1'From Pharo1.0beta of 16 May 2008 [Latest update: #10487] on 19 October 2009 at 4:57:33 pm'! 2BracketSliderMorph subclass: #AColorSelectorMorph 3 instanceVariableNames: '' 4 classVariableNames: '' 5 poolDictionaries: '' 6 category: 'Polymorph-Widgets'! 7!AColorSelectorMorph commentStamp: 'gvc 5/18/2007 13:52' prior: 0! 8ColorComponentSelector showing an alpha gradient over a hatched background.! 9 10 11!AColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/3/2009 13:43'! 12color: aColor 13 "Set the gradient colors." 14 15 super color: aColor asNontranslucentColor. 16 self fillStyle: self defaultFillStyle! ! 17 18 19!AColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:43'! 20defaultFillStyle 21 "Answer the hue gradient." 22 23 ^(GradientFillStyle colors: {self color alpha: 0. self color}) 24 origin: self topLeft; 25 direction: (self bounds isWide 26 ifTrue: [self width@0] 27 ifFalse: [0@self height])! ! 28 29!AColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:17'! 30hatchForm 31 "Answer a form showing a grid hatch pattern." 32 33 ^ColorPresenterMorph hatchForm! ! 34 35 36!AColorSelectorMorph methodsFor: 'drawing' stamp: 'gvc 9/19/2006 14:28'! 37drawOn: aCanvas 38 "Draw a hatch pattern first." 39 40 aCanvas 41 fillRectangle: self innerBounds 42 fillStyle: (InfiniteForm with: self hatchForm). 43 super drawOn: aCanvas 44! ! 45 46 47!AColorSelectorMorph methodsFor: 'initialization' stamp: 'gvc 9/26/2006 11:54'! 48initialize 49 "Initialize the receiver." 50 51 super initialize. 52 self 53 value: 1.0; 54 color: Color black! ! 55 56 57!AColorSelectorMorph methodsFor: 'visual properties' stamp: 'gvc 9/19/2006 15:46'! 58fillStyle: fillStyle 59 "If it is a color then override with gradient." 60 61 fillStyle isColor 62 ifTrue: [self color: fillStyle] 63 ifFalse: [super fillStyle: fillStyle]! ! 64TestCase subclass: #ATestCase 65 instanceVariableNames: '' 66 classVariableNames: '' 67 poolDictionaries: '' 68 category: 'Tests-Traits'! 69 70!ATestCase methodsFor: 'as yet unclassified' stamp: 'oscar.nierstrasz 10/18/2009 14:59'! 71testRequirement 72 " 73 self debug: #testRequirement 74 " 75 | class | 76 class := Object 77 subclass: #AClassForTest 78 instanceVariableNames: '' 79 classVariableNames: '' 80 poolDictionaries: '' 81 category: self class category. 82 [ 83 class compile: 'call 84 ^ self isCalled'. 85 self assert: (class requiredSelectors includes: #isCalled). 86 87 88 class compile: 'isCalled 89 ^ 1'. 90 "Fail here:" 91 self deny: (class requiredSelectors includes: #isCalled)] 92 93 ensure: [class removeFromSystem. 94 RequiredSelectors current clearOut: class ] ! ! 95Exception subclass: #Abort 96 instanceVariableNames: '' 97 classVariableNames: '' 98 poolDictionaries: '' 99 category: 'Exceptions-Kernel'! 100 101!Abort methodsFor: 'as yet unclassified' stamp: 'ajh 3/24/2003 00:55'! 102defaultAction 103 "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" 104 105 UnhandledError signalForException: self! ! 106DialogWindow subclass: #AboutDialogWindow 107 instanceVariableNames: '' 108 classVariableNames: '' 109 poolDictionaries: '' 110 category: 'Polymorph-Widgets-Windows'! 111!AboutDialogWindow commentStamp: 'gvc 5/18/2007 13:53' prior: 0! 112Default superclass for application about dialogs.! 113 114 115!AboutDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 16:32'! 116newButtons 117 "Answer new buttons as appropriate." 118 119 ^{self newCloseButton isDefault: true}! ! 120Object subclass: #AbstractEvent 121 instanceVariableNames: 'item itemKind environment' 122 classVariableNames: '' 123 poolDictionaries: '' 124 category: 'System-Change Notification'! 125 126!AbstractEvent methodsFor: 'accessing' stamp: 'rw 6/30/2003 08:22'! 127item 128 "Return the item that triggered the event (typically the name of a class, a category, a protocol, a method)." 129 130 ^item! ! 131 132!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:43'! 133itemCategory 134 135 ^self environmentAt: self class categoryKind! ! 136 137!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:43'! 138itemClass 139 140 ^self environmentAt: self class classKind! ! 141 142!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/14/2003 12:10'! 143itemExpression 144 145 ^self environmentAt: self class expressionKind! ! 146 147!AbstractEvent methodsFor: 'accessing' stamp: 'rw 6/30/2003 08:22'! 148itemKind 149 "Return the kind of the item of the event (#category, #class, #protocol, #method, ...)" 150 151 ^itemKind! ! 152 153!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:44'! 154itemMethod 155 156 ^self environmentAt: self class methodKind! ! 157 158!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:44'! 159itemProtocol 160 161 ^self environmentAt: self class protocolKind! ! 162 163!AbstractEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 10:38'! 164itemRequestor 165 166 ^self environmentAt: #requestor! ! 167 168!AbstractEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 10:38'! 169itemSelector 170 171 ^self environmentAt: #selector! ! 172 173 174!AbstractEvent methodsFor: 'printing' stamp: 'NS 1/19/2004 17:52'! 175printOn: aStream 176 177 self printEventKindOn: aStream. 178 aStream 179 nextPutAll: ' Event for item: '; 180 print: self item; 181 nextPutAll: ' of kind: '; 182 print: self itemKind! ! 183 184 185!AbstractEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:34'! 186isAdded 187 188 ^false! ! 189 190!AbstractEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 18:41'! 191isCategoryKnown 192 193 ^self itemCategory notNil! ! 194 195!AbstractEvent methodsFor: 'testing' stamp: 'rw 7/10/2003 15:01'! 196isCommented 197 198 ^false! ! 199 200!AbstractEvent methodsFor: 'testing' stamp: 'rw 7/14/2003 10:15'! 201isDoIt 202 203 ^false! ! 204 205!AbstractEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 15:09'! 206isModified 207 208 ^false! ! 209 210!AbstractEvent methodsFor: 'testing' stamp: 'NS 1/21/2004 09:40'! 211isProtocolKnown 212 213 ^self itemCategory notNil! ! 214 215!AbstractEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 19:53'! 216isRecategorized 217 218 ^false! ! 219 220!AbstractEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:34'! 221isRemoved 222 223 ^false! ! 224 225!AbstractEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:35'! 226isRenamed 227 228 ^false! ! 229 230!AbstractEvent methodsFor: 'testing' stamp: 'NS 1/27/2004 12:44'! 231isReorganized 232 ^ false! ! 233 234 235!AbstractEvent methodsFor: 'triggering' stamp: 'rw 7/14/2003 17:06'! 236trigger: anEventManager 237 "Trigger the event manager." 238 239 anEventManager triggerEvent: self eventSelector with: self.! ! 240 241 242!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:10'! 243changeKind 244 245 ^self class changeKind! ! 246 247!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:43'! 248environmentAt: anItemKind 249 250 (self itemKind = anItemKind) ifTrue: [^self item]. 251 ^environment at: anItemKind ifAbsent: [nil]! ! 252 253!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:20'! 254eventSelector 255 256 ^self class eventSelectorBlock value: itemKind value: self changeKind! ! 257 258!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:36'! 259item: anItem kind: anItemKind 260 261 item := anItem. 262 itemKind := anItemKind. 263 environment := Dictionary new! ! 264 265!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:37'! 266itemCategory: aCategory 267 268 environment at: self class categoryKind put: aCategory! ! 269 270!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:36'! 271itemClass: aClass 272 273 environment at: self class classKind put: aClass! ! 274 275!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/14/2003 12:11'! 276itemExpression: anExpression 277 278 environment at: self class expressionKind put: anExpression! ! 279 280!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:38'! 281itemMethod: aMethod 282 283 environment at: self class methodKind put: aMethod! ! 284 285!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:38'! 286itemProtocol: aProtocol 287 288 environment at: self class protocolKind put: aProtocol! ! 289 290!AbstractEvent methodsFor: 'private-accessing' stamp: 'NS 1/27/2004 10:38'! 291itemRequestor: requestor 292 293 environment at: #requestor put: requestor! ! 294 295!AbstractEvent methodsFor: 'private-accessing' stamp: 'NS 1/27/2004 10:39'! 296itemSelector: aSymbol 297 298 environment at: #selector put: aSymbol! ! 299 300"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 301 302AbstractEvent class 303 instanceVariableNames: ''! 304 305!AbstractEvent class methodsFor: 'accessing' stamp: 'NS 1/16/2004 14:08'! 306allChangeKinds 307 "AbstractEvent allChangeKinds" 308 309 ^AbstractEvent allSubclasses collect: [:cl | cl changeKind]! ! 310 311!AbstractEvent class methodsFor: 'accessing' stamp: 'bvs 7/20/2004 12:12'! 312allItemKinds 313 "self allItemKinds" 314 315 ^(AbstractEvent class organization listAtCategoryNamed: #'item kinds') 316 collect: [:sel | self perform: sel]! ! 317 318!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:08'! 319changeKind 320 "Return a symbol, with a : as last character, identifying the change kind." 321 322 self subclassResponsibility! ! 323 324!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:18'! 325eventSelectorBlock 326 327 ^[:itemKind :changeKind | itemKind, changeKind, 'Event:']! ! 328 329!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:19'! 330itemChangeCombinations 331 332 ^self supportedKinds collect: [:itemKind | self eventSelectorBlock value: itemKind value: self changeKind]! ! 333 334!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:04'! 335supportedKinds 336 "All the kinds of items that this event can take. By default this is all the kinds in the system. But subclasses can override this to limit the choices. For example, the SuperChangedEvent only works with classes, and not with methods, instance variables, ..." 337 338 ^self allItemKinds! ! 339 340!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 11:39'! 341systemEvents 342 "Return all the possible events in the system. Make a cross product of 343 the items and the change types." 344 "self systemEvents" 345 346 ^self allSubclasses 347 inject: OrderedCollection new 348 into: [:allEvents :eventClass | allEvents addAll: eventClass itemChangeCombinations; yourself]! ! 349 350 351!AbstractEvent class methodsFor: 'instance creation' stamp: 'ab 2/10/2005 16:32'! 352classCategory: aName 353 ^ self item: aName kind: AbstractEvent categoryKind.! ! 354 355!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 18:42'! 356class: aClass 357 ^ self item: aClass kind: AbstractEvent classKind.! ! 358 359!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 18:42'! 360class: aClass category: cat 361 | instance | 362 instance := self class: aClass. 363 instance itemCategory: cat. 364 ^instance! ! 365 366!AbstractEvent class methodsFor: 'instance creation' stamp: 'rw 7/9/2003 11:19'! 367item: anItem kind: anItemKind 368 369 ^self basicNew item: anItem kind: anItemKind! ! 370 371!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/16/2004 14:19'! 372method: aMethod class: aClass 373 374 | instance | 375 instance := self item: aMethod kind: self methodKind. 376 instance itemClass: aClass. 377 ^instance! ! 378 379!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/16/2004 14:20'! 380method: aMethod protocol: prot class: aClass 381 382 | instance | 383 instance := self method: aMethod class: aClass. 384 instance itemProtocol: prot. 385 ^instance! ! 386 387!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:48'! 388method: aMethod selector: aSymbol class: aClass 389 390 | instance | 391 instance := self item: aMethod kind: self methodKind. 392 instance itemSelector: aSymbol. 393 instance itemClass: aClass. 394 ^instance! ! 395 396!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:49'! 397method: aMethod selector: aSymbol class: aClass requestor: requestor 398 399 | instance | 400 instance := self method: aMethod selector: aSymbol class: aClass. 401 instance itemRequestor: requestor. 402 ^instance! ! 403 404!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:49'! 405method: aMethod selector: aSymbol protocol: prot class: aClass 406 407 | instance | 408 instance := self method: aMethod selector: aSymbol class: aClass. 409 instance itemProtocol: prot. 410 ^instance! ! 411 412!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:50'! 413method: aMethod selector: aSymbol protocol: prot class: aClass requestor: requestor 414 415 | instance | 416 instance := self method: aMethod selector: aSymbol protocol: prot class: aClass. 417 instance itemRequestor: requestor. 418 ^instance! ! 419 420!AbstractEvent class methodsFor: 'instance creation' stamp: 'rw 6/30/2003 09:20'! 421new 422 "Override new to trigger an error, since we want to use specialized methods to create basic and higher-level events." 423 424 ^self error: 'Instances can only be created using specialized instance creation methods.'! ! 425 426 427!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'! 428categoryKind 429 430 ^#category! ! 431 432!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'! 433classKind 434 435 ^#class! ! 436 437!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/14/2003 11:41'! 438expressionKind 439 440 ^#expression! ! 441 442!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'! 443methodKind 444 445 ^#method! ! 446 447!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/10/2003 12:36'! 448protocolKind 449 450 ^#protocol! ! 451 452 453!AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 10:23'! 454comment1 455 456"Smalltalk organization removeElement: #ClassForTestingSystemChanges3 457Smalltalk garbageCollect 458Smalltalk organizati 459 460classify:under: 461 462 463SystemChangeNotifier uniqueInstance releaseAll 464SystemChangeNotifier uniqueInstance noMoreNotificationsFor: aDependent. 465 466 467aDependent := SystemChangeNotifierTest new. 468SystemChangeNotifier uniqueInstance 469 notifyOfAllSystemChanges: aDependent 470 using: #event: 471 472SystemChangeNotifier uniqueInstance classAdded: #Foo inCategory: #FooCat 473 474 475 476| eventSource dependentObject | 477eventSource := EventManager new. 478dependentObject := Object new. 479 480register - dependentObject becomes dependent: 481eventSource 482 when: #anEvent send: #error to: dependentObject. 483 484unregister dependentObject: 485eventSource removeDependent: dependentObject. 486 487[eventSource triggerEvent: #anEvent] 488 on: Error 489 do: [:exc | self halt: 'Should not be!!']."! ! 490 491!AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 10:24'! 492comment2 493 494"HTTPSocket useProxyServerNamed: 'proxy.telenet.be' port: 8080 495TestRunner open 496 497-------------------- 498We propose two orthogonal groups to categorize each event: 499(1) the 'change type': 500 added, removed, modified, renamed 501 + the composite 'changed' (see below for an explanation) 502(2) the 'item type': 503 class, method, instance variable, pool variable, protocol, category 504 + the composite 'any' (see below for an explanation). 505The list of supported events is the cross product of these two lists (see below for an explicit enumeration of the events). 506 507Depending on the change type, certain information related to the change is always present (for adding, the new things that was added, for removals, what was removed, for renaming, the old and the new name, etc.). 508 509Depending on the item type, information regarding the item is present (for a method, which class it belongs to). 510 511Certain events 'overlap', for example, a method rename triggers a class change. To capture this I impose a hierarchy on the 'item types' (just put some numbers to clearly show the idea. They don't need numbers, really. Items at a certain categories are included by items one category number higher): 512level 1 category 513level 2 class 514level 3 instance variable, pool variable, protocol, method. 515 516Changes propagate according to this tree: any 'added', 'removed' or 'renamed' change type in level X triggers a 'changed' change type in level X - 1. A 'modified' change type does not trigger anything special. 517For example, a method additions triggers a class modification. This does not trigger a category modification. 518 519Note that we added 'composite events': wildcards for the 'change type' ('any' - any system additions) and for the 'item type' ('Changed' - all changes related to classes), and one for 'any change systemwide' (systemChanged). 520 521This result is this list of Events: 522 523classAdded 524classRemoved 525classModified 526classRenamed (?) 527classChanged (composite) 528 529methodAdded 530methodRemoved 531methodModified 532methodRenamed (?) 533methodChanged (composite) 534 535instanceVariableAdded 536instanceVariableRemoved 537instanceVariableModified 538instanceVariableRenamed (?) 539instanceVariableChanged (composite) 540 541protocolAdded 542protocolRemoved 543protocolModified 544protocolRenamed (?) 545protocolChanged (composite) 546 547poolVariableAdded 548poolVariableRemoved 549poolVariableModified 550poolVariableRenamed (?) 551poolChanged (composite) 552 553categoryAdded 554categoryRemoved 555categoryModified 556categeryRenamed (?) 557categoryChanged (composite) 558 559anyAdded (composite) 560anyRemoved (composite) 561anyModified (composite) 562anyRenamed (composite) 563 564anyChanged (composite) 565 566 567 568To check: can we pass somehow the 'source' of the change (a browser, a file-in, something else) ? Maybe by checking the context, but should not be too expensive either... I found this useful in some of my tools, but it might be too advanced to have in general. Tools that need this can always write code to check it for them. But is not always simple... 569 570 571Utilities (for the recent methods) and ChangeSet are the two main clients at this moment. 572 573Important: make it very explicit that the event is send synchronously (or asynchronously, would we take that route). 574 575 576 category 577 class 578 comment 579 protocol 580 method 581OR 582 category 583 Smalltalk 584 class 585 comment 586 protocol 587 method 588?? 589 590 591 592 Smalltalk category 593 \ / 594 class 595 / | \ 596 comment | protocol 597 | / 598 method 599 600"! ! 601 602!AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 15:43'! 603comment3 604 605"Things to consider for trapping: 606ClassOrganizer>>#changeFromCategorySpecs: 607 Problem: I want to trap this to send the appropriate bunch of ReCategorization events, but ClassOrganizer instances do not know where they belong to (what class, or what system); it just uses symbols. So I cannot trigger the change, because not enough information is available. This is a conceptual problem: the organization is stand-alone implementation-wise, while conceptually it belongs to a class. The clean solution could be to reroute this message to a class, but this does not work for all of the senders (that would work from the browserm but not for the file-in). 608 609Browser>>#categorizeAllUncategorizedMethods 610 Problem: should be trapped to send a ReCategorization event. However, this is model code that should not be in the Browser. Clean solution is to move it out of there to the model, and then trap it there (or reroute it to one of the trapped places). 611 612Note: Debugger>>#contents:notifying: recompiles methods when needed, so I trapped it to get updates. However, I need to find a way to write a unit test for this. Haven't gotten around yet for doing this though... 613"! ! 614Object subclass: #AbstractFont 615 instanceVariableNames: '' 616 classVariableNames: '' 617 poolDictionaries: '' 618 category: 'Graphics-Fonts'! 619!AbstractFont commentStamp: '<historical>' prior: 0! 620AbstractFont defines the generic interface that all fonts need to implement.! 621 622 623!AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 7/29/2006 14:36'! 624displayStrikeoutOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint 625 "display the strikeout if appropriate for the receiver"! ! 626 627!AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 7/29/2006 13:51'! 628displayUnderlineOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint 629 "display the underline if appropriate for the receiver"! ! 630 631!AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 8/10/2006 07:16'! 632emphasisString 633 "Answer a translated string that represents the receiver's emphasis." 634 635 ^self emphasisStringFor: self emphasis! ! 636 637!AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 8/10/2006 07:13'! 638emphasisStringFor: emphasisCode 639 "Answer a translated string that represents the attributes given in emphasisCode." 640 641 ^self class emphasisStringFor: emphasisCode! ! 642 643!AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:43'! 644hasDistinctGlyphsForAll: asciiString 645 "Answer true if the receiver has glyphs for all the characters 646 in asciiString and no single glyph is shared by more than one character, false otherwise. 647 The default behaviour is to answer true, but subclasses may reimplement" 648 649 ^true! ! 650 651!AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:25'! 652hasGlyphsForAll: asciiString 653 "Answer true if the receiver has glyphs for all the characters 654 in asciiString, false otherwise. 655 The default behaviour is to answer true, but subclasses may reimplement" 656 657 ^true! ! 658 659!AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 4/6/2007 12:58'! 660isSubPixelPositioned 661 "Answer true if the receiver is currently using subpixel positioned 662 glyphs, false otherwise. This affects how padded space sizes are calculated 663 when composing text. 664 Currently, only FreeTypeFonts are subPixelPositioned, and only when not 665 Hinted" 666 667 ^false ! ! 668 669!AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:32'! 670isSymbolFont 671 "Answer true if the receiver is a Symbol font, false otherwise. 672 The default is to answer false, subclasses can reimplement" 673 674 ^false! ! 675 676!AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/10/2007 13:08'! 677kerningLeft: leftChar right: rightChar 678 ^0! ! 679 680!AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/31/2007 20:17'! 681linearWidthOf: aCharacter 682 "This is the scaled, unrounded advance width." 683 ^self widthOf: aCharacter! ! 684 685!AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 4/3/2007 16:47'! 686widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray 687 "Set the first element of aTwoElementArray to the width of leftCharacter and 688 the second element to the width of left character when kerned with 689 rightCharacterOrNil. Answer aTwoElementArray" 690 | w k | 691 w := self widthOf: leftCharacter. 692 rightCharacterOrNil isNil 693 ifTrue:[ 694 aTwoElementArray 695 at: 1 put: w; 696 at: 2 put: w] 697 ifFalse:[ 698 k := self kerningLeft: leftCharacter right: rightCharacterOrNil. 699 aTwoElementArray 700 at: 1 put: w; 701 at: 2 put: w+k]. 702 ^aTwoElementArray 703 ! ! 704 705 706!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'! 707ascent 708 709 self subclassResponsibility. 710! ! 711 712!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'! 713ascentOf: aCharacter 714 715 ^ self ascent. 716! ! 717 718!AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:06'! 719baseKern 720 ^0! ! 721 722!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'! 723basicAscentOf: aCharacter 724 725 ^ self ascent. 726! ! 727 728!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'! 729basicDescentOf: aCharacter 730 731 ^ self descent. 732! ! 733 734!AbstractFont methodsFor: 'accessing' stamp: 'ar 5/19/2000 14:56'! 735characterToGlyphMap 736 "Return the character to glyph mapping table. If the table is not provided the character scanner will query the font directly for the width of each individual character." 737 ^nil! ! 738 739!AbstractFont methodsFor: 'accessing' stamp: 'nk 3/15/2004 18:57'! 740derivativeFonts 741 ^#()! ! 742 743!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'! 744descent 745 746 self subclassResponsibility. 747! ! 748 749!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'! 750descentOf: aCharacter 751 752 ^ self descent. 753! ! 754 755!AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:15'! 756familyName 757 "Answer the name to be used as a key in the TextConstants dictionary." 758 ^self subclassResponsibility! ! 759 760!AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'! 761height 762 "Answer the height of the receiver, total of maximum extents of 763 characters above and below the baseline." 764 765 ^self subclassResponsibility! ! 766 767!AbstractFont methodsFor: 'accessing' stamp: 'nk 5/26/2003 09:45'! 768isRegular 769 ^false! ! 770 771!AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'! 772lineGrid 773 "Answer the relative space between lines" 774 775 ^self subclassResponsibility! ! 776 777!AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:33'! 778pixelSize 779 "Make sure that we don't return a Fraction" 780 ^ TextStyle pointsToPixels: self pointSize! ! 781 782!AbstractFont methodsFor: 'accessing' stamp: 'nk 4/1/2004 10:48'! 783pointSize 784 self subclassResponsibility.! ! 785 786!AbstractFont methodsFor: 'accessing' stamp: 'nk 7/11/2004 21:15'! 787textStyle 788 ^ TextStyle actualTextStyles detect: 789 [:aStyle | aStyle fontArray includes: self] ifNone: [ TextStyle fontArray: { self } ]! ! 790 791!AbstractFont methodsFor: 'accessing' stamp: 'nk 3/22/2004 15:15'! 792textStyleName 793 "Answer the name to be used as a key in the TextConstants dictionary." 794 ^self familyName! ! 795 796!AbstractFont methodsFor: 'accessing' stamp: 'ar 5/19/2000 14:57'! 797xTable 798 "Return the xTable for the font. The xTable defines the left x-value for each individual glyph in the receiver. If such a table is not provided, the character scanner will ask the font directly for the appropriate width of each individual character." 799 ^nil! ! 800 801 802!AbstractFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:47'! 803releaseCachedState 804 ! ! 805 806 807!AbstractFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 14:59'! 808displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta 809 "Draw the given string from startIndex to stopIndex 810 at aPoint on the (already prepared) display context." 811 ^self subclassResponsibility! ! 812 813!AbstractFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:36'! 814displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY 815 "Draw the given string from startIndex to stopIndex 816 at aPoint on the (already prepared) display context." 817 ^self subclassResponsibility! ! 818 819!AbstractFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 14:59'! 820installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor 821 "Install the receiver on the given DisplayContext (either BitBlt or Canvas) for further drawing operations." 822 ^self subclassResponsibility! ! 823 824 825!AbstractFont methodsFor: 'measuring' stamp: 'lr 7/4/2009 10:42'! 826approxWidthOfText: aText 827 "Return the width of aText -- quickly, and a little bit dirty. Used by lists morphs containing Text objects to get a quick, fairly accurate measure of the width of a list item." 828 | w | 829 (aText isNil or: [ aText size == 0 ]) ifTrue: [ ^ 0 ]. 830 w := self widthOfString: aText asString. 831 832 "If the text has no emphasis, just return the string size. If it is empasized, 833 just approximate the width by adding about 20% to the width" 834 ((aText runLengthFor: 1) == aText size and: [ (aText emphasisAt: 1) == 0 ]) 835 ifTrue: [ ^ w ] 836 ifFalse: [ ^ w * 6 // 5 ]! ! 837 838!AbstractFont methodsFor: 'measuring' stamp: 'ar 5/19/2000 14:58'! 839widthOf: aCharacter 840 "Return the width of the given character" 841 ^self subclassResponsibility! ! 842 843!AbstractFont methodsFor: 'measuring' stamp: 'ar 12/31/2001 14:25'! 844widthOfString: aString 845 aString ifNil:[^0]. 846 ^self widthOfString: aString from: 1 to: aString size. 847" 848 TextStyle default defaultFont widthOfString: 'zort' 21 849"! ! 850 851!AbstractFont methodsFor: 'measuring' stamp: 'lr 7/4/2009 10:42'! 852widthOfString: aString from: startIndex to: stopIndex 853 "Measure the length of the given string between start and stop index" 854 | character resultX | 855 resultX := 0. 856 startIndex 857 to: stopIndex 858 do: 859 [ :i | 860 character := aString at: i. 861 resultX := resultX + (self widthOf: character) ]. 862 ^ resultX! ! 863 864!AbstractFont methodsFor: 'measuring' stamp: 'sps 3/23/2004 15:50'! 865widthOfStringOrText: aStringOrText 866 aStringOrText ifNil:[^0]. 867 ^aStringOrText isText 868 ifTrue:[self approxWidthOfText: aStringOrText ] 869 ifFalse:[self widthOfString: aStringOrText ] ! ! 870 871 872!AbstractFont methodsFor: 'notifications' stamp: 'nk 4/2/2004 11:25'! 873pixelsPerInchChanged 874 "The definition of TextStyle class>>pixelsPerInch has changed. Do whatever is necessary."! ! 875 876 877!AbstractFont methodsFor: 'testing' stamp: 'yo 2/12/2007 19:34'! 878isFontSet 879 880 ^ false. 881! ! 882 883!AbstractFont methodsFor: 'testing' stamp: 'nk 6/25/2003 12:54'! 884isTTCFont 885 ^false! ! 886 887"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 888 889AbstractFont class 890 instanceVariableNames: ''! 891 892!AbstractFont class methodsFor: 'as yet unclassified' stamp: 'eem 6/11/2008 12:35'! 893emphasisStringFor: emphasisCode 894 "Answer a translated string that represents the attributes given in emphasisCode." 895 896 | emphases | 897 emphasisCode = 0 ifTrue: [ ^'Normal' translated ]. 898 899 emphases := (IdentityDictionary new) 900 at: 1 put: 'Bold' translated; 901 at: 2 put: 'Italic' translated; 902 at: 4 put: 'Underlined' translated; 903 at: 8 put: 'Narrow' translated; 904 at: 16 put: 'StruckOut' translated; 905 yourself. 906 907 ^String streamContents: [ :s | | bit | 908 bit := 1. 909 [ bit < 32 ] whileTrue: [ | code | 910 code := emphasisCode bitAnd: bit. 911 code isZero ifFalse: [ s nextPutAll: (emphases at: code); space ]. 912 bit := bit bitShift: 1 ]. 913 s position isZero ifFalse: [ s skip: -1 ]. 914 ]! ! 915DialogWindow subclass: #AbstractFontSelectorDialogWindow 916 instanceVariableNames: 'fontFamilies selectedFont textPreviewMorph fontFamilyIndex fontSizeIndex isBold isItalic isUnderlined isStruckOut previewText' 917 classVariableNames: '' 918 poolDictionaries: '' 919 category: 'Polymorph-Widgets-Windows'! 920!AbstractFontSelectorDialogWindow commentStamp: 'gvc 5/18/2007 13:04' prior: 0! 921Dialog based font chooser with preview.! 922 923 924!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:40'! 925fontFamilies 926 "Answer the set of available fonts families that are supported as Text objects 927 in the font that they represent." 928 929 ^fontFamilies ifNil: [ 930 self fontFamilies: self defaultFontFamilies. 931 fontFamilies]! ! 932 933!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:02'! 934fontFamilies: anObject 935 "Set the value of fontFamilies" 936 937 fontFamilies := anObject! ! 938 939!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 14:30'! 940fontFamilyIndex 941 "Answer the value of fontFamilyIndex" 942 943 ^ fontFamilyIndex! ! 944 945!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:19'! 946fontFamilyIndex: anObject 947 "Set the value of fontFamilyIndex" 948 949 fontFamilyIndex := anObject. 950 self updateSelectedFont! ! 951 952!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 14:30'! 953fontSizeIndex 954 "Answer the value of fontSizeIndex" 955 956 ^ fontSizeIndex! ! 957 958!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:19'! 959fontSizeIndex: anObject 960 "Set the value of fontSizeIndex" 961 962 fontSizeIndex := anObject. 963 self updateSelectedFont! ! 964 965!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! 966isBold 967 "Answer the value of isBold" 968 969 ^ isBold! ! 970 971!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! 972isBold: anObject 973 "Set the value of isBold" 974 975 isBold := anObject. 976 self changed: #isBold! ! 977 978!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! 979isItalic 980 "Answer the value of isItalic" 981 982 ^ isItalic! ! 983 984!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! 985isItalic: anObject 986 "Set the value of isItalic" 987 988 isItalic := anObject. 989 self changed: #isItalic! ! 990 991!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! 992isStruckOut 993 "Answer the value of isStruckOut" 994 995 ^ isStruckOut! ! 996 997!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! 998isStruckOut: anObject 999 "Set the value of isStruckOut" 1000 1001 isStruckOut := anObject. 1002 self changed: #isStruckOut! ! 1003 1004!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! 1005isUnderlined 1006 "Answer the value of isUnderlined" 1007 1008 ^ isUnderlined! ! 1009 1010!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! 1011isUnderlined: anObject 1012 "Set the value of isUnderlined" 1013 1014 isUnderlined := anObject. 1015 self changed: #isUnderlined! ! 1016 1017!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:30'! 1018previewText 1019 "Answer the value of previewText" 1020 1021 ^previewText asText addAttribute: (TextEmphasis new emphasisCode: self textEmphasisCode)! ! 1022 1023!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/18/2007 13:07'! 1024previewText: anObject 1025 "Set the value of previewText" 1026 1027 previewText := anObject. 1028 self changed: #previewText! ! 1029 1030!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! 1031selectedFont 1032 "Answer the value of selectedFont" 1033 1034 ^ selectedFont! ! 1035 1036!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 10/9/2007 14:19'! 1037selectedFont: anObject 1038 "Set the value of selectedFont" 1039 1040 selectedFont := anObject ifNil: [TextStyle defaultFont]. 1041 self updateFromSelectedFont! ! 1042 1043!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! 1044textPreviewMorph 1045 "Answer the value of textPreviewMorph" 1046 1047 ^ textPreviewMorph! ! 1048 1049!AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! 1050textPreviewMorph: anObject 1051 "Set the value of textPreviewMorph" 1052 1053 textPreviewMorph := anObject! ! 1054 1055 1056!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:49'! 1057defaultFontFamilies 1058 "Answer the set of available fonts families that are supported in the font that they represent." 1059 1060 self subclassResponsibility! ! 1061 1062!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:31'! 1063defaultPreviewText 1064 "Answer the default text to use for the preview of the font." 1065 1066 ^(33 to: 127) asByteArray asString! ! 1067 1068!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:47'! 1069familyName 1070 "Answer the selected family name or nil if none." 1071 1072 (self fontFamilyIndex between: 1 and: self fontFamilies size) 1073 ifFalse: [^nil]. 1074 ^(self fontFamilies at: self fontFamilyIndex) asString! ! 1075 1076!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 16:03'! 1077fontSize 1078 "Answer the selected font size or nil if none." 1079 1080 (self fontSizeIndex between: 1 and: self fontSizes size) 1081 ifFalse: [^nil]. 1082 ^self fontSizes at: self fontSizeIndex! ! 1083 1084!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 14:31'! 1085fontSizes 1086 "Answer the set of available fonts sizes that are supported." 1087 1088 ^#(6 7 8 9 10 11 12 13 14 15 16 18 20 21 22 24 26 28 32 36 48)! ! 1089 1090!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:22'! 1091initialize 1092 "Initialize the receiver." 1093 1094 self 1095 isBold: false; 1096 isItalic: false; 1097 isUnderlined: false; 1098 isStruckOut: false; 1099 previewText: self defaultPreviewText; 1100 fontFamilyIndex: 0; 1101 fontSizeIndex: 0. 1102 super initialize! ! 1103 1104!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/16/2007 13:43'! 1105isFreeTypeInstalled 1106 "Answer whether FreeType appears to be installed." 1107 1108 ^Smalltalk includesKey: #FreeTypeFont! ! 1109 1110!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:35'! 1111matchingFont 1112 "Answer the font that matches the selections." 1113 1114 self subclassResponsibility! ! 1115 1116!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! 1117newBoldButtonMorph 1118 "Answer a button for the boldness of the font." 1119 1120 ^self 1121 newButtonFor: self 1122 getState: #isBold 1123 action: #toggleBold 1124 arguments: nil 1125 getEnabled: nil 1126 labelForm: self theme smallBoldIcon 1127 help: 'Toggle bold font' translated! ! 1128 1129!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:48'! 1130newContentMorph 1131 "Answer a new content morph." 1132 1133 self textPreviewMorph: self newTextPreviewMorph. 1134 ^(self newColumn: { 1135 (self newRow: { 1136 self newGroupbox: 'Family' translated for: 1137 self newFontFamilyMorph. 1138 (self newColumn: { 1139 (self newGroupbox: 'Style' translated for: 1140 self newFontStyleButtonRowMorph) 1141 vResizing: #shrinkWrap. 1142 self newGroupbox: 'Point size' translated for: 1143 self newFontSizeMorph}) 1144 hResizing: #shrinkWrap}) 1145 vResizing: #spaceFill. 1146 (self newGroupbox: 'Preview' translated for: 1147 self textPreviewMorph) 1148 vResizing: #shrinkWrap}) 1149 minWidth: 350; 1150 minHeight: 400! ! 1151 1152!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:49'! 1153newFontFamilyMorph 1154 "Answer a list for the font family of the font." 1155 1156 |highestFont| 1157 highestFont := self fontFamilies first fontAt: 1 withStyle: TextStyle default. 1158 self fontFamilies do: [:ff | |f| 1159 f := ff fontAt: 1 withStyle: TextStyle default. 1160 f height > highestFont height 1161 ifTrue: [highestFont := f]]. 1162 ^(self 1163 newListFor: self 1164 list: #fontFamilies 1165 selected: #fontFamilyIndex 1166 changeSelected: #fontFamilyIndex: 1167 help: nil) 1168 font: highestFont! ! 1169 1170!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:49'! 1171newFontSizeMorph 1172 "Answer a list for the font size of the font." 1173 1174 ^self 1175 newListFor: self 1176 list: #fontSizes 1177 selected: #fontSizeIndex 1178 changeSelected: #fontSizeIndex: 1179 help: nil! ! 1180 1181!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:48'! 1182newFontStyleButtonRowMorph 1183 "Answer a new font style button row morph." 1184 1185 ^self newRow: { 1186 self newBoldButtonMorph. 1187 self newItalicButtonMorph. 1188 self newUnderlinedButtonMorph. 1189 self newStruckOutButtonMorph}! ! 1190 1191!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! 1192newItalicButtonMorph 1193 "Answer a button for the italic emphasis of the font." 1194 1195 ^self 1196 newButtonFor: self 1197 getState: #isItalic 1198 action: #toggleItalic 1199 arguments: nil 1200 getEnabled: nil 1201 labelForm: self theme smallItalicIcon 1202 help: 'Toggle italic font' translated! ! 1203 1204!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! 1205newStruckOutButtonMorph 1206 "Answer a button for the struck out emphasis of the font." 1207 1208 ^self 1209 newButtonFor: self 1210 getState: #isStruckOut 1211 action: #toggleStruckOut 1212 arguments: nil 1213 getEnabled: nil 1214 labelForm: self theme smallStrikeOutIcon 1215 help: 'Toggle struck-out font' translated! ! 1216 1217!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 16:31'! 1218newTextPreviewMorph 1219 "Answer a text entry morph for the preview of the font." 1220 1221 ^(self 1222 newTextEditorFor: self 1223 getText: #previewText 1224 setText: nil 1225 getEnabled: nil) 1226 vResizing: #rigid; 1227 enabled: false; 1228 extent: 20@90! ! 1229 1230!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! 1231newUnderlinedButtonMorph 1232 "Answer a button for the italic emphasis of the font." 1233 1234 ^self 1235 newButtonFor: self 1236 getState: #isUnderlined 1237 action: #toggleUnderlined 1238 arguments: nil 1239 getEnabled: nil 1240 labelForm: self theme smallUnderlineIcon 1241 help: 'Toggle underlined font' translated! ! 1242 1243!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:33'! 1244textEmphasisCode 1245 "Answer the current bitmask for the text emphasis." 1246 1247 ^(((self isBold ifTrue: [1] ifFalse: [0]) bitOr: 1248 (self isItalic ifTrue: [2] ifFalse: [0])) bitOr: 1249 (self isUnderlined ifTrue: [4] ifFalse: [0])) bitOr: 1250 (self isStruckOut ifTrue: [16] ifFalse: [0])! ! 1251 1252!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! 1253toggleBold 1254 "Toggle the font bold emphasis." 1255 1256 self isBold: self isBold not. 1257 self updateSelectedFont! ! 1258 1259!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! 1260toggleItalic 1261 "Toggle the font italic emphasis." 1262 1263 self isItalic: self isItalic not. 1264 self updateSelectedFont! ! 1265 1266!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! 1267toggleStruckOut 1268 "Toggle the font struck out emphasis." 1269 1270 self isStruckOut: self isStruckOut not. 1271 self updateSelectedFont! ! 1272 1273!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! 1274toggleUnderlined 1275 "Toggle the font underlined emphasis." 1276 1277 self isUnderlined: self isUnderlined not. 1278 self updateSelectedFont! ! 1279 1280!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:21'! 1281updateFromSelectedFont 1282 "Update our state based on the selected font." 1283 1284 self subclassResponsibility! ! 1285 1286!AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/4/2007 10:25'! 1287updateSelectedFont 1288 "Update the selected font to reflect the choices." 1289 1290 self selectedFont: self matchingFont! ! 1291 1292"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 1293 1294AbstractFontSelectorDialogWindow class 1295 instanceVariableNames: ''! 1296 1297!AbstractFontSelectorDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/21/2007 12:42'! 1298taskbarIcon 1299 "Answer the icon for the receiver in a task bar." 1300 1301 ^MenuIcons smallFontsIcon! ! 1302Model subclass: #AbstractHierarchicalList 1303 instanceVariableNames: 'currentSelection' 1304 classVariableNames: '' 1305 poolDictionaries: '' 1306 category: 'Morphic-Explorer'! 1307!AbstractHierarchicalList commentStamp: '<historical>' prior: 0! 1308Contributed by Bob Arning as part of the ObjectExplorer package. 1309! 1310 1311 1312!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 15:22'! 1313genericMenu: aMenu 1314 1315 aMenu add: 'no menu yet' target: self selector: #yourself. 1316 ^aMenu! ! 1317 1318!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:44'! 1319getCurrentSelection 1320 1321 ^currentSelection! ! 1322 1323!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:46'! 1324noteNewSelection: x 1325 1326 currentSelection := x. 1327 self changed: #getCurrentSelection. 1328 currentSelection ifNil: [^self]. 1329 currentSelection sendSettingMessageTo: self. 1330! ! 1331 1332!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:53'! 1333perform: selector orSendTo: otherTarget 1334 "Selector was just chosen from a menu by a user. If can respond, then 1335perform it on myself. If not, send it to otherTarget, presumably the 1336editPane from which the menu was invoked." 1337 1338 (self respondsTo: selector) 1339 ifTrue: [^ self perform: selector] 1340 ifFalse: [^ otherTarget perform: selector]! ! 1341 1342!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:47'! 1343update: aSymbol 1344 1345 aSymbol == #hierarchicalList ifTrue: [ 1346 ^self changed: #getList 1347 ]. 1348 super update: aSymbol! ! 1349Object subclass: #AbstractLauncher 1350 instanceVariableNames: 'parameters' 1351 classVariableNames: '' 1352 poolDictionaries: '' 1353 category: 'System-Support'! 1354!AbstractLauncher commentStamp: '<historical>' prior: 0! 1355The class AutoStart in combination with the Launcher classes provides a mechanism for starting Squeak from the command line or a web page. Parameters on the command line or in the embed tag in the web page a parsed and stored in the lauchner's parameter dictionary. 1356Subclasses can access these parameters to determine what to do. 1357 1358CommandLineLauncherExample provides an example for a command line application. if you start squeak with a command line 'class Integer' it will launch a class browser on class Integer. 1359To enable this execute 1360CommandLineLauncherExample activate 1361before you save the image. 1362To disable execute 1363CommandLineLauncherExample deactivate 1364 1365The PluginLauchner is an example how to use this framework to start Squeak as a browser plugin. It looks for a parameter 'src' which should point to a file containing a squeak script.! 1366 1367 1368!AbstractLauncher methodsFor: 'running' stamp: 'tk 10/24/2001 06:40'! 1369startUp 1370 "A backstop for subclasses. Note that this is not a class message (most startUps are class messages)." 1371 1372! ! 1373 1374 1375!AbstractLauncher methodsFor: 'private' stamp: 'dc 5/30/2008 10:17'! 1376commandLine: aString 1377 "Start up this launcher from within Squeak as if it Squeak been launched the given command line." 1378 | dict tokens cmd arg | 1379 dict := Dictionary new. 1380 tokens := (aString findTokens: ' ') readStream. 1381 1382 [ cmd := tokens next. 1383 arg := tokens next. 1384 cmd ~~ nil and: [ arg ~~ nil ] ] whileTrue: 1385 [ dict 1386 at: cmd 1387 put: arg ]. 1388 self parameters: dict. 1389 self startUp! ! 1390 1391!AbstractLauncher methodsFor: 'private' stamp: 'mir 9/23/1999 13:18'! 1392determineParameterNameFrom: alternateParameterNames 1393 "Determine which of the given alternate parameter names is actually used." 1394 1395 ^alternateParameterNames detect: [:each | self includesParameter: each asUppercase] ifNone: [nil] ! ! 1396 1397!AbstractLauncher methodsFor: 'private' stamp: 'mir 1/11/2000 16:35'! 1398includesParameter: parName 1399 "Return if the parameter named parName exists." 1400 ^self parameters 1401 includesKey: parName asUppercase! ! 1402 1403!AbstractLauncher methodsFor: 'private' stamp: 'mdr 4/10/2001 10:50'! 1404numericParameterAtOneOf: alternateParameterNames ifAbsent: aBlock 1405 "Return the parameter named using one of the alternate names or an empty string" 1406 1407 | parameterValue | 1408 parameterValue := self parameterAtOneOf: alternateParameterNames. 1409 parameterValue isEmpty 1410 ifTrue: [^aBlock value]. 1411 ^[Number readFrom: parameterValue] ifError: aBlock 1412 1413! ! 1414 1415!AbstractLauncher methodsFor: 'private' stamp: 'mir 8/4/1999 14:19'! 1416parameterAt: parName 1417 "Return the parameter named parName or an empty string" 1418 ^self 1419 parameterAt: parName 1420 ifAbsent: ['']! ! 1421 1422!AbstractLauncher methodsFor: 'private' stamp: 'mir 1/11/2000 16:36'! 1423parameterAt: parName ifAbsent: aBlock 1424 "Return the parameter named parName. 1425 Evaluate the block if parameter does not exist." 1426 ^self parameters 1427 at: parName asUppercase 1428 ifAbsent: [aBlock value]! ! 1429 1430!AbstractLauncher methodsFor: 'private' stamp: 'mir 9/23/1999 12:09'! 1431parameterAtOneOf: alternateParameterNames 1432 | parameterName | 1433 "Return the parameter named using one of the alternate names or an empty string" 1434 1435 parameterName := self determineParameterNameFrom: alternateParameterNames. 1436 ^parameterName isNil 1437 ifTrue: [''] 1438 ifFalse: [self parameterAt: parameterName ifAbsent: ['']]! ! 1439 1440!AbstractLauncher methodsFor: 'private' stamp: 'marcus.denker 9/14/2008 18:54'! 1441parameters 1442 parameters ifNil: [parameters := self class extractParameters]. 1443 ^parameters! ! 1444 1445!AbstractLauncher methodsFor: 'private' stamp: 'mir 7/29/1999 10:21'! 1446parameters: startupParameters 1447 parameters := startupParameters! ! 1448 1449"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 1450 1451AbstractLauncher class 1452 instanceVariableNames: ''! 1453 1454!AbstractLauncher class methodsFor: 'activation' stamp: 'mir 8/6/1999 18:14'! 1455activate 1456 "Register this launcher with the auto start class" 1457 1458 self autoStarter addLauncher: self! ! 1459 1460!AbstractLauncher class methodsFor: 'activation'! 1461deactivate 1462 "Unregister this launcher with the auto start class" 1463 self autoStarter removeLauncher: self! ! 1464 1465 1466!AbstractLauncher class methodsFor: 'private' stamp: 'mir 8/4/1999 13:57'! 1467autoStarter 1468 ^AutoStart! ! 1469 1470!AbstractLauncher class methodsFor: 'private' stamp: 'sd 9/30/2003 13:55'! 1471extractParameters 1472 1473 ^ SmalltalkImage current extractParameters! ! 1474Object subclass: #AbstractObjectsAsMethod 1475 instanceVariableNames: '' 1476 classVariableNames: '' 1477 poolDictionaries: '' 1478 category: 'Tests-ObjectsAsMethods'! 1479 1480!AbstractObjectsAsMethod methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 14:25'! 1481flushCache! ! 1482 1483!AbstractObjectsAsMethod methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 14:23'! 1484methodClass: aMethodClass! ! 1485 1486!AbstractObjectsAsMethod methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 14:23'! 1487selector: aSymbol! ! 1488Morph subclass: #AbstractResizerMorph 1489 instanceVariableNames: 'dotColor handleColor lastMouse' 1490 classVariableNames: '' 1491 poolDictionaries: '' 1492 category: 'Morphic-Windows'! 1493!AbstractResizerMorph commentStamp: 'jmv 1/29/2006 17:15' prior: 0! 1494I am the superclass of a hierarchy of morph specialized in allowing the user to resize or rearrange windows and panes.! 1495 1496 1497!AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/27/2008 21:34'! 1498adoptPaneColor: paneColor 1499 "Just get the resizer fill style for the theme." 1500 1501 paneColor ifNil: [^super adoptPaneColor: paneColor]. 1502 self fillStyle: (self theme resizerGripNormalFillStyleFor: self)! ! 1503 1504!AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/12/2007 10:59'! 1505mouseUp: anEvent 1506 "Change the cursor back to normal if necessary." 1507 1508 (self bounds containsPoint: anEvent cursorPoint) ifFalse: [ 1509 anEvent hand showTemporaryCursor: nil. 1510 self 1511 setDefaultColors; 1512 changed]! ! 1513 1514!AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:20'! 1515shouldDraw 1516 "Answer whether the resizer should be drawn." 1517 1518 ^self fillStyle isTransparent not! ! 1519 1520!AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:35'! 1521shouldInvalidateOnMouseTransition 1522 "Answer whether the resizer should be invalidated 1523 when the mouse enters or leaves." 1524 1525 ^false! ! 1526 1527 1528!AbstractResizerMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/13/2008 10:36'! 1529mouseEnter: anEvent 1530 1531 self isCursorOverHandle ifTrue: 1532 [self setInverseColors. 1533 self shouldInvalidateOnMouseTransition ifTrue: [self changed]. "avoid unnecessary invalidation" 1534 anEvent hand showTemporaryCursor: self resizeCursor]! ! 1535 1536!AbstractResizerMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/13/2008 10:36'! 1537mouseLeave: anEvent 1538 1539 anEvent hand showTemporaryCursor: nil. 1540 self setDefaultColors. 1541 self shouldInvalidateOnMouseTransition ifTrue: [self changed]. "avoid unnecessary invalidation"! ! 1542 1543 1544!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:36'! 1545dotColor 1546 1547 ^ dotColor ifNil: [self setDefaultColors. dotColor]! ! 1548 1549!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:35'! 1550handleColor 1551 1552 ^ handleColor ifNil: [self setDefaultColors. handleColor]! ! 1553 1554!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:37'! 1555handlesMouseDown: anEvent 1556 1557 ^ true! ! 1558 1559!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:37'! 1560handlesMouseOver: anEvent 1561 1562 ^ true 1563 ! ! 1564 1565!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'md 2/24/2006 23:01'! 1566initialize 1567 1568 super initialize. 1569 self color: Color transparent! ! 1570 1571!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:40'! 1572isCursorOverHandle 1573 1574 ^ true! ! 1575 1576!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:42'! 1577mouseDown: anEvent 1578 1579 lastMouse := anEvent cursorPoint! ! 1580 1581!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:37'! 1582resizeCursor 1583 1584 self subclassResponsibility! ! 1585 1586!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/29/2005 13:25'! 1587setDefaultColors 1588 1589 handleColor := Color lightGray lighter lighter. 1590 dotColor := Color gray lighter! ! 1591 1592!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/30/2005 21:30'! 1593setInverseColors 1594 1595 handleColor := Color lightGray. 1596 dotColor := Color white! ! 1597Object subclass: #AbstractSoundSystem 1598 instanceVariableNames: '' 1599 classVariableNames: '' 1600 poolDictionaries: '' 1601 category: 'System-Support'! 1602!AbstractSoundSystem commentStamp: 'gk 2/24/2004 08:34' prior: 0! 1603This is the abstract base class for a sound system. A sound system offers a small protocol for playing sounds and making beeps and works like a facade towards the rest of Squeak. A sound system is registered in the application registry SoundService and can be accessed by "SoundService default" like for example: 1604 1605SoundService default playSoundNamed: 'croak' 1606 1607The idea is that as much sound playing as possible should go through this facade. This way we decouple the sound system from the rest of Squeak and make it pluggable. It also is a perfect spot to check for the Preference class>>soundsEnabled. 1608 1609Two basic subclasses exist at the time of this writing, the BaseSoundSystem which represents the standard Squeak sound system, and the DummySoundSystem which is a dummy implementation that can be used when there is no sound card available, or when the base sound system isn't in the image, or when you simply don't want to use the available sound card.! 1610 1611 1612!AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'! 1613randomBitsFromSoundInput: bitCount 1614 1615 self subclassResponsibility! ! 1616 1617!AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'! 1618sampledSoundChoices 1619 1620 self subclassResponsibility! ! 1621 1622!AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:53'! 1623shutDown 1624 "Default is to do nothing."! ! 1625 1626!AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:56'! 1627soundNamed: soundName 1628 1629 self subclassResponsibility! ! 1630 1631 1632!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/24/2004 23:27'! 1633beep 1634 "Make a primitive beep." 1635 1636 self subclassResponsibility! ! 1637 1638!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:47'! 1639playSampledSound: samples rate: rate 1640 1641 self subclassResponsibility! ! 1642 1643!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:50'! 1644playSoundNamed: soundName 1645 1646 self subclassResponsibility! ! 1647 1648!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'! 1649playSoundNamed: soundName ifAbsentReadFrom: aifFileName 1650 1651 self subclassResponsibility! ! 1652 1653!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'! 1654playSoundNamedOrBeep: soundName 1655 1656 self subclassResponsibility! ! 1657PluggableTextMorph subclass: #AcceptableCleanTextMorph 1658 instanceVariableNames: '' 1659 classVariableNames: '' 1660 poolDictionaries: '' 1661 category: 'Morphic-Pluggable Widgets'! 1662 1663!AcceptableCleanTextMorph methodsFor: 'menu commands' stamp: 'dgd 2/21/2003 22:50'! 1664accept 1665 "Overridden to allow accept of clean text" 1666 1667 | textToAccept ok | 1668 textToAccept := textMorph asText. 1669 ok := setTextSelector isNil or: 1670 [setTextSelector numArgs = 2 1671 ifTrue: 1672 [model 1673 perform: setTextSelector 1674 with: textToAccept 1675 with: self] 1676 ifFalse: [model perform: setTextSelector with: textToAccept]]. 1677 ok 1678 ifTrue: 1679 [self setText: self getText. 1680 self hasUnacceptedEdits: false]! ! 1681FileDirectory subclass: #AcornFileDirectory 1682 instanceVariableNames: '' 1683 classVariableNames: 'LegalCharMap' 1684 poolDictionaries: '' 1685 category: 'Files-Directories'! 1686 1687!AcornFileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'! 1688checkName: aFileName fixErrors: fixing 1689 "Check if the file name contains any invalid characters" 1690 | fName hasBadChars correctedName newChar| 1691 fName := super checkName: aFileName fixErrors: fixing. 1692 correctedName := String streamContents:[:s| 1693 fName do:[:c| 1694 (newChar := LegalCharMap at: c asciiValue +1) ifNotNil:[s nextPut: newChar]]]. 1695 hasBadChars := fName ~= correctedName. 1696 (hasBadChars and:[fixing not]) ifTrue:[^self error:'Invalid file name']. 1697 hasBadChars ifFalse:[^ fName]. 1698 ^ correctedName! ! 1699 1700!AcornFileDirectory methodsFor: 'file name utilities' stamp: 'tpr 11/5/2004 13:08'! 1701fullPathFor: path 1702 "if the arg is an empty string, just return my path name converted via the language stuff. 1703If the arg seems to be a rooted path, return it raw, assuming it is already ok. 1704Otherwise cons up a path" 1705 path isEmpty ifTrue:[^pathName asSqueakPathName]. 1706 ((path includes: $$ ) or:[path includes: $:]) ifTrue:[^path]. 1707 ^pathName asSqueakPathName, self slash, path! ! 1708 1709 1710!AcornFileDirectory methodsFor: 'path access' stamp: 'tpr 11/30/2003 21:42'! 1711pathParts 1712 "Return the path from the root of the file system to this directory as an 1713 array of directory names. 1714 This version tries to cope with the RISC OS' strange filename formatting; 1715 filesystem::discname/$/path/to/file 1716 where the $ needs to be considered part of the filingsystem-discname atom." 1717 | pathList | 1718 pathList := super pathParts. 1719 (pathList indexOf: '$') = 2 1720 ifTrue: ["if the second atom is root ($) then stick $ on the first atom 1721 and drop the second. Yuck" 1722 ^ Array 1723 streamContents: [:a | 1724 a nextPut: (pathList at: 1), '/$'. 1725 3 to: pathList size do: [:i | a 1726 nextPut: (pathList at: i)]]]. 1727 ^ pathList! ! 1728 1729 1730!AcornFileDirectory methodsFor: 'testing' stamp: 'tpr 4/28/2004 21:54'! 1731directoryExists: filenameOrPath 1732"if the path is a root,we have to treat it carefully" 1733 (filenameOrPath endsWith: '$') ifTrue:[^(FileDirectory on: filenameOrPath) exists]. 1734 ^(self directoryNamed: filenameOrPath ) exists! ! 1735 1736 1737!AcornFileDirectory methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'! 1738directoryContentsFor: fullPath 1739 "Return a collection of directory entries for the files and directories in 1740 the directory with the given path. See primLookupEntryIn:index: for 1741 further details." 1742 "FileDirectory default directoryContentsFor: ''" 1743 1744 | entries extraPath | 1745 entries := super directoryContentsFor: fullPath. 1746 fullPath isNullPath 1747 ifTrue: [ 1748 "For Acorn we also make sure that at least the parent of the current dir 1749 is added - sometimes this is in a filing system that has not been (or 1750 cannot be) polled for disc root names" 1751 extraPath := self class default containingDirectory. 1752 "Only add the extra path if we haven't already got the root of the current dir in the list" 1753 entries detect: [:ent | extraPath fullName beginsWith: ent name] 1754 ifNone: [entries := entries 1755 copyWith: (DirectoryEntry 1756 name: extraPath fullName 1757 creationTime: 0 1758 modificationTime: 0 1759 isDirectory: true 1760 fileSize: 0)]]. 1761 ^ entries 1762! ! 1763 1764"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 1765 1766AcornFileDirectory class 1767 instanceVariableNames: ''! 1768 1769!AcornFileDirectory class methodsFor: '*network-uri' stamp: 'tpr 5/4/2005 17:22'! 1770privateFullPathForURI: aURI 1771 "derive the full filepath from aURI" 1772 | first path | 1773 1774 path := String streamContents: [ :s | 1775 first := false. 1776 aURI pathComponents do: [ :p | 1777 first ifTrue: [ s nextPut: self pathNameDelimiter ]. 1778 first := true. 1779 s nextPutAll: p ] ]. 1780 ^path unescapePercents 1781! ! 1782 1783 1784!AcornFileDirectory class methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:32'! 1785initialize 1786"Set up the legal chars map for filenames. May need extending for unicode etc. 1787Basic rule is that any char legal for use in filenames will have a non-nil entry in this array; except for space, this is the same character. Space is transcoded to a char 160 to be a 'hard space' " 1788"AcornFileDirectory initialize" 1789 | aVal | 1790 LegalCharMap := Array new: 256. 1791 Character alphabet do:[:c| 1792 LegalCharMap at: c asciiValue +1 put: c. 1793 LegalCharMap at: (aVal := c asUppercase) asciiValue +1 put: aVal]. 1794 '`!!()-_=+[{]};~,./1234567890' do:[:c| 1795 LegalCharMap at: c asciiValue + 1 put: c]. 1796 LegalCharMap at: Character space asciiValue +1 put: (Character value:160 "hardspace"). 1797 LegalCharMap at: 161 put: (Character value:160 "hardspace")."secondary mapping to keep it in strings"! ! 1798 1799 1800!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:16'! 1801isActiveDirectoryClass 1802 "Does this class claim to be that properly active subclass of FileDirectory 1803 for the current platform? On Acorn, the test is whether platformName 1804 is 'RiscOS' (on newer VMs) or if the primPathNameDelimiter is $. (on 1805 older ones), which is what we would like to use for a dirsep if only it 1806 would work out. See pathNameDelimiter for more woeful details - then 1807 just get on and enjoy Squeak" 1808 1809 ^ SmalltalkImage current platformName = 'RiscOS' 1810 or: [self primPathNameDelimiter = $.]! ! 1811 1812!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'tpr 8/1/2003 16:38'! 1813isCaseSensitive 1814 "Risc OS ignores the case of file names" 1815 ^ false! ! 1816 1817!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'TPR 7/20/1999 17:52'! 1818maxFileNameLength 1819 1820 ^ 255 1821! ! 1822 1823!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'TPR 5/10/1998 21:45'! 1824pathNameDelimiter 1825"Acorn RiscOS uses a dot as the directory separator and has no real concept of filename extensions. We tried to make code handle this, but there are just too many uses of dot as a filename extension - so fake it out by pretending to use a slash. The file prims do conversions instead. 1826Sad, but pragmatic" 1827 ^ $/ 1828! ! 1829HostWindowProxy subclass: #AcornWindowProxy 1830 instanceVariableNames: 'flags' 1831 classVariableNames: 'BackButton CloseButton HasTitleBar IconiseButton ToggleSizeButton' 1832 poolDictionaries: '' 1833 category: 'Graphics-External-Ffenestri'! 1834 1835!AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 16:32'! 1836addButton: buttonFlag 1837"we need a button on the window. If there is already one, ignore this. 1838If the host window does not yet exist we need only set the flag. If there is 1839already a window, we will need to destroy the old window, add the flag and recreate" 1840 1841 "do we already have a button? - if so just return" 1842 (self hasButton: buttonFlag) ifTrue:[^self]. 1843 1844 "add the close button flag" 1845 self addFlag: buttonFlag. 1846 "note that we have a titlebar in order for the button to exist" 1847 self addFlag: HasTitleBar. 1848 1849 "if we have a window recreate it" 1850 self isOpen ifTrue:[self recreate]! ! 1851 1852!AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 15:01'! 1853addCloseButton 1854"we need a close button on the window. If there is already one, ignore this. 1855If the host window does not yet exist we need only set the flag. If there is 1856already a window, we will need to destroy the old window, add the flag and recreate" 1857 1858 ^self addButton: CloseButton! ! 1859 1860!AcornWindowProxy methodsFor: 'window decorations' stamp: 'lr 7/4/2009 10:42'! 1861addFlag: flagVal 1862 "add flagVal to the flags" 1863 flags ifNil: [ flags := 0 ]. 1864 flags := flags bitOr: flagVal! ! 1865 1866!AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 15:01'! 1867addIconiseButton 1868"we need a iconise button on the window. If there is already one, ignore this. 1869If the host window does not yet exist we need only set the flag. If there is 1870already a window, we will need to destroy the old window, add the flag and recreate" 1871 1872 ^self addButton: IconiseButton! ! 1873 1874!AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 15:25'! 1875addToggleSizeButton 1876"we need a toggle size button on the window. If there is already one, ignore this. 1877If the host window does not yet exist we need only set the flag. If there is 1878already a window, we will need to destroy the old window, add the flag and recreate" 1879 1880 ^self addButton: ToggleSizeButton! ! 1881 1882!AcornWindowProxy methodsFor: 'window decorations' stamp: 'lr 7/4/2009 10:42'! 1883attributes 1884 | val | 1885 ^ flags 1886 ifNil: [ super attributes ] 1887 ifNotNil: 1888 [ (val := ByteArray new: 4) 1889 longAt: 1 1890 put: flags 1891 bigEndian: false. 1892 val ]! ! 1893 1894!AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/7/2004 11:37'! 1895defaultWindowType 1896 "set myself up for use as a normal window titlebar, close, iconise & size buttons" 1897 self addCloseButton; addIconiseButton; addToggleSizeButton! ! 1898 1899!AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 15:20'! 1900hasButton: buttonFlag 1901"do I have the button?" 1902 flags ifNil:[^false]. 1903 ^flags anyMask: buttonFlag! ! 1904 1905!AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/11/2004 18:31'! 1906hasTitleBar 1907"do I have a title bar set?" 1908 ^self hasButton: HasTitleBar! ! 1909 1910!AcornWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/6/2004 16:33'! 1911windowTitle: titleString 1912 "set the window title. If the window is open and doesn't already have a 1913titlebar, add the title bar, recreate and set the title" 1914 (self isOpen and: [self hasTitleBar not]) 1915 ifTrue:[ 1916 "note that we have a titlebar in order for the title to exist" 1917 self addFlag: HasTitleBar. 1918 self recreate]. 1919 super windowTitle: titleString! ! 1920 1921"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 1922 1923AcornWindowProxy class 1924 instanceVariableNames: ''! 1925 1926!AcornWindowProxy class methodsFor: 'class initialization' stamp: 'lr 7/4/2009 10:42'! 1927initialize 1928 "AcornWindowProxy initialize" 1929 "Encode attributes in a 4byte ByteArary to be treated as an int in the vm" 1930 BackButton := 16777216. 1931 CloseButton := 33554432. 1932 IconiseButton := 0. "handled by OS completely independently" 1933 ToggleSizeButton := 134217728. 1934 HasTitleBar := 67108864! ! 1935 1936 1937!AcornWindowProxy class methodsFor: 'system startup' stamp: 'tpr 10/1/2004 16:28'! 1938isActiveHostWindowProxyClass 1939"Am I active?" 1940 ^SmalltalkImage current platformName = 'RiscOS'! ! 1941Array variableSubclass: #ActionSequence 1942 instanceVariableNames: '' 1943 classVariableNames: '' 1944 poolDictionaries: '' 1945 category: 'System-Object Events'! 1946!ActionSequence commentStamp: 'tlk 5/7/2006 20:02' prior: 0! 1947An ActionSequence is an array that lists the object's dependant objects.! 1948 1949 1950!ActionSequence methodsFor: 'converting' stamp: 'reThink 2/18/2001 15:12'! 1951asActionSequence 1952 1953 ^self! ! 1954 1955!ActionSequence methodsFor: 'converting' stamp: 'rw 7/20/2003 16:03'! 1956asActionSequenceTrappingErrors 1957 1958 ^WeakActionSequenceTrappingErrors withAll: self! ! 1959 1960!ActionSequence methodsFor: 'converting' stamp: 'reThink 2/18/2001 15:28'! 1961asMinimalRepresentation 1962 1963 self size = 0 1964 ifTrue: [^nil]. 1965 self size = 1 1966 ifTrue: [^self first]. 1967 ^self! ! 1968 1969 1970!ActionSequence methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 17:51'! 1971value 1972 "Answer the result of evaluating the elements of the receiver." 1973 1974 | answer | 1975 self do: 1976 [:each | 1977 answer := each value]. 1978 ^answer! ! 1979 1980!ActionSequence methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 17:52'! 1981valueWithArguments: anArray 1982 1983 | answer | 1984 self do: 1985 [:each | 1986 answer := each valueWithArguments: anArray]. 1987 ^answer! ! 1988 1989 1990!ActionSequence methodsFor: 'printing' stamp: 'SqR 07/28/2001 18:25'! 1991printOn: aStream 1992 1993 self size < 2 ifTrue: [^super printOn: aStream]. 1994 aStream nextPutAll: '#('. 1995 self 1996 do: [:each | each printOn: aStream] 1997 separatedBy: [aStream cr]. 1998 aStream nextPut: $)! ! 1999 2000"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 2001 2002ActionSequence class 2003 instanceVariableNames: ''! 2004AbstractEvent subclass: #AddedEvent 2005 instanceVariableNames: '' 2006 classVariableNames: '' 2007 poolDictionaries: '' 2008 category: 'System-Change Notification'! 2009 2010!AddedEvent methodsFor: 'printing' stamp: 'rw 6/30/2003 09:31'! 2011printEventKindOn: aStream 2012 2013 aStream nextPutAll: 'Added'! ! 2014 2015 2016!AddedEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:35'! 2017isAdded 2018 2019 ^true! ! 2020 2021"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 2022 2023AddedEvent class 2024 instanceVariableNames: ''! 2025 2026!AddedEvent class methodsFor: 'accessing' stamp: 'rw 7/19/2003 09:52'! 2027changeKind 2028 2029 ^#Added! ! 2030 2031!AddedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:22'! 2032supportedKinds 2033 "All the kinds of items that this event can take." 2034 2035 ^ Array with: self classKind with: self methodKind with: self categoryKind with: self protocolKind! ! 2036Object variableSubclass: #AdditionalMethodState 2037 instanceVariableNames: 'method selector' 2038 classVariableNames: '' 2039 poolDictionaries: '' 2040 category: 'Kernel-Methods'! 2041!AdditionalMethodState commentStamp: '<historical>' prior: 0! 2042I am class holding state for compiled methods. All my instance variables should be actually part of the CompiledMethod itself, but the current implementation of the VM doesn't allow this. Currently I hold the selector and any pragmas or properties the compiled method has. Pragmas and properties are stored in indexable fields; pragmas as instances of Pragma, properties as instances of Association. 2043 2044I am a reimplementation of much of MethodProperties, but eliminating the explicit properties and pragmas dictionaries. Hence I answer true to isMethodProperties.! 2045 2046 2047!AdditionalMethodState methodsFor: 'testing' stamp: 'eem 11/27/2008 13:12'! 2048analogousCodeTo: aMethodProperties 2049 | bs | 2050 (bs := self basicSize) ~= aMethodProperties basicSize ifTrue: 2051 [^false]. 2052 1 to: bs do: 2053 [:i| 2054 ((self basicAt: i) analogousCodeTo: (aMethodProperties basicAt: i)) ifFalse: 2055 [^false]]. 2056 ^true! ! 2057 2058!AdditionalMethodState methodsFor: 'testing' stamp: 'bgf 12/6/2008 12:15'! 2059hasLiteralSuchThat: aBlock 2060 "Answer true if litBlock returns true for any literal in this array, even if embedded in further array structure. 2061 This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" 2062 1 to: self basicSize do: [:i | 2063 | propertyOrPragma "<Association|Pragma>" | 2064 propertyOrPragma := self basicAt: i. 2065 (propertyOrPragma isVariableBinding 2066 ifTrue: [(aBlock value: propertyOrPragma key) 2067 or: [(aBlock value: propertyOrPragma value) 2068 or: [propertyOrPragma value isArray 2069 and: [propertyOrPragma value hasLiteralSuchThat: aBlock]]]] 2070 ifFalse: [propertyOrPragma hasLiteralSuchThat: aBlock]) ifTrue: 2071 [^true]]. 2072 ^false! ! 2073 2074!AdditionalMethodState methodsFor: 'testing' stamp: 'eem 11/29/2008 16:40'! 2075hasLiteralThorough: literal 2076 "Answer true if any literal in these properties is literal, 2077 even if embedded in array structure." 2078 1 to: self basicSize do: [:i | 2079 | propertyOrPragma "<Association|Pragma>" | 2080 propertyOrPragma := self basicAt: i. 2081 (propertyOrPragma isVariableBinding 2082 ifTrue: [propertyOrPragma key == literal 2083 or: [propertyOrPragma value == literal 2084 or: [propertyOrPragma value isArray 2085 and: [propertyOrPragma value hasLiteral: literal]]]] 2086 ifFalse: [propertyOrPragma hasLiteral: literal]) ifTrue: 2087 [^true]]. 2088 ^false! ! 2089 2090!AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 10:53'! 2091includes: aPropertyOrPragma "<Association|Pragma>" 2092 "Test if the property or pragma is present." 2093 2094 1 to: self basicSize do: 2095 [:i | 2096 (self basicAt: i) = aPropertyOrPragma ifTrue: 2097 [^true]]. 2098 ^false! ! 2099 2100!AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 10:53'! 2101includesKey: aKey 2102 "Test if the property aKey or pragma with selector aKey is present." 2103 2104 1 to: self basicSize do: 2105 [:i | 2106 (self basicAt: i) key == aKey ifTrue: 2107 [^true]]. 2108 ^false! ! 2109 2110!AdditionalMethodState methodsFor: 'testing' stamp: 'eem 11/29/2008 13:47'! 2111isEmpty 2112 ^self basicSize = 0! ! 2113 2114!AdditionalMethodState methodsFor: 'testing' stamp: 'md 2/19/2006 11:24'! 2115isMethodProperties 2116 ^true! ! 2117 2118!AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 16:49'! 2119notEmpty 2120 ^self basicSize > 0! ! 2121 2122!AdditionalMethodState methodsFor: 'testing' stamp: 'JohanBrichau 10/7/2009 20:07'! 2123refersToLiteral: aLiteral 2124 ^ self pragmas anySatisfy: [ :pragma | pragma hasLiteral: aLiteral ]! ! 2125 2126 2127!AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 10:19'! 2128at: aKey 2129 "Answer the property value or pragma associated with aKey." 2130 2131 ^self at: aKey ifAbsent: [self error: 'not found']! ! 2132 2133!AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 12/1/2008 10:55'! 2134at: aKey ifAbsent: aBlock 2135 "Answer the property value or pragma associated with aKey or, 2136 if aKey isn't found, answer the result of evaluating aBlock." 2137 2138 1 to: self basicSize do: 2139 [:i | 2140 | propertyOrPragma "<Association|Pragma>" | 2141 (propertyOrPragma := self basicAt: i) key == aKey ifTrue: 2142 [^propertyOrPragma isVariableBinding 2143 ifTrue: [propertyOrPragma value] 2144 ifFalse: [propertyOrPragma]]]. 2145 ^aBlock value! ! 2146 2147!AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 12/1/2008 10:54'! 2148at: aKey ifAbsentPut: aBlock 2149 "Answer the property value or pragma associated with aKey or, 2150 if aKey isn't found, answer the result of evaluating aBlock." 2151 2152 1 to: self basicSize do: 2153 [:i | 2154 | propertyOrPragma "<Association|Pragma>" | 2155 (propertyOrPragma := self basicAt: i) key == aKey ifTrue: 2156 [^propertyOrPragma isVariableBinding 2157 ifTrue: [propertyOrPragma value] 2158 ifFalse: [propertyOrPragma]]]. 2159 ^method propertyValueAt: aKey put: aBlock value! ! 2160 2161!AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 12/1/2008 10:56'! 2162at: aKey put: aValue 2163 "Replace the property value or pragma associated with aKey." 2164 2165 1 to: self basicSize do: 2166 [:i | 2167 | propertyOrPragma "<Association|Pragma>" | 2168 (propertyOrPragma := self basicAt: i) key == aKey ifTrue: 2169 [propertyOrPragma isVariableBinding 2170 ifTrue: [propertyOrPragma value: aValue] 2171 ifFalse: [self basicAt: i put: aValue]]]. 2172 ^method propertyValueAt: aKey put: aValue! ! 2173 2174!AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 18:36'! 2175keysAndValuesDo: aBlock 2176 "Enumerate the receiver with all the keys and values." 2177 2178 1 to: self basicSize do: [:i | 2179 | propertyOrPragma "<Association|Pragma>" | 2180 (propertyOrPragma := self basicAt: i) isVariableBinding 2181 ifTrue: [aBlock value: propertyOrPragma key value: propertyOrPragma value] 2182 ifFalse: [aBlock value: propertyOrPragma keyword value: propertyOrPragma]]! ! 2183 2184!AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 14:11'! 2185pragmas 2186 "Answer the raw messages comprising my pragmas." 2187 | pragmaStream | 2188 pragmaStream := WriteStream on: (Array new: self basicSize). 2189 1 to: self basicSize do: [:i | 2190 | propertyOrPragma "<Association|Message>" | 2191 (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: 2192 [pragmaStream nextPut: propertyOrPragma]]. 2193 ^pragmaStream contents! ! 2194 2195!AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 10:25'! 2196properties 2197 2198 | propertyStream | 2199 propertyStream := WriteStream on: (Array new: self basicSize * 2). 2200 1 to: self basicSize do: [:i | 2201 | propertyOrPragma "<Association|Pragma>" | 2202 (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: 2203 [propertyStream nextPut: propertyOrPragma key; nextPut: propertyOrPragma value]]. 2204 ^IdentityDictionary newFromPairs: propertyStream contents! ! 2205 2206!AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 19:32'! 2207removeKey: aKey ifAbsent: aBlock 2208 "Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock." 2209 2210 1 to: self basicSize do: [:i | 2211 | propertyOrPragma "<Association|Pragma>" | 2212 propertyOrPragma := self basicAt: i. 2213 (propertyOrPragma isVariableBinding 2214 ifTrue: [propertyOrPragma key] 2215 ifFalse: [propertyOrPragma keyword]) 2216 == aKey ifTrue: 2217 [^method removeProperty: aKey]]. 2218 ^aBlock value! ! 2219 2220!AdditionalMethodState methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'! 2221selector 2222 ^selector! ! 2223 2224!AdditionalMethodState methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'! 2225selector: aSymbol 2226 selector := aSymbol! ! 2227 2228!AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 18:28'! 2229setMethod: aMethod 2230 method := aMethod. 2231 1 to: self basicSize do: 2232 [:i| | propertyOrPragma "<Association|Pragma>" | 2233 (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: 2234 [propertyOrPragma setMethod: aMethod]]! ! 2235 2236 2237!AdditionalMethodState methodsFor: 'copying' stamp: 'eem 11/29/2008 18:35'! 2238copyWith: aPropertyOrPragma "<Association|Pragma>" 2239 "Answer a copy of the receiver which includes aPropertyOrPragma" 2240 | bs copy | 2241 (Association == aPropertyOrPragma class 2242 or: [Pragma == aPropertyOrPragma class]) ifFalse: 2243 [self error: self class name, ' instances should hold only Associations or Pragmas.']. 2244 copy := self class new: (bs := self basicSize) + 1. 2245 1 to: bs do: 2246 [:i| 2247 copy basicAt: i put: (self basicAt: i)]. 2248 copy basicAt: bs + 1 put: aPropertyOrPragma. 2249 ^copy 2250 selector: selector; 2251 setMethod: method; 2252 yourself 2253! ! 2254 2255!AdditionalMethodState methodsFor: 'copying' stamp: 'eem 11/29/2008 18:35'! 2256copyWithout: aPropertyOrPragma "<Association|Pragma>" 2257 "Answer a copy of the receiver which no longer includes aPropertyOrPragma" 2258 | bs copy offset | 2259 copy := self class new: (bs := self basicSize) - ((self includes: aPropertyOrPragma) 2260 ifTrue: [1] 2261 ifFalse: [0]). 2262 offset := 0. 2263 1 to: bs do: 2264 [:i| 2265 (self basicAt: i) = aPropertyOrPragma 2266 ifTrue: [offset := 1] 2267 ifFalse: [copy basicAt: i - offset put: (self basicAt: i)]]. 2268 ^copy 2269 selector: selector; 2270 setMethod: method; 2271 yourself 2272! ! 2273 2274 2275!AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 10:28'! 2276includesProperty: aKey 2277 "Test if the property aKey is present." 2278 2279 1 to: self basicSize do: [:i | 2280 | propertyOrPragma "<Association|Pragma>" | 2281 propertyOrPragma := self basicAt: i. 2282 (propertyOrPragma isVariableBinding 2283 and: [propertyOrPragma key == aKey]) ifTrue: 2284 [^true]]. 2285 ^false! ! 2286 2287!AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 10:18'! 2288propertyKeysAndValuesDo: aBlock 2289 "Enumerate the receiver with all the keys and values." 2290 2291 1 to: self basicSize do: [:i | 2292 | propertyOrPragma "<Association|Pragma>" | 2293 (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: 2294 [aBlock value: propertyOrPragma key value: propertyOrPragma value]]! ! 2295 2296!AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 11:46'! 2297propertyValueAt: aKey 2298 "Answer the property value associated with aKey." 2299 2300 ^ self propertyValueAt: aKey ifAbsent: [ self error: 'Property not found' ].! ! 2301 2302!AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 11:45'! 2303propertyValueAt: aKey ifAbsent: aBlock 2304 "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 2305 2306 1 to: self basicSize do: [:i | 2307 | propertyOrPragma "<Association|Pragma>" | 2308 propertyOrPragma := self basicAt: i. 2309 (propertyOrPragma isVariableBinding 2310 and: [propertyOrPragma key == aKey]) ifTrue: 2311 [^propertyOrPragma value]]. 2312 ^aBlock value! ! 2313 2314!AdditionalMethodState methodsFor: 'properties' stamp: 'lr 2/6/2006 20:48'! 2315removeKey: aKey 2316 "Remove the property with aKey. Answer the property or raise an error if aKey isn't found." 2317 2318 ^ self removeKey: aKey ifAbsent: [ self error: 'Property not found' ].! ! 2319 2320 2321!AdditionalMethodState methodsFor: 'decompiling' stamp: 'eem 6/11/2009 17:06'! 2322method: aMethodNodeOrNil 2323 "For decompilation" 2324 method := aMethodNodeOrNil! ! 2325 2326"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 2327 2328AdditionalMethodState class 2329 instanceVariableNames: ''! 2330 2331!AdditionalMethodState class methodsFor: 'instance creation' stamp: 'eem 11/29/2008 18:48'! 2332forMethod: aMethod selector: aSelector 2333 ^(self basicNew: 0) 2334 selector: aSelector; 2335 setMethod: aMethod; 2336 yourself! ! 2337 2338!AdditionalMethodState class methodsFor: 'instance creation' stamp: 'eem 11/28/2008 12:26'! 2339selector: aSelector with: aPropertyOrPragma 2340 ^(self basicNew: 1) 2341 selector: aSelector; 2342 basicAt: 1 put: aPropertyOrPragma; 2343 yourself! ! 2344MessageDialogWindow subclass: #AlertDialogWindow 2345 instanceVariableNames: '' 2346 classVariableNames: '' 2347 poolDictionaries: '' 2348 category: 'Polymorph-Widgets-Windows'! 2349!AlertDialogWindow commentStamp: 'gvc 5/18/2007 13:52' prior: 0! 2350Message dialog with a warning icon.! 2351 2352 2353!AlertDialogWindow methodsFor: 'visual properties' stamp: 'gvc 5/18/2007 10:27'! 2354icon 2355 "Answer an icon for the receiver." 2356 2357 ^self theme warningIcon! ! 2358 2359"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 2360 2361AlertDialogWindow class 2362 instanceVariableNames: ''! 2363 2364!AlertDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 11:50'! 2365taskbarIcon 2366 "Answer the icon for the receiver in a task bar." 2367 2368 ^self theme smallWarningIcon! ! 2369RectangleMorph subclass: #AlignmentMorph 2370 instanceVariableNames: '' 2371 classVariableNames: '' 2372 poolDictionaries: '' 2373 category: 'Morphic-Basic'! 2374!AlignmentMorph commentStamp: 'kfr 10/27/2003 10:25' prior: 0! 2375Used for layout. 2376Since all morphs now support layoutPolicy the main use of this class is no longer needed. 2377Kept around for compability. 2378Supports a few methods not found elsewhere that can be convenient, eg. newRow 2379! 2380 2381 2382!AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! 2383addAColumn: aCollectionOfMorphs 2384 2385 | col | 2386 col := self inAColumn: aCollectionOfMorphs. 2387 self addMorphBack: col. 2388 ^col! ! 2389 2390!AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! 2391addARow: aCollectionOfMorphs 2392 2393 | row | 2394 row := self inARow: aCollectionOfMorphs. 2395 self addMorphBack: row. 2396 ^row! ! 2397 2398!AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! 2399addARowCentered: aCollectionOfMorphs 2400 2401 ^(self addARow: aCollectionOfMorphs) 2402 hResizing: #shrinkWrap; 2403 wrapCentering: #center; 2404 cellPositioning: #leftCenter! ! 2405 2406!AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! 2407addARowCentered: aCollectionOfMorphs cellInset: cellInsetInteger 2408 2409 ^(self addARow: aCollectionOfMorphs) 2410 hResizing: #shrinkWrap; 2411 wrapCentering: #center; 2412 cellPositioning: #leftCenter; 2413 cellInset: cellInsetInteger! ! 2414 2415 2416!AlignmentMorph methodsFor: 'classification' stamp: 'di 5/7/1998 01:20'! 2417isAlignmentMorph 2418 2419 ^ true 2420! ! 2421 2422 2423!AlignmentMorph methodsFor: 'event handling' stamp: 'sw 5/6/1998 15:58'! 2424wantsKeyboardFocusFor: aSubmorph 2425 aSubmorph wouldAcceptKeyboardFocus ifTrue: [^ true]. 2426 ^ super wantsKeyboardFocusFor: aSubmorph! ! 2427 2428 2429!AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! 2430defaultBorderWidth 2431 "answer the default border width for the receiver" 2432 ^ 0! ! 2433 2434!AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! 2435defaultColor 2436 "answer the default color/fill style for the receiver" 2437 ^ Color 2438 r: 0.8 2439 g: 1.0 2440 b: 0.8! ! 2441 2442!AlignmentMorph methodsFor: 'initialization' stamp: 'stephane.ducasse 1/15/2009 15:58'! 2443initialize 2444 2445 super initialize. 2446 self layoutPolicy: TableLayout new; 2447 listDirection: #leftToRight; 2448 wrapCentering: #topLeft; 2449 hResizing: #spaceFill; 2450 vResizing: #spaceFill; 2451 layoutInset: 2; 2452 rubberBandCells: true 2453 2454 "from AlignmentMorphBob1which was merged in this class, in an effort to remove alignementBob1 and 2455 still preserving the addInRow behavior" 2456 " self listDirection: #topToBottom. 2457 self layoutInset: 0. 2458 self hResizing: #rigid. 2459 self vResizing: #rigid"! ! 2460 2461!AlignmentMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:34'! 2462openInWindowLabeled: aString inWorld: aWorld 2463 2464 self layoutInset: 0. 2465 ^super openInWindowLabeled: aString inWorld: aWorld.! ! 2466 2467 2468!AlignmentMorph methodsFor: 'object filein' stamp: 'gm 2/22/2003 13:12'! 2469convertOldAlignmentsNov2000: varDict using: smartRefStrm 2470 "major change - much of AlignmentMorph is now implemented more generally in Morph" 2471 2472 "These are going away 2473 #('orientation' 'centering' 'hResizing' 'vResizing' 2474 'inset' 'minCellSize' 'layoutNeeded' 'priorFullBounds')" 2475 2476 | orientation centering hResizing vResizing inset minCellSize inAlignment | 2477 orientation := varDict at: 'orientation'. 2478 centering := varDict at: 'centering'. 2479 hResizing := varDict at: 'hResizing'. 2480 vResizing := varDict at: 'vResizing'. 2481 inset := varDict at: 'inset'. 2482 minCellSize := varDict at: 'minCellSize'. 2483 (orientation == #horizontal or: [orientation == #vertical]) 2484 ifTrue: [self layoutPolicy: TableLayout new]. 2485 self cellPositioning: #topLeft. 2486 self rubberBandCells: true. 2487 orientation == #horizontal ifTrue: [self listDirection: #leftToRight]. 2488 orientation == #vertical ifTrue: [self listDirection: #topToBottom]. 2489 centering == #topLeft ifTrue: [self wrapCentering: #topLeft]. 2490 centering == #bottomRight ifTrue: [self wrapCentering: #bottomRight]. 2491 centering == #center 2492 ifTrue: 2493 [self wrapCentering: #center. 2494 orientation == #horizontal 2495 ifTrue: [self cellPositioning: #leftCenter] 2496 ifFalse: [self cellPositioning: #topCenter]]. 2497 (inset isNumber or: [inset isPoint]) ifTrue: [self layoutInset: inset]. 2498 (minCellSize isNumber or: [minCellSize isPoint]) 2499 ifTrue: [self minCellSize: minCellSize]. 2500 (self hasProperty: #clipToOwnerWidth) ifTrue: [self clipSubmorphs: true]. 2501 2502 "now figure out if our owner was an AlignmentMorph, even if it is reshaped..." 2503 inAlignment := false. 2504 owner isMorph 2505 ifTrue: [(owner isAlignmentMorph) ifTrue: [inAlignment := true]] 2506 ifFalse: 2507 ["e.g., owner may be reshaped" 2508 2509 (owner class instanceVariablesString 2510 findString: 'orientation centering hResizing vResizing') > 0 2511 ifTrue: 2512 ["this was an alignment morph being reshaped" 2513 2514 inAlignment := true]]. 2515 "And check for containment in system windows" 2516 owner isSystemWindow ifTrue: [inAlignment := true]. 2517 (hResizing == #spaceFill and: [inAlignment not]) 2518 ifTrue: [self hResizing: #shrinkWrap] 2519 ifFalse: [self hResizing: hResizing]. 2520 (vResizing == #spaceFill and: [inAlignment not]) 2521 ifTrue: [self vResizing: #shrinkWrap] 2522 ifFalse: [self vResizing: vResizing]! ! 2523 2524 2525!AlignmentMorph methodsFor: 'visual properties' stamp: 'sw 11/5/2001 15:11'! 2526canHaveFillStyles 2527 "Return true if the receiver can have general fill styles; not just colors. 2528 This method is for gradually converting old morphs." 2529 2530 ^ self class == AlignmentMorph "no subclasses"! ! 2531 2532!AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:52'! 2533fancyText: aString font: aFont color: aColor 2534 | answer tm col | 2535 col := ColorTheme current dialog3DTitles 2536 ifTrue: [aColor] 2537 ifFalse: [aColor negated]. 2538 tm := TextMorph new. 2539 tm beAllFont: aFont; 2540 color: col; 2541 contents: aString. 2542 answer := self inAColumn: {tm}. 2543 ColorTheme current dialog3DTitles 2544 ifTrue: ["" 2545 tm addDropShadow. 2546 tm shadowPoint: 5 @ 5 + tm bounds center]. 2547 tm lock. 2548 ^ answer! ! 2549 2550!AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:53'! 2551inAColumn: aCollectionOfMorphs 2552 2553 | col | 2554 col := self class newColumn 2555 color: Color transparent; 2556 vResizing: #shrinkWrap; 2557 layoutInset: 1; 2558 wrapCentering: #center; 2559 cellPositioning: #topCenter. 2560 aCollectionOfMorphs do: [ :each | col addMorphBack: each]. 2561 ^col! ! 2562 2563!AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:54'! 2564inARightColumn: aCollectionOfMorphs 2565 | col | 2566 col := self class newColumn color: Color transparent; 2567 vResizing: #shrinkWrap; 2568 layoutInset: 1; 2569 wrapCentering: #bottomRight; 2570 cellPositioning: #topCenter. 2571 aCollectionOfMorphs 2572 do: [:each | col addMorphBack: each]. 2573 ^ col! ! 2574 2575!AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:55'! 2576inARow: aCollectionOfMorphs 2577 | row | 2578 row := self class newRow color: Color transparent; 2579 vResizing: #shrinkWrap; 2580 layoutInset: 2; 2581 wrapCentering: #center; 2582 cellPositioning: #leftCenter. 2583 aCollectionOfMorphs 2584 do: [:each | row addMorphBack: each]. 2585 ^ row! ! 2586 2587"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 2588 2589AlignmentMorph class 2590 instanceVariableNames: ''! 2591 2592!AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'! 2593columnPrototype 2594 "Answer a prototypical column" 2595 2596 | sampleMorphs aColumn | 2597 sampleMorphs := #(red yellow green) collect: 2598 [:aColor | Morph new extent: 130 @ 38; color: (Color perform: aColor); setNameTo: aColor asString; yourself]. 2599 aColumn := self inAColumn: sampleMorphs. 2600 aColumn setNameTo: 'Column'. 2601 aColumn color: Color veryVeryLightGray. 2602 aColumn cellInset: 4; layoutInset: 6. 2603 aColumn enableDragNDrop. 2604 aColumn setBalloonText: 'Things dropped into here will automatically be organized into a column. Once you have added your own items here, you will want to remove the sample colored rectangles that this started with, and you will want to change this balloon help message to one of your own!!' translated. 2605 ^ aColumn! ! 2606 2607!AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/2/2001 04:45'! 2608inAColumn: aCollectionOfMorphs 2609 "Answer a columnar AlignmentMorph holding the given collection" 2610 2611 | col | 2612 col := self newColumn 2613 color: Color transparent; 2614 vResizing: #shrinkWrap; 2615 hResizing: #shrinkWrap; 2616 layoutInset: 1; 2617 borderColor: Color black; 2618 borderWidth: 1; 2619 wrapCentering: #center; 2620 cellPositioning: #topCenter. 2621 aCollectionOfMorphs do: [:each | col addMorphBack: each]. 2622 ^ col! ! 2623 2624!AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/5/2001 15:11'! 2625inARow: aCollectionOfMorphs 2626 "Answer a row-oriented AlignmentMorph holding the given collection" 2627 2628 | aRow | 2629 aRow := self newRow 2630 color: Color transparent; 2631 vResizing: #shrinkWrap; 2632 hResizing: #shrinkWrap; 2633 layoutInset: 1; 2634 borderColor: Color black; 2635 borderWidth: 1; 2636 wrapCentering: #center; 2637 cellPositioning: #topCenter. 2638 aCollectionOfMorphs do: [ :each | aRow addMorphBack: each]. 2639 ^ aRow! ! 2640 2641!AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:51'! 2642newColumn 2643 2644 ^ self new 2645 listDirection: #topToBottom; 2646 hResizing: #spaceFill; 2647 extent: 1@1; 2648 vResizing: #spaceFill 2649! ! 2650 2651!AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:50'! 2652newRow 2653 2654 ^ self new 2655 listDirection: #leftToRight; 2656 hResizing: #spaceFill; 2657 vResizing: #spaceFill; 2658 extent: 1@1; 2659 borderWidth: 0 2660! ! 2661 2662!AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:37'! 2663newSpacer: aColor 2664 "Answer a space-filling instance of me of the given color." 2665 2666 ^ self new 2667 hResizing: #spaceFill; 2668 vResizing: #spaceFill; 2669 layoutInset: 0; 2670 borderWidth: 0; 2671 extent: 1@1; 2672 color: aColor. 2673! ! 2674 2675!AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:37'! 2676newVariableTransparentSpacer 2677 "Answer a space-filling instance of me of the given color." 2678 2679 ^ self new 2680 hResizing: #spaceFill; 2681 vResizing: #spaceFill; 2682 layoutInset: 0; 2683 borderWidth: 0; 2684 extent: 1@1; 2685 color: Color transparent 2686! ! 2687 2688!AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'! 2689rowPrototype 2690 "Answer a prototypical row" 2691 2692 | sampleMorphs aRow | 2693 sampleMorphs := (1 to: (2 + 3 atRandom)) collect: 2694 [:integer | EllipseMorph new extent: ((60 + (20 atRandom)) @ (80 + ((20 atRandom)))); color: Color random; setNameTo: ('egg', integer asString); yourself]. 2695 aRow := self inARow: sampleMorphs. 2696 aRow setNameTo: 'Row'. 2697 aRow enableDragNDrop. 2698 aRow cellInset: 6. 2699 aRow layoutInset: 8. 2700 aRow setBalloonText: 'Things dropped into here will automatically be organized into a row. Once you have added your own items here, you will want to remove the sample colored eggs that this started with, and you will want to change this balloon help message to one of your own!!' translated. 2701 aRow color: Color veryVeryLightGray. 2702 ^ aRow 2703 2704 "AlignmentMorph rowPrototype openInHand"! ! 2705 2706 2707!AlignmentMorph class methodsFor: 'scripting' stamp: 'sw 11/16/2004 00:44'! 2708defaultNameStemForInstances 2709 "The code just below, now commented out, resulted in every instance of every sublcass of AlignmentMorph being given a default name of the form 'Alignment1', rather than the desired 'MoviePlayer1', 'ScriptEditor2', etc." 2710 2711 "^ 'Alignment'" 2712 2713 ^ super defaultNameStemForInstances! ! 2714ColorMappingCanvas subclass: #AlphaBlendingCanvas 2715 instanceVariableNames: 'alpha' 2716 classVariableNames: '' 2717 poolDictionaries: '' 2718 category: 'Morphic-Support'! 2719 2720!AlphaBlendingCanvas methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/1/2008 16:31'! 2721image: aForm at: aPoint sourceRect: sourceRect rule: rule 2722 "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle. 2723 Do a blendAlpha if the rule is blend to cope with translucent images being drawn (via translucentImage:...)." 2724 2725 rule = Form paint ifTrue:[ 2726 ^myCanvas 2727 image: aForm 2728 at: aPoint 2729 sourceRect: sourceRect 2730 rule: Form paintAlpha 2731 alpha: alpha. 2732 ]. 2733 rule = Form over ifTrue:[ 2734 ^myCanvas 2735 image: aForm 2736 at: aPoint 2737 sourceRect: sourceRect 2738 rule: Form blendAlpha 2739 alpha: alpha. 2740 ]. 2741 rule = Form blend ifTrue:[ 2742 ^myCanvas 2743 image: aForm 2744 at: aPoint 2745 sourceRect: sourceRect 2746 rule: Form blendAlpha 2747 alpha: alpha. 2748 ].! ! 2749 2750 2751!AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! 2752alpha 2753 ^alpha! ! 2754 2755!AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! 2756alpha: newAlpha 2757 alpha := newAlpha.! ! 2758 2759 2760!AlphaBlendingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:18'! 2761on: aCanvas 2762 myCanvas := aCanvas. 2763 alpha := 1.0.! ! 2764 2765 2766!AlphaBlendingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:23'! 2767mapColor: aColor 2768 aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..." 2769 aColor isTransparent ifTrue:[^aColor]. 2770 aColor isOpaque ifTrue:[^aColor alpha: alpha]. 2771 ^aColor alpha: (aColor alpha * alpha)! ! 2772ImageMorph subclass: #AlphaImageMorph 2773 instanceVariableNames: 'alpha cachedForm layout scale enabled' 2774 classVariableNames: 'DefaultImage' 2775 poolDictionaries: '' 2776 category: 'Polymorph-Widgets'! 2777!AlphaImageMorph commentStamp: 'gvc 5/18/2007 13:52' prior: 0! 2778Displays an image with the specified alpha value (translucency) and optional scale and layout (scaled, top-right etc.).! 2779 2780 2781!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/26/2006 09:40'! 2782alpha 2783 "Answer the value of alpha" 2784 2785 ^ alpha! ! 2786 2787!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:34'! 2788alpha: anObject 2789 "Set the value of alpha" 2790 2791 alpha := anObject. 2792 self 2793 cachedForm: nil; 2794 changed; 2795 changed: #alpha! ! 2796 2797!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:58'! 2798cachedForm 2799 "Answer the value of cachedForm" 2800 2801 |form i effectiveAlpha| 2802 cachedForm ifNil: [ 2803 i := self image. 2804 self layout == #scaled 2805 ifTrue: [self extent = i extent 2806 ifFalse: [i := i magnify: i boundingBox by: (self extent / i extent) smoothing: 2]] 2807 ifFalse: [self scale ~= 1 2808 ifTrue: [i := i magnify: i boundingBox by: self scale smoothing: 2]]. 2809 effectiveAlpha := self enabled 2810 ifTrue: [self alpha] 2811 ifFalse: [self alpha / 2]. 2812 effectiveAlpha = 1.0 2813 ifTrue: [self cachedForm: i] 2814 ifFalse: [form := Form extent: i extent depth: 32. 2815 form fillColor: (Color white alpha: 0.003922). 2816 (form getCanvas asAlphaBlendingCanvas: effectiveAlpha) 2817 drawImage: i 2818 at: 0@0. 2819 self cachedForm: form]]. 2820 ^cachedForm! ! 2821 2822!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/27/2006 15:02'! 2823cachedForm: anObject 2824 "Set the value of cachedForm" 2825 2826 cachedForm := anObject! ! 2827 2828!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:56'! 2829enabled 2830 "Answer the value of enabled" 2831 2832 ^enabled! ! 2833 2834!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:57'! 2835enabled: anObject 2836 "Set the value of enabled" 2837 2838 enabled := anObject. 2839 self 2840 cachedForm: nil; 2841 changed! ! 2842 2843!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/28/2006 14:15'! 2844image: anImage 2845 "Clear the cached form." 2846 2847 ^self image: anImage size: anImage extent! ! 2848 2849!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/27/2009 16:14'! 2850image: aForm size: aPoint 2851 "Set the image to be the form scaled to the given size and padded if neccesary." 2852 2853 |f f2| 2854 f := aForm scaledToSize: aPoint. 2855 (f depth < 32 and: [f depth > 4]) 2856 ifTrue: [f2 := Form extent: aPoint depth: 32. 2857 f2 fillColor: (Color white alpha: 0.003922). 2858 f2 getCanvas translucentImage: f at: 0@0. 2859 f2 fixAlpha] 2860 ifFalse: [f2 := f]. 2861 self cachedForm: nil. 2862 super image: f2. 2863 self extent: aPoint + (self borderWidth * 2). 2864 self changed: #imageExtent! ! 2865 2866!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 6/30/2009 16:02'! 2867imageExtent 2868 "Answer the extent of the original form." 2869 2870 ^self image extent! ! 2871 2872!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 10/11/2006 12:00'! 2873layout 2874 "Answer the value of layout" 2875 2876 ^ layout! ! 2877 2878!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:28'! 2879layout: aSymbol 2880 "Set the value of layout" 2881 2882 |old| 2883 (old := layout) = aSymbol ifTrue: [^self]. 2884 layout := aSymbol. 2885 (old = #scaled or: [aSymbol = #scaled]) 2886 ifTrue: [self cachedForm: nil]. 2887 self changed! ! 2888 2889!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 16:10'! 2890layoutSymbols 2891 "Answer the available layout options." 2892 2893 ^#(#center #tiled #scaled 2894 #topLeft #topCenter #topRight #rightCenter 2895 #bottomRight #bottomCenter #bottomLeft #leftCenter)! ! 2896 2897!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 10/11/2006 12:43'! 2898scale 2899 "Answer the value of scale" 2900 2901 ^ scale! ! 2902 2903!AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:34'! 2904scale: aNumber 2905 "Set the value of scale" 2906 2907 scale = aNumber ifTrue: [^self]. 2908 scale := aNumber. 2909 self 2910 cachedForm: nil; 2911 changed; 2912 changed: #scale! ! 2913 2914 2915!AlphaImageMorph methodsFor: 'drawing' stamp: 'gvc 8/8/2007 16:25'! 2916drawOn: aCanvas 2917 "Draw with the current alpha 2918 Can't do simple way since BitBlt rules are dodgy!!." 2919 2920 aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle. 2921 (self cachedForm width = 0 or: [self cachedForm height = 0]) ifTrue: [^self]. 2922 self layout == #tiled 2923 ifTrue: [aCanvas fillRectangle: self innerBounds fillStyle: (AlphaInfiniteForm with: self cachedForm)] 2924 ifFalse: [aCanvas clipBy: self innerBounds during: [:c | 2925 c translucentImage: self cachedForm at: self layoutPosition]]! ! 2926 2927 2928!AlphaImageMorph methodsFor: 'geometry' stamp: 'gvc 10/11/2006 12:02'! 2929extent: aPoint 2930 "Allow as normal." 2931 2932 self perform: #extent: withArguments: {aPoint} inSuperclass: Morph 2933! ! 2934 2935!AlphaImageMorph methodsFor: 'geometry' stamp: 'gvc 8/8/2007 16:09'! 2936layoutPosition 2937 "Answer the position that the cached form should be drawn 2938 based on the layout" 2939 2940 self layout == #topCenter ifTrue: [^self innerBounds topCenter - (self cachedForm width // 2 @ 0)]. 2941 self layout == #topRight ifTrue: [^self innerBounds topRight - (self cachedForm width @ 0)]. 2942 self layout == #rightCenter ifTrue: [^self innerBounds rightCenter - (self cachedForm width @ (self cachedForm height // 2))]. 2943 self layout == #bottomRight ifTrue: [^self innerBounds bottomRight - self cachedForm extent]. 2944 self layout == #bottomCenter ifTrue: [^self innerBounds bottomCenter - (self cachedForm width // 2 @ self cachedForm height)]. 2945 self layout == #bottomLeft ifTrue: [^self innerBounds bottomLeft - (0 @ self cachedForm height)]. 2946 self layout == #leftCenter ifTrue: [^self innerBounds leftCenter - (0 @ (self cachedForm height // 2))]. 2947 self layout == #center ifTrue: [^self innerBounds center - (self cachedForm extent // 2)]. 2948 ^self innerBounds topLeft! ! 2949 2950!AlphaImageMorph methodsFor: 'geometry' stamp: 'gvc 10/22/2007 11:51'! 2951optimalExtent 2952 "Answer the optimal extent for the receiver." 2953 2954 ^self image extent * self scale + (self borderWidth * 2)! ! 2955 2956 2957!AlphaImageMorph methodsFor: 'initialization' stamp: 'gvc 9/26/2006 12:40'! 2958defaultColor 2959 "Answer the default color for the receiver." 2960 2961 ^Color transparent! ! 2962 2963!AlphaImageMorph methodsFor: 'initialization' stamp: 'gvc 12/3/2007 11:37'! 2964defaultImage 2965 "Answer the default image for the receiver." 2966 2967 ^DefaultImage ifNil: [DefaultImage := DefaultForm asFormOfDepth: 32]! ! 2968 2969!AlphaImageMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:37'! 2970initialize 2971 "Initialize the receiver. 2972 Use the 32 bit depth default image to avoid 2973 unnecessary conversions." 2974 2975 super initialize. 2976 enabled := true. 2977 self 2978 scale: 1.0; 2979 layout: #topLeft; 2980 alpha: 1.0! ! 2981InfiniteForm subclass: #AlphaInfiniteForm 2982 instanceVariableNames: 'origin extent' 2983 classVariableNames: '' 2984 poolDictionaries: '' 2985 category: 'Polymorph-Widgets-FillStyles'! 2986!AlphaInfiniteForm commentStamp: 'gvc 5/18/2007 13:49' prior: 0! 2987Alpha aware InfiniteForm.! 2988 2989 2990!AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/7/2008 14:00'! 2991extent 2992 "Answer the extent of the repeating area." 2993 2994 ^extent ifNil: [SmallInteger maxVal @ SmallInteger maxVal]! ! 2995 2996!AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:48'! 2997extent: anObject 2998 "Set the value of extent" 2999 3000 extent := anObject! ! 3001 3002!AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:42'! 3003origin 3004 "Answer the origin." 3005 3006 ^origin ifNil: [0@0]! ! 3007 3008!AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:42'! 3009origin: aPoint 3010 "Set the origin." 3011 3012 origin := aPoint! ! 3013 3014 3015!AlphaInfiniteForm methodsFor: 'as yet unclassified' stamp: 'gvc 12/3/2008 17:09'! 3016direction: aPoint 3017 "Ignore" 3018! ! 3019 3020 3021!AlphaInfiniteForm methodsFor: 'displaying' stamp: 'gvc 10/7/2008 13:59'! 3022computeBoundingBox 3023 "Refer to the comment in DisplayObject|computeBoundingBox." 3024 3025 ^self origin extent: self extent! ! 3026 3027!AlphaInfiniteForm methodsFor: 'displaying' stamp: 'gvc 8/10/2009 11:42'! 3028displayOnPort: aPort offsetBy: offset 3029 3030 | targetBox patternBox savedMap top left | 3031 3032 aPort destForm depth < 32 ifTrue: [^super displayOnPort: aPort offsetBy: offset]. 3033 "this version tries to get the form aligned where the user wants it and not just aligned with the cliprect" 3034 3035 (patternForm isForm) ifFalse: [ 3036 "patternForm is a Pattern or Color; just use it as a mask for BitBlt" 3037 ^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over]. 3038 3039 "do it iteratively" 3040 targetBox := aPort clipRect. 3041 patternBox := patternForm boundingBox. 3042 savedMap := aPort colorMap. 3043 aPort sourceForm: patternForm; 3044 fillColor: nil; 3045 combinationRule: Form blend; 3046 sourceRect: (0@0 extent: patternBox extent); 3047 colorMap: (patternForm colormapIfNeededFor: aPort destForm). 3048 top := (targetBox top truncateTo: patternBox height) + offset y. 3049 left := (targetBox left truncateTo: patternBox width) + offset x. 3050 3051 left to: (targetBox right - 1) by: patternBox width do: 3052 [:x | top to: (targetBox bottom - 1) by: patternBox height do: 3053 [:y | aPort destOrigin: x@y; copyBits]]. 3054 aPort colorMap: savedMap. 3055! ! 3056GIFReadWriter subclass: #AnimatedGIFReadWriter 3057 instanceVariableNames: 'forms delays comments' 3058 classVariableNames: '' 3059 poolDictionaries: '' 3060 category: 'Graphics-Files'! 3061 3062!AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 3063allImages 3064 | body colorTable | 3065 stream class == ReadWriteStream ifFalse: 3066 [ stream binary. 3067 self on: (ReadWriteStream with: stream contentsOfEntireFile) ]. 3068 localColorTable := nil. 3069 forms := OrderedCollection new. 3070 delays := OrderedCollection new. 3071 comments := OrderedCollection new. 3072 self readHeader. 3073 [ (body := self readBody) isNil ] whileFalse: 3074 [ colorTable := localColorTable ifNil: [ colorPalette ]. 3075 transparentIndex ifNotNil: 3076 [ transparentIndex + 1 > colorTable size ifTrue: 3077 [ colorTable := colorTable 3078 forceTo: transparentIndex + 1 3079 paddingWith: Color white ]. 3080 colorTable 3081 at: transparentIndex + 1 3082 put: Color transparent ]. 3083 body colors: colorTable. 3084 forms add: body. 3085 delays add: delay ]. 3086 ^ forms! ! 3087 3088!AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'! 3089delays 3090 ^ delays! ! 3091 3092!AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'! 3093forms 3094 ^ forms! ! 3095 3096 3097!AnimatedGIFReadWriter methodsFor: 'private' stamp: 'mir 11/19/2003 12:25'! 3098comment: aString 3099 comments add: aString! ! 3100 3101 3102!AnimatedGIFReadWriter methodsFor: 'private-decoding' stamp: 'mir 11/19/2003 12:21'! 3103readBitData 3104 | form | 3105 form := super readBitData. 3106 form offset: offset. 3107 ^form! ! 3108 3109"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 3110 3111AnimatedGIFReadWriter class 3112 instanceVariableNames: ''! 3113 3114!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! 3115formsFromFileNamed: fileName 3116 | stream | 3117 stream := FileStream readOnlyFileNamed: fileName. 3118 ^ self formsFromStream: stream! ! 3119 3120!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! 3121formsFromStream: stream 3122 | reader | 3123 reader := self new on: stream reset. 3124 Cursor read showWhile: 3125 [ reader allImages. 3126 reader close ]. 3127 ^ reader! ! 3128 3129!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 6/12/2004 13:12'! 3130typicalFileExtensions 3131 "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" 3132 ^#('gif')! ! 3133 3134!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! 3135wantsToHandleGIFs 3136 ^true! ! 3137Object subclass: #Announcement 3138 instanceVariableNames: '' 3139 classVariableNames: '' 3140 poolDictionaries: '' 3141 category: 'Announcements-Core'! 3142 3143!Announcement methodsFor: '*announcements-view' stamp: 'lr 9/3/2006 16:17'! 3144open 3145 self inspect! ! 3146 3147 3148!Announcement methodsFor: 'converting' stamp: 'lr 10/3/2006 14:32'! 3149asAnnouncement 3150 ^ self! ! 3151 3152"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 3153 3154Announcement class 3155 instanceVariableNames: ''! 3156 3157!Announcement class methodsFor: 'converting' stamp: 'lr 10/3/2006 14:31'! 3158asAnnouncement 3159 ^ self new! ! 3160 3161 3162!Announcement class methodsFor: 'public' stamp: 'lr 9/20/2006 08:18'! 3163, anAnnouncementClass 3164 ^ AnnouncementSet with: self with: anAnnouncementClass! ! 3165 3166 3167!Announcement class methodsFor: 'testing' stamp: 'lr 10/3/2006 14:31'! 3168handles: anAnnouncementClass 3169 ^ anAnnouncementClass isKindOf: self! ! 3170Announcement subclass: #AnnouncementMockA 3171 instanceVariableNames: '' 3172 classVariableNames: '' 3173 poolDictionaries: '' 3174 category: 'Tests-Announcements'! 3175Announcement subclass: #AnnouncementMockB 3176 instanceVariableNames: '' 3177 classVariableNames: '' 3178 poolDictionaries: '' 3179 category: 'Tests-Announcements'! 3180AnnouncementMockB subclass: #AnnouncementMockC 3181 instanceVariableNames: '' 3182 classVariableNames: '' 3183 poolDictionaries: '' 3184 category: 'Tests-Announcements'! 3185Set subclass: #AnnouncementSet 3186 instanceVariableNames: '' 3187 classVariableNames: '' 3188 poolDictionaries: '' 3189 category: 'Announcements-Core'! 3190 3191!AnnouncementSet methodsFor: 'adding' stamp: 'lr 6/13/2006 08:13'! 3192, anAnnouncementClass 3193 self add: anAnnouncementClass! ! 3194 3195 3196!AnnouncementSet methodsFor: 'testing' stamp: 'lr 10/3/2006 14:31'! 3197handles: anAnnouncementClass 3198 ^ self anySatisfy: [ :each | each handles: anAnnouncementClass ]! ! 3199Object subclass: #AnnouncementSpy 3200 instanceVariableNames: 'announcer announcements index' 3201 classVariableNames: '' 3202 poolDictionaries: '' 3203 category: 'Announcements-View'! 3204 3205!AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:02'! 3206announcements 3207 ^ announcements! ! 3208 3209!AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 9/3/2006 14:08'! 3210announcements: aCollection 3211 announcements := aCollection. 3212 self changed: #announcements! ! 3213 3214!AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:04'! 3215announcer 3216 ^ announcer! ! 3217 3218!AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 9/25/2006 09:26'! 3219announcer: anAnnouncer 3220 announcer ifNotNil: [ announcer unsubscribe: self ]. 3221 announcer := anAnnouncer. 3222 announcer ifNotNil: [ announcer subscribe: Announcement send: #announce: to: self ]! ! 3223 3224!AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:02'! 3225index 3226 ^ index ! ! 3227 3228!AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:20'! 3229index: anInteger 3230 index := anInteger. 3231 self changed: #index! ! 3232 3233 3234!AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'lr 9/3/2006 14:08'! 3235extent 3236 ^ 250 @ 400! ! 3237 3238!AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'lr 6/14/2006 17:03'! 3239label 3240 ^ self announcer printString! ! 3241 3242 3243!AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/3/2006 16:21'! 3244clear 3245 self announcements: OrderedCollection new! ! 3246 3247!AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/25/2006 09:19'! 3248close 3249 self announcer: nil! ! 3250 3251!AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/25/2006 09:25'! 3252open 3253 (self announcements at: self index ifAbsent: [ ^ self ]) 3254 open! ! 3255 3256 3257!AnnouncementSpy methodsFor: 'building' stamp: 'lr 9/3/2006 16:21'! 3258buildMenu: aMenuMorph 3259 ^ aMenuMorph 3260 defaultTarget: self; 3261 add: 'open' action: #open; 3262 add: 'clear' action: #clear; 3263 yourself! ! 3264 3265!AnnouncementSpy methodsFor: 'building' stamp: 'lr 9/25/2006 09:20'! 3266buildWith: aBuilder 3267 ^ aBuilder build: (aBuilder pluggableWindowSpec new 3268 model: self; 3269 label: self label; 3270 extent: self extent; 3271 closeAction: #close; 3272 children: (OrderedCollection new 3273 add: (aBuilder pluggableListSpec new 3274 model: self; 3275 list: #announcements; 3276 menu: #buildMenu:; 3277 getIndex: #index; 3278 setIndex: #index:; 3279 frame: (0 @ 0 corner: 1 @ 1); 3280 yourself); 3281 yourself); 3282 yourself)! ! 3283 3284 3285!AnnouncementSpy methodsFor: 'initialization' stamp: 'lr 6/14/2006 17:03'! 3286initialize 3287 super initialize. 3288 self announcements: OrderedCollection new. 3289 self index: 0! ! 3290 3291 3292!AnnouncementSpy methodsFor: 'private' stamp: 'lr 9/3/2006 14:09'! 3293announce: anAnnouncement 3294 self announcements add: anAnnouncement. 3295 self index: self announcements size. 3296 self changed: #announcements! ! 3297 3298!AnnouncementSpy methodsFor: 'private' stamp: 'lr 6/14/2006 17:19'! 3299changed: aSymbol 3300 WorldState addDeferredUIMessage: [ super changed: aSymbol ]! ! 3301 3302!AnnouncementSpy methodsFor: 'private' stamp: 'lr 6/14/2006 17:29'! 3303perform: selector orSendTo: otherTarget 3304 ^ (self respondsTo: selector) 3305 ifTrue: [ self perform: selector ] 3306 ifFalse: [ super perform: selector orSendTo: otherTarget ]! ! 3307 3308"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 3309 3310AnnouncementSpy class 3311 instanceVariableNames: ''! 3312 3313!AnnouncementSpy class methodsFor: 'instance-creation' stamp: 'lr 6/14/2006 17:05'! 3314on: anAnnouncer 3315 ^ self new 3316 announcer: anAnnouncer; 3317 yourself! ! 3318 3319!AnnouncementSpy class methodsFor: 'instance-creation' stamp: 'lr 6/14/2006 17:05'! 3320openOn: anAnnouncer 3321 ToolBuilder open: (self on: anAnnouncer)! ! 3322Object subclass: #Announcer 3323 instanceVariableNames: 'subscriptions' 3324 classVariableNames: '' 3325 poolDictionaries: '' 3326 category: 'Announcements-Core'! 3327!Announcer commentStamp: 'lr 3/2/2009 10:27' prior: 0! 3328The code is based on the announcements as described by Vassili Bykov in <http://www.cincomsmalltalk.com/userblogs/vbykov/blogView?searchCategory=Announcements%20Framework>. The implementation is a slightly extended and generalized version of the code found in OmniBrowser by Colin Putney.! 3329 3330 3331!Announcer methodsFor: '*announcements-view' stamp: 'lr 9/20/2006 08:18'! 3332open 3333 AnnouncementSpy openOn: self! ! 3334 3335 3336!Announcer methodsFor: 'announce' stamp: 'lr 8/5/2008 12:06'! 3337announce: anAnnouncement 3338 | announcement | 3339 announcement := anAnnouncement asAnnouncement. 3340 subscriptions ifNil: [ ^ announcement ]. 3341 subscriptions keysAndValuesDo: [ :class :actions | 3342 (class handles: announcement) 3343 ifTrue: [ actions valueWithArguments: (Array with: announcement) ] ]. 3344 ^ announcement! ! 3345 3346 3347!Announcer methodsFor: 'convenience' stamp: 'lr 10/27/2006 14:26'! 3348on: anAnnouncementClass do: aValuable 3349 ^ self subscribe: anAnnouncementClass do: aValuable! ! 3350 3351!Announcer methodsFor: 'convenience' stamp: 'lr 10/27/2006 14:27'! 3352on: anAnnouncementClass send: aSelector to: anObject 3353 ^ self subscribe: anAnnouncementClass send: aSelector to: anObject! ! 3354 3355!Announcer methodsFor: 'convenience' stamp: 'tg 2/25/2009 12:05'! 3356when: anAnnouncementClass do: aValuable 3357 ^ self subscribe: anAnnouncementClass do: aValuable! ! 3358 3359 3360!Announcer methodsFor: 'subscription' stamp: 'lr 8/5/2008 12:05'! 3361subscribe: anAnnouncementClass do: aValuable 3362 | actions | 3363 subscriptions ifNil: [ subscriptions := IdentityDictionary new ]. 3364 actions := subscriptions at: anAnnouncementClass ifAbsent: [ ActionSequence new ]. 3365 subscriptions at: anAnnouncementClass put: (actions copyWith: aValuable). 3366 ^ aValuable! ! 3367 3368!Announcer methodsFor: 'subscription' stamp: 'lr 10/27/2006 14:27'! 3369subscribe: anAnnouncementClass send: aSelector to: anObject 3370 ^ self subscribe: anAnnouncementClass do: (MessageSend receiver: anObject selector: aSelector)! ! 3371 3372!Announcer methodsFor: 'subscription' stamp: 'lr 8/5/2008 12:05'! 3373unsubscribe: anObject 3374 subscriptions ifNil: [ ^ self ]. 3375 subscriptions keysAndValuesDo: [ :class :actions | 3376 subscriptions at: class put: (actions 3377 reject: [ :each | each receiver == anObject ]) ]. 3378 subscriptions keysAndValuesRemove: [ :class :actions | 3379 actions isEmpty ]! ! 3380 3381"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 3382 3383Announcer class 3384 instanceVariableNames: ''! 3385TestCase subclass: #AnnouncerTest 3386 instanceVariableNames: 'announcer' 3387 classVariableNames: '' 3388 poolDictionaries: '' 3389 category: 'Tests-Announcements'! 3390 3391!AnnouncerTest methodsFor: 'running' stamp: 'lr 9/25/2006 08:42'! 3392setUp 3393 announcer := Announcer new! ! 3394 3395 3396!AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:11'! 3397testAnnounceClass 3398 self assert: (announcer announce: AnnouncementMockA) 3399 class = AnnouncementMockA! ! 3400 3401!AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:10'! 3402testAnnounceInstance 3403 | instance | 3404 instance := AnnouncementMockA new. 3405 self assert: (announcer announce: instance) = instance! ! 3406 3407!AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:08'! 3408testSubscribeBlock 3409 | announcement instance | 3410 announcer 3411 subscribe: AnnouncementMockA 3412 do: [ :ann | announcement := ann ]. 3413 3414 announcement := nil. 3415 instance := announcer announce: AnnouncementMockA. 3416 self assert: announcement = instance. 3417 3418 announcement := nil. 3419 instance := announcer announce: AnnouncementMockB. 3420 self assert: announcement isNil! ! 3421 3422!AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:07'! 3423testSubscribeSend 3424 | announcement instance | 3425 announcer 3426 subscribe: AnnouncementMockA 3427 send: #value: 3428 to: [ :ann | announcement := ann ]. 3429 3430 announcement := nil. 3431 instance := announcer announce: AnnouncementMockA. 3432 self assert: announcement = instance. 3433 3434 announcement := nil. 3435 instance := announcer announce: AnnouncementMockB new. 3436 self assert: announcement isNil! ! 3437 3438!AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:07'! 3439testSubscribeSet 3440 | announcement instance | 3441 announcer 3442 subscribe: AnnouncementMockA , AnnouncementMockC 3443 do: [ :ann | announcement := ann ]. 3444 3445 announcement := nil. 3446 instance := announcer announce: AnnouncementMockA. 3447 self assert: announcement = instance. 3448 3449 announcement := nil. 3450 instance := announcer announce: AnnouncementMockB. 3451 self assert: announcement isNil. 3452 3453 announcement := nil. 3454 instance := announcer announce: AnnouncementMockC. 3455 self assert: announcement = instance! ! 3456 3457!AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:06'! 3458testSubscribeSubclass 3459 | announcement instance | 3460 announcer 3461 subscribe: AnnouncementMockB 3462 do: [ :ann | announcement := ann ]. 3463 3464 announcement := nil. 3465 instance := announcer announce: AnnouncementMockA. 3466 self assert: announcement isNil. 3467 3468 announcement := nil. 3469 instance := announcer announce: AnnouncementMockB. 3470 self assert: announcement = instance. 3471 3472 announcement := nil. 3473 instance := announcer announce: AnnouncementMockC. 3474 self assert: announcement = instance.! ! 3475 3476!AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:10'! 3477testUnsubscribeBlock 3478 | announcement | 3479 announcer 3480 subscribe: AnnouncementMockA 3481 do: [ :ann | announcement := ann ]. 3482 announcer 3483 unsubscribe: self. 3484 3485 announcement := nil. 3486 announcer announce: AnnouncementMockA new. 3487 self assert: announcement isNil! ! 3488 3489!AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:13'! 3490testUnsubscribeSend 3491 | announcement receiver | 3492 announcer 3493 subscribe: AnnouncementMockA 3494 send: #value: 3495 to: (receiver := [ :ann | announcement := ann ]). 3496 announcer 3497 unsubscribe: receiver. 3498 3499 announcement := nil. 3500 announcer announce: AnnouncementMockA new. 3501 self assert: announcement isNil! ! 3502 3503!AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:13'! 3504testUnsubscribeSet 3505 | announcement | 3506 announcer 3507 subscribe: AnnouncementMockA , AnnouncementMockB 3508 do: [ :ann | announcement := ann ]. 3509 announcer 3510 unsubscribe: self. 3511 3512 announcement := nil. 3513 announcer announce: AnnouncementMockA new. 3514 self assert: announcement isNil. 3515 3516 announcement := nil. 3517 announcer announce: AnnouncementMockB new. 3518 self assert: announcement isNil.! ! 3519Object subclass: #AppRegistry 3520 instanceVariableNames: '' 3521 classVariableNames: '' 3522 poolDictionaries: '' 3523 category: 'System-Applications'! 3524!AppRegistry commentStamp: 'ads 4/2/2003 15:30' prior: 0! 3525AppRegistry is a simple little class, not much more than a wrapper around a collection. It's intended to help break dependencies between packages. For example, if you'd like to be able to send e-mail, you could use the bare-bones MailComposition class, or you could use the full-blown Celeste e-mail client. Instead of choosing one or the other, you can call "MailSender default" (where MailSender is a subclass of AppRegistry), and thus avoid creating a hard-coded dependency on either of the two mail senders. 3526 3527This will only really be useful, of course, for applications that have a very simple, general, well-defined interface. Most of the time, you're probably better off just marking your package as being dependent on a specific other package, and avoiding the hassle of this whole AppRegistry thing. But for simple things like e-mail senders or web browsers, it might be useful. 3528! 3529 3530 3531!AppRegistry methodsFor: 'notes' stamp: 'ads 4/2/2003 15:04'! 3532seeClassSide 3533 "All the code for AppRegistry is on the class side."! ! 3534 3535"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 3536 3537AppRegistry class 3538 instanceVariableNames: 'registeredClasses default'! 3539 3540!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:36'! 3541appName 3542 "Defaults to the class name, which is probably good enough, but you could override this in subclasses if you want to." 3543 ^ self name! ! 3544 3545!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'alain.plantec 2/8/2009 21:37'! 3546askForDefault 3547 "self askForDefault" 3548 self registeredClasses isEmpty ifTrue: 3549 [self inform: 'There are no ', self appName, ' applications registered.'. 3550 ^ default := nil]. 3551 self registeredClasses size = 1 ifTrue: 3552 [^ default := self registeredClasses anyOne]. 3553 3554 default := UIManager default 3555 chooseFrom: (self registeredClasses collect: [:c | c name]) 3556 values: self registeredClasses 3557 title: ('Which ' , self appName, ' would you prefer?') translated. 3558 default ifNil: [default := self registeredClasses first]. 3559 ^default.! ! 3560 3561!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:11'! 3562default 3563 ^ default ifNil: [self askForDefault]! ! 3564 3565!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'nk 3/9/2004 12:33'! 3566default: aClassOrNil 3567 "Sets my default to aClassOrNil. 3568 Answers the old default." 3569 | oldDefault | 3570 oldDefault := default. 3571 aClassOrNil ifNotNil: [ self register: aClassOrNil ]. 3572 default := aClassOrNil. 3573 ^ oldDefault! ! 3574 3575!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'nk 3/9/2004 12:35'! 3576defaultOrNil 3577 ^ default! ! 3578 3579!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 4/2/2003 15:25'! 3580register: aProviderClass 3581 (self registeredClasses includes: aProviderClass) ifFalse: 3582 [default := nil. "so it'll ask for a new default, since if you're registering a new app you probably want to use it" 3583 self registeredClasses add: aProviderClass].! ! 3584 3585!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:01'! 3586registeredClasses 3587 ^ registeredClasses ifNil: [registeredClasses := OrderedCollection new]! ! 3588 3589!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ar 9/27/2005 21:48'! 3590removeObsolete 3591 "AppRegistry removeObsoleteClasses" 3592 self registeredClasses copy do:[:cls| 3593 (cls class isObsolete or:[cls isBehavior and:[cls isObsolete]]) 3594 ifTrue:[self unregister: cls]]. 3595 self subclasses do:[:cls| cls removeObsolete].! ! 3596 3597!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:03'! 3598unregister: aProviderClass 3599 (default = aProviderClass) ifTrue: [default := nil]. 3600 self registeredClasses remove: aProviderClass ifAbsent: [].! ! 3601Path subclass: #Arc 3602 instanceVariableNames: 'quadrant radius center' 3603 classVariableNames: '' 3604 poolDictionaries: '' 3605 category: 'ST80-Paths'! 3606!Arc commentStamp: '<historical>' prior: 0! 3607Arcs are an unusual implementation of splines due to Ted Kaehler. Imagine two lines that meet at a corner. Now imagine two moving points; one moves from the corner to the end on one line, the other moves from the end of the other line in to the corner. Now imagine a series of lines drawn between those moving points at each step along the way (they form a sort of spider web pattern). By connecting segments of the intersecting lines, a smooth curve is achieved that is tangent to both of the original lines. Voila.! 3608 3609 3610!Arc methodsFor: 'accessing'! 3611center 3612 "Answer the point at the center of the receiver." 3613 3614 ^center! ! 3615 3616!Arc methodsFor: 'accessing'! 3617center: aPoint 3618 "Set aPoint to be the receiver's center." 3619 3620 center := aPoint! ! 3621 3622!Arc methodsFor: 'accessing'! 3623center: aPoint radius: anInteger 3624 "The receiver is defined by a point at the center and a radius. The 3625 quadrant is not reset." 3626 3627 center := aPoint. 3628 radius := anInteger! ! 3629 3630!Arc methodsFor: 'accessing'! 3631center: aPoint radius: anInteger quadrant: section 3632 "Set the receiver's quadrant to be the argument, section. The size of the 3633 receiver is defined by the center and its radius." 3634 3635 center := aPoint. 3636 radius := anInteger. 3637 quadrant := section! ! 3638 3639!Arc methodsFor: 'accessing'! 3640quadrant 3641 "Answer the part of the circle represented by the receiver." 3642 ^quadrant! ! 3643 3644!Arc methodsFor: 'accessing'! 3645quadrant: section 3646 "Set the part of the circle represented by the receiver to be the argument, 3647 section." 3648 3649 quadrant := section! ! 3650 3651!Arc methodsFor: 'accessing'! 3652radius 3653 "Answer the receiver's radius." 3654 3655 ^radius! ! 3656 3657!Arc methodsFor: 'accessing'! 3658radius: anInteger 3659 "Set the receiver's radius to be the argument, anInteger." 3660 3661 radius := anInteger! ! 3662 3663 3664!Arc methodsFor: 'display box access'! 3665computeBoundingBox 3666 | aRectangle aPoint | 3667 aRectangle := center - radius + form offset extent: form extent + (radius * 2) asPoint. 3668 aPoint := center + form extent. 3669 quadrant = 1 ifTrue: [^ aRectangle encompass: center x @ aPoint y]. 3670 quadrant = 2 ifTrue: [^ aRectangle encompass: aPoint x @ aPoint y]. 3671 quadrant = 3 ifTrue: [^ aRectangle encompass: aPoint x @ center y]. 3672 quadrant = 4 ifTrue: [^ aRectangle encompass: center x @ center y]! ! 3673 3674 3675!Arc methodsFor: 'displaying'! 3676displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm 3677 3678 | nSegments line angle sin cos xn yn xn1 yn1 | 3679 nSegments := 12.0. 3680 line := Line new. 3681 line form: self form. 3682 angle := 90.0 / nSegments. 3683 sin := (angle * (2 * Float pi / 360.0)) sin. 3684 cos := (angle * (2 * Float pi / 360.0)) cos. 3685 quadrant = 1 3686 ifTrue: 3687 [xn := radius asFloat. 3688 yn := 0.0]. 3689 quadrant = 2 3690 ifTrue: 3691 [xn := 0.0. 3692 yn := 0.0 - radius asFloat]. 3693 quadrant = 3 3694 ifTrue: 3695 [xn := 0.0 - radius asFloat. 3696 yn := 0.0]. 3697 quadrant = 4 3698 ifTrue: 3699 [xn := 0.0. 3700 yn := radius asFloat]. 3701 nSegments asInteger 3702 timesRepeat: 3703 [xn1 := xn * cos + (yn * sin). 3704 yn1 := yn * cos - (xn * sin). 3705 line beginPoint: center + (xn asInteger @ yn asInteger). 3706 line endPoint: center + (xn1 asInteger @ yn1 asInteger). 3707 line 3708 displayOn: aDisplayMedium 3709 at: aPoint 3710 clippingBox: clipRect 3711 rule: anInteger 3712 fillColor: aForm. 3713 xn := xn1. 3714 yn := yn1]! ! 3715 3716!Arc methodsFor: 'displaying'! 3717displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm 3718 3719 | newArc tempCenter | 3720 newArc := Arc new. 3721 tempCenter := aTransformation applyTo: self center. 3722 newArc center: tempCenter x asInteger @ tempCenter y asInteger. 3723 newArc quadrant: self quadrant. 3724 newArc radius: (self radius * aTransformation scale x) asInteger. 3725 newArc form: self form. 3726 newArc 3727 displayOn: aDisplayMedium 3728 at: 0 @ 0 3729 clippingBox: clipRect 3730 rule: anInteger 3731 fillColor: aForm! ! 3732 3733"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 3734 3735Arc class 3736 instanceVariableNames: ''! 3737 3738!Arc class methodsFor: 'examples'! 3739example 3740 "Click the button somewhere on the screen. The designated point will 3741 be the center of an Arc with radius 50 in the 4th quadrant." 3742 3743 | anArc aForm | 3744 aForm := Form extent: 1 @ 30. "make a long thin Form for display" 3745 aForm fillBlack. "turn it black" 3746 anArc := Arc new. 3747 anArc form: aForm. "set the form for display" 3748 anArc radius: 50.0. 3749 anArc center: Sensor waitButton. 3750 anArc quadrant: 4. 3751 anArc displayOn: Display. 3752 Sensor waitButton 3753 3754 "Arc example"! ! 3755Object subclass: #Archive 3756 instanceVariableNames: 'members' 3757 classVariableNames: '' 3758 poolDictionaries: '' 3759 category: 'Compression-Archives'! 3760!Archive commentStamp: '<historical>' prior: 0! 3761This is the abstract superclass for file archives. Archives can be read from or written to files, and contain members that represent files and directories.! 3762 3763 3764!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! 3765addDirectory: aFileName 3766 ^self addDirectory: aFileName as: aFileName 3767! ! 3768 3769!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:57'! 3770addDirectory: aFileName as: anotherFileName 3771 | newMember | 3772 newMember := self memberClass newFromDirectory: aFileName. 3773 self addMember: newMember. 3774 newMember localFileName: anotherFileName. 3775 ^newMember! ! 3776 3777!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:29'! 3778addFile: aFileName 3779 ^self addFile: aFileName as: aFileName! ! 3780 3781!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'! 3782addFile: aFileName as: anotherFileName 3783 | newMember | 3784 newMember := self memberClass newFromFile: aFileName. 3785 self addMember: newMember. 3786 newMember localFileName: anotherFileName. 3787 ^newMember! ! 3788 3789!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! 3790addMember: aMember 3791 ^members addLast: aMember! ! 3792 3793!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'! 3794addString: aString as: aFileName 3795 | newMember | 3796 newMember := self memberClass newFromString: aString named: aFileName. 3797 self addMember: newMember. 3798 newMember localFileName: aFileName. 3799 ^newMember! ! 3800 3801!Archive methodsFor: 'archive operations' stamp: 'tak 2/2/2005 13:22'! 3802addTree: aFileNameOrDirectory match: aBlock 3803 | nameSize | 3804 nameSize := aFileNameOrDirectory isString 3805 ifTrue: [aFileNameOrDirectory size] 3806 ifFalse: [aFileNameOrDirectory pathName size]. 3807 ^ self 3808 addTree: aFileNameOrDirectory 3809 removingFirstCharacters: nameSize + 1 3810 match: aBlock! ! 3811 3812!Archive methodsFor: 'archive operations' stamp: 'tak 2/2/2005 13:00'! 3813addTree: aFileNameOrDirectory removingFirstCharacters: n 3814 ^ self 3815 addTree: aFileNameOrDirectory 3816 removingFirstCharacters: n 3817 match: [:e | true]! ! 3818 3819!Archive methodsFor: 'archive operations' stamp: 'eem 6/11/2008 12:47'! 3820addTree: aFileNameOrDirectory removingFirstCharacters: n match: aBlock 3821 | dir fullPath relativePath | 3822 dir := (aFileNameOrDirectory isString) 3823 ifTrue: [ FileDirectory on: aFileNameOrDirectory ] 3824 ifFalse: [ aFileNameOrDirectory ]. 3825 fullPath := dir pathName, dir slash. 3826 relativePath := fullPath copyFrom: n + 1 to: fullPath size. 3827 (dir entries select: [ :entry | aBlock value: entry]) 3828 do: [ :ea | | fullName newMember | 3829 fullName := fullPath, ea name. 3830 newMember := ea isDirectory 3831 ifTrue: [ self memberClass newFromDirectory: fullName ] 3832 ifFalse: [ self memberClass newFromFile: fullName ]. 3833 newMember localFileName: relativePath, ea name. 3834 self addMember: newMember. 3835 ea isDirectory ifTrue: [ self addTree: fullName removingFirstCharacters: n match: aBlock]. 3836 ]. 3837! ! 3838 3839!Archive methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:12'! 3840canWriteToFileNamed: aFileName 3841 "Catch attempts to overwrite existing zip file" 3842 ^(members anySatisfy: [ :ea | ea usesFileNamed: aFileName ]) not. 3843! ! 3844 3845!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! 3846contentsOf: aMemberOrName 3847 | member | 3848 member := self member: aMemberOrName. 3849 member ifNil: [ ^nil ]. 3850 ^member contents! ! 3851 3852!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48'! 3853extractMember: aMemberOrName 3854 | member | 3855 member := self member: aMemberOrName. 3856 member ifNil: [ ^nil ]. 3857 member extractToFileNamed: member localFileName inDirectory: FileDirectory default.! ! 3858 3859!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! 3860extractMember: aMemberOrName toFileNamed: aFileName 3861 | member | 3862 member := self member: aMemberOrName. 3863 member ifNil: [ ^nil ]. 3864 member extractToFileNamed: aFileName! ! 3865 3866!Archive methodsFor: 'archive operations' stamp: 'nk 11/11/2002 14:09'! 3867extractMemberWithoutPath: aMemberOrName 3868 self extractMemberWithoutPath: aMemberOrName inDirectory: FileDirectory default.! ! 3869 3870!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48'! 3871extractMemberWithoutPath: aMemberOrName inDirectory: dir 3872 | member | 3873 member := self member: aMemberOrName. 3874 member ifNil: [ ^nil ]. 3875 member extractToFileNamed: (FileDirectory localNameFor: member localFileName) inDirectory: dir! ! 3876 3877!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'! 3878memberNamed: aString 3879 "Return the first member whose zip name or local file name matches aString, or nil" 3880 ^members detect: [ :ea | ea fileName = aString or: [ ea localFileName = aString ]] ifNone: [ ]! ! 3881 3882!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:00'! 3883memberNames 3884 ^members collect: [ :ea | ea fileName ]! ! 3885 3886!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:58'! 3887members 3888 ^members! ! 3889 3890!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'! 3891membersMatching: aString 3892 ^members select: [ :ea | (aString match: ea fileName) or: [ aString match: ea localFileName ] ]! ! 3893 3894!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:59'! 3895numberOfMembers 3896 ^members size! ! 3897 3898!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! 3899removeMember: aMemberOrName 3900 | member | 3901 member := self member: aMemberOrName. 3902 member ifNotNil: [ members remove: member ]. 3903 ^member! ! 3904 3905!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! 3906replaceMember: aMemberOrName with: newMember 3907 | member | 3908 member := self member: aMemberOrName. 3909 member ifNotNil: [ members replaceAll: member with: newMember ]. 3910 ^member! ! 3911 3912!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 17:24'! 3913setContentsOf: aMemberOrName to: aString 3914 | newMember oldMember | 3915 oldMember := self member: aMemberOrName. 3916 newMember := (self memberClass newFromString: aString named: oldMember fileName) 3917 copyFrom: oldMember. 3918 self replaceMember: oldMember with: newMember.! ! 3919 3920!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 20:58'! 3921writeTo: aStream 3922 self subclassResponsibility! ! 3923 3924!Archive methodsFor: 'archive operations' stamp: 'stephane.ducasse 8/8/2009 12:32'! 3925writeToFileNamed: aFileName 3926 | stream | 3927 "Catch attempts to overwrite existing zip file" 3928 (self canWriteToFileNamed: aFileName) 3929 ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ]. 3930 stream := StandardFileStream forceNewFileNamed: aFileName. 3931 [ self writeTo: stream ] 3932 ensure: [ stream close ]! ! 3933 3934 3935!Archive methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:39'! 3936initialize 3937 super initialize. 3938 members := OrderedCollection new.! ! 3939 3940 3941!Archive methodsFor: 'private' stamp: 'nk 2/22/2001 07:56'! 3942member: aMemberOrName 3943 ^(members includes: aMemberOrName) 3944 ifTrue: [ aMemberOrName ] 3945 ifFalse: [ self memberNamed: aMemberOrName ].! ! 3946 3947!Archive methodsFor: 'private' stamp: 'nk 2/21/2001 18:14'! 3948memberClass 3949 self subclassResponsibility! ! 3950Object subclass: #ArchiveMember 3951 instanceVariableNames: 'fileName isCorrupt' 3952 classVariableNames: '' 3953 poolDictionaries: '' 3954 category: 'Compression-Archives'! 3955!ArchiveMember commentStamp: '<historical>' prior: 0! 3956This is the abstract superclass for archive members, which are files or directories stored in archives.! 3957 3958 3959!ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! 3960fileName 3961 ^fileName! ! 3962 3963!ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! 3964fileName: aName 3965 fileName := aName! ! 3966 3967!ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:16'! 3968isCorrupt 3969 ^isCorrupt ifNil: [ isCorrupt := false ]! ! 3970 3971!ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:06'! 3972isCorrupt: aBoolean 3973 "Mark this member as being corrupt." 3974 isCorrupt := aBoolean! ! 3975 3976!ArchiveMember methodsFor: 'accessing' stamp: 'nk 12/20/2002 15:02'! 3977localFileName: aString 3978 "Set my internal filename. 3979 Returns the (possibly new) filename. 3980 aString will be translated from local FS format into Unix format." 3981 3982 ^fileName := aString copyReplaceAll: FileDirectory slash with: '/'.! ! 3983 3984 3985!ArchiveMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'! 3986close 3987! ! 3988 3989!ArchiveMember methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:39'! 3990initialize 3991 super initialize. 3992 fileName := ''. 3993 isCorrupt := false.! ! 3994 3995 3996!ArchiveMember methodsFor: 'printing' stamp: 'nk 12/20/2002 15:11'! 3997printOn: aStream 3998 super printOn: aStream. 3999 aStream nextPut: $(; 4000 nextPutAll: self fileName; 4001 nextPut: $)! ! 4002 4003 4004!ArchiveMember methodsFor: 'testing' stamp: 'nk 2/21/2001 19:43'! 4005usesFileNamed: aFileName 4006 "Do I require aFileName? That is, do I care if it's clobbered?" 4007 ^false! ! 4008 4009"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 4010 4011ArchiveMember class 4012 instanceVariableNames: ''! 4013 4014!ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:33'! 4015newDirectoryNamed: aString 4016 self subclassResponsibility! ! 4017 4018!ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! 4019newFromFile: aFileName 4020 self subclassResponsibility! ! 4021 4022!ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! 4023newFromString: aString 4024 self subclassResponsibility! ! 4025Error subclass: #ArithmeticError 4026 instanceVariableNames: '' 4027 classVariableNames: '' 4028 poolDictionaries: '' 4029 category: 'Exceptions-Kernel'! 4030ArrayedCollection variableSubclass: #Array 4031 instanceVariableNames: '' 4032 classVariableNames: '' 4033 poolDictionaries: '' 4034 category: 'Collections-Arrayed'! 4035!Array commentStamp: '<historical>' prior: 0! 4036I present an ArrayedCollection whose elements are objects.! 4037 4038 4039!Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:02'! 4040atWrap: index 4041 "Optimized to go through the primitive if possible" 4042 <primitive: 60> 4043 ^ self at: index - 1 \\ self size + 1! ! 4044 4045!Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:03'! 4046atWrap: index put: anObject 4047 "Optimized to go through the primitive if possible" 4048 <primitive: 61> 4049 ^ self at: index - 1 \\ self size + 1 put: anObject! ! 4050 4051 4052!Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:09'! 4053+* aCollection 4054 "Premultiply aCollection by self. aCollection should be an Array or Matrix. 4055 The name of this method is APL's +.x squished into Smalltalk syntax." 4056 4057 ^aCollection preMultiplyByArray: self 4058! ! 4059 4060!Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:10'! 4061preMultiplyByArray: a 4062 "Answer a+*self where a is an Array. Arrays are always understood as column vectors, 4063 so an n element Array is an n*1 Array. This multiplication is legal iff self size = 1." 4064 4065 self size = 1 ifFalse: [self error: 'dimensions do not conform']. 4066 ^a * self first! ! 4067 4068!Array methodsFor: 'arithmetic' stamp: 'eem 6/11/2008 12:49'! 4069preMultiplyByMatrix: m 4070 "Answer m+*self where m is a Matrix." 4071 4072 m columnCount = self size ifFalse: [self error: 'dimensions do not conform']. 4073 ^(1 to: m rowCount) collect: [:row | | s | 4074 s := 0. 4075 1 to: self size do: [:k | s := (m at: row at: k) * (self at: k) + s]. 4076 s]! ! 4077 4078 4079!Array methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:03'! 4080literalEqual: other 4081 4082 self class == other class ifFalse: [^ false]. 4083 self size = other size ifFalse: [^ false]. 4084 self with: other do: [:e1 :e2 | 4085 (e1 literalEqual: e2) ifFalse: [^ false]]. 4086 ^ true! ! 4087 4088 4089!Array methodsFor: 'converting' stamp: 'sma 5/12/2000 17:32'! 4090asArray 4091 "Answer with the receiver itself." 4092 4093 ^ self! ! 4094 4095!Array methodsFor: 'converting' stamp: 'tpr 11/2/2004 11:31'! 4096elementsExchangeIdentityWith: otherArray 4097 "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array. The identityHashes remain with the pointers rather than with the objects so that objects in hashed structures should still be properly indexed after the mutation." 4098 4099 <primitive: 128> 4100 otherArray class == Array ifFalse: [^ self error: 'arg must be array']. 4101 self size = otherArray size ifFalse: [^ self error: 'arrays must be same size']. 4102 (self anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. 4103 (otherArray anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. 4104 self with: otherArray do:[:a :b| a == b ifTrue:[^self error:'can''t become yourself']]. 4105 4106 "Must have failed because not enough space in forwarding table (see ObjectMemory-prepareForwardingTableForBecoming:with:twoWay:). Do GC and try again only once" 4107 (Smalltalk bytesLeft: true) = Smalltalk primitiveGarbageCollect 4108 ifTrue: [^ self primitiveFailed]. 4109 ^ self elementsExchangeIdentityWith: otherArray! ! 4110 4111!Array methodsFor: 'converting' stamp: 'di 3/28/1999 10:23'! 4112elementsForwardIdentityTo: otherArray 4113 "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation." 4114 <primitive: 72> 4115 self primitiveFailed! ! 4116 4117!Array methodsFor: 'converting' stamp: 'brp 9/26/2003 08:09'! 4118elementsForwardIdentityTo: otherArray copyHash: copyHash 4119 "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation." 4120 <primitive: 249> 4121 self primitiveFailed! ! 4122 4123!Array methodsFor: 'converting' stamp: 'nice 4/16/2009 09:35'! 4124evalStrings 4125 "Allows you to construct literal arrays. 4126 #(true false nil '5@6' 'Set new' '''text string''') evalStrings 4127 gives an array with true, false, nil, a Point, a Set, and a String 4128 instead of just a bunch of Symbols" 4129 4130 ^ self collect: [:each | | item | 4131 item := each. 4132 (each isString and: [each isSymbol not]) ifTrue: [ 4133 item := Compiler evaluate: each]. 4134 each class == Array ifTrue: [item := item evalStrings]. 4135 item]! ! 4136 4137 4138!Array methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'! 4139copyWithDependent: newElement 4140 self size = 0 ifTrue:[^DependentsArray with: newElement]. 4141 ^self copyWith: newElement! ! 4142 4143 4144!Array methodsFor: 'file in/out' stamp: 'tk 9/28/2000 15:35'! 4145objectForDataStream: refStrm 4146 | dp | 4147 "I am about to be written on an object file. If I am one of two shared global arrays, write a proxy instead." 4148 4149self == (TextConstants at: #DefaultTabsArray) ifTrue: [ 4150 dp := DiskProxy global: #TextConstants selector: #at: args: #(DefaultTabsArray). 4151 refStrm replace: self with: dp. 4152 ^ dp]. 4153self == (TextConstants at: #DefaultMarginTabsArray) ifTrue: [ 4154 dp := DiskProxy global: #TextConstants selector: #at: args: #(DefaultMarginTabsArray). 4155 refStrm replace: self with: dp. 4156 ^ dp]. 4157^ super objectForDataStream: refStrm! ! 4158 4159 4160!Array methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:42'! 4161byteEncode:aStream 4162 aStream writeArray:self. 4163! ! 4164 4165!Array methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:55'! 4166storeOnStream:aStream 4167 self isLiteral ifTrue: [super storeOnStream:aStream] ifFalse:[aStream writeCollection:self]. 4168! ! 4169 4170 4171!Array methodsFor: 'printing' stamp: 'sd 7/31/2005 21:44'! 4172printOn: aStream 4173 self isLiteral ifTrue: [self printAsLiteralFormOn: aStream. ^ self]. 4174 self isSelfEvaluating ifTrue: [self printAsSelfEvaluatingFormOn: aStream. ^ self]. 4175 4176 super printOn: aStream! ! 4177 4178!Array methodsFor: 'printing'! 4179storeOn: aStream 4180 "Use the literal form if possible." 4181 4182 self isLiteral 4183 ifTrue: 4184 [aStream nextPut: $#; nextPut: $(. 4185 self do: 4186 [:element | 4187 element printOn: aStream. 4188 aStream space]. 4189 aStream nextPut: $)] 4190 ifFalse: [super storeOn: aStream]! ! 4191 4192 4193!Array methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! 4194isSelfEvaluating 4195 ^ (self allSatisfy: [:each | each isSelfEvaluating]) and: [self class == Array]! ! 4196 4197!Array methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! 4198printAsLiteralFormOn: aStream 4199 aStream nextPut: $#. 4200 self printElementsOn: aStream 4201! ! 4202 4203!Array methodsFor: 'self evaluating' stamp: 'MarcusDenker 10/5/2009 11:44'! 4204printAsSelfEvaluatingFormOn: aStream 4205 4206 aStream nextPut: ${. 4207 self do: [:el | aStream print: el] separatedBy: [ aStream nextPutAll: '. ']. 4208 aStream nextPut: $}! ! 4209 4210 4211!Array methodsFor: 'testing' stamp: 'eem 5/8/2008 11:13'! 4212isArray 4213 ^true! ! 4214 4215!Array methodsFor: 'testing' stamp: 'sma 5/12/2000 14:11'! 4216isLiteral 4217 ^ self allSatisfy: [:each | each isLiteral]! ! 4218 4219 4220!Array methodsFor: 'private' stamp: 'marcus.denker 9/28/2008 09:57'! 4221hasLiteral: literal 4222 "Answer true if literal is identical to any literal in this array, even 4223 if imbedded in further array structure. This method is only intended 4224 for private use by CompiledMethod hasLiteralSymbol:" 4225 4226 1 to: self size do: [:index | 4227 | lit | 4228 (lit := self at: index) == literal ifTrue: [^ true]. 4229 (lit class == Array and: [lit hasLiteral: literal]) ifTrue: [^ true]]. 4230 ^ false! ! 4231 4232!Array methodsFor: 'private' stamp: 'md 3/1/2006 21:09'! 4233hasLiteralSuchThat: testBlock 4234 "Answer true if testBlock returns true for any literal in this array, even if imbedded in further Arrays or CompiledMethods. This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" 4235 | lit | 4236 1 to: self size do: [:index | 4237 (testBlock value: (lit := self at: index)) ifTrue: [^ true]. 4238 (lit hasLiteralSuchThat: testBlock) ifTrue: [^ true]]. 4239 ^ false! ! 4240 4241!Array methodsFor: 'private' stamp: 'G.C 10/22/2008 09:59'! 4242refersToLiteral: literal 4243 "Answer true if literal is identical to any literal in this array, even if imbedded in further array structures or closure methods" 4244 1 4245 to: self size 4246 do: 4247 [ :index | 4248 | lit | 4249 (lit := self at: index) == literal ifTrue: [ ^ true ]. 4250 (lit refersToLiteral: literal) ifTrue: [ ^ true ] ]. 4251 ^ false! ! 4252 4253!Array methodsFor: 'private'! 4254replaceFrom: start to: stop with: replacement startingAt: repStart 4255 "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." 4256 <primitive: 105> 4257 super replaceFrom: start to: stop with: replacement startingAt: repStart! ! 4258 4259"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 4260 4261Array class 4262 instanceVariableNames: ''! 4263 4264!Array class methodsFor: 'brace support' stamp: 'di 11/18/1999 22:53'! 4265braceStream: nElements 4266 "This method is used in compilation of brace constructs. 4267 It MUST NOT be deleted or altered." 4268 4269 ^ WriteStream basicNew braceArray: (self new: nElements) 4270! ! 4271 4272!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'! 4273braceWith: a 4274 "This method is used in compilation of brace constructs. 4275 It MUST NOT be deleted or altered." 4276 4277 | array | 4278 array := self new: 1. 4279 array at: 1 put: a. 4280 ^ array! ! 4281 4282!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:15'! 4283braceWith: a with: b 4284 "This method is used in compilation of brace constructs. 4285 It MUST NOT be deleted or altered." 4286 4287 | array | 4288 array := self new: 2. 4289 array at: 1 put: a. 4290 array at: 2 put: b. 4291 ^ array! ! 4292 4293!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'! 4294braceWith: a with: b with: c 4295 "This method is used in compilation of brace constructs. 4296 It MUST NOT be deleted or altered." 4297 4298 | array | 4299 array := self new: 3. 4300 array at: 1 put: a. 4301 array at: 2 put: b. 4302 array at: 3 put: c. 4303 ^ array! ! 4304 4305!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'! 4306braceWith: a with: b with: c with: d 4307 "This method is used in compilation of brace constructs. 4308 It MUST NOT be deleted or altered." 4309 4310 | array | 4311 array := self new: 4. 4312 array at: 1 put: a. 4313 array at: 2 put: b. 4314 array at: 3 put: c. 4315 array at: 4 put: d. 4316 ^ array! ! 4317 4318!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'! 4319braceWithNone 4320 "This method is used in compilation of brace constructs. 4321 It MUST NOT be deleted or altered." 4322 4323 ^ self new: 0! ! 4324 4325 4326!Array class methodsFor: 'instance creation' stamp: 'md 7/19/2004 12:34'! 4327new: sizeRequested 4328 "Answer an instance of this class with the number of indexable 4329 variables specified by the argument, sizeRequested. 4330 4331 This is a shortcut (direct call of primitive, no #initialize, for performance" 4332 4333 <primitive: 71> "This method runs primitively if successful" 4334 ^ self basicNew: sizeRequested "Exceptional conditions will be handled in basicNew:" 4335! ! 4336TestCase subclass: #ArrayLiteralTest 4337 instanceVariableNames: '' 4338 classVariableNames: '' 4339 poolDictionaries: '' 4340 category: 'Tests-Compiler'! 4341 4342!ArrayLiteralTest methodsFor: 'initialization' stamp: 'avi 2/16/2004 21:09'! 4343tearDown 4344 self class removeSelector: #array! ! 4345 4346 4347!ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:34'! 4348testByteArrayBase 4349 self class compile: 'array ^ #[2r1010 8r333 16rFF]'. 4350 self assert: (self array isKindOf: ByteArray). 4351 self assert: (self array size = 3). 4352 self assert: (self array first = 10). 4353 self assert: (self array second = 219). 4354 self assert: (self array last = 255) 4355 4356! ! 4357 4358!ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:35'! 4359testByteArrayEmpty 4360 self class compile: 'array ^ #[]'. 4361 self assert: (self array isKindOf: ByteArray). 4362 self assert: (self array isEmpty)! ! 4363 4364!ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:36'! 4365testByteArrayLiteral 4366 self class compile: 'array ^ #[ 1 2 3 4 ]'. 4367 self assert: (self array = self array). 4368 self assert: (self array == self array)! ! 4369 4370!ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:45'! 4371testByteArrayLong 4372 self class compile: 'array ^ #[ ' , ((0 to: 255) inject: ' ' into: [ :r :e | r , ' ' , e asString ]) , ' ]'. 4373 self assert: (self array isKindOf: ByteArray). 4374 self assert: (self array size = 256). 4375 0 to: 255 do: [ :index | self assert: (self array at: index + 1) = index ]! ! 4376 4377!ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:32'! 4378testByteArrayRange 4379 self class compile: 'array ^ #[ 0 255 ]'. 4380 self assert: (self array isKindOf: ByteArray). 4381 self assert: (self array size = 2). 4382 self assert: (self array first = 0). 4383 self assert: (self array last = 255)! ! 4384 4385!ArrayLiteralTest methodsFor: 'tests' stamp: 'Henrik Sperre Johansen 3/23/2009 13:55'! 4386testByteArrayWithinArray 4387 self class compile: 'array ^ #( #[1] #[2] )'. 4388 self assert: (self array isKindOf: Array). 4389 self assert: (self array size = 2). 4390 self assert: (self array first isKindOf: ByteArray). 4391 self assert: (self array first first = 1). 4392 self assert: (self array last isKindOf: ByteArray). 4393 self assert: (self array last first = 2) 4394 4395! ! 4396 4397!ArrayLiteralTest methodsFor: 'tests' stamp: 'avi 2/16/2004 21:08'! 4398testReservedIdentifiers 4399 self class compile: 'array ^ #(nil true false)'. 4400 self assert: self array = {nil. true. false}.! ! 4401 4402!ArrayLiteralTest methodsFor: 'tests' stamp: 'avi 2/16/2004 21:09'! 4403testSymbols 4404 self class compile: 'array ^ #(#nil #true #false #''nil'' #''true'' #''false'')'. 4405 self assert: self array = {#nil. #true. #false. #nil. #true. #false}.! ! 4406CollectionRootTest subclass: #ArrayTest 4407 uses: TEmptySequenceableTest + TSequencedElementAccessTest + TCloneTest + TIncludesWithIdentityCheckTest + TCopyTest + TSetArithmetic + TCreationWithTest + TPutBasicTest + TConvertTest - {} + TSortTest + TOccurrencesForMultiplinessTest + TIterateSequencedReadableTest + TSequencedConcatenationTest + TReplacementSequencedTest + TAsStringCommaAndDelimiterSequenceableTest + TBeginsEndsWith + TPrintOnSequencedTest + TIndexAccess + TSubCollectionAccess + TConvertAsSetForMultiplinessIdentityTest + TCopyPartOfSequenceable + TCopySequenceableSameContents + TCopySequenceableWithOrWithoutSpecificElements + TCopySequenceableWithReplacement + TIndexAccessForMultipliness + TCopyPartOfSequenceableForMultipliness + TConvertAsSortedTest + TPutTest + TSequencedStructuralEqualityTest 4408 instanceVariableNames: 'example1 literalArray selfEvaluatingArray otherArray nonSEArray1 nonSEarray2 example2 empty collection result withoutEqualElements withEqualElements withCharacters unsortedCollection sortedInAscendingOrderCollection sizeCollection collectionNotIncluded removedCollection elementInForCopy elementNotInForCopy firstIndex secondIndex replacementCollection indexArray valueArray nonEmptyMoreThan1Element subCollectionNotIn replacementCollectionSameSize oldSubCollection nonEmpty1Element collectionOfCollection collectionOfFloatWithEqualElements floatCollectionWithSameBeginingAnEnd collectionWithoutNil duplicateElement collection5Elements' 4409 classVariableNames: '' 4410 poolDictionaries: '' 4411 category: 'CollectionsTests-Arrayed'! 4412!ArrayTest commentStamp: '<historical>' prior: 0! 4413This is the unit test for the class Array. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 4414 - http://www.c2.com/cgi/wiki?UnitTest 4415 - http://minnow.cc.gatech.edu/squeak/1547 4416 - the sunit class category! 4417 4418 4419!ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:12'! 4420aValue 4421 4422 ^ 33! ! 4423 4424!ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:13'! 4425anIndex 4426 4427 ^ 2! ! 4428 4429!ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:19'! 4430anotherValue 4431 4432 ^ 66! ! 4433 4434 4435!ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/6/2008 16:53'! 4436collection 4437 4438 ^ collection ! ! 4439 4440!ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/5/2008 15:06'! 4441empty 4442 4443 ^ empty! ! 4444 4445!ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/5/2008 15:06'! 4446nonEmpty 4447 4448 ^ example1! ! 4449 4450!ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/6/2008 16:54'! 4451result 4452 4453 ^ result! ! 4454 4455!ArrayTest methodsFor: 'initialization' stamp: 'delaunay 5/14/2009 14:00'! 4456setUp 4457 4458 4459 literalArray := #(1 true 3 #four). 4460 selfEvaluatingArray := { 1. true. (3/4). Color black. (2 to: 4) . 5 }. 4461 nonSEArray1 := { 1 . Set with: 1 }. 4462 nonSEarray2 := { Smalltalk associationAt: #Array }. 4463 example1 := #(1 2 3 4 5) copy. 4464 indexArray:= {2. 3. 4.}. 4465 valueArray:={0. 0. 0.}. 4466 oldSubCollection:= {2. 3. 4.}. 4467 nonEmptyMoreThan1Element:= example1. 4468 subCollectionNotIn:= {1. 8. 3.}. 4469 collectionNotIncluded:= {7. 8. 9.}. 4470 removedCollection:= { 2. 4. }. 4471 4472 example2 := {1. 2. 3/4. 4. 5}. 4473 collection := #(1 -2 3 1). 4474 collectionWithoutNil := #( 1 2 3 4). 4475 result := {SmallInteger. SmallInteger. SmallInteger. SmallInteger.}. 4476 empty := #(). 4477 duplicateElement := 5.2. 4478 withEqualElements := {1.5. duplicateElement . 6.1. 2.0. duplicateElement .} . 4479 withoutEqualElements := {1.1. 4.4. 6.5. 2.4. 3.1.}. 4480 withCharacters := {$a. $x. $d. $c. $m.}. 4481 unsortedCollection := {1. 2. 8. 5. 6. 7.}. 4482 sortedInAscendingOrderCollection := {1. 2. 3. 4. 5. 6.}. 4483 elementInForCopy:= 2. 4484 elementNotInForCopy:= 9. 4485 firstIndex:= 2. 4486 secondIndex:= 4. 4487 replacementCollection:= {4. 3. 2. 1.}. 4488 replacementCollectionSameSize := {5. 4. 3.}. 4489 nonEmpty1Element:={ 5.}. 4490 collectionOfCollection:={1.5. 5.5. 6.5.}. 4491 collectionOfFloatWithEqualElements:={1.5. 5.5. 6.5. 1.5}. 4492 floatCollectionWithSameBeginingAnEnd := {1.5. 5.5. 1.5 copy}. 4493 collection5Elements := { 1. 2. 5. 3. 4.}.! ! 4494 4495 4496!ArrayTest methodsFor: 'parameters'! 4497accessValuePutIn 4498 "return access the element put in the non-empty collection" 4499 4500 ^ self perform: self selectorToAccessValuePutIn! ! 4501 4502!ArrayTest methodsFor: 'parameters'! 4503accessValuePutInOn: s 4504 4505 "return access the element put in the non-empty collection" 4506 4507 ^ s perform: self selectorToAccessValuePutIn! ! 4508 4509!ArrayTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/5/2008 15:12'! 4510selectorToAccessValuePutIn 4511 "return the selector of the method that should be invoked to access an element" 4512 4513 ^ #second! ! 4514 4515!ArrayTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/9/2008 18:49'! 4516valuePutIn 4517 "the value that we will put in the non empty collection" 4518 4519 ^ 2! ! 4520 4521 4522!ArrayTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/30/2008 19:02'! 4523accessCollection 4524 4525 ^ example1! ! 4526 4527!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! 4528anotherElementNotIn 4529 ^ elementNotInForCopy ! ! 4530 4531!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:05'! 4532anotherElementOrAssociationIn 4533 " return an element (or an association for Dictionary ) present in 'collection' " 4534 ^ self collection anyOne.! ! 4535 4536!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:05'! 4537anotherElementOrAssociationNotIn 4538 " return an element (or an association for Dictionary )not present in 'collection' " 4539 ^ elementNotInForCopy ! ! 4540 4541!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/9/2009 11:11'! 4542collectionInForIncluding 4543 ^ self nonEmpty copyWithoutFirst.! ! 4544 4545!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:16'! 4546collectionMoreThan1NoDuplicates 4547 " return a collection of size 5 without equal elements" 4548 ^ withoutEqualElements ! ! 4549 4550!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:01'! 4551collectionMoreThan5Elements 4552" return a collection including at least 5 elements" 4553 4554 ^ collection5Elements ! ! 4555 4556!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/30/2009 10:51'! 4557collectionNotIncluded 4558 ^ collectionNotIncluded.! ! 4559 4560!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:07'! 4561collectionOfFloat 4562 ^ collectionOfCollection! ! 4563 4564!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 10:28'! 4565collectionWith1TimeSubcollection 4566 ^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst). ! ! 4567 4568!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 10:29'! 4569collectionWith2TimeSubcollection 4570 ^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst),self oldSubCollection .! ! 4571 4572!ArrayTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/26/2009 09:58'! 4573collectionWithCharacters 4574 ^ withCharacters.! ! 4575 4576!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:49'! 4577collectionWithCopy 4578 "return a collection of type 'self collectionWIithoutEqualsElements clas' containing no elements equals ( with identity equality) 4579 but 2 elements only equals with classic equality" 4580 | result collection | 4581 collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. 4582 collection add: collection first copy. 4583 result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. 4584 ^ result! ! 4585 4586!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! 4587collectionWithCopyNonIdentical 4588 " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" 4589 ^ collectionOfCollection! ! 4590 4591!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:24'! 4592collectionWithElementsToRemove 4593 ^ removedCollection! ! 4594 4595!ArrayTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/26/2009 09:57'! 4596collectionWithEqualElements 4597 ^ withEqualElements.! ! 4598 4599!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:50'! 4600collectionWithIdentical 4601 "return a collection of type : 'self collectionWIithoutEqualsElements class containing two elements equals ( with identity equality)" 4602 | result collection element | 4603 collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. 4604 element := collection first. 4605 collection add: element. 4606 result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. 4607 ^ result! ! 4608 4609!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:17'! 4610collectionWithNonIdentitySameAtEndAndBegining 4611 " return a collection with elements at end and begining equals only with classic equality (they are not the same object). 4612(others elements of the collection are not equal to those elements)" 4613 ^ floatCollectionWithSameBeginingAnEnd ! ! 4614 4615!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 11:15'! 4616collectionWithSameAtEndAndBegining 4617" return a collection with elements at end and begining equals . 4618(others elements of the collection are not equal to those elements)" 4619 ^ floatCollectionWithSameBeginingAnEnd ! ! 4620 4621!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:27'! 4622collectionWithSortableElements 4623" return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" 4624 ^ withoutEqualElements ! ! 4625 4626!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:25'! 4627collectionWithoutEqualElements 4628 ^ withoutEqualElements .! ! 4629 4630!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 15:49'! 4631collectionWithoutEqualsElements 4632 ^ withoutEqualElements ! ! 4633 4634!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:39'! 4635collectionWithoutNilElements 4636" return a collection that doesn't includes a nil element and that doesn't includes equal elements'" 4637 ^ collectionWithoutNil ! ! 4638 4639!ArrayTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:27'! 4640element 4641 ^ 3! ! 4642 4643!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:22'! 4644elementInCollectionOfFloat 4645 ^ collectionOfCollection atRandom! ! 4646 4647!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:28'! 4648elementInForCopy 4649 ^ elementInForCopy ! ! 4650 4651!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:39'! 4652elementInForElementAccessing 4653" return an element inculded in 'accessCollection '" 4654 ^ self accessCollection anyOne! ! 4655 4656!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 13:55'! 4657elementInForIncludesTest 4658 4659 ^ elementInForCopy ! ! 4660 4661!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/10/2009 14:49'! 4662elementInForIndexAccess 4663 ^ elementInForCopy ! ! 4664 4665!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:18'! 4666elementInForIndexAccessing 4667 4668 ^ withoutEqualElements anyOne! ! 4669 4670!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 11:54'! 4671elementInForOccurrences 4672 ^ elementInForCopy ! ! 4673 4674!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:16'! 4675elementInForReplacement 4676 ^ elementInForCopy ! ! 4677 4678!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! 4679elementNotIn 4680"return an element not included in 'nonEmpty' " 4681 4682 ^ elementNotInForCopy ! ! 4683 4684!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! 4685elementNotInForCopy 4686 ^ elementNotInForCopy ! ! 4687 4688!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:39'! 4689elementNotInForElementAccessing 4690" return an element not included in 'accessCollection' " 4691 ^ elementNotInForCopy ! ! 4692 4693!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/7/2009 11:18'! 4694elementNotInForIndexAccessing 4695 4696 ^elementNotInForCopy ! ! 4697 4698!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! 4699elementNotInForOccurrences 4700 ^ elementNotInForCopy ! ! 4701 4702!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:13'! 4703elementTwiceInForOccurrences 4704" return an element included exactly two time in # collectionWithEqualElements" 4705^ duplicateElement ! ! 4706 4707!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:46'! 4708elementsCopyNonIdenticalWithoutEqualElements 4709 " return a collection that does niot include equal elements ( classic equality )" 4710 ^ collectionOfCollection! ! 4711 4712!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 16:41'! 4713firstCollection 4714 ^example1 ! ! 4715 4716!ArrayTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 10:35'! 4717firstEven 4718 "Returns the first even number of #collection" 4719 ^ -2! ! 4720 4721!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! 4722firstIndex 4723 ^ firstIndex ! ! 4724 4725!ArrayTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 10:35'! 4726firstOdd 4727 "Returns the first odd number of #collection" 4728 ^ 1! ! 4729 4730!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 14:00'! 4731floatCollectionWithSameAtEndAndBegining 4732" return a collection with elements at end and begining equals only with classic equality (they are not the same object). 4733(others elements of the collection are not equal to those elements)" 4734 ^ floatCollectionWithSameBeginingAnEnd ! ! 4735 4736!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 16:00'! 4737indexArray 4738 ^ indexArray .! ! 4739 4740!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 15:59'! 4741indexInForCollectionWithoutDuplicates 4742 ^ 2.! ! 4743 4744!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 16:56'! 4745indexInNonEmpty 4746 ^ 2 ! ! 4747 4748!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/9/2009 15:53'! 4749integerCollection 4750 ^example1 .! ! 4751 4752!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:28'! 4753integerCollectionWithoutEqualElements 4754 ^{1. 2. 6. 5.}! ! 4755 4756!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:53'! 4757moreThan3Elements 4758 " return a collection including atLeast 3 elements" 4759 ^ example1 ! ! 4760 4761!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:53'! 4762moreThan4Elements 4763 4764" return a collection including at leat 4 elements" 4765 ^ example1 ! ! 4766 4767!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:16'! 4768newElement 4769 ^999! ! 4770 4771!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/8/2009 11:40'! 4772nonEmpty1Element 4773 4774 ^ nonEmpty1Element ! ! 4775 4776!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 15:20'! 4777nonEmptyMoreThan1Element 4778 ^nonEmptyMoreThan1Element .! ! 4779 4780!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 11:41'! 4781oldSubCollection 4782 ^oldSubCollection ! ! 4783 4784!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! 4785replacementCollection 4786 ^replacementCollection .! ! 4787 4788!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:32'! 4789replacementCollectionSameSize 4790 ^replacementCollectionSameSize ! ! 4791 4792!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:29'! 4793resultForCollectElementsClass 4794" return the retsult expected by collecting the class of each element of collectionWithoutNilElements" 4795 ^ result ! ! 4796 4797!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 16:41'! 4798secondCollection 4799 ^example2 ! ! 4800 4801!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! 4802secondIndex 4803 ^ secondIndex ! ! 4804 4805!ArrayTest methodsFor: 'requirements' stamp: 'damienpollet 1/13/2009 16:59'! 4806sizeCollection 4807 4808 ^ self collection! ! 4809 4810!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 14:08'! 4811smallerIndex 4812 ^ firstIndex -1! ! 4813 4814!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/27/2009 15:20'! 4815sortedInAscendingOrderCollection 4816 ^sortedInAscendingOrderCollection . 4817 ! ! 4818 4819!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/3/2009 11:35'! 4820subCollectionNotIn 4821 4822 ^subCollectionNotIn ! ! 4823 4824!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/27/2009 15:20'! 4825unsortedCollection 4826 ^unsortedCollection .! ! 4827 4828!ArrayTest methodsFor: 'requirements'! 4829valueArray 4830" return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty' at indexes in 'indexArray' " 4831 | result | 4832 result := Array new: self indexArray size. 4833 1 to: result size do: 4834 [:i | 4835 result at:i put: (self aValue ). 4836 ]. 4837 ^ result.! ! 4838 4839!ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:11'! 4840withEqualElements 4841 " return a collection of float including equal elements (classic equality)" 4842 ^ collectionOfFloatWithEqualElements! ! 4843 4844 4845!ArrayTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! 4846elementToAdd 4847 ^ 55! ! 4848 4849 4850!ArrayTest methodsFor: 'test - creation' stamp: 'stephane.ducasse 12/9/2008 22:00'! 4851collectionClass 4852 4853 ^ Array! ! 4854 4855!ArrayTest methodsFor: 'test - creation'! 4856testOfSize 4857 "self debug: #testOfSize" 4858 4859 | aCol | 4860 aCol := self collectionClass ofSize: 3. 4861 self assert: (aCol size = 3). 4862! ! 4863 4864!ArrayTest methodsFor: 'test - creation'! 4865testWith 4866 "self debug: #testWith" 4867 4868 | aCol element | 4869 element := self collectionMoreThan5Elements anyOne. 4870 aCol := self collectionClass with: element. 4871 self assert: (aCol includes: element).! ! 4872 4873!ArrayTest methodsFor: 'test - creation'! 4874testWithAll 4875 "self debug: #testWithAll" 4876 4877 | aCol collection | 4878 collection := self collectionMoreThan5Elements asOrderedCollection . 4879 aCol := self collectionClass withAll: collection . 4880 4881 collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. 4882 4883 self assert: (aCol size = collection size ).! ! 4884 4885!ArrayTest methodsFor: 'test - creation'! 4886testWithWith 4887 "self debug: #testWithWith" 4888 4889 | aCol collection element1 element2 | 4890 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . 4891 element1 := collection at: 1. 4892 element2 := collection at:2. 4893 4894 aCol := self collectionClass with: element1 with: element2 . 4895 self assert: (aCol occurrencesOf: element1 ) == ( collection occurrencesOf: element1). 4896 self assert: (aCol occurrencesOf: element2 ) == ( collection occurrencesOf: element2). 4897 4898 ! ! 4899 4900!ArrayTest methodsFor: 'test - creation'! 4901testWithWithWith 4902 "self debug: #testWithWithWith" 4903 4904 | aCol collection | 4905 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . 4906 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 4907 4908 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 4909 4910!ArrayTest methodsFor: 'test - creation'! 4911testWithWithWithWith 4912 "self debug: #testWithWithWithWith" 4913 4914 | aCol collection | 4915 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. 4916 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 4917 4918 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 4919 4920!ArrayTest methodsFor: 'test - creation'! 4921testWithWithWithWithWith 4922 "self debug: #testWithWithWithWithWith" 4923 4924 | aCol collection | 4925 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . 4926 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 4927 4928 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 4929 4930 4931!ArrayTest methodsFor: 'test - equality'! 4932testEqualSign 4933 "self debug: #testEqualSign" 4934 4935 self deny: (self empty = self nonEmpty).! ! 4936 4937!ArrayTest methodsFor: 'test - equality'! 4938testEqualSignIsTrueForNonIdenticalButEqualCollections 4939 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 4940 4941 self assert: (self empty = self empty copy). 4942 self assert: (self empty copy = self empty). 4943 self assert: (self empty copy = self empty copy). 4944 4945 self assert: (self nonEmpty = self nonEmpty copy). 4946 self assert: (self nonEmpty copy = self nonEmpty). 4947 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 4948 4949!ArrayTest methodsFor: 'test - equality'! 4950testEqualSignOfIdenticalCollectionObjects 4951 "self debug: #testEqualSignOfIdenticalCollectionObjects" 4952 4953 self assert: (self empty = self empty). 4954 self assert: (self nonEmpty = self nonEmpty). 4955 ! ! 4956 4957 4958!ArrayTest methodsFor: 'test - iterate' stamp: 'luc.fabresse 11/29/2008 23:10'! 4959expectedSizeAfterReject 4960 ^1! ! 4961 4962!ArrayTest methodsFor: 'test - iterate' stamp: 'stephane.ducasse 10/6/2008 17:39'! 4963speciesClass 4964 4965 ^ Array! ! 4966 4967!ArrayTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/13/2009 16:28'! 4968testAnySatisfy 4969 4970 self assert: ( self collection anySatisfy: [:each | each = -2]). 4971 self deny: (self collection anySatisfy: [:each | each isString]).! ! 4972 4973!ArrayTest methodsFor: 'test - iterate' stamp: 'delaunay 4/14/2009 14:12'! 4974testDo 4975 4976 | res | 4977 res := OrderedCollection new. 4978 self collection do: [:each | res add: each class]. 4979 self assert: res asArray = self result.! ! 4980 4981!ArrayTest methodsFor: 'test - iterate' stamp: 'delaunay 4/14/2009 14:13'! 4982testDo2 4983 4984 | res | 4985 res := OrderedCollection new. 4986 self collection do: [:each | res add: each class]. 4987 self assert: res asArray = self result. ! ! 4988 4989 4990!ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:12'! 4991testIsArray 4992 4993 self assert: example1 isArray! ! 4994 4995!ArrayTest methodsFor: 'testing' stamp: 'apb 4/21/2006 08:59'! 4996testIsLiteral 4997 "We work with a copy of literalArray, to avoid corrupting the code." 4998 | l | 4999 l := literalArray copy. 5000 self assert: l isLiteral. 5001 l at: 1 put: self class. 5002 self deny: l isLiteral! ! 5003 5004!ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:18'! 5005testIsSelfEvaluating 5006 5007 self assert: example1 isSelfEvaluating. 5008 example1 at: 1 put: Bag new. 5009 self deny: example1 isSelfEvaluating. 5010 example1 at: 1 put: 1.! ! 5011 5012!ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:50'! 5013testLiteralEqual 5014 self 5015 deny: (example1 literalEqual: example1 asIntegerArray)! ! 5016 5017!ArrayTest methodsFor: 'testing' stamp: 'dc 5/24/2007 10:56'! 5018testNewWithSize 5019 |array| 5020 array := Array new: 5. 5021 self assert: array size = 5. 5022 1 to: 5 do: [:index | self assert: (array at: index) isNil]! ! 5023 5024!ArrayTest methodsFor: 'testing' stamp: 'stephane.ducasse 10/6/2008 16:53'! 5025testPremultiply 5026 self assert: example1 +* #(2 ) = #(2 4 6 8 10 ) ! ! 5027 5028!ArrayTest methodsFor: 'testing' stamp: 'delaunay 5/4/2009 15:15'! 5029testPrinting 5030 self assert: literalArray printString = '#(1 true 3 #four)'. 5031 self assert: (literalArray = (Compiler evaluate: literalArray printString)). 5032 "self assert: selfEvaluatingArray printString = '{1. true. (3/4). Color black. (2 to: 4). 5}'." 5033 self assert: (selfEvaluatingArray = (Compiler evaluate: selfEvaluatingArray printString)). 5034 self assert: nonSEArray1 printString = 'an Array(1 a Set(1))'. 5035 self assert: nonSEarray2 printString = '{#Array->Array}' 5036! ! 5037 5038 5039!ArrayTest methodsFor: 'tests - accessing' stamp: 'delaunay 4/10/2009 16:19'! 5040testAtWrap2 5041 | tabTest | 5042 tabTest := #(5 6 8 ). 5043 self assert: (tabTest atWrap: 2) = 6. 5044 self assert: (tabTest atWrap: 7) = 5. 5045 self assert: (tabTest atWrap: 5) = 6. 5046 self assert: (tabTest atWrap: 0) = 8. 5047 self assert: (tabTest atWrap: 1) = 5. 5048 self assert: (tabTest atWrap: -2) = 5! ! 5049 5050 5051!ArrayTest methodsFor: 'tests - as identity set'! 5052testAsIdentitySetWithIdentityEqualsElements 5053 | result | 5054 result := self collectionWithIdentical asIdentitySet. 5055 " Only one element should have been removed as two elements are equals with Identity equality" 5056 self assert: result size = (self collectionWithIdentical size - 1). 5057 self collectionWithIdentical do: 5058 [ :each | 5059 (self collectionWithIdentical occurrencesOf: each) > 1 5060 ifTrue: 5061 [ "the two elements equals only with classic equality shouldn't 'have been removed" 5062 self assert: (result asOrderedCollection occurrencesOf: each) = 1 5063 " the other elements are still here" ] 5064 ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ]. 5065 self assert: result class = IdentitySet! ! 5066 5067!ArrayTest methodsFor: 'tests - as identity set'! 5068testAsIdentitySetWithoutIdentityEqualsElements 5069 | result collection | 5070 collection := self collectionWithCopy. 5071 result := collection asIdentitySet. 5072 " no elements should have been removed as no elements are equels with Identity equality" 5073 self assert: result size = collection size. 5074 collection do: 5075 [ :each | 5076 (collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ]. 5077 self assert: result class = IdentitySet! ! 5078 5079 5080!ArrayTest methodsFor: 'tests - as set tests'! 5081testAsIdentitySetWithEqualsElements 5082 | result collection | 5083 collection := self withEqualElements . 5084 result := collection asIdentitySet. 5085 collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 5086 self assert: result class = IdentitySet.! ! 5087 5088!ArrayTest methodsFor: 'tests - as set tests'! 5089testAsSetWithEqualsElements 5090 | result | 5091 result := self withEqualElements asSet. 5092 self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 5093 self assert: result class = Set! ! 5094 5095 5096!ArrayTest methodsFor: 'tests - as sorted collection'! 5097testAsSortedArray 5098 | result collection | 5099 collection := self collectionWithSortableElements . 5100 result := collection asSortedArray. 5101 self assert: (result class includesBehavior: Array). 5102 self assert: result isSorted. 5103 self assert: result size = collection size! ! 5104 5105!ArrayTest methodsFor: 'tests - as sorted collection'! 5106testAsSortedCollection 5107 5108 | aCollection result | 5109 aCollection := self collectionWithSortableElements . 5110 result := aCollection asSortedCollection. 5111 5112 self assert: (result class includesBehavior: SortedCollection). 5113 result do: 5114 [ :each | 5115 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 5116 5117 self assert: result size = aCollection size.! ! 5118 5119!ArrayTest methodsFor: 'tests - as sorted collection'! 5120testAsSortedCollectionWithSortBlock 5121 | result tmp | 5122 result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. 5123 self assert: (result class includesBehavior: SortedCollection). 5124 result do: 5125 [ :each | 5126 self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 5127 self assert: result size = self collectionWithSortableElements size. 5128 tmp:=result at: 1. 5129 result do: [:each| self assert: tmp>=each. tmp:=each]. 5130 ! ! 5131 5132 5133!ArrayTest methodsFor: 'tests - at put'! 5134testAtPut 5135 "self debug: #testAtPut" 5136 5137 self nonEmpty at: self anIndex put: self aValue. 5138 self assert: (self nonEmpty at: self anIndex) = self aValue. 5139 ! ! 5140 5141!ArrayTest methodsFor: 'tests - at put'! 5142testAtPutOutOfBounds 5143 "self debug: #testAtPutOutOfBounds" 5144 5145 self should: [self empty at: self anIndex put: self aValue] raise: Error 5146 ! ! 5147 5148!ArrayTest methodsFor: 'tests - at put'! 5149testAtPutTwoValues 5150 "self debug: #testAtPutTwoValues" 5151 5152 self nonEmpty at: self anIndex put: self aValue. 5153 self nonEmpty at: self anIndex put: self anotherValue. 5154 self assert: (self nonEmpty at: self anIndex) = self anotherValue.! ! 5155 5156 5157!ArrayTest methodsFor: 'tests - begins ends with'! 5158testsBeginsWith 5159 5160 self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty size)). 5161 self assert: (self nonEmpty beginsWith:(self nonEmpty )). 5162 self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 5163 5164!ArrayTest methodsFor: 'tests - begins ends with'! 5165testsBeginsWithEmpty 5166 5167 self deny: (self nonEmpty beginsWith:(self empty)). 5168 self deny: (self empty beginsWith:(self nonEmpty )). 5169! ! 5170 5171!ArrayTest methodsFor: 'tests - begins ends with'! 5172testsEndsWith 5173 5174 self assert: (self nonEmpty endsWith:(self nonEmpty copyWithoutFirst)). 5175 self assert: (self nonEmpty endsWith:(self nonEmpty )). 5176 self deny: (self nonEmpty endsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 5177 5178!ArrayTest methodsFor: 'tests - begins ends with'! 5179testsEndsWithEmpty 5180 5181 self deny: (self nonEmpty endsWith:(self empty )). 5182 self deny: (self empty endsWith:(self nonEmpty )). 5183 ! ! 5184 5185 5186!ArrayTest methodsFor: 'tests - comma and delimiter'! 5187testAsCommaStringEmpty 5188 5189 self assert: self empty asCommaString = ''. 5190 self assert: self empty asCommaStringAnd = ''. 5191 5192 5193! ! 5194 5195!ArrayTest methodsFor: 'tests - comma and delimiter'! 5196testAsCommaStringMore 5197 5198 "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. 5199 self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' 5200" 5201 5202 | result resultAnd index allElementsAsString | 5203 result:= self nonEmpty asCommaString . 5204 resultAnd:= self nonEmpty asCommaStringAnd . 5205 5206 index := 1. 5207 (result findBetweenSubStrs: ',' )do: 5208 [:each | 5209 index = 1 5210 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] 5211 ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. 5212 index:=index+1 5213 ]. 5214 5215 "verifying esultAnd :" 5216 allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 5217 1 to: allElementsAsString size do: 5218 [:i | 5219 i<(allElementsAsString size ) 5220 ifTrue: [ 5221 i = 1 5222 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] 5223 ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] 5224 ]. 5225 i=(allElementsAsString size) 5226 ifTrue:[ 5227 i = 1 5228 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 5229 ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 5230 ]. 5231 5232 5233 ].! ! 5234 5235!ArrayTest methodsFor: 'tests - comma and delimiter'! 5236testAsCommaStringOne 5237 5238 "self assert: self oneItemCol asCommaString = '1'. 5239 self assert: self oneItemCol asCommaStringAnd = '1'." 5240 5241 self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). 5242 self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). 5243 ! ! 5244 5245!ArrayTest methodsFor: 'tests - comma and delimiter'! 5246testAsStringOnDelimiterEmpty 5247 5248 | delim emptyStream | 5249 delim := ', '. 5250 emptyStream := ReadWriteStream on: ''. 5251 self empty asStringOn: emptyStream delimiter: delim. 5252 self assert: emptyStream contents = ''. 5253! ! 5254 5255!ArrayTest methodsFor: 'tests - comma and delimiter'! 5256testAsStringOnDelimiterLastEmpty 5257 5258 | delim emptyStream | 5259 delim := ', '. 5260 emptyStream := ReadWriteStream on: ''. 5261 self empty asStringOn: emptyStream delimiter: delim last:'and'. 5262 self assert: emptyStream contents = ''. 5263! ! 5264 5265!ArrayTest methodsFor: 'tests - comma and delimiter'! 5266testAsStringOnDelimiterLastMore 5267 5268 | delim multiItemStream result last allElementsAsString | 5269 5270 delim := ', '. 5271 last := 'and'. 5272 result:=''. 5273 multiItemStream := ReadWriteStream on:result. 5274 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 5275 5276 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 5277 1 to: allElementsAsString size do: 5278 [:i | 5279 i<(allElementsAsString size-1 ) 5280 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 5281 i=(allElementsAsString size-1) 5282 ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. 5283 i=(allElementsAsString size) 5284 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 5285 ]. 5286 5287! ! 5288 5289!ArrayTest methodsFor: 'tests - comma and delimiter'! 5290testAsStringOnDelimiterLastOne 5291 5292 | delim oneItemStream result | 5293 5294 delim := ', '. 5295 result:=''. 5296 oneItemStream := ReadWriteStream on: result. 5297 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 5298 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 5299 5300 5301 ! ! 5302 5303!ArrayTest methodsFor: 'tests - comma and delimiter'! 5304testAsStringOnDelimiterMore 5305 5306 | delim multiItemStream result index | 5307 "delim := ', '. 5308 multiItemStream := '' readWrite. 5309 self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. 5310 self assert: multiItemStream contents = '1, 2, 3'." 5311 5312 delim := ', '. 5313 result:=''. 5314 multiItemStream := ReadWriteStream on:result. 5315 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 5316 5317 index:=1. 5318 (result findBetweenSubStrs: ', ' )do: 5319 [:each | 5320 self assert: each= ((self nonEmpty at:index)asString). 5321 index:=index+1 5322 ].! ! 5323 5324!ArrayTest methodsFor: 'tests - comma and delimiter'! 5325testAsStringOnDelimiterOne 5326 5327 | delim oneItemStream result | 5328 "delim := ', '. 5329 oneItemStream := '' readWrite. 5330 self oneItemCol asStringOn: oneItemStream delimiter: delim. 5331 self assert: oneItemStream contents = '1'." 5332 5333 delim := ', '. 5334 result:=''. 5335 oneItemStream := ReadWriteStream on: result. 5336 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 5337 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 5338 5339 5340 ! ! 5341 5342 5343!ArrayTest methodsFor: 'tests - concatenation'! 5344testConcatenation 5345 | result index | 5346 result:= self firstCollection,self secondCollection . 5347 "first part : " 5348 index := 1. 5349 self firstCollection do: 5350 [:each | 5351 self assert: (self firstCollection at: index)=each. 5352 index := index+1.]. 5353 "second part : " 5354 1 to: self secondCollection size do: 5355 [:i | 5356 self assert: (self secondCollection at:i)= (result at:index). 5357 index:=index+1]. 5358 "size : " 5359 self assert: result size = (self firstCollection size + self secondCollection size).! ! 5360 5361!ArrayTest methodsFor: 'tests - concatenation'! 5362testConcatenationWithEmpty 5363 | result | 5364 result:= self empty,self secondCollection . 5365 5366 1 to: self secondCollection size do: 5367 [:i | 5368 self assert: (self secondCollection at:i)= (result at:i). 5369 ]. 5370 "size : " 5371 self assert: result size = ( self secondCollection size).! ! 5372 5373 5374!ArrayTest methodsFor: 'tests - converting'! 5375assertNoDuplicates: aCollection whenConvertedTo: aClass 5376 | result | 5377 result := self collectionWithEqualElements asIdentitySet. 5378 self assert: (result class includesBehavior: IdentitySet). 5379 self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! 5380 5381!ArrayTest methodsFor: 'tests - converting'! 5382assertNonDuplicatedContents: aCollection whenConvertedTo: aClass 5383 | result | 5384 result := aCollection perform: ('as' , aClass name) asSymbol. 5385 self assert: (result class includesBehavior: aClass). 5386 result do: 5387 [ :each | 5388 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 5389 ^ result! ! 5390 5391!ArrayTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 12:35'! 5392assertSameContents: aCollection whenConvertedTo: aClass 5393 | result | 5394 result := aCollection perform: ('as' , aClass name) asSymbol. 5395 self assert: (result class includesBehavior: aClass). 5396 result do: 5397 [ :each | 5398 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 5399 self assert: result size = aCollection size! ! 5400 5401!ArrayTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 14:55'! 5402testAsArray 5403 "self debug: #testAsArray3" 5404 self 5405 assertSameContents: self collectionWithoutEqualElements 5406 whenConvertedTo: Array! ! 5407 5408!ArrayTest methodsFor: 'tests - converting'! 5409testAsBag 5410 5411 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! 5412 5413!ArrayTest methodsFor: 'tests - converting'! 5414testAsByteArray 5415| res | 5416self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 5417 self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . 5418 5419 res := true. 5420 self integerCollectionWithoutEqualElements 5421 detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] 5422 ifNone: [ res := false ]. 5423 self assert: res = false. 5424 5425 5426 self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! 5427 5428!ArrayTest methodsFor: 'tests - converting'! 5429testAsIdentitySet 5430 "test with a collection without equal elements :" 5431 self 5432 assertSameContents: self collectionWithoutEqualElements 5433 whenConvertedTo: IdentitySet. 5434! ! 5435 5436!ArrayTest methodsFor: 'tests - converting'! 5437testAsOrderedCollection 5438 5439 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! 5440 5441!ArrayTest methodsFor: 'tests - converting'! 5442testAsSet 5443 | | 5444 "test with a collection without equal elements :" 5445 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. 5446 ! ! 5447 5448 5449!ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 5450testCopyEmptyWith 5451 "self debug: #testCopyWith" 5452 | res | 5453 res := self empty copyWith: self elementToAdd. 5454 self assert: res size = (self empty size + 1). 5455 self assert: (res includes: self elementToAdd)! ! 5456 5457!ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 5458testCopyEmptyWithout 5459 "self debug: #testCopyEmptyWithout" 5460 | res | 5461 res := self empty copyWithout: self elementToAdd. 5462 self assert: res size = self empty size. 5463 self deny: (res includes: self elementToAdd)! ! 5464 5465!ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 5466testCopyEmptyWithoutAll 5467 "self debug: #testCopyEmptyWithoutAll" 5468 | res | 5469 res := self empty copyWithoutAll: self collectionWithElementsToRemove. 5470 self assert: res size = self empty size. 5471 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! 5472 5473!ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 5474testCopyNonEmptyWith 5475 "self debug: #testCopyNonEmptyWith" 5476 | res | 5477 res := self nonEmpty copyWith: self elementToAdd. 5478 "here we do not test the size since for a non empty set we would get a problem. 5479 Then in addition copy is not about duplicate management. The element should 5480 be in at the end." 5481 self assert: (res includes: self elementToAdd). 5482 self nonEmpty do: [ :each | res includes: each ]! ! 5483 5484!ArrayTest methodsFor: 'tests - copy'! 5485testCopyNonEmptyWithout 5486 "self debug: #testCopyNonEmptyWithout" 5487 5488 | res anElementOfTheCollection | 5489 anElementOfTheCollection := self nonEmpty anyOne. 5490 res := (self nonEmpty copyWithout: anElementOfTheCollection). 5491 "here we do not test the size since for a non empty set we would get a problem. 5492 Then in addition copy is not about duplicate management. The element should 5493 be in at the end." 5494 self deny: (res includes: anElementOfTheCollection). 5495 self nonEmpty do: 5496 [:each | (each = anElementOfTheCollection) 5497 ifFalse: [self assert: (res includes: each)]]. 5498 5499! ! 5500 5501!ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 5502testCopyNonEmptyWithoutAll 5503 "self debug: #testCopyNonEmptyWithoutAll" 5504 | res | 5505 res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. 5506 "here we do not test the size since for a non empty set we would get a problem. 5507 Then in addition copy is not about duplicate management. The element should 5508 be in at the end." 5509 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]. 5510 self nonEmpty do: 5511 [ :each | 5512 (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! 5513 5514!ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! 5515testCopyNonEmptyWithoutAllNotIncluded 5516 ! ! 5517 5518!ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 5519testCopyNonEmptyWithoutNotIncluded 5520 "self debug: #testCopyNonEmptyWithoutNotIncluded" 5521 | res | 5522 res := self nonEmpty copyWithout: self elementToAdd. 5523 "here we do not test the size since for a non empty set we would get a problem. 5524 Then in addition copy is not about duplicate management. The element should 5525 be in at the end." 5526 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 5527 5528 5529!ArrayTest methodsFor: 'tests - copy - clone'! 5530testCopyCreatesNewObject 5531 "self debug: #testCopyCreatesNewObject" 5532 5533 | copy | 5534 copy := self nonEmpty copy. 5535 self deny: self nonEmpty == copy. 5536 ! ! 5537 5538!ArrayTest methodsFor: 'tests - copy - clone'! 5539testCopyEmpty 5540 "self debug: #testCopyEmpty" 5541 5542 | copy | 5543 copy := self empty copy. 5544 self assert: copy isEmpty.! ! 5545 5546!ArrayTest methodsFor: 'tests - copy - clone'! 5547testCopyNonEmpty 5548 "self debug: #testCopyNonEmpty" 5549 5550 | copy | 5551 copy := self nonEmpty copy. 5552 self deny: copy isEmpty. 5553 self assert: copy size = self nonEmpty size. 5554 self nonEmpty do: 5555 [:each | copy includes: each]! ! 5556 5557 5558!ArrayTest methodsFor: 'tests - copying part of sequenceable'! 5559testCopyAfter 5560 | result index collection | 5561 collection := self collectionWithoutEqualsElements . 5562 index:= self indexInForCollectionWithoutDuplicates . 5563 result := collection copyAfter: (collection at:index ). 5564 5565 "verifying content: " 5566 (1) to: result size do: 5567 [:i | 5568 self assert: (collection at:(i + index ))=(result at: (i))]. 5569 5570 "verify size: " 5571 self assert: result size = (collection size - index).! ! 5572 5573!ArrayTest methodsFor: 'tests - copying part of sequenceable'! 5574testCopyAfterEmpty 5575 | result | 5576 result := self empty copyAfter: self collectionWithoutEqualsElements first. 5577 self assert: result isEmpty. 5578 ! ! 5579 5580!ArrayTest methodsFor: 'tests - copying part of sequenceable'! 5581testCopyAfterLast 5582 | result index collection | 5583 collection := self collectionWithoutEqualsElements . 5584 index:= self indexInForCollectionWithoutDuplicates . 5585 result := collection copyAfterLast: (collection at:index ). 5586 5587 "verifying content: " 5588 (1) to: result size do: 5589 [:i | 5590 self assert: (collection at:(i + index ))=(result at: (i))]. 5591 5592 "verify size: " 5593 self assert: result size = (collection size - index).! ! 5594 5595!ArrayTest methodsFor: 'tests - copying part of sequenceable'! 5596testCopyAfterLastEmpty 5597 | result | 5598 result := self empty copyAfterLast: self collectionWithoutEqualsElements first. 5599 self assert: result isEmpty.! ! 5600 5601!ArrayTest methodsFor: 'tests - copying part of sequenceable'! 5602testCopyEmptyMethod 5603 | result | 5604 result := self collectionWithoutEqualsElements copyEmpty . 5605 self assert: result isEmpty . 5606 self assert: result class= self nonEmpty class.! ! 5607 5608!ArrayTest methodsFor: 'tests - copying part of sequenceable'! 5609testCopyFromTo 5610 | result index collection | 5611 collection := self collectionWithoutEqualsElements . 5612 index :=self indexInForCollectionWithoutDuplicates . 5613 result := collection copyFrom: index to: collection size . 5614 5615 "verify content of 'result' : " 5616 1 to: result size do: 5617 [:i | 5618 self assert: (result at:i)=(collection at: (i + index - 1))]. 5619 5620 "verify size of 'result' : " 5621 self assert: result size = (collection size - index + 1).! ! 5622 5623!ArrayTest methodsFor: 'tests - copying part of sequenceable'! 5624testCopyUpTo 5625 | result index collection | 5626 collection := self collectionWithoutEqualsElements . 5627 index:= self indexInForCollectionWithoutDuplicates . 5628 result := collection copyUpTo: (collection at:index). 5629 5630 "verify content of 'result' :" 5631 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 5632 5633 "verify size of 'result' :" 5634 self assert: result size = (index-1). 5635 ! ! 5636 5637!ArrayTest methodsFor: 'tests - copying part of sequenceable'! 5638testCopyUpToEmpty 5639 | result | 5640 result := self empty copyUpTo: self collectionWithoutEqualsElements first. 5641 self assert: result isEmpty. 5642 ! ! 5643 5644!ArrayTest methodsFor: 'tests - copying part of sequenceable'! 5645testCopyUpToLast 5646 | result index collection | 5647 collection := self collectionWithoutEqualsElements . 5648 index:= self indexInForCollectionWithoutDuplicates . 5649 result := collection copyUpToLast: (collection at:index). 5650 5651 "verify content of 'result' :" 5652 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 5653 5654 "verify size of 'result' :" 5655 self assert: result size = (index-1).! ! 5656 5657!ArrayTest methodsFor: 'tests - copying part of sequenceable'! 5658testCopyUpToLastEmpty 5659 | result | 5660 result := self empty copyUpToLast: self collectionWithoutEqualsElements first. 5661 self assert: result isEmpty.! ! 5662 5663 5664!ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 5665testCopyAfterLastWithDuplicate 5666 | result element collection | 5667 collection := self collectionWithSameAtEndAndBegining . 5668 element := collection first. 5669 5670 " collectionWithSameAtEndAndBegining first and last elements are equals. 5671 'copyAfter:' should copy after the last occurence of element :" 5672 result := collection copyAfterLast: (element ). 5673 5674 "verifying content: " 5675 self assert: result isEmpty. 5676 5677! ! 5678 5679!ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 5680testCopyAfterWithDuplicate 5681 | result element collection | 5682 collection := self collectionWithSameAtEndAndBegining . 5683 element := collection last. 5684 5685 " collectionWithSameAtEndAndBegining first and last elements are equals. 5686 'copyAfter:' should copy after the first occurence :" 5687 result := collection copyAfter: (element ). 5688 5689 "verifying content: " 5690 1 to: result size do: 5691 [:i | 5692 self assert: (collection at:(i + 1 )) = (result at: (i)) 5693 ]. 5694 5695 "verify size: " 5696 self assert: result size = (collection size - 1).! ! 5697 5698!ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 5699testCopyUpToLastWithDuplicate 5700 | result element collection | 5701 collection := self collectionWithSameAtEndAndBegining . 5702 element := collection first. 5703 5704 " collectionWithSameAtEndAndBegining first and last elements are equals. 5705 'copyUpToLast:' should copy until the last occurence :" 5706 result := collection copyUpToLast: (element ). 5707 5708 "verifying content: " 5709 1 to: result size do: 5710 [:i | 5711 self assert: (result at: i ) = ( collection at: i ) 5712 ]. 5713 5714 self assert: result size = (collection size - 1). 5715 5716! ! 5717 5718!ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 5719testCopyUpToWithDuplicate 5720 | result element collection | 5721 collection := self collectionWithSameAtEndAndBegining . 5722 element := collection last. 5723 5724 " collectionWithSameAtEndAndBegining first and last elements are equals. 5725 'copyUpTo:' should copy until the first occurence :" 5726 result := collection copyUpTo: (element ). 5727 5728 "verifying content: " 5729 self assert: result isEmpty. 5730 5731! ! 5732 5733 5734!ArrayTest methodsFor: 'tests - copying same contents'! 5735testReverse 5736 | result | 5737 result := self nonEmpty reverse . 5738 5739 "verify content of 'result: '" 5740 1 to: result size do: 5741 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 5742 "verify size of 'result' :" 5743 self assert: result size=self nonEmpty size.! ! 5744 5745!ArrayTest methodsFor: 'tests - copying same contents'! 5746testReversed 5747 | result | 5748 result := self nonEmpty reversed . 5749 5750 "verify content of 'result: '" 5751 1 to: result size do: 5752 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 5753 "verify size of 'result' :" 5754 self assert: result size=self nonEmpty size.! ! 5755 5756!ArrayTest methodsFor: 'tests - copying same contents'! 5757testShallowCopy 5758 | result | 5759 result := self nonEmpty shallowCopy . 5760 5761 "verify content of 'result: '" 5762 1 to: self nonEmpty size do: 5763 [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. 5764 "verify size of 'result' :" 5765 self assert: result size=self nonEmpty size.! ! 5766 5767!ArrayTest methodsFor: 'tests - copying same contents'! 5768testShallowCopyEmpty 5769 | result | 5770 result := self empty shallowCopy . 5771 self assert: result isEmpty .! ! 5772 5773!ArrayTest methodsFor: 'tests - copying same contents'! 5774testShuffled 5775 | result | 5776 result := self nonEmpty shuffled . 5777 5778 "verify content of 'result: '" 5779 result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. 5780 "verify size of 'result' :" 5781 self assert: result size=self nonEmpty size.! ! 5782 5783!ArrayTest methodsFor: 'tests - copying same contents'! 5784testSortBy 5785 " can only be used if the collection tested can include sortable elements :" 5786 | result tmp | 5787 self 5788 shouldnt: [ self collectionWithSortableElements ] 5789 raise: Error. 5790 self shouldnt: [self collectionWithSortableElements anyOne < self collectionWithSortableElements anyOne] raise: Error. 5791 result := self collectionWithSortableElements sortBy: [ :a :b | a < b ]. 5792 5793 "verify content of 'result' : " 5794 result do: 5795 [ :each | 5796 (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 5797 tmp := result first. 5798 result do: 5799 [ :each | 5800 self assert: each >= tmp. 5801 tmp := each ]. 5802 5803 "verify size of 'result' :" 5804 self assert: result size = self collectionWithSortableElements size! ! 5805 5806 5807!ArrayTest methodsFor: 'tests - copying with or without'! 5808testCopyWithFirst 5809 5810 | index element result | 5811 index:= self indexInNonEmpty . 5812 element:= self nonEmpty at: index. 5813 5814 result := self nonEmpty copyWithFirst: element. 5815 5816 self assert: result size = (self nonEmpty size + 1). 5817 self assert: result first = element . 5818 5819 2 to: result size do: 5820 [ :i | 5821 self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! 5822 5823!ArrayTest methodsFor: 'tests - copying with or without'! 5824testCopyWithSequenceable 5825 5826 | result index element | 5827 index := self indexInNonEmpty . 5828 element := self nonEmpty at: index. 5829 result := self nonEmpty copyWith: (element ). 5830 5831 self assert: result size = (self nonEmpty size + 1). 5832 self assert: result last = element . 5833 5834 1 to: (result size - 1) do: 5835 [ :i | 5836 self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! 5837 5838!ArrayTest methodsFor: 'tests - copying with or without'! 5839testCopyWithoutFirst 5840 5841 | result | 5842 result := self nonEmpty copyWithoutFirst. 5843 5844 self assert: result size = (self nonEmpty size - 1). 5845 5846 1 to: result size do: 5847 [:i | 5848 self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! 5849 5850!ArrayTest methodsFor: 'tests - copying with or without'! 5851testCopyWithoutIndex 5852 | result index | 5853 index := self indexInNonEmpty . 5854 result := self nonEmpty copyWithoutIndex: index . 5855 5856 "verify content of 'result:'" 5857 1 to: result size do: 5858 [:i | 5859 i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. 5860 i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. 5861 5862 "verify size of result : " 5863 self assert: result size=(self nonEmpty size -1).! ! 5864 5865!ArrayTest methodsFor: 'tests - copying with or without'! 5866testForceToPaddingStartWith 5867 5868 | result element | 5869 element := self nonEmpty at: self indexInNonEmpty . 5870 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). 5871 5872 "verify content of 'result' : " 5873 1 to: 2 do: 5874 [:i | self assert: ( element ) = ( result at:(i) ) ]. 5875 5876 3 to: result size do: 5877 [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. 5878 5879 "verify size of 'result' :" 5880 self assert: result size = (self nonEmpty size + 2).! ! 5881 5882!ArrayTest methodsFor: 'tests - copying with or without'! 5883testForceToPaddingWith 5884 5885 | result element | 5886 element := self nonEmpty at: self indexInNonEmpty . 5887 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). 5888 5889 "verify content of 'result' : " 5890 1 to: self nonEmpty size do: 5891 [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. 5892 5893 (result size - 1) to: result size do: 5894 [:i | self assert: ( result at:i ) = ( element ) ]. 5895 5896 "verify size of 'result' :" 5897 self assert: result size = (self nonEmpty size + 2).! ! 5898 5899 5900!ArrayTest methodsFor: 'tests - copying with replacement'! 5901firstIndexesOf: subCollection in: collection 5902" return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " 5903 | tmp result currentIndex | 5904 tmp:= collection. 5905 result:= OrderedCollection new. 5906 currentIndex := 1. 5907 5908 [tmp isEmpty ]whileFalse: 5909 [ 5910 (tmp beginsWith: subCollection) 5911 ifTrue: [ 5912 result add: currentIndex. 5913 1 to: subCollection size do: 5914 [:i | 5915 tmp := tmp copyWithoutFirst. 5916 currentIndex := currentIndex + 1] 5917 ] 5918 ifFalse: [ 5919 tmp := tmp copyWithoutFirst. 5920 currentIndex := currentIndex +1. 5921 ] 5922 ]. 5923 5924 ^ result. 5925 ! ! 5926 5927!ArrayTest methodsFor: 'tests - copying with replacement'! 5928testCopyReplaceAllWith1Occurence 5929 | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | 5930 5931 result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 5932 5933 "detecting indexes of olSubCollection" 5934 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . 5935 index:= firstIndexesOfOccurrence at: 1. 5936 5937 "verify content of 'result' : " 5938 "first part of 'result'' : '" 5939 5940 1 to: (index -1) do: 5941 [ 5942 :i | 5943 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 5944 ]. 5945 5946 " middle part containing replacementCollection : " 5947 5948 index to: (index + self replacementCollection size-1) do: 5949 [ 5950 :i | 5951 self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) 5952 ]. 5953 5954 " end part :" 5955 5956 endPartIndexResult := index + self replacementCollection size . 5957 endPartIndexCollection := index + self oldSubCollection size . 5958 5959 1 to: (result size - endPartIndexResult - 1 ) do: 5960 [ 5961 :i | 5962 self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). 5963 ]. 5964 5965 5966 ! ! 5967 5968!ArrayTest methodsFor: 'tests - copying with replacement'! 5969testCopyReplaceAllWithManyOccurence 5970 | result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff | 5971 " testing fixture here as this method may be not used for collection that can't contain equals element :" 5972 self shouldnt: [self collectionWith2TimeSubcollection ]raise: Error. 5973 self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection ) = 2. 5974 5975 " test :" 5976 diff := self replacementCollection size - self oldSubCollection size. 5977 result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 5978 5979 "detecting indexes of olSubCollection" 5980 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection . 5981 5982 " verifying that replacementCollection has been put in places of oldSubCollections " 5983 firstIndexesOfOccurrence do: [ 5984 :each | 5985 (firstIndexesOfOccurrence indexOf: each) = 1 5986 ifTrue: [ 5987 each to: self replacementCollection size do: 5988 [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. 5989 ] 5990 ifFalse:[ 5991 (each + diff) to: self replacementCollection size do: 5992 [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. 5993 ]. 5994 5995 ]. 5996 5997 " verifying that the 'between' parts correspond to the initial collection : " 5998 1 to: firstIndexesOfOccurrence size do: [ 5999 :i | 6000 i = 1 6001 " specific comportement for the begining of the collection :" 6002 ifTrue: [ 6003 1 to: ((firstIndexesOfOccurrence at: i) - 1 ) do: 6004 [ :j | 6005 self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] 6006 ] 6007 " between parts till the end : " 6008 ifFalse: [ 6009 resultBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self replacementCollection size. 6010 collectionBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self oldSubCollection size. 6011 6012 1 to: ( firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: 6013 [ :j | 6014 self assert: (result at: (resultBetweenPartIndex + i - 1)) = (self collectionWith2TimeSubcollection at: (collectionBetweenPartIndex +i - 1)) ] 6015 ] 6016 ]. 6017 6018 "final part :" 6019 1 to: (self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size ) ) do: 6020 [ 6021 :i | 6022 self assert: ( result at:(firstIndexesOfOccurrence last + self replacementCollection size -1) + i ) = ( self collectionWith2TimeSubcollection at:(firstIndexesOfOccurrence last + self oldSubCollection size -1) + i ) . 6023 ]! ! 6024 6025!ArrayTest methodsFor: 'tests - copying with replacement'! 6026testCopyReplaceFromToWith 6027 | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | 6028 6029 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 6030 lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. 6031 lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. 6032 6033 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . 6034 6035 "verify content of 'result' : " 6036 "first part of 'result' " 6037 6038 1 to: (indexOfSubcollection - 1) do: 6039 [ 6040 :i | 6041 self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) 6042 ]. 6043 6044 " middle part containing replacementCollection : " 6045 6046 (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: 6047 [ 6048 :i | 6049 self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) 6050 ]. 6051 6052 " end part :" 6053 1 to: (result size - lastIndexOfReplacementCollection ) do: 6054 [ 6055 :i | 6056 self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). 6057 ]. 6058 6059 6060 6061 6062 6063 ! ! 6064 6065!ArrayTest methodsFor: 'tests - copying with replacement'! 6066testCopyReplaceFromToWithInsertion 6067 | result indexOfSubcollection | 6068 6069 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 6070 6071 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . 6072 6073 "verify content of 'result' : " 6074 "first part of 'result'' : '" 6075 6076 1 to: (indexOfSubcollection -1) do: 6077 [ 6078 :i | 6079 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 6080 ]. 6081 6082 " middle part containing replacementCollection : " 6083 indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: 6084 [ 6085 :i | 6086 self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) 6087 ]. 6088 6089 " end part :" 6090 (indexOfSubcollection + self replacementCollection size) to: (result size) do: 6091 [:i| 6092 self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. 6093 6094 " verify size: " 6095 self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). 6096 6097 6098 6099 6100 6101 ! ! 6102 6103 6104!ArrayTest methodsFor: 'tests - element accessing'! 6105testAfter 6106 "self debug: #testAfter" 6107 self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). 6108 self 6109 should: 6110 [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] 6111 raise: Error. 6112 self 6113 should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] 6114 raise: Error! ! 6115 6116!ArrayTest methodsFor: 'tests - element accessing'! 6117testAfterIfAbsent 6118 "self debug: #testAfterIfAbsent" 6119 self assert: (self moreThan4Elements 6120 after: (self moreThan4Elements at: 1) 6121 ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). 6122 self assert: (self moreThan4Elements 6123 after: (self moreThan4Elements at: self moreThan4Elements size) 6124 ifAbsent: [ 33 ]) == 33. 6125 self assert: (self moreThan4Elements 6126 after: self elementNotInForElementAccessing 6127 ifAbsent: [ 33 ]) = 33! ! 6128 6129!ArrayTest methodsFor: 'tests - element accessing'! 6130testAt 6131 "self debug: #testAt" 6132 " 6133 self assert: (self accessCollection at: 1) = 1. 6134 self assert: (self accessCollection at: 2) = 2. 6135 " 6136 | index | 6137 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 6138 self assert: (self moreThan4Elements at: index) = self elementInForElementAccessing! ! 6139 6140!ArrayTest methodsFor: 'tests - element accessing'! 6141testAtAll 6142 "self debug: #testAtAll" 6143 " self flag: #theCollectionshouldbe102030intheFixture. 6144 6145 self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. 6146 self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." 6147 | result | 6148 result := self moreThan4Elements atAll: #(2 1 2 ). 6149 self assert: (result at: 1) = (self moreThan4Elements at: 2). 6150 self assert: (result at: 2) = (self moreThan4Elements at: 1). 6151 self assert: (result at: 3) = (self moreThan4Elements at: 2). 6152 self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! 6153 6154!ArrayTest methodsFor: 'tests - element accessing'! 6155testAtIfAbsent 6156 "self debug: #testAt" 6157 | absent | 6158 absent := false. 6159 self moreThan4Elements 6160 at: self moreThan4Elements size + 1 6161 ifAbsent: [ absent := true ]. 6162 self assert: absent = true. 6163 absent := false. 6164 self moreThan4Elements 6165 at: self moreThan4Elements size 6166 ifAbsent: [ absent := true ]. 6167 self assert: absent = false! ! 6168 6169!ArrayTest methodsFor: 'tests - element accessing'! 6170testAtLast 6171 "self debug: #testAtLast" 6172 | index | 6173 self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. 6174 "tmp:=1. 6175 self do: 6176 [:each | 6177 each =self elementInForIndexAccessing 6178 ifTrue:[index:=tmp]. 6179 tmp:=tmp+1]." 6180 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 6181 self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! 6182 6183!ArrayTest methodsFor: 'tests - element accessing'! 6184testAtLastError 6185 "self debug: #testAtLast" 6186 self 6187 should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] 6188 raise: Error! ! 6189 6190!ArrayTest methodsFor: 'tests - element accessing'! 6191testAtLastIfAbsent 6192 "self debug: #testAtLastIfAbsent" 6193 self assert: (self moreThan4Elements 6194 atLast: 1 6195 ifAbsent: [ nil ]) = self moreThan4Elements last. 6196 self assert: (self moreThan4Elements 6197 atLast: self moreThan4Elements size + 1 6198 ifAbsent: [ 222 ]) = 222! ! 6199 6200!ArrayTest methodsFor: 'tests - element accessing'! 6201testAtOutOfBounds 6202 "self debug: #testAtOutOfBounds" 6203 self 6204 should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] 6205 raise: Error. 6206 self 6207 should: [ self moreThan4Elements at: -1 ] 6208 raise: Error! ! 6209 6210!ArrayTest methodsFor: 'tests - element accessing'! 6211testAtPin 6212 "self debug: #testAtPin" 6213 self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. 6214 self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. 6215 self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! 6216 6217!ArrayTest methodsFor: 'tests - element accessing'! 6218testAtRandom 6219 | result | 6220 result := self nonEmpty atRandom . 6221 self assert: (self nonEmpty includes: result).! ! 6222 6223!ArrayTest methodsFor: 'tests - element accessing'! 6224testAtWrap 6225 "self debug: #testAt" 6226 " 6227 self assert: (self accessCollection at: 1) = 1. 6228 self assert: (self accessCollection at: 2) = 2. 6229 " 6230 | index | 6231 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 6232 self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. 6233 self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. 6234 self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. 6235 self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! 6236 6237!ArrayTest methodsFor: 'tests - element accessing'! 6238testBefore 6239 "self debug: #testBefore" 6240 self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). 6241 self 6242 should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] 6243 raise: Error. 6244 self 6245 should: [ self moreThan4Elements before: 66 ] 6246 raise: Error! ! 6247 6248!ArrayTest methodsFor: 'tests - element accessing'! 6249testBeforeIfAbsent 6250 "self debug: #testBefore" 6251 self assert: (self moreThan4Elements 6252 before: (self moreThan4Elements at: 1) 6253 ifAbsent: [ 99 ]) = 99. 6254 self assert: (self moreThan4Elements 6255 before: (self moreThan4Elements at: 2) 6256 ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! 6257 6258!ArrayTest methodsFor: 'tests - element accessing'! 6259testFirstSecondThird 6260 "self debug: #testFirstSecondThird" 6261 self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). 6262 self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). 6263 self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). 6264 self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! 6265 6266!ArrayTest methodsFor: 'tests - element accessing'! 6267testLast 6268 "self debug: #testLast" 6269 self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! 6270 6271!ArrayTest methodsFor: 'tests - element accessing'! 6272testMiddle 6273 "self debug: #testMiddle" 6274 self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! 6275 6276 6277!ArrayTest methodsFor: 'tests - equality'! 6278testEqualSignForSequenceableCollections 6279 "self debug: #testEqualSign" 6280 6281 self deny: (self nonEmpty = self nonEmpty asSet). 6282 self deny: (self nonEmpty reversed = self nonEmpty). 6283 self deny: (self nonEmpty = self nonEmpty reversed).! ! 6284 6285!ArrayTest methodsFor: 'tests - equality'! 6286testHasEqualElements 6287 "self debug: #testHasEqualElements" 6288 6289 self deny: (self empty hasEqualElements: self nonEmpty). 6290 self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). 6291 self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). 6292 self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! 6293 6294!ArrayTest methodsFor: 'tests - equality'! 6295testHasEqualElementsIsTrueForNonIdenticalButEqualCollections 6296 "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" 6297 6298 self assert: (self empty hasEqualElements: self empty copy). 6299 self assert: (self empty copy hasEqualElements: self empty). 6300 self assert: (self empty copy hasEqualElements: self empty copy). 6301 6302 self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). 6303 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). 6304 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! 6305 6306!ArrayTest methodsFor: 'tests - equality'! 6307testHasEqualElementsOfIdenticalCollectionObjects 6308 "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" 6309 6310 self assert: (self empty hasEqualElements: self empty). 6311 self assert: (self nonEmpty hasEqualElements: self nonEmpty). 6312 ! ! 6313 6314 6315!ArrayTest methodsFor: 'tests - fixture'! 6316howMany: subCollection in: collection 6317" return an integer representing how many time 'subCollection' appears in 'collection' " 6318 | tmp nTime | 6319 tmp:= collection. 6320 nTime:= 0. 6321 6322 [tmp isEmpty ]whileFalse: 6323 [ 6324 (tmp beginsWith: subCollection) 6325 ifTrue: [ 6326 nTime := nTime + 1. 6327 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] 6328 ] 6329 ifFalse: [tmp := tmp copyWithoutFirst.] 6330 ]. 6331 6332 ^ nTime. 6333 ! ! 6334 6335!ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/17/2009 15:26'! 6336test0CopyTest 6337 self 6338 shouldnt: self empty 6339 raise: Error. 6340 self assert: self empty size = 0. 6341 self 6342 shouldnt: self nonEmpty 6343 raise: Error. 6344 self assert: (self nonEmpty size = 0) not. 6345 self 6346 shouldnt: self collectionWithElementsToRemove 6347 raise: Error. 6348 self assert: (self collectionWithElementsToRemove size = 0) not. 6349 self 6350 shouldnt: self elementToAdd 6351 raise: Error! ! 6352 6353!ArrayTest methodsFor: 'tests - fixture'! 6354test0FixtureAsSetForIdentityMultiplinessTest 6355 6356 "a collection (of elements for which copy is not identical ) without equal elements:" 6357 | element res | 6358 self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ]raise: Error. 6359 element := self elementsCopyNonIdenticalWithoutEqualElements anyOne. 6360 self deny: element copy == element . 6361 6362 res := true. 6363 self elementsCopyNonIdenticalWithoutEqualElements 6364 detect: 6365 [ :each | 6366 (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] 6367 ifNone: [ res := false ]. 6368 self assert: res = false 6369 6370 ! ! 6371 6372!ArrayTest methodsFor: 'tests - fixture'! 6373test0FixtureAsStringCommaAndDelimiterTest 6374 6375 self shouldnt: [self nonEmpty] raise:Error . 6376 self deny: self nonEmpty isEmpty. 6377 6378 self shouldnt: [self empty] raise:Error . 6379 self assert: self empty isEmpty. 6380 6381 self shouldnt: [self nonEmpty1Element ] raise:Error . 6382 self assert: self nonEmpty1Element size=1.! ! 6383 6384!ArrayTest methodsFor: 'tests - fixture'! 6385test0FixtureBeginsEndsWithTest 6386 6387 self shouldnt: [self nonEmpty ] raise: Error. 6388 self deny: self nonEmpty isEmpty. 6389 self assert: self nonEmpty size>1. 6390 6391 self shouldnt: [self empty ] raise: Error. 6392 self assert: self empty isEmpty.! ! 6393 6394!ArrayTest methodsFor: 'tests - fixture'! 6395test0FixtureCloneTest 6396 6397self shouldnt: [ self nonEmpty ] raise: Error. 6398self deny: self nonEmpty isEmpty. 6399 6400self shouldnt: [ self empty ] raise: Error. 6401self assert: self empty isEmpty. 6402 6403! ! 6404 6405!ArrayTest methodsFor: 'tests - fixture'! 6406test0FixtureConverAsSortedTest 6407 6408 self shouldnt: [self collectionWithSortableElements ] raise: Error. 6409 self deny: self collectionWithSortableElements isEmpty .! ! 6410 6411!ArrayTest methodsFor: 'tests - fixture'! 6412test0FixtureCopyPartOfForMultipliness 6413 6414self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. 6415 6416self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 6417 6418self assert: self collectionWithSameAtEndAndBegining size > 1. 6419 64201 to: self collectionWithSameAtEndAndBegining size do: 6421 [:i | 6422 (i > 1 ) & (i < self collectionWithSameAtEndAndBegining size) 6423 ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at:i) = (self collectionWithSameAtEndAndBegining first)]. 6424 ]! ! 6425 6426!ArrayTest methodsFor: 'tests - fixture'! 6427test0FixtureCopyPartOfSequenceableTest 6428 6429 self shouldnt: [self collectionWithoutEqualsElements ] raise: Error. 6430 self collectionWithoutEqualsElements do: 6431 [:each | self assert: (self collectionWithoutEqualsElements occurrencesOf: each)=1]. 6432 6433 self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. 6434 self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualsElements size. 6435 6436 self shouldnt: [self empty] raise: Error. 6437 self assert: self empty isEmpty .! ! 6438 6439!ArrayTest methodsFor: 'tests - fixture'! 6440test0FixtureCopySameContentsTest 6441 6442 self shouldnt: [self nonEmpty ] raise: Error. 6443 self deny: self nonEmpty isEmpty. 6444 6445 self shouldnt: [self empty ] raise: Error. 6446 self assert: self empty isEmpty. 6447 6448! ! 6449 6450!ArrayTest methodsFor: 'tests - fixture'! 6451test0FixtureCopyWithOrWithoutSpecificElementsTest 6452 6453 self shouldnt: [self nonEmpty ] raise: Error. 6454 self deny: self nonEmpty isEmpty . 6455 6456 self shouldnt: [self indexInNonEmpty ] raise: Error. 6457 self assert: self indexInNonEmpty > 0. 6458 self assert: self indexInNonEmpty <= self nonEmpty size.! ! 6459 6460!ArrayTest methodsFor: 'tests - fixture'! 6461test0FixtureCopyWithReplacementTest 6462 6463 self shouldnt: [self replacementCollection ]raise: Error. 6464 self shouldnt: [self oldSubCollection] raise: Error. 6465 6466 self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. 6467 self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. 6468 6469 ! ! 6470 6471!ArrayTest methodsFor: 'tests - fixture'! 6472test0FixtureCreationWithTest 6473 6474self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. 6475self assert: self collectionMoreThan5Elements size >= 5.! ! 6476 6477!ArrayTest methodsFor: 'tests - fixture'! 6478test0FixtureEmptySequenceableTest 6479 6480self shouldnt: [ self nonEmpty ] raise: Error. 6481self deny: self nonEmpty isEmpty . 6482 6483self shouldnt: [ self empty ] raise: Error. 6484self assert: self empty isEmpty.! ! 6485 6486!ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/15/2009 14:37'! 6487test0FixtureIncludeTest 6488 | elementIn | 6489 self 6490 shouldnt: [ self nonEmpty ] 6491 raise: Error. 6492 self deny: self nonEmpty isEmpty. 6493 self 6494 shouldnt: [ self elementNotIn ] 6495 raise: Error. 6496 elementIn := true. 6497 self nonEmpty 6498 detect: [ :each | each = self elementNotIn ] 6499 ifNone: [ elementIn := false ]. 6500 self assert: elementIn = false. 6501 self 6502 shouldnt: [ self anotherElementNotIn ] 6503 raise: Error. 6504 elementIn := true. 6505 self nonEmpty 6506 detect: [ :each | each = self anotherElementNotIn ] 6507 ifNone: [ elementIn := false ]. 6508 self assert: elementIn = false. 6509 self 6510 shouldnt: [ self collection ] 6511 raise: Error. 6512 "self shouldnt: [self collectionInForIncluding ] raise: Error." 6513 "collectionIn:=false. 6514 index:=1. 6515 1 to: self nonEmpty size do: 6516 [:i| 6517 collectionIn = false 6518 ifTrue:[(self nonEmpty at:i)=(self collectionInForIncluding at:index) 6519 ifTrue:[ 6520 index=self collectionInForIncluding 6521 ifTrue:[collectionIn := true]. 6522 index:=index+1.] 6523 ifFalse:[index:=1]. 6524 ] 6525 ]. 6526 self assert: collectionIn=true." 6527 self 6528 shouldnt: [ self empty ] 6529 raise: Error. 6530 self assert: self empty isEmpty. 6531 self 6532 shouldnt: [ self collectionOfFloat ] 6533 raise: Error. 6534 self collectionOfFloat do: [ :each | self assert: each class = Float ]. 6535 self 6536 shouldnt: [ self elementInForIncludesTest ] 6537 raise: Error. 6538 elementIn := true. 6539 self nonEmpty 6540 detect: [ :each | each = self elementInForIncludesTest ] 6541 ifNone: [ elementIn := false ]. 6542 self assert: elementIn = true! ! 6543 6544!ArrayTest methodsFor: 'tests - fixture'! 6545test0FixtureIncludeWithIdentityTest 6546 | element | 6547 self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. 6548 element := self collectionWithCopyNonIdentical anyOne. 6549 self deny: element == element copy. 6550! ! 6551 6552!ArrayTest methodsFor: 'tests - fixture'! 6553test0FixtureIndexAccessFotMultipliness 6554 self 6555 shouldnt: [ self collectionWithSameAtEndAndBegining ] 6556 raise: Error. 6557 self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 6558 self assert: self collectionWithSameAtEndAndBegining size > 1. 6559 1 to: self collectionWithSameAtEndAndBegining size 6560 do: 6561 [ :i | 6562 i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: 6563 [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! 6564 6565!ArrayTest methodsFor: 'tests - fixture'! 6566test0FixtureIndexAccessTest 6567 | res collection element | 6568 self 6569 shouldnt: [ self collectionMoreThan1NoDuplicates ] 6570 raise: Error. 6571 self assert: self collectionMoreThan1NoDuplicates size >1. 6572 res := true. 6573 self collectionMoreThan1NoDuplicates 6574 detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] 6575 ifNone: [ res := false ]. 6576 self assert: res = false. 6577 self 6578 shouldnt: [ self elementInForIndexAccessing ] 6579 raise: Error. 6580 self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). 6581 self 6582 shouldnt: [ self elementNotInForIndexAccessing ] 6583 raise: Error. 6584 self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! 6585 6586!ArrayTest methodsFor: 'tests - fixture'! 6587test0FixtureIterateSequencedReadableTest 6588 6589 | res | 6590 6591 self shouldnt: self nonEmptyMoreThan1Element raise: Error. 6592 self assert: self nonEmptyMoreThan1Element size > 1. 6593 6594 6595 self shouldnt: self empty raise: Error. 6596 self assert: self empty isEmpty . 6597 6598 res := true. 6599 self nonEmptyMoreThan1Element 6600 detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] 6601 ifNone: [ res := false ]. 6602 self assert: res = false.! ! 6603 6604!ArrayTest methodsFor: 'tests - fixture'! 6605test0FixtureOccurrencesForMultiplinessTest 6606 | cpt element collection | 6607 self shouldnt: [self collectionWithEqualElements ]raise: Error. 6608self shouldnt: [self collectionWithEqualElements ]raise: Error. 6609 6610self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 6611element := self elementTwiceInForOccurrences . 6612collection := self collectionWithEqualElements . 6613 6614cpt := 0 . 6615" testing with identity check ( == ) so that identy collections can use this trait : " 6616self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. 6617self assert: cpt = 2.! ! 6618 6619!ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/2/2009 11:53'! 6620test0FixtureOccurrencesTest 6621 self 6622 shouldnt: self empty 6623 raise: Error. 6624 self assert: self empty isEmpty. 6625 self 6626 shouldnt: self nonEmpty 6627 raise: Error. 6628 self deny: self nonEmpty isEmpty. 6629 self 6630 shouldnt: self elementInForOccurrences 6631 raise: Error. 6632 self assert: (self nonEmpty includes: self elementInForOccurrences). 6633 self 6634 shouldnt: self elementNotInForOccurrences 6635 raise: Error. 6636 self deny: (self nonEmpty includes: self elementNotInForOccurrences)! ! 6637 6638!ArrayTest methodsFor: 'tests - fixture'! 6639test0FixturePrintTest 6640 6641 self shouldnt: [self nonEmpty ] raise: Error.! ! 6642 6643!ArrayTest methodsFor: 'tests - fixture'! 6644test0FixturePutOneOrMoreElementsTest 6645 self shouldnt: self aValue raise: Error. 6646 6647 6648 self shouldnt: self indexArray raise: Error. 6649 self indexArray do: [ 6650 :each| 6651 self assert: each class = SmallInteger. 6652 self assert: (each>=1 & each<= self nonEmpty size). 6653 ]. 6654 6655 self assert: self indexArray size = self valueArray size. 6656 6657 self shouldnt: self empty raise: Error. 6658 self assert: self empty isEmpty . 6659 6660 self shouldnt: self nonEmpty raise: Error. 6661 self deny: self nonEmpty isEmpty.! ! 6662 6663!ArrayTest methodsFor: 'tests - fixture'! 6664test0FixturePutTest 6665 self shouldnt: self aValue raise: Error. 6666 self shouldnt: self anotherValue raise: Error. 6667 6668 self shouldnt: self anIndex raise: Error. 6669 self nonEmpty isDictionary 6670 ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. 6671 6672 self shouldnt: self empty raise: Error. 6673 self assert: self empty isEmpty . 6674 6675 self shouldnt: self nonEmpty raise: Error. 6676 self deny: self nonEmpty isEmpty.! ! 6677 6678!ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/14/2009 11:50'! 6679test0FixtureSequencedConcatenationTest 6680 self 6681 shouldnt: self empty 6682 raise: Exception. 6683 self assert: self empty isEmpty. 6684 self 6685 shouldnt: self firstCollection 6686 raise: Exception. 6687 self 6688 shouldnt: self secondCollection 6689 raise: Exception! ! 6690 6691!ArrayTest methodsFor: 'tests - fixture'! 6692test0FixtureSequencedElementAccessTest 6693 self 6694 shouldnt: [ self moreThan4Elements ] 6695 raise: Error. 6696 self assert: self moreThan4Elements size >= 4. 6697 self 6698 shouldnt: [ self subCollectionNotIn ] 6699 raise: Error. 6700 self subCollectionNotIn 6701 detect: [ :each | (self moreThan4Elements includes: each) not ] 6702 ifNone: [ self assert: false ]. 6703 self 6704 shouldnt: [ self elementNotInForElementAccessing ] 6705 raise: Error. 6706 self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). 6707 self 6708 shouldnt: [ self elementInForElementAccessing ] 6709 raise: Error. 6710 self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! 6711 6712!ArrayTest methodsFor: 'tests - fixture'! 6713test0FixtureSetAritmeticTest 6714 self 6715 shouldnt: [ self collection ] 6716 raise: Error. 6717 self deny: self collection isEmpty. 6718 self 6719 shouldnt: [ self nonEmpty ] 6720 raise: Error. 6721 self deny: self nonEmpty isEmpty. 6722 self 6723 shouldnt: [ self anotherElementOrAssociationNotIn ] 6724 raise: Error. 6725 self collection isDictionary 6726 ifTrue: 6727 [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] 6728 ifFalse: 6729 [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. 6730 self 6731 shouldnt: [ self collectionClass ] 6732 raise: Error! ! 6733 6734!ArrayTest methodsFor: 'tests - fixture'! 6735test0FixtureSubcollectionAccessTest 6736 self 6737 shouldnt: [ self moreThan3Elements ] 6738 raise: Error. 6739 self assert: self moreThan3Elements size > 2! ! 6740 6741!ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/28/2009 14:11'! 6742test0FixtureTConvertAsSetForMultiplinessTest 6743 "a collection ofFloat with equal elements:" 6744 | res | 6745 self 6746 shouldnt: [ self withEqualElements ] 6747 raise: Error. 6748 self 6749 shouldnt: 6750 [ self withEqualElements do: [ :each | self assert: each class = Float ] ] 6751 raise: Error. 6752 res := true. 6753 self withEqualElements 6754 detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] 6755 ifNone: [ res := false ]. 6756 self assert: res = true. 6757 6758 "a collection of Float without equal elements:" 6759 self 6760 shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ] 6761 raise: Error. 6762 self 6763 shouldnt: 6764 [ self elementsCopyNonIdenticalWithoutEqualElements do: [ :each | self assert: each class = Float ] ] 6765 raise: Error. 6766 res := true. 6767 self elementsCopyNonIdenticalWithoutEqualElements 6768 detect: 6769 [ :each | 6770 (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] 6771 ifNone: [ res := false ]. 6772 self assert: res = false! ! 6773 6774!ArrayTest methodsFor: 'tests - fixture'! 6775test0FixtureTConvertTest 6776 "a collection of number without equal elements:" 6777 | res | 6778 self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. 6779 6780 res := true. 6781 self collectionWithoutEqualElements 6782 detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] 6783 ifNone: [ res := false ]. 6784 self assert: res = false. 6785 6786 6787! ! 6788 6789!ArrayTest methodsFor: 'tests - fixture'! 6790test0SortingArrayedTest 6791 | tmp sorted | 6792 " an unsorted collection of number " 6793 self shouldnt: [ self unsortedCollection ]raise: Error. 6794 self unsortedCollection do:[:each | each isNumber]. 6795 sorted := true. 6796 self unsortedCollection pairsDo: [ 6797 :each1 :each2 | 6798 each2 < each1 ifTrue: [ sorted := false]. 6799 ]. 6800 self assert: sorted = false. 6801 6802 6803 6804 " a collection of number sorted in an ascending order" 6805 self shouldnt: [ self sortedInAscendingOrderCollection ]raise: Error. 6806 self sortedInAscendingOrderCollection do:[:each | each isNumber]. 6807 tmp:= self sortedInAscendingOrderCollection at:1. 6808 self sortedInAscendingOrderCollection do: 6809 [: each | self assert: (each>= tmp). tmp:=each] 6810 ! ! 6811 6812!ArrayTest methodsFor: 'tests - fixture'! 6813test0TSequencedStructuralEqualityTest 6814 6815 self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! 6816 6817!ArrayTest methodsFor: 'tests - fixture'! 6818test0TStructuralEqualityTest 6819 self shouldnt: [self empty] raise: Error. 6820 self shouldnt: [self nonEmpty] raise: Error. 6821 self assert: self empty isEmpty. 6822 self deny: self nonEmpty isEmpty.! ! 6823 6824!ArrayTest methodsFor: 'tests - fixture'! 6825testOFixtureReplacementSequencedTest 6826 6827 self shouldnt: self nonEmpty raise: Error. 6828 self deny: self nonEmpty isEmpty. 6829 6830 self shouldnt: self elementInForReplacement raise: Error. 6831 self assert: (self nonEmpty includes: self elementInForReplacement ) . 6832 6833 self shouldnt: self newElement raise: Error. 6834 6835 self shouldnt: self firstIndex raise: Error. 6836 self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). 6837 6838 self shouldnt: self secondIndex raise: Error. 6839 self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). 6840 6841 self assert: self firstIndex <=self secondIndex . 6842 6843 self shouldnt: self replacementCollection raise: Error. 6844 6845 self shouldnt: self replacementCollectionSameSize raise: Error. 6846 self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size 6847 ! ! 6848 6849 6850!ArrayTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! 6851testIdentityIncludes 6852 " test the comportement in presence of elements 'includes' but not 'identityIncludes' " 6853 " can not be used by collections that can't include elements for wich copy doesn't return another instance " 6854 | collection element | 6855 self 6856 shouldnt: [ self collectionWithCopyNonIdentical ] 6857 raise: Error. 6858 collection := self collectionWithCopyNonIdentical. 6859 element := collection anyOne copy. 6860 "self assert: (collection includes: element)." 6861 self deny: (collection identityIncludes: element)! ! 6862 6863!ArrayTest methodsFor: 'tests - includes'! 6864testIdentityIncludesNonSpecificComportement 6865 " test the same comportement than 'includes: ' " 6866 | collection | 6867 collection := self nonEmpty . 6868 6869 self deny: (collection identityIncludes: self elementNotIn ). 6870 self assert:(collection identityIncludes: collection anyOne) 6871! ! 6872 6873!ArrayTest methodsFor: 'tests - includes'! 6874testIncludesAllOfAllThere 6875 "self debug: #testIncludesAllOfAllThere'" 6876 self assert: (self empty includesAllOf: self empty). 6877 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 6878 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 6879 6880!ArrayTest methodsFor: 'tests - includes'! 6881testIncludesAllOfNoneThere 6882 "self debug: #testIncludesAllOfNoneThere'" 6883 self deny: (self empty includesAllOf: self nonEmpty ). 6884 self deny: (self nonEmpty includesAllOf: { self elementNotIn. self anotherElementNotIn })! ! 6885 6886!ArrayTest methodsFor: 'tests - includes'! 6887testIncludesAnyOfAllThere 6888 "self debug: #testIncludesAnyOfAllThere'" 6889 self deny: (self nonEmpty includesAnyOf: self empty). 6890 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 6891 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 6892 6893!ArrayTest methodsFor: 'tests - includes'! 6894testIncludesAnyOfNoneThere 6895 "self debug: #testIncludesAnyOfNoneThere'" 6896 self deny: (self nonEmpty includesAnyOf: self empty). 6897 self deny: (self nonEmpty includesAnyOf: { self elementNotIn. self anotherElementNotIn })! ! 6898 6899!ArrayTest methodsFor: 'tests - includes'! 6900testIncludesElementIsNotThere 6901 "self debug: #testIncludesElementIsNotThere" 6902 6903 self deny: (self nonEmpty includes: self elementNotIn). 6904 self assert: (self nonEmpty includes: self nonEmpty anyOne). 6905 self deny: (self empty includes: self elementNotIn)! ! 6906 6907!ArrayTest methodsFor: 'tests - includes'! 6908testIncludesElementIsThere 6909 "self debug: #testIncludesElementIsThere" 6910 6911 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 6912 6913 6914!ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/15/2009 14:22'! 6915testIdentityIndexOf 6916 "self debug: #testIdentityIndexOf" 6917 | collection element | 6918 element := self elementInCollectionOfFloat copy. 6919 self deny: self elementInCollectionOfFloat == element. 6920 collection := self collectionOfFloat copyWith: element. 6921 self assert: (collection identityIndexOf: element) = collection size! ! 6922 6923!ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/15/2009 14:22'! 6924testIdentityIndexOfIAbsent 6925 "self debug: #testIdentityIndexOfIfAbsent" 6926 | collection element | 6927 element := self elementInCollectionOfFloat copy. 6928 self deny: self elementInCollectionOfFloat == element. 6929 collection := self collectionOfFloat copyWith: element. 6930 self assert: (collection 6931 identityIndexOf: element 6932 ifAbsent: [ 0 ]) = collection size. 6933 self assert: (self collectionOfFloat 6934 identityIndexOf: element 6935 ifAbsent: [ 55 ]) = 55! ! 6936 6937!ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 6938testIndexOf 6939 "self debug: #testIndexOf" 6940 | tmp index collection | 6941 collection := self collectionMoreThan1NoDuplicates. 6942 tmp := collection size. 6943 collection reverseDo: 6944 [ :each | 6945 each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. 6946 tmp := tmp - 1 ]. 6947 self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! 6948 6949!ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 6950testIndexOfIfAbsent 6951 "self debug: #testIndexOfIfAbsent" 6952 | collection | 6953 collection := self collectionMoreThan1NoDuplicates. 6954 self assert: (collection 6955 indexOf: collection first 6956 ifAbsent: [ 33 ]) = 1. 6957 self assert: (collection 6958 indexOf: self elementNotInForIndexAccessing 6959 ifAbsent: [ 33 ]) = 33! ! 6960 6961!ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 6962testIndexOfStartingAt 6963 "self debug: #testLastIndexOf" 6964 | element collection | 6965 collection := self collectionMoreThan1NoDuplicates. 6966 element := collection first. 6967 self assert: (collection 6968 indexOf: element 6969 startingAt: 2 6970 ifAbsent: [ 99 ]) = 99. 6971 self assert: (collection 6972 indexOf: element 6973 startingAt: 1 6974 ifAbsent: [ 99 ]) = 1. 6975 self assert: (collection 6976 indexOf: self elementNotInForIndexAccessing 6977 startingAt: 1 6978 ifAbsent: [ 99 ]) = 99! ! 6979 6980!ArrayTest methodsFor: 'tests - index access'! 6981testIndexOfStartingAtIfAbsent 6982 "self debug: #testLastIndexOf" 6983 | element collection | 6984 collection := self collectionMoreThan1NoDuplicates. 6985 element := collection first. 6986 self assert: (collection 6987 indexOf: element 6988 startingAt: 2 6989 ifAbsent: [ 99 ]) = 99. 6990 self assert: (collection 6991 indexOf: element 6992 startingAt: 1 6993 ifAbsent: [ 99 ]) = 1. 6994 self assert: (collection 6995 indexOf: self elementNotInForIndexAccessing 6996 startingAt: 1 6997 ifAbsent: [ 99 ]) = 99! ! 6998 6999!ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 7000testIndexOfSubCollectionStartingAt 7001 "self debug: #testIndexOfIfAbsent" 7002 | subcollection index collection | 7003 collection := self collectionMoreThan1NoDuplicates. 7004 subcollection := self collectionMoreThan1NoDuplicates. 7005 index := collection 7006 indexOfSubCollection: subcollection 7007 startingAt: 1. 7008 self assert: index = 1. 7009 index := collection 7010 indexOfSubCollection: subcollection 7011 startingAt: 2. 7012 self assert: index = 0! ! 7013 7014!ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 7015testIndexOfSubCollectionStartingAtIfAbsent 7016 "self debug: #testIndexOfIfAbsent" 7017 | index absent subcollection collection | 7018 collection := self collectionMoreThan1NoDuplicates. 7019 subcollection := self collectionMoreThan1NoDuplicates. 7020 absent := false. 7021 index := collection 7022 indexOfSubCollection: subcollection 7023 startingAt: 1 7024 ifAbsent: [ absent := true ]. 7025 self assert: absent = false. 7026 absent := false. 7027 index := collection 7028 indexOfSubCollection: subcollection 7029 startingAt: 2 7030 ifAbsent: [ absent := true ]. 7031 self assert: absent = true! ! 7032 7033!ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 7034testLastIndexOf 7035 "self debug: #testLastIndexOf" 7036 | element collection | 7037 collection := self collectionMoreThan1NoDuplicates. 7038 element := collection first. 7039 self assert: (collection lastIndexOf: element) = 1. 7040 self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! 7041 7042!ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 7043testLastIndexOfIfAbsent 7044 "self debug: #testIndexOfIfAbsent" 7045 | element collection | 7046 collection := self collectionMoreThan1NoDuplicates. 7047 element := collection first. 7048 self assert: (collection 7049 lastIndexOf: element 7050 ifAbsent: [ 99 ]) = 1. 7051 self assert: (collection 7052 lastIndexOf: self elementNotInForIndexAccessing 7053 ifAbsent: [ 99 ]) = 99! ! 7054 7055!ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 7056testLastIndexOfStartingAt 7057 "self debug: #testLastIndexOf" 7058 | element collection | 7059 collection := self collectionMoreThan1NoDuplicates. 7060 element := collection last. 7061 self assert: (collection 7062 lastIndexOf: element 7063 startingAt: collection size 7064 ifAbsent: [ 99 ]) = collection size. 7065 self assert: (collection 7066 lastIndexOf: element 7067 startingAt: collection size - 1 7068 ifAbsent: [ 99 ]) = 99. 7069 self assert: (collection 7070 lastIndexOf: self elementNotInForIndexAccessing 7071 startingAt: collection size 7072 ifAbsent: [ 99 ]) = 99! ! 7073 7074 7075!ArrayTest methodsFor: 'tests - index accessing for multipliness'! 7076testIdentityIndexOfDuplicate 7077 "self debug: #testIdentityIndexOf" 7078 | collection element | 7079 7080 "testing fixture here as this method may not be used by some collections testClass" 7081 self shouldnt: [self collectionWithNonIdentitySameAtEndAndBegining ] raise: Error. 7082 collection := self collectionWithNonIdentitySameAtEndAndBegining . 7083 self assert: collection first = collection last. 7084 self deny: collection first == collection last. 7085 1 to: collection size do: 7086 [ :i | 7087 i > 1 & (i < collection size) ifTrue: 7088 [ self deny: (collection at: i) = collection first ] ]. 7089 7090 7091 element := collection last. 7092 " floatCollectionWithSameAtEndAndBegining first and last elements are equals but are not the same object" 7093 self assert: (collection identityIndexOf: element) = collection size! ! 7094 7095!ArrayTest methodsFor: 'tests - index accessing for multipliness'! 7096testIdentityIndexOfIAbsentDuplicate 7097 "self debug: #testIdentityIndexOfIfAbsent" 7098 | collection element elementCopy | 7099 collection := self collectionWithNonIdentitySameAtEndAndBegining . 7100 element := collection last. 7101 elementCopy := element copy. 7102 self deny: element == elementCopy . 7103 self assert: (collection 7104 identityIndexOf: element 7105 ifAbsent: [ 0 ]) = collection size. 7106 self assert: (collection 7107 identityIndexOf: elementCopy 7108 ifAbsent: [ 55 ]) = 55! ! 7109 7110!ArrayTest methodsFor: 'tests - index accessing for multipliness'! 7111testIndexOfDuplicate 7112 "self debug: #testIndexOf" 7113 | collection element | 7114 collection := self collectionWithSameAtEndAndBegining. 7115 element := collection last. 7116 7117 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 7118 'indexOf: should return the position of the first occurrence :'" 7119 self assert: (collection indexOf: element) = 1! ! 7120 7121!ArrayTest methodsFor: 'tests - index accessing for multipliness'! 7122testIndexOfIfAbsentDuplicate 7123 "self debug: #testIndexOfIfAbsent" 7124 | collection element | 7125 collection := self collectionWithSameAtEndAndBegining. 7126 element := collection last. 7127 7128 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 7129 'indexOf:ifAbsent: should return the position of the first occurrence :'" 7130 self assert: (collection 7131 indexOf: element 7132 ifAbsent: [ 55 ]) = 1! ! 7133 7134!ArrayTest methodsFor: 'tests - index accessing for multipliness'! 7135testIndexOfStartingAtDuplicate 7136 "self debug: #testLastIndexOf" 7137 | collection element | 7138 collection := self collectionWithSameAtEndAndBegining. 7139 element := collection last. 7140 7141 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 7142 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" 7143 self assert: (collection 7144 indexOf: element 7145 startingAt: 1 7146 ifAbsent: [ 55 ]) = 1. 7147 self assert: (collection 7148 indexOf: element 7149 startingAt: 2 7150 ifAbsent: [ 55 ]) = collection size! ! 7151 7152!ArrayTest methodsFor: 'tests - index accessing for multipliness'! 7153testLastIndexOfDuplicate 7154 "self debug: #testLastIndexOf" 7155 | collection element | 7156 collection := self collectionWithSameAtEndAndBegining. 7157 element := collection first. 7158 7159 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 7160 'lastIndexOf: should return the position of the last occurrence :'" 7161 self assert: (collection lastIndexOf: element) = collection size! ! 7162 7163!ArrayTest methodsFor: 'tests - index accessing for multipliness'! 7164testLastIndexOfIfAbsentDuplicate 7165 "self debug: #testIndexOfIfAbsent" 7166 "self debug: #testLastIndexOf" 7167 | collection element | 7168 collection := self collectionWithSameAtEndAndBegining. 7169 element := collection first. 7170 7171 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 7172 'lastIndexOf: should return the position of the last occurrence :'" 7173 self assert: (collection 7174 lastIndexOf: element 7175 ifAbsent: [ 55 ]) = collection size! ! 7176 7177!ArrayTest methodsFor: 'tests - index accessing for multipliness'! 7178testLastIndexOfStartingAtDuplicate 7179 "self debug: #testLastIndexOf" 7180 | collection element | 7181 collection := self collectionWithSameAtEndAndBegining. 7182 element := collection last. 7183 7184 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 7185 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" 7186 self assert: (collection 7187 lastIndexOf: element 7188 startingAt: collection size 7189 ifAbsent: [ 55 ]) = collection size. 7190 self assert: (collection 7191 lastIndexOf: element 7192 startingAt: collection size - 1 7193 ifAbsent: [ 55 ]) = 1! ! 7194 7195 7196!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7197testAllButFirstDo 7198 7199 | result | 7200 result:= OrderedCollection new. 7201 7202 self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 7203 7204 1 to: (result size) do: 7205 [:i| 7206 self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. 7207 7208 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 7209 7210!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7211testAllButLastDo 7212 7213 | result | 7214 result:= OrderedCollection new. 7215 7216 self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 7217 7218 1 to: (result size) do: 7219 [:i| 7220 self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. 7221 7222 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 7223 7224!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7225testCollectFromTo 7226 7227 | result | 7228 result:=self nonEmptyMoreThan1Element 7229 collect: [ :each | each ] 7230 from: 1 7231 to: (self nonEmptyMoreThan1Element size - 1). 7232 7233 1 to: result size 7234 do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. 7235 self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! 7236 7237!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7238testDetectSequenced 7239" testing that detect keep the first element returning true for sequenceable collections " 7240 7241 | element result | 7242 element := self nonEmptyMoreThan1Element at:1. 7243 result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. 7244 self assert: result = element. ! ! 7245 7246!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7247testFindFirst 7248 7249 | element result | 7250 element := self nonEmptyMoreThan1Element at:1. 7251 result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. 7252 7253 self assert: result=1. ! ! 7254 7255!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7256testFindFirstNotIn 7257 7258 | result | 7259 7260 result:=self empty findFirst: [:each | true]. 7261 7262 self assert: result=0. ! ! 7263 7264!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7265testFindLast 7266 7267 | element result | 7268 element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. 7269 result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. 7270 7271 self assert: result=self nonEmptyMoreThan1Element size. ! ! 7272 7273!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7274testFindLastNotIn 7275 7276 | result | 7277 7278 result:=self empty findFirst: [:each | true]. 7279 7280 self assert: result=0. ! ! 7281 7282!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7283testFromToDo 7284 7285 | result | 7286 result:= OrderedCollection new. 7287 7288 self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 7289 7290 1 to: (self nonEmptyMoreThan1Element size -1) do: 7291 [:i| 7292 self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. 7293 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 7294 7295!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7296testKeysAndValuesDo 7297 "| result | 7298 result:= OrderedCollection new. 7299 7300 self nonEmptyMoreThan1Element keysAndValuesDo: 7301 [:i :value| 7302 result add: (value+i)]. 7303 7304 1 to: result size do: 7305 [:i| 7306 self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" 7307 | indexes elements | 7308 indexes:= OrderedCollection new. 7309 elements := OrderedCollection new. 7310 7311 self nonEmptyMoreThan1Element keysAndValuesDo: 7312 [:i :value| 7313 indexes add: (i). 7314 elements add: value]. 7315 7316 (1 to: self nonEmptyMoreThan1Element size )do: 7317 [ :i | 7318 self assert: (indexes at: i) = i. 7319 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 7320 ]. 7321 7322 self assert: indexes size = elements size. 7323 self assert: indexes size = self nonEmptyMoreThan1Element size . 7324 7325 ! ! 7326 7327!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7328testKeysAndValuesDoEmpty 7329 | result | 7330 result:= OrderedCollection new. 7331 7332 self empty keysAndValuesDo: 7333 [:i :value| 7334 result add: (value+i)]. 7335 7336 self assert: result isEmpty .! ! 7337 7338!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7339testPairsCollect 7340 7341 | index result | 7342 index:=0. 7343 7344 result:=self nonEmptyMoreThan1Element pairsCollect: 7345 [:each1 :each2 | 7346 self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). 7347 (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). 7348 ]. 7349 7350 result do: 7351 [:each | self assert: each = true]. 7352 7353! ! 7354 7355!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7356testPairsDo 7357 | index | 7358 index:=1. 7359 7360 self nonEmptyMoreThan1Element pairsDo: 7361 [:each1 :each2 | 7362 self assert:(self nonEmptyMoreThan1Element at:index)=each1. 7363 self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. 7364 index:=index+2]. 7365 7366 self nonEmptyMoreThan1Element size odd 7367 ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] 7368 ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! 7369 7370!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7371testReverseDo 7372 | result | 7373 result:= OrderedCollection new. 7374 self nonEmpty reverseDo: [: each | result add: each]. 7375 7376 1 to: result size do: 7377 [:i| 7378 self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! 7379 7380!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7381testReverseDoEmpty 7382 | result | 7383 result:= OrderedCollection new. 7384 self empty reverseDo: [: each | result add: each]. 7385 7386 self assert: result isEmpty .! ! 7387 7388!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7389testReverseWithDo 7390 7391 | secondCollection result index | 7392 result:= OrderedCollection new. 7393 index := self nonEmptyMoreThan1Element size + 1. 7394 secondCollection:= self nonEmptyMoreThan1Element copy. 7395 7396 self nonEmptyMoreThan1Element reverseWith: secondCollection do: 7397 [:a :b | 7398 self assert: (self nonEmptyMoreThan1Element indexOf: a ) = (index := index - 1 ). 7399 result add: (a = b)]. 7400 7401 1 to: result size do: 7402 [:i| 7403 self assert: (result at:i)=(true)]. 7404 self assert: result size = self nonEmptyMoreThan1Element size.! ! 7405 7406!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7407testWithCollect 7408 7409 | result newCollection index collection | 7410 7411 index := 0. 7412 collection := self nonEmptyMoreThan1Element . 7413 newCollection := collection copy. 7414 result:=collection with: newCollection collect: [:a :b | 7415 self assert: (collection indexOf: a ) = ( index := index + 1). 7416 self assert: (a = b). 7417 b]. 7418 7419 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 7420 self assert: result size = collection size.! ! 7421 7422!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7423testWithCollectError 7424 self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! 7425 7426!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7427testWithDo 7428 7429 | secondCollection result index | 7430 result:= OrderedCollection new. 7431 secondCollection:= self nonEmptyMoreThan1Element copy. 7432 index := 0. 7433 7434 self nonEmptyMoreThan1Element with: secondCollection do: 7435 [:a :b | 7436 self assert: (self nonEmptyMoreThan1Element indexOf: a) = ( index := index + 1). 7437 result add: (a =b)]. 7438 7439 1 to: result size do: 7440 [:i| 7441 self assert: (result at:i)=(true)]. 7442 self assert: result size = self nonEmptyMoreThan1Element size.! ! 7443 7444!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7445testWithDoError 7446 7447 self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! 7448 7449!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7450testWithIndexCollect 7451 7452 | result index collection | 7453 index := 0. 7454 collection := self nonEmptyMoreThan1Element . 7455 result := collection withIndexCollect: [:each :i | 7456 self assert: i = (index := index + 1). 7457 self assert: i = (collection indexOf: each) . 7458 each] . 7459 7460 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 7461 self assert: result size = collection size.! ! 7462 7463!ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 7464testWithIndexDo 7465 7466 "| result | 7467 result:=Array new: self nonEmptyMoreThan1Element size. 7468 self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 7469 7470 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" 7471 | indexes elements | 7472 indexes:= OrderedCollection new. 7473 elements := OrderedCollection new. 7474 7475 self nonEmptyMoreThan1Element withIndexDo: 7476 [:value :i | 7477 indexes add: (i). 7478 elements add: value]. 7479 7480 (1 to: self nonEmptyMoreThan1Element size )do: 7481 [ :i | 7482 self assert: (indexes at: i) = i. 7483 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 7484 ]. 7485 7486 self assert: indexes size = elements size. 7487 self assert: indexes size = self nonEmptyMoreThan1Element size . 7488 ! ! 7489 7490 7491!ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:52'! 7492testOccurrencesOf 7493 | result expected | 7494 result := self nonEmpty occurrencesOf: self elementInForOccurrences. 7495 expected := 0. 7496 self nonEmpty do: [ :each | self elementInForOccurrences = each ifTrue: [ expected := expected + 1 ] ]. 7497 self assert: result = expected! ! 7498 7499!ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:52'! 7500testOccurrencesOfEmpty 7501 | result | 7502 result := self empty occurrencesOf: self elementInForOccurrences. 7503 self assert: result = 0! ! 7504 7505!ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:53'! 7506testOccurrencesOfNotIn 7507 | result | 7508 result := self empty occurrencesOf: self elementNotInForOccurrences. 7509 self assert: result = 0! ! 7510 7511 7512!ArrayTest methodsFor: 'tests - occurrencesOf for multipliness'! 7513testOccurrencesOfForMultipliness 7514 7515| collection element | 7516collection := self collectionWithEqualElements . 7517element := self elementTwiceInForOccurrences . 7518 7519self assert: (collection occurrencesOf: element ) = 2. ! ! 7520 7521 7522!ArrayTest methodsFor: 'tests - printing'! 7523testPrintElementsOn 7524 7525 | aStream result allElementsAsString | 7526 result:=''. 7527 aStream:= ReadWriteStream on: result. 7528 7529 self nonEmpty printElementsOn: aStream . 7530 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 7531 1 to: allElementsAsString size do: 7532 [:i | 7533 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 7534 ].! ! 7535 7536!ArrayTest methodsFor: 'tests - printing'! 7537testPrintNameOn 7538 7539 | aStream result | 7540 result:=''. 7541 aStream:= ReadWriteStream on: result. 7542 7543 self nonEmpty printNameOn: aStream . 7544 Transcript show: result asString. 7545 self nonEmpty class name first isVowel 7546 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 7547 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 7548 7549!ArrayTest methodsFor: 'tests - printing'! 7550testPrintOn 7551 | aStream result allElementsAsString | 7552 result:=''. 7553 aStream:= ReadWriteStream on: result. 7554 7555 self nonEmpty printOn: aStream . 7556 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 7557 1 to: allElementsAsString size do: 7558 [:i | 7559 i=1 7560 ifTrue:[ 7561 self accessCollection class name first isVowel 7562 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 7563 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 7564 i=2 7565 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 7566 i>2 7567 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. 7568 ].! ! 7569 7570!ArrayTest methodsFor: 'tests - printing'! 7571testPrintOnDelimiter 7572 | aStream result allElementsAsString | 7573 result:=''. 7574 aStream:= ReadWriteStream on: result. 7575 7576 self nonEmpty printOn: aStream delimiter: ', ' . 7577 7578 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 7579 1 to: allElementsAsString size do: 7580 [:i | 7581 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 7582 ].! ! 7583 7584!ArrayTest methodsFor: 'tests - printing'! 7585testPrintOnDelimiterLast 7586 7587 | aStream result allElementsAsString | 7588 result:=''. 7589 aStream:= ReadWriteStream on: result. 7590 7591 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 7592 7593 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 7594 1 to: allElementsAsString size do: 7595 [:i | 7596 i<(allElementsAsString size-1 ) 7597 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 7598 i=(allElementsAsString size-1) 7599 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 7600 i=(allElementsAsString size) 7601 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 7602 ].! ! 7603 7604!ArrayTest methodsFor: 'tests - printing'! 7605testStoreOn 7606" for the moment work only for collection that include simple elements such that Integer" 7607 7608"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 7609string := ''. 7610str := ReadWriteStream on: string. 7611elementsAsStringExpected := OrderedCollection new. 7612elementsAsStringObtained := OrderedCollection new. 7613self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 7614 7615self nonEmpty storeOn: str. 7616result := str contents . 7617cuttedResult := ( result findBetweenSubStrs: ';' ). 7618 7619index := 1. 7620 7621cuttedResult do: 7622 [ :each | 7623 index = 1 7624 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 7625 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 7626 elementsAsStringObtained add: tmp. 7627 index := index + 1. ] 7628 ifFalse: [ 7629 index < cuttedResult size 7630 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 7631 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 7632 elementsAsStringObtained add: tmp. 7633 index := index + 1.] 7634 ifFalse: [self assert: ( each = ' yourself)' ) ]. 7635 ] 7636 7637 ]. 7638 7639 7640 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 7641 7642! ! 7643 7644 7645!ArrayTest methodsFor: 'tests - puting with indexes'! 7646testAtAllIndexesPut 7647 7648 self nonEmpty atAllPut: self aValue. 7649 self nonEmpty do:[ :each| self assert: each = self aValue]. 7650 ! ! 7651 7652!ArrayTest methodsFor: 'tests - puting with indexes'! 7653testAtAllPut 7654 | | 7655 self nonEmpty atAll: self indexArray put: self aValue.. 7656 7657 self indexArray do: 7658 [:i | self assert: (self nonEmpty at: i)=self aValue ]. 7659 ! ! 7660 7661!ArrayTest methodsFor: 'tests - puting with indexes'! 7662testAtAllPutAll 7663 7664 | valueArray | 7665 valueArray := self valueArray . 7666 self nonEmpty atAll: self indexArray putAll: valueArray . 7667 7668 1 to: self indexArray size do: 7669 [:i | 7670 self assert: (self nonEmpty at:(self indexArray at: i))= (valueArray at:i) ]! ! 7671 7672!ArrayTest methodsFor: 'tests - puting with indexes'! 7673testAtLastPut 7674 | result index | 7675 index := self indexArray anyOne. 7676 result := self nonEmpty atLast: index put: self aValue. 7677 7678 self assert: (self nonEmpty at: (self nonEmpty size +1 - index)) = self aValue .! ! 7679 7680!ArrayTest methodsFor: 'tests - puting with indexes'! 7681testAtWrapPut 7682 "self debug: #testAtWrapPut" 7683 | index | 7684 index := self indexArray anyOne. 7685 7686 self nonEmpty atWrap: 0 put: self aValue. 7687 self assert: (self nonEmpty at:(self nonEmpty size))=self aValue. 7688 7689 self nonEmpty atWrap: (self nonEmpty size+1) put: self aValue. 7690 self assert: (self nonEmpty at:(1))=self aValue. 7691 7692 self nonEmpty atWrap: (index ) put: self aValue. 7693 self assert: (self nonEmpty at: index ) = self aValue. 7694 7695 self nonEmpty atWrap: (self nonEmpty size+index ) put: self aValue . 7696 self assert: (self nonEmpty at:(index ))=self aValue .! ! 7697 7698!ArrayTest methodsFor: 'tests - puting with indexes'! 7699testFromToPut 7700 7701 | collection index | 7702 index := self indexArray anyOne. 7703 collection := self nonEmpty copy. 7704 collection from: 1 to: index put: self aValue.. 7705 1 to: index do: 7706 [:i | self assert: (collection at: i)= self aValue]. 7707 (index +1) to: collection size do: 7708 [:i | self assert: (collection at:i)= (self nonEmpty at:i)].! ! 7709 7710!ArrayTest methodsFor: 'tests - puting with indexes'! 7711testSwapWith 7712 "self debug: #testSwapWith" 7713 | result index | 7714 index := self indexArray anyOne. 7715 result:= self nonEmpty copy . 7716 result swap: index with: 1. 7717 self assert: (result at: index) = (self nonEmpty at:1). 7718 self assert: (result at: 1) = (self nonEmpty at: index). 7719 ! ! 7720 7721 7722!ArrayTest methodsFor: 'tests - replacing'! 7723testReplaceAllWith 7724 | result collection oldElement newElement | 7725 collection := self nonEmpty . 7726 result := collection copy. 7727 oldElement := self elementInForReplacement . 7728 newElement := self newElement . 7729 result replaceAll: oldElement with: newElement . 7730 7731 1 to: collection size do: 7732 [: 7733 each | 7734 ( collection at: each ) = oldElement 7735 ifTrue: [ self assert: ( result at: each ) = newElement ]. 7736 ].! ! 7737 7738!ArrayTest methodsFor: 'tests - replacing'! 7739testReplaceFromToWith 7740 | result collection replacementCollection firstIndex secondIndex | 7741 collection := self nonEmpty . 7742 replacementCollection := self replacementCollectionSameSize . 7743 firstIndex := self firstIndex . 7744 secondIndex := self secondIndex . 7745 result := collection copy. 7746 result replaceFrom: firstIndex to: secondIndex with: replacementCollection . 7747 7748 "verify content of 'result' : " 7749 "first part of 'result'' : '" 7750 7751 1 to: ( firstIndex - 1 ) do: [ :i | self assert: (collection at:i ) = ( result at: i ) ]. 7752 7753 " middle part containing replacementCollection : " 7754 7755 ( firstIndex ) to: ( firstIndex + replacementCollection size - 1 ) do: 7756 [ :i | 7757 self assert: ( result at: i ) = ( replacementCollection at: ( i - firstIndex +1 ) ) 7758 ]. 7759 7760 " end part :" 7761 ( firstIndex + replacementCollection size) to: (result size) do: 7762 [:i| 7763 self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ]. 7764 7765 ! ! 7766 7767!ArrayTest methodsFor: 'tests - replacing'! 7768testReplaceFromToWithStartingAt 7769 | result repStart collection replacementCollection firstIndex secondIndex | 7770 collection := self nonEmpty . 7771 result := collection copy. 7772 replacementCollection := self replacementCollectionSameSize . 7773 firstIndex := self firstIndex . 7774 secondIndex := self secondIndex . 7775 repStart := replacementCollection size - ( secondIndex - firstIndex + 1 ) + 1. 7776 result replaceFrom: firstIndex to: secondIndex with: replacementCollection startingAt: repStart . 7777 7778 "verify content of 'result' : " 7779 "first part of 'result'' : '" 7780 7781 1 to: ( firstIndex - 1 ) do: [ :i | self assert: ( collection at:i ) = ( result at: i ) ]. 7782 7783 " middle part containing replacementCollection : " 7784 7785 ( firstIndex ) to: ( replacementCollection size - repStart +1 ) do: 7786 [:i| 7787 self assert: (result at: i)=( replacementCollection at: ( repStart + ( i -firstIndex ) ) ) ]. 7788 7789 " end part :" 7790 ( firstIndex + replacementCollection size ) to: ( result size ) do: 7791 [ :i | 7792 self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ].! ! 7793 7794 7795!ArrayTest methodsFor: 'tests - sequence isempty'! 7796testSequenceAbleIfEmptyifNotEmptyDo 7797 "self debug: #testSequenceAbleIfEmptyifNotEmptyDo" 7798 7799 self assert: (self nonEmpty 7800 ifEmpty: [false] 7801 ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! 7802 7803!ArrayTest methodsFor: 'tests - sequence isempty'! 7804testSequenceIfEmptyifNotEmptyDo 7805 "self debug #testSequenceIfEmptyifNotEmptyDo" 7806 7807 self assert: (self nonEmpty 7808 ifEmpty: [false] 7809 ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! 7810 7811!ArrayTest methodsFor: 'tests - sequence isempty'! 7812testSequenceIfNotEmpty 7813 7814 self assert: (self nonEmpty 7815 ifNotEmpty: [:s | self accessValuePutInOn: s]) = self valuePutIn! ! 7816 7817!ArrayTest methodsFor: 'tests - sequence isempty'! 7818testSequenceIfNotEmptyDo 7819 7820 self empty ifNotEmptyDo: [:s | self assert: false]. 7821 self assert: (self nonEmpty ifNotEmptyDo: [:s | self accessValuePutInOn: s]) = self valuePutIn 7822! ! 7823 7824!ArrayTest methodsFor: 'tests - sequence isempty'! 7825testSequenceIfNotEmptyDoifNotEmpty 7826 7827 self assert: (self nonEmpty 7828 ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn] 7829 ifEmpty: [false])! ! 7830 7831!ArrayTest methodsFor: 'tests - sequence isempty'! 7832testSequenceIfNotEmptyifEmpty 7833 7834 self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [:s | (self accessValuePutInOn: s) = self valuePutIn])! ! 7835 7836 7837!ArrayTest methodsFor: 'tests - set arithmetic'! 7838containsAll: union of: one andOf: another 7839 7840 self assert: (one allSatisfy: [:each | union includes: each]). 7841 self assert: (another allSatisfy: [:each | union includes: each])! ! 7842 7843!ArrayTest methodsFor: 'tests - set arithmetic'! 7844numberOfSimilarElementsInIntersection 7845 ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! 7846 7847!ArrayTest methodsFor: 'tests - set arithmetic'! 7848testDifference 7849 "Answer the set theoretic difference of two collections." 7850 "self debug: #testDifference" 7851 7852 self assert: (self collection difference: self collection) isEmpty. 7853 self assert: (self empty difference: self collection) isEmpty. 7854 self assert: (self collection difference: self empty) = self collection 7855! ! 7856 7857!ArrayTest methodsFor: 'tests - set arithmetic'! 7858testDifferenceWithNonNullIntersection 7859 "Answer the set theoretic difference of two collections." 7860 "self debug: #testDifferenceWithNonNullIntersection" 7861 " #(1 2 3) difference: #(2 4) 7862 -> #(1 3)" 7863 | res overlapping | 7864 overlapping := self collectionClass 7865 with: self anotherElementOrAssociationNotIn 7866 with: self anotherElementOrAssociationIn. 7867 res := self collection difference: overlapping. 7868 self deny: (res includes: self anotherElementOrAssociationIn). 7869 overlapping do: [ :each | self deny: (res includes: each) ]! ! 7870 7871!ArrayTest methodsFor: 'tests - set arithmetic'! 7872testDifferenceWithSeparateCollection 7873 "Answer the set theoretic difference of two collections." 7874 "self debug: #testDifferenceWithSeparateCollection" 7875 | res separateCol | 7876 separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. 7877 res := self collection difference: separateCol. 7878 self deny: (res includes: self anotherElementOrAssociationNotIn). 7879 self assert: res = self collection. 7880 res := separateCol difference: self collection. 7881 self deny: (res includes: self collection anyOne). 7882 self assert: res = separateCol! ! 7883 7884!ArrayTest methodsFor: 'tests - set arithmetic'! 7885testIntersectionBasic 7886 "self debug: #testIntersectionBasic" 7887 | inter | 7888 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 7889 self deny: inter isEmpty. 7890 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 7891 7892!ArrayTest methodsFor: 'tests - set arithmetic'! 7893testIntersectionEmpty 7894 "self debug: #testIntersectionEmpty" 7895 7896 | inter | 7897 inter := self empty intersection: self empty. 7898 self assert: inter isEmpty. 7899 inter := self empty intersection: self collection . 7900 self assert: inter = self empty. 7901 ! ! 7902 7903!ArrayTest methodsFor: 'tests - set arithmetic'! 7904testIntersectionItself 7905 "self debug: #testIntersectionItself" 7906 7907 self assert: (self collection intersection: self collection) = self collection. 7908 ! ! 7909 7910!ArrayTest methodsFor: 'tests - set arithmetic'! 7911testIntersectionTwoSimilarElementsInIntersection 7912 "self debug: #testIntersectionBasic" 7913 | inter | 7914 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 7915 self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. 7916 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 7917 7918!ArrayTest methodsFor: 'tests - set arithmetic'! 7919testUnion 7920 "self debug: #testUnionOfEmpties" 7921 7922 | union | 7923 union := self empty union: self nonEmpty. 7924 self containsAll: union of: self empty andOf: self nonEmpty. 7925 union := self nonEmpty union: self empty. 7926 self containsAll: union of: self empty andOf: self nonEmpty. 7927 union := self collection union: self nonEmpty. 7928 self containsAll: union of: self collection andOf: self nonEmpty.! ! 7929 7930!ArrayTest methodsFor: 'tests - set arithmetic'! 7931testUnionOfEmpties 7932 "self debug: #testUnionOfEmpties" 7933 7934 self assert: (self empty union: self empty) isEmpty. 7935 7936 ! ! 7937 7938 7939!ArrayTest methodsFor: 'tests - sorting'! 7940testIsSorted 7941 self assert: [ self sortedInAscendingOrderCollection isSorted ]. 7942 self deny: [ self unsortedCollection isSorted ]! ! 7943 7944!ArrayTest methodsFor: 'tests - sorting'! 7945testIsSortedBy 7946 self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a<b]). 7947 self deny: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a>b]). 7948! ! 7949 7950!ArrayTest methodsFor: 'tests - sorting'! 7951testSort 7952 | result tmp | 7953 result := self unsortedCollection sort. 7954 tmp := result at: 1. 7955 result do: 7956 [:each | self assert: each>=tmp. tmp:= each. ].! ! 7957 7958!ArrayTest methodsFor: 'tests - sorting'! 7959testSortUsingSortBlock 7960 | result tmp | 7961 result := self unsortedCollection sort: [:a :b | a>b]. 7962 tmp := result at: 1. 7963 result do: 7964 [:each | self assert: each<=tmp. tmp:= each. ].! ! 7965 7966 7967!ArrayTest methodsFor: 'tests - subcollections access'! 7968testAllButFirst 7969 "self debug: #testAllButFirst" 7970 | abf col | 7971 col := self moreThan3Elements. 7972 abf := col allButFirst. 7973 self deny: abf first = col first. 7974 self assert: abf size + 1 = col size! ! 7975 7976!ArrayTest methodsFor: 'tests - subcollections access'! 7977testAllButFirstNElements 7978 "self debug: #testAllButFirst" 7979 | abf col | 7980 col := self moreThan3Elements. 7981 abf := col allButFirst: 2. 7982 1 7983 to: abf size 7984 do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. 7985 self assert: abf size + 2 = col size! ! 7986 7987!ArrayTest methodsFor: 'tests - subcollections access'! 7988testAllButLast 7989 "self debug: #testAllButLast" 7990 | abf col | 7991 col := self moreThan3Elements. 7992 abf := col allButLast. 7993 self deny: abf last = col last. 7994 self assert: abf size + 1 = col size! ! 7995 7996!ArrayTest methodsFor: 'tests - subcollections access'! 7997testAllButLastNElements 7998 "self debug: #testAllButFirst" 7999 | abf col | 8000 col := self moreThan3Elements. 8001 abf := col allButLast: 2. 8002 1 8003 to: abf size 8004 do: [ :i | self assert: (abf at: i) = (col at: i) ]. 8005 self assert: abf size + 2 = col size! ! 8006 8007!ArrayTest methodsFor: 'tests - subcollections access'! 8008testFirstNElements 8009 "self debug: #testFirstNElements" 8010 | result | 8011 result := self moreThan3Elements first: self moreThan3Elements size - 1. 8012 1 8013 to: result size 8014 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. 8015 self assert: result size = (self moreThan3Elements size - 1). 8016 self 8017 should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] 8018 raise: Error! ! 8019 8020!ArrayTest methodsFor: 'tests - subcollections access'! 8021testLastNElements 8022 "self debug: #testLastNElements" 8023 | result | 8024 result := self moreThan3Elements last: self moreThan3Elements size - 1. 8025 1 8026 to: result size 8027 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. 8028 self assert: result size = (self moreThan3Elements size - 1). 8029 self 8030 should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] 8031 raise: Error! ! 8032 8033"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 8034 8035ArrayTest class 8036 uses: TEmptySequenceableTest classTrait + TSequencedElementAccessTest classTrait + TCloneTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TCreationWithTest classTrait + TPutBasicTest classTrait + TConvertTest classTrait + TSortTest classTrait + TIterateSequencedReadableTest classTrait + TSequencedConcatenationTest classTrait + TReplacementSequencedTest classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TBeginsEndsWith classTrait + TPrintOnSequencedTest classTrait + TIndexAccess classTrait + TSubCollectionAccess classTrait + TCopyPartOfSequenceable classTrait + TCopySequenceableSameContents classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopySequenceableWithReplacement classTrait + TIndexAccessForMultipliness classTrait + TCopyPartOfSequenceableForMultipliness classTrait + TConvertAsSortedTest classTrait + TPutTest classTrait + TIncludesWithIdentityCheckTest classTrait + TConvertAsSetForMultiplinessIdentityTest classTrait + TSequencedStructuralEqualityTest classTrait + TOccurrencesForMultiplinessTest classTrait 8037 instanceVariableNames: ''! 8038SequenceableCollection subclass: #ArrayedCollection 8039 instanceVariableNames: '' 8040 classVariableNames: '' 8041 poolDictionaries: '' 8042 category: 'Collections-Abstract'! 8043!ArrayedCollection commentStamp: '<historical>' prior: 0! 8044I am an abstract collection of elements with a fixed range of integers (from 1 to n>=0) as external keys.! 8045 8046 8047!ArrayedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:36'! 8048size 8049 "Answer how many elements the receiver contains." 8050 8051 <primitive: 62> 8052 ^ self basicSize! ! 8053 8054 8055!ArrayedCollection methodsFor: 'adding' stamp: 'sma 5/12/2000 14:09'! 8056add: newObject 8057 self shouldNotImplement! ! 8058 8059 8060!ArrayedCollection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 14:20'! 8061flattenOnStream: aStream 8062 aStream writeArrayedCollection: self! ! 8063 8064 8065!ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 15:22'! 8066byteSize 8067 ^self basicSize * self bytesPerBasicElement 8068! ! 8069 8070!ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:28'! 8071bytesPerBasicElement 8072 "Answer the number of bytes that each of my basic elements requires. 8073 In other words: 8074 self basicSize * self bytesPerBasicElement 8075 should equal the space required on disk by my variable sized representation." 8076 ^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ]! ! 8077 8078!ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 18:51'! 8079bytesPerElement 8080 ^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ]. 8081! ! 8082 8083!ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 7/30/2004 17:50'! 8084restoreEndianness 8085 "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Reverse the byte order if the current machine is Little Endian. 8086 We only intend this for non-pointer arrays. Do nothing if I contain pointers." 8087 8088 self class isPointers | self class isWords not ifTrue: [^self]. 8089 SmalltalkImage current isLittleEndian 8090 ifTrue: 8091 [Bitmap 8092 swapBytesIn: self 8093 from: 1 8094 to: self basicSize]! ! 8095 8096!ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 17:36'! 8097swapHalves 8098 "A normal switch in endianness (byte order in words) reverses the order of 4 bytes. That is not correct for SoundBuffers, which use 2-bytes units. If a normal switch has be done, this method corrects it further by swapping the two halves of the long word. 8099 This method is only used for 16-bit quanities in SoundBuffer, ShortIntegerArray, etc." 8100 8101 | hack blt | 8102 "The implementation is a hack, but fast for large ranges" 8103 hack := Form new hackBits: self. 8104 blt := (BitBlt toForm: hack) sourceForm: hack. 8105 blt combinationRule: Form reverse. "XOR" 8106 blt sourceY: 0; destY: 0; height: self size; width: 2. 8107 blt sourceX: 0; destX: 2; copyBits. "Exchange bytes 0&1 with 2&3" 8108 blt sourceX: 2; destX: 0; copyBits. 8109 blt sourceX: 0; destX: 2; copyBits.! ! 8110 8111!ArrayedCollection methodsFor: 'objects from disk' stamp: 'ar 5/17/2001 19:50'! 8112writeOn: aStream 8113 "Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed). Always store in Big Endian (Mac) byte order. Do the writing at BitBlt speeds. We only intend this for non-pointer arrays. Do nothing if I contain pointers." 8114 self class isPointers | self class isWords not ifTrue: [^ super writeOn: aStream]. 8115 "super may cause an error, but will not be called." 8116 aStream nextInt32Put: self basicSize. 8117 aStream nextWordsPutAll: self.! ! 8118 8119!ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 18:07'! 8120writeOnGZIPByteStream: aStream 8121 "We only intend this for non-pointer arrays. Do nothing if I contain pointers." 8122 8123 self class isPointers | self class isWords not ifTrue: [^ super writeOnGZIPByteStream: aStream]. 8124 "super may cause an error, but will not be called." 8125 8126 aStream nextPutAllWordArray: self! ! 8127 8128 8129!ArrayedCollection methodsFor: 'printing'! 8130storeOn: aStream 8131 8132 aStream nextPutAll: '(('. 8133 aStream nextPutAll: self class name. 8134 aStream nextPutAll: ' new: '. 8135 aStream store: self size. 8136 aStream nextPut: $). 8137 (self storeElementsFrom: 1 to: self size on: aStream) 8138 ifFalse: [aStream nextPutAll: '; yourself']. 8139 aStream nextPut: $)! ! 8140 8141 8142!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 18:18'! 8143asSortedArray 8144 self isSorted ifTrue: [^ self asArray]. 8145 ^ super asSortedArray! ! 8146 8147!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 6/1/2000 11:57'! 8148isSorted 8149 "Return true if the receiver is sorted by the given criterion. 8150 Optimization for isSortedBy: [:a :b | a <= b]." 8151 8152 | lastElm elm | 8153 self isEmpty ifTrue: [^ true]. 8154 lastElm := self first. 8155 2 to: self size do: 8156 [:index | 8157 elm := self at: index. 8158 lastElm <= elm ifFalse: [^ false]. 8159 lastElm := elm]. 8160 ^ true! ! 8161 8162!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 6/1/2000 11:58'! 8163isSortedBy: aBlock 8164 "Return true if the receiver is sorted by the given criterion." 8165 8166 | lastElm elm | 8167 self isEmpty ifTrue: [^ true]. 8168 lastElm := self first. 8169 2 to: self size do: 8170 [:index | 8171 elm := self at: index. 8172 (aBlock value: lastElm value: elm) ifFalse: [^ false]. 8173 lastElm := elm]. 8174 ^ true! ! 8175 8176!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:28'! 8177mergeFirst: first middle: middle last: last into: dst by: aBlock 8178 "Private. Merge the sorted ranges [first..middle] and [middle+1..last] 8179 of the receiver into the range [first..last] of dst." 8180 8181 | i1 i2 val1 val2 out | 8182 i1 := first. 8183 i2 := middle + 1. 8184 val1 := self at: i1. 8185 val2 := self at: i2. 8186 out := first - 1. "will be pre-incremented" 8187 8188 "select 'lower' half of the elements based on comparator" 8189 [(i1 <= middle) and: [i2 <= last]] whileTrue: 8190 [(aBlock value: val1 value: val2) 8191 ifTrue: [dst at: (out := out + 1) put: val1. 8192 val1 := self at: (i1 := i1 + 1)] 8193 ifFalse: [dst at: (out := out + 1) put: val2. 8194 i2 := i2 + 1. 8195 i2 <= last ifTrue: [val2 := self at: i2]]]. 8196 8197 "copy the remaining elements" 8198 i1 <= middle 8199 ifTrue: [dst replaceFrom: out + 1 to: last with: self startingAt: i1] 8200 ifFalse: [dst replaceFrom: out + 1 to: last with: self startingAt: i2]! ! 8201 8202!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:25'! 8203mergeSortFrom: startIndex to: stopIndex by: aBlock 8204 "Sort the given range of indices using the mergesort algorithm. 8205 Mergesort is a worst-case O(N log N) sorting algorithm that usually 8206 does only half as many comparisons as heapsort or quicksort." 8207 8208 "Details: recursively split the range to be sorted into two halves, 8209 mergesort each half, then merge the two halves together. An extra 8210 copy of the data is used as temporary storage and successive merge 8211 phases copy data back and forth between the receiver and this copy. 8212 The recursion is set up so that the final merge is performed into the 8213 receiver, resulting in the receiver being completely sorted." 8214 8215 self size <= 1 ifTrue: [^ self]. "nothing to do" 8216 startIndex = stopIndex ifTrue: [^ self]. 8217 self assert: [startIndex >= 1 and: [startIndex < stopIndex]]. "bad start index" 8218 self assert: [stopIndex <= self size]. "bad stop index" 8219 self 8220 mergeSortFrom: startIndex 8221 to: stopIndex 8222 src: self clone 8223 dst: self 8224 by: aBlock! ! 8225 8226!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:26'! 8227mergeSortFrom: first to: last src: src dst: dst by: aBlock 8228 "Private. Split the range to be sorted in half, sort each half, and 8229 merge the two half-ranges into dst." 8230 8231 | middle | 8232 first = last ifTrue: [^ self]. 8233 middle := (first + last) // 2. 8234 self mergeSortFrom: first to: middle src: dst dst: src by: aBlock. 8235 self mergeSortFrom: middle + 1 to: last src: dst dst: src by: aBlock. 8236 src mergeFirst: first middle: middle last: last into: dst by: aBlock! ! 8237 8238!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:22'! 8239sort 8240 "Sort this array into ascending order using the '<=' operator." 8241 8242 self sort: [:a :b | a <= b]! ! 8243 8244!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:21'! 8245sort: aSortBlock 8246 "Sort this array using aSortBlock. The block should take two arguments 8247 and return true if the first element should preceed the second one." 8248 8249 self 8250 mergeSortFrom: 1 8251 to: self size 8252 by: aSortBlock! ! 8253 8254 8255!ArrayedCollection methodsFor: 'private'! 8256defaultElement 8257 8258 ^nil! ! 8259 8260!ArrayedCollection methodsFor: 'private'! 8261storeElementsFrom: firstIndex to: lastIndex on: aStream 8262 8263 | noneYet defaultElement arrayElement | 8264 noneYet := true. 8265 defaultElement := self defaultElement. 8266 firstIndex to: lastIndex do: 8267 [:index | 8268 arrayElement := self at: index. 8269 arrayElement = defaultElement 8270 ifFalse: 8271 [noneYet 8272 ifTrue: [noneYet := false] 8273 ifFalse: [aStream nextPut: $;]. 8274 aStream nextPutAll: ' at: '. 8275 aStream store: index. 8276 aStream nextPutAll: ' put: '. 8277 aStream store: arrayElement]]. 8278 ^noneYet! ! 8279 8280"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 8281 8282ArrayedCollection class 8283 instanceVariableNames: ''! 8284 8285!ArrayedCollection class methodsFor: 'instance creation'! 8286new 8287 "Answer a new instance of me, with size = 0." 8288 8289 ^self new: 0! ! 8290 8291!ArrayedCollection class methodsFor: 'instance creation'! 8292new: size withAll: value 8293 "Answer an instance of me, with number of elements equal to size, each 8294 of which refers to the argument, value." 8295 8296 ^(self new: size) atAllPut: value! ! 8297 8298!ArrayedCollection class methodsFor: 'instance creation'! 8299newFrom: aCollection 8300 "Answer an instance of me containing the same elements as aCollection." 8301 | newArray | 8302 newArray := self new: aCollection size. 8303 1 to: aCollection size do: [:i | newArray at: i put: (aCollection at: i)]. 8304 ^ newArray 8305 8306" Array newFrom: {1. 2. 3} 8307 {1. 2. 3} as: Array 8308 {1. 2. 3} as: ByteArray 8309 {$c. $h. $r} as: String 8310 {$c. $h. $r} as: Text 8311"! ! 8312 8313!ArrayedCollection class methodsFor: 'instance creation' stamp: 'ar 5/17/2001 19:50'! 8314newFromStream: s 8315 "Only meant for my subclasses that are raw bits and word-like. For quick unpack form the disk." 8316 | len | 8317 8318 self isPointers | self isWords not ifTrue: [^ super newFromStream: s]. 8319 "super may cause an error, but will not be called." 8320 8321 s next = 16r80 ifTrue: 8322 ["A compressed format. Could copy what BitMap does, or use a 8323 special sound compression format. Callers normally compress their own way." 8324 ^ self error: 'not implemented']. 8325 s skip: -1. 8326 len := s nextInt32. 8327 ^ s nextWordsInto: (self basicNew: len)! ! 8328 8329!ArrayedCollection class methodsFor: 'instance creation'! 8330with: anObject 8331 "Answer a new instance of me, containing only anObject." 8332 8333 | newCollection | 8334 newCollection := self new: 1. 8335 newCollection at: 1 put: anObject. 8336 ^newCollection! ! 8337 8338!ArrayedCollection class methodsFor: 'instance creation'! 8339with: firstObject with: secondObject 8340 "Answer a new instance of me, containing firstObject and secondObject." 8341 8342 | newCollection | 8343 newCollection := self new: 2. 8344 newCollection at: 1 put: firstObject. 8345 newCollection at: 2 put: secondObject. 8346 ^newCollection! ! 8347 8348!ArrayedCollection class methodsFor: 'instance creation'! 8349with: firstObject with: secondObject with: thirdObject 8350 "Answer a new instance of me, containing only the three arguments as 8351 elements." 8352 8353 | newCollection | 8354 newCollection := self new: 3. 8355 newCollection at: 1 put: firstObject. 8356 newCollection at: 2 put: secondObject. 8357 newCollection at: 3 put: thirdObject. 8358 ^newCollection! ! 8359 8360!ArrayedCollection class methodsFor: 'instance creation'! 8361with: firstObject with: secondObject with: thirdObject with: fourthObject 8362 "Answer a new instance of me, containing only the three arguments as 8363 elements." 8364 8365 | newCollection | 8366 newCollection := self new: 4. 8367 newCollection at: 1 put: firstObject. 8368 newCollection at: 2 put: secondObject. 8369 newCollection at: 3 put: thirdObject. 8370 newCollection at: 4 put: fourthObject. 8371 ^newCollection! ! 8372 8373!ArrayedCollection class methodsFor: 'instance creation'! 8374with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject 8375 "Answer a new instance of me, containing only the five arguments as 8376 elements." 8377 8378 | newCollection | 8379 newCollection := self new: 5. 8380 newCollection at: 1 put: firstObject. 8381 newCollection at: 2 put: secondObject. 8382 newCollection at: 3 put: thirdObject. 8383 newCollection at: 4 put: fourthObject. 8384 newCollection at: 5 put: fifthObject. 8385 ^newCollection! ! 8386 8387!ArrayedCollection class methodsFor: 'instance creation' stamp: 'sw 10/24/1998 22:22'! 8388with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject 8389 "Answer a new instance of me, containing only the 6 arguments as elements." 8390 8391 | newCollection | 8392 newCollection := self new: 6. 8393 newCollection at: 1 put: firstObject. 8394 newCollection at: 2 put: secondObject. 8395 newCollection at: 3 put: thirdObject. 8396 newCollection at: 4 put: fourthObject. 8397 newCollection at: 5 put: fifthObject. 8398 newCollection at: 6 put: sixthObject. 8399 ^ newCollection! ! 8400 8401!ArrayedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:37'! 8402withAll: aCollection 8403 "Create a new collection containing all the elements from aCollection." 8404 8405 ^ (self new: aCollection size) replaceFrom: 1 to: aCollection size with: aCollection! ! 8406Halt subclass: #AssertionFailure 8407 instanceVariableNames: '' 8408 classVariableNames: '' 8409 poolDictionaries: '' 8410 category: 'Exceptions-Extensions'! 8411!AssertionFailure commentStamp: 'gh 5/2/2002 20:29' prior: 0! 8412AsssertionFailure is the exception signaled from Object>>assert: when the assertion block evaluates to false.! 8413 8414ParseNode subclass: #AssignmentNode 8415 instanceVariableNames: 'variable value' 8416 classVariableNames: '' 8417 poolDictionaries: '' 8418 category: 'Compiler-ParseNodes'! 8419!AssignmentNode commentStamp: '<historical>' prior: 0! 8420AssignmentNode comment: 'I represent a (var_expr) construct.'! 8421 8422 8423!AssignmentNode methodsFor: 'code generation' stamp: 'eem 6/4/2008 11:26'! 8424emitForEffect: stack on: aStream 8425 8426 variable emitLoad: stack on: aStream. 8427 value emitForValue: stack on: aStream. 8428 pc := aStream position + 1. "debug pc is first byte of the store". 8429 variable emitStorePop: stack on: aStream! ! 8430 8431!AssignmentNode methodsFor: 'code generation' stamp: 'eem 6/4/2008 11:26'! 8432emitForValue: stack on: aStream 8433 8434 variable emitLoad: stack on: aStream. 8435 value emitForValue: stack on: aStream. 8436 pc := aStream position + 1. "debug pc is first byte of the store" 8437 variable emitStore: stack on: aStream! ! 8438 8439!AssignmentNode methodsFor: 'code generation'! 8440sizeForEffect: encoder 8441 8442 ^(value sizeForValue: encoder) 8443 + (variable sizeForStorePop: encoder)! ! 8444 8445!AssignmentNode methodsFor: 'code generation'! 8446sizeForValue: encoder 8447 8448 ^(value sizeForValue: encoder) 8449 + (variable sizeForStore: encoder)! ! 8450 8451 8452!AssignmentNode methodsFor: 'code generation (closures)' stamp: 'eem 5/30/2008 09:37'! 8453analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>" 8454 "N.B. since assigment happens _after_ the value is evaluated the value is sent the message _first_." 8455 value analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools. 8456 variable beingAssignedToAnalyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools! ! 8457 8458 8459!AssignmentNode methodsFor: 'code generation (new scheme)' stamp: 'eem 6/4/2008 11:27'! 8460emitCodeForEffect: stack encoder: encoder 8461 8462 variable emitCodeForLoad: stack encoder: encoder. 8463 value emitCodeForValue: stack encoder: encoder. 8464 pc := encoder methodStreamPosition + 1. "debug pc is first byte of the store, i.e. the next byte". 8465 variable emitCodeForStorePop: stack encoder: encoder! ! 8466 8467!AssignmentNode methodsFor: 'code generation (new scheme)' stamp: 'eem 6/4/2008 11:27'! 8468emitCodeForValue: stack encoder: encoder 8469 8470 variable emitCodeForLoad: stack encoder: encoder. 8471 value emitCodeForValue: stack encoder: encoder. 8472 pc := encoder methodStreamPosition + 1. "debug pc is first byte of the store, i.e. the next byte". 8473 variable emitCodeForStore: stack encoder: encoder! ! 8474 8475!AssignmentNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 15:16'! 8476sizeCodeForEffect: encoder 8477 8478 ^(variable sizeCodeForLoad: encoder) 8479 + (value sizeCodeForValue: encoder) 8480 + (variable sizeCodeForStorePop: encoder)! ! 8481 8482!AssignmentNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 15:16'! 8483sizeCodeForValue: encoder 8484 8485 ^(variable sizeCodeForLoad: encoder) 8486 + (value sizeCodeForValue: encoder) 8487 + (variable sizeCodeForStore: encoder)! ! 8488 8489 8490!AssignmentNode methodsFor: 'equation translation'! 8491variable 8492 ^variable! ! 8493 8494 8495!AssignmentNode methodsFor: 'initialize-release'! 8496toDoIncrement: var 8497 var = variable ifFalse: [^ nil]. 8498 (value isMemberOf: MessageNode) 8499 ifTrue: [^ value toDoIncrement: var] 8500 ifFalse: [^ nil]! ! 8501 8502!AssignmentNode methodsFor: 'initialize-release'! 8503value 8504 ^ value! ! 8505 8506!AssignmentNode methodsFor: 'initialize-release'! 8507variable: aVariable value: expression 8508 8509 variable := aVariable. 8510 value := expression! ! 8511 8512!AssignmentNode methodsFor: 'initialize-release' stamp: 'di 3/22/1999 12:00'! 8513variable: aVariable value: expression from: encoder 8514 8515 (aVariable isMemberOf: MessageAsTempNode) 8516 ifTrue: ["Case of remote temp vars" 8517 ^ aVariable store: expression from: encoder]. 8518 variable := aVariable. 8519 value := expression! ! 8520 8521!AssignmentNode methodsFor: 'initialize-release' stamp: 'hmm 7/15/2001 21:17'! 8522variable: aVariable value: expression from: encoder sourceRange: range 8523 8524 encoder noteSourceRange: range forNode: self. 8525 ^self 8526 variable: aVariable 8527 value: expression 8528 from: encoder! ! 8529 8530 8531!AssignmentNode methodsFor: 'printing' stamp: 'eem 5/6/2008 13:48'! 8532printOn: aStream indent: level 8533 variable printOn: aStream indent: level. 8534 aStream nextPutAll: ' := '. 8535 value printOn: aStream indent: level + 2! ! 8536 8537!AssignmentNode methodsFor: 'printing' stamp: 'eem 5/9/2008 18:44'! 8538printOn: aStream indent: level precedence: p 8539 8540 aStream nextPut: $(. 8541 self printOn: aStream indent: level. 8542 aStream nextPut: $)! ! 8543 8544!AssignmentNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 8545printWithClosureAnalysisOn: aStream indent: level 8546 variable printWithClosureAnalysisOn: aStream indent: level. 8547 aStream nextPutAll: ' := '. 8548 value printWithClosureAnalysisOn: aStream indent: level + 2! ! 8549 8550!AssignmentNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 8551printWithClosureAnalysisOn: aStream indent: level precedence: p 8552 8553 aStream nextPut: $(. 8554 self printWithClosureAnalysisOn: aStream indent: level. 8555 aStream nextPut: $)! ! 8556 8557 8558!AssignmentNode methodsFor: 'testing' stamp: 'eem 6/16/2008 09:37'! 8559isAssignmentNode 8560 ^true! ! 8561 8562 8563!AssignmentNode methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:12'! 8564accept: aVisitor 8565 aVisitor visitAssignmentNode: self! ! 8566LookupKey subclass: #Association 8567 instanceVariableNames: 'value' 8568 classVariableNames: '' 8569 poolDictionaries: '' 8570 category: 'Collections-Support'! 8571!Association commentStamp: '<historical>' prior: 0! 8572I represent a pair of associated objects--a key and a value. My instances can serve as entries in a dictionary.! 8573 8574 8575!Association methodsFor: '*services-base-preferences' stamp: 'rr 3/21/2006 11:58'! 8576serviceUpdate 8577 self key service perform: self value! ! 8578 8579 8580!Association methodsFor: 'accessing' stamp: 'John M McIntosh 3/2/2009 21:15'! 8581isSpecialWriteBinding 8582 "Return true if this variable binding is write protected, e.g., should not be accessed primitively but rather by sending #value: messages" 8583 ^false! ! 8584 8585!Association methodsFor: 'accessing'! 8586key: aKey value: anObject 8587 "Store the arguments as the variables of the receiver." 8588 8589 key := aKey. 8590 value := anObject! ! 8591 8592!Association methodsFor: 'accessing'! 8593value 8594 "Answer the value of the receiver." 8595 8596 ^value! ! 8597 8598!Association methodsFor: 'accessing'! 8599value: anObject 8600 "Store the argument, anObject, as the value of the receiver." 8601 8602 value := anObject! ! 8603 8604 8605!Association methodsFor: 'comparing' stamp: 'md 1/27/2004 17:27'! 8606= anAssociation 8607 8608 ^ super = anAssociation and: [value = anAssociation value]! ! 8609 8610 8611!Association methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 20:53'! 8612byteEncode: aStream 8613 aStream writeAssocation:self.! ! 8614 8615 8616!Association methodsFor: 'objects from disk' stamp: 'tk 10/3/2000 13:03'! 8617objectForDataStream: refStrm 8618 | dp | 8619 "I am about to be written on an object file. If I am a known global, write a proxy that will hook up with the same resource in the destination system." 8620 8621 ^ (Smalltalk associationAt: key ifAbsent: [nil]) == self 8622 ifTrue: [dp := DiskProxy global: #Smalltalk selector: #associationOrUndeclaredAt: 8623 args: (Array with: key). 8624 refStrm replace: self with: dp. 8625 dp] 8626 ifFalse: [self]! ! 8627 8628 8629!Association methodsFor: 'printing'! 8630printOn: aStream 8631 8632 super printOn: aStream. 8633 aStream nextPutAll: '->'. 8634 value printOn: aStream! ! 8635 8636!Association methodsFor: 'printing' stamp: 'MPW 1/4/1901 08:31'! 8637propertyListOn: aStream 8638 aStream write:key; print:'='; write:value. 8639! ! 8640 8641!Association methodsFor: 'printing'! 8642storeOn: aStream 8643 "Store in the format (key->value)" 8644 aStream nextPut: $(. 8645 key storeOn: aStream. 8646 aStream nextPutAll: '->'. 8647 value storeOn: aStream. 8648 aStream nextPut: $)! ! 8649 8650 8651!Association methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! 8652isSelfEvaluating 8653 ^ self class == Association! ! 8654 8655"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 8656 8657Association class 8658 instanceVariableNames: ''! 8659 8660!Association class methodsFor: 'instance creation'! 8661key: newKey value: newValue 8662 "Answer an instance of me with the arguments as the key and value of 8663 the association." 8664 8665 ^(super key: newKey) value: newValue! ! 8666ClassTestCase subclass: #AssociationTest 8667 instanceVariableNames: 'a b' 8668 classVariableNames: '' 8669 poolDictionaries: '' 8670 category: 'CollectionsTests-Support'! 8671 8672!AssociationTest methodsFor: 'setup' stamp: 'zz 12/5/2005 18:33'! 8673setUp 8674 8675 a := 1 -> 'one'. 8676 b := 1 -> 'een'.! ! 8677 8678 8679!AssociationTest methodsFor: 'tests' stamp: 'ab 12/29/2008 07:59'! 8680testComparison 8681 self assert: ((#a -> 'foo') < (#b -> 'zork'))! ! 8682 8683!AssociationTest methodsFor: 'tests' stamp: 'md 3/8/2004 16:37'! 8684testEquality 8685 8686 self 8687 assert: (a key = b key); 8688 deny: (a value = b value); 8689 deny: (a = b) 8690 8691! ! 8692 8693!AssociationTest methodsFor: 'tests' stamp: 'al 10/13/2008 20:32'! 8694testHash 8695 8696 self 8697 assert: (a hash = a copy hash); 8698 assert: (a hash = b hash)! ! 8699 8700!AssociationTest methodsFor: 'tests' stamp: 'ab 12/29/2008 08:01'! 8701testIsSelfEvaluating 8702 self assert: (a isSelfEvaluating). 8703 8704 self assert: (a printString = '1->''one''') 8705! ! 8706Object subclass: #AsyncFile 8707 instanceVariableNames: 'name writeable semaphore fileHandle' 8708 classVariableNames: 'Busy ErrorCode' 8709 poolDictionaries: '' 8710 category: 'Files-Kernel'! 8711!AsyncFile commentStamp: '<historical>' prior: 0! 8712An asynchronous file allows simple file read and write operations to be performed in parallel with other processing. This is useful in multimedia applications that need to stream large amounts of sound or image data from or to a file while doing other work. 8713! 8714 8715 8716!AsyncFile methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'! 8717close 8718 8719 fileHandle ifNil: [^ self]. "already closed" 8720 self primClose: fileHandle. 8721 Smalltalk unregisterExternalObject: semaphore. 8722 semaphore := nil. 8723 fileHandle := nil. 8724! ! 8725 8726!AsyncFile methodsFor: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'! 8727fileHandle 8728 ^ fileHandle! ! 8729 8730!AsyncFile methodsFor: 'as yet unclassified' stamp: 'ar 6/3/2007 22:13'! 8731open: fullFileName forWrite: aBoolean 8732 "Open a file of the given name, and return a handle for that file. Answer the receiver if the primitive succeeds, nil otherwise. 8733 If openForWrite is true, then: 8734 if there is no existing file with this name, then create one 8735 else open the existing file in read-write mode 8736 otherwise: 8737 if there is an existing file with this name, then open it read-only 8738 else answer nil." 8739 "Note: if an exisiting file is opened for writing, it is NOT truncated. If truncation is desired, the file should be deleted before being opened as an asynchronous file." 8740 "Note: On some platforms (e.g., Mac), a file can only have one writer at a time." 8741 8742 | semaIndex | 8743 name := fullFileName. 8744 writeable := aBoolean. 8745 semaphore := Semaphore new. 8746 semaIndex := Smalltalk registerExternalObject: semaphore. 8747 fileHandle := self primOpen: name asVmPathName forWrite: writeable semaIndex: semaIndex. 8748 fileHandle ifNil: [ 8749 Smalltalk unregisterExternalObject: semaphore. 8750 semaphore := nil. 8751 ^ nil]. 8752! ! 8753 8754!AsyncFile methodsFor: 'as yet unclassified' stamp: 'nice 4/16/2009 10:02'! 8755readByteCount: byteCount fromFilePosition: fPosition onCompletionDo: aBlock 8756 "Start a read operation to read byteCount's from the given position in this file. and fork a process to await its completion. When the operation completes, evaluate the given block. Note that, since the completion block may run asynchronous, the client may need to use a SharedQueue or a semaphore for synchronization." 8757 8758 | buffer | 8759 buffer := String new: byteCount. 8760 self primReadStart: fileHandle fPosition: fPosition count: byteCount. 8761 "here's the process that awaits the results:" 8762 [| n | 8763 [ semaphore wait. 8764 n := self primReadResult: fileHandle intoBuffer: buffer at: 1 count: byteCount. 8765 n = Busy. 8766 ] whileTrue. "loop while busy in case the semaphore had excess signals" 8767 n = ErrorCode ifTrue: [^ self error: 'asynchronous read operation failed']. 8768 aBlock value: buffer. 8769 ] forkAt: Processor userInterruptPriority. 8770! ! 8771 8772!AsyncFile methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'! 8773test: byteCount fileName: fileName 8774 "AsyncFile new test: 10000 fileName: 'testData'" 8775 8776 | buf1 buf2 bytesWritten bytesRead | 8777 buf1 := String new: byteCount withAll: $x. 8778 buf2 := String new: byteCount. 8779 self open: ( FileDirectory default fullNameFor: fileName) forWrite: true. 8780 self primWriteStart: fileHandle 8781 fPosition: 0 8782 fromBuffer: buf1 8783 at: 1 8784 count: byteCount. 8785 semaphore wait. 8786 bytesWritten := self primWriteResult: fileHandle. 8787 self close. 8788 8789 self open: ( FileDirectory default fullNameFor: fileName) forWrite: false. 8790 self primReadStart: fileHandle fPosition: 0 count: byteCount. 8791 semaphore wait. 8792 bytesRead := 8793 self primReadResult: fileHandle 8794 intoBuffer: buf2 8795 at: 1 8796 count: byteCount. 8797 self close. 8798 8799 buf1 = buf2 ifFalse: [self error: 'buffers do not match']. 8800 ^ 'wrote ', bytesWritten printString, ' bytes; ', 8801 'read ', bytesRead printString, ' bytes' 8802! ! 8803 8804!AsyncFile methodsFor: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'! 8805waitForCompletion 8806 semaphore wait! ! 8807 8808!AsyncFile methodsFor: 'as yet unclassified' stamp: 'nice 4/16/2009 10:02'! 8809writeBuffer: buffer atFilePosition: fPosition onCompletionDo: aBlock 8810 "Start an operation to write the contents of the buffer at given position in this file, and fork a process to await its completion. When the write completes, evaluate the given block. Note that, since the completion block runs asynchronously, the client may need to use a SharedQueue or a semaphore for synchronization." 8811 8812 self primWriteStart: fileHandle 8813 fPosition: fPosition 8814 fromBuffer: buffer 8815 at: 1 8816 count: buffer size. 8817 "here's the process that awaits the results:" 8818 [| n | 8819 [ semaphore wait. 8820 n := self primWriteResult: fileHandle. 8821 n = Busy. 8822 ] whileTrue. "loop while busy in case the semaphore had excess signals" 8823 n = ErrorCode ifTrue: [^ self error: 'asynchronous write operation failed']. 8824 n = buffer size ifFalse: [^ self error: 'did not write the entire buffer']. 8825 aBlock value. 8826 ] forkAt: Processor userInterruptPriority. 8827! ! 8828 8829 8830!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 8831primClose: fHandle 8832 "Close this file. Do nothing if primitive fails." 8833 8834 <primitive: 'primitiveAsyncFileClose' module: 'AsynchFilePlugin'> 8835! ! 8836 8837!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 8838primOpen: fileName forWrite: openForWrite semaIndex: semaIndex 8839 "Open a file of the given name, and return a handle for that file. Answer the receiver if the primitive succeeds, nil otherwise." 8840 8841 <primitive: 'primitiveAsyncFileOpen' module: 'AsynchFilePlugin'> 8842 ^ nil 8843! ! 8844 8845!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 8846primReadResult: fHandle intoBuffer: buffer at: startIndex count: count 8847 "Copy the result of the last read operation into the given buffer starting at the given index. The buffer may be any sort of bytes or words object, excluding CompiledMethods. Answer the number of bytes read. A negative result means: 8848 -1 the last operation is still in progress 8849 -2 the last operation encountered an error" 8850 8851 <primitive: 'primitiveAsyncFileReadResult' module: 'AsynchFilePlugin'> 8852 self primitiveFailed 8853! ! 8854 8855!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 8856primReadStart: fHandle fPosition: fPosition count: count 8857 "Start a read operation of count bytes starting at the given offset in the given file." 8858 8859 <primitive: 'primitiveAsyncFileReadStart' module: 'AsynchFilePlugin'> 8860 self error: 'READ THE COMMENT FOR THIS METHOD.' 8861 8862"NOTE: This method will fail if there is insufficient C heap to allocate an internal buffer of the required size (the value of count). If you are trying to read a movie file, then the buffer size will be height*width*2 bytes. Each Squeak image retains a value to be used for this allocation, and it it initially set to 0. If you are wish to play a 640x480 movie, you need room for a buffer of 640*480*2 = 614400 bytes. You should execute the following... 8863 8864 Smalltalk extraVMMemory 2555000. 8865 8866Then save-and-quit, restart, and try to open the movie file again. If you are using Async files in another way, find out the value of count when this failure occurs (call it NNNN), and instead of the above, execute... 8867 8868 Smalltalk extraVMMemory: Smalltalk extraVMMemory + NNNN 8869 8870then save-and-quit, restart, and try again. 8871" 8872 8873! ! 8874 8875!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 8876primWriteResult: fHandle 8877 "Answer the number of bytes written. A negative result means: 8878 -1 the last operation is still in progress 8879 -2 the last operation encountered an error" 8880 8881 <primitive: 'primitiveAsyncFileWriteResult' module: 'AsynchFilePlugin'> 8882 self primitiveFailed 8883! ! 8884 8885!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 8886primWriteStart: fHandle fPosition: fPosition fromBuffer: buffer at: startIndex count: count 8887 "Start a write operation of count bytes starting at the given index in the given buffer. The buffer may be any sort of bytes or words object, excluding CompiledMethods. The contents of the buffer are copied into an internal buffer immediately, so the buffer can be reused after the write operation has been started. Fail if there is insufficient C heap to allocate an internal buffer of the requested size." 8888 8889 <primitive: 'primitiveAsyncFileWriteStart' module: 'AsynchFilePlugin'> 8890 writeable ifFalse: [^ self error: 'attempt to write a file opened read-only']. 8891 self primitiveFailed 8892! ! 8893 8894"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 8895 8896AsyncFile class 8897 instanceVariableNames: ''! 8898 8899!AsyncFile class methodsFor: 'initialization' stamp: 'bootstrap 5/31/2006 20:45'! 8900initialize 8901 "AsyncFile initialize" 8902 8903 "Possible abnormal I/O completion results." 8904 Busy := -1. 8905 ErrorCode := -2. 8906! ! 8907Object subclass: #Author 8908 instanceVariableNames: 'fullName' 8909 classVariableNames: '' 8910 poolDictionaries: '' 8911 category: 'System-Support'! 8912!Author commentStamp: 'MiguelCoba 7/25/2009 01:09' prior: 0! 8913I am responsible for the full name used to identify the current code author.! 8914 8915 8916!Author methodsFor: 'accessing' stamp: 'MiguelCoba 7/25/2009 02:41'! 8917fullName 8918 "Answer the full name to be used to identify the current code author." 8919 8920 [fullName isEmptyOrNil ] whileTrue: [self requestFullName]. 8921 ^ fullName! ! 8922 8923!Author methodsFor: 'accessing' stamp: 'MiguelCoba 7/25/2009 00:55'! 8924fullName: aString 8925 fullName := aString.! ! 8926 8927!Author methodsFor: 'accessing' stamp: 'MiguelCoba 7/25/2009 00:58'! 8928fullNamePerSe 8929 8930 "Answer the currently-prevailing author full name, such as it is, empty or not" 8931 8932 ^ fullName! ! 8933 8934 8935!Author methodsFor: 'initialization' stamp: 'MiguelCoba 7/25/2009 03:07'! 8936initialize 8937 super initialize. 8938 fullName := ''.! ! 8939 8940 8941!Author methodsFor: 'ui-requests' stamp: 'MiguelCoba 9/16/2009 12:10'! 8942messagePrompt 8943 ^ 8944'Please type your full name. 8945It will be used to sign the changes you make to the image. 8946Avoid spaces, accents, dashes, underscore and similar characters. 8947 8948Vincent van Gogh -> VincentVanGogh 8949Miguel Cobá -> MiguelCoba 8950Göran Krampe -> GoranKrampe 8951Göran Krampe -> GoeranKrampe 8952Stéphane DUCASSE -> StephaneDucasse 8953Yoshiki Oshima -> YoshikiOshima 8954'! ! 8955 8956!Author methodsFor: 'ui-requests' stamp: 'MiguelCoba 7/25/2009 01:54'! 8957requestFullName 8958 | initialAnswer | 8959 initialAnswer := fullName isEmptyOrNil 8960 ifTrue: ['FirstnameLastname' translated] 8961 ifFalse: [fullName]. 8962 fullName := UIManager default 8963 request: self messagePrompt 8964 initialAnswer: initialAnswer! ! 8965 8966 8967!Author methodsFor: 'testing-support' stamp: 'oscar.nierstrasz 10/18/2009 18:27'! 8968useAuthor: aString during: aBlock 8969 | previous | 8970 previous := fullName. 8971 fullName := aString. 8972 ^ aBlock ensure: [ fullName := previous ]! ! 8973 8974"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 8975 8976Author class 8977 instanceVariableNames: 'uniqueInstance'! 8978 8979!Author class methodsFor: 'convenience' stamp: 'MiguelCoba 7/25/2009 01:58'! 8980fullName 8981 ^ Author uniqueInstance fullName! ! 8982 8983!Author class methodsFor: 'convenience' stamp: 'MiguelCoba 7/25/2009 01:58'! 8984fullName: aString 8985 ^ Author uniqueInstance fullName: aString! ! 8986 8987!Author class methodsFor: 'convenience' stamp: 'MiguelCoba 7/25/2009 01:58'! 8988fullNamePerSe 8989 ^ Author uniqueInstance fullNamePerSe! ! 8990 8991!Author class methodsFor: 'convenience' stamp: 'MiguelCoba 7/25/2009 01:10'! 8992requestFullName 8993 ^ Author uniqueInstance requestFullName! ! 8994 8995 8996!Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:24'! 8997initials 8998 self deprecated: 'Use ''Author fullName'' instead.'. 8999 ^ Author uniqueInstance fullName! ! 9000 9001!Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:25'! 9002initials: aString 9003 self deprecated: 'Use ''Author fullName:'' instead.'. 9004 ^ Author uniqueInstance fullName: aString! ! 9005 9006!Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:25'! 9007initialsPerSe 9008 self deprecated: 'Use ''Author fullNamePerSe'' instead.'. 9009 ^ Author uniqueInstance fullNamePerSe! ! 9010 9011!Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:26'! 9012requestInitials 9013 self deprecated: 'Use ''Author requestFullName'' instead.'. 9014 ^ Author uniqueInstance requestFullName! ! 9015 9016!Author class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:27'! 9017requestName 9018 self deprecated: 'Use ''Author requestFullName'' instead.'. 9019 ^ Author uniqueInstance requestFullName! ! 9020 9021 9022!Author class methodsFor: 'instance creation' stamp: 'on 5/10/2008 13:05'! 9023new 9024 self error: 'Author is a singleton -- send uniqueInstance instead'! ! 9025 9026!Author class methodsFor: 'instance creation' stamp: 'on 5/10/2008 13:10'! 9027reset 9028 ^ uniqueInstance := nil! ! 9029 9030!Author class methodsFor: 'instance creation' stamp: 'on 5/10/2008 13:09'! 9031uniqueInstance 9032 ^ uniqueInstance ifNil: [ uniqueInstance := super new ]! ! 9033 9034!Author class methodsFor: 'instance creation' stamp: 'on 5/10/2008 13:27'! 9035uniqueInstance: anInstance 9036 "Needed by AuthorTest to restore saved instance" 9037 ^ uniqueInstance := anInstance! ! 9038 9039 9040!Author class methodsFor: 'testing-support' stamp: 'oscar.nierstrasz 10/18/2009 18:31'! 9041useAuthor: aString during: aBlock 9042 ^ self uniqueInstance useAuthor: aString during: aBlock! ! 9043TestCase subclass: #AuthorTest 9044 instanceVariableNames: 'author' 9045 classVariableNames: '' 9046 poolDictionaries: '' 9047 category: 'Tests-System'! 9048 9049!AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:31'! 9050setUp 9051 author := Author uniqueInstance. 9052 Author reset.! ! 9053 9054!AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:21'! 9055tearDown 9056 Author uniqueInstance: author! ! 9057 9058!AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 14:48'! 9059testDeprecation 9060 | savedPref | 9061 savedPref := Preferences showDeprecationWarnings. 9062 Preferences setPreference: #showDeprecationWarnings toValue: true. 9063 9064 self should: [ Utilities authorInitials ] raise: Warning. 9065 self should: [ Utilities authorInitialsPerSe ] raise: Warning. 9066 self should: [ Utilities setAuthorInitials ] raise: Warning. 9067 self should: [ Utilities setAuthorInitials: 'ak' ] raise: Warning. 9068 9069 self should: [ Utilities authorName ] raise: Warning. 9070 self should: [ Utilities authorName: 'alan' ] raise: Warning. 9071 self should: [ Utilities authorNamePerSe ] raise: Warning. 9072 self should: [ Utilities setAuthorName ] raise: Warning. 9073 9074 Preferences setPreference: #showDeprecationWarnings toValue: savedPref. 9075! ! 9076 9077!AuthorTest methodsFor: 'running' stamp: 'MiguelCoba 7/25/2009 02:45'! 9078testInitiallyEmpty 9079 self assert: (Author uniqueInstance fullNamePerSe isEmpty). 9080 ! ! 9081 9082!AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:35'! 9083testUniqueness 9084 self should: [ Author new ] raise: Error.! ! 9085Object subclass: #Authorizer 9086 instanceVariableNames: 'users realm' 9087 classVariableNames: '' 9088 poolDictionaries: '' 9089 category: 'Network-Url'! 9090!Authorizer commentStamp: '<historical>' prior: 0! 9091The Authorizer does user authorization checking. Each instance of authorizer keeps track of the realm that it is authorizing for, and the table of authorized users. An authorizer can be asked to return the user name/symbol associated with a userID (which concatenates the username and password from the HTTP request) with the user: method. 9092! 9093 9094 9095!Authorizer methodsFor: 'authentication' stamp: 'PeterHugossonMiller 9/3/2009 00:12'! 9096encode: nameString password: pwdString 9097 "Encode per RFC1421 of the username:password combination." 9098 9099 | clear code clearSize idx map | 9100 clear := (nameString, ':', pwdString) asByteArray. 9101 clearSize := clear size. 9102 [ clear size \\ 3 ~= 0 ] whileTrue: [ clear := clear, #(0) ]. 9103 idx := 1. 9104 map := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'. 9105 code := String new writeStream. 9106 [ idx < clear size ] whileTrue: [ code 9107 nextPut: (map at: (clear at: idx) // 4 + 1); 9108 nextPut: (map at: (clear at: idx) \\ 4 * 16 + ((clear at: idx + 1) // 16) + 1); 9109 nextPut: (map at: (clear at: idx + 1) \\ 16 * 4 + ((clear at: idx + 2) // 64) + 1); 9110 nextPut: (map at: (clear at: idx + 2) \\ 64 + 1). 9111 idx := idx + 3 ]. 9112 code := code contents. 9113 idx := code size. 9114 clear size - clearSize timesRepeat: [ code at: idx put: $=. idx := idx - 1]. 9115 ^code! ! 9116 9117!Authorizer methodsFor: 'authentication' stamp: 'mjg 11/3/97 12:31'! 9118mapFrom: aKey to: aPerson 9119 "Establish a mapping from a RFC 1421 key to a user." 9120 9121 users isNil ifTrue: [ users := Dictionary new ]. 9122 aPerson 9123 isNil ifTrue: [ users removeKey: aKey ] 9124 ifFalse: [ 9125 users removeKey: (users keyAtValue: aPerson ifAbsent: []) ifAbsent: []. 9126 users at: aKey put: aPerson ] 9127! ! 9128 9129!Authorizer methodsFor: 'authentication' stamp: 'tk 5/21/1998 16:32'! 9130mapName: nameString password: pwdString to: aPerson 9131 "Insert/remove the encoding per RFC1421 of the username:password combination into/from the UserMap. DO NOT call this directly, use mapName:password:to: in your ServerAction class. Only it knows how to record the change on the disk!!" 9132 9133 self mapFrom: (self encode: nameString password: pwdString) to: aPerson 9134! ! 9135 9136!Authorizer methodsFor: 'authentication' stamp: 'ar 8/17/2001 18:19'! 9137user: userId 9138 "Return the requesting user." 9139 ^users at: userId ifAbsent: [ self error: (self class unauthorizedFor: realm) ]! ! 9140 9141 9142!Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'! 9143realm 9144 ^realm! ! 9145 9146!Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'! 9147realm: aString 9148 realm := aString 9149! ! 9150 9151"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 9152 9153Authorizer class 9154 instanceVariableNames: ''! 9155 9156!Authorizer class methodsFor: 'as yet unclassified' stamp: 'adrian_lienhard 7/18/2009 15:52'! 9157unauthorizedFor: realm 9158 ^'HTTP/1.0 401 Unauthorized', self crlf, 'WWW-Authenticate: Basic realm="Pharo/',realm,'"', 9159 String crlfcrlf, '<html><title>Unauthorized</title><body><h2>Unauthorized for ',realm, '</h2></body></html>' 9160 9161! ! 9162Object subclass: #AutoStart 9163 instanceVariableNames: 'parameters' 9164 classVariableNames: 'Active InstalledLaunchers' 9165 poolDictionaries: '' 9166 category: 'System-Support'! 9167 9168"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 9169 9170AutoStart class 9171 instanceVariableNames: ''! 9172 9173!AutoStart class methodsFor: 'accessing' stamp: 'mir 7/28/1999 17:47'! 9174addLauncher: launcher 9175 self installedLaunchers add: launcher! ! 9176 9177!AutoStart class methodsFor: 'accessing'! 9178addLauncherFirst: launcher 9179 self installedLaunchers addFirst: launcher! ! 9180 9181!AutoStart class methodsFor: 'accessing' stamp: 'mir 7/28/1999 17:47'! 9182removeLauncher: launcher 9183 self installedLaunchers remove: launcher ifAbsent: []! ! 9184 9185 9186!AutoStart class methodsFor: 'initialization' stamp: 'mir 7/28/1999 17:44'! 9187deinstall 9188 "AutoStart deinstall" 9189 9190 Smalltalk removeFromStartUpList: AutoStart. 9191 InstalledLaunchers := nil! ! 9192 9193!AutoStart class methodsFor: 'initialization' stamp: 'mir 9/30/2004 15:05'! 9194initialize 9195 "AutoStart initialize" 9196 "Order: ExternalSettings, SecurityManager, AutoStart" 9197 Smalltalk addToStartUpList: AutoStart after: SecurityManager. 9198 Smalltalk addToShutDownList: AutoStart after: SecurityManager.! ! 9199 9200!AutoStart class methodsFor: 'initialization' stamp: 'mir 9/30/2004 15:06'! 9201shutDown: quitting 9202 self active: false! ! 9203 9204!AutoStart class methodsFor: 'initialization' stamp: 'stephane.ducasse 4/13/2009 21:14'! 9205startUp: resuming 9206 "The image is either being newly started (resuming is true), or it's just been snapshotted. 9207 If this has just been a snapshot, skip all the startup stuff." 9208 9209 | startupParameters launchers | 9210 self active ifTrue: [^self]. 9211 self active: true. 9212 resuming ifFalse: [^self]. 9213 9214 HTTPClient determineIfRunningInBrowser. 9215 startupParameters := AbstractLauncher extractParameters. 9216 (startupParameters includesKey: 'apiSupported' asUppercase ) 9217 ifTrue: [ 9218 HTTPClient browserSupportsAPI: ((startupParameters at: 'apiSupported' asUppercase) asUppercase = 'TRUE'). 9219 HTTPClient isRunningInBrowser 9220 ifFalse: [HTTPClient isRunningInBrowser: true]]. 9221 self checkForUpdates 9222 ifTrue: [^self]. 9223 self checkForPluginUpdate. 9224 launchers := self installedLaunchers collect: [:launcher | 9225 launcher new]. 9226 launchers do: [:launcher | 9227 launcher parameters: startupParameters]. 9228 launchers do: [:launcher | 9229 Smalltalk at: #WorldState ifPresent: [ :ws | ws addDeferredUIMessage: [launcher startUp]]]! ! 9230 9231 9232!AutoStart class methodsFor: 'updating' stamp: 'sd 3/20/2008 22:26'! 9233checkForPluginUpdate 9234 | pluginVersion updateURL | 9235 World 9236 ifNotNil: [ 9237 World install. 9238 ActiveHand position: 100@100]. 9239 HTTPClient isRunningInBrowser 9240 ifFalse: [^false]. 9241 pluginVersion := AbstractLauncher extractParameters 9242 at: (SmalltalkImage current platformName copyWithout: Character space) asUppercase 9243 ifAbsent: [^false]. 9244 updateURL := AbstractLauncher extractParameters 9245 at: 'UPDATE_URL' 9246 ifAbsent: [^false]. 9247 ^SystemVersion check: pluginVersion andRequestPluginUpdate: updateURL! ! 9248 9249!AutoStart class methodsFor: 'updating' stamp: 'sd 3/20/2008 22:26'! 9250checkForUpdates 9251 | availableUpdate updateServer | 9252 World 9253 ifNotNil: [ 9254 World install. 9255 ActiveHand position: 100@100]. 9256 HTTPClient isRunningInBrowser 9257 ifFalse: [^self processUpdates]. 9258 availableUpdate := (AbstractLauncher extractParameters 9259 at: 'UPDATE' 9260 ifAbsent: [''] ) asInteger. 9261 availableUpdate 9262 ifNil: [^false]. 9263 updateServer := AbstractLauncher extractParameters 9264 at: 'UPDATESERVER' 9265 ifAbsent: [AbstractLauncher extractParameters 9266 at: 'UPDATE_SERVER' 9267 ifAbsent: ['Squeakland']]. 9268 Utilities setUpdateServer: updateServer. 9269 ^SystemVersion checkAndApplyUpdates: availableUpdate! ! 9270 9271!AutoStart class methodsFor: 'updating' stamp: 'CdG 10/17/2005 19:34'! 9272processUpdates 9273 "Process update files from a well-known update server. This method is called at system startup time, Only if the preference #updateFromServerAtStartup is true is the actual update processing undertaken automatically" 9274 | choice | 9275 (Preferences valueOfFlag: #updateFromServerAtStartup) ifTrue: 9276 [choice := UIManager default chooseFrom: #('Yes, Update' 'No, Not now' 'Don''t ask again') 9277 title: 'Shall I look for new code\updates on the server?' withCRs. 9278 choice = 1 ifTrue: [ 9279 Utilities updateFromServer]. 9280 choice = 3 ifTrue: [ 9281 Preferences setPreference: #updateFromServerAtStartup toValue: false. 9282 self inform: 'Remember to save you image to make this setting permant.']]. 9283 ^false! ! 9284 9285 9286!AutoStart class methodsFor: 'private' stamp: 'mir 9/7/2004 13:34'! 9287active 9288 ^ Active == true! ! 9289 9290!AutoStart class methodsFor: 'private' stamp: 'mir 9/7/2004 13:36'! 9291active: aBoolean 9292 Active := aBoolean! ! 9293 9294!AutoStart class methodsFor: 'private' stamp: 'mir 7/28/1999 17:43'! 9295installedLaunchers 9296 InstalledLaunchers ifNil: [ 9297 InstalledLaunchers := OrderedCollection new]. 9298 ^InstalledLaunchers! ! 9299Object subclass: #BDFFontReader 9300 instanceVariableNames: 'file properties' 9301 classVariableNames: '' 9302 poolDictionaries: '' 9303 category: 'Graphics-Fonts'! 9304!BDFFontReader commentStamp: '<historical>' prior: 0! 9305I am a conversion utility for reading X11 Bitmap Distribution Format fonts. My code is derived from the multilingual Squeak changeset written by OHSHIMA Yoshiki (ohshima@is.titech.ac.jp), although all support for fonts with more than 256 glyphs has been ripped out. See http://www.is.titech.ac.jp/~ohshima/squeak/squeak-multilingual-e.html . 9306 9307My class methods contain tools for fetching BDF source files from a well-known archive site, batch conversion to Squeak's .sf2 format, and installation of these fonts as TextStyles. Also, the legal notices for the standard 75dpi fonts I process this way are included as "x11FontLegalNotices'.! 9308 9309 9310!BDFFontReader methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:41'! 9311initialize 9312 super initialize. 9313 properties := Dictionary new.! ! 9314 9315!BDFFontReader methodsFor: 'initialize' stamp: 'pmm 7/4/2009 12:05'! 9316openFileNamed: fileName 9317 file := (MultiByteFileStream readOnlyFileNamed: fileName) 9318 ascii; 9319 wantsLineEndConversion: true; 9320 yourself! ! 9321 9322 9323!BDFFontReader methodsFor: 'reading' stamp: 'nop 1/18/2000 19:45'! 9324errorFileFormat 9325 self error: 'malformed bdf format'! ! 9326 9327!BDFFontReader methodsFor: 'reading' stamp: 'nop 1/18/2000 19:46'! 9328errorUnsupported 9329 self error: 'unsupported bdf'! ! 9330 9331!BDFFontReader methodsFor: 'reading' stamp: 'ar 10/25/2005 00:35'! 9332getLine 9333 ^file upTo: Character cr.! ! 9334 9335!BDFFontReader methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:51'! 9336read 9337 | xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width blt lastAscii pointSize ret stream | 9338 form := encoding := bbx := nil. 9339 self readAttributes. 9340 height := Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). 9341 ascent := Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. 9342 descent := Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. 9343 pointSize := (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. 9344 maxWidth := 0. 9345 minAscii := 9999. 9346 strikeWidth := 0. 9347 maxAscii := 0. 9348 charsNum := Integer readFromString: (properties at: #CHARS) first. 9349 chars := Set new: charsNum. 9350 1 9351 to: charsNum 9352 do: 9353 [ :i | 9354 array := self readOneCharacter. 9355 stream := array readStream. 9356 form := stream next. 9357 encoding := stream next. 9358 bbx := stream next. 9359 form ifNotNil: 9360 [ width := bbx at: 1. 9361 maxWidth := maxWidth max: width. 9362 minAscii := minAscii min: encoding. 9363 maxAscii := maxAscii max: encoding. 9364 strikeWidth := strikeWidth + width. 9365 chars add: array ] ]. 9366 chars := chars asSortedCollection: [ :x :y | (x at: 2) <= (y at: 2) ]. 9367 charsNum := chars size. "undefined encodings make this different" 9368 charsNum > 256 9369 ifTrue: 9370 [ "it should be 94x94 charset, and should be fixed width font" 9371 strikeWidth := 94 * 94 * maxWidth. 9372 maxAscii := 94 * 94. 9373 minAscii := 0. 9374 xTable := XTableForFixedFont new. 9375 xTable maxAscii: 94 * 94. 9376 xTable width: maxWidth ] 9377 ifFalse: [ xTable := (Array new: 258) atAllPut: 0 ]. 9378 glyphs := Form extent: strikeWidth @ height. 9379 blt := BitBlt toForm: glyphs. 9380 lastAscii := 0. 9381 charsNum > 256 9382 ifTrue: 9383 [ 1 9384 to: charsNum 9385 do: 9386 [ :i | 9387 stream := (chars at: i) readStream. 9388 form := stream next. 9389 encoding := stream next. 9390 bbx := stream next. 9391 encoding := (encoding // 256 - 33) * 94 + (encoding \\ 256 - 33). 9392 blt 9393 copy: ((encoding * maxWidth) @ 0 extent: maxWidth @ height) 9394 from: 0 @ 0 9395 in: form ] ] 9396 ifFalse: 9397 [ 1 9398 to: charsNum 9399 do: 9400 [ :i | 9401 stream := (chars at: i) readStream. 9402 form := stream next. 9403 encoding := stream next. 9404 bbx := stream next. 9405 lastAscii + 1 9406 to: encoding - 1 9407 do: 9408 [ :a | 9409 xTable 9410 at: a + 2 9411 put: (xTable at: a + 1) ]. 9412 blt 9413 copy: ((xTable at: encoding + 1) @ (ascent - (bbx at: 2) - (bbx at: 4)) extent: (bbx at: 1) @ (bbx at: 2)) 9414 from: 0 @ 0 9415 in: form. 9416 xTable 9417 at: encoding + 2 9418 put: (xTable at: encoding + 1) + (bbx at: 1). 9419 lastAscii := encoding ] ]. 9420 ret := Array new: 8. 9421 ret 9422 at: 1 9423 put: xTable. 9424 ret 9425 at: 2 9426 put: glyphs. 9427 ret 9428 at: 3 9429 put: minAscii. 9430 ret 9431 at: 4 9432 put: maxAscii. 9433 ret 9434 at: 5 9435 put: maxWidth. 9436 ret 9437 at: 6 9438 put: ascent. 9439 ret 9440 at: 7 9441 put: descent. 9442 ret 9443 at: 8 9444 put: pointSize. 9445 ^ ret 9446 " ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}"! ! 9447 9448!BDFFontReader methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 9449readAttributes 9450 "I don't handle double-quotes correctly, but it works" 9451 | str a | 9452 file reset. 9453 [ file atEnd ] whileFalse: 9454 [ str := self getLine. 9455 (str beginsWith: 'STARTCHAR') ifTrue: 9456 [ file skip: 0 - str size - 1. 9457 ^ self ]. 9458 a := str substrings. 9459 properties 9460 at: a first asSymbol 9461 put: a allButFirst ]. 9462 self error: 'file seems corrupted'! ! 9463 9464!BDFFontReader methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:51'! 9465readChars 9466 | strikeWidth ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width pointSize stream | 9467 form := encoding := bbx := nil. 9468 self readAttributes. 9469 height := Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). 9470 ascent := Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. 9471 descent := Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. 9472 pointSize := (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. 9473 maxWidth := 0. 9474 minAscii := 9999. 9475 strikeWidth := 0. 9476 maxAscii := 0. 9477 charsNum := Integer readFromString: (properties at: #CHARS) first. 9478 chars := Set new: charsNum. 9479 1 9480 to: charsNum 9481 do: 9482 [ :i | 9483 array := self readOneCharacter. 9484 stream := array readStream. 9485 form := stream next. 9486 encoding := stream next. 9487 bbx := stream next. 9488 form ifNotNil: 9489 [ width := bbx at: 1. 9490 maxWidth := maxWidth max: width. 9491 minAscii := minAscii min: encoding. 9492 maxAscii := maxAscii max: encoding. 9493 strikeWidth := strikeWidth + width. 9494 chars add: array ] ]. 9495 chars := chars asSortedCollection: [ :x :y | (x at: 2) <= (y at: 2) ]. 9496 ^ chars! ! 9497 9498!BDFFontReader methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 9499readOneCharacter 9500 | str a encoding bbx form bits hi low pos | 9501 ((str := self getLine) beginsWith: 'ENDFONT') ifTrue: 9502 [ ^ { nil. nil. nil } ]. 9503 (str beginsWith: 'STARTCHAR') ifFalse: [ self errorFileFormat ]. 9504 ((str := self getLine) beginsWith: 'ENCODING') ifFalse: [ self errorFileFormat ]. 9505 encoding := Integer readFromString: str substrings second. 9506 (self getLine beginsWith: 'SWIDTH') ifFalse: [ self errorFileFormat ]. 9507 (self getLine beginsWith: 'DWIDTH') ifFalse: [ self errorFileFormat ]. 9508 ((str := self getLine) beginsWith: 'BBX') ifFalse: [ self errorFileFormat ]. 9509 a := str substrings. 9510 bbx := (2 to: 5) collect: [ :i | Integer readFromString: (a at: i) ]. 9511 ((str := self getLine) beginsWith: 'ATTRIBUTES') ifTrue: [ str := self getLine ]. 9512 (str beginsWith: 'BITMAP') ifFalse: [ self errorFileFormat ]. 9513 form := Form extent: (bbx at: 1) @ (bbx at: 2). 9514 bits := form bits. 9515 pos := 0. 9516 1 9517 to: (bbx at: 2) 9518 do: 9519 [ :t | 9520 1 9521 to: ((bbx at: 1) - 1) // 8 + 1 9522 do: 9523 [ :i | 9524 hi := ('0123456789ABCDEF' indexOf: file next asUppercase) - 1 bitShift: 4. 9525 low := ('0123456789ABCDEF' indexOf: file next asUppercase) - 1. 9526 bits 9527 byteAt: pos + i 9528 put: hi + low ]. 9529 file next ~= Character cr ifTrue: [ self errorFileFormat ]. 9530 pos := pos + (((bbx at: 1) // 32 + 1) * 4) ]. 9531 (self getLine beginsWith: 'ENDCHAR') ifFalse: [ self errorFileFormat ]. 9532 encoding < 0 ifTrue: 9533 [ ^ { nil. nil. nil } ]. 9534 ^ { form. encoding. bbx }! ! 9535 9536"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 9537 9538BDFFontReader class 9539 instanceVariableNames: ''! 9540 9541!BDFFontReader class methodsFor: 'documentation' stamp: 'nop 2/11/2001 00:22'! 9542gettingAndInstallingTheFonts 9543 9544 "Download the 1.3M of BDF font source files from x.org: 9545 9546 BDFFontReader downloadFonts. 9547 9548 Convert them to .sf2 StrikeFont files: 9549 9550 BDFFontReader convertX11FontsToStrike2. 9551 9552 Install them into the system as TextStyles: 9553 9554 BDFFontReader installX11Fonts. 9555 9556 Read the legal notices in 'BDFFontReader x11FontLegalNotices' before 9557 redistributing images containing these fonts."! ! 9558 9559!BDFFontReader class methodsFor: 'documentation' stamp: 'nop 1/23/2000 18:30'! 9560x11FontLegalNotices 9561 9562 ^ 'The X11 BDF fonts contain copyright and license information as comments in the 9563font source code. For the font family files "cour" (Courier), "helv" (Helvetica), "ncen" (New Century Schoolbook), and "tim" (Times Roman) the notice reads: 9564 9565COMMENT Copyright 1984-1989, 1994 Adobe Systems Incorporated. 9566COMMENT Copyright 1988, 1994 Digital Equipment Corporation. 9567COMMENT 9568COMMENT Adobe is a trademark of Adobe Systems Incorporated which may be 9569COMMENT registered in certain jurisdictions. 9570COMMENT Permission to use these trademarks is hereby granted only in 9571COMMENT association with the images described in this file. 9572COMMENT 9573COMMENT Permission to use, copy, modify, distribute and sell this software 9574COMMENT and its documentation for any purpose and without fee is hereby 9575COMMENT granted, provided that the above copyright notices appear in all 9576COMMENT copies and that both those copyright notices and this permission 9577COMMENT notice appear in supporting documentation, and that the names of 9578COMMENT Adobe Systems and Digital Equipment Corporation not be used in 9579COMMENT advertising or publicity pertaining to distribution of the software 9580COMMENT without specific, written prior permission. Adobe Systems and 9581COMMENT Digital Equipment Corporation make no representations about the 9582COMMENT suitability of this software for any purpose. It is provided "as 9583COMMENT is" without express or implied warranty. 9584 9585For the font family files "char" (Charter), the notice reads: 9586 9587COMMENT Copyright 1988 Bitstream, Inc., Cambridge, Massachusetts, USA 9588COMMENT Bitstream and Charter are registered trademarks of Bitstream, Inc. 9589COMMENT 9590COMMENT The names "Bitstream" and "Charter" are registered trademarks of 9591COMMENT Bitstream, Inc. Permission to use these trademarks is hereby 9592COMMENT granted only in association with the images described in this file. 9593COMMENT 9594COMMENT Permission to use, copy, modify, and distribute this software and 9595COMMENT its documentation for any purpose and without fee is hereby 9596COMMENT granted, provided that the above copyright notice appear in all 9597COMMENT copies and that both that copyright notice and this permission 9598COMMENT notice appear in supporting documentation, and that the name of 9599COMMENT Bitstream not be used in advertising or publicity pertaining to 9600COMMENT distribution of the software without specific, written prior 9601COMMENT permission. Bitstream makes no representations about the 9602COMMENT suitability of this software for any purpose. It is provided "as 9603COMMENT is" without express or implied warranty. 9604COMMENT 9605COMMENT BITSTREAM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, 9606COMMENT INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN 9607COMMENT NO EVENT SHALL BITSTREAM BE LIABLE FOR ANY SPECIAL, INDIRECT OR 9608COMMENT CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS 9609COMMENT OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, 9610COMMENT NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN 9611COMMENT CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 9612 9613For the font family files "lu" (Lucida), "lub" (Lucida Bright), and "lut" (Lucida Typewriter), 9614the notice reads: 9615 9616COMMENT (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered 9617COMMENT trademark of Bigelow & Holmes. See LEGAL NOTICE file for terms 9618COMMENT of the license. 9619 9620The LEGAL NOTICE contains: 9621 9622This is the LEGAL NOTICE pertaining to the Lucida fonts from Bigelow & Holmes: 9623 9624 NOTICE TO USER: The source code, including the glyphs or icons 9625 forming a par of the OPEN LOOK TM Graphic User Interface, on this 9626 tape and in these files is copyrighted under U.S. and international 9627 laws. Sun Microsystems, Inc. of Mountain View, California owns 9628 the copyright and has design patents pending on many of the icons. 9629 AT&T is the owner of the OPEN LOOK trademark associated with the 9630 materials on this tape. Users and possessors of this source code 9631 are hereby granted a nonexclusive, royalty-free copyright and 9632 design patent license to use this code in individual and 9633 commercial software. A royalty-free, nonexclusive trademark 9634 license to refer to the code and output as "OPEN LOOK" compatible 9635 is available from AT&T if, and only if, the appearance of the 9636 icons or glyphs is not changed in any manner except as absolutely 9637 necessary to accommodate the standard resolution of the screen or 9638 other output device, the code and output is not changed except as 9639 authorized herein, and the code and output is validated by AT&T. 9640 Bigelow & Holmes is the owner of the Lucida (R) trademark for the 9641 fonts and bit-mapped images associated with the materials on this 9642 tape. Users are granted a royalty-free, nonexclusive license to use 9643 the trademark only to identify the fonts and bit-mapped images if, 9644 and only if, the fonts and bit-mapped images are not modified in any 9645 way by the user. 9646 9647 9648 Any use of this source code must include, in the user documentation 9649 and internal comments to the code, notices to the end user as 9650 follows: 9651 9652 9653 (c) Copyright 1989 Sun Microsystems, Inc. Sun design patents 9654 pending in the U.S. and foreign countries. OPEN LOOK is a 9655 trademark of AT&T. Used by written permission of the owners. 9656 9657 9658 (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered 9659 trademark of Bigelow & Holmes. Permission to use the Lucida 9660 trademark is hereby granted only in association with the images 9661 and fonts described in this file. 9662 9663 9664 9665 SUN MICROSYSTEMS, INC., AT&T, AND BIGELOW & HOLMES 9666 MAKE NO REPRESENTATIONS ABOUT THE SUITABILITY OF 9667 THIS SOURCE CODE FOR ANY PURPOSE. IT IS PROVIDED "AS IS" 9668 WITHOUT EXPRESS OR IMPLIED WARRANTY OF ANY KIND. 9669 SUN MICROSYSTEMS, INC., AT&T AND BIGELOW & HOLMES, 9670 SEVERALLY AND INDIVIDUALLY, DISCLAIM ALL WARRANTIES 9671 WITH REGARD TO THIS SOURCE CODE, INCLUDING ALL IMPLIED 9672 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 9673 PARTICULAR PURPOSE. IN NO EVENT SHALL SUN MICROSYSTEMS, 9674 INC., AT&T OR BIGELOW & HOLMES BE LIABLE FOR ANY 9675 SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, 9676 OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA 9677 OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE 9678 OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION 9679 WITH THE USE OR PERFORMANCE OF THIS SOURCE CODE. 9680 9681'. 9682 9683 9684 9685 9686 9687! ! 9688 9689 9690!BDFFontReader class methodsFor: 'file creation' stamp: 'nice 4/16/2009 10:04'! 9691convertFilesNamed: fileName toFamilyNamed: familyName inDirectoryNamed: dirName 9692 "BDFFontReader convertFilesNamed: 'helvR' toFamilyNamed: 'Helvetica' inDirectoryNamed: '' " 9693 "This utility converts X11 BDF font files to Squeak .sf2 StrikeFont files." 9694 "For this utility to work as is, the BDF files must be named 'familyNN.bdf', 9695 and must reside in the directory named by dirName (use '' for the current directory). 9696 The output StrikeFont files will be named familyNN.sf2, and will be placed in the 9697 current directory." 9698 "Check for matching file names." 9699 | allFontNames dir | 9700 dir := dirName isEmpty 9701 ifTrue: [ FileDirectory default ] 9702 ifFalse: [ FileDirectory default directoryNamed: dirName ]. 9703 allFontNames := dir fileNamesMatching: fileName , '##.bdf'. 9704 allFontNames isEmpty ifTrue: [ ^ self error: 'No files found like ' , fileName , 'NN.bdf' ]. 9705 UIManager default informUserDuring: 9706 [ :info | 9707 allFontNames do: 9708 [ :fname | | sizeChars f | 9709 info value: 'Converting ' , familyName , ' BDF file ' , fname , ' to SF2 format'. 9710 sizeChars := (fname 9711 copyFrom: fileName size + 1 9712 to: fname size) copyUpTo: $.. 9713 f := StrikeFont new 9714 readBDFFromFile: (dir fullNameFor: fname) 9715 name: familyName , sizeChars. 9716 f writeAsStrike2named: familyName , sizeChars , '.sf2' ] ]! ! 9717 9718!BDFFontReader class methodsFor: 'file creation' stamp: 'yo 5/25/2004 10:52'! 9719new 9720 9721 ^ self basicNew. 9722! ! 9723 9724!BDFFontReader class methodsFor: 'file creation' stamp: 'ar 10/25/2005 00:21'! 9725openFileNamed: fileName 9726 ^self new openFileNamed: fileName! ! 9727 9728 9729!BDFFontReader class methodsFor: 'resource download' stamp: 'nop 1/23/2000 18:43'! 9730convertX11FontsToStrike2 "BDFFontReader convertX11FontsToStrike2" 9731 "Given a set of standard X11 BDF font files (probably downloaded via BDFFontReader downloadFonts), produce .sf2 format fonts. The source and destination directory is the current directory." 9732 9733 "Charter currently tickles a bug in the BDF parser. Skip it for now." 9734 "self convertFilesNamed: 'charR' toFamilyNamed: 'Charter' inDirectoryNamed: ''." 9735 9736 self convertFilesNamed: 'courR' toFamilyNamed: 'Courier' inDirectoryNamed: ''. 9737 self convertFilesNamed: 'helvR' toFamilyNamed: 'Helvetica' inDirectoryNamed: ''. 9738 9739 self convertFilesNamed: 'lubR' toFamilyNamed: 'LucidaBright' inDirectoryNamed: ''. 9740 self convertFilesNamed: 'luRS' toFamilyNamed: 'Lucida' inDirectoryNamed: ''. 9741 self convertFilesNamed: 'lutRS' toFamilyNamed: 'LucidaTypewriter' inDirectoryNamed: ''. 9742 9743 self convertFilesNamed: 'ncenR' toFamilyNamed: 'NewCenturySchoolbook' inDirectoryNamed: ''. 9744 self convertFilesNamed: 'timR' toFamilyNamed: 'TimesRoman' inDirectoryNamed: ''.! ! 9745 9746!BDFFontReader class methodsFor: 'resource download' stamp: 'pmm 7/4/2009 12:07'! 9747downloadFonts 9748 "BDFFontReader downloadFonts" 9749 "Download a standard set of BDF sources from x.org. 9750 The combined size of these source files is around 1.2M; after conversion 9751 to .sf2 format they may be deleted." 9752 | heads tails filenames baseUrl basePath | 9753 heads := #( 9754 'charR' 9755 'courR' 9756 'helvR' 9757 'lubR' 9758 'luRS' 9759 'lutRS' 9760 'ncenR' 9761 'timR' 9762 ). 9763 tails := #('08' '10' '12' '14' '18' '24' ). 9764 filenames := OrderedCollection new. 9765 heads do: [ :head | filenames addAll: (tails collect: [ :tail | head , tail , '.bdf' ]) ]. 9766 baseUrl := Url absoluteFromText: 'http://ftp.x.org/pub/R6.4/xc/fonts/bdf/75dpi/'. 9767 basePath := baseUrl path. 9768 filenames do: 9769 [ :filename | | newUrl newPath document f | 9770 newUrl := baseUrl clone. 9771 newPath := OrderedCollection newFrom: basePath. 9772 newPath addLast: filename. 9773 newUrl path: newPath. 9774 UIManager default 9775 informUser: 'Fetching ' translated, filename 9776 during: [ document := newUrl retrieveContents ]. 9777 f := (MultiByteFileStream newFileNamed: filename) 9778 ascii; wantsLineEndConversion: true; yourself. 9779 f nextPutAll: document content. 9780 f close ]! ! 9781 9782!BDFFontReader class methodsFor: 'resource download' stamp: 'eem 6/11/2008 13:33'! 9783installX11Fonts "BDFFontReader installX11Fonts" 9784 "Installs previously-converted .sf2 fonts into the TextConstants dictionary. This makes them available as TextStyles everywhere in the image." 9785 9786 | families | 9787 families := #( 'Courier' 'Helvetica' 'LucidaBright' 'Lucida' 'LucidaTypewriter' 'NewCenturySchoolbook' 'TimesRoman' ). 9788 9789 families do: [:family | | fontArray textStyle | 9790 fontArray := StrikeFont readStrikeFont2Family: family. 9791 textStyle := TextStyle fontArray: fontArray. 9792 TextConstants at: family asSymbol put: textStyle. 9793 ]. 9794! ! 9795ImageReadWriter subclass: #BMPReadWriter 9796 instanceVariableNames: 'bfType bfSize bfOffBits biSize biWidth biHeight biPlanes biBitCount biCompression biSizeImage biXPelsPerMeter biYPelsPerMeter biClrUsed biClrImportant' 9797 classVariableNames: '' 9798 poolDictionaries: '' 9799 category: 'Graphics-Files'! 9800 9801!BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 15:36'! 9802nextImage 9803 | colors | 9804 stream binary. 9805 self readHeader. 9806 biBitCount = 24 ifTrue:[^self read24BmpFile]. 9807 "read the color map" 9808 colors := self readColorMap. 9809 ^self readIndexedBmpFile: colors! ! 9810 9811!BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 9812read24BmpFile 9813 "Read 24-bit pixel data from the given a BMP stream." 9814 | form formBits pixelLine bitsIndex bitBlt | 9815 form := Form 9816 extent: biWidth @ biHeight 9817 depth: 32. 9818 pixelLine := ByteArray new: (24 * biWidth + 31) // 32 * 4. 9819 bitsIndex := (form height - 1) * biWidth + 1. 9820 formBits := form bits. 9821 1 9822 to: biHeight 9823 do: 9824 [ :i | 9825 pixelLine := stream nextInto: pixelLine. 9826 self 9827 read24BmpLine: pixelLine 9828 into: formBits 9829 startingAt: bitsIndex 9830 width: biWidth. 9831 bitsIndex := bitsIndex - biWidth ]. 9832 bitBlt := BitBlt toForm: form. 9833 bitBlt combinationRule: 7. "bitOr:with:" 9834 bitBlt halftoneForm: (Bitmap with: 4278190080). 9835 bitBlt copyBits. 9836 ^ form! ! 9837 9838!BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 9839read24BmpLine: pixelLine into: formBits startingAt: formBitsIndex width: width 9840 | pixIndex rgb bitsIndex | 9841 pixIndex := 0. "pre-increment" 9842 bitsIndex := formBitsIndex - 1. "pre-increment" 9843 1 9844 to: width 9845 do: 9846 [ :j | 9847 rgb := (pixelLine at: (pixIndex := pixIndex + 1)) + ((pixelLine at: (pixIndex := pixIndex + 1)) bitShift: 8) + ((pixelLine at: (pixIndex := pixIndex + 1)) bitShift: 16). 9848 formBits 9849 at: (bitsIndex := bitsIndex + 1) 9850 put: rgb ]! ! 9851 9852!BMPReadWriter methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:51'! 9853readColorMap 9854 "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." 9855 | colorCount colors maxLevel b g r ccStream | 9856 colorCount := (bfOffBits - 54) // 4. 9857 "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" 9858 biBitCount >= 16 ifTrue: [ ^ nil ]. 9859 colorCount = 0 ifTrue: 9860 [ "this BMP file does not have a color map" 9861 "default monochrome color map" 9862 biBitCount = 1 ifTrue: 9863 [ ^ Array 9864 with: Color white 9865 with: Color black ]. 9866 "default gray-scale color map" 9867 maxLevel := (2 raisedTo: biBitCount) - 1. 9868 ^ (0 to: maxLevel) collect: [ :level | Color gray: level asFloat / maxLevel ] ]. 9869 ccStream := (stream next: colorCount * 4) readStream. 9870 colors := Array new: colorCount. 9871 1 9872 to: colorCount 9873 do: 9874 [ :i | 9875 b := ccStream next. 9876 g := ccStream next. 9877 r := ccStream next. 9878 ccStream next. "skip reserved" 9879 colors 9880 at: i 9881 put: (Color 9882 r: r 9883 g: g 9884 b: b 9885 range: 255) ]. 9886 ^ colors! ! 9887 9888!BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 9889readHeader 9890 | reserved | 9891 bfType := stream nextLittleEndianNumber: 2. 9892 bfSize := stream nextLittleEndianNumber: 4. 9893 reserved := stream nextLittleEndianNumber: 4. 9894 bfOffBits := stream nextLittleEndianNumber: 4. 9895 biSize := stream nextLittleEndianNumber: 4. 9896 biWidth := stream nextLittleEndianNumber: 4. 9897 biHeight := stream nextLittleEndianNumber: 4. 9898 biPlanes := stream nextLittleEndianNumber: 2. 9899 biBitCount := stream nextLittleEndianNumber: 2. 9900 biCompression := stream nextLittleEndianNumber: 4. 9901 biSizeImage := stream nextLittleEndianNumber: 4. 9902 biXPelsPerMeter := stream nextLittleEndianNumber: 4. 9903 biYPelsPerMeter := stream nextLittleEndianNumber: 4. 9904 biClrUsed := stream nextLittleEndianNumber: 4. 9905 biClrImportant := stream nextLittleEndianNumber: 4! ! 9906 9907!BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 9908readIndexedBmpFile: colors 9909 "Read uncompressed pixel data of depth d from the given BMP stream, where d is 1, 4, 8, or 16" 9910 | form bytesPerRow pixelData pixelLine startIndex map bitBlt mask | 9911 colors 9912 ifNil: 9913 [ form := Form 9914 extent: biWidth @ biHeight 9915 depth: biBitCount ] 9916 ifNotNil: 9917 [ form := ColorForm 9918 extent: biWidth @ biHeight 9919 depth: biBitCount. 9920 form colors: colors ]. 9921 bytesPerRow := (biBitCount * biWidth + 31) // 32 * 4. 9922 pixelData := ByteArray new: bytesPerRow * biHeight. 9923 biHeight 9924 to: 1 9925 by: -1 9926 do: 9927 [ :y | 9928 pixelLine := stream next: bytesPerRow. 9929 startIndex := (y - 1) * bytesPerRow + 1. 9930 pixelData 9931 replaceFrom: startIndex 9932 to: startIndex + bytesPerRow - 1 9933 with: pixelLine 9934 startingAt: 1 ]. 9935 form bits copyFromByteArray: pixelData. 9936 biBitCount = 16 ifTrue: 9937 [ map := ColorMap 9938 shifts: #(8 -8 0 0 ) 9939 masks: #(255 65280 0 0 ). 9940 mask := 2147516416 ]. 9941 biBitCount = 32 ifTrue: 9942 [ map := ColorMap 9943 shifts: #(24 8 -8 -24 ) 9944 masks: #(255 65280 16711680 4278190080 ). 9945 mask := 4278190080 ]. 9946 map ifNotNil: 9947 [ bitBlt := BitBlt toForm: form. 9948 bitBlt sourceForm: form. 9949 bitBlt colorMap: map. 9950 bitBlt combinationRule: Form over. 9951 bitBlt copyBits ]. 9952 mask ifNotNil: 9953 [ bitBlt := BitBlt toForm: form. 9954 bitBlt combinationRule: 7. "bitOr:with:" 9955 bitBlt halftoneForm: (Bitmap with: mask). 9956 bitBlt copyBits ]. 9957 ^ form! ! 9958 9959 9960!BMPReadWriter methodsFor: 'testing' stamp: 'ar 6/16/2002 15:27'! 9961understandsImageFormat 9962 stream size < 54 ifTrue:[^false]. "min size = BITMAPFILEHEADER+BITMAPINFOHEADER" 9963 self readHeader. 9964 bfType = 19778 "BM" ifFalse:[^false]. 9965 biSize = 40 ifFalse:[^false]. 9966 biPlanes = 1 ifFalse:[^false]. 9967 bfSize <= stream size ifFalse:[^false]. 9968 biCompression = 0 ifFalse:[^false]. 9969 ^true! ! 9970 9971 9972!BMPReadWriter methodsFor: 'writing' stamp: 'lr 7/4/2009 10:42'! 9973nextPutImage: aForm 9974 | bhSize rowBytes rgb data colorValues depth image ppw scanLineLen | 9975 depth := aForm depth. 9976 [ #(1 4 8 32 ) includes: depth ] whileFalse: [ depth := depth + 1 asLargerPowerOfTwo ]. 9977 image := aForm asFormOfDepth: depth. 9978 image unhibernate. 9979 bhSize := 14. "# bytes in file header" 9980 biSize := 40. "info header size in bytes" 9981 biWidth := image width. 9982 biHeight := image height. 9983 biClrUsed := depth = 32 9984 ifTrue: [ 0 ] 9985 ifFalse: [ 1 << depth ]. "No. color table entries" 9986 bfOffBits := biSize + bhSize + (4 * biClrUsed). 9987 rowBytes := ((depth min: 24) * biWidth + 31) // 32 * 4. 9988 biSizeImage := biHeight * rowBytes. 9989 9990 "Write the file header" 9991 stream position: 0. 9992 stream 9993 nextLittleEndianNumber: 2 9994 put: 19778. "bfType = BM" 9995 stream 9996 nextLittleEndianNumber: 4 9997 put: bfOffBits + biSizeImage. "Entire file size in bytes" 9998 stream 9999 nextLittleEndianNumber: 4 10000 put: 0. "bfReserved" 10001 stream 10002 nextLittleEndianNumber: 4 10003 put: bfOffBits. "Offset of bitmap data from start of hdr (and file)" 10004 10005 "Write the bitmap info header" 10006 stream position: bhSize. 10007 stream 10008 nextLittleEndianNumber: 4 10009 put: biSize. "info header size in bytes" 10010 stream 10011 nextLittleEndianNumber: 4 10012 put: image width. "biWidth" 10013 stream 10014 nextLittleEndianNumber: 4 10015 put: image height. "biHeight" 10016 stream 10017 nextLittleEndianNumber: 2 10018 put: 1. "biPlanes" 10019 stream 10020 nextLittleEndianNumber: 2 10021 put: (depth min: 24). "biBitCount" 10022 stream 10023 nextLittleEndianNumber: 4 10024 put: 0. "biCompression" 10025 stream 10026 nextLittleEndianNumber: 4 10027 put: biSizeImage. "size of image section in bytes" 10028 stream 10029 nextLittleEndianNumber: 4 10030 put: 2800. "biXPelsPerMeter" 10031 stream 10032 nextLittleEndianNumber: 4 10033 put: 2800. "biYPelsPerMeter" 10034 stream 10035 nextLittleEndianNumber: 4 10036 put: biClrUsed. 10037 stream 10038 nextLittleEndianNumber: 4 10039 put: 0. "biClrImportant" 10040 biClrUsed > 0 ifTrue: 10041 [ "write color map; this works for ColorForms, too" 10042 colorValues := image colormapIfNeededForDepth: 32. 10043 1 10044 to: biClrUsed 10045 do: 10046 [ :i | 10047 rgb := colorValues at: i. 10048 0 10049 to: 24 10050 by: 8 10051 do: [ :j | stream nextPut: (rgb >> j bitAnd: 255) ] ] ]. 10052 depth < 32 10053 ifTrue: 10054 [ "depth = 1, 4 or 8." 10055 data := image bits asByteArray. 10056 ppw := 32 // depth. 10057 scanLineLen := (biWidth + ppw - 1) // ppw * 4. "# of bytes in line" 10058 1 10059 to: biHeight 10060 do: 10061 [ :i | 10062 stream 10063 next: scanLineLen 10064 putAll: data 10065 startingAt: (biHeight - i) * scanLineLen + 1 ] ] 10066 ifFalse: 10067 [ 1 10068 to: biHeight 10069 do: 10070 [ :i | 10071 data := (image copy: (0 @ (biHeight - i) extent: biWidth @ 1)) bits. 10072 1 10073 to: data size 10074 do: 10075 [ :j | 10076 stream 10077 nextLittleEndianNumber: 3 10078 put: (data at: j) ]. 10079 1 10080 to: (data size * 3 + 3) // 4 * 4 - (data size * 3) 10081 do: [ :j | stream nextPut: 0 "pad to 32-bits" ] ] ]. 10082 stream position = (bfOffBits + biSizeImage) ifFalse: [ self error: 'Write failure' ]. 10083 stream close! ! 10084 10085"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 10086 10087BMPReadWriter class 10088 instanceVariableNames: ''! 10089 10090!BMPReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'! 10091typicalFileExtensions 10092 "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" 10093 ^#('bmp')! ! 10094 10095 10096!BMPReadWriter class methodsFor: 'testing' stamp: 'ar 6/16/2002 18:55'! 10097displayAllFrom: fd 10098 "BMPReadWriter displayAllFrom: FileDirectory default" 10099 fd fileNames do:[:fName| 10100 (fName endsWith: '.bmp') ifTrue:[ 10101 [(Form fromBinaryStream: (fd readOnlyFileNamed: fName)) display. 10102 Display forceDisplayUpdate] on: Error do:[:nix|]. 10103 ]. 10104 ]. 10105 fd directoryNames do:[:fdName| 10106 self displayAllFrom: (fd directoryNamed: fdName) 10107 ].! ! 10108 10109!BMPReadWriter class methodsFor: 'testing' stamp: 'ar 6/16/2002 18:56'! 10110readAllFrom: fd 10111 "MessageTally spyOn:[BMPReadWriter readAllFrom: FileDirectory default]" 10112 fd fileNames do:[:fName| 10113 (fName endsWith: '.bmp') ifTrue:[ 10114 [Form fromBinaryStream: (fd readOnlyFileNamed: fName)] on: Error do:[:nix]. 10115 ]. 10116 ]. 10117 fd directoryNames do:[:fdName| 10118 self readAllFrom: (fd directoryNamed: fdName) 10119 ].! ! 10120TestCase subclass: #BMPReadWriterTest 10121 instanceVariableNames: '' 10122 classVariableNames: '' 10123 poolDictionaries: '' 10124 category: 'GraphicsTests-Files'! 10125 10126!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 02:22'! 10127bmpData16bit 10128 "Created via: 10129 (Base64MimeConverter mimeEncode: 10130 (FileStream readOnlyFileNamed: 'bmptest16b.bmp') binary) 10131 contents 10132 " 10133 ^(Base64MimeConverter mimeDecodeToBytes: 10134'Qk24AAAAAAAAADYAAAAoAAAACAAAAAgAAAABABAAAAAAAIIAAADDDgAAww4AAAAAAAAAAAAA 101354APgA+AD4AMfAB8AHwAfAOAD4APgA+ADHwAfAB8AHwDgA+AD/3//f/9//38fAB8A4APgA/9/ 10136/3//f/9/HwAfAAAAAAD/f/9//3//fwB8AHwAAAAA/3//f/9//38AfAB8AAAAAAAAAAAAfAB8 10137AHwAfAAAAAAAAAAAAHwAfAB8AHwAAA==' readStream) contents! ! 10138 10139!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:27'! 10140bmpData24bit 10141 "Created via: 10142 (Base64MimeConverter mimeEncode: 10143 (FileStream readOnlyFileNamed: 'bmptest24.bmp') binary) 10144 contents 10145 " 10146 ^(Base64MimeConverter mimeDecodeToBytes: 10147'Qk32AAAAAAAAADYAAAAoAAAACAAAAAgAAAABABgAAAAAAAAAAADEDgAAxA4AAAAAAAAAAAAA 10148AP8AAP8AAP8AAP8A/wAA/wAA/wAA/wAAAP8AAP8AAP8AAP8A/wAA/wAA/wAA/wAAAP8AAP8A 10149/////////////////wAA/wAAAP8AAP8A/////////////////wAA/wAAAAAAAAAA//////// 10150////////AAD/AAD/AAAAAAAA////////////////AAD/AAD/AAAAAAAAAAAAAAAAAAD/AAD/ 10151AAD/AAD/AAAAAAAAAAAAAAAAAAD/AAD/AAD/AAD/' readStream) contents! ! 10152 10153!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 02:22'! 10154bmpData32bit 10155 "Created via: 10156 (Base64MimeConverter mimeEncode: 10157 (FileStream readOnlyFileNamed: 'bmptest32b.bmp') binary) 10158 contents 10159 " 10160 ^(Base64MimeConverter mimeDecodeToBytes: 10161'Qk04AQAAAAAAADYAAAAoAAAACAAAAAgAAAABACAAAAAAAAIBAADDDgAAww4AAAAAAAAAAAAA 10162AP8AAAD/AAAA/wAAAP8AAP8AAAD/AAAA/wAAAP8AAAAA/wAAAP8AAAD/AAAA/wAA/wAAAP8A 10163AAD/AAAA/wAAAAD/AAAA/wAA////AP///wD///8A////AP8AAAD/AAAAAP8AAAD/AAD///8A 10164////AP///wD///8A/wAAAP8AAAAAAAAAAAAAAP///wD///8A////AP///wAAAP8AAAD/AAAA 10165AAAAAAAA////AP///wD///8A////AAAA/wAAAP8AAAAAAAAAAAAAAAAAAAAAAAAA/wAAAP8A 10166AAD/AAAA/wAAAAAAAAAAAAAAAAAAAAAAAAD/AAAA/wAAAP8AAAD/AAAA' 10167readStream) contents! ! 10168 10169!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:41'! 10170bmpData4bit 10171 "Created via: 10172 (Base64MimeConverter mimeEncode: 10173 (FileStream readOnlyFileNamed: 'bmptest4.bmp') binary) 10174 contents 10175 " 10176 ^(Base64MimeConverter mimeDecodeToBytes: 10177'Qk12BAAAAAAAADYEAAAoAAAACAAAAAgAAAABAAgAAAAAAEAAAADEDgAAxA4AAAAAAAAAAAAA 10178AAAAAAAAgAAAgAAAAICAAIAAAACAAIAAgIAAAMDAwADA3MAA8MqmAAAgQAAAIGAAACCAAAAg 10179oAAAIMAAACDgAABAAAAAQCAAAEBAAABAYAAAQIAAAECgAABAwAAAQOAAAGAAAABgIAAAYEAA 10180AGBgAABggAAAYKAAAGDAAABg4AAAgAAAAIAgAACAQAAAgGAAAICAAACAoAAAgMAAAIDgAACg 10181AAAAoCAAAKBAAACgYAAAoIAAAKCgAACgwAAAoOAAAMAAAADAIAAAwEAAAMBgAADAgAAAwKAA 10182AMDAAADA4AAA4AAAAOAgAADgQAAA4GAAAOCAAADgoAAA4MAAAODgAEAAAABAACAAQABAAEAA 10183YABAAIAAQACgAEAAwABAAOAAQCAAAEAgIABAIEAAQCBgAEAggABAIKAAQCDAAEAg4ABAQAAA 10184QEAgAEBAQABAQGAAQECAAEBAoABAQMAAQEDgAEBgAABAYCAAQGBAAEBgYABAYIAAQGCgAEBg 10185wABAYOAAQIAAAECAIABAgEAAQIBgAECAgABAgKAAQIDAAECA4ABAoAAAQKAgAECgQABAoGAA 10186QKCAAECgoABAoMAAQKDgAEDAAABAwCAAQMBAAEDAYABAwIAAQMCgAEDAwABAwOAAQOAAAEDg 10187IABA4EAAQOBgAEDggABA4KAAQODAAEDg4ACAAAAAgAAgAIAAQACAAGAAgACAAIAAoACAAMAA 10188gADgAIAgAACAICAAgCBAAIAgYACAIIAAgCCgAIAgwACAIOAAgEAAAIBAIACAQEAAgEBgAIBA 10189gACAQKAAgEDAAIBA4ACAYAAAgGAgAIBgQACAYGAAgGCAAIBgoACAYMAAgGDgAICAAACAgCAA 10190gIBAAICAYACAgIAAgICgAICAwACAgOAAgKAAAICgIACAoEAAgKBgAICggACAoKAAgKDAAICg 101914ACAwAAAgMAgAIDAQACAwGAAgMCAAIDAoACAwMAAgMDgAIDgAACA4CAAgOBAAIDgYACA4IAA 10192gOCgAIDgwACA4OAAwAAAAMAAIADAAEAAwABgAMAAgADAAKAAwADAAMAA4ADAIAAAwCAgAMAg 10193QADAIGAAwCCAAMAgoADAIMAAwCDgAMBAAADAQCAAwEBAAMBAYADAQIAAwECgAMBAwADAQOAA 10194wGAAAMBgIADAYEAAwGBgAMBggADAYKAAwGDAAMBg4ADAgAAAwIAgAMCAQADAgGAAwICAAMCA 10195oADAgMAAwIDgAMCgAADAoCAAwKBAAMCgYADAoIAAwKCgAMCgwADAoOAAwMAAAMDAIADAwEAA 10196wMBgAMDAgADAwKAA8Pv/AKSgoACAgIAAAAD/AAD/AAAA//8A/wAAAP8A/wD//wAA////APr6 10197+vr8/Pz8+vr6+vz8/Pz6+v/////8/Pr6//////z8AAD/////+fkAAP/////5+QAAAAD5+fn5 10198AAAAAPn5+fk=' readStream) contents! ! 10199 10200!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:27'! 10201bmpData8bit 10202 "Created via: 10203 (Base64MimeConverter mimeEncode: 10204 (FileStream readOnlyFileNamed: 'bmptest8.bmp') binary) 10205 contents 10206 " 10207 ^(Base64MimeConverter mimeDecodeToBytes: 10208'Qk12BAAAAAAAADYEAAAoAAAACAAAAAgAAAABAAgAAAAAAEAAAADEDgAAxA4AAAAAAAAAAAAA 10209AAAAAAAAgAAAgAAAAICAAIAAAACAAIAAgIAAAMDAwADA3MAA8MqmAAAgQAAAIGAAACCAAAAg 10210oAAAIMAAACDgAABAAAAAQCAAAEBAAABAYAAAQIAAAECgAABAwAAAQOAAAGAAAABgIAAAYEAA 10211AGBgAABggAAAYKAAAGDAAABg4AAAgAAAAIAgAACAQAAAgGAAAICAAACAoAAAgMAAAIDgAACg 10212AAAAoCAAAKBAAACgYAAAoIAAAKCgAACgwAAAoOAAAMAAAADAIAAAwEAAAMBgAADAgAAAwKAA 10213AMDAAADA4AAA4AAAAOAgAADgQAAA4GAAAOCAAADgoAAA4MAAAODgAEAAAABAACAAQABAAEAA 10214YABAAIAAQACgAEAAwABAAOAAQCAAAEAgIABAIEAAQCBgAEAggABAIKAAQCDAAEAg4ABAQAAA 10215QEAgAEBAQABAQGAAQECAAEBAoABAQMAAQEDgAEBgAABAYCAAQGBAAEBgYABAYIAAQGCgAEBg 10216wABAYOAAQIAAAECAIABAgEAAQIBgAECAgABAgKAAQIDAAECA4ABAoAAAQKAgAECgQABAoGAA 10217QKCAAECgoABAoMAAQKDgAEDAAABAwCAAQMBAAEDAYABAwIAAQMCgAEDAwABAwOAAQOAAAEDg 10218IABA4EAAQOBgAEDggABA4KAAQODAAEDg4ACAAAAAgAAgAIAAQACAAGAAgACAAIAAoACAAMAA 10219gADgAIAgAACAICAAgCBAAIAgYACAIIAAgCCgAIAgwACAIOAAgEAAAIBAIACAQEAAgEBgAIBA 10220gACAQKAAgEDAAIBA4ACAYAAAgGAgAIBgQACAYGAAgGCAAIBgoACAYMAAgGDgAICAAACAgCAA 10221gIBAAICAYACAgIAAgICgAICAwACAgOAAgKAAAICgIACAoEAAgKBgAICggACAoKAAgKDAAICg 102224ACAwAAAgMAgAIDAQACAwGAAgMCAAIDAoACAwMAAgMDgAIDgAACA4CAAgOBAAIDgYACA4IAA 10223gOCgAIDgwACA4OAAwAAAAMAAIADAAEAAwABgAMAAgADAAKAAwADAAMAA4ADAIAAAwCAgAMAg 10224QADAIGAAwCCAAMAgoADAIMAAwCDgAMBAAADAQCAAwEBAAMBAYADAQIAAwECgAMBAwADAQOAA 10225wGAAAMBgIADAYEAAwGBgAMBggADAYKAAwGDAAMBg4ADAgAAAwIAgAMCAQADAgGAAwICAAMCA 10226oADAgMAAwIDgAMCgAADAoCAAwKBAAMCgYADAoIAAwKCgAMCgwADAoOAAwMAAAMDAIADAwEAA 10227wMBgAMDAgADAwKAA8Pv/AKSgoACAgIAAAAD/AAD/AAAA//8A/wAAAP8A/wD//wAA////APr6 10228+vr8/Pz8+vr6+vz8/Pz6+v/////8/Pr6//////z8AAD/////+fkAAP/////5+QAAAAD5+fn5 10229AAAAAPn5+fk=' readStream) contents! ! 10230 10231!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:04'! 10232bmpDataR5G6B5 10233 "This is a BMP file based on BitmapV4Header which is currently unsupported." 10234 "Created via: 10235 (Base64MimeConverter mimeEncode: 10236 (FileStream readOnlyFileNamed: 'bmptest16-R5G6B5.bmp') binary) 10237 contents 10238 " 10239 ^(Base64MimeConverter mimeDecodeToBytes: 10240'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA 10241APgAAOAHAAAfAAAAAAAAAOAH4AfgB+AHHwAfAB8AHwDgB+AH4AfgBx8AHwAfAB8A4AfgB/// 10242////////HwAfAOAH4Af//////////x8AHwAAAAAA//////////8A+AD4AAAAAP////////// 10243APgA+AAAAAAAAAAAAPgA+AD4APgAAAAAAAAAAAD4APgA+AD4AAA=' 10244readStream) contents! ! 10245 10246!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:04'! 10247bmpDataX4R4G4B4 10248 "This is a BMP file based on BitmapV4Header which is currently unsupported." 10249 "Created via: 10250 (Base64MimeConverter mimeEncode: 10251 (FileStream readOnlyFileNamed: 'bmptest16-X4R4G4B4.bmp') binary) 10252 contents 10253 " 10254 ^(Base64MimeConverter mimeDecodeToBytes: 10255'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA 10256AA8AAPAAAAAPAAAAAAAAAPAA8ADwAPAADwAPAA8ADwDwAPAA8ADwAA8ADwAPAA8A8ADwAP8P 10257/w//D/8PDwAPAPAA8AD/D/8P/w//Dw8ADwAAAAAA/w//D/8P/w8ADwAPAAAAAP8P/w//D/8P 10258AA8ADwAAAAAAAAAAAA8ADwAPAA8AAAAAAAAAAAAPAA8ADwAPAAA=' 10259readStream) contents! ! 10260 10261!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:05'! 10262bmpDataX8R8G8B8 10263 "This is a BMP file based on BitmapV4Header which is currently unsupported." 10264 "Created via: 10265 (Base64MimeConverter mimeEncode: 10266 (FileStream readOnlyFileNamed: 'bmptest32-X8R8G8B8.bmp') binary) 10267 contents 10268 " 10269 ^(Base64MimeConverter mimeDecodeToBytes: 10270'Qk1IAQAAAAAAAEYAAAA4AAAACAAAAAgAAAABACAAAwAAAAIBAADDDgAAww4AAAAAAAAAAAAA 10271AAAA/wAA/wAA/wAAAAAAAAAA/wAAAP8AAAD/AAAA/wAA/wAAAP8AAAD/AAAA/wAAAAD/AAAA 10272/wAAAP8AAAD/AAD/AAAA/wAAAP8AAAD/AAAAAP8AAAD/AAD///8A////AP///wD///8A/wAA 10273AP8AAAAA/wAAAP8AAP///wD///8A////AP///wD/AAAA/wAAAAAAAAAAAAAA////AP///wD/ 10274//8A////AAAA/wAAAP8AAAAAAAAAAAD///8A////AP///wD///8AAAD/AAAA/wAAAAAAAAAA 10275AAAAAAAAAAAAAAD/AAAA/wAAAP8AAAD/AAAAAAAAAAAAAAAAAAAAAAAAAP8AAAD/AAAA/wAA 10276AP8AAA==' 10277readStream) contents! ! 10278 10279 10280!BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! 10281testBmp16Bit 10282 | reader form | 10283 reader := BMPReadWriter new on: self bmpData16bit readStream. 10284 form := reader nextImage. 10285 "special black here to compensate for zero-is-transparent effect" 10286 self assert: (form colorAt: 7 @ 1) = Color red. 10287 self assert: (form colorAt: 1 @ 7) = Color green. 10288 self assert: (form colorAt: 7 @ 7) = Color blue. 10289 self assert: (form colorAt: 4 @ 4) = Color white. 10290 self assert: (form pixelValueAt: 1 @ 1) = 32768! ! 10291 10292!BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! 10293testBmp24Bit 10294 | reader form | 10295 reader := BMPReadWriter new on: self bmpData24bit readStream. 10296 form := reader nextImage. 10297 self assert: (form colorAt: 7 @ 1) = Color red. 10298 self assert: (form colorAt: 1 @ 7) = Color green. 10299 self assert: (form colorAt: 7 @ 7) = Color blue. 10300 self assert: (form colorAt: 4 @ 4) = Color white. 10301 self assert: (form pixelValueAt: 1 @ 1) = 4278190080! ! 10302 10303!BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! 10304testBmp32Bit 10305 | reader form | 10306 reader := BMPReadWriter new on: self bmpData32bit readStream. 10307 form := reader nextImage. 10308 self assert: (form colorAt: 7 @ 1) = Color red. 10309 self assert: (form colorAt: 1 @ 7) = Color green. 10310 self assert: (form colorAt: 7 @ 7) = Color blue. 10311 self assert: (form colorAt: 4 @ 4) = Color white. 10312 self assert: (form pixelValueAt: 1 @ 1) = 4278190080! ! 10313 10314!BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! 10315testBmp4Bit 10316 | reader form | 10317 reader := BMPReadWriter new on: self bmpData4bit readStream. 10318 form := reader nextImage. 10319 self assert: (form colorAt: 1 @ 1) = Color black. 10320 self assert: (form colorAt: 7 @ 1) = Color red. 10321 self assert: (form colorAt: 1 @ 7) = Color green. 10322 self assert: (form colorAt: 7 @ 7) = Color blue. 10323 self assert: (form colorAt: 4 @ 4) = Color white! ! 10324 10325!BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! 10326testBmp8Bit 10327 | reader form | 10328 reader := BMPReadWriter new on: self bmpData8bit readStream. 10329 form := reader nextImage. 10330 self assert: (form colorAt: 1 @ 1) = Color black. 10331 self assert: (form colorAt: 7 @ 1) = Color red. 10332 self assert: (form colorAt: 1 @ 7) = Color green. 10333 self assert: (form colorAt: 7 @ 7) = Color blue. 10334 self assert: (form colorAt: 4 @ 4) = Color white! ! 10335Object subclass: #BadEqualer 10336 instanceVariableNames: '' 10337 classVariableNames: '' 10338 poolDictionaries: '' 10339 category: 'SUnit-Utilities'! 10340!BadEqualer commentStamp: 'mjr 8/20/2003 13:28' prior: 0! 10341I am an object that doesn't always report #= correctly. Used for testing the EqualityTester.! 10342 10343 10344!BadEqualer methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'! 10345= other 10346 self class = other class 10347 ifFalse: [^ false]. 10348 ^ 100 atRandom < 30 ! ! 10349Object subclass: #BadHasher 10350 instanceVariableNames: '' 10351 classVariableNames: '' 10352 poolDictionaries: '' 10353 category: 'SUnit-Utilities'! 10354!BadHasher commentStamp: 'mjr 8/20/2003 13:28' prior: 0! 10355I am an object that doesn't always hash correctly. I am used for testing the HashTester.! 10356 10357 10358!BadHasher methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'! 10359hash 10360 "answer with a different hash some of the time" 10361 100 atRandom < 30 10362 ifTrue: [^ 1]. 10363 ^ 2! ! 10364Collection subclass: #Bag 10365 instanceVariableNames: 'contents' 10366 classVariableNames: '' 10367 poolDictionaries: '' 10368 category: 'Collections-Unordered'! 10369!Bag commentStamp: '<historical>' prior: 0! 10370I represent an unordered collection of possibly duplicate elements. 10371 10372I store these elements in a dictionary, tallying up occurrences of equal objects. Because I store an occurrence only once, my clients should beware that objects they store will not necessarily be retrieved such that == is true. If the client cares, a subclass of me should be created.! 10373 10374 10375!Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'! 10376at: index 10377 self errorNotKeyed! ! 10378 10379!Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'! 10380at: index put: anObject 10381 self errorNotKeyed! ! 10382 10383!Bag methodsFor: 'accessing' stamp: 'tao 1/5/2000 18:25'! 10384cumulativeCounts 10385 "Answer with a collection of cumulative percents covered by elements so far." 10386 | s n | 10387 s := self size / 100.0. n := 0. 10388 ^ self sortedCounts asArray collect: 10389 [:a | n := n + a key. (n / s roundTo: 0.1) -> a value]! ! 10390 10391!Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:35'! 10392size 10393 "Answer how many elements the receiver contains." 10394 10395 | tally | 10396 tally := 0. 10397 contents do: [:each | tally := tally + each]. 10398 ^ tally! ! 10399 10400!Bag methodsFor: 'accessing' stamp: 'sma 6/15/2000 17:00'! 10401sortedCounts 10402 "Answer with a collection of counts with elements, sorted by decreasing 10403 count." 10404 10405 | counts | 10406 counts := SortedCollection sortBlock: [:x :y | x >= y]. 10407 contents associationsDo: 10408 [:assn | 10409 counts add: (Association key: assn value value: assn key)]. 10410 ^ counts! ! 10411 10412!Bag methodsFor: 'accessing'! 10413sortedElements 10414 "Answer with a collection of elements with counts, sorted by element." 10415 10416 | elements | 10417 elements := SortedCollection new. 10418 contents associationsDo: [:assn | elements add: assn]. 10419 ^elements! ! 10420 10421!Bag methodsFor: 'accessing' stamp: 'md 1/20/2006 15:58'! 10422valuesAndCounts 10423 10424 ^ contents! ! 10425 10426 10427!Bag methodsFor: 'adding' stamp: 'sma 5/12/2000 17:18'! 10428add: newObject 10429 "Include newObject as one of the receiver's elements. Answer newObject." 10430 10431 ^ self add: newObject withOccurrences: 1! ! 10432 10433!Bag methodsFor: 'adding' stamp: 'sma 5/12/2000 17:20'! 10434add: newObject withOccurrences: anInteger 10435 "Add newObject anInteger times to the receiver. Answer newObject." 10436 10437 contents at: newObject put: (contents at: newObject ifAbsent: [0]) + anInteger. 10438 ^ newObject! ! 10439 10440 10441!Bag methodsFor: 'comparing' stamp: 'md 10/17/2004 16:09'! 10442= aBag 10443 "Two bags are equal if 10444 (a) they are the same 'kind' of thing. 10445 (b) they have the same size. 10446 (c) each element occurs the same number of times in both of them" 10447 10448 (aBag isKindOf: Bag) ifFalse: [^false]. 10449 self size = aBag size ifFalse: [^false]. 10450 contents associationsDo: [:assoc| 10451 (aBag occurrencesOf: assoc key) = assoc value 10452 ifFalse: [^false]]. 10453 ^true 10454 10455! ! 10456 10457 10458!Bag methodsFor: 'converting' stamp: 'sma 5/12/2000 14:34'! 10459asBag 10460 ^ self! ! 10461 10462!Bag methodsFor: 'converting' stamp: 'sma 5/12/2000 14:30'! 10463asSet 10464 "Answer a set with the elements of the receiver." 10465 10466 ^ contents keys! ! 10467 10468 10469!Bag methodsFor: 'copying' stamp: 'sma 5/12/2000 14:53'! 10470copy 10471 ^ self shallowCopy setContents: contents copy! ! 10472 10473 10474!Bag methodsFor: 'enumerating'! 10475do: aBlock 10476 "Refer to the comment in Collection|do:." 10477 10478 contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! ! 10479 10480 10481!Bag methodsFor: 'removing' stamp: 'sma 5/12/2000 14:32'! 10482remove: oldObject ifAbsent: exceptionBlock 10483 "Refer to the comment in Collection|remove:ifAbsent:." 10484 10485 | count | 10486 count := contents at: oldObject ifAbsent: [^ exceptionBlock value]. 10487 count = 1 10488 ifTrue: [contents removeKey: oldObject] 10489 ifFalse: [contents at: oldObject put: count - 1]. 10490 ^ oldObject! ! 10491 10492!Bag methodsFor: 'removing' stamp: 'nice 9/14/2009 20:28'! 10493removeAll 10494 "Implementation Note: as contents will be overwritten, a shallowCopy of self would be modified. 10495 An alternative implementation preserving capacity would be to create a new contents: 10496 self setContents: (self class contentsClass new: contents size)." 10497 10498 contents removeAll! ! 10499 10500 10501!Bag methodsFor: 'testing'! 10502includes: anObject 10503 "Refer to the comment in Collection|includes:." 10504 10505 ^contents includesKey: anObject! ! 10506 10507!Bag methodsFor: 'testing'! 10508occurrencesOf: anObject 10509 "Refer to the comment in Collection|occurrencesOf:." 10510 10511 (self includes: anObject) 10512 ifTrue: [^contents at: anObject] 10513 ifFalse: [^0]! ! 10514 10515 10516!Bag methodsFor: 'private' stamp: 'sma 5/12/2000 14:49'! 10517setContents: aDictionary 10518 contents := aDictionary! ! 10519 10520"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 10521 10522Bag class 10523 instanceVariableNames: ''! 10524 10525!Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! 10526contentsClass 10527 ^Dictionary! ! 10528 10529!Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 13:31'! 10530new 10531 ^ self new: 4! ! 10532 10533!Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! 10534new: nElements 10535 ^ super new setContents: (self contentsClass new: nElements)! ! 10536 10537!Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:17'! 10538newFrom: aCollection 10539 "Answer an instance of me containing the same elements as aCollection." 10540 10541 ^ self withAll: aCollection 10542 10543"Examples: 10544 Bag newFrom: {1. 2. 3. 3} 10545 {1. 2. 3. 3} as: Bag 10546"! ! 10547CollectionRootTest subclass: #BagTest 10548 uses: TAddTest + TIncludesWithIdentityCheckTest + TCloneTest + TCopyTest + TSetArithmetic + TConvertTest + TAsStringCommaAndDelimiterTest + TRemoveForMultiplenessTest + TPrintTest + TConvertAsSortedTest + TConvertAsSetForMultiplinessTest + TConcatenationTest + TStructuralEqualityTest + TCreationWithTest - {#testOfSize} + TOccurrencesForMultiplinessTest 10549 instanceVariableNames: 'empty nonEmpty result emptyButAllocatedWith20 elementExistsTwice element collectionWithElement collectionIn collectionNotIn collectionOfString elementNotIn collectionWithCharacters otherCollectionWithoutEqualElements collectionWithoutNilMoreThan5' 10550 classVariableNames: '' 10551 poolDictionaries: '' 10552 category: 'CollectionsTests-Unordered'! 10553 10554!BagTest methodsFor: 'as yet unclassified' stamp: 'damienpollet 1/13/2009 15:57'! 10555testAnySastify 10556 10557 self assert: ( self collection anySatisfy: [:each | each = self element]). 10558 self deny: (self collection anySatisfy: [:each | each isString]).! ! 10559 10560 10561!BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:28'! 10562testAdd 10563 "self run: #testAdd" 10564 "self debug: #testAdd" 10565 10566 | aBag | 10567 aBag := Bag new. 10568 aBag add: 'a'. 10569 aBag add: 'b'. 10570 10571 self assert: aBag size = 2. 10572 aBag add: 'a'. 10573 self assert: aBag size = 3. 10574 self assert: (aBag occurrencesOf: 'a') = 2 10575 10576! ! 10577 10578!BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:28'! 10579testAddWithOccurrences 10580 "self debug:#testAddWithOccurrences" 10581 10582 | aBag | 10583 aBag := Bag new. 10584 aBag add: 'a' withOccurrences: 3. 10585 self assert: (aBag size = 3). 10586 10587 10588 10589 10590 10591! ! 10592 10593!BagTest methodsFor: 'basic tests' stamp: 'TJ 3/8/2006 08:42'! 10594testAsBag 10595 10596 | aBag | 10597 10598 aBag := Bag new. 10599 10600 self assert: aBag asBag = aBag.! ! 10601 10602!BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:29'! 10603testAsSet 10604 10605 | aBag aSet | 10606 aBag := Bag new. 10607 aBag add:'a' withOccurrences: 4. 10608 aBag add:'b' withOccurrences: 2. 10609 aSet := aBag asSet. 10610 self assert: aSet size = 2. 10611 self assert: (aSet occurrencesOf: 'a') = 1 10612 ! ! 10613 10614!BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:30'! 10615testCopy 10616 "self run: #testCopy" 10617 10618 | aBag newBag | 10619 aBag := Bag new. 10620 aBag add:'a' withOccurrences: 4. 10621 aBag add:'b' withOccurrences: 2. 10622 newBag := aBag copy. 10623 self assert: newBag = newBag. 10624 self assert: newBag asSet size = 2.! ! 10625 10626!BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:32'! 10627testOccurrencesOf 10628 "self debug: #testOccurrencesOf" 10629 10630 | aBag | 10631 aBag := Bag new. 10632 aBag add: 'a' withOccurrences: 3. 10633 aBag add: 'b'. 10634 aBag add: 'b'. 10635 aBag add: 'b'. 10636 aBag add: 'b'. 10637 self assert: (aBag occurrencesOf:'a') = 3. 10638 self assert: (aBag occurrencesOf:'b') = 4. 10639 self assert: (aBag occurrencesOf:'c') = 0. 10640 self assert: (aBag occurrencesOf: nil) =0. 10641 aBag add: nil. 10642 self assert: (aBag occurrencesOf: nil) =1. 10643 ! ! 10644 10645 10646!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:01'! 10647anotherElementOrAssociationIn 10648 " return an element (or an association for Dictionary ) present in 'collection' " 10649 ^ self collection anyOne! ! 10650 10651!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:01'! 10652anotherElementOrAssociationNotIn 10653 " return an element (or an association for Dictionary )not present in 'collection' " 10654 ^ elementNotIn ! ! 10655 10656!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 12:07'! 10657collectionInForIncluding 10658 ^ collectionIn ! ! 10659 10660!BagTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:16'! 10661collectionMoreThan5Elements 10662" return a collection including at least 5 elements" 10663 10664 ^ collectionWithoutNilMoreThan5 ! ! 10665 10666!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 12:08'! 10667collectionNotIncluded 10668 ^ collectionNotIn ! ! 10669 10670!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:07'! 10671collectionOfFloat 10672 ^ collectionOfString! ! 10673 10674!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:22'! 10675collectionWithCharacters 10676 ^ collectionWithCharacters .! ! 10677 10678!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! 10679collectionWithCopyNonIdentical 10680 " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" 10681 ^ collectionOfString! ! 10682 10683!BagTest methodsFor: 'requirements' stamp: 'sd 1/28/2009 16:32'! 10684collectionWithElement 10685 "Returns a collection that already includes what is returned by #element." 10686 ^ collectionWithElement! ! 10687 10688!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:24'! 10689collectionWithElementsToRemove 10690 ^ collectionIn! ! 10691 10692!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:20'! 10693collectionWithEqualElements 10694 ^ nonEmpty ! ! 10695 10696!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:31'! 10697collectionWithSortableElements 10698" return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" 10699 ^ nonEmpty ! ! 10700 10701!BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! 10702collectionWithoutEqualElements 10703 ^ otherCollectionWithoutEqualElements! ! 10704 10705!BagTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:15'! 10706collectionWithoutNilElements 10707 " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" 10708 ^ collectionWithoutNilMoreThan5! ! 10709 10710!BagTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:32'! 10711element 10712 ^ super element! ! 10713 10714!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:19'! 10715elementInForIncludesTest 10716 10717 ^ self element ! ! 10718 10719!BagTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:32'! 10720elementInForOccurrences 10721" return an element included in nonEmpty" 10722 ^self nonEmpty anyOne.! ! 10723 10724!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 13:40'! 10725elementNotIn 10726 10727 ^elementNotIn ! ! 10728 10729!BagTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:33'! 10730elementTwiceInForOccurrences 10731" return an element included exactly two time in # collectionWithEqualElements" 10732^ self elementTwiceIn ! ! 10733 10734!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:19'! 10735elementsCopyNonIdenticalWithoutEqualElements 10736 " return a collection that does niot incllude equal elements ( classic equality ) 10737 all elements included are elements for which copy is not identical to the element " 10738 ^ collectionOfString ! ! 10739 10740!BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:53'! 10741firstCollection 10742" return a collection that will be the first part of the concatenation" 10743 ^ nonEmpty ! ! 10744 10745!BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! 10746integerCollectionWithoutEqualElements 10747 ^ otherCollectionWithoutEqualElements! ! 10748 10749!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/30/2009 10:54'! 10750nonEmpty1Element 10751 10752 ^ self speciesClass new add: self element ;yourself.! ! 10753 10754!BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:28'! 10755nonEmptyWithoutEqualElements 10756" return a collection without equal elements " 10757 ^ otherCollectionWithoutEqualElements ! ! 10758 10759!BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! 10760otherCollection 10761 ^ otherCollectionWithoutEqualElements! ! 10762 10763!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:47'! 10764resultForCollectElementsClass 10765" return the retsult expected by collecting the class of each element of collectionWithoutNilElements" 10766 ^ result ! ! 10767 10768!BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:53'! 10769secondCollection 10770" return a collection that will be the second part of the concatenation" 10771 ^ collectionWithCharacters ! ! 10772 10773!BagTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:40'! 10774selectedNumber 10775 ^ 4! ! 10776 10777!BagTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/6/2008 17:39'! 10778speciesClass 10779 10780 ^ Bag! ! 10781 10782!BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:21'! 10783withEqualElements 10784 " return a collection including equal elements (classic equality)" 10785 ^ nonEmpty .! ! 10786 10787 10788!BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:22'! 10789collection 10790 10791 ^ nonEmpty. 10792 ! ! 10793 10794!BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 15:13'! 10795empty 10796 10797 ^ empty 10798 10799 ! ! 10800 10801!BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:26'! 10802emptyButAllocatedWith20 10803 10804 ^ emptyButAllocatedWith20! ! 10805 10806!BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 15:14'! 10807nonEmpty 10808 10809 ^ nonEmpty 10810 10811 ! ! 10812 10813!BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:22'! 10814result 10815 10816 ^ result. 10817 ! ! 10818 10819!BagTest methodsFor: 'setup' stamp: 'delaunay 5/14/2009 12:15'! 10820setUp 10821 empty := self speciesClass new. 10822 nonEmpty := self speciesClass new 10823 add: 13; 10824 add: -2; 10825 add: self elementTwiceIn; 10826 add: 10; 10827 add: self elementTwiceIn; 10828 add: self element; 10829 yourself. 10830 elementNotIn := 0. 10831 collectionIn := self speciesClass new 10832 add: -2; 10833 add: self elementTwiceIn; 10834 add: 10; 10835 yourself. 10836 collectionNotIn := self speciesClass new 10837 add: self elementNotIn; 10838 add: 5; 10839 yourself. 10840 collectionOfString := self speciesClass new 10841 add: 1.5; 10842 add: 5.5; 10843 add: 7.5; 10844 yourself. 10845 otherCollectionWithoutEqualElements := self speciesClass new 10846 add: 1; 10847 add: 20; 10848 add: 30; 10849 add: 40; 10850 yourself. 10851 collectionWithoutNilMoreThan5 := self speciesClass new 10852 add: 1; 10853 add: 2; 10854 add: 3; 10855 add: 4; 10856 add: 5; 10857 add: 6; 10858 yourself. 10859 result := self speciesClass new 10860 add: SmallInteger; 10861 add: SmallInteger; 10862 add: SmallInteger; 10863 add: SmallInteger; 10864 add: SmallInteger; 10865 add: SmallInteger; 10866 yourself. 10867 emptyButAllocatedWith20 := self speciesClass new: 20. 10868 collectionWithElement := self speciesClass new 10869 add: self element; 10870 yourself. 10871 collectionWithCharacters := self speciesClass new 10872 add: $p; 10873 add: $v; 10874 add: $i; 10875 add: $y; 10876 yourself! ! 10877 10878!BagTest methodsFor: 'setup' stamp: 'delaunay 5/11/2009 11:27'! 10879sizeCollection 10880 ^ otherCollectionWithoutEqualElements! ! 10881 10882 10883!BagTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! 10884elementToAdd 10885 ^ 42! ! 10886 10887 10888!BagTest methodsFor: 'test - creation'! 10889testWith 10890 "self debug: #testWith" 10891 10892 | aCol element | 10893 element := self collectionMoreThan5Elements anyOne. 10894 aCol := self collectionClass with: element. 10895 self assert: (aCol includes: element).! ! 10896 10897!BagTest methodsFor: 'test - creation'! 10898testWithAll 10899 "self debug: #testWithAll" 10900 10901 | aCol collection | 10902 collection := self collectionMoreThan5Elements asOrderedCollection . 10903 aCol := self collectionClass withAll: collection . 10904 10905 collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. 10906 10907 self assert: (aCol size = collection size ).! ! 10908 10909!BagTest methodsFor: 'test - creation'! 10910testWithWith 10911 "self debug: #testWithWith" 10912 10913 | aCol collection element1 element2 | 10914 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . 10915 element1 := collection at: 1. 10916 element2 := collection at:2. 10917 10918 aCol := self collectionClass with: element1 with: element2 . 10919 self assert: (aCol occurrencesOf: element1 ) == ( collection occurrencesOf: element1). 10920 self assert: (aCol occurrencesOf: element2 ) == ( collection occurrencesOf: element2). 10921 10922 ! ! 10923 10924!BagTest methodsFor: 'test - creation'! 10925testWithWithWith 10926 "self debug: #testWithWithWith" 10927 10928 | aCol collection | 10929 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . 10930 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 10931 10932 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 10933 10934!BagTest methodsFor: 'test - creation'! 10935testWithWithWithWith 10936 "self debug: #testWithWithWithWith" 10937 10938 | aCol collection | 10939 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. 10940 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 10941 10942 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 10943 10944!BagTest methodsFor: 'test - creation'! 10945testWithWithWithWithWith 10946 "self debug: #testWithWithWithWithWith" 10947 10948 | aCol collection | 10949 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . 10950 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 10951 10952 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 10953 10954 10955!BagTest methodsFor: 'test - equality'! 10956testEqualSign 10957 "self debug: #testEqualSign" 10958 10959 self deny: (self empty = self nonEmpty).! ! 10960 10961!BagTest methodsFor: 'test - equality'! 10962testEqualSignIsTrueForNonIdenticalButEqualCollections 10963 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 10964 10965 self assert: (self empty = self empty copy). 10966 self assert: (self empty copy = self empty). 10967 self assert: (self empty copy = self empty copy). 10968 10969 self assert: (self nonEmpty = self nonEmpty copy). 10970 self assert: (self nonEmpty copy = self nonEmpty). 10971 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 10972 10973!BagTest methodsFor: 'test - equality'! 10974testEqualSignOfIdenticalCollectionObjects 10975 "self debug: #testEqualSignOfIdenticalCollectionObjects" 10976 10977 self assert: (self empty = self empty). 10978 self assert: (self nonEmpty = self nonEmpty). 10979 ! ! 10980 10981 10982!BagTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/30/2009 17:36'! 10983doWithoutNumber 10984 10985 ^ 4! ! 10986 10987!BagTest methodsFor: 'test - iterate' stamp: 'marcus.denker 2/20/2009 16:29'! 10988expectedElementByDetect 10989 10990 ^ -2 10991 10992 ! ! 10993 10994!BagTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/30/2009 17:37'! 10995expectedSizeAfterReject 10996 ^ 2! ! 10997 10998 10999!BagTest methodsFor: 'test - remove' stamp: 'damienpollet 1/30/2009 17:15'! 11000elementTwiceIn 11001 ^ super elementTwiceIn! ! 11002 11003!BagTest methodsFor: 'test - remove' stamp: 'damienpollet 1/30/2009 17:07'! 11004testRemoveElementThatExistsTwice 11005 "self debug: #testRemoveElementThatDoesExistsTwice" 11006 | size | 11007 size := self nonEmpty size. 11008 self assert: (self nonEmpty includes: self elementTwiceIn). 11009 self nonEmpty remove: self elementTwiceIn. 11010 self assert: size - 1 = self nonEmpty size! ! 11011 11012 11013!BagTest methodsFor: 'test - set arithmetic' stamp: 'stephane.ducasse 12/20/2008 22:46'! 11014collectionClass 11015 11016 ^ Bag! ! 11017 11018 11019!BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:02'! 11020testCreation 11021 "self run: #testCreation" 11022 "self debug: #testCreation" 11023 11024 | bag | 11025 bag := Bag new. 11026 self assert: (bag size) = 0. 11027 self assert: (bag isEmpty). 11028 11029! ! 11030 11031!BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:02'! 11032testCumulativeCounts 11033 "self run: #testCumulativeCounts" 11034 "self debug: #testCumulativeCounts" 11035 11036 | bag cumulativeCounts | 11037 bag := Bag new. 11038 bag add: '1' withOccurrences: 50. 11039 bag add: '2' withOccurrences: 40. 11040 bag add: '3' withOccurrences: 10. 11041 11042 cumulativeCounts := bag cumulativeCounts. 11043 11044 self assert: cumulativeCounts size = 3. 11045 self assert: cumulativeCounts first = (50 -> '1'). 11046 self assert: cumulativeCounts second = (90 -> '2'). 11047 self assert: cumulativeCounts third = (100 -> '3'). 11048! ! 11049 11050!BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:02'! 11051testEqual 11052 "(self run: #testEqual)" 11053 "(self debug: #testEqual)" 11054 | bag1 bag2 | 11055 bag1 := Bag new. 11056 bag2 := Bag new. 11057 self assert: bag1 = bag2. 11058 bag1 add: #a; 11059 add: #b. 11060 bag2 add: #a; 11061 add: #a. 11062 self deny: bag1 = bag2. 11063 self assert: bag1 = bag1. 11064 bag1 add: #a. 11065 bag2 add: #b. 11066 self assert: bag1 = bag2. 11067 bag1 add: #c. 11068 self deny: bag1 = bag2. 11069 bag2 add: #c. 11070 self assert: bag1 = bag2! ! 11071 11072!BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! 11073testRemove 11074 "self run: #testRemove" 11075 "self debug: #testRemove" 11076 11077 | bag item | 11078 item := 'test item'. 11079 bag := Bag new. 11080 11081 bag add: item. 11082 self assert: (bag size) = 1. 11083 bag remove: item. 11084 self assert: bag isEmpty. 11085 11086 bag add: item withOccurrences: 2. 11087 bag remove: item. 11088 bag remove: item. 11089 self assert: (bag size) = 0. 11090 11091 self should: [bag remove: item.] raise: Error.! ! 11092 11093!BagTest methodsFor: 'tests' stamp: 'nice 9/14/2009 21:05'! 11094testRemoveAll 11095 "Allows one to remove all elements of a collection" 11096 11097 | c1 c2 s2 | 11098 c1 := #(10 9 8 7 5 4 4 2) asBag. 11099 c2 := c1 copy. 11100 s2 := c2 size. 11101 11102 c1 removeAll. 11103 11104 self assert: c1 size = 0. 11105 self assert: c2 size = s2 description: 'the copy has not been modified'.! ! 11106 11107!BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! 11108testSortedCounts 11109 "self run: #testSortedCounts" 11110 "self debug: #testSortedCounts" 11111 11112 | bag sortedCounts| 11113 bag := Bag new. 11114 bag add: '1' withOccurrences: 10. 11115 bag add: '2' withOccurrences: 1. 11116 bag add: '3' withOccurrences: 5. 11117 11118 sortedCounts := bag sortedCounts. 11119 self assert: sortedCounts size = 3. 11120 11121 self assert: sortedCounts first = (10->'1'). 11122 self assert: sortedCounts second = (5->'3'). 11123 self assert: sortedCounts third = (1->'2'). ! ! 11124 11125!BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! 11126testSortedElements 11127 "self run: #testSortedElements" 11128 "self debug: #testSortedElements" 11129 11130 | bag sortedElements| 11131 bag := Bag new. 11132 bag add: '2' withOccurrences: 1. 11133 bag add: '1' withOccurrences: 10. 11134 bag add: '3' withOccurrences: 5. 11135 11136 sortedElements := bag sortedElements. 11137 11138 self assert: sortedElements size = 3. 11139 11140 self assert: sortedElements first = ('1'->10). 11141 self assert: sortedElements second = ('2'->1). 11142 self assert: sortedElements third = ('3'->5). 11143 ! ! 11144 11145 11146!BagTest methodsFor: 'tests - adding'! 11147testTAdd 11148 | added collection | 11149 collection :=self otherCollection . 11150 added := collection add: self element. 11151 11152 self assert: added == self element. "test for identiy because #add: has not reason to copy its parameter." 11153 self assert: (collection includes: self element) . 11154 self assert: (self collectionWithElement includes: self element). 11155 11156 ! ! 11157 11158!BagTest methodsFor: 'tests - adding'! 11159testTAddAll 11160 | added collection toBeAdded | 11161 collection := self collectionWithElement . 11162 toBeAdded := self otherCollection . 11163 added := collection addAll: toBeAdded . 11164 self assert: added == toBeAdded . "test for identiy because #addAll: has not reason to copy its parameter." 11165 self assert: (collection includesAllOf: toBeAdded )! ! 11166 11167!BagTest methodsFor: 'tests - adding'! 11168testTAddIfNotPresentWithElementAlreadyIn 11169 11170 | added oldSize collection element | 11171 collection := self collectionWithElement . 11172 oldSize := collection size. 11173 element := self element . 11174 self assert: (collection includes: element ). 11175 11176 added := collection addIfNotPresent: element . 11177 11178 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 11179 self assert: collection size = oldSize! ! 11180 11181!BagTest methodsFor: 'tests - adding'! 11182testTAddIfNotPresentWithNewElement 11183 11184 | added oldSize collection element | 11185 collection := self otherCollection . 11186 oldSize := collection size. 11187 element := self element . 11188 self deny: (collection includes: element ). 11189 11190 added := collection addIfNotPresent: element . 11191 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 11192 self assert: (collection size = (oldSize + 1)). 11193 11194 ! ! 11195 11196!BagTest methodsFor: 'tests - adding'! 11197testTAddTwice 11198 | added oldSize collection element | 11199 collection := self collectionWithElement . 11200 element := self element . 11201 oldSize := collection size. 11202 added := collection 11203 add: element ; 11204 add: element . 11205 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 11206 self assert: (collection includes: element ). 11207 self assert: collection size = (oldSize + 2)! ! 11208 11209!BagTest methodsFor: 'tests - adding'! 11210testTAddWithOccurences 11211 | added oldSize collection element | 11212 collection := self collectionWithElement . 11213 element := self element . 11214 oldSize := collection size. 11215 added := collection add: element withOccurrences: 5. 11216 11217 self assert: added == element. "test for identiy because #add: has not reason to copy its parameter." 11218 self assert: (collection includes: element). 11219 self assert: collection size = (oldSize + 5)! ! 11220 11221!BagTest methodsFor: 'tests - adding'! 11222testTWrite 11223 | added collection element | 11224 collection := self otherCollection . 11225 element := self element . 11226 added := collection write: element . 11227 11228 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 11229 self assert: (collection includes: element ) . 11230 self assert: (collection includes: element ). 11231 11232 ! ! 11233 11234!BagTest methodsFor: 'tests - adding'! 11235testTWriteTwice 11236 | added oldSize collection element | 11237 collection := self collectionWithElement . 11238 element := self element . 11239 oldSize := collection size. 11240 added := collection 11241 write: element ; 11242 write: element . 11243 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 11244 self assert: (collection includes: element ). 11245 self assert: collection size = (oldSize + 2)! ! 11246 11247 11248!BagTest methodsFor: 'tests - as set tests'! 11249testAsIdentitySetWithEqualsElements 11250 | result collection | 11251 collection := self withEqualElements . 11252 result := collection asIdentitySet. 11253 collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 11254 self assert: result class = IdentitySet.! ! 11255 11256!BagTest methodsFor: 'tests - as set tests'! 11257testAsSetWithEqualsElements 11258 | result | 11259 result := self withEqualElements asSet. 11260 self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 11261 self assert: result class = Set! ! 11262 11263 11264!BagTest methodsFor: 'tests - as sorted collection'! 11265testAsSortedArray 11266 | result collection | 11267 collection := self collectionWithSortableElements . 11268 result := collection asSortedArray. 11269 self assert: (result class includesBehavior: Array). 11270 self assert: result isSorted. 11271 self assert: result size = collection size! ! 11272 11273!BagTest methodsFor: 'tests - as sorted collection'! 11274testAsSortedCollection 11275 11276 | aCollection result | 11277 aCollection := self collectionWithSortableElements . 11278 result := aCollection asSortedCollection. 11279 11280 self assert: (result class includesBehavior: SortedCollection). 11281 result do: 11282 [ :each | 11283 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 11284 11285 self assert: result size = aCollection size.! ! 11286 11287!BagTest methodsFor: 'tests - as sorted collection'! 11288testAsSortedCollectionWithSortBlock 11289 | result tmp | 11290 result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. 11291 self assert: (result class includesBehavior: SortedCollection). 11292 result do: 11293 [ :each | 11294 self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 11295 self assert: result size = self collectionWithSortableElements size. 11296 tmp:=result at: 1. 11297 result do: [:each| self assert: tmp>=each. tmp:=each]. 11298 ! ! 11299 11300 11301!BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! 11302testAsCommaStringEmpty 11303 11304 self assert: self empty asCommaString = ''. 11305 self assert: self empty asCommaStringAnd = ''. 11306 11307! ! 11308 11309!BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! 11310testAsCommaStringMore 11311 11312 | result resultAnd index allElementsAsString tmp | 11313 result:= self nonEmpty asCommaString . 11314 resultAnd:= self nonEmpty asCommaStringAnd . 11315 tmp :=OrderedCollection new. 11316 self nonEmpty do: [ :each | tmp add: each asString]. 11317 11318 "verifying result :" 11319 index := 1. 11320 allElementsAsString := (result findBetweenSubStrs: ', ' ). 11321 allElementsAsString do: 11322 [:each | 11323 self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). 11324 ]. 11325 11326 "verifying esultAnd :" 11327 allElementsAsString:=(resultAnd findBetweenSubStrs: ', ' ). 11328 1 to: allElementsAsString size do: 11329 [:i | 11330 i<(allElementsAsString size-1 ) | i= allElementsAsString size 11331 ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. 11332 i=(allElementsAsString size-1) 11333 ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. 11334 ].! ! 11335 11336!BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! 11337testAsCommaStringOne 11338 11339 self nonEmpty1Element do: 11340 [:each | 11341 self assert: each asString =self nonEmpty1Element asCommaString. 11342 self assert: each asString=self nonEmpty1Element asCommaStringAnd.]. 11343 11344 ! ! 11345 11346!BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! 11347testAsStringOnDelimiterEmpty 11348 11349 | delim emptyStream | 11350 delim := ', '. 11351 emptyStream := ReadWriteStream on: ''. 11352 self empty asStringOn: emptyStream delimiter: delim. 11353 self assert: emptyStream contents = ''. 11354! ! 11355 11356!BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! 11357testAsStringOnDelimiterLastEmpty 11358 11359 | delim emptyStream | 11360 delim := ', '. 11361 emptyStream := ReadWriteStream on: ''. 11362 self empty asStringOn: emptyStream delimiter: delim last:'and'. 11363 self assert: emptyStream contents = ''. 11364! ! 11365 11366!BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! 11367testAsStringOnDelimiterLastMore 11368 11369 | delim multiItemStream result last allElementsAsString tmp | 11370 11371 delim := ', '. 11372 last := 'and'. 11373 result:=''. 11374 tmp := self nonEmpty collect: [:each | each asString]. 11375 multiItemStream := ReadWriteStream on:result. 11376 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 11377 11378 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 11379 1 to: allElementsAsString size do: 11380 [:i | 11381 i<(allElementsAsString size-1 ) | i= allElementsAsString size 11382 ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. 11383 i=(allElementsAsString size-1) 11384 ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. 11385 ]. 11386! ! 11387 11388!BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! 11389testAsStringOnDelimiterLastOne 11390 11391 | delim oneItemStream result | 11392 11393 delim := ', '. 11394 result:=''. 11395 oneItemStream := ReadWriteStream on: result. 11396 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 11397 oneItemStream do: 11398 [:each1 | 11399 self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] 11400 ]. 11401 11402 11403! ! 11404 11405!BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! 11406testAsStringOnDelimiterMore 11407 11408 | delim multiItemStream result allElementsAsString tmp | 11409 11410 11411 delim := ', '. 11412 result:=''. 11413 tmp:= self nonEmpty collect:[:each | each asString]. 11414 multiItemStream := ReadWriteStream on:result. 11415 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 11416 11417 allElementsAsString := (result findBetweenSubStrs: ', ' ). 11418 allElementsAsString do: 11419 [:each | 11420 self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). 11421 ].! ! 11422 11423!BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! 11424testAsStringOnDelimiterOne 11425 11426 | delim oneItemStream result | 11427 11428 delim := ', '. 11429 result:=''. 11430 oneItemStream := ReadWriteStream on: result. 11431 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 11432 oneItemStream do: 11433 [:each1 | 11434 self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] 11435 ]. 11436 11437! ! 11438 11439 11440!BagTest methodsFor: 'tests - concatenation'! 11441testConcatenation 11442 11443"| collection1 collection2 result | 11444collection1 := self firstCollection . 11445collection2 := self secondCollection . 11446result := collection1 , collection2. 11447 11448collection1 do:[ :each | self assert: (result includes: each)]. 11449collection2 do:[ :each | self assert: (result includes: each)]." 11450 11451| collection1 collection2 result | 11452collection1 := self firstCollection . 11453collection2 := self secondCollection . 11454result := collection1 , collection2. 11455 11456result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ]. 11457self assert: result size = (collection1 size + collection2 size)! ! 11458 11459!BagTest methodsFor: 'tests - concatenation'! 11460testConcatenationWithDuplicate 11461 11462 11463| collection1 collection2 result | 11464collection1 := self firstCollection . 11465collection2 := self firstCollection . 11466result := collection1 , collection2. 11467 11468result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ]. 11469self assert: result size = (collection1 size * 2)! ! 11470 11471!BagTest methodsFor: 'tests - concatenation'! 11472testConcatenationWithEmpty 11473 | result | 11474 result := self firstCollection , self empty. 11475 self assert: result = self firstCollection! ! 11476 11477 11478!BagTest methodsFor: 'tests - converting'! 11479assertNoDuplicates: aCollection whenConvertedTo: aClass 11480 | result | 11481 result := self collectionWithEqualElements asIdentitySet. 11482 self assert: (result class includesBehavior: IdentitySet). 11483 self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! 11484 11485!BagTest methodsFor: 'tests - converting'! 11486assertNonDuplicatedContents: aCollection whenConvertedTo: aClass 11487 | result | 11488 result := aCollection perform: ('as' , aClass name) asSymbol. 11489 self assert: (result class includesBehavior: aClass). 11490 result do: 11491 [ :each | 11492 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 11493 ^ result! ! 11494 11495!BagTest methodsFor: 'tests - converting'! 11496assertSameContents: aCollection whenConvertedTo: aClass 11497 | result | 11498 result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. 11499 self assert: result size = aCollection size! ! 11500 11501!BagTest methodsFor: 'tests - converting'! 11502testAsArray 11503 "self debug: #testAsArray3" 11504 self 11505 assertSameContents: self collectionWithoutEqualElements 11506 whenConvertedTo: Array! ! 11507 11508!BagTest methodsFor: 'tests - converting'! 11509testAsByteArray 11510| res | 11511self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 11512 self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . 11513 11514 res := true. 11515 self integerCollectionWithoutEqualElements 11516 detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] 11517 ifNone: [ res := false ]. 11518 self assert: res = false. 11519 11520 11521 self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! 11522 11523!BagTest methodsFor: 'tests - converting'! 11524testAsIdentitySet 11525 "test with a collection without equal elements :" 11526 self 11527 assertSameContents: self collectionWithoutEqualElements 11528 whenConvertedTo: IdentitySet. 11529! ! 11530 11531!BagTest methodsFor: 'tests - converting'! 11532testAsOrderedCollection 11533 11534 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! 11535 11536 11537!BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 11538testCopyEmptyWith 11539 "self debug: #testCopyWith" 11540 | res | 11541 res := self empty copyWith: self elementToAdd. 11542 self assert: res size = (self empty size + 1). 11543 self assert: (res includes: self elementToAdd)! ! 11544 11545!BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 11546testCopyEmptyWithout 11547 "self debug: #testCopyEmptyWithout" 11548 | res | 11549 res := self empty copyWithout: self elementToAdd. 11550 self assert: res size = self empty size. 11551 self deny: (res includes: self elementToAdd)! ! 11552 11553!BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 11554testCopyEmptyWithoutAll 11555 "self debug: #testCopyEmptyWithoutAll" 11556 | res | 11557 res := self empty copyWithoutAll: self collectionWithElementsToRemove. 11558 self assert: res size = self empty size. 11559 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! 11560 11561!BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 11562testCopyNonEmptyWith 11563 "self debug: #testCopyNonEmptyWith" 11564 | res | 11565 res := self nonEmpty copyWith: self elementToAdd. 11566 "here we do not test the size since for a non empty set we would get a problem. 11567 Then in addition copy is not about duplicate management. The element should 11568 be in at the end." 11569 self assert: (res includes: self elementToAdd). 11570 self nonEmpty do: [ :each | res includes: each ]! ! 11571 11572!BagTest methodsFor: 'tests - copy'! 11573testCopyNonEmptyWithout 11574 "self debug: #testCopyNonEmptyWithout" 11575 11576 | res anElementOfTheCollection | 11577 anElementOfTheCollection := self nonEmpty anyOne. 11578 res := (self nonEmpty copyWithout: anElementOfTheCollection). 11579 "here we do not test the size since for a non empty set we would get a problem. 11580 Then in addition copy is not about duplicate management. The element should 11581 be in at the end." 11582 self deny: (res includes: anElementOfTheCollection). 11583 self nonEmpty do: 11584 [:each | (each = anElementOfTheCollection) 11585 ifFalse: [self assert: (res includes: each)]]. 11586 11587! ! 11588 11589!BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 11590testCopyNonEmptyWithoutAll 11591 "self debug: #testCopyNonEmptyWithoutAll" 11592 | res | 11593 res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. 11594 "here we do not test the size since for a non empty set we would get a problem. 11595 Then in addition copy is not about duplicate management. The element should 11596 be in at the end." 11597 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]. 11598 self nonEmpty do: 11599 [ :each | 11600 (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! 11601 11602!BagTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! 11603testCopyNonEmptyWithoutAllNotIncluded 11604 ! ! 11605 11606!BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 11607testCopyNonEmptyWithoutNotIncluded 11608 "self debug: #testCopyNonEmptyWithoutNotIncluded" 11609 | res | 11610 res := self nonEmpty copyWithout: self elementToAdd. 11611 "here we do not test the size since for a non empty set we would get a problem. 11612 Then in addition copy is not about duplicate management. The element should 11613 be in at the end." 11614 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 11615 11616 11617!BagTest methodsFor: 'tests - copy - clone'! 11618testCopyCreatesNewObject 11619 "self debug: #testCopyCreatesNewObject" 11620 11621 | copy | 11622 copy := self nonEmpty copy. 11623 self deny: self nonEmpty == copy. 11624 ! ! 11625 11626!BagTest methodsFor: 'tests - copy - clone'! 11627testCopyEmpty 11628 "self debug: #testCopyEmpty" 11629 11630 | copy | 11631 copy := self empty copy. 11632 self assert: copy isEmpty.! ! 11633 11634!BagTest methodsFor: 'tests - copy - clone'! 11635testCopyNonEmpty 11636 "self debug: #testCopyNonEmpty" 11637 11638 | copy | 11639 copy := self nonEmpty copy. 11640 self deny: copy isEmpty. 11641 self assert: copy size = self nonEmpty size. 11642 self nonEmpty do: 11643 [:each | copy includes: each]! ! 11644 11645 11646!BagTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/17/2009 15:26'! 11647test0CopyTest 11648 self 11649 shouldnt: self empty 11650 raise: Error. 11651 self assert: self empty size = 0. 11652 self 11653 shouldnt: self nonEmpty 11654 raise: Error. 11655 self assert: (self nonEmpty size = 0) not. 11656 self 11657 shouldnt: self collectionWithElementsToRemove 11658 raise: Error. 11659 self assert: (self collectionWithElementsToRemove size = 0) not. 11660 self 11661 shouldnt: self elementToAdd 11662 raise: Error! ! 11663 11664!BagTest methodsFor: 'tests - fixture'! 11665test0FixtureAsStringCommaAndDelimiterTest 11666 11667 self shouldnt: [self nonEmpty] raise:Error . 11668 self deny: self nonEmpty isEmpty. 11669 11670 self shouldnt: [self empty] raise:Error . 11671 self assert: self empty isEmpty. 11672 11673 self shouldnt: [self nonEmpty1Element ] raise:Error . 11674 self assert: self nonEmpty1Element size=1.! ! 11675 11676!BagTest methodsFor: 'tests - fixture'! 11677test0FixtureCloneTest 11678 11679self shouldnt: [ self nonEmpty ] raise: Error. 11680self deny: self nonEmpty isEmpty. 11681 11682self shouldnt: [ self empty ] raise: Error. 11683self assert: self empty isEmpty. 11684 11685! ! 11686 11687!BagTest methodsFor: 'tests - fixture'! 11688test0FixtureConcatenationTest 11689 self shouldnt: [ self firstCollection ]raise: Error. 11690 self deny: self firstCollection isEmpty. 11691 11692 self shouldnt: [ self firstCollection ]raise: Error. 11693 self deny: self firstCollection isEmpty. 11694 11695 self shouldnt: [ self empty ]raise: Error. 11696 self assert: self empty isEmpty! ! 11697 11698!BagTest methodsFor: 'tests - fixture'! 11699test0FixtureConverAsSortedTest 11700 11701 self shouldnt: [self collectionWithSortableElements ] raise: Error. 11702 self deny: self collectionWithSortableElements isEmpty .! ! 11703 11704!BagTest methodsFor: 'tests - fixture'! 11705test0FixtureCreationWithTest 11706 11707self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. 11708self assert: self collectionMoreThan5Elements size >= 5.! ! 11709 11710!BagTest methodsFor: 'tests - fixture'! 11711test0FixtureIncludeTest 11712 | elementIn | 11713 self shouldnt: [ self nonEmpty ]raise: Error. 11714 self deny: self nonEmpty isEmpty. 11715 11716 self shouldnt: [ self elementNotIn ]raise: Error. 11717 11718 elementIn := true. 11719 self nonEmpty detect: 11720 [ :each | each = self elementNotIn ] 11721 ifNone: [ elementIn := false ]. 11722 self assert: elementIn = false. 11723 11724 self shouldnt: [ self anotherElementNotIn ]raise: Error. 11725 11726 elementIn := true. 11727 self nonEmpty detect: 11728 [ :each | each = self anotherElementNotIn ] 11729 ifNone: [ elementIn := false ]. 11730 self assert: elementIn = false. 11731 11732 self shouldnt: [ self empty ] raise: Error. 11733 self assert: self empty isEmpty. 11734 11735! ! 11736 11737!BagTest methodsFor: 'tests - fixture'! 11738test0FixtureIncludeWithIdentityTest 11739 | element | 11740 self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. 11741 element := self collectionWithCopyNonIdentical anyOne. 11742 self deny: element == element copy. 11743! ! 11744 11745!BagTest methodsFor: 'tests - fixture'! 11746test0FixtureOccurrencesForMultiplinessTest 11747 | cpt element collection | 11748 self shouldnt: [self collectionWithEqualElements ]raise: Error. 11749self shouldnt: [self collectionWithEqualElements ]raise: Error. 11750 11751self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 11752element := self elementTwiceInForOccurrences . 11753collection := self collectionWithEqualElements . 11754 11755cpt := 0 . 11756" testing with identity check ( == ) so that identy collections can use this trait : " 11757self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. 11758self assert: cpt = 2.! ! 11759 11760!BagTest methodsFor: 'tests - fixture'! 11761test0FixtureOccurrencesTest 11762 | tmp | 11763 self shouldnt: [self empty ]raise: Error. 11764 self assert: self empty isEmpty. 11765 11766 self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. 11767 self deny: self collectionWithoutEqualElements isEmpty. 11768 11769 tmp := OrderedCollection new. 11770 self collectionWithoutEqualElements do: [ 11771 :each | 11772 self deny: (tmp includes: each). 11773 tmp add: each. 11774 ]. 11775 11776 11777 self shouldnt: [ self elementNotInForOccurrences ] raise: Error. 11778 self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! 11779 11780!BagTest methodsFor: 'tests - fixture'! 11781test0FixturePrintTest 11782 11783 self shouldnt: [self nonEmpty ] raise: Error. 11784 self deny: self nonEmpty isEmpty.! ! 11785 11786!BagTest methodsFor: 'tests - fixture'! 11787test0FixtureRequirementsOfTAddTest 11788 self 11789 shouldnt: [ self collectionWithElement ] 11790 raise: Exception. 11791 self 11792 shouldnt: [ self otherCollection ] 11793 raise: Exception. 11794 self 11795 shouldnt: [ self element ] 11796 raise: Exception. 11797 self assert: (self collectionWithElement includes: self element). 11798 self deny: (self otherCollection includes: self element)! ! 11799 11800!BagTest methodsFor: 'tests - fixture'! 11801test0FixtureSetAritmeticTest 11802 self 11803 shouldnt: [ self collection ] 11804 raise: Error. 11805 self deny: self collection isEmpty. 11806 self 11807 shouldnt: [ self nonEmpty ] 11808 raise: Error. 11809 self deny: self nonEmpty isEmpty. 11810 self 11811 shouldnt: [ self anotherElementOrAssociationNotIn ] 11812 raise: Error. 11813 self collection isDictionary 11814 ifTrue: 11815 [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] 11816 ifFalse: 11817 [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. 11818 self 11819 shouldnt: [ self collectionClass ] 11820 raise: Error! ! 11821 11822!BagTest methodsFor: 'tests - fixture'! 11823test0FixtureTConvertAsSetForMultiplinessTest 11824 "a collection with equal elements:" 11825 | res | 11826 self shouldnt: [ self withEqualElements] raise: Error. 11827 11828 res := true. 11829 self withEqualElements 11830 detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] 11831 ifNone: [ res := false ]. 11832 self assert: res = true. 11833 11834! ! 11835 11836!BagTest methodsFor: 'tests - fixture'! 11837test0FixtureTConvertTest 11838 "a collection of number without equal elements:" 11839 | res | 11840 self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. 11841 11842 res := true. 11843 self collectionWithoutEqualElements 11844 detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] 11845 ifNone: [ res := false ]. 11846 self assert: res = false. 11847 11848 11849! ! 11850 11851!BagTest methodsFor: 'tests - fixture'! 11852test0FixtureTRemoveTest 11853 | duplicate | 11854 self shouldnt: [ self empty ]raise: Error. 11855 self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. 11856 self deny: self nonEmptyWithoutEqualElements isEmpty. 11857 duplicate := true. 11858 self nonEmptyWithoutEqualElements detect: 11859 [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] 11860 ifNone: [duplicate := false]. 11861 self assert: duplicate = false. 11862 11863 11864 self shouldnt: [ self elementNotIn ] raise: Error. 11865 self assert: self empty isEmpty. 11866 self deny: self nonEmptyWithoutEqualElements isEmpty. 11867 self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! 11868 11869!BagTest methodsFor: 'tests - fixture'! 11870test0TStructuralEqualityTest 11871 self shouldnt: [self empty] raise: Error. 11872 self shouldnt: [self nonEmpty] raise: Error. 11873 self assert: self empty isEmpty. 11874 self deny: self nonEmpty isEmpty.! ! 11875 11876 11877!BagTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:58'! 11878anotherElementNotIn 11879 ^ 42! ! 11880 11881!BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 11882elementNotInForOccurrences 11883 ^ 666! ! 11884 11885!BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! 11886testIdentityIncludes 11887 " test the comportement in presence of elements 'includes' but not 'identityIncludes' " 11888 " can not be used by collections that can't include elements for wich copy doesn't return another instance " 11889 | collection element | 11890 self 11891 shouldnt: [ self collectionWithCopyNonIdentical ] 11892 raise: Error. 11893 collection := self collectionWithCopyNonIdentical. 11894 element := collection anyOne copy. 11895 "self assert: (collection includes: element)." 11896 self deny: (collection identityIncludes: element)! ! 11897 11898!BagTest methodsFor: 'tests - includes'! 11899testIdentityIncludesNonSpecificComportement 11900 " test the same comportement than 'includes: ' " 11901 | collection | 11902 collection := self nonEmpty . 11903 11904 self deny: (collection identityIncludes: self elementNotIn ). 11905 self assert:(collection identityIncludes: collection anyOne) 11906! ! 11907 11908!BagTest methodsFor: 'tests - includes'! 11909testIncludesAllOfAllThere 11910 "self debug: #testIncludesAllOfAllThere'" 11911 self assert: (self empty includesAllOf: self empty). 11912 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 11913 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 11914 11915!BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 11916testIncludesAllOfNoneThere 11917 "self debug: #testIncludesAllOfNoneThere'" 11918 self deny: (self empty includesAllOf: self collection). 11919 self deny: (self nonEmpty includesAllOf: { 11920 (self elementNotIn). 11921 (self anotherElementNotIn) 11922 })! ! 11923 11924!BagTest methodsFor: 'tests - includes'! 11925testIncludesAnyOfAllThere 11926 "self debug: #testIncludesAnyOfAllThere'" 11927 self deny: (self nonEmpty includesAnyOf: self empty). 11928 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 11929 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 11930 11931!BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 11932testIncludesAnyOfNoneThere 11933 "self debug: #testIncludesAnyOfNoneThere'" 11934 self deny: (self nonEmpty includesAnyOf: self empty). 11935 self deny: (self nonEmpty includesAnyOf: { 11936 (self elementNotIn). 11937 (self anotherElementNotIn) 11938 })! ! 11939 11940!BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 11941testIncludesElementIsNotThere 11942 "self debug: #testIncludesElementIsNotThere" 11943 self deny: (self nonEmpty includes: self elementNotInForOccurrences). 11944 self assert: (self nonEmpty includes: self nonEmpty anyOne). 11945 self deny: (self empty includes: self elementNotInForOccurrences)! ! 11946 11947!BagTest methodsFor: 'tests - includes'! 11948testIncludesElementIsThere 11949 "self debug: #testIncludesElementIsThere" 11950 11951 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 11952 11953!BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/9/2009 10:44'! 11954testIncludesSubstringAnywhere 11955 "self debug: #testIncludesSubstringAnywher'" 11956 self assert: (self empty includesAllOf: self empty). 11957 self assert: (self nonEmpty includesAllOf: { (self nonEmpty anyOne) }). 11958 self assert: (self nonEmpty includesAllOf: self nonEmpty)! ! 11959 11960 11961!BagTest methodsFor: 'tests - occurrencesOf'! 11962testOccurrencesOfEmpty 11963 | result | 11964 result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). 11965 self assert: result = 0! ! 11966 11967!BagTest methodsFor: 'tests - occurrencesOf'! 11968testOccurrencesOfNotIn 11969 | result | 11970 result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. 11971 self assert: result = 0! ! 11972 11973 11974!BagTest methodsFor: 'tests - occurrencesOf for multipliness'! 11975testOccurrencesOfForMultipliness 11976 11977| collection element | 11978collection := self collectionWithEqualElements . 11979element := self elementTwiceInForOccurrences . 11980 11981self assert: (collection occurrencesOf: element ) = 2. ! ! 11982 11983 11984!BagTest methodsFor: 'tests - printing'! 11985testPrintElementsOn 11986 11987 | aStream result allElementsAsString tmp | 11988 result:=''. 11989 aStream:= ReadWriteStream on: result. 11990 tmp:= OrderedCollection new. 11991 self nonEmpty do: [:each | tmp add: each asString]. 11992 11993 self nonEmpty printElementsOn: aStream . 11994 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 11995 1 to: allElementsAsString size do: 11996 [:i | 11997 self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)). 11998 ].! ! 11999 12000!BagTest methodsFor: 'tests - printing'! 12001testPrintNameOn 12002 12003 | aStream result | 12004 result:=''. 12005 aStream:= ReadWriteStream on: result. 12006 12007 self nonEmpty printNameOn: aStream . 12008 Transcript show: result asString. 12009 self nonEmpty class name first isVowel 12010 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 12011 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 12012 12013!BagTest methodsFor: 'tests - printing'! 12014testPrintOn 12015 | aStream result allElementsAsString tmp | 12016 result:=''. 12017 aStream:= ReadWriteStream on: result. 12018 tmp:= OrderedCollection new. 12019 self nonEmpty do: [:each | tmp add: each asString]. 12020 12021 self nonEmpty printOn: aStream . 12022 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 12023 1 to: allElementsAsString size do: 12024 [:i | 12025 i=1 12026 ifTrue:[ 12027 self accessCollection class name first isVowel 12028 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 12029 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 12030 i=2 12031 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 12032 i>2 12033 ifTrue:[self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)).]. 12034 ].! ! 12035 12036!BagTest methodsFor: 'tests - printing'! 12037testPrintOnDelimiter 12038 | aStream result allElementsAsString tmp | 12039 result:=''. 12040 aStream:= ReadWriteStream on: result. 12041 tmp:= OrderedCollection new. 12042 self nonEmpty do: [:each | tmp add: each asString]. 12043 12044 12045 12046 self nonEmpty printOn: aStream delimiter: ', ' . 12047 12048 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 12049 1 to: allElementsAsString size do: 12050 [:i | 12051 self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)) 12052 ].! ! 12053 12054!BagTest methodsFor: 'tests - printing'! 12055testPrintOnDelimiterLast 12056 12057 | aStream result allElementsAsString tmp | 12058 result:=''. 12059 aStream:= ReadWriteStream on: result. 12060 tmp:= OrderedCollection new. 12061 self nonEmpty do: [:each | tmp add: each asString]. 12062 12063 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 12064 12065 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 12066 1 to: allElementsAsString size do: 12067 [:i | 12068 i<(allElementsAsString size-1 ) 12069 ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. 12070 i=(allElementsAsString size-1) 12071 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 12072 i=(allElementsAsString size) 12073 ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. 12074 ].! ! 12075 12076!BagTest methodsFor: 'tests - printing'! 12077testStoreOn 12078" for the moment work only for collection that include simple elements such that Integer" 12079 12080"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 12081string := ''. 12082str := ReadWriteStream on: string. 12083elementsAsStringExpected := OrderedCollection new. 12084elementsAsStringObtained := OrderedCollection new. 12085self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 12086 12087self nonEmpty storeOn: str. 12088result := str contents . 12089cuttedResult := ( result findBetweenSubStrs: ';' ). 12090 12091index := 1. 12092 12093cuttedResult do: 12094 [ :each | 12095 index = 1 12096 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 12097 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 12098 elementsAsStringObtained add: tmp. 12099 index := index + 1. ] 12100 ifFalse: [ 12101 index < cuttedResult size 12102 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 12103 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 12104 elementsAsStringObtained add: tmp. 12105 index := index + 1.] 12106 ifFalse: [self assert: ( each = ' yourself)' ) ]. 12107 ] 12108 12109 ]. 12110 12111 12112 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 12113 12114! ! 12115 12116 12117!BagTest methodsFor: 'tests - remove'! 12118testRemoveAllError 12119 "self debug: #testRemoveElementThatExists" 12120 | el res subCollection | 12121 el := self elementNotIn. 12122 subCollection := self nonEmptyWithoutEqualElements copyWith: el. 12123 self 12124 should: [ res := self nonEmptyWithoutEqualElements removeAll: subCollection ] 12125 raise: Error! ! 12126 12127!BagTest methodsFor: 'tests - remove'! 12128testRemoveAllFoundIn 12129 "self debug: #testRemoveElementThatExists" 12130 | el res subCollection | 12131 el := self nonEmptyWithoutEqualElements anyOne. 12132 subCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. 12133 self 12134 shouldnt: 12135 [ res := self nonEmptyWithoutEqualElements removeAllFoundIn: subCollection ] 12136 raise: Error. 12137 self assert: self nonEmptyWithoutEqualElements size = 1. 12138 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 12139 12140!BagTest methodsFor: 'tests - remove'! 12141testRemoveAllSuchThat 12142 "self debug: #testRemoveElementThatExists" 12143 | el subCollection | 12144 el := self nonEmptyWithoutEqualElements anyOne. 12145 subCollection := self nonEmptyWithoutEqualElements copyWithout: el. 12146 self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | subCollection includes: each ]. 12147 self assert: self nonEmptyWithoutEqualElements size = 1. 12148 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 12149 12150!BagTest methodsFor: 'tests - remove'! 12151testRemoveElementFromEmpty 12152 "self debug: #testRemoveElementFromEmpty" 12153 self 12154 should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] 12155 raise: Error! ! 12156 12157!BagTest methodsFor: 'tests - remove'! 12158testRemoveElementReallyRemovesElement 12159 "self debug: #testRemoveElementReallyRemovesElement" 12160 | size | 12161 size := self nonEmptyWithoutEqualElements size. 12162 self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. 12163 self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! 12164 12165!BagTest methodsFor: 'tests - remove'! 12166testRemoveElementThatExists 12167 "self debug: #testRemoveElementThatExists" 12168 | el res | 12169 el := self nonEmptyWithoutEqualElements anyOne. 12170 self 12171 shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] 12172 raise: Error. 12173 self assert: res == el! ! 12174 12175!BagTest methodsFor: 'tests - remove'! 12176testRemoveIfAbsent 12177 "self debug: #testRemoveElementThatExists" 12178 | el res | 12179 el := self elementNotIn. 12180 self 12181 shouldnt: 12182 [ res := self nonEmptyWithoutEqualElements 12183 remove: el 12184 ifAbsent: [ 33 ] ] 12185 raise: Error. 12186 self assert: res == 33! ! 12187 12188 12189!BagTest methodsFor: 'tests - set arithmetic'! 12190containsAll: union of: one andOf: another 12191 12192 self assert: (one allSatisfy: [:each | union includes: each]). 12193 self assert: (another allSatisfy: [:each | union includes: each])! ! 12194 12195!BagTest methodsFor: 'tests - set arithmetic'! 12196numberOfSimilarElementsInIntersection 12197 ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! 12198 12199!BagTest methodsFor: 'tests - set arithmetic'! 12200testDifference 12201 "Answer the set theoretic difference of two collections." 12202 "self debug: #testDifference" 12203 12204 self assert: (self collection difference: self collection) isEmpty. 12205 self assert: (self empty difference: self collection) isEmpty. 12206 self assert: (self collection difference: self empty) = self collection 12207! ! 12208 12209!BagTest methodsFor: 'tests - set arithmetic'! 12210testDifferenceWithNonNullIntersection 12211 "Answer the set theoretic difference of two collections." 12212 "self debug: #testDifferenceWithNonNullIntersection" 12213 " #(1 2 3) difference: #(2 4) 12214 -> #(1 3)" 12215 | res overlapping | 12216 overlapping := self collectionClass 12217 with: self anotherElementOrAssociationNotIn 12218 with: self anotherElementOrAssociationIn. 12219 res := self collection difference: overlapping. 12220 self deny: (res includes: self anotherElementOrAssociationIn). 12221 overlapping do: [ :each | self deny: (res includes: each) ]! ! 12222 12223!BagTest methodsFor: 'tests - set arithmetic'! 12224testDifferenceWithSeparateCollection 12225 "Answer the set theoretic difference of two collections." 12226 "self debug: #testDifferenceWithSeparateCollection" 12227 | res separateCol | 12228 separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. 12229 res := self collection difference: separateCol. 12230 self deny: (res includes: self anotherElementOrAssociationNotIn). 12231 self assert: res = self collection. 12232 res := separateCol difference: self collection. 12233 self deny: (res includes: self collection anyOne). 12234 self assert: res = separateCol! ! 12235 12236!BagTest methodsFor: 'tests - set arithmetic'! 12237testIntersectionBasic 12238 "self debug: #testIntersectionBasic" 12239 | inter | 12240 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 12241 self deny: inter isEmpty. 12242 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 12243 12244!BagTest methodsFor: 'tests - set arithmetic'! 12245testIntersectionEmpty 12246 "self debug: #testIntersectionEmpty" 12247 12248 | inter | 12249 inter := self empty intersection: self empty. 12250 self assert: inter isEmpty. 12251 inter := self empty intersection: self collection . 12252 self assert: inter = self empty. 12253 ! ! 12254 12255!BagTest methodsFor: 'tests - set arithmetic'! 12256testIntersectionItself 12257 "self debug: #testIntersectionItself" 12258 12259 self assert: (self collection intersection: self collection) = self collection. 12260 ! ! 12261 12262!BagTest methodsFor: 'tests - set arithmetic'! 12263testIntersectionTwoSimilarElementsInIntersection 12264 "self debug: #testIntersectionBasic" 12265 | inter | 12266 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 12267 self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. 12268 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 12269 12270!BagTest methodsFor: 'tests - set arithmetic'! 12271testUnion 12272 "self debug: #testUnionOfEmpties" 12273 12274 | union | 12275 union := self empty union: self nonEmpty. 12276 self containsAll: union of: self empty andOf: self nonEmpty. 12277 union := self nonEmpty union: self empty. 12278 self containsAll: union of: self empty andOf: self nonEmpty. 12279 union := self collection union: self nonEmpty. 12280 self containsAll: union of: self collection andOf: self nonEmpty.! ! 12281 12282!BagTest methodsFor: 'tests - set arithmetic'! 12283testUnionOfEmpties 12284 "self debug: #testUnionOfEmpties" 12285 12286 self assert: (self empty union: self empty) isEmpty. 12287 12288 ! ! 12289 12290"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 12291 12292BagTest class 12293 uses: TAddTest classTrait + TCloneTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TConvertTest classTrait + TAsStringCommaAndDelimiterTest classTrait + TRemoveForMultiplenessTest classTrait + TPrintTest classTrait + TConvertAsSortedTest classTrait + TIncludesWithIdentityCheckTest classTrait + TConvertAsSetForMultiplinessTest classTrait + TConcatenationTest classTrait + TStructuralEqualityTest classTrait + TCreationWithTest classTrait + TOccurrencesForMultiplinessTest classTrait 12294 instanceVariableNames: ''! 12295Object subclass: #BalloonBezierSimulation 12296 instanceVariableNames: 'start end via lastX lastY fwDx fwDy fwDDx fwDDy maxSteps' 12297 classVariableNames: 'HeightSubdivisions LineConversions MonotonSubdivisions OverflowSubdivisions' 12298 poolDictionaries: '' 12299 category: 'Balloon-Simulation'! 12300!BalloonBezierSimulation commentStamp: '<historical>' prior: 0! 12301This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! 12302 12303 12304!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! 12305end 12306 ^end! ! 12307 12308!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! 12309end: aPoint 12310 end := aPoint! ! 12311 12312!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 01:57'! 12313inTangent 12314 "Return the tangent at the start point" 12315 ^via - start! ! 12316 12317!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! 12318initialX 12319 ^start y <= end y 12320 ifTrue:[start x] 12321 ifFalse:[end x]! ! 12322 12323!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! 12324initialY 12325 ^start y <= end y 12326 ifTrue:[start y] 12327 ifFalse:[end y]! ! 12328 12329!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! 12330initialZ 12331 ^0 "Assume no depth given"! ! 12332 12333!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 01:57'! 12334outTangent 12335 "Return the tangent at the end point" 12336 ^end - via! ! 12337 12338!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! 12339start 12340 ^start! ! 12341 12342!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! 12343start: aPoint 12344 start := aPoint! ! 12345 12346!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! 12347via 12348 ^via! ! 12349 12350!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! 12351via: aPoint 12352 via := aPoint! ! 12353 12354 12355!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:46'! 12356computeInitialStateFrom: source with: transformation 12357 "Compute the initial state in the receiver." 12358 start := (transformation localPointToGlobal: source start) asIntegerPoint. 12359 end := (transformation localPointToGlobal: source end) asIntegerPoint. 12360 via := (transformation localPointToGlobal: source via) asIntegerPoint.! ! 12361 12362!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 02:39'! 12363computeSplitAt: t 12364 "Split the receiver at the parametric value t" 12365 | left right newVia1 newVia2 newPoint | 12366 left := self clone. 12367 right := self clone. 12368 "Compute new intermediate points" 12369 newVia1 := (via - start) * t + start. 12370 newVia2 := (end - via) * t + via. 12371 "Compute new point on curve" 12372 newPoint := ((newVia1 - newVia2) * t + newVia2) asIntegerPoint. 12373 left via: newVia1 asIntegerPoint. 12374 left end: newPoint. 12375 right start: newPoint. 12376 right via: newVia2 asIntegerPoint. 12377 ^Array with: left with: right! ! 12378 12379!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 01:34'! 12380floatStepToFirstScanLineAt: yValue in: edgeTableEntry 12381 "Float version of forward differencing" 12382 | startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 12383 steps scaledStepSize squaredStepSize | 12384 (end y) >= (start y) ifTrue:[ 12385 startX := start x. endX := end x. 12386 startY := start y. endY := end y. 12387 ] ifFalse:[ 12388 startX := end x. endX := start x. 12389 startY := end y. endY := start y. 12390 ]. 12391 12392 deltaY := endY - startY. 12393 12394 "Quickly check if the line is visible at all" 12395 (yValue >= endY or:[deltaY = 0]) ifTrue:[ 12396 ^edgeTableEntry lines: 0]. 12397 12398 fwX1 := (startX + endX - (2 * via x)) asFloat. 12399 fwX2 := (via x - startX * 2) asFloat. 12400 fwY1 := (startY + endY - (2 * via y)) asFloat. 12401 fwY2 := ((via y - startY) * 2) asFloat. 12402 steps := deltaY asInteger * 2. 12403 scaledStepSize := 1.0 / steps asFloat. 12404 squaredStepSize := scaledStepSize * scaledStepSize. 12405 fwDx := fwX2 * scaledStepSize. 12406 fwDDx := 2.0 * fwX1 * squaredStepSize. 12407 fwDy := fwY2 * scaledStepSize. 12408 fwDDy := 2.0 * fwY1 * squaredStepSize. 12409 fwDx := fwDx + (fwDDx * 0.5). 12410 fwDy := fwDy + (fwDDy * 0.5). 12411 12412 lastX := startX asFloat. 12413 lastY := startY asFloat. 12414 12415 "self xDirection: xDir. 12416 self yDirection: yDir." 12417 edgeTableEntry xValue: startX. 12418 edgeTableEntry yValue: startY. 12419 edgeTableEntry zValue: 0. 12420 edgeTableEntry lines: deltaY. 12421 12422 "If not at first scan line then step down to yValue" 12423 yValue = startY ifFalse:[ 12424 self stepToNextScanLineAt: yValue in: edgeTableEntry. 12425 "And adjust remainingLines" 12426 edgeTableEntry lines: deltaY - (yValue - startY). 12427 ].! ! 12428 12429!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 02:45'! 12430floatStepToNextScanLineAt: yValue in: edgeTableEntry 12431 "Float version of forward differencing" 12432 [yValue asFloat > lastY] whileTrue:[ 12433 (fwDx < -50.0 or:[fwDx > 50.0]) ifTrue:[self halt]. 12434 (fwDy < -50.0 or:[fwDy > 50.0]) ifTrue:[self halt]. 12435 (fwDDx < -50.0 or:[fwDDx > 50.0]) ifTrue:[self halt]. 12436 (fwDDy < -50.0 or:[fwDDy > 50.0]) ifTrue:[self halt]. 12437 lastX := lastX + fwDx. 12438 lastY := lastY + fwDy. 12439 fwDx := fwDx + fwDDx. 12440 fwDy := fwDy + fwDDy. 12441 ]. 12442 edgeTableEntry xValue: lastX asInteger. 12443 edgeTableEntry zValue: 0.! ! 12444 12445!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 16:23'! 12446intStepToFirstScanLineAt: yValue in: edgeTableEntry 12447 "Scaled integer version of forward differencing" 12448 | startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 12449 scaledStepSize squaredStepSize | 12450 (end y) >= (start y) ifTrue:[ 12451 startX := start x. endX := end x. 12452 startY := start y. endY := end y. 12453 ] ifFalse:[ 12454 startX := end x. endX := start x. 12455 startY := end y. endY := start y. 12456 ]. 12457 12458 deltaY := endY - startY. 12459 12460 "Quickly check if the line is visible at all" 12461 (yValue >= endY or:[deltaY = 0]) ifTrue:[ 12462 ^edgeTableEntry lines: 0]. 12463 12464 fwX1 := (startX + endX - (2 * via x)). 12465 fwX2 := (via x - startX * 2). 12466 fwY1 := (startY + endY - (2 * via y)). 12467 fwY2 := ((via y - startY) * 2). 12468 maxSteps := deltaY asInteger * 2. 12469 scaledStepSize := 16r1000000 // maxSteps. 12470 "@@: Okay, we need some fancy 64bit multiplication here" 12471 squaredStepSize := self absoluteSquared8Dot24: scaledStepSize. 12472 squaredStepSize = ((scaledStepSize * scaledStepSize) bitShift: -24) 12473 ifFalse:[self error:'Bad computation']. 12474 fwDx := fwX2 * scaledStepSize. 12475 fwDDx := 2 * fwX1 * squaredStepSize. 12476 fwDy := fwY2 * scaledStepSize. 12477 fwDDy := 2 * fwY1 * squaredStepSize. 12478 fwDx := fwDx + (fwDDx // 2). 12479 fwDy := fwDy + (fwDDy // 2). 12480 12481 self validateIntegerRange. 12482 12483 lastX := startX * 256. 12484 lastY := startY * 256. 12485 12486 edgeTableEntry xValue: startX. 12487 edgeTableEntry yValue: startY. 12488 edgeTableEntry zValue: 0. 12489 edgeTableEntry lines: deltaY. 12490 12491 "If not at first scan line then step down to yValue" 12492 yValue = startY ifFalse:[ 12493 self stepToNextScanLineAt: yValue in: edgeTableEntry. 12494 "And adjust remainingLines" 12495 edgeTableEntry lines: deltaY - (yValue - startY). 12496 ].! ! 12497 12498!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 04:02'! 12499intStepToNextScanLineAt: yValue in: edgeTableEntry 12500 "Scaled integer version of forward differencing" 12501 [maxSteps >= 0 and:[yValue * 256 > lastY]] whileTrue:[ 12502 self validateIntegerRange. 12503 lastX := lastX + ((fwDx + 16r8000) // 16r10000). 12504 lastY := lastY + ((fwDy + 16r8000) // 16r10000). 12505 fwDx := fwDx + fwDDx. 12506 fwDy := fwDy + fwDDy. 12507 maxSteps := maxSteps - 1. 12508 ]. 12509 edgeTableEntry xValue: lastX // 256. 12510 edgeTableEntry zValue: 0.! ! 12511 12512!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/29/1998 22:14'! 12513isMonoton 12514 "Return true if the receiver is monoton along the y-axis, 12515 e.g., check if the tangents have the same sign" 12516 ^(via y - start y) * (end y - via y) >= 0! ! 12517 12518!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/31/1998 16:36'! 12519stepToFirstScanLineAt: yValue in: edgeTableEntry 12520 "Compute the initial x value for the scan line at yValue" 12521 ^self intStepToFirstScanLineAt: yValue in: edgeTableEntry! ! 12522 12523!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 03:40'! 12524stepToNextScanLineAt: yValue in: edgeTableEntry 12525 "Compute the next x value for the scan line at yValue. 12526 This message is sent during incremental updates. 12527 The yValue parameter is passed in here for edges 12528 that have more complicated computations," 12529 ^self intStepToNextScanLineAt: yValue in: edgeTableEntry! ! 12530 12531!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 11/1/1998 00:31'! 12532subdivide 12533 "Subdivide the receiver" 12534 | dy dx | 12535 "Test 1: If the bezier curve is not monoton in Y, we need a subdivision" 12536 self isMonoton ifFalse:[ 12537 MonotonSubdivisions := MonotonSubdivisions + 1. 12538 ^self subdivideToBeMonoton]. 12539 12540 "Test 2: If the receiver is horizontal, don't do anything" 12541 (end y = start y) ifTrue:[^nil]. 12542 12543 "Test 3: If the receiver can be represented as a straight line, 12544 make a line from the receiver and declare it invalid" 12545 ((end - start) crossProduct: (via - start)) = 0 ifTrue:[ 12546 LineConversions := LineConversions + 1. 12547 ^self subdivideToBeLine]. 12548 12549 "Test 4: If the height of the curve exceeds 256 pixels, subdivide 12550 (forward differencing is numerically not very stable)" 12551 dy := end y - start y. 12552 dy < 0 ifTrue:[dy := dy negated]. 12553 (dy > 255) ifTrue:[ 12554 HeightSubdivisions := HeightSubdivisions + 1. 12555 ^self subdivideAt: 0.5]. 12556 12557 "Test 5: Check if the incremental values could possibly overflow the scaled integer range" 12558 dx := end x - start x. 12559 dx < 0 ifTrue:[dx := dx negated]. 12560 dy * 32 < dx ifTrue:[ 12561 OverflowSubdivisions := OverflowSubdivisions + 1. 12562 ^self subdivideAt: 0.5]. 12563 12564 ^nil! ! 12565 12566!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 22:13'! 12567subdivideAt: parameter 12568 "Subdivide the receiver at the given parameter" 12569 | both | 12570 (parameter <= 0.0 or:[parameter >= 1.0]) ifTrue:[self halt]. 12571 both := self computeSplitAt: parameter. 12572 "Transcript cr. 12573 self quickPrint: self. 12574 Transcript space. 12575 self quickPrint: both first. 12576 Transcript space. 12577 self quickPrint: both last. 12578 Transcript endEntry." 12579 self via: both first via. 12580 self end: both first end. 12581 ^both last! ! 12582 12583!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 11/11/1998 22:15'! 12584subdivideToBeLine 12585 "Not a true subdivision. 12586 Just return a line representing the receiver and fake me to be of zero height" 12587 | line | 12588 line := BalloonLineSimulation new. 12589 line start: start. 12590 line end: end. 12591 "Make me invalid" 12592 end := start. 12593 via := start. 12594 ^line! ! 12595 12596!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 02:24'! 12597subdivideToBeMonoton 12598 "Subdivide the receiver at it's extreme point" 12599 | v1 v2 t other | 12600 v1 := (via - start). 12601 v2 := (end - via). 12602 t := (v1 y / (v2 y - v1 y)) negated asFloat. 12603 other := self subdivideAt: t. 12604 self isMonoton ifFalse:[self halt]. 12605 other isMonoton ifFalse:[self halt]. 12606 ^other! ! 12607 12608 12609!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 16:37'! 12610absoluteSquared8Dot24: value 12611 "Compute the squared value of a 8.24 number with 0.0 <= value < 1.0, 12612 e.g., compute (value * value) bitShift: -24" 12613 | halfWord1 halfWord2 result | 12614 (value >= 0 and:[value < 16r1000000]) ifFalse:[^self error:'Value out of range']. 12615 halfWord1 := value bitAnd: 16rFFFF. 12616 halfWord2 := (value bitShift: -16) bitAnd: 255. 12617 12618 result := (halfWord1 * halfWord1) bitShift: -16. "We don't need the lower 16bits at all" 12619 result := result + ((halfWord1 * halfWord2) * 2). 12620 result := result + ((halfWord2 * halfWord2) bitShift: 16). 12621 "word1 := halfWord1 * halfWord1. 12622 word2 := (halfWord2 * halfWord1) + (word1 bitShift: -16). 12623 word1 := word1 bitAnd: 16rFFFF. 12624 word2 := word2 + (halfWord1 * halfWord2). 12625 word2 := word2 + ((halfWord2 * halfWord2) bitShift: 16)." 12626 12627 ^result bitShift: -8! ! 12628 12629!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'! 12630debugDraw 12631 | entry minY maxY lX lY canvas | 12632 entry := BalloonEdgeData new. 12633 canvas := Display getCanvas. 12634 minY := (start y min: end y) min: via y. 12635 maxY := (start y max: end y) max: via y. 12636 entry yValue: minY. 12637 self stepToFirstScanLineAt: minY in: entry. 12638 lX := entry xValue. 12639 lY := entry yValue. 12640 minY+1 to: maxY do:[:y| 12641 self stepToNextScanLineAt: y in: entry. 12642 canvas line: lX@lY to: entry xValue @ y width: 2 color: Color black. 12643 lX := entry xValue. 12644 lY := y. 12645 ]. 12646! ! 12647 12648!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'! 12649debugDraw2 12650 | canvas last max t next | 12651 canvas := Display getCanvas. 12652 max := 100. 12653 last := nil. 12654 0 to: max do:[:i| 12655 t := i asFloat / max asFloat. 12656 next := self valueAt: t. 12657 last ifNotNil:[ 12658 canvas line: last to: next rounded width: 2 color: Color blue. 12659 ]. 12660 last := next rounded. 12661 ].! ! 12662 12663!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'! 12664debugDrawWide: n 12665 | entry minY maxY canvas curve p1 p2 entry2 y | 12666 curve := self class new. 12667 curve start: start + (0@n). 12668 curve via: via + (0@n). 12669 curve end: end + (0@n). 12670 entry := BalloonEdgeData new. 12671 entry2 := BalloonEdgeData new. 12672 canvas := Display getCanvas. 12673 minY := (start y min: end y) min: via y. 12674 maxY := (start y max: end y) max: via y. 12675 entry yValue: minY. 12676 entry2 yValue: minY + n. 12677 self stepToFirstScanLineAt: minY in: entry. 12678 curve stepToFirstScanLineAt: minY+n in: entry2. 12679 y := minY. 12680 1 to: n do:[:i| 12681 y := y + 1. 12682 self stepToNextScanLineAt: y in: entry. 12683 p1 := entry xValue @ y. 12684 canvas line: p1 to: p1 + (n@0) width: 1 color: Color black. 12685 ]. 12686 [y < maxY] whileTrue:[ 12687 y := y + 1. 12688 self stepToNextScanLineAt: y in: entry. 12689 p2 := (entry xValue + n) @ y. 12690 curve stepToNextScanLineAt: y in: entry2. 12691 p1 := entry2 xValue @ y. 12692 canvas line: p1 to: p2 width: 1 color: Color black. 12693 ]. 12694! ! 12695 12696!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 00:35'! 12697printOn: aStream 12698 aStream 12699 nextPutAll: self class name; 12700 nextPut:$(; 12701 print: start; 12702 nextPutAll:' - '; 12703 print: via; 12704 nextPutAll:' - '; 12705 print: end; 12706 nextPut:$)! ! 12707 12708!BalloonBezierSimulation methodsFor: 'private' stamp: 'MPW 1/1/1901 21:55'! 12709printOnStream: aStream 12710 aStream 12711 print: self class name; 12712 print:'('; 12713 write: start; 12714 print:' - '; 12715 write: via; 12716 print:' - '; 12717 write: end; 12718 print:')'.! ! 12719 12720!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 21:56'! 12721quickPrint: curve 12722 Transcript nextPut:$(; 12723 print: curve start; 12724 space; 12725 print: curve via; 12726 space; 12727 print: curve end; 12728 nextPut:$).! ! 12729 12730!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 22:13'! 12731quickPrint: curve first: aBool 12732 aBool ifTrue:[Transcript cr]. 12733 Transcript nextPut:$(; 12734 print: curve start; 12735 space; 12736 print: curve via; 12737 space; 12738 print: curve end; 12739 nextPut:$). 12740 Transcript endEntry.! ! 12741 12742!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:53'! 12743stepToFirst 12744 | startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 12745 steps scaledStepSize squaredStepSize | 12746 (end y) >= (start y) ifTrue:[ 12747 startX := start x. endX := end x. 12748 startY := start y. endY := end y. 12749 ] ifFalse:[ 12750 startX := end x. endX := start x. 12751 startY := end y. endY := start y. 12752 ]. 12753 12754 deltaY := endY - startY. 12755 12756 "Quickly check if the line is visible at all" 12757 (deltaY = 0) ifTrue:[^self]. 12758 12759 fwX1 := (startX + endX - (2 * via x)) asFloat. 12760 fwX2 := (via x - startX * 2) asFloat. 12761 fwY1 := (startY + endY - (2 * via y)) asFloat. 12762 fwY2 := ((via y - startY) * 2) asFloat. 12763 steps := deltaY asInteger * 2. 12764 scaledStepSize := 1.0 / steps asFloat. 12765 squaredStepSize := scaledStepSize * scaledStepSize. 12766 fwDx := fwX2 * scaledStepSize. 12767 fwDDx := 2.0 * fwX1 * squaredStepSize. 12768 fwDy := fwY2 * scaledStepSize. 12769 fwDDy := 2.0 * fwY1 * squaredStepSize. 12770 fwDx := fwDx + (fwDDx * 0.5). 12771 fwDy := fwDy + (fwDDy * 0.5). 12772 12773 lastX := startX asFloat. 12774 lastY := startY asFloat. 12775! ! 12776 12777!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:50'! 12778stepToFirstInt 12779 "Scaled integer version of forward differencing" 12780 | startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 12781 scaledStepSize squaredStepSize | 12782 self halt. 12783 (end y) >= (start y) ifTrue:[ 12784 startX := start x. endX := end x. 12785 startY := start y. endY := end y. 12786 ] ifFalse:[ 12787 startX := end x. endX := start x. 12788 startY := end y. endY := start y. 12789 ]. 12790 12791 deltaY := endY - startY. 12792 12793 "Quickly check if the line is visible at all" 12794 (deltaY = 0) ifTrue:[^nil]. 12795 12796 fwX1 := (startX + endX - (2 * via x)). 12797 fwX2 := (via x - startX * 2). 12798 fwY1 := (startY + endY - (2 * via y)). 12799 fwY2 := ((via y - startY) * 2). 12800 maxSteps := deltaY asInteger * 2. 12801 scaledStepSize := 16r1000000 // maxSteps. 12802 "@@: Okay, we need some fancy 64bit multiplication here" 12803 squaredStepSize := (scaledStepSize * scaledStepSize) bitShift: -24. 12804 fwDx := fwX2 * scaledStepSize. 12805 fwDDx := 2 * fwX1 * squaredStepSize. 12806 fwDy := fwY2 * scaledStepSize. 12807 fwDDy := 2 * fwY1 * squaredStepSize. 12808 fwDx := fwDx + (fwDDx // 2). 12809 fwDy := fwDy + (fwDDy // 2). 12810 12811 self validateIntegerRange. 12812 12813 lastX := startX * 256. 12814 lastY := startY * 256. 12815! ! 12816 12817!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 00:26'! 12818stepToNext 12819 lastX := lastX + fwDx. 12820 lastY := lastY + fwDy. 12821 fwDx := fwDx + fwDDx. 12822 fwDy := fwDy + fwDDy.! ! 12823 12824!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 04:01'! 12825stepToNextInt 12826 "Scaled integer version of forward differencing" 12827 self halt. 12828 (maxSteps >= 0) ifTrue:[ 12829 self validateIntegerRange. 12830 lastX := lastX + ((fwDx + 16r8000) // 16r10000). 12831 lastY := lastY + ((fwDy + 16r8000) // 16r10000). 12832 fwDx := fwDx + fwDDx. 12833 fwDy := fwDy + fwDDy. 12834 maxSteps := maxSteps - 1. 12835 ].! ! 12836 12837!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:27'! 12838validateIntegerRange 12839 fwDx class == SmallInteger ifFalse:[self halt]. 12840 fwDy class == SmallInteger ifFalse:[self halt]. 12841 fwDDx class == SmallInteger ifFalse:[self halt]. 12842 fwDDy class == SmallInteger ifFalse:[self halt]. 12843! ! 12844 12845!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/29/1998 21:26'! 12846valueAt: parameter 12847 "Return the point at the value parameter: 12848 p(t) = (1-t)^2 * p1 + 12849 2*t*(1-t) * p2 + 12850 t^2 * p3. 12851 " 12852 | t1 t2 t3 | 12853 t1 := (1.0 - parameter) squared. 12854 t2 := 2 * parameter * (1.0 - parameter). 12855 t3 := parameter squared. 12856 ^(start * t1) + (via * t2) + (end * t3)! ! 12857 12858"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 12859 12860BalloonBezierSimulation class 12861 instanceVariableNames: ''! 12862 12863!BalloonBezierSimulation class methodsFor: 'initialization' stamp: 'MarcusDenker 9/30/2009 11:56'! 12864initialize 12865 HeightSubdivisions := 0. 12866 LineConversions := 0. 12867 MonotonSubdivisions := 0. 12868 OverflowSubdivisions := 0.! ! 12869Object variableWordSubclass: #BalloonBuffer 12870 instanceVariableNames: '' 12871 classVariableNames: '' 12872 poolDictionaries: '' 12873 category: 'Balloon-Engine'! 12874!BalloonBuffer commentStamp: '<historical>' prior: 0! 12875BalloonBuffer is a repository for primitive data used by the BalloonEngine.! 12876 12877 12878!BalloonBuffer methodsFor: 'accessing' stamp: 'ar 10/26/1998 21:12'! 12879at: index 12880 "For simulation only" 12881 | word | 12882 word := self basicAt: index. 12883 word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" 12884 ^word >= 16r80000000 "Negative?!!" 12885 ifTrue:["word - 16r100000000" 12886 (word bitInvert32 + 1) negated] 12887 ifFalse:[word]! ! 12888 12889!BalloonBuffer methodsFor: 'accessing' stamp: 'ar 10/26/1998 21:12'! 12890at: index put: anInteger 12891 "For simulation only" 12892 | word | 12893 anInteger < 0 12894 ifTrue:["word := 16r100000000 + anInteger" 12895 word := (anInteger + 1) negated bitInvert32] 12896 ifFalse:[word := anInteger]. 12897 self basicAt: index put: word. 12898 ^anInteger! ! 12899 12900!BalloonBuffer methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! 12901floatAt: index 12902 "For simulation only" 12903 <primitive: 'primitiveAt' module: 'FloatArrayPlugin'> 12904 ^Float fromIEEE32Bit: (self basicAt: index)! ! 12905 12906!BalloonBuffer methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! 12907floatAt: index put: value 12908 "For simulation only" 12909 <primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'> 12910 value isFloat 12911 ifTrue:[self basicAt: index put: value asIEEE32BitWord] 12912 ifFalse:[self at: index put: value asFloat]. 12913 ^value! ! 12914 12915"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 12916 12917BalloonBuffer class 12918 instanceVariableNames: ''! 12919 12920!BalloonBuffer class methodsFor: 'instance creation' stamp: 'ar 10/26/1998 21:11'! 12921new 12922 ^self new: 256.! ! 12923FormCanvas subclass: #BalloonCanvas 12924 instanceVariableNames: 'transform colorTransform engine aaLevel deferred' 12925 classVariableNames: '' 12926 poolDictionaries: '' 12927 category: 'Morphic-Balloon'! 12928!BalloonCanvas commentStamp: '<historical>' prior: 0! 12929BalloonCanvas is a canvas using the BalloonEngine for drawing wherever possible. It has various methods which other canvases do not support due to the extra features of the balloon engine.! 12930 12931 12932!BalloonCanvas methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/21/2008 16:46'! 12933fillRectangle: aRectangle basicFillStyle: aFillStyle 12934 "Fill the given rectangle with the given, non-composite, fill style." 12935 12936 ^self drawRectangle: aRectangle 12937 color: aFillStyle "@@: Name confusion!!!!!!" 12938 borderWidth: 0 12939 borderColor: nil 12940! ! 12941 12942 12943!BalloonCanvas methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/21/2008 16:46'! 12944fillRectangle: aRectangle fillStyle: aFillStyle 12945 "Fill the given rectangle. Double-dispatched via the fill style." 12946 12947 aFillStyle fillRectangle: aRectangle on: self! ! 12948 12949 12950!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 11/13/1998 01:02'! 12951aaLevel 12952 ^aaLevel! ! 12953 12954!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:53'! 12955aaLevel: newLevel 12956 "Only allow changes to aaLevel if we're working on >= 8 bit forms" 12957 form depth >= 8 ifFalse:[^self]. 12958 aaLevel = newLevel ifTrue:[^self]. 12959 self flush. "In case there are pending primitives in the engine" 12960 aaLevel := newLevel. 12961 engine ifNotNil:[engine aaLevel: aaLevel].! ! 12962 12963!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:54'! 12964deferred 12965 ^deferred! ! 12966 12967!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:55'! 12968deferred: aBoolean 12969 deferred == aBoolean ifTrue:[^self]. 12970 self flush. "Force pending prims on screen" 12971 deferred := aBoolean. 12972 engine ifNotNil:[engine deferred: aBoolean].! ! 12973 12974!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 2/13/2001 21:07'! 12975ensuredEngine 12976 engine ifNil:[ 12977 engine := BalloonEngine new. 12978 "engine := BalloonDebugEngine new" 12979 engine aaLevel: aaLevel. 12980 engine bitBlt: port. 12981 engine destOffset: origin. 12982 engine clipRect: clipRect. 12983 engine deferred: deferred. 12984 engine]. 12985 engine colorTransform: colorTransform. 12986 engine edgeTransform: transform. 12987 ^engine! ! 12988 12989 12990!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'DSM 10/15/1999 15:14'! 12991drawBezier3Shape: vertices color: c borderWidth: borderWidth borderColor: 12992borderColor 12993 self drawBezierShape: (Bezier3Segment convertBezier3ToBezier2: 12994vertices) color: c borderWidth: borderWidth borderColor: borderColor! ! 12995 12996!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:25'! 12997drawBezierShape: vertices color: c borderWidth: borderWidth borderColor: borderColor 12998 "Draw a boundary shape that is defined by a list of vertices. 12999 Each three subsequent vertices define a quadratic bezier segment. 13000 For lines, the control point should be set to either the start or the end 13001 of the bezier curve." 13002 | fillC borderC | 13003 fillC := self shadowColor ifNil:[c]. 13004 borderC := self shadowColor ifNil:[borderColor]. 13005 self ensuredEngine 13006 drawBezierShape: vertices 13007 fill: fillC 13008 borderWidth: borderWidth 13009 borderColor: borderC 13010 transform: transform.! ! 13011 13012!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 11/24/1998 15:16'! 13013drawCompressedShape: compressedShape 13014 "Draw a compressed shape" 13015 self ensuredEngine 13016 drawCompressedShape: compressedShape 13017 transform: transform.! ! 13018 13019!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'DSM 10/15/1999 15:18'! 13020drawGeneralBezier3Shape: contours color: c borderWidth: borderWidth 13021borderColor: borderColor 13022 | b2 | 13023 b2 := contours collect: [:b3 | Bezier3Segment 13024convertBezier3ToBezier2: b3 ]. 13025 self drawGeneralBezierShape: b2 color: c borderWidth: borderWidth 13026borderColor: borderColor! ! 13027 13028!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'! 13029drawGeneralBezierShape: contours color: c borderWidth: borderWidth borderColor: borderColor 13030 "Draw a general boundary shape (e.g., possibly containing holes)" 13031 | fillC borderC | 13032 fillC := self shadowColor ifNil:[c]. 13033 borderC := self shadowColor ifNil:[borderColor]. 13034 self ensuredEngine 13035 drawGeneralBezierShape: contours 13036 fill: fillC 13037 borderWidth: borderWidth 13038 borderColor: borderC 13039 transform: transform.! ! 13040 13041!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'! 13042drawGeneralPolygon: contours color: c borderWidth: borderWidth borderColor: borderColor 13043 "Draw a general polygon (e.g., a polygon that can contain holes)" 13044 | fillC borderC | 13045 fillC := self shadowColor ifNil:[c]. 13046 borderC := self shadowColor ifNil:[borderColor]. 13047 self ensuredEngine 13048 drawGeneralPolygon: contours 13049 fill: fillC 13050 borderWidth: borderWidth 13051 borderColor: borderC 13052 transform: transform.! ! 13053 13054!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'! 13055drawOval: r color: c borderWidth: borderWidth borderColor: borderColor 13056 "Draw the oval defined by the given rectangle" 13057 | fillC borderC | 13058 fillC := self shadowColor ifNil:[c]. 13059 borderC := self shadowColor ifNil:[borderColor]. 13060 self ensuredEngine 13061 drawOval: r 13062 fill: fillC 13063 borderWidth: borderWidth 13064 borderColor: borderC 13065 transform: transform.! ! 13066 13067!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'! 13068drawRectangle: r color: c borderWidth: borderWidth borderColor: borderColor 13069 "Draw a rectangle" 13070 | fillC borderC | 13071 fillC := self shadowColor ifNil:[c]. 13072 borderC := self shadowColor ifNil:[borderColor]. 13073 self ensuredEngine 13074 drawRectangle: r 13075 fill: fillC 13076 borderWidth: borderWidth 13077 borderColor: borderC 13078 transform: transform.! ! 13079 13080 13081!BalloonCanvas methodsFor: 'converting' stamp: 'ar 11/11/1998 22:57'! 13082asBalloonCanvas 13083 ^self! ! 13084 13085 13086!BalloonCanvas methodsFor: 'copying' stamp: 'ar 11/24/1998 22:33'! 13087copy 13088 self flush. 13089 ^super copy resetEngine! ! 13090 13091 13092!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:40'! 13093fillColor: c 13094 "Note: This always fills, even if the color is transparent." 13095 "Note2: To achieve the above we must make sure that c is NOT transparent" 13096 self frameAndFillRectangle: form boundingBox 13097 fillColor: (c alpha: 1.0) 13098 borderWidth: 0 13099 borderColor: nil! ! 13100 13101!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:51'! 13102fillOval: r color: c borderWidth: borderWidth borderColor: borderColor 13103 "Draw a filled and outlined oval" 13104 "Note: The optimization test below should actually read: 13105 self ifNoTransformWithIn: (r insetBy: borderWidth // 2) 13106 but since borderWidth is assumed to be very small related to r we don't check it." 13107 13108 (self ifNoTransformWithIn: r) 13109 ifTrue:[^super fillOval: r color: c borderWidth: borderWidth borderColor: borderColor]. 13110 13111 ^self drawOval: (r insetBy: borderWidth // 2) 13112 color: c 13113 borderWidth: borderWidth 13114 borderColor: borderColor! ! 13115 13116!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:40'! 13117fillRectangle: r color: c 13118 "Fill the rectangle with the given color" 13119 ^self frameAndFillRectangle: r 13120 fillColor: c 13121 borderWidth: 0 13122 borderColor: nil! ! 13123 13124!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 06:26'! 13125frameAndFillRectangle: r fillColor: c borderWidth: borderWidth borderColor: borderColor 13126 "Draw a filled and outlined rectangle" 13127 "Note: The optimization test below should actually read: 13128 self ifNoTransformWithIn: (r insetBy: borderWidth // 2) 13129 but since borderWidth is assumed to be very small related to r we don't check it." 13130 13131 (self ifNoTransformWithIn: r) 13132 ifTrue:[^super frameAndFillRectangle: r fillColor: c borderWidth: borderWidth borderColor: borderColor]. 13133 13134 ^self drawRectangle: (r insetBy: borderWidth // 2) 13135 color: c 13136 borderWidth: borderWidth 13137 borderColor: borderColor! ! 13138 13139!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:52'! 13140frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor 13141 "Draw a beveled or raised rectangle" 13142 | bw | 13143 13144 "Note: The optimization test below should actually read: 13145 self ifNoTransformWithIn: (r insetBy: borderWidth // 2) 13146 but since borderWidth is assumed to be very small related to r we don't check it." 13147 13148 (self ifNoTransformWithIn: r) 13149 ifTrue:[^super frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor]. 13150 13151 "Fill rectangle and draw top and left border" 13152 bw := borderWidth // 2. 13153 self drawRectangle: (r insetBy: bw) 13154 color: fillColor 13155 borderWidth: borderWidth 13156 borderColor: topLeftColor. 13157 "Now draw bottom right border." 13158 self drawPolygon: (Array with: r topRight + (bw negated@bw) 13159 with: r bottomRight - bw asPoint 13160 with: r bottomLeft + (bw@bw negated)) 13161 color: nil 13162 borderWidth: borderWidth 13163 borderColor: bottomRightColor.! ! 13164 13165!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/12/1999 17:45'! 13166line: pt1 to: pt2 width: w color: c 13167 "Draw a line from pt1 to: pt2" 13168 (self ifNoTransformWithIn:(pt1 rect: pt2)) 13169 ifTrue:[^super line: pt1 to: pt2 width: w color: c]. 13170 ^self drawPolygon: (Array with: pt1 with: pt2) 13171 color: c 13172 borderWidth: w 13173 borderColor: c! ! 13174 13175!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 11/11/1998 19:39'! 13176point: pt color: c 13177 "Is there any use for this?" 13178 | myPt | 13179 transform 13180 ifNil:[myPt := pt] 13181 ifNotNil:[myPt := transform localPointToGlobal: pt]. 13182 ^super point: myPt color: c! ! 13183 13184 13185!BalloonCanvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:50'! 13186fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc 13187 "Fill the given rectangle." 13188 ^self drawOval: (aRectangle insetBy: bw // 2) 13189 color: aFillStyle "@@: Name confusion!!!!!!" 13190 borderWidth: bw 13191 borderColor: bc 13192! ! 13193 13194 13195!BalloonCanvas methodsFor: 'drawing-polygons' stamp: 'ar 8/26/2001 22:14'! 13196drawPolygon: vertices fillStyle: aFillStyle 13197 "Fill the given polygon." 13198 self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: nil! ! 13199 13200!BalloonCanvas methodsFor: 'drawing-polygons' stamp: 'ar 2/17/2000 00:25'! 13201drawPolygon: vertices fillStyle: aFillStyle borderWidth: borderWidth borderColor: borderColor 13202 "Draw a simple polygon defined by the list of vertices." 13203 | fillC borderC | 13204 fillC := self shadowColor ifNil:[aFillStyle]. 13205 borderC := self shadowColor ifNil:[borderColor]. 13206 self ensuredEngine 13207 drawPolygon: (vertices copyWith: vertices first) 13208 fill: fillC 13209 borderWidth: borderWidth 13210 borderColor: borderC 13211 transform: transform.! ! 13212 13213 13214!BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/24/1998 15:28'! 13215flush 13216 "Force all pending primitives onscreen" 13217 engine ifNotNil:[engine flush].! ! 13218 13219!BalloonCanvas methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:42'! 13220initialize 13221 super initialize. 13222 aaLevel := 1. 13223 deferred := false.! ! 13224 13225!BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/11/1998 20:25'! 13226resetEngine 13227 engine := nil.! ! 13228 13229 13230!BalloonCanvas methodsFor: 'testing' stamp: 'ar 11/13/1998 13:19'! 13231isBalloonCanvas 13232 ^true! ! 13233 13234!BalloonCanvas methodsFor: 'testing' stamp: 'ar 11/12/1998 01:07'! 13235isVisible: aRectangle 13236 ^transform 13237 ifNil:[super isVisible: aRectangle] 13238 ifNotNil:[super isVisible: (transform localBoundsToGlobal: aRectangle)]! ! 13239 13240 13241!BalloonCanvas methodsFor: 'todo' stamp: 'ar 12/31/2001 02:27'! 13242drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c 13243 (self ifNoTransformWithIn: boundsRect) 13244 ifTrue:[^super drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]! ! 13245 13246!BalloonCanvas methodsFor: 'todo' stamp: 'tween 3/10/2009 07:49'! 13247drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc 13248 (self ifNoTransformWithIn: boundsRect) 13249 ifTrue:[^super drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc]! ! 13250 13251!BalloonCanvas methodsFor: 'todo' stamp: 'ar 2/9/1999 05:46'! 13252line: point1 to: point2 brushForm: brush 13253 "Who's gonna use this?" 13254 | pt1 pt2 | 13255 self flush. "Sorry, but necessary..." 13256 transform 13257 ifNil:[pt1 := point1. pt2 := point2] 13258 ifNotNil:[pt1 := transform localPointToGlobal: point1. 13259 pt2 := transform localPointToGlobal: point2]. 13260 ^super line: pt1 to: pt2 brushForm: brush! ! 13261 13262!BalloonCanvas methodsFor: 'todo' stamp: 'ar 2/9/1999 05:46'! 13263paragraph: para bounds: bounds color: c 13264 (self ifNoTransformWithIn: bounds) 13265 ifTrue:[^super paragraph: para bounds: bounds color: c].! ! 13266 13267 13268!BalloonCanvas methodsFor: 'transforming' stamp: 'ar 11/24/1998 14:45'! 13269colorTransformBy: aColorTransform 13270 aColorTransform ifNil:[^self]. 13271 colorTransform 13272 ifNil:[colorTransform := aColorTransform] 13273 ifNotNil:[colorTransform := colorTransform composedWithLocal: aColorTransform]! ! 13274 13275!BalloonCanvas methodsFor: 'transforming' stamp: 'ar 12/30/1998 10:47'! 13276preserveStateDuring: aBlock 13277 | state result | 13278 state := BalloonState new. 13279 state transform: transform. 13280 state colorTransform: colorTransform. 13281 state aaLevel: self aaLevel. 13282 result := aBlock value: self. 13283 transform := state transform. 13284 colorTransform := state colorTransform. 13285 self aaLevel: state aaLevel. 13286 ^result! ! 13287 13288!BalloonCanvas methodsFor: 'transforming' stamp: 'ar 11/12/1998 00:32'! 13289transformBy: aTransform 13290 aTransform ifNil:[^self]. 13291 transform 13292 ifNil:[transform := aTransform] 13293 ifNotNil:[transform := transform composedWithLocal: aTransform]! ! 13294 13295!BalloonCanvas methodsFor: 'transforming' stamp: 'ar 5/29/1999 08:59'! 13296transformBy: aDisplayTransform during: aBlock 13297 | myTransform result | 13298 myTransform := transform. 13299 self transformBy: aDisplayTransform. 13300 result := aBlock value: self. 13301 transform := myTransform. 13302 ^result! ! 13303 13304 13305!BalloonCanvas methodsFor: 'private' stamp: 'marcus.denker 9/14/2008 21:01'! 13306ifNoTransformWithIn: box 13307 "Return true if the current transformation does not affect the given bounding box" 13308 | delta | 13309 transform ifNil: [^true]. 13310 delta := (transform localPointToGlobal: box origin) - box origin. 13311 ^(transform localPointToGlobal: box corner) - box corner = delta! ! 13312 13313!BalloonCanvas methodsFor: 'private' stamp: 'nk 5/1/2004 12:54'! 13314image: aForm at: aPoint sourceRect: sourceRect rule: rule 13315 | warp dstRect srcQuad dstOffset center | 13316 (self ifNoTransformWithIn: sourceRect) & false 13317 ifTrue:[^super image: aForm at: aPoint sourceRect: sourceRect rule: rule]. 13318 dstRect := (transform localBoundsToGlobal: (aForm boundingBox translateBy: aPoint)). 13319 dstOffset := 0@0. "dstRect origin." 13320 "dstRect := 0@0 corner: dstRect extent." 13321 center := 0@0."transform globalPointToLocal: dstRect origin." 13322 srcQuad := transform globalPointsToLocal: (dstRect innerCorners). 13323 srcQuad := srcQuad collect:[:pt| pt - aPoint]. 13324 warp := (WarpBlt current toForm: form) 13325 sourceForm: aForm; 13326 cellSize: 2; "installs a new colormap if cellSize > 1" 13327 combinationRule: Form over. 13328 warp copyQuad: srcQuad toRect: (dstRect translateBy: dstOffset). 13329 13330 self frameRectangle: (aForm boundingBox translateBy: aPoint) color: Color green. 13331 13332 "... TODO ... create a bitmap fill style from the form and use it for a simple rectangle."! ! 13333Object subclass: #BalloonEdgeData 13334 instanceVariableNames: 'index xValue yValue zValue lines source' 13335 classVariableNames: '' 13336 poolDictionaries: '' 13337 category: 'Balloon-Simulation'! 13338!BalloonEdgeData commentStamp: '<historical>' prior: 0! 13339BalloonEdgeData defines an entry in the internal edge table of the Balloon engine. 13340 13341Instance Variables: 13342 index <Integer> The index into the external objects array of the associated graphics engine 13343 xValue <Integer> The computed x-value of the requested operation 13344 yValue <Integer> The y-value for the requested operation 13345 height <Integer> The (remaining) height of the edge 13346 source <Object> The object from the external objects array! 13347 13348 13349!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! 13350index 13351 ^index! ! 13352 13353!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'! 13354index: anInteger 13355 index := anInteger! ! 13356 13357!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:13'! 13358lines 13359 ^lines! ! 13360 13361!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:13'! 13362lines: anInteger 13363 ^lines := anInteger! ! 13364 13365!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! 13366source 13367 ^source! ! 13368 13369!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 21:39'! 13370source: anObject 13371 source := anObject! ! 13372 13373!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! 13374xValue 13375 ^xValue! ! 13376 13377!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'! 13378xValue: anInteger 13379 xValue := anInteger! ! 13380 13381!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! 13382yValue 13383 ^yValue! ! 13384 13385!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'! 13386yValue: anInteger 13387 yValue := anInteger! ! 13388 13389!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 19:56'! 13390zValue 13391 ^zValue! ! 13392 13393!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 19:56'! 13394zValue: anInteger 13395 zValue := anInteger! ! 13396 13397 13398!BalloonEdgeData methodsFor: 'computing' stamp: 'ar 10/27/1998 15:53'! 13399stepToFirstScanLine 13400 source stepToFirstScanLineAt: yValue in: self! ! 13401 13402!BalloonEdgeData methodsFor: 'computing' stamp: 'ar 10/27/1998 15:53'! 13403stepToNextScanLine 13404 source stepToNextScanLineAt: yValue in: self! ! 13405Object subclass: #BalloonEngine 13406 instanceVariableNames: 'workBuffer span bitBlt forms clipRect destOffset externals aaLevel edgeTransform colorTransform deferred postFlushNeeded' 13407 classVariableNames: 'BezierStats BufferCache CacheProtect Counts Debug Times' 13408 poolDictionaries: 'BalloonEngineConstants' 13409 category: 'Balloon-Engine'! 13410!BalloonEngine commentStamp: '<historical>' prior: 0! 13411BalloonEngine is the representative for the Balloon engine inside Squeak. For most purposes it should not be used directly but via BalloonCanvas since this ensures proper initialization and is polymorphic with other canvas uses.! 13412 13413 13414!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/11/1998 23:04'! 13415aaLevel 13416 ^aaLevel ifNil:[1]! ! 13417 13418!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/11/1998 23:04'! 13419aaLevel: anInteger 13420 aaLevel := (anInteger min: 4) max: 1.! ! 13421 13422!BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/29/1998 01:51'! 13423aaTransform 13424 "Return a transformation for the current anti-aliasing level" 13425 | matrix | 13426 matrix := MatrixTransform2x3 withScale: (self aaLevel) asFloat asPoint. 13427 matrix offset: (self aaLevel // 2) asFloat asPoint. 13428 ^matrix composedWith:(MatrixTransform2x3 withOffset: destOffset asFloatPoint)! ! 13429 13430!BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/13/1998 03:04'! 13431bitBlt 13432 ^bitBlt! ! 13433 13434!BalloonEngine methodsFor: 'accessing' stamp: 'ar 5/28/2000 15:02'! 13435bitBlt: aBitBlt 13436 bitBlt := aBitBlt. 13437 bitBlt isNil ifTrue:[^self]. 13438 self class primitiveSetBitBltPlugin: bitBlt getPluginName. 13439 self clipRect: bitBlt clipRect. 13440 bitBlt 13441 sourceForm: (Form extent: span size @ 1 depth: 32 bits: span); 13442 sourceRect: (0@0 extent: 1@span size); 13443 colorMap: (Color colorMapIfNeededFrom: 32 to: bitBlt destForm depth); 13444 combinationRule: (bitBlt destForm depth >= 8 ifTrue:[34] ifFalse:[Form paint]).! ! 13445 13446!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/1/1998 02:57'! 13447clipRect 13448 ^clipRect! ! 13449 13450!BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/13/1998 02:44'! 13451clipRect: aRect 13452 clipRect := aRect truncated! ! 13453 13454!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/24/1998 15:04'! 13455colorTransform 13456 ^colorTransform! ! 13457 13458!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/24/1998 15:04'! 13459colorTransform: aColorTransform 13460 colorTransform := aColorTransform! ! 13461 13462!BalloonEngine methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:24'! 13463deferred 13464 ^deferred! ! 13465 13466!BalloonEngine methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:24'! 13467deferred: aBoolean 13468 deferred := aBoolean.! ! 13469 13470!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/1/1998 02:56'! 13471destOffset 13472 ^destOffset! ! 13473 13474!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/12/1998 00:22'! 13475destOffset: aPoint 13476 destOffset := aPoint asIntegerPoint. 13477 bitBlt destX: aPoint x; destY: aPoint y.! ! 13478 13479!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/25/1998 22:34'! 13480edgeTransform 13481 ^edgeTransform! ! 13482 13483!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/25/1998 22:34'! 13484edgeTransform: aTransform 13485 edgeTransform := aTransform.! ! 13486 13487!BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/29/1998 01:51'! 13488fullTransformFrom: aMatrix 13489 | m | 13490 m := self aaTransform composedWith: aMatrix. 13491 "m offset: m offset + destOffset." 13492 ^m! ! 13493 13494 13495!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/25/1998 00:45'! 13496canProceedAfter: failureReason 13497 "Check if we can proceed after the failureReason indicated." 13498 | newBuffer | 13499 failureReason = GErrorNeedFlush ifTrue:[ 13500 "Need to flush engine before proceeding" 13501 self copyBits. 13502 self reset. 13503 ^true]. 13504 failureReason = GErrorNoMoreSpace ifTrue:[ 13505 "Work buffer is too small" 13506 newBuffer := workBuffer species new: workBuffer size * 2. 13507 self primCopyBufferFrom: workBuffer to: newBuffer. 13508 workBuffer := newBuffer. 13509 ^true]. 13510 "Not handled" 13511 ^false! ! 13512 13513!BalloonEngine methodsFor: 'copying' stamp: 'ar 3/6/2001 12:06'! 13514copyBits 13515 (bitBlt notNil and:[bitBlt destForm notNil]) ifTrue:[bitBlt destForm unhibernate]. 13516 self copyLoopFaster.! ! 13517 13518!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:32'! 13519copyLoop 13520 "This is the basic rendering loop using as little primitive support as possible." 13521 | finished edge fill | 13522 edge := BalloonEdgeData new. 13523 fill := BalloonFillData new. 13524 self primInitializeProcessing. "Initialize the GE for processing" 13525 [self primFinishedProcessing] whileFalse:[ 13526 "Step 1: Process the edges in the global edge table that will be added in this step" 13527 [finished := self primNextGlobalEdgeEntryInto: edge. 13528 finished] whileFalse:[ 13529 edge source: (externals at: edge index). 13530 edge stepToFirstScanLine. 13531 self primAddActiveEdgeTableEntryFrom: edge]. 13532 13533 "Step 2: Scan the active edge table" 13534 [finished := self primNextFillEntryInto: fill. 13535 finished] whileFalse:[ 13536 fill source: (externals at: fill index). 13537 "Compute the new fill" 13538 fill computeFill. 13539 "And mix it in the out buffer" 13540 self primMergeFill: fill destForm bits from: fill]. 13541 13542 "Step 3: Display the current span buffer if necessary" 13543 self primDisplaySpanBuffer. 13544 13545 "Step 4: Advance and resort the active edge table" 13546 [finished := self primNextActiveEdgeEntryInto: edge. 13547 finished] whileFalse:[ 13548 "If the index is zero then the edge has been handled by the GE" 13549 edge source: (externals at: edge index). 13550 edge stepToNextScanLine. 13551 self primChangeActiveEdgeTableEntryFrom: edge]. 13552 ]. 13553 self primGetTimes: Times. 13554 self primGetCounts: Counts. 13555 self primGetBezierStats: BezierStats.! ! 13556 13557!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:32'! 13558copyLoopFaster 13559 "This is a copy loop drawing one scan line at a time" 13560 | edge fill reason | 13561 edge := BalloonEdgeData new. 13562 fill := BalloonFillData new. 13563 [self primFinishedProcessing] whileFalse:[ 13564 reason := self primRenderScanline: edge with: fill. 13565 "reason ~= 0 means there has been a problem" 13566 reason = 0 ifFalse:[ 13567 self processStopReason: reason edge: edge fill: fill. 13568 ]. 13569 ]. 13570 self primGetTimes: Times. 13571 self primGetCounts: Counts. 13572 self primGetBezierStats: BezierStats.! ! 13573 13574!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:33'! 13575copyLoopFastest 13576 "This is a copy loop drawing the entire image" 13577 | edge fill reason | 13578 edge := BalloonEdgeData new. 13579 fill := BalloonFillData new. 13580 [self primFinishedProcessing] whileFalse:[ 13581 reason := self primRenderImage: edge with: fill. 13582 "reason ~= 0 means there has been a problem" 13583 reason = 0 ifFalse:[ 13584 self processStopReason: reason edge: edge fill: fill. 13585 ]. 13586 ]. 13587 self primGetTimes: Times. 13588 self primGetCounts: Counts. 13589 self primGetBezierStats: BezierStats.! ! 13590 13591!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/11/1998 21:19'! 13592processStopReason: reason edge: edge fill: fill 13593 "The engine has stopped because of some reason. 13594 Try to figure out how to respond and do the necessary actions." 13595 "Note: The order of operations below can affect the speed" 13596 13597 "Process unknown fills first" 13598 reason = GErrorFillEntry ifTrue:[ 13599 fill source: (externals at: fill index). 13600 "Compute the new fill" 13601 fill computeFill. 13602 "And mix it in the out buffer" 13603 ^self primMergeFill: fill destForm bits from: fill]. 13604 13605 "Process unknown steppings in the AET second" 13606 reason = GErrorAETEntry ifTrue:[ 13607 edge source: (externals at: edge index). 13608 edge stepToNextScanLine. 13609 ^self primChangeActiveEdgeTableEntryFrom: edge]. 13610 13611 "Process unknown entries in the GET third" 13612 reason = GErrorGETEntry ifTrue:[ 13613 edge source: (externals at: edge index). 13614 edge stepToFirstScanLine. 13615 ^self primAddActiveEdgeTableEntryFrom: edge]. 13616 13617 "Process generic problems last" 13618 (self canProceedAfter: reason) ifTrue:[^self]. "Okay." 13619 13620 ^self error:'Unkown stop reason in graphics engine' 13621! ! 13622 13623 13624!BalloonEngine methodsFor: 'drawing' stamp: 'ar 10/11/1999 16:49'! 13625drawBezierShape: points fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform 13626 | fills | 13627 self edgeTransform: aTransform. 13628 self resetIfNeeded. 13629 fills := self registerFill: fillStyle and: borderFill. 13630 self primAddBezierShape: points 13631 segments: (points size) // 3 13632 fill: (fills at: 1) 13633 lineWidth: borderWidth 13634 lineFill: (fills at: 2). 13635 self postFlushIfNeeded.! ! 13636 13637!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:44'! 13638drawCompressedShape: shape transform: aTransform 13639 | fillIndexList | 13640 self edgeTransform: aTransform. 13641 self resetIfNeeded. 13642 13643 fillIndexList := self registerFills: shape fillStyles. 13644 13645 self primAddCompressedShape: shape points 13646 segments: shape numSegments 13647 leftFills: shape leftFills 13648 rightFills: shape rightFills 13649 lineWidths: shape lineWidths 13650 lineFills: shape lineFills 13651 fillIndexList: fillIndexList. 13652 self postFlushIfNeeded.! ! 13653 13654!BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/15/1999 03:02'! 13655drawGeneralBezierShape: contours fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform 13656 13657 | fills | 13658 self edgeTransform: aTransform. 13659 self resetIfNeeded. 13660 fills := self registerFill: fillStyle and: borderFill. 13661 contours do:[:points| 13662 self primAddBezierShape: points 13663 segments: (points size // 3) 13664 fill: (fills at: 1) 13665 lineWidth: borderWidth 13666 lineFill: (fills at: 2). 13667 "Note: To avoid premature flushing of the pipeline we need to 13668 reset the flush bit within the engine." 13669 self primFlushNeeded: false. 13670 ]. 13671 "And set the flush bit afterwards" 13672 self primFlushNeeded: true. 13673 self postFlushIfNeeded.! ! 13674 13675!BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/15/1999 03:02'! 13676drawGeneralPolygon: contours fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform 13677 13678 | fills | 13679 self edgeTransform: aTransform. 13680 self resetIfNeeded. 13681 fills := self registerFill: fillStyle and: borderFill. 13682 contours do:[:points| 13683 self primAddPolygon: points 13684 segments: points size 13685 fill: (fills at: 1) 13686 lineWidth: borderWidth 13687 lineFill: (fills at: 2). 13688 "Note: To avoid premature flushing of the pipeline we need to 13689 reset the flush bit within the engine." 13690 self primFlushNeeded: false. 13691 ]. 13692 "And set the flush bit afterwards" 13693 self primFlushNeeded: true. 13694 self postFlushIfNeeded.! ! 13695 13696!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'! 13697drawOval: rect fill: fillStyle borderWidth: borderWidth borderColor: borderColor transform: aMatrix 13698 13699 | fills | 13700 self edgeTransform: aMatrix. 13701 self resetIfNeeded. 13702 fills := self registerFill: fillStyle and: borderColor. 13703 self primAddOvalFrom: rect origin 13704 to: rect corner 13705 fillIndex: (fills at: 1) 13706 borderWidth: borderWidth 13707 borderColor: (fills at: 2). 13708 self postFlushIfNeeded.! ! 13709 13710!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'! 13711drawPolygon: points fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform 13712 13713 | fills | 13714 self edgeTransform: aTransform. 13715 self resetIfNeeded. 13716 fills := self registerFill: fillStyle and: borderFill. 13717 self primAddPolygon: points 13718 segments: points size 13719 fill: (fills at: 1) 13720 lineWidth: borderWidth 13721 lineFill: (fills at: 2). 13722 self postFlushIfNeeded.! ! 13723 13724!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'! 13725drawRectangle: rect fill: fillStyle borderWidth: borderWidth borderColor: borderColor transform: aMatrix 13726 13727 | fills | 13728 self edgeTransform: aMatrix. 13729 self resetIfNeeded. 13730 fills := self registerFill: fillStyle and: borderColor. 13731 self primAddRectFrom: rect origin 13732 to: rect corner 13733 fillIndex: (fills at: 1) 13734 borderWidth: borderWidth 13735 borderColor: (fills at: 2). 13736 self postFlushIfNeeded.! ! 13737 13738!BalloonEngine methodsFor: 'drawing' stamp: 'bf 4/3/2004 01:36'! 13739registerFill: aFillStyle 13740 "Register the given fill style." 13741 | theForm | 13742 aFillStyle ifNil:[^0]. 13743 aFillStyle isSolidFill 13744 ifTrue:[^aFillStyle scaledPixelValue32]. 13745 13746 aFillStyle isGradientFill ifTrue:[ 13747 ^self primAddGradientFill: aFillStyle pixelRamp 13748 from: aFillStyle origin 13749 along: aFillStyle direction 13750 normal: aFillStyle normal 13751 radial: aFillStyle isRadialFill 13752 ]. 13753 aFillStyle isBitmapFill ifTrue:[ 13754 theForm := aFillStyle form asSourceForm. 13755 theForm unhibernate. 13756 forms := forms copyWith: theForm. 13757 ^self primAddBitmapFill: theForm 13758 colormap: (theForm colormapIfNeededForDepth: 32) 13759 tile: aFillStyle isTiled 13760 from: aFillStyle origin 13761 along: aFillStyle direction 13762 normal: aFillStyle normal 13763 xIndex: forms size]. 13764 ^0! ! 13765 13766!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'! 13767registerFill: fill1 and: fill2 13768 ^self registerFills: (Array with: fill1 with: fill2)! ! 13769 13770!BalloonEngine methodsFor: 'drawing' stamp: 'di 11/21/1999 20:15'! 13771registerFills: fills 13772 13773 | fillIndexList index fillIndex | 13774 ((colorTransform notNil and:[colorTransform isAlphaTransform]) or:[ 13775 fills anySatisfy: [:any| any notNil and:[any isTranslucent]]]) 13776 ifTrue:[ self flush. 13777 self reset. 13778 postFlushNeeded := true]. 13779 fillIndexList := WordArray new: fills size. 13780 index := 1. 13781 [index <= fills size] whileTrue:[ 13782 fillIndex := self registerFill: (fills at: index). 13783 fillIndex == nil 13784 ifTrue:[index := 1] "Need to start over" 13785 ifFalse:[fillIndexList at: index put: fillIndex. 13786 index := index+1] 13787 ]. 13788 ^fillIndexList! ! 13789 13790 13791!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:29'! 13792flush 13793 "Force all pending primitives onscreen" 13794 workBuffer ifNil:[^self]. 13795 self copyBits. 13796 self release.! ! 13797 13798!BalloonEngine methodsFor: 'initialize' stamp: 'stephane.ducasse 6/14/2009 22:37'! 13799initialize 13800 | w | 13801 super initialize. 13802 w := Display width > 2048 ifTrue: [ 4096 ] ifFalse: [ 2048 ]. 13803 externals := OrderedCollection new: 100. 13804 span := Bitmap new: w. 13805 bitBlt := nil. 13806 self bitBlt: ((BitBlt toForm: Display) destRect: Display boundingBox; yourself). 13807 forms := #(). 13808 deferred := false.! ! 13809 13810!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:42'! 13811postFlushIfNeeded 13812 "Force all pending primitives onscreen" 13813 workBuffer ifNil:[^self]. 13814 (deferred not or:[postFlushNeeded]) ifTrue:[ 13815 self copyBits. 13816 self release].! ! 13817 13818!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:43'! 13819preFlushIfNeeded 13820 "Force all pending primitives onscreen" 13821 workBuffer ifNil:[^self]. 13822 self primFlushNeeded ifTrue:[ 13823 self copyBits. 13824 self reset].! ! 13825 13826!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/11/1998 22:52'! 13827release 13828 self class recycleBuffer: workBuffer. 13829 workBuffer := nil.! ! 13830 13831!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:34'! 13832reset 13833 workBuffer ifNil:[workBuffer := self class allocateOrRecycleBuffer: 10000]. 13834 self primInitializeBuffer: workBuffer. 13835 self primSetAALevel: self aaLevel. 13836 self primSetOffset: destOffset. 13837 self primSetClipRect: clipRect. 13838 self primSetEdgeTransform: edgeTransform. 13839 self primSetColorTransform: colorTransform. 13840 forms := #().! ! 13841 13842!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:39'! 13843resetIfNeeded 13844 workBuffer ifNil:[self reset]. 13845 self primSetEdgeTransform: edgeTransform. 13846 self primSetColorTransform: colorTransform. 13847 self primSetDepth: self primGetDepth + 1. 13848 postFlushNeeded := false.! ! 13849 13850 13851!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:48'! 13852primClipRectInto: rect 13853 <primitive: 'primitiveGetClipRect' module: 'B2DPlugin'> 13854 ^self primitiveFailed! ! 13855 13856!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! 13857primFlushNeeded 13858 <primitive: 'primitiveNeedsFlush' module: 'B2DPlugin'> 13859 ^self primitiveFailed! ! 13860 13861!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! 13862primFlushNeeded: aBoolean 13863 <primitive: 'primitiveNeedsFlushPut' module: 'B2DPlugin'> 13864 ^self primitiveFailed! ! 13865 13866!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! 13867primGetAALevel 13868 "Set the AA level" 13869 <primitive: 'primitiveGetAALevel' module: 'B2DPlugin'> 13870 ^self primitiveFailed! ! 13871 13872!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! 13873primGetBezierStats: statsArray 13874 <primitive: 'primitiveGetBezierStats' module: 'B2DPlugin'> 13875 ^self primitiveFailed! ! 13876 13877!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! 13878primGetClipRect: rect 13879 <primitive: 'primitiveGetClipRect' module: 'B2DPlugin'> 13880 ^self primitiveFailed! ! 13881 13882!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! 13883primGetCounts: statsArray 13884 <primitive: 'primitiveGetCounts' module: 'B2DPlugin'> 13885 ^self primitiveFailed! ! 13886 13887!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! 13888primGetDepth 13889 <primitive: 'primitiveGetDepth' module: 'B2DPlugin'> 13890 ^self primitiveFailed! ! 13891 13892!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! 13893primGetFailureReason 13894 <primitive: 'primitiveGetFailureReason' module: 'B2DPlugin'> 13895 ^0! ! 13896 13897!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! 13898primGetOffset 13899 <primitive: 'primitiveGetOffset' module: 'B2DPlugin'> 13900 ^self primitiveFailed! ! 13901 13902!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! 13903primGetTimes: statsArray 13904 <primitive: 'primitiveGetTimes' module: 'B2DPlugin'> 13905 ^self primitiveFailed! ! 13906 13907!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! 13908primSetAALevel: level 13909 "Set the AA level" 13910 <primitive: 'primitiveSetAALevel' module: 'B2DPlugin'> 13911 ^self primitiveFailed! ! 13912 13913!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! 13914primSetClipRect: rect 13915 <primitive: 'primitiveSetClipRect' module: 'B2DPlugin'> 13916 ^self primitiveFailed! ! 13917 13918!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! 13919primSetColorTransform: transform 13920 <primitive: 'primitiveSetColorTransform' module: 'B2DPlugin'> 13921 ^self primitiveFailed! ! 13922 13923!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! 13924primSetDepth: depth 13925 <primitive: 'primitiveSetDepth' module: 'B2DPlugin'> 13926 ^self primitiveFailed! ! 13927 13928!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! 13929primSetEdgeTransform: transform 13930 <primitive: 'primitiveSetEdgeTransform' module: 'B2DPlugin'> 13931 ^self primitiveFailed! ! 13932 13933!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! 13934primSetOffset: point 13935 <primitive: 'primitiveSetOffset' module: 'B2DPlugin'> 13936 ^self primitiveFailed! ! 13937 13938 13939!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! 13940primAddBezierFrom: start to: end via: via leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex 13941 <primitive: 'primitiveAddBezier' module: 'B2DPlugin'> 13942 (self canProceedAfter: self primGetFailureReason) ifTrue:[ 13943 ^self primAddBezierFrom: start to: end via: via leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex 13944 ]. 13945 ^self primitiveFailed! ! 13946 13947!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! 13948primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill 13949 <primitive: 'primitiveAddBezierShape' module: 'B2DPlugin'> 13950 (self canProceedAfter: self primGetFailureReason) ifTrue:[ 13951 ^self primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill 13952 ]. 13953 ^self primitiveFailed! ! 13954 13955!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! 13956primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex 13957 <primitive: 'primitiveAddBitmapFill' module: 'B2DPlugin'> 13958 (self canProceedAfter: self primGetFailureReason) ifTrue:[ 13959 ^self primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex 13960 ]. 13961 ^self primitiveFailed! ! 13962 13963!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! 13964primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList 13965 <primitive: 'primitiveAddCompressedShape' module: 'B2DPlugin'> 13966 (self canProceedAfter: self primGetFailureReason) ifTrue:[ 13967 ^self primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList 13968 ]. 13969 ^self primitiveFailed! ! 13970 13971!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! 13972primAddExternalEdge: index initialX: initialX initialY: initialY initialZ: initialZ leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex 13973 <primitive: 'primitiveRegisterExternalEdge' module: 'B2DPlugin'> 13974 (self canProceedAfter: self primGetFailureReason) ifTrue:[ 13975 ^self primAddExternalEdge: index initialX: initialX initialY: initialY initialZ: initialZ leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex 13976 ]. 13977 ^self primitiveFailed! ! 13978 13979!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! 13980primAddExternalFill: index 13981 <primitive: 'primitiveRegisterExternalFill' module: 'B2DPlugin'> 13982 (self canProceedAfter: self primGetFailureReason) ifTrue:[ 13983 ^self primAddExternalFill: index 13984 ]. 13985 ^self primitiveFailed! ! 13986 13987!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! 13988primAddGradientFill: colorRamp from: origin along: direction normal: normal radial: isRadial 13989 <primitive: 'primitiveAddGradientFill' module: 'B2DPlugin'> 13990 (self canProceedAfter: self primGetFailureReason) ifTrue:[ 13991 ^self primAddGradientFill: colorRamp 13992 from: origin 13993 along: direction 13994 normal: normal 13995 radial: isRadial 13996 ]. 13997 ^self primitiveFailed! ! 13998 13999!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! 14000primAddLineFrom: start to: end leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex 14001 <primitive: 'primitiveAddLine' module: 'B2DPlugin'> 14002 (self canProceedAfter: self primGetFailureReason) ifTrue:[ 14003 ^self primAddLineFrom: start to: end leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex 14004 ]. 14005 ^self primitiveFailed! ! 14006 14007!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! 14008primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32 14009 <primitive: 'primitiveAddOval' module: 'B2DPlugin'> 14010 (self canProceedAfter: self primGetFailureReason) ifTrue:[ 14011 ^self primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32 14012 ]. 14013 ^self primitiveFailed! ! 14014 14015!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! 14016primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill 14017 <primitive: 'primitiveAddPolygon' module: 'B2DPlugin'> 14018 (self canProceedAfter: self primGetFailureReason) ifTrue:[ 14019 ^self primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill 14020 ]. 14021 ^self primitiveFailed! ! 14022 14023!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! 14024primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32 14025 <primitive: 'primitiveAddRect' module: 'B2DPlugin'> 14026 (self canProceedAfter: self primGetFailureReason) ifTrue:[ 14027 ^self primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32 14028 ]. 14029 ^self primitiveFailed! ! 14030 14031 14032!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'! 14033primAddActiveEdgeTableEntryFrom: edgeEntry 14034 "Add edge entry to the AET." 14035 <primitive: 'primitiveAddActiveEdgeEntry' module: 'B2DPlugin'> 14036 (self canProceedAfter: self primGetFailureReason) ifTrue:[ 14037 ^self primAddActiveEdgeTableEntryFrom: edgeEntry 14038 ]. 14039 ^self primitiveFailed! ! 14040 14041!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'! 14042primChangeActiveEdgeTableEntryFrom: edgeEntry 14043 "Change the entry in the active edge table from edgeEntry" 14044 <primitive: 'primitiveChangedActiveEdgeEntry' module: 'B2DPlugin'> 14045 ^self primitiveFailed! ! 14046 14047!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'! 14048primDisplaySpanBuffer 14049 "Display the current scan line if necessary" 14050 <primitive: 'primitiveDisplaySpanBuffer' module: 'B2DPlugin'> 14051 ^self primitiveFailed! ! 14052 14053!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! 14054primFinishedProcessing 14055 "Return true if there are no more entries in AET and GET and the last scan line has been displayed" 14056 <primitive: 'primitiveFinishedProcessing' module: 'B2DPlugin'> 14057 ^self primitiveFailed! ! 14058 14059!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! 14060primInitializeProcessing 14061 "Initialize processing in the GE. 14062 Create the active edge table and sort it." 14063 <primitive: 'primitiveInitializeProcessing' module: 'B2DPlugin'> 14064 ^self primitiveFailed! ! 14065 14066!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! 14067primMergeFill: fillBitmap from: fill 14068 "Merge the filled bitmap into the current output buffer." 14069 <primitive: 'primitiveMergeFillFrom' module: 'B2DPlugin'> 14070 ^self primitiveFailed! ! 14071 14072!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! 14073primNextActiveEdgeEntryInto: edgeEntry 14074 "Store the next entry of the AET at the current y-value in edgeEntry. 14075 Return false if there is no entry, true otherwise." 14076 <primitive: 'primitiveNextActiveEdgeEntry' module: 'B2DPlugin'> 14077 ^self primitiveFailed! ! 14078 14079!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! 14080primNextFillEntryInto: fillEntry 14081 "Store the next fill entry of the active edge table in fillEntry. 14082 Return false if there is no such entry, true otherwise" 14083 <primitive: 'primitiveNextFillEntry' module: 'B2DPlugin'> 14084 ^self primitiveFailed! ! 14085 14086!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! 14087primNextGlobalEdgeEntryInto: edgeEntry 14088 "Store the next entry of the GET at the current y-value in edgeEntry. 14089 Return false if there is no entry, true otherwise." 14090 <primitive: 'primitiveNextGlobalEdgeEntry' module: 'B2DPlugin'> 14091 ^self primitiveFailed! ! 14092 14093!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! 14094primRenderImage: edge with: fill 14095 "Start/Proceed rendering the current scan line" 14096 <primitive: 'primitiveRenderImage' module: 'B2DPlugin'> 14097 ^self primitiveFailed! ! 14098 14099!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! 14100primRenderScanline: edge with: fill 14101 "Start/Proceed rendering the current scan line" 14102 <primitive: 'primitiveRenderScanline' module: 'B2DPlugin'> 14103 ^self primitiveFailed! ! 14104 14105 14106!BalloonEngine methodsFor: 'primitives-misc' stamp: 'ar 2/2/2001 15:48'! 14107primCopyBufferFrom: oldBuffer to: newBuffer 14108 "Copy the contents of oldBuffer into the (larger) newBuffer" 14109 <primitive: 'primitiveCopyBuffer' module: 'B2DPlugin'> 14110 ^self primitiveFailed! ! 14111 14112!BalloonEngine methodsFor: 'primitives-misc' stamp: 'ar 2/2/2001 15:49'! 14113primInitializeBuffer: buffer 14114 <primitive: 'primitiveInitializeBuffer' module: 'B2DPlugin'> 14115 ^self primitiveFailed! ! 14116 14117"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 14118 14119BalloonEngine class 14120 instanceVariableNames: ''! 14121 14122!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/25/1998 17:37'! 14123debug: aBoolean 14124 "BalloonEngine debug: true" 14125 "BalloonEngine debug: false" 14126 Debug := aBoolean! ! 14127 14128!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! 14129doProfileStats: aBool 14130 "Note: On Macintosh systems turning on profiling can significantly 14131 degrade the performance of Balloon since we're using the high 14132 accuracy timer for measuring." 14133 "BalloonEngine doProfileStats: true" 14134 "BalloonEngine doProfileStats: false" 14135 <primitive: 'primitiveDoProfileStats' module: 'B2DPlugin'> 14136 ^false! ! 14137 14138!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/30/1998 23:57'! 14139printBezierStats 14140 "BalloonEngine printBezierStats" 14141 "BalloonEngine resetBezierStats" 14142 Transcript 14143 cr; nextPutAll:'Bezier statistics:'; 14144 crtab; print: (BezierStats at: 1); tab; nextPutAll:' non-monoton curves splitted'; 14145 crtab; print: (BezierStats at: 2); tab; nextPutAll:' curves splitted for numerical accuracy'; 14146 crtab; print: (BezierStats at: 3); tab; nextPutAll:' curves splitted to avoid integer overflow'; 14147 crtab; print: (BezierStats at: 4); tab; nextPutAll:' curves internally converted to lines'; 14148 endEntry.! ! 14149 14150!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/28/1998 23:59'! 14151printStat: time count: n string: aString 14152 Transcript 14153 cr; 14154 print: time; tab; 14155 nextPutAll:' mSecs -- '; 14156 print: n; tab; 14157 nextPutAll:' ops -- '; 14158 print: ((time asFloat / (n max: 1) asFloat) roundTo: 0.01); tab; 14159 nextPutAll: ' avg. mSecs/op -- '; 14160 nextPutAll: aString.! ! 14161 14162!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 1/12/1999 10:52'! 14163printStats 14164 "BalloonEngine doProfileStats: true" 14165 "BalloonEngine printStats" 14166 "BalloonEngine resetStats" 14167 Transcript cr; nextPutAll:'/************** BalloonEngine statistics ****************/'. 14168 self printStat: (Times at: 1) count: (Counts at: 1) string: 'Initialization'. 14169 self printStat: (Times at: 2) count: (Counts at: 2) string: 'Finish test'. 14170 self printStat: (Times at: 3) count: (Counts at: 3) string: 'Fetching/Adding GET entries'. 14171 self printStat: (Times at: 4) count: (Counts at: 4) string: 'Adding AET entries'. 14172 self printStat: (Times at: 5) count: (Counts at: 5) string: 'Fetching/Computing fills'. 14173 self printStat: (Times at: 6) count: (Counts at: 6) string: 'Merging fills'. 14174 self printStat: (Times at: 7) count: (Counts at: 7) string: 'Displaying span buffer'. 14175 self printStat: (Times at: 8) count: (Counts at: 8) string: 'Fetching/Updating AET entries'. 14176 self printStat: (Times at: 9) count: (Counts at: 9) string: 'Changing AET entries'. 14177 Transcript cr; print: Times sum; nextPutAll:' mSecs for all operations'. 14178 Transcript cr; print: Counts sum; nextPutAll: ' overall operations'. 14179 Transcript endEntry.! ! 14180 14181!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/30/1998 23:57'! 14182resetBezierStats 14183 BezierStats := WordArray new: 4.! ! 14184 14185!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/28/1998 23:38'! 14186resetStats 14187 Times := WordArray new: 10. 14188 Counts := WordArray new: 10.! ! 14189 14190 14191!BalloonEngine class methodsFor: 'initialization' stamp: 'ar 11/11/1998 22:49'! 14192initialize 14193 "BalloonEngine initialize" 14194 BufferCache := WeakArray new: 1. 14195 Smalltalk garbageCollect. "Make the cache old" 14196 CacheProtect := Semaphore forMutualExclusion. 14197 Times := WordArray new: 10. 14198 Counts := WordArray new: 10. 14199 BezierStats := WordArray new: 4. 14200 Debug ifNil:[Debug := false].! ! 14201 14202 14203!BalloonEngine class methodsFor: 'private' stamp: 'ar 11/11/1998 22:50'! 14204allocateOrRecycleBuffer: initialSize 14205 "Try to recycly a buffer. If this is not possibly, create a new one." 14206 | buffer | 14207 CacheProtect critical:[ 14208 buffer := BufferCache at: 1. 14209 BufferCache at: 1 put: nil. 14210 ]. 14211 ^buffer ifNil:[BalloonBuffer new: initialSize]! ! 14212 14213!BalloonEngine class methodsFor: 'private' stamp: 'ar 5/28/2000 22:17'! 14214primitiveSetBitBltPlugin: pluginName 14215 <primitive: 'primitiveSetBitBltPlugin' module: 'B2DPlugin'> 14216 ^nil! ! 14217 14218!BalloonEngine class methodsFor: 'private' stamp: 'eem 6/11/2008 13:00'! 14219recycleBuffer: balloonBuffer 14220 "Try to keep the buffer for later drawing operations." 14221 14222 CacheProtect critical:[ | buffer | 14223 buffer := BufferCache at: 1. 14224 (buffer isNil or:[buffer size < balloonBuffer size] ) 14225 ifTrue:[BufferCache at: 1 put: balloonBuffer]. 14226 ].! ! 14227SharedPool subclass: #BalloonEngineConstants 14228 instanceVariableNames: '' 14229 classVariableNames: 'BEAaLevelIndex BEBalloonEngineSize BEBitBltIndex BEClipRectIndex BEColorTransformIndex BEDeferredIndex BEDestOffsetIndex BEEdgeTransformIndex BEExternalsIndex BEFormsIndex BEPostFlushNeededIndex BESpanIndex BEWorkBufferIndex ETBalloonEdgeDataSize ETIndexIndex ETLinesIndex ETSourceIndex ETXValueIndex ETYValueIndex ETZValueIndex FTBalloonFillDataSize FTDestFormIndex FTIndexIndex FTMaxXIndex FTMinXIndex FTSourceIndex FTYValueIndex GBBaseSize GBBitmapDepth GBBitmapHeight GBBitmapRaster GBBitmapSize GBBitmapWidth GBColormapOffset GBColormapSize GBEndX GBEndY GBFinalX GBMBaseSize GBTileFlag GBUpdateDDX GBUpdateDDY GBUpdateDX GBUpdateDY GBUpdateData GBUpdateX GBUpdateY GBViaX GBViaY GBWideEntry GBWideExit GBWideExtent GBWideFill GBWideSize GBWideUpdateData GBWideWidth GEBaseEdgeSize GEBaseFillSize GEEdgeClipFlag GEEdgeFillsInvalid GEFillIndexLeft GEFillIndexRight GENumLines GEObjectIndex GEObjectLength GEObjectType GEObjectUnused GEPrimitiveBezier GEPrimitiveClippedBitmapFill GEPrimitiveEdge GEPrimitiveEdgeMask GEPrimitiveFill GEPrimitiveFillMask GEPrimitiveLine GEPrimitiveLinearGradientFill GEPrimitiveRadialGradientFill GEPrimitiveRepeatedBitmapFill GEPrimitiveTypeMask GEPrimitiveUnknown GEPrimitiveWide GEPrimitiveWideBezier GEPrimitiveWideEdge GEPrimitiveWideLine GEPrimitiveWideMask GEStateAddingFromGET GEStateBlitBuffer GEStateCompleted GEStateScanningAET GEStateUnlocked GEStateUpdateEdges GEStateWaitingChange GEStateWaitingForEdge GEStateWaitingForFill GEXValue GEYValue GEZValue GErrorAETEntry GErrorBadState GErrorFillEntry GErrorGETEntry GErrorNeedFlush GErrorNoMoreSpace GFDirectionX GFDirectionY GFNormalX GFNormalY GFOriginX GFOriginY GFRampLength GFRampOffset GGBaseSize GLBaseSize GLEndX GLEndY GLError GLErrorAdjDown GLErrorAdjUp GLWideEntry GLWideExit GLWideExtent GLWideFill GLWideSize GLWideWidth GLXDirection GLXIncrement GLYDirection GWAAColorMask GWAAColorShift GWAAHalfPixel GWAALevel GWAAScanMask GWAAShift GWAETStart GWAETUsed GWBezierHeightSubdivisions GWBezierLineConversions GWBezierMonotonSubdivisions GWBezierOverflowSubdivisions GWBufferTop GWClearSpanBuffer GWClipMaxX GWClipMaxY GWClipMinX GWClipMinY GWColorTransform GWCountAddAETEntry GWCountChangeAETEntry GWCountDisplaySpan GWCountFinishTest GWCountInitializing GWCountMergeFill GWCountNextAETEntry GWCountNextFillEntry GWCountNextGETEntry GWCurrentY GWCurrentZ GWDestOffsetX GWDestOffsetY GWEdgeTransform GWFillMaxX GWFillMaxY GWFillMinX GWFillMinY GWFillOffsetX GWFillOffsetY GWGETStart GWGETUsed GWHasClipShapes GWHasColorTransform GWHasEdgeTransform GWHeaderSize GWLastExportedEdge GWLastExportedFill GWLastExportedLeftX GWLastExportedRightX GWMagicIndex GWMagicNumber GWMinimalSize GWNeedsFlush GWObjStart GWObjUsed GWPoint1 GWPoint2 GWPoint3 GWPoint4 GWPointListFirst GWSize GWSpanEnd GWSpanEndAA GWSpanSize GWSpanStart GWState GWStopReason GWTimeAddAETEntry GWTimeChangeAETEntry GWTimeDisplaySpan GWTimeFinishTest GWTimeInitializing GWTimeMergeFill GWTimeNextAETEntry GWTimeNextFillEntry GWTimeNextGETEntry' 14230 poolDictionaries: '' 14231 category: 'Balloon-Engine'! 14232 14233"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 14234 14235BalloonEngineConstants class 14236 instanceVariableNames: ''! 14237 14238!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:55'! 14239initEdgeConstants 14240 "Initialize the edge constants" 14241 14242 "Edge primitive types" 14243 GEPrimitiveEdge := 2. "External edge - not handled by the GE" 14244 GEPrimitiveWideEdge := 3. "Wide external edge" 14245 GEPrimitiveLine := 4. "Straight line" 14246 GEPrimitiveWideLine := 5. "Wide line" 14247 GEPrimitiveBezier := 6. "Quadratic bezier curve" 14248 GEPrimitiveWideBezier := 7. "Wide bezier curve" 14249 14250 "Special flags" 14251 GEPrimitiveWide := 16r01. "Flag determining a wide primitive" 14252 GEPrimitiveWideMask := 16rFE. "Mask for clearing the wide flag" 14253 GEEdgeFillsInvalid := 16r10000. "Flag determining if left/right fills of an edge are invalid" 14254 GEEdgeClipFlag := 16r20000. "Flag determining if this is a clip edge" 14255 14256 "General edge state constants" 14257 GEXValue := 4. "Current raster x" 14258 GEYValue := 5. "Current raster y" 14259 GEZValue := 6. "Current raster z" 14260 GENumLines := 7. "Number of scan lines remaining" 14261 GEFillIndexLeft := 8. "Left fill index" 14262 GEFillIndexRight := 9. "Right fill index" 14263 GEBaseEdgeSize := 10. "Basic size of each edge" 14264 14265 "General fill state constants" 14266 GEBaseFillSize := 4. "Basic size of each fill" 14267 14268 "General Line state constants" 14269 GLXDirection := 10. "Direction of edge (1: left-to-right; -1: right-to-left)" 14270 GLYDirection := 11. "Direction of edge (1: top-to-bottom; -1: bottom-to-top)" 14271 GLXIncrement := 12. "Increment at each scan line" 14272 GLError := 13. "Current error" 14273 GLErrorAdjUp := 14. "Error to add at each scan line" 14274 GLErrorAdjDown := 15. "Error to subtract on roll-over" 14275 "Note: The following entries are only needed before the incremental 14276 state is computed. They are therefore aliased to the error values above" 14277 GLEndX := 14. "End X of line" 14278 GLEndY := 15. "End Y of line" 14279 GLBaseSize := 16. "Basic size of each line" 14280 14281 "Additional stuff for wide lines" 14282 GLWideFill := 16. "Current fill of line" 14283 GLWideWidth := 17. "Current width of line" 14284 GLWideEntry := 18. "Initial steps" 14285 GLWideExit := 19. "Final steps" 14286 GLWideExtent := 20. "Target width" 14287 GLWideSize := 21. "Size of wide lines" 14288 14289 "General Bezier state constants" 14290 GBUpdateData := 10. "Incremental update data for beziers" 14291 GBUpdateX := 0. "Last computed X value (24.8)" 14292 GBUpdateY := 1. "Last computed Y value (24.8)" 14293 GBUpdateDX := 2. "Delta X forward difference step (8.24)" 14294 GBUpdateDY := 3. "Delta Y forward difference step (8.24)" 14295 GBUpdateDDX := 4. "Delta DX forward difference step (8.24)" 14296 GBUpdateDDY := 5. "Delta DY forward difference step (8.24)" 14297 "Note: The following four entries are only needed before the incremental 14298 state is computed. They are therefore aliased to the incremental values above" 14299 GBViaX := 12. "via x" 14300 GBViaY := 13. "via y" 14301 GBEndX := 14. "end x" 14302 GBEndY := 15. "end y" 14303 GBBaseSize := 16. "Basic size of each bezier. 14304 Note: MUST be greater or equal to the size of lines" 14305 "Additional stuff for wide beziers" 14306 GBWideFill := 16. "Current fill of line" 14307 GBWideWidth := 17. "Current width of line" 14308 GBWideEntry := 18. "Initial steps" 14309 GBWideExit := 19. "Final steps" 14310 GBWideExtent := 20. "Target extent" 14311 GBFinalX := 21. "Final X value" 14312 GBWideUpdateData := 22. "Update data for second curve" 14313 GBWideSize := 28. "Size of wide beziers" 14314 14315! ! 14316 14317!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'! 14318initFillConstants 14319 "Initialize the fill constants" 14320 14321 "Fill primitive types" 14322 GEPrimitiveFill := 16r100. 14323 GEPrimitiveLinearGradientFill := 16r200. 14324 GEPrimitiveRadialGradientFill := 16r300. 14325 GEPrimitiveClippedBitmapFill := 16r400. 14326 GEPrimitiveRepeatedBitmapFill := 16r500. 14327 14328 "General fill state constants" 14329 GEBaseFillSize := 4. "Basic size of each fill" 14330 14331 "Oriented fill constants" 14332 GFOriginX := 4. "X origin of fill" 14333 GFOriginY := 5. "Y origin of fill" 14334 GFDirectionX := 6. "X direction of fill" 14335 GFDirectionY := 7. "Y direction of fill" 14336 GFNormalX := 8. "X normal of fill" 14337 GFNormalY := 9. "Y normal of fill" 14338 14339 "Gradient fill constants" 14340 GFRampLength := 10. "Length of following color ramp" 14341 GFRampOffset := 12. "Offset of first ramp entry" 14342 GGBaseSize := 12. 14343 14344 "Bitmap fill constants" 14345 GBBitmapWidth := 10. "Width of bitmap" 14346 GBBitmapHeight := 11. "Height of bitmap" 14347 GBBitmapDepth := 12. "Depth of bitmap" 14348 GBBitmapSize := 13. "Size of bitmap words" 14349 GBBitmapRaster := 14. "Size of raster line" 14350 GBColormapSize := 15. "Size of colormap, if any" 14351 GBTileFlag := 16. "True if the bitmap is tiled" 14352 GBColormapOffset := 18. "Offset of colormap, if any" 14353 GBMBaseSize := 18. "Basic size of bitmap fill" 14354! ! 14355 14356!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:59'! 14357initPrimitiveConstants 14358 "Initialize the primitive constants" 14359 14360 "Primitive type constants" 14361 GEPrimitiveUnknown := 0. 14362 GEPrimitiveEdgeMask := 16rFF. 14363 GEPrimitiveFillMask := 16rFF00. 14364 GEPrimitiveTypeMask := 16rFFFF. 14365 14366 "General state constants (Note: could be compressed later)" 14367 GEObjectType := 0. "Type of object" 14368 GEObjectLength := 1. "Length of object" 14369 GEObjectIndex := 2. "Index into external objects" 14370 GEObjectUnused := 3. "Currently unused" 14371 14372! ! 14373 14374!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:00'! 14375initStateConstants 14376 "Initialize the state Constants" 14377 14378 GEStateUnlocked := 0. "Buffer is unlocked and can be modified as wanted" 14379 GEStateAddingFromGET := 1. "Adding edges from the GET" 14380 GEStateWaitingForEdge := 2. "Waiting for edges added to GET" 14381 GEStateScanningAET := 3. "Scanning the active edge table" 14382 GEStateWaitingForFill := 4. "Waiting for a fill to mix in during AET scan" 14383 GEStateBlitBuffer := 5. "Blt the current scan line" 14384 GEStateUpdateEdges := 6. "Update edges to next scan line" 14385 GEStateWaitingChange := 7. "Waiting for a changed edge" 14386 GEStateCompleted := 8. "Rendering completed" 14387 14388 "Error constants" 14389 GErrorNoMoreSpace := 1. "No more space in collection" 14390 GErrorBadState := 2. "Tried to call a primitive while engine in bad state" 14391 GErrorNeedFlush := 3. "Tried to call a primitive that requires flushing before" 14392 14393 "Incremental error constants" 14394 GErrorGETEntry := 4. "Unknown entry in GET" 14395 GErrorFillEntry := 5. "Unknown FILL encountered" 14396 GErrorAETEntry := 6. "Unknown entry in AET" 14397! ! 14398 14399!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:04'! 14400initWorkBufferConstants 14401 "Initialize the work buffer constants" 14402 14403 "General work buffer constants" 14404 GWMagicNumber := 16r416E6469. "Magic number" 14405 GWHeaderSize := 128. "Size of header" 14406 GWMinimalSize := 256. "Minimal size of work buffer" 14407 14408 "Header entries" 14409 GWMagicIndex := 0. "Index of magic number" 14410 GWSize := 1. "Size of full buffer" 14411 GWState := 2. "Current state (e.g., locked or not." 14412 "Buffer entries" 14413 GWObjStart := 8. "objStart" 14414 GWObjUsed := 9. "objUsed" 14415 GWBufferTop := 10. "wbTop" 14416 GWGETStart := 11. "getStart" 14417 GWGETUsed := 12. "getUsed" 14418 GWAETStart := 13. "aetStart" 14419 GWAETUsed := 14. "aetUsed" 14420 14421 "Transform entries" 14422 GWHasEdgeTransform := 16. "True if we have an edge transformation" 14423 GWHasColorTransform := 17. "True if we have a color transformation" 14424 GWEdgeTransform := 18. "2x3 edge transformation" 14425 GWColorTransform := 24. "8 word RGBA color transformation" 14426 14427 "Span entries" 14428 GWSpanStart := 32. "spStart" 14429 GWSpanSize := 33. "spSize" 14430 GWSpanEnd := 34. "spEnd" 14431 GWSpanEndAA := 35. "spEndAA" 14432 14433 "Bounds entries" 14434 GWFillMinX := 36. "fillMinX" 14435 GWFillMaxX := 37. "fillMaxX" 14436 GWFillMinY := 38. "fillMinY" 14437 GWFillMaxY := 39. "fillMaxY" 14438 GWFillOffsetX := 40. "fillOffsetX" 14439 GWFillOffsetY := 41. "fillOffsetY" 14440 GWClipMinX := 42. 14441 GWClipMaxX := 43. 14442 GWClipMinY := 44. 14443 GWClipMaxY := 45. 14444 GWDestOffsetX := 46. 14445 GWDestOffsetY := 47. 14446 14447 "AA entries" 14448 GWAALevel := 48. "aaLevel" 14449 GWAAShift := 49. "aaShift" 14450 GWAAColorShift := 50. "aaColorShift" 14451 GWAAColorMask := 51. "aaColorMask" 14452 GWAAScanMask := 52. "aaScanMask" 14453 GWAAHalfPixel := 53. "aaHalfPixel" 14454 14455 "Misc entries" 14456 GWNeedsFlush := 63. "True if the engine may need a flush" 14457 GWStopReason := 64. "stopReason" 14458 GWLastExportedEdge := 65. "last exported edge" 14459 GWLastExportedFill := 66. "last exported fill" 14460 GWLastExportedLeftX := 67. "last exported leftX" 14461 GWLastExportedRightX := 68. "last exported rightX" 14462 GWClearSpanBuffer := 69. "Do we have to clear the span buffer?" 14463 GWPointListFirst := 70. "First point list in buffer" 14464 14465 GWPoint1 := 80. 14466 GWPoint2 := 82. 14467 GWPoint3 := 84. 14468 GWPoint4 := 86. 14469 14470 GWCurrentY := 88. 14471 14472 "Profile stats" 14473 GWTimeInitializing := 90. 14474 GWCountInitializing := 91. 14475 GWTimeFinishTest := 92. 14476 GWCountFinishTest := 93. 14477 GWTimeNextGETEntry := 94. 14478 GWCountNextGETEntry := 95. 14479 GWTimeAddAETEntry := 96. 14480 GWCountAddAETEntry := 97. 14481 GWTimeNextFillEntry := 98. 14482 GWCountNextFillEntry := 99. 14483 GWTimeMergeFill := 100. 14484 GWCountMergeFill := 101. 14485 GWTimeDisplaySpan := 102. 14486 GWCountDisplaySpan := 103. 14487 GWTimeNextAETEntry := 104. 14488 GWCountNextAETEntry := 105. 14489 GWTimeChangeAETEntry := 106. 14490 GWCountChangeAETEntry := 107. 14491 14492 "Bezier stats" 14493 GWBezierMonotonSubdivisions := 108. "# of subdivision due to non-monoton beziers" 14494 GWBezierHeightSubdivisions := 109. "# of subdivisions due to excessive height" 14495 GWBezierOverflowSubdivisions := 110. "# of subdivisions due to possible int overflow" 14496 GWBezierLineConversions := 111. "# of beziers converted to lines" 14497 14498 GWHasClipShapes := 112. "True if the engine contains clip shapes" 14499 GWCurrentZ := 113. "Current z value of primitives" 14500! ! 14501 14502!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'! 14503initialize 14504 "BalloonEngineConstants initialize" 14505 self initStateConstants. 14506 self initWorkBufferConstants. 14507 self initPrimitiveConstants. 14508 self initEdgeConstants. 14509 self initFillConstants. 14510 self initializeInstVarNames: BalloonEngine prefixedBy: 'BE'. 14511 self initializeInstVarNames: BalloonEdgeData prefixedBy: 'ET'. 14512 self initializeInstVarNames: BalloonFillData prefixedBy: 'FT'.! ! 14513 14514!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:07'! 14515initializeInstVarNames: aClass prefixedBy: aString 14516 14517 | token value | 14518 aClass instVarNames doWithIndex:[:instVarName :index| 14519 token := (aString, instVarName first asUppercase asString, (instVarName copyFrom: 2 to: instVarName size),'Index') asSymbol. 14520 value := index - 1. 14521 (self bindingOf: token) ifNil:[self addClassVarName: token]. 14522 (self bindingOf: token) value: value. 14523 ]. 14524 token := (aString, aClass name,'Size') asSymbol. 14525 (self bindingOf: token) ifNil:[self addClassVarName: token]. 14526 (self bindingOf: token) value: aClass instSize.! ! 14527Object subclass: #BalloonFillData 14528 instanceVariableNames: 'index minX maxX yValue source destForm' 14529 classVariableNames: '' 14530 poolDictionaries: '' 14531 category: 'Balloon-Simulation'! 14532!BalloonFillData commentStamp: '<historical>' prior: 0! 14533This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! 14534 14535 14536!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! 14537destForm 14538 ^destForm! ! 14539 14540!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! 14541destForm: aForm 14542 destForm := aForm! ! 14543 14544!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! 14545index 14546 ^index! ! 14547 14548!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! 14549index: anInteger 14550 index := anInteger! ! 14551 14552!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! 14553maxX 14554 ^maxX! ! 14555 14556!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! 14557maxX: anInteger 14558 maxX := anInteger! ! 14559 14560!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! 14561minX 14562 ^minX! ! 14563 14564!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! 14565minX: anInteger 14566 minX := anInteger! ! 14567 14568!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! 14569source 14570 ^source! ! 14571 14572!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! 14573source: anObject 14574 source := anObject! ! 14575 14576!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/28/1998 16:35'! 14577width 14578 ^maxX - minX! ! 14579 14580!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! 14581yValue 14582 ^yValue! ! 14583 14584!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! 14585yValue: anInteger 14586 yValue := anInteger! ! 14587 14588 14589!BalloonFillData methodsFor: 'computing' stamp: 'ar 11/14/1998 19:32'! 14590computeFill 14591 (destForm isNil or:[destForm width < self width]) ifTrue:[ 14592 destForm := Form extent: (self width + 10) @ 1 depth: 32. 14593 ]. 14594 source computeFillFrom: minX to: maxX at: yValue in: destForm! ! 14595TestCase subclass: #BalloonFontTest 14596 instanceVariableNames: '' 14597 classVariableNames: '' 14598 poolDictionaries: '' 14599 category: 'MorphicTests-Widgets'! 14600 14601!BalloonFontTest methodsFor: 'tests' stamp: 'sd 12/9/2001 21:44'! 14602testDefaultFont 14603 "(self selector: #testDefaultFont) debug" 14604 self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont. 14605 self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont.! ! 14606 14607!BalloonFontTest methodsFor: 'tests' stamp: 'sd 12/9/2001 21:55'! 14608testSpecificFont 14609 "(self selector: #testSpecificFont) debug" 14610 | aMorph | 14611 aMorph := RectangleMorph new. 14612 self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont. 14613 self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont. 14614 aMorph 14615 balloonFont: (StrikeFont familyName: #ComicPlain size: 19). 14616 self assert: aMorph balloonFont 14617 = (StrikeFont familyName: #ComicPlain size: 19). 14618 "The next test is horrible because I do no know how to access the font 14619 with the appropiate interface" 14620 self assert: (((BalloonMorph getTextMorph: 'lulu' for: aMorph) text runs at: 1) 14621 at: 1) font 14622 = (StrikeFont familyName: #ComicPlain size: 19)! ! 14623Object subclass: #BalloonLineSimulation 14624 instanceVariableNames: 'start end xIncrement xDirection error errorAdjUp errorAdjDown' 14625 classVariableNames: '' 14626 poolDictionaries: '' 14627 category: 'Balloon-Simulation'! 14628!BalloonLineSimulation commentStamp: '<historical>' prior: 0! 14629This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! 14630 14631 14632!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! 14633end 14634 ^end! ! 14635 14636!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! 14637end: aPoint 14638 end := aPoint! ! 14639 14640!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'! 14641initialX 14642 ^start y <= end y 14643 ifTrue:[start x] 14644 ifFalse:[end x]! ! 14645 14646!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'! 14647initialY 14648 ^start y <= end y 14649 ifTrue:[start y] 14650 ifFalse:[end y]! ! 14651 14652!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'! 14653initialZ 14654 ^0 "Assume no depth given"! ! 14655 14656!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! 14657start 14658 ^start! ! 14659 14660!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! 14661start: aPoint 14662 start := aPoint! ! 14663 14664 14665!BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:52'! 14666computeInitialStateFrom: source with: aTransformation 14667 "Compute the initial state in the receiver." 14668 start := (aTransformation localPointToGlobal: source start) asIntegerPoint. 14669 end := (aTransformation localPointToGlobal: source end) asIntegerPoint.! ! 14670 14671!BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:22'! 14672stepToFirstScanLineAt: yValue in: edgeTableEntry 14673 "Compute the initial x value for the scan line at yValue" 14674 | startX endX startY endY yDir deltaY deltaX widthX | 14675 (start y) <= (end y) ifTrue:[ 14676 startX := start x. endX := end x. 14677 startY := start y. endY := end y. 14678 yDir := 1. 14679 ] ifFalse:[ 14680 startX := end x. endX := start x. 14681 startY := end y. endY := start y. 14682 yDir := -1. 14683 ]. 14684 14685 deltaY := endY - startY. 14686 deltaX := endX - startX. 14687 14688 "Quickly check if the line is visible at all" 14689 (yValue >= endY or:[deltaY = 0]) ifTrue:[^edgeTableEntry lines: 0]. 14690 14691 "Check if edge goes left to right" 14692 deltaX >= 0 ifTrue:[ 14693 xDirection := 1. 14694 widthX := deltaX. 14695 error := 0. 14696 ] ifFalse:[ 14697 xDirection := -1. 14698 widthX := 0 - deltaX. 14699 error := 1 - deltaY. 14700 ]. 14701 14702 "Check if edge is horizontal" 14703 deltaY = 0 14704 ifTrue:[ xIncrement := 0. 14705 errorAdjUp := 0] 14706 ifFalse:["Check if edge is y-major" 14707 deltaY > widthX 14708 ifTrue:[ xIncrement := 0. 14709 errorAdjUp := widthX] 14710 ifFalse:[ xIncrement := (widthX // deltaY) * xDirection. 14711 errorAdjUp := widthX \\ deltaY]]. 14712 14713 errorAdjDown := deltaY. 14714 14715 edgeTableEntry xValue: startX. 14716 edgeTableEntry lines: deltaY. 14717 14718 "If not at first scan line then step down to yValue" 14719 yValue = startY ifFalse:[ 14720 startY to: yValue do:[:y| self stepToNextScanLineAt: y in: edgeTableEntry]. 14721 "And adjust remainingLines" 14722 edgeTableEntry lines: deltaY - (yValue - startY). 14723 ].! ! 14724 14725!BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:39'! 14726stepToNextScanLineAt: yValue in: edgeTableEntry 14727 "Compute the next x value for the scan line at yValue. 14728 This message is sent during incremental updates. 14729 The yValue parameter is passed in here for edges 14730 that have more complicated computations," 14731 | x | 14732 x := edgeTableEntry xValue + xIncrement. 14733 error := error + errorAdjUp. 14734 error > 0 ifTrue:[ 14735 x := x + xDirection. 14736 error := error - errorAdjDown. 14737 ]. 14738 edgeTableEntry xValue: x.! ! 14739 14740!BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/29/1998 23:42'! 14741subdivide 14742 ^nil! ! 14743 14744 14745!BalloonLineSimulation methodsFor: 'printing' stamp: 'ar 10/27/1998 23:20'! 14746printOn: aStream 14747 aStream 14748 nextPutAll: self class name; 14749 nextPut:$(; 14750 print: start; 14751 nextPutAll:' - '; 14752 print: end; 14753 nextPut:$)! ! 14754 14755!BalloonLineSimulation methodsFor: 'printing' stamp: 'MPW 1/1/1901 21:57'! 14756printOnStream: aStream 14757 aStream 14758 print: self class name; 14759 print:'('; 14760 write: start; 14761 print:' - '; 14762 write: end; 14763 print:')'.! ! 14764PolygonMorph subclass: #BalloonMorph 14765 instanceVariableNames: 'target offsetFromTarget balloonOwner' 14766 classVariableNames: 'BalloonColor BalloonFont' 14767 poolDictionaries: '' 14768 category: 'Morphic-Widgets'! 14769!BalloonMorph commentStamp: '<historical>' prior: 0! 14770A balloon with text used for the display of explanatory information. 14771 14772Balloon help is integrated into Morphic as follows: 14773If a Morph has the property #balloonText, then it will respond to #showBalloon by adding a text balloon to the world, and to #deleteBalloon by removing the balloon. 14774 14775Moreover, if mouseOverEnabled is true (see class msg), then the Hand will arrange to cause display of the balloon after the mouse has lingered over the morph for a while, and removal of the balloon when the mouse leaves the bounds of that morph. In any case, the Hand will attempt to remove any such balloons before handling mouseDown events, or displaying other balloons. 14776 14777Balloons should not be duplicated with veryDeepCopy unless their target is also duplicated at the same time.! 14778 14779 14780!BalloonMorph methodsFor: 'accessing' stamp: 'ar 10/3/2000 17:19'! 14781balloonOwner 14782 ^balloonOwner! ! 14783 14784 14785!BalloonMorph methodsFor: 'initialization' stamp: 'dgd 3/12/2006 14:27'! 14786defaultBorderColor 14787 "answer the default border color/fill style for the receiver" 14788 ^ self defaultColor muchDarker"Color black"! ! 14789 14790!BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! 14791defaultBorderWidth 14792 "answer the default border width for the receiver" 14793 ^ 1! ! 14794 14795!BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! 14796defaultColor 14797 "answer the default color/fill style for the receiver" 14798 ^ self class balloonColor! ! 14799 14800!BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:20'! 14801initialize 14802 "initialize the state of the receiver" 14803 super initialize. 14804 "" 14805 self beSmoothCurve. 14806 14807 offsetFromTarget := 0 @ 0! ! 14808 14809!BalloonMorph methodsFor: 'initialization' stamp: 'ar 10/4/2000 10:13'! 14810popUpFor: aMorph hand: aHand 14811 "Pop up the receiver as balloon help for the given hand" 14812 balloonOwner := aMorph. 14813 self popUpForHand: aHand.! ! 14814 14815!BalloonMorph methodsFor: 'initialization' stamp: 'RAA 7/1/2001 18:48'! 14816popUpForHand: aHand 14817 "Pop up the receiver as balloon help for the given hand" 14818 | worldBounds | 14819 14820 self lock. 14821 self fullBounds. "force layout" 14822 self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber. 14823 aHand world addMorphFront: self. 14824 "So that if the translation below makes it overlap the receiver, it won't 14825 interfere with the rootMorphsAt: logic and hence cause flashing. Without 14826 this, flashing happens, believe me!!" 14827 ((worldBounds := aHand world bounds) containsRect: self bounds) ifFalse: 14828 [self bounds: (self bounds translatedToBeWithin: worldBounds)]. 14829 aHand balloonHelp: self. 14830! ! 14831 14832 14833!BalloonMorph methodsFor: 'menus' stamp: 'wiz 12/30/2004 17:14'! 14834adjustedCenter 14835 "Return the center of the original textMorph box within the balloon." 14836 14837 ^ (self vertices last: 4) average rounded ! ! 14838 14839 14840!BalloonMorph methodsFor: 'stepping and presenter' stamp: 'sma 12/23/1999 14:05'! 14841step 14842 "Move with target." 14843 14844 target ifNotNil: [self position: target position + offsetFromTarget]. 14845! ! 14846 14847 14848!BalloonMorph methodsFor: 'testing' stamp: 'di 9/18/97 10:10'! 14849stepTime 14850 ^ 0 "every cycle"! ! 14851 14852 14853!BalloonMorph methodsFor: 'wiw support' stamp: 'RAA 6/27/2000 18:07'! 14854morphicLayerNumber 14855 14856 "helpful for insuring some morphs always appear in front of or behind others. 14857 smaller numbers are in front" 14858 14859 ^5 "Balloons are very front-like things"! ! 14860 14861 14862!BalloonMorph methodsFor: 'private' stamp: 'sma 12/23/1999 14:06'! 14863setTarget: aMorph 14864 (target := aMorph) ifNotNil: [offsetFromTarget := self position - target position]! ! 14865 14866"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 14867 14868BalloonMorph class 14869 instanceVariableNames: ''! 14870 14871!BalloonMorph class methodsFor: '*FreeType-override' stamp: 'tween 8/7/2007 01:59'! 14872chooseBalloonFont 14873 "BalloonMorph chooseBalloonFont" 14874 14875 Preferences 14876 chooseFontWithPrompt: 'Ballon Help font...' translated 14877 andSendTo: self 14878 withSelector: #setBalloonFontTo: 14879 highlightSelector: #balloonFont! ! 14880 14881 14882!BalloonMorph class methodsFor: 'instance creation' stamp: 'sma 12/23/1999 20:05'! 14883string: str for: morph 14884 ^ self string: str for: morph corner: #bottomLeft! ! 14885 14886!BalloonMorph class methodsFor: 'instance creation' stamp: 'sd 12/5/2001 20:27'! 14887string: str for: morph corner: cornerName 14888 "Make up and return a balloon for morph. Find the quadrant that 14889 clips the text the least, using cornerName as a tie-breaker. tk 9/12/97" 14890 | tm vertices | 14891 tm := self getTextMorph: str for: morph. 14892 vertices := self getVertices: tm bounds. 14893 vertices := self 14894 getBestLocation: vertices 14895 for: morph 14896 corner: cornerName. 14897 ^ self new color: morph balloonColor; 14898 setVertices: vertices; 14899 addMorph: tm; 14900 setTarget: morph! ! 14901 14902 14903!BalloonMorph class methodsFor: 'utility' stamp: 'sma 11/11/2000 14:59'! 14904balloonColor 14905 ^ BalloonColor! ! 14906 14907!BalloonMorph class methodsFor: 'utility' stamp: 'sw 1/31/2000 15:43'! 14908balloonFont 14909 ^ BalloonFont! ! 14910 14911!BalloonMorph class methodsFor: 'utility' stamp: 'sma 11/11/2000 14:59'! 14912setBalloonColorTo: aColor 14913 aColor ifNotNil: [BalloonColor := aColor]! ! 14914 14915!BalloonMorph class methodsFor: 'utility' stamp: 'sw 1/31/2000 15:40'! 14916setBalloonFontTo: aFont 14917 aFont ifNotNil: [BalloonFont := aFont]! ! 14918 14919 14920!BalloonMorph class methodsFor: 'private' stamp: 'wiz 1/24/2005 00:32'! 14921getBestLocation: vertices for: morph corner: cornerName 14922 "Try four rel locations of the balloon for greatest unclipped area. 12/99 sma" 14923 14924 | rect maxArea verts rectCorner morphPoint mbc a mp dir bestVerts result usableArea | 14925 "wiz 1/8/2005 Choose rect independantly of vertice order or size. Would be nice it this took into account curveBounds but it does not." 14926 rect := Rectangle encompassing: vertices. 14927 maxArea := -1. 14928 verts := vertices. 14929 usableArea := (morph world ifNil: [self currentWorld]) viewBox. 14930 1 to: 4 do: [:i | 14931 dir := #(vertical horizontal) atWrap: i. 14932 verts := verts collect: [:p | p flipBy: dir centerAt: rect center]. 14933 rectCorner := #(bottomLeft bottomRight topRight topLeft) at: i. 14934 morphPoint := #(topCenter topCenter bottomCenter bottomCenter) at: i. 14935 a := ((rect 14936 align: (rect perform: rectCorner) 14937 with: (mbc := morph boundsForBalloon perform: morphPoint)) 14938 intersect: usableArea) area. 14939 (a > maxArea or: [a = rect area and: [rectCorner = cornerName]]) ifTrue: 14940 [maxArea := a. 14941 bestVerts := verts. 14942 mp := mbc]]. 14943 result := bestVerts collect: [:p | p + (mp - bestVerts first)] "Inlined align:with:". 14944 ^ result! ! 14945 14946!BalloonMorph class methodsFor: 'private' stamp: 'sd 12/5/2001 20:28'! 14947getTextMorph: aStringOrMorph for: balloonOwner 14948 "Construct text morph." 14949 | m text | 14950 aStringOrMorph isMorph 14951 ifTrue: [m := aStringOrMorph] 14952 ifFalse: [BalloonFont 14953 ifNil: [text := aStringOrMorph] 14954 ifNotNil: [text := Text 14955 string: aStringOrMorph 14956 attribute: (TextFontReference toFont: balloonOwner balloonFont)]. 14957 m := (TextMorph new contents: text) centered]. 14958 m setToAdhereToEdge: #adjustedCenter. 14959 ^ m! ! 14960 14961!BalloonMorph class methodsFor: 'private' stamp: 'wiz 1/8/2005 18:05'! 14962getVertices: bounds 14963 "Construct vertices for a balloon up and to left of anchor" 14964 14965 | corners | 14966 corners := bounds corners atAll: #(1 4 3 2). 14967 ^ (Array 14968 with: corners first + (0 - bounds width // 2 @ 0) 14969 with: corners first + (0 - bounds width // 4 @ (bounds height // 2))) , corners! ! 14970RectangleMorph subclass: #BalloonRectangleMorph 14971 instanceVariableNames: '' 14972 classVariableNames: '' 14973 poolDictionaries: '' 14974 category: 'Morphic-Balloon'! 14975!BalloonRectangleMorph commentStamp: '<historical>' prior: 0! 14976BalloonRectangleMorph is an example for drawing using the BalloonEngine.! 14977 14978 14979!BalloonRectangleMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 22:24'! 14980doesBevels 14981 "To return true means that this object can show bevelled borders, and 14982 therefore can accept, eg, #raised or #inset as valid borderColors. 14983 Must be overridden by subclasses that do not support bevelled borders." 14984 14985 ^ false! ! 14986 14987 14988!BalloonRectangleMorph methodsFor: 'drawing' stamp: 'ar 11/15/1998 22:40'! 14989drawOn: aCanvas 14990 (color isKindOf: OrientedFillStyle) ifTrue:[ 14991 color origin: bounds center. 14992 color direction: (bounds extent x * 0.7) @ 0. 14993 color normal: 0@(bounds extent y * 0.7). 14994 ]. 14995 (borderColor isKindOf: OrientedFillStyle) ifTrue:[ 14996 borderColor origin: bounds topLeft. 14997 borderColor direction: (bounds extent x) @ 0. 14998 borderColor normal: 0@(bounds extent y). 14999 ]. 15000 aCanvas asBalloonCanvas 15001 drawRectangle: (bounds insetBy: borderWidth // 2) 15002 color: color 15003 borderWidth: borderWidth 15004 borderColor: borderColor.! ! 15005 15006 15007!BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! 15008defaultBorderColor 15009 "answer the default border color/fill style for the receiver" 15010 ^ GradientFillStyle ramp: {0.0 -> Color black. 1.0 -> Color white}! ! 15011 15012!BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! 15013defaultBorderWidth 15014 "answer the default border width for the receiver" 15015 ^ 10! ! 15016 15017!BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! 15018defaultColor 15019 "answer the default color/fill style for the receiver" 15020 | result | 15021 result := GradientFillStyle ramp: {0.0 -> Color green. 0.5 -> Color yellow. 1.0 -> Color red}. 15022 result radial: true. 15023 ^ result! ! 15024 15025!BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:41'! 15026initialize 15027"initialize the state of the receiver" 15028 super initialize. 15029"" 15030 self extent: 100 @ 100! ! 15031 15032 15033!BalloonRectangleMorph methodsFor: 'rotate scale and flex' stamp: 'ar 11/15/1998 22:20'! 15034newTransformationMorph 15035 ^MatrixTransformMorph new! ! 15036 15037 15038!BalloonRectangleMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:08'! 15039canDrawBorder: aBorderStyle 15040 ^aBorderStyle style == #simple! ! 15041Object subclass: #BalloonSolidFillSimulation 15042 instanceVariableNames: 'color' 15043 classVariableNames: '' 15044 poolDictionaries: '' 15045 category: 'Balloon-Simulation'! 15046!BalloonSolidFillSimulation commentStamp: '<historical>' prior: 0! 15047This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! 15048 15049 15050!BalloonSolidFillSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:07'! 15051computeFillFrom: minX to: maxX at: yValue in: form 15052 | bb | 15053 color isTransparent ifFalse:[ 15054 bb := BitBlt toForm: form. 15055 bb fillColor: color. 15056 bb destX: 0 destY: 0 width: (maxX - minX) height: 1. 15057 bb combinationRule: Form over. 15058 bb copyBits].! ! 15059 15060!BalloonSolidFillSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:08'! 15061computeInitialStateFrom: source with: aColorTransform 15062 color := source asColor.! ! 15063Object subclass: #BalloonState 15064 instanceVariableNames: 'transform colorTransform aaLevel' 15065 classVariableNames: '' 15066 poolDictionaries: '' 15067 category: 'Balloon-Engine'! 15068!BalloonState commentStamp: '<historical>' prior: 0! 15069This class is a repository for data which needs to be preserved during certain operations of BalloonCanvas.! 15070 15071 15072!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:47'! 15073aaLevel 15074 ^aaLevel! ! 15075 15076!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:47'! 15077aaLevel: aNumber 15078 aaLevel := aNumber! ! 15079 15080!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'! 15081colorTransform 15082 ^colorTransform! ! 15083 15084!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'! 15085colorTransform: aColorTransform 15086 colorTransform := aColorTransform! ! 15087 15088!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:41'! 15089transform 15090 ^transform! ! 15091 15092!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'! 15093transform: aMatrixTransform 15094 transform := aMatrixTransform! ! 15095MimeConverter subclass: #Base64MimeConverter 15096 instanceVariableNames: 'data' 15097 classVariableNames: 'FromCharTable ToCharTable' 15098 poolDictionaries: '' 15099 category: 'Network-MIME'! 15100!Base64MimeConverter commentStamp: '<historical>' prior: 0! 15101This class encodes and decodes data in Base64 format. This is MIME encoding. We translate a whole stream at once, taking a Stream as input and giving one as output. Returns a whole stream for the caller to use. 15102 0 A 17 R 34 i 51 z 15103 1 B 18 S 35 j 52 0 15104 2 C 19 T 36 k 53 1 15105 3 D 20 U 37 l 54 2 15106 4 E 21 V 38 m 55 3 15107 5 F 22 W 39 n 56 4 15108 6 G 23 X 40 o 57 5 15109 7 H 24 Y 41 p 58 6 15110 8 I 25 Z 42 q 59 7 15111 9 J 26 a 43 r 60 8 15112 10 K 27 b 44 s 61 9 15113 11 L 28 c 45 t 62 + 15114 12 M 29 d 46 u 63 / 15115 13 N 30 e 47 v 15116 14 O 31 f 48 w (pad) = 15117 15 P 32 g 49 x 15118 16 Q 33 h 50 y 15119Outbound: bytes are broken into 6 bit chunks, and the 0-63 value is converted to a character. 3 data bytes go into 4 characters. 15120Inbound: Characters are translated in to 0-63 values and shifted into 8 bit bytes. 15121 15122(See: N. Borenstein, Bellcore, N. Freed, Innosoft, Network Working Group, Request for Comments: RFC 1521, September 1993, MIME (Multipurpose Internet Mail Extensions) Part One: Mechanisms for Specifying and Describing the Format of Internet Message Bodies. Sec 6.2) 15123 15124By Ted Kaehler, based on Tim Olson's Base64Filter.! 15125 15126 15127!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:34'! 15128mimeDecode 15129 "Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full byte stream of characters. Reutrn a whole stream for the user to read." 15130 15131 | nibA nibB nibC nibD | 15132 [mimeStream atEnd] whileFalse: [ 15133 (nibA := self nextValue) ifNil: [^ dataStream]. 15134 (nibB := self nextValue) ifNil: [^ dataStream]. 15135 dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)) asCharacter. 15136 nibB := nibB bitAnd: 16rF. 15137 (nibC := self nextValue) ifNil: [^ dataStream]. 15138 dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)) asCharacter. 15139 nibC := nibC bitAnd: 16r3. 15140 (nibD := self nextValue) ifNil: [^ dataStream]. 15141 dataStream nextPut: ((nibC bitShift: 6) + nibD) asCharacter. 15142 ]. 15143 ^ dataStream! ! 15144 15145!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:39'! 15146mimeDecodeToByteArray 15147 "Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full ByteArray of 0-255 values. Reutrn a whole stream for the user to read." 15148 15149 | nibA nibB nibC nibD | 15150 [mimeStream atEnd] whileFalse: [ 15151 (nibA := self nextValue) ifNil: [^ dataStream]. 15152 (nibB := self nextValue) ifNil: [^ dataStream]. 15153 dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)). 15154 nibB := nibB bitAnd: 16rF. 15155 (nibC := self nextValue) ifNil: [^ dataStream]. 15156 dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)). 15157 nibC := nibC bitAnd: 16r3. 15158 (nibD := self nextValue) ifNil: [^ dataStream]. 15159 dataStream nextPut: ((nibC bitShift: 6) + nibD). 15160 ]. 15161 ^ dataStream! ! 15162 15163!Base64MimeConverter methodsFor: 'conversion' stamp: 'ls 2/10/2001 13:26'! 15164mimeEncode 15165 "Convert from data to 6 bit characters." 15166 15167 | phase1 phase2 raw nib lineLength | 15168 phase1 := phase2 := false. 15169 lineLength := 0. 15170 [dataStream atEnd] whileFalse: [ 15171 lineLength >= 70 ifTrue: [ mimeStream cr. lineLength := 0. ]. 15172 data := raw := dataStream next asInteger. 15173 nib := (data bitAnd: 16rFC) bitShift: -2. 15174 mimeStream nextPut: (ToCharTable at: nib+1). 15175 (raw := dataStream next) ifNil: [raw := 0. phase1 := true]. 15176 data := ((data bitAnd: 3) bitShift: 8) + raw asInteger. 15177 nib := (data bitAnd: 16r3F0) bitShift: -4. 15178 mimeStream nextPut: (ToCharTable at: nib+1). 15179 (raw := dataStream next) ifNil: [raw := 0. phase2 := true]. 15180 data := ((data bitAnd: 16rF) bitShift: 8) + (raw asInteger). 15181 nib := (data bitAnd: 16rFC0) bitShift: -6. 15182 mimeStream nextPut: (ToCharTable at: nib+1). 15183 nib := (data bitAnd: 16r3F). 15184 mimeStream nextPut: (ToCharTable at: nib+1). 15185 15186 lineLength := lineLength + 4.]. 15187 phase1 ifTrue: [mimeStream skip: -2; nextPut: $=; nextPut: $=. 15188 ^ mimeStream]. 15189 phase2 ifTrue: [mimeStream skip: -1; nextPut: $=. 15190 ^ mimeStream]. 15191 15192! ! 15193 15194!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:21'! 15195nextValue 15196 "The next six bits of data char from the mimeStream, or nil. Skip all other chars" 15197 | raw num | 15198 [raw := mimeStream next. 15199 raw ifNil: [^ nil]. "end of stream" 15200 raw == $= ifTrue: [^ nil]. 15201 num := FromCharTable at: raw asciiValue + 1. 15202 num ifNotNil: [^ num]. 15203 "else ignore space, return, tab, ..." 15204 true] whileTrue.! ! 15205 15206"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 15207 15208Base64MimeConverter class 15209 instanceVariableNames: ''! 15210 15211!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'damiencassou 5/30/2008 11:45'! 15212decodeInteger: mimeString 15213 "Decode the MIME string into an integer of any length" 15214 | bytes sum | 15215 bytes := (Base64MimeConverter mimeDecodeToBytes: mimeString readStream) contents. 15216 sum := 0. 15217 bytes reverseDo: [ :by | sum := sum * 256 + by ]. 15218 ^ sum! ! 15219 15220!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 2/21/2000 17:22'! 15221encodeInteger: int 15222 | strm | 15223 "Encode an integer of any length and return the MIME string" 15224 15225 strm := ReadWriteStream on: (ByteArray new: int digitLength). 15226 1 to: int digitLength do: [:ii | strm nextPut: (int digitAt: ii)]. 15227 strm reset. 15228 ^ ((self mimeEncode: strm) contents) copyUpTo: $= "remove padding"! ! 15229 15230!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 13:53'! 15231initialize 15232 15233 FromCharTable := Array new: 256. "nils" 15234 ToCharTable := Array new: 64. 15235 ($A asciiValue to: $Z asciiValue) doWithIndex: [:val :ind | 15236 FromCharTable at: val+1 put: ind-1. 15237 ToCharTable at: ind put: val asCharacter]. 15238 ($a asciiValue to: $z asciiValue) doWithIndex: [:val :ind | 15239 FromCharTable at: val+1 put: ind+25. 15240 ToCharTable at: ind+26 put: val asCharacter]. 15241 ($0 asciiValue to: $9 asciiValue) doWithIndex: [:val :ind | 15242 FromCharTable at: val+1 put: ind+25+26. 15243 ToCharTable at: ind+26+26 put: val asCharacter]. 15244 FromCharTable at: $+ asciiValue + 1 put: 62. 15245 ToCharTable at: 63 put: $+. 15246 FromCharTable at: $/ asciiValue + 1 put: 63. 15247 ToCharTable at: 64 put: $/. 15248 ! ! 15249 15250!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/12/97 11:41'! 15251mimeDecodeToBytes: aStream 15252 "Return a RWBinaryOrTextStream of the original ByteArray. aStream has only 65 innocuous character values. aStream is not binary. (See class comment). 4 bytes in aStream goes to 3 bytes in output." 15253 15254 | me | 15255 aStream position: 0. 15256 me := self new mimeStream: aStream. 15257 me dataStream: (RWBinaryOrTextStream on: (ByteArray new: aStream size * 3 // 4)). 15258 me mimeDecodeToByteArray. 15259 me dataStream position: 0. 15260 ^ me dataStream! ! 15261 15262!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 13:01'! 15263mimeDecodeToChars: aStream 15264 "Return a ReadWriteStream of the original String. aStream has only 65 innocuous character values. It is not binary. (See class comment). 4 bytes in aStream goes to 3 bytes in output." 15265 15266 | me | 15267 aStream position: 0. 15268 me := self new mimeStream: aStream. 15269 me dataStream: (ReadWriteStream on: (String new: aStream size * 3 // 4)). 15270 me mimeDecode. 15271 me dataStream position: 0. 15272 ^ me dataStream! ! 15273 15274!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 12:28'! 15275mimeEncode: aStream 15276 "Return a ReadWriteStream of characters. The data of aStream is encoded as 65 innocuous characters. (See class comment). 3 bytes in aStream goes to 4 bytes in output." 15277 15278 | me | 15279 aStream position: 0. 15280 me := self new dataStream: aStream. 15281 me mimeStream: (ReadWriteStream on: (String new: aStream size + 20 * 4 // 3)). 15282 me mimeEncode. 15283 me mimeStream position: 0. 15284 ^ me mimeStream! ! 15285TestCase subclass: #Base64MimeConverterTest 15286 instanceVariableNames: 'message' 15287 classVariableNames: '' 15288 poolDictionaries: '' 15289 category: 'CollectionsTests-Streams'! 15290!Base64MimeConverterTest commentStamp: '<historical>' prior: 0! 15291This is the unit test for the class Base64MimeConverter. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 15292 - http://www.c2.com/cgi/wiki?UnitTest 15293 - http://minnow.cc.gatech.edu/squeak/1547 15294 - the sunit class category! 15295 15296 15297!Base64MimeConverterTest methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:10'! 15298setUp 15299 message := ReadWriteStream on: (String new: 10). 15300 message nextPutAll: 'Hi There!!'.! ! 15301 15302 15303!Base64MimeConverterTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:23'! 15304testMimeEncodeDecode 15305 15306 | encoded | 15307 encoded := Base64MimeConverter mimeEncode: message. 15308 self assert: (encoded contents = 'SGkgVGhlcmUh'). 15309 self assert: ((Base64MimeConverter mimeDecodeToChars: encoded) contents = message contents).! ! 15310TestCase subclass: #BasicBehaviorClassMetaclassTest 15311 instanceVariableNames: '' 15312 classVariableNames: '' 15313 poolDictionaries: '' 15314 category: 'KernelTests-Classes'! 15315!BasicBehaviorClassMetaclassTest commentStamp: '<historical>' prior: 0! 15316This class contains some tests regarding the classes 15317 Behavior 15318 ClassDescription 15319 Class 15320 Metaclass 15321--- 15322 ! 15323 15324 15325!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:19'! 15326testBehaviorClassClassDescriptionMetaclassHierarchy 15327 "self run: #testBehaviorClassClassDescriptionMetaclassHierarchy" 15328 15329 self assert: Class superclass == ClassDescription. 15330 self assert: Metaclass superclass == ClassDescription. 15331 15332 self assert: ClassDescription superclass == Behavior. 15333 self assert: Behavior superclass = Object. 15334 15335 self assert: Class class class == Metaclass. 15336 self assert: Metaclass class class == Metaclass. 15337 self assert: ClassDescription class class == Metaclass. 15338 self assert: Behavior class class == Metaclass. 15339 15340 15341 15342 15343 15344 15345 15346 15347 15348 15349 15350 15351 15352 ! ! 15353 15354!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'md 7/24/2009 15:29'! 15355testClassDescriptionAllSubInstances 15356 "self run: #testClassDescriptionAllSubInstances" 15357 15358 | cdNo clsNo metaclsNo | 15359 15360 Smalltalk garbageCollect. 15361 cdNo := ClassDescription allSubInstances size. 15362 clsNo := Class allSubInstances size . 15363 metaclsNo := Metaclass allSubInstances size. 15364 15365 self assert: cdNo = (clsNo + metaclsNo). 15366 15367 15368 15369 15370 15371 15372 15373 15374 15375 15376 ! ! 15377 15378!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:17'! 15379testMetaclass 15380 "self run: #testMetaclass" 15381 15382 self assert: OrderedCollection class class == Metaclass. 15383 self assert: Dictionary class class == Metaclass. 15384 self assert: Object class class == Metaclass. 15385 15386 15387 15388 15389 15390 15391 15392 15393 15394 15395 15396 15397 15398 ! ! 15399 15400!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:12'! 15401testMetaclassName 15402 "self run: #testMetaclassName" 15403 15404 self assert: Dictionary class name = 'Dictionary class'. 15405 self assert: OrderedCollection class name = 'OrderedCollection class'. 15406 ! ! 15407 15408!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:12'! 15409testMetaclassNumberOfInstances 15410 "self run: #testMetaclassNumberOfInstances" 15411 15412 self assert: Dictionary class allInstances size = 1. 15413 self assert: OrderedCollection class allInstances size = 1.! ! 15414 15415!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:18'! 15416testMetaclassPointOfCircularity 15417 "self run: #testMetaclassPointOfCircularity" 15418 15419 self assert: Metaclass class instanceCount = 1. 15420 self assert: Metaclass class someInstance == Metaclass. 15421 15422 15423 15424 15425 15426 15427 15428 15429 15430 15431 15432 ! ! 15433 15434!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:13'! 15435testMetaclassSuperclass 15436 "self run: #testMetaclassSuperclass" 15437 15438 self assert: Dictionary class superclass == Set class. 15439 self assert: OrderedCollection class superclass == SequenceableCollection class. 15440 15441 ! ! 15442 15443!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:14'! 15444testMetaclassSuperclassHierarchy 15445 "self run: #testMetaclassSuperclassHierarchy" 15446 15447 | s | 15448 self assert: SequenceableCollection class instanceCount = 1. 15449 self assert: Collection class instanceCount = 1. 15450 self assert: Object class instanceCount = 1. 15451 self assert: ProtoObject class instanceCount = 1. 15452 15453 s := OrderedCollection new. 15454 s add: SequenceableCollection class. 15455 s add: Collection class. 15456 s add: Object class. 15457 s add: ProtoObject class. 15458 15459 s add: Class. 15460 s add: ClassDescription. 15461 s add: Behavior. 15462 s add: Object. 15463 s add: ProtoObject. 15464 15465 self assert: OrderedCollection class allSuperclasses = s. 15466 15467 15468 15469 15470 15471 15472 ! ! 15473 15474!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:21'! 15475testObjectAllSubclasses 15476 "self run: #testObjectAllSubclasses" 15477 15478 | n2 | 15479 n2 := Object allSubclasses size. 15480 self assert: n2 = (Object allSubclasses 15481 select: [:cls | cls class class == Metaclass 15482 or: [cls class == Metaclass]]) size! ! 15483 15484!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:13'! 15485testSuperclass 15486 "self run: #testSuperclass" 15487 15488 | s | 15489 self assert: Dictionary superclass == Set. 15490 self assert: OrderedCollection superclass == SequenceableCollection. 15491 15492 s := OrderedCollection new. 15493 s add: SequenceableCollection. 15494 s add: Collection. 15495 s add: Object. 15496 s add: ProtoObject. 15497 15498 self assert: OrderedCollection allSuperclasses = s. 15499 15500 15501 ! ! 15502Categorizer subclass: #BasicClassOrganizer 15503 instanceVariableNames: 'subject classComment commentStamp' 15504 classVariableNames: '' 15505 poolDictionaries: '' 15506 category: 'Kernel-Classes'! 15507 15508!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:02'! 15509classComment 15510 classComment 15511 ifNil: [^ '']. 15512 ^ classComment text ifNil: ['']! ! 15513 15514!BasicClassOrganizer methodsFor: 'accessing' stamp: 'marcus.denker 8/17/2008 20:56'! 15515classComment: aString 15516 "Store the comment, aString, associated with the object that refers to the 15517 receiver." 15518 15519 (aString isKindOf: RemoteString) 15520 ifTrue: [classComment := aString] 15521 ifFalse: [aString isEmptyOrNil 15522 ifTrue: [classComment := nil] 15523 ifFalse: [ 15524 self error: 'use aClass classComment:'. 15525 classComment := RemoteString newString: aString onFileNumber: 2]] 15526 "Later add priorSource and date and initials?"! ! 15527 15528!BasicClassOrganizer methodsFor: 'accessing' stamp: 'marcus.denker 8/17/2008 20:56'! 15529classComment: aString stamp: aStamp 15530 "Store the comment, aString, associated with the object that refers to the receiver." 15531 15532 self commentStamp: aStamp. 15533 (aString isKindOf: RemoteString) 15534 ifTrue: [classComment := aString] 15535 ifFalse: [aString isEmptyOrNil 15536 ifTrue: [classComment := nil] 15537 ifFalse: 15538 [self error: 'use aClass classComment:'. 15539 classComment := RemoteString newString: aString onFileNumber: 2]] 15540 "Later add priorSource and date and initials?"! ! 15541 15542!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! 15543commentRemoteStr 15544 ^ classComment! ! 15545 15546!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! 15547commentStamp 15548 "Answer the comment stamp for the class" 15549 15550 ^ commentStamp! ! 15551 15552!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! 15553commentStamp: aStamp 15554 commentStamp := aStamp! ! 15555 15556!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! 15557dateCommentLastSubmitted 15558 "Answer a Date object indicating when my class comment was last submitted. If there is no date stamp, or one of the old-time <historical> guys, return nil" 15559 "RecentMessageSet organization dateCommentLastSubmitted" 15560 15561 | aStamp tokens | 15562 (aStamp := self commentStamp) isEmptyOrNil ifTrue: [^ nil]. 15563 tokens := aStamp findBetweenSubStrs: ' 15564'. "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance" 15565 ^ tokens size > 1 15566 ifTrue: 15567 [[tokens second asDate] ifError: [nil]] 15568 ifFalse: 15569 [nil]! ! 15570 15571!BasicClassOrganizer methodsFor: 'accessing' stamp: 'marcus.denker 7/29/2009 15:26'! 15572hasComment 15573 "Answer whether the class classified by the receiver has a comment." 15574 ^classComment notNil! ! 15575 15576!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'! 15577hasSubject 15578 ^ self subject notNil! ! 15579 15580!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'! 15581subject 15582 ^ subject.! ! 15583 15584 15585!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:03'! 15586fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex 15587 "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." 15588 | fileComment | 15589 classComment ifNotNil: 15590 [aFileStream cr. 15591 fileComment := RemoteString newString: classComment text 15592 onFileNumber: fileIndex toFile: aFileStream. 15593 moveSource ifTrue: [classComment := fileComment]]! ! 15594 15595!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'! 15596moveChangedCommentToFile: aFileStream numbered: fileIndex 15597 "If the comment is in the changes file, then move it to a new file." 15598 15599 (classComment ~~ nil and: [classComment sourceFileNumber > 1]) ifTrue: 15600 [self fileOutCommentOn: aFileStream moveSource: true toFile: fileIndex]! ! 15601 15602!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'! 15603objectForDataStream: refStrm 15604 | dp | 15605 "I am about to be written on an object file. Write a path to me in the other system instead." 15606 15607 self hasSubject ifTrue: [ 15608 (refStrm insideASegment and: [self subject isSystemDefined not]) ifTrue: [ 15609 ^ self]. "do trace me" 15610 (self subject isKindOf: Class) ifTrue: [ 15611 dp := DiskProxy global: self subject name selector: #organization args: #(). 15612 refStrm replace: self with: dp. 15613 ^ dp]]. 15614 ^ self "in desparation" 15615! ! 15616 15617!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'! 15618putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass 15619 "Store the comment about the class onto file, aFileStream." 15620 | header | 15621 classComment ifNotNil: 15622 [aFileStream cr; nextPut: $!!. 15623 header := String streamContents: [:strm | 15624 strm nextPutAll: aClass name; 15625 nextPutAll: ' commentStamp: '. 15626 commentStamp ifNil: [commentStamp := '<historical>']. 15627 commentStamp storeOn: strm. 15628 strm nextPutAll: ' prior: '; nextPutAll: '0']. 15629 aFileStream nextChunkPut: header. 15630 aClass organization fileOutCommentOn: aFileStream 15631 moveSource: moveSource toFile: sourceIndex. 15632 aFileStream cr]! ! 15633 15634 15635!BasicClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 16:04'! 15636setSubject: aClassDescription 15637 subject := aClassDescription! ! 15638 15639 15640!BasicClassOrganizer methodsFor: 'deprecated' stamp: 'AndrewBlack 9/3/2009 01:08'! 15641hasNoComment 15642 "Answer whether the class classified by the receiver has a comment." 15643 self deprecated: 'Use ''hasComment'' instead.' on: '29 July 2009' in: #Pharo1.0. 15644 ^classComment == nil! ! 15645 15646"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 15647 15648BasicClassOrganizer class 15649 instanceVariableNames: ''! 15650 15651!BasicClassOrganizer class methodsFor: 'constants' stamp: 'NS 4/19/2004 15:52'! 15652ambiguous 15653 ^ #ambiguous! ! 15654 15655 15656!BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'! 15657class: aClassDescription 15658 ^ self new setSubject: aClassDescription! ! 15659 15660!BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'! 15661class: aClassDescription defaultList: aSortedCollection 15662 | inst | 15663 inst := self defaultList: aSortedCollection. 15664 inst setSubject: aClassDescription. 15665 ^ inst! ! 15666Inspector subclass: #BasicInspector 15667 instanceVariableNames: '' 15668 classVariableNames: '' 15669 poolDictionaries: '' 15670 category: 'Tools-Inspector'! 15671 15672!BasicInspector methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'! 15673inspect: anObject 15674 "Initialize the receiver so that it is inspecting anObject. There is no 15675 current selection." 15676 15677 self initialize. 15678 object := anObject. 15679 selectionIndex := 0. 15680 contents := ''! ! 15681Object subclass: #BasicRequestor 15682 instanceVariableNames: 'caption answer' 15683 classVariableNames: '' 15684 poolDictionaries: '' 15685 category: 'Services-Base'! 15686!BasicRequestor commentStamp: 'rr 7/10/2006 14:44' prior: 0! 15687This class is the root of the Requestor hierarchy. 15688 15689Requestors are interfaces between services and the system. ServiceActions are given an instance 15690of a Requestor, and they ask it for the data they need. The requestor is determined by the model of the application. A class used as a model can implement the #requestor message to return the most suited requestor. A requestor knows how to query its model and the user if needed. 15691 15692Requestor are defined in hierarchies so that the protocol they rely on (methods starting with 'get') can be easily reused.! 15693 15694 15695!BasicRequestor methodsFor: 'executing' stamp: 'rr 5/31/2004 22:43'! 15696get: aString 15697 self caption: aString. 15698 ^ self getSymbol! ! 15699 15700 15701!BasicRequestor methodsFor: 'generic requests' stamp: 'rr 6/1/2004 21:50'! 15702caption: aString 15703 caption := aString! ! 15704 15705!BasicRequestor methodsFor: 'generic requests' stamp: 'DamienCassou 9/29/2009 09:02'! 15706getString 15707 | result | 15708 result := UIManager default request:caption initialAnswer: answer contents. 15709 self newCaption. 15710 result isEmptyOrNil ifTrue:[ServiceCancelled signal]. 15711 ^ result! ! 15712 15713!BasicRequestor methodsFor: 'generic requests' stamp: 'rr 5/31/2004 22:18'! 15714getStringCollection 15715 caption := caption, Character cr asString, 'Separate items with space'. 15716 ^ (self getString findTokens: ' ') collect: [:each | each copyWithoutAll: ' ' ]! ! 15717 15718!BasicRequestor methodsFor: 'generic requests' stamp: 'rr 5/31/2004 22:19'! 15719getSymbol 15720 ^ self getString asSymbol! ! 15721 15722!BasicRequestor methodsFor: 'generic requests' stamp: 'rr 5/31/2004 22:20'! 15723getSymbolCollection 15724 ^[self getStringCollection collect: [:each | each asSymbol]] 15725 on: ServiceCancelled 15726 do: [#()]! ! 15727 15728!BasicRequestor methodsFor: 'generic requests' stamp: 'PeterHugossonMiller 9/3/2009 00:12'! 15729newCaption 15730 caption := 'Enter text'. 15731 answer := String new writeStream.! ! 15732 15733 15734!BasicRequestor methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:42'! 15735initialize 15736 super initialize. 15737 self newCaption! ! 15738 15739"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 15740 15741BasicRequestor class 15742 instanceVariableNames: ''! 15743TestCase subclass: #BecomeTest 15744 instanceVariableNames: '' 15745 classVariableNames: '' 15746 poolDictionaries: '' 15747 category: 'Tests-VM'! 15748 15749!BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:28'! 15750testBecome 15751 "Test the two way become. Note. we cannot use string literals for this test" 15752 | a b c d | 15753 15754 a := 'ab' copy. 15755 b := 'cd' copy. 15756 c := a. 15757 d := b. 15758 15759 a become: b. 15760 15761 self 15762 assert: a = 'cd'; 15763 assert: b = 'ab'; 15764 assert: c = 'cd'; 15765 assert: d = 'ab'. 15766 15767 15768! ! 15769 15770!BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:28'! 15771testBecomeForward 15772 "Test the forward become." 15773 | a b c d | 15774 15775 a := 'ab' copy. 15776 b := 'cd' copy. 15777 c := a. 15778 d := b. 15779 15780 a becomeForward: b. 15781 15782 self 15783 assert: a = 'cd'; 15784 assert: b = 'cd'; 15785 assert: c = 'cd'; 15786 assert: d = 'cd'. 15787 15788 15789! ! 15790 15791!BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 17:36'! 15792testBecomeForwardDontCopyIdentityHash 15793 "Check that 15794 1. the argument to becomeForward: is NOT modified to have the receiver's identity hash. 15795 2. the receiver's identity hash is unchanged." 15796 15797 | a b hb | 15798 15799 a := 'ab' copy. 15800 b := 'cd' copy. 15801 hb := b identityHash. 15802 15803 a becomeForward: b copyHash: false. 15804 15805 self 15806 assert: a identityHash = hb; 15807 assert: b identityHash = hb. 15808 15809! ! 15810 15811!BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:29'! 15812testBecomeForwardHash 15813 15814 | a b c hb | 15815 15816 a := 'ab' copy. 15817 b := 'cd' copy. 15818 c := a. 15819 hb := b hash. 15820 15821 a becomeForward: b. 15822 15823 self 15824 assert: a hash = hb; 15825 assert: b hash = hb; 15826 assert: c hash = hb. 15827 15828 15829! ! 15830 15831!BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:27'! 15832testBecomeForwardIdentityHash 15833 "Check that 15834 1. the argument to becomeForward: is modified to have the receiver's identity hash. 15835 2. the receiver's identity hash is unchanged." 15836 15837 | a b ha | 15838 15839 a := 'ab' copy. 15840 b := 'cd' copy. 15841 ha := a identityHash. 15842 15843 a becomeForward: b. 15844 15845 self 15846 assert: a identityHash = ha; 15847 assert: b identityHash = ha. 15848 15849! ! 15850 15851!BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:30'! 15852testBecomeHash 15853 15854 | a b c d ha hb | 15855 15856 a := 'ab' copy. 15857 b := 'cd' copy. 15858 c := a. 15859 d := b. 15860 ha := a hash. 15861 hb := b hash. 15862 15863 a become: b. 15864 15865 self 15866 assert: a hash = hb; 15867 assert: b hash = ha; 15868 assert: c hash = hb; 15869 assert: d hash = ha. 15870 15871 15872! ! 15873 15874!BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:31'! 15875testBecomeIdentityHash 15876 "Note. The identity hash of both objects seems to change after the become:" 15877 15878 | a b c d | 15879 15880 a := 'ab' copy. 15881 b := 'cd' copy. 15882 c := a. 15883 d := b. 15884 15885 a become: b. 15886 15887 self 15888 assert: a identityHash = c identityHash; 15889 assert: b identityHash = d identityHash; 15890 deny: a identityHash = b identityHash. 15891! ! 15892Object subclass: #Beeper 15893 instanceVariableNames: '' 15894 classVariableNames: '' 15895 poolDictionaries: '' 15896 category: 'System-Support'! 15897!Beeper commentStamp: 'gk 2/26/2004 22:44' prior: 0! 15898Beeper provides simple audio (or in some other way) feedback to the user. 15899 15900The recommended use is "Beeper beep" to give the user the equivalence of a beep. If you want to force the beep to use the primitive in the VM for beeping, then use "Beeper beepPrimitive". In either case, if sounds are disabled there will be no beep. 15901 15902The actual beeping, when you use "Beeper beep", is done by sending a #play message to a registered playable object. You can register your own playable object by invoking the class side method #setDefault: passing in an object that responds to the #play message. 15903 15904The default playable object is an instance of Beeper itself which implements #play on the instance side. That implementation delegates the playing of the beep to the default SoundService. 15905 15906Note that #play is introduced as a common interface between AbstractSound and Beeper. 15907This way we can register instances of AbstractSound as playable entities, for example: 15908 15909 Beeper setDefault: (SampledSound new 15910 setSamples: self coffeeCupClink 15911 samplingRate: 12000). 15912 15913Then "Beeper beep" will play the coffeeCup sound.! 15914 15915 15916!Beeper methodsFor: 'play interface' stamp: 'gk 2/24/2004 23:25'! 15917play 15918 "This is how the default Beeper makes a beep, 15919 by sending beep to the default sound service. 15920 The sound system will check if sounds are enabled." 15921 15922 SoundService default beep! ! 15923 15924"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 15925 15926Beeper class 15927 instanceVariableNames: 'default'! 15928 15929!Beeper class methodsFor: 'beeping' stamp: 'pavel.krivanek 3/11/2009 07:39'! 15930beep 15931 "The preferred way of producing an audible feedback. 15932 The default playable entity (an instance of Beeper) 15933 also uses the pluggable SoundService 15934 mechanism, so it will use the primitive beep only 15935 if there is no other sound mechanism available." 15936 15937 self default 15938 ifNil: [self beepPrimitive] 15939 ifNotNil: [ self default play]. 15940! ! 15941 15942!Beeper class methodsFor: 'beeping' stamp: 'gk 2/24/2004 08:38'! 15943beepPrimitive 15944 "Make a primitive beep. Only use this if 15945 you want to force this to be a primitive beep. 15946 Otherwise use Beeper class>>beep 15947 since this method bypasses the current 15948 registered playable entity." 15949 15950 Preferences soundsEnabled ifTrue: [ 15951 self primitiveBeep]! ! 15952 15953 15954!Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:51'! 15955clearDefault 15956 "Clear the default playable. 15957 Will be lazily initialized in Beeper class >>default." 15958 15959 default := nil! ! 15960 15961!Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:55'! 15962default 15963 "When the default is not defined it is 15964 initialized using #newDefault." 15965 15966 default isNil 15967 ifTrue: [default := self newDefault ]. 15968 ^ default! ! 15969 15970!Beeper class methodsFor: 'customize' stamp: 'gk 2/24/2004 22:12'! 15971newDefault 15972 "Subclasses may override me to provide a default beep. 15973 This base implementation returns an instance of Beeper 15974 which uses the pluggable sound service." 15975 15976 ^ self new! ! 15977 15978!Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:54'! 15979setDefault: aPlayableEntity 15980 "Set the playable entity used when making a beep. 15981 The playable entity should implement the message #play." 15982 15983 default := aPlayableEntity! ! 15984 15985 15986!Beeper class methodsFor: 'private' stamp: 'gk 2/24/2004 23:51'! 15987primitiveBeep 15988 "Make a primitive beep. Not to be called directly. 15989 It is much better to use Beeper class>>beep 15990 or Beeper class>>beepPrimitive 15991 since this method bypasses the current 15992 registered playable entity and does not 15993 check Preferences class>>soundsEnabled." 15994 15995 <primitive: 140> 15996 self primitiveFailed! ! 15997Object subclass: #Behavior 15998 uses: TPureBehavior 15999 instanceVariableNames: 'superclass methodDict format' 16000 classVariableNames: 'ObsoleteSubclasses' 16001 poolDictionaries: '' 16002 category: 'Kernel-Classes'! 16003!Behavior commentStamp: 'al 12/8/2005 20:44' prior: 0! 16004My instances describe the behavior of other objects. I provide the minimum state necessary for compiling methods, and creating and running instances. Most objects are created as instances of the more fully supported subclass, Class, but I am a good starting point for providing instance-specific behavior (as in Metaclass).! 16005 16006 16007!Behavior methodsFor: '*system-support' stamp: 'tpr 12/17/2003 16:04'! 16008allCallsOn 16009 "Answer a SortedCollection of all the methods that refer to me by name or as part of an association in a global dict." 16010 16011 16012 ^ (self systemNavigation allCallsOn: (self environment associationAt: self theNonMetaClass name)), (self systemNavigation allCallsOn: self theNonMetaClass name) ! ! 16013 16014!Behavior methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:43'! 16015allCallsOn: aSymbol 16016 "Answer a SortedCollection of all the methods that call on aSymbol." 16017 16018 16019 ^ self systemNavigation allCallsOn: aSymbol from: self . 16020 ! ! 16021 16022!Behavior methodsFor: '*system-support' stamp: 'stephane.ducasse 10/12/2008 21:02'! 16023allUnsentMessages 16024 "Answer an array of all the messages defined by the receiver that are not sent anywhere in the system." 16025 16026 ^ SystemNavigation default allUnsentMessagesIn: self selectors! ! 16027 16028 16029!Behavior methodsFor: '*traits'! 16030providedSelectors 16031 ^ProvidedSelectors current for: self! ! 16032 16033 16034!Behavior methodsFor: '*traits-requires' stamp: 'NS 5/26/2005 12:11'! 16035classAndMethodFor: aSymbol do: binaryBlock ifAbsent: absentBlock 16036 "Looks up the selector aSymbol in the class chain. If it is found, binaryBlock is evaluated 16037 with the class that defines the selector and the associated method. Otherwise 16038 absentBlock is evaluated." 16039 16040 | method | 16041 self withAllSuperclassesDo: [:class | 16042 method := class compiledMethodAt: aSymbol ifAbsent: [nil]. 16043 method ifNotNil: [^ binaryBlock value: class value: method]. 16044 ]. 16045 ^ absentBlock value.! ! 16046 16047!Behavior methodsFor: '*traits-requires' stamp: 'dvf 9/9/2005 19:45'! 16048classesComposedWithMe 16049 ^{self}! ! 16050 16051!Behavior methodsFor: '*traits-requires' stamp: 'NS 5/26/2005 14:27'! 16052computeSelfSendersFromInheritedSelfSenders: inheritedCollection localSelfSenders: localCollection 16053 "Compute the set of all self-senders from the set of inherited self-senders and the set of local self-senders." 16054 16055 | result mDict | 16056 mDict := self methodDict. 16057 result := IdentitySet new: inheritedCollection size + localCollection size. 16058 "This if-statement is just a performance optimization. 16059 Both branches are semantically equivalent." 16060 inheritedCollection size > mDict size ifTrue: [ 16061 result addAll: inheritedCollection. 16062 mDict keysDo: [:each | result remove: each ifAbsent: []]. 16063 ] ifFalse: [ 16064 inheritedCollection do: [:each | (mDict includesKey: each) ifFalse: [result add: each]]. 16065 ]. 16066 result addAll: localCollection. 16067 ^ result.! ! 16068 16069!Behavior methodsFor: '*traits-requires' stamp: 'NS 5/26/2005 14:11'! 16070computeTranslationsAndUpdateUnreachableSet: unreachableCollection 16071 "This method computes the set of unreachable selectors in the superclass by altering the set of unreachable selectors in this class. In addition, it builds a dictionary mapping super-sent selectors to the selectors of methods sending these selectors." 16072 16073 | translations reachableSenders oldUnreachable | 16074 oldUnreachable := unreachableCollection copy. 16075 translations := IdentityDictionary new. 16076 "Add selectors implemented in this class to unreachable set." 16077 self methodDict keysDo: [:s | unreachableCollection add: s]. 16078 16079 "Fill translation dictionary and remove super-reachable selectors from unreachable." 16080 self sendCaches superSentSelectorsAndSendersDo: [:sent :senders | 16081 reachableSenders := FixedIdentitySet readonlyWithAll: senders notIn: oldUnreachable. 16082 reachableSenders isEmpty ifFalse: [ 16083 translations at: sent put: reachableSenders. 16084 unreachableCollection remove: sent ifAbsent: []. 16085 ]. 16086 ]. 16087 ^ translations! ! 16088 16089!Behavior methodsFor: '*traits-requires' stamp: 'dvf 8/4/2005 16:48'! 16090findSelfSendersOf: selector unreachable: unreachableCollection noInheritedSelfSenders: noInheritedBoolean 16091 "This method answers a subset of all the reachable methods (local or inherited) that self-send selector (empty set => no self-senders). 16092 See Nathanael Sch䲬i's PhD for more details." 16093 16094 | selfSenders reachableSelfSenders translations | 16095 "Check whether there are local methods that self-send selector and are reachable." 16096 selfSenders := self sendCaches selfSendersOf: selector. 16097 reachableSelfSenders := FixedIdentitySet readonlyWithAll: selfSenders notIn: unreachableCollection. 16098 (self superclass isNil or: [noInheritedBoolean or: [reachableSelfSenders notEmpty]]) 16099 ifTrue: [^ reachableSelfSenders]. 16100 16101 "Compute the set of unreachable superclass methods and super-send translations and recurse." 16102 translations := self computeTranslationsAndUpdateUnreachableSet: unreachableCollection. 16103 reachableSelfSenders := superclass findSelfSendersOf: selector unreachable: unreachableCollection noInheritedSelfSenders: false. 16104 16105 "Use the translations to replace selectors that are super-sent with the methods that issue the super-sends." 16106 reachableSelfSenders := self translateReachableSelfSenders: reachableSelfSenders translations: translations. 16107 ^ reachableSelfSenders.! ! 16108 16109!Behavior methodsFor: '*traits-requires' stamp: 'dvf 9/12/2005 11:44'! 16110requiredSelectors 16111 ^RequiredSelectors current for: self! ! 16112 16113!Behavior methodsFor: '*traits-requires' stamp: 'dvf 9/6/2005 13:14'! 16114requiredSelectorsCache 16115 ^RequiredSelectors current cacheFor: self! ! 16116 16117!Behavior methodsFor: '*traits-requires' stamp: 'dvf 9/1/2005 16:36'! 16118sendCaches 16119 ^LocalSends current for: self! ! 16120 16121!Behavior methodsFor: '*traits-requires' stamp: 'NS 5/24/2005 16:38'! 16122translateReachableSelfSenders: senderCollection translations: translationDictionary 16123 | result superSenders | 16124 (translationDictionary isEmptyOrNil or: [senderCollection isEmpty]) ifTrue: [^ senderCollection]. 16125 result := FixedIdentitySet new. 16126 senderCollection do: [:s | 16127 superSenders := translationDictionary at: s ifAbsent: [nil]. 16128 superSenders isNil 16129 ifTrue: [result add: s] 16130 ifFalse: [result addAll: superSenders]. 16131 result isFull ifTrue: [^ result]. 16132 ]. 16133 ^ result.! ! 16134 16135!Behavior methodsFor: '*traits-requires' stamp: 'dvf 9/12/2005 18:28'! 16136updateRequiredStatusFor: selector inSubclasses: someClasses 16137 "Updates the requirements cache to reflect whether selector is required in this class and some of its subclasses." 16138 | inheritedMethod | 16139 inheritedMethod := self superclass ifNotNil: [self superclass lookupSelector: selector]. 16140 ^self updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: FixedIdentitySet new providedInParent: inheritedMethod noInheritedSelfSenders: false accumulatingInto: IdentitySet new.! ! 16141 16142!Behavior methodsFor: '*traits-requires' stamp: 'dvf 8/9/2005 17:02'! 16143updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: inheritedSelfSenders providedInParent: providedBoolean noInheritedSelfSenders: noInheritedBoolean 16144 "Updates the requirements cache to reflect whether selector is required in this class and all of its subclasses. The parameter inheritedSelfSenders is a subset of the methods in the parent of this class that are known to self-send selector. providedBoolean indicates whether selector is provided in the parent. noInheritedBoolean is true if no self-senders could be found in the superclass. 16145 See Nathanael Sch䲬i's PhD for more details." 16146 16147 | selfSenders provided m | 16148 "Remove from the inherited selfSenders methods that are potentially unreachable." 16149 selfSenders := inheritedSelfSenders reject: [:each | self includesSelector: each]. 16150 16151 "Check whether the method is provided." 16152 m := self compiledMethodAt: selector ifAbsent: [nil]. 16153 providedBoolean ifTrue: [ 16154 provided := m isNil or: [m isDisabled not and: [m isExplicitlyRequired not and: [m isSubclassResponsibility not]]]. 16155 ] ifFalse: [ 16156 provided := m notNil and: [m isProvided]. 16157 ]. 16158 16159 provided ifTrue: [ 16160 "If it is provided, it cannot be required." 16161 self setRequiredStatusOf: selector to: false. 16162 ] ifFalse: [ 16163 "If there are non-overridden inherited selfSenders we know that it must be 16164 required. Otherwise, we search for self-senders." 16165 selfSenders isEmpty ifTrue: [selfSenders := self findSelfSendersOf: selector unreachable: IdentitySet new noInheritedSelfSenders: noInheritedBoolean]. 16166 self setRequiredStatusOf: selector to: selfSenders notEmpty. 16167 ]. 16168 16169 "Do the same for all subclasses." 16170 self subclassesDo: [:each | 16171 (someClasses includes: each) ifTrue: 16172 [each updateRequiredStatusFor: selector 16173 inSubclasses: someClasses 16174 parentSelfSenders: selfSenders 16175 providedInParent: provided 16176 noInheritedSelfSenders: (provided not and: [selfSenders isEmpty])]].! ! 16177 16178!Behavior methodsFor: '*traits-requires' stamp: 'dvf 9/12/2005 19:43'! 16179updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: inheritedSelfSenders providedInParent: inheritedMethod noInheritedSelfSenders: noInheritedBoolean accumulatingInto: requiringClasses 16180 "Updates the requirements cache to reflect whether selector is required in this class and all of its subclasses. The parameter inheritedSelfSenders is a subset of the methods in the parent of this class that are known to self-send selector. providedBoolean indicates whether selector is provided in the parent. noInheritedBoolean is true if no self-senders could be found in the superclass. 16181 See Nathanael Sch䲬i's PhD for more details." 16182 16183 "Remove from the inherited selfSenders methods that are potentially unreachable." 16184 16185 | selfSenders m relevantMethod required lookedForInheritedSelfSenders | 16186 lookedForInheritedSelfSenders := false. 16187 selfSenders := inheritedSelfSenders 16188 reject: [:each | self includesSelector: each]. 16189 16190 "Check whether the method is provided." 16191 m := self compiledMethodAt: selector ifAbsent: [nil]. 16192 relevantMethod := m ifNotNil: [m] ifNil: [inheritedMethod]. 16193 relevantMethod 16194 ifNotNil: [required := relevantMethod isSubclassResponsibility or: [ 16195 relevantMethod isDisabled or: [ 16196 relevantMethod isExplicitlyRequired]]] 16197 ifNil: ["If there are non-overridden inherited selfSenders we know that it must be 16198 required. Otherwise, we search for self-senders." 16199 16200 selfSenders isEmpty 16201 ifTrue: 16202 [selfSenders := self 16203 findSelfSendersOf: selector 16204 unreachable: IdentitySet new 16205 noInheritedSelfSenders: noInheritedBoolean. 16206 lookedForInheritedSelfSenders := true]. 16207 required := selfSenders notEmpty]. 16208 16209 required ifTrue: [requiringClasses add: self]. 16210 16211 "Do the same for all subclasses." 16212 self subclassesDo: 16213 [:each | 16214 (someClasses includes: each) 16215 ifTrue: 16216 [each 16217 updateRequiredStatusFor: selector 16218 inSubclasses: someClasses 16219 parentSelfSenders: selfSenders 16220 providedInParent: relevantMethod 16221 noInheritedSelfSenders: (lookedForInheritedSelfSenders and: [selfSenders isEmpty]) 16222 accumulatingInto: requiringClasses]]. 16223 ^requiringClasses! ! 16224 16225!Behavior methodsFor: '*traits-requires' stamp: 'dvf 8/9/2005 15:39'! 16226withInheritanceTraitCompositionIncludes: aTrait 16227 ^self withAllSuperclasses anySatisfy: [:c | c traitCompositionIncludes: aTrait]! ! 16228 16229 16230!Behavior methodsFor: 'accessing' stamp: 'ajh 9/19/2001 17:30'! 16231classDepth 16232 16233 superclass ifNil: [^ 1]. 16234 ^ superclass classDepth + 1! ! 16235 16236!Behavior methodsFor: 'accessing'! 16237compilerClass 16238 "Answer a compiler class appropriate for source methods of this class." 16239 16240 ^Compiler! ! 16241 16242!Behavior methodsFor: 'accessing'! 16243decompilerClass 16244 "Answer a decompiler class appropriate for compiled methods of this class." 16245 16246 ^ self compilerClass decompilerClass! ! 16247 16248!Behavior methodsFor: 'accessing'! 16249environment 16250 "Return the environment in which the receiver is visible" 16251 ^Smalltalk! ! 16252 16253!Behavior methodsFor: 'accessing'! 16254evaluatorClass 16255 "Answer an evaluator class appropriate for evaluating expressions in the 16256 context of this class." 16257 16258 ^Compiler! ! 16259 16260!Behavior methodsFor: 'accessing'! 16261format 16262 "Answer an Integer that encodes the kinds and numbers of variables of 16263 instances of the receiver." 16264 16265 ^format! ! 16266 16267!Behavior methodsFor: 'accessing' stamp: 'di 3/7/2001 17:05'! 16268methodDict 16269 methodDict == nil ifTrue: [self recoverFromMDFaultWithTrace]. 16270 ^ methodDict! ! 16271 16272!Behavior methodsFor: 'accessing' stamp: 'rca 7/26/2000 16:53'! 16273name 16274 "Answer a String that is the name of the receiver." 16275 ^'a subclass of ', superclass name! ! 16276 16277!Behavior methodsFor: 'accessing'! 16278parserClass 16279 "Answer a parser class to use for parsing method headers." 16280 16281 ^self compilerClass parserClass! ! 16282 16283!Behavior methodsFor: 'accessing'! 16284sourceCodeTemplate 16285 "Answer an expression to be edited and evaluated in order to define 16286 methods in this class or trait." 16287 16288 ^'message selector and argument names 16289 "comment stating purpose of message" 16290 16291 | temporary variable names | 16292 statements'! ! 16293 16294!Behavior methodsFor: 'accessing'! 16295subclassDefinerClass 16296 "Answer an evaluator class appropriate for evaluating definitions of new 16297 subclasses of this class." 16298 16299 ^Compiler! ! 16300 16301!Behavior methodsFor: 'accessing' stamp: 'ar 7/13/1999 22:00'! 16302typeOfClass 16303 "Answer a symbol uniquely describing the type of the receiver" 16304 self instSpec = CompiledMethod instSpec ifTrue:[^#compiledMethod]. "Very special!!" 16305 self isBytes ifTrue:[^#bytes]. 16306 (self isWords and:[self isPointers not]) ifTrue:[^#words]. 16307 self isWeak ifTrue:[^#weak]. 16308 self isVariable ifTrue:[^#variable]. 16309 ^#normal.! ! 16310 16311 16312!Behavior methodsFor: 'accessing class hierarchy' stamp: 'nb 5/6/2003 17:11'! 16313allSubclasses 16314 "Answer a Set of the receiver's and the receiver's descendent's subclasses. " 16315 16316 | scan scanTop | 16317 scan := OrderedCollection withAll: self subclasses. 16318 scanTop := 1. 16319 [scanTop > scan size] 16320 whileFalse: [scan addAll: (scan at: scanTop) subclasses. 16321 scanTop := scanTop + 1]. 16322 ^ scan asSet! ! 16323 16324!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 3/28/2003 15:06'! 16325allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level 16326 "Walk the tree of subclasses, giving the class and its level" 16327 | subclassNames | 16328 classAndLevelBlock value: self value: level. 16329 self == Class ifTrue: [^ self]. "Don't visit all the metaclasses" 16330 "Visit subclasses in alphabetical order" 16331 subclassNames := SortedCollection new. 16332 self subclassesDo: [:subC | subclassNames add: subC name]. 16333 subclassNames do: 16334 [:name | (self environment at: name) 16335 allSubclassesWithLevelDo: classAndLevelBlock 16336 startingLevel: level+1]! ! 16337 16338!Behavior methodsFor: 'accessing class hierarchy'! 16339allSuperclasses 16340 "Answer an OrderedCollection of the receiver's and the receiver's 16341 ancestor's superclasses. The first element is the receiver's immediate 16342 superclass, followed by its superclass; the last element is Object." 16343 | temp | 16344 ^ superclass == nil 16345 ifTrue: [ OrderedCollection new] 16346 ifFalse: [temp := superclass allSuperclasses. 16347 temp addFirst: superclass. 16348 temp]! ! 16349 16350!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 1/28/2009 14:20'! 16351allSuperclassesIncluding: aClass 16352 "Answer an OrderedCollection of the receiver's and the receiver's 16353 ancestor's superclasses up to aClass included. The first element is the receiver's immediate 16354 superclass up to aClass included." 16355 | temp | 16356 ^ superclass == aClass 16357 ifTrue: [ OrderedCollection with: aClass] 16358 ifFalse: [temp := superclass allSuperclassesIncluding: aClass. 16359 temp addFirst: superclass. 16360 temp]! ! 16361 16362!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 3/14/2004 18:09'! 16363subclasses 16364 "slow implementation since Behavior does not keep trace of subclasses" 16365 16366 ^ self class allInstances select: [:each | each superclass = self ]! ! 16367 16368!Behavior methodsFor: 'accessing class hierarchy'! 16369superclass 16370 "Answer the receiver's superclass, a Class." 16371 16372 ^superclass! ! 16373 16374!Behavior methodsFor: 'accessing class hierarchy' stamp: 'ar 7/10/1999 12:10'! 16375superclass: aClass 16376 "Change the receiver's superclass to be aClass." 16377 "Note: Do not use 'aClass isKindOf: Behavior' here 16378 in case we recompile from Behavior itself." 16379 (aClass == nil or: [aClass isBehavior]) 16380 ifTrue: [superclass := aClass. 16381 Object flushCache] 16382 ifFalse: [self error: 'superclass must be a class-describing object']! ! 16383 16384!Behavior methodsFor: 'accessing class hierarchy'! 16385withAllSubclasses 16386 "Answer a Set of the receiver, the receiver's descendent's, and the 16387 receiver's descendent's subclasses." 16388 16389 ^ self allSubclasses add: self; 16390 yourself! ! 16391 16392!Behavior methodsFor: 'accessing class hierarchy'! 16393withAllSuperclasses 16394 "Answer an OrderedCollection of the receiver and the receiver's 16395 superclasses. The first element is the receiver, 16396 followed by its superclass; the last element is Object." 16397 16398 | temp | 16399 temp := self allSuperclasses. 16400 temp addFirst: self. 16401 ^ temp! ! 16402 16403 16404!Behavior methodsFor: 'accessing instances and variables'! 16405allClassVarNames 16406 "Answer a Set of the names of the receiver's and the receiver's ancestor's 16407 class variables." 16408 16409 ^superclass allClassVarNames! ! 16410 16411!Behavior methodsFor: 'accessing instances and variables'! 16412allInstVarNames 16413 "Answer an Array of the names of the receiver's instance variables. The 16414 Array ordering is the order in which the variables are stored and 16415 accessed by the interpreter." 16416 16417 | vars | 16418 superclass == nil 16419 ifTrue: [vars := self instVarNames copy] "Guarantee a copy is answered." 16420 ifFalse: [vars := superclass allInstVarNames , self instVarNames]. 16421 ^vars! ! 16422 16423!Behavior methodsFor: 'accessing instances and variables' stamp: 'MarcusDenker 10/17/2009 16:49'! 16424allInstances 16425 "Answer a collection of all current instances of the receiver." 16426 16427 | all inst next | 16428 all := OrderedCollection new. 16429 inst := self someInstance. 16430 [inst == nil] 16431 whileFalse: [ 16432 next := inst nextInstance. 16433 inst == all ifFalse: [all add: inst]. 16434 inst := next]. 16435 ^ all asArray! ! 16436 16437!Behavior methodsFor: 'accessing instances and variables' stamp: 'tpr 5/30/2003 13:04'! 16438allSharedPools 16439 "Answer a Set of the names of the pools (Dictionaries or SharedPool subclasses) that the receiver and the receiver's ancestors share." 16440 16441 ^superclass allSharedPools! ! 16442 16443!Behavior methodsFor: 'accessing instances and variables' stamp: 'di 6/20/97 10:51'! 16444allSubInstances 16445 "Answer a list of all current instances of the receiver and all of its subclasses." 16446 | aCollection | 16447 aCollection := OrderedCollection new. 16448 self allSubInstancesDo: 16449 [:x | x == aCollection ifFalse: [aCollection add: x]]. 16450 ^ aCollection! ! 16451 16452!Behavior methodsFor: 'accessing instances and variables' stamp: 'ajh 10/17/2002 11:03'! 16453allowsSubInstVars 16454 "Classes that allow instances to change classes among its subclasses will want to override this and return false, so inst vars are not accidentally added to its subclasses." 16455 16456 ^ true! ! 16457 16458!Behavior methodsFor: 'accessing instances and variables'! 16459classVarNames 16460 "Answer a Set of the receiver's class variable names." 16461 16462 ^Set new! ! 16463 16464!Behavior methodsFor: 'accessing instances and variables' stamp: 'sw 5/21/2001 22:51'! 16465inspectAllInstances 16466 "Inpsect all instances of the receiver. 1/26/96 sw" 16467 16468 | all allSize prefix | 16469 all := self allInstances. 16470 (allSize := all size) == 0 ifTrue: [^ self inform: 'There are no 16471instances of ', self name]. 16472 prefix := allSize == 1 16473 ifTrue: ['The lone instance'] 16474 ifFalse: ['The ', allSize printString, ' instances']. 16475 16476 all asArray inspectWithLabel: (prefix, ' of ', self name)! ! 16477 16478!Behavior methodsFor: 'accessing instances and variables' stamp: 'sw 5/21/2001 22:51'! 16479inspectSubInstances 16480 "Inspect all instances of the receiver and all its subclasses. CAUTION - don't do this for something as generic as Object!! 1/26/96 sw" 16481 16482 | all allSize prefix | 16483 all := self allSubInstances. 16484 (allSize := all size) == 0 ifTrue: [^ self inform: 'There are no 16485instances of ', self name, ' 16486or any of its subclasses']. 16487 prefix := allSize == 1 16488 ifTrue: ['The lone instance'] 16489 ifFalse: ['The ', allSize printString, ' instances']. 16490 16491 all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')! ! 16492 16493!Behavior methodsFor: 'accessing instances and variables'! 16494instVarNames 16495 "Answer an Array of the instance variable names. Behaviors must make 16496 up fake local instance variable names because Behaviors have instance 16497 variables for the purpose of compiling methods, but these are not named 16498 instance variables." 16499 16500 | mySize superSize | 16501 mySize := self instSize. 16502 superSize := 16503 superclass == nil 16504 ifTrue: [0] 16505 ifFalse: [superclass instSize]. 16506 mySize = superSize ifTrue: [^#()]. 16507 ^(superSize + 1 to: mySize) collect: [:i | 'inst' , i printString]! ! 16508 16509!Behavior methodsFor: 'accessing instances and variables'! 16510instanceCount 16511 "Answer the number of instances of the receiver that are currently in 16512 use." 16513 16514 | count | 16515 count := 0. 16516 self allInstancesDo: [:x | count := count + 1]. 16517 ^count! ! 16518 16519!Behavior methodsFor: 'accessing instances and variables'! 16520sharedPools 16521 "Answer a Set of the names of the pools (Dictionaries) that the receiver 16522 shares. 16523 9/12/96 tk sharedPools have an order now" 16524 16525 ^ OrderedCollection new! ! 16526 16527!Behavior methodsFor: 'accessing instances and variables'! 16528someInstance 16529 "Primitive. Answer the first instance in the enumeration of all instances 16530 of the receiver. Fails if there are none. Essential. See Object 16531 documentation whatIsAPrimitive." 16532 16533 <primitive: 77> 16534 ^nil! ! 16535 16536!Behavior methodsFor: 'accessing instances and variables'! 16537subclassInstVarNames 16538 "Answer a Set of the names of the receiver's subclasses' instance 16539 variables." 16540 | vars | 16541 vars := Set new. 16542 self allSubclasses do: [:aSubclass | vars addAll: aSubclass instVarNames]. 16543 ^vars! ! 16544 16545 16546!Behavior methodsFor: 'accessing method dictionary'! 16547>> selector 16548 "Answer the compiled method associated with the argument, selector (a 16549 Symbol), a message selector in the receiver's method dictionary. If the 16550 selector is not in the dictionary, create an error notification." 16551 16552 ^self compiledMethodAt: selector 16553! ! 16554 16555!Behavior methodsFor: 'accessing method dictionary'! 16556addSelector: selector withMethod: compiledMethod 16557 ^ self addSelector: selector withMethod: compiledMethod notifying: nil! ! 16558 16559!Behavior methodsFor: 'accessing method dictionary'! 16560addSelector: selector withMethod: compiledMethod notifying: requestor 16561 ^ self addSelectorSilently: selector withMethod: compiledMethod! ! 16562 16563!Behavior methodsFor: 'accessing method dictionary'! 16564addSelectorSilently: selector withMethod: compiledMethod 16565 self methodDictAddSelectorSilently: selector withMethod: compiledMethod. 16566 self registerLocalSelector: selector! ! 16567 16568!Behavior methodsFor: 'accessing method dictionary' stamp: 'kph 8/27/2008 22:31'! 16569allSelectors 16570 "Answer all selectors understood by instances of the receiver" 16571 16572 ^ self allSelectorsBelow: nil! ! 16573 16574!Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 1/28/2009 14:29'! 16575allSelectorsAbove 16576 16577 ^ self allSelectorsAboveUntil: ProtoObject 16578 16579 16580! ! 16581 16582!Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 1/28/2009 14:28'! 16583allSelectorsAboveUntil: aRootClass 16584 16585 | coll | 16586 coll := IdentitySet new. 16587 (self allSuperclassesIncluding: aRootClass) 16588 do: [:aClass | 16589 aClass selectorsDo: [ :sel | coll add: sel ]]. 16590 ^ coll 16591 16592 16593! ! 16594 16595!Behavior methodsFor: 'accessing method dictionary' stamp: 'dc 9/28/2008 15:54'! 16596allSelectorsBelow: topClass 16597 | coll | 16598 coll := IdentitySet new. 16599 self withAllSuperclassesDo: 16600 [:aClass | 16601 aClass = topClass 16602 ifTrue: [^ coll ] 16603 ifFalse: [aClass selectorsDo: [ :sel | coll add: sel ]]]. 16604 ^ coll 16605 16606 16607! ! 16608 16609!Behavior methodsFor: 'accessing method dictionary' stamp: 'al 6/12/2006 10:48'! 16610basicLocalSelectors 16611 "Direct accessor for the instance variable localSelectors. 16612 Because of hardcoded ivar indexes of Behavior and Class in the VM, Class and 16613 Metaclass declare the needed ivar and override this method as an accessor. 16614 By returning nil instead of declaring this method as a subclass responsibility, 16615 Behavior can be instantiated for creating anonymous classes." 16616 16617 ^nil! ! 16618 16619!Behavior methodsFor: 'accessing method dictionary' stamp: 'al 3/25/2006 13:17'! 16620basicLocalSelectors: aSetOrNil 16621 self subclassResponsibility ! ! 16622 16623!Behavior methodsFor: 'accessing method dictionary'! 16624changeRecordsAt: selector 16625 "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." 16626 16627 "(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]" 16628 ^ChangeSet 16629 scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil]) 16630 class: self meta: self isMeta 16631 category: (self whichCategoryIncludesSelector: selector) 16632 selector: selector.! ! 16633 16634!Behavior methodsFor: 'accessing method dictionary' stamp: 'mga 3/20/2005 11:11'! 16635commentsAt: selector 16636 "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote." 16637 16638 16639 ^self commentsIn: (self sourceCodeAt: selector) asString. 16640 16641"Behavior commentsAt: #commentsAt:"! ! 16642 16643!Behavior methodsFor: 'accessing method dictionary' stamp: 'mga 3/21/2005 10:53'! 16644commentsIn: sourceString 16645 16646 16647 | commentStart nextQuotePos someComments aPos | 16648 ('*"*' match: sourceString) ifFalse: [^#()]. 16649 someComments:= OrderedCollection new. 16650 sourceString size == 0 ifTrue: [^ someComments]. 16651 aPos:=1. 16652 nextQuotePos:= 0. 16653 [commentStart := sourceString findString: '"' startingAt: aPos. 16654 nextQuotePos:= self nextQuotePosIn: sourceString startingFrom: commentStart. 16655 (commentStart ~= 0 and: [nextQuotePos >commentStart])] whileTrue: [ 16656 commentStart ~= nextQuotePos ifTrue: [ 16657 someComments add: ((sourceString copyFrom: commentStart + 1 to: nextQuotePos - 1) copyReplaceAll: '""' with: '"').]. 16658 aPos := nextQuotePos+1]. 16659 ^someComments! ! 16660 16661!Behavior methodsFor: 'accessing method dictionary'! 16662compiledMethodAt: selector 16663 "Answer the compiled method associated with the argument, selector (a 16664 Symbol), a message selector in the receiver's method dictionary. If the 16665 selector is not in the dictionary, create an error notification." 16666 16667 ^ self methodDict at: selector! ! 16668 16669!Behavior methodsFor: 'accessing method dictionary'! 16670compiledMethodAt: selector ifAbsent: aBlock 16671 "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock" 16672 16673 ^ self methodDict at: selector ifAbsent: [aBlock value]! ! 16674 16675!Behavior methodsFor: 'accessing method dictionary'! 16676compress 16677 "Compact the method dictionary of the receiver." 16678 16679 self methodDict rehash! ! 16680 16681!Behavior methodsFor: 'accessing method dictionary'! 16682compressedSourceCodeAt: selector 16683 "(Paragraph compressedSourceCodeAt: #displayLines:affectedRectangle:) size 721 1921 16684 Paragraph selectors inject: 0 into: [:tot :sel | tot + (Paragraph compressedSourceCodeAt: sel) size] 13606 31450" 16685 | rawText parse | 16686 rawText := (self sourceCodeAt: selector) asString. 16687 parse := self compilerClass new parse: rawText in: self notifying: nil. 16688 ^ rawText compressWithTable: 16689 ((selector keywords , 16690 parse tempNames , 16691 self instVarNames , 16692 #(self super ifTrue: ifFalse:) , 16693 ((0 to: 7) collect: 16694 [:i | String streamContents: 16695 [:s | s cr. i timesRepeat: [s tab]]]) , 16696 (self compiledMethodAt: selector) literalStrings) 16697 asSortedCollection: [:a :b | a size > b size])! ! 16698 16699!Behavior methodsFor: 'accessing method dictionary'! 16700deregisterLocalSelector: aSymbol 16701 self basicLocalSelectors notNil ifTrue: [ 16702 self basicLocalSelectors remove: aSymbol ifAbsent: []]! ! 16703 16704!Behavior methodsFor: 'accessing method dictionary'! 16705firstCommentAt: selector 16706 "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote." 16707 16708 |someComments| 16709 someComments := self commentsAt: selector. 16710 ^someComments isEmpty ifTrue: [''] ifFalse: [someComments first] 16711 16712 16713"Behavior firstCommentAt: #firstCommentAt:"! ! 16714 16715!Behavior methodsFor: 'accessing method dictionary' stamp: 'damiencassou 5/30/2008 10:56'! 16716firstPrecodeCommentFor: selector 16717 "If there is a comment in the source code at the given selector that preceeds the body of the method, return it here, else return nil" 16718 "Behavior firstPrecodeCommentFor: #firstPrecodeCommentFor:" 16719 | parser source tree | 16720 (#(#Comment #Definition #Hierarchy ) includes: selector) ifTrue: 16721 [ "Not really a selector" 16722 ^ nil ]. 16723 source := self 16724 sourceCodeAt: selector asSymbol 16725 ifAbsent: [ ^ nil ]. 16726 parser := self parserClass new. 16727 tree := parser 16728 parse: source readStream 16729 class: self 16730 noPattern: false 16731 context: nil 16732 notifying: nil 16733 ifFail: [ ^ nil ]. 16734 ^ (tree comment ifNil: [ ^ nil ]) first! ! 16735 16736!Behavior methodsFor: 'accessing method dictionary'! 16737"popeye" formalHeaderPartsFor: "olive oil" aSelector 16738 "RELAX!! The warning you may have just seen about possibly having a bad source file does not apply here, because this method *intends* to have its source code start with a comment. 16739 This method returns a collection giving the parts in the formal declaration for aSelector. This parse is in support of schemes in which adjutant properties of a method can be declared via special comments secreted in the formal header 16740 The result will have 16741 3 elements for a simple, argumentless selector. 16742 5 elements for a single-argument selector 16743 9 elements for a two-argument selector 16744 13 elements for a three-argument, selector 16745 etc... 16746 16747 The syntactic elements are: 16748 16749 1 comment preceding initial selector fragment 16750 16751 2 first selector fragment 16752 3 comment following first selector fragment (nil if selector has no arguments) 16753 16754 ---------------------- (ends here for, e.g., #copy) 16755 16756 4 first formal argument 16757 5 comment following first formal argument (nil if selector has only one argument) 16758 16759 ---------------------- (ends here for, e.g., #copyFrom:) 16760 16761 6 second keyword 16762 7 comment following second keyword 16763 8 second formal argument 16764 9 comment following second formal argument (nil if selector has only two arguments) 16765 16766 ---------------------- (ends here for, e.g., #copyFrom:to:) 16767 16768 Any nil element signifies an absent comment. 16769 NOTE: The comment following the final formal argument is *not* successfully retrieved by this method in its current form, though it can be obtained, if needed, by other means (e.g. calling #firstPrecodeCommentFor:). Thus, the *final* element in the structure returned by this method is always going to be nil." 16770 16771 ^ Scanner new scanMessageParts: (self methodHeaderFor: aSelector) 16772 16773" 16774 Behavior class formalHeaderPartsFor: #formalHeaderPartsFor: 16775" 16776 16777 16778 ! ! 16779 16780!Behavior methodsFor: 'accessing method dictionary'! 16781formalParametersAt: aSelector 16782 "Return the names of the arguments used in this method." 16783 16784 | source parser message list params | 16785 source := self sourceCodeAt: aSelector ifAbsent: [^ #()]. "for now" 16786 (parser := self parserClass new) parseSelector: source. 16787 message := source copyFrom: 1 to: (parser endOfLastToken min: source size). 16788 list := message string findTokens: Character separators. 16789 params := OrderedCollection new. 16790 list withIndexDo: [:token :ind | ind even ifTrue: [params addLast: token]]. 16791 ^ params! ! 16792 16793!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 1/2/1999 15:45'! 16794lookupSelector: selector 16795 "Look up the given selector in my methodDictionary. 16796 Return the corresponding method if found. 16797 Otherwise chase the superclass chain and try again. 16798 Return nil if no method is found." 16799 | lookupClass | 16800 lookupClass := self. 16801 [lookupClass == nil] 16802 whileFalse: 16803 [(lookupClass includesSelector: selector) 16804 ifTrue: [^ lookupClass compiledMethodAt: selector]. 16805 lookupClass := lookupClass superclass]. 16806 ^ nil! ! 16807 16808!Behavior methodsFor: 'accessing method dictionary' stamp: 'dvf 9/27/2005 17:08'! 16809methodDict: aDictionary 16810 methodDict := aDictionary! ! 16811 16812!Behavior methodsFor: 'accessing method dictionary'! 16813methodDictionary 16814 "Convenience" 16815 ^self methodDict! ! 16816 16817!Behavior methodsFor: 'accessing method dictionary'! 16818methodDictionary: aDictionary 16819 self methodDict: aDictionary! ! 16820 16821!Behavior methodsFor: 'accessing method dictionary'! 16822methodHeaderFor: selector 16823 "Answer the string corresponding to the method header for the given selector" 16824 16825 | sourceString parser | 16826 sourceString := self ultimateSourceCodeAt: selector ifAbsent: [self standardMethodHeaderFor: selector]. 16827 (parser := self parserClass new) parseSelector: sourceString. 16828 ^ sourceString asString copyFrom: 1 to: (parser endOfLastToken min: sourceString size) 16829 16830 "Behavior methodHeaderFor: #methodHeaderFor: " 16831! ! 16832 16833!Behavior methodsFor: 'accessing method dictionary'! 16834methodsDo: aBlock 16835 "Evaluate aBlock for all the compiled methods in my method dictionary." 16836 16837 ^ self methodDict valuesDo: aBlock! ! 16838 16839!Behavior methodsFor: 'accessing method dictionary' stamp: 'mga 3/21/2005 12:04'! 16840nextQuotePosIn: sourceString startingFrom: commentStart 16841 | pos nextQuotePos | 16842 pos := commentStart + 1. 16843 [((nextQuotePos := sourceString findString: '"' startingAt: pos) == (sourceString findString: '""' startingAt: pos)) and: [nextQuotePos ~= 0]] 16844 whileTrue: 16845 [pos := nextQuotePos + 2]. 16846 ^nextQuotePos! ! 16847 16848!Behavior methodsFor: 'accessing method dictionary'! 16849precodeCommentOrInheritedCommentFor: selector 16850 "Answer a string representing the first comment in the method associated 16851 with selector, considering however only comments that occur before the 16852 beginning of the actual code. If the version recorded in the receiver is 16853 uncommented, look up the inheritance chain. Return nil if none found." 16854 | aSuper aComment | 16855 ^ (aComment := self firstPrecodeCommentFor: selector) isEmptyOrNil 16856 ifTrue: [(self == Behavior 16857 or: [superclass == nil 16858 or: [(aSuper := superclass whichClassIncludesSelector: selector) == nil]]) 16859 ifFalse: [aSuper precodeCommentOrInheritedCommentFor: selector] 16860 "ActorState precodeCommentOrInheritedCommentFor: #printOn:"] 16861 ifFalse: [aComment]! ! 16862 16863!Behavior methodsFor: 'accessing method dictionary'! 16864registerLocalSelector: aSymbol 16865 self basicLocalSelectors notNil ifTrue: [ 16866 self basicLocalSelectors add: aSymbol]! ! 16867 16868!Behavior methodsFor: 'accessing method dictionary'! 16869removeSelector: aSelector 16870 "Assuming that the argument, selector (a Symbol), is a message selector 16871 in my method dictionary, remove it and its method. 16872 16873 If the method to remove will be replaced by a method from my trait composition, 16874 the current method does not have to be removed because we mark it as non-local. 16875 If it is not identical to the actual method from the trait it will be replaced automatically 16876 by #noteChangedSelectors:. 16877 16878 This is useful to avoid bootstrapping problems when moving methods to a trait 16879 (e.g., from TPureBehavior to TMethodDictionaryBehavior). Manual moving (implementing 16880 the method in the trait and then remove it from the class) does not work if the methods 16881 themselves are used for this process (such as compiledMethodAt:, includesLocalSelector: or 16882 addTraitSelector:withMethod:)" 16883 16884 | changeFromLocalToTraitMethod | 16885 changeFromLocalToTraitMethod := (self includesLocalSelector: aSelector) 16886 and: [self hasTraitComposition] 16887 and: [self traitComposition includesMethod: aSelector]. 16888 16889 changeFromLocalToTraitMethod 16890 ifFalse: [self basicRemoveSelector: aSelector] 16891 ifTrue: [self ensureLocalSelectors]. 16892 self deregisterLocalSelector: aSelector. 16893 self noteChangedSelectors: (Array with: aSelector) 16894 16895! ! 16896 16897!Behavior methodsFor: 'accessing method dictionary'! 16898removeSelectorSilently: selector 16899 "Remove selector without sending system change notifications" 16900 16901 ^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].! ! 16902 16903!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 3/27/1999 13:02'! 16904rootStubInImageSegment: imageSegment 16905 16906 ^ ImageSegmentRootStub new 16907 xxSuperclass: superclass 16908 format: format 16909 segment: imageSegment! ! 16910 16911!Behavior methodsFor: 'accessing method dictionary'! 16912selectors 16913 "Answer a Set of all the message selectors specified in the receiver's 16914 method dictionary." 16915 16916 ^ self methodDict keys! ! 16917 16918!Behavior methodsFor: 'accessing method dictionary'! 16919selectorsAndMethodsDo: aBlock 16920 "Evaluate selectorBlock for all the message selectors in my method dictionary." 16921 16922 ^ self methodDict keysAndValuesDo: aBlock! ! 16923 16924!Behavior methodsFor: 'accessing method dictionary'! 16925selectorsDo: selectorBlock 16926 "Evaluate selectorBlock for all the message selectors in my method dictionary." 16927 16928 ^ self methodDict keysDo: selectorBlock! ! 16929 16930!Behavior methodsFor: 'accessing method dictionary' stamp: 'md 1/2/2006 18:56'! 16931selectorsWithArgs: numberOfArgs 16932 "Return all selectors defined in this class that take this number of arguments" 16933 16934 ^ self selectors select: [:selector | selector numArgs = numberOfArgs]! ! 16935 16936!Behavior methodsFor: 'accessing method dictionary'! 16937sourceCodeAt: selector 16938 16939 ^ (self methodDict at: selector) getSourceFor: selector in: self! ! 16940 16941!Behavior methodsFor: 'accessing method dictionary'! 16942sourceCodeAt: selector ifAbsent: aBlock 16943 16944 ^ (self methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self! ! 16945 16946!Behavior methodsFor: 'accessing method dictionary'! 16947sourceMethodAt: selector 16948 "Answer the paragraph corresponding to the source code for the 16949 argument." 16950 16951 ^(self sourceCodeAt: selector) asText makeSelectorBoldIn: self! ! 16952 16953!Behavior methodsFor: 'accessing method dictionary'! 16954sourceMethodAt: selector ifAbsent: aBlock 16955 "Answer the paragraph corresponding to the source code for the 16956 argument." 16957 16958 ^ (self sourceCodeAt: selector ifAbsent: [^ aBlock value]) asText makeSelectorBoldIn: self! ! 16959 16960!Behavior methodsFor: 'accessing method dictionary'! 16961standardMethodHeaderFor: aSelector 16962 | args | 16963 args := (1 to: aSelector numArgs) collect:[:i| 'arg', i printString]. 16964 args size = 0 ifTrue:[^aSelector asString]. 16965 args size = 1 ifTrue:[^aSelector,' arg1']. 16966 ^String streamContents:[:s| 16967 (aSelector findTokens:':') with: args do:[:tok :arg| 16968 s nextPutAll: tok; nextPutAll:': '; nextPutAll: arg; nextPutAll:' '. 16969 ]. 16970 ]. 16971! ! 16972 16973!Behavior methodsFor: 'accessing method dictionary'! 16974supermostPrecodeCommentFor: selector 16975 "Answer a string representing the precode comment in the most distant 16976 superclass's implementation of the selector. Return nil if none found." 16977 | aSuper superComment | 16978 (self == Behavior 16979 or: [superclass == nil 16980 or: [(aSuper := superclass whichClassIncludesSelector: selector) == nil]]) 16981 ifFalse: ["There is a super implementor" 16982 superComment := aSuper supermostPrecodeCommentFor: selector]. 16983 ^ superComment 16984 ifNil: [self firstPrecodeCommentFor: selector 16985 "ActorState supermostPrecodeCommentFor: #printOn:"]! ! 16986 16987!Behavior methodsFor: 'accessing method dictionary' stamp: 'al 12/6/2004 11:36'! 16988ultimateSourceCodeAt: selector ifAbsent: aBlock 16989 "Return the source code at selector, deferring to superclass if necessary" 16990 ^ self sourceCodeAt: selector ifAbsent: 16991 [superclass 16992 ifNil: 16993 [aBlock value] 16994 ifNotNil: 16995 [superclass ultimateSourceCodeAt: selector ifAbsent: aBlock]]! ! 16996 16997!Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 11/19/2004 15:18'! 16998zapAllMethods 16999 "Remove all methods in this class which is assumed to be obsolete" 17000 17001 methodDict := self emptyMethodDictionary. 17002 self class isMeta ifTrue: [self class zapAllMethods]! ! 17003 17004 17005!Behavior methodsFor: 'adding/removing methods'! 17006basicAddSelector: selector withMethod: compiledMethod 17007 "Add the message selector with the corresponding compiled method to the 17008 receiver's method dictionary. 17009 Do this without sending system change notifications" 17010 17011 | oldMethodOrNil | 17012 oldMethodOrNil := self lookupSelector: selector. 17013 self methodDict at: selector put: compiledMethod. 17014 compiledMethod methodClass: self. 17015 compiledMethod selector: selector. 17016 17017 "Now flush Squeak's method cache, either by selector or by method" 17018 oldMethodOrNil ifNotNil: [oldMethodOrNil flushCache]. 17019 selector flushCache.! ! 17020 17021!Behavior methodsFor: 'adding/removing methods'! 17022localSelectors 17023 "Return a set of selectors defined locally. 17024 The instance variable is lazily initialized. If it is nil then there 17025 are no non-local selectors" 17026 17027 ^ self basicLocalSelectors isNil 17028 ifTrue: [self selectors] 17029 ifFalse: [self basicLocalSelectors].! ! 17030 17031!Behavior methodsFor: 'adding/removing methods'! 17032methodDictAddSelectorSilently: selector withMethod: compiledMethod 17033 self basicAddSelector: selector withMethod: compiledMethod! ! 17034 17035 17036!Behavior methodsFor: 'compiling'! 17037binding 17038 ^ nil -> self! ! 17039 17040!Behavior methodsFor: 'compiling'! 17041compile: code 17042 "Compile the argument, code, as source code in the context of the 17043 receiver. Create an error notification if the code can not be compiled. 17044 The argument is either a string or an object that converts to a string or a 17045 PositionableStream on an object that converts to a string." 17046 17047 ^self compile: code notifying: nil! ! 17048 17049!Behavior methodsFor: 'compiling'! 17050compile: code classified: category notifying: requestor trailer: bytes ifFail: failBlock 17051 "Compile code without logging the source in the changes file" 17052 17053 | methodNode | 17054 methodNode := self compilerClass new 17055 compile: code 17056 in: self 17057 classified: category 17058 notifying: requestor 17059 ifFail: failBlock. 17060 ^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! ! 17061 17062!Behavior methodsFor: 'compiling'! 17063compile: code notifying: requestor 17064 "Compile the argument, code, as source code in the context of the 17065 receiver and insEtall the result in the receiver's method dictionary. The 17066 second argument, requestor, is to be notified if an error occurs. The 17067 argument code is either a string or an object that converts to a string or 17068 a PositionableStream. This method also saves the source code." 17069 17070 | methodAndNode | 17071 methodAndNode := self 17072 compile: code "a Text" 17073 classified: nil 17074 notifying: requestor 17075 trailer: self defaultMethodTrailer 17076 ifFail: [^nil]. 17077 methodAndNode method putSource: code fromParseNode: methodAndNode node inFile: 2 17078 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr]. 17079 self addSelector: methodAndNode selector withMethod: methodAndNode method notifying: requestor. 17080 ^ methodAndNode selector! ! 17081 17082!Behavior methodsFor: 'compiling'! 17083compileAll 17084 ^ self compileAllFrom: self! ! 17085 17086!Behavior methodsFor: 'compiling'! 17087compileAllFrom: oldClass 17088 "Compile all the methods in the receiver's method dictionary. 17089 This validates sourceCode and variable references and forces 17090 all methods to use the current bytecode set" 17091 "ar 7/10/1999: Use oldClass selectors not self selectors" 17092 17093 oldClass selectorsDo: [:sel | self recompile: sel from: oldClass]. 17094 self environment currentProjectDo: [:proj | proj compileAllIsolated: self from: oldClass].! ! 17095 17096!Behavior methodsFor: 'compiling'! 17097decompile: selector 17098 "Find the compiled code associated with the argument, selector, as a 17099 message selector in the receiver's method dictionary and decompile it. 17100 Answer the resulting source code as a string. Create an error notification 17101 if the selector is not in the receiver's method dictionary." 17102 17103 ^self decompilerClass new decompile: selector in: self! ! 17104 17105!Behavior methodsFor: 'compiling'! 17106defaultMethodTrailer 17107 ^ #(0 0 0 0)! ! 17108 17109!Behavior methodsFor: 'compiling' stamp: 'eem 5/13/2008 09:50'! 17110instVarNamesAndOffsetsDo: aBinaryBlock 17111 "This is part of the interface between the compiler and a class's instance or field names. 17112 The class should enumerate aBinaryBlock with the instance variable name strings and 17113 their integer offsets. The order is important. Names evaluated later will override the 17114 same names occurring earlier." 17115 17116 "Nothing to do here; ClassDescription introduces named instance variables" 17117 ^self! ! 17118 17119!Behavior methodsFor: 'compiling'! 17120recompile: selector 17121 "Compile the method associated with selector in the receiver's method dictionary." 17122 ^self recompile: selector from: self! ! 17123 17124!Behavior methodsFor: 'compiling'! 17125recompile: selector from: oldClass 17126 "Compile the method associated with selector in the receiver's method dictionary." 17127 "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" 17128 | method trailer methodNode | 17129 method := oldClass compiledMethodAt: selector. 17130 trailer := method trailer. 17131 methodNode := self compilerClass new 17132 compile: (oldClass sourceCodeAt: selector) 17133 in: self 17134 notifying: nil 17135 ifFail: [^ self]. "Assume OK after proceed from SyntaxError" 17136 selector == methodNode selector ifFalse: [self error: 'selector changed!!']. 17137 self basicAddSelector: selector withMethod: (methodNode generate: trailer). 17138! ! 17139 17140!Behavior methodsFor: 'compiling'! 17141recompileChanges 17142 "Compile all the methods that are in the changes file. 17143 This validates sourceCode and variable references and forces 17144 methods to use the current bytecode set" 17145 17146 self selectorsDo: 17147 [:sel | (self compiledMethodAt: sel) fileIndex > 1 ifTrue: 17148 [self recompile: sel from: self]]! ! 17149 17150!Behavior methodsFor: 'compiling'! 17151recompileNonResidentMethod: method atSelector: selector from: oldClass 17152 "Recompile the method supplied in the context of this class." 17153 17154 | trailer methodNode | 17155 trailer := method trailer. 17156 methodNode := self compilerClass new 17157 compile: (method getSourceFor: selector in: oldClass) 17158 in: self 17159 notifying: nil 17160 ifFail: ["We're in deep doo-doo if this fails (syntax error). 17161 Presumably the user will correct something and proceed, 17162 thus installing the result in this methodDict. We must 17163 retrieve that new method, and restore the original (or remove) 17164 and then return the method we retrieved." 17165 ^ self error: 'see comment']. 17166 selector == methodNode selector ifFalse: [self error: 'selector changed!!']. 17167 ^ methodNode generate: trailer 17168! ! 17169 17170!Behavior methodsFor: 'compiling' stamp: 'eem 6/19/2008 09:08'! 17171variablesAndOffsetsDo: aBinaryBlock 17172 "This is the interface between the compiler and a class's instance or field names. The 17173 class should enumerate aBinaryBlock with the field definitions (with nil offsets) followed 17174 by the instance variable name strings and their integer offsets (1-relative). The order is 17175 important; names evaluated later will override the same names occurring earlier." 17176 17177 "Only need to do instance variables here. CProtoObject introduces field definitions." 17178 self instVarNamesAndOffsetsDo: aBinaryBlock! ! 17179 17180 17181!Behavior methodsFor: 'copying'! 17182copy 17183 "Answer a copy of the receiver without a list of subclasses." 17184 17185 | myCopy | 17186 myCopy := self shallowCopy. 17187 ^myCopy methodDictionary: self copyOfMethodDictionary! ! 17188 17189!Behavior methodsFor: 'copying'! 17190copyOfMethodDictionary 17191 "Return a copy of the receiver's method dictionary" 17192 17193 ^ self methodDict copy! ! 17194 17195!Behavior methodsFor: 'copying'! 17196deepCopy 17197 "Classes should only be shallowCopied or made anew." 17198 17199 ^ self shallowCopy! ! 17200 17201 17202!Behavior methodsFor: 'enumerating' stamp: 'apb 7/13/2004 00:40'! 17203allInstancesDo: aBlock 17204 "Evaluate the argument, aBlock, for each of the current instances of the 17205 receiver. 17206 17207 Because aBlock might change the class of inst (for example, using become:), 17208 it is essential to compute next before aBlock value: inst." 17209 | inst next | 17210 self == UndefinedObject ifTrue: [^ aBlock value: nil]. 17211 inst := self someInstance. 17212 [inst == nil] 17213 whileFalse: 17214 [ 17215 next := inst nextInstance. 17216 aBlock value: inst. 17217 inst := next]! ! 17218 17219!Behavior methodsFor: 'enumerating' stamp: 'tk 11/12/1999 11:36'! 17220allInstancesEverywhereDo: aBlock 17221 "Evaluate the argument, aBlock, for each of the current instances of the receiver. Including those in ImageSegments that are out on the disk. Bring each in briefly." 17222 17223 self == UndefinedObject ifTrue: [^ aBlock value: nil]. 17224 self allInstancesDo: aBlock. 17225 "Now iterate over instances in segments that are out on the disk." 17226 ImageSegment allSubInstancesDo: [:seg | 17227 seg allInstancesOf: self do: aBlock]. 17228! ! 17229 17230!Behavior methodsFor: 'enumerating' stamp: 'di 6/20/97 10:50'! 17231allSubInstancesDo: aBlock 17232 "Evaluate the argument, aBlock, for each of the current instances of the 17233 receiver and all its subclasses." 17234 17235 self allInstancesDo: aBlock. 17236 self allSubclassesDo: [:sub | sub allInstancesDo: aBlock]! ! 17237 17238!Behavior methodsFor: 'enumerating'! 17239allSubclassesDo: aBlock 17240 "Evaluate the argument, aBlock, for each of the receiver's subclasses." 17241 17242 self subclassesDo: 17243 [:cl | 17244 aBlock value: cl. 17245 cl allSubclassesDo: aBlock]! ! 17246 17247!Behavior methodsFor: 'enumerating' stamp: 'tk 8/18/1999 17:38'! 17248allSubclassesDoGently: aBlock 17249 "Evaluate the argument, aBlock, for each of the receiver's subclasses." 17250 17251 self subclassesDoGently: 17252 [:cl | 17253 cl isInMemory ifTrue: [ 17254 aBlock value: cl. 17255 cl allSubclassesDoGently: aBlock]]! ! 17256 17257!Behavior methodsFor: 'enumerating'! 17258allSuperclassesDo: aBlock 17259 "Evaluate the argument, aBlock, for each of the receiver's superclasses." 17260 17261 superclass == nil 17262 ifFalse: [aBlock value: superclass. 17263 superclass allSuperclassesDo: aBlock]! ! 17264 17265!Behavior methodsFor: 'enumerating'! 17266selectSubclasses: aBlock 17267 "Evaluate the argument, aBlock, with each of the receiver's (next level) 17268 subclasses as its argument. Collect into a Set only those subclasses for 17269 which aBlock evaluates to true. In addition, evaluate aBlock for the 17270 subclasses of each of these successful subclasses and collect into the set 17271 those for which aBlock evaluates true. Answer the resulting set." 17272 17273 | aSet | 17274 aSet := Set new. 17275 self allSubclasses do: 17276 [:aSubclass | 17277 (aBlock value: aSubclass) ifTrue: [aSet add: aSubclass]]. 17278 ^aSet! ! 17279 17280!Behavior methodsFor: 'enumerating'! 17281selectSuperclasses: aBlock 17282 "Evaluate the argument, aBlock, with the receiver's superclasses as the 17283 argument. Collect into an OrderedCollection only those superclasses for 17284 which aBlock evaluates to true. In addition, evaluate aBlock for the 17285 superclasses of each of these successful superclasses and collect into the 17286 OrderedCollection ones for which aBlock evaluates to true. Answer the 17287 resulting OrderedCollection." 17288 17289 | aSet | 17290 aSet := Set new. 17291 self allSuperclasses do: 17292 [:aSuperclass | 17293 (aBlock value: aSuperclass) ifTrue: [aSet add: aSuperclass]]. 17294 ^aSet! ! 17295 17296!Behavior methodsFor: 'enumerating'! 17297withAllSubclassesDo: aBlock 17298 "Evaluate the argument, aBlock, for the receiver and each of its 17299 subclasses." 17300 17301 aBlock value: self. 17302 self allSubclassesDo: aBlock! ! 17303 17304!Behavior methodsFor: 'enumerating' stamp: 'nk 2/14/2001 12:09'! 17305withAllSuperAndSubclassesDoGently: aBlock 17306 self allSuperclassesDo: aBlock. 17307 aBlock value: self. 17308 self allSubclassesDoGently: aBlock! ! 17309 17310!Behavior methodsFor: 'enumerating' stamp: 'ar 7/11/1999 04:21'! 17311withAllSuperclassesDo: aBlock 17312 "Evaluate the argument, aBlock, for each of the receiver's superclasses." 17313 aBlock value: self. 17314 superclass == nil 17315 ifFalse: [superclass withAllSuperclassesDo: aBlock]! ! 17316 17317 17318!Behavior methodsFor: 'initialize-release'! 17319emptyMethodDictionary 17320 17321 ^ MethodDictionary new! ! 17322 17323!Behavior methodsFor: 'initialize-release' stamp: 'NS 1/28/2004 11:17'! 17324forgetDoIts 17325 "get rid of old DoIt methods" 17326 self 17327 basicRemoveSelector: #DoIt; 17328 basicRemoveSelector: #DoItIn:! ! 17329 17330!Behavior methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:43'! 17331initialize 17332 "moved here from the class side's #new" 17333 super initialize. 17334 superclass := Object. 17335 "no longer sending any messages, some of them crash the VM" 17336 methodDict := self emptyMethodDictionary. 17337 format := Object format! ! 17338 17339!Behavior methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 15:07'! 17340nonObsoleteClass 17341 "Attempt to find and return the current version of this obsolete class" 17342 17343 | obsName | 17344 obsName := self name. 17345 [obsName beginsWith: 'AnObsolete'] 17346 whileTrue: [obsName := obsName copyFrom: 'AnObsolete' size + 1 to: obsName size]. 17347 ^ self environment at: obsName asSymbol! ! 17348 17349!Behavior methodsFor: 'initialize-release'! 17350obsolete 17351 "Invalidate and recycle local methods, 17352 e.g., zap the method dictionary if can be done safely." 17353 self canZapMethodDictionary 17354 ifTrue: [self methodDict: self emptyMethodDictionary]. 17355 self hasTraitComposition ifTrue: [ 17356 self traitComposition traits do: [:each | 17357 each removeUser: self]]! ! 17358 17359!Behavior methodsFor: 'initialize-release' stamp: 'al 12/12/2003 20:59'! 17360superclass: aClass methodDictionary: mDict format: fmt 17361 "Basic initialization of the receiver. 17362 Must only be sent to a new instance; else we would need Object flushCache." 17363 superclass := aClass. 17364 format := fmt. 17365 methodDict := mDict. 17366 self traitComposition: nil! ! 17367 17368 17369!Behavior methodsFor: 'instance creation' stamp: 'sd 3/28/2003 15:06'! 17370basicNew 17371 "Primitive. Answer an instance of the receiver (which is a class) with no 17372 indexable variables. Fail if the class is indexable. Essential. See Object 17373 documentation whatIsAPrimitive." 17374 17375 <primitive: 70> 17376 self isVariable ifTrue: [ ^ self basicNew: 0 ]. 17377 "space must be low" 17378 self environment signalLowSpace. 17379 ^ self basicNew "retry if user proceeds" 17380! ! 17381 17382!Behavior methodsFor: 'instance creation' stamp: 'sd 3/28/2003 15:06'! 17383basicNew: sizeRequested 17384 "Primitive. Answer an instance of this class with the number 17385 of indexable variables specified by the argument, sizeRequested. 17386 Fail if this class is not indexable or if the argument is not a 17387 positive Integer, or if there is not enough memory available. 17388 Essential. See Object documentation whatIsAPrimitive." 17389 17390 <primitive: 71> 17391 self isVariable ifFalse: 17392 [self error: self printString, ' cannot have variable sized instances']. 17393 (sizeRequested isInteger and: [sizeRequested >= 0]) ifTrue: 17394 ["arg okay; space must be low." 17395 self environment signalLowSpace. 17396 ^ self basicNew: sizeRequested "retry if user proceeds"]. 17397 self primitiveFailed! ! 17398 17399!Behavior methodsFor: 'instance creation' stamp: 'sw 5/4/2000 20:47'! 17400initializedInstance 17401 "Answer an instance of the receiver which in some sense is initialized. In the case of Morphs, this will yield an instance that can be attached to the Hand after having received the same kind of basic initialization that would be obtained from an instance chosen from the 'new morph' menu. Return nil if the receiver is reluctant for some reason to return such a thing" 17402 17403 ^ self new! ! 17404 17405!Behavior methodsFor: 'instance creation' stamp: 'Noury Bouraqadi 8/23/2003 14:51'! 17406new 17407 "Answer a new initialized instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable." 17408 17409 ^ self basicNew initialize 17410! ! 17411 17412!Behavior methodsFor: 'instance creation' stamp: 'sd 5/20/2004 11:20'! 17413new: sizeRequested 17414 "Answer an initialized instance of this class with the number of indexable 17415 variables specified by the argument, sizeRequested." 17416 17417 ^ (self basicNew: sizeRequested) initialize ! ! 17418 17419 17420!Behavior methodsFor: 'newcompiler'! 17421parseScope 17422 17423 ^ Smalltalk at: #ClassScope ifPresent: [:class | class new class: self]! ! 17424 17425 17426!Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:13'! 17427addObsoleteSubclass: aClass 17428 "Weakly remember that aClass was a subclass of the receiver and is now obsolete" 17429 | obs | 17430 17431 obs := ObsoleteSubclasses at: self ifAbsent:[WeakArray new]. 17432 (obs includes: aClass) ifTrue:[^self]. 17433 obs := obs copyWithout: nil. 17434 obs := obs copyWith: aClass. 17435 ObsoleteSubclasses at: self put: obs. 17436! ! 17437 17438!Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:20'! 17439obsoleteSubclasses 17440 "Return all the weakly remembered obsolete subclasses of the receiver" 17441 | obs | 17442 obs := ObsoleteSubclasses at: self ifAbsent: [^ #()]. 17443 ^ obs copyWithout: nil! ! 17444 17445!Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:21'! 17446removeAllObsoleteSubclasses 17447 "Remove all the obsolete subclasses of the receiver" 17448 ObsoleteSubclasses removeKey: self ifAbsent: []. 17449! ! 17450 17451!Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:22'! 17452removeObsoleteSubclass: aClass 17453 "Remove aClass from the weakly remembered obsolete subclasses" 17454 | obs | 17455 obs := ObsoleteSubclasses at: self ifAbsent:[^ self]. 17456 (obs includes: aClass) ifFalse:[^self]. 17457 obs := obs copyWithout: aClass. 17458 obs := obs copyWithout: nil. 17459 ObsoleteSubclasses at: self put: obs! ! 17460 17461 17462!Behavior methodsFor: 'printing'! 17463defaultNameStemForInstances 17464 "Answer a basis for external names for default instances of the receiver. 17465 For classees, the class-name itself is a good one." 17466 17467 ^ self name! ! 17468 17469!Behavior methodsFor: 'printing'! 17470literalScannedAs: scannedLiteral notifying: requestor 17471 "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote). 17472 If scannedLiteral is not an association, answer it. 17473 Else, if it is of the form: 17474 nil->#NameOfMetaclass 17475 answer nil->theMetaclass, if any has that name, else report an error. 17476 Else, if it is of the form: 17477 #NameOfGlobalVariable->anythiEng 17478 answer the global, class, or pool association with that nameE, if any, else 17479 add it to Undeclared a answer the new Association." 17480 17481 | key value | 17482 (scannedLiteral isVariableBinding) 17483 ifFalse: [^ scannedLiteral]. 17484 key := scannedLiteral key. 17485 value := scannedLiteral value. 17486 key isNil 17487 ifTrue: "###<metaclass soleInstance name>" 17488 [(self bindingOf: value) ifNotNil:[:assoc| 17489 (assoc value isKindOf: Behavior) 17490 ifTrue: [^ nil->assoc value class]]. 17491 requestor notify: 'No such metaclass'. 17492 ^false]. 17493 (key isSymbol) 17494 ifTrue: "##<global var name>" 17495 [(self bindingOf: key) ifNotNil:[:assoc | ^assoc]. 17496 Undeclared at: key put: nil. 17497 ^Undeclared bindingOf: key]. 17498 requestor notify: '## must be followed by a non-local variable name'. 17499 ^false 17500 17501" Form literalScannedAs: 14 notifying: nil 14 17502 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm 17503 Form literalScannedAs: ##OneBitForm notifying: nil OneBitForm->a Form 17504 Form literalScannedAs: ##Form notifying: nil Form->Form 17505 Form literalScannedAs: ###Form notifying: nil nilE->Form class 17506"! ! 17507 17508!Behavior methodsFor: 'printing'! 17509longPrintOn: aStream 17510 "Append to the argument, aStream, the names and values of all of the receiver's instance variables. But, not useful for a class with a method dictionary." 17511 17512 aStream nextPutAll: '<<too complex to show>>'; cr.! ! 17513 17514!Behavior methodsFor: 'printing'! 17515prettyPrinterClass 17516 ^ PrettyPrinting prettyPrinterClassFor: self! ! 17517 17518!Behavior methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 00:11'! 17519printHierarchy 17520 "Answer a description containing the names and instance variable names 17521 of all of the subclasses and superclasses of the receiver." 17522 17523 | aStream index | 17524 index := 0. 17525 aStream := (String new: 16) writeStream. 17526 self allSuperclasses reverseDo: 17527 [:aClass | 17528 aStream crtab: index. 17529 index := index + 1. 17530 aStream nextPutAll: aClass name. 17531 aStream space. 17532 aStream print: aClass instVarNames]. 17533 aStream cr. 17534 self printSubclassesOn: aStream level: index. 17535 ^aStream contents! ! 17536 17537!Behavior methodsFor: 'printing'! 17538printOn: aStream 17539 "Refer to the comment in Object|printOn:." 17540 17541 aStream nextPutAll: 'a descendent of '. 17542 superclass printOn: aStream! ! 17543 17544!Behavior methodsFor: 'printing' stamp: 'MPW 1/1/1901 21:56'! 17545printOnStream: aStream 17546 "Refer to the comment in Object|printOn:." 17547 17548 aStream print: 'a descendent of '; write:superclass.! ! 17549 17550!Behavior methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 17551printWithClosureAnalysisOn: aStream 17552 "Refer to the comment in Object|printOn:." 17553 17554 aStream nextPutAll: 'a descendent of '. 17555 superclass printWithClosureAnalysisOn: aStream! ! 17556 17557!Behavior methodsFor: 'printing'! 17558storeLiteral: aCodeLiteral on: aStream 17559 "Store aCodeLiteral on aStream, changing an Association to ##GlobalName 17560 or ###MetaclassSoleInstanceName format if appropriate" 17561 | key value | 17562 (aCodeLiteral isVariableBinding) 17563 ifFalse: 17564 [aCodeLiteral storeOn: aStream. 17565 ^self]. 17566 key := aCodeLiteral key. 17567 (key isNil and: [(value := aCodeLiteral value) isMemberOf: Metaclass]) 17568 ifTrue: 17569 [aStream nextPutAll: '###'; nextPutAll: value soleInstance name. 17570 ^self]. 17571 (key isSymbol and: [(self bindingOf: key) notNil]) 17572 ifTrue: 17573 [aStream nextPutAll: '##'; nextPutAll: key. 17574 ^self]. 17575 aCodeLiteral storeOn: aStream! ! 17576 17577 17578!Behavior methodsFor: 'queries' stamp: 'dvf 9/17/2001 00:18'! 17579whichClassDefinesClassVar: aString 17580 ^self whichSuperclassSatisfies: 17581 [:aClass | 17582 (aClass classVarNames collect: [:each | each asString]) 17583 includes: aString asString]! ! 17584 17585!Behavior methodsFor: 'queries' stamp: 'dvf 9/17/2001 00:18'! 17586whichClassDefinesInstVar: aString 17587 ^self 17588 whichSuperclassSatisfies: [:aClass | aClass instVarNames includes: aString]! ! 17589 17590!Behavior methodsFor: 'queries' stamp: 'bh 3/6/2000 00:51'! 17591whichSelectorsAssign: instVarName 17592 "Answer a Set of selectors whose methods store into the argument, 17593 instVarName, as a named instance variable." 17594 ^self whichSelectorsStoreInto: instVarName! ! 17595 17596!Behavior methodsFor: 'queries' stamp: 'bh 3/6/2000 00:52'! 17597whichSelectorsRead: instVarName 17598 "Answer a Set of selectors whose methods access the argument, 17599 instVarName, as a named instance variable." 17600 ^self whichSelectorsAccess: instVarName! ! 17601 17602!Behavior methodsFor: 'queries' stamp: 'dvf 9/17/2001 00:18'! 17603whichSuperclassSatisfies: aBlock 17604 (aBlock value: self) ifTrue: [^self]. 17605 ^superclass isNil 17606 ifTrue: [nil] 17607 ifFalse: [superclass whichSuperclassSatisfies: aBlock]! ! 17608 17609 17610!Behavior methodsFor: 'send caches'! 17611clearSendCaches 17612 LocalSends current clearOut: self! ! 17613 17614!Behavior methodsFor: 'send caches'! 17615hasRequiredSelectors 17616 ^ self requiredSelectors notEmpty! ! 17617 17618!Behavior methodsFor: 'send caches'! 17619requirements 17620 ^ self requiredSelectorsCache 17621 ifNil: [#()] 17622 ifNotNilDo: [:rsc | rsc requirements]! ! 17623 17624!Behavior methodsFor: 'send caches'! 17625sendCaches: aSendCaches 17626 ^ self explicitRequirement! ! 17627 17628!Behavior methodsFor: 'send caches'! 17629setRequiredStatusOf: selector to: aBoolean 17630 aBoolean 17631 ifTrue: [self requiredSelectorsCache addRequirement: selector] 17632 ifFalse: [self requiredSelectorsCache removeRequirement: selector].! ! 17633 17634!Behavior methodsFor: 'send caches'! 17635superRequirements 17636 ^ self requiredSelectorsCache superRequirements! ! 17637 17638 17639!Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! 17640shutDown 17641 "This message is sent on system shutdown to registered classes" 17642! ! 17643 17644!Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! 17645shutDown: quitting 17646 "This message is sent on system shutdown to registered classes" 17647 ^self shutDown.! ! 17648 17649!Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! 17650startUp 17651 "This message is sent to registered classes when the system is coming up." 17652! ! 17653 17654!Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! 17655startUp: resuming 17656 "This message is sent to registered classes when the system is coming up." 17657 ^self startUp! ! 17658 17659!Behavior methodsFor: 'system startup' stamp: 'tk 10/26/2001 16:06'! 17660startUpFrom: anImageSegment 17661 "Override this when a per-instance startUp message needs to be sent. For example, to correct the order of 16-bit non-pointer data when it came from a different endian machine." 17662 17663 ^ nil! ! 17664 17665 17666!Behavior methodsFor: 'testing'! 17667canZapMethodDictionary 17668 "Return true if it is safe to zap the method dictionary on #obsolete" 17669 ^true! ! 17670 17671!Behavior methodsFor: 'testing'! 17672instSize 17673 "Answer the number of named instance variables 17674 (as opposed to indexed variables) of the receiver." 17675 17676 self flag: #instSizeChange. "Smalltalk browseAllCallsOn: #instSizeChange" 17677" 17678 NOTE: This code supports the backward-compatible extension to 8 bits of instSize. 17679 When we revise the image format, it should become... 17680 ^ ((format bitShift: -1) bitAnd: 16rFF) - 1 17681 Note also that every other method in this category will require 17682 2 bits more of right shift after the change. 17683" 17684 ^ ((format bitShift: -10) bitAnd: 16rC0) + ((format bitShift: -1) bitAnd: 16r3F) - 1! ! 17685 17686!Behavior methodsFor: 'testing'! 17687instSpec 17688 ^ (format bitShift: -7) bitAnd: 16rF! ! 17689 17690!Behavior methodsFor: 'testing' stamp: 'ar 7/9/1999 18:18'! 17691isBehavior 17692 "Return true if the receiver is a behavior" 17693 ^true! ! 17694 17695!Behavior methodsFor: 'testing'! 17696isBits 17697 "Answer whether the receiver contains just bits (not pointers)." 17698 17699 ^ self instSpec >= 6! ! 17700 17701!Behavior methodsFor: 'testing'! 17702isBytes 17703 "Answer whether the receiver has 8-bit instance variables." 17704 17705 ^ self instSpec >= 8! ! 17706 17707!Behavior methodsFor: 'testing'! 17708isFixed 17709 "Answer whether the receiver does not have a variable (indexable) part." 17710 17711 ^self isVariable not! ! 17712 17713!Behavior methodsFor: 'testing' stamp: 'dvf 9/27/2005 14:57'! 17714isMeta 17715 ^ false! ! 17716 17717!Behavior methodsFor: 'testing' stamp: 'ar 7/14/1999 02:38'! 17718isObsolete 17719 "Return true if the receiver is obsolete." 17720 ^self instanceCount = 0! ! 17721 17722!Behavior methodsFor: 'testing'! 17723isPointers 17724 "Answer whether the receiver contains just pointers (not bits)." 17725 17726 ^self isBits not! ! 17727 17728!Behavior methodsFor: 'testing'! 17729isVariable 17730 "Answer whether the receiver has indexable variables." 17731 17732 ^ self instSpec >= 2! ! 17733 17734!Behavior methodsFor: 'testing' stamp: 'ar 3/21/98 02:36'! 17735isWeak 17736 "Answer whether the receiver has contains weak references." 17737 ^ self instSpec = 4! ! 17738 17739!Behavior methodsFor: 'testing'! 17740isWords 17741 "Answer whether the receiver has 16-bit instance variables." 17742 17743 ^self isBytes not! ! 17744 17745!Behavior methodsFor: 'testing' stamp: 'sd 3/28/2003 15:07'! 17746shouldNotBeRedefined 17747 "Return true if the receiver should not be redefined. 17748 The assumption is that compact classes, 17749 classes in Smalltalk specialObjects and 17750 Behaviors should not be redefined" 17751 17752 ^(self environment compactClassesArray includes: self) 17753 or:[(self environment specialObjectsArray includes: self) 17754 or:[self isKindOf: self]]! ! 17755 17756 17757!Behavior methodsFor: 'testing class hierarchy' stamp: 'ar 3/12/98 12:36'! 17758includesBehavior: aClass 17759 ^self == aClass or:[self inheritsFrom: aClass]! ! 17760 17761!Behavior methodsFor: 'testing class hierarchy'! 17762inheritsFrom: aClass 17763 "Answer whether the argument, aClass, is on the receiver's superclass 17764 chain." 17765 17766 | aSuperclass | 17767 aSuperclass := superclass. 17768 [aSuperclass == nil] 17769 whileFalse: 17770 [aSuperclass == aClass ifTrue: [^true]. 17771 aSuperclass := aSuperclass superclass]. 17772 ^false! ! 17773 17774!Behavior methodsFor: 'testing class hierarchy'! 17775kindOfSubclass 17776 "Answer a String that is the keyword that describes the receiver's kind 17777 of subclass, either a regular subclass, a variableSubclass, a 17778 variableByteSubclass, a variableWordSubclass, or a weakSubclass." 17779 self isWeak 17780 ifTrue: [^ ' weakSubclass: ']. 17781 ^ self isVariable 17782 ifTrue: [self isBits 17783 ifTrue: [self isBytes 17784 ifTrue: [ ' variableByteSubclass: '] 17785 ifFalse: [ ' variableWordSubclass: ']] 17786 ifFalse: [ ' variableSubclass: ']] 17787 ifFalse: [ ' subclass: ']! ! 17788 17789 17790!Behavior methodsFor: 'testing method dictionary' stamp: 'al 2/29/2004 14:18'! 17791bindingOf: varName 17792 "Answer the binding of some variable resolved in the scope of the receiver" 17793 ^superclass bindingOf: varName! ! 17794 17795!Behavior methodsFor: 'testing method dictionary' stamp: 'sd 5/7/2006 09:58'! 17796canPerform: selector 17797 "Answer whether the receiver can safely perform to the message whose selector 17798 is the argument: it is not an abstract or cancelled method" 17799 17800 ^ self classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false].! ! 17801 17802!Behavior methodsFor: 'testing method dictionary'! 17803canUnderstand: selector 17804 "Answer whether the receiver can respond to the message whose selector 17805 is the argument. The selector can be in the method dictionary of the 17806 receiver's class or any of its superclasses." 17807 17808 (self includesSelector: selector) ifTrue: [^true]. 17809 superclass == nil ifTrue: [^false]. 17810 ^superclass canUnderstand: selector! ! 17811 17812!Behavior methodsFor: 'testing method dictionary' stamp: 'ar 5/18/2003 18:13'! 17813classBindingOf: varName 17814 "Answer the binding of some variable resolved in the scope of the receiver's class" 17815 ^self bindingOf: varName! ! 17816 17817!Behavior methodsFor: 'testing method dictionary'! 17818hasMethods 17819 "Answer whether the receiver has any methods in its method dictionary." 17820 17821 ^ self methodDict notEmpty! ! 17822 17823!Behavior methodsFor: 'testing method dictionary'! 17824includesLocalSelector: aSymbol 17825 ^self basicLocalSelectors isNil 17826 ifTrue: [self includesSelector: aSymbol] 17827 ifFalse: [self localSelectors includes: aSymbol]! ! 17828 17829!Behavior methodsFor: 'testing method dictionary'! 17830includesSelector: aSymbol 17831 "Answer whether the message whose selector is the argument is in the 17832 method dictionary of the receiver's class." 17833 17834 ^ self methodDict includesKey: aSymbol! ! 17835 17836!Behavior methodsFor: 'testing method dictionary'! 17837isAliasSelector: aSymbol 17838 "Return true if the selector aSymbol is an alias defined 17839 in my or in another composition somewhere deeper in 17840 the tree of traits compositions." 17841 17842 ^(self includesLocalSelector: aSymbol) not 17843 and: [self hasTraitComposition] 17844 and: [self traitComposition isAliasSelector: aSymbol]! ! 17845 17846!Behavior methodsFor: 'testing method dictionary'! 17847isDisabledSelector: selector 17848 ^ self classAndMethodFor: selector do: [:c :m | m isDisabled] ifAbsent: [false]! ! 17849 17850!Behavior methodsFor: 'testing method dictionary'! 17851isLocalAliasSelector: aSymbol 17852 "Return true if the selector aSymbol is an alias defined 17853 in my trait composition." 17854 17855 ^(self includesLocalSelector: aSymbol) not 17856 and: [self hasTraitComposition] 17857 and: [self traitComposition isLocalAliasSelector: aSymbol]! ! 17858 17859!Behavior methodsFor: 'testing method dictionary'! 17860isProvidedSelector: selector 17861 ^ ProvidedSelectors current isSelector: selector providedIn: self 17862! ! 17863 17864!Behavior methodsFor: 'testing method dictionary' stamp: 'G.C 10/22/2008 09:59'! 17865thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte 17866 "Answer a set of selectors whose methods access the argument as a 17867 literal. Dives into the compact literal notation, making it slow but 17868 thorough " 17869 | selectors | 17870 selectors := IdentitySet new. 17871 self selectorsAndMethodsDo: 17872 [ :sel :method | 17873 ((method refersToLiteral: literal) or: [ specialFlag and: [ method scanFor: specialByte ] ]) ifTrue: [ selectors add: sel ] ]. 17874 ^ selectors! ! 17875 17876!Behavior methodsFor: 'testing method dictionary'! 17877whichClassIncludesSelector: aSymbol 17878 "Answer the class on the receiver's superclass chain where the 17879 argument, aSymbol (a message selector), will be found. Answer nil if none found." 17880 "Rectangle whichClassIncludesSelector: #inspect." 17881 (self includesSelector: aSymbol) 17882 ifTrue: [^ self]. 17883 superclass == nil 17884 ifTrue: [^ nil]. 17885 ^ superclass whichClassIncludesSelector: aSymbol! ! 17886 17887!Behavior methodsFor: 'testing method dictionary' stamp: 'eem 2/1/2007 14:14'! 17888whichSelectorsAccess: instVarName 17889 "Answer a set of selectors whose methods access the argument, 17890 instVarName, as a named instance variable." 17891 17892 | instVarIndex | 17893 instVarIndex := self instVarIndexFor: instVarName ifAbsent: [^IdentitySet new]. 17894 ^ self methodDict keys select: 17895 [:sel | 17896 ((self methodDict at: sel) 17897 readsField: instVarIndex) 17898 or: [(self methodDict at: sel) writesField: instVarIndex]] 17899 17900 "Point whichSelectorsAccess: 'x'."! ! 17901 17902!Behavior methodsFor: 'testing method dictionary'! 17903whichSelectorsReferTo: literal 17904 "Answer a Set of selectors whose methods access the argument as a 17905literal." 17906 17907 | special byte | 17908 special := self environment hasSpecialSelector: literal ifTrueSetByte: [:b | 17909byte := b]. 17910 ^self whichSelectorsReferTo: literal special: special byte: byte 17911 17912 "Rectangle whichSelectorsReferTo: #+."! ! 17913 17914!Behavior methodsFor: 'testing method dictionary'! 17915whichSelectorsReferTo: literal special: specialFlag byte: specialByte 17916 "Answer a set of selectors whose methods access the argument as a literal." 17917 17918 | who | 17919 who := IdentitySet new. 17920 self selectorsAndMethodsDo: 17921 [:sel :method | 17922 ((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]]) 17923 ifTrue: 17924 [((literal isVariableBinding) not 17925 or: [method literals allButLast includes: literal]) 17926 ifTrue: [who add: sel]]]. 17927 ^ who! ! 17928 17929!Behavior methodsFor: 'testing method dictionary' stamp: 'eem 2/1/2007 14:15'! 17930whichSelectorsStoreInto: instVarName 17931 "Answer a Set of selectors whose methods access the argument, 17932 instVarName, as a named instance variable." 17933 | instVarIndex | 17934 instVarIndex := self instVarIndexFor: instVarName ifAbsent: [^IdentitySet new]. 17935 ^ self methodDict keys select: 17936 [:sel | (self methodDict at: sel) writesField: instVarIndex] 17937 17938 "Point whichSelectorsStoreInto: 'x'."! ! 17939 17940 17941!Behavior methodsFor: 'traits'! 17942addExclusionOf: aSymbol to: aTrait 17943 self setTraitComposition: ( 17944 self traitComposition copyWithExclusionOf: aSymbol to: aTrait)! ! 17945 17946!Behavior methodsFor: 'traits'! 17947addToComposition: aTrait 17948 self setTraitComposition: (self traitComposition copyTraitExpression 17949 add: aTrait; 17950 yourself)! ! 17951 17952!Behavior methodsFor: 'traits'! 17953addTraitSelector: aSymbol withMethod: aCompiledMethod 17954 "Add aMethod with selector aSymbol to my 17955 methodDict. aMethod must not be defined locally." 17956 17957 | source methodAndNode | 17958 self assert: [(self includesLocalSelector: aSymbol) not]. 17959 self ensureLocalSelectors. 17960 17961 source := aCompiledMethod getSourceReplacingSelectorWith: aSymbol. 17962 methodAndNode := self 17963 compile: source 17964 classified: nil 17965 notifying: nil 17966 trailer: #(0 0 0 0) 17967 ifFail: [^nil]. 17968 methodAndNode method putSource: source fromParseNode: methodAndNode node inFile: 2 17969 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Trait method'; cr]. 17970 17971 self basicAddSelector: aSymbol withMethod: methodAndNode method! ! 17972 17973!Behavior methodsFor: 'traits'! 17974applyChangesOfNewTraitCompositionReplacing: oldComposition 17975 | changedSelectors | 17976 changedSelectors := self traitComposition 17977 changedSelectorsComparedTo: oldComposition. 17978 changedSelectors isEmpty ifFalse: [ 17979 self noteChangedSelectors: changedSelectors]. 17980 self traitComposition isEmpty ifTrue: [ 17981 self purgeLocalSelectors]. 17982 ^changedSelectors! ! 17983 17984!Behavior methodsFor: 'traits'! 17985ensureLocalSelectors 17986 "Ensures that the instance variable localSelectors is effectively used to maintain 17987 the set of local selectors. 17988 This method must be called before any non-local selectors are added to the 17989 method dictionary!!" 17990 17991 self basicLocalSelectors isNil 17992 ifTrue: [self basicLocalSelectors: self selectors]! ! 17993 17994!Behavior methodsFor: 'traits'! 17995flattenDown: aTrait 17996 | selectors | 17997 self assert: [self hasTraitComposition and: [self traitComposition allTraits includes: aTrait]]. 17998 selectors := (self traitComposition transformationOfTrait: aTrait) selectors. 17999 self basicLocalSelectors: self basicLocalSelectors , selectors. 18000 self removeFromComposition: aTrait.! ! 18001 18002!Behavior methodsFor: 'traits'! 18003flattenDownAllTraits 18004 self traitComposition allTraits do: [:each | self flattenDown: each]. 18005 self assert: [ self traitComposition isEmpty ]. 18006 self traitComposition: nil.! ! 18007 18008!Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:39'! 18009hasTraitComposition 18010 self subclassResponsibility ! ! 18011 18012!Behavior methodsFor: 'traits'! 18013noteChangedSelectors: aCollection 18014 "Start update of my methodDict (after changes to traits in traitComposition 18015 or after a local method was removed from my methodDict). The argument 18016 is a collection of method selectors that may have been changed. Most of the time 18017 aCollection only holds one selector. But when there are aliases involved 18018 there may be several method changes that have to be propagated to users." 18019 18020 | affectedSelectors | 18021 affectedSelectors := IdentitySet new. 18022 aCollection do: [:selector | 18023 affectedSelectors addAll: (self updateMethodDictionarySelector: selector)]. 18024 self notifyUsersOfChangedSelectors: affectedSelectors. 18025 ^ affectedSelectors! ! 18026 18027!Behavior methodsFor: 'traits'! 18028notifyUsersOfChangedSelector: aSelector 18029 self notifyUsersOfChangedSelectors: (Array with: aSelector)! ! 18030 18031!Behavior methodsFor: 'traits'! 18032notifyUsersOfChangedSelectors: aCollection! ! 18033 18034!Behavior methodsFor: 'traits'! 18035purgeLocalSelectors 18036 self basicLocalSelectors: nil! ! 18037 18038!Behavior methodsFor: 'traits'! 18039removeAlias: aSymbol of: aTrait 18040 self setTraitComposition: ( 18041 self traitComposition copyWithoutAlias: aSymbol of: aTrait)! ! 18042 18043!Behavior methodsFor: 'traits'! 18044removeFromComposition: aTrait 18045 self setTraitComposition: (self traitComposition copyTraitExpression 18046 removeFromComposition: aTrait)! ! 18047 18048!Behavior methodsFor: 'traits'! 18049removeTraitSelector: aSymbol 18050 self assert: [(self includesLocalSelector: aSymbol) not]. 18051 self basicRemoveSelector: aSymbol! ! 18052 18053!Behavior methodsFor: 'traits'! 18054selfSentSelectorsFromSelectors: interestingSelectors 18055 | m result info | 18056 result := IdentitySet new. 18057 interestingSelectors collect: 18058 [:sel | 18059 m := self compiledMethodAt: sel ifAbsent: []. 18060 m ifNotNil: 18061 [info := (SendInfo on: m) collectSends. 18062 info selfSentSelectors do: [:sentSelector | result add: sentSelector]]]. 18063 ^result! ! 18064 18065!Behavior methodsFor: 'traits'! 18066setTraitComposition: aTraitComposition 18067 | oldComposition | 18068 (self hasTraitComposition not and: [aTraitComposition isEmpty]) ifTrue: [^self]. 18069 aTraitComposition assertValidUser: self. 18070 18071 oldComposition := self traitComposition. 18072 self traitComposition: aTraitComposition. 18073 self applyChangesOfNewTraitCompositionReplacing: oldComposition. 18074 18075 oldComposition traits do: [:each | each removeUser: self]. 18076 aTraitComposition traits do: [:each | each addUser: self]! ! 18077 18078!Behavior methodsFor: 'traits'! 18079setTraitCompositionFrom: aTraitExpression 18080 ^ self setTraitComposition: aTraitExpression asTraitComposition! ! 18081 18082!Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:36'! 18083traitComposition 18084 self subclassResponsibility! ! 18085 18086!Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:39'! 18087traitComposition: aTraitComposition 18088 self subclassResponsibility ! ! 18089 18090!Behavior methodsFor: 'traits'! 18091traitCompositionIncludes: aTrait 18092 ^self == aTrait or: 18093 [self hasTraitComposition and: 18094 [self traitComposition allTraits includes: aTrait]]! ! 18095 18096!Behavior methodsFor: 'traits'! 18097traitCompositionString 18098 ^self hasTraitComposition 18099 ifTrue: [self traitComposition asString] 18100 ifFalse: ['{}']! ! 18101 18102!Behavior methodsFor: 'traits'! 18103traitOrClassOfSelector: aSymbol 18104 "Return the trait or the class which originally defines the method aSymbol 18105 or return self if locally defined or if it is a conflict marker method. 18106 This is primarly used by Debugger to determin the behavior in which a recompiled 18107 method should be put. If a conflict method is recompiled it should be put into 18108 the class, thus return self. Also see TraitComposition>>traitProvidingSelector:" 18109 18110 ((self includesLocalSelector: aSymbol) or: [ 18111 self hasTraitComposition not]) ifTrue: [^self]. 18112 ^(self traitComposition traitProvidingSelector: aSymbol) ifNil: [self]! ! 18113 18114!Behavior methodsFor: 'traits'! 18115traitTransformations 18116 ^ self traitComposition transformations ! ! 18117 18118!Behavior methodsFor: 'traits'! 18119traits 18120 "Returns a collection of all traits used by the receiver" 18121 ^ self traitComposition traits! ! 18122 18123!Behavior methodsFor: 'traits'! 18124traitsProvidingSelector: aSymbol 18125 | result | 18126 result := OrderedCollection new. 18127 self hasTraitComposition ifFalse: [^result]. 18128 (self traitComposition methodDescriptionsForSelector: aSymbol) 18129 do: [:methodDescription | methodDescription selector = aSymbol ifTrue: [ 18130 result addAll: (methodDescription locatedMethods 18131 collect: [:each | each location])]]. 18132 ^result! ! 18133 18134!Behavior methodsFor: 'traits'! 18135updateMethodDictionarySelector: aSymbol 18136 "A method with selector aSymbol in myself or my traitComposition has been changed. 18137 Do the appropriate update to my methodDict (remove or update method) and 18138 return all affected selectors of me so that my useres get notified." 18139 18140 | effectiveMethod modifiedSelectors descriptions selector | 18141 modifiedSelectors := IdentitySet new. 18142 descriptions := self hasTraitComposition 18143 ifTrue: [ self traitComposition methodDescriptionsForSelector: aSymbol ] 18144 ifFalse: [ #() ]. 18145 descriptions do: [:methodDescription | 18146 selector := methodDescription selector. 18147 (self includesLocalSelector: selector) ifFalse: [ 18148 methodDescription isEmpty 18149 ifTrue: [ 18150 self removeTraitSelector: selector. 18151 modifiedSelectors add: selector] 18152 ifFalse: [ 18153 effectiveMethod := methodDescription effectiveMethod. 18154 self addTraitSelector: selector withMethod: effectiveMethod. 18155 modifiedSelectors add: selector]]]. 18156 ^modifiedSelectors! ! 18157 18158 18159!Behavior methodsFor: 'user interface' stamp: 'md 8/27/2005 17:18'! 18160allLocalCallsOn: aSymbol 18161 "Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy." 18162 18163 | aSet special byte cls | 18164 aSet := Set new. 18165 cls := self theNonMetaClass. 18166 special := self environment hasSpecialSelector: aSymbol 18167 ifTrueSetByte: [:b | byte := b ]. 18168 cls withAllSuperAndSubclassesDoGently: [ :class | 18169 (class whichSelectorsReferTo: aSymbol special: special byte: byte) 18170 do: [:sel | 18171 sel isDoIt ifFalse: [aSet add: class name , ' ', sel]]]. 18172 cls class withAllSuperAndSubclassesDoGently: [ :class | 18173 (class whichSelectorsReferTo: aSymbol special: special byte: byte) 18174 do: [:sel | 18175 sel isDoIt ifFalse: [aSet add: class name , ' ', sel]]]. 18176 ^aSet! ! 18177 18178!Behavior methodsFor: 'user interface' stamp: 'marcus.denker 9/29/2008 15:17'! 18179allUnreferencedInstanceVariables 18180 "Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses" 18181 18182 ^ self allInstVarNames reject: [:ivn | 18183 | definingClass | 18184 definingClass := self classThatDefinesInstanceVariable: ivn. 18185 definingClass withAllSubclasses anySatisfy: [:class | 18186 (class whichSelectorsAccess: ivn asSymbol) notEmpty]]! ! 18187 18188!Behavior methodsFor: 'user interface'! 18189crossReference 18190 "Answer an Array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included." 18191 18192 ^self selectors asSortedCollection asArray collect: [:x | Array 18193 with: (String with: Character cr), x 18194 with: (self whichSelectorsReferTo: x)] 18195 18196 "Point crossReference."! ! 18197 18198!Behavior methodsFor: 'user interface' stamp: 'marcus.denker 9/29/2008 13:01'! 18199unreferencedInstanceVariables 18200 "Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses." 18201 18202 ^ self instVarNames reject: [:ivn | 18203 self withAllSubclasses anySatisfy: [:class | 18204 (class whichSelectorsAccess: ivn) notEmpty]]! ! 18205 18206!Behavior methodsFor: 'user interface' stamp: 'RAA 5/28/2001 12:00'! 18207withAllSubAndSuperclassesDo: aBlock 18208 18209 self withAllSubclassesDo: aBlock. 18210 self allSuperclassesDo: aBlock. 18211! ! 18212 18213 18214!Behavior methodsFor: 'private'! 18215basicRemoveSelector: selector 18216 "Assuming that the argument, selector (a Symbol), is a message selector 18217 in my method dictionary, remove it and its method." 18218 18219 | oldMethod | 18220 oldMethod := self methodDict at: selector ifAbsent: [^ self]. 18221 self methodDict removeKey: selector. 18222 18223 "Now flush Squeak's method cache, either by selector or by method" 18224 oldMethod flushCache. 18225 selector flushCache! ! 18226 18227!Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06'! 18228becomeCompact 18229 "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." 18230 | cct index | 18231 18232 self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. 18233 cct := self environment compactClassesArray. 18234 (self indexIfCompact > 0 or: [cct includes: self]) 18235 ifTrue: [^ self halt: self name , 'is already compact']. 18236 index := cct indexOf: nil 18237 ifAbsent: [^ self halt: 'compact class table is full']. 18238 "Install this class in the compact class table" 18239 cct at: index put: self. 18240 "Update instspec so future instances will be compact" 18241 format := format + (index bitShift: 11). 18242 "Make up new instances and become old ones into them" 18243 self updateInstancesFrom: self. 18244 "Purge any old instances" 18245 Smalltalk garbageCollect.! ! 18246 18247!Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06'! 18248becomeCompactSimplyAt: index 18249 "Make me compact, but don't update the instances. For importing segments." 18250"Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." 18251 | cct | 18252 18253 self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. 18254 cct := self environment compactClassesArray. 18255 (self indexIfCompact > 0 or: [cct includes: self]) 18256 ifTrue: [^ self halt: self name , 'is already compact']. 18257 (cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use']. 18258 "Install this class in the compact class table" 18259 cct at: index put: self. 18260 "Update instspec so future instances will be compact" 18261 format := format + (index bitShift: 11). 18262 "Caller must convert the instances" 18263! ! 18264 18265!Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06'! 18266becomeUncompact 18267 | cct index | 18268 cct := self environment compactClassesArray. 18269 (index := self indexIfCompact) = 0 18270 ifTrue: [^ self]. 18271 (cct includes: self) 18272 ifFalse: [^ self halt "inconsistent state"]. 18273 "Update instspec so future instances will not be compact" 18274 format := format - (index bitShift: 11). 18275 "Make up new instances and become old ones into them" 18276 self updateInstancesFrom: self. 18277 "Make sure there are no compact ones left around" 18278 Smalltalk garbageCollect. 18279 "Remove this class from the compact class table" 18280 cct at: index put: nil. 18281! ! 18282 18283!Behavior methodsFor: 'private'! 18284flushCache 18285 "Tell the interpreter to remove the contents of its method lookup cache, if it has 18286 one. Essential. See Object documentation whatIsAPrimitive." 18287 18288 <primitive: 89> 18289 self primitiveFailed! ! 18290 18291!Behavior methodsFor: 'private'! 18292indexIfCompact 18293 "If these 5 bits are non-zero, then instances of this class 18294 will be compact. It is crucial that there be an entry in 18295 Smalltalk compactClassesArray for any class so optimized. 18296 See the msgs becomeCompact and becomeUncompact." 18297 ^ (format bitShift: -11) bitAnd: 16r1F 18298" 18299Smalltalk compactClassesArray doWithIndex: 18300 [:c :i | c == nil ifFalse: 18301 [c indexIfCompact = i ifFalse: [self halt]]] 18302"! ! 18303 18304!Behavior methodsFor: 'private' stamp: 'sd 11/19/2004 15:13'! 18305setFormat: aFormatInstanceDescription 18306 "only use this method with extreme care since it modifies the format of the class 18307 ie a description of the number of instance variables and whether the class is 18308 compact, variable sized" 18309 18310 format := aFormatInstanceDescription 18311 18312! ! 18313 18314!Behavior methodsFor: 'private'! 18315spaceUsed 18316 "Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables." 18317 18318 | space | 18319 space := 0. 18320 self selectorsDo: [:sel | | method | 18321 space := space + 16. "dict and org'n space" 18322 method := self compiledMethodAt: sel. 18323 space := space + (method size + 6 "hdr + avg pad"). 18324 method literalsDo: [:lit | 18325 (lit isMemberOf: Array) ifTrue: [space := space + ((lit size + 1) * 4)]. 18326 (lit isMemberOf: Float) ifTrue: [space := space + 12]. 18327 (lit isMemberOf: ByteString) ifTrue: [space := space + (lit size + 6)]. 18328 (lit isMemberOf: LargeNegativeInteger) ifTrue: [space := space + ((lit size + 1) * 4)]. 18329 (lit isMemberOf: LargePositiveInteger) ifTrue: [space := space + ((lit size + 1) * 4)]]]. 18330 ^ space! ! 18331 18332"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 18333 18334Behavior class 18335 uses: TPureBehavior classTrait 18336 instanceVariableNames: ''! 18337 18338!Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:23'! 18339flushObsoleteSubclasses 18340 "Behavior flushObsoleteSubclasses" 18341 ObsoleteSubclasses finalizeValues.! ! 18342 18343!Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:51'! 18344initialize 18345 "Behavior initialize" 18346 "Never called for real" 18347 ObsoleteSubclasses 18348 ifNil: [self initializeObsoleteSubclasses] 18349 ifNotNil: [| newDict | 18350 newDict := WeakKeyToCollectionDictionary newFrom: ObsoleteSubclasses. 18351 newDict rehash. 18352 ObsoleteSubclasses := newDict]! ! 18353 18354!Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:46'! 18355initializeObsoleteSubclasses 18356 ObsoleteSubclasses := WeakKeyToCollectionDictionary new.! ! 18357 18358 18359!Behavior class methodsFor: 'testing' stamp: 'dvf 9/27/2005 16:12'! 18360canZapMethodDictionary 18361 "Return false since zapping the method dictionary of Behavior class or its subclasses will cause the system to fail." 18362 ^false! ! 18363TestCase subclass: #BehaviorTest 18364 instanceVariableNames: '' 18365 classVariableNames: '' 18366 poolDictionaries: '' 18367 category: 'KernelTests-Classes'! 18368 18369!BehaviorTest methodsFor: 'tests' stamp: 'dc 9/28/2008 16:46'! 18370testAllSelectors 18371 self assert: ProtoObject allSelectors = ProtoObject selectors. 18372 self assert: Object allSelectors = (Object selectors union: ProtoObject selectors). 18373 self assert: (Object allSelectorsBelow: ProtoObject) = (Object selectors).! ! 18374 18375!BehaviorTest methodsFor: 'tests' stamp: 'sd 1/28/2009 14:32'! 18376testAllSelectorsAbove 18377 "self debug: #testAllSelectorsAbove" 18378 18379 |sels | 18380 sels := Morph allSelectorsAbove. 18381 self deny: (sels includes: #submorphs). 18382 self deny: (sels includes: #submorphs). 18383 self assert: (sels includes: #clearHaltOnce). 18384 self assert: (sels includes: #cannotInterpret: ) 18385 ! ! 18386 18387!BehaviorTest methodsFor: 'tests' stamp: 'sd 1/28/2009 14:31'! 18388testAllSelectorsAboveUntil 18389 "self debug: #testAllSelectorsAboveUntil" 18390 18391 |sels | 18392 sels := Morph allSelectorsAboveUntil: Object.. 18393 self deny: (sels includes: #submorphs). 18394 self deny: (sels includes: #submorphs). 18395 self assert: (sels includes: #clearHaltOnce). 18396 self deny: (sels includes: #cannotInterpret: ) 18397 ! ! 18398 18399!BehaviorTest methodsFor: 'tests' stamp: 'sd 3/14/2004 18:11'! 18400testBehaviorSubclasses 18401 "self run: #testBehaviorSubclasses" 18402 18403 | b b2 | 18404 b := Behavior new. 18405 b superclass: OrderedCollection. 18406 b methodDictionary: MethodDictionary new. 18407 self shouldnt: [b subclasses ] raise: Error. 18408 self shouldnt: [b withAllSubclasses] raise: Error. 18409 self shouldnt: [b allSubclasses] raise: Error. 18410 b2 := Behavior new. 18411 b2 superclass: b. 18412 b2 methodDictionary: MethodDictionary new. 18413 self assert: (b subclasses includes: b2). 18414 self assert: (b withAllSubclasses includes: b).! ! 18415 18416!BehaviorTest methodsFor: 'tests' stamp: 'sd 11/19/2004 15:38'! 18417testBehaviornewnewShouldNotCrash 18418 18419 Behavior new new. 18420 "still not working correctly but at least does not crash the image" 18421 ! ! 18422 18423!BehaviorTest methodsFor: 'tests' stamp: 'marcus.denker 9/14/2008 21:14'! 18424testBinding 18425 self assert: Object binding value = Object. 18426 self assert: Object binding key = #Object. 18427 18428 self assert: Object class binding value = Object class. 18429 18430 "returns nil for Metaclasses... like Encoder>>#associationFor:" 18431 18432 self assert: Object class binding key isNil.! ! 18433 18434!BehaviorTest methodsFor: 'tests' stamp: 'ar 9/27/2005 21:43'! 18435testChange 18436 "self debug: #testChange" 18437 18438 | behavior model | 18439 behavior := Behavior new. 18440 behavior superclass: Model. 18441 behavior setFormat: Model format. 18442 model := Model new. 18443 model primitiveChangeClassTo: behavior new. 18444 behavior compile: 'thisIsATest ^ 2'. 18445 self assert: model thisIsATest = 2. 18446 self should: [Model new thisIsATest] raise: MessageNotUnderstood. 18447 18448 18449! ! 18450 18451!BehaviorTest methodsFor: 'tests' stamp: 'sd 1/28/2009 14:25'! 18452testallSuperclassesIncluding 18453 "self debug: #testallSuperclassesIncluding" 18454 18455 |cls | 18456 cls := ArrayedCollection allSuperclassesIncluding: Collection. 18457 self deny: (cls includes: ArrayedCollection). 18458 self deny: (cls includes: Object). 18459 self assert: (cls includes: Collection). 18460 self assert: (cls includes: SequenceableCollection). ! ! 18461 18462 18463!BehaviorTest methodsFor: 'tests - testing method dictionary' stamp: 'marcus.denker 9/29/2008 15:11'! 18464testWhichSelectorsAccess 18465 self assert: ((Point whichSelectorsAccess: 'x') includes: #x). 18466 self deny: ((Point whichSelectorsAccess: 'y') includes: #x).! ! 18467LineSegment subclass: #Bezier2Segment 18468 instanceVariableNames: 'via' 18469 classVariableNames: '' 18470 poolDictionaries: '' 18471 category: 'Balloon-Geometry'! 18472!Bezier2Segment commentStamp: '<historical>' prior: 0! 18473This class represents a quadratic bezier segment between two points 18474 18475Instance variables: 18476 via <Point> The additional control point (OFF the curve)! 18477 18478 18479!Bezier2Segment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:14'! 18480bounds 18481 "Return the bounds containing the receiver" 18482 ^super bounds encompass: via! ! 18483 18484!Bezier2Segment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'! 18485degree 18486 ^2! ! 18487 18488!Bezier2Segment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:14'! 18489via 18490 "Return the control point" 18491 ^via! ! 18492 18493 18494!Bezier2Segment methodsFor: 'bezier clipping' stamp: 'ar 6/7/2003 23:45'! 18495bezierClipHeight: dir 18496 | dirX dirY uMin uMax dx dy u | 18497 dirX := dir x. 18498 dirY := dir y. 18499 uMin := 0.0. 18500 uMax := (dirX * dirX) + (dirY * dirY). 18501 dx := via x - start x. 18502 dy := via y - start y. 18503 u := (dirX * dx) + (dirY * dy). 18504 u < uMin ifTrue:[uMin := u]. 18505 u > uMax ifTrue:[uMax := u]. 18506 ^uMin@uMax! ! 18507 18508 18509!Bezier2Segment methodsFor: 'converting' stamp: 'ar 6/8/2003 04:19'! 18510asBezier2Points: error 18511 ^Array with: start with: via with: end! ! 18512 18513!Bezier2Segment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:17'! 18514asBezier2Segment 18515 "Represent the receiver as quadratic bezier segment" 18516 ^self! ! 18517 18518!Bezier2Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:05'! 18519asBezier3Segment 18520 "Represent the receiver as cubic bezier segment" 18521 ^Bezier3Segment 18522 from: start 18523 via: 2*via+start / 3.0 18524 and: 2*via+end / 3.0 18525 to: end! ! 18526 18527!Bezier2Segment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:18'! 18528asIntegerSegment 18529 "Convert the receiver into integer representation" 18530 ^self species 18531 from: start asIntegerPoint 18532 to: end asIntegerPoint 18533 via: via asIntegerPoint! ! 18534 18535!Bezier2Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 20:58'! 18536asTangentSegment 18537 ^LineSegment from: via-start to: end-via! ! 18538 18539 18540!Bezier2Segment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:13'! 18541from: startPoint to: endPoint 18542 "Initialize the receiver as straight line" 18543 start := startPoint. 18544 end := endPoint. 18545 via := (start + end) // 2.! ! 18546 18547!Bezier2Segment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:13'! 18548from: startPoint to: endPoint via: viaPoint 18549 "Initialize the receiver" 18550 start := startPoint. 18551 end := endPoint. 18552 via := viaPoint.! ! 18553 18554!Bezier2Segment methodsFor: 'initialize' stamp: 'ar 6/7/2003 22:37'! 18555from: startPoint to: endPoint withMidPoint: pointOnCurve 18556 "Initialize the receiver with the pointOnCurve assumed at the parametric value 0.5" 18557 start := startPoint. 18558 end := endPoint. 18559 "Compute via" 18560 via := (pointOnCurve * 2) - (start + end * 0.5).! ! 18561 18562!Bezier2Segment methodsFor: 'initialize' stamp: 'ar 6/6/2003 03:03'! 18563from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter 18564 "Initialize the receiver with the pointOnCurve at the given parametric value" 18565 | t1 t2 t3 | 18566 start := startPoint. 18567 end := endPoint. 18568 "Compute via" 18569 t1 := (1.0 - parameter) squared. 18570 t2 := 1.0 / (2 * parameter * (1.0 - parameter)). 18571 t3 := parameter squared. 18572 via := (pointOnCurve - (start * t1) - (end * t3)) * t2! ! 18573 18574!Bezier2Segment methodsFor: 'initialize' stamp: 'ar 6/7/2003 00:09'! 18575initializeFrom: controlPoints 18576 controlPoints size = 3 ifFalse:[self error:'Wrong number of control points']. 18577 start := controlPoints at: 1. 18578 via := controlPoints at: 2. 18579 end := controlPoints at: 3.! ! 18580 18581 18582!Bezier2Segment methodsFor: 'printing' stamp: 'ar 11/2/1998 12:18'! 18583printOn: aStream 18584 "Print the receiver on aStream" 18585 aStream 18586 nextPutAll: self class name; 18587 nextPutAll:' from: '; 18588 print: start; 18589 nextPutAll: ' via: '; 18590 print: via; 18591 nextPutAll: ' to: '; 18592 print: end; 18593 space.! ! 18594 18595!Bezier2Segment methodsFor: 'printing' stamp: 'MPW 1/1/1901 21:59'! 18596printOnStream: aStream 18597 aStream 18598 print: self class name; 18599 print:'from: '; 18600 write: start; 18601 print:'via: '; 18602 write: via; 18603 print:'to: '; 18604 write: end; 18605 print:' '.! ! 18606 18607 18608!Bezier2Segment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:15'! 18609hasZeroLength 18610 "Return true if the receiver has zero length" 18611 ^start = end and:[start = via]! ! 18612 18613!Bezier2Segment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:15'! 18614isBezier2Segment 18615 "Return true if the receiver is a quadratic bezier segment" 18616 ^true! ! 18617 18618!Bezier2Segment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:15'! 18619isStraight 18620 "Return true if the receiver represents a straight line" 18621 ^(self tangentAtStart crossProduct: self tangentAtEnd) = 0! ! 18622 18623 18624!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:08'! 18625controlPoints 18626 ^{start. via. end}! ! 18627 18628!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:39'! 18629controlPointsDo: aBlock 18630 aBlock value: start; value: via; value: end! ! 18631 18632!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:08'! 18633curveFrom: param1 to: param2 18634 "Return a new curve from param1 to param2" 18635 | newStart newEnd newVia tan1 tan2 d1 d2 | 18636 tan1 := via - start. 18637 tan2 := end - via. 18638 param1 <= 0.0 ifTrue:[ 18639 newStart := start. 18640 ] ifFalse:[ 18641 d1 := tan1 * param1 + start. 18642 d2 := tan2 * param1 + via. 18643 newStart := (d2 - d1) * param1 + d1 18644 ]. 18645 param2 >= 1.0 ifTrue:[ 18646 newEnd := end. 18647 ] ifFalse:[ 18648 d1 := tan1 * param2 + start. 18649 d2 := tan2 * param2 + via. 18650 newEnd := (d2 - d1) * param2 + d1. 18651 ]. 18652 tan2 := (tan2 - tan1 * param1 + tan1) * (param2 - param1). 18653 newVia := newStart + tan2. 18654 ^self clone from: newStart to: newEnd via: newVia.! ! 18655 18656!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:15'! 18657length 18658 "Return the length of the receiver" 18659 "Note: Overestimates the length" 18660 ^(start dist: via) + (via dist: end)! ! 18661 18662!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/6/1998 23:39'! 18663lineSegmentsDo: aBlock 18664 "Evaluate aBlock with the receiver's line segments" 18665 "Note: We could use forward differencing here." 18666 | steps last deltaStep t next | 18667 steps := 1 max: (self length // 10). "Assume 10 pixels per step" 18668 last := start. 18669 deltaStep := 1.0 / steps asFloat. 18670 t := deltaStep. 18671 1 to: steps do:[:i| 18672 next := self valueAt: t. 18673 aBlock value: last value: next. 18674 last := next. 18675 t := t + deltaStep].! ! 18676 18677!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 17:21'! 18678lineSegments: steps do: aBlock 18679 "Evaluate aBlock with the receiver's line segments" 18680 "Note: We could use forward differencing here." 18681 | last deltaStep t next | 18682 last := start. 18683 deltaStep := 1.0 / steps asFloat. 18684 t := deltaStep. 18685 1 to: steps do:[:i| 18686 next := self valueAt: t. 18687 aBlock value: last value: next. 18688 last := next. 18689 t := t + deltaStep].! ! 18690 18691!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:04'! 18692outlineSegment: width 18693 | delta newStart newEnd param newMid | 18694 delta := self tangentAtStart normalized * width. 18695 delta := delta y @ delta x negated. 18696 newStart := start + delta. 18697 delta := self tangentAtEnd normalized * width. 18698 delta := delta y @ delta x negated. 18699 newEnd := end + delta. 18700 param := 0.5. "self tangentAtStart r / (self tangentAtStart r + self tangentAtEnd r)." 18701 delta := (self tangentAt: param) normalized * width. 18702 delta := delta y @ delta x negated. 18703 newMid := (self valueAt: param) + delta. 18704 ^self class from: newStart to: newEnd withMidPoint: newMid at: param! ! 18705 18706!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/9/2003 03:43'! 18707parameterAtExtremeX 18708 "Note: Only valid for non-monoton receivers" 18709 ^self parameterAtExtreme: 0.0@1.0. 18710! ! 18711 18712!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/9/2003 03:43'! 18713parameterAtExtremeY 18714 "Note: Only valid for non-monoton receivers" 18715 ^self parameterAtExtreme: 1.0@0.0. 18716! ! 18717 18718!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/9/2003 03:43'! 18719parameterAtExtreme: tangentDirection 18720 "Compute the parameter value at which the tangent reaches tangentDirection. 18721 We need to find the parameter value t at which the following holds 18722 18723 ((t * dir + in) crossProduct: tangentDirection) = 0. 18724 18725 Since this is pretty ugly we use the normal direction rather than the tangent and compute the equivalent relation using the dot product as 18726 18727 ((t * dir + in) dotProduct: nrm) = 0. 18728 18729 Reformulation yields 18730 18731 ((t * dir x + in x) * nrm x) + ((t * dir y + in y) * nrm y) = 0. 18732 (t * dir x * nrm x) + (in x * nrm x) + (t * dir y * nrm y) + (in y * nrm y) = 0. 18733 (t * dir x * nrm x) + (t * dir y * nrm y) = 0 - ((in x * nrm x) + (in y * nrm y)). 18734 18735 (in x * nrm x) + (in y * nrm y) 18736 t = 0 - --------------------------------------- 18737 (dir x * nrm x) + (dir y * nrm y) 18738 And that's that. Note that we can get rid of the negation by computing 'dir' the other way around (e.g., in the above it would read '-dir') which is trivial to do. Note also that the above does not generalize easily beyond 2D since its not clear how to express the 'normal direction' of a tangent plane. 18739 " 18740 | inX inY dirX dirY nrmX nrmY | 18741 "Compute in" 18742 inX := via x - start x. 18743 inY := via y - start y. 18744 "Compute -dir" 18745 dirX := inX - (end x - via x). 18746 dirY := inY - (end y - via y). 18747 "Compute nrm" 18748 nrmX := tangentDirection y. 18749 nrmY := 0 - tangentDirection x. 18750 "Compute result" 18751 ^((inX * nrmX) + (inY * nrmY)) / 18752 ((dirX * nrmX) + (dirY * nrmY))! ! 18753 18754!Bezier2Segment methodsFor: 'vector functions' stamp: 'nk 12/27/2003 13:00'! 18755roundTo: quantum 18756 super roundTo: quantum. 18757 via := via roundTo: quantum. 18758! ! 18759 18760!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:54'! 18761tangentAtMid 18762 "Return the tangent at the given parametric value along the receiver" 18763 | in out | 18764 in := self tangentAtStart. 18765 out := self tangentAtEnd. 18766 ^in + out * 0.5! ! 18767 18768!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:16'! 18769tangentAt: parameter 18770 "Return the tangent at the given parametric value along the receiver" 18771 | in out | 18772 in := self tangentAtStart. 18773 out := self tangentAtEnd. 18774 ^in + (out - in * parameter)! ! 18775 18776!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:16'! 18777tangentAtEnd 18778 "Return the tangent for the last point" 18779 ^end - via! ! 18780 18781!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:16'! 18782tangentAtStart 18783 "Return the tangent for the first point" 18784 ^via - start! ! 18785 18786!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:17'! 18787valueAt: parameter 18788 "Evaluate the receiver at the given parametric value" 18789 "Return the point at the parametric value t: 18790 p(t) = (1-t)^2 * p1 + 18791 2*t*(1-t) * p2 + 18792 t^2 * p3. 18793 " 18794 | t1 t2 t3 | 18795 t1 := (1.0 - parameter) squared. 18796 t2 := 2 * parameter * (1.0 - parameter). 18797 t3 := parameter squared. 18798 ^(start * t1) + (via * t2) + (end * t3)! ! 18799 18800"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 18801 18802Bezier2Segment class 18803 instanceVariableNames: ''! 18804 18805!Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:14'! 18806from: startPoint to: endPoint via: viaPoint 18807 ^self new from: startPoint to: endPoint via: viaPoint! ! 18808 18809!Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:30'! 18810from: startPoint to: endPoint withMidPoint: pointOnCurve 18811 ^self new from: startPoint to: endPoint withMidPoint: pointOnCurve! ! 18812 18813!Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:32'! 18814from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter 18815 ^self new from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter! ! 18816 18817!Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:30'! 18818from: startPoint via: viaPoint to: endPoint 18819 ^self new from: startPoint to: endPoint via: viaPoint! ! 18820 18821!Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:32'! 18822from: startPoint withMidPoint: pointOnCurve at: parameter to: endPoint 18823 ^self new from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter! ! 18824 18825!Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:30'! 18826from: startPoint withMidPoint: pointOnCurve to: endPoint 18827 ^self new from: startPoint to: endPoint withMidPoint: pointOnCurve! ! 18828 18829 18830!Bezier2Segment class methodsFor: 'utilities' stamp: 'ar 6/7/2003 18:33'! 18831makeEllipseSegments: aRectangle 18832 "Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle. 18833 This method creates eight bezier segments (two for each quadrant) approximating the oval." 18834 "EXAMPLE: 18835 This example draws an oval with a red border and overlays the approximating bezier segments on top of the oval (drawn in black), thus giving an impression of how closely the bezier resembles the oval. Change the rectangle to see how accurate the approximation is for various radii of the oval. 18836 | rect | 18837 rect := 100@100 extent: 1200@500. 18838 Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red. 18839 (Bezier2Segment makeEllipseSegments: rect) do:[:seg| 18840 seg lineSegmentsDo:[:last :next| 18841 Display getCanvas line: last to: next width: 1 color: Color black]]. 18842 " 18843 "EXAMPLE: 18844 | minRadius maxRadius | 18845 maxRadius := 300. 18846 minRadius := 20. 18847 maxRadius to: minRadius by: -10 do:[:rad| 18848 | rect | 18849 rect := 400@400 - rad corner: 400@400 + rad. 18850 Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red. 18851 (Bezier2Segment makeEllipseSegments: rect) do:[:seg| 18852 seg lineSegmentsDo:[:last :next| 18853 Display getCanvas line: last to: next width: 1 color: Color black]]]. 18854 " 18855 | nrm topCenter leftCenter rightCenter bottomCenter dir scale seg1a topRight seg1b seg2a bottomRight seg2b center bottomLeft topLeft seg3a seg3b seg4a seg4b | 18856 dir := aRectangle width * 0.5. 18857 nrm := aRectangle height * 0.5. 18858 18859 "Compute the eight control points on the oval" 18860 scale := 0.7071067811865475. "45 degreesToRadians cos = 45 degreesToRadians sin = 2 sqrt / 2" 18861 center := aRectangle origin + aRectangle corner * 0.5. 18862 18863 topCenter := aRectangle topCenter. 18864 rightCenter := aRectangle rightCenter. 18865 leftCenter := aRectangle leftCenter. 18866 bottomCenter := aRectangle bottomCenter. 18867 18868 topRight := (center x + (dir * scale)) @ (center y - (nrm * scale)). 18869 bottomRight := (center x + (dir * scale)) @ (center y + (nrm * scale)). 18870 bottomLeft := (center x - (dir * scale)) @ (center y + (nrm * scale)). 18871 topLeft := (center x - (dir * scale)) @ (center y - (nrm * scale)). 18872 18873 scale := 0.414213562373095. "2 sqrt - 1" 18874 18875 dir := (dir * scale) @ 0. 18876 nrm := 0 @ (nrm * scale). 18877 18878 seg1a := self from: topCenter via: topCenter + dir to: topRight. 18879 seg1b := self from: topRight via: rightCenter - nrm to: rightCenter. 18880 18881 seg2a := self from: rightCenter via: rightCenter + nrm to: bottomRight. 18882 seg2b := self from: bottomRight via: bottomCenter + dir to: bottomCenter. 18883 18884 seg3a := self from: bottomCenter via: bottomCenter - dir to: bottomLeft. 18885 seg3b := self from: bottomLeft via: leftCenter + nrm to: leftCenter. 18886 18887 seg4a := self from: leftCenter via: leftCenter - nrm to: topLeft. 18888 seg4b := self from: topLeft via: topCenter - dir to: topCenter. 18889 18890 ^{seg1a. seg1b. seg2a. seg2b. seg3a. seg3b. seg4a. seg4b}! ! 18891LineSegment subclass: #Bezier3Segment 18892 instanceVariableNames: 'via1 via2' 18893 classVariableNames: '' 18894 poolDictionaries: '' 18895 category: 'Balloon-Geometry'! 18896!Bezier3Segment commentStamp: '<historical>' prior: 0! 18897This class represents a cubic bezier segment between two points 18898 18899Instance variables: 18900 via1, via2 <Point> The additional control points (OFF the curve)! 18901 18902 18903!Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/15/1999 15:20'! 18904bounds 18905 ^ ((super bounds encompassing: via1) encompassing: via2)! ! 18906 18907!Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'! 18908degree 18909 ^3! ! 18910 18911!Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/6/2003 21:59'! 18912length 18913 "Answer a gross approximation of the length of the receiver" 18914 ^(start dist: via1) + (via1 dist: via2) + (via2 dist: end)! ! 18915 18916!Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/15/1999 15:01'! 18917valueAt: t 18918 | a b c d | 18919 18920 "| p1 p2 p3 | 18921 p1 := start interpolateTo: via1 at: t. 18922 p2 := via1 interpolateTo: via2 at: t. 18923 p3 := via2 interpolateTo: end at: t. 18924 p1 := p1 interpolateTo: p2 at: t. 18925 p2 := p2 interpolateTo: p3 at: t. 18926 ^ p1 interpolateTo: p2 at: t" 18927 18928 a := (start negated) + (3 * via1) - (3 * via2) + (end). 18929 b := (3 * start) - (6 * via1) + (3 * via2). 18930 c := (3 * start negated) + (3 * via1). 18931 d := start. 18932 ^ ((a * t + b) * t + c) * t + d 18933 18934! ! 18935 18936!Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/6/2003 22:37'! 18937via1 18938 ^via1! ! 18939 18940!Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/14/1999 15:31'! 18941via1: aPoint 18942 via1 := aPoint! ! 18943 18944!Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/6/2003 22:37'! 18945via2 18946 ^via2! ! 18947 18948!Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/14/1999 15:31'! 18949via2: aPoint 18950 via2 := aPoint! ! 18951 18952 18953!Bezier3Segment methodsFor: 'bezier clipping' stamp: 'ar 6/7/2003 23:45'! 18954bezierClipHeight: dir 18955 "Check if the argument overlaps the receiver somewhere 18956 along the line from start to end. Optimized for speed." 18957 | u dirX dirY dx dy uMin uMax | 18958 dirX := dir x. 18959 dirY := dir y. 18960 uMin := 0.0. 18961 uMax := (dirX * dirX) + (dirY * dirY). 18962 18963 dx := via1 x - start x. 18964 dy := via1 y - start y. 18965 u := (dirX * dx) + (dirY * dy). 18966 u < uMin ifTrue:[uMin := u]. 18967 u > uMax ifTrue:[uMax := u]. 18968 18969 dx := via2 x - start x. 18970 dy := via2 y - start y. 18971 u := (dirX * dx) + (dirY * dy). 18972 u < uMin ifTrue:[uMin := u]. 18973 u > uMax ifTrue:[uMax := u]. 18974 18975 ^uMin@uMax! ! 18976 18977 18978!Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:07'! 18979asBezier2Points: error 18980 "Demote a cubic bezier to a set of approximating quadratic beziers. 18981 Should convert to forward differencing someday" 18982 18983 | curves pts step prev index a b f | 18984 curves := self bezier2SegmentCount: error. 18985 pts := Array new: curves * 3. 18986 step := 1.0 / (curves * 2). 18987 prev := start. 18988 1 to: curves do: [ :c | 18989 index := 3*c. 18990 a := pts at: index-2 put: prev. 18991 b := (self valueAt: (c*2-1)*step). 18992 f := pts at: index put: (self valueAt: (c*2)*step). 18993 pts at: index-1 put: (4 * b - a - f) / 2. 18994 prev := pts at: index. 18995 ]. 18996 ^ pts. 18997 ! ! 18998 18999!Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:07'! 19000asBezier2Segments 19001 "Demote a cubic bezier to a set of approximating quadratic beziers." 19002 ^self asBezier2Segments: 0.5! ! 19003 19004!Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/6/2003 22:23'! 19005asBezierShape 19006 "Demote a cubic bezier to a set of approximating quadratic beziers." 19007 ^self asBezierShape: 0.5! ! 19008 19009!Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:09'! 19010asBezierShape: error 19011 "Demote a cubic bezier to a set of approximating quadratic beziers. 19012 Should convert to forward differencing someday" 19013 ^(self asBezier2Points: error) asPointArray.! ! 19014 19015!Bezier3Segment methodsFor: 'converting' stamp: 'DSM 10/15/1999 15:45'! 19016asPointArray 19017 | p | 19018 p := PointArray new: 4. 19019 p at: 1 put: start. 19020 p at: 2 put: via1. 19021 p at: 3 put: via2. 19022 p at: 4 put: end. 19023 ^ p! ! 19024 19025!Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 20:58'! 19026asTangentSegment 19027 ^Bezier2Segment 19028 from: via1-start 19029 via: via2-via1 19030 to: end-via2! ! 19031 19032!Bezier3Segment methodsFor: 'converting' stamp: 'DSM 3/10/2000 12:10'! 19033bezier2SegmentCount: pixelError 19034 "Compute the number of quadratic bezier segments needed to approximate 19035 this cubic with no more than a specified error" 19036 | a | 19037 a := (start x negated @ start y negated) + (3 * via1) - (3 * via2) + 19038(end). 19039 ^ (((a r / (20.0 * pixelError)) raisedTo: 0.333333) ceiling) max: 1. 19040 19041! ! 19042 19043 19044!Bezier3Segment methodsFor: 'initialization' stamp: 'DSM 10/14/1999 15:33'! 19045from: aPoint1 via: aPoint2 and: aPoint3 to: aPoint4 19046 start := aPoint1. 19047 via1 := aPoint2. 19048 via2 := aPoint3. 19049 end := aPoint4! ! 19050 19051!Bezier3Segment methodsFor: 'initialization' stamp: 'ar 6/7/2003 00:09'! 19052initializeFrom: controlPoints 19053 controlPoints size = 4 ifFalse:[self error:'Wrong number of control points']. 19054 start := controlPoints at: 1. 19055 via1 := controlPoints at: 2. 19056 via2 := controlPoints at: 3. 19057 end := controlPoints at: 4.! ! 19058 19059 19060!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:08'! 19061controlPoints 19062 ^{start. via1. via2. end}! ! 19063 19064!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:39'! 19065controlPointsDo: aBlock 19066 aBlock value: start; value: via1; value: via2; value: end! ! 19067 19068!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/6/2003 21:52'! 19069lineSegmentsDo: aBlock 19070 "Evaluate aBlock with the receiver's line segments" 19071 "Note: We could use forward differencing here." 19072 | steps last deltaStep t next | 19073 steps := 1 max: (self length // 10). "Assume 10 pixels per step" 19074 last := start. 19075 deltaStep := 1.0 / steps asFloat. 19076 t := deltaStep. 19077 1 to: steps do:[:i| 19078 next := self valueAt: t. 19079 aBlock value: last value: next. 19080 last := next. 19081 t := t + deltaStep].! ! 19082 19083!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 17:21'! 19084lineSegments: steps do: aBlock 19085 "Evaluate aBlock with the receiver's line segments" 19086 "Note: We could use forward differencing here." 19087 | last deltaStep t next | 19088 last := start. 19089 deltaStep := 1.0 / steps asFloat. 19090 t := deltaStep. 19091 1 to: steps do:[:i| 19092 next := self valueAt: t. 19093 aBlock value: last value: next. 19094 last := next. 19095 t := t + deltaStep].! ! 19096 19097!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:04'! 19098outlineSegment: width 19099 | tan1 nrm1 tan2 nrm2 newStart newVia1 newEnd newVia2 dist | 19100 tan1 := (via1 - start) normalized. 19101 nrm1 := tan1 * width. 19102 nrm1 := nrm1 y @ nrm1 x negated. 19103 tan2 := (end - via2) normalized. 19104 nrm2 := tan2 * width. 19105 nrm2 := nrm2 y @ nrm2 x negated. 19106 newStart := start + nrm1. 19107 newEnd := end + nrm2. 19108 dist := (newStart dist: newEnd) * 0.3. 19109 newVia1 := newStart + (tan1 * dist). 19110 newVia2 := newEnd - (tan2 * dist). 19111 ^self class from: newStart via: newVia1 and: newVia2 to: newEnd. 19112! ! 19113 19114!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/6/2003 22:02'! 19115tangentAtEnd 19116 ^end - via2! ! 19117 19118!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:56'! 19119tangentAtMid 19120 | tan1 tan2 tan3 | 19121 tan1 := via1 - start. 19122 tan2 := via2 - via1. 19123 tan3 := end - via2. 19124 ^(tan1 + (2*tan2) + tan3) * 0.25 19125! ! 19126 19127!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/6/2003 22:01'! 19128tangentAtStart 19129 ^via1 - start! ! 19130 19131!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 19:25'! 19132tangentAt: parameter 19133 | tan1 tan2 tan3 t1 t2 t3 | 19134 tan1 := via1 - start. 19135 tan2 := via2 - via1. 19136 tan3 := end - via2. 19137 t1 := (1.0 - parameter) squared. 19138 t2 := 2 * parameter * (1.0 - parameter). 19139 t3 := parameter squared. 19140 ^(tan1 * t1) + (tan2 * t2) + (tan3 * t3)! ! 19141 19142 19143!Bezier3Segment methodsFor: 'private' stamp: 'DSM 10/14/1999 16:25'! 19144bezier2SegmentCount 19145 "Compute the number of quadratic bezier segments needed to approximate 19146 this cubic with less than a 1-pixel error" 19147 ^ self bezier2SegmentCount: 1.0! ! 19148 19149"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 19150 19151Bezier3Segment class 19152 instanceVariableNames: ''! 19153 19154!Bezier3Segment class methodsFor: 'examples' stamp: 'DSM 10/15/1999 15:49'! 19155example1 19156 | c | 19157 c := Bezier3Segment new from: 0@0 via: 0@100 and: 100@0 to: 100@100. 19158 ^ c asBezierShape! ! 19159 19160!Bezier3Segment class methodsFor: 'examples' stamp: 'DSM 10/15/1999 16:00'! 19161example2 19162 "draws a cubic bezier on the screen" 19163 | c canvas | 19164 c := Bezier3Segment new 19165 from: 0 @ 0 19166 via: 0 @ 100 19167 and: 100 @ 0 19168 to: 100 @ 100. 19169 canvas := BalloonCanvas on: Display. 19170 canvas aaLevel: 4. 19171 canvas 19172 drawBezier3Shape: c asPointArray 19173 color: Color transparent 19174 borderWidth: 1 19175 borderColor: Color black! ! 19176 19177 19178!Bezier3Segment class methodsFor: 'instance creation' stamp: 'DSM 1917910/15/1999 15:23'! 19180from: p1 to: p2 19181 ^ self new from: p1 via: (p1 interpolateTo: p2 at: 0.3333) and: (p1 19182interpolateTo: p2 at: 0.66667) to: p2! ! 19183 19184!Bezier3Segment class methodsFor: 'instance creation' stamp: 'DSM 1918510/15/1999 15:24'! 19186from: p1 via: p2 and: p3 to: p4 19187 ^ self new from: p1 via: p2 and: p3 to: p4! ! 19188 19189 19190!Bezier3Segment class methodsFor: 'utilities' stamp: 'DSM 10/15/1999 16:06'! 19191convertBezier3ToBezier2: vertices 19192 | pa pts index c | 19193 pts := OrderedCollection new. 19194 1 to: vertices size // 4 do: 19195 [:i | 19196 index := i * 4 - 3. 19197 c := Bezier3Segment new 19198 from: (vertices at: index) 19199 via: (vertices at: index + 1) 19200 and: (vertices at: index + 2) 19201 to: (vertices at: index + 3). 19202 pts addAll: c asBezierShape]. 19203 pa := PointArray new: pts size. 19204 pts withIndexDo: [:p :i | pa at: i put: p ]. 19205 ^ pa! ! 19206 19207!Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:25'! 19208makeEllipseSegments: aRectangle 19209 "Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle. 19210 This method creates four bezier segments (one for each quadrant) approximating the oval." 19211 "EXAMPLE: 19212 This example draws an oval with a red border and overlays the approximating bezier segments on top of the oval (drawn in black), thus giving an impression of how closely the bezier resembles the oval. Change the rectangle to see how accurate the approximation is for various radii of the oval. 19213 | rect | 19214 rect := 100@100 extent: 500@200. 19215 Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red. 19216 (Bezier3Segment makeEllipseSegments: rect) do:[:seg| 19217 seg lineSegmentsDo:[:last :next| 19218 Display getCanvas line: last to: next width: 1 color: Color black]]. 19219 " 19220 "EXAMPLE: 19221 | minRadius maxRadius | 19222 maxRadius := 300. 19223 minRadius := 20. 19224 maxRadius to: minRadius by: -10 do:[:rad| 19225 | rect | 19226 rect := 400@400 - rad corner: 400@400 + rad. 19227 Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red. 19228 (Bezier3Segment makeEllipseSegments: rect) do:[:seg| 19229 seg lineSegmentsDo:[:last :next| 19230 Display getCanvas line: last to: next width: 1 color: Color black]]]. 19231 " 19232 ^self makeEllipseSegments: aRectangle count: 4! ! 19233 19234!Bezier3Segment class methodsFor: 'utilities' stamp: 'eem 6/11/2008 16:08'! 19235makeEllipseSegments: aRectangle count: segmentCount 19236 "Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle. 19237 This method creates segmentCount bezier segments (one for each quadrant) approximating the oval." 19238 | count angle center scale | 19239 center := aRectangle origin + aRectangle corner * 0.5. 19240 scale := aRectangle extent * 0.5. 19241 count := segmentCount max: 2. "need at least two segments" 19242 angle := 360.0 / count. 19243 ^(1 to: count) collect:[:i| | seg | 19244 seg := self makeUnitPieSegmentFrom: i-1*angle to: i*angle. 19245 self controlPoints: (seg controlPoints collect:[:pt| pt * scale + center]) 19246 ].! ! 19247 19248!Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:53'! 19249makePieSegments: aRectangle from: angle1 to: angle2 19250 "Create a series of cubic bezier segments for the oval inscribed in aRectangle between angle1 and angle2. The segments are oriented clockwise, to get counter-clockwise segments simply switch angle1 and angle2." 19251 angle2 < angle1 ifTrue:[ 19252 "ccw segments" 19253 ^(self makePieSegments: aRectangle from: angle2 to: angle1) 19254 reversed collect:[:seg| seg reversed] 19255 ]. 19256 "Split up segments if larger than 120 degrees" 19257 angle2 - angle1 > 120 ifTrue:["subdivide" 19258 | midAngle | 19259 midAngle := angle1 + angle2 * 0.5. 19260 ^(self makePieSegments: aRectangle from: angle1 to: midAngle), 19261 (self makePieSegments: aRectangle from: midAngle to: angle2). 19262 ]. 19263 "Create actual pie segment" 19264 ^self makePieSegment: aRectangle from: angle1 to: angle2 19265! ! 19266 19267!Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:26'! 19268makePieSegment: aRectangle from: angle1 to: angle2 19269 "Create a single pie segment for the oval inscribed in aRectangle between angle1 and angle2. If angle1 is less than angle2 this method creates a CW pie segment, otherwise it creates a CCW pie segment." 19270 | seg center scale | 19271 angle1 > angle2 ifTrue:["ccw" 19272 ^(self makePieSegment: aRectangle from: angle2 to: angle1) reversed 19273 ]. 19274 "create a unit circle pie segment from angle1 to angle2" 19275 seg := self makeUnitPieSegmentFrom: angle1 to: angle2. 19276 "scale the segment to fit aRectangle" 19277 center := aRectangle origin + aRectangle corner * 0.5. 19278 scale := aRectangle extent * 0.5. 19279 ^self controlPoints: (seg controlPoints collect:[:pt| pt * scale + center])! ! 19280 19281!Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:59'! 19282makeUnitPieSegmentFrom: angle1 to: angle2 19283 "Create a clockwise unit pie segment from angle1 to angle2, that is a pie segment for a circle centered at zero with radius one. Note: This method can be used to create at most a quarter circle." 19284 | pt1 pt2 rad1 rad2 | 19285 rad1 := angle1 degreesToRadians. 19286 rad2 := angle2 degreesToRadians. 19287 pt1 := rad1 sin @ rad1 cos negated. 19288 pt2 := rad2 sin @ rad2 cos negated. 19289 ^self makeUnitPieSegmentWith: pt1 and: pt2! ! 19290 19291!Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 04:45'! 19292makeUnitPieSegmentWith: point1 and: point2 19293 "Create a clockwise unit pie segment from point1 to point2, that is a pie segment for a circle centered at zero with radius one." 19294 | pt1 pt2 dir1 dir2 mid length scale cp1 cp2 pt3 magic | 19295 "point1 and point2 are the points on the unit circle 19296 for accuracy (or broken input), renormalize them." 19297 pt1 := point1 normalized. 19298 pt2 := point2 normalized. 19299 "compute the normal vectors - those are tangent directions for the bezier" 19300 dir1 := pt1 y negated @ pt1 x. 19301 dir2 := pt2 y negated @ pt2 x. 19302 "Okay, now that we have the points and tangents on the unit circle, let's do the magic. For fitting a cubic bezier onto a circle section we know that we want the end points be on the circle and the tangents to point towards the right direction (both of which we have in the above). What we do NOT know is how to scale the tangents so that midpoint of the bezier is exactly on the circle. 19303 The good news is that there is a linear relation between the length of the tangent vectors and the distance of the midpoint from the circle's origin. The bad news is that I don't know how to derive it analytically. So what I do here is simply sampling the bezier twice (not really - the first sample is free) and then to compute the distance from the sample." 19304 19305 "The first sample is just between the two points on the curve" 19306 mid := pt1 + pt2 * 0.5. 19307 19308 "The second sample will be taken from the curve with coincident control points at the intersection of dir1 and dir2, which simplifies significantly with a little understanding about trigonometry, since the angle formed between mid, pt1 and the intersection is the same as between the center, pt1 and mid." 19309 length := mid r. 19310 "length is not only the distance from the center of the unit circle but also the sine of the angle between the circle's center, pt1 and mid (since center is at zero and pt1 has unit length). Therefore, to scale dir1 to the intersection with dir2 we can use mid's distance from pt1 and simply divide it by the sine value." 19311 scale := (mid dist: pt1). 19312 length > 0.0 ifTrue:[ scale := scale / length]. 19313 "now sample the cubic bezier (optimized version for coincident control points)" 19314 cp1 := pt1 + (dir1 * (scale * 0.75)). 19315 cp2 := pt2 - (dir2 * (scale * 0.75)). 19316 pt3 := cp1 + cp2 * 0.5. 19317 "compute the magic constant" 19318 scale := (pt3 - mid) r / scale. 19319 magic := 1.0 - length / scale. 19320 "and finally answer the pie segment" 19321 ^self 19322 from: pt1 19323 via: pt1 + (dir1 * magic) 19324 and: pt2 - (dir2 * magic) 19325 to: pt2! ! 19326Object subclass: #BitBlt 19327 instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight colorMap' 19328 classVariableNames: 'CachedFontColorMaps ColorConvertingMaps' 19329 poolDictionaries: '' 19330 category: 'Graphics-Primitives'! 19331!BitBlt commentStamp: '<historical>' prior: 0! 19332I represent a block transfer (BLT) of pixels into a rectangle (destX, destY, width, height) of the destinationForm. The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or a constant color, currently called halftoneForm. If both are specified, their pixel values are combined with a logical AND function prior to transfer. In any case, the pixels from the source are combined with those of the destination by as specified by the combinationRule. 19333 19334The combination rule whose value is 0 through 15 programs the transfer to produce 1 or 0 according to its 4-bit representation as follows: 19335 8: if source is 0 and destination is 0 19336 4: if source is 0 and destination is 1 19337 2: if source is 1 and destination is 0 19338 1: if source is 1 and destination is 1. 19339At each pixel the corresponding bits of the source and destination pixel values determine one of these conditions; if the combination rule has a 1 in the corresponding bit position, then the new destination value will be 1, otherwise it will be zero. Forms may be of different depths, see the comment in class Form. 19340 19341In addition to the original 16 combination rules, this BitBlt supports 19342 16 fails (to simulate paint bits) 19343 17 fails (to simulate erase bits) 19344 18 sourceWord + destinationWord 19345 19 sourceWord - destinationWord 19346 20 rgbAdd: sourceWord with: destinationWord. Sum of color components 19347 21 rgbSub: sourceWord with: destinationWord. Difference of color components 19348 22 OLDrgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 19349 23 OLDtallyIntoMap: destinationWord. Tallies pixValues into a colorMap 19350 these old versions don't do bitwise dest clipping. Use 32 and 33 now. 19351 24 alphaBlend: sourceWord with: destinationWord. 32-bit source and dest only 19352 25 pixPaint: sourceWord with: destinationWord. Wherever the sourceForm is non-zero, it replaces the destination. Can be used with a 1-bit source color mapped to (0, FFFFFFFF), and a fillColor to fill the dest with that color wherever the source is 1. 19353 26 pixMask: sourceWord with: destinationWord. Like pixPaint, but fills with 0. 19354 27 rgbMax: sourceWord with: destinationWord. Max of each color component. 19355 28 rgbMin: sourceWord with: destinationWord. Min of each color component. 19356 29 rgbMin: sourceWord bitInvert32 with: destinationWord. Min with (max-source) 19357 30 alphaBlendConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. 19358 31 alphaPaintConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. 19359 32 rgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 19360 33 tallyIntoMap: destinationWord. Tallies pixValues into a colorMap 19361 34 alphaBlendScaled: srcWord with: dstWord. Alpha blend of scaled srcWord and destWord. 19362 19363The color specified by halftoneForm may be either a Color or a Pattern. A Color is converted to a pixelValue for the depth of the destinationForm. If a Pattern, BitBlt will simply interpret its bitmap as an array of Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. Within each scan line the 32-bit value is repeated from left to right across the form. If the value repeats on pixels boudaries, the effect will be a constant color; if not, it will produce a halftone that repeats on 32-bit boundaries. 19364 19365Any transfer specified is further clipped by the specified rectangle (clipX, clipY, clipWidth, clipHeight), and also by the bounds of the source and destination forms. 19366 To make a small Form repeat and fill a big form, use an InfiniteForm as the source. 19367 To write on a form and leave with both transparent and opapue areas, use a MaskedForm as the source. 19368 19369Pixels from a source to a destination whose pixels have a different depth are converted based on the optional colorMap. If colorMap is nil, then conversion to more bits is done by filling the new high-order bits with zero, and conversion to fewer bits is done by truncating the lost high-order bits. 19370 19371The colorMap, if specified, must be a either word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source, or a fully specified ColorMap which may contain a lookup table (ie Bitmap) and/or four separate masks and shifts which are applied to the pixels. For every source pixel, BitBlt will first perform masking and shifting and then index the lookup table, and select the corresponding pixelValue and mask it to the destination pixel size before storing. 19372 When blitting from a 32 or 16 bit deep Form to one 8 bits or less, the default is truncation. This will produce very strange colors, since truncation of the high bits does not produce the nearest encoded color. Supply a 512 long colorMap, and red, green, and blue will be shifted down to 3 bits each, and mapped. The message copybits...stdColors will use the best map to the standard colors for destinations of depths 8, 4, 2 and 1. Two other sized of colorMaps are allowed, 4096 (4 bits per color) and 32786 (five bits per color). 19373 Normal blits between 16 and 32 bit forms truncates or pads the colors automatically to provide the best preservation of colors. 19374 Colors can be remapped at the same depth. Sometimes a Form is in terms of colors that are not the standard colors for this depth, for example in a GIF file. Convert the Form to a MaskedForm and send colorMap: the list of colors that the picture is in terms of. MaskedForm will use the colorMap when copying to the display or another Form. (Note also that a Form can be copied to itself, and transformed in the process, if a non-nil colorMap is supplied.)! 19375 19376 19377!BitBlt methodsFor: '*FreeType-addition' stamp: 'tween 8/1/2006 17:52'! 19378combinationRule 19379 "Answer the receiver's combinationRule" 19380 19381 ^combinationRule! ! 19382 19383!BitBlt methodsFor: '*FreeType-addition' stamp: 'tween 7/28/2006 17:54'! 19384copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray 19385 "This entry point to BitBlt supplies an extra argument to specify the fore color 19386 argb value for operation 41. This is split into an alpha value and an rgb value, 19387 so that both can be passed as smallIntegers to the primitive. 19388 rgbColorInteger must be a smallInteger between 0 and 16rFFFFFF. 19389 alpha must be a smallInteger between 0 and 16rFF." 19390 19391 <primitive: 'primitiveCopyBits' module: 'BitBltPlugin'> 19392 19393 "Check for compressed source, destination or halftone forms" 19394 ((sourceForm isForm) and: [sourceForm unhibernate]) 19395 ifTrue: [^ self copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray]. 19396 ((destForm isForm) and: [destForm unhibernate ]) 19397 ifTrue: [^ self copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray]. 19398 ((halftoneForm isForm) and: [halftoneForm unhibernate]) 19399 ifTrue: [^ self copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray]. 19400 19401 self primitiveFailed "Later do nicer error recovery -- share copyBits recovery"! ! 19402 19403!BitBlt methodsFor: '*FreeType-addition' stamp: 'tween 4/4/2007 20:59'! 19404installFreeTypeFont: aFreeTypeFont foregroundColor: foregroundColor backgroundColor: backgroundColor 19405 "Set up the parameters. Since the glyphs in a TTCFont is 32bit depth form, it tries to use rule=34 to get better AA result if possible." 19406 19407 (FreeTypeSettings current bitBltSubPixelAvailable and: [destForm depth >= 8]) 19408 ifTrue:[ 19409 self combinationRule: 41. 19410 destForm depth = 8 19411 ifTrue:[self colorMap: (self cachedFontColormapFrom: 32 to: destForm depth)] 19412 ifFalse:[self colorMap: nil]] 19413 ifFalse:[ 19414 "use combination rule 34 when rule 41 is not available in the BitBlt plugin, 19415 or the destination form depth <= 8" 19416 destForm depth <= 8 19417 ifTrue: [ 19418 self colorMap: (self cachedFontColormapFrom: 32 to: destForm depth). 19419 self combinationRule: Form paint.] 19420 ifFalse: [ 19421 self colorMap: nil. 19422 self combinationRule: 34]]. 19423 halftoneForm := nil. 19424 sourceX := sourceY := 0. 19425 height := aFreeTypeFont height. 19426! ! 19427 19428 19429!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19430clipBy: aRectangle 19431 | aPoint right bottom | 19432 right := clipX + clipWidth. 19433 bottom := clipY + clipHeight. 19434 aPoint := aRectangle origin. 19435 aPoint x > clipX ifTrue: [ clipX := aPoint x ]. 19436 aPoint y > clipY ifTrue: [ clipY := aPoint y ]. 19437 aPoint := aRectangle corner. 19438 aPoint x < right ifTrue: [ right := aPoint x ]. 19439 aPoint y < bottom ifTrue: [ bottom := aPoint y ]. 19440 clipWidth := right - clipX. 19441 clipHeight := bottom - clipY. 19442 clipWidth < 0 ifTrue: [ clipWidth := 0 ]. 19443 clipHeight < 0 ifTrue: [ clipHeight := 0 ]! ! 19444 19445!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19446clipByX1: x1 y1: y1 x2: x2 y2: y2 19447 | right bottom | 19448 right := clipX + clipWidth. 19449 bottom := clipY + clipHeight. 19450 x1 > clipX ifTrue: [ clipX := x1 ]. 19451 y1 > clipY ifTrue: [ clipY := y1 ]. 19452 x2 < right ifTrue: [ right := x2 ]. 19453 y2 < bottom ifTrue: [ bottom := y2 ]. 19454 clipWidth := right - clipX. 19455 clipHeight := bottom - clipY. 19456 clipWidth < 0 ifTrue: [ clipWidth := 0 ]. 19457 clipHeight < 0 ifTrue: [ clipHeight := 0 ]! ! 19458 19459!BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! 19460clipHeight 19461 ^clipHeight! ! 19462 19463!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19464clipHeight: anInteger 19465 "Set the receiver's clipping area height to be the argument, anInteger." 19466 clipHeight := anInteger! ! 19467 19468!BitBlt methodsFor: 'accessing'! 19469clipRect 19470 "Answer the receiver's clipping area rectangle." 19471 19472 ^clipX @ clipY extent: clipWidth @ clipHeight! ! 19473 19474!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19475clipRect: aRectangle 19476 "Set the receiver's clipping area rectangle to be the argument, aRectangle." 19477 clipX := aRectangle left truncated. 19478 clipY := aRectangle top truncated. 19479 clipWidth := aRectangle right truncated - clipX. 19480 clipHeight := aRectangle bottom truncated - clipY! ! 19481 19482!BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! 19483clipWidth 19484 ^clipWidth! ! 19485 19486!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19487clipWidth: anInteger 19488 "Set the receiver's clipping area width to be the argument, anInteger." 19489 clipWidth := anInteger! ! 19490 19491!BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! 19492clipX 19493 ^clipX! ! 19494 19495!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19496clipX: anInteger 19497 "Set the receiver's clipping area top left x coordinate to be the argument, 19498 anInteger." 19499 clipX := anInteger! ! 19500 19501!BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! 19502clipY 19503 ^clipY! ! 19504 19505!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19506clipY: anInteger 19507 "Set the receiver's clipping area top left y coordinate to be the argument, 19508 anInteger." 19509 clipY := anInteger! ! 19510 19511!BitBlt methodsFor: 'accessing' stamp: 'tk 8/15/2001 10:56'! 19512color 19513 "Return the current fill color as a Color. 19514 Gives the wrong answer if the halftoneForm is a complex pattern of more than one word." 19515 19516 halftoneForm ifNil: [^ Color black]. 19517 ^ Color colorFromPixelValue: halftoneForm first depth: destForm depth! ! 19518 19519!BitBlt methodsFor: 'accessing'! 19520colorMap 19521 ^ colorMap! ! 19522 19523!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19524colorMap: map 19525 "See last part of BitBlt comment. 6/18/96 tk" 19526 colorMap := map! ! 19527 19528!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19529combinationRule: anInteger 19530 "Set the receiver's combination rule to be the argument, anInteger, a 19531 number in the range 0-15." 19532 combinationRule := anInteger! ! 19533 19534!BitBlt methodsFor: 'accessing'! 19535destForm 19536 ^ destForm! ! 19537 19538!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19539destOrigin: aPoint 19540 "Set the receiver's destination top left coordinates to be those of the 19541 argument, aPoint." 19542 destX := aPoint x. 19543 destY := aPoint y! ! 19544 19545!BitBlt methodsFor: 'accessing' stamp: 'tk 3/19/97'! 19546destRect 19547 "The rectangle we are about to blit to or just blitted to. " 19548 19549 ^ destX @ destY extent: width @ height! ! 19550 19551!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19552destRect: aRectangle 19553 "Set the receiver's destination form top left coordinates to be the origin of 19554 the argument, aRectangle, and set the width and height of the receiver's 19555 destination form to be the width and height of aRectangle." 19556 destX := aRectangle left. 19557 destY := aRectangle top. 19558 width := aRectangle width. 19559 height := aRectangle height! ! 19560 19561!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19562destX: anInteger 19563 "Set the top left x coordinate of the receiver's destination form to be the 19564 argument, anInteger." 19565 destX := anInteger! ! 19566 19567!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19568destX: x destY: y width: w height: h 19569 "Combined init message saves 3 sends from DisplayScanner" 19570 destX := x. 19571 destY := y. 19572 width := w. 19573 height := h! ! 19574 19575!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19576destY: anInteger 19577 "Set the top left y coordinate of the receiver's destination form to be the 19578 argument, anInteger." 19579 destY := anInteger! ! 19580 19581!BitBlt methodsFor: 'accessing'! 19582fillColor 19583 ^ halftoneForm! ! 19584 19585!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19586fillColor: aColorOrPattern 19587 "The destForm will be filled with this color or pattern of colors. May be an old Color, a new type Color, a Bitmap (see BitBlt comment), a Pattern, or a Form. 6/18/96 tk" 19588 aColorOrPattern == nil ifTrue: 19589 [ halftoneForm := nil. 19590 ^ self ]. 19591 destForm == nil ifTrue: [ self error: 'Must set destForm first' ]. 19592 halftoneForm := destForm bitPatternFor: aColorOrPattern! ! 19593 19594!BitBlt methodsFor: 'accessing' stamp: 'tbn 9/14/2004 20:38'! 19595halftoneForm 19596 "Returns the receivers half tone form. See class commment." 19597 19598 ^halftoneForm! ! 19599 19600!BitBlt methodsFor: 'accessing' stamp: 'tbn 9/14/2004 20:39'! 19601halftoneForm: aBitmap 19602 "Sets the receivers half tone form. See class commment." 19603 19604 halftoneForm := aBitmap 19605 19606 ! ! 19607 19608!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19609height: anInteger 19610 "Set the receiver's destination form height to be the argument, anInteger." 19611 height := anInteger! ! 19612 19613!BitBlt methodsFor: 'accessing'! 19614sourceForm 19615 19616 ^ sourceForm! ! 19617 19618!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19619sourceForm: aForm 19620 "Set the receiver's source form to be the argument, aForm." 19621 sourceForm := aForm! ! 19622 19623!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19624sourceOrigin: aPoint 19625 "Set the receiver's source form coordinates to be those of the argument, 19626 aPoint." 19627 sourceX := aPoint x. 19628 sourceY := aPoint y! ! 19629 19630!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19631sourceRect: aRectangle 19632 "Set the receiver's source form top left x and y, width and height to be 19633 the top left coordinate and extent of the argument, aRectangle." 19634 sourceX := aRectangle left. 19635 sourceY := aRectangle top. 19636 width := aRectangle width. 19637 height := aRectangle height! ! 19638 19639!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19640sourceX: anInteger 19641 "Set the receiver's source form top left x to be the argument, anInteger." 19642 sourceX := anInteger! ! 19643 19644!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19645sourceY: anInteger 19646 "Set the receiver's source form top left y to be the argument, anInteger." 19647 sourceY := anInteger! ! 19648 19649!BitBlt methodsFor: 'accessing' stamp: 'ar 5/25/2000 19:39'! 19650tallyMap 19651 "Return the map used for tallying pixels" 19652 ^colorMap! ! 19653 19654!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19655tallyMap: aBitmap 19656 "Install the map used for tallying pixels" 19657 colorMap := aBitmap! ! 19658 19659!BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 19660width: anInteger 19661 "Set the receiver's destination form width to be the argument, anInteger." 19662 width := anInteger! ! 19663 19664 19665!BitBlt methodsFor: 'copying' stamp: 'jmv 8/4/2009 16:29'! 19666basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta 19667 19668 destY := aPoint y. 19669 destX := aPoint x. 19670 19671 "the following are not really needed, but theBitBlt primitive will fail if not set" 19672 sourceX ifNil: [sourceX := 100]. 19673 width ifNil: [width := 100]. 19674 19675 self primDisplayString: aString from: startIndex to: stopIndex 19676 map: font characterToGlyphMap xTable: font xTable 19677 kern: kernDelta. 19678 ^ destX@destY. 19679! ! 19680 19681!BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! 19682copy: destRectangle from: sourcePt in: srcForm 19683 | destOrigin | 19684 sourceForm := srcForm. 19685 halftoneForm := nil. 19686 combinationRule := 3. "store" 19687 destOrigin := destRectangle origin. 19688 destX := destOrigin x. 19689 destY := destOrigin y. 19690 sourceX := sourcePt x. 19691 sourceY := sourcePt y. 19692 width := destRectangle width. 19693 height := destRectangle height. 19694 self copyBits! ! 19695 19696!BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! 19697copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule 19698 "Specify a Color to fill, not a Form. 6/18/96 tk" 19699 | destOrigin | 19700 sourceForm := srcForm. 19701 self fillColor: hf. "sets halftoneForm" 19702 combinationRule := rule. 19703 destOrigin := destRectangle origin. 19704 destX := destOrigin x. 19705 destY := destOrigin y. 19706 sourceX := sourcePt x. 19707 sourceY := sourcePt y. 19708 width := destRectangle width. 19709 height := destRectangle height. 19710 srcForm == nil ifFalse: [ colorMap := srcForm colormapIfNeededFor: destForm ]. 19711 ^ self copyBits! ! 19712 19713!BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! 19714copy: destRectangle from: sourcePt in: srcForm halftoneForm: hf rule: rule 19715 | destOrigin | 19716 sourceForm := srcForm. 19717 self fillColor: hf. "sets halftoneForm" 19718 combinationRule := rule. 19719 destOrigin := destRectangle origin. 19720 destX := destOrigin x. 19721 destY := destOrigin y. 19722 sourceX := sourcePt x. 19723 sourceY := sourcePt y. 19724 width := destRectangle width. 19725 height := destRectangle height. 19726 self copyBits! ! 19727 19728!BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! 19729copyBits 19730 "Primitive. Perform the movement of bits from the source form to the 19731 destination form. Fail if any variables are not of the right type (Integer, 19732 Float, or Form) or if the combination rule is not implemented. 19733 In addition to the original 16 combination rules, this BitBlt supports 19734 16 fail (to simulate paint) 19735 17 fail (to simulate mask) 19736 18 sourceWord + destinationWord 19737 19 sourceWord - destinationWord 19738 20 rgbAdd: sourceWord with: destinationWord 19739 21 rgbSub: sourceWord with: destinationWord 19740 22 rgbDiff: sourceWord with: destinationWord 19741 23 tallyIntoMap: destinationWord 19742 24 alphaBlend: sourceWord with: destinationWord 19743 25 pixPaint: sourceWord with: destinationWord 19744 26 pixMask: sourceWord with: destinationWord 19745 27 rgbMax: sourceWord with: destinationWord 19746 28 rgbMin: sourceWord with: destinationWord 19747 29 rgbMin: sourceWord bitInvert32 with: destinationWord 19748" 19749 "Check for compressed source, destination or halftone forms" 19750 <primitive: 'primitiveCopyBits' module: 'BitBltPlugin'> 19751 (combinationRule >= 30 and: [ combinationRule <= 31 ]) ifTrue: 19752 [ "No alpha specified -- re-run with alpha = 1.0" 19753 ^ self copyBitsTranslucent: 255 ]. 19754 (sourceForm isForm and: [ sourceForm unhibernate ]) ifTrue: [ ^ self copyBits ]. 19755 (destForm isForm and: [ destForm unhibernate ]) ifTrue: [ ^ self copyBits ]. 19756 (halftoneForm isForm and: [ halftoneForm unhibernate ]) ifTrue: [ ^ self copyBits ]. 19757 19758 "Check for unimplmented rules" 19759 combinationRule = Form oldPaint ifTrue: [ ^ self paintBits ]. 19760 combinationRule = Form oldErase1bitShape ifTrue: [ ^ self eraseBits ]. 19761 19762 "Check if BitBlt doesn't support full color maps" 19763 (colorMap notNil and: [ colorMap isColormap ]) ifTrue: 19764 [ colorMap := colorMap colors. 19765 ^ self copyBits ]. 19766 "Check if clipping gots us way out of range" 19767 self clipRange ifTrue: 19768 [ self roundVariables. 19769 ^ self copyBitsAgain ]. 19770 self error: 'Bad BitBlt arg (Fraction?); proceed to convert.'. 19771 "Convert all numeric parameters to integers and try again." 19772 self roundVariables. 19773 ^ self copyBitsAgain! ! 19774 19775!BitBlt methodsFor: 'copying' stamp: 'nk 4/17/2004 19:42'! 19776copyBitsTranslucent: factor 19777 "This entry point to BitBlt supplies an extra argument to specify translucency 19778 for operations 30 and 31. The argument must be an integer between 0 and 255." 19779 19780 <primitive: 'primitiveCopyBits' module: 'BitBltPlugin'> 19781 19782 "Check for compressed source, destination or halftone forms" 19783 ((sourceForm isForm) and: [sourceForm unhibernate]) 19784 ifTrue: [^ self copyBitsTranslucent: factor]. 19785 ((destForm isForm) and: [destForm unhibernate]) 19786 ifTrue: [^ self copyBitsTranslucent: factor]. 19787 ((halftoneForm isForm) and: [halftoneForm unhibernate]) 19788 ifTrue: [^ self copyBitsTranslucent: factor]. 19789 19790 self primitiveFailed "Later do nicer error recovery -- share copyBits recovery"! ! 19791 19792!BitBlt methodsFor: 'copying' stamp: 'ar 5/14/2001 23:32'! 19793copyForm: srcForm to: destPt rule: rule 19794 ^ self copyForm: srcForm to: destPt rule: rule 19795 colorMap: (srcForm colormapIfNeededFor: destForm)! ! 19796 19797!BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! 19798copyForm: srcForm to: destPt rule: rule color: color 19799 sourceForm := srcForm. 19800 halftoneForm := color. 19801 combinationRule := rule. 19802 destX := destPt x + sourceForm offset x. 19803 destY := destPt y + sourceForm offset y. 19804 sourceX := 0. 19805 sourceY := 0. 19806 width := sourceForm width. 19807 height := sourceForm height. 19808 self copyBits! ! 19809 19810!BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! 19811copyForm: srcForm to: destPt rule: rule colorMap: map 19812 sourceForm := srcForm. 19813 halftoneForm := nil. 19814 combinationRule := rule. 19815 destX := destPt x + sourceForm offset x. 19816 destY := destPt y + sourceForm offset y. 19817 sourceX := 0. 19818 sourceY := 0. 19819 width := sourceForm width. 19820 height := sourceForm height. 19821 colorMap := map. 19822 self copyBits! ! 19823 19824!BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! 19825copyForm: srcForm to: destPt rule: rule fillColor: color 19826 sourceForm := srcForm. 19827 self fillColor: color. "sets halftoneForm" 19828 combinationRule := rule. 19829 destX := destPt x + sourceForm offset x. 19830 destY := destPt y + sourceForm offset y. 19831 sourceX := 0. 19832 sourceY := 0. 19833 width := sourceForm width. 19834 height := sourceForm height. 19835 self copyBits! ! 19836 19837!BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! 19838copyFrom: sourceRectangle in: srcForm to: destPt 19839 | sourceOrigin | 19840 sourceForm := srcForm. 19841 halftoneForm := nil. 19842 combinationRule := 3. "store" 19843 destX := destPt x. 19844 destY := destPt y. 19845 sourceOrigin := sourceRectangle origin. 19846 sourceX := sourceOrigin x. 19847 sourceY := sourceOrigin y. 19848 width := sourceRectangle width. 19849 height := sourceRectangle height. 19850 colorMap := srcForm colormapIfNeededFor: destForm. 19851 self copyBits! ! 19852 19853!BitBlt methodsFor: 'copying' stamp: 'JuanVuletich 8/22/2009 23:39'! 19854displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta 19855 "If required, do a second pass with new rule and colorMap. 19856 This happens when #installStrikeFont:foregroundColor:backgroundColor: sets rule 37 (rgbMul). 19857 the desired effect is to do two bitblt calls. The first one is with rule 37 and special colormap. 19858 The second one is rule 34, with a colormap for applying the requested foreground color. 19859 This two together do component alpha blending, i.e. alpha blend red, green and blue separatedly. 19860 This is needed for arbitrary color over abitrary background text with subpixel AA." 19861 19862 | answer prevRule secondPassMap | 19863 "If combinationRule is rgbMul, we might need the special two-pass technique for component alpha blending. 19864 If not, do it simply" 19865 combinationRule = 37 "rgbMul" ifFalse: [ 19866 ^self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta ]. 19867 19868 "We need to do a second pass. The colormap set is for use in the second pass." 19869 secondPassMap := colorMap. 19870 colorMap := sourceForm depth ~= destForm depth 19871 ifTrue: [ self cachedFontColormapFrom: sourceForm depth to: destForm depth ]. 19872 answer := self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta. 19873 colorMap := secondPassMap. 19874 secondPassMap ifNotNil: [ 19875 prevRule := combinationRule. 19876 combinationRule := 20. "rgbAdd" 19877 self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta. 19878 combinationRule := prevRule ]. 19879 ^answer! ! 19880 19881!BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! 19882fill: destRect fillColor: grayForm rule: rule 19883 "Fill with a Color, not a Form. 6/18/96 tk" 19884 sourceForm := nil. 19885 self fillColor: grayForm. "sets halftoneForm" 19886 combinationRule := rule. 19887 destX := destRect left. 19888 destY := destRect top. 19889 sourceX := 0. 19890 sourceY := 0. 19891 width := destRect width. 19892 height := destRect height. 19893 self copyBits! ! 19894 19895!BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! 19896pixelAt: aPoint 19897 "Assumes this BitBlt has been set up specially (see the init message, 19898 BitBlt bitPeekerFromForm:. Returns the pixel at aPoint." 19899 sourceX := aPoint x. 19900 sourceY := aPoint y. 19901 destForm unhibernate. "before poking" 19902 destForm bits 19903 at: 1 19904 put: 0. "Just to be sure" 19905 self copyBits. 19906 ^ destForm bits at: 1! ! 19907 19908!BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! 19909pixelAt: aPoint put: pixelValue 19910 "Assumes this BitBlt has been set up specially (see the init message, 19911 BitBlt bitPokerToForm:. Overwrites the pixel at aPoint." 19912 destX := aPoint x. 19913 destY := aPoint y. 19914 sourceForm unhibernate. "before poking" 19915 sourceForm bits 19916 at: 1 19917 put: pixelValue. 19918 self copyBits 19919 " 19920| bb | 19921bb _ (BitBlt bitPokerToForm: Display). 19922[Sensor anyButtonPressed] whileFalse: 19923 [bb pixelAt: Sensor cursorPoint put: 55] 19924"! ! 19925 19926 19927!BitBlt methodsFor: 'line drawing'! 19928drawFrom: startPoint to: stopPoint 19929 19930 ^ self drawFrom: startPoint to: stopPoint withFirstPoint: true! ! 19931 19932!BitBlt methodsFor: 'line drawing' stamp: 'lr 7/4/2009 10:42'! 19933drawFrom: startPoint to: stopPoint withFirstPoint: drawFirstPoint 19934 "Draw a line whose end points are startPoint and stopPoint. 19935 The line is formed by repeatedly calling copyBits at every 19936 point along the line. If drawFirstPoint is false, then omit 19937 the first point so as not to overstrike at line junctions." 19938 "Always draw down, or at least left-to-right" 19939 | offset point1 point2 forwards | 19940 forwards := (startPoint y = stopPoint y and: [ startPoint x < stopPoint x ]) or: [ startPoint y < stopPoint y ]. 19941 forwards 19942 ifTrue: 19943 [ point1 := startPoint. 19944 point2 := stopPoint ] 19945 ifFalse: 19946 [ point1 := stopPoint. 19947 point2 := startPoint ]. 19948 sourceForm == nil 19949 ifTrue: 19950 [ destX := point1 x. 19951 destY := point1 y ] 19952 ifFalse: 19953 [ width := sourceForm width. 19954 height := sourceForm height. 19955 offset := sourceForm offset. 19956 destX := (point1 x + offset x) rounded. 19957 destY := (point1 y + offset y) rounded ]. 19958 19959 "Note that if not forwards, then the first point is the last and vice versa. 19960 We agree to always paint stopPoint, and to optionally paint startPoint." 19961 (drawFirstPoint or: [ forwards == false "ie this is stopPoint" ]) ifTrue: [ self copyBits ]. 19962 self 19963 drawLoopX: (point2 x - point1 x) rounded 19964 Y: (point2 y - point1 y) rounded. 19965 (drawFirstPoint or: 19966 [ "ie this is stopPoint" 19967 forwards ]) ifTrue: [ self copyBits ]! ! 19968 19969!BitBlt methodsFor: 'line drawing' stamp: 'lr 7/4/2009 10:42'! 19970drawLoopX: xDelta Y: yDelta 19971 "Primitive. Implements the Bresenham plotting algorithm (IBM Systems 19972 Journal, Vol. 4 No. 1, 1965). It chooses a principal direction, and 19973 maintains a potential, P. When P's sign changes, it is time to move in 19974 the minor direction as well. This particular version does not write the 19975 first and last points, so that these can be called for as needed in client code. 19976 Optional. See Object documentation whatIsAPrimitive." 19977 | dx dy px py P | 19978 <primitive: 'primitiveDrawLoop' module: 'BitBltPlugin'> 19979 dx := xDelta sign. 19980 dy := yDelta sign. 19981 px := yDelta abs. 19982 py := xDelta abs. 19983 "self copyBits." 19984 py > px 19985 ifTrue: 19986 [ "more horizontal" 19987 P := py // 2. 19988 1 19989 to: py 19990 do: 19991 [ :i | 19992 destX := destX + dx. 19993 (P := P - px) < 0 ifTrue: 19994 [ destY := destY + dy. 19995 P := P + py ]. 19996 i < py ifTrue: [ self copyBits ] ] ] 19997 ifFalse: 19998 [ "more vertical" 19999 P := px // 2. 20000 1 20001 to: px 20002 do: 20003 [ :i | 20004 destY := destY + dy. 20005 (P := P - py) < 0 ifTrue: 20006 [ destX := destX + dx. 20007 P := P + px ]. 20008 i < px ifTrue: [ self copyBits ] ] ]! ! 20009 20010 20011!BitBlt methodsFor: 'text display' stamp: 'ar 10/24/2005 21:49'! 20012displayString: aString from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY font: aFont 20013 "Double dispatch into the font. This method is present so that other-than-bitblt entities can be used by CharacterScanner and friends to display text." 20014 ^ aFont displayString: aString on: self from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY! ! 20015 20016!BitBlt methodsFor: 'text display' stamp: 'ar 10/25/2005 01:12'! 20017displayString: aString from: startIndex to: stopIndex at: aPoint kern: kernDelta font: aFont 20018 "Double dispatch into the font. This method is present so that other-than-bitblt entities can be used by CharacterScanner and friends to display text." 20019 ^ aFont displayString: aString on: self from: startIndex to: stopIndex at: aPoint kern: kernDelta! ! 20020 20021!BitBlt methodsFor: 'text display' stamp: 'ar 10/24/2005 21:48'! 20022installFont: aFont foregroundColor: foregroundColor backgroundColor: backgroundColor 20023 "Double dispatch into the font. This method is present so that other-than-bitblt entities can be used by CharacterScanner and friends to display text." 20024 ^aFont installOn: self foregroundColor: foregroundColor backgroundColor: backgroundColor! ! 20025 20026 20027!BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 20028cachedFontColormapFrom: sourceDepth to: destDepth 20029 "Modified from computeColormapFrom:to:." 20030 | srcIndex map | 20031 CachedFontColorMaps class == Array ifFalse: [ CachedFontColorMaps := (1 to: 9) collect: [ :i | Array new: 32 ] ]. 20032 srcIndex := sourceDepth. 20033 sourceDepth > 8 ifTrue: [ srcIndex := 9 ]. 20034 (map := (CachedFontColorMaps at: srcIndex) at: destDepth) ~~ nil ifTrue: [ ^ map ]. 20035 map := (Color 20036 cachedColormapFrom: sourceDepth 20037 to: destDepth) copy. 20038 (CachedFontColorMaps at: srcIndex) 20039 at: destDepth 20040 put: map. 20041 ^ map! ! 20042 20043!BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 20044clipRange 20045 "clip and adjust source origin and extent appropriately" 20046 "first in x" 20047 "fill in the lazy state if needed" 20048 | sx sy dx dy bbW bbH | 20049 destX ifNil: [ destX := 0 ]. 20050 destY ifNil: [ destY := 0 ]. 20051 width ifNil: [ width := destForm width ]. 20052 height ifNil: [ height := destForm height ]. 20053 sourceX ifNil: [ sourceX := 0 ]. 20054 sourceY ifNil: [ sourceY := 0 ]. 20055 clipX ifNil: [ clipX := 0 ]. 20056 clipY ifNil: [ clipY := 0 ]. 20057 clipWidth ifNil: [ clipWidth := destForm width ]. 20058 clipHeight ifNil: [ clipHeight := destForm height ]. 20059 destX >= clipX 20060 ifTrue: 20061 [ sx := sourceX. 20062 dx := destX. 20063 bbW := width ] 20064 ifFalse: 20065 [ sx := sourceX + (clipX - destX). 20066 bbW := width - (clipX - destX). 20067 dx := clipX ]. 20068 dx + bbW > (clipX + clipWidth) ifTrue: [ bbW := bbW - (dx + bbW - (clipX + clipWidth)) ]. 20069 "then in y" 20070 destY >= clipY 20071 ifTrue: 20072 [ sy := sourceY. 20073 dy := destY. 20074 bbH := height ] 20075 ifFalse: 20076 [ sy := sourceY + clipY - destY. 20077 bbH := height - (clipY - destY). 20078 dy := clipY ]. 20079 dy + bbH > (clipY + clipHeight) ifTrue: [ bbH := bbH - (dy + bbH - (clipY + clipHeight)) ]. 20080 sourceForm ifNotNil: 20081 [ sx < 0 ifTrue: 20082 [ dx := dx - sx. 20083 bbW := bbW + sx. 20084 sx := 0 ]. 20085 sx + bbW > sourceForm width ifTrue: [ bbW := bbW - (sx + bbW - sourceForm width) ]. 20086 sy < 0 ifTrue: 20087 [ dy := dy - sy. 20088 bbH := bbH + sy. 20089 sy := 0 ]. 20090 sy + bbH > sourceForm height ifTrue: [ bbH := bbH - (sy + bbH - sourceForm height) ] ]. 20091 (bbW <= 0 or: [ bbH <= 0 ]) ifTrue: 20092 [ sourceX := sourceY := destX := destY := clipX := clipY := width := height := 0. 20093 ^ true ]. 20094 (sx = sourceX and: 20095 [ sy = sourceY and: 20096 [ dx = destX and: [ dy = destY and: [ bbW = width and: [ bbH = height ] ] ] ] ]) ifTrue: [ ^ false ]. 20097 sourceX := sx. 20098 sourceY := sy. 20099 destX := dx. 20100 destY := dy. 20101 width := bbW. 20102 height := bbH. 20103 ^ true! ! 20104 20105!BitBlt methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! 20106colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix 20107 | srcIndex map mapsForSource mapsForSourceAndDest | 20108 ColorConvertingMaps class == Array ifFalse: [ ColorConvertingMaps := (1 to: 10) collect: [ :i | Array new: 32 ] ]. 20109 srcIndex := sourceDepth. 20110 sourceDepth > 8 ifTrue: 20111 [ srcIndex := keepSubPix 20112 ifTrue: [ 9 ] 20113 ifFalse: [ 10 ] ]. 20114 mapsForSource := ColorConvertingMaps at: srcIndex. 20115 (mapsForSourceAndDest := mapsForSource at: destDepth) isNil ifTrue: 20116 [ mapsForSourceAndDest := mapsForSource 20117 at: destDepth 20118 put: Dictionary new ]. 20119 map := mapsForSourceAndDest 20120 at: targetColor 20121 ifAbsentPut: 20122 [ Color 20123 computeColorConvertingMap: targetColor 20124 from: sourceDepth 20125 to: destDepth 20126 keepSubPixelAA: keepSubPix ]. 20127 ^ map! ! 20128 20129!BitBlt methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 20130copyBitsAgain 20131 "Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object 20132 documentation whatIsAPrimitive." 20133 20134 <primitive: 'primitiveCopyBits' module: 'BitBltPlugin'> 20135 self primitiveFailed! ! 20136 20137!BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 20138copyBitsFrom: x0 to: x1 at: y 20139 destX := x0. 20140 destY := y. 20141 sourceX := x0. 20142 width := x1 - x0. 20143 self copyBits! ! 20144 20145!BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 20146eraseBits 20147 "Perform the erase operation, which puts 0's in the destination 20148 wherever the source (which is assumed to be just 1 bit deep) 20149 has a 1. This requires the colorMap to be set in order to AND 20150 all 1's into the destFrom pixels regardless of their size." 20151 | oldMask oldMap | 20152 oldMask := halftoneForm. 20153 halftoneForm := nil. 20154 oldMap := colorMap. 20155 self colorMap: (Bitmap 20156 with: 0 20157 with: 4294967295). 20158 combinationRule := Form erase. 20159 self copyBits. "Erase the dest wherever the source is 1" 20160 halftoneForm := oldMask. "already converted to a Bitmap" 20161 colorMap := oldMap! ! 20162 20163!BitBlt methodsFor: 'private' stamp: 'ar 5/26/2000 16:38'! 20164getPluginName 20165 "Private. Return the name of the plugin representing BitBlt. 20166 Used for dynamically switching between different BB representations only." 20167 ^'BitBltPlugin'! ! 20168 20169!BitBlt methodsFor: 'private' stamp: 'jmv 9/7/2009 09:27'! 20170installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor 20171 | lastSourceDepth targetColor | 20172 sourceForm ifNotNil:[lastSourceDepth := sourceForm depth]. 20173 sourceForm := aStrikeFont glyphs. 20174 20175 "Ignore any halftone pattern since we use a color map approach here" 20176 halftoneForm := nil. 20177 sourceY := 0. 20178 height := aStrikeFont height. 20179 20180 sourceForm depth = 1 ifTrue: [ 20181 self combinationRule: Form paint. 20182 (colorMap notNil and:[lastSourceDepth = sourceForm depth]) ifFalse: [ 20183 "Set up color map for a different source depth (color font)" 20184 "Uses caching for reasonable efficiency" 20185 colorMap := self cachedFontColormapFrom: sourceForm depth to: destForm depth. 20186 colorMap at: 1 put: (destForm pixelValueFor: backgroundColor)]. 20187 colorMap at: 2 put: (destForm pixelValueFor: foregroundColor). 20188 ] 20189 ifFalse: [ 20190 (Preferences subPixelRenderFonts and: [ foregroundColor = Color black or: [ Preferences subPixelRenderColorFonts ]]) ifTrue: [ 20191 destForm depth > 8 ifTrue: [ 20192 "rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)" 20193 self combinationRule: 37. "RGBMul" 20194 colorMap := (destForm depth = 32 or: [ (foregroundColor = Color black) not ]) ifTrue: [ 20195 "rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)" 20196 "This colorMap is to be used on the second pass with rule 20 (rgbAdd) 20197 See #displayString:from:to:at:strikeFont:kern:" 20198 "Note: In 32bpp we always need the second pass, as the source could have transparent pixels, and we need to add to the alpha channel" 20199 self colorConvertingMap: foregroundColor from: sourceForm depth to: destForm depth keepSubPixelAA: true]] 20200 ifFalse: [ 20201 self combinationRule: 25. "Paint" 20202 targetColor := foregroundColor = Color black ifFalse: [ foregroundColor ]. 20203 colorMap := self colorConvertingMap: targetColor from: sourceForm depth to: destForm depth keepSubPixelAA: true] 20204 ] 20205 ifFalse: [ 20206 "Do not use rule 34 for 16bpp display. TTCFont uses it, but it builds a glyphs cache for each color used!!" 20207 self combinationRule: (destForm depth = 32 ifTrue: [34 "alphaBlendScaled"] ifFalse: [25 "Paint"]). 20208 colorMap := self colorConvertingMap: foregroundColor from: sourceForm depth to: destForm depth keepSubPixelAA: false 20209 ] 20210 ].! ! 20211 20212!BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 20213installTTCFont: aTTCFont foregroundColor: foregroundColor backgroundColor: backgroundColor 20214 "Set up the parameters. Since the glyphs in a TTCFont is 32bit depth form, it tries to use rule=34 to get better AA result if possible." 20215 aTTCFont depth = 32 ifTrue: 20216 [ destForm depth <= 8 20217 ifTrue: 20218 [ self colorMap: (self 20219 cachedFontColormapFrom: aTTCFont depth 20220 to: destForm depth). 20221 self combinationRule: Form paint ] 20222 ifFalse: 20223 [ self colorMap: nil. 20224 self combinationRule: 34 ]. 20225 halftoneForm := nil. 20226 sourceY := 0. 20227 height := aTTCFont height ]! ! 20228 20229!BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 20230paintBits 20231 "Perform the paint operation, which requires two calls to BitBlt." 20232 | color oldMap saveRule | 20233 sourceForm depth = 1 ifFalse: 20234 [ ^ self halt: 'paint operation is only defined for 1-bit deep sourceForms' ]. 20235 saveRule := combinationRule. 20236 color := halftoneForm. 20237 halftoneForm := nil. 20238 oldMap := colorMap. 20239 "Map 1's to ALL ones, not just one" 20240 self colorMap: (Bitmap 20241 with: 0 20242 with: 4294967295). 20243 combinationRule := Form erase. 20244 self copyBits. "Erase the dest wherever the source is 1" 20245 halftoneForm := color. 20246 combinationRule := Form under. 20247 self copyBits. "then OR, with whatever color, into the hole" 20248 colorMap := oldMap. 20249 combinationRule := saveRule 20250 20251 " | dot | 20252dot _ Form dotOfSize: 32. 20253((BitBlt destForm: Display 20254 sourceForm: dot 20255 fillColor: Color lightGray 20256 combinationRule: Form paint 20257 destOrigin: Sensor cursorPoint 20258 sourceOrigin: 0@0 20259 extent: dot extent 20260 clipRect: Display boundingBox) 20261 colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) copyBits"! ! 20262 20263!BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 20264primDisplayString: aString from: startIndex to: stopIndex map: glyphMap xTable: xTable kern: kernDelta 20265 | ascii | 20266 <primitive:'primitiveDisplayString' module:'BitBltPlugin'> 20267 startIndex 20268 to: stopIndex 20269 do: 20270 [ :charIndex | 20271 ascii := (aString at: charIndex) asciiValue. 20272 sourceX := xTable at: ascii + 1. 20273 width := (xTable at: ascii + 2) - sourceX. 20274 self copyBits. 20275 destX := destX + width + kernDelta ]! ! 20276 20277!BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 20278roundVariables 20279 | maxVal minVal | 20280 maxVal := SmallInteger maxVal. 20281 minVal := SmallInteger minVal. 20282 destX := destX asInteger 20283 min: maxVal 20284 max: minVal. 20285 destY := destY asInteger 20286 min: maxVal 20287 max: minVal. 20288 width := width asInteger 20289 min: maxVal 20290 max: minVal. 20291 height := height asInteger 20292 min: maxVal 20293 max: minVal. 20294 sourceX := sourceX asInteger 20295 min: maxVal 20296 max: minVal. 20297 sourceY := sourceY asInteger 20298 min: maxVal 20299 max: minVal. 20300 clipX := clipX asInteger 20301 min: maxVal 20302 max: minVal. 20303 clipY := clipY asInteger 20304 min: maxVal 20305 max: minVal. 20306 clipWidth := clipWidth asInteger 20307 min: maxVal 20308 max: minVal. 20309 clipHeight := clipHeight asInteger 20310 min: maxVal 20311 max: minVal! ! 20312 20313!BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 20314setDestForm: df 20315 | bb | 20316 bb := df boundingBox. 20317 destForm := df. 20318 clipX := bb left. 20319 clipY := bb top. 20320 clipWidth := bb width. 20321 clipHeight := bb height! ! 20322 20323!BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 20324setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect 20325 | aPoint | 20326 destForm := df. 20327 sourceForm := sf. 20328 self fillColor: hf. "sets halftoneForm" 20329 combinationRule := cr. 20330 destX := destOrigin x. 20331 destY := destOrigin y. 20332 sourceX := sourceOrigin x. 20333 sourceY := sourceOrigin y. 20334 width := extent x. 20335 height := extent y. 20336 aPoint := clipRect origin. 20337 clipX := aPoint x. 20338 clipY := aPoint y. 20339 aPoint := clipRect corner. 20340 clipWidth := aPoint x - clipX. 20341 clipHeight := aPoint y - clipY. 20342 sourceForm == nil ifFalse: [ colorMap := sourceForm colormapIfNeededFor: destForm ]! ! 20343 20344"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 20345 20346BitBlt class 20347 instanceVariableNames: ''! 20348 20349!BitBlt class methodsFor: 'benchmarks' stamp: 'PeterHugossonMiller 9/3/2009 00:12'! 20350benchDiffsFrom: before to: afterwards 20351 "Given two outputs of BitBlt>>benchmark show the relative improvements." 20352 | old new log oldLine newLine oldVal newVal improvement | 20353 log := String new writeStream. 20354 old := before readStream. 20355 new := afterwards readStream. 20356 [ old atEnd or: [ new atEnd ] ] whileFalse: 20357 [ oldLine := old upTo: Character cr. 20358 newLine := new upTo: Character cr. 20359 (oldLine includes: Character tab) 20360 ifTrue: 20361 [ oldLine := oldLine readStream. 20362 newLine := newLine readStream. 20363 Transcript 20364 cr; 20365 show: (oldLine upTo: Character tab); 20366 tab. 20367 log 20368 cr; 20369 nextPutAll: (newLine upTo: Character tab); 20370 tab. 20371 20372 [ oldLine skipSeparators. 20373 newLine skipSeparators. 20374 oldLine atEnd ] whileFalse: 20375 [ oldVal := Integer readFrom: oldLine. 20376 newVal := Integer readFrom: newLine. 20377 improvement := oldVal asFloat / newVal asFloat roundTo: 0.01. 20378 Transcript 20379 show: improvement printString; 20380 tab; 20381 tab. 20382 log 20383 print: improvement; 20384 tab; 20385 tab ] ] 20386 ifFalse: 20387 [ Transcript 20388 cr; 20389 show: oldLine. 20390 log 20391 cr; 20392 nextPutAll: oldLine ] ]. 20393 ^ log contents! ! 20394 20395!BitBlt class methodsFor: 'benchmarks' stamp: 'PeterHugossonMiller 9/3/2009 00:13'! 20396benchmark 20397 "BitBlt benchmark" 20398 "Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else. 20399 Attention: *this*may*take*a*while*" 20400 | bb source dest destRect log t | 20401 log := String new writeStream. 20402 destRect := 0 @ 0 extent: 600 @ 600. 20403 "Form paint/Form over - the most common rules" 20404 #(25 3 ) do: 20405 [ :rule | 20406 Transcript 20407 cr; 20408 show: '---- Combination rule: ' , rule printString , ' ----'. 20409 log 20410 cr; 20411 nextPutAll: '---- Combination rule: ' , rule printString , ' ----'. 20412 #(1 2 4 8 16 32 ) do: 20413 [ :destDepth | 20414 dest := nil. 20415 dest := Form 20416 extent: destRect extent 20417 depth: destDepth. 20418 Transcript cr. 20419 log cr. 20420 #(1 2 4 8 16 32 ) do: 20421 [ :sourceDepth | 20422 Transcript 20423 cr; 20424 show: sourceDepth printString , ' => ' , destDepth printString. 20425 log 20426 cr; 20427 nextPutAll: sourceDepth printString , ' => ' , destDepth printString. 20428 source := nil. 20429 bb := nil. 20430 source := Form 20431 extent: destRect extent 20432 depth: sourceDepth. 20433 source getCanvas 20434 fillOval: dest boundingBox 20435 color: Color yellow 20436 borderWidth: 30 20437 borderColor: Color black. 20438 bb := WarpBlt toForm: dest. 20439 bb sourceForm: source. 20440 bb sourceRect: source boundingBox. 20441 bb destRect: dest boundingBox. 20442 bb colorMap: (source colormapIfNeededFor: dest). 20443 bb combinationRule: rule. 20444 20445 "Measure speed of copyBits" 20446 t := Time millisecondsToRun: [ bb copyBits ]. 20447 Transcript 20448 tab; 20449 show: t printString. 20450 log 20451 tab; 20452 nextPutAll: t printString. 20453 bb 20454 sourceForm: source 20455 destRect: source boundingBox. 20456 20457 "Measure speed of 1x1 warpBits" 20458 bb cellSize: 1. 20459 t := Time millisecondsToRun: [ bb warpBits ]. 20460 Transcript 20461 tab; 20462 show: t printString. 20463 log 20464 tab; 20465 nextPutAll: t printString. 20466 20467 "Measure speed of 2x2 warpBits" 20468 bb cellSize: 2. 20469 t := Time millisecondsToRun: [ bb warpBits ]. 20470 Transcript 20471 tab; 20472 show: t printString. 20473 log 20474 tab; 20475 nextPutAll: t printString. 20476 20477 "Measure speed of 3x3 warpBits" 20478 bb cellSize: 3. 20479 t := Time millisecondsToRun: [ bb warpBits ]. 20480 Transcript 20481 tab; 20482 show: t printString. 20483 log 20484 tab; 20485 nextPutAll: t printString ] ] ]. 20486 ^ log contents! ! 20487 20488!BitBlt class methodsFor: 'benchmarks' stamp: 'PeterHugossonMiller 9/3/2009 00:14'! 20489benchmark2 20490 "BitBlt benchmark" 20491 "Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else. 20492 Attention: *this*may*take*a*while*" 20493 | bb source dest destRect log t | 20494 log := String new writeStream. 20495 destRect := 0 @ 0 extent: 600 @ 600. 20496 "Form paint/Form over - the most common rules" 20497 #(25 3 ) do: 20498 [ :rule | 20499 Transcript 20500 cr; 20501 show: '---- Combination rule: ' , rule printString , ' ----'. 20502 log 20503 cr; 20504 nextPutAll: '---- Combination rule: ' , rule printString , ' ----'. 20505 #(1 2 4 8 16 32 ) do: 20506 [ :destDepth | 20507 dest := nil. 20508 dest := Form 20509 extent: destRect extent 20510 depth: destDepth. 20511 Transcript cr. 20512 log cr. 20513 #(1 2 4 8 16 32 ) do: 20514 [ :sourceDepth | 20515 Transcript 20516 cr; 20517 show: sourceDepth printString , ' => ' , destDepth printString. 20518 log 20519 cr; 20520 nextPutAll: sourceDepth printString , ' => ' , destDepth printString. 20521 source := nil. 20522 bb := nil. 20523 source := Form 20524 extent: destRect extent 20525 depth: sourceDepth. 20526 source getCanvas 20527 fillOval: dest boundingBox 20528 color: Color yellow 20529 borderWidth: 30 20530 borderColor: Color black. 20531 bb := WarpBlt toForm: dest. 20532 bb sourceForm: source. 20533 bb sourceRect: source boundingBox. 20534 bb destRect: dest boundingBox. 20535 bb colorMap: (source colormapIfNeededFor: dest). 20536 bb combinationRule: rule. 20537 20538 "Measure speed of copyBits" 20539 t := Time millisecondsToRun: 20540 [ 1 20541 to: 10 20542 do: [ :i | bb copyBits ] ]. 20543 Transcript 20544 tab; 20545 show: t printString. 20546 log 20547 tab; 20548 nextPutAll: t printString. 20549 bb 20550 sourceForm: source 20551 destRect: source boundingBox. 20552 20553 "Measure speed of 1x1 warpBits" 20554 bb cellSize: 1. 20555 t := Time millisecondsToRun: 20556 [ 1 20557 to: 4 20558 do: [ :i | bb warpBits ] ]. 20559 Transcript 20560 tab; 20561 show: t printString. 20562 log 20563 tab; 20564 nextPutAll: t printString. 20565 20566 "Measure speed of 2x2 warpBits" 20567 bb cellSize: 2. 20568 t := Time millisecondsToRun: [ bb warpBits ]. 20569 Transcript 20570 tab; 20571 show: t printString. 20572 log 20573 tab; 20574 nextPutAll: t printString. 20575 20576 "Measure speed of 3x3 warpBits" 20577 bb cellSize: 3. 20578 t := Time millisecondsToRun: [ bb warpBits ]. 20579 Transcript 20580 tab; 20581 show: t printString. 20582 log 20583 tab; 20584 nextPutAll: t printString ] ] ]. 20585 ^ log contents! ! 20586 20587!BitBlt class methodsFor: 'benchmarks' stamp: 'PeterHugossonMiller 9/3/2009 00:14'! 20588benchmark3 20589 "BitBlt benchmark" 20590 "Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else. 20591 Attention: *this*may*take*a*while*" 20592 | bb source dest destRect log t | 20593 log := String new writeStream. 20594 destRect := 0 @ 0 extent: 600 @ 600. 20595 "Form paint/Form over - the most common rules" 20596 #(25 3 ) do: 20597 [ :rule | 20598 Transcript 20599 cr; 20600 show: '---- Combination rule: ' , rule printString , ' ----'. 20601 log 20602 cr; 20603 nextPutAll: '---- Combination rule: ' , rule printString , ' ----'. 20604 #(1 2 4 8 16 32 ) do: 20605 [ :destDepth | 20606 dest := nil. 20607 dest := Form 20608 extent: destRect extent 20609 depth: destDepth. 20610 Transcript cr. 20611 log cr. 20612 #(1 2 4 8 16 32 ) do: 20613 [ :sourceDepth | 20614 Transcript 20615 cr; 20616 show: sourceDepth printString , ' => ' , destDepth printString. 20617 log 20618 cr; 20619 nextPutAll: sourceDepth printString , ' => ' , destDepth printString. 20620 source := nil. 20621 bb := nil. 20622 source := Form 20623 extent: destRect extent 20624 depth: sourceDepth. 20625 source getCanvas 20626 fillOval: dest boundingBox 20627 color: Color yellow 20628 borderWidth: 30 20629 borderColor: Color black. 20630 bb := WarpBlt toForm: dest. 20631 bb sourceForm: source. 20632 bb sourceRect: source boundingBox. 20633 bb destRect: dest boundingBox. 20634 bb colorMap: (source colormapIfNeededFor: dest). 20635 bb combinationRule: rule. 20636 20637 "Measure speed of copyBits" 20638 t := Time millisecondsToRun: 20639 [ 1 20640 to: 10 20641 do: [ :i | bb copyBits ] ]. 20642 Transcript 20643 tab; 20644 show: t printString. 20645 log 20646 tab; 20647 nextPutAll: t printString. 20648 bb 20649 sourceForm: source 20650 destRect: source boundingBox. 20651 20652 "Measure speed of 1x1 warpBits" 20653 bb cellSize: 1. 20654 t := Time millisecondsToRun: 20655 [ 1 20656 to: 4 20657 do: [ :i | bb warpBits ] ]. 20658 Transcript 20659 tab; 20660 show: t printString. 20661 log 20662 tab; 20663 nextPutAll: t printString. 20664 20665 "Measure speed of 2x2 warpBits" 20666 bb cellSize: 2. 20667 t := Time millisecondsToRun: [ bb warpBits ]. 20668 Transcript 20669 tab; 20670 show: t printString. 20671 log 20672 tab; 20673 nextPutAll: t printString. 20674 20675 "Measure speed of 3x3 warpBits" 20676 bb cellSize: 3. 20677 t := Time millisecondsToRun: [ bb warpBits ]. 20678 Transcript 20679 tab; 20680 show: t printString. 20681 log 20682 tab; 20683 nextPutAll: t printString ] ] ]. 20684 ^ log contents! ! 20685 20686 20687!BitBlt class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 20688alphaBlendDemo 20689 "To run this demo, use... 20690 Display restoreAfter: [BitBlt alphaBlendDemo] 20691 Displays 10 alphas, then lets you paint. Option-Click to stop painting." 20692 "This code exhibits alpha blending in any display depth by performing 20693 the blend in an off-screen buffer with 32-bit pixels, and then copying 20694 the result back onto the screen with an appropriate color map. - tk 3/10/97" 20695 "This version uses a sliding buffer for painting that keeps pixels in 32 bits 20696 as long as they are in the buffer, so as not to lose info by converting down 20697 to display resolution and back up to 32 bits at each operation. - di 3/15/97" 20698 "compute color maps if needed" 20699 | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect | 20700 Display depth <= 8 ifTrue: 20701 [ mapDto32 := Color 20702 cachedColormapFrom: Display depth 20703 to: 32. 20704 map32toD := Color 20705 cachedColormapFrom: 32 20706 to: Display depth ]. 20707 20708 "display 10 different alphas, across top of screen" 20709 buff := Form 20710 extent: 500 @ 50 20711 depth: 32. 20712 dispToBuff := BitBlt toForm: buff. 20713 dispToBuff colorMap: mapDto32. 20714 dispToBuff 20715 copyFrom: (50 @ 10 extent: 500 @ 50) 20716 in: Display 20717 to: 0 @ 0. 20718 1 20719 to: 10 20720 do: 20721 [ :i | 20722 dispToBuff 20723 fill: ((50 * (i - 1)) @ 0 extent: 50 @ 50) 20724 fillColor: (Color red alpha: i / 10) 20725 rule: Form blend ]. 20726 buffToDisplay := BitBlt toForm: Display. 20727 buffToDisplay colorMap: map32toD. 20728 buffToDisplay 20729 copyFrom: buff boundingBox 20730 in: buff 20731 to: 50 @ 10. 20732 20733 "Create a brush with radially varying alpha" 20734 brush := Form 20735 extent: 30 @ 30 20736 depth: 32. 20737 1 20738 to: 5 20739 do: 20740 [ :i | 20741 brush 20742 fillShape: (Form dotOfSize: brush width * (6 - i) // 5) 20743 fillColor: (Color red alpha: 0.02 * i - 0.01) 20744 at: brush extent // 2 ]. 20745 20746 "Now paint with the brush using alpha blending." 20747 buffSize := 100. 20748 buff := Form 20749 extent: brush extent + buffSize 20750 depth: 32. "Travelling 32-bit buffer" 20751 dispToBuff := BitBlt toForm: buff. "This is from Display to buff" 20752 dispToBuff colorMap: mapDto32. 20753 brushToBuff := BitBlt toForm: buff. "This is from brush to buff" 20754 brushToBuff 20755 sourceForm: brush; 20756 sourceOrigin: 0 @ 0. 20757 brushToBuff combinationRule: Form blend. 20758 buffToBuff := BitBlt toForm: buff. "This is for slewing the buffer" 20759 [ Sensor yellowButtonPressed ] whileFalse: 20760 [ prevP := nil. 20761 buffRect := Sensor cursorPoint - (buffSize // 2) extent: buff extent. 20762 dispToBuff 20763 copyFrom: buffRect 20764 in: Display 20765 to: 0 @ 0. 20766 [ Sensor redButtonPressed ] whileTrue: 20767 [ "Here is the painting loop" 20768 p := Sensor cursorPoint - (brush extent // 2). 20769 (prevP == nil or: [ prevP ~= p ]) ifTrue: 20770 [ prevP == nil ifTrue: [ prevP := p ]. 20771 (p dist: prevP) > buffSize ifTrue: 20772 [ "Stroke too long to fit in buffer -- clip to buffer, 20773 and next time through will do more of it" 20774 theta := (p - prevP) theta. 20775 p := (theta cos @ theta sin * buffSize asFloat + prevP) truncated ]. 20776 brushRect := p extent: brush extent. 20777 (buffRect containsRect: brushRect) ifFalse: 20778 [ "Brush is out of buffer region. Scroll the buffer, 20779 and fill vacated regions from the display" 20780 delta := brushRect amountToTranslateWithin: buffRect. 20781 buffToBuff 20782 copyFrom: buff boundingBox 20783 in: buff 20784 to: delta. 20785 newBuffRect := buffRect translateBy: delta negated. 20786 (newBuffRect areasOutside: buffRect) do: 20787 [ :r | 20788 dispToBuff 20789 copyFrom: r 20790 in: Display 20791 to: r origin - newBuffRect origin ]. 20792 buffRect := newBuffRect ]. 20793 20794 "Interpolate from prevP to p..." 20795 brushToBuff 20796 drawFrom: prevP - buffRect origin 20797 to: p - buffRect origin 20798 withFirstPoint: false. 20799 20800 "Update (only) the altered pixels of the destination" 20801 updateRect := (p min: prevP) corner: (p max: prevP) + brush extent. 20802 buffToDisplay 20803 copy: updateRect 20804 from: updateRect origin - buffRect origin 20805 in: buff. 20806 prevP := p ] ] ]! ! 20807 20808!BitBlt class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 20809antiAliasDemo 20810 "To run this demo, use... 20811 Display restoreAfter: [BitBlt antiAliasDemo] 20812 Goes immediately into on-screen paint mode. Option-Click to stop painting." 20813 "This code exhibits alpha blending in any display depth by performing 20814 the blend in an off-screen buffer with 32-bit pixels, and then copying 20815 the result back onto the screen with an appropriate color map. - tk 3/10/97" 20816 "This version uses a sliding buffer for painting that keeps pixels in 32 bits 20817 as long as they are in the buffer, so as not to lose info by converting down 20818 to display resolution and back up to 32 bits at each operation. - di 3/15/97" 20819 "This version also uses WarpBlt to paint into twice as large a buffer, 20820 and then use smoothing when reducing back down to the display. 20821 In fact this same routine will now work for 3x3 soothing as well. 20822 Remove the statements 'buff displayAt: 0@0' to hide the buffer. - di 3/19/97" 20823 "compute color maps if needed" 20824 | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect scale p0 | 20825 Display depth <= 8 ifTrue: 20826 [ mapDto32 := Color 20827 cachedColormapFrom: Display depth 20828 to: 32. 20829 map32toD := Color 20830 cachedColormapFrom: 32 20831 to: Display depth ]. 20832 20833 "Create a brush with radially varying alpha" 20834 brush := Form 20835 extent: 3 @ 3 20836 depth: 32. 20837 brush 20838 fill: brush boundingBox 20839 fillColor: (Color red alpha: 0.05). 20840 brush 20841 fill: (1 @ 1 extent: 1 @ 1) 20842 fillColor: (Color red alpha: 0.2). 20843 scale := 2. "Actual drawing happens at this magnification" 20844 "Scale brush up for painting in magnified buffer" 20845 brush := brush 20846 magnify: brush boundingBox 20847 by: scale. 20848 20849 "Now paint with the brush using alpha blending." 20850 buffSize := 100. 20851 buff := Form 20852 extent: (brush extent + buffSize) * scale 20853 depth: 32. "Travelling 32-bit buffer" 20854 dispToBuff := (WarpBlt toForm: buff) 20855 sourceForm: Display; 20856 colorMap: mapDto32; 20857 combinationRule: Form over. "From Display to buff - magnify by 2" 20858 brushToBuff := (BitBlt toForm: buff) 20859 sourceForm: brush; 20860 sourceOrigin: 0 @ 0; 20861 combinationRule: Form blend. "From brush to buff" 20862 buffToDisplay := (WarpBlt toForm: Display) 20863 sourceForm: buff; 20864 colorMap: map32toD; 20865 cellSize: scale; 20866 combinationRule: Form over. "From buff to Display - shrink by 2" "...and use smoothing" 20867 buffToBuff := BitBlt toForm: buff. "This is for slewing the buffer" 20868 [ Sensor yellowButtonPressed ] whileFalse: 20869 [ prevP := nil. 20870 buffRect := Sensor cursorPoint - (buff extent // scale // 2) extent: buff extent // scale. 20871 p0 := buff extent // 2 - (buffRect extent // 2). 20872 dispToBuff 20873 copyQuad: buffRect innerCorners 20874 toRect: buff boundingBox. 20875 buff displayAt: 0 @ 0. "** remove to hide sliding buffer **" 20876 [ Sensor redButtonPressed ] whileTrue: 20877 [ "Here is the painting loop" 20878 p := Sensor cursorPoint - buffRect origin + p0. "p, prevP are rel to buff origin" 20879 (prevP == nil or: [ prevP ~= p ]) ifTrue: 20880 [ prevP == nil ifTrue: [ prevP := p ]. 20881 (p dist: prevP) > (buffSize - 1) ifTrue: 20882 [ "Stroke too long to fit in buffer -- clip to buffer, 20883 and next time through will do more of it" 20884 theta := (p - prevP) theta. 20885 p := (theta cos @ theta sin * (buffSize - 2) asFloat + prevP) truncated ]. 20886 brushRect := p extent: brush extent. 20887 ((buff boundingBox insetBy: scale) containsRect: brushRect) ifFalse: 20888 [ "Brush is out of buffer region. Scroll the buffer, 20889 and fill vacated regions from the display" 20890 delta := (brushRect amountToTranslateWithin: (buff boundingBox insetBy: scale)) // scale. 20891 buffToBuff 20892 copyFrom: buff boundingBox 20893 in: buff 20894 to: delta * scale. 20895 newBuffRect := buffRect translateBy: delta negated. 20896 p := p translateBy: delta * scale. 20897 prevP := prevP translateBy: delta * scale. 20898 (newBuffRect areasOutside: buffRect) do: 20899 [ :r | 20900 dispToBuff 20901 copyQuad: r innerCorners 20902 toRect: ((r origin - newBuffRect origin) * scale extent: r extent * scale) ]. 20903 buffRect := newBuffRect ]. 20904 20905 "Interpolate from prevP to p..." 20906 brushToBuff 20907 drawFrom: prevP 20908 to: p 20909 withFirstPoint: false. 20910 buff displayAt: 0 @ 0. "** remove to hide sliding buffer **" 20911 20912 "Update (only) the altered pixels of the destination" 20913 updateRect := (p min: prevP) corner: (p max: prevP) + brush extent. 20914 updateRect := updateRect origin // scale * scale corner: (updateRect corner + scale) // scale * scale. 20915 buffToDisplay 20916 copyQuad: updateRect innerCorners 20917 toRect: (updateRect origin // scale + buffRect origin extent: updateRect extent // scale). 20918 prevP := p ] ] ]! ! 20919 20920!BitBlt class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 20921exampleColorMap 20922 "BitBlt exampleColorMap" 20923 "This example shows what one can do with the fixed part of a color map. The color map, as setup below, rotates the bits of a pixel all the way around. Thus you'll get a (sometime strange looking ;-) animation of colors which will end up exactly the way it looked at the beginning. The example is given to make you understand that the masks and shifts can be used for a lot more than simply color converting pixels. In this example, for instance, we use only two of the four independent shifters." 20924 | cc bb | 20925 cc := ColorMap 20926 masks: { 20927 (1 << (Display depth - 1)). "mask out high bit of color component" 20928 ((1 << (Display depth - 1)) - 1). "mask all other bits" 20929 0. 20930 0 20931 } 20932 shifts: { 20933 (1 - Display depth). "shift right to bottom most position" 20934 1. "shift all other pixels one bit left" 20935 0. 20936 0 20937 }. 20938 bb := BitBlt toForm: Display. 20939 bb 20940 sourceForm: Display; 20941 combinationRule: 3; 20942 colorMap: cc. 20943 1 20944 to: Display depth 20945 do: 20946 [ :i | 20947 bb copyBits. 20948 Display forceDisplayUpdate ]! ! 20949 20950!BitBlt class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 20951exampleOne 20952 "This tests BitBlt by displaying the result of all sixteen combination rules that BitBlt is capable of using. (Please see the comment in BitBlt for the meaning of the combination rules). This only works at Display depth of 1. (Rule 15 does not work?)" 20953 | path displayDepth | 20954 displayDepth := Display depth. 20955 Display newDepth: 1. 20956 path := Path new. 20957 0 20958 to: 3 20959 do: 20960 [ :i | 20961 0 20962 to: 3 20963 do: [ :j | path add: (j * 100) @ (i * 75) ] ]. 20964 Display fillWhite. 20965 path := path translateBy: 60 @ 40. 20966 1 20967 to: 16 20968 do: 20969 [ :index | 20970 BitBlt 20971 exampleAt: (path at: index) 20972 rule: index - 1 20973 fillColor: nil ]. 20974 [ Sensor anyButtonPressed ] whileFalse: [ ]. 20975 Display newDepth: displayDepth 20976 20977 "BitBlt exampleOne"! ! 20978 20979!BitBlt class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 20980exampleTwo 20981 "This is to test painting with a gray tone. It also tests that the seaming with gray patterns is correct in the microcode. Lets you paint for a while and then automatically stops. This only works at Depth of 1." 20982 "create a small black Form source as a brush. " 20983 | f aBitBlt displayDepth | 20984 displayDepth := Display depth. 20985 Display newDepth: 1. 20986 f := Form extent: 20 @ 20. 20987 f fillBlack. 20988 "create a BitBlt which will OR gray into the display. " 20989 aBitBlt := BitBlt 20990 destForm: Display 20991 sourceForm: f 20992 fillColor: Color gray 20993 combinationRule: Form over 20994 destOrigin: Sensor cursorPoint 20995 sourceOrigin: 0 @ 0 20996 extent: f extent 20997 clipRect: Display computeBoundingBox. 20998 "paint the gray Form on the screen for a while. " 20999 [ Sensor anyButtonPressed ] whileFalse: 21000 [ aBitBlt destOrigin: Sensor cursorPoint. 21001 aBitBlt copyBits ]. 21002 Display newDepth: displayDepth 21003 "BitBlt exampleTwo"! ! 21004 21005 21006!BitBlt class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:04'! 21007asGrafPort 21008 "Return the GrafPort associated with the receiver" 21009 ^GrafPort! ! 21010 21011!BitBlt class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 21012bitPeekerFromForm: sourceForm 21013 "Answer an instance to be used extract individual pixels from the given Form. The destination for a 1x1 copyBits will be the low order bits of (bits at: 1)." 21014 | pixPerWord | 21015 pixPerWord := 32 // sourceForm depth. 21016 sourceForm unhibernate. 21017 ^ self 21018 destForm: (Form 21019 extent: pixPerWord @ 1 21020 depth: sourceForm depth) 21021 sourceForm: sourceForm 21022 halftoneForm: nil 21023 combinationRule: Form over 21024 destOrigin: (pixPerWord - 1) @ 0 21025 sourceOrigin: 0 @ 0 21026 extent: 1 @ 1 21027 clipRect: (0 @ 0 extent: pixPerWord @ 1)! ! 21028 21029!BitBlt class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 21030bitPokerToForm: destForm 21031 "Answer an instance to be used for valueAt: aPoint put: pixValue. 21032 The source for a 1x1 copyBits will be the low order of (bits at: 1)" 21033 | pixPerWord | 21034 pixPerWord := 32 // destForm depth. 21035 destForm unhibernate. 21036 ^ self 21037 destForm: destForm 21038 sourceForm: (Form 21039 extent: pixPerWord @ 1 21040 depth: destForm depth) 21041 halftoneForm: nil 21042 combinationRule: Form over 21043 destOrigin: 0 @ 0 21044 sourceOrigin: (pixPerWord - 1) @ 0 21045 extent: 1 @ 1 21046 clipRect: (0 @ 0 extent: destForm extent)! ! 21047 21048!BitBlt class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:00'! 21049current 21050 "Return the class currently to be used for BitBlt" 21051 ^Display defaultBitBltClass! ! 21052 21053!BitBlt class methodsFor: 'instance creation'! 21054destForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect 21055 "Answer an instance of me with values set according to the arguments." 21056 21057 ^ self new 21058 setDestForm: df 21059 sourceForm: sf 21060 fillColor: hf 21061 combinationRule: cr 21062 destOrigin: destOrigin 21063 sourceOrigin: sourceOrigin 21064 extent: extent 21065 clipRect: clipRect! ! 21066 21067!BitBlt class methodsFor: 'instance creation'! 21068destForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect 21069 "Answer an instance of me with values set according to the arguments." 21070 21071 ^ self new 21072 setDestForm: df 21073 sourceForm: sf 21074 fillColor: hf 21075 combinationRule: cr 21076 destOrigin: destOrigin 21077 sourceOrigin: sourceOrigin 21078 extent: extent 21079 clipRect: clipRect! ! 21080 21081!BitBlt class methodsFor: 'instance creation'! 21082toForm: aForm 21083 ^ self new setDestForm: aForm! ! 21084 21085 21086!BitBlt class methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 21087exampleAt: originPoint rule: rule fillColor: mask 21088 "This builds a source and destination form and copies the source to the 21089 destination using the specifed rule and mask. It is called from the method 21090 named exampleOne. Only works with Display depth of 1" 21091 | s d border aBitBlt | 21092 border := Form extent: 32 @ 32. 21093 border fillBlack. 21094 border 21095 fill: (1 @ 1 extent: 30 @ 30) 21096 fillColor: Color white. 21097 s := Form extent: 32 @ 32. 21098 s fillWhite. 21099 s fillBlack: (7 @ 7 corner: 25 @ 25). 21100 d := Form extent: 32 @ 32. 21101 d fillWhite. 21102 d fillBlack: (0 @ 0 corner: 32 @ 16). 21103 s 21104 displayOn: Display 21105 at: originPoint. 21106 border 21107 displayOn: Display 21108 at: originPoint 21109 rule: Form under. 21110 d 21111 displayOn: Display 21112 at: originPoint + (s width @ 0). 21113 border 21114 displayOn: Display 21115 at: originPoint + (s width @ 0) 21116 rule: Form under. 21117 d 21118 displayOn: Display 21119 at: originPoint + (s extent // (2 @ 1)). 21120 aBitBlt := BitBlt 21121 destForm: Display 21122 sourceForm: s 21123 fillColor: mask 21124 combinationRule: rule 21125 destOrigin: originPoint + (s extent // (2 @ 1)) 21126 sourceOrigin: 0 @ 0 21127 extent: s extent 21128 clipRect: Display computeBoundingBox. 21129 aBitBlt copyBits. 21130 border 21131 displayOn: Display 21132 at: originPoint + (s extent // (2 @ 1)) 21133 rule: Form under 21134 21135 "BitBlt exampleAt: 100@100 rule: 0 fillColor: nil"! ! 21136 21137!BitBlt class methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! 21138recreateColorMaps 21139 CachedFontColorMaps := ColorConvertingMaps := nil! ! 21140 21141 21142!BitBlt class methodsFor: 'class initialization' stamp: 'jmv 9/7/2009 09:32'! 21143initialize 21144 self recreateColorMaps! ! 21145TestCase subclass: #BitBltClipBugs 21146 instanceVariableNames: '' 21147 classVariableNames: '' 21148 poolDictionaries: '' 21149 category: 'Tests-Bugs'! 21150 21151!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! 21152testDrawingWayOutside 21153 | f1 bb f2 | 21154 f1 := Form extent: 100@100 depth: 1. 21155 f2 := Form extent: 100@100 depth: 1. 21156 bb := BitBlt toForm: f1. 21157 bb combinationRule: 3. 21158 bb sourceForm: f2. 21159 bb destOrigin: SmallInteger maxVal squared asPoint. 21160 bb width: 100; height: 100. 21161 self shouldnt:[bb copyBits] raise: Error. 21162! ! 21163 21164!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! 21165testDrawingWayOutside2 21166 | f1 bb f2 | 21167 f1 := Form extent: 100@100 depth: 1. 21168 f2 := Form extent: 100@100 depth: 1. 21169 bb := BitBlt toForm: f1. 21170 bb combinationRule: 3. 21171 bb sourceForm: f2. 21172 bb destOrigin: 0@0. 21173 bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. 21174 self shouldnt:[bb copyBits] raise: Error.! ! 21175 21176!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! 21177testDrawingWayOutside3 21178 | f1 bb f2 | 21179 f1 := Form extent: 100@100 depth: 1. 21180 f2 := Form extent: 100@100 depth: 1. 21181 bb := BitBlt toForm: f1. 21182 bb combinationRule: 3. 21183 bb sourceForm: f2. 21184 bb destOrigin: SmallInteger maxVal squared asPoint. 21185 bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. 21186 self shouldnt:[bb copyBits] raise: Error. 21187! ! 21188 21189!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! 21190testDrawingWayOutside4 21191 | f1 bb f2 | 21192 f1 := Form extent: 100@100 depth: 1. 21193 f2 := Form extent: 100@100 depth: 1. 21194 bb := BitBlt toForm: f1. 21195 bb combinationRule: 3. 21196 bb sourceForm: f2. 21197 bb destOrigin: SmallInteger maxVal squared asPoint. 21198 bb width: 100; height: 100. 21199 bb sourceOrigin: SmallInteger maxVal squared asPoint. 21200 self shouldnt:[bb copyBits] raise: Error. 21201! ! 21202 21203!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! 21204testDrawingWayOutside5 21205 | f1 bb f2 | 21206 f1 := Form extent: 100@100 depth: 1. 21207 f2 := Form extent: 100@100 depth: 1. 21208 bb := BitBlt toForm: f1. 21209 bb combinationRule: 3. 21210 bb sourceForm: f2. 21211 bb destOrigin: 0@0. 21212 bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. 21213 bb sourceOrigin: SmallInteger maxVal squared asPoint. 21214 self shouldnt:[bb copyBits] raise: Error.! ! 21215 21216!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! 21217testDrawingWayOutside6 21218 | f1 bb f2 | 21219 f1 := Form extent: 100@100 depth: 1. 21220 f2 := Form extent: 100@100 depth: 1. 21221 bb := BitBlt toForm: f1. 21222 bb combinationRule: 3. 21223 bb sourceForm: f2. 21224 bb destOrigin: SmallInteger maxVal squared asPoint. 21225 bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. 21226 bb sourceOrigin: SmallInteger maxVal squared asPoint. 21227 self shouldnt:[bb copyBits] raise: Error. 21228! ! 21229 21230!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! 21231testFillingWayOutside 21232 | f1 bb | 21233 f1 := Form extent: 100@100 depth: 1. 21234 bb := BitBlt toForm: f1. 21235 bb combinationRule: 3. 21236 bb fillColor: Color black. 21237 bb destOrigin: SmallInteger maxVal squared asPoint. 21238 bb width: 100; height: 100. 21239 self shouldnt:[bb copyBits] raise: Error. 21240! ! 21241 21242!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! 21243testFillingWayOutside2 21244 | f1 bb | 21245 f1 := Form extent: 100@100 depth: 1. 21246 bb := BitBlt toForm: f1. 21247 bb combinationRule: 3. 21248 bb fillColor: Color black. 21249 bb destOrigin: 0@0. 21250 bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. 21251 self shouldnt:[bb copyBits] raise: Error.! ! 21252 21253!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! 21254testFillingWayOutside3 21255 | f1 bb | 21256 f1 := Form extent: 100@100 depth: 1. 21257 bb := BitBlt toForm: f1. 21258 bb combinationRule: 3. 21259 bb fillColor: Color black. 21260 bb destOrigin: SmallInteger maxVal squared asPoint. 21261 bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. 21262 self shouldnt:[bb copyBits] raise: Error. 21263! ! 21264ClassTestCase subclass: #BitBltTest 21265 instanceVariableNames: '' 21266 classVariableNames: '' 21267 poolDictionaries: '' 21268 category: 'GraphicsTests-Primitives'! 21269 21270!BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:12'! 21271testAlphaCompositing 21272 "self run: #testAlphaCompositing" 21273 21274 | bb f1 f2 mixColor result eps | 21275 f1 := Form extent: 1@1 depth: 32. 21276 f2 := Form extent: 1@1 depth: 32. 21277 eps := 0.5 / 255. 21278 0 to: 255 do:[:i| 21279 f1 colorAt: 0@0 put: Color blue. 21280 mixColor := Color red alpha: i / 255.0. 21281 f2 colorAt: 0@0 put: mixColor. 21282 mixColor := f2 colorAt: 0@0. 21283 bb := BitBlt toForm: f1. 21284 bb sourceForm: f2. 21285 bb combinationRule: Form blend. 21286 bb copyBits. 21287 result := f1 colorAt: 0@0. 21288 self assert: (result red - mixColor alpha) abs < eps. 21289 self assert: (result blue - (1.0 - mixColor alpha)) abs < eps. 21290 self assert: result alpha = 1.0. 21291 ].! ! 21292 21293!BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:12'! 21294testAlphaCompositing2 21295 "self run: #testAlphaCompositing2" 21296 21297 | bb f1 f2 mixColor result eps | 21298 f1 := Form extent: 1@1 depth: 32. 21299 f2 := Form extent: 1@1 depth: 32. 21300 eps := 0.5 / 255. 21301 0 to: 255 do:[:i| 21302 f1 colorAt: 0@0 put: Color transparent. 21303 mixColor := Color red alpha: i / 255.0. 21304 f2 colorAt: 0@0 put: mixColor. 21305 mixColor := f2 colorAt: 0@0. 21306 bb := BitBlt toForm: f1. 21307 bb sourceForm: f2. 21308 bb combinationRule: Form blend. 21309 bb copyBits. 21310 result := f1 colorAt: 0@0. 21311 self assert: (result red - mixColor alpha) abs < eps. 21312 self assert: result alpha = mixColor alpha. 21313 ].! ! 21314 21315!BitBltTest methodsFor: 'bugs' stamp: 'NorbertHartl 6/20/2008 21:37'! 21316testAlphaCompositing2Simulated 21317 "self run: #testAlphaCompositing2Simulated" 21318 21319 | bb f1 f2 mixColor result eps | 21320 Smalltalk at: #BitBltSimulation ifPresent: [:bitblt| 21321 f1 := Form extent: 1@1 depth: 32. 21322 f2 := Form extent: 1@1 depth: 32. 21323 eps := 0.5 / 255. 21324 0 to: 255 do:[:i| 21325 f1 colorAt: 0@0 put: Color transparent. 21326 mixColor := Color red alpha: i / 255.0. 21327 f2 colorAt: 0@0 put: mixColor. 21328 mixColor := f2 colorAt: 0@0. 21329 bb := BitBlt toForm: f1. 21330 bb sourceForm: f2. 21331 bb combinationRule: Form blend. 21332 result := f1 colorAt: 0@0. 21333 self assert: (result red - mixColor alpha) abs < eps. 21334 self assert: result alpha = mixColor alpha. 21335 ].]! ! 21336 21337!BitBltTest methodsFor: 'bugs' stamp: 'NorbertHartl 6/20/2008 21:37'! 21338testAlphaCompositingSimulated 21339 "self run: #testAlphaCompositingSimulated" 21340 21341 | bb f1 f2 mixColor result eps | 21342 Smalltalk at: #BitBltSimulation ifPresent:[:bitblt| 21343 21344 f1 := Form extent: 1@1 depth: 32. 21345 f2 := Form extent: 1@1 depth: 32. 21346 eps := 0.5 / 255. 21347 0 to: 255 do:[:i| 21348 f1 colorAt: 0@0 put: Color blue. 21349 mixColor := Color red alpha: i / 255.0. 21350 f2 colorAt: 0@0 put: mixColor. 21351 mixColor := f2 colorAt: 0@0. 21352 bb := BitBlt toForm: f1. 21353 bb sourceForm: f2. 21354 bb combinationRule: Form blend. 21355 result := f1 colorAt: 0@0. 21356 self assert: (result red - mixColor alpha) abs < eps. 21357 self assert: (result blue - (1.0 - mixColor alpha)) abs < eps. 21358 self assert: result alpha = 1.0. 21359 ]].! ! 21360 21361!BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:13'! 21362testPeekerUnhibernateBug 21363 "self run: #testPeekerUnhibernateBug" 21364 21365 | bitBlt | 21366 bitBlt := BitBlt bitPeekerFromForm: Display. 21367 bitBlt destForm hibernate. 21368 self shouldnt:[bitBlt pixelAt: 1@1] raise: Error.! ! 21369 21370!BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:14'! 21371testPokerUnhibernateBug 21372 "self run: #testPokerUnhibernateBug" 21373 21374 | bitBlt | 21375 bitBlt := BitBlt bitPokerToForm: Display. 21376 bitBlt sourceForm hibernate. 21377 self shouldnt:[bitBlt pixelAt: 1@1 put: 0] raise: Error.! ! 21378ArrayedCollection variableWordSubclass: #Bitmap 21379 instanceVariableNames: '' 21380 classVariableNames: '' 21381 poolDictionaries: '' 21382 category: 'Graphics-Primitives'! 21383!Bitmap commentStamp: '<historical>' prior: 0! 21384My instances provide contiguous storage of bits, primarily to hold the graphical data of Forms. Forms and their subclasses provide the additional structural information as to how the bits should be interpreted in two dimensions.! 21385 21386 21387!Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:11'! 21388atAllPut: value 21389 "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays." 21390 <primitive: 145> 21391 super atAllPut: value.! ! 21392 21393!Bitmap methodsFor: 'accessing'! 21394bitPatternForDepth: depth 21395 "The raw call on BitBlt needs a Bitmap to represent this color. I already am Bitmap like. I am already adjusted for a specific depth. Interpret me as an array of (32/depth) Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk" 21396 21397 ^ self! ! 21398 21399!Bitmap methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 21400byteAt: byteAddress 21401 "Extract a byte from a Bitmap. Note that this is a byte address and it is one-order. For repeated use, create an instance of BitBlt and use pixelAt:. See Form pixelAt: 7/1/96 tk" 21402 | lowBits | 21403 lowBits := byteAddress - 1 bitAnd: 3. 21404 ^ ((self at: (byteAddress - 1 - lowBits) // 4 + 1) bitShift: (lowBits - 3) * 8) bitAnd: 255! ! 21405 21406!Bitmap methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 21407byteAt: byteAddress put: byte 21408 "Insert a byte into a Bitmap. Note that this is a byte address and it is one-order. For repeated use, create an instance of BitBlt and use pixelAt:put:. See Form pixelAt:put: 7/1/96 tk" 21409 | longWord shift lowBits longAddr | 21410 (byte < 0 or: [ byte > 255 ]) ifTrue: [ ^ self errorImproperStore ]. 21411 lowBits := byteAddress - 1 bitAnd: 3. 21412 longWord := self at: (longAddr := (byteAddress - 1 - lowBits) // 4 + 1). 21413 shift := (3 - lowBits) * 8. 21414 longWord := longWord - (longWord bitAnd: (255 bitShift: shift)) + (byte bitShift: shift). 21415 self 21416 at: longAddr 21417 put: longWord. 21418 ^ byte! ! 21419 21420!Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:18'! 21421byteSize 21422 ^self size * 4! ! 21423 21424!Bitmap methodsFor: 'accessing' stamp: 'nk 7/30/2004 17:53'! 21425copyFromByteArray: byteArray 21426 "This method should work with either byte orderings" 21427 21428 | myHack byteHack | 21429 myHack := Form new hackBits: self. 21430 byteHack := Form new hackBits: byteArray. 21431 SmalltalkImage current isLittleEndian ifTrue: [byteHack swapEndianness]. 21432 byteHack displayOn: myHack! ! 21433 21434!Bitmap methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! 21435defaultElement 21436 "Return the default element of the receiver" 21437 ^0! ! 21438 21439!Bitmap methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 21440integerAt: index 21441 "Return the integer at the given index" 21442 | word | 21443 <primitive: 165> 21444 word := self basicAt: index. 21445 word < 1073741823 ifTrue: [ ^ word ]. "Avoid LargeInteger computations" 21446 ^ word >= 2147483648 21447 ifTrue: 21448 [ "Negative?!!" 21449 "word - 16r100000000" 21450 (word bitInvert32 + 1) negated ] 21451 ifFalse: [ word ]! ! 21452 21453!Bitmap methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 21454integerAt: index put: anInteger 21455 "Store the integer at the given index" 21456 | word | 21457 <primitive: 166> 21458 anInteger < 0 21459 ifTrue: 21460 [ "word _ 16r100000000 + anInteger" 21461 word := (anInteger + 1) negated bitInvert32 ] 21462 ifFalse: [ word := anInteger ]. 21463 self 21464 basicAt: index 21465 put: word. 21466 ^ anInteger! ! 21467 21468!Bitmap methodsFor: 'accessing' stamp: 'tk 3/15/97'! 21469pixelValueForDepth: depth 21470 "Self is being used to represent a single color. Answer bits that appear in ONE pixel of this color in a Bitmap of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Returns an integer. First pixel only. " 21471 21472 ^ (self at: 1) bitAnd: (1 bitShift: depth) - 1! ! 21473 21474!Bitmap methodsFor: 'accessing'! 21475primFill: aPositiveInteger 21476 "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays." 21477 21478 <primitive: 145> 21479 self errorImproperStore.! ! 21480 21481!Bitmap methodsFor: 'accessing'! 21482replaceFrom: start to: stop with: replacement startingAt: repStart 21483 "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." 21484 <primitive: 105> 21485 super replaceFrom: start to: stop with: replacement startingAt: repStart! ! 21486 21487 21488!Bitmap methodsFor: 'as yet unclassified' stamp: 'lr 7/4/2009 10:42'! 21489asByteArray 21490 "Faster way to make a byte array from me. 21491 copyFromByteArray: makes equal Bitmap." 21492 | f bytes hack | 21493 f := Form 21494 extent: 4 @ self size 21495 depth: 8 21496 bits: self. 21497 bytes := ByteArray new: self size * 4. 21498 hack := Form new hackBits: bytes. 21499 SmalltalkImage current isLittleEndian ifTrue: [ hack swapEndianness ]. 21500 hack 21501 copyBits: f boundingBox 21502 from: f 21503 at: 0 @ 0 21504 clippingBox: hack boundingBox 21505 rule: Form over 21506 fillColor: nil 21507 map: nil. 21508 21509 "f displayOn: hack." 21510 ^ bytes! ! 21511 21512!Bitmap methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 21:51'! 21513copy 21514 21515 ^self clone! ! 21516 21517 21518!Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! 21519compress: bm toByteArray: ba 21520 "Store a run-coded compression of the receiver into the byteArray ba, 21521 and return the last index stored into. ba is assumed to be large enough. 21522 The encoding is as follows... 21523 S {N D}*. 21524 S is the size of the original bitmap, followed by run-coded pairs. 21525 N is a run-length * 4 + data code. 21526 D, the data, depends on the data code... 21527 0 skip N words, D is absent 21528 1 N words with all 4 bytes = D (1 byte) 21529 2 N words all = D (4 bytes) 21530 3 N words follow in D (4N bytes) 21531 S and N are encoded as follows... 21532 0-223 0-223 21533 224-254 (0-30)*256 + next byte (0-7935) 21534 255 next 4 bytes" 21535 | size k word j lowByte eqBytes i | 21536 <primitive: 'primitiveCompressToByteArray' module: 'MiscPrimitivePlugin'> 21537 self 21538 var: #bm 21539 declareC: 'int *bm'. 21540 self 21541 var: #ba 21542 declareC: 'unsigned char *ba'. 21543 size := bm size. 21544 i := self 21545 encodeInt: size 21546 in: ba 21547 at: 1. 21548 k := 1. 21549 [ k <= size ] whileTrue: 21550 [ word := bm at: k. 21551 lowByte := word bitAnd: 255. 21552 eqBytes := (word >> 8 bitAnd: 255) = lowByte and: 21553 [ (word >> 16 bitAnd: 255) = lowByte and: [ (word >> 24 bitAnd: 255) = lowByte ] ]. 21554 j := k. 21555 [ j < size and: [ word = (bm at: j + 1) ] "scan for = words..." ] whileTrue: [ j := j + 1 ]. 21556 j > k 21557 ifTrue: 21558 [ "We have two or more = words, ending at j" 21559 eqBytes 21560 ifTrue: 21561 [ "Actually words of = bytes" 21562 i := self 21563 encodeInt: (j - k + 1) * 4 + 1 21564 in: ba 21565 at: i. 21566 ba 21567 at: i 21568 put: lowByte. 21569 i := i + 1 ] 21570 ifFalse: 21571 [ i := self 21572 encodeInt: (j - k + 1) * 4 + 2 21573 in: ba 21574 at: i. 21575 i := self 21576 encodeBytesOf: word 21577 in: ba 21578 at: i ]. 21579 k := j + 1 ] 21580 ifFalse: 21581 [ "Check for word of 4 = bytes" 21582 eqBytes 21583 ifTrue: 21584 [ "Note 1 word of 4 = bytes" 21585 i := self 21586 encodeInt: 1 * 4 + 1 21587 in: ba 21588 at: i. 21589 ba 21590 at: i 21591 put: lowByte. 21592 i := i + 1. 21593 k := k + 1 ] 21594 ifFalse: 21595 [ "Finally, check for junk" 21596 [ j < size and: [ (bm at: j) ~= (bm at: j + 1) ] "scan for ~= words..." ] whileTrue: [ j := j + 1 ]. 21597 j = size ifTrue: [ j := j + 1 ]. 21598 "We have one or more unmatching words, ending at j-1" 21599 i := self 21600 encodeInt: (j - k) * 4 + 3 21601 in: ba 21602 at: i. 21603 k 21604 to: j - 1 21605 do: 21606 [ :m | 21607 i := self 21608 encodeBytesOf: (bm at: m) 21609 in: ba 21610 at: i ]. 21611 k := j ] ] ]. 21612 ^ i - 1 "number of bytes actually stored" 21613 " 21614Space check: 21615 | n rawBytes myBytes b | 21616n _ rawBytes _ myBytes _ 0. 21617Form allInstancesDo: 21618 [:f | f unhibernate. 21619 b _ f bits. 21620 n _ n + 1. 21621 rawBytes _ rawBytes + (b size*4). 21622 myBytes _ myBytes + (b compressToByteArray size). 21623 f hibernate]. 21624Array with: n with: rawBytes with: myBytes 21625ColorForms: (116 230324 160318 ) 21626Forms: (113 1887808 1325055 ) 21627 21628Integerity check: 21629Form allInstances do: 21630 [:f | f unhibernate. 21631 f bits = (Bitmap decompressFromByteArray: f bits compressToByteArray) 21632 ifFalse: [self halt]. 21633 f hibernate] 21634 21635Speed test: 21636MessageTally spyOn: [Form allInstances do: 21637 [:f | Bitmap decompressFromByteArray: f bits compressToByteArray]] 21638"! ! 21639 21640!Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! 21641compressGZip 21642 "just hacking around to see if further compression would help Nebraska" 21643 | ba hackwa hackba blt rowsAtATime sourceOrigin rowsRemaining bufferStream gZipStream | 21644 bufferStream := RWBinaryOrTextStream on: (ByteArray new: 5000). 21645 gZipStream := GZipWriteStream on: bufferStream. 21646 ba := nil. 21647 rowsAtATime := 20000. "or 80000 bytes" 21648 hackwa := Form new hackBits: self. 21649 sourceOrigin := 0 @ 0. 21650 [ (rowsRemaining := hackwa height - sourceOrigin y) > 0 ] whileTrue: 21651 [ rowsAtATime := rowsAtATime min: rowsRemaining. 21652 (ba isNil or: [ ba size ~= (rowsAtATime * 4) ]) ifTrue: 21653 [ ba := ByteArray new: rowsAtATime * 4. 21654 hackba := Form new hackBits: ba. 21655 blt := (BitBlt toForm: hackba) sourceForm: hackwa ]. 21656 blt 21657 combinationRule: Form over; 21658 sourceOrigin: sourceOrigin; 21659 destX: 0 21660 destY: 0 21661 width: 4 21662 height: rowsAtATime; 21663 copyBits. 21664 "bufferStream nextPutAll: ba." 21665 sourceOrigin := sourceOrigin x @ (sourceOrigin y + rowsAtATime) ]. 21666 gZipStream close. 21667 ^ bufferStream contents! ! 21668 21669!Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! 21670compressToByteArray 21671 "Return a run-coded compression of this bitmap into a byteArray" 21672 "Without skip codes, it is unlikely that the compressed bitmap will be any larger than was the original. The run-code cases are... 21673 N >= 1 words of equal bytes: 4N bytes -> 2 bytes (at worst 4 -> 2) 21674 N > 1 equal words: 4N bytes -> 5 bytes (at worst 8 -> 5) 21675 N > 1 unequal words: 4N bytes -> 4N + M, where M is the number of bytes required to encode the run length. 21676 21677The worst that can happen is that the method begins with unequal words, and than has interspersed occurrences of a word with equal bytes. Thus we require a run-length at the beginning, and after every interspersed word of equal bytes. However, each of these saves 2 bytes, so it must be followed by a run of 1984 (7936//4) or more (for which M jumps from 2 to 5) to add any extra overhead. Therefore the worst case is a series of runs of 1984 or more, with single interspersed words of equal bytes. At each break we save 2 bytes, but add 5. Thus the overhead would be no more than 5 (encoded size) + 2 (first run len) + (S//1984*3)." 21678 "NOTE: This code is copied in Form hibernate for reasons given there." 21679 | byteArray lastByte | 21680 byteArray := ByteArray new: self size * 4 + 7 + (self size // 1984 * 3). 21681 lastByte := self 21682 compress: self 21683 toByteArray: byteArray. 21684 ^ byteArray 21685 copyFrom: 1 21686 to: lastByte! ! 21687 21688!Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! 21689decompress: bm fromByteArray: ba at: index 21690 "Decompress the body of a byteArray encoded by compressToByteArray (qv)... 21691 The format is simply a sequence of run-coded pairs, {N D}*. 21692 N is a run-length * 4 + data code. 21693 D, the data, depends on the data code... 21694 0 skip N words, D is absent 21695 (could be used to skip from one raster line to the next) 21696 1 N words with all 4 bytes = D (1 byte) 21697 2 N words all = D (4 bytes) 21698 3 N words follow in D (4N bytes) 21699 S and N are encoded as follows (see decodeIntFrom:)... 21700 0-223 0-223 21701 224-254 (0-30)*256 + next byte (0-7935) 21702 255 next 4 bytes" 21703 "NOTE: If fed with garbage, this routine could read past the end of ba, but it should fail before writing past the ned of bm." 21704 | i code n anInt data end k pastEnd | 21705 <primitive: 'primitiveDecompressFromByteArray' module: 'MiscPrimitivePlugin'> 21706 self 21707 var: #bm 21708 declareC: 'int *bm'. 21709 self 21710 var: #ba 21711 declareC: 'unsigned char *ba'. 21712 i := index. "byteArray read index" 21713 end := ba size. 21714 k := 1. "bitmap write index" 21715 pastEnd := bm size + 1. 21716 [ i <= end ] whileTrue: 21717 [ "Decode next run start N" 21718 anInt := ba at: i. 21719 i := i + 1. 21720 anInt <= 223 ifFalse: 21721 [ anInt <= 254 21722 ifTrue: 21723 [ anInt := (anInt - 224) * 256 + (ba at: i). 21724 i := i + 1 ] 21725 ifFalse: 21726 [ anInt := 0. 21727 1 21728 to: 4 21729 do: 21730 [ :j | 21731 anInt := (anInt bitShift: 8) + (ba at: i). 21732 i := i + 1 ] ] ]. 21733 n := anInt >> 2. 21734 k + n > pastEnd ifTrue: [ ^ self primitiveFailed ]. 21735 code := anInt bitAnd: 3. 21736 code = 0 ifTrue: 21737 [ "skip" 21738 ]. 21739 code = 1 ifTrue: 21740 [ "n consecutive words of 4 bytes = the following byte" 21741 data := ba at: i. 21742 i := i + 1. 21743 data := data bitOr: (data bitShift: 8). 21744 data := data bitOr: (data bitShift: 16). 21745 1 21746 to: n 21747 do: 21748 [ :j | 21749 bm 21750 at: k 21751 put: data. 21752 k := k + 1 ] ]. 21753 code = 2 ifTrue: 21754 [ "n consecutive words = 4 following bytes" 21755 data := 0. 21756 1 21757 to: 4 21758 do: 21759 [ :j | 21760 data := (data bitShift: 8) bitOr: (ba at: i). 21761 i := i + 1 ]. 21762 1 21763 to: n 21764 do: 21765 [ :j | 21766 bm 21767 at: k 21768 put: data. 21769 k := k + 1 ] ]. 21770 code = 3 ifTrue: 21771 [ "n consecutive words from the data..." 21772 1 21773 to: n 21774 do: 21775 [ :m | 21776 data := 0. 21777 1 21778 to: 4 21779 do: 21780 [ :j | 21781 data := (data bitShift: 8) bitOr: (ba at: i). 21782 i := i + 1 ]. 21783 bm 21784 at: k 21785 put: data. 21786 k := k + 1 ] ] ]! ! 21787 21788!Bitmap methodsFor: 'filing' stamp: 'jm 2/15/98 17:27'! 21789encodeBytesOf: anInt in: ba at: i 21790 "Copy the integer anInt into byteArray ba at index i, and return the next index" 21791 21792 self inline: true. 21793 self var: #ba declareC: 'unsigned char *ba'. 21794 0 to: 3 do: 21795 [:j | ba at: i+j put: (anInt >> (3-j*8) bitAnd: 16rFF)]. 21796 ^ i+4! ! 21797 21798!Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! 21799encodeInt: int 21800 "Encode the integer int as per encodeInt:in:at:, and return it as a ByteArray" 21801 | byteArray next | 21802 byteArray := ByteArray new: 5. 21803 next := self 21804 encodeInt: int 21805 in: byteArray 21806 at: 1. 21807 ^ byteArray 21808 copyFrom: 1 21809 to: next - 1! ! 21810 21811!Bitmap methodsFor: 'filing' stamp: 'jm 2/15/98 17:26'! 21812encodeInt: anInt in: ba at: i 21813 "Encode the integer anInt in byteArray ba at index i, and return the next index. 21814 The encoding is as follows... 21815 0-223 0-223 21816 224-254 (0-30)*256 + next byte (0-7935) 21817 255 next 4 bytes" 21818 21819 self inline: true. 21820 self var: #ba declareC: 'unsigned char *ba'. 21821 anInt <= 223 ifTrue: [ba at: i put: anInt. ^ i+1]. 21822 anInt <= 7935 ifTrue: [ba at: i put: anInt//256+224. ba at: i+1 put: anInt\\256. ^ i+2]. 21823 ba at: i put: 255. 21824 ^ self encodeBytesOf: anInt in: ba at: i+1! ! 21825 21826!Bitmap methodsFor: 'filing' stamp: 'PeterHugossonMiller 9/3/2009 00:15'! 21827readCompressedFrom: strm 21828 "Decompress an old-style run-coded stream into this bitmap: 21829 [0 means end of runs] 21830 [n = 1..127] [(n+3) copies of next byte] 21831 [n = 128..191] [(n-127) next bytes as is] 21832 [n = 192..255] [(n-190) copies of next 4 bytes]" 21833 | n byte out outBuff bytes | 21834 out := (outBuff := ByteArray new: self size * 4) writeStream. 21835 [ (n := strm next) > 0 ] whileTrue: 21836 [ (n 21837 between: 1 21838 and: 127) ifTrue: 21839 [ byte := strm next. 21840 1 21841 to: n + 3 21842 do: [ :i | out nextPut: byte ] ]. 21843 (n 21844 between: 128 21845 and: 191) ifTrue: 21846 [ 1 21847 to: n - 127 21848 do: [ :i | out nextPut: strm next ] ]. 21849 (n 21850 between: 192 21851 and: 255) ifTrue: 21852 [ bytes := (1 to: 4) collect: [ :i | strm next ]. 21853 1 21854 to: n - 190 21855 do: [ :i | bytes do: [ :b | out nextPut: b ] ] ] ]. 21856 out position = outBuff size ifFalse: [ self error: 'Decompression size error' ]. 21857 "Copy the final byteArray into self" 21858 self copyFromByteArray: outBuff! ! 21859 21860!Bitmap methodsFor: 'filing' stamp: 'tk 1/24/2000 22:37'! 21861restoreEndianness 21862 "This word object was just read in from a stream. Bitmaps are always compressed and serialized in a machine-independent way. Do not correct the Endianness." 21863 21864 "^ self" 21865! ! 21866 21867!Bitmap methodsFor: 'filing' stamp: 'nk 12/31/2003 16:02'! 21868storeBits: startBit to: stopBit on: aStream 21869 "Store my bits as a hex string, breaking the lines every 100 bytes or 21870 so to comply with the maximum line length limits of Postscript (255 21871 bytes). " 21872 | lineWidth | 21873 lineWidth := 0. 21874 self 21875 do: [:word | 21876 startBit 21877 to: stopBit 21878 by: -4 21879 do: [:shift | 21880 aStream nextPut: (word >> shift bitAnd: 15) asHexDigit. 21881 lineWidth := lineWidth + 1]. 21882 (lineWidth > 100) 21883 ifTrue: [aStream cr. 21884 lineWidth := 0]]. 21885 lineWidth > 0 ifTrue: [ aStream cr ].! ! 21886 21887!Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! 21888writeOn: aStream 21889 "Store the array of bits onto the argument, aStream. A leading byte of 16r80 identifies this as compressed by compressToByteArray (qv)." 21890 | b | 21891 aStream nextPut: 128. 21892 b := self compressToByteArray. 21893 aStream 21894 nextPutAll: (self encodeInt: b size); 21895 nextPutAll: b! ! 21896 21897!Bitmap methodsFor: 'filing' stamp: 'tk 2/19/1999 07:36'! 21898writeUncompressedOn: aStream 21899 "Store the array of bits onto the argument, aStream. 21900 (leading byte ~= 16r80) identifies this as raw bits (uncompressed)." 21901 21902 aStream nextInt32Put: self size. 21903 aStream nextPutAll: self 21904! ! 21905 21906 21907!Bitmap methodsFor: 'initialization' stamp: 'ar 12/23/1999 14:35'! 21908fromByteStream: aStream 21909 "Initialize the array of bits by reading integers from the argument, 21910 aStream." 21911 aStream nextWordsInto: self! ! 21912 21913 21914!Bitmap methodsFor: 'printing' stamp: 'sma 6/1/2000 09:42'! 21915printOn: aStream 21916 self printNameOn: aStream. 21917 aStream nextPutAll: ' of length '; print: self size! ! 21918 21919!Bitmap methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:00'! 21920printOnStream: aStream 21921 21922 aStream print: 'a Bitmap of length '; write:self size. 21923! ! 21924 21925 21926!Bitmap methodsFor: 'testing' stamp: 'ar 5/25/2000 19:42'! 21927isColormap 21928 "Bitmaps were used as color maps for BitBlt. 21929 This method allows to recognize real color maps." 21930 ^false! ! 21931 21932"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 21933 21934Bitmap class 21935 instanceVariableNames: ''! 21936 21937!Bitmap class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 21938decodeIntFrom: s 21939 "Decode an integer in stream s as follows... 21940 0-223 0-223 21941 224-254 (0-30)*256 + next byte (0-7935) 21942 255 next 4 bytes " 21943 | int | 21944 int := s next. 21945 int <= 223 ifTrue: [ ^ int ]. 21946 int <= 254 ifTrue: [ ^ (int - 224) * 256 + s next ]. 21947 int := s next. 21948 1 21949 to: 3 21950 do: [ :j | int := (int bitShift: 8) + s next ]. 21951 ^ int! ! 21952 21953!Bitmap class methodsFor: 'instance creation' stamp: 'damiencassou 5/30/2008 14:51'! 21954decompressFromByteArray: byteArray 21955 | s bitmap size | 21956 s := byteArray readStream. 21957 size := self decodeIntFrom: s. 21958 bitmap := self new: size. 21959 bitmap 21960 decompress: bitmap 21961 fromByteArray: byteArray 21962 at: s position + 1. 21963 ^ bitmap! ! 21964 21965!Bitmap class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 21966newFromStream: s 21967 | len | 21968 s next = 128 ifTrue: 21969 [ "New compressed format" 21970 len := self decodeIntFrom: s. 21971 ^ Bitmap decompressFromByteArray: (s nextInto: (ByteArray new: len)) ]. 21972 s skip: -1. 21973 len := s nextInt32. 21974 len <= 0 21975 ifTrue: 21976 [ "Old compressed format" 21977 ^ (self new: len negated) readCompressedFrom: s ] 21978 ifFalse: 21979 [ "Old raw data format" 21980 ^ s nextWordsInto: (self new: len) ]! ! 21981 21982 21983!Bitmap class methodsFor: 'utilities' stamp: 'lr 7/4/2009 10:42'! 21984swapBytesIn: aNonPointerThing from: start to: stop 21985 "Perform a bigEndian/littleEndian byte reversal of my words. 21986 We only intend this for non-pointer arrays. Do nothing if I contain pointers." 21987 "The implementation is a hack, but fast for large ranges" 21988 | hack blt | 21989 hack := Form new hackBits: aNonPointerThing. 21990 blt := (BitBlt toForm: hack) sourceForm: hack. 21991 blt combinationRule: Form reverse. "XOR" 21992 blt 21993 sourceY: start - 1; 21994 destY: start - 1; 21995 height: stop - start + 1; 21996 width: 1. 21997 blt 21998 sourceX: 0; 21999 destX: 3; 22000 copyBits. "Exchange bytes 0 and 3" 22001 blt 22002 sourceX: 3; 22003 destX: 0; 22004 copyBits. 22005 blt 22006 sourceX: 0; 22007 destX: 3; 22008 copyBits. 22009 blt 22010 sourceX: 1; 22011 destX: 2; 22012 copyBits. "Exchange bytes 1 and 2" 22013 blt 22014 sourceX: 2; 22015 destX: 1; 22016 copyBits. 22017 blt 22018 sourceX: 1; 22019 destX: 2; 22020 copyBits! ! 22021TestCase subclass: #BitmapBugz 22022 instanceVariableNames: '' 22023 classVariableNames: '' 22024 poolDictionaries: '' 22025 category: 'Tests-Bugs'! 22026 22027!BitmapBugz methodsFor: 'as yet unclassified' stamp: 'ar 8/2/2003 19:21'! 22028testBitmapByteAt 22029 | bm | 22030 bm := Bitmap new: 1. 22031 1 to: 4 do:[:i| 22032 self should:[bm byteAt: i put: 1000] raise: Error. 22033 ].! ! 22034OrientedFillStyle subclass: #BitmapFillStyle 22035 instanceVariableNames: 'form tileFlag' 22036 classVariableNames: '' 22037 poolDictionaries: '' 22038 category: 'Balloon-Fills'! 22039!BitmapFillStyle commentStamp: '<historical>' prior: 0! 22040A BitmapFillStyle fills using any kind of form. 22041 22042Instance variables: 22043 form <Form> The form to be used as fill. 22044 tileFlag <Boolean> If true, then the form is repeatedly drawn to fill the area.! 22045 22046 22047!BitmapFillStyle methodsFor: '*morphic-balloon' stamp: 'wiz 8/30/2003 16:54'! 22048grabNewGraphicIn: aMorph event: evt 22049 "Used by any morph that can be represented by a graphic" 22050 | fill | 22051 fill := Form fromUser. 22052 fill boundingBox area = 0 22053 ifTrue: [^ self]. 22054 self form: fill. 22055 self direction: fill width @ 0. 22056 self normal: 0 @ fill height. 22057 aMorph changed! ! 22058 22059!BitmapFillStyle methodsFor: '*morphic-balloon' stamp: 'ar 6/25/1999 11:57'! 22060newForm: aForm forMorph: aMorph 22061 self form: aForm. 22062 self direction: (aForm width @ 0). 22063 self normal: (0 @ aForm height). 22064 aMorph changed.! ! 22065 22066 22067!BitmapFillStyle methodsFor: 'accessing' stamp: 'wiz 1/16/2005 20:17'! 22068direction 22069 22070 22071 22072 ^direction ifNil:[direction :=( (normal y @ normal x negated) * form width / form height ) rounded]! ! 22073 22074!BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:40'! 22075form 22076 ^form! ! 22077 22078!BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:40'! 22079form: aForm 22080 form := aForm! ! 22081 22082!BitmapFillStyle methodsFor: 'accessing' stamp: 'wiz 1/16/2005 20:18'! 22083normal 22084 ^normal ifNil:[normal := ((direction y negated @ direction x) * form height / form width ) rounded]! ! 22085 22086!BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/27/1998 14:37'! 22087tileFlag 22088 ^tileFlag! ! 22089 22090!BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/27/1998 14:30'! 22091tileFlag: aBoolean 22092 tileFlag := aBoolean! ! 22093 22094 22095!BitmapFillStyle methodsFor: 'converting' stamp: 'ar 11/11/1998 22:41'! 22096asColor 22097 ^form colorAt: 0@0! ! 22098 22099 22100!BitmapFillStyle methodsFor: 'testing' stamp: 'ar 11/11/1998 22:40'! 22101isBitmapFill 22102 ^true! ! 22103 22104!BitmapFillStyle methodsFor: 'testing' stamp: 'ar 11/27/1998 14:37'! 22105isTiled 22106 "Return true if the receiver should be repeated if the fill shape is larger than the form" 22107 ^tileFlag == true! ! 22108 22109"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 22110 22111BitmapFillStyle class 22112 instanceVariableNames: ''! 22113 22114!BitmapFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/13/1998 20:32'! 22115form: aForm 22116 ^self new form: aForm! ! 22117 22118!BitmapFillStyle class methodsFor: 'instance creation' stamp: 'KLC 1/27/2004 13:33'! 22119fromForm: aForm 22120 | fs | 22121 fs := self form: aForm. 22122 fs origin: 0@0. 22123 fs direction: aForm width @ 0. 22124 fs normal: 0 @ aForm height. 22125 fs tileFlag: true. 22126 ^fs! ! 22127 22128!BitmapFillStyle class methodsFor: 'instance creation' stamp: 'ar 6/18/1999 07:09'! 22129fromUser 22130 | fill | 22131 fill := self form: Form fromUser. 22132 fill origin: 0@0. 22133 fill direction: fill form width @ 0. 22134 fill normal: 0 @ fill form height. 22135 fill tileFlag: true. "So that we can fill arbitrary objects" 22136 ^fill! ! 22137TestCase subclass: #BitmapStreamTests 22138 instanceVariableNames: 'random array stream filename' 22139 classVariableNames: '' 22140 poolDictionaries: '' 22141 category: 'Tests-Bugs'! 22142!BitmapStreamTests commentStamp: 'nk 3/7/2004 14:26' prior: 0! 22143This is an incomplete test suite for storing and reading various word- and short-word subclasses of ArrayedCollection. 22144 22145It demonstrates some problems with filing in of certain kinds of arrayed objects, including: 22146 22147ShortPointArray 22148ShortIntegerArray 22149ShortRunArray 22150WordArray 22151MatrixTransform2x3 22152 22153In 3.6b-5331, I get 8 passed/6 failed/6 errors (not counting the MatrixTransform2x3 tests, which were added later). 22154 22155I ran into problems when trying to read back the SqueakLogo flash character morph, after I'd done a 'save morph to disk' from its debug menu. 22156 22157The words within the ShortPointArrays and ShortRunArrays were reversed. 22158! 22159 22160 22161!BitmapStreamTests methodsFor: 'running' stamp: 'SergeStinckwich 5/27/2008 22:58'! 22162setUp 22163 filename := 'bitmapStreamTest.ref'. 22164 random := Random new! ! 22165 22166!BitmapStreamTests methodsFor: 'running' stamp: 'SergeStinckwich 5/27/2008 22:59'! 22167tearDown 22168 FileDirectory default 22169 deleteFileNamed: filename 22170 ifAbsent: []! ! 22171 22172 22173!BitmapStreamTests methodsFor: 'tests-matrixtransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'! 22174testMatrixTransform2x3WithImageSegment 22175 array := MatrixTransform2x3 new. 22176 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. 22177 self validateImageSegment 22178 ! ! 22179 22180!BitmapStreamTests methodsFor: 'tests-matrixtransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'! 22181testMatrixTransform2x3WithRefStream 22182 array := MatrixTransform2x3 new. 22183 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. 22184 self validateRefStream 22185 ! ! 22186 22187!BitmapStreamTests methodsFor: 'tests-matrixtransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'! 22188testMatrixTransform2x3WithRefStreamOnDisk 22189 array := MatrixTransform2x3 new. 22190 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. 22191 self validateRefStreamOnDisk ! ! 22192 22193!BitmapStreamTests methodsFor: 'tests-matrixtransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'! 22194testMatrixTransform2x3WithSmartRefStream 22195 array := MatrixTransform2x3 new. 22196 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. 22197 self validateSmartRefStream 22198 ! ! 22199 22200!BitmapStreamTests methodsFor: 'tests-matrixtransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'! 22201testMatrixTransform2x3WithSmartRefStreamOnDisk 22202 array := MatrixTransform2x3 new. 22203 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. 22204 self validateSmartRefStreamOnDisk 22205 ! ! 22206 22207 22208!BitmapStreamTests methodsFor: 'tests-misc' stamp: 'DouglasBrebner 9/2/2009 19:18'! 22209testOtherClasses 22210 22211 #(WordArrayForSegment FloatArray PointArray IntegerArray String ShortPointArray ShortIntegerArray WordArray Array DependentsArray ByteArray Bitmap ColorArray ) do: [:s | | a | 22212 a := (Smalltalk at: s) new: 3. 22213 self assert: (a basicSize * a bytesPerBasicElement = a byteSize). ] 22214! ! 22215 22216 22217!BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22218testShortIntegerArrayReadRefStream2 22219 |refStrm| 22220 refStrm := ReferenceStream on: ((RWBinaryOrTextStream with: (ByteArray withAll: #(20 6 17 83 104 111 114 116 73 110 116 101 103 101 114 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3))) reset; binary). 22221 self assert: (refStrm next = (ShortIntegerArray with: 0 with: 1 with: 2 with: 3)).! ! 22222 22223!BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22224testShortIntegerArrayWithImageSegment 22225 array := ShortIntegerArray new: 10. 22226 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. 22227 self validateImageSegment 22228 ! ! 22229 22230!BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22231testShortIntegerArrayWithRefStream 22232 22233 array := ShortIntegerArray with: 0 with: 1 with: 2 with: 3. 22234 self validateRefStream 22235 ! ! 22236 22237!BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22238testShortIntegerArrayWithRefStream2 22239 array := ShortIntegerArray with: 0 with: 1 with: 2 with: 3. 22240 self validateRefStream. 22241 self assert: stream byteStream contents = (ByteArray withAll: #(20 6 17 83 104 111 114 116 73 110 116 101 103 101 114 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3)) 22242 22243! ! 22244 22245!BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22246testShortIntegerArrayWithRefStreamOnDisk 22247 array := ShortIntegerArray new: 10. 22248 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. 22249 self validateRefStreamOnDisk 22250 ! ! 22251 22252!BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22253testShortIntegerArrayWithSmartRefStream 22254 array := ShortIntegerArray new: 10. 22255 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. 22256 self validateSmartRefStream 22257 ! ! 22258 22259!BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22260testShortIntegerArrayWithSmartRefStream2 22261 array := ShortIntegerArray with: 0 with: 1 with: 2 with: 3. 22262 self validateSmartRefStream. 22263 self assert: (stream contents asByteArray last: 15) = (ByteArray withAll: #(0 0 0 2 0 0 0 1 0 2 0 3 33 13 13)) 22264 22265! ! 22266 22267!BitmapStreamTests methodsFor: 'tests-shortintegerarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22268testShortIntegerArrayWithSmartRefStreamOnDisk 22269 array := ShortIntegerArray new: 10. 22270 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. 22271 self validateSmartRefStreamOnDisk 22272 ! ! 22273 22274 22275!BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22276testShortPointArrayWithImageSegment 22277 array := ShortPointArray new: 10. 22278 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. 22279 self validateImageSegment 22280 ! ! 22281 22282!BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22283testShortPointArrayWithRefStream 22284 array := ShortPointArray new: 10. 22285 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. 22286 self validateRefStream 22287 ! ! 22288 22289!BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22290testShortPointArrayWithRefStream2 22291 array := ShortPointArray with: 0@1 with: 2@3. 22292 self validateRefStream. 22293 self assert: stream byteStream contents = (ByteArray withAll: #(20 6 15 83 104 111 114 116 80 111 105 110 116 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3 )) 22294 ! ! 22295 22296!BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22297testShortPointArrayWithRefStreamOnDisk 22298 array := ShortPointArray new: 10. 22299 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. 22300 self validateRefStreamOnDisk 22301 ! ! 22302 22303!BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22304testShortPointArrayWithSmartRefStream 22305 array := ShortPointArray new: 10. 22306 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. 22307 self validateSmartRefStream 22308 ! ! 22309 22310!BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22311testShortPointArrayWithSmartRefStream2 22312 array := ShortPointArray with: 0@1 with: 2@3. 22313 self validateSmartRefStream. 22314 self assert: (stream contents asByteArray last: 15) = (ByteArray withAll: #(0 0 0 2 0 0 0 1 0 2 0 3 33 13 13)) 22315 ! ! 22316 22317!BitmapStreamTests methodsFor: 'tests-shortpointarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22318testShortPointArrayWithSmartRefStreamOnDisk 22319 array := ShortPointArray new: 10. 22320 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. 22321 self validateSmartRefStreamOnDisk 22322 ! ! 22323 22324 22325!BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'nk 3/17/2004 16:39'! 22326createSampleShortRunArray 22327 ^ShortRunArray newFrom: { 0. 1. 1. 2. 2. 2. 3. 3. 3. 3 }! ! 22328 22329!BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22330testShortRunArrayWithImageSegment 22331 array := self createSampleShortRunArray. 22332 self validateImageSegment 22333 ! ! 22334 22335!BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22336testShortRunArrayWithRefStream 22337 array := self createSampleShortRunArray. 22338 self validateRefStream 22339 ! ! 22340 22341!BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22342testShortRunArrayWithRefStreamOnDisk 22343 array := self createSampleShortRunArray. 22344 self validateRefStreamOnDisk 22345 ! ! 22346 22347!BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22348testShortRunArrayWithSmartRefStream 22349 array := self createSampleShortRunArray. 22350 self validateSmartRefStream 22351 ! ! 22352 22353!BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22354testShortRunArrayWithSmartRefStream2 22355 array := self createSampleShortRunArray. 22356 self validateSmartRefStream. 22357 self assert: (stream contents asByteArray last: 23) = (ByteArray withAll: #(0 0 0 4 0 1 0 0 0 2 0 1 0 3 0 2 0 4 0 3 33 13 13)) 22358 22359! ! 22360 22361!BitmapStreamTests methodsFor: 'tests-shortrunarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22362testShortRunArrayWithSmartRefStreamOnDisk 22363 array := self createSampleShortRunArray. 22364 self validateSmartRefStreamOnDisk 22365 ! ! 22366 22367 22368!BitmapStreamTests methodsFor: 'tests-wordarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22369testWordArrayWithImageSegment 22370 array := WordArray new: 10. 22371 1 to: 10 do: [ :i | array at: i put: self randomWord ]. 22372 self validateImageSegment 22373 ! ! 22374 22375!BitmapStreamTests methodsFor: 'tests-wordarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22376testWordArrayWithRefStream 22377 array := WordArray new: 10. 22378 1 to: 10 do: [ :i | array at: i put: self randomWord ]. 22379 self validateRefStream 22380 ! ! 22381 22382!BitmapStreamTests methodsFor: 'tests-wordarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22383testWordArrayWithRefStreamOnDisk 22384 array := WordArray new: 10. 22385 1 to: 10 do: [ :i | array at: i put: self randomWord ]. 22386 self validateRefStreamOnDisk 22387 ! ! 22388 22389!BitmapStreamTests methodsFor: 'tests-wordarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22390testWordArrayWithSmartRefStream 22391 array := WordArray new: 10. 22392 1 to: 10 do: [ :i | array at: i put: self randomWord ]. 22393 self validateSmartRefStream 22394 ! ! 22395 22396!BitmapStreamTests methodsFor: 'tests-wordarray' stamp: 'stephaneducasse 2/3/2006 22:39'! 22397testWordArrayWithSmartRefStreamOnDisk 22398 array := WordArray new: 10. 22399 1 to: 10 do: [ :i | array at: i put: self randomWord ]. 22400 self validateSmartRefStreamOnDisk 22401 ! ! 22402 22403 22404!BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'! 22405randomFloat 22406 "Answer a random 32-bit float" 22407 | w | 22408 random seed: (w := random nextValue). 22409 ^w! ! 22410 22411!BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:33'! 22412randomShortInt 22413 ^((random next * 65536) - 32768) truncated! ! 22414 22415!BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:00'! 22416randomShortPoint 22417 ^(((random next * 65536) @ (random next * 65536)) - (32768 @ 32768)) truncated! ! 22418 22419!BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'! 22420randomWord 22421 "Answer a random 32-bit integer" 22422 | w | 22423 random seed: (w := random nextValue). 22424 ^w truncated! ! 22425 22426!BitmapStreamTests methodsFor: 'private' stamp: 'al 6/14/2008 19:12'! 22427validateImageSegment 22428 | other externalSegmentFilename | 22429 externalSegmentFilename := 'bitmapStreamTest.extSeg'. 22430 [ 22431 (ImageSegment new copyFromRootsForExport: (Array with: array)) 22432 writeForExport: externalSegmentFilename. 22433 other := (FileDirectory default readOnlyFileNamed: externalSegmentFilename) 22434 fileInObjectAndCode 22435 ] ensure: [ FileDirectory default deleteFileNamed: externalSegmentFilename ifAbsent: [ ] ]. 22436 self assert: array = other originalRoots first! ! 22437 22438!BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'! 22439validateRefStream 22440 "array is set up with an array." 22441 | other rwstream | 22442 rwstream := RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6). 22443 22444 stream := ReferenceStream on: rwstream. 22445 stream nextPut: array; close. 22446 22447 rwstream position: 0. 22448 stream := ReferenceStream on: rwstream. 22449 other := stream next. 22450 stream close. 22451 22452 self assert: array = other! ! 22453 22454!BitmapStreamTests methodsFor: 'private' stamp: 'SergeStinckwich 5/27/2008 22:59'! 22455validateRefStreamOnDisk 22456 "array is set up with an array." 22457 | other | 22458 22459 FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. 22460 22461 stream := ReferenceStream fileNamed: filename. 22462 stream nextPut: array; close. 22463 22464 stream := ReferenceStream fileNamed: filename. 22465 other := stream next. 22466 stream close. 22467 22468 self assert: array = other! ! 22469 22470!BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'! 22471validateSmartRefStream 22472 "array is set up with an array." 22473 | other | 22474 stream := RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6). 22475 stream binary. 22476 stream fileOutClass: nil andObject: array. 22477 stream position: 0. 22478 stream binary. 22479 other := stream fileInObjectAndCode. 22480 self assert: array = other! ! 22481 22482!BitmapStreamTests methodsFor: 'private' stamp: 'SergeStinckwich 5/27/2008 22:59'! 22483validateSmartRefStreamOnDisk 22484 "array is set up with an array." 22485 | other | 22486 22487 FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. 22488 22489 stream := FileDirectory default fileNamed: filename. 22490 stream fileOutClass: nil andObject: array. 22491 stream close. 22492 22493 stream := FileDirectory default fileNamed: filename. 22494 other := stream fileInObjectAndCode. 22495 stream close. 22496 22497 self assert: array = other! ! 22498Error subclass: #BlockCannotReturn 22499 instanceVariableNames: 'result deadHome' 22500 classVariableNames: '' 22501 poolDictionaries: '' 22502 category: 'Exceptions-Kernel'! 22503!BlockCannotReturn commentStamp: '<historical>' prior: 0! 22504This class is private to the EHS implementation. Its use allows for ensured execution to survive code such as: 22505 22506[self doThis. 22507^nil] 22508 ensure: [self doThat] 22509 22510Signaling or handling this exception is not recommended.! 22511 22512 22513!BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'! 22514deadHome 22515 22516 ^ deadHome! ! 22517 22518!BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'! 22519deadHome: context 22520 22521 deadHome := context! ! 22522 22523!BlockCannotReturn methodsFor: 'accessing' stamp: 'tfei 3/30/1999 12:54'! 22524result 22525 22526 ^result! ! 22527 22528!BlockCannotReturn methodsFor: 'accessing' stamp: 'tfei 3/30/1999 12:54'! 22529result: r 22530 22531 result := r! ! 22532 22533 22534!BlockCannotReturn methodsFor: 'exceptiondescription' stamp: 'tfei 3/30/1999 12:55'! 22535defaultAction 22536 22537 self messageText: 'Block cannot return'. 22538 ^super defaultAction! ! 22539 22540!BlockCannotReturn methodsFor: 'exceptiondescription' stamp: 'tfei 4/2/1999 15:49'! 22541isResumable 22542 22543 ^true! ! 22544Object variableSubclass: #BlockClosure 22545 instanceVariableNames: 'outerContext startpc numArgs' 22546 classVariableNames: '' 22547 poolDictionaries: '' 22548 category: 'Kernel-Methods'! 22549!BlockClosure commentStamp: '<historical>' prior: 0! 22550I am a block closure for Eliot's closure implementation. Not to be confused with the old BlockClosure.! 22551]style[(103)i! 22552 22553 22554!BlockClosure methodsFor: '*services-base' stamp: 'rr 3/21/2006 11:53'! 22555valueWithRequestor: aRequestor 22556 "To do later: make the fillInTheBlank display more informative captions. 22557 Include the description of the service, and maybe record steps" 22558 22559 ^ self numArgs isZero 22560 ifTrue: [self value] 22561 ifFalse: [self value: aRequestor]! ! 22562 22563 22564!BlockClosure methodsFor: '*splitjoin' stamp: 'stephane.ducasse 4/13/2009 22:03'! 22565split: aSequenceableCollection 22566 | result position | 22567 result := OrderedCollection new. 22568 position := 1. 22569 aSequenceableCollection 22570 withIndexDo: [:element :idx | 22571 (self value: element) 22572 ifTrue: [result add: (aSequenceableCollection copyFrom: position to: idx - 1). 22573 position := idx + 1]]. 22574 result add: (aSequenceableCollection copyFrom: position to: aSequenceableCollection size). 22575 ^ result! ! 22576 22577 22578!BlockClosure methodsFor: 'accessing' stamp: 'stephane.ducasse 5/20/2009 21:19'! 22579argumentCount 22580 "Answer the number of arguments that must be used to evaluate this block" 22581 22582 ^numArgs 22583 22584! ! 22585 22586!BlockClosure methodsFor: 'accessing' stamp: 'eem 9/3/2008 13:57'! 22587copiedValueAt: i 22588 <primitive: 60> 22589 ^self basicAt: i! ! 22590 22591!BlockClosure methodsFor: 'accessing' stamp: 'eem 7/28/2008 13:58'! 22592home 22593 ^outerContext home! ! 22594 22595!BlockClosure methodsFor: 'accessing' stamp: 'ajh 1/21/2003 13:16'! 22596isBlock 22597 22598 ^ true! ! 22599 22600!BlockClosure methodsFor: 'accessing' stamp: 'eem 5/29/2008 12:18'! 22601method 22602 ^outerContext method! ! 22603 22604!BlockClosure methodsFor: 'accessing' stamp: 'eem 5/28/2008 16:02'! 22605numArgs 22606 "Answer the number of arguments that must be used to evaluate this block" 22607 22608 ^numArgs! ! 22609 22610!BlockClosure methodsFor: 'accessing' stamp: 'eem 9/3/2008 14:07'! 22611numCopiedValues 22612 "Answer the number of copied values of the receiver. Since these are 22613 stored in the receiver's indexable fields this is the receiver's basic size. 22614 Primitive. Answer the number of indexable variables in the receiver. 22615 This value is the same as the largest legal subscript." 22616 22617 <primitive: 62> 22618 ^self basicSize! ! 22619 22620!BlockClosure methodsFor: 'accessing' stamp: 'eem 5/24/2008 11:21'! 22621outerContext 22622 ^outerContext! ! 22623 22624!BlockClosure methodsFor: 'accessing' stamp: 'eem 6/26/2008 09:17'! 22625receiver 22626 ^outerContext receiver! ! 22627 22628!BlockClosure methodsFor: 'accessing' stamp: 'eem 6/1/2008 09:39'! 22629startpc 22630 ^startpc! ! 22631 22632 22633!BlockClosure methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:45'! 22634doWhileFalse: conditionBlock 22635 "Evaluate the receiver once, then again as long the value of conditionBlock is false." 22636 22637 | result | 22638 [result := self value. 22639 conditionBlock value] whileFalse. 22640 22641 ^ result! ! 22642 22643!BlockClosure methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:39'! 22644doWhileTrue: conditionBlock 22645 "Evaluate the receiver once, then again as long the value of conditionBlock is true." 22646 22647 | result | 22648 [result := self value. 22649 conditionBlock value] whileTrue. 22650 22651 ^ result! ! 22652 22653!BlockClosure methodsFor: 'controlling' stamp: 'sma 5/12/2000 13:22'! 22654repeat 22655 "Evaluate the receiver repeatedly, ending only if the block explicitly returns." 22656 22657 [self value. true] whileTrue! ! 22658 22659!BlockClosure methodsFor: 'controlling' stamp: 'ls 9/24/1999 09:45'! 22660repeatWithGCIf: testBlock 22661 | ans | 22662 "run the receiver, and if testBlock returns true, garbage collect and run the receiver again" 22663 ans := self value. 22664 (testBlock value: ans) ifTrue: [ Smalltalk garbageCollect. ans := self value ]. 22665 ^ans! ! 22666 22667!BlockClosure methodsFor: 'controlling'! 22668whileFalse 22669 "Ordinarily compiled in-line, and therefore not overridable. 22670 This is in case the message is sent to other than a literal block. 22671 Evaluate the receiver, as long as its value is false." 22672 22673 ^ [self value] whileFalse: []! ! 22674 22675!BlockClosure methodsFor: 'controlling'! 22676whileFalse: aBlock 22677 "Ordinarily compiled in-line, and therefore not overridable. 22678 This is in case the message is sent to other than a literal block. 22679 Evaluate the argument, aBlock, as long as the value of the receiver is false." 22680 22681 ^ [self value] whileFalse: [aBlock value]! ! 22682 22683!BlockClosure methodsFor: 'controlling' stamp: 'jcg 7/8/2007 18:25'! 22684whileNil: aBlock 22685 "Unlike #whileTrue/False: this is not compiled inline." 22686 ^ [self value isNil] whileTrue: [aBlock value] 22687 ! ! 22688 22689!BlockClosure methodsFor: 'controlling' stamp: 'jcg 7/8/2007 18:25'! 22690whileNotNil: aBlock 22691 "Unlike #whileTrue/False: this is not compiled inline." 22692 ^ [self value notNil] whileTrue: [aBlock value] 22693 ! ! 22694 22695!BlockClosure methodsFor: 'controlling'! 22696whileTrue 22697 "Ordinarily compiled in-line, and therefore not overridable. 22698 This is in case the message is sent to other than a literal block. 22699 Evaluate the receiver, as long as its value is true." 22700 22701 ^ [self value] whileTrue: []! ! 22702 22703!BlockClosure methodsFor: 'controlling'! 22704whileTrue: aBlock 22705 "Ordinarily compiled in-line, and therefore not overridable. 22706 This is in case the message is sent to other than a literal block. 22707 Evaluate the argument, aBlock, as long as the value of the receiver is true." 22708 22709 ^ [self value] whileTrue: [aBlock value]! ! 22710 22711 22712!BlockClosure methodsFor: 'copying' stamp: 'eem 5/28/2008 14:53'! 22713postCopy 22714 "To render a copy safe we need to provide a new outerContext that 22715 cannot be returned from and a copy of any remoteTemp vectors. 22716 When a block is active it makes no reference to state in its nested 22717 contexts (this is the whole point of the indirect temps scheme; any 22718 indirect state is either copied or in indirect temp vectors. So we 22719 need to substitute a dummy outerContext and copy the copiedValues, 22720 copying anything looking like a remote temp vector. if we accidentally 22721 copy an Array that isn't actually an indirect temp vector we do extra work 22722 but don't break anything." 22723 22724 outerContext := MethodContext 22725 sender: nil 22726 receiver: outerContext receiver 22727 method: outerContext method 22728 arguments: #(). 22729 self fixTemps! ! 22730 22731 22732!BlockClosure methodsFor: 'debugger access' stamp: 'nice 4/14/2009 19:09'! 22733sender 22734 "Answer the context that sent the message that created the receiver." 22735 22736 ^outerContext sender! ! 22737 22738 22739!BlockClosure methodsFor: 'error handing' stamp: 'eem 11/26/2008 20:03'! 22740numArgsError: numArgsForInvocation 22741 22742 | printNArgs | 22743 printNArgs := [:n| n printString, ' argument', (n = 1 ifTrue: [''] ifFalse:['s'])]. 22744 self error: 22745 'This block accepts ', (printNArgs value: numArgs), 22746 ', but was called with ', (printNArgs value: numArgsForInvocation), '.'! ! 22747 22748 22749!BlockClosure methodsFor: 'evaluating' stamp: 'cmm 2/16/2003 16:08'! 22750bench 22751 "See how many times I can value in 5 seconds. I'll answer a meaningful description." 22752 22753 | startTime endTime count | 22754 count := 0. 22755 endTime := Time millisecondClockValue + 5000. 22756 startTime := Time millisecondClockValue. 22757 [ Time millisecondClockValue > endTime ] whileFalse: [ self value. count := count + 1 ]. 22758 endTime := Time millisecondClockValue. 22759 ^count = 1 22760 ifTrue: [ ((endTime - startTime) // 1000) printString, ' seconds.' ] 22761 ifFalse: 22762 [ ((count * 1000) / (endTime - startTime)) asFloat printString, ' per second.' ]! ! 22763 22764!BlockClosure methodsFor: 'evaluating' stamp: 'brp 9/25/2003 13:49'! 22765durationToRun 22766 22767 "Answer the duration taken to execute this block." 22768 22769 22770 22771 ^ Duration milliSeconds: self timeToRun 22772 22773 22774 22775! ! 22776 22777!BlockClosure methodsFor: 'evaluating' stamp: 'ajh 1/13/2002 13:36'! 22778ifError: errorHandlerBlock 22779 "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." 22780 "Examples: 22781 [1 whatsUpDoc] ifError: [:err :rcvr | 'huh?']. 22782 [1 / 0] ifError: [:err :rcvr | 22783 'ZeroDivide' = err 22784 ifTrue: [Float infinity] 22785 ifFalse: [self error: err]] 22786" 22787 22788 ^ self on: Error do: [:ex | 22789 errorHandlerBlock valueWithPossibleArgs: {ex description. ex receiver}]! ! 22790 22791!BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/5/2009 13:05'! 22792simulateValueWithArguments: anArray caller: aContext 22793 | newContext sz | 22794 (anArray class ~~ Array 22795 or: [numArgs ~= anArray size]) ifTrue: 22796 [^ContextPart primitiveFailToken]. 22797 newContext := (MethodContext newForMethod: outerContext method) 22798 setSender: aContext 22799 receiver: outerContext receiver 22800 method: outerContext method 22801 closure: self 22802 startpc: startpc. 22803 sz := self basicSize. 22804 newContext stackp: sz + numArgs. 22805 1 to: numArgs do: 22806 [:i| newContext at: i put: (anArray at: i)]. 22807 1 to: sz do: 22808 [:i| newContext at: i + numArgs put: (self at: i)]. 22809 ^newContext! ! 22810 22811!BlockClosure methodsFor: 'evaluating' stamp: 'jm 6/3/1998 14:25'! 22812timeToRun 22813 "Answer the number of milliseconds taken to execute this block." 22814 22815 ^ Time millisecondsToRun: self 22816! ! 22817 22818!BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/3/2008 14:09'! 22819value 22820 "Activate the receiver, creating a closure activation (MethodContext) 22821 whose closure is the receiver and whose caller is the sender of this message. 22822 Supply the copied values to the activation as its arguments and copied temps. 22823 Primitive. Optional (but you're going to want this for performance)." 22824 | newContext ncv | 22825 <primitive: 201> 22826 numArgs ~= 0 ifTrue: 22827 [self numArgsError: 0]. 22828 newContext := self asContextWithSender: thisContext sender. 22829 (ncv := self numCopiedValues) > 0 ifTrue: 22830 [newContext stackp: ncv. 22831 1 to: ncv do: "nil basicSize = 0" 22832 [:i| newContext at: i put: (self at: i)]]. 22833 thisContext privSender: newContext! ! 22834 22835!BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/3/2008 14:09'! 22836value: anArg 22837 "Activate the receiver, creating a closure activation (MethodContext) 22838 whose closure is the receiver and whose caller is the sender of this message. 22839 Supply the argument and copied values to the activation as its arguments and copied temps. 22840 Primitive. Optional (but you're going to want this for performance)." 22841 | newContext ncv | 22842 <primitive: 202> 22843 numArgs ~= 1 ifTrue: 22844 [self numArgsError: 1]. 22845 newContext := self asContextWithSender: thisContext sender. 22846 ncv := self numCopiedValues. 22847 newContext stackp: ncv + 1. 22848 newContext at: 1 put: anArg. 22849 1 to: ncv do: 22850 [:i| newContext at: i + 1 put: (self at: i)]. 22851 thisContext privSender: newContext! ! 22852 22853!BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/3/2008 14:10'! 22854value: firstArg value: secondArg 22855 "Activate the receiver, creating a closure activation (MethodContext) 22856 whose closure is the receiver and whose caller is the sender of this message. 22857 Supply the arguments and copied values to the activation as its arguments and copied temps. 22858 Primitive. Optional (but you're going to want this for performance)." 22859 | newContext ncv | 22860 <primitive: 203> 22861 numArgs ~= 2 ifTrue: 22862 [self numArgsError: 2]. 22863 newContext := self asContextWithSender: thisContext sender. 22864 ncv := self numCopiedValues. 22865 newContext stackp: ncv + 2. 22866 newContext at: 1 put: firstArg. 22867 newContext at: 2 put: secondArg. 22868 1 to: ncv do: 22869 [:i| newContext at: i + 2 put: (self at: i)]. 22870 thisContext privSender: newContext! ! 22871 22872!BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/3/2008 14:11'! 22873value: firstArg value: secondArg value: thirdArg 22874 "Activate the receiver, creating a closure activation (MethodContext) 22875 whose closure is the receiver and whose caller is the sender of this message. 22876 Supply the arguments and copied values to the activation as its arguments and copied temps. 22877 Primitive. Optional (but you're going to want this for performance)." 22878 | newContext ncv | 22879 <primitive: 204> 22880 numArgs ~= 3 ifTrue: 22881 [self numArgsError: 3]. 22882 newContext := self asContextWithSender: thisContext sender. 22883 ncv := self numCopiedValues. 22884 newContext stackp: ncv + 3. 22885 newContext at: 1 put: firstArg. 22886 newContext at: 2 put: secondArg. 22887 newContext at: 3 put: thirdArg. 22888 1 to: ncv do: 22889 [:i| newContext at: i + 3 put: (self at: i)]. 22890 thisContext privSender: newContext! ! 22891 22892!BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/3/2008 14:11'! 22893value: firstArg value: secondArg value: thirdArg value: fourthArg 22894 "Activate the receiver, creating a closure activation (MethodContext) 22895 whose closure is the receiver and whose caller is the sender of this message. 22896 Supply the arguments and copied values to the activation as its arguments and copied temps. 22897 Primitive. Optional (but you're going to want this for performance)." 22898 | newContext ncv | 22899 <primitive: 205> 22900 numArgs ~= 4 ifTrue: 22901 [self numArgsError: 4]. 22902 newContext := self asContextWithSender: thisContext sender. 22903 ncv := self numCopiedValues. 22904 newContext stackp: ncv + 4. 22905 newContext at: 1 put: firstArg. 22906 newContext at: 2 put: secondArg. 22907 newContext at: 3 put: thirdArg. 22908 newContext at: 4 put: fourthArg. 22909 1 to: ncv do: 22910 [:i| newContext at: i + 4 put: (self at: i)]. 22911 thisContext privSender: newContext! ! 22912 22913!BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:22'! 22914valueAt: blockPriority 22915 "Evaluate the receiver (block), with another priority as the actual one 22916 and restore it afterwards. The caller should be careful with using 22917 higher priorities." 22918 | activeProcess result outsidePriority | 22919 activeProcess := Processor activeProcess. 22920 outsidePriority := activeProcess priority. 22921 activeProcess priority: blockPriority. 22922 result := self ensure: [activeProcess priority: outsidePriority]. 22923 "Yield after restoring lower priority to give the preempted processes a 22924 chance to run." 22925 blockPriority > outsidePriority 22926 ifTrue: [Processor yield]. 22927 ^ result! ! 22928 22929!BlockClosure methodsFor: 'evaluating' stamp: 'eem 8/22/2008 14:21'! 22930valueNoContextSwitch 22931 "An exact copy of BlockClosure>>value except that this version will not preempt 22932 the current process on block activation if a higher-priority process is runnable. 22933 Primitive. Essential." 22934 <primitive: 221> 22935 numArgs ~= 0 ifTrue: 22936 [self numArgsError: 0]. 22937 self primitiveFailed! ! 22938 22939!BlockClosure methodsFor: 'evaluating' stamp: 'eem 8/22/2008 14:21'! 22940valueNoContextSwitch: anArg 22941 "An exact copy of BlockClosure>>value: except that this version will not preempt 22942 the current process on block activation if a higher-priority process is runnable. 22943 Primitive. Essential." 22944 <primitive: 222> 22945 numArgs ~= 1 ifTrue: 22946 [self numArgsError: 1]. 22947 self primitiveFailed! ! 22948 22949!BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:23'! 22950valueSupplyingAnswer: anObject 22951 ^ (anObject isCollection and: [anObject isString not]) 22952 ifTrue: [self valueSupplyingAnswers: {anObject}] 22953 ifFalse: [self valueSupplyingAnswers: {{'*'. anObject}}]! ! 22954 22955!BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:24'! 22956valueSupplyingAnswers: aListOfPairs 22957 "evaluate the block using a list of questions / answers that might be called upon to 22958 automatically respond to Object>>confirm: or FillInTheBlank requests" 22959 22960 ^ [self value] 22961 on: ProvideAnswerNotification 22962 do: 22963 [:notify | | answer caption | 22964 22965 caption := notify messageText withSeparatorsCompacted. "to remove new lines" 22966 answer := aListOfPairs 22967 detect: 22968 [:each | caption = each first or: 22969 [(caption includesSubstring: each first caseSensitive: false) or: 22970 [(each first match: caption) or: 22971 [(String includesSelector: #matchesRegex:) and: [caption matchesRegex: each first]]]]] 22972 ifNone: [nil]. 22973 answer 22974 ifNotNil: [notify resume: answer second] 22975 ifNil: 22976 [ | outerAnswer | 22977 outerAnswer := ProvideAnswerNotification signal: notify messageText. 22978 outerAnswer 22979 ifNil: [notify resume] 22980 ifNotNil: [notify resume: outerAnswer]]]! ! 22981 22982!BlockClosure methodsFor: 'evaluating' stamp: 'jrp 10/10/2004 22:28'! 22983valueSuppressingAllMessages 22984 22985 ^ self valueSuppressingMessages: #('*')! ! 22986 22987!BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:24'! 22988valueSuppressingMessages: aListOfStrings 22989 22990 ^ self 22991 valueSuppressingMessages: aListOfStrings 22992 supplyingAnswers: #()! ! 22993 22994!BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:24'! 22995valueSuppressingMessages: aListOfStrings supplyingAnswers: aListOfPairs 22996 22997 ^ self valueSupplyingAnswers: aListOfPairs, (aListOfStrings collect: [:each | {each. true}])! ! 22998 22999!BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/3/2008 14:08'! 23000valueWithArguments: anArray 23001 "Activate the receiver, creating a closure activation (MethodContext) 23002 whose closure is the receiver and whose caller is the sender of this message. 23003 Supply the arguments in an anArray and copied values to the activation as its arguments and copied temps. 23004 Primitive. Optional (but you're going to want this for performance)." 23005 | newContext ncv | 23006 <primitive: 206> 23007 numArgs ~= anArray size ifTrue: 23008 [self numArgsError: anArray size]. 23009 newContext := self asContextWithSender: thisContext sender. 23010 ncv := self numCopiedValues. 23011 newContext stackp: ncv + numArgs. 23012 1 to: numArgs do: 23013 [:i| newContext at: i put: (anArray at: i)]. 23014 1 to: ncv do: 23015 [:i| newContext at: i + numArgs put: (self at: i)]. 23016 thisContext privSender: newContext! ! 23017 23018!BlockClosure methodsFor: 'evaluating' stamp: 'nk 3/11/2001 11:49'! 23019valueWithEnoughArguments: anArray 23020 "call me with enough arguments from anArray" 23021 | args | 23022 (anArray size == self numArgs) 23023 ifTrue: [ ^self valueWithArguments: anArray ]. 23024 23025 args := Array new: self numArgs. 23026 args replaceFrom: 1 23027 to: (anArray size min: args size) 23028 with: anArray 23029 startingAt: 1. 23030 23031 ^ self valueWithArguments: args! ! 23032 23033!BlockClosure methodsFor: 'evaluating' stamp: 'md 3/28/2006 20:17'! 23034valueWithExit 23035 self value: [ ^nil ]! ! 23036 23037!BlockClosure methodsFor: 'evaluating' stamp: 'eem 5/28/2008 15:03'! 23038valueWithPossibleArgs: anArray 23039 23040 ^numArgs = 0 23041 ifTrue: [self value] 23042 ifFalse: 23043 [self valueWithArguments: 23044 (numArgs = anArray size 23045 ifTrue: [anArray] 23046 ifFalse: 23047 [numArgs > anArray size 23048 ifTrue: [anArray, (Array new: numArgs - anArray size)] 23049 ifFalse: [anArray copyFrom: 1 to: numArgs]])]! ! 23050 23051!BlockClosure methodsFor: 'evaluating' stamp: 'eem 5/25/2008 14:47'! 23052valueWithPossibleArgument: anArg 23053 "Evaluate the block represented by the receiver. 23054 If the block requires one argument, use anArg, if it requires more than one, 23055 fill up the rest with nils." 23056 23057 | a | 23058 numArgs = 0 ifTrue: [^self value]. 23059 numArgs = 1 ifTrue: [^self value: anArg]. 23060 a := Array new: numArgs. 23061 a at: 1 put: anArg. 23062 ^self valueWithArguments: a! ! 23063 23064!BlockClosure methodsFor: 'evaluating' stamp: 'ar 8/17/2007 13:15'! 23065valueWithin: aDuration onTimeout: timeoutBlock 23066 "Evaluate the receiver. 23067 If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead" 23068 23069 | theProcess delay watchdog | 23070 23071 aDuration <= Duration zero ifTrue: [^ timeoutBlock value ]. 23072 23073 "the block will be executed in the current process" 23074 theProcess := Processor activeProcess. 23075 delay := aDuration asDelay. 23076 23077 "make a watchdog process" 23078 watchdog := [ 23079 delay wait. "wait for timeout or completion" 23080 theProcess ifNotNil:[ theProcess signalException: TimedOut ] 23081 ] newProcess. 23082 23083 "Watchdog needs to run at high priority to do its job (but not at timing priority)" 23084 watchdog priority: Processor timingPriority-1. 23085 23086 "catch the timeout signal" 23087 ^ [ watchdog resume. "start up the watchdog" 23088 self ensure:[ "evaluate the receiver" 23089 theProcess := nil. "it has completed, so ..." 23090 delay delaySemaphore signal. "arrange for the watchdog to exit" 23091 ]] on: TimedOut do: [ :e | timeoutBlock value ]. 23092! ! 23093 23094 23095!BlockClosure methodsFor: 'exceptions' stamp: 'sma 5/11/2000 19:38'! 23096assert 23097 self assert: self! ! 23098 23099!BlockClosure methodsFor: 'exceptions' stamp: 'eem 8/22/2008 14:22'! 23100ensure: aBlock 23101 "Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes." 23102 23103 | returnValue b | 23104 <primitive: 198> 23105 returnValue := self valueNoContextSwitch. 23106 "aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated" 23107 aBlock == nil ifFalse: [ 23108 "nil out aBlock temp before evaluating aBlock so it is not executed again if aBlock remote returns" 23109 b := aBlock. 23110 thisContext tempAt: 1 put: nil. "Could be aBlock := nil, but arguments cannot be modified" 23111 b value. 23112 ]. 23113 ^ returnValue! ! 23114 23115!BlockClosure methodsFor: 'exceptions' stamp: 'eem 8/22/2008 14:29'! 23116ifCurtailed: aBlock 23117 "Evaluate the receiver with an abnormal termination action. 23118 Evaluate aBlock only if execution is unwound during execution 23119 of the receiver. If execution of the receiver finishes normally 23120 do not evaluate aBlock." 23121 23122 <primitive: 198> 23123 ^self valueNoContextSwitch! ! 23124 23125!BlockClosure methodsFor: 'exceptions' stamp: 'ajh 2/1/2003 00:30'! 23126on: exception do: handlerAction 23127 "Evaluate the receiver in the scope of an exception handler." 23128 23129 | handlerActive | 23130 <primitive: 199> "just a marker, fail and execute the following" 23131 handlerActive := true. 23132 ^ self value! ! 23133 23134!BlockClosure methodsFor: 'exceptions' stamp: 'ajh 10/9/2001 16:51'! 23135onDNU: selector do: handleBlock 23136 "Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)" 23137 23138 ^ self on: MessageNotUnderstood do: [:exception | 23139 exception message selector = selector 23140 ifTrue: [handleBlock valueWithPossibleArgs: {exception}] 23141 ifFalse: [exception pass] 23142 ]! ! 23143 23144!BlockClosure methodsFor: 'exceptions' stamp: 'ajh 7/26/2002 11:49'! 23145valueUninterruptably 23146 "Prevent remote returns from escaping the sender. Even attempts to terminate (unwind) this process will be halted and the process will resume here. A terminate message is needed for every one of these in the sender chain to get the entire process unwound." 23147 23148 ^ self ifCurtailed: [^ self]! ! 23149 23150 23151!BlockClosure methodsFor: 'initialize-release' stamp: 'eem 9/3/2008 14:08'! 23152outerContext: aContext startpc: aStartpc numArgs: argCount copiedValues: anArrayOrNil 23153 outerContext := aContext. 23154 startpc := aStartpc. 23155 numArgs := argCount. 23156 1 to: self numCopiedValues do: 23157 [:i| 23158 self at: i put: (anArrayOrNil at: i)]! ! 23159 23160 23161!BlockClosure methodsFor: 'printing' stamp: 'stephane.ducasse 4/21/2009 11:52'! 23162asText 23163 23164 ^ self asString asText! ! 23165 23166!BlockClosure methodsFor: 'printing' stamp: 'eem 7/28/2008 14:06'! 23167decompile 23168 ^Decompiler new decompileBlock: self! ! 23169 23170!BlockClosure methodsFor: 'printing' stamp: 'eem 7/28/2008 14:09'! 23171fullPrintOn: aStream 23172 aStream print: self; cr. 23173 (self decompile ifNil: ['--source missing--']) printOn: aStream indent: 0! ! 23174 23175!BlockClosure methodsFor: 'printing' stamp: 'eem 5/24/2008 11:23'! 23176printOn: aStream 23177 aStream nextPutAll: '[closure] in '. 23178 outerContext printOn: aStream! ! 23179 23180 23181!BlockClosure methodsFor: 'scheduling' stamp: 'eem 5/28/2008 16:16'! 23182asContext 23183 "Create a MethodContext that is ready to execute self. Assumes self takes no args (if it does the args will be nil)" 23184 23185 ^self asContextWithSender: nil! ! 23186 23187!BlockClosure methodsFor: 'scheduling' stamp: 'ajh 7/15/2001 16:03'! 23188fork 23189 "Create and schedule a Process running the code in the receiver." 23190 23191 ^ self newProcess resume! ! 23192 23193!BlockClosure methodsFor: 'scheduling' stamp: 'ajh 10/16/2002 11:14'! 23194forkAndWait 23195 "Suspend current process and execute self in new process, when it completes resume current process" 23196 23197 | semaphore | 23198 semaphore := Semaphore new. 23199 [self ensure: [semaphore signal]] fork. 23200 semaphore wait. 23201! ! 23202 23203!BlockClosure methodsFor: 'scheduling' stamp: 'ajh 9/29/2001 21:00'! 23204forkAt: priority 23205 "Create and schedule a Process running the code in the receiver at the given priority. Answer the newly created process." 23206 23207 ^ self newProcess 23208 priority: priority; 23209 resume! ! 23210 23211!BlockClosure methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! 23212forkAt: priority named: name 23213 23214 "Create and schedule a Process running the code in the receiver at the 23215 23216 given priority and having the given name. Answer the newly created 23217 23218 process." 23219 23220 23221 23222 | forkedProcess | 23223 23224 forkedProcess := self newProcess. 23225 23226 forkedProcess priority: priority. 23227 23228 forkedProcess name: name. 23229 23230 ^ forkedProcess resume! ! 23231 23232!BlockClosure methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! 23233forkNamed: aString 23234 23235 "Create and schedule a Process running the code in the receiver and 23236 23237 having the given name." 23238 23239 23240 23241 ^ self newProcess name: aString; resume! ! 23242 23243!BlockClosure methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:25'! 23244newProcess 23245 "Answer a Process running the code in the receiver. The process is not 23246 scheduled." 23247 <primitive: 19> "Simulation guard" 23248 ^Process 23249 forContext: 23250 [self value. 23251 Processor terminateActive] asContext 23252 priority: Processor activePriority! ! 23253 23254!BlockClosure methodsFor: 'scheduling' stamp: 'marcus.denker 6/10/2009 20:28'! 23255newProcessWith: anArray 23256 "Answer a Process running the code in the receiver. The receiver's block 23257 arguments are bound to the contents of the argument, anArray. The 23258 process is not scheduled." 23259 <primitive: 19> "Simulation guard" 23260 ^Process 23261 forContext: 23262 [self valueWithArguments: anArray. 23263 Processor terminateActive] asContext 23264 priority: Processor activePriority! ! 23265 23266 23267!BlockClosure methodsFor: 'testing' stamp: 'eem 5/29/2008 12:20'! 23268hasMethodReturn 23269 "Answer whether the receiver has a method-return ('^') in its code." 23270 | myMethod scanner preceedingBytecodeMessage end | 23271 "Determine end of block from the instruction preceding it. 23272 Find the instruction by using an MNU handler to capture 23273 the instruction message sent by the scanner." 23274 myMethod := outerContext method. 23275 scanner := InstructionStream new method: myMethod pc: myMethod initialPC. 23276 [scanner pc < startpc] whileTrue: 23277 [[scanner interpretNextInstructionFor: nil] 23278 on: MessageNotUnderstood 23279 do: [:ex| preceedingBytecodeMessage := ex message]]. 23280 end := preceedingBytecodeMessage arguments last + startpc - 1. 23281 scanner method: myMethod pc: startpc. 23282 scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]]. 23283 ^scanner pc <= end! ! 23284 23285!BlockClosure methodsFor: 'testing' stamp: 'eem 5/23/2008 13:48'! 23286isClosure 23287 ^true! ! 23288 23289!BlockClosure methodsFor: 'testing' stamp: 'eem 11/26/2008 20:27'! 23290isDead 23291 "Has self finished" 23292 ^false! ! 23293 23294 23295!BlockClosure methodsFor: 'private' stamp: 'eem 6/11/2008 11:38'! 23296asContextWithSender: aContext 23297 "Inner private support method for evaluation. Do not use unless you know what you're doing." 23298 23299 ^(MethodContext newForMethod: outerContext method) 23300 setSender: aContext 23301 receiver: outerContext receiver 23302 method: outerContext method 23303 closure: self 23304 startpc: startpc! ! 23305 23306!BlockClosure methodsFor: 'private' stamp: 'sd 3/22/2009 19:33'! 23307asMinimalRepresentation 23308 "Answer the receiver." 23309 23310 ^self! ! 23311 23312!BlockClosure methodsFor: 'private' stamp: 'eem 5/28/2008 14:50'! 23313copyForSaving 23314 "Answer a copy of the receiver suitable for serialization. 23315 Notionally, if the receiver's outerContext has been returned from then nothing 23316 needs to be done and we can use the receiver. But there's a race condition 23317 determining if the receiver has been returned from (it could be executing in a 23318 different process). So answer a copy anyway." 23319 ^self shallowCopy postCopy! ! 23320 23321!BlockClosure methodsFor: 'private' stamp: 'eem 12/14/2008 16:47'! 23322fixTemps 23323 "Fix the values of the temporary variables used in the block that 23324 are ordinarily shared with the method in which the block is defined. 23325 This is a no-op for closures, provided for backward-compatibility with 23326 old BlockContexts that needed the fixTemps hack to persist."! ! 23327 23328!BlockClosure methodsFor: 'private' stamp: 'sd 3/22/2009 19:33'! 23329isValid 23330 "Answer the receiver." 23331 23332 ^true! ! 23333 23334!BlockClosure methodsFor: 'private' stamp: 'eem 5/28/2008 14:56'! 23335reentrant 23336 "Answer a version of the recever that can be reentered. 23337 Closures are reentrant (unlike BlockContect) so simply answer self." 23338 ^self! ! 23339 23340!BlockClosure methodsFor: 'private' stamp: 'ar 3/2/2001 01:16'! 23341valueUnpreemptively 23342 "Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!" 23343 "Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! 23344 After you've done all that thinking, go right ahead and use it..." 23345 | activeProcess oldPriority result | 23346 activeProcess := Processor activeProcess. 23347 oldPriority := activeProcess priority. 23348 activeProcess priority: Processor highestPriority. 23349 result := self ensure: [activeProcess priority: oldPriority]. 23350 "Yield after restoring priority to give the preempted processes a chance to run" 23351 Processor yield. 23352 ^result! ! 23353 23354"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 23355 23356BlockClosure class 23357 instanceVariableNames: ''! 23358 23359!BlockClosure class methodsFor: 'instance creation' stamp: 'eem 9/3/2008 14:02'! 23360outerContext: aContext startpc: aStartpc numArgs: argCount copiedValues: anArrayOrNil 23361 ^(self new: anArrayOrNil basicSize) 23362 outerContext: aContext 23363 startpc: aStartpc 23364 numArgs: argCount 23365 copiedValues: anArrayOrNil! ! 23366TestCase subclass: #BlockClosuresTestCase 23367 instanceVariableNames: '' 23368 classVariableNames: '' 23369 poolDictionaries: '' 23370 category: 'KernelTests-Methods'! 23371!BlockClosuresTestCase commentStamp: '<historical>' prior: 0! 23372This test case collects examples for block uses that require full block closures.! 23373 23374 23375!BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:20'! 23376constructCannotReturnBlockInDeadFrame 23377 23378 ^ [:arg | ^arg]. 23379! ! 23380 23381!BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:14'! 23382constructFibonacciBlockInDeadFrame 23383 23384 | fib | 23385 fib := [:val | 23386 (val <= 0) ifTrue: [self error: 'not a natural number']. 23387 (val <= 2) ifTrue: [1] 23388 ifFalse: [(fib value: (val - 1)) + (fib value: (val - 2))]]. 23389 ^fib 23390! ! 23391 23392!BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:14'! 23393constructFibonacciBlockWithBlockArgumentInDeadFrame 23394 23395 ^ [:val :blk | 23396 (val <= 0) ifTrue: [self error: 'not a natural number']. 23397 (val <= 2) ifTrue: [1] 23398 ifFalse: [(blk value: (val - 1) value: blk) + (blk value: (val - 2) value: blk)]]. 23399! ! 23400 23401!BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:15'! 23402constructSharedClosureEnvironmentInDeadFrame 23403 23404 |array result| 23405 result := 10. 23406 array := Array new: 2. 23407 array at: 1 put: [:arg | result := arg]. 23408 array at: 2 put: [result]. 23409 ^array 23410! ! 23411 23412!BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:44'! 23413continuationExample1: aCollection 23414 23415 " see comment below. 23416 Here we simply collect the values of a value with continuation block " 23417 23418 23419 | streamCreator collector | 23420 23421 streamCreator := [:collection | | i localBlock | 23422 i := 1. 23423 localBlock := 23424 [ | current | 23425 current := collection at: i. 23426 i := i + 1. 23427 Array with: current 23428 with: (i<= collection size ifTrue: [localBlock] 23429 ifFalse: [nil]) 23430 ]. 23431 ]. 23432 23433 23434 collector := [:valueWithContinuation | | oc | 23435 oc := OrderedCollection new. 23436 [ | local | 23437 local := valueWithContinuation value. 23438 oc add: local first. 23439 local last notNil] 23440 whileTrue: []. 23441 oc. 23442 ]. 23443 23444 ^collector value: (streamCreator value: aCollection). 23445 23446"The continuation examples are examples of a 'back to LISP' style. 23447These examples use blocks to process the elements of a collection in a 23448fashion that is similar to streaming. 23449The creator block creates a blocks that act like a stream. In the 23450following, this block is called a 'value with continuation block'. 23451When such a value with continuation block receives the message 23452value, it returns a Array of two elements, the value and the 23453continuation 23454 1. the next collection element 23455 2. a so-called continuation, which is either nil or a block 23456 that can return the next value with continuation. 23457 23458To collect all elements of a value with continuation stream, 23459use the collector block. " 23460! ! 23461 23462!BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:44'! 23463continuationExample2: aCollection 23464 23465 " see comment in method continuationExample1:. 23466 The block named 'processor' takes a value with contiuation 23467 and a processing block. It creates a new value with continuation. 23468 Again we use a collector to collect all values. " 23469 23470 | stream processor collector | 23471 23472 stream := [:collection | | i localBlock | 23473 i := 1. 23474 localBlock := 23475 [ | current | 23476 current := collection at: i. 23477 i := i + 1. 23478 Array with: current 23479 with: (i<= collection size ifTrue: [localBlock] 23480 ifFalse: [nil]) 23481 ]. 23482 ]. 23483 23484 processor := 23485 [:valueWithContinuation :activity | | localBlock | 23486 localBlock := 23487 [ | current | 23488 current := valueWithContinuation value. 23489 Array with: (activity value: current first) 23490 with: (current last notNil ifTrue: [localBlock])]. 23491 localBlock 23492 ]. 23493 23494 collector := [:valueWithContinuation | | oc | 23495 oc := OrderedCollection new. 23496 [ | local | 23497 local := valueWithContinuation value. 23498 oc add: local first. 23499 local last notNil] 23500 whileTrue: []. 23501 oc. 23502 ]. 23503 23504 ^collector value: (processor value: (stream value: aCollection) 23505 value: [:x | x * x]).! ! 23506 23507!BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:27'! 23508continuationExample3: aCollection 23509 23510 " see comment in method continuationExample1:. 23511 The block named 'processor' takes a value with contiuation 23512 and a processing block. It creates a new value with continuation. 23513 Here we set up a chain of three values with continuation: 23514 one data source and two value processors. 23515 Again we use a collector to collect all values. " 23516 23517 | stream processor collector | 23518 23519 stream := [:collection | | i localBlock | 23520 i := 1. 23521 localBlock := 23522 [ | current | 23523 current := collection at: i. 23524 i := i + 1. 23525 Array with: current 23526 with: (i<= collection size ifTrue: [localBlock] 23527 ifFalse: [nil]) 23528 ]. 23529 ]. 23530 23531 processor := 23532 [:valueWithContinuation :activity | | localBlock | 23533 localBlock := 23534 [ | current | 23535 current := valueWithContinuation value. 23536 Array with: (activity value: current first) 23537 with: (current last notNil ifTrue: [localBlock])]. 23538 localBlock 23539 ]. 23540 23541 collector := [:valueWithContinuation | | oc | 23542 oc := OrderedCollection new. 23543 [ | local | 23544 local := valueWithContinuation value. 23545 oc add: local first. 23546 local last notNil] 23547 whileTrue: []. 23548 oc. 23549 ]. 23550 23551 ^collector value: (processor value: (processor value: (stream value: aCollection) 23552 value: [:x | x * x]) 23553 value: [:x | x - 10]).! ! 23554 23555!BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:44'! 23556example1: anInteger 23557 23558 " this example is very simple. A named block recursively computes the factorial. 23559 The example tests whether the value of x is still available after the recursive call. 23560 Note that the recursive call precedes the multiplication. For the purpose of the test 23561 this is essential. (When you commute the factors, the example will work also in 23562 some system without block closures, but not in Squeak.) " 23563 23564 | factorial | 23565 23566 factorial := [:x | x = 1 ifTrue: [1] 23567 ifFalse: [(factorial value: x - 1)* x]]. 23568 ^ factorial value: anInteger 23569 23570 23571 ! ! 23572 23573!BlockClosuresTestCase methodsFor: 'examples' stamp: 'lr 3/31/2009 09:31'! 23574example2: anInteger 23575 23576 " BlockClosuresTestCase new example2: 6" 23577 " to complicate the example1, we set up a dynamic reference chain that is 23578 used to dump all calls of facorial when recursion depth is maximal. 23579 The return value is an instance of orderedCollection, the trace. " 23580 23581 | factorial trace | 23582 23583 trace := OrderedCollection new. 23584 factorial := 23585 [:x :dumper :trace2 | | localDumper | 23586 localDumper := [ :collection | 23587 collection add: x. 23588 dumper value: collection.]. 23589 x = 1 ifTrue: 23590 [localDumper value: trace2. 23591 1] 23592 ifFalse: 23593 [(factorial value: x - 1 23594 value: localDumper 23595 value: trace2)* x. 23596 ] 23597 ]. 23598 factorial value: anInteger 23599 value: [ :collection | ] 23600 value: trace. 23601 ^trace! ! 23602 23603!BlockClosuresTestCase methodsFor: 'examples' stamp: 'PeterHugossonMiller 9/2/2009 16:19'! 23604nestedLoopsExample: arrays 23605 23606 " A while ago, Hans Baveco asked for a way to 23607 dynamically nest loops. Better solutions than this one 23608 were proposed, but this one is a beautiful test for 23609 recursive block usage. " 23610 23611 | result sizeOfResult streams block | 23612 23613 23614"arrays := OrderedCollection new. 23615arrays add: #(#a #b); 23616 add: #(1 2 3 4); 23617 add: #('w' 'x' 'y' 'z')." 23618sizeOfResult := 23619 arrays inject: 1 into: 23620 [:prod :array | prod * array size]. 23621streams := arrays collect: 23622 [:a | a readStream]. " This is an OrderedCollection of Streams " 23623 23624result := OrderedCollection new: sizeOfResult. 23625block := 23626 [:r :tupel :allStreams | | innerBlock | 23627 innerBlock := 23628 [:myIdx | 23629 [myIdx = allStreams size 23630 ifTrue: [1 to: allStreams size do: 23631 [:i | tupel at: i put: (allStreams at: i) peek]. 23632 r addLast: tupel shallowCopy] 23633 ifFalse: [innerBlock value: myIdx + 1]. 23634 (allStreams at: myIdx) next. 23635 (allStreams at: myIdx) atEnd 23636 ] 23637 whileFalse: []. 23638 (allStreams at: myIdx) reset. 23639 ]. 23640 innerBlock value: 1. 23641 r 23642 ]. 23643 block value: result 23644 value: (Array new: streams size) " this is a buffer " 23645 value: streams. 23646 23647 ^result 23648! ! 23649 23650 23651!BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: 'BG 1/25/2002 10:01'! 23652comment 23653 23654 " The Jensen device was something very sophisticated in the days of Algol 60. 23655Essentially it was tricky use of a parameter passing policy that was called 'call by name'. In modern terminology, a call by name parameter was a pair of blocks (in a system with full block closures, of course.) 23656 23657For the lovers of Algol 60, here is a short example: 23658 23659 BEGIN 23660 REAL PROCEDURE JensenSum (A, I, N); 23661 REAL A; INTEGER I, N; 23662 BEGIN 23663 REAL S; 23664 S := 0.0; 23665 FOR I := 1 STEP 1 UNTIL N DO S := S + A; 23666 JensenSum := S; 23667 END; 23668 23669 ARRAY X [1:10], Y[1:10, 1:10]; 23670 COMMENT Do array initialization here ; 23671 23672 JensenSum (X[I], I, 10); 23673 JensenSum (Y[I, I], I, 10); 23674 JensenSum(JensenSum(Y[I, J], J, 10), I, 10); 23675END; 23676 23677The first call sums the elements of X, the second sums the diagonal elements of Y and the third call sums up all elements of Y. 23678 23679It is possible to reimplement all this with blocks only and that is what is done in the jensen device examples. 23680 23681Additional remark: 23682The Jensen device was something for clever minds. I remember an artice written by Donald Knuth and published in the Communications of the ACM (I think in 1962, but I may err) about that programming trick. That article showed how a simple procedure (called the general problem solver) could be used to do almost anything. The problem was of course to find out the right parameters. I seached my collection of photocopies for that article, but regrettably I could not find it. Perhaps I can find it later. 23683 "! ! 23684 23685!BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: 'BG 1/24/2002 18:00'! 23686gpsExample1: aCollection 23687 23688 " BlockClosuresTestCase new gpsExample1: (1 to: 100) asArray" 23689 23690 | gps i s | 23691 23692 gps := [:idx :exp :sum | | cnt | 23693 cnt := 1. 23694 sum first value: 0. 23695 [idx first value: cnt. 23696 sum first value: (sum last value + exp last value). 23697 cnt := cnt + 1. 23698 cnt <= aCollection size] whileTrue: [ ]. 23699 sum last value 23700 ]. 23701 23702 23703 ^gps value: (Array with: [:val | i := val] 23704 with: [ i]) 23705 value: (Array with: [:val | aCollection at: i put: val] 23706 with: [ aCollection at: i]) 23707 value: (Array with: [:val | s := val] 23708 with: [ s]) 23709! ! 23710 23711!BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: 'BG 1/25/2002 10:03'! 23712gpsExample2: aCollection 23713 23714 " BlockClosuresTestCase new 23715 gpsExample2: #(#(1 2 3 4 5) #(6 7 8 9 10) #(11 12 13 14 15) #(16 17 18 19 20) #(21 22 23 24 25))" 23716 23717 | js i j | 23718 23719 " js is the translation of the Algol procedure from method comment. " 23720 js := [:a :idx :n | | sum | 23721 sum := 0. 23722 idx first value: 1. 23723 [idx last value <= n last value] 23724 whileTrue: 23725 [sum := sum + a last value. 23726 idx first value: idx last value + 1.]. 23727 sum 23728 ]. 23729 23730 " This is the most complicated call that is mentioned in method comment. Note that js is called recursively. " 23731 23732 ^ js value: (Array with: [:val | self error: 'can not assign to procedure'] 23733 with: [ js value: (Array with: [:val | (aCollection at: i) at: j put: val] 23734 with: [ (aCollection at: i) at: j]) 23735 value: (Array with:[:val | j := val] 23736 with: [ j]) 23737 value: (Array with: [:val | self error: 'can not assign to constant'] 23738 with: [ aCollection size]) 23739 ] 23740 ) 23741 value: (Array with:[:val | i := val] 23742 with: [ i]) 23743 value: (Array with: [:val | self error: 'can not assign to constant'] 23744 with: [ aCollection size]) 23745 23746! ! 23747 23748 23749!BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:22'! 23750testCannotReturn 23751 23752 | blk | 23753 blk := self constructCannotReturnBlockInDeadFrame. 23754 self 23755 should: [blk value: 1] 23756 raise: Exception 23757! ! 23758 23759!BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:45'! 23760testContinuationExample1 23761 23762 | array | 23763 array := (1 to: 20) asOrderedCollection. 23764 self assert: ((self continuationExample1: array) = array) 23765 ! ! 23766 23767!BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:45'! 23768testContinuationExample2 23769 23770 | array | 23771 array := (1 to: 20) asOrderedCollection. 23772 self assert: ((self continuationExample2: array) = (array collect: [:x | x * x])) 23773 ! ! 23774 23775!BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:45'! 23776testContinuationExample3 23777 23778 | array | 23779 array := (1 to: 20) asOrderedCollection. 23780 self assert: ((self continuationExample3: array) = (array collect: [:x | x * x - 10])) 23781 ! ! 23782 23783!BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 16:05'! 23784testExample1 23785 23786 self assert: ((self example1: 5) = 5 factorial) 23787 ! ! 23788 23789!BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 18:28'! 23790testExample2 23791 23792 self assert: ((self example2: 5) = (1 to: 5) asOrderedCollection) 23793 ! ! 23794 23795!BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:59'! 23796testGpsExample1 23797 23798 | result array | 23799 23800 array := (1 to: 100) asArray. 23801 result := array inject: 0 23802 into: [:sum :val | sum + val]. 23803 self assert: ((self gpsExample1: array) = result) 23804 ! ! 23805 23806!BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/25/2002 09:57'! 23807testGpsExample2 23808 23809 | result array | 23810 23811 " integer matrix elements should be used for the purpose of this test. " 23812 array := #(#(1 2 3 4 5) #(6 7 8 9 10) #(11 12 13 14 15) #(16 17 18 19 20) #(21 22 23 24 25)). 23813 result := array inject: 0 23814 into: [:sum :subarray | 23815 sum + (subarray inject: 0 23816 into: [:s :elem | s + elem])]. 23817 self assert: ((self gpsExample2: array) = result) 23818 ! ! 23819 23820!BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 16:40'! 23821testNestedLoopsExample1 23822 23823 | arrays result | 23824 arrays := OrderedCollection new. 23825 arrays add: #(#a #b); 23826 add: #(1 2 3 4); 23827 add: #('w' 'x' 'y' 'z'). 23828 result := OrderedCollection new. 23829 CollectionCombinator new 23830 forArrays: arrays 23831 processWith: [:item |result addLast: item]. 23832 self assert: ((self nestedLoopsExample: arrays) = result) 23833 ! ! 23834 23835!BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:17'! 23836testReentrantBlock 23837 23838 | fib | 23839 fib := [:val | 23840 (val <= 0) ifTrue: [self error: 'not a natural number']. 23841 (val <= 2) 23842 ifTrue: [1] 23843 ifFalse: [(fib value: (val - 1)) + (fib value: (val - 2))]]. 23844 23845 self 23846 should: [fib value: 0] 23847 raise: TestResult error. 23848 self assert: ((fib value: 1) == 1). 23849 self assert: ((fib value: 2) == 1). 23850 self assert: ((fib value: 3) == 2). 23851 self assert: ((fib value: 4) == 3). 23852 self assert: ((fib value: 5) == 5). 23853 self assert: ((fib value: 6) == 8). 23854! ! 23855 23856!BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:17'! 23857testReentrantBlockOldEnvironment 23858 23859 | fib | 23860 fib := self constructFibonacciBlockInDeadFrame. 23861 self 23862 should: [fib value: 0] 23863 raise: TestResult error. 23864 self assert: ((fib value: 1) == 1). 23865 self assert: ((fib value: 2) == 1). 23866 self assert: ((fib value: 3) == 2). 23867 self assert: ((fib value: 4) == 3). 23868 self assert: ((fib value: 5) == 5). 23869 self assert: ((fib value: 6) == 8). 23870! ! 23871 23872!BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:18'! 23873testReentrantBlockOldEnvironmentWithBlockArguement 23874 23875 | fib | 23876 fib := self constructFibonacciBlockWithBlockArgumentInDeadFrame. 23877 self 23878 should: [fib value: 0 value: fib] 23879 raise: TestResult error. 23880 self assert: ((fib value: 1 value: fib) == 1). 23881 self assert: ((fib value: 2 value: fib) == 1). 23882 self assert: ((fib value: 3 value: fib) == 2). 23883 self assert: ((fib value: 4 value: fib) == 3). 23884 self assert: ((fib value: 5 value: fib) == 5). 23885 self assert: ((fib value: 6 value: fib) == 8). 23886! ! 23887 23888!BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:18'! 23889testSharedClosureEnvironment 23890 |blockArray| 23891 blockArray := self constructSharedClosureEnvironmentInDeadFrame. 23892 self assert: ((blockArray at: 2) value == 10). 23893 self assert: (((blockArray at: 1) value: 5) == 5). 23894 self assert: ((blockArray at: 2) value == 5). 23895! ! 23896ContextPart variableSubclass: #BlockContext 23897 instanceVariableNames: 'nargs startpc home' 23898 classVariableNames: '' 23899 poolDictionaries: '' 23900 category: 'Kernel-Methods'! 23901!BlockContext commentStamp: '<historical>' prior: 0! 23902My instances function similarly to instances of MethodContext, but they hold the dynamic state for execution of a block in Smalltalk. They access all temporary variables and the method sender via their home pointer, so that those values are effectively shared. Their indexable part is used to store their independent value stack during execution. 23903 23904My instance must hold onto its home in order to work. This can cause circularities if the home is also pointing (via a temp, perhaps) to the instance. In the rare event that this happens (as in SortedCollection sortBlock:) the message fixTemps will replace home with a copy of home, thus defeating the sharing of temps but, nonetheless, eliminating the circularity. 23905 23906BlockContexts must only be created using the method newForMethod:. Note that it is impossible to determine the real object size of a BlockContext except by asking for the frameSize of its method. Any fields above the stack pointer (stackp) are truly invisible -- even (and especially!!) to the garbage collector. Any store into stackp other than by the primitive method stackp: is potentially fatal.! 23907 23908 23909!BlockContext methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/26/2005 16:16'! 23910asMinimalRepresentation 23911 "Answer the receiver." 23912 23913 ^self! ! 23914 23915!BlockContext methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/26/2005 15:52'! 23916isValid 23917 "Answer true so we can be used in event dispatching." 23918 23919 ^true! ! 23920 23921 23922!BlockContext methodsFor: '*services-base' stamp: 'rr 3/21/2006 11:53'! 23923valueWithRequestor: aRequestor 23924 "To do later: make the fillInTheBlank display more informative captions. 23925 Include the description of the service, and maybe record steps" 23926 23927 ^ self numArgs isZero 23928 ifTrue: [self value] 23929 ifFalse: [self value: aRequestor]! ! 23930 23931 23932!BlockContext methodsFor: '*splitjoin' stamp: 'onierstrasz 4/12/2009 20:12'! 23933split: aSequenceableCollection 23934 | result position | 23935 result := OrderedCollection new. 23936 position := 1. 23937 aSequenceableCollection 23938 withIndexDo: [:element :idx | 23939 (self value: element) 23940 ifTrue: [result add: (aSequenceableCollection copyFrom: position to: idx - 1). 23941 position := idx + 1]]. 23942 result add: (aSequenceableCollection copyFrom: position to: aSequenceableCollection size). 23943 ^ result! ! 23944 23945 23946!BlockContext methodsFor: 'accessing' stamp: 'eem 5/28/2008 10:43'! 23947activeHome 23948 "Search senders for the home context. If the home 23949 context is not found on the sender chain answer nil." 23950 ^self caller findContextSuchThat: [:ctxt | ctxt = home]! ! 23951 23952!BlockContext methodsFor: 'accessing' stamp: 'GabrielOmarCotelli 5/25/2009 15:52'! 23953argumentCount 23954 23955 "Added for ANSI compatibility." 23956 ^ self numArgs! ! 23957 23958!BlockContext methodsFor: 'accessing' stamp: 'eem 5/29/2008 13:14'! 23959caller 23960 ^sender! ! 23961 23962!BlockContext methodsFor: 'accessing' stamp: 'eem 5/24/2008 11:20'! 23963closureHome 23964 "Answer the context from which an ^-return should return from." 23965 23966 ^self home! ! 23967 23968!BlockContext methodsFor: 'accessing' stamp: 'eem 6/15/2008 11:32'! 23969contextForLocalVariables 23970 "Answer the context in which local variables (temporaries) are stored." 23971 23972 ^home! ! 23973 23974!BlockContext methodsFor: 'accessing' stamp: 'di 9/9/2000 10:44'! 23975copyForSaving 23976 "Fix the values of the temporary variables used in the block that are 23977 ordinarily shared with the method in which the block is defined." 23978 23979 home := home copy. 23980 home swapSender: nil! ! 23981 23982!BlockContext methodsFor: 'accessing'! 23983fixTemps 23984 "Fix the values of the temporary variables used in the block that are 23985 ordinarily shared with the method in which the block is defined." 23986 23987 home := home copy. 23988 home swapSender: nil! ! 23989 23990!BlockContext methodsFor: 'accessing' stamp: 'md 4/27/2006 15:14'! 23991hasInstVarRef 23992 "Answer whether the receiver references an instance variable." 23993 23994 | method scanner end printer | 23995 23996 home ifNil: [^false]. 23997 method := self method. 23998 end := self endPC. 23999 scanner := InstructionStream new method: method pc: startpc. 24000 printer := InstVarRefLocator new. 24001 24002 [scanner pc <= end] whileTrue: [ 24003 (printer interpretNextInstructionUsing: scanner) ifTrue: [^true]. 24004 ]. 24005 ^false! ! 24006 24007!BlockContext methodsFor: 'accessing'! 24008hasMethodReturn 24009 "Answer whether the receiver has a return ('^') in its code." 24010 24011 | method scanner end | 24012 method := self method. 24013 "Determine end of block from long jump preceding it" 24014 end := (method at: startpc-2)\\16-4*256 + (method at: startpc-1) + startpc - 1. 24015 scanner := InstructionStream new method: method pc: startpc. 24016 scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]]. 24017 ^scanner pc <= end! ! 24018 24019!BlockContext methodsFor: 'accessing'! 24020home 24021 "Answer the context in which the receiver was defined." 24022 24023 ^home! ! 24024 24025!BlockContext methodsFor: 'accessing' stamp: 'ajh 1/21/2003 13:16'! 24026isBlock 24027 24028 ^ true! ! 24029 24030!BlockContext methodsFor: 'accessing' stamp: 'ajh 1/31/2003 12:12'! 24031isExecutingBlock 24032 24033 ^ true! ! 24034 24035!BlockContext methodsFor: 'accessing'! 24036method 24037 "Answer the compiled method in which the receiver was defined." 24038 24039 ^home method! ! 24040 24041!BlockContext methodsFor: 'accessing' stamp: 'eem 6/15/2008 11:33'! 24042methodReturnContext 24043 "Answer the context from which an ^-return should return from." 24044 24045 ^home! ! 24046 24047!BlockContext methodsFor: 'accessing' stamp: 'mdr 4/10/2001 10:34'! 24048numArgs 24049 "Answer the number of arguments that must be used to evaluate this block" 24050 24051 ^nargs! ! 24052 24053!BlockContext methodsFor: 'accessing'! 24054receiver 24055 "Refer to the comment in ContextPart|receiver." 24056 24057 ^home receiver! ! 24058 24059!BlockContext methodsFor: 'accessing' stamp: 'ajh 1/30/2003 15:45'! 24060reentrant 24061 "Copy before calling so multiple activations can exist" 24062 24063 ^ self copy! ! 24064 24065!BlockContext methodsFor: 'accessing'! 24066tempAt: index 24067 "Refer to the comment in ContextPart|tempAt:." 24068 24069 ^home at: index! ! 24070 24071!BlockContext methodsFor: 'accessing'! 24072tempAt: index put: value 24073 "Refer to the comment in ContextPart|tempAt:put:." 24074 24075 ^home at: index put: value! ! 24076 24077!BlockContext methodsFor: 'accessing' stamp: 'md 2/9/2007 19:11'! 24078tempNamed: aName 24079 ^self home tempNamed: aName! ! 24080 24081!BlockContext methodsFor: 'accessing' stamp: 'md 2/9/2007 19:12'! 24082tempNamed: aName put: anObject 24083 ^self home tempNamed: aName put: anObject! ! 24084 24085 24086!BlockContext methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:45'! 24087doWhileFalse: conditionBlock 24088 "Evaluate the receiver once, then again as long the value of conditionBlock is false." 24089 24090 | result | 24091 [result := self value. 24092 conditionBlock value] whileFalse. 24093 24094 ^ result! ! 24095 24096!BlockContext methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:39'! 24097doWhileTrue: conditionBlock 24098 "Evaluate the receiver once, then again as long the value of conditionBlock is true." 24099 24100 | result | 24101 [result := self value. 24102 conditionBlock value] whileTrue. 24103 24104 ^ result! ! 24105 24106!BlockContext methodsFor: 'controlling' stamp: 'sma 5/12/2000 13:22'! 24107repeat 24108 "Evaluate the receiver repeatedly, ending only if the block explicitly returns." 24109 24110 [self value. true] whileTrue! ! 24111 24112!BlockContext methodsFor: 'controlling' stamp: 'ls 9/24/1999 09:45'! 24113repeatWithGCIf: testBlock 24114 | ans | 24115 "run the receiver, and if testBlock returns true, garbage collect and run the receiver again" 24116 ans := self value. 24117 (testBlock value: ans) ifTrue: [ Smalltalk garbageCollect. ans := self value ]. 24118 ^ans! ! 24119 24120!BlockContext methodsFor: 'controlling'! 24121whileFalse 24122 "Ordinarily compiled in-line, and therefore not overridable. 24123 This is in case the message is sent to other than a literal block. 24124 Evaluate the receiver, as long as its value is false." 24125 24126 ^ [self value] whileFalse: []! ! 24127 24128!BlockContext methodsFor: 'controlling'! 24129whileFalse: aBlock 24130 "Ordinarily compiled in-line, and therefore not overridable. 24131 This is in case the message is sent to other than a literal block. 24132 Evaluate the argument, aBlock, as long as the value of the receiver is false." 24133 24134 ^ [self value] whileFalse: [aBlock value]! ! 24135 24136!BlockContext methodsFor: 'controlling'! 24137whileTrue 24138 "Ordinarily compiled in-line, and therefore not overridable. 24139 This is in case the message is sent to other than a literal block. 24140 Evaluate the receiver, as long as its value is true." 24141 24142 ^ [self value] whileTrue: []! ! 24143 24144!BlockContext methodsFor: 'controlling'! 24145whileTrue: aBlock 24146 "Ordinarily compiled in-line, and therefore not overridable. 24147 This is in case the message is sent to other than a literal block. 24148 Evaluate the argument, aBlock, as long as the value of the receiver is true." 24149 24150 ^ [self value] whileTrue: [aBlock value]! ! 24151 24152 24153!BlockContext methodsFor: 'evaluating' stamp: 'cmm 2/16/2003 16:08'! 24154bench 24155 "See how many times I can value in 5 seconds. I'll answer a meaningful description." 24156 24157 | startTime endTime count | 24158 count := 0. 24159 endTime := Time millisecondClockValue + 5000. 24160 startTime := Time millisecondClockValue. 24161 [ Time millisecondClockValue > endTime ] whileFalse: [ self value. count := count + 1 ]. 24162 endTime := Time millisecondClockValue. 24163 ^count = 1 24164 ifTrue: [ ((endTime - startTime) // 1000) printString, ' seconds.' ] 24165 ifFalse: 24166 [ ((count * 1000) / (endTime - startTime)) asFloat printString, ' per second.' ]! ! 24167 24168!BlockContext methodsFor: 'evaluating' stamp: 'brp 9/25/2003 13:49'! 24169durationToRun 24170 "Answer the duration taken to execute this block." 24171 24172 ^ Duration milliSeconds: self timeToRun 24173 24174 ! ! 24175 24176!BlockContext methodsFor: 'evaluating' stamp: 'ajh 1/13/2002 13:36'! 24177ifError: errorHandlerBlock 24178 "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." 24179 "Examples: 24180 [1 whatsUpDoc] ifError: [:err :rcvr | 'huh?']. 24181 [1 / 0] ifError: [:err :rcvr | 24182 'ZeroDivide' = err 24183 ifTrue: [Float infinity] 24184 ifFalse: [self error: err]] 24185" 24186 24187 ^ self on: Error do: [:ex | 24188 errorHandlerBlock valueWithPossibleArgs: {ex description. ex receiver}]! ! 24189 24190!BlockContext methodsFor: 'evaluating' stamp: 'jm 6/3/1998 14:25'! 24191timeToRun 24192 "Answer the number of milliseconds taken to execute this block." 24193 24194 ^ Time millisecondsToRun: self 24195! ! 24196 24197!BlockContext methodsFor: 'evaluating'! 24198value 24199 "Primitive. Evaluate the block represented by the receiver. Fail if the 24200 block expects any arguments or if the block is already being executed. 24201 Optional. No Lookup. See Object documentation whatIsAPrimitive." 24202 24203 <primitive: 81> 24204 ^self valueWithArguments: #()! ! 24205 24206!BlockContext methodsFor: 'evaluating' stamp: 'nk 3/11/2001 11:49'! 24207valueWithEnoughArguments: anArray 24208 "call me with enough arguments from anArray" 24209 | args | 24210 (anArray size == self numArgs) 24211 ifTrue: [ ^self valueWithArguments: anArray ]. 24212 24213 args := Array new: self numArgs. 24214 args replaceFrom: 1 24215 to: (anArray size min: args size) 24216 with: anArray 24217 startingAt: 1. 24218 24219 ^ self valueWithArguments: args! ! 24220 24221!BlockContext methodsFor: 'evaluating' stamp: 'md 3/28/2006 20:17'! 24222valueWithExit 24223 self value: [ ^nil ]! ! 24224 24225!BlockContext methodsFor: 'evaluating'! 24226value: arg 24227 "Primitive. Evaluate the block represented by the receiver. Fail if the 24228 block expects other than one argument or if the block is already being 24229 executed. Optional. No Lookup. See Object documentation 24230 whatIsAPrimitive." 24231 24232 <primitive: 81> 24233 ^self valueWithArguments: (Array with: arg)! ! 24234 24235!BlockContext methodsFor: 'evaluating'! 24236value: arg1 value: arg2 24237 "Primitive. Evaluate the block represented by the receiver. Fail if the 24238 block expects other than two arguments or if the block is already being 24239 executed. Optional. See Object documentation whatIsAPrimitive." 24240 24241 <primitive: 81> 24242 ^self valueWithArguments: (Array with: arg1 with: arg2)! ! 24243 24244!BlockContext methodsFor: 'evaluating'! 24245value: arg1 value: arg2 value: arg3 24246 "Primitive. Evaluate the block represented by the receiver. Fail if the 24247 block expects other than three arguments or if the block is already being 24248 executed. Optional. See Object documentation whatIsAPrimitive." 24249 24250 <primitive: 81> 24251 ^self valueWithArguments: 24252 (Array 24253 with: arg1 24254 with: arg2 24255 with: arg3)! ! 24256 24257!BlockContext methodsFor: 'evaluating' stamp: 'di 11/30/97 09:19'! 24258value: arg1 value: arg2 value: arg3 value: arg4 24259 "Primitive. Evaluate the block represented by the receiver. Fail if the 24260 block expects other than three arguments or if the block is already being 24261 executed. Optional. See Object documentation whatIsAPrimitive." 24262 24263 <primitive: 81> 24264 ^self valueWithArguments: 24265 (Array 24266 with: arg1 24267 with: arg2 24268 with: arg3 24269 with: arg4)! ! 24270 24271!BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/10/2004 22:28'! 24272valueSupplyingAnswer: anObject 24273 24274 ^ (anObject isCollection and: [anObject isString not]) 24275 ifTrue: [self valueSupplyingAnswers: {anObject}] 24276 ifFalse: [self valueSupplyingAnswers: {{'*'. anObject}}]! ! 24277 24278!BlockContext methodsFor: 'evaluating' stamp: 'NicolasCellier 10/28/2008 00:43'! 24279valueSupplyingAnswers: aListOfPairs 24280 "evaluate the block using a list of questions / answers that might be called upon to 24281 automatically respond to Object>>confirm: or FillInTheBlank requests" 24282 24283 ^ [self value] 24284 on: ProvideAnswerNotification 24285 do: 24286 [:notify | | answer caption | 24287 24288 caption := notify messageText withSeparatorsCompacted. "to remove new lines" 24289 answer := aListOfPairs 24290 detect: 24291 [:each | caption = each first or: 24292 [(caption includesSubstring: each first caseSensitive: false) or: 24293 [(each first match: caption) or: 24294 [(String includesSelector: #matchesRegex:) and: [caption matchesRegex: each first]]]]] 24295 ifNone: [nil]. 24296 answer 24297 ifNotNil: [notify resume: answer second] 24298 ifNil: 24299 [ | outerAnswer | 24300 outerAnswer := ProvideAnswerNotification signal: notify messageText. 24301 outerAnswer 24302 ifNil: [notify resume] 24303 ifNotNil: [notify resume: outerAnswer]]]! ! 24304 24305!BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/10/2004 22:28'! 24306valueSuppressingAllMessages 24307 24308 ^ self valueSuppressingMessages: #('*')! ! 24309 24310!BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/4/2004 18:59'! 24311valueSuppressingMessages: aListOfStrings 24312 24313 ^ self 24314 valueSuppressingMessages: aListOfStrings 24315 supplyingAnswers: #()! ! 24316 24317!BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/4/2004 18:58'! 24318valueSuppressingMessages: aListOfStrings supplyingAnswers: aListOfPairs 24319 24320 ^ self valueSupplyingAnswers: aListOfPairs, (aListOfStrings collect: [:each | {each. true}])! ! 24321 24322!BlockContext methodsFor: 'evaluating' stamp: 'md 7/30/2005 21:22'! 24323valueWithArguments: anArray 24324 "Primitive. Evaluate the block represented by the receiver. The argument 24325 is an Array whose elements are the arguments for the block. Fail if the 24326 length of the Array is not the same as the the number of arguments that 24327 the block was expecting. Fail if the block is already being executed. 24328 Essential. See Object documentation whatIsAPrimitive." 24329 24330 <primitive: 82> 24331 24332 anArray isArray ifFalse: [^self error: 'valueWithArguments: expects an array']. 24333 self numArgs = anArray size 24334 ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.'] 24335 ifFalse: [self error: 24336 'This block accepts ' ,self numArgs printString, ' argument', (self numArgs = 1 ifTrue:[''] ifFalse:['s']) , 24337 ', but was called with ', anArray size printString, '.'] 24338 24339! ! 24340 24341!BlockContext methodsFor: 'evaluating' stamp: 'md 10/7/2004 15:24'! 24342valueWithPossibleArgs: anArray 24343 24344 "Evaluate the block represented by the receiver. 24345 If the block requires arguments, take them from anArray. If anArray is too 24346 large, the rest is ignored, if it is too small, use nil for the other arguments" 24347 24348 self numArgs = 0 ifTrue: [^self value]. 24349 self numArgs = anArray size ifTrue: [^self valueWithArguments: anArray]. 24350 self numArgs > anArray size ifTrue: [ 24351 ^self valueWithArguments: anArray, 24352 (Array new: (self numArgs - anArray size)) 24353 ]. 24354 ^self valueWithArguments: (anArray copyFrom: 1 to: self numArgs) 24355 24356! ! 24357 24358!BlockContext methodsFor: 'evaluating' stamp: 'md 10/7/2004 15:26'! 24359valueWithPossibleArgument: anArg 24360 24361 "Evaluate the block represented by the receiver. 24362 If the block requires one argument, use anArg, if it requires more than one, 24363 fill up the rest with nils." 24364 24365 self numArgs = 0 ifTrue: [^self value]. 24366 self numArgs = 1 ifTrue: [^self value: anArg]. 24367 self numArgs > 1 ifTrue: [^self valueWithArguments: {anArg}, (Array new: self numArgs - 1)]! ! 24368 24369!BlockContext methodsFor: 'evaluating' stamp: 'ar 8/17/2007 13:15'! 24370valueWithin: aDuration onTimeout: timeoutBlock 24371 "Evaluate the receiver. 24372 If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead" 24373 24374 | theProcess delay watchdog | 24375 24376 aDuration <= Duration zero ifTrue: [^ timeoutBlock value ]. 24377 24378 "the block will be executed in the current process" 24379 theProcess := Processor activeProcess. 24380 delay := aDuration asDelay. 24381 24382 "make a watchdog process" 24383 watchdog := [ 24384 delay wait. "wait for timeout or completion" 24385 theProcess ifNotNil:[ theProcess signalException: TimedOut ] 24386 ] newProcess. 24387 24388 "Watchdog needs to run at high priority to do its job (but not at timing priority)" 24389 watchdog priority: Processor timingPriority-1. 24390 24391 "catch the timeout signal" 24392 ^ [ watchdog resume. "start up the watchdog" 24393 self ensure:[ "evaluate the receiver" 24394 theProcess := nil. "it has completed, so ..." 24395 delay delaySemaphore signal. "arrange for the watchdog to exit" 24396 ]] on: TimedOut do: [ :e | timeoutBlock value ]. 24397! ! 24398 24399 24400!BlockContext methodsFor: 'exceptions' stamp: 'sma 5/11/2000 19:38'! 24401assert 24402 self assert: self! ! 24403 24404!BlockContext methodsFor: 'exceptions' stamp: 'ajh 3/4/2004 22:36'! 24405ensure: aBlock 24406 "Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes." 24407 24408 | returnValue b | 24409 <primitive: 198> 24410 returnValue := self value. 24411 "aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated" 24412 aBlock == nil ifFalse: [ 24413 "nil out aBlock temp before evaluating aBlock so it is not executed again if aBlock remote returns" 24414 b := aBlock. 24415 thisContext tempAt: 1 put: nil. "aBlock := nil" 24416 b value. 24417 ]. 24418 ^ returnValue! ! 24419 24420!BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 21:43'! 24421ifCurtailed: aBlock 24422 "Evaluate the receiver with an abnormal termination action." 24423 24424 <primitive: 198> 24425 ^ self value! ! 24426 24427!BlockContext methodsFor: 'exceptions' stamp: 'ar 3/6/2001 14:25'! 24428on: exception do: handlerAction 24429 "Evaluate the receiver in the scope of an exception handler." 24430 | handlerActive | 24431 <primitive: 199> 24432 handlerActive := true. 24433 ^self value! ! 24434 24435!BlockContext methodsFor: 'exceptions' stamp: 'ajh 10/9/2001 16:51'! 24436onDNU: selector do: handleBlock 24437 "Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)" 24438 24439 ^ self on: MessageNotUnderstood do: [:exception | 24440 exception message selector = selector 24441 ifTrue: [handleBlock valueWithPossibleArgs: {exception}] 24442 ifFalse: [exception pass] 24443 ]! ! 24444 24445!BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 21:53'! 24446valueUninterruptably 24447 "Temporarily make my home Context unable to return control to its sender, to guard against circumlocution of the ensured behavior." 24448 24449 ^ self ifCurtailed: [^ self]! ! 24450 24451 24452!BlockContext methodsFor: 'initialize-release' stamp: 'ls 6/21/2000 17:42'! 24453home: aContextPart startpc: position nargs: anInteger 24454 "This is the initialization message. The receiver has been initialized with 24455 the correct size only." 24456 24457 home := aContextPart. 24458 pc := startpc := position. 24459 nargs := anInteger. 24460 stackp := 0.! ! 24461 24462!BlockContext methodsFor: 'initialize-release' stamp: 'ajh 7/18/2003 21:49'! 24463privRefresh 24464 "Reinitialize the receiver so that it is in the state it was at its creation." 24465 24466 pc := startpc. 24467 self stackp: 0. 24468 nargs timesRepeat: [ "skip arg popping" 24469 self nextInstruction selector = #popIntoTemporaryVariable: 24470 ifFalse: [self halt: 'unexpected bytecode instruction'] 24471 ]. 24472! ! 24473 24474 24475!BlockContext methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:35'! 24476blockReturnTop 24477 "Simulate the interpreter's action when a ReturnTopOfStack bytecode is 24478 encountered in the receiver." 24479 24480 | save dest | 24481 save := home. "Needed because return code will nil it" 24482 dest := self return: self pop from: self. 24483 home := save. 24484 sender := nil. 24485 ^ dest! ! 24486 24487 24488!BlockContext methodsFor: 'printing' stamp: 'md 2/22/2006 15:53'! 24489decompile 24490 ^ home method decompilerClass new decompileBlock: self! ! 24491 24492!BlockContext methodsFor: 'printing' stamp: 'md 2/20/2006 13:46'! 24493decompileString 24494 ^self decompile decompileString.! ! 24495 24496!BlockContext methodsFor: 'printing' stamp: 'eem 7/28/2008 14:10'! 24497fullPrintOn: aStream 24498 aStream print: self; cr. 24499 (self decompile ifNil: ['--source missing--']) printOn: aStream indent: 0! ! 24500 24501!BlockContext methodsFor: 'printing' stamp: 'eem 5/16/2008 12:03'! 24502printOn: aStream 24503 | decompilation blockString truncatedBlockString | 24504 24505 home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil']. 24506 aStream nextPutAll: '[] in '. 24507 super printOn: aStream. 24508 decompilation := [self decompile ifNil: ['--source missing--']] 24509 on: Error 24510 do: [:ex| ' (error in decompilation)']. 24511 blockString := ((decompilation isString 24512 ifTrue: [decompilation] 24513 ifFalse: [decompilation printString]) 24514 replaceAll: Character cr with: Character space) 24515 replaceAll: Character tab with: Character space. 24516 truncatedBlockString := blockString truncateWithElipsisTo: 80. 24517 truncatedBlockString size < blockString size ifTrue: 24518 [truncatedBlockString := truncatedBlockString, ']}']. 24519 aStream space; nextPutAll: truncatedBlockString! ! 24520 24521!BlockContext methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:01'! 24522printOnStream: aStream 24523 24524 home == nil ifTrue: [^aStream print: 'a BlockContext with home=nil']. 24525 aStream print: '[] in '. 24526 super printOnStream: aStream! ! 24527 24528 24529!BlockContext methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:23'! 24530asContext 24531 24532 ^ self! ! 24533 24534!BlockContext methodsFor: 'scheduling' stamp: 'di 9/12/1998 11:53'! 24535fork 24536 "Create and schedule a Process running the code in the receiver." 24537 24538 ^ self newProcess resume! ! 24539 24540!BlockContext methodsFor: 'scheduling' stamp: 'ajh 10/16/2002 11:14'! 24541forkAndWait 24542 "Suspend current process and execute self in new process, when it completes resume current process" 24543 24544 | semaphore | 24545 semaphore := Semaphore new. 24546 [self ensure: [semaphore signal]] fork. 24547 semaphore wait. 24548! ! 24549 24550!BlockContext methodsFor: 'scheduling' stamp: 'jm 11/9/1998 10:16'! 24551forkAt: priority 24552 "Create and schedule a Process running the code in the receiver at the given priority. Answer the newly created process." 24553 24554 | forkedProcess | 24555 forkedProcess := self newProcess. 24556 forkedProcess priority: priority. 24557 ^ forkedProcess resume 24558! ! 24559 24560!BlockContext methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! 24561forkAt: priority named: name 24562 "Create and schedule a Process running the code in the receiver at the 24563 given priority and having the given name. Answer the newly created 24564 process." 24565 24566 | forkedProcess | 24567 forkedProcess := self newProcess. 24568 forkedProcess priority: priority. 24569 forkedProcess name: name. 24570 ^ forkedProcess resume! ! 24571 24572!BlockContext methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! 24573forkNamed: aString 24574 "Create and schedule a Process running the code in the receiver and 24575 having the given name." 24576 24577 ^ self newProcess name: aString; resume! ! 24578 24579!BlockContext methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:25'! 24580newProcess 24581 "Answer a Process running the code in the receiver. The process is not 24582 scheduled." 24583 <primitive: 19> "Simulation guard" 24584 ^Process 24585 forContext: 24586 [self value. 24587 Processor terminateActive] asContext 24588 priority: Processor activePriority! ! 24589 24590!BlockContext methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:25'! 24591newProcessWith: anArray 24592 "Answer a Process running the code in the receiver. The receiver's block 24593 arguments are bound to the contents of the argument, anArray. The 24594 process is not scheduled." 24595 <primitive: 19> "Simulation guard" 24596 ^Process 24597 forContext: 24598 [self valueWithArguments: anArray. 24599 Processor terminateActive] asContext 24600 priority: Processor activePriority! ! 24601 24602!BlockContext methodsFor: 'scheduling' stamp: 'sr 6/14/2004 15:19'! 24603valueAt: blockPriority 24604 "Evaluate the receiver (block), with another priority as the actual one 24605 and restore it afterwards. The caller should be careful with using 24606 higher priorities." 24607 | activeProcess result outsidePriority | 24608 activeProcess := Processor activeProcess. 24609 outsidePriority := activeProcess priority. 24610 activeProcess priority: blockPriority. 24611 result := self 24612 ensure: [activeProcess priority: outsidePriority]. 24613 "Yield after restoring lower priority to give the preempted processes a 24614 chance to run." 24615 blockPriority > outsidePriority 24616 ifTrue: [Processor yield]. 24617 ^ result! ! 24618 24619 24620!BlockContext methodsFor: 'system simulation' stamp: 'di 1/11/1999 10:24'! 24621pushArgs: args from: sendr 24622 "Simulates action of the value primitive." 24623 24624 args size ~= nargs ifTrue: [^self error: 'incorrect number of args']. 24625 self stackp: 0. 24626 args do: [:arg | self push: arg]. 24627 sender := sendr. 24628 pc := startpc! ! 24629 24630!BlockContext methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 18:03'! 24631stepToSendOrReturn 24632 pc = startpc ifTrue: [ 24633 "pop args first" 24634 self numArgs timesRepeat: [self step]]. 24635 ^super stepToSendOrReturn! ! 24636 24637 24638!BlockContext methodsFor: 'testing' stamp: 'kph 1/21/2009 15:33'! 24639= other 24640 24641 self class == other class ifFalse: [^ false]. 24642 self home receiver == other home receiver ifFalse: [^ false]. 24643 self home selector == other home selector ifFalse: [^ false]. 24644 ^ self startpc == other startpc 24645! ! 24646 24647!BlockContext methodsFor: 'testing' stamp: 'kph 1/21/2009 15:33'! 24648hash 24649 24650 ^ self method hash! ! 24651 24652 24653!BlockContext methodsFor: 'private' stamp: 'ajh 1/24/2003 20:36'! 24654aboutToReturn: result through: firstUnwindContext 24655 "Called from VM when an unwindBlock is found between self and its home. Return to home's sender, executing unwind blocks on the way." 24656 24657 self home return: result! ! 24658 24659!BlockContext methodsFor: 'private' stamp: 'tfei 3/31/1999 17:40'! 24660cannotReturn: result 24661 "The receiver tried to return result to a method context that no longer exists." 24662 24663 | ex newResult | 24664 ex := BlockCannotReturn new. 24665 ex result: result. 24666 newResult := ex signal. 24667 ^newResult! ! 24668 24669!BlockContext methodsFor: 'private' stamp: 'ajh 1/27/2003 21:18'! 24670copyTo: aContext blocks: dict 24671 "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home." 24672 24673 | copy | 24674 self == aContext ifTrue: [^ nil]. 24675 copy := self copy. 24676 (dict at: self home ifAbsentPut: [OrderedCollection new]) add: copy. 24677 self sender ifNotNil: [ 24678 copy privSender: (self sender copyTo: aContext blocks: dict)]. 24679 ^ copy! ! 24680 24681!BlockContext methodsFor: 'private' stamp: 'md 4/27/2006 15:14'! 24682endPC 24683 "Determine end of block from long jump preceding it" 24684 ^(self method at: startpc - 2) 24685 \\ 16 - 4 * 256 24686 + (self method at: startpc - 1) + startpc - 1.! ! 24687 24688!BlockContext methodsFor: 'private' stamp: 'di 1/14/1999 22:28'! 24689instVarAt: index put: value 24690 index = 3 ifTrue: [self stackp: value. ^ value]. 24691 ^ super instVarAt: index put: value! ! 24692 24693!BlockContext methodsFor: 'private' stamp: 'ajh 7/7/2004 13:43'! 24694myEnv 24695 "polymorphic with MethodContext" 24696 24697 ^ nil! ! 24698 24699!BlockContext methodsFor: 'private' stamp: 'ajh 1/27/2003 21:08'! 24700privHome: context 24701 24702 home := context! ! 24703 24704!BlockContext methodsFor: 'private'! 24705startpc 24706 "for use by the System Tracer only" 24707 24708 ^startpc! ! 24709 24710!BlockContext methodsFor: 'private'! 24711valueError 24712 24713 self error: 'Incompatible number of args, or already active'! ! 24714 24715!BlockContext methodsFor: 'private' stamp: 'ar 3/2/2001 01:16'! 24716valueUnpreemptively 24717 "Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!" 24718 "Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! 24719 After you've done all that thinking, go right ahead and use it..." 24720 | activeProcess oldPriority result | 24721 activeProcess := Processor activeProcess. 24722 oldPriority := activeProcess priority. 24723 activeProcess priority: Processor highestPriority. 24724 result := self ensure: [activeProcess priority: oldPriority]. 24725 "Yield after restoring priority to give the preempted processes a chance to run" 24726 Processor yield. 24727 ^result! ! 24728 24729"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 24730 24731BlockContext class 24732 instanceVariableNames: ''! 24733TestCase subclass: #BlockContextTest 24734 instanceVariableNames: 'aBlockContext contextOfaBlockContext' 24735 classVariableNames: '' 24736 poolDictionaries: '' 24737 category: 'KernelTests-Methods'! 24738!BlockContextTest commentStamp: 'jrp 10/17/2004 12:22' prior: 0! 24739I am an SUnit Test of BlockContext and its supertype ContextPart. See also MethodContextTest. 24740 24741My fixtures are: 24742aBlockContext - just some trivial block, i.e., [100@100 corner: 200@200]. 24743 24744NOTES ABOUT AUTOMATING USER INPUTS 24745 24746When executing non-interactive programs you will inevitably run into programs (like SqueakMap or Monticello installation packages -- and other programs, to be fair) that require user input during their execution and these sort of problems shoot the whole non-interactiveness of your enclosing program. 24747 24748BlockContext helper methods have been made available and tests of these helpers are provided in this class to demonstrate that it can intercept PopUpMenu and FillInTheBlankMorph requests for user interaction. Of course, PopUpMenu and FillInTheBlankMorph were modified to first signal a ProvideAnswerNotification and if someone handles that (e.g. the enclosing block) then the user interaction will be circumvented and the provided answer of the enclosing block will be used. The basic syntax looks like: 24749 24750 [self confirm: 'Install spyware?'] valueSupplyingAnswer: #('Install spyware?' false) 24751 24752There a few variants on this theme making it easy to provide a literal list of answers for the block so that you can handle a bunch of questions in a block with appropriate answers. 24753 24754Additionally, it is possible to suppress Object>>inform: modal dialog boxes as these get in the way of automating anything. After applying this changeset you should be able to tryout the following code snippets to see the variants on this theme that are available. 24755 24756Examples: 24757 24758So you don't need any introduction here -- this one works like usual. 24759[self inform: 'hello'. #done] value. 24760 24761Now let's suppress all inform: messages. 24762[self inform: 'hello'; inform: 'there'. #done] valueSuppressingAllMessages. 24763 24764Here we can just suppress a single inform: message. 24765[self inform: 'hi'; inform: 'there'. #done] valueSuppressingMessages: #('there') 24766 24767Here you see how you can suppress a list of messages. 24768[self inform: 'hi'; inform: 'there'; inform: 'bill'. #done] valueSuppressingMessages: #('hi' 'there') 24769 24770Enough about inform:, let's look at confirm:. As you see this one works as expected. 24771[self confirm: 'You like Squeak?'] value 24772 24773Let's supply answers to one of the questions -- check out the return value. 24774[{self confirm: 'You like Smalltalk?'. self confirm: 'You like Squeak?'}] 24775 valueSupplyingAnswer: #('You like Smalltalk?' true) 24776 24777Here we supply answers using only substrings of the questions (for simplicity). 24778[{self confirm: 'You like Squeak?'. self confirm: 'You like MVC?'}] 24779 valueSupplyingAnswers: #( ('Squeak' true) ('MVC' false) ) 24780 24781This time let's answer all questions exactly the same way. 24782[{self confirm: 'You like Squeak?'. self confirm: 'You like Morphic?'}] 24783 valueSupplyingAnswer: true 24784 24785And, of course, we can answer FillInTheBlank questions in the same manner. 24786[FillInTheBlank request: 'What day is it?'] 24787 valueSupplyingAnswer: 'the first day of the rest of your life' 24788 24789We can also return whatever the initialAnswer of the FillInTheBlank was by using the #default answer. 24790[FillInTheBlank request: 'What day is it?' initialAnswer: DateAndTime now dayOfWeekName] 24791 valueSupplyingAnswer: #default 24792 24793Finally, you can also do regex matches on any of the question text (or inform text) (should you have VB-Regex enhancements in your image). 24794[FillInTheBlank request: 'What day is it?'] 24795 valueSupplyingAnswers: { {'What day.*\?'. DateAndTime now dayOfWeekName} }! 24796 24797 24798!BlockContextTest methodsFor: 'setup' stamp: 'md 9/6/2005 19:56'! 24799setUp 24800 super setUp. 24801 aBlockContext := [100@100 corner: 200@200]. 24802 contextOfaBlockContext := thisContext.! ! 24803 24804 24805!BlockContextTest methodsFor: 'testing' stamp: 'rbb 3/1/2005 10:23'! 24806testSupplyAnswerOfFillInTheBlank 24807 24808 self should: ['blue' = ([UIManager default request: 'Your favorite color?'] 24809 valueSupplyingAnswer: #('Your favorite color?' 'blue'))]! ! 24810 24811!BlockContextTest methodsFor: 'testing' stamp: 'rbb 3/1/2005 10:24'! 24812testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer 24813 24814 self should: ['red' = ([UIManager default request: 'Your favorite color?' initialAnswer: 'red'] 24815 valueSupplyingAnswer: #('Your favorite color?' #default))]! ! 24816 24817 24818!BlockContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 13:13'! 24819testNew 24820 self should: [ContextPart new: 5] raise: Error. 24821 [ContextPart new: 5] 24822 ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. 24823 [ContextPart new] 24824 ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. 24825 [ContextPart basicNew] 24826 ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. 24827 24828! ! 24829 24830!BlockContextTest methodsFor: 'tests' stamp: 'mjr 8/24/2003 18:27'! 24831testNoArguments 24832 [10 24833 timesRepeat: [:arg | 1 + 2]] 24834 ifError: [:err :rcvr | self deny: err = 'This block requires 1 arguments.']. 24835 [10 24836 timesRepeat: [:arg1 :arg2 | 1 + 2]] 24837 ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! ! 24838 24839!BlockContextTest methodsFor: 'tests' stamp: 'mjr 8/24/2003 18:25'! 24840testOneArgument 24841 | c | 24842 c := OrderedCollection new. 24843 c add: 'hello'. 24844 [c 24845 do: [1 + 2]] 24846 ifError: [:err :rcvr | self deny: err = 'This block requires 0 arguments.']. 24847 [c 24848 do: [:arg1 :arg2 | 1 + 2]] 24849 ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! ! 24850 24851!BlockContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 12:50'! 24852testRunSimulated 24853 self assert: (ContextPart runSimulated: aBlockContext) class = Rectangle.! ! 24854 24855!BlockContextTest methodsFor: 'tests' stamp: 'al 7/4/2009 19:01'! 24856testSetUp 24857 "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'" 24858 self deny: aBlockContext isPseudoContext. 24859 self assert: aBlockContext home = contextOfaBlockContext. 24860 self assert: aBlockContext receiver = self. 24861 self assert: (aBlockContext method isKindOf: CompiledMethod).! ! 24862 24863!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/10/2004 22:19'! 24864testSupplyAnswerThroughNestedBlocks 24865 24866 self should: [true = ([[self confirm: 'You like Smalltalk?'] 24867 valueSupplyingAnswer: #('Blub' false)] valueSupplyingAnswer: #('Smalltalk' true))]! ! 24868 24869!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:27'! 24870testSupplyAnswerUsingOnlySubstringOfQuestion 24871 24872 self should: [false = ([self confirm: 'You like Smalltalk?'] 24873 valueSupplyingAnswer: #('like' false))]! ! 24874 24875!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/10/2004 22:31'! 24876testSupplyAnswerUsingRegexMatchOfQuestion 24877 24878 (String includesSelector: #matchesRegex:) ifFalse: [^ self]. 24879 24880 self should: [true = ([self confirm: 'You like Smalltalk?'] 24881 valueSupplyingAnswer: #('.*Smalltalk\?' true))]! ! 24882 24883!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/10/2004 22:17'! 24884testSupplyAnswerUsingTraditionalMatchOfQuestion 24885 24886 self should: [true = ([self confirm: 'You like Smalltalk?'] 24887 valueSupplyingAnswer: #('*Smalltalk#' true))]! ! 24888 24889!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:25'! 24890testSupplySameAnswerToAllQuestions 24891 24892 self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: true)]. 24893 24894 self should: [#(true true) = ([{self confirm: 'One'. self confirm: 'Two'}] valueSupplyingAnswer: true)].! ! 24895 24896!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:39'! 24897testSupplySeveralAnswersToSeveralQuestions 24898 24899 self should: [#(false true) = ([{self confirm: 'One'. self confirm: 'Two'}] 24900 valueSupplyingAnswers: #( ('One' false) ('Two' true) ))]. 24901 24902 self should: [#(true false) = ([{self confirm: 'One'. self confirm: 'Two'}] 24903 valueSupplyingAnswers: #( ('One' true) ('Two' false) ))]! ! 24904 24905!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:26'! 24906testSupplySpecificAnswerToQuestion 24907 24908 self should: [false = ([self confirm: 'You like Smalltalk?'] 24909 valueSupplyingAnswer: #('You like Smalltalk?' false))]! ! 24910 24911!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:35'! 24912testSuppressInform 24913 24914 self should: [[nil inform: 'Should not see this message or this test failed!!'] valueSuppressingAllMessages isNil]! ! 24915 24916!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/10/2004 22:29'! 24917testSuppressInformUsingStringMatchOptions 24918 24919 self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('Should not see this message or this test failed!!')) isNil]. 24920 24921 self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('not see this message')) isNil]. 24922 24923 self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('*message*failed#')) isNil]. 24924! ! 24925 24926!BlockContextTest methodsFor: 'tests' stamp: 'md 9/6/2005 19:58'! 24927testTallyInstructions 24928 self assert: (ContextPart tallyInstructions: aBlockContext) size = 15.! ! 24929 24930!BlockContextTest methodsFor: 'tests' stamp: 'md 9/6/2005 19:58'! 24931testTallyMethods 24932 self assert: (ContextPart tallyMethods: aBlockContext) size = 3.! ! 24933 24934!BlockContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 12:48'! 24935testTrace 24936 self assert: (ContextPart trace: aBlockContext) class = Rectangle.! ! 24937 24938 24939!BlockContextTest methodsFor: 'tests - evaluating' stamp: 'Henrik Sperre Johansen 3/23/2009 13:45'! 24940testValueWithArguments 24941 self 24942 should: [aBlockContext 24943 valueWithArguments: #(1 )] 24944 raise: Error. 24945 self 24946 shouldnt: [aBlockContext 24947 valueWithArguments: #()] 24948 raise: Error. 24949 [aBlockContext 24950 valueWithArguments: #(1 )] 24951 ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 0 arguments, but was called with 1 argument.']. 24952 [[:i | 3 + 4] 24953 valueWithArguments: #(1 2)] 24954 ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 1 argument, but was called with 2 arguments.']! ! 24955 24956!BlockContextTest methodsFor: 'tests - evaluating' stamp: 'md 3/23/2006 13:52'! 24957testValueWithExitBreak 24958 24959 | val | 24960 24961 [ :break | 24962 1 to: 10 do: [ :i | 24963 val := i. 24964 i = 4 ifTrue: [break value]. 24965 ] 24966 ] valueWithExit. 24967 24968 self assert: val = 4.! ! 24969 24970!BlockContextTest methodsFor: 'tests - evaluating' stamp: 'md 3/23/2006 13:52'! 24971testValueWithExitContinue 24972 24973 | val last | 24974 val := 0. 24975 24976 1 to: 10 do: [ :i | 24977 [ :continue | 24978 i = 4 ifTrue: [continue value]. 24979 val := val + 1. 24980 last := i 24981 ] valueWithExit. 24982 ]. 24983 24984 self assert: val = 9. 24985 self assert: last = 10. ! ! 24986 24987!BlockContextTest methodsFor: 'tests - evaluating' stamp: 'md 10/7/2004 13:52'! 24988testValueWithPossibleArgs 24989 | block blockWithArg blockWith2Arg | 24990 24991 block := [1]. 24992 blockWithArg := [:arg | arg]. 24993 blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}]. 24994 24995 self assert: (block valueWithPossibleArgs: #()) = 1. 24996 self assert: (block valueWithPossibleArgs: #(1)) = 1. 24997 24998 self assert: (blockWithArg valueWithPossibleArgs: #()) = nil. 24999 self assert: (blockWithArg valueWithPossibleArgs: #(1)) = 1. 25000 self assert: (blockWithArg valueWithPossibleArgs: #(1 2)) = 1. 25001 25002 self assert: (blockWith2Arg valueWithPossibleArgs: #()) = {nil .nil}. 25003 self assert: (blockWith2Arg valueWithPossibleArgs: #(1)) = {1 . nil}. 25004 self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2)) = #(1 2). 25005 self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2 3)) = #(1 2). 25006 25007 25008 ! ! 25009 25010!BlockContextTest methodsFor: 'tests - evaluating' stamp: 'md 10/7/2004 13:59'! 25011testValueWithPossibleArgument 25012 | block blockWithArg blockWith2Arg | 25013 25014 block := [1]. 25015 blockWithArg := [:arg | arg]. 25016 blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}]. 25017 25018 self assert: (block valueWithPossibleArgument: 1) = 1. 25019 25020 self assert: (blockWithArg valueWithPossibleArgument: 1) = 1. 25021 25022 self assert: (blockWith2Arg valueWithPossibleArgument: 1) = {1 . nil}. 25023 25024 25025 ! ! 25026 25027 25028!BlockContextTest methodsFor: 'tests - printing' stamp: 'md 2/22/2006 15:39'! 25029testDecompile 25030 self assert: ([3 + 4] decompile printString = '{[3 + 4]}').! ! 25031InstructionClient subclass: #BlockLocalTempCounter 25032 instanceVariableNames: 'stackPointer scanner blockEnd joinOffsets' 25033 classVariableNames: '' 25034 poolDictionaries: '' 25035 category: 'Compiler-Support'! 25036!BlockLocalTempCounter commentStamp: '<historical>' prior: 0! 25037I am a support class for the decompiler that is used to find the number of local temps in a block by finding out what the stack offset is at the end of a block.! 25038]style[(160)i! 25039 25040 25041!BlockLocalTempCounter methodsFor: 'initialize-release' stamp: 'eem 9/26/2008 13:40'! 25042tempCountForBlockAt: pc in: method 25043 "Compute the number of local temporaries in a block. 25044 If the block begins with a sequence of push: nil bytecodes then some of 25045 These could be initializing local temps. We can only reliably disambuguate 25046 them from other uses of nil by parsing the stack and seeing what the offset 25047 of the stack pointer is at the end of the block. 25048 25049 There are short-cuts. The ones we take here are 25050 - if there is no sequence of push nils there can be no local temps 25051 - we follow forward jumps to shorten the amount of scanning" 25052 stackPointer := 0. 25053 scanner := InstructionStream new method: method pc: pc. 25054 scanner interpretNextInstructionFor: self. 25055 blockEnd isNil ifTrue: 25056 [self error: 'pc is not that of a block']. 25057 scanner nextByte = Encoder pushNilCode ifTrue: 25058 [joinOffsets := Dictionary new. 25059 [scanner pc < blockEnd] whileTrue: 25060 [scanner interpretNextInstructionFor: self]]. 25061 ^stackPointer! ! 25062 25063!BlockLocalTempCounter methodsFor: 'initialize-release' stamp: 'eem 9/26/2008 13:41'! 25064testTempCountForBlockAt: startPc in: method 25065 "Compute the number of local temporaries in a block. 25066 If the block begins with a sequence of push: nil bytecodes then some of 25067 These could be initializing local temps. We can only reliably disambuguate 25068 them from other uses of nil by parsing the stack and seeing what the offset 25069 of the stack pointer is at the end of the block.There are short-cuts. The only 25070 one we take here is 25071 - if there is no sequence of push nils there can be no local temps" 25072 25073 | symbolicLines line prior thePc | 25074 symbolicLines := Dictionary new. 25075 method symbolicLinesDo: 25076 [:pc :lineForPC| symbolicLines at: pc put: lineForPC]. 25077 stackPointer := 0. 25078 scanner := InstructionStream new method: method pc: startPc. 25079 scanner interpretNextInstructionFor: self. 25080 blockEnd isNil ifTrue: 25081 [self error: 'pc is not that of a block']. 25082 scanner nextByte = Encoder pushNilCode ifTrue: 25083 [joinOffsets := Dictionary new. 25084 [scanner pc < blockEnd] whileTrue: 25085 [line := symbolicLines at: scanner pc. 25086 prior := stackPointer. 25087 thePc := scanner pc. 25088 scanner interpretNextInstructionFor: self. 25089 Transcript cr; print: prior; nextPutAll: '->'; print: stackPointer; tab; print: thePc; tab; nextPutAll: line; flush]]. 25090 ^stackPointer! ! 25091 25092 25093!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 11:36'! 25094blockReturnTop 25095 "Return Top Of Stack bytecode." 25096 stackPointer := stackPointer - 1. 25097 scanner pc < blockEnd ifTrue: 25098 [self doJoin]! ! 25099 25100!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:13'! 25101doDup 25102 "Duplicate Top Of Stack bytecode." 25103 stackPointer := stackPointer + 1! ! 25104 25105!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:17'! 25106doPop 25107 "Remove Top Of Stack bytecode." 25108 stackPointer := stackPointer - 1! ! 25109 25110!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 13:40'! 25111jump: offset 25112 "Unconditional Jump bytecode." 25113 offset > 0 ifTrue: 25114 [joinOffsets at: scanner pc + offset put: stackPointer. 25115 self doJoin]! ! 25116 25117!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 13:40'! 25118jump: offset if: condition 25119 "Conditional Jump bytecode." 25120 stackPointer := stackPointer - 1. 25121 offset > 0 ifTrue: 25122 [joinOffsets at: scanner pc + offset put: stackPointer]! ! 25123 25124!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 11:36'! 25125methodReturnConstant: value 25126 "Return Constant bytecode." 25127 self doJoin! ! 25128 25129!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 11:36'! 25130methodReturnReceiver 25131 "Return Self bytecode." 25132 self doJoin! ! 25133 25134!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 11:36'! 25135methodReturnTop 25136 "Return Top Of Stack bytecode." 25137 stackPointer := stackPointer - 1. 25138 self doJoin! ! 25139 25140!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:19'! 25141popIntoLiteralVariable: anAssociation 25142 "Remove Top Of Stack And Store Into Literal Variable bytecode." 25143 stackPointer := stackPointer - 1! ! 25144 25145!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:19'! 25146popIntoReceiverVariable: offset 25147 "Remove Top Of Stack And Store Into Instance Variable bytecode." 25148 stackPointer := stackPointer - 1! ! 25149 25150!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:19'! 25151popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 25152 "Remove Top Of Stack And Store Into Offset of Temp Vector bytecode." 25153 stackPointer := stackPointer - 1! ! 25154 25155!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:20'! 25156popIntoTemporaryVariable: offset 25157 "Remove Top Of Stack And Store Into Temporary Variable bytecode." 25158 stackPointer := stackPointer - 1! ! 25159 25160!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:20'! 25161pushActiveContext 25162 "Push Active Context On Top Of Its Own Stack bytecode." 25163 stackPointer := stackPointer + 1! ! 25164 25165!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:16'! 25166pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize 25167 "Push Closure bytecode. Either compute the end of the block if this is 25168 the block we're analysing, or skip it, adjusting the stack as appropriate." 25169 blockEnd 25170 ifNil: [blockEnd := scanner pc + blockSize] 25171 ifNotNil: 25172 [stackPointer := stackPointer - numCopied + 1. 25173 scanner pc: scanner pc + blockSize]! ! 25174 25175!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:21'! 25176pushConsArrayWithElements: numElements 25177 "Push Cons Array of size numElements popping numElements items from the stack into the array bytecode." 25178 stackPointer := stackPointer - numElements + 1! ! 25179 25180!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:21'! 25181pushConstant: value 25182 "Push Constant, value, on Top Of Stack bytecode." 25183 stackPointer := stackPointer + 1! ! 25184 25185!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:22'! 25186pushLiteralVariable: anAssociation 25187 "Push Contents Of anAssociation On Top Of Stack bytecode." 25188 stackPointer := stackPointer + 1! ! 25189 25190!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:22'! 25191pushNewArrayOfSize: numElements 25192 "Push New Array of size numElements bytecode." 25193 stackPointer := stackPointer + 1! ! 25194 25195!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:22'! 25196pushReceiver 25197 "Push Active Context's Receiver on Top Of Stack bytecode." 25198 stackPointer := stackPointer + 1! ! 25199 25200!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:23'! 25201pushReceiverVariable: offset 25202 "Push Contents Of the Receiver's Instance Variable Whose Index 25203 is the argument, offset, On Top Of Stack bytecode." 25204 stackPointer := stackPointer + 1! ! 25205 25206!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:23'! 25207pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 25208 "Push Contents at Offset in Temp Vector bytecode." 25209 stackPointer := stackPointer + 1! ! 25210 25211!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:23'! 25212pushTemporaryVariable: offset 25213 "Push Contents Of Temporary Variable Whose Index Is the 25214 argument, offset, On Top Of Stack bytecode." 25215 stackPointer := stackPointer + 1! ! 25216 25217!BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:24'! 25218send: selector super: supered numArgs: numberArguments 25219 "Send Message With Selector, selector, bytecode. The argument, 25220 supered, indicates whether the receiver of the message is specified with 25221 'super' in the source method. The arguments of the message are found in 25222 the top numArguments locations on the stack and the receiver just 25223 below them." 25224 25225 stackPointer := stackPointer - numberArguments! ! 25226 25227 25228!BlockLocalTempCounter methodsFor: 'private' stamp: 'eem 9/26/2008 13:40'! 25229doJoin 25230 scanner pc < blockEnd ifTrue: 25231 [stackPointer := joinOffsets at: scanner pc]! ! 25232 25233"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 25234 25235BlockLocalTempCounter class 25236 instanceVariableNames: ''! 25237 25238!BlockLocalTempCounter class methodsFor: 'instance creation' stamp: 'eem 9/23/2008 16:07'! 25239tempCountForBlockAt: pc in: method 25240 ^self new tempCountForBlockAt: pc in: method! ! 25241ParseNode subclass: #BlockNode 25242 instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement' 25243 classVariableNames: '' 25244 poolDictionaries: '' 25245 category: 'Compiler-ParseNodes'! 25246!BlockNode commentStamp: '<historical>' prior: 0! 25247I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments.! 25248 25249 25250!BlockNode methodsFor: 'accessing' stamp: 'eem 6/2/2008 14:00'! 25251addArgument: aTempVariableNode 25252 temporaries := temporaries copyWith: aTempVariableNode! ! 25253 25254!BlockNode methodsFor: 'accessing' stamp: 'eem 7/27/2008 15:57'! 25255arguments 25256 ^arguments! ! 25257 25258!BlockNode methodsFor: 'accessing'! 25259arguments: argNodes 25260 "Decompile." 25261 25262 arguments := argNodes! ! 25263 25264!BlockNode methodsFor: 'accessing' stamp: 'tk 8/4/1999 22:53'! 25265block 25266 ^ self! ! 25267 25268!BlockNode methodsFor: 'accessing' stamp: 'eem 8/22/2008 10:01'! 25269closureCreationNode 25270 closureCreationNode ifNil: 25271 [closureCreationNode := LeafNode new 25272 key: #closureCreationNode 25273 code: nil]. 25274 ^closureCreationNode! ! 25275 25276!BlockNode methodsFor: 'accessing'! 25277firstArgument 25278 ^ arguments first! ! 25279 25280!BlockNode methodsFor: 'accessing' stamp: 'eem 5/30/2008 12:12'! 25281nArgsSlot 25282 "Private for the Encoder to use in bindArg" 25283 ^nArgsNode! ! 25284 25285!BlockNode methodsFor: 'accessing' stamp: 'eem 5/30/2008 12:12'! 25286nArgsSlot: anInteger 25287 "Private for the Encoder to use in bindArg" 25288 nArgsNode := anInteger! ! 25289 25290!BlockNode methodsFor: 'accessing'! 25291numberOfArguments 25292 25293 ^arguments size! ! 25294 25295!BlockNode methodsFor: 'accessing' stamp: 'eem 7/24/2008 12:37'! 25296optimized 25297 ^optimized! ! 25298 25299!BlockNode methodsFor: 'accessing'! 25300returnLast 25301 25302 self returns 25303 ifFalse: 25304 [returns := true. 25305 statements at: statements size put: statements last asReturnNode]! ! 25306 25307!BlockNode methodsFor: 'accessing' stamp: 'ar 11/17/2002 19:57'! 25308returnNilIfNoOther 25309 25310 self returns 25311 ifFalse: 25312 [statements last == NodeNil ifFalse: [statements add: NodeNil]. 25313 self returnLast]! ! 25314 25315!BlockNode methodsFor: 'accessing' stamp: 'gk 4/6/2006 11:29'! 25316returnSelfIfNoOther: encoder 25317 25318 self returns ifTrue:[^self]. 25319 statements last == NodeSelf ifFalse: [ 25320 statements := statements copyWith: (encoder encodeVariable: 'self'). 25321 ]. 25322 self returnLast. 25323! ! 25324 25325!BlockNode methodsFor: 'accessing' stamp: 'eem 8/4/2008 10:48'! 25326startOfLastStatement 25327 ^startOfLastStatement! ! 25328 25329!BlockNode methodsFor: 'accessing' stamp: 'eem 8/4/2008 10:50'! 25330startOfLastStatement: anInteger 25331 "Note the source index of the start of the last full statement. The 25332 last full statement is the value answered by a block and hence the 25333 expression the debugger should display as the value of the block." 25334 startOfLastStatement := anInteger! ! 25335 25336!BlockNode methodsFor: 'accessing' stamp: 'eem 7/27/2008 15:57'! 25337temporaries 25338 ^temporaries! ! 25339 25340!BlockNode methodsFor: 'accessing' stamp: 'sma 2/27/2000 22:37'! 25341temporaries: aCollection 25342 temporaries := aCollection! ! 25343 25344 25345!BlockNode methodsFor: 'code generation'! 25346code 25347 25348 ^statements first code! ! 25349 25350!BlockNode methodsFor: 'code generation' stamp: 'di 11/19/1999 19:32'! 25351emitExceptLast: stack on: aStream 25352 | nextToLast | 25353 nextToLast := statements size - 1. 25354 nextToLast < 1 ifTrue: [^ self]. "Only one statement" 25355 1 to: nextToLast do: 25356 [:i | (statements at: i) emitForEffect: stack on: aStream]. 25357! ! 25358 25359!BlockNode methodsFor: 'code generation'! 25360emitForEvaluatedEffect: stack on: aStream 25361 25362 self returns 25363 ifTrue: 25364 [self emitForEvaluatedValue: stack on: aStream. 25365 stack pop: 1] 25366 ifFalse: 25367 [self emitExceptLast: stack on: aStream. 25368 statements last emitForEffect: stack on: aStream]! ! 25369 25370!BlockNode methodsFor: 'code generation' stamp: 'di 11/19/1999 19:44'! 25371emitForEvaluatedValue: stack on: aStream 25372 self emitExceptLast: stack on: aStream. 25373 statements last emitForValue: stack on: aStream. 25374! ! 25375 25376!BlockNode methodsFor: 'code generation' stamp: 'hmm 7/17/2001 21:02'! 25377emitForValue: stack on: aStream 25378 25379 aStream nextPut: LdThisContext. 25380 stack push: 1. 25381 nArgsNode emitForValue: stack on: aStream. 25382 remoteCopyNode 25383 emit: stack 25384 args: 1 25385 on: aStream. 25386 "Force a two byte jump." 25387 self emitLong: size code: JmpLong on: aStream. 25388 stack push: arguments size. 25389 arguments reverseDo: [:arg | arg emitStorePop: stack on: aStream]. 25390 self emitForEvaluatedValue: stack on: aStream. 25391 self returns ifFalse: [ 25392 aStream nextPut: EndRemote. 25393 pc := aStream position. 25394 ]. 25395 stack pop: 1! ! 25396 25397!BlockNode methodsFor: 'code generation' stamp: 'di 11/19/1999 19:33'! 25398sizeExceptLast: encoder 25399 | codeSize nextToLast | 25400 nextToLast := statements size - 1. 25401 nextToLast < 1 ifTrue: [^ 0]. "Only one statement" 25402 codeSize := 0. 25403 1 to: nextToLast do: 25404 [:i | codeSize := codeSize + ((statements at: i) sizeForEffect: encoder)]. 25405 ^ codeSize! ! 25406 25407!BlockNode methodsFor: 'code generation'! 25408sizeForEvaluatedEffect: encoder 25409 25410 self returns ifTrue: [^self sizeForEvaluatedValue: encoder]. 25411 ^(self sizeExceptLast: encoder) 25412 + (statements last sizeForEffect: encoder)! ! 25413 25414!BlockNode methodsFor: 'code generation'! 25415sizeForEvaluatedValue: encoder 25416 25417 ^(self sizeExceptLast: encoder) 25418 + (statements last sizeForValue: encoder)! ! 25419 25420!BlockNode methodsFor: 'code generation'! 25421sizeForValue: encoder 25422 nArgsNode := encoder encodeLiteral: arguments size. 25423 remoteCopyNode := encoder encodeSelector: #blockCopy:. 25424 size := (self sizeForEvaluatedValue: encoder) 25425 + (self returns ifTrue: [0] ifFalse: [1]). "endBlock" 25426 arguments := arguments collect: "Chance to prepare debugger remote temps" 25427 [:arg | arg asStorableNode: encoder]. 25428 arguments do: [:arg | size := size + (arg sizeForStorePop: encoder)]. 25429 ^1 + (nArgsNode sizeForValue: encoder) 25430 + (remoteCopyNode size: encoder args: 1 super: false) + 2 + size! ! 25431 25432 25433!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 9/3/2009 12:55'! 25434actualScope 25435 "Answer the actual scope for the receiver. If this is an unoptimized block then it is its 25436 actual scope, but if this is an optimized block then the actual scope is some outer block." 25437 ^actualScopeIfOptimized ifNil: [self]! ! 25438 25439!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2009 11:42'! 25440addHoistedTemps: additionalTemporaries "<SequenceableCollection>" 25441 additionalTemporaries do: 25442 [:temp| 25443 temp definingScope ifNil: 25444 [temp definingScope: self]]. 25445 temporaries := (temporaries isNil or: [temporaries isEmpty]) 25446 ifTrue: [additionalTemporaries copy] 25447 ifFalse: 25448 [temporaries last isIndirectTempVector 25449 ifTrue: [temporaries allButLast, additionalTemporaries, { temporaries last }] 25450 ifFalse: [temporaries, additionalTemporaries]]! ! 25451 25452!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2009 16:43'! 25453addRemoteTemp: aTempVariableNode rootNode: rootNode "<MethodNode>" 25454 "Add aTempVariableNode to my actualScope's sequence of 25455 remote temps. If I am an optimized block then the actual 25456 scope is my actualScopeIfOptimized, otherwise it is myself." 25457 temporaries isArray ifTrue: 25458 [temporaries := temporaries asOrderedCollection]. 25459 remoteTempNode == nil ifTrue: 25460 [remoteTempNode := RemoteTempVectorNode new 25461 name: self remoteTempNodeName 25462 index: arguments size + temporaries size 25463 type: LdTempType 25464 scope: 0. 25465 actualScopeIfOptimized 25466 ifNil: 25467 [temporaries addLast: remoteTempNode. 25468 remoteTempNode definingScope: self] 25469 ifNotNil: [actualScopeIfOptimized addHoistedTemps: { remoteTempNode }]]. 25470 remoteTempNode addRemoteTemp: aTempVariableNode encoder: rootNode encoder. 25471 "use remove:ifAbsent: because the deferred analysis for optimized 25472 loops can result in the temp has already been hoised into the root." 25473 temporaries remove: aTempVariableNode ifAbsent: []. 25474 ^remoteTempNode! ! 25475 25476!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2009 13:29'! 25477analyseArguments: methodArguments temporaries: methodTemporaries rootNode: rootNode "<MethodNode>" "^<Sequence of: <TempVarNade>>" 25478 "Top level entry-point for analysing temps within the hierarchy of blocks in the receiver's method. 25479 Answer the (possibly modified) sequence of temp vars. 25480 Need to hoist temps out of macro-optimized blocks into their actual blocks. 25481 Need to note reads and writes to temps from blocks other than their actual blocks to determine 25482 whether blocks can be local (simple slots within a block/method context) or remote (slots in 25483 indirection vectors that are shared between contexts by sharing indirection vectors). 25484 25485 The algorithm is based on numbering temporary reads and writes and block extents. 25486 The index used for numbering starts at zero and is incremented on every block entry 25487 and block exit. So the following 25488 | a b blk r1 r2 t | 25489 a := 1. b := 2. t := 0. 25490 blk := [ | s | s := a + b. t := t + s]. 25491 r1 := blk value. 25492 b := -100. 25493 r2 := blk value. 25494 r1 -> r2 -> t 25495 is numbered as 25496 method block 0 to: 6: 25497 | a b blk r1 r2 t | 25498 a w@1 := 1. b w@1 := 2. t w@1 := 0. 25499 blk w@5 := [entry@2 | s | 25500 t w@3 := t r@3 + a r@3 + b r@3 25501 ] exit@4. 25502 r1 w@5 := blk r@5 value. 25503 b w@5 := nil. 25504 r2 w@5 := blk r@5 value. 25505 r1 r@5 -> r2 r@5 -> t r@5 25506 So: 25507 b and blk cannot be copied because for both there exists a write @5 that follows a 25508 read @4 within block 2 through 4 25509 t must be remote because there exists a write @3 within block (2 to: 4) 25510 Complications are introduced by optimized blocks. In the following temp is written to 25511 after it is closed over by [ temp ] since the inlined block is executed more than once. 25512 | temp coll | 25513 coll := OrderedCollection new. 25514 1 to: 5 do: [ :index | 25515 temp := index. 25516 coll add: [ temp ] ]. 25517 self assert: (coll collect: [:ea| ea value]) asArray = #(5 5 5 5 5) 25518 In the following i is local to the block and must be initialized each time around the loop 25519 but if the block is inlined it must be declared at method level. 25520 | col | 25521 col := OrderedCollection new. 25522 1 to: 3 do: [ :each | | i | i := each. col add: [ i ]. i := i + 1 ]. 25523 self assert: (col collect: [ :each | each value ]) asArray = #(2 3 4)" 25524 self assert: (arguments isEmpty or: [arguments hasEqualElements: methodArguments]). 25525 arguments := methodArguments asArray. "won't change" 25526 self assert: (temporaries isNil or: [temporaries isEmpty or: [temporaries hasEqualElements: methodTemporaries]]). 25527 temporaries := OrderedCollection withAll: methodTemporaries. 25528 25529 self assert: optimized not. "the top-level block should not be optimized." 25530 self analyseTempsWithin: self rootNode: rootNode assignmentPools: Dictionary new. 25531 25532 "The top-level block needs to reindex temporaries since analysis may have rearranged them. 25533 This happens when temps are made remote and/or a remote node is added." 25534 temporaries withIndexDo: 25535 [:temp :offsetPlusOne| temp index: arguments size + offsetPlusOne - 1]. 25536 25537 "Answer the (possibly modified) sequence of temps." 25538 ^temporaries asArray! ! 25539 25540!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2009 11:42'! 25541analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>" 25542 | effectiveScope blockStart | 25543 effectiveScope := optimized 25544 ifTrue: [actualScopeIfOptimized := scopeBlock] 25545 ifFalse: [self]. 25546 25547 arguments ifNotNil: 25548 [arguments do: [:temp| temp definingScope: self]]. 25549 temporaries ifNotNil: 25550 [temporaries do: [:temp| temp definingScope: self]]. 25551 25552 optimized ifFalse: "if optimized this isn't an actual scope" 25553 [rootNode noteBlockEntry: 25554 [:entryNumber| 25555 blockExtent := (blockStart := entryNumber) to: 0]]. 25556 25557 "Need to enumerate a copy because closure analysis can add a statement 25558 via ifHasRemoteTempNodeEnsureInitializationStatementExists:." 25559 statements copy do: 25560 [:statement| 25561 statement analyseTempsWithin: effectiveScope rootNode: rootNode assignmentPools: assignmentPools]. 25562 25563 optimized ifFalse: "if optimized this isn't an actual scope" 25564 [rootNode noteBlockExit: 25565 [:exitNumber| 25566 blockExtent := blockStart to: exitNumber]]. 25567 25568 "Now that the analysis is done move any temps that need to be moved." 25569 self postNumberingProcessTempsWithin: effectiveScope rootNode: rootNode. 25570 25571 "This is simply a nicety for compiler developers..." 25572 temporaries do: 25573 [:temp| 25574 (temp isIndirectTempVector and: [temp name includes: $?]) ifTrue: 25575 [temp name: temp definingScope remoteTempNodeName]]! ! 25576 25577!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 5/20/2008 12:16'! 25578blockExtent "^<Interval>" 25579 ^blockExtent! ! 25580 25581!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2009 11:56'! 25582computeCopiedValues: rootNode 25583 | referencedValues | 25584 referencedValues := rootNode referencedValuesWithinBlockExtent: blockExtent. 25585 ^((referencedValues reject: [:temp| temp isDefinedWithinBlockExtent: blockExtent]) 25586 asSortedCollection: ParseNode tempSortBlock) 25587 asArray! ! 25588 25589!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2008 14:10'! 25590constructClosureCreationNode: encoder 25591 copiedValues := self computeCopiedValues: encoder rootNode. 25592 encoder supportsClosureOpcodes ifTrue: 25593 [^self closureCreationNode]. 25594 "Without the bytecode we can still get by." 25595 ^MessageNode new 25596 receiver: (encoder encodeVariable: 'thisContext') 25597 selector: #closureCopy:copiedValues: 25598 arguments: (Array 25599 with: (encoder encodeLiteral: arguments size) 25600 with: (copiedValues isEmpty 25601 ifTrue: [NodeNil] 25602 ifFalse: [BraceNode new elements: copiedValues])) 25603 precedence: 3 25604 from: encoder! ! 25605 25606!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2008 14:10'! 25607emitCodeForClosureValue: stack encoder: encoder 25608 "if not supportsClosureOpcodes closureCreationSupportNode is the 25609 node for thisContext closureCopy: numArgs [ copiedValues: { values } ]" 25610 encoder supportsClosureOpcodes 25611 ifTrue: 25612 [copiedValues do: 25613 [:copiedValue| copiedValue emitCodeForValue: stack encoder: encoder]. 25614 closureCreationNode pc: encoder methodStreamPosition + 1. 25615 encoder 25616 genPushClosureCopyNumCopiedValues: copiedValues size 25617 numArgs: arguments size 25618 jumpSize: size. 25619 stack 25620 pop: copiedValues size; 25621 push: 1] 25622 ifFalse: 25623 [closureCreationNode emitCodeForValue: stack encoder: encoder. 25624 encoder genJumpLong: size]. "Force a two byte jump." 25625 "Emit the body of the block" 25626 self emitCodeForEvaluatedClosureValue: stack encoder: encoder! ! 25627 25628!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 9/12/2008 10:55'! 25629emitCodeForEvaluatedClosureValue: stack encoder: encoder 25630 | position | 25631 position := stack position. 25632 stack position: arguments size + copiedValues size. 25633 temporaries size timesRepeat: 25634 [NodeNil emitCodeForValue: stack encoder: encoder]. 25635 self 25636 reindexingLocalsDo: [self emitCodeForEvaluatedValue: stack encoder: encoder] 25637 encoder: encoder. 25638 self returns ifFalse: 25639 [encoder genReturnTopToCaller. 25640 pc := encoder methodStreamPosition]. 25641 stack position: position! ! 25642 25643!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2009 18:56'! 25644ifHasRemoteTempNodeEnsureInitializationStatementExists: rootNode 25645 "If a remoteTempNode has been added ensure a statement exists to initialize it." 25646 remoteTempNode ~~ nil ifTrue: 25647 [(statements notEmpty 25648 and: [statements first isAssignmentNode 25649 and: [statements first variable isTemp 25650 and: [statements first variable isIndirectTempVector]]]) 25651 ifTrue: "If this is a decompiled tree, or if a temporary has been added later in 25652 the analysis then there already is a temp vector initialization node." 25653 [(statements first variable ~~ remoteTempNode) ifTrue: 25654 [statements first variable become: remoteTempNode]. 25655 statements first value numElements: remoteTempNode remoteTemps size] 25656 ifFalse: 25657 [statements addFirst: (remoteTempNode nodeToInitialize: rootNode encoder)]].! ! 25658 25659!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 5/19/2008 17:12'! 25660noteOptimized 25661 optimized := true! ! 25662 25663!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/20/2009 09:52'! 25664optimizedBlockHoistTempsInto: scopeBlock "<BlockNode>" 25665 "This is a No-op for all nodes except non-optimized BlockNodes." 25666 "Let's assume the special > 0 guard in MessageNode>>analyseTempsWithin:forValue:encoder: is correct. 25667 Then we can simply hoist our temps up." 25668 self assert: (arguments isNil or: [arguments size <= 1]). 25669 (arguments notNil and: [arguments notEmpty]) ifTrue: 25670 [scopeBlock addHoistedTemps: arguments. 25671 arguments := #()]. 25672 temporaries notEmpty ifTrue: 25673 [scopeBlock addHoistedTemps: temporaries. 25674 temporaries := #()]! ! 25675 25676!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2009 16:23'! 25677postNumberingProcessTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" 25678 "A temp can be local (and copied) if it is not written to after it is captured. 25679 A temp cannot be local if it is written to remotely. 25680 Need to enumerate a copy of the temporaries because any temps becoming remote 25681 will be removed from temporaries in analyseClosure: (and a single remote temp node 25682 will get added)" 25683 temporaries copy do: 25684 [:each| 25685 each isIndirectTempVector ifFalse: 25686 [each analyseClosure: rootNode]]. 25687 25688 "If this is an optimized node we need to hoist temporaries up into the relevant block scope." 25689 optimized ifTrue: 25690 [self optimizedBlockHoistTempsInto: scopeBlock]. 25691 25692 "Now we may have added a remoteTempNode. So we need a statement to initialize it." 25693 self ifHasRemoteTempNodeEnsureInitializationStatementExists: rootNode. 25694 25695 "Now add all arguments and locals to the pool so that copiedValues can be computed during sizing." 25696 rootNode 25697 addLocalsToPool: arguments; 25698 addLocalsToPool: temporaries! ! 25699 25700!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 6/2/2008 16:37'! 25701reindexingLocalsDo: aBlock encoder: encoderOrNil 25702 "Evaluate aBlock wih arguments, temporaries and copiedValues reindexed for 25703 their positions within the receiver's block, restoring the correct indices afterwards. 25704 If encoder is not nil remember the temps for this block's extent." 25705 | tempIndices result tempsToReindex | 25706 self assert: copiedValues notNil. 25707 tempsToReindex := arguments asArray, copiedValues, temporaries. 25708 tempIndices := tempsToReindex collect: [:temp| temp index]. 25709 tempsToReindex withIndexDo: 25710 [:temp :newIndex| temp index: newIndex - 1. self assert: temp index + 1 = newIndex]. 25711 encoderOrNil ifNotNil: 25712 [encoderOrNil noteBlockExtent: blockExtent hasLocals: tempsToReindex]. 25713 result := aBlock ensure: 25714 ["Horribly pragmatic hack. The copiedValues will have completely 25715 unrelated indices within the closure method and sub-method. 25716 Avoiding the effort of rebinding temps in the inner scope simply 25717 update the indices to their correct ones during the generation of 25718 the closure method and restore the indices immedately there-after." 25719 tempsToReindex with: tempIndices do: 25720 [:temp :oldIndex| temp index: oldIndex. self assert: temp index = oldIndex]]. 25721 ^result! ! 25722 25723!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/22/2009 10:48'! 25724remoteTempNodeName 25725 "Answer a useful name for a RemoteTempVectorNode in the receiver." 25726 | prefix scope extent | 25727 prefix := actualScopeIfOptimized ifNil: ['<'] ifNotNil: [ '<...']. 25728 scope := self. 25729 [extent := scope blockExtent. 25730 extent == nil 25731 and: [scope actualScope ~~ scope]] whileTrue: 25732 [scope := scope actualScope]. 25733 ^extent 25734 ifNil: [prefix, '?-?>'] 25735 ifNotNil: 25736 [prefix, extent first printString, '-', 25737 (extent last isZero 25738 ifTrue: ['?'] 25739 ifFalse: [extent last printString]), '>']! ! 25740 25741!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2008 14:11'! 25742sizeCodeForClosureValue: encoder 25743 "Compute the size for the creation of the block and its code." 25744 "If we have the closure bytecodes constructClosureCreationNode: will note 25745 the copied values in the copiedValues inst var and answer #pushCopiedValues." 25746 closureCreationNode := self constructClosureCreationNode: encoder. 25747 "Remember size of body for emit time so we know the size of the jump around it." 25748 size := self sizeCodeForEvaluatedClosureValue: encoder. 25749 ^encoder supportsClosureOpcodes 25750 ifTrue: 25751 [(copiedValues inject: 0 into: [:sum :node| sum + (node sizeCodeForValue: encoder)]) 25752 + (encoder sizePushClosureCopyNumCopiedValues: copiedValues size numArgs: arguments size jumpSize: size) 25753 + size] 25754 ifFalse: 25755 ["closureCreationSupportNode is send closureCopy:copiedValues:" 25756 (closureCreationNode sizeCodeForValue: encoder) 25757 + (encoder sizeJumpLong: size) 25758 + size]! ! 25759 25760!BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 5/31/2008 14:31'! 25761sizeCodeForEvaluatedClosureValue: encoder 25762 "The closure value primitives push the arguments and the copied values. 25763 The compiler guarantees that any copied values come before all local temps. 25764 So on closure activation we only need to push nils for the remaining temporaries." 25765 ^temporaries size * (NodeNil sizeCodeForValue: encoder) 25766 + (self 25767 reindexingLocalsDo: [self sizeCodeForEvaluatedValue: encoder] 25768 encoder: nil "don't store temps yet") 25769 + (self returns ifTrue: [0] ifFalse: [encoder sizeReturnTopToCaller])! ! 25770 25771 25772!BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 6/2/2008 13:29'! 25773emitCodeExceptLast: stack encoder: encoder 25774 | position nextToLast | 25775 position := stack position. 25776 nextToLast := statements size - 1. 25777 1 to: nextToLast do: 25778 [:i | | statement | 25779 statement := statements at: i. 25780 statement emitCodeForEffect: stack encoder: encoder. 25781 self assert: stack position = position].! ! 25782 25783!BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/21/2008 11:28'! 25784emitCodeForEvaluatedEffect: stack encoder: encoder 25785 | position | 25786 position := stack position. 25787 self returns 25788 ifTrue: 25789 [self emitCodeForEvaluatedValue: stack encoder: encoder. 25790 stack pop: 1] 25791 ifFalse: 25792 [self emitCodeExceptLast: stack encoder: encoder. 25793 statements last emitCodeForEffect: stack encoder: encoder]. 25794 self assert: stack position = position! ! 25795 25796!BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/21/2008 11:36'! 25797emitCodeForEvaluatedValue: stack encoder: encoder 25798 | position | 25799 position := stack position. 25800 self emitCodeExceptLast: stack encoder: encoder. 25801 statements last emitCodeForBlockValue: stack encoder: encoder. 25802 self assert: stack position - 1 = position! ! 25803 25804!BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 16:55'! 25805emitCodeForValue: stack encoder: encoder 25806 25807 self generateAsClosure ifTrue: 25808 [^self emitCodeForClosureValue: stack encoder: encoder]. 25809 encoder genPushThisContext. 25810 stack push: 1. 25811 nArgsNode emitCodeForValue: stack encoder: encoder. 25812 remoteCopyNode 25813 emitCode: stack 25814 args: 1 25815 encoder: encoder. 25816 "Force a two byte jump." 25817 encoder genJumpLong: size. 25818 stack push: arguments size. 25819 arguments reverseDo: [:arg | arg emitCodeForStorePop: stack encoder: encoder]. 25820 self emitCodeForEvaluatedValue: stack encoder: encoder. 25821 self returns ifFalse: 25822 [encoder genReturnTopToCaller. 25823 pc := encoder methodStreamPosition]. 25824 stack pop: 1! ! 25825 25826!BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/29/2008 15:21'! 25827sizeCodeExceptLast: encoder 25828 | codeSize | 25829 codeSize := 0. 25830 1 to: statements size - 1 do: 25831 [:i | | statement | 25832 statement := statements at: i. 25833 codeSize := codeSize + (statement sizeCodeForEffect: encoder)]. 25834 ^codeSize! ! 25835 25836!BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:13'! 25837sizeCodeForEvaluatedEffect: encoder 25838 25839 ^self returns 25840 ifTrue: [self sizeCodeForEvaluatedValue: encoder] 25841 ifFalse: [(self sizeCodeExceptLast: encoder) 25842 + (statements last sizeCodeForEffect: encoder)]! ! 25843 25844!BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 25845sizeCodeForEvaluatedValue: encoder 25846 25847 ^(self sizeCodeExceptLast: encoder) 25848 + (statements last sizeCodeForBlockValue: encoder)! ! 25849 25850!BlockNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 16:55'! 25851sizeCodeForValue: encoder 25852 self generateAsClosure ifTrue: 25853 [^self sizeCodeForClosureValue: encoder]. 25854 25855 nArgsNode := encoder encodeLiteral: arguments size. 25856 remoteCopyNode := encoder encodeSelector: #blockCopy:. 25857 size := self sizeCodeForEvaluatedValue: encoder. 25858 self returns ifFalse: 25859 [size := size + encoder sizeReturnTopToCaller]. "endBlock" 25860 arguments := arguments collect: "Chance to prepare debugger remote temps" 25861 [:arg | arg asStorableNode: encoder]. 25862 arguments do: [:arg | size := size + (arg sizeCodeForStorePop: encoder)]. 25863 ^encoder sizePushThisContext 25864 + (nArgsNode sizeCodeForValue: encoder) 25865 + (remoteCopyNode sizeCode: encoder args: 1 super: false) 25866 + (encoder sizeJumpLong: size) 25867 + size! ! 25868 25869 25870!BlockNode methodsFor: 'equation translation'! 25871statements 25872 ^statements! ! 25873 25874!BlockNode methodsFor: 'equation translation'! 25875statements: val 25876 statements := val! ! 25877 25878 25879!BlockNode methodsFor: 'initialize-release' stamp: 'eem 5/20/2008 13:40'! 25880arguments: argNodes statements: statementsCollection returns: returnBool from: encoder 25881 "Compile." 25882 25883 arguments := argNodes. 25884 statements := statementsCollection size > 0 25885 ifTrue: [statementsCollection] 25886 ifFalse: [argNodes size > 0 25887 ifTrue: [statementsCollection copyWith: arguments last] 25888 ifFalse: [Array with: NodeNil]]. 25889 optimized := false. 25890 returns := returnBool! ! 25891 25892!BlockNode methodsFor: 'initialize-release' stamp: 'eem 8/4/2008 14:12'! 25893noteSourceRangeStart: start end: end encoder: encoder 25894 "Note two source ranges for this node. One is for the debugger 25895 and is of the last expression, the result of the block. One is for 25896 source analysis and is for the entire block." 25897 encoder 25898 noteSourceRange: (start to: end) 25899 forNode: self closureCreationNode. 25900 startOfLastStatement 25901 ifNil: 25902 [encoder 25903 noteSourceRange: (start to: end) 25904 forNode: self] 25905 ifNotNil: 25906 [encoder 25907 noteSourceRange: (startOfLastStatement to: end - 1) 25908 forNode: self]! ! 25909 25910!BlockNode methodsFor: 'initialize-release' stamp: 'eem 5/20/2008 13:40'! 25911statements: statementsCollection returns: returnBool 25912 "Decompile." 25913 25914 | returnLast | 25915 returnLast := returnBool. 25916 returns := false. 25917 statements := 25918 (statementsCollection size > 1 25919 and: [(statementsCollection at: statementsCollection size - 1) 25920 isReturningIf]) 25921 ifTrue: 25922 [returnLast := false. 25923 statementsCollection allButLast] 25924 ifFalse: [statementsCollection size = 0 25925 ifTrue: [Array with: NodeNil] 25926 ifFalse: [statementsCollection]]. 25927 arguments := #(). 25928 temporaries := #(). 25929 optimized := false. 25930 returnLast ifTrue: [self returnLast]! ! 25931 25932 25933!BlockNode methodsFor: 'printing' stamp: 'alain.plantec 5/18/2009 15:34'! 25934decompileString 25935 "Answer a string description of the parse tree whose root is the receiver." 25936 25937 ^ self printString 25938! ! 25939 25940!BlockNode methodsFor: 'printing' stamp: 'eem 5/6/2008 14:28'! 25941printArgumentsOn: aStream indent: level 25942 arguments size = 0 ifTrue: [^ self]. 25943 arguments do: 25944 [:arg | aStream nextPut: $:; nextPutAll: arg key; space]. 25945 aStream nextPut: $|; space. 25946 "If >0 args and >1 statement, put all statements on separate lines" 25947 statements size > 1 ifTrue: 25948 [aStream crtab: level]! ! 25949 25950!BlockNode methodsFor: 'printing' stamp: 'eem 9/25/2008 12:48'! 25951printOn: aStream indent: level 25952 25953 "statements size <= 1 ifFalse: [aStream crtab: level]." 25954 aStream nextPut: $[. 25955 self printArgumentsOn: aStream indent: level. 25956 (self printTemporaries: temporaries on: aStream doPrior: []) ifTrue: 25957 ["If >0 temps and >1 statement, put all statements on separate lines" 25958 statements size > 1 25959 ifTrue: [aStream crtab: level] 25960 ifFalse: [aStream space]]. 25961 self printStatementsOn: aStream indent: level. 25962 aStream nextPut: $]! ! 25963 25964!BlockNode methodsFor: 'printing' stamp: 'eem 9/23/2008 15:05'! 25965printStatementsOn: aStream indent: levelOrZero 25966 | len shown thisStatement level | 25967 level := 1 max: levelOrZero. 25968 comment == nil 25969 ifFalse: 25970 [self printCommentOn: aStream indent: level. 25971 aStream crtab: level]. 25972 len := shown := statements size. 25973 (levelOrZero = 0 "top level" and: [statements last isReturnSelf]) 25974 ifTrue: [shown := 1 max: shown - 1] 25975 ifFalse: ["should a trailing nil be printed or not? Not if it is an implicit result." 25976 (arguments size = 0 25977 and: [len >= 1 25978 and: [(statements at: len) == NodeNil 25979 and: [len = 1 25980 or: [len > 1 25981 and: [(statements at: len - 1) isMessageNode 25982 and: [(statements at: len - 1) isNilIf]]]]]]) 25983 ifTrue: [shown := shown - 1]]. 25984 1 to: shown do: 25985 [:i | 25986 thisStatement := statements at: i. 25987 thisStatement printOn: aStream indent: level. 25988 i < shown ifTrue: [aStream nextPut: $.; crtab: level]. 25989 (thisStatement comment ~~ nil and: [thisStatement comment size > 0]) 25990 ifTrue: 25991 [i = shown ifTrue: [aStream crtab: level]. 25992 thisStatement printCommentOn: aStream indent: level. 25993 i < shown ifTrue: [aStream crtab: level]]]! ! 25994 25995!BlockNode methodsFor: 'printing' stamp: 'eem 7/21/2009 13:12'! 25996printTemporaries: tempSequence on: aStream doPrior: aBlock 25997 "Print any in-scope temporaries. If there are any evaluate aBlock 25998 prior to printing. Answer whether any temporaries were printed." 25999 | tempStream seen | 26000 tempSequence ifNil: 26001 [^false]. 26002 tempStream := (String new: 16) writeStream. 26003 "This is for the decompiler which canmot work out which optimized block a particular temp is 26004 local to and hence may produce diplicates as in 26005 expr ifTrue: [| aTemp | ...] ifFalse: [| aTemp | ...]" 26006 seen := Set new. 26007 tempSequence do: 26008 [:tempNode | 26009 tempNode isIndirectTempVector 26010 ifTrue: 26011 [tempNode remoteTemps do: 26012 [:tempVariableNode| 26013 (tempVariableNode scope >= 0 26014 and: [(seen includes: tempNode key) not]) ifTrue: 26015 [tempStream space; nextPutAll: (seen add: tempVariableNode key)]]] 26016 ifFalse: 26017 [(tempNode scope >= -1 26018 and: ["This is for the decompiler which may create a block arg when converting 26019 a while into a to:do: but won't remove it form temporaries" 26020 tempNode isBlockArg not 26021 and: [(seen includes: tempNode key) not]]) ifTrue: 26022 [tempStream space; nextPutAll: (seen add: tempNode key)]]]. 26023 tempStream position = 0 ifTrue: 26024 [^false]. 26025 aBlock value. 26026 aStream nextPut: $|; nextPutAll: tempStream contents; space; nextPut: $|. 26027 ^true! ! 26028 26029!BlockNode methodsFor: 'printing' stamp: 'eem 6/2/2008 12:06'! 26030printWithClosureAnalysisArgumentsOn: aStream indent: level 26031 arguments size = 0 ifTrue: [^self]. 26032 arguments do: 26033 [:tempNode | 26034 aStream space; nextPut: $:. 26035 tempNode printDefinitionForClosureAnalysisOn: aStream]. 26036 aStream nextPut: $|; space. 26037 "If >0 args and >1 statement, put all statements on separate lines" 26038 statements size > 1 ifTrue: 26039 [aStream crtab: level]! ! 26040 26041!BlockNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:53'! 26042printWithClosureAnalysisOn: aStream indent: level 26043 aStream nextPut: $[. 26044 blockExtent ifNotNil: [aStream print: blockExtent]. 26045 self printWithClosureAnalysisArgumentsOn: aStream indent: level. 26046 self printWithClosureAnalysisTemporariesOn: aStream indent: level. 26047 self printWithClosureAnalysisStatementsOn: aStream indent: level. 26048 aStream nextPut: $]! ! 26049 26050!BlockNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:48'! 26051printWithClosureAnalysisStatementsOn: aStream indent: levelOrZero 26052 | len shown thisStatement level | 26053 level := 1 max: levelOrZero. 26054 comment == nil 26055 ifFalse: 26056 [self printCommentOn: aStream indent: level. 26057 aStream crtab: level]. 26058 len := shown := statements size. 26059 (levelOrZero = 0 "top level" and: [statements last isReturnSelf]) 26060 ifTrue: [shown := 1 max: shown - 1] 26061 ifFalse: [(len = 1 and: [((statements at: 1) == NodeNil) & (arguments size = 0)]) 26062 ifTrue: [shown := shown - 1]]. 26063 1 to: shown do: 26064 [:i | 26065 thisStatement := statements at: i. 26066 thisStatement printWithClosureAnalysisOn: aStream indent: level. 26067 i < shown ifTrue: [aStream nextPut: $.; crtab: level]. 26068 (thisStatement comment ~~ nil and: [thisStatement comment size > 0]) 26069 ifTrue: 26070 [i = shown ifTrue: [aStream crtab: level]. 26071 thisStatement printCommentOn: aStream indent: level. 26072 i < shown ifTrue: [aStream crtab: level]]]! ! 26073 26074!BlockNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:54'! 26075printWithClosureAnalysisTemporariesOn: aStream indent: level 26076 26077 (temporaries == nil or: [temporaries size = 0]) ifFalse: 26078 [aStream nextPut: $|. 26079 temporaries do: 26080 [:tempNode | 26081 aStream space. 26082 tempNode printDefinitionForClosureAnalysisOn: aStream]. 26083 aStream nextPutAll: ' | '. 26084 "If >0 args and >1 statement, put all statements on separate lines" 26085 statements size > 1 ifTrue: [aStream crtab: level]]! ! 26086 26087 26088!BlockNode methodsFor: 'testing'! 26089canBeSpecialArgument 26090 "Can I be an argument of (e.g.) ifTrue:?" 26091 26092 ^arguments size = 0! ! 26093 26094!BlockNode methodsFor: 'testing' stamp: 'eem 7/17/2008 12:20'! 26095generateAsClosure 26096 "Answer if we're compiling under the closure regime. If blockExtent has been set by 26097 analyseTempsWithin:rootNode: et al then we're compiling under the closure regime." 26098 ^blockExtent ~~ nil! ! 26099 26100!BlockNode methodsFor: 'testing' stamp: 'eem 9/25/2008 12:10'! 26101isBlockNode 26102 ^true! ! 26103 26104!BlockNode methodsFor: 'testing'! 26105isComplex 26106 26107 ^statements size > 1 or: [statements size = 1 and: [statements first isComplex]]! ! 26108 26109!BlockNode methodsFor: 'testing'! 26110isJust: node 26111 26112 returns ifTrue: [^false]. 26113 ^statements size = 1 and: [statements first == node]! ! 26114 26115!BlockNode methodsFor: 'testing'! 26116isJustCaseError 26117 26118 ^ statements size = 1 and: 26119 [statements first 26120 isMessage: #caseError 26121 receiver: [:r | r==NodeSelf] 26122 arguments: nil]! ! 26123 26124!BlockNode methodsFor: 'testing'! 26125isQuick 26126 ^ statements size = 1 26127 and: [statements first isVariableReference 26128 or: [statements first isSpecialConstant]]! ! 26129 26130!BlockNode methodsFor: 'testing'! 26131returns 26132 26133 ^returns or: [statements last isReturningIf]! ! 26134 26135 26136!BlockNode methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:13'! 26137accept: aVisitor 26138 aVisitor visitBlockNode: self! ! 26139 26140"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 26141 26142BlockNode class 26143 instanceVariableNames: ''! 26144 26145!BlockNode class methodsFor: 'instance creation' stamp: 'sma 3/3/2000 13:34'! 26146statements: statements returns: returns 26147 ^ self new statements: statements returns: returns! ! 26148 26149!BlockNode class methodsFor: 'instance creation' stamp: 'eem 5/19/2008 17:10'! 26150withJust: aNode 26151 ^ self new statements: (Array with: aNode) returns: false! ! 26152InstructionClient subclass: #BlockStartLocator 26153 instanceVariableNames: 'nextJumpIsAroundBlock' 26154 classVariableNames: '' 26155 poolDictionaries: '' 26156 category: 'Kernel-Methods'! 26157 26158!BlockStartLocator methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:43'! 26159initialize 26160 super initialize. 26161 nextJumpIsAroundBlock := false! ! 26162 26163 26164!BlockStartLocator methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:48'! 26165jump: offset 26166 "If this jump is around a block answer the size of that block." 26167 26168 nextJumpIsAroundBlock ifTrue: 26169 [nextJumpIsAroundBlock := false. 26170 ^offset]! ! 26171 26172!BlockStartLocator methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:54'! 26173pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize 26174 "Answer the size of the block" 26175 ^blockSize! ! 26176 26177!BlockStartLocator methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 14:16'! 26178send: selector super: supered numArgs: numberArguments 26179 nextJumpIsAroundBlock := #closureCopy:copiedValues: == selector 26180 "Don't use 26181 nextJumpIsAroundBlock := #(blockCopy: closureCopy:copiedValues:) includes: selector 26182 since BlueBook BlockContexts do not have their own temps."! ! 26183Object subclass: #Boolean 26184 instanceVariableNames: '' 26185 classVariableNames: '' 26186 poolDictionaries: '' 26187 category: 'Kernel-Objects'! 26188!Boolean commentStamp: '<historical>' prior: 0! 26189Boolean is an abstract class defining the protocol for logic testing operations and conditional control structures for the logical values represented by the instances of its subclasses True and False. 26190 26191Boolean redefines #new so no instances of Boolean can be created. It also redefines several messages in the 'copying' protocol to ensure that only one instance of each of its subclasses True (the global true, logical assertion) and False (the global false, logical negation) ever exist in the system.! 26192 26193 26194!Boolean methodsFor: 'controlling'! 26195and: alternativeBlock 26196 "Nonevaluating conjunction. If the receiver is true, answer the value of 26197 the argument, alternativeBlock; otherwise answer false without 26198 evaluating the argument." 26199 26200 self subclassResponsibility! ! 26201 26202!Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44'! 26203and: block1 and: block2 26204 "Nonevaluating conjunction without deep nesting. 26205 The receiver is evaluated, followed by the blocks in order. 26206 If any of these evaluates as false, then return false immediately, 26207 without evaluating any further blocks. 26208 If all return true, then return true." 26209 26210 self ifFalse: [^ false]. 26211 block1 value ifFalse: [^ false]. 26212 block2 value ifFalse: [^ false]. 26213 ^ true! ! 26214 26215!Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44'! 26216and: block1 and: block2 and: block3 26217 "Nonevaluating conjunction without deep nesting. 26218 The receiver is evaluated, followed by the blocks in order. 26219 If any of these evaluates as false, then return false immediately, 26220 without evaluating any further blocks. 26221 If all return true, then return true." 26222 26223 self ifFalse: [^ false]. 26224 block1 value ifFalse: [^ false]. 26225 block2 value ifFalse: [^ false]. 26226 block3 value ifFalse: [^ false]. 26227 ^ true! ! 26228 26229!Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44'! 26230and: block1 and: block2 and: block3 and: block4 26231 "Nonevaluating conjunction without deep nesting. 26232 The receiver is evaluated, followed by the blocks in order. 26233 If any of these evaluates as false, then return false immediately, 26234 without evaluating any further blocks. 26235 If all return true, then return true." 26236 26237 self ifFalse: [^ false]. 26238 block1 value ifFalse: [^ false]. 26239 block2 value ifFalse: [^ false]. 26240 block3 value ifFalse: [^ false]. 26241 block4 value ifFalse: [^ false]. 26242 ^ true! ! 26243 26244!Boolean methodsFor: 'controlling'! 26245ifFalse: alternativeBlock 26246 "If the receiver is true (i.e., the condition is true), then the value is the 26247 true alternative, which is nil. Otherwise answer the result of evaluating 26248 the argument, alternativeBlock. Create an error notification if the 26249 receiver is nonBoolean. Execution does not actually reach here because 26250 the expression is compiled in-line." 26251 26252 self subclassResponsibility! ! 26253 26254!Boolean methodsFor: 'controlling'! 26255ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock 26256 "Same as ifTrue:ifFalse:." 26257 26258 self subclassResponsibility! ! 26259 26260!Boolean methodsFor: 'controlling'! 26261ifTrue: alternativeBlock 26262 "If the receiver is false (i.e., the condition is false), then the value is the 26263 false alternative, which is nil. Otherwise answer the result of evaluating 26264 the argument, alternativeBlock. Create an error notification if the 26265 receiver is nonBoolean. Execution does not actually reach here because 26266 the expression is compiled in-line." 26267 26268 self subclassResponsibility! ! 26269 26270!Boolean methodsFor: 'controlling'! 26271ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock 26272 "If the receiver is true (i.e., the condition is true), then answer the value 26273 of the argument trueAlternativeBlock. If the receiver is false, answer the 26274 result of evaluating the argument falseAlternativeBlock. If the receiver 26275 is a nonBoolean then create an error notification. Execution does not 26276 actually reach here because the expression is compiled in-line." 26277 26278 self subclassResponsibility! ! 26279 26280!Boolean methodsFor: 'controlling'! 26281or: alternativeBlock 26282 "Nonevaluating disjunction. If the receiver is false, answer the value of 26283 the argument, alternativeBlock; otherwise answer true without 26284 evaluating the argument." 26285 26286 self subclassResponsibility! ! 26287 26288!Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45'! 26289or: block1 or: block2 26290 "Nonevaluating alternation without deep nesting. 26291 The receiver is evaluated, followed by the blocks in order. 26292 If any of these evaluates as true, then return true immediately, 26293 without evaluating any further blocks. 26294 If all return false, then return false." 26295 26296 self ifTrue: [^ true]. 26297 block1 value ifTrue: [^ true]. 26298 block2 value ifTrue: [^ true]. 26299 ^ false! ! 26300 26301!Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45'! 26302or: block1 or: block2 or: block3 26303 "Nonevaluating alternation without deep nesting. 26304 The receiver is evaluated, followed by the blocks in order. 26305 If any of these evaluates as true, then return true immediately, 26306 without evaluating any further blocks. 26307 If all return false, then return false." 26308 26309 self ifTrue: [^ true]. 26310 block1 value ifTrue: [^ true]. 26311 block2 value ifTrue: [^ true]. 26312 block3 value ifTrue: [^ true]. 26313 ^ false! ! 26314 26315!Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45'! 26316or: block1 or: block2 or: block3 or: block4 26317 "Nonevaluating alternation without deep nesting. 26318 The receiver is evaluated, followed by the blocks in order. 26319 If any of these evaluates as true, then return true immediately, 26320 without evaluating any further blocks. 26321 If all return false, then return false." 26322 26323 self ifTrue: [^ true]. 26324 block1 value ifTrue: [^ true]. 26325 block2 value ifTrue: [^ true]. 26326 block3 value ifTrue: [^ true]. 26327 block4 value ifTrue: [^ true]. 26328 ^ false! ! 26329 26330!Boolean methodsFor: 'controlling' stamp: 'dgd 9/26/2004 19:05'! 26331or: block1 or: block2 or: block3 or: block4 or: block5 26332 "Nonevaluating alternation without deep nesting. 26333 The receiver is evaluated, followed by the blocks in order. 26334 If any of these evaluates as true, then return true immediately, 26335 without evaluating any further blocks. 26336 If all return false, then return false." 26337 26338 self ifTrue: [^ true]. 26339 block1 value ifTrue: [^ true]. 26340 block2 value ifTrue: [^ true]. 26341 block3 value ifTrue: [^ true]. 26342 block4 value ifTrue: [^ true]. 26343 block5 value ifTrue: [^ true]. 26344 ^ false! ! 26345 26346 26347!Boolean methodsFor: 'copying' stamp: 'tk 6/26/1998 11:32'! 26348clone 26349 "Receiver has two concrete subclasses, True and False. 26350 Only one instance of each should be made, so return self."! ! 26351 26352!Boolean methodsFor: 'copying'! 26353deepCopy 26354 "Receiver has two concrete subclasses, True and False. 26355 Only one instance of each should be made, so return self."! ! 26356 26357!Boolean methodsFor: 'copying'! 26358shallowCopy 26359 "Receiver has two concrete subclasses, True and False. 26360 Only one instance of each should be made, so return self."! ! 26361 26362!Boolean methodsFor: 'copying' stamp: 'tk 8/20/1998 16:07'! 26363veryDeepCopyWith: deepCopier 26364 "Return self. I can't be copied. Do not record me."! ! 26365 26366 26367!Boolean methodsFor: 'logical operations'! 26368& aBoolean 26369 "Evaluating conjunction. Evaluate the argument. Then answer true if 26370 both the receiver and the argument are true." 26371 26372 self subclassResponsibility! ! 26373 26374!Boolean methodsFor: 'logical operations' stamp: 'stephane.ducasse 5/20/2009 21:28'! 26375==> aBlock 26376 "The material conditional, also known as the material implication or truth functional conditional. 26377 Correspond to not ... or ... and does not correspond to the English if...then... construction. 26378 26379 known as: 26380 b if a 26381 a implies b 26382 if a then b 26383 b is a consequence of a 26384 a therefore b (but note: 'it is raining therefore it is cloudy' is implication; 'it is autumn therefore the leaves are falling' is equivalence). 26385 26386 Here is the truth table for material implication: 26387 26388 p | q | p ==> q 26389 -------|-------|------------- 26390 T | T | T 26391 T | F | F 26392 F | T | T 26393 F | F | T 26394 " 26395 26396 ^self not or: [aBlock value]! ! 26397 26398!Boolean methodsFor: 'logical operations'! 26399eqv: aBoolean 26400 "Answer true if the receiver is equivalent to aBoolean." 26401 26402 ^self == aBoolean! ! 26403 26404!Boolean methodsFor: 'logical operations'! 26405not 26406 "Negation. Answer true if the receiver is false, answer false if the 26407 receiver is true." 26408 26409 self subclassResponsibility! ! 26410 26411!Boolean methodsFor: 'logical operations'! 26412| aBoolean 26413 "Evaluating disjunction (OR). Evaluate the argument. Then answer true 26414 if either the receiver or the argument is true." 26415 26416 self subclassResponsibility! ! 26417 26418 26419!Boolean methodsFor: 'printing' stamp: 'sw 9/27/2001 17:19'! 26420basicType 26421 "Answer a symbol representing the inherent type of the receiver" 26422 26423 ^ #Boolean! ! 26424 26425!Boolean methodsFor: 'printing' stamp: 'apb 4/21/2006 09:22'! 26426isLiteral 26427 ^ true! ! 26428 26429!Boolean methodsFor: 'printing'! 26430storeOn: aStream 26431 "Refer to the comment in Object|storeOn:." 26432 26433 self printOn: aStream! ! 26434 26435 26436!Boolean methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:45'! 26437isSelfEvaluating 26438 ^ true! ! 26439 26440"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 26441 26442Boolean class 26443 instanceVariableNames: ''! 26444 26445!Boolean class methodsFor: 'instance creation' stamp: 'sw 5/5/2000 00:31'! 26446initializedInstance 26447 ^ nil! ! 26448 26449!Boolean class methodsFor: 'instance creation'! 26450new 26451 self error: 'You may not create any more Booleans - this is two-valued logic'! ! 26452PreferenceView subclass: #BooleanPreferenceView 26453 instanceVariableNames: '' 26454 classVariableNames: '' 26455 poolDictionaries: '' 26456 category: 'System-Support'! 26457!BooleanPreferenceView commentStamp: '<historical>' prior: 0! 26458I am responsible for building the visual representation of a preference that accepts true and false values! 26459 26460 26461!BooleanPreferenceView methodsFor: 'user interface' stamp: 'alain.plantec 5/30/2008 09:57'! 26462offerPreferenceNameMenu: aPanel with: ignored1 in: ignored2 26463 "the user clicked on a preference name -- put up a menu" 26464 26465 | aMenu | 26466 ActiveHand showTemporaryCursor: nil. 26467 aMenu := MenuMorph new defaultTarget: self preference. 26468 aMenu addTitle: self preference name. 26469 26470 (Preferences okayToChangeProjectLocalnessOf: self preference name) ifTrue: 26471 [aMenu addUpdating: #isProjectLocalString target: self preference action: #toggleProjectLocalness. 26472 aMenu balloonTextForLastItem: 'Some preferences are best applied uniformly to all projects, and others are best set by each individual project. If this item is checked, then this preference will be printed in bold and will have a separate value for each project']. 26473 26474 aMenu add: 'browse senders' target: self systemNavigation selector: #browseAllCallsOn: argument: self preference name. 26475 aMenu balloonTextForLastItem: 'This will open a method-list browser on all methods that the send the preference "', self preference name, '".'. 26476 aMenu add: 'show category...' target: aPanel selector: #findCategoryFromPreference: argument: self preference name. 26477 aMenu balloonTextForLastItem: 'Allows you to find out which category, or categories, this preference belongs to.'. 26478 26479 aMenu add: 'hand me a button for this preference' target: self selector: #tearOffButton. 26480 aMenu balloonTextForLastItem: 'Will give you a button that governs this preference, which you may deposit wherever you wish'. 26481 26482 aMenu add: 'copy this name to clipboard' target: self preference selector: #copyName. 26483 aMenu balloonTextForLastItem: 'Copy the name of the preference to the text clipboard, so that you can paste into code somewhere'. 26484 26485 aMenu popUpInWorld! ! 26486 26487!BooleanPreferenceView methodsFor: 'user interface' stamp: 'md 9/5/2005 15:40'! 26488representativeButtonWithColor: aColor inPanel: aPreferencesPanel 26489 "Return a button that controls the setting of prefSymbol. It will keep up to date even if the preference value is changed in a different place" 26490 26491 | outerButton aButton str miniWrapper | 26492 26493 outerButton := AlignmentMorph newRow height: 24. 26494 outerButton color: (aColor ifNil: [Color r: 0.645 g: 1.0 b: 1.0]). 26495 outerButton hResizing: (aPreferencesPanel ifNil: [#shrinkWrap] ifNotNil: [#spaceFill]). 26496 outerButton vResizing: #shrinkWrap. 26497 outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox). 26498 aButton 26499 target: self preference; 26500 actionSelector: #togglePreferenceValue; 26501 getSelector: #preferenceValue. 26502 26503 outerButton addTransparentSpacerOfSize: (2 @ 0). 26504 str := StringMorph contents: self preference name font: (StrikeFont familyName: 'NewYork' size: 12). 26505 26506 self preference localToProject ifTrue: 26507 [str emphasis: TextEmphasis bold emphasisCode]. 26508 26509 miniWrapper := AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap. 26510 miniWrapper beTransparent addMorphBack: str lock. 26511 aPreferencesPanel 26512 ifNotNil: "We're in a Preferences panel" 26513 [miniWrapper on: #mouseDown send: #offerPreferenceNameMenu:with:in: to: self withValue: aPreferencesPanel. 26514 miniWrapper on: #mouseEnter send: #menuButtonMouseEnter: to: miniWrapper. 26515 miniWrapper on: #mouseLeave send: #menuButtonMouseLeave: to: miniWrapper. 26516 miniWrapper setBalloonText: 'Click here for a menu of options regarding this preference. Click on the checkbox to the left to toggle the setting of this preference'] 26517 26518 ifNil: "We're a naked button, not in a panel" 26519 [miniWrapper setBalloonText: self preference helpString; setProperty: #balloonTarget toValue: aButton]. 26520 26521 outerButton addMorphBack: miniWrapper. 26522 outerButton setNameTo: self preference name. 26523 26524 aButton setBalloonText: self preference helpString. 26525 26526 ^ outerButton 26527 26528 "(Preferences preferenceAt: #balloonHelpEnabled) view tearOffButton"! ! 26529 26530"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 26531 26532BooleanPreferenceView class 26533 instanceVariableNames: ''! 26534 26535!BooleanPreferenceView class methodsFor: 'initialization' stamp: 'hpt 9/26/2004 15:55'! 26536initialize 26537 PreferenceViewRegistry ofBooleanPreferences register: self.! ! 26538 26539!BooleanPreferenceView class methodsFor: 'initialization' stamp: 'hpt 9/26/2004 15:55'! 26540unload 26541 PreferenceViewRegistry ofBooleanPreferences unregister: self.! ! 26542 26543 26544!BooleanPreferenceView class methodsFor: 'view registry' stamp: 'alain.plantec 6/6/2009 22:38'! 26545handlesPanel: aPreferencePanel 26546 ^false! ! 26547ClassTestCase subclass: #BooleanTest 26548 instanceVariableNames: '' 26549 classVariableNames: '' 26550 poolDictionaries: '' 26551 category: 'KernelTests-Objects'! 26552!BooleanTest commentStamp: '<historical>' prior: 0! 26553This is the unit test for the class Boolean. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 26554 - http://www.c2.com/cgi/wiki?UnitTest 26555 - http://minnow.cc.gatech.edu/squeak/1547 26556 - the sunit class category 26557! 26558 26559 26560!BooleanTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:02'! 26561testBooleanInitializedInstance 26562 26563 self assert: (Boolean initializedInstance = nil).! ! 26564 26565!BooleanTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:02'! 26566testBooleanNew 26567 26568 self should: [Boolean new] raise: TestResult error. 26569 self should: [True new] raise: TestResult error. 26570 self should: [False new] raise: TestResult error. ! ! 26571 26572!BooleanTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:02'! 26573testNew 26574 26575 self should: [Boolean new] raise: TestResult error. ! ! 26576Object subclass: #BorderStyle 26577 instanceVariableNames: '' 26578 classVariableNames: 'Default' 26579 poolDictionaries: '' 26580 category: 'Morphic-Borders'! 26581!BorderStyle commentStamp: 'kfr 10/27/2003 10:19' prior: 0! 26582See BorderedMorph 26583 26584BorderedMorh new borderStyle: (BorderStyle inset width: 2); openInWorld.! 26585 26586 26587!BorderStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/25/2008 12:09'! 26588hasFillStyle 26589 "Answer false." 26590 26591 ^false! ! 26592 26593!BorderStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/14/2007 10:31'! 26594isComposite 26595 "Answer false." 26596 26597 ^false! ! 26598 26599!BorderStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/25/2009 15:35'! 26600printOn: aStream 26601 "Print a description of the 26602 receiver on the given stream." 26603 26604 self storeOn: aStream! ! 26605 26606!BorderStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/25/2009 15:34'! 26607storeOn: aStream 26608 "Store a reconstructable representation of the 26609 receiver on the given stream." 26610 26611 aStream 26612 nextPutAll: '(' , self class name; 26613 nextPutAll: ' width: '; print: self width; 26614 nextPutAll: ' color: '; print: self color; 26615 nextPutAll: ')'! ! 26616 26617 26618!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'! 26619baseColor 26620 ^Color transparent! ! 26621 26622!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'! 26623baseColor: aColor 26624 "Ignored"! ! 26625 26626!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! 26627color 26628 ^Color transparent! ! 26629 26630!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! 26631color: aColor 26632 "Ignored"! ! 26633 26634!BorderStyle methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:22'! 26635colorsAtCorners 26636 ^Array new: 4 withAll: self color! ! 26637 26638!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! 26639dotOfSize: diameter forDirection: aDirection 26640 | form | 26641 form := Form extent: diameter@diameter depth: Display depth. 26642 form getCanvas fillOval: form boundingBox color: self color. 26643 ^form! ! 26644 26645!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'! 26646style 26647 ^#none! ! 26648 26649!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! 26650width 26651 ^0! ! 26652 26653!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! 26654width: aNumber 26655 "Ignored"! ! 26656 26657!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:08'! 26658widthForRounding 26659 ^self width! ! 26660 26661 26662!BorderStyle methodsFor: 'color tracking' stamp: 'ar 8/25/2001 17:29'! 26663trackColorFrom: aMorph 26664 "If necessary, update our color to reflect a change in aMorphs color"! ! 26665 26666 26667!BorderStyle methodsFor: 'comparing' stamp: 'ar 8/25/2001 18:38'! 26668= aBorderStyle 26669 ^self species = aBorderStyle species 26670 and:[self style == aBorderStyle style 26671 and:[self width = aBorderStyle width 26672 and:[self color = aBorderStyle color]]].! ! 26673 26674!BorderStyle methodsFor: 'comparing' stamp: 'ar 8/25/2001 16:08'! 26675hash 26676 "hash is implemented because #= is implemented" 26677 ^self species hash bitXor: (self width hash bitXor: self color hash)! ! 26678 26679 26680!BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 17:01'! 26681drawLineFrom: startPoint to: stopPoint on: aCanvas 26682 ^aCanvas line: startPoint to: stopPoint width: self width color: self color! ! 26683 26684!BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:24'! 26685frameOval: aRectangle on: aCanvas 26686 "Frame the given rectangle on aCanvas" 26687 aCanvas frameOval: aRectangle width: self width color: self color! ! 26688 26689!BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:57'! 26690framePolygon: vertices on: aCanvas 26691 "Frame the given rectangle on aCanvas" 26692 self framePolyline: vertices on: aCanvas. 26693 self drawLineFrom: vertices last to: vertices first on: aCanvas.! ! 26694 26695!BorderStyle methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:59'! 26696framePolyline: vertices on: aCanvas 26697 "Frame the given rectangle on aCanvas" 26698 26699 | prev next | 26700 prev := vertices first. 26701 2 to: vertices size 26702 do: 26703 [:i | 26704 next := vertices at: i. 26705 self 26706 drawLineFrom: prev 26707 to: next 26708 on: aCanvas. 26709 prev := next]! ! 26710 26711!BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:24'! 26712frameRectangle: aRectangle on: aCanvas 26713 "Frame the given rectangle on aCanvas" 26714 aCanvas frameRectangle: aRectangle width: self width color: self color! ! 26715 26716 26717!BorderStyle methodsFor: 'initialize' stamp: 'ar 8/25/2001 16:06'! 26718releaseCachedState 26719 "Release any associated cached state"! ! 26720 26721 26722!BorderStyle methodsFor: 'testing' stamp: 'ar 8/25/2001 16:08'! 26723isBorderStyle 26724 ^true! ! 26725 26726!BorderStyle methodsFor: 'testing' stamp: 'ar 8/26/2001 19:30'! 26727isComplex 26728 ^false! ! 26729 26730"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 26731 26732BorderStyle class 26733 instanceVariableNames: ''! 26734 26735!BorderStyle class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/8/2007 17:20'! 26736dashed 26737 "Answer a dashed border style" 26738 26739 ^DashedBorder new! ! 26740 26741 26742!BorderStyle class methodsFor: 'instance creation' stamp: 'sw 11/26/2001 16:05'! 26743borderStyleChoices 26744 "Answer the superset of all supported borderStyle symbols" 26745 26746 ^ #(simple inset raised complexAltFramed complexAltInset complexAltRaised complexFramed complexInset complexRaised)! ! 26747 26748!BorderStyle class methodsFor: 'instance creation' stamp: 'yo 7/2/2004 17:21'! 26749borderStyleForSymbol: sym 26750 "Answer a border style corresponding to the given symbol" 26751 26752 | aSymbol | 26753 aSymbol := sym == #none ifTrue: [#simple] ifFalse: [sym]. 26754 ^ self perform: aSymbol 26755" 26756 | aSymbol selector | 26757 aSymbol := sym == #none ifTrue: [#simple] ifFalse: [sym]. 26758 selector := Vocabulary eToyVocabulary translationKeyFor: aSymbol. 26759 selector isNil ifTrue: [selector := aSymbol]. 26760 ^ self perform: selector 26761" 26762! ! 26763 26764!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 23:52'! 26765color: aColor width: aNumber 26766 ^self width: aNumber color: aColor! ! 26767 26768!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:01'! 26769complexAltFramed 26770 ^ComplexBorder style: #complexAltFramed! ! 26771 26772!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:01'! 26773complexAltInset 26774 ^ComplexBorder style: #complexAltInset! ! 26775 26776!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! 26777complexAltRaised 26778 ^ComplexBorder style: #complexAltRaised! ! 26779 26780!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! 26781complexFramed 26782 ^ComplexBorder style: #complexFramed! ! 26783 26784!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! 26785complexInset 26786 ^ComplexBorder style: #complexInset! ! 26787 26788!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! 26789complexRaised 26790 ^ComplexBorder style: #complexRaised! ! 26791 26792!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 17:26'! 26793default 26794 ^Default ifNil:[Default := self new]! ! 26795 26796!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 14:59'! 26797inset 26798 ^InsetBorder new! ! 26799 26800!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 14:59'! 26801raised 26802 ^RaisedBorder new! ! 26803 26804!BorderStyle class methodsFor: 'instance creation' stamp: 'sw 11/27/2001 15:22'! 26805simple 26806 "Answer a simple border style" 26807 26808 ^ SimpleBorder new! ! 26809 26810!BorderStyle class methodsFor: 'instance creation' stamp: 'rr 6/21/2005 13:50'! 26811thinGray 26812 ^ self width: 1 color: Color gray! ! 26813 26814!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:19'! 26815width: aNumber 26816 ^self width: aNumber color: Color black! ! 26817 26818!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:19'! 26819width: aNumber color: aColor 26820 ^SimpleBorder new color: aColor; width: aNumber; yourself! ! 26821Morph subclass: #BorderedMorph 26822 instanceVariableNames: 'borderWidth borderColor' 26823 classVariableNames: '' 26824 poolDictionaries: '' 26825 category: 'Morphic-Kernel'! 26826!BorderedMorph commentStamp: 'kfr 10/27/2003 11:17' prior: 0! 26827BorderedMorph introduce borders to morph. Borders have the instanceVariables borderWidth and borderColor. 26828 26829BorderedMorph new borderColor: Color red; borderWidth: 10; openInWorld. 26830 26831BorderedMorph also have a varaity of border styles: simple, inset, raised, complexAltFramed, complexAltInset, complexAltRaised, complexFramed, complexInset, complexRaised. 26832These styles are set using the classes BorderStyle, SimpleBorder, RaisedBorder, InsetBorder and ComplexBorder. 26833 26834BorderedMorph new borderStyle: (SimpleBorder width: 1 color: Color white); openInWorld. 26835BorderedMorph new borderStyle: (BorderStyle inset width: 2); openInWorld. 26836 26837 26838! 26839 26840 26841!BorderedMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2006 15:50'! 26842colorForInsets 26843 "Return the color to be used for shading inset borders." 26844 26845 self owner isSystemWindow 26846 ifTrue: [^self owner colorForInsets]. 26847 ^super colorForInsets! ! 26848 26849 26850!BorderedMorph methodsFor: 'accessing' stamp: 'sw 8/6/97 14:34'! 26851borderColor 26852 ^ borderColor! ! 26853 26854!BorderedMorph methodsFor: 'accessing' stamp: 'ar 8/17/2001 16:52'! 26855borderColor: colorOrSymbolOrNil 26856 self doesBevels ifFalse:[ 26857 colorOrSymbolOrNil isColor ifFalse:[^self]]. 26858 borderColor = colorOrSymbolOrNil ifFalse: [ 26859 borderColor := colorOrSymbolOrNil. 26860 self changed]. 26861! ! 26862 26863!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:24'! 26864borderInset 26865 self borderColor: #inset! ! 26866 26867!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:25'! 26868borderRaised 26869 self borderColor: #raised! ! 26870 26871!BorderedMorph methodsFor: 'accessing' stamp: 'aoy 2/17/2003 01:19'! 26872borderStyle 26873 "Work around the borderWidth/borderColor pair" 26874 26875 | style | 26876 borderColor ifNil: [^BorderStyle default]. 26877 borderWidth isZero ifTrue: [^BorderStyle default]. 26878 style := self valueOfProperty: #borderStyle ifAbsent: [BorderStyle default]. 26879 (borderWidth = style width and: 26880 ["Hah!! Try understanding this..." 26881 26882 borderColor == style style or: 26883 ["#raised/#inset etc" 26884 26885 #simple == style style and: [borderColor = style color]]]) 26886 ifFalse: 26887 [style := borderColor isColor 26888 ifTrue: [BorderStyle width: borderWidth color: borderColor] 26889 ifFalse: [(BorderStyle perform: borderColor) width: borderWidth "argh."]. 26890 self setProperty: #borderStyle toValue: style]. 26891 ^style trackColorFrom: self! ! 26892 26893!BorderedMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 22:42'! 26894borderStyle: aBorderStyle 26895 "Work around the borderWidth/borderColor pair" 26896 26897 aBorderStyle = self borderStyle ifTrue: [^self]. 26898 "secure against invalid border styles" 26899 (self canDrawBorder: aBorderStyle) 26900 ifFalse: 26901 ["Replace the suggested border with a simple one" 26902 26903 ^self borderStyle: (BorderStyle width: aBorderStyle width 26904 color: (aBorderStyle trackColorFrom: self) color)]. 26905 aBorderStyle width = self borderStyle width ifFalse: [self changed]. 26906 (aBorderStyle isNil or: [aBorderStyle == BorderStyle default]) 26907 ifTrue: 26908 [self removeProperty: #borderStyle. 26909 borderWidth := 0. 26910 ^self changed]. 26911 self setProperty: #borderStyle toValue: aBorderStyle. 26912 borderWidth := aBorderStyle width. 26913 borderColor := aBorderStyle style == #simple 26914 ifTrue: [aBorderStyle color] 26915 ifFalse: [aBorderStyle style]. 26916 self changed! ! 26917 26918!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:09'! 26919borderWidth 26920 ^ borderWidth! ! 26921 26922!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/4/1999 09:42'! 26923borderWidth: anInteger 26924 borderColor ifNil: [borderColor := Color black]. 26925 borderWidth := anInteger max: 0. 26926 self changed! ! 26927 26928!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:19'! 26929doesBevels 26930 "To return true means that this object can show bevelled borders, and 26931 therefore can accept, eg, #raised or #inset as valid borderColors. 26932 Must be overridden by subclasses that do not support bevelled borders." 26933 26934 ^ true! ! 26935 26936!BorderedMorph methodsFor: 'accessing' stamp: 'di 1/3/1999 12:24'! 26937hasTranslucentColor 26938 "Answer true if this any of this morph is translucent but not transparent." 26939 26940 (color isColor and: [color isTranslucentColor]) ifTrue: [^ true]. 26941 (borderColor isColor and: [borderColor isTranslucentColor]) ifTrue: [^ true]. 26942 ^ false 26943! ! 26944 26945!BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:36'! 26946useRoundedCorners 26947 self cornerStyle: #rounded! ! 26948 26949!BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:37'! 26950useSquareCorners 26951 self cornerStyle: #square! ! 26952 26953 26954!BorderedMorph methodsFor: 'geometry' stamp: 'sw 5/18/2001 22:52'! 26955acquireBorderWidth: aBorderWidth 26956 "Gracefully acquire the new border width, keeping the interior area intact and not seeming to shift" 26957 26958 | delta | 26959 (delta := aBorderWidth- self borderWidth) == 0 ifTrue: [^ self]. 26960 self bounds: ((self bounds origin - (delta @ delta)) corner: (self bounds corner + (delta @ delta))). 26961 self borderWidth: aBorderWidth. 26962 self layoutChanged! ! 26963 26964!BorderedMorph methodsFor: 'geometry' stamp: 'nk 4/5/2001 14:24'! 26965closestPointTo: aPoint 26966 "account for round corners. Still has a couple of glitches at upper left and right corners" 26967 | pt | 26968 pt := self bounds pointNearestTo: aPoint. 26969 self wantsRoundedCorners ifFalse: [ ^pt ]. 26970 self bounds corners with: (self bounds insetBy: 6) corners do: [ :out :in | 26971 (pt - out) abs < (6@6) 26972 ifTrue: [ ^(in + (Point r: 5.0 degrees: (pt - in) degrees)) asIntegerPoint ]. 26973 ]. 26974 ^pt.! ! 26975 26976!BorderedMorph methodsFor: 'geometry' stamp: 'nk 4/5/2001 14:23'! 26977intersectionWithLineSegmentFromCenterTo: aPoint 26978 "account for round corners. Still has a couple of glitches at upper left and right corners" 26979 | pt | 26980 pt := super intersectionWithLineSegmentFromCenterTo: aPoint. 26981 self wantsRoundedCorners ifFalse: [ ^pt ]. 26982 self bounds corners with: (self bounds insetBy: 6) corners do: [ :out :in | 26983 (pt - out) abs < (6@6) 26984 ifTrue: [ ^(in + (Point r: 5.0 degrees: (pt - in) degrees)) asIntegerPoint ]. 26985 ]. 26986 ^pt.! ! 26987 26988 26989!BorderedMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:53'! 26990borderInitialize 26991 "initialize the receiver state related to border" 26992 borderColor:= self defaultBorderColor. 26993 borderWidth := self defaultBorderWidth! ! 26994 26995!BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! 26996defaultBorderColor 26997 "answer the default border color/fill style for the receiver" 26998 ^ Color black! ! 26999 27000!BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! 27001defaultBorderWidth 27002 "answer the default border width for the receiver" 27003 ^ 2! ! 27004 27005!BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:07'! 27006initialize 27007 "initialize the state of the receiver" 27008 super initialize. 27009"" 27010 self borderInitialize! ! 27011 27012 27013!BorderedMorph methodsFor: 'lookenhancements' stamp: 'kfr 11/5/2006 21:36'! 27014addCornerGrips 27015 self 27016 addMorphBack: (TopLeftGripMorph new target: self; position: self position). 27017 self 27018 addMorphBack: (TopRightGripMorph new target: self; position: self position). 27019 self 27020 addMorphBack: (BottomLeftGripMorph new target: self;position: self position). 27021 self 27022 addMorphBack: (BottomRightGripMorph new target: self;position: self position)! ! 27023 27024!BorderedMorph methodsFor: 'lookenhancements' stamp: 'kfr 11/5/2006 21:36'! 27025addPaneHSplitterBetween: topMorph and: bottomMorphs 27026 27027 | targetY minX maxX splitter | 27028 targetY := topMorph layoutFrame bottomFraction. 27029 27030 minX := (bottomMorphs detectMin: [:each | each layoutFrame leftFraction]) layoutFrame leftFraction. 27031 maxX := (bottomMorphs detectMax: [:each | each layoutFrame rightFraction]) layoutFrame rightFraction. 27032 splitter := ProportionalSplitterMorph new beSplitsTopAndBottom; yourself. 27033 splitter layoutFrame: (LayoutFrame 27034 fractions: (minX @ targetY corner: maxX @ targetY) 27035 offsets: (((topMorph layoutFrame leftOffset ifNil: [0]) @ 0 corner: (topMorph layoutFrame rightOffset ifNil: [0]) @ 4) translateBy: 0 @ (topMorph layoutFrame bottomOffset ifNil: [0]))). 27036 27037 self addMorphBack: (splitter position: self position).! ! 27038 27039!BorderedMorph methodsFor: 'lookenhancements' stamp: 'kfr 11/5/2006 21:34'! 27040addPaneSplitters 27041 | splitter remaining target targetX sameX minY maxY targetY sameY minX maxX | 27042 self removePaneSplitters. 27043 self removeCornerGrips. 27044 27045 remaining := submorphs reject: [:each | each layoutFrame rightFraction = 1]. 27046 [remaining notEmpty] whileTrue: 27047 [target := remaining first. 27048 targetX := target layoutFrame rightFraction. 27049 sameX := submorphs select: [:each | each layoutFrame rightFraction = targetX]. 27050 minY := (sameX detectMin: [:each | each layoutFrame topFraction]) layoutFrame topFraction. 27051 maxY := (sameX detectMax: [:each | each layoutFrame bottomFraction]) layoutFrame bottomFraction. 27052 splitter := ProportionalSplitterMorph new. 27053 splitter layoutFrame: (LayoutFrame 27054 fractions: (targetX @ minY corner: targetX @ maxY) 27055 offsets: ((0 @ (target layoutFrame topOffset ifNil: [0]) corner: 4 @ (target layoutFrame bottomOffset ifNil: [0])) translateBy: (target layoutFrame rightOffset ifNil: [0]) @ 0)). 27056 self addMorphBack: (splitter position: self position). 27057 remaining := remaining copyWithoutAll: sameX]. 27058 27059 remaining := submorphs copy reject: [:each | each layoutFrame bottomFraction = 1]. 27060 [remaining notEmpty] 27061 whileTrue: [target := remaining first. 27062 targetY := target layoutFrame bottomFraction. 27063 sameY := submorphs select: [:each | each layoutFrame bottomFraction = targetY]. 27064 minX := (sameY detectMin: [:each | each layoutFrame leftFraction]) layoutFrame leftFraction. 27065 maxX := (sameY detectMax: [:each | each layoutFrame rightFraction]) layoutFrame rightFraction. 27066 splitter := ProportionalSplitterMorph new beSplitsTopAndBottom; yourself. 27067 splitter layoutFrame: (LayoutFrame 27068 fractions: (minX @ targetY corner: maxX @ targetY) 27069 offsets: (((target layoutFrame leftOffset ifNil: [0]) @ 0 corner: (target layoutFrame rightOffset ifNil: [0]) @ 4) translateBy: 0 @ (target layoutFrame bottomOffset ifNil: [0]))). 27070 self addMorphBack: (splitter position: self position). 27071 remaining := remaining copyWithoutAll: sameY]. 27072 27073 self linkSubmorphsToSplitters. 27074 self splitters do: [:each | each comeToFront]. 27075! ! 27076 27077!BorderedMorph methodsFor: 'lookenhancements' stamp: 'kfr 11/5/2006 21:37'! 27078addPaneVSplitterBetween: leftMorph and: rightMorphs 27079 27080 | targetX minY maxY splitter | 27081 targetX := leftMorph layoutFrame rightFraction. 27082 minY := (rightMorphs detectMin: [:each | each layoutFrame topFraction]) layoutFrame topFraction. 27083 maxY := (rightMorphs detectMax: [:each | each layoutFrame bottomFraction]) layoutFrame bottomFraction. 27084 27085 splitter := ProportionalSplitterMorph new. 27086 splitter layoutFrame: (LayoutFrame 27087 fractions: (targetX @ minY corner: targetX @ maxY) 27088 offsets: ((0 @ (leftMorph layoutFrame topOffset ifNil: [0]) corner: (4@ (leftMorph layoutFrame bottomOffset ifNil: [0]))) translateBy: (leftMorph layoutFrame rightOffset ifNil: [0]) @ 0)). 27089 27090 self addMorphBack: (splitter position: self position).! ! 27091 27092!BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:16'! 27093linkSubmorphsToSplitters 27094 27095 self splitters do: 27096 [:each | 27097 each splitsTopAndBottom 27098 ifTrue: 27099 [self submorphsDo: 27100 [:eachMorph | 27101 (eachMorph ~= each and: [eachMorph layoutFrame bottomFraction = each layoutFrame topFraction]) ifTrue: [each addLeftOrTop: eachMorph]. 27102 (eachMorph ~= each and: [eachMorph layoutFrame topFraction = each layoutFrame bottomFraction]) ifTrue: [each addRightOrBottom: eachMorph]]] 27103 ifFalse: 27104 [self submorphsDo: 27105 [:eachMorph | 27106 (eachMorph ~= each and: [eachMorph layoutFrame rightFraction = each layoutFrame leftFraction]) ifTrue: [each addLeftOrTop: eachMorph]. 27107 (eachMorph ~= each and: [eachMorph layoutFrame leftFraction = each layoutFrame rightFraction]) ifTrue: [each addRightOrBottom: eachMorph]]]]! ! 27108 27109!BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 00:03'! 27110removeCornerGrips 27111 27112 | corners | 27113 corners := self submorphsSatisfying: [:each | each isKindOf: CornerGripMorph]. 27114 corners do: [:each | each delete]! ! 27115 27116!BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:28'! 27117removePaneSplitters 27118 27119 self splitters do: [:each | each delete]! ! 27120 27121!BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:16'! 27122splitters 27123 27124 ^ self submorphsSatisfying: [:each | each isKindOf: ProportionalSplitterMorph]! ! 27125 27126 27127!BorderedMorph methodsFor: 'menu' stamp: 'dgd 9/18/2004 19:16'! 27128addBorderStyleMenuItems: aMenu hand: aHandMorph 27129 "Add border-style menu items" 27130 27131 | subMenu | 27132 subMenu := MenuMorph new defaultTarget: self. 27133 "subMenu addTitle: 'border' translated." 27134 subMenu addStayUpItemSpecial. 27135 subMenu addList: 27136 {{'border color...' translated. #changeBorderColor:}. 27137 {'border width...' translated. #changeBorderWidth:}}. 27138 subMenu addLine. 27139 BorderStyle borderStyleChoices do: 27140 [:sym | (self borderStyleForSymbol: sym) 27141 ifNotNil: 27142 [subMenu add: sym translated target: self selector: #setBorderStyle: argument: sym]]. 27143 aMenu add: 'border style' translated subMenu: subMenu 27144! ! 27145 27146!BorderedMorph methodsFor: 'menu' stamp: 'ar 10/5/2000 18:50'! 27147changeBorderColor: evt 27148 | aHand | 27149 aHand := evt ifNotNil: [evt hand] ifNil: [self primaryHand]. 27150 self changeColorTarget: self selector: #borderColor: originalColor: self borderColor hand: aHand! ! 27151 27152!BorderedMorph methodsFor: 'menu' stamp: 'marcus.denker 11/10/2008 10:04'! 27153changeBorderWidth: evt 27154 | handle origin aHand newWidth oldWidth | 27155 aHand := evt ifNil: [self primaryHand] ifNotNil: [evt hand]. 27156 origin := aHand position. 27157 oldWidth := borderWidth. 27158 handle := HandleMorph new 27159 forEachPointDo: 27160 [:newPoint | handle removeAllMorphs. 27161 handle addMorph: 27162 (LineMorph from: origin to: newPoint color: Color black width: 1). 27163 newWidth := (newPoint - origin) r asInteger // 5. 27164 self borderWidth: newWidth] 27165 lastPointDo: 27166 [:newPoint | handle deleteBalloon. 27167 self halo ifNotNil: [:halo | halo addHandles]. 27168 self rememberCommand: 27169 (Command new cmdWording: 'border change' translated; 27170 undoTarget: self selector: #borderWidth: argument: oldWidth; 27171 redoTarget: self selector: #borderWidth: argument: newWidth)]. 27172 aHand attachMorph: handle. 27173 handle setProperty: #helpAtCenter toValue: true. 27174 handle showBalloon: 27175'Move cursor farther from 27176this point to increase border width. 27177Click when done.' translated hand: evt hand. 27178 handle startStepping! ! 27179 27180 27181!BorderedMorph methodsFor: 'private' stamp: 'di 6/20/97 11:21'! 27182setBorderWidth: w borderColor: bc 27183 self borderWidth: w. 27184 self borderColor: bc.! ! 27185 27186!BorderedMorph methodsFor: 'private' stamp: 'di 6/20/97 11:22'! 27187setColor: c borderWidth: w borderColor: bc 27188 self color: c. 27189 self borderWidth: w. 27190 self borderColor: bc.! ! 27191 27192"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 27193 27194BorderedMorph class 27195 instanceVariableNames: ''! 27196 27197!BorderedMorph class methodsFor: 'examples' stamp: 'StephaneDucasse 9/6/2009 15:53'! 27198gradientExample 27199 "self gradientExample" 27200 27201 | morph fs | 27202 morph := BorderedMorph new. 27203 fs := GradientFillStyle ramp: {0.0 -> Color red. 1.0 -> Color green}. 27204 fs origin: morph bounds center. 27205 fs direction: (morph bounds width // 2) @ 0. 27206 fs radial: true. 27207 morph fillStyle: fs. 27208 World primaryHand attachMorph: morph.! ! 27209BorderedMorph subclass: #BorderedSubpaneDividerMorph 27210 instanceVariableNames: 'resizingEdge' 27211 classVariableNames: '' 27212 poolDictionaries: '' 27213 category: 'Morphic-Windows'! 27214 27215!BorderedSubpaneDividerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/2/2007 13:56'! 27216adoptPaneColor: paneColor 27217 "Match the color." 27218 27219 super adoptPaneColor: paneColor. 27220 paneColor ifNil: [^self]. 27221 self color: paneColor! ! 27222 27223 27224!BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! 27225firstEnter: evt 27226 "The first time this divider is activated, find its window and redirect further interaction there." 27227 | window | 27228 27229 window := self firstOwnerSuchThat: [:m | m respondsTo: #secondaryPaneTransition:divider:]. 27230 window ifNil: [ self suspendEventHandler. ^ self ]. "not working out" 27231 window secondaryPaneTransition: evt divider: self. 27232 self on: #mouseEnter send: #secondaryPaneTransition:divider: to: window. 27233! ! 27234 27235!BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! 27236horizontal 27237 27238 self hResizing: #spaceFill.! ! 27239 27240!BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! 27241resizingEdge 27242 27243 ^resizingEdge 27244! ! 27245 27246!BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! 27247resizingEdge: edgeSymbol 27248 27249 (#(top bottom) includes: edgeSymbol) ifFalse: 27250 [ self error: 'resizingEdge must be #top or #bottom' ]. 27251 resizingEdge := edgeSymbol. 27252 self on: #mouseEnter send: #firstEnter: to: self. 27253! ! 27254 27255!BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! 27256vertical 27257 27258 self vResizing: #spaceFill.! ! 27259 27260 27261!BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'! 27262defaultBorderWidth 27263"answer the default border width for the receiver" 27264 ^ 0! ! 27265 27266!BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'! 27267defaultColor 27268"answer the default color/fill style for the receiver" 27269 ^ Color black! ! 27270 27271!BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'! 27272initialize 27273 "initialize the state of the receiver" 27274 super initialize. 27275"" 27276 self extent: 1 @ 1! ! 27277 27278"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 27279 27280BorderedSubpaneDividerMorph class 27281 instanceVariableNames: ''! 27282 27283!BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! 27284forBottomEdge 27285 ^self new horizontal resizingEdge: #bottom! ! 27286 27287!BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'! 27288forTopEdge 27289 ^self new horizontal resizingEdge: #top! ! 27290 27291!BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'! 27292horizontal 27293 ^self new horizontal! ! 27294 27295!BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'! 27296vertical 27297 ^self new vertical! ! 27298CornerGripMorph subclass: #BottomLeftGripMorph 27299 instanceVariableNames: '' 27300 classVariableNames: '' 27301 poolDictionaries: '' 27302 category: 'Morphic-Windows'! 27303!BottomLeftGripMorph commentStamp: 'jmv 1/29/2006 17:17' prior: 0! 27304I am the handle in the left bottom of windows used for resizing them.! 27305 27306 27307!BottomLeftGripMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 13:47'! 27308containsPoint: aPoint 27309 "Answer true only if on edges." 27310 27311 |w| 27312 ^(super containsPoint: aPoint) and: [ 27313 w := SystemWindow borderWidth. 27314 ((self bounds translateBy: w@w negated) 27315 containsPoint: aPoint) not]! ! 27316 27317 27318!BottomLeftGripMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/13/2008 10:21'! 27319drawOn: aCanvas 27320 "Draw the grip on the given canvas." 27321 27322 | dotBounds alphaCanvas windowBorderWidth dotBounds2 | 27323 27324 self shouldDraw ifFalse: [^self]. 27325 27326 windowBorderWidth := SystemWindow borderWidth. 27327 alphaCanvas := aCanvas asAlphaBlendingCanvas: 0.7. 27328 "alphaCanvas 27329 frameRectangle: bounds color: Color blue." 27330 27331 dotBounds := self bounds. 27332 dotBounds2 := dotBounds right: (dotBounds left + windowBorderWidth). 27333 dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth). 27334 alphaCanvas 27335 fillRectangle: dotBounds2 27336 color: self handleColor. 27337 27338 dotBounds2 := dotBounds left: (dotBounds left + windowBorderWidth). 27339 dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth). 27340 alphaCanvas 27341 fillRectangle: dotBounds2 27342 color: self handleColor. 27343 27344 dotBounds2 := dotBounds2 left: (dotBounds2 left + 7). 27345 dotBounds2 := dotBounds2 right: (dotBounds2 right - 7). 27346 alphaCanvas 27347 fillRectangle: dotBounds2 27348 color: self dotColor. 27349 27350 dotBounds2 := dotBounds right: (dotBounds left + windowBorderWidth). 27351 dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - windowBorderWidth). 27352 alphaCanvas 27353 fillRectangle: dotBounds2 27354 color: self handleColor. 27355 27356 dotBounds2 := dotBounds2 top: (dotBounds2 top + 7). 27357 dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - 7). 27358 alphaCanvas 27359 fillRectangle: dotBounds2 27360 color: self dotColor! ! 27361 27362 27363!BottomLeftGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:26'! 27364gripLayoutFrame 27365 ^ LayoutFrame 27366 fractions: (0 @ 1 corner: 0 @ 1) 27367 offsets: (0 @ (0 - self defaultHeight) corner: self defaultWidth @ 0)! ! 27368 27369!BottomLeftGripMorph methodsFor: 'accessing' stamp: 'md 2/24/2006 22:43'! 27370ptName 27371 ^#bottomLeft! ! 27372 27373!BottomLeftGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:52'! 27374resizeCursor 27375 27376 ^ Cursor resizeForEdge: #bottomLeft! ! 27377 27378 27379!BottomLeftGripMorph methodsFor: 'target resize' stamp: 'jmv 1/29/2006 18:06'! 27380apply: delta 27381 | oldBounds | 27382 oldBounds := target bounds. 27383 target 27384 bounds: (oldBounds origin + (delta x @ 0) corner: oldBounds corner + (0 @ delta y))! ! 27385CornerGripMorph subclass: #BottomRightGripMorph 27386 instanceVariableNames: '' 27387 classVariableNames: '' 27388 poolDictionaries: '' 27389 category: 'Morphic-Windows'! 27390!BottomRightGripMorph commentStamp: 'jmv 1/29/2006 17:18' prior: 0! 27391I am the handle in the right bottom of windows used for resizing them.! 27392 27393 27394!BottomRightGripMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/12/2007 10:52'! 27395containsPoint: aPoint 27396 "Answer true only if on edges." 27397 27398 |w| 27399 ^(super containsPoint: aPoint) and: [ 27400 w := SystemWindow borderWidth. 27401 ((self bounds translateBy: (w@w) negated) 27402 containsPoint: aPoint) not]! ! 27403 27404 27405!BottomRightGripMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/13/2008 10:21'! 27406drawOn: aCanvas 27407 "Draw the grip on the given canvas." 27408 27409 | dotBounds alphaCanvas windowBorderWidth dotBounds2 | 27410 27411 self shouldDraw ifFalse: [^self]. 27412 27413 windowBorderWidth := SystemWindow borderWidth. 27414 alphaCanvas := aCanvas asAlphaBlendingCanvas: 0.7. 27415 "alphaCanvas 27416 frameRectangle: bounds color: Color blue." 27417 27418 dotBounds := self bounds. 27419 dotBounds2 := dotBounds left: (dotBounds right - windowBorderWidth). 27420 dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth). 27421 alphaCanvas 27422 fillRectangle: dotBounds2 27423 color: self handleColor. 27424 27425 dotBounds2 := dotBounds right: (dotBounds right - windowBorderWidth). 27426 dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth). 27427 alphaCanvas 27428 fillRectangle: dotBounds2 27429 color: self handleColor. 27430 27431 dotBounds2 := dotBounds2 left: (dotBounds2 left + 7). 27432 dotBounds2 := dotBounds2 right: (dotBounds2 right - 7). 27433 alphaCanvas 27434 fillRectangle: dotBounds2 27435 color: self dotColor. 27436 27437 dotBounds2 := dotBounds left: (dotBounds right - windowBorderWidth). 27438 dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - windowBorderWidth). 27439 alphaCanvas 27440 fillRectangle: dotBounds2 27441 color: self handleColor. 27442 27443 dotBounds2 := dotBounds2 top: (dotBounds2 top + 7). 27444 dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - 7). 27445 alphaCanvas 27446 fillRectangle: dotBounds2 27447 color: self dotColor! ! 27448 27449 27450!BottomRightGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:27'! 27451gripLayoutFrame 27452 ^ LayoutFrame 27453 fractions: (1 @ 1 corner: 1 @ 1) 27454 offsets: (0 - self defaultWidth @ (0 - self defaultHeight) corner: 0 @ 0)! ! 27455 27456!BottomRightGripMorph methodsFor: 'accessing' stamp: 'md 2/24/2006 22:43'! 27457ptName 27458 ^#bottomRight! ! 27459 27460!BottomRightGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:51'! 27461resizeCursor 27462 27463 ^ Cursor resizeForEdge: #bottomRight! ! 27464 27465 27466!BottomRightGripMorph methodsFor: 'target resize' stamp: 'jmv 1/29/2006 17:59'! 27467apply: delta 27468 | oldBounds | 27469 oldBounds := target bounds. 27470 target 27471 bounds: (oldBounds origin corner: oldBounds corner + delta)! ! 27472GradientFillStyle subclass: #BoundedGradientFillStyle 27473 instanceVariableNames: 'extent' 27474 classVariableNames: '' 27475 poolDictionaries: '' 27476 category: 'Polymorph-Widgets-FillStyles'! 27477!BoundedGradientFillStyle commentStamp: 'gvc 3/13/2009 12:19' prior: 0! 27478Gradient fillstyle that draws with optional extent.! 27479 27480 27481!BoundedGradientFillStyle methodsFor: 'accessing' stamp: 'gvc 3/13/2009 12:22'! 27482extent 27483 "Answer the value of extent" 27484 27485 ^ extent! ! 27486 27487!BoundedGradientFillStyle methodsFor: 'accessing' stamp: 'gvc 3/13/2009 12:22'! 27488extent: anObject 27489 "Set the value of extent" 27490 27491 extent := anObject! ! 27492 27493 27494!BoundedGradientFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/13/2009 12:39'! 27495= aGradientFillStyle 27496 "Answer whether equal." 27497 27498 ^super = aGradientFillStyle 27499 and: [self extent = aGradientFillStyle extent]! ! 27500 27501!BoundedGradientFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/13/2009 12:22'! 27502fillRectangle: aRectangle on: aCanvas 27503 "Fill the given rectangle on the given canvas with the receiver." 27504 27505 self extent ifNil: [^super fillRectangle: aRectangle on: aCanvas]. 27506 aCanvas fillRectangle: ((self origin extent: self extent) intersect: aRectangle) basicFillStyle: self! ! 27507 27508!BoundedGradientFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/13/2009 12:39'! 27509hash 27510 "Hash is implemented because #= is implemented." 27511 27512 ^super hash bitXor: self extent hash! ! 27513ParseNode subclass: #BraceNode 27514 instanceVariableNames: 'elements sourceLocations emitNode' 27515 classVariableNames: '' 27516 poolDictionaries: '' 27517 category: 'Compiler-ParseNodes'! 27518!BraceNode commentStamp: '<historical>' prior: 0! 27519Used for compiling and decompiling brace constructs. 27520 27521These now compile into either a fast short form for 4 elements or less: 27522 Array braceWith: a with: b ... 27523or a long form of indefinfite length: 27524 (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray. 27525 27526The erstwhile brace assignment form is no longer supported.! 27527 27528 27529!BraceNode methodsFor: 'code generation' stamp: 'di 11/19/1999 08:58'! 27530emitForValue: stack on: aStream 27531 27532 ^ emitNode emitForValue: stack on: aStream! ! 27533 27534!BraceNode methodsFor: 'code generation' stamp: 'di 1/4/2000 11:24'! 27535selectorForShortForm: nElements 27536 27537 nElements > 4 ifTrue: [^ nil]. 27538 ^ #(braceWithNone braceWith: braceWith:with: 27539 braceWith:with:with: braceWith:with:with:with:) at: nElements + 1! ! 27540 27541!BraceNode methodsFor: 'code generation' stamp: 'di 11/19/1999 11:13'! 27542sizeForValue: encoder 27543 27544 emitNode := elements size <= 4 27545 ifTrue: ["Short form: Array braceWith: a with: b ... " 27546 MessageNode new 27547 receiver: (encoder encodeVariable: #Array) 27548 selector: (self selectorForShortForm: elements size) 27549 arguments: elements precedence: 3 from: encoder] 27550 ifFalse: ["Long form: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray" 27551 CascadeNode new 27552 receiver: (MessageNode new 27553 receiver: (encoder encodeVariable: #Array) 27554 selector: #braceStream: 27555 arguments: (Array with: (encoder encodeLiteral: elements size)) 27556 precedence: 3 from: encoder) 27557 messages: ((elements collect: [:elt | MessageNode new receiver: nil 27558 selector: #nextPut: 27559 arguments: (Array with: elt) 27560 precedence: 3 from: encoder]) 27561 copyWith: (MessageNode new receiver: nil 27562 selector: #braceArray 27563 arguments: (Array new) 27564 precedence: 1 from: encoder))]. 27565 ^ emitNode sizeForValue: encoder! ! 27566 27567 27568!BraceNode methodsFor: 'code generation (closures)' stamp: 'eem 7/20/2009 09:33'! 27569analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>" 27570 elements do: 27571 [:node| 27572 node analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools]! ! 27573 27574!BraceNode methodsFor: 'code generation (closures)' stamp: 'eem 5/21/2008 10:40'! 27575elements 27576 ^elements! ! 27577 27578!BraceNode methodsFor: 'code generation (closures)' stamp: 'eem 5/30/2008 17:22'! 27579maxElementsForConsArray 27580 "Hack; we have no way of knowing how much stack space is available during sizing" 27581 ^8! ! 27582 27583 27584!BraceNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/30/2008 17:40'! 27585emitCodeForValue: stack encoder: encoder 27586 27587 (encoder supportsClosureOpcodes 27588 "Hack; we have no way of knowing how much stack space is available" 27589 and: [elements size <= self maxElementsForConsArray]) ifTrue: 27590 [elements do: [:node| node emitCodeForValue: stack encoder: encoder]. 27591 encoder genPushConsArray: elements size. 27592 stack 27593 pop: elements size; 27594 push: 1. 27595 ^self]. 27596 ^emitNode emitCodeForValue: stack encoder: encoder! ! 27597 27598!BraceNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/30/2008 17:22'! 27599sizeCodeForValue: encoder 27600 27601 (encoder supportsClosureOpcodes 27602 "Hack; we have no way of knowing how much stack space is available" 27603 and: [elements size <= self maxElementsForConsArray]) ifTrue: 27604 [^(elements inject: 0 into: [:sum :node| sum + (node sizeCodeForValue: encoder)]) 27605 + (encoder sizePushConsArray: elements size)]. 27606 emitNode := elements size <= 4 27607 ifTrue: ["Short form: Array braceWith: a with: b ... " 27608 MessageNode new 27609 receiver: (encoder encodeVariable: #Array) 27610 selector: (self selectorForShortForm: elements size) 27611 arguments: elements precedence: 3 from: encoder] 27612 ifFalse: ["Long form: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray" 27613 CascadeNode new 27614 receiver: (MessageNode new 27615 receiver: (encoder encodeVariable: #Array) 27616 selector: #braceStream: 27617 arguments: (Array with: (encoder encodeLiteral: elements size)) 27618 precedence: 3 from: encoder) 27619 messages: ((elements collect: [:elt | MessageNode new receiver: nil 27620 selector: #nextPut: 27621 arguments: (Array with: elt) 27622 precedence: 3 from: encoder]) 27623 copyWith: (MessageNode new receiver: nil 27624 selector: #braceArray 27625 arguments: (Array new) 27626 precedence: 1 from: encoder))]. 27627 ^emitNode sizeCodeForValue: encoder! ! 27628 27629 27630!BraceNode methodsFor: 'enumerating'! 27631casesForwardDo: aBlock 27632 "For each case in forward order, evaluate aBlock with three arguments: 27633 the key block, the value block, and whether it is the last case." 27634 27635 | numCases case | 27636 1 to: (numCases := elements size) do: 27637 [:i | 27638 case := elements at: i. 27639 aBlock value: case receiver value: case arguments first value: i=numCases]! ! 27640 27641!BraceNode methodsFor: 'enumerating'! 27642casesReverseDo: aBlock 27643 "For each case in reverse order, evaluate aBlock with three arguments: 27644 the key block, the value block, and whether it is the last case." 27645 27646 | numCases case | 27647 (numCases := elements size) to: 1 by: -1 do: 27648 [:i | 27649 case := elements at: i. 27650 aBlock value: case receiver value: case arguments first value: i=numCases]! ! 27651 27652 27653!BraceNode methodsFor: 'initialize-release'! 27654elements: collection 27655 "Decompile." 27656 27657 elements := collection! ! 27658 27659!BraceNode methodsFor: 'initialize-release'! 27660elements: collection sourceLocations: locations 27661 "Compile." 27662 27663 elements := collection. 27664 sourceLocations := locations! ! 27665 27666!BraceNode methodsFor: 'initialize-release' stamp: 'di 11/19/1999 11:06'! 27667matchBraceStreamReceiver: receiver messages: messages 27668 27669 ((receiver isMessage: #braceStream: receiver: nil arguments: [:arg | arg isConstantNumber]) 27670 and: [messages last isMessage: #braceArray receiver: nil arguments: nil]) 27671 ifFalse: [^ nil "no match"]. 27672 27673 "Appears to be a long form brace construct" 27674 self elements: (messages allButLast collect: 27675 [:msg | (msg isMessage: #nextPut: receiver: nil arguments: nil) 27676 ifFalse: [^ nil "not a brace element"]. 27677 msg arguments first])! ! 27678 27679!BraceNode methodsFor: 'initialize-release' stamp: 'di 11/19/1999 11:19'! 27680matchBraceWithReceiver: receiver selector: selector arguments: arguments 27681 27682 selector = (self selectorForShortForm: arguments size) 27683 ifFalse: [^ nil "no match"]. 27684 27685 "Appears to be a short form brace construct" 27686 self elements: arguments! ! 27687 27688 27689!BraceNode methodsFor: 'printing' stamp: 'di 11/19/1999 09:17'! 27690printOn: aStream indent: level 27691 27692 aStream nextPut: ${. 27693 1 to: elements size do: 27694 [:i | (elements at: i) printOn: aStream indent: level. 27695 i < elements size ifTrue: [aStream nextPutAll: '. ']]. 27696 aStream nextPut: $}! ! 27697 27698!BraceNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 27699printWithClosureAnalysisOn: aStream indent: level 27700 27701 aStream nextPut: ${. 27702 1 to: elements size do: 27703 [:i | (elements at: i) printWithClosureAnalysisOn: aStream indent: level. 27704 i < elements size ifTrue: [aStream nextPutAll: '. ']]. 27705 aStream nextPut: $}! ! 27706 27707 27708!BraceNode methodsFor: 'testing' stamp: 'eem 9/25/2008 14:48'! 27709blockAssociationCheck: encoder 27710 "If all elements are MessageNodes of the form [block]->[block], and there is at 27711 least one element, answer true. 27712 Otherwise, notify encoder of an error." 27713 27714 elements size = 0 27715 ifTrue: [^encoder notify: 'At least one case required']. 27716 elements with: sourceLocations do: 27717 [:x :loc | 27718 (x isMessage: #-> 27719 receiver: 27720 [:rcvr | 27721 rcvr isBlockNode and: [rcvr numberOfArguments = 0]] 27722 arguments: 27723 [:arg | 27724 arg isBlockNode and: [arg numberOfArguments = 0]]) 27725 ifFalse: 27726 [^encoder notify: 'Association between 0-argument blocks required' at: loc]]. 27727 ^true! ! 27728 27729!BraceNode methodsFor: 'testing'! 27730numElements 27731 27732 ^ elements size! ! 27733 27734 27735!BraceNode methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:14'! 27736accept: aVisitor 27737 aVisitor visitBraceNode: self! ! 27738 27739"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 27740 27741BraceNode class 27742 instanceVariableNames: ''! 27743 27744!BraceNode class methodsFor: 'examples' stamp: 'di 11/19/1999 09:05'! 27745example 27746 "Test the {a. b. c} syntax." 27747 27748 | x | 27749 x := {1. {2. 3}. 4}. 27750 ^ {x first. x second first. x second last. x last. 5} as: Set 27751 27752"BraceNode example Set (0 1 2 3 4 5 )" 27753! ! 27754Morph subclass: #BracketMorph 27755 instanceVariableNames: 'orientation' 27756 classVariableNames: '' 27757 poolDictionaries: '' 27758 category: 'Polymorph-Widgets'! 27759!BracketMorph commentStamp: 'gvc 5/18/2007 13:48' prior: 0! 27760Morph displaying opposing arrows.! 27761 27762 27763!BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/21/2006 15:48'! 27764horizontal 27765 "Answer whether horizontal or vertical." 27766 27767 ^self orientation == #horizontal! ! 27768 27769!BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 15:54'! 27770horizontal: aBoolean 27771 "Set whether horizontal or vertical." 27772 27773 ^self orientation: (aBoolean ifTrue: [#horizontal] ifFalse: [#vertical])! ! 27774 27775!BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 15:51'! 27776orientation 27777 "Answer the value of orientation" 27778 27779 ^ orientation! ! 27780 27781!BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 15:52'! 27782orientation: anObject 27783 "Set the value of orientation" 27784 27785 orientation := anObject. 27786 self changed! ! 27787 27788 27789!BracketMorph methodsFor: 'drawing' stamp: 'gvc 9/21/2006 16:16'! 27790drawOn: aCanvas 27791 "Draw triangles at the edges." 27792 27793 |r| 27794 r := self horizontal 27795 ifTrue: [self bounds insetBy: (2@1 corner: 2@1)] 27796 ifFalse: [self bounds insetBy: (1@2 corner: 1@2)]. 27797 aCanvas 27798 drawPolygon: (self leftOrTopVertices: self bounds) 27799 fillStyle: self borderColor; 27800 drawPolygon: (self leftOrTopVertices: r) 27801 fillStyle: self fillStyle; 27802 drawPolygon: (self rightOrBottomVertices: self bounds) 27803 fillStyle: self borderColor; 27804 drawPolygon: (self rightOrBottomVertices: r) 27805 fillStyle: self fillStyle! ! 27806 27807 27808!BracketMorph methodsFor: 'geometry' stamp: 'gvc 9/21/2006 15:45'! 27809leftOrTopVertices: r 27810 "Answer the vertices for a left or top bracket in the given rectangle." 27811 27812 ^self orientation == #vertical 27813 ifTrue: [{r topLeft - (0@1). r left + (r height // 2 + (r height \\ 2))@(r center y - (r height + 1 \\ 2)). 27814 r left + (r height // 2 + (r height \\ 2))@(r center y). r bottomLeft}] 27815 ifFalse: [{r topLeft. (r center x - (r width + 1 \\ 2))@(r top + (r width // 2 + (r width \\ 2))). 27816 r center x@(r top + (r width // 2 + (r width \\ 2))). r topRight}]! ! 27817 27818!BracketMorph methodsFor: 'geometry' stamp: 'gvc 9/21/2006 16:18'! 27819rightOrBottomVertices: r 27820 "Answer the vertices for a right or bottom bracket in the given rectangle." 27821 27822 ^self orientation == #vertical 27823 ifTrue: [{r topRight - (0@1). r right - (r height // 2 + (r height \\ 2))@(r center y - (r height + 1 \\ 2)). 27824 r right - (r height // 2 + (r height \\ 2))@(r center y). r bottomRight}] 27825 ifFalse: [{(r center x)@(r bottom - 1 - (r width // 2 + (r width \\ 2))). 27826 r center x @(r bottom - 1 - (r width // 2 + (r width \\ 2))). r bottomRight. r bottomLeft - (1@0)}]! ! 27827 27828 27829!BracketMorph methodsFor: 'initialization' stamp: 'gvc 9/19/2006 15:52'! 27830initialize 27831 "Initialize the receiver." 27832 27833 super initialize. 27834 self 27835 orientation: #horizontal! ! 27836PluggableSliderMorph subclass: #BracketSliderMorph 27837 instanceVariableNames: '' 27838 classVariableNames: '' 27839 poolDictionaries: '' 27840 category: 'Polymorph-Widgets'! 27841!BracketSliderMorph commentStamp: 'gvc 5/18/2007 13:39' prior: 0! 27842Abstract superclass for morphs that are used to select a component (R, G, B or A) of a colour.! 27843 27844 27845!BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:40'! 27846defaultFillStyle 27847 "Answer the defauolt fill style." 27848 27849 ^Color gray! ! 27850 27851!BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:40'! 27852extent: aPoint 27853 "Update the gradient directions." 27854 27855 super extent: aPoint. 27856 self updateFillStyle! ! 27857 27858!BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 16:05'! 27859fillStyleToUse 27860 "Answer the fillStyle that should be used for the receiver." 27861 27862 ^self fillStyle! ! 27863 27864!BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 14:06'! 27865gradient 27866 "Answer the gradient." 27867 27868 self subclassResponsibility! ! 27869 27870!BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:39'! 27871initialize 27872 "Initialize the receiver." 27873 27874 super initialize. 27875 self 27876 fillStyle: self defaultFillStyle; 27877 borderStyle: (BorderStyle inset baseColor: self paneColor; width: 1); 27878 sliderColor: Color black; 27879 clipSubmorphs: true! ! 27880 27881!BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 15:53'! 27882initializeSlider 27883 "Make the slider raised." 27884 27885 slider :=( BracketMorph newBounds: self totalSliderArea) 27886 horizontal: self bounds isWide; 27887 color: self thumbColor; 27888 borderStyle: (BorderStyle raised baseColor: Color white; width: 1). 27889 sliderShadow := (BracketMorph newBounds: self totalSliderArea) 27890 horizontal: self bounds isWide; 27891 color: self pagingArea color; 27892 borderStyle: (BorderStyle inset baseColor: (Color white alpha: 0.6); width: 1). 27893 slider on: #mouseMove send: #scrollAbsolute: to: self. 27894 slider on: #mouseDown send: #mouseDownInSlider: to: self. 27895 slider on: #mouseUp send: #mouseUpInSlider: to: self. 27896 "(the shadow must have the pagingArea as its owner to highlight properly)" 27897 self pagingArea addMorph: sliderShadow. 27898 sliderShadow hide. 27899 self addMorph: slider. 27900 self computeSlider. 27901! ! 27902 27903!BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:41'! 27904layoutBounds: aRectangle 27905 "Set the bounds for laying out children of the receiver. 27906 Note: written so that #layoutBounds can be changed without touching this method" 27907 27908 super layoutBounds: aRectangle. 27909 self updateFillStyle. 27910 slider horizontal: self bounds isWide. 27911 sliderShadow horizontal: self bounds isWide! ! 27912 27913!BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 11:34'! 27914roomToMove 27915 "Allow to run off the edges a bit." 27916 27917 ^self bounds isWide 27918 ifTrue: [self totalSliderArea insetBy: ((self sliderThickness // 2@0) negated corner: (self sliderThickness // 2 + 1)@0)] 27919 ifFalse: [self totalSliderArea insetBy: (0@(self sliderThickness // 2) negated corner: 0@(self sliderThickness // 2 - (self sliderThickness \\ 2) + 1))]! ! 27920 27921!BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:29'! 27922sliderColor: newColor 27923 "Set the slider colour." 27924 27925 super sliderColor: (self enabled ifTrue: [Color black] ifFalse: [self sliderShadowColor]). 27926 slider ifNotNil: [slider borderStyle baseColor: Color white]! ! 27927 27928!BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 15:43'! 27929sliderShadowColor 27930 "Answer the color for the slider shadow." 27931 27932 ^Color black alpha: 0.6! ! 27933 27934!BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2006 12:02'! 27935sliderThickness 27936 "Answer the thickness of the slider." 27937 27938 ^((self bounds isWide 27939 ifTrue: [self height] 27940 ifFalse: [self width]) // 2 max: 8) // 2 * 2 + 1! ! 27941 27942!BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:41'! 27943updateFillStyle 27944 "Update the fill style directions." 27945 27946 |b fs| 27947 fs := self fillStyle. 27948 fs isOrientedFill ifTrue: [ 27949 b := self innerBounds. 27950 fs origin: b topLeft. 27951 fs direction: (b isWide 27952 ifTrue: [b width@0] 27953 ifFalse: [0@b height])]! ! 27954Halt subclass: #BreakPoint 27955 instanceVariableNames: '' 27956 classVariableNames: '' 27957 poolDictionaries: '' 27958 category: 'System-Tools'! 27959!BreakPoint commentStamp: 'md 11/18/2003 09:32' prior: 0! 27960This exception is raised on executing a breakpoint. 27961 27962"BreakPoint signal" is called from "Object>>break".! 27963 27964Object subclass: #BreakpointManager 27965 instanceVariableNames: '' 27966 classVariableNames: 'Installed' 27967 poolDictionaries: '' 27968 category: 'System-Tools'! 27969!BreakpointManager commentStamp: 'md 10/9/2008 20:17' prior: 0! 27970This class manages methods that include breakpoints. 27971It has several class methods to install and uninstall breakpoints. 27972 27973Evaluating "BreakpointManager clear" will remove all installed breakpoints in the system. 27974 27975Known issues: 27976- currently, only break-on-entry type of breakpoints are supported 27977- uninstalling the breakpoint doesn't auto-update other browsers 27978- uninstalling a breakpoint while debugging should restart-simulate the current method 27979 27980Ernest Micklei, 2002 27981 27982Send comments to emicklei@philemonworks.com! 27983 27984 27985"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 27986 27987BreakpointManager class 27988 instanceVariableNames: ''! 27989 27990!BreakpointManager class methodsFor: 'examples' stamp: 'emm 5/30/2002 14:12'! 27991testBreakpoint 27992 "In the menu of the methodList, click on -toggle break on entry- 27993 and evaluate the following:" 27994 27995 "BreakpointManager testBreakpoint" 27996 27997 Transcript cr; show: 'Breakpoint test'! ! 27998 27999 28000!BreakpointManager class methodsFor: 'install-uninstall' stamp: 'nice 4/10/2008 22:00'! 28001installInClass: aClass selector: aSymbol 28002 "Install a new method containing a breakpoint. 28003 The receiver will remember this for unstalling it later" 28004 28005 | breakMethod | 28006 breakMethod := self compilePrototype: aSymbol in: aClass. 28007 breakMethod isNil 28008 ifTrue: [^ nil]. 28009 self installed at: breakMethod put: aClass >> aSymbol. "old method" 28010 aClass basicAddSelector: aSymbol withMethod: breakMethod.! ! 28011 28012!BreakpointManager class methodsFor: 'install-uninstall' stamp: 'md 2/15/2006 21:25'! 28013unInstall: breakMethod 28014 28015 | class selector oldMethod | 28016 oldMethod := self installed at: breakMethod ifAbsent:[^self]. 28017 class := breakMethod methodClass. 28018 selector := breakMethod selector. 28019 28020 (class>>selector) == breakMethod ifTrue:[ 28021 class methodDictionary at: selector put: oldMethod]. 28022 self installed removeKey: breakMethod! ! 28023 28024 28025!BreakpointManager class methodsFor: 'intialization-release' stamp: 'marcus.denker 10/9/2008 20:35'! 28026clear 28027 "BreakpointManager clear" 28028 28029 self installed associations do: [:entry | 28030 self unInstall: entry key]. 28031 28032 ! ! 28033 28034 28035!BreakpointManager class methodsFor: 'testing' stamp: 'emm 5/30/2002 09:22'! 28036methodHasBreakpoint: aMethod 28037 ^self installed includesKey: aMethod! ! 28038 28039 28040!BreakpointManager class methodsFor: 'private' stamp: 'emm 5/30/2002 09:36'! 28041breakpointMethodSourceFor: aSymbol in: aClass 28042 "Compose new source containing a break statement (currently it will be the first, 28043 later we want to insert it in any place)" 28044 28045 | oldSource methodNode breakOnlyMethodNode sendBreakMessageNode | 28046 oldSource := aClass sourceCodeAt: aSymbol. 28047 methodNode := aClass compilerClass new 28048 compile: oldSource 28049 in: aClass 28050 notifying: nil 28051 ifFail: [self error: '[breakpoint] unable to install breakpoint']. 28052 breakOnlyMethodNode := aClass compilerClass new 28053 compile: 'temporaryMethodSelectorForBreakpoint 28054self break. 28055^self' 28056 in: aClass 28057 notifying: nil 28058 ifFail: [self error: '[breakpoint] unable to install breakpoint']. 28059 sendBreakMessageNode := breakOnlyMethodNode block statements first. 28060 methodNode block statements addFirst: sendBreakMessageNode. 28061 ^methodNode printString 28062 ! ! 28063 28064!BreakpointManager class methodsFor: 'private' stamp: 'md 10/9/2008 20:14'! 28065compilePrototype: aSymbol in: aClass 28066 "Compile and return a new method containing a break statement" 28067 28068 | source node method | 28069 source := self breakpointMethodSourceFor: aSymbol in: aClass. 28070 node := aClass compilerClass new 28071 compile: source 28072 in: aClass 28073 notifying: nil 28074 ifFail: [self error: '[breakpoint] unable to install breakpoint']. 28075 node isNil ifTrue: [^nil]. 28076 method := node generate: (aClass>>aSymbol) trailer. 28077 ^method! ! 28078 28079!BreakpointManager class methodsFor: 'private' stamp: 'emm 4/24/2002 23:24'! 28080installed 28081 Installed isNil ifTrue:[Installed := IdentityDictionary new]. 28082 ^Installed! ! 28083CodeHolder subclass: #Browser 28084 instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer systemCategoryListIndex classListIndex messageCategoryListIndex messageListIndex editSelection metaClassIndicated' 28085 classVariableNames: 'RecentClasses' 28086 poolDictionaries: '' 28087 category: 'Tools-Browser'! 28088!Browser commentStamp: '<historical>' prior: 0! 28089I represent a query path into the class descriptions, the software of the system.! 28090 28091 28092!Browser methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/1/2008 16:37'! 28093buildMorphicSwitches 28094 28095 | instanceSwitch commentSwitch classSwitch row | 28096 28097 instanceSwitch := PluggableButtonMorph 28098 on: self 28099 getState: #instanceMessagesIndicated 28100 action: #indicateInstanceMessages. 28101 instanceSwitch 28102 label: 'instance'; 28103 askBeforeChanging: true; 28104 borderWidth: 1; 28105 borderColor: Color gray. 28106 commentSwitch := PluggableButtonMorph 28107 on: self 28108 getState: #classCommentIndicated 28109 action: #plusButtonHit. 28110 28111 commentSwitch 28112 label: '?' asText allBold; 28113 askBeforeChanging: true; 28114 setBalloonText: 'class comment'; 28115 borderWidth: 1; 28116 borderColor: Color gray. 28117 classSwitch := PluggableButtonMorph 28118 on: self 28119 getState: #classMessagesIndicated 28120 action: #indicateClassMessages. 28121 classSwitch 28122 label: 'class'; 28123 askBeforeChanging: true; 28124 borderWidth: 1; 28125 borderColor: Color gray. 28126 row := AlignmentMorph newRow 28127 hResizing: #spaceFill; 28128 vResizing: #spaceFill; 28129 cellInset: 0; 28130 borderWidth: 0; 28131 layoutInset: 0; 28132 addMorphBack: instanceSwitch; 28133 addMorphBack: commentSwitch; 28134 addMorphBack: classSwitch. 28135 28136 row color: Color white. 28137 {instanceSwitch. commentSwitch. classSwitch} do: [:m | 28138 m 28139 color: Color transparent; 28140 hResizing: #spaceFill; 28141 vResizing: #spaceFill.]. 28142 ^ row 28143! ! 28144 28145 28146!Browser methodsFor: '*services-base' stamp: 'rr 6/28/2005 15:50'! 28147browseReference: ref 28148 self okToChange ifTrue: [ 28149 self selectCategoryForClass: ref actualClass theNonMetaClass. 28150 self selectClass: ref actualClass theNonMetaClass . 28151 ref actualClass isMeta ifTrue: [self indicateClassMessages]. 28152 self changed: #classSelectionChanged. 28153 self selectMessageCategoryNamed: ref category. 28154 self selectedMessageName: ref methodSymbol. 28155 ]! ! 28156 28157!Browser methodsFor: '*services-base' stamp: 'rr 8/5/2005 10:03'! 28158methodReference 28159 | cls sel | 28160 cls := self selectedClassOrMetaClass. 28161 sel := self selectedMessageName. 28162 cls isNil | sel isNil ifTrue: [^nil]. 28163 ^ MethodReference class: cls selector: sel! ! 28164 28165!Browser methodsFor: '*services-base' stamp: 'rr 3/10/2006 16:01'! 28166optionalButtonRow 28167 ^ServiceGui browserButtonRow: self inlinedIn: super optionalButtonRow! ! 28168 28169!Browser methodsFor: '*services-base' stamp: 'rr 8/3/2005 17:16'! 28170selectReference: ref 28171 self browseReference: ref! ! 28172 28173 28174!Browser methodsFor: 'accessing' stamp: 'al 12/6/2005 22:36'! 28175contents 28176 "Depending on the current selection, different information is retrieved. 28177 Answer a string description of that information. This information is the 28178 method of the currently selected class and message." 28179 28180 | comment theClass latestCompiledMethod | 28181 latestCompiledMethod := currentCompiledMethod. 28182 currentCompiledMethod := nil. 28183 28184 editSelection == #newTrait 28185 ifTrue: [^Trait newTemplateIn: self selectedSystemCategoryName]. 28186 editSelection == #none ifTrue: [^ '']. 28187 editSelection == #editSystemCategories 28188 ifTrue: [^ systemOrganizer printString]. 28189 editSelection == #newClass 28190 ifTrue: [^ (theClass := self selectedClass) 28191 ifNil: 28192 [Class template: self selectedSystemCategoryName] 28193 ifNotNil: 28194 [Class templateForSubclassOf: theClass category: self selectedSystemCategoryName]]. 28195 editSelection == #editClass 28196 ifTrue: [^self classDefinitionText]. 28197 editSelection == #editComment 28198 ifTrue: 28199 [(theClass := self selectedClass) ifNil: [^ '']. 28200 comment := theClass comment. 28201 currentCompiledMethod := theClass organization commentRemoteStr. 28202 ^ comment size = 0 28203 ifTrue: ['This class has not yet been commented.'] 28204 ifFalse: [comment]]. 28205 editSelection == #hierarchy 28206 ifTrue: [ 28207 self selectedClassOrMetaClass isTrait 28208 ifTrue: [^''] 28209 ifFalse: [^self selectedClassOrMetaClass printHierarchy]]. 28210 editSelection == #editMessageCategories 28211 ifTrue: [^ self classOrMetaClassOrganizer printString]. 28212 editSelection == #newMessage 28213 ifTrue: 28214 [^ (theClass := self selectedClassOrMetaClass) 28215 ifNil: [''] 28216 ifNotNil: [theClass sourceCodeTemplate]]. 28217 editSelection == #editMessage 28218 ifTrue: 28219 [self showingByteCodes ifTrue: [^ self selectedBytecodes]. 28220 currentCompiledMethod := latestCompiledMethod. 28221 ^ self selectedMessage]. 28222 28223 self error: 'Browser internal error: unknown edit selection.'! ! 28224 28225!Browser methodsFor: 'accessing' stamp: 'tak 9/25/2008 14:58'! 28226contentsSelection 28227 "Return the interval of text in the code pane to select when I set the pane's contents" 28228 28229 messageCategoryListIndex > 0 & (messageListIndex = 0) 28230 ifTrue: [^ 1 to: 500] "entire empty method template" 28231 ifFalse: [^ 1 to: 0] "null selection"! ! 28232 28233!Browser methodsFor: 'accessing' stamp: 'al 4/24/2004 12:01'! 28234contents: input notifying: aController 28235 "The retrieved information has changed and its source must now be 28236 updated. The information can be a variety of things, depending on 28237 the list selections (such as templates for class or message definition, 28238 methods) or the user menu commands (such as definition, comment, 28239 hierarchy). Answer the result of updating the source." 28240 28241 | aString aText theClass | 28242 self changed: #annotation. 28243 aString := input asString. 28244 aText := input asText. 28245 editSelection == #newTrait ifTrue: [^self defineTrait: input asString notifying: aController]. 28246 editSelection == #editSystemCategories ifTrue: [^ self changeSystemCategories: aString]. 28247 editSelection == #editClass | (editSelection == #newClass) ifTrue: [^ self defineClass: aString notifying: aController]. 28248 editSelection == #editComment 28249 ifTrue: 28250 [theClass := self selectedClass. 28251 theClass 28252 ifNil: 28253 [self inform: 'You must select a class 28254before giving it a comment.'. 28255 ^ false]. 28256 theClass comment: aText stamp: Utilities changeStamp. 28257 self changed: #classCommentText. 28258 ^ true]. 28259 editSelection == #hierarchy ifTrue: [^ true]. 28260 editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. 28261 editSelection == #editMessage | (editSelection == #newMessage) 28262 ifTrue: 28263 [^ self okayToAccept 28264 ifFalse: 28265 [false] 28266 ifTrue: 28267 [self compileMessage: aText notifying: aController]]. 28268 editSelection == #none 28269 ifTrue: 28270 [self inform: 'This text cannot be accepted 28271in this part of the browser.'. 28272 ^ false]. 28273 self error: 'unacceptable accept'! ! 28274 28275!Browser methodsFor: 'accessing' stamp: 'alain.plantec 6/11/2008 13:46'! 28276couldBrowseAnyClass 28277 "Answer whether the receiver is equipped to browse any class. This is in 28278 support of the system-brower feature that allows the browser to be 28279 redirected at the selected class name. This implementation is clearly 28280 ugly, but the feature it enables is handsome enough. 3/1/96 sw" 28281 self dependents 28282 detect: [:d | (d isKindOf: PluggableListMorph) 28283 and: [d getListSelector == #systemCategoryList]] 28284 ifNone: [^ false]. 28285 ^ true! ! 28286 28287!Browser methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:28'! 28288doItReceiver 28289 "This class's classPool has been jimmied to be the classPool of the class 28290 being browsed. A doIt in the code pane will let the user see the value of 28291 the class variables." 28292 28293 ^ self selectedClass ifNil: [FakeClassPool new]! ! 28294 28295!Browser methodsFor: 'accessing'! 28296editSelection 28297 ^editSelection! ! 28298 28299!Browser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'! 28300editSelection: aSelection 28301 "Set the editSelection as requested." 28302 28303 editSelection := aSelection. 28304 self changed: #editSelection.! ! 28305 28306!Browser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'! 28307noteSelectionIndex: anInteger for: aSymbol 28308 aSymbol == #systemCategoryList 28309 ifTrue: 28310 [systemCategoryListIndex := anInteger]. 28311 aSymbol == #classList 28312 ifTrue: 28313 [classListIndex := anInteger]. 28314 aSymbol == #messageCategoryList 28315 ifTrue: 28316 [messageCategoryListIndex := anInteger]. 28317 aSymbol == #messageList 28318 ifTrue: 28319 [messageListIndex := anInteger].! ! 28320 28321!Browser methodsFor: 'accessing' stamp: 'rbb 3/1/2005 10:26'! 28322request: prompt initialAnswer: initialAnswer 28323 28324 ^ UIManager default 28325 request: prompt 28326 initialAnswer: initialAnswer 28327! ! 28328 28329!Browser methodsFor: 'accessing' stamp: 'sw 9/26/2002 17:56'! 28330suggestCategoryToSpawnedBrowser: aBrowser 28331 "aBrowser is a message-category browser being spawned from the receiver. Tell it what it needs to know to get its category info properly set up." 28332 28333 (self isMemberOf: Browser) "yecch, but I didn't invent the browser hierarchy" 28334 ifTrue: 28335 [aBrowser messageCategoryListIndex: (self messageCategoryList indexOf: self categoryOfCurrentMethod ifAbsent: [2])] 28336 ifFalse: 28337 [aBrowser setOriginalCategoryIndexForCurrentMethod]! ! 28338 28339 28340!Browser methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:26'! 28341annotation 28342 "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." 28343 28344 | aSelector aClass | 28345 (aClass := self selectedClassOrMetaClass) == nil ifTrue: [^ '------']. 28346 self editSelection == #editComment ifTrue: 28347 [^ self annotationForSelector: #Comment ofClass: aClass]. 28348 28349 self editSelection == #editClass ifTrue: 28350 [^ self annotationForSelector: #Definition ofClass: aClass]. 28351 (aSelector := self selectedMessageName) ifNil: [^ '------']. 28352 ^ self annotationForSelector: aSelector ofClass: aClass! ! 28353 28354 28355!Browser methodsFor: 'breakpoints' stamp: 'marcus.denker 10/9/2008 20:32'! 28356toggleBreakOnEntry 28357 "Install or uninstall a halt-on-entry breakpoint" 28358 super toggleBreakOnEntry. 28359 self changed: #messageList 28360 ! ! 28361 28362 28363!Browser methodsFor: 'class comment pane' stamp: 'nk 2/15/2004 13:20'! 28364buildMorphicCommentPane 28365 "Construct the pane that shows the class comment. 28366 Respect the Preference for standardCodeFont." 28367 28368 | commentPane | 28369 commentPane := BrowserCommentTextMorph 28370 on: self 28371 text: #classCommentText 28372 accept: #classComment:notifying: 28373 readSelection: nil 28374 menu: #codePaneMenu:shifted:. 28375 commentPane font: Preferences standardCodeFont. 28376 ^ commentPane! ! 28377 28378!Browser methodsFor: 'class comment pane' stamp: 'dew 3/5/2005 23:10'! 28379classComment: aText notifying: aPluggableTextMorph 28380 "The user has just entered aText. 28381 It may be all red (a side-effect of replacing the default comment), so remove the color if it is." 28382 28383 | theClass cleanedText redRange | 28384 theClass := self selectedClassOrMetaClass. 28385 theClass 28386 ifNotNil: [cleanedText := aText asText. 28387 redRange := cleanedText rangeOf: TextColor red startingAt: 1. 28388 redRange size = cleanedText size 28389 ifTrue: [cleanedText 28390 removeAttribute: TextColor red 28391 from: 1 28392 to: redRange last ]. 28393 theClass comment: aText stamp: Utilities changeStamp]. 28394 self changed: #classCommentText. 28395 ^ true! ! 28396 28397!Browser methodsFor: 'class comment pane' stamp: 'md 2/24/2006 15:23'! 28398noCommentNagString 28399 28400 ^ Text string: 'THIS CLASS HAS NO COMMENT!!' translated attribute: TextColor red. 28401 ! ! 28402 28403 28404!Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:26'! 28405addAllMethodsToCurrentChangeSet 28406 "Add all the methods in the selected class or metaclass to the current change set. You ought to know what you're doing before you invoke this!!" 28407 28408 | aClass | 28409 (aClass := self selectedClassOrMetaClass) ifNotNil: 28410 [aClass selectors do: 28411 [:sel | 28412 ChangeSet current adoptSelector: sel forClass: aClass]. 28413 self changed: #annotation] 28414! ! 28415 28416!Browser methodsFor: 'class functions'! 28417buildClassBrowser 28418 "Create and schedule a new class category browser for the current class 28419 selection, if one exists." 28420 28421 self buildClassBrowserEditString: nil! ! 28422 28423!Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:26'! 28424classCommentText 28425 "return the text to display for the comment of the currently selected class" 28426 | theClass | 28427 theClass := self selectedClassOrMetaClass. 28428 theClass ifNil: [ ^'']. 28429 28430 ^ theClass hasComment 28431 ifTrue: [ theClass comment ] 28432 ifFalse: [ self noCommentNagString ]! ! 28433 28434!Browser methodsFor: 'class functions' stamp: 'eem 5/7/2008 12:04'! 28435classDefinitionText 28436 "return the text to display for the definition of the currently selected class" 28437 | theClass | 28438 ^(theClass := self selectedClassOrMetaClass) ifNil: [''] ifNotNil: [theClass definition]! ! 28439 28440!Browser methodsFor: 'class functions' stamp: 'sw 12/6/2000 16:32'! 28441classListMenu: aMenu 28442 "For backward compatibility with old browers stored in image segments" 28443 28444 ^ self classListMenu: aMenu shifted: false! ! 28445 28446!Browser methodsFor: 'class functions' stamp: 'dc 7/18/2008 11:40'! 28447classListMenu: aMenu shifted: shifted 28448 "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" 28449 28450 ServiceGui browser: self classMenu: aMenu. 28451 ServiceGui onlyServices ifTrue: [^aMenu]. 28452 shifted 28453 ifTrue: 28454 [^ self shiftedClassListMenu: aMenu]. 28455 aMenu addList: #( 28456 - 28457 ('browse full (b)' browseMethodFull) 28458 ('browse hierarchy (h)' spawnHierarchy) 28459 ('browse protocol (p)' browseFullProtocol) 28460 - 28461 ('fileOut' fileOutClass) 28462 - 28463 ('show hierarchy' hierarchy) 28464 ('show definition' editClass) 28465 ('show comment' editComment) 28466 - 28467 ('inst var refs...' browseInstVarRefs) 28468 ('inst var defs...' browseInstVarDefs) 28469 - 28470 ('class var refs...' browseClassVarRefs) 28471 ('class vars' browseClassVariables) 28472 ('class refs (N)' browseClassRefs) 28473 - 28474 ('rename class ...' renameClass) 28475 ('copy class' copyClass) 28476 ('remove class (x)' removeClass) 28477 - 28478 ('find method...' findMethod) 28479 ('find method wildcard...' findMethodWithWildcard) 28480 - 28481 ('more...' offerShiftedClassListMenu)). 28482 ^ aMenu 28483! ! 28484 28485!Browser methodsFor: 'class functions' stamp: 'DamienCassou 9/29/2009 09:05'! 28486copyClass 28487 | copysName | 28488 classListIndex = 0 28489 ifTrue: [^ self]. 28490 self okToChange 28491 ifFalse: [^ self]. 28492 copysName := self request: 'Please type new class name' initialAnswer: self selectedClass name. 28493 copysName isEmptyOrNil 28494 ifTrue: [^ self]. 28495 "Cancel returns ''" 28496 self selectedClass duplicateClassWithNewName: copysName. 28497 self classListIndex: 0. 28498 self changed: #classList! ! 28499 28500!Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:30'! 28501createInstVarAccessors 28502 "Create getters and setters for all inst vars defined at the level of the current class selection, except do NOT clobber or override any selectors already understood by the instances of the selected class" 28503 28504 | aClass newMessage setter | 28505 (aClass := self selectedClassOrMetaClass) ifNotNil: 28506 [aClass instVarNames do: 28507 [:aName | 28508 (aClass canUnderstand: aName asSymbol) 28509 ifFalse: 28510 [newMessage := aName, ' 28511 "Answer the value of ', aName, '" 28512 28513 ^ ', aName. 28514 aClass compile: newMessage classified: 'accessing' notifying: nil]. 28515 (aClass canUnderstand: (setter := aName, ':') asSymbol) 28516 ifFalse: 28517 [newMessage := setter, ' anObject 28518 "Set the value of ', aName, '" 28519 28520 ', aName, ' := anObject'. 28521 aClass compile: newMessage classified: 'accessing' notifying: nil]]]! ! 28522 28523!Browser methodsFor: 'class functions' stamp: 'md 3/3/2006 11:02'! 28524defineClass: defString notifying: aController 28525 "The receiver's textual content is a request to define a new class. The 28526 source code is defString. If any errors occur in compilation, notify 28527 aController." 28528 | oldClass class newClassName defTokens keywdIx envt | 28529 oldClass := self selectedClassOrMetaClass. 28530 defTokens := defString findTokens: Character separators. 28531 28532 ((defTokens first = 'Trait' and: [defTokens second = 'named:']) 28533 or: [defTokens second = 'classTrait']) 28534 ifTrue: [^self defineTrait: defString notifying: aController]. 28535 28536 keywdIx := defTokens findFirst: [:x | x beginsWith: 'category']. 28537 envt := Smalltalk. 28538 keywdIx := defTokens findFirst: [:x | '*subclass*' match: x]. 28539 newClassName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'. 28540 ((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName]) 28541 and: [envt includesKey: newClassName asSymbol]) ifTrue: 28542 ["Attempting to define new class over existing one when 28543 not looking at the original one in this browser..." 28544 (self confirm: ((newClassName , ' is an existing class in this system. 28545Redefining it might cause serious problems. 28546Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size)) 28547 ifFalse: [^ false]]. 28548 "ar 8/29/1999: Use oldClass superclass for defining oldClass 28549 since oldClass superclass knows the definerClass of oldClass." 28550 oldClass ifNotNil:[oldClass := oldClass superclass]. 28551 class := oldClass subclassDefinerClass 28552 evaluate: defString 28553 notifying: aController 28554 logged: true. 28555 (class isKindOf: Behavior) 28556 ifTrue: [self changed: #systemCategoryList. 28557 self changed: #classList. 28558 self clearUserEditFlag. 28559 self setClass: class selector: nil. 28560 "self clearUserEditFlag; editClass." 28561 ^ true] 28562 ifFalse: [^ false]! ! 28563 28564!Browser methodsFor: 'class functions' stamp: 'nk 2/15/2004 13:23'! 28565editClass 28566 "Retrieve the description of the class definition." 28567 28568 classListIndex = 0 ifTrue: [^ self]. 28569 self okToChange ifFalse: [^ self]. 28570 self messageCategoryListIndex: 0. 28571 self editSelection: #editClass. 28572 self changed: #contents. 28573 self changed: #classCommentText. 28574! ! 28575 28576!Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:26'! 28577editComment 28578 "Retrieve the description of the class comment." 28579 28580 classListIndex = 0 ifTrue: [^ self]. 28581 self okToChange ifFalse: [^ self]. 28582 self messageCategoryListIndex: 0. 28583 metaClassIndicated := false. 28584 self editSelection: #editComment. 28585 self changed: #classSelectionChanged. 28586 self changed: #messageCategoryList. 28587 self changed: #messageList. 28588 self decorateButtons. 28589 self contentsChanged 28590! ! 28591 28592!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'! 28593fileOutClass 28594 "Print a description of the selected class onto a file whose name is the 28595 category name followed by .st." 28596 28597Cursor write showWhile: 28598 [classListIndex ~= 0 ifTrue: [self selectedClass fileOut]]! ! 28599 28600!Browser methodsFor: 'class functions' stamp: 'alain.plantec 2/6/2009 16:29'! 28601findMethod 28602 "Pop up a list of the current class's methods, and select the one chosen by the user" 28603 28604 | aClass selectors reply cat messageCatIndex messageIndex choices | 28605 self classListIndex = 0 ifTrue: [^ self]. 28606 self okToChange ifFalse: [^ self]. 28607 aClass := self selectedClassOrMetaClass. 28608 selectors := aClass selectors asSortedArray. 28609 selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.' translated. ^ self]. 28610 choices := (Array with: 'Enter Wildcard' translated), selectors. 28611 reply := UIManager default chooseFrom: choices lines: #(1). 28612 reply = 0 ifTrue: [^self]. 28613 reply = 1 28614 ifTrue: [ 28615 reply := UIManager default request: 'Enter partial method name:' translated. 28616 (reply isNil or: [reply isEmpty]) 28617 ifTrue: [^self]. 28618 (reply includes: $*) 28619 ifFalse: [reply := '*', reply, '*']. 28620 selectors := selectors select: [:each | reply match: each]. 28621 selectors isEmpty ifTrue: [self inform: aClass name, ' has no matching methods.' translated. ^ self]. 28622 reply := selectors size = 1 28623 ifTrue: [selectors first] 28624 ifFalse: [ UIManager default chooseFrom: selectors values: selectors]. 28625 reply isNil ifTrue: [^self]] 28626 ifFalse: [reply := choices at: reply]. 28627 28628 cat := aClass whichCategoryIncludesSelector: reply. 28629 messageCatIndex := self messageCategoryList indexOf: cat. 28630 self messageCategoryListIndex: messageCatIndex. 28631 messageIndex := (self messageList indexOf: reply). 28632 self messageListIndex: messageIndex! ! 28633 28634!Browser methodsFor: 'class functions' stamp: 'alain.plantec 2/6/2009 16:30'! 28635findMethodWithWildcard 28636 "Pop up a list of the current class's methods, and select the one chosen by the user" 28637 28638 | aClass selectors reply cat messageCatIndex messageIndex | 28639 self classListIndex = 0 ifTrue: [^ self]. 28640 self okToChange ifFalse: [^ self]. 28641 aClass := self selectedClassOrMetaClass. 28642 selectors := aClass selectors asSortedArray. 28643 selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.' translated. ^ self]. 28644 28645 reply := UIManager default request: 'Enter partial method name:' translated. 28646 (reply isNil or: [reply isEmpty]) 28647 ifTrue: [^self]. 28648 (reply includes: $*) 28649 ifFalse: [reply := '*', reply, '*']. 28650 selectors := selectors select: [:each | reply match: each]. 28651 selectors isEmpty ifTrue: [self inform: aClass name, ' has no matching methods.'. ^ self]. 28652 reply := selectors size = 1 28653 ifTrue: [selectors first] 28654 ifFalse: [UIManager default chooseFrom: selectors values: selectors]. 28655 reply == nil ifTrue: [^ self]. 28656 28657 cat := aClass whichCategoryIncludesSelector: reply. 28658 messageCatIndex := self messageCategoryList indexOf: cat. 28659 self messageCategoryListIndex: messageCatIndex. 28660 messageIndex := (self messageList indexOf: reply). 28661 self messageListIndex: messageIndex! ! 28662 28663!Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:09'! 28664hierarchy 28665 "Display the inheritance hierarchy of the receiver's selected class." 28666 28667 classListIndex = 0 ifTrue: [^ self]. 28668 self okToChange ifFalse: [^ self]. 28669 self messageCategoryListIndex: 0. 28670 self editSelection: #hierarchy. 28671 self changed: #editComment. 28672 self contentsChanged. 28673 ^ self! ! 28674 28675!Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:07'! 28676makeNewSubclass 28677 28678 self selectedClassOrMetaClass ifNil: [^ self]. 28679 self okToChange ifFalse: [^ self]. 28680 self editSelection: #newClass. 28681 self contentsChanged! ! 28682 28683!Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:09'! 28684plusButtonHit 28685 "Cycle among definition, comment, and hierachy" 28686 28687 editSelection == #editComment 28688 ifTrue: [self hierarchy. ^ self]. 28689 editSelection == #hierarchy 28690 ifTrue: [self editSelection: #editClass. 28691 classListIndex = 0 ifTrue: [^ self]. 28692 self okToChange ifFalse: [^ self]. 28693 self changed: #editComment. 28694 self contentsChanged. 28695 ^ self]. 28696 self editComment! ! 28697 28698!Browser methodsFor: 'class functions' stamp: 'sw 3/5/2001 18:04'! 28699removeClass 28700 "If the user confirms the wish to delete the class, do so" 28701 28702 super removeClass ifTrue: 28703 [self classListIndex: 0]! ! 28704 28705!Browser methodsFor: 'class functions' stamp: 'DamienCassou 9/29/2009 09:05'! 28706renameClass 28707 | oldName newName obs | 28708 classListIndex = 0 28709 ifTrue: [^ self]. 28710 self okToChange 28711 ifFalse: [^ self]. 28712 oldName := self selectedClass name. 28713 newName := self request: 'Please type new class name' initialAnswer: oldName. 28714 newName isEmptyOrNil 28715 ifTrue: [^ self]. 28716 "Cancel returns ''" 28717 newName := newName asSymbol. 28718 newName = oldName 28719 ifTrue: [^ self]. 28720 (Smalltalk includesKey: newName) 28721 ifTrue: [^ self error: newName , ' already exists']. 28722 self selectedClass rename: newName. 28723 self changed: #classList. 28724 self 28725 classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) 28726 indexOf: newName). 28727 obs := self systemNavigation 28728 allCallsOn: (Smalltalk associationAt: newName). 28729 obs isEmpty 28730 ifFalse: [self systemNavigation 28731 browseMessageList: obs 28732 name: 'Obsolete References to ' , oldName 28733 autoSelect: oldName]! ! 28734 28735!Browser methodsFor: 'class functions' stamp: 'md 7/29/2005 15:59'! 28736shiftedClassListMenu: aMenu 28737 "Set up the menu to apply to the receiver's class list when the shift key is down" 28738 28739 ^ aMenu addList: #( 28740 - 28741 ('unsent methods' browseUnusedMethods 'browse all methods defined by this class that have no senders') 28742 ('unreferenced inst vars' showUnreferencedInstVars 'show a list of all instance variables that are not referenced in methods') 28743 ('unreferenced class vars' showUnreferencedClassVars 'show a list of all class variables that are not referenced in methods') 28744 ('subclass template' makeNewSubclass 'put a template into the code pane for defining of a subclass of this class') 28745 - 28746 ('sample instance' makeSampleInstance 'give me a sample instance of this class, if possible') 28747 ('inspect instances' inspectInstances 'open an inspector on all the extant instances of this class') 28748 ('inspect subinstances' inspectSubInstances 'open an inspector on all the extant instances of this class and of all of its subclasses') 28749 - 28750 ('add all meths to current chgs' addAllMethodsToCurrentChangeSet 28751 'place all the methods defined by this class into the current change set') 28752 ('create inst var accessors' createInstVarAccessors 'compile instance-variable access methods for any instance variables that do not yet have them') 28753 - 28754 ('more...' offerUnshiftedClassListMenu 'return to the standard class-list menu'))! ! 28755 28756 28757!Browser methodsFor: 'class list'! 28758classList 28759 "Answer an array of the class names of the selected category. Answer an 28760 empty array if no selection exists." 28761 28762 systemCategoryListIndex = 0 28763 ifTrue: [^Array new] 28764 ifFalse: [^systemOrganizer listAtCategoryNumber: systemCategoryListIndex]! ! 28765 28766!Browser methodsFor: 'class list'! 28767classListIndex 28768 "Answer the index of the current class selection." 28769 28770 ^classListIndex! ! 28771 28772!Browser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! 28773classListIndex: anInteger 28774 "Set anInteger to be the index of the current class selection." 28775 28776 | className | 28777 28778 classListIndex := anInteger. 28779 self setClassOrganizer. 28780 messageCategoryListIndex := 0. 28781 messageListIndex := 0. 28782 self classCommentIndicated 28783 ifTrue: [] 28784 ifFalse: [self editSelection: (anInteger = 0 28785 ifTrue: [metaClassIndicated | (systemCategoryListIndex == 0) 28786 ifTrue: [#none] 28787 ifFalse: [#newClass]] 28788 ifFalse: [#editClass])]. 28789 contents := nil. 28790 self selectedClass isNil 28791 ifFalse: [className := self selectedClass name. 28792 (RecentClasses includes: className) 28793 ifTrue: [RecentClasses remove: className]. 28794 RecentClasses addFirst: className. 28795 RecentClasses size > 16 28796 ifTrue: [RecentClasses removeLast]]. 28797 self changed: #classSelectionChanged. 28798 self changed: #classCommentText. 28799 self changed: #classListIndex. "update my selection" 28800 self changed: #messageCategoryList. 28801 self changed: #messageList. 28802 self changed: #relabel. 28803 self contentsChanged! ! 28804 28805!Browser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! 28806classListSingleton 28807 28808 | name | 28809 name := self selectedClassName. 28810 ^ name ifNil: [Array new] 28811 ifNotNil: [Array with: name]! ! 28812 28813!Browser methodsFor: 'class list' stamp: 'alain.plantec 2/6/2009 16:34'! 28814recent 28815 "Let the user select from a list of recently visited classes. 11/96 stp. 28816 12/96 di: use class name, not classes themselves. 28817 : dont fall into debugger in empty case" 28818 28819 | className class recentList | 28820 recentList := RecentClasses select: [:n | Smalltalk includesKey: n]. 28821 recentList size == 0 ifTrue: [^ Beeper beep]. 28822 className := UIManager default chooseFrom: recentList values: recentList. 28823 className isNil ifTrue: [^ self]. 28824 class := Smalltalk at: className. 28825 self selectCategoryForClass: class. 28826 self classListIndex: (self classList indexOf: class name)! ! 28827 28828!Browser methodsFor: 'class list' stamp: 'sr 10/29/1999 20:28'! 28829selectClass: classNotMeta 28830 self classListIndex: (self classList indexOf: classNotMeta name)! ! 28831 28832!Browser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! 28833selectedClass 28834 "Answer the class that is currently selected. Answer nil if no selection 28835 exists." 28836 28837 | name envt | 28838 (name := self selectedClassName) ifNil: [^ nil]. 28839 (envt := self selectedEnvironment) ifNil: [^ nil]. 28840 ^ envt at: name! ! 28841 28842!Browser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! 28843selectedClassName 28844 | aClassList | 28845 "Answer the name of the current class. Answer nil if no selection exists." 28846 28847 (classListIndex = 0 or: [classListIndex > (aClassList := self classList) size]) ifTrue: [^ nil]. 28848 ^ aClassList at: classListIndex! ! 28849 28850!Browser methodsFor: 'class list'! 28851toggleClassListIndex: anInteger 28852 "If anInteger is the current class index, deselect it. Else make it the 28853 current class selection." 28854 28855 self classListIndex: 28856 (classListIndex = anInteger 28857 ifTrue: [0] 28858 ifFalse: [anInteger])! ! 28859 28860 28861!Browser methodsFor: 'code pane' stamp: 'rr 7/10/2006 11:48'! 28862codePaneMenu: aMenu shifted: shifted 28863 ServiceGui browser: self codePaneMenu: aMenu. 28864 ServiceGui onlyServices ifTrue: [^ aMenu]. 28865 super codePaneMenu: aMenu shifted: shifted. 28866 ^ aMenu! ! 28867 28868!Browser methodsFor: 'code pane' stamp: 'sd 11/20/2005 21:26'! 28869compileMessage: aText notifying: aController 28870 "Compile the code that was accepted by the user, placing the compiled method into an appropriate message category. Return true if the compilation succeeded, else false." 28871 28872 | fallBackCategoryIndex fallBackMethodIndex originalSelectorName result | 28873 28874 self selectedMessageCategoryName ifNil: 28875 [ self selectOriginalCategoryForCurrentMethod 28876 ifFalse:["Select the '--all--' category" 28877 self messageCategoryListIndex: 1]]. 28878 28879 28880 self selectedMessageCategoryName asSymbol = ClassOrganizer allCategory 28881 ifTrue: 28882 [ "User tried to save a method while the ALL category was selected" 28883 fallBackCategoryIndex := messageCategoryListIndex. 28884 fallBackMethodIndex := messageListIndex. 28885 editSelection == #newMessage 28886 ifTrue: 28887 [ "Select the 'as yet unclassified' category" 28888 messageCategoryListIndex := 0. 28889 (result := self defineMessageFrom: aText notifying: aController) 28890 ifNil: 28891 ["Compilation failure: reselect the original category & method" 28892 messageCategoryListIndex := fallBackCategoryIndex. 28893 messageListIndex := fallBackMethodIndex] 28894 ifNotNil: 28895 [self setSelector: result]] 28896 ifFalse: 28897 [originalSelectorName := self selectedMessageName. 28898 self setOriginalCategoryIndexForCurrentMethod. 28899 messageListIndex := fallBackMethodIndex := self messageList indexOf: originalSelectorName. 28900 (result := self defineMessageFrom: aText notifying: aController) 28901 ifNotNil: 28902 [self setSelector: result] 28903 ifNil: 28904 [ "Compilation failure: reselect the original category & method" 28905 messageCategoryListIndex := fallBackCategoryIndex. 28906 messageListIndex := fallBackMethodIndex. 28907 ^ result notNil]]. 28908 self changed: #messageCategoryList. 28909 ^ result notNil] 28910 ifFalse: 28911 [ "User tried to save a method while the ALL category was NOT selected" 28912 ^ (self defineMessageFrom: aText notifying: aController) notNil]! ! 28913 28914!Browser methodsFor: 'code pane' stamp: 'sw 5/18/2001 20:55'! 28915showBytecodes 28916 "Show or hide the bytecodes of the selected method -- an older protocol now mostly not relevant." 28917 28918 self toggleShowingByteCodes! ! 28919 28920 28921!Browser methodsFor: 'construction' stamp: 'sd 11/20/2005 21:26'! 28922addLowerPanesTo: window at: nominalFractions with: editString 28923 | commentPane | 28924 super addLowerPanesTo: window at: nominalFractions with: editString. 28925 commentPane := self buildMorphicCommentPane. 28926 window addMorph: commentPane fullFrame: (LayoutFrame fractions: (0@0.75 corner: 1@1)). 28927 self changed: #editSelection.! ! 28928 28929 28930!Browser methodsFor: 'copying' stamp: 'sd 11/20/2005 21:26'! 28931veryDeepInner: deepCopier 28932 "Copy all of my instance variables. Some need to be not copied at all, but shared. See DeepCopier class comment." 28933 28934super veryDeepInner: deepCopier. 28935"systemOrganizer := systemOrganizer. clone has the old value. we share it" 28936"classOrganizer := classOrganizer clone has the old value. we share it" 28937"metaClassOrganizer := metaClassOrganizer clone has the old value. we share it" 28938systemCategoryListIndex := systemCategoryListIndex veryDeepCopyWith: deepCopier. 28939classListIndex := classListIndex veryDeepCopyWith: deepCopier. 28940messageCategoryListIndex := messageCategoryListIndex veryDeepCopyWith: deepCopier. 28941messageListIndex := messageListIndex veryDeepCopyWith: deepCopier. 28942editSelection := editSelection veryDeepCopyWith: deepCopier. 28943metaClassIndicated := metaClassIndicated veryDeepCopyWith: deepCopier. 28944! ! 28945 28946 28947!Browser methodsFor: 'drag and drop' stamp: 'nk 6/12/2004 17:43'! 28948acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph 28949 "Here we are fetching informations from the dropped transferMorph 28950 and 28951 performing the correct action for this drop." 28952 | srcType success srcBrowser | 28953 success := false. 28954 srcType := transferMorph dragTransferType. 28955 srcBrowser := transferMorph source model. 28956 srcType == #messageList 28957 ifTrue: [ | srcClass srcSelector srcCategory | 28958 srcClass := transferMorph passenger key. 28959 srcSelector := transferMorph passenger value. 28960 srcCategory := srcBrowser selectedMessageCategoryName. 28961 srcCategory 28962 ifNil: [srcCategory := srcClass organization categoryOfElement: srcSelector]. 28963 success := self 28964 acceptMethod: srcSelector 28965 messageCategory: srcCategory 28966 class: srcClass 28967 atListMorph: dstListMorph 28968 internal: self == srcBrowser 28969 copy: transferMorph shouldCopy]. 28970 srcType == #classList 28971 ifTrue: [success := self 28972 changeCategoryForClass: transferMorph passenger 28973 srcSystemCategory: srcBrowser selectedSystemCategoryName 28974 atListMorph: dstListMorph 28975 internal: self == srcBrowser 28976 copy: transferMorph shouldCopy]. 28977 ^ success! ! 28978 28979!Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! 28980acceptMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel dstClass: dstClass dstClassOrMeta: dstClassOrMeta srcClassOrMeta: srcClassOrMeta internal: internal copySemantic: copyFlag 28981 | success hierarchyChange higher checkForOverwrite | 28982 (success := dstClassOrMeta ~~ nil) ifFalse: [^false]. 28983 checkForOverwrite := dstClassOrMeta selectors includes: methodSel. 28984 hierarchyChange := (higher := srcClassOrMeta inheritsFrom: dstClassOrMeta) | (dstClassOrMeta inheritsFrom: srcClassOrMeta). 28985 success := (checkForOverwrite not 28986 or: [self 28987 overwriteDialogHierarchyChange: hierarchyChange 28988 higher: higher 28989 sourceClassName: srcClassOrMeta name 28990 destinationClassName: dstClassOrMeta name 28991 methodSelector: methodSel]) 28992 and: [self 28993 message: methodSel 28994 compileInClass: dstClassOrMeta 28995 fromClass: srcClassOrMeta 28996 dstMessageCategory: dstMessageCategorySel 28997 srcMessageCategory: srcMessageCategorySel 28998 internal: internal 28999 copySemantic: copyFlag]. 29000 ^ success! ! 29001 29002!Browser methodsFor: 'drag and drop' stamp: 'al 4/24/2004 11:50'! 29003acceptMethod: methodSel messageCategory: srcMessageCategorySel class: srcClassOrMeta atListMorph: dstListMorph internal: internal copy: copyFlag 29004 | success dstClassOrMeta dstClass dstMessageCategorySel | 29005 dstClass := self dstClassDstListMorph: dstListMorph. 29006 dstClassOrMeta := dstClass 29007 ifNotNil: [self metaClassIndicated 29008 ifTrue: [dstClass classSide] 29009 ifFalse: [dstClass]]. 29010 dstMessageCategorySel := self dstMessageCategoryDstListMorph: dstListMorph. 29011 success := (dstClassOrMeta notNil 29012 and: [dstClassOrMeta == srcClassOrMeta]) 29013 ifTrue: ["one class" 29014 self 29015 changeMessageCategoryForMethod: methodSel 29016 dstMessageCategory: dstMessageCategorySel 29017 srcMessageCategory: srcMessageCategorySel 29018 insideClassOrMeta: dstClassOrMeta 29019 internal: internal 29020 copySemantic: copyFlag] 29021 ifFalse: ["different classes" 29022 self 29023 acceptMethod: methodSel 29024 dstMessageCategory: dstMessageCategorySel 29025 srcMessageCategory: srcMessageCategorySel 29026 dstClass: dstClass 29027 dstClassOrMeta: dstClassOrMeta 29028 srcClassOrMeta: srcClassOrMeta 29029 internal: internal 29030 copySemantic: copyFlag]. 29031 ^ success! ! 29032 29033!Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! 29034changeCategoryForClass: class srcSystemCategory: srcSystemCategorySel atListMorph: dstListMorph internal: internal copy: copyFlag 29035 "only move semantic" 29036 | newClassCategory success | 29037 self flag: #stringSymbolProblem. 29038 success := copyFlag not ifFalse: [^ false]. 29039 newClassCategory := self dstCategoryDstListMorph: dstListMorph. 29040 (success := newClassCategory notNil & (newClassCategory ~= class category)) 29041 ifTrue: 29042 [class category: newClassCategory. 29043 self changed: #classList. 29044 internal ifFalse: [self selectClass: class]]. 29045 ^ success! ! 29046 29047!Browser methodsFor: 'drag and drop' stamp: 'nk 4/22/2004 18:00'! 29048changeMessageCategoryForMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel insideClassOrMeta: classOrMeta internal: internal copySemantic: copyFlag 29049 "Recategorize the method named by methodSel. 29050 If the dstMessageCategorySel is the allCategory, then recategorize 29051 it from its parents." 29052 | success messageCategorySel | 29053 copyFlag 29054 ifTrue: [^ false]. 29055 "only move semantic" 29056 messageCategorySel := dstMessageCategorySel 29057 ifNil: [srcMessageCategorySel]. 29058 (success := messageCategorySel notNil 29059 and: [messageCategorySel ~= srcMessageCategorySel]) 29060 ifTrue: [success := messageCategorySel == ClassOrganizer allCategory 29061 ifTrue: [self recategorizeMethodSelector: methodSel] 29062 ifFalse: [(classOrMeta organization categories includes: messageCategorySel) 29063 and: [classOrMeta organization 29064 classify: methodSel 29065 under: messageCategorySel 29066 suppressIfDefault: false. 29067 true]]]. 29068 success 29069 ifTrue: [self changed: #messageList. 29070 internal 29071 ifFalse: [self setSelector: methodSel]]. 29072 ^ success! ! 29073 29074!Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! 29075dragPassengerFor: item inMorph: dragSource 29076 | transferType smn | 29077 (dragSource isKindOf: PluggableListMorph) 29078 ifFalse: [^nil]. 29079 transferType := self dragTransferTypeForMorph: dragSource. 29080 transferType == #classList 29081 ifTrue: [^self selectedClass]. 29082 transferType == #messageList 29083 ifFalse: [ ^nil ]. 29084 smn := self selectedMessageName ifNil: [ ^nil ]. 29085 (MessageSet isPseudoSelector: smn) ifTrue: [ ^nil ]. 29086 29087 ^ self selectedClassOrMetaClass -> smn. 29088! ! 29089 29090!Browser methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:18'! 29091dragTransferTypeForMorph: dragSource 29092 ^(dragSource isKindOf: PluggableListMorph) 29093 ifTrue: [dragSource getListSelector]! ! 29094 29095!Browser methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 23:21'! 29096dstCategoryDstListMorph: dstListMorph 29097 ^(dstListMorph getListSelector == #systemCategoryList) 29098 ifTrue: [dstListMorph potentialDropItem ] 29099 ifFalse: [self selectedSystemCategoryName]! ! 29100 29101!Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! 29102dstClassDstListMorph: dstListMorph 29103 | dropItem | 29104 ^(dstListMorph getListSelector == #classList) 29105 ifTrue: [(dropItem := dstListMorph potentialDropItem) ifNotNil: [Smalltalk at: dropItem withBlanksCondensed asSymbol]] 29106 ifFalse: [dstListMorph model selectedClass]! ! 29107 29108!Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! 29109dstMessageCategoryDstListMorph: dstListMorph 29110 | dropItem | 29111 ^dstListMorph getListSelector == #messageCategoryList 29112 ifTrue: 29113 [dropItem := dstListMorph potentialDropItem. 29114 dropItem ifNotNil: [dropItem asSymbol]] 29115 ifFalse: [self selectedMessageCategoryName ifNil: [ Categorizer default ]]! ! 29116 29117!Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! 29118message: messageSel compileInClass: dstClassOrMeta fromClass: srcClassOrMeta dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel internal: internal copySemantic: copyFlag 29119 | source messageCategorySel tm success oldOrNoMethod newMethod | 29120 source := srcClassOrMeta sourceCodeAt: messageSel. 29121 messageCategorySel := dstMessageCategorySel ifNil: [srcMessageCategorySel]. 29122 self selectClass: dstClassOrMeta theNonMetaClass. 29123 (self messageCategoryList includes: messageCategorySel) 29124 ifFalse: ["create message category" 29125 self classOrMetaClassOrganizer addCategory: messageCategorySel]. 29126 self selectMessageCategoryNamed: messageCategorySel. 29127 tm := self codeTextMorph. 29128 tm setText: source. 29129 tm setSelection: (0 to: 0). 29130 tm hasUnacceptedEdits: true. 29131 oldOrNoMethod := srcClassOrMeta compiledMethodAt: messageSel ifAbsent: []. 29132 tm accept. 29133 "compilation successful?" 29134 newMethod := dstClassOrMeta compiledMethodAt: messageSel ifAbsent: []. 29135 success := newMethod ~~ nil & (newMethod ~~ oldOrNoMethod). 29136 " success ifFalse: [TransferMorph allInstances do: [:e | e delete]]. 29137 " 29138 success 29139 ifTrue: 29140 [copyFlag not ifTrue: ["remove old method in move semantic if new exists" 29141 srcClassOrMeta removeSelector: messageSel].internal 29142 ifTrue: [self selectClass: srcClassOrMeta] 29143 ifFalse: [self selectClass: dstClassOrMeta]. 29144 self setSelector: messageSel]. 29145 ^ success! ! 29146 29147!Browser methodsFor: 'drag and drop' stamp: 'alain.plantec 2/6/2009 16:33'! 29148overwriteDialogHierarchyChange: hierarchyChange higher: higherFlag sourceClassName: srcClassName destinationClassName: dstClassName methodSelector: methodSelector 29149 | lf | 29150 lf := Character cr asString. 29151 ^ UIManager default 29152 confirm: 'There is a conflict.' translated, ' Overwrite' translated, (hierarchyChange 29153 ifTrue: [higherFlag 29154 ifTrue: [' superclass' translated] 29155 ifFalse: [' subclass' translated]] 29156 ifFalse: ['']) , ' method' translated, lf , dstClassName , '>>' , methodSelector , lf , 'by ' translated, (hierarchyChange 29157 ifTrue: ['moving' translated] 29158 ifFalse: ['copying' translated]) , ' method' translated, lf , srcClassName name , '>>' , methodSelector , ' ?'. 29159 29160! ! 29161 29162!Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! 29163wantsDroppedMorph: transferMorph event: anEvent inMorph: destinationLM 29164 "We are only interested in TransferMorphs as wrappers for 29165 informations. If their content is really interesting for us, will 29166 determined later in >>acceptDroppingMorph:event:." 29167 29168 | srcType dstType | 29169 29170 "only want drops on lists (not, for example, on pluggable texts)" 29171 (destinationLM isKindOf: PluggableListMorph) ifFalse: [^ false]. 29172 29173 srcType := transferMorph dragTransferType. 29174 dstType := destinationLM getListSelector. 29175 29176 (srcType == #messageList 29177 and: [dstType == #messageCategoryList or: [dstType == #classList]]) 29178 ifTrue: [^true]. 29179 (srcType == #classList 29180 and: [dstType == #systemCategoryList]) 29181 ifTrue: [^true]. 29182" [ 29183 srcLS == #messageList ifTrue: [^ dstLS == #messageList | (dstLS == #messageCategoryList) | (dstLS == #classList)]. 29184 srcLS == #classList ifTrue: [^ dstLS == #classList | (dstLS == #systemCategoryList)]]. 29185" 29186 ^ false! ! 29187 29188 29189!Browser methodsFor: 'initialization' stamp: 'md 2/24/2006 15:24'! 29190addAListPane: aListPane to: window at: nominalFractions plus: verticalOffset 29191 29192 | row switchHeight divider | 29193 29194 row := AlignmentMorph newColumn 29195 hResizing: #spaceFill; 29196 vResizing: #spaceFill; 29197 layoutInset: 1; 29198 borderWidth: 1; 29199 layoutPolicy: ProportionalLayout new. 29200 switchHeight := 25. 29201 self 29202 addMorphicSwitchesTo: row 29203 at: ( 29204 LayoutFrame 29205 fractions: (0@1 corner: 1@1) 29206 offsets: (0@(1-switchHeight) corner: 0@0) 29207 ). 29208 29209 divider := BorderedSubpaneDividerMorph forTopEdge. 29210 divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 0. 29211 row 29212 addMorph: divider 29213 fullFrame: ( 29214 LayoutFrame 29215 fractions: (0@1 corner: 1@1) 29216 offsets: (0@switchHeight negated corner: 0@(1-switchHeight)) 29217 ). 29218 29219 row 29220 addMorph: aListPane 29221 fullFrame: ( 29222 LayoutFrame 29223 fractions: (0@0 corner: 1@1) 29224 offsets: (0@0 corner: 0@(switchHeight negated)) 29225 ). 29226 29227 window 29228 addMorph: row 29229 fullFrame: ( 29230 LayoutFrame 29231 fractions: nominalFractions 29232 offsets: (0@verticalOffset corner: 0@0) 29233 ). 29234 row on: #mouseEnter send: #paneTransition: to: window. 29235 row on: #mouseLeave send: #paneTransition: to: window. 29236 29237! ! 29238 29239!Browser methodsFor: 'initialization' stamp: 'RAA 1/10/2001 11:46'! 29240addClassAndSwitchesTo: window at: nominalFractions plus: verticalOffset 29241 29242 ^self 29243 addAListPane: self buildMorphicClassList 29244 to: window 29245 at: nominalFractions 29246 plus: verticalOffset 29247! ! 29248 29249!Browser methodsFor: 'initialization' stamp: 'rr 6/21/2005 13:24'! 29250addMorphicSwitchesTo: window at: aLayoutFrame 29251 29252 window 29253 addMorph: self buildMorphicSwitches 29254 fullFrame: aLayoutFrame. 29255 29256! ! 29257 29258!Browser methodsFor: 'initialization' stamp: 'rww 8/18/2002 09:31'! 29259browseSelectionInPlace 29260 29261 "In place code - incomplete" 29262" self systemCategoryListIndex: 29263 (self systemCategoryList indexOf: self selectedClass category). 29264 self classListIndex: (self classList indexOf: self selectedClass name)" 29265 29266 self spawnHierarchy.! ! 29267 29268!Browser methodsFor: 'initialization'! 29269browserWindowActivated 29270 "Called when a window whose model is the receiver is reactivated, giving the receiver an opportunity to take steps if it wishes. The default is to do nothing. 8/5/96 sw"! ! 29271 29272!Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/15/2009 09:36'! 29273buildMorphicClassList 29274 29275 | myClassList | 29276 29277 (myClassList := PluggableListMorph new) 29278 on: self list: #classList 29279 selected: #classListIndex changeSelected: #classListIndex: 29280 menu: #classListMenu:shifted: keystroke: #classListKey:from:. 29281 myClassList borderWidth: 0. 29282 myClassList enableDragNDrop: true. 29283 myClassList doubleClickSelector: #browseSelectionInPlace. 29284 "For doubleClick to work best disable autoDeselect" 29285 myClassList autoDeselect: false . 29286 ^myClassList 29287 29288! ! 29289 29290!Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/15/2009 09:36'! 29291buildMorphicMessageCatList 29292 29293 | myMessageCatList | 29294 29295 (myMessageCatList := PluggableMessageCategoryListMorph new) 29296 on: self list: #messageCategoryList 29297 selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: 29298 menu: #messageCategoryMenu: 29299 keystroke: #arrowKey:from: getRawListSelector: #rawMessageCategoryList. 29300 myMessageCatList enableDragNDrop: true. 29301 ^myMessageCatList 29302! ! 29303 29304!Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/15/2009 09:36'! 29305buildMorphicMessageList 29306 "Build a morphic message list, with #messageList as its list-getter" 29307 29308 | aListMorph | 29309 (aListMorph := PluggableListMorph new) 29310 on: self list: #messageList 29311 selected: #messageListIndex changeSelected: #messageListIndex: 29312 menu: #messageListMenu:shifted: 29313 keystroke: #messageListKey:from:. 29314 aListMorph enableDragNDrop: true. 29315 aListMorph menuTitleSelector: #messageListSelectorTitle. 29316 ^aListMorph 29317 29318! ! 29319 29320!Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/15/2009 09:36'! 29321buildMorphicSystemCatList 29322 | dragNDropFlag myCatList | 29323 dragNDropFlag := true. 29324 (myCatList := PluggableListMorph new) 29325 on: self list: #systemCategoryList 29326 selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: 29327 menu: #systemCategoryMenu: keystroke: #systemCatListKey:from:. 29328 myCatList enableDragNDrop: dragNDropFlag. 29329 ^myCatList 29330! ! 29331 29332!Browser methodsFor: 'initialization' stamp: 'sw 1/13/2000 16:45'! 29333defaultBrowserTitle 29334 ^ 'System Browser'! ! 29335 29336!Browser methodsFor: 'initialization' stamp: 'ar 1/31/2001 20:56'! 29337highlightClassList: list with: morphList! ! 29338 29339!Browser methodsFor: 'initialization' stamp: 'ar 1/31/2001 20:56'! 29340highlightMessageCategoryList: list with: morphList! ! 29341 29342!Browser methodsFor: 'initialization' stamp: 'ar 1/31/2001 20:56'! 29343highlightSystemCategoryList: list with: morphList! ! 29344 29345!Browser methodsFor: 'initialization' stamp: 'AdrianLienhard 8/26/2009 21:07'! 29346labelString 29347 ^self selectedClass ifNil: [ self defaultBrowserTitle ] 29348 ifNotNil: [ self selectedClass printString ]. 29349! ! 29350 29351!Browser methodsFor: 'initialization' stamp: 'sw 9/22/1999 17:13'! 29352methodCategoryChanged 29353 self changed: #messageCategoryList. 29354 self changed: #messageList. 29355 self changed: #annotation. 29356 self messageListIndex: 0! ! 29357 29358!Browser methodsFor: 'initialization' stamp: 'marcus.denker 11/26/2008 14:24'! 29359openAsMorphClassEditing: editString 29360 "Create a pluggable version a Browser on just a single class." 29361 | window dragNDropFlag hSepFrac switchHeight mySingletonClassList | 29362 29363 window := (SystemWindow labelled: 'later') model: self. 29364 dragNDropFlag := true. 29365 hSepFrac := 0.3. 29366 switchHeight := 25. 29367 mySingletonClassList := PluggableListMorph on: self list: #classListSingleton 29368 selected: #indexIsOne changeSelected: #indexIsOne: 29369 menu: #classListMenu:shifted: keystroke: #classListKey:from:. 29370 mySingletonClassList enableDragNDrop: dragNDropFlag. 29371 29372 self 29373 addLowerPanesTo: window 29374 at: (0@hSepFrac corner: 1@1) 29375 with: editString. 29376 window 29377 addMorph: mySingletonClassList 29378 fullFrame: ( 29379 LayoutFrame 29380 fractions: (0@0 corner: 0.5@0) 29381 offsets: (0@0 corner: 0@switchHeight) 29382 ). 29383 29384 self 29385 addMorphicSwitchesTo: window 29386 at: ( 29387 LayoutFrame 29388 fractions: (0.5@0 corner: 1.0@0) 29389 offsets: (0@0 corner: 0@switchHeight) 29390 ). 29391 29392 window 29393 addMorph: self buildMorphicMessageCatList 29394 fullFrame: ( 29395 LayoutFrame 29396 fractions: (0@0 corner: 0.5@hSepFrac) 29397 offsets: (0@switchHeight corner: 0@0) 29398 ). 29399 29400 window 29401 addMorph: self buildMorphicMessageList 29402 fullFrame: ( 29403 LayoutFrame 29404 fractions: (0.5@0 corner: 1.0@hSepFrac) 29405 offsets: (0@switchHeight corner: 0@0) 29406 ). 29407 29408 window setUpdatablePanesFrom: #(messageCategoryList messageList). 29409 ^ window 29410! ! 29411 29412!Browser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! 29413openAsMorphEditing: editString 29414 "Create a pluggable version of all the morphs for a Browser in Morphic" 29415 | window hSepFrac | 29416 29417 hSepFrac := 0.4. 29418 window := (SystemWindow labelled: 'later') model: self. 29419 29420"The method SystemWindow>>addMorph:fullFrame: checks scrollBarsOnRight, then adds the morph at the back if true, otherwise it is added in front. But flopout hScrollbars need the lowerpanes to be behind the upper ones in the draw order. Hence the value of scrollBarsOnRight affects the order in which the lowerpanes are added. " 29421 Preferences scrollBarsOnRight ifFalse: 29422 [self 29423 addLowerPanesTo: window 29424 at: (0@hSepFrac corner: 1@1) 29425 with: editString]. 29426 29427 window 29428 addMorph: self buildMorphicSystemCatList 29429 frame: (0@0 corner: 0.25@hSepFrac). 29430 self 29431 addClassAndSwitchesTo: window 29432 at: (0.25@0 corner: 0.5@hSepFrac) 29433 plus: 0. 29434 window 29435 addMorph: self buildMorphicMessageCatList 29436 frame: (0.5@0 extent: 0.25@hSepFrac). 29437 window addMorph: self buildMorphicMessageList 29438 frame: (0.75@0 extent: 0.25@hSepFrac). 29439 29440 Preferences scrollBarsOnRight ifTrue: 29441 [self 29442 addLowerPanesTo: window 29443 at: (0@hSepFrac corner: 1@1) 29444 with: editString]. 29445 29446 window setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList). 29447 ^ window 29448! ! 29449 29450!Browser methodsFor: 'initialization' stamp: 'marcus.denker 11/26/2008 14:24'! 29451openAsMorphMessageEditing: editString 29452 "Create a pluggable version a Browser that shows just one message" 29453 | window mySingletonMessageList verticalOffset nominalFractions | 29454 window := (SystemWindow labelled: 'later') model: self. 29455 29456 mySingletonMessageList := PluggableListMorph on: self list: #messageListSingleton 29457 selected: #indexIsOne changeSelected: #indexIsOne: 29458 menu: #messageListMenu:shifted: 29459 keystroke: #messageListKey:from:. 29460 mySingletonMessageList enableDragNDrop: true. 29461 verticalOffset := 25. 29462 nominalFractions := 0@0 corner: 1@0. 29463 window 29464 addMorph: mySingletonMessageList 29465 fullFrame: ( 29466 LayoutFrame 29467 fractions: nominalFractions 29468 offsets: (0@0 corner: 0@verticalOffset) 29469 ). 29470 29471 verticalOffset := self addOptionalAnnotationsTo: window at: nominalFractions plus: verticalOffset. 29472 verticalOffset := self addOptionalButtonsTo: window at: nominalFractions plus: verticalOffset. 29473 29474 window 29475 addMorph: (self buildMorphicCodePaneWith: editString) 29476 fullFrame: ( 29477 LayoutFrame 29478 fractions: (0@0 corner: 1@1) 29479 offsets: (0@verticalOffset corner: 0@0) 29480 ). 29481 29482 ^ window! ! 29483 29484!Browser methodsFor: 'initialization' stamp: 'marcus.denker 11/26/2008 14:24'! 29485openAsMorphMsgCatEditing: editString 29486 "Create a pluggable version a Browser on just a message category." 29487 29488 | window hSepFrac | 29489 window := (SystemWindow labelled: 'later') model: self. 29490 hSepFrac := 0.3. 29491 window 29492 addMorph: ((PluggableListMorph on: self list: #messageCatListSingleton 29493 selected: #indexIsOne changeSelected: #indexIsOne: 29494 menu: #messageCategoryMenu:) enableDragNDrop: true) 29495 fullFrame: ( 29496 LayoutFrame 29497 fractions: (0@0 corner: 1@0) 29498 offsets: (0@0 corner: 0@25) 29499 ). 29500 window 29501 addMorph: self buildMorphicMessageList 29502 fullFrame: ( 29503 LayoutFrame 29504 fractions: (0@0 corner: 1@hSepFrac) 29505 offsets: (0@25 corner: 0@0) 29506 ). 29507 29508 self 29509 addLowerPanesTo: window 29510 at: (0@hSepFrac corner: 1@1) 29511 with: editString. 29512 window setUpdatablePanesFrom: #(messageCatListSingleton messageList). 29513 ^ window! ! 29514 29515!Browser methodsFor: 'initialization' stamp: 'marcus.denker 11/26/2008 14:24'! 29516openAsMorphSysCatEditing: editString 29517 "Create a pluggable version of all the views for a Browser, including views and controllers." 29518 | window hSepFrac switchHeight mySingletonList nextOffsets | 29519 29520 window := (SystemWindow labelled: 'later') model: self. 29521 hSepFrac := 0.30. 29522 switchHeight := 25. 29523 mySingletonList := PluggableListMorph on: self list: #systemCategorySingleton 29524 selected: #indexIsOne changeSelected: #indexIsOne: 29525 menu: #systemCatSingletonMenu: keystroke: #systemCatSingletonKey:from:. 29526 mySingletonList enableDragNDrop: true. 29527 mySingletonList hideScrollBarsIndefinitely. 29528 window 29529 addMorph: mySingletonList 29530 fullFrame: ( 29531 LayoutFrame 29532 fractions: (0@0 corner: 1@0) 29533 offsets: (0@0 corner: 0@switchHeight) 29534 ). 29535 29536 self 29537 addClassAndSwitchesTo: window 29538 at: (0@0 corner: 0.3333@hSepFrac) 29539 plus: switchHeight. 29540 29541 nextOffsets := 0@switchHeight corner: 0@0. 29542 window 29543 addMorph: self buildMorphicMessageCatList 29544 fullFrame: ( 29545 LayoutFrame 29546 fractions: (0.3333@0 corner: 0.6666@hSepFrac) 29547 offsets: nextOffsets 29548 ). 29549 29550 window 29551 addMorph: self buildMorphicMessageList 29552 fullFrame: ( 29553 LayoutFrame 29554 fractions: (0.6666@0 corner: 1@hSepFrac) 29555 offsets: nextOffsets 29556 ). 29557 29558 self 29559 addLowerPanesTo: window 29560 at: (0@hSepFrac corner: 1@1) 29561 with: editString. 29562 29563 window setUpdatablePanesFrom: #( classList messageCategoryList messageList). 29564 ^ window! ! 29565 29566!Browser methodsFor: 'initialization' stamp: 'alain.plantec 6/10/2008 18:33'! 29567openEditString: aString 29568 "Create a pluggable version of all the views for a Browser, including views and controllers." 29569 ^ self openAsMorphEditing: aString! ! 29570 29571!Browser methodsFor: 'initialization' stamp: 'alain.plantec 6/10/2008 18:34'! 29572openMessageCatEditString: aString 29573 "Create a pluggable version of the views for a Browser that just shows one message category." 29574 ^ self openAsMorphMsgCatEditing: aString! ! 29575 29576!Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/30/2008 10:08'! 29577openMessageEditString: aString 29578 "Create a pluggable version of the views for a Browser that just shows one message." 29579 ^ self openAsMorphMessageEditing: aString! ! 29580 29581!Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/30/2008 10:13'! 29582openOnClassWithEditString: aString 29583 "Create a pluggable version of all the views for a Browser, including views and controllers." 29584 ^ self openAsMorphClassEditing: aString. 29585 29586! ! 29587 29588!Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/30/2008 10:16'! 29589openSystemCatEditString: aString 29590 "Create a pluggable version of all the views for a Browser, including views and controllers. The top list view is of the currently selected system class category--a single item list." 29591 29592 ^ self openAsMorphSysCatEditing: aString! ! 29593 29594!Browser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! 29595setClass: aBehavior selector: aSymbol 29596 "Set the state of a new, uninitialized Browser." 29597 29598 | isMeta aClass messageCatIndex | 29599 aBehavior ifNil: [^ self]. 29600 (aBehavior isKindOf: Metaclass) 29601 ifTrue: [ 29602 isMeta := true. 29603 aClass := aBehavior soleInstance] 29604 ifFalse: [ 29605 isMeta := false. 29606 aClass := aBehavior]. 29607 self selectCategoryForClass: aClass. 29608 self classListIndex: ( 29609 (systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) 29610 indexOf: aClass name). 29611 self metaClassIndicated: isMeta. 29612 aSymbol ifNil: [^ self]. 29613 messageCatIndex := aBehavior organization numberOfCategoryOfElement: aSymbol. 29614 self messageCategoryListIndex: (messageCatIndex > 0 29615 ifTrue: [messageCatIndex + 1] 29616 ifFalse: [0]). 29617 messageCatIndex = 0 ifTrue: [^ self]. 29618 self messageListIndex: ( 29619 (aBehavior organization listAtCategoryNumber: messageCatIndex) 29620 indexOf: aSymbol).! ! 29621 29622!Browser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! 29623setSelector: aSymbol 29624 "Make the receiver point at the given selector, in the currently chosen class" 29625 29626 | aClass messageCatIndex | 29627 aSymbol ifNil: [^ self]. 29628 (aClass := self selectedClassOrMetaClass) ifNil: [^ self]. 29629 messageCatIndex := aClass organization numberOfCategoryOfElement: aSymbol. 29630 self messageCategoryListIndex: messageCatIndex + 1. 29631 messageCatIndex = 0 ifTrue: [^ self]. 29632 self messageListIndex: 29633 ((aClass organization listAtCategoryNumber: messageCatIndex) 29634 indexOf: aSymbol)! ! 29635 29636!Browser methodsFor: 'initialization' stamp: 'sw 11/8/1999 13:36'! 29637systemCatSingletonKey: aChar from: aView 29638 ^ self messageListKey: aChar from: aView! ! 29639 29640!Browser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! 29641systemOrganizer: aSystemOrganizer 29642 "Initialize the receiver as a perspective on the system organizer, 29643 aSystemOrganizer. Typically there is only one--the system variable 29644 SystemOrganization." 29645 29646 contents := nil. 29647 systemOrganizer := aSystemOrganizer. 29648 systemCategoryListIndex := 0. 29649 classListIndex := 0. 29650 messageCategoryListIndex := 0. 29651 messageListIndex := 0. 29652 metaClassIndicated := false. 29653 self setClassOrganizer. 29654 self editSelection: #none.! ! 29655 29656 29657!Browser methodsFor: 'message category functions' stamp: 'DamienCassou 9/29/2009 09:04'! 29658addCategory 29659 "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" 29660 | labels reject lines cats menuIndex oldIndex newName | 29661 self okToChange ifFalse: [^ self]. 29662 classListIndex = 0 ifTrue: [^ self]. 29663 labels := OrderedCollection with: 'new...'. 29664 reject := Set new. 29665 reject 29666 addAll: self selectedClassOrMetaClass organization categories; 29667 add: ClassOrganizer nullCategory; 29668 add: ClassOrganizer default. 29669 lines := OrderedCollection new. 29670 self selectedClassOrMetaClass allSuperclasses do: [:cls | 29671 cls = Object ifFalse: [ 29672 cats := cls organization categories reject: 29673 [:cat | reject includes: cat]. 29674 cats isEmpty ifFalse: [ 29675 lines add: labels size. 29676 labels addAll: cats asSortedCollection. 29677 reject addAll: cats]]]. 29678 newName := (labels size = 1 or: [ 29679 menuIndex := (UIManager default chooseFrom: labels lines: lines title: 'Add Category'). 29680 menuIndex = 0 ifTrue: [^ self]. 29681 menuIndex = 1]) 29682 ifTrue: [ 29683 self request: 'Please type new category name' 29684 initialAnswer: 'category name'] 29685 ifFalse: [ 29686 labels at: menuIndex]. 29687 oldIndex := messageCategoryListIndex. 29688 newName isEmptyOrNil 29689 ifTrue: [^ self] 29690 ifFalse: [newName := newName asSymbol]. 29691 self classOrMetaClassOrganizer 29692 addCategory: newName 29693 before: (messageCategoryListIndex = 0 29694 ifTrue: [nil] 29695 ifFalse: [self selectedMessageCategoryName]). 29696 self changed: #messageCategoryList. 29697 self messageCategoryListIndex: 29698 (oldIndex = 0 29699 ifTrue: [self classOrMetaClassOrganizer categories size + 1] 29700 ifFalse: [oldIndex]). 29701 self changed: #messageCategoryList. 29702! ! 29703 29704!Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:47'! 29705alphabetizeMessageCategories 29706 classListIndex = 0 ifTrue: [^ false]. 29707 self okToChange ifFalse: [^ false]. 29708 self classOrMetaClassOrganizer sortCategories. 29709 self clearUserEditFlag. 29710 self editClass. 29711 self classListIndex: classListIndex. 29712 ^ true! ! 29713 29714!Browser methodsFor: 'message category functions'! 29715buildMessageCategoryBrowser 29716 "Create and schedule a message category browser for the currently 29717 selected message category." 29718 29719 self buildMessageCategoryBrowserEditString: nil! ! 29720 29721!Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'! 29722buildMessageCategoryBrowserEditString: aString 29723 "Create and schedule a message category browser for the currently 29724 selected message category. The initial text view contains the characters 29725 in aString." 29726 "wod 6/24/1998: set newBrowser classListIndex so that it works whether the 29727 receiver is a standard or a Hierarchy Browser." 29728 29729 | newBrowser | 29730 messageCategoryListIndex ~= 0 29731 ifTrue: 29732 [newBrowser := Browser new. 29733 newBrowser systemCategoryListIndex: systemCategoryListIndex. 29734 newBrowser classListIndex: (newBrowser classList indexOf: self selectedClassName). 29735 newBrowser metaClassIndicated: metaClassIndicated. 29736 newBrowser messageCategoryListIndex: messageCategoryListIndex. 29737 newBrowser messageListIndex: messageListIndex. 29738 self class openBrowserView: (newBrowser openMessageCatEditString: aString) 29739 label: 'Message Category Browser (' , 29740 newBrowser selectedClassOrMetaClassName , ')']! ! 29741 29742!Browser methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:10'! 29743canShowMultipleMessageCategories 29744 "Answer whether the receiver is capable of showing multiple message categories" 29745 29746 ^ true! ! 29747 29748!Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'! 29749categoryOfCurrentMethod 29750 "Determine the method category associated with the receiver at the current moment, or nil if none" 29751 29752 | aCategory | 29753 ^ super categoryOfCurrentMethod ifNil: 29754 [(aCategory := self messageCategoryListSelection) == ClassOrganizer allCategory 29755 ifTrue: 29756 [nil] 29757 ifFalse: 29758 [aCategory]]! ! 29759 29760!Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:56'! 29761changeMessageCategories: aString 29762 "The characters in aString represent an edited version of the the message 29763 categories for the selected class. Update this information in the system 29764 and inform any dependents that the categories have been changed. This 29765 message is invoked because the user had issued the categories command 29766 and edited the message categories. Then the user issued the accept 29767 command." 29768 29769 self classOrMetaClassOrganizer changeFromString: aString. 29770 self clearUserEditFlag. 29771 self editClass. 29772 self classListIndex: classListIndex. 29773 ^ true! ! 29774 29775!Browser methodsFor: 'message category functions' stamp: 'nk 2/14/2004 15:06'! 29776editMessageCategories 29777 "Indicate to the receiver and its dependents that the message categories of 29778 the selected class have been changed." 29779 29780 self okToChange ifFalse: [^ self]. 29781 classListIndex ~= 0 29782 ifTrue: 29783 [self messageCategoryListIndex: 0. 29784 self editSelection: #editMessageCategories. 29785 self changed: #editMessageCategories. 29786 self contentsChanged]! ! 29787 29788!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'! 29789fileOutMessageCategories 29790 "Print a description of the selected message category of the selected class 29791 onto an external file." 29792 29793Cursor write showWhile: 29794 [messageCategoryListIndex ~= 0 29795 ifTrue: 29796 [self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName]]! ! 29797 29798!Browser methodsFor: 'message category functions' stamp: 'marcus.denker 10/20/2008 20:53'! 29799messageCategoryMenu: aMenu 29800 ServiceGui browser: self messageCategoryMenu: aMenu. 29801 ServiceGui onlyServices ifTrue: [^aMenu]. 29802 ^ aMenu labels: 29803'browse 29804fileOut 29805reorganize 29806alphabetize 29807remove empty categories 29808categorize all uncategorized 29809new category... 29810rename... 29811remove' 29812 lines: #(3 8) 29813 selections: 29814 #(buildMessageCategoryBrowser fileOutMessageCategories 29815 editMessageCategories alphabetizeMessageCategories removeEmptyCategories 29816 categorizeAllUncategorizedMethods addCategory renameCategory removeMessageCategory) 29817! ! 29818 29819!Browser methodsFor: 'message category functions' stamp: 'nk 4/23/2004 09:18'! 29820removeEmptyCategories 29821 self okToChange ifFalse: [^ self]. 29822 self selectedClassOrMetaClass organization removeEmptyCategories. 29823 self changed: #messageCategoryList 29824! ! 29825 29826!Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'! 29827removeMessageCategory 29828 "If a message category is selected, create a Confirmer so the user can 29829 verify that the currently selected message category should be removed 29830 from the system. If so, remove it." 29831 29832 | messageCategoryName | 29833 messageCategoryListIndex = 0 ifTrue: [^ self]. 29834 self okToChange ifFalse: [^ self]. 29835 messageCategoryName := self selectedMessageCategoryName. 29836 (self messageList size = 0 29837 or: [self confirm: 'Are you sure you want to 29838remove this method category 29839and all its methods?']) 29840 ifTrue: 29841 [self selectedClassOrMetaClass removeCategory: messageCategoryName. 29842 self messageCategoryListIndex: 0. 29843 self changed: #classSelectionChanged]. 29844 self changed: #messageCategoryList. 29845! ! 29846 29847!Browser methodsFor: 'message category functions' stamp: 'DamienCassou 9/29/2009 09:05'! 29848renameCategory 29849 "Prompt for a new category name and add it before the 29850 current selection, or at the end if no current selection" 29851 | oldIndex oldName newName | 29852 classListIndex = 0 ifTrue: [^ self]. 29853 self okToChange ifFalse: [^ self]. 29854 (oldIndex := messageCategoryListIndex) = 0 ifTrue: [^ self]. 29855 oldName := self selectedMessageCategoryName. 29856 newName := self 29857 request: 'Please type new category name' 29858 initialAnswer: oldName. 29859 newName isEmptyOrNil 29860 ifTrue: [^ self] 29861 ifFalse: [newName := newName asSymbol]. 29862 newName = oldName ifTrue: [^ self]. 29863 self classOrMetaClassOrganizer 29864 renameCategory: oldName 29865 toBe: newName. 29866 self classListIndex: classListIndex. 29867 self messageCategoryListIndex: oldIndex. 29868 self changed: #messageCategoryList. 29869! ! 29870 29871!Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'! 29872showHomeCategory 29873 "Show the home category of the selected method. This is only really useful if one is in a tool that supports the showing of categories. Thus, it's good in browsers and hierarchy browsers but not in message-list browsers" 29874 29875 | aSelector | 29876 self okToChange ifTrue: 29877 [(aSelector := self selectedMessageName) ifNotNil: 29878 [self selectOriginalCategoryForCurrentMethod. 29879 self selectedMessageName: aSelector]]! ! 29880 29881 29882!Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'! 29883categorizeAllUncategorizedMethods 29884 "Categorize methods by looking in parent classes for a method category." 29885 29886 | organizer organizers | 29887 organizer := self classOrMetaClassOrganizer. 29888 organizers := self selectedClassOrMetaClass withAllSuperclasses collect: [:ea | ea organization]. 29889 (organizer listAtCategoryNamed: ClassOrganizer default) do: [:sel | | found | 29890 found := (organizers collect: [ :org | org categoryOfElement: sel]) 29891 detect: [:ea | ea ~= ClassOrganizer default and: [ ea ~= nil]] 29892 ifNone: []. 29893 found ifNotNil: [organizer classify: sel under: found]]. 29894 29895 self changed: #messageCategoryList! ! 29896 29897!Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'! 29898messageCatListSingleton 29899 29900 | name | 29901 name := self selectedMessageCategoryName. 29902 ^ name ifNil: [Array new] 29903 ifNotNil: [Array with: name]! ! 29904 29905!Browser methodsFor: 'message category list' stamp: 'ccn 3/22/1999 17:56'! 29906messageCategoryList 29907 "Answer the selected category of messages." 29908 29909 classListIndex = 0 29910 ifTrue: [^ Array new] 29911 ifFalse: [^ (Array with: ClassOrganizer allCategory), self classOrMetaClassOrganizer categories]! ! 29912 29913!Browser methodsFor: 'message category list'! 29914messageCategoryListIndex 29915 "Answer the index of the selected message category." 29916 29917 ^messageCategoryListIndex! ! 29918 29919!Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'! 29920messageCategoryListIndex: anInteger 29921 "Set the selected message category to be the one indexed by anInteger." 29922 29923 messageCategoryListIndex := anInteger. 29924 messageListIndex := 0. 29925 self changed: #messageCategorySelectionChanged. 29926 self changed: #messageCategoryListIndex. "update my selection" 29927 self changed: #messageList. 29928 self editSelection: (anInteger > 0 29929 ifTrue: [#newMessage] 29930 ifFalse: [self classListIndex > 0 29931 ifTrue: [#editClass] 29932 ifFalse: [#newClass]]). 29933 contents := nil. 29934 self contentsChanged.! ! 29935 29936!Browser methodsFor: 'message category list' stamp: 'ccn 3/24/1999 11:02'! 29937messageCategoryListSelection 29938 "Return the selected category name or nil." 29939 29940 ^ ((self messageCategoryList size = 0 29941 or: [self messageCategoryListIndex = 0]) 29942 or: [self messageCategoryList size < self messageCategoryListIndex]) 29943 ifTrue: [nil] 29944 ifFalse: [self messageCategoryList at: (self messageCategoryListIndex max: 1)]! ! 29945 29946!Browser methodsFor: 'message category list' stamp: 'sw 10/16/1999 22:56'! 29947rawMessageCategoryList 29948 ^ classListIndex = 0 29949 ifTrue: [Array new] 29950 ifFalse: [self classOrMetaClassOrganizer categories]! ! 29951 29952!Browser methodsFor: 'message category list' stamp: 'nk 4/22/2004 17:59'! 29953recategorizeMethodSelector: sel 29954 "Categorize method named sel by looking in parent classes for a 29955 method category. 29956 Answer true if recategorized." 29957 | thisCat | 29958 self selectedClassOrMetaClass allSuperclasses 29959 do: [:ea | 29960 thisCat := ea organization categoryOfElement: sel. 29961 (thisCat ~= ClassOrganizer default 29962 and: [thisCat notNil]) 29963 ifTrue: [self classOrMetaClassOrganizer classify: sel under: thisCat. 29964 self changed: #messageCategoryList. 29965 ^ true]]. 29966 ^ false! ! 29967 29968!Browser methodsFor: 'message category list' stamp: 'nk 6/13/2004 06:20'! 29969selectMessageCategoryNamed: aSymbol 29970 "Given aSymbol, select the category with that name. Do nothing if 29971 aSymbol doesn't exist." 29972 self messageCategoryListIndex: (self messageCategoryList indexOf: aSymbol ifAbsent: [ 1])! ! 29973 29974!Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'! 29975selectOriginalCategoryForCurrentMethod 29976 "private - Select the message category for the current method. 29977 29978 Note: This should only be called when somebody tries to save 29979 a method that they are modifying while ALL is selected. 29980 29981 Returns: true on success, false on failure." 29982 | aSymbol selectorName | 29983 aSymbol := self categoryOfCurrentMethod. 29984 selectorName := self selectedMessageName. 29985 (aSymbol notNil and: [aSymbol ~= ClassOrganizer allCategory]) 29986 ifTrue: 29987 [messageCategoryListIndex := (self messageCategoryList indexOf: aSymbol). 29988 messageListIndex := (self messageList indexOf: selectorName). 29989 self changed: #messageCategorySelectionChanged. 29990 self changed: #messageCategoryListIndex. "update my selection" 29991 self changed: #messageList. 29992 self changed: #messageListIndex. 29993 ^ true]. 29994 ^ false! ! 29995 29996!Browser methodsFor: 'message category list'! 29997selectedMessageCategoryName 29998 "Answer the name of the selected message category, if any. Answer nil 29999 otherwise." 30000 30001 messageCategoryListIndex = 0 ifTrue: [^nil]. 30002 ^self messageCategoryList at: messageCategoryListIndex! ! 30003 30004!Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'! 30005setOriginalCategoryIndexForCurrentMethod 30006 "private - Set the message category index for the currently selected method. 30007 30008 Note: This should only be called when somebody tries to save 30009 a method that they are modifying while ALL is selected." 30010 30011 messageCategoryListIndex := self messageCategoryList indexOf: self categoryOfCurrentMethod 30012 ! ! 30013 30014 30015!Browser methodsFor: 'message functions' stamp: 'sw 1/11/2001 07:22'! 30016addExtraShiftedItemsTo: aMenu 30017 "The shifted selector-list menu is being built; some menu items are appropriate only for certain kinds of browsers, and this gives a hook for them to be added as approrpiate. If any is added here, a line should be added first -- browse reimplementors of this message for examples." 30018! ! 30019 30020!Browser methodsFor: 'message functions'! 30021buildMessageBrowser 30022 "Create and schedule a message browser on the currently selected 30023 message. Do nothing if no message is selected. The initial text view 30024 contains nothing." 30025 30026 self buildMessageBrowserEditString: nil! ! 30027 30028!Browser methodsFor: 'message functions' stamp: 'sd 1/5/2002 21:11'! 30029buildMessageBrowserEditString: aString 30030 "Create and schedule a message browser for the receiver in which the 30031 argument, aString, contains characters to be edited in the text view." 30032 30033 messageListIndex = 0 ifTrue: [^ self]. 30034 ^ self class openMessageBrowserForClass: self selectedClassOrMetaClass 30035 selector: self selectedMessageName editString: aString! ! 30036 30037!Browser methodsFor: 'message functions' stamp: 'sd 11/20/2005 21:26'! 30038defineMessage: aString notifying: aController 30039 "Compile the expressions in aString. Notify aController if a syntax error 30040 occurs. Install the compiled method in the selected class classified under 30041 the currently selected message category name. Answer true if 30042 compilation succeeds, false otherwise." 30043 | selectedMessageName selector category oldMessageList | 30044 selectedMessageName := self selectedMessageName. 30045 oldMessageList := self messageList. 30046 contents := nil. 30047 selector := self selectedClassOrMetaClass 30048 compile: aString 30049 classified: (category := self selectedMessageCategoryName) 30050 notifying: aController. 30051 selector == nil ifTrue: [^ false]. 30052 contents := aString copy. 30053 selector ~~ selectedMessageName 30054 ifTrue: 30055 [category = ClassOrganizer nullCategory 30056 ifTrue: [self changed: #classSelectionChanged. 30057 self changed: #classList. 30058 self messageCategoryListIndex: 1]. 30059 self setClassOrganizer. "In case organization not cached" 30060 (oldMessageList includes: selector) 30061 ifFalse: [self changed: #messageList]. 30062 self messageListIndex: (self messageList indexOf: selector)]. 30063 ^ true! ! 30064 30065!Browser methodsFor: 'message functions' stamp: 'lr 7/3/2009 20:59'! 30066defineMessageFrom: aString notifying: aController 30067 "Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise." 30068 | selectedMessageName selector category oldMessageList | 30069 selectedMessageName := self selectedMessageName. 30070 oldMessageList := self messageList. 30071 contents := nil. 30072 selector := self selectedClassOrMetaClass 30073 compile: aString 30074 classified: (category := self selectedMessageCategoryName) 30075 notifying: aController. 30076 selector == nil ifTrue: [^ nil]. 30077 contents := aString copy. 30078 selector ~~ selectedMessageName 30079 ifTrue: 30080 [category = ClassOrganizer nullCategory 30081 ifTrue: [self changed: #classSelectionChanged. 30082 self changed: #classList. 30083 self messageCategoryListIndex: 1]. 30084 self setClassOrganizer. "In case organization not cached" 30085 (oldMessageList includes: selector) 30086 ifFalse: [self changed: #messageList]. 30087 self messageListIndex: (self messageList indexOf: selector)]. 30088 ^ selector! ! 30089 30090!Browser methodsFor: 'message functions' stamp: 'al 4/24/2004 12:48'! 30091inspectInstances 30092 "Inspect all instances of the selected class. 1/26/96 sw" 30093 30094 | myClass | 30095 ((myClass := self selectedClassOrMetaClass) isNil or: [myClass isTrait]) 30096 ifFalse: [myClass theNonMetaClass inspectAllInstances] 30097! ! 30098 30099!Browser methodsFor: 'message functions' stamp: 'al 4/24/2004 12:48'! 30100inspectSubInstances 30101 "Inspect all instances of the selected class and all its subclasses 1/26/96 sw" 30102 30103 | aClass | 30104 ((aClass := self selectedClassOrMetaClass) isNil or: [aClass isTrait]) 30105 ifFalse: [ 30106 aClass := aClass theNonMetaClass. 30107 aClass inspectSubInstances]. 30108! ! 30109 30110!Browser methodsFor: 'message functions' stamp: 'marcus.denker 9/20/2008 20:27'! 30111messageListMenu: aMenu shifted: shifted 30112 "Answer the message-list menu" 30113 ServiceGui browser: self messageListMenu: aMenu. 30114 ServiceGui onlyServices ifTrue: [^ aMenu]. 30115 shifted 30116 ifTrue: [^ self shiftedMessageListMenu: aMenu]. 30117 aMenu addList: #( 30118 ('what to show...' offerWhatToShowMenu) 30119 ('toggle break on entry' toggleBreakOnEntry) 30120 - 30121 ('browse full (b)' browseMethodFull) 30122 ('browse hierarchy (h)' classHierarchy) 30123 ('browse method (O)' openSingleMessageBrowser) 30124 ('browse protocol (p)' browseFullProtocol) 30125 - 30126 ('fileOut' fileOutMessage) 30127 - 30128 ('senders of... (n)' browseSendersOfMessages) 30129 ('implementors of... (m)' browseMessages) 30130 ('inheritance (i)' methodHierarchy) 30131 ('versions (v)' browseVersions) 30132 - 30133 ('inst var refs...' browseInstVarRefs) 30134 ('inst var defs...' browseInstVarDefs) 30135 ('class var refs...' browseClassVarRefs) 30136 ('class variables' browseClassVariables) 30137 ('class refs (N)' browseClassRefs) 30138 - 30139 ('remove method (x)' removeMessage) 30140 - 30141 ('more...' shiftedYellowButtonActivity)). 30142 ^ aMenu! ! 30143 30144!Browser methodsFor: 'message functions' stamp: 'al 4/24/2004 11:49'! 30145removeMessage 30146 "If a message is selected, create a Confirmer so the user can verify that 30147 the currently selected message should be removed from the system. If 30148 so, 30149 remove it. If the Preference 'confirmMethodRemoves' is set to false, the 30150 confirmer is bypassed." 30151 | messageName confirmation | 30152 messageListIndex = 0 30153 ifTrue: [^ self]. 30154 self okToChange 30155 ifFalse: [^ self]. 30156 messageName := self selectedMessageName. 30157 confirmation := self systemNavigation confirmRemovalOf: messageName on: self selectedClassOrMetaClass. 30158 confirmation == 3 30159 ifTrue: [^ self]. 30160 (self selectedClassOrMetaClass includesLocalSelector: messageName) 30161 ifTrue: [self selectedClassOrMetaClass removeSelector: messageName] 30162 ifFalse: [self removeNonLocalSelector: messageName]. 30163 self messageListIndex: 0. 30164 self changed: #messageList. 30165 self setClassOrganizer. 30166 "In case organization not cached" 30167 confirmation == 2 30168 ifTrue: [self systemNavigation browseAllCallsOn: messageName]! ! 30169 30170!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:03'! 30171removeMessageFromBrowser 30172 "Our list speaks the truth and can't have arbitrary things removed" 30173 30174 ^ self changed: #flash! ! 30175 30176!Browser methodsFor: 'message functions' stamp: 'stephane.ducasse 10/26/2008 14:39'! 30177shiftedMessageListMenu: aMenu 30178 "Fill aMenu with the items appropriate when the shift key is held down" 30179 30180 aMenu addStayUpItem. 30181 aMenu addList: #( 30182 ('toggle diffing (D)' toggleDiffing) 30183 ('implementors of sent messages' browseAllMessages) 30184 - 30185 ('local senders of...' browseLocalSendersOfMessages) 30186 ('local implementors of...' browseLocalImplementors) 30187 - 30188 ('spawn sub-protocol' spawnProtocol) 30189 ('spawn full protocol' spawnFullProtocol) 30190 - 30191 ('sample instance' makeSampleInstance) 30192 ('inspect instances' inspectInstances) 30193 ('inspect subinstances' inspectSubInstances)). 30194 30195 self addExtraShiftedItemsTo: aMenu. 30196 aMenu addList: #( 30197 - 30198 ('change category...' changeCategory)). 30199 30200 self canShowMultipleMessageCategories ifTrue: [aMenu addList: 30201 #(('show category (C)' showHomeCategory))]. 30202 aMenu addList: #( 30203 - 30204 ('change sets with this method' findMethodInChangeSets) 30205 ('revert to previous version' revertToPreviousVersion) 30206 ('remove from current change set' removeFromCurrentChanges) 30207 ('revert & remove from changes' revertAndForget) 30208 ('add to current change set' adoptMessageInCurrentChangeset) 30209 ('copy up or copy down...' copyUpOrCopyDown) 30210 - 30211 ('more...' unshiftedYellowButtonActivity)). 30212 ^ aMenu 30213! ! 30214 30215 30216!Browser methodsFor: 'message list' stamp: 'adrian-lienhard 5/18/2009 21:10'! 30217messageList 30218 "Answer an Array of the message selectors of the currently selected message category, provided that the messageCategoryListIndex is in proper range. Otherwise, answer an empty Array If messageCategoryListIndex is found to be larger than the number of categories (it happens!!), it is reset to zero." 30219 | sel | 30220 (sel := self messageCategoryListSelection) ifNil: [ 30221 ^ self classOrMetaClassOrganizer 30222 ifNil: [Array new] 30223 ifNotNil: [self classOrMetaClassOrganizer allMethodSelectors] 30224 ]. 30225 30226 ^ sel = ClassOrganizer allCategory ifTrue: [ 30227 self classOrMetaClassOrganizer 30228 ifNil: [Array new] 30229 ifNotNil: [self classOrMetaClassOrganizer allMethodSelectors]] 30230 ifFalse: [ 30231 (self classOrMetaClassOrganizer listAtCategoryNumber: messageCategoryListIndex - 1) 30232 ifNil: [messageCategoryListIndex := 0. Array new]]! ! 30233 30234!Browser methodsFor: 'message list'! 30235messageListIndex 30236 "Answer the index of the selected message selector into the currently 30237 selected message category." 30238 30239 ^messageListIndex! ! 30240 30241!Browser methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'! 30242messageListIndex: anInteger 30243 "Set the selected message selector to be the one indexed by anInteger." 30244 30245 messageListIndex := anInteger. 30246 self editSelection: (anInteger > 0 30247 ifTrue: [#editMessage] 30248 ifFalse: [self messageCategoryListIndex > 0 30249 ifTrue: [#newMessage] 30250 ifFalse: [self classListIndex > 0 30251 ifTrue: [#editClass] 30252 ifFalse: [#newClass]]]). 30253 contents := nil. 30254 self changed: #messageListIndex. "update my selection" 30255 self contentsChanged. 30256 self decorateButtons.! ! 30257 30258!Browser methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'! 30259messageListSingleton 30260 30261 | name | 30262 name := self selectedMessageName. 30263 ^ name ifNil: [Array new] 30264 ifNotNil: [Array with: name]! ! 30265 30266!Browser methodsFor: 'message list' stamp: 'sw 12/1/2000 11:17'! 30267reformulateList 30268 "If the receiver has a way of reformulating its message list, here is a chance for it to do so" 30269 30270 super reformulateList. 30271 self messageListIndex: 0! ! 30272 30273!Browser methodsFor: 'message list' stamp: 'md 2/20/2006 15:01'! 30274selectedMessage 30275 "Answer a copy of the source code for the selected message." 30276 30277 | class selector method | 30278 contents == nil ifFalse: [^ contents copy]. 30279 30280 self showingDecompile ifTrue: 30281 [^ self decompiledSourceIntoContents]. 30282 30283 class := self selectedClassOrMetaClass. 30284 selector := self selectedMessageName. 30285 method := class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" 30286 currentCompiledMethod := method. 30287 30288 ^ contents := (self showingDocumentation 30289 ifFalse: [ self sourceStringPrettifiedAndDiffed ] 30290 ifTrue: [ self commentContents ]) 30291 copy asText makeSelectorBoldIn: class! ! 30292 30293!Browser methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'! 30294selectedMessageName 30295 "Answer the message selector of the currently selected message, if any. 30296 Answer nil otherwise." 30297 30298 | aList | 30299 messageListIndex = 0 ifTrue: [^ nil]. 30300 ^ (aList := self messageList) size >= messageListIndex 30301 ifTrue: 30302 [aList at: messageListIndex] 30303 ifFalse: 30304 [nil]! ! 30305 30306!Browser methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'! 30307selectedMessageName: aSelector 30308 "Make the given selector be the selected message name" 30309 30310 | anIndex | 30311 anIndex := self messageList indexOf: aSelector. 30312 anIndex > 0 ifTrue: 30313 [self messageListIndex: anIndex]! ! 30314 30315!Browser methodsFor: 'message list'! 30316toggleMessageListIndex: anInteger 30317 "If the currently selected message index is anInteger, deselect the message 30318 selector. Otherwise select the message selector whose index is anInteger." 30319 30320 self messageListIndex: 30321 (messageListIndex = anInteger 30322 ifTrue: [0] 30323 ifFalse: [anInteger])! ! 30324 30325 30326!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 12:25'! 30327classCommentIndicated 30328 "Answer true iff we're viewing the class comment." 30329 30330 ^ editSelection == #editComment 30331! ! 30332 30333!Browser methodsFor: 'metaclass' stamp: 'mir 9/25/2008 14:56'! 30334classMessagesIndicated 30335 "Answer whether the messages to be presented should come from the metaclass." 30336 30337 ^ self metaClassIndicated and: [self classCommentIndicated not]! ! 30338 30339!Browser methodsFor: 'metaclass'! 30340classOrMetaClassOrganizer 30341 "Answer the class organizer for the metaclass or class, depending on 30342 which (instance or class) is indicated." 30343 30344 self metaClassIndicated 30345 ifTrue: [^metaClassOrganizer] 30346 ifFalse: [^classOrganizer]! ! 30347 30348!Browser methodsFor: 'metaclass'! 30349indicateClassMessages 30350 "Indicate that the message selection should come from the metaclass 30351 messages." 30352 30353 self metaClassIndicated: true! ! 30354 30355!Browser methodsFor: 'metaclass'! 30356indicateInstanceMessages 30357 "Indicate that the message selection should come from the class (instance) 30358 messages." 30359 30360 self metaClassIndicated: false! ! 30361 30362!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:20'! 30363instanceMessagesIndicated 30364 "Answer whether the messages to be presented should come from the 30365 class." 30366 30367 ^metaClassIndicated not and: [self classCommentIndicated not]! ! 30368 30369!Browser methodsFor: 'metaclass' stamp: 'sr 6/21/2000 17:23'! 30370metaClassIndicated 30371 "Answer the boolean flag that indicates which of the method dictionaries, 30372 class or metaclass." 30373 30374 ^ metaClassIndicated! ! 30375 30376!Browser methodsFor: 'metaclass' stamp: 'sd 11/20/2005 21:26'! 30377metaClassIndicated: trueOrFalse 30378 "Indicate whether browsing instance or class messages." 30379 30380 metaClassIndicated := trueOrFalse. 30381 self setClassOrganizer. 30382 systemCategoryListIndex > 0 ifTrue: 30383 [self editSelection: (classListIndex = 0 30384 ifTrue: [metaClassIndicated 30385 ifTrue: [#none] 30386 ifFalse: [#newClass]] 30387 ifFalse: [#editClass])]. 30388 messageCategoryListIndex := 0. 30389 messageListIndex := 0. 30390 contents := nil. 30391 self changed: #classSelectionChanged. 30392 self changed: #messageCategoryList. 30393 self changed: #messageList. 30394 self changed: #contents. 30395 self changed: #annotation. 30396 self decorateButtons 30397! ! 30398 30399!Browser methodsFor: 'metaclass' stamp: 'al 4/24/2004 11:47'! 30400selectedClassOrMetaClass 30401 "Answer the selected class/trait or metaclass/classTrait." 30402 30403 | cls | 30404 ^self metaClassIndicated 30405 ifTrue: [(cls := self selectedClass) ifNil: [nil] ifNotNil: [cls classSide]] 30406 ifFalse: [self selectedClass]! ! 30407 30408!Browser methodsFor: 'metaclass'! 30409selectedClassOrMetaClassName 30410 "Answer the selected class name or metaclass name." 30411 30412 ^self selectedClassOrMetaClass name! ! 30413 30414!Browser methodsFor: 'metaclass' stamp: 'md 2/18/2006 16:31'! 30415setClassOrganizer 30416 "Install whatever organization is appropriate" 30417 | theClass | 30418 classOrganizer := nil. 30419 metaClassOrganizer := nil. 30420 classListIndex = 0 ifTrue: [^ self]. 30421 theClass := self selectedClass ifNil: [ ^self ]. 30422 classOrganizer := theClass organization. 30423 metaClassOrganizer := theClass classSide organization.! ! 30424 30425 30426!Browser methodsFor: 'system category functions' stamp: 'DamienCassou 9/29/2009 09:04'! 30427addSystemCategory 30428 "Prompt for a new category name and add it before the 30429 current selection, or at the end if no current selection" 30430 | oldIndex newName | 30431 self okToChange ifFalse: [^ self]. 30432 oldIndex := systemCategoryListIndex. 30433 newName := self 30434 request: 'Please type new category name' 30435 initialAnswer: 'Category-Name'. 30436 newName isEmptyOrNil 30437 ifTrue: [^ self] 30438 ifFalse: [newName := newName asSymbol]. 30439 systemOrganizer 30440 addCategory: newName 30441 before: (systemCategoryListIndex = 0 30442 ifTrue: [nil] 30443 ifFalse: [self selectedSystemCategoryName]). 30444 self systemCategoryListIndex: 30445 (oldIndex = 0 30446 ifTrue: [self systemCategoryList size] 30447 ifFalse: [oldIndex]). 30448 self changed: #systemCategoryList.! ! 30449 30450!Browser methodsFor: 'system category functions' stamp: 'brp 8/4/2003 21:38'! 30451alphabetizeSystemCategories 30452 30453 self okToChange ifFalse: [^ false]. 30454 systemOrganizer sortCategories. 30455 self systemCategoryListIndex: 0. 30456 self changed: #systemCategoryList. 30457! ! 30458 30459!Browser methodsFor: 'system category functions'! 30460buildSystemCategoryBrowser 30461 "Create and schedule a new system category browser." 30462 30463 self buildSystemCategoryBrowserEditString: nil! ! 30464 30465!Browser methodsFor: 'system category functions' stamp: 'sd 11/20/2005 21:26'! 30466buildSystemCategoryBrowserEditString: aString 30467 "Create and schedule a new system category browser with initial textual 30468 contents set to aString." 30469 30470 | newBrowser | 30471 systemCategoryListIndex > 0 30472 ifTrue: 30473 [newBrowser := self class new. 30474 newBrowser systemCategoryListIndex: systemCategoryListIndex. 30475 newBrowser setClass: self selectedClassOrMetaClass selector: self selectedMessageName. 30476 self class openBrowserView: (newBrowser openSystemCatEditString: aString) 30477 label: 'Classes in category ', newBrowser selectedSystemCategoryName]! ! 30478 30479!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:21'! 30480changeSystemCategories: aString 30481 "Update the class categories by parsing the argument aString." 30482 30483 systemOrganizer changeFromString: aString. 30484 self changed: #systemCategoryList. 30485 ^ true! ! 30486 30487!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:43'! 30488classNotFound 30489 30490 self changed: #flash.! ! 30491 30492!Browser methodsFor: 'system category functions' stamp: 'nk 2/14/2004 15:09'! 30493editSystemCategories 30494 "Retrieve the description of the class categories of the system organizer." 30495 30496 self okToChange ifFalse: [^ self]. 30497 self systemCategoryListIndex: 0. 30498 self editSelection: #editSystemCategories. 30499 self changed: #editSystemCategories. 30500 self contentsChanged! ! 30501 30502!Browser methodsFor: 'system category functions' stamp: 'tk 3/31/98 07:52'! 30503fileOutSystemCategory 30504 "Print a description of each class in the selected category onto a file 30505 whose name is the category name followed by .st." 30506 30507 systemCategoryListIndex ~= 0 30508 ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName]! ! 30509 30510!Browser methodsFor: 'system category functions' stamp: 'DamienCassou 9/23/2009 08:32'! 30511findClass 30512 "Search for a class by name." 30513 | pattern foundClassOrTrait | 30514 30515 self okToChange ifFalse: [^ self classNotFound]. 30516 pattern := UIManager default request: 'Class name or fragment?'. 30517 pattern isEmptyOrNil ifTrue: [^ self classNotFound]. 30518 foundClassOrTrait := SystemNavigation default classFromPattern: pattern withCaption: ''. 30519 foundClassOrTrait ifNil: [^ self classNotFound]. 30520 self selectCategoryForClass: foundClassOrTrait. 30521 self selectClass: foundClassOrTrait. 30522! ! 30523 30524!Browser methodsFor: 'system category functions' stamp: 'sw 11/8/1999 10:04'! 30525potentialClassNames 30526 "Answer the names of all the classes that could be viewed in this browser. This hook is provided so that HierarchyBrowsers can indicate their restricted subset. For generic Browsers, the entire list of classes known to Smalltalk is provided, though of course that really only is accurate in the case of full system browsers." 30527 30528 ^ Smalltalk classNames! ! 30529 30530!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:55'! 30531removeSystemCategory 30532 "If a class category is selected, create a Confirmer so the user can 30533 verify that the currently selected class category and all of its classes 30534 should be removed from the system. If so, remove it." 30535 30536 systemCategoryListIndex = 0 ifTrue: [^ self]. 30537 self okToChange ifFalse: [^ self]. 30538 (self classList size = 0 30539 or: [self confirm: 'Are you sure you want to 30540remove this system category 30541and all its classes?']) 30542 ifTrue: 30543 [systemOrganizer removeSystemCategory: self selectedSystemCategoryName. 30544 self systemCategoryListIndex: 0. 30545 self changed: #systemCategoryList]! ! 30546 30547!Browser methodsFor: 'system category functions' stamp: 'DamienCassou 9/29/2009 09:05'! 30548renameSystemCategory 30549 "Prompt for a new category name and add it before the 30550 current selection, or at the end if no current selection" 30551 | oldIndex oldName newName | 30552 (oldIndex := systemCategoryListIndex) = 0 30553 ifTrue: [^ self]. "no selection" 30554 self okToChange ifFalse: [^ self]. 30555 oldName := self selectedSystemCategoryName. 30556 newName := self 30557 request: 'Please type new category name' 30558 initialAnswer: oldName. 30559 newName isEmptyOrNil 30560 ifTrue: [^ self] 30561 ifFalse: [newName := newName asSymbol]. 30562 oldName = newName ifTrue: [^ self]. 30563 systemOrganizer 30564 renameCategory: oldName 30565 toBe: newName. 30566 self systemCategoryListIndex: oldIndex. 30567 self changed: #systemCategoryList.! ! 30568 30569!Browser methodsFor: 'system category functions' stamp: 'marcus.denker 10/20/2008 21:22'! 30570systemCatSingletonMenu: aMenu 30571 30572 ^ aMenu labels: 30573'browse 30574fileOut 30575update 30576rename... 30577remove' 30578 lines: #(2 4) 30579 selections: 30580 #(buildSystemCategoryBrowser 30581 fileOutSystemCategory updateSystemCategories 30582 renameSystemCategory removeSystemCategory) 30583! ! 30584 30585!Browser methodsFor: 'system category functions' stamp: 'marcus.denker 10/20/2008 21:23'! 30586systemCategoryMenu: aMenu 30587 30588 ServiceGui browser: self classCategoryMenu: aMenu. 30589 ServiceGui onlyServices ifTrue: [^aMenu]. 30590 ^ aMenu labels: 30591'find class... (f) 30592recent classes... (r) 30593browse 30594fileOut 30595reorganize 30596alphabetize 30597update 30598add category... 30599rename... 30600remove' 30601 lines: #(2 4 6 8) 30602 selections: 30603 #(findClass recent buildSystemCategoryBrowser 30604 fileOutSystemCategory 30605 editSystemCategories alphabetizeSystemCategories updateSystemCategories 30606 addSystemCategory renameSystemCategory removeSystemCategory )! ! 30607 30608!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:17'! 30609updateSystemCategories 30610 "The class categories were changed in another browser. The receiver must 30611 reorganize its lists based on these changes." 30612 30613 self okToChange ifFalse: [^ self]. 30614 self changed: #systemCategoryList! ! 30615 30616 30617!Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'! 30618indexIsOne 30619 "When used as a singleton list, index is always one" 30620 ^ 1! ! 30621 30622!Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'! 30623indexIsOne: value 30624 "When used as a singleton list, can't change it" 30625 30626 ^ self! ! 30627 30628!Browser methodsFor: 'system category list' stamp: 'stp 01/13/2000 12:25'! 30629selectCategoryForClass: theClass 30630 30631 self systemCategoryListIndex: (self systemCategoryList indexOf: theClass category) 30632! ! 30633 30634!Browser methodsFor: 'system category list' stamp: 'md 3/3/2006 11:02'! 30635selectedEnvironment 30636 "Answer the name of the selected system category or nil." 30637 30638 systemCategoryListIndex = 0 ifTrue: [^nil]. 30639 ^ Smalltalk! ! 30640 30641!Browser methodsFor: 'system category list'! 30642selectedSystemCategoryName 30643 "Answer the name of the selected system category or nil." 30644 30645 systemCategoryListIndex = 0 ifTrue: [^nil]. 30646 ^self systemCategoryList at: systemCategoryListIndex! ! 30647 30648!Browser methodsFor: 'system category list'! 30649systemCategoryList 30650 "Answer the class categories modelled by the receiver." 30651 30652 ^systemOrganizer categories! ! 30653 30654!Browser methodsFor: 'system category list'! 30655systemCategoryListIndex 30656 "Answer the index of the selected class category." 30657 30658 ^systemCategoryListIndex! ! 30659 30660!Browser methodsFor: 'system category list' stamp: 'sd 11/20/2005 21:26'! 30661systemCategoryListIndex: anInteger 30662 "Set the selected system category index to be anInteger. Update all other 30663 selections to be deselected." 30664 30665 systemCategoryListIndex := anInteger. 30666 classListIndex := 0. 30667 messageCategoryListIndex := 0. 30668 messageListIndex := 0. 30669 self editSelection: ( anInteger = 0 ifTrue: [#none] ifFalse: [#newClass]). 30670 metaClassIndicated := false. 30671 self setClassOrganizer. 30672 contents := nil. 30673 self changed: #systemCategorySelectionChanged. 30674 self changed: #systemCategoryListIndex. "update my selection" 30675 self changed: #classList. 30676 self changed: #messageCategoryList. 30677 self changed: #messageList. 30678 self changed: #relabel. 30679 self contentsChanged! ! 30680 30681!Browser methodsFor: 'system category list' stamp: 'sd 11/20/2005 21:26'! 30682systemCategorySingleton 30683 30684 | cat | 30685 cat := self selectedSystemCategoryName. 30686 ^ cat ifNil: [Array new] 30687 ifNotNil: [Array with: cat]! ! 30688 30689!Browser methodsFor: 'system category list'! 30690toggleSystemCategoryListIndex: anInteger 30691 "If anInteger is the current system category index, deselect it. Else make 30692 it the current system category selection." 30693 30694 self systemCategoryListIndex: 30695 (systemCategoryListIndex = anInteger 30696 ifTrue: [0] 30697 ifFalse: [anInteger])! ! 30698 30699 30700!Browser methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:19'! 30701buildWith: builder 30702 "Create the ui for the browser" 30703 | windowSpec listSpec textSpec buttonSpec panelSpec max | 30704 windowSpec := builder pluggableWindowSpec new. 30705 windowSpec model: self. 30706 windowSpec label: 'System Browser'. 30707 windowSpec children: OrderedCollection new. 30708 30709 max := self wantsOptionalButtons ifTrue:[0.43] ifFalse:[0.5]. 30710 listSpec := builder pluggableListSpec new. 30711 listSpec 30712 model: self; 30713 list: #systemCategoryList; 30714 getIndex: #systemCategoryListIndex; 30715 setIndex: #systemCategoryListIndex:; 30716 menu: #systemCategoryMenu:; 30717 keyPress: #systemCatListKey:from:; 30718 frame: (0@0 corner: 0.25@max). 30719 windowSpec children add: listSpec. 30720 30721 listSpec := builder pluggableListSpec new. 30722 listSpec 30723 model: self; 30724 list: #classList; 30725 getIndex: #classListIndex; 30726 setIndex: #classListIndex:; 30727 menu: #classListMenu:; 30728 keyPress: #classListKey:from:; 30729 frame: (0.25@0 corner: 0.5@(max-0.1)). 30730 windowSpec children add: listSpec. 30731 30732 panelSpec := builder pluggablePanelSpec new. 30733 panelSpec frame: (0.25@(max-0.1) corner: 0.5@max). 30734 panelSpec children: OrderedCollection new. 30735 windowSpec children addLast: panelSpec. 30736 30737 buttonSpec := builder pluggableButtonSpec new. 30738 buttonSpec 30739 model: self; 30740 label: 'instance'; 30741 state: #instanceMessagesIndicated; 30742 action: #indicateInstanceMessages; 30743 frame: (0@0 corner: 0.4@1). 30744 panelSpec children addLast: buttonSpec. 30745 30746 buttonSpec := builder pluggableButtonSpec new. 30747 buttonSpec 30748 model: self; 30749 label: '?'; 30750 state: #classCommentIndicated; 30751 action: #plusButtonHit; 30752 frame: (0.4@0 corner: 0.6@1). 30753 panelSpec children addLast: buttonSpec. 30754 30755 buttonSpec := builder pluggableButtonSpec new. 30756 buttonSpec 30757 model: self; 30758 label: 'class'; 30759 state: #classMessagesIndicated; 30760 action: #indicateClassMessages; 30761 frame: (0.6@0 corner: 1@1). 30762 panelSpec children addLast: buttonSpec. 30763 30764 listSpec := builder pluggableListSpec new. 30765 listSpec 30766 model: self; 30767 list: #messageCategoryList; 30768 getIndex: #messageCategoryListIndex; 30769 setIndex: #messageCategoryListIndex:; 30770 menu: #messageCategoryMenu:; 30771 keyPress: #arrowKey:from:; 30772 frame: (0.5@0 corner: 0.75@max). 30773 windowSpec children add: listSpec. 30774 30775 listSpec := builder pluggableListSpec new. 30776 listSpec 30777 model: self; 30778 list: #messageList; 30779 getIndex: #messageListIndex; 30780 setIndex: #messageListIndex:; 30781 menu: #messageListMenu:shifted:; 30782 keyPress: #messageListKey:from:; 30783 frame: (0.75@0 corner: 1@max). 30784 windowSpec children add: listSpec. 30785 30786 self wantsOptionalButtons ifTrue:[ 30787 panelSpec := self buildOptionalButtonsWith: builder. 30788 panelSpec frame: (0@0.43 corner: 1@0.5). 30789 windowSpec children add: panelSpec. 30790 ]. 30791 30792 textSpec := builder pluggableTextSpec new. 30793 textSpec 30794 model: self; 30795 getText: #contents; 30796 setText: #contents:notifying:; 30797 selection: #contentsSelection; 30798 menu: #codePaneMenu:shifted:; 30799 frame: (0@0.5corner: 1@1). 30800 windowSpec children add: textSpec. 30801 30802 ^builder build: windowSpec! ! 30803 30804 30805!Browser methodsFor: 'traits' stamp: 'al 1/9/2006 18:29'! 30806addSpecialMenu: aMenu 30807 aMenu addList: #( 30808 - 30809 ('new class' newClass) 30810 ('new trait' newTrait) 30811 -). 30812 self selectedClass notNil ifTrue: [ 30813 aMenu addList: #( 30814 ('add trait' addTrait) 30815 -) ]. 30816 aMenu addList: #(-). 30817 ^ aMenu! ! 30818 30819!Browser methodsFor: 'traits' stamp: 'al 1/9/2006 18:26'! 30820addTrait 30821 | input trait | 30822 input := UIManager default request: 'add trait'. 30823 input isEmptyOrNil ifFalse: [ 30824 trait := Smalltalk classNamed: input. 30825 (trait isNil or: [trait isTrait not]) ifTrue: [ 30826 ^self inform: 'Input invalid. ' , input , ' does not exist or is not a trait']. 30827 self selectedClass addToComposition: trait. 30828 self contentsChanged]. 30829! ! 30830 30831!Browser methodsFor: 'traits' stamp: 'md 3/3/2006 10:58'! 30832defineTrait: defString notifying: aController 30833 30834 | defTokens keywdIx envt oldTrait newTraitName trait | 30835 oldTrait := self selectedClassOrMetaClass. 30836 defTokens := defString findTokens: Character separators. 30837 keywdIx := defTokens findFirst: [:x | x = 'category']. 30838 envt := self selectedEnvironment. 30839 keywdIx := defTokens findFirst: [:x | x = 'named:']. 30840 newTraitName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'. 30841 ((oldTrait isNil or: [oldTrait baseTrait name asString ~= newTraitName]) 30842 and: [envt includesKey: newTraitName asSymbol]) ifTrue: 30843 ["Attempting to define new class/trait over existing one when 30844 not looking at the original one in this browser..." 30845 (self confirm: ((newTraitName , ' is an existing class/trait in this system. 30846Redefining it might cause serious problems. 30847Is this really what you want to do?') asText makeBoldFrom: 1 to: newTraitName size)) 30848 ifFalse: [^ false]]. 30849 30850 trait := Compiler evaluate: defString notifying: aController logged: true. 30851 ^(trait isKindOf: TraitBehavior) 30852 ifTrue: [ 30853 self changed: #classList. 30854 self classListIndex: (self classList indexOf: trait baseTrait name). 30855 self clearUserEditFlag; editClass. 30856 true] 30857 ifFalse: [ false ] 30858! ! 30859 30860!Browser methodsFor: 'traits' stamp: 'al 4/24/2004 11:48'! 30861newClass 30862 (self selectedClassOrMetaClass notNil and: 30863 [self selectedClassOrMetaClass isTrait]) ifTrue: [self classListIndex: 0]. 30864 self editClass. 30865 editSelection := #newClass. 30866 self contentsChanged! ! 30867 30868!Browser methodsFor: 'traits' stamp: 'al 4/24/2004 11:48'! 30869newTrait 30870 self classListIndex: 0. 30871 self editClass. 30872 editSelection := #newTrait. 30873 self contentsChanged! ! 30874 30875!Browser methodsFor: 'traits' stamp: 'al 4/24/2004 11:49'! 30876removeNonLocalSelector: aSymbol 30877 | traits isAlias | 30878 traits := self selectedClassOrMetaClass traitsProvidingSelector: aSymbol. 30879 isAlias := self selectedClassOrMetaClass isLocalAliasSelector: aSymbol. 30880 isAlias 30881 ifTrue: [ 30882 self assert: traits size = 1. 30883 self selectedClassOrMetaClass removeAlias: aSymbol of: traits first] 30884 ifFalse: [ 30885 traits do: [:each | 30886 self selectedClassOrMetaClass addExclusionOf: aSymbol to: each ]] 30887 ! ! 30888 30889 30890!Browser methodsFor: 'user interface' stamp: 'hpt 9/30/2004 20:51'! 30891addModelItemsToWindowMenu: aMenu 30892 "Add model-related items to the window menu" 30893 super addModelItemsToWindowMenu: aMenu. 30894 SystemBrowser addRegistryMenuItemsTo: aMenu inAccountOf: self.! ! 30895 30896"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 30897 30898Browser class 30899 instanceVariableNames: ''! 30900 30901!Browser class methodsFor: 'initialization' stamp: 'hpt 8/5/2004 19:41'! 30902initialize 30903 "Browser initialize" 30904 30905 RecentClasses := OrderedCollection new. 30906 self 30907 registerInFlapsRegistry; 30908 registerInAppRegistry ! ! 30909 30910!Browser class methodsFor: 'initialization' stamp: 'hpt 8/5/2004 19:41'! 30911registerInAppRegistry 30912 "Register the receiver in the SystemBrowser AppRegistry" 30913 SystemBrowser register: self.! ! 30914 30915!Browser class methodsFor: 'initialization' stamp: 'asm 4/10/2003 12:32'! 30916registerInFlapsRegistry 30917 "Register the receiver in the system's flaps registry" 30918 self environment 30919 at: #Flaps 30920 ifPresent: [:cl | cl registerQuad: #(#Browser #prototypicalToolWindow 'Browser' 'A Browser is a tool that allows you to view all the code of all the classes in the system' ) 30921 forFlapNamed: 'Tools']! ! 30922 30923!Browser class methodsFor: 'initialization' stamp: 'hpt 8/5/2004 19:42'! 30924unload 30925 "Unload the receiver from global registries" 30926 30927 self environment at: #Flaps ifPresent: [:cl | 30928 cl unregisterQuadsWithReceiver: self]. 30929 SystemBrowser unregister: self.! ! 30930 30931 30932!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:27'! 30933fullOnClass: aClass 30934 "Open a new full browser set to class." 30935 | brow | 30936 brow := self new. 30937 brow setClass: aClass selector: nil. 30938 ^ self 30939 openBrowserView: (brow openEditString: nil) 30940 label: 'System Browser'! ! 30941 30942!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 30943fullOnClass: aClass selector: aSelector 30944 "Open a new full browser set to class." 30945 30946 | brow classToUse | 30947 classToUse := SystemBrowser default. 30948 brow := classToUse new. 30949 brow setClass: aClass selector: aSelector. 30950 ^ classToUse 30951 openBrowserView: (brow openEditString: nil) 30952 label: brow labelString! ! 30953 30954!Browser class methodsFor: 'instance creation' stamp: 'di 10/18/1999 22:03'! 30955new 30956 30957 ^super new systemOrganizer: SystemOrganization! ! 30958 30959!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 30960newOnCategory: aCategory 30961 "Browse the system category of the given name. 7/13/96 sw" 30962 30963 "Browser newOnCategory: 'Interface-Browser'" 30964 30965 | newBrowser catList | 30966 newBrowser := self new. 30967 catList := newBrowser systemCategoryList. 30968 newBrowser systemCategoryListIndex: 30969 (catList indexOf: aCategory asSymbol ifAbsent: [^ self inform: 'No such category']). 30970 ^ self 30971 openBrowserView: (newBrowser openSystemCatEditString: nil) 30972 label: 'Classes in category ', aCategory 30973! ! 30974 30975!Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 16:28'! 30976newOnClass: aClass 30977 "Open a new class browser on this class." 30978 ^ self newOnClass: aClass label: 'Class Browser: ', aClass name! ! 30979 30980!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 30981newOnClass: aClass label: aLabel 30982 "Open a new class browser on this class." 30983 | newBrowser | 30984 30985 newBrowser := self new. 30986 newBrowser setClass: aClass selector: nil. 30987 ^ self 30988 openBrowserView: (newBrowser openOnClassWithEditString: nil) 30989 label: aLabel 30990! ! 30991 30992!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 30993newOnClass: aClass selector: aSymbol 30994 "Open a new class browser on this class." 30995 | newBrowser | 30996 30997 newBrowser := self new. 30998 newBrowser setClass: aClass selector: aSymbol. 30999 ^ self 31000 openBrowserView: (newBrowser openOnClassWithEditString: nil) 31001 label: 'Class Browser: ', aClass name 31002! ! 31003 31004!Browser class methodsFor: 'instance creation' stamp: 'md 3/10/2006 21:46'! 31005open 31006 ^self openBrowser 31007 31008! ! 31009 31010!Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:11'! 31011openBrowser 31012 "Create and schedule a BrowserView with default browser label. The 31013 view consists of five subviews, starting with the list view of system 31014 categories of SystemOrganization. The initial text view part is empty." 31015 31016 | br | 31017 br := self new. 31018 ^ self 31019 openBrowserView: (br openEditString: nil) 31020 label: br defaultBrowserTitle. 31021 31022! ! 31023 31024!Browser class methodsFor: 'instance creation' stamp: 'alain.plantec 6/19/2008 09:43'! 31025openBrowserView: aBrowserView label: aString 31026 "Schedule aBrowserView, labelling the view aString." 31027 31028 (aBrowserView setLabel: aString) openInWorld. 31029 ^ aBrowserView model 31030! ! 31031 31032!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 31033openMessageBrowserForClass: aBehavior selector: aSymbol editString: aString 31034 "Create and schedule a message browser for the class, aBehavior, in 31035 which the argument, aString, contains characters to be edited in the text 31036 view. These characters are the source code for the message selector 31037 aSymbol." 31038 31039 | newBrowser | 31040 (newBrowser := self new) setClass: aBehavior selector: aSymbol. 31041 ^ self openBrowserView: (newBrowser openMessageEditString: aString) 31042 label: newBrowser selectedClassOrMetaClassName , ' ' , newBrowser selectedMessageName 31043! ! 31044 31045!Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 31046prototypicalToolWindow 31047 "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" 31048 31049 | aWindow | 31050 aWindow := self new openAsMorphEditing: nil. 31051 aWindow setLabel: 'System Browser'; applyModelExtent. 31052 ^ aWindow! ! 31053 31054!Browser class methodsFor: 'instance creation' stamp: 'nk 6/2/2004 12:55'! 31055systemOrganizer: anOrganizer 31056 31057 ^(super new) 31058 systemOrganizer: anOrganizer; 31059 yourself! ! 31060 31061 31062!Browser class methodsFor: 'window color' stamp: 'sw 2/26/2002 13:46'! 31063windowColorSpecification 31064 "Answer a WindowColorSpec object that declares my preference" 31065 31066 ^ WindowColorSpec classSymbol: self name wording: 'Browser' brightColor: #lightGreen pastelColor: #paleGreen helpMessage: 'The standard "system browser" tool that allows you to browse through all the code in the system'! ! 31067PluggableTextMorph subclass: #BrowserCommentTextMorph 31068 instanceVariableNames: '' 31069 classVariableNames: '' 31070 poolDictionaries: '' 31071 category: 'Tools-Browser'! 31072!BrowserCommentTextMorph commentStamp: '<historical>' prior: 0! 31073I am a PluggableTextMorph that knows enough to make myself invisible when necessary.! 31074 31075 31076!BrowserCommentTextMorph methodsFor: 'accessing' stamp: 'nk 2/15/2004 14:12'! 31077lowerPane 31078 "Answer the AlignmentMorph that I live beneath" 31079 ^self valueOfProperty: #browserLowerPane! ! 31080 31081!BrowserCommentTextMorph methodsFor: 'accessing' stamp: 'nk 2/15/2004 14:07'! 31082window 31083 ^self owner ifNil: [ self valueOfProperty: #browserWindow ].! ! 31084 31085 31086!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'nk 2/15/2004 13:41'! 31087hideOrShowPane 31088 (self model editSelection == #editClass) 31089 ifTrue: [ self showPane ] 31090 ifFalse: [ self hidePane ]! ! 31091 31092!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'marcus.denker 11/10/2008 10:04'! 31093hidePane 31094 "Fixed to not keep doing the splitters. If we are hiden don't hide again!!" 31095 31096 | win | 31097 self owner ifNotNil: [ 31098 win := self window ifNil: [^self]. 31099 self window ifNotNil: [:window | window removePaneSplitters]. 31100 self lowerPane ifNotNil: [:lp | 31101 lp layoutFrame bottomFraction: self layoutFrame bottomFraction. 31102 lp layoutFrame bottomOffset: SystemWindow borderWidth negated]. 31103 self delete. 31104 win updatePanesFromSubmorphs. 31105 win addPaneSplitters]! ! 31106 31107!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'marcus.denker 11/10/2008 10:04'! 31108showPane 31109 "Fixed to not keep doing the splitters. If we are showing don't show again!!" 31110 31111 | win | 31112 self owner ifNil: [ 31113 win := self window ifNil: [ ^self ]. 31114 win addMorph: self fullFrame: self layoutFrame. 31115 win updatePanesFromSubmorphs. 31116 self lowerPane ifNotNil: [ :lp | lp layoutFrame bottomFraction: self layoutFrame topFraction ]. 31117 win addPaneSplitters]! ! 31118 31119 31120!BrowserCommentTextMorph methodsFor: 'updating' stamp: 'stephane.ducasse 10/9/2008 18:50'! 31121noteNewOwner: win 31122 "Dirty fix for when the 'lower pane' hasn't been reset to the bottom at the 31123 time the receiver is added" 31124 31125 super noteNewOwner: win. 31126 self setProperty: #browserWindow toValue: win. 31127 win ifNil: [ ^self ]. 31128 win setProperty: #browserClassCommentPane toValue: self. 31129 self setProperty: #browserLowerPane toValue: (win submorphThat: [ :m | m isAlignmentMorph and: [ m layoutFrame bottomFraction = 1 or: [ m layoutFrame bottomFraction = self layoutFrame topFraction]]] ifNone: []). 31130! ! 31131 31132!BrowserCommentTextMorph methodsFor: 'updating' stamp: 'nk 2/15/2004 13:42'! 31133update: anAspect 31134 super update: anAspect. 31135 anAspect == #editSelection ifFalse: [ ^self ]. 31136 self hideOrShowPane! ! 31137ServiceProvider subclass: #BrowserProvider 31138 instanceVariableNames: '' 31139 classVariableNames: '' 31140 poolDictionaries: '' 31141 category: 'Services-Base-Providers'! 31142!BrowserProvider commentStamp: 'rr 7/10/2006 15:17' prior: 0! 31143I define the default categories of services dealing with browsing: 31144- the class category menu (service identifier: browserClassCategoryMenu) 31145- the class menu (browserClassMenu) 31146- the method category menu (browserMethodCategoryMenu) 31147- the browser method menu (browserMethodMenu) 31148- the browser button bar (browserButtonBar) 31149- the browser code pane/selection menu (browserCodePaneMenu)! 31150 31151 31152!BrowserProvider methodsFor: 'saved preferences'! 31153browserClassMenushortcut 31154 ^ #(#'Shortcut for browserClassMenu:' '' 1000 )! ! 31155 31156!BrowserProvider methodsFor: 'saved preferences'! 31157browserMethodMenushortcut 31158 ^ #(#'Shortcut for browserMethodMenu:' '' 1000 )! ! 31159 31160 31161!BrowserProvider methodsFor: 'services' stamp: 'rr 10/23/2005 14:42'! 31162browser 31163 ^ ServiceCategory text: 'Browser' 31164 button: 'browser' 31165 description: 'The browser menus'! ! 31166 31167!BrowserProvider methodsFor: 'services' stamp: 'rr 1/9/2006 18:59'! 31168browserButtonBar 31169 ^ ServiceCategory 31170 text:'button bar' 31171 button:'button' 31172 description:'the browser button bar'! ! 31173 31174!BrowserProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:00'! 31175browserClassCategoryMenu 31176 ^ ServiceCategory 31177 text:'Class Category' 31178 button:'class cat' 31179 description:'The browser class category menu'! ! 31180 31181!BrowserProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:00'! 31182browserClassMenu 31183 ^ ServiceCategory 31184 text:'Class' 31185 button:'class' 31186 description:'The browser class menu'! ! 31187 31188!BrowserProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:01'! 31189browserCodePaneMenu 31190 ^ ServiceCategory text: 'Code Pane' 31191 button: 'pane' 31192 description: 'The browser code pane menu'! ! 31193 31194!BrowserProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:00'! 31195browserMethodCategoryMenu 31196 ^ ServiceCategory 31197 text:'Method Category' 31198 button:'method cat' 31199 description:'The browser method menu'! ! 31200 31201!BrowserProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:01'! 31202browserMethodMenu 31203 ^ ServiceCategory 31204 text:'Method' 31205 button:'method' 31206 description:'The browser method menu'! ! 31207 31208"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 31209 31210BrowserProvider class 31211 instanceVariableNames: ''! 31212 31213!BrowserProvider class methodsFor: 'initialization' stamp: 'rr 1/10/2006 12:53'! 31214initialize 31215 ServiceRegistry current buildProvider: self new! ! 31216TextRequestor subclass: #BrowserRequestor 31217 instanceVariableNames: '' 31218 classVariableNames: '' 31219 poolDictionaries: '' 31220 category: 'Services-Base-Requestors'! 31221!BrowserRequestor commentStamp: 'rr 7/10/2006 15:24' prior: 0! 31222I am a requestor specialized to fetch information in a Browser. 31223I can ask a browser its selected class and selected method for example. 31224If the RB is installed too, I can also fetch ast nodes in the browser's selected 31225method. 31226 31227I am the default requestor for CodeHolder and it's subclasses. 31228 31229To be integrated with services, alternative browsers, such as the OmniBrowser and Whisker should define a specialized requestor subclassing this one. A few core messages would need to be redefined, such as getClass, getMessage ... to be adapted to the browser's data structures. 31230Only a few of them have to be overridden, the majority of the requests rely on a few base ones.! 31231 31232 31233!BrowserRequestor methodsFor: 'initialization' stamp: 'rr 8/27/2005 15:52'! 31234browser: b 31235 self model: b! ! 31236 31237 31238!BrowserRequestor methodsFor: 'requests' stamp: 'gvc 9/26/2008 15:14'! 31239getArgumentPermutation 31240 "Answer the argument permutation map. 31241 No support for changing argument count." 31242 31243 ^(1 to: (self getBrowser selectedMessageName ifNil: [^nil]) numArgs) asArray! ! 31244 31245!BrowserRequestor methodsFor: 'requests' stamp: 'rr 8/27/2005 15:43'! 31246getBrowser 31247 ^ self getModel! ! 31248 31249!BrowserRequestor methodsFor: 'requests' stamp: 'rr 8/27/2005 15:51'! 31250getClass 31251 ^ self getBrowser selectedClassOrMetaClass! ! 31252 31253!BrowserRequestor methodsFor: 'requests' stamp: 'alain.plantec 2/6/2009 15:18'! 31254getInitializingExpressionForTheNewParameter 31255 ^ UIManager default request: 'Enter default parameter code' translated initialAnswer: '42'! ! 31256 31257!BrowserRequestor methodsFor: 'requests' stamp: 'alain.plantec 2/6/2009 15:18'! 31258getNewSelectorName 31259 ^ UIManager default request: 'Enter the new selector name' translated initialAnswer: self getSelector! ! 31260 31261!BrowserRequestor methodsFor: 'requests' stamp: 'alain.plantec 2/6/2009 15:18'! 31262getNewVariableName 31263 ^ UIManager default request: 'Enter the new variable name' translated initialAnswer: 'foo'! ! 31264 31265!BrowserRequestor methodsFor: 'requests' stamp: 'rr 8/4/2005 14:41'! 31266getPackage 31267 self getSelector ifNil: [ 31268 ^ PackageInfo named:( 31269 self getClass ifNil: [self getSystemCategory] 31270 ifNotNilDo: [:c | c category copyUpTo: $-])]. 31271 ^ PackageOrganizer default 31272 packageOfMethod: 31273 (MethodReference class: self getClass 31274 selector: self getSelector) 31275 ifNone: [PackageInfo named: (self getClass category copyUpTo: $-)] ! ! 31276 31277!BrowserRequestor methodsFor: 'requests' stamp: 'rr 5/31/2004 22:10'! 31278getPackageForCategory 31279 "answers a packageinfo for the current class category" 31280 ^ PackageInfo named: self getClass theNonMetaClass category! ! 31281 31282!BrowserRequestor methodsFor: 'requests' stamp: 'rr 5/31/2004 22:10'! 31283getPackageForCategoryName 31284 "answers a packageinfo for the current class category" 31285 ^ self getPackageForCategory packageName! ! 31286 31287!BrowserRequestor methodsFor: 'requests' stamp: 'rr 5/31/2004 22:10'! 31288getPackageName 31289 ^ self getPackage packageName! ! 31290 31291!BrowserRequestor methodsFor: 'requests' stamp: 'rr 1/9/2006 19:27'! 31292getPackageProvider 31293 | provs classes | 31294 provs := ServiceProvider registeredProviders. 31295 classes := self getPackage classes. 31296 ^ classes detect: [:e | provs includes: e] ifNone: [ServiceProvider newProviderFor: self getPackageName]! ! 31297 31298!BrowserRequestor methodsFor: 'requests' stamp: 'rr 8/27/2005 15:52'! 31299getSelection 31300 self getBrowser selectedInterval ifEmpty: [^super getSelection]. 31301 ^ self getBrowser selectedInterval! ! 31302 31303!BrowserRequestor methodsFor: 'requests' stamp: 'rr 1/9/2006 11:58'! 31304getSelector 31305 | s | 31306 s := self getBrowser selectedMessageName. 31307 ^ s ifNil: [super getSelector] ifNotNil: [s]! ! 31308 31309!BrowserRequestor methodsFor: 'requests' stamp: 'rr 10/11/2005 15:06'! 31310getSelectorCollection 31311 self caption: 'enter selector list'. 31312 ^ self getSymbolCollection ! ! 31313 31314!BrowserRequestor methodsFor: 'requests' stamp: 'rr 8/27/2005 15:51'! 31315getSelectorName 31316 ^ self getBrowser selectedMessageName! ! 31317 31318!BrowserRequestor methodsFor: 'requests' stamp: 'rr 8/27/2005 15:51'! 31319getSystemCategory 31320 ^ self getBrowser selectedSystemCategoryName ! ! 31321 31322"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 31323 31324BrowserRequestor class 31325 instanceVariableNames: ''! 31326GenericUrl subclass: #BrowserUrl 31327 instanceVariableNames: '' 31328 classVariableNames: '' 31329 poolDictionaries: '' 31330 category: 'Network-Url'! 31331!BrowserUrl commentStamp: '<historical>' prior: 0! 31332URLs that instruct a browser to do something.! 31333 31334 31335!BrowserUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:42'! 31336hasContents 31337 ^true! ! 31338WidgetStub subclass: #ButtonStub 31339 instanceVariableNames: 'enabled' 31340 classVariableNames: '' 31341 poolDictionaries: '' 31342 category: 'ToolBuilder-SUnit'! 31343 31344!ButtonStub methodsFor: 'events' stamp: 'cwp 4/22/2005 22:01'! 31345eventAccessors 31346 ^ #(label color state enabled)! ! 31347 31348 31349!ButtonStub methodsFor: 'simulating' stamp: 'stephaneducasse 2/3/2006 22:32'! 31350click 31351 | action | 31352 action := spec action. 31353 action isSymbol 31354 ifTrue: [self model perform: action] 31355 ifFalse: [action value]! ! 31356 31357!ButtonStub methodsFor: 'simulating' stamp: 'cwp 4/22/2005 22:44'! 31358color 31359 ^ self model perform: spec color! ! 31360 31361!ButtonStub methodsFor: 'simulating' stamp: 'cwp 7/14/2006 11:09'! 31362isEnabled 31363 enabled ifNil: [enabled := spec model perform: spec enabled]. 31364 ^ enabled! ! 31365ArrayedCollection variableByteSubclass: #ByteArray 31366 instanceVariableNames: '' 31367 classVariableNames: '' 31368 poolDictionaries: '' 31369 category: 'Collections-Arrayed'! 31370!ByteArray commentStamp: '<historical>' prior: 0! 31371I represent an ArrayedCollection whose elements are integers between 0 and 255. 31372! 31373 31374 31375!ByteArray methodsFor: '*Network-Kernel' stamp: 'mir 6/17/2007 23:12'! 31376asSocketAddress 31377 ^SocketAddress fromOldByteAddress: self! ! 31378 31379 31380!ByteArray methodsFor: '*system-hashing-core' stamp: 'rww 4/11/2004 14:48'! 31381asByteArrayOfSize: size 31382 " 31383 '34523' asByteArray asByteArrayOfSize: 100. 31384 31385 ((( 31386 | repeats bytes | 31387 repeats := 1000000. 31388 bytes := '123456789123456789123456789123456789123456789123456789' asByteArray. 31389 [repeats timesRepeat: (bytes asByteArrayOfSize: 1024) ] timeToRun. 31390 )))" 31391 31392 | bytes | 31393 size < self size 31394 ifTrue: [^ self error: 'bytearray bigger than ', size asString]. 31395 bytes := self asByteArray. 31396 ^ (ByteArray new: (size - bytes size)), bytes 31397! ! 31398 31399!ByteArray methodsFor: '*system-hashing-core' stamp: 'StephaneDucasse 10/17/2009 17:15'! 31400bitXor: aByteArray 31401 | answer | 31402 answer := self copy. 31403 1 31404 to: (self size min: aByteArray size) 31405 do: 31406 [ :each | 31407 answer 31408 at: each 31409 put: ((self at: each) bitXor: (aByteArray at: each)) ]. 31410 ^ answer! ! 31411 31412!ByteArray methodsFor: '*system-hashing-core' stamp: 'cmm 2/21/2006 00:05'! 31413destroy 31414 1 to: self size do: 31415 [ : x | 31416 self at: x put: 0 ]! ! 31417 31418 31419!ByteArray methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:35'! 31420asWideString 31421 31422 ^ WideString fromByteArray: self. 31423! ! 31424 31425!ByteArray methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:47'! 31426atAllPut: value 31427 "Fill the receiver with the given value" 31428 31429 <primitive: 145> 31430 super atAllPut: value! ! 31431 31432!ByteArray methodsFor: 'accessing' stamp: 'ar 12/5/1998 14:52'! 31433byteAt: index 31434 <primitive: 60> 31435 ^self at: index! ! 31436 31437!ByteArray methodsFor: 'accessing' stamp: 'ar 12/5/1998 14:52'! 31438byteAt: index put: value 31439 <primitive: 61> 31440 ^self at: index put: value! ! 31441 31442!ByteArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:17'! 31443byteSize 31444 ^self size! ! 31445 31446!ByteArray methodsFor: 'accessing' stamp: 'tk 3/13/2000 14:46'! 31447bytesPerElement 31448 "Number of bytes in each item. This multiplied by (self size)*8 gives the number of bits stored." 31449 ^ 1! ! 31450 31451 31452!ByteArray methodsFor: 'comparing' stamp: 'SqR 8/13/2002 10:52'! 31453hash 31454 "#hash is implemented, because #= is implemented" 31455 31456 ^self class 31457 hashBytes: self 31458 startingWith: self species hash! ! 31459 31460 31461!ByteArray methodsFor: 'converting' stamp: 'sma 5/12/2000 17:35'! 31462asByteArray 31463 ^ self! ! 31464 31465!ByteArray methodsFor: 'converting'! 31466asString 31467 "Convert to a String with Characters for each byte. 31468 Fast code uses primitive that avoids character conversion" 31469 31470 ^ (String new: self size) replaceFrom: 1 to: self size with: self! ! 31471 31472!ByteArray methodsFor: 'converting' stamp: 'MarianoMartinezPeck 8/16/2009 17:21'! 31473hex 31474 | result stream | 31475 result := String new: self size * 2. 31476 stream := result writeStream. 31477 1 to: self size do: [ :ix | |each| 31478 each := self at: ix. 31479 stream 31480 nextPut: ('0123456789ABCDEF' at: each // 16 + 1); 31481 nextPut: ('0123456789ABCDEF' at: each \\ 16 + 1)]. 31482 ^ result! ! 31483 31484 31485!ByteArray methodsFor: 'platform independent access' stamp: 'jmb 12/3/2004 14:54'! 31486doubleAt: index bigEndian: bool 31487 "Return a 64 bit float starting from the given byte index" 31488 | w1 w2 dbl | 31489 w1 := self unsignedLongAt: index bigEndian: bool. 31490 w2 := self unsignedLongAt: index + 4 bigEndian: bool. 31491 dbl := Float new: 2. 31492 bool 31493 ifTrue: [dbl basicAt: 1 put: w1. 31494 dbl basicAt: 2 put: w2] 31495 ifFalse: [dbl basicAt: 1 put: w2. 31496 dbl basicAt: 2 put: w1]. 31497 ^ dbl! ! 31498 31499!ByteArray methodsFor: 'platform independent access' stamp: 'jmb 12/3/2004 14:54'! 31500doubleAt: index put: value bigEndian: bool 31501 "Store a 64 bit float starting from the given byte index" 31502 | w1 w2 | 31503 bool 31504 ifTrue: [w1 := value basicAt: 1. 31505 w2 := value basicAt: 2] 31506 ifFalse: [w1 := value basicAt: 2. 31507 w2 := value basicAt: 1]. 31508 self unsignedLongAt: index put: w1 bigEndian: bool. 31509 self unsignedLongAt: index + 4 put: w2 bigEndian: bool. 31510 ^ value! ! 31511 31512!ByteArray methodsFor: 'platform independent access' stamp: 'SergeStinckwich 2/19/2009 13:33'! 31513floatAt: index bigEndian: boolean 31514 ^ Float 31515 fromIEEE32Bit: (self unsignedLongAt: index bigEndian: boolean)! ! 31516 31517!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:44'! 31518longAt: index bigEndian: aBool 31519 "Return a 32bit integer quantity starting from the given byte index" 31520 | b0 b1 b2 w h | 31521 aBool ifTrue:[ 31522 b0 := self at: index. 31523 b1 := self at: index+1. 31524 b2 := self at: index+2. 31525 w := self at: index+3. 31526 ] ifFalse:[ 31527 w := self at: index. 31528 b2 := self at: index+1. 31529 b1 := self at: index+2. 31530 b0 := self at: index+3. 31531 ]. 31532 "Minimize LargeInteger arithmetic" 31533 h := ((b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80) bitShift: 8) + b1. 31534 b2 = 0 ifFalse:[w := (b2 bitShift: 8) + w]. 31535 h = 0 ifFalse:[w := (h bitShift: 16) + w]. 31536 ^w! ! 31537 31538!ByteArray methodsFor: 'platform independent access' stamp: 'ar 8/2/2003 19:29'! 31539longAt: index put: value bigEndian: aBool 31540 "Return a 32bit integer quantity starting from the given byte index" 31541 | b0 b1 b2 b3 | 31542 b0 := value bitShift: -24. 31543 b0 := (b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80). 31544 b0 < 0 ifTrue:[b0 := 256 + b0]. 31545 b1 := (value bitShift: -16) bitAnd: 255. 31546 b2 := (value bitShift: -8) bitAnd: 255. 31547 b3 := value bitAnd: 255. 31548 aBool ifTrue:[ 31549 self at: index put: b0. 31550 self at: index+1 put: b1. 31551 self at: index+2 put: b2. 31552 self at: index+3 put: b3. 31553 ] ifFalse:[ 31554 self at: index put: b3. 31555 self at: index+1 put: b2. 31556 self at: index+2 put: b1. 31557 self at: index+3 put: b0. 31558 ]. 31559 ^value! ! 31560 31561!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:57'! 31562shortAt: index bigEndian: aBool 31563 "Return a 16 bit integer quantity starting from the given byte index" 31564 | uShort | 31565 uShort := self unsignedShortAt: index bigEndian: aBool. 31566 ^(uShort bitAnd: 16r7FFF) - (uShort bitAnd: 16r8000)! ! 31567 31568!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/3/1998 14:20'! 31569shortAt: index put: value bigEndian: aBool 31570 "Store a 16 bit integer quantity starting from the given byte index" 31571 self unsignedShortAt: index put: (value bitAnd: 16r7FFF) - (value bitAnd: -16r8000) bigEndian: aBool. 31572 ^value! ! 31573 31574!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:49'! 31575unsignedLongAt: index bigEndian: aBool 31576 "Return a 32bit unsigned integer quantity starting from the given byte index" 31577 | b0 b1 b2 w | 31578 aBool ifTrue:[ 31579 b0 := self at: index. 31580 b1 := self at: index+1. 31581 b2 := self at: index+2. 31582 w := self at: index+3. 31583 ] ifFalse:[ 31584 w := self at: index. 31585 b2 := self at: index+1. 31586 b1 := self at: index+2. 31587 b0 := self at: index+3. 31588 ]. 31589 "Minimize LargeInteger arithmetic" 31590 b2 = 0 ifFalse:[w := (b2 bitShift: 8) + w]. 31591 b1 = 0 ifFalse:[w := (b1 bitShift: 16) + w]. 31592 b0 = 0 ifFalse:[w := (b0 bitShift: 24) + w]. 31593 ^w! ! 31594 31595!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:49'! 31596unsignedLongAt: index put: value bigEndian: aBool 31597 "Store a 32bit unsigned integer quantity starting from the given byte index" 31598 | b0 b1 b2 b3 | 31599 b0 := value bitShift: -24. 31600 b1 := (value bitShift: -16) bitAnd: 255. 31601 b2 := (value bitShift: -8) bitAnd: 255. 31602 b3 := value bitAnd: 255. 31603 aBool ifTrue:[ 31604 self at: index put: b0. 31605 self at: index+1 put: b1. 31606 self at: index+2 put: b2. 31607 self at: index+3 put: b3. 31608 ] ifFalse:[ 31609 self at: index put: b3. 31610 self at: index+1 put: b2. 31611 self at: index+2 put: b1. 31612 self at: index+3 put: b0. 31613 ]. 31614 ^value! ! 31615 31616!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:51'! 31617unsignedShortAt: index bigEndian: aBool 31618 "Return a 16 bit unsigned integer quantity starting from the given byte index" 31619 ^aBool 31620 ifTrue:[((self at: index) bitShift: 8) + (self at: index+1)] 31621 ifFalse:[((self at: index+1) bitShift: 8) + (self at: index)].! ! 31622 31623!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:53'! 31624unsignedShortAt: index put: value bigEndian: aBool 31625 "Store a 16 bit unsigned integer quantity starting from the given byte index" 31626 aBool ifTrue:[ 31627 self at: index put: (value bitShift: -8). 31628 self at: index+1 put: (value bitAnd: 255). 31629 ] ifFalse:[ 31630 self at: index+1 put: (value bitShift: -8). 31631 self at: index put: (value bitAnd: 255). 31632 ]. 31633 ^value! ! 31634 31635 31636!ByteArray methodsFor: 'printing' stamp: 'stephane.ducasse 2/1/2009 22:39'! 31637printOn: aStream 31638 31639 aStream nextPutAll: '#['. 31640 self 31641 do: [ :each | each printOn: aStream ] 31642 separatedBy: [ aStream nextPut: $ ]. 31643 aStream nextPut: $]! ! 31644 31645!ByteArray methodsFor: 'printing' stamp: 'stephane.ducasse 2/1/2009 22:40'! 31646storeOn: aStream 31647 aStream nextPutAll: '#['. 31648 self 31649 do: [ :each | each storeOn: aStream ] 31650 separatedBy: [ aStream nextPut: $ ]. 31651 aStream nextPut: $]! ! 31652 31653 31654!ByteArray methodsFor: 'testing' stamp: 'stephane.ducasse 2/1/2009 23:10'! 31655isLiteral 31656 "so that #(1 #[1 2 3] 5) prints itself" 31657 ^ true! ! 31658 31659 31660!ByteArray methodsFor: 'zip archive' stamp: 'nk 8/21/2004 15:23'! 31661lastIndexOfPKSignature: aSignature 31662 "Answer the last index in me where aSignature (4 bytes long) occurs, or 0 if not found" 31663 | a b c d | 31664 a := aSignature first. 31665 b := aSignature second. 31666 c := aSignature third. 31667 d := aSignature fourth. 31668 (self size - 3) to: 1 by: -1 do: [ :i | 31669 (((self at: i) = a) 31670 and: [ ((self at: i + 1) = b) 31671 and: [ ((self at: i + 2) = c) 31672 and: [ ((self at: i + 3) = d) ]]]) 31673 ifTrue: [ ^i ] 31674 ]. 31675 ^0! ! 31676 31677 31678!ByteArray methodsFor: 'private' stamp: 'ar 1/28/2000 17:45'! 31679asByteArrayPointer 31680 "Return a ByteArray describing a pointer to the contents of the receiver." 31681 ^self shouldNotImplement! ! 31682 31683!ByteArray methodsFor: 'private'! 31684defaultElement 31685 31686 ^0! ! 31687 31688!ByteArray methodsFor: 'private'! 31689replaceFrom: start to: stop with: replacement startingAt: repStart 31690 "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." 31691 <primitive: 105> 31692 super replaceFrom: start to: stop with: replacement startingAt: repStart! ! 31693 31694"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 31695 31696ByteArray class 31697 instanceVariableNames: ''! 31698 31699!ByteArray class methodsFor: 'byte based hash' stamp: 'SqR 8/21/2002 16:21'! 31700hashBytes: aByteArray startingWith: speciesHash 31701 "Answer the hash of a byte-indexed collection, 31702 using speciesHash as the initial value. 31703 See SmallInteger>>hashMultiply. 31704 31705 The primitive should be renamed at a 31706 suitable point in the future" 31707 31708 | byteArraySize hash low | 31709 <primitive: 'primitiveStringHash' module: 'MiscPrimitivePlugin'> 31710 31711 self var: #aHash declareC: 'int speciesHash'. 31712 self var: #aByteArray declareC: 'unsigned char *aByteArray'. 31713 31714 byteArraySize := aByteArray size. 31715 hash := speciesHash bitAnd: 16rFFFFFFF. 31716 1 to: byteArraySize do: [:pos | 31717 hash := hash + (aByteArray basicAt: pos). 31718 "Begin hashMultiply" 31719 low := hash bitAnd: 16383. 31720 hash := (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF. 31721 ]. 31722 ^ hash! ! 31723TestCase subclass: #ByteArrayBugz 31724 instanceVariableNames: '' 31725 classVariableNames: '' 31726 poolDictionaries: '' 31727 category: 'Tests-Bugs'! 31728 31729!ByteArrayBugz methodsFor: 'as yet unclassified' stamp: 'ar 8/2/2003 19:28'! 31730testByteArrayLongAt 31731 | ba value | 31732 ba := ByteArray new: 4. 31733 value := -1. 31734 self shouldnt:[ba longAt: 1 put: value bigEndian: true] raise: Error. 31735 self assert: (ba longAt: 1 bigEndian: true) = value. 31736 self shouldnt:[ba longAt: 1 put: value bigEndian: false] raise: Error. 31737 self assert: (ba longAt: 1 bigEndian: false) = value. 31738! ! 31739TestCase subclass: #ByteArrayTest 31740 instanceVariableNames: '' 31741 classVariableNames: '' 31742 poolDictionaries: '' 31743 category: 'CollectionsTests-Arrayed'! 31744 31745!ByteArrayTest methodsFor: 'as yet unclassified' stamp: 'SergeStinckwich 2/19/2009 13:31'! 31746testFourthByteArraysReturnTheCorrectValues 31747 31748self assert: [(#(16r3F 16r80 0 0) asByteArray floatAt:1 bigEndian: true) = 1.0]. 31749self assert: [(#(16rC0 0 0 0) asByteArray floatAt:1 bigEndian: true) = -2.0]. 31750 31751! ! 31752String variableByteSubclass: #ByteString 31753 instanceVariableNames: '' 31754 classVariableNames: '' 31755 poolDictionaries: '' 31756 category: 'Collections-Strings'! 31757!ByteString commentStamp: '<historical>' prior: 0! 31758This class represents the array of 8 bit wide characters. 31759! 31760 31761 31762!ByteString methodsFor: 'accessing' stamp: 'yo 8/26/2002 20:33'! 31763at: index 31764 "Primitive. Answer the Character stored in the field of the receiver 31765 indexed by the argument. Fail if the index argument is not an Integer or 31766 is out of bounds. Essential. See Object documentation whatIsAPrimitive." 31767 31768 <primitive: 63> 31769 ^ Character value: (super at: index)! ! 31770 31771!ByteString methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:33'! 31772at: index put: aCharacter 31773 "Primitive. Store the Character in the field of the receiver indicated by 31774 the index. Fail if the index is not an Integer or is out of bounds, or if 31775 the argument is not a Character. Essential. See Object documentation 31776 whatIsAPrimitive." 31777 31778 <primitive: 64> 31779 aCharacter isCharacter 31780 ifFalse:[^self errorImproperStore]. 31781 aCharacter isOctetCharacter ifFalse:[ 31782 "Convert to WideString" 31783 self becomeForward: (WideString from: self). 31784 ^self at: index put: aCharacter. 31785 ]. 31786 index isInteger 31787 ifTrue: [self errorSubscriptBounds: index] 31788 ifFalse: [self errorNonIntegerIndex]! ! 31789 31790!ByteString methodsFor: 'accessing' stamp: 'ar 12/27/1999 13:44'! 31791byteAt: index 31792 <primitive: 60> 31793 ^(self at: index) asciiValue! ! 31794 31795!ByteString methodsFor: 'accessing' stamp: 'ar 12/27/1999 13:44'! 31796byteAt: index put: value 31797 <primitive: 61> 31798 self at: index put: value asCharacter. 31799 ^value! ! 31800 31801!ByteString methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:17'! 31802byteSize 31803 ^self size! ! 31804 31805!ByteString methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:33'! 31806replaceFrom: start to: stop with: replacement startingAt: repStart 31807 "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." 31808 <primitive: 105> 31809 replacement class == WideString ifTrue: [ 31810 self becomeForward: (WideString from: self). 31811 ]. 31812 31813 super replaceFrom: start to: stop with: replacement startingAt: repStart. 31814! ! 31815 31816 31817!ByteString methodsFor: 'comparing' stamp: 'nice 3/23/2007 00:50'! 31818beginsWith: prefix 31819 "Answer whether the receiver begins with the given prefix string. 31820 The comparison is case-sensitive." 31821 31822 31823 "IMPLEMENTATION NOTE: 31824 following algorithm is optimized in primitive only in case self and prefix are bytes like. 31825 Otherwise, if self is wide, then super outperforms, 31826 Otherwise, if prefix is wide, primitive is not correct" 31827 31828 prefix class isBytes ifFalse: [^super beginsWith: prefix]. 31829 31830 self size < prefix size ifTrue: [^ false]. 31831 ^ (self findSubstring: prefix in: self startingAt: 1 31832 matchTable: CaseSensitiveOrder) = 1 31833! ! 31834 31835!ByteString methodsFor: 'comparing' stamp: 'JMM 10/30/2006 15:58'! 31836findSubstring: key in: body startingAt: start matchTable: matchTable 31837 key isWideString ifTrue: [^super findSubstring: key in: body startingAt: start matchTable: matchTable]. 31838 ^self findSubstringViaPrimitive: key in: body startingAt: start matchTable: matchTable! ! 31839 31840!ByteString methodsFor: 'comparing' stamp: 'JMM 10/30/2006 15:57'! 31841findSubstringViaPrimitive: key in: body startingAt: start matchTable: matchTable 31842 "Answer the index in the string body at which the substring key first occurs, at or beyond start. The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches. If no match is found, zero will be returned. 31843 31844 The algorithm below is not optimum -- it is intended to be translated to C which will go so fast that it wont matter." 31845 | index | 31846 <primitive: 'primitiveFindSubstring' module: 'MiscPrimitivePlugin'> 31847 self var: #key declareC: 'unsigned char *key'. 31848 self var: #body declareC: 'unsigned char *body'. 31849 self var: #matchTable declareC: 'unsigned char *matchTable'. 31850 31851 key size = 0 ifTrue: [^ 0]. 31852 start to: body size - key size + 1 do: 31853 [:startIndex | 31854 index := 1. 31855 [(matchTable at: (body at: startIndex+index-1) asciiValue + 1) 31856 = (matchTable at: (key at: index) asciiValue + 1)] 31857 whileTrue: 31858 [index = key size ifTrue: [^ startIndex]. 31859 index := index+1]]. 31860 ^ 0 31861" 31862' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 1 matchTable: CaseSensitiveOrder 1 31863' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 2 matchTable: CaseSensitiveOrder 7 31864' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 8 matchTable: CaseSensitiveOrder 0 31865' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseSensitiveOrder 0 31866' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseInsensitiveOrder 7 31867"! ! 31868 31869 31870!ByteString methodsFor: 'converting' stamp: 'ar 4/10/2005 17:20'! 31871asByteArray 31872 | ba sz | 31873 sz := self byteSize. 31874 ba := ByteArray new: sz. 31875 ba replaceFrom: 1 to: sz with: self startingAt: 1. 31876 ^ba! ! 31877 31878!ByteString methodsFor: 'converting' stamp: 'yo 8/28/2002 16:52'! 31879asOctetString 31880 31881 ^ self. 31882! ! 31883 31884!ByteString methodsFor: 'converting' stamp: 'yo 11/11/2002 12:20'! 31885convertFromCompoundText 31886 31887 | readStream writeStream converter | 31888 readStream := self readStream. 31889 writeStream := String new writeStream. 31890 converter := CompoundTextConverter new. 31891 converter ifNil: [^ self]. 31892 [readStream atEnd] whileFalse: [ 31893 writeStream nextPut: (converter nextFromStream: readStream)]. 31894 ^ writeStream contents 31895! ! 31896 31897!ByteString methodsFor: 'converting' stamp: 'mir 7/20/2004 15:50'! 31898convertFromSystemString 31899 31900 | readStream writeStream converter | 31901 readStream := self readStream. 31902 writeStream := String new writeStream. 31903 converter := LanguageEnvironment defaultSystemConverter. 31904 converter ifNil: [^ self]. 31905 [readStream atEnd] whileFalse: [ 31906 writeStream nextPut: (converter nextFromStream: readStream)]. 31907 ^ writeStream contents 31908! ! 31909 31910 31911!ByteString methodsFor: 'testing' stamp: 'ar 4/10/2005 18:04'! 31912isByteString 31913 "Answer whether the receiver is a ByteString" 31914 ^true! ! 31915 31916!ByteString methodsFor: 'testing' stamp: 'ar 4/10/2005 17:28'! 31917isOctetString 31918 "Answer whether the receiver can be represented as a byte string. 31919 This is different from asking whether the receiver *is* a ByteString 31920 (i.e., #isByteString)" 31921 ^ true. 31922! ! 31923 31924"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 31925 31926ByteString class 31927 instanceVariableNames: ''! 31928 31929!ByteString class methodsFor: 'primitives' stamp: 'yo 12/15/2005 13:44'! 31930compare: string1 with: string2 collated: order 31931 "Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array." 31932 31933 | len1 len2 c1 c2 | 31934 <primitive: 'primitiveCompareString' module: 'MiscPrimitivePlugin'> 31935 self var: #string1 declareC: 'unsigned char *string1'. 31936 self var: #string2 declareC: 'unsigned char *string2'. 31937 self var: #order declareC: 'unsigned char *order'. 31938 31939 len1 := string1 size. 31940 len2 := string2 size. 31941 1 to: (len1 min: len2) do: 31942 [:i | 31943 c1 := order at: (string1 basicAt: i) + 1. 31944 c2 := order at: (string2 basicAt: i) + 1. 31945 c1 = c2 ifFalse: 31946 [c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]]]. 31947 len1 = len2 ifTrue: [^ 2]. 31948 len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3]. 31949! ! 31950 31951!ByteString class methodsFor: 'primitives' stamp: 'ar 2/3/2001 16:12'! 31952findFirstInString: aString inSet: inclusionMap startingAt: start 31953 | i stringSize | 31954 <primitive: 'primitiveFindFirstInString' module: 'MiscPrimitivePlugin'> 31955 self var: #aString declareC: 'unsigned char *aString'. 31956 self var: #inclusionMap declareC: 'char *inclusionMap'. 31957 31958 inclusionMap size ~= 256 ifTrue: [ ^0 ]. 31959 31960 i := start. 31961 stringSize := aString size. 31962 [ i <= stringSize and: [ (inclusionMap at: (aString at: i) asciiValue+1) = 0 ] ] whileTrue: [ 31963 i := i + 1 ]. 31964 31965 i > stringSize ifTrue: [ ^0 ]. 31966 ^i! ! 31967 31968!ByteString class methodsFor: 'primitives' stamp: 'ar 2/3/2001 16:13'! 31969indexOfAscii: anInteger inString: aString startingAt: start 31970 31971 | stringSize | 31972 <primitive: 'primitiveIndexOfAsciiInString' module: 'MiscPrimitivePlugin'> 31973 31974 self var: #aCharacter declareC: 'int anInteger'. 31975 self var: #aString declareC: 'unsigned char *aString'. 31976 31977 stringSize := aString size. 31978 start to: stringSize do: [:pos | 31979 (aString at: pos) asciiValue = anInteger ifTrue: [^ pos]]. 31980 31981 ^ 0 31982! ! 31983 31984!ByteString class methodsFor: 'primitives' stamp: 'ar 9/28/2001 04:35'! 31985stringHash: aString initialHash: speciesHash 31986 31987 | stringSize hash low | 31988 <primitive: 'primitiveStringHash' module: 'MiscPrimitivePlugin'> 31989 31990 self var: #aHash declareC: 'int speciesHash'. 31991 self var: #aString declareC: 'unsigned char *aString'. 31992 31993 stringSize := aString size. 31994 hash := speciesHash bitAnd: 16rFFFFFFF. 31995 1 to: stringSize do: [:pos | 31996 hash := hash + (aString at: pos) asciiValue. 31997 "Begin hashMultiply" 31998 low := hash bitAnd: 16383. 31999 hash := (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF. 32000 ]. 32001 ^ hash! ! 32002 32003!ByteString class methodsFor: 'primitives' stamp: 'ar 2/3/2001 16:12'! 32004translate: aString from: start to: stop table: table 32005 "translate the characters in the string by the given table, in place" 32006 <primitive: 'primitiveTranslateStringWithTable' module: 'MiscPrimitivePlugin'> 32007 self var: #table declareC: 'unsigned char *table'. 32008 self var: #aString declareC: 'unsigned char *aString'. 32009 32010 start to: stop do: [ :i | 32011 aString at: i put: (table at: (aString at: i) asciiValue+1) ]! ! 32012Symbol variableByteSubclass: #ByteSymbol 32013 instanceVariableNames: '' 32014 classVariableNames: '' 32015 poolDictionaries: '' 32016 category: 'Collections-Strings'! 32017!ByteSymbol commentStamp: '<historical>' prior: 0! 32018This class represents the symbols containing 8bit characters.! 32019 32020 32021!ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:10'! 32022at: index 32023 "Primitive. Answer the Character stored in the field of the receiver 32024 indexed by the argument. Fail if the index argument is not an Integer or 32025 is out of bounds. Essential. See Object documentation whatIsAPrimitive." 32026 32027 <primitive: 63> 32028 ^ Character value: (super at: index)! ! 32029 32030!ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:10'! 32031byteAt: index 32032 <primitive: 60> 32033 ^(self at: index) asciiValue! ! 32034 32035!ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:10'! 32036byteAt: anInteger put: anObject 32037 "You cannot modify the receiver." 32038 self errorNoModification! ! 32039 32040!ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:11'! 32041byteSize 32042 ^self size! ! 32043 32044!ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:51'! 32045species 32046 "Answer the preferred class for reconstructing the receiver." 32047 ^ByteString 32048! ! 32049 32050 32051!ByteSymbol methodsFor: 'comparing' stamp: 'nice 3/23/2007 00:50'! 32052beginsWith: prefix 32053 "Answer whether the receiver begins with the given prefix string. 32054 The comparison is case-sensitive." 32055 32056 32057 "IMPLEMENTATION NOTE: 32058 following algorithm is optimized in primitive only in case self and prefix are bytes like. 32059 Otherwise, if self is wide, then super outperforms, 32060 Otherwise, if prefix is wide, primitive is not correct" 32061 32062 prefix class isBytes ifFalse: [^super beginsWith: prefix]. 32063 32064 self size < prefix size ifTrue: [^ false]. 32065 ^ (self findSubstring: prefix in: self startingAt: 1 32066 matchTable: CaseSensitiveOrder) = 1 32067! ! 32068 32069!ByteSymbol methodsFor: 'comparing' stamp: 'ar 4/10/2005 22:14'! 32070findSubstring: key in: body startingAt: start matchTable: matchTable 32071 "Answer the index in the string body at which the substring key first occurs, at or beyond start. The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches. If no match is found, zero will be returned." 32072 <primitive: 'primitiveFindSubstring' module: 'MiscPrimitivePlugin'> 32073 ^super findSubstring: key in: body startingAt: start matchTable: matchTable! ! 32074 32075 32076!ByteSymbol methodsFor: 'converting' stamp: 'ar 4/10/2005 22:12'! 32077asByteArray 32078 | ba sz | 32079 sz := self byteSize. 32080 ba := ByteArray new: sz. 32081 ba replaceFrom: 1 to: sz with: self startingAt: 1. 32082 ^ba! ! 32083 32084!ByteSymbol methodsFor: 'converting' stamp: 'ar 4/10/2005 22:12'! 32085asOctetString 32086 ^ self! ! 32087 32088 32089!ByteSymbol methodsFor: 'testing' stamp: 'ar 4/10/2005 22:14'! 32090isByteString 32091 "Answer whether the receiver is a ByteString" 32092 ^true! ! 32093 32094!ByteSymbol methodsFor: 'testing' stamp: 'ar 4/10/2005 22:14'! 32095isOctetString 32096 "Answer whether the receiver can be represented as a byte string. 32097 This is different from asking whether the receiver *is* a ByteString 32098 (i.e., #isByteString)" 32099 ^ true. 32100! ! 32101 32102 32103!ByteSymbol methodsFor: 'private' stamp: 'ar 4/11/2005 00:08'! 32104pvtAt: index put: aCharacter 32105 "Primitive. Store the Character in the field of the receiver indicated by 32106 the index. Fail if the index is not an Integer or is out of bounds, or if 32107 the argument is not a Character. Essential. See Object documentation 32108 whatIsAPrimitive." 32109 32110 <primitive: 64> 32111 aCharacter isCharacter 32112 ifFalse:[^self errorImproperStore]. 32113 index isInteger 32114 ifTrue: [self errorSubscriptBounds: index] 32115 ifFalse: [self errorNonIntegerIndex]! ! 32116 32117!ByteSymbol methodsFor: 'private' stamp: 'ar 4/10/2005 23:02'! 32118string: aString 32119 1 to: aString size do: [:j | self pvtAt: j put: (aString at: j)]. 32120 ^self! ! 32121 32122"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 32123 32124ByteSymbol class 32125 instanceVariableNames: ''! 32126 32127!ByteSymbol class methodsFor: 'primitives' stamp: 'ar 8/18/2005 13:46'! 32128findFirstInString: aString inSet: inclusionMap startingAt: start 32129 ^ByteString findFirstInString: aString inSet: inclusionMap startingAt: start! ! 32130 32131!ByteSymbol class methodsFor: 'primitives' stamp: 'ar 8/18/2005 13:46'! 32132indexOfAscii: anInteger inString: aString startingAt: start 32133 ^ByteString indexOfAscii: anInteger inString: aString startingAt: start! ! 32134 32135!ByteSymbol class methodsFor: 'primitives' stamp: 'ar 8/18/2005 13:46'! 32136stringHash: aString initialHash: speciesHash 32137 ^ByteString stringHash: aString initialHash: speciesHash! ! 32138 32139!ByteSymbol class methodsFor: 'primitives' stamp: 'ar 8/18/2005 13:47'! 32140translate: aString from: start to: stop table: table 32141 ^ByteString translate: aString from: start to: stop table: table! ! 32142TextConverter subclass: #ByteTextConverter 32143 instanceVariableNames: '' 32144 classVariableNames: '' 32145 poolDictionaries: 'EventSensorConstants' 32146 category: 'Multilingual-TextConversion'! 32147!ByteTextConverter commentStamp: 'michael.rueger 1/27/2009 18:00' prior: 0! 32148A ByteTextConverter is the abstract class for text converters on single byte encodings.! 32149 32150 32151!ByteTextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:11'! 32152byteToUnicode: char 32153 "Map from my byte based encoding to unicode. 32154 Due to the leading char encoding this is not strictly true, but hopefully at some point we can get rid of the leading char overhead." 32155 | value | 32156 value := char charCode. 32157 32158 value < 128 32159 ifTrue: [^ char]. 32160 value > 255 32161 ifTrue: [^ char]. 32162 ^self class byteToUnicodeTable at: (value - 128 + 1)! ! 32163 32164!ByteTextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:11'! 32165nextFromStream: aStream 32166 "Read the next byte (we are only dealing with byte based encodings here) character from aStream and return the result converted to unicode." 32167 32168 | byteOrChar | 32169 byteOrChar := aStream basicNext. 32170 aStream isBinary 32171 ifTrue: [^byteOrChar]. 32172 ^byteOrChar 32173 ifNotNil: [self byteToUnicode: byteOrChar]! ! 32174 32175!ByteTextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:10'! 32176nextPut: unicodeCharacter toStream: aStream 32177 "Write the unicode character to aStream." 32178 32179 aStream isBinary 32180 ifTrue: [aStream basicNextPut: unicodeCharacter charCode] 32181 ifFalse: [aStream basicNextPut: (self unicodeToByte: unicodeCharacter)]! ! 32182 32183!ByteTextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:10'! 32184unicodeToByte: unicodeChar 32185 32186 ^unicodeChar charCode < 128 32187 ifTrue: [unicodeChar] 32188 ifFalse: [self class unicodeToByteTable at: unicodeChar charCode ifAbsent: [0 asCharacter]]! ! 32189 32190"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 32191 32192ByteTextConverter class 32193 instanceVariableNames: 'byteToUnicode unicodeToByte'! 32194 32195!ByteTextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/5/2009 14:10'! 32196byteToUnicodeTable 32197 "Return the table mapping from my byte based encoding to unicode" 32198 ^byteToUnicode! ! 32199 32200!ByteTextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 1/30/2009 11:01'! 32201languageEnvironment 32202 self subclassResponsibility! ! 32203 32204!ByteTextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/5/2009 14:10'! 32205unicodeToByteTable 32206 "Return the table mapping from unicode to my byte based encoding" 32207 ^unicodeToByte! ! 32208 32209 32210!ByteTextConverter class methodsFor: 'class initialization' stamp: 'michael.rueger 2/5/2009 14:06'! 32211byteToUnicodeSpec 32212 "Sepcify a table mapping the entries 0x80 to 0xFF to their unicode counterparts by returning a 128 element array.. 32213 The entries 0x00 to 0x7F map to identical values so we don't need to specify them." 32214 32215 self subclassResponsibility! ! 32216 32217!ByteTextConverter class methodsFor: 'class initialization' stamp: 'michael.rueger 1/27/2009 18:40'! 32218initialize 32219 "ByteTextConverter initialize" 32220 32221 self allSubclassesDo: [:subclass | 32222 subclass initializeTables]! ! 32223 32224!ByteTextConverter class methodsFor: 'class initialization' stamp: 'nice 7/26/2009 22:37'! 32225initializeTables 32226 "Initialize the mappings to and from unicode." 32227 32228 | byteToUnicodeSpec leadingChar | 32229 byteToUnicodeSpec := self byteToUnicodeSpec. 32230 32231 leadingChar := self languageEnvironment leadingChar. 32232 byteToUnicode := byteToUnicodeSpec collect: [:charValue | 32233 Character leadingChar: leadingChar code: charValue]. 32234 32235 unicodeToByte := Dictionary new. 32236 "Mind the offset because first 128 characters are not stored into byteToUnicodeSpec" 32237 byteToUnicodeSpec keysAndValuesDo: [:byteEntry :unicodeEntry | 32238 unicodeToByte at: unicodeEntry put: (127 + byteEntry) asCharacter]! ! 32239TestCase subclass: #ByteTextConverterTest 32240 instanceVariableNames: '' 32241 classVariableNames: '' 32242 poolDictionaries: '' 32243 category: 'MultilingualTests-TextConversion'! 32244 32245!ByteTextConverterTest methodsFor: 'testing' stamp: 'nice 7/26/2009 22:44'! 32246testConversionToFrom 32247 "Non regresson test for http://code.google.com/p/pharo/issues/detail?id=986" 32248 32249 self assert: (('äöü' convertToEncoding: 'mac-roman') convertFromEncoding: 'mac-roman') = 'äöü'! ! 32250MethodNode subclass: #BytecodeAgnosticMethodNode 32251 instanceVariableNames: 'locationCounter localsPool' 32252 classVariableNames: '' 32253 poolDictionaries: '' 32254 category: 'Compiler-ParseNodes'! 32255!BytecodeAgnosticMethodNode commentStamp: '<historical>' prior: 0! 32256I am a version of MethodNode that is able to work with different BytecodeEncoders, and is hence able to generate methods using different bytecode sets.! 32257]style[(151)i! 32258 32259 32260!BytecodeAgnosticMethodNode methodsFor: 'code generation (closures)' stamp: 'eem 5/29/2008 15:27'! 32261addLocalsToPool: locals "<Set of: TempVariableNode>" 32262 localsPool isNil ifTrue: 32263 [localsPool := IdentitySet new]. 32264 localsPool addAll: locals! ! 32265 32266!BytecodeAgnosticMethodNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2008 10:04'! 32267ensureClosureAnalysisDone 32268 block blockExtent ifNil: 32269 [temporaries := block analyseArguments: arguments temporaries: temporaries rootNode: self]! ! 32270 32271!BytecodeAgnosticMethodNode methodsFor: 'code generation (closures)' stamp: 'eem 5/20/2008 13:43'! 32272locationCounter 32273 ^locationCounter! ! 32274 32275!BytecodeAgnosticMethodNode methodsFor: 'code generation (closures)' stamp: 'eem 5/30/2008 11:27'! 32276noteBlockEntry: aBlock 32277 "Evaluate aBlock with the numbering for the block entry." 32278 locationCounter isNil ifTrue: 32279 [locationCounter := -1]. 32280 aBlock value: locationCounter + 1. 32281 locationCounter := locationCounter + 2! ! 32282 32283!BytecodeAgnosticMethodNode methodsFor: 'code generation (closures)' stamp: 'eem 6/2/2008 12:12'! 32284noteBlockExit: aBlock 32285 "Evaluate aBlock with the numbering for the block exit." 32286 aBlock value: locationCounter + 1. 32287 locationCounter := locationCounter + 2! ! 32288 32289!BytecodeAgnosticMethodNode methodsFor: 'code generation (closures)' stamp: 'eem 5/29/2008 16:07'! 32290referencedValuesWithinBlockExtent: anInterval 32291 ^(localsPool select: 32292 [:temp| 32293 temp isReferencedWithinBlockExtent: anInterval]) collect: 32294 [:temp| 32295 temp isRemote ifTrue: [temp remoteNode] ifFalse: [temp]]! ! 32296 32297 32298!BytecodeAgnosticMethodNode methodsFor: 'code generation (new scheme)' stamp: 'eem 12/1/2008 13:48'! 32299generate: trailer 32300 "The receiver is the root of a parse tree. Answer a CompiledMethod. 32301 The argument, trailer, is the reference to the source code that is 32302 stored with every CompiledMethod." 32303 32304 | primErrNode blkSize nLits literals stack method | 32305 self generate: trailer ifQuick: 32306 [:m | 32307 m literalAt: 2 put: encoder associationForClass; 32308 properties: properties. 32309 ^m]. 32310 primErrNode := self primitiveErrorVariableName ifNotNil: 32311 [encoder fixTemp: self primitiveErrorVariableName]. 32312 encoder supportsClosureOpcodes ifTrue: 32313 [self ensureClosureAnalysisDone. 32314 encoder rootNode: self. "this is for BlockNode>>sizeCodeForClosureValue:"]. 32315 blkSize := (block sizeCodeForEvaluatedValue: encoder) 32316 + (primErrNode ifNil: [0] ifNotNil: [2 "We force store-long (129)"]). 32317 method := CompiledMethod 32318 newBytes: blkSize 32319 trailerBytes: trailer 32320 nArgs: arguments size 32321 nTemps: (encoder supportsClosureOpcodes 32322 ifTrue: [| locals | 32323 locals := arguments, 32324 temporaries, 32325 (primErrNode 32326 ifNil: [#()] 32327 ifNotNil: [{primErrNode}]). 32328 encoder 32329 noteBlockExtent: block blockExtent 32330 hasLocals: locals. 32331 locals size] 32332 ifFalse: [encoder maxTemp]) 32333 nStack: 0 32334 nLits: (nLits := (literals := encoder allLiterals) size) 32335 primitive: primitive. 32336 nLits > 255 ifTrue: 32337 [^self error: 'Too many literals referenced']. 32338 1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)]. 32339 encoder streamToMethod: method. 32340 stack := ParseStack new init. 32341 primErrNode ifNotNil: [primErrNode emitCodeForStore: stack encoder: encoder]. 32342 stack position: method numTemps. 32343 block emitCodeForEvaluatedValue: stack encoder: encoder. 32344 stack position ~= (method numTemps + 1) ifTrue: 32345 [^self error: 'Compiler stack discrepancy']. 32346 encoder methodStreamPosition ~= (method size - trailer size) ifTrue: 32347 [^self error: 'Compiler code size discrepancy']. 32348 method needsFrameSize: stack size - method numTemps. 32349 method properties: properties. 32350 ^method! ! 32351 32352 32353!BytecodeAgnosticMethodNode methodsFor: 'debugger support' stamp: 'eem 6/5/2009 16:51'! 32354blockExtentsToTempsMap 32355 "Answer a Dictionary of blockExtent to temp locations for the current method. 32356 This is used by the debugger to locate temp vars in contexts. A temp map 32357 entry is a pair of the temp's name and its index, where an index is either an 32358 integer for a normal temp or a pair of the index of the indirect temp vector 32359 containing the temp and the index of the temp in its indirect temp vector." 32360 32361 ^encoder blockExtentsToTempsMap ifNil: 32362 [| methNode | 32363 methNode := encoder classEncoding parserClass new 32364 encoderClass: encoder class; 32365 parse: (sourceText ifNil: [self decompileString]) 32366 class: self methodClass. 32367 "As a side effect generate: creates data needed for the map." 32368 methNode generate: #(0 0 0 0). 32369 methNode encoder blockExtentsToTempsMap]! ! 32370 32371!BytecodeAgnosticMethodNode methodsFor: 'debugger support' stamp: 'eem 7/1/2009 13:45'! 32372hasGeneratedMethod 32373 ^encoder hasGeneratedMethod! ! 32374 32375!BytecodeAgnosticMethodNode methodsFor: 'debugger support' stamp: 'eem 7/6/2009 09:46'! 32376schematicTempNamesString 32377 "Answer the temp names for the current method node in a form that captures 32378 temp structure. The temps at each method and block scope level occur 32379 space-separated, with any indirect temps enclosed in parentheses. Each block 32380 level is enclosed in square brackets. e.g. 32381 'method level temps (indirect temp)[block args and temps (indirect)]' 32382 This representation can be reconstituted into a blockExtentsToTempsMap 32383 by a CompiledMethod that has been copied with the schematicTempNamesString." 32384 encoder hasGeneratedMethod ifFalse: 32385 ["create the encoder's blockExtentsToLoals map, except if the method is quick 32386 in which case it has no temps." 32387 (self generate: #(0 0 0 0)) isQuick ifTrue: 32388 [^'']]. 32389 ^encoder schematicTempNamesString! ! 32390 32391 32392!BytecodeAgnosticMethodNode methodsFor: 'printing' stamp: 'eem 7/24/2008 10:07'! 32393printWithClosureAnalysisOn: aStream 32394 self ensureClosureAnalysisDone. 32395 super printWithClosureAnalysisOn: aStream! ! 32396 32397"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 32398 32399BytecodeAgnosticMethodNode class 32400 instanceVariableNames: ''! 32401Encoder subclass: #BytecodeEncoder 32402 instanceVariableNames: 'stream position rootNode blockExtentsToLocals' 32403 classVariableNames: '' 32404 poolDictionaries: '' 32405 category: 'Compiler-Kernel'! 32406!BytecodeEncoder commentStamp: '<historical>' prior: 0! 32407I am an abstract superclass for different bytecode set encoders. Subclasses inherit the literal management of Encoder and encapsulate the mapping of opcodes to specific bytecodes.! 32408 32409 32410!BytecodeEncoder methodsFor: 'accessing' stamp: 'eem 5/29/2008 09:36'! 32411methodNodeClass 32412 ^BytecodeAgnosticMethodNode! ! 32413 32414!BytecodeEncoder methodsFor: 'accessing' stamp: 'eem 5/14/2008 17:47'! 32415methodStreamPosition 32416 ^stream position! ! 32417 32418!BytecodeEncoder methodsFor: 'accessing' stamp: 'eem 5/24/2008 11:56'! 32419rootNode "^<BlockNode>" 32420 ^rootNode! ! 32421 32422!BytecodeEncoder methodsFor: 'accessing' stamp: 'eem 5/24/2008 11:56'! 32423rootNode: node "<BlockNode>" 32424 rootNode := node! ! 32425 32426 32427!BytecodeEncoder methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:52'! 32428outOfRangeError: string index: index range: rangeStart to: rangeEnd 32429 "For now..." 32430 ^self error: thisContext sender method selector, ' ', string 32431 , ' index ', index printString 32432 , ' is out of range ', rangeStart printString, ' to ', rangeEnd printString! ! 32433 32434 32435!BytecodeEncoder methodsFor: 'initialize-release' stamp: 'eem 7/24/2008 17:24'! 32436streamToMethod: aCompiledMethod 32437 stream := WriteStream with: aCompiledMethod. 32438 stream position: aCompiledMethod initialPC - 1! ! 32439 32440 32441!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 7/27/2008 00:39'! 32442nextPut: aByte 32443 "For sizing make the encoder its own stream and 32444 keep track of position with this version of nextPut:" 32445 position := position + 1! ! 32446 32447!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 18:22'! 32448sizeBranchPopFalse: distance 32449 ^self sizeOpcodeSelector: #genBranchPopFalse: withArguments: {distance}! ! 32450 32451!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 18:22'! 32452sizeBranchPopTrue: distance 32453 ^self sizeOpcodeSelector: #genBranchPopTrue: withArguments: {distance}! ! 32454 32455!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:28'! 32456sizeDup 32457 ^self sizeOpcodeSelector: #genDup withArguments: #()! ! 32458 32459!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:40'! 32460sizeJump: distance 32461 ^self sizeOpcodeSelector: #genJump: withArguments: {distance}! ! 32462 32463!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:40'! 32464sizeJumpLong: distance 32465 ^self sizeOpcodeSelector: #genJumpLong: withArguments: {distance}! ! 32466 32467!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 7/27/2008 00:39'! 32468sizeOpcodeSelector: genSelector withArguments: args 32469 stream := self. 32470 position := 0. 32471 self perform: genSelector withArguments: args. 32472 ^position! ! 32473 32474!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:28'! 32475sizePop 32476 ^self sizeOpcodeSelector: #genPop withArguments: #()! ! 32477 32478!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/30/2008 16:46'! 32479sizePushClosureCopyNumCopiedValues: numCopied numArgs: numArgs jumpSize: jumpSize 32480 ^self 32481 sizeOpcodeSelector: #genPushClosureCopyNumCopiedValues:numArgs:jumpSize: 32482 withArguments: {numCopied. numArgs. jumpSize}! ! 32483 32484!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/30/2008 16:36'! 32485sizePushConsArray: numElements 32486 ^self sizeOpcodeSelector: #genPushConsArray: withArguments: {numElements}! ! 32487 32488!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 16:22'! 32489sizePushInstVar: instVarIndex 32490 ^self sizeOpcodeSelector: #genPushInstVar: withArguments: {instVarIndex}! ! 32491 32492!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 6/19/2008 08:54'! 32493sizePushInstVarLong: instVarIndex 32494 ^self sizeOpcodeSelector: #genPushInstVarLong: withArguments: {instVarIndex}! ! 32495 32496!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:43'! 32497sizePushLiteral: literalIndex 32498 ^self sizeOpcodeSelector: #genPushLiteral: withArguments: {literalIndex}! ! 32499 32500!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:43'! 32501sizePushLiteralVar: literalIndex 32502 ^self sizeOpcodeSelector: #genPushLiteralVar: withArguments: {literalIndex}! ! 32503 32504!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/24/2008 12:35'! 32505sizePushNewArray: size 32506 ^self sizeOpcodeSelector: #genPushNewArray: withArguments: {size}! ! 32507 32508!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 16:21'! 32509sizePushReceiver 32510 ^self sizeOpcodeSelector: #genPushReceiver withArguments: #()! ! 32511 32512!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/24/2008 22:59'! 32513sizePushRemoteTemp: tempIndex inVectorAt: tempVectorIndex 32514 ^self sizeOpcodeSelector: #genPushRemoteTemp:inVectorAt: withArguments: {tempIndex. tempVectorIndex}! ! 32515 32516!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:37'! 32517sizePushSpecialLiteral: specialLiteral 32518 ^self sizeOpcodeSelector: #genPushSpecialLiteral: withArguments: {specialLiteral}! ! 32519 32520!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:26'! 32521sizePushTemp: tempIndex 32522 ^self sizeOpcodeSelector: #genPushTemp: withArguments: {tempIndex}! ! 32523 32524!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:28'! 32525sizePushThisContext 32526 ^self sizeOpcodeSelector: #genPushThisContext withArguments: #()! ! 32527 32528!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/15/2008 09:07'! 32529sizeReturnReceiver 32530 ^self sizeOpcodeSelector: #genReturnReceiver withArguments: #()! ! 32531 32532!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:38'! 32533sizeReturnSpecialLiteral: specialLiteral 32534 ^self sizeOpcodeSelector: #genReturnSpecialLiteral: withArguments: {specialLiteral}! ! 32535 32536!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:34'! 32537sizeReturnTop 32538 ^self sizeOpcodeSelector: #genReturnTop withArguments: #()! ! 32539 32540!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/15/2008 09:06'! 32541sizeReturnTopToCaller 32542 ^self sizeOpcodeSelector: #genReturnTopToCaller withArguments: #()! ! 32543 32544!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 16:11'! 32545sizeSend: selectorLiteralIndex numArgs: nArgs 32546 ^self sizeOpcodeSelector: #genSend:numArgs: withArguments: {selectorLiteralIndex. nArgs}! ! 32547 32548!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 16:11'! 32549sizeSendSuper: selectorLiteralIndex numArgs: nArgs 32550 ^self sizeOpcodeSelector: #genSendSuper:numArgs: withArguments: {selectorLiteralIndex. nArgs}! ! 32551 32552!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:44'! 32553sizeStoreInstVar: instVarIndex 32554 ^self sizeOpcodeSelector: #genStoreInstVar: withArguments: {instVarIndex}! ! 32555 32556!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 6/19/2008 08:54'! 32557sizeStoreInstVarLong: instVarIndex 32558 ^self sizeOpcodeSelector: #genStoreInstVarLong: withArguments: {instVarIndex}! ! 32559 32560!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:43'! 32561sizeStoreLiteralVar: literalIndex 32562 ^self sizeOpcodeSelector: #genStoreLiteralVar: withArguments: {literalIndex}! ! 32563 32564!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/15/2008 10:00'! 32565sizeStorePopInstVar: instVarIndex 32566 ^self sizeOpcodeSelector: #genStorePopInstVar: withArguments: {instVarIndex}! ! 32567 32568!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 6/19/2008 08:54'! 32569sizeStorePopInstVarLong: instVarIndex 32570 ^self sizeOpcodeSelector: #genStorePopInstVarLong: withArguments: {instVarIndex}! ! 32571 32572!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/15/2008 10:20'! 32573sizeStorePopLiteralVar: literalIndex 32574 ^self sizeOpcodeSelector: #genStorePopLiteralVar: withArguments: {literalIndex}! ! 32575 32576!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/24/2008 23:02'! 32577sizeStorePopRemoteTemp: tempIndex inVectorAt: tempVectorIndex 32578 ^self sizeOpcodeSelector: #genStorePopRemoteTemp:inVectorAt: withArguments: {tempIndex. tempVectorIndex}! ! 32579 32580!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:36'! 32581sizeStorePopTemp: tempIndex 32582 ^self sizeOpcodeSelector: #genStorePopTemp: withArguments: {tempIndex}! ! 32583 32584!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/24/2008 23:02'! 32585sizeStoreRemoteTemp: tempIndex inVectorAt: tempVectorIndex 32586 ^self sizeOpcodeSelector: #genStoreRemoteTemp:inVectorAt: withArguments: {tempIndex. tempVectorIndex}! ! 32587 32588!BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:45'! 32589sizeStoreTemp: tempIndex 32590 ^self sizeOpcodeSelector: #genStoreTemp: withArguments: {tempIndex}! ! 32591 32592 32593!BytecodeEncoder methodsFor: 'special literal encodings' stamp: 'eem 5/14/2008 16:02'! 32594if: code isSpecialLiteralForPush: aBlock 32595 "If code is that of a special literal for push then evaluate aBlock with the special literal 32596 The special literals for push are nil true false -1 0 1 & 2 which have special encodings 32597 in the blue book bytecode set. Answer whether it was a special literal." 32598 ^(code between: LdTrue and: LdNil + 4) 32599 and: [aBlock value: (#(true false nil -1 0 1 2) at: code - LdSelf). 32600 true]! ! 32601 32602!BytecodeEncoder methodsFor: 'special literal encodings' stamp: 'eem 5/14/2008 17:49'! 32603if: code isSpecialLiteralForReturn: aBlock 32604 "If code is that of a special literal for return then evaluate aBlock with the special literal. 32605 The special literals for return are nil true false which have special encodings 32606 in the blue book bytecode set. Answer whether it was a special literal." 32607 ^(code between: LdTrue and: LdNil) 32608 and: [aBlock value: (#(true false nil) at: code - LdSelf). 32609 true]! ! 32610 32611 32612!BytecodeEncoder methodsFor: 'temps' stamp: 'eem 6/23/2008 10:55'! 32613bindAndJuggle: name 32614 "This is used to insert a new temp and reorcder temps on editing. 32615 It doesn't really work for closure compilation since we have multiple 32616 locations for temps. Simply signal a reparse is necessary." 32617 32618 ReparseAfterSourceEditing signal! ! 32619 32620!BytecodeEncoder methodsFor: 'temps' stamp: 'eem 9/8/2008 18:24'! 32621bindBlockArg: name within: aBlockNode 32622 "Read the comment in the superclass's method. 32623 If we have closures we should check the argument 32624 count against the block, not the method. 32625 32626 (Note that this isn't entirely adequate either since optimized blocks 32627 will slip through the cracks (their arguments (i.e. ifNotNil: [:expr|) 32628 are charged against their enclosing block, not themselves))." 32629 | nArgs | 32630 self supportsClosureOpcodes ifFalse: 32631 [^super bindBlockArg: name within: aBlockNode]. 32632 (nArgs := aBlockNode nArgsSlot) isNil ifTrue: 32633 [aBlockNode nArgsSlot: (nArgs := 0)]. 32634 nArgs >= 15 ifTrue: 32635 [^self notify: 'Too many arguments']. 32636 aBlockNode nArgsSlot: nArgs + 1. 32637 ^(self bindTemp: name) 32638 beBlockArg; 32639 nowHasDef; 32640 nowHasRef; 32641 yourself! ! 32642 32643!BytecodeEncoder methodsFor: 'temps' stamp: 'eem 5/30/2008 14:35'! 32644bindBlockTemp: name within: aBlockNode 32645 "Read the comment in the superclass's bindBlockArg:within: method. 32646 If we have closures we should check the argument 32647 count against the block, not the method. 32648 32649 (Note that this isn't entirely adequate either since optimized blocks 32650 will slip through the cracks (their arguments (i.e. ifNotNil: [:expr|) 32651 are charged against their enclosing block, not themselves))." 32652 | nArgs | 32653 self supportsClosureOpcodes ifFalse: 32654 [^super bindBlockTemp: name within: aBlockNode]. 32655 (nArgs := aBlockNode nArgsSlot) isNil ifTrue: 32656 [aBlockNode nArgsSlot: (nArgs := 0)]. 32657 nArgs >= (CompiledMethod fullFrameSize - 1) ifTrue: 32658 [^self notify: 'Too many temporaries']. 32659 aBlockNode nArgsSlot: nArgs + 1. 32660 ^self bindTemp: name! ! 32661 32662!BytecodeEncoder methodsFor: 'temps' stamp: 'eem 7/18/2008 07:33'! 32663bindTemp: name 32664 "Declare a temporary; error not if a field or class variable or out-of-scope temp. 32665 Read the comment in Encoder>>bindBlockArg:within: and subclass implementations." 32666 self supportsClosureOpcodes ifFalse: 32667 [^super bindTemp: name]. 32668 scopeTable at: name ifPresent: 32669 [:node| 32670 "When non-interactive raise the error only if it is a duplicate" 32671 node isTemp 32672 ifTrue:[node scope >= 0 ifTrue: 32673 [^self notify:'Name is already defined']] 32674 ifFalse:[self warnAboutShadowed: name]]. 32675 ^self reallyBind: name! ! 32676 32677!BytecodeEncoder methodsFor: 'temps' stamp: 'eem 6/5/2009 16:51'! 32678blockExtentsToTempsMap 32679 "Answer a Dictionary of blockExtent to temp locations for the current method. 32680 This is used by the debugger to locate temp vars in contexts. A temp map 32681 entry is a pair of the temp's name and its index, where an index is either an 32682 integer for a normal temp or a pair of the index of the indirect temp vector 32683 containing the temp and the index of the temp in its indirect temp vector." 32684 | blockExtentsToTempsMap | 32685 blockExtentsToLocals ifNil: 32686 [^nil]. 32687 blockExtentsToTempsMap := Dictionary new. 32688 blockExtentsToLocals keysAndValuesDo: 32689 [:blockExtent :locals| 32690 blockExtentsToTempsMap 32691 at: blockExtent 32692 put: (Array streamContents: 32693 [:stream| 32694 locals withIndexDo: 32695 [:local :index| 32696 local isIndirectTempVector 32697 ifTrue: [local remoteTemps withIndexDo: 32698 [:remoteLocal :innerIndex| stream nextPut: { remoteLocal key. { index. innerIndex } }]] 32699 ifFalse: [stream nextPut: { local key. index }]]])]. 32700 ^blockExtentsToTempsMap! ! 32701 32702!BytecodeEncoder methodsFor: 'temps' stamp: 'eem 6/3/2008 12:33'! 32703noteBlockExtent: blockExtent hasLocals: tempNodes 32704 blockExtentsToLocals ifNil: 32705 [blockExtentsToLocals := Dictionary new]. 32706 blockExtentsToLocals at: blockExtent put: tempNodes asArray! ! 32707 32708 32709!BytecodeEncoder methodsFor: 'testing' stamp: 'eem 6/29/2009 11:11'! 32710hasGeneratedMethod 32711 ^blockExtentsToLocals notNil! ! 32712 32713!BytecodeEncoder methodsFor: 'testing' stamp: 'eem 7/17/2008 12:34'! 32714supportsClosureOpcodes 32715 "Answer if the receiver supports the 32716 genPushNewArray:/genPushConsArray: 32717 genPushRemoteTemp:inVectorAt: 32718 genStoreRemoteTemp:inVectorAt: 32719 genStorePopRemoteTemp:inVectorAt: 32720 genPushClosureCopyCopiedValues:numArgs:jumpSize: 32721 opcodes" 32722 ^false! ! 32723 32724 32725!BytecodeEncoder methodsFor: 'results' stamp: 'eem 6/5/2009 17:53'! 32726printSchematicTempNamesOn: aStream blockExtents: blockExtents fromIndex: startIndex 32727 "Print the locals in the blockExtent startIndex, recursing to print any locals in nested blockExtents. 32728 Answer the index of the last blockExtent printed." 32729 | blockExtent subsequentIndex | 32730 blockExtent := blockExtents at: startIndex. 32731 blockExtent first > 0 ifTrue: 32732 [aStream nextPut: $[ ]. 32733 ((blockExtentsToLocals at: blockExtent) reject: [:local| local isRemote]) 32734 do: [:local| 32735 local isIndirectTempVector 32736 ifTrue: 32737 [aStream nextPut: $(. 32738 local remoteTemps 32739 do: [:remoteLocal| aStream nextPutAll: remoteLocal key] 32740 separatedBy: [aStream space]. 32741 aStream nextPut: $)] 32742 ifFalse: [aStream nextPutAll: local key]] 32743 separatedBy: [aStream space]. 32744 subsequentIndex := startIndex + 1. 32745 [subsequentIndex <= blockExtents size 32746 and: [(blockExtents at: subsequentIndex) last < blockExtent last]] whileTrue: 32747 [subsequentIndex := self printSchematicTempNamesOn: aStream 32748 blockExtents: blockExtents 32749 fromIndex: subsequentIndex]. 32750 blockExtent first > 0 ifTrue: 32751 [aStream nextPut: $] ]. 32752 ^subsequentIndex! ! 32753 32754!BytecodeEncoder methodsFor: 'results' stamp: 'eem 5/29/2009 09:11'! 32755schematicTempNamesOn: aStream blockExtents: blockExtents fromIndex: startIndex 32756 "Print the locals in the blockExtent startIndex, recursing to print any locals in nested blockExtents. 32757 Answer the index of the last blockExtent printed." 32758 | blockExtent subsequentIndex | 32759 blockExtent := blockExtents at: startIndex. 32760 ((blockExtentsToLocals at: blockExtent) reject: [:local| local isRemote]) do: 32761 [:local| 32762 local isIndirectTempVector 32763 ifTrue: [local remoteTemps do: 32764 [:remoteLocal| aStream nextPut: remoteLocal key]] 32765 ifFalse: [aStream nextPut: local key]]. 32766 subsequentIndex := startIndex + 1. 32767 [subsequentIndex <= blockExtents size 32768 and: [(blockExtents at: subsequentIndex) last < blockExtent last]] whileTrue: 32769 [aStream nextPut: (Array streamContents: 32770 [:nestedTempStream| 32771 subsequentIndex := self schematicTempNamesOn: nestedTempStream 32772 blockExtents: blockExtents 32773 fromIndex: subsequentIndex])]. 32774 ^subsequentIndex! ! 32775 32776!BytecodeEncoder methodsFor: 'results' stamp: 'eem 6/29/2009 11:22'! 32777schematicTempNamesString 32778 "Answer the temp names for the current method node in a form that captures 32779 temp structure. The temps at each method and block scope level occurr 32780 space-separated, with any indirect temps enclosed in parentheses. Each block 32781 level is enclosed in square brackets. e.g. 32782 'method level temps (indirect temp)[block args and temps (indirect)]' 32783 This representation can be reconstituted into a blockExtentsToTempsMap 32784 by a CompiledMethod that has been copied with teh schematicTempNamesString." 32785 blockExtentsToLocals ifNil: 32786 [self error: 'blockExtentsToLocals uninitialized. method not yet generated?']. 32787 ^String streamContents: 32788 [:aStream| 32789 self printSchematicTempNamesOn: aStream 32790 blockExtents: (blockExtentsToLocals keys asSortedCollection: 32791 [:range1 :range2| 32792 range1 first <= range2 first]) 32793 fromIndex: 1]! ! 32794EUCTextConverter subclass: #CNGBTextConverter 32795 instanceVariableNames: '' 32796 classVariableNames: '' 32797 poolDictionaries: '' 32798 category: 'Multilingual-TextConversion'! 32799!CNGBTextConverter commentStamp: '<historical>' prior: 0! 32800Text converter for Simplified Chinese variation of EUC. (Even though the name doesn't look so, it is what it is.)! 32801 32802 32803!CNGBTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'! 32804languageEnvironment 32805 32806 ^ SimplifiedChineseEnvironment. 32807! ! 32808 32809!CNGBTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 14:42'! 32810leadingChar 32811 32812 ^ GB2312 leadingChar 32813! ! 32814 32815"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 32816 32817CNGBTextConverter class 32818 instanceVariableNames: ''! 32819 32820!CNGBTextConverter class methodsFor: 'utilities' stamp: 'yo 10/23/2002 14:42'! 32821encodingNames 32822 32823 ^ #('gb2312' ) copy 32824! ! 32825ByteTextConverter subclass: #CP1250TextConverter 32826 instanceVariableNames: '' 32827 classVariableNames: 'FromTable' 32828 poolDictionaries: '' 32829 category: 'Multilingual-TextConversion'! 32830!CP1250TextConverter commentStamp: '<historical>' prior: 0! 32831Text converter for CP1250. Windows code page used in Eastern Europe.! 32832 32833 32834"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 32835 32836CP1250TextConverter class 32837 instanceVariableNames: ''! 32838 32839!CP1250TextConverter class methodsFor: 'accessing' stamp: 'pk 1/19/2005 14:35'! 32840encodingNames 32841 32842 ^ #('cp-1250') copy 32843! ! 32844 32845!CP1250TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 1/30/2009 11:02'! 32846languageEnvironment 32847 ^Latin2Environment! ! 32848 32849 32850!CP1250TextConverter class methodsFor: 'initialization' stamp: 'michael.rueger 2/5/2009 14:07'! 32851byteToUnicodeSpec 32852 "Sepcify a table mapping the entries 0x80 to 0xFF to their unicode counterparts by returning a 128 element array.. 32853 The entries 0x00 to 0x7F map to identical values so we don't need to specify them." 32854 32855 "http://en.wikipedia.org/wiki/Windows-1250" 32856 "http://www.microsoft.com/globaldev/reference/sbcs/1250.mspx" 32857 ^#( 32858 16r20AC 16r0081 16r201A 16r083 16r201E 16r2026 16r2020 16r2021 32859 16r0088 16r2030 16r0160 16r2039 16r015A 16r0164 16r017D 16r0179 32860 32861 16r0090 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 32862 16r0098 16r2122 16r0161 16r203A 16r015B 16r0165 16r017E 16r017A 32863 32864 16r00A0 16r02C7 16r02D8 16r0141 16r00A4 16r0104 16r00A6 16r00A7 32865 16r00A8 16r00A9 16r015E 16r00AB 16r00AC 16r00AD 16r00AE 16r017B 32866 32867 16r00B0 16r00B1 16r02DB 16r0142 16r00B4 16r00B5 16r00B6 16r00B7 32868 16r00B8 16r0105 16r015F 16r00BB 16r013D 16r02DD 16r013E 16r017C 32869 32870 16r0154 16r00C1 16r00C2 16r0102 16r00C4 16r0139 16r0106 16r00C7 32871 16r010C 16r00C9 16r0118 16r00CB 16r011A 16r00CD 16r00CE 16r010E 32872 32873 16r0110 16r0143 16r0147 16r00D3 16r00D4 16r0150 16r00D6 16r00D7 32874 16r0158 16r016E 16r00DA 16r0170 16r00DC 16r00DD 16r0162 16r00DF 32875 32876 16r0155 16r00E1 16r00E2 16r0103 16r00E4 16r013A 16r0107 16r00E7 32877 16r010D 16r00E9 16r0119 16r00EB 16r011B 16r00ED 16r00EE 16r010F 32878 32879 16r0111 16r0144 16r0148 16r00F3 16r00F4 16r0151 16r00F6 16r00F7 32880 16r0159 16r016F 16r00FA 16r0171 16r00FC 16r00FD 16r0163 16r02D9 32881)! ! 32882ByteTextConverter subclass: #CP1253TextConverter 32883 instanceVariableNames: '' 32884 classVariableNames: 'FromTable' 32885 poolDictionaries: '' 32886 category: 'Multilingual-TextConversion'! 32887!CP1253TextConverter commentStamp: '<historical>' prior: 0! 32888Text converter for CP1253. Windows code page used for Greek.! 32889 32890 32891"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 32892 32893CP1253TextConverter class 32894 instanceVariableNames: ''! 32895 32896!CP1253TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/5/2009 14:07'! 32897byteToUnicodeSpec 32898 "Sepcify a table mapping the entries 0x80 to 0xFF to their unicode counterparts by returning a 128 element array.. 32899 The entries 0x00 to 0x7F map to identical values so we don't need to specify them." 32900 32901 "http://en.wikipedia.org/wiki/Windows-1253" 32902 "http://www.microsoft.com/globaldev/reference/sbcs/1253.mspx" 32903 ^#( 32904 16r20AC 16r0081 16r201A 16r0192 16r201E 16r2026 16r2020 16r2021 32905 16r0088 16r2030 16r008A 16r2039 16r008C 16r008D 16r008E 16r008F 32906 32907 16r0090 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 32908 16r0098 16r2122 16r009A 16r203A 16r009C 16r009D 16r009E 16r009F 32909 32910 16r00A0 16r0385 16r0386 16r00A3 16r00A4 16r00A5 16r00A6 16r00A7 32911 16r00A8 16r00A9 16r00AA 16r00AB 16r00AC 16r00AD 16r00AE 16r2015 32912 32913 16r00B0 16r00B1 16r00B2 16r00B3 16r0384 16r00B5 16r00B6 16r00B7 32914 16r0388 16r0389 16r038A 16r00BB 16r038C 16r00BD 16r038E 16r038F 32915 32916 16r0390 16r0391 16r0392 16r0393 16r0394 16r0395 16r0396 16r0397 32917 16r0398 16r0399 16r039A 16r039B 16r039C 16r039D 16r039E 16r039F 32918 32919 16r03A0 16r03A1 16r00D2 16r03A3 16r03A4 16r03A5 16r03A6 16r03A7 32920 16r03A8 16r03A9 16r03AA 16r03AB 16r03AC 16r03AD 16r03AE 16r03AF 32921 32922 16r03B0 16r03B1 16r03B2 16r03B3 16r03B4 16r03B5 16r03B6 16r03B7 32923 16r03B8 16r03B9 16r03BA 16r03BB 16r03BC 16r03BD 16r03BE 16r03BF 32924 32925 16r03C0 16r03C1 16r03C2 16r03C3 16r03C4 16r03C5 16r03C6 16r03C7 32926 16r03C8 16r03C9 16r03CA 16r03CB 16r03CC 16r03CD 16r03CE 16r00FF 32927)! ! 32928 32929!CP1253TextConverter class methodsFor: 'accessing' stamp: 'yo 2/19/2004 10:11'! 32930encodingNames 32931 32932 ^ #('cp-1253') copy 32933! ! 32934 32935!CP1253TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 18:49'! 32936languageEnvironment 32937 ^GreekEnvironment! ! 32938Model subclass: #CPUWatcher 32939 instanceVariableNames: 'tally watcher threshold' 32940 classVariableNames: 'CurrentCPUWatcher' 32941 poolDictionaries: '' 32942 category: 'Tools-Process Browser'! 32943!CPUWatcher commentStamp: '<historical>' prior: 0! 32944CPUWatcher implements a simple runaway process monitoring tool 32945that will suspend a process that is taking up too much of Squeak's 32946time and allow user interaction. By default it watches for a Process that 32947is taking more than 80% of the time; this threshold can be changed. 32948 32949CPUWatcher can also be used to show cpu percentages for each process 32950from within the ProcessBrowser. 32951 32952 CPUWatcher startMonitoring. "process period 20 seconds, sample rate 100 msec" 32953 CPUWatcher current monitorProcessPeriod: 10 sampleRate: 20. 32954 CPUWatcher current threshold: 0.5. "change from 80% to 50%" 32955 CPUWatcher stopMonitoring. 32956! 32957 32958 32959!CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/14/2001 07:56'! 32960isMonitoring 32961 ^watcher notNil! ! 32962 32963!CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:36'! 32964tally 32965 ^tally copy! ! 32966 32967!CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:49'! 32968threshold 32969 "What fraction of the time can a process be the active process before we stop it?" 32970 ^threshold! ! 32971 32972!CPUWatcher methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 32973threshold: thresh 32974 "What fraction of the time can a process be the active process before we stop it?" 32975 threshold := (thresh max: 0.02) min: 1.0! ! 32976 32977!CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/14/2001 08:26'! 32978watcherProcess 32979 ^watcher! ! 32980 32981 32982!CPUWatcher methodsFor: 'porcine capture' stamp: 'sd 11/20/2005 21:27'! 32983catchThePig: aProcess 32984 | rules | 32985 "nickname, allow-stop, allow-debug" 32986 rules := ProcessBrowser nameAndRulesFor: aProcess. 32987 32988 (ProcessBrowser isUIProcess: aProcess) 32989 ifTrue: [ "aProcess debugWithTitle: 'Interrupted from the CPUWatcher'." ] 32990 ifFalse: [ rules second ifFalse: [ ^self ]. 32991 ProcessBrowser suspendProcess: aProcess. 32992 self openWindowForSuspendedProcess: aProcess ] 32993! ! 32994 32995!CPUWatcher methodsFor: 'porcine capture' stamp: 'sd 11/20/2005 21:27'! 32996findThePig 32997 "tally has been updated. Look at it to see if there is a bad process. 32998 This runs at a very high priority, so make it fast" 32999 | countAndProcess | 33000 countAndProcess := tally sortedCounts first. 33001 (countAndProcess key / tally size > self threshold) ifTrue: [ | proc | 33002 proc := countAndProcess value. 33003 proc == Processor backgroundProcess ifTrue: [ ^self ]. "idle process? OK" 33004 self catchThePig: proc 33005 ]. 33006! ! 33007 33008!CPUWatcher methodsFor: 'porcine capture' stamp: 'sd 11/20/2005 21:27'! 33009openMorphicWindowForSuspendedProcess: aProcess 33010 | menu rules | 33011 menu := MenuMorph new. 33012 "nickname allow-stop allow-debug" 33013 rules := ProcessBrowser nameAndRulesFor: aProcess. 33014 menu add: 'Dismiss this menu' target: menu selector: #delete; addLine. 33015 menu add: 'Open Process Browser' target: ProcessBrowser selector: #open. 33016 menu add: 'Resume' 33017 target: self 33018 selector: #resumeProcess:fromMenu: 33019 argumentList: { aProcess . menu }. 33020 menu add: 'Terminate' 33021 target: self 33022 selector: #terminateProcess:fromMenu: 33023 argumentList: { aProcess . menu }. 33024 rules third ifTrue: [ 33025 menu add: 'Debug at a lower priority' 33026 target: self 33027 selector: #debugProcess:fromMenu: 33028 argumentList: { aProcess . menu }. 33029 ]. 33030 menu addTitle: aProcess identityHash asString, 33031 ' ', rules first, 33032 ' is taking too much time and has been suspended. 33033What do you want to do with it?'. 33034 menu stayUp: true. 33035 menu popUpInWorld 33036! ! 33037 33038!CPUWatcher methodsFor: 'porcine capture' stamp: 'alain.plantec 5/30/2008 10:35'! 33039openWindowForSuspendedProcess: aProcess 33040 33041 WorldState addDeferredUIMessage: [ self openMorphicWindowForSuspendedProcess: aProcess ] 33042 ! ! 33043 33044 33045!CPUWatcher methodsFor: 'process operations' stamp: 'sd 11/20/2005 21:27'! 33046debugProcess: aProcess 33047 | uiPriority oldPriority | 33048 uiPriority := Processor activeProcess priority. 33049 aProcess priority >= uiPriority ifTrue: [ 33050 oldPriority := ProcessBrowser setProcess: aProcess toPriority: uiPriority - 1 33051 ]. 33052 ProcessBrowser debugProcess: aProcess.! ! 33053 33054!CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:27'! 33055debugProcess: aProcess fromMenu: aMenuMorph 33056 aMenuMorph delete. 33057 self debugProcess: aProcess.! ! 33058 33059!CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:21'! 33060resumeProcess: aProcess fromMenu: aMenuMorph 33061 aMenuMorph delete. 33062 ProcessBrowser resumeProcess: aProcess.! ! 33063 33064!CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:24'! 33065terminateProcess: aProcess fromMenu: aMenuMorph 33066 aMenuMorph delete. 33067 ProcessBrowser terminateProcess: aProcess.! ! 33068 33069 33070!CPUWatcher methodsFor: 'startup-shutdown' stamp: 'sd 11/20/2005 21:27'! 33071monitorProcessPeriod: secs sampleRate: msecs 33072 self stopMonitoring. 33073 33074 watcher := [ [ | promise | 33075 promise := Processor tallyCPUUsageFor: secs every: msecs. 33076 tally := promise value. 33077 promise := nil. 33078 self findThePig. 33079 ] repeat ] forkAt: Processor highestPriority. 33080 Processor yield ! ! 33081 33082!CPUWatcher methodsFor: 'startup-shutdown' stamp: 'nk 3/14/2001 08:07'! 33083startMonitoring 33084 self 33085 monitorProcessPeriod: 20 sampleRate: 100! ! 33086 33087!CPUWatcher methodsFor: 'startup-shutdown' stamp: 'sd 11/20/2005 21:27'! 33088stopMonitoring 33089 watcher ifNotNil: [ 33090 ProcessBrowser terminateProcess: watcher. 33091 watcher := nil. 33092 ]! ! 33093 33094"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 33095 33096CPUWatcher class 33097 instanceVariableNames: ''! 33098 33099!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/8/2001 18:45'! 33100current 33101 ^CurrentCPUWatcher 33102! ! 33103 33104!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:28'! 33105currentWatcherProcess 33106 ^CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher watcherProcess ] 33107! ! 33108 33109!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/8/2001 21:43'! 33110dumpTallyOnTranscript 33111 self current ifNotNil: [ 33112 ProcessBrowser dumpTallyOnTranscript: self current tally 33113 ]! ! 33114 33115!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:15'! 33116initialize 33117 "CPUWatcher initialize" 33118 Smalltalk addToStartUpList: self. 33119 Smalltalk addToShutDownList: self.! ! 33120 33121!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:06'! 33122isMonitoring 33123 33124 ^CurrentCPUWatcher notNil and: [ CurrentCPUWatcher isMonitoring ] 33125! ! 33126 33127!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 10/31/2001 10:50'! 33128monitorPreferenceChanged 33129 Preferences cpuWatcherEnabled 33130 ifTrue: [ self startMonitoring ] 33131 ifFalse: [ self stopMonitoring ]! ! 33132 33133!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:14'! 33134shutDown 33135 self stopMonitoring.! ! 33136 33137!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:17'! 33138startMonitoring 33139 "CPUWatcher startMonitoring" 33140 33141 ^self startMonitoringPeriod: 20 rate: 100 threshold: 0.8! ! 33142 33143!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:28'! 33144startMonitoringPeriod: pd rate: rt threshold: th 33145 "CPUWatcher startMonitoring" 33146 33147 CurrentCPUWatcher ifNotNil: [ ^CurrentCPUWatcher startMonitoring. ]. 33148 CurrentCPUWatcher := (self new) 33149 monitorProcessPeriod: pd sampleRate: rt; 33150 threshold: th; 33151 yourself. 33152 ^CurrentCPUWatcher 33153! ! 33154 33155!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:14'! 33156startUp 33157 self monitorPreferenceChanged.! ! 33158 33159!CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:28'! 33160stopMonitoring 33161 "CPUWatcher stopMonitoring" 33162 33163 CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher stopMonitoring. ]. 33164 CurrentCPUWatcher := nil. 33165! ! 33166Error subclass: #CRCError 33167 instanceVariableNames: '' 33168 classVariableNames: '' 33169 poolDictionaries: '' 33170 category: 'Compression-Streams'! 33171 33172!CRCError methodsFor: 'as yet unclassified' stamp: 'nk 3/7/2004 15:56'! 33173isResumable 33174 ^true! ! 33175HTTPDownloadRequest subclass: #CachedHTTPDownloadRequest 33176 instanceVariableNames: 'cachedName' 33177 classVariableNames: '' 33178 poolDictionaries: '' 33179 category: 'System-Download'! 33180 33181!CachedHTTPDownloadRequest methodsFor: 'accessing' stamp: 'ar 12/14/1999 14:53'! 33182cachedName 33183 ^cachedName! ! 33184 33185!CachedHTTPDownloadRequest methodsFor: 'accessing' stamp: 'ar 12/14/1999 14:53'! 33186cachedName: aString 33187 cachedName := aString.! ! 33188 33189!CachedHTTPDownloadRequest methodsFor: 'accessing' stamp: 'ar 12/14/1999 15:00'! 33190startRetrieval 33191 | fileStream | 33192 cachedName == nil ifTrue:[^super startRetrieval]. 33193 (FileDirectory default fileExists: cachedName) ifTrue:[ 33194 fileStream := FileStream concreteStream new open: cachedName forWrite: false. 33195 fileStream == nil ifFalse:[^self content: 33196 (MIMEDocument 33197 contentType: 'text/plain' 33198 content: fileStream contentsOfEntireFile)]. 33199 FileDirectory default deleteFileNamed: cachedName ifAbsent:[]]. 33200 super startRetrieval. "fetch from URL" 33201 "and cache in file dir" 33202 fileStream := FileStream concreteStream new open: cachedName forWrite: true. 33203 fileStream == nil ifFalse:[ 33204 fileStream nextPutAll: (content content). 33205 fileStream close].! ! 33206CodeLoader subclass: #CachingCodeLoader 33207 instanceVariableNames: 'cacheDir' 33208 classVariableNames: '' 33209 poolDictionaries: '' 33210 category: 'System-Download'! 33211 33212!CachingCodeLoader methodsFor: 'accessing' stamp: 'mir 12/22/1999 14:10'! 33213cacheDir 33214 ^cacheDir! ! 33215 33216!CachingCodeLoader methodsFor: 'accessing' stamp: 'mir 12/22/1999 14:10'! 33217cacheDir: aString 33218 cacheDir := aString.! ! 33219 33220!CachingCodeLoader methodsFor: 'accessing' stamp: 'mir 12/22/1999 14:10'! 33221localCache: stringArray 33222 | fd | 33223 fd := FileDirectory default. 33224 stringArray do:[:part| 33225 (fd directoryNames includes: part) 33226 ifFalse:[fd createDirectory: part]. 33227 fd := fd directoryNamed: part]. 33228 self cacheDir: (fd pathName copyWith: fd pathNameDelimiter).! ! 33229 33230!CachingCodeLoader methodsFor: 'accessing' stamp: 'mir 12/22/1999 14:10'! 33231localCacheDir: aString 33232 self cacheDir: 33233 (FileDirectory default pathName, 33234 FileDirectory slash, 33235 aString, 33236 FileDirectory slash)! ! 33237 33238 33239!CachingCodeLoader methodsFor: 'private' stamp: 'mir 12/22/1999 14:11'! 33240createRequestFor: name in: aLoader 33241 | request | 33242 request := super createRequestFor: name in: aLoader. 33243 request cachedName: cacheDir, name. 33244 ^request! ! 33245 33246!CachingCodeLoader methodsFor: 'private' stamp: 'avi 4/30/2004 01:40'! 33247httpRequestClass 33248 ^CachedHTTPDownloadRequest 33249! ! 33250Morph subclass: #CachingMorph 33251 instanceVariableNames: 'damageRecorder cacheCanvas' 33252 classVariableNames: '' 33253 poolDictionaries: '' 33254 category: 'Morphic-Basic'! 33255!CachingMorph commentStamp: '<historical>' prior: 0! 33256This morph can be used to cache the picture of a morph that takes a long time to draw. It should be used with judgement, however, since heavy use of caching can consume large amounts of memory.! 33257 33258 33259!CachingMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/21/2003 23:03'! 33260updateCacheCanvas: aCanvas 33261 "Update the cached image of the morphs being held by this hand." 33262 33263 | myBnds rectList | 33264 myBnds := self fullBounds. 33265 (cacheCanvas isNil or: [cacheCanvas extent ~= myBnds extent]) 33266 ifTrue: 33267 [cacheCanvas := (aCanvas allocateForm: myBnds extent) getCanvas. 33268 cacheCanvas translateBy: myBnds origin negated 33269 during: [:tempCanvas | super fullDrawOn: tempCanvas]. 33270 ^self]. 33271 33272 "incrementally update the cache canvas" 33273 rectList := damageRecorder 33274 invalidRectsFullBounds: (0 @ 0 extent: myBnds extent). 33275 damageRecorder reset. 33276 rectList do: 33277 [:r | 33278 cacheCanvas 33279 translateTo: myBnds origin negated 33280 clippingTo: r 33281 during: 33282 [:c | 33283 c fillColor: Color transparent. "clear to transparent" 33284 super fullDrawOn: c]]! ! 33285 33286 33287!CachingMorph methodsFor: 'caching' stamp: 'jm 11/13/97 16:31'! 33288releaseCachedState 33289 33290 super releaseCachedState. 33291 cacheCanvas := nil. 33292! ! 33293 33294 33295!CachingMorph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:43'! 33296invalidRect: damageRect from: aMorph 33297 "Record the given rectangle in the damage list." 33298 damageRecorder recordInvalidRect: (damageRect translateBy: self fullBounds origin negated). 33299 super invalidRect: damageRect from: aMorph! ! 33300 33301 33302!CachingMorph methodsFor: 'drawing'! 33303drawOn: aCanvas 33304 33305 submorphs isEmpty ifTrue: [^ super drawOn: aCanvas]. 33306! ! 33307 33308!CachingMorph methodsFor: 'drawing' stamp: 'ar 12/30/2001 19:14'! 33309fullDrawOn: aCanvas 33310 (aCanvas isVisible: self fullBounds) ifFalse:[^self]. 33311 self updateCacheCanvas: aCanvas. 33312 aCanvas cache: self fullBounds 33313 using: cacheCanvas form 33314 during:[:cachingCanvas| super fullDrawOn: cachingCanvas]. 33315! ! 33316 33317!CachingMorph methodsFor: 'drawing' stamp: 'ar 5/28/2000 17:12'! 33318imageForm 33319 33320 self updateCacheCanvas: Display getCanvas. 33321 ^ cacheCanvas form offset: self fullBounds topLeft 33322! ! 33323 33324 33325!CachingMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! 33326defaultColor 33327 "answer the default color/fill style for the receiver" 33328 ^ Color veryLightGray! ! 33329 33330!CachingMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:48'! 33331initialize 33332 "initialize the state of the receiver" 33333 super initialize. 33334 "" 33335 damageRecorder := DamageRecorder new! ! 33336FileStreamException subclass: #CannotDeleteFileException 33337 instanceVariableNames: '' 33338 classVariableNames: '' 33339 poolDictionaries: '' 33340 category: 'Exceptions-Kernel'! 33341FlattenEncoder subclass: #Canvas 33342 instanceVariableNames: '' 33343 classVariableNames: '' 33344 poolDictionaries: '' 33345 category: 'Morphic-Support'! 33346!Canvas commentStamp: '<historical>' prior: 0! 33347A canvas is a two-dimensional medium on which morphs are drawn in a device-independent manner. Canvases keep track of the origin and clipping rectangle, as well as the underlying drawing medium (such as a window, pixmap, or postscript script). 33348 33349Subclasses must implement (at least) the following methods: 33350 * Drawing: 33351 #fillOval:color:borderWidth:borderColor: 33352 #frameAndFillRectangle:fillColor:borderWidth:borderColor: 33353 #drawPolygon:color:borderWidth:borderColor: 33354 #image:at:sourceRect:rule: 33355 #stencil:at:sourceRect:rule: 33356 #line:to:width:color: 33357 #paragraph:bounds:color: 33358 #text:bounds:font:color: 33359 * Support 33360 #clipBy:during: 33361 #translateBy:during: 33362 #translateBy:clippingTo:during: 33363 #transformBy:clippingTo:during: 33364! 33365 33366 33367!Canvas methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/21/2008 16:34'! 33368fillRectangle: aRectangle basicFillStyle: aFillStyle 33369 "Fill the given rectangle with the given, non-composite, fill style 33370 Note: The default implementation does not recognize any enhanced fill styles." 33371 33372 self fillRectangle: aRectangle color: aFillStyle asColor.! ! 33373 33374!Canvas methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/14/2006 14:33'! 33375frameRectangle: aRectangle width: width colors: colors dashes: dashes 33376 "Draw a rectangle with the given width, colors and dash lengths." 33377 33378 self 33379 frameRectangle: aRectangle 33380 width: width 33381 colors: colors 33382 dashes: dashes 33383 offset: self origin! ! 33384 33385!Canvas methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/18/2006 16:52'! 33386frameRectangle: aRectangle width: width colors: colors dashes: dashes offset: offset 33387 "Draw a rectangle with the given width, colors and dash lengths. 33388 The offset specifies how the coordinate system is translated from the screen origin 33389 (infinite forms are 0@0 screen based)." 33390 33391 |o s hf vf c r ds di d os l| 33392 width < 1 ifTrue: [^self]. 33393 dashes size < 2 33394 ifTrue: [^self frameRectangle: aRectangle width: width color: colors first]. 33395 r := aRectangle. 33396 s := dashes sum * width. 33397 ds := dashes size. 33398 di := 1. 33399 d := (dashes at: di) * width. 33400 c := colors at: di. 33401 hf := Form extent: s @ 1 depth: 32. 33402 r height >= width ifTrue: [ 33403 o := r left + offset x \\ s. 33404 0 to: s - 1 do: [:x | 33405 hf colorAt: x + o \\ s @ 0 put: c. 33406 d := d - 1. 33407 d = 0 ifTrue: [ 33408 di := di \\ ds + 1. 33409 d := (dashes at: di) * width. 33410 c := colors at: di]]. 33411 os := 0. 33412 l := r width truncateTo: width. 33413 self 33414 fillRectangle: (r topLeft + (os@0) extent: l@width) 33415 color: (InfiniteForm with: hf)]. 33416 vf := Form extent: 1 @ s depth: 32. 33417 r width >= width ifTrue: [ 33418 o := r top + offset y + width + (s - (r width \\ s)) \\ s. 33419 0 to: s - 1 do: [:y | 33420 vf colorAt: 0 @ (y + o \\ s) put: c. 33421 d := d - 1. 33422 d = 0 ifTrue: [ 33423 di := di \\ ds + 1. 33424 d := (dashes at: di) * width. 33425 c := colors at: di]]. 33426 os := width - (r width \\ width). 33427 l := r height - os truncateTo: width. 33428 self 33429 fillRectangle: (r topRight + (width negated @ os) extent: width@l) 33430 color: (InfiniteForm with: vf)]. 33431 r height > width ifTrue: [ 33432 o := r right + offset x - (width * 2) + (r height \\ s) + (r width \\ s) \\ s. 33433 0 to: s - 1 do: [:x | 33434 hf colorAt: o + s -1 - x \\ s @ 0 put: c. 33435 d := d - 1. 33436 d = 0 ifTrue: [ 33437 di := di \\ ds + 1. 33438 d := (dashes at: di) * width. 33439 c := colors at: di]]. 33440 os := width - (r width \\ width + (r height \\ width) \\ width). 33441 l := r width - os truncateTo: width. 33442 os := (r width - os) \\ width. 33443 self 33444 fillRectangle: (r bottomLeft + (os @ width negated) extent: l@width) 33445 color: (InfiniteForm with: hf)]. 33446 r width > width ifTrue: [ 33447 o := r top + offset y + (r height * 2 \\ s) + (r width * 2 \\ s) - (width * 3) \\ s. 33448 0 to: s - 1 do: [:y | 33449 vf colorAt: 0 @ (o + s -1 - y \\ s) put: c. 33450 d := d - 1. 33451 d = 0 ifTrue: [ 33452 di := di \\ ds + 1. 33453 d := (dashes at: di) * width. 33454 c := colors at: di]]. 33455 l := r height - (2 * width) + os. 33456 os := width. 33457 self 33458 fillRectangle: (r topLeft + (0@os) extent: width@l) 33459 color: (InfiniteForm with: vf)]! ! 33460 33461!Canvas methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/17/2006 10:42'! 33462line: pt1 to: pt2 width: width colors: colors dashes: dashes startingOffset: startingOffset 33463 "Draw a line using the given width, colors and dash lengths. 33464 Dash lengths are considered as multiples of width." 33465 33466 |dist deltaBig segmentOffset phase segmentLength startPoint distDone endPoint segLens lens l ep| 33467 width = 0 ifTrue: [^startingOffset]. 33468 dist := pt1 dist: pt2. 33469 dist = 0 ifTrue: [^startingOffset]. 33470 (dashes allSatisfy: [:d | d = 0]) ifTrue: [^startingOffset]. 33471 deltaBig := pt2 - pt1. 33472 segLens := dashes collect: [:d | d * width]. 33473 33474 "Figure out what phase we are in and how far, given startingOffset." 33475 segmentOffset := startingOffset \\ segLens sum. 33476 lens := segLens readStream. 33477 l := 0. 33478 [lens atEnd or: [segmentOffset <= (l := l + lens next)]] whileFalse: []. 33479 segmentLength := lens atEnd 33480 ifTrue: [phase := segLens size. 33481 segLens sum - segmentOffset] 33482 ifFalse: [phase := lens position. 33483 (segLens first: phase) sum - segmentOffset.]. 33484 startPoint := pt1. 33485 distDone := 0.0. 33486 segmentLength < (segLens at: phase) 33487 ifTrue: [startPoint := startPoint + (deltaBig * segmentLength / dist). 33488 distDone := distDone + segmentLength. 33489 phase := phase \\ segLens size + 1. 33490 segmentLength := (segLens at: phase)]. 33491 [distDone < dist] whileTrue: 33492 [segmentLength := segmentLength min: dist - distDone. 33493 endPoint := startPoint + (deltaBig * segmentLength / dist). 33494 ep := startPoint + (deltaBig * (segmentLength - width max: 0) / dist). 33495 self 33496 line: startPoint truncated 33497 to: ep truncated 33498 width: width 33499 color: (colors at: phase). 33500 distDone := distDone + segmentLength. 33501 phase := phase \\ segLens size + 1. 33502 startPoint := endPoint. 33503 segmentLength := segLens at: phase]. 33504 ^startingOffset + distDone! ! 33505 33506 33507!Canvas methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/6/2007 15:18'! 33508drawMorph: aMorph 33509 "Changed to improve performance. Have seen a 30% improvement." 33510 33511 (aMorph fullBounds intersects: self clipRect) 33512 ifFalse: [^self]. 33513 self draw: aMorph! ! 33514 33515!Canvas methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/21/2008 16:35'! 33516fillRectangle: aRectangle fillStyle: aFillStyle 33517 "Fill the given rectangle. Double-dispatched via the fill style." 33518 33519 aFillStyle fillRectangle: aRectangle on: self! ! 33520 33521 33522!Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:07'! 33523clipRect 33524 "Return the currently active clipping rectangle" 33525 ^self subclassResponsibility! ! 33526 33527!Canvas methodsFor: 'accessing' stamp: 'ar 2/12/2000 18:17'! 33528contentsOfArea: aRectangle 33529 "Return the contents of the given area" 33530 ^self contentsOfArea: aRectangle into: (Form extent: aRectangle extent depth: self depth)! ! 33531 33532!Canvas methodsFor: 'accessing' stamp: 'ar 2/12/2000 18:17'! 33533contentsOfArea: aRectangle into: aForm 33534 "Return the contents of the given area" 33535 ^self subclassResponsibility! ! 33536 33537!Canvas methodsFor: 'accessing'! 33538depth 33539 33540 ^ Display depth 33541! ! 33542 33543!Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:15'! 33544extent 33545 "Return the physical extent of the output device" 33546 ^self subclassResponsibility! ! 33547 33548!Canvas methodsFor: 'accessing' stamp: 'jm 6/2/1998 06:39'! 33549form 33550 33551 ^ Display 33552! ! 33553 33554!Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:11'! 33555origin 33556 "Return the current origin for drawing operations" 33557 ^self subclassResponsibility! ! 33558 33559!Canvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:46'! 33560shadowColor 33561 "Return the current override color or nil if no such color exists" 33562 ^nil! ! 33563 33564!Canvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:46'! 33565shadowColor: aColor 33566 "Set a shadow color. If set this color overrides any client-supplied color."! ! 33567 33568 33569!Canvas methodsFor: 'converting' stamp: 'ar 8/8/2001 14:22'! 33570asAlphaBlendingCanvas: alpha 33571 ^(AlphaBlendingCanvas on: self) alpha: alpha! ! 33572 33573!Canvas methodsFor: 'converting' stamp: 'ar 6/24/1999 17:46'! 33574asShadowDrawingCanvas 33575 ^self asShadowDrawingCanvas: (Color black alpha: 0.5).! ! 33576 33577!Canvas methodsFor: 'converting' stamp: 'ar 8/8/2001 14:14'! 33578asShadowDrawingCanvas: aColor 33579 ^(ShadowDrawingCanvas on: self) shadowColor: aColor! ! 33580 33581 33582!Canvas methodsFor: 'copying' stamp: 'jm 8/2/97 13:54'! 33583copy 33584 33585 ^ self clone 33586! ! 33587 33588!Canvas methodsFor: 'copying' stamp: 'ls 3/20/2000 21:24'! 33589copyClipRect: newClipRect 33590 33591 ^ ClippingCanvas canvas: self clipRect: newClipRect 33592! ! 33593 33594 33595!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:18'! 33596fillColor: aColor 33597 "Fill the receiver with the given color. 33598 Note: This method should be named differently since it is intended to fill the background and thus fills even if the color is transparent" 33599 ^self fillRectangle: self clipRect color: (aColor alpha: 1.0).! ! 33600 33601!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:30'! 33602line: pt1 to: pt2 brushForm: brush 33603 "Obsolete - will be removed in the future"! ! 33604 33605!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'! 33606line: pt1 to: pt2 color: c 33607 33608 self line: pt1 to: pt2 width: 1 color: c. 33609! ! 33610 33611!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:31'! 33612line: pt1 to: pt2 width: w color: c 33613 "Draw a line using the given width and color" 33614 ^self subclassResponsibility! ! 33615 33616!Canvas methodsFor: 'drawing' stamp: 'aoy 2/15/2003 21:41'! 33617line: pt1 to: pt2 width: width color: color1 dashLength: s1 secondColor: color2 secondDashLength: s2 startingOffset: startingOffset 33618 "Draw a line using the given width, colors and dash lengths. 33619 Originally written by Stephan Rudlof; tweaked by Dan Ingalls 33620 to use startingOffset for sliding offset as in 'ants' animations. 33621 Returns the sum of the starting offset and the length of this line." 33622 33623 | dist deltaBig colors nextPhase segmentOffset phase segmentLength startPoint distDone endPoint segLens | 33624 dist := pt1 dist: pt2. 33625 dist = 0 ifTrue: [^startingOffset]. 33626 s1 = 0 & (s2 = 0) ifTrue: [^startingOffset]. 33627 deltaBig := pt2 - pt1. 33628 colors := { 33629 color1. 33630 color2}. 33631 segLens := { 33632 s1 asFloat. 33633 s2 asFloat}. 33634 nextPhase := { 33635 2. 33636 1}. 33637 33638 "Figure out what phase we are in and how far, given startingOffset." 33639 segmentOffset := startingOffset \\ (s1 + s2). 33640 segmentLength := segmentOffset < s1 33641 ifTrue: 33642 [phase := 1. 33643 s1 - segmentOffset] 33644 ifFalse: 33645 [phase := 2. 33646 s1 + s2 - segmentOffset]. 33647 startPoint := pt1. 33648 distDone := 0.0. 33649 [distDone < dist] whileTrue: 33650 [segmentLength := segmentLength min: dist - distDone. 33651 endPoint := startPoint + (deltaBig * segmentLength / dist). 33652 self 33653 line: startPoint truncated 33654 to: endPoint truncated 33655 width: width 33656 color: (colors at: phase). 33657 distDone := distDone + segmentLength. 33658 phase := nextPhase at: phase. 33659 startPoint := endPoint. 33660 segmentLength := segLens at: phase]. 33661 ^startingOffset + dist! ! 33662 33663!Canvas methodsFor: 'drawing' stamp: 'sr 4/27/2000 03:31'! 33664line: pt1 to: pt2 width: w1 color: c1 stepWidth: s1 secondWidth: w2 secondColor: c2 secondStepWidth: s2 33665 "Draw a line using the given width, colors and steps; both steps can 33666 have different stepWidths (firstStep, secondStep), draw widths and 33667 colors." 33668 | bigSteps offsetPoint dist p1p2Vec deltaBig delta1 delta2 lastPoint bigStep | 33669 s1 = 0 & (s2 = 0) ifTrue: [^ self]. 33670 dist := pt1 dist: pt2. 33671 dist = 0 ifTrue: [^ self]. 33672 bigStep := s1 + s2. 33673 bigSteps := dist / bigStep. 33674 p1p2Vec := pt2 - pt1. 33675 deltaBig := p1p2Vec / bigSteps. 33676 delta1 := deltaBig * (s1 / bigStep). 33677 delta2 := deltaBig * (s2 / bigStep). 33678 dist <= s1 33679 ifTrue: 33680 [self 33681 line: pt1 rounded 33682 to: pt2 rounded 33683 width: w1 33684 color: c1. 33685 ^ self]. 33686 0 to: bigSteps truncated - 1 do: 33687 [:bigStepIx | 33688 self 33689 line: (pt1 + (offsetPoint := deltaBig * bigStepIx)) rounded 33690 to: (pt1 + (offsetPoint := offsetPoint + delta1)) rounded 33691 width: w1 33692 color: c1. 33693 self 33694 line: (pt1 + offsetPoint) rounded 33695 to: (pt1 + (offsetPoint + delta2)) rounded 33696 width: w2 33697 color: c2]. 33698 "if there was no loop, offsetPoint is nil" 33699 lastPoint := pt1 + ((offsetPoint ifNil: [0 @ 0]) 33700 + delta2). 33701 (lastPoint dist: pt2) 33702 <= s1 33703 ifTrue: [self 33704 line: lastPoint rounded 33705 to: pt2 rounded 33706 width: w1 33707 color: c1] 33708 ifFalse: 33709 [self 33710 line: lastPoint rounded 33711 to: (lastPoint + delta1) rounded 33712 width: w1 33713 color: c1. 33714 self 33715 line: (lastPoint + delta1) rounded 33716 to: pt2 33717 width: w1 33718 color: c2]! ! 33719 33720!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:31'! 33721paragraph: paragraph bounds: bounds color: c 33722 "Draw the given paragraph" 33723 ^self subclassResponsibility! ! 33724 33725!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:32'! 33726point: p color: c 33727 "Obsolete - will be removed in the future"! ! 33728 33729!Canvas methodsFor: 'drawing' stamp: 'ar 2/5/1999 18:28'! 33730render: anObject 33731 "Do some 3D operations with the object if possible"! ! 33732 33733 33734!Canvas methodsFor: 'drawing-general' stamp: 'ar 5/29/1999 05:14'! 33735draw: anObject 33736 ^anObject drawOn: self! ! 33737 33738!Canvas methodsFor: 'drawing-general'! 33739fullDraw: anObject 33740 ^anObject fullDrawOn: self! ! 33741 33742!Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 15:23'! 33743fullDrawMorph: aMorph 33744 self fullDraw: aMorph! ! 33745 33746!Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:47'! 33747roundCornersOf: aMorph during: aBlock 33748 ^self roundCornersOf: aMorph in: aMorph bounds during: aBlock! ! 33749 33750!Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:47'! 33751roundCornersOf: aMorph in: bounds during: aBlock 33752 ^aBlock value! ! 33753 33754 33755!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/16/2000 23:45'! 33756drawImage: aForm at: aPoint 33757 "Draw the given Form, which is assumed to be a Form or ColorForm" 33758 33759 self drawImage: aForm 33760 at: aPoint 33761 sourceRect: aForm boundingBox! ! 33762 33763!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 01:47'! 33764drawImage: aForm at: aPoint sourceRect: sourceRect 33765 "Draw the given form." 33766 self shadowColor ifNotNil:[ 33767 ^self fillRectangle: ((aForm boundingBox intersect: sourceRect) translateBy: aPoint) 33768 color: self shadowColor]. 33769 ^self image: aForm 33770 at: aPoint 33771 sourceRect: sourceRect 33772 rule: Form over! ! 33773 33774!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/16/2000 23:48'! 33775paintImage: aForm at: aPoint 33776 "Draw the given Form, which is assumed to be a Form or ColorForm following the convention that zero is the transparent pixel value." 33777 33778 self paintImage: aForm 33779 at: aPoint 33780 sourceRect: aForm boundingBox 33781! ! 33782 33783!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 01:48'! 33784paintImage: aForm at: aPoint sourceRect: sourceRect 33785 "Draw the given Form, which is assumed to be a Form or ColorForm following the convention that zero is the transparent pixel value." 33786 self shadowColor ifNotNil:[ 33787 ^self stencil: aForm at: aPoint sourceRect: sourceRect color: self shadowColor]. 33788 ^self image: aForm 33789 at: aPoint 33790 sourceRect: sourceRect 33791 rule: Form paint! ! 33792 33793!Canvas methodsFor: 'drawing-images' stamp: 'ar 6/25/1999 12:17'! 33794stencil: stencilForm at: aPoint color: aColor 33795 "Flood this canvas with aColor wherever stencilForm has non-zero pixels" 33796 ^self stencil: stencilForm 33797 at: aPoint 33798 sourceRect: stencilForm boundingBox 33799 color: aColor! ! 33800 33801!Canvas methodsFor: 'drawing-images' stamp: 'ar 6/25/1999 12:17'! 33802stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor 33803 "Flood this canvas with aColor wherever stencilForm has non-zero pixels" 33804 ^self subclassResponsibility! ! 33805 33806!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 14:05'! 33807translucentImage: aForm at: aPoint 33808 "Draw a translucent image using the best available way of representing translucency." 33809 self translucentImage: aForm 33810 at: aPoint 33811 sourceRect: aForm boundingBox! ! 33812 33813!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/10/2004 17:19'! 33814translucentImage: aForm at: aPoint sourceRect: sourceRect 33815 "Draw a translucent image using the best available way of representing translucency. 33816 Note: This will be fixed in the future." 33817 self shadowColor ifNotNil:[ 33818 ^self stencil: aForm at: aPoint sourceRect: sourceRect color: self shadowColor]. 33819 (self depth < 32 or:[aForm isTranslucent not]) 33820 ifTrue:[^self paintImage: aForm at: aPoint sourceRect: sourceRect]. 33821 self image: aForm 33822 at: aPoint 33823 sourceRect: sourceRect 33824 rule: Form blend! ! 33825 33826!Canvas methodsFor: 'drawing-images' stamp: 'ar 12/28/2001 23:44'! 33827warpImage: aForm transform: aTransform 33828 "Warp the given form using aTransform" 33829 ^self warpImage: aForm transform: aTransform at: 0@0! ! 33830 33831!Canvas methodsFor: 'drawing-images' stamp: 'ar 12/28/2001 23:54'! 33832warpImage: aForm transform: aTransform at: extraOffset 33833 "Warp the given form using aTransform. 33834 TODO: Use transform to figure out appropriate cell size" 33835 ^self warpImage: aForm transform: aTransform at: extraOffset sourceRect: aForm boundingBox cellSize: 1! ! 33836 33837!Canvas methodsFor: 'drawing-images' stamp: 'ar 12/29/2001 00:20'! 33838warpImage: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize 33839 "Warp the given using the appropriate transform and offset." 33840 ^self subclassResponsibility! ! 33841 33842 33843!Canvas methodsFor: 'drawing-obsolete' stamp: 'ar 2/12/2000 18:10'! 33844image: aForm at: aPoint 33845 "Note: This protocol is deprecated. Use #paintImage: instead." 33846 self image: aForm 33847 at: aPoint 33848 sourceRect: aForm boundingBox 33849 rule: Form paint. 33850! ! 33851 33852!Canvas methodsFor: 'drawing-obsolete' stamp: 'ar 2/12/2000 18:11'! 33853image: aForm at: aPoint rule: combinationRule 33854 "Note: This protocol is deprecated. Use one of the explicit image drawing messages (#paintImage, #drawImage) instead." 33855 self image: aForm 33856 at: aPoint 33857 sourceRect: aForm boundingBox 33858 rule: combinationRule. 33859! ! 33860 33861!Canvas methodsFor: 'drawing-obsolete' stamp: 'ar 2/12/2000 18:11'! 33862imageWithOpaqueWhite: aForm at: aPoint 33863 "Note: This protocol is deprecated. Use #drawImage: instead" 33864 self image: aForm 33865 at: aPoint 33866 sourceRect: (0@0 extent: aForm extent) 33867 rule: Form over. 33868! ! 33869 33870 33871!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'! 33872fillOval: r color: c 33873 33874 self fillOval: r color: c borderWidth: 0 borderColor: Color transparent. 33875! ! 33876 33877!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'! 33878fillOval: r color: c borderWidth: borderWidth borderColor: borderColor 33879 "Fill the given oval." 33880 ^self subclassResponsibility! ! 33881 33882!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:51'! 33883fillOval: aRectangle fillStyle: aFillStyle 33884 "Fill the given oval." 33885 ^self fillOval: aRectangle fillStyle: aFillStyle borderWidth: 0 borderColor: Color transparent! ! 33886 33887!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:50'! 33888fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc 33889 "Fill the given oval. 33890 Note: The default implementation does not recognize any enhanced fill styles" 33891 self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc! ! 33892 33893!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'! 33894frameOval: r color: c 33895 33896 self fillOval: r color: Color transparent borderWidth: 1 borderColor: c. 33897! ! 33898 33899!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'! 33900frameOval: r width: w color: c 33901 33902 self fillOval: r color: Color transparent borderWidth: w borderColor: c. 33903! ! 33904 33905 33906!Canvas methodsFor: 'drawing-polygons' stamp: 'ar 6/18/1999 08:56'! 33907drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc 33908 "Draw the given polygon." 33909 ^self subclassResponsibility! ! 33910 33911!Canvas methodsFor: 'drawing-polygons' stamp: 'ar 6/25/1999 12:18'! 33912drawPolygon: vertices fillStyle: aFillStyle 33913 "Fill the given polygon." 33914 self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: Color transparent! ! 33915 33916!Canvas methodsFor: 'drawing-polygons' stamp: 'ar 6/18/1999 08:58'! 33917drawPolygon: vertices fillStyle: aFillStyle borderWidth: bw borderColor: bc 33918 "Fill the given polygon. 33919 Note: The default implementation does not recognize any enhanced fill styles" 33920 self drawPolygon: vertices color: aFillStyle asColor borderWidth: bw borderColor: bc! ! 33921 33922 33923!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:32'! 33924fillRectangle: r color: c 33925 "Fill the rectangle using the given color" 33926 ^self 33927 frameAndFillRectangle: r 33928 fillColor: c 33929 borderWidth: 0 33930 borderColor: Color transparent! ! 33931 33932!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 8/25/2001 17:27'! 33933fillRectangle: aRectangle fillStyle: aFillStyle borderStyle: aBorderStyle 33934 "Fill the given rectangle." 33935 self fillRectangle: (aRectangle insetBy: aBorderStyle width) fillStyle: aFillStyle. 33936 aBorderStyle frameRectangle: aRectangle on: self! ! 33937 33938!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:32'! 33939frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor 33940 "Draw the rectangle using the given attributes" 33941 ^self subclassResponsibility! ! 33942 33943!Canvas methodsFor: 'drawing-rectangles' stamp: 'RAA 8/14/2000 14:22'! 33944frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor 33945 "Draw the rectangle using the given attributes. 33946 Note: This is a *very* simple implementation" 33947 | bw pt | 33948 self frameAndFillRectangle: r 33949 fillColor: fillColor 33950 borderWidth: borderWidth 33951 borderColor: bottomRightColor. 33952 bottomRightColor = topLeftColor ifFalse: [ 33953 bw := borderWidth asPoint. 33954 pt := r topLeft + (bw // 2). 33955 self line: pt to: pt + ((r extent x - bw x)@0) width: borderWidth color: topLeftColor. 33956 self line: pt to: pt + (0@(r extent y - bw y)) width: borderWidth color: topLeftColor. 33957 ].! ! 33958 33959!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:33'! 33960frameRectangle: r color: c 33961 33962 self frameRectangle: r width: 1 color: c. 33963! ! 33964 33965!Canvas methodsFor: 'drawing-rectangles' stamp: 'marcus.denker 8/15/2008 17:43'! 33966frameRectangle: r width: w color: c 33967 "Draw a frame around the given rectangle" 33968 ^self frameAndFillRectangle: r 33969 fillColor: Color transparent 33970 borderWidth: w 33971 borderColor: c! ! 33972 33973 33974!Canvas methodsFor: 'drawing-support' stamp: 'gm 2/22/2003 14:53'! 33975cache: aRectangle using: aCache during: aBlock 33976 "Cache the execution of aBlock by the given cache. 33977 Note: At some point we may want to actually *create* the cache here; 33978 for now we're only using it." 33979 33980 (aCache notNil 33981 and: [(aCache isForm) and: [aCache extent = aRectangle extent]]) 33982 ifTrue: [^self paintImage: aCache at: aRectangle origin]. 33983 aBlock value: self! ! 33984 33985!Canvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 02:53'! 33986clipBy: aRectangle during: aBlock 33987 "Set a clipping rectangle active only during the execution of aBlock. 33988 Note: In the future we may want to have more general clip shapes - not just rectangles" 33989 ^self subclassResponsibility! ! 33990 33991!Canvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 01:43'! 33992preserveStateDuring: aBlock 33993 "Preserve the full canvas state during the execution of aBlock" 33994 ^aBlock value: self copy! ! 33995 33996!Canvas methodsFor: 'drawing-support' stamp: 'di 10/16/1999 16:02'! 33997transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock 33998 "Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')." 33999 ^ self transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: 1 34000! ! 34001 34002!Canvas methodsFor: 'drawing-support' stamp: 'di 10/16/1999 15:56'! 34003transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize 34004 "Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')." 34005 ^ self subclassResponsibility! ! 34006 34007!Canvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:00'! 34008translateBy: delta during: aBlock 34009 "Set a translation only during the execution of aBlock." 34010 ^self subclassResponsibility! ! 34011 34012!Canvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 14:08'! 34013translateTo: newOrigin clippingTo: aRectangle during: aBlock 34014 "Set a new origin and clipping rectangle only during the execution of aBlock." 34015 self translateBy: newOrigin - self origin 34016 clippingTo: (aRectangle translateBy: self origin negated) 34017 during: aBlock! ! 34018 34019 34020!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:35'! 34021drawString: s at: pt 34022 34023 ^ self drawString: s from: 1 to: s size at: pt font: nil color: Color black! ! 34024 34025!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:25'! 34026drawString: s at: pt font: aFont color: aColor 34027 34028 ^ self drawString: s from: 1 to: s size at: pt font: aFont color: aColor! ! 34029 34030!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:36'! 34031drawString: s from: firstIndex to: lastIndex at: pt font: font color: aColor 34032 self drawString: s from: firstIndex to: lastIndex in: (pt extent: 10000@10000) font: font color: aColor! ! 34033 34034!Canvas methodsFor: 'drawing-text' stamp: 'tween 3/10/2009 08:07'! 34035drawString: s from: firstIndex to: lastIndex at: pt font: font color: aColor underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc 34036 self drawString: s from: firstIndex to: lastIndex in: (pt extent: 10000@10000) font: font color: aColor underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc! ! 34037 34038!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:37'! 34039drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c 34040 ^self subclassResponsibility! ! 34041 34042!Canvas methodsFor: 'drawing-text' stamp: 'tween 3/10/2009 07:42'! 34043drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc 34044 ^self subclassResponsibility! ! 34045 34046!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:39'! 34047drawString: s in: boundsRect 34048 ^self drawString: s from: 1 to: s size in: boundsRect font: nil color: Color black! ! 34049 34050!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:13'! 34051drawString: s in: boundsRect font: fontOrNil color: c 34052 ^self drawString: s from: 1 to: s size in: boundsRect font: fontOrNil color: c! ! 34053 34054!Canvas methodsFor: 'drawing-text' stamp: 'tween 3/10/2009 08:12'! 34055drawString: s in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc 34056 ^self drawString: s from: 1 to: s size in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc! ! 34057 34058!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:40'! 34059text: s at: pt font: fontOrNil color: c 34060 "OBSOLETE" 34061 ^ self drawString: s at: pt font: fontOrNil color: c! ! 34062 34063!Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:40'! 34064text: s bounds: boundsRect font: fontOrNil color: c 34065 "OBSOLETE" 34066 ^self drawString: s in: boundsRect font: fontOrNil color: c! ! 34067 34068 34069!Canvas methodsFor: 'initialization' stamp: 'ar 5/27/2000 21:50'! 34070finish 34071 "If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect." 34072 ^self flush! ! 34073 34074!Canvas methodsFor: 'initialization' stamp: 'ar 2/9/1999 06:29'! 34075flush! ! 34076 34077!Canvas methodsFor: 'initialization' stamp: 'di 9/22/1999 19:21'! 34078reset 34079 "Reset the canvas." 34080 34081 super initWithTarget:self class defaultTarget. 34082! ! 34083 34084 34085!Canvas methodsFor: 'nebraska/embeddedworlds' stamp: 'RAA 12/5/2000 18:28'! 34086transform2By: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize 34087 34088 "an attempt to use #displayInterpolatedOn: instead of WarpBlt." 34089 34090 | patchRect subCanvas pureRect biggerPatch biggerClip interForm | 34091 34092 self flag: #bob. "added to Canvas in hopes it will work for Nebraska" 34093 (aDisplayTransform isPureTranslation) ifTrue: [ 34094 ^aBlock value: (self copyOffset: aDisplayTransform offset negated truncated 34095 clipRect: aClipRect) 34096 ]. 34097 "Prepare an appropriate warp from patch to aClipRect" 34098 pureRect := (aDisplayTransform globalBoundsToLocal: aClipRect). 34099 patchRect := pureRect rounded. 34100 patchRect area = 0 ifTrue: [^self]. "oh, well!!" 34101 biggerPatch := patchRect expandBy: 1. 34102 biggerClip := (aDisplayTransform localBoundsToGlobal: biggerPatch) rounded. 34103 34104 "Render the submorphs visible in the clipping rectangle, as patchForm" 34105 subCanvas := FormCanvas extent: biggerPatch extent depth: self depth. 34106 self isShadowDrawing ifTrue: [ 34107 subCanvas shadowColor: self shadowColor 34108 ]. 34109 34110 "this biggerPatch/biggerClip is an attempt to improve positioning of the final image in high magnification conditions. Since we cannot grab fractional pixels from the source, take one extra and then take just the part we need from the expanded form" 34111 34112 subCanvas 34113 translateBy: biggerPatch topLeft negated rounded 34114 during: [ :offsetCanvas | aBlock value: offsetCanvas]. 34115 interForm := Form extent: biggerClip extent depth: self depth. 34116 subCanvas form 34117 displayInterpolatedIn: interForm boundingBox 34118 on: interForm. 34119 self 34120 drawImage: interForm 34121 at: aClipRect origin 34122 sourceRect: (aClipRect origin - biggerClip origin extent: aClipRect extent) 34123 34124! ! 34125 34126 34127!Canvas methodsFor: 'other'! 34128flushDisplay 34129 " Dummy ."! ! 34130 34131!Canvas methodsFor: 'other'! 34132forceToScreen:rect 34133 " dummy " 34134! ! 34135 34136!Canvas methodsFor: 'other'! 34137translateBy:aPoint clippingTo:aRect during:aBlock 34138 ^aBlock value:(self copyOffset:aPoint clipRect:aRect).! ! 34139 34140 34141!Canvas methodsFor: 'testing' stamp: 'di 8/12/2000 15:04'! 34142doesRoundedCorners 34143 34144 ^ true! ! 34145 34146!Canvas methodsFor: 'testing' stamp: 'ar 11/13/1998 13:19'! 34147isBalloonCanvas 34148 ^false! ! 34149 34150!Canvas methodsFor: 'testing' stamp: 'nk 1/1/2004 21:09'! 34151isPostscriptCanvas 34152 ^false! ! 34153 34154!Canvas methodsFor: 'testing' stamp: 'ar 6/22/1999 19:03'! 34155isShadowDrawing 34156 ^false! ! 34157 34158!Canvas methodsFor: 'testing' stamp: 'ar 6/22/1999 14:10'! 34159isVisible: aRectangle 34160 "Return true if the given rectangle is (partially) visible" 34161 ^self clipRect intersects: aRectangle 34162! ! 34163 34164!Canvas methodsFor: 'testing' stamp: 'di 9/24/2000 16:10'! 34165seesNothingOutside: aRectangle 34166 "Return true if this canvas will not touch anything outside aRectangle" 34167 ^ aRectangle containsRect: self clipRect 34168! ! 34169 34170 34171!Canvas methodsFor: 'private' stamp: 'ar 2/12/2000 18:12'! 34172image: aForm at: aPoint sourceRect: sourceRect rule: rule 34173 "Note: The public use of this protocol is deprecated. It will become private. Nobody in the outside world must assume that a thing like a combination rule has any specific effect." 34174 ^self subclassResponsibility! ! 34175 34176!Canvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:21'! 34177image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha 34178 "Privately used for blending forms w/ constant alpha. Fall back to simpler case by defaul." 34179 ^self image: aForm at: aPoint sourceRect: sourceRect rule: rule! ! 34180 34181"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 34182 34183Canvas class 34184 instanceVariableNames: ''! 34185 34186!Canvas class methodsFor: 'configuring'! 34187filterSelector 34188 ^#drawOnCanvas:.! ! 34189ParseNode subclass: #CascadeNode 34190 instanceVariableNames: 'receiver messages' 34191 classVariableNames: '' 34192 poolDictionaries: '' 34193 category: 'Compiler-ParseNodes'! 34194!CascadeNode commentStamp: '<historical>' prior: 0! 34195The first message has the common receiver, the rest have receiver == nil, which signifies cascading.! 34196 34197 34198!CascadeNode methodsFor: 'accessing' stamp: 'eem 9/10/2008 15:15'! 34199messages 34200 ^messages! ! 34201 34202!CascadeNode methodsFor: 'accessing' stamp: 'tk 10/22/2000 16:55'! 34203receiver 34204 ^receiver! ! 34205 34206 34207!CascadeNode methodsFor: 'code generation'! 34208emitForValue: stack on: aStream 34209 34210 receiver emitForValue: stack on: aStream. 34211 1 to: messages size - 1 do: 34212 [:i | 34213 aStream nextPut: Dup. 34214 stack push: 1. 34215 (messages at: i) emitForValue: stack on: aStream. 34216 aStream nextPut: Pop. 34217 stack pop: 1]. 34218 messages last emitForValue: stack on: aStream! ! 34219 34220!CascadeNode methodsFor: 'code generation'! 34221sizeForValue: encoder 34222 34223 | size | 34224 size := (receiver sizeForValue: encoder) + (messages size - 1 * 2). 34225 messages do: [:aMessage | size := size + (aMessage sizeForValue: encoder)]. 34226 ^size! ! 34227 34228 34229!CascadeNode methodsFor: 'code generation (closures)' stamp: 'eem 5/19/2008 20:26'! 34230analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>" 34231 { receiver }, messages do: 34232 [:node| node analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools]! ! 34233 34234 34235!CascadeNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/15/2008 09:41'! 34236emitCodeForValue: stack encoder: encoder 34237 receiver emitCodeForValue: stack encoder: encoder. 34238 1 to: messages size - 1 do: 34239 [:i | 34240 encoder genDup. 34241 stack push: 1. 34242 (messages at: i) emitCodeForValue: stack encoder: encoder. 34243 encoder genPop. 34244 stack pop: 1]. 34245 messages last emitCodeForValue: stack encoder: encoder! ! 34246 34247!CascadeNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/15/2008 09:39'! 34248sizeCodeForValue: encoder 34249 | size | 34250 size := (receiver sizeCodeForValue: encoder) 34251 + (messages size - 1 * (encoder sizeDup + encoder sizePop)). 34252 messages do: [:aMessage | size := size + (aMessage sizeCodeForValue: encoder)]. 34253 ^size! ! 34254 34255 34256!CascadeNode methodsFor: 'initialize-release'! 34257receiver: receivingObject messages: msgs 34258 " Transcript show: 'abc'; cr; show: 'def' " 34259 34260 receiver := receivingObject. 34261 messages := msgs! ! 34262 34263 34264!CascadeNode methodsFor: 'printing'! 34265printOn: aStream indent: level 34266 self printOn: aStream indent: level precedence: 0! ! 34267 34268!CascadeNode methodsFor: 'printing' stamp: 'di 4/25/2000 19:17'! 34269printOn: aStream indent: level precedence: p 34270 34271 p > 0 ifTrue: [aStream nextPut: $(]. 34272 messages first printReceiver: receiver on: aStream indent: level. 34273 1 to: messages size do: 34274 [:i | (messages at: i) printOn: aStream indent: level. 34275 i < messages size ifTrue: 34276 [aStream nextPut: $;. 34277 messages first precedence >= 2 ifTrue: [aStream crtab: level + 1]]]. 34278 p > 0 ifTrue: [aStream nextPut: $)]! ! 34279 34280!CascadeNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 34281printWithClosureAnalysisOn: aStream indent: level 34282 self printWithClosureAnalysisOn: aStream indent: level precedence: 0! ! 34283 34284!CascadeNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 34285printWithClosureAnalysisOn: aStream indent: level precedence: p 34286 34287 p > 0 ifTrue: [aStream nextPut: $(]. 34288 messages first printWithClosureAnalysisReceiver: receiver on: aStream indent: level. 34289 1 to: messages size do: 34290 [:i | (messages at: i) printWithClosureAnalysisOn: aStream indent: level. 34291 i < messages size ifTrue: 34292 [aStream nextPut: $;. 34293 messages first precedence >= 2 ifTrue: [aStream crtab: level + 1]]]. 34294 p > 0 ifTrue: [aStream nextPut: $)]! ! 34295 34296 34297!CascadeNode methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:16'! 34298accept: aVisitor 34299 aVisitor visitCascadeNode: self! ! 34300Object subclass: #Categorizer 34301 instanceVariableNames: 'categoryArray categoryStops elementArray' 34302 classVariableNames: 'Default NullCategory' 34303 poolDictionaries: '' 34304 category: 'Kernel-Classes'! 34305 34306!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! 34307addCategory: newCategory 34308 ^ self addCategory: newCategory before: nil ! ! 34309 34310!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! 34311addCategory: catString before: nextCategory 34312 "Add a new category named heading. 34313 If default category exists and is empty, remove it. 34314 If nextCategory is nil, then add the new one at the end, 34315 otherwise, insert it before nextCategory." 34316 | index newCategory | 34317 newCategory := catString asSymbol. 34318 (categoryArray indexOf: newCategory) > 0 34319 ifTrue: [^self]. "heading already exists, so done" 34320 index := categoryArray indexOf: nextCategory 34321 ifAbsent: [categoryArray size + 1]. 34322 categoryArray := categoryArray 34323 copyReplaceFrom: index 34324 to: index-1 34325 with: (Array with: newCategory). 34326 categoryStops := categoryStops 34327 copyReplaceFrom: index 34328 to: index-1 34329 with: (Array with: (index = 1 34330 ifTrue: [0] 34331 ifFalse: [categoryStops at: index-1])). 34332 "remove empty default category" 34333 (newCategory ~= Default 34334 and: [(self listAtCategoryNamed: Default) isEmpty]) 34335 ifTrue: [self removeCategory: Default]! ! 34336 34337!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! 34338allMethodSelectors 34339 "give a list of all method selectors." 34340 34341 ^ elementArray copy sort! ! 34342 34343!Categorizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:29'! 34344categories 34345 "Answer an Array of categories (names)." 34346 categoryArray isNil ifTrue: [^ nil]. 34347 (categoryArray size = 1 34348 and: [categoryArray first = Default & (elementArray size = 0)]) 34349 ifTrue: [^Array with: NullCategory]. 34350 ^categoryArray! ! 34351 34352!Categorizer methodsFor: 'accessing' stamp: 'mtf 1/19/2009 15:00'! 34353categories: anArray 34354 "Reorder my categories to be in order of the argument, anArray. If the 34355 resulting organization does not include all elements, then give an error." 34356 34357 | newCategories newStops newElements catName list runningTotal | 34358 34359 anArray size < 2 ifTrue: [ ^ self ]. 34360 34361 newCategories := Array new: anArray size. 34362 newStops := Array new: anArray size. 34363 newElements := Array new: 0. 34364 runningTotal := 0. 34365 1 to: anArray size do: 34366 [:i | 34367 catName := (anArray at: i) asSymbol. 34368 list := self listAtCategoryNamed: catName. 34369 newElements := newElements, list. 34370 newCategories at: i put: catName. 34371 newStops at: i put: (runningTotal := runningTotal + list size)]. 34372 elementArray do: 34373 [:element | "check to be sure all elements are included" 34374 (newElements includes: element) 34375 ifFalse: [^self error: 'New categories must match old ones']]. 34376 "Everything is good, now update my three arrays." 34377 categoryArray := newCategories. 34378 categoryStops := newStops. 34379 elementArray := newElements! ! 34380 34381!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! 34382categoryOfElement: element 34383 "Answer the category associated with the argument, element." 34384 34385 | index | 34386 index := self numberOfCategoryOfElement: element. 34387 index = 0 34388 ifTrue: [^nil] 34389 ifFalse: [^categoryArray at: index]! ! 34390 34391!Categorizer methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 00:16'! 34392changeFromCategorySpecs: categorySpecs 34393 "Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment." 34394 34395 | oldElements newElements newCategories newStops currentStop temp ii cc catSpec | 34396 oldElements := elementArray asSet. 34397 newCategories := Array new: categorySpecs size. 34398 newStops := Array new: categorySpecs size. 34399 currentStop := 0. 34400 newElements := (Array new: 16) writeStream. 34401 1 to: categorySpecs size do: 34402 [:i | | selectors | 34403 catSpec := categorySpecs at: i. 34404 newCategories at: i put: catSpec first asSymbol. 34405 selectors := catSpec allButFirst collect: [:each | each isSymbol 34406 ifTrue: [each] 34407 ifFalse: [each printString asSymbol]]. 34408 selectors asSortedCollection do: 34409 [:elem | 34410 (oldElements remove: elem ifAbsent: [nil]) notNil ifTrue: 34411 [newElements nextPut: elem. 34412 currentStop := currentStop+1]]. 34413 newStops at: i put: currentStop]. 34414 34415 "Ignore extra elements but don't lose any existing elements!!" 34416 oldElements := oldElements collect: 34417 [:elem | Array with: (self categoryOfElement: elem) with: elem]. 34418 newElements := newElements contents. 34419 categoryArray := newCategories. 34420 (cc := categoryArray asSet) size = categoryArray size ifFalse: ["has duplicate element" 34421 temp := categoryArray asOrderedCollection. 34422 temp removeAll: categoryArray asSet asOrderedCollection. 34423 temp do: [:dup | 34424 | tmp | 34425 tmp := dup. 34426 ii := categoryArray indexOf: tmp. 34427 [tmp := (tmp,' #2') asSymbol. cc includes: tmp] whileTrue. 34428 cc add: tmp. 34429 categoryArray at: ii put: tmp]]. 34430 categoryStops := newStops. 34431 elementArray := newElements. 34432 oldElements do: [:pair | self classify: pair last under: pair first].! ! 34433 34434!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! 34435changeFromString: aString 34436 "Parse the argument, aString, and make this be the receiver's structure." 34437 34438 | categorySpecs | 34439 categorySpecs := Scanner new scanTokens: aString. 34440 "If nothing was scanned and I had no elements before, then default me" 34441 (categorySpecs isEmpty and: [elementArray isEmpty]) 34442 ifTrue: [^ self setDefaultList: Array new]. 34443 34444 ^ self changeFromCategorySpecs: categorySpecs! ! 34445 34446!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! 34447classify: element under: heading 34448 self classify: element under: heading suppressIfDefault: true! ! 34449 34450!Categorizer methodsFor: 'accessing' stamp: 'al 11/28/2005 22:05'! 34451classify: element under: heading suppressIfDefault: aBoolean 34452 "Store the argument, element, in the category named heading. If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein" 34453 34454 | catName catIndex elemIndex realHeading | 34455 ((heading = NullCategory) or: [heading == nil]) 34456 ifTrue: [realHeading := Default] 34457 ifFalse: [realHeading := heading asSymbol]. 34458 (catName := self categoryOfElement: element) = realHeading 34459 ifTrue: [^ self]. "done if already under that category" 34460 34461 catName ~~ nil ifTrue: 34462 [(aBoolean and: [realHeading = Default]) 34463 ifTrue: [^ self]. "return if non-Default category already assigned in memory" 34464 self basicRemoveElement: element]. "remove if in another category" 34465 34466 (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading]. 34467 34468 catIndex := categoryArray indexOf: realHeading. 34469 elemIndex := 34470 catIndex > 1 34471 ifTrue: [categoryStops at: catIndex - 1] 34472 ifFalse: [0]. 34473 [(elemIndex := elemIndex + 1) <= (categoryStops at: catIndex) 34474 and: [element >= (elementArray at: elemIndex)]] whileTrue. 34475 34476 "elemIndex is now the index for inserting the element. Do the insertion before it." 34477 elementArray := elementArray copyReplaceFrom: elemIndex to: elemIndex-1 34478 with: (Array with: element). 34479 34480 "add one to stops for this and later categories" 34481 catIndex to: categoryArray size do: 34482 [:i | categoryStops at: i put: (categoryStops at: i) + 1]. 34483 34484 ((categoryArray includes: Default) 34485 and: [(self listAtCategoryNamed: Default) size = 0]) ifTrue: [self removeCategory: Default]. 34486 34487 self assertInvariant.! ! 34488 34489!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! 34490classifyAll: aCollection under: heading 34491 34492 aCollection do: 34493 [:element | self classify: element under: heading]! ! 34494 34495!Categorizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:20'! 34496elementCategoryDict 34497 | dict firstIndex lastIndex | 34498 elementArray isNil ifTrue: [^ nil]. 34499 dict := Dictionary new: elementArray size. 34500 1to: categoryStops size do: [:cat | 34501 firstIndex := self firstIndexOfCategoryNumber: cat. 34502 lastIndex := self lastIndexOfCategoryNumber: cat. 34503 firstIndex to: lastIndex do: [:el | 34504 dict at: (elementArray at: el) put: (categoryArray at: cat)]. 34505 ]. 34506 ^ dict.! ! 34507 34508!Categorizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:33'! 34509isEmptyCategoryNamed: categoryName 34510 | i | 34511 i := categoryArray indexOf: categoryName ifAbsent: [^false]. 34512 ^self isEmptyCategoryNumber: i! ! 34513 34514!Categorizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:33'! 34515isEmptyCategoryNumber: anInteger 34516 34517 | firstIndex lastIndex | 34518 (anInteger < 1 or: [anInteger > categoryStops size]) 34519 ifTrue: [^ true]. 34520 firstIndex := self firstIndexOfCategoryNumber: anInteger. 34521 lastIndex := self lastIndexOfCategoryNumber: anInteger. 34522 ^ firstIndex > lastIndex! ! 34523 34524!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! 34525listAtCategoryNamed: categoryName 34526 "Answer the array of elements associated with the name, categoryName." 34527 34528 | i | 34529 i := categoryArray indexOf: categoryName ifAbsent: [^Array new]. 34530 ^self listAtCategoryNumber: i! ! 34531 34532!Categorizer methodsFor: 'accessing' stamp: 'NS 4/6/2004 13:51'! 34533listAtCategoryNumber: anInteger 34534 "Answer the array of elements stored at the position indexed by anInteger. Answer nil if anInteger is larger than the number of categories." 34535 34536 | firstIndex lastIndex | 34537 (anInteger < 1 or: [anInteger > categoryStops size]) 34538 ifTrue: [^ nil]. 34539 firstIndex := self firstIndexOfCategoryNumber: anInteger. 34540 lastIndex := self lastIndexOfCategoryNumber: anInteger. 34541 ^elementArray copyFrom: firstIndex to: lastIndex! ! 34542 34543!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! 34544numberOfCategoryOfElement: element 34545 "Answer the index of the category with which the argument, element, is 34546 associated." 34547 34548 | categoryIndex elementIndex | 34549 categoryIndex := 1. 34550 elementIndex := 0. 34551 [(elementIndex := elementIndex + 1) <= elementArray size] 34552 whileTrue: 34553 ["point to correct category" 34554 [elementIndex > (categoryStops at: categoryIndex)] 34555 whileTrue: [categoryIndex := categoryIndex + 1]. 34556 "see if this is element" 34557 element = (elementArray at: elementIndex) ifTrue: [^categoryIndex]]. 34558 ^0! ! 34559 34560!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! 34561removeCategory: cat 34562 "Remove the category named, cat. Create an error notificiation if the 34563 category has any elements in it." 34564 34565 | index lastStop | 34566 index := categoryArray indexOf: cat ifAbsent: [^self]. 34567 lastStop := 34568 index = 1 34569 ifTrue: [0] 34570 ifFalse: [categoryStops at: index - 1]. 34571 (categoryStops at: index) - lastStop > 0 34572 ifTrue: [^self error: 'cannot remove non-empty category']. 34573 categoryArray := categoryArray copyReplaceFrom: index to: index with: Array new. 34574 categoryStops := categoryStops copyReplaceFrom: index to: index with: Array new. 34575 categoryArray size = 0 34576 ifTrue: 34577 [categoryArray := Array with: Default. 34578 categoryStops := Array with: 0] 34579! ! 34580 34581!Categorizer methodsFor: 'accessing' stamp: 'NS 4/12/2004 20:50'! 34582removeElement: element 34583 ^ self basicRemoveElement: element! ! 34584 34585!Categorizer methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 00:16'! 34586removeEmptyCategories 34587 "Remove empty categories." 34588 34589 | categoryIndex currentStop keptCategories keptStops | 34590 keptCategories := (Array new: 16) writeStream. 34591 keptStops := (Array new: 16) writeStream. 34592 currentStop := categoryIndex := 0. 34593 [(categoryIndex := categoryIndex + 1) <= categoryArray size] 34594 whileTrue: 34595 [(categoryStops at: categoryIndex) > currentStop 34596 ifTrue: 34597 [keptCategories nextPut: (categoryArray at: categoryIndex). 34598 keptStops nextPut: (currentStop := categoryStops at: categoryIndex)]]. 34599 categoryArray := keptCategories contents. 34600 categoryStops := keptStops contents. 34601 categoryArray size = 0 34602 ifTrue: 34603 [categoryArray := Array with: Default. 34604 categoryStops := Array with: 0] 34605 34606 "ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]."! ! 34607 34608!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! 34609renameCategory: oldCatString toBe: newCatString 34610 "Rename a category. No action if new name already exists, or if old name does not exist." 34611 | index oldCategory newCategory | 34612 oldCategory := oldCatString asSymbol. 34613 newCategory := newCatString asSymbol. 34614 (categoryArray indexOf: newCategory) > 0 34615 ifTrue: [^ self]. "new name exists, so no action" 34616 (index := categoryArray indexOf: oldCategory) = 0 34617 ifTrue: [^ self]. "old name not found, so no action" 34618 categoryArray := categoryArray copy. "need to change identity so smart list update will notice the change" 34619 categoryArray at: index put: newCategory! ! 34620 34621!Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! 34622sortCategories 34623 | privateCategories publicCategories newCategories | 34624 34625 privateCategories := self categories select: 34626 [:one | (one findString: 'private' startingAt: 1 caseSensitive: false) = 1]. 34627 publicCategories := self categories copyWithoutAll: privateCategories. 34628 newCategories := publicCategories asSortedCollection asOrderedCollection 34629 addAll: privateCategories asSortedCollection; 34630 asArray. 34631 self categories: newCategories! ! 34632 34633 34634!Categorizer methodsFor: 'fileIn/Out' stamp: 'NS 4/5/2004 17:44'! 34635scanFrom: aStream 34636 "Reads in the organization from the next chunk on aStream. 34637 Categories or elements not found in the definition are not affected. 34638 New elements are ignored." 34639 34640 self changeFromString: aStream nextChunk. 34641 aStream skipStyleChunk.! ! 34642 34643 34644!Categorizer methodsFor: 'printing' stamp: 'NS 4/5/2004 17:44'! 34645printOn: aStream 34646 "Refer to the comment in Object|printOn:." 34647 34648 | elementIndex | 34649 elementIndex := 1. 34650 1 to: categoryArray size do: 34651 [:i | 34652 aStream nextPut: $(. 34653 (categoryArray at: i) asString printOn: aStream. 34654 [elementIndex <= (categoryStops at: i)] 34655 whileTrue: 34656 [aStream space; nextPutAll: (elementArray at: elementIndex). 34657 elementIndex := elementIndex + 1]. 34658 aStream nextPut: $); cr]! ! 34659 34660!Categorizer methodsFor: 'printing' stamp: 'NS 4/5/2004 17:44'! 34661printOnStream: aStream 34662 "Refer to the comment in Object|printOn:." 34663 34664 | elementIndex | 34665 elementIndex := 1. 34666 1 to: categoryArray size do: 34667 [:i | 34668 aStream print: '('; 34669 write:(categoryArray at:i). " is the asString redundant? " 34670 34671 [elementIndex <= (categoryStops at: i)] 34672 whileTrue: 34673 [aStream print:' '; write:(elementArray at: elementIndex). 34674 elementIndex := elementIndex + 1]. 34675 aStream print:')'. 34676 aStream cr]! ! 34677 34678!Categorizer methodsFor: 'printing' stamp: 'lr 6/22/2005 08:12'! 34679printString 34680 ^ String streamContents: [ :stream | self printOn: stream ].! ! 34681 34682 34683!Categorizer methodsFor: 'private' stamp: 'dvf 8/11/2005 22:38'! 34684assertInvariant 34685 self assert: (elementArray size = categoryStops last)! ! 34686 34687!Categorizer methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 00:15'! 34688basicRemoveElement: element 34689 "Remove the selector, element, from all categories." 34690 | categoryIndex elementIndex nextStop newElements | 34691 categoryIndex := 1. 34692 elementIndex := 0. 34693 nextStop := 0. 34694 "nextStop keeps track of the stops in the new element array" 34695 newElements := (Array new: elementArray size) writeStream. 34696 [(elementIndex := elementIndex + 1) <= elementArray size] 34697 whileTrue: 34698 [[elementIndex > (categoryStops at: categoryIndex)] 34699 whileTrue: 34700 [categoryStops at: categoryIndex put: nextStop. 34701 categoryIndex := categoryIndex + 1]. 34702 (elementArray at: elementIndex) = element 34703 ifFalse: 34704 [nextStop := nextStop + 1. 34705 newElements nextPut: (elementArray at: elementIndex)]]. 34706 [categoryIndex <= categoryStops size] 34707 whileTrue: 34708 [categoryStops at: categoryIndex put: nextStop. 34709 categoryIndex := categoryIndex + 1]. 34710 elementArray := newElements contents. 34711 self assertInvariant.! ! 34712 34713!Categorizer methodsFor: 'private' stamp: 'NS 4/5/2004 17:44'! 34714elementArray 34715 34716 ^ elementArray! ! 34717 34718!Categorizer methodsFor: 'private' stamp: 'NS 4/6/2004 13:51'! 34719firstIndexOfCategoryNumber: anInteger 34720 anInteger < 1 ifTrue: [^ nil]. 34721 ^ (anInteger > 1 34722 ifTrue: [(categoryStops at: anInteger - 1) + 1] 34723 ifFalse: [1]).! ! 34724 34725!Categorizer methodsFor: 'private' stamp: 'NS 4/6/2004 13:52'! 34726lastIndexOfCategoryNumber: anInteger 34727 anInteger > categoryStops size ifTrue: [^ nil]. 34728 ^ categoryStops at: anInteger! ! 34729 34730!Categorizer methodsFor: 'private' stamp: 'NS 4/5/2004 17:50'! 34731setDefaultList: aSortedCollection 34732 34733 categoryArray := Array with: Default. 34734 categoryStops := Array with: aSortedCollection size. 34735 elementArray := aSortedCollection asArray! ! 34736 34737"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 34738 34739Categorizer class 34740 instanceVariableNames: ''! 34741 34742!Categorizer class methodsFor: 'class initialization' stamp: 'eem 1/7/2009 16:04'! 34743allCategory 34744 "Return a symbol that represents the virtual all methods category." 34745 34746 ^#'-- all --'! ! 34747 34748!Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'! 34749default 34750 ^ Default! ! 34751 34752!Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/6/2004 11:48'! 34753initialize 34754 " self initialize " 34755 34756 Default := 'as yet unclassified' asSymbol. 34757 NullCategory := 'no messages' asSymbol.! ! 34758 34759!Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'! 34760nullCategory 34761 ^ NullCategory! ! 34762 34763 34764!Categorizer class methodsFor: 'documentation' stamp: 'NS 4/5/2004 17:44'! 34765documentation 34766 "Instances consist of an Array of category names (categoryArray), each of 34767 which refers to an Array of elements (elementArray). This association is 34768 made through an Array of stop indices (categoryStops), each of which is 34769 the index in elementArray of the last element (if any) of the 34770 corresponding category. For example: categories := Array with: 'firstCat' 34771 with: 'secondCat' with: 'thirdCat'. stops := Array with: 1 with: 4 with: 4. 34772 elements := Array with: #a with: #b with: #c with: #d. This means that 34773 category firstCat has only #a, secondCat has #b, #c, and #d, and 34774 thirdCat has no elements. This means that stops at: stops size must be the 34775 same as elements size." ! ! 34776 34777 34778!Categorizer class methodsFor: 'housekeeping' stamp: 'NS 4/6/2004 11:48'! 34779sortAllCategories 34780 34781 self allSubInstances 34782 do: [:x | x sortCategories]! ! 34783 34784 34785!Categorizer class methodsFor: 'instance creation' stamp: 'NS 4/5/2004 17:44'! 34786defaultList: aSortedCollection 34787 "Answer an instance of me with initial elements from the argument, 34788 aSortedCollection." 34789 34790 ^self new setDefaultList: aSortedCollection! ! 34791SystemChangeTestRoot subclass: #ChangeHooksTest 34792 instanceVariableNames: 'previousChangeSet testsChangeSet capturedEvents generatedTestClass generatedTestClassX createdMethodName createdMethod doItExpression' 34793 classVariableNames: '' 34794 poolDictionaries: '' 34795 category: 'Tests-SystemChangeNotification'! 34796!ChangeHooksTest commentStamp: 'rw 4/5/2006 17:14' prior: 0! 34797This class implements unit tests to verify that when the system changes, notification messages are sent around correctly. 34798 34799Therefore the test messages make a system change, after registering to receive an event ater the change occured. In this event (sent immediately after the change), the actual assertions take place. 34800 34801Note that the system changes are *really* made to the system, but in a change set that is created in the setUp method, while the previous one is restored in the tearDown method.! 34802 34803 34804!ChangeHooksTest methodsFor: 'events-classes' stamp: 'rw 4/5/2006 17:15'! 34805classCommentedEvent: event 34806 34807 self addSingleEvent: event. 34808 self assert: generatedTestClass comment = self commentStringForTesting. 34809 self 34810 checkEvent: event 34811 kind: #Commented 34812 item: generatedTestClass 34813 itemKind: AbstractEvent classKind! ! 34814 34815!ChangeHooksTest methodsFor: 'events-classes' stamp: 'rw 4/5/2006 17:15'! 34816classCreationEvent: event 34817 34818 | classCreated | 34819 self addSingleEvent: event. 34820 classCreated := Smalltalk classNamed: self newlyCreatedClassName. 34821 self assert: classCreated notNil. 34822 self 34823 assert: ((Smalltalk organization 34824 listAtCategoryNamed: #'System-Change Notification') 34825 includes: self newlyCreatedClassName). 34826 self 34827 checkEvent: event 34828 kind: #Added 34829 item: classCreated 34830 itemKind: AbstractEvent classKind! ! 34831 34832!ChangeHooksTest methodsFor: 'events-classes' stamp: 'rw 4/5/2006 17:15'! 34833classRecategorizedEvent: event 34834 34835 self addSingleEvent: event. 34836 self 34837 checkEvent: event 34838 kind: #Recategorized 34839 item: generatedTestClass 34840 itemKind: AbstractEvent classKind. 34841 self assert: event oldCategory = #'System-Change Notification'! ! 34842 34843!ChangeHooksTest methodsFor: 'events-classes' stamp: 'rw 4/5/2006 17:15'! 34844classRedefinitionEvent: event 34845 34846 self addSingleEvent: event. 34847 self 34848 checkEvent: event 34849 kind: #Modified 34850 item: generatedTestClass 34851 itemKind: AbstractEvent classKind.! ! 34852 34853!ChangeHooksTest methodsFor: 'events-classes' stamp: 'rw 4/5/2006 17:16'! 34854classRemovalEvent: event 34855 "This event used to be sent efter the class was removed. 34856 This was changed, and therefore this test is useless currently." 34857 34858 self addSingleEvent: event. 34859 self assert: (Smalltalk classNamed: self generatedTestClassName) isNil. 34860 self 34861 checkEvent: event 34862 kind: #Removed 34863 item: self generatedTestClassName 34864 itemKind: AbstractEvent classKind! ! 34865 34866!ChangeHooksTest methodsFor: 'events-classes' stamp: 'rw 4/5/2006 17:16'! 34867classRenameEvent: event 34868 34869 | renamedClass | 34870 self addSingleEvent: event. 34871 renamedClass := Smalltalk classNamed: self renamedTestClassName. 34872 self assert: renamedClass notNil. 34873 self assert: (Smalltalk classNamed: self generatedTestClassName) isNil. 34874 self 34875 checkEvent: event 34876 kind: #Renamed 34877 item: renamedClass 34878 itemKind: AbstractEvent classKind. 34879 self assert: event oldName = self generatedTestClassName! ! 34880 34881!ChangeHooksTest methodsFor: 'events-classes' stamp: 'rw 4/5/2006 17:16'! 34882classSuperChangedEvent: event 34883 34884 self addSingleEvent: event. 34885 self 34886 checkEvent: event 34887 kind: #Modified 34888 item: generatedTestClass 34889 itemKind: AbstractEvent classKind. 34890 self assert: generatedTestClass superclass = Model! ! 34891 34892 34893!ChangeHooksTest methodsFor: 'events-expression' stamp: 'rw 4/5/2006 17:16'! 34894methodDoItEvent1: event 34895 34896 self addSingleEvent: event. 34897 self 34898 checkEvent: event 34899 kind: #DoIt 34900 item: doItExpression 34901 itemKind: AbstractEvent expressionKind. 34902 self assert: event context isNil.! ! 34903 34904 34905!ChangeHooksTest methodsFor: 'events-general' stamp: 'rw 8/1/2003 17:11'! 34906rememberEvent: event 34907 34908 capturedEvents add: event! ! 34909 34910!ChangeHooksTest methodsFor: 'events-general' stamp: 'rw 8/1/2003 16:41'! 34911shouldNotBeCalledEvent: anEvent 34912 "This event should not be called, so fail the test." 34913 34914 self assert: false! ! 34915 34916 34917!ChangeHooksTest methodsFor: 'events-instance variables' stamp: 'rw 4/5/2006 17:16'! 34918instanceVariableCreationEvent: event 34919 34920 self addSingleEvent: event. 34921 self assert: event isModified. 34922 self assert: event item = generatedTestClass. 34923 self assert: event itemKind = AbstractEvent classKind. 34924 self assert: event areInstVarsModified. 34925 self deny: event isSuperclassModified. 34926 self deny: event areClassVarsModified. 34927 self deny: event areSharedPoolsModified. 34928 34929! ! 34930 34931!ChangeHooksTest methodsFor: 'events-instance variables' stamp: 'rw 4/5/2006 17:18'! 34932instanceVariableRemovedEvent: event 34933 34934 self addSingleEvent: event. 34935 self assert: event isModified. 34936 self assert: event item = generatedTestClassX. 34937 self assert: event itemKind = AbstractEvent classKind. 34938 self assert: event areInstVarsModified. 34939 self deny: event isSuperclassModified. 34940 self deny: event areClassVarsModified. 34941 self deny: event areSharedPoolsModified. 34942 34943! ! 34944 34945 34946!ChangeHooksTest methodsFor: 'events-methods' stamp: 'rw 4/5/2006 17:18'! 34947methodCreationEvent1: event 34948 34949 | methodCreated | 34950 self addSingleEvent: event. 34951 self shouldnt: [methodCreated := generatedTestClass >> createdMethodName] 34952 raise: Error. 34953 self 34954 checkEvent: event 34955 kind: #Added 34956 item: methodCreated 34957 itemKind: AbstractEvent methodKind! ! 34958 34959!ChangeHooksTest methodsFor: 'events-methods' stamp: 'rw 4/5/2006 17:18'! 34960methodCreationEvent2: event 34961 34962 | methodCreated | 34963 self addSingleEvent: event. 34964 self shouldnt: [methodCreated := generatedTestClass >> createdMethodName] 34965 raise: Error. 34966 self 34967 checkEvent: event 34968 kind: #Added 34969 item: methodCreated 34970 itemKind: AbstractEvent methodKind! ! 34971 34972!ChangeHooksTest methodsFor: 'events-methods' stamp: 'rw 4/5/2006 17:18'! 34973methodRecategorizationEvent: event 34974 34975 | methodCreated | 34976 self addSingleEvent: event. 34977 self shouldnt: [methodCreated := generatedTestClass >> createdMethodName] 34978 raise: Error. 34979 self assert: ((generatedTestClass organization categoryOfElement: createdMethodName) = #newCategory). 34980 self assert: event oldCategory = #testing. 34981 self 34982 checkEvent: event 34983 kind: #Recategorized 34984 item: methodCreated 34985 itemKind: AbstractEvent methodKind.! ! 34986 34987!ChangeHooksTest methodsFor: 'events-methods' stamp: 'rw 4/5/2006 17:18'! 34988methodRemovedEvent1: event 34989 34990 self addSingleEvent: event. 34991 self should: [generatedTestClass >> createdMethodName] raise: Error. 34992 self 34993 checkEvent: event 34994 kind: #Removed 34995 item: createdMethod 34996 itemKind: AbstractEvent methodKind. 34997 event itemClass = generatedTestClass. 34998 event itemMethod = createdMethodName. 34999 self assert: ((generatedTestClass organization categoryOfElement: createdMethodName) isNil).! ! 35000 35001!ChangeHooksTest methodsFor: 'events-methods' stamp: 'rw 4/5/2006 17:18'! 35002methodRemovedEvent2: event 35003 35004 self methodRemovedEvent1: event! ! 35005 35006 35007!ChangeHooksTest methodsFor: 'running' stamp: 'rw 4/4/2006 22:59'! 35008setUp 35009 35010 previousChangeSet := ChangeSet current. 35011 testsChangeSet := ChangeSet new. 35012 ChangeSet newChanges: testsChangeSet. 35013 capturedEvents := OrderedCollection new. 35014 self generateTestClass. 35015 self generateTestClassX. 35016 super setUp! ! 35017 35018!ChangeHooksTest methodsFor: 'running' stamp: 'rw 4/5/2006 17:23'! 35019tearDown 35020 35021 super tearDown. 35022 self removeGeneratedTestClasses. 35023 ChangeSet newChanges: previousChangeSet. 35024 ChangeSorter removeChangeSet: testsChangeSet. 35025 previousChangeSet := nil. 35026 testsChangeSet := nil. 35027! ! 35028 35029 35030!ChangeHooksTest methodsFor: 'testing-classes' stamp: 'rw 4/5/2006 17:19'! 35031testClassCommentedEvent 35032 35033 self systemChangeNotifier notify: self 35034 ofAllSystemChangesUsing: #classCommentedEvent:. 35035 generatedTestClass comment: self commentStringForTesting. 35036 self checkForOnlySingleEvent! ! 35037 35038!ChangeHooksTest methodsFor: 'testing-classes' stamp: 'rw 4/5/2006 17:19'! 35039testClassCreationEvent 35040 35041 self systemChangeNotifier notify: self 35042 ofAllSystemChangesUsing: #classCreationEvent:. 35043 Object 35044 subclass: self newlyCreatedClassName 35045 instanceVariableNames: '' 35046 classVariableNames: '' 35047 poolDictionaries: '' 35048 category: 'System-Change Notification'. 35049 self checkForOnlySingleEvent! ! 35050 35051!ChangeHooksTest methodsFor: 'testing-classes' stamp: 'rw 4/5/2006 17:19'! 35052testClassRecategorizedEvent1 35053 35054 self systemChangeNotifier notify: self 35055 ofAllSystemChangesUsing: #classRecategorizedEvent:. 35056 Object 35057 subclass: generatedTestClass name 35058 instanceVariableNames: '' 35059 classVariableNames: '' 35060 poolDictionaries: '' 35061 category: 'Collections-Abstract'. 35062 self checkForOnlySingleEvent! ! 35063 35064!ChangeHooksTest methodsFor: 'testing-classes' stamp: 'rw 4/5/2006 17:19'! 35065testClassRecategorizedEvent2 35066 35067 self systemChangeNotifier notify: self 35068 ofAllSystemChangesUsing: #classRecategorizedEvent:. 35069 generatedTestClass category: 'Collections-Abstract'. 35070 self checkForOnlySingleEvent! ! 35071 35072!ChangeHooksTest methodsFor: 'testing-classes' stamp: 'rw 4/5/2006 17:19'! 35073testClassRedefinition 35074 35075 self systemChangeNotifier notify: self 35076 ofAllSystemChangesUsing: #classRedefinitionEvent:. 35077 self generateTestClass! ! 35078 35079!ChangeHooksTest methodsFor: 'testing-classes' stamp: 'rw 4/5/2006 17:20'! 35080testClassRemovalEvent 35081 "This event used to be sent efter the class was removed. 35082 This was changed, and therefore this test is useless currently." 35083 35084 "Keep it, since I really want to check with the responsible for the ChangeSet, 35085 and it is very likely this will be reintroduced afterwards!!" 35086 35087" | createdClass | 35088 createdClass := self compileUniqueClass. 35089 self systemChangeNotifier notify: self 35090 ofAllSystemChangesUsing: #classRemovalEvent:. 35091 createdClass removeFromSystem. 35092 self checkForOnlySingleEvent 35093 35094 "! ! 35095 35096!ChangeHooksTest methodsFor: 'testing-classes' stamp: 'rw 4/5/2006 17:20'! 35097testClassRenamedEvent 35098 35099 self systemChangeNotifier notify: self 35100 ofAllSystemChangesUsing: #classRenameEvent:. 35101 generatedTestClass rename: self renamedTestClassName. 35102 self checkForOnlySingleEvent! ! 35103 35104!ChangeHooksTest methodsFor: 'testing-classes' stamp: 'rw 4/5/2006 17:20'! 35105testClassSuperChangedEvent 35106 35107 self systemChangeNotifier notify: self 35108 ofAllSystemChangesUsing: #classSuperChangedEvent:. 35109 Model 35110 subclass: generatedTestClass name 35111 instanceVariableNames: '' 35112 classVariableNames: '' 35113 poolDictionaries: '' 35114 category: 'System-Change Notification'. 35115 self checkForOnlySingleEvent! ! 35116 35117 35118!ChangeHooksTest methodsFor: 'testing-expression' stamp: 'rw 4/5/2006 17:20'! 35119testDoItEvent1 35120 35121 self systemChangeNotifier notify: self 35122 ofAllSystemChangesUsing: #methodDoItEvent1:. 35123 doItExpression := '1 + 2'. 35124 Compiler evaluate: doItExpression logged: true. 35125 self checkForOnlySingleEvent! ! 35126 35127!ChangeHooksTest methodsFor: 'testing-expression' stamp: 'rw 4/5/2006 17:20'! 35128testDoItEvent2 35129 35130 self systemChangeNotifier notify: self 35131 ofAllSystemChangesUsing: #shouldNotBeCalledEvent:. 35132 doItExpression := '1 + 2'. 35133 Compiler evaluate: doItExpression logged: false.! ! 35134 35135 35136!ChangeHooksTest methodsFor: 'testing-instance variables' stamp: 'rw 4/5/2006 17:20'! 35137testInstanceVariableCreationEvent1 35138 35139 self systemChangeNotifier notify: self 35140 ofAllSystemChangesUsing: #instanceVariableCreationEvent:. 35141 Object 35142 subclass: self generatedTestClassName 35143 instanceVariableNames: 'x' 35144 classVariableNames: '' 35145 poolDictionaries: '' 35146 category: 'System-Change Notification'. 35147 self checkForOnlySingleEvent! ! 35148 35149!ChangeHooksTest methodsFor: 'testing-instance variables' stamp: 'rw 4/5/2006 17:17'! 35150testInstanceVariableCreationEvent2 35151 35152 self systemChangeNotifier notify: self 35153 ofAllSystemChangesUsing: #instanceVariableCreationEvent:. 35154 generatedTestClass addInstVarName: 'x'. 35155 self checkForOnlySingleEvent! ! 35156 35157!ChangeHooksTest methodsFor: 'testing-instance variables' stamp: 'rw 4/5/2006 17:18'! 35158testInstanceVariableRemovedEvent1 35159 35160 self systemChangeNotifier notify: self 35161 ofAllSystemChangesUsing: #instanceVariableRemovedEvent:. 35162 Object 35163 subclass: generatedTestClassX name 35164 instanceVariableNames: '' 35165 classVariableNames: '' 35166 poolDictionaries: '' 35167 category: 'System-Change Notification'. 35168 self checkForOnlySingleEvent! ! 35169 35170!ChangeHooksTest methodsFor: 'testing-instance variables' stamp: 'rw 4/5/2006 17:17'! 35171testInstanceVariableRemovedEvent2 35172 35173 self systemChangeNotifier notify: self 35174 ofAllSystemChangesUsing: #instanceVariableRemovedEvent:. 35175 generatedTestClassX removeInstVarName: 'x'. 35176 self checkForOnlySingleEvent! ! 35177 35178!ChangeHooksTest methodsFor: 'testing-instance variables' stamp: 'rw 4/5/2006 17:21'! 35179testInstanceVariableRenamedSilently 35180 35181 self systemChangeNotifier notify: self 35182 ofAllSystemChangesUsing: #shouldNotBeCalledEvent:. 35183 generatedTestClassX renameSilentlyInstVar: 'x' to: 'y'! ! 35184 35185 35186!ChangeHooksTest methodsFor: 'testing-methods' stamp: 'rw 4/5/2006 17:21'! 35187testMethodCreationEvent1 35188 35189 self systemChangeNotifier notify: self 35190 ofAllSystemChangesUsing: #methodCreationEvent1:. 35191 createdMethodName := #testCreation. 35192 generatedTestClass compile: createdMethodName , ' ^1'. 35193 self checkForOnlySingleEvent! ! 35194 35195!ChangeHooksTest methodsFor: 'testing-methods' stamp: 'rw 4/5/2006 17:21'! 35196testMethodCreationEvent2 35197 35198 self systemChangeNotifier notify: self 35199 ofAllSystemChangesUsing: #methodCreationEvent2:. 35200 createdMethodName := #testCreation. 35201 generatedTestClass compile: createdMethodName , ' ^1' classified: #testing. 35202 self checkForOnlySingleEvent! ! 35203 35204!ChangeHooksTest methodsFor: 'testing-methods' stamp: 'rw 4/5/2006 17:21'! 35205testMethodRecategorizationEvent 35206 35207 createdMethodName := #testCreation. 35208 generatedTestClass compile: createdMethodName , ' ^1' classified: #testing. 35209 self systemChangeNotifier notify: self 35210 ofAllSystemChangesUsing: #methodRecategorizationEvent:. 35211 generatedTestClass organization 35212 classify: createdMethodName 35213 under: #newCategory 35214 suppressIfDefault: false. 35215 self checkForOnlySingleEvent! ! 35216 35217!ChangeHooksTest methodsFor: 'testing-methods' stamp: 'rw 4/5/2006 17:21'! 35218testMethodRemovedEvent1 35219 35220 createdMethodName := #testCreation. 35221 generatedTestClass compile: createdMethodName , ' ^1'. 35222 createdMethod := generatedTestClass >> createdMethodName. 35223 self systemChangeNotifier notify: self 35224 ofAllSystemChangesUsing: #methodRemovedEvent1:. 35225 generatedTestClass removeSelector: createdMethodName. 35226 self checkForOnlySingleEvent! ! 35227 35228!ChangeHooksTest methodsFor: 'testing-methods' stamp: 'rw 4/5/2006 17:21'! 35229testMethodRemovedEvent2 35230 35231 createdMethodName := #testCreation. 35232 generatedTestClass compile: createdMethodName , ' ^1'. 35233 createdMethod := generatedTestClass >> createdMethodName. 35234 self systemChangeNotifier notify: self 35235 ofAllSystemChangesUsing: #methodRemovedEvent2:. 35236 Smalltalk 35237 removeSelector: (Array with: generatedTestClass name with: createdMethodName). 35238 self checkForOnlySingleEvent! ! 35239 35240 35241!ChangeHooksTest methodsFor: 'private' stamp: 'rw 8/1/2003 17:03'! 35242addSingleEvent: anEvent 35243 35244 capturedEvents isEmpty ifFalse: [self assert: false]. 35245 capturedEvents add: anEvent! ! 35246 35247!ChangeHooksTest methodsFor: 'private' stamp: 'rw 7/11/2003 09:55'! 35248checkEvent: anEvent kind: changeKind item: item itemKind: itemKind 35249 35250 self assert: (anEvent perform: ('is' , changeKind) asSymbol). 35251 self assert: anEvent item = item. 35252 self assert: anEvent itemKind = itemKind! ! 35253 35254!ChangeHooksTest methodsFor: 'private' stamp: 'rw 8/1/2003 17:01'! 35255checkForOnlySingleEvent 35256 35257 self assert: capturedEvents size = 1! ! 35258 35259!ChangeHooksTest methodsFor: 'private' stamp: 'rw 7/2/2003 18:07'! 35260commentStringForTesting 35261 35262 ^'Added this comment as part of the unit test in SystemChangeTest>>testClassCommentedBasicEvents. You should never see this, unless you are debugging the system somewhere in between the tests.'! ! 35263 35264!ChangeHooksTest methodsFor: 'private' stamp: 'rw 4/5/2006 17:22'! 35265removeGeneratedTestClasses 35266 "Remove all classes that were possibly generated during testing." 35267 35268 | possiblyToRemove | 35269 possiblyToRemove := OrderedCollection 35270 with: self generatedTestClassName 35271 with: self generatedTestClassNameX 35272 with: self renamedTestClassName 35273 with: self newlyCreatedClassName. 35274 possiblyToRemove do: [:name | (Smalltalk hasClassNamed: name) ifTrue: [(Smalltalk at: name) removeFromSystemUnlogged]]! ! 35275 35276 35277!ChangeHooksTest methodsFor: 'private-generation' stamp: 'rw 4/4/2006 21:41'! 35278generateTestClass 35279 35280 generatedTestClass := Object 35281 subclass: self generatedTestClassName 35282 instanceVariableNames: '' 35283 classVariableNames: '' 35284 poolDictionaries: '' 35285 category: 'System-Change Notification'.! ! 35286 35287!ChangeHooksTest methodsFor: 'private-generation' stamp: 'rw 4/4/2006 21:41'! 35288generateTestClassX 35289 35290 generatedTestClassX := Object 35291 subclass: self generatedTestClassNameX 35292 instanceVariableNames: 'x' 35293 classVariableNames: '' 35294 poolDictionaries: '' 35295 category: 'System-Change Notification'.! ! 35296 35297!ChangeHooksTest methodsFor: 'private-generation' stamp: 'rw 4/4/2006 22:10'! 35298generatedTestClassName 35299 35300 35301 ^#'AutoGeneratedClassForTestingSystemChanges'! ! 35302 35303!ChangeHooksTest methodsFor: 'private-generation' stamp: 'rw 4/4/2006 22:10'! 35304generatedTestClassNameX 35305 35306 ^#'AutoGeneratedClassXForTestingSystemChanges'! ! 35307 35308!ChangeHooksTest methodsFor: 'private-generation' stamp: 'rw 4/4/2006 22:18'! 35309newlyCreatedClassName 35310 35311 ^#'AutoGeneratedClassWhileTestingSystemChanges'! ! 35312 35313!ChangeHooksTest methodsFor: 'private-generation' stamp: 'rw 4/4/2006 22:10'! 35314renamedTestClassName 35315 35316 35317 ^#'AutoRenamedClassForTestingSystemChanges'! ! 35318CodeHolder subclass: #ChangeList 35319 instanceVariableNames: 'changeList list listIndex listSelections file lostMethodPointer showsVersions' 35320 classVariableNames: '' 35321 poolDictionaries: '' 35322 category: 'Tools-Changes'! 35323!ChangeList commentStamp: '<historical>' prior: 0! 35324A ChangeList represents a list of changed methods that reside on a file in fileOut format. The classes and methods in my list are not necessarily in this image!! Used as the model for both Version Lists and Changed Methods (in Screen Menu, Changes...). Note that the two kinds of window have different controller classes!!!! 35325 35326It holds three lists: 35327 changeList - a list of ChangeRecords 35328 list - a list of one-line printable headers 35329 listSelections - a list of Booleans (true = selected, false = not selected) multiple OK. 35330 listIndex 35331Items that are removed (removeDoits, remove an item) are removed from all three lists. 35332Most recently clicked item is the one showing in the bottom pane.! 35333 35334 35335!ChangeList methodsFor: '*Polymorph-Tools-Diff-override' stamp: 'gvc 9/2/2008 15:47'! 35336compareToCurrentVersion 35337 "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text" 35338 35339 | change class s1 s2 | 35340 listIndex = 0 35341 ifTrue: [^ self]. 35342 change := changeList at: listIndex. 35343 ((class := change methodClass) notNil 35344 and: [class includesSelector: change methodSelector]) 35345 ifTrue: [s1 := (class sourceCodeAt: change methodSelector) asString. 35346 s2 := change string. 35347 s1 = s2 35348 ifTrue: [^ self inform: 'Exact Match']. 35349 (DiffMorph 35350 from: s2 35351 to: s1 35352 contextClass: class) 35353 openInWindowLabeled: 'Comparison to Current Version'] 35354 ifFalse: [self flash]! ! 35355 35356 35357!ChangeList methodsFor: '*monticello' stamp: 'stephaneducasse 2/4/2006 20:47'! 35358changeTo: changeSubset 35359 | newList newChangeList | 35360 35361 newChangeList := OrderedCollection new. 35362 newList := OrderedCollection new. 35363 35364 1 to: changeList size do: 35365 [:i | (changeSubset includes: (changeList at: i)) ifTrue: 35366 [newChangeList add: (changeList at: i). 35367 newList add: (list at: i)]]. 35368 newChangeList size < changeList size 35369 ifTrue: 35370 [changeList := newChangeList. 35371 list := newList. 35372 listIndex := 0. 35373 listSelections := Array new: list size withAll: false]. 35374 self changed: #list 35375 35376 ! ! 35377 35378 35379!ChangeList methodsFor: 'accessing'! 35380changeList 35381 ^ changeList! ! 35382 35383!ChangeList methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'! 35384changes: changeRecords file: aFile 35385 file := aFile. 35386 changeList := OrderedCollection new. 35387 list := OrderedCollection new. 35388 listIndex := 0. 35389 changeRecords do: [:each | 35390 (each respondsTo: #methodClass) 35391 ifFalse: [self addItem: ChangeRecord new text: each asString] 35392 ifTrue: 35393 [self addItem: each text: ('method: ' , each methodClass name , (each isMetaClassChange ifTrue: [' class '] ifFalse: [' ']) 35394 , each methodSelector 35395 , '; ' , each stamp)]]. 35396 listSelections := Array new: list size withAll: false! ! 35397 35398!ChangeList methodsFor: 'accessing' stamp: 'ls 5/12/1999 07:55'! 35399currentChange 35400 "return the current change being viewed, or nil if none" 35401 listIndex = 0 ifTrue: [ ^nil ]. 35402 ^changeList at: listIndex! ! 35403 35404!ChangeList methodsFor: 'accessing'! 35405file 35406 ^file! ! 35407 35408!ChangeList methodsFor: 'accessing' stamp: 'TPR 11/28/1998 17:38'! 35409listHasSingleEntry 35410 "does the list of changes have only a single item?" 35411 ^list size = 1! ! 35412 35413!ChangeList methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'! 35414listSelections 35415 listSelections ifNil: [ 35416 list ifNotNil: [ 35417 listSelections := Array new: list size withAll: false]]. 35418 ^ listSelections! ! 35419 35420!ChangeList methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'! 35421setLostMethodPointer: sourcePointer 35422 lostMethodPointer := sourcePointer! ! 35423 35424!ChangeList methodsFor: 'accessing' stamp: 'sw 10/19/1999 15:11'! 35425showsVersions 35426 ^ false! ! 35427 35428 35429!ChangeList methodsFor: 'initialization-release' stamp: 'sd 11/20/2005 21:26'! 35430addItem: item text: text 35431 | cr | 35432 cr := Character cr. 35433 changeList addLast: item. 35434 list addLast: (text collect: [:x | x = cr ifTrue: [$/] ifFalse: [x]])! ! 35435 35436!ChangeList methodsFor: 'initialization-release' stamp: 'sw 1/7/2000 12:42'! 35437changeListButtonSpecs 35438 35439 ^#( 35440 ('select all' selectAll 'select all entries') 35441 ('deselect all' deselectAll 'deselect all entries') 35442 ('select conflicts' selectAllConflicts 'select all methods that occur in any change set') 35443 ('file in selections' fileInSelections 'file in all selected entries') 35444 )! ! 35445 35446!ChangeList methodsFor: 'initialization-release' stamp: 'sd 11/20/2005 21:26'! 35447initialize 35448 "Initialize a blank ChangeList. Set the contentsSymbol to reflect whether diffs will initally be shown or not" 35449 35450 contentsSymbol := Preferences diffsInChangeList 35451 ifTrue: 35452 [self defaultDiffsSymbol] 35453 ifFalse: 35454 [#source]. 35455 changeList := OrderedCollection new. 35456 list := OrderedCollection new. 35457 listIndex := 0. 35458 super initialize! ! 35459 35460!ChangeList methodsFor: 'initialization-release' stamp: 'sd 11/20/2005 21:26'! 35461openAsMorphName: labelString multiSelect: multiSelect 35462 "Open a morphic view for the messageSet, whose label is labelString. 35463 The listView may be either single or multiple selection type" 35464 | window listHeight listPane | 35465 listHeight := 0.4. 35466 window := (SystemWindow labelled: labelString) 35467 model: self. 35468 listPane := multiSelect 35469 ifTrue: [PluggableListMorphOfMany 35470 on: self 35471 list: #list 35472 primarySelection: #listIndex 35473 changePrimarySelection: #toggleListIndex: 35474 listSelection: #listSelectionAt: 35475 changeListSelection: #listSelectionAt:put: 35476 menu: (self showsVersions 35477 ifTrue: [#versionsMenu:] 35478 ifFalse: [#changeListMenu:])] 35479 ifFalse: [PluggableListMorph 35480 on: self 35481 list: #list 35482 selected: #listIndex 35483 changeSelected: #toggleListIndex: 35484 menu: (self showsVersions 35485 ifTrue: [#versionsMenu:] 35486 ifFalse: [#changeListMenu:])]. 35487 listPane keystrokeActionSelector: #changeListKey:from:. 35488 window 35489 addMorph: listPane 35490 frame: (0 @ 0 extent: 1 @ listHeight). 35491 self 35492 addLowerPanesTo: window 35493 at: (0 @ listHeight corner: 1 @ 1) 35494 with: nil. 35495 ^ window openInWorld! ! 35496 35497!ChangeList methodsFor: 'initialization-release' stamp: 'nice 4/16/2009 09:39'! 35498optionalButtonRow 35499 "Answer a row of buttons to occur in a tool pane" 35500 35501 | aRow | 35502 aRow := AlignmentMorph newRow. 35503 aRow hResizing: #spaceFill. 35504 aRow clipSubmorphs: true. 35505 aRow layoutInset: 2@2; cellInset: 3. 35506 aRow wrapCentering: #center; cellPositioning: #leftCenter. 35507 self changeListButtonSpecs do: 35508 [:triplet | | aButton | 35509 aButton := PluggableButtonMorph 35510 on: self 35511 getState: nil 35512 action: triplet second. 35513 aButton 35514 hResizing: #spaceFill; 35515 vResizing: #spaceFill; 35516 label: triplet first asString; 35517 askBeforeChanging: true; 35518 onColor: Color white offColor: Color white. 35519 35520 aRow addMorphBack: aButton. 35521 aButton setBalloonText: triplet third]. 35522 aRow addMorphBack: self regularDiffButton. 35523 self wantsPrettyDiffOption ifTrue: 35524 [aRow addMorphBack: self prettyDiffButton]. 35525 ^ aRow! ! 35526 35527!ChangeList methodsFor: 'initialization-release' stamp: 'sw 8/15/2002 22:34'! 35528wantsPrettyDiffOption 35529 "Answer whether pretty-diffs are meaningful for this tool" 35530 35531 ^ true! ! 35532 35533 35534!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35535browseAllVersionsOfSelections 35536 "Opens a Versions browser on all the currently selected methods, showing each alongside all of their historical versions." 35537 | oldSelection aList | 35538 oldSelection := self listIndex. 35539 aList := OrderedCollection new. 35540 Cursor read showWhile: [ 35541 1 to: changeList size do: [:i | 35542 (listSelections at: i) ifTrue: [ 35543 listIndex := i. 35544 self browseVersions. 35545 aList add: i. 35546 ]]]. 35547 listIndex := oldSelection. 35548 35549 aList size == 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts']. 35550! ! 35551 35552!ChangeList methodsFor: 'menu actions' stamp: 'eem 6/11/2008 16:45'! 35553browseCurrentVersionsOfSelections 35554 "Opens a message-list browser on the current in-memory versions of all methods that are currently seleted" 35555 | aList | 35556 35557 aList := OrderedCollection new. 35558 Cursor read showWhile: [ 35559 1 to: changeList size do: [:i | 35560 (listSelections at: i) ifTrue: [ 35561 | aClass aChange | 35562 aChange := changeList at: i. 35563 (aChange type = #method 35564 and: [(aClass := aChange methodClass) notNil 35565 and: [aClass includesSelector: aChange methodSelector]]) 35566 ifTrue: [ 35567 aList add: ( 35568 MethodReference new 35569 setStandardClass: aClass 35570 methodSymbol: aChange methodSelector 35571 ) 35572 ]]]]. 35573 35574 aList size == 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts']. 35575 MessageSet 35576 openMessageList: aList 35577 name: 'Current versions of selected methods in ', file localName! ! 35578 35579!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35580browseVersions 35581 | change class browser | 35582 listIndex = 0 35583 ifTrue: [^ nil ]. 35584 change := changeList at: listIndex. 35585 ((class := change methodClass) notNil 35586 and: [class includesSelector: change methodSelector]) 35587 ifFalse: [ ^nil ]. 35588 browser := super browseVersions. 35589 browser ifNotNil: [ browser addedChangeRecord: change ]. 35590 ^browser! ! 35591 35592!ChangeList methodsFor: 'menu actions' stamp: 'nk 6/2/2006 08:03'! 35593buildMorphicCodePaneWith: editString 35594 35595 | codePane | 35596 35597 codePane := AcceptableCleanTextMorph 35598 on: self 35599 text: #contents 35600 accept: #contents: 35601 readSelection: #contentsSelection 35602 menu: #codePaneMenu:shifted:. 35603 codePane font: Preferences standardCodeFont. 35604 editString ifNotNil: [ 35605 codePane editString: editString. 35606 codePane hasUnacceptedEdits: true 35607 ]. 35608 ^codePane 35609! ! 35610 35611!ChangeList methodsFor: 'menu actions' stamp: 'sw 1/25/2001 07:22'! 35612changeListKey: aChar from: view 35613 "Respond to a Command key in the list pane." 35614 35615 aChar == $D ifTrue: [^ self toggleDiffing]. 35616 aChar == $a ifTrue: [^ self selectAll]. 35617 35618 ^ self arrowKey: aChar from: view! ! 35619 35620!ChangeList methodsFor: 'menu actions' stamp: 'alain.plantec 5/30/2008 10:39'! 35621changeListMenu: aMenu 35622 "Fill aMenu up so that it comprises the primary changelist-browser menu" 35623 35624 aMenu addTitle: 'change list'. 35625 aMenu addStayUpItemSpecial. 35626 35627 aMenu addList: #( 35628 35629 ('fileIn selections' fileInSelections 'import the selected items into the image') 35630 ('fileOut selections... ' fileOutSelections 'create a new file containing the selected items') 35631 - 35632 ('compare to current' compareToCurrentVersion 'open a separate window which shows the text differences between the on-file version and the in-image version.' ) 35633 ('toggle diffing (D)' toggleDiffing 'start or stop showing diffs in the code pane.') 35634 - 35635 ('select conflicts with any changeset' selectAllConflicts 'select methods in the file which also occur in any change-set in the system') 35636 ('select conflicts with current changeset' selectConflicts 'select methods in the file which also occur in the current change-set') 35637 ('select conflicts with...' selectConflictsWith 'allows you to designate a file or change-set against which to check for code conflicts.') 35638 - 35639 ('select unchanged methods' selectUnchangedMethods 'select methods in the file whose in-image versions are the same as their in-file counterparts' ) 35640 ('select new methods' selectNewMethods 'select methods in the file that do not current occur in the image') 35641 ('select methods for this class' selectMethodsForThisClass 'select all methods in the file that belong to the currently-selected class') 35642 35643 - 35644 ('select all (a)' selectAll 'select all the items in the list') 35645 ('deselect all' deselectAll 'deselect all the items in the list') 35646 ('invert selections' invertSelections 'select every item that is not currently selected, and deselect every item that *is* currently selected') 35647 - 35648 ('browse all versions of single selection' browseVersions 'open a version browser showing the versions of the currently selected method') 35649 ('browse all versions of selections' browseAllVersionsOfSelections 'open a version browser showing all the versions of all the selected methods') 35650 ('browse current versions of selections' browseCurrentVersionsOfSelections 'open a message-list browser showing the current (in-image) counterparts of the selected methods') 35651 ('destroy current methods of selections' destroyCurrentCodeOfSelections 'remove (*destroy*) the in-image counterparts of all selected methods') 35652 - 35653 ('remove doIts' removeDoIts 'remove all items that are doIts rather than methods') 35654 ('remove older versions' removeOlderMethodVersions 'remove all but the most recent versions of methods in the list') 35655 ('remove up-to-date versions' removeExistingMethodVersions 'remove all items whose code is the same as the counterpart in-image code') 35656 ('remove selected items' removeSelections 'remove the selected items from the change-list') 35657 ('remove unselected items' removeNonSelections 'remove all the items not currently selected from the change-list')). 35658 35659 ^ aMenu 35660 35661! ! 35662 35663!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35664deselectAll 35665 "Deselect all items in the list pane, and clear the code pane" 35666 35667 listIndex := 0. 35668 listSelections atAllPut: false. 35669 self changed: #allSelections. 35670 self contentsChanged! ! 35671 35672!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35673destroyCurrentCodeOfSelections 35674 "Actually remove from the system any in-memory methods with class and selector identical to items current selected. This may seem rather arcane but believe me it has its great uses, when trying to split out code. To use effectively, first file out a change set that you wish to split off. Then open a ChangeList browser on that fileout. Now look through the methods, and select any of them which you want to remove completely from the system, then issue this command. For those methods where you have made changes to pre-existing versions, of course, you won't want to remove them from the system, so use this mechanism with care!!" 35675 35676 | aClass aChange aList | 35677 aList := OrderedCollection new. 35678 1 to: changeList size do: 35679 [:index | 35680 (listSelections at: index) ifTrue: 35681 [aChange := changeList at: index. 35682 (aChange type = #method 35683 and: [(aClass := aChange methodClass) notNil 35684 and: [aClass includesSelector: aChange methodSelector]]) 35685 ifTrue: 35686 [aList add: {aClass. aChange methodSelector}]]]. 35687 35688 aList size > 0 ifTrue: 35689 [(self confirm: 'Warning!! This will actually remove ', aList size printString, ' method(s) from the system!!') ifFalse: [^ self]]. 35690 aList do: 35691 [:aPair | Transcript cr; show: 'Removed: ', aPair first printString, '.', aPair second. 35692 aPair first removeSelector: aPair second]! ! 35693 35694!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35695fileInSelections 35696 | any | 35697 any := false. 35698 listSelections with: changeList do: 35699 [:selected :item | selected ifTrue: [any := true. item fileIn]]. 35700 any ifFalse: 35701 [self inform: 'nothing selected, so nothing done']! ! 35702 35703!ChangeList methodsFor: 'menu actions' stamp: 'PeterHugossonMiller 9/3/2009 00:17'! 35704fileOutSelections 35705 | fileName internalStream | 35706 fileName := UIManager default request: 'Enter the base of file name' initialAnswer: 'Filename'. 35707 internalStream := (String new: 1000) writeStream. 35708 internalStream header; timeStamp. 35709 listSelections with: changeList do: 35710 [:selected :item | selected ifTrue: [item fileOutOn: internalStream]]. 35711 35712 FileStream writeSourceCodeFrom: internalStream baseName: fileName isSt: true 35713! ! 35714 35715!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35716invertSelections 35717 "Invert the selectedness of each item in the changelist" 35718 35719 listSelections := listSelections collect: [ :ea | ea not]. 35720 listIndex := 0. 35721 self changed: #allSelections. 35722 self contentsChanged! ! 35723 35724!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35725removeDoIts 35726 "Remove doits from the receiver, other than initializes. 1/26/96 sw" 35727 35728 | newChangeList newList | 35729 35730 newChangeList := OrderedCollection new. 35731 newList := OrderedCollection new. 35732 35733 changeList with: list do: 35734 [:chRec :str | 35735 (chRec type ~~ #doIt or: 35736 [str endsWith: 'initialize']) 35737 ifTrue: 35738 [newChangeList add: chRec. 35739 newList add: str]]. 35740 newChangeList size < changeList size 35741 ifTrue: 35742 [changeList := newChangeList. 35743 list := newList. 35744 listIndex := 0. 35745 listSelections := Array new: list size withAll: false]. 35746 self changed: #list. 35747 35748 ! ! 35749 35750!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35751removeExistingMethodVersions 35752 "Remove all up to date version of entries from the receiver" 35753 | newChangeList newList str keep cls sel | 35754 newChangeList := OrderedCollection new. 35755 newList := OrderedCollection new. 35756 35757 changeList with: list do:[:chRec :strNstamp | 35758 keep := true. 35759 (cls := chRec methodClass) ifNotNil:[ 35760 str := chRec string. 35761 sel := cls parserClass new parseSelector: str. 35762 keep := (cls sourceCodeAt: sel ifAbsent:['']) asString ~= str. 35763 ]. 35764 keep ifTrue:[ 35765 newChangeList add: chRec. 35766 newList add: strNstamp]]. 35767 newChangeList size < changeList size 35768 ifTrue: 35769 [changeList := newChangeList. 35770 list := newList. 35771 listIndex := 0. 35772 listSelections := Array new: list size withAll: false]. 35773 self changed: #list! ! 35774 35775!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35776removeNonSelections 35777 "Remove the unselected items from the receiver." 35778 35779 | newChangeList newList | 35780 35781 newChangeList := OrderedCollection new. 35782 newList := OrderedCollection new. 35783 35784 1 to: changeList size do: 35785 [:i | (listSelections at: i) ifTrue: 35786 [newChangeList add: (changeList at: i). 35787 newList add: (list at: i)]]. 35788 newChangeList size == 0 ifTrue: 35789 [^ self inform: 'That would remove everything. 35790Why would you want to do that?']. 35791 35792 newChangeList size < changeList size 35793 ifTrue: 35794 [changeList := newChangeList. 35795 list := newList. 35796 listIndex := 0. 35797 listSelections := Array new: list size withAll: false]. 35798 self changed: #list 35799 35800 ! ! 35801 35802!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35803removeOlderMethodVersions 35804 "Remove older versions of entries from the receiver." 35805 | newChangeList newList found str | 35806 newChangeList := OrderedCollection new. 35807 newList := OrderedCollection new. 35808 found := OrderedCollection new. 35809 35810 changeList reverseWith: list do: 35811 [:chRec :strNstamp | str := strNstamp copyUpTo: $;. 35812 (found includes: str) 35813 ifFalse: 35814 [found add: str. 35815 newChangeList add: chRec. 35816 newList add: strNstamp]]. 35817 newChangeList size < changeList size 35818 ifTrue: 35819 [changeList := newChangeList reversed. 35820 list := newList reversed. 35821 listIndex := 0. 35822 listSelections := Array new: list size withAll: false]. 35823 self changed: #list! ! 35824 35825!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35826removeSelections 35827 "Remove the selected items from the receiver. 9/18/96 sw" 35828 35829 | newChangeList newList | 35830 35831 newChangeList := OrderedCollection new. 35832 newList := OrderedCollection new. 35833 35834 1 to: changeList size do: 35835 [:i | (listSelections at: i) ifFalse: 35836 [newChangeList add: (changeList at: i). 35837 newList add: (list at: i)]]. 35838 newChangeList size < changeList size 35839 ifTrue: 35840 [changeList := newChangeList. 35841 list := newList. 35842 listIndex := 0. 35843 listSelections := Array new: list size withAll: false]. 35844 self changed: #list 35845 35846 ! ! 35847 35848!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35849selectAll 35850 listIndex := 0. 35851 listSelections atAllPut: true. 35852 self changed: #allSelections! ! 35853 35854!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35855selectAllConflicts 35856 "Selects all method definitions in the receiver which are also in any existing change set in the system. This makes no statement about whether the content of the methods differ, only whether there is a change represented." 35857 35858 | aClass aChange | 35859 Cursor read showWhile: 35860 [1 to: changeList size do: 35861 [:i | aChange := changeList at: i. 35862 listSelections at: i put: 35863 (aChange type = #method 35864 and: [(aClass := aChange methodClass) notNil 35865 and: [ChangeSorter doesAnyChangeSetHaveClass: aClass andSelector: aChange methodSelector]])]]. 35866 self changed: #allSelections! ! 35867 35868!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35869selectConflicts 35870 "Selects all method definitions for which there is ALSO an entry in changes" 35871 | change class | 35872 Cursor read showWhile: 35873 [1 to: changeList size do: 35874 [:i | change := changeList at: i. 35875 listSelections at: i put: 35876 (change type = #method 35877 and: [(class := change methodClass) notNil 35878 and: [(ChangeSet current atSelector: change methodSelector 35879 class: class) ~~ #none]])]]. 35880 self changed: #allSelections! ! 35881 35882!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35883selectConflicts: changeSetOrList 35884 "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList" 35885 | change class systemChanges | 35886 Cursor read showWhile: 35887 [(changeSetOrList isKindOf: ChangeSet) ifTrue: [ 35888 1 to: changeList size do: 35889 [:i | change := changeList at: i. 35890 listSelections at: i put: 35891 (change type = #method 35892 and: [(class := change methodClass) notNil 35893 and: [(changeSetOrList atSelector: change methodSelector 35894 class: class) ~~ #none]])]] 35895 ifFalse: ["a ChangeList" 35896 1 to: changeList size do: 35897 [:i | change := changeList at: i. 35898 listSelections at: i put: 35899 (change type = #method 35900 and: [(class := change methodClass) notNil 35901 and: [changeSetOrList list includes: (list at: i)]])]] 35902 ]. 35903 self changed: #allSelections! ! 35904 35905!ChangeList methodsFor: 'menu actions' stamp: 'PeterHugossonMiller 9/3/2009 00:17'! 35906selectConflictsWith 35907 "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList chosen by the user. 4/11/96 tk" 35908 | aStream all index | 35909 aStream := (String new: 200) writeStream. 35910 (all := ChangeSorter allChangeSets copy) do: 35911 [:sel | aStream nextPutAll: (sel name contractTo: 40); cr]. 35912 ChangeList allSubInstancesDo: 35913 [:sel | aStream nextPutAll: (sel file name); cr. 35914 all addLast: sel]. 35915 aStream skip: -1. 35916 index := (UIManager default chooseFrom: (aStream contents substrings)). 35917 index > 0 ifTrue: [ 35918 self selectConflicts: (all at: index)]. 35919! ! 35920 35921!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35922selectMethodsForThisClass 35923 | name | 35924 self currentChange ifNil: [ ^self ]. 35925 name := self currentChange methodClassName. 35926 name ifNil: [ ^self ]. 35927 ^self selectSuchThat: [ :change | 35928 change methodClassName = name ].! ! 35929 35930!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35931selectNewMethods 35932 "Selects all method definitions for which there is no counterpart method in the current image" 35933 35934 | change class | 35935 Cursor read showWhile: 35936 [1 to: changeList size do: 35937 [:i | change := changeList at: i. 35938 listSelections at: i put: 35939 ((change type = #method and: 35940 [((class := change methodClass) isNil) or: 35941 [(class includesSelector: change methodSelector) not]]))]]. 35942 self changed: #allSelections! ! 35943 35944!ChangeList methodsFor: 'menu actions' stamp: 'DamienCassou 9/23/2009 08:33'! 35945selectSuchThat 35946 "query the user for a selection criterio. By Lex Spoon. NB: the UI for invoking this from a changelist browser is currently commented out; to reenfranchise it, you'll need to mild editing to ChangeList method #changeListMenu:" 35947 | code block | 35948 code := UIManager default request: 'selection criteria for a change named aChangeRecord?\For instance, ''aChangeRecord category = ''System-Network''''' withCRs. 35949 35950 code isEmptyOrNil ifTrue: [^ self ]. 35951 35952 block := Compiler evaluate: '[:aChangeRecord | ', code, ']'. 35953 35954 self selectSuchThat: block! ! 35955 35956!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35957selectSuchThat: aBlock 35958 "select all changes for which block returns true" 35959 listSelections := changeList collect: [ :change | aBlock value: change ]. 35960 self changed: #allSelections! ! 35961 35962!ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! 35963selectUnchangedMethods 35964 "Selects all method definitions for which there is already a method in the current image, whose source is exactly the same. 9/18/96 sw" 35965 | change class | 35966 Cursor read showWhile: 35967 [1 to: changeList size do: 35968 [:i | change := changeList at: i. 35969 listSelections at: i put: 35970 ((change type = #method and: 35971 [(class := change methodClass) notNil]) and: 35972 [(class includesSelector: change methodSelector) and: 35973 [change string withBlanksCondensed = (class sourceCodeAt: change methodSelector) asString withBlanksCondensed ]])]]. 35974 self changed: #allSelections! ! 35975 35976 35977!ChangeList methodsFor: 'scanning' stamp: 'sd 11/20/2005 21:26'! 35978scanCategory 35979 "Scan anything that involves more than one chunk; method name is historical only" 35980 35981 | itemPosition item tokens stamp isComment anIndex | 35982 itemPosition := file position. 35983 item := file nextChunk. 35984 35985 isComment := (item includesSubString: 'commentStamp:'). 35986 (isComment or: [item includesSubString: 'methodsFor:']) ifFalse: 35987 ["Maybe a preamble, but not one we recognize; bail out with the preamble trick" 35988 ^ self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble) 35989 text: ('preamble: ' , item contractTo: 50)]. 35990 35991 tokens := Scanner new scanTokens: item. 35992 tokens size >= 3 ifTrue: 35993 [stamp := ''. 35994 anIndex := tokens indexOf: #stamp: ifAbsent: [nil]. 35995 anIndex ifNotNil: [stamp := tokens at: (anIndex + 1)]. 35996 35997 tokens second == #methodsFor: 35998 ifTrue: [^ self scanCategory: tokens third class: tokens first 35999 meta: false stamp: stamp]. 36000 tokens third == #methodsFor: 36001 ifTrue: [^ self scanCategory: tokens fourth class: tokens first 36002 meta: true stamp: stamp]]. 36003 36004 tokens second == #commentStamp: 36005 ifTrue: 36006 [stamp := tokens third. 36007 self addItem: 36008 (ChangeRecord new file: file position: file position type: #classComment 36009 class: tokens first category: nil meta: false stamp: stamp) 36010 text: 'class comment for ' , tokens first, 36011 (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]). 36012 file nextChunk. 36013 ^ file skipStyleChunk]! ! 36014 36015!ChangeList methodsFor: 'scanning' stamp: 'md 2/21/2006 09:42'! 36016scanCategory: category class: class meta: meta stamp: stamp 36017 | itemPosition method | 36018 [itemPosition := file position. 36019 method := file nextChunk. 36020 file skipStyleChunk. 36021 method size > 0] "done when double terminators" 36022 whileTrue: 36023 [self addItem: (ChangeRecord new file: file position: itemPosition type: #method 36024 class: class category: category meta: meta stamp: stamp) 36025 text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) 36026 , (self class parserClass new parseSelector: method) 36027 , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! ! 36028 36029!ChangeList methodsFor: 'scanning' stamp: 'sd 11/20/2005 21:26'! 36030scanFile: aFile from: startPosition to: stopPosition 36031 | itemPosition item prevChar | 36032 file := aFile. 36033 changeList := OrderedCollection new. 36034 list := OrderedCollection new. 36035 listIndex := 0. 36036 file position: startPosition. 36037'Scanning ', aFile localName, '...' 36038 displayProgressAt: Sensor cursorPoint 36039 from: startPosition to: stopPosition 36040 during: [:bar | 36041 [file position < stopPosition] 36042 whileTrue: 36043 [bar value: file position. 36044 [file atEnd not and: [file peek isSeparator]] 36045 whileTrue: [prevChar := file next]. 36046 (file peekFor: $!!) 36047 ifTrue: 36048 [(prevChar = Character cr or: [prevChar = Character lf]) 36049 ifTrue: [self scanCategory]] 36050 ifFalse: 36051 [itemPosition := file position. 36052 item := file nextChunk. 36053 file skipStyleChunk. 36054 item size > 0 ifTrue: 36055 [self addItem: (ChangeRecord new file: file position: itemPosition type: #doIt) 36056 text: 'do it: ' , (item contractTo: 50)]]]]. 36057 listSelections := Array new: list size withAll: false! ! 36058 36059 36060!ChangeList methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 13:50'! 36061buildWith: builder 36062 ^self buildWith: builder multiSelect: true! ! 36063 36064!ChangeList methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:46'! 36065buildWith: builder multiSelect: multiSelect 36066 "Open a morphic view for the messageSet, whose label is labelString. 36067 The listView may be either single or multiple selection type" 36068 36069 | windowSpec max listSpec panelSpec textSpec | 36070 windowSpec := builder pluggableWindowSpec new. 36071 windowSpec model: self. 36072 windowSpec label: 'System Browser'. 36073 windowSpec children: OrderedCollection new. 36074 36075 max := self wantsOptionalButtons ifTrue:[0.33] ifFalse:[0.4]. 36076 36077 multiSelect ifTrue:[ 36078 listSpec := builder pluggableMultiSelectionListSpec new. 36079 listSpec getSelectionList: #listSelectionAt:. 36080 listSpec setSelectionList: #listSelectionAt:put:. 36081 ] ifFalse:[ 36082 listSpec := builder pluggableListSpec new. 36083 ]. 36084 36085 listSpec 36086 model: self; 36087 list: #list; 36088 getIndex: #listIndex; 36089 setIndex: #toggleListIndex:; 36090 menu: (self showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:]); 36091 keyPress: #changeListKey:from:; 36092 frame: (0@0 corner: 1@max). 36093 windowSpec children add: listSpec. 36094 36095 self wantsOptionalButtons ifTrue:[ 36096 panelSpec := self buildOptionalButtonsWith: builder. 36097 panelSpec frame: (0@0.33 corner: 1@0.4). 36098 windowSpec children add: panelSpec. 36099 ]. 36100 36101 textSpec := builder pluggableTextSpec new. 36102 textSpec 36103 model: self; 36104 getText: #contents; 36105 setText: #contents:; 36106 selection: #contentsSelection; 36107 menu: #codePaneMenu:shifted:; 36108 frame: (0@0.4corner: 1@1). 36109 windowSpec children add: textSpec. 36110 36111 ^builder build: windowSpec! ! 36112 36113 36114!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'! 36115annotation 36116 "Answer the string to be shown in an annotation pane. Make plain that the annotation is associated with the current in-image version of the code, not of the selected disk-based version, and if the corresponding method is missing from the in-image version, mention that fact." 36117 36118 | annot aChange aClass | 36119 36120 annot := super annotation. 36121 annot asString = '------' ifTrue: [^ annot]. 36122 36123 ^ ((aChange := self currentChange) notNil and: [aChange methodSelector notNil]) 36124 ifFalse: 36125 [annot] 36126 ifTrue: 36127 [((aClass := aChange methodClass) isNil or: [(aClass includesSelector: aChange methodSelector) not]) 36128 ifTrue: 36129 [aChange methodClassName, ' >> ', aChange methodSelector, ' is not present in the current image.'] 36130 ifFalse: 36131 ['current version: ', annot]]! ! 36132 36133!ChangeList methodsFor: 'viewing access' stamp: 'sw 9/5/2001 13:52'! 36134contents 36135 "Answer the contents string, obeying diffing directives if needed" 36136 36137 ^ self showingAnyKindOfDiffs 36138 ifFalse: 36139 [self undiffedContents] 36140 ifTrue: 36141 [self showsVersions 36142 ifTrue: 36143 [self diffedVersionContents] 36144 ifFalse: 36145 [self contentsDiffedFromCurrent]]! ! 36146 36147!ChangeList methodsFor: 'viewing access' stamp: 'tk 4/10/1998 09:25'! 36148contents: aString 36149 listIndex = 0 ifTrue: [self changed: #flash. ^ false]. 36150 lostMethodPointer ifNotNil: [^ self restoreDeletedMethod]. 36151 self okToChange "means not dirty" ifFalse: ["is dirty" 36152 self inform: 'This is a view of a method on a file.\Please cancel your changes. You may\accept, but only when the method is untouched.' withCRs. ^ false]. 36153 "Can't accept changes here. Method text must be unchanged!!" 36154 (changeList at: listIndex) fileIn. 36155 ^ true! ! 36156 36157!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'! 36158contentsDiffedFromCurrent 36159 "Answer the contents diffed forward from current (in-memory) method version" 36160 36161 | aChange aClass | 36162 listIndex = 0 36163 ifTrue: [^ '']. 36164 aChange := changeList at: listIndex. 36165 ^ ((aChange type == #method and: [(aClass := aChange methodClass) notNil]) and: [aClass includesSelector: aChange methodSelector]) 36166 ifTrue: 36167 [Utilities methodDiffFor: aChange text class: aClass selector: aChange methodSelector prettyDiffs: self showingPrettyDiffs] 36168 ifFalse: 36169 [(changeList at: listIndex) text]! ! 36170 36171!ChangeList methodsFor: 'viewing access' stamp: 'sw 11/13/2001 09:12'! 36172contentsSymbolQuints 36173 "Answer a list of quintuplets representing information on the alternative views available in the code pane" 36174 36175 ^ self sourceAndDiffsQuintsOnly! ! 36176 36177!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'! 36178diffedVersionContents 36179 "Answer diffed version contents, maybe pretty maybe not" 36180 36181 | change class earlier later | 36182 (listIndex = 0 36183 or: [changeList size < listIndex]) 36184 ifTrue: [^ '']. 36185 change := changeList at: listIndex. 36186 later := change text. 36187 class := change methodClass. 36188 (listIndex == changeList size or: [class == nil]) 36189 ifTrue: [^ later]. 36190 36191 earlier := (changeList at: listIndex + 1) text. 36192 36193 ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! ! 36194 36195!ChangeList methodsFor: 'viewing access'! 36196list 36197 ^ list! ! 36198 36199!ChangeList methodsFor: 'viewing access'! 36200listIndex 36201 ^ listIndex! ! 36202 36203!ChangeList methodsFor: 'viewing access'! 36204listSelectionAt: index 36205 ^ listSelections at: index! ! 36206 36207!ChangeList methodsFor: 'viewing access' stamp: 'di 1/13/1999 14:59'! 36208listSelectionAt: index put: value 36209 36210 ^ listSelections at: index put: value! ! 36211 36212!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'! 36213restoreDeletedMethod 36214 "If lostMethodPointer is not nil, then this is a version browser for a method that has been removed. In this case we want to establish a sourceCode link to prior versions. We do this by installing a dummy method with the correct source code pointer prior to installing this version." 36215 | dummyMethod class selector | 36216 dummyMethod := CompiledMethod toReturnSelf setSourcePointer: lostMethodPointer. 36217 class := (changeList at: listIndex) methodClass. 36218 selector := (changeList at: listIndex) methodSelector. 36219 class addSelectorSilently: selector withMethod: dummyMethod. 36220 (changeList at: listIndex) fileIn. 36221 "IF for some reason, the dummy remains, remove it, but (N.B.!!) we might not get control back if the compile (fileIn above) fails." 36222 (class compiledMethodAt: selector) == dummyMethod 36223 ifTrue: [class basicRemoveSelector: selector]. 36224 ^ true! ! 36225 36226!ChangeList methodsFor: 'viewing access' stamp: 'nk 2/26/2004 13:50'! 36227selectedClass 36228 ^(self selectedClassOrMetaClass ifNil: [ ^nil ]) theNonMetaClass ! ! 36229 36230!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'! 36231selectedClassOrMetaClass 36232 | c | 36233 ^ (c := self currentChange) ifNotNil: [c methodClass]! ! 36234 36235!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'! 36236selectedMessageName 36237 | c | 36238 ^ (c := self currentChange) ifNotNil: [c methodSelector]! ! 36239 36240!ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'! 36241toggleListIndex: newListIndex 36242 36243 listIndex ~= 0 ifTrue: [listSelections at: listIndex put: false]. 36244 newListIndex ~= 0 ifTrue: [listSelections at: newListIndex put: true]. 36245 listIndex := newListIndex. 36246 self changed: #listIndex. 36247 self contentsChanged! ! 36248 36249!ChangeList methodsFor: 'viewing access' stamp: 'sw 1/25/1999 14:45'! 36250undiffedContents 36251 ^ listIndex = 0 36252 ifTrue: [''] 36253 ifFalse: [(changeList at: listIndex) text]! ! 36254 36255"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 36256 36257ChangeList class 36258 instanceVariableNames: ''! 36259 36260!ChangeList class methodsFor: '*monticello' stamp: 'ar 8/6/2009 18:46'! 36261recentLogOn: origChangesFile startingFrom: initialPos 36262 "Prompt with a menu of how far back to go when browsing a changes file." 36263 36264 | end banners positions pos chunk i changesFile | 36265 changesFile := origChangesFile readOnlyCopy. 36266 banners := OrderedCollection new. 36267 positions := OrderedCollection new. 36268 end := changesFile size. 36269 pos := initialPos. 36270 [pos = 0 36271 or: [banners size > 20]] 36272 whileFalse: [changesFile position: pos. 36273 chunk := changesFile nextChunk. 36274 i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. 36275 i > 0 36276 ifTrue: [positions addLast: pos. 36277 banners 36278 addLast: (chunk copyFrom: 5 to: i - 2). 36279 pos := Number 36280 readFrom: (chunk copyFrom: i + 13 to: chunk size)] 36281 ifFalse: [pos := 0]]. 36282 changesFile close. 36283 banners size == 0 ifTrue: [^self recent: end on: origChangesFile]. 36284 36285 pos := UIManager default chooseFrom: banners values: positions 36286 title: 'Browse as far back as...'. 36287 pos == nil 36288 ifTrue: [^ self]. 36289 ^self recent: end - pos on: origChangesFile! ! 36290 36291!ChangeList class methodsFor: '*monticello' stamp: 'stephaneducasse 2/4/2006 20:47'! 36292recent: charCount on: origChangesFile 36293 "Opens a changeList on the end of the specified changes log file" 36294 | changeList end changesFile | 36295 changesFile := origChangesFile readOnlyCopy. 36296 end := changesFile size. 36297 Cursor read 36298 showWhile: [changeList := self new 36299 scanFile: changesFile 36300 from: (0 max: end - charCount) 36301 to: end]. 36302 changesFile close. 36303 ^changeList! ! 36304 36305 36306!ChangeList class methodsFor: 'filein/out' stamp: 'md 10/22/2003 16:13'! 36307browseChangesFile: fullName 36308 "Browse the selected file in fileIn format." 36309 36310 fullName 36311 ifNotNil: 36312 [ChangeList browseStream: (FileStream readOnlyFileNamed: fullName)] 36313 ifNil: 36314 [Beeper beep]! ! 36315 36316!ChangeList class methodsFor: 'filein/out' stamp: 'tak 3/16/2005 11:46'! 36317browseCompressedChangesFile: fullName 36318 "Browse the selected file in fileIn format." 36319 36320 | zipped unzipped stream | 36321 fullName ifNil: [^Beeper beep]. 36322 stream := FileStream readOnlyFileNamed: fullName. 36323 [stream converter: Latin1TextConverter new. 36324 zipped := GZipReadStream on: stream. 36325 unzipped := zipped contents asString] 36326 ensure: [stream close]. 36327 stream := (MultiByteBinaryOrTextStream with: unzipped) reset. 36328 ChangeList browseStream: stream! ! 36329 36330!ChangeList class methodsFor: 'filein/out' stamp: 'sd 11/20/2005 21:28'! 36331fileReaderServicesForFile: fullName suffix: suffix 36332 | services | 36333 services := OrderedCollection new. 36334 (FileStream isSourceFileSuffix: suffix) | (suffix = '*') 36335 ifTrue: [ services add: self serviceBrowseChangeFile ]. 36336 (suffix = 'changes') | (suffix = '*') 36337 ifTrue: [ services add: self serviceBrowseDotChangesFile ]. 36338 (fullName asLowercase endsWith: '.cs.gz') | (suffix = '*') 36339 ifTrue: [ services add: self serviceBrowseCompressedChangeFile ]. 36340 ^services! ! 36341 36342!ChangeList class methodsFor: 'filein/out' stamp: 'nk 4/29/2004 10:35'! 36343serviceBrowseChangeFile 36344 "Answer a service for opening a changelist browser on a file" 36345 36346 ^ (SimpleServiceEntry 36347 provider: self 36348 label: 'changelist browser' 36349 selector: #browseStream: 36350 description: 'open a changelist tool on this file' 36351 buttonLabel: 'changes') 36352 argumentGetter: [ :fileList | fileList readOnlyStream ]! ! 36353 36354!ChangeList class methodsFor: 'filein/out' stamp: 'nk 12/13/2002 12:03'! 36355serviceBrowseCompressedChangeFile 36356 "Answer a service for opening a changelist browser on a file" 36357 36358 ^ SimpleServiceEntry 36359 provider: self 36360 label: 'changelist browser' 36361 selector: #browseCompressedChangesFile: 36362 description: 'open a changelist tool on this file' 36363 buttonLabel: 'changes'! ! 36364 36365!ChangeList class methodsFor: 'filein/out' stamp: 'sw 7/4/2002 18:37'! 36366serviceBrowseDotChangesFile 36367 "Answer a service for opening a changelist browser on the tail end of a .changes file" 36368 36369 ^ SimpleServiceEntry 36370 provider: self 36371 label: 'recent changes in file' 36372 selector: #browseRecentLogOnPath: 36373 description: 'open a changelist tool on recent changes in file' 36374 buttonLabel: 'recent changes'! ! 36375 36376!ChangeList class methodsFor: 'filein/out' stamp: 'nk 12/13/2002 12:04'! 36377services 36378 "Answer potential file services associated with this class" 36379 36380 ^ { self serviceBrowseChangeFile. 36381 self serviceBrowseDotChangesFile. 36382 self serviceBrowseCompressedChangeFile }! ! 36383 36384 36385!ChangeList class methodsFor: 'initialization' stamp: 'GabrielOmarCotelli 6/4/2009 20:38'! 36386unload 36387 36388 FileServices unregisterFileReader: self ! ! 36389 36390 36391!ChangeList class methodsFor: 'initialize-release' stamp: 'GabrielOmarCotelli 6/4/2009 20:38'! 36392initialize 36393 36394 FileServices registerFileReader: self! ! 36395 36396 36397!ChangeList class methodsFor: 'instance creation' stamp: 'alain.plantec 5/30/2008 10:41'! 36398open: aChangeList name: aString multiSelect: multiSelect 36399 "Create a standard system view for the messageSet, whose label is aString. 36400 The listView may be either single or multiple selection type" 36401 ^ self openAsMorph: aChangeList name: aString multiSelect: multiSelect. 36402! ! 36403 36404!ChangeList class methodsFor: 'instance creation' stamp: 'RAA 1/11/2001 08:20'! 36405openAsMorph: aChangeList name: labelString multiSelect: multiSelect 36406 "Open a morphic view for the messageSet, whose label is labelString. 36407 The listView may be either single or multiple selection type" 36408 36409 ^aChangeList openAsMorphName: labelString multiSelect: multiSelect 36410! ! 36411 36412 36413!ChangeList class methodsFor: 'public access' stamp: 'di 1/18/2001 15:30'! 36414browseFile: fileName "ChangeList browseFile: 'AutoDeclareFix.st'" 36415 "Opens a changeList on the file named fileName" 36416 36417 ^ self browseStream: (FileStream readOnlyFileNamed: fileName)! ! 36418 36419!ChangeList class methodsFor: 'public access' stamp: 'tak 9/25/2008 16:25'! 36420browseRecent: charCount 36421 "ChangeList browseRecent: 5000" 36422 "Opens a changeList on the end of the changes log file" 36423 "The core was moved to browserRecent:on:." 36424 ^ self browseRecent: charCount on: (SourceFiles at: 2) ! ! 36425 36426!ChangeList class methodsFor: 'public access' stamp: 'sd 11/20/2005 21:28'! 36427browseRecent: charCount on: origChangesFile 36428 "Opens a changeList on the end of the specified changes log file" 36429 | changeList end changesFile | 36430 changesFile := origChangesFile readOnlyCopy. 36431 changesFile setConverterForCode. 36432 end := changesFile size. 36433 Cursor read 36434 showWhile: [changeList := self new 36435 scanFile: changesFile 36436 from: (0 max: end - charCount) 36437 to: end]. 36438 changesFile close. 36439 self 36440 open: changeList 36441 name: 'Recent changes' 36442 multiSelect: true! ! 36443 36444!ChangeList class methodsFor: 'public access' stamp: 'sd 11/16/2003 14:10'! 36445browseRecentLog 36446 "ChangeList browseRecentLog" 36447 "Prompt with a menu of how far back to go to browse the current image's changes log file" 36448 ^ self 36449 browseRecentLogOn: (SourceFiles at: 2) 36450 startingFrom: SmalltalkImage current lastQuitLogPosition! ! 36451 36452!ChangeList class methodsFor: 'public access' stamp: 'sd 11/20/2005 21:28'! 36453browseRecentLogOn: origChangesFile 36454 "figure out where the last snapshot or quit was, then browse the recent entries." 36455 36456 | end done block pos chunk changesFile positions prevBlock | 36457 changesFile := origChangesFile readOnlyCopy. 36458 positions := SortedCollection new. 36459 end := changesFile size. 36460 prevBlock := end. 36461 block := end - 1024 max: 0. 36462 done := false. 36463 [done 36464 or: [positions size > 0]] 36465 whileFalse: [changesFile position: block. 36466 "ignore first fragment" 36467 changesFile nextChunk. 36468 [changesFile position < prevBlock] 36469 whileTrue: [pos := changesFile position. 36470 chunk := changesFile nextChunk. 36471 ((chunk indexOfSubCollection: '----' startingAt: 1) = 1) ifTrue: [ 36472 ({ '----QUIT'. '----SNAPSHOT' } anySatisfy: [ :str | 36473 chunk beginsWith: str ]) 36474 ifTrue: [positions add: pos]]]. 36475 block = 0 36476 ifTrue: [done := true] 36477 ifFalse: [prevBlock := block. 36478 block := block - 1024 max: 0]]. 36479 changesFile close. 36480 positions isEmpty 36481 ifTrue: [self inform: 'File ' , changesFile name , ' does not appear to be a changes file'] 36482 ifFalse: [self browseRecentLogOn: origChangesFile startingFrom: positions last]! ! 36483 36484!ChangeList class methodsFor: 'public access' stamp: 'alain.plantec 2/6/2009 16:37'! 36485browseRecentLogOn: origChangesFile startingFrom: initialPos 36486 "Prompt with a menu of how far back to go when browsing a changes file." 36487 36488 | end banners positions pos chunk i changesFile | 36489 changesFile := origChangesFile readOnlyCopy. 36490 banners := OrderedCollection new. 36491 positions := OrderedCollection new. 36492 end := changesFile size. 36493 changesFile setConverterForCode. 36494 pos := initialPos. 36495 [pos = 0 36496 or: [banners size > 20]] 36497 whileFalse: [changesFile position: pos. 36498 chunk := changesFile nextChunk. 36499 i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. 36500 i > 0 36501 ifTrue: [positions addLast: pos. 36502 banners 36503 addLast: (chunk copyFrom: 5 to: i - 2). 36504 pos := Number 36505 readFrom: (chunk copyFrom: i + 13 to: chunk size)] 36506 ifFalse: [pos := 0]]. 36507 changesFile close. 36508 banners size == 0 ifTrue: [^ self inform: 36509'this image has never been saved 36510since changes were compressed' translated]. 36511 pos := UIManager default chooseFrom: banners values: positions title: 'Browse as far back as...' translated. 36512 pos isNil ifTrue: [^ self]. 36513 self browseRecent: end - pos on: origChangesFile! ! 36514 36515!ChangeList class methodsFor: 'public access' stamp: 'nb 6/17/2003 12:25'! 36516browseRecentLogOnPath: fullName 36517 "figure out where the last snapshot or quit was, then browse the recent entries." 36518 36519 fullName 36520 ifNotNil: 36521 [self browseRecentLogOn: (FileStream readOnlyFileNamed: fullName)] 36522 ifNil: 36523 [Beeper beep] 36524 ! ! 36525 36526!ChangeList class methodsFor: 'public access' stamp: 'sd 11/20/2005 21:28'! 36527browseStream: changesFile 36528 "Opens a changeList on a fileStream" 36529 | changeList charCount | 36530 changesFile readOnly. 36531 changesFile setConverterForCode. 36532 charCount := changesFile size. 36533 charCount > 1000000 ifTrue: 36534 [(self confirm: 'The file ', changesFile name , ' 36535is really long (' , charCount printString , ' characters). 36536Would you prefer to view only the last million characters?') 36537 ifTrue: [charCount := 1000000]]. 36538 "changesFile setEncoderForSourceCodeNamed: changesFile name." 36539 Cursor read showWhile: 36540 [changeList := self new 36541 scanFile: changesFile from: changesFile size-charCount to: changesFile size]. 36542 changesFile close. 36543 self open: changeList name: changesFile localName , ' log' multiSelect: true! ! 36544 36545!ChangeList class methodsFor: 'public access' stamp: 'alain.plantec 2/6/2009 16:38'! 36546getRecentLocatorWithPrompt: aPrompt 36547 "Prompt with a menu of how far back to go. Return nil if user backs out. Otherwise return the number of characters back from the end of the .changes file the user wishes to include" 36548 "ChangeList getRecentPosition" 36549 | end changesFile banners positions pos chunk i | 36550 changesFile := (SourceFiles at: 2) readOnlyCopy. 36551 banners := OrderedCollection new. 36552 positions := OrderedCollection new. 36553 end := changesFile size. 36554 pos := SmalltalkImage current lastQuitLogPosition. 36555 [pos = 0 or: [banners size > 20]] whileFalse: 36556 [changesFile position: pos. 36557 chunk := changesFile nextChunk. 36558 i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. 36559 i > 0 ifTrue: [positions addLast: pos. 36560 banners addLast: (chunk copyFrom: 5 to: i-2). 36561 pos := Number readFrom: (chunk copyFrom: i+13 to: chunk size)] 36562 ifFalse: [pos := 0]]. 36563 changesFile close. 36564 pos := UIManager default chooseFrom: banners values: positions title: aPrompt. 36565 pos ifNil: [^ nil]. 36566 ^ end - pos! ! 36567 36568 36569!ChangeList class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:07'! 36570windowColorSpecification 36571 "Answer a WindowColorSpec object that declares my preference" 36572 36573 ^ WindowColorSpec classSymbol: self name wording: 'Change List' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A tool that presents a list of all the changes found in an external file.'! ! 36574ChangeList subclass: #ChangeListForProjects 36575 instanceVariableNames: '' 36576 classVariableNames: '' 36577 poolDictionaries: '' 36578 category: 'Tools-Changes'! 36579!ChangeListForProjects commentStamp: '<historical>' prior: 0! 36580A ChangeList that looks at the changes in a revokable project. This class has no users at present.! 36581 36582 36583!ChangeListForProjects methodsFor: 'contents' stamp: 'sw 9/5/2001 15:25'! 36584contents 36585 ^ self showingAnyKindOfDiffs 36586 ifFalse: [self undiffedContents] 36587 ifTrue: [self currentDiffedFromContents] 36588 "Current is writing over one in list. Show how I would change it"! ! 36589 36590!ChangeListForProjects methodsFor: 'contents' stamp: 'sd 11/20/2005 21:26'! 36591currentDiffedFromContents 36592 "Answer the current in-memory method diffed from the current contents" 36593 36594 | aChange aClass | 36595 listIndex = 0 36596 ifTrue: [^ '']. 36597 aChange := changeList at: listIndex. 36598 ^ ((aChange type == #method 36599 and: [(aClass := aChange methodClass) notNil]) 36600 and: [aClass includesSelector: aChange methodSelector]) 36601 ifTrue: [TextDiffBuilder 36602 buildDisplayPatchFrom: aChange text 36603 to: (aClass sourceCodeAt: aChange methodSelector) 36604 inClass: aClass 36605 prettyDiffs: self showingPrettyDiffs] 36606 ifFalse: [(changeList at: listIndex) text]! ! 36607Object subclass: #ChangeRecord 36608 instanceVariableNames: 'file position type class category meta stamp' 36609 classVariableNames: '' 36610 poolDictionaries: '' 36611 category: 'System-Changes'! 36612!ChangeRecord commentStamp: '<historical>' prior: 0! 36613A ChangeRecord represents a change recorded on a file in fileOut format. 36614It includes a type (more needs to be done here), and additional information 36615for certain types such as method defs which need class and category.! 36616 36617 36618!ChangeRecord methodsFor: '*monticello' stamp: 'avi 9/14/2004 14:27'! 36619asMethodDefinition 36620 ^ MCMethodDefinition 36621 className: class 36622 classIsMeta: meta 36623 selector: self methodSelector 36624 category: category 36625 timeStamp: stamp 36626 source: self string! ! 36627 36628 36629!ChangeRecord methodsFor: 'access'! 36630category 36631 ^category! ! 36632 36633!ChangeRecord methodsFor: 'access' stamp: 'sumim 9/1/2003 18:27'! 36634fileIndex 36635 ^ (SourceFiles collect: [ :sf | sf name]) 36636 indexOf: file name ifAbsent: [^ nil]. 36637! ! 36638 36639!ChangeRecord methodsFor: 'access' stamp: 'nk 1/7/2004 10:28'! 36640fileName 36641 ^(file ifNotNil: [ file name ]) 36642 ifNil: [ '<no file>' ]! ! 36643 36644!ChangeRecord methodsFor: 'access' stamp: 'sw 10/20/2002 02:53'! 36645fileOutOn: aFileStream 36646 "File the receiver out on the given file stream" 36647 36648 | aString | 36649 type == #method 36650 ifTrue: 36651 [aFileStream nextPut: $!!. 36652 aString := class asString 36653 , (meta ifTrue: [' class methodsFor: '] 36654 ifFalse: [' methodsFor: ']) 36655 , category asString printString. 36656 stamp ifNotNil: 36657 [aString := aString, ' stamp: ''', stamp, '''']. 36658 aFileStream nextChunkPut: aString. 36659 aFileStream cr]. 36660 36661 type == #preamble ifTrue: [aFileStream nextPut: $!!]. 36662 36663 type == #classComment 36664 ifTrue: 36665 [aFileStream nextPut: $!!. 36666 aFileStream nextChunkPut: class asString, ' commentStamp: ', stamp storeString. 36667 aFileStream cr]. 36668 36669 aFileStream nextChunkPut: self string. 36670 type == #method ifTrue: [aFileStream nextChunkPut: ' ']. 36671 aFileStream cr! ! 36672 36673!ChangeRecord methodsFor: 'access' stamp: 'tk 6/24/1999 15:27'! 36674headerFor: selector 36675 36676 ^ ' ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) 36677 , selector 36678 , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])! ! 36679 36680!ChangeRecord methodsFor: 'access'! 36681isMetaClassChange 36682 ^meta! ! 36683 36684!ChangeRecord methodsFor: 'access'! 36685methodClass 36686 | methodClass | 36687 type == #method ifFalse: [^ nil]. 36688 (Smalltalk includesKey: class asSymbol) ifFalse: [^ nil]. 36689 methodClass := Smalltalk at: class asSymbol. 36690 meta ifTrue: [^ methodClass class] 36691 ifFalse: [^ methodClass]! ! 36692 36693!ChangeRecord methodsFor: 'access'! 36694methodClassName 36695 ^class! ! 36696 36697!ChangeRecord methodsFor: 'access' stamp: 'eem 1/28/2009 16:40'! 36698methodSelector 36699 ^type == #method ifTrue: 36700 [(Smalltalk at: class ifAbsent: [Object]) parserClass new parseSelector: self string]! ! 36701 36702!ChangeRecord methodsFor: 'access' stamp: 'ar 7/15/2005 22:57'! 36703originalChangeSetForSelector: methodSelector 36704 "Returns the original changeset which contained this method version. If it is contained in the .sources file, return #sources. If it is in neither (e.g. its changeset was deleted), return nil. (The selector is passed in purely as an optimization.)" 36705 36706 | likelyChangeSets originalChangeSet | 36707 (file localName findTokens: '.') last = 'sources' 36708 ifTrue: [^ #sources]. 36709 likelyChangeSets := ChangeSet allChangeSets select: 36710 [:cs | (cs atSelector: methodSelector class: self methodClass) ~~ #none]. 36711 originalChangeSet := likelyChangeSets 36712 detect: [:cs | cs containsMethodAtPosition: position] 36713 ifNone: [nil]. 36714 ^ originalChangeSet "(still need to check for sources file)"! ! 36715 36716!ChangeRecord methodsFor: 'access' stamp: 'sumim 9/2/2003 14:07'! 36717position 36718 ^ position! ! 36719 36720!ChangeRecord methodsFor: 'access' stamp: 'sumim 9/2/2003 13:33'! 36721prior 36722 | currFile preamble prevPos tokens prevFileIndex | 36723 currFile := file readOnlyCopy. 36724 currFile position: (0 max: position - 150). 36725 [currFile position < (position - 1)] whileTrue: [preamble := currFile nextChunk]. 36726 currFile close. 36727 prevPos := nil. 36728 (preamble findString: 'methodsFor:' startingAt: 1) > 0 36729 ifTrue: [tokens := Scanner new scanTokens: preamble] 36730 ifFalse: [tokens := Array new]. 36731 ((tokens size between: 7 and: 8) 36732 and: [(tokens at: tokens size - 5) == #methodsFor:]) ifTrue: [ 36733 (tokens at: tokens size - 3) == #stamp: 36734 ifTrue: [ 36735 prevPos := tokens last. 36736 prevFileIndex := SourceFiles fileIndexFromSourcePointer: prevPos. 36737 prevPos := SourceFiles filePositionFromSourcePointer: prevPos] 36738 ifFalse: [ 36739 prevPos := tokens at: tokens size - 2. 36740 prevFileIndex := tokens last]. 36741 (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos := nil]]. 36742 prevPos ifNil: [^ nil]. 36743 ^ {prevFileIndex. prevPos. 36744 SourceFiles sourcePointerFromFileIndex: prevFileIndex andPosition: prevPos}! ! 36745 36746!ChangeRecord methodsFor: 'access' stamp: 'tk 6/21/1999 20:34'! 36747readStamp 36748 "Get the time stamp of this method off the file" 36749 36750 | item tokens anIndex | 36751 stamp := ''. 36752 file ifNil: [^ stamp]. 36753 file position: position. 36754 item := file nextChunk. 36755 tokens := Scanner new scanTokens: item. 36756 tokens size < 3 ifTrue: [^ stamp]. 36757 anIndex := tokens indexOf: #stamp: ifAbsent: [^ stamp]. 36758 ^ stamp := tokens at: (anIndex + 1). 36759! ! 36760 36761!ChangeRecord methodsFor: 'access' stamp: '6/6/97 08:56 dhhi'! 36762stamp 36763 ^ stamp! ! 36764 36765!ChangeRecord methodsFor: 'access' stamp: 'tk 9/7/2000 15:09'! 36766stamp: threePartString 36767 36768 stamp := threePartString! ! 36769 36770!ChangeRecord methodsFor: 'access' stamp: 'di 1/13/98 16:57'! 36771string 36772 | string | 36773 file openReadOnly. 36774 file position: position. 36775 string := file nextChunk. 36776 file close. 36777 ^ string! ! 36778 36779!ChangeRecord methodsFor: 'access' stamp: 'tk 6/23/1999 08:20'! 36780text 36781 | text | 36782 ^ file ifNil: [''] 36783 ifNotNil: [ 36784 file openReadOnly. 36785 file position: position. 36786 text := file nextChunkText. 36787 file close. 36788 text]! ! 36789 36790!ChangeRecord methodsFor: 'access' stamp: 'nk 11/25/2003 09:44'! 36791timeStamp 36792 "Answer a TimeStamp that corresponds to my (text) stamp" 36793 | tokens date time | 36794 tokens := self stamp findTokens: Character separators. 36795 ^ tokens size > 2 36796 ifTrue: [[date := Date 36797 fromString: (tokens at: tokens size - 1). 36798 time := Time fromString: tokens last. 36799 TimeStamp date: date time: time] 36800 on: Error 36801 do: [:ex | ex 36802 return: (TimeStamp fromSeconds: 0)]] 36803 ifFalse: [TimeStamp fromSeconds: 0]! ! 36804 36805!ChangeRecord methodsFor: 'access'! 36806type 36807 ^ type! ! 36808 36809 36810!ChangeRecord methodsFor: 'initialization' stamp: 'tk 6/24/1999 14:51'! 36811class: clsName category: cat method: method sourceFiles: fileArray 36812 "This should be enough to find all the information for a method, or method deletion" 36813 36814 file := fileArray at: method fileIndex. 36815 position := method filePosition. 36816 type := #method. 36817 class := clsName copyUpTo: $ . "the non-meta part of a class name" 36818 category := cat. 36819 meta := clsName endsWith: ' class'. 36820 self readStamp.! ! 36821 36822!ChangeRecord methodsFor: 'initialization'! 36823file: f position: p type: t 36824 file := f. 36825 position := p. 36826 type := t! ! 36827 36828!ChangeRecord methodsFor: 'initialization' stamp: '6/6/97 08:48 dhhi'! 36829file: f position: p type: t class: c category: cat meta: m stamp: s 36830 self file: f position: p type: t. 36831 class := c. 36832 category := cat. 36833 meta := m. 36834 stamp := s! ! 36835 36836!ChangeRecord methodsFor: 'initialization' stamp: 'nk 11/26/2002 12:07'! 36837fileIn 36838 "File the receiver in. If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it." 36839 36840 | methodClass s aSelector | 36841 Cursor read showWhile: 36842 [(methodClass := self methodClass) notNil ifTrue: 36843 [methodClass compile: self text classified: category withStamp: stamp notifying: nil. 36844 (aSelector := self methodSelector) ifNotNil: 36845 [Utilities noteMethodSubmission: aSelector forClass: methodClass]]. 36846 (type == #doIt) ifTrue: 36847 [((s := self string) beginsWith: '----') ifFalse: [Compiler evaluate: s]]. 36848 (type == #classComment) ifTrue: 36849 [ | cls | (cls := Smalltalk at: class asSymbol) comment: self text stamp: stamp. 36850 Utilities noteMethodSubmission: #Comment forClass: cls ]]! ! 36851Object subclass: #ChangeSet 36852 instanceVariableNames: 'name preamble postscript revertable isolationSet isolatedProject changeRecords structures superclasses' 36853 classVariableNames: 'AllChangeSets PreviousSet' 36854 poolDictionaries: '' 36855 category: 'System-Changes'! 36856!ChangeSet commentStamp: '<historical>' prior: 0! 36857ChangeSets keep track of the changes made to a system, so they can be written on a file as source code (a "fileOut"). Every project has an associated changeSet. For simple projects, a different changeSet may be designated to capture changes at any time. 36858 36859This implementation of ChangeSet is capable of remembering and manipulating methods for which the classes are not present in the system. However at the present time, this capability is not used in normal rearranging and fileOuts, but only for invoking and revoking associated with isolation layers. 36860 36861For isolated projects (see Project class comment), the changeSet binding is semi-permanent. Every project exists in an isolation layer defined by its closest enclosing parent (or itself) that is isolated. If a project is not isolated, then changes reported to its designated changeSet must also be reported to the permanent changeSet for that layer, designated in the isolated project. This ensures that that outer project will be able to revert all changes upon exit. 36862 36863Note that only certain changes may be reverted. Classes may not be added, removed, renamed or reshaped except in the layer in which they are defined because these operations on non-local classes are not revertable. 36864 36865If a Squeak Project is established as being isolated, then its associated changeSet will be declared to be revertable. In this case all changes stored can be reverted. The changeSet associated with an isolated project is tied to that project, and cannot be edited in a changeSorter. 36866------ 36867 36868name - a String used to name the changeSet, and thus any associated project or fileOut. 36869 36870preamble and postscript: two strings that serve as prefix (useful for documentation) and suffix (useful for doits) to the fileout of the changeSet. 36871 36872revertable - a Boolean 36873If this variable is true, then all of the changes recorded by this changeSet can be reverted. 36874 36875isolationSet - a ChangeSet or nil 36876The isolationSet is the designated changeSet for an isolation layer. If this changeSet is an isolationSet, then this variable will be nil. If not, then it points to the isolationSet for this layer, and all changes reported here will also be reported to the isolationSet. 36877 36878isolatedProject - a Project or nil 36879If this is an isolationSet, then this variable points to the project with which it is associated. 36880 36881changeRecords - Dictionary {class name -> a ClassChangeRecord}. 36882These classChangeRecords (qv) remember all of the system changes. 36883 36884structures - Dictionary {#Rectangle -> #(<classVersionInteger> 'origin' 'corner')}. 36885Of the names of the instances variables before any changes for all classes in classChanges, and all of their superclasses. In the same format used in SmartRefStream. Inst var names are strings. 36886 36887superclasses - Dictionary {#Rectangle -> #Object}. 36888Of all classes in classChanges, and all of their superclasses. 36889 36890Structures and superclasses save the instance variable names of this class and all of its superclasses. Later we can tell how it changed and write a conversion method. The conversion method is used when old format objects are brought in from the disk from ImageSegment files (.extSeg) or SmartRefStream files (.obj .morph .bo .sp). 36891 36892NOTE: It should be fairly simple, by adding a bit more information to the classChangeRecords, to reconstruct the information now stored in 'structures' and 'superclasses'. This would be a welcome simplification. 36893! 36894 36895 36896!ChangeSet methodsFor: 'accessing' stamp: 'BJP 4/24/2001 00:23'! 36897author 36898 | author | 36899 self assurePreambleExists. 36900 author := self preambleString lineNumber: 3. 36901 author := author copyFrom: 8 to: author size. "Strip the 'Author:' prefix. Ugly ugly." 36902 ^author withBlanksTrimmed. 36903 ! ! 36904 36905!ChangeSet methodsFor: 'accessing' stamp: 'di 4/1/2000 12:00'! 36906classRemoves 36907 36908 ^ changeRecords keys select: 36909 [:className | (changeRecords at: className) isClassRemoval]! ! 36910 36911!ChangeSet methodsFor: 'accessing' stamp: 'ar 7/16/2005 18:59'! 36912editPostscript 36913 "edit the receiver's postscript, in a separate window. " 36914 self assurePostscriptExists. 36915 UIManager default 36916 edit: self postscript 36917 label: 'Postscript for ChangeSet named ', name 36918 accept:[:aString| self postscript: aString].! ! 36919 36920!ChangeSet methodsFor: 'accessing' stamp: 'sw 6/29/1999 14:44'! 36921hasPostscript 36922 ^ postscript notNil! ! 36923 36924!ChangeSet methodsFor: 'accessing' stamp: 'di 4/1/2000 12:00'! 36925methodChanges 36926 36927 | methodChangeDict changeTypes | 36928 methodChangeDict := Dictionary new. 36929 changeRecords associationsDo: 36930 [:assn | 36931 changeTypes := assn value methodChangeTypes. 36932 changeTypes isEmpty ifFalse: [methodChangeDict at: assn key put: changeTypes]]. 36933 ^ methodChangeDict! ! 36934 36935!ChangeSet methodsFor: 'accessing' stamp: 'di 3/29/2000 16:22'! 36936methodInfoFromRemoval: classAndSelector 36937 36938 ^ (self changeRecorderFor: classAndSelector first) 36939 infoFromRemoval: classAndSelector last! ! 36940 36941!ChangeSet methodsFor: 'accessing'! 36942name 36943 "The name of this changeSet. 36944 2/7/96 sw: If name is nil, we've got garbage. Help to identify." 36945 36946 ^ name == nil 36947 ifTrue: 36948 ['<no name -- garbage?>'] 36949 ifFalse: 36950 [name]! ! 36951 36952!ChangeSet methodsFor: 'accessing'! 36953name: anObject 36954 name := anObject! ! 36955 36956!ChangeSet methodsFor: 'accessing' stamp: 'ar 7/16/2005 18:04'! 36957postscriptHasDependents 36958 ^false! ! 36959 36960!ChangeSet methodsFor: 'accessing'! 36961printOn: aStream 36962 "2/7/96 sw: provide the receiver's name in the printout" 36963 super printOn: aStream. 36964 aStream nextPutAll: ' named ', self name! ! 36965 36966!ChangeSet methodsFor: 'accessing' stamp: 'MPW 1/1/1901 22:02'! 36967printOnStream: aStream 36968 "2/7/96 sw: provide the receiver's name in the printout" 36969 super printOnStream: aStream. 36970 aStream print: ' named ', self name! ! 36971 36972!ChangeSet methodsFor: 'accessing' stamp: 'sw 6/29/1999 14:48'! 36973removePostscript 36974 postscript := nil! ! 36975 36976!ChangeSet methodsFor: 'accessing' stamp: 'tk 6/8/1999 22:25'! 36977structures 36978 ^structures! ! 36979 36980!ChangeSet methodsFor: 'accessing' stamp: 'tk 6/8/1999 22:25'! 36981superclasses 36982 ^superclasses! ! 36983 36984 36985!ChangeSet methodsFor: 'change logging' stamp: 'di 3/29/2000 13:10'! 36986addClass: class 36987 "Include indication that a new class was created." 36988 36989 class wantsChangeSetLogging ifFalse: [^ self]. 36990 isolationSet ifNotNil: 36991 ["If there is an isolation layer above me, inform it as well." 36992 isolationSet addClass: class]. 36993 self atClass: class add: #new. 36994 self atClass: class add: #change. 36995 self addCoherency: class name! ! 36996 36997!ChangeSet methodsFor: 'change logging' stamp: 'NS 1/19/2004 18:30'! 36998changeClass: class from: oldClass 36999 "Remember that a class definition has been changed. Record the original structure, so that a conversion method can be built." 37000 37001 class wantsChangeSetLogging ifFalse: [^ self]. 37002 isolationSet ifNotNil: 37003 ["If there is an isolation layer above me, inform it as well." 37004 isolationSet changeClass: class from: oldClass]. 37005 class isMeta 37006 ifFalse: [self atClass: class add: #change] "normal" 37007 ifTrue: [((self classChangeAt: class theNonMetaClass name) includes: #add) 37008 ifTrue: [self atClass: class add: #add] "When a class is defined, the metaclass 37009 is not recorded, even though it was added. A further change is 37010 really just part of the original add." 37011 ifFalse: [self atClass: class add: #change]]. 37012 self addCoherency: class name. 37013 (self changeRecorderFor: class) notePriorDefinition: oldClass. 37014 self noteClassStructure: oldClass! ! 37015 37016!ChangeSet methodsFor: 'change logging' stamp: 'rw 10/17/2006 22:26'! 37017event: anEvent 37018 "Hook for SystemChangeNotifier" 37019 anEvent itemKind = SystemChangeNotifier classKind ifTrue: [ 37020 anEvent isRemoved 37021 ifTrue: [self noteRemovalOf: anEvent item]. 37022 anEvent isAdded 37023 ifTrue: [self addClass: anEvent item]. 37024 anEvent isModified 37025 ifTrue: [anEvent anyChanges ifTrue: [self changeClass: anEvent item from: anEvent oldItem]]. 37026 anEvent isCommented 37027 ifTrue: [self commentClass: anEvent item]. 37028 anEvent isRenamed 37029 ifTrue: [self renameClass: anEvent item from: anEvent oldName to: anEvent newName]. 37030 anEvent isReorganized 37031 ifTrue: [self reorganizeClass: anEvent item]. 37032 anEvent isRecategorized 37033 ifTrue: [self changeClass: anEvent item from: anEvent item]. 37034 ]. 37035 37036 anEvent itemKind = SystemChangeNotifier methodKind ifTrue: [ 37037 anEvent isAdded 37038 ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: nil]. 37039 anEvent isModified 37040 ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: anEvent oldItem]. 37041 anEvent isRemoved 37042 ifTrue: [self removeSelector: anEvent itemSelector class: anEvent itemClass priorMethod: anEvent item lastMethodInfo: {anEvent item sourcePointer. anEvent itemProtocol}]. 37043 anEvent isRecategorized 37044 ifTrue: [self reorganizeClass: anEvent itemClass]. 37045 ].! ! 37046 37047!ChangeSet methodsFor: 'change logging' stamp: 'di 3/29/2000 11:08'! 37048noteNewMethod: newMethod forClass: class selector: selector priorMethod: methodOrNil 37049 37050 class wantsChangeSetLogging ifFalse: [^ self]. 37051 isolationSet ifNotNil: 37052 ["If there is an isolation layer above me, inform it as well." 37053 isolationSet noteNewMethod: newMethod forClass: class selector: selector 37054 priorMethod: methodOrNil]. 37055 (self changeRecorderFor: class) 37056 noteNewMethod: newMethod selector: selector priorMethod: methodOrNil 37057! ! 37058 37059!ChangeSet methodsFor: 'change logging' stamp: 'di 3/29/2000 12:29'! 37060removeSelector: selector class: class priorMethod: priorMethod lastMethodInfo: info 37061 "Include indication that a method has been forgotten. 37062 info is a pair of the source code pointer and message category 37063 for the method that was removed." 37064 37065 class wantsChangeSetLogging ifFalse: [^ self]. 37066 isolationSet ifNotNil: 37067 ["If there is an isolation layer above me, inform it as well." 37068 isolationSet removeSelector: selector class: class 37069 priorMethod: priorMethod lastMethodInfo: info]. 37070 (self changeRecorderFor: class) 37071 noteRemoveSelector: selector priorMethod: priorMethod lastMethodInfo: info 37072! ! 37073 37074!ChangeSet methodsFor: 'change logging' stamp: 'rw 10/19/2006 17:52'! 37075renameClass: class from: oldName to: newName 37076 "Include indication that a class has been renamed." 37077 37078 | recorder oldMetaClassName newMetaClassName | 37079 isolationSet ifNotNil: 37080 ["If there is an isolation layer above me, inform it as well." 37081 isolationSet renameClass: class as: newName]. 37082 (recorder := self changeRecorderFor: oldName) 37083 noteChangeType: #rename; 37084 noteNewName: newName asSymbol. 37085 37086 "store under new name (metaclass too)" 37087 changeRecords at: newName put: recorder. 37088 changeRecords removeKey: oldName. 37089 self noteClassStructure: class. 37090 37091 newMetaClassName := newName, ' class'. 37092 oldMetaClassName := oldName, ' class'. 37093 recorder := changeRecords at: oldMetaClassName ifAbsent: [^ nil]. 37094 changeRecords at: newMetaClassName put: recorder. 37095 changeRecords removeKey: oldMetaClassName. 37096 recorder noteNewName: newMetaClassName! ! 37097 37098 37099!ChangeSet methodsFor: 'class changes' stamp: 'di 4/1/2000 12:00'! 37100changedClassNames 37101 "Answer a OrderedCollection of the names of changed or edited classes. 37102 DOES include removed classes. Sort alphabetically." 37103 37104 ^ changeRecords keysSortedSafely ! ! 37105 37106!ChangeSet methodsFor: 'class changes' stamp: 'di 3/23/2000 08:12'! 37107changedClasses 37108 "Answer an OrderedCollection of changed or edited classes. 37109 Does not include removed classes. Sort alphabetically by name." 37110 37111 "Much faster to sort names first, then convert back to classes. Because metaclasses reconstruct their name at every comparison in the sorted collection. 37112 8/91 sw chgd to filter out non-existent classes (triggered by problems with class-renames" 37113 37114 ^ self changedClassNames 37115 collect: [:className | Smalltalk classNamed: className] 37116 thenSelect: [:aClass | aClass notNil]! ! 37117 37118!ChangeSet methodsFor: 'class changes' stamp: 'di 4/1/2000 12:00'! 37119classChangeAt: className 37120 "Return what we know about class changes to this class." 37121 37122 ^ (changeRecords at: className ifAbsent: [^ Set new]) 37123 allChangeTypes! ! 37124 37125!ChangeSet methodsFor: 'class changes' stamp: 'NS 1/26/2004 09:46'! 37126commentClass: class 37127 "Include indication that a class comment has been changed." 37128 37129 class wantsChangeSetLogging ifFalse: [^ self]. 37130 self atClass: class add: #comment! ! 37131 37132!ChangeSet methodsFor: 'class changes' stamp: 'nk 6/26/2002 12:30'! 37133containsClass: aClass 37134 ^ self changedClasses includes: aClass! ! 37135 37136!ChangeSet methodsFor: 'class changes' stamp: 'PeterHugossonMiller 9/3/2009 00:18'! 37137fatDefForClass: class 37138 | newDef oldDef oldStrm newStrm outStrm oldVars newVars addedVars | 37139 class isBehavior ifFalse: [ ^ class definition ]. 37140 newDef := class definition. 37141 oldDef := (self changeRecorderFor: class) priorDefinition. 37142 oldDef ifNil: [ ^ newDef ]. 37143 oldDef = newDef ifTrue: [ ^ newDef ]. 37144 oldStrm := oldDef readStream. 37145 newStrm := newDef readStream. 37146 outStrm := (String new: newDef size * 2) writeStream. 37147 37148 "Merge inst vars from old and new defs..." 37149 oldStrm 37150 upToAll: 'instanceVariableNames'; 37151 upTo: $'. 37152 outStrm 37153 nextPutAll: (newStrm upToAll: 'instanceVariableNames'); 37154 nextPutAll: 'instanceVariableNames:'. 37155 newStrm peek = $: ifTrue: [ newStrm next ]. "may or may not be there, but already written" 37156 outStrm 37157 nextPutAll: (newStrm upTo: $'); 37158 nextPut: $'. 37159 oldVars := (oldStrm upTo: $') findTokens: Character separators. 37160 newVars := (newStrm upTo: $') findTokens: Character separators. 37161 addedVars := oldVars asSet 37162 addAll: newVars; 37163 removeAll: oldVars; 37164 asOrderedCollection. 37165 oldVars , addedVars do: 37166 [ :var | 37167 outStrm 37168 nextPutAll: var; 37169 space ]. 37170 outStrm nextPut: $'. 37171 class isMeta ifFalse: 37172 [ "Merge class vars from old and new defs..." 37173 oldStrm 37174 upToAll: 'classVariableNames:'; 37175 upTo: $'. 37176 outStrm 37177 nextPutAll: (newStrm upToAll: 'classVariableNames:'); 37178 nextPutAll: 'classVariableNames:'; 37179 nextPutAll: (newStrm upTo: $'); 37180 nextPut: $'. 37181 oldVars := (oldStrm upTo: $') findTokens: Character separators. 37182 newVars := (newStrm upTo: $') findTokens: Character separators. 37183 addedVars := oldVars asSet 37184 addAll: newVars; 37185 removeAll: oldVars; 37186 asOrderedCollection. 37187 oldVars , addedVars do: 37188 [ :var | 37189 outStrm 37190 nextPutAll: var; 37191 space ]. 37192 outStrm nextPut: $' ]. 37193 outStrm nextPutAll: newStrm upToEnd. 37194 ^ outStrm contents! ! 37195 37196!ChangeSet methodsFor: 'class changes' stamp: 'tk 6/9/1999 19:54'! 37197noteClassForgotten: className 37198 "Remove from structures if class is not a superclass of some other one we are remembering" 37199 37200 structures ifNil: [^ self]. 37201 Smalltalk at: className ifPresent: [:cls | 37202 cls subclasses do: [:sub | (structures includesKey: sub) ifTrue: [ 37203 ^ self]]]. "No delete" 37204 structures removeKey: className ifAbsent: [].! ! 37205 37206!ChangeSet methodsFor: 'class changes' stamp: 'dvf 9/27/2005 19:05'! 37207noteClassStructure: aClass 37208 "Save the instance variable names of this class and all of its superclasses. Later we can tell how it changed and write a conversion method. The conversion method is used when old format objects are brought in from the disk from ImageSegment files (.extSeg) or SmartRefStream files (.obj .morph .bo .sp)." 37209 37210 | clsName | 37211 aClass isBehavior ifFalse: [^ self]. 37212 37213 structures ifNil: [structures := Dictionary new. 37214 superclasses := Dictionary new]. 37215 clsName := (aClass name asLowercase beginsWith: 'anobsolete') 37216 ifTrue: [(aClass name copyFrom: 11 to: aClass name size) asSymbol] 37217 ifFalse: [aClass name]. 37218 (structures includesKey: clsName) ifFalse: [ 37219 structures at: clsName put: 37220 ((Array with: aClass classVersion), (aClass allInstVarNames)). 37221 superclasses at: clsName put: aClass superclass name]. 37222 "up the superclass chain" 37223 aClass superclass ifNotNil: [self noteClassStructure: aClass superclass]. 37224! ! 37225 37226!ChangeSet methodsFor: 'class changes' stamp: 'NS 1/19/2004 17:49'! 37227noteRemovalOf: class 37228 "The class is about to be removed from the system. 37229 Adjust the receiver to reflect that fact." 37230 37231 class wantsChangeSetLogging ifFalse: [^ self]. 37232 (self changeRecorderFor: class) 37233 noteChangeType: #remove fromClass: class. 37234 changeRecords removeKey: class class name ifAbsent: [].! ! 37235 37236!ChangeSet methodsFor: 'class changes'! 37237reorganizeClass: class 37238 "Include indication that a class was reorganized." 37239 37240 self atClass: class add: #reorganize! ! 37241 37242!ChangeSet methodsFor: 'class changes' stamp: 'di 5/16/2000 09:03'! 37243trimHistory 37244 "Drop non-essential history: methods added and then removed, as well as rename and reorganization of newly-added classes." 37245 37246 changeRecords do: [:chgRecord | chgRecord trimHistory]! ! 37247 37248 37249!ChangeSet methodsFor: 'converting' stamp: 'RAA 12/20/2000 16:02'! 37250convertApril2000: varDict using: smartRefStrm 37251 | cls info selector pair classChanges methodChanges methodRemoves classRemoves | 37252 "These variables are automatically stored into the new instance: 37253 ('name' 'preamble' 'postscript' 'structures' 'superclasses' ). 37254 This method is for additional changes. 37255 It initializes the isolation variables, and then duplicates the logic fo 37256 assimilateAllChangesFoundIn:." 37257 37258 revertable := false. 37259 isolationSet := nil. 37260 isolatedProject := nil. 37261 changeRecords := Dictionary new. 37262 37263 classChanges := varDict at: 'classChanges'. 37264 classChanges keysDo: 37265 [:className | 37266 (cls := Smalltalk classNamed: className) ifNotNil: 37267 [info := classChanges at: className ifAbsent: [Set new]. 37268 info do: [:each | self atClass: cls add: each]]]. 37269 37270 methodChanges := varDict at: 'methodChanges'. 37271 methodRemoves := varDict at: 'methodRemoves'. 37272 methodChanges keysDo: 37273 [:className | 37274 (cls := Smalltalk classNamed: className) ifNotNil: 37275 [info := methodChanges at: className ifAbsent: [Dictionary new]. 37276 info associationsDo: 37277 [:assoc | selector := assoc key. 37278 (assoc value == #remove or: [assoc value == #addedThenRemoved]) 37279 ifTrue: 37280 [assoc value == #addedThenRemoved 37281 ifTrue: [self atSelector: selector class: cls put: #add]. 37282 pair := methodRemoves at: {cls name. selector} ifAbsent: [nil] . 37283 self removeSelector: selector class: cls priorMethod: nil lastMethodInfo: pair] 37284 ifFalse: 37285 [self atSelector: selector class: cls put: assoc value]]]]. 37286 37287 classRemoves := varDict at: 'classRemoves'. 37288 classRemoves do: 37289 [:className | self noteRemovalOf: className]. 37290 37291! ! 37292 37293 37294!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/15/2005 21:53'! 37295askAddedInstVars: classList 37296 | pairList pairClasses index pls newStruct oldStruct | 37297 "Ask the author whether these newly added inst vars need to be non-nil" 37298 37299 pairList := OrderedCollection new. 37300 pairClasses := OrderedCollection new. 37301 "Class version numbers: If it must change, something big happened. Do need a conversion method then. Ignore them here." 37302 classList do: [:cls | 37303 newStruct := (cls allInstVarNames). 37304 oldStruct := (structures at: cls name ifAbsent: [#(0), newStruct]) allButFirst. 37305 newStruct do: [:instVarName | 37306 (oldStruct includes: instVarName) ifFalse: [ 37307 pairList add: cls name, ' ', instVarName. 37308 pairClasses add: cls]]]. 37309 37310 pairList isEmpty ifTrue: [^ #()]. 37311 [index := UIManager default 37312 chooseFrom: pairList, #('all of these need a non-nil value' 37313 'all of these are OK with a nil value') 37314 title: 37315'These instance variables were added. 37316When an old project comes in, newly added 37317instance variables will have the value nil. 37318Click on items to remove them from the list. 37319Click on any for which nil is an OK value.'. 37320 (index <= (pls := pairList size)) & (index > 0) ifTrue: [ 37321 pairList removeAt: index. 37322 pairClasses removeAt: index]. 37323 index = (pls + 2) ifTrue: ["all are OK" ^ #()]. 37324 pairList isEmpty | (index = (pls + 1)) "all need conversion, exit"] whileFalse. 37325 37326 ^ pairClasses asSet asArray "non redundant"! ! 37327 37328!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/15/2005 21:54'! 37329askRemovedInstVars: classList 37330 | pairList pairClasses index pls newStruct oldStruct | 37331 "Ask the author whether these newly removed inst vars need to have their info saved" 37332 37333 pairList := OrderedCollection new. 37334 pairClasses := OrderedCollection new. 37335 "Class version numbers: If it must change, something big happened. Do need a conversion method then. Ignore them here." 37336 classList do: [:cls | 37337 newStruct := (cls allInstVarNames). 37338 oldStruct := (structures at: cls name ifAbsent: [#(0), newStruct]) allButFirst. 37339 oldStruct do: [:instVarName | 37340 (newStruct includes: instVarName) ifFalse: [ 37341 pairList add: cls name, ' ', instVarName. 37342 pairClasses add: cls]]]. 37343 37344 pairList isEmpty ifTrue: [^ #()]. 37345 [index := UIManager default 37346 chooseFrom: pairList, #('all of these need a conversion method' 37347 'all of these have old values that can be erased') 37348 title: 37349'These instance variables were removed. 37350When an old project comes in, instance variables 37351that have been removed will lose their contents. 37352Click on items to remove them from the list. 37353Click on any whose value is unimportant and need not be saved.'. 37354 (index <= (pls := pairList size)) & (index > 0) ifTrue: [ 37355 pairList removeAt: index. 37356 pairClasses removeAt: index]. 37357 index = (pls + 2) ifTrue: ["all are OK" ^ #()]. 37358 pairList isEmpty | (index = (pls + 1)) "all need conversion, exit"] whileFalse. 37359 37360 ^ pairClasses asSet asArray "non redundant"! ! 37361 37362!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/15/2005 21:51'! 37363askRenames: renamed addTo: msgSet using: smart 37364 | list rec ans oldStruct newStruct | 37365 "Go through the renamed classes. Ask the user if it could be in a project. Add a method in SmartRefStream, and a conversion method in the new class." 37366 37367 list := OrderedCollection new. 37368 renamed do: [:cls | 37369 rec := changeRecords at: cls name. 37370 rec priorName ifNotNil: [ 37371 ans := UIManager default chooseFrom: 37372 #('Yes, write code to convert those instances' 37373 'No, no instances are in projects') 37374 title: 'You renamed class ', rec priorName, 37375 ' to be ', rec thisName, 37376 '.\Could an instance of ', rec priorName, 37377 ' be in a project on someone''s disk?'. 37378 ans = 1 ifTrue: [ 37379 oldStruct := structures at: rec priorName ifAbsent: [nil]. 37380 newStruct := (Array with: cls classVersion), (cls allInstVarNames). 37381 oldStruct ifNotNil: [ 37382 smart writeConversionMethodIn: cls fromInstVars: oldStruct 37383 to: newStruct renamedFrom: rec priorName. 37384 smart writeClassRename: cls name was: rec priorName. 37385 list add: cls name, ' convertToCurrentVersion:refStream:']] 37386 ifFalse: [structures removeKey: rec priorName ifAbsent: []]]]. 37387 list isEmpty ifTrue: [^ msgSet]. 37388 msgSet messageList ifNil: [msgSet initializeMessageList: list] 37389 ifNotNil: [list do: [:item | msgSet addItem: item]]. 37390 ^ msgSet! ! 37391 37392!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:05'! 37393assurePostscriptExists 37394 "Make sure there is a StringHolder holding the postscript. " 37395 37396 "NOTE: FileIn recognizes the postscript by the line with Postscript: on it" 37397 postscript == nil ifTrue: [postscript := '"Postscript: 37398Leave the line above, and replace the rest of this comment by a useful one. 37399Executable statements should follow this comment, and should 37400be separated by periods, with no exclamation points (!!). 37401Be sure to put any further comments in double-quotes, like this one." 37402']! ! 37403 37404!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:02'! 37405assurePreambleExists 37406 "Make sure there is a StringHolder holding the preamble; if it's found to have reverted to empty contents, put up the template" 37407 37408 (preamble isEmptyOrNil) 37409 ifTrue: [preamble := self preambleTemplate]! ! 37410 37411!ChangeSet methodsFor: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 00:20'! 37412buildMessageForMailOutWithUser: userName 37413 "prepare the message" 37414 | message compressBuffer compressStream data compressedStream compressTarget | 37415 message := MailMessage empty. 37416 message 37417 setField: 'from' 37418 toString: userName. 37419 message 37420 setField: 'to' 37421 toString: 'Pharo-project@lists.gforge.inria.fr'. 37422 message 37423 setField: 'subject' 37424 toString: self chooseSubjectPrefixForEmail , name. 37425 message body: (MIMEDocument 37426 contentType: 'text/plain' 37427 content: (String streamContents: 37428 [ :str | 37429 str 37430 nextPutAll: 'from preamble:'; 37431 cr; 37432 cr. 37433 self fileOutPreambleOn: str ])). 37434 37435 "Prepare the gzipped data" 37436 data := String new writeStream. 37437 data 37438 header; 37439 timeStamp. 37440 self fileOutPreambleOn: data. 37441 self fileOutOn: data. 37442 self fileOutPostscriptOn: data. 37443 data trailer. 37444 data := data contents readStream. 37445 compressBuffer := ByteArray new: 1000. 37446 compressStream := GZipWriteStream on: (compressTarget := (ByteArray new: 1000) writeStream). 37447 [ data atEnd ] whileFalse: [ compressStream nextPutAll: (data nextInto: compressBuffer) ]. 37448 compressStream close. 37449 compressedStream := compressTarget contents asString readStream. 37450 message 37451 addAttachmentFrom: compressedStream 37452 withName: name , '.cs.gz'. 37453 ^ message! ! 37454 37455!ChangeSet methodsFor: 'filein/out' stamp: 'MiguelCoba 7/25/2009 02:16'! 37456checkForAlienAuthorship 37457 "Check to see if there are any methods in the receiver that have author full name other than that of the current author, and open a browser on all found" 37458 37459 | aList fullName | 37460 (fullName := Author fullNamePerSe) ifNil: [^ self inform: 'No author full name set in this image']. 37461 (aList := self methodsWithInitialsOtherThan: fullName) size > 0 37462 ifFalse: 37463 [^ self inform: 'All methods in "', self name, '" 37464have authoring stamps which start with "', fullName, '"'] 37465 ifTrue: 37466 [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" whose authoring stamps do not start with "', fullName, '"']! ! 37467 37468!ChangeSet methodsFor: 'filein/out' stamp: 'MiguelCoba 7/25/2009 02:17'! 37469checkForAnyAlienAuthorship 37470 "Check to see if there are any versions of any methods in the receiver that have author full name other than that of the current author, and open a browser on all found" 37471 37472 | aList fullName | 37473 (fullName := Author fullNamePerSe) ifNil: [^ self inform: 'No author full name set in this image']. 37474 (aList := self methodsWithAnyInitialsOtherThan: fullName) size > 0 37475 ifFalse: [^ self inform: 'All versions of all methods in "', self name, '" 37476have authoring stamps which start with "', fullName, '"'] 37477 ifTrue: 37478 [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" with any authoring stamps not starting with "', fullName, '"']! ! 37479 37480!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/17/2005 11:13'! 37481checkForConversionMethods 37482 "See if any conversion methods are needed" 37483 | oldStruct newStruct tell choice list need 37484sel smart restore renamed listAdd listDrop msgSet rec nn | 37485 37486 Preferences conversionMethodsAtFileOut ifFalse: [^ self]. "Check preference" 37487 structures ifNil: [^ self]. 37488 37489 list := OrderedCollection new. 37490 renamed := OrderedCollection new. 37491 self changedClasses do: [:class | 37492 need := (self atClass: class includes: #new) not. 37493 need ifTrue: ["Renamed classes." 37494 (self atClass: class includes: #rename) ifTrue: [ 37495 rec := changeRecords at: class name. 37496 rec priorName ifNotNil: [ 37497 (structures includesKey: rec priorName) ifTrue: [ 37498 renamed add: class. need := false]]]]. 37499 need ifTrue: [need := (self atClass: class includes: #change)]. 37500 need ifTrue: [oldStruct := structures at: class name 37501 ifAbsent: [need := false. #()]]. 37502 need ifTrue: [ 37503 newStruct := (Array with: class classVersion), (class allInstVarNames). 37504 need := (oldStruct ~= newStruct)]. 37505 need ifTrue: [sel := #convertToCurrentVersion:refStream:. 37506 (#(add change) includes: (self atSelector: sel class: class)) ifFalse: [ 37507 list add: class]]. 37508 ]. 37509 37510 list isEmpty & renamed isEmpty ifTrue: [^ self]. 37511 "Ask user if want to do this" 37512 tell := 'If there might be instances of ', (list asArray, renamed asArray) printString, 37513 '\in a project (.pr file) on someone''s disk, \please ask to write a conversion method.\' 37514 withCRs, 37515 'After you edit the conversion method, you''ll need to fileOut again.\' withCRs, 37516 'The preference conversionMethodsAtFileOut in category "fileout" controls this feature.'. 37517 choice := UIManager default chooseFrom: 37518'Write a conversion method by editing a prototype 37519These classes are not used in any object file. fileOut my changes now. 37520I''m too busy. fileOut my changes now. 37521Don''t ever ask again. fileOut my changes now.' withCRs title: tell. 37522 choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut]. 37523 choice = 2 ifTrue: ["Don't consider this class again in the changeSet" 37524 list do: [:cls | structures removeKey: cls name ifAbsent: []]. 37525 renamed do: [:cls | 37526 nn := (changeRecords at: cls name) priorName. 37527 structures removeKey: nn ifAbsent: []]]. 37528 choice ~= 1 ifTrue: [^ self]. "exit if choice 2,3,4" 37529 37530 listAdd := self askAddedInstVars: list. "Go through each inst var that was added" 37531 listDrop := self askRemovedInstVars: list. "Go through each inst var that was removed" 37532 list := (listAdd, listDrop) asSet asArray. 37533 37534 smart := SmartRefStream on: (RWBinaryOrTextStream on: '12345'). 37535 smart structures: structures. 37536 smart superclasses: superclasses. 37537 (restore := self class current) == self ifFalse: [ 37538 self class newChanges: self]. "if not current one" 37539 msgSet := smart conversionMethodsFor: list. 37540 "each new method is added to self (a changeSet). Then filed out with the rest." 37541 self askRenames: renamed addTo: msgSet using: smart. "renamed classes, add 2 methods" 37542 restore == self ifFalse: [self class newChanges: restore]. 37543 msgSet isEmpty ifTrue: [^ self]. 37544 self inform: 'Remember to fileOut again after modifying these methods.'. 37545 ToolSet browseMessageSet: msgSet name: 'Conversion methods for ', self name autoSelect: false.! ! 37546 37547!ChangeSet methodsFor: 'filein/out' stamp: 'di 3/26/2000 10:06'! 37548checkForSlips 37549 "Return a collection of method refs with possible debugging code in them." 37550 | slips method | 37551 slips := OrderedCollection new. 37552 self changedClasses do: 37553 [:aClass | 37554 (self methodChangesAtClass: aClass name) associationsDo: 37555 [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: 37556 [method := aClass compiledMethodAt: mAssoc key ifAbsent: [nil]. 37557 method ifNotNil: 37558 [method hasReportableSlip 37559 ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]. 37560 ^ slips! ! 37561 37562!ChangeSet methodsFor: 'filein/out' stamp: 'sd 4/16/2003 09:16'! 37563checkForUnclassifiedMethods 37564 "Open a message list browser on all methods in the current change set that have not been categorized," 37565 37566 | aList | 37567 (aList := self methodsWithoutClassifications) size > 0 37568 ifFalse: 37569 [^ self inform: 'All methods in "', self name, '" 37570are categorized.'] 37571 ifTrue: 37572 [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" which have not been categorized']! ! 37573 37574!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/17/2005 10:48'! 37575checkForUncommentedClasses 37576 "Check to see if any classes involved in this change set do not have class comments. Open up a browser showing all such classes." 37577 37578 | aList | 37579 aList := self changedClasses 37580 select: 37581 [:aClass | aClass theNonMetaClass organization classComment isEmptyOrNil] 37582 thenCollect: 37583 [:aClass | aClass theNonMetaClass name]. 37584 37585 aList size > 0 37586 ifFalse: 37587 [^ self inform: 'All classes involved in this change set have class comments'] 37588 ifTrue: 37589 [ToolSet openClassListBrowser: aList asSet asSortedArray title: 'Classes in Change Set ', self name, ': classes that lack class comments']! ! 37590 37591!ChangeSet methodsFor: 'filein/out' stamp: 'sd 4/16/2003 09:16'! 37592checkForUncommentedMethods 37593 | aList | 37594 "Check to see if there are any methods in the receiver that have no comments, and open a browser on all found" 37595 37596 (aList := self methodsWithoutComments) size > 0 37597 ifFalse: 37598 [^ self inform: 'All methods in "', self name, '" have comments'] 37599 ifTrue: 37600 [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" that lack comments']! ! 37601 37602!ChangeSet methodsFor: 'filein/out' stamp: 'stephane.ducasse 10/12/2008 21:02'! 37603checkForUnsentMessages 37604 "Check the change set for unsent messages, and if any are found, open 37605 up a message-list browser on them" 37606 | nameLine allChangedSelectors augList unsent | 37607 nameLine := '"' , self name , '"'. 37608 allChangedSelectors := Set new. 37609 (augList := self changedMessageListAugmented) 37610 do: [:each | each isValid 37611 ifTrue: [allChangedSelectors add: each methodSymbol]]. 37612 unsent := self systemNavigation allUnsentMessagesIn: allChangedSelectors. 37613 unsent size = 0 37614 ifTrue: [^ self inform: 'There are no unsent 37615messages in change set 37616' , nameLine]. 37617 self systemNavigation 37618 browseMessageList: (augList 37619 select: [:each | unsent includes: each methodSymbol]) 37620 name: 'Unsent messages in ' , nameLine! ! 37621 37622!ChangeSet methodsFor: 'filein/out' stamp: 'rbb 2/18/2005 14:21'! 37623chooseSubjectPrefixForEmail 37624 37625 | subjectIndex | 37626 37627 subjectIndex := 37628 (UIManager default chooseFrom: #('Bug fix [FIX]' 'Enhancement [ENH]' 'Goodie [GOODIE]' 'Test suite [TEST]' 'None of the above (will not be archived)') 37629 title: 'What type of change set\are you submitting to the list?' withCRs). 37630 37631 ^ #('[CS] ' '[FIX] ' '[ENH] ' '[GOODIE] ' '[TEST] ' '[CS] ') at: subjectIndex + 1! ! 37632 37633!ChangeSet methodsFor: 'filein/out' stamp: 'nk 10/15/2003 09:55'! 37634defaultChangeSetDirectory 37635 ^self class defaultChangeSetDirectory! ! 37636 37637!ChangeSet methodsFor: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 00:51'! 37638fileOut 37639 "File out the receiver, to a file whose name is a function of the 37640 change-set name and a unique numeric tag." 37641 | slips nameToUse internalStream | 37642 self checkForConversionMethods. 37643 ChangeSet promptForDefaultChangeSetDirectoryIfNecessary. 37644 nameToUse := self defaultChangeSetDirectory 37645 nextNameFor: self name extension: FileStream cs. 37646 nameToUse := self defaultChangeSetDirectory fullNameFor: nameToUse. 37647 Cursor write showWhile: [ 37648 internalStream := (String new: 10000) writeStream. 37649 internalStream header; timeStamp. 37650 self fileOutPreambleOn: internalStream. 37651 self fileOutOn: internalStream. 37652 self fileOutPostscriptOn: internalStream. 37653 internalStream trailer. 37654 37655 FileStream writeSourceCodeFrom: internalStream baseName: (nameToUse copyFrom: 1 to: nameToUse size - 3) isSt: false. 37656 ]. 37657 Preferences checkForSlips 37658 ifFalse: [^ self]. 37659 slips := self checkForSlips. 37660 (slips size > 0 37661 and: [self confirm: 'Methods in this fileOut have halts 37662or references to the Transcript 37663or other ''slips'' in them. 37664Would you like to browse them?' translated]) 37665 ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name]! ! 37666 37667!ChangeSet methodsFor: 'filein/out' stamp: 'di 3/28/2000 09:35'! 37668fileOutChangesFor: class on: stream 37669 "Write out all the method changes for this class." 37670 37671 | changes | 37672 changes := Set new. 37673 (self methodChangesAtClass: class name) associationsDo: 37674 [:mAssoc | (mAssoc value = #remove or: [mAssoc value = #addedThenRemoved]) 37675 ifFalse: [changes add: mAssoc key]]. 37676 changes isEmpty ifFalse: 37677 [class fileOutChangedMessages: changes on: stream. 37678 stream cr]! ! 37679 37680!ChangeSet methodsFor: 'filein/out' stamp: 'dvf 9/27/2005 19:04'! 37681fileOutOn: stream 37682 "Write out all the changes the receiver knows about" 37683 37684 | classList traits classes traitList list | 37685 (self isEmpty and: [stream isKindOf: FileStream]) 37686 ifTrue: [self inform: 'Warning: no changes to file out']. 37687 37688 traits := self changedClasses reject: [:each | each isBehavior]. 37689 classes := self changedClasses select: [:each | each isBehavior]. 37690 traitList := self class traitsOrder: traits asOrderedCollection. 37691 classList := self class superclassOrder: classes asOrderedCollection. 37692 list := OrderedCollection new 37693 addAll: traitList; 37694 addAll: classList; 37695 yourself. 37696 37697 "First put out rename, max classDef and comment changes." 37698 list do: [:aClass | self fileOutClassDefinition: aClass on: stream]. 37699 37700 "Then put out all the method changes" 37701 list do: [:aClass | self fileOutChangesFor: aClass on: stream]. 37702 37703 "Finally put out removals, final class defs and reorganization if any" 37704 list reverseDo: [:aClass | self fileOutPSFor: aClass on: stream]. 37705 37706 self classRemoves asSortedCollection do: 37707 [:aClassName | stream nextChunkPut: 'Smalltalk removeClassNamed: #', aClassName; cr].! ! 37708 37709!ChangeSet methodsFor: 'filein/out' stamp: 'al 7/22/2008 21:35'! 37710fileOutPSFor: class on: stream 37711 "Write out removals and initialization for this class." 37712 37713 | dict changeType classRecord currentDef | 37714 classRecord := changeRecords at: class name ifAbsent: [^ self]. 37715 dict := classRecord methodChangeTypes. 37716 dict keysSortedSafely do: 37717 [:key | changeType := dict at: key. 37718 (#(remove addedThenRemoved) includes: changeType) 37719 ifTrue: [stream nextChunkPut: class name, 37720 ' removeSelector: ', key storeString; cr] 37721 ifFalse: [(key = #initialize and: [class isMeta]) ifTrue: 37722 [stream nextChunkPut: class soleInstance name, ' initialize'; cr]]]. 37723 ((classRecord includesChangeType: #change) 37724 and: [(currentDef := class definition) ~= (self fatDefForClass: class)]) ifTrue: 37725 [stream nextChunkPut: currentDef; cr ]. 37726 (classRecord includesChangeType: #reorganize) ifTrue: 37727 [class fileOutOrganizationOn: stream. 37728 stream cr]! ! 37729 37730!ChangeSet methodsFor: 'filein/out' stamp: 'di 3/29/1999 13:35'! 37731fileOutPostscriptOn: stream 37732 "If the receiver has a postscript, put it out onto the stream. " 37733 37734 | aString | 37735 aString := self postscriptString. 37736 (aString ~~ nil and: [aString size > 0]) 37737 ifTrue: 37738 [stream nextChunkPut: aString "surroundedBySingleQuotes". 37739 stream cr; cr]! ! 37740 37741!ChangeSet methodsFor: 'filein/out' stamp: 'di 3/29/1999 14:58'! 37742fileOutPreambleOn: stream 37743 "If the receiver has a preamble, put it out onto the stream. " 37744 37745 | aString | 37746 aString := self preambleString. 37747 (aString ~~ nil and: [aString size > 0]) 37748 ifTrue: 37749 [stream nextChunkPut: aString "surroundedBySingleQuotes". 37750 stream cr; cr]! ! 37751 37752!ChangeSet methodsFor: 'filein/out' stamp: 'rbb 2/18/2005 14:16'! 37753lookForSlips 37754 "Scan the receiver for changes that the user may regard as slips to be remedied" 37755 37756 | slips nameLine msg | 37757 nameLine := ' 37758"', self name, '" 37759'. 37760 (slips := self checkForSlips) size == 0 ifTrue: 37761 [^ self inform: 'No slips detected in change set', nameLine]. 37762 37763 msg := slips size == 1 37764 ifTrue: 37765 [ 'One method in change set', nameLine, 37766'has a halt, reference to the Transcript, 37767and/or some other ''slip'' in it. 37768Would you like to browse it? ?'] 37769 ifFalse: 37770 [ slips size printString, 37771' methods in change set', nameLine, 'have halts or references to the 37772Transcript or other ''slips'' in them. 37773Would you like to browse them?']. 37774 37775 (UIManager default chooseFrom: #('Ignore' 'Browse slips') title: msg) = 2 37776 ifTrue: [self systemNavigation browseMessageList: slips 37777 name: 'Possible slips in ', name]! ! 37778 37779!ChangeSet methodsFor: 'filein/out' stamp: 'sd 4/16/2003 09:16'! 37780mailOut 37781 "Email a compressed version of this changeset to the squeak-dev list, so that it can be shared with everyone. (You will be able to edit the email before it is sent.)" 37782 37783 | userName message slips | 37784 37785 userName := MailSender userName. 37786 37787 self checkForConversionMethods. 37788 Cursor write showWhile: [message := self buildMessageForMailOutWithUser: userName]. 37789 37790 MailSender sendMessage: message. 37791 37792 Preferences suppressCheckForSlips ifTrue: [^ self]. 37793 slips := self checkForSlips. 37794 (slips size > 0 and: [self confirm: 'Methods in this fileOut have halts 37795or references to the Transcript 37796or other ''slips'' in them. 37797Would you like to browse them?']) 37798 ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name] 37799! ! 37800 37801!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/15/2005 21:27'! 37802objectForDataStream: refStrm 37803 "I am about to be written on an object file. Write a path to me in the other system instead." 37804 37805 refStrm projectChangeSet == self ifTrue: [^ self]. 37806 37807 "try to write reference for me" 37808 ^ DiskProxy 37809 global: #ChangeSet 37810 selector: #existingOrNewChangeSetNamed: 37811 args: (Array with: self name) 37812"=== 37813 refStrm replace: self with: nil. 37814 ^ nil 37815===" 37816! ! 37817 37818!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:03'! 37819postscript 37820 "Answer the string representing the postscript. " 37821 ^postscript ifNotNil:[postscript isString ifTrue:[postscript] ifFalse:[postscript contents asString]]! ! 37822 37823!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:03'! 37824postscript: aString 37825 "Answer the string representing the postscript. " 37826 postscript := aString! ! 37827 37828!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:03'! 37829postscriptString 37830 "Answer the string representing the postscript. " 37831 ^self postscript! ! 37832 37833!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:03'! 37834postscriptString: aString 37835 "Establish aString as the new contents of the postscript. " 37836 self postscript: aString! ! 37837 37838!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 17:55'! 37839preamble 37840 "Answer the string representing the preamble" 37841 ^preamble ifNotNil:[preamble isString ifTrue:[preamble] ifFalse:[preamble contents asString]]! ! 37842 37843!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:00'! 37844preamble: aString 37845 "Establish aString as the new contents of the preamble. " 37846 37847 preamble := aString! ! 37848 37849!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:00'! 37850preambleString 37851 "Answer the string representing the preamble" 37852 37853 ^self preamble! ! 37854 37855!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:00'! 37856preambleString: aString 37857 "Establish aString as the new contents of the preamble. " 37858 self preamble: aString.! ! 37859 37860!ChangeSet methodsFor: 'filein/out' stamp: 'nk 7/2/2003 10:47'! 37861preambleTemplate 37862 "Answer a string that will form the default contents for a change set's preamble. 37863 Just a first stab at what the content should be." 37864 37865 ^ String streamContents: [:strm | 37866 strm nextPutAll: '"Change Set:'. "NOTE: fileIn recognizes preambles by this string." 37867 strm tab;tab; nextPutAll: self name. 37868 strm cr; nextPutAll: 'Date:'; tab; tab; tab; nextPutAll: Date today printString. 37869 strm cr; nextPutAll: 'Author:'; tab; tab; tab; nextPutAll: Preferences defaultAuthorName. 37870 strm cr; cr; nextPutAll: '<your descriptive text goes here>"'] 37871"ChangeSet current preambleTemplate"! ! 37872 37873!ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:02'! 37874setPreambleToSay: aString 37875 "Make aString become the preamble of this change set" 37876 self preamble: aString! ! 37877 37878!ChangeSet methodsFor: 'filein/out' stamp: 'di 9/24/1999 12:33'! 37879summaryString 37880 "Answer the string summarizing this changeSet" 37881 37882 ^ self summaryStringDelta: 0 37883" 37884To summarize all recent changeSets on a file... 37885(FileStream newFileNamed: 'Summaries.txt') nextPutAll: 37886 (String streamContents: 37887 [:s | (ChangeSorter changeSetsNamedSuchThat: 37888 [:name | name first isDigit and: [name initialIntegerOrNil >= 948]]) 37889 do: [:cs | s nextPutAll: cs summaryString; cr]]); 37890 close 37891 37892To list all changeSets with a certain string in the preamble... 37893 (FileStream newFileNamed: 'MyUpdates.txt') nextPutAll: 37894 (String streamContents: 37895 [:s | ChangeSorter gatherChangeSetRevertables do: 37896 [:cs | (cs preambleString notNil 37897 and: [cs preambleString includesSubString: 'Author Name']) 37898 ifTrue: [s nextPutAll: cs summaryString; cr]]]); 37899 close 37900"! ! 37901 37902!ChangeSet methodsFor: 'filein/out' stamp: 'dc 5/30/2008 10:17'! 37903summaryStringDelta: delta 37904 "Answer the string summarizing this changeSet" 37905 | ps s2 date author line intName | 37906 ^ String streamContents: 37907 [ :s | 37908 intName := self name splitInteger. 37909 intName first isNumber 37910 ifTrue: [ s nextPutAll: (intName first + delta) printString , intName last ] 37911 ifFalse: [ s nextPutAll: intName first "weird convention of splitInteger" ]. 37912 (ps := self preambleString) 37913 ifNil: [ s cr ] 37914 ifNotNil: 37915 [ s2 := ps readStream. 37916 s2 37917 match: 'Date:'; 37918 skipSeparators. 37919 date := s2 upTo: Character cr. 37920 s2 37921 match: 'Author:'; 37922 skipSeparators. 37923 author := s2 upTo: Character cr. 37924 s 37925 nextPutAll: ' -- '; 37926 nextPutAll: author; 37927 nextPutAll: ' -- '; 37928 nextPutAll: date; 37929 cr. 37930 [ s2 atEnd ] whileFalse: 37931 [ line := s2 upTo: Character cr. 37932 (line isEmpty or: [ line = '"' ]) ifFalse: 37933 [ s 37934 nextPutAll: line; 37935 cr ] ] ] ]! ! 37936 37937!ChangeSet methodsFor: 'filein/out' stamp: 'sd 1/16/2004 21:31'! 37938verboseFileOut 37939 "File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'changeSetVersionNumbers'" 37940 37941 ChangeSet current fileOut. 37942 Transcript cr; show: 'Changes filed out ', Date dateAndTimeNow printString! ! 37943 37944 37945!ChangeSet methodsFor: 'initialization' stamp: 'di 3/29/2000 20:42'! 37946beIsolationSetFor: aProject 37947 37948 self isEmpty ifFalse: [self error: 'Must be empty at the start.']. 37949 isolatedProject := aProject. 37950 revertable := true.! ! 37951 37952!ChangeSet methodsFor: 'initialization' stamp: 'di 4/1/2000 12:00'! 37953clear 37954 "Reset the receiver to be empty. " 37955 37956 changeRecords := Dictionary new. 37957 preamble := nil. 37958 postscript := nil! ! 37959 37960!ChangeSet methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:44'! 37961initialize 37962 "Initialize the receiver to be empty." 37963 37964 super initialize. 37965 name ifNil: 37966 [^ self error: 'All changeSets must be registered, as in ChangeSorter newChangeSet']. 37967 revertable := false. 37968 self clear. 37969! ! 37970 37971!ChangeSet methodsFor: 'initialization'! 37972isMoribund 37973 "Answer whether the receiver is obsolete and about to die; part of an effort to get such guys cleared out from the change sorter. 2/7/96 sw" 37974 37975 ^ name == nil ! ! 37976 37977!ChangeSet methodsFor: 'initialization' stamp: 'sw 3/6/1999 09:31'! 37978veryDeepCopyWith: deepCopier 37979 "Return self; this is NOT the way to launch new change sets!! Having this method here allows Change Sorters to be in parts bins"! ! 37980 37981!ChangeSet methodsFor: 'initialization' stamp: 'di 3/23/2000 12:14'! 37982wither 37983 "The receiver is to be clobbered. Clear it out. 2/7/96 sw" 37984 37985 self clear. 37986 name := nil! ! 37987 37988!ChangeSet methodsFor: 'initialization' stamp: 'di 9/21/2000 15:29'! 37989zapHistory 37990 "Much stronger than trimHistory, but it should still leave the changeSet in good shape. 37991 Must not be done on revertable changeSets 37992 ChangeSet allInstancesDo: [:cs | cs zapHistory]." 37993 37994 revertable ifTrue: [^ self]. "No can do" 37995 changeRecords do: [:chgRecord | chgRecord zapHistory]! ! 37996 37997 37998!ChangeSet methodsFor: 'isolation layers' stamp: 'di 4/1/2000 09:25'! 37999compileAll: newClass from: oldClass 38000 "If I have changes for this class, recompile them" 38001 38002 (changeRecords at: newClass ifAbsent: [^ self]) 38003 compileAll: newClass from: oldClass 38004! ! 38005 38006!ChangeSet methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:47'! 38007invoke 38008 38009 "Do the first part of the invoke operation -- no particular hurry." 38010 changeRecords do: [:changeRecord | changeRecord invokePhase1]. 38011 38012 "Complete the invoke process -- this must be very simple." 38013 "Replace method dicts for any method changes." 38014 changeRecords do: [:changeRecord | changeRecord invokePhase2]. 38015 Behavior flushCache. 38016 38017! ! 38018 38019!ChangeSet methodsFor: 'isolation layers' stamp: 'di 4/13/2000 12:47'! 38020isolatedProject 38021 "Return the isolated project for which I am the changeSet." 38022 38023 ^ isolatedProject! ! 38024 38025!ChangeSet methodsFor: 'isolation layers' stamp: 'di 3/29/2000 13:59'! 38026isolationSet: setOrNil 38027 38028 setOrNil == self 38029 ifTrue: [isolationSet := nil] "Means this IS the isolation set" 38030 ifFalse: [isolationSet := setOrNil]! ! 38031 38032!ChangeSet methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:47'! 38033revoke 38034 38035 "Do the first part of the revoke operation -- this must be very simple." 38036 "Replace original method dicts if there are method changes." 38037 changeRecords do: [:changeRecord | changeRecord revokePhase1]. 38038 Behavior flushCache. 38039 38040 "Complete the revoke process -- no particular hurry." 38041 changeRecords do: [:changeRecord | changeRecord revokePhase2]. 38042! ! 38043 38044!ChangeSet methodsFor: 'isolation layers' stamp: 'di 3/23/2000 12:00'! 38045uninstall 38046 38047 self halt. 38048! ! 38049 38050 38051!ChangeSet methodsFor: 'method changes' stamp: 'sw 12/28/2000 18:08'! 38052adoptSelector: aSelector forClass: aClass 38053 "Adopt the given selector/class combination as a change in the receiver" 38054 38055 self noteNewMethod: (aClass methodDictionary at: aSelector) 38056 forClass: aClass selector: aSelector priorMethod: nil! ! 38057 38058!ChangeSet methodsFor: 'method changes' stamp: 'md 8/27/2005 16:37'! 38059atSelector: selector class: class put: changeType 38060 38061 selector isDoIt ifTrue: [^ self]. 38062 (self changeRecorderFor: class) atSelector: selector put: changeType. 38063! ! 38064 38065!ChangeSet methodsFor: 'method changes' stamp: 'sw 6/26/2001 12:15'! 38066changedMessageList 38067 "Used by a message set browser to access the list view information." 38068 38069 | messageList classNameInFull classNameInParts | 38070 messageList := OrderedCollection new. 38071 changeRecords associationsDo: [:clAssoc | 38072 classNameInFull := clAssoc key asString. 38073 classNameInParts := classNameInFull findTokens: ' '. 38074 38075 (clAssoc value allChangeTypes includes: #comment) ifTrue: 38076 [messageList add: 38077 (MethodReference new 38078 setClassSymbol: classNameInParts first asSymbol 38079 classIsMeta: false 38080 methodSymbol: #Comment 38081 stringVersion: classNameInFull, ' Comment')]. 38082 38083 clAssoc value methodChangeTypes associationsDo: [:mAssoc | 38084 (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: 38085 [messageList add: 38086 (MethodReference new 38087 setClassSymbol: classNameInParts first asSymbol 38088 classIsMeta: classNameInParts size > 1 38089 methodSymbol: mAssoc key 38090 stringVersion: classNameInFull, ' ' , mAssoc key)]]]. 38091 ^ messageList asSortedArray! ! 38092 38093!ChangeSet methodsFor: 'method changes' stamp: 'tk 6/7/1999 18:57'! 38094changedMessageListAugmented 38095 "Even added classes have all messages in changedMessageList." 38096 ^ self changedMessageList asArray! ! 38097 38098!ChangeSet methodsFor: 'method changes' stamp: 'sw 4/19/2001 19:45'! 38099hasAnyChangeForSelector: aSelector 38100 "Answer whether the receiver has any change under the given selector, whether it be add, change, or remove, for any class" 38101 38102 changeRecords do: 38103 [:aRecord | (aRecord changedSelectors includes: aSelector) 38104 ifTrue: [^ true]]. 38105 ^ false! ! 38106 38107!ChangeSet methodsFor: 'method changes' stamp: 'RAA 5/28/2001 12:05'! 38108messageListForChangesWhich: aBlock ifNone: ifEmptyBlock 38109 38110 | answer | 38111 38112 answer := self changedMessageListAugmented select: [ :each | 38113 aBlock value: each actualClass value: each methodSymbol 38114 ]. 38115 answer isEmpty ifTrue: [^ifEmptyBlock value]. 38116 ^answer 38117! ! 38118 38119!ChangeSet methodsFor: 'method changes' stamp: 'di 4/1/2000 12:00'! 38120methodChangesAtClass: className 38121 "Return an old-style dictionary of method change types." 38122 38123 ^(changeRecords at: className ifAbsent: [^ Dictionary new]) 38124 methodChangeTypes! ! 38125 38126!ChangeSet methodsFor: 'method changes' stamp: 'di 4/4/2000 11:14'! 38127removeSelectorChanges: selector class: class 38128 "Remove all memory of changes associated with the argument, selector, in 38129 this class." 38130 38131 | chgRecord | 38132 (chgRecord := changeRecords at: class name ifAbsent: [^ self]) 38133 removeSelector: selector. 38134 chgRecord hasNoChanges ifTrue: [changeRecords removeKey: class name]! ! 38135 38136!ChangeSet methodsFor: 'method changes' stamp: 'SqR 6/13/2000 19:16'! 38137selectorsInClass: aClassName 38138 "Used by a ChangeSorter to access the list methods." 38139 38140 ^ (changeRecords at: aClassName ifAbsent: [^#()]) changedSelectors! ! 38141 38142 38143!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 09:37'! 38144absorbClass: className from: otherChangeSet 38145 "Absorb into the receiver all the changes found in the class in the other change set. 38146 *** Classes renamed in otherChangeSet may have problems" 38147 38148 | cls | 38149 (self changeRecorderFor: className) 38150 assimilateAllChangesIn: (otherChangeSet changeRecorderFor: className). 38151 38152 (cls := Smalltalk classNamed: className) ifNotNil: 38153 [self absorbStructureOfClass: cls from: otherChangeSet]. 38154! ! 38155 38156!ChangeSet methodsFor: 'moving changes' stamp: 'di 3/23/2000 11:52'! 38157absorbMethod: selector class: aClass from: aChangeSet 38158 "Absorb into the receiver all the changes for the method in the class in the other change set." 38159 38160 | info | 38161 info := aChangeSet methodChanges at: aClass name ifAbsent: [Dictionary new]. 38162 self atSelector: selector class: aClass put: (info at: selector). 38163 38164! ! 38165 38166!ChangeSet methodsFor: 'moving changes' stamp: 'sw 1/30/2001 15:41'! 38167absorbStructureOfClass: aClass from: otherChangeSet 38168 "Absorb into the receiver all the structure and superclass info in the other change set. Used to write conversion methods." 38169 38170 | sup next | 38171 otherChangeSet structures ifNil: [^ self]. 38172 (otherChangeSet structures includesKey: aClass name) ifFalse: [^ self]. 38173 structures ifNil: 38174 [structures := Dictionary new. 38175 superclasses := Dictionary new]. 38176 sup := aClass name. 38177 [(structures includesKey: sup) 38178 ifTrue: ["use what is here" true] 38179 ifFalse: [self flag: #noteToDan. "sw 1/30/2001 13:57 emergency workaround -- a case arose where the otherChangeSet's structures did not have the key, and it gummed up the works." 38180 (otherChangeSet structures includesKey: sup) ifTrue: 38181 [structures at: sup put: (otherChangeSet structures at: sup)]. 38182 next := otherChangeSet superclasses at: sup. 38183 superclasses at: sup put: next. 38184 (sup := next) = 'nil'] 38185 ] whileFalse. 38186 38187 38188! ! 38189 38190!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 11:21'! 38191assimilateAllChangesFoundIn: otherChangeSet 38192 "Make all changes in otherChangeSet take effect on self as if they happened just now." 38193 38194 otherChangeSet changedClassNames do: 38195 [:className | self absorbClass: className from: otherChangeSet] 38196! ! 38197 38198!ChangeSet methodsFor: 'moving changes' stamp: 'ar 7/16/2005 18:59'! 38199editPreamble 38200 "edit the receiver's preamble, in a separate window. " 38201 self assurePreambleExists. 38202 UIManager default 38203 edit: self preamble 38204 label: 'Preamble for ChangeSet named ', name 38205 accept:[:aString| self preamble: aString]! ! 38206 38207!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 11:49'! 38208expungeEmptyClassChangeEntries 38209 38210 changeRecords keysAndValuesRemove: 38211 [:className :classRecord | classRecord hasNoChanges]! ! 38212 38213!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 12:40'! 38214forgetAllChangesFoundIn: otherChangeSet 38215 "Remove from the receiver all method changes found in aChangeSet. The intention is facilitate the process of factoring a large set of changes into disjoint change sets. To use: in a change sorter, copy over all the changes you want into some new change set, then use the subtract-other-side feature to subtract those changes from the larger change set, and continue in this manner." 38216 38217 otherChangeSet == self ifTrue: [^ self]. 38218 otherChangeSet changedClassNames do: 38219 [:className | self forgetChangesForClass: className in: otherChangeSet]. 38220 self expungeEmptyClassChangeEntries. 38221 38222" Old code... 38223 aChangeSet changedClassNames do: 38224 [:className | 38225 (cls := Smalltalk classNamed: className) ~~ nil ifTrue: 38226 [itsMethodChanges := aChangeSet methodChanges at: className 38227 ifAbsent: [Dictionary new]. 38228 itsMethodChanges associationsDo: [:assoc | 38229 self forgetChange: assoc value forSelector: assoc key class: cls]. 38230 myClassChange := self classChangeAt: className. 38231 myClassChange size > 0 ifTrue: 38232 [(aChangeSet classChangeAt: className) do: 38233 [:aChange | myClassChange remove: aChange ifAbsent: []]]. 38234 self noteClassForgotten: className]]. 38235 38236 aChangeSet classRemoves do: 38237 [:className | (recorder := changeRecords at: className ifAbsent: []) 38238 ifNotNil: [recorder forgetClassRemoval]]. 38239 self expungeEmptyClassChangeEntries 38240" 38241! ! 38242 38243!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 12:04'! 38244forgetChangesForClass: className in: otherChangeSet 38245 "See forgetAllChangesFoundIn:. Used in culling changeSets." 38246 38247 (self changeRecorderFor: className) 38248 forgetChangesIn: (otherChangeSet changeRecorderFor: className). 38249 self noteClassForgotten: className 38250! ! 38251 38252!ChangeSet methodsFor: 'moving changes' stamp: 'sw 3/5/1999 19:27'! 38253hasPreamble 38254 ^ preamble notNil! ! 38255 38256!ChangeSet methodsFor: 'moving changes' stamp: 'nk 3/30/2002 09:13'! 38257methodsWithAnyInitialsOtherThan: myInits 38258 "Return a collection of method refs whose author appears to be different from the given one, even historically" 38259 | slips method aTimeStamp | 38260 slips := Set new. 38261 self changedClasses do: [:aClass | 38262 (self methodChangesAtClass: aClass name) associationsDo: [ :mAssoc | 38263 (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: 38264 [method := aClass compiledMethodAt: mAssoc key ifAbsent: [nil]. 38265 method ifNotNil: [ 38266 (aClass changeRecordsAt: mAssoc key) do: [ :chg | 38267 aTimeStamp := chg stamp. 38268 (aTimeStamp notNil and: [(aTimeStamp beginsWith: myInits) not]) 38269 ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]]. 38270 ^ slips! ! 38271 38272!ChangeSet methodsFor: 'moving changes' stamp: 'nk 7/2/2003 10:47'! 38273methodsWithInitialsOtherThan: myInits 38274 "Return a collection of method refs whose author appears to be different from the given one" 38275 | slips method aTimeStamp | 38276 slips := OrderedCollection new. 38277 self changedClasses do: 38278 [:aClass | 38279 (self methodChangesAtClass: aClass name) associationsDo: 38280 [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: 38281 [method := aClass compiledMethodAt: mAssoc key ifAbsent: [nil]. 38282 method ifNotNil: 38283 [((aTimeStamp := Utilities timeStampForMethod: method) notNil and: 38284 [(aTimeStamp beginsWith: myInits) not]) 38285 ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]. 38286 ^ slips 38287 38288 "Smalltalk browseMessageList: (ChangeSet current methodsWithInitialsOtherThan: 'sw') name: 'authoring problems'"! ! 38289 38290!ChangeSet methodsFor: 'moving changes' stamp: 'nk 7/2/2003 10:47'! 38291methodsWithoutComments 38292 "Return a collection representing methods in the receiver which have no precode comments" 38293 38294 | slips | 38295 slips := OrderedCollection new. 38296 self changedClasses do: 38297 [:aClass | 38298 (self methodChangesAtClass: aClass name) associationsDo: 38299 [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: 38300 [(aClass selectors includes: mAssoc key) ifTrue: 38301 [(aClass firstPrecodeCommentFor: mAssoc key) isEmptyOrNil 38302 ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]. 38303 ^ slips 38304 38305 "Smalltalk browseMessageList: (ChangeSet current methodsWithoutComments) name: 'methods lacking comments'"! ! 38306 38307!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/1/2000 12:00'! 38308removeClassAndMetaClassChanges: class 38309 "Remove all memory of changes associated with this class and its metaclass. 7/18/96 sw" 38310 38311 changeRecords removeKey: class name ifAbsent: []. 38312 changeRecords removeKey: class class name ifAbsent: []. 38313! ! 38314 38315!ChangeSet methodsFor: 'moving changes' stamp: 'yo 8/30/2002 13:59'! 38316removeClassChanges: class 38317 "Remove all memory of changes associated with this class" 38318 | cname | 38319 (class isString) 38320 ifTrue: [ cname := class ] 38321 ifFalse: [ cname := class name ]. 38322 38323 changeRecords removeKey: cname ifAbsent: []. 38324 self noteClassForgotten: cname.! ! 38325 38326!ChangeSet methodsFor: 'moving changes' stamp: 'sw 3/5/1999 19:32'! 38327removePreamble 38328 preamble := nil! ! 38329 38330 38331!ChangeSet methodsFor: 'testing' stamp: 'sw 8/10/2002 22:21'! 38332containsMethodAtPosition: aFilePosition 38333 "Answer whether the receiver contains the method logged at the given file position" 38334 38335 "class: aClassSymbol" "(need class parameter to speed up?)" "<- dew 9/6/2001" 38336 38337 changeRecords values do: 38338 [:classChangeRecord | 38339 classChangeRecord methodChanges values do: 38340 [:methodChangeRecord | | changeType | 38341 changeType := methodChangeRecord changeType. 38342 ((changeType == #add or: [changeType == #change]) and: 38343 [methodChangeRecord currentMethod notNil and: [methodChangeRecord currentMethod filePosition = aFilePosition]]) 38344 ifTrue: [^ true]]]. 38345 ^ false! ! 38346 38347!ChangeSet methodsFor: 'testing' stamp: 'RAA 10/19/2000 13:17'! 38348isEmpty 38349 "Answer whether the receiver contains any elements." 38350 38351 changeRecords ifNil: [^true]. 38352 ^ changeRecords isEmpty ! ! 38353 38354!ChangeSet methodsFor: 'testing' stamp: 'nk 7/2/2003 10:47'! 38355methodsWithoutClassifications 38356 "Return a collection representing methods in the receiver which have not been categorized" 38357 38358 | slips notClassified aSelector | 38359 38360 notClassified := {'as yet unclassified' asSymbol. #all}. 38361 slips := OrderedCollection new. 38362 self changedClasses do: 38363 [:aClass | 38364 (self methodChangesAtClass: aClass name) associationsDo: 38365 [:mAssoc | (aClass selectors includes: (aSelector := mAssoc key)) ifTrue: 38366 [(notClassified includes: (aClass organization categoryOfElement: aSelector)) 38367 ifTrue: [slips add: aClass name , ' ' , aSelector]]]]. 38368 ^ slips 38369 38370 "Smalltalk browseMessageList: (ChangeSet current methodsWithoutClassifications) name: 'unclassified methods'"! ! 38371 38372!ChangeSet methodsFor: 'testing' stamp: 'sw 8/3/1998 16:25'! 38373okayToRemove 38374 ^ self okayToRemoveInforming: true! ! 38375 38376!ChangeSet methodsFor: 'testing' stamp: 'stephane.ducasse 7/10/2009 16:44'! 38377okayToRemoveInforming: aBoolean 38378 "Answer whether it is okay to remove the receiver. If aBoolean is true, inform the receiver if it is not okay" 38379 38380 | aName | 38381 aName := self name. 38382 self == self class current ifTrue: 38383 [aBoolean ifTrue: [self inform: 'Cannot remove "', aName, '" 38384because it is the 38385current change set.']. 38386 ^ false]. 38387 ^ true 38388! ! 38389 38390 38391!ChangeSet methodsFor: 'private' stamp: 'di 3/23/2000 08:37'! 38392addCoherency: className 38393 "SqR!! 19980923: If I recreate the class then don't remove it" 38394 38395 (self changeRecorderFor: className) 38396 checkCoherence. 38397" 38398 classRemoves remove: className ifAbsent: []. 38399 (classChanges includesKey: className) ifTrue: 38400 [(classChanges at: className) remove: #remove ifAbsent: []] 38401"! ! 38402 38403!ChangeSet methodsFor: 'private' stamp: 'di 3/28/2000 14:40'! 38404atClass: class add: changeType 38405 38406 (self changeRecorderFor: class) 38407 noteChangeType: changeType fromClass: class! ! 38408 38409!ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'! 38410atClass: class includes: changeType 38411 38412 ^(changeRecords at: class name ifAbsent: [^false]) 38413 includesChangeType: changeType! ! 38414 38415!ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'! 38416atSelector: selector class: class 38417 38418 ^ (changeRecords at: class name ifAbsent: [^ #none]) 38419 atSelector: selector ifAbsent: [^ #none]! ! 38420 38421!ChangeSet methodsFor: 'private'! 38422changed: anAspectSymbol with: aParameter 38423 "Allow objects to depend on the ChangeSet class instead of a particular instance 38424 of ChangeSet (which may be switched using projects)." 38425 38426 ChangeSet changed: anAspectSymbol with: aParameter. 38427 super changed: anAspectSymbol with: aParameter! ! 38428 38429!ChangeSet methodsFor: 'private' stamp: 'yo 8/30/2002 13:59'! 38430changeRecorderFor: class 38431 38432 | cname | 38433 (class isString) 38434 ifTrue: [ cname := class ] 38435 ifFalse: [ cname := class name ]. 38436 38437 "Later this will init the changeRecords so according to whether they should be revertable." 38438 ^ changeRecords at: cname 38439 ifAbsent: [^ changeRecords at: cname 38440 put: (ClassChangeRecord new initFor: cname revertable: revertable)]! ! 38441 38442!ChangeSet methodsFor: 'private' stamp: 'al 7/22/2008 21:36'! 38443fileOutClassDefinition: class on: stream 38444 "Write out class definition for the given class on the given stream, if the class definition was added or changed." 38445 38446 (self atClass: class includes: #rename) ifTrue: 38447 [stream nextChunkPut: 'Smalltalk renameClassNamed: #', (self oldNameFor: class), ' as: #', class name; cr]. 38448 38449 (self atClass: class includes: #change) ifTrue: [ "fat definition only needed for changes" 38450 stream nextChunkPut: (self fatDefForClass: class); cr. 38451 DeepCopier new checkClass: class. "If veryDeepCopy weakly copies some inst 38452 vars in this class, warn author when new ones are added." 38453 ] ifFalse: [ 38454 (self atClass: class includes: #add) ifTrue: [ "use current definition for add" 38455 stream nextChunkPut: class definition; cr. 38456 DeepCopier new checkClass: class. "If veryDeepCopy weakly copies some inst 38457 vars in this class, warn author when new ones are added." 38458 ]. 38459 ]. 38460 38461 (self atClass: class includes: #comment) ifTrue: 38462 [class theNonMetaClass organization putCommentOnFile: stream numbered: 0 moveSource: false forClass: class theNonMetaClass. 38463 stream cr]. 38464 38465! ! 38466 38467!ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'! 38468oldNameFor: class 38469 38470 ^ (changeRecords at: class name) priorName! ! 38471 38472"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 38473 38474ChangeSet class 38475 instanceVariableNames: 'current'! 38476 38477!ChangeSet class methodsFor: 'current changeset' stamp: 'ar 7/17/2005 10:48'! 38478browseChangedMessages 38479 "Create and schedule a message browser on each method that has been 38480 changed." 38481 38482 current isEmpty ifTrue: [^ self inform: 'There are no changed messages 38483in the current change set.']. 38484 ToolSet openChangedMessageSet: current.! ! 38485 38486!ChangeSet class methodsFor: 'current changeset' stamp: 'wiz 9/19/2006 03:21'! 38487current 38488 "return the current changeset 38489 assure first that we have a named changeset. To cure mantis #4535. " 38490 current isMoribund 38491 ifTrue: [(ChangeSet newChanges: (ChangeSet assuredChangeSetNamed: 'Unnamed'))] . 38492 38493 ^ current! ! 38494 38495!ChangeSet class methodsFor: 'current changeset' stamp: 'em 3/31/2005 11:48'! 38496currentChangeSetString 38497 "ChangeSet current currentChangeSetString" 38498 38499 ^ 'Current Change Set: ' translated, self current name! ! 38500 38501!ChangeSet class methodsFor: 'current changeset' stamp: 'NS 1/16/2004 14:49'! 38502newChanges: aChangeSet 38503 "Set the system ChangeSet to be the argument, aChangeSet. Tell the current project that aChangeSet is now its change set. When called from Project enter:, the setChangeSet: call is redundant but harmless; when called from code that changes the current-change-set from within a project, it's vital" 38504 38505 SystemChangeNotifier uniqueInstance noMoreNotificationsFor: current. 38506 current isolationSet: nil. 38507 current := aChangeSet. 38508 SystemChangeNotifier uniqueInstance notify: aChangeSet ofAllSystemChangesUsing: #event:. 38509 Smalltalk currentProjectDo: 38510 [:proj | 38511 proj setChangeSet: aChangeSet. 38512 aChangeSet isolationSet: proj isolationSet]! ! 38513 38514!ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 22:18'! 38515noChanges 38516 "Initialize the system ChangeSet." 38517 38518 current initialize! ! 38519 38520!ChangeSet class methodsFor: 'current changeset' stamp: 'sd 9/8/2006 21:05'! 38521resetCurrentToNewUnnamedChangeSet 38522 38523 current := self new. 38524 self newChanges: current ! ! 38525 38526 38527!ChangeSet class methodsFor: 'defaults' stamp: 'nk 7/18/2004 16:13'! 38528defaultChangeSetDirectory 38529 "Answer the directory in which to store ChangeSets. 38530 Answer the default directory if the preferred directory doesn't exist." 38531 | dir directoryName | 38532 directoryName := Preferences 38533 parameterAt: #defaultChangeSetDirectoryName 38534 ifAbsentPut: ['']. 38535 dir := directoryName isEmptyOrNil 38536 ifTrue: [ FileDirectory default ] 38537 ifFalse: [ FileDirectory default directoryNamed: directoryName ]. 38538 dir exists 38539 ifTrue: [^ dir]. 38540 ^ FileDirectory default! ! 38541 38542!ChangeSet class methodsFor: 'defaults' stamp: 'nk 3/24/2004 15:52'! 38543defaultChangeSetDirectory: dirOrName 38544 "Set the Preference for storing change sets to the given directory or name (possibly relative). 38545 Rewrite directory names below the default directory as relative names. 38546 If dirOrName is an empty string, use the default directory." 38547 38548 "ChangeSet defaultChangeSetDirectory: 'changeSets'" 38549 38550 | dirName defaultFullName | 38551 dirName := dirOrName isString 38552 ifTrue: [FileDirectory default fullNameFor: dirOrName] 38553 ifFalse: [dirOrName fullName]. 38554 defaultFullName := FileDirectory default fullName. 38555 dirName = defaultFullName 38556 ifTrue: [dirName := ''] 38557 ifFalse: [(dirName beginsWith: defaultFullName , FileDirectory slash) 38558 ifTrue: [dirName := dirName copyFrom: defaultFullName size + 2 to: dirName size]]. 38559 Preferences setParameter: #defaultChangeSetDirectoryName to: dirName! ! 38560 38561!ChangeSet class methodsFor: 'defaults' stamp: 'dgd 9/6/2003 19:56'! 38562defaultName 38563 ^ self uniqueNameLike: 'Unnamed' translated! ! 38564 38565!ChangeSet class methodsFor: 'defaults' stamp: 'alain.plantec 2/8/2009 18:54'! 38566promptForDefaultChangeSetDirectoryIfNecessary 38567 "Check the Preference (if any), and prompt the 38568 user to change it if necessary. 38569 The default if the Preference is unset is the current 38570 directory. Answer the directory." 38571 "ChangeSet 38572 promptForDefaultChangeSetDirectoryIfNecessary" 38573 | choice directoryName dir message | 38574 directoryName := Preferences 38575 parameterAt: #defaultChangeSetDirectoryName 38576 ifAbsentPut: ['']. 38577 [dir := FileDirectory default directoryNamed: directoryName. 38578 dir exists] 38579 whileFalse: [message := 'The preferred change set directory' translated , ' (''{1}'') ' , 'does not exist.' translated , ' 38580' , 'Create it or use the default directory' translated , ' ({2})?' format: {directoryName. FileDirectory default pathName}. 38581 choice := UIManager default 38582 chooseFrom: (#('Create directory' 'Use default directory and forget preference' 'Choose another directory' ) 38583 collect: [:ea | ea translated]) 38584 message: message. 38585 choice = 1 38586 ifTrue: [dir assureExistence]. 38587 choice = 3 38588 ifTrue: [dir := UIManager default chooseDirectory. 38589 directoryName := dir 38590 ifNil: [''] 38591 ifNotNil: [dir pathName]]]. 38592 self defaultChangeSetDirectory: directoryName. 38593 ^ dir! ! 38594 38595!ChangeSet class methodsFor: 'defaults' stamp: 'ar 7/15/2005 21:24'! 38596uniqueNameLike: aString 38597 38598 | try | 38599 (self named: aString) ifNil: [^ aString]. 38600 38601 1 to: 999999 do: 38602 [:i | try := aString , i printString. 38603 (self named: try) ifNil: [^ try]]! ! 38604 38605 38606!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:20'! 38607allChangeSetNames 38608 ^ self allChangeSets collect: [:c | c name]! ! 38609 38610!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:10'! 38611allChangeSets 38612 "Return the list of all current ChangeSets" 38613 38614 ^ AllChangeSets! ! 38615 38616!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:22'! 38617allChangeSetsWithClass: class selector: selector 38618 class ifNil: [^ #()]. 38619 ^ self allChangeSets select: 38620 [:cs | (cs atSelector: selector class: class) ~~ #none]! ! 38621 38622!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:17'! 38623allChangeSets: aCollection 38624 "Return the list of all current ChangeSets" 38625 38626 AllChangeSets := aCollection.! ! 38627 38628!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:14'! 38629basicNewChangeSet: newName 38630 | newSet | 38631 newName ifNil: [^ nil]. 38632 (self named: newName) ifNotNil: 38633 [self inform: 'Sorry that name is already used'. 38634 ^ nil]. 38635 newSet := self basicNewNamed: newName. 38636 AllChangeSets add: newSet. 38637 ^ newSet! ! 38638 38639!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:11'! 38640changeSetsNamedSuchThat: nameBlock 38641 "(ChangeSet changeSetsNamedSuchThat: 38642 [:name | name first isDigit and: [name initialInteger >= 373]]) 38643 do: [:cs | AllChangeSets remove: cs wither]" 38644 38645 ^ AllChangeSets select: [:aChangeSet | nameBlock value: aChangeSet name]! ! 38646 38647!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:26'! 38648changeSet: aChangeSet containsClass: aClass 38649 | theClass | 38650 theClass := Smalltalk classNamed: aClass. 38651 theClass ifNil: [^ false]. 38652 ^ aChangeSet containsClass: theClass! ! 38653 38654!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:26'! 38655deleteChangeSetsNumberedLowerThan: anInteger 38656 "Delete all changes sets whose names start with integers smaller than anInteger" 38657 38658 self removeChangeSetsNamedSuchThat: 38659 [:aName | aName first isDigit and: [aName initialIntegerOrNil < anInteger]]. 38660 38661 "ChangeSet deleteChangeSetsNumberedLowerThan: (ChangeSorterPlus highestNumberedChangeSet name initialIntegerOrNil - 500)" 38662! ! 38663 38664!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:24'! 38665existingOrNewChangeSetNamed: aName 38666 38667 | newSet | 38668 ^(self named: aName) ifNil: [ 38669 newSet := self basicNewNamed: aName. 38670 AllChangeSets add: newSet. 38671 newSet 38672 ]! ! 38673 38674!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:12'! 38675gatherChangeSets "ChangeSet gatherChangeSets" 38676 "Collect any change sets created in other projects" 38677 | allChangeSets obsolete | 38678 allChangeSets := AllChangeSets asSet. 38679 ChangeSet allSubInstances do: [:each | 38680 (allChangeSets includes: each) == (obsolete := each isMoribund) ifTrue:[ 38681 obsolete 38682 ifTrue: ["Was included and is obsolete." 38683 AllChangeSets remove: each] 38684 ifFalse: ["Was not included and is not obsolete." 38685 AllChangeSets add: each]]]. 38686 ^ AllChangeSets! ! 38687 38688!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:20'! 38689highestNumberedChangeSet 38690 "ChangeSorter highestNumberedChangeSet" 38691 | aList | 38692 aList := (self allChangeSetNames select: [:aString | aString startsWithDigit] thenCollect: 38693 [:aString | aString initialIntegerOrNil]). 38694 ^ (aList size > 0) 38695 ifTrue: 38696 [aList max] 38697 ifFalse: 38698 [nil] 38699! ! 38700 38701!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:29'! 38702mostRecentChangeSetWithChangeForClass: class selector: selector 38703 | hits | 38704 hits := self allChangeSets select: 38705 [:cs | (cs atSelector: selector class: class) ~~ #none]. 38706 hits isEmpty ifTrue: [^ 'not in any change set']. 38707 ^ 'recent cs: ', hits last name! ! 38708 38709!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:11'! 38710named: aName 38711 "Return the change set of the given name, or nil if none found. 1/22/96 sw" 38712 38713 ^ AllChangeSets 38714 detect: [:aChangeSet | aChangeSet name = aName] 38715 ifNone: [nil]! ! 38716 38717!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:13'! 38718promoteToTop: aChangeSet 38719 "Make aChangeSet the first in the list from now on" 38720 38721 AllChangeSets remove: aChangeSet ifAbsent: [^ self]. 38722 AllChangeSets add: aChangeSet! ! 38723 38724!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:26'! 38725removeChangeSetsNamedSuchThat: nameBlock 38726 (self changeSetsNamedSuchThat: nameBlock) 38727 do: [:cs | self removeChangeSet: cs]! ! 38728 38729!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:13'! 38730removeChangeSet: aChangeSet 38731 "Remove the given changeSet. Caller must assure that it's cool to do this" 38732 38733 AllChangeSets remove: aChangeSet ifAbsent: []. 38734 aChangeSet wither 38735! ! 38736 38737!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:26'! 38738removeEmptyUnnamedChangeSets 38739 "Remove all change sets that are empty, whose names start with Unnamed, 38740 and which are not nailed down by belonging to a Project." 38741 "ChangeSorter removeEmptyUnnamedChangeSets" 38742 | toGo | 38743 (toGo := (self changeSetsNamedSuchThat: [:csName | csName beginsWith: 'Unnamed']) 38744 select: [:cs | cs isEmpty and: [cs okayToRemoveInforming: false]]) 38745 do: [:cs | self removeChangeSet: cs]. 38746 self inform: toGo size printString, ' change set(s) removed.'! ! 38747 38748!ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:13'! 38749secondaryChangeSet 38750 "Answer a likely change set to use as the second initial one in a Dual Change Sorter. " 38751 38752 AllChangeSets size = 1 ifTrue: [^ AllChangeSets first]. 38753 AllChangeSets last == ChangeSet current 38754 ifTrue: [^ AllChangeSets at: (AllChangeSets size - 1)] 38755 ifFalse: [^ AllChangeSets last]! ! 38756 38757 38758!ChangeSet class methodsFor: 'file list services' stamp: 'ar 7/15/2005 21:36'! 38759fileReaderServicesForFile: fullName suffix: suffix 38760 38761 ^ (FileStream isSourceFileSuffix: suffix) 38762 ifTrue: [ self services] 38763 ifFalse: [#()]! ! 38764 38765!ChangeSet class methodsFor: 'file list services' stamp: 'ar 7/15/2005 21:35'! 38766serviceFileIntoNewChangeSet 38767 "Answer a service for installing a file into a new change set" 38768 38769 ^ SimpleServiceEntry 38770 provider: self 38771 label: 'install into new change set' 38772 selector: #fileIntoNewChangeSet: 38773 description: 'install the file as a body of code in the image: create a new change set and file-in the selected file into it' 38774 buttonLabel: 'install'! ! 38775 38776!ChangeSet class methodsFor: 'file list services' stamp: 'ar 7/15/2005 21:36'! 38777services 38778 ^ Array with: self serviceFileIntoNewChangeSet! ! 38779 38780 38781!ChangeSet class methodsFor: 'filein/out' stamp: 'SqR 11/14/2000 11:36'! 38782doWeFileOut: aClass given: aSet cache: cache 38783 | aClassAllSuperclasses aClassSoleInstanceAllSuperclasses | 38784 38785 aClassAllSuperclasses := cache at: aClass 38786 ifAbsent: [cache at: aClass put: aClass allSuperclasses asArray]. 38787 (aSet includesAnyOf: aClassAllSuperclasses) ifTrue: [^false]. 38788 aClass isMeta ifFalse: [^true]. 38789 (aSet includes: aClass soleInstance) ifTrue: [^false]. 38790 aClassSoleInstanceAllSuperclasses := cache at: aClass soleInstance 38791 ifAbsent: [cache at: aClass soleInstance put: aClass soleInstance allSuperclasses asArray]. 38792 (aSet includesAnyOf: aClassSoleInstanceAllSuperclasses) ifTrue: [^false]. 38793 ^true! ! 38794 38795!ChangeSet class methodsFor: 'filein/out' stamp: 'marcus.denker 9/14/2008 21:10'! 38796superclassOrder: classes 38797 "Arrange the classes in the collection, classes, in superclass order so the 38798 classes can be properly filed in. Do it in sets instead of ordered collections. 38799 SqR 4/12/2000 22:04" 38800 38801 | all list aClass inclusionSet aClassIndex cache | 38802 38803 list := classes copy. "list is indexable" 38804 inclusionSet := list asSet. cache := Dictionary new. 38805 all := OrderedCollection new: list size. 38806 list size timesRepeat: 38807 [ 38808 aClassIndex := list findFirst: [:one | one notNil and: 38809 [self doWeFileOut: one given: inclusionSet cache: cache]]. 38810 aClass := list at: aClassIndex. 38811 all addLast: aClass. 38812 inclusionSet remove: aClass. 38813 list at: aClassIndex put: nil 38814 ]. 38815 ^all! ! 38816 38817!ChangeSet class methodsFor: 'filein/out' stamp: 'al 7/18/2004 18:45'! 38818traitsOrder: aCollection 38819 "Answer an OrderedCollection. The traits 38820 are ordered so they can be filed in." 38821 38822 | traits | 38823 traits := aCollection asSortedCollection: [:t1 :t2 | 38824 (t1 isBaseTrait and: [t1 classTrait == t2]) or: [ 38825 (t2 traitComposition allTraits includes: t1) or: [ 38826 (t1 traitComposition allTraits includes: t2) not]]]. 38827 ^traits asArray! ! 38828 38829 38830!ChangeSet class methodsFor: 'initialization' stamp: 'ar 7/15/2005 21:12'! 38831initialize 38832 "ChangeSet initialize" 38833 AllChangeSets == nil ifTrue: 38834 [AllChangeSets := OrderedCollection new]. 38835 self gatherChangeSets. 38836 FileServices registerFileReader: self. 38837! ! 38838 38839 38840!ChangeSet class methodsFor: 'instance creation' stamp: 'di 4/6/2001 09:43'! 38841basicNewNamed: aName 38842 38843 ^ (self basicNew name: aName) initialize! ! 38844 38845!ChangeSet class methodsFor: 'instance creation' stamp: 'ar 7/16/2005 15:17'! 38846new 38847 "All current changeSets must be registered in the AllChangeSets collection. 38848 Due to a quirk of history, this is maintained as class variable of ChangeSorter." 38849 38850 ^ self basicNewChangeSet: ChangeSet defaultName! ! 38851 38852 38853!ChangeSet class methodsFor: 'scanning' stamp: 'ar 7/16/2005 19:22'! 38854getRecentLocatorWithPrompt: aPrompt 38855 "Prompt with a menu of how far back to go. Return nil if user backs out. Otherwise return the number of characters back from the end of the .changes file the user wishes to include" 38856 "ChangeList getRecentPosition" 38857 | end changesFile banners positions pos chunk i | 38858 changesFile := (SourceFiles at: 2) readOnlyCopy. 38859 banners := OrderedCollection new. 38860 positions := OrderedCollection new. 38861 end := changesFile size. 38862 pos := SmalltalkImage current lastQuitLogPosition. 38863 [pos = 0 or: [banners size > 20]] whileFalse: 38864 [changesFile position: pos. 38865 chunk := changesFile nextChunk. 38866 i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. 38867 i > 0 ifTrue: [positions addLast: pos. 38868 banners addLast: (chunk copyFrom: 5 to: i-2). 38869 pos := Number readFrom: (chunk copyFrom: i+13 to: chunk size)] 38870 ifFalse: [pos := 0]]. 38871 changesFile close. 38872 pos := UIManager default chooseFrom: banners values: positions title: aPrompt. 38873 pos == nil ifTrue: [^ nil]. 38874 ^ end - pos! ! 38875 38876!ChangeSet class methodsFor: 'scanning' stamp: 'ar 7/16/2005 15:12'! 38877scanCategory: file 38878 "Scan anything that involves more than one chunk; method name is historical only" 38879 | itemPosition item tokens stamp isComment anIndex | 38880 itemPosition := file position. 38881 item := file nextChunk. 38882 38883 isComment := (item includesSubString: 'commentStamp:'). 38884 (isComment or: [item includesSubString: 'methodsFor:']) ifFalse: 38885 ["Maybe a preamble, but not one we recognize; bail out with the preamble trick" 38886 ^{(ChangeRecord new file: file position: itemPosition type: #preamble)}]. 38887 38888 tokens := Scanner new scanTokens: item. 38889 tokens size >= 3 ifTrue: 38890 [stamp := ''. 38891 anIndex := tokens indexOf: #stamp: ifAbsent: [nil]. 38892 anIndex ifNotNil: [stamp := tokens at: (anIndex + 1)]. 38893 38894 tokens second == #methodsFor: 38895 ifTrue: [^ self scanFile: file category: tokens third class: tokens first 38896 meta: false stamp: stamp]. 38897 tokens third == #methodsFor: 38898 ifTrue: [^ self scanFile: file category: tokens fourth class: tokens first 38899 meta: true stamp: stamp]]. 38900 38901 tokens second == #commentStamp: 38902 ifTrue: 38903 [stamp := tokens third. 38904 item := (ChangeRecord new file: file position: file position type: #classComment 38905 class: tokens first category: nil meta: false stamp: stamp). 38906 file nextChunk. 38907 file skipStyleChunk. 38908 ^Array with: item]. 38909 ^#()! ! 38910 38911!ChangeSet class methodsFor: 'scanning' stamp: 'ar 7/16/2005 15:11'! 38912scanFile: file category: cat class: class meta: meta stamp: stamp 38913 | itemPosition method items | 38914 items := OrderedCollection new. 38915 [itemPosition := file position. 38916 method := file nextChunk. 38917 file skipStyleChunk. 38918 method size > 0] whileTrue:[ 38919 items add: (ChangeRecord new file: file position: itemPosition type: #method 38920 class: class category: cat meta: meta stamp: stamp)]. 38921 ^items! ! 38922 38923!ChangeSet class methodsFor: 'scanning' stamp: 'ar 7/16/2005 15:14'! 38924scanFile: file from: startPosition to: stopPosition 38925 | itemPosition item prevChar changeList | 38926 changeList := OrderedCollection new. 38927 file position: startPosition. 38928'Scanning ', file localName, '...' 38929 displayProgressAt: Sensor cursorPoint 38930 from: startPosition to: stopPosition 38931 during: [:bar | 38932 [file position < stopPosition] whileTrue:[ 38933 bar value: file position. 38934 [file atEnd not and: [file peek isSeparator]] 38935 whileTrue: [prevChar := file next]. 38936 (file peekFor: $!!) ifTrue:[ 38937 (prevChar = Character cr or: [prevChar = Character lf]) 38938 ifTrue: [changeList addAll: (self scanCategory: file)]. 38939 ] ifFalse:[ 38940 itemPosition := file position. 38941 item := file nextChunk. 38942 file skipStyleChunk. 38943 item size > 0 ifTrue:[ 38944 changeList add: (ChangeRecord new file: file position: itemPosition type: #doIt). 38945 ]. 38946 ]. 38947 ]]. 38948 ^changeList! ! 38949 38950!ChangeSet class methodsFor: 'scanning' stamp: 'ar 7/16/2005 20:19'! 38951scanVersionsOf: method class: class meta: meta category: cat selector: selector 38952 | position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp changeList file | 38953 changeList := OrderedCollection new. 38954 position := method filePosition. 38955 sourceFilesCopy := SourceFiles collect:[:x | x ifNotNil:[x readOnlyCopy]]. 38956 method fileIndex == 0 ifTrue: [^ nil]. 38957 file := sourceFilesCopy at: method fileIndex. 38958 [position notNil & file notNil] whileTrue:[ 38959 file position: (0 max: position-150). "Skip back to before the preamble" 38960 preamble := method getPreambleFrom: file at: (0 max: position - 3). 38961 "Preamble is likely a linked method preamble, if we're in 38962 a changes file (not the sources file). Try to parse it 38963 for prior source position and file index" 38964 prevPos := nil. 38965 stamp := ''. 38966 (preamble findString: 'methodsFor:' startingAt: 1) > 0 38967 ifTrue: [tokens := Scanner new scanTokens: preamble] 38968 ifFalse: [tokens := Array new "ie cant be back ref"]. 38969 ((tokens size between: 7 and: 8) 38970 and: [(tokens at: tokens size-5) = #methodsFor:]) ifTrue:[ 38971 (tokens at: tokens size-3) = #stamp: ifTrue:[ 38972 "New format gives change stamp and unified prior pointer" 38973 stamp := tokens at: tokens size-2. 38974 prevPos := tokens last. 38975 prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos. 38976 prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos. 38977 ] ifFalse: ["Old format gives no stamp; prior pointer in two parts" 38978 prevPos := tokens at: tokens size-2. 38979 prevFileIndex := tokens last. 38980 ]. 38981 (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos := nil] 38982 ]. 38983 ((tokens size between: 5 and: 6) 38984 and: [(tokens at: tokens size-3) = #methodsFor:]) ifTrue:[ 38985 (tokens at: tokens size-1) = #stamp: ifTrue: [ 38986 "New format gives change stamp and unified prior pointer" 38987 stamp := tokens at: tokens size. 38988 ] 38989 ]. 38990 changeList add: (ChangeRecord new file: file position: position type: #method 38991 class: class name category: cat meta: meta stamp: stamp). 38992 position := prevPos. 38993 prevPos notNil ifTrue:[file := sourceFilesCopy at: prevFileIndex]. 38994 ]. 38995 sourceFilesCopy do: [:x | x ifNotNil:[x close]]. 38996 ^changeList! ! 38997 38998 38999!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:30'! 39000assuredChangeSetNamed: aName 39001 "Answer a change set of the given name. If one already exists, answer that, else create a new one and answer it." 39002 39003 | existing | 39004 ^ (existing := self named: aName) 39005 ifNotNil: 39006 [existing] 39007 ifNil: 39008 [self basicNewChangeSet: aName]! ! 39009 39010!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:28'! 39011buildAggregateChangeSet 39012 "Establish a change-set named Aggregate which bears the union of all the changes in all the existing change-sets in the system (other than any pre-existing Aggregate). This can be useful when wishing to discover potential conflicts between a disk-resident change-set and an image. Formerly very useful, now some of its unique contributions have been overtaken by new features" 39013 39014 | aggregateChangeSet | 39015 aggregateChangeSet := self existingOrNewChangeSetNamed: 'Aggregate'. 39016 aggregateChangeSet clear. 39017 self allChangeSets do: 39018 [:aChangeSet | aChangeSet == aggregateChangeSet ifFalse: 39019 [aggregateChangeSet assimilateAllChangesFoundIn: aChangeSet]] 39020 39021"ChangeSet buildAggregateChangeSet" 39022 39023 ! ! 39024 39025!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:37'! 39026countOfChangeSetsWithClass: aClass andSelector: aSelector 39027 "Answer how many change sets record a change for the given class and selector" 39028 39029 ^ (self allChangeSetsWithClass: aClass selector: aSelector) size! ! 39030 39031!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:38'! 39032doesAnyChangeSetHaveClass: aClass andSelector: aSelector 39033 "Answer whether any known change set bears a change for the given class and selector" 39034 39035 ^ (self countOfChangeSetsWithClass: aClass andSelector: aSelector) > 0! ! 39036 39037!ChangeSet class methodsFor: 'services' stamp: 'jf 11/1/2008 13:29'! 39038fileIntoNewChangeSet: fullName 39039 "File in all of the contents of the currently selected file, if any, into a new change set." 39040 39041 | fn ff | 39042 fullName ifNil: [^ Beeper beep]. 39043 [ff := FileStream readOnlyFileNamed: (fn := GZipReadStream uncompressedFileName: fullName). 39044 ChangeSet newChangesFromStream: ff named: (FileDirectory localNameFor: fn)] 39045 ensure: [ff ifNotNil: [ff close]]! ! 39046 39047!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:37'! 39048fileOutChangeSetsNamed: nameList 39049 "File out the list of change sets whose names are provided" 39050 "ChangeSorter fileOutChangeSetsNamed: #('New Changes' 'miscTidies-sw')" 39051 39052 | notFound aChangeSet infoString empty | 39053 notFound := OrderedCollection new. 39054 empty := OrderedCollection new. 39055 nameList do: 39056 [:aName | (aChangeSet := self named: aName) 39057 ifNotNil: 39058 [aChangeSet isEmpty 39059 ifTrue: 39060 [empty add: aName] 39061 ifFalse: 39062 [aChangeSet fileOut]] 39063 ifNil: 39064 [notFound add: aName]]. 39065 39066 infoString := (nameList size - notFound size) printString, ' change set(s) filed out'. 39067 notFound size > 0 ifTrue: 39068 [infoString := infoString, ' 39069 39070', notFound size printString, ' change set(s) not found:'. 39071 notFound do: 39072 [:aName | infoString := infoString, ' 39073', aName]]. 39074 empty size > 0 ifTrue: 39075 [infoString := infoString, ' 39076', empty size printString, ' change set(s) were empty:'. 39077 empty do: 39078 [:aName | infoString := infoString, ' 39079', aName]]. 39080 39081 self inform: infoString! ! 39082 39083!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:31'! 39084newChangeSet 39085 "Prompt the user for a name, and establish a new change set of 39086 that name (if ok), making it the current changeset. Return nil 39087 of not ok, else return the actual changeset." 39088 39089 | newName newSet | 39090 newName := UIManager default 39091 request: 'Please name the new change set:' 39092 initialAnswer: ChangeSet defaultName. 39093 newName isEmptyOrNil ifTrue: 39094 [^ nil]. 39095 newSet := self basicNewChangeSet: newName. 39096 newSet ifNotNil: 39097 [self newChanges: newSet]. 39098 ^ newSet! ! 39099 39100!ChangeSet class methodsFor: 'services' stamp: 'MiguelCoba 7/25/2009 02:00'! 39101newChangeSet: aName 39102 "Makes a new change set called aName, add author full name to try to 39103 ensure a unique change set name." 39104 39105 | newName | 39106 newName := aName , FileDirectory dot , Author fullName. 39107 ^ self basicNewChangeSet: newName! ! 39108 39109!ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:33'! 39110newChangesFromStream: aStream named: aName 39111 "File in the code from the stream into a new change set whose 39112 name is derived from aName. Leave the 'current change set' 39113 unchanged. Return the new change set or nil on failure." 39114 39115 | oldChanges newName newSet newStream | 39116 oldChanges := ChangeSet current. 39117 PreviousSet := oldChanges name. "so a Bumper update can find it" 39118 newName := aName sansPeriodSuffix. 39119 newSet := self basicNewChangeSet: newName. 39120 [newSet ifNotNil:[ 39121 (aStream respondsTo: #converter:) ifFalse: [ 39122 newStream := MultiByteBinaryOrTextStream with: (aStream contentsOfEntireFile). 39123 newStream reset. 39124 ] ifTrue: [ 39125 newStream := aStream. 39126 ]. 39127 39128 self newChanges: newSet. 39129 newStream setConverterForCode. 39130 newStream fileInAnnouncing: 'Loading ', newName, '...'. 39131 Transcript cr; show: 'File ', aName, ' successfully filed in to change set ', newName]. 39132 aStream close] ensure: [self newChanges: oldChanges]. 39133 PreviousSet := nil. 39134 ^ newSet! ! 39135ChangeSorter subclass: #ChangeSetBrowser 39136 instanceVariableNames: '' 39137 classVariableNames: '' 39138 poolDictionaries: '' 39139 category: 'Tools-Changes'! 39140!ChangeSetBrowser commentStamp: '<historical>' prior: 0! 39141A tool allowing you to browse the methods of a single change set.! 39142 39143 39144!ChangeSetBrowser methodsFor: 'initialization' stamp: 'alain.plantec 5/30/2008 10:45'! 39145addModelItemsToWindowMenu: aMenu 39146 "Add model-related items to the given window menu" 39147 39148 | oldTarget | 39149 oldTarget := aMenu defaultTarget. 39150 aMenu defaultTarget: self. 39151 aMenu addLine. 39152 aMenu add: 'rename change set' action: #rename. 39153 aMenu add: 'make changes go to me' action: #newCurrent. 39154 aMenu addLine. 39155 aMenu add: 'file out' action: #fileOut. 39156 aMenu add: 'browse methods' action: #browseChangeSet. 39157 aMenu addLine. 39158 myChangeSet hasPreamble 39159 ifTrue: 39160 [aMenu add: 'edit preamble' action: #addPreamble. 39161 aMenu add: 'remove preamble' action: #removePreamble] 39162 ifFalse: 39163 [aMenu add: 'add preamble' action: #addPreamble]. 39164 39165 myChangeSet hasPostscript 39166 ifTrue: 39167 [aMenu add: 'edit postscript...' action: #editPostscript. 39168 aMenu add: 'remove postscript' action: #removePostscript] 39169 ifFalse: 39170 [aMenu add: 'add postscript...' action: #editPostscript]. 39171 aMenu addLine. 39172 39173 aMenu add: 'destroy change set' action: #remove. 39174 aMenu addLine. 39175 aMenu addLine. 39176 aMenu add: 'what to show...' target: self action: #offerWhatToShowMenu. 39177 aMenu addLine. 39178 aMenu add: 'more...' action: #offerShiftedChangeSetMenu. 39179 aMenu defaultTarget: oldTarget. 39180 39181 ^ aMenu! ! 39182 39183!ChangeSetBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! 39184openAsMorphIn: window rect: rect 39185 "Add a set of changeSetBrowser views to the given top view offset by the given amount" 39186 39187 | aHeight | 39188 contents := ''. 39189 aHeight := 0.25. 39190 self addDependent: window. "so it will get changed: #relabel" 39191 39192 39193 window addMorph: (PluggableListMorphByItem on: self 39194 list: #classList 39195 selected: #currentClassName 39196 changeSelected: #currentClassName: 39197 menu: #classListMenu:shifted: 39198 keystroke: #classListKey:from:) 39199 frame: (((0.0@0 extent: 0.5 @ aHeight) 39200 scaleBy: rect extent) translateBy: rect origin). 39201 39202 window addMorph: (PluggableListMorphByItem on: self 39203 list: #messageList 39204 selected: #currentSelector 39205 changeSelected: #currentSelector: 39206 menu: #messageMenu:shifted: 39207 keystroke: #messageListKey:from:) 39208 frame: (((0.5@0 extent: 0.5 @ aHeight) 39209 scaleBy: rect extent) translateBy: rect origin). 39210 39211 self addLowerPanesTo: window 39212 at: (((0@aHeight corner: 1@1) scaleBy: rect extent) translateBy: rect origin) 39213 with: nil! ! 39214 39215!ChangeSetBrowser methodsFor: 'initialization' stamp: 'sw 3/14/2001 10:03'! 39216wantsAnnotationPane 39217 "This kind of browser always wants annotation panes, so answer true" 39218 39219 ^ true! ! 39220 39221!ChangeSetBrowser methodsFor: 'initialization' stamp: 'sw 3/9/2001 15:02'! 39222wantsOptionalButtons 39223 "Sure, why not?" 39224 39225 ^ true! ! 39226 39227 39228!ChangeSetBrowser methodsFor: 'menu' stamp: 'sw 3/12/2001 14:07'! 39229offerUnshiftedChangeSetMenu 39230 "The user chose 'more' from the shifted window menu; go back to the regular window menu" 39231 39232 self containingWindow ifNotNil: [self containingWindow offerWindowMenu] ! ! 39233 39234!ChangeSetBrowser methodsFor: 'menu' stamp: 'MiguelCoba 7/25/2009 02:06'! 39235shiftedChangeSetMenu: aMenu 39236 "Set up aMenu to hold items relating to the change-set-list pane when the shift key is down" 39237 39238 aMenu title: 'Change set (shifted)'. 39239 aMenu addStayUpItemSpecial. 39240 aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts. 39241 aMenu balloonTextForLastItem: 39242'Browse all methods that occur both in this change set and in at least one other change set.'. 39243 39244 aMenu addLine. 39245 aMenu add: 'check for slips' action: #lookForSlips. 39246 aMenu balloonTextForLastItem: 39247'Check this change set for halts and references to Transcript.'. 39248 39249 aMenu add: 'check for unsent messages' action: #checkForUnsentMessages. 39250 aMenu balloonTextForLastItem: 39251'Check this change set for messages that are not sent anywhere in the system'. 39252 39253 aMenu add: 'check for uncommented methods' action: #checkForUncommentedMethods. 39254 aMenu balloonTextForLastItem: 39255'Check this change set for methods that do not have comments'. 39256 39257 aMenu add: 'check for uncommented classes' action: #checkForUncommentedClasses. 39258 aMenu balloonTextForLastItem: 39259'Check for classes with code in this changeset which lack class comments'. 39260 39261 39262 Author fullNamePerSe isEmptyOrNil ifFalse: 39263 [aMenu add: 'check for other authors' action: #checkForAlienAuthorship. 39264 aMenu balloonTextForLastItem: 39265'Check this change set for methods whose current authoring stamp does not start with "', Author fullName, '"'. 39266 39267 aMenu add: 'check for any other authors' action: #checkForAnyAlienAuthorship. 39268 aMenu balloonTextForLastItem: 39269'Check this change set for methods any of whose previous authoring stamps do not start with "', Author fullName, '"']. 39270 39271 aMenu add: 'check for uncategorized methods' action: #checkForUnclassifiedMethods. 39272 aMenu balloonTextForLastItem: 39273'Check to see if any methods in the selected change set have not yet been assigned to a category. If any are found, open a browser on them.'. 39274 aMenu addLine. 39275 39276 aMenu add: 'inspect change set' action: #inspectChangeSet. 39277 aMenu balloonTextForLastItem: 39278'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'. 39279 39280 aMenu add: 'update' action: #update. 39281 aMenu balloonTextForLastItem: 39282'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)'. 39283 39284 aMenu add: 'trim history' action: #trimHistory. 39285 aMenu balloonTextForLastItem: 39286' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. NOTE: can cause confusion if later filed in over an earlier version of these changes'. 39287 39288 aMenu add: 'clear this change set' action: #clearChangeSet. 39289 aMenu balloonTextForLastItem: 39290'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'. 39291 39292 aMenu add: 'uninstall this change set' action: #uninstallChangeSet. 39293 aMenu balloonTextForLastItem: 39294'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!'. 39295 39296 aMenu addLine. 39297 39298 aMenu add: 'more...' action: #offerUnshiftedChangeSetMenu. 39299 aMenu balloonTextForLastItem: 39300'Takes you back to the primary change-set menu.'. 39301 39302 ^ aMenu! ! 39303ElementCategory subclass: #ChangeSetCategory 39304 instanceVariableNames: 'membershipSelector' 39305 classVariableNames: '' 39306 poolDictionaries: '' 39307 category: 'Tools-Changes'! 39308!ChangeSetCategory commentStamp: '<historical>' prior: 0! 39309A ChangeSetCategory represents a list of change sets to be shown in a ChangeSorter. It computes whether a given change set is in the list by sending its membershipSelector to ChangeSorter (i.e. the class object) with the change set as message argument.! 39310 39311 39312!ChangeSetCategory methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! 39313membershipSelector: aSelector 39314 "Set the membershipSelector" 39315 39316 membershipSelector := aSelector! ! 39317 39318 39319!ChangeSetCategory methodsFor: 'miscellaneous' stamp: 'sd 5/23/2003 14:25'! 39320defaultChangeSetToShow 39321 "Answer the name of a change-set to show" 39322 39323 ^ ChangeSet current! ! 39324 39325!ChangeSetCategory methodsFor: 'miscellaneous' stamp: 'sd 11/20/2005 21:26'! 39326reconstituteList 39327 "Clear out the receiver's elements and rebuild them" 39328 39329 | newMembers | 39330 "First determine newMembers and check if they have not changed..." 39331 newMembers := ChangeSorter allChangeSets select: 39332 [:aChangeSet | ChangeSorter perform: membershipSelector with: aChangeSet]. 39333 (newMembers collect: [:cs | cs name]) = keysInOrder ifTrue: [^ self "all current"]. 39334 39335 "Things have changed. Need to recompute the whole category" 39336 self clear. 39337 newMembers do: 39338 [:aChangeSet | self fasterElementAt: aChangeSet name asSymbol put: aChangeSet] 39339! ! 39340 39341 39342!ChangeSetCategory methodsFor: 'queries' stamp: 'sw 4/11/2001 16:11'! 39343acceptsManualAdditions 39344 "Answer whether the user is allowed manually to manipulate the contents of the change-set-category." 39345 39346 ^ false! ! 39347 39348!ChangeSetCategory methodsFor: 'queries' stamp: 'sd 11/20/2005 21:26'! 39349changeSetList 39350 "Answer the list of change-set names in the category" 39351 39352 | aChangeSet | 39353 self reconstituteList. 39354 keysInOrder size == 0 ifTrue: 39355 ["don't tolerate emptiness, because ChangeSorters gag when they have no change-set selected" 39356 aChangeSet := ChangeSorter assuredChangeSetNamed: 'New Changes'. 39357 self elementAt: aChangeSet name put: aChangeSet]. 39358 ^ keysInOrder reversed! ! 39359 39360!ChangeSetCategory methodsFor: 'queries' stamp: 'sw 4/5/2001 17:26'! 39361hasChangeForClassName: aClassName selector: aSelector otherThanIn: excludedChangeSet 39362 "Answer whether any change set in this category, other than the excluded one, has a change marked for the given class and selector" 39363 39364 self elementsInOrder do: 39365 [:aChangeSet | 39366 (aChangeSet ~~ excludedChangeSet and: 39367 [((aChangeSet methodChangesAtClass: aClassName) includesKey: aSelector)]) ifTrue: [^ true]]. 39368 39369 ^ false! ! 39370 39371!ChangeSetCategory methodsFor: 'queries' stamp: 'sw 3/30/2001 14:04'! 39372includesChangeSet: aChangeSet 39373 "Answer whether the receiver includes aChangeSet in its retrieval list" 39374 39375 ^ ChangeSorter perform: membershipSelector with: aChangeSet! ! 39376 39377 39378!ChangeSetCategory methodsFor: 'services' stamp: 'sd 11/20/2005 21:26'! 39379fileOutAllChangeSets 39380 "File out all the nonempty change sets in the current category, suppressing the checks for slips that might otherwise ensue. Obtain user confirmation before undertaking this possibly prodigious task." 39381 39382 | aList | 39383 aList := self elementsInOrder select: 39384 [:aChangeSet | aChangeSet isEmpty not]. 39385 aList size == 0 ifTrue: [^ self inform: 'sorry, all the change sets in this category are empty']. 39386 (self confirm: 'This will result in filing out ', aList size printString, ' change set(s) 39387Are you certain you want to do this?') ifFalse: [^ self]. 39388 39389 Preferences setFlag: #checkForSlips toValue: false during: 39390 [ChangeSorter fileOutChangeSetsNamed: (aList collect: [:m | m name]) asSortedArray]! ! 39391 39392!ChangeSetCategory methodsFor: 'services' stamp: 'alain.plantec 5/30/2008 10:48'! 39393fillAggregateChangeSet 39394 "Create a change-set named Aggregate and pour into it all the changes in all the change-sets of the currently-selected category" 39395 39396 | aggChangeSet | 39397 aggChangeSet := ChangeSorter assuredChangeSetNamed: #Aggregate. 39398 aggChangeSet clear. 39399 aggChangeSet setPreambleToSay: '"Change Set: Aggregate 39400Created at ', Time now printString, ' on ', Date today printString, ' by combining all the changes in all the change sets in the category ', categoryName printString, '"'. 39401 39402 (self elementsInOrder copyWithout: aggChangeSet) do: 39403 [:aChangeSet | aggChangeSet assimilateAllChangesFoundIn: aChangeSet]. 39404 SystemWindow wakeUpTopWindowUponStartup 39405! ! 39406ChangeSetCategory subclass: #ChangeSetCategoryWithParameters 39407 instanceVariableNames: 'parameters' 39408 classVariableNames: '' 39409 poolDictionaries: '' 39410 category: 'Tools-Changes'! 39411 39412!ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:34'! 39413acceptsManualAdditions 39414 "Answer whether the user is allowed manually to manipulate the contents of the change-set-category." 39415 39416 ^ true! ! 39417 39418!ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:43'! 39419addChangeSet: aChangeSet 39420 self inform: 'sorry, you can''t do that'! ! 39421 39422!ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:08'! 39423includesChangeSet: aChangeSet 39424 "Answer whether the receiver includes aChangeSet in its retrieval list" 39425 39426 ^ ChangeSorter perform: membershipSelector withArguments: { aChangeSet } , parameters! ! 39427 39428!ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'! 39429parameters: anArray 39430 parameters := anArray! ! 39431 39432!ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'! 39433reconstituteList 39434 "Clear out the receiver's elements and rebuild them" 39435 39436 | newMembers | 39437 "First determine newMembers and check if they have not changed..." 39438 newMembers := ChangeSorter allChangeSets select: 39439 [:aChangeSet | ChangeSorter perform: membershipSelector withArguments: { aChangeSet }, parameters]. 39440 (newMembers collect: [:cs | cs name]) = keysInOrder ifTrue: [^ self "all current"]. 39441 39442 "Things have changed. Need to recompute the whole category" 39443 self clear. 39444 newMembers do: 39445 [:aChangeSet | self fasterElementAt: aChangeSet name asSymbol put: aChangeSet]! ! 39446TestCase subclass: #ChangeSetClassChangesTest 39447 instanceVariableNames: 'saveCurrentChangeSet addedChangeSetAccessor' 39448 classVariableNames: '' 39449 poolDictionaries: '' 39450 category: 'Tests-Bugs'! 39451!ChangeSetClassChangesTest commentStamp: 'dtl 2/19/2005 13:21' prior: 0! 39452Class category changes are not being properly added to the default changeset in Squeak 3.7. This test case will pass in Squeak 3.6, and fail in Squeak 3.[7-9]. 39453! 39454 39455 39456!ChangeSetClassChangesTest methodsFor: 'running' stamp: 'marcus.denker 11/10/2008 10:04'! 39457tearDown 39458 39459 (Smalltalk classNamed: #JunkClass) ifNotNil: [:c | c removeFromSystem: true]. 39460 SystemOrganization removeCategory: #'DeleteMe-1'. 39461 SystemOrganization removeCategory: #'DeleteMe-2'. 39462 ChangeSet current removeClassChanges: 'JunkClass' 39463 39464! ! 39465 39466 39467!ChangeSetClassChangesTest methodsFor: 'support' stamp: 'dtl 2/19/2005 13:08'! 39468isDefinition: firstString equivalentTo: secondString 39469 "When a class definition is reconstructed with #fatDefForClass, it may 39470 contain extra trailing space characters in parts of the definition. This 39471 is probably a minor bug, but it should be overlooked for purposes of 39472 testing the change set update mechanism. The expedient here is to just 39473 remove spaces before comparing the definition strings." 39474 39475 ^ firstString notNil 39476 and: [(firstString copyReplaceAll: ' ''' with: '''') 39477 = (secondString copyReplaceAll: ' ''' with: '''')]! ! 39478 39479 39480!ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'stephaneducasse 2/3/2006 22:39'! 39481testAddInstanceVariable 39482 "Adding an instance variable to the class should result in a change 39483 record being added to the current change set." 39484 39485 | saveClassDefinition | 39486 "Define a class and save its definition" 39487 Object subclass: #JunkClass 39488 instanceVariableNames: 'zzz' 39489 classVariableNames: '' 39490 poolDictionaries: '' 39491 category: 'DeleteMe-1'. 39492 saveClassDefinition := (Smalltalk classNamed: #JunkClass) definition. 39493 self assert: (self 39494 isDefinition: saveClassDefinition 39495 equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))). 39496 39497 "Redefine the class, adding one instance variable" 39498 Object subclass: #JunkClass 39499 instanceVariableNames: 'zzz aaa' 39500 classVariableNames: '' 39501 poolDictionaries: '' 39502 category: 'DeleteMe-1'. 39503 39504 "Assert that the class definition has changed" 39505 self deny: (self 39506 isDefinition: (Smalltalk classNamed: #JunkClass) definition 39507 equivalentTo: saveClassDefinition). 39508 self deny: (self 39509 isDefinition: saveClassDefinition 39510 equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))). 39511 self assert: (self 39512 isDefinition: (Smalltalk classNamed: #JunkClass) definition 39513 equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))). 39514 39515 "Assert that the change has been recorded in the current change set" 39516 self assert: (self 39517 isDefinition: (ChangeSet current changeRecorderFor: (Smalltalk classNamed: #JunkClass)) 39518 priorDefinition 39519 equivalentTo: saveClassDefinition). 39520! ! 39521 39522!ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'dtl 2/19/2005 11:55'! 39523testAddInstanceVariableAddsNewChangeRecord 39524 "Changing the class category for a class should result in a change 39525 record being updated in the current change set." 39526 39527 "At the start of this test, JunkClass should not exist, and there should be 39528 no change records pertaining to it in the change set." 39529 self deny: (Smalltalk hasClassNamed: 'JunkClass'). 39530 self assert: (ChangeSet current changeRecorderFor: (Smalltalk classNamed: #JunkClass)) 39531 thisName = 'nil'. 39532 "Remove bogus change records created as side effect of preceding assert" 39533 ChangeSet current removeClassChanges: 'nil'. 39534 "Define a class and save its definition" 39535 Object subclass: #JunkClass 39536 instanceVariableNames: 'zzz' 39537 classVariableNames: '' 39538 poolDictionaries: '' 39539 category: 'DeleteMe-1'. 39540 39541 "Forget about JunkClass in the change set" 39542 ChangeSet current removeClassChanges: 'JunkClass'. 39543 39544 "Redefine the class, adding one instance variable" 39545 Object subclass: #JunkClass 39546 instanceVariableNames: 'zzz aaa' 39547 classVariableNames: '' 39548 poolDictionaries: '' 39549 category: 'DeleteMe-1'. 39550 39551 "A change record should now exist in the change set" 39552 self assert: (self 39553 isDefinition: (ChangeSet current 39554 changeRecorderFor: (Smalltalk classNamed: #JunkClass)) priorDefinition 39555 equivalentTo: 39556'Object subclass: #JunkClass 39557 instanceVariableNames: ''zzz '' 39558 classVariableNames: '''' 39559 poolDictionaries: '''' 39560 category: ''DeleteMe-1''') 39561! ! 39562 39563!ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'stephaneducasse 2/3/2006 22:39'! 39564testChangeClassCategory 39565 "Changing the class category for a class should result in a change 39566 record being added to the current change set." 39567 39568 | saveClassDefinition | 39569 "Define a class and save its definition" 39570 Object subclass: #JunkClass 39571 instanceVariableNames: 'zzz' 39572 classVariableNames: '' 39573 poolDictionaries: '' 39574 category: 'DeleteMe-1'. 39575 saveClassDefinition := (Smalltalk classNamed: #JunkClass) definition. 39576 self assert: saveClassDefinition = 39577 (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass)). 39578 39579 "Redefine the class, changing only the class category" 39580 Object subclass: #JunkClass 39581 instanceVariableNames: 'zzz' 39582 classVariableNames: '' 39583 poolDictionaries: '' 39584 category: 'DeleteMe-2'. 39585 39586 "Assert that the class definition has changed" 39587 self deny: (self 39588 isDefinition: (Smalltalk classNamed: #JunkClass) definition 39589 equivalentTo: saveClassDefinition). 39590 self deny: (self 39591 isDefinition: saveClassDefinition 39592 equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))). 39593 self assert: (self 39594 isDefinition: (Smalltalk classNamed: #JunkClass) definition 39595 equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))). 39596 39597 "Assert that the change has been recorded in the current change set" 39598 self assert: (self 39599 isDefinition: (ChangeSet current changeRecorderFor: (Smalltalk classNamed: #JunkClass)) 39600 priorDefinition 39601 equivalentTo: 39602'Object subclass: #JunkClass 39603 instanceVariableNames: ''zzz '' 39604 classVariableNames: '''' 39605 poolDictionaries: '''' 39606 category: ''DeleteMe-2''')! ! 39607 39608!ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'dtl 2/19/2005 12:01'! 39609testChangeClassCategoryAddsNewChangeRecord 39610 "Changing the class category for a class should result in a change 39611 record being updated in the current change set." 39612 39613 "At the start of this test, JunkClass should not exist, and there should be 39614 no change records pertaining to it in the change set." 39615 self deny: (Smalltalk hasClassNamed: 'JunkClass'). 39616 self assert: (ChangeSet current changeRecorderFor: (Smalltalk classNamed: #JunkClass)) 39617 thisName = 'nil'. 39618 "Remove bogus change records created as side effect of preceding assert" 39619 ChangeSet current removeClassChanges: 'nil'. 39620 "Define a class and save its definition" 39621 Object subclass: #JunkClass 39622 instanceVariableNames: 'zzz' 39623 classVariableNames: '' 39624 poolDictionaries: '' 39625 category: 'DeleteMe-1'. 39626 39627 "Forget about JunkClass in the change set" 39628 ChangeSet current removeClassChanges: 'JunkClass'. 39629 39630 "Redefine the class, changing only the class category" 39631 Object subclass: #JunkClass 39632 instanceVariableNames: 'zzz' 39633 classVariableNames: '' 39634 poolDictionaries: '' 39635 category: 'DeleteMe-2'. 39636 39637 "A change record should now exist in the change set" 39638 self assert: (self 39639 isDefinition: (ChangeSet current 39640 changeRecorderFor: (Smalltalk classNamed: #JunkClass)) priorDefinition 39641 equivalentTo: 39642'Object subclass: #JunkClass 39643 instanceVariableNames: ''zzz '' 39644 classVariableNames: '''' 39645 poolDictionaries: '''' 39646 category: ''DeleteMe-2''')! ! 39647 39648!ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'wiz 8/13/2006 17:55'! 39649testInitialChangeSet 39650 "Run this to assure the initial changeset is named. Checks bug found in 3.9 7052." 39651 "self new testInitialChangeSet" 39652 "self run: #testInitialChangeSet" 39653 39654 self deny: (ChangeSet current printString = 'a ChangeSet named <no name -- garbage?>') . 39655 39656^true! ! 39657CodeHolder subclass: #ChangeSorter 39658 instanceVariableNames: 'parent myChangeSet currentClassName currentSelector priorChangeSetList changeSetCategory' 39659 classVariableNames: '' 39660 poolDictionaries: '' 39661 category: 'Tools-Changes'! 39662!ChangeSorter commentStamp: '<historical>' prior: 0! 39663I display a ChangeSet. Two of me are in a DualChangeSorter.! 39664 39665 39666!ChangeSorter methodsFor: 'access' stamp: 'tk 4/29/1998 08:22'! 39667changeSet 39668 ^ myChangeSet! ! 39669 39670!ChangeSorter methodsFor: 'access' stamp: 'sw 3/29/2001 14:45'! 39671changeSetCategory 39672 "Answer the current changeSetCategory object that governs which change sets are shown in this ChangeSorter" 39673 39674 ^ changeSetCategory ifNil: 39675 [self setDefaultChangeSetCategory]! ! 39676 39677!ChangeSorter methodsFor: 'access' stamp: 'sw 1/27/2000 11:19'! 39678changeSetCurrentlyDisplayed 39679 ^ myChangeSet! ! 39680 39681!ChangeSorter methodsFor: 'access' stamp: 'tk 4/30/1998 13:37'! 39682label 39683 ^ self labelString! ! 39684 39685!ChangeSorter methodsFor: 'access' stamp: 'sd 5/23/2003 14:25'! 39686labelString 39687 "The label for my entire window. The large button that displays my name is gotten via mainButtonName" 39688 39689 ^ String streamContents: 39690 [:aStream | 39691 aStream nextPutAll: (ChangeSet current == myChangeSet 39692 ifTrue: ['Changes go to "', myChangeSet name, '"'] 39693 ifFalse: ['ChangeSet: ', myChangeSet name]). 39694 (self changeSetCategory categoryName ~~ #All) 39695 ifTrue: 39696 [aStream nextPutAll: ' - ', self parenthesizedCategoryName]]! ! 39697 39698!ChangeSorter methodsFor: 'access' stamp: 'sma 11/11/2000 23:28'! 39699modelWakeUp 39700 "A window with me as model is being entered. 39701 Make sure I am up-to-date with the changeSets." 39702 39703 self canDiscardEdits ifTrue: [self update]! ! 39704 39705!ChangeSorter methodsFor: 'access' stamp: 'sd 11/20/2005 21:26'! 39706myChangeSet: anObject 39707 myChangeSet := anObject! ! 39708 39709!ChangeSorter methodsFor: 'access' stamp: 'tk 4/24/1998 08:42'! 39710parent 39711 ^ parent! ! 39712 39713!ChangeSorter methodsFor: 'access' stamp: 'sd 11/20/2005 21:26'! 39714parent: anObject 39715 parent := anObject! ! 39716 39717!ChangeSorter methodsFor: 'access' stamp: 'sw 3/29/2001 22:51'! 39718parenthesizedCategoryName 39719 "Answer my category name in parentheses" 39720 39721 ^ ' (', self changeSetCategory categoryName, ')'! ! 39722 39723!ChangeSorter methodsFor: 'access' stamp: 'sd 11/20/2005 21:26'! 39724showChangeSet: chgSet 39725 39726 myChangeSet == chgSet ifFalse: [ 39727 myChangeSet := chgSet. 39728 currentClassName := nil. 39729 currentSelector := nil]. 39730 self changed: #relabel. 39731 self changed: #currentCngSet. "new -- list of sets" 39732 self changed: #mainButtonName. "old, button" 39733 self changed: #classList. 39734 self changed: #messageList. 39735 self setContents. 39736 self contentsChanged.! ! 39737 39738!ChangeSorter methodsFor: 'access' stamp: 'pk 10/17/2006 09:37'! 39739showChangeSetNamed: aName 39740 39741 self showChangeSet: (ChangesOrganizer changeSetNamed: aName) ! ! 39742 39743 39744!ChangeSorter methodsFor: 'annotation' stamp: 'sw 2/22/2001 10:35'! 39745addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream 39746 "Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior version is pointed to by the lost-method pointer in the change held on to by the changeset" 39747 39748 (aClass includesSelector: aSelector) ifTrue: 39749 [^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. 39750 aStream nextPutAll: 39751 ((myChangeSet methodInfoFromRemoval: {aClass name. aSelector}) 39752 ifNil: 39753 ['no prior versions'] 39754 ifNotNil: 39755 ['version(s) retrievable here']), self annotationSeparator! ! 39756 39757 39758!ChangeSorter methodsFor: 'changeSet menu' stamp: 'pk 10/17/2006 09:36'! 39759browseMethodConflicts 39760 "Check to see if any other change set also holds changes to any methods in the selected change set; if so, open a browser on all such." 39761 39762 | aList | 39763 39764 aList := myChangeSet 39765 messageListForChangesWhich: [ :aClass :aSelector | 39766 (ChangesOrganizer allChangeSetsWithClass: aClass selector: aSelector) size > 1 39767 ] 39768 ifNone: [^ self inform: 'No other change set has changes 39769for any method in this change set.']. 39770 39771 MessageSet 39772 openMessageList: aList 39773 name: 'Methods in "', myChangeSet name, '" that are also in other change sets (', aList size printString, ')' 39774 ! ! 39775 39776!ChangeSorter methodsFor: 'changeSet menu' stamp: 'pk 10/17/2006 09:48'! 39777changeSetCategories 39778 39779 ^ ChangesOrganizer changeSetCategories! ! 39780 39781!ChangeSorter methodsFor: 'changeSet menu' stamp: 'pk 10/17/2006 09:48'! 39782chooseChangeSetCategoryInMorphic 39783 "Present the user with a list of change-set-categories and let her choose one. In this morphic variant, we include balloon help" 39784 39785 | aMenu | 39786 aMenu := MenuMorph new defaultTarget: self. 39787 aMenu title: 39788'Choose the category of 39789change sets to show in 39790this Change Sorter 39791(red = current choice)'. 39792 self changeSetCategories elementsInOrder do: 39793 [:aCategory | 39794 aMenu add: aCategory categoryName target: self selector: #showChangeSetCategory: argument: aCategory. 39795 aCategory == changeSetCategory ifTrue: 39796 [aMenu lastItem color: Color red]. 39797 aMenu balloonTextForLastItem: aCategory documentation]. 39798 aMenu popUpInWorld! ! 39799 39800!ChangeSorter methodsFor: 'changeSet menu' stamp: 'pk 10/17/2006 09:36'! 39801chooseCngSet 39802 "Present the user with an alphabetical list of change set names, and let her choose one" 39803 39804 | changeSetsSortedAlphabetically chosen | 39805 self okToChange ifFalse: [^ self]. 39806 39807 changeSetsSortedAlphabetically := self changeSetList asSortedCollection: 39808 [:a :b | a asLowercase withoutLeadingDigits < b asLowercase withoutLeadingDigits]. 39809 39810 chosen := (SelectionMenu selections: changeSetsSortedAlphabetically) 39811 startUp. 39812 chosen ifNil: [^ self]. 39813 self showChangeSet: (ChangesOrganizer changeSetNamed: chosen)! ! 39814 39815!ChangeSorter methodsFor: 'changeSet menu' stamp: 'pk 10/17/2006 09:49'! 39816makeNewCategory 39817 "Create a new, static change-set category, which will be populated entirely by change sets that have been manually placed in it" 39818 39819 | catName aCategory | 39820 catName := UIManager default request: 'Please give the new category a name' initialAnswer: ''. 39821 catName isEmptyOrNil ifTrue: [^ self]. 39822 catName := catName asSymbol. 39823 (self changeSetCategories includesKey: catName) ifTrue: 39824 [^ self inform: 'Sorry, there is already a category of that name']. 39825 39826 aCategory := StaticChangeSetCategory new categoryName: catName. 39827 self changeSetCategories elementAt: catName put: aCategory. 39828 aCategory addChangeSet: myChangeSet. 39829 self showChangeSetCategory: aCategory! ! 39830 39831!ChangeSorter methodsFor: 'changeSet menu' stamp: 'pk 10/17/2006 09:49'! 39832makeNewCategoryShowingClassChanges 39833 "Create a new, static change-set category, which will be populated entirely by change sets that have been manually placed in it" 39834 39835 | catName aCategory clsName | 39836 clsName := self selectedClass ifNotNil: [self selectedClass name ] ifNil: ['']. 39837 clsName := UIManager default request: 'Which class?' initialAnswer: clsName. 39838 clsName isEmptyOrNil ifTrue: [^ self]. 39839 catName := ('Changes to ', clsName) asSymbol. 39840 (self changeSetCategories includesKey: catName) ifTrue: 39841 [^ self inform: 'Sorry, there is already a category of that name']. 39842 39843 aCategory := ChangeSetCategoryWithParameters new categoryName: catName. 39844 aCategory membershipSelector: #changeSet:containsClass: ; parameters: { clsName }. 39845 self changeSetCategories elementAt: catName put: aCategory. 39846 aCategory reconstituteList. 39847 self showChangeSetCategory: aCategory! ! 39848 39849!ChangeSorter methodsFor: 'changeSet menu' stamp: 'pk 10/17/2006 09:49'! 39850removeCategory 39851 "Remove the current category" 39852 39853 | itsName | 39854 self changeSetCategory acceptsManualAdditions ifFalse: 39855 [^ self inform: 'sorry, you can only remove manually-added categories.']. 39856 39857 (self confirm: 'Really remove the change-set-category 39858named ', (itsName := changeSetCategory categoryName), '?') ifFalse: [^ self]. 39859 39860 self changeSetCategories removeElementAt: itsName. 39861 self setDefaultChangeSetCategory. 39862 39863 self update! ! 39864 39865!ChangeSorter methodsFor: 'changeSet menu' stamp: 'pk 10/17/2006 09:36'! 39866removePrompting: doPrompt 39867 "Completely destroy my change set. Check if it's OK first, and if doPrompt is true, get the user to confirm his intentions first." 39868 39869 | message aName changeSetNumber msg | 39870 aName := myChangeSet name. 39871 myChangeSet okayToRemove ifFalse: [^ self]. "forms current changes for some project" 39872 (myChangeSet isEmpty or: [doPrompt not]) ifFalse: 39873 [message := 'Are you certain that you want to 39874remove (destroy) the change set 39875named "', aName, '" ?'. 39876 (self confirm: message) ifFalse: [^ self]]. 39877 39878 doPrompt ifTrue: 39879 [msg := myChangeSet hasPreamble 39880 ifTrue: 39881 [myChangeSet hasPostscript 39882 ifTrue: 39883 ['a preamble and a postscript'] 39884 ifFalse: 39885 ['a preamble']] 39886 ifFalse: 39887 [myChangeSet hasPostscript 39888 ifTrue: 39889 ['a postscript'] 39890 ifFalse: 39891 ['']]. 39892 msg isEmpty ifFalse: 39893 [(self confirm: 39894'Caution!! This change set has 39895', msg, ' which will be 39896lost if you destroy the change set. 39897Do you really want to go ahead with this?') ifFalse: [^ self]]]. 39898 39899 "Go ahead and remove the change set" 39900 changeSetNumber := myChangeSet name initialIntegerOrNil. 39901 changeSetNumber ifNotNil: [SystemVersion current unregisterUpdate: changeSetNumber]. 39902 ChangesOrganizer removeChangeSet: myChangeSet. 39903 self showChangeSet: ChangeSet current.! ! 39904 39905!ChangeSorter methodsFor: 'changeSet menu' stamp: 'pk 10/17/2006 09:49'! 39906renameCategory 39907 "Obtain a new name for the category and, if acceptable, apply it" 39908 39909 | catName oldName | 39910 self changeSetCategory acceptsManualAdditions ifFalse: 39911 [^ self inform: 'sorry, you can only rename manually-added categories.']. 39912 39913 catName := UIManager default request: 'Please give the new category a name' initialAnswer: (oldName := changeSetCategory categoryName). 39914 catName isEmptyOrNil ifTrue: [^ self]. 39915 (catName := catName asSymbol) = oldName ifTrue: [^ self inform: 'no change.']. 39916 (self changeSetCategories includesKey: catName) ifTrue: 39917 [^ self inform: 'Sorry, there is already a category of that name']. 39918 39919 changeSetCategory categoryName: catName. 39920 self changeSetCategories removeElementAt: oldName. 39921 self changeSetCategories elementAt: catName put: changeSetCategory. 39922 39923 self update! ! 39924 39925!ChangeSorter methodsFor: 'changeSet menu' stamp: 'pk 10/17/2006 09:37'! 39926showChangeSetCategory: aChangeSetCategory 39927 "Show the given change-set category" 39928 39929 changeSetCategory := aChangeSetCategory. 39930 self changed: #changeSetList. 39931 (self changeSetList includes: myChangeSet name) ifFalse: 39932 [self showChangeSet: (ChangesOrganizer changeSetNamed: self changeSetList first)]. 39933 self changed: #relabel! ! 39934 39935 39936!ChangeSorter methodsFor: 'changeset menu' stamp: 'sd 11/20/2005 21:26'! 39937addPreamble 39938 myChangeSet assurePreambleExists. 39939 self okToChange ifTrue: 39940 [currentClassName := nil. 39941 currentSelector := nil. 39942 self showChangeSet: myChangeSet]! ! 39943 39944!ChangeSorter methodsFor: 'changeset menu' stamp: 'sd 11/20/2005 21:26'! 39945addToCategoryOpposite 39946 "Add the current change set to the category viewed on the opposite side, if it's of the sort to accept things like that" 39947 39948 | categoryOpposite | 39949 categoryOpposite := (parent other: self) changeSetCategory. 39950 categoryOpposite acceptsManualAdditions 39951 ifTrue: 39952 [categoryOpposite addChangeSet: myChangeSet. 39953 categoryOpposite reconstituteList. 39954 self update] 39955 ifFalse: 39956 [self inform: 39957'sorry, this command only makes sense 39958if the category showing on the opposite 39959side is a static category whose 39960members are manually maintained']! ! 39961 39962!ChangeSorter methodsFor: 'changeset menu' stamp: 'tk 4/24/1998 13:27'! 39963browseChangeSet 39964 "Open a message list browser on the new and changed methods in the current change set" 39965 39966 ChangedMessageSet openFor: myChangeSet 39967 39968! ! 39969 39970!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 8/12/2002 17:29'! 39971categorySubmenu: aMenu shifted: shiftedIgnored 39972 "Fill aMenu with less-frequently-needed category items" 39973 39974 aMenu title: 'Change set category'. 39975 aMenu addStayUpItem. 39976 39977 aMenu addList: #( 39978 ('make a new category...' makeNewCategory 'Creates a new change-set-category (you will be asked to supply a name) which will start out its life with this change set in it') 39979 ('make a new category with class...' makeNewCategoryShowingClassChanges 'Creates a new change-set-category that includes change sets that change a particular class (you will be asked to supply a name)') 39980 ('rename this category' renameCategory 'Rename this change-set category. Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.') 39981 ('remove this category' removeCategory 'Remove this change-set category. Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.') 39982 ('show categories of this changeset' showCategoriesOfChangeSet 'Show a list of all the change-set categories that contain this change-set; if the you choose one of the categories from this pop-up, that category will be installed in this change sorter') 39983 -). 39984 39985 parent ifNotNil: 39986 [aMenu addList: #( 39987 ('add change set to category opposite' addToCategoryOpposite 'Adds this change set to the category on the other side of the change sorter. Only applies if the category shown on the opposite side is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.'))]. 39988 39989 aMenu addList: #( 39990 ('remove change set from this category' removeFromCategory 'Removes this change set from the current category. Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.') 39991 - 39992 ('file out category''s change sets' fileOutAllChangeSets 'File out every change set in this category that has anything in it. The usual checks for slips are suppressed when this command is done.') 39993 ('set recent-updates marker' setRecentUpdatesMarker 'Allows you to specify a number that will demarcate which updates are considered "recent" and which are not. This will govern which updates are included in the RecentUpdates category in a change sorter') 39994 ('fill aggregate change set' fillAggregateChangeSet 'Creates a change-set named Aggregate into which all the changes in all the change sets in this category will be copied.') 39995 - 39996 ('back to main menu' offerUnshiftedChangeSetMenu 'Takes you back to the shifted change-set menu.') 39997 ('back to shifted menu' offerShiftedChangeSetMenu 'Takes you back to the primary change-set menu.')). 39998 39999 ^ aMenu! ! 40000 40001!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 3/30/2001 00:00'! 40002changeSetList 40003 "Answer a list of ChangeSet names to be shown in the change sorter." 40004 40005 ^ self changeSetCategory changeSetList! ! 40006 40007!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 7/17/2002 11:37'! 40008changeSetListKey: aChar from: view 40009 "Respond to a Command key. I am a model with a listView that has a list of changeSets." 40010 40011 aChar == $b ifTrue: [^ self browseChangeSet]. 40012 aChar == $B ifTrue: [^ self openChangeSetBrowser]. 40013 aChar == $c ifTrue: [^ self copyAllToOther]. 40014 aChar == $D ifTrue: [^ self toggleDiffing]. 40015 aChar == $f ifTrue: [^ self findCngSet]. 40016 aChar == $m ifTrue: [^ self newCurrent]. 40017 aChar == $n ifTrue: [^ self newSet]. 40018 aChar == $o ifTrue: [^ self fileOut]. 40019 aChar == $p ifTrue: [^ self addPreamble]. 40020 aChar == $r ifTrue: [^ self rename]. 40021 aChar == $s ifTrue: [^ self chooseChangeSetCategory]. 40022 aChar == $x ifTrue: [^ self remove]. 40023 aChar == $- ifTrue: [^ self subtractOtherSide]. 40024 40025 ^ self messageListKey: aChar from: view! ! 40026 40027!ChangeSorter methodsFor: 'changeset menu' stamp: 'alain.plantec 5/30/2008 10:56'! 40028changeSetMenu: aMenu shifted: isShifted 40029 "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" 40030 40031 isShifted ifTrue: [^ self shiftedChangeSetMenu: aMenu]. 40032 aMenu title: 'Change Set'. 40033 aMenu addStayUpItemSpecial. 40034 aMenu add: 'make changes go to me (m)' action: #newCurrent. 40035 aMenu addLine. 40036 aMenu add: 'new change set... (n)' action: #newSet. 40037 aMenu add: 'find...(f)' action: #findCngSet. 40038 aMenu add: 'show category... (s)' action: #chooseChangeSetCategory. 40039 aMenu balloonTextForLastItem: 40040'Lets you choose which change sets should be listed in this change sorter'. 40041 aMenu add: 'select change set...' action: #chooseCngSet. 40042 aMenu addLine. 40043 aMenu add: 'rename change set (r)' action: #rename. 40044 aMenu add: 'file out (o)' action: #fileOut. 40045 aMenu add: 'mail to list' action: #mailOut. 40046 aMenu add: 'browse methods (b)' action: #browseChangeSet. 40047 aMenu add: 'browse change set (B)' action: #openChangeSetBrowser. 40048 aMenu addLine. 40049 parent 40050 ifNotNil: 40051 [aMenu add: 'copy all to other side (c)' action: #copyAllToOther. 40052 aMenu add: 'submerge into other side' action: #submergeIntoOtherSide. 40053 aMenu add: 'subtract other side (-)' action: #subtractOtherSide. 40054 aMenu addLine]. 40055 myChangeSet hasPreamble 40056 ifTrue: 40057 [aMenu add: 'edit preamble (p)' action: #addPreamble. 40058 aMenu add: 'remove preamble' action: #removePreamble] 40059 ifFalse: [aMenu add: 'add preamble (p)' action: #addPreamble]. 40060 myChangeSet hasPostscript 40061 ifTrue: 40062 [aMenu add: 'edit postscript...' action: #editPostscript. 40063 aMenu add: 'remove postscript' action: #removePostscript] 40064 ifFalse: [aMenu add: 'add postscript...' action: #editPostscript]. 40065 aMenu addLine. 40066 40067 aMenu add: 'category functions...' action: #offerCategorySubmenu. 40068 aMenu balloonTextForLastItem: 40069'Various commands relating to change-set-categories'. 40070 aMenu addLine. 40071 40072 40073 aMenu add: 'destroy change set (x)' action: #remove. 40074 aMenu addLine. 40075 aMenu add: 'more...' action: #offerShiftedChangeSetMenu. 40076 ^ aMenu! ! 40077 40078!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 10/30/2000 10:48'! 40079checkForAlienAuthorship 40080 "Open a message list browser on all uncommented methods in the current change set that have alien authorship" 40081 40082 myChangeSet checkForAlienAuthorship 40083 40084! ! 40085 40086!ChangeSorter methodsFor: 'changeset menu' stamp: 'nk 3/30/2002 08:56'! 40087checkForAnyAlienAuthorship 40088 "Open a message list browser on all uncommented methods in the current change set that have alien authorship, even historically" 40089 40090 myChangeSet checkForAnyAlienAuthorship 40091 40092! ! 40093 40094!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 3/29/2001 12:47'! 40095checkForUnclassifiedMethods 40096 "Open a message list browser on all methods in the current change set that have not been categorized" 40097 40098 myChangeSet checkForUnclassifiedMethods 40099 40100! ! 40101 40102!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 7/18/2002 17:58'! 40103checkForUncommentedClasses 40104 "Open a class list browser on classes in the change set that lack class comments" 40105 40106 myChangeSet checkForUncommentedClasses! ! 40107 40108!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 10/30/2000 10:39'! 40109checkForUncommentedMethods 40110 "Open a message list browser on all uncommented methods in the current change set" 40111 40112 myChangeSet checkForUncommentedMethods 40113 40114! ! 40115 40116!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 10/27/1999 14:20'! 40117checkForUnsentMessages 40118 "Open a message list browser on all unsent messages in the current change set" 40119 40120 myChangeSet checkForUnsentMessages 40121 40122! ! 40123 40124!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 7/8/1999 13:36'! 40125checkThatSidesDiffer: escapeBlock 40126 "If the change sets on both sides of the dual sorter are the same, put up an error message and escape via escapeBlock, else proceed happily" 40127 40128 (myChangeSet == (parent other: self) changeSet) 40129 ifTrue: 40130 [self inform: 40131'This command requires that the 40132change sets selected on the two 40133sides of the change sorter *not* 40134be the same.'. 40135 ^ escapeBlock value] 40136! ! 40137 40138!ChangeSorter methodsFor: 'changeset menu' stamp: 'alain.plantec 5/30/2008 11:01'! 40139chooseChangeSetCategory 40140 "Present the user with a list of change-set-categories and let her choose one" 40141 self okToChange ifFalse: [^ self]. 40142 ^ self chooseChangeSetCategoryInMorphic 40143! ! 40144 40145!ChangeSorter methodsFor: 'changeset menu' stamp: 'sd 11/20/2005 21:26'! 40146clearChangeSet 40147 "Clear out the current change set, after getting a confirmation." 40148 | message | 40149 40150 self okToChange ifFalse: [^ self]. 40151 myChangeSet isEmpty ifFalse: 40152 [message := 'Are you certain that you want to\forget all the changes in this set?' withCRs. 40153 (self confirm: message) ifFalse: [^ self]]. 40154 myChangeSet clear. 40155 self changed: #classList. 40156 self changed: #messageList. 40157 self setContents. 40158 self contentsChanged. 40159! ! 40160 40161!ChangeSorter methodsFor: 'changeset menu' stamp: 'sd 11/20/2005 21:26'! 40162copyAllToOther 40163 "Copy this entire change set into the one on the other side" 40164 | companionSorter | 40165 self checkThatSidesDiffer: [^ self]. 40166 (companionSorter := parent other: self) changeSetCurrentlyDisplayed assimilateAllChangesFoundIn: myChangeSet. 40167 companionSorter changed: #classList. "Later the changeSet itself will notice..." 40168 companionSorter changed: #messageList! ! 40169 40170!ChangeSorter methodsFor: 'changeset menu' stamp: 'tk 6/5/1998 06:47'! 40171currentCngSet 40172 ^ myChangeSet name! ! 40173 40174!ChangeSorter methodsFor: 'changeset menu' stamp: 'tk 4/28/1998 08:06'! 40175editPostscript 40176 "Allow the user to edit the receiver's change-set's postscript -- in a separate window" 40177 40178 myChangeSet editPostscript! ! 40179 40180!ChangeSorter methodsFor: 'changeset menu' stamp: 'tk 4/28/1998 08:06'! 40181editPreamble 40182 "Allow the user to edit the receiver's change-set's preamble -- in a separate window." 40183 40184 myChangeSet editPreamble! ! 40185 40186!ChangeSorter methodsFor: 'changeset menu' stamp: 'nk 1/4/2004 17:07'! 40187fileIntoNewChangeSet 40188 "Obtain a file designation from the user, and file its contents into a 40189 new change set whose name is a function of the filename. Show the 40190 new set and leave the current changeSet unaltered." 40191 | aNewChangeSet stream | 40192 self okToChange 40193 ifFalse: [^ self]. 40194 ChangeSet promptForDefaultChangeSetDirectoryIfNecessary. 40195 stream := StandardFileMenu oldFileStreamFrom: ChangeSet defaultChangeSetDirectory. 40196 stream 40197 ifNil: [^ self]. 40198 aNewChangeSet := self class 40199 newChangesFromStream: stream 40200 named: (FileDirectory localNameFor: stream name). 40201 aNewChangeSet 40202 ifNotNil: [self showChangeSet: aNewChangeSet]! ! 40203 40204!ChangeSorter methodsFor: 'changeset menu' stamp: 'tk 6/10/1999 12:44'! 40205fileOut 40206 "File out the current change set." 40207 40208 myChangeSet fileOut. 40209 parent modelWakeUp. "notice object conversion methods created" 40210! ! 40211 40212!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 3/30/2001 00:57'! 40213fileOutAllChangeSets 40214 "File out all nonempty change sets in the current category, probably" 40215 40216 self changeSetCategory fileOutAllChangeSets! ! 40217 40218!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 3/30/2001 01:26'! 40219fillAggregateChangeSet 40220 "Create a change-set named Aggregate and pour into it all the changes in all the change-sets of the currently-selected category" 40221 40222 self changeSetCategory fillAggregateChangeSet! ! 40223 40224!ChangeSorter methodsFor: 'changeset menu' stamp: 'DamienCassou 9/23/2009 08:33'! 40225findCngSet 40226 "Search for a changeSet by name. Pop up a menu of all changeSets whose name contains the string entered by the user. If only one matches, then the pop-up menu is bypassed" 40227 | index pattern candidates nameList | 40228 self okToChange ifFalse: [^ self]. 40229 pattern := UIManager default request: 'ChangeSet name or fragment?'. 40230 pattern isEmptyOrNil ifTrue: [^ self]. 40231 nameList := self changeSetList asSet. 40232 candidates := ChangeSet allChangeSets select: 40233 [:c | (nameList includes: c name) and: 40234 [c name includesSubstring: pattern caseSensitive: false]]. 40235 candidates size = 0 ifTrue: [^ Beeper beep]. 40236 candidates size = 1 ifTrue: 40237 [^ self showChangeSet: candidates first]. 40238 index := UIManager default chooseFrom: (candidates collect: [:each | each name]). 40239 index = 0 ifFalse: [self showChangeSet: (candidates at: index)]. 40240! ! 40241 40242!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 1/10/1999 01:01'! 40243inspectChangeSet 40244 "Open a message list browser on the new and changed methods in the current change set" 40245 40246 myChangeSet inspectWithLabel: 'Change set: ', myChangeSet name 40247 40248! ! 40249 40250!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 2/17/1999 11:05'! 40251lookForSlips 40252 "Open a message list browser on the new and changed methods in the current change set" 40253 40254 myChangeSet lookForSlips 40255 40256! ! 40257 40258!ChangeSorter methodsFor: 'changeset menu' stamp: 'dvf 5/13/2000 05:08'! 40259mailOut 40260 "Create a mail with a gzipped attachment holding out the current change 40261 set. " 40262 myChangeSet mailOut. 40263 parent modelWakeUp! ! 40264 40265!ChangeSorter methodsFor: 'changeset menu' stamp: 'tk 4/24/1998 13:10'! 40266mainButtonName 40267 40268 ^ myChangeSet name! ! 40269 40270!ChangeSorter methodsFor: 'changeset menu' stamp: 'sd 11/20/2005 21:26'! 40271methodConflictsWithOppositeCategory 40272 "Check to see if ANY change set on the other side shares any methods with the selected change set; if so, open a browser on all such." 40273 40274 | aList otherCategory | 40275 40276 otherCategory := (parent other: self) changeSetCategory. 40277 aList := myChangeSet 40278 messageListForChangesWhich: [ :aClass :aSelector | 40279 aClass notNil and: 40280 [otherCategory 40281 hasChangeForClassName: aClass name 40282 selector: aSelector 40283 otherThanIn: myChangeSet] 40284 ] 40285 ifNone: [^ self inform: 40286'There are no methods that appear both in 40287this change set and in any change set 40288(other than this one) on the other side.']. 40289 40290 MessageSet 40291 openMessageList: aList 40292 name: 'Methods in "', myChangeSet name, '" also in some other change set in category ', otherCategory categoryName,' (', aList size printString, ')' 40293 ! ! 40294 40295!ChangeSorter methodsFor: 'changeset menu' stamp: 'sd 11/20/2005 21:26'! 40296methodConflictsWithOtherSide 40297 "Check to see if the change set on the other side shares any methods with the selected change set; if so, open a browser on all such." 40298 40299 | aList other | 40300 40301 self checkThatSidesDiffer: [^ self]. 40302 other := (parent other: self) changeSet. 40303 aList := myChangeSet 40304 messageListForChangesWhich: [ :aClass :aSelector | 40305 aClass notNil and: [(other methodChangesAtClass: aClass name) includesKey: aSelector] 40306 ] 40307 ifNone: [^ self inform: 'There are no methods that appear 40308both in this change set and 40309in the one on the other side.']. 40310 40311 MessageSet 40312 openMessageList: aList 40313 name: 'Methods in "', myChangeSet name, '" that are also in ', other name,' (', aList size printString, ')' 40314 ! ! 40315 40316!ChangeSorter methodsFor: 'changeset menu' stamp: 'sd 5/23/2003 15:15'! 40317newCurrent 40318 "make my change set be the current one that changes go into" 40319 40320 ChangeSet newChanges: myChangeSet. 40321 self update. "Because list of changes in a category may thus have changed" 40322 self changed: #relabel.! ! 40323 40324!ChangeSorter methodsFor: 'changeset menu' stamp: 'sd 11/20/2005 21:26'! 40325newSet 40326 "Create a new changeSet and show it., making it the current one. Reject name if already in use." 40327 40328 | aSet | 40329 self okToChange ifFalse: [^ self]. 40330 aSet := self class newChangeSet. 40331 aSet ifNotNil: 40332 [self changeSetCategory acceptsManualAdditions ifTrue: 40333 [changeSetCategory addChangeSet: aSet]. 40334 self update. 40335 (changeSetCategory includesChangeSet: aSet) ifTrue: 40336 [self showChangeSet: aSet]. 40337 self changed: #relabel]! ! 40338 40339!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 4/11/2001 17:41'! 40340offerCategorySubmenu 40341 "Offer a menu of category-related items" 40342 40343 self offerMenuFrom: #categorySubmenu:shifted: shifted: false! ! 40344 40345!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 2/27/2001 21:55'! 40346offerShiftedChangeSetMenu 40347 "Offer the shifted version of the change set menu" 40348 40349 self offerMenuFrom: #changeSetMenu:shifted: shifted: true! ! 40350 40351!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 3/6/2001 14:41'! 40352offerUnshiftedChangeSetMenu 40353 "Offer the unshifted version of the change set menu" 40354 40355 self offerMenuFrom: #changeSetMenu:shifted: shifted: false! ! 40356 40357!ChangeSorter methodsFor: 'changeset menu' stamp: 'alain.plantec 5/30/2008 11:10'! 40358openChangeSetBrowser 40359 "Open a ChangeSet browser on the current change set" 40360 40361 (ChangeSetBrowser new myChangeSet: myChangeSet) openAsMorph! ! 40362 40363!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 12/13/2003 18:14'! 40364promoteToTopChangeSet 40365 "Move the selected change-set to the top of the list" 40366 40367 self class promoteToTop: myChangeSet. 40368 (parent ifNil: [self]) modelWakeUp! ! 40369 40370!ChangeSorter methodsFor: 'changeset menu' stamp: 'di 6/14/1998 12:00'! 40371remove 40372 "Completely destroy my change set. Check if it's OK first" 40373 40374 self okToChange ifFalse: [^ self]. 40375 self removePrompting: true. 40376 self update! ! 40377 40378!ChangeSorter methodsFor: 'changeset menu' stamp: 'DamienCassou 9/29/2009 09:07'! 40379removeContainedInClassCategories 40380 | matchExpression | 40381 myChangeSet removePreamble. 40382 matchExpression := UIManager default request: 'Enter class category name (wildcard is ok)' initialAnswer: 'System-*'. 40383 matchExpression ifNil: [^ self]. 40384 (Smalltalk organization categories 40385 select: [:each | matchExpression match: each]) 40386 do: [:eachCat | 40387 | classNames | 40388 classNames := Smalltalk organization listAtCategoryNamed: eachCat. 40389 classNames 40390 do: [:eachClassName | 40391 myChangeSet removeClassChanges: eachClassName. 40392 myChangeSet removeClassChanges: eachClassName , ' class']. 40393 self showChangeSet: myChangeSet]! ! 40394 40395!ChangeSorter methodsFor: 'changeset menu' stamp: 'sd 11/20/2005 21:26'! 40396removeFromCategory 40397 "Add the current change set to the category viewed on the opposite side, if it's of the sort to accept things like that" 40398 40399 | aCategory | 40400 (aCategory := self changeSetCategory) acceptsManualAdditions 40401 ifTrue: 40402 [aCategory removeElementAt: myChangeSet name. 40403 aCategory reconstituteList. 40404 self update] 40405 ifFalse: 40406 [self inform: 40407'sorry, this command only makes 40408sense for static categories whose 40409members are manually maintained']! ! 40410 40411!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 6/29/1999 20:53'! 40412removePostscript 40413 (myChangeSet hasPostscript and: [myChangeSet postscriptHasDependents]) ifTrue: 40414 [^ self inform: 40415'Cannot remove the postscript right 40416now because there is at least one 40417window open on that postscript. 40418Close that window and try again.']. 40419 40420 myChangeSet removePostscript. 40421 self showChangeSet: myChangeSet! ! 40422 40423!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 3/5/1999 19:32'! 40424removePreamble 40425 myChangeSet removePreamble. 40426 self showChangeSet: myChangeSet! ! 40427 40428!ChangeSorter methodsFor: 'changeset menu' stamp: 'DamienCassou 9/29/2009 09:08'! 40429rename 40430 "Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out" 40431 40432 | newName | 40433 newName := UIManager default request: 'New name for this change set' 40434 initialAnswer: myChangeSet name. 40435 (newName = myChangeSet name or: [newName isEmptyOrNil]) ifTrue: 40436 [^ Beeper beep]. 40437 40438 (self class changeSetNamed: newName) ifNotNil: 40439 [^ Utilities inform: 'Sorry that name is already used']. 40440 40441 myChangeSet name: newName. 40442 self update. 40443 self changed: #mainButtonName. 40444 self changed: #relabel.! ! 40445 40446!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 3/5/2001 11:03'! 40447reorderChangeSets 40448 "apply a standard reordering -- let the class handle this" 40449 40450 ^ self class reorderChangeSets! ! 40451 40452!ChangeSorter methodsFor: 'changeset menu' stamp: 'alain.plantec 2/6/2009 15:19'! 40453setRecentUpdatesMarker 40454 "Allow the user to change the recent-updates marker" 40455 40456 | result | 40457 result := UIManager default request: 40458('Enter the lowest change-set number 40459that you wish to consider "recent"?' translated, ' 40460(note: highest change-set number 40461in this image at this time is ' translated, ChangeSet highestNumberedChangeSet asString, ')') initialAnswer: self class recentUpdateMarker asString. 40462 (result notNil and: [result startsWithDigit]) ifTrue: 40463 [self class recentUpdateMarker: result asInteger. 40464 SystemWindow wakeUpTopWindowUponStartup]! ! 40465 40466!ChangeSorter methodsFor: 'changeset menu' stamp: 'MiguelCoba 7/25/2009 02:06'! 40467shiftedChangeSetMenu: aMenu 40468 "Set up aMenu to hold items relating to the change-set-list pane when the shift key is down" 40469 40470 aMenu title: 'Change set (shifted)'. 40471 aMenu addStayUpItemSpecial. 40472 40473 "CONFLICTS SECTION" 40474 aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts. 40475 aMenu balloonTextForLastItem: 40476'Browse all methods that occur both in this change set and in at least one other change set.'. 40477 parent ifNotNil: 40478 [aMenu add: 'conflicts with change set opposite' action: #methodConflictsWithOtherSide. 40479 aMenu balloonTextForLastItem: 40480'Browse all methods that occur both in this change set and in the one on the opposite side of the change sorter.'. 40481 40482 aMenu add: 'conflicts with category opposite' action: #methodConflictsWithOppositeCategory. 40483 aMenu balloonTextForLastItem: 40484'Browse all methods that occur both in this change set and in ANY change set in the category list on the opposite side of this change sorter, other of course than this change set itself. (Caution -- this could be VERY slow)']. 40485 aMenu addLine. 40486 40487 "CHECKS SECTION" 40488 aMenu add: 'check for slips' action: #lookForSlips. 40489 aMenu balloonTextForLastItem: 40490'Check this change set for halts and references to Transcript.'. 40491 40492 aMenu add: 'check for unsent messages' action: #checkForUnsentMessages. 40493 aMenu balloonTextForLastItem: 40494'Check this change set for messages that are not sent anywhere in the system'. 40495 40496 aMenu add: 'check for uncommented methods' action: #checkForUncommentedMethods. 40497 aMenu balloonTextForLastItem: 40498'Check this change set for methods that do not have comments'. 40499 40500 aMenu add: 'check for uncommented classes' action: #checkForUncommentedClasses. 40501 aMenu balloonTextForLastItem: 40502'Check for classes with code in this changeset which lack class comments'. 40503 40504 Author fullNamePerSe isEmptyOrNil ifFalse: 40505 [aMenu add: 'check for other authors' action: #checkForAlienAuthorship. 40506 aMenu balloonTextForLastItem: 40507'Check this change set for methods whose current authoring stamp does not start with "', Author fullName, '"'. 40508 40509 aMenu add: 'check for any other authors' action: #checkForAnyAlienAuthorship. 40510 aMenu balloonTextForLastItem: 40511'Check this change set for methods any of whose authoring stamps do not start with "', Author fullName, '"']. 40512 40513 aMenu add: 'check for uncategorized methods' action: #checkForUnclassifiedMethods. 40514 aMenu balloonTextForLastItem: 40515'Check to see if any methods in the selected change set have not yet been assigned to a category. If any are found, open a browser on them.'. 40516 aMenu addLine. 40517 40518 aMenu add: 'inspect change set' action: #inspectChangeSet. 40519 aMenu balloonTextForLastItem: 40520'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'. 40521 40522 aMenu add: 'update' action: #update. 40523 aMenu balloonTextForLastItem: 40524'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)'. 40525 40526 aMenu add: 'promote to top of list' action: #promoteToTopChangeSet. 40527 aMenu balloonTextForLastItem: 40528'Make this change set appear first in change-set lists in all change sorters.'. 40529 40530 aMenu add: 'trim history' action: #trimHistory. 40531 aMenu balloonTextForLastItem: 40532' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. NOTE: can cause confusion if later filed in over an earlier version of these changes'. 40533 40534 aMenu add: 'remove contained in class categories...' action: #removeContainedInClassCategories. 40535 aMenu balloonTextForLastItem: ' Drops any changes in given class categories'. 40536 40537 aMenu add: 'clear this change set' action: #clearChangeSet. 40538 aMenu balloonTextForLastItem: 40539'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'. 40540 40541 aMenu add: 'uninstall this change set' action: #uninstallChangeSet. 40542 aMenu balloonTextForLastItem: 40543'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!'. 40544 40545 aMenu addLine. 40546 aMenu add: 'file into new...' action: #fileIntoNewChangeSet. 40547 aMenu balloonTextForLastItem: 40548'Load a fileout from disk and place its changes into a new change set (seldom needed -- much better to do this from a file-list browser these days.)'. 40549 40550 aMenu add: 'reorder all change sets' action: #reorderChangeSets. 40551 aMenu balloonTextForLastItem: 40552'Applies a standard reordering of all change-sets in the system -- at the bottom will come the sets that come with the release; next will come all the numbered updates; finally, at the top, will come all other change sets'. 40553 40554 aMenu addLine. 40555 40556 aMenu add: 'more...' action: #offerUnshiftedChangeSetMenu. 40557 aMenu balloonTextForLastItem: 40558'Takes you back to the primary change-set menu.'. 40559 40560 ^ aMenu! ! 40561 40562!ChangeSorter methodsFor: 'changeset menu' stamp: 'pk 10/23/2008 18:13'! 40563showCategoriesOfChangeSet 40564 "Show a list of all the categories in which the selected change-set occurs 40565 at the moment. Install the one the user chooses, if any." 40566 | aMenu | 40567 aMenu := MenuMorph new defaultTarget: self. 40568 aMenu title: 'Categories which 40569contain change set 40570"' , myChangeSet name , '"'. 40571 self changeSetCategories elementsInOrder 40572 do: [:aCategory | 40573 (aCategory includesChangeSet: myChangeSet) 40574 ifTrue: [aMenu 40575 add: aCategory categoryName 40576 target: self 40577 selector: #showChangeSetCategory: 40578 argument: aCategory. 40579 aCategory == changeSetCategory 40580 ifTrue: [aMenu lastItem color: Color red]]. 40581 aMenu balloonTextForLastItem: aCategory documentation]. 40582 aMenu popUpInWorld! ! 40583 40584!ChangeSorter methodsFor: 'changeset menu' stamp: 'sd 11/20/2005 21:26'! 40585submergeIntoOtherSide 40586 "Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well." 40587 | other message nextToView i all | 40588 self checkThatSidesDiffer: [^ self]. 40589 self okToChange ifFalse: [^ self]. 40590 other := (parent other: self) changeSet. 40591 other == myChangeSet ifTrue: [^ self inform: 'Both sides are the same!!']. 40592 myChangeSet isEmpty ifTrue: [^ self inform: 'Nothing to copy. To remove, 40593simply choose "remove".']. 40594 40595 myChangeSet okayToRemove ifFalse: [^ self]. 40596 message := 'Please confirm: copy all changes 40597in "', myChangeSet name, '" into "', other name, '" 40598and then destroy the change set 40599named "', myChangeSet name, '"?'. 40600 40601 (self confirm: message) ifFalse: [^ self]. 40602 40603 (myChangeSet hasPreamble or: [myChangeSet hasPostscript]) ifTrue: 40604 [(self confirm: 40605'Caution!! This change set has a preamble or 40606a postscript or both. If you submerge it into 40607the other side, these will be lost. 40608Do you really want to go ahead with this?') ifFalse: [^ self]]. 40609 40610 other assimilateAllChangesFoundIn: myChangeSet. 40611 all := ChangeSet allChangeSets. 40612 nextToView := ((all includes: myChangeSet) 40613 and: [(i := all indexOf: myChangeSet) < all size]) 40614 ifTrue: [all at: i+1] 40615 ifFalse: [other]. 40616 40617 self removePrompting: false. 40618 self showChangeSet: nextToView. 40619 parent modelWakeUp. 40620! ! 40621 40622!ChangeSorter methodsFor: 'changeset menu' stamp: 'sw 7/8/1999 12:32'! 40623subtractOtherSide 40624 "Subtract the changes found on the other side from the requesting side." 40625 self checkThatSidesDiffer: [^ self]. 40626 myChangeSet forgetAllChangesFoundIn: ((parent other: self) changeSet). 40627 self showChangeSet: myChangeSet! ! 40628 40629!ChangeSorter methodsFor: 'changeset menu' stamp: 'di 5/12/2000 15:03'! 40630trimHistory 40631 "Drop non-essential history (rename, reorg, method removals) from newly-added classes." 40632 40633 myChangeSet trimHistory 40634 40635! ! 40636 40637!ChangeSorter methodsFor: 'changeset menu' stamp: 'di 3/8/2000 14:18'! 40638uninstallChangeSet 40639 "Attempt to uninstall the current change set, after confirmation." 40640 40641 self okToChange ifFalse: [^ self]. 40642 (self confirm: 'Uninstalling a changeSet is unreliable at best. 40643It will only work if the changeSet consists only of single 40644changes, additions and removals of methods, and if 40645no subsequent changes have been to any of them. 40646No changes to classes will be undone. 40647The changeSet will be cleared after uninstallation. 40648Do you still wish to attempt to uninstall this changeSet?') 40649 ifFalse: [^ self]. 40650 40651 myChangeSet uninstall. 40652 self changed: #relabel. 40653 self changed: #classList. 40654 self changed: #messageList. 40655 self setContents. 40656 self contentsChanged. 40657! ! 40658 40659!ChangeSorter methodsFor: 'changeset menu' stamp: 'di 6/21/1998 13:02'! 40660update 40661 "recompute all of my panes" 40662 40663 self updateIfNecessary. 40664 parent ifNotNil: [(parent other: self) updateIfNecessary]! ! 40665 40666!ChangeSorter methodsFor: 'changeset menu' stamp: 'sd 11/20/2005 21:26'! 40667updateIfNecessary 40668 "Recompute all of my panes." 40669 40670 | newList | 40671 self okToChange ifFalse: [^ self]. 40672 40673 myChangeSet ifNil: [^ self]. "Has been known to happen though shouldn't" 40674 (myChangeSet isMoribund or: [(changeSetCategory notNil and: [changeSetCategory includesChangeSet: myChangeSet]) not]) ifTrue: 40675 [self changed: #changeSetList. 40676 ^ self showChangeSet: self changeSetCategory defaultChangeSetToShow]. 40677 40678 newList := self changeSetList. 40679 40680 (priorChangeSetList == nil or: [priorChangeSetList ~= newList]) 40681 ifTrue: 40682 [priorChangeSetList := newList. 40683 self changed: #changeSetList]. 40684 self showChangeSet: myChangeSet! ! 40685 40686 40687!ChangeSorter methodsFor: 'class list' stamp: 'sw 3/29/2001 15:19'! 40688classList 40689 "Computed. View should try to preserve selections, even though index changes" 40690 40691 ^ myChangeSet ifNotNil: [myChangeSet changedClassNames] ifNil: [OrderedCollection new] 40692! ! 40693 40694!ChangeSorter methodsFor: 'class list' stamp: 'sw 3/5/2001 18:24'! 40695classListKey: aChar from: view 40696 "Respond to a Command key in the class-list pane." 40697 40698 aChar == $x ifTrue: [^ self removeClass]. 40699 aChar == $d ifTrue: [^ self forgetClass]. 40700 40701 ^ self messageListKey: aChar from: view "picks up b,h,p"! ! 40702 40703!ChangeSorter methodsFor: 'class list' stamp: 'dc 7/18/2008 11:41'! 40704classListMenu: aMenu shifted: shifted 40705 "Fill aMenu with items appropriate for the class list" 40706 40707 aMenu title: 'class list'. 40708 aMenu addStayUpItemSpecial. 40709 (parent notNil and: [shifted not]) 40710 ifTrue: [aMenu addList: #( "These two only apply to dual change sorters" 40711 ('copy class chgs to other side' copyClassToOther) 40712 ('move class chgs to other side' moveClassToOther))]. 40713 40714 aMenu addList: (shifted 40715 ifFalse: [#( 40716 - 40717 ('delete class from change set (d)' forgetClass) 40718 ('remove class from system (x)' removeClass) 40719 - 40720 ('browse full (b)' browseMethodFull) 40721 ('browse hierarchy (h)' spawnHierarchy) 40722 ('browse protocol (p)' browseFullProtocol) 40723 - 40724 ('fileOut' fileOutClass) 40725 - 40726 ('inst var refs...' browseInstVarRefs) 40727 ('inst var defs...' browseInstVarDefs) 40728 ('class var refs...' browseClassVarRefs) 40729 ('class vars' browseClassVariables) 40730 ('class refs (N)' browseClassRefs) 40731 - 40732 ('more...' offerShiftedClassListMenu))] 40733 40734 ifTrue: [#( 40735 - 40736 ('unsent methods' browseUnusedMethods) 40737 ('unreferenced inst vars' showUnreferencedInstVars) 40738 ('unreferenced class vars' showUnreferencedClassVars) 40739 - 40740 ('sample instance' makeSampleInstance) 40741 ('inspect instances' inspectInstances) 40742 ('inspect subinstances' inspectSubInstances) 40743 - 40744 ('more...' offerUnshiftedClassListMenu ))]). 40745 ^ aMenu! ! 40746 40747!ChangeSorter methodsFor: 'class list' stamp: 'sw 2/26/2001 12:00'! 40748classMenu: aMenu 40749 "Set up aMenu for the class-list. Retained for backward compatibility with old change sorters in image segments" 40750 40751 ^ self classListMenu: aMenu shifted: false! ! 40752 40753!ChangeSorter methodsFor: 'class list' stamp: 'sw 3/6/2001 12:40'! 40754classMenu: aMenu shifted: shifted 40755 "Fill aMenu with items appropriate for the class list. Retained for bkwd compatibility" 40756 40757 ^ self classListMenu: aMenu shifted: shifted! ! 40758 40759!ChangeSorter methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! 40760copyClassToOther 40761 "Place these changes in the other changeSet also" 40762 40763 | otherSorter otherChangeSet | 40764 self checkThatSidesDiffer: [^ self]. 40765 self okToChange ifFalse: [^ Beeper beep]. 40766 currentClassName ifNil: [^ Beeper beep]. 40767 otherSorter := parent other: self. 40768 otherChangeSet := otherSorter changeSet. 40769 40770 otherChangeSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet. 40771 otherSorter showChangeSet: otherChangeSet.! ! 40772 40773!ChangeSorter methodsFor: 'class list' stamp: 'tk 4/24/1998 09:14'! 40774currentClassName 40775 40776 ^ currentClassName! ! 40777 40778!ChangeSorter methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! 40779currentClassName: aString 40780 40781 currentClassName := aString. 40782 currentSelector := nil. "fix by wod" 40783 self changed: #currentClassName. 40784 self changed: #messageList. 40785 self setContents. 40786 self contentsChanged.! ! 40787 40788!ChangeSorter methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! 40789fileOutClass 40790 "this is a hack!!!! makes a new change set, called the class name, adds author initials to try to make a unique change set name, files it out and removes it. kfr 16 june 2000" 40791 | aSet | 40792 "File out the selected class set." 40793 aSet := self class newChangeSet: currentClassName. 40794 aSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet. 40795 aSet fileOut. 40796 self class removeChangeSet: aSet. 40797 parent modelWakeUp. "notice object conversion methods created" 40798 40799! ! 40800 40801!ChangeSorter methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! 40802forgetClass 40803 "Remove all mention of this class from the changeSet" 40804 40805 self okToChange ifFalse: [^ self]. 40806 currentClassName ifNotNil: [ 40807 myChangeSet removeClassChanges: currentClassName. 40808 currentClassName := nil. 40809 currentSelector := nil. 40810 self showChangeSet: myChangeSet]. 40811! ! 40812 40813!ChangeSorter methodsFor: 'class list' stamp: 'sw 3/5/2001 18:30'! 40814messageListKey: aChar from: view 40815 "Respond to a Command key in the message-list pane." 40816 40817 aChar == $d ifTrue: [^ self forget]. 40818 super messageListKey: aChar from: view! ! 40819 40820!ChangeSorter methodsFor: 'class list' stamp: 'nb 6/17/2003 12:25'! 40821moveClassToOther 40822 "Place class changes in the other changeSet and remove them from this one" 40823 40824 self checkThatSidesDiffer: [^ self]. 40825 (self okToChange and: [currentClassName notNil]) ifFalse: [^ Beeper beep]. 40826 40827 self copyClassToOther. 40828 self forgetClass! ! 40829 40830!ChangeSorter methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! 40831selectedClass 40832 "Answer the currently-selected class. If there is no selection, or if the selection refers to a class no longer extant, return nil" 40833 | c | 40834 ^ currentClassName ifNotNil: [(c := self selectedClassOrMetaClass) 40835 ifNotNil: [c theNonMetaClass]]! ! 40836 40837 40838!ChangeSorter methodsFor: 'code pane' stamp: 'sd 11/20/2005 21:26'! 40839contents: aString notifying: aController 40840 "Compile the code in aString. Notify aController of any syntax errors. 40841 Create an error if the category of the selected message is unknown. 40842 Answer false if the compilation fails. Otherwise, if the compilation 40843 created a new method, deselect the current selection. Then answer true." 40844 | category selector class oldSelector | 40845 40846 (class := self selectedClassOrMetaClass) ifNil: 40847 [(myChangeSet preambleString == nil or: [aString size == 0]) ifTrue: [ ^ false]. 40848 (aString count: [:char | char == $"]) odd 40849 ifTrue: [self inform: 'unmatched double quotes in preamble'] 40850 ifFalse: [(Scanner new scanTokens: aString) size > 0 ifTrue: [ 40851 self inform: 'Part of the preamble is not within double-quotes. 40852To put a double-quote inside a comment, type two double-quotes in a row. 40853(Ignore this warning if you are including a doIt in the preamble.)']]. 40854 myChangeSet preambleString: aString. 40855 self currentSelector: nil. "forces update with no 'unsubmitted chgs' feedback" 40856 ^ true]. 40857 oldSelector := self selectedMessageName. 40858 category := class organization categoryOfElement: oldSelector. 40859 selector := class compile: aString 40860 classified: category 40861 notifying: aController. 40862 selector ifNil: [^ false]. 40863 (self messageList includes: selector) 40864 ifTrue: [self currentSelector: selector] 40865 ifFalse: [self currentSelector: oldSelector]. 40866 self update. 40867 ^ true! ! 40868 40869!ChangeSorter methodsFor: 'code pane' stamp: 'PeterHugossonMiller 9/3/2009 00:52'! 40870setContents 40871 "return the source code that shows in the bottom pane" 40872 | sel class strm changeType | 40873 self clearUserEditFlag. 40874 currentClassName 40875 ifNil: [^ contents := myChangeSet preambleString 40876 ifNil: ['']]. 40877 class := self selectedClassOrMetaClass. 40878 (sel := currentSelector) == nil 40879 ifTrue: [strm := (String new: 100) writeStream. 40880 (myChangeSet classChangeAt: currentClassName) 40881 do: [:each | 40882 each = #remove 40883 ifTrue: [strm nextPutAll: 'Entire class was removed.'; 40884 cr]. 40885 each = #addedThenRemoved 40886 ifTrue: [strm nextPutAll: 'Class was added then removed.']. 40887 each = #rename 40888 ifTrue: [strm nextPutAll: 'Class name was changed.'; 40889 cr]. 40890 each = #add 40891 ifTrue: [strm nextPutAll: 'Class definition was added.'; 40892 cr]. 40893 each = #change 40894 ifTrue: [strm nextPutAll: 'Class definition was changed.'; 40895 cr]. 40896 each = #reorganize 40897 ifTrue: [strm nextPutAll: 'Class organization was changed.'; 40898 cr]. 40899 each = #comment 40900 ifTrue: [strm nextPutAll: 'New class comment.'; 40901 cr]]. 40902 ^ contents := strm contents] 40903 ifFalse: [changeType := myChangeSet atSelector: (sel := sel asSymbol) class: class. 40904 changeType == #remove 40905 ifTrue: [^ contents := 'Method has been removed (see versions)']. 40906 changeType == #addedThenRemoved 40907 ifTrue: [^ contents := 'Added then removed (see versions)']. 40908 class 40909 ifNil: [^ contents := 'Method was added, but cannot be found!!']. 40910 (class includesSelector: sel) 40911 ifFalse: [^ contents := 'Method was added, but cannot be found!!']. 40912 contents := class sourceCodeAt: sel. 40913 (#(#prettyPrint #prettyDiffs ) includes: contentsSymbol) 40914 ifTrue: [contents := class prettyPrinterClass 40915 format: contents 40916 in: class 40917 notifying: nil]. 40918 self showingAnyKindOfDiffs 40919 ifTrue: [contents := self diffFromPriorSourceFor: contents]. 40920 ^ contents := contents asText makeSelectorBoldIn: class]! ! 40921 40922!ChangeSorter methodsFor: 'code pane' stamp: 'sw 11/13/2001 07:34'! 40923toggleDiffing 40924 "Toggle whether diffs should be shown in the code pane" 40925 40926 self okToChange ifTrue: 40927 [super toggleDiffing. 40928 self changed: #contents. 40929 self update] 40930 40931! ! 40932 40933!ChangeSorter methodsFor: 'code pane' stamp: 'JW 2/2/2001 21:41'! 40934wantsOptionalButtons 40935 "No optional buttons for ChangeSorter" 40936 ^false! ! 40937 40938 40939!ChangeSorter methodsFor: 'creation' stamp: 'sd 11/20/2005 21:26'! 40940morphicWindow 40941 "ChangeSorter new openAsMorph" 40942 | window | 40943 40944 myChangeSet ifNil: [self myChangeSet: ChangeSet current]. 40945 window := (SystemWindow labelled: self labelString) model: self. 40946 self openAsMorphIn: window rect: (0@0 extent: 1@1). 40947 ^ window 40948! ! 40949 40950!ChangeSorter methodsFor: 'creation' stamp: 'alain.plantec 5/30/2008 11:08'! 40951open 40952 "ChangeSorter new open" 40953 ^ self openAsMorph! ! 40954 40955!ChangeSorter methodsFor: 'creation' stamp: 'sw 3/6/1999 09:34'! 40956openAsMorph 40957 "ChangeSorter new openAsMorph" 40958 ^ self morphicWindow openInWorld. 40959! ! 40960 40961!ChangeSorter methodsFor: 'creation' stamp: 'sd 11/20/2005 21:26'! 40962openAsMorphIn: window rect: rect 40963 "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." 40964 40965 | csListHeight msgListHeight csMsgListHeight | 40966 contents := ''. 40967 csListHeight := 0.25. 40968 msgListHeight := 0.25. 40969 csMsgListHeight := csListHeight + msgListHeight. 40970 self addDependent: window. "so it will get changed: #relabel" 40971 40972"The method SystemWindow>>addMorph:fullFrame: checks scrollBarsOnRight, then adds the morph at the back if true, otherwise it is added in front. But flopout hScrollbars needs the crrentSelector pane to be behind the upper ones in the draw order. Hence the value of scrollBarsOnRight affects the order in which the lowerpanes are added." 40973 Preferences scrollBarsOnRight ifFalse: 40974 [window addMorph: (PluggableListMorphByItem on: self 40975 list: #messageList 40976 selected: #currentSelector 40977 changeSelected: #currentSelector: 40978 menu: #messageMenu:shifted: 40979 keystroke: #messageListKey:from:) 40980 frame: (((0@csListHeight extent: 1@msgListHeight) 40981 scaleBy: rect extent) translateBy: rect origin)]. 40982 40983 window addMorph: ((PluggableListMorphByItem on: self 40984 list: #changeSetList 40985 selected: #currentCngSet 40986 changeSelected: #showChangeSetNamed: 40987 menu: #changeSetMenu:shifted: 40988 keystroke: #changeSetListKey:from:) 40989 autoDeselect: false) 40990 frame: (((0@0 extent: 0.5@csListHeight) 40991 scaleBy: rect extent) translateBy: rect origin). 40992 40993 window addMorph: (PluggableListMorphByItem on: self 40994 list: #classList 40995 selected: #currentClassName 40996 changeSelected: #currentClassName: 40997 menu: #classListMenu:shifted: 40998 keystroke: #classListKey:from:) 40999 frame: (((0.5@0 extent: 0.5@csListHeight) 41000 scaleBy: rect extent) translateBy: rect origin). 41001 41002 Preferences scrollBarsOnRight ifTrue: 41003 [window addMorph: (PluggableListMorphByItem on: self 41004 list: #messageList 41005 selected: #currentSelector 41006 changeSelected: #currentSelector: 41007 menu: #messageMenu:shifted: 41008 keystroke: #messageListKey:from:) 41009 frame: (((0@csListHeight extent: 1@msgListHeight) 41010 scaleBy: rect extent) translateBy: rect origin)]. 41011 41012 self addLowerPanesTo: window 41013 at: (((0@csMsgListHeight corner: 1@1) scaleBy: rect extent) translateBy: rect origin) 41014 with: nil. 41015! ! 41016 41017!ChangeSorter methodsFor: 'creation' stamp: 'sd 11/20/2005 21:26'! 41018setDefaultChangeSetCategory 41019 "Set a default ChangeSetCategory for the receiver, and answer it" 41020 41021 ^ changeSetCategory := self class changeSetCategoryNamed: #All! ! 41022 41023!ChangeSorter methodsFor: 'creation' stamp: 'sd 11/20/2005 21:26'! 41024veryDeepFixupWith: deepCopier 41025 41026 super veryDeepFixupWith: deepCopier. 41027 parent := deepCopier references at: parent ifAbsent: [parent]. 41028 self updateIfNecessary! ! 41029 41030!ChangeSorter methodsFor: 'creation' stamp: 'sd 11/20/2005 21:26'! 41031veryDeepInner: deepCopier 41032 "Copy all of my instance variables. Some need to be not copied at all, but shared." 41033 41034super veryDeepInner: deepCopier. 41035"parent := parent. Weakly copied" 41036"myChangeSet := myChangeSet. Weakly copied" 41037currentClassName := currentClassName veryDeepCopyWith: deepCopier. 41038"currentSelector := currentSelector. Symbol" 41039priorChangeSetList := priorChangeSetList veryDeepCopyWith: deepCopier. 41040changeSetCategory := changeSetCategory. 41041 41042! ! 41043 41044 41045!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'! 41046browseVersions 41047 "Create and schedule a changelist browser on the versions of the 41048 selected message." 41049 | class selector method category pair sourcePointer | 41050 41051 (selector := self selectedMessageName) ifNil: [^ self]. 41052 class := self selectedClassOrMetaClass. 41053 (class includesSelector: selector) 41054 ifTrue: [method := class compiledMethodAt: selector. 41055 category := class whichCategoryIncludesSelector: selector. 41056 sourcePointer := nil] 41057 ifFalse: [pair := myChangeSet methodInfoFromRemoval: {class name. selector}. 41058 pair ifNil: [^ nil]. 41059 sourcePointer := pair first. 41060 method := CompiledMethod toReturnSelf setSourcePointer: sourcePointer. 41061 category := pair last]. 41062 VersionsBrowser 41063 browseVersionsOf: method 41064 class: self selectedClass meta: class isMeta 41065 category: category selector: selector 41066 lostMethodPointer: sourcePointer. 41067! ! 41068 41069!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'! 41070copyMethodToOther 41071 "Place this change in the other changeSet also" 41072 | other cls sel | 41073 self checkThatSidesDiffer: [^ self]. 41074 currentSelector ifNotNil: 41075 [other := (parent other: self) changeSet. 41076 cls := self selectedClassOrMetaClass. 41077 sel := currentSelector asSymbol. 41078 41079 other absorbMethod: sel class: cls from: myChangeSet. 41080 (parent other: self) showChangeSet: other] 41081! ! 41082 41083!ChangeSorter methodsFor: 'message list' stamp: 'tk 4/24/1998 09:15'! 41084currentSelector 41085 41086 ^ currentSelector! ! 41087 41088!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'! 41089currentSelector: messageName 41090 41091 currentSelector := messageName. 41092 self changed: #currentSelector. 41093 self setContents. 41094 self contentsChanged.! ! 41095 41096!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'! 41097forget 41098 "Drop this method from the changeSet" 41099 41100 self okToChange ifFalse: [^ self]. 41101 currentSelector ifNotNil: [ 41102 myChangeSet removeSelectorChanges: self selectedMessageName 41103 class: self selectedClassOrMetaClass. 41104 currentSelector := nil. 41105 self showChangeSet: myChangeSet]! ! 41106 41107!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'! 41108messageList 41109 41110 | probe newSelectors | 41111 currentClassName ifNil: [^ #()]. 41112 probe := (currentClassName endsWith: ' class') 41113 ifTrue: [currentClassName] 41114 ifFalse: [currentClassName asSymbol]. 41115 newSelectors := myChangeSet selectorsInClass: probe. 41116 (newSelectors includes: currentSelector) ifFalse: [currentSelector := nil]. 41117 ^ newSelectors asSortedCollection 41118! ! 41119 41120!ChangeSorter methodsFor: 'message list' stamp: 'sw 3/9/2001 14:27'! 41121messageListMenu: aMenu shifted: shifted 41122 "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" 41123 41124 ^ self messageMenu: aMenu shifted: shifted! ! 41125 41126!ChangeSorter methodsFor: 'message list' stamp: 'alain.plantec 5/30/2008 11:03'! 41127messageMenu: aMenu shifted: shifted 41128 "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" 41129 41130 shifted ifTrue: [^ self shiftedMessageMenu: aMenu]. 41131 41132 aMenu title: 'message list'. 41133 aMenu addStayUpItemSpecial. 41134 41135 parent ifNotNil: 41136 [aMenu addList: #( 41137 ('copy method to other side' copyMethodToOther) 41138 ('move method to other side' moveMethodToOther))]. 41139 41140 aMenu addList: #( 41141 ('delete method from changeSet (d)' forget) 41142 - 41143 ('remove method from system (x)' removeMessage) 41144 - 41145 ('browse full (b)' browseMethodFull) 41146 ('browse hierarchy (h)' spawnHierarchy) 41147 ('browse method (O)' openSingleMessageBrowser) 41148 ('browse protocol (p)' browseFullProtocol) 41149 - 41150 ('fileOut' fileOutMessage) 41151 - 41152 ('senders of... (n)' browseSendersOfMessages) 41153 ('implementors of... (m)' browseMessages) 41154 ('inheritance (i)' methodHierarchy) 41155 ('versions (v)' browseVersions) 41156 - 41157 ('more...' shiftedYellowButtonActivity)). 41158 ^ aMenu 41159! ! 41160 41161!ChangeSorter methodsFor: 'message list' stamp: 'nk 7/30/2004 17:58'! 41162moveMethodToOther 41163 "Place this change in the other changeSet and remove it from this side" 41164 41165 | other cls sel | 41166 self checkThatSidesDiffer: [^self]. 41167 self okToChange ifFalse: [^Beeper beep]. 41168 currentSelector ifNotNil: 41169 [other := (parent other: self) changeSet. 41170 other == myChangeSet ifTrue: [^Beeper beep]. 41171 cls := self selectedClassOrMetaClass. 41172 sel := currentSelector asSymbol. 41173 other 41174 absorbMethod: sel 41175 class: cls 41176 from: myChangeSet. 41177 (parent other: self) showChangeSet: other. 41178 self forget "removes the method from this side"]! ! 41179 41180!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'! 41181removeFromCurrentChanges 41182 "Redisplay after removal in case we are viewing the current changeSet" 41183 41184 super removeFromCurrentChanges. 41185 currentSelector := nil. 41186 self showChangeSet: myChangeSet! ! 41187 41188!ChangeSorter methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'! 41189removeMessage 41190 "Remove the selected msg from the system. Real work done by the 41191 parent, a ChangeSorter" 41192 | confirmation sel | 41193 self okToChange 41194 ifFalse: [^ self]. 41195 currentSelector 41196 ifNotNil: [confirmation := self systemNavigation confirmRemovalOf: (sel := self selectedMessageName) on: self selectedClassOrMetaClass. 41197 confirmation == 3 41198 ifTrue: [^ self]. 41199 self selectedClassOrMetaClass removeSelector: sel. 41200 self update. 41201 confirmation == 2 41202 ifTrue: [self systemNavigation browseAllCallsOn: sel]]! ! 41203 41204!ChangeSorter methodsFor: 'message list' stamp: 'jm 5/4/1998 07:32'! 41205selectedMessageName 41206 41207 currentSelector ifNil: [^ nil]. 41208 ^ currentSelector asSymbol! ! 41209 41210!ChangeSorter methodsFor: 'message list' stamp: 'marcus.denker 9/20/2008 20:19'! 41211shiftedMessageMenu: aMenu 41212 "Arm the menu so that it holds items appropriate to the message-list while the shift key is down. Answer the menu." 41213 41214 ^ aMenu addList: #( 41215 - 41216 ('toggle diffing (D)' toggleDiffing) 41217 ('implementors of sent messages' browseAllMessages) 41218 ('change category...' changeCategory) 41219 - 41220 ('sample instance' makeSampleInstance) 41221 ('inspect instances' inspectInstances) 41222 ('inspect subinstances' inspectSubInstances) 41223 - 41224 ('change sets with this method' findMethodInChangeSets) 41225 ('revert to previous version' revertToPreviousVersion) 41226 ('revert & remove from changes' revertAndForget) 41227 - 41228 ('more...' unshiftedYellowButtonActivity))! ! 41229 41230 41231!ChangeSorter methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 20:32'! 41232buildWith: builder 41233 " 41234 MorphicUIBuilder open: ChangeSorter. 41235 " 41236 | windowSpec | 41237 windowSpec := builder pluggableWindowSpec new. 41238 windowSpec label: 'Change Sorter'. 41239 windowSpec model: self. 41240 windowSpec children: OrderedCollection new. 41241 self buildWith: builder in: windowSpec rect: (0@0 extent: 1@1). 41242 ^builder build: windowSpec! ! 41243 41244!ChangeSorter methodsFor: 'toolbuilder' stamp: 'sd 11/20/2005 21:26'! 41245buildWith: builder in: window rect: rect 41246 | csListHeight msgListHeight csMsgListHeight listSpec textSpec | 41247 contents := ''. 41248 csListHeight := 0.25. 41249 msgListHeight := 0.25. 41250 csMsgListHeight := csListHeight + msgListHeight. 41251 41252 listSpec := builder pluggableListSpec new. 41253 listSpec 41254 model: self; 41255 list: #changeSetList; 41256 getSelected: #currentCngSet; 41257 setSelected: #showChangeSetNamed:; 41258 menu: #changeSetMenu:shifted:; 41259 keyPress: #changeSetListKey:from:; 41260 autoDeselect: false; 41261 frame: (((0@0 extent: 0.5@csListHeight) 41262 scaleBy: rect extent) translateBy: rect origin). 41263 window children add: listSpec. 41264 41265 listSpec := builder pluggableListSpec new. 41266 listSpec 41267 model: self; 41268 list: #classList; 41269 getSelected: #currentClassName; 41270 setSelected: #currentClassName:; 41271 menu: #classListMenu:shifted:; 41272 keyPress: #classListKey:from:; 41273 frame: (((0.5@0 extent: 0.5@csListHeight) 41274 scaleBy: rect extent) translateBy: rect origin). 41275 window children add: listSpec. 41276 41277 listSpec := builder pluggableListSpec new. 41278 listSpec 41279 model: self; 41280 list: #messageList; 41281 getSelected: #currentSelector; 41282 setSelected: #currentSelector:; 41283 menu: #messageMenu:shifted:; 41284 keyPress: #messageListKey:from:; 41285 frame: (((0@csListHeight extent: 1@msgListHeight) 41286 scaleBy: rect extent) translateBy: rect origin). 41287 window children add: listSpec. 41288 41289 textSpec := builder pluggableTextSpec new. 41290 textSpec 41291 model: self; 41292 getText: #contents; 41293 setText: #contents:notifying:; 41294 selection: #contentsSelection; 41295 menu: #codePaneMenu:shifted:; 41296 frame: (((0@csMsgListHeight corner: 1@1) scaleBy: rect extent) translateBy: rect origin). 41297 window children add: textSpec. 41298 ^window! ! 41299 41300 41301!ChangeSorter methodsFor: 'traits' stamp: 'al 7/18/2004 11:44'! 41302selectedClassOrMetaClass 41303 "Careful, the class may have been removed!!" 41304 41305 | cName tName | 41306 currentClassName ifNil: [^ nil]. 41307 (currentClassName endsWith: ' class') 41308 ifTrue: [cName := (currentClassName copyFrom: 1 to: currentClassName size-6) asSymbol. 41309 ^ (Smalltalk at: cName ifAbsent: [^nil]) class]. 41310 (currentClassName endsWith: ' classTrait') 41311 ifTrue: [tName := (currentClassName copyFrom: 1 to: currentClassName size-11) asSymbol. 41312 ^ (Smalltalk at: tName ifAbsent: [^nil]) classTrait]. 41313 cName := currentClassName asSymbol. 41314 ^ Smalltalk at: cName ifAbsent: [nil]! ! 41315 41316"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 41317 41318ChangeSorter class 41319 instanceVariableNames: ''! 41320 41321!ChangeSorter class methodsFor: 'browse' stamp: 'sd 11/20/2005 21:28'! 41322browseChangeSetsWithClass: class selector: selector 41323 "Put up a menu comprising a list of change sets that hold changes for the given class and selector. If the user selects one, open a single change-sorter onto it" 41324 41325 | hits index | 41326 hits := self allChangeSets select: 41327 [:cs | (cs atSelector: selector class: class) ~~ #none]. 41328 hits isEmpty ifTrue: [^ self inform: class name, '.', selector , ' 41329is not in any change set']. 41330 index := hits size == 1 41331 ifTrue: [1] 41332 ifFalse: [(UIManager default chooseFrom: (hits collect: [:cs | cs name]) 41333 lines: #())]. 41334 index = 0 ifTrue: [^ self]. 41335 (ChangeSorter new myChangeSet: (hits at: index)) open. 41336! ! 41337 41338!ChangeSorter class methodsFor: 'browse' stamp: 'sd 11/20/2005 21:28'! 41339browseChangeSetsWithSelector: aSelector 41340 "Put up a list of all change sets that contain an addition, deletion, or change of any method with the given selector" 41341 41342 | hits index | 41343 hits := self allChangeSets select: 41344 [:cs | cs hasAnyChangeForSelector: aSelector]. 41345 hits isEmpty ifTrue: [^ self inform: aSelector , ' 41346is not in any change set']. 41347 index := hits size == 1 41348 ifTrue: [1] 41349 ifFalse: [(UIManager default chooseFrom: (hits collect: [:cs | cs name]) 41350 lines: #())]. 41351 index = 0 ifTrue: [^ self]. 41352 (ChangeSetBrowser new myChangeSet: (hits at: index)) open 41353 41354"ChangeSorter browseChangeSetsWithSelector: #clearPenTrails" 41355! ! 41356 41357 41358!ChangeSorter class methodsFor: 'class initialization' stamp: 'pk 10/17/2006 09:10'! 41359initialize 41360 "ChangeSorter initialize" 41361 41362 FileList registerFileReader: self. 41363 41364 self registerInFlapsRegistry. 41365! ! 41366 41367 41368!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 08:59'! 41369allChangeSetNames 41370 41371 ^ ChangesOrganizer allChangeSetNames! ! 41372 41373!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:00'! 41374allChangeSets 41375 41376 ^ ChangesOrganizer allChangeSets! ! 41377 41378!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:12'! 41379allChangeSetsWithClass: class selector: selector 41380 41381 ^ ChangesOrganizer allChangeSetsWithClass: class selector: selector! ! 41382 41383!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:19'! 41384assuredChangeSetNamed: aName 41385 41386 ^ ChangesOrganizer assuredChangeSetNamed: aName! ! 41387 41388!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:01'! 41389basicNewChangeSet: newName 41390 41391 ^ ChangesOrganizer basicNewChangeSet: newName! ! 41392 41393!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:03'! 41394belongsInAdditions: aChangeSet 41395 41396 ^ ChangesOrganizer belongsInAdditions: aChangeSet! ! 41397 41398!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:03'! 41399belongsInAll: aChangeSet 41400 41401 ^ ChangesOrganizer belongsInAll: aChangeSet! ! 41402 41403!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:03'! 41404belongsInMyInitials: aChangeSet 41405 41406 ^ ChangesOrganizer belongsInMyInitials: aChangeSet! ! 41407 41408!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:04'! 41409belongsInNumbered: aChangeSet 41410 41411 ^ ChangesOrganizer belongsInNumbered: aChangeSet! ! 41412 41413!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:06'! 41414belongsInProjectsInRelease: aChangeSet 41415 41416 ^ ChangesOrganizer belongsInProjectsInRelease: aChangeSet! ! 41417 41418!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:06'! 41419belongsInRecentUpdates: aChangeSet 41420 41421 ^ ChangesOrganizer belongsInRecentUpdates: aChangeSet! ! 41422 41423!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:20'! 41424buildAggregateChangeSet 41425 41426 ^ ChangesOrganizer buildAggregateChangeSet 41427 41428 ! ! 41429 41430!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:12'! 41431changeSet: aChangeSet containsClass: aClass 41432 41433 ^ ChangesOrganizer changeSet: aChangeSet containsClass: aClass! ! 41434 41435!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:07'! 41436changeSetCategoryNamed: aName 41437 41438 ^ ChangesOrganizer changeSetCategoryNamed: aName! ! 41439 41440!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:12'! 41441changeSetNamed: aName 41442 41443 ^ ChangesOrganizer changeSetNamed: aName! ! 41444 41445!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:07'! 41446changeSetNamesInReleaseImage 41447 41448 ^ ChangesOrganizer changeSetNamesInReleaseImage! ! 41449 41450!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:08'! 41451changeSetNamesInThreeOh 41452 41453 ^ ChangesOrganizer changeSetNamesInThreeOh! ! 41454 41455!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:12'! 41456changeSetsNamedSuchThat: nameBlock 41457 41458 ^ ChangesOrganizer changeSetsNamedSuchThat: nameBlock! ! 41459 41460!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:20'! 41461countOfChangeSetsWithClass: aClass andSelector: aSelector 41462 41463 ^ ChangesOrganizer countOfChangeSetsWithClass: aClass andSelector: aSelector! ! 41464 41465!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:16'! 41466deleteChangeSetsNumberedLowerThan: anInteger 41467 41468 ^ ChangesOrganizer deleteChangeSetsNumberedLowerThan: anInteger! ! 41469 41470!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:21'! 41471doesAnyChangeSetHaveClass: aClass andSelector: aSelector 41472 41473 ^ ChangesOrganizer doesAnyChangeSetHaveClass: aClass andSelector: aSelector! ! 41474 41475!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:13'! 41476existingOrNewChangeSetNamed: aName 41477 41478 ^ ChangesOrganizer existingOrNewChangeSetNamed: aName! ! 41479 41480!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:23'! 41481fileOutChangeSetsNamed: nameList 41482 41483 ^ ChangesOrganizer fileOutChangeSetsNamed: nameList! ! 41484 41485!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:13'! 41486gatherChangeSets 41487 41488 ^ ChangesOrganizer gatherChangeSets! ! 41489 41490!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:13'! 41491highestNumberedChangeSet 41492 41493 ^ ChangesOrganizer highestNumberedChangeSet 41494! ! 41495 41496!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:10'! 41497initializeChangeSetCategories 41498 41499 ^ ChangesOrganizer initializeChangeSetCategories! ! 41500 41501!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:13'! 41502mostRecentChangeSetWithChangeForClass: class selector: selector 41503 41504 ^ ChangesOrganizer mostRecentChangeSetWithChangeForClass: class selector: selector! ! 41505 41506!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:01'! 41507newChangeSet 41508 41509 ^ ChangesOrganizer newChangeSet! ! 41510 41511!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:02'! 41512newChangeSet: aName 41513 41514 ^ ChangesOrganizer newChangeSet: aName! ! 41515 41516!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:02'! 41517newChangesFromStream: aStream named: aName 41518 41519 ^ ChangesOrganizer newChangesFromStream: aStream named: aName! ! 41520 41521!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:14'! 41522promoteToTop: aChangeSet 41523 41524 ^ ChangesOrganizer promoteToTop: aChangeSet! ! 41525 41526!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:21'! 41527recentUpdateMarker 41528 41529 ^ ChangesOrganizer recentUpdateMarker! ! 41530 41531!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:22'! 41532recentUpdateMarker: aNumber 41533 41534 ^ ChangesOrganizer recentUpdateMarker: aNumber! ! 41535 41536!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:16'! 41537removeChangeSet: aChangeSet 41538 41539 ^ ChangesOrganizer removeChangeSet: aChangeSet! ! 41540 41541!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:17'! 41542removeChangeSetsNamedSuchThat: nameBlock 41543 41544 ^ ChangesOrganizer removeChangeSetsNamedSuchThat: nameBlock! ! 41545 41546!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:17'! 41547removeEmptyUnnamedChangeSets 41548 41549 ^ ChangesOrganizer removeEmptyUnnamedChangeSets! ! 41550 41551!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:22'! 41552reorderChangeSets 41553 41554 ^ ChangesOrganizer reorderChangeSets! ! 41555 41556!ChangeSorter class methodsFor: 'deprecated' stamp: 'pk 10/17/2006 09:22'! 41557secondaryChangeSet 41558 41559 ^ ChangesOrganizer secondaryChangeSet! ! 41560 41561 41562!ChangeSorter class methodsFor: 'initialization' stamp: 'asm 4/10/2003 12:42'! 41563registerInFlapsRegistry 41564 "Register the receiver in the system's flaps registry" 41565 self environment 41566 at: #Flaps 41567 ifPresent: [:cl | cl registerQuad: #(ChangeSorter prototypicalToolWindow 'Change Set' 'A tool that allows you to view and manipulate all the code changes in a single change set') 41568 forFlapNamed: 'Tools']! ! 41569 41570!ChangeSorter class methodsFor: 'initialization' stamp: 'ar 9/27/2005 19:56'! 41571unload 41572 "Unload the receiver from global registries" 41573 41574 self environment at: #FileList ifPresent: [:cl | 41575 cl unregisterFileReader: self]. 41576 self environment at: #Flaps ifPresent: [:cl | 41577 cl unregisterQuadsWithReceiver: self] ! ! 41578 41579 41580!ChangeSorter class methodsFor: 'services' stamp: 'sw 6/13/2001 00:56'! 41581prototypicalToolWindow 41582 "Answer a window representing a prototypical instance of the receiver" 41583 41584 ^ self new morphicWindow applyModelExtent! ! 41585 41586 41587!ChangeSorter class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:09'! 41588windowColorSpecification 41589 "Answer a WindowColorSpec object that declares my preference" 41590 41591 ^ WindowColorSpec classSymbol: self name wording: 'Change Sorter' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A tool that lets you see the code for one change set at a time.'! ! 41592MessageSet subclass: #ChangedMessageSet 41593 instanceVariableNames: 'changeSet' 41594 classVariableNames: '' 41595 poolDictionaries: '' 41596 category: 'Tools-Browser'! 41597!ChangedMessageSet commentStamp: '<historical>' prior: 0! 41598A ChangedMessageSet is a message set associated with a change-set; it bears an entry for every method added or changed in the change set, as well as for every class-comment of which the change-set bears a note.! 41599 41600 41601!ChangedMessageSet methodsFor: 'acceptance' stamp: 'md 2/20/2006 18:42'! 41602contents: aString notifying: aController 41603 "Accept the string as new source for the current method, and make certain the annotation pane gets invalidated" 41604 41605 | existingSelector existingClass superResult newSelector | 41606 existingSelector := self selectedMessageName. 41607 existingClass := self selectedClassOrMetaClass. 41608 41609 superResult := super contents: aString notifying: aController. 41610 superResult ifTrue: "succeeded" 41611 [newSelector := existingClass parserClass new parseSelector: aString. 41612 newSelector ~= existingSelector 41613 ifTrue: "Selector changed -- maybe an addition" 41614 [self reformulateList. 41615 self changed: #messageList. 41616 self messageList doWithIndex: 41617 [:aMethodReference :anIndex | 41618 (aMethodReference actualClass == existingClass and: 41619 [aMethodReference methodSymbol == newSelector]) 41620 ifTrue: 41621 [self messageListIndex: anIndex]]]]. 41622 ^ superResult! ! 41623 41624 41625!ChangedMessageSet methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! 41626changeSet: aChangeSet 41627 changeSet := aChangeSet! ! 41628 41629 41630!ChangedMessageSet methodsFor: 'message list' stamp: 'sw 1/28/2001 20:59'! 41631growable 41632 "Answer whether the receiver can be changed by manual additions & deletions" 41633 41634 ^ false! ! 41635 41636 41637!ChangedMessageSet methodsFor: 'reformulation' stamp: 'sw 6/26/2001 11:20'! 41638reformulateList 41639 "Reformulate the message list of the receiver" 41640 41641 self initializeMessageList: (changeSet changedMessageListAugmented select: 41642 [:each | each isValid]) 41643! ! 41644 41645"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 41646 41647ChangedMessageSet class 41648 instanceVariableNames: ''! 41649 41650!ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:28'! 41651openFor: aChangeSet 41652 "Open up a ChangedMessageSet browser on the given change set; this is a conventional message-list browser whose message-list consists of all the methods in aChangeSet. After any method submission, the message list is refigured, making it plausibly dynamic" 41653 41654 | messageSet | 41655 41656 messageSet := aChangeSet changedMessageListAugmented select: [ :each | each isValid]. 41657 self 41658 openMessageList: messageSet 41659 name: 'Methods in Change Set ', aChangeSet name 41660 autoSelect: nil 41661 changeSet: aChangeSet! ! 41662 41663!ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/30/2008 11:20'! 41664openMessageList: messageList name: labelString autoSelect: autoSelectString changeSet: aChangeSet 41665 | messageSet | 41666 41667 messageSet := self messageList: messageList. 41668 messageSet changeSet: aChangeSet. 41669 messageSet autoSelectString: autoSelectString. 41670 self openAsMorph: messageSet name: labelString! ! 41671Object subclass: #ChangesOrganizer 41672 instanceVariableNames: '' 41673 classVariableNames: 'ChangeSetCategories ChangeSetNamesInRelease RecentUpdateMarker' 41674 poolDictionaries: '' 41675 category: 'System-Changes'! 41676!ChangesOrganizer commentStamp: 'pk 10/17/2006 09:25' prior: 0! 41677Changes organizer! 41678 41679 41680"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 41681 41682ChangesOrganizer class 41683 instanceVariableNames: ''! 41684 41685!ChangesOrganizer class methodsFor: 'adding' stamp: 'pk 2/6/2006 09:49'! 41686basicNewChangeSet: newName 41687 ^ChangeSet basicNewChangeSet: newName! ! 41688 41689!ChangesOrganizer class methodsFor: 'adding' stamp: 'pk 2/6/2006 09:49'! 41690newChangeSet 41691 "Prompt the user for a name, and establish a new change set of 41692 that name (if ok), making it the current changeset. Return nil 41693 of not ok, else return the actual changeset." 41694 41695 | newName newSet | 41696 newName := UIManager default 41697 request: 'Please name the new change set:' 41698 initialAnswer: ChangeSet defaultName. 41699 newName isEmptyOrNil ifTrue: 41700 [^ nil]. 41701 newSet := self basicNewChangeSet: newName. 41702 newSet ifNotNil: 41703 [ChangeSet newChanges: newSet]. 41704 ^ newSet! ! 41705 41706!ChangesOrganizer class methodsFor: 'adding' stamp: 'MiguelCoba 7/25/2009 02:01'! 41707newChangeSet: aName 41708 "Makes a new change set called aName, add author full name to try to 41709 ensure a unique change set name." 41710 41711 | newName | 41712 newName := aName , FileDirectory dot , Author fullName. 41713 ^ self basicNewChangeSet: newName! ! 41714 41715!ChangesOrganizer class methodsFor: 'adding' stamp: 'pk 2/6/2006 09:49'! 41716newChangesFromStream: aStream named: aName 41717 ^ChangeSet newChangesFromStream: aStream named: aName 41718! ! 41719 41720 41721!ChangesOrganizer class methodsFor: 'class initialization' stamp: 'pk 2/6/2006 09:49'! 41722belongsInAdditions: aChangeSet 41723 "Answer whether a change set belongs in the Additions category, which is fed by all change sets that are neither numbered nor in the initial release" 41724 41725 ^ (((self belongsInProjectsInRelease: aChangeSet) or: 41726 [self belongsInNumbered: aChangeSet])) not! ! 41727 41728!ChangesOrganizer class methodsFor: 'class initialization' stamp: 'pk 2/6/2006 09:49'! 41729belongsInAll: aChangeSet 41730 "Answer whether a change set belongs in the All category" 41731 41732 ^ true ! ! 41733 41734!ChangesOrganizer class methodsFor: 'class initialization' stamp: 'MiguelCoba 7/25/2009 02:01'! 41735belongsInMyInitials: aChangeSet 41736 "Answer whether a change set belongs in the MyInitials category. " 41737 41738 ^ aChangeSet name endsWith: ('-', Author fullName)! ! 41739 41740!ChangesOrganizer class methodsFor: 'class initialization' stamp: 'pk 10/17/2006 09:04'! 41741belongsInNumbered: aChangeSet 41742 "Answer whether a change set belongs in the Numbered category. " 41743 41744 ^ aChangeSet name startsWithDigit! ! 41745 41746!ChangesOrganizer class methodsFor: 'class initialization' stamp: 'pk 2/6/2006 09:49'! 41747belongsInProjectsInRelease: aChangeSet 41748 "Answer whether a change set belongs in the ProjectsInRelease category. You can hand-tweak this to suit your working style. This just covers the space of project names in the 2.9, 3.0, and 3.1a systems" 41749 41750 | aString | 41751 ^ ((aString := aChangeSet name) beginsWith: 'Play With Me') or: [self changeSetNamesInReleaseImage includes: aString]! ! 41752 41753!ChangesOrganizer class methodsFor: 'class initialization' stamp: 'pk 2/6/2006 09:49'! 41754belongsInRecentUpdates: aChangeSet 41755 "Answer whether a change set belongs in the RecentUpdates category." 41756 41757 ^ aChangeSet name startsWithDigit and: 41758 [aChangeSet name asInteger >= self recentUpdateMarker]! ! 41759 41760!ChangesOrganizer class methodsFor: 'class initialization' stamp: 'pk 2/6/2006 09:49'! 41761changeSetCategoryNamed: aName 41762 "Answer the changeSetCategory of the given name, or nil if none" 41763 41764 ^ ChangeSetCategories elementAt: aName asSymbol ! ! 41765 41766!ChangesOrganizer class methodsFor: 'class initialization' stamp: 'pk 2/6/2006 09:49'! 41767changeSetNamesInReleaseImage 41768 "Answer a list of names of project change sets that come pre-shipped in the latest sytem release. On the brink of shipping a new release, call 'ChangeSorter noteChangeSetsInRelease' " 41769 41770 ^ ChangeSetNamesInRelease ifNil: 41771 [ChangeSetNamesInRelease := self changeSetNamesInThreeOh]! ! 41772 41773!ChangesOrganizer class methodsFor: 'class initialization' stamp: 'pk 2/6/2006 09:49'! 41774changeSetNamesInThreeOh 41775 "Hard-coded: answer a list of names of project change sets that came pre-shipped in Squeak 3.0" 41776 41777 ^ #('The Worlds of Squeak' 'Fun with Morphic' 'Games' 'Fun With Music' 'Building with Squeak' 'Squeak and the Internet' 'Squeak in 3D' 'More About Sound' ) ! ! 41778 41779!ChangesOrganizer class methodsFor: 'class initialization' stamp: 'pk 10/23/2008 16:41'! 41780initialization 41781 41782 "Initialize the class variables" 41783 ChangeSetCategories ifNil: 41784 [self initializeChangeSetCategories]. 41785 41786 RecentUpdateMarker := 0.! ! 41787 41788!ChangesOrganizer class methodsFor: 'class initialization' stamp: 'stephane.ducasse 7/10/2009 16:46'! 41789initializeChangeSetCategories 41790 "Initialize the set of change-set categories" 41791 "ChangesOrganizer initializeChangeSetCategories" 41792 41793 | aCategory | 41794 ChangeSetCategories := ElementCategory new categoryName: #ChangeSetCategories. 41795 41796 aCategory := ChangeSetCategory new categoryName: #All. 41797 aCategory membershipSelector: #belongsInAll:. 41798 aCategory documentation: 'All change sets known to the system'. 41799 ChangeSetCategories addCategoryItem: aCategory. 41800 41801 aCategory := ChangeSetCategory new categoryName: #Additions. 41802 aCategory membershipSelector: #belongsInAdditions:. 41803 aCategory documentation: 'All unnumbered change sets except those representing projects in the system as initially released.'. 41804 ChangeSetCategories addCategoryItem: aCategory. 41805 41806 aCategory := ChangeSetCategory new categoryName: #MyInitials. 41807 aCategory membershipSelector: #belongsInMyInitials:. 41808 aCategory documentation: 'All change sets whose names end with the current author''s initials.'. 41809 ChangeSetCategories addCategoryItem: aCategory. 41810 41811 aCategory := ChangeSetCategory new categoryName: #Numbered. 41812 aCategory membershipSelector: #belongsInNumbered:. 41813 aCategory documentation: 'All change sets whose names start with a digit -- normally these will be the official updates to the system.'. 41814 ChangeSetCategories addCategoryItem: aCategory. 41815 41816 aCategory := ChangeSetCategory new categoryName: #RecentUpdates. 41817 aCategory membershipSelector: #belongsInRecentUpdates:. 41818 aCategory documentation: 'Updates whose numbers are at or beyond the number I have designated as the earliest one to qualify as Recent'. 41819 ChangeSetCategories addCategoryItem: aCategory. 41820 41821 ChangeSetCategories elementsInOrder do: [:anElem | anElem reconstituteList] ! ! 41822 41823 41824!ChangesOrganizer class methodsFor: 'enumerating' stamp: 'pk 2/6/2006 09:49'! 41825allChangeSetNames 41826 ^ self allChangeSets collect: [:c | c name]! ! 41827 41828!ChangesOrganizer class methodsFor: 'enumerating' stamp: 'pk 2/6/2006 09:49'! 41829allChangeSets 41830 "Return the list of all current ChangeSets" 41831 41832 ^ChangeSet allChangeSets! ! 41833 41834!ChangesOrganizer class methodsFor: 'enumerating' stamp: 'pk 2/6/2006 09:49'! 41835allChangeSetsWithClass: class selector: selector 41836 class ifNil: [^ #()]. 41837 ^ self allChangeSets select: 41838 [:cs | (cs atSelector: selector class: class) ~~ #none]! ! 41839 41840!ChangesOrganizer class methodsFor: 'enumerating' stamp: 'pk 2/6/2006 09:49'! 41841changeSet: aChangeSet containsClass: aClass 41842 | theClass | 41843 theClass := Smalltalk classNamed: aClass. 41844 theClass ifNil: [^ false]. 41845 ^ aChangeSet containsClass: theClass! ! 41846 41847!ChangesOrganizer class methodsFor: 'enumerating' stamp: 'pk 2/6/2006 09:49'! 41848changeSetNamed: aName 41849 "Return the change set of the given name, or nil if none found. 1/22/96 sw" 41850 ^ChangeSet named: aName! ! 41851 41852!ChangesOrganizer class methodsFor: 'enumerating' stamp: 'pk 2/6/2006 09:49'! 41853changeSetsNamedSuchThat: nameBlock 41854 ^ChangeSet changeSetsNamedSuchThat: nameBlock! ! 41855 41856!ChangesOrganizer class methodsFor: 'enumerating' stamp: 'pk 2/6/2006 09:49'! 41857existingOrNewChangeSetNamed: aName 41858 ^ChangeSet existingOrNewChangeSetNamed: aName! ! 41859 41860!ChangesOrganizer class methodsFor: 'enumerating' stamp: 'pk 10/23/2008 16:30'! 41861gatherChangeSets 41862 41863 "ChangesOrganizer gatherChangeSets" 41864 41865 ^ ChangeSet gatherChangeSets! ! 41866 41867!ChangesOrganizer class methodsFor: 'enumerating' stamp: 'pk 10/23/2008 16:28'! 41868highestNumberedChangeSet 41869 "ChangesOrganizer highestNumberedChangeSet" 41870 | aList | 41871 aList := (ChangeSet allChangeSetNames select: [:aString | aString startsWithDigit] thenCollect: 41872 [:aString | aString initialIntegerOrNil]). 41873 ^ (aList size > 0) 41874 ifTrue: 41875 [aList max] 41876 ifFalse: 41877 [nil] 41878! ! 41879 41880!ChangesOrganizer class methodsFor: 'enumerating' stamp: 'pk 2/6/2006 09:49'! 41881mostRecentChangeSetWithChangeForClass: class selector: selector 41882 | hits | 41883 hits := self allChangeSets select: 41884 [:cs | (cs atSelector: selector class: class) ~~ #none]. 41885 hits isEmpty ifTrue: [^ 'not in any change set']. 41886 ^ 'recent cs: ', hits last name! ! 41887 41888!ChangesOrganizer class methodsFor: 'enumerating' stamp: 'pk 2/6/2006 09:49'! 41889promoteToTop: aChangeSet 41890 "Make aChangeSet the first in the list from now on" 41891 ^ChangeSet promoteToTop: aChangeSet! ! 41892 41893 41894!ChangesOrganizer class methodsFor: 'removing' stamp: 'pk 2/6/2006 09:49'! 41895deleteChangeSetsNumberedLowerThan: anInteger 41896 "Delete all changes sets whose names start with integers smaller than anInteger" 41897 41898 self removeChangeSetsNamedSuchThat: 41899 [:aName | aName first isDigit and: [aName initialIntegerOrNil < anInteger]]. 41900 41901 "ChangesOrganizer deleteChangeSetsNumberedLowerThan: (ChangeSorter highestNumberedChangeSet name initialIntegerOrNil - 500)" 41902! ! 41903 41904!ChangesOrganizer class methodsFor: 'removing' stamp: 'pk 2/6/2006 09:49'! 41905removeChangeSet: aChangeSet 41906 "Remove the given changeSet. Caller must assure that it's cool to do this" 41907 ^ChangeSet removeChangeSet: aChangeSet! ! 41908 41909!ChangesOrganizer class methodsFor: 'removing' stamp: 'pk 2/6/2006 09:49'! 41910removeChangeSetsNamedSuchThat: nameBlock 41911 (self changeSetsNamedSuchThat: nameBlock) 41912 do: [:cs | self removeChangeSet: cs]! ! 41913 41914!ChangesOrganizer class methodsFor: 'removing' stamp: 'pk 10/23/2008 15:57'! 41915removeEmptyUnnamedChangeSets 41916 "Remove all change sets that are empty, whose names start with Unnamed, 41917 and which are not nailed down by belonging to a Project." 41918 "ChangesOrganizer removeEmptyUnnamedChangeSets" 41919 | toGo | 41920 (toGo := (self changeSetsNamedSuchThat: [:csName | csName beginsWith: 'Unnamed']) 41921 select: [:cs | cs isEmpty and: [cs okayToRemoveInforming: false]]) 41922 do: [:cs | self removeChangeSet: cs]. 41923 self inform: toGo size printString, ' change set(s) removed.'! ! 41924 41925 41926!ChangesOrganizer class methodsFor: 'services' stamp: 'pk 2/6/2006 09:49'! 41927assuredChangeSetNamed: aName 41928 "Answer a change set of the given name. If one already exists, answer that, else create a new one and answer it." 41929 41930 | existing | 41931 ^ (existing := self changeSetNamed: aName) 41932 ifNotNil: 41933 [existing] 41934 ifNil: 41935 [self basicNewChangeSet: aName]! ! 41936 41937!ChangesOrganizer class methodsFor: 'services' stamp: 'pk 10/23/2008 16:29'! 41938buildAggregateChangeSet 41939 "Establish a change-set named Aggregate which bears the union of all the changes in all the existing change-sets in the system (other than any pre-existing Aggregate). This can be useful when wishing to discover potential conflicts between a disk-resident change-set and an image. Formerly very useful, now some of its unique contributions have been overtaken by new features" 41940 41941 | aggregateChangeSet | 41942 aggregateChangeSet := self existingOrNewChangeSetNamed: 'Aggregate'. 41943 aggregateChangeSet clear. 41944 self allChangeSets do: 41945 [:aChangeSet | aChangeSet == aggregateChangeSet ifFalse: 41946 [aggregateChangeSet assimilateAllChangesFoundIn: aChangeSet]] 41947 41948"ChangesOrganizer buildAggregateChangeSet" 41949 41950 ! ! 41951 41952!ChangesOrganizer class methodsFor: 'services' stamp: 'pk 2/6/2006 09:49'! 41953countOfChangeSetsWithClass: aClass andSelector: aSelector 41954 "Answer how many change sets record a change for the given class and selector" 41955 41956 ^ (self allChangeSetsWithClass: aClass selector: aSelector) size! ! 41957 41958!ChangesOrganizer class methodsFor: 'services' stamp: 'pk 2/6/2006 09:49'! 41959doesAnyChangeSetHaveClass: aClass andSelector: aSelector 41960 "Answer whether any known change set bears a change for the given class and selector" 41961 41962 ^ (self countOfChangeSetsWithClass: aClass andSelector: aSelector) > 0! ! 41963 41964!ChangesOrganizer class methodsFor: 'services' stamp: 'pk 2/6/2006 09:49'! 41965recentUpdateMarker 41966 "Answer the number representing the threshold of what counts as 'recent' for an update number. This allow you to use the RecentUpdates category in a ChangeSorter to advantage" 41967 41968 ^ RecentUpdateMarker ifNil: [RecentUpdateMarker := 0]! ! 41969 41970!ChangesOrganizer class methodsFor: 'services' stamp: 'pk 2/6/2006 09:49'! 41971recentUpdateMarker: aNumber 41972 "Set the recent update marker as indicated" 41973 41974 ^ RecentUpdateMarker := aNumber! ! 41975 41976!ChangesOrganizer class methodsFor: 'services' stamp: 'hfm 9/30/2009 04:03'! 41977reorderChangeSets 41978 "Change the order of the change sets to something more convenient: 41979 First come the project changesets that come with the release. These are mostly empty. 41980 Next come all numbered updates. 41981 Next come all remaining changesets 41982 In a ChangeSorter, they will appear in the reversed order." 41983 41984 "ChangesOrganizer reorderChangeSets" 41985 41986 | newHead newMid newTail | 41987 newHead := OrderedCollection new. 41988 newMid := OrderedCollection new. 41989 newTail := OrderedCollection new. 41990 ChangeSet allChangeSets do: 41991 [:aChangeSet | 41992 (self belongsInProjectsInRelease: aChangeSet) 41993 ifTrue: 41994 [newHead add: aChangeSet] 41995 ifFalse: 41996 [(self belongsInNumbered: aChangeSet) 41997 ifTrue: 41998 [newMid add: aChangeSet] 41999 ifFalse: 42000 [newTail add: aChangeSet]]]. 42001 ChangeSet allChangeSets: newHead, newMid, newTail. 42002 SystemWindow wakeUpTopWindowUponStartup! ! 42003 42004!ChangesOrganizer class methodsFor: 'services' stamp: 'pk 2/6/2006 09:49'! 42005secondaryChangeSet 42006 ^ChangeSet secondaryChangeSet! ! 42007 42008 42009!ChangesOrganizer class methodsFor: 'utilities' stamp: 'pk 10/23/2008 16:28'! 42010fileOutChangeSetsNamed: nameList 42011 "File out the list of change sets whose names are provided" 42012 "ChangesOrganizer fileOutChangeSetsNamed: #('New Changes' 'miscTidies-sw')" 42013 42014 | notFound aChangeSet infoString empty | 42015 notFound := OrderedCollection new. 42016 empty := OrderedCollection new. 42017 nameList do: 42018 [:aName | (aChangeSet := self changeSetNamed: aName) 42019 ifNotNil: 42020 [aChangeSet isEmpty 42021 ifTrue: 42022 [empty add: aName] 42023 ifFalse: 42024 [aChangeSet fileOut]] 42025 ifNil: 42026 [notFound add: aName]]. 42027 42028 infoString := (nameList size - notFound size) printString, ' change set(s) filed out'. 42029 notFound size > 0 ifTrue: 42030 [infoString := infoString, ' 42031 42032', notFound size printString, ' change set(s) not found:'. 42033 notFound do: 42034 [:aName | infoString := infoString, ' 42035', aName]]. 42036 empty size > 0 ifTrue: 42037 [infoString := infoString, ' 42038', empty size printString, ' change set(s) were empty:'. 42039 empty do: 42040 [:aName | infoString := infoString, ' 42041', aName]]. 42042 42043 self inform: infoString! ! 42044Magnitude subclass: #Character 42045 instanceVariableNames: 'value' 42046 classVariableNames: 'CharacterTable ClassificationTable LetterBits LowercaseBit UppercaseBit' 42047 poolDictionaries: '' 42048 category: 'Collections-Strings'! 42049!Character commentStamp: 'ar 4/9/2005 22:35' prior: 0! 42050I represent a character by storing its associated Unicode. The first 256 characters are created uniquely, so that all instances of latin1 characters ($R, for example) are identical. 42051 42052 The code point is based on Unicode. Since Unicode is 21-bit wide character set, we have several bits available for other information. As the Unicode Standard states, a Unicode code point doesn't carry the language information. This is going to be a problem with the languages so called CJK (Chinese, Japanese, Korean. Or often CJKV including Vietnamese). Since the characters of those languages are unified and given the same code point, it is impossible to display a bare Unicode code point in an inspector or such tools. To utilize the extra available bits, we use them for identifying the languages. Since the old implementation uses the bits to identify the character encoding, the bits are sometimes called "encoding tag" or neutrally "leading char", but the bits rigidly denotes the concept of languages. 42053 42054 The other languages can have the language tag if you like. This will help to break the large default font (font set) into separately loadable chunk of fonts. However, it is open to the each native speakers and writers to decide how to define the character equality, since the same Unicode code point may have different language tag thus simple #= comparison may return false. 42055 42056I represent a character by storing its associated ASCII code (extended to 256 codes). My instances are created uniquely, so that all instances of a character ($R, for example) are identical.! 42057 42058 42059!Character methodsFor: '*packageinfo-base' stamp: 'ab 5/31/2003 17:15'! 42060escapeEntities 42061 #($< '<' $> '>' $& '&') pairsDo: 42062 [:k :v | 42063 self = k ifTrue: [^ v]]. 42064 ^ String with: self! ! 42065 42066 42067!Character methodsFor: '*splitjoin' stamp: 'onierstrasz 4/10/2009 22:51'! 42068join: aSequenceableCollection 42069 ^ self asString join: aSequenceableCollection 42070! ! 42071 42072 42073!Character methodsFor: '*vb-regex' stamp: 'avi 11/30/2003 13:31'! 42074isAlphabetic 42075 ^ self isLetter! ! 42076 42077 42078!Character methodsFor: 'accessing'! 42079asciiValue 42080 "Answer the value of the receiver that represents its ascii encoding." 42081 42082 ^value! ! 42083 42084!Character methodsFor: 'accessing' stamp: 'yo 12/29/2002 10:11'! 42085charCode 42086 42087 ^ (value bitAnd: 16r3FFFFF). 42088! ! 42089 42090!Character methodsFor: 'accessing' stamp: 'GabrielOmarCotelli 5/25/2009 16:04'! 42091codePoint 42092 42093 ^value! ! 42094 42095!Character methodsFor: 'accessing' stamp: 'yo 12/1/2003 19:30'! 42096digitValue 42097 "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 42098 otherwise. This is used to parse literal numbers of radix 2-36." 42099 42100 ^ (EncodedCharSet charsetAt: self leadingChar) digitValue: self. 42101! ! 42102 42103!Character methodsFor: 'accessing' stamp: 'yo 12/29/2002 10:14'! 42104leadingChar 42105 42106 ^ (value bitAnd: (16r3FC00000)) bitShift: -22. 42107! ! 42108 42109 42110!Character methodsFor: 'comparing' stamp: 'md 8/2/2005 18:21'! 42111sameAs: aCharacter 42112 "Answer whether the receiver is equal to aCharacter, ignoring case" 42113 ^ (self asLowercase = aCharacter asLowercase) ! ! 42114 42115!Character methodsFor: 'comparing'! 42116< aCharacter 42117 "Answer true if the receiver's value < aCharacter's value." 42118 42119 ^self asciiValue < aCharacter asciiValue! ! 42120 42121!Character methodsFor: 'comparing' stamp: 'ar 4/9/2005 21:48'! 42122= aCharacter 42123 "Primitive. Answer true if the receiver and the argument are the same 42124 object (have the same object pointer) and false otherwise. Optional. See 42125 Object documentation whatIsAPrimitive." 42126 42127 ^ self == aCharacter or:[ 42128 aCharacter isCharacter and: [self asciiValue = aCharacter asciiValue]]! ! 42129 42130!Character methodsFor: 'comparing'! 42131> aCharacter 42132 "Answer true if the receiver's value > aCharacter's value." 42133 42134 ^self asciiValue > aCharacter asciiValue! ! 42135 42136!Character methodsFor: 'comparing'! 42137hash 42138 "Hash is reimplemented because = is implemented." 42139 42140 ^value! ! 42141 42142 42143!Character methodsFor: 'converting'! 42144asCharacter 42145 "Answer the receiver itself." 42146 42147 ^self! ! 42148 42149!Character methodsFor: 'converting' stamp: 'ls 9/5/1998 01:18'! 42150asIRCLowercase 42151 "convert to lowercase, using IRC's rules" 42152 42153 self == $[ ifTrue: [ ^ ${ ]. 42154 self == $] ifTrue: [ ^ $} ]. 42155 self == $\ ifTrue: [ ^ $| ]. 42156 42157 ^self asLowercase! ! 42158 42159!Character methodsFor: 'converting'! 42160asInteger 42161 "Answer the value of the receiver." 42162 42163 ^value! ! 42164 42165!Character methodsFor: 'converting' stamp: 'yo 8/16/2004 11:35'! 42166asLowercase 42167 "If the receiver is uppercase, answer its matching lowercase Character." 42168 "A tentative implementation. Eventually this should consult the Unicode table." 42169 42170 | v | 42171 v := self charCode. 42172 (((8r101 <= v and: [v <= 8r132]) or: [16rC0 <= v and: [v <= 16rD6]]) or: [16rD8 <= v and: [v <= 16rDE]]) 42173 ifTrue: [^ Character value: value + 8r40] 42174 ifFalse: [^ self]! ! 42175 42176!Character methodsFor: 'converting' stamp: 'sma 3/11/2000 17:21'! 42177asString 42178 ^ String with: self! ! 42179 42180!Character methodsFor: 'converting' stamp: 'raa 5/26/2001 09:54'! 42181asSymbol 42182 "Answer a Symbol consisting of the receiver as the only element." 42183 42184 ^Symbol internCharacter: self! ! 42185 42186!Character methodsFor: 'converting' stamp: 'tk 9/4/2000 12:05'! 42187asText 42188 ^ self asString asText! ! 42189 42190!Character methodsFor: 'converting' stamp: 'ar 4/9/2005 21:51'! 42191asUnicode 42192 42193 | table charset v | 42194 self leadingChar = 0 ifTrue: [^ value]. 42195 charset := EncodedCharSet charsetAt: self leadingChar. 42196 charset isCharset ifFalse: [^ self charCode]. 42197 table := charset ucsTable. 42198 table isNil ifTrue: [^ 16rFFFD]. 42199 42200 v := table at: self charCode + 1. 42201 v = -1 ifTrue: [^ 16rFFFD]. 42202 42203 ^ v. 42204! ! 42205 42206!Character methodsFor: 'converting' stamp: 'yo 8/16/2004 11:34'! 42207asUppercase 42208 "If the receiver is lowercase, answer its matching uppercase Character." 42209 "A tentative implementation. Eventually this should consult the Unicode table." 42210 42211 | v | 42212 v := self charCode. 42213 (((8r141 <= v and: [v <= 8r172]) or: [16rE0 <= v and: [v <= 16rF6]]) or: [16rF8 <= v and: [v <= 16rFE]]) 42214 ifTrue: [^ Character value: value - 8r40] 42215 ifFalse: [^ self] 42216! ! 42217 42218!Character methodsFor: 'converting' stamp: 'yo 8/11/2003 21:18'! 42219basicSqueakToIso 42220 | asciiValue | 42221 42222 value < 128 ifTrue: [^ self]. 42223 value > 255 ifTrue: [^ self]. 42224 asciiValue := #(196 197 199 201 209 214 220 225 224 226 228 227 229 231 233 232 234 235 237 236 238 239 241 243 242 244 246 245 250 249 251 252 134 176 162 163 167 149 182 223 174 169 153 180 168 128 198 216 129 177 138 141 165 181 142 143 144 154 157 170 186 158 230 248 191 161 172 166 131 173 178 171 187 133 160 192 195 213 140 156 150 151 147 148 145 146 247 179 253 159 185 164 139 155 188 189 135 183 130 132 137 194 202 193 203 200 205 206 207 204 211 212 190 210 218 219 217 208 136 152 175 215 221 222 184 240 254 255 256 ) at: self asciiValue - 127. 42225 ^ Character value: asciiValue. 42226! ! 42227 42228!Character methodsFor: 'converting' stamp: 'michael.rueger 2/5/2009 17:02'! 42229macRomanToUnicode 42230 "Convert the receiver from MacRoman Unicode." 42231 42232 ^MacRomanTextConverter new unicodeToByte: self! ! 42233 42234!Character methodsFor: 'converting'! 42235to: other 42236 "Answer with a collection in ascii order -- $a to: $z" 42237 ^ (self asciiValue to: other asciiValue) collect: 42238 [:ascii | Character value: ascii]! ! 42239 42240!Character methodsFor: 'converting' stamp: 'michael.rueger 2/5/2009 17:01'! 42241unicodeToMacRoman 42242 "Convert the receiver from Unicode to MacRoman encoding." 42243 42244 ^MacRomanTextConverter new byteToUnicode: self! ! 42245 42246 42247!Character methodsFor: 'copying' stamp: 'tk 12/9/2000 11:46'! 42248clone 42249 "Answer with the receiver, because Characters are unique."! ! 42250 42251!Character methodsFor: 'copying'! 42252copy 42253 "Answer with the receiver because Characters are unique."! ! 42254 42255!Character methodsFor: 'copying'! 42256deepCopy 42257 "Answer with the receiver because Characters are unique."! ! 42258 42259!Character methodsFor: 'copying' stamp: 'tk 1/7/1999 16:50'! 42260veryDeepCopyWith: deepCopier 42261 "Return self. I can't be copied."! ! 42262 42263 42264!Character methodsFor: 'object filein' stamp: 'tk 1/17/2000 11:27'! 42265comeFullyUpOnReload: smartRefStream 42266 "Use existing an Character. Don't use the new copy." 42267 42268 ^ self class value: value! ! 42269 42270!Character methodsFor: 'object filein' stamp: 'tk 2/16/2001 14:52'! 42271objectForDataStream: refStrm 42272 "I am being collected for inclusion in a segment. Do not include Characters!! Let them be in outPointers." 42273 42274 refStrm insideASegment 42275 ifFalse: ["Normal use" ^ self] 42276 ifTrue: ["recording objects to go into an ImageSegment" 42277 "remove it from references. Do not trace." 42278 refStrm references removeKey: self ifAbsent: []. 42279 ^ nil] 42280! ! 42281 42282 42283!Character methodsFor: 'printing' stamp: 'ar 4/9/2005 21:53'! 42284hex 42285 ^value hex! ! 42286 42287!Character methodsFor: 'printing'! 42288isLiteral 42289 42290 ^true! ! 42291 42292!Character methodsFor: 'printing' stamp: 'lr 11/21/2005 17:40'! 42293printOn: aStream 42294 | name | 42295 value > 32 42296 ifTrue: [ aStream nextPut: $$; nextPut: self ] 42297 ifFalse: [ 42298 name := self class constantNameFor: self. 42299 name notNil 42300 ifTrue: [ aStream nextPutAll: self class name; space; nextPutAll: name ] 42301 ifFalse: [ aStream nextPutAll: self class name; nextPutAll: ' value: '; print: value ] ].! ! 42302 42303!Character methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:04'! 42304printOnStream: aStream 42305 42306 aStream print:'$', (String with:self).! ! 42307 42308!Character methodsFor: 'printing' stamp: 'ar 4/9/2005 22:30'! 42309storeBinaryOn: aStream 42310 "Store the receiver on a binary (file) stream" 42311 value < 256 42312 ifTrue:[aStream basicNextPut: self] 42313 ifFalse:[Stream nextInt32Put: value].! ! 42314 42315!Character methodsFor: 'printing' stamp: 'lr 1/3/2007 19:30'! 42316storeOn: aStream 42317 "Common character literals are preceded by '$', however special need to be encoded differently: for some this might be done by using one of the shortcut constructor methods for the rest we have to create them by ascii-value." 42318 42319 | name | 42320 (value between: 33 and: 255) 42321 ifTrue: [ aStream nextPut: $$; nextPut: self ] 42322 ifFalse: [ 42323 name := self class constantNameFor: self. 42324 name notNil 42325 ifTrue: [ aStream nextPutAll: self class name; space; nextPutAll: name ] 42326 ifFalse: [ 42327 aStream 42328 nextPut: $(; nextPutAll: self class name; 42329 nextPutAll: ' value: '; print: value; nextPut: $) ] ].! ! 42330 42331 42332!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:57'! 42333canBeGlobalVarInitial 42334 42335 ^ (EncodedCharSet charsetAt: self leadingChar) canBeGlobalVarInitial: self. 42336! ! 42337 42338!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:58'! 42339canBeNonGlobalVarInitial 42340 42341 ^ (EncodedCharSet charsetAt: self leadingChar) canBeNonGlobalVarInitial: self. 42342! ! 42343 42344!Character methodsFor: 'testing'! 42345isAlphaNumeric 42346 "Answer whether the receiver is a letter or a digit." 42347 42348 ^self isLetter or: [self isDigit]! ! 42349 42350!Character methodsFor: 'testing' stamp: 'yo 8/28/2002 13:42'! 42351isCharacter 42352 42353 ^ true. 42354! ! 42355 42356!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43'! 42357isDigit 42358 42359 ^ (EncodedCharSet charsetAt: self leadingChar) isDigit: self. 42360! ! 42361 42362!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43'! 42363isLetter 42364 42365 ^ (EncodedCharSet charsetAt: self leadingChar) isLetter: self. 42366! ! 42367 42368!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43'! 42369isLowercase 42370 42371 ^ (EncodedCharSet charsetAt: self leadingChar) isLowercase: self. 42372! ! 42373 42374!Character methodsFor: 'testing' stamp: 'yo 8/27/2002 15:18'! 42375isOctetCharacter 42376 42377 ^ value < 256. 42378! ! 42379 42380!Character methodsFor: 'testing' stamp: 'yo 7/29/2005 15:21'! 42381isSafeForHTTP 42382 "whether a character is 'safe', or needs to be escaped when used, eg, in a URL" 42383 "[GG] See http://www.faqs.org/rfcs/rfc1738.html. ~ is unsafe and has been removed" 42384 ^ self charCode < 128 42385 and: [self isAlphaNumeric 42386 or: ['.-_' includes: (Character value: self charCode)]]! ! 42387 42388!Character methodsFor: 'testing'! 42389isSeparator 42390 "Answer whether the receiver is one of the separator characters--space, 42391 cr, tab, line feed, or form feed." 42392 42393 value = 32 ifTrue: [^true]. "space" 42394 value = 13 ifTrue: [^true]. "cr" 42395 value = 9 ifTrue: [^true]. "tab" 42396 value = 10 ifTrue: [^true]. "line feed" 42397 value = 12 ifTrue: [^true]. "form feed" 42398 ^false! ! 42399 42400!Character methodsFor: 'testing' stamp: 'di 4/3/1999 00:38'! 42401isSpecial 42402 "Answer whether the receiver is one of the special characters" 42403 42404 ^'+-/\*~<>=@,%|&?!!' includes: self! ! 42405 42406!Character methodsFor: 'testing' stamp: 'ar 4/12/2005 14:09'! 42407isTraditionalDomestic 42408 "Yoshiki's note about #isUnicode says: 42409 [This method] is for the backward compatibility when we had domestic 42410 traditional encodings for CJK languages. To support loading the 42411 projects in traditional domestic encodings (From Nihongo4), and load 42412 some changesets. Once we decided to get rid of classes like JISX0208 42413 from the EncodedCharSet table, the need for isUnicode will not be 42414 necessary. 42415 I (Andreas) decided to change the name from isUnicode to #isTraditionalDomestic 42416 since I found isUnicode to be horribly confusing (how could the character *not* 42417 be Unicode after all?). But still, we should remove this method in due time." 42418 ^ ((EncodedCharSet charsetAt: self leadingChar) isKindOf: LanguageEnvironment class) not! ! 42419 42420!Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43'! 42421isUppercase 42422 42423 ^ (EncodedCharSet charsetAt: self leadingChar) isUppercase: self. 42424! ! 42425 42426!Character methodsFor: 'testing'! 42427isVowel 42428 "Answer whether the receiver is one of the vowels, AEIOU, in upper or 42429 lower case." 42430 42431 ^'AEIOU' includes: self asUppercase! ! 42432 42433!Character methodsFor: 'testing'! 42434tokenish 42435 "Answer whether the receiver is a valid token-character--letter, digit, or 42436 colon." 42437 42438 ^self isLetter or: [self isDigit or: [self = $:]]! ! 42439 42440 42441!Character methodsFor: 'private' stamp: 'ar 4/9/2005 22:18'! 42442setValue: newValue 42443 value ifNotNil:[^self error:'Characters are immutable']. 42444 value := newValue.! ! 42445 42446 42447!Character methodsFor: '*Multilingual' stamp: 'pmm 9/12/2009 20:39'! 42448asUnicodeChar 42449 "Answer a copy of the receiver with Unicode as the leadingChar" 42450 ^ Unicode charFromUnicode: self asUnicode! ! 42451 42452"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 42453 42454Character class 42455 instanceVariableNames: ''! 42456 42457!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! 42458arrowDown 42459 ^ self value: 31! ! 42460 42461!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! 42462arrowLeft 42463 ^ self value: 28! ! 42464 42465!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! 42466arrowRight 42467 ^ self value: 29! ! 42468 42469!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! 42470arrowUp 42471 ^ self value: 30! ! 42472 42473!Character class methodsFor: 'accessing untypeable characters'! 42474backspace 42475 "Answer the Character representing a backspace." 42476 42477 ^self value: 8! ! 42478 42479!Character class methodsFor: 'accessing untypeable characters'! 42480cr 42481 "Answer the Character representing a carriage return." 42482 42483 ^self value: 13! ! 42484 42485!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:19'! 42486delete 42487 ^ self value: 127! ! 42488 42489!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! 42490end 42491 ^ self value: 4! ! 42492 42493!Character class methodsFor: 'accessing untypeable characters'! 42494enter 42495 "Answer the Character representing enter." 42496 42497 ^self value: 3! ! 42498 42499!Character class methodsFor: 'accessing untypeable characters' stamp: 'ls 9/2/1999 08:06'! 42500escape 42501 "Answer the ASCII ESC character" 42502 42503 ^self value: 27! ! 42504 42505!Character class methodsFor: 'accessing untypeable characters' stamp: 'sma 3/15/2000 22:33'! 42506euro 42507 "The Euro currency sign, that E with two dashes. The key code is a wild guess" 42508 42509 ^ Character value: 219! ! 42510 42511!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! 42512home 42513 ^ self value: 1! ! 42514 42515!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:19'! 42516insert 42517 ^ self value: 5! ! 42518 42519!Character class methodsFor: 'accessing untypeable characters' stamp: 'ls 9/8/1998 22:15'! 42520lf 42521 "Answer the Character representing a linefeed." 42522 42523 ^self value: 10! ! 42524 42525!Character class methodsFor: 'accessing untypeable characters'! 42526linefeed 42527 "Answer the Character representing a linefeed." 42528 42529 ^self value: 10! ! 42530 42531!Character class methodsFor: 'accessing untypeable characters' stamp: 'wiz 4/9/2006 20:30'! 42532nbsp 42533 "non-breakable space. Latin1 encoding common usage." 42534 42535 ^ Character value: 160! ! 42536 42537!Character class methodsFor: 'accessing untypeable characters'! 42538newPage 42539 "Answer the Character representing a form feed." 42540 42541 ^self value: 12! ! 42542 42543!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! 42544pageDown 42545 ^ self value: 12! ! 42546 42547!Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! 42548pageUp 42549 ^ self value: 11! ! 42550 42551!Character class methodsFor: 'accessing untypeable characters'! 42552space 42553 "Answer the Character representing a space." 42554 42555 ^self value: 32! ! 42556 42557!Character class methodsFor: 'accessing untypeable characters'! 42558tab 42559 "Answer the Character representing a tab." 42560 42561 ^self value: 9! ! 42562 42563 42564!Character class methodsFor: 'constants' stamp: 'rhi 9/8/2000 14:57'! 42565alphabet 42566 "($a to: $z) as: String" 42567 42568 ^ 'abcdefghijklmnopqrstuvwxyz' copy! ! 42569 42570!Character class methodsFor: 'constants'! 42571characterTable 42572 "Answer the class variable in which unique Characters are stored." 42573 42574 ^CharacterTable! ! 42575 42576 42577!Character class methodsFor: 'initialization' stamp: 'yo 10/4/2003 16:03'! 42578initialize 42579 "Create the table of unique Characters." 42580" self initializeClassificationTable"! ! 42581 42582!Character class methodsFor: 'initialization' stamp: 'dgd 8/24/2003 15:10'! 42583initializeClassificationTable 42584 " 42585 Initialize the classification table. The classification table is a 42586 compact encoding of upper and lower cases of characters with 42587 42588 - bits 0-7: The lower case value of this character. 42589 - bits 8-15: The upper case value of this character. 42590 - bit 16: lowercase bit (e.g., isLowercase == true) 42591 - bit 17: uppercase bit (e.g., isUppercase == true) 42592 42593 " 42594 | ch1 ch2 | 42595 42596 LowercaseBit := 1 bitShift: 16. 42597 UppercaseBit := 1 bitShift: 17. 42598 42599 "Initialize the letter bits (e.g., isLetter == true)" 42600 LetterBits := LowercaseBit bitOr: UppercaseBit. 42601 42602 ClassificationTable := Array new: 256. 42603 "Initialize the defaults (neither lower nor upper case)" 42604 0 to: 255 do:[:i| 42605 ClassificationTable at: i+1 put: (i bitShift: 8) + i. 42606 ]. 42607 42608 "Initialize character pairs (upper-lower case)" 42609 #( 42610 "Basic roman" 42611 ($A $a) ($B $b) ($C $c) ($D $d) 42612 ($E $e) ($F $f) ($G $g) ($H $h) 42613 ($I $i) ($J $j) ($K $k) ($L $l) 42614 ($M $m) ($N $n) ($O $o) ($P $p) 42615 ($Q $q) ($R $r) ($S $s) ($T $t) 42616 ($U $u) ($V $v) ($W $w) ($X $x) 42617 ($Y $y) ($Z $z) 42618 "International" 42619 ($Ä $ä) ($Å $å) ($Ç $ç) ($É $é) 42620 ($Ñ $ñ) ($Ö $ö) ($Ü $ü) ($À $à) 42621 ($à $ã) ($Õ $õ) ($Œ $œ) ($Æ $æ) 42622 "International - Spanish" 42623 ($Á $á) ($Í $í) ($Ó $ó) ($Ú $ú) 42624 "International - PLEASE CHECK" 42625 ($È $è) ($Ì $ì) ($Ò $ò) ($Ù $ù) 42626 ($Ë $ë) ($Ï $ï) 42627 ($ $â) ($Ê $ê) ($Î $î) ($Ô $ô) ($Û $û) 42628 ) do:[:pair| 42629 ch1 := pair first asciiValue. 42630 ch2 := pair last asciiValue. 42631 ClassificationTable at: ch1+1 put: (ch1 bitShift: 8) + ch2 + UppercaseBit. 42632 ClassificationTable at: ch2+1 put: (ch1 bitShift: 8) + ch2 + LowercaseBit. 42633 ]. 42634 42635 "Initialize a few others for which we only have lower case versions." 42636 #($ß $Ø $ø $ÿ) do:[:char| 42637 ch1 := char asciiValue. 42638 ClassificationTable at: ch1+1 put: (ch1 bitShift: 8) + ch1 + LowercaseBit. 42639 ]. 42640! ! 42641 42642 42643!Character class methodsFor: 'instance creation' stamp: 'ar 4/9/2005 22:36'! 42644allByteCharacters 42645 "Answer all the characters that can be encoded in a byte" 42646 ^ (0 to: 255) collect: [:v | Character value: v] 42647 42648 42649! ! 42650 42651!Character class methodsFor: 'instance creation' stamp: 'ar 4/9/2005 22:37'! 42652allCharacters 42653 "This name is obsolete since only the characters that will fit in a byte can be queried" 42654 ^self allByteCharacters 42655 42656! ! 42657 42658!Character class methodsFor: 'instance creation' stamp: 'GabrielOmarCotelli 5/25/2009 16:03'! 42659codePoint: anInteger 42660 42661 "Just for ANSI Compliance" 42662 42663 ^self value: anInteger 42664 ! ! 42665 42666!Character class methodsFor: 'instance creation'! 42667digitValue: x 42668 "Answer the Character whose digit value is x. For example, answer $9 for 42669 x=9, $0 for x=0, $A for x=10, $Z for x=35." 42670 42671 | index | 42672 index := x asInteger. 42673 ^CharacterTable at: 42674 (index < 10 42675 ifTrue: [48 + index] 42676 ifFalse: [55 + index]) 42677 + 1! ! 42678 42679!Character class methodsFor: 'instance creation' stamp: 'ar 4/9/2005 22:24'! 42680leadingChar: leadChar code: code 42681 42682 code >= 16r400000 ifTrue: [ 42683 self error: 'code is out of range'. 42684 ]. 42685 leadChar >= 256 ifTrue: [ 42686 self error: 'lead is out of range'. 42687 ]. 42688 42689 ^self value: (leadChar bitShift: 22) + code.! ! 42690 42691!Character class methodsFor: 'instance creation'! 42692new 42693 "Creating new characters is not allowed." 42694 42695 self error: 'cannot create new characters'! ! 42696 42697!Character class methodsFor: 'instance creation'! 42698separators 42699 ^ #(32 "space" 42700 13 "cr" 42701 9 "tab" 42702 10 "line feed" 42703 12 "form feed") 42704 collect: [:v | Character value: v] 42705 42706 42707! ! 42708 42709!Character class methodsFor: 'instance creation' stamp: 'GabrielOmarCotelli 5/29/2009 23:42'! 42710value: anInteger 42711 "Answer the Character whose value is anInteger." 42712 42713 anInteger negative ifTrue:[self error: 'Characters expects a positive value.']. 42714 anInteger > 255 ifTrue: [^self basicNew setValue: anInteger]. 42715 ^ CharacterTable at: anInteger + 1. 42716! ! 42717 42718 42719!Character class methodsFor: 'private' stamp: 'lr 11/21/2005 17:24'! 42720constantNameFor: aCharacter 42721 ^ self constantNames 42722 detect: [ :each | (self perform: each) = aCharacter ] 42723 ifNone: [ nil ].! ! 42724 42725!Character class methodsFor: 'private' stamp: 'gvc 6/21/2007 11:52'! 42726constantNames 42727 "Added the rest of them!!" 42728 42729 ^#(backspace cr delete escape lf newPage space tab 42730 arrowDown arrowLeft arrowRight arrowUp 42731 enter end home insert nbsp pageDown pageUp).! ! 42732Rectangle subclass: #CharacterBlock 42733 instanceVariableNames: 'stringIndex text textLine' 42734 classVariableNames: '' 42735 poolDictionaries: 'TextConstants' 42736 category: 'Graphics-Text'! 42737!CharacterBlock commentStamp: '<historical>' prior: 0! 42738My instances contain information about displayed characters. They are used to return the results of methods: 42739 Paragraph characterBlockAtPoint: aPoint and 42740 Paragraph characterBlockForIndex: stringIndex. 42741Any recomposition or movement of a Paragraph can make the instance obsolete.! 42742 42743 42744!CharacterBlock methodsFor: 'accessing' stamp: 'di 6/7/2000 17:33'! 42745copy 42746 "Overridden because Rectangle does a deepCopy, which goes nuts with the text" 42747 42748 ^ self clone! ! 42749 42750!CharacterBlock methodsFor: 'accessing'! 42751stringIndex 42752 "Answer the position of the receiver in the string it indexes." 42753 42754 ^stringIndex! ! 42755 42756!CharacterBlock methodsFor: 'accessing' stamp: 'di 12/2/97 14:33'! 42757textLine 42758 ^ textLine! ! 42759 42760!CharacterBlock methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 42761textLine: aLine 42762 textLine := aLine! ! 42763 42764 42765!CharacterBlock methodsFor: 'comparing'! 42766< aCharacterBlock 42767 "Answer whether the string index of the receiver precedes that of 42768 aCharacterBlock." 42769 42770 ^stringIndex < aCharacterBlock stringIndex! ! 42771 42772!CharacterBlock methodsFor: 'comparing'! 42773<= aCharacterBlock 42774 "Answer whether the string index of the receiver does not come after that 42775 of aCharacterBlock." 42776 42777 ^(self > aCharacterBlock) not! ! 42778 42779!CharacterBlock methodsFor: 'comparing'! 42780= aCharacterBlock 42781 42782 self species = aCharacterBlock species 42783 ifTrue: [^stringIndex = aCharacterBlock stringIndex] 42784 ifFalse: [^false]! ! 42785 42786!CharacterBlock methodsFor: 'comparing'! 42787> aCharacterBlock 42788 "Answer whether the string index of the receiver comes after that of 42789 aCharacterBlock." 42790 42791 ^aCharacterBlock < self! ! 42792 42793!CharacterBlock methodsFor: 'comparing'! 42794>= aCharacterBlock 42795 "Answer whether the string index of the receiver does not precede that of 42796 aCharacterBlock." 42797 42798 ^(self < aCharacterBlock) not! ! 42799 42800!CharacterBlock methodsFor: 'comparing' stamp: 'th 9/17/2002 11:54'! 42801max: aCharacterBlock 42802 aCharacterBlock ifNil:[^self]. 42803 ^aCharacterBlock > self 42804 ifTrue:[ aCharacterBlock] 42805 ifFalse:[self].! ! 42806 42807!CharacterBlock methodsFor: 'comparing' stamp: 'th 9/17/2002 11:54'! 42808min: aCharacterBlock 42809 aCharacterBlock ifNil:[^self]. 42810 ^aCharacterBlock < self 42811 ifTrue:[ aCharacterBlock] 42812 ifFalse:[self].! ! 42813 42814 42815!CharacterBlock methodsFor: 'printing' stamp: 'di 12/2/97 19:15'! 42816printOn: aStream 42817 42818 aStream nextPutAll: 'a CharacterBlock with index '. 42819 stringIndex printOn: aStream. 42820 (text ~~ nil and: [text size> 0 and: [stringIndex between: 1 and: text size]]) 42821 ifTrue: [aStream nextPutAll: ' and character '. 42822 (text at: stringIndex) printOn: aStream]. 42823 aStream nextPutAll: ' and rectangle '. 42824 super printOn: aStream. 42825 textLine ifNotNil: [aStream cr; nextPutAll: ' in '. 42826 textLine printOn: aStream]. 42827! ! 42828 42829 42830!CharacterBlock methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 42831moveBy: aPoint 42832 "Change the corner positions of the receiver so that its area translates by 42833 the amount defined by the argument, aPoint." 42834 origin := origin + aPoint. 42835 corner := corner + aPoint! ! 42836 42837!CharacterBlock methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 42838stringIndex: anInteger text: aText topLeft: topLeft extent: extent 42839 stringIndex := anInteger. 42840 text := aText. 42841 super 42842 setOrigin: topLeft 42843 corner: topLeft + extent! ! 42844CharacterScanner subclass: #CharacterBlockScanner 42845 instanceVariableNames: 'characterPoint characterIndex lastCharacter lastCharacterExtent lastSpaceOrTabExtent nextLeftMargin specialWidth' 42846 classVariableNames: '' 42847 poolDictionaries: '' 42848 category: 'Graphics-Text'! 42849!CharacterBlockScanner commentStamp: '<historical>' prior: 0! 42850My instances are used to scan text to compute the CharacterBlock for a character specified by its index in the text or its proximity to the cursor location.! 42851 42852 42853!CharacterBlockScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 12:49'! 42854crossedX 42855 "Text display has wrapping. The scanner just found a character past the x 42856 location of the cursor. We know that the cursor is pointing at a character 42857 or before one." 42858 42859 | leadingTab currentX | 42860 characterIndex == nil ifFalse: [ 42861 "If the last character of the last line is a space, 42862 and it crosses the right margin, then locating 42863 the character block after it is impossible without this hack." 42864 characterIndex > text size ifTrue: [ 42865 lastIndex := characterIndex. 42866 characterPoint := (nextLeftMargin ifNil: [leftMargin]) @ (destY + line lineHeight). 42867 ^true]]. 42868 characterPoint x <= (destX + (lastCharacterExtent x // 2)) 42869 ifTrue: [lastCharacter := (text at: lastIndex). 42870 characterPoint := destX @ destY. 42871 ^true]. 42872 lastIndex >= line last 42873 ifTrue: [lastCharacter := (text at: line last). 42874 characterPoint := destX @ destY. 42875 ^true]. 42876 42877 "Pointing past middle of a character, return the next character." 42878 lastIndex := lastIndex + 1. 42879 lastCharacter := text at: lastIndex. 42880 currentX := destX + lastCharacterExtent x + kern. 42881 self lastCharacterExtentSetX: (font widthOf: lastCharacter). 42882 characterPoint := currentX @ destY. 42883 lastCharacter = Space ifFalse: [^ true]. 42884 42885 "Yukky if next character is space or tab." 42886 alignment = Justified ifTrue: 42887 [self lastCharacterExtentSetX: 42888 (lastCharacterExtent x + (line justifiedPadFor: (spaceCount + 1) font: font)). 42889 ^ true]. 42890 42891 true ifTrue: [^ true]. 42892 "NOTE: I find no value to the following code, and so have defeated it - DI" 42893 42894 "See tabForDisplay for illumination on the following awfulness." 42895 leadingTab := true. 42896 line first to: lastIndex - 1 do: 42897 [:index | (text at: index) ~= Tab ifTrue: [leadingTab := false]]. 42898 (alignment ~= Justified or: [leadingTab]) 42899 ifTrue: [self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX 42900 leftMargin: leftMargin rightMargin: rightMargin) - 42901 currentX] 42902 ifFalse: [self lastCharacterExtentSetX: (((currentX + (textStyle tabWidth - 42903 (line justifiedTabDeltaFor: spaceCount))) - 42904 currentX) max: 0)]. 42905 ^ true! ! 42906 42907!CharacterBlockScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 12:50'! 42908paddedSpace 42909 "When the line is justified, the spaces will not be the same as the font's 42910 space character. A padding of extra space must be considered in trying 42911 to find which character the cursor is pointing at. Answer whether the 42912 scanning has crossed the cursor." 42913 42914 | pad | 42915 pad := 0. 42916 spaceCount := spaceCount + 1. 42917 pad := line justifiedPadFor: spaceCount font: font. 42918 lastSpaceOrTabExtent := lastCharacterExtent copy. 42919 self lastSpaceOrTabExtentSetX: spaceWidth + pad. 42920 (destX + lastSpaceOrTabExtent x) >= characterPoint x 42921 ifTrue: [lastCharacterExtent := lastSpaceOrTabExtent copy. 42922 ^self crossedX]. 42923 lastIndex := lastIndex + 1. 42924 destX := destX + lastSpaceOrTabExtent x. 42925 ^ false 42926! ! 42927 42928 42929!CharacterBlockScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 42930characterBlockAtPoint: aPoint in: aParagraph 42931 "Answer a CharacterBlock for character in aParagraph at point aPoint. It 42932 is assumed that aPoint has been transformed into coordinates appropriate 42933 to the text's destination form rectangle and the composition rectangle." 42934 self 42935 initializeFromParagraph: aParagraph 42936 clippedBy: aParagraph clippingRectangle. 42937 characterPoint := aPoint. 42938 ^ self buildCharacterBlockIn: aParagraph! ! 42939 42940!CharacterBlockScanner methodsFor: 'scanning' stamp: 'nk 11/22/2004 14:32'! 42941characterBlockAtPoint: aPoint index: index in: textLine 42942 "This method is the Morphic characterBlock finder. It combines 42943 MVC's characterBlockAtPoint:, -ForIndex:, and buildCharcterBlock:in:" 42944 | runLength lineStop done stopCondition | 42945 line := textLine. 42946 rightMargin := line rightMargin. 42947 lastIndex := line first. 42948 self setStopConditions. "also sets font" 42949 characterIndex := index. " == nil means scanning for point" 42950 characterPoint := aPoint. 42951 (characterPoint isNil or: [characterPoint y > line bottom]) 42952 ifTrue: [characterPoint := line bottomRight]. 42953 (text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left]) 42954 or: [characterIndex notNil and: [characterIndex < line first]]]) 42955 ifTrue: [^ (CharacterBlock new stringIndex: line first text: text 42956 topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid) 42957 textLine: line]. 42958 destX := leftMargin := line leftMarginForAlignment: alignment. 42959 destY := line top. 42960 runLength := text runLengthFor: line first. 42961 characterIndex 42962 ifNotNil: [lineStop := characterIndex "scanning for index"] 42963 ifNil: [lineStop := line last "scanning for point"]. 42964 runStopIndex := lastIndex + (runLength - 1) min: lineStop. 42965 lastCharacterExtent := 0 @ line lineHeight. 42966 spaceCount := 0. 42967 42968 done := false. 42969 [done] whileFalse: 42970 [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex 42971 in: text string rightX: characterPoint x 42972 stopConditions: stopConditions kern: kern. 42973 "see setStopConditions for stopping conditions for character block operations." 42974 self lastCharacterExtentSetX: (specialWidth 42975 ifNil: [font widthOf: (text at: lastIndex)] 42976 ifNotNil: [specialWidth]). 42977 (self perform: stopCondition) ifTrue: 42978 [characterIndex 42979 ifNil: [ 42980 "Result for characterBlockAtPoint: " 42981 (stopCondition ~~ #cr and: [ lastIndex == line last 42982 and: [ aPoint x > ((characterPoint x) + (lastCharacterExtent x / 2)) ]]) 42983 ifTrue: [ "Correct for right half of last character in line" 42984 ^ (CharacterBlock new stringIndex: lastIndex + 1 42985 text: text 42986 topLeft: characterPoint + (lastCharacterExtent x @ 0) + (font descentKern @ 0) 42987 extent: 0 @ lastCharacterExtent y) 42988 textLine: line ]. 42989 ^ (CharacterBlock new stringIndex: lastIndex 42990 text: text topLeft: characterPoint + (font descentKern @ 0) 42991 extent: lastCharacterExtent - (font baseKern @ 0)) 42992 textLine: line] 42993 ifNotNil: ["Result for characterBlockForIndex: " 42994 ^ (CharacterBlock new stringIndex: characterIndex 42995 text: text topLeft: characterPoint + ((font descentKern) - kern @ 0) 42996 extent: lastCharacterExtent) 42997 textLine: line]]]! ! 42998 42999!CharacterBlockScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 43000characterBlockForIndex: targetIndex in: aParagraph 43001 "Answer a CharacterBlock for character in aParagraph at targetIndex. The 43002 coordinates in the CharacterBlock will be appropriate to the intersection 43003 of the destination form rectangle and the composition rectangle." 43004 self 43005 initializeFromParagraph: aParagraph 43006 clippedBy: aParagraph clippingRectangle. 43007 characterIndex := targetIndex. 43008 characterPoint := aParagraph rightMarginForDisplay @ (aParagraph topAtLineIndex: (aParagraph lineIndexOfCharacterIndex: characterIndex)). 43009 ^ self buildCharacterBlockIn: aParagraph! ! 43010 43011!CharacterBlockScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 43012indentationLevel: anInteger 43013 super indentationLevel: anInteger. 43014 nextLeftMargin := leftMargin. 43015 indentationLevel timesRepeat: 43016 [ nextLeftMargin := textStyle 43017 nextTabXFrom: nextLeftMargin 43018 leftMargin: leftMargin 43019 rightMargin: rightMargin ]! ! 43020 43021!CharacterBlockScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 43022placeEmbeddedObject: anchoredMorph 43023 "Workaround: The following should really use #textAnchorType" 43024 anchoredMorph relativeTextAnchorPosition ifNotNil: [ ^ true ]. 43025 (super placeEmbeddedObject: anchoredMorph) ifFalse: [ ^ false ]. 43026 specialWidth := anchoredMorph width. 43027 ^ true! ! 43028 43029 43030!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! 43031cr 43032 "Answer a CharacterBlock that specifies the current location of the mouse 43033 relative to a carriage return stop condition that has just been 43034 encountered. The ParagraphEditor convention is to denote selections by 43035 CharacterBlocks, sometimes including the carriage return (cursor is at 43036 the end) and sometimes not (cursor is in the middle of the text)." 43037 ((characterIndex ~= nil and: [ characterIndex > text size ]) or: 43038 [ line last = text size and: [ destY + line lineHeight < characterPoint y ] ]) ifTrue: 43039 [ "When off end of string, give data for next character" 43040 destY := destY + line lineHeight. 43041 lastCharacter := nil. 43042 characterPoint := (nextLeftMargin ifNil: [ leftMargin ]) @ destY. 43043 lastIndex := lastIndex + 1. 43044 self lastCharacterExtentSetX: 0. 43045 ^ true ]. 43046 lastCharacter := CR. 43047 characterPoint := destX @ destY. 43048 self lastCharacterExtentSetX: rightMargin - destX. 43049 ^ true! ! 43050 43051!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! 43052endOfRun 43053 "Before arriving at the cursor location, the selection has encountered an 43054 end of run. Answer false if the selection continues, true otherwise. Set 43055 up indexes for building the appropriate CharacterBlock." 43056 | runLength lineStop | 43057 (((characterIndex ~~ nil and: [ runStopIndex < characterIndex and: [ runStopIndex < text size ] ]) or: [ characterIndex == nil and: [ lastIndex < line last ] ]) or: 43058 [ lastIndex < line last and: 43059 [ (text at: lastIndex) leadingChar ~= (text at: lastIndex + 1) leadingChar and: [ lastIndex ~= characterIndex ] ] ]) ifTrue: 43060 [ "We're really at the end of a real run." 43061 runLength := text runLengthFor: (lastIndex := lastIndex + 1). 43062 characterIndex ~~ nil 43063 ifTrue: [ lineStop := characterIndex "scanning for index" ] 43064 ifFalse: [ lineStop := line last "scanning for point" ]. 43065 (runStopIndex := lastIndex + (runLength - 1)) > lineStop ifTrue: [ runStopIndex := lineStop ]. 43066 self setStopConditions. 43067 ^ false ]. 43068 lastCharacter := text at: lastIndex. 43069 characterPoint := destX @ destY. 43070 ((lastCharacter = Space and: [ alignment = Justified ]) or: [ lastCharacter = Tab and: [ lastSpaceOrTabExtent notNil ] ]) ifTrue: [ lastCharacterExtent := lastSpaceOrTabExtent ]. 43071 characterIndex ~~ nil ifTrue: 43072 [ "If scanning for an index and we've stopped on that index, 43073 then we back destX off by the width of the character stopped on 43074 (it will be pointing at the right side of the character) and return" 43075 runStopIndex = characterIndex ifTrue: 43076 [ self characterPointSetX: destX - lastCharacterExtent x. 43077 ^ true ]. 43078 "Otherwise the requested index was greater than the length of the 43079 string. Return string size + 1 as index, indicate further that off the 43080 string by setting character to nil and the extent to 0." 43081 lastIndex := lastIndex + 1. 43082 lastCharacter := nil. 43083 self lastCharacterExtentSetX: 0. 43084 ^ true ]. 43085 43086 "Scanning for a point and either off the end of the line or off the end of the string." 43087 runStopIndex = text size ifTrue: 43088 [ "off end of string" 43089 lastIndex := lastIndex + 1. 43090 lastCharacter := nil. 43091 self lastCharacterExtentSetX: 0. 43092 ^ true ]. 43093 "just off end of line without crossing x" 43094 lastIndex := lastIndex + 1. 43095 ^ true! ! 43096 43097!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! 43098setFont 43099 specialWidth := nil. 43100 super setFont! ! 43101 43102!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 10/18/2004 14:30'! 43103setStopConditions 43104 "Set the font and the stop conditions for the current run." 43105 43106 self setFont. 43107 self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]). 43108! ! 43109 43110!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! 43111tab 43112 | currentX | 43113 currentX := (alignment == Justified and: [ self leadingTab not ]) 43114 ifTrue: 43115 [ "imbedded tabs in justified text are weird" 43116 destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX ] 43117 ifFalse: 43118 [ textStyle 43119 nextTabXFrom: destX 43120 leftMargin: leftMargin 43121 rightMargin: rightMargin ]. 43122 lastSpaceOrTabExtent := lastCharacterExtent copy. 43123 self lastSpaceOrTabExtentSetX: (currentX - destX max: 0). 43124 currentX >= characterPoint x ifTrue: 43125 [ lastCharacterExtent := lastSpaceOrTabExtent copy. 43126 ^ self crossedX ]. 43127 destX := currentX. 43128 lastIndex := lastIndex + 1. 43129 ^ false! ! 43130 43131 43132!CharacterBlockScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 43133buildCharacterBlockIn: para 43134 "handle nullText" 43135 | lineIndex runLength lineStop done stopCondition | 43136 (para numberOfLines = 0 or: [ text size = 0 ]) ifTrue: 43137 [ ^ CharacterBlock new 43138 stringIndex: 1 43139 text: para text 43140 topLeft: (para 43141 leftMarginForDisplayForLine: 1 43142 alignment: (alignment ifNil: 43143 [ "like being off end of string" 43144 textStyle alignment ])) @ para compositionRectangle top 43145 extent: 0 @ textStyle lineGrid ]. 43146 "find the line" 43147 lineIndex := para lineIndexOfTop: characterPoint y. 43148 destY := para topAtLineIndex: lineIndex. 43149 line := para lines at: lineIndex. 43150 lastIndex := line first. 43151 rightMargin := para rightMarginForDisplay. 43152 self setStopConditions. " also loads the font and loads all emphasis attributes " 43153 (lineIndex = para numberOfLines and: [ destY + line lineHeight < characterPoint y ]) 43154 ifTrue: 43155 [ "if beyond lastLine, force search to last character" 43156 self characterPointSetX: rightMargin ] 43157 ifFalse: 43158 [ characterPoint y < para compositionRectangle top ifTrue: 43159 [ "force search to first line" 43160 characterPoint := para compositionRectangle topLeft ]. 43161 characterPoint x > rightMargin ifTrue: [ self characterPointSetX: rightMargin ] ]. 43162 destX := leftMargin := para 43163 leftMarginForDisplayForLine: lineIndex 43164 alignment: (alignment ifNil: [ textStyle alignment ]). 43165 nextLeftMargin := para 43166 leftMarginForDisplayForLine: lineIndex + 1 43167 alignment: (alignment ifNil: [ textStyle alignment ]). 43168 lastIndex := line first. 43169 self setStopConditions. "also sets font" 43170 runLength := text runLengthFor: line first. 43171 characterIndex == nil 43172 ifTrue: [ lineStop := line last "characterBlockAtPoint" ] 43173 ifFalse: [ lineStop := characterIndex "characterBlockForIndex" ]. 43174 (runStopIndex := lastIndex + (runLength - 1)) > lineStop ifTrue: [ runStopIndex := lineStop ]. 43175 lastCharacterExtent := 0 @ line lineHeight. 43176 spaceCount := 0. 43177 done := false. 43178 self handleIndentation. 43179 [ done ] whileFalse: 43180 [ stopCondition := self 43181 scanCharactersFrom: lastIndex 43182 to: runStopIndex 43183 in: text string 43184 rightX: characterPoint x 43185 stopConditions: stopConditions 43186 kern: kern. 43187 43188 "see setStopConditions for stopping conditions for character block operations." 43189 self lastCharacterExtentSetX: (font widthOf: (text at: lastIndex)). 43190 (self perform: stopCondition) ifTrue: 43191 [ characterIndex == nil 43192 ifTrue: 43193 [ "characterBlockAtPoint" 43194 ^ CharacterBlock new 43195 stringIndex: lastIndex 43196 text: text 43197 topLeft: characterPoint + (font descentKern @ 0) 43198 extent: lastCharacterExtent ] 43199 ifFalse: 43200 [ "characterBlockForIndex" 43201 ^ CharacterBlock new 43202 stringIndex: lastIndex 43203 text: text 43204 topLeft: characterPoint + ((font descentKern - kern) @ 0) 43205 extent: lastCharacterExtent ] ] ]! ! 43206 43207!CharacterBlockScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 43208characterPointSetX: xVal 43209 characterPoint := xVal @ characterPoint y! ! 43210 43211!CharacterBlockScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 43212lastCharacterExtentSetX: xVal 43213 lastCharacterExtent := xVal @ lastCharacterExtent y! ! 43214 43215!CharacterBlockScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 43216lastSpaceOrTabExtentSetX: xVal 43217 lastSpaceOrTabExtent := xVal @ lastSpaceOrTabExtent y! ! 43218Object subclass: #CharacterScanner 43219 instanceVariableNames: 'destX lastIndex xTable destY stopConditions text textStyle alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern indentationLevel wantsColumnBreaks pendingKernX' 43220 classVariableNames: 'DefaultStopConditions NilCondition PaddedSpaceCondition SpaceCondition' 43221 poolDictionaries: 'TextConstants' 43222 category: 'Graphics-Text'! 43223!CharacterScanner commentStamp: '<historical>' prior: 0! 43224My instances hold the state associated with scanning text. My subclasses scan characters for specified purposes, such as computing a CharacterBlock or placing characters into Forms.! 43225 43226 43227!CharacterScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 09:53'! 43228basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta 43229 "Primitive. This is the inner loop of text display--but see 43230 scanCharactersFrom: to:rightX: which would get the string, 43231 stopConditions and displaying from the instance. March through source 43232 String from startIndex to stopIndex. If any character is flagged with a 43233 non-nil entry in stops, then return the corresponding value. Determine 43234 width of each character from xTable, indexed by map. 43235 If dextX would exceed rightX, then return stops at: 258. 43236 Advance destX by the width of the character. If stopIndex has been 43237 reached, then return stops at: 257. Optional. 43238 See Object documentation whatIsAPrimitive." 43239 | ascii nextDestX char floatDestX widthAndKernedWidth nextChar atEndOfRun | 43240 <primitive: 103> 43241 lastIndex := startIndex. 43242 floatDestX := destX. 43243 widthAndKernedWidth := Array new: 2. 43244 atEndOfRun := false. 43245 [lastIndex <= stopIndex] 43246 whileTrue: 43247 [char := (sourceString at: lastIndex). 43248 ascii := char asciiValue + 1. 43249 (stops at: ascii) == nil ifFalse: [^stops at: ascii]. 43250 "Note: The following is querying the font about the width 43251 since the primitive may have failed due to a non-trivial 43252 mapping of characters to glyphs or a non-existing xTable." 43253 nextChar := (lastIndex + 1 <= stopIndex) 43254 ifTrue:[sourceString at: lastIndex + 1] 43255 ifFalse:[ 43256 atEndOfRun := true. 43257 "if there is a next char in sourceString, then get the kern 43258 and store it in pendingKernX" 43259 lastIndex + 1 <= sourceString size 43260 ifTrue:[sourceString at: lastIndex + 1] 43261 ifFalse:[ nil]]. 43262 font 43263 widthAndKernedWidthOfLeft: char 43264 right: nextChar 43265 into: widthAndKernedWidth. 43266 nextDestX := floatDestX + (widthAndKernedWidth at: 1). 43267 nextDestX > rightX ifTrue: [^stops at: CrossedX]. 43268 floatDestX := floatDestX + kernDelta + (widthAndKernedWidth at: 2). 43269 atEndOfRun 43270 ifTrue:[ 43271 pendingKernX := (widthAndKernedWidth at: 2) - (widthAndKernedWidth at: 1). 43272 floatDestX := floatDestX - pendingKernX]. 43273 destX := floatDestX. 43274 lastIndex := lastIndex + 1]. 43275 lastIndex := stopIndex. 43276 ^stops at: EndOfRun! ! 43277 43278!CharacterScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 11:16'! 43279columnBreak 43280 43281 pendingKernX := 0. 43282 ^true! ! 43283 43284!CharacterScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 09:59'! 43285setFont 43286 | priorFont | 43287 "Set the font and other emphasis." 43288 priorFont := font. 43289 text == nil ifFalse:[ 43290 emphasisCode := 0. 43291 kern := 0. 43292 indentationLevel := 0. 43293 alignment := textStyle alignment. 43294 font := nil. 43295 (text attributesAt: lastIndex forStyle: textStyle) 43296 do: [:att | att emphasizeScanner: self]]. 43297 font == nil ifTrue: 43298 [self setFont: textStyle defaultFontIndex]. 43299 font := font emphasized: emphasisCode. 43300 priorFont 43301 ifNotNil: [ 43302 font = priorFont 43303 ifTrue:[ 43304 "font is the same, perhaps the color has changed? 43305 We still want kerning between chars of the same 43306 font, but of different color. So add any pending kern to destX" 43307 destX := destX + (pendingKernX ifNil:[0])]. 43308 destX := destX + priorFont descentKern]. 43309 pendingKernX := 0. "clear any pending kern so there is no danger of it being added twice" 43310 destX := destX - font descentKern. 43311 "NOTE: next statement should be removed when clipping works" 43312 leftMargin ifNotNil: [destX := destX max: leftMargin]. 43313 kern := kern - font baseKern. 43314 43315 "Install various parameters from the font." 43316 spaceWidth := font widthOf: Space. 43317 xTable := font xTable. 43318 stopConditions := DefaultStopConditions.! ! 43319 43320 43321!CharacterScanner methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:44'! 43322initialize 43323 super initialize. 43324 destX := destY := leftMargin := 0.! ! 43325 43326!CharacterScanner methodsFor: 'initialize' stamp: 'lr 7/4/2009 10:42'! 43327initializeStringMeasurer 43328 stopConditions := Array new: 258. 43329 stopConditions 43330 at: CrossedX 43331 put: #crossedX. 43332 stopConditions 43333 at: EndOfRun 43334 put: #endOfRun! ! 43335 43336!CharacterScanner methodsFor: 'initialize' stamp: 'lr 7/4/2009 10:42'! 43337wantsColumnBreaks: aBoolean 43338 wantsColumnBreaks := aBoolean! ! 43339 43340 43341!CharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/18/2002 12:32'! 43342isBreakableAtIndex: index 43343 43344 ^ (EncodedCharSet at: ((text at: index) leadingChar + 1)) isBreakableAt: index in: text. 43345! ! 43346 43347!CharacterScanner methodsFor: 'scanner methods' stamp: 'lr 7/4/2009 10:42'! 43348scanJapaneseCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta 43349 | ascii encoding f nextDestX maxAscii startEncoding | 43350 lastIndex := startIndex. 43351 lastIndex > stopIndex ifTrue: 43352 [ lastIndex := stopIndex. 43353 ^ stops at: EndOfRun ]. 43354 startEncoding := (sourceString at: startIndex) leadingChar. 43355 font ifNil: [ font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1 ]. 43356 ((font isMemberOf: StrikeFontSet) or: [ font isKindOf: TTCFontSet ]) 43357 ifTrue: 43358 [ maxAscii := font maxAsciiFor: startEncoding. 43359 f := font fontArray at: startEncoding + 1. 43360 "xTable _ f xTable. 43361 maxAscii _ xTable size - 2." 43362 spaceWidth := f widthOf: Space ] 43363 ifFalse: [ maxAscii := font maxAscii ]. 43364 [ lastIndex <= stopIndex ] whileTrue: 43365 [ encoding := (sourceString at: lastIndex) leadingChar. 43366 encoding ~= startEncoding ifTrue: 43367 [ lastIndex := lastIndex - 1. 43368 ^ stops at: EndOfRun ]. 43369 ascii := (sourceString at: lastIndex) charCode. 43370 ascii > maxAscii ifTrue: [ ascii := maxAscii ]. 43371 (encoding = 0 and: [ (stopConditions at: ascii + 1) ~~ nil ]) ifTrue: [ ^ stops at: ascii + 1 ]. 43372 nextDestX := destX + (font widthOf: (sourceString at: lastIndex)). 43373 nextDestX > rightX ifTrue: [ ^ stops at: CrossedX ]. 43374 destX := nextDestX + kernDelta. 43375 "destX printString displayAt: 0@(lastIndex*20)." 43376 lastIndex := lastIndex + 1 ]. 43377 lastIndex := stopIndex. 43378 ^ stops at: EndOfRun! ! 43379 43380!CharacterScanner methodsFor: 'scanner methods' stamp: 'lr 7/4/2009 10:42'! 43381scanMultiCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta 43382 | ascii encoding f nextDestX maxAscii startEncoding | 43383 lastIndex := startIndex. 43384 lastIndex > stopIndex ifTrue: 43385 [ lastIndex := stopIndex. 43386 ^ stops at: EndOfRun ]. 43387 startEncoding := (sourceString at: startIndex) leadingChar. 43388 font ifNil: [ font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1 ]. 43389 ((font isMemberOf: StrikeFontSet) or: [ font isKindOf: TTCFontSet ]) 43390 ifTrue: 43391 [ maxAscii := font maxAsciiFor: startEncoding. 43392 f := font fontArray at: startEncoding + 1. 43393 spaceWidth := f widthOf: Space ] 43394 ifFalse: [ maxAscii := font maxAscii ]. 43395 [ lastIndex <= stopIndex ] whileTrue: 43396 [ encoding := (sourceString at: lastIndex) leadingChar. 43397 encoding ~= startEncoding ifTrue: 43398 [ lastIndex := lastIndex - 1. 43399 ^ stops at: EndOfRun ]. 43400 ascii := (sourceString at: lastIndex) charCode. 43401 ascii > maxAscii ifTrue: [ ascii := maxAscii ]. 43402 (encoding = 0 and: [ (stopConditions at: ascii + 1) ~~ nil ]) ifTrue: [ ^ stops at: ascii + 1 ]. 43403 nextDestX := destX + (font widthOf: (sourceString at: lastIndex)). 43404 nextDestX > rightX ifTrue: [ ^ stops at: CrossedX ]. 43405 destX := nextDestX + kernDelta. 43406 "destX printString displayAt: 0@(lastIndex*20)." 43407 lastIndex := lastIndex + 1 ]. 43408 lastIndex := stopIndex. 43409 ^ stops at: EndOfRun! ! 43410 43411 43412!CharacterScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 43413embeddedObject 43414 | savedIndex | 43415 savedIndex := lastIndex. 43416 text 43417 attributesAt: lastIndex 43418 do: 43419 [ :attr | 43420 attr anchoredMorph ifNotNil: 43421 [ "Following may look strange but logic gets reversed. 43422 If the morph fits on this line we're not done (return false for true) 43423 and if the morph won't fit we're done (return true for false)" 43424 (self placeEmbeddedObject: attr anchoredMorph) ifFalse: [ ^ true ] ] ]. 43425 lastIndex := savedIndex + 1. "for multiple(!!) embedded morphs" 43426 ^ false! ! 43427 43428!CharacterScanner methodsFor: 'scanning' stamp: 'hmm 7/15/2000 22:40'! 43429handleIndentation 43430 self indentationLevel timesRepeat: [ 43431 self plainTab]! ! 43432 43433!CharacterScanner methodsFor: 'scanning' stamp: 'ar 5/17/2000 18:20'! 43434indentationLevel 43435 "return the number of tabs that are currently being placed at the beginning of each line" 43436 ^indentationLevel ifNil:[0]! ! 43437 43438!CharacterScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 43439indentationLevel: anInteger 43440 "set the number of tabs to put at the beginning of each line" 43441 indentationLevel := anInteger! ! 43442 43443!CharacterScanner methodsFor: 'scanning' stamp: 'ar 1/8/2000 14:23'! 43444leadingTab 43445 "return true if only tabs lie to the left" 43446 line first to: lastIndex do: 43447 [:i | (text at: i) == Tab ifFalse: [^ false]]. 43448 ^ true! ! 43449 43450!CharacterScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 43451measureString: aString inFont: aFont from: startIndex to: stopIndex 43452 "WARNING: In order to use this method the receiver has to be set up using #initializeStringMeasurer" 43453 destX := destY := lastIndex := 0. 43454 xTable := aFont xTable. 43455 self 43456 scanCharactersFrom: startIndex 43457 to: stopIndex 43458 in: aString 43459 rightX: 999999 43460 stopConditions: stopConditions 43461 kern: 0. 43462 ^ destX! ! 43463 43464!CharacterScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 43465placeEmbeddedObject: anchoredMorph 43466 "Place the anchoredMorph or return false if it cannot be placed. 43467 In any event, advance destX by its width." 43468 "Workaround: The following should really use #textAnchorType" 43469 | w | 43470 anchoredMorph relativeTextAnchorPosition ifNotNil: [ ^ true ]. 43471 destX := destX + (w := anchoredMorph width). 43472 (destX > rightMargin and: [ leftMargin + w <= rightMargin ]) ifTrue: 43473 [ "Won't fit, but would on next line" 43474 ^ false ]. 43475 lastIndex := lastIndex + 1. 43476 self setFont. "Force recalculation of emphasis for next run" 43477 ^ true! ! 43478 43479!CharacterScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 43480plainTab 43481 "This is the basic method of adjusting destX for a tab." 43482 destX := (alignment == Justified and: [ self leadingTab not ]) 43483 ifTrue: 43484 [ "embedded tabs in justified text are weird" 43485 destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX ] 43486 ifFalse: 43487 [ textStyle 43488 nextTabXFrom: destX 43489 leftMargin: leftMargin 43490 rightMargin: rightMargin ]! ! 43491 43492!CharacterScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 43493scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta 43494 | startEncoding selector | 43495 sourceString isByteString ifTrue: 43496 [ ^ self 43497 basicScanCharactersFrom: startIndex 43498 to: stopIndex 43499 in: sourceString 43500 rightX: rightX 43501 stopConditions: stops 43502 kern: kernDelta ]. 43503 sourceString isWideString ifTrue: 43504 [ startIndex > stopIndex ifTrue: 43505 [ lastIndex := stopIndex. 43506 ^ stops at: EndOfRun ]. 43507 startEncoding := (sourceString at: startIndex) leadingChar. 43508 selector := (EncodedCharSet charsetAt: startEncoding) scanSelector. 43509 ^ self 43510 perform: selector 43511 withArguments: (Array 43512 with: startIndex 43513 with: stopIndex 43514 with: sourceString 43515 with: rightX 43516 with: stopConditions 43517 with: kernDelta) ]. 43518 ^ stops at: EndOfRun! ! 43519 43520 43521!CharacterScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 43522addEmphasis: code 43523 "Set the bold-ital-under-strike emphasis." 43524 emphasisCode := emphasisCode bitOr: code! ! 43525 43526!CharacterScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 43527addKern: kernDelta 43528 "Set the current kern amount." 43529 kern := kern + kernDelta! ! 43530 43531!CharacterScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 43532initializeFromParagraph: aParagraph clippedBy: clippingRectangle 43533 text := aParagraph text. 43534 textStyle := aParagraph textStyle! ! 43535 43536!CharacterScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 43537setActualFont: aFont 43538 "Set the basal font to an isolated font reference." 43539 font := aFont! ! 43540 43541!CharacterScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 43542setAlignment: style 43543 alignment := style! ! 43544 43545!CharacterScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 43546setConditionArray: aSymbol 43547 aSymbol == #paddedSpace ifTrue: [ ^ stopConditions := PaddedSpaceCondition copy ]. 43548 aSymbol == #space ifTrue: [ ^ stopConditions := SpaceCondition copy ]. 43549 aSymbol == nil ifTrue: [ ^ stopConditions := NilCondition copy ]. 43550 self error: 'undefined stopcondition for space character'! ! 43551 43552!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'! 43553setFont: fontNumber 43554 "Set the font by number from the textStyle." 43555 43556 self setActualFont: (textStyle fontAt: fontNumber)! ! 43557 43558!CharacterScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 43559text: t textStyle: ts 43560 text := t. 43561 textStyle := ts! ! 43562 43563!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'! 43564textColor: ignored 43565 "Overridden in DisplayScanner"! ! 43566 43567"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 43568 43569CharacterScanner class 43570 instanceVariableNames: ''! 43571 43572!CharacterScanner class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 43573initialize 43574 " 43575 CharacterScanner initialize 43576" 43577 | a | 43578 a := Array new: 258. 43579 a 43580 at: 1 + 1 43581 put: #embeddedObject. 43582 a 43583 at: Tab asciiValue + 1 43584 put: #tab. 43585 a 43586 at: CR asciiValue + 1 43587 put: #cr. 43588 a 43589 at: EndOfRun 43590 put: #endOfRun. 43591 a 43592 at: CrossedX 43593 put: #crossedX. 43594 NilCondition := a copy. 43595 DefaultStopConditions := a copy. 43596 PaddedSpaceCondition := a copy. 43597 PaddedSpaceCondition 43598 at: Space asciiValue + 1 43599 put: #paddedSpace. 43600 SpaceCondition := a copy. 43601 SpaceCondition 43602 at: Space asciiValue + 1 43603 put: #space! ! 43604Collection subclass: #CharacterSet 43605 instanceVariableNames: 'map' 43606 classVariableNames: '' 43607 poolDictionaries: '' 43608 category: 'Collections-Support'! 43609!CharacterSet commentStamp: '<historical>' prior: 0! 43610A set of characters. Lookups for inclusion are very fast.! 43611 43612 43613!CharacterSet methodsFor: 'collection ops' stamp: 'nice 5/9/2006 23:20'! 43614add: aCharacter 43615 "I automatically become a WideCharacterSet if you add a wide character to myself" 43616 43617 aCharacter asciiValue >= 256 43618 ifTrue: [| wide | 43619 wide := WideCharacterSet new. 43620 wide addAll: self. 43621 wide add: aCharacter. 43622 self become: wide. 43623 ^aCharacter]. 43624 map at: aCharacter asciiValue + 1 put: 1. 43625 ^aCharacter! ! 43626 43627!CharacterSet methodsFor: 'collection ops' stamp: 'ar 4/9/2005 22:37'! 43628do: aBlock 43629 "evaluate aBlock with each character in the set" 43630 43631 Character allByteCharacters do: [ :c | 43632 (self includes: c) ifTrue: [ aBlock value: c ] ] 43633! ! 43634 43635!CharacterSet methodsFor: 'collection ops' stamp: 'nice 5/9/2006 23:09'! 43636includes: aCharacter 43637 aCharacter asciiValue >= 256 43638 ifTrue: ["Guard against wide characters" 43639 ^false]. 43640 ^(map at: aCharacter asciiValue + 1) > 0! ! 43641 43642!CharacterSet methodsFor: 'collection ops' stamp: 'nice 5/9/2006 23:20'! 43643remove: aCharacter 43644 aCharacter asciiValue >= 256 43645 ifFalse: ["Guard against wide characters" 43646 map at: aCharacter asciiValue + 1 put: 0]. 43647 ^aCharacter! ! 43648 43649!CharacterSet methodsFor: 'collection ops' stamp: 'nice 5/9/2006 23:02'! 43650size 43651 ^map sum! ! 43652 43653 43654!CharacterSet methodsFor: 'comparison' stamp: 'tk 7/5/2001 21:58'! 43655= anObject 43656 ^self species == anObject species and: [ 43657 self byteArrayMap = anObject byteArrayMap ]! ! 43658 43659!CharacterSet methodsFor: 'comparison' stamp: 'ls 8/17/1998 20:46'! 43660hash 43661 ^self byteArrayMap hash! ! 43662 43663!CharacterSet methodsFor: 'comparison' stamp: 'tk 7/5/2001 21:57'! 43664species 43665 ^CharacterSet! ! 43666 43667 43668!CharacterSet methodsFor: 'conversion' stamp: 'nice 3/23/2007 02:28'! 43669byteComplement 43670 "return a character set containing precisely the single byte characters the receiver does not" 43671 43672 | set | 43673 set := CharacterSet allCharacters. 43674 self do: [ :c | set remove: c ]. 43675 ^set! ! 43676 43677!CharacterSet methodsFor: 'conversion' stamp: 'nice 11/20/2007 00:19'! 43678complement 43679 "return a character set containing precisely the characters the receiver does not" 43680 43681 ^CharacterSetComplement of: self copy! ! 43682 43683 43684!CharacterSet methodsFor: 'copying' stamp: 'nice 11/20/2007 00:40'! 43685postCopy 43686 map := map copy! ! 43687 43688 43689!CharacterSet methodsFor: 'testing' stamp: 'nice 5/9/2006 23:23'! 43690hasWideCharacters 43691 ^false! ! 43692 43693 43694!CharacterSet methodsFor: 'private' stamp: 'ls 8/17/1998 20:35'! 43695byteArrayMap 43696 "return a ByteArray mapping each ascii value to a 1 if that ascii value is in the set, and a 0 if it isn't. Intended for use by primitives only" 43697 ^map! ! 43698 43699!CharacterSet methodsFor: 'private' stamp: 'alain.plantec 5/28/2009 09:44'! 43700initialize 43701 super initialize. 43702 map := ByteArray new: 256 withAll: 0.! ! 43703 43704!CharacterSet methodsFor: 'private' stamp: 'nice 5/9/2006 23:22'! 43705wideCharacterMap 43706 "used for comparing with WideCharacterSet" 43707 43708 | wide | 43709 wide := WideCharacterSet new. 43710 wide addAll: self. 43711 ^wide wideCharacterMap! ! 43712 43713"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 43714 43715CharacterSet class 43716 instanceVariableNames: ''! 43717 43718!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/17/1998 20:42'! 43719allCharacters 43720 "return a set containing all characters" 43721 43722 | set | 43723 set := self empty. 43724 0 to: 255 do: [ :ascii | set add: (Character value: ascii) ]. 43725 ^set! ! 43726 43727!CharacterSet class methodsFor: 'instance creation' stamp: 'nk 8/3/2004 06:54'! 43728empty 43729 "return an empty set of characters" 43730 ^self new! ! 43731 43732!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 1/3/1999 12:52'! 43733newFrom: aCollection 43734 | newCollection | 43735 newCollection := self new. 43736 newCollection addAll: aCollection. 43737 ^newCollection! ! 43738 43739!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/18/1998 00:40'! 43740nonSeparators 43741 "return a set containing everything but the whitespace characters" 43742 43743 ^self separators complement! ! 43744 43745!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/18/1998 00:40'! 43746separators 43747 "return a set containing just the whitespace characters" 43748 43749 | set | 43750 set := self empty. 43751 set addAll: Character separators. 43752 ^set! ! 43753Collection subclass: #CharacterSetComplement 43754 instanceVariableNames: 'absent byteArrayMapCache' 43755 classVariableNames: '' 43756 poolDictionaries: '' 43757 category: 'Collections-Support'! 43758!CharacterSetComplement commentStamp: 'nice 8/31/2008 14:53' prior: 0! 43759CharacterSetComplement is a space efficient implementation of (CharacterSet complement) taking care of WideCharacter (code > 255) 43760 43761However, it will maintain a byteArrayMap for character <= 255 in a cache keeping 43762 43763instance variables: 43764 absent <CharacterSet> contains character that are not in the set (i.e. my complement) 43765 byteArrayMapCache <ByteArray | nil> cache this information because it has to be used in tight loops where efficiency matters! 43766 43767 43768!CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 8/31/2008 14:56'! 43769add: aCharacter 43770 "a character is present if not absent, so adding a character is removing it from the absent" 43771 43772 (absent includes: aCharacter) 43773 ifTrue: 43774 [byteArrayMapCache := nil. 43775 absent remove: aCharacter]. 43776 ^ aCharacter! ! 43777 43778!CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 3/23/2007 02:11'! 43779do: aBlock 43780 "evaluate aBlock with each character in the set. 43781 don't do it, there are too many..." 43782 43783 self shouldNotImplement! ! 43784 43785!CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 3/23/2007 02:07'! 43786includes: aCharacter 43787 ^(absent includes: aCharacter) not! ! 43788 43789!CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 3/23/2007 02:15'! 43790reject: aBlock 43791 "Implementation note: rejecting present is selecting absent" 43792 43793 ^(absent select: aBlock) complement! ! 43794 43795!CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 8/31/2008 14:54'! 43796remove: aCharacter 43797 "This means aCharacter is now absent from myself. 43798 It must be added to my absent." 43799 43800 byteArrayMapCache := nil. 43801 ^absent add: aCharacter! ! 43802 43803!CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 1/10/2009 00:50'! 43804removeAll 43805 | newSet | 43806 newSet := CharacterSet new. 43807 self become: newSet! ! 43808 43809!CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 3/23/2007 02:15'! 43810select: aBlock 43811 "Implementation note: selecting present is rejecting absent" 43812 43813 ^(absent reject: aBlock) complement! ! 43814 43815!CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 3/23/2007 02:10'! 43816size 43817 "Is this 2**32-absent size ?" 43818 43819 ^self shouldNotImplement! ! 43820 43821 43822!CharacterSetComplement methodsFor: 'comparing' stamp: 'nice 3/23/2007 02:19'! 43823= anObject 43824 "Implementation note: we do not test if equal to a WideCharacterSet, 43825 because it is unlikely that WideCharacterSet is as complete as self" 43826 43827 ^self class == anObject class and: [ 43828 absent = anObject complement ]! ! 43829 43830!CharacterSetComplement methodsFor: 'comparing' stamp: 'marcus.denker 8/11/2008 20:45'! 43831hash 43832 ^absent hash bitXor: self class hash! ! 43833 43834 43835!CharacterSetComplement methodsFor: 'converting' stamp: 'nice 3/23/2007 02:08'! 43836complement 43837 "return a character set containing precisely the characters the receiver does not" 43838 43839 ^absent copy! ! 43840 43841 43842!CharacterSetComplement methodsFor: 'copying' stamp: 'nice 11/20/2007 01:08'! 43843postCopy 43844 absent := absent copy! ! 43845 43846 43847!CharacterSetComplement methodsFor: 'initialization' stamp: 'nice 8/31/2008 14:56'! 43848complement: aCharacterSet 43849 "initialize with the complement" 43850 43851 byteArrayMapCache := nil. 43852 absent := aCharacterSet. 43853 ! ! 43854 43855 43856!CharacterSetComplement methodsFor: 'printing' stamp: 'nice 11/19/2007 23:54'! 43857printOn: aStream 43858 "Print a description of the complement rather than self. 43859 Rationale: self would be too long to print." 43860 43861 aStream nextPut: $(. 43862 absent printOn: aStream. 43863 aStream nextPut: $); space; nextPutAll: #complement.! ! 43864 43865!CharacterSetComplement methodsFor: 'printing' stamp: 'nice 11/19/2007 23:55'! 43866storeOn: aStream 43867 "Store a description of the elements of the complement rather than self." 43868 43869 aStream nextPut: $(. 43870 absent storeOn: aStream. 43871 aStream nextPut: $); space; nextPutAll: #complement.! ! 43872 43873 43874!CharacterSetComplement methodsFor: 'testing' stamp: 'nice 3/23/2007 02:12'! 43875hasWideCharacters 43876 "This is a guess that absent is not holding each and every possible wideCharacter..." 43877 43878 ^true! ! 43879 43880 43881!CharacterSetComplement methodsFor: 'private' stamp: 'nice 8/31/2008 14:28'! 43882byteArrayMap 43883 "return a ByteArray mapping each ascii value to a 1 if that ascii value is in the set, and a 0 if it isn't. Intended for use by primitives only" 43884 43885 ^byteArrayMapCache ifNil: [byteArrayMapCache := absent byteArrayMap collect: [:i | 1 - i]]! ! 43886 43887"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 43888 43889CharacterSetComplement class 43890 instanceVariableNames: ''! 43891 43892!CharacterSetComplement class methodsFor: 'instance creation' stamp: 'nice 3/23/2007 02:25'! 43893of: aCharacterSet 43894 "answer the complement of aCharacterSet" 43895 43896 ^ super new complement: aCharacterSet! ! 43897TestCase subclass: #CharacterSetTest 43898 instanceVariableNames: '' 43899 classVariableNames: '' 43900 poolDictionaries: '' 43901 category: 'CollectionsTests-Support'! 43902!CharacterSetTest commentStamp: 'nice 11/20/2007 00:35' prior: 0! 43903CharacterSetTest holds tests for CharacterSet! 43904 43905 43906!CharacterSetTest methodsFor: 'testing' stamp: 'nice 11/20/2007 00:38'! 43907testCopy 43908 | theOriginal theCopy | 43909 theOriginal := CharacterSet newFrom: 'abc'. 43910 theCopy := theOriginal copy. 43911 theCopy remove: $a. 43912 ^self should: [theOriginal includes: $a] description: 'Changing the copy should not change the original'.! ! 43913ClassTestCase subclass: #CharacterTest 43914 instanceVariableNames: '' 43915 classVariableNames: '' 43916 poolDictionaries: '' 43917 category: 'CollectionsTests-Text'! 43918!CharacterTest commentStamp: '<historical>' prior: 0! 43919This is the unit test for the class Character. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 43920 - http://www.c2.com/cgi/wiki?UnitTest 43921 - http://minnow.cc.gatech.edu/squeak/1547 43922 - the sunit class category! 43923 43924 43925!CharacterTest methodsFor: 'testing - class methods' stamp: 'GabrielOmarCotelli 5/25/2009 16:02'! 43926testCodePoint 43927 43928 self assert: (Character codePoint: $a codePoint) = $a. 43929 self assert: (Character codePoint: 97) codePoint = 97.! ! 43930 43931!CharacterTest methodsFor: 'testing - class methods' stamp: 'GabrielOmarCotelli 5/29/2009 23:43'! 43932testInstanceCreation 43933 43934 self should: [ Character value: -1] raise: Error. 43935 43936 self shouldnt: [Character value: 0] raise: Error. 43937 self shouldnt: [Character value: 256] raise: Error! ! 43938 43939!CharacterTest methodsFor: 'testing - class methods' stamp: 'sd 6/5/2005 09:25'! 43940testNew 43941 43942 self should: [Character new] raise: Error.! ! 43943 43944 43945!CharacterTest methodsFor: 'testing-printing' stamp: 'stephane.ducasse 5/25/2008 15:47'! 43946testHex 43947 self assert: $a hex = '61'. 43948 self assert: Character space hex = '20'! ! 43949 43950!CharacterTest methodsFor: 'testing-printing' stamp: 'lr 11/21/2005 17:41'! 43951testPrintString 43952 self assert: $a printString = '$a'. 43953 self assert: $5 printString = '$5'. 43954 self assert: $@ printString = '$@'. 43955 43956 self assert: Character cr printString = 'Character cr'. 43957 self assert: Character lf printString = 'Character lf'. 43958 self assert: Character space printString = 'Character space'. 43959 43960 self assert: (Character value: 0) printString = 'Character value: 0'. 43961 self assert: (Character value: 17) printString = 'Character value: 17'.! ! 43962 43963!CharacterTest methodsFor: 'testing-printing' stamp: 'lr 11/21/2005 17:41'! 43964testPrintStringAll 43965 Character allCharacters do: [ :each | 43966 self assert: (self class compilerClass 43967 evaluate: each printString) = each ].! ! 43968 43969!CharacterTest methodsFor: 'testing-printing' stamp: 'lr 11/21/2005 17:22'! 43970testStoreString 43971 self assert: $a storeString = '$a'. 43972 self assert: $5 storeString = '$5'. 43973 self assert: $@ storeString = '$@'. 43974 43975 self assert: Character cr storeString = 'Character cr'. 43976 self assert: Character lf storeString = 'Character lf'. 43977 self assert: Character space storeString = 'Character space'. 43978 43979 self assert: (Character value: 0) storeString = '(Character value: 0)'. 43980 self assert: (Character value: 17) storeString = '(Character value: 17)'.! ! 43981 43982!CharacterTest methodsFor: 'testing-printing' stamp: 'lr 11/21/2005 17:24'! 43983testStoreStringAll 43984 Character allCharacters do: [ :each | 43985 self assert: (self class compilerClass 43986 evaluate: each storeString) = each ].! ! 43987ThreePhaseButtonMorph subclass: #CheckboxButtonMorph 43988 uses: TEnableOnHaloMenu 43989 instanceVariableNames: 'repressedImage enabled isRadioButton' 43990 classVariableNames: '' 43991 poolDictionaries: '' 43992 category: 'Polymorph-Widgets'! 43993!CheckboxButtonMorph commentStamp: 'gvc 5/23/2007 12:19' prior: 0! 43994Checkbox/radio - button only.! 43995 43996 43997!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 12/8/2008 19:17'! 43998adoptPaneColor: paneColor 43999 "Pass on to the border too." 44000 44001 super adoptPaneColor: paneColor. 44002 paneColor ifNil: [^self]. 44003 self fillStyle: self fillStyleToUse. 44004 self borderStyle: self borderStyleToUse. 44005 self cornerStyle: (self isRadioButton 44006 ifTrue: [self theme radioButtonCornerStyleFor: self] 44007 ifFalse: [self theme checkboxCornerStyleFor: self])! ! 44008 44009!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/27/2009 11:54'! 44010borderStyle: newStyle 44011 "Use narrowest image dimension." 44012 44013 | newExtent | 44014 self borderStyle = newStyle ifTrue: [^self]. 44015 super borderStyle: newStyle. 44016 newExtent := 2 * newStyle width + image extent min asPoint. 44017 bounds extent = newExtent ifFalse: [self extent: newExtent]! ! 44018 44019!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 11/5/2007 15:34'! 44020borderWidth: bw 44021 "Use narrowest image dimension." 44022 44023 | newExtent | 44024 super borderWidth: bw. 44025 newExtent := 2 * bw + image extent min asPoint. 44026 bounds extent = newExtent ifFalse: [super extent: newExtent]! ! 44027 44028!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 16:04'! 44029enabled 44030 "Answer the value of enabled" 44031 44032 ^ enabled! ! 44033 44034!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2009 14:11'! 44035enabled: anObject 44036 "Set the value of enabled" 44037 44038 enabled = anObject ifTrue: [^self]. 44039 enabled := anObject. 44040 self changed: #enabled. 44041 self 44042 adoptPaneColor: self paneColor; 44043 changed! ! 44044 44045!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 11/5/2007 15:28'! 44046image: anImage 44047 "Fixed to take account of border width. Use narrowest 44048 dimanesion of image to allow a little flexibility." 44049 44050 image := anImage depth = 1 44051 ifTrue: [ColorForm mappingWhiteToTransparentFrom: anImage] 44052 ifFalse: [anImage]. 44053 self extent: 2 * self borderWidth + image extent min asPoint. 44054 self changed! ! 44055 44056!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/25/2007 17:34'! 44057isRadioButton 44058 "Answer the value of isRadioButton" 44059 44060 ^ isRadioButton! ! 44061 44062!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/25/2007 17:34'! 44063isRadioButton: anObject 44064 "Set the value of isRadioButton" 44065 44066 isRadioButton := anObject! ! 44067 44068!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:17'! 44069repressedImage 44070 "Answer the value of repressedImage" 44071 44072 ^ repressedImage! ! 44073 44074!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:18'! 44075repressedImage: anObject 44076 "Set the value of repressedImage. This is shown when 44077 pressed after being off." 44078 44079 repressedImage := anObject. 44080 self invalidRect: self bounds! ! 44081 44082!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/25/2006 17:46'! 44083selected 44084 "Answer the state taking account of the intermediate states." 44085 44086 ^self state == #repressed or: [self state == #on]! ! 44087 44088!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 18:00'! 44089selected: aBoolean 44090 "Set the state taking account of the intermediate states." 44091 44092 (self state == #pressed or: [self state == #repressed]) 44093 ifTrue: [self state: (aBoolean ifTrue: [#repressed] ifFalse: [#pressed])] 44094 ifFalse: [self state: (aBoolean ifTrue: [#on] ifFalse: [#off])]! ! 44095 44096!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 16:41'! 44097state 44098 "Answer the state." 44099 44100 ^state! ! 44101 44102!CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 2/29/2008 21:53'! 44103state: newState 44104 "Change the image and invalidate the rect." 44105 44106 newState == state ifTrue: [^ self]. 44107 state := newState. 44108 self 44109 adoptPaneColor: self paneColor; 44110 changed! ! 44111 44112 44113!CheckboxButtonMorph methodsFor: 'as yet unclassified'! 44114addToggleItemsToHaloMenu: aCustomMenu 44115 "Add toggle-items to the halo menu" 44116 44117 super addToggleItemsToHaloMenu: aCustomMenu. 44118 aCustomMenu 44119 addUpdating: #enabledString 44120 target: self 44121 action: #toggleEnabled! ! 44122 44123!CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 19:16'! 44124beCheckbox 44125 "Change the images and square the border 44126 to be a checkbox." 44127 44128 self 44129 isRadioButton: false; 44130 onImage: self theme checkboxMarkerForm; 44131 cornerStyle: (self theme checkboxCornerStyleFor: self); 44132 borderStyle: self borderStyleToUse! ! 44133 44134!CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 19:16'! 44135beRadioButton 44136 "Change the images and round the border 44137 to be a radio button." 44138 44139 self 44140 isRadioButton: true; 44141 onImage: self theme radioButtonMarkerForm; 44142 cornerStyle: (self theme radioButtonCornerStyleFor: self); 44143 borderStyle: self borderStyleToUse! ! 44144 44145!CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/29/2008 22:05'! 44146borderStyleToUse 44147 "Answer the borderStyle that should be used for the receiver." 44148 44149 ^self isRadioButton 44150 ifTrue: [self radioBorderStyleToUse] 44151 ifFalse: [self checkboxBorderStyleToUse]! ! 44152 44153!CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/29/2008 22:05'! 44154checkboxBorderStyleToUse 44155 "Answer the borderStyle that should be used for the receiver when it is a checkbox." 44156 44157 ^self selected 44158 ifTrue: [self enabled 44159 ifTrue: [self theme checkboxButtonSelectedBorderStyleFor: self] 44160 ifFalse: [self theme checkboxButtonSelectedDisabledBorderStyleFor: self]] 44161 ifFalse: [self enabled 44162 ifTrue: [self theme checkboxButtonNormalBorderStyleFor: self] 44163 ifFalse: [self theme checkboxButtonDisabledBorderStyleFor: self]]! ! 44164 44165!CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/29/2008 22:04'! 44166checkboxFillStyleToUse 44167 "Answer the fillStyle that should be used for the receiver when it is a checkbox." 44168 44169 ^self selected 44170 ifTrue: [self enabled 44171 ifTrue: [self theme checkboxButtonSelectedFillStyleFor: self] 44172 ifFalse: [self theme checkboxButtonSelectedDisabledFillStyleFor: self]] 44173 ifFalse: [self enabled 44174 ifTrue: [self theme checkboxButtonNormalFillStyleFor: self] 44175 ifFalse: [self theme checkboxButtonDisabledFillStyleFor: self]]! ! 44176 44177!CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 11:38'! 44178colorToUse 44179 "Answer the color we should use." 44180 44181 ^self paneColor! ! 44182 44183!CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 14:16'! 44184disable 44185 "Disable the receiver." 44186 44187 self enabled: false! ! 44188 44189!CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 14:16'! 44190enable 44191 "Enable the receiver." 44192 44193 self enabled: true! ! 44194 44195!CheckboxButtonMorph methodsFor: 'as yet unclassified'! 44196enabledString 44197 "Answer the string to be shown in a menu to represent the 44198 'enabled' status" 44199 44200 ^ (self enabled 44201 ifTrue: ['<on>'] 44202 ifFalse: ['<off>']), 'enabled' translated! ! 44203 44204!CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/29/2008 21:56'! 44205fillStyleToUse 44206 "Answer the fillStyle that should be used for the receiver." 44207 44208 ^self isRadioButton 44209 ifTrue: [self radioFillStyleToUse] 44210 ifFalse: [self checkboxFillStyleToUse]! ! 44211 44212!CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 11:46'! 44213imageToUse 44214 "Answer the image we should use." 44215 44216 ^state caseOf: { 44217 [#off] -> [self offImage]. 44218 [#pressed] -> [self pressedImage]. 44219 [#on] -> [self onImage]. 44220 [#repressed] -> [self repressedImage ifNil: [self onImage]]} 44221 otherwise: []! ! 44222 44223!CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/29/2008 22:04'! 44224radioBorderStyleToUse 44225 "Answer the borderStyle that should be used for the receiver when it is a radio button." 44226 44227 ^self selected 44228 ifTrue: [self enabled 44229 ifTrue: [self theme radioButtonSelectedBorderStyleFor: self] 44230 ifFalse: [self theme radioButtonSelectedDisabledBorderStyleFor: self]] 44231 ifFalse: [self enabled 44232 ifTrue: [self theme radioButtonNormalBorderStyleFor: self] 44233 ifFalse: [self theme radioButtonDisabledBorderStyleFor: self]]! ! 44234 44235!CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/29/2008 21:58'! 44236radioFillStyleToUse 44237 "Answer the fillStyle that should be used for the receiver when it is a radio button." 44238 44239 ^self selected 44240 ifTrue: [self enabled 44241 ifTrue: [self theme radioButtonSelectedFillStyleFor: self] 44242 ifFalse: [self theme radioButtonSelectedDisabledFillStyleFor: self]] 44243 ifFalse: [self enabled 44244 ifTrue: [self theme radioButtonNormalFillStyleFor: self] 44245 ifFalse: [self theme radioButtonDisabledFillStyleFor: self]]! ! 44246 44247!CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 19:17'! 44248themeChanged 44249 "Update the on image." 44250 44251 self onImage: (self isRadioButton 44252 ifTrue: [self theme radioButtonMarkerForm] 44253 ifFalse: [self theme checkboxMarkerForm]). 44254 self adoptPaneColor: self paneColor. 44255 super themeChanged! ! 44256 44257!CheckboxButtonMorph methodsFor: 'as yet unclassified'! 44258toggleEnabled 44259 "Toggle the enabled state." 44260 44261 self enabled: self enabled not! ! 44262 44263 44264!CheckboxButtonMorph methodsFor: 'drawing' stamp: 'gvc 5/23/2007 11:48'! 44265drawOn: aCanvas 44266 "Draw the image for the current state." 44267 44268 |img| 44269 aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle. 44270 img := self imageToUse. 44271 img ifNotNil: [ 44272 aCanvas 44273 translucentImage: img 44274 at: self innerBounds center - (img extent // 2)]. 44275 (self state == #pressed or: [self state == #repressed]) ifTrue: [ 44276 aCanvas fillRectangle: self innerBounds fillStyle: (self paneColor alpha: 0.3)]. 44277 self enabled ifFalse: [aCanvas fillRectangle: self innerBounds fillStyle: (self paneColor alpha: 0.4)]! ! 44278 44279 44280!CheckboxButtonMorph methodsFor: 'event handling' stamp: 'gvc 9/18/2006 13:40'! 44281mouseDown: evt 44282 "Handle the transitions." 44283 44284 self enabled ifFalse: [^self perform: #mouseDown: withArguments: {evt} inSuperclass: Morph]. 44285 self isOn 44286 ifTrue: [self state: #repressed] 44287 ifFalse: [self state: #pressed]. 44288 actWhen == #buttonDown 44289 ifTrue: 44290 [self doButtonAction]. 44291 self mouseStillDown: evt.! ! 44292 44293!CheckboxButtonMorph methodsFor: 'event handling' stamp: 'gvc 8/17/2006 16:34'! 44294mouseMove: evt 44295 "Check for straying." 44296 44297 self enabled ifFalse: [^self perform: #mouseMove: withArguments: {evt} inSuperclass: Morph]. 44298 (self containsPoint: evt cursorPoint) 44299 ifTrue: [state == #on 44300 ifTrue: [self state: #repressed]. 44301 state == #off 44302 ifTrue: [self state: #pressed]. 44303 self perform: #mouseMove: withArguments: {evt} inSuperclass: Morph] 44304 "Allow on:send:to: to set the response to events other than actWhen" 44305 ifFalse: [state == #repressed 44306 ifTrue: [self state: #on]. 44307 state == #pressed 44308 ifTrue: [self state: #off]]. 44309! ! 44310 44311!CheckboxButtonMorph methodsFor: 'event handling' stamp: 'gvc 8/17/2006 16:35'! 44312mouseUp: evt 44313 "Allow on:send:to: to set the response to events other than actWhen" 44314 44315 self enabled ifFalse: [^self perform: #mouseUp: withArguments: {evt} inSuperclass: Morph]. 44316 actWhen == #buttonUp 44317 ifFalse: [^self perform: #mouseUp: withArguments: {evt} inSuperclass: Morph]. 44318 (self containsPoint: evt cursorPoint) 44319 ifTrue: [state == #repressed 44320 ifTrue: [self state: #off] 44321 ifFalse: [self state: #on]. 44322 self doButtonAction: evt] 44323 ifFalse: [target ifNotNil: [target mouseUpBalk: evt]]. 44324 ^self perform: #mouseDown: withArguments: {evt} inSuperclass: Morph! ! 44325 44326 44327!CheckboxButtonMorph methodsFor: 'initialization' stamp: 'gvc 10/25/2007 17:36'! 44328initialize 44329 "Initialize the receiver." 44330 44331 super initialize. 44332 self 44333 isRadioButton: false; 44334 enabled: true; 44335 onImage: self theme checkboxMarkerForm; 44336 fillStyle: self fillStyleToUse; 44337 borderStyle: self borderStyleToUse! ! 44338 44339"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 44340 44341CheckboxButtonMorph class 44342 uses: TEnableOnHaloMenu classTrait 44343 instanceVariableNames: ''! 44344 44345!CheckboxButtonMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 15:21'! 44346checkBox 44347 "Answer a button pre-initialized with checkbox images." 44348 44349 ^self new 44350 beCheckbox! ! 44351 44352!CheckboxButtonMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 15:21'! 44353radioButton 44354 "Answer a button pre-initialized with radio button images." 44355 44356 ^self new 44357 beRadioButton! ! 44358MorphicModel subclass: #CheckboxMorph 44359 uses: TEnableOnHaloMenu 44360 instanceVariableNames: 'buttonMorph labelMorph setStateSelector getStateSelector enabled getEnabledSelector' 44361 classVariableNames: '' 44362 poolDictionaries: '' 44363 category: 'Polymorph-Widgets'! 44364!CheckboxMorph commentStamp: 'gvc 5/18/2007 13:47' prior: 0! 44365Checkbox with box button and label with enablement support.! 44366 44367 44368!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 14:49'! 44369buttonMorph 44370 "Answer the value of buttonMorph" 44371 44372 ^ buttonMorph! ! 44373 44374!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/2/2007 16:11'! 44375buttonMorph: aMorph 44376 "Set the value of buttonMorph" 44377 44378 buttonMorph ifNotNil: [ 44379 self removeDependent: buttonMorph. 44380 buttonMorph delete]. 44381 buttonMorph := aMorph. 44382 self 44383 addDependent: aMorph; 44384 addMorphFront: aMorph! ! 44385 44386!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 14:49'! 44387enabled 44388 "Answer the value of enabled" 44389 44390 ^ enabled! ! 44391 44392!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/2/2007 16:06'! 44393enabled: aBoolean 44394 "Set the value of enabled" 44395 44396 enabled := aBoolean. 44397 self labelMorph ifNotNilDo: [:m | 44398 (m respondsTo: #enabled:) ifTrue: [ 44399 m enabled: aBoolean]]. 44400 self buttonMorph ifNotNilDo: [:m | m enabled: aBoolean]. 44401 self changed: #enabled! ! 44402 44403!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:58'! 44404font 44405 "Answer the label font" 44406 44407 ^self labelMorph font! ! 44408 44409!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:58'! 44410font: aFont 44411 "Set the label font" 44412 44413 self labelMorph font: aFont! ! 44414 44415!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:05'! 44416getEnabledSelector 44417 "Answer the value of getEnabledSelector" 44418 44419 ^ getEnabledSelector! ! 44420 44421!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 18:01'! 44422getEnabledSelector: anObject 44423 "Set the value of getEnabledSelector" 44424 44425 getEnabledSelector := anObject. 44426 self updateEnabled! ! 44427 44428!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 14:49'! 44429getStateSelector 44430 "Answer the value of getStateSelector" 44431 44432 ^ getStateSelector! ! 44433 44434!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 18:02'! 44435getStateSelector: anObject 44436 "Set the value of getStateSelector" 44437 44438 getStateSelector := anObject. 44439 self updateSelection! ! 44440 44441!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/2/2007 16:14'! 44442label 44443 "Answer the contents of the label morph." 44444 44445 ^(self labelMorph ifNil: [^'']) contents! ! 44446 44447!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/2/2007 16:13'! 44448label: aString 44449 "Set the contents of the label morph." 44450 44451 self labelMorph contents: aString. 44452 self labelMorph: self newLabel! ! 44453 44454!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 14:49'! 44455labelMorph 44456 "Answer the value of labelMorph" 44457 44458 ^ labelMorph! ! 44459 44460!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/2/2007 16:09'! 44461labelMorph: aMorph 44462 "Set the value of labelMorph" 44463 44464 labelMorph ifNotNil: [labelMorph delete]. 44465 labelMorph := aMorph. 44466 self addMorphBack: aMorph! ! 44467 44468!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:00'! 44469setStateSelector 44470 "Answer the value of setStateSelector" 44471 44472 ^ setStateSelector! ! 44473 44474!CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:00'! 44475setStateSelector: anObject 44476 "Set the value of setStateSelector" 44477 44478 setStateSelector := anObject! ! 44479 44480 44481!CheckboxMorph methodsFor: 'as yet unclassified'! 44482addToggleItemsToHaloMenu: aCustomMenu 44483 "Add toggle-items to the halo menu" 44484 44485 super addToggleItemsToHaloMenu: aCustomMenu. 44486 aCustomMenu 44487 addUpdating: #enabledString 44488 target: self 44489 action: #toggleEnabled! ! 44490 44491!CheckboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 15:38'! 44492beCheckbox 44493 "Change the button to be a checkbox." 44494 44495 self buttonMorph beCheckbox! ! 44496 44497!CheckboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 15:38'! 44498beRadioButton 44499 "Change the button to be a radio button." 44500 44501 self buttonMorph beRadioButton! ! 44502 44503!CheckboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 11:38'! 44504disable 44505 "Disable the receiver." 44506 44507 self enabled: false! ! 44508 44509!CheckboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 11:38'! 44510enable 44511 "Enable the receiver." 44512 44513 self enabled: true! ! 44514 44515!CheckboxMorph methodsFor: 'as yet unclassified'! 44516enabledString 44517 "Answer the string to be shown in a menu to represent the 44518 'enabled' status" 44519 44520 ^ (self enabled 44521 ifTrue: ['<on>'] 44522 ifFalse: ['<off>']), 'enabled' translated! ! 44523 44524!CheckboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/17/2006 15:14'! 44525isSelected 44526 "Answer whether the receiver is selected." 44527 44528 self model ifNil: [^false]. 44529 ^self model perform: (self getStateSelector ifNil: [^false])! ! 44530 44531!CheckboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/17/2006 18:03'! 44532newButtonMorph 44533 "Answer a new button morph" 44534 44535 ^CheckboxButtonMorph new 44536 target: self; 44537 actionSelector: #toggleSelected; 44538 vResizing: #shrinkWrap; 44539 hResizing: #shrinkWrap! ! 44540 44541!CheckboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 16:13'! 44542newLabel 44543 "Answer a new label morph" 44544 44545 ^self theme checkboxLabelFor: self! ! 44546 44547!CheckboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 16:14'! 44548newLabelMorph 44549 "Answer a new label morph" 44550 44551 ^self theme checkboxLabelFor: self! ! 44552 44553!CheckboxMorph methodsFor: 'as yet unclassified'! 44554toggleEnabled 44555 "Toggle the enabled state." 44556 44557 self enabled: self enabled not! ! 44558 44559!CheckboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/25/2006 14:35'! 44560toggleSelected 44561 "Toggle the selection state." 44562 44563 self enabled ifFalse: [^self]. 44564 self model ifNil: [^self]. 44565 (self setStateSelector ifNil: [^self]) numArgs = 0 44566 ifTrue: [self model perform: self setStateSelector]. 44567 self setStateSelector numArgs = 1 44568 ifTrue: [ self model perform: self setStateSelector with: self isSelected not]. 44569 self updateSelection 44570 ! ! 44571 44572 44573!CheckboxMorph methodsFor: 'drawing' stamp: 'gvc 5/22/2007 16:04'! 44574drawSubmorphsOn: aCanvas 44575 "Display submorphs back to front. 44576 Draw the focus here since we are using inset bounds 44577 for the focus rectangle." 44578 44579 super drawSubmorphsOn: aCanvas. 44580 self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOn: aCanvas]! ! 44581 44582 44583!CheckboxMorph methodsFor: 'event handling' stamp: 'gvc 1/16/2007 15:20'! 44584handlesKeyboard: evt 44585 "Yes, we do it here." 44586 44587 ^true! ! 44588 44589!CheckboxMorph methodsFor: 'event handling' stamp: 'gvc 5/22/2007 16:11'! 44590keyStroke: event 44591 "Process keys navigation and space to toggle." 44592 44593 (self navigationKey: event) ifTrue: [^self]. 44594 event keyCharacter = Character space 44595 ifTrue: [self toggleSelected]! ! 44596 44597!CheckboxMorph methodsFor: 'event handling' stamp: 'gvc 9/6/2007 14:37'! 44598keyboardFocusChange: aBoolean 44599 "The message is sent to a morph when its keyboard focus changes. 44600 Update for focus feedback." 44601 44602 self focusChanged! ! 44603 44604 44605!CheckboxMorph methodsFor: 'focus handling' stamp: 'gvc 1/11/2007 12:28'! 44606takesKeyboardFocus 44607 "Answer whether the receiver can normally take keyboard focus." 44608 44609 ^true! ! 44610 44611 44612!CheckboxMorph methodsFor: 'initialization' stamp: 'gvc 8/2/2007 16:11'! 44613initialize 44614 "Initialize the receiver." 44615 44616 super initialize. 44617 self 44618 borderWidth: 2; "space for focus" 44619 borderColor: Color transparent; 44620 enabled: true; 44621 changeTableLayout; 44622 listDirection: #leftToRight; 44623 wrapCentering: #center; 44624 cellInset: 8; 44625 buttonMorph: self newButtonMorph; 44626 labelMorph: self newLabelMorph; 44627 on: #mouseDown send: #updateButton: to: self; 44628 on: #mouseMove send: #updateButton: to: self; 44629 on: #mouseUp send: #updateButton: to: self! ! 44630 44631!CheckboxMorph methodsFor: 'initialization' stamp: 'gvc 8/17/2006 18:01'! 44632on: anObject selected: getSelectionSel changeSelected: setSelectionSel 44633 "Set the receiver to the given model parameterized by the given message selectors." 44634 44635 self 44636 model: anObject; 44637 getStateSelector: getSelectionSel; 44638 setStateSelector: setSelectionSel; 44639 updateSelection! ! 44640 44641 44642!CheckboxMorph methodsFor: 'updating' stamp: 'gvc 8/17/2006 17:58'! 44643update: aSymbol 44644 "Refer to the comment in View|update:." 44645 44646 aSymbol == self getStateSelector ifTrue: 44647 [self updateSelection. 44648 ^ self]. 44649 aSymbol == self getEnabledSelector ifTrue: 44650 [self updateEnabled. 44651 ^ self]! ! 44652 44653!CheckboxMorph methodsFor: 'updating' stamp: 'gvc 8/17/2006 18:06'! 44654updateButton: evt 44655 "Update the button due to mouse activity in the receiver." 44656 44657 self enabled ifFalse: [^self]. 44658 evt isMouseDown ifTrue: [ 44659 self buttonMorph state == #on ifTrue: [^self buttonMorph state: #repressed]. 44660 self buttonMorph state == #off ifTrue: [^self buttonMorph state: #pressed]]. 44661 evt isMouseUp ifTrue: [ 44662 self buttonMorph state == #repressed ifTrue: [ 44663 ^self buttonMorph state: #off; doButtonAction]. 44664 self buttonMorph state == #pressed ifTrue: [ 44665 ^self buttonMorph state: #on; doButtonAction]]. 44666 evt isMove ifTrue: [ 44667 (self containsPoint: evt cursorPoint) 44668 ifTrue: [self buttonMorph state == #on ifTrue: [^self buttonMorph state: #repressed]. 44669 self buttonMorph state == #off ifTrue: [^self buttonMorph state: #pressed]] 44670 ifFalse: [self buttonMorph state == #repressed ifTrue: [^self buttonMorph state: #on]. 44671 self buttonMorph state == #pressed ifTrue: [^self buttonMorph state: #off]]]! ! 44672 44673!CheckboxMorph methodsFor: 'updating' stamp: 'gvc 9/8/2009 13:25'! 44674updateEnabled 44675 "Update the enablement state." 44676 44677 self model ifNotNil: [ 44678 self getEnabledSelector ifNotNil: [ 44679 self enabled: (self model perform: self getEnabledSelector)]]! ! 44680 44681!CheckboxMorph methodsFor: 'updating' stamp: 'gvc 8/17/2006 17:58'! 44682updateSelection 44683 "Update the selection state." 44684 44685 self buttonMorph ifNotNilDo: [:m | m selected: self isSelected]. 44686 self changed: #isSelected! ! 44687 44688"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 44689 44690CheckboxMorph class 44691 uses: TEnableOnHaloMenu classTrait 44692 instanceVariableNames: ''! 44693 44694!CheckboxMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 8/17/2006 16:50'! 44695on: anObject selected: getSelectionSel changeSelected: setSelectionSel 44696 "Answer a new instance of the receiver on the given model using 44697 the given selectors as the interface." 44698 44699 ^self new 44700 on: anObject 44701 selected: getSelectionSel 44702 changeSelected: setSelectionSel! ! 44703MessageDialogWindow subclass: #ChooseDropListDialogWindow 44704 instanceVariableNames: 'listMorph list' 44705 classVariableNames: '' 44706 poolDictionaries: '' 44707 category: 'Polymorph-Widgets-Windows'! 44708!ChooseDropListDialogWindow commentStamp: 'gvc 5/18/2007 13:46' prior: 0! 44709Message dialog containing a drop list for selection of an item.! 44710 44711 44712!ChooseDropListDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/12/2007 14:15'! 44713list 44714 "Answer the value of list" 44715 44716 ^ list! ! 44717 44718!ChooseDropListDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/12/2007 15:21'! 44719list: anObject 44720 "Set the value of list" 44721 44722 list := anObject. 44723 self 44724 changed: #list; 44725 changed: #selectionIndex! ! 44726 44727!ChooseDropListDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/12/2007 14:17'! 44728listMorph 44729 "Answer the value of listMorph" 44730 44731 ^ listMorph! ! 44732 44733!ChooseDropListDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/12/2007 14:17'! 44734listMorph: anObject 44735 "Set the value of listMorph" 44736 44737 listMorph := anObject! ! 44738 44739 44740!ChooseDropListDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 10:27'! 44741icon 44742 "Answer an icon for the receiver." 44743 44744 ^self theme questionIcon! ! 44745 44746!ChooseDropListDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 14:35'! 44747initialize 44748 "Initialize the receiver." 44749 44750 self list: #(). 44751 super initialize! ! 44752 44753!ChooseDropListDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/29/2007 13:32'! 44754newContentMorph 44755 "Answer a new content morph." 44756 44757 self iconMorph: self newIconMorph. 44758 self textMorph: self newTextMorph. 44759 self listMorph: self newListMorph. 44760 ^self newGroupboxForAll: { 44761 self newRow: {self iconMorph. self textMorph}. 44762 self listMorph}! ! 44763 44764!ChooseDropListDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 14:17'! 44765newListMorph 44766 "Answer a new drop-list morph." 44767 44768 ^self 44769 newDropListFor: self 44770 list: #list 44771 getSelected: #selectionIndex 44772 setSelected: nil 44773 getEnabled: nil 44774 help: nil! ! 44775 44776!ChooseDropListDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 14:22'! 44777selectedItem 44778 "Answer the selected list item or nil if cancelled." 44779 44780 ^self cancelled ifFalse: [self listMorph selectedItem]! ! 44781 44782!ChooseDropListDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 14:15'! 44783selectionIndex 44784 "Answer the initial selection index for the list." 44785 44786 ^self list ifEmpty: [0] ifNotEmpty: [1]! ! 44787 44788"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 44789 44790ChooseDropListDialogWindow class 44791 instanceVariableNames: ''! 44792 44793!ChooseDropListDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 11:50'! 44794taskbarIcon 44795 "Answer the icon for the receiver in a task bar." 44796 44797 ^self theme smallQuestionIcon! ! 44798SharedPool subclass: #ChronologyConstants 44799 instanceVariableNames: '' 44800 classVariableNames: 'DayNames DaysInMonth MonthNames NanosInMillisecond NanosInSecond SecondsInDay SecondsInHour SecondsInMinute SqueakEpoch' 44801 poolDictionaries: '' 44802 category: 'Kernel-Chronology'! 44803!ChronologyConstants commentStamp: 'brp 3/12/2004 14:34' prior: 0! 44804ChronologyConstants is a SharedPool for the constants used by the Kernel-Chronology classes.! 44805 44806 44807"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 44808 44809ChronologyConstants class 44810 instanceVariableNames: ''! 44811 44812!ChronologyConstants class methodsFor: 'class initialization' stamp: 'brp 9/25/2003 10:49'! 44813initialize 44814 "ChronologyConstants initialize" SqueakEpoch := 2415386. "Julian day number of 1 Jan 1901" 44815 SecondsInDay := 86400. 44816 SecondsInHour := 3600. 44817 SecondsInMinute := 60. 44818 NanosInSecond := 10 raisedTo: 9. 44819 NanosInMillisecond := 10 raisedTo: 6. 44820 DayNames := #(Sunday Monday Tuesday Wednesday Thursday Friday Saturday). 44821 44822 MonthNames := #(January February March April May June July 44823 August September October November December). 44824 DaysInMonth := #(31 28 31 30 31 30 31 31 30 31 30 31). 44825! ! 44826Arc subclass: #Circle 44827 instanceVariableNames: '' 44828 classVariableNames: '' 44829 poolDictionaries: '' 44830 category: 'ST80-Paths'! 44831!Circle commentStamp: '<historical>' prior: 0! 44832I represent a full circle. I am made from four Arcs.! 44833 44834 44835!Circle methodsFor: 'display box access'! 44836computeBoundingBox 44837 44838 ^center - radius + form offset extent: form extent + (radius * 2) asPoint! ! 44839 44840 44841!Circle methodsFor: 'displaying'! 44842displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm 44843 44844 1 to: 4 do: 44845 [:i | 44846 super quadrant: i. 44847 super displayOn: aDisplayMedium 44848 at: aPoint 44849 clippingBox: clipRect 44850 rule: anInteger 44851 fillColor: aForm]! ! 44852 44853!Circle methodsFor: 'displaying'! 44854displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm 44855 44856 1 to: 4 do: 44857 [:i | 44858 super quadrant: i. 44859 super displayOn: aDisplayMedium 44860 transformation: aTransformation 44861 clippingBox: clipRect 44862 rule: anInteger 44863 fillColor: aForm]! ! 44864 44865"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 44866 44867Circle class 44868 instanceVariableNames: ''! 44869 44870!Circle class methodsFor: 'examples'! 44871exampleOne 44872 "Click any button somewhere on the screen. The point will be the center 44873 of the circcle of radius 150." 44874 44875 | aCircle aForm | 44876 aForm := Form extent: 1@30. 44877 aForm fillBlack. 44878 aCircle := Circle new. 44879 aCircle form: aForm. 44880 aCircle radius: 150. 44881 aCircle center: Sensor waitButton. 44882 aCircle displayOn: Display 44883 44884 "Circle exampleOne"! ! 44885 44886!Circle class methodsFor: 'examples'! 44887exampleTwo 44888 "Designate a rectangular area that should be used as the brush for 44889 displaying the circle. Click any button at a point on the screen which 44890 will be the center location for the circle. The curve will be displayed 44891 with a long black form." 44892 44893 | aCircle aForm | 44894 aForm := Form fromUser. 44895 aCircle := Circle new. 44896 aCircle form: aForm. 44897 aCircle radius: 150. 44898 aCircle center: Sensor waitButton. 44899 aCircle displayOn: Display at: 0 @ 0 rule: Form reverse 44900 44901 "Circle exampleTwo"! ! 44902EllipseMorph subclass: #CircleMorph 44903 instanceVariableNames: '' 44904 classVariableNames: '' 44905 poolDictionaries: '' 44906 category: 'Morphic-Basic'! 44907!CircleMorph commentStamp: '<historical>' prior: 0! 44908I am a specialization of EllipseMorph that knows enough to remain circular. 44909! 44910 44911 44912!CircleMorph methodsFor: 'geometry' stamp: 'nk 7/1/2002 07:01'! 44913bounds: aRectangle 44914 | size | 44915 size := aRectangle width min: aRectangle height. 44916 super bounds: (Rectangle origin: aRectangle origin extent: size @ size).! ! 44917 44918!CircleMorph methodsFor: 'geometry' stamp: 'nk 7/1/2002 16:39'! 44919extent: aPoint 44920 | size oldRotationCenter | 44921 oldRotationCenter := self rotationCenter. 44922 size := aPoint x min: aPoint y. 44923 super extent: size @ size. 44924 self rotationCenter: oldRotationCenter.! ! 44925 44926!CircleMorph methodsFor: 'geometry' stamp: 'nk 7/1/2002 08:49'! 44927transformedBy: aTransform 44928 aTransform isIdentity ifTrue:[^self]. 44929 ^self center: (aTransform localPointToGlobal: self center). 44930! ! 44931 44932 44933!CircleMorph methodsFor: 'geometry etoy' stamp: 'nk 7/1/2002 07:12'! 44934heading: newHeading 44935 "Set the receiver's heading (in eToy terms). 44936 Note that circles never use flex shells." 44937 self rotationDegrees: newHeading.! ! 44938 44939!CircleMorph methodsFor: 'geometry etoy' stamp: 'nk 7/1/2002 07:31'! 44940referencePosition 44941 "Return the current reference position of the receiver" 44942 ^ self valueOfProperty: #referencePosition ifAbsent: [ self center ] 44943! ! 44944 44945!CircleMorph methodsFor: 'geometry etoy' stamp: 'nk 7/1/2002 11:16'! 44946rotationCenter 44947 "Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." 44948 | refPos | 44949 refPos := self referencePosition. 44950 ^ (refPos - self bounds origin) / self bounds extent asFloatPoint! ! 44951 44952!CircleMorph methodsFor: 'geometry etoy' stamp: 'nk 7/1/2002 13:48'! 44953rotationCenter: aPointOrNil 44954 "Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." 44955 | newRef box | 44956 aPointOrNil isNil 44957 ifTrue: [self removeProperty: #referencePosition. 44958 self removeProperty: #originalCenter. 44959 self removeProperty: #originalAngle. ] 44960 ifFalse: [ box := self bounds. 44961 newRef := box origin + (aPointOrNil * box extent). 44962 self setRotationCenterFrom: newRef ]. 44963 44964! ! 44965 44966 44967!CircleMorph methodsFor: 'menus' stamp: 'nk 7/1/2002 11:30'! 44968setRotationCenterFrom: aPoint 44969 "Called by halo rotation code. 44970 Circles store their referencePosition." 44971 self setProperty: #referencePosition toValue: aPoint. 44972 self setProperty: #originalCenter toValue: self center. 44973 self setProperty: #originalAngle toValue: self heading.! ! 44974 44975 44976!CircleMorph methodsFor: 'parts bin' stamp: 'alain.plantec 5/28/2009 09:46'! 44977initialize 44978 super initialize. 44979 self extent: 40@40; 44980 color: Color green lighter; 44981 yourself! ! 44982 44983!CircleMorph methodsFor: 'parts bin' stamp: 'nk 7/1/2002 16:42'! 44984initializeToStandAlone 44985 ^super initializeToStandAlone 44986 extent: 40@40; 44987 color: Color green lighter; 44988 yourself! ! 44989 44990 44991!CircleMorph methodsFor: 'rotate scale and flex' stamp: 'nk 7/1/2002 07:04'! 44992addFlexShellIfNecessary 44993 "When scaling or rotating from a halo, I can do this without a flex shell" 44994 44995 ^ self 44996! ! 44997 44998!CircleMorph methodsFor: 'rotate scale and flex' stamp: 'nk 7/1/2002 16:29'! 44999privateMoveBy: delta 45000 self setProperty: #referencePosition toValue: self referencePosition + delta. 45001 self setProperty: #originalCenter toValue: (self valueOfProperty: #originalCenter ifAbsent: [ self center ]) + delta. 45002 super privateMoveBy: delta. 45003! ! 45004 45005!CircleMorph methodsFor: 'rotate scale and flex' stamp: 'nk 7/1/2002 07:28'! 45006rotationDegrees 45007 45008 ^ self forwardDirection! ! 45009 45010!CircleMorph methodsFor: 'rotate scale and flex' stamp: 'nk 7/1/2002 15:52'! 45011rotationDegrees: degrees 45012 | ref newPos flex origAngle origCenter | 45013 ref := self referencePosition. 45014 origAngle := self valueOfProperty: #originalAngle ifAbsentPut: [ self heading ]. 45015 origCenter := self valueOfProperty: #originalCenter ifAbsentPut: [ self center ]. 45016 flex := (MorphicTransform offset: ref negated) 45017 withAngle: (degrees - origAngle) degreesToRadians. 45018 newPos := (flex transform: origCenter) - flex offset. 45019 self position: (self position + newPos - self center) asIntegerPoint. 45020 self setProperty: #referencePosition toValue: ref. 45021 self setProperty: #originalAngle toValue: origAngle. 45022 self setProperty: #originalCenter toValue: origCenter. 45023 self forwardDirection: degrees. 45024 self changed. 45025! ! 45026TestCase subclass: #CircleMorphBugs 45027 instanceVariableNames: '' 45028 classVariableNames: '' 45029 poolDictionaries: '' 45030 category: 'Tests-Bugs'! 45031 45032!CircleMorphBugs methodsFor: 'as yet unclassified' stamp: 'wiz 4/18/2007 00:57'! 45033testCircleInstance 45034"" 45035"self run: #testCircleInstance" 45036 45037| circ | 45038self assert: (circ := CircleMorph initializedInstance) extent = circ extent x asPoint 45039 45040! ! 45041MorphTest subclass: #CircleMorphTest 45042 instanceVariableNames: '' 45043 classVariableNames: '' 45044 poolDictionaries: '' 45045 category: 'MorphicTests-Basic'! 45046!CircleMorphTest commentStamp: 'tlk 5/21/2006 14:16' prior: 0! 45047A CircleMorphTest is a subclass of MorphTest. It was first implemented when removing some unused and broken functionality. 45048 45049My fixtures are morph, a CircleMorph and world. 45050! 45051 45052 45053!CircleMorphTest methodsFor: 'initialization' stamp: 'tlk 5/21/2006 14:17'! 45054setUp 45055 morph := CircleMorph new! ! 45056ClassDescription subclass: #Class 45057 uses: TBehaviorCategorization 45058 instanceVariableNames: 'subclasses name classPool sharedPools environment category traitComposition localSelectors' 45059 classVariableNames: '' 45060 poolDictionaries: '' 45061 category: 'Kernel-Classes'! 45062!Class commentStamp: '<historical>' prior: 0! 45063I add a number of facilities to those in ClassDescription: 45064 A set of all my subclasses (defined in ClassDescription, but only used here and below) 45065 A name by which I can be found in a SystemDictionary 45066 A classPool for class variables shared between this class and its metaclass 45067 A list of sharedPools which probably should be supplanted by some better mechanism. 45068 45069My instances describe the representation and behavior of objects. I add more comprehensive programming support facilities to the basic attributes of Behavior and the descriptive facilities of ClassDescription. 45070 45071The slot 'subclasses' is a redundant structure. It is never used during execution, but is used by the development system to simplify or speed certain operations. ! 45072 45073 45074!Class methodsFor: '*monticello' stamp: 'al 3/26/2006 21:31'! 45075asClassDefinition 45076 ^ MCClassDefinition 45077 name: self name 45078 superclassName: self superclass name 45079 traitComposition: self traitCompositionString 45080 classTraitComposition: self class traitCompositionString 45081 category: self category 45082 instVarNames: self instVarNames 45083 classVarNames: self classVarNames 45084 poolDictionaryNames: self poolDictionaryNames 45085 classInstVarNames: self class instVarNames 45086 type: self typeOfClass 45087 comment: self organization classComment asString 45088 commentStamp: self organization commentStamp ! ! 45089 45090!Class methodsFor: '*monticello' stamp: 'avi 3/10/2004 13:32'! 45091classDefinitions 45092 ^ Array with: self asClassDefinition! ! 45093 45094!Class methodsFor: '*monticello' stamp: 'ab 4/14/2003 22:30'! 45095poolDictionaryNames 45096 ^ self sharedPools collect: [:ea | self environment keyAtIdentityValue: ea]! ! 45097 45098 45099!Class methodsFor: 'accessing' stamp: 'al 3/18/2006 13:23'! 45100basicCategory 45101 ^category! ! 45102 45103!Class methodsFor: 'accessing' stamp: 'al 3/18/2006 13:23'! 45104basicCategory: aSymbol 45105 category := aSymbol! ! 45106 45107!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'! 45108basicLocalSelectors 45109 "Direct accessor for the instance variable localSelectors. 45110 Since localSelectors is lazily initialized, this may 45111 return nil, which means that all selectors are local." 45112 45113 ^ localSelectors! ! 45114 45115!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'! 45116basicLocalSelectors: aSetOrNil 45117 localSelectors := aSetOrNil! ! 45118 45119!Class methodsFor: 'accessing'! 45120classPool 45121 "Answer the dictionary of class variables." 45122 45123 classPool == nil 45124 ifTrue: [^Dictionary new] 45125 ifFalse: [^classPool]! ! 45126 45127!Class methodsFor: 'accessing' stamp: 'BG 8/11/2002 20:53'! 45128classPoolFrom: aClass 45129 "share the classPool with aClass." 45130 45131 classPool := aClass classPool! ! 45132 45133!Class methodsFor: 'accessing' stamp: 'al 9/3/2004 13:37'! 45134classPool: aDictionary 45135 classPool := aDictionary! ! 45136 45137!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 12:38'! 45138hasTraitComposition 45139 ^traitComposition notNil! ! 45140 45141!Class methodsFor: 'accessing'! 45142name 45143 "Answer the name of the receiver." 45144 45145 name == nil 45146 ifTrue: [^super name] 45147 ifFalse: [^name]! ! 45148 45149!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 12:35'! 45150traitComposition 45151 traitComposition ifNil: [traitComposition := TraitComposition new]. 45152 ^traitComposition! ! 45153 45154!Class methodsFor: 'accessing' stamp: 'al 3/25/2006 12:37'! 45155traitComposition: aTraitComposition 45156 traitComposition := aTraitComposition! ! 45157 45158 45159!Class methodsFor: 'accessing class hierarchy' stamp: 'tk 10/17/1999 13:31'! 45160addSubclass: aSubclass 45161 "Make the argument, aSubclass, be one of the subclasses of the receiver. 45162 Create an error notification if the argument's superclass is not the receiver." 45163 45164 aSubclass superclass ~~ self 45165 ifTrue: [^self error: aSubclass name , ' is not my subclass']. 45166 subclasses == nil 45167 ifTrue: [subclasses := Array with: aSubclass. 45168 ^self]. 45169 subclasses do:[:cl| cl == aSubclass ifTrue:[^self]]. "Already my subclass" 45170 subclasses := subclasses copyWith: aSubclass.! ! 45171 45172!Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 10:54'! 45173removeSubclass: aSubclass 45174 "If the argument, aSubclass, is one of the receiver's subclasses, remove it." 45175 45176 subclasses == nil ifFalse: 45177 [subclasses := subclasses copyWithout: aSubclass. 45178 subclasses isEmpty ifTrue: [subclasses := nil]]. 45179! ! 45180 45181!Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 11:00'! 45182subclasses 45183 "Answer a Set containing the receiver's subclasses." 45184 45185 ^subclasses == nil 45186 ifTrue: [#()] 45187 ifFalse: [subclasses copy]! ! 45188 45189!Class methodsFor: 'accessing class hierarchy' stamp: 'tk 8/18/1999 17:42'! 45190subclassesDoGently: aBlock 45191 "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." 45192 subclasses == nil 45193 ifFalse: [subclasses do: aBlock]! ! 45194 45195!Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 11:00'! 45196subclassesDo: aBlock 45197 "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." 45198 subclasses == nil 45199 ifFalse:[subclasses do: aBlock]! ! 45200 45201 45202!Class methodsFor: 'class name' stamp: 'sw 12/1/2000 20:39'! 45203externalName 45204 "Answer a name by which the receiver can be known." 45205 45206 ^ name! ! 45207 45208!Class methodsFor: 'class name' stamp: 'sw 12/18/2000 15:50'! 45209nameForViewer 45210 "Answer the name to be shown in the header of a viewer looking at the receiver" 45211 45212 ^ self name ifNil: ['Unnamed class']! ! 45213 45214!Class methodsFor: 'class name' stamp: 'rw 10/7/2006 08:30'! 45215rename: aString 45216 "The new name of the receiver is the argument, aString." 45217 45218 | oldName newName | 45219 (newName := aString asSymbol) = (oldName := self name) 45220 ifTrue: [^ self]. 45221 (self environment includesKey: newName) 45222 ifTrue: [^ self error: newName , ' already exists']. 45223 (Undeclared includesKey: newName) 45224 ifTrue: [self inform: 'There are references to, ' , aString printString , ' 45225from Undeclared. Check them after this change.']. 45226 name := newName. 45227 self environment renameClass: self from: oldName! ! 45228 45229 45230!Class methodsFor: 'class variables' stamp: 'dvf 9/27/2005 17:32'! 45231addClassVarName: aString 45232 "Add the argument, aString, as a class variable of the receiver. 45233 Signal an error if the first character of aString is not capitalized, 45234 or if it is already a variable named in the class." 45235 | symbol oldState | 45236 oldState := self copy. 45237 aString first canBeGlobalVarInitial 45238 ifFalse: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. 45239 symbol := aString asSymbol. 45240 self withAllSubclasses do: 45241 [:subclass | 45242 (subclass bindingOf: symbol) ifNotNil:[ 45243 ^ self error: aString 45244 , ' is already used as a variable name in class ' 45245 , subclass name]]. 45246 classPool == nil ifTrue: [classPool := Dictionary new]. 45247 (classPool includesKey: symbol) ifFalse: 45248 ["Pick up any refs in Undeclared" 45249 classPool declare: symbol from: Undeclared. 45250 SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldState to: self]! ! 45251 45252!Class methodsFor: 'class variables' stamp: 'al 9/3/2004 14:25'! 45253allClassVarNames 45254 "Answer a Set of the names of the receiver's class variables, including those 45255 defined in the superclasses of the receiver." 45256 45257 | aSet | 45258 self superclass == nil 45259 ifTrue: 45260 [^self classVarNames] "This is the keys so it is a new Set." 45261 ifFalse: 45262 [aSet := self superclass allClassVarNames. 45263 aSet addAll: self classVarNames. 45264 ^aSet]! ! 45265 45266!Class methodsFor: 'class variables' stamp: 'al 9/3/2004 14:25'! 45267classVarNames 45268 "Answer a Set of the names of the class variables defined in the receiver." 45269 45270 ^self classPool keys! ! 45271 45272!Class methodsFor: 'class variables' stamp: 'tk 3/15/98 20:19'! 45273ensureClassPool 45274 45275 classPool ifNil: [classPool := Dictionary new].! ! 45276 45277!Class methodsFor: 'class variables' stamp: 'bf 1/12/2006 10:44'! 45278removeClassVarName: aString 45279 "Remove the class variable whose name is the argument, aString, from 45280 the names defined in the receiver, a class. Create an error notification if 45281 aString is not a class variable or if it is still being used in the code of 45282 the class." 45283 45284 | aSymbol | 45285 aSymbol := aString asSymbol. 45286 (classPool includesKey: aSymbol) 45287 ifFalse: [^self error: aString, ' is not a class variable']. 45288 self withAllSubclasses do:[:subclass | 45289 (Array with: subclass with: subclass class) do:[:classOrMeta | 45290 (classOrMeta whichSelectorsReferTo: (classPool associationAt: aSymbol)) 45291 isEmpty ifFalse: [ 45292 InMidstOfFileinNotification signal ifTrue: [ 45293 Transcript cr; show: self name, ' (' , aString , ' is Undeclared) '. 45294 ^Undeclared declare: aSymbol from: classPool]. 45295 (self confirm: (aString,' is still used in code of class ', classOrMeta name, 45296 '.\Is it okay to move it to Undeclared?') withCRs) 45297 ifTrue:[^Undeclared declare: aSymbol from: classPool] 45298 ifFalse:[^self]]]]. 45299 classPool removeKey: aSymbol. 45300 classPool isEmpty ifTrue: [classPool := nil]. 45301! ! 45302 45303 45304!Class methodsFor: 'compiling' stamp: 'md 3/5/2006 23:47'! 45305binding 45306 45307 ^ Smalltalk associationAt: name ifAbsent: [nil -> self] 45308! ! 45309 45310!Class methodsFor: 'compiling' stamp: 'ar 5/17/2003 14:06'! 45311bindingOf: varName 45312 "Answer the binding of some variable resolved in the scope of the receiver" 45313 | aSymbol binding | 45314 aSymbol := varName asSymbol. 45315 45316 "First look in classVar dictionary." 45317 binding := self classPool bindingOf: aSymbol. 45318 binding ifNotNil:[^binding]. 45319 45320 "Next look in shared pools." 45321 self sharedPools do:[:pool | 45322 binding := pool bindingOf: aSymbol. 45323 binding ifNotNil:[^binding]. 45324 ]. 45325 45326 "Next look in declared environment." 45327 binding := self environment bindingOf: aSymbol. 45328 binding ifNotNil:[^binding]. 45329 45330 "Finally look higher up the superclass chain and fail at the end." 45331 superclass == nil 45332 ifTrue: [^ nil] 45333 ifFalse: [^ superclass bindingOf: aSymbol]. 45334 45335! ! 45336 45337!Class methodsFor: 'compiling' stamp: 'ar 5/17/2003 14:13'! 45338canFindWithoutEnvironment: varName 45339 "This method is used for analysis of system structure -- see senders." 45340 "Look up varName, in the context of the receiver. Return true if it can be found without using the declared environment." 45341 45342 "First look in classVar dictionary." 45343 (self classPool bindingOf: varName) ifNotNil:[^true]. 45344 45345 "Next look in shared pools." 45346 self sharedPools do:[:pool | 45347 (pool bindingOf: varName) ifNotNil:[^true]. 45348 ]. 45349 45350 "Finally look higher up the superclass chain and fail at the end." 45351 superclass == nil 45352 ifTrue: [^ false] 45353 ifFalse: [^ (superclass bindingOf: varName) notNil]. 45354 45355! ! 45356 45357!Class methodsFor: 'compiling' stamp: 'ar 7/14/1999 04:56'! 45358compileAll 45359 super compileAll. 45360 self class compileAll.! ! 45361 45362!Class methodsFor: 'compiling'! 45363compileAllFrom: oldClass 45364 "Recompile all the methods in the receiver's method dictionary (not the 45365 subclasses). Also recompile the methods in the metaclass." 45366 45367 super compileAllFrom: oldClass. 45368 self class compileAllFrom: oldClass class! ! 45369 45370!Class methodsFor: 'compiling' stamp: 'sd 3/28/2003 15:24'! 45371possibleVariablesFor: misspelled continuedFrom: oldResults 45372 45373 | results | 45374 results := misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults. 45375 self sharedPools do: [:pool | 45376 results := misspelled correctAgainstDictionary: pool continuedFrom: results ]. 45377 superclass == nil 45378 ifTrue: 45379 [ ^ misspelled correctAgainstDictionary: self environment continuedFrom: results ] 45380 ifFalse: 45381 [ ^ superclass possibleVariablesFor: misspelled continuedFrom: results ]! ! 45382 45383 45384!Class methodsFor: 'copying' stamp: 'di 2/17/2000 22:43'! 45385copy 45386 | newClass | 45387 newClass := self class copy new 45388 superclass: superclass 45389 methodDict: self methodDict copy 45390 format: format 45391 name: name 45392 organization: self organization copy 45393 instVarNames: instanceVariables copy 45394 classPool: classPool copy 45395 sharedPools: sharedPools. 45396 Class instSize+1 to: self class instSize do: 45397 [:offset | newClass instVarAt: offset put: (self instVarAt: offset)]. 45398 ^ newClass! ! 45399 45400!Class methodsFor: 'copying' stamp: 'marcus.denker 8/19/2008 21:09'! 45401duplicateClassWithNewName: aSymbol 45402 45403 | copysName class newDefinition | 45404 45405 copysName := aSymbol asSymbol. 45406 copysName = self name ifTrue: [^ self]. 45407 (Smalltalk includesKey: copysName) ifTrue: [^ self error: copysName , ' already exists']. 45408 45409 newDefinition := self definition copyReplaceAll: '#' , self name asString with: '#' , copysName asString. 45410 class := Compiler evaluate: newDefinition logged: true. 45411 class class instanceVariableNames: self class instanceVariablesString. 45412 class copyAllCategoriesFrom: self. 45413 class class copyAllCategoriesFrom: self class. 45414 ^class! ! 45415 45416 45417!Class methodsFor: 'fileIn/Out' stamp: 'PeterHugossonMiller 9/3/2009 00:53'! 45418fileOut 45419 "Create a file whose name is the name of the receiver with '.st' as the 45420 extension, and file a description of the receiver onto it." 45421 45422 | internalStream | 45423 internalStream := (String new: 100) writeStream. 45424 internalStream header; timeStamp. 45425 45426 self hasSharedPools ifTrue: [ 45427 self shouldFileOutPools 45428 ifTrue: [self fileOutSharedPoolsOn: internalStream]]. 45429 self fileOutOn: internalStream moveSource: false toFile: 0. 45430 internalStream trailer. 45431 45432 FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true! ! 45433 45434!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:00'! 45435fileOutInitializerOn: aStream 45436 ^self class fileOutInitializerOn: aStream! ! 45437 45438!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:04'! 45439fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex 45440 "File a description of the receiver on aFileStream. If the boolean argument, 45441 moveSource, is true, then set the trailing bytes to the position of aFileStream and 45442 to fileIndex in order to indicate where to find the source code." 45443 ^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! ! 45444 45445!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:04'! 45446fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool 45447 "File a description of the receiver on aFileStream. If the boolean argument, 45448 moveSource, is true, then set the trailing bytes to the position of aFileStream and 45449 to fileIndex in order to indicate where to find the source code." 45450 45451 Transcript cr; show: self name. 45452 super 45453 fileOutOn: aFileStream 45454 moveSource: moveSource 45455 toFile: fileIndex. 45456 self class nonTrivial 45457 ifTrue: 45458 [aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr. 45459 self class 45460 fileOutOn: aFileStream 45461 moveSource: moveSource 45462 toFile: fileIndex 45463 initializing: aBool]! ! 45464 45465!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:04'! 45466fileOutPool: aPool onFileStream: aFileStream 45467 | aPoolName aValue | 45468 (aPool isKindOf: SharedPool class) ifTrue:[^self notify: 'we do not fileout SharedPool type shared pools for now']. 45469 aPoolName := self environment keyAtIdentityValue: aPool. 45470 Transcript cr; show: aPoolName. 45471 aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr. 45472 aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr. 45473 aPool keys asSortedCollection do: [ :aKey | 45474 aValue := aPool at: aKey. 45475 aFileStream nextPutAll: aPoolName , ' at: #''' , aKey asString , '''', ' put: '. 45476 (aValue isKindOf: Number) 45477 ifTrue: [aValue printOn: aFileStream] 45478 ifFalse: [aFileStream nextPutAll: '('. 45479 aValue printOn: aFileStream. 45480 aFileStream nextPutAll: ')']. 45481 aFileStream nextPutAll: '!!'; cr]. 45482 aFileStream cr! ! 45483 45484!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:04'! 45485fileOutSharedPoolsOn: aFileStream 45486 "file out the shared pools of this class after prompting the user about each pool" 45487 | poolsToFileOut | 45488 poolsToFileOut := self sharedPools select: 45489 [:aPool | (self shouldFileOutPool: (self environment keyAtIdentityValue: aPool))]. 45490 poolsToFileOut do: [:aPool | self fileOutPool: aPool onFileStream: aFileStream]. 45491 ! ! 45492 45493!Class methodsFor: 'fileIn/Out' stamp: 'md 4/30/2008 15:36'! 45494hasSharedPools 45495 45496 ^ self sharedPools notEmpty! ! 45497 45498!Class methodsFor: 'fileIn/Out' stamp: 'dvf 9/27/2005 17:36'! 45499objectForDataStream: refStrm 45500 "I am about to be written on an object file. Write a reference to a class in Smalltalk instead." 45501 45502 refStrm insideASegment 45503 ifFalse: ["Normal use" 45504 ^ DiskProxy global: self theNonMetaClass name selector: #withClassVersion: 45505 args: {self classVersion}] 45506 ifTrue: ["recording objects to go into an ImageSegment" 45507 self isSystemDefined ifFalse: [^ self]. "do trace Player classes" 45508 (refStrm rootObject includes: self) ifTrue: [^ self]. 45509 "is in roots, intensionally write out, ^ self" 45510 45511 "A normal class. remove it from references. Do not trace." 45512 refStrm references removeKey: self ifAbsent: []. "already there" 45513 ^ nil] 45514! ! 45515 45516!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'! 45517reformatAll 45518 "Reformat all methods in this class. 45519 Leaves old code accessible to version browsing" 45520 super reformatAll. "me..." 45521 self class reformatAll "...and my metaclass"! ! 45522 45523!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'! 45524removeFromChanges 45525 "References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet. 45526 7/18/96 sw: call removeClassAndMetaClassChanges:" 45527 45528 ChangeSet current removeClassAndMetaClassChanges: self! ! 45529 45530!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'! 45531shouldFileOutPool: aPoolName 45532 "respond with true if the user wants to file out aPoolName" 45533 ^self confirm: ('FileOut the sharedPool ', aPoolName, '?')! ! 45534 45535!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'! 45536shouldFileOutPools 45537 "respond with true if the user wants to file out the shared pools" 45538 ^self confirm: 'FileOut selected sharedPools?'! ! 45539 45540!Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'! 45541storeDataOn: aDataStream 45542 "I don't get stored. Use a DiskProxy" 45543 45544 (aDataStream insideASegment and: [self isSystemDefined not]) ifTrue: [ 45545 ^ super storeDataOn: aDataStream]. "do trace me" 45546 self error: 'use a DiskProxy to store a Class'! ! 45547 45548!Class methodsFor: 'fileIn/Out' stamp: 'ar 4/10/2005 20:27'! 45549withClassVersion: aVersion 45550 aVersion = self classVersion ifTrue:[^self]. 45551 ^self error: 'Invalid class version'! ! 45552 45553 45554!Class methodsFor: 'initialize-release' stamp: 'Noury 10/26/2008 18:58'! 45555declare: varString 45556 "Declare class variables common to all instances. Answer whether 45557 recompilation is advisable." 45558 45559 | newVars conflicts | 45560 newVars := 45561 (Scanner new scanFieldNames: varString) 45562 collect: [:x | x asSymbol]. 45563 conflicts := false. 45564 classPool == nil 45565 ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do: 45566 [:var | self removeClassVarName: var]]. 45567 (newVars reject: [:var | self classPool includesKey: var]) 45568 do: [:var | "adding" 45569 "check if new vars defined elsewhere" 45570 (self bindingOf: var) notNil 45571 ifTrue: 45572 [self error: var , ' is defined elsewhere'. 45573 conflicts := true]]. 45574 newVars size > 0 45575 ifTrue: 45576 [classPool := self classPool. 45577 "in case it was nil" 45578 newVars do: [:var | classPool declare: var from: Undeclared]]. 45579 ^conflicts! ! 45580 45581!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 14:07'! 45582obsolete 45583 "Change the receiver and all of its subclasses to an obsolete class." 45584 self == Object 45585 ifTrue: [^self error: 'Object is NOT obsolete']. 45586 self setName: 'AnObsolete' , self name. 45587 Object class instSize + 1 to: self class instSize do: 45588 [:i | self instVarAt: i put: nil]. "Store nil over class instVars." 45589 self classPool: nil. 45590 self sharedPools: nil. 45591 self class obsolete. 45592 super obsolete.! ! 45593 45594!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 13:35'! 45595removeFromSystem 45596 "Forget the receiver from the Smalltalk global dictionary. Any existing 45597 instances will refer to an obsolete version of the receiver." 45598 self removeFromSystem: true.! ! 45599 45600!Class methodsFor: 'initialize-release' stamp: 'sd 4/24/2008 22:28'! 45601removeFromSystem: logged 45602 "Forget the receiver from the Smalltalk global dictionary. Any existing 45603 instances will refer to an obsolete version of the receiver." 45604 45605 "keep the class name and category for triggering the system change message. If we wait to long, then we get obsolete information which is not what we want." 45606 45607 "tell class to deactivate and unload itself-- two separate events in the module system" 45608 self unload. 45609 self superclass ifNotNil: 45610 ["If we have no superclass there's nothing to be remembered" 45611 self superclass addObsoleteSubclass: self]. 45612 self environment forgetClass: self logged: logged. 45613 self obsolete.! ! 45614 45615!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 13:36'! 45616removeFromSystemUnlogged 45617 "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver. Do not log the removal either to the current change set nor to the system changes log" 45618 ^self removeFromSystem: false! ! 45619 45620!Class methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 16:09'! 45621sharing: poolString 45622 "Set up sharedPools. Answer whether recompilation is advisable." 45623 | oldPools found | 45624 oldPools := self sharedPools. 45625 sharedPools := OrderedCollection new. 45626 (Scanner new scanFieldNames: poolString) do: 45627 [:poolName | 45628 sharedPools add: (self environment at: poolName asSymbol ifAbsent:[ 45629 (self confirm: 'The pool dictionary ', poolName,' does not exist.', 45630 '\Do you want it automatically created?' withCRs) 45631 ifTrue:[self environment at: poolName asSymbol put: Dictionary new] 45632 ifFalse:[^self error: poolName,' does not exist']])]. 45633 sharedPools isEmpty ifTrue: [sharedPools := nil]. 45634 oldPools do: [:pool | found := false. 45635 self sharedPools do: [:p | p == pool ifTrue: [found := true]]. 45636 found ifFalse: [^ true "A pool got deleted"]]. 45637 ^ false! ! 45638 45639!Class methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 10:55'! 45640superclass: sup methodDict: md format: ft name: nm organization: org instVarNames: nilOrArray classPool: pool sharedPools: poolSet 45641 "Answer an instance of me, a new class, using the arguments of the 45642 message as the needed information. 45643 Must only be sent to a new instance; else we would need Object flushCache." 45644 45645 superclass := sup. 45646 methodDict := md. 45647 format := ft. 45648 name := nm. 45649 instanceVariables := nilOrArray. 45650 classPool := pool. 45651 sharedPools := poolSet. 45652 self organization: org.! ! 45653 45654!Class methodsFor: 'initialize-release' stamp: 'ar 7/20/1999 11:23'! 45655superclass: aClass methodDictionary: mDict format: fmt 45656 "Basic initialization of the receiver" 45657 super superclass: aClass methodDictionary: mDict format: fmt. 45658 subclasses := nil. "Important for moving down the subclasses field into Class" 45659! ! 45660 45661!Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 13:35'! 45662unload 45663 "Sent when a the class is removed. Does nothing, but may be overridden by (class-side) subclasses." 45664! ! 45665 45666 45667!Class methodsFor: 'instance variables' stamp: 'al 9/3/2004 14:25'! 45668addInstVarName: aString 45669 "Add the argument, aString, as one of the receiver's instance variables." 45670 ^(ClassBuilder new) 45671 name: self name 45672 inEnvironment: self environment 45673 subclassOf: self superclass 45674 type: self typeOfClass 45675 instanceVariableNames: self instanceVariablesString, ' ', aString 45676 classVariableNames: self classVariablesString 45677 poolDictionaries: self sharedPoolsString 45678 category: self category 45679! ! 45680 45681!Class methodsFor: 'instance variables' stamp: 'al 9/3/2004 14:25'! 45682removeInstVarName: aString 45683 "Remove the argument, aString, as one of the receiver's instance variables." 45684 45685 | newInstVarString | 45686 (self instVarNames includes: aString) 45687 ifFalse: [self error: aString , ' is not one of my instance variables']. 45688 newInstVarString := ''. 45689 (self instVarNames copyWithout: aString) do: 45690 [:varName | newInstVarString := newInstVarString , ' ' , varName]. 45691 ^(ClassBuilder new) 45692 name: self name 45693 inEnvironment: self environment 45694 subclassOf: self superclass 45695 type: self typeOfClass 45696 instanceVariableNames: newInstVarString 45697 classVariableNames: self classVariablesString 45698 poolDictionaries: self sharedPoolsString 45699 category: self category! ! 45700 45701 45702!Class methodsFor: 'organization'! 45703category 45704 "Answer the system organization category for the receiver. First check whether the 45705 category name stored in the ivar is still correct and only if this fails look it up 45706 (latter is much more expensive)" 45707 45708 | result | 45709 self basicCategory ifNotNil: [ :symbol | 45710 ((SystemOrganization listAtCategoryNamed: symbol) includes: self name) 45711 ifTrue: [ ^symbol ] ]. 45712 self basicCategory: (result := SystemOrganization categoryOfElement: self name). 45713 ^result! ! 45714 45715!Class methodsFor: 'organization'! 45716category: aString 45717 "Categorize the receiver under the system category, aString, removing it from 45718 any previous categorization." 45719 45720 | oldCategory | 45721 oldCategory := self basicCategory. 45722 aString isString 45723 ifTrue: [ 45724 self basicCategory: aString asSymbol. 45725 SystemOrganization classify: self name under: self basicCategory ] 45726 ifFalse: [self errorCategoryName]. 45727 SystemChangeNotifier uniqueInstance 45728 class: self recategorizedFrom: oldCategory to: self basicCategory! ! 45729 45730!Class methodsFor: 'organization' stamp: 'di 11/16/1999 16:25'! 45731environment 45732 45733 environment == nil ifTrue: [^ super environment]. 45734 ^ environment! ! 45735 45736!Class methodsFor: 'organization' stamp: 'di 12/23/1999 11:42'! 45737environment: anEnvironment 45738 45739 environment := anEnvironment! ! 45740 45741 45742!Class methodsFor: 'pool variables' stamp: 'tpr 5/30/2003 13:04'! 45743addSharedPool: aSharedPool 45744 "Add the argument, aSharedPool, as one of the receiver's shared pools. 45745 Create an error if the shared pool is already one of the pools. 45746 This method will work with shared pools that are plain Dictionaries or thenewer SharedPool subclasses" 45747 45748 (self sharedPools includes: aSharedPool) 45749 ifTrue: [^self error: 'This is already in my shared pool list']. 45750 sharedPools == nil 45751 ifTrue: [sharedPools := OrderedCollection with: aSharedPool] 45752 ifFalse: [sharedPools add: aSharedPool]! ! 45753 45754!Class methodsFor: 'pool variables' stamp: 'al 9/3/2004 14:25'! 45755allSharedPools 45756 "Answer a Set of the pools the receiver shares, including those defined 45757 in the superclasses of the receiver." 45758 | aSet | 45759 ^self superclass == nil 45760 ifTrue: [self sharedPools copy] 45761 ifFalse: [aSet := self superclass allSharedPools. 45762 aSet addAll: self sharedPools. 45763 aSet]! ! 45764 45765!Class methodsFor: 'pool variables' stamp: 'tk 9/12/96'! 45766removeSharedPool: aDictionary 45767 "Remove the pool dictionary, aDictionary, as one of the receiver's pool 45768 dictionaries. Create an error notification if the dictionary is not one of 45769 the pools. 45770 : Note that it removes the wrong one if there are two empty Dictionaries in the list." 45771 45772 | satisfiedSet workingSet aSubclass | 45773 (self sharedPools includes: aDictionary) 45774 ifFalse: [^self error: 'the dictionary is not in my pool']. 45775 45776 "first see if it is declared in a superclass in which case we can remove it." 45777 (self selectSuperclasses: [:class | class sharedPools includes: aDictionary]) isEmpty 45778 ifFalse: [sharedPools remove: aDictionary. 45779 sharedPools isEmpty ifTrue: [sharedPools := nil]. 45780 ^self]. 45781 45782 "second get all the subclasses that reference aDictionary through me rather than a 45783 superclass that is one of my subclasses." 45784 45785 workingSet := self subclasses asOrderedCollection. 45786 satisfiedSet := Set new. 45787 [workingSet isEmpty] whileFalse: 45788 [aSubclass := workingSet removeFirst. 45789 (aSubclass sharedPools includes: aDictionary) 45790 ifFalse: 45791 [satisfiedSet add: aSubclass. 45792 workingSet addAll: aSubclass subclasses]]. 45793 45794 "for each of these, see if they refer to any of the variables in aDictionary because 45795 if they do, we can not remove the dictionary." 45796 satisfiedSet add: self. 45797 satisfiedSet do: 45798 [:sub | 45799 aDictionary associationsDo: 45800 [:aGlobal | 45801 (sub whichSelectorsReferTo: aGlobal) isEmpty 45802 ifFalse: [^self error: aGlobal key 45803 , ' is still used in code of class ' 45804 , sub name]]]. 45805 sharedPools remove: aDictionary. 45806 sharedPools isEmpty ifTrue: [sharedPools := nil]! ! 45807 45808!Class methodsFor: 'pool variables'! 45809sharedPools 45810 "Answer a Set of the pool dictionaries declared in the receiver." 45811 45812 sharedPools == nil 45813 ifTrue: [^OrderedCollection new] 45814 ifFalse: [^sharedPools]! ! 45815 45816!Class methodsFor: 'pool variables' stamp: 'al 9/3/2004 13:41'! 45817sharedPools: aCollection 45818 sharedPools := aCollection! ! 45819 45820 45821!Class methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:46'! 45822isSelfEvaluating 45823 ^ true! ! 45824 45825 45826!Class methodsFor: 'subclass creation' stamp: 'StephaneDucasse 9/15/2009 09:46'! 45827newSubclass 45828 | i className | 45829 i := 1. 45830 [className := (self name , i printString) asSymbol. 45831 self environment includesKey: className] 45832 whileTrue: [i := i + 1]. 45833 45834 ^ self subclass: className 45835 instanceVariableNames: '' 45836 classVariableNames: '' 45837 poolDictionaries: '' 45838 category: 'Foo' 45839 45840"Point newSubclass new"! ! 45841 45842!Class methodsFor: 'subclass creation' stamp: 'AlexandreBergel 1/26/2009 10:22'! 45843subclass: t 45844 ^ self subclass: t instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Unclassified' 45845! ! 45846 45847!Class methodsFor: 'subclass creation' stamp: 'AlexandreBergel 1/26/2009 10:22'! 45848subclass: t instanceVariableNames: ins 45849 ^ self subclass: t instanceVariableNames: ins classVariableNames: '' poolDictionaries: '' category: 'Unclassified' 45850! ! 45851 45852!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:57'! 45853subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat 45854 "This is the standard initialization message for creating a new class as a 45855 subclass of an existing class (the receiver)." 45856 ^(ClassBuilder new) 45857 superclass: self 45858 subclass: t 45859 instanceVariableNames: f 45860 classVariableNames: d 45861 poolDictionaries: s 45862 category: cat 45863! ! 45864 45865!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:18'! 45866subclass: t uses: aTraitCompositionOrArray instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat 45867 | newClass copyOfOldClass | 45868 copyOfOldClass := self copy. 45869 newClass := self 45870 subclass: t 45871 instanceVariableNames: f 45872 classVariableNames: d 45873 poolDictionaries: s 45874 category: cat. 45875 45876 45877 newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. 45878 SystemChangeNotifier uniqueInstance 45879 classDefinitionChangedFrom: copyOfOldClass to: newClass. 45880 ^newClass! ! 45881 45882!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:57'! 45883variableByteSubclass: t instanceVariableNames: f 45884 classVariableNames: d poolDictionaries: s category: cat 45885 "This is the standard initialization message for creating a new class as a 45886 subclass of an existing class (the receiver) in which the subclass is to 45887 have indexable byte-sized nonpointer variables." 45888 ^(ClassBuilder new) 45889 superclass: self 45890 variableByteSubclass: t 45891 instanceVariableNames: f 45892 classVariableNames: d 45893 poolDictionaries: s 45894 category: cat 45895! ! 45896 45897!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:18'! 45898variableByteSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f 45899 classVariableNames: d poolDictionaries: s category: cat 45900 "This is the standard initialization message for creating a new class as a 45901 subclass of an existing class (the receiver) in which the subclass is to 45902 have indexable byte-sized nonpointer variables." 45903 45904 | newClass copyOfOldClass | 45905 copyOfOldClass := self copy. 45906 newClass := self 45907 variableByteSubclass: t 45908 instanceVariableNames: f 45909 classVariableNames: d 45910 poolDictionaries: s 45911 category: cat. 45912 45913 newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. 45914 SystemChangeNotifier uniqueInstance 45915 classDefinitionChangedFrom: copyOfOldClass to: newClass. 45916 ^newClass 45917! ! 45918 45919!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:56'! 45920variableSubclass: t instanceVariableNames: f 45921 classVariableNames: d poolDictionaries: s category: cat 45922 "This is the standard initialization message for creating a new class as a 45923 subclass of an existing class (the receiver) in which the subclass is to 45924 have indexable pointer variables." 45925 ^(ClassBuilder new) 45926 superclass: self 45927 variableSubclass: t 45928 instanceVariableNames: f 45929 classVariableNames: d 45930 poolDictionaries: s 45931 category: cat 45932! ! 45933 45934!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:17'! 45935variableSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f 45936 classVariableNames: d poolDictionaries: s category: cat 45937 "This is the standard initialization message for creating a new class as a 45938 subclass of an existing class (the receiver) in which the subclass is to 45939 have indexable pointer variables." 45940 45941 | newClass copyOfOldClass | 45942 copyOfOldClass := self copy. 45943 newClass := self 45944 variableSubclass: t 45945 instanceVariableNames: f 45946 classVariableNames: d 45947 poolDictionaries: s 45948 category: cat. 45949 45950 newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. 45951 SystemChangeNotifier uniqueInstance 45952 classDefinitionChangedFrom: copyOfOldClass to: newClass. 45953 ^newClass ! ! 45954 45955!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:56'! 45956variableWordSubclass: t instanceVariableNames: f 45957 classVariableNames: d poolDictionaries: s category: cat 45958 "This is the standard initialization message for creating a new class as a 45959 subclass of an existing class (the receiver) in which the subclass is to 45960 have indexable word-sized nonpointer variables." 45961 ^(ClassBuilder new) 45962 superclass: self 45963 variableWordSubclass: t 45964 instanceVariableNames: f 45965 classVariableNames: d 45966 poolDictionaries: s 45967 category: cat 45968! ! 45969 45970!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:18'! 45971variableWordSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f 45972 classVariableNames: d poolDictionaries: s category: cat 45973 "This is the standard initialization message for creating a new class as a 45974 subclass of an existing class (the receiver) in which the subclass is to 45975 have indexable word-sized nonpointer variables." 45976 45977 | newClass copyOfOldClass | 45978 copyOfOldClass := self copy. 45979 newClass := self 45980 variableWordSubclass: t 45981 instanceVariableNames: f 45982 classVariableNames: d 45983 poolDictionaries: s 45984 category: cat. 45985 45986 newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. 45987 SystemChangeNotifier uniqueInstance 45988 classDefinitionChangedFrom: copyOfOldClass to: newClass. 45989 ^newClass 45990! ! 45991 45992!Class methodsFor: 'subclass creation' stamp: 'tak 9/25/2008 15:00'! 45993weakSubclass: t instanceVariableNames: f 45994 classVariableNames: d poolDictionaries: s category: cat 45995 "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have weak indexable pointer variables." 45996 ^(ClassBuilder new) 45997 superclass: self 45998 weakSubclass: t 45999 instanceVariableNames: f 46000 classVariableNames: d 46001 poolDictionaries: s 46002 category: cat! ! 46003 46004!Class methodsFor: 'subclass creation' stamp: 'al 7/19/2004 11:18'! 46005weakSubclass: t uses: aTraitCompositionOrArray instanceVariableNames: f 46006 classVariableNames: d poolDictionaries: s category: cat 46007 "This is the standard initialization message for creating a new class as a 46008 subclass of an existing class (the receiver) in which the subclass is to 46009 have weak indexable pointer variables." 46010 46011 | newClass copyOfOldClass | 46012 copyOfOldClass := self copy. 46013 newClass := self 46014 weakSubclass: t 46015 instanceVariableNames: f 46016 classVariableNames: d 46017 poolDictionaries: s 46018 category: cat. 46019 46020 newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. 46021 SystemChangeNotifier uniqueInstance 46022 classDefinitionChangedFrom: copyOfOldClass to: newClass. 46023 ^newClass 46024! ! 46025 46026 46027!Class methodsFor: 'testing'! 46028hasMethods 46029 "Answer a Boolean according to whether any methods are defined for the 46030 receiver (includes whether there are methods defined in the receiver's 46031 metaclass)." 46032 46033 ^super hasMethods or: [self class hasMethods]! ! 46034 46035!Class methodsFor: 'testing' stamp: 'al 6/5/2006 13:13'! 46036isObsolete 46037 "Return true if the receiver is obsolete." 46038 ^(self environment at: name ifAbsent: [nil]) ~~ self! ! 46039 46040!Class methodsFor: 'testing' stamp: 'tk 8/12/1999 15:47'! 46041isSystemDefined 46042 "Answer true if the receiver is a system-defined class, and not a UniClass (an instance-specific lightweight class)" 46043 46044 ^ self == self officialClass! ! 46045 46046!Class methodsFor: 'testing' stamp: 'tk 8/12/1999 15:49'! 46047officialClass 46048 "I am not a UniClass. (See Player officialClass). Return the class you use to make new subclasses." 46049 46050 ^ self! ! 46051 46052 46053!Class methodsFor: 'traits' stamp: 'NS 4/12/2004 16:48'! 46054applyChangesOfNewTraitCompositionReplacing: oldComposition 46055 "See Trait>>applyChangesOfNewTraitCompositionReplacing:" 46056 | changedSelectors | 46057 changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. 46058 self classSide 46059 noteNewBaseTraitCompositionApplied: self traitComposition. 46060 ^ changedSelectors! ! 46061 46062 46063!Class methodsFor: 'private' stamp: 'ar 7/15/1999 15:37'! 46064setName: aSymbol 46065 "Private - set the name of the class" 46066 name := aSymbol.! ! 46067 46068!Class methodsFor: 'private' stamp: 'sd 2/1/2004 15:18'! 46069spaceUsed 46070 46071 "Object spaceUsed" 46072 ^ super spaceUsed + self class spaceUsed! ! 46073 46074"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 46075 46076Class class 46077 uses: TBehaviorCategorization classTrait 46078 instanceVariableNames: ''! 46079 46080!Class class methodsFor: 'fileIn/Out' stamp: 'PeterHugossonMiller 9/3/2009 00:53'! 46081fileOutPool: aString 46082 "file out the global pool named aString" 46083 46084 | internalStream | 46085 internalStream := (String new: 1000) writeStream. 46086 self new fileOutPool: (self environment at: aString asSymbol) onFileStream: internalStream. 46087 46088 FileStream writeSourceCodeFrom: internalStream baseName: aString isSt: true.! ! 46089 46090 46091!Class class methodsFor: 'inquiries' stamp: 'al 6/14/2008 09:50'! 46092rootsOfTheWorld 46093 "return all classes that have a nil superclass" 46094 46095 ^(Smalltalk select: [:each | each isBehavior and: [each superclass isNil]]) asOrderedCollection! ! 46096 46097 46098!Class class methodsFor: 'instance creation' stamp: 'di 6/7/2000 22:01'! 46099template: aSystemCategoryName 46100 "Answer an expression that can be edited and evaluated in order to define a new class." 46101 46102 ^ self templateForSubclassOf: Object name category: aSystemCategoryName ! ! 46103 46104!Class class methodsFor: 'instance creation' stamp: 'eem 5/7/2008 12:06'! 46105templateForSubclassOf: priorClassName category: systemCategoryName 46106 "Answer an expression that can be edited and evaluated in order to define a new class, given that the class previously looked at was as given" 46107 46108 ^priorClassName asString, ' subclass: #NameOfSubclass 46109 instanceVariableNames: '''' 46110 classVariableNames: '''' 46111 poolDictionaries: '''' 46112 category: ''' , systemCategoryName asString , ''''! ! 46113Object subclass: #ClassBuilder 46114 instanceVariableNames: 'environ classMap instVarMap progress maxClassIndex currentClassIndex' 46115 classVariableNames: 'QuietMode' 46116 poolDictionaries: '' 46117 category: 'Kernel-Classes'! 46118!ClassBuilder commentStamp: 'ar 2/27/2003 22:55' prior: 0! 46119Responsible for creating a new class or changing the format of an existing class (from a class definition in a browser or a fileIn). This includes validating the definition, computing the format of instances, creating or modifying the accompanying Metaclass, setting up the class and metaclass objects themselves, registering the class as a global, recompiling methods, modifying affected subclasses, mutating existing instances to the new format, and more. 46120 46121You typically only need to use or modify this class, or even know how it works, when making fundamental changes to how the Smalltalk system and language works. 46122 46123Implementation notes: 46124ClassBuilder relies on the assumption that it can see ALL subclasses of some class. If there are any existing subclasses of some class, regardless of whether they have instances or not, regardless of whether they are considered obsolete or not, ClassBuilder MUST SEE THEM. 46125! 46126 46127 46128!ClassBuilder methodsFor: 'class definition' stamp: 'adrian_lienhard 1/17/2009 14:06'! 46129class: oldClass instanceVariableNames: instVarString unsafe: unsafe 46130 "This is the basic initialization message to change the definition of 46131 an existing Metaclass" 46132 | instVars newClass needNew copyOfOldClass copyOfOldTraitComposition copyOfOldClassTraitComposition | 46133 environ := oldClass environment. 46134 instVars := Scanner new scanFieldNames: instVarString. 46135 unsafe ifFalse:[ 46136 "Run validation checks so we know that we have a good chance for recompilation" 46137 (self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil]. 46138 (self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]]. 46139 "See if we need a new subclass or not" 46140 needNew := self needsSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. 46141 needNew ifNil:[^nil]. "some error" 46142 needNew ifFalse:[^oldClass]. "no new class needed" 46143 46144 "Create the new class" 46145 copyOfOldClass := oldClass copy. 46146 oldClass hasTraitComposition ifTrue: [ 46147 copyOfOldTraitComposition := oldClass traitComposition copyTraitExpression ]. 46148 oldClass class hasTraitComposition ifTrue: [ 46149 copyOfOldClassTraitComposition := oldClass class traitComposition copyTraitExpression ]. 46150 46151 newClass := self 46152 newSubclassOf: oldClass superclass 46153 type: oldClass typeOfClass 46154 instanceVariables: instVars 46155 from: oldClass. 46156 46157 newClass := self recompile: false from: oldClass to: newClass mutate: false. 46158 46159 "... set trait composition..." 46160 copyOfOldTraitComposition ifNotNil: [ 46161 newClass setTraitComposition: copyOfOldTraitComposition ]. 46162 copyOfOldClassTraitComposition ifNotNil: [ 46163 newClass class setTraitComposition: copyOfOldClassTraitComposition ]. 46164 46165 self doneCompiling: newClass. 46166 SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. 46167 ^newClass! ! 46168 46169!ClassBuilder methodsFor: 'class definition' stamp: 'ar 8/29/1999 15:34'! 46170name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category 46171 "Define a new class in the given environment" 46172 ^self 46173 name: className 46174 inEnvironment: env 46175 subclassOf: newSuper 46176 type: type 46177 instanceVariableNames: instVarString 46178 classVariableNames: classVarString 46179 poolDictionaries: poolString 46180 category: category 46181 unsafe: false! ! 46182 46183!ClassBuilder methodsFor: 'class definition' stamp: 'adrian_lienhard 1/17/2009 14:06'! 46184name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe 46185 "Define a new class in the given environment. 46186 If unsafe is true do not run any validation checks. 46187 This facility is provided to implement important system changes." 46188 | oldClass newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory copyOfOldTraitComposition copyOfOldClassTraitComposition | 46189 46190 environ := env. 46191 instVars := Scanner new scanFieldNames: instVarString. 46192 classVars := (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. 46193 46194 "Validate the proposed name" 46195 unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. 46196 oldClass := env at: className ifAbsent:[nil]. 46197 oldClass isBehavior 46198 ifFalse: [oldClass := nil] "Already checked in #validateClassName:" 46199 ifTrue: [ 46200 copyOfOldClass := oldClass copy. 46201 copyOfOldClass superclass addSubclass: copyOfOldClass. 46202 copyOfOldClass ifNotNil: [ 46203 oldClass hasTraitComposition ifTrue: [ 46204 copyOfOldTraitComposition := oldClass traitComposition copyTraitExpression ]. 46205 oldClass class hasTraitComposition ifTrue: [ 46206 copyOfOldClassTraitComposition := oldClass class traitComposition copyTraitExpression ] ] ]. 46207 46208 [unsafe ifFalse:[ 46209 "Run validation checks so we know that we have a good chance for recompilation" 46210 (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. 46211 (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. 46212 (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. 46213 (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]]. 46214 46215 "See if we need a new subclass" 46216 needNew := self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. 46217 needNew == nil ifTrue:[^nil]. "some error" 46218 46219 (needNew and:[unsafe not]) ifTrue:[ 46220 "Make sure we don't redefine any dangerous classes" 46221 (self tooDangerousClasses includes: oldClass name) ifTrue:[ 46222 self error: oldClass name, ' cannot be changed'. 46223 ]. 46224 "Check if the receiver should not be redefined" 46225 (oldClass ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[ 46226 self notify: oldClass name asText allBold, 46227 ' should not be redefined. \Proceed to store over it.' withCRs]]. 46228 46229 needNew ifTrue:[ 46230 "Create the new class" 46231 newClass := self 46232 newSubclassOf: newSuper 46233 type: type 46234 instanceVariables: instVars 46235 from: oldClass. 46236 newClass == nil ifTrue:[^nil]. "Some error" 46237 newClass setName: className. 46238 ] ifFalse:[ 46239 "Reuse the old class" 46240 newClass := oldClass. 46241 ]. 46242 46243 "Install the class variables and pool dictionaries... " 46244 force := (newClass declare: classVarString) | (newClass sharing: poolString). 46245 46246 "... classify ..." 46247 newCategory := category asSymbol. 46248 organization := environ ifNotNil:[environ organization]. 46249 oldClass isNil ifFalse: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol]. 46250 organization classify: newClass name under: newCategory. 46251 newClass environment: environ. 46252 46253 "... recompile ..." 46254 newClass := self recompile: force from: oldClass to: newClass mutate: false. 46255 46256 "... export if not yet done ..." 46257 (environ at: newClass name ifAbsent:[nil]) == newClass ifFalse:[ 46258 environ at: newClass name put: newClass. 46259 Smalltalk flushClassNameCache. 46260 ]. 46261 46262 "... set trait composition..." 46263 copyOfOldTraitComposition ifNotNil: [ 46264 newClass setTraitComposition: copyOfOldTraitComposition ]. 46265 copyOfOldClassTraitComposition ifNotNil: [ 46266 newClass class setTraitComposition: copyOfOldClassTraitComposition ]. 46267 46268 46269 newClass doneCompiling. 46270 "... notify interested clients ..." 46271 oldClass isNil ifTrue: [ 46272 SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory. 46273 ^ newClass]. 46274 newCategory ~= oldCategory 46275 ifTrue: [SystemChangeNotifier uniqueInstance class: newClass recategorizedFrom: oldCategory to: category] 46276 ifFalse: [SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass.]. 46277] ensure: 46278 [copyOfOldClass ifNotNil: [copyOfOldClass superclass removeSubclass: copyOfOldClass]. 46279 Behavior flushObsoleteSubclasses. 46280 ]. 46281 ^newClass! ! 46282 46283!ClassBuilder methodsFor: 'class definition' stamp: 'ar 9/22/2002 02:57'! 46284needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass 46285 "Answer whether we need a new subclass to conform to the requested changes" 46286 | newFormat | 46287 "Compute the format of the new class" 46288 newFormat := 46289 self computeFormat: type 46290 instSize: instVars size 46291 forSuper: newSuper 46292 ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]). 46293 newFormat == nil ifTrue:[^nil]. 46294 46295 "Check if we really need a new subclass" 46296 oldClass ifNil:[^true]. "yes, it's a new class" 46297 newSuper == oldClass superclass ifFalse:[^true]. "yes, it's a superclass change" 46298 newFormat = oldClass format ifFalse:[^true]. "yes, it's a format change" 46299 instVars = oldClass instVarNames ifFalse:[^true]. "yes, it's an iVar change" 46300 46301 ^false 46302! ! 46303 46304!ClassBuilder methodsFor: 'class definition' stamp: 'adrian_lienhard 1/17/2009 11:31'! 46305newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass 46306 "Create a new subclass of the given superclass with the given specification." 46307 | newFormat newClass | 46308 "Compute the format of the new class" 46309 newFormat := 46310 self computeFormat: type 46311 instSize: instVars size 46312 forSuper: newSuper 46313 ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]). 46314 46315 newFormat == nil ifTrue:[^nil]. 46316 46317 (oldClass == nil or:[oldClass isMeta not]) 46318 ifTrue:[newClass := self privateNewSubclassOf: newSuper from: oldClass] 46319 ifFalse:[newClass := oldClass clone]. 46320 46321 newClass 46322 superclass: newSuper 46323 methodDictionary: MethodDictionary new 46324 format: newFormat; 46325 setInstVarNames: instVars. 46326 46327 oldClass ifNotNil:[ 46328 newClass organization: oldClass organization. 46329 "Recompile the new class" 46330 oldClass hasMethods 46331 ifTrue:[newClass compileAllFrom: oldClass]. 46332 self recordClass: oldClass replacedBy: newClass. 46333 ]. 46334 46335 (oldClass == nil or:[oldClass isObsolete not]) 46336 ifTrue:[newSuper addSubclass: newClass] 46337 ifFalse:[newSuper addObsoleteSubclass: newClass]. 46338 46339 ^newClass! ! 46340 46341!ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/21/2004 09:53'! 46342recompile: force from: oldClass to: newClass mutate: forceMutation 46343 "Do the necessary recompilation after changine oldClass to newClass. 46344 If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass 46345 and all its subclasses. If forceMutation is true force a mutation even 46346 if oldClass and newClass are the same." 46347 46348 oldClass == nil ifTrue:[^ newClass]. 46349 46350 (newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[ 46351 ^newClass]. 46352 46353 currentClassIndex := 0. 46354 maxClassIndex := oldClass withAllSubclasses size. 46355 46356 (oldClass == newClass and:[forceMutation not]) ifTrue:[ 46357 "Recompile from newClass without mutating" 46358 self informUserDuring:[ 46359 newClass isSystemDefined ifFalse:[progress := nil]. 46360 newClass withAllSubclassesDo:[:cl| 46361 self showProgressFor: cl. 46362 cl compileAll]]. 46363 ^newClass]. 46364 "Recompile and mutate oldClass to newClass" 46365 self informUserDuring:[ 46366 newClass isSystemDefined ifFalse:[progress := nil]. 46367 self mutate: oldClass to: newClass. 46368 ]. 46369 ^oldClass "now mutated to newClass"! ! 46370 46371!ClassBuilder methodsFor: 'class definition' stamp: 'al 7/4/2009 16:55'! 46372silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName 46373 "Move the instvar from srcClass to dstClass. 46374 Do not perform any checks." 46375 | srcVars dstVars dstIndex newClass copyOfSrcClass copyOfDstClass copyOfOldTraitComposition copyOfOldClassTraitComposition | 46376 copyOfSrcClass := srcClass copy. 46377 copyOfDstClass := dstClass copy. 46378 46379 srcVars := srcClass instVarNames copyWithout: instVarName. 46380 srcClass == dstClass 46381 ifTrue:[dstVars := srcVars] 46382 ifFalse:[dstVars := dstClass instVarNames]. 46383 dstIndex := dstVars indexOf: prevInstVarName. 46384 dstVars := (dstVars copyFrom: 1 to: dstIndex), 46385 (Array with: instVarName), 46386 (dstVars copyFrom: dstIndex+1 to: dstVars size). 46387 instVarMap at: srcClass name put: srcVars. 46388 instVarMap at: dstClass name put: dstVars. 46389 (srcClass inheritsFrom: dstClass) ifTrue:[ 46390 copyOfOldTraitComposition := copyOfOldClassTraitComposition := nil. 46391 dstClass hasTraitComposition ifTrue: [ 46392 copyOfOldTraitComposition := dstClass traitComposition copyTraitExpression ]. 46393 dstClass class hasTraitComposition ifTrue: [ 46394 copyOfOldClassTraitComposition := dstClass class traitComposition copyTraitExpression ]. 46395 46396 newClass := self reshapeClass: dstClass toSuper: dstClass superclass. 46397 self recompile: false from: dstClass to: newClass mutate: true. 46398 46399 copyOfOldTraitComposition ifNotNil: [ 46400 newClass setTraitComposition: copyOfOldTraitComposition ]. 46401 copyOfOldClassTraitComposition ifNotNil: [ 46402 newClass class setTraitComposition: copyOfOldClassTraitComposition ]. 46403 ] ifFalse:[ 46404 (dstClass inheritsFrom: srcClass) ifTrue:[ 46405 newClass := self reshapeClass: srcClass toSuper: srcClass superclass. 46406 self recompile: false from: srcClass to: newClass mutate: true. 46407 ] ifFalse:[ "Disjunct hierarchies" 46408 srcClass == dstClass ifFalse:[ 46409 newClass := self reshapeClass: dstClass toSuper: dstClass superclass. 46410 self recompile: false from: dstClass to: newClass mutate: true. 46411 ]. 46412 newClass := self reshapeClass: srcClass toSuper: srcClass superclass. 46413 self recompile: false from: srcClass to: newClass mutate: true. 46414 ]. 46415 ]. 46416 self doneCompiling: srcClass. 46417 self doneCompiling: dstClass. 46418 SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfSrcClass to: srcClass. 46419 SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfDstClass to: dstClass.! ! 46420 46421 46422!ClassBuilder methodsFor: 'class format' stamp: 'eem 6/13/2008 10:03'! 46423computeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex 46424 "Compute the new format for making oldClass a subclass of newSuper. 46425 Return the format or nil if there is any problem." 46426 | instSize isVar isWords isPointers isWeak | 46427 type == #compiledMethod 46428 ifTrue:[^CompiledMethod format]. 46429 instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]). 46430 instSize > 254 ifTrue:[ 46431 self error: 'Class has too many instance variables (', instSize printString,')'. 46432 ^nil]. 46433 type == #normal ifTrue:[isVar := isWeak := false. isWords := isPointers := true]. 46434 type == #bytes ifTrue:[isVar := true. isWords := isPointers := isWeak := false]. 46435 type == #words ifTrue:[isVar := isWords := true. isPointers := isWeak := false]. 46436 type == #variable ifTrue:[isVar := isPointers := isWords := true. isWeak := false]. 46437 type == #weak ifTrue:[isVar := isWeak := isWords := isPointers := true]. 46438 (isPointers not and:[instSize > 0]) ifTrue:[ 46439 self error:'A non-pointer class cannot have instance variables'. 46440 ^nil]. 46441 ^(self format: instSize 46442 variable: isVar 46443 words: isWords 46444 pointers: isPointers 46445 weak: isWeak) + (ccIndex bitShift: 11).! ! 46446 46447!ClassBuilder methodsFor: 'class format' stamp: 'ar 7/11/1999 06:39'! 46448format: nInstVars variable: isVar words: isWords pointers: isPointers weak: isWeak 46449 "Compute the format for the given instance specfication." 46450 | cClass instSpec sizeHiBits fmt | 46451 self flag: #instSizeChange. 46452" 46453Smalltalk browseAllCallsOn: #instSizeChange. 46454Smalltalk browseAllImplementorsOf: #fixedFieldsOf:. 46455Smalltalk browseAllImplementorsOf: #instantiateClass:indexableSize:. 46456" 46457" 46458 NOTE: This code supports the backward-compatible extension to 8 bits of instSize. 46459 For now the format word is... 46460 <2 bits=instSize//64><5 bits=cClass><4 bits=instSpec><6 bits=instSize\\64><1 bit=0> 46461 But when we revise the image format, it should become... 46462 <5 bits=cClass><4 bits=instSpec><8 bits=instSize><1 bit=0> 46463" 46464 sizeHiBits := (nInstVars+1) // 64. 46465 cClass := 0. "for now" 46466 instSpec := isWeak 46467 ifTrue:[4] 46468 ifFalse:[isPointers 46469 ifTrue: [isVar 46470 ifTrue: [nInstVars>0 ifTrue: [3] ifFalse: [2]] 46471 ifFalse: [nInstVars>0 ifTrue: [1] ifFalse: [0]]] 46472 ifFalse: [isWords ifTrue: [6] ifFalse: [8]]]. 46473 fmt := sizeHiBits. 46474 fmt := (fmt bitShift: 5) + cClass. 46475 fmt := (fmt bitShift: 4) + instSpec. 46476 fmt := (fmt bitShift: 6) + ((nInstVars+1)\\64). "+1 since prim size field includes header" 46477 fmt := (fmt bitShift: 1). "This shift plus integer bit lets wordSize work like byteSize" 46478 ^fmt! ! 46479 46480 46481!ClassBuilder methodsFor: 'class mutation' stamp: 'al 7/4/2009 16:52'! 46482mutate: oldClass to: newClass 46483 "Mutate the old class and subclasses into newClass and subclasses. 46484 Note: This method is slightly different from: #mutate:toSuper: since 46485 here we are at the root of reshaping and have two distinct roots." 46486 46487 | copyOfOldTraitComposition copyOfOldClassTraitComposition | 46488 self showProgressFor: oldClass. 46489 "Convert the subclasses" 46490 oldClass subclasses do: [:oldSubclass | | newSubclass | 46491 copyOfOldTraitComposition := copyOfOldClassTraitComposition := nil. 46492 oldSubclass hasTraitComposition ifTrue: [ 46493 copyOfOldTraitComposition := oldSubclass traitComposition copyTraitExpression ]. 46494 oldSubclass class hasTraitComposition ifTrue: [ 46495 copyOfOldClassTraitComposition := oldSubclass class traitComposition copyTraitExpression ]. 46496 46497 newSubclass := self reshapeClass: oldSubclass toSuper: newClass. 46498 self mutate: oldSubclass to: newSubclass. 46499 46500 copyOfOldTraitComposition ifNotNil: [ 46501 newSubclass setTraitComposition: copyOfOldTraitComposition ]. 46502 copyOfOldClassTraitComposition ifNotNil: [ 46503 newSubclass class setTraitComposition: copyOfOldClassTraitComposition ]. 46504 ]. 46505 "And any obsolete ones" 46506 oldClass obsoleteSubclasses do: [:oldSubclass | | newSubclass | 46507 oldSubclass ifNotNil: [ 46508 copyOfOldTraitComposition := copyOfOldClassTraitComposition := nil. 46509 oldSubclass hasTraitComposition ifTrue: [ 46510 copyOfOldTraitComposition := oldSubclass traitComposition copyTraitExpression ]. 46511 oldSubclass class hasTraitComposition ifTrue: [ 46512 copyOfOldClassTraitComposition := oldSubclass class traitComposition copyTraitExpression ]. 46513 46514 newSubclass := self reshapeClass: oldSubclass toSuper: newClass. 46515 self mutate: oldSubclass to: newSubclass. 46516 46517 copyOfOldTraitComposition ifNotNil: [ 46518 newSubclass setTraitComposition: copyOfOldTraitComposition ]. 46519 copyOfOldClassTraitComposition ifNotNil: [ 46520 newSubclass class setTraitComposition: copyOfOldClassTraitComposition ]. 46521 ]. 46522 ]. 46523 self update: oldClass to: newClass. 46524 ^newClass! ! 46525 46526!ClassBuilder methodsFor: 'class mutation' stamp: 'ar 9/22/2002 03:16'! 46527reshapeClass: oldClass toSuper: newSuper 46528 "Reshape the given class to the new super class. Recompile all the methods in the newly created class. Answer the new class." 46529 | instVars | 46530 46531 "ar 9/22/2002: The following is a left-over from some older code. 46532 I do *not* know why we uncompact oldClass here. If you do, then 46533 please let me know so I can put a comment here..." 46534 oldClass becomeUncompact. 46535 46536 instVars := instVarMap at: oldClass name ifAbsent:[oldClass instVarNames]. 46537 46538 ^self newSubclassOf: newSuper 46539 type: oldClass typeOfClass 46540 instanceVariables: instVars 46541 from: oldClass! ! 46542 46543!ClassBuilder methodsFor: 'class mutation' stamp: 'ar 2/27/2003 23:42'! 46544update: oldClass to: newClass 46545 "Convert oldClass, all its instances and possibly its meta class into newClass, instances of newClass and possibly its meta class. The process is surprisingly simple in its implementation and surprisingly complex in its nuances and potentially bad side effects. 46546 We can rely on two assumptions (which are critical): 46547 #1: The method #updateInstancesFrom: will not create any lasting pointers to 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do a become of the old vs. the new instances and therefore it will not create pointers to *new* instances before the #become: which are *old* afterwards) 46548 #2: The non-preemptive execution of the critical piece of code guarantees that nobody can get a hold by 'other means' (such as process interruption and reflection) on the old instances. 46549 Given the above two, we know that after #updateInstancesFrom: there are no pointer to any old instances. After the forwarding become there will be no pointers to the old class or meta class either. Meaning that if we throw in a nice fat GC at the end of the critical block, everything will be gone (but see the comment right there). There's no need to worry. 46550 " 46551 | meta | 46552 meta := oldClass isMeta. 46553 "Note: Everything from here on will run without the ability to get interrupted 46554 to prevent any other process to create new instances of the old class." 46555 [ 46556 "Note: The following removal may look somewhat obscure and needs an explanation. When we mutate the class hierarchy we create new classes for any existing subclass. So it may look as if we don't have to remove the old class from its superclass. However, at the top of the hierarchy (the first class we reshape) that superclass itself is not newly created so therefore it will hold both the oldClass and newClass in its (obsolete or not) subclasses. Since the #become: below will transparently replace the pointers to oldClass with newClass the superclass would have newClass in its subclasses TWICE. With rather unclear effects if we consider that we may convert the meta-class hierarchy itself (which is derived from the non-meta class hierarchy). 46557 Due to this problem ALL classes are removed from their superclass just prior to converting them. Here, breaking the superclass/subclass invariant really doesn't matter since we will effectively remove the oldClass (become+GC) just a few lines below." 46558 46559 oldClass superclass removeSubclass: oldClass. 46560 oldClass superclass removeObsoleteSubclass: oldClass. 46561 46562 "Convert the instances of oldClass into instances of newClass" 46563 newClass updateInstancesFrom: oldClass. 46564 46565 meta 46566 ifTrue:[oldClass becomeForward: newClass] 46567 ifFalse:[(Array with: oldClass with: oldClass class) 46568 elementsForwardIdentityTo: 46569 (Array with: newClass with: newClass class)]. 46570 46571 Smalltalk garbageCollect. 46572 46573 "Warning: Read this before you even think about removing the GC. Yes, it slows us down. Quite heavily if you have a large image. However, there's no good and simple alternative here, since unfortunately, #become: does change class pointers. What happens is that after the above become all of the instances of the old class will have a class pointer identifying them as instances of newClass. If we get our hands on any of these instances we will break immediately since their expected instance layout (that of its class, e.g., newClass) will not match their actual instance layout (that of oldClass). And getting your hands on any of those instances is really simple - just reshaping one class two times in rapid succession will do it. Reflection techniques, interrupts, etc. will only add to this problem. In the case of Metaclass things get even worse since when we recompile the entire class hierarchy we will recompile both, Metaclass and its instances (and some of its instances will have the old and some the new layout). 46574 46575 The only easy solution to this problem would be to 'fix up' the class pointers of the old instances to point to the old class (using primitiveChangeClassTo:). But this won't work either - as we do a one-way become we would have to search the entire object memory for the oldClass and couldn't even clearly identify it unless we give it some 'special token' which sounds quite error-prone. If you really need to get rid of the GC here are some alternatives: 46576 46577 On the image level, one could create a copy of the oldClass before becoming it into the new class and, after becoming it, 'fix up' the old instances. That would certainly work but it sounds quite complex, as we need to make sure we're not breaking any of the superclass/subclass meta/non-meta class variants. 46578 46579 Alternatively, fix up #becomeForward on the VM-level to 'dump the source objects' of #become. This would be quite doable (just 'convert' them into a well known special class such as bitmap) yet it has problems if (accidentally or not) one of the objects in #become: appears on 'both sides of the fence' (right now, this will work ... in a way ... even though the consequences are unclear). 46580 46581 Another alternative is to provide a dedicated primitive for this (instead of using it implicitly in become) which would allow us to dump all the existing instances right here. This is equivalent to a more general primitiveChangeClassTo: and might be worthwhile but it would likely have to keep in mind the differences between bits and pointer thingies etc. 46582 46583 Since all of the alternatives seem rather complex and magical compared to a straight-forward GC it seems best to stick with the GC solution for now. If someone has a real need to fix this problem, that person will likely be motivated enough to check out the alternatives. Personally I'd probably go for #1 (copy the old class and remap the instances to it) since it's a solution that could be easily reverted from within the image if there's any problem with it." 46584 46585 ] valueUnpreemptively. 46586! ! 46587 46588 46589!ClassBuilder methodsFor: 'initialize' stamp: 'ar 3/3/2001 00:29'! 46590doneCompiling: aClass 46591 "The receiver has finished modifying the class hierarchy. 46592 Do any necessary cleanup." 46593 aClass doneCompiling. 46594 Behavior flushObsoleteSubclasses.! ! 46595 46596!ClassBuilder methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:47'! 46597initialize 46598 super initialize. 46599 environ := Smalltalk. 46600 instVarMap := IdentityDictionary new.! ! 46601 46602 46603!ClassBuilder methodsFor: 'public' stamp: 'ar 8/29/1999 15:38'! 46604class: oldClass instanceVariableNames: instVarString 46605 "This is the basic initialization message to change the definition of 46606 an existing Metaclass" 46607 oldClass isMeta ifFalse:[^self error: oldClass name, 'is not a Metaclass']. 46608 ^self class: oldClass instanceVariableNames: instVarString unsafe: false! ! 46609 46610!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:40'! 46611moveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName 46612 "Move the given instVar from srcClass to dstClass" 46613 (srcClass instVarNames includes: instVarName) 46614 ifFalse:[^self error: instVarName,' is not an instance variable of ', srcClass name]. 46615 (prevInstVarName isNil or:[dstClass instVarNames includes: prevInstVarName]) 46616 ifFalse:[^self error: prevInstVarName, 'is not an instance variable of', dstClass name]. 46617 (srcClass inheritsFrom: dstClass) ifTrue:[ 46618 "Move the instvar up the hierarchy." 46619 (self validateClass: srcClass forMoving: instVarName upTo: dstClass) 46620 ifFalse:[^false]. 46621 ]. 46622 (dstClass inheritsFrom: srcClass) ifTrue:[ 46623 "Move the instvar down the hierarchy" 46624 (self validateClass: srcClass forMoving: instVarName downTo: dstClass) 46625 ifFalse:[^false]. 46626 ]. 46627 ^self silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName! ! 46628 46629!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'! 46630superclass: newSuper 46631 subclass: t instanceVariableNames: f 46632 classVariableNames: d poolDictionaries: s category: cat 46633 "This is the standard initialization message for creating a new class as a 46634 subclass of an existing class." 46635 ^self 46636 name: t 46637 inEnvironment: newSuper environment 46638 subclassOf: newSuper 46639 type: newSuper typeOfClass 46640 instanceVariableNames: f 46641 classVariableNames: d 46642 poolDictionaries: s 46643 category: cat! ! 46644 46645!ClassBuilder methodsFor: 'public' stamp: 'eem 6/13/2008 10:00'! 46646superclass: aClass 46647 variableByteSubclass: t instanceVariableNames: f 46648 classVariableNames: d poolDictionaries: s category: cat 46649 "This is the standard initialization message for creating a new class as a 46650 subclass of an existing class in which the subclass is to 46651 have indexable byte-sized nonpointer variables." 46652 | oldClassOrNil actualType | 46653 (aClass instSize > 0) 46654 ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields']. 46655 (aClass isVariable and: [aClass isWords]) 46656 ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields']. 46657 (aClass isVariable and: [aClass isPointers]) 46658 ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields']. 46659 oldClassOrNil := aClass environment at: t ifAbsent:[nil]. 46660 actualType := (oldClassOrNil notNil 46661 and: [oldClassOrNil typeOfClass == #compiledMethod]) 46662 ifTrue: [#compiledMethod] 46663 ifFalse: [#bytes]. 46664 ^self 46665 name: t 46666 inEnvironment: aClass environment 46667 subclassOf: aClass 46668 type: actualType 46669 instanceVariableNames: f 46670 classVariableNames: d 46671 poolDictionaries: s 46672 category: cat! ! 46673 46674!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'! 46675superclass: aClass 46676 variableSubclass: t instanceVariableNames: f 46677 classVariableNames: d poolDictionaries: s category: cat 46678 "This is the standard initialization message for creating a new class as a 46679 subclass of an existing class in which the subclass is to 46680 have indexable pointer variables." 46681 aClass isBits 46682 ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. 46683 ^self 46684 name: t 46685 inEnvironment: aClass environment 46686 subclassOf: aClass 46687 type: #variable 46688 instanceVariableNames: f 46689 classVariableNames: d 46690 poolDictionaries: s 46691 category: cat! ! 46692 46693!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:30'! 46694superclass: aClass 46695 variableWordSubclass: t instanceVariableNames: f 46696 classVariableNames: d poolDictionaries: s category: cat 46697 "This is the standard initialization message for creating a new class as a 46698 subclass of an existing class in which the subclass is to 46699 have indexable word-sized nonpointer variables." 46700 (aClass instSize > 0) 46701 ifTrue: [^self error: 'cannot make a word subclass of a class with named fields']. 46702 (aClass isVariable and: [aClass isBytes]) 46703 ifTrue: [^self error: 'cannot make a word subclass of a class with byte fields']. 46704 (aClass isVariable and: [aClass isPointers]) 46705 ifTrue: [^self error: 'cannot make a word subclass of a class with pointer fields']. 46706 46707 ^self 46708 name: t 46709 inEnvironment: aClass environment 46710 subclassOf: aClass 46711 type: #words 46712 instanceVariableNames: f 46713 classVariableNames: d 46714 poolDictionaries: s 46715 category: cat! ! 46716 46717!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:30'! 46718superclass: aClass 46719 weakSubclass: t instanceVariableNames: f 46720 classVariableNames: d poolDictionaries: s category: cat 46721 "This is the standard initialization message for creating a new class as a 46722 subclass of an existing class (the receiver) in which the subclass is to 46723 have weak indexable pointer variables." 46724 aClass isBits 46725 ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. 46726 ^self 46727 name: t 46728 inEnvironment: aClass environment 46729 subclassOf: aClass 46730 type: #weak 46731 instanceVariableNames: f 46732 classVariableNames: d 46733 poolDictionaries: s 46734 category: cat! ! 46735 46736 46737!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/20/1999 00:41'! 46738validateClass: srcClass forMoving: iv downTo: dstClass 46739 "Make sure that we don't have any accesses to the instVar left" 46740 srcClass withAllSubclassesDo:[:cls| 46741 (cls == dstClass or:[cls inheritsFrom: dstClass]) ifFalse:[ 46742 cls forgetDoIts. 46743 (cls whichSelectorsAccess: iv) isEmpty ifFalse:[ 46744 self notify: (iv printString asText allBold), ' is still used in ', cls name asText allBold,'. 46745Proceed to move it to Undeclared'. 46746 ]. 46747 ]. 46748 ]. 46749 ^true! ! 46750 46751!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/20/1999 00:39'! 46752validateClass: srcClass forMoving: iv upTo: dstClass 46753 "Make sure we don't have this instvar already" 46754 dstClass withAllSubclassesDo:[:cls| 46755 (cls == srcClass or:[cls inheritsFrom: srcClass]) ifFalse:[ 46756 cls isPointers ifFalse:[ 46757 self error: dstClass name, ' cannot have instance variables'. 46758 ^false]. 46759 cls instSize >= 254 ifTrue:[ 46760 self error: cls name, ' has more than 254 instance variables'. 46761 ^false]. 46762 (cls instVarNames includes: iv) ifTrue:[ 46763 self notify: (iv printString asText allBold),' is defined in ', cls name asText allBold,' 46764Proceed to move it up to ', dstClass name asText allBold,' as well'. 46765 instVarMap at: cls name put: (cls instVarNames copyWithout: iv)]. 46766 ]. 46767 ]. 46768 ^true! ! 46769 46770!ClassBuilder methodsFor: 'validation' stamp: 'yo 11/11/2002 10:22'! 46771validateClassName: aString 46772 "Validate the new class name" 46773 aString first canBeGlobalVarInitial ifFalse:[ 46774 self error: 'Class names must be capitalized'. 46775 ^false]. 46776 environ at: aString ifPresent:[:old| 46777 (old isKindOf: Behavior) ifFalse:[ 46778 self notify: aString asText allBold, 46779 ' already exists!!\Proceed will store over it.' withCRs]]. 46780 ^true! ! 46781 46782!ClassBuilder methodsFor: 'validation' stamp: 'lr 7/3/2009 20:54'! 46783validateClassvars: classVarArray from: oldClass forSuper: newSuper 46784 "Check if any of the classVars of oldClass conflict with the new superclass" 46785 | usedNames classVars temp | 46786 classVarArray isEmpty ifTrue:[^true]. "Okay" 46787 46788 "Validate the class var names" 46789 usedNames := classVarArray asSet. 46790 usedNames size = classVarArray size 46791 ifFalse:[ classVarArray do:[:var| 46792 usedNames remove: var ifAbsent:[temp := var]]. 46793 self error: temp,' is multiply defined'. ^false]. 46794 (usedNames includesAnyOf: self reservedNames) 46795 ifTrue:[ self reservedNames do:[:var| 46796 (usedNames includes: var) ifTrue:[temp := var]]. 46797 self error: temp,' is a reserved name'. ^false]. 46798 46799 newSuper == nil ifFalse:[ 46800 usedNames := newSuper allClassVarNames asSet. 46801 classVarArray do:[:iv| 46802 (usedNames includes: iv) ifTrue:[ 46803 newSuper withAllSuperclassesDo:[:cl| 46804 (cl classVarNames includes: iv) ifTrue:[temp := cl]]. 46805 self error: iv, ' is already defined in ', temp name. 46806 ^false]]]. 46807 46808 classVars := classVarArray. 46809 46810 oldClass == nil ifFalse:[ 46811 usedNames := Set new: 20. 46812 (oldClass allSubclasses reject: #isMeta) do: [:cl | usedNames addAll: cl classVarNames]. 46813 newSuper == nil ifFalse:[classVars := classVars, newSuper allClassVarNames asArray]. 46814 classVars do:[:iv| 46815 (usedNames includes: iv) ifTrue:[ 46816 self error: iv, ' is already defined in a subclass of ', oldClass name. 46817 ^false]]]. 46818 46819 ^true! ! 46820 46821!ClassBuilder methodsFor: 'validation' stamp: 'lr 7/3/2009 20:54'! 46822validateInstvars: instVarArray from: oldClass forSuper: newSuper 46823 "Check if any of the instVars of oldClass conflict with the new superclass" 46824 | instVars usedNames temp | 46825 instVarArray isEmpty ifTrue:[^true]. "Okay" 46826 newSuper allowsSubInstVars ifFalse: [ 46827 self error: newSuper printString, ' does not allow subclass inst vars. See allowsSubInstVars.'. ^ false]. 46828 46829 "Validate the inst var names" 46830 usedNames := instVarArray asSet. 46831 usedNames size = instVarArray size 46832 ifFalse:[ instVarArray do:[:var| 46833 usedNames remove: var ifAbsent:[temp := var]]. 46834 self error: temp,' is multiply defined'. ^false]. 46835 (usedNames includesAnyOf: self reservedNames) 46836 ifTrue:[ self reservedNames do:[:var| 46837 (usedNames includes: var) ifTrue:[temp := var]]. 46838 self error: temp,' is a reserved name'. ^false]. 46839 46840 newSuper == nil ifFalse:[ 46841 usedNames := newSuper allInstVarNames asSet. 46842 instVarArray do:[:iv| 46843 (usedNames includes: iv) ifTrue:[ 46844 newSuper withAllSuperclassesDo:[:cl| 46845 (cl instVarNames includes: iv) ifTrue:[temp := cl]]. 46846 self error: iv,' is already defined in ', temp name. 46847 ^false]]]. 46848 oldClass == nil ifFalse:[ 46849 usedNames := Set new: 20. 46850 oldClass allSubclassesDo:[:cl| usedNames addAll: cl instVarNames]. 46851 instVars := instVarArray. 46852 newSuper == nil ifFalse:[instVars := instVars, newSuper allInstVarNames]. 46853 instVars do:[:iv| 46854 (usedNames includes: iv) ifTrue:[ 46855 self error: iv, ' is already defined in a subclass of ', oldClass name. 46856 ^false]]]. 46857 46858 ^true! ! 46859 46860!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/13/2009 21:19'! 46861validateSubclass: subclass canKeepLayoutFrom: oldClass forSubclassFormat: newType 46862 "Returns whether the immediate subclasses of oldClass can keep its layout" 46863 "Note: Squeak does not appear to model classFormat relationships.. so I'm putting some logic here. bkv 4/2/2003" 46864 46865 "Only run this test for a real subclass - otherwise this prevents changing 46866 a class from #subclass: to #variableSubclass: etc." 46867 subclass = oldClass ifTrue:[^true]. 46868 46869 "isWeak implies isVariant" 46870 (oldClass isVariable and: [ subclass isWeak ]) 46871 ifFalse: [ "In general we discourage format mis-matches" 46872 (subclass typeOfClass == newType) 46873 ifFalse: [ self error: subclass name,' cannot be recompiled'. 46874 ^ false ]]. 46875 ^ true! ! 46876 46877!ClassBuilder methodsFor: 'validation' stamp: 'bkv 4/2/2003 17:19'! 46878validateSubclassFormat: newType from: oldClass forSuper: newSuper extra: newInstSize 46879 "Validate the # of instVars and the format of the subclasses" 46880 | deltaSize | 46881 oldClass == nil ifTrue: [^ true]. "No subclasses" 46882 "Compute the # of instvars needed for all subclasses" 46883 deltaSize := newInstSize. 46884 (oldClass notNil) 46885 ifTrue: [deltaSize := deltaSize - oldClass instVarNames size]. 46886 (newSuper notNil) 46887 ifTrue: [deltaSize := deltaSize + newSuper instSize]. 46888 (oldClass notNil and: [oldClass superclass notNil]) 46889 ifTrue: [deltaSize := deltaSize - oldClass superclass instSize]. 46890 (oldClass == nil) 46891 ifTrue: [ (deltaSize > 254) 46892 ifTrue: [ self error: 'More than 254 instance variables'. 46893 ^ false]. 46894 ^ true]. 46895 46896 oldClass withAllSubclassesDo: [:sub | ( sub instSize + deltaSize > 254 ) 46897 ifTrue: [ self error: sub name,' has more than 254 instance variables'. 46898 ^ false]. 46899 46900 "If we get this far, check whether the immediate subclasses of oldClass can keep its layout." 46901 (newType ~~ #normal) 46902 ifTrue: [ self validateSubclass: sub canKeepLayoutFrom: oldClass forSubclassFormat: newType ]]. 46903 46904 ^ true! ! 46905 46906!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/15/1999 13:50'! 46907validateSuperclass: aSuperClass forSubclass: aClass 46908 "Check if it is okay to use aSuperClass as the superclass of aClass" 46909 aClass == nil ifTrue:["New class" 46910 (aSuperClass == nil or:[aSuperClass isBehavior and:[aSuperClass isMeta not]]) 46911 ifFalse:[self error: aSuperClass name,' is not a valid superclass'. 46912 ^false]. 46913 ^true]. 46914 aSuperClass == aClass superclass ifTrue:[^true]. "No change" 46915 (aClass isMeta) "Not permitted - meta class hierarchy is derived from class hierarchy" 46916 ifTrue:[^self error: aClass name, ' must inherit from ', aClass superclass name]. 46917 "Check for circular references" 46918 (aSuperClass ~~ nil and:[aSuperClass == aClass or:[aSuperClass inheritsFrom: aClass]]) 46919 ifTrue:[self error: aSuperClass name,' inherits from ', aClass name. 46920 ^false]. 46921 ^true! ! 46922 46923 46924!ClassBuilder methodsFor: 'private' stamp: 'sd 3/28/2008 11:03'! 46925informUserDuring: aBlock 46926 self class isSilent ifTrue: [ ^ aBlock value ]. 46927 UIManager default informUserDuring: 46928 [ :bar | 46929 progress := bar. 46930 aBlock value ]. 46931 progress := nil! ! 46932 46933!ClassBuilder methodsFor: 'private' stamp: 'ar 2/27/2003 22:56'! 46934privateNewSubclassOf: newSuper 46935 "Create a new meta and non-meta subclass of newSuper" 46936 "WARNING: This method does not preserve the superclass/subclass invariant!!" 46937 | newSuperMeta newMeta | 46938 newSuperMeta := newSuper ifNil:[Class] ifNotNil:[newSuper class]. 46939 newMeta := Metaclass new. 46940 newMeta 46941 superclass: newSuperMeta 46942 methodDictionary: MethodDictionary new 46943 format: newSuperMeta format. 46944 ^newMeta new 46945! ! 46946 46947!ClassBuilder methodsFor: 'private' stamp: 'ar 2/27/2003 22:56'! 46948privateNewSubclassOf: newSuper from: oldClass 46949 "Create a new meta and non-meta subclass of newSuper using oldClass as template" 46950 "WARNING: This method does not preserve the superclass/subclass invariant!!" 46951 | newSuperMeta oldMeta newMeta | 46952 oldClass ifNil:[^self privateNewSubclassOf: newSuper]. 46953 newSuperMeta := newSuper ifNil:[Class] ifNotNil:[newSuper class]. 46954 oldMeta := oldClass class. 46955 newMeta := oldMeta clone. 46956 newMeta 46957 superclass: newSuperMeta 46958 methodDictionary: MethodDictionary new 46959 format: (self computeFormat: oldMeta typeOfClass 46960 instSize: oldMeta instVarNames size 46961 forSuper: newSuperMeta 46962 ccIndex: 0); 46963 setInstVarNames: oldMeta instVarNames; 46964 organization: oldMeta organization. 46965 "Recompile the meta class" 46966 oldMeta hasMethods 46967 ifTrue:[newMeta compileAllFrom: oldMeta]. 46968 "Record the meta class change" 46969 self recordClass: oldMeta replacedBy: newMeta. 46970 "And create a new instance" 46971 ^newMeta adoptInstance: oldClass from: oldMeta! ! 46972 46973!ClassBuilder methodsFor: 'private' stamp: 'NS 1/27/2004 14:21'! 46974recordClass: oldClass replacedBy: newClass 46975 "Keep the changes up to date when we're moving instVars around" 46976 (instVarMap includesKey: oldClass name) ifTrue:[ 46977 SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldClass to: newClass. 46978 ].! ! 46979 46980!ClassBuilder methodsFor: 'private' stamp: 'gk 2/28/2005 16:35'! 46981reservedNames 46982 "Return a list of names that must not be used for variables" 46983 ^#('self' 'super' 'thisContext' 'true' 'false' 'nil' 46984 self super thisContext #true #false #nil).! ! 46985 46986!ClassBuilder methodsFor: 'private' stamp: 'ar 3/5/2001 12:00'! 46987showProgressFor: aClass 46988 "Announce that we're processing aClass" 46989 progress == nil ifTrue:[^self]. 46990 aClass isObsolete ifTrue:[^self]. 46991 currentClassIndex := currentClassIndex + 1. 46992 (aClass hasMethods and: [aClass wantsRecompilationProgressReported]) ifTrue: 46993 [progress value: ('Recompiling ', aClass name,' (', currentClassIndex printString,'/', maxClassIndex printString,')')]! ! 46994 46995!ClassBuilder methodsFor: 'private' stamp: 'eem 7/21/2008 14:16'! 46996tooDangerousClasses 46997 "Return a list of class names which will not be modified in the public interface" 46998 ^#( 46999 "Object will break immediately" 47000 ProtoObject Object 47001 "Contexts and their superclasses" 47002 InstructionStream ContextPart BlockContext MethodContext BlockClosure 47003 "Superclasses of basic collections" 47004 Collection SequenceableCollection ArrayedCollection 47005 "Collections known to the VM" 47006 Array Bitmap String Symbol ByteArray CompiledMethod TranslatedMethod 47007 "Basic Numbers" 47008 Magnitude Number SmallInteger Float 47009 "Misc other" 47010 LookupKey Association Link Point Rectangle Behavior PositionableStream UndefinedObject 47011 ) 47012! ! 47013 47014"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 47015 47016ClassBuilder class 47017 instanceVariableNames: ''! 47018 47019!ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:50'! 47020beSilent: aBool 47021 "ClassDefiner beSilent: true" 47022 "ClassDefiner beSilent: false" 47023 QuietMode := aBool.! ! 47024 47025!ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:53'! 47026beSilentDuring: aBlock 47027 "Temporarily suppress information about what is going on" 47028 | wasSilent result | 47029 wasSilent := self isSilent. 47030 self beSilent: true. 47031 result := aBlock value. 47032 self beSilent: wasSilent. 47033 ^result! ! 47034 47035!ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:48'! 47036isSilent 47037 ^QuietMode == true! ! 47038 47039 47040!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'sd 3/28/2008 11:03'! 47041checkClassHierarchyConsistency 47042 "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following 47043 two logical equivalences hold for classes A and B: 47044 - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B 47045 - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" 47046 UIManager default informUserDuring: [ :bar | self checkClassHierarchyConsistency: bar ]! ! 47047 47048!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:03'! 47049checkClassHierarchyConsistency: informer 47050 "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following 47051 two logical equivalences hold for classes A and B: 47052 - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B 47053 - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" 47054 | classes | 47055 Transcript cr; show: 'Start checking the class hierarchy...'. 47056 Smalltalk garbageCollect. 47057 classes := Metaclass allInstances. 47058 classes keysAndValuesDo: [:index :meta | 47059 informer value:'Validating class hierarchy ', (index * 100 // classes size) printString,'%'. 47060 meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each]. 47061 self checkClassHierarchyConsistencyFor: meta. 47062 ]. 47063 Transcript show: 'OK'.! ! 47064 47065!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:48'! 47066checkClassHierarchyConsistencyFor: aClassDescription 47067 "Check whether aClassDescription has a consistent superclass and consistent regular and obsolete 47068 subclasses" 47069 47070 | mySuperclass | 47071 mySuperclass := aClassDescription superclass. 47072 (mySuperclass subclasses includes: aClassDescription) = aClassDescription isObsolete 47073 ifTrue: [self error: 'Something wrong!!']. 47074 mySuperclass ifNil: [^ self]. "Obsolete subclasses of nil cannot be stored" 47075 (mySuperclass obsoleteSubclasses includes: aClassDescription) = aClassDescription isObsolete 47076 ifFalse: [self error: 'Something wrong!!']. 47077 47078 aClassDescription subclasses do: [:each | 47079 each isObsolete ifTrue: [self error: 'Something wrong!!']. 47080 each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] 47081 ]. 47082 aClassDescription obsoleteSubclasses do: [:each | 47083 each isObsolete ifFalse: [self error: 'Something wrong!!']. 47084 each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] 47085 ].! ! 47086 47087!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'sd 3/28/2008 11:03'! 47088cleanupAndCheckClassHierarchy 47089 "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. 47090 Afterwards it checks whether the hierarchy is really consistent." 47091 UIManager default informUserDuring: [ :bar | self cleanupAndCheckClassHierarchy: bar ]! ! 47092 47093!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 15:58'! 47094cleanupAndCheckClassHierarchy: informer 47095 "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. 47096 Afterwards it checks whether the hierarchy is really consistent." 47097 47098 Transcript cr; show: '*** Before cleaning up ***'. 47099 self countReallyObsoleteClassesAndMetaclasses. 47100 self cleanupClassHierarchy: informer. 47101 self checkClassHierarchyConsistency: informer. 47102 Transcript cr; cr; show: '*** After cleaning up ***'. 47103 self countReallyObsoleteClassesAndMetaclasses.! ! 47104 47105!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'sd 3/28/2008 11:03'! 47106cleanupClassHierarchy 47107 "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." 47108 UIManager default informUserDuring: [ :bar | self cleanupClassHierarchy: bar ]! ! 47109 47110!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:02'! 47111cleanupClassHierarchy: informer 47112 "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." 47113 | classes | 47114 Transcript cr; show: 'Start fixing the class hierarchy and cleaning up...'. 47115 Smalltalk garbageCollect. 47116 classes := Metaclass allInstances. 47117 classes keysAndValuesDo: [:index :meta | 47118 informer value:'Fixing class hierarchy ', (index * 100 // classes size) printString,'%'. 47119 "Check classes before metaclasses (because Metaclass>>isObsolete 47120 checks whether the related class is obsolete)" 47121 meta allInstances do: [:each | self cleanupClassHierarchyFor: each]. 47122 self cleanupClassHierarchyFor: meta. 47123 ]. 47124 Transcript show: 'DONE'.! ! 47125 47126!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 5/8/2002 10:55'! 47127cleanupClassHierarchyFor: aClassDescription 47128 47129 | myName mySuperclass | 47130 mySuperclass := aClassDescription superclass. 47131 (self isReallyObsolete: aClassDescription) ifTrue: [ 47132 47133 "Remove class >>>from SystemDictionary if it is obsolete" 47134 myName := aClassDescription name asString. 47135 Smalltalk keys asArray do: [:each | 47136 (each asString = myName and: [(Smalltalk at: each) == aClassDescription]) 47137 ifTrue: [Smalltalk removeKey: each]]. 47138 47139 "Make class officially obsolete if it is not" 47140 (aClassDescription name asString beginsWith: 'AnObsolete') 47141 ifFalse: [aClassDescription obsolete]. 47142 47143 aClassDescription isObsolete 47144 ifFalse: [self error: 'Something wrong!!']. 47145 47146 "Add class to obsoleteSubclasses of its superclass" 47147 mySuperclass 47148 ifNil: [self error: 'Obsolete subclasses of nil cannot be stored']. 47149 (mySuperclass obsoleteSubclasses includes: aClassDescription) 47150 ifFalse: [mySuperclass addObsoleteSubclass: aClassDescription]. 47151 ] ifFalse:[ 47152 "check if superclass has aClassDescription in its obsolete subclasses" 47153 mySuperclass ifNil:[mySuperclass := Class]. "nil subclasses" 47154 mySuperclass removeObsoleteSubclass: aClassDescription. 47155 ]. 47156 "And remove its obsolete subclasses if not actual superclass" 47157 aClassDescription obsoleteSubclasses do:[:obs| 47158 obs superclass == aClassDescription ifFalse:[ 47159 aClassDescription removeObsoleteSubclass: obs]]. 47160! ! 47161 47162!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'! 47163countReallyObsoleteClassesAndMetaclasses 47164 "Counting really obsolete classes and metaclasses" 47165 47166 | metaSize classSize | 47167 Smalltalk garbageCollect. 47168 metaSize := self reallyObsoleteMetaclasses size. 47169 Transcript cr; show: 'Really obsolete metaclasses: ', metaSize printString. 47170 classSize := self reallyObsoleteClasses size. 47171 Transcript cr; show: 'Really obsolete classes: ', classSize printString; cr. 47172 "Metaclasses must correspond to classes!!" 47173 metaSize ~= classSize 47174 ifTrue: [self error: 'Serious metalevel inconsistency!!!!'].! ! 47175 47176!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'! 47177isReallyObsolete: aClassDescription 47178 "Returns whether the argument class is *really* obsolete. (Due to a bug, the method isObsolete 47179 isObsolete does not always return the right answer" 47180 47181 ^ aClassDescription isObsolete or: [(aClassDescription superclass subclasses includes: aClassDescription) not]! ! 47182 47183!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'! 47184reallyObsoleteClasses 47185 | obsoleteClasses | 47186 obsoleteClasses := OrderedCollection new. 47187 Metaclass allInstances do: [:meta | meta allInstances do: [:each | 47188 (self isReallyObsolete: each) ifTrue: [obsoleteClasses add: each]]]. 47189 ^ obsoleteClasses! ! 47190 47191!ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'! 47192reallyObsoleteMetaclasses 47193 ^ Metaclass allInstances select: [:each | self isReallyObsolete: each].! ! 47194TestCase subclass: #ClassBuilderChangeClassTypeTest 47195 instanceVariableNames: 'baseClass subClass' 47196 classVariableNames: '' 47197 poolDictionaries: '' 47198 category: 'KernelTests-Classes'! 47199 47200!ClassBuilderChangeClassTypeTest methodsFor: 'utilities' stamp: 'BG 1/5/2004 22:49'! 47201baseClassName 47202 47203 ^'TestClassForClassChangeTest'! ! 47204 47205!ClassBuilderChangeClassTypeTest methodsFor: 'utilities' stamp: 'BG 1/5/2004 22:51'! 47206cleanup 47207 baseClass ifNotNil:[baseClass removeFromSystem].! ! 47208TestCase subclass: #ClassBuilderFormatTests 47209 instanceVariableNames: 'baseClass subClass' 47210 classVariableNames: '' 47211 poolDictionaries: '' 47212 category: 'KernelTests-Classes'! 47213 47214!ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:21'! 47215testByteVariableSubclass 47216 "Ensure that the invariants for superclass/subclass format are preserved" 47217 baseClass := Object variableByteSubclass: self baseClassName 47218 instanceVariableNames: '' 47219 classVariableNames: '' 47220 poolDictionaries: '' 47221 category: 'Kernel-Tests-ClassBuilder'. 47222 [ 47223 47224 self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. 47225 self deny: (subClass isPointers). 47226 self assert: (subClass isVariable). 47227 self deny: (subClass isWeak). 47228 self assert: (subClass isBytes). 47229 subClass removeFromSystem. 47230 47231 "pointer classes" 47232 self should:[self makeIVarsSubclassOf: baseClass] raise: Error. 47233 self should:[self makeVariableSubclassOf: baseClass] raise: Error. 47234 self should:[self makeWeakSubclassOf: baseClass] raise: Error. 47235 47236 "bit classes" 47237 self shouldnt:[self makeByteVariableSubclassOf: baseClass] raise: Error. 47238 self deny: (subClass isPointers). 47239 self assert: (subClass isVariable). 47240 self deny: (subClass isWeak). 47241 self assert: (subClass isBytes). 47242 subClass removeFromSystem. 47243 47244 self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. 47245 47246 ] ensure:[self cleanup].! ! 47247 47248!ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 7/13/2009 21:18'! 47249testChangeToVariableSubclass 47250 "Ensure that the invariants for superclass/subclass format are preserved" 47251 baseClass := Object subclass: self baseClassName 47252 instanceVariableNames: '' 47253 classVariableNames: '' 47254 poolDictionaries: '' 47255 category: 'Kernel-Tests-ClassBuilder'. 47256 [ 47257 self shouldnt:[baseClass := Object variableSubclass: self baseClassName 47258 instanceVariableNames: '' 47259 classVariableNames: '' 47260 poolDictionaries: '' 47261 category: 'Kernel-Tests-ClassBuilder'] raise: Error. 47262 47263 ] ensure:[self cleanup].! ! 47264 47265!ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'! 47266testSubclass 47267 "Ensure that the invariants for superclass/subclass format are preserved" 47268 baseClass := Object subclass: self baseClassName 47269 instanceVariableNames: '' 47270 classVariableNames: '' 47271 poolDictionaries: '' 47272 category: 'Kernel-Tests-ClassBuilder'. 47273 [ 47274 self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. 47275 self assert: (subClass isPointers). 47276 self deny: (subClass isVariable). 47277 self deny: (subClass isWeak). 47278 self deny: (subClass isBytes). 47279 subClass removeFromSystem. 47280 47281 "pointer classes" 47282 self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. 47283 self assert: (subClass isPointers). 47284 self deny: (subClass isVariable). 47285 self deny: (subClass isWeak). 47286 self deny: (subClass isBytes). 47287 subClass removeFromSystem. 47288 47289 self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. 47290 self assert: (subClass isPointers). 47291 self assert:(subClass isVariable). 47292 self deny: (subClass isWeak). 47293 self deny: (subClass isBytes). 47294 subClass removeFromSystem. 47295 47296 self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. 47297 self assert: (subClass isPointers). 47298 self assert:(subClass isVariable). 47299 self assert:(subClass isWeak). 47300 self deny: (subClass isBytes). 47301 subClass removeFromSystem. 47302 47303 "bit classes" 47304 self shouldnt:[self makeByteVariableSubclassOf: baseClass] raise: Error. 47305 self deny: (subClass isPointers). 47306 self assert: (subClass isVariable). 47307 self deny: (subClass isWeak). 47308 self assert: (subClass isBytes). 47309 subClass removeFromSystem. 47310 47311 self shouldnt:[self makeWordVariableSubclassOf: baseClass] raise: Error. 47312 self deny: (subClass isPointers). 47313 self assert: (subClass isVariable). 47314 self deny: (subClass isWeak). 47315 self deny: (subClass isBytes). 47316 subClass removeFromSystem. 47317 ] ensure:[self cleanup].! ! 47318 47319!ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:21'! 47320testSubclassWithInstanceVariables 47321 "Ensure that the invariants for superclass/subclass format are preserved" 47322 baseClass := Object subclass: self baseClassName 47323 instanceVariableNames: 'var1 var2' 47324 classVariableNames: '' 47325 poolDictionaries: '' 47326 category: 'Kernel-Tests-ClassBuilder'. 47327 [ 47328 self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. 47329 self assert: (subClass isPointers). 47330 self deny: (subClass isVariable). 47331 self deny: (subClass isWeak). 47332 self deny: (subClass isBytes). 47333 subClass removeFromSystem. 47334 47335 "pointer classes" 47336 self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. 47337 self assert: (subClass isPointers). 47338 self deny: (subClass isVariable). 47339 self deny: (subClass isWeak). 47340 self deny: (subClass isBytes). 47341 subClass removeFromSystem. 47342 47343 self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. 47344 self assert: (subClass isPointers). 47345 self assert: (subClass isVariable). 47346 self deny: (subClass isWeak). 47347 self deny: (subClass isBytes). 47348 subClass removeFromSystem. 47349 47350 self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. 47351 self assert: (subClass isPointers). 47352 self assert: (subClass isVariable). 47353 self assert: (subClass isWeak). 47354 self deny: (subClass isBytes). 47355 subClass removeFromSystem. 47356 47357 "bit classes" 47358 self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. 47359 self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. 47360 ] ensure:[self cleanup].! ! 47361 47362!ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'! 47363testVariableSubclass 47364 "Ensure that the invariants for superclass/subclass format are preserved" 47365 baseClass := Object variableSubclass: self baseClassName 47366 instanceVariableNames: '' 47367 classVariableNames: '' 47368 poolDictionaries: '' 47369 category: 'Kernel-Tests-ClassBuilder'. 47370 [ 47371 "pointer classes" 47372 self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. 47373 self assert: (subClass isPointers). 47374 self assert: (subClass isVariable). 47375 self deny: (subClass isWeak). 47376 self deny: (subClass isBytes). 47377 subClass removeFromSystem. 47378 47379 self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. 47380 self assert: (subClass isPointers). 47381 self assert: (subClass isVariable). 47382 self deny: (subClass isWeak). 47383 self deny: (subClass isBytes). 47384 subClass removeFromSystem. 47385 47386 self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. 47387 self assert: (subClass isPointers). 47388 self assert: (subClass isVariable). 47389 self deny: (subClass isWeak). 47390 self deny: (subClass isBytes). 47391 subClass removeFromSystem. 47392 47393 self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. 47394 self assert: (subClass isPointers). 47395 self assert: (subClass isVariable). 47396 self assert: (subClass isWeak). 47397 self deny: (subClass isBytes). 47398 subClass removeFromSystem. 47399 47400 "bit classes" 47401 self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. 47402 self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. 47403 ] ensure:[self cleanup].! ! 47404 47405!ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'! 47406testWeakSubclass 47407 "Ensure that the invariants for superclass/subclass format are preserved" 47408 baseClass := Object weakSubclass: self baseClassName 47409 instanceVariableNames: '' 47410 classVariableNames: '' 47411 poolDictionaries: '' 47412 category: 'Kernel-Tests-ClassBuilder'. 47413 [ 47414 "pointer classes" 47415 self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. 47416 self assert: (subClass isPointers). 47417 self assert: (subClass isVariable). 47418 self assert: (subClass isWeak). 47419 self deny: (subClass isBytes). 47420 subClass removeFromSystem. 47421 47422 self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. 47423 self assert: (subClass isPointers). 47424 self assert: (subClass isVariable). 47425 self assert: (subClass isWeak). 47426 self deny: (subClass isBytes). 47427 subClass removeFromSystem. 47428 47429 self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. 47430 self assert: (subClass isPointers). 47431 self assert: (subClass isVariable). 47432 self deny: (subClass isWeak). 47433 self deny: (subClass isBytes). 47434 subClass removeFromSystem. 47435 47436 self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. 47437 self assert: (subClass isPointers). 47438 self assert: (subClass isVariable). 47439 self assert: (subClass isWeak). 47440 self deny: (subClass isBytes). 47441 subClass removeFromSystem. 47442 47443 "bit classes" 47444 self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. 47445 self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. 47446 ] ensure:[self cleanup].! ! 47447 47448!ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'! 47449testWordVariableSubclass 47450 "Ensure that the invariants for superclass/subclass format are preserved" 47451 baseClass := Object variableWordSubclass: self baseClassName 47452 instanceVariableNames: '' 47453 classVariableNames: '' 47454 poolDictionaries: '' 47455 category: 'Kernel-Tests-ClassBuilder'. 47456 [ 47457 self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. 47458 self deny: (subClass isPointers). 47459 self assert: (subClass isVariable). 47460 self deny: (subClass isWeak). 47461 self deny: (subClass isBytes). 47462 subClass removeFromSystem. 47463 47464 "pointer classes" 47465 self should:[self makeIVarsSubclassOf: baseClass] raise: Error. 47466 self should:[self makeVariableSubclassOf: baseClass] raise: Error. 47467 self should:[self makeWeakSubclassOf: baseClass] raise: Error. 47468 47469 "bit classes" 47470 self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. 47471 self shouldnt:[self makeWordVariableSubclassOf: baseClass] raise: Error. 47472 self deny: (subClass isPointers). 47473 self assert: (subClass isVariable). 47474 self deny: (subClass isWeak). 47475 self deny: (subClass isBytes). 47476 subClass removeFromSystem. 47477 47478 ] ensure:[self cleanup].! ! 47479 47480 47481!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! 47482baseClassName 47483 ^#DummyClassBuilderFormatTestSuperClass! ! 47484 47485!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! 47486cleanup 47487 subClass ifNotNil:[subClass removeFromSystem]. 47488 baseClass ifNotNil:[baseClass removeFromSystem].! ! 47489 47490!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! 47491makeByteVariableSubclassOf: aClass 47492 subClass := aClass variableByteSubclass: self subClassName 47493 instanceVariableNames: '' 47494 classVariableNames: '' 47495 poolDictionaries: '' 47496 category: 'Kernel-Tests-ClassBuilder'! ! 47497 47498!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! 47499makeIVarsSubclassOf: aClass 47500 subClass := aClass subclass: self subClassName 47501 instanceVariableNames: 'var3 var4' 47502 classVariableNames: '' 47503 poolDictionaries: '' 47504 category: 'Kernel-Tests-ClassBuilder'! ! 47505 47506!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! 47507makeNormalSubclassOf: aClass 47508 subClass := aClass subclass: self subClassName 47509 instanceVariableNames: '' 47510 classVariableNames: '' 47511 poolDictionaries: '' 47512 category: 'Kernel-Tests-ClassBuilder'! ! 47513 47514!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! 47515makeVariableSubclassOf: aClass 47516 subClass := aClass variableSubclass: self subClassName 47517 instanceVariableNames: '' 47518 classVariableNames: '' 47519 poolDictionaries: '' 47520 category: 'Kernel-Tests-ClassBuilder'.! ! 47521 47522!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:16'! 47523makeWeakSubclassOf: aClass 47524 subClass := aClass weakSubclass: self subClassName 47525 instanceVariableNames: '' 47526 classVariableNames: '' 47527 poolDictionaries: '' 47528 category: 'Kernel-Tests-ClassBuilder'! ! 47529 47530!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:16'! 47531makeWordVariableSubclassOf: aClass 47532 subClass := aClass variableWordSubclass: self subClassName 47533 instanceVariableNames: '' 47534 classVariableNames: '' 47535 poolDictionaries: '' 47536 category: 'Kernel-Tests-ClassBuilder'! ! 47537 47538!ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:16'! 47539subClassName 47540 ^#DummyClassBuilderFormatTestSubClass! ! 47541Object subclass: #ClassCategoryReader 47542 instanceVariableNames: 'class category changeStamp' 47543 classVariableNames: '' 47544 poolDictionaries: '' 47545 category: 'Kernel-Classes'! 47546!ClassCategoryReader commentStamp: '<historical>' prior: 0! 47547I represent a mechanism for retrieving class descriptions stored on a file.! 47548 47549 47550!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'al 11/28/2005 22:10'! 47551scanFrom: aStream 47552 "File in methods from the stream, aStream." 47553 | methodText | 47554 [methodText := aStream nextChunkText. 47555 methodText size > 0] 47556 whileTrue: 47557 [class compile: methodText classified: category 47558 withStamp: changeStamp notifying: nil]! ! 47559 47560!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'tk 1/27/2000 23:24'! 47561scanFromNoCompile: aStream 47562 "Just move the source code for the methods from aStream." 47563 | methodText selector | 47564 47565 [methodText := aStream nextChunkText. 47566 methodText size > 0] 47567 whileTrue: 47568 [(SourceFiles at: 2) ifNotNil: [ 47569 selector := class parserClass new parseSelector: methodText. 47570 (class compiledMethodAt: selector) putSource: methodText 47571 fromParseNode: nil class: class category: category 47572 withStamp: changeStamp inFile: 2 priorMethod: nil]]! ! 47573 47574!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'RAA 6/22/2000 16:08'! 47575scanFromNoCompile: aStream forSegment: anImageSegment 47576 47577 ^self scanFromNoCompile: aStream "subclasses may care about the segment"! ! 47578 47579 47580!ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'! 47581setClass: aClass category: aCategory 47582 ^ self setClass: aClass category: aCategory changeStamp: String new 47583! ! 47584 47585!ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'! 47586setClass: aClass category: aCategory changeStamp: aString 47587 47588 class := aClass. 47589 category := aCategory. 47590 changeStamp := aString 47591! ! 47592 47593!ClassCategoryReader methodsFor: 'private' stamp: 'ajh 1/18/2002 01:14'! 47594theClass 47595 47596 ^ class! ! 47597 47598"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 47599 47600ClassCategoryReader class 47601 instanceVariableNames: ''! 47602Object subclass: #ClassChangeRecord 47603 instanceVariableNames: 'inForce revertable changeTypes thisDefinition priorDefinition thisName priorName thisOrganization priorOrganization thisComment priorComment thisMD priorMD methodChanges' 47604 classVariableNames: '' 47605 poolDictionaries: '' 47606 category: 'System-Changes'! 47607!ClassChangeRecord commentStamp: '<historical>' prior: 0! 47608A ClassChangeRecorder keeps track of most substantive changes premissible in a project, isolated or not. 47609 47610Structure: 47611inForce a boolean 47612 Tells whether these changes are in effect. 47613 true for all changeSets in and above the current project. 47614 It should be sufficient only to record this for the changeSet 47615 as a whole, but this redundancy could help in error recovery. 47616classIsLocal a boolean 47617 True if and only if this class is defined in this layer of the 47618 project structure. 47619changeTypes an identitySet 47620 Summarizes which changes have been made in this class. 47621 Values include #comment, #reorganize, #rename, 47622 and the four more summarized below. 47623thisName a string 47624 Retains the class name for this layer. 47625priorName a string 47626 Preserves the prior name. 47627thisComment a text 47628 Retains the class comment for this layer. 47629priorComment a text 47630 Preserves the prior comment. 47631thisOrganization a classOrganizer 47632 Retains the class organization for this layer. 47633priorOrganization a classOrganizer 47634 Preserves the prior organization. 47635thisMD a methodDictionary 47636 Used to prepare changes for nearly atomic invocation 47637 of this layer (see below). 47638priorMD a methodDictionary 47639 Preserves the state of an altered class as it exists in the next 47640 outer layer of the project structure. 47641methodChanges a dictionary of classChangeRecords 47642 Retains all the method changes for this layer. 47643 47644Four of the possible changeTypes are maintained in a mutually exclusive set, analogously to MethodChangeRecords. Here is a simple summary of the relationship between these four changeType symbols and the recording of prior state 47645 | prior == nil | prior not nil 47646 --------- |---------------------------- |-------------------- 47647 add | add | change 47648 --------- |---------------------------- |-------------------- 47649 remove | addedThenRemoved | remove 47650 47651A classChangeRecorder is notified of changes by the method 47652 noteMethodChange: <ClassChangeRecord>. 47653ClassChangeRecorders are designed to invoke a set of changes relative to the definition of a class in an prior layer. It is important that both invocation and revocation of these changes take place in a nearly atomic fashion so that interdependent changes will be adopted as a whole, and so that only one flush of the method cache should be necessary. A further reason for revocation to be simple is that it may be requested as an attempt to recover from an error in a project that is failing.! 47654 47655 47656!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 4/2/2000 21:39'! 47657allChangeTypes 47658 47659 | chgs | 47660 (priorName ~~ nil and: [changeTypes includes: #rename]) ifTrue: 47661 [(chgs := changeTypes copy) add: 'oldName: ' , priorName. 47662 ^ chgs]. 47663 ^ changeTypes! ! 47664 47665!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 4/2/2000 21:59'! 47666assimilateAllChangesIn: otherRecord 47667 47668 | selector changeRecord changeType | 47669 otherRecord isClassRemoval ifTrue: [^ self noteChangeType: #remove]. 47670 47671 otherRecord allChangeTypes do: 47672 [:chg | self noteChangeType: chg fromClass: self realClass]. 47673 47674 otherRecord methodChanges associationsDo: 47675 [:assn | selector := assn key. changeRecord := assn value. 47676 changeType := changeRecord changeType. 47677 (changeType == #remove or: [changeType == #addedThenRemoved]) 47678 ifTrue: 47679 [changeType == #addedThenRemoved 47680 ifTrue: [self atSelector: selector put: #add]. 47681 self noteRemoveSelector: selector priorMethod: nil 47682 lastMethodInfo: changeRecord methodInfoFromRemoval] 47683 ifFalse: 47684 [self atSelector: selector put: changeType]]. 47685! ! 47686 47687!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/28/2000 10:59'! 47688hasNoChanges 47689 47690 ^ changeTypes isEmpty and: [methodChanges isEmpty]! ! 47691 47692!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/24/2000 09:36'! 47693includesChangeType: changeType 47694 47695 changeType == #new ifTrue: [^ changeTypes includes: #add]. "Backwd compat" 47696 ^ changeTypes includes: changeType! ! 47697 47698!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/28/2000 15:14'! 47699noteChangeType: changeSymbol 47700 47701 ^ self noteChangeType: changeSymbol fromClass: nil! ! 47702 47703!ClassChangeRecord methodsFor: 'all changes' stamp: 'sw 4/3/2001 14:16'! 47704noteChangeType: changeSymbol fromClass: class 47705 47706 (changeSymbol = #new or: [changeSymbol = #add]) ifTrue: 47707 [changeTypes add: #add. 47708 changeTypes remove: #change ifAbsent: []. 47709 revertable := false. 47710 ^ self]. 47711 changeSymbol = #change ifTrue: 47712 [(changeTypes includes: #add) ifTrue: [^ self]. 47713 ^ changeTypes add: changeSymbol]. 47714 changeSymbol == #addedThenRemoved ifTrue: 47715 [^ self]. "An entire class was added but then removed" 47716 changeSymbol = #comment ifTrue: 47717 [^ changeTypes add: changeSymbol]. 47718 changeSymbol = #reorganize ifTrue: 47719 [^ changeTypes add: changeSymbol]. 47720 changeSymbol = #rename ifTrue: 47721 [^ changeTypes add: changeSymbol]. 47722 (changeSymbol beginsWith: 'oldName: ') ifTrue: 47723 ["Must only be used when assimilating other changeSets" 47724 (changeTypes includes: #add) ifTrue: [^ self]. 47725 priorName := changeSymbol copyFrom: 'oldName: ' size + 1 to: changeSymbol size. 47726 ^ changeTypes add: #rename]. 47727 changeSymbol = #remove ifTrue: 47728 [(changeTypes includes: #add) 47729 ifTrue: [changeTypes add: #addedThenRemoved] 47730 ifFalse: [changeTypes add: #remove]. 47731 ^ changeTypes removeAllFoundIn: #(add change comment reorganize)]. 47732 47733 self error: 'Unrecognized changeType'! ! 47734 47735!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 5/16/2000 08:43'! 47736trimHistory 47737 "Drop non-essential history." 47738 47739 "Forget methods added and later removed" 47740 methodChanges keysAndValuesRemove: 47741 [:sel :chgRecord | chgRecord changeType == #addedThenRemoved]. 47742 47743 "Forget renaming and reorganization of newly-added classes." 47744 (changeTypes includes: #add) ifTrue: 47745 [changeTypes removeAllFoundIn: #(rename reorganize)]. 47746! ! 47747 47748 47749!ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/27/2000 22:06'! 47750checkCoherence 47751 "If I recreate the class then don't remove it" 47752 47753 (changeTypes includes: #remove) ifTrue: 47754 [changeTypes remove: #remove. 47755 changeTypes add: #change]. 47756 (changeTypes includes: #addedThenRemoved) ifTrue: 47757 [changeTypes remove: #addedThenRemoved. 47758 changeTypes add: #add]. 47759! ! 47760 47761!ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/27/2000 22:08'! 47762notePriorDefinition: oldClass 47763 47764 oldClass ifNil: [^ self]. 47765 priorDefinition ifNil: [priorDefinition := oldClass definition]! ! 47766 47767!ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/28/2000 09:12'! 47768priorDefinition 47769 47770 ^ priorDefinition! ! 47771 47772 47773!ClassChangeRecord methodsFor: 'initialization' stamp: 'di 4/5/2000 08:11'! 47774initFor: className revertable: isRevertable 47775 47776 inForce := isRevertable. 47777 changeTypes := IdentitySet new. 47778 methodChanges := IdentityDictionary new. 47779 priorName := thisName := className. 47780 revertable := isRevertable and: [self realClass notNil]. 47781 revertable ifTrue: 47782 [priorMD := self realClass methodDict copy. 47783 priorOrganization := self realClass organization deepCopy]. 47784! ! 47785 47786!ClassChangeRecord methodsFor: 'initialization' stamp: 'di 9/21/2000 12:34'! 47787zapHistory 47788 "Drop all recorded information not needed to simply keep track of what has been changed. 47789 Saves a lot of space." 47790 47791 methodChanges do: [:r | r noteNewMethod: nil]. "Drop all refes to old methods" 47792 thisOrganization := nil. 47793 priorOrganization := nil. 47794 thisComment := nil. 47795 priorComment := nil. 47796 thisMD := nil. 47797 priorMD := nil.! ! 47798 47799 47800!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'eem 6/11/2008 16:51'! 47801invokePhase1 47802 47803 | elements | 47804 revertable ifFalse: [^ self]. 47805 inForce ifTrue: [self error: 'Can invoke only when not in force.']. 47806 47807 "Do the first part of the invoke operation -- no particular hurry." 47808 "Save the outer method dictionary for quick revert of method changes." 47809 priorMD := self realClass methodDict. 47810 47811 "Prepare a methodDictionary for switcheroo." 47812 thisMD := self realClass methodDict copy. 47813 methodChanges associationsDo: 47814 [:assn | | selector changeRecord type | 47815 selector := assn key. 47816 changeRecord := assn value. 47817 type := changeRecord changeType. 47818 type = #remove ifTrue: [thisMD removeKey: selector]. 47819 type = #add ifTrue: [thisMD at: selector put: changeRecord currentMethod]. 47820 type = #change ifTrue: [thisMD at: selector put: changeRecord currentMethod]. 47821 ]. 47822 47823 "Replace the original organization (and comment)." 47824 priorOrganization := self realClass organization. 47825 thisOrganization elementArray copy do: 47826 [:sel | (thisMD includesKey: sel) ifFalse: [thisOrganization removeElement: sel]]. 47827 #(DoIt DoItIn:) do: [:sel | thisMD removeKey: sel ifAbsent: []]. 47828 thisOrganization elementArray size = thisMD size ifFalse: 47829 [elements := thisOrganization elementArray asSet. 47830 thisMD keysDo: 47831 [:sel | (elements includes: sel) ifFalse: 47832 [thisOrganization classify: sel 47833 under: (priorOrganization categoryOfElement: sel)]]]. 47834 self realClass organization: thisOrganization. 47835 47836 47837! ! 47838 47839!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:50'! 47840invokePhase2 47841 47842 revertable ifFalse: [^ self]. 47843 47844 "Do the second part of the revert operation. This must be very simple." 47845 "Replace original method dicts if there are method changes." 47846 self realClass methodDictionary: thisMD. "zap. Must flush Cache in outer loop." 47847 inForce := true. 47848! ! 47849 47850!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/30/2000 18:03'! 47851realClass 47852 "Return the actual class (or meta), as determined from my name." 47853 47854 thisName ifNil: [^ nil]. 47855 (thisName endsWith: ' class') 47856 ifTrue: [^ (Smalltalk at: (thisName copyFrom: 1 to: thisName size - 6) asSymbol 47857 ifAbsent: [^ nil]) class] 47858 ifFalse: [^ Smalltalk at: thisName ifAbsent: [^ nil]]! ! 47859 47860!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:50'! 47861revokePhase1 47862 47863 revertable ifFalse: [^ self]. 47864 inForce ifFalse: [self error: 'Can revoke only when in force.']. 47865 47866 "Do the first part of the revoke operation. This must be very simple." 47867 "Replace original method dict if there are method changes." 47868 self realClass methodDictionary: priorMD "zap. Must flush Cache in outer loop."! ! 47869 47870!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:50'! 47871revokePhase2 47872 47873 revertable ifFalse: [^ self]. 47874 47875 "Replace the original organization (and comment)." 47876 thisOrganization := self realClass organization. 47877 self realClass organization: priorOrganization. 47878 inForce := false. 47879! ! 47880 47881 47882!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 10:38'! 47883atSelector: selector ifAbsent: absentBlock 47884 47885 ^ (methodChanges at: selector ifAbsent: absentBlock) 47886 changeType! ! 47887 47888!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 11:01'! 47889atSelector: selector put: changeType 47890 47891 (self findOrMakeMethodChangeAt: selector priorMethod: nil) 47892 noteChangeType: changeType! ! 47893 47894!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 10:07'! 47895changedSelectors 47896 "Return a set of the changed or removed selectors." 47897 47898 ^ methodChanges keys! ! 47899 47900!ClassChangeRecord methodsFor: 'method changes' stamp: 'eem 6/11/2008 16:50'! 47901compileAll: newClass from: oldClass 47902 "Something about this class has changed. Locally retained methods must be recompiled. 47903 NOTE: You might think that if this changeSet is in force, then we can just note 47904 the new methods but a lower change set may override and be in force which 47905 would mean that only the overriding copies go recompiled. Just do it." 47906 47907 methodChanges associationsDo: 47908 [:assn | | sel changeType changeRecord newMethod | 47909 sel := assn key. 47910 changeRecord := assn value. 47911 changeType := changeRecord changeType. 47912 (changeType == #add or: [changeType == #change]) ifTrue: 47913 [newMethod := newClass 47914 recompileNonResidentMethod: changeRecord currentMethod 47915 atSelector: sel from: oldClass. 47916 changeRecord noteNewMethod: newMethod]]! ! 47917 47918!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 11:01'! 47919findOrMakeMethodChangeAt: selector priorMethod: priorMethod 47920 47921 ^ methodChanges at: selector 47922 ifAbsent: [methodChanges at: selector 47923 put: (MethodChangeRecord new priorMethod: priorMethod)]! ! 47924 47925!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/29/2000 16:26'! 47926infoFromRemoval: selector 47927 47928 ^ (methodChanges at: selector ifAbsent: [^ nil]) 47929 methodInfoFromRemoval 47930 47931! ! 47932 47933!ClassChangeRecord methodsFor: 'method changes' stamp: 'eem 6/11/2008 16:53'! 47934methodChangeTypes 47935 "Return an old-style dictionary of method change types." 47936 47937 | dict | 47938 dict := IdentityDictionary new. 47939 methodChanges associationsDo: 47940 [:assn | | selector record | 47941 selector := assn key. 47942 record := assn value. 47943 dict at: selector put: record changeType]. 47944 ^ dict! ! 47945 47946!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 4/1/2000 23:49'! 47947methodChanges 47948 47949 ^ methodChanges! ! 47950 47951!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 23:28'! 47952noteNewMethod: newMethod selector: selector priorMethod: methodOrNil 47953 47954 | methodChange | 47955 methodChange := self findOrMakeMethodChangeAt: selector priorMethod: methodOrNil. 47956 methodOrNil == nil 47957 ifTrue: [methodChange noteChangeType: #add] 47958 ifFalse: [methodChange noteChangeType: #change]. 47959 methodChange noteNewMethod: newMethod. 47960! ! 47961 47962!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/23/2000 23:00'! 47963noteRemoveSelector: selector priorMethod: priorMethod lastMethodInfo: infoOrNil 47964 47965 | methodChange | 47966 methodChange := self findOrMakeMethodChangeAt: selector priorMethod: priorMethod. 47967 methodChange changeType == #add 47968 ifTrue: [methodChange noteChangeType: #addedThenRemoved] 47969 ifFalse: [methodChange noteChangeType: #remove]. 47970 47971 infoOrNil ifNotNil: 47972 ["Save the source code pointer and category so can still browse old versions" 47973 methodChange noteMethodInfoFromRemoval: infoOrNil] 47974 47975! ! 47976 47977!ClassChangeRecord methodsFor: 'method changes' stamp: 'sw 8/14/2002 11:11'! 47978removeSelector: selector 47979 "Remove all memory of changes associated with the argument, selector, in this class." 47980 47981 selector == #Comment 47982 ifTrue: 47983 [changeTypes remove: #comment ifAbsent: []] 47984 ifFalse: 47985 [methodChanges removeKey: selector ifAbsent: []]! ! 47986 47987 47988!ClassChangeRecord methodsFor: 'removal' stamp: 'eem 6/11/2008 16:50'! 47989forgetChangesIn: otherRecord 47990 "See forgetAllChangesFoundIn:. Used in culling changeSets." 47991 47992 | cls otherMethodChanges | 47993 (cls := self realClass) == nil ifTrue: [^ self]. "We can do better now, though..." 47994 otherMethodChanges := otherRecord methodChangeTypes. 47995 otherMethodChanges associationsDo: 47996 [:assoc | | selector actionToSubtract | 47997 selector := assoc key. actionToSubtract := assoc value. 47998 (cls includesSelector: selector) 47999 ifTrue: [(#(add change) includes: actionToSubtract) 48000 ifTrue: [methodChanges removeKey: selector ifAbsent: []]] 48001 ifFalse: [(#(remove addedThenRemoved) includes: actionToSubtract) 48002 ifTrue: [methodChanges removeKey: selector ifAbsent: []]]]. 48003 changeTypes isEmpty ifFalse: 48004 [changeTypes removeAllFoundIn: otherRecord allChangeTypes. 48005 (changeTypes includes: #rename) ifFalse: 48006 [changeTypes removeAllSuchThat: [:x | x beginsWith: 'oldName: ']]]! ! 48007 48008!ClassChangeRecord methodsFor: 'removal' stamp: 'di 3/23/2000 12:27'! 48009forgetClassRemoval 48010 48011 self halt.! ! 48012 48013!ClassChangeRecord methodsFor: 'removal' stamp: 'di 4/1/2000 23:05'! 48014isClassRemoval 48015 "NOTE: there are other removals with changeType #addedThenRemoved, 48016 but this message is used to write out removals in fileOut, and those 48017 cases should not be written out." 48018 48019 ^ (changeTypes includes: #remove) or: [changeTypes includes: #removeClass]! ! 48020 48021 48022!ClassChangeRecord methodsFor: 'rename' stamp: 'di 5/8/2000 20:39'! 48023noteNewName: newName 48024 48025 thisName := newName! ! 48026 48027!ClassChangeRecord methodsFor: 'rename' stamp: 'di 3/24/2000 09:38'! 48028priorName 48029 48030 ^ priorName! ! 48031 48032!ClassChangeRecord methodsFor: 'rename' stamp: 'tk 6/8/2001 09:11'! 48033thisName 48034 48035 ^ thisName! ! 48036ClassCategoryReader subclass: #ClassCommentReader 48037 instanceVariableNames: '' 48038 classVariableNames: '' 48039 poolDictionaries: '' 48040 category: 'Kernel-Classes'! 48041 48042!ClassCommentReader methodsFor: 'fileIn/Out' stamp: 'sw 7/31/2002 10:40'! 48043scanFrom: aStream 48044 "File in the class comment from aStream. Not string-i-fied, just a text, exactly as it is in the browser. Move to changes file." 48045 48046 class theNonMetaClass classComment: (aStream nextChunkText) stamp: changeStamp 48047 "Writes it on the disk and saves a RemoteString ref"! ! 48048 48049!ClassCommentReader methodsFor: 'fileIn/Out' stamp: 'tk 1/27/2000 22:56'! 48050scanFromNoCompile: aStream 48051 "File in the class comment from aStream. Not string-i-fied, just a text, exactly as it is in the browser. Move to changes file." 48052 48053 self scanFrom: aStream. "for comments, the same as usual"! ! 48054 48055"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 48056 48057ClassCommentReader class 48058 instanceVariableNames: ''! 48059 48060!ClassCommentReader class methodsFor: 'instance creation' stamp: 'AndrewBlack 9/1/2009 06:42'! 48061forClass: aClass 48062 ^ self new setClass: aClass category: #Comment ! ! 48063VersionsBrowser subclass: #ClassCommentVersionsBrowser 48064 instanceVariableNames: '' 48065 classVariableNames: '' 48066 poolDictionaries: '' 48067 category: 'Tools-Changes'! 48068!ClassCommentVersionsBrowser commentStamp: 'asm 8/13/2002 23:20' prior: 0! 48069A class-comment-versions-browser tool! 48070 48071 48072!ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'sd 11/20/2005 21:26'! 48073diffedVersionContents 48074 "Answer diffed version contents, maybe pretty maybe not" 48075 48076 | change class earlier later | 48077 (listIndex = 0 48078 or: [changeList size < listIndex]) 48079 ifTrue: [^ '']. 48080 change := changeList at: listIndex. 48081 later := change text. 48082 class := self selectedClass. 48083 (listIndex == changeList size or: [class == nil]) 48084 ifTrue: [^ later]. 48085 48086 earlier := (changeList at: listIndex + 1) text. 48087 48088 ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! ! 48089 48090!ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'sd 11/20/2005 21:26'! 48091reformulateList 48092 48093 classOfMethod organization classComment ifNil: [^ self]. 48094 48095 self scanVersionsOf: classOfMethod. 48096 self changed: #list. "for benefit of mvc" 48097 listIndex := 1. 48098 self changed: #listIndex. 48099 self contentsChanged! ! 48100 48101!ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'sd 11/20/2005 21:26'! 48102scanVersionsOf: class 48103 "Scan for all past versions of the class comment of the given class" 48104 48105 | oldCommentRemoteStr sourceFilesCopy position prevPos stamp preamble tokens prevFileIndex | 48106 48107 classOfMethod := class. 48108 oldCommentRemoteStr := class organization commentRemoteStr. 48109 currentCompiledMethod := oldCommentRemoteStr. 48110 selectorOfMethod := #Comment. 48111 changeList := OrderedCollection new. 48112 list := OrderedCollection new. 48113 listIndex := 0. 48114 oldCommentRemoteStr ifNil:[^ nil] ifNotNil: [oldCommentRemoteStr sourcePointer]. 48115 48116 sourceFilesCopy := SourceFiles collect: 48117 [:x | x isNil ifTrue: [ nil ] 48118 ifFalse: [x readOnlyCopy]]. 48119 position := oldCommentRemoteStr position. 48120 file := sourceFilesCopy at: oldCommentRemoteStr sourceFileNumber. 48121 [position notNil & file notNil] 48122 whileTrue: 48123 [file position: (0 max: position-150). " Skip back to before the preamble" 48124 [file position < (position-1)] "then pick it up from the front" 48125 whileTrue: [preamble := file nextChunk]. 48126 48127 prevPos := nil. 48128 stamp := ''. 48129 (preamble findString: 'commentStamp:' startingAt: 1) > 0 48130 ifTrue: [tokens := Scanner new scanTokens: preamble. 48131 (tokens at: tokens size-3) = #commentStamp: 48132 ifTrue: ["New format gives change stamp and unified prior pointer" 48133 stamp := tokens at: tokens size-2. 48134 prevPos := tokens last. 48135 prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos. 48136 prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos]] 48137 ifFalse: ["The stamp get lost, maybe after a condenseChanges" 48138 stamp := '<historical>']. 48139 self addItem: 48140 (ChangeRecord new file: file position: position type: #classComment 48141 class: class name category: nil meta: class stamp: stamp) 48142 text: stamp , ' ' , class name , ' class comment'. 48143 prevPos = 0 ifTrue:[prevPos := nil]. 48144 position := prevPos. 48145 prevPos notNil 48146 ifTrue:[file := sourceFilesCopy at: prevFileIndex]]. 48147 sourceFilesCopy do: [:x | x notNil ifTrue: [x close]]. 48148 listSelections := Array new: list size withAll: false! ! 48149 48150!ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'sd 11/20/2005 21:26'! 48151updateListsAndCodeIn: aWindow 48152 | aComment | 48153 aComment := classOfMethod organization commentRemoteStr. 48154 aComment == currentCompiledMethod 48155 ifFalse: 48156 ["Do not attempt to formulate if there is no source pointer. 48157 It probably means it has been recompiled, but the source hasn't been written 48158 (as during a display of the 'save text simply?' confirmation)." 48159 aComment last ~= 0 ifTrue: [self reformulateList]]. 48160 ^ true 48161! ! 48162 48163 48164!ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'sd 11/20/2005 21:26'! 48165compareToCurrentVersion 48166 "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text" 48167 48168 | change s1 s2 | 48169 listIndex = 0 48170 ifTrue: [^ self]. 48171 change := changeList at: listIndex. 48172 s1 := classOfMethod organization classComment. 48173 s2 := change string. 48174 s1 = s2 48175 ifTrue: [^ self inform: 'Exact Match']. 48176 (StringHolder new 48177 textContents: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2 inClass: classOfMethod prettyDiffs: self showingPrettyDiffs)) 48178 openLabel: 'Comparison to Current Version'! ! 48179 48180!ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'asm 8/13/2002 21:02'! 48181offerVersionsHelp 48182 (StringHolder new contents: self versionsHelpString) 48183 openLabel: 'Class Comment Versions Browsers'! ! 48184 48185!ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'sd 11/20/2005 21:26'! 48186openSingleMessageBrowser 48187 | mr | 48188 "Create and schedule a message list browser populated only by the currently selected message" 48189 48190 mr := MethodReference new 48191 setStandardClass: self selectedClass 48192 methodSymbol: #Comment. 48193 48194 self systemNavigation 48195 browseMessageList: (Array with: mr) 48196 name: mr asStringOrText 48197 autoSelect: nil! ! 48198 48199!ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'alain.plantec 5/30/2008 11:20'! 48200versionsMenu: aMenu 48201 "Fill aMenu with menu items appropriate to the receiver" 48202 48203 aMenu title: 'versions'. 48204 aMenu addStayUpItemSpecial. 48205 ^ aMenu addList: #( 48206 48207 ('compare to current' compareToCurrentVersion 'compare selected version to the current version') 48208 ('revert to selected version' fileInSelections 'resubmit the selected version, so that it becomes the current version') 48209 ('remove from changes' removeMethodFromChanges 'remove this method from the current change set, if present') 48210 ('edit current method (O)' openSingleMessageBrowser 'open a single-message browser on the current version of this method') 48211 - 48212 ('toggle diffing (D)' toggleDiffing 'toggle whether or not diffs should be shown here') 48213 ('update list' reformulateList 'reformulate the list of versions, in case it somehow got out of synch with reality') 48214 - 48215 ('help...' offerVersionsHelp 'provide an explanation of the use of this tool')) 48216! ! 48217 48218 48219!ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/17/2002 21:57'! 48220classCommentIndicated 48221 "Answer whether the receiver is pointed at a class comment" 48222 48223 ^ true! ! 48224 48225!ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/15/2002 22:38'! 48226contentsSymbolQuints 48227 "Answer a list of quintuplets representing information on the alternative views available in the code pane" 48228 48229 ^ #( 48230(source togglePlainSource showingPlainSourceString 'source' 'the textual source code as writen') 48231(showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version'))! ! 48232 48233!ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sd 11/20/2005 21:26'! 48234priorSourceOrNil 48235 "If the currently-selected method has a previous version, return its source, else return nil" 48236 | aClass aSelector changeRecords | 48237 (aClass := self selectedClass) ifNil: [^ nil]. 48238 (aSelector := self selectedMessageName) ifNil: [^ nil]. 48239 changeRecords := self class commentRecordsOf: self selectedClass. 48240 (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil]. 48241 ^ (changeRecords at: 2) string 48242! ! 48243 48244!ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'asm 8/13/2002 20:59'! 48245selectedClass 48246 "Answer the class currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane" 48247 48248 ^ classOfMethod! ! 48249 48250!ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/15/2002 22:35'! 48251wantsPrettyDiffOption 48252 "Answer whether pretty-diffs are meaningful for this tool" 48253 48254 ^ false! ! 48255 48256"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 48257 48258ClassCommentVersionsBrowser class 48259 instanceVariableNames: ''! 48260 48261!ClassCommentVersionsBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 48262browseCommentOf: class 48263 | changeList | 48264 Cursor read showWhile: 48265 [changeList := self new scanVersionsOf: class. 48266 changeList ifNil: [^ self inform: 'No versions available']. 48267 self open: changeList name: 'Recent versions of ',class name,'''s comments' multiSelect: false ] 48268! ! 48269 48270 48271!ClassCommentVersionsBrowser class methodsFor: 'utilities' stamp: 'sd 11/20/2005 21:28'! 48272commentRecordsOf: aClass 48273 "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." 48274 48275 | aList | 48276 aList := self new 48277 scanVersionsOf: aClass. 48278 ^ aList ifNotNil: [aList changeList]! ! 48279 48280!ClassCommentVersionsBrowser class methodsFor: 'utilities' stamp: 'sd 11/20/2005 21:28'! 48281timeStampFor: aSelector class: aClass reverseOrdinal: anInteger 48282 "Answer the time stamp corresponding to some version of the given method, nil if none. The reverseOrdinal parameter is interpreted as: 1 = current version; 2 = last-but-one version, etc." 48283 48284 | aChangeList | 48285 aChangeList := self new scanVersionsOf: aClass. 48286 ^ aChangeList ifNil: [nil] ifNotNil: 48287 [aChangeList list size >= anInteger 48288 ifTrue: 48289 [(aChangeList changeList at: anInteger) stamp] 48290 ifFalse: 48291 [nil]]! ! 48292 48293 48294!ClassCommentVersionsBrowser class methodsFor: 'window color' stamp: 'asm 8/13/2002 20:57'! 48295windowColorSpecification 48296 "Answer a WindowColorSpec object that declares my preference" 48297 48298 ^ WindowColorSpec classSymbol: self name wording: 'Class Comment Versions Browser' brightColor: #(0.769 0.653 1.0) pastelColor: #(0.819 0.753 1.0) helpMessage: 'A tool for viewing prior versions of a class comment.'! ! 48299Behavior subclass: #ClassDescription 48300 uses: TClassAndTraitDescription 48301 instanceVariableNames: 'instanceVariables organization' 48302 classVariableNames: '' 48303 poolDictionaries: '' 48304 category: 'Kernel-Classes'! 48305!ClassDescription commentStamp: '<historical>' prior: 0! 48306I add a number of facilities to basic Behaviors: 48307 Named instance variables 48308 Category organization for methods 48309 The notion of a name of this class (implemented as subclass responsibility) 48310 The maintenance of a ChangeSet, and logging changes on a file 48311 Most of the mechanism for fileOut. 48312 48313I am an abstract class, in particular, my facilities are intended for inheritance by two subclasses, Class and Metaclass. 48314 48315The slots 'organization' and 'methodDict' should ONLY be accessed by message in order for things to work during ImageSegment>>discoverActiveClasses (q.v.).! 48316 48317 48318!ClassDescription methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:45'! 48319allUnreferencedClassVariables 48320 "Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses" 48321 48322 ^ self systemNavigation allUnreferencedClassVariablesOf: self! ! 48323 48324 48325!ClassDescription methodsFor: 'accessing' stamp: 'sd 6/27/2003 23:57'! 48326classVersion 48327 "Default. Any class may return a later version to inform readers that use ReferenceStream. 8/17/96 tk" 48328 "This method allows you to distinguish between class versions when the shape of the class 48329 hasn't changed (when there's no change in the instVar names). 48330 In the conversion methods you usually can tell by the inst var names 48331 what old version you have. In a few cases, though, the same inst var 48332 names were kept but their interpretation changed (like in the layoutFrame). 48333 By changing the class version when you keep the same instVars you can 48334 warn older and newer images that they have to convert." 48335 ^ 0! ! 48336 48337!ClassDescription methodsFor: 'accessing' stamp: 'NS 12/9/2003 15:12'! 48338version 48339 "Allows polymoprhism with TraitDescription>>version" 48340 48341 ^ self classVersion! ! 48342 48343 48344!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'di 2/17/2000 22:36'! 48345classesThatImplementAllOf: selectorSet 48346 "Return an array of any classes that implement all the messages in selectorSet." 48347 48348 | found remaining | 48349 found := OrderedCollection new. 48350 selectorSet do: 48351 [:sel | (self methodDict includesKey: sel) ifTrue: [found add: sel]]. 48352 found isEmpty 48353 ifTrue: [^ self subclasses inject: Array new 48354 into: [:subsThatDo :sub | 48355 subsThatDo , (sub classesThatImplementAllOf: selectorSet)]] 48356 ifFalse: [remaining := selectorSet copyWithoutAll: found. 48357 remaining isEmpty ifTrue: [^ Array with: self]. 48358 ^ self subclasses inject: Array new 48359 into: [:subsThatDo :sub | 48360 subsThatDo , (sub classesThatImplementAllOf: remaining)]]! ! 48361 48362!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'dtl 8/26/2004 11:02'! 48363commentInventory 48364 "Answer a string with a count of the classes with and without comments 48365 for all the classes in the package of which this class is a member." 48366 48367 "Morph commentInventory" 48368 48369 ^ SystemOrganization commentInventory: (self category copyUpTo: $-), '*'! ! 48370 48371!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'al 11/28/2005 11:51'! 48372printSubclassesOn: aStream level: level 48373 "As part of the algorithm for printing a description of the receiver, print the 48374 subclass on the file stream, aStream, indenting level times." 48375 48376 | subclassNames | 48377 aStream crtab: level. 48378 aStream nextPutAll: self name. 48379 aStream space; print: self instVarNames. 48380 self == Class 48381 ifTrue: 48382 [aStream crtab: level + 1; nextPutAll: '[ ... all the Metaclasses ... ]'. 48383 ^self]. 48384 subclassNames := self subclasses asSortedCollection:[:c1 :c2| c1 name <= c2 name]. 48385 "Print subclasses in alphabetical order" 48386 subclassNames do: 48387 [:subclass | subclass printSubclassesOn: aStream level: level + 1]! ! 48388 48389!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'al 11/28/2005 11:52'! 48390removeUninstantiatedSubclassesSilently 48391 "Remove the classes of any subclasses that have neither instances nor subclasses. Answer the number of bytes reclaimed" 48392 "Player removeUninstantiatedSubclassesSilently" 48393 48394 | candidatesForRemoval oldFree | 48395 48396 oldFree := self environment garbageCollect. 48397 candidatesForRemoval := 48398 self subclasses select: [:c | 48399 (c instanceCount = 0) and: [c subclasses size = 0]]. 48400 candidatesForRemoval do: [:c | c removeFromSystem]. 48401 ^ self environment garbageCollect - oldFree! ! 48402 48403!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'al 11/28/2005 11:52'! 48404subclasses 48405 ^ Array new! ! 48406 48407!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'al 11/28/2005 11:52'! 48408subclassesDo: aBlock 48409 "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." 48410 ^self subclasses do: aBlock! ! 48411 48412 48413!ClassDescription methodsFor: 'accessing comment' stamp: 'PeterHugossonMiller 9/3/2009 00:54'! 48414classCommentBlank 48415 48416 | existingComment stream | 48417 existingComment := self theNonMetaClass organization classComment. 48418 existingComment isEmpty 48419 ifFalse: [^existingComment]. 48420 48421 stream := (String new: 100) writeStream. 48422 stream 48423 nextPutAll: 'A'; 48424 nextPutAll: (self name first isVowel ifTrue: ['n '] ifFalse: [' ']); 48425 nextPutAll: self name; 48426 nextPutAll: ' is xxxxxxxxx.'; 48427 cr; cr; 48428 nextPutAll: 'Instance Variables'. 48429 48430 self instVarNames asSortedCollection do: [:each | 48431 stream 48432 cr; tab; nextPutAll: each; 48433 nextPut: $:; 48434 tab; tab; 48435 nextPutAll: '<Object>']. 48436 48437 stream cr. 48438 self instVarNames asSortedCollection do: [:each | 48439 stream 48440 cr; nextPutAll: each; 48441 cr; tab; nextPutAll: '- xxxxx'; cr]. 48442 48443 ^stream contents! ! 48444 48445!ClassDescription methodsFor: 'accessing comment'! 48446comment 48447 "Answer the receiver's comment. (If missing, supply a template) " 48448 | aString | 48449 aString := self instanceSide organization classComment. 48450 aString isEmpty ifFalse: [^ aString]. 48451 ^self classCommentBlank! ! 48452 48453!ClassDescription methodsFor: 'accessing comment'! 48454comment: aStringOrText 48455 "Set the receiver's comment to be the argument, aStringOrText." 48456 48457 self instanceSide classComment: aStringOrText.! ! 48458 48459!ClassDescription methodsFor: 'accessing comment'! 48460comment: aStringOrText stamp: aStamp 48461 "Set the receiver's comment to be the argument, aStringOrText." 48462 48463 self instanceSide classComment: aStringOrText stamp: aStamp.! ! 48464 48465!ClassDescription methodsFor: 'accessing comment'! 48466hasComment 48467 "return whether this class truly has a comment other than the default" 48468 | org | 48469 org := self instanceSide organization. 48470 ^org classComment isEmptyOrNil not! ! 48471 48472 48473!ClassDescription methodsFor: 'accessing method dictionary'! 48474addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor 48475 | priorMethodOrNil oldProtocol newProtocol | 48476 priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil]. 48477 self addSelectorSilently: selector withMethod: compiledMethod. 48478 oldProtocol := self organization categoryOfElement: selector. 48479 SystemChangeNotifier uniqueInstance 48480 doSilently: [self organization classify: selector under: category]. 48481 newProtocol := self organization categoryOfElement: selector. 48482 priorMethodOrNil isNil 48483 ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: self requestor: requestor] 48484 ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self oldProtocol: oldProtocol newProtocol: newProtocol requestor: requestor].! ! 48485 48486!ClassDescription methodsFor: 'accessing method dictionary'! 48487addSelectorSilently: selector withMethod: compiledMethod 48488 super addSelectorSilently: selector withMethod: compiledMethod. 48489 self instanceSide noteAddedSelector: selector meta: self isMeta.! ! 48490 48491!ClassDescription methodsFor: 'accessing method dictionary'! 48492addSelector: selector withMethod: compiledMethod notifying: requestor 48493 | priorMethodOrNil | 48494 priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil]. 48495 self addSelectorSilently: selector withMethod: compiledMethod. 48496 priorMethodOrNil isNil 48497 ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inClass: self requestor: requestor] 48498 ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! ! 48499 48500!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sw 1/5/2001 06:53'! 48501allMethodCategoriesIntegratedThrough: mostGenericClass 48502 "Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass" 48503 48504 | aColl | 48505 aColl := OrderedCollection new. 48506 self withAllSuperclasses do: 48507 [:aClass | 48508 (aClass includesBehavior: mostGenericClass) 48509 ifTrue: [aColl addAll: aClass organization categories]]. 48510 aColl remove: 'no messages' asSymbol ifAbsent: []. 48511 48512 ^ (aColl asSet asSortedCollection: [:a :b | a asLowercase < b asLowercase]) asArray 48513 48514"ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"! ! 48515 48516!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'nice 3/22/2008 01:21'! 48517allMethodsInCategory: aName 48518 "Answer a list of all the methods of the receiver and all its 48519 superclasses that are in the category named aName" 48520 48521 | aColl | 48522 aColl := OrderedCollection new. 48523 self withAllSuperclasses 48524 do: [:aClass | aColl 48525 addAll: (aName = ClassOrganizer allCategory 48526 ifTrue: [aClass organization allMethodSelectors] 48527 ifFalse: [aClass organization listAtCategoryNamed: aName])]. 48528 ^ aColl asSet asSortedArray 48529 48530 "TileMorph allMethodsInCategory: #initialization"! ! 48531 48532!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:17'! 48533induceMDFault 48534 "Stache a copy of the methodDict in the organization slot (hack!!), 48535 and set the methodDict to nil. This will induce an MD fault on any message send. 48536 See: ClassDescription>>recoverFromMDFault 48537 and ImageSegment>>discoverActiveClasses." 48538 48539 organization := Array with: methodDict with: organization. 48540 methodDict := nil. 48541 self flushCache! ! 48542 48543!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'nice 3/22/2008 01:21'! 48544methodsInCategory: aName 48545 "Answer a list of the methods of the receiver that are in category named aName" 48546 48547 | aColl | 48548 aColl := Set withAll: (aName = ClassOrganizer allCategory 48549 ifTrue: [self organization allMethodSelectors] 48550 ifFalse: [self organization listAtCategoryNamed: aName]). 48551 ^ aColl asSortedArray 48552 48553 "TileMorph methodsInCategory: #initialization"! ! 48554 48555!ClassDescription methodsFor: 'accessing method dictionary'! 48556noteAddedSelector: aSelector meta: isMeta 48557 "A hook allowing some classes to react to adding of certain selectors"! ! 48558 48559!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'di 3/7/2001 17:05'! 48560recoverFromMDFault 48561 "This method handles methodDict faults to support, eg, discoverActiveClasses (qv)." 48562 (organization isMemberOf: Array) ifFalse: [^ self error: 'oops']. 48563 methodDict := organization first. 48564 organization := organization second. 48565! ! 48566 48567!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sd 3/28/2003 15:32'! 48568recoverFromMDFaultWithTrace 48569 "This method handles emthodDict faults to support, eg, discoverActiveClasses (qv)." 48570 self recoverFromMDFault. 48571 self environment at: #MDFaultDict ifPresent: 48572 [:faultDict | faultDict at: self name put: 48573 (String streamContents: 48574 [:strm | (thisContext stackOfSize: 20) do: [:item | strm print: item; cr]])] 48575 48576"Execute the following statement to induce MD fault tracing. This means that, not only will all active classes be recorded but, after a test run, MDFaultDict will contain, for every class used, a stack trace showing how it came to be used. This statement should be executed just prior to any such text, in order to clear the traces. 48577 48578 Smalltalk at: #MDFaultDict put: Dictionary new. 48579 48580"! ! 48581 48582!ClassDescription methodsFor: 'accessing method dictionary'! 48583removeCategory: aString 48584 "Remove each of the messages categorized under aString in the method 48585 dictionary of the receiver. Then remove the category aString." 48586 | categoryName | 48587 categoryName := aString asSymbol. 48588 (self organization listAtCategoryNamed: categoryName) do: 48589 [:sel | self removeSelector: sel]. 48590 self organization removeCategory: categoryName! ! 48591 48592!ClassDescription methodsFor: 'accessing method dictionary'! 48593removeSelector: selector 48594 "Remove the message whose selector is given from the method 48595 dictionary of the receiver, if it is there. Answer nil otherwise." 48596 48597 | priorMethod priorProtocol | 48598 priorMethod := self compiledMethodAt: selector ifAbsent: [^ nil]. 48599 priorProtocol := self whichCategoryIncludesSelector: selector. 48600 super removeSelector: selector. 48601 SystemChangeNotifier uniqueInstance 48602 doSilently: [self updateOrganizationSelector: selector oldCategory: priorProtocol newCategory: nil]. 48603 SystemChangeNotifier uniqueInstance 48604 methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! ! 48605 48606 48607!ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'NS 4/12/2004 15:03'! 48608classSide 48609 ^self theMetaClass! ! 48610 48611!ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'NS 4/12/2004 15:04'! 48612instanceSide 48613 ^ self theNonMetaClass! ! 48614 48615!ClassDescription methodsFor: 'accessing parallel hierarchy'! 48616isClassSide 48617 ^self == self classSide! ! 48618 48619!ClassDescription methodsFor: 'accessing parallel hierarchy'! 48620isInstanceSide 48621 ^self isClassSide not! ! 48622 48623!ClassDescription methodsFor: 'accessing parallel hierarchy'! 48624isMeta 48625 ^self isClassSide! ! 48626 48627!ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'sd 6/27/2003 22:50'! 48628theMetaClass 48629 "Sent to a class or metaclass, always return the metaclass" 48630 48631 ^self class! ! 48632 48633!ClassDescription methodsFor: 'accessing parallel hierarchy'! 48634theNonMetaClass 48635 "Sent to a class or metaclass, always return the class" 48636 48637 ^self! ! 48638 48639 48640!ClassDescription methodsFor: 'compiling'! 48641acceptsLoggingOfCompilation 48642 "Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set. The metaclass follows the rule of the class itself. 6/18/96 sw" 48643 "weird name is so that it will come lexically before #compile, so that a clean build can make it through. 7/7/96 sw" 48644 48645 ^ true! ! 48646 48647!ClassDescription methodsFor: 'compiling'! 48648compile: code classified: heading 48649 "Compile the argument, code, as source code in the context of the 48650 receiver and install the result in the receiver's method dictionary under 48651 the classification indicated by the second argument, heading. nil is to be 48652 notified if an error occurs. The argument code is either a string or an 48653 object that converts to a string or a PositionableStream on an object that 48654 converts to a string." 48655 48656 ^self 48657 compile: code 48658 classified: heading 48659 notifying: nil! ! 48660 48661!ClassDescription methodsFor: 'compiling'! 48662compile: text classified: category notifying: requestor 48663 | stamp | 48664 stamp := self acceptsLoggingOfCompilation ifTrue: [Utilities changeStamp] ifFalse: [nil]. 48665 ^ self compile: text classified: category 48666 withStamp: stamp notifying: requestor! ! 48667 48668!ClassDescription methodsFor: 'compiling'! 48669compile: text classified: category withStamp: changeStamp notifying: requestor 48670 ^ self compile: text classified: category withStamp: changeStamp notifying: requestor logSource: self acceptsLoggingOfCompilation! ! 48671 48672!ClassDescription methodsFor: 'compiling'! 48673compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource 48674 | methodAndNode | 48675 methodAndNode := self compile: text asString classified: category notifying: requestor 48676 trailer: self defaultMethodTrailer ifFail: [^nil]. 48677 logSource ifTrue: [ 48678 self logMethodSource: text forMethodWithNode: methodAndNode 48679 inCategory: category withStamp: changeStamp notifying: requestor. 48680 ]. 48681 self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode 48682 method inProtocol: category notifying: requestor. 48683 self instanceSide noteCompilationOf: methodAndNode selector meta: self isClassSide. 48684 ^ methodAndNode selector! ! 48685 48686!ClassDescription methodsFor: 'compiling'! 48687compile: code notifying: requestor 48688 "Refer to the comment in Behavior|compile:notifying:." 48689 48690 ^self compile: code 48691 classified: ClassOrganizer default 48692 notifying: requestor! ! 48693 48694!ClassDescription methodsFor: 'compiling'! 48695compileSilently: code classified: category 48696 "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." 48697 48698 ^ self compileSilently: code classified: category notifying: nil.! ! 48699 48700!ClassDescription methodsFor: 'compiling'! 48701compileSilently: code classified: category notifying: requestor 48702 "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." 48703 48704 ^ SystemChangeNotifier uniqueInstance 48705 doSilently: [self compile: code classified: category withStamp: nil notifying: requestor logSource: false].! ! 48706 48707!ClassDescription methodsFor: 'compiling'! 48708doneCompiling 48709 "A ClassBuilder has finished the compilation of the receiver. 48710 This message is a notification for a class that needs to do some 48711 cleanup / reinitialization after it has been recompiled."! ! 48712 48713!ClassDescription methodsFor: 'compiling' stamp: 'eem 5/13/2008 09:48'! 48714instVarNamesAndOffsetsDo: aBinaryBlock 48715 "This is part of the interface between the compiler and a class's instance or field names. 48716 The class should enumerate aBinaryBlock with the instance variable name strings and 48717 their integer offsets. The order is important. Names evaluated later will override the 48718 same names occurring earlier." 48719 48720 | superInstSize | 48721 (superInstSize := superclass notNil ifTrue: [superclass instSize] ifFalse: [0]) > 0 ifTrue: 48722 [superclass instVarNamesAndOffsetsDo: aBinaryBlock]. 48723 1 to: self instSize - superInstSize do: 48724 [:i| aBinaryBlock value: (instanceVariables at: i) value: i + superInstSize]! ! 48725 48726!ClassDescription methodsFor: 'compiling' stamp: 'al 11/28/2005 11:51'! 48727moveInstVarNamed: instVarName to: anotherClass after: prevInstVarName 48728 "Move the given instance variable to another class." 48729 self == anotherClass ifFalse:[ 48730 self notify:'Warning:' asText allBold,' moving ', instVarName printString,' from ', self name,' to ', anotherClass name,' will not be recorded in the change set correctly. 48731Proceed to do it anyways.']. 48732 ^(ClassBuilder new) 48733 moveInstVarNamed: instVarName 48734 from: self 48735 to: anotherClass 48736 after: prevInstVarName! ! 48737 48738!ClassDescription methodsFor: 'compiling'! 48739noteCompilationOf: aSelector meta: isMeta 48740 "A hook allowing some classes to react to recompilation of certain selectors"! ! 48741 48742!ClassDescription methodsFor: 'compiling'! 48743reformatAll 48744 "Reformat all methods in this class. 48745 Leaves old code accessible to version browsing" 48746 self selectorsDo: [:sel | self reformatMethodAt: sel]! ! 48747 48748!ClassDescription methodsFor: 'compiling' stamp: 'alain.plantec 5/18/2009 15:46'! 48749reformatMethodAt: selector 48750 | newCodeString method | 48751 newCodeString := self prettyPrinterClass 48752 format: (self sourceCodeAt: selector) 48753 in: self 48754 notifying: nil. 48755 method := self compiledMethodAt: selector. 48756 method 48757 putSource: newCodeString 48758 fromParseNode: nil 48759 class: self 48760 category: (self organization categoryOfElement: selector) 48761 inFile: 2 48762 priorMethod: method 48763! ! 48764 48765!ClassDescription methodsFor: 'compiling'! 48766wantsChangeSetLogging 48767 "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism. 7/12/96 sw" 48768 48769 ^ true! ! 48770 48771!ClassDescription methodsFor: 'compiling'! 48772wantsRecompilationProgressReported 48773 "Answer whether the receiver would like progress of its recompilation reported interactively to the user." 48774 48775 ^ true! ! 48776 48777 48778!ClassDescription methodsFor: 'copying'! 48779copy: sel from: class 48780 "Install the method associated with the first argument, sel, a message 48781 selector, found in the method dictionary of the second argument, class, 48782 as one of the receiver's methods. Classify the message under -As yet not 48783 classified-." 48784 48785 self copy: sel 48786 from: class 48787 classified: nil! ! 48788 48789!ClassDescription methodsFor: 'copying'! 48790copy: sel from: class classified: cat 48791 "Install the method associated with the first arugment, sel, a message 48792 selector, found in the method dictionary of the second argument, class, 48793 as one of the receiver's methods. Classify the message under the third 48794 argument, cat." 48795 48796 | code category | 48797 "Useful when modifying an existing class" 48798 code := class sourceMethodAt: sel. 48799 code == nil 48800 ifFalse: 48801 [cat == nil 48802 ifTrue: [category := class organization categoryOfElement: sel] 48803 ifFalse: [category := cat]. 48804 (self methodDict includesKey: sel) 48805 ifTrue: [code asString = (self sourceMethodAt: sel) asString 48806 ifFalse: [self error: self name 48807 , ' ' 48808 , sel 48809 , ' will be redefined if you proceed.']]. 48810 self compile: code classified: category]! ! 48811 48812!ClassDescription methodsFor: 'copying'! 48813copyAll: selArray from: class 48814 "Install all the methods found in the method dictionary of the second 48815 argument, class, as the receiver's methods. Classify the messages under 48816 -As yet not classified-." 48817 48818 self copyAll: selArray 48819 from: class 48820 classified: nil! ! 48821 48822!ClassDescription methodsFor: 'copying'! 48823copyAll: selArray from: class classified: cat 48824 "Install all the methods found in the method dictionary of the second 48825 argument, class, as the receiver's methods. Classify the messages under 48826 the third argument, cat." 48827 48828 selArray do: 48829 [:s | self copy: s 48830 from: class 48831 classified: cat]! ! 48832 48833!ClassDescription methodsFor: 'copying'! 48834copyAllCategoriesFrom: aClass 48835 "Specify that the categories of messages for the receiver include all of 48836 those found in the class, aClass. Install each of the messages found in 48837 these categories into the method dictionary of the receiver, classified 48838 under the appropriate categories." 48839 48840 aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! ! 48841 48842!ClassDescription methodsFor: 'copying'! 48843copyCategory: cat from: class 48844 "Specify that one of the categories of messages for the receiver is cat, as 48845 found in the class, class. Copy each message found in this category." 48846 48847 self copyCategory: cat 48848 from: class 48849 classified: cat! ! 48850 48851!ClassDescription methodsFor: 'copying'! 48852copyCategory: cat from: aClass classified: newCat 48853 "Specify that one of the categories of messages for the receiver is the 48854 third argument, newCat. Copy each message found in the category cat in 48855 class aClass into this new category." 48856 48857 self copyAll: (aClass organization listAtCategoryNamed: cat) 48858 from: aClass 48859 classified: newCat! ! 48860 48861!ClassDescription methodsFor: 'copying'! 48862copyMethodDictionaryFrom: donorClass 48863 "Copy the method dictionary of the donor class over to the receiver" 48864 48865 self methodDict: donorClass copyOfMethodDictionary. 48866 self organization: donorClass organization deepCopy.! ! 48867 48868 48869!ClassDescription methodsFor: 'deprecated' stamp: 'sd 4/26/2008 11:54'! 48870commentFollows 48871 "Answer a ClassCommentReader who will scan in the comment." 48872 self deprecated: 'user classCommentReader instead'. 48873 48874 ^ ClassCommentReader new setClass: self category: #Comment 48875 48876! ! 48877 48878 48879!ClassDescription methodsFor: 'fileIn/Out'! 48880classComment: aString stamp: aStamp 48881 "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." 48882 48883 | ptr header file oldCommentRemoteStr oldComment oldStamp | 48884 oldComment := self organization classComment. 48885 oldStamp := self organization commentStamp. 48886 (aString isKindOf: RemoteString) ifTrue: 48887 [SystemChangeNotifier uniqueInstance class: self oldComment: oldComment newComment: aString string oldStamp: oldStamp newStamp: aStamp. 48888 ^ self organization classComment: aString stamp: aStamp]. 48889 48890 oldCommentRemoteStr := self organization commentRemoteStr. 48891 (aString size = 0) & (oldCommentRemoteStr isNil) ifTrue: [^ self organization classComment: nil]. 48892 "never had a class comment, no need to write empty string out" 48893 48894 ptr := oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. 48895 SourceFiles ifNotNil: [(file := SourceFiles at: 2) ifNotNil: 48896 [file setToEnd; cr; nextPut: $!!. "directly" 48897 "Should be saying (file command: 'H3') for HTML, but ignoring it here" 48898 header := String streamContents: [:strm | strm nextPutAll: self name; 48899 nextPutAll: ' commentStamp: '. 48900 aStamp storeOn: strm. 48901 strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. 48902 file nextChunkPut: header]]. 48903 self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. 48904 SystemChangeNotifier uniqueInstance class: self oldComment: oldComment newComment: aString oldStamp: oldStamp newStamp: aStamp! ! 48905 48906!ClassDescription methodsFor: 'fileIn/Out' stamp: 'PeterHugossonMiller 9/3/2009 00:55'! 48907definition 48908 "Answer a String that defines the receiver." 48909 48910 | aStream | 48911 aStream := (String new: 300) writeStream. 48912 superclass == nil 48913 ifTrue: [aStream nextPutAll: 'ProtoObject'] 48914 ifFalse: [aStream nextPutAll: superclass name]. 48915 aStream nextPutAll: self kindOfSubclass; 48916 store: self name. 48917 (self hasTraitComposition and: [self traitComposition notEmpty]) ifTrue: [ 48918 aStream cr; tab; nextPutAll: 'uses: '; 48919 nextPutAll: self traitCompositionString]. 48920 aStream cr; tab; nextPutAll: 'instanceVariableNames: '; 48921 store: self instanceVariablesString. 48922 aStream cr; tab; nextPutAll: 'classVariableNames: '; 48923 store: self classVariablesString. 48924 aStream cr; tab; nextPutAll: 'poolDictionaries: '; 48925 store: self sharedPoolsString. 48926 aStream cr; tab; nextPutAll: 'category: '; 48927 store: (SystemOrganization categoryOfElement: self name) asString. 48928 48929 superclass ifNil: [ 48930 aStream nextPutAll: '.'; cr. 48931 aStream nextPutAll: self name. 48932 aStream space; nextPutAll: 'superclass: nil'. ]. 48933 48934 ^ aStream contents! ! 48935 48936!ClassDescription methodsFor: 'fileIn/Out'! 48937fileOutCategory: aSymbol on: aFileStream moveSource: moveSource toFile: fileIndex 48938 "File a description of the receiver's category, aString, onto aFileStream. If 48939 moveSource, is true, then set the method source pointer to the new file position. 48940 Note when this method is called with moveSource=true, it is condensing the 48941 .sources file, and should only write one preamble per method category." 48942 48943 | selectors | 48944 aFileStream cr. 48945 selectors := (aSymbol asString = ClassOrganizer allCategory) 48946 ifTrue: [ self organization allMethodSelectors ] 48947 ifFalse: [ self organization listAtCategoryNamed: aSymbol ]. 48948 48949 "Overridden to preserve author stamps in sources file regardless" 48950 selectors do: [:sel | 48951 self printMethodChunk: sel 48952 withPreamble: true 48953 on: aFileStream 48954 moveSource: moveSource 48955 toFile: fileIndex]. 48956 ^ self! ! 48957 48958!ClassDescription methodsFor: 'fileIn/Out' stamp: 'bf 12/17/2005 00:04'! 48959fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex 48960 "File a description of the messages of this class that have been 48961 changed (i.e., are entered into the argument, aSet) onto aFileStream. If 48962 moveSource, is true, then set the method source pointer to the new file position. 48963 Note when this method is called with moveSource=true, it is condensing the 48964 .changes file, and should only write a preamble for every method." 48965 | org sels | 48966 (org := self organization) categories do: 48967 [:cat | 48968 sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. 48969 ((cat beginsWith: '*') and: [cat endsWith: '-override']) 48970 ifTrue: [ 48971 sels do: 48972 [:sel | self printMethodChunkHistorically: sel on: aFileStream 48973 moveSource: moveSource toFile: fileIndex]] 48974 ifFalse: [ 48975 sels do: 48976 [:sel | self printMethodChunk: sel withPreamble: true on: aFileStream 48977 moveSource: moveSource toFile: fileIndex]]]! ! 48978 48979!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sumim 9/2/2003 14:36'! 48980fileOutChangedMessagesHistorically: aSet on: aFileStream moveSource: moveSource toFile: fileIndex 48981 "File all historical description of the messages of this class that have been 48982 changed (i.e., are entered into the argument, aSet) onto aFileStream. If 48983 moveSource, is true, then set the method source pointer to the new file position. 48984 Note when this method is called with moveSource=true, it is condensing the 48985 .changes file, and should only write a preamble for every method." 48986 | org sels | 48987 (org := self organization) categories do: 48988 [:cat | 48989 sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. 48990 sels do: 48991 [:sel | self printMethodChunkHistorically: sel on: aFileStream 48992 moveSource: moveSource toFile: fileIndex]]! ! 48993 48994!ClassDescription methodsFor: 'fileIn/Out'! 48995moveChangesTo: newFile 48996 "Used in the process of condensing changes, this message requests that 48997 the source code of all methods of the receiver that have been changed 48998 should be moved to newFile." 48999 49000 | changes | 49001 changes := self methodDict keys select: [:sel | 49002 (self compiledMethodAt: sel) fileIndex > 1 ]. 49003 self 49004 fileOutChangedMessages: changes 49005 on: newFile 49006 moveSource: true 49007 toFile: 2! ! 49008 49009!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sumim 9/2/2003 14:37'! 49010moveChangesWithVersionsTo: newFile 49011 "Used in the process of condensing changes, this message requests that 49012 the source code of all methods of the receiver that have been changed 49013 should be moved to newFile." 49014 49015 | changes | 49016 changes := self methodDict keys select: [:sel | (self methodDict at: sel) fileIndex > 1]. 49017 self fileOutChangedMessagesHistorically: changes 49018 on: newFile 49019 moveSource: true 49020 toFile: 2! ! 49021 49022!ClassDescription methodsFor: 'fileIn/Out' stamp: 'md 2/20/2006 15:13'! 49023printMethodChunkHistorically: selector on: outStream moveSource: moveSource toFile: fileIndex 49024 "Copy all source codes historically for the method associated with selector onto the 49025 fileStream. If moveSource true, then also set the source code pointer of the method." 49026 49027 | preamble method newPos sourceFile endPos category changeList prior | 49028 category := self organization categoryOfElement: selector. 49029 preamble := self name , ' methodsFor: ', category asString printString. 49030 method := self methodDict at: selector. 49031 ((method fileIndex = 0 49032 or: [(SourceFiles at: method fileIndex) == nil]) 49033 or: [method filePosition = 0]) 49034 ifTrue: [ 49035 outStream cr; nextPut: $!!; nextChunkPut: preamble; cr. 49036 outStream nextChunkPut: method decompileString. 49037 outStream nextChunkPut: ' '; cr] 49038 ifFalse: [ 49039 changeList := ChangeSet 49040 scanVersionsOf: method 49041 class: self 49042 meta: self isMeta 49043 category: category 49044 selector: selector. 49045 newPos := nil. 49046 sourceFile := SourceFiles at: method fileIndex. 49047 changeList reverseDo: [ :chgRec | 49048 chgRec fileIndex = fileIndex ifTrue: [ 49049 outStream copyPreamble: preamble from: sourceFile at: chgRec position. 49050 (prior := chgRec prior) ifNotNil: [ 49051 outStream position: outStream position - 2. 49052 outStream nextPutAll: ' prior: ', ( 49053 prior first = method fileIndex ifFalse: [prior third] ifTrue: [ 49054 SourceFiles 49055 sourcePointerFromFileIndex: method fileIndex 49056 andPosition: newPos]) printString. 49057 outStream nextPut: $!!; cr]. 49058 "Copy the method chunk" 49059 newPos := outStream position. 49060 outStream copyMethodChunkFrom: sourceFile at: chgRec position. 49061 sourceFile skipSeparators. "The following chunk may have ]style[" 49062 sourceFile peek == $] ifTrue: [ 49063 outStream cr; copyMethodChunkFrom: sourceFile]. 49064 outStream nextChunkPut: ' '; cr]]. 49065 moveSource ifTrue: [ 49066 endPos := outStream position. 49067 method checkOKToAdd: endPos - newPos at: newPos. 49068 method setSourcePosition: newPos inFile: fileIndex]]. 49069 ^ outStream! ! 49070 49071 49072!ClassDescription methodsFor: 'filein/out'! 49073classComment: aString 49074 "Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing. Empty string gets stored only if had a non-empty one before." 49075 ^ self classComment: aString stamp: '<historical>'! ! 49076 49077!ClassDescription methodsFor: 'filein/out'! 49078commentStamp: changeStamp 49079 self organization commentStamp: changeStamp. 49080 ^ self commentStamp: changeStamp prior: 0! ! 49081 49082!ClassDescription methodsFor: 'filein/out'! 49083commentStamp: changeStamp prior: indexAndOffset 49084 "Prior source link ignored when filing in." 49085 49086 ^ ClassCommentReader new setClass: self 49087 category: #Comment 49088 changeStamp: changeStamp! ! 49089 49090!ClassDescription methodsFor: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 00:55'! 49091fileOutCategory: catName 49092 49093 | internalStream | 49094 internalStream := (String new: 1000) writeStream. 49095 internalStream header; timeStamp. 49096 self fileOutCategory: catName on: internalStream moveSource: false toFile: 0. 49097 internalStream trailer. 49098 49099 ^ FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , catName) isSt: true.! ! 49100 49101!ClassDescription methodsFor: 'filein/out'! 49102fileOutChangedMessages: aSet on: aFileStream 49103 "File a description of the messages of the receiver that have been 49104 changed (i.e., are entered into the argument, aSet) onto aFileStream." 49105 49106 self fileOutChangedMessages: aSet 49107 on: aFileStream 49108 moveSource: false 49109 toFile: 0! ! 49110 49111!ClassDescription methodsFor: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 00:55'! 49112fileOutMethod: selector 49113 "Write source code of a single method on a file. Make up a name for the file." 49114 49115 | internalStream | 49116 (selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.']. 49117 (self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found']. 49118 internalStream := (String new: 1000) writeStream. 49119 internalStream header; timeStamp. 49120 self printMethodChunk: selector withPreamble: true 49121 on: internalStream moveSource: false toFile: 0. 49122 49123 FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true.! ! 49124 49125!ClassDescription methodsFor: 'filein/out'! 49126fileOutOn: aFileStream 49127 "File a description of the receiver on aFileStream." 49128 49129 self fileOutOn: aFileStream 49130 moveSource: false 49131 toFile: 0! ! 49132 49133!ClassDescription methodsFor: 'filein/out'! 49134fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex 49135 "File a description of the receiver on aFileStream. If the boolean 49136 argument, moveSource, is true, then set the trailing bytes to the position 49137 of aFileStream and to fileIndex in order to indicate where to find the 49138 source code." 49139 49140 aFileStream nextChunkPut: self definition. 49141 49142 self organization 49143 putCommentOnFile: aFileStream 49144 numbered: fileIndex 49145 moveSource: moveSource 49146 forClass: self. 49147 self organization categories do: 49148 [:heading | 49149 self fileOutCategory: heading 49150 on: aFileStream 49151 moveSource: moveSource 49152 toFile: fileIndex]! ! 49153 49154!ClassDescription methodsFor: 'filein/out'! 49155fileOutOrganizationOn: aFileStream 49156 "File a description of the receiver's organization on aFileStream." 49157 49158 aFileStream cr; nextPut: $!!. 49159 aFileStream nextChunkPut: self name, ' reorganize'; cr. 49160 aFileStream nextChunkPut: self organization printString; cr! ! 49161 49162!ClassDescription methodsFor: 'filein/out'! 49163localMethods 49164 "returns the methods of classes including the ones of the traits that the class uses" 49165 49166 ^ self methods select: [:each | self includesLocalSelector: each selector].! ! 49167 49168!ClassDescription methodsFor: 'filein/out'! 49169methods 49170 "returns the methods of classes including the ones of the traits that the class uses" 49171 49172 ^ self methodDict values ! ! 49173 49174!ClassDescription methodsFor: 'filein/out'! 49175methodsFor: categoryName 49176 "Answer a ClassCategoryReader for compiling the messages in the category, categoryName, of the receiver." 49177 49178 ^ ClassCategoryReader new setClass: self category: categoryName asSymbol 49179 49180 "(False methodsFor: 'logical operations') inspect"! ! 49181 49182!ClassDescription methodsFor: 'filein/out'! 49183methodsFor: aString priorSource: sourcePosition inFile: fileIndex 49184 "Prior source pointer ignored when filing in." 49185 ^ self methodsFor: aString! ! 49186 49187!ClassDescription methodsFor: 'filein/out'! 49188methodsFor: categoryName stamp: changeStamp 49189 ^ self methodsFor: categoryName stamp: (Utilities fixStamp: changeStamp) prior: 0! ! 49190 49191!ClassDescription methodsFor: 'filein/out'! 49192methodsFor: categoryName stamp: changeStamp prior: indexAndOffset 49193 "Prior source link ignored when filing in." 49194 ^ ClassCategoryReader new setClass: self 49195 category: categoryName asSymbol 49196 changeStamp: changeStamp 49197 49198"Most importantly, return the new ClassCategoryReader, so a fileIn will let it seize control. So method will be placed in the proper category. See the transfer of control where ReadWriteStream fileIn calls scanFrom:"! ! 49199 49200!ClassDescription methodsFor: 'filein/out'! 49201printCategoryChunk: categoryName on: aFileStream 49202 ^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream! ! 49203 49204!ClassDescription methodsFor: 'filein/out'! 49205printCategoryChunk: category on: aFileStream priorMethod: priorMethod 49206 ^ self printCategoryChunk: category on: aFileStream 49207 withStamp: Utilities changeStamp priorMethod: priorMethod! ! 49208 49209!ClassDescription methodsFor: 'filein/out'! 49210printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod 49211 "Print a method category preamble. This must have a category name. 49212 It may have an author/date stamp, and it may have a prior source link. 49213 If it has a prior source link, it MUST have a stamp, even if it is empty." 49214 49215"The current design is that changeStamps and prior source links are preserved in the changes file. All fileOuts include changeStamps. Condensing sources, however, eliminates all stamps (and links, natch)." 49216 49217 aFileStream cr; nextPut: $!!. 49218 aFileStream nextChunkPut: (String streamContents: 49219 [:strm | 49220 strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString. 49221 (changeStamp ~~ nil and: 49222 [changeStamp size > 0 or: [priorMethod ~~ nil]]) ifTrue: 49223 [strm nextPutAll: ' stamp: '; print: changeStamp]. 49224 priorMethod ~~ nil ifTrue: 49225 [strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]]). 49226 ! ! 49227 49228!ClassDescription methodsFor: 'filein/out'! 49229printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream 49230 ^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp 49231 priorMethod: nil! ! 49232 49233!ClassDescription methodsFor: 'filein/out'! 49234printMethodChunk: selector withPreamble: doPreamble on: outStream 49235 moveSource: moveSource toFile: fileIndex 49236 "Copy the source code for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." 49237 | preamble method oldPos newPos sourceFile endPos | 49238 doPreamble 49239 ifTrue: [preamble := self name , ' methodsFor: ' , 49240 (self organization categoryOfElement: selector) asString printString] 49241 ifFalse: [preamble := '']. 49242 method := self methodDict at: selector ifAbsent: 49243 [outStream nextPutAll: selector; cr. 49244 outStream tab; nextPutAll: '** ERROR!! THIS SCRIPT IS MISSING ** ' translated; cr; cr. 49245 outStream nextPutAll: ' '. 49246 ^ outStream]. 49247 49248 ((method fileIndex = 0 49249 or: [(SourceFiles at: method fileIndex) == nil]) 49250 or: [(oldPos := method filePosition) = 0]) 49251 ifTrue: 49252 ["The source code is not accessible. We must decompile..." 49253 preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr]. 49254 outStream nextChunkPut: method decompileString] 49255 ifFalse: 49256 [sourceFile := SourceFiles at: method fileIndex. 49257 preamble size > 0 49258 ifTrue: "Copy the preamble" 49259 [outStream copyPreamble: preamble from: sourceFile at: oldPos] 49260 ifFalse: 49261 [sourceFile position: oldPos]. 49262 "Copy the method chunk" 49263 newPos := outStream position. 49264 outStream copyMethodChunkFrom: sourceFile. 49265 sourceFile skipSeparators. "The following chunk may have ]style[" 49266 sourceFile peek == $] ifTrue: [ 49267 outStream cr; copyMethodChunkFrom: sourceFile]. 49268 moveSource ifTrue: "Set the new method source pointer" 49269 [endPos := outStream position. 49270 method checkOKToAdd: endPos - newPos at: newPos. 49271 method setSourcePosition: newPos inFile: fileIndex]]. 49272 preamble size > 0 ifTrue: [outStream nextChunkPut: ' ']. 49273 ^ outStream cr! ! 49274 49275!ClassDescription methodsFor: 'filein/out'! 49276putClassCommentToCondensedChangesFile: aFileStream 49277 "Called when condensing changes. If the receiver has a class comment, and if that class comment does not reside in the .sources file, then write it to the given filestream, with the resulting RemoteString being reachable from the source file #2. Note that any existing backpointer into the .sources file is lost by this process -- a situation that maybe should be fixed someday." 49278 49279 | header aStamp aCommentRemoteStr | 49280 self isMeta ifTrue: [^ self]. "bulletproofing only" 49281 ((aCommentRemoteStr := self organization commentRemoteStr) isNil or: 49282 [aCommentRemoteStr sourceFileNumber == 1]) ifTrue: [^ self]. 49283 49284 aFileStream cr; nextPut: $!!. 49285 header := String streamContents: [:strm | strm nextPutAll: self name; 49286 nextPutAll: ' commentStamp: '. 49287 (aStamp := self organization commentStamp ifNil: ['<historical>']) storeOn: strm. 49288 strm nextPutAll: ' prior: 0']. 49289 aFileStream nextChunkPut: header. 49290 aFileStream cr. 49291 self organization classComment: (RemoteString newString: self organization classComment onFileNumber: 2 toFile: aFileStream) stamp: aStamp! ! 49292 49293 49294!ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 10:59'! 49295forgetDoIts 49296 "get rid of old DoIt methods and bogus entries in the ClassOrganizer." 49297 SystemChangeNotifier uniqueInstance doSilently: [ 49298 self organization 49299 removeElement: #DoIt; 49300 removeElement: #DoItIn:. 49301 ]. 49302 super forgetDoIts.! ! 49303 49304!ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 11:00'! 49305obsolete 49306 "Make the receiver obsolete." 49307 superclass removeSubclass: self. 49308 self organization: nil. 49309 super obsolete.! ! 49310 49311!ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 11:26'! 49312superclass: aClass methodDictionary: mDict format: fmt 49313 "Basic initialization of the receiver" 49314 super superclass: aClass methodDictionary: mDict format: fmt. 49315 instanceVariables := nil. 49316 self organization: nil.! ! 49317 49318!ClassDescription methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 23:25'! 49319updateInstances: oldInstances from: oldClass isMeta: isMeta 49320 "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary. Return the array of old instances (none of which should be pointed to legally by anyone but the array)." 49321 "If there are any contexts having an old instance as receiver it might crash the system because the layout has changed, and the method only knows about the old layout." 49322 | map variable instSize newInstances | 49323 49324 oldInstances isEmpty ifTrue:[^#()]. "no instances to convert" 49325 isMeta ifTrue: [ 49326 oldInstances size = 1 ifFalse:[^self error:'Metaclasses can only have one instance']. 49327 self soleInstance class == self ifTrue:[ 49328 ^self error:'Metaclasses can only have one instance']]. 49329 map := self instVarMappingFrom: oldClass. 49330 variable := self isVariable. 49331 instSize := self instSize. 49332 newInstances := Array new: oldInstances size. 49333 1 to: oldInstances size do:[:i| 49334 newInstances at: i put: ( 49335 self newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map)]. 49336 "Now perform a bulk mutation of old instances into new ones" 49337 oldInstances elementsExchangeIdentityWith: newInstances. 49338 ^newInstances "which are now old"! ! 49339 49340!ClassDescription methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 20:48'! 49341updateInstancesFrom: oldClass 49342 "Recreate any existing instances of the argument, oldClass, as instances of 49343 the receiver, which is a newly changed class. Permute variables as 49344 necessary. Return the array of old instances (none of which should be 49345 pointed to legally by anyone but the array)." 49346 "ar 7/15/1999: The updating below is possibly dangerous. If there are any 49347 contexts having an old instance as receiver it might crash the system if 49348 the new receiver in which the context is executed has a different layout. 49349 See bottom below for a simple example:" 49350 | oldInstances | 49351 oldInstances := oldClass allInstances asArray. 49352 oldInstances := self updateInstances: oldInstances from: oldClass isMeta: self isMeta. 49353 "Now fix up instances in segments that are out on the disk." 49354 ImageSegment allSubInstancesDo: [:seg | 49355 seg segUpdateInstancesOf: oldClass toBe: self isMeta: self isMeta]. 49356 ^oldInstances 49357 49358" | crashingBlock class | 49359 class := Object subclass: #CrashTestDummy 49360 instanceVariableNames: 'instVar' 49361 classVariableNames: '' 49362 poolDictionaries: '' 49363 category: 'Crash-Test'. 49364 class compile:'instVar: value instVar := value'. 49365 class compile:'crashingBlock ^[instVar]'. 49366 crashingBlock := (class new) instVar: 42; crashingBlock. 49367 Object subclass: #CrashTestDummy 49368 instanceVariableNames: '' 49369 classVariableNames: '' 49370 poolDictionaries: '' 49371 category: 'Crash-Test'. 49372 crashingBlock. 49373 crashingBlock value. 49374 " 49375! ! 49376 49377 49378!ClassDescription methodsFor: 'instance variables'! 49379addInstVarName: aString 49380 "Add the argument, aString, as one of the receiver's instance variables." 49381 49382 self subclassResponsibility! ! 49383 49384!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:50'! 49385allInstVarNamesEverywhere 49386 "Answer the set of inst var names used by the receiver, all superclasses, and all subclasses" 49387 49388 | aList | 49389 aList := OrderedCollection new. 49390 (self allSuperclasses , self withAllSubclasses asOrderedCollection) do: 49391 [:cls | aList addAll: cls instVarNames]. 49392 ^ aList asSet 49393 49394 "BorderedMorph allInstVarNamesEverywhere"! ! 49395 49396!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:50'! 49397checkForInstVarsOK: instVarString 49398 "Return true if instVarString does no include any names used in a subclass" 49399 | instVarArray | 49400 instVarArray := Scanner new scanFieldNames: instVarString. 49401 self allSubclasses do: 49402 [:cl | cl instVarNames do: 49403 [:n | (instVarArray includes: n) 49404 ifTrue: [self error: n , ' is already used in ' , cl name. 49405 ^ false]]]. 49406 ^ true! ! 49407 49408!ClassDescription methodsFor: 'instance variables' stamp: 'PeterHugossonMiller 9/3/2009 00:54'! 49409chooseClassVarName 49410 "Present the user with a list of class variable names and answer the one selected, or nil if none" 49411 49412 | lines labelStream allVars index | 49413 lines := OrderedCollection new. 49414 allVars := OrderedCollection new. 49415 labelStream := (String new: 200) writeStream. 49416 self withAllSuperclasses reverseDo: 49417 [:class | | vars | 49418 vars := class classVarNames asSortedCollection. 49419 vars do: 49420 [:var | 49421 labelStream nextPutAll: var; cr. 49422 allVars add: var]. 49423 vars isEmpty ifFalse: [lines add: allVars size]]. 49424 labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better" 49425 labelStream skip: -1 "cut last CR". 49426 index := (UIManager default chooseFrom: (labelStream contents substrings) lines: lines). 49427 index = 0 ifTrue: [^ nil]. 49428 ^ allVars at: index! ! 49429 49430!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 22:16'! 49431chooseInstVarAlphabeticallyThenDo: aBlock 49432 | allVars index | 49433 "Put up a menu of all the instance variables in the receiver, presented in alphabetical order, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter." 49434 49435 allVars := self allInstVarNames asSortedArray. 49436 allVars isEmpty ifTrue: [^ self inform: 'There are no 49437instance variables']. 49438 49439 index := (UIManager default chooseFrom: allVars lines: #() title: 'Instance variables in 49440', self name). 49441 index = 0 ifTrue: [^ self]. 49442 aBlock value: (allVars at: index)! ! 49443 49444!ClassDescription methodsFor: 'instance variables' stamp: 'PeterHugossonMiller 9/3/2009 00:54'! 49445chooseInstVarThenDo: aBlock 49446 "Put up a menu of all the instance variables in the receiver, and when 49447the user chooses one, evaluate aBlock with the chosen variable as its 49448parameter. If the list is 6 or larger, then offer an alphabetical 49449formulation as an alternative. triggered by a 'show alphabetically' item 49450at the top of the list." 49451 49452 | lines labelStream allVars index count offerAlpha | 49453 (count := self allInstVarNames size) = 0 ifTrue: 49454 [^ self inform: 'There are no 49455instance variables.']. 49456 49457 allVars := OrderedCollection new. 49458 lines := OrderedCollection new. 49459 labelStream := (String new: 200) writeStream. 49460 (offerAlpha := count > 5) 49461 ifTrue: 49462 [lines add: 1. 49463 allVars add: 'show alphabetically'. 49464 labelStream nextPutAll: allVars first; cr]. 49465 self withAllSuperclasses reverseDo: 49466 [:class | | vars | 49467 vars := class instVarNames. 49468 vars do: 49469 [:var | 49470 labelStream nextPutAll: var; cr. 49471 allVars add: var]. 49472 vars isEmpty ifFalse: [lines add: allVars size]]. 49473 labelStream skip: -1 "cut last CR". 49474 (lines size > 0 and: [lines last = allVars size]) ifTrue: 49475 [lines removeLast]. "dispense with inelegant line beneath last item" 49476 index := (UIManager default chooseFrom: (labelStream contents subStrings: {Character cr}) lines: lines 49477title: 'Instance variables in', self name). 49478 index = 0 ifTrue: [^ self]. 49479 (index = 1 and: [offerAlpha]) ifTrue: [^ self 49480chooseInstVarAlphabeticallyThenDo: aBlock]. 49481 aBlock value: (allVars at: index)! ! 49482 49483!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:50'! 49484classThatDefinesClassVariable: classVarName 49485 "Answer the class that defines the given class variable" 49486 49487 (self classPool includesKey: classVarName asSymbol) ifTrue: [^ self]. 49488 ^self superclass ifNotNil: [self superclass classThatDefinesClassVariable: classVarName]! ! 49489 49490!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:50'! 49491classThatDefinesInstanceVariable: instVarName 49492 (self instVarNames notNil and: [self instVarNames includes: instVarName asString]) ifTrue: [^ self]. 49493 ^self superclass ifNotNil: [self superclass classThatDefinesInstanceVariable: instVarName]! ! 49494 49495!ClassDescription methodsFor: 'instance variables'! 49496forceNewFrom: anArray 49497 "Create a new instance of the class and fill 49498 its instance variables up with the array." 49499 | object max | 49500 49501 object := self new. 49502 max := self instSize. 49503 anArray doWithIndex: [:each :index | 49504 index > max ifFalse: 49505 [object instVarAt: index put: each]]. 49506 ^ object! ! 49507 49508!ClassDescription methodsFor: 'instance variables'! 49509instVarIndexFor: instVarName 49510 "Answer the index of the named instance variable." 49511 49512 | index | 49513 index := instanceVariables == nil 49514 ifTrue: [0] 49515 ifFalse: [instanceVariables indexOf: instVarName]. 49516 index == 0 ifTrue: 49517 [^superclass == nil 49518 ifTrue: [0] 49519 ifFalse: [superclass instVarIndexFor: instVarName]]. 49520 ^superclass == nil 49521 ifTrue: [index] 49522 ifFalse: [index + superclass instSize]! ! 49523 49524!ClassDescription methodsFor: 'instance variables' stamp: 'eem 5/14/2008 13:15'! 49525instVarIndexFor: instVarName ifAbsent: aBlock 49526 "Answer the index of the named instance variable." 49527 49528 | index | 49529 index := instanceVariables == nil 49530 ifTrue: [0] 49531 ifFalse: [instanceVariables indexOf: instVarName ifAbsent: [0]]. 49532 index == 0 ifTrue: 49533 [^superclass == nil 49534 ifTrue: [aBlock value] 49535 ifFalse: [superclass instVarIndexFor: instVarName ifAbsent: aBlock]]. 49536 ^superclass == nil 49537 ifTrue: [index] 49538 ifFalse: [index + superclass instSize]! ! 49539 49540!ClassDescription methodsFor: 'instance variables'! 49541instVarNameForIndex: index 49542 "Answer the named instance variable with index index or nil if none." 49543 49544 | superInstSize | 49545 index > self instSize ifTrue: [^nil]. 49546 superInstSize := superclass isNil ifTrue: [0] ifFalse: [superclass instSize]. 49547 index > superInstSize ifTrue: 49548 [^instanceVariables at: index - superInstSize]. 49549 superclass isNil ifTrue: [^nil]. 49550 ^superclass instVarNameForIndex: index 49551 49552 "(Object allSubclasses select: 49553 [:cls| cls instSize > cls superclass instSize and: [cls subclasses isEmpty and: [cls superclass instSize > 0]]]) collect: 49554 [:cls| (1 to: cls instSize) collect: [:i| cls instVarNameForIndex: i]]"! ! 49555 49556!ClassDescription methodsFor: 'instance variables'! 49557instVarNames 49558 "Answer an Array of the receiver's instance variable names." 49559 49560 instanceVariables == nil 49561 ifTrue: [^#()] 49562 ifFalse: [^instanceVariables]! ! 49563 49564!ClassDescription methodsFor: 'instance variables'! 49565removeInstVarName: aString 49566 "Remove the argument, aString, as one of the receiver's instance 49567 variables. Create an error notification if the argument is not found." 49568 49569 self subclassResponsibility! ! 49570 49571!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:52'! 49572renameInstVar: oldName to: newName 49573 49574 (self confirm: 'WARNING: Renaming of instance variables 49575is subject to substitution ambiguities. 49576Do you still wish to attempt it?') ifFalse: [self halt]. 49577 "...In other words, this does a dumb text search-and-replace, 49578 which might improperly alter, eg, a literal string. As long as 49579 the oldName is unique, everything should work jes' fine. - di" 49580 49581 ^ self renameSilentlyInstVar: oldName to: newName! ! 49582 49583!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:52'! 49584renameSilentlyInstVar: old to: new 49585 | i oldName newName | 49586 oldName := old asString. 49587 newName := new asString. 49588 (i := self instVarNames indexOf: oldName) = 0 ifTrue: 49589 [self error: oldName , ' is not defined in ', self name]. 49590 self allSuperclasses , self withAllSubclasses asOrderedCollection do: 49591 [:cls | (cls instVarNames includes: newName) ifTrue: 49592 [self error: newName , ' is already used in ', cls name]]. 49593 49594 self instVarNames replaceFrom: i to: i with: (Array with: newName). 49595 self replaceSilently: oldName to: newName. "replace in text body of all methods"! ! 49596 49597!ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:52'! 49598replaceSilently: old to: new 49599 "text-replace any part of a method. Used for class and pool variables. Don't touch the header. Not guaranteed to work if name appears in odd circumstances" 49600 | oldCode newCode parser header body sels oldName newName | 49601 49602 oldName := old asString. 49603 newName := new asString. 49604 self withAllSubclasses do: 49605 [:cls | sels := cls selectors. 49606 sels removeAllFoundIn: #(DoIt DoItIn:). 49607 sels do: 49608 [:sel | 49609 oldCode := cls sourceCodeAt: sel. 49610 "Don't make changes in the method header" 49611 (parser := cls parserClass new) parseSelector: oldCode. 49612 header := oldCode copyFrom: 1 to: (parser endOfLastToken min: oldCode size). 49613 body := header size > oldCode size 49614 ifTrue: [''] 49615 ifFalse: [oldCode copyFrom: header size+1 to: oldCode size]. 49616 newCode := header , (body copyReplaceTokens: oldName with: newName). 49617 newCode ~= oldCode ifTrue: 49618 [cls compile: newCode 49619 classified: (cls organization categoryOfElement: sel) 49620 notifying: nil]]. 49621 cls isMeta ifFalse: 49622 [oldCode := cls comment. 49623 newCode := oldCode copyReplaceTokens: oldName with: newName. 49624 newCode ~= oldCode ifTrue: 49625 [cls comment: newCode]]]! ! 49626 49627 49628!ClassDescription methodsFor: 'organization'! 49629methodReferencesInCategory: aCategoryName 49630 ^(self organization listAtCategoryNamed: aCategoryName) 49631 collect: [:ea | MethodReference new 49632 setClassSymbol: self theNonMetaClass name 49633 classIsMeta: self isMeta 49634 methodSymbol: ea 49635 stringVersion: ''] 49636! ! 49637 49638!ClassDescription methodsFor: 'organization' stamp: 'NS 4/8/2004 11:02'! 49639organization 49640 "Answer the instance of ClassOrganizer that represents the organization 49641 of the messages of the receiver." 49642 49643 organization ifNil: 49644 [self organization: (ClassOrganizer defaultList: self methodDict keys asSortedCollection asArray)]. 49645 (organization isMemberOf: Array) ifTrue: 49646 [self recoverFromMDFaultWithTrace]. 49647 49648 "Making sure that subject is set correctly. It should not be necessary." 49649 organization ifNotNil: [organization setSubject: self]. 49650 ^ organization! ! 49651 49652!ClassDescription methodsFor: 'organization' stamp: 'NS 4/8/2004 11:04'! 49653organization: aClassOrg 49654 "Install an instance of ClassOrganizer that represents the organization of the messages of the receiver." 49655 49656 aClassOrg ifNotNil: [aClassOrg setSubject: self]. 49657 organization := aClassOrg! ! 49658 49659!ClassDescription methodsFor: 'organization'! 49660reorganize 49661 "During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization. See the transfer of control where ReadWriteStream fileIn calls scanFrom:" 49662 49663 ^self organization! ! 49664 49665!ClassDescription methodsFor: 'organization'! 49666whichCategoryIncludesSelector: aSelector 49667 "Answer the category of the argument, aSelector, in the organization of 49668 the receiver, or answer nil if the receiver does not inlcude this selector." 49669 49670 (self includesSelector: aSelector) 49671 ifTrue: [^ self organization categoryOfElement: aSelector] 49672 ifFalse: [^nil]! ! 49673 49674!ClassDescription methodsFor: 'organization'! 49675zapOrganization 49676 "Remove the organization of this class by message categories. 49677 This is typically done to save space in small systems. Classes and methods 49678 created or filed in subsequently will, nonetheless, be organized" 49679 49680 self organization: nil. 49681 self isClassSide ifFalse: [self classSide zapOrganization]! ! 49682 49683 49684!ClassDescription methodsFor: 'organization updating'! 49685applyChangesOfNewTraitCompositionReplacing: oldComposition 49686 | changedSelectors | 49687 changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. 49688 self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition. 49689 ^ changedSelectors.! ! 49690 49691!ClassDescription methodsFor: 'organization updating'! 49692noteRecategorizedSelectors: aCollection oldComposition: aTraitComposition 49693 | oldCategory newCategory | 49694 aCollection do: [:each | 49695 oldCategory := self organization categoryOfElement: each. 49696 newCategory := (self traitComposition methodDescriptionForSelector: each) effectiveMethodCategory. 49697 self noteRecategorizedSelector: each from: oldCategory to: newCategory]! ! 49698 49699!ClassDescription methodsFor: 'organization updating'! 49700noteRecategorizedSelector: aSymbol from: oldCategoryOrNil to: newCategoryOrNil 49701 | changedCategories | 49702 changedCategories := self updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil. 49703 changedCategories do: [:each | 49704 (self organization isEmptyCategoryNamed: each) ifTrue: [self organization removeCategory: each]]! ! 49705 49706!ClassDescription methodsFor: 'organization updating'! 49707notifyOfRecategorizedSelector: element from: oldCategory to: newCategory 49708 SystemChangeNotifier uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self! ! 49709 49710!ClassDescription methodsFor: 'organization updating'! 49711updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil 49712 | currentCategory effectiveCategory sel changedCategories composition | 49713 changedCategories := IdentitySet new. 49714 composition := self hasTraitComposition 49715 ifTrue: [self traitComposition] 49716 ifFalse: [TraitComposition new]. 49717 (composition methodDescriptionsForSelector: aSymbol) do: [:each | 49718 sel := each selector. 49719 (self includesLocalSelector: sel) ifFalse: [ 49720 currentCategory := self organization categoryOfElement: sel. 49721 effectiveCategory := each effectiveMethodCategoryCurrent: currentCategory new: newCategoryOrNil. 49722 effectiveCategory isNil ifTrue: [ 49723 currentCategory ifNotNil: [changedCategories add: currentCategory]. 49724 self organization removeElement: sel. 49725 ] ifFalse: [ 49726 ((currentCategory isNil or: [currentCategory == ClassOrganizer ambiguous or: [currentCategory == oldCategoryOrNil]]) and: [currentCategory ~~ effectiveCategory]) ifTrue: [ 49727 currentCategory ifNotNil: [changedCategories add: currentCategory]. 49728 self organization 49729 classify: sel 49730 under: effectiveCategory 49731 suppressIfDefault: false]]]]. 49732 ^ changedCategories! ! 49733 49734 49735!ClassDescription methodsFor: 'printing' stamp: 'al 11/28/2005 11:51'! 49736classVariablesString 49737 "Answer a string of my class variable names separated by spaces." 49738 49739 ^String streamContents: [ :stream | 49740 self classPool keys asSortedCollection 49741 do: [ :each | stream nextPutAll: each ] 49742 separatedBy: [ stream space ] ]! ! 49743 49744!ClassDescription methodsFor: 'printing' stamp: 'al 11/28/2005 11:51'! 49745instanceVariablesString 49746 "Answer a string of my instance variable names separated by spaces." 49747 49748 ^String streamContents: [ :stream | 49749 self instVarNames 49750 do: [ :each | stream nextPutAll: each ] 49751 separatedBy: [ stream space ] ]! ! 49752 49753!ClassDescription methodsFor: 'printing'! 49754printOn: aStream 49755 aStream nextPutAll: self name! ! 49756 49757!ClassDescription methodsFor: 'printing'! 49758printOnStream: aStream 49759 aStream print: self name! ! 49760 49761!ClassDescription methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 49762printWithClosureAnalysisOn: aStream 49763 49764 aStream nextPutAll: self name! ! 49765 49766!ClassDescription methodsFor: 'printing' stamp: 'al 11/28/2005 11:52'! 49767sharedPoolsString 49768 "Answer a string of my shared pool names separated by spaces." 49769 49770 ^String streamContents: [ :stream | 49771 self sharedPools 49772 do: [ :each | 49773 stream nextPutAll: (self environment 49774 keyAtIdentityValue: each 49775 ifAbsent: [ 'private' ]) ] 49776 separatedBy: [ stream space ] ]! ! 49777 49778!ClassDescription methodsFor: 'printing'! 49779storeOn: aStream 49780 "Classes and Metaclasses have global names." 49781 49782 aStream nextPutAll: self name! ! 49783 49784 49785!ClassDescription methodsFor: 'private'! 49786errorCategoryName 49787 self error: 'Category name must be a String'! ! 49788 49789!ClassDescription methodsFor: 'private' stamp: 'al 11/28/2005 11:51'! 49790instVarMappingFrom: oldClass 49791 "Return the mapping from instVars of oldClass to new class that is used for converting old instances of oldClass." 49792 | oldInstVarNames | 49793 oldInstVarNames := oldClass allInstVarNames. 49794 ^self allInstVarNames 49795 collect: [:instVarName | oldInstVarNames indexOf: instVarName].! ! 49796 49797!ClassDescription methodsFor: 'private' stamp: 'marcus.denker 8/25/2008 12:05'! 49798linesOfCode 49799 "An approximate measure of lines of code. 49800 Includes comments, but excludes blank lines." 49801 | lines | 49802 lines := self localMethods inject: 0 into: [:sum :each | sum + each linesOfCode]. 49803 self isMeta 49804 ifTrue: [^ lines] 49805 ifFalse: [^ lines + self class linesOfCode]! ! 49806 49807!ClassDescription methodsFor: 'private' stamp: 'alain.plantec 5/18/2009 08:43'! 49808logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor 49809 aCompiledMethodWithNode method 49810 putSource: aText 49811 fromParseNode: aCompiledMethodWithNode node 49812 class: self 49813 category: category 49814 withStamp: changeStamp 49815 inFile: 2 49816 priorMethod: (self 49817 compiledMethodAt: aCompiledMethodWithNode selector 49818 ifAbsent: []) ! ! 49819 49820!ClassDescription methodsFor: 'private' stamp: 'ar 7/10/1999 11:17'! 49821newInstanceFrom: oldInstance variable: variable size: instSize map: map 49822 "Create a new instance of the receiver based on the given old instance. 49823 The supplied map contains a mapping of the old instVar names into 49824 the receiver's instVars" 49825 | new | 49826 variable 49827 ifTrue: [new := self basicNew: oldInstance basicSize] 49828 ifFalse: [new := self basicNew]. 49829 1 to: instSize do: 49830 [:offset | (map at: offset) > 0 ifTrue: 49831 [new instVarAt: offset 49832 put: (oldInstance instVarAt: (map at: offset))]]. 49833 variable 49834 ifTrue: [1 to: oldInstance basicSize do: 49835 [:offset | 49836 new basicAt: offset put: (oldInstance basicAt: offset)]]. 49837 ^new! ! 49838 49839!ClassDescription methodsFor: 'private' stamp: 'marcus.denker 8/24/2008 13:14'! 49840numberOfMethods 49841 "cound all methods that are local (not comming from a trait)" 49842 | num | 49843 num := (self methods select: [:each | self includesLocalSelector: each selector]) size. 49844 self isMeta 49845 ifTrue: [^ num] 49846 ifFalse: [^ num + self class numberOfMethods] ! ! 49847 49848!ClassDescription methodsFor: 'private' stamp: 'ar 7/15/1999 17:04'! 49849setInstVarNames: instVarArray 49850 "Private - for class initialization only" 49851 | required | 49852 required := self instSize. 49853 superclass notNil ifTrue:[required := required - superclass instSize]. 49854 instVarArray size = required 49855 ifFalse:[^self error: required printString, ' instvar names are required']. 49856 instVarArray isEmpty 49857 ifTrue:[instanceVariables := nil] 49858 ifFalse:[instanceVariables := instVarArray asArray].! ! 49859 49860"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 49861 49862ClassDescription class 49863 uses: TClassAndTraitDescription classTrait 49864 instanceVariableNames: ''! 49865ClassTestCase subclass: #ClassDescriptionTest 49866 instanceVariableNames: '' 49867 classVariableNames: '' 49868 poolDictionaries: '' 49869 category: 'KernelTests-Classes'! 49870!ClassDescriptionTest commentStamp: '<historical>' prior: 0! 49871This is the unit test for the class ClassDescription. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 49872 - http://www.c2.com/cgi/wiki?UnitTest 49873 - http://minnow.cc.gatech.edu/squeak/1547 49874 - the sunit class category! 49875 49876 49877!ClassDescriptionTest methodsFor: 'tests' stamp: 'sd 5/10/2008 12:34'! 49878testMethods 49879 self assert: Object methods = Object methodDict values. ! ! 49880 49881!ClassDescriptionTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:24'! 49882testOrganization 49883 49884 | aClassOrganizer | 49885 aClassOrganizer := ClassDescription organization. 49886 self assert: (aClassOrganizer isKindOf: ClassOrganizer).! ! 49887TextDiffBuilder subclass: #ClassDiffBuilder 49888 instanceVariableNames: '' 49889 classVariableNames: '' 49890 poolDictionaries: '' 49891 category: 'System-FilePackage'! 49892 49893!ClassDiffBuilder methodsFor: 'initialize' stamp: 'PeterHugossonMiller 9/3/2009 00:56'! 49894split: aString 49895 | lines in out c | 49896 lines := OrderedCollection new. 49897 in := aString readStream. 49898 out := String new writeStream. 49899 [ in atEnd ] whileFalse: 49900 [ (c := in next) isSeparator 49901 ifTrue: 49902 [ out nextPut: c. 49903 lines add: out contents. 49904 out reset ] 49905 ifFalse: [ out nextPut: c ] ]. 49906 out position = 0 ifFalse: [ lines add: out contents ]. 49907 ^ lines! ! 49908 49909 49910!ClassDiffBuilder methodsFor: 'printing' stamp: 'nk 4/24/2004 08:49'! 49911printPatchSequence: ps on: aStream 49912 | type line | 49913 ps do: [:assoc | 49914 type := assoc key. 49915 line := assoc value. 49916 aStream 49917 withAttributes: (self attributesOf: type) 49918 do: [aStream nextPutAll: line]]! ! 49919Object subclass: #ClassFactoryForTestCase 49920 instanceVariableNames: 'createdClasses' 49921 classVariableNames: '' 49922 poolDictionaries: '' 49923 category: 'SUnit-Extensions'! 49924 49925!ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 14:21'! 49926createdClassNames 49927 ^self createdClasses collect: [:class| class name]! ! 49928 49929!ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 13:59'! 49930createdClasses 49931 ^createdClasses! ! 49932 49933!ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 14:01'! 49934createdClasses: classes 49935 createdClasses := classes asIdentitySet ! ! 49936 49937!ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 16:37'! 49938defaultCategory 49939 ^ (self packageName , '-', self defaultCategoryPostfix) asSymbol! ! 49940 49941!ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 16:23'! 49942defaultCategoryPostfix 49943 ^ #Default! ! 49944 49945!ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 16:20'! 49946packageName 49947 ^#CategoryForTestToBeDeleted! ! 49948 49949 49950!ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'Noury 10/26/2008 16:26'! 49951cleanUp 49952 | createdClassNames | 49953 createdClassNames := self createdClassNames. 49954 self deleteClasses. 49955 self deletePackage. 49956 self cleanUpChangeSetForClassNames: createdClassNames! ! 49957 49958!ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'Noury 10/26/2008 14:20'! 49959cleanUpChangeSetForClassNames: classeNames 49960 | changeSet | 49961 changeSet := ChangeSet current. 49962 classeNames do: [:name| 49963 changeSet 49964 removeClassChanges: name; 49965 removeClassChanges: name, ' class']. ! ! 49966 49967!ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'Noury 10/26/2008 12:47'! 49968delete: aClass 49969 aClass isObsolete ifTrue: [^self]. 49970 aClass removeFromChanges. 49971 aClass removeFromSystemUnlogged 49972! ! 49973 49974!ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'Noury 10/26/2008 12:46'! 49975deleteClasses 49976 self createdClasses do: [:class| 49977 self delete: class]! ! 49978 49979!ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'Noury 10/26/2008 16:33'! 49980deletePackage 49981 | categoriesMatchString | 49982 categoriesMatchString := self packageName, '-*'. 49983 SystemOrganization removeCategoriesMatching: categoriesMatchString! ! 49984 49985!ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'Noury 10/26/2008 14:01'! 49986initialize 49987 super initialize. 49988 self createdClasses: IdentitySet new! ! 49989 49990 49991!ClassFactoryForTestCase methodsFor: 'creating' stamp: 'Noury 10/26/2008 14:55'! 49992newClass 49993 ^self newSubclassOf: Object instanceVariableNames: '' classVariableNames: ''! ! 49994 49995!ClassFactoryForTestCase methodsFor: 'creating' stamp: 'Noury 10/26/2008 16:46'! 49996newClassInCategory: category 49997 ^self newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: category! ! 49998 49999!ClassFactoryForTestCase methodsFor: 'creating' stamp: 'Noury 10/26/2008 14:08'! 50000newName 50001 | postFix | 50002 postFix := (self createdClasses size + 1) printString. 50003 ^#ClassForTestToBeDeleted, postFix! ! 50004 50005!ClassFactoryForTestCase methodsFor: 'creating' stamp: 'Noury 10/26/2008 16:25'! 50006newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString 50007 ^self 50008 newSubclassOf: aClass 50009 instanceVariableNames: ivNamesString 50010 classVariableNames: classVarsString 50011 category: self defaultCategoryPostfix! ! 50012 50013!ClassFactoryForTestCase methodsFor: 'creating' stamp: 'Noury 10/26/2008 16:36'! 50014newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category 50015 | newClass | 50016 newClass := aClass 50017 subclass: self newName 50018 instanceVariableNames: ivNamesString 50019 classVariableNames: classVarsString 50020 poolDictionaries: '' 50021 category: (self packageName, '-', category) asSymbol. 50022 self createdClasses add: newClass. 50023 ^newClass! ! 50024TestCase subclass: #ClassFactoryForTestCaseTest 50025 instanceVariableNames: 'factory' 50026 classVariableNames: '' 50027 poolDictionaries: '' 50028 category: 'SUnit-Tests'! 50029 50030!ClassFactoryForTestCaseTest methodsFor: 'setUp-tearDown' stamp: 'Noury 10/26/2008 12:19'! 50031setUp 50032 super setUp. 50033 factory := ClassFactoryForTestCase new! ! 50034 50035!ClassFactoryForTestCaseTest methodsFor: 'setUp-tearDown' stamp: 'Noury 10/26/2008 14:53'! 50036tearDown 50037 super tearDown. 50038 factory cleanUp! ! 50039 50040 50041!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:43'! 50042testClassCreationInDifferentCategories 50043 | firstThreeClasses lastTwoClasses | 50044 3 timesRepeat: [ 50045 factory newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: #One]. 50046 firstThreeClasses := factory createdClasses copy. 50047 2 timesRepeat: [ 50048 factory newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: #Two]. 50049 lastTwoClasses := factory createdClasses copyWithoutAll: firstThreeClasses. 50050 self assert: (firstThreeClasses allSatisfy: [:class| class category = (factory packageName, '-', #One) asSymbol]). 50051 self assert: (lastTwoClasses allSatisfy: [:class| class category = (factory packageName, '-', #Two) asSymbol]).! ! 50052 50053!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:42'! 50054testClassFastCreationInDifferentCategories 50055 | firstThreeClasses lastTwoClasses | 50056 3 timesRepeat: [ 50057 factory newClassInCategory: #One]. 50058 firstThreeClasses := factory createdClasses copy. 50059 2 timesRepeat: [ 50060 factory newClassInCategory: #Two]. 50061 lastTwoClasses := factory createdClasses copyWithoutAll: firstThreeClasses. 50062 self assert: (firstThreeClasses allSatisfy: [:class| class category = (factory packageName, '-', #One) asSymbol]). 50063 self assert: (lastTwoClasses allSatisfy: [:class| class category = (factory packageName, '-', #Two) asSymbol]).! ! 50064 50065!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:44'! 50066testDefaultCategoryCleanUp 50067 | createdClassNames allClasses | 50068 3 timesRepeat: [ 50069 factory newClass]. 50070 createdClassNames := factory createdClassNames. 50071 factory cleanUp. 50072 self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]). 50073 allClasses := SystemNavigation new allClasses. 50074 self assert: (factory createdClasses noneSatisfy: [:class| allClasses includes: class]). 50075 self deny: (SystemOrganization categories includes: factory defaultCategory). 50076 self deny: (ChangeSet current changedClassNames includesAnyOf: createdClassNames) 50077! ! 50078 50079!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:38'! 50080testMultipleClassCreation 50081 5 timesRepeat: [ 50082 factory newClass]. 50083 self assert: (SystemNavigation new allClasses includesAllOf: factory createdClasses). 50084 self assert: factory createdClassNames asSet size = 5. 50085 self assert: (SystemOrganization listAtCategoryNamed: factory defaultCategory) asSet = factory createdClassNames asSet! ! 50086 50087!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:47'! 50088testPackageCleanUp 50089 | createdClassNames allClasses | 50090 3 timesRepeat: [ 50091 factory newClassInCategory: #One]. 50092 2 timesRepeat: [ 50093 factory newClassInCategory: #Two]. 50094 createdClassNames := factory createdClassNames. 50095 factory cleanUp. 50096 self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]). 50097 allClasses := SystemNavigation new allClasses. 50098 self assert: (factory createdClasses noneSatisfy: [:class| allClasses includes: class]). 50099 self assert: (SystemOrganization categoriesMatching: factory packageName, '*') isEmpty. 50100 self deny: (ChangeSet current changedClassNames includesAnyOf: createdClassNames) 50101! ! 50102 50103!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:37'! 50104testSingleClassCreation 50105 |class elementsInCategoryForTest | 50106 class := factory 50107 newSubclassOf: Object 50108 instanceVariableNames: 'a b c' 50109 classVariableNames: 'X Y'. 50110 self assert: (SystemNavigation new allClasses includes: class). 50111 elementsInCategoryForTest := SystemOrganization listAtCategoryNamed: factory defaultCategory. 50112 self assert: elementsInCategoryForTest = {class name}. 50113 self assert: class instVarNames = #(a b c). 50114 self assert: class classPool keys = #(X Y) asSet! ! 50115 50116!ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:37'! 50117testSingleClassFastCreation 50118 |class elementsInCategoryForTest | 50119 class := factory newClass. 50120 self assert: (SystemNavigation new allClasses includes: class). 50121 elementsInCategoryForTest := SystemOrganization listAtCategoryNamed: factory defaultCategory. 50122 self assert: elementsInCategoryForTest = {class name}. 50123 self assert: class instVarNames isEmpty. 50124 self assert: class classPool isEmpty! ! 50125 50126"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 50127 50128ClassFactoryForTestCaseTest class 50129 instanceVariableNames: ''! 50130 50131!ClassFactoryForTestCaseTest class methodsFor: 'history' stamp: 'simon.denier 11/22/2008 22:13'! 50132lastStoredRun 50133 ^ ((Dictionary new) add: (#passed->((Set new) add: #testDefaultCategoryCleanUp; add: #testPackageCleanUp; add: #testSingleClassCreation; add: #testClassCreationInDifferentCategories; add: #testClassFastCreationInDifferentCategories; add: #testMultipleClassCreation; add: #testSingleClassFastCreation; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ! 50134HierarchyBrowser subclass: #ClassListBrowser 50135 instanceVariableNames: 'defaultTitle' 50136 classVariableNames: '' 50137 poolDictionaries: '' 50138 category: 'Tools-Browser'! 50139!ClassListBrowser commentStamp: '<historical>' prior: 0! 50140A ClassListBrowser displays the code for an arbitrary list of classes. 50141 50142ClassListBrowser example1. "all classes that have the string 'Pluggable' in their names" 50143ClassListBrowser example2. "all classes whose names start with the letter S" 50144ClassListBrowser example3. "all variable classes" 50145ClassListBrowser example4. "all classes with more than 100 methods" 50146ClassListBrowser example5. "all classes that lack class comments" 50147ClassListBrowser example6. "all classes that have class instance variables" 50148 50149ClassListBrowser new initForClassesNamed: #(Browser Boolean) title: 'Browser and Boolean!!'. 50150! 50151 50152 50153!ClassListBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! 50154initForClassesNamed: nameList title: aTitle 50155 "Initialize the receiver for the class-name-list and title provided" 50156 50157 self systemOrganizer: SystemOrganization. 50158 metaClassIndicated := false. 50159 defaultTitle := aTitle. 50160 classList := nameList copy. 50161 self class openBrowserView: (self openSystemCatEditString: nil) 50162 label: aTitle 50163 50164 "ClassListBrowser new initForClassesNamed: #(Browser CategoryViewer) title: 'Frogs'"! ! 50165 50166 50167!ClassListBrowser methodsFor: 'title' stamp: 'sd 11/20/2005 21:26'! 50168defaultTitle: aTitle 50169 "Set the browser's default title" 50170 50171 defaultTitle := aTitle! ! 50172 50173!ClassListBrowser methodsFor: 'title' stamp: 'sw 7/18/2002 22:43'! 50174labelString 50175 "Answer the label strilng to use on the browser" 50176 50177 ^ defaultTitle ifNil: [super labelString]! ! 50178 50179"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 50180 50181ClassListBrowser class 50182 instanceVariableNames: ''! 50183 50184!ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 16:01'! 50185example1 50186 "Put up a ClassListBrowser that shows all classes that have the string 'Pluggable' in their names" 50187 50188 self browseClassesSatisfying: [:cl | cl name includesSubString: 'Pluggable'] title: 'Pluggables' 50189 50190"ClassListBrowser example1" 50191 ! ! 50192 50193!ClassListBrowser class methodsFor: 'examples' stamp: 'sd 4/17/2003 21:21'! 50194example2 50195 "Put up a ClassListBrowser that shows all classes whose names start with 50196 the letter S" 50197 50198 self new 50199 initForClassesNamed: (self systemNavigation allClasses 50200 collect: [:c | c name] 50201 thenSelect: [:aName | aName first == $S]) 50202 title: 'All classes starting with S' 50203 "ClassListBrowser example2"! ! 50204 50205!ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 16:03'! 50206example3 50207 "Put up a ClassListBrowser that shows all Variable classes" 50208 50209 self browseClassesSatisfying: [:c | c isVariable] title: 'All Variable classes' 50210 50211"ClassListBrowser example3" 50212 ! ! 50213 50214!ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 16:04'! 50215example4 50216 "Put up a ClassListBrowser that shows all classes implementing more than 100 methods" 50217 50218 self browseClassesSatisfying: 50219 [:c | (c selectors size + c class selectors size) > 100] title: 'Classes with more than 100 methods' 50220 50221"ClassListBrowser example4" 50222 ! ! 50223 50224!ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 14:32'! 50225example5 50226 "Put up a ClassListBrowser that shows all classes that lack class comments" 50227 50228 self 50229 browseClassesSatisfying: 50230 [:c | c organization classComment isEmptyOrNil] 50231 title: 'Classes lacking class comments' 50232 50233"ClassListBrowser example5" 50234 ! ! 50235 50236!ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 14:33'! 50237example6 50238 "Put up a ClassListBrowser that shows all classes that have class instance variables" 50239 50240 self 50241 browseClassesSatisfying: 50242 [:c | c class instVarNames size > 0] 50243 title: 50244 'Classes that define class-side instance variables' 50245 50246"ClassListBrowser example6"! ! 50247 50248 50249!ClassListBrowser class methodsFor: 'instance creation' stamp: 'sd 4/17/2003 21:21'! 50250browseClassesSatisfying: classBlock title: aTitle 50251 "Put up a ClassListBrowser showing all classes that satisfy the classBlock." 50252 50253 self new 50254 initForClassesNamed: 50255 (self systemNavigation allClasses select: 50256 [:c | (classBlock value: c) == true] 50257 thenCollect: 50258 [:c | c name]) 50259 title: 50260 aTitle! ! 50261BasicClassOrganizer subclass: #ClassOrganizer 50262 instanceVariableNames: '' 50263 classVariableNames: '' 50264 poolDictionaries: '' 50265 category: 'Kernel-Classes'! 50266!ClassOrganizer commentStamp: 'NS 4/6/2004 16:13' prior: 0! 50267I represent method categorization information for classes. The handling of class comments has gone through a tortuous evolution. Grandfathered class comments (before late aug 98) have no time stamps, and historically, fileouts of class comments always substituted the timestamp reflecting the author and date/time at the moment of fileout; and historically any timestamps in a filed out class comment were dropped on the floor, with the author & time prevailing at the moment of filein being substituted. Such grandfathered comments now go out on fileouts with '<historical>' timestamp; class comments created after the 8/98 changes will have their correct timestamps preserved, though there is not yet a decent ui for reading those stamps other than filing out and looking at the file; nor is there yet any ui for browsing and recovering past versions of such comments. Everything in good time!!! 50268 50269 50270!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'! 50271addCategory: catString before: nextCategory 50272 | oldCategories | 50273 oldCategories := self categories copy. 50274 SystemChangeNotifier uniqueInstance doSilently: [ 50275 super addCategory: catString before: nextCategory]. 50276 self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! 50277 50278!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:28'! 50279changeFromCategorySpecs: categorySpecs 50280 | oldDict oldCategories | 50281 oldDict := self elementCategoryDict. 50282 oldCategories := self categories copy. 50283 SystemChangeNotifier uniqueInstance doSilently: [ 50284 super changeFromCategorySpecs: categorySpecs]. 50285 self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict. 50286 self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! 50287 50288!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'! 50289classify: element under: heading suppressIfDefault: aBoolean 50290 | oldCat newCat | 50291 oldCat := self categoryOfElement: element. 50292 SystemChangeNotifier uniqueInstance doSilently: [ 50293 super classify: element under: heading suppressIfDefault: aBoolean]. 50294 newCat := self categoryOfElement: element. 50295 self notifyOfChangedSelector: element from: oldCat to: newCat.! ! 50296 50297!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'! 50298removeCategory: cat 50299 | oldCategories | 50300 oldCategories := self categories copy. 50301 SystemChangeNotifier uniqueInstance doSilently: [ 50302 super removeCategory: cat]. 50303 self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! 50304 50305!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'! 50306removeElement: element 50307 | oldCat | 50308 oldCat := self categoryOfElement: element. 50309 SystemChangeNotifier uniqueInstance doSilently: [ 50310 super removeElement: element]. 50311 self notifyOfChangedSelector: element from: oldCat to: (self categoryOfElement: element).! ! 50312 50313!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'! 50314removeEmptyCategories 50315 | oldCategories | 50316 oldCategories := self categories copy. 50317 SystemChangeNotifier uniqueInstance doSilently: [ 50318 super removeEmptyCategories]. 50319 self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! 50320 50321!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'! 50322renameCategory: oldCatString toBe: newCatString 50323 | oldCat newCat oldElementsBefore oldElementsAfter | 50324 oldCat := oldCatString asSymbol. 50325 newCat := newCatString asSymbol. 50326 oldElementsBefore := self listAtCategoryNamed: oldCat. 50327 SystemChangeNotifier uniqueInstance doSilently: [ 50328 super renameCategory: oldCatString toBe: newCatString]. 50329 oldElementsAfter := (self listAtCategoryNamed: oldCat) asSet. 50330 oldElementsBefore do: [:each | 50331 (oldElementsAfter includes: each) 50332 ifFalse: [self notifyOfChangedSelector: each from: oldCat to: newCat]. 50333 ]. 50334 self notifyOfChangedCategoryFrom: oldCat to: newCat.! ! 50335 50336!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/12/2004 20:57'! 50337setDefaultList: aSortedCollection 50338 | oldDict oldCategories | 50339 oldDict := self elementCategoryDict. 50340 oldCategories := self categories copy. 50341 SystemChangeNotifier uniqueInstance doSilently: [ 50342 super setDefaultList: aSortedCollection]. 50343 self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict. 50344 self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! 50345 50346!ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'! 50347sortCategories 50348 | oldCategories | 50349 oldCategories := self categories copy. 50350 SystemChangeNotifier uniqueInstance doSilently: [ 50351 super sortCategories]. 50352 self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! 50353 50354 50355!ClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 10:15'! 50356notifyOfChangedCategoriesFrom: oldCollectionOrNil to: newCollectionOrNil 50357 (self hasSubject and: [oldCollectionOrNil ~= newCollectionOrNil]) 50358 ifTrue: [SystemChangeNotifier uniqueInstance classReorganized: self subject].! ! 50359 50360!ClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 23:02'! 50361notifyOfChangedCategoryFrom: oldNameOrNil to: newNameOrNil 50362 (self hasSubject and: [oldNameOrNil ~= newNameOrNil]) 50363 ifTrue: [SystemChangeNotifier uniqueInstance classReorganized: self subject].! ! 50364 50365!ClassOrganizer methodsFor: 'private' stamp: 'NS 4/16/2004 10:47'! 50366notifyOfChangedSelector: element from: oldCategory to: newCategory 50367 (self hasSubject and: [(oldCategory ~= newCategory)]) ifTrue: [ 50368 self subject notifyOfRecategorizedSelector: element from: oldCategory to: newCategory. 50369 ].! ! 50370 50371!ClassOrganizer methodsFor: 'private' stamp: 'eem 6/11/2008 17:00'! 50372notifyOfChangedSelectorsOldDict: oldDictionaryOrNil newDict: newDictionaryOrNil 50373 (oldDictionaryOrNil isNil and: [newDictionaryOrNil isNil]) 50374 ifTrue: [^ self]. 50375 50376 oldDictionaryOrNil isNil ifTrue: [ 50377 newDictionaryOrNil keysAndValuesDo: [:el :cat | 50378 self notifyOfChangedSelector: el from: nil to: cat]. 50379 ^ self. 50380 ]. 50381 50382 newDictionaryOrNil isNil ifTrue: [ 50383 oldDictionaryOrNil keysAndValuesDo: [:el :cat | 50384 self notifyOfChangedSelector: el from: cat to: nil]. 50385 ^ self. 50386 ]. 50387 50388 oldDictionaryOrNil keysAndValuesDo: [:el :cat | | newCat | 50389 newCat := newDictionaryOrNil at: el. 50390 self notifyOfChangedSelector: el from: cat to: newCat. 50391 ].! ! 50392 50393"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 50394 50395ClassOrganizer class 50396 instanceVariableNames: ''! 50397TestCase subclass: #ClassRenameFixTest 50398 instanceVariableNames: 'previousChangeSet testsChangeSet newClassName originalName' 50399 classVariableNames: '' 50400 poolDictionaries: '' 50401 category: 'Tests-Bugs'! 50402 50403!ClassRenameFixTest methodsFor: 'running' stamp: 'cmm 8/7/2005 18:20'! 50404setUp 50405 50406 previousChangeSet := ChangeSet current. 50407 testsChangeSet := ChangeSet new. 50408 ChangeSet newChanges: testsChangeSet. 50409 SystemChangeNotifier uniqueInstance 50410 notify: self 50411 ofSystemChangesOfItem: #class 50412 change: #Renamed 50413 using: #verifyRenameEvent:. 50414 super setUp! ! 50415 50416!ClassRenameFixTest methodsFor: 'running' stamp: 'cmm 8/7/2005 18:21'! 50417tearDown 50418 50419 self removeEverythingInSetFromSystem: testsChangeSet. 50420 ChangeSet newChanges: previousChangeSet. 50421 ChangeSorter removeChangeSet: testsChangeSet. 50422 previousChangeSet := nil. 50423 testsChangeSet := nil. 50424 SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self. 50425 super tearDown.! ! 50426 50427!ClassRenameFixTest methodsFor: 'running' stamp: 'cmm 8/7/2005 19:04'! 50428verifyRenameEvent: aRenamedEvent 50429 50430 | renamedClass | 50431 self assert: aRenamedEvent isRenamed. 50432 renamedClass := aRenamedEvent item. 50433 self assert: (Smalltalk classNamed: newClassName) name = newClassName. 50434 self assert: renamedClass name = newClassName! ! 50435 50436 50437!ClassRenameFixTest methodsFor: 'tests' stamp: 'cmm 8/7/2005 18:21'! 50438renameClassUsing: aBlock 50439 50440 | createdClass foundClasses | 50441 originalName := self newUniqueClassName. 50442 createdClass := Object 50443 subclass: originalName 50444 instanceVariableNames: '' 50445 classVariableNames: '' 50446 poolDictionaries: '' 50447 category: 'ClassRenameFix-GeneradClass'. 50448 newClassName := self newUniqueClassName. 50449 aBlock value: createdClass value: newClassName. 50450 self assert: (Smalltalk classNamed: originalName) isNil. 50451 self assert: (Smalltalk classNamed: newClassName) notNil. 50452 foundClasses := Smalltalk organization listAtCategoryNamed: 'ClassRenameFix-GeneradClass'. 50453 self assert: (foundClasses notEmpty). 50454 self assert: (foundClasses includes: newClassName). 50455 self assert: (createdClass name = newClassName).! ! 50456 50457!ClassRenameFixTest methodsFor: 'tests' stamp: 'md 9/6/2005 18:30'! 50458testRenameClassUsingClass 50459 "self run: #testRenameClassUsingClass" 50460 50461 self renameClassUsing: [:class :newName | class rename: newName].! ! 50462 50463 50464!ClassRenameFixTest methodsFor: 'private' stamp: 'md 9/6/2005 18:30'! 50465newUniqueClassName 50466 "Return a class name that is not used in the system." 50467 50468 "self new newClassName" 50469 50470 | baseName newName | 50471 baseName := 'AutoGeneratedClassForTestingSystemChanges'. 50472 1 to: 9999 50473 do: 50474 [:number | 50475 newName := baseName , number printString. 50476 (Smalltalk hasClassNamed: newName) ifFalse: [^newName asSymbol]]. 50477 ^self 50478 error: 'Can no longer find a new and unique class name for the SystemChangeTest !!'! ! 50479 50480!ClassRenameFixTest methodsFor: 'private' stamp: 'md 9/6/2005 18:30'! 50481removeEverythingInSetFromSystem: aChangeSet 50482 50483 aChangeSet changedMessageList 50484 do: [:methodRef | methodRef actualClass removeSelector: methodRef methodSymbol]. 50485 aChangeSet changedClasses 50486 do: [:each | each isMeta 50487 ifFalse: [each removeFromSystemUnlogged]]! ! 50488TestCase subclass: #ClassTest 50489 instanceVariableNames: 'className renamedName' 50490 classVariableNames: '' 50491 poolDictionaries: '' 50492 category: 'KernelTests-Classes'! 50493 50494!ClassTest methodsFor: 'setup' stamp: 'rw 10/7/2006 08:57'! 50495deleteClass 50496 | cl | 50497 cl := Smalltalk at: className ifAbsent: [^self]. 50498 cl removeFromChanges; removeFromSystemUnlogged 50499 ! ! 50500 50501!ClassTest methodsFor: 'setup' stamp: 'rw 10/7/2006 08:57'! 50502deleteRenamedClass 50503 | cl | 50504 cl := Smalltalk at: renamedName ifAbsent: [^self]. 50505 cl removeFromChanges; removeFromSystemUnlogged 50506 ! ! 50507 50508!ClassTest methodsFor: 'setup' stamp: 'rw 10/17/2006 22:05'! 50509setUp 50510 className := #TUTU. 50511 renamedName := #RenamedTUTU. 50512 self deleteClass. 50513 self deleteRenamedClass. 50514 Object subclass: className 50515 instanceVariableNames: '' 50516 classVariableNames: '' 50517 poolDictionaries: '' 50518 category: 'KernelTests-Classes'! ! 50519 50520!ClassTest methodsFor: 'setup' stamp: 'rw 10/17/2006 22:08'! 50521tearDown 50522 self deleteClass. 50523 self deleteRenamedClass! ! 50524 50525 50526!ClassTest methodsFor: 'testing' stamp: 'md 1/5/2004 14:59'! 50527testAddInstVarName 50528 "self run: #testAddInstVarName" 50529 50530 50531 | tutu | 50532 tutu := Smalltalk at: #TUTU. 50533 tutu addInstVarName: 'x'. 50534 self assert: (tutu instVarNames = #('x')). 50535 tutu addInstVarName: 'y'. 50536 self assert: (tutu instVarNames = #('x' 'y')) 50537 50538 ! ! 50539 50540!ClassTest methodsFor: 'testing' stamp: 'rw 10/17/2006 22:13'! 50541testRenaming 50542 "self debug: #testRenaming" 50543 "self run: #testRenaming" 50544 50545 | oldName newMetaclassName class | 50546 oldName := className. 50547 newMetaclassName := (renamedName, #' class') asSymbol. 50548 class := Smalltalk at: oldName. 50549 class class compile: 'dummyMeth'. 50550 class rename: renamedName. 50551 self assert: class name = renamedName. 50552 self assert: (ChangeSet current changedClassNames includes: renamedName). 50553 self assert: (ChangeSet current changedClassNames includes: newMetaclassName). 50554 ! ! 50555 50556 50557!ClassTest methodsFor: 'testing - access' stamp: 'sd 4/24/2008 22:11'! 50558testHaSharedPools 50559 "self run: #testHaSharedPools" 50560 50561 self deny: Point hasSharedPools. 50562 self assert: Date hasSharedPools! ! 50563 50564 50565!ClassTest methodsFor: 'testing - class variables' stamp: 'marcus.denker 12/4/2008 11:12'! 50566testClassVarNames 50567 50568 self assert: (Object classVarNames includes: #DependentsFields). 50569 50570 "A class and it's meta-class share the class variables" 50571 self assert: (Object classVarNames = Object class classVarNames).! ! 50572 50573 50574!ClassTest methodsFor: 'testing - compiling' stamp: 'sd 6/5/2005 08:25'! 50575testCompileAll 50576 50577 self shouldnt: [ClassTest compileAll] raise: Error.! ! 50578TestCase subclass: #ClassTestCase 50579 instanceVariableNames: '' 50580 classVariableNames: '' 50581 poolDictionaries: '' 50582 category: 'SUnit-Utilities'! 50583!ClassTestCase commentStamp: 'brp 7/26/2003 16:57' prior: 0! 50584This class is intended for unit tests of individual classes and their metaclasses. 50585 50586It provides methods to determine the coverage of the unit tests. 50587 50588Subclasses are expected to re-implement #classesToBeTested and #selectorsToBeIgnored. 50589 50590They should also implement to confirm that all methods have been tested. 50591 50592#testCoverage 50593 50594 super testCoverage. 50595 50596! 50597 50598 50599!ClassTestCase methodsFor: 'Coverage' stamp: 'apb 4/15/2006 11:50'! 50600selectorsTested 50601 | literals | 50602 literals := Set new. 50603 self class 50604 selectorsAndMethodsDo: [ :s :m | (s beginsWith: 'test') 50605 ifTrue: [ literals addAll: (m messages)] ]. 50606 ^ literals asSortedArray! ! 50607 50608 50609!ClassTestCase methodsFor: 'coverage' stamp: 'brp 7/27/2003 12:39'! 50610classToBeTested 50611 50612 self subclassResponsibility! ! 50613 50614!ClassTestCase methodsFor: 'coverage' stamp: 'brp 7/26/2003 16:35'! 50615selectorsNotTested 50616 50617 ^ self selectorsToBeTested difference: self selectorsTested. 50618! ! 50619 50620!ClassTestCase methodsFor: 'coverage' stamp: 'brp 7/26/2003 17:22'! 50621selectorsToBeIgnored 50622 ^ #(#DoIt #DoItIn:)! ! 50623 50624!ClassTestCase methodsFor: 'coverage' stamp: 'brp 7/27/2003 12:40'! 50625selectorsToBeTested 50626 50627 ^ ( { self classToBeTested. self classToBeTested class } gather: [:c | c selectors]) 50628 difference: self selectorsToBeIgnored! ! 50629 50630 50631!ClassTestCase methodsFor: 'tests' stamp: 'marcus.denker 7/29/2009 15:27'! 50632testClassComment 50633 self should: [self targetClass organization hasComment].! ! 50634 50635!ClassTestCase methodsFor: 'tests' stamp: 'brp 12/14/2003 15:51'! 50636testCoverage 50637 50638 | untested | 50639 self class mustTestCoverage ifTrue: 50640 [ untested := self selectorsNotTested. 50641 self assert: untested isEmpty 50642 description: untested size asString, ' selectors are not covered' ]! ! 50643 50644!ClassTestCase methodsFor: 'tests' stamp: 'md 3/25/2003 23:07'! 50645testNew 50646 self shouldnt: [self targetClass new] raise: Error.! ! 50647 50648!ClassTestCase methodsFor: 'tests' stamp: 'md 3/26/2003 17:24'! 50649testUnCategorizedMethods 50650 | categories slips | 50651 categories := self categoriesForClass: self targetClass. 50652 slips := categories select: [:each | each = #'as yet unclassified']. 50653 self should: [slips isEmpty]. ! ! 50654 50655 50656!ClassTestCase methodsFor: 'private' stamp: 'md 1/28/2004 11:32'! 50657categoriesForClass: aClass 50658 50659 ^ aClass organization allMethodSelectors collect: 50660 [:each | aClass organization categoryOfElement: each]. 50661! ! 50662 50663!ClassTestCase methodsFor: 'private' stamp: 'md 1/28/2004 11:28'! 50664targetClass 50665 |className| 50666 50667 className := self class name asText copyFrom: 0 to: self class name size - 4. 50668 ^ Smalltalk at: (className asString asSymbol). 50669! ! 50670 50671"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 50672 50673ClassTestCase class 50674 instanceVariableNames: ''! 50675 50676!ClassTestCase class methodsFor: 'testing' stamp: 'md 2/22/2006 14:21'! 50677isAbstract 50678 "Override to true if a TestCase subclass is Abstract and should not have 50679 TestCase instances built from it" 50680 50681 ^self name = #ClassTestCase 50682 ! ! 50683 50684!ClassTestCase class methodsFor: 'testing' stamp: 'brp 12/14/2003 15:50'! 50685mustTestCoverage 50686 50687 ^ false! ! 50688TraitDescription subclass: #ClassTrait 50689 uses: TApplyingOnClassSide 50690 instanceVariableNames: 'baseTrait' 50691 classVariableNames: '' 50692 poolDictionaries: '' 50693 category: 'Traits-Kernel'! 50694!ClassTrait commentStamp: '<historical>' prior: 0! 50695While every class has an associated metaclass, a trait can have an associated classtrait, an instance of me. To preserve metaclass compatibility, the associated classtrait (if there is one) is automatically applied to the metaclass, whenever a trait is applied to a class. Consequently, a trait with an associated classtrait can only be applied to classes, whereas a trait without a classtrait can be applied to both classes and metaclasses.! 50696 50697 50698!ClassTrait methodsFor: '*monticello' stamp: 'damiencassou 7/30/2009 12:10'! 50699asMCDefinition 50700 ^MCClassTraitDefinition 50701 baseTraitName: self baseTrait name 50702 classTraitComposition: self traitCompositionString 50703 category: self category 50704 ! ! 50705 50706 50707!ClassTrait methodsFor: 'accessing' stamp: 'damiencassou 8/6/2009 11:37'! 50708category 50709 ^ self baseTrait category! ! 50710 50711!ClassTrait methodsFor: 'accessing' stamp: 'al 4/21/2004 09:38'! 50712name 50713 ^self baseTrait name , ' classTrait'! ! 50714 50715 50716!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:38'! 50717baseTrait 50718 ^baseTrait! ! 50719 50720!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:48'! 50721baseTrait: aTrait 50722 self assert: aTrait isBaseTrait. 50723 baseTrait := aTrait 50724 50725 ! ! 50726 50727!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:38'! 50728classTrait 50729 ^self! ! 50730 50731!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 4/20/2004 09:44'! 50732classTrait: aClassTrait 50733 self error: 'Trait is already a class trait!!' 50734 50735 ! ! 50736 50737!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:41'! 50738hasClassTrait 50739 ^false! ! 50740 50741!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:48'! 50742isBaseTrait 50743 ^false! ! 50744 50745!ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:48'! 50746isClassTrait 50747 ^true! ! 50748 50749 50750!ClassTrait methodsFor: 'compiling' stamp: 'al 4/7/2004 14:54'! 50751compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource 50752 50753 | classSideUsersOfBaseTrait message | 50754 classSideUsersOfBaseTrait := self baseTrait users select: [:each | each isClassSide]. 50755 classSideUsersOfBaseTrait isEmpty ifFalse: [ 50756 message := String streamContents: [:stream | 50757 stream nextPutAll: 'The instance side of this trait is used on '; cr. 50758 classSideUsersOfBaseTrait 50759 do: [:each | stream nextPutAll: each name] 50760 separatedBy: [ stream nextPutAll: ', ']. 50761 stream cr; nextPutAll: ' You can not add methods to the class side of this trait!!']. 50762 ^TraitException signal: message]. 50763 50764 ^super 50765 compile: text 50766 classified: category 50767 withStamp: changeStamp 50768 notifying: requestor 50769 logSource: logSource! ! 50770 50771 50772!ClassTrait methodsFor: 'composition'! 50773assertConsistantCompositionsForNew: aTraitComposition 50774 "Applying or modifying a trait composition on the class side 50775 of a behavior has some restrictions." 50776 50777 | baseTraits notAddable message | 50778 baseTraits := aTraitComposition traits select: [:each | each isBaseTrait]. 50779 baseTraits isEmpty ifFalse: [ 50780 notAddable := (baseTraits reject: [:each | each classSide methodDict isEmpty]). 50781 notAddable isEmpty ifFalse: [ 50782 message := String streamContents: [:stream | 50783 stream nextPutAll: 'You can not add the base trait(s)'; cr. 50784 notAddable 50785 do: [:each | stream nextPutAll: each name] 50786 separatedBy: [ stream nextPutAll: ', ']. 50787 stream cr; nextPutAll: 'to this composition because it/they define(s) methods on the class side.']. 50788 ^TraitCompositionException signal: message]]. 50789 50790 (self instanceSide traitComposition traits asSet = 50791 (aTraitComposition traits 50792 select: [:each | each isClassTrait] 50793 thenCollect: [:each | each baseTrait]) asSet) ifFalse: [ 50794 ^TraitCompositionException signal: 'You can not add or remove class side traits on 50795 the class side of a composition. (But you can specify aliases or exclusions 50796 for existing traits or add a trait which does not have any methods on the class side.)']! ! 50797 50798!ClassTrait methodsFor: 'composition'! 50799noteNewBaseTraitCompositionApplied: aTraitComposition 50800 "The argument is the new trait composition of my base trait - add 50801 the new traits or remove non existing traits on my class side composition. 50802 (Each class trait in my composition has its base trait on the instance side 50803 of the composition - manually added traits to the class side are always 50804 base traits.)" 50805 50806 | newComposition traitsFromInstanceSide | 50807 traitsFromInstanceSide := self traitComposition traits 50808 select: [:each | each isClassTrait] 50809 thenCollect: [:each | each baseTrait]. 50810 50811 newComposition := self traitComposition copyTraitExpression. 50812 (traitsFromInstanceSide copyWithoutAll: aTraitComposition traits) do: [:each | 50813 newComposition removeFromComposition: each classTrait]. 50814 (aTraitComposition traits copyWithoutAll: traitsFromInstanceSide) do: [:each | 50815 newComposition add: (each classTrait)]. 50816 50817 self setTraitComposition: newComposition! ! 50818 50819!ClassTrait methodsFor: 'composition' stamp: 'al 7/18/2004 14:02'! 50820uses: aTraitCompositionOrArray 50821 | copyOfOldTrait newComposition | 50822 copyOfOldTrait := self copy. 50823 newComposition := aTraitCompositionOrArray asTraitComposition. 50824 self assertConsistantCompositionsForNew: newComposition. 50825 self setTraitComposition: newComposition. 50826 SystemChangeNotifier uniqueInstance 50827 traitDefinitionChangedFrom: copyOfOldTrait to: self.! ! 50828 50829 50830!ClassTrait methodsFor: 'copying' stamp: 'dvf 8/30/2005 16:51'! 50831copy 50832 "Make a copy of the receiver. Share the 50833 reference to the base trait." 50834 50835 ^(self class new) 50836 baseTrait: self baseTrait; 50837 initializeFrom: self; 50838 yourself! ! 50839 50840 50841!ClassTrait methodsFor: 'filein/out' stamp: 'al 3/26/2006 21:31'! 50842definitionST80 50843 ^String streamContents: [:stream | 50844 stream 50845 nextPutAll: self name; 50846 crtab; 50847 nextPutAll: 'uses: '; 50848 nextPutAll: self traitCompositionString]! ! 50849 50850 50851!ClassTrait methodsFor: 'initialize' stamp: 'al 7/18/2004 12:11'! 50852baseClass: aTrait traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization 50853 50854 self baseTrait: aTrait. 50855 self 50856 traitComposition: aComposition 50857 methodDict: aMethodDict 50858 localSelectors: aSet 50859 organization: aClassOrganization 50860! ! 50861 50862!ClassTrait methodsFor: 'initialize' stamp: 'dvf 8/30/2005 16:48'! 50863initializeFrom: anotherClassTrait 50864 traitComposition := self traitComposition copyTraitExpression. 50865 methodDict := self methodDict copy. 50866 localSelectors := self localSelectors copy. 50867 organization := self organization copy.! ! 50868 50869!ClassTrait methodsFor: 'initialize' stamp: 'al 3/24/2004 20:37'! 50870initializeWithBaseTrait: aTrait 50871 self baseTrait: aTrait. 50872 self noteNewBaseTraitCompositionApplied: aTrait traitComposition. 50873 aTrait users do: [:each | self addUser: each classSide]. 50874 ! ! 50875 50876!ClassTrait methodsFor: 'initialize' stamp: 'al 7/17/2004 22:56'! 50877traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization 50878 50879 "Used by copy of Trait" 50880 50881 localSelectors := aSet. 50882 methodDict := aMethodDict. 50883 traitComposition := aComposition. 50884 self organization: aClassOrganization! ! 50885 50886"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 50887 50888ClassTrait class 50889 uses: TApplyingOnClassSide classTrait 50890 instanceVariableNames: ''! 50891 50892!ClassTrait class methodsFor: 'instance creation' stamp: 'al 3/23/2004 19:41'! 50893for: aTrait 50894 ^self new 50895 initializeWithBaseTrait: aTrait; 50896 yourself! ! 50897TraitsTestCase subclass: #ClassTraitTest 50898 instanceVariableNames: '' 50899 classVariableNames: '' 50900 poolDictionaries: '' 50901 category: 'Tests-Traits'! 50902 50903!ClassTraitTest methodsFor: 'testing' stamp: 'al 3/26/2006 12:15'! 50904testChanges 50905 "Test the most important features to ensure that 50906 general functionality of class traits are working." 50907 50908 "self run: #testChanges" 50909 50910 | classTrait | 50911 classTrait := self t1 classTrait. 50912 classTrait compile: 'm1ClassSide ^17' classified: 'mycategory'. 50913 50914 "local selectors" 50915 self assert: (classTrait includesLocalSelector: #m1ClassSide). 50916 self deny: (classTrait includesLocalSelector: #otherSelector). 50917 50918 "propagation" 50919 self assert: (self t5 classSide methodDict includesKey: #m1ClassSide). 50920 self assert: (self c2 class methodDict includesKey: #m1ClassSide). 50921 self shouldnt: [self c2 m1ClassSide] raise: Error. 50922 self assert: self c2 m1ClassSide = 17. 50923 50924 "category" 50925 self assert: (self c2 class organization categoryOfElement: #m1ClassSide) 50926 = 'mycategory'. 50927 50928 "conflicts" 50929 self t2 classSide compile: 'm1ClassSide' classified: 'mycategory'. 50930 self assert: (self c2 class methodDict includesKey: #m1ClassSide). 50931 self deny: (self c2 class includesLocalSelector: #m1ClassSide). 50932 self should: [self c2 m1ClassSide] raise: Error. 50933 50934 "conflict category" 50935 self assert: (self c2 class organization categoryOfElement: #m1ClassSide) 50936 = #mycategory! ! 50937 50938!ClassTraitTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'! 50939testConflictsAliasesAndExclusions 50940 "conflict" 50941 50942 self t1 classTrait compile: 'm2ClassSide: x ^99' classified: 'mycategory'. 50943 self assert: (self t1 classTrait includesLocalSelector: #m2ClassSide:). 50944 self assert: (self t5 classTrait >> #m2ClassSide:) isConflict. 50945 self assert: (self c2 class >> #m2ClassSide:) isConflict. 50946 50947 "exclusion and alias" 50948 self assert: self t5 classSide traitComposition asString 50949 = 'T1 classTrait + T2 classTrait'. 50950 self t5 classSide 50951 setTraitCompositionFrom: (self t1 classTrait @ { (#m2ClassSideAlias1: -> #m2ClassSide:) } 50952 + self t2 classTrait) @ { (#m2ClassSideAlias2: -> #m2ClassSide:) } 50953 - { #m2ClassSide: }. 50954 self deny: (self t5 classTrait >> #m2ClassSide:) isConflict. 50955 self deny: (self c2 class >> #m2ClassSide:) isConflict. 50956 self assert: (self c2 m2ClassSideAlias1: 13) = 99. 50957 self assert: (self c2 m2ClassSideAlias2: 13) = 13! ! 50958 50959!ClassTraitTest methodsFor: 'testing' stamp: 'dvf 8/30/2005 16:17'! 50960testInitialization 50961 "self run: #testInitialization" 50962 50963 | classTrait | 50964 classTrait := self t1 classTrait. 50965 self assert: self t1 hasClassTrait. 50966 self assert: self t1 classTrait == classTrait. 50967 self assert: classTrait isClassTrait. 50968 self assert: classTrait classSide == classTrait. 50969 self deny: classTrait isBaseTrait. 50970 self assert: classTrait baseTrait == self t1. 50971 50972 "assert classtrait methods are propagated to users when setting traitComposition" 50973 self assert: self t4 hasClassTrait. 50974 self assert: self t5 hasClassTrait. 50975 self assert: (self t2 classSide includesLocalSelector: #m2ClassSide:). 50976 self assert: (self t4 classSide methodDict includesKey: #m2ClassSide:). 50977 self assert: (self t5 classSide methodDict includesKey: #m2ClassSide:). 50978 self assert: (self c2 m2ClassSide: 17) = 17! ! 50979 50980!ClassTraitTest methodsFor: 'testing' stamp: 'al 3/26/2006 12:06'! 50981testUsers 50982 self assert: self t2 classSide users size = 3. 50983 self assert: (self t2 classSide users includesAllOf: { 50984 (self t4 classTrait). 50985 (self t5 classTrait). 50986 (self t6 classTrait) }). 50987 self assert: self t5 classSide users size = 1. 50988 self assert: self t5 classSide users anyOne = self c2 class. 50989 self c2 setTraitCompositionFrom: self t1 + self t5. 50990 self assert: self t5 classSide users size = 1. 50991 self assert: self t5 classSide users anyOne = self c2 class. 50992 self c2 setTraitComposition: self t2 asTraitComposition. 50993 self assert: self t5 classSide users isEmpty! ! 50994Object subclass: #Clipboard 50995 instanceVariableNames: 'contents recent' 50996 classVariableNames: 'Default' 50997 poolDictionaries: '' 50998 category: 'System-Clipboard'! 50999!Clipboard commentStamp: 'michael.rueger 3/2/2009 13:22' prior: 0! 51000The Clipboard class is the abstract superclass for the concrete platform specific clipboard. The legacy clipboard support using the VM supplied primitives was moved to SqueakClipboard. 51001 51002The Clipboard implements a basic buffering scheme for text. The currently selected text is also exported to the OS so that text can be copied from and to other applications. Commonly only a single instance is used (the default clipboard) but applications are free to use other than the default clipboard if necessary.! 51003 51004 51005!Clipboard methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:32'! 51006chooseRecentClipping "Clipboard chooseRecentClipping" 51007 "Choose by menu from among the recent clippings" 51008 51009 recent ifNil: [^ nil]. 51010 ^ (SelectionMenu 51011 labelList: (recent collect: [:txt | ((txt asString contractTo: 50) 51012 copyReplaceAll: Character cr asString with: '\') 51013 copyReplaceAll: Character tab asString with: '|']) 51014 selections: recent) startUp. 51015 51016! ! 51017 51018!Clipboard methodsFor: 'accessing' stamp: 'michael.rueger 6/10/2009 13:42'! 51019clipboardText 51020 "Return the text currently in the clipboard. If the system clipboard is empty, or if it differs from the Smalltalk clipboard text, use the Smalltalk clipboard. This is done since (a) the Mac clipboard gives up on very large chunks of text and (b) since not all platforms support the notion of a clipboard." 51021 51022 | string decodedString | 51023 string := self primitiveClipboardText. 51024 (string isEmpty 51025 or: [string = contents asString]) 51026 ifTrue: [^ contents]. 51027 decodedString := string convertFromWithConverter: UTF8TextConverter new. 51028 decodedString := decodedString replaceAll: 10 asCharacter with: 13 asCharacter. 51029 ^ decodedString = contents asString 51030 ifTrue: [contents] 51031 ifFalse: [decodedString asText]. 51032! ! 51033 51034!Clipboard methodsFor: 'accessing' stamp: 'michael.rueger 3/25/2009 14:23'! 51035clipboardText: text 51036 51037 | string | 51038 string := text asString. 51039 self noteRecentClipping: text asText. 51040 contents := text asText. 51041 string := string convertToWithConverter: UTF8TextConverter new. 51042 self primitiveClipboardText: string. 51043! ! 51044 51045 51046!Clipboard methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:47'! 51047initialize 51048 super initialize. 51049 contents := '' asText. 51050 recent := OrderedCollection new! ! 51051 51052 51053!Clipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/25/2009 14:23'! 51054primitiveClipboardText 51055 "Get the current clipboard text. Return the empty string if the primitive fails." 51056 <primitive: 141> 51057 ^ ''! ! 51058 51059!Clipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/25/2009 14:23'! 51060primitiveClipboardText: aString 51061 "Set the current clipboard text to the given string." 51062 51063 <primitive: 141> 51064 "don't fail if the primitive is not implemented"! ! 51065 51066 51067!Clipboard methodsFor: 'private' stamp: 'ar 1/15/2001 18:34'! 51068noteRecentClipping: text 51069 "Keep most recent clippings in a queue for pasteRecent (paste... command)" 51070 text isEmpty ifTrue: [^ self]. 51071 text size > 50000 ifTrue: [^ self]. 51072 (recent includes: text) ifTrue: [^ self]. 51073 recent addFirst: text. 51074 [recent size > 5] whileTrue: [recent removeLast]. 51075! ! 51076 51077"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 51078 51079Clipboard class 51080 instanceVariableNames: ''! 51081 51082!Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:45'! 51083chooseRecentClipping "Clipboard chooseRecentClipping" 51084 "Choose by menu from among the recent clippings" 51085 ^self default chooseRecentClipping! ! 51086 51087!Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:35'! 51088clipboardText "Clipboard clipboardText" 51089 ^self default clipboardText.! ! 51090 51091!Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:35'! 51092clipboardText: aText 51093 ^self default clipboardText: aText! ! 51094 51095!Clipboard class methodsFor: 'accessing' stamp: 'michael.rueger 3/2/2009 11:12'! 51096default 51097 ^Default ifNil: [Default := OSPlatform current clipboardClass new].! ! 51098 51099 51100!Clipboard class methodsFor: 'initialization' stamp: 'michael.rueger 3/2/2009 11:11'! 51101initialize 51102 "Clipboard initialize" 51103 51104 Smalltalk addToStartUpList: self. 51105 Smalltalk addToShutDownList: self. 51106 self startUp: true.! ! 51107 51108!Clipboard class methodsFor: 'initialization' stamp: 'michael.rueger 3/2/2009 11:11'! 51109shutDown: quitting 51110 "Squeak is shutting down. If this platform requires specific shutdown code, this is a great place to put it." 51111! ! 51112 51113!Clipboard class methodsFor: 'initialization' stamp: 'michael.rueger 3/2/2009 11:12'! 51114startUp: resuming 51115 "Squeak is starting up. If this platform requires specific intialization, this is a great place to put it." 51116 resuming 51117 ifTrue: [Default := nil]! ! 51118PluggableCanvas subclass: #ClippingCanvas 51119 instanceVariableNames: 'canvas clipRect' 51120 classVariableNames: '' 51121 poolDictionaries: '' 51122 category: 'Morphic-Support'! 51123!ClippingCanvas commentStamp: '<historical>' prior: 0! 51124A modified canvas which clips all drawing commands.! 51125 51126 51127!ClippingCanvas methodsFor: 'accessing' stamp: 'ls 3/25/2000 22:56'! 51128clipRect 51129 ^clipRect! ! 51130 51131!ClippingCanvas methodsFor: 'accessing' stamp: 'ls 3/26/2000 14:22'! 51132contentsOfArea: aRectangle into: aForm 51133 self flag: #hack. "ignore the clipping specification for this command. This is purely so that CachingCanvas will work properly when clipped. There *has* to be a clean way to do this...." 51134 ^canvas contentsOfArea: aRectangle into: aForm! ! 51135 51136!ClippingCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:17'! 51137form 51138 ^canvas form! ! 51139 51140!ClippingCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:15'! 51141shadowColor 51142 ^canvas shadowColor! ! 51143 51144 51145!ClippingCanvas methodsFor: 'initialization' stamp: 'ls 3/20/2000 20:44'! 51146canvas: aCanvas clipRect: aRectangle 51147 canvas := aCanvas. 51148 clipRect := aRectangle.! ! 51149 51150 51151!ClippingCanvas methodsFor: 'testing' stamp: 'ls 3/20/2000 21:17'! 51152isBalloonCanvas 51153 ^canvas isBalloonCanvas! ! 51154 51155!ClippingCanvas methodsFor: 'testing' stamp: 'ls 3/20/2000 21:18'! 51156isShadowDrawing 51157 ^canvas isShadowDrawing! ! 51158 51159 51160!ClippingCanvas methodsFor: 'private' stamp: 'ls 3/20/2000 20:44'! 51161apply: aBlock 51162 "apply the given block to the inner canvas with clipRect as the clipping rectangle" 51163 canvas clipBy: clipRect during: aBlock! ! 51164 51165"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 51166 51167ClippingCanvas class 51168 instanceVariableNames: ''! 51169 51170!ClippingCanvas class methodsFor: 'instance creation' stamp: 'ls 3/20/2000 20:45'! 51171canvas: aCanvas clipRect: aRectangle 51172 ^self new canvas: aCanvas clipRect: aRectangle! ! 51173TestCase subclass: #ClosureCompilerTest 51174 instanceVariableNames: '' 51175 classVariableNames: 'CmpRR CogRTLOpcodes Jump MoveCqR Nop' 51176 poolDictionaries: '' 51177 category: 'Tests-Compiler'! 51178 51179!ClosureCompilerTest methodsFor: 'source' stamp: 'eem 7/1/2009 10:51'! 51180closureCases 51181 ^#( 51182'| n | 51183n := 1. 51184^n + n' 51185 51186'| i | 51187i := 0. 51188[i := i + 1. 51189 i <= 10] whileTrue. 51190^i' 51191 51192'[:c :s| | mn | 51193mn := Compiler new 51194 compile: (c sourceCodeAt: s) 51195 in: c 51196 notifying: nil 51197 ifFail: [self halt]. 51198mn generate: #(0 0 0 0). 51199{mn blockExtentsToTempsMap. 51200 mn encoder schematicTempNames}] 51201 value: AbstractInstructionTests 51202 value: #runBinaryConditionalJumps:' 51203 51204'inject: thisValue into: binaryBlock 51205 | nextValue | 51206 nextValue := thisValue. 51207 self do: [:each | nextValue := binaryBlock value: nextValue value: each]. 51208 ^nextValue' 51209 51210'runBinaryConditionalJumps: assertPrintBar 51211 "CogIA32CompilerTests new runBinaryConditionalJumps: false" 51212 | mask reg1 reg2 reg3 | 51213 mask := 1 << self processor bitsInWord - 1. 51214 self concreteCompilerClass dataRegistersWithAccessorsDo: 51215 [:n :get :set| 51216 n = 0 ifTrue: [reg1 := get]. 51217 n = 1 ifTrue: [reg2 := set]. 51218 n = 2 ifTrue: [reg3 := set]]. 51219 #( (JumpAbove > unsigned) (JumpBelowOrEqual <= unsigned) 51220 (JumpBelow < unsigned) (JumpAboveOrEqual >= unsigned) 51221 (JumpGreater > signed) (JumpLessOrEqual <= signed) 51222 (JumpLess < signed) (JumpGreaterOrEqual >= signed) 51223 (JumpZero = signed) (JumpNonZero ~= signed)) do: 51224 [:triple| 51225 [:opName :relation :signednessOrResult| | opcode jumpNotTaken jumpTaken nop memory bogus | 51226 self resetGen. 51227 opcode := CogRTLOpcodes classPool at: opName. 51228 self gen: CmpRR operand: 2 operand: 1. 51229 jumpTaken := self gen: opcode. 51230 self gen: MoveCqR operand: 0 operand: 0. 51231 jumpNotTaken := self gen: Jump. 51232 jumpTaken jmpTarget: (self gen: MoveCqR operand: 1 operand: 0). 51233 jumpNotTaken jmpTarget: (nop := self gen: Nop). 51234 memory := self generateInstructions. 51235 bogus := false. 51236 self pairs: (-2 to: 2) do: 51237 [:a :b| | taken | 51238 self processor 51239 reset; 51240 perform: reg2 with: a signedIntToLong; 51241 perform: reg3 with: b signedIntToLong. 51242 [self processor singleStepIn: memory. 51243 self processor pc ~= nop address] whileTrue. 51244 taken := (self processor perform: reg1) = 1. 51245 assertPrintBar 51246 ifTrue: 51247 [self assert: taken = (signednessOrResult == #unsigned 51248 ifTrue: [(a bitAnd: mask) perform: relation with: (b bitAnd: mask)] 51249 ifFalse: [a perform: relation with: b])] 51250 ifFalse: 51251 [Transcript 51252 nextPutAll: reg2; nextPut: $(; print: a; nextPutAll: '') ''; nextPutAll: relation; space; 51253 nextPutAll: reg3; nextPut: $(; print: b; nextPutAll: '') = ''; 51254 print: taken; cr; flush. 51255 taken = (signednessOrResult == #unsigned 51256 ifTrue: [(a bitAnd: mask) perform: relation with: (b bitAnd: mask)] 51257 ifFalse: [a perform: relation with: b]) ifFalse: 51258 [bogus := true]]]. 51259 bogus ifTrue: 51260 [self processor printRegistersOn: Transcript. 51261 Transcript show: (self processor disassembleInstructionAt: jumpTaken address In: memory); cr]] 51262 valueWithArguments: triple]' 51263 51264'mapFromBlockStartsIn: aMethod toTempVarsFrom: schematicTempNamesString constructor: aDecompilerConstructor 51265 | map | 51266 map := aMethod 51267 mapFromBlockKeys: aMethod startpcsToBlockExtents keys asSortedCollection 51268 toSchematicTemps: schematicTempNamesString. 51269 map keysAndValuesDo: 51270 [:startpc :tempNameTupleVector| | subMap tempVector numTemps | 51271 subMap := Dictionary new. 51272 "Find how many temp slots there are (direct & indirect temp vectors) 51273 and for each indirect temp vector find how big it is." 51274 tempNameTupleVector do: 51275 [:tuple| 51276 tuple last isArray 51277 ifTrue: 51278 [subMap at: tuple last first put: tuple last last. 51279 numTemps := tuple last first] 51280 ifFalse: 51281 [numTemps := tuple last]]. 51282 "create the temp vector for this scope level." 51283 tempVector := Array new: numTemps. 51284 "fill it in with any indirect temp vectors" 51285 subMap keysAndValuesDo: 51286 [:index :size| 51287 tempVector at: index put: (Array new: size)]. 51288 "fill it in with temp nodes." 51289 tempNameTupleVector do: 51290 [:tuple| | itv | 51291 tuple last isArray 51292 ifTrue: 51293 [itv := tempVector at: tuple last first. 51294 itv at: tuple last last 51295 put: (aDecompilerConstructor 51296 codeTemp: tuple last last - 1 51297 named: tuple first)] 51298 ifFalse: 51299 [tempVector 51300 at: tuple last 51301 put: (aDecompilerConstructor 51302 codeTemp: tuple last - 1 51303 named: tuple first)]]. 51304 "replace any indirect temp vectors with proper RemoteTempVectorNodes" 51305 subMap keysAndValuesDo: 51306 [:index :size| 51307 tempVector 51308 at: index 51309 put: (aDecompilerConstructor 51310 codeRemoteTemp: index 51311 remoteTemps: (tempVector at: index))]. 51312 "and update the entry in the map" 51313 map at: startpc put: tempVector]. 51314 ^map' 51315 51316 'gnuifyFrom: inFileStream to: outFileStream 51317 51318"convert interp.c to use GNU features" 51319 51320 | inData beforeInterpret inInterpret inInterpretVars beforePrimitiveResponse inPrimitiveResponse | 51321 51322 inData := inFileStream upToEnd withSqueakLineEndings. 51323 inFileStream close. 51324 51325 "print a header" 51326 outFileStream 51327 nextPutAll: ''/* This file has been post-processed for GNU C */''; 51328 cr; cr; cr. 51329 51330 beforeInterpret := true. "whether we are before the beginning of interpret()" 51331 inInterpret := false. "whether we are in the middle of interpret" 51332 inInterpretVars := false. "whether we are in the variables of interpret" 51333 beforePrimitiveResponse := true. "whether we are before the beginning of primitiveResponse()" 51334 inPrimitiveResponse := false. "whether we are inside of primitiveResponse" 51335 ''Gnuifying'' 51336 displayProgressAt: Sensor cursorPoint 51337 from: 1 to: (inData occurrencesOf: Character cr) 51338 during: 51339 [:bar | | lineNumber | 51340 lineNumber := 0. 51341 inData linesDo: 51342 [ :inLine | | outLine extraOutLine caseLabel | 51343 bar value: (lineNumber := lineNumber + 1). 51344 outLine := inLine. "print out one line for each input line; by default, print out the line that was input, but some rules modify it" 51345 extraOutLine := nil. "occasionally print a second output line..." 51346 beforeInterpret ifTrue: [ 51347 inLine = ''#include "sq.h"'' ifTrue: [ 51348 outLine := ''#include "sqGnu.h"'' ]. 51349 inLine = ''interpret(void) {'' ifTrue: [ 51350 "reached the beginning of interpret" 51351 beforeInterpret := false. 51352 inInterpret := true. 51353 inInterpretVars := true ] ] 51354 ifFalse: [ 51355 inInterpretVars ifTrue: [ 51356 (inLine findString: ''register struct foo * foo = &fum;'') > 0 ifTrue: [ 51357 outLine := ''register struct foo * foo FOO_REG = &fum;'' ]. 51358 (inLine findString: '' localIP;'') > 0 ifTrue: [ 51359 outLine := '' char* localIP IP_REG;'' ]. 51360 (inLine findString: '' localFP;'') > 0 ifTrue: [ 51361 outLine := '' char* localFP FP_REG;'' ]. 51362 (inLine findString: '' localSP;'') > 0 ifTrue: [ 51363 outLine := '' char* localSP SP_REG;'' ]. 51364 (inLine findString: '' currentBytecode;'') > 0 ifTrue: [ 51365 outLine := '' sqInt currentBytecode CB_REG;'' ]. 51366 inLine isEmpty ifTrue: [ 51367 "reached end of variables" 51368 inInterpretVars := false. 51369 outLine := '' JUMP_TABLE;''. 51370 extraOutLine := inLine ] ] 51371 ifFalse: [ 51372 inInterpret ifTrue: [ 51373 "working inside interpret(); translate the switch statement" 51374 (inLine beginsWith: '' case '') ifTrue: [ 51375 caseLabel := (inLine findTokens: '' :'') second. 51376 outLine := '' CASE('', caseLabel, '')'' ]. 51377 inLine = '' break;'' ifTrue: [ 51378 outLine := '' BREAK;'' ]. 51379 inLine = ''}'' ifTrue: [ 51380 "all finished with interpret()" 51381 inInterpret := false ] ] 51382 ifFalse: [ 51383 beforePrimitiveResponse ifTrue: [ 51384 (inLine beginsWith: ''primitiveResponse('') ifTrue: [ 51385 "into primitiveResponse we go" 51386 beforePrimitiveResponse := false. 51387 inPrimitiveResponse := true. 51388 extraOutLine := '' PRIM_TABLE;'' ] ] 51389 ifFalse: [ 51390 inPrimitiveResponse ifTrue: [ 51391 inLine = '' switch (primitiveIndex) {'' ifTrue: [ 51392 extraOutLine := outLine. 51393 outLine := '' PRIM_DISPATCH;'' ]. 51394 inLine = '' switch (GIV(primitiveIndex)) {'' ifTrue: [ 51395 extraOutLine := outLine. 51396 outLine := '' PRIM_DISPATCH;'' ]. 51397 (inLine beginsWith: '' case '') ifTrue: [ 51398 caseLabel := (inLine findTokens: '' :'') second. 51399 outLine := '' CASE('', caseLabel, '')'' ]. 51400 inLine = ''}'' ifTrue: [ 51401 inPrimitiveResponse := false ] ] 51402 ] ] ] ]. 51403 51404 outFileStream nextPutAll: outLine; cr. 51405 extraOutLine ifNotNil: [ 51406 outFileStream nextPutAll: extraOutLine; cr ]]]. 51407 51408 outFileStream close' )! ! 51409 51410 51411!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/24/2008 12:28'! 51412doTestDebuggerTempAccessWith: one with: two 51413 "Test debugger access for temps" 51414 | outerContext local1 remote1 | 51415 outerContext := thisContext. 51416 local1 := 3. 51417 remote1 := 1/2. 51418 self assert: (Compiler new evaluate: 'one' in: thisContext to: self) == one. 51419 self assert: (Compiler new evaluate: 'two' in: thisContext to: self) == two. 51420 self assert: (Compiler new evaluate: 'local1' in: thisContext to: self) == local1. 51421 self assert: (Compiler new evaluate: 'remote1' in: thisContext to: self) == remote1. 51422 Compiler new evaluate: 'local1 := -3.0' in: thisContext to: self. 51423 self assert: local1 = -3.0. 51424 (1 to: 2) do: 51425 [:i| | local2 r1 r2 r3 r4 | 51426 local2 := i * 3. 51427 remote1 := local2 / 7. 51428 self assert: thisContext ~~ outerContext. 51429 self assert: (r1 := Compiler new evaluate: 'one' in: thisContext to: self) == one. 51430 self assert: (r2 := Compiler new evaluate: 'two' in: thisContext to: self) == two. 51431 self assert: (r3 := Compiler new evaluate: 'i' in: thisContext to: self) == i. 51432 self assert: (r4 := Compiler new evaluate: 'local2' in: thisContext to: self) == local2. 51433 self assert: (r4 := Compiler new evaluate: 'remote1' in: thisContext to: self) == remote1. 51434 self assert: (r4 := Compiler new evaluate: 'remote1' in: outerContext to: self) == remote1. 51435 Compiler new evaluate: 'local2 := 15' in: thisContext to: self. 51436 self assert: local2 = 15. 51437 Compiler new evaluate: 'local1 := 25' in: thisContext to: self. 51438 self assert: local1 = 25. 51439 { r1. r2. r3. r4 } "placate the compiler"]. 51440 self assert: local1 = 25. 51441 self assert: remote1 = (6/7)! ! 51442 51443!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/4/2008 16:58'! 51444supportTestSourceRangeAccessForDecompiledInjectInto: method source: source 51445 "Test debugger source range selection for inject:into:" 51446 ^self 51447 supportTestSourceRangeAccessForInjectInto: method 51448 source: source 51449 selectionSequence: #( ':= t1' 51450 'do: [:t4 | t3 := t2 value: t3 value: t4]' 51451 'value: t3 value: t4' 51452 ':= t2 value: t3 value: t4' 51453 ']' 51454 'value: t3 value: t4' 51455 ':= t2 value: t3 value: t4' 51456 ']' 51457 '^t3')! ! 51458 51459!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/4/2008 19:44'! 51460supportTestSourceRangeAccessForDecompiledNoBytecodeInjectInto: method source: source 51461 "Test debugger source range selection for inject:into:" 51462 ^self 51463 supportTestSourceRangeAccessForInjectInto: method 51464 source: source 51465 selectionSequence: #( 'at: 1 put: t1' 51466 'do: [:t4 | t3 at: 1 put: (t2 value: (t3 at: 1) value: t4)]' 51467 'value: (t3 at: 1) value: t4' 51468 'at: 1 put: (t2 value: (t3 at: 1) value: t4)' 51469 ']' 51470 'value: (t3 at: 1) value: t4' 51471 'at: 1 put: (t2 value: (t3 at: 1) value: t4)' 51472 ']' 51473 '^t3 at: 1')! ! 51474 51475!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 7/24/2009 20:53'! 51476supportTestSourceRangeAccessForInjectInto: method source: source 51477 "Test debugger source range selection for inject:into:" 51478 ^self 51479 supportTestSourceRangeAccessForInjectInto: method 51480 source: source 51481 selectionSequence: #( ':= thisValue' 51482 'do: [:each | nextValue := binaryBlock value: nextValue value: each]' 51483 'value: nextValue value: each' 51484 ':= binaryBlock value: nextValue value: each' 51485 'nextValue := binaryBlock value: nextValue value: each' 51486 'value: nextValue value: each' 51487 ':= binaryBlock value: nextValue value: each' 51488 'nextValue := binaryBlock value: nextValue value: each' 51489 '^nextValue')! ! 51490 51491!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 7/29/2008 17:16'! 51492supportTestSourceRangeAccessForInjectInto: method source: source selectionSequence: selections 51493 "Test debugger source range selection for inject:into:" 51494 | evaluationCount sourceMap debugTokenSequence debugCount | 51495 DebuggerMethodMap voidMapCache. 51496 evaluationCount := 0. 51497 sourceMap := method debuggerMap abstractSourceMap. 51498 debugTokenSequence := selections collect: [:string| Scanner new scanTokens: string]. 51499 debugCount := 0. 51500 thisContext 51501 runSimulated: [(1 to: 2) 51502 withArgs: 51503 { 0. 51504 [:sum :each| 51505 evaluationCount := evaluationCount + 1. 51506 sum + each]} 51507 executeMethod: method] 51508 contextAtEachStep: 51509 [:ctxt| | range debugTokens | 51510 (ctxt method == method 51511 and: ["Exclude the send of #blockCopy: or #closureCopy:copiedValues: and braceWith:with: 51512 to create the block, and the #new: and #at:'s for the indirect temp vector. 51513 This for compilation without closure bytecodes. (Note that at:put:'s correspond to stores)" 51514 (ctxt willSend 51515 and: [(#(closureCopy:copiedValues: blockCopy: new: at: braceWith:with:) includes: ctxt selectorToSendOrSelf) not]) 51516 "Exclude the store of the argument into the home context (for BlueBook blocks) 51517 and the store of an indirection vector into an initial temp" 51518 or: [(ctxt willStore 51519 and: [(ctxt isBlock and: [ctxt pc = ctxt startpc]) not 51520 and: [(ctxt isBlock not 51521 and: [(method usesClosureBytecodes and: [ctxt abstractPC = 2])]) not]]) 51522 or: [ctxt willReturn]]]) ifTrue: 51523 [debugTokens := debugTokenSequence at: (debugCount := debugCount + 1) ifAbsent: [#(bogusToken)]. 51524 self assert: (sourceMap includesKey: ctxt abstractPC). 51525 range := sourceMap at: ctxt abstractPC ifAbsent: [(1 to: 0)]. 51526 self assert: (Scanner new scanTokens: (source copyFrom: range first to: range last)) = debugTokens]]. 51527 self assert: evaluationCount = 2! ! 51528 51529!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/5/2009 17:11'! 51530testBlockNumbering 51531 "Test that the compiler and CompiledMethod agree on the block numbering of a substantial doit." 51532 "self new testBlockNumbering" 51533 | methodNode method tempRefs | 51534 methodNode := 51535 Parser new 51536 encoderClass: EncoderForV3PlusClosures; 51537 parse: 'foo 51538 | numCopiedValuesCounts | 51539 numCopiedValuesCounts := Dictionary new. 51540 0 to: 32 do: [:i| numCopiedValuesCounts at: i put: 0]. 51541 Transcript clear. 51542 Smalltalk allClasses remove: GeniePlugin; do: 51543 [:c| 51544 {c. c class} do: 51545 [:b| 51546 Transcript nextPut: b name first; endEntry. 51547 b selectorsAndMethodsDo: 51548 [:s :m| | pn | 51549 m isQuick not ifTrue: 51550 [pn := b parserClass new 51551 encoderClass: EncoderForV3PlusClosures; 51552 parse: (b sourceCodeAt: s) 51553 class: b. 51554 pn generate: #(0 0 0 0). 51555 [pn accept: nil] 51556 on: MessageNotUnderstood 51557 do: [:ex| | msg numCopied | 51558 msg := ex message. 51559 (msg selector == #visitBlockNode: 51560 and: [(msg argument instVarNamed: ''optimized'') not]) ifTrue: 51561 [numCopied := (msg argument computeCopiedValues: pn) size. 51562 numCopiedValuesCounts 51563 at: numCopied 51564 put: (numCopiedValuesCounts at: numCopied) + 1]. 51565 msg setSelector: #==. 51566 ex resume: nil]]]]]. 51567 numCopiedValuesCounts' 51568 class: Object. 51569 method := methodNode generate: #(0 0 0 0). 51570 tempRefs := methodNode encoder blockExtentsToTempsMap. 51571 self assert: tempRefs keys = method startpcsToBlockExtents values asSet! ! 51572 51573!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/5/2009 17:13'! 51574testBlockNumberingForInjectInto 51575 "Test that the compiler and CompiledMethod agree on the block numbering of Collection>>inject:into: 51576 and that temp names for inject:into: are recorded." 51577 "self new testBlockNumberingForInjectInto" 51578 | methodNode method tempRefs | 51579 methodNode := Parser new 51580 encoderClass: EncoderForV3PlusClosures; 51581 parse: (Collection sourceCodeAt: #inject:into:) 51582 class: Collection. 51583 method := methodNode generate: #(0 0 0 0). 51584 tempRefs := methodNode encoder blockExtentsToTempsMap. 51585 self assert: tempRefs keys = method startpcsToBlockExtents values asSet. 51586 self assert: ((tempRefs includesKey: (0 to: 6)) 51587 and: [(tempRefs at: (0 to: 6)) hasEqualElements: #(('thisValue' 1) ('binaryBlock' 2) ('nextValue' (3 1)))]). 51588 self assert: ((tempRefs includesKey: (2 to: 4)) 51589 and: [(tempRefs at: (2 to: 4)) hasEqualElements: #(('each' 1) ('binaryBlock' 2) ('nextValue' (3 1)))])! ! 51590 51591!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/24/2008 11:03'! 51592testDebuggerTempAccess 51593 self doTestDebuggerTempAccessWith: 1 with: 2! ! 51594 51595!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 7/24/2009 21:12'! 51596testDecompiledDoitMethodTempNames 51597 "self new testDecompiledDoitMethodTempNames" 51598 "Test that a decompiled doit that has been copied with temps decompiles to the input" 51599 | removeComments | 51600 removeComments := [:n| n comment: nil]. 51601 self closureCases do: 51602 [:source| | mns m mps mnps | 51603 "Need to compare an ungenerated tree with the generated method's methodNode 51604 because generating code alters the tree when it introduces remote temp vectors." 51605 mns := #(first last) collect: 51606 [:ignored| 51607 source first isLetter 51608 ifTrue: 51609 [self class compilerClass new 51610 compile: source 51611 in: self class 51612 notifying: nil 51613 ifFail: [self error: 'compilation error']] 51614 ifFalse: 51615 [self class compilerClass new 51616 compileNoPattern: source 51617 in: self class 51618 context: nil 51619 notifying: nil 51620 ifFail: [self error: 'compilation error']]]. 51621 m := (mns last generate: #(0 0 0 0)) copyWithTempsFromMethodNode: mns last. 51622 removeComments value: mns first. 51623 mns first nodesDo: removeComments. 51624 self assert: (mnps := mns first printString) = (mps := m methodNode printString)]! ! 51625 51626!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/4/2008 16:57'! 51627testInjectIntoDecompilations 51628 "Test various compilations decompile to the same code for a method sufficiently 51629 simple that this is possible and sufficiently complex that the code generated 51630 varies between the compilations." 51631 "self new testInjectIntoDecompilations" 51632 | source | 51633 source := (Collection sourceCodeAt: #inject:into:) asString. 51634 { Encoder. 51635 EncoderForV3. EncoderForLongFormV3. 51636 EncoderForV3PlusClosures. EncoderForLongFormV3PlusClosures } do: 51637 [:encoderClass| | method | 51638 method := (Parser new 51639 encoderClass: encoderClass; 51640 parse: source 51641 class: Collection) 51642 generate: #(0 0 0 0). 51643 self assert: (Scanner new scanTokens: method decompileString) 51644 = #(inject: t1 into: t2 51645 | t3 | 51646 t3 ':=' t1 . 51647 self do: [ ':t4' | t3 ':=' t2 value: t3 value: t4 ] . 51648 ^ t3)]! ! 51649 51650!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 7/29/2008 17:17'! 51651testInjectIntoDecompiledDebugs 51652 "Test various debugs of the decompiled form debug correctly." 51653 "self new testInjectIntoDecompiledDebugs" 51654 | source | 51655 source := (Collection sourceCodeAt: #inject:into:) asString. 51656 { Encoder. 51657 EncoderForV3PlusClosures. EncoderForLongFormV3PlusClosures } do: 51658 [:encoderClass| | method | 51659 method := (Parser new 51660 encoderClass: encoderClass; 51661 parse: source 51662 class: Collection) 51663 generate: #(0 0 0 0). 51664 self supportTestSourceRangeAccessForDecompiledInjectInto: method source: method decompileString]! ! 51665 51666!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 7/24/2009 11:51'! 51667testInlineBlockCollectionEM1 51668 | a1 b1 i1 a2 b2 i2 we wb | 51669 b1 := OrderedCollection new. 51670 i1 := 1. 51671 [a1 := i1. 51672 i1 <= 3] whileTrue: 51673 [b1 add: [a1]. 51674 i1 := i1 + 1]. 51675 b1 := b1 asArray collect: [:b | b value]. 51676 b2 := OrderedCollection new. 51677 i2 := 1. 51678 we := [a2 := i2. i2 <= 3]. 51679 wb := [b2 add: [a2]. i2 := i2 + 1]. 51680 we whileTrue: wb. "defeat optimization" 51681 b2 := b2 asArray collect: [:b | b value]. 51682 self assert: b1 = b2! ! 51683 51684!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 3/7/2009 11:25'! 51685testInlineBlockCollectionLR1 51686 "Test case from Lukas Renggli" 51687 | col | 51688 col := OrderedCollection new. 51689 1 to: 11 do: [ :each | col add: [ each ] ]. 51690 self assert: (col collect: [ :each | each value ]) asArray = (1 to: 11) asArray! ! 51691 51692!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 3/7/2009 11:39'! 51693testInlineBlockCollectionLR2 51694 "Test case from Lukas Renggli" 51695 | col | 51696 col := OrderedCollection new. 51697 1 to: 11 do: [ :each | #(1) do: [:ignored| col add: [ each ]] ]. 51698 self assert: (col collect: [ :each | each value ]) asArray = (1 to: 11) asArray! ! 51699 51700!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 3/9/2009 11:00'! 51701testInlineBlockCollectionLR3 51702 | col | 51703 col := OrderedCollection new. 51704 1 to: 11 do: [ :each | | i | i := each. col add: [ i ]. i := i + 1 ]. 51705 self assert: (col collect: [ :each | each value ]) asArray = (2 to: 12) asArray! ! 51706 51707!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 7/22/2009 16:55'! 51708testInlineBlockCollectionSD1 51709 | a1 b1 a2 b2 | 51710 b1 := OrderedCollection new. 51711 1 to: 3 do: 51712 [:i | 51713 a1 := i. 51714 b1 add: [a1]]. 51715 b1 := b1 asArray collect: [:b | b value]. 51716 b2 := OrderedCollection new. 51717 1 to: 3 do: 51718 [:i | 51719 a2 := i. 51720 b2 add: [a2]] yourself. "defeat optimization" 51721 b2 := b2 asArray collect: [:b | b value]. 51722 self assert: b1 = b2! ! 51723 51724!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/30/2009 12:15'! 51725testMethodAndNodeTempNames 51726 "self new testMethodAndNodeTempNames" 51727 "Test that BytecodeAgnosticMethodNode>>blockExtentsToTempRefs answers the same 51728 structure as CompiledMethod>>blockExtentsToTempRefs when the method has been 51729 copied with the appropriate temps. This tests whether doit methods are debuggable 51730 since they carry their own temps." 51731 self closureCases do: 51732 [:source| | mn om m mbe obe | 51733 mn := source first isLetter 51734 ifTrue: 51735 [self class compilerClass new 51736 compile: source 51737 in: self class 51738 notifying: nil 51739 ifFail: [self error: 'compilation error']] 51740 ifFalse: 51741 [self class compilerClass new 51742 compileNoPattern: source 51743 in: self class 51744 context: nil 51745 notifying: nil 51746 ifFail: [self error: 'compilation error']]. 51747 m := (om := mn generate: #(0 0 0 0)) copyWithTempsFromMethodNode: mn. 51748 self assert: m holdsTempNames. 51749 self assert: m endPC = om endPC. 51750 mbe := m blockExtentsToTempsMap. 51751 obe := mn blockExtentsToTempsMap. 51752 self assert: mbe keys = obe keys. 51753 (mbe keys intersection: obe keys) do: 51754 [:interval| 51755 self assert: (mbe at: interval) = (obe at: interval)]]! ! 51756 51757!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/4/2008 15:20'! 51758testSourceRangeAccessForBlueBookInjectInto 51759 "Test debugger source range selection for inject:into: for a version compiled with closures" 51760 "self new testSourceRangeAccessForBlueBookInjectInto" 51761 | source method | 51762 source := (Collection sourceCodeAt: #inject:into:) asString. 51763 method := (Parser new 51764 encoderClass: EncoderForV3; 51765 parse: source 51766 class: Collection) 51767 generate: (Collection compiledMethodAt: #inject:into:) trailer. 51768 self supportTestSourceRangeAccessForInjectInto: method source: source! ! 51769 51770!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/4/2008 15:20'! 51771testSourceRangeAccessForBlueBookLongFormInjectInto 51772 "Test debugger source range selection for inject:into: for a version compiled with closures" 51773 "self new testSourceRangeAccessForBlueBookLongFormInjectInto" 51774 | source method | 51775 source := (Collection sourceCodeAt: #inject:into:) asString. 51776 method := (Parser new 51777 encoderClass: EncoderForLongFormV3; 51778 parse: source 51779 class: Collection) 51780 generate: (Collection compiledMethodAt: #inject:into:) trailer. 51781 self supportTestSourceRangeAccessForInjectInto: method source: source! ! 51782 51783!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/4/2008 15:20'! 51784testSourceRangeAccessForClosureBytecodeInjectInto 51785 "Test debugger source range selection for inject:into: for a version compiled with closures" 51786 "self new testSourceRangeAccessForClosureBytecodeInjectInto" 51787 | source method | 51788 source := (Collection sourceCodeAt: #inject:into:) asString. 51789 method := (Parser new 51790 encoderClass: EncoderForV3PlusClosures; 51791 parse: source 51792 class: Collection) 51793 generate: (Collection compiledMethodAt: #inject:into:) trailer. 51794 self supportTestSourceRangeAccessForInjectInto: method source: source! ! 51795 51796!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/4/2008 15:20'! 51797testSourceRangeAccessForClosureLongFormBytecodeInjectInto 51798 "Test debugger source range selection for inject:into: for a version compiled with closures" 51799 "self new testSourceRangeAccessForClosureLongFormBytecodeInjectInto" 51800 | source method | 51801 source := (Collection sourceCodeAt: #inject:into:) asString. 51802 method := (Parser new 51803 encoderClass: EncoderForLongFormV3PlusClosures; 51804 parse: source 51805 class: Collection) 51806 generate: (Collection compiledMethodAt: #inject:into:) trailer. 51807 self supportTestSourceRangeAccessForInjectInto: method source: source! ! 51808 51809!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/4/2008 11:40'! 51810testSourceRangeAccessForInjectInto 51811 "Test debugger source range selection for inject:into: for the current version of the method" 51812 "self new testSourceRangeAccessForInjectInto" 51813 self supportTestSourceRangeAccessForInjectInto: (Collection compiledMethodAt: #inject:into:) 51814 source: (Collection sourceCodeAt: #inject:into:) asString! ! 51815 51816!ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/15/2008 11:26'! 51817testTempNameAccessForInjectInto 51818 "self new testTempNameAccessForInjectInto" 51819 | methodNode method evaluationCount block debuggerMap | 51820 methodNode := Parser new 51821 encoderClass: EncoderForV3PlusClosures; 51822 parse: (Collection sourceCodeAt: #inject:into:) 51823 class: Collection. 51824 method := methodNode generate: #(0 0 0 0). 51825 debuggerMap := DebuggerMethodMap forMethod: method methodNode: methodNode. 51826 evaluationCount := 0. 51827 block := [:prev :each| | theContext tempNames | 51828 evaluationCount := evaluationCount + 1. 51829 theContext := thisContext sender. 51830 tempNames := debuggerMap tempNamesForContext: theContext. 51831 self assert: (tempNames hasEqualElements: tempNames). 51832 #('thisValue' 'each' 'binaryBlock' 'nextValue') 51833 with: { 0. each. block. prev} 51834 do: [:tempName :value| 51835 self assert: (debuggerMap namedTempAt: (tempNames indexOf: tempName) in: theContext) == value. 51836 tempName ~= 'each' ifTrue: 51837 [self assert: (debuggerMap namedTempAt: (tempNames indexOf: tempName) in: theContext home) == value]]]. 51838 (1 to: 10) withArgs: { 0. block } executeMethod: method. 51839 self assert: evaluationCount = 10! ! 51840 51841 51842!ClosureCompilerTest methodsFor: 'testing' stamp: 'AdrianLienhard 10/19/2009 09:31'! 51843expectedFailures 51844 "The problem in the tests #testDebuggerTempAccess is that a compiler evaluate 51845 message is sent and this prevents the proper temp analysis of the closure compiler" 51846 51847 ^#(testDebuggerTempAccess testInjectIntoDecompilations testInjectIntoDecompiledDebugs)! ! 51848 51849"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 51850 51851ClosureCompilerTest class 51852 instanceVariableNames: ''! 51853 51854!ClosureCompilerTest class methodsFor: 'code examples' stamp: 'eem 5/20/2008 09:40'! 51855methodWithCopiedAndAssignedTemps 51856 | blk "0w" a "0w" b "0w" c "0w" t "0w" r1 "0w" r2 "0w" | 51857 a := 1. "1w" 51858 b := 2. "1w" 51859 c := 4. "1w" 51860 t := 0. "1w" 51861 blk "5w" := ["2" t "3w" := t "3r" + a "3r" + b "3r" + c "3r" ] "4". 51862 r1 "5w" := blk "5r" value. 51863 b "5w" := -100. 51864 r2 "5w" := blk "5r" value. 51865 ^r1 "5r" -> r2 "5r" -> t "5r" 51866 51867 "a: main(read(),write(0,1)), block(read(3),write()) => copy; no writes follow read 51868 b: main(read(),write(0,1,5)), block(read(3),write()) => remote; write follows contained read 51869 blk: main(read(5),write(0,5)), block(read(),write()) => no copy in blocks < 5 51870 c: main(read(),write(0,1)), block(read(3),write()) => copy; no writes follow read 51871 r1: main(read(5),write(0,5)), block(read(),write()) => no copy in blocks < 5 51872 r2: main(read(5),write(0,5)), block(read(),write()) => no copy in blocks < 5 51873 t: main(read(5),write(0,1)), block(read(3),write(3)) => remote; read follows contained write" 51874 51875 51876 "(Parser new 51877 encoderClass: EncoderForV3; 51878 parse: (self class sourceCodeAt: #methodWithCopiedAndAssignedTemps) 51879 class: self class) generateUsingClosures: #(0 0 0 0)"! ! 51880 51881!ClosureCompilerTest class methodsFor: 'code examples' stamp: 'eem 5/19/2008 20:45'! 51882methodWithCopiedAndPostClosedOverAssignedTemps 51883 | blk a b c r1 r2 | 51884 a := 1. 51885 b := 2. 51886 c := 4. 51887 blk := [a + b + c]. 51888 r1 := blk value. 51889 b := nil. 51890 r2 := blk value. 51891 r1 -> r2 51892 51893 "(Parser new 51894 encoderClass: EncoderForV3; 51895 parse: (self class sourceCodeAt: #methodWithCopiedAndPostClosedOverAssignedTemps) 51896 class: self class) generateUsingClosures: #(0 0 0 0)"! ! 51897 51898!ClosureCompilerTest class methodsFor: 'code examples' stamp: 'eem 5/19/2008 20:10'! 51899methodWithCopiedTemps 51900 | a b c r | 51901 a := 1. 51902 b := 2. 51903 c := 4. 51904 r := [a + b + c] value. 51905 b := nil. 51906 r 51907 51908 "Parser new 51909 parse: (self class sourceCodeAt: #methodWithCopiedTemps) 51910 class: self class" 51911 51912 "(Parser new 51913 encoderClass: EncoderForV3; 51914 parse: (self class sourceCodeAt: #methodWithCopiedTemps) 51915 class: self class) generateUsingClosures: #(0 0 0 0)"! ! 51916 51917!ClosureCompilerTest class methodsFor: 'code examples' stamp: 'eem 5/19/2008 14:24'! 51918methodWithOptimizedBlocks 51919 | s c | 51920 s := self isNil 51921 ifTrue: [| a | a := 'isNil'. a] 51922 ifFalse: [| b | b := 'notNil'. b]. 51923 c := String new: s size. 51924 1 to: s size do: 51925 [:i| c at: i put: (s at: i)]. 51926 ^c 51927 51928 "Parser new 51929 parse: (self class sourceCodeAt: #methodWithOptimizedBlocks) 51930 class: self class"! ! 51931 51932!ClosureCompilerTest class methodsFor: 'code examples' stamp: 'eem 5/19/2008 14:24'! 51933methodWithOptimizedBlocksA 51934 | s c | 51935 s := self isNil 51936 ifTrue: [| a | a := 'isNil'. a] 51937 ifFalse: [| a | a := 'notNil'. a]. 51938 c := String new: s size. 51939 1 to: s size do: 51940 [:i| c at: i put: (s at: i)]. 51941 ^c 51942 51943 "Parser new 51944 parse: (self class sourceCodeAt: #methodWithOptimizedBlocksA) 51945 class: self class"! ! 51946 51947!ClosureCompilerTest class methodsFor: 'code examples' stamp: 'eem 5/19/2008 14:12'! 51948methodWithVariousTemps 51949 | classes total totalLength | 51950 classes := self withAllSuperclasses. 51951 total := totalLength := 0. 51952 classes do: [:class| | className | 51953 className := class name. 51954 total := total + 1. 51955 totalLength := totalLength + className size]. 51956 ^total -> totalLength 51957 51958 "Parser new 51959 parse: (self class sourceCodeAt: #methodWithVariousTemps) 51960 class: self class"! ! 51961TestCase subclass: #ClosureTests 51962 instanceVariableNames: 'collection' 51963 classVariableNames: '' 51964 poolDictionaries: '' 51965 category: 'Tests-Compiler'! 51966 51967!ClosureTests methodsFor: 'utilities' stamp: 'lr 3/9/2009 16:48'! 51968assertValues: anArray 51969 | values | 51970 values := collection collect: [ :each | each value ]. 51971 self 51972 assert: anArray asArray = values asArray 51973 description: 'Expected: ' , anArray asArray printString , 51974 ', but got ' , values asArray printString! ! 51975 51976 51977!ClosureTests methodsFor: 'running' stamp: 'lr 3/9/2009 16:48'! 51978setUp 51979 super setUp. 51980 collection := OrderedCollection new! ! 51981 51982 51983!ClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:35'! 51984methodArgument: anObject 51985 ^ [ anObject ] 51986 ! ! 51987 51988!ClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:33'! 51989testBlockArgument 51990 | block block1 block2 | 51991 block := [ :arg | | temp | temp := arg. [ temp ] ]. 51992 block1 := block value: 1. 51993 block2 := block value: 2. 51994 self assert: block1 value = 1. 51995 self assert: block2 value = 2! ! 51996 51997!ClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:33'! 51998testBlockTemp 51999 | block block1 block2 | 52000 block := [ :arg | [ arg ] ]. 52001 block1 := block value: 1. 52002 block2 := block value: 2. 52003 self assert: block1 value = 1. 52004 self assert: block2 value = 2! ! 52005 52006!ClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:36'! 52007testMethodArgument 52008 | temp block | 52009 temp := 0. 52010 block := [ [ temp ] ]. 52011 temp := 1. 52012 block := block value. 52013 temp := 2. 52014 self assert: block value = 2! ! 52015 52016!ClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:36'! 52017testMethodTemp 52018 | block1 block2 | 52019 block1 := self methodArgument: 1. 52020 block2 := self methodArgument: 2. 52021 self assert: block1 value = 1. 52022 self assert: block2 value = 2! ! 52023 52024 52025!ClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! 52026testToDoArgument 52027 1 to: 5 do: [ :index | 52028 collection add: [ index ] ]. 52029 self assertValues: #(1 2 3 4 5)! ! 52030 52031!ClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! 52032testToDoArgumentNotInlined 52033 | block | 52034 block := [ :index | 52035 collection add: [ index ] ]. 52036 1 to: 5 do: block. 52037 self assertValues: #(1 2 3 4 5)! ! 52038 52039!ClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! 52040testToDoInsideTemp 52041 1 to: 5 do: [ :index | 52042 | temp | 52043 temp := index. 52044 collection add: [ temp ] ]. 52045 self assertValues: #(1 2 3 4 5)! ! 52046 52047!ClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! 52048testToDoInsideTempNotInlined 52049 | block | 52050 block := [ :index | 52051 | temp | 52052 temp := index. 52053 collection add: [ temp ] ]. 52054 1 to: 5 do: block. 52055 self assertValues: #(1 2 3 4 5)! ! 52056 52057!ClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! 52058testToDoOutsideTemp 52059 | temp | 52060 1 to: 5 do: [ :index | 52061 temp := index. 52062 collection add: [ temp ] ]. 52063 self assertValues: #(5 5 5 5 5)! ! 52064 52065!ClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! 52066testToDoOutsideTempNotInlined 52067 | block temp | 52068 block := [ :index | 52069 temp := index. 52070 collection add: [ temp ] ]. 52071 1 to: 5 do: block. 52072 self assertValues: #(5 5 5 5 5)! ! 52073 52074 52075!ClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:29'! 52076testWhileModificationAfter 52077 | index | 52078 index := 0. 52079 [ index < 5 ] whileTrue: [ 52080 collection add: [ index ]. 52081 index := index + 1 ]. 52082 self assertValues: #(5 5 5 5 5)! ! 52083 52084!ClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:29'! 52085testWhileModificationAfterNotInlined 52086 | index block | 52087 index := 0. 52088 block := [ 52089 collection add: [ index ]. 52090 index := index + 1 ]. 52091 [ index < 5 ] whileTrue: block. 52092 self assertValues: #(5 5 5 5 5)! ! 52093 52094!ClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:29'! 52095testWhileModificationBefore 52096 | index | 52097 index := 0. 52098 [ index < 5 ] whileTrue: [ 52099 index := index + 1. 52100 collection add: [ index ] ]. 52101 self assertValues: #(5 5 5 5 5)! ! 52102 52103!ClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:29'! 52104testWhileModificationBeforeNotInlined 52105 | index block | 52106 index := 0. 52107 block := [ 52108 index := index + 1. 52109 collection add: [ index ] ]. 52110 [ index < 5 ] whileTrue: block. 52111 self assertValues: #(5 5 5 5 5)! ! 52112 52113!ClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:52'! 52114testWhileWithTemp 52115 | index | 52116 index := 0. 52117 [ index < 5 ] whileTrue: [ 52118 | temp | 52119 temp := index := index + 1. 52120 collection add: [ temp ] ]. 52121 self assertValues: #(1 2 3 4 5)! ! 52122 52123!ClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:53'! 52124testWhileWithTempNotInlined 52125 | index block | 52126 index := 0. 52127 block := [ 52128 | temp | 52129 temp := index := index + 1. 52130 collection add: [ temp ] ]. 52131 [ index < 5 ] whileTrue: block. 52132 self assertValues: #(1 2 3 4 5)! ! 52133 52134"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 52135 52136ClosureTests class 52137 instanceVariableNames: ''! 52138TextDiffBuilder subclass: #CodeDiffBuilder 52139 instanceVariableNames: 'class' 52140 classVariableNames: '' 52141 poolDictionaries: '' 52142 category: 'System-FilePackage'! 52143!CodeDiffBuilder commentStamp: '<historical>' prior: 0! 52144I am a differencer that compares source in tokens tokenised by a parser. I consider comments significant, but consider sequences of whitespace equivalent. Depending on the definition of WhitespaceForCodeDiff>>at: sequences of whitespace containing carriage-returns may be considered different to sequences of whitespace lacking carriage-returns (which may result in better-formatted diffs).! 52145]style[(392)i! 52146 52147StringHolder subclass: #CodeHolder 52148 instanceVariableNames: 'currentCompiledMethod contentsSymbol' 52149 classVariableNames: '' 52150 poolDictionaries: '' 52151 category: 'Tools-Base'! 52152!CodeHolder commentStamp: '<historical>' prior: 0! 52153An ancestor class for all models which can show code. Eventually, much of the code that currently resides in StringHolder which only applies to code-holding StringHolders might get moved down here.! 52154 52155 52156!CodeHolder methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/5/2009 11:36'! 52157optionalButtonRow 52158 "Answer a row of control buttons" 52159 52160 | buttons aLabel | 52161 buttons := OrderedCollection new. 52162 Preferences menuButtonInToolPane 52163 ifTrue: [buttons add: self menuButton]. 52164 self optionalButtonPairs 52165 do: [:tuple | 52166 aLabel := Preferences abbreviatedBrowserButtons 52167 ifTrue: [self abbreviatedWordingFor: tuple second]. 52168 buttons add: ((PluggableButtonMorph 52169 on: self 52170 getState: nil 52171 action: tuple second) 52172 hResizing: #spaceFill; 52173 vResizing: #spaceFill; 52174 label: (aLabel ifNil: [tuple first asString]); 52175 setBalloonText: (tuple size > 2 ifTrue: [tuple third]); 52176 triggerOnMouseDown: (tuple size > 3 52177 ifTrue: [tuple fourth] 52178 ifFalse: [false]))]. 52179 buttons add: self codePaneProvenanceButton. 52180 ^(UITheme builder newRow: buttons) 52181 setNameTo: 'buttonPane'; 52182 cellInset: 2! ! 52183 52184 52185!CodeHolder methodsFor: '*services-base' stamp: 'rr 3/15/2004 09:21'! 52186requestor 52187 ^ (BrowserRequestor new) browser: self; yourself! ! 52188 52189 52190!CodeHolder methodsFor: 'annotation' stamp: 'md 2/24/2006 15:25'! 52191addOptionalAnnotationsTo: window at: fractions plus: verticalOffset 52192 "Add an annotation pane to the window if preferences indicate a desire for it, and return the incoming verticalOffset plus the height of the added pane, if any" 52193 52194 | aTextMorph divider delta | 52195 self wantsAnnotationPane ifFalse: [^ verticalOffset]. 52196 aTextMorph := PluggableTextMorph 52197 on: self 52198 text: #annotation 52199 accept: #annotation: 52200 readSelection: nil 52201 menu: #annotationPaneMenu:shifted:. 52202 aTextMorph 52203 askBeforeDiscardingEdits: true; 52204 acceptOnCR: true; 52205 borderWidth: 0; 52206 hideScrollBarsIndefinitely. 52207 divider := BorderedSubpaneDividerMorph forBottomEdge. 52208 divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2. 52209 delta := self defaultAnnotationPaneHeight. 52210 window 52211 addMorph: aTextMorph 52212 fullFrame: (LayoutFrame 52213 fractions: fractions 52214 offsets: (0@verticalOffset corner: 0@(verticalOffset + delta - 2))). 52215 window 52216 addMorph: divider 52217 fullFrame: (LayoutFrame 52218 fractions: fractions 52219 offsets: (0@(verticalOffset + delta - 2) corner: 0@(verticalOffset + delta))). 52220 ^ verticalOffset + delta! ! 52221 52222!CodeHolder methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:27'! 52223addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream 52224 "add an annotation detailing the prior versions count" 52225 | versionsCount | 52226 52227 versionsCount := VersionsBrowser versionCountForSelector: aSelector class: aClass. 52228 aStream nextPutAll: 52229 ((versionsCount > 1 52230 ifTrue: 52231 [versionsCount == 2 ifTrue: 52232 ['1 prior version'] 52233 ifFalse: 52234 [versionsCount printString, ' prior versions']] 52235 ifFalse: 52236 ['no prior versions']), self annotationSeparator)! ! 52237 52238!CodeHolder methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:27'! 52239annotation 52240 "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." 52241 52242 | aSelector aClass | 52243 52244 ((aSelector := self selectedMessageName) == nil or: [(aClass := self selectedClassOrMetaClass) == nil]) 52245 ifTrue: [^ '------']. 52246 ^ self annotationForSelector: aSelector ofClass: aClass! ! 52247 52248!CodeHolder methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:27'! 52249annotationForClassCommentFor: aClass 52250 "Provide a line of content for an annotation pane, given that the receiver is pointing at the clas comment of the given class." 52251 52252 | aStamp nonMeta | 52253 aStamp := (nonMeta := aClass theNonMetaClass) organization commentStamp. 52254 ^ aStamp 52255 ifNil: 52256 [nonMeta name, ' has no class comment'] 52257 ifNotNil: 52258 ['class comment for ', nonMeta name, 52259 (aStamp = '<historical>' 52260 ifFalse: 52261 [' - ', aStamp] 52262 ifTrue: 52263 [''])]! ! 52264 52265!CodeHolder methodsFor: 'annotation' stamp: 'sw 8/26/2002 10:19'! 52266annotationForClassDefinitionFor: aClass 52267 "Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class." 52268 52269 ^ 'Class definition for ', aClass name! ! 52270 52271!CodeHolder methodsFor: 'annotation' stamp: 'sw 8/26/2002 10:19'! 52272annotationForHierarchyFor: aClass 52273 "Provide a line of content for an annotation pane, given that the receiver is pointing at the hierarchy of the given class." 52274 52275 ^ 'Hierarchy for ', aClass name! ! 52276 52277!CodeHolder methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:27'! 52278annotationForSelector: aSelector ofClass: aClass 52279 "Provide a line of content for an annotation pane, representing 52280 information about the given selector and class" 52281 | stamp sendersCount implementorsCount aCategory separator aString aList aComment aStream requestList | 52282 aSelector == #Comment 52283 ifTrue: [^ self annotationForClassCommentFor: aClass]. 52284 aSelector == #Definition 52285 ifTrue: [^ self annotationForClassDefinitionFor: aClass]. 52286 aSelector == #Hierarchy 52287 ifTrue: [^ self annotationForHierarchyFor: aClass]. 52288 aStream := ReadWriteStream on: ''. 52289 requestList := self annotationRequests. 52290 separator := requestList size > 1 52291 ifTrue: [self annotationSeparator] 52292 ifFalse: ['']. 52293 requestList 52294 do: [:aRequest | 52295 aRequest == #firstComment 52296 ifTrue: [aComment := aClass firstCommentAt: aSelector. 52297 aComment isEmptyOrNil 52298 ifFalse: [aStream nextPutAll: aComment , separator]]. 52299 aRequest == #masterComment 52300 ifTrue: [aComment := aClass supermostPrecodeCommentFor: aSelector. 52301 aComment isEmptyOrNil 52302 ifFalse: [aStream nextPutAll: aComment , separator]]. 52303 aRequest == #documentation 52304 ifTrue: [aComment := aClass precodeCommentOrInheritedCommentFor: aSelector. 52305 aComment isEmptyOrNil 52306 ifFalse: [aStream nextPutAll: aComment , separator]]. 52307 aRequest == #timeStamp 52308 ifTrue: [stamp := self timeStamp. 52309 aStream 52310 nextPutAll: (stamp size > 0 52311 ifTrue: [stamp , separator] 52312 ifFalse: ['no timeStamp' , separator])]. 52313 aRequest == #messageCategory 52314 ifTrue: [aCategory := aClass organization categoryOfElement: aSelector. 52315 aCategory 52316 ifNotNil: ["woud be nil for a method no longer present, 52317 e.g. in a recent-submissions browser" 52318 aStream nextPutAll: aCategory , separator]]. 52319 aRequest == #sendersCount 52320 ifTrue: [sendersCount := (self systemNavigation allCallsOn: aSelector) size. 52321 sendersCount := sendersCount == 1 52322 ifTrue: ['1 sender'] 52323 ifFalse: [sendersCount printString , ' senders']. 52324 aStream nextPutAll: sendersCount , separator]. 52325 aRequest == #implementorsCount 52326 ifTrue: [implementorsCount := self systemNavigation numberOfImplementorsOf: aSelector. 52327 implementorsCount := implementorsCount == 1 52328 ifTrue: ['1 implementor'] 52329 ifFalse: [implementorsCount printString , ' implementors']. 52330 aStream nextPutAll: implementorsCount , separator]. 52331 aRequest == #priorVersionsCount 52332 ifTrue: [self 52333 addPriorVersionsCountForSelector: aSelector 52334 ofClass: aClass 52335 to: aStream]. 52336 aRequest == #priorTimeStamp 52337 ifTrue: [stamp := VersionsBrowser 52338 timeStampFor: aSelector 52339 class: aClass 52340 reverseOrdinal: 2. 52341 stamp 52342 ifNotNil: [aStream nextPutAll: 'prior time stamp: ' , stamp , separator]]. 52343 aRequest == #recentChangeSet 52344 ifTrue: [aString := ChangeSorter mostRecentChangeSetWithChangeForClass: aClass selector: aSelector. 52345 aString size > 0 52346 ifTrue: [aStream nextPutAll: aString , separator]]. 52347 aRequest == #allChangeSets 52348 ifTrue: [aList := ChangeSorter allChangeSetsWithClass: aClass selector: aSelector. 52349 aList size > 0 52350 ifTrue: [aList size = 1 52351 ifTrue: [aStream nextPutAll: 'only in change set '] 52352 ifFalse: [aStream nextPutAll: 'in change sets: ']. 52353 aList 52354 do: [:aChangeSet | aStream nextPutAll: aChangeSet name , ' ']] 52355 ifFalse: [aStream nextPutAll: 'in no change set']. 52356 aStream nextPutAll: separator]]. 52357 ^ aStream contents! ! 52358 52359!CodeHolder methodsFor: 'annotation' stamp: 'RAA 1/13/2001 07:20'! 52360annotationPaneMenu: aMenu shifted: shifted 52361 52362 ^ aMenu 52363 labels: 'change pane size' 52364 lines: #() 52365 selections: #(toggleAnnotationPaneSize)! ! 52366 52367!CodeHolder methodsFor: 'annotation' stamp: 'sw 9/27/1999 14:13'! 52368annotationRequests 52369 ^ Preferences defaultAnnotationRequests! ! 52370 52371!CodeHolder methodsFor: 'annotation' stamp: 'sw 2/22/2001 10:02'! 52372annotationSeparator 52373 "Answer the separator to be used between annotations" 52374 52375 ^ ' · '! ! 52376 52377!CodeHolder methodsFor: 'annotation' stamp: 'sw 9/28/2001 08:43'! 52378defaultAnnotationPaneHeight 52379 "Answer the receiver's preferred default height for new annotation panes." 52380 52381 ^ Preferences parameterAt: #defaultAnnotationPaneHeight ifAbsentPut: [25]! ! 52382 52383!CodeHolder methodsFor: 'annotation' stamp: 'md 7/24/2009 15:51'! 52384defaultButtonPaneHeight 52385 "Answer the user's preferred default height for new button panes." 52386 52387 ^ (Preferences 52388 parameterAt: #defaultButtonPaneHeight 52389 ifAbsentPut: [25]) + 2 52390 52391! ! 52392 52393 52394!CodeHolder methodsFor: 'breakpoints' stamp: 'marcus.denker 10/9/2008 20:31'! 52395toggleBreakOnEntry 52396 "Install or uninstall a halt-on-entry breakpoint" 52397 52398 | selectedMethod | 52399 self selectedClassOrMetaClass isNil ifTrue:[^self]. 52400 selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName. 52401 selectedMethod hasBreakpoint 52402 ifTrue: 52403 [BreakpointManager unInstall: selectedMethod] 52404 ifFalse: 52405 [BreakpointManager 52406 installInClass: self selectedClassOrMetaClass 52407 selector: self selectedMessageName].! ! 52408 52409 52410!CodeHolder methodsFor: 'categories' stamp: 'sd 11/8/2005 22:06'! 52411categoryFromUserWithPrompt: aPrompt for: aClass 52412 "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" 52413 52414 | labels myCategories reject lines cats newName menuIndex | 52415 labels := OrderedCollection with: 'new...'. 52416 labels addAll: (myCategories := aClass organization categories asSortedCollection: 52417 [:a :b | a asLowercase < b asLowercase]). 52418 reject := myCategories asSet. 52419 reject 52420 add: ClassOrganizer nullCategory; 52421 add: ClassOrganizer default. 52422 lines := OrderedCollection with: 1 with: (myCategories size + 1). 52423 52424 aClass allSuperclasses do: 52425 [:cls | 52426 cats := cls organization categories reject: 52427 [:cat | reject includes: cat]. 52428 cats isEmpty ifFalse: 52429 [lines add: labels size. 52430 labels addAll: (cats asSortedCollection: 52431 [:a :b | a asLowercase < b asLowercase]). 52432 reject addAll: cats]]. 52433 52434 newName := (labels size = 1 or: 52435 [menuIndex := (UIManager default chooseFrom: labels lines: lines title: aPrompt). 52436 menuIndex = 0 ifTrue: [^ nil]. 52437 menuIndex = 1]) 52438 ifTrue: 52439 [UIManager default request: 'Please type new category name' 52440 initialAnswer: 'category name'] 52441 ifFalse: 52442 [labels at: menuIndex]. 52443 ^ newName ifNotNil: [newName asSymbol]! ! 52444 52445!CodeHolder methodsFor: 'categories' stamp: 'sd 11/20/2005 21:27'! 52446categoryOfCurrentMethod 52447 "Answer the category that owns the current method. If unable to determine a category, answer nil." 52448 52449 | aClass aSelector | 52450 ^ (aClass := self selectedClassOrMetaClass) 52451 ifNotNil: [(aSelector := self selectedMessageName) 52452 ifNotNil: [aClass whichCategoryIncludesSelector: aSelector]]! ! 52453 52454!CodeHolder methodsFor: 'categories' stamp: 'sd 11/20/2005 21:26'! 52455changeCategory 52456 "Present a menu of the categories of messages for the current class, 52457 and let the user choose a new category for the current message" 52458 52459 | aClass aSelector | 52460 (aClass := self selectedClassOrMetaClass) ifNotNil: 52461 [(aSelector := self selectedMessageName) ifNotNil: 52462 [(self letUserReclassify: aSelector in: aClass) ifTrue: 52463 ["ChangeSet current reorganizeClass: aClass." 52464 "Decided on further review that the above, when present, could cause more 52465 unexpected harm than good" 52466 self methodCategoryChanged]]]! ! 52467 52468!CodeHolder methodsFor: 'categories' stamp: 'sd 11/20/2005 21:27'! 52469letUserReclassify: anElement in: aClass 52470 "Put up a list of categories and solicit one from the user. 52471 Answer true if user indeed made a change, else false" 52472 52473 52474 | currentCat newCat | 52475 currentCat := aClass organization categoryOfElement: anElement. 52476 newCat := self 52477 categoryFromUserWithPrompt: 'choose category (currently "', currentCat, '")' 52478 for: aClass. 52479 (newCat ~~ nil and: [newCat ~= currentCat]) 52480 ifTrue: 52481 [aClass organization classify: anElement under: newCat suppressIfDefault: false. 52482 ^ true] 52483 ifFalse: 52484 [^ false]! ! 52485 52486!CodeHolder methodsFor: 'categories' stamp: 'sw 9/27/1999 14:11'! 52487methodCategoryChanged 52488 self changed: #annotation! ! 52489 52490!CodeHolder methodsFor: 'categories' stamp: 'sw 3/22/2000 23:04'! 52491selectedMessageCategoryName 52492 "Answer the name of the message category of the message of the currently selected context." 52493 52494 ^ self selectedClass organization categoryOfElement: self selectedMessageName! ! 52495 52496 52497!CodeHolder methodsFor: 'categories & search pane' stamp: 'sd 11/20/2005 21:27'! 52498listPaneWithSelector: aSelector 52499 "If, among my window's paneMorphs, there is a list pane defined with aSelector as its retriever, answer it, else answer nil" 52500 52501 | aWindow | 52502 ^ (aWindow := self containingWindow) ifNotNil: 52503 [aWindow paneMorphSatisfying: 52504 [:aMorph | (aMorph isKindOf: PluggableListMorph) and: 52505 [aMorph getListSelector == aSelector]]]! ! 52506 52507!CodeHolder methodsFor: 'categories & search pane' stamp: 'sd 11/20/2005 21:27'! 52508newSearchPane 52509 "Answer a new search pane for the receiver" 52510 52511 | aTextMorph | 52512 aTextMorph := PluggableTextMorph on: self 52513 text: #lastSearchString accept: #lastSearchString: 52514 readSelection: nil menu: nil. 52515 aTextMorph setProperty: #alwaysAccept toValue: true. 52516 aTextMorph askBeforeDiscardingEdits: false. 52517 aTextMorph acceptOnCR: true. 52518 aTextMorph setBalloonText: 'Type here and hit ENTER, and all methods whose selectors match what you typed will appear in the list pane below.'. 52519 ^ aTextMorph! ! 52520 52521!CodeHolder methodsFor: 'categories & search pane' stamp: 'sw 3/7/2001 12:22'! 52522searchPane 52523 "Answer the search pane associated with the receiver in its window, or nil if none. Morphic only" 52524 52525 ^ self textPaneWithSelector: #lastSearchString! ! 52526 52527!CodeHolder methodsFor: 'categories & search pane' stamp: 'sd 11/20/2005 21:27'! 52528textPaneWithSelector: aSelector 52529 "If, among my window's paneMorphs, there is a text pane defined with aSelector as its retriever, answer it, else answer nil" 52530 52531 | aWindow | 52532 ^ (aWindow := self containingWindow) ifNotNil: 52533 [aWindow paneMorphSatisfying: 52534 [:aMorph | (aMorph isKindOf: PluggableTextMorph) and: 52535 [aMorph getTextSelector == aSelector]]]! ! 52536 52537 52538!CodeHolder methodsFor: 'commands' stamp: 'sd 5/23/2003 14:35'! 52539adoptMessageInCurrentChangeset 52540 "Add the receiver's method to the current change set if not already there" 52541 52542 self setClassAndSelectorIn: [:cl :sel | 52543 cl ifNotNil: 52544 [ChangeSet current adoptSelector: sel forClass: cl. 52545 self changed: #annotation]] 52546! ! 52547 52548!CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:27'! 52549browseImplementors 52550 "Create and schedule a message set browser on all implementors of the currently selected message selector. Do nothing if no message is selected." 52551 52552 | aMessageName | 52553 (aMessageName := self selectedMessageName) ifNotNil: 52554 [self systemNavigation browseAllImplementorsOf: aMessageName]! ! 52555 52556!CodeHolder methodsFor: 'commands' stamp: 'nk 6/26/2003 21:43'! 52557browseSenders 52558 "Create and schedule a message set browser on all senders of the currently selected message selector. Of there is no message currently selected, offer a type-in" 52559 52560 self sendQuery: #browseAllCallsOn: to: self systemNavigation! ! 52561 52562!CodeHolder methodsFor: 'commands' stamp: 'alain.plantec 5/30/2008 11:24'! 52563copyUpOrCopyDown 52564 "Used to copy down code from a superclass to a subclass or vice-versa in one easy step, if you know what you're doing. Prompt the user for which class to copy down or copy up to, then spawn a fresh browser for that class, with the existing code planted in it, and with the existing method category also established." 52565 52566 | aClass aSelector allClasses implementors aMenu aColor | 52567 ((aClass := self selectedClassOrMetaClass) isNil or: [(aSelector := self selectedMessageName) == nil]) 52568 ifTrue: [^ Beeper beep]. 52569 52570 allClasses := self systemNavigation hierarchyOfClassesSurrounding: aClass. 52571 implementors := self systemNavigation hierarchyOfImplementorsOf: aSelector forClass: aClass. 52572 aMenu := MenuMorph new defaultTarget: self. 52573 aMenu title: 52574aClass name, '.', aSelector, ' 52575Choose where to insert a copy of this method 52576(blue = current, black = available, red = other implementors'. 52577 allClasses do: 52578 [:cl | 52579 aColor := cl == aClass 52580 ifTrue: [#blue] 52581 ifFalse: 52582 [(implementors includes: cl) 52583 ifTrue: [#red] 52584 ifFalse: [#black]]. 52585 (aColor == #red) 52586 ifFalse: 52587 [aMenu add: cl name selector: #spawnToClass: argument: cl] 52588 ifTrue: 52589 [aMenu add: cl name selector: #spawnToCollidingClass: argument: cl]. 52590 aMenu lastItem color: (Color colorFrom: aColor)]. 52591 aMenu popUpInWorld! ! 52592 52593!CodeHolder methodsFor: 'commands' stamp: 'sw 5/18/2001 17:51'! 52594offerMenu 52595 "Offer a menu to the user from the bar of tool buttons" 52596 52597 self offerDurableMenuFrom: #messageListMenu:shifted: shifted: false! ! 52598 52599!CodeHolder methodsFor: 'commands' stamp: 'sw 2/27/2001 12:14'! 52600offerShiftedClassListMenu 52601 "Offer the shifted class-list menu." 52602 52603 ^ self offerMenuFrom: #classListMenu:shifted: shifted: true! ! 52604 52605!CodeHolder methodsFor: 'commands' stamp: 'sw 2/27/2001 12:15'! 52606offerUnshiftedClassListMenu 52607 "Offer the shifted class-list menu." 52608 52609 ^ self offerMenuFrom: #classListMenu:shifted: shifted: false! ! 52610 52611!CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:27'! 52612removeClass 52613 "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." 52614 52615 | message className classToRemove result | 52616 self okToChange ifFalse: [^ false]. 52617 classToRemove := self selectedClassOrMetaClass ifNil: [Beeper beep. ^ false]. 52618 classToRemove := classToRemove theNonMetaClass. 52619 className := classToRemove name. 52620 message := 'Are you certain that you 52621want to REMOVE the class ', className, ' 52622from the system?'. 52623 (result := self confirm: message) 52624 ifTrue: 52625 [classToRemove subclasses size > 0 52626 ifTrue: [(self confirm: 'class has subclasses: ' , message) 52627 ifFalse: [^ false]]. 52628 classToRemove removeFromSystem. 52629 self changed: #classList. 52630 true]. 52631 ^ result! ! 52632 52633!CodeHolder methodsFor: 'commands' stamp: 'sw 3/6/2001 15:18'! 52634shiftedYellowButtonActivity 52635 "Offer the shifted selector-list menu" 52636 52637 ^ self offerMenuFrom: #messageListMenu:shifted: shifted: true! ! 52638 52639!CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:27'! 52640spawnFullProtocol 52641 "Create and schedule a new protocol browser on the currently selected class or meta." 52642 52643 | aClassOrMetaclass | 52644 (aClassOrMetaclass := self selectedClassOrMetaClass) ifNotNil: 52645 [ProtocolBrowser openFullProtocolForClass: aClassOrMetaclass]! ! 52646 52647!CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:27'! 52648spawnProtocol 52649 | aClassOrMetaclass | 52650 "Create and schedule a new protocol browser on the currently selected class or meta." 52651 (aClassOrMetaclass := self selectedClassOrMetaClass) ifNotNil: 52652 [ProtocolBrowser openSubProtocolForClass: aClassOrMetaclass]! ! 52653 52654!CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:27'! 52655spawnToClass: aClass 52656 "Used to copy down code from a superclass to a subclass in one easy step, if you know what you're doing. Spawns a new message-category browser for the indicated class, populating it with the source code seen in the current tool." 52657 52658 | aCategory newBrowser org | 52659 (aCategory := self categoryOfCurrentMethod) 52660 ifNil: 52661 [self buildClassBrowserEditString: self contents] 52662 ifNotNil: 52663 [((org := aClass organization) categories includes: aCategory) 52664 ifFalse: [org addCategory: aCategory]. 52665 newBrowser := Browser new setClass: aClass selector: nil. 52666 newBrowser selectMessageCategoryNamed: aCategory. 52667 Browser openBrowserView: (newBrowser openMessageCatEditString: self contents) 52668 label: 'category "', aCategory, '" in ', 52669 newBrowser selectedClassOrMetaClassName]! ! 52670 52671!CodeHolder methodsFor: 'commands' stamp: 'sw 3/20/2001 15:11'! 52672spawnToCollidingClass: aClass 52673 "Potentially used to copy down code from a superclass to a subclass in one easy step, in the case where the given class already has its own version of code, which would consequently be clobbered if the spawned code were accepted." 52674 52675 self inform: 'That would be destructive of 52676some pre-existing code already in that 52677class for this selector. For the moment, 52678we will not let you do this to yourself.'! ! 52679 52680!CodeHolder methodsFor: 'commands' stamp: 'sw 3/6/2001 15:19'! 52681unshiftedYellowButtonActivity 52682 "Offer the unshifted shifted selector-list menu" 52683 52684 ^ self offerMenuFrom: #messageListMenu:shifted: shifted: false! ! 52685 52686 52687!CodeHolder methodsFor: 'construction' stamp: 'sd 11/20/2005 21:27'! 52688addLowerPanesTo: window at: nominalFractions with: editString 52689 52690 | verticalOffset row innerFractions | 52691 52692 row := AlignmentMorph newColumn 52693 hResizing: #spaceFill; 52694 vResizing: #spaceFill; 52695 layoutInset: 0; 52696 borderWidth: 1; 52697 borderColor: Color black; 52698 layoutPolicy: ProportionalLayout new. 52699 52700 verticalOffset := 0. 52701 innerFractions := 0@0 corner: 1@0. 52702 verticalOffset := self addOptionalAnnotationsTo: row at: innerFractions plus: verticalOffset. 52703 verticalOffset := self addOptionalButtonsTo: row at: innerFractions plus: verticalOffset. 52704 52705 row 52706 addMorph: ((self buildMorphicCodePaneWith: editString) borderWidth: 0) 52707 fullFrame: ( 52708 LayoutFrame 52709 fractions: (innerFractions withBottom: 1) 52710 offsets: (0@verticalOffset corner: 0@0) 52711 ). 52712 window 52713 addMorph: row 52714 frame: nominalFractions. 52715 52716 row on: #mouseEnter send: #paneTransition: to: window. 52717 row on: #mouseLeave send: #paneTransition: to: window.! ! 52718 52719!CodeHolder methodsFor: 'construction' stamp: 'sd 11/20/2005 21:27'! 52720buildClassBrowserEditString: aString 52721 "Create and schedule a new class browser for the current selection, with initial textual contents set to aString. This is used specifically in spawning where a class is established but a method-category is not." 52722 52723 | newBrowser | 52724 newBrowser := Browser new. 52725 newBrowser setClass: self selectedClassOrMetaClass selector: nil. 52726 newBrowser editSelection: #newMessage. 52727 Browser openBrowserView: (newBrowser openOnClassWithEditString: aString) 52728 label: 'Class Browser: ', self selectedClassOrMetaClass name 52729! ! 52730 52731!CodeHolder methodsFor: 'construction' stamp: 'tween 8/27/2004 12:18'! 52732buildMorphicCodePaneWith: editString 52733 "Construct the pane that shows the code. 52734 Respect the Preference for standardCodeFont." 52735 52736 | codePane | 52737 codePane := MorphicTextEditor default 52738 on: self 52739 text: #contents 52740 accept: #contents:notifying: 52741 readSelection: #contentsSelection 52742 menu: #codePaneMenu:shifted:. 52743 codePane font: Preferences standardCodeFont. 52744 editString 52745 ifNotNil: [codePane editString: editString. 52746 codePane hasUnacceptedEdits: true]. 52747 ^ codePane! ! 52748 52749 52750!CodeHolder methodsFor: 'contents' stamp: 'sd 11/20/2005 21:27'! 52751commentContents 52752 "documentation for the selected method" 52753 52754 | poss aClass aSelector | 52755 ^ (poss := (aClass := self selectedClassOrMetaClass) 52756 ifNil: 52757 ['----'] 52758 ifNotNil: 52759 [(aSelector := self selectedMessageName) 52760 ifNil: 52761 ['---'] 52762 ifNotNil: 52763 [(aClass precodeCommentOrInheritedCommentFor: aSelector)", String cr, String cr, self timeStamp" 52764"which however misses comments that are between the temps declaration and the body of the method; those are picked up by ·aClass commentOrInheritedCommentFor: aSelector· but that method will get false positives from comments *anywhere* in the method source"]]) 52765 isEmptyOrNil 52766 ifTrue: 52767 [aSelector 52768 ifNotNil: 52769 [((aClass methodHeaderFor: aSelector), ' 52770 52771Has no comment') asText makeSelectorBoldIn: aClass] 52772 ifNil: 52773 ['Hamna']] 52774 ifFalse: [aSelector 52775 ifNotNil: [((aClass methodHeaderFor: aSelector), ' 52776 52777', poss) asText makeSelectorBoldIn: aClass] 52778 ifNil: [poss]]! ! 52779 52780!CodeHolder methodsFor: 'contents' stamp: 'di 10/1/2001 22:25'! 52781contents 52782 "Answer the source code or documentation for the selected method" 52783 52784 self showingByteCodes ifTrue: 52785 [^ self selectedBytecodes]. 52786 52787 self showingDocumentation ifTrue: 52788 [^ self commentContents]. 52789 52790 ^ self selectedMessage! ! 52791 52792!CodeHolder methodsFor: 'contents' stamp: 'alain.plantec 5/18/2009 15:31'! 52793contentsSymbol 52794 "Answer a symbol indicating what kind of content should be shown for the method; for normal showing of source code, this symbol is #source. A nil value in the contentsSymbol slot will be set to #source by this method" 52795 52796 ^ contentsSymbol ifNil: 52797 [contentsSymbol := Preferences browseWithPrettyPrint 52798 ifTrue: 52799 [#prettyPrint] 52800 ifFalse: 52801 [#source]]! ! 52802 52803!CodeHolder methodsFor: 'contents' stamp: 'sd 11/20/2005 21:27'! 52804contentsSymbol: aSymbol 52805 "Set the contentsSymbol as indicated. #source means to show source code, #comment means to show the first comment found in the source code" 52806 52807 contentsSymbol := aSymbol! ! 52808 52809 52810!CodeHolder methodsFor: 'controls' stamp: 'gm 2/16/2003 20:37'! 52811buttonWithSelector: aSelector 52812 "If receiver has a control button with the given action selector answer it, else answer nil. morphic only at this point" 52813 52814 | aWindow aPane | 52815 ((aWindow := self containingWindow) isSystemWindow) 52816 ifFalse: [^nil]. 52817 (aPane := aWindow submorphNamed: 'buttonPane') ifNil: [^nil]. 52818 ^aPane submorphThat: 52819 [:m | 52820 (m isKindOf: PluggableButtonMorph) and: [m actionSelector == aSelector]] 52821 ifNone: [^nil]! ! 52822 52823!CodeHolder methodsFor: 'controls' stamp: 'gvc 1/20/2009 15:55'! 52824codePaneProvenanceButton 52825 "Answer a button that reports on, and allow the user to modify, 52826 the code-pane-provenance setting" 52827 52828 ^(UITheme builder 52829 newDropListFor: self 52830 list: #codePaneProvenanceList 52831 getSelected: #codePaneProvenanceIndex 52832 setSelected: #codePaneProvenanceIndex: 52833 help: 'Select what is shown in the code pane' translated) 52834 useRoundedCorners; 52835 hResizing: #spaceFill; 52836 vResizing: #spaceFill; 52837 minWidth: 88! ! 52838 52839!CodeHolder methodsFor: 'controls' stamp: 'gvc 1/20/2009 15:34'! 52840codePaneProvenanceIndex 52841 "Answer the selected code provenance index." 52842 52843 ^((self contentsSymbolQuints select: [:e | e ~= #-]) collect: [:e | 52844 e first]) indexOf: self contentsSymbol ifAbsent: [0]! ! 52845 52846!CodeHolder methodsFor: 'controls' stamp: 'gvc 1/20/2009 15:33'! 52847codePaneProvenanceIndex: anInteger 52848 "Set the code provenance to the item with the given index." 52849 52850 self perform: ((self contentsSymbolQuints select: [:e | e ~= #-]) at: anInteger) second! ! 52851 52852!CodeHolder methodsFor: 'controls' stamp: 'gvc 1/20/2009 15:31'! 52853codePaneProvenanceList 52854 "Answer a list of the display strings for code provenance." 52855 52856 ^(self contentsSymbolQuints select: [:e | e ~= #-]) collect: [:e | 52857 e fourth]! ! 52858 52859!CodeHolder methodsFor: 'controls' stamp: 'sd 11/20/2005 21:26'! 52860codePaneProvenanceString 52861 "Answer a string that reports on code-pane-provenance" 52862 52863 | symsAndWordings | 52864 (symsAndWordings := self contentsSymbolQuints) do: 52865 [:aQuad | 52866 contentsSymbol == aQuad first ifTrue: [^ aQuad fourth]]. 52867 ^ symsAndWordings first fourth "default to plain source, for example if nil as initially"! ! 52868 52869!CodeHolder methodsFor: 'controls' stamp: 'alain.plantec 5/18/2009 15:31'! 52870contentsSymbolQuints 52871 "Answer a list of quintuplets representing information on the alternative views available in the code pane 52872 first element: the contentsSymbol used 52873 second element: the selector to call when this item is chosen. 52874 third element: the selector to call to obtain the wording of the menu item. 52875 fourth element: the wording to represent this view 52876 fifth element: balloon help 52877 A hypen indicates a need for a seperator line in a menu of such choices" 52878 52879 ^ #( 52880(source togglePlainSource showingPlainSourceString 'source' 'the textual source code as writen') 52881(documentation toggleShowDocumentation showingDocumentationString 'documentation' 'the first comment in the method') 52882- 52883(prettyPrint togglePrettyPrint prettyPrintString 'prettyPrint' 'the method source presented in a standard text format') 52884- 52885(showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version') 52886(prettyDiffs togglePrettyDiffing showingPrettyDiffsString 'prettyDiffs' 'formatted textual source diffed from formatted form of prior version') 52887- 52888(decompile toggleDecompile showingDecompileString 'decompile' 'source code decompiled from byteCodes') 52889(byteCodes toggleShowingByteCodes showingByteCodesString 'byteCodes' 'the bytecodes that comprise the compiled method'))! ! 52890 52891!CodeHolder methodsFor: 'controls' stamp: 'ar 2/12/2005 14:28'! 52892decorateButtons 52893 "Change screen feedback for any buttons in the UI of the receiver that may wish it. Initially, it is only the Inheritance button that is decorated, but one can imagine others." 52894 self changed: #inheritanceButtonColor. 52895 self decorateForInheritance ! ! 52896 52897!CodeHolder methodsFor: 'controls' stamp: 'marcus.denker 8/17/2008 21:04'! 52898decorateForInheritance 52899 "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." 52900 52901 | aButton | 52902 (aButton := self inheritanceButton) ifNil: [^ self]. 52903 52904 ((currentCompiledMethod isKindOf: CompiledMethod) and: [Preferences decorateBrowserButtons]) 52905 ifFalse: [^aButton offColor: Color transparent]. 52906 52907 "This table duplicates the old logic, but adds two new colors for the cases where there is a superclass definition, but this method doesn't call it." 52908 52909 aButton offColor: self color! ! 52910 52911!CodeHolder methodsFor: 'controls' stamp: 'sw 1/25/2001 14:44'! 52912inheritanceButton 52913 "If receiver has an Inheritance button, answer it, else answer nil. morphic only at this point" 52914 52915 ^ self buttonWithSelector: #methodHierarchy! ! 52916 52917!CodeHolder methodsFor: 'controls' stamp: 'sd 11/20/2005 21:27'! 52918optionalButtonPairs 52919 "Answer a tuple (formerly pairs) defining buttons, in the format: 52920 button label 52921 selector to send 52922 help message" 52923 52924 | aList | 52925 52926 aList := #( 52927 ('browse' browseMethodFull 'view this method in a browser') 52928 ('senders' browseSendersOfMessages 'browse senders of...') 52929 ('implementors' browseMessages 'browse implementors of...') 52930 ('versions' browseVersions 'browse versions')), 52931 52932 (Preferences decorateBrowserButtons 52933 ifTrue: 52934 [{#('inheritance' methodHierarchy 'browse method inheritance 52935green: sends to super 52936tan: has override(s) 52937mauve: both of the above 52938pink: is an override but doesn''t call super 52939pinkish tan: has override(s), also is an override but doesn''t call super' )}] 52940 ifFalse: 52941 [{#('inheritance' methodHierarchy 'browse method inheritance')}]), 52942 52943 #( 52944 ('hierarchy' classHierarchy 'browse class hierarchy') 52945 ('inst vars' browseInstVarRefs 'inst var refs...') 52946 ('class vars' browseClassVarRefs 'class var refs...')). 52947 52948 ^ aList! ! 52949 52950!CodeHolder methodsFor: 'controls' stamp: 'sw 11/13/2001 09:12'! 52951sourceAndDiffsQuintsOnly 52952 "Answer a list of quintuplets representing information on the alternative views available in the code pane for the case where the only plausible choices are showing source or either of the two kinds of diffs" 52953 52954 ^ #( 52955(source togglePlainSource showingPlainSourceString 'source' 'the textual source code as writen') 52956(showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version') 52957(prettyDiffs togglePrettyDiffing showingPrettyDiffsString 'prettyDiffs' 'formatted textual source diffed from formatted form of prior version'))! ! 52958 52959 52960!CodeHolder methodsFor: 'diffs' stamp: 'sw 9/5/2001 13:36'! 52961defaultDiffsSymbol 52962 "Answer the code symbol to use when generically switching to diffing" 52963 52964 ^ Preferences diffsWithPrettyPrint 52965 ifTrue: 52966 [#prettyDiffs] 52967 ifFalse: 52968 [#showDiffs]! ! 52969 52970!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'! 52971diffButton 52972 "Return a checkbox that lets the user decide whether diffs should be shown or not. Not sent any more but retained against the possibility of existing subclasses outside the base image using it." 52973 52974 | outerButton aButton | 52975 outerButton := AlignmentMorph newRow. 52976 outerButton wrapCentering: #center; cellPositioning: #leftCenter. 52977 outerButton color: Color transparent. 52978 outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. 52979 outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox). 52980 aButton 52981 target: self; 52982 actionSelector: #toggleRegularDiffing; 52983 getSelector: #showingRegularDiffs. 52984 outerButton addMorphBack: (StringMorph contents: 'diffs') lock. 52985 outerButton setBalloonText: 'If checked, then code differences from the previous version, if any, will be shown.'. 52986 52987 ^ outerButton 52988! ! 52989 52990!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'! 52991diffFromPriorSourceFor: sourceCode 52992 "If there is a prior version of source for the selected method, return a diff, else just return the source code" 52993 52994 | prior | 52995 ^ (prior := self priorSourceOrNil) 52996 ifNil: [sourceCode] 52997 ifNotNil: [TextDiffBuilder buildDisplayPatchFrom: prior to: sourceCode inClass: self selectedClass prettyDiffs: self showingPrettyDiffs]! ! 52998 52999!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'! 53000prettyDiffButton 53001 "Return a checkbox that lets the user decide whether prettyDiffs should be shown or not" 53002 53003 | outerButton aButton | 53004 outerButton := AlignmentMorph newRow. 53005 outerButton wrapCentering: #center; cellPositioning: #leftCenter. 53006 outerButton color: Color transparent. 53007 outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. 53008 outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox). 53009 aButton 53010 target: self; 53011 actionSelector: #togglePrettyDiffing; 53012 getSelector: #showingPrettyDiffs. 53013 outerButton addMorphBack: (StringMorph contents: 'prettyDiffs') lock. 53014 (self isKindOf: VersionsBrowser) 53015 ifTrue: 53016 [outerButton setBalloonText: 'If checked, then pretty-printed code differences from the previous version, if any, will be shown.'] 53017 ifFalse: 53018 [outerButton setBalloonText: 'If checked, then pretty-printed code differences between the file-based method and the in-memory version, if any, will be shown.']. 53019 53020 ^ outerButton 53021! ! 53022 53023!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'! 53024regularDiffButton 53025 "Return a checkbox that lets the user decide whether regular diffs should be shown or not" 53026 53027 | outerButton aButton | 53028 outerButton := AlignmentMorph newRow. 53029 outerButton wrapCentering: #center; cellPositioning: #leftCenter. 53030 outerButton color: Color transparent. 53031 outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. 53032 outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox). 53033 aButton 53034 target: self; 53035 actionSelector: #toggleRegularDiffing; 53036 getSelector: #showingRegularDiffs. 53037 outerButton addMorphBack: (StringMorph contents: 'diffs') lock. 53038 outerButton setBalloonText: 'If checked, then code differences from the previous version, if any, will be shown.'. 53039 53040 ^ outerButton 53041! ! 53042 53043!CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:49'! 53044showDiffs 53045 "Answer whether the receiver is showing diffs of source code. The preferred protocol here is #showingRegularDiffs, but this message is still sent by some preexisting buttons so is retained." 53046 53047 ^ contentsSymbol == #showDiffs 53048! ! 53049 53050!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'! 53051showDiffs: aBoolean 53052 "Set whether I'm showing diffs as indicated; use the global preference to determine which kind of diffs to institute." 53053 53054 self showingAnyKindOfDiffs 53055 ifFalse: 53056 [aBoolean ifTrue: 53057 [contentsSymbol := self defaultDiffsSymbol]] 53058 ifTrue: 53059 [aBoolean ifFalse: 53060 [contentsSymbol := #source]]. 53061 self setContentsToForceRefetch. 53062 self contentsChanged! ! 53063 53064!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:26'! 53065showPrettyDiffs: aBoolean 53066 "Set whether I'm showing pretty diffs as indicated" 53067 53068 self showingPrettyDiffs 53069 ifFalse: 53070 [aBoolean ifTrue: 53071 [contentsSymbol := #prettyDiffs]] 53072 ifTrue: 53073 [aBoolean ifFalse: 53074 [contentsSymbol := #source]]. 53075 self setContentsToForceRefetch. 53076 self contentsChanged! ! 53077 53078!CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:26'! 53079showRegularDiffs: aBoolean 53080 "Set whether I'm showing regular diffs as indicated" 53081 53082 self showingRegularDiffs 53083 ifFalse: 53084 [aBoolean ifTrue: 53085 [contentsSymbol := #showDiffs]] 53086 ifTrue: 53087 [aBoolean ifFalse: 53088 [contentsSymbol := #source]]. 53089 self setContentsToForceRefetch. 53090 self contentsChanged! ! 53091 53092!CodeHolder methodsFor: 'diffs' stamp: 'sw 9/5/2001 13:32'! 53093showingAnyKindOfDiffs 53094 "Answer whether the receiver is currently set to show any kind of diffs" 53095 53096 ^ #(showDiffs prettyDiffs) includes: contentsSymbol! ! 53097 53098!CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 09:10'! 53099showingDiffsString 53100 "Answer a string representing whether I'm showing diffs. Not sent any more but retained so that prexisting buttons that sent this will not raise errors." 53101 53102 ^ (self showingRegularDiffs 53103 ifTrue: 53104 ['<yes>'] 53105 ifFalse: 53106 ['<no>']), 'showDiffs'! ! 53107 53108!CodeHolder methodsFor: 'diffs' stamp: 'sw 5/19/2001 00:07'! 53109showingPrettyDiffs 53110 "Answer whether the receiver is showing pretty diffs of source code" 53111 53112 ^ contentsSymbol == #prettyDiffs 53113! ! 53114 53115!CodeHolder methodsFor: 'diffs' stamp: 'sw 5/22/2001 16:41'! 53116showingPrettyDiffsString 53117 "Answer a string representing whether I'm showing pretty diffs" 53118 53119 ^ (self showingPrettyDiffs 53120 ifTrue: 53121 ['<yes>'] 53122 ifFalse: 53123 ['<no>']), 'prettyDiffs'! ! 53124 53125!CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:07'! 53126showingRegularDiffs 53127 "Answer whether the receiver is showing regular diffs of source code" 53128 53129 ^ contentsSymbol == #showDiffs 53130! ! 53131 53132!CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:43'! 53133showingRegularDiffsString 53134 "Answer a string representing whether I'm showing regular diffs" 53135 53136 ^ (self showingRegularDiffs 53137 ifTrue: 53138 ['<yes>'] 53139 ifFalse: 53140 ['<no>']), 'showDiffs'! ! 53141 53142!CodeHolder methodsFor: 'diffs' stamp: 'sw 1/18/2001 13:58'! 53143toggleDiff 53144 "Retained for backward compatibility with existing buttons in existing images" 53145 53146 self toggleDiffing! ! 53147 53148!CodeHolder methodsFor: 'diffs' stamp: 'marcus.denker 9/20/2008 20:31'! 53149toggleDiffing 53150 "Toggle whether diffs should be shown in the code pane. If any kind of diffs were being shown, stop showing diffs. If no kind of diffs were being shown, start showing whatever kind of diffs are called for by default." 53151 53152 | wasShowingDiffs | 53153 self okToChange ifTrue: 53154 [wasShowingDiffs := self showingAnyKindOfDiffs. 53155 self showDiffs: wasShowingDiffs not. 53156 self setContentsToForceRefetch. 53157 self contentsChanged] 53158 53159! ! 53160 53161!CodeHolder methodsFor: 'diffs' stamp: 'marcus.denker 9/20/2008 20:31'! 53162togglePlainSource 53163 "Toggle whether plain source shown in the code pane" 53164 53165 | wasShowingPlainSource | 53166 self okToChange ifTrue: 53167 [wasShowingPlainSource := self showingPlainSource. 53168 wasShowingPlainSource 53169 ifTrue: 53170 [self showDocumentation: true] 53171 ifFalse: 53172 [contentsSymbol := #source]. 53173 self setContentsToForceRefetch. 53174 self changed: #contents] 53175 53176! ! 53177 53178!CodeHolder methodsFor: 'diffs' stamp: 'marcus.denker 9/20/2008 20:31'! 53179togglePrettyDiffing 53180 "Toggle whether pretty-diffing should be shown in the code pane" 53181 53182 | wasShowingDiffs | 53183 self okToChange ifTrue: 53184 [wasShowingDiffs := self showingPrettyDiffs. 53185 self showPrettyDiffs: wasShowingDiffs not. 53186 self setContentsToForceRefetch. 53187 self contentsChanged] 53188 53189! ! 53190 53191!CodeHolder methodsFor: 'diffs' stamp: 'marcus.denker 9/20/2008 20:31'! 53192togglePrettyPrint 53193 "Toggle whether pretty-print is in effectin the code pane" 53194 53195 self okToChange ifTrue: 53196 [self showingPrettyPrint 53197 ifTrue: 53198 [contentsSymbol := #source] 53199 ifFalse: 53200 [contentsSymbol := #prettyPrint]. 53201 self setContentsToForceRefetch. 53202 self contentsChanged] 53203 53204! ! 53205 53206!CodeHolder methodsFor: 'diffs' stamp: 'marcus.denker 9/20/2008 20:31'! 53207toggleRegularDiffing 53208 "Toggle whether regular-diffing should be shown in the code pane" 53209 53210 | wasShowingDiffs | 53211 self okToChange ifTrue: 53212 [wasShowingDiffs := self showingRegularDiffs. 53213 self showRegularDiffs: wasShowingDiffs not. 53214 self setContentsToForceRefetch. 53215 self contentsChanged] 53216 53217! ! 53218 53219!CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:24'! 53220wantsDiffFeedback 53221 "Answer whether the receiver is showing diffs of source code" 53222 53223 ^ self showingAnyKindOfDiffs! ! 53224 53225 53226!CodeHolder methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:19'! 53227canShowMultipleMessageCategories 53228 "Answer whether the receiver is capable of showing multiple message categories" 53229 53230 ^ false! ! 53231 53232 53233!CodeHolder methodsFor: 'message list' stamp: 'md 2/22/2006 16:10'! 53234decompiledSourceIntoContents 53235 "Obtain a source string by decompiling the method's code, and place 53236 that source string into my contents. Also return the string. 53237 Get temps from source file if shift key is pressed." 53238 53239 | class | 53240 class := self selectedClassOrMetaClass. 53241 "Was method deleted while in another project?" 53242 currentCompiledMethod := (class compiledMethodAt: self selectedMessageName ifAbsent: [^ '']). 53243 53244 contents := (Sensor leftShiftDown not) 53245 ifTrue: [currentCompiledMethod decompileWithTemps] 53246 ifFalse: [currentCompiledMethod decompile]. 53247 contents := contents decompileString asText makeSelectorBoldIn: class. 53248 ^ contents copy! ! 53249 53250!CodeHolder methodsFor: 'message list' stamp: 'sw 8/16/2002 23:23'! 53251selectedBytecodes 53252 "Answer text to show in a code pane when in showing-byte-codes mode" 53253 53254 ^ (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName ifAbsent: [^ '' asText]) symbolic asText! ! 53255 53256!CodeHolder methodsFor: 'message list' stamp: 'md 2/20/2006 15:02'! 53257selectedMessage 53258 "Answer a copy of the source code for the selected message. This generic version is probably actually never reached, since every subclass probably reimplements and does not send to super. In time, ideally, most, or all, reimplementors would vanish and all would defer instead to a universal version right here. Everything in good time." 53259 53260 | class selector method | 53261 contents ifNotNil: [^ contents copy]. 53262 53263 self showingDecompile ifTrue:[^ self decompiledSourceIntoContents]. 53264 53265 class := self selectedClassOrMetaClass. 53266 (class isNil or: [(selector := self selectedMessageName) isNil]) ifTrue: [^ '']. 53267 method := class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" 53268 currentCompiledMethod := method. 53269 53270 ^ contents := (self showComment 53271 ifFalse: [self sourceStringPrettifiedAndDiffed] 53272 ifTrue: [ self commentContents]) 53273 copy asText makeSelectorBoldIn: class! ! 53274 53275!CodeHolder methodsFor: 'message list' stamp: 'alain.plantec 5/18/2009 15:44'! 53276sourceStringPrettifiedAndDiffed 53277 "Answer a copy of the source code for the selected message, transformed by diffing and pretty-printing exigencies" 53278 53279 | class selector sourceString | 53280 class := self selectedClassOrMetaClass. 53281 selector := self selectedMessageName. 53282 (class isNil or: [selector isNil]) ifTrue: [^'missing']. 53283 sourceString := class ultimateSourceCodeAt: selector ifAbsent: [^'error']. 53284 self validateMessageSource: sourceString forSelector: selector. 53285 (#(#prettyPrint #prettyDiffs) 53286 includes: contentsSymbol) 53287 ifTrue: 53288 [sourceString := class prettyPrinterClass 53289 format: sourceString 53290 in: class 53291 notifying: nil]. 53292 self showingAnyKindOfDiffs 53293 ifTrue: [sourceString := self diffFromPriorSourceFor: sourceString]. 53294 ^sourceString! ! 53295 53296!CodeHolder methodsFor: 'message list' stamp: 'sd 11/20/2005 21:27'! 53297validateMessageSource: sourceString forSelector: aSelector 53298 "Check whether there is evidence that method source is invalid" 53299 53300 | sourcesName | 53301 (self selectedClass compilerClass == Object compilerClass 53302 and: [(sourceString asString findString: aSelector keywords first ) ~= 1]) 53303 ifTrue: [sourcesName := FileDirectory localNameFor: SmalltalkImage current sourcesName. 53304 self inform: 'There may be a problem with your sources file!! 53305 53306The source code for every method should (usually) start with the 53307method selector but this is not the case with this method!! You may 53308proceed with caution but it is recommended that you get a new source file. 53309 53310This can happen if you download the "' , sourcesName , '" file, 53311or the ".changes" file you use, as TEXT. It must be transfered 53312in BINARY mode, even if it looks like a text file, 53313to preserve the CR line ends. 53314 53315Mac users: This may have been caused by Stuffit Expander. 53316To prevent the files above to be converted to Mac line ends 53317when they are expanded, do this: Start the program, then 53318from Preferences... in the File menu, choose the Cross 53319Platform panel, then select "Never" and press OK. 53320Then expand the compressed archive again. 53321 53322(Occasionally, the source code for a method may legitimately 53323start with a non-alphabetic character -- for example, Behavior 53324method #formalHeaderPartsFor:. In such rare cases, you can 53325happily disregard this warning.)'].! ! 53326 53327 53328!CodeHolder methodsFor: 'message list menu' stamp: 'sd 11/20/2005 21:27'! 53329messageListKey: aChar from: view 53330 "Respond to a Command key. I am a model with a code pane, and I also 53331 have a listView that has a list of methods. The view knows how to get 53332 the list and selection." 53333 53334 | sel class | 53335 aChar == $D ifTrue: [^ self toggleDiffing]. 53336 53337 sel := self selectedMessageName. 53338 aChar == $m ifTrue: "These next two put up a type in if no message selected" 53339 [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation]. 53340 aChar == $n ifTrue: 53341 [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation]. 53342 53343 "The following require a class selection" 53344 (class := self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view]. 53345 aChar == $b ifTrue: [^ Browser fullOnClass: class selector: sel]. 53346 aChar == $N ifTrue: [^ self browseClassRefs]. 53347 aChar == $i ifTrue: [^ self methodHierarchy]. 53348 aChar == $h ifTrue: [^ self classHierarchy]. 53349 aChar == $p ifTrue: [^ self browseFullProtocol]. 53350 53351 "The following require a method selection" 53352 sel ifNotNil: 53353 [aChar == $o ifTrue: [^ self fileOutMessage]. 53354 aChar == $c ifTrue: [^ self copySelector]. 53355 aChar == $v ifTrue: [^ self browseVersions]. 53356 aChar == $O ifTrue: [^ self openSingleMessageBrowser]. 53357 aChar == $x ifTrue: [^ self removeMessage]. 53358 aChar == $d ifTrue: [^ self removeMessageFromBrowser]. 53359 53360 (aChar == $C and: [self canShowMultipleMessageCategories]) 53361 ifTrue: [^ self showHomeCategory]]. 53362 53363 ^ self arrowKey: aChar from: view! ! 53364 53365 53366!CodeHolder methodsFor: 'misc' stamp: 'md 2/24/2006 15:25'! 53367addOptionalButtonsTo: window at: fractions plus: verticalOffset 53368 "If the receiver wishes it, add a button pane to the window, and 53369 answer the verticalOffset plus the height added" 53370 | delta buttons divider | 53371 self wantsOptionalButtons 53372 ifFalse: [^ verticalOffset]. 53373 delta := self defaultButtonPaneHeight. 53374 buttons := self optionalButtonRow color: Color white. 53375 divider := BorderedSubpaneDividerMorph forBottomEdge. 53376 divider extent: 4 @ 4; 53377 color: Color gray; 53378 borderColor: #simple; 53379 borderWidth: 1. 53380 window 53381 addMorph: buttons 53382 fullFrame: (LayoutFrame 53383 fractions: fractions 53384 offsets: (0 @ verticalOffset corner: 0 @ (verticalOffset + delta - 1))). 53385 window 53386 addMorph: divider 53387 fullFrame: (LayoutFrame 53388 fractions: fractions 53389 offsets: (0 @ (verticalOffset + delta - 1) corner: 0 @ (verticalOffset + delta))). 53390 ^ verticalOffset + delta! ! 53391 53392!CodeHolder methodsFor: 'misc' stamp: 'nk 4/10/2001 07:52'! 53393getSelectorAndSendQuery: querySelector to: queryPerformer 53394 "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained as its argument. If no message is currently selected, then obtain a method name from a user type-in" 53395 53396 self getSelectorAndSendQuery: querySelector to: queryPerformer with: { }. 53397! ! 53398 53399!CodeHolder methodsFor: 'misc' stamp: 'StephaneDucasse 10/15/2009 18:01'! 53400getSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs 53401 "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained and queryArgs as its arguments. If no message is currently selected, then obtain a method name from a user type-in" 53402 53403 | strm array | 53404 strm := (array := Array new: queryArgs size + 1) writeStream. 53405 strm nextPut: nil. 53406 strm nextPutAll: queryArgs. 53407 53408 self selectedMessageName ifNil: [ | selector | 53409 selector := UIManager default request: 'Type selector:' initialAnswer: 'flag:'. 53410 selector ifNil: [selector := String new]. 53411 selector := selector copyWithout: Character space. 53412 ^ selector isEmptyOrNil ifFalse: [ 53413 (Symbol hasInterned: selector 53414 ifTrue: [ :aSymbol | 53415 array at: 1 put: aSymbol. 53416 queryPerformer perform: querySelector withArguments: array]) 53417 ifFalse: [ self inform: 'no such selector'] 53418 ] 53419 ]. 53420 53421 self selectMessageAndEvaluate: [:selector | 53422 array at: 1 put: selector. 53423 queryPerformer perform: querySelector withArguments: array 53424 ]! ! 53425 53426!CodeHolder methodsFor: 'misc' stamp: 'md 2/24/2006 15:28'! 53427isThereAnOverride 53428 "Answer whether any subclass of my selected class implements my 53429 selected selector" 53430 | aName aClass | 53431 aName := self selectedMessageName ifNil: [^ false]. 53432 aClass := self selectedClassOrMetaClass ifNil: [^ false]. 53433 aClass allSubclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]]. 53434 ^ false! ! 53435 53436!CodeHolder methodsFor: 'misc' stamp: 'md 2/24/2006 15:28'! 53437isThisAnOverride 53438 "Answer whether any superclass of my selected class implements my selected selector" 53439 | aName aClass | 53440 aName := self selectedMessageName ifNil: [^ false]. 53441 aClass := self selectedClassOrMetaClass ifNil: [^ false]. 53442 aClass allSuperclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]]. 53443 ^ false! ! 53444 53445!CodeHolder methodsFor: 'misc' stamp: 'sd 11/20/2005 21:27'! 53446menuButton 53447 "Answer a button that brings up a menu. Useful when adding new features, but at present is between uses" 53448 53449 | aButton | 53450 aButton := IconicButton new target: self; 53451 borderWidth: 0; 53452 labelGraphic: (ScriptingSystem formAtKey: #TinyMenu); 53453 color: Color transparent; 53454 actWhen: #buttonDown; 53455 actionSelector: #offerMenu; 53456 yourself. 53457 aButton setBalloonText: 'click here to get a menu with further options'. 53458 ^ aButton 53459! ! 53460 53461!CodeHolder methodsFor: 'misc' stamp: 'sw 9/27/2001 01:26'! 53462modelWakeUpIn: aWindow 53463 "The window has been activated. Respond to possible changes that may have taken place while it was inactive" 53464 53465 self updateListsAndCodeIn: aWindow. 53466 self decorateButtons. 53467 self refreshAnnotation. 53468 53469 super modelWakeUpIn: aWindow! ! 53470 53471!CodeHolder methodsFor: 'misc' stamp: 'alain.plantec 2/6/2009 16:46'! 53472okayToAccept 53473 "Answer whether it is okay to accept the receiver's input" 53474 53475 self showingDocumentation ifTrue: 53476 [self inform: 53477'Sorry, for the moment you can 53478only submit changes here when 53479you are showing source. Later, you 53480will be able to edit the isolated comment 53481here and save it back, but only if you 53482implement it!!.' translated. 53483 ^ false]. 53484 53485 self showingAnyKindOfDiffs ifFalse: 53486 [^ true]. 53487 ^ self confirm: 53488'Caution!! 53489You are "showing diffs" here, so 53490there is a danger that some of the text in the 53491code pane is contaminated by the "diff" display' translated 53492! ! 53493 53494!CodeHolder methodsFor: 'misc' stamp: 'sd 11/20/2005 21:27'! 53495priorSourceOrNil 53496 "If the currently-selected method has a previous version, return its source, else return nil" 53497 | aClass aSelector changeRecords | 53498 (aClass := self selectedClassOrMetaClass) ifNil: [^ nil]. 53499 (aSelector := self selectedMessageName) ifNil: [^ nil]. 53500 changeRecords := aClass changeRecordsAt: aSelector. 53501 (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil]. 53502 ^ (changeRecords at: 2) string 53503! ! 53504 53505!CodeHolder methodsFor: 'misc' stamp: 'marcus.denker 11/10/2008 10:04'! 53506refreshAnnotation 53507 "If the receiver has an annotation pane that does not bear unaccepted edits, refresh it" 53508 53509 (self dependents detect: [:m | (m inheritsFromAnyIn: #('PluggableTextView' 'PluggableTextMorph')) and: [m getTextSelector == #annotation]] ifNone: [nil]) ifNotNil: 53510 [:aPane | aPane hasUnacceptedEdits ifFalse: 53511 [aPane update: #annotation]]! ! 53512 53513!CodeHolder methodsFor: 'misc' stamp: 'stephane.ducasse 10/26/2008 15:13'! 53514refusesToAcceptCode 53515 "Answer whether receiver, given its current contentsSymbol, could accept code happily if asked to" 53516 53517 ^ (#(byteCodes documentation) includes: self contentsSymbol)! ! 53518 53519!CodeHolder methodsFor: 'misc' stamp: 'sd 11/20/2005 21:27'! 53520releaseCachedState 53521 "Can always be found again. Don't write on a file." 53522 currentCompiledMethod := nil.! ! 53523 53524!CodeHolder methodsFor: 'misc' stamp: 'sd 11/20/2005 21:27'! 53525sampleInstanceOfSelectedClass 53526 | aClass | 53527 "Return a sample instance of the class currently being pointed at" 53528 (aClass := self selectedClassOrMetaClass) ifNil: [^ nil]. 53529 ^ aClass theNonMetaClass initializedInstance! ! 53530 53531!CodeHolder methodsFor: 'misc' stamp: 'rbb 3/1/2005 10:31'! 53532sendQuery: querySelector to: queryPerformer 53533 "Apply a query to the primary selector associated with the current context. If no such selection exists, obtain one by user type-in. Then send querySelector to queryPerformer with the selector as its argument." 53534 53535 | aSelector aString | 53536 aSelector := self selectedMessageName ifNil: 53537 [aString :=UIManager default request: 'Type selector:' initialAnswer: 'flag:'. 53538 ^ aString isEmptyOrNil ifFalse: 53539 [(Symbol hasInterned: aString ifTrue: 53540 [:aSymbol | queryPerformer perform: querySelector with: aSymbol]) 53541 ifFalse: 53542 [self inform: 'no such selector']]]. 53543 53544 queryPerformer perform: querySelector with: aSelector! ! 53545 53546!CodeHolder methodsFor: 'misc' stamp: 'sd 11/20/2005 21:27'! 53547setClassAndSelectorIn: csBlock 53548 "Evaluate csBlock with my selected class and and selector as its arguments; provide nil arguments if I don't have a method currently selected" 53549 53550 | aName | 53551 (aName := self selectedMessageName) 53552 ifNil: 53553 [csBlock value: nil value: nil] 53554 ifNotNil: 53555 [csBlock value: self selectedClassOrMetaClass value: aName] 53556! ! 53557 53558!CodeHolder methodsFor: 'misc' stamp: 'sw 2/22/2001 06:37'! 53559suggestCategoryToSpawnedBrowser: aBrowser 53560 "aBrowser is a message-category browser being spawned from the receiver. Tell it what it needs to know to get its category info properly set up." 53561 53562 aBrowser setOriginalCategoryIndexForCurrentMethod! ! 53563 53564!CodeHolder methodsFor: 'misc' stamp: 'rbb 3/1/2005 10:31'! 53565useSelector: incomingSelector orGetSelectorAndSendQuery: querySelector to: queryPerformer 53566 "If incomingSelector is not nil, use it, else obtain a selector from user type-in. Using the determined selector, send the query to the performer provided." 53567 53568 | aSelector | 53569 incomingSelector 53570 ifNotNil: 53571 [queryPerformer perform: querySelector with: incomingSelector] 53572 ifNil: 53573 [aSelector :=UIManager default request: 'Type selector:' initialAnswer: 'flag:'. 53574 aSelector isEmptyOrNil ifFalse: 53575 [(Symbol hasInterned: aSelector ifTrue: 53576 [:aSymbol | queryPerformer perform: querySelector with: aSymbol]) 53577 ifFalse: 53578 [self inform: 'no such selector']]]! ! 53579 53580 53581!CodeHolder methodsFor: 'self-updating' stamp: 'nk 4/29/2004 12:25'! 53582didCodeChangeElsewhere 53583 "Determine whether the code for the currently selected method and class has been changed somewhere else." 53584 | aClass aSelector aCompiledMethod | 53585 currentCompiledMethod ifNil: [^ false]. 53586 53587 (aClass := self selectedClassOrMetaClass) ifNil: [^ false]. 53588 53589 (aSelector := self selectedMessageName) ifNil: [^ false]. 53590 53591 self classCommentIndicated 53592 ifTrue: [^ currentCompiledMethod ~~ aClass organization commentRemoteStr]. 53593 53594 ^ (aCompiledMethod := aClass compiledMethodAt: aSelector ifAbsent: [^ false]) ~~ currentCompiledMethod 53595 and: [aCompiledMethod last ~= 0 "either not yet installed" 53596 or: [ currentCompiledMethod last = 0 "or these methods don't have source pointers"]]! ! 53597 53598!CodeHolder methodsFor: 'self-updating' stamp: 'sw 10/19/1999 08:37'! 53599stepIn: aSystemWindow 53600 self updateListsAndCodeIn: aSystemWindow! ! 53601 53602!CodeHolder methodsFor: 'self-updating' stamp: 'sw 2/14/2001 15:34'! 53603updateCodePaneIfNeeded 53604 "If the code for the currently selected method has changed underneath me, then update the contents of my code pane unless it holds unaccepted edits" 53605 53606 self didCodeChangeElsewhere 53607 ifTrue: 53608 [self hasUnacceptedEdits 53609 ifFalse: 53610 [self setContentsToForceRefetch. 53611 self contentsChanged] 53612 ifTrue: 53613 [self changed: #codeChangedElsewhere]]! ! 53614 53615!CodeHolder methodsFor: 'self-updating' stamp: 'sw 10/19/1999 14:14'! 53616updateListsAndCodeIn: aWindow 53617 super updateListsAndCodeIn: aWindow. 53618 self updateCodePaneIfNeeded! ! 53619 53620!CodeHolder methodsFor: 'self-updating' stamp: 'sw 10/20/1999 12:22'! 53621wantsStepsIn: aWindow 53622 ^ Preferences smartUpdating! ! 53623 53624 53625!CodeHolder methodsFor: 'tiles' stamp: 'alain.plantec 5/30/2008 11:23'! 53626addModelItemsToWindowMenu: aMenu 53627 "Add model-related item to the window menu" 53628 53629 super addModelItemsToWindowMenu: aMenu. 53630 aMenu addLine. 53631 aMenu add: 'what to show...' translated target: self action: #offerWhatToShowMenu! ! 53632 53633 53634!CodeHolder methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:32'! 53635buildCodeProvenanceButtonWith: builder 53636 | buttonSpec | 53637 buttonSpec := builder pluggableActionButtonSpec new. 53638 buttonSpec model: self. 53639 buttonSpec label: #codePaneProvenanceString. 53640 buttonSpec action: #offerWhatToShowMenu. 53641 buttonSpec help: 'Governs what view is shown in the code pane. Click here to change the view'. 53642 ^buttonSpec! ! 53643 53644!CodeHolder methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:32'! 53645buildOptionalButtonsWith: builder 53646 53647 | panelSpec buttonSpec | 53648 panelSpec := builder pluggablePanelSpec new. 53649 panelSpec children: OrderedCollection new. 53650 self optionalButtonPairs do:[:spec| 53651 buttonSpec := builder pluggableActionButtonSpec new. 53652 buttonSpec model: self. 53653 buttonSpec label: spec first. 53654 buttonSpec action: spec second. 53655 spec second == #methodHierarchy ifTrue:[ 53656 buttonSpec color: #inheritanceButtonColor. 53657 ]. 53658 spec size > 2 ifTrue:[buttonSpec help: spec third]. 53659 panelSpec children add: buttonSpec. 53660 ]. 53661 "What to show" 53662 panelSpec children add: (self buildCodeProvenanceButtonWith: builder). 53663 53664 panelSpec layout: #horizontal. "buttons" 53665 ^panelSpec! ! 53666 53667!CodeHolder methodsFor: 'toolbuilder' stamp: 'marcus.denker 8/17/2008 21:02'! 53668color 53669 53670 | flags aColor | 53671 flags := 0. 53672 self isThisAnOverride ifTrue: [ flags := flags bitOr: 4 ]. 53673 currentCompiledMethod sendsToSuper ifTrue: [ flags := flags bitOr: 2 ]. 53674 self isThereAnOverride ifTrue: [ flags := flags bitOr: 1 ]. 53675 aColor := { 53676 Color transparent. 53677 Color tan lighter. 53678 Color green muchLighter. 53679 Color blue muchLighter. 53680 Color red muchLighter. "has super but doesn't call it" 53681 (Color r: 0.94 g: 0.823 b: 0.673). "has sub; has super but doesn't call it" 53682 Color green muchLighter. 53683 Color blue muchLighter. 53684 } at: flags + 1. 53685 53686 ^aColor! ! 53687 53688!CodeHolder methodsFor: 'toolbuilder' stamp: 'marcus.denker 8/17/2008 21:04'! 53689inheritanceButtonColor 53690 "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." 53691 53692 ((currentCompiledMethod isKindOf: CompiledMethod) and: [Preferences decorateBrowserButtons]) 53693 ifFalse: [^Color transparent]. 53694 53695 "This table duplicates the old logic, but adds two new colors for the cases where there is a superclass definition, but this method doesn't call it." 53696 53697 ^ self color 53698 53699! ! 53700 53701 53702!CodeHolder methodsFor: 'traits' stamp: 'alain.plantec 5/30/2008 11:25'! 53703makeSampleInstance 53704 | aClass nonMetaClass anInstance | 53705 ((aClass := self selectedClassOrMetaClass) isNil 53706 or: [aClass isTrait]) 53707 ifTrue: [^ self]. 53708 nonMetaClass := aClass theNonMetaClass. 53709 anInstance := self sampleInstanceOfSelectedClass. 53710 (anInstance isNil 53711 and: [nonMetaClass ~~ UndefinedObject]) 53712 ifTrue: [^ self inform: 'Sorry, cannot make an instance of ' , nonMetaClass name]. 53713 anInstance isMorph 53714 ifTrue: [self currentHand attachMorph: anInstance] 53715 ifFalse: [anInstance inspectWithLabel: 'An instance of ' , nonMetaClass name]! ! 53716 53717!CodeHolder methodsFor: 'traits' stamp: 'alain.plantec 2/6/2009 16:49'! 53718showUnreferencedClassVars 53719 "Search for all class variables known to the selected class, and put up a 53720 list of those that have no references anywhere in the system. The 53721 search includes superclasses, so that you don't need to navigate your 53722 way to the class that defines each class variable in order to determine 53723 whether it is unreferenced" 53724 | cls aList aReport | 53725 ((cls := self selectedClass) isNil or: [cls isTrait]) ifTrue: [^ self]. 53726 aList := self systemNavigation allUnreferencedClassVariablesOf: cls. 53727 aList size == 0 53728 ifTrue: [^ self inform: 'There are no unreferenced 53729class variables in 53730' , cls name]. 53731 aReport := String 53732 streamContents: [:aStream | 53733 aStream nextPutAll: 'Unreferenced class variable(s) in ' translated, cls name; 53734 cr. 53735 aList 53736 do: [:el | aStream tab; nextPutAll: el; cr]]. 53737 Transcript cr; show: aReport. 53738 self inform: aReport! ! 53739 53740!CodeHolder methodsFor: 'traits' stamp: 'alain.plantec 2/6/2009 16:51'! 53741showUnreferencedInstVars 53742 "Search for all instance variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each inst variable in order to determine whether it is unreferenced" 53743 53744 | cls aList aReport | 53745 ((cls := self selectedClassOrMetaClass) isNil or: [cls isTrait]) ifTrue: [^ self]. 53746 aList := cls allUnreferencedInstanceVariables. 53747 aList size == 0 ifTrue: [^ self inform: 'There are no unreferenced 53748instance variables in 53749', cls name]. 53750 aReport := String streamContents: 53751 [:aStream | 53752 aStream nextPutAll: 'Unreferenced instance variable(s) in ' translated, cls name; cr. 53753 aList do: [:el | aStream tab; nextPutAll: el; cr]]. 53754 Transcript cr; show: aReport. 53755 self inform: aReport! ! 53756 53757!CodeHolder methodsFor: 'traits' stamp: 'alain.plantec 5/30/2008 11:27'! 53758spawnHierarchy 53759 "Create and schedule a new hierarchy browser on the currently selected 53760 class or meta." 53761 | newBrowser aSymbol aBehavior messageCatIndex selectedClassOrMetaClass | 53762 (selectedClassOrMetaClass := self selectedClassOrMetaClass) 53763 ifNil: [^ self]. 53764 selectedClassOrMetaClass isTrait 53765 ifTrue: [^ self]. 53766 newBrowser := HierarchyBrowser new initHierarchyForClass: selectedClassOrMetaClass. 53767 ((aSymbol := self selectedMessageName) notNil 53768 and: [(MessageSet isPseudoSelector: aSymbol) not]) 53769 ifTrue: [aBehavior := selectedClassOrMetaClass. 53770 messageCatIndex := aBehavior organization numberOfCategoryOfElement: aSymbol. 53771 newBrowser messageCategoryListIndex: messageCatIndex + 1. 53772 newBrowser 53773 messageListIndex: ((aBehavior organization listAtCategoryNumber: messageCatIndex) 53774 indexOf: aSymbol)]. 53775 Browser 53776 openBrowserView: (newBrowser openSystemCatEditString: nil) 53777 label: newBrowser labelString. 53778 newBrowser assureSelectionsShow! ! 53779 53780 53781!CodeHolder methodsFor: 'what to show' stamp: 'alain.plantec 5/30/2008 11:22'! 53782addContentsTogglesTo: aMenu 53783 "Add updating menu toggles governing contents to aMenu." 53784 self contentsSymbolQuints 53785 do: [:aQuint | aQuint == #- 53786 ifTrue: [aMenu addLine] 53787 ifFalse: [aMenu 53788 addUpdating: aQuint third 53789 target: self 53790 action: aQuint second. 53791 aMenu balloonTextForLastItem: aQuint fifth]]! ! 53792 53793!CodeHolder methodsFor: 'what to show' stamp: 'alain.plantec 5/30/2008 11:26'! 53794offerWhatToShowMenu 53795 "Offer a menu governing what to show" 53796 | aMenu | 53797 aMenu := MenuMorph new defaultTarget: self. 53798 aMenu addTitle: 'What to show' translated. 53799 aMenu addStayUpItem. 53800 self addContentsTogglesTo: aMenu. 53801 aMenu popUpInWorld! ! 53802 53803!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 16:36'! 53804prettyPrintString 53805 "Answer whether the receiver is showing pretty-print" 53806 53807 ^ ((contentsSymbol == #prettyPrint) 53808 ifTrue: 53809 ['<yes>'] 53810 ifFalse: 53811 ['<no>']), 'prettyPrint'! ! 53812 53813!CodeHolder methodsFor: 'what to show' stamp: 'sd 11/20/2005 21:27'! 53814setContentsToForceRefetch 53815 "Set the receiver's contents such that on the next update the contents will be formulated afresh. This is a critical and obscure difference between Browsers on the one hand and MessageSets on the other, and has over the years been the source of much confusion and much difficulty. By centralizing the different handling here, we don't need so many idiosyncratic overrides in MessageSet any more" 53816 53817 contents := nil! ! 53818 53819!CodeHolder methodsFor: 'what to show' stamp: 'sd 11/20/2005 21:27'! 53820showByteCodes: aBoolean 53821 "Get into or out of bytecode-showoing mode" 53822 53823 self okToChange ifFalse: [^ self changed: #flash]. 53824 aBoolean 53825 ifTrue: 53826 [contentsSymbol := #byteCodes] 53827 ifFalse: 53828 [contentsSymbol == #byteCodes ifTrue: [contentsSymbol := #source]]. 53829 self contentsChanged! ! 53830 53831!CodeHolder methodsFor: 'what to show' stamp: 'sw 12/5/2000 11:32'! 53832showComment 53833 "Answer whether the receiver should show documentation rather than, say, source code" 53834 53835 ^ self contentsSymbol == #documentation 53836! ! 53837 53838!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 09:14'! 53839showDecompile: aBoolean 53840 "Set the decompile toggle as indicated" 53841 53842 self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#decompile])! ! 53843 53844!CodeHolder methodsFor: 'what to show' stamp: 'sw 12/5/2000 12:25'! 53845showDocumentation: aBoolean 53846 "Set the showDocumentation toggle as indicated" 53847 53848 self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#documentation])! ! 53849 53850!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 18:05'! 53851showingByteCodes 53852 "Answer whether the receiver is showing bytecodes" 53853 53854 ^ contentsSymbol == #byteCodes! ! 53855 53856!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 18:28'! 53857showingByteCodesString 53858 "Answer whether the receiver is showing bytecodes" 53859 53860 ^ (self showingByteCodes 53861 ifTrue: 53862 ['<yes>'] 53863 ifFalse: 53864 ['<no>']), 'byteCodes'! ! 53865 53866!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 06:52'! 53867showingDecompile 53868 "Answer whether the receiver should show decompile rather than, say, source code" 53869 53870 ^ self contentsSymbol == #decompile 53871! ! 53872 53873!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 06:50'! 53874showingDecompileString 53875 "Answer a string characerizing whether decompilation is showing" 53876 53877 ^ (self showingDecompile 53878 ifTrue: 53879 ['<yes>'] 53880 ifFalse: 53881 ['<no>']), 'decompile'! ! 53882 53883!CodeHolder methodsFor: 'what to show' stamp: 'sw 12/5/2000 12:12'! 53884showingDocumentation 53885 "Answer whether the receiver should show documentation rather than, say, source code" 53886 53887 ^ self contentsSymbol == #documentation 53888! ! 53889 53890!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 20:05'! 53891showingDocumentationString 53892 "Answer a string characerizing whether documentation is showing" 53893 53894 ^ (self showingDocumentation 53895 ifTrue: 53896 ['<yes>'] 53897 ifFalse: 53898 ['<no>']), 'documentation'! ! 53899 53900!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 19:43'! 53901showingPlainSource 53902 "Answer whether the receiver is showing plain source" 53903 53904 ^ contentsSymbol == #source! ! 53905 53906!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 09:31'! 53907showingPlainSourceString 53908 "Answer a string telling whether the receiver is showing plain source" 53909 53910 ^ (self showingPlainSource 53911 ifTrue: 53912 ['<yes>'] 53913 ifFalse: 53914 ['<no>']), 'source'! ! 53915 53916!CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 18:36'! 53917showingPrettyPrint 53918 "Answer whether the receiver is showing pretty-print" 53919 53920 ^ contentsSymbol == #prettyPrint! ! 53921 53922!CodeHolder methodsFor: 'what to show' stamp: 'sw 12/5/2000 11:48'! 53923showingSource 53924 "Answer whether the receiver is currently showing source code" 53925 53926 ^ self contentsSymbol == #source 53927! ! 53928 53929!CodeHolder methodsFor: 'what to show' stamp: 'marcus.denker 9/20/2008 20:31'! 53930toggleDecompile 53931 "Toggle the setting of the showingDecompile flag, unless there are unsubmitted edits that the user declines to discard" 53932 53933 | wasShowing | 53934 self okToChange ifTrue: 53935 [wasShowing := self showingDecompile. 53936 self showDecompile: wasShowing not. 53937 self setContentsToForceRefetch. 53938 self contentsChanged] 53939 53940! ! 53941 53942!CodeHolder methodsFor: 'what to show' stamp: 'marcus.denker 9/20/2008 20:32'! 53943toggleShowDocumentation 53944 "Toggle the setting of the showingDocumentation flag, unless there are unsubmitted edits that the user declines to discard" 53945 53946 | wasShowing | 53947 self okToChange ifTrue: 53948 [wasShowing := self showingDocumentation. 53949 self showDocumentation: wasShowing not. 53950 self setContentsToForceRefetch. 53951 self contentsChanged] 53952 53953! ! 53954 53955!CodeHolder methodsFor: 'what to show' stamp: 'marcus.denker 9/20/2008 20:32'! 53956toggleShowingByteCodes 53957 "Toggle whether the receiver is showing bytecodes" 53958 53959 self showByteCodes: self showingByteCodes not. 53960 self setContentsToForceRefetch. 53961 self contentsChanged! ! 53962Object subclass: #CodeLoader 53963 instanceVariableNames: 'baseURL sourceFiles segments publicKey' 53964 classVariableNames: 'DefaultBaseURL DefaultKey' 53965 poolDictionaries: '' 53966 category: 'System-Download'! 53967!CodeLoader commentStamp: '<historical>' prior: 0! 53968CodeLoader provides a simple facility for loading code from the network. 53969 53970Examples: 53971 | loader | 53972 loader _ CodeLoader new. 53973 loader baseURL:'http://isgwww.cs.uni-magdeburg.de/~raab/test/'. 53974 loader localCache: #('.cache' 'source'). 53975 "Sources and segments can be loaded in parallel" 53976 loader loadSourceFiles: #('file1.st' 'file2.st.gz'). 53977 loader localCache: #('.cache' 'segments'). 53978 loader loadSegments: #('is1.extseg' 'is2.extseg.gz'). 53979 "Install sources first - will wait until the files are actually loaded" 53980 loader installSourceFiles. 53981 "And then the segments" 53982 loader installSegments.! 53983 53984 53985!CodeLoader methodsFor: 'accessing' stamp: 'ar 12/13/1999 18:19'! 53986baseURL 53987 ^baseURL! ! 53988 53989!CodeLoader methodsFor: 'accessing' stamp: 'ar 12/13/1999 18:19'! 53990baseURL: aString 53991 baseURL := aString.! ! 53992 53993!CodeLoader methodsFor: 'accessing' stamp: 'ar 12/22/1999 15:07'! 53994publicKey 53995 ^publicKey! ! 53996 53997!CodeLoader methodsFor: 'accessing' stamp: 'ar 12/22/1999 15:07'! 53998publicKey: aPublicKey 53999 publicKey := aPublicKey! ! 54000 54001 54002!CodeLoader methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:47'! 54003initialize 54004 super initialize. 54005 publicKey := DefaultKey. 54006 baseURL := self class defaultBaseURL! ! 54007 54008 54009!CodeLoader methodsFor: 'installing' stamp: 'RAA 2/19/2001 08:23'! 54010installProject 54011 "Assume that we're loading a single file and it's a project" 54012 | aStream | 54013 aStream := sourceFiles first contentStream. 54014 aStream ifNil:[^self error:'Project was not loaded']. 54015 ProjectLoading 54016 openName: nil "<--do we want to cache this locally? Need a name if so" 54017 stream: aStream 54018 fromDirectory: nil 54019 withProjectView: nil. 54020! ! 54021 54022!CodeLoader methodsFor: 'installing' stamp: 'sd 1/30/2004 15:16'! 54023installSegment: reqEntry 54024 "Install the previously loaded segment" 54025 | contentStream contents trusted | 54026 contentStream := reqEntry value contentStream. 54027 contentStream ifNil:[^self error:'No content to install: ', reqEntry key printString]. 54028 trusted := SecurityManager default positionToSecureContentsOf: contentStream. 54029 trusted ifFalse:[(SecurityManager default enterRestrictedMode) ifFalse:[ 54030 contentStream close. 54031 ^self error:'Insecure content encountered: ', reqEntry key printString]]. 54032 contents := contentStream ascii upToEnd unzipped. 54033 (contentStream respondsTo: #close) ifTrue:[contentStream close]. 54034 ^(RWBinaryOrTextStream with: contents) reset fileInObjectAndCode install.! ! 54035 54036!CodeLoader methodsFor: 'installing' stamp: 'mir 1/20/2000 13:37'! 54037installSegments 54038 "Install the previously loaded segments" 54039 segments == nil ifTrue:[^self]. 54040 segments do:[:req| self installSegment: req]. 54041 segments := nil.! ! 54042 54043!CodeLoader methodsFor: 'installing' stamp: 'sd 1/30/2004 15:16'! 54044installSourceFile: aStream 54045 "Install the previously loaded source file" 54046 | contents trusted | 54047 aStream ifNil:[^self error:'No content to install']. 54048 trusted := SecurityManager default positionToSecureContentsOf: aStream. 54049 trusted ifFalse:[(SecurityManager default enterRestrictedMode) 54050 ifFalse:[ aStream close. 54051 ^ self error:'Insecure content encountered']]. 54052 contents := aStream ascii upToEnd unzipped. 54053 (aStream respondsTo: #close) ifTrue:[aStream close]. 54054 ^(RWBinaryOrTextStream with: contents) reset fileIn! ! 54055 54056!CodeLoader methodsFor: 'installing' stamp: 'ar 12/22/1999 15:02'! 54057installSourceFiles 54058 "Install the previously loaded source files" 54059 sourceFiles == nil ifTrue:[^self]. 54060 sourceFiles do:[:req| self installSourceFile: req contentStream]. 54061 sourceFiles := nil.! ! 54062 54063 54064!CodeLoader methodsFor: 'loading' stamp: 'mir 10/13/2000 12:24'! 54065loadSegments: anArray 54066 "Load all the source files in the given array." 54067 | loader request reqName | 54068 loader := HTTPLoader default. 54069 segments := anArray collect:[:name | 54070 reqName := (FileDirectory extensionFor: name) isEmpty 54071 ifTrue: [FileDirectory fileName: name extension: ImageSegment compressedFileExtension] 54072 ifFalse: [name]. 54073 request := self createRequestFor: reqName in: loader. 54074 name->request]. 54075! ! 54076 54077!CodeLoader methodsFor: 'loading' stamp: 'ar 12/14/1999 14:40'! 54078loadSourceFiles: anArray 54079 "Load all the source files in the given array." 54080 | loader request | 54081 loader := HTTPLoader default. 54082 sourceFiles := anArray collect:[:name| 54083 request := self createRequestFor: name in: loader. 54084 request]. 54085! ! 54086 54087 54088!CodeLoader methodsFor: 'private' stamp: 'mir 2/2/2001 14:44'! 54089createRequestFor: name in: aLoader 54090 "Create a URL request for the given string, which can be cached locally." 54091 | request | 54092 request := HTTPLoader httpRequestClass for: self baseURL , name in: aLoader. 54093 aLoader addRequest: request. "fetch from URL" 54094 ^request! ! 54095 54096!CodeLoader methodsFor: 'private' stamp: 'avi 4/30/2004 01:40'! 54097httpRequestClass 54098 ^HTTPDownloadRequest! ! 54099 54100"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 54101 54102CodeLoader class 54103 instanceVariableNames: ''! 54104 54105!CodeLoader class methodsFor: 'accessing' stamp: 'mir 1/11/2000 13:45'! 54106defaultBaseURL 54107 ^DefaultBaseURL ifNil: ['']! ! 54108 54109!CodeLoader class methodsFor: 'accessing' stamp: 'mir 1/11/2000 13:45'! 54110defaultBaseURL: aURLString 54111 DefaultBaseURL := aURLString! ! 54112 54113!CodeLoader class methodsFor: 'accessing' stamp: 'ar 12/22/1999 15:08'! 54114defaultKey 54115 "Return the default key used for verifying signatures of loaded code" 54116 ^DefaultKey! ! 54117 54118!CodeLoader class methodsFor: 'accessing' stamp: 'mir 1/10/2000 18:16'! 54119defaultKey: aPublicKey 54120 "Store the default key used for verifying signatures of loaded code" 54121 DefaultKey := aPublicKey 54122 "CodeLoader defaultKey: DOLPublicKey" 54123 "CodeLoader defaultKey: (DigitalSignatureAlgorithm testKeySet at: 2)"! ! 54124 54125 54126!CodeLoader class methodsFor: 'utilities' stamp: 'mir 9/6/2000 15:03'! 54127compressFileNamed: aFileName 54128 self compressFileNamed: aFileName in: FileDirectory default! ! 54129 54130!CodeLoader class methodsFor: 'utilities' stamp: 'mir 10/13/2000 13:27'! 54131compressFileNamed: aFileName in: aDirectory 54132 "Compress the currently selected file" 54133 | zipped buffer unzipped zipFileName | 54134 unzipped := aDirectory readOnlyFileNamed: (aDirectory fullNameFor: aFileName). 54135 unzipped binary. 54136 zipFileName := aFileName copyUpToLast: $. . 54137 zipped := aDirectory newFileNamed: (zipFileName, FileDirectory dot, ImageSegment compressedFileExtension). 54138 zipped binary. 54139 zipped := GZipWriteStream on: zipped. 54140 buffer := ByteArray new: 50000. 54141 'Compressing ', zipFileName displayProgressAt: Sensor cursorPoint 54142 from: 0 to: unzipped size 54143 during:[:bar| 54144 [unzipped atEnd] whileFalse:[ 54145 bar value: unzipped position. 54146 zipped nextPutAll: (unzipped nextInto: buffer)]. 54147 zipped close. 54148 unzipped close]. 54149! ! 54150 54151!CodeLoader class methodsFor: 'utilities' stamp: 'mir 1/18/2000 16:22'! 54152exportCategories: catList to: aFileName 54153 "CodeLoader exportCategories: #( 'Game-Animation' 'Game-Framework' ) to: 'Game-Framework'" 54154 54155 | list classList | 54156 classList := OrderedCollection new. 54157 catList do: [:catName | 54158 list := SystemOrganization listAtCategoryNamed: catName asSymbol. 54159 list do: [:nm | classList add: (Smalltalk at: nm); add: (Smalltalk at: nm) class]]. 54160 self exportCodeSegment: aFileName classes: classList keepSource: true! ! 54161 54162!CodeLoader class methodsFor: 'utilities' stamp: 'mir 1/18/2000 20:53'! 54163exportCategoryNamed: catName 54164 "CodeLoader exportCategoryNamed: 'OceanicPanic' " 54165 54166 | list | 54167 list := SystemOrganization listAtCategoryNamed: catName asSymbol. 54168 self exportClassesNamed: list to: catName! ! 54169 54170!CodeLoader class methodsFor: 'utilities' stamp: 'mir 1/18/2000 20:53'! 54171exportClassesNamed: classNameList to: aFileName 54172 54173 | classList | 54174 classList := OrderedCollection new. 54175 classNameList do: [:nm | classList add: (Smalltalk at: nm); add: (Smalltalk at: nm) class]. 54176 self exportCodeSegment: aFileName classes: classList keepSource: true! ! 54177 54178!CodeLoader class methodsFor: 'utilities' stamp: 'eem 7/1/2009 13:51'! 54179exportCodeSegment: exportName classes: aClassList keepSource: keepSources 54180 54181 "Code for writing out a specific category of classes as an external image segment. Perhaps this should be a method." 54182 54183 | is oldMethods newMethods classList symbolHolder fileName | 54184 keepSources 54185 ifTrue: [ 54186 self confirm: 'We are going to abandon sources. 54187Quit without saving after this has run.' orCancel: [^self]]. 54188 54189 classList := aClassList asArray. 54190 54191 "Strong pointers to symbols" 54192 symbolHolder := Symbol allInstances. 54193 54194 oldMethods := OrderedCollection new: classList size * 150. 54195 newMethods := OrderedCollection new: classList size * 150. 54196 keepSources 54197 ifTrue: [ 54198 classList do: [:cl | 54199 cl selectors do: 54200 [:selector | | m oldCodeString methodNode | 54201 m := cl compiledMethodAt: selector. 54202 m fileIndex > 0 ifTrue: 54203 [oldCodeString := cl sourceCodeAt: selector. 54204 methodNode := cl compilerClass new 54205 parse: oldCodeString in: cl notifying: nil. 54206 oldMethods addLast: m. 54207 newMethods addLast: (m copyWithTempsFromMethodNode: methodNode)]]]]. 54208 oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. 54209 oldMethods := newMethods := nil. 54210 54211 Smalltalk garbageCollect. 54212 is := ImageSegment new copyFromRootsForExport: classList. "Classes and MetaClasses" 54213 54214 fileName := FileDirectory fileName: exportName extension: ImageSegment fileExtension. 54215 is writeForExport: fileName. 54216 self compressFileNamed: fileName 54217 54218! ! 54219 54220!CodeLoader class methodsFor: 'utilities' stamp: 'mir 10/12/2000 17:39'! 54221loadCode: codeSegmentName from: baseURL ifClassNotLoaded: testClass 54222 54223 CodeLoader defaultBaseURL: baseURL. 54224 (Smalltalk includesKey: testClass) 54225 ifFalse: [CodeLoader loadCodeSegment: codeSegmentName]. 54226! ! 54227 54228!CodeLoader class methodsFor: 'utilities' stamp: 'mir 2/2/2001 14:56'! 54229loadCodeSegment: segmentName 54230 | loader | 54231 loader := self new. 54232 loader loadSegments: (Array with: segmentName). 54233 loader installSegments.! ! 54234 54235!CodeLoader class methodsFor: 'utilities' stamp: 'asm 12/6/2002 08:11'! 54236signFile: fileName renameAs: destFile key: privateKey dsa: dsa 54237 "Sign the given file using the private key." 54238 | in out | 54239 in := FileStream readOnlyFileNamed: fileName. in binary. 54240 out := FileStream newFileNamed: destFile. out binary. 54241 [in atEnd] whileFalse:[out nextPutAll: (in next: 4096)]. 54242 in close. out close. 54243 FileDirectory activeDirectoryClass splitName: destFile to:[:path :file| 54244 SecurityManager default signFile: file directory: (FileDirectory on: path). 54245 ]. 54246! ! 54247 54248!CodeLoader class methodsFor: 'utilities' stamp: 'mir 2/14/2000 16:47'! 54249signFiles: fileNames in: dirName key: privateKey 54250 "Sign the files in the current directory and put them into a folder signed." 54251 54252 | newNames oldNames | 54253 oldNames := fileNames collect:[:fileName | dirName , FileDirectory slash, fileName]. 54254 newNames := fileNames collect:[:fileName | dirName , FileDirectory slash, 'signed', FileDirectory slash, fileName]. 54255 CodeLoader 54256 signFilesFrom: oldNames 54257 to: newNames 54258 key: privateKey! ! 54259 54260!CodeLoader class methodsFor: 'utilities' stamp: 'mir 1/18/2000 18:49'! 54261signFiles: fileNames key: privateKey 54262 "Sign the files in the current directory and put them into a folder signed." 54263 54264 | newNames | 54265 newNames := fileNames collect:[:fileName | 'signed', FileDirectory slash, fileName]. 54266 CodeLoader 54267 signFilesFrom: fileNames 54268 to: newNames 54269 key: privateKey! ! 54270 54271!CodeLoader class methodsFor: 'utilities' stamp: 'ads 7/31/2003 14:00'! 54272signFilesFrom: sourceNames to: destNames key: privateKey 54273 "Sign all the given files using the private key. 54274 This will add an 's' to the extension of the file." 54275 "| fd oldNames newNames | 54276 fd := FileDirectory default directoryNamed:'unsigned'. 54277 oldNames := fd fileNames. 54278 newNames := oldNames collect:[:name| 'signed', FileDirectory slash, name]. 54279 oldNames := oldNames collect:[:name| 'unsigned', FileDirectory slash, name]. 54280 CodeLoader 54281 signFilesFrom: oldNames 54282 to: newNames 54283 key: DOLPrivateKey." 54284 | dsa | 54285 dsa := DigitalSignatureAlgorithm new. 54286 dsa initRandomNonInteractively. 54287 'Signing files...' displayProgressAt: Sensor cursorPoint 54288 from: 1 to: sourceNames size during:[:bar| 54289 1 to: sourceNames size do:[:i| 54290 bar value: i. 54291 self signFile: (sourceNames at: i) renameAs: (destNames at: i) key: privateKey dsa: dsa]]. 54292 ! ! 54293 54294!CodeLoader class methodsFor: 'utilities' stamp: 'ar 2/6/2001 19:17'! 54295verifySignedFileNamed: aFileName 54296 "CodeLoader verifySignedFileNamed: 'signed\dummy1.dsq' " 54297 54298 | secured signedFileStream | 54299 signedFileStream := FileStream fileNamed: aFileName. 54300 secured := SecurityManager default positionToSecureContentsOf: signedFileStream. 54301 signedFileStream close. 54302 Transcript show: aFileName , ' verified: '; show: secured printString; cr. 54303 54304! ! 54305ModelExtension subclass: #CodeModelExtension 54306 instanceVariableNames: 'perClassCache' 54307 classVariableNames: '' 54308 poolDictionaries: '' 54309 category: 'Traits-LocalSends'! 54310 54311!CodeModelExtension methodsFor: 'access to cache' stamp: 'dvf 9/6/2005 15:29'! 54312cacheFor: aClass 54313 ^perClassCache at: aClass ifAbsentPut: [self newCacheFor: aClass]! ! 54314 54315!CodeModelExtension methodsFor: 'access to cache' stamp: 'dvf 9/1/2005 21:17'! 54316clearOut: aClass 54317 ^perClassCache removeKey: aClass ifAbsent: []! ! 54318 54319!CodeModelExtension methodsFor: 'access to cache' stamp: 'dvf 9/5/2005 14:20'! 54320for: aClass 54321 | newSendCache | 54322 ^perClassCache at: aClass 54323 ifAbsent: 54324 [newSendCache := self newCacheFor: aClass. 54325 (self haveInterestsIn: aClass) 54326 ifTrue: [perClassCache at: aClass put: newSendCache]. 54327 newSendCache]! ! 54328 54329!CodeModelExtension methodsFor: 'access to cache' stamp: 'dvf 9/1/2005 21:18'! 54330initialize 54331 super initialize. 54332 perClassCache := IdentityDictionary new.! ! 54333 54334 54335!CodeModelExtension methodsFor: 'invalidation' stamp: 'dvf 1/31/2006 23:38'! 54336classChanged: modificationEvent 54337 "We dont want to provide an out of date reply" 54338 modificationEvent itemClass ifNil: [self]. 54339 self clearOut: modificationEvent itemClass 54340! ! 54341 54342"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 54343 54344CodeModelExtension class 54345 instanceVariableNames: ''! 54346 54347!CodeModelExtension class methodsFor: 'initialization' stamp: 'dvf 9/2/2005 12:20'! 54348isAbstract 54349 ^self == CodeModelExtension! ! 54350SystemWindow subclass: #CollapsedMorph 54351 instanceVariableNames: 'uncollapsedMorph' 54352 classVariableNames: '' 54353 poolDictionaries: '' 54354 category: 'Morphic-Windows'! 54355 54356!CollapsedMorph methodsFor: 'collapse/expand' stamp: 'sw 5/9/2000 00:18'! 54357beReplacementFor: aMorph 54358 54359 | itsWorld priorPosition | 54360 (itsWorld := aMorph world) ifNil: [^self]. 54361 uncollapsedMorph := aMorph. 54362 54363 self setLabel: aMorph externalName. 54364 aMorph delete. 54365 itsWorld addMorphFront: self. 54366 self collapseOrExpand. 54367 (priorPosition := aMorph valueOfProperty: #collapsedPosition ifAbsent: [nil]) 54368 ifNotNil: 54369 [self position: priorPosition]. 54370! ! 54371 54372!CollapsedMorph methodsFor: 'collapse/expand' stamp: 'sw 4/9/2001 14:23'! 54373uncollapseToHand 54374 "Hand the uncollapsedMorph to the user, placing it in her hand, after remembering appropriate state for possible future use" 54375 54376 | nakedMorph | 54377 nakedMorph := uncollapsedMorph. 54378 uncollapsedMorph := nil. 54379 nakedMorph setProperty: #collapsedPosition toValue: self position. 54380 mustNotClose := false. "so the delete will succeed" 54381 self delete. 54382 ActiveHand attachMorph: nakedMorph! ! 54383 54384 54385!CollapsedMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 16:41'! 54386buildWindowMenu 54387 "Answer the menu to be put up in response to the user's clicking on the window-menu control in the window title. Specialized for CollapsedMorphs." 54388 54389 | aMenu | 54390 aMenu := MenuMorph new defaultTarget: self. 54391 aMenu add: 'change name...' translated action: #relabel. 54392 aMenu addLine. 54393 aMenu add: 'send to back' translated action: #sendToBack. 54394 aMenu add: 'make next-to-topmost' translated action: #makeSecondTopmost. 54395 aMenu addLine. 54396 self mustNotClose 54397 ifFalse: 54398 [aMenu add: 'make unclosable' translated action: #makeUnclosable] 54399 ifTrue: 54400 [aMenu add: 'make closable' translated action: #makeClosable]. 54401 aMenu 54402 add: (self isSticky ifTrue: ['make draggable'] ifFalse: ['make undraggable']) translated 54403 action: #toggleStickiness. 54404 ^aMenu! ! 54405 54406 54407!CollapsedMorph methodsFor: 'resize/collapse' stamp: 'sw 9/1/2000 11:07'! 54408collapseOrExpand 54409 "Toggle the expand/collapsd state of the receiver. If expanding, copy the window title back to the name of the expanded morph" 54410 54411 | aWorld | 54412 isCollapsed 54413 ifTrue: 54414 [uncollapsedMorph setProperty: #collapsedPosition toValue: self position. 54415 labelString ifNotNil: [uncollapsedMorph setNameTo: labelString]. 54416 mustNotClose := false. "We're not closing but expanding" 54417 self delete. 54418 (aWorld := self currentWorld) addMorphFront: uncollapsedMorph. 54419 aWorld startSteppingSubmorphsOf: uncollapsedMorph] 54420 ifFalse: 54421 [super collapseOrExpand]! ! 54422 54423!CollapsedMorph methodsFor: 'resize/collapse' stamp: 'sw 6/5/2001 22:55'! 54424wantsExpandBox 54425 "Answer whether I'd like an expand box" 54426 54427 ^ false! ! 54428Object subclass: #Collection 54429 instanceVariableNames: '' 54430 classVariableNames: 'MutexForPicking RandomForPicking' 54431 poolDictionaries: '' 54432 category: 'Collections-Abstract'! 54433!Collection commentStamp: '<historical>' prior: 0! 54434I am the abstract superclass of all classes that represent a group of elements.! 54435 54436 54437!Collection methodsFor: '*morphic-objectmenu' stamp: 'wiz 7/20/2004 13:06'! 54438asKnownNameMenu 54439 "Return a menu to select an element of the collection. 54440 Menu uses the knownName or class name as only description of 54441 element." 54442 | menu | 54443 menu := CustomMenu new. 54444 self 54445 do: [:m | menu 54446 add: (m knownName 54447 ifNil: [m class name asString]) 54448 action: m]. 54449 ^ menu! ! 54450 54451 54452!Collection methodsFor: '*packageinfo-base' stamp: 'ab 9/30/2002 19:26'! 54453gather: aBlock 54454 ^ Array streamContents: 54455 [:stream | 54456 self do: [:ea | stream nextPutAll: (aBlock value: ea)]]! ! 54457 54458 54459!Collection methodsFor: '*services-base' stamp: 'rr 3/21/2006 11:59'! 54460chooseOne: caption 54461 "pops up a menu asking for one of the elements in the collection. 54462 If none is chosen, raises a ServiceCancelled notification" 54463 54464 | m | 54465 m := MenuMorph entitled: caption. 54466 self do: 54467 [:ea | 54468 m 54469 add: ea 54470 target: [:n | ^ n] 54471 selector: #value: 54472 argument: ea]. 54473 m invokeModal. 54474 ServiceCancelled signal! ! 54475 54476 54477!Collection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:33'! 54478anyOne 54479 "Answer a representative sample of the receiver. This method can 54480 be helpful when needing to preinfer the nature of the contents of 54481 semi-homogeneous collections." 54482 54483 self emptyCheck. 54484 self do: [:each | ^ each]! ! 54485 54486!Collection methodsFor: 'accessing' stamp: 'sd 11/4/2003 22:05'! 54487atRandom 54488 "Answer a random element of the receiver. Uses a shared random 54489 number generator owned by class Collection. If you use this a lot, 54490 define your own instance of Random and use #atRandom:. Causes 54491 an error if self has no elements." 54492 54493 ^ self class mutexForPicking critical: [ 54494 self atRandom: self class randomForPicking ] 54495 54496"Examples: 54497 #('one' 'or' 'the' 'other') atRandom 54498 (1 to: 10) atRandom 54499 'Just pick one of these letters at random' atRandom 54500 #(3 7 4 9 21) asSet atRandom (just to show it also works for Sets) 54501"! ! 54502 54503!Collection methodsFor: 'accessing' stamp: 'damiencassou 4/13/2009 12:02'! 54504atRandom: aGenerator 54505 "Answer a random element of the receiver. Uses aGenerator which 54506 should be kept by the user in a variable and used every time. Use 54507 this instead of #atRandom for better uniformity of random numbers because 54508 only you use the generator. Causes an error if self has no elements." 54509 | rand index | 54510 54511 self emptyCheck. 54512 rand := aGenerator nextInt: self size. 54513 index := 1. 54514 self do: [:each | 54515 index == rand ifTrue: [^each]. 54516 index := index + 1]. 54517 ^ self errorEmptyCollection 54518! ! 54519 54520!Collection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:41'! 54521capacity 54522 "Answer the current capacity of the receiver." 54523 54524 ^ self size! ! 54525 54526!Collection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:34'! 54527size 54528 "Answer how many elements the receiver contains." 54529 54530 | tally | 54531 tally := 0. 54532 self do: [:each | tally := tally + 1]. 54533 ^ tally! ! 54534 54535 54536!Collection methodsFor: 'adapting' stamp: 'di 11/6/1998 13:34'! 54537adaptToCollection: rcvr andSend: selector 54538 "If I am involved in arithmetic with another Collection, return a Collection of 54539 the results of each element combined with the scalar in that expression." 54540 54541 rcvr isSequenceable & self isSequenceable ifFalse: 54542 [self error: 'Only sequenceable collections may be combined arithmetically']. 54543 ^ rcvr with: self collect: 54544 [:rcvrElement :myElement | rcvrElement perform: selector with: myElement]! ! 54545 54546!Collection methodsFor: 'adapting' stamp: 'mk 10/27/2003 21:48'! 54547adaptToComplex: rcvr andSend: selector 54548 "If I am involved in arithmetic with a scalar, return a Collection of 54549 the results of each element combined with the scalar in that expression." 54550 54551 ^ self collect: [:element | rcvr perform: selector with: element]! ! 54552 54553!Collection methodsFor: 'adapting' stamp: 'di 11/9/1998 12:16'! 54554adaptToNumber: rcvr andSend: selector 54555 "If I am involved in arithmetic with a scalar, return a Collection of 54556 the results of each element combined with the scalar in that expression." 54557 54558 ^ self collect: [:element | rcvr perform: selector with: element]! ! 54559 54560!Collection methodsFor: 'adapting' stamp: 'di 11/6/1998 13:37'! 54561adaptToPoint: rcvr andSend: selector 54562 "If I am involved in arithmetic with a scalar, return a Collection of 54563 the results of each element combined with the scalar in that expression." 54564 54565 ^ self collect: [:element | rcvr perform: selector with: element]! ! 54566 54567!Collection methodsFor: 'adapting' stamp: 'di 11/6/1998 13:37'! 54568adaptToString: rcvr andSend: selector 54569 "If I am involved in arithmetic with a String, convert it to a Number." 54570 ^ rcvr asNumber perform: selector with: self! ! 54571 54572 54573!Collection methodsFor: 'adding'! 54574add: newObject 54575 "Include newObject as one of the receiver's elements. Answer newObject. 54576 ArrayedCollections cannot respond to this message." 54577 54578 self subclassResponsibility! ! 54579 54580!Collection methodsFor: 'adding' stamp: 'sma 5/12/2000 17:21'! 54581add: newObject withOccurrences: anInteger 54582 "Add newObject anInteger times to the receiver. Answer newObject." 54583 54584 anInteger timesRepeat: [self add: newObject]. 54585 ^ newObject! ! 54586 54587!Collection methodsFor: 'adding' stamp: 'sma 5/12/2000 17:26'! 54588addAll: aCollection 54589 "Include all the elements of aCollection as the receiver's elements. Answer 54590 aCollection. Actually, any object responding to #do: can be used as argument." 54591 54592 aCollection do: [:each | self add: each]. 54593 ^ aCollection! ! 54594 54595!Collection methodsFor: 'adding' stamp: 'sma 5/12/2000 17:23'! 54596addIfNotPresent: anObject 54597 "Include anObject as one of the receiver's elements, but only if there 54598 is no such element already. Anwser anObject." 54599 54600 (self includes: anObject) ifFalse: [self add: anObject]. 54601 ^ anObject! ! 54602 54603 54604!Collection methodsFor: 'arithmetic' stamp: 'G.C 10/23/2008 10:12'! 54605* arg 54606 54607 ^ arg adaptToCollection: self andSend: #*! ! 54608 54609!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:53'! 54610+ arg 54611 54612 ^ arg adaptToCollection: self andSend: #+! ! 54613 54614!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:53'! 54615- arg 54616 54617 ^ arg adaptToCollection: self andSend: #-! ! 54618 54619!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:53'! 54620/ arg 54621 54622 ^ arg adaptToCollection: self andSend: #/! ! 54623 54624!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:54'! 54625// arg 54626 54627 ^ arg adaptToCollection: self andSend: #//! ! 54628 54629!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:54'! 54630\\ arg 54631 54632 ^ arg adaptToCollection: self andSend: #\\! ! 54633 54634!Collection methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 00:17'! 54635raisedTo: arg 54636 54637 ^ arg adaptToCollection: self andSend: #raisedTo:! ! 54638 54639 54640!Collection methodsFor: 'comparing' stamp: 'SqR 8/3/2000 13:36'! 54641hash 54642 "Answer an integer hash value for the receiver such that, 54643 -- the hash value of an unchanged object is constant over time, and 54644 -- two equal objects have equal hash values" 54645 54646 | hash | 54647 54648 hash := self species hash. 54649 self size <= 10 ifTrue: 54650 [self do: [:elem | hash := hash bitXor: elem hash]]. 54651 ^hash bitXor: self size hash! ! 54652 54653 54654!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:22'! 54655asArray 54656 "Answer an Array whose elements are the elements of the receiver. 54657 Implementation note: Cannot use ''Array withAll: self'' as that only 54658 works for SequenceableCollections which support the replacement 54659 primitive." 54660 54661 | array index | 54662 array := Array new: self size. 54663 index := 0. 54664 self do: [:each | array at: (index := index + 1) put: each]. 54665 ^ array! ! 54666 54667!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:10'! 54668asBag 54669 "Answer a Bag whose elements are the elements of the receiver." 54670 54671 ^ Bag withAll: self! ! 54672 54673!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:22'! 54674asByteArray 54675 "Answer a ByteArray whose elements are the elements of the receiver. 54676 Implementation note: Cannot use ''ByteArray withAll: self'' as that only 54677 works for SequenceableCollections which support the replacement 54678 primitive." 54679 54680 | array index | 54681 array := ByteArray new: self size. 54682 index := 0. 54683 self do: [:each | array at: (index := index + 1) put: each]. 54684 ^ array! ! 54685 54686!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:26'! 54687asCharacterSet 54688 "Answer a CharacterSet whose elements are the unique elements of the receiver. 54689 The reciever should only contain characters." 54690 54691 ^ CharacterSet newFrom: self! ! 54692 54693!Collection methodsFor: 'converting' stamp: 'ar 9/22/2000 10:12'! 54694asIdentitySet 54695 ^(IdentitySet new: self size) addAll: self; yourself! ! 54696 54697!Collection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:43'! 54698asOrderedCollection 54699 "Answer an OrderedCollection whose elements are the elements of the 54700 receiver. The order in which elements are added depends on the order 54701 in which the receiver enumerates its elements. In the case of unordered 54702 collections, the ordering is not necessarily the same for multiple 54703 requests for the conversion." 54704 54705 ^ self as: OrderedCollection! ! 54706 54707!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:29'! 54708asSet 54709 "Answer a Set whose elements are the unique elements of the receiver." 54710 54711 ^ Set withAll: self! ! 54712 54713!Collection methodsFor: 'converting' stamp: 'LC 6/18/2001 18:46'! 54714asSkipList: aSortBlock 54715 "Answer a SkipList whose elements are the elements of the 54716 receiver. The sort order is defined by the argument, aSortBlock." 54717 54718 | skipList | 54719 skipList := SortedCollection new: self size. 54720 skipList sortBlock: aSortBlock. 54721 skipList addAll: self. 54722 ^ skipList! ! 54723 54724!Collection methodsFor: 'converting'! 54725asSortedArray 54726 "Return a copy of the receiver in sorted order, as an Array. 6/10/96 sw" 54727 54728 ^ self asSortedCollection asArray! ! 54729 54730!Collection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:44'! 54731asSortedCollection 54732 "Answer a SortedCollection whose elements are the elements of the 54733 receiver. The sort order is the default less than or equal." 54734 54735 ^ self as: SortedCollection! ! 54736 54737!Collection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:46'! 54738asSortedCollection: aSortBlock 54739 "Answer a SortedCollection whose elements are the elements of the 54740 receiver. The sort order is defined by the argument, aSortBlock." 54741 54742 | aSortedCollection | 54743 aSortedCollection := SortedCollection new: self size. 54744 aSortedCollection sortBlock: aSortBlock. 54745 aSortedCollection addAll: self. 54746 ^ aSortedCollection! ! 54747 54748 54749!Collection methodsFor: 'copying' stamp: 'al 12/12/2003 14:31'! 54750, aCollection 54751 ^self copy addAll: aCollection; yourself! ! 54752 54753!Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 14:41'! 54754copyWith: newElement 54755 "Answer a new collection with newElement added (as last 54756 element if sequenceable)." 54757 54758 ^ self copy 54759 add: newElement; 54760 yourself! ! 54761 54762!Collection methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'! 54763copyWithDependent: newElement 54764 "Answer a new collection with newElement added (as last 54765 element if sequenceable)." 54766 ^self copyWith: newElement! ! 54767 54768!Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 14:43'! 54769copyWithout: oldElement 54770 "Answer a copy of the receiver that does not contain any 54771 elements equal to oldElement." 54772 54773 ^ self reject: [:each | each = oldElement] 54774 54775"Examples: 54776 'fred the bear' copyWithout: $e 54777 #(2 3 4 5 5 6) copyWithout: 5 54778"! ! 54779 54780!Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 18:08'! 54781copyWithoutAll: aCollection 54782 "Answer a copy of the receiver that does not contain any elements 54783 equal to those in aCollection." 54784 54785 ^ self reject: [:each | aCollection includes: each]! ! 54786 54787 54788!Collection methodsFor: 'enumerating' stamp: 'sma 4/30/2000 11:17'! 54789allSatisfy: aBlock 54790 "Evaluate aBlock with the elements of the receiver. 54791 If aBlock returns false for any element return false. 54792 Otherwise return true." 54793 54794 self do: [:each | (aBlock value: each) ifFalse: [^ false]]. 54795 ^ true! ! 54796 54797!Collection methodsFor: 'enumerating' stamp: 'sma 4/30/2000 11:17'! 54798anySatisfy: aBlock 54799 "Evaluate aBlock with the elements of the receiver. 54800 If aBlock returns true for any element return true. 54801 Otherwise return false." 54802 54803 self do: [:each | (aBlock value: each) ifTrue: [^ true]]. 54804 ^ false! ! 54805 54806!Collection methodsFor: 'enumerating'! 54807associationsDo: aBlock 54808 "Evaluate aBlock for each of the receiver's elements (key/value 54809 associations). If any non-association is within, the error is not caught now, 54810 but later, when a key or value message is sent to it." 54811 54812 self do: aBlock! ! 54813 54814!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:45'! 54815collect: aBlock 54816 "Evaluate aBlock with each of the receiver's elements as the argument. 54817 Collect the resulting values into a collection like the receiver. Answer 54818 the new collection." 54819 54820 | newCollection | 54821 newCollection := self species new. 54822 self do: [:each | newCollection add: (aBlock value: each)]. 54823 ^ newCollection! ! 54824 54825!Collection methodsFor: 'enumerating' stamp: 'dgd 9/13/2004 23:42'! 54826collect: collectBlock thenDo: doBlock 54827 "Utility method to improve readability." 54828 ^ (self collect: collectBlock) do: doBlock! ! 54829 54830!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:51'! 54831collect: collectBlock thenSelect: selectBlock 54832 "Utility method to improve readability." 54833 54834 ^ (self collect: collectBlock) select: selectBlock! ! 54835 54836!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:52'! 54837count: aBlock 54838 "Evaluate aBlock with each of the receiver's elements as the argument. 54839 Answer the number of elements that answered true." 54840 54841 | sum | 54842 sum := 0. 54843 self do: [:each | (aBlock value: each) ifTrue: [sum := sum + 1]]. 54844 ^ sum! ! 54845 54846!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:20'! 54847detect: aBlock 54848 "Evaluate aBlock with each of the receiver's elements as the argument. 54849 Answer the first element for which aBlock evaluates to true." 54850 54851 ^ self detect: aBlock ifNone: [self errorNotFound: aBlock]! ! 54852 54853!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:52'! 54854detect: aBlock ifNone: exceptionBlock 54855 "Evaluate aBlock with each of the receiver's elements as the argument. 54856 Answer the first element for which aBlock evaluates to true. If none 54857 evaluate to true, then evaluate the argument, exceptionBlock." 54858 54859 self do: [:each | (aBlock value: each) ifTrue: [^ each]]. 54860 ^ exceptionBlock value! ! 54861 54862!Collection methodsFor: 'enumerating'! 54863detectMax: aBlock 54864 "Evaluate aBlock with each of the receiver's elements as the argument. 54865 Answer the element for which aBlock evaluates to the highest magnitude. 54866 If collection empty, return nil. This method might also be called elect:." 54867 54868 | maxElement maxValue val | 54869 self do: [:each | 54870 maxValue == nil 54871 ifFalse: [ 54872 (val := aBlock value: each) > maxValue ifTrue: [ 54873 maxElement := each. 54874 maxValue := val]] 54875 ifTrue: ["first element" 54876 maxElement := each. 54877 maxValue := aBlock value: each]. 54878 "Note that there is no way to get the first element that works 54879 for all kinds of Collections. Must test every one."]. 54880 ^ maxElement! ! 54881 54882!Collection methodsFor: 'enumerating'! 54883detectMin: aBlock 54884 "Evaluate aBlock with each of the receiver's elements as the argument. 54885 Answer the element for which aBlock evaluates to the lowest number. 54886 If collection empty, return nil." 54887 54888 | minElement minValue val | 54889 self do: [:each | 54890 minValue == nil 54891 ifFalse: [ 54892 (val := aBlock value: each) < minValue ifTrue: [ 54893 minElement := each. 54894 minValue := val]] 54895 ifTrue: ["first element" 54896 minElement := each. 54897 minValue := aBlock value: each]. 54898 "Note that there is no way to get the first element that works 54899 for all kinds of Collections. Must test every one."]. 54900 ^ minElement! ! 54901 54902!Collection methodsFor: 'enumerating'! 54903detectSum: aBlock 54904 "Evaluate aBlock with each of the receiver's elements as the argument. 54905 Return the sum of the answers." 54906 | sum | 54907 sum := 0. 54908 self do: [:each | 54909 sum := (aBlock value: each) + sum]. 54910 ^ sum! ! 54911 54912!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 17:52'! 54913difference: aCollection 54914 "Answer the set theoretic difference of two collections." 54915 54916 ^ self reject: [:each | aCollection includes: each]! ! 54917 54918!Collection methodsFor: 'enumerating'! 54919do: aBlock 54920 "Evaluate aBlock with each of the receiver's elements as the argument." 54921 54922 self subclassResponsibility! ! 54923 54924!Collection methodsFor: 'enumerating' stamp: 'md 7/22/2005 16:26'! 54925do: aBlock displayingProgress: aString 54926 54927 aString 54928 displayProgressAt: Sensor cursorPoint 54929 from: 0 to: self size 54930 during: 54931 [:bar | 54932 self inject: 1 into: 54933 [:index :each | 54934 bar value: index. 54935 aBlock value: each. 54936 index + 1]]! ! 54937 54938!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:57'! 54939do: elementBlock separatedBy: separatorBlock 54940 "Evaluate the elementBlock for all elements in the receiver, 54941 and evaluate the separatorBlock between." 54942 54943 | beforeFirst | 54944 beforeFirst := true. 54945 self do: 54946 [:each | 54947 beforeFirst 54948 ifTrue: [beforeFirst := false] 54949 ifFalse: [separatorBlock value]. 54950 elementBlock value: each]! ! 54951 54952!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:59'! 54953do: aBlock without: anItem 54954 "Enumerate all elements in the receiver. 54955 Execute aBlock for those elements that are not equal to the given item" 54956 54957 ^ self do: [:each | anItem = each ifFalse: [aBlock value: each]]! ! 54958 54959!Collection methodsFor: 'enumerating' stamp: 'yo 8/27/2008 23:45'! 54960explorerContents 54961 54962 ^self explorerContentsWithIndexCollect: [:value :index | 54963 ObjectExplorerWrapper 54964 with: value 54965 name: index printString 54966 model: self]! ! 54967 54968!Collection methodsFor: 'enumerating' stamp: 'yo 8/27/2008 23:29'! 54969explorerContentsWithIndexCollect: twoArgBlock 54970 54971 ^ self asOrderedCollection withIndexCollect: twoArgBlock 54972! ! 54973 54974!Collection methodsFor: 'enumerating' stamp: 'dvf 6/10/2000 18:32'! 54975groupBy: keyBlock having: selectBlock 54976 "Like in SQL operation - Split the recievers contents into collections of 54977 elements for which keyBlock returns the same results, and return those 54978 collections allowed by selectBlock. keyBlock should return an Integer." 54979 | result key | 54980 result := PluggableDictionary integerDictionary. 54981 self do: 54982 [:e | 54983 key := keyBlock value: e. 54984 (result includesKey: key) 54985 ifFalse: [result at: key put: OrderedCollection new]. 54986 (result at: key) 54987 add: e]. 54988 ^ result := result select: selectBlock! ! 54989 54990!Collection methodsFor: 'enumerating'! 54991inject: thisValue into: binaryBlock 54992 "Accumulate a running value associated with evaluating the argument, 54993 binaryBlock, with the current value of the argument, thisValue, and the 54994 receiver as block arguments. For instance, to sum the numeric elements 54995 of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal + 54996 next]." 54997 54998 | nextValue | 54999 nextValue := thisValue. 55000 self do: [:each | nextValue := binaryBlock value: nextValue value: each]. 55001 ^nextValue! ! 55002 55003!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 17:52'! 55004intersection: aCollection 55005 "Answer the set theoretic intersection of two collections." 55006 55007 ^ self select: [:each | aCollection includes: each]! ! 55008 55009!Collection methodsFor: 'enumerating' stamp: 'gh 9/18/2001 15:59'! 55010noneSatisfy: aBlock 55011 "Evaluate aBlock with the elements of the receiver. 55012 If aBlock returns false for all elements return true. 55013 Otherwise return false" 55014 55015 self do: [:item | (aBlock value: item) ifTrue: [^ false]]. 55016 ^ true! ! 55017 55018!Collection methodsFor: 'enumerating'! 55019reject: aBlock 55020 "Evaluate aBlock with each of the receiver's elements as the argument. 55021 Collect into a new collection like the receiver only those elements for 55022 which aBlock evaluates to false. Answer the new collection." 55023 55024 ^self select: [:element | (aBlock value: element) == false]! ! 55025 55026!Collection methodsFor: 'enumerating' stamp: 'dgd 9/13/2004 23:42'! 55027reject: rejectBlock thenDo: doBlock 55028 "Utility method to improve readability." 55029 ^ (self reject: rejectBlock) do: doBlock! ! 55030 55031!Collection methodsFor: 'enumerating'! 55032select: aBlock 55033 "Evaluate aBlock with each of the receiver's elements as the argument. 55034 Collect into a new collection like the receiver, only those elements for 55035 which aBlock evaluates to true. Answer the new collection." 55036 55037 | newCollection | 55038 newCollection := self species new. 55039 self do: [:each | (aBlock value: each) ifTrue: [newCollection add: each]]. 55040 ^newCollection! ! 55041 55042!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:59'! 55043select: selectBlock thenCollect: collectBlock 55044 "Utility method to improve readability." 55045 55046 ^ (self select: selectBlock) collect: collectBlock! ! 55047 55048!Collection methodsFor: 'enumerating' stamp: 'hfm 2/12/2009 13:38'! 55049select: selectBlock thenDo: doBlock 55050 "Utility method to improve readability. 55051 Do not create the intermediate collection." 55052 55053 self do: [: each | 55054 ( selectBlock value: each ) 55055 ifTrue: [ doBlock value: each ] 55056 ].! ! 55057 55058!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 17:54'! 55059union: aCollection 55060 "Answer the set theoretic union of two collections." 55061 55062 ^ self asSet addAll: aCollection; yourself! ! 55063 55064 55065!Collection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 12:07'! 55066contents 55067 ^ self! ! 55068 55069!Collection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 12:08'! 55070flattenOnStream: aStream 55071 ^ aStream writeCollection: self! ! 55072 55073!Collection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 12:07'! 55074write: anObject 55075 ^ self add: anObject! ! 55076 55077 55078!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:51'! 55079abs 55080 "Absolute value of all elements in the collection" 55081 ^ self collect: [:a | a abs]! ! 55082 55083!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! 55084arcCos 55085 ^self collect: [:each | each arcCos]! ! 55086 55087!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! 55088arcSin 55089 ^self collect: [:each | each arcSin]! ! 55090 55091!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! 55092arcTan 55093 ^self collect: [:each | each arcTan]! ! 55094 55095!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:57'! 55096average 55097 ^ self sum / self size! ! 55098 55099!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:51'! 55100ceiling 55101 ^ self collect: [:a | a ceiling]! ! 55102 55103!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! 55104cos 55105 ^self collect: [:each | each cos]! ! 55106 55107!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! 55108degreeCos 55109 ^self collect: [:each | each degreeCos]! ! 55110 55111!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:21'! 55112degreeSin 55113 ^self collect: [:each | each degreeSin]! ! 55114 55115!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:21'! 55116exp 55117 ^self collect: [:each | each exp]! ! 55118 55119!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:51'! 55120floor 55121 ^ self collect: [:a | a floor]! ! 55122 55123!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:21'! 55124ln 55125 ^self collect: [:each | each ln]! ! 55126 55127!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:52'! 55128log 55129 ^ self collect: [:each | each log]! ! 55130 55131!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:58'! 55132max 55133 ^ self inject: self anyOne into: [:max :each | max max: each]! ! 55134 55135!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:00'! 55136median 55137 ^ self asSortedCollection median! ! 55138 55139!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:00'! 55140min 55141 ^ self inject: self anyOne into: [:min :each | min min: each]! ! 55142 55143!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:52'! 55144negated 55145 "Negated value of all elements in the collection" 55146 ^ self collect: [:a | a negated]! ! 55147 55148!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:00'! 55149range 55150 ^ self max - self min! ! 55151 55152!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:53'! 55153reciprocal 55154 "Return the reciever full of reciprocated elements" 55155 ^ self collect: [:a | a reciprocal]! ! 55156 55157!Collection methodsFor: 'math functions' stamp: 'nk 12/30/2003 15:47'! 55158roundTo: quantum 55159 ^self collect: [ :ea | ea roundTo: quantum ]! ! 55160 55161!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:53'! 55162rounded 55163 ^ self collect: [:a | a rounded]! ! 55164 55165!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:23'! 55166sign 55167 ^self collect: [:each | each sign]! ! 55168 55169!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:22'! 55170sin 55171 ^self collect: [:each | each sin]! ! 55172 55173!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:53'! 55174sqrt 55175 ^ self collect: [:each | each sqrt]! ! 55176 55177!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:53'! 55178squared 55179 ^ self collect: [:each | each * each]! ! 55180 55181!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:02'! 55182sum 55183 "This is implemented using a variant of the normal inject:into: pattern. 55184 The reason for this is that it is not known whether we're in the normal 55185 number line, i.e. whether 0 is a good initial value for the sum. 55186 Consider a collection of measurement objects, 0 would be the unitless 55187 value and would not be appropriate to add with the unit-ed objects." 55188 | sum sample | 55189 sample := self anyOne. 55190 sum := self inject: sample into: [:accum :each | accum + each]. 55191 ^ sum - sample! ! 55192 55193!Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:22'! 55194tan 55195 ^self collect: [:each | each tan]! ! 55196 55197!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:54'! 55198truncated 55199 ^ self collect: [:a | a truncated]! ! 55200 55201 55202!Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:19'! 55203asCommaString 55204 "Return collection printed as 'a, b, c' " 55205 55206 ^String streamContents: [:s | self asStringOn: s delimiter: ', '] 55207 ! ! 55208 55209!Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:20'! 55210asCommaStringAnd 55211 "Return collection printed as 'a, b and c' " 55212 55213 ^String streamContents: [:s | self asStringOn: s delimiter: ', ' last: ' and '] 55214 ! ! 55215 55216!Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:27'! 55217asStringOn: aStream delimiter: delimString 55218 "Print elements on a stream separated 55219 with a delimiter String like: 'a, b, c' 55220 Uses #asString instead of #print:." 55221 55222 self do: [:elem | aStream nextPutAll: elem asString] 55223 separatedBy: [aStream nextPutAll: delimString]! ! 55224 55225!Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:27'! 55226asStringOn: aStream delimiter: delimString last: lastDelimString 55227 "Print elements on a stream separated 55228 with a delimiter between all the elements and with 55229 a special one before the last like: 'a, b and c'. 55230 Uses #asString instead of #print: 55231 55232 Note: Feel free to improve the code to detect the last element." 55233 55234 | n sz | 55235 n := 1. 55236 sz := self size. 55237 self do: [:elem | 55238 n := n + 1. 55239 aStream nextPutAll: elem asString] 55240 separatedBy: [ 55241 aStream nextPutAll: (n = sz ifTrue: [lastDelimString] ifFalse: [delimString])]! ! 55242 55243!Collection methodsFor: 'printing' stamp: 'apb 4/21/2006 09:37'! 55244printElementsOn: aStream 55245 "The original code used #skip:, but some streams do not support that, 55246 and we don't really need it." 55247 55248 aStream nextPut: $(. 55249 self do: [:element | aStream print: element] separatedBy: [aStream space]. 55250 aStream nextPut: $)! ! 55251 55252!Collection methodsFor: 'printing' stamp: 'sma 6/1/2000 09:41'! 55253printNameOn: aStream 55254 super printOn: aStream! ! 55255 55256!Collection methodsFor: 'printing' stamp: 'sma 6/1/2000 09:41'! 55257printOn: aStream 55258 "Append a sequence of characters that identify the receiver to aStream." 55259 55260 self printNameOn: aStream. 55261 self printElementsOn: aStream! ! 55262 55263!Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:01'! 55264printOn: aStream delimiter: delimString 55265 "Print elements on a stream separated 55266 with a delimiter String like: 'a, b, c' " 55267 55268 self do: [:elem | aStream print: elem] separatedBy: [aStream print: delimString] 55269 ! ! 55270 55271!Collection methodsFor: 'printing' stamp: 'fbs 1/14/2005 10:54'! 55272printOn: aStream delimiter: delimString last: lastDelimString 55273 "Print elements on a stream separated 55274 with a delimiter between all the elements and with 55275 a special one before the last like: 'a, b and c' 55276 55277 Note: Feel free to improve the code to detect the last element." 55278 55279 | n sz | 55280 n := 1. 55281 sz := self size. 55282 self do: [:elem | 55283 n := n + 1. 55284 aStream print: elem] 55285 separatedBy: [ 55286 n = sz 55287 ifTrue: [aStream print: lastDelimString] 55288 ifFalse: [aStream print: delimString]]! ! 55289 55290!Collection methodsFor: 'printing'! 55291storeOn: aStream 55292 "Refer to the comment in Object|storeOn:." 55293 55294 | noneYet | 55295 aStream nextPutAll: '(('. 55296 aStream nextPutAll: self class name. 55297 aStream nextPutAll: ' new)'. 55298 noneYet := true. 55299 self do: 55300 [:each | 55301 noneYet 55302 ifTrue: [noneYet := false] 55303 ifFalse: [aStream nextPut: $;]. 55304 aStream nextPutAll: ' add: '. 55305 aStream store: each]. 55306 noneYet ifFalse: [aStream nextPutAll: '; yourself']. 55307 aStream nextPut: $)! ! 55308 55309 55310!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:22'! 55311remove: oldObject 55312 "Remove oldObject from the receiver's elements. Answer oldObject 55313 unless no element is equal to oldObject, in which case, raise an error. 55314 ArrayedCollections cannot respond to this message." 55315 55316 ^ self remove: oldObject ifAbsent: [self errorNotFound: oldObject]! ! 55317 55318!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:14'! 55319remove: oldObject ifAbsent: anExceptionBlock 55320 "Remove oldObject from the receiver's elements. If several of the 55321 elements are equal to oldObject, only one is removed. If no element is 55322 equal to oldObject, answer the result of evaluating anExceptionBlock. 55323 Otherwise, answer the argument, oldObject. ArrayedCollections cannot 55324 respond to this message." 55325 55326 self subclassResponsibility! ! 55327 55328!Collection methodsFor: 'removing' stamp: 'nice 9/14/2009 20:30'! 55329removeAll 55330 "Remove each element from the receiver and leave it empty. 55331 ArrayedCollections cannot respond to this message. 55332 There are two good reasons why a subclass should override this message: 55333 1) the subclass does not support being modified while being iterated 55334 2) the subclass provides a much faster way than iterating through each element" 55335 55336 self do: [:each | self remove: each].! ! 55337 55338!Collection methodsFor: 'removing' stamp: 'nice 1/10/2009 00:01'! 55339removeAll: aCollection 55340 "Remove each element of aCollection from the receiver. If successful for 55341 each, answer aCollection. Otherwise create an error notification. 55342 ArrayedCollections cannot respond to this message." 55343 55344 aCollection == self ifTrue: [^self removeAll]. 55345 aCollection do: [:each | self remove: each]. 55346 ^ aCollection! ! 55347 55348!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:16'! 55349removeAllFoundIn: aCollection 55350 "Remove each element of aCollection which is present in the receiver 55351 from the receiver. Answer aCollection. No error is raised if an element 55352 isn't found. ArrayedCollections cannot respond to this message." 55353 55354 aCollection do: [:each | self remove: each ifAbsent: []]. 55355 ^ aCollection! ! 55356 55357!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:19'! 55358removeAllSuchThat: aBlock 55359 "Evaluate aBlock for each element and remove all that elements from 55360 the receiver for that aBlock evaluates to true. Use a copy to enumerate 55361 collections whose order changes when an element is removed (i.e. Sets)." 55362 55363 self copy do: [:each | (aBlock value: each) ifTrue: [self remove: each]]! ! 55364 55365 55366!Collection methodsFor: 'testing'! 55367contains: aBlock 55368 "VW compatibility" 55369 ^self anySatisfy: aBlock! ! 55370 55371!Collection methodsFor: 'testing' stamp: 'ls 3/27/2000 17:25'! 55372identityIncludes: anObject 55373 "Answer whether anObject is one of the receiver's elements." 55374 55375 self do: [:each | anObject == each ifTrue: [^true]]. 55376 ^false! ! 55377 55378!Collection methodsFor: 'testing' stamp: 'jf 12/1/2003 15:37'! 55379ifEmpty: aBlock 55380 "Evaluate the block if I'm empty" 55381 55382 ^ self isEmpty ifTrue: aBlock! ! 55383 55384!Collection methodsFor: 'testing' stamp: 'md 10/7/2004 14:49'! 55385ifEmpty: emptyBlock ifNotEmpty: notEmptyBlock 55386 "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise" 55387 " If the notEmptyBlock has an argument, eval with the receiver as its argument" 55388 55389 ^ self isEmpty ifTrue: emptyBlock ifFalse: [notEmptyBlock valueWithPossibleArgument: self]! ! 55390 55391!Collection methodsFor: 'testing' stamp: 'md 10/7/2004 15:36'! 55392ifEmpty: emptyBlock ifNotEmptyDo: notEmptyBlock 55393 "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise" 55394 "Evaluate the notEmptyBlock with the receiver as its argument" 55395 55396 ^ self isEmpty ifTrue: emptyBlock ifFalse: [notEmptyBlock value: self]! ! 55397 55398!Collection methodsFor: 'testing' stamp: 'md 10/7/2004 14:58'! 55399ifNotEmpty: aBlock 55400 "Evaluate the given block unless the receiver is empty. 55401 55402 If the block has an argument, eval with the receiver as its argument, 55403 but it might be better to use ifNotEmptyDo: to make the code easier to 55404 understand" 55405 55406 ^self isEmpty ifFalse: [aBlock valueWithPossibleArgument: self]. 55407! ! 55408 55409!Collection methodsFor: 'testing' stamp: 'md 10/7/2004 14:48'! 55410ifNotEmpty: notEmptyBlock ifEmpty: emptyBlock 55411 "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise 55412 If the notEmptyBlock has an argument, eval with the receiver as its argument" 55413 55414 ^ self isEmpty ifFalse: [notEmptyBlock valueWithPossibleArgument: self] ifTrue: emptyBlock! ! 55415 55416!Collection methodsFor: 'testing' stamp: 'md 10/7/2004 14:28'! 55417ifNotEmptyDo: aBlock 55418 "Evaluate the given block with the receiver as its argument." 55419 55420 ^self isEmpty ifFalse: [aBlock value: self]. 55421! ! 55422 55423!Collection methodsFor: 'testing' stamp: 'md 10/7/2004 15:36'! 55424ifNotEmptyDo: notEmptyBlock ifEmpty: emptyBlock 55425 "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise 55426 Evaluate the notEmptyBlock with the receiver as its argument" 55427 55428 ^ self isEmpty ifFalse: [notEmptyBlock value: self] ifTrue: emptyBlock! ! 55429 55430!Collection methodsFor: 'testing' stamp: 'sma 5/12/2000 14:07'! 55431includes: anObject 55432 "Answer whether anObject is one of the receiver's elements." 55433 55434 ^ self anySatisfy: [:each | each = anObject]! ! 55435 55436!Collection methodsFor: 'testing'! 55437includesAllOf: aCollection 55438 "Answer whether all the elements of aCollection are in the receiver." 55439 aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]]. 55440 ^ true! ! 55441 55442!Collection methodsFor: 'testing'! 55443includesAnyOf: aCollection 55444 "Answer whether any element of aCollection is one of the receiver's elements." 55445 aCollection do: [:elem | (self includes: elem) ifTrue: [^ true]]. 55446 ^ false! ! 55447 55448!Collection methodsFor: 'testing' stamp: 'nk 8/30/2004 07:49'! 55449includesSubstringAnywhere: testString 55450 "Answer whether the receiver includes, anywhere in its nested structure, a string that has testString as a substring" 55451 self do: 55452 [:element | 55453 (element isString) 55454 ifTrue: 55455 [(element includesSubString: testString) ifTrue: [^ true]]. 55456 (element isCollection) 55457 ifTrue: 55458 [(element includesSubstringAnywhere: testString) ifTrue: [^ true]]]. 55459 ^ false 55460 55461"#(first (second third) ((allSentMessages ('Elvis' includes:)))) includesSubstringAnywhere: 'lvi'"! ! 55462 55463!Collection methodsFor: 'testing' stamp: 'ar 8/17/1999 19:43'! 55464isCollection 55465 "Return true if the receiver is some sort of Collection and responds to basic collection messages such as #size and #do:" 55466 ^true! ! 55467 55468!Collection methodsFor: 'testing'! 55469isEmpty 55470 "Answer whether the receiver contains any elements." 55471 55472 ^self size = 0! ! 55473 55474!Collection methodsFor: 'testing' stamp: 'bf 3/10/2000 09:29'! 55475isEmptyOrNil 55476 "Answer whether the receiver contains any elements, or is nil. Useful in numerous situations where one wishes the same reaction to an empty collection or to nil" 55477 55478 ^ self isEmpty! ! 55479 55480!Collection methodsFor: 'testing' stamp: 'di 11/6/1998 09:16'! 55481isSequenceable 55482 ^ false! ! 55483 55484!Collection methodsFor: 'testing' stamp: 'sma 5/12/2000 17:49'! 55485notEmpty 55486 "Answer whether the receiver contains any elements." 55487 55488 ^ self isEmpty not! ! 55489 55490!Collection methodsFor: 'testing'! 55491occurrencesOf: anObject 55492 "Answer how many of the receiver's elements are equal to anObject." 55493 55494 | tally | 55495 tally := 0. 55496 self do: [:each | anObject = each ifTrue: [tally := tally + 1]]. 55497 ^tally! ! 55498 55499 55500!Collection methodsFor: 'private'! 55501emptyCheck 55502 55503 self isEmpty ifTrue: [self errorEmptyCollection]! ! 55504 55505!Collection methodsFor: 'private'! 55506errorEmptyCollection 55507 55508 self error: 'this collection is empty'! ! 55509 55510!Collection methodsFor: 'private'! 55511errorNoMatch 55512 55513 self error: 'collection sizes do not match'! ! 55514 55515!Collection methodsFor: 'private' stamp: 'sma 5/12/2000 11:22'! 55516errorNotFound: anObject 55517 "Actually, this should raise a special Exception not just an error." 55518 55519 self error: 'Object is not in the collection.'! ! 55520 55521!Collection methodsFor: 'private' stamp: 'yo 6/29/2004 13:14'! 55522errorNotKeyed 55523 55524 self error: ('Instances of {1} do not respond to keyed accessing messages.' translated format: {self class name}) 55525! ! 55526 55527!Collection methodsFor: 'private'! 55528toBraceStack: itsSize 55529 "Push receiver's elements onto the stack of thisContext sender. Error if receiver does 55530 not have itsSize elements or if receiver is unordered. 55531 Do not call directly: this is called by {a. b} := ... constructs." 55532 55533 self size ~= itsSize ifTrue: 55534 [self error: 'Trying to store ', self size printString, 55535 ' values into ', itsSize printString, ' variables.']. 55536 thisContext sender push: itsSize fromIndexable: self! ! 55537 55538 55539!Collection methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 07:12'! 55540isZero 55541 "Answer whether the receiver is zero" 55542 self deprecated: 'You should not use this method.'. 55543 ^ false! ! 55544 55545"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 55546 55547Collection class 55548 instanceVariableNames: ''! 55549 55550!Collection class methodsFor: 'instance creation' stamp: 'apb 10/15/2000 22:05'! 55551ofSize: n 55552 "Create a new collection of size n with nil as its elements. 55553 This method exists because OrderedCollection new: n creates an 55554 empty collection, not one of size n." 55555 ^ self new: n! ! 55556 55557!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 19:58'! 55558with: anObject 55559 "Answer an instance of me containing anObject." 55560 55561 ^ self new 55562 add: anObject; 55563 yourself! ! 55564 55565!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:01'! 55566with: firstObject with: secondObject 55567 "Answer an instance of me containing the two arguments as elements." 55568 55569 ^ self new 55570 add: firstObject; 55571 add: secondObject; 55572 yourself! ! 55573 55574!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:03'! 55575with: firstObject with: secondObject with: thirdObject 55576 "Answer an instance of me containing the three arguments as elements." 55577 55578 ^ self new 55579 add: firstObject; 55580 add: secondObject; 55581 add: thirdObject; 55582 yourself! ! 55583 55584!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'! 55585with: firstObject with: secondObject with: thirdObject with: fourthObject 55586 "Answer an instance of me, containing the four arguments as the elements." 55587 55588 ^ self new 55589 add: firstObject; 55590 add: secondObject; 55591 add: thirdObject; 55592 add: fourthObject; 55593 yourself! ! 55594 55595!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'! 55596with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject 55597 "Answer an instance of me, containing the five arguments as the elements." 55598 55599 ^ self new 55600 add: firstObject; 55601 add: secondObject; 55602 add: thirdObject; 55603 add: fourthObject; 55604 add: fifthObject; 55605 yourself! ! 55606 55607!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'! 55608with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject 55609 "Answer an instance of me, containing the six arguments as the elements." 55610 55611 ^ self new 55612 add: firstObject; 55613 add: secondObject; 55614 add: thirdObject; 55615 add: fourthObject; 55616 add: fifthObject; 55617 add: sixthObject; 55618 yourself! ! 55619 55620!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:07'! 55621withAll: aCollection 55622 "Create a new collection containing all the elements from aCollection." 55623 55624 ^ (self new: aCollection size) 55625 addAll: aCollection; 55626 yourself! ! 55627 55628 55629!Collection class methodsFor: 'private' stamp: 'lr 11/4/2003 12:07'! 55630initialize 55631 "Set up a Random number generator to be used by atRandom when the 55632 user does not feel like creating his own Random generator." 55633 55634 RandomForPicking := Random new. 55635 MutexForPicking := Semaphore forMutualExclusion! ! 55636 55637!Collection class methodsFor: 'private' stamp: 'lr 11/4/2003 12:08'! 55638mutexForPicking 55639 ^ MutexForPicking! ! 55640 55641!Collection class methodsFor: 'private' stamp: 'sma 5/12/2000 12:31'! 55642randomForPicking 55643 ^ RandomForPicking! ! 55644Object subclass: #CollectionCombinator 55645 instanceVariableNames: 'resultProcessingBlock collectionOfArrays buffer' 55646 classVariableNames: '' 55647 poolDictionaries: '' 55648 category: 'KernelTests-Methods'! 55649!CollectionCombinator commentStamp: '<historical>' prior: 0! 55650For a collection of collections, enumerate all elements of the cartesian product. The code shows how recursion is used to implement variable nesting of loops. 55651The cartesian product is usually a huge collection, that should not be kept in memory. Therefore the user of the class has to provide a block with one argument that is called each time a tuple is constructed. When possible, that block should not build a collection of all these tuples, but should immediately drop unsuitable tuples. 55652To get a first impression, try this with 'inspect it': 55653 55654 | result | 55655 result := OrderedCollection new. 55656 CollectionCombinator new 55657 forArrays: (OrderedCollection with: #(#a #b #c) 55658 with: #(1 2 3 4 5) 55659 with: #('v' 'w' 'x' 'y' 'z') 55660 with: #('one' 'two' 'three') 55661 ) 55662 processWith: [:item |result addLast: item]. 55663 result 55664 ! 55665 55666 55667!CollectionCombinator methodsFor: 'as yet unclassified' stamp: 'BG 12/20/2001 21:33'! 55668combineFromIdx: myIdx 55669 55670 " this method is recursive. Recursion runs from values 1 to collectionOfArrays size of parameter myIdx. Each time it is called, this method has the responsiblity to provide all possible values for one index position of the result tuples. That index position is given by the value of myIdx." 55671 55672 (collectionOfArrays at: myIdx) do: 55673 [:item | 55674 buffer at: myIdx put: item. 55675 myIdx = collectionOfArrays size 55676 ifTrue: [resultProcessingBlock value: buffer shallowCopy] 55677 ifFalse: [self combineFromIdx: myIdx + 1] 55678 ]. 55679 55680 " The buffer is a shared object and its contents are later changed. It is therefore necessary to make a copy. "! ! 55681 55682!CollectionCombinator methodsFor: 'as yet unclassified' stamp: 'BG 12/20/2001 21:32'! 55683forArrays: anArray processWith: aBlock 55684 55685 " anArray is a kind of a sequenceable collection of arrays. 55686 aBlock is a block with one argument, that is used to process a tuple immediately after it is constructed. " 55687 collectionOfArrays := anArray. 55688 resultProcessingBlock := aBlock. 55689 buffer := Array new: anArray size. 55690 self combineFromIdx: 1 55691 ! ! 55692ClassTestCase subclass: #CollectionRootTest 55693 uses: TIterateTest + TEmptyTest + TSizeTest 55694 instanceVariableNames: '' 55695 classVariableNames: '' 55696 poolDictionaries: '' 55697 category: 'CollectionsTests-Abstract'! 55698!CollectionRootTest commentStamp: 'stephane.ducasse 1/12/2009 17:41' prior: 0! 55699I'm the root of the hierarchy of the collection tests. 55700! 55701 55702 55703!CollectionRootTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:36'! 55704collectionWithoutNilElements 55705" return a collection that doesn't includes a nil element and that doesn't includes equal elements'" 55706 self subclassResponsibility! ! 55707 55708!CollectionRootTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:20'! 55709doWithoutNumber 55710 55711 ^ 2! ! 55712 55713!CollectionRootTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:32'! 55714element 55715 ^ 3! ! 55716 55717!CollectionRootTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:14'! 55718elementTwiceIn 55719 ^ 1 "12332312322"! ! 55720 55721!CollectionRootTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:36'! 55722empty 55723 self subclassResponsibility! ! 55724 55725!CollectionRootTest methodsFor: 'requirements' stamp: 'damienpollet 1/21/2009 18:25'! 55726expectedElementByDetect 55727 55728 ^ -2! ! 55729 55730!CollectionRootTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:35'! 55731nonEmpty 55732 55733 self subclassResponsibility! ! 55734 55735!CollectionRootTest methodsFor: 'requirements'! 55736sizeCollection 55737 "Answers a collection not empty" 55738 ^ self explicitRequirement! ! 55739 55740 55741!CollectionRootTest methodsFor: 'test - fixture'! 55742test0FixtureIterateTest 55743 55744 55745| res | 55746self shouldnt: [ self collectionWithoutNilElements ] raise: Error. 55747 55748self assert: ( self collectionWithoutNilElements occurrencesOf: nil) = 0. 55749 55750res := true. 55751self collectionWithoutNilElements 55752 detect: [ :each | (self collectionWithoutNilElements occurrencesOf: each) > 1 ] 55753 ifNone: [ res := false ]. 55754self assert: res = false.! ! 55755 55756 55757!CollectionRootTest methodsFor: 'tests - empty'! 55758testIfEmpty 55759 55760 self nonEmpty ifEmpty: [ self assert: false] . 55761 self empty ifEmpty: [ self assert: true] . 55762 55763 55764 ! ! 55765 55766!CollectionRootTest methodsFor: 'tests - empty'! 55767testIfEmptyifNotEmpty 55768 55769 self assert: (self empty ifEmpty: [true] ifNotEmpty: [false]). 55770 self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [true]). 55771 ! ! 55772 55773!CollectionRootTest methodsFor: 'tests - empty'! 55774testIfEmptyifNotEmptyDo 55775 "self debug #testIfEmptyifNotEmptyDo" 55776 55777 self assert: (self empty ifEmpty: [true] ifNotEmptyDo: [:s | false]). 55778 self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | true]). 55779 self assert: (self nonEmpty 55780 ifEmpty: [false] 55781 ifNotEmptyDo: [:s | s]) == self nonEmpty.! ! 55782 55783!CollectionRootTest methodsFor: 'tests - empty'! 55784testIfNotEmpty 55785 55786 self empty ifNotEmpty: [self assert: false]. 55787 self nonEmpty ifNotEmpty: [self assert: true]. 55788 self assert: (self nonEmpty ifNotEmpty: [:s | s ]) = self nonEmpty 55789 ! ! 55790 55791!CollectionRootTest methodsFor: 'tests - empty'! 55792testIfNotEmptyDo 55793 55794 self empty ifNotEmptyDo: [:s | self assert: false]. 55795 self assert: (self nonEmpty ifNotEmptyDo: [:s | s]) == self nonEmpty 55796! ! 55797 55798!CollectionRootTest methodsFor: 'tests - empty'! 55799testIfNotEmptyDoifNotEmpty 55800 55801 self assert: (self empty ifNotEmptyDo: [:s | false] ifEmpty: [true]). 55802 self assert: (self nonEmpty 55803 ifNotEmptyDo: [:s | s] 55804 ifEmpty: [false]) == self nonEmpty! ! 55805 55806!CollectionRootTest methodsFor: 'tests - empty'! 55807testIfNotEmptyifEmpty 55808 55809 self assert: (self empty ifNotEmpty: [false] ifEmpty: [true]). 55810 self assert: (self nonEmpty ifNotEmpty: [true] ifEmpty: [false]). 55811 ! ! 55812 55813!CollectionRootTest methodsFor: 'tests - empty'! 55814testIsEmpty 55815 55816 self assert: (self empty isEmpty). 55817 self deny: (self nonEmpty isEmpty).! ! 55818 55819!CollectionRootTest methodsFor: 'tests - empty'! 55820testIsEmptyOrNil 55821 55822 self assert: (self empty isEmptyOrNil). 55823 self deny: (self nonEmpty isEmptyOrNil).! ! 55824 55825!CollectionRootTest methodsFor: 'tests - empty'! 55826testNotEmpty 55827 55828 self assert: (self nonEmpty notEmpty). 55829 self deny: (self empty notEmpty).! ! 55830 55831 55832!CollectionRootTest methodsFor: 'tests - fixture'! 55833test0FixtureEmptyTest 55834 55835self shouldnt: [ self nonEmpty ] raise: Error. 55836self deny: self nonEmpty isEmpty. 55837 55838self shouldnt: [ self empty ] raise: Error. 55839self assert: self empty isEmpty.! ! 55840 55841!CollectionRootTest methodsFor: 'tests - fixture'! 55842test0TSizeTest 55843 self shouldnt: [self empty] raise: Error. 55844 self shouldnt: [self sizeCollection] raise: Error. 55845 self assert: self empty isEmpty. 55846 self deny: self sizeCollection isEmpty.! ! 55847 55848 55849!CollectionRootTest methodsFor: 'tests - iterate' stamp: 'delaunay 5/14/2009 11:03'! 55850testDoSeparatedBy 55851 | string expectedString beforeFirst | 55852 string := ''. 55853 self collectionWithoutNilElements 55854 do: [ :each | string := string , each asString ] 55855 separatedBy: [ string := string , '|' ]. 55856 expectedString := ''. 55857 beforeFirst := true. 55858 self collectionWithoutNilElements do: 55859 [ :each | 55860 beforeFirst = true 55861 ifTrue: [ beforeFirst := false ] 55862 ifFalse: [ expectedString := expectedString , '|' ]. 55863 expectedString := expectedString , each asString ]. 55864 self assert: expectedString = string! ! 55865 55866!CollectionRootTest methodsFor: 'tests - iterate' stamp: 'delaunay 5/14/2009 11:08'! 55867testRejectNoReject 55868 | res collection | 55869 collection := self collectionWithoutNilElements . 55870 res := collection reject: [ :each | each isNil ]. 55871 self assert: res size = collection size! ! 55872 55873 55874!CollectionRootTest methodsFor: 'tests - iterating'! 55875testAllSatisfy 55876 55877 | element | 55878 " when all element satisfy the condition, should return true : " 55879 self assert: ( self collectionWithoutNilElements allSatisfy: [:each | (each notNil) ] ). 55880 55881 " when all element don't satisfy the condition, should return false : " 55882 self deny: ( self collectionWithoutNilElements allSatisfy: [:each | (each notNil) not ] ). 55883 55884 " when only one element doesn't satisfy the condition' should return false'" 55885 element := self collectionWithoutNilElements anyOne. 55886 self deny: ( self collectionWithoutNilElements allSatisfy: [:each | (each = element) not] ).! ! 55887 55888!CollectionRootTest methodsFor: 'tests - iterating'! 55889testAllSatisfyEmpty 55890 55891 self assert: ( self empty allSatisfy: [:each | false]). 55892 ! ! 55893 55894!CollectionRootTest methodsFor: 'tests - iterating'! 55895testAnySastify 55896 55897 | element | 55898 " when all elements satisty the condition, should return true :" 55899 self assert: ( self collectionWithoutNilElements anySatisfy: [:each | each notNil ]). 55900 55901 " when only one element satisfy the condition, should return true :" 55902 element := self collectionWithoutNilElements anyOne. 55903 self assert: ( self collectionWithoutNilElements anySatisfy: [:each | (each = element) ] ). 55904 55905 " when all elements don't satisty the condition, should return false :" 55906 self deny: ( self collectionWithoutNilElements anySatisfy: [:each | (each notNil) not ]). 55907! ! 55908 55909!CollectionRootTest methodsFor: 'tests - iterating'! 55910testBasicCollect 55911 55912 | res index | 55913 index := 0. 55914 res := self collectionWithoutNilElements collect: [ 55915 :each | 55916 index := index + 1. 55917 each 55918 ]. 55919 55920 res do:[:each | self assert: (self collectionWithoutNilElements occurrencesOf: each) = (res occurrencesOf: each)]. 55921 self assert: index = self collectionWithoutNilElements size. 55922 ! ! 55923 55924!CollectionRootTest methodsFor: 'tests - iterating'! 55925testBasicCollectEmpty 55926 55927 | res | 55928 res := self empty collect: [:each | each class]. 55929 self assert: res isEmpty 55930 ! ! 55931 55932!CollectionRootTest methodsFor: 'tests - iterating'! 55933testCollectOnEmpty 55934 self assert: (self empty collect: [:e | self fail]) isEmpty! ! 55935 55936!CollectionRootTest methodsFor: 'tests - iterating'! 55937testCollectThenSelectOnEmpty 55938 55939 self assert: (self empty collect: [:e | self fail] thenSelect: [:e | self fail]) isEmpty! ! 55940 55941!CollectionRootTest methodsFor: 'tests - iterating'! 55942testDetect 55943 55944 | res element | 55945 element := self collectionWithoutNilElements anyOne . 55946 55947 res := self collectionWithoutNilElements detect: [:each | each = element]. 55948 self assert: (res = element). 55949 55950 55951 ! ! 55952 55953!CollectionRootTest methodsFor: 'tests - iterating'! 55954testDetectIfNone 55955 55956 | res element | 55957 res := self collectionWithoutNilElements detect: [:each | each notNil not] ifNone: [100]. 55958 self assert: res = 100. 55959 55960 element := self collectionWithoutNilElements anyOne. 55961 res := self collectionWithoutNilElements detect: [:each | each = element] ifNone: [100]. 55962 self assert: res = element. 55963 55964 55965 ! ! 55966 55967!CollectionRootTest methodsFor: 'tests - iterating'! 55968testDo2 55969 "dc: Bad test, it assumes that a new instance of #speciesClass allows addition with #add:. This is not the case of Interval for which species is Array." 55970 "res := self speciesClass new. 55971 self collection do: [:each | res add: each class]. 55972 self assert: res = self result. " 55973 | collection cptElementsViewed cptElementsIn | 55974 collection := self collectionWithoutNilElements. 55975 cptElementsViewed := 0. 55976 cptElementsIn := OrderedCollection new. 55977 collection do: 55978 [ :each | 55979 cptElementsViewed := cptElementsViewed + 1. 55980 " #do doesn't iterate with the same objects than those in the collection for FloatArray( I don' t know why ) . That's why I use #includes: and not #identityIncludes: '" 55981 (collection includes: each) ifTrue: [ 55982 " the collection used doesn't include equal elements. Therefore each element viewed should not have been viewed before " 55983 ( cptElementsIn includes: each ) ifFalse: [ cptElementsIn add: each ] . 55984 ]. 55985 ]. 55986 self assert: cptElementsViewed = collection size. 55987 self assert: cptElementsIn size = collection size. 55988 55989 ! ! 55990 55991!CollectionRootTest methodsFor: 'tests - iterating'! 55992testDoWithout 55993 "self debug: #testDoWithout" 55994 55995 | res element collection | 55996 collection := self collectionWithoutNilElements . 55997 res := OrderedCollection new. 55998 element := self collectionWithoutNilElements anyOne . 55999 collection do: [:each | res add: each] without: element . 56000 " verifying result :" 56001 self assert: res size = (collection size - (collection occurrencesOf: element)). 56002 res do: [:each | self assert: (collection occurrencesOf: each) = ( res occurrencesOf: each ) ]. 56003 ! ! 56004 56005!CollectionRootTest methodsFor: 'tests - iterating'! 56006testInjectInto 56007 |result| 56008 result:= self collectionWithoutNilElements 56009 inject: 0 56010 into: [:inj :ele | ele notNil ifTrue: [ inj + 1 ]]. 56011 56012 self assert: self collectionWithoutNilElements size = result .! ! 56013 56014!CollectionRootTest methodsFor: 'tests - iterating'! 56015testNoneSatisfy 56016 56017 | element | 56018 self assert: ( self collectionWithoutNilElements noneSatisfy: [:each | each notNil not ] ). 56019 element := self collectionWithoutNilElements anyOne. 56020 self deny: ( self collectionWithoutNilElements noneSatisfy: [:each | (each = element)not ] ).! ! 56021 56022!CollectionRootTest methodsFor: 'tests - iterating'! 56023testNoneSatisfyEmpty 56024 56025 self assert: ( self empty noneSatisfy: [:each | false]). 56026 ! ! 56027 56028!CollectionRootTest methodsFor: 'tests - iterating'! 56029testReject 56030 56031 | res element | 56032 res := self collectionWithoutNilElements reject: [:each | each notNil not]. 56033 self assert: res size = self collectionWithoutNilElements size. 56034 56035 element := self collectionWithoutNilElements anyOne. 56036 res := self collectionWithoutNilElements reject: [:each | each = element]. 56037 self assert: res size = (self collectionWithoutNilElements size - 1). 56038 56039 56040 ! ! 56041 56042!CollectionRootTest methodsFor: 'tests - iterating'! 56043testRejectEmpty 56044 56045 | res | 56046 res := self empty reject: [:each | each odd]. 56047 self assert: res size = self empty size 56048 ! ! 56049 56050!CollectionRootTest methodsFor: 'tests - iterating'! 56051testSelect 56052 56053 | res element | 56054 res := self collectionWithoutNilElements select: [:each | each notNil]. 56055 self assert: res size = self collectionWithoutNilElements size. 56056 56057 element := self collectionWithoutNilElements anyOne. 56058 res := self collectionWithoutNilElements select: [:each | (each = element) not]. 56059 self assert: res size = (self collectionWithoutNilElements size - 1). 56060 ! ! 56061 56062!CollectionRootTest methodsFor: 'tests - iterating'! 56063testSelectOnEmpty 56064 56065 self assert: (self empty select: [:e | self fail]) isEmpty 56066 ! ! 56067 56068 56069!CollectionRootTest methodsFor: 'tests - size capacity'! 56070testSize 56071 56072 | size | 56073 self assert: self empty size = 0. 56074 size := 0. 56075 self sizeCollection do: [ :each | size := size + 1]. 56076 56077 self assert: self sizeCollection size = size.! ! 56078 56079"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 56080 56081CollectionRootTest class 56082 instanceVariableNames: ''! 56083 56084!CollectionRootTest class methodsFor: 'as yet unclassified' stamp: 'damienpollet 1/13/2009 15:28'! 56085isAbstract 56086 56087 ^ self name = #CollectionRootTest! ! 56088Object subclass: #Color 56089 instanceVariableNames: 'rgb cachedDepth cachedBitPattern' 56090 classVariableNames: 'Black Blue BlueShift Brown CachedColormaps ColorChart ColorNames ComponentMask ComponentMax Cyan DarkGray Gray GrayToIndexMap Green GreenShift HalfComponentMask HighLightBitmaps IndexedColors LightBlue LightBrown LightCyan LightGray LightGreen LightMagenta LightOrange LightRed LightYellow Magenta MaskingMap Orange PureBlue PureCyan PureGreen PureMagenta PureRed PureYellow RandomStream Red RedShift TranslucentPatterns Transparent VeryDarkGray VeryLightGray VeryVeryDarkGray VeryVeryLightGray White Yellow' 56091 poolDictionaries: '' 56092 category: 'Graphics-Primitives'! 56093!Color commentStamp: '<historical>' prior: 0! 56094This class represents abstract color, regardless of the depth of bitmap it will be shown in. At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with. The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. (See comment in BitBlt.) To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8). (See comment in DisplayMedium) 56095 Color is represented as the amount of light in red, green, and blue. White is (1.0, 1.0, 1.0) and black is (0, 0, 0). Pure red is (1.0, 0, 0). These colors are "additive". Think of Color's instance variables as: 56096 r amount of red, a Float between 0.0 and 1.0. 56097 g amount of green, a Float between 0.0 and 1.0. 56098 b amount of blue, a Float between 0.0 and 1.0. 56099(But, in fact, the three are encoded as values from 0 to 1023 and combined in a single integer, rgb. The user does not need to know this.) 56100 Many colors are named. You find a color by name by sending a message to class Color, for example (Color lightBlue). Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below) 56101 A color is essentially immutable. Once you set red, green, and blue, you cannot change them. Instead, create a new Color and use it. 56102 Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number. Convert the range of this number to an integer from 1 to N. Then call (Color green lightShades: N) to get an Array of colors from white to green. Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array. atPin: gives the first (or last) color if the index is out of range. atWrap: wraps around to the other end if the index is out of range. 56103 Here are some fun things to run in when your screen has color: 56104 Pen new mandala: 30 diameter: Display height-100. 56105 Pen new web "Draw with the mouse, opt-click to end" 56106 Display fillWhite. Pen new hilberts: 5. 56107 Form toothpaste: 30 "Draw with mouse, opt-click to end" 56108You might also want to try the comment in 56109 Form>class>examples>tinyText... 56110 56111 56112Messages: 56113 mixed: proportion with: aColor Answer this color mixed with the given color additively. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix. 56114 56115 + add two colors 56116 - subtract two colors 56117 * multiply the values of r, g, b by a number or an Array of factors. ((Color named: #white) * 0.3) gives a darkish gray. (aColor * #(0 0 0.9)) gives a color with slightly less blue. 56118 / divide a color by a factor or an array of three factors. 56119 56120 errorForDepth: d How close the nearest color at this depth is to this abstract color. Sum of the squares of the RGB differences, square rooted and normalized to 1.0. Multiply by 100 to get percent. 56121 56122 hue Returns the hue of the color. On a wheel from 0 to 360 with pure red at 0 and again at 360. 56123 saturation Returns the saturation of the color. 0.0 to 1.0 56124 brightness Returns the brightness of the color. 0.0 to 1.0 56125 56126 name Look to see if this Color has a name. 56127 display Show a swatch of this color tracking the cursor. 56128 56129 lightShades: thisMany An array of thisMany colors from white to the receiver. 56130 darkShades: thisMany An array of thisMany colors from black to the receiver. Array is of length num. 56131 mix: color2 shades: thisMany An array of thisMany colors from the receiver to color2. 56132 wheel: thisMany An array of thisMany colors around the color wheel starting and ending at the receiver. 56133 56134 pixelValueForDepth: d Returns the bits that appear be in a Bitmap of this depth for this color. Represents the nearest available color at this depth. Normal users do not need to know which pixelValue is used for which color. 56135 56136Messages to Class Color. 56137 red: r green: g blue: b Return a color with the given r, g, and b components. 56138 r: g: b: Same as above, for fast typing. 56139 56140 hue: h saturation: s brightness: b Create a color with the given hue, saturation, and brightness. 56141 56142 pink 56143 blue 56144 red ... Many colors have messages that return an instance of Color. 56145 canUnderstand: #brown Returns true if #brown is a defined color. 56146 names An OrderedCollection of the names of the colors. 56147 named: #notAllThatGray put: aColor Add a new color to the list and create an access message and a class variable for it. 56148 fromUser Shows the palette of colors available at this display depth. Click anywhere to return the color you clicked on. 56149 56150 hotColdShades: thisMany An array of thisMany colors showing temperature from blue to red to white hot. 56151 56152 stdColorsForDepth: d An Array of colors available at this depth. For 16 bit and 32 bits, returns a ColorGenerator. It responds to at: with a Color for that index, simulating a very big Array. 56153 56154 colorFromPixelValue: value depth: d Returns a Color whose bit pattern (inside a Bitmap) at this depth is the number specified. Normal users do not need to use this. 56155 56156(See also comments in these classes: Form, Bitmap, BitBlt, Pattern, MaskedForm.)! 56157 56158 56159!Color methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/17/2007 11:41'! 56160contrastingColor 56161 "Answer black or white depending on the luminance." 56162 56163 self isTransparent ifTrue: [^Color black]. 56164 ^self luminance > 0.5 56165 ifTrue: [Color black] 56166 ifFalse: [Color white]! ! 56167 56168!Color methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/21/2008 16:35'! 56169fillRectangle: aRectangle on: aCanvas 56170 "Fill the given rectangle on the given canvas with the receiver." 56171 56172 aCanvas fillRectangle: aRectangle basicFillStyle: self! ! 56173 56174!Color methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/21/2006 09:48'! 56175pixelWord32 56176 "Returns an integer representing the bits that appear in a single pixel of this color in a Form of depth 32. 56177 Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue. 56178 Just a little quicker if we are dealing with RGBA colors at 32 bit depth." 56179 56180 | val | 56181 "eight bits per component; top 8 bits set to all ones (opaque alpha)" 56182 val := LargePositiveInteger new: 4. 56183 val at: 3 put: ((rgb bitShift: -22) bitAnd: 16rFF). 56184 val at: 2 put: ((rgb bitShift: -12) bitAnd: 16rFF). 56185 val at: 1 put: ((rgb bitShift: -2) bitAnd: 16rFF). 56186 val = 0 ifTrue: [val at: 1 put: 1]. "closest non-transparent black" 56187 val at: 4 put: 16rFF. "opaque alpha" 56188 ^val 56189! ! 56190 56191 56192!Color methodsFor: '*morphic' stamp: 'ar 7/8/2006 21:00'! 56193iconOrThumbnailOfSize: aNumberOrPoint 56194 "Answer an appropiate form to represent the receiver" 56195 | form | 56196 form := Form extent: aNumberOrPoint asPoint asPoint depth: 32. 56197 form fillColor: self. 56198 ^ form! ! 56199 56200 56201!Color methodsFor: 'access'! 56202alpha 56203 "Return the opacity ('alpha') value of opaque so that normal colors can be compared to TransparentColors." 56204 56205 ^ 1.0 56206! ! 56207 56208!Color methodsFor: 'access'! 56209blue 56210 "Return the blue component of this color, a float in the range [0.0..1.0]." 56211 56212 ^ self privateBlue asFloat / ComponentMax! ! 56213 56214!Color methodsFor: 'access'! 56215brightness 56216 "Return the brightness of this color, a float in the range [0.0..1.0]." 56217 56218 ^ ((self privateRed max: 56219 self privateGreen) max: 56220 self privateBlue) asFloat / ComponentMax! ! 56221 56222!Color methodsFor: 'access'! 56223green 56224 "Return the green component of this color, a float in the range [0.0..1.0]." 56225 56226 ^ self privateGreen asFloat / ComponentMax! ! 56227 56228!Color methodsFor: 'access' stamp: 'lr 7/4/2009 10:42'! 56229hue 56230 "Return the hue of this color, an angle in the range [0.0..360.0]." 56231 | r g b max min span h | 56232 r := self privateRed. 56233 g := self privateGreen. 56234 b := self privateBlue. 56235 max := (r max: g) max: b. 56236 min := (r min: g) min: b. 56237 span := (max - min) asFloat. 56238 span = 0.0 ifTrue: [ ^ 0.0 ]. 56239 r = max 56240 ifTrue: [ h := (g - b) asFloat / span * 60.0 ] 56241 ifFalse: 56242 [ g = max 56243 ifTrue: [ h := 120.0 + ((b - r) asFloat / span * 60.0) ] 56244 ifFalse: [ h := 240.0 + ((r - g) asFloat / span * 60.0) ] ]. 56245 h < 0.0 ifTrue: [ h := 360.0 + h ]. 56246 ^ h! ! 56247 56248!Color methodsFor: 'access'! 56249luminance 56250 "Return the luminance of this color, a brightness value weighted by the human eye's color sensitivity." 56251 56252 ^ ((299 * self privateRed) + 56253 (587 * self privateGreen) + 56254 (114 * self privateBlue)) / (1000 * ComponentMax) 56255! ! 56256 56257!Color methodsFor: 'access'! 56258red 56259 "Return the red component of this color, a float in the range [0.0..1.0]." 56260 56261 ^ self privateRed asFloat / ComponentMax! ! 56262 56263!Color methodsFor: 'access' stamp: 'lr 7/4/2009 10:42'! 56264saturation 56265 "Return the saturation of this color, a value between 0.0 and 1.0." 56266 | r g b max min | 56267 r := self privateRed. 56268 g := self privateGreen. 56269 b := self privateBlue. 56270 max := min := r. 56271 g > max ifTrue: [ max := g ]. 56272 b > max ifTrue: [ max := b ]. 56273 g < min ifTrue: [ min := g ]. 56274 b < min ifTrue: [ min := b ]. 56275 max = 0 56276 ifTrue: [ ^ 0.0 ] 56277 ifFalse: [ ^ (max - min) asFloat / max asFloat ]! ! 56278 56279 56280!Color methodsFor: 'conversions' stamp: 'ar 11/2/1998 12:19'! 56281asColor 56282 "Convert the receiver into a color" 56283 ^self! ! 56284 56285!Color methodsFor: 'conversions' stamp: 'TBn 6/15/2000 20:37'! 56286asColorref 56287 "Convert the receiver into a colorref" 56288 ^(self red * 255) asInteger + ((self green * 255) asInteger << 8) + ((self green * 255) asInteger << 16)! ! 56289 56290!Color methodsFor: 'conversions' stamp: 'bf 2/19/2008 12:10'! 56291asHTMLColor 56292 | s | 56293 s := '#000000' copy. 56294 s at: 2 put: (Character digitValue: ((rgb bitShift: -6 - RedShift) bitAnd: 15)). 56295 s at: 3 put: (Character digitValue: ((rgb bitShift: -2 - RedShift) bitAnd: 15)). 56296 s at: 4 put: (Character digitValue: ((rgb bitShift: -6 - GreenShift) bitAnd: 15)). 56297 s at: 5 put: (Character digitValue: ((rgb bitShift: -2 - GreenShift) bitAnd: 15)). 56298 s at: 6 put: (Character digitValue: ((rgb bitShift: -6 - BlueShift) bitAnd: 15)). 56299 s at: 7 put: (Character digitValue: ((rgb bitShift: -2 - BlueShift) bitAnd: 15)). 56300 ^ s! ! 56301 56302!Color methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'! 56303asNontranslucentColor 56304 ^ self! ! 56305 56306!Color methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 56307balancedPatternForDepth: depth 56308 "A generalization of bitPatternForDepth: as it exists. Generates a 2x2 stipple of color. 56309 The topLeft and bottomRight pixel are closest approx to this color" 56310 | pv1 pv2 mask1 mask2 pv3 c | 56311 (depth == cachedDepth and: [ cachedBitPattern size = 2 ]) ifTrue: [ ^ cachedBitPattern ]. 56312 (depth 56313 between: 4 56314 and: 16) ifFalse: [ ^ self bitPatternForDepth: depth ]. 56315 cachedDepth := depth. 56316 pv1 := self pixelValueForDepth: depth. 56317 " 56318 Subtract error due to pv1 to get pv2. 56319 pv2 _ (self - (err1 _ (Color colorFromPixelValue: pv1 depth: depth) - self)) 56320 pixelValueForDepth: depth. 56321 Subtract error due to 2 pv1's and pv2 to get pv3. 56322 pv3 _ (self - err1 - err1 - ((Color colorFromPixelValue: pv2 depth: depth) - self)) 56323 pixelValueForDepth: depth. 56324" 56325 "Above two statements computed faster by the following..." 56326 pv2 := (c := self - ((Color 56327 colorFromPixelValue: pv1 56328 depth: depth) - self)) pixelValueForDepth: depth. 56329 pv3 := c + (c - (Color 56330 colorFromPixelValue: pv2 56331 depth: depth)) pixelValueForDepth: depth. 56332 56333 "Return to a 2-word bitmap that encodes a 2x2 stipple of the given pixelValues." 56334 mask1 := #( 56335 #- 56336 #- 56337 #- 56338 16843009 56339 #- 56340 #- 56341 #- 56342 65537 56343 #- 56344 #- 56345 #- 56346 #- 56347 #- 56348 #- 56349 #- 56350 1 56351 ) at: depth. "replicates every other 4 bits" "replicates every other 8 bits" "replicates every other 16 bits" 56352 mask2 := #( 56353 #- 56354 #- 56355 #- 56356 269488144 56357 #- 56358 #- 56359 #- 56360 16777472 56361 #- 56362 #- 56363 #- 56364 #- 56365 #- 56366 #- 56367 #- 56368 65536 56369 ) at: depth. "replicates the other 4 bits" "replicates the other 8 bits" "replicates the other 16 bits" 56370 ^ cachedBitPattern := Bitmap 56371 with: mask1 * pv1 + (mask2 * pv2) 56372 with: mask1 * pv3 + (mask2 * pv1)! ! 56373 56374!Color methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 56375bitPatternForDepth: depth 56376 "Return a Bitmap, possibly containing a stipple pattern, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps. The resulting Bitmap may be multiple words to represent a stipple pattern of several lines. " 56377 "See also: pixelValueAtDepth: -- value for single pixel 56378 pixelWordAtDepth: -- a 32-bit word filled with the pixel value" 56379 "Details: The pattern for the most recently requested depth is cached." 56380 "Note for depths > 2, there are stippled and non-stippled versions (generated with #balancedPatternForDepth: and #bitPatternForDepth:, respectively). The stippled versions don't work with the window bit caching of StandardSystemView, so we make sure that for these depths, only unstippled patterns are returned" 56381 (depth == cachedDepth and: [ depth <= 2 or: [ cachedBitPattern size = 1 ] ]) ifTrue: [ ^ cachedBitPattern ]. 56382 cachedDepth := depth. 56383 depth > 2 ifTrue: [ ^ cachedBitPattern := Bitmap with: (self pixelWordForDepth: depth) ]. 56384 depth = 1 ifTrue: [ ^ cachedBitPattern := self halfTonePattern1 ]. 56385 depth = 2 ifTrue: [ ^ cachedBitPattern := self halfTonePattern2 ]! ! 56386 56387!Color methodsFor: 'conversions'! 56388closestPixelValue1 56389 "Return the nearest approximation to this color for a monochrome Form." 56390 56391 "fast special cases" 56392 rgb = 0 ifTrue: [^ 1]. "black" 56393 rgb = 16r3FFFFFFF ifTrue: [^ 0]. "white" 56394 56395 self luminance > 0.5 56396 ifTrue: [^ 0] "white" 56397 ifFalse: [^ 1]. "black" 56398! ! 56399 56400!Color methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 56401closestPixelValue2 56402 "Return the nearest approximation to this color for a 2-bit deep Form." 56403 "fast special cases" 56404 | lum | 56405 rgb = 0 ifTrue: [ ^ 1 ]. "black" 56406 rgb = 1073741823 ifTrue: [ ^ 2 ]. "opaque white" 56407 lum := self luminance. 56408 lum < 0.2 ifTrue: [ ^ 1 ]. "black" 56409 lum > 0.6 ifTrue: [ ^ 2 ]. "opaque white" 56410 ^ 3 "50% gray"! ! 56411 56412!Color methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 56413closestPixelValue4 56414 "Return the nearest approximation to this color for a 4-bit deep Form." 56415 "fast special cases" 56416 | bIndex | 56417 rgb = 0 ifTrue: [ ^ 1 ]. "black" 56418 rgb = 1073741823 ifTrue: [ ^ 2 ]. "opaque white" 56419 rgb = PureRed privateRGB ifTrue: [ ^ 4 ]. 56420 rgb = PureGreen privateRGB ifTrue: [ ^ 5 ]. 56421 rgb = PureBlue privateRGB ifTrue: [ ^ 6 ]. 56422 rgb = PureCyan privateRGB ifTrue: [ ^ 7 ]. 56423 rgb = PureYellow privateRGB ifTrue: [ ^ 8 ]. 56424 rgb = PureMagenta privateRGB ifTrue: [ ^ 9 ]. 56425 bIndex := (self luminance * 8.0) rounded. "bIndex in [0..8]" 56426 ^ #(1 10 11 12 3 13 14 15 2 ) at: bIndex + 1 "black" "1/8 gray" "2/8 gray" "3/8 gray" "4/8 gray" "5/8 gray" "6/8 gray" "7/8 gray" "opaque white"! ! 56427 56428!Color methodsFor: 'conversions'! 56429closestPixelValue8 56430 "Return the nearest approximation to this color for an 8-bit deep Form." 56431 56432 "fast special cases" 56433 rgb = 0 ifTrue: [^ 1]. "black" 56434 rgb = 16r3FFFFFFF ifTrue: [^ 255]. "white" 56435 56436 self saturation < 0.2 ifTrue: [ 56437 ^ GrayToIndexMap at: (self privateGreen >> 2) + 1. "nearest gray" 56438 ] ifFalse: [ 56439 "compute nearest entry in the color cube" 56440 ^ 40 + 56441 ((((self privateRed * 5) + HalfComponentMask) // ComponentMask) * 36) + 56442 ((((self privateBlue * 5) + HalfComponentMask) // ComponentMask) * 6) + 56443 (((self privateGreen * 5) + HalfComponentMask) // ComponentMask)]. 56444! ! 56445 56446!Color methodsFor: 'conversions' stamp: 'di 9/2/97 20:21'! 56447dominantColor 56448 ^ self! ! 56449 56450!Color methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 56451halfTonePattern1 56452 "Return a halftone-pattern to approximate luminance levels on 1-bit deep Forms." 56453 | lum | 56454 lum := self luminance. 56455 lum < 0.1 ifTrue: [ ^ Bitmap with: 4294967295 ]. "black" 56456 lum < 0.4 ifTrue: 56457 [ ^ Bitmap 56458 with: 3149642683 56459 with: 4008636142 ]. "dark gray" 56460 lum < 0.6 ifTrue: 56461 [ ^ Bitmap 56462 with: 1431655765 56463 with: 2863311530 ]. "medium gray" 56464 lum < 0.9 ifTrue: 56465 [ ^ Bitmap 56466 with: 1145324612 56467 with: 286331153 ]. "light gray" 56468 ^ Bitmap with: 0 "1-bit white"! ! 56469 56470!Color methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 56471halfTonePattern2 56472 "Return a halftone-pattern to approximate luminance levels on 2-bit deep Forms." 56473 | lum | 56474 lum := self luminance. 56475 lum < 0.125 ifTrue: [ ^ Bitmap with: 1431655765 ]. "black" 56476 lum < 0.25 ifTrue: 56477 [ ^ Bitmap 56478 with: 1431655765 56479 with: 3722304989 ]. "1/8 gray" 56480 lum < 0.375 ifTrue: 56481 [ ^ Bitmap 56482 with: 3722304989 56483 with: 2004318071 ]. "2/8 gray" 56484 lum < 0.5 ifTrue: 56485 [ ^ Bitmap 56486 with: 4294967295 56487 with: 2004318071 ]. "3/8 gray" 56488 lum < 0.625 ifTrue: [ ^ Bitmap with: 4294967295 ]. "4/8 gray" 56489 lum < 0.75 ifTrue: 56490 [ ^ Bitmap 56491 with: 4294967295 56492 with: 3149642683 ]. "5/8 gray" 56493 lum < 0.875 ifTrue: 56494 [ ^ Bitmap 56495 with: 4008636142 56496 with: 3149642683 ]. "6/8 gray" 56497 lum < 1.0 ifTrue: 56498 [ ^ Bitmap 56499 with: 2863311530 56500 with: 3149642683 ]. "7/8 gray" 56501 ^ Bitmap with: 2863311530 "opaque white" 56502 56503 "handy expression for computing patterns for 2x2 tiles; 56504 set p to a string of 4 letters (e.g., 'wggw' for a gray-and- 56505 white checkerboard) and print the result of evaluating: 56506| p d w1 w2 | 56507p _ 'wggw'. 56508d _ Dictionary new. 56509d at: $b put: '01'. 56510d at: $w put: '10'. 56511d at: $g put: '11'. 56512w1 _ (d at: (p at: 1)), (d at: (p at: 2)). 56513w1 _ '2r', w1, w1, w1, w1, w1, w1, w1, w1, ' hex'. 56514w2 _ (d at: (p at: 3)), (d at: (p at: 4)). 56515w2 _ '2r', w2, w2, w2, w2, w2, w2, w2, w2, ' hex'. 56516Array with: (Compiler evaluate: w1) with: (Compiler evaluate: w2) 56517"! ! 56518 56519!Color methodsFor: 'conversions' stamp: 'tk 4/24/97'! 56520indexInMap: aColorMap 56521 "Return the index corresponding to this color in the given color map. RGB colors are truncated to 3-, 4-, or 5-bits per color component when indexing into such a colorMap. " 56522 56523 aColorMap size = 2 ifTrue: [^ (self pixelValueForDepth: 1) + 1]. 56524 aColorMap size = 4 ifTrue: [^ (self pixelValueForDepth: 2) + 1]. 56525 aColorMap size = 16 ifTrue: [^ (self pixelValueForDepth: 4) + 1]. 56526 aColorMap size = 256 ifTrue: [^ (self pixelValueForDepth: 8) + 1]. 56527 aColorMap size = 512 ifTrue: [^ (self pixelValueForDepth: 9) + 1]. 56528 aColorMap size = 4096 ifTrue: [^ (self pixelValueForDepth: 12) + 1]. 56529 aColorMap size = 32768 ifTrue: [^ (self pixelValueForDepth: 16) + 1]. 56530 self error: 'unknown pixel depth'. 56531! ! 56532 56533!Color methodsFor: 'conversions' stamp: 'bf 4/18/2001 16:25'! 56534makeForegroundColor 56535 "Make a foreground color contrasting with me" 56536 ^self luminance >= 0.5 56537 ifTrue: [Color black] 56538 ifFalse: [Color white]! ! 56539 56540!Color methodsFor: 'conversions' stamp: 'ar 5/15/2001 16:12'! 56541pixelValue32 56542 "Note: pixelWord not pixelValue so we include translucency" 56543 ^self pixelWordForDepth: 32! ! 56544 56545!Color methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 56546pixelValueForDepth: d 56547 "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" 56548 "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." 56549 "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue." 56550 | rgbBlack val | 56551 d = 8 ifTrue: [ ^ self closestPixelValue8 ]. "common case" 56552 d < 8 ifTrue: 56553 [ d = 4 ifTrue: [ ^ self closestPixelValue4 ]. 56554 d = 2 ifTrue: [ ^ self closestPixelValue2 ]. 56555 d = 1 ifTrue: [ ^ self closestPixelValue1 ] ]. 56556 rgbBlack := 1. "closest black that is not transparent in RGB" 56557 d = 16 ifTrue: 56558 [ "five bits per component; top bits ignored" 56559 val := (((rgb bitShift: -15) bitAnd: 31744) bitOr: ((rgb bitShift: -10) bitAnd: 992)) bitOr: ((rgb bitShift: -5) bitAnd: 31). 56560 ^ val = 0 56561 ifTrue: [ rgbBlack ] 56562 ifFalse: [ val ] ]. 56563 d = 32 ifTrue: 56564 [ "eight bits per component; top 8 bits set to all ones (opaque alpha)" 56565 val := LargePositiveInteger new: 4. 56566 val 56567 at: 3 56568 put: ((rgb bitShift: -22) bitAnd: 255). 56569 val 56570 at: 2 56571 put: ((rgb bitShift: -12) bitAnd: 255). 56572 val 56573 at: 1 56574 put: ((rgb bitShift: -2) bitAnd: 255). 56575 val = 0 ifTrue: 56576 [ val 56577 at: 1 56578 put: 1 ]. "closest non-transparent black" 56579 val 56580 at: 4 56581 put: 255. "opaque alpha" 56582 ^ val ]. 56583 d = 12 ifTrue: 56584 [ "for indexing a color map with 4 bits per color component" 56585 val := (((rgb bitShift: -18) bitAnd: 3840) bitOr: ((rgb bitShift: -12) bitAnd: 240)) bitOr: ((rgb bitShift: -6) bitAnd: 15). 56586 ^ val = 0 56587 ifTrue: [ rgbBlack ] 56588 ifFalse: [ val ] ]. 56589 d = 9 ifTrue: 56590 [ "for indexing a color map with 3 bits per color component" 56591 val := (((rgb bitShift: -21) bitAnd: 448) bitOr: ((rgb bitShift: -14) bitAnd: 56)) bitOr: ((rgb bitShift: -7) bitAnd: 7). 56592 ^ val = 0 56593 ifTrue: [ rgbBlack ] 56594 ifFalse: [ val ] ]. 56595 self error: 'unknown pixel depth: ' , d printString! ! 56596 56597!Color methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 56598pixelWordFor: depth filledWith: pixelValue 56599 "Return to a 32-bit word that concatenates enough copies of the given pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." 56600 | halfword | 56601 depth = 32 ifTrue: [ ^ pixelValue ]. 56602 depth = 16 56603 ifTrue: [ halfword := pixelValue ] 56604 ifFalse: 56605 [ halfword := pixelValue * (#( 56606 65535 56607 21845 56608 #- 56609 4369 56610 #- 56611 #- 56612 #- 56613 257 56614 ) at: depth) "replicates at every bit" "replicates every 2 bits" "replicates every 4 bits" "replicates every 8 bits" ]. 56615 ^ halfword bitOr: (halfword bitShift: 16)! ! 56616 56617!Color methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 56618pixelWordForDepth: depth 56619 "Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." 56620 | pixelValue | 56621 pixelValue := self pixelValueForDepth: depth. 56622 ^ self 56623 pixelWordFor: depth 56624 filledWith: pixelValue! ! 56625 56626!Color methodsFor: 'conversions' stamp: 'ar 1/14/1999 15:28'! 56627scaledPixelValue32 56628 "Return the alpha scaled pixel value for depth 32" 56629 ^self pixelWordForDepth: 32! ! 56630 56631 56632!Color methodsFor: 'copying' stamp: 'tk 8/19/1998 16:12'! 56633veryDeepCopyWith: deepCopier 56634 "Return self. I am immutable in the Morphic world. Do not record me."! ! 56635 56636 56637!Color methodsFor: 'equality' stamp: 'di 1/6/1999 20:26'! 56638= aColor 56639 "Return true if the receiver equals the given color. This method handles TranslucentColors, too." 56640 56641 aColor isColor ifFalse: [^ false]. 56642 ^ aColor privateRGB = rgb and: 56643 [aColor privateAlpha = self privateAlpha] 56644! ! 56645 56646!Color methodsFor: 'equality' stamp: 'di 9/27/2000 08:07'! 56647diff: theOther 56648 "Returns a number between 0.0 and 1.0" 56649 56650 ^ ((self privateRed - theOther privateRed) abs 56651 + (self privateGreen - theOther privateGreen) abs 56652 + (self privateBlue - theOther privateBlue) abs) 56653 / 3.0 / ComponentMax! ! 56654 56655!Color methodsFor: 'equality'! 56656hash 56657 56658 ^ rgb! ! 56659 56660 56661!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'! 56662darkShades: thisMany 56663 "An array of thisMany colors from black to the receiver. Array is of length num. Very useful for displaying color based on a variable in your program. " 56664 "Color showColors: (Color red darkShades: 12)" 56665 56666 ^ self class black mix: self shades: thisMany 56667! ! 56668 56669!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'! 56670lightShades: thisMany 56671 "An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program. " 56672 "Color showColors: (Color red lightShades: 12)" 56673 56674 ^ self class white mix: self shades: thisMany 56675! ! 56676 56677!Color methodsFor: 'groups of shades' stamp: 'lr 7/4/2009 10:42'! 56678mix: color2 shades: thisMany 56679 "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " 56680 "Color showColors: (Color red mix: Color green shades: 12)" 56681 | redInc greenInc blueInc rr gg bb c out | 56682 thisMany = 1 ifTrue: [ ^ Array with: color2 ]. 56683 redInc := (color2 red - self red) / (thisMany - 1). 56684 greenInc := (color2 green - self green) / (thisMany - 1). 56685 blueInc := (color2 blue - self blue) / (thisMany - 1). 56686 rr := self red. 56687 gg := self green. 56688 bb := self blue. 56689 out := (1 to: thisMany) collect: 56690 [ :num | 56691 c := Color 56692 r: rr 56693 g: gg 56694 b: bb. 56695 rr := rr + redInc. 56696 gg := gg + greenInc. 56697 bb := bb + blueInc. 56698 c ]. 56699 out 56700 at: out size 56701 put: color2. "hide roundoff errors" 56702 ^ out! ! 56703 56704!Color methodsFor: 'groups of shades' stamp: 'lr 7/4/2009 10:42'! 56705wheel: thisMany 56706 "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " 56707 | sat bri hue step c | 56708 sat := self saturation. 56709 bri := self brightness. 56710 hue := self hue. 56711 step := 360.0 / (thisMany max: 1). 56712 ^ (1 to: thisMany) collect: 56713 [ :num | 56714 c := Color 56715 h: hue 56716 s: sat 56717 v: bri. "hue is taken mod 360" 56718 hue := hue + step. 56719 c ] 56720 " 56721(Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] 56722"! ! 56723 56724 56725!Color methodsFor: 'html' stamp: 'stephane.ducasse 5/25/2008 18:10'! 56726printHtmlString 56727 "answer a string whose characters are the html representation 56728 of the receiver" 56729 ^ ((self red * 255) asInteger printStringBase: 16 length: 2 padded: true) 56730 , ((self green * 255) asInteger printStringBase: 16 length: 2 padded: true) 56731 , ((self blue * 255) asInteger printStringBase: 16 length: 2 padded: true)! ! 56732 56733 56734!Color methodsFor: 'morphic menu' stamp: 'dgd 10/17/2003 12:10'! 56735addFillStyleMenuItems: aMenu hand: aHand from: aMorph 56736 "Add the items for changing the current fill style of the receiver" 56737 aMenu add: 'change color...' translated target: self selector: #changeColorIn:event: argument: aMorph! ! 56738 56739!Color methodsFor: 'morphic menu' stamp: 'ar 10/5/2000 18:50'! 56740changeColorIn: aMorph event: evt 56741 "Note: This is just a workaround to make sure we don't use the old color inst var" 56742 aMorph changeColorTarget: aMorph selector: #fillStyle: originalColor: self hand: evt hand! ! 56743 56744 56745!Color methodsFor: 'other' stamp: 'sw 2/16/98 03:42'! 56746colorForInsets 56747 ^ self! ! 56748 56749!Color methodsFor: 'other' stamp: 'lr 7/4/2009 10:42'! 56750display 56751 "Show a swatch of this color tracking the cursor until the next mouseClick. " 56752 "Color red display" 56753 | f | 56754 f := Form 56755 extent: 40 @ 20 56756 depth: Display depth. 56757 f fillColor: self. 56758 Cursor blank showWhile: 56759 [ f 56760 follow: [ Sensor cursorPoint ] 56761 while: [ Sensor noButtonPressed ] ]! ! 56762 56763!Color methodsFor: 'other' stamp: 'jm 12/4/97 10:24'! 56764name 56765 "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." 56766 56767 ColorNames do: 56768 [:name | (Color perform: name) = self ifTrue: [^ name]]. 56769 ^ nil 56770! ! 56771 56772!Color methodsFor: 'other' stamp: 'ar 8/16/2001 12:47'! 56773raisedColor 56774 ^ self! ! 56775 56776!Color methodsFor: 'other' stamp: 'jm 12/4/97 10:27'! 56777rgbTriplet 56778 "Color fromUser rgbTriplet" 56779 56780 ^ Array 56781 with: (self red roundTo: 0.01) 56782 with: (self green roundTo: 0.01) 56783 with: (self blue roundTo: 0.01) 56784! ! 56785 56786 56787!Color methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:14'! 56788byteEncode: aStream 56789 56790 aStream 56791 print: '('; 56792 print: self class name; 56793 print: ' r: '; 56794 write: (self red roundTo: 0.001); 56795 print: ' g: '; 56796 write: (self green roundTo: 0.001); 56797 print: ' b: '; 56798 write: (self blue roundTo: 0.001) ; 56799 print: ')'. 56800! ! 56801 56802!Color methodsFor: 'printing' stamp: 'lr 7/4/2009 10:42'! 56803printOn: aStream 56804 | name | 56805 (name := self name) ifNotNil: 56806 [ ^ aStream 56807 nextPutAll: 'Color '; 56808 nextPutAll: name ]. 56809 self storeOn: aStream! ! 56810 56811!Color methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 00:56'! 56812shortPrintString 56813 "Return a short (but less precise) print string for use where space is tight." 56814 | s | 56815 s := String new writeStream. 56816 s 56817 nextPutAll: '(' , self class name; 56818 nextPutAll: ' r: '; 56819 nextPutAll: (self red roundTo: 0.01) printString; 56820 nextPutAll: ' g: '; 56821 nextPutAll: (self green roundTo: 0.01) printString; 56822 nextPutAll: ' b: '; 56823 nextPutAll: (self blue roundTo: 0.01) printString; 56824 nextPutAll: ')'. 56825 ^ s contents! ! 56826 56827!Color methodsFor: 'printing' stamp: 'mir 7/21/1999 11:41'! 56828storeArrayOn: aStream 56829 56830 aStream nextPutAll: '#('. 56831 self storeArrayValuesOn: aStream. 56832 aStream nextPutAll: ') ' 56833! ! 56834 56835!Color methodsFor: 'printing' stamp: 'mir 7/21/1999 11:41'! 56836storeArrayValuesOn: aStream 56837 56838 (self red roundTo: 0.001) storeOn: aStream. 56839 aStream space. 56840 (self green roundTo: 0.001) storeOn: aStream. 56841 aStream space. 56842 (self blue roundTo: 0.001) storeOn: aStream. 56843 56844! ! 56845 56846!Color methodsFor: 'printing' stamp: 'di 9/27/2000 13:34'! 56847storeOn: aStream 56848 56849 aStream 56850 nextPutAll: '(' , self class name; 56851 nextPutAll: ' r: '; print: (self red roundTo: 0.001); 56852 nextPutAll: ' g: '; print: (self green roundTo: 0.001); 56853 nextPutAll: ' b: '; print: (self blue roundTo: 0.001); 56854 nextPutAll: ')'. 56855! ! 56856 56857 56858!Color methodsFor: 'queries' stamp: 'sw 9/27/2001 17:26'! 56859basicType 56860 "Answer a symbol representing the inherent type of the receiver" 56861 56862 ^ #Color! ! 56863 56864!Color methodsFor: 'queries' stamp: 'ar 1/14/1999 15:27'! 56865isBitmapFill 56866 ^false! ! 56867 56868!Color methodsFor: 'queries' stamp: 'ar 11/12/1998 19:43'! 56869isBlack 56870 "Return true if the receiver represents black" 56871 ^rgb = 0! ! 56872 56873!Color methodsFor: 'queries'! 56874isColor 56875 56876 ^ true 56877! ! 56878 56879!Color methodsFor: 'queries' stamp: 'ar 6/18/1999 06:58'! 56880isGradientFill 56881 ^false! ! 56882 56883!Color methodsFor: 'queries' stamp: 'ar 11/12/1998 19:44'! 56884isGray 56885 "Return true if the receiver represents a shade of gray" 56886 ^(self privateRed = self privateGreen) and:[self privateRed = self privateBlue]! ! 56887 56888!Color methodsFor: 'queries' stamp: 'ar 4/20/2001 04:33'! 56889isOpaque 56890 ^true! ! 56891 56892!Color methodsFor: 'queries' stamp: 'ar 6/18/1999 07:57'! 56893isOrientedFill 56894 "Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)" 56895 ^false! ! 56896 56897!Color methodsFor: 'queries' stamp: 'ar 11/7/1998 20:20'! 56898isSolidFill 56899 ^true! ! 56900 56901!Color methodsFor: 'queries' stamp: 'di 12/30/1998 14:33'! 56902isTranslucent 56903 56904 ^ false 56905! ! 56906 56907!Color methodsFor: 'queries' stamp: 'di 1/3/1999 12:23'! 56908isTranslucentColor 56909 "This means: self isTranslucent, but isTransparent not" 56910 ^ false! ! 56911 56912!Color methodsFor: 'queries'! 56913isTransparent 56914 56915 ^ false 56916! ! 56917 56918 56919!Color methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:46'! 56920isSelfEvaluating 56921 ^ self class == Color! ! 56922 56923 56924!Color methodsFor: 'transformations' stamp: 'fbs 2/3/2005 13:09'! 56925* aNumberOrArray 56926 "Answer this color with its RGB multiplied by the given number, or 56927 multiply this color's RGB values by the corresponding entries in the 56928 given array." 56929 "(Color brown * 2) display" 56930 "(Color brown * #(1 0 1)) display" 56931 | multipliers | 56932 multipliers := aNumberOrArray isCollection 56933 ifTrue: [aNumberOrArray] 56934 ifFalse: 56935 [Array 56936 with: aNumberOrArray 56937 with: aNumberOrArray 56938 with: aNumberOrArray]. 56939 56940 ^ Color basicNew 56941 setPrivateRed: (self privateRed * multipliers first) asInteger 56942 green: (self privateGreen * multipliers second) asInteger 56943 blue: (self privateBlue * multipliers third) asInteger.! ! 56944 56945!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'! 56946+ aColor 56947 "Answer this color mixed with the given color in an additive color space. " 56948 "(Color blue + Color green) display" 56949 56950 ^ Color basicNew 56951 setPrivateRed: self privateRed + aColor privateRed 56952 green: self privateGreen + aColor privateGreen 56953 blue: self privateBlue + aColor privateBlue 56954! ! 56955 56956!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'! 56957- aColor 56958 "Answer aColor is subtracted from the given color in an additive color space. " 56959 "(Color white - Color red) display" 56960 56961 ^ Color basicNew 56962 setPrivateRed: self privateRed - aColor privateRed 56963 green: self privateGreen - aColor privateGreen 56964 blue: self privateBlue - aColor privateBlue 56965! ! 56966 56967!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:07'! 56968/ aNumber 56969 "Answer this color with its RGB divided by the given number. " 56970 "(Color red / 2) display" 56971 56972 ^ Color basicNew 56973 setPrivateRed: (self privateRed / aNumber) asInteger 56974 green: (self privateGreen / aNumber) asInteger 56975 blue: (self privateBlue / aNumber) asInteger 56976! ! 56977 56978!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:50'! 56979adjustBrightness: brightness 56980 "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" 56981 56982 ^ Color 56983 h: self hue 56984 s: self saturation 56985 v: (self brightness + brightness min: 1.0 max: 0.005) 56986 alpha: self alpha! ! 56987 56988!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:51'! 56989adjustSaturation: saturation brightness: brightness 56990 "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" 56991 56992 ^ Color 56993 h: self hue 56994 s: (self saturation + saturation min: 1.0 max: 0.005) 56995 v: (self brightness + brightness min: 1.0 max: 0.005) 56996 alpha: self alpha! ! 56997 56998!Color methodsFor: 'transformations' stamp: 'sma 6/25/2000 15:36'! 56999alpha: alphaValue 57000 "Answer a new Color with the given amount of opacity ('alpha')." 57001 57002 alphaValue = 1.0 57003 ifFalse: [^ TranslucentColor basicNew setRgb: rgb alpha: alphaValue]! ! 57004 57005!Color methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! 57006alphaMixed: proportion with: aColor 57007 "Answer this color mixed with the given color. The proportion, a number 57008 between 0.0 and 1.0, determines what what fraction of the receiver to 57009 use in the mix. For example, 0.9 would yield a color close to the 57010 receiver. This method uses RGB interpolation; HSV interpolation can lead 57011 to surprises. Mixes the alphas (for transparency) also." 57012 | frac1 frac2 | 57013 frac1 := proportion asFloat 57014 min: 1.0 57015 max: 0.0. 57016 frac2 := 1.0 - frac1. 57017 ^ Color 57018 r: self red * frac1 + (aColor red * frac2) 57019 g: self green * frac1 + (aColor green * frac2) 57020 b: self blue * frac1 + (aColor blue * frac2) 57021 alpha: self alpha * frac1 + (aColor alpha * frac2)! ! 57022 57023!Color methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! 57024atLeastAsLuminentAs: aFloat 57025 | revisedColor | 57026 revisedColor := self. 57027 [ revisedColor luminance < aFloat ] whileTrue: [ revisedColor := revisedColor slightlyLighter ]. 57028 ^ revisedColor! ! 57029 57030!Color methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! 57031atMostAsLuminentAs: aFloat 57032 | revisedColor | 57033 revisedColor := self. 57034 [ revisedColor luminance > aFloat ] whileTrue: [ revisedColor := revisedColor slightlyDarker ]. 57035 ^ revisedColor! ! 57036 57037!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! 57038blacker 57039 57040 ^ self alphaMixed: 0.8333 with: Color black 57041! ! 57042 57043!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54'! 57044dansDarker 57045 "Return a darker shade of the same color. 57046 An attempt to do better than the current darker method. 57047 (now obsolete, since darker has been changed to do this. -dew)" 57048 ^ Color h: self hue s: self saturation 57049 v: (self brightness - 0.16 max: 0.0)! ! 57050 57051!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:40'! 57052darker 57053 "Answer a darker shade of this color." 57054 57055 ^ self adjustBrightness: -0.08! ! 57056 57057!Color methodsFor: 'transformations' stamp: 'dew 3/8/2002 00:13'! 57058duller 57059 57060 ^ self adjustSaturation: -0.03 brightness: -0.2! ! 57061 57062!Color methodsFor: 'transformations' stamp: 'dew 1/23/2002 20:19'! 57063lighter 57064 "Answer a lighter shade of this color." 57065 57066 ^ self adjustSaturation: -0.03 brightness: 0.08! ! 57067 57068!Color methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! 57069mixed: proportion with: aColor 57070 "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: 57071 aColor alphaMixed: proportion with: anotherColor 57072 " 57073 | frac1 frac2 | 57074 frac1 := proportion asFloat 57075 min: 1.0 57076 max: 0.0. 57077 frac2 := 1.0 - frac1. 57078 ^ Color 57079 r: self red * frac1 + (aColor red * frac2) 57080 g: self green * frac1 + (aColor green * frac2) 57081 b: self blue * frac1 + (aColor blue * frac2)! ! 57082 57083!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29'! 57084muchDarker 57085 57086 ^ self alphaMixed: 0.5 with: Color black 57087! ! 57088 57089!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'! 57090muchLighter 57091 57092 ^ self alphaMixed: 0.233 with: Color white 57093! ! 57094 57095!Color methodsFor: 'transformations' stamp: 'ar 6/19/1999 00:36'! 57096negated 57097 "Return an RGB inverted color" 57098 ^Color 57099 r: 1.0 - self red 57100 g: 1.0 - self green 57101 b: 1.0 - self blue! ! 57102 57103!Color methodsFor: 'transformations' stamp: 'di 9/27/2000 08:14'! 57104orColorUnlike: theOther 57105 "If this color is a lot like theOther, then return its complement, otherwide, return self" 57106 57107 (self diff: theOther) < 0.3 57108 ifTrue: [^ theOther negated] 57109 ifFalse: [^ self]! ! 57110 57111!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:42'! 57112paler 57113 "Answer a paler shade of this color." 57114 57115 ^ self adjustSaturation: -0.09 brightness: 0.09 57116! ! 57117 57118!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! 57119slightlyDarker 57120 57121 ^ self adjustBrightness: -0.03 57122! ! 57123 57124!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! 57125slightlyLighter 57126 57127 ^ self adjustSaturation: -0.01 brightness: 0.03! ! 57128 57129!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25'! 57130slightlyWhiter 57131 57132 ^ self alphaMixed: 0.85 with: Color white 57133! ! 57134 57135!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:44'! 57136twiceDarker 57137 "Answer a significantly darker shade of this color." 57138 57139 ^ self adjustBrightness: -0.15! ! 57140 57141!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:45'! 57142twiceLighter 57143 "Answer a significantly lighter shade of this color." 57144 57145 ^ self adjustSaturation: -0.06 brightness: 0.15! ! 57146 57147!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'! 57148veryMuchLighter 57149 57150 ^ self alphaMixed: 0.1165 with: Color white 57151! ! 57152 57153!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! 57154whiter 57155 57156 ^ self alphaMixed: 0.8333 with: Color white 57157! ! 57158 57159 57160!Color methodsFor: 'private'! 57161attemptToMutateError 57162 "A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it." 57163 57164 self error: 'Color objects are immutable once created' 57165! ! 57166 57167!Color methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 57168flushCache 57169 "Flush my cached bit pattern." 57170 cachedDepth := nil. 57171 cachedBitPattern := nil! ! 57172 57173!Color methodsFor: 'private'! 57174privateAlpha 57175 "Private!! Return the raw alpha value for opaque. Used only for equality testing." 57176 57177 ^ 255! ! 57178 57179!Color methodsFor: 'private'! 57180privateBlue 57181 "Private!! Return the internal representation of my blue component." 57182 57183 ^ rgb bitAnd: ComponentMask! ! 57184 57185!Color methodsFor: 'private'! 57186privateGreen 57187 "Private!! Return the internal representation of my green component. 57188 Replaced >> by bitShift: 0 -. SqR!! 2/25/1999 23:08" 57189 57190 ^ (rgb bitShift: 0 - GreenShift) bitAnd: ComponentMask! ! 57191 57192!Color methodsFor: 'private'! 57193privateRGB 57194 "Private!! Return the internal representation of my RGB components." 57195 57196 ^ rgb 57197! ! 57198 57199!Color methodsFor: 'private'! 57200privateRed 57201 "Private!! Return the internal representation of my red component." 57202 57203 ^ (rgb bitShift: 0 - RedShift) bitAnd: ComponentMask! ! 57204 57205!Color methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 57206setHue: hue saturation: saturation brightness: brightness 57207 "Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details." 57208 | s v hf i f p q t | 57209 s := (saturation asFloat max: 0.0) min: 1.0. 57210 v := (brightness asFloat max: 0.0) min: 1.0. 57211 57212 "zero saturation yields gray with the given brightness" 57213 s = 0.0 ifTrue: 57214 [ ^ self 57215 setRed: v 57216 green: v 57217 blue: v ]. 57218 hf := hue asFloat. 57219 (hf < 0.0 or: [ hf >= 360.0 ]) ifTrue: [ hf := hf - ((hf quo: 360.0) asFloat * 360.0) ]. 57220 hf := hf / 60.0. 57221 i := hf asInteger. "integer part of hue" 57222 f := hf fractionPart. "fractional part of hue" 57223 p := (1.0 - s) * v. 57224 q := (1.0 - (s * f)) * v. 57225 t := (1.0 - (s * (1.0 - f))) * v. 57226 0 = i ifTrue: 57227 [ ^ self 57228 setRed: v 57229 green: t 57230 blue: p ]. 57231 1 = i ifTrue: 57232 [ ^ self 57233 setRed: q 57234 green: v 57235 blue: p ]. 57236 2 = i ifTrue: 57237 [ ^ self 57238 setRed: p 57239 green: v 57240 blue: t ]. 57241 3 = i ifTrue: 57242 [ ^ self 57243 setRed: p 57244 green: q 57245 blue: v ]. 57246 4 = i ifTrue: 57247 [ ^ self 57248 setRed: t 57249 green: p 57250 blue: v ]. 57251 5 = i ifTrue: 57252 [ ^ self 57253 setRed: v 57254 green: p 57255 blue: q ]. 57256 self error: 'implementation error'! ! 57257 57258!Color methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 57259setPrivateRed: r green: g blue: b 57260 "Initialize this color's r, g, and b components to the given values in the range [0..ComponentMax]. Encoded in a single variable as 3 integers in [0..1023]." 57261 rgb == nil ifFalse: [ self attemptToMutateError ]. 57262 rgb := ((r 57263 min: ComponentMask 57264 max: 0) bitShift: RedShift) + ((g 57265 min: ComponentMask 57266 max: 0) bitShift: GreenShift) + (b 57267 min: ComponentMask 57268 max: 0). 57269 cachedDepth := nil. 57270 cachedBitPattern := nil! ! 57271 57272!Color methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 57273setRGB: rgb0 57274 rgb == nil ifFalse: [ self attemptToMutateError ]. 57275 rgb := rgb0! ! 57276 57277!Color methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 57278setRed: r green: g blue: b 57279 "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0]. Encoded in a single variable as 3 integers in [0..1023]." 57280 rgb == nil ifFalse: [ self attemptToMutateError ]. 57281 rgb := (((r * ComponentMax) rounded bitAnd: ComponentMask) bitShift: RedShift) + (((g * ComponentMax) rounded bitAnd: ComponentMask) bitShift: GreenShift) + ((b * ComponentMax) rounded bitAnd: ComponentMask). 57282 cachedDepth := nil. 57283 cachedBitPattern := nil! ! 57284 57285!Color methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 57286setRed: r green: g blue: b range: range 57287 "Initialize this color's r, g, and b components to the given values in the range [0..r]." 57288 rgb == nil ifFalse: [ self attemptToMutateError ]. 57289 rgb := ((r * ComponentMask // range bitAnd: ComponentMask) bitShift: RedShift) + ((g * ComponentMask // range bitAnd: ComponentMask) bitShift: GreenShift) + (b * ComponentMask // range bitAnd: ComponentMask). 57290 cachedDepth := nil. 57291 cachedBitPattern := nil! ! 57292 57293"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 57294 57295Color class 57296 instanceVariableNames: ''! 57297 57298!Color class methodsFor: 'class initialization' stamp: 'lr 7/4/2009 10:42'! 57299initializeNames 57300 "Name some colors." 57301 "Color initializeNames" 57302 ColorNames := OrderedCollection new. 57303 self 57304 named: #black 57305 put: (Color 57306 r: 0 57307 g: 0 57308 b: 0). 57309 self 57310 named: #veryVeryDarkGray 57311 put: (Color 57312 r: 0.125 57313 g: 0.125 57314 b: 0.125). 57315 self 57316 named: #veryDarkGray 57317 put: (Color 57318 r: 0.25 57319 g: 0.25 57320 b: 0.25). 57321 self 57322 named: #darkGray 57323 put: (Color 57324 r: 0.375 57325 g: 0.375 57326 b: 0.375). 57327 self 57328 named: #gray 57329 put: (Color 57330 r: 0.5 57331 g: 0.5 57332 b: 0.5). 57333 self 57334 named: #lightGray 57335 put: (Color 57336 r: 0.625 57337 g: 0.625 57338 b: 0.625). 57339 self 57340 named: #veryLightGray 57341 put: (Color 57342 r: 0.75 57343 g: 0.75 57344 b: 0.75). 57345 self 57346 named: #veryVeryLightGray 57347 put: (Color 57348 r: 0.875 57349 g: 0.875 57350 b: 0.875). 57351 self 57352 named: #white 57353 put: (Color 57354 r: 1.0 57355 g: 1.0 57356 b: 1.0). 57357 self 57358 named: #red 57359 put: (Color 57360 r: 1.0 57361 g: 0 57362 b: 0). 57363 self 57364 named: #yellow 57365 put: (Color 57366 r: 1.0 57367 g: 1.0 57368 b: 0). 57369 self 57370 named: #green 57371 put: (Color 57372 r: 0 57373 g: 1.0 57374 b: 0). 57375 self 57376 named: #cyan 57377 put: (Color 57378 r: 0 57379 g: 1.0 57380 b: 1.0). 57381 self 57382 named: #blue 57383 put: (Color 57384 r: 0 57385 g: 0 57386 b: 1.0). 57387 self 57388 named: #magenta 57389 put: (Color 57390 r: 1.0 57391 g: 0 57392 b: 1.0). 57393 self 57394 named: #brown 57395 put: (Color 57396 r: 0.6 57397 g: 0.2 57398 b: 0). 57399 self 57400 named: #orange 57401 put: (Color 57402 r: 1.0 57403 g: 0.6 57404 b: 0). 57405 self 57406 named: #lightRed 57407 put: (Color 57408 r: 1.0 57409 g: 0.8 57410 b: 0.8). 57411 self 57412 named: #lightYellow 57413 put: (Color 57414 r: 1.0 57415 g: 1.0 57416 b: 0.8). 57417 self 57418 named: #lightGreen 57419 put: (Color 57420 r: 0.8 57421 g: 1.0 57422 b: 0.6). 57423 self 57424 named: #lightCyan 57425 put: (Color 57426 r: 0.4 57427 g: 1.0 57428 b: 1.0). 57429 self 57430 named: #lightBlue 57431 put: (Color 57432 r: 0.8 57433 g: 1.0 57434 b: 1.0). 57435 self 57436 named: #lightMagenta 57437 put: (Color 57438 r: 1.0 57439 g: 0.8 57440 b: 1.0). 57441 self 57442 named: #lightBrown 57443 put: (Color 57444 r: 1.0 57445 g: 0.6 57446 b: 0.2). 57447 self 57448 named: #lightOrange 57449 put: (Color 57450 r: 1.0 57451 g: 0.8 57452 b: 0.4). 57453 self 57454 named: #transparent 57455 put: (TranslucentColor new alpha: 0.0)! ! 57456 57457 57458!Color class methodsFor: 'color from user' stamp: 'lr 7/4/2009 10:42'! 57459colorTest: depth extent: chartExtent colorMapper: colorMapper 57460 "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." 57461 "Note: It is slow to build this palette, so it should be cached for quick access." 57462 "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" 57463 "(Color colorTest: 32 extent: 570@180 colorMapper: 57464 [:c | Color 57465 r: (c red * 7) asInteger / 7 57466 g: (c green * 7) asInteger / 7 57467 b: (c blue * 3) asInteger / 3]) display" 57468 "(Color colorTest: 32 extent: 570@180 colorMapper: 57469 [:c | Color 57470 r: (c red * 5) asInteger / 5 57471 g: (c green * 5) asInteger / 5 57472 b: (c blue * 5) asInteger / 5]) display" 57473 "(Color colorTest: 32 extent: 570@180 colorMapper: 57474 [:c | Color 57475 r: (c red * 15) asInteger / 15 57476 g: (c green * 15) asInteger / 15 57477 b: (c blue * 15) asInteger / 15]) display" 57478 "(Color colorTest: 32 extent: 570@180 colorMapper: 57479 [:c | Color 57480 r: (c red * 31) asInteger / 31 57481 g: (c green * 31) asInteger / 31 57482 b: (c blue * 31) asInteger / 31]) display" 57483 | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | 57484 palette := Form 57485 extent: chartExtent 57486 depth: depth. 57487 transCaption := Form 57488 extent: 34 @ 9 57489 depth: 1 57490 fromArray: #( 57491 0 57492 0 57493 256 57494 0 57495 256 57496 0 57497 3808663859 57498 2147483648 57499 2491688266 57500 2147483648 57501 2491688266 57502 0 57503 2491688266 57504 0 57505 2466486578 57506 0 57507 0 57508 0 57509 ) 57510 offset: 0 @ 0. "(DisplayText text: 'no color' asText textStyle: (TextConstants at: #ComicPlain)) form storeString" 57511 transHt := transCaption height. 57512 palette fillWhite: (0 @ 0 extent: palette width @ transHt). 57513 palette fillBlack: (0 @ transHt extent: palette width @ 1). 57514 transCaption 57515 displayOn: palette 57516 at: palette boundingBox topCenter - ((transCaption width // 2) @ 0). 57517 grayWidth := 10. 57518 startHue := 338.0. 57519 vSteps := (palette height - transHt) // 2. 57520 hSteps := palette width - grayWidth. 57521 x := 0. 57522 startHue 57523 to: startHue + 360.0 57524 by: 360.0 / hSteps 57525 do: 57526 [ :h | 57527 basicHue := Color 57528 h: h asFloat 57529 s: 1.0 57530 v: 1.0. 57531 y := transHt + 1. 57532 0 57533 to: vSteps 57534 do: 57535 [ :n | 57536 c := basicHue 57537 mixed: n asFloat / vSteps asFloat 57538 with: Color white. 57539 c := colorMapper value: c. 57540 palette 57541 fill: (x @ y extent: 1 @ 1) 57542 fillColor: c. 57543 y := y + 1 ]. 57544 1 57545 to: vSteps 57546 do: 57547 [ :n | 57548 c := Color black 57549 mixed: n asFloat / vSteps asFloat 57550 with: basicHue. 57551 c := colorMapper value: c. 57552 palette 57553 fill: (x @ y extent: 1 @ 1) 57554 fillColor: c. 57555 y := y + 1 ]. 57556 x := x + 1 ]. 57557 y := transHt + 1. 57558 1 57559 to: vSteps * 2 57560 do: 57561 [ :n | 57562 c := Color black 57563 mixed: n asFloat / (vSteps * 2) asFloat 57564 with: Color white. 57565 c := colorMapper value: c. 57566 palette 57567 fill: (x @ y extent: 10 @ 1) 57568 fillColor: c. 57569 y := y + 1 ]. 57570 ^ palette! ! 57571 57572!Color class methodsFor: 'color from user' stamp: 'lr 7/4/2009 10:42'! 57573fromUser 57574 "Displays a color palette of colors, waits for a mouse click, and returns the selected color. Any pixel on the Display can be chosen, not just those in the color palette." 57575 "Note: Since the color chart is cached, you may need to do 'ColorChart _ nil' after changing the oldColorPaletteForDepth:extent: method." 57576 "Color fromUser" 57577 | d startPt save tr oldColor c here s | 57578 d := Display depth. 57579 (ColorChart == nil or: [ ColorChart depth ~= Display depth ]) ifTrue: 57580 [ ColorChart := self 57581 oldColorPaletteForDepth: d 57582 extent: (2 * 144) @ 80 ]. 57583 Sensor cursorPoint y < Display center y 57584 ifTrue: [ startPt := 0 @ (Display boundingBox bottom - ColorChart height) ] 57585 ifFalse: [ startPt := 0 @ 0 ]. 57586 save := Form fromDisplay: (startPt extent: ColorChart extent). 57587 ColorChart displayAt: startPt. 57588 tr := ColorChart extent - (50 @ 19) corner: ColorChart extent. 57589 tr := tr translateBy: startPt. 57590 oldColor := nil. 57591 [ Sensor anyButtonPressed ] whileFalse: 57592 [ c := Display colorAt: (here := Sensor cursorPoint). 57593 (tr containsPoint: here) 57594 ifFalse: 57595 [ Display 57596 fill: (0 @ 61 + startPt extent: 20 @ 19) 57597 fillColor: c ] 57598 ifTrue: 57599 [ c := Color transparent. 57600 Display 57601 fill: (0 @ 61 + startPt extent: 20 @ 19) 57602 fillColor: Color white ]. 57603 c = oldColor ifFalse: 57604 [ Display fillWhite: (20 @ 61 + startPt extent: 135 @ 19). 57605 c isTransparent 57606 ifTrue: [ s := 'transparent' ] 57607 ifFalse: 57608 [ s := c shortPrintString. 57609 s := s 57610 copyFrom: 7 57611 to: s size - 1 ]. 57612 s displayAt: 20 @ 61 + startPt. 57613 oldColor := c ] ]. 57614 save displayAt: startPt. 57615 Sensor waitNoButton. 57616 ^ c! ! 57617 57618!Color class methodsFor: 'color from user' stamp: 'lr 7/4/2009 10:42'! 57619oldColorPaletteForDepth: depth extent: paletteExtent 57620 "Returns a form of the given size showing a color palette for the given depth." 57621 "(Color oldColorPaletteForDepth: Display depth extent: 720@100) display" 57622 | c p f nSteps rect w h q | 57623 f := Form 57624 extent: paletteExtent 57625 depth: depth. 57626 f 57627 fill: f boundingBox 57628 fillColor: Color white. 57629 nSteps := depth > 8 57630 ifTrue: [ 12 ] 57631 ifFalse: [ 6 ]. 57632 w := paletteExtent x // (nSteps * nSteps). 57633 h := (paletteExtent y - 20) // nSteps. 57634 0 57635 to: nSteps - 1 57636 do: 57637 [ :r | 57638 0 57639 to: nSteps - 1 57640 do: 57641 [ :g | 57642 0 57643 to: nSteps - 1 57644 do: 57645 [ :b | 57646 c := Color 57647 r: r 57648 g: g 57649 b: b 57650 range: nSteps - 1. 57651 rect := (r * nSteps * w + (b * w)) @ (g * h) extent: w @ (h + 1). 57652 f 57653 fill: rect 57654 fillColor: c ] ] ]. 57655 q := Quadrangle 57656 origin: paletteExtent - (50 @ 19) 57657 corner: paletteExtent. 57658 q displayOn: f. 57659 'Trans.' 57660 displayOn: f 57661 at: q origin + (9 @ 1). 57662 w := (paletteExtent x - q width - 130) // 64 max: 1. 57663 p := (paletteExtent x - q width - (64 * w) - 1) @ (paletteExtent y - 19). 57664 0 57665 to: 63 57666 do: 57667 [ :v | 57668 c := Color 57669 r: v 57670 g: v 57671 b: v 57672 range: 63. 57673 f 57674 fill: ((v * w) @ 0 + p extent: (w + 1) @ 19) 57675 fillColor: c ]. 57676 ^ f! ! 57677 57678 57679!Color class methodsFor: 'colormaps' stamp: 'lr 7/4/2009 10:42'! 57680cachedColormapFrom: sourceDepth to: destDepth 57681 "Return a cached colormap for mapping between the given depths. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." 57682 "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" 57683 "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." 57684 | srcIndex map | 57685 CachedColormaps class == Array ifFalse: [ CachedColormaps := (1 to: 9) collect: [ :i | Array new: 32 ] ]. 57686 srcIndex := sourceDepth. 57687 sourceDepth > 8 ifTrue: [ srcIndex := 9 ]. 57688 (map := (CachedColormaps at: srcIndex) at: destDepth) ~~ nil ifTrue: [ ^ map ]. 57689 map := self 57690 computeColormapFrom: sourceDepth 57691 to: destDepth. 57692 (CachedColormaps at: srcIndex) 57693 at: destDepth 57694 put: map. 57695 ^ map! ! 57696 57697!Color class methodsFor: 'colormaps'! 57698colorMapIfNeededFrom: sourceDepth to: destDepth 57699 "Return a colormap for mapping between the given depths, or nil if no colormap is needed." 57700 "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" 57701 57702 sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" 57703 57704 (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ 57705 "mapping is done in BitBlt by zero-filling or truncating each color component" 57706 ^ nil]. 57707 57708 ^ Color cachedColormapFrom: sourceDepth to: destDepth 57709! ! 57710 57711!Color class methodsFor: 'colormaps' stamp: 'jmv 8/2/2009 21:32'! 57712computeColorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix 57713 57714 sourceDepth < 16 ifTrue: [ 57715 "source is 1-, 2-, 4-, or 8-bit indexed color. 57716 Assumed not to include subpixelAA" 57717 ^ self computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth 57718 ] ifFalse: [ 57719 "source is 16-bit or 32-bit RGB. 57720 Might include subpixelAA" 57721 ^ self computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix 57722 ]! ! 57723 57724!Color class methodsFor: 'colormaps' stamp: 'lr 7/4/2009 10:42'! 57725computeColormapFrom: sourceDepth to: destDepth 57726 "Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead." 57727 | map bitsPerColor | 57728 sourceDepth < 16 57729 ifTrue: 57730 [ "source is 1-, 2-, 4-, or 8-bit indexed color" 57731 map := (IndexedColors 57732 copyFrom: 1 57733 to: (1 bitShift: sourceDepth)) collect: [ :c | c pixelValueForDepth: destDepth ]. 57734 map := map as: Bitmap ] 57735 ifFalse: 57736 [ "source is 16-bit or 32-bit RGB" 57737 destDepth > 8 57738 ifTrue: [ bitsPerColor := 5 "retain maximum color resolution" ] 57739 ifFalse: [ bitsPerColor := 4 ]. 57740 map := self 57741 computeRGBColormapFor: destDepth 57742 bitsPerColor: bitsPerColor ]. 57743 57744 "Note: zero is transparent except when source depth is one-bit deep" 57745 sourceDepth > 1 ifTrue: 57746 [ map 57747 at: 1 57748 put: 0 ]. 57749 ^ map! ! 57750 57751!Color class methodsFor: 'colormaps' stamp: 'StephaneDucasse 10/17/2009 17:15'! 57752computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth 57753 | map f c | 57754 map := (IndexedColors 57755 copyFrom: 1 57756 to: (1 bitShift: sourceDepth)) collect: 57757 [ :cc | 57758 f := 1.0 - ((cc red + cc green + cc blue) / 3.0). 57759 c := targetColor notNil 57760 ifTrue: 57761 [ destDepth = 32 57762 ifTrue: [ targetColor * f alpha: f ] 57763 ifFalse: 57764 [ targetColor 57765 alphaMixed: f * 1.5 57766 with: Color white ] ] 57767 ifFalse: [ cc ]. 57768 destDepth = 32 57769 ifTrue: [ c pixelValueForDepth: destDepth ] 57770 ifFalse: 57771 [ f = 0.0 57772 ifTrue: [ 0 ] 57773 ifFalse: [ c pixelValueForDepth: destDepth ] ] ]. 57774 map := map as: Bitmap. 57775 ^ map! ! 57776 57777!Color class methodsFor: 'colormaps' stamp: 'StephaneDucasse 10/17/2009 17:15'! 57778computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix 57779 "Builds a colormap intended to convert from subpixelAA black values to targetColor values. 57780 keepSubPix 57781 ifTrue: [ Answer colors that also include subpixelAA ] 57782 ifFalse: [ 57783 Take fullpixel luminance level. Apply it to targetColor. 57784 I.e. answer colors with NO subpixelAA ]" 57785 | mask map c bitsPerColor r g b f v | 57786 destDepth > 8 57787 ifTrue: [ bitsPerColor := 5 "retain maximum color resolution" ] 57788 ifFalse: [ bitsPerColor := 4 ]. 57789 "Usually a bit less is enough, but make it configurable" 57790 bitsPerColor := bitsPerColor min: Preferences aaFontsColormapDepth. 57791 mask := (1 bitShift: bitsPerColor) - 1. 57792 map := Bitmap new: (1 bitShift: 3 * bitsPerColor). 57793 0 57794 to: map size - 1 57795 do: 57796 [ :i | 57797 r := (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask. 57798 g := (i bitShift: 0 - bitsPerColor) bitAnd: mask. 57799 b := (i bitShift: 0) bitAnd: mask. 57800 f := 1.0 - ((r + g + b) / 3.0 / mask). 57801 c := targetColor notNil 57802 ifTrue: 57803 [ (keepSubPix and: [ destDepth > 8 ]) 57804 ifTrue: 57805 [ Color 57806 r: (1.0 - (r / mask)) * targetColor red 57807 g: (1.0 - (g / mask)) * targetColor green 57808 b: (1.0 - (b / mask)) * targetColor blue 57809 alpha: f * targetColor alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] 57810 ifFalse: 57811 [ destDepth = 32 57812 ifTrue: [ targetColor * f alpha: f * targetColor alpha ] 57813 ifFalse: 57814 [ targetColor 57815 alphaMixed: f * 1.5 57816 with: Color white ] ] ] 57817 ifFalse: 57818 [ Color 57819 r: r 57820 g: g 57821 b: b 57822 range: mask ]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" 57823 v := destDepth = 32 57824 ifTrue: [ c pixelValueForDepth: destDepth ] 57825 ifFalse: 57826 [ f < 0.1 57827 ifTrue: [ 0 ] 57828 ifFalse: [ c pixelValueForDepth: destDepth ] ]. 57829 map 57830 at: i + 1 57831 put: v ]. 57832 ^ map! ! 57833 57834!Color class methodsFor: 'colormaps' stamp: 'lr 7/4/2009 10:42'! 57835computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor 57836 "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." 57837 | mask map c | 57838 (#(3 4 5 ) includes: bitsPerColor) ifFalse: 57839 [ self error: 'BitBlt only supports 3, 4, or 5 bits per color component' ]. 57840 mask := (1 bitShift: bitsPerColor) - 1. 57841 map := Bitmap new: (1 bitShift: 3 * bitsPerColor). 57842 0 57843 to: map size - 1 57844 do: 57845 [ :i | 57846 c := Color 57847 r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) 57848 g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) 57849 b: ((i bitShift: 0) bitAnd: mask) 57850 range: mask. 57851 map 57852 at: i + 1 57853 put: (c pixelValueForDepth: destDepth) ]. 57854 map 57855 at: 1 57856 put: (Color transparent pixelWordForDepth: destDepth). "zero always transparent" 57857 ^ map! ! 57858 57859 57860!Color class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 57861colorRampForDepth: depth extent: aPoint 57862 "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths." 57863 "(Color colorRampForDepth: Display depth extent: 256@80) display" 57864 "(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint" 57865 | f dx dy r | 57866 f := Form 57867 extent: aPoint 57868 depth: depth. 57869 dx := aPoint x // 256. 57870 dy := aPoint y // 4. 57871 0 57872 to: 255 57873 do: 57874 [ :i | 57875 r := (dx * i) @ 0 extent: dx @ dy. 57876 f 57877 fill: r 57878 fillColor: (Color 57879 r: i 57880 g: 0 57881 b: 0 57882 range: 255). 57883 r := r translateBy: 0 @ dy. 57884 f 57885 fill: r 57886 fillColor: (Color 57887 r: 0 57888 g: i 57889 b: 0 57890 range: 255). 57891 r := r translateBy: 0 @ dy. 57892 f 57893 fill: r 57894 fillColor: (Color 57895 r: 0 57896 g: 0 57897 b: i 57898 range: 255). 57899 r := r translateBy: 0 @ dy. 57900 f 57901 fill: r 57902 fillColor: (Color 57903 r: i 57904 g: i 57905 b: i 57906 range: 255) ]. 57907 ^ f! ! 57908 57909!Color class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 57910hotColdShades: thisMany 57911 "An array of thisMany colors showing temperature from blue to red to white hot. (Later improve this by swinging in hue.) " 57912 "Color showColors: (Color hotColdShades: 25)" 57913 | n s1 s2 s3 s4 s5 | 57914 thisMany < 5 ifTrue: [ ^ self error: 'must be at least 5 shades' ]. 57915 n := thisMany // 5. 57916 s1 := self white 57917 mix: self yellow 57918 shades: thisMany - (n * 4). 57919 s2 := self yellow 57920 mix: self red 57921 shades: n + 1. 57922 s2 := s2 57923 copyFrom: 2 57924 to: n + 1. 57925 s3 := self red 57926 mix: self green darker 57927 shades: n + 1. 57928 s3 := s3 57929 copyFrom: 2 57930 to: n + 1. 57931 s4 := self green darker 57932 mix: self blue 57933 shades: n + 1. 57934 s4 := s4 57935 copyFrom: 2 57936 to: n + 1. 57937 s5 := self blue 57938 mix: self black 57939 shades: n + 1. 57940 s5 := s5 57941 copyFrom: 2 57942 to: n + 1. 57943 ^ s1 , s2 , s3 , s4 , s5! ! 57944 57945!Color class methodsFor: 'examples'! 57946showColorCube 57947 "Show a 12x12x12 color cube." 57948 "Color showColorCube" 57949 57950 0 to: 11 do: [:r | 57951 0 to: 11 do: [:g | 57952 0 to: 11 do: [:b | 57953 Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) 57954 fillColor: (Color r: r g: g b: b range: 11)]]]. 57955! ! 57956 57957!Color class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 57958showColors: colorList 57959 "Display the given collection of colors across the top of the Display." 57960 | w r | 57961 w := Display width // colorList size. 57962 r := 0 @ 0 extent: w @ ((w min: 30) max: 10). 57963 colorList do: 57964 [ :c | 57965 Display 57966 fill: r 57967 fillColor: c. 57968 r := r translateBy: w @ 0 ]! ! 57969 57970!Color class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 57971showHSVPalettes 57972 "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." 57973 "Color showHSVPalettes" 57974 | left top c | 57975 left := top := 0. 57976 0 57977 to: 179 57978 by: 15 57979 do: 57980 [ :h | 57981 0 57982 to: 10 57983 do: 57984 [ :s | 57985 left := h * 4 + (s * 4). 57986 0 57987 to: 10 57988 do: 57989 [ :v | 57990 c := Color 57991 h: h 57992 s: s asFloat / 10.0 57993 v: v asFloat / 10.0. 57994 top := v * 4. 57995 Display 57996 fill: (left @ top extent: 4 @ 4) 57997 fillColor: c. 57998 c := Color 57999 h: h + 180 58000 s: s asFloat / 10.0 58001 v: v asFloat / 10.0. 58002 top := v * 4 + 50. 58003 Display 58004 fill: (left @ top extent: 4 @ 4) 58005 fillColor: c ] ] ]! ! 58006 58007!Color class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 58008showHuesInteractively 58009 "Shows a palette of hues at a (saturation, brightness) point determined by the mouse position. Click the mouse button to exit and return the selected (saturation, brightness) point." 58010 "Color showHuesInteractively" 58011 | p s v | 58012 [ Sensor anyButtonPressed ] whileFalse: 58013 [ p := Sensor cursorPoint. 58014 s := p x asFloat / 300.0. 58015 v := p y asFloat / 300.0. 58016 self showColors: (self 58017 wheel: 12 58018 saturation: s 58019 brightness: v) ]. 58020 ^ (s min: 1.0) @ (v min: 1.0)! ! 58021 58022!Color class methodsFor: 'examples'! 58023wheel: thisMany 58024 "Return a collection of thisMany colors evenly spaced around the color wheel." 58025 "Color showColors: (Color wheel: 12)" 58026 58027 ^ Color wheel: thisMany saturation: 0.9 brightness: 0.7 58028! ! 58029 58030!Color class methodsFor: 'examples'! 58031wheel: thisMany saturation: s brightness: v 58032 "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." 58033 "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)" 58034 "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)" 58035 58036 ^ (Color h: 0.0 s: s v: v) wheel: thisMany 58037! ! 58038 58039 58040!Color class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 58041initialize 58042 "Color initialize" 58043 "Details: Externally, the red, green, and blue components of color 58044 are floats in the range [0.0..1.0]. Internally, they are represented 58045 as integers in the range [0..ComponentMask] packing into a 58046 small integer to save space and to allow fast hashing and 58047 equality testing. 58048 58049 For a general description of color representations for computer 58050 graphics, including the relationship between the RGB and HSV 58051 color models used here, see Chapter 17 of Foley and van Dam, 58052 Fundamentals of Interactive Computer Graphics, Addison-Wesley, 58053 1982." 58054 ComponentMask := 1023. 58055 HalfComponentMask := 512. "used to round up in integer calculations" 58056 ComponentMax := 1023.0. "a Float used to normalize components" 58057 RedShift := 20. 58058 GreenShift := 10. 58059 BlueShift := 0. 58060 PureRed := self 58061 r: 1 58062 g: 0 58063 b: 0. 58064 PureGreen := self 58065 r: 0 58066 g: 1 58067 b: 0. 58068 PureBlue := self 58069 r: 0 58070 g: 0 58071 b: 1. 58072 PureYellow := self 58073 r: 1 58074 g: 1 58075 b: 0. 58076 PureCyan := self 58077 r: 0 58078 g: 1 58079 b: 1. 58080 PureMagenta := self 58081 r: 1 58082 g: 0 58083 b: 1. 58084 RandomStream := Random new. 58085 self initializeIndexedColors. 58086 self initializeGrayToIndexMap. 58087 self initializeNames. 58088 self initializeHighLights! ! 58089 58090!Color class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 58091initializeGrayToIndexMap 58092 "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level." 58093 "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors." 58094 "Color initializeGrayToIndexMap" 58095 "record the level and index of each gray in the 8-bit color table" 58096 | grayLevels grayIndices c distToClosest dist indexOfClosest | 58097 grayLevels := OrderedCollection new. 58098 grayIndices := OrderedCollection new. 58099 "Note: skip the first entry, which is reserved for transparent" 58100 2 58101 to: IndexedColors size 58102 do: 58103 [ :i | 58104 c := IndexedColors at: i. 58105 c saturation = 0.0 ifTrue: 58106 [ "c is a gray" 58107 grayLevels add: c privateBlue >> 2. "top 8 bits; R, G, and B are the same" 58108 grayIndices add: i - 1 ] ]. "pixel values are zero-based" 58109 grayLevels := grayLevels asArray. 58110 grayIndices := grayIndices asArray. 58111 58112 "for each gray level in [0..255], select the closest match" 58113 GrayToIndexMap := ByteArray new: 256. 58114 0 58115 to: 255 58116 do: 58117 [ :level | 58118 distToClosest := 10000. "greater than distance to any real gray" 58119 1 58120 to: grayLevels size 58121 do: 58122 [ :i | 58123 dist := (level - (grayLevels at: i)) abs. 58124 dist < distToClosest ifTrue: 58125 [ distToClosest := dist. 58126 indexOfClosest := grayIndices at: i ] ]. 58127 GrayToIndexMap 58128 at: level + 1 58129 put: indexOfClosest ]! ! 58130 58131!Color class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 58132initializeHighLights 58133 "Create a set of Bitmaps for quickly reversing areas of the screen without converting colors. " 58134 "Color initializeHighLights" 58135 | t | 58136 t := Array new: 32. 58137 t 58138 at: 1 58139 put: (Bitmap with: 4294967295). 58140 t 58141 at: 2 58142 put: (Bitmap with: 4294967295). 58143 t 58144 at: 4 58145 put: (Bitmap with: 1431655765). 58146 t 58147 at: 8 58148 put: (Bitmap with: 117901063). 58149 t 58150 at: 16 58151 put: (Bitmap with: 4294967295). 58152 t 58153 at: 32 58154 put: (Bitmap with: 4294967295). 58155 HighLightBitmaps := t! ! 58156 58157!Color class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 58158initializeIndexedColors 58159 "Build an array of colors corresponding to the fixed colormap used 58160 for display depths of 1, 2, 4, or 8 bits." 58161 "Color initializeIndexedColors" 58162 | a index grayVal | 58163 a := Array new: 256. 58164 58165 "1-bit colors (monochrome)" 58166 a 58167 at: 1 58168 put: (Color 58169 r: 1.0 58170 g: 1.0 58171 b: 1.0). "white or transparent" 58172 a 58173 at: 2 58174 put: (Color 58175 r: 0.0 58176 g: 0.0 58177 b: 0.0). "black" 58178 58179 "additional colors for 2-bit color" 58180 a 58181 at: 3 58182 put: (Color 58183 r: 1.0 58184 g: 1.0 58185 b: 1.0). "opaque white" 58186 a 58187 at: 4 58188 put: (Color 58189 r: 0.5 58190 g: 0.5 58191 b: 0.5). "1/2 gray" 58192 58193 "additional colors for 4-bit color" 58194 a 58195 at: 5 58196 put: (Color 58197 r: 1.0 58198 g: 0.0 58199 b: 0.0). "red" 58200 a 58201 at: 6 58202 put: (Color 58203 r: 0.0 58204 g: 1.0 58205 b: 0.0). "green" 58206 a 58207 at: 7 58208 put: (Color 58209 r: 0.0 58210 g: 0.0 58211 b: 1.0). "blue" 58212 a 58213 at: 8 58214 put: (Color 58215 r: 0.0 58216 g: 1.0 58217 b: 1.0). "cyan" 58218 a 58219 at: 9 58220 put: (Color 58221 r: 1.0 58222 g: 1.0 58223 b: 0.0). "yellow" 58224 a 58225 at: 10 58226 put: (Color 58227 r: 1.0 58228 g: 0.0 58229 b: 1.0). "magenta" 58230 a 58231 at: 11 58232 put: (Color 58233 r: 0.125 58234 g: 0.125 58235 b: 0.125). "1/8 gray" 58236 a 58237 at: 12 58238 put: (Color 58239 r: 0.25 58240 g: 0.25 58241 b: 0.25). "2/8 gray" 58242 a 58243 at: 13 58244 put: (Color 58245 r: 0.375 58246 g: 0.375 58247 b: 0.375). "3/8 gray" 58248 a 58249 at: 14 58250 put: (Color 58251 r: 0.625 58252 g: 0.625 58253 b: 0.625). "5/8 gray" 58254 a 58255 at: 15 58256 put: (Color 58257 r: 0.75 58258 g: 0.75 58259 b: 0.75). "6/8 gray" 58260 a 58261 at: 16 58262 put: (Color 58263 r: 0.875 58264 g: 0.875 58265 b: 0.875). "7/8 gray" 58266 58267 "additional colors for 8-bit color" 58268 "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" 58269 index := 17. 58270 1 58271 to: 31 58272 do: 58273 [ :v | 58274 v \\ 4 = 0 ifFalse: 58275 [ grayVal := v / 32.0. 58276 a 58277 at: index 58278 put: (Color 58279 r: grayVal 58280 g: grayVal 58281 b: grayVal). 58282 index := index + 1 ] ]. 58283 58284 "The remainder of color table defines a color cube with six steps 58285 for each primary color. Note that the corners of this cube repeat 58286 previous colors, but this simplifies the mapping between RGB colors 58287 and color map indices. This color cube spans indices 40 through 255 58288 (indices 41-256 in this 1-based array)." 58289 0 58290 to: 5 58291 do: 58292 [ :r | 58293 0 58294 to: 5 58295 do: 58296 [ :g | 58297 0 58298 to: 5 58299 do: 58300 [ :b | 58301 index := 41 + (36 * r + (6 * b) + g). 58302 index > 256 ifTrue: [ self error: 'index out of range in color table compuation' ]. 58303 a 58304 at: index 58305 put: (Color 58306 r: r 58307 g: g 58308 b: b 58309 range: 5) ] ] ]. 58310 IndexedColors := a! ! 58311 58312!Color class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 58313initializeTranslucentPatterns 58314 "Color initializeTranslucentPatterns" 58315 | mask bits pattern patternList | 58316 TranslucentPatterns := Array new: 8. 58317 #(1 2 4 8 ) do: 58318 [ :d | 58319 patternList := Array new: 5. 58320 mask := (1 bitShift: d) - 1. 58321 bits := 2 * d. 58322 [ bits >= 32 ] whileFalse: 58323 [ mask := mask bitOr: (mask bitShift: bits). "double the length of mask" 58324 bits := bits + bits ]. 58325 "0% pattern" 58326 pattern := Bitmap 58327 with: 0 58328 with: 0. 58329 patternList 58330 at: 1 58331 put: pattern. 58332 "25% pattern" 58333 pattern := Bitmap 58334 with: mask 58335 with: 0. 58336 patternList 58337 at: 2 58338 put: pattern. 58339 "50% pattern" 58340 pattern := Bitmap 58341 with: mask 58342 with: mask bitInvert32. 58343 patternList 58344 at: 3 58345 put: pattern. 58346 "75% pattern" 58347 pattern := Bitmap 58348 with: mask 58349 with: 4294967295. 58350 patternList 58351 at: 4 58352 put: pattern. 58353 "100% pattern" 58354 pattern := Bitmap 58355 with: 4294967295 58356 with: 4294967295. 58357 patternList 58358 at: 5 58359 put: pattern. 58360 TranslucentPatterns 58361 at: d 58362 put: patternList ]! ! 58363 58364!Color class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 58365named: newName put: aColor 58366 "Add a new color to the list and create an access message and a class variable for it. The name should start with a lowercase letter. (The class variable will start with an uppercase letter.) (Color colorNames) returns a list of all color names. " 58367 | str cap sym accessor csym | 58368 str := newName asString. 58369 sym := str asSymbol. 58370 cap := str capitalized. 58371 csym := cap asSymbol. 58372 (self class canUnderstand: sym) ifFalse: 58373 [ "define access message" 58374 accessor := str , (String 58375 with: Character cr 58376 with: Character tab) , '^' , cap. 58377 self class 58378 compile: accessor 58379 classified: 'named colors' ]. 58380 (self classPool includesKey: csym) ifFalse: [ self addClassVarName: cap ]. 58381 (ColorNames includes: sym) ifFalse: [ ColorNames add: sym ]. 58382 ^ self classPool 58383 at: csym 58384 put: aColor! ! 58385 58386 58387!Color class methodsFor: 'instance creation' stamp: 'ar 4/10/2005 18:45'! 58388colorFrom: parm 58389 "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" 58390 58391 | aColor firstParm | 58392 (parm isKindOf: Color) ifTrue: [^ parm]. 58393 (parm isSymbol) ifTrue: [^ self perform: parm]. 58394 (parm isString) ifTrue: [^ self fromString: parm]. 58395 ((parm isKindOf: SequenceableCollection) and: [parm size > 0]) 58396 ifTrue: 58397 [firstParm := parm first. 58398 (firstParm isKindOf: Number) ifTrue: 58399 [^ self fromRgbTriplet: parm]. 58400 aColor := self colorFrom: firstParm. 58401 parm doWithIndex: 58402 [:sym :ind | ind > 1 ifTrue: 58403 [aColor := aColor perform: sym]]. 58404 ^ aColor]. 58405 ^ parm 58406 58407" 58408Color colorFrom: #(blue darker) 58409Color colorFrom: Color blue darker 58410Color colorFrom: #blue 58411Color colorFrom: #(0.0 0.0 1.0) 58412"! ! 58413 58414!Color class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 58415colorFromPixelValue: p depth: d 58416 "Convert a pixel value for the given display depth into a color." 58417 "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." 58418 | r g b alpha | 58419 d = 8 ifTrue: [ ^ IndexedColors at: (p bitAnd: 255) + 1 ]. 58420 d = 4 ifTrue: [ ^ IndexedColors at: (p bitAnd: 15) + 1 ]. 58421 d = 2 ifTrue: [ ^ IndexedColors at: (p bitAnd: 3) + 1 ]. 58422 d = 1 ifTrue: [ ^ IndexedColors at: (p bitAnd: 1) + 1 ]. 58423 d = 16 | (d = 15) ifTrue: 58424 [ "five bits per component" 58425 r := (p bitShift: -10) bitAnd: 31. 58426 g := (p bitShift: -5) bitAnd: 31. 58427 b := p bitAnd: 31. 58428 (r = 0 and: [ g = 0 ]) ifTrue: 58429 [ b = 0 ifTrue: [ ^ Color transparent ]. 58430 b = 1 ifTrue: [ ^ Color black ] ]. 58431 ^ Color 58432 r: r 58433 g: g 58434 b: b 58435 range: 31 ]. 58436 d = 32 ifTrue: 58437 [ "eight bits per component; 8 bits of alpha" 58438 r := (p bitShift: -16) bitAnd: 255. 58439 g := (p bitShift: -8) bitAnd: 255. 58440 b := p bitAnd: 255. 58441 alpha := p bitShift: -24. 58442 alpha = 0 ifTrue: [ ^ Color transparent ]. 58443 (r = 0 and: [ g = 0 and: [ b = 0 ] ]) ifTrue: [ ^ Color transparent ]. 58444 alpha < 255 58445 ifTrue: 58446 [ ^ (Color 58447 r: r 58448 g: g 58449 b: b 58450 range: 255) alpha: alpha asFloat / 255.0 ] 58451 ifFalse: 58452 [ ^ Color 58453 r: r 58454 g: g 58455 b: b 58456 range: 255 ] ]. 58457 d = 12 ifTrue: 58458 [ "four bits per component" 58459 r := (p bitShift: -8) bitAnd: 15. 58460 g := (p bitShift: -4) bitAnd: 15. 58461 b := p bitAnd: 15. 58462 ^ Color 58463 r: r 58464 g: g 58465 b: b 58466 range: 15 ]. 58467 d = 9 ifTrue: 58468 [ "three bits per component" 58469 r := (p bitShift: -6) bitAnd: 7. 58470 g := (p bitShift: -3) bitAnd: 7. 58471 b := p bitAnd: 7. 58472 ^ Color 58473 r: r 58474 g: g 58475 b: b 58476 range: 7 ]. 58477 self error: 'unknown pixel depth: ' , d printString! ! 58478 58479!Color class methodsFor: 'instance creation' stamp: 'mir 7/21/1999 11:54'! 58480fromArray: colorDef 58481 colorDef size == 3 58482 ifTrue: [^self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)]. 58483 colorDef size == 0 58484 ifTrue: [^Color transparent]. 58485 colorDef size == 4 58486 ifTrue: [^(TranslucentColor r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)) alpha: (colorDef at: 4)]. 58487 self error: 'Undefined color definition'! ! 58488 58489!Color class methodsFor: 'instance creation' stamp: 'sw 8/8/97 22:03'! 58490fromRgbTriplet: list 58491 ^ self r: list first g: list second b: list last! ! 58492 58493!Color class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 58494fromString: aString 58495 "for HTML color spec: #FFCCAA or white/black" 58496 "Color fromString: '#FFCCAA'. 58497 Color fromString: 'white'. 58498 Color fromString: 'orange'" 58499 | aColorHex red green blue | 58500 aString isEmptyOrNil ifTrue: [ ^ Color white ]. 58501 aString first = $# 58502 ifTrue: 58503 [ aColorHex := aString 58504 copyFrom: 2 58505 to: aString size ] 58506 ifFalse: [ aColorHex := aString ]. 58507 58508 [ aColorHex size = 6 ifTrue: 58509 [ aColorHex := aColorHex asUppercase. 58510 red := ('16r' , (aColorHex 58511 copyFrom: 1 58512 to: 2)) asNumber / 255. 58513 green := ('16r' , (aColorHex 58514 copyFrom: 3 58515 to: 4)) asNumber / 255. 58516 blue := ('16r' , (aColorHex 58517 copyFrom: 5 58518 to: 6)) asNumber / 255. 58519 ^ self 58520 r: red 58521 g: green 58522 b: blue ] ] ifError: 58523 [ :err :rcvr | 58524 "not a hex color triplet" 58525 ]. 58526 58527 "try to match aColorHex with known named colors" 58528 aColorHex := aColorHex asLowercase. 58529 ^ self perform: (ColorNames 58530 detect: [ :i | i asString asLowercase = aColorHex ] 58531 ifNone: [ #white ])! ! 58532 58533!Color class methodsFor: 'instance creation' stamp: 'jm 12/4/97 13:05'! 58534gray: brightness 58535 "Return a gray shade with the given brightness in the range [0.0..1.0]." 58536 58537 ^ self basicNew setRed: brightness green: brightness blue: brightness 58538! ! 58539 58540!Color class methodsFor: 'instance creation'! 58541h: hue s: saturation v: brightness 58542 "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." 58543 "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." 58544 58545 ^ self basicNew setHue: hue saturation: saturation brightness: brightness! ! 58546 58547!Color class methodsFor: 'instance creation' stamp: 'dew 3/19/2002 23:49'! 58548h: h s: s v: v alpha: alpha 58549 58550 ^ (self h: h s: s v: v) alpha: alpha! ! 58551 58552!Color class methodsFor: 'instance creation'! 58553new 58554 58555 ^ self r: 0.0 g: 0.0 b: 0.0! ! 58556 58557!Color class methodsFor: 'instance creation' stamp: 'jm 12/4/97 13:04'! 58558r: r g: g b: b 58559 "Return a color with the given r, g, and b components in the range [0.0..1.0]." 58560 58561 ^ self basicNew setRed: r green: g blue: b 58562! ! 58563 58564!Color class methodsFor: 'instance creation'! 58565r: r g: g b: b alpha: alpha 58566 58567 ^ (self r: r g: g b: b) alpha: alpha! ! 58568 58569!Color class methodsFor: 'instance creation'! 58570r: r g: g b: b range: range 58571 "Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)." 58572 58573 ^ self basicNew setRed: r green: g blue: b range: range! ! 58574 58575!Color class methodsFor: 'instance creation'! 58576random 58577 "Return a random color that isn't too dark or under-saturated." 58578 58579 ^ self basicNew 58580 setHue: (360.0 * RandomStream next) 58581 saturation: (0.3 + (RandomStream next * 0.7)) 58582 brightness: (0.4 + (RandomStream next * 0.6))! ! 58583 58584 58585!Color class methodsFor: 'named colors'! 58586black 58587 ^Black! ! 58588 58589!Color class methodsFor: 'named colors'! 58590blue 58591 ^Blue! ! 58592 58593!Color class methodsFor: 'named colors'! 58594brown 58595 ^Brown! ! 58596 58597!Color class methodsFor: 'named colors'! 58598cyan 58599 ^Cyan! ! 58600 58601!Color class methodsFor: 'named colors'! 58602darkGray 58603 ^DarkGray! ! 58604 58605!Color class methodsFor: 'named colors'! 58606gray 58607 ^Gray! ! 58608 58609!Color class methodsFor: 'named colors'! 58610green 58611 ^Green! ! 58612 58613!Color class methodsFor: 'named colors'! 58614lightBlue 58615 ^LightBlue! ! 58616 58617!Color class methodsFor: 'named colors'! 58618lightBrown 58619 ^LightBrown! ! 58620 58621!Color class methodsFor: 'named colors'! 58622lightCyan 58623 ^LightCyan! ! 58624 58625!Color class methodsFor: 'named colors'! 58626lightGray 58627 ^LightGray! ! 58628 58629!Color class methodsFor: 'named colors'! 58630lightGreen 58631 ^LightGreen! ! 58632 58633!Color class methodsFor: 'named colors'! 58634lightMagenta 58635 ^LightMagenta! ! 58636 58637!Color class methodsFor: 'named colors'! 58638lightOrange 58639 ^LightOrange! ! 58640 58641!Color class methodsFor: 'named colors'! 58642lightRed 58643 ^LightRed! ! 58644 58645!Color class methodsFor: 'named colors'! 58646lightYellow 58647 ^LightYellow! ! 58648 58649!Color class methodsFor: 'named colors'! 58650magenta 58651 ^Magenta! ! 58652 58653!Color class methodsFor: 'named colors'! 58654orange 58655 ^Orange! ! 58656 58657!Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:06'! 58658paleBlue 58659 ^(Color r: 0.87 g: 0.976 b: 0.995) 58660! ! 58661 58662!Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:07'! 58663paleBuff 58664 ^(Color r: 0.995 g: 0.979 b: 0.921)! ! 58665 58666!Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:06'! 58667paleGreen 58668 ^(Color r: 0.874 g: 1.0 b: 0.835)! ! 58669 58670!Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:05'! 58671paleMagenta 58672 ^(Color r: 1.0 g: 0.901 b: 1.0)! ! 58673 58674!Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:03'! 58675paleOrange 58676 ^ (Color r: 0.991 g: 0.929 b: 0.843) 58677! ! 58678 58679!Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:03'! 58680palePeach 58681 ^(Color r: 1.0 g: 0.929 b: 0.835)! ! 58682 58683!Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:07'! 58684paleRed 58685 ^(Color r: 1.0 g: 0.901 b: 0.901)! ! 58686 58687!Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:02'! 58688paleTan 58689 ^(Color r: 0.921 g: 0.878 b: 0.78) 58690! ! 58691 58692!Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:05'! 58693paleYellow 58694 ^(Color r: 1.0 g: 1.0 b: 0.85)! ! 58695 58696!Color class methodsFor: 'named colors'! 58697red 58698 ^Red! ! 58699 58700!Color class methodsFor: 'named colors' stamp: 'wod 5/24/1998 01:56'! 58701tan 58702 ^ Color r: 0.8 g: 0.8 b: 0.5! ! 58703 58704!Color class methodsFor: 'named colors'! 58705transparent 58706 ^Transparent! ! 58707 58708!Color class methodsFor: 'named colors'! 58709veryDarkGray 58710 ^VeryDarkGray! ! 58711 58712!Color class methodsFor: 'named colors'! 58713veryLightGray 58714 ^VeryLightGray! ! 58715 58716!Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:06'! 58717veryPaleRed 58718 ^(Color r: 1.0 g: 0.948 b: 0.948)! ! 58719 58720!Color class methodsFor: 'named colors'! 58721veryVeryDarkGray 58722 ^VeryVeryDarkGray! ! 58723 58724!Color class methodsFor: 'named colors'! 58725veryVeryLightGray 58726 ^VeryVeryLightGray! ! 58727 58728!Color class methodsFor: 'named colors'! 58729white 58730 ^White! ! 58731 58732!Color class methodsFor: 'named colors'! 58733yellow 58734 ^Yellow! ! 58735 58736 58737!Color class methodsFor: 'other'! 58738colorNames 58739 "Return a collection of color names." 58740 58741 ^ ColorNames! ! 58742 58743!Color class methodsFor: 'other' stamp: 'BG 3/16/2005 08:18'! 58744hex: aFloat 58745 "Return an hexadecimal two-digits string between 00 and FF 58746 for a float between 0.0 and 1.0" 58747 | str | 58748 str := ((aFloat * 255) asInteger printStringHex) asLowercase. 58749 str size = 1 ifTrue: [^'0',str] ifFalse: [^str]! ! 58750 58751!Color class methodsFor: 'other'! 58752indexedColors 58753 58754 ^ IndexedColors! ! 58755 58756!Color class methodsFor: 'other' stamp: 'lr 7/4/2009 10:42'! 58757maskingMap: depth 58758 "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero. Cache the most recently used map." 58759 | sizeNeeded | 58760 depth <= 8 58761 ifTrue: [ sizeNeeded := 1 bitShift: depth ] 58762 ifFalse: [ sizeNeeded := 4096 ]. 58763 (MaskingMap == nil or: [ MaskingMap size ~= sizeNeeded ]) ifTrue: 58764 [ MaskingMap := Bitmap 58765 new: sizeNeeded 58766 withAll: 4294967295. 58767 MaskingMap 58768 at: 1 58769 put: 0 "transparent" ]. 58770 ^ MaskingMap! ! 58771 58772!Color class methodsFor: 'other' stamp: 'lr 7/4/2009 10:42'! 58773pixelScreenForDepth: depth 58774 "Return a 50% stipple containing alternating pixels of all-zeros and all-ones to be used as a mask at the given depth." 58775 | mask bits | 58776 mask := (1 bitShift: depth) - 1. 58777 bits := 2 * depth. 58778 [ bits >= 32 ] whileFalse: 58779 [ mask := mask bitOr: (mask bitShift: bits). "double the length of mask" 58780 bits := bits + bits ]. 58781 ^ Bitmap 58782 with: mask 58783 with: mask bitInvert32! ! 58784 58785!Color class methodsFor: 'other'! 58786quickHighLight: depth 58787 "Quickly return a Bitblt-ready raw colorValue for highlighting areas. 6/22/96 tk" 58788 58789 ^ HighLightBitmaps at: depth! ! 58790 58791!Color class methodsFor: 'other' stamp: 'lr 7/4/2009 10:42'! 58792shutDown 58793 "Color shutDown" 58794 ColorChart := nil. "Palette of colors for the user to pick from" 58795 CachedColormaps := nil. "Maps to translate between color depths" 58796 MaskingMap := nil "Maps all colors except transparent to black for creating a mask"! ! 58797 58798!Color class methodsFor: 'other' stamp: 'ar 2/16/2000 21:56'! 58799translucentMaskFor: alphaValue depth: d 58800 "Return a pattern representing a mask usable for stipple transparency" 58801 ^(TranslucentPatterns at: d) at: ((alphaValue min: 1.0 max: 0.0) * 4) rounded + 1! ! 58802ArrayedCollection variableWordSubclass: #ColorArray 58803 instanceVariableNames: '' 58804 classVariableNames: '' 58805 poolDictionaries: '' 58806 category: 'Collections-Arrayed'! 58807 58808!ColorArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 20:03'! 58809at: index 58810 ^(super at: index) asColorOfDepth: 32! ! 58811 58812!ColorArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 20:04'! 58813at: index put: aColor 58814 ^super at: index put: (aColor pixelWordForDepth: 32).! ! 58815 58816 58817!ColorArray methodsFor: 'converting' stamp: 'ar 3/3/2001 20:06'! 58818asColorArray 58819 ^self! ! 58820 58821!ColorArray methodsFor: 'converting' stamp: 'RAA 3/8/2001 06:24'! 58822bytesPerElement 58823 58824 ^4! ! 58825ColorPresenterMorph subclass: #ColorChooserMorph 58826 uses: TEnableOnHaloMenu 58827 instanceVariableNames: 'setColorSelector enabled getEnabledSelector' 58828 classVariableNames: '' 58829 poolDictionaries: '' 58830 category: 'Polymorph-Widgets'! 58831!ColorChooserMorph commentStamp: 'gvc 5/18/2007 13:45' prior: 0! 58832ColorPresenter that opens a colour selector when clicked.! 58833 58834 58835!ColorChooserMorph methodsFor: 'accessing' stamp: 'gvc 10/12/2006 13:47'! 58836getEnabledSelector 58837 "Answer the value of getEnabledSelector" 58838 58839 ^ getEnabledSelector! ! 58840 58841!ColorChooserMorph methodsFor: 'accessing' stamp: 'gvc 10/12/2006 13:51'! 58842getEnabledSelector: anObject 58843 "Set the value of getEnabledSelector" 58844 58845 getEnabledSelector := anObject. 58846 self updateEnabled! ! 58847 58848 58849!ColorChooserMorph methodsFor: 'as yet unclassified'! 58850addToggleItemsToHaloMenu: aCustomMenu 58851 "Add toggle-items to the halo menu" 58852 58853 super addToggleItemsToHaloMenu: aCustomMenu. 58854 aCustomMenu 58855 addUpdating: #enabledString 58856 target: self 58857 action: #toggleEnabled! ! 58858 58859!ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 11:03'! 58860chooseColor 58861 "Popup the color picker for now." 58862 58863 |newColor| 58864 newColor := self theme 58865 chooseColorIn: ((self ownerThatIsA: SystemWindow) ifNil: [self]) 58866 title: 'Choose Color' 58867 color: self labelMorph color. 58868 newColor ifNil: [^self]. 58869 self labelMorph color: newColor. 58870 self solidLabelMorph color: newColor asNontranslucentColor. 58871 self setColorSelector ifNotNil: [self model perform: self setColorSelector with: newColor]! ! 58872 58873!ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/12/2006 13:46'! 58874enabled 58875 "Answer the enabled state of the receiver." 58876 58877 ^enabled! ! 58878 58879!ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:57'! 58880enabled: aBoolean 58881 "Set the enabled state of the receiver." 58882 58883 enabled := aBoolean. 58884 self contentMorph ifNotNilDo: [:m | m enabled: aBoolean]. 58885 self changed: #enabled! ! 58886 58887!ColorChooserMorph methodsFor: 'as yet unclassified'! 58888enabledString 58889 "Answer the string to be shown in a menu to represent the 58890 'enabled' status" 58891 58892 ^ (self enabled 58893 ifTrue: ['<on>'] 58894 ifFalse: ['<off>']), 'enabled' translated! ! 58895 58896!ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 11:44'! 58897initialize 58898 "Initialize the receiver." 58899 58900 enabled := true. 58901 super initialize! ! 58902 58903!ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 19:40'! 58904newContentMorph 58905 "Answer a new button morph" 58906 58907 |b| 58908 b := (self theme 58909 newButtonIn: self 58910 for: self 58911 getState: nil 58912 action: #chooseColor 58913 arguments: #() 58914 getEnabled: #enabled 58915 label: (self newHatchMorph layoutInset: 2) 58916 help: nil) 58917 hResizing: #spaceFill. 58918 b contentHolder hResizing: #spaceFill. 58919 ^b! ! 58920 58921!ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:46'! 58922on: anObject color: getColSel changeColor: setColSel 58923 "Set the receiver to the given model parameterized by the given message selectors." 58924 58925 self 58926 on: anObject color: getColSel; 58927 setColorSelector: setColSel! ! 58928 58929!ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/14/2009 18:41'! 58930setColorSelector 58931 "Answer the value of setColorSelector" 58932 58933 ^ setColorSelector! ! 58934 58935!ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/14/2009 18:41'! 58936setColorSelector: anObject 58937 "Set the value of setColorSelector" 58938 58939 setColorSelector := anObject! ! 58940 58941!ColorChooserMorph methodsFor: 'as yet unclassified'! 58942toggleEnabled 58943 "Toggle the enabled state." 58944 58945 self enabled: self enabled not! ! 58946 58947!ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/12/2006 13:51'! 58948update: aSymbol 58949 "Refer to the comment in View|update:." 58950 58951 super update: aSymbol. 58952 aSymbol == self getEnabledSelector ifTrue: 58953 [self updateEnabled. 58954 ^ self]! ! 58955 58956!ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:25'! 58957updateEnabled 58958 "Update the enablement state." 58959 58960 self model ifNotNil: [ 58961 self getEnabledSelector ifNotNil: [ 58962 self enabled: (self model perform: self getEnabledSelector)]]! ! 58963 58964"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 58965 58966ColorChooserMorph class 58967 uses: TEnableOnHaloMenu classTrait 58968 instanceVariableNames: ''! 58969 58970!ColorChooserMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:49'! 58971on: anObject color: getSel changeColor: setSel 58972 "Answer a new instance of the receiver on the given model using 58973 the given selectors as the interface." 58974 58975 ^self new 58976 on: anObject 58977 color: getSel 58978 changeColor: setSel! ! 58979SolidFillStyle subclass: #ColorFillStyle 58980 instanceVariableNames: 'origin extent' 58981 classVariableNames: '' 58982 poolDictionaries: '' 58983 category: 'Polymorph-Widgets-FillStyles'! 58984!ColorFillStyle commentStamp: 'gvc 12/8/2008 13:05' prior: 0! 58985Simple fillstyle that draws a color at the specified origin with option extent.! 58986 58987 58988!ColorFillStyle methodsFor: 'accessing' stamp: 'gvc 12/8/2008 13:05'! 58989extent 58990 "Answer the value of extent" 58991 58992 ^ extent! ! 58993 58994!ColorFillStyle methodsFor: 'accessing' stamp: 'gvc 12/8/2008 13:05'! 58995extent: anObject 58996 "Set the value of extent" 58997 58998 extent := anObject! ! 58999 59000!ColorFillStyle methodsFor: 'accessing' stamp: 'gvc 12/8/2008 13:05'! 59001origin 59002 "Answer the value of origin" 59003 59004 ^ origin! ! 59005 59006!ColorFillStyle methodsFor: 'accessing' stamp: 'gvc 12/8/2008 13:05'! 59007origin: anObject 59008 "Set the value of origin" 59009 59010 origin := anObject! ! 59011 59012 59013!ColorFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 13:11'! 59014fillRectangle: aRectangle on: aCanvas 59015 "Fill the given rectangle on the given canvas with the receiver." 59016 59017 |o c| 59018 o := self origin ifNil: [aRectangle origin] ifNotNil: [self origin]. 59019 c := self extent ifNil: [aRectangle corner] ifNotNil: [o + self extent]. 59020 aCanvas fillRectangle: (o corner: c) basicFillStyle: self! ! 59021 59022!ColorFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 13:14'! 59023isOrientedFill 59024 "Answer true if origin is not nil so that morph movement adjusts origin." 59025 59026 ^self origin notNil! ! 59027Form subclass: #ColorForm 59028 instanceVariableNames: 'colors cachedDepth cachedColormap' 59029 classVariableNames: '' 59030 poolDictionaries: '' 59031 category: 'Graphics-Display Objects'! 59032!ColorForm commentStamp: '<historical>' prior: 0! 59033ColorForm is a normal Form plus a color map of up to 2^depth Colors. Typically, one reserves one entry in the color map for transparent. This allows 1, 3, 15, or 255 non-transparent colors in ColorForms of depths 1, 2, 4, and 8 bits per pixel. ColorForms don't support depths greater than 8 bits because that would require excessively large color maps with little real benefit, since 16-bit and 32-bit depths already support thousands and millions of colors. 59034 59035ColorForms have several uses: 59036 1) Precise colors. You can have up to 256 true colors, instead being limited to the 8-bit color palette. 59037 2) Easy transparency. Just store (Color transparent) at the desired position in the color map. 59038 3) Cheap color remapping by changing the color map. 59039 59040A color map is an Array of up to 2^depth Color objects. A Bitmap colorMap is automatically computed and cached for rapid display. Note that if you change the color map, you must resubmit it via the colors: method to flush this cache. 59041 59042ColorForms can be a bit tricky. Note that: 59043 a) When you BitBlt from one ColorForm to another, you must remember to copy the color map of the source ColorForm to the destination ColorForm. 59044 b) A ColorForm's color map is an array of depth-independent Color objects. BitBlt requires a BitMap of actual pixel values, adjusted to the destination depth. These are different things!! ColorForms automatically maintain a cache of the BitBlt-style color map corresponding to the colors array for the last depth on which the ColorForm was displayed, so there should be little need for clients to work with BitBlt-style color maps. 59045 c) The default map for 8 bit depth has black in the first entry, not transparent. Say (cform colors at: 1 put: Color transparent). 59046! 59047 59048 59049!ColorForm methodsFor: 'accessing' stamp: 'jm 11/14/97 17:39'! 59050colors 59051 "Return my color palette." 59052 59053 self ensureColorArrayExists. 59054 ^ colors 59055! ! 59056 59057!ColorForm methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45'! 59058colors: colorList 59059 "Set my color palette to the given collection." 59060 59061 | colorArray colorCount newColors | 59062 colorList ifNil: [ 59063 colors := cachedDepth := cachedColormap := nil. 59064 ^ self]. 59065 59066 colorArray := colorList asArray. 59067 colorCount := colorArray size. 59068 newColors := Array new: (1 bitShift: self depth). 59069 1 to: newColors size do: [:i | 59070 i <= colorCount 59071 ifTrue: [newColors at: i put: (colorArray at: i)] 59072 ifFalse: [newColors at: i put: Color transparent]]. 59073 59074 colors := newColors. 59075 cachedDepth := nil. 59076 cachedColormap := nil. 59077! ! 59078 59079!ColorForm methodsFor: 'accessing' stamp: 'mir 7/21/1999 11:51'! 59080colorsFromArray: colorArray 59081 | colorList | 59082 colorList := colorArray collect: [:colorDef | 59083 Color fromArray: colorDef]. 59084 self colors: colorList! ! 59085 59086 59087!ColorForm methodsFor: 'color manipulation' stamp: 'di 11/11/1998 13:20'! 59088asGrayScale 59089 "Return a grayscale ColorForm computed by mapping each color into its grayscale equivalent" 59090 ^ self copy colors: 59091 (colors collect: 59092 [:c | c isTransparent ifTrue: [c] 59093 ifFalse: [Color gray: c luminance]])! ! 59094 59095!ColorForm methodsFor: 'color manipulation' stamp: 'ar 5/17/2001 15:44'! 59096colormapIfNeededForDepth: destDepth 59097 "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." 59098 59099 | newMap | 59100 colors == nil ifTrue: [ 59101 "use the standard colormap" 59102 ^ Color colorMapIfNeededFrom: self depth to: destDepth]. 59103 59104 (destDepth = cachedDepth and:[cachedColormap isColormap not]) 59105 ifTrue: [^ cachedColormap]. 59106 newMap := Bitmap new: colors size. 59107 1 to: colors size do: [:i | 59108 newMap 59109 at: i 59110 put: ((colors at: i) pixelValueForDepth: destDepth)]. 59111 59112 cachedDepth := destDepth. 59113 ^ cachedColormap := newMap. 59114! ! 59115 59116!ColorForm methodsFor: 'color manipulation' stamp: 'jm 4/18/98 20:34'! 59117colorsUsed 59118 "Return a list of the colors actually used by this ColorForm." 59119 59120 | myColor list | 59121 myColor := self colors. 59122 list := OrderedCollection new. 59123 self tallyPixelValues doWithIndex: [:count :i | 59124 count > 0 ifTrue: [list add: (myColor at: i)]]. 59125 ^ list asArray 59126! ! 59127 59128!ColorForm methodsFor: 'color manipulation' stamp: 'jm 11/16/97 11:18'! 59129ensureTransparentColor 59130 "Ensure that the receiver (a) includes Color transparent in its color map and (b) that the entry for Color transparent is the first entry in its color map." 59131 59132 | i | 59133self error: 'not yet implemented'. 59134 (colors includes: Color transparent) 59135 ifTrue: [ 59136 (colors indexOf: Color transparent) = 1 ifTrue: [^ self]. 59137 "shift the entry for color transparent"] 59138 ifFalse: [ 59139 i := self unusedColormapEntry. 59140 i = 0 ifTrue: [self error: 'no color map entry is available']. 59141 colors at: i put: Color transparent. 59142 "shift the entry for color transparent"]. 59143! ! 59144 59145!ColorForm methodsFor: 'color manipulation' stamp: 'di 8/28/1998 15:48'! 59146indexOfColor: aColor 59147 "Return the index of aColor in my color array" 59148 59149 self ensureColorArrayExists. 59150 ^ colors indexOf: aColor ifAbsent: [0]! ! 59151 59152!ColorForm methodsFor: 'color manipulation' stamp: 'jm 10/19/1998 10:52'! 59153mapColor: oldColor to: newColor 59154 "Replace all occurances of the given color with the given new color in my color map." 59155 59156 self ensureColorArrayExists. 59157 1 to: colors size do: [:i | 59158 (colors at: i) = oldColor ifTrue: [colors at: i put: newColor]]. 59159 self clearColormapCache. 59160! ! 59161 59162!ColorForm methodsFor: 'color manipulation' stamp: 'jm 11/16/97 09:08'! 59163replaceColor: oldColor with: newColor 59164 "Replace all occurances of the given color with the given new color in my color map." 59165 59166 self ensureColorArrayExists. 59167 1 to: colors size do: [:i | 59168 (colors at: i) = oldColor ifTrue: [colors at: i put: newColor]]. 59169 self clearColormapCache. 59170! ! 59171 59172!ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 15:42'! 59173replaceColorAt: aPoint with: newColor 59174 "Replace a color map entry with newColor. The entry replaced is the one used by aPoint. If there are are two entries in the colorMap for the oldColor, just replace ONE!!!! There are often two whites or two blacks, and this is what you want, when replacing one." 59175 59176 | oldIndex | 59177 self ensureColorArrayExists. 59178 oldIndex := self pixelValueAt: aPoint. 59179 colors at: oldIndex+1 put: newColor. 59180 self clearColormapCache. 59181! ! 59182 59183!ColorForm methodsFor: 'color manipulation' stamp: 'di 8/28/1998 15:49'! 59184replaceColorAtIndex: index with: newColor 59185 "Replace a color map entry with newColor." 59186 59187 self ensureColorArrayExists. 59188 colors at: index put: newColor. 59189 cachedColormap == nil ifFalse: 59190 [cachedColormap at: index put: (newColor pixelValueForDepth: cachedDepth)]! ! 59191 59192!ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 11:26'! 59193transparentAllPixelsLike: aPoint 59194 "Make all occurances of the given pixel value transparent. Very useful when two entries in the colorMap have the same value. This only changes ONE." 59195 59196 self replaceColorAt: aPoint with: Color transparent. 59197! ! 59198 59199!ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 11:27'! 59200transparentColor: aColor 59201 "Make all occurances of the given color transparent. Note: for colors like black and white, which have two entries in the colorMap, this changes BOTH of them. Not always what you want." 59202 59203 self replaceColor: aColor with: Color transparent. 59204! ! 59205 59206!ColorForm methodsFor: 'color manipulation' stamp: 'ar 5/28/2000 12:06'! 59207twoToneFromDisplay: aRectangle backgroundColor: bgColor 59208 "Copy one-bit deep ColorForm from the Display using a color map that maps all colors except the background color to black. Used for caching the contents of inactive MVC windows." 59209 59210 | map | 59211 (width = aRectangle width and: [height = aRectangle height]) 59212 ifFalse: [self setExtent: aRectangle extent depth: depth]. 59213 59214 "make a color map mapping the background color 59215 to zero and all other colors to one" 59216 map := Bitmap new: (1 bitShift: (Display depth min: 9)). 59217 1 to: map size do: [:i | map at: i put: 16rFFFFFFFF]. 59218 map at: (bgColor indexInMap: map) put: 0. 59219 59220 (BitBlt current toForm: self) 59221 destOrigin: 0@0; 59222 sourceForm: Display; 59223 sourceRect: aRectangle; 59224 combinationRule: Form over; 59225 colorMap: map; 59226 copyBits. 59227! ! 59228 59229 59230!ColorForm methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:44'! 59231colormapIfNeededFor: destForm 59232 | newMap color pv | 59233 (self hasNonStandardPalette or:[destForm hasNonStandardPalette]) ifFalse:[ 59234 ^self colormapIfNeededForDepth: destForm depth. 59235 ]. 59236 colors == nil ifTrue: [ 59237 "use the standard colormap" 59238 ^ super colormapIfNeededFor: destForm]. 59239 59240 (destForm depth = cachedDepth and:[cachedColormap isColormap]) 59241 ifTrue: [^ cachedColormap]. 59242 newMap := WordArray new: (1 bitShift: self depth). 59243 1 to: colors size do: [:i | 59244 color := colors at: i. 59245 pv := destForm pixelValueFor: color. 59246 (pv = 0 and:[color isTransparent not]) ifTrue:[pv := 1]. 59247 newMap at: i put: pv]. 59248 59249 cachedDepth := destForm depth. 59250 ^cachedColormap := ColorMap shifts: nil masks: nil colors: newMap.! ! 59251 59252 59253!ColorForm methodsFor: 'copying' stamp: 'RAA 8/14/2000 10:45'! 59254asCursorForm 59255 59256 ^ (self asFormOfDepth: 32) offset: offset; as: StaticForm! ! 59257 59258!ColorForm methodsFor: 'copying' stamp: 'ar 10/24/2005 22:25'! 59259blankCopyOf: aRectangle scaledBy: scale 59260 ^Form extent: (aRectangle extent * scale) truncated depth: 32! ! 59261 59262!ColorForm methodsFor: 'copying' stamp: 'ar 5/28/2000 12:06'! 59263copy: aRect 59264 "Return a new ColorForm containing the portion of the receiver delineated by aRect." 59265 59266 | newForm | 59267 newForm := self class extent: aRect extent depth: depth. 59268 ((BitBlt current 59269 destForm: newForm 59270 sourceForm: self 59271 fillColor: nil 59272 combinationRule: Form over 59273 destOrigin: 0@0 59274 sourceOrigin: aRect origin 59275 extent: aRect extent 59276 clipRect: newForm boundingBox) 59277 colorMap: nil) copyBits. 59278 colors ifNotNil: [newForm colors: colors copy]. 59279 ^ newForm 59280! ! 59281 59282!ColorForm methodsFor: 'copying' stamp: 'jm 2/27/98 09:38'! 59283deepCopy 59284 59285 ^ self shallowCopy 59286 bits: bits copy; 59287 offset: offset copy; 59288 colors: colors 59289! ! 59290 59291 59292!ColorForm methodsFor: 'displaying' stamp: 'di 7/17/97 10:04'! 59293displayOnPort: port at: location 59294 59295 port copyForm: self to: location rule: Form paint! ! 59296 59297!ColorForm methodsFor: 'displaying' stamp: 'ar 12/14/2001 18:14'! 59298maskingMap 59299 "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero." 59300 | maskingMap | 59301 maskingMap := Bitmap new: (1 bitShift: depth) withAll: 16rFFFFFFFF. 59302 1 to: colors size do:[:i| 59303 (colors at: i) isTransparent ifTrue:[maskingMap at: i put: 0]. 59304 ]. 59305 colors size+1 to: maskingMap size do:[:i| maskingMap at: i put: 0]. 59306 ^maskingMap! ! 59307 59308 59309!ColorForm methodsFor: 'filein/out' stamp: 'ar 3/3/2001 20:07'! 59310hibernate 59311 "Make myself take up less space. See comment in Form>hibernate." 59312 59313 super hibernate. 59314 self clearColormapCache. 59315 colors ifNotNil:[colors := colors asColorArray].! ! 59316 59317!ColorForm methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:46'! 59318readAttributesFrom: aBinaryStream 59319 super readAttributesFrom: aBinaryStream. 59320 colors := ColorArray new: (2 raisedTo: depth). 59321 1 to: colors size do: [:idx | 59322 colors basicAt: idx put: (aBinaryStream nextLittleEndianNumber: 4). 59323 ]. 59324 ! ! 59325 59326!ColorForm methodsFor: 'filein/out' stamp: 'bf 5/25/2000 16:31'! 59327storeOn: aStream 59328 aStream nextPut: $(. 59329 super storeOn: aStream. 59330 aStream 59331 cr; tab; 59332 nextPutAll: 'colorsFromArray: #('. 59333 self colors do: [:color | 59334 color storeArrayOn: aStream]. 59335 aStream nextPutAll: ' ))'.! ! 59336 59337!ColorForm methodsFor: 'filein/out' stamp: 'ar 3/3/2001 20:07'! 59338unhibernate 59339 colors ifNotNil:[colors := colors asArray]. 59340 ^super unhibernate. 59341! ! 59342 59343!ColorForm methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:42'! 59344writeAttributesOn: file 59345 | colorArray | 59346 super writeAttributesOn: file. 59347 colorArray := self colors asColorArray. 59348 1 to: (2 raisedTo: depth) do: [:idx | 59349 file nextLittleEndianNumber: 4 put: (colorArray basicAt: idx). 59350 ] ! ! 59351 59352 59353!ColorForm methodsFor: 'pixel accessing' stamp: 'jm 11/14/97 17:25'! 59354colorAt: aPoint 59355 "Return the color of the pixel at aPoint." 59356 59357 ^ self colors at: (self pixelValueAt: aPoint) + 1 59358! ! 59359 59360!ColorForm methodsFor: 'pixel accessing' stamp: 'jm 11/14/97 17:25'! 59361colorAt: aPoint put: aColor 59362 "Store the given color into the pixel at aPoint. The given color must match one of the colors in the receiver's colormap." 59363 59364 | i | 59365 i := self colors indexOf: aColor 59366 ifAbsent: [^ self error: 'trying to use a color that is not in my colormap']. 59367 self pixelValueAt: aPoint put: i - 1. 59368! ! 59369 59370!ColorForm methodsFor: 'pixel accessing' stamp: 'tk 10/21/97 12:27'! 59371isTransparentAt: aPoint 59372 "Return true if the receiver is transparent at the given point." 59373 59374 ^ (self colorAt: aPoint) isTransparent 59375! ! 59376 59377!ColorForm methodsFor: 'pixel accessing' stamp: 'ar 5/28/2000 12:06'! 59378pixelValueAt: aPoint 59379 "Return the raw pixel value at the given point. Typical clients use colorAt: to get a Color." 59380 "Details: To get the raw pixel value, be sure the peeker's colorMap is nil." 59381 59382 ^ (BitBlt current bitPeekerFromForm: self) colorMap: nil; pixelAt: aPoint 59383! ! 59384 59385 59386!ColorForm methodsFor: 'postscript generation'! 59387asFormWithSingleTransparentColors 59388 | transparentIndexes | 59389 transparentIndexes := self transparentColorIndexes. 59390 transparentIndexes size <= 1 ifTrue:[^self] 59391 ifFalse:[^self mapTransparencies:transparentIndexes].! ! 59392 59393!ColorForm methodsFor: 'postscript generation'! 59394decodeArray 59395 ^self depth = 1 ifTrue:['[1 0]'] ifFalse:['[0 255]'].! ! 59396 59397!ColorForm methodsFor: 'postscript generation'! 59398getTransparencyUnificationLUT 59399 | lut transparentIndex | 59400 lut := Array new:colors size. 59401 transparentIndex := self indexOfColor:Color transparent. 59402 1 to: colors size do: 59403 [ :i | lut at:i put:(((colors at:i) = Color transparent) ifTrue:[transparentIndex] ifFalse:[i])]. 59404 ! ! 59405 59406!ColorForm methodsFor: 'postscript generation'! 59407mapTransparencies:transparentIndexes 59408 ^self deepCopy mapColors:transparentIndexes to:(transparentIndexes at:1).! ! 59409 59410!ColorForm methodsFor: 'postscript generation'! 59411setColorspaceOn:aStream 59412 self depth = 1 ifTrue:[ 59413 aStream print:'/DeviceRGB setcolorspace 0 setgray'; cr. 59414 ] 59415 ifFalse:[ 59416 aStream print:'[ /Indexed /DeviceRGB '; 59417 write:self colors size-1; 59418 print:' <'. 59419 (self colormapIfNeededForDepth: 32 ) storeBits:20 to:0 on:aStream. 59420 aStream print:'> ] setcolorspace'; cr.]. 59421! ! 59422 59423!ColorForm methodsFor: 'postscript generation'! 59424transparentColorIndexes 59425 ^(1 to: colors size) select: [ :index | (colors at:index) isTransparent ]. 59426! ! 59427 59428 59429!ColorForm methodsFor: 'scaling, rotation' stamp: 'ar 3/15/1999 14:28'! 59430flipBy: direction centerAt: aPoint 59431 | oldColors newForm | 59432 oldColors := colors. 59433 self colors: nil. 59434 newForm := super flipBy: direction centerAt: aPoint. 59435 self colors: oldColors. 59436 newForm colors: oldColors. 59437 ^newForm ! ! 59438 59439!ColorForm methodsFor: 'scaling, rotation' stamp: 'RAA 8/5/2000 18:12'! 59440scaledToSize: newExtent 59441 59442 "super method did not seem to work so well on ColorForms" 59443 59444 ^(self asFormOfDepth: 16) scaledToSize: newExtent! ! 59445 59446 59447!ColorForm methodsFor: 'testing' stamp: 'ar 5/27/2001 16:34'! 59448isColorForm 59449 ^true! ! 59450 59451!ColorForm methodsFor: 'testing' stamp: 'ar 2/10/2004 17:18'! 59452isTranslucent 59453 "Answer whether this form may be translucent" 59454 ^true! ! 59455 59456 59457!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 09:07'! 59458clearColormapCache 59459 59460 cachedDepth := nil. 59461 cachedColormap := nil. 59462! ! 59463 59464!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 09:12'! 59465depth: bitsPerPixel 59466 59467 bitsPerPixel > 8 ifTrue: [self error: 'ColorForms only support depths up to 8 bits']. 59468 super depth: bitsPerPixel. 59469! ! 59470 59471!ColorForm methodsFor: 'private' stamp: 'ar 5/17/2001 15:44'! 59472ensureColorArrayExists 59473 "Return my color palette." 59474 59475 colors ifNil: [ 59476 self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. 59477 self colors: (Color indexedColors copyFrom: 1 to: (1 bitShift: self depth))]. 59478! ! 59479 59480!ColorForm methodsFor: 'private' stamp: 'jm 4/5/1999 10:11'! 59481setColors: colorArray cachedColormap: aBitmap depth: anInteger 59482 "Semi-private. Set the color array, cached colormap, and cached colormap depth to avoid having to recompute the colormap when switching color palettes in animations." 59483 59484 colors := colorArray. 59485 cachedDepth := anInteger. 59486 cachedColormap := aBitmap. 59487! ! 59488 59489!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 08:37'! 59490setExtent: extent depth: bitsPerPixel 59491 "Create a virtual bit map with the given extent and bitsPerPixel." 59492 59493 bitsPerPixel > 8 ifTrue: [self error: 'ColorForms only support depths up to 8 bits']. 59494 super setExtent: extent depth: bitsPerPixel. 59495! ! 59496 59497!ColorForm methodsFor: 'private' stamp: 'jm 2/24/98 18:53'! 59498unusedColormapEntry 59499 "Return the index of an unused color map entry, or zero if there isn't one." 59500 59501 | tallies | 59502 tallies := self tallyPixelValues. 59503 1 to: tallies size do: [:i | 59504 (tallies at: i) = 0 ifTrue: [^ i]]. 59505 ^ 0 59506! ! 59507 59508"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 59509 59510ColorForm class 59511 instanceVariableNames: ''! 59512 59513!ColorForm class methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 8/19/2009 23:24'! 59514extent: extentPoint depth: bitsPerPixel 59515 "Answer an instance of me with blank bitmap of the given dimensions and depth max 8." 59516 59517 ^ bitsPerPixel > 8 59518 ifTrue: [ self basicNew setExtent: extentPoint depth: 8] 59519 ifFalse: [ self basicNew setExtent: extentPoint depth: bitsPerPixel] 59520! ! 59521 59522!ColorForm class methodsFor: 'as yet unclassified' stamp: 'nk 4/17/2004 19:44'! 59523mappingWhiteToTransparentFrom: aFormOrCursor 59524 "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." 59525 59526 | f map | 59527 aFormOrCursor depth <= 8 ifFalse: [ 59528 ^ self error: 'argument depth must be 8-bits per pixel or less']. 59529 (aFormOrCursor isColorForm) ifTrue: [ 59530 f := aFormOrCursor deepCopy. 59531 map := aFormOrCursor colors. 59532 ] ifFalse: [ 59533 f := ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. 59534 f copyBits: aFormOrCursor boundingBox 59535 from: aFormOrCursor 59536 at: 0@0 59537 clippingBox: aFormOrCursor boundingBox 59538 rule: Form over 59539 fillColor: nil. 59540 map := Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. 59541 map := map collect: [:c | 59542 c = Color white ifTrue: [Color transparent] ifFalse: [c]]. 59543 f colors: map. 59544 ^ f 59545! ! 59546 59547!ColorForm class methodsFor: 'as yet unclassified'! 59548twoToneFromDisplay: aRectangle using: oldForm backgroundColor: bgColor 59549 "Return a 1-bit deep ColorForm copied from the given rectangle of the display. All colors except the background color will be mapped to black." 59550 59551 | f | 59552 ((oldForm ~~ nil) and: [oldForm extent = aRectangle extent]) ifTrue: [ 59553 f := oldForm fromDisplay: aRectangle. 59554 ] ifFalse: [ 59555 f := ColorForm extent: aRectangle extent depth: 1. 59556 f twoToneFromDisplay: aRectangle backgroundColor: bgColor. 59557 f colors: (Array 59558 with: bgColor 59559 with: Color black)]. 59560 ^ f 59561! ! 59562Object subclass: #ColorMap 59563 instanceVariableNames: 'shifts masks colors' 59564 classVariableNames: '' 59565 poolDictionaries: '' 59566 category: 'Graphics-Primitives'! 59567 59568!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:54'! 59569alphaMask 59570 ^masks at: 4! ! 59571 59572!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:55'! 59573alphaMask: value 59574 masks at: 4 put: value! ! 59575 59576!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! 59577alphaShift 59578 ^shifts at: 4! ! 59579 59580!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! 59581alphaShift: value 59582 shifts at: 4 put: value! ! 59583 59584!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:39'! 59585at: index 59586 ^colors at: index! ! 59587 59588!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:39'! 59589at: index put: value 59590 ^colors at: index put: value! ! 59591 59592!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! 59593blueMask 59594 ^masks at: 3! ! 59595 59596!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! 59597blueMask: value 59598 masks at: 3 put: value! ! 59599 59600!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! 59601blueShift 59602 ^shifts at: 3! ! 59603 59604!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! 59605blueShift: value 59606 shifts at: 3 put: value! ! 59607 59608!ColorMap methodsFor: 'accessing' stamp: 'ar 2/10/2000 17:12'! 59609colors 59610 ^colors! ! 59611 59612!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! 59613greenMask 59614 ^masks at: 2! ! 59615 59616!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! 59617greenMask: value 59618 masks at: 2 put: value! ! 59619 59620!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! 59621greenShift 59622 ^shifts at: 2! ! 59623 59624!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:36'! 59625greenShift: value 59626 shifts at: 2 put: value.! ! 59627 59628!ColorMap methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 00:57'! 59629inverseMap 59630 "Return the inverse map of the receiver" 59631 | newMasks newShifts | 59632 colors ifNotNil: [ ^ self error: 'Not yet implemented' ]. 59633 newMasks := (Array new: 4) writeStream. 59634 newShifts := (Array new: 4) writeStream. 59635 masks 59636 with: shifts 59637 do: 59638 [ :mask :shift | 59639 newMasks nextPut: (mask bitShift: shift). 59640 newShifts nextPut: shift negated ]. 59641 ^ ColorMap 59642 shifts: newShifts contents 59643 masks: newMasks contents! ! 59644 59645!ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 19:16'! 59646masks 59647 ^masks! ! 59648 59649!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:36'! 59650redMask 59651 ^masks at: 1! ! 59652 59653!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'! 59654redMask: value 59655 masks at: 1 put: value! ! 59656 59657!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'! 59658redShift 59659 ^shifts at: 1! ! 59660 59661!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'! 59662redShift: value 59663 shifts at: 1 put: value! ! 59664 59665!ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 20:48'! 59666rgbaBitMasks 59667 "Return the rgba bit masks for the receiver" 59668 ^masks asArray with: shifts collect:[:m :s| m bitShift: s]! ! 59669 59670!ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 19:16'! 59671shifts 59672 ^shifts! ! 59673 59674 59675!ColorMap methodsFor: 'comparing' stamp: 'tk 7/5/2001 21:59'! 59676= aColorMap 59677 "Return true if the receiver is equal to aColorMap" 59678 self species == aColorMap species ifFalse:[^false]. 59679 self isIndexed == aColorMap isIndexed ifFalse:[^false]. 59680 ^self colors = aColorMap colors and:[ 59681 self shifts = aColorMap shifts and:[ 59682 self masks = aColorMap masks]]! ! 59683 59684!ColorMap methodsFor: 'comparing' stamp: 'ar 5/27/2000 19:29'! 59685hash 59686 "Hash is re-implemented because #= is re-implemented" 59687 ^colors hash bitXor: (shifts hash bitXor: masks hash)! ! 59688 59689 59690!ColorMap methodsFor: 'pixel mapping' stamp: 'lr 7/4/2009 10:42'! 59691mapPixel: pixelValue 59692 "Perform a forward pixel mapping operation" 59693 | pv | 59694 (shifts == nil and: [ masks == nil ]) 59695 ifFalse: 59696 [ pv := (((pixelValue bitAnd: self redMask) bitShift: self redShift) bitOr: ((pixelValue bitAnd: self greenMask) bitShift: self greenShift)) bitOr: (((pixelValue bitAnd: self blueMask) bitShift: self blueShift) bitOr: ((pixelValue bitAnd: self alphaMask) bitShift: self alphaShift)) ] 59697 ifTrue: [ pv := pixelValue ]. 59698 colors ifNotNil: [ pv := colors at: pv ]. 59699 "Need to check for translucency else Form>>paint goes gaga" 59700 pv = 0 ifTrue: [ pixelValue = 0 ifFalse: [ pv := 1 ] ]. 59701 ^ pv! ! 59702 59703!ColorMap methodsFor: 'pixel mapping' stamp: 'lr 7/4/2009 10:42'! 59704mappingTo: aColorMap 59705 "Compute a new color map through the receiver and aColorMap. 59706 Both maps are assumed to be mappings into canonical ARGB space" 59707 | fixedMap | 59708 self = aColorMap ifTrue: [ ^ nil ]. "No mapping needed" 59709 aColorMap isIndexed ifTrue: [ ^ nil ]. "We can't compute mappings to an indexed map yet" 59710 fixedMap := self class 59711 mappingFrom: self rgbaBitMasks 59712 to: aColorMap rgbaBitMasks. 59713 self isIndexed ifFalse: [ ^ fixedMap ]. 59714 "If the receiver is indexed then we need to map the colors as well" 59715 self flag: #untested. 59716 ^ ColorMap 59717 shifts: fixedMap shifts 59718 masks: fixedMap masks 59719 colors: (colors collect: [ :pv | aColorMap pixelMap: pv ])! ! 59720 59721!ColorMap methodsFor: 'pixel mapping' stamp: 'lr 7/4/2009 10:42'! 59722pixelMap: pixelValue 59723 "Perform a reverse pixel mapping operation" 59724 | pv | 59725 colors == nil 59726 ifTrue: [ pv := pixelValue ] 59727 ifFalse: [ pv := colors at: pixelValue ]. 59728 (shifts == nil and: [ masks == nil ]) ifFalse: 59729 [ pv := (((pv bitAnd: self redMask) bitShift: self redShift) bitOr: ((pv bitAnd: self greenMask) bitShift: self greenShift)) bitOr: (((pv bitAnd: self blueMask) bitShift: self blueShift) bitOr: ((pv bitAnd: self alphaMask) bitShift: self alphaShift)) ]. 59730 "Need to check for translucency else Form>>paint goes gaga" 59731 pv = 0 ifTrue: [ pixelValue = 0 ifFalse: [ pv := 1 ] ]. 59732 ^ pv! ! 59733 59734 59735!ColorMap methodsFor: 'testing' stamp: 'ar 5/25/2000 19:41'! 59736isColormap 59737 ^true! ! 59738 59739!ColorMap methodsFor: 'testing' stamp: 'ar 5/27/2000 19:06'! 59740isFixed 59741 "Return true if the receiver does not use a lookup mechanism for pixel mapping" 59742 ^self isIndexed not! ! 59743 59744!ColorMap methodsFor: 'testing' stamp: 'ar 5/27/2000 19:06'! 59745isIndexed 59746 "Return true if the receiver uses a lookup mechanism for pixel mapping" 59747 ^colors notNil! ! 59748 59749 59750!ColorMap methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 59751setShifts: shiftArray masks: maskArray colors: colorArray 59752 shiftArray ifNotNil: [ shifts := shiftArray asIntegerArray ]. 59753 maskArray ifNotNil: [ masks := maskArray asWordArray ]. 59754 colorArray ifNotNil: [ colors := colorArray asWordArray ]! ! 59755 59756"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 59757 59758ColorMap class 59759 instanceVariableNames: ''! 59760 59761!ColorMap class methodsFor: 'instance creation' stamp: 'ar 2/22/2000 14:08'! 59762colors: colorArray 59763 ^self new setShifts: nil masks: nil colors: colorArray! ! 59764 59765!ColorMap class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 59766mapBitsFrom: srcBitMask to: dstBitMask 59767 "Return an array consisting of the shift and the mask for 59768 mapping component values out of srcBitMask and into dstBitMask. 59769 While this computation is somewhat complicated it eases the batch 59770 conversion of all the pixels in BitBlt." 59771 | srcBits dstBits srcLow srcHigh dstLow dstHigh bits mask shift | 59772 (srcBitMask = 0 or: [ dstBitMask = 0 ]) ifTrue: 59773 [ ^ #(0 0 ) ]. "Zero mask and shift" 59774 "Compute low and high bit position for source and dest bit mask" 59775 srcLow := srcBitMask lowBit - 1. 59776 srcHigh := srcBitMask highBit. 59777 dstLow := dstBitMask lowBit - 1. 59778 dstHigh := dstBitMask highBit. 59779 "Compute the number of bits in source and dest bit mask" 59780 srcBits := srcHigh - srcLow. 59781 dstBits := dstHigh - dstLow. 59782 "Compute the maximum number of bits we can transfer inbetween" 59783 bits := srcBits min: dstBits. 59784 "Compute the (unshifted) transfer mask" 59785 mask := (1 bitShift: bits) - 1. 59786 "Shift the transfer mask to the mask the highest n bits of srcBitMask" 59787 mask := mask bitShift: srcHigh - bits. 59788 "Compute the delta shift so that the most significant bit of the 59789 source bit mask falls on the most significant bit of the dest bit mask. 59790 Note that delta is used for #bitShift: so 59791 shift > 0 : shift right 59792 shift < 0 : shift left 59793 e.g., if dstHigh > srcHigh we need to shift left and if dstHigh < srcHigh 59794 we need to shift right. This leads to:" 59795 shift := dstHigh - srcHigh. 59796 "And that's all we need" 59797 ^ Array 59798 with: shift 59799 with: mask! ! 59800 59801!ColorMap class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 59802mappingFrom: srcBitMasks to: dstBitMasks 59803 "Return a color map mapping from the array of source bit masks 59804 to the array of dest bit masks." 59805 | shifts masks shiftAndMask | 59806 shifts := IntegerArray new: 4. 59807 masks := WordArray new: 4. 59808 1 59809 to: 4 59810 do: 59811 [ :i | 59812 shiftAndMask := self 59813 mapBitsFrom: (srcBitMasks at: i) 59814 to: (dstBitMasks at: i). 59815 shifts 59816 at: i 59817 put: (shiftAndMask at: 1). 59818 masks 59819 at: i 59820 put: (shiftAndMask at: 2) ]. 59821 ^ self 59822 shifts: shifts 59823 masks: masks! ! 59824 59825!ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 20:08'! 59826mappingFromARGB: dstBitMasks 59827 "Return a ColorMap mapping from canonical ARGB space into dstBitMasks" 59828 ^self mappingFrom: #(16rFF0000 16rFF00 16rFF 16rFF000000) to: dstBitMasks! ! 59829 59830!ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 20:08'! 59831mappingToARGB: srcBitMasks 59832 "Return a ColorMap mapping from srcBitMasks into canonical ARGB space" 59833 ^self mappingFrom: srcBitMasks to: #(16rFF0000 16rFF00 16rFF 16rFF000000)! ! 59834 59835!ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/4/2001 15:59'! 59836masks: maskArray shifts: shiftArray 59837 ^self shifts: shiftArray masks: maskArray colors: nil.! ! 59838 59839!ColorMap class methodsFor: 'instance creation' stamp: 'ar 1/16/2000 16:02'! 59840shifts: shiftArray masks: maskArray 59841 ^self shifts: shiftArray masks: maskArray colors: nil.! ! 59842 59843!ColorMap class methodsFor: 'instance creation' stamp: 'ar 1/16/2000 16:02'! 59844shifts: shiftArray masks: maskArray colors: colorArray 59845 ^self new setShifts: shiftArray masks: maskArray colors: colorArray! ! 59846Canvas subclass: #ColorMappingCanvas 59847 instanceVariableNames: 'myCanvas' 59848 classVariableNames: '' 59849 poolDictionaries: '' 59850 category: 'Morphic-Support'! 59851 59852!ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:40'! 59853clipRect 59854 ^myCanvas clipRect! ! 59855 59856!ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'! 59857depth 59858 ^myCanvas depth! ! 59859 59860!ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'! 59861extent 59862 ^myCanvas extent! ! 59863 59864!ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/24/1999 17:54'! 59865form 59866 ^myCanvas form! ! 59867 59868!ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'! 59869origin 59870 ^myCanvas origin! ! 59871 59872 59873!ColorMappingCanvas methodsFor: 'drawing' stamp: 'ar 6/22/1999 18:15'! 59874line: pt1 to: pt2 width: w color: c 59875 "Draw a line using the given width and color" 59876 myCanvas 59877 line: pt1 59878 to: pt2 59879 width: w 59880 color: (self mapColor: c).! ! 59881 59882!ColorMappingCanvas methodsFor: 'drawing' stamp: 'ar 6/22/1999 18:16'! 59883paragraph: paragraph bounds: bounds color: c 59884 "Draw the given paragraph" 59885 myCanvas 59886 paragraph: paragraph 59887 bounds: bounds 59888 color: (self mapColor: c)! ! 59889 59890 59891!ColorMappingCanvas methodsFor: 'drawing-images' stamp: 'ar 6/24/1999 18:26'! 59892stencil: aForm at: aPoint color: aColor 59893 myCanvas 59894 stencil: aForm 59895 at: aPoint 59896 color: (self mapColor: aColor)! ! 59897 59898!ColorMappingCanvas methodsFor: 'drawing-images' stamp: 'ar 6/24/1999 18:26'! 59899stencil: aForm at: aPoint sourceRect: aRect color: aColor 59900 myCanvas 59901 stencil: aForm 59902 at: aPoint 59903 sourceRect: aRect 59904 color: (self mapColor: aColor)! ! 59905 59906 59907!ColorMappingCanvas methodsFor: 'drawing-ovals' stamp: 'ar 6/22/1999 17:59'! 59908fillOval: r color: c borderWidth: borderWidth borderColor: borderColor 59909 "Fill the given oval." 59910 myCanvas 59911 fillOval: r 59912 color: (self mapColor: c) 59913 borderWidth: borderWidth 59914 borderColor: (self mapColor: borderColor)! ! 59915 59916 59917!ColorMappingCanvas methodsFor: 'drawing-polygons' stamp: 'mir 9/12/2001 14:24'! 59918drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc 59919 "Draw the given polygon." 59920 ^myCanvas 59921 drawPolygon: vertices 59922 color: aColor 59923 borderWidth: bw 59924 borderColor: (self mapColor: bc)! ! 59925 59926 59927!ColorMappingCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/22/1999 17:59'! 59928frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor 59929 "Draw the rectangle using the given attributes" 59930 myCanvas 59931 frameAndFillRectangle: r 59932 fillColor: (self mapColor: fillColor) 59933 borderWidth: borderWidth 59934 borderColor: (self mapColor: borderColor)! ! 59935 59936!ColorMappingCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/22/1999 18:01'! 59937frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor 59938 "Draw the rectangle using the given attributes" 59939 myCanvas 59940 frameAndFillRectangle: r 59941 fillColor: (self mapColor: fillColor) 59942 borderWidth: borderWidth 59943 topLeftColor: (self mapColor: topLeftColor) 59944 bottomRightColor: (self mapColor: bottomRightColor)! ! 59945 59946 59947!ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:19'! 59948clipBy: aRectangle during: aBlock 59949 "Set a clipping rectangle active only during the execution of aBlock. 59950 Note: In the future we may want to have more general clip shapes - not just rectangles" 59951 | oldCanvas | 59952 oldCanvas := myCanvas. 59953 myCanvas clipBy: aRectangle during:[:newCanvas| 59954 myCanvas := newCanvas. 59955 aBlock value: self]. 59956 myCanvas := oldCanvas! ! 59957 59958!ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:19'! 59959preserveStateDuring: aBlock 59960 "Preserve the full canvas state during the execution of aBlock" 59961 | oldCanvas | 59962 oldCanvas := myCanvas. 59963 myCanvas preserveStateDuring:[:newCanvas| 59964 myCanvas := newCanvas. 59965 aBlock value: self]. 59966 myCanvas := oldCanvas.! ! 59967 59968!ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'di 10/16/1999 16:01'! 59969transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize 59970 59971 "Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')." 59972 | oldCanvas | 59973 oldCanvas := myCanvas. 59974 myCanvas transformBy: aDisplayTransform 59975 clippingTo: aClipRect 59976 during: [:newCanvas | 59977 myCanvas := newCanvas. 59978 aBlock value: self] 59979 smoothing: cellSize. 59980 myCanvas := oldCanvas.! ! 59981 59982!ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:22'! 59983translateBy: delta during: aBlock 59984 "Set a translation only during the execution of aBlock." 59985 | oldCanvas | 59986 oldCanvas := myCanvas. 59987 myCanvas translateBy: delta during:[:newCanvas| 59988 myCanvas := newCanvas. 59989 aBlock value: self]. 59990 myCanvas := oldCanvas.! ! 59991 59992!ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:22'! 59993translateTo: newOrigin clippingTo: aRectangle during: aBlock 59994 "Set a new origin and clipping rectangle only during the execution of aBlock." 59995 | oldCanvas | 59996 oldCanvas := myCanvas. 59997 myCanvas translateTo: newOrigin clippingTo: aRectangle during:[:newCanvas| 59998 myCanvas := newCanvas. 59999 aBlock value: self]. 60000 myCanvas := oldCanvas.! ! 60001 60002 60003!ColorMappingCanvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:28'! 60004drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c 60005 "Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used." 60006 myCanvas 60007 drawString: s from: firstIndex to: lastIndex 60008 in: boundsRect 60009 font: fontOrNil 60010 color: (self mapColor: c)! ! 60011 60012!ColorMappingCanvas methodsFor: 'drawing-text' stamp: 'tween 3/10/2009 07:45'! 60013drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc 60014 "Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used." 60015 myCanvas 60016 drawString: s 60017 from: firstIndex 60018 to: lastIndex 60019 in: boundsRect 60020 font: fontOrNil 60021 color: (self mapColor: c) 60022 underline: underline 60023 underlineColor: (self mapColor: uc) 60024 strikethrough: strikethrough 60025 strikethroughColor: (self mapColor: sc)! ! 60026 60027 60028!ColorMappingCanvas methodsFor: 'initialization' stamp: 'ar 6/22/1999 18:24'! 60029flush 60030 myCanvas flush.! ! 60031 60032!ColorMappingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:14'! 60033on: aCanvas 60034 myCanvas := aCanvas.! ! 60035 60036!ColorMappingCanvas methodsFor: 'initialization' stamp: 'ar 6/22/1999 18:23'! 60037reset 60038 myCanvas reset.! ! 60039 60040 60041!ColorMappingCanvas methodsFor: 'other' stamp: 'ar 6/22/1999 18:21'! 60042translateBy: delta clippingTo: aRectangle during: aBlock 60043 "Set a translation and clipping rectangle only during the execution of aBlock." 60044 | oldCanvas | 60045 oldCanvas := myCanvas. 60046 myCanvas translateBy: delta clippingTo: aRectangle during:[:newCanvas| 60047 myCanvas := newCanvas. 60048 aBlock value: self]. 60049 myCanvas := oldCanvas.! ! 60050 60051 60052!ColorMappingCanvas methodsFor: 'testing' stamp: 'ar 8/8/2001 14:16'! 60053isShadowDrawing 60054 ^myCanvas isShadowDrawing! ! 60055 60056 60057!ColorMappingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:15'! 60058image: aForm at: aPoint sourceRect: sourceRect rule: rule 60059 "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle." 60060 ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: rule.! ! 60061 60062!ColorMappingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:15'! 60063mapColor: aColor 60064 ^aColor! ! 60065 60066"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 60067 60068ColorMappingCanvas class 60069 instanceVariableNames: ''! 60070 60071!ColorMappingCanvas class methodsFor: 'instance creation' stamp: 'ar 6/22/1999 18:23'! 60072on: aCanvas 60073 ^self new on: aCanvas! ! 60074FormCanvas subclass: #ColorPatchCanvas 60075 instanceVariableNames: 'stopMorph foundMorph doStop' 60076 classVariableNames: '' 60077 poolDictionaries: '' 60078 category: 'Morphic-Support'! 60079!ColorPatchCanvas commentStamp: '<historical>' prior: 0! 60080I generate patches of Morphic worlds that views below certain Morphs. This facility is used for the end-user scripting system.! 60081 60082 60083!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:15'! 60084doStop 60085 ^doStop! ! 60086 60087!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:15'! 60088doStop: aBoolean 60089 doStop := aBoolean! ! 60090 60091!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:15'! 60092foundMorph 60093 ^foundMorph! ! 60094 60095!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:38'! 60096foundMorph: aBoolean 60097 foundMorph := aBoolean! ! 60098 60099!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:14'! 60100stopMorph 60101 ^stopMorph! ! 60102 60103!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:14'! 60104stopMorph: aMorph 60105 stopMorph := aMorph! ! 60106 60107 60108!ColorPatchCanvas methodsFor: 'drawing-general' stamp: 'ar 6/22/1999 16:14'! 60109fullDrawMorph: aMorph 60110 (foundMorph and:[doStop]) ifTrue:[^self]. "Found it and should stop" 60111 aMorph == stopMorph ifTrue:[ 60112 "Never draw the stopMorph" 60113 foundMorph := true. 60114 ^self]. 60115 ^super fullDrawMorph: aMorph.! ! 60116 60117 60118!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 16:34'! 60119clipBy: aRectangle during: aBlock 60120 "Set a clipping rectangle active only during the execution of aBlock. 60121 Note: In the future we may want to have more general clip shapes - not just rectangles" 60122 | tempCanvas | 60123 tempCanvas := (self copyClipRect: aRectangle). 60124 aBlock value: tempCanvas. 60125 foundMorph := tempCanvas foundMorph.! ! 60126 60127!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 16:42'! 60128preserveStateDuring: aBlock 60129 "Preserve the full canvas state during the execution of aBlock. 60130 Note: This does *not* include the state in the receiver (e.g., foundMorph)." 60131 | tempCanvas | 60132 tempCanvas := self copy. 60133 aBlock value: tempCanvas. 60134 foundMorph := tempCanvas foundMorph.! ! 60135 60136!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 2/17/2000 00:15'! 60137transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize 60138 "Note: This method has been originally copied from TransformationMorph." 60139 | innerRect patchRect sourceQuad warp start subCanvas | 60140 (aDisplayTransform isPureTranslation) ifTrue:[ 60141 subCanvas := self copyOffset: aDisplayTransform offset negated truncated 60142 clipRect: aClipRect. 60143 aBlock value: subCanvas. 60144 foundMorph := subCanvas foundMorph. 60145 ^self 60146 ]. 60147 "Prepare an appropriate warp from patch to innerRect" 60148 innerRect := aClipRect. 60149 patchRect := aDisplayTransform globalBoundsToLocal: 60150 (self clipRect intersect: innerRect). 60151 sourceQuad := (aDisplayTransform sourceQuadFor: innerRect) 60152 collect: [:p | p - patchRect topLeft]. 60153 warp := self warpFrom: sourceQuad toRect: innerRect. 60154 warp cellSize: cellSize. 60155 60156 "Render the submorphs visible in the clipping rectangle, as patchForm" 60157 start := (self depth = 1 and: [self isShadowDrawing not]) 60158 "If this is true B&W, then we need a first pass for erasure." 60159 ifTrue: [1] ifFalse: [2]. 60160 start to: 2 do: 60161 [:i | "If i=1 we first make a shadow and erase it for opaque whites in B&W" 60162 subCanvas := ColorPatchCanvas extent: patchRect extent depth: self depth. 60163 subCanvas stopMorph: stopMorph. 60164 subCanvas foundMorph: foundMorph. 60165 subCanvas doStop: doStop. 60166 i=1 ifTrue: [subCanvas shadowColor: Color black. 60167 warp combinationRule: Form erase] 60168 ifFalse: [self isShadowDrawing ifTrue: 60169 [subCanvas shadowColor: self shadowColor]. 60170 warp combinationRule: Form paint]. 60171 subCanvas translateBy: patchRect topLeft negated 60172 during:[:offsetCanvas| aBlock value: offsetCanvas]. 60173 i = 2 ifTrue:[foundMorph := subCanvas foundMorph]. 60174 warp sourceForm: subCanvas form; warpBits. 60175 warp sourceForm: nil. subCanvas := nil "release space for next loop"] 60176! ! 60177 60178!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 16:39'! 60179translateBy: delta during: aBlock 60180 "Set a translation only during the execution of aBlock." 60181 | tempCanvas | 60182 tempCanvas := self copyOffset: delta. 60183 aBlock value: tempCanvas. 60184 foundMorph := tempCanvas foundMorph.! ! 60185 60186!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 16:40'! 60187translateTo: newOrigin clippingTo: aRectangle during: aBlock 60188 "Set a new origin and clipping rectangle only during the execution of aBlock." 60189 | tempCanvas | 60190 tempCanvas := self copyOrigin: newOrigin clipRect: aRectangle. 60191 aBlock value: tempCanvas. 60192 foundMorph := tempCanvas foundMorph.! ! 60193 60194 60195!ColorPatchCanvas methodsFor: 'initialization' stamp: 'ar 6/22/1999 16:18'! 60196reset 60197 "Initialize the receiver to act just as a FormCanvas" 60198 super reset. 60199 foundMorph := false. 60200 doStop := false. 60201 stopMorph := nil.! ! 60202 60203 60204!ColorPatchCanvas methodsFor: 'other' stamp: 'ar 6/22/1999 16:39'! 60205translateBy: delta clippingTo: aRectangle during: aBlock 60206 "Set a translation and clipping rectangle only during the execution of aBlock." 60207 | tempCanvas | 60208 tempCanvas := self copyOffset: delta clipRect: aRectangle. 60209 aBlock value: tempCanvas. 60210 foundMorph := tempCanvas foundMorph.! ! 60211 60212 60213!ColorPatchCanvas methodsFor: 'private' stamp: 'ar 6/22/1999 16:18'! 60214setForm: aForm 60215 "Initialize the receiver to act just as a FormCanvas" 60216 super setForm: aForm. 60217 stopMorph := nil. 60218 doStop := false. 60219 foundMorph := false.! ! 60220SketchMorph subclass: #ColorPickerMorph 60221 instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously target selector argument originalColor theSelectorDisplayMorph isModal clickedTranslucency' 60222 classVariableNames: 'ColorChart DragBox FeedbackBox RevertBox TransText TransparentBox' 60223 poolDictionaries: '' 60224 category: 'Morphic-Widgets'! 60225!ColorPickerMorph commentStamp: 'kfr 10/27/2003 16:16' prior: 0! 60226A gui for setting color and transparency. Behaviour can be changed with the Preference modalColorPickers.! 60227 60228 60229!ColorPickerMorph methodsFor: 'accessing' stamp: 'ar 6/25/1999 11:33'! 60230argument 60231 ^argument! ! 60232 60233!ColorPickerMorph methodsFor: 'accessing' stamp: 'ar 6/25/1999 11:33'! 60234argument: anObject 60235 argument := anObject! ! 60236 60237!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! 60238deleteOnMouseUp 60239 60240 ^ deleteOnMouseUp 60241! ! 60242 60243!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! 60244deleteOnMouseUp: aBoolean 60245 60246 deleteOnMouseUp := aBoolean. 60247! ! 60248 60249!ColorPickerMorph methodsFor: 'accessing' stamp: 'ar 8/25/2001 20:44'! 60250locationIndicator 60251 | loc | 60252 ^self valueOfProperty: #locationIndicator ifAbsent:[ 60253 loc := EllipseMorph new. 60254 loc color: Color transparent; 60255 borderWidth: 1; 60256 borderColor: Color red; 60257 extent: 6@6. 60258 self setProperty: #locationIndicator toValue: loc. 60259 self addMorphFront: loc. 60260 loc]! ! 60261 60262!ColorPickerMorph methodsFor: 'accessing' stamp: 'KR 12/9/2005 22:51'! 60263originalColor: colorOrSymbol 60264 "Set the receiver's original color. It is at this point that a command is launched to represent the action of the picker, in support of Undo." 60265 60266 originalColor := (colorOrSymbol isColor) 60267 ifTrue: [colorOrSymbol] 60268 ifFalse: [Color lightGreen]. 60269 originalForm fill: RevertBox fillColor: originalColor. 60270 selectedColor := originalColor. 60271 self updateAlpha: originalColor alpha. 60272 self locationIndicator 60273 center: self topLeft + (self positionOfColor: originalColor)! ! 60274 60275!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! 60276selectedColor 60277 60278 ^ selectedColor 60279! ! 60280 60281!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! 60282selector 60283 60284 ^ selector 60285! ! 60286 60287!ColorPickerMorph methodsFor: 'accessing' stamp: 'di 8/30/2000 13:40'! 60288selector: aSymbol 60289 "Set the selector to be associated with the receiver. Store it in the receiver's command, if appropriate" 60290 60291 selector := aSymbol. 60292 self updateSelectorDisplay! ! 60293 60294!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! 60295sourceHand 60296 60297 ^ sourceHand 60298! ! 60299 60300!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! 60301sourceHand: aHand 60302 60303 sourceHand := aHand. 60304! ! 60305 60306!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'! 60307target 60308 60309 ^ target 60310! ! 60311 60312!ColorPickerMorph methodsFor: 'accessing' stamp: 'aoy 2/15/2003 21:24'! 60313target: anObject 60314 target := anObject. 60315 selectedColor := (target respondsTo: #color) 60316 ifTrue: [target color] 60317 ifFalse: [Color white]! ! 60318 60319!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! 60320updateContinuously 60321 60322 ^ updateContinuously 60323! ! 60324 60325!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! 60326updateContinuously: aBoolean 60327 60328 updateContinuously := aBoolean. 60329! ! 60330 60331 60332!ColorPickerMorph methodsFor: 'drawing' stamp: 'di 9/3/1999 13:34'! 60333drawOn: aCanvas 60334 aCanvas depth = 1 ifTrue: [aCanvas fillRectangle: self bounds color: Color white]. 60335 Display depth = originalForm depth ifFalse: [self buildChartForm]. 60336 super drawOn: aCanvas! ! 60337 60338 60339!ColorPickerMorph methodsFor: 'event handling' stamp: 'jm 11/4/97 07:15'! 60340handlesMouseDown: evt 60341 60342 ^ true 60343! ! 60344 60345!ColorPickerMorph methodsFor: 'event handling' stamp: 'RAA 2/19/2001 13:16'! 60346inhibitDragging 60347 60348 ^self hasProperty: #noDraggingThisPicker! ! 60349 60350!ColorPickerMorph methodsFor: 'event handling' stamp: 'RAA 2/19/2001 13:17'! 60351mouseDown: evt 60352 | localPt | 60353 localPt := evt cursorPoint - self topLeft. 60354 self deleteAllBalloons. 60355 clickedTranslucency := TransparentBox containsPoint: localPt. 60356 self inhibitDragging ifFalse: [ 60357 (DragBox containsPoint: localPt) 60358 ifTrue: [^ evt hand grabMorph: self]. 60359 ]. 60360 (RevertBox containsPoint: localPt) 60361 ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor]. 60362 self inhibitDragging ifFalse: [self comeToFront]. 60363 sourceHand := evt hand. 60364 self startStepping. 60365! ! 60366 60367!ColorPickerMorph methodsFor: 'event handling' stamp: 'stephane.ducasse 11/5/2008 21:51'! 60368mouseUp: evt 60369 60370 self stopStepping. 60371 sourceHand := nil. 60372 deleteOnMouseUp ifTrue: [self delete]. 60373 self updateTargetColor. 60374! ! 60375 60376 60377!ColorPickerMorph methodsFor: 'geometry testing' stamp: 'LC 2/2/2000 04:28'! 60378containsPoint: aPoint 60379 ^ (super containsPoint: aPoint) 60380 or: [RevertBox containsPoint: aPoint - self topLeft]! ! 60381 60382 60383!ColorPickerMorph methodsFor: 'halos and balloon help' stamp: 'sw 7/6/1999 09:07'! 60384isLikelyRecipientForMouseOverHalos 60385 ^ false! ! 60386 60387 60388!ColorPickerMorph methodsFor: 'initialization' stamp: 'di 9/28/2000 12:05'! 60389buildChartForm 60390 | chartForm | 60391 chartForm := ColorChart deepCopy asFormOfDepth: Display depth. 60392 chartForm fill: ((TransparentBox left + 9)@0 extent: 1@9) fillColor: Color lightGray. 60393 chartForm fill: ((TransparentBox right - 10)@0 extent: 1@9) fillColor: Color lightGray. 60394 TransText displayOn: chartForm at: 62@0. 60395 Display depth = 32 ifTrue: 60396 ["Set opaque bits for 32-bit display" 60397 chartForm fill: chartForm boundingBox rule: Form under 60398 fillColor: (Color r: 0.0 g: 0.0 b: 0.0 alpha: 1.0)]. 60399 chartForm borderWidth: 1. 60400 self form: chartForm. 60401 selectedColor ifNotNil: [self updateAlpha: selectedColor alpha]. 60402 self updateSelectorDisplay. 60403 60404! ! 60405 60406!ColorPickerMorph methodsFor: 'initialization' stamp: 'sw 9/8/2000 18:14'! 60407choseModalityFromPreference 60408 "Decide whether to be modal or not by consulting the prevailing preference" 60409 60410 self initializeModal: Preferences modalColorPickers! ! 60411 60412!ColorPickerMorph methodsFor: 'initialization' stamp: 'ar 9/4/2001 13:26'! 60413initialize 60414 "Initialize the receiver. Obey the modalColorPickers preference when deciding how to configure myself. This is not quite satisfactory -- we'd like to have explicit calls tell us things like whether whether to be modal, whether to allow transparency, but for the moment, in grand Morphic fashion, this is rather inflexibly all housed right here" 60415 60416 super initialize. 60417 self clipSubmorphs: true. 60418 self buildChartForm. 60419 60420 selectedColor := Color white. 60421 sourceHand := nil. 60422 deleteOnMouseUp := false. 60423 clickedTranslucency := false. 60424 updateContinuously := true. 60425 selector := nil. 60426 target := nil! ! 60427 60428!ColorPickerMorph methodsFor: 'initialization' stamp: 'yo 2/23/2005 17:17'! 60429initializeForPropertiesPanel 60430 "Initialize the receiver. If beModal is true, it will be a modal color picker, else not" 60431 60432 isModal := false. 60433 self removeAllMorphs. 60434 self setProperty: #noDraggingThisPicker toValue: true. 60435 60436 self addMorph: ((Morph newBounds: (RevertBox translateBy: self topLeft)) 60437 color: Color transparent; setCenteredBalloonText: 'restore original color' translated). 60438 self addMorph: ((Morph newBounds: (FeedbackBox translateBy: self topLeft)) 60439 color: Color transparent; setCenteredBalloonText: 'shows selected color' translated). 60440 self addMorph: ((Morph newBounds: (TransparentBox translateBy: self topLeft)) 60441 color: Color transparent; setCenteredBalloonText: 'adjust translucency' translated). 60442 60443 self buildChartForm. 60444 60445 selectedColor ifNil: [selectedColor := Color white]. 60446 sourceHand := nil. 60447 deleteOnMouseUp := false. 60448 updateContinuously := true. 60449! ! 60450 60451!ColorPickerMorph methodsFor: 'initialization' stamp: 'yo 2/23/2005 17:13'! 60452initializeModal: beModal 60453 "Initialize the receiver. If beModal is true, it will be a modal color picker, else not" 60454 60455 isModal := beModal. 60456 self removeAllMorphs. 60457 isModal ifFalse: 60458 [theSelectorDisplayMorph := AlignmentMorph newRow 60459 color: Color white; 60460 borderWidth: 1; 60461 borderColor: Color red; 60462 hResizing: #shrinkWrap; 60463 vResizing: #shrinkWrap; 60464 addMorph: (StringMorph contents: 'theSelector' translated). 60465 self addMorph: theSelectorDisplayMorph. 60466 60467 self addMorph: (SimpleButtonMorph new borderWidth: 0; 60468 label: 'x' font: nil; color: Color transparent; 60469 actionSelector: #delete; target: self; useSquareCorners; 60470 position: self topLeft - (0@3); extent: 10@12; 60471 setCenteredBalloonText: 'dismiss color picker' translated)]. 60472 60473 self addMorph: ((Morph newBounds: (DragBox translateBy: self topLeft)) 60474 color: Color transparent; setCenteredBalloonText: 'put me somewhere' translated). 60475 self addMorph: ((Morph newBounds: (RevertBox translateBy: self topLeft)) 60476 color: Color transparent; setCenteredBalloonText: 'restore original color' translated). 60477 self addMorph: ((Morph newBounds: (FeedbackBox translateBy: self topLeft)) 60478 color: Color transparent; setCenteredBalloonText: 'shows selected color' translated). 60479 self addMorph: ((Morph newBounds: (TransparentBox translateBy: self topLeft)) 60480 color: Color transparent; setCenteredBalloonText: 'adjust translucency' translated). 60481 60482 self buildChartForm. 60483 60484 selectedColor ifNil: [selectedColor := Color white]. 60485 sourceHand := nil. 60486 deleteOnMouseUp := false. 60487 updateContinuously := true. 60488! ! 60489 60490!ColorPickerMorph methodsFor: 'initialization' stamp: 'sma 4/22/2000 19:39'! 60491updateSelectorDisplay 60492 theSelectorDisplayMorph ifNil: [^self]. 60493 theSelectorDisplayMorph position: self bottomLeft. 60494 theSelectorDisplayMorph firstSubmorph contents: selector asString , ' ' , selectedColor printString! ! 60495 60496 60497!ColorPickerMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:17'! 60498addCustomMenuItems: aCustomMenu hand: aHandMorph 60499 60500 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 60501 deleteOnMouseUp 60502 ifTrue: [aCustomMenu add: 'stay up' translated action: #toggleDeleteOnMouseUp] 60503 ifFalse: [aCustomMenu add: 'do not stay up' translated action: #toggleDeleteOnMouseUp]. 60504 updateContinuously 60505 ifTrue: [aCustomMenu add: 'update only at end' translated action: #toggleUpdateContinuously] 60506 ifFalse: [aCustomMenu add: 'update continuously' translated action: #toggleUpdateContinuously]. 60507! ! 60508 60509!ColorPickerMorph methodsFor: 'menu' stamp: 'michael.rueger 4/15/2009 14:01'! 60510pickUpColorFor: aMorph 60511 "Show the eyedropper cursor, and modally track the mouse through a mouse-down and mouse-up cycle" 60512 60513 | aHand localPt | 60514 aHand := aMorph ifNil: [self activeHand] ifNotNil: [aMorph activeHand]. 60515 aHand ifNil: [aHand := self currentHand]. 60516 self addToWorld: aHand world near: (aMorph ifNil: [aHand world]) fullBounds. 60517 self owner ifNil: [^ self]. 60518 60519 aHand showTemporaryCursor: (ScriptingSystem formAtKey: #Eyedropper) 60520 hotSpotOffset: 6 negated @ 4 negated. "<<<< the form was changed a bit??" 60521 60522 self updateContinuously: false. 60523 [Sensor anyButtonPressed] 60524 whileFalse: 60525 [self trackColorUnderMouse]. 60526 self deleteAllBalloons. 60527 60528 localPt := Sensor cursorPoint - self topLeft. 60529 self inhibitDragging ifFalse: [ 60530 (DragBox containsPoint: localPt) ifTrue: 60531 ["Click or drag the drag-dot means to anchor as a modeless picker" 60532 ^ self anchorAndRunModeless: aHand]. 60533 ]. 60534 (clickedTranslucency := TransparentBox containsPoint: localPt) 60535 ifTrue: [selectedColor := originalColor]. 60536 60537 self updateContinuously: true. 60538 [Sensor anyButtonPressed] 60539 whileTrue: 60540 [self updateTargetColorWith: self indicateColorUnderMouse]. 60541 aHand 60542 newMouseFocus: nil; 60543 showTemporaryCursor: nil. 60544 self delete. 60545 60546 ! ! 60547 60548!ColorPickerMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'! 60549toggleDeleteOnMouseUp 60550 60551 deleteOnMouseUp := deleteOnMouseUp not. 60552! ! 60553 60554!ColorPickerMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'! 60555toggleUpdateContinuously 60556 60557 updateContinuously := updateContinuously not. 60558! ! 60559 60560 60561!ColorPickerMorph methodsFor: 'other' stamp: 'di 11/27/1999 09:12'! 60562addToWorld: world near: box 60563 | goodLocation | 60564 goodLocation := self bestPositionNear: box inWorld: world. 60565 world allMorphsDo: 60566 [:p | (p isMemberOf: ColorPickerMorph) ifTrue: 60567 [(p ~~ self and: [p owner notNil and: [p target == target]]) ifTrue: 60568 [(p selector == selector and: [p argument == argument]) 60569 ifTrue: [^ p comeToFront "uncover existing picker"] 60570 ifFalse: ["place second picker relative to first" 60571 goodLocation := self bestPositionNear: p bounds inWorld: world]]]]. 60572 self position: goodLocation. 60573 world addMorphFront: self. 60574 self changed 60575! ! 60576 60577!ColorPickerMorph methodsFor: 'other' stamp: 'di 11/27/1999 08:51'! 60578bestPositionNear: box inWorld: world 60579 | points b | 60580 points := #(topCenter rightCenter bottomCenter leftCenter). "possible anchors" 60581 1 to: 4 do: 60582 [:i | "Try the four obvious anchor points" 60583 b := self bounds align: (self bounds perform: (points at: i)) 60584 with: (box perform: (points atWrap: i + 2)). 60585 (world viewBox containsRect: b) ifTrue: 60586 [^ b topLeft" Yes, it fits"]]. 60587 60588 ^ 20@20 "when all else fails" 60589! ! 60590 60591!ColorPickerMorph methodsFor: 'other' stamp: 'di 9/25/2000 15:38'! 60592indicateColorUnderMouse 60593 "Track the mouse with the special eyedropper cursor, and accept whatever color is under the mouse as the currently-chosen color; reflect that choice in the feedback box, and return that color." 60594 60595 | pt | 60596 self pickColorAt: (pt := Sensor cursorPoint). 60597 isModal ifTrue: 60598 [self activeHand position: pt. 60599 self world displayWorldSafely; runStepMethods]. 60600 ^ selectedColor ! ! 60601 60602!ColorPickerMorph methodsFor: 'other' stamp: 'ar 12/8/2000 15:32'! 60603putUpFor: aMorph near: aRectangle 60604 "Put the receiver up on the screen. Note highly variant behavior depending on the setting of the #modalColorPickers preference" 60605 | layerNumber | 60606 aMorph isMorph ifTrue: [ 60607 layerNumber := aMorph morphicLayerNumber. 60608 aMorph allOwnersDo:[:m| 60609 layerNumber := layerNumber min: m morphicLayerNumber]. 60610 self setProperty: #morphicLayerNumber toValue: layerNumber - 0.1 60611 ]. 60612 60613 isModal == true "backward compatibility" 60614 ifTrue: 60615 [self pickUpColorFor: aMorph] 60616 ifFalse: 60617 [self addToWorld: 60618 ((aMorph notNil and: [aMorph world notNil]) 60619 ifTrue: 60620 [aMorph world] 60621 ifFalse: 60622 [self currentWorld]) 60623 near: 60624 (aRectangle ifNil: 60625 [aMorph ifNil: [100@100 extent: 1@1] ifNotNil: [aMorph fullBoundsInWorld]])]! ! 60626 60627!ColorPickerMorph methodsFor: 'other' stamp: 'di 9/27/2000 11:48'! 60628trackColorUnderMouse 60629 "Track the mouse with the special eyedropper cursor, and accept whatever color is under the mouse as the currently-chosen color; reflect that choice in the feedback box, and return that color." 60630 60631 | pt | 60632 selectedColor := originalColor. 60633 self trackColorAt: (pt := Sensor cursorPoint). 60634 isModal ifTrue: 60635 [self activeHand position: pt. 60636 self world displayWorldSafely; runStepMethods. 60637 self modalBalloonHelpAtPoint: pt]. 60638 ^ selectedColor ! ! 60639 60640 60641!ColorPickerMorph methodsFor: 'stepping and presenter' stamp: 'jm 11/4/97 07:15'! 60642step 60643 60644 sourceHand ifNotNil: 60645 [self pickColorAt: sourceHand position]. 60646! ! 60647 60648 60649!ColorPickerMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 4/17/2004 19:34'! 60650delete 60651 "The moment of departure has come. 60652 If the receiver has an affiliated command, finalize it and have the system remember it. 60653 In any case, delete the receiver" 60654 60655 (selector isNil or: [ target isNil ]) ifFalse: [ 60656 self rememberCommand: 60657 (Command new 60658 cmdWording: 'color change' translated; 60659 undoTarget: target selector: selector arguments: (self argumentsWith: originalColor); 60660 redoTarget: target selector: selector arguments: (self argumentsWith: selectedColor)). 60661 ]. 60662 super delete! ! 60663 60664 60665!ColorPickerMorph methodsFor: 'testing' stamp: 'jm 11/4/97 07:15'! 60666stepTime 60667 60668 ^ 50 60669! ! 60670 60671 60672!ColorPickerMorph methodsFor: 'private' stamp: 'mir 11/19/2008 12:47'! 60673anchorAndRunModeless: aHand 60674 "If user clicks on the drag-dot of a modal picker, 60675 anchor it, and change to modeless operation." 60676 60677 aHand showTemporaryCursor: nil. "revert to normal cursor" 60678 self initializeModal: false; originalColor: originalColor. "reset as modeless" 60679 aHand position: Sensor cursorPoint; grabMorph: self. "Slip into drag operation" 60680! ! 60681 60682!ColorPickerMorph methodsFor: 'private' stamp: 'ar 7/19/2003 20:40'! 60683argumentsWith: aColor 60684 "Return an argument array appropriate to this action selector" 60685 60686 | nArgs | 60687 nArgs := selector ifNil:[0] ifNotNil:[selector numArgs]. 60688 nArgs = 0 ifTrue:[^#()]. 60689 nArgs = 1 ifTrue:[^ {aColor}]. 60690 nArgs = 2 ifTrue:[^ {aColor. sourceHand}]. 60691 nArgs = 3 ifTrue:[^ {aColor. argument. sourceHand}]. 60692! ! 60693 60694!ColorPickerMorph methodsFor: 'private' stamp: 'di 9/27/2000 12:55'! 60695deleteAllBalloons 60696 60697 self submorphsDo: [:m | m deleteBalloon]. 60698! ! 60699 60700!ColorPickerMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 22:59'! 60701modalBalloonHelpAtPoint: cursorPoint 60702 self flag: #arNote. "Throw this away. There needs to be another way." 60703 self submorphsDo: 60704 [:m | 60705 m wantsBalloon 60706 ifTrue: 60707 [(m valueOfProperty: #balloon) isNil 60708 ifTrue: 60709 [(m containsPoint: cursorPoint) ifTrue: [m showBalloon: m balloonText]] 60710 ifFalse: [(m containsPoint: cursorPoint) ifFalse: [m deleteBalloon]]]]! ! 60711 60712!ColorPickerMorph methodsFor: 'private' stamp: 'stephane.ducasse 11/5/2008 21:50'! 60713pickColorAt: aGlobalPoint 60714 60715 | alpha selfRelativePoint pickedColor | 60716 clickedTranslucency ifNil: [clickedTranslucency := false]. 60717 selfRelativePoint := (self globalPointToLocal: aGlobalPoint) - self topLeft. 60718 (FeedbackBox containsPoint: selfRelativePoint) ifTrue: [^ self]. 60719 (RevertBox containsPoint: selfRelativePoint) 60720 ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor]. 60721 60722 "check for transparent color and update using appropriate feedback color " 60723 (TransparentBox containsPoint: selfRelativePoint) ifTrue: 60724 [clickedTranslucency ifFalse: [^ self]. "Can't wander into translucency control" 60725 alpha := (selfRelativePoint x - TransparentBox left - 10) asFloat / 60726 (TransparentBox width - 20) 60727 min: 1.0 max: 0.0. 60728 "(alpha roundTo: 0.01) printString , ' ' displayAt: 0@0." " -- debug" 60729 self 60730 updateColor: (selectedColor alpha: alpha) 60731 feedbackColor: (selectedColor alpha: alpha). 60732 ^ self]. 60733 60734 "pick up color, either inside or outside this world" 60735 clickedTranslucency ifTrue: [^ self]. "Can't wander out of translucency control" 60736 self locationIndicator visible: false. self refreshWorld. 60737 pickedColor := Display colorAt: aGlobalPoint. 60738 self locationIndicator visible: true. self refreshWorld. 60739 self 60740 updateColor: ( 60741 (selectedColor isColor and: [selectedColor isTranslucentColor]) 60742 ifTrue: [pickedColor alpha: selectedColor alpha] 60743 ifFalse: [pickedColor] 60744 ) 60745 feedbackColor: pickedColor! ! 60746 60747!ColorPickerMorph methodsFor: 'private' stamp: 'ar 9/4/2001 13:27'! 60748positionOfColor: aColor 60749 "Compute the position of the given color in the color chart form" 60750 | rgbRect x y h s v | 60751 rgbRect := (0@0 extent: originalForm boundingBox extent) insetBy: (1@10 corner: 11@1). 60752 h := aColor hue. 60753 s := aColor saturation. 60754 v := aColor brightness. 60755 h = 0.0 ifTrue:["gray" 60756 ^(rgbRect right + 6) @ (rgbRect height * (1.0 - v) + rgbRect top)]. 60757 x := (h + 22 \\ 360 / 360.0 * rgbRect width) rounded. 60758 y := 0.5. 60759 s < 1.0 ifTrue:[y := y - (1.0 - s * 0.5)]. 60760 v < 1.0 ifTrue:[y := y + (1.0 - v * 0.5)]. 60761 y := (y * rgbRect height) rounded. 60762 ^x@y + (1@10)! ! 60763 60764!ColorPickerMorph methodsFor: 'private' stamp: 'di 9/30/2000 10:07'! 60765trackColorAt: aGlobalPoint 60766 "Before the mouse comes down in a modal color picker, track the color under the cursor, and show it in the feedback box, but do not make transparency changes" 60767 60768 | selfRelativePoint pickedColor | 60769 selfRelativePoint := (self globalPointToLocal: aGlobalPoint) - self topLeft. 60770 (FeedbackBox containsPoint: selfRelativePoint) ifTrue: [^ self]. 60771 (RevertBox containsPoint: selfRelativePoint) 60772 ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor]. 60773 60774 "check for transparent color and update using appropriate feedback color " 60775 (TransparentBox containsPoint: selfRelativePoint) ifTrue: [^ self]. 60776 60777 "pick up color, either inside or outside this world" 60778 pickedColor := Display colorAt: aGlobalPoint. 60779 self updateColor: (pickedColor alpha: originalColor alpha) 60780 feedbackColor: pickedColor! ! 60781 60782!ColorPickerMorph methodsFor: 'private' stamp: 'di 9/28/2000 11:10'! 60783updateAlpha: alpha 60784 | sliderRect | 60785 sliderRect := (TransparentBox left + 10)@1 corner: (TransparentBox right - 9)@9. 60786 originalForm fill: (sliderRect withRight: sliderRect left + (alpha*sliderRect width)) 60787 fillColor: Color lightGray. 60788 originalForm fillWhite: (sliderRect withLeft: sliderRect left + (alpha*sliderRect width)). 60789 originalForm fill: ((TransparentBox right - 9)@1 extent: 8@8) 60790 fillColor: (alpha < 1.0 ifTrue: [Color white] ifFalse: [Color lightGray]). 60791 TransText displayOn: originalForm at: 62@1 rule: Form paint. 60792! ! 60793 60794!ColorPickerMorph methodsFor: 'private' stamp: 'ar 8/25/2001 20:50'! 60795updateColor: aColor feedbackColor: feedbackColor 60796 "Set my selected color to the given color if it is different. Give user feedback. Inform the target of the change if the target and selector are not nil." 60797 60798 selectedColor = aColor ifTrue: [^ self]. "do nothing if color doesn't change" 60799 60800 self updateAlpha: aColor alpha. 60801 originalForm fill: FeedbackBox fillColor: feedbackColor. 60802 self form: originalForm. 60803 selectedColor := aColor. 60804 updateContinuously ifTrue: [self updateTargetColor]. 60805 self locationIndicator center: self topLeft + (self positionOfColor: feedbackColor).! ! 60806 60807!ColorPickerMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 18:41'! 60808updateTargetColor 60809 | nArgs | 60810 (target notNil and: [selector notNil]) 60811 ifTrue: 60812 [self updateSelectorDisplay. 60813 nArgs := selector numArgs. 60814 nArgs = 1 ifTrue: [^target perform: selector with: selectedColor]. 60815 nArgs = 2 60816 ifTrue: 60817 [^target 60818 perform: selector 60819 with: selectedColor 60820 with: sourceHand]. 60821 nArgs = 3 60822 ifTrue: 60823 [^target 60824 perform: selector 60825 with: selectedColor 60826 with: argument 60827 with: sourceHand]]! ! 60828 60829!ColorPickerMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 18:41'! 60830updateTargetColorWith: aColor 60831 "Update the target so that it reflects aColor as the color choice" 60832 60833 (target notNil and: [selector notNil]) 60834 ifTrue: 60835 [self updateSelectorDisplay. 60836 ^target perform: selector withArguments: (self argumentsWith: aColor)]! ! 60837 60838"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 60839 60840ColorPickerMorph class 60841 instanceVariableNames: ''! 60842 60843!ColorPickerMorph class methodsFor: 'as yet unclassified' stamp: 'sw 10/27/1999 11:40'! 60844perniciousBorderColor 60845 "Answer the color of the border lines of a color picker; this color gets reported as you drag the mouse through from the translucent box to the true color area, for example, and can cause some difficulties in some special cases, so it is faithfully reported here in this hard-coded fashion in order that energetic clients wishing to handle it as special-case it can do so." 60846 60847 ^ Color r: 0.0 g: 0.0 b: 0.032! ! 60848 60849 60850!ColorPickerMorph class methodsFor: 'initialization' stamp: 'ar 7/8/2006 20:32'! 60851colorPaletteForDepth: depth extent: chartExtent 60852 "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." 60853 "Note: It is slow to build this palette, so it should be cached for quick access." 60854 "(Color colorPaletteForDepth: 16 extent: 190@60) display" 60855 60856 | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | 60857 palette := Form extent: chartExtent depth: depth. 60858 transCaption := "(DisplayText text: 'no color' asText textStyle: (TextConstants at: #ComicPlain)) form storeString" 60859 (Form extent: 34@9 depth: 1 60860 fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) 60861 offset: 0@0). 60862 transHt := transCaption height. 60863 palette fillWhite: (0@0 extent: palette width@transHt). 60864 palette fillBlack: (0@transHt extent: palette width@1). 60865 transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). 60866 grayWidth := 10. 60867 startHue := 338.0. 60868 vSteps := palette height - transHt // 2. 60869 hSteps := palette width - grayWidth. 60870 x := 0. 60871 startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | 60872 basicHue := Color h: h asFloat s: 1.0 v: 1.0. 60873 y := transHt+1. 60874 0 to: vSteps do: [:n | 60875 c := basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. 60876 palette fill: (x@y extent: 1@1) fillColor: c. 60877 y := y + 1]. 60878 1 to: vSteps do: [:n | 60879 c := Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. 60880 palette fill: (x@y extent: 1@1) fillColor: c. 60881 y := y + 1]. 60882 x := x + 1]. 60883 y := transHt + 1. 60884 1 to: vSteps * 2 do: [:n | 60885 c := Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. 60886 palette fill: (x@y extent: 10@1) fillColor: c. 60887 y := y + 1]. 60888 ^ palette 60889! ! 60890 60891!ColorPickerMorph class methodsFor: 'initialization' stamp: 'ar 7/8/2006 20:33'! 60892initialize 60893 "ColorPickerMorph initialize" 60894 60895 ColorChart := ColorPickerMorph colorPaletteForDepth: 16 extent: 190@60. 60896 DragBox := (11@0) extent: 9@8. 60897 RevertBox := (ColorChart width - 20)@1 extent: 9@8. 60898 FeedbackBox := (ColorChart width - 10)@1 extent: 9@8. 60899 TransparentBox := DragBox topRight corner: RevertBox bottomLeft. 60900 60901 ColorChart fillBlack: ((DragBox left - 1)@0 extent: 1@9). 60902 ColorChart fillBlack: ((TransparentBox left)@0 extent: 1@9). 60903 ColorChart fillBlack: ((FeedbackBox left - 1)@0 extent: 1@9). 60904 ColorChart fillBlack: ((RevertBox left - 1)@0 extent: 1@9). 60905 (Form dotOfSize: 5) displayOn: ColorChart at: DragBox center + (0@1). 60906 60907 self localeChanged.! ! 60908 60909!ColorPickerMorph class methodsFor: 'initialization' stamp: 'tak 8/4/2005 14:26'! 60910localeChanged 60911 | formTranslator | 60912 formTranslator := NaturalLanguageFormTranslator localeID: Locale current localeID. 60913 TransText := formTranslator translate: 'translucent'. 60914 TransText 60915 ifNil: [TransText := Form 60916 extent: 63 @ 8 60917 depth: 1 60918 fromArray: #(4194306 1024 4194306 1024 15628058 2476592640 4887714 2485462016 1883804850 2486772764 4756618 2485462016 4748474 1939416064 0 0 ) 60919 offset: 0 @ 0]. 60920 TransText := ColorForm mappingWhiteToTransparentFrom: TransText! ! 60921 60922!ColorPickerMorph class methodsFor: 'initialization' stamp: 'ar 7/8/2006 20:33'! 60923noColorCaption 60924 | formTranslator | 60925 formTranslator := NaturalLanguageFormTranslator localeID: Locale current localeID. 60926 ^ (formTranslator translate: 'no color') 60927 ifNil: [Form 60928 extent: 34 @ 9 60929 depth: 1 60930 fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0 ) 60931 offset: 0 @ 0] 60932! ! 60933MorphicModel subclass: #ColorPresenterMorph 60934 instanceVariableNames: 'contentMorph labelMorph solidLabelMorph getColorSelector' 60935 classVariableNames: 'HatchForm' 60936 poolDictionaries: '' 60937 category: 'Polymorph-Widgets'! 60938!ColorPresenterMorph commentStamp: 'gvc 5/18/2007 13:38' prior: 0! 60939Displays a colour with alpha against a white, hatched and black background.! 60940 60941 60942!ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/22/2006 09:25'! 60943contentMorph 60944 "Answer the value of contentMorph" 60945 60946 ^ contentMorph! ! 60947 60948!ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/22/2006 09:25'! 60949contentMorph: anObject 60950 "Set the value of contentMorph" 60951 60952 contentMorph := anObject! ! 60953 60954!ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 15:48'! 60955getColorSelector 60956 "Answer the value of getColorSelector" 60957 60958 ^ getColorSelector! ! 60959 60960!ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 15:48'! 60961getColorSelector: anObject 60962 "Set the value of getColorSelector" 60963 60964 getColorSelector := anObject! ! 60965 60966!ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 15:48'! 60967labelMorph 60968 "Answer the value of labelMorph" 60969 60970 ^ labelMorph! ! 60971 60972!ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 15:48'! 60973labelMorph: anObject 60974 "Set the value of labelMorph" 60975 60976 labelMorph := anObject! ! 60977 60978!ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 16:17'! 60979solidLabelMorph 60980 "Answer the value of solidLabelMorph" 60981 60982 ^ solidLabelMorph! ! 60983 60984!ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 16:17'! 60985solidLabelMorph: anObject 60986 "Set the value of solidLabelMorph" 60987 60988 solidLabelMorph := anObject! ! 60989 60990 60991!ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 16:04'! 60992hatchForm 60993 "Answer a form showing a grid hatch pattern." 60994 60995 ^self class hatchForm! ! 60996 60997!ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:34'! 60998initialize 60999 "Initialize the receiver." 61000 61001 super initialize. 61002 self 61003 borderWidth: 0; 61004 changeTableLayout; 61005 labelMorph: self newLabelMorph; 61006 solidLabelMorph: self newLabelMorph; 61007 contentMorph: self newContentMorph; 61008 addMorphBack: self contentMorph! ! 61009 61010!ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:23'! 61011newContentMorph 61012 "Answer a new content morph" 61013 61014 ^Morph new 61015 color: Color transparent; 61016 changeTableLayout; 61017 borderStyle: (BorderStyle inset width: 1); 61018 vResizing: #spaceFill; 61019 hResizing: #spaceFill; 61020 addMorph: self newHatchMorph; 61021 yourself! ! 61022 61023!ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 19:40'! 61024newHatchMorph 61025 "Answer a new morph showing a grid hatch pattern." 61026 61027 ^Morph new 61028 color: Color transparent; 61029 changeProportionalLayout; 61030 vResizing: #spaceFill; 61031 hResizing: #spaceFill; 61032 minWidth: 48; 61033 minHeight: 12; 61034 addMorph: (Morph new color: Color white) 61035 fullFrame: (LayoutFrame fractions: (0@0 corner: 0.3@1)); 61036 addMorph: (Morph new fillStyle: (InfiniteForm with: self hatchForm)) 61037 fullFrame: (LayoutFrame fractions: (0.3@0 corner: 0.7@1)); 61038 addMorph: self solidLabelMorph 61039 fullFrame: (LayoutFrame fractions: (0.7@0 corner: 1@1)); 61040 addMorph: self labelMorph 61041 fullFrame: (LayoutFrame fractions: (0@0 corner: 1@1))! ! 61042 61043!ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 16:20'! 61044newLabelMorph 61045 "Answer a new label morph" 61046 61047 ^Morph new! ! 61048 61049!ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:45'! 61050on: anObject color: getColSel 61051 "Set the receiver to the given model parameterized by the given message selectors." 61052 61053 self 61054 model: anObject; 61055 getColorSelector: getColSel; 61056 updateColor! ! 61057 61058!ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/3/2009 18:14'! 61059setColor: aColor 61060 "Update the colour of the labels." 61061 61062 self labelMorph color: aColor. 61063 self solidLabelMorph color: aColor asNontranslucentColor! ! 61064 61065!ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:34'! 61066update: aSymbol 61067 "Refer to the comment in View|update:." 61068 61069 aSymbol == self getColorSelector ifTrue: 61070 [self updateColor. 61071 ^ self]! ! 61072 61073!ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 18:36'! 61074updateColor 61075 "Update the color state." 61076 61077 |col| 61078 self getColorSelector ifNotNil: [ 61079 col := (self model perform: self getColorSelector) ifNil: [Color transparent]. 61080 self setColor: col]! ! 61081 61082"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 61083 61084ColorPresenterMorph class 61085 instanceVariableNames: ''! 61086 61087!ColorPresenterMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 16:05'! 61088hatchForm 61089 "Answer a form showing a grid hatch pattern." 61090 61091 ^HatchForm ifNil: [HatchForm := self newHatchForm]! ! 61092 61093!ColorPresenterMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 16:24'! 61094newHatchForm 61095 "Answer a new hatch form." 61096 61097 ^(Form 61098 extent: 8@8 61099 depth: 1 61100 fromArray: #( 4026531840 4026531840 4026531840 4026531840 251658240 251658240 251658240 251658240) 61101 offset: 0@0)! ! 61102 61103!ColorPresenterMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:49'! 61104on: anObject color: getSel 61105 "Answer a new instance of the receiver on the given model using 61106 the given selectors as the interface." 61107 61108 ^self new 61109 on: anObject 61110 color: getSel! ! 61111DialogWindow subclass: #ColorSelectorDialogWindow 61112 instanceVariableNames: 'selectedColor hsvaMorph' 61113 classVariableNames: '' 61114 poolDictionaries: '' 61115 category: 'Polymorph-Widgets-Windows'! 61116!ColorSelectorDialogWindow commentStamp: 'gvc 5/18/2007 13:35' prior: 0! 61117Standard dialog for selecting a colour by HSVA colour selector, picking from the screen or editing of values.! 61118 61119 61120!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/22/2006 16:39'! 61121basicSelectedColor: anObject 61122 "Set the value of selectedColor" 61123 61124 selectedColor := anObject. 61125 self 61126 changed: #selectedColor; 61127 changed: #red; 61128 changed: #green; 61129 changed: #blue; 61130 changed: #hue; 61131 changed: #saturation; 61132 changed: #brightness; 61133 changed: #alpha! ! 61134 61135!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/22/2006 10:04'! 61136hsvaMorph 61137 "Answer the value of hsvaMorph" 61138 61139 ^ hsvaMorph! ! 61140 61141!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/22/2006 10:04'! 61142hsvaMorph: anObject 61143 "Set the value of hsvaMorph" 61144 61145 hsvaMorph := anObject! ! 61146 61147!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/22/2006 09:49'! 61148selectedColor 61149 "Answer the value of selectedColor" 61150 61151 ^ selectedColor! ! 61152 61153!ColorSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/22/2006 10:03'! 61154selectedColor: aColor 61155 "Set the value of selectedColor. Update the color selectors." 61156 61157 self basicSelectedColor: aColor. 61158 self hsvaMorph selectedColor: aColor! ! 61159 61160 61161!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:30'! 61162alpha 61163 "Answer the alpha value of the selected color." 61164 61165 ^(self selectedColor alpha * 255) asInteger! ! 61166 61167!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:21'! 61168alpha: anInteger 61169 "Set the alpha value of the selected color." 61170 61171 |c| 61172 c := self selectedColor. 61173 self selectedColor: (c alpha: anInteger / 255)! ! 61174 61175!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:30'! 61176blue 61177 "Answer the blue value of the selected color." 61178 61179 ^(self selectedColor blue * 255) asInteger! ! 61180 61181!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:14'! 61182blue: anInteger 61183 "Set the blue value of the selected color." 61184 61185 |c| 61186 c := self selectedColor. 61187 self selectedColor: ((Color r: c red * 255 g: c green * 255 b: anInteger range: 255) alpha: c alpha)! ! 61188 61189!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:38'! 61190brightness 61191 "Answer the brightness value of the selected color." 61192 61193 ^(self selectedColor brightness * 255) asInteger! ! 61194 61195!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:37'! 61196brightness: anInteger 61197 "Set the brightness value of the selected color." 61198 61199 |c| 61200 c := self selectedColor. 61201 self selectedColor: ((Color h: c hue s: c saturation v: anInteger / 255) alpha: c alpha)! ! 61202 61203!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 11:13'! 61204colorSelected: aColor 61205 "A color has been selected.." 61206 61207 self basicSelectedColor: aColor! ! 61208 61209!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 12:16'! 61210defaultLabel 61211 "Answer the default label for the receiver." 61212 61213 ^'Colour Selector' translated! ! 61214 61215!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:30'! 61216green 61217 "Answer the green value of the selected color." 61218 61219 ^(self selectedColor green * 255) asInteger! ! 61220 61221!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:14'! 61222green: anInteger 61223 "Set the green value of the selected color." 61224 61225 |c| 61226 c := self selectedColor. 61227 self selectedColor: ((Color r: c red * 255 g: anInteger b: c blue * 255 range: 255) alpha: c alpha)! ! 61228 61229!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:38'! 61230hue 61231 "Answer the hue value of the selected color." 61232 61233 ^(self selectedColor hue / 359 * 255) asInteger! ! 61234 61235!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:16'! 61236hue: anInteger 61237 "Set the hue value of the selected color." 61238 61239 |c| 61240 c := self selectedColor. 61241 self selectedColor: ((Color h: (anInteger / 255 * 359) rounded s: c saturation v: c brightness) alpha: c alpha)! ! 61242 61243!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 10:06'! 61244initialize 61245 "Initialize the receiver." 61246 61247 self 61248 basicSelectedColor: Color blue. 61249 super initialize. 61250 self selectedColor: self selectedColor! ! 61251 61252!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:11'! 61253newColorComponentFieldMorph: aspect 61254 "Answer a text entry for the specified aspect of the color." 61255 61256 ^(self 61257 newTextEntryFor: self 61258 get: aspect 61259 set: (aspect, ':') asSymbol 61260 class: Integer 61261 getEnabled: nil 61262 help: nil) 61263 acceptOnFocusChange: true; 61264 minWidth: 40! ! 61265 61266!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:04'! 61267newColorPickerButtonMorph 61268 "Answer a button to enable picking of colour." 61269 61270 ^self 61271 newButtonFor: self 61272 getState: nil 61273 action: #pickColor 61274 arguments: nil 61275 getEnabled: nil 61276 labelForm: ((ScriptingSystem formAtKey: #Eyedropper) 61277 scaledIntoFormOfSize: 16) 61278 help: 'Pick a colour from the screen' translated! ! 61279 61280!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 12:32'! 61281newColorPresenterMorph 61282 "Answer a color presenter." 61283 61284 ^self 61285 newColorPresenterFor: self 61286 getColor: #selectedColor 61287 help: 'Shows the selected colour' translated! ! 61288 61289!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 12:14'! 61290newContentMorph 61291 "Answer a new content morph." 61292 61293 self hsvaMorph: self newHSVAColorSelectorMorph. 61294 ^self newRow: { 61295 self newGroupbox: 'Colour' translated forAll: { 61296 self hsvaMorph. 61297 (self newRow: { 61298 (self newLabelGroup: { 61299 'Selected colour' translated -> self newColorPresenterMorph}) 61300 vResizing: #shrinkWrap. 61301 self newColorPickerButtonMorph}) 61302 cellPositioning: #leftCenter}. 61303 (self newGroupbox: 'Values' translated for: 61304 (self newLabelGroup: { 61305 'Red' translated -> (self newColorComponentFieldMorph: #red). 61306 'Green' translated -> (self newColorComponentFieldMorph: #green). 61307 'Blue' translated -> (self newColorComponentFieldMorph: #blue). 61308 'Hue' translated -> (self newColorComponentFieldMorph: #hue). 61309 'Saturation' translated -> (self newColorComponentFieldMorph: #saturation). 61310 'Brightness' translated -> (self newColorComponentFieldMorph: #brightness). 61311 'Alpha' translated -> (self newColorComponentFieldMorph: #alpha)})) 61312 hResizing: #shrinkWrap}! ! 61313 61314!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2006 13:11'! 61315newHSVAColorSelectorMorph 61316 "Answer a hsva color selector." 61317 61318 ^HSVAColorSelectorMorph new 61319 extent: (40@28) + 152; 61320 when: #selectedColor send: #colorSelected: to: self! ! 61321 61322!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/21/2009 18:25'! 61323pickColor 61324 "Pick a colour from the screen." 61325 61326 |p d c h| 61327 h := self world activeHand. 61328 d := Delay forMilliseconds: 20. 61329 h showTemporaryCursor: (ScriptingSystem formAtKey: #Eyedropper) 61330 hotSpotOffset: 6 negated @ 4 negated. 61331 [Sensor anyButtonPressed] whileFalse: 61332 [[Sensor nextEvent isNil] whileFalse. "Pharo compatability" 61333 p := Sensor cursorPoint. 61334 (self hsvaMorph containsPoint: p) 61335 ifFalse: ["deal with the fact that 32 bit displays may have garbage in the alpha bits" 61336 c := Display depth = 32 61337 ifTrue: [Color 61338 colorFromPixelValue: ((Display pixelValueAt: p) bitOr: 16rFF000000) 61339 depth: 32] 61340 ifFalse: [Display colorAt: p]]. 61341 self world activeHand position: p. 61342 self selectedColor ~= c ifTrue: [ 61343 self selectedColor: c]. 61344 self world displayWorldSafely. 61345 d wait]. 61346 h showTemporaryCursor: nil! ! 61347 61348!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:29'! 61349red 61350 "Answer the red value of the selected color." 61351 61352 ^(self selectedColor red * 255) asInteger! ! 61353 61354!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:14'! 61355red: anInteger 61356 "Set the red value of the selected color." 61357 61358 |c| 61359 c := self selectedColor. 61360 self selectedColor: ((Color r: anInteger g: c green * 255 b: c blue * 255 range: 255) alpha: c alpha)! ! 61361 61362!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:38'! 61363saturation 61364 "Answer the saturation value of the selected color." 61365 61366 ^(self selectedColor saturation * 255) asInteger! ! 61367 61368!ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:36'! 61369saturation: anInteger 61370 "Set the saturation value of the selected color." 61371 61372 |c| 61373 c := self selectedColor. 61374 self selectedColor: ((Color h: c hue s: anInteger / 255 v: c brightness) alpha: c alpha)! ! 61375ClassTestCase subclass: #ColorTest 61376 instanceVariableNames: '' 61377 classVariableNames: '' 61378 poolDictionaries: '' 61379 category: 'GraphicsTests-Primitives'! 61380 61381!ColorTest methodsFor: 'testing' stamp: 'dg 2/19/2008 13:19'! 61382testAsHTMLColor 61383 61384 | table aColorString | 61385 table := #('0' '1' '2' '3' '4' '5' '6' '7' '8' '9' 'A' 'B' 'C' 'D' 'E' 'F'). 61386 61387 table do: [ :each | 61388 aColorString := '#', each, each, '0000'. 61389 self assert: ((Color fromString: aColorString) asHTMLColor sameAs: aColorString)]. 61390 61391 table do: [ :each | 61392 aColorString := '#', '00', each, each, '00'. 61393 self assert: ((Color fromString: aColorString) asHTMLColor sameAs: aColorString)]. 61394 61395 table do: [ :each | 61396 aColorString := '#', '0000', each, each. 61397 self assert: ((Color fromString: aColorString) asHTMLColor sameAs: aColorString)]. 61398 61399 table do: [ :each | 61400 aColorString := '#', each, each, each, each, each, each. 61401 self assert: ((Color fromString: aColorString) asHTMLColor sameAs: aColorString)].! ! 61402 61403!ColorTest methodsFor: 'testing' stamp: 'dg 2/19/2008 12:43'! 61404testColorFrom 61405 self assert: ((Color colorFrom: #white) asHTMLColor sameAs: '#ffffff'). 61406 self assert: ((Color colorFrom: #(1.0 0.5 0.0)) asHTMLColor sameAs: '#ff8000'). 61407 self assert: ((Color colorFrom: (Color white)) asHTMLColor sameAs: '#ffffff'). 61408 self assert: ((Color colorFrom: '#FF8800') asHTMLColor sameAs: '#ff8800'). 61409 self assert: ((Color colorFrom: '#222222') asHTMLColor sameAs: '#222222').! ! 61410 61411!ColorTest methodsFor: 'testing' stamp: 'dg 2/19/2008 12:43'! 61412testFromString 61413 self assert: ((Color fromString: '#FF8800') asHTMLColor sameAs: '#ff8800').! ! 61414 61415!ColorTest methodsFor: 'testing' stamp: 'fbs 2/3/2005 13:13'! 61416testMultiplyByArray 61417 | newColor oldColor tolerance | 61418 tolerance := 0.001. 61419 61420 oldColor := Color r: 0.75 g: 0.5 b: 0.25. 61421 newColor := oldColor * #(0.1 2 3). 61422 61423 self assert: (0.075 - newColor red) abs < tolerance. 61424 self assert: (1 - newColor green) abs < tolerance. 61425 self assert: (0.75 - newColor blue) abs < tolerance.! ! 61426 61427!ColorTest methodsFor: 'testing' stamp: 'fbs 2/3/2005 12:57'! 61428testMultiplyByArrayIdentityTransform 61429 | newColor oldColor tolerance | 61430 tolerance := 0.001. 61431 61432 oldColor := Color r: 0.75 g: 0.5 b: 0.25. 61433 newColor := oldColor * 2. 61434 61435 self assert: (1 - newColor red) abs < tolerance. 61436 self assert: (1 - newColor green) abs < tolerance. 61437 self assert: (0.5 - newColor blue) abs < tolerance.! ! 61438 61439!ColorTest methodsFor: 'testing' stamp: 'fbs 2/3/2005 12:56'! 61440testMultiplyByNumber 61441 | newColor oldColor tolerance | 61442 tolerance := 0.001. 61443 61444 oldColor := Color r: 0.75 g: 0.5 b: 0.25. 61445 newColor := oldColor * 2. 61446 61447 self assert: (1 - newColor red) abs < tolerance. 61448 self assert: (1 - newColor green) abs < tolerance. 61449 self assert: (0.5 - newColor blue) abs < tolerance.! ! 61450 61451 61452!ColorTest methodsFor: 'tests' stamp: 'sd 6/16/2006 13:12'! 61453testPrintHtmlString 61454 "self debug: #testPrintHtmlString" 61455 61456 self shouldnt: [Color white printHtmlString ] raise: Error. 61457 self assert: Color white printHtmlString = 'FFFFFF'. 61458 self assert: Color red printHtmlString = 'FF0000'. 61459 self assert: Color black printHtmlString = '000000'.! ! 61460Object subclass: #ColorTheme 61461 instanceVariableNames: '' 61462 classVariableNames: '' 61463 poolDictionaries: '' 61464 category: 'System-Support'! 61465 61466!ColorTheme methodsFor: 'theme' stamp: 'marcus.denker 11/29/2008 22:55'! 61467baseColors 61468 ^ Array 61469 with: (Color fromArray: #(0.2 0.3 0.9 )) 61470 with: (Color fromArray: #(0.6 0.7 1.0 )) 61471 with: (Color fromArray: #(0.85 0.9 1.0 ))! ! 61472 61473!ColorTheme methodsFor: 'theme' stamp: 'dgd 11/2/2004 21:23'! 61474cancelColor 61475 ^ Color lightRed! ! 61476 61477!ColorTheme methodsFor: 'theme' stamp: 'marcus.denker 11/29/2008 22:57'! 61478helpColor 61479^ self okColor! ! 61480 61481!ColorTheme methodsFor: 'theme' stamp: 'marcus.denker 11/29/2008 23:06'! 61482normal: index 61483 ^ (self baseColors second wheel: 8) at: index! ! 61484 61485!ColorTheme methodsFor: 'theme' stamp: 'dgd 11/2/2004 21:22'! 61486okColor 61487 ^ Color lightGreen! ! 61488 61489 61490!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:27'! 61491dialog3DTitles 61492 ^ true! ! 61493 61494!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 19:56'! 61495dialogBorderColor 61496 ^ Color fromArray: #(0.355 0.516 1.0 )! ! 61497 61498!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 19:54'! 61499dialogBorderWidth 61500 ^ 4! ! 61501 61502!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 19:59'! 61503dialogButtonBorderWidth 61504 ^ 0! ! 61505 61506!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/2/2004 21:09'! 61507dialogColor 61508 ^ Color paleYellow! ! 61509 61510!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:49'! 61511dialogPaneBorderColor 61512 ^ Color black 61513! ! 61514 61515!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:44'! 61516dialogPaneBorderWidth 61517 ^ 0! ! 61518 61519!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:30'! 61520dialogPaneRampOrColor 61521 ^ {0.0 -> (Color r: 0.742 g: 0.871 b: 1.0). 61522 1.0 -> (Color r: 0.516 g: 0.645 b: 1.0)}! ! 61523 61524!ColorTheme methodsFor: 'theme - dialogs' stamp: 'dgd 11/3/2004 19:38'! 61525dialogRampOrColor 61526 ^ {0.0 -> (Color r: 0.516 g: 0.645 b: 1.0). 61527 1.0 -> (Color r: 0.742 g: 0.871 b: 1.0)}! ! 61528 61529 61530!ColorTheme methodsFor: 'theme - dockingbar' stamp: 'marcus.denker 11/29/2008 22:52'! 61531dockingBarAutoGradient 61532 ^ true! ! 61533 61534!ColorTheme methodsFor: 'theme - dockingbar' stamp: 'marcus.denker 11/29/2008 22:52'! 61535dockingBarColor 61536 ^self normal:1! ! 61537 61538!ColorTheme methodsFor: 'theme - dockingbar' stamp: 'marcus.denker 11/29/2008 22:52'! 61539dockingBarGradientRamp 61540 ^ {0.0 -> Color white. 1.0 61541 -> (self normal:1)}! ! 61542 61543 61544!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:30'! 61545menuBorderColor 61546 ^ self subclassResponsibility! ! 61547 61548!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:31'! 61549menuBorderWidth 61550 ^ self subclassResponsibility! ! 61551 61552!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:31'! 61553menuColor 61554 ^ self subclassResponsibility! ! 61555 61556!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:32'! 61557menuLineColor 61558 ^ self subclassResponsibility! ! 61559 61560!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:32'! 61561menuSelectionColor 61562 ^ self subclassResponsibility! ! 61563 61564!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:32'! 61565menuTitleBorderColor 61566 ^ self subclassResponsibility! ! 61567 61568!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:32'! 61569menuTitleBorderWidth 61570 ^ self subclassResponsibility! ! 61571 61572!ColorTheme methodsFor: 'theme - menus' stamp: 'dgd 11/2/2004 17:32'! 61573menuTitleColor 61574 ^ self subclassResponsibility! ! 61575 61576"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 61577 61578ColorTheme class 61579 instanceVariableNames: ''! 61580 61581!ColorTheme class methodsFor: 'accessing' stamp: 'marcus.denker 11/29/2008 22:53'! 61582current 61583 ^ self new! ! 61584TextStream subclass: #ColoredCodeStream 61585 instanceVariableNames: 'dialect colorTable' 61586 classVariableNames: 'ST80ColorTable' 61587 poolDictionaries: '' 61588 category: 'Compiler-Kernel'! 61589 61590!ColoredCodeStream methodsFor: 'color/style' stamp: 'md 8/14/2005 17:33'! 61591colorTable 61592 "Answer the table to use to determine colors" 61593 61594 ^ colorTable ifNil: [colorTable := ST80ColorTable]! ! 61595 61596!ColoredCodeStream methodsFor: 'color/style' stamp: 'sw 5/20/2001 21:05'! 61597withColor: colorSymbol emphasis: emphasisSymbol do: aBlock 61598 "Evaluate the given block with the given color and style text attribute" 61599 61600 ^ self withAttributes: {TextColor color: (Color perform: colorSymbol). 61601 TextEmphasis perform: emphasisSymbol} 61602 do: aBlock! ! 61603 61604!ColoredCodeStream methodsFor: 'color/style' stamp: 'sw 5/20/2001 11:30'! 61605withStyleFor: elementType do: aBlock 61606 "Evaluate aBlock with appropriate emphasis and color for the given elementType" 61607 61608 | colorAndStyle | 61609 colorAndStyle := self colorTable at: elementType. 61610 ^ self withColor: colorAndStyle first emphasis: colorAndStyle second do: aBlock! ! 61611 61612"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 61613 61614ColoredCodeStream class 61615 instanceVariableNames: ''! 61616 61617!ColoredCodeStream class methodsFor: 'initialization' stamp: 'wiz 9/12/2005 00:41'! 61618initialize 61619 "Initialize the colors that characterize the ST80 dialect" 61620 61621 ST80ColorTable := IdentityDictionary new. 61622 #( (temporaryVariable blue italic) 61623 (methodArgument blue normal) 61624 (methodSelector black bold) 61625 (blockArgument red normal) 61626 (comment brown normal) 61627 (variable magenta normal) 61628 (literal orange normal) 61629 (keyword darkGray bold) 61630 (prefixKeyword veryDarkGray bold) 61631 (setOrReturn black bold)) do: 61632 [:aTriplet | 61633 ST80ColorTable at: aTriplet first put: aTriplet allButFirst] 61634 61635"ColoredCodeStream initialize"! ! 61636 61637 61638!ColoredCodeStream class methodsFor: 'instance creation' stamp: 'md 8/15/2005 11:00'! 61639contents: blockWithArg 61640 "Evaluate blockWithArg on a DialectStream of the given description" 61641 61642 | stream | 61643 stream := self on: (Text new: 400). 61644 blockWithArg value: stream. 61645 ^ stream contents! ! 61646Object subclass: #CombinedChar 61647 instanceVariableNames: 'codes combined' 61648 classVariableNames: 'Compositions Decompositions Diacriticals' 61649 poolDictionaries: '' 61650 category: 'Multilingual-Scanning'! 61651 61652!CombinedChar methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:22'! 61653add: char 61654 61655 | dict elem | 61656 codes ifNil: [codes := Array with: char. combined := char. ^ true]. 61657 61658 dict := Compositions at: combined charCode ifAbsent: [^ false]. 61659 61660 elem := dict at: combined charCode ifAbsent: [^ false]. 61661 61662 codes := codes copyWith: char. 61663 combined := elem. 61664 ^ true. 61665! ! 61666 61667!CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 2/10/2004 07:08'! 61668base 61669 61670 ^ codes first. 61671! ! 61672 61673!CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 2/10/2004 07:08'! 61674combined 61675 61676 ^ combined. 61677! ! 61678 61679!CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 10/10/2007 19:50'! 61680simpleAdd: char 61681 61682 | dict elem | 61683 codes ifNil: [codes := Array with: char. combined := char. ^ true]. 61684 61685 dict := Compositions at: combined charCode ifAbsent: [^ false]. 61686 61687 elem := dict at: char charCode ifAbsent: [^ false]. 61688 61689 combined := Character leadingChar: self base leadingChar code: elem. 61690 codes at: 1 put: combined. 61691 ^ true. 61692! ! 61693 61694"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 61695 61696CombinedChar class 61697 instanceVariableNames: ''! 61698 61699!CombinedChar class methodsFor: 'testing' stamp: 'michael.rueger 3/2/2009 10:13'! 61700isCompositionCharacter: charCode 61701 ^Compositions includesKey: charCode! ! 61702 61703!CombinedChar class methodsFor: 'testing' stamp: 'yo 12/31/2002 19:21'! 61704isDiacriticals: unicode 61705 61706 ^ Diacriticals includes: unicode. 61707! ! 61708 61709 61710!CombinedChar class methodsFor: 'utility' stamp: 'sd 2/4/2008 21:22'! 61711parseCompositionMappingFrom: stream 61712" 61713 self halt. 61714 self parseCompositionMapping 61715" 61716 61717 | line fieldEnd point fieldStart compositions toNumber diacritical result | 61718 61719 toNumber := [:quad | ('16r', quad) asNumber]. 61720 61721 Compositions := IdentityDictionary new: 2048. 61722 Decompositions := IdentityDictionary new: 2048. 61723 Diacriticals := IdentitySet new: 2048. 61724 61725 [(line := stream upTo: Character cr) size > 0] whileTrue: [ 61726 fieldEnd := line indexOf: $; startingAt: 1. 61727 point := ('16r', (line copyFrom: 1 to: fieldEnd - 1)) asNumber. 61728 2 to: 6 do: [:i | 61729 fieldStart := fieldEnd + 1. 61730 fieldEnd := line indexOf: $; startingAt: fieldStart. 61731 ]. 61732 compositions := line copyFrom: fieldStart to: fieldEnd - 1. 61733 (compositions size > 0 and: [compositions first ~= $<]) ifTrue: [ 61734 compositions := compositions substrings collect: toNumber. 61735 compositions size > 1 ifTrue: [ 61736 diacritical := compositions first. 61737 Diacriticals add: diacritical. 61738 result := compositions second. 61739 (Decompositions includesKey: point) ifTrue: [ 61740 self error: 'should not happen'. 61741 ] ifFalse: [ 61742 Decompositions at: point put: (Array with: diacritical with: result). 61743 ]. 61744 (Compositions includesKey: diacritical) ifTrue: [ 61745 (Compositions at: diacritical) at: result put: point. 61746 ] ifFalse: [ 61747 Compositions at: diacritical 61748 put: (IdentityDictionary new at: result put: point; yourself). 61749 ]. 61750 ]. 61751 ]. 61752 ]. 61753! ! 61754Object subclass: #Command 61755 instanceVariableNames: 'phase cmdWording undoTarget undoSelector undoArguments redoTarget redoSelector redoArguments parameters' 61756 classVariableNames: '' 61757 poolDictionaries: '' 61758 category: 'Morphic-Undo'! 61759!Command commentStamp: '<historical>' prior: 0! 61760An object representing an undoable command to be done in the environment. 61761 61762Structure: 61763 phase indicates whether the cmd is current in undone or redone mode 61764 cmdWording The wording of the command (used in arming the "undo"/"redo" menu items 61765 parameters an IdentityDictionary /NOT USED/ 61766 undoTarget Receiver, selector and arguments to accomplish undo 61767 undoSelector 61768 undoArguments 61769 redoTarget Receiver, selector and arguments to accomplish redo 61770 redoSelector 61771 redoArguments 61772 61773To use this, for any command you wish to use, you 61774 * Create an instance of Command, as follows... 61775 cmd _ Command new cmdWording: 'resizing'. 61776 * Give the the command undo state and redo state, as follows... 61777 cmd undoTarget: target selector: #extent: argument: oldExtent. 61778 cmd redoTarget: target selector: #extent: argument: newExtent. 61779 * Send a message of the form 61780 Command rememberCommand: cmd 61781 61782LastCommand is the last command that was actually done or undone. 61783 61784CommandHistory, applicable only when infiniteUndo is set, holds a 'tape' of the complete history of commands, as far back as it's possible to go. 61785 61786CommandExcursions, also applicable only in the infiniteUndo case, and rather at the fringe even then, holds segments of former CommandHistory that have been lopped off because of variant paths taken.! 61787 61788 61789!Command methodsFor: 'command execution' stamp: 'di 8/30/2000 16:04'! 61790doCommand 61791 "Do the command represented by the receiver. Not actually called by active current code, but reachable by the not-yet-unsealed promoteToCurrent: action." 61792 61793 redoTarget ifNotNil: [redoTarget perform: redoSelector withArguments: redoArguments]! ! 61794 61795!Command methodsFor: 'command execution' stamp: 'di 8/30/2000 16:04'! 61796redoCommand 61797 "Perform the 'redo' operation" 61798 61799 redoTarget ifNotNil: [redoTarget perform: redoSelector withArguments: redoArguments]! ! 61800 61801!Command methodsFor: 'command execution' stamp: 'sw 2/2/2006 02:00'! 61802stillValid 61803 "Answer whether the receiver is still valid." 61804 61805 ^ (undoTarget isMorph and: [undoTarget isInWorld]) or: [redoTarget isMorph and: [redoTarget isInWorld]]! ! 61806 61807!Command methodsFor: 'command execution' stamp: 'di 8/30/2000 16:02'! 61808undoCommand 61809 "Perform the 'undo' operation" 61810 61811 undoTarget ifNotNil: [undoTarget perform: undoSelector withArguments: undoArguments]! ! 61812 61813 61814!Command methodsFor: 'copying' stamp: 'tk 2/25/2001 17:53'! 61815veryDeepFixupWith: deepCopier 61816 | old | 61817 "ALL inst vars were weakly copied. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 61818 61819super veryDeepFixupWith: deepCopier. 618201 to: self class instSize do: 61821 [:ii | old := self instVarAt: ii. 61822 self instVarAt: ii put: (deepCopier references at: old ifAbsent: [old])]. 61823 61824! ! 61825 61826!Command methodsFor: 'copying' stamp: 'tk 2/25/2001 17:53'! 61827veryDeepInner: deepCopier 61828 "ALL fields are weakly copied!! Can't duplicate an object by duplicating a Command that involves it. See DeepCopier." 61829 61830 super veryDeepInner: deepCopier. 61831 "just keep old pointers to all fields" 61832 parameters := parameters.! ! 61833 61834 61835!Command methodsFor: 'initialization' stamp: 'sw 8/29/2000 14:12'! 61836cmdWording: wrd 61837 "Set the wording to be used in a menu item referring to the receiver" 61838 61839 cmdWording := wrd! ! 61840 61841!Command methodsFor: 'initialization' stamp: 'sw 8/29/2000 14:13'! 61842phase: aPhase 61843 "Set the phase of the command to the supplied symbol" 61844 61845 phase := aPhase! ! 61846 61847!Command methodsFor: 'initialization' stamp: 'di 8/30/2000 13:04'! 61848redoTarget: target selector: aSymbol argument: argument 61849 61850 ^ self redoTarget: target selector: aSymbol arguments: {argument}! ! 61851 61852!Command methodsFor: 'initialization' stamp: 'di 8/30/2000 20:53'! 61853redoTarget: target selector: selector arguments: arguments 61854 "Give target morph a chance to refine its undo operation" 61855 61856 target refineRedoTarget: target selector: selector arguments: arguments in: 61857 [:rTarget :rSelector :rArguments | 61858 redoTarget := rTarget. 61859 redoSelector := rSelector. 61860 redoArguments := rArguments]! ! 61861 61862!Command methodsFor: 'initialization' stamp: 'di 8/30/2000 13:04'! 61863undoTarget: target selector: aSymbol argument: argument 61864 61865 ^ self undoTarget: target selector: aSymbol arguments: {argument}! ! 61866 61867!Command methodsFor: 'initialization' stamp: 'di 8/30/2000 20:53'! 61868undoTarget: target selector: selector arguments: arguments 61869 "Give target morph a chance to refine its undo operation" 61870 61871 target refineUndoTarget: target selector: selector arguments: arguments in: 61872 [:rTarget :rSelector :rArguments | 61873 undoTarget := rTarget. 61874 undoSelector := rSelector. 61875 undoArguments := rArguments]! ! 61876 61877 61878!Command methodsFor: 'parameters' stamp: 'sw 8/29/2000 14:12'! 61879parameterAt: aSymbol 61880 "Answer the parameter stored at the given symbol, or nil if none" 61881 61882 ^ self parameterAt: aSymbol ifAbsent: [nil]! ! 61883 61884!Command methodsFor: 'parameters' stamp: 'sw 8/29/2000 14:12'! 61885parameterAt: aSymbol ifAbsent: aBlock 61886 "Answer the parameter stored at the aSymbol, but if none, return the result of evaluating aBlock" 61887 61888 ^ self assuredParameterDictionary at: aSymbol ifAbsent: [aBlock value]! ! 61889 61890!Command methodsFor: 'parameters' stamp: 'sw 8/29/2000 14:12'! 61891parameterAt: aSymbol put: aValue 61892 "Place aValue in the parameters dictionary using aSymbol as key" 61893 61894 ^ self assuredParameterDictionary at: aSymbol put: aValue! ! 61895 61896 61897!Command methodsFor: 'printing' stamp: 'di 8/30/2000 14:09'! 61898printOn: aStream 61899 "Provide more detailed info about the receiver, put in for debugging, maybe should be removed" 61900 61901 super printOn: aStream. 61902 aStream nextPutAll: ' phase: ', phase printString. 61903 cmdWording ifNotNil: [aStream nextPutAll: '; ', cmdWording asString]. 61904 parameters ifNotNil: 61905 [parameters associationsDo: 61906 [:assoc | aStream nextPutAll: ': ', assoc printString]]! ! 61907 61908 61909!Command methodsFor: 'private' stamp: 'sw 8/29/2000 14:09'! 61910assuredParameterDictionary 61911 "Private!! Answer the parameters dictionary, creating it if necessary" 61912 61913 ^ parameters ifNil: [parameters := IdentityDictionary new]! ! 61914 61915!Command methodsFor: 'private' stamp: 'dgd 8/26/2003 21:43'! 61916cmdWording 61917 "Answer the wording to be used to refer to the command in a menu" 61918 61919 ^ cmdWording ifNil: ['last command' translated]! ! 61920 61921!Command methodsFor: 'private' stamp: 'sw 8/29/2000 14:13'! 61922phase 61923 "Answer the phase of the command" 61924 61925 ^ phase! ! 61926 61927!Command methodsFor: 'private' stamp: 'di 12/12/2000 12:36'! 61928undoTarget 61929 ^ undoTarget! ! 61930 61931"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 61932 61933Command class 61934 instanceVariableNames: ''! 61935 61936!Command class methodsFor: 'dog simple ui' stamp: 'ar 8/31/2000 23:13'! 61937redoEnabled 61938 | w | 61939 ^(w := self currentWorld) == nil ifTrue:[false] ifFalse:[w commandHistory redoEnabled]! ! 61940 61941!Command class methodsFor: 'dog simple ui' stamp: 'ar 8/31/2000 23:13'! 61942redoNextCommand 61943 | w | 61944 ^(w := self currentWorld) == nil ifFalse:[w commandHistory redoNextCommand]! ! 61945 61946!Command class methodsFor: 'dog simple ui' stamp: 'ar 8/31/2000 23:13'! 61947undoEnabled 61948 | w | 61949 ^(w := self currentWorld) == nil ifTrue:[false] ifFalse:[w commandHistory undoEnabled]! ! 61950 61951!Command class methodsFor: 'dog simple ui' stamp: 'ar 8/31/2000 23:14'! 61952undoLastCommand 61953 | w | 61954 ^(w := self currentWorld) == nil ifFalse:[w commandHistory undoLastCommand]! ! 61955 61956!Command class methodsFor: 'dog simple ui' stamp: 'ar 11/9/2000 20:38'! 61957undoRedoButtons 61958 "Answer a morph that offers undo and redo buttons" 61959 61960 | aButton wrapper | 61961 "self currentHand attachMorph: Command undoRedoButtons" 61962 wrapper := AlignmentMorph newColumn. 61963 wrapper color: Color veryVeryLightGray lighter; 61964 borderWidth: 0; 61965 layoutInset: 0; 61966 vResizing: #shrinkWrap; 61967 hResizing: #shrinkWrap. 61968 #((CrudeUndo undoLastCommand 'undo last command done' undoEnabled CrudeUndoDisabled CrudeUndoDisabled) 61969 (CrudeRedo redoNextCommand 'redo last undone command' redoEnabled CrudeRedoDisabled CrudeRedoDisabled)) do: 61970 [:tuple | 61971 wrapper addTransparentSpacerOfSize: (8@0). 61972 aButton := UpdatingThreePhaseButtonMorph new. 61973 aButton 61974 onImage: (ScriptingSystem formAtKey: tuple first); 61975 offImage: (ScriptingSystem formAtKey: tuple fifth); 61976 pressedImage: (ScriptingSystem formAtKey: tuple sixth); 61977 getSelector: tuple fourth; 61978 color: Color transparent; 61979 target: self; 61980 actionSelector: tuple second; 61981 setNameTo: tuple second; 61982 setBalloonText: tuple third; 61983 extent: aButton onImage extent. 61984 wrapper addMorphBack: aButton. 61985 wrapper addTransparentSpacerOfSize: (8@0)]. 61986 ^ wrapper! ! 61987 61988 61989!Command class methodsFor: 'initialization' stamp: 'RAA 9/21/2000 14:02'! 61990zapObsolete 61991"Command zapObsolete" 61992 "kill some obsolete stuff still retained by the CompiledMethods in change records" 61993 61994 | before after histories lastCmd histCount lastCount | 61995 Smalltalk garbageCollect. 61996 before := Command allInstances size. 61997 histories := Association allInstances select: [ :each | 61998 each key == #CommandHistory and: [ 61999 (each value isKindOf: OrderedCollection) and: [ 62000 each value isEmpty not and: [ 62001 each value first isKindOf: Command]]] 62002 ]. 62003 histCount := histories size. 62004 lastCmd := Association allInstances select: [ :each | 62005 each key == #LastCommand and: [each value isKindOf: Command] 62006 ]. 62007 lastCount := lastCmd size. 62008 histories do: [ :each | each value: OrderedCollection new]. 62009 lastCmd do: [ :each | each value: Command new]. 62010 Smalltalk garbageCollect. 62011 Smalltalk garbageCollect. 62012 after := Command allInstances size. 62013 Transcript show: {before. after. histCount. histories. lastCount. lastCmd} printString; cr; cr. 62014 ! ! 62015Object subclass: #CommandHistory 62016 instanceVariableNames: 'lastCommand history excursions' 62017 classVariableNames: '' 62018 poolDictionaries: '' 62019 category: 'Morphic-Undo'! 62020 62021!CommandHistory methodsFor: 'called by programmer' stamp: 'sw 2/2/2006 01:48'! 62022assureLastCommandStillValid 62023 "If the lastCommand is not valid, set it to nil; answer the lastCommand." 62024 62025 lastCommand ifNotNil: 62026 [lastCommand stillValid ifFalse: 62027 [self cantUndo]]. 62028 ^ lastCommand! ! 62029 62030!CommandHistory methodsFor: 'called by programmer' stamp: 'ar 8/31/2000 22:46'! 62031cantUndo 62032 "Called by client to indicate that the prior undoable command is no longer undoable" 62033 62034 lastCommand := nil. 62035 history := OrderedCollection new.! ! 62036 62037!CommandHistory methodsFor: 'called by programmer' stamp: 'ar 8/31/2000 22:47'! 62038promoteToCurrent: aCommand 62039 "Very unusual and speculative and unfinished!!. Not currently reachable. For the real thing, we presumably march forward or backward from the current command pointer to the target command in an orderly fashion, doing or undoing each command in turn." 62040 62041 | itsIndex | 62042 Preferences useUndo ifFalse: [^ self]. 62043 itsIndex := history indexOf: aCommand ifAbsent: [nil]. 62044 itsIndex ifNotNil: 62045 [history remove: aCommand ifAbsent: []]. 62046 history add: (lastCommand := aCommand). 62047 itsIndex < history size ifTrue: 62048 [excursions add: (history copyFrom: (itsIndex to: history size))]. 62049 history := (history copyFrom: 1 to: itsIndex) copyWith: aCommand. 62050 62051 lastCommand := aCommand. 62052 aCommand doCommand. 62053 lastCommand phase: #done.! ! 62054 62055!CommandHistory methodsFor: 'called by programmer' stamp: 'aoy 2/15/2003 21:14'! 62056purgeAllCommandsSuchThat: cmdBlock 62057 "Remove a bunch of commands, as in [:cmd | cmd undoTarget == zort]" 62058 62059 Preferences useUndo ifFalse: [^self]. 62060 history := history reject: cmdBlock. 62061 lastCommand := history isEmpty ifTrue: [nil] ifFalse: [history last] ! ! 62062 62063 62064!CommandHistory methodsFor: 'called from the ui' stamp: 'ar 8/31/2000 22:49'! 62065commandToUndo 62066 "Undo the last command, i.e. move backward in the recent-commands tape, if possible." 62067 62068 | anIndex | 62069 lastCommand ifNil: [^ nil]. 62070 lastCommand phase == #done ifTrue: [^ lastCommand]. 62071 (lastCommand phase == #undone and: 62072 [(anIndex := history indexOf: lastCommand) > 1]) 62073 ifTrue: [^ history at: anIndex - 1] 62074 ifFalse: [^ nil] 62075! ! 62076 62077!CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25'! 62078redoNextCommand 62079 "If there is a way to 'redo' (move FORWARD) in the undo/redo history tape, do it." 62080 62081 | anIndex | 62082 lastCommand ifNil: [^ Beeper beep]. 62083 lastCommand phase == #undone 62084 ifFalse: 62085 [anIndex := history indexOf: lastCommand. 62086 (anIndex < history size) 62087 ifTrue: 62088 [lastCommand := history at: anIndex + 1] 62089 ifFalse: 62090 [^ Beeper beep]]. 62091 62092 lastCommand redoCommand. 62093 lastCommand phase: #done 62094! ! 62095 62096!CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25'! 62097undoLastCommand 62098 "Undo the last command, i.e. move backward in the recent-commands tape, if possible." 62099 62100 | aPhase anIndex | 62101 lastCommand ifNil: [^ Beeper beep]. 62102 62103 (aPhase := lastCommand phase) == #done 62104 ifFalse: 62105 [aPhase == #undone 62106 ifTrue: 62107 [anIndex := history indexOf: lastCommand. 62108 anIndex > 1 ifTrue: 62109 [lastCommand := history at: anIndex - 1]]]. 62110 62111 lastCommand undoCommand. 62112 lastCommand phase: #undone 62113 62114 "Command undoLastCommand" 62115! ! 62116 62117!CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25'! 62118undoOrRedoCommand 62119 "This gives a feature comparable to standard Mac undo/redo. If the undo/redo action taken was a simple do or a redo, then undo it. But if the last undo/redo action taken was an undo, then redo it." 62120 62121 "Command undoOrRedoCommand" 62122 | aPhase | 62123 lastCommand ifNil: [^ Beeper beep]. 62124 62125 (aPhase := lastCommand phase) == #done 62126 ifTrue: 62127 [lastCommand undoCommand. 62128 lastCommand phase: #undone] 62129 ifFalse: 62130 [aPhase == #undone 62131 ifTrue: 62132 [lastCommand redoCommand. 62133 lastCommand phase: #done]]! ! 62134 62135!CommandHistory methodsFor: 'called from the ui' stamp: 'alain.plantec 2/6/2009 16:53'! 62136undoTo 62137 "Not yet functional, and not yet sent. Allow the user to choose a point somewhere in the undo/redo tape, and undo his way to there. Applicable only if infiniteUndo is set. " 62138 62139 | anIndex commandList reply | 62140 (anIndex := self historyIndexOfLastCommand) == 0 ifTrue: [^ Beeper beep]. 62141 commandList := history 62142 copyFrom: ((anIndex - 10) max: 1) 62143 to: ((anIndex + 10) min: history size). 62144 reply := UIManager default 62145 chooseFrom: (commandList collect: [:cmd | cmd cmdWording truncateWithElipsisTo: 20]) 62146 values: commandList 62147 title: 'undo or redo to...' translated. 62148 reply ifNotNil: [self inform: #deferred] 62149 62150 "ActiveWorld commandHistory undoTo" 62151! ! 62152 62153 62154!CommandHistory methodsFor: 'command history' stamp: 'ar 8/31/2000 22:44'! 62155historyIndexOfLastCommand 62156 "Answer which position of the CommandHistory list is occupied by the LastCommand" 62157 62158 ^ history indexOf: lastCommand ifAbsent: [0]! ! 62159 62160!CommandHistory methodsFor: 'command history' stamp: 'ar 8/31/2000 22:45'! 62161lastCommand 62162 "Answer the last command done or undone" 62163 62164 ^ lastCommand! ! 62165 62166!CommandHistory methodsFor: 'command history' stamp: 'ar 8/31/2000 22:45'! 62167nextCommand 62168 "Answer the command object that would be sent the #redoCommand message if the user were to request Redo, or nil if none" 62169 62170 | anIndex | 62171 lastCommand ifNil: [^ nil]. 62172 lastCommand phase == #undone ifTrue: [^ lastCommand]. 62173 anIndex := history indexOf: lastCommand ifAbsent: [^ nil]. 62174 ^ anIndex = history size ifTrue: [nil] ifFalse: [history at: (anIndex + 1)]! ! 62175 62176!CommandHistory methodsFor: 'command history' stamp: 'di 12/12/2000 13:46'! 62177resetCommandHistory "CommandHistory allInstancesDo: [:ch | ch resetCommandHistory]" 62178 "Clear out the command history so that no commands are held" 62179 62180 lastCommand := nil. 62181 history := OrderedCollection new.! ! 62182 62183 62184!CommandHistory methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:48'! 62185initialize 62186 super initialize. 62187 lastCommand := nil. 62188 history := OrderedCollection new. 62189 excursions := OrderedCollection new.! ! 62190 62191 62192!CommandHistory methodsFor: 'menu' stamp: 'ar 8/31/2000 22:41'! 62193nextCommandToUndo 62194 | anIndex | 62195 lastCommand ifNil: [^ nil]. 62196 lastCommand phase == #done ifTrue: [^ lastCommand]. 62197 (lastCommand phase == #undone and: 62198 [(anIndex := history indexOf: lastCommand) > 1]) 62199 ifTrue: [^ history at: anIndex - 1] 62200 ifFalse: [^ nil]! ! 62201 62202!CommandHistory methodsFor: 'menu' stamp: 'ar 8/31/2000 22:39'! 62203redoEnabled 62204 "Answer whether the redo command is currently available" 62205 62206 ^ self nextCommand notNil! ! 62207 62208!CommandHistory methodsFor: 'menu' stamp: 'dgd 4/3/2006 14:26'! 62209redoMenuWording 62210 "Answer the wording to be used in a menu offering the current 62211 Redo command" 62212 | nextCommand | 62213 62214 ((nextCommand := self nextCommand) isNil 62215 or: [Preferences useUndo not]) 62216 ifTrue: [^ 'can''t redo' translated]. 62217 62218 ^ String 62219 streamContents: [:aStream | 62220 aStream nextPutAll: 'redo' translated. 62221 aStream nextPutAll: ' "'. 62222 aStream nextPutAll: (nextCommand cmdWording truncateWithElipsisTo: 20). 62223 aStream nextPut: $". 62224 lastCommand phase == #done 62225 ifFalse: [aStream nextPutAll: ' (z)']]! ! 62226 62227!CommandHistory methodsFor: 'menu' stamp: 'ar 8/31/2000 22:40'! 62228undoEnabled 62229 "Answer whether there is an undoable command at the ready" 62230 62231 ^ lastCommand notNil! ! 62232 62233!CommandHistory methodsFor: 'menu' stamp: 'dgd 4/3/2006 14:26'! 62234undoMenuWording 62235 "Answer the wording to be used in an 'undo' menu item" 62236 62237 (lastCommand isNil 62238 or: [Preferences useUndo not] 62239 or: [Preferences infiniteUndo not and: [lastCommand phase == #undone]] 62240 or: [self nextCommandToUndo isNil]) 62241 ifTrue: [^ 'can''t undo' translated]. 62242 62243 ^ String 62244 streamContents: [:aStream | 62245 aStream nextPutAll: 'undo' translated. 62246 aStream nextPutAll: ' "'. 62247 aStream nextPutAll: (self nextCommandToUndo cmdWording truncateWithElipsisTo: 20). 62248 aStream nextPut: $". 62249 lastCommand phase == #done 62250 ifTrue: [aStream nextPutAll: ' (z)']].! ! 62251 62252!CommandHistory methodsFor: 'menu' stamp: 'sw 2/2/2006 01:53'! 62253undoOrRedoMenuWording 62254 "Answer the wording to be used in a menu item offering undo/redo (i.e., the form used when the #infiniteUndo preference is false)" 62255 62256 | pre | 62257 self assureLastCommandStillValid. 62258 lastCommand ifNil: [^ 'can''t undo' translated]. 62259 pre := lastCommand phase == #done 62260 ifTrue: ['undo' translated] 62261 ifFalse: ['redo' translated]. 62262 ^ pre, ' "', (lastCommand cmdWording truncateWithElipsisTo: 20), '" (z)'! ! 62263 62264 62265!CommandHistory methodsFor: 'undo' stamp: 'di 12/12/2000 10:16'! 62266rememberCommand: aCommand 62267 "Make the supplied command be the 'LastCommand', and mark it 'done'" 62268 62269 | currentCommandIndex | 62270 Preferences useUndo ifFalse: [^ self]. "Command initialize" 62271 62272 Preferences infiniteUndo ifTrue: 62273 [currentCommandIndex := history indexOf: lastCommand. 62274 ((currentCommandIndex < history size) and: [Preferences preserveCommandExcursions]) ifTrue: 62275 [excursions add: (history copyFrom: (currentCommandIndex to: history size)). 62276 history := history copyFrom: 1 to: currentCommandIndex]. 62277 history addLast: aCommand]. 62278 62279 lastCommand := aCommand. 62280 lastCommand phase: #done.! ! 62281 62282"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 62283 62284CommandHistory class 62285 instanceVariableNames: ''! 62286 62287!CommandHistory class methodsFor: 'initialization' stamp: 'dgd 4/3/2006 14:28'! 62288initialize 62289 "CommandHistory initialize" 62290 62291 Smalltalk addToStartUpList: self. 62292 Smalltalk addToShutDownList: self.! ! 62293 62294 62295!CommandHistory class methodsFor: 'system startup' stamp: 'tk 5/16/2002 13:52'! 62296forgetAllGrabCommandsFrom: starter 62297 "Forget all the commands that might be held on to in the properties dicitonary of various morphs for various reasons." 62298 62299 | object | 62300 object := starter. 62301 [ 62302 [0 == object] whileFalse: [ 62303 object isMorph ifTrue: [object removeProperty: #undoGrabCommand]. 62304 object := object nextObject]. 62305 ] ifError: [:err :rcvr | "object is obsolete" 62306 self forgetAllGrabCommandsFrom: object nextObject]. 62307 62308 "CommandHistory forgetAllGrabCommandsFrom: true someObject" 62309! ! 62310 62311!CommandHistory class methodsFor: 'system startup' stamp: 'tk 5/16/2002 13:38'! 62312resetAllHistory 62313 "Reset all command histories, and make all morphs that might be holding on to undo-grab-commands forget them" 62314 62315 self allInstancesDo: [:c | c resetCommandHistory]. 62316 self forgetAllGrabCommandsFrom: self someObject. 62317 62318 "CommandHistory resetAllHistory" 62319! ! 62320 62321!CommandHistory class methodsFor: 'system startup' stamp: 'adrian_lienhard 2/16/2009 10:49'! 62322shutDown: aboutToQuit 62323 aboutToQuit ifFalse: [^ self]. 62324 Preferences purgeUndoOnQuit ifTrue: [self resetAllHistory]! ! 62325 62326!CommandHistory class methodsFor: 'system startup' stamp: 'adrian_lienhard 2/16/2009 10:49'! 62327startUp: resuming 62328 resuming ifFalse: [^ self]. 62329 Preferences purgeUndoOnQuit ifFalse: [self resetAllHistory] 62330 62331 ! ! 62332AbstractLauncher subclass: #CommandLineLauncherExample 62333 instanceVariableNames: '' 62334 classVariableNames: '' 62335 poolDictionaries: '' 62336 category: 'System-Download'! 62337!CommandLineLauncherExample commentStamp: '<historical>' prior: 0! 62338CommandLineLauncherExample provides an example for a command line application. if you start squeak with a command line 'class Integer' it will launch a class browser on class Integer. 62339To enable this execute 62340CommandLineLauncherExample activate 62341before you save the image. 62342To disable execute 62343CommandLineLauncherExample deactivate! 62344 62345 62346!CommandLineLauncherExample methodsFor: 'running' stamp: 'ar 9/27/2005 20:23'! 62347startUp 62348 | className | 62349 className := self parameterAt: 'class'. 62350 ToolSet browse: (Smalltalk at: className asSymbol ifAbsent: [Object]) selector: nil! ! 62351ParseNode subclass: #CommentNode 62352 instanceVariableNames: '' 62353 classVariableNames: '' 62354 poolDictionaries: '' 62355 category: 'Compiler-ParseNodes'! 62356 62357!CommentNode methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:43'! 62358accept: aVisitor 62359 aVisitor visitCommentNode: self! ! 62360AbstractEvent subclass: #CommentedEvent 62361 instanceVariableNames: 'oldComment newComment oldStamp newStamp' 62362 classVariableNames: '' 62363 poolDictionaries: '' 62364 category: 'System-Change Notification'! 62365 62366!CommentedEvent methodsFor: 'accessing' stamp: 'gk 8/15/2007 01:17'! 62367newComment 62368 ^newComment! ! 62369 62370!CommentedEvent methodsFor: 'accessing' stamp: 'gk 8/15/2007 01:17'! 62371newComment: aString 62372 newComment := aString! ! 62373 62374!CommentedEvent methodsFor: 'accessing' stamp: 'gk 8/23/2007 21:37'! 62375newStamp 62376 ^newStamp! ! 62377 62378!CommentedEvent methodsFor: 'accessing' stamp: 'gk 8/23/2007 21:37'! 62379newStamp: aString 62380 newStamp := aString! ! 62381 62382!CommentedEvent methodsFor: 'accessing' stamp: 'gk 8/15/2007 01:18'! 62383oldComment 62384 ^oldComment! ! 62385 62386!CommentedEvent methodsFor: 'accessing' stamp: 'gk 8/15/2007 01:17'! 62387oldComment: aString 62388 oldComment := aString! ! 62389 62390!CommentedEvent methodsFor: 'accessing' stamp: 'gk 8/23/2007 21:37'! 62391oldStamp 62392 ^oldStamp! ! 62393 62394!CommentedEvent methodsFor: 'accessing' stamp: 'gk 8/23/2007 21:37'! 62395oldStamp: aString 62396 oldStamp := aString! ! 62397 62398 62399!CommentedEvent methodsFor: 'printing' stamp: 'rw 7/1/2003 11:37'! 62400printEventKindOn: aStream 62401 62402 aStream nextPutAll: 'Commented'! ! 62403 62404 62405!CommentedEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:37'! 62406isCommented 62407 62408 ^true! ! 62409 62410"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 62411 62412CommentedEvent class 62413 instanceVariableNames: ''! 62414 62415!CommentedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:08'! 62416changeKind 62417 62418 ^#Commented! ! 62419 62420!CommentedEvent class methodsFor: 'accessing'! 62421class: aClass oldComment: oldComment newComment: newComment 62422 62423 ^(self class: aClass) oldComment: oldComment; newComment: newComment; yourself! ! 62424 62425!CommentedEvent class methodsFor: 'accessing' stamp: 'gk 8/23/2007 21:36'! 62426class: aClass oldComment: oldComment newComment: newComment oldStamp: oldStamp newStamp: newStamp 62427 62428 ^(self class: aClass) 62429 oldComment: oldComment; 62430 newComment: newComment; 62431 oldStamp: oldStamp; 62432 newStamp: newStamp; yourself! ! 62433 62434!CommentedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 11:20'! 62435supportedKinds 62436 62437 ^Array with: self classKind! ! 62438ByteArray variableByteSubclass: #CompiledMethod 62439 instanceVariableNames: '' 62440 classVariableNames: 'LargeFrame SmallFrame' 62441 poolDictionaries: '' 62442 category: 'Kernel-Methods'! 62443!CompiledMethod commentStamp: 'ls 7/5/2003 13:48' prior: 0! 62444My instances are methods suitable for interpretation by the virtual machine. This is the only class in the system whose instances intermix both indexable pointer fields and indexable integer fields. 62445 62446 62447The current format of a CompiledMethod is as follows: 62448 62449 header (4 bytes) 62450 literals (4 bytes each) 62451 bytecodes (variable) 62452 trailer (variable) 62453 62454The header is a 30-bit integer with the following format: 62455 62456(index 0) 9 bits: main part of primitive number (#primitive) 62457(index 9) 8 bits: number of literals (#numLiterals) 62458(index 17) 1 bit: whether a large frame size is needed (#frameSize) 62459(index 18) 6 bits: number of temporary variables (#numTemps) 62460(index 24) 4 bits: number of arguments to the method (#numArgs) 62461(index 28) 1 bit: high-bit of primitive number (#primitive) 62462(index 29) 1 bit: flag bit, ignored by the VM (#flag) 62463 62464 62465The trailer has two variant formats. In the first variant, the last byte is at least 252 and the last four bytes represent a source pointer into one of the sources files (see #sourcePointer). In the second variant, the last byte is less than 252, and the last several bytes are a compressed version of the names of the method's temporary variables. The number of bytes used for this purpose is the value of the last byte in the method. 62466! 62467 62468 62469!CompiledMethod methodsFor: '*Tools-Inspector' stamp: 'eem 5/15/2008 13:14'! 62470explorerContents 62471 "(CompiledMethod compiledMethodAt: #explorerContents) explore" 62472 62473 ^Array streamContents: 62474 [:s| | tokens | 62475 tokens := Scanner new scanTokens: (self headerDescription readStream skipTo: $"; upTo: $"). 62476 s nextPut: (ObjectExplorerWrapper 62477 with: ((0 to: tokens size by: 2) collect: 62478 [:i| i = 0 ifTrue: [self header] ifFalse: [{tokens at: i - 1. tokens at: i}]]) 62479 name: 'header' 62480 model: self). 62481 (1 to: self numLiterals) do: 62482 [:key| 62483 s nextPut: (ObjectExplorerWrapper 62484 with: (self literalAt: key) 62485 name: ('literal', key printString contractTo: 32) 62486 model: self)]. 62487 self isQuick 62488 ifTrue: [s nextPut: (ObjectExplorerWrapper 62489 with: self symbolic 62490 name: #symbolic 62491 model: self)] 62492 ifFalse: 62493 [self symbolicLinesDo: 62494 [:pc :line| 62495 pc <= 1 62496 ifTrue: 62497 [s nextPut: (ObjectExplorerWrapper 62498 with: line 62499 name: 'pragma' 62500 model: self)] 62501 ifFalse: 62502 [s nextPut: (ObjectExplorerWrapper 62503 with: line 62504 name: pc printString 62505 model: self)]]]. 62506 "should be self numLiterals + 1 * Smalltalk wordSize + 1" 62507 self endPC + 1 62508 to: self basicSize 62509 do: [:key| 62510 s nextPut: (ObjectExplorerWrapper 62511 with: (self basicAt: key) 62512 name: key printString 62513 model: self)]]! ! 62514 62515!CompiledMethod methodsFor: '*Tools-Inspector' stamp: 'ar 9/27/2005 18:32'! 62516inspectorClass 62517 "Answer the class of the inspector to be used on the receiver. Called by inspect; 62518 use basicInspect to get a normal (less useful) type of inspector." 62519 62520 ^ CompiledMethodInspector! ! 62521 62522 62523!CompiledMethod methodsFor: 'accessing' stamp: 'md 3/31/2007 19:45'! 62524classBinding 62525 ^(self literalAt: self numLiterals) ! ! 62526 62527!CompiledMethod methodsFor: 'accessing' stamp: 'eem 8/20/2009 11:43'! 62528clearFlag 62529 "Clear the user-level flag bit" 62530 62531 self objectAt: 1 put: (self header bitAnd: (1 << 29) bitInvert)! ! 62532 62533!CompiledMethod methodsFor: 'accessing' stamp: 'md 2/18/2006 13:11'! 62534defaultSelector 62535 "Invent and answer an appropriate message selector (a Symbol) for me, 62536 that is, one that will parse with the correct number of arguments." 62537 62538 ^#DoIt numArgs: self numArgs! ! 62539 62540!CompiledMethod methodsFor: 'accessing' stamp: 'eem 6/30/2009 12:38'! 62541endPC 62542 "Answer the index of the last bytecode." 62543 | size flagByte | 62544 "Can't create a zero-sized CompiledMethod so no need to use last for the errorEmptyCollection check. 62545 We can reuse size." 62546 size := self size. 62547 flagByte := self at: size. 62548 flagByte = 0 ifTrue: 62549 ["If last byte = 0, may be either 0, 0, 0, 0 or just 0" 62550 1 to: 4 do: [:i | (self at: size - i) = 0 ifFalse: [^size - i]]]. 62551 flagByte < 252 ifTrue: 62552 ["Magic sources (temp names encoded in last few bytes)" 62553 ^flagByte <= 127 62554 ifTrue: [size - flagByte - 1] 62555 ifFalse: [size - (flagByte - 128 * 128) - (self at: size - 1) - 2]]. 62556 "Normal 4-byte source pointer" 62557 ^size - 4! ! 62558 62559!CompiledMethod methodsFor: 'accessing' stamp: 'eem 8/20/2009 11:42'! 62560flag 62561 "Answer the user-level flag bit" 62562 62563 ^((self header bitShift: -29) bitAnd: 1) = 1! ! 62564 62565!CompiledMethod methodsFor: 'accessing' stamp: 'di 1/2/1999 17:00'! 62566flushCache 62567 "Tell the interpreter to remove all references to this method from its method lookup cache, if it has one. This primitive must be called whenever a method is defined or removed. 62568 NOTE: Only one of two selective flush methods needs to be used. 62569 Squeak 2.2 and earlier uses 119 (See Symbol flushCache). 62570 Squeak 2.3 and later uses 116 (See CompiledMethod flushCache)." 62571 62572 <primitive: 116> 62573! ! 62574 62575!CompiledMethod methodsFor: 'accessing' stamp: 'di 10/23/1999 22:00'! 62576frameSize 62577 "Answer the size of temporary frame needed to run the receiver." 62578 "NOTE: Versions 2.7 and later use two sizes of contexts." 62579 62580 (self header noMask: 16r20000) 62581 ifTrue: [^ SmallFrame] 62582 ifFalse: [^ LargeFrame] 62583! ! 62584 62585!CompiledMethod methodsFor: 'accessing'! 62586initialPC 62587 "Answer the program counter for the receiver's first bytecode." 62588 62589 ^ (self numLiterals + 1) * 4 + 1! ! 62590 62591!CompiledMethod methodsFor: 'accessing' stamp: 'eem 11/29/2008 11:38'! 62592methodClass 62593 "answer the class that I am installed in" 62594 ^(self literalAt: self numLiterals) value.! ! 62595 62596!CompiledMethod methodsFor: 'accessing' stamp: 'md 2/16/2006 11:30'! 62597methodClass: aClass 62598 "set the class binding in the last literal to aClass" 62599 self literalAt: self numLiterals put: aClass binding! ! 62600 62601!CompiledMethod methodsFor: 'accessing' stamp: 'eem 11/29/2008 11:38'! 62602methodClassAssociation 62603 "answer the association to the class that I am installed in, or nil if none." 62604 ^self literalAt: self numLiterals! ! 62605 62606!CompiledMethod methodsFor: 'accessing' stamp: 'md 2/16/2006 14:00'! 62607methodReference 62608 | class selector | 62609 class := self methodClass ifNil: [^nil]. 62610 selector := self selector ifNil: [^nil]. 62611 ^MethodReference class: class selector: selector. 62612 ! ! 62613 62614!CompiledMethod methodsFor: 'accessing' stamp: 'ar 6/2/1998 16:26'! 62615numArgs 62616 "Answer the number of arguments the receiver takes." 62617 62618 ^ (self header bitShift: -24) bitAnd: 16r0F! ! 62619 62620!CompiledMethod methodsFor: 'accessing'! 62621numLiterals 62622 "Answer the number of literals used by the receiver." 62623 62624 ^ (self header bitShift: -9) bitAnd: 16rFF! ! 62625 62626!CompiledMethod methodsFor: 'accessing'! 62627numTemps 62628 "Answer the number of temporary variables used by the receiver." 62629 62630 ^ (self header bitShift: -18) bitAnd: 16r3F! ! 62631 62632!CompiledMethod methodsFor: 'accessing' stamp: 'adrian_lienhard 2/21/2009 13:40'! 62633origin 62634 ^ self methodClass traitOrClassOfSelector: self selector! ! 62635 62636!CompiledMethod methodsFor: 'accessing' stamp: 'ls 6/22/2000 14:35'! 62637primitive 62638 "Answer the primitive index associated with the receiver. 62639 Zero indicates that this is not a primitive method. 62640 We currently allow 10 bits of primitive index, but they are in two places 62641 for backward compatibility. The time to unpack is negligible, 62642 since the reconstituted full index is stored in the method cache." 62643 | primBits | 62644 primBits := self header bitAnd: 16r100001FF. 62645 62646 ^ (primBits bitAnd: 16r1FF) + (primBits bitShift: -19) 62647! ! 62648 62649!CompiledMethod methodsFor: 'accessing' stamp: 'eem 11/30/2008 08:55'! 62650properties 62651 "Answer the method properties of the receiver." 62652 | propertiesOrSelector | 62653 ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties 62654 ifTrue: [propertiesOrSelector] 62655 ifFalse: [AdditionalMethodState forMethod: self selector: propertiesOrSelector]! ! 62656 62657!CompiledMethod methodsFor: 'accessing' stamp: 'eem 11/29/2008 17:23'! 62658properties: aMethodProperties 62659 "Set the method-properties of the receiver to aMethodProperties." 62660 self literalAt: self numLiterals - 1 62661 put: (aMethodProperties isEmpty 62662 ifTrue: [aMethodProperties selector] 62663 ifFalse: [aMethodProperties 62664 setMethod: self; 62665 yourself])! ! 62666 62667!CompiledMethod methodsFor: 'accessing'! 62668returnField 62669 "Answer the index of the instance variable returned by a quick return 62670 method." 62671 | prim | 62672 prim := self primitive. 62673 prim < 264 62674 ifTrue: [self error: 'only meaningful for quick-return'] 62675 ifFalse: [^ prim - 264]! ! 62676 62677!CompiledMethod methodsFor: 'accessing' stamp: 'md 1/20/2006 16:09'! 62678scanner 62679 62680 ^ InstructionStream on: self! ! 62681 62682!CompiledMethod methodsFor: 'accessing' stamp: 'md 2/15/2006 20:51'! 62683searchForClass 62684 "search me in all classes, if found, return my class. Slow!!" 62685 self systemNavigation allBehaviorsDo: [:class | 62686 (class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^class]]. 62687 ^nil.! ! 62688 62689!CompiledMethod methodsFor: 'accessing' stamp: 'md 2/15/2006 20:51'! 62690searchForSelector 62691 "search me in all classes, if found, return my selector. Slow!!" 62692 | selector | 62693 self systemNavigation allBehaviorsDo: [:class | 62694 (selector := class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^selector]]. 62695 ^nil.! ! 62696 62697!CompiledMethod methodsFor: 'accessing' stamp: 'eem 11/28/2008 12:54'! 62698selector 62699 "Answer a method's selector. This is either the penultimate literal, 62700 or, if the method has any properties or pragmas, the selector of 62701 the MethodProperties stored in the penultimate literal." 62702 | penultimateLiteral | 62703 ^(penultimateLiteral := self penultimateLiteral) isMethodProperties 62704 ifTrue: [penultimateLiteral selector] 62705 ifFalse: [penultimateLiteral]! ! 62706 62707!CompiledMethod methodsFor: 'accessing' stamp: 'eem 11/28/2008 12:58'! 62708selector: aSelector 62709 "Set a method's selector. This is either the penultimate literal, 62710 or, if the method has any properties or pragmas, the selector of 62711 the MethodProperties stored in the penultimate literal." 62712 | penultimateLiteral nl | 62713 (penultimateLiteral := self penultimateLiteral) isMethodProperties 62714 ifTrue: [penultimateLiteral selector: aSelector] 62715 ifFalse: [(nl := self numLiterals) < 2 ifTrue: 62716 [self error: 'insufficient literals to hold selector']. 62717 self literalAt: nl - 1 put: aSelector]! ! 62718 62719!CompiledMethod methodsFor: 'accessing' stamp: 'ajh 11/17/2001 14:30'! 62720trailer 62721 62722 | end trailer | 62723 end := self endPC. 62724 trailer := ByteArray new: self size - end. 62725 end + 1 to: self size do: [:i | 62726 trailer at: i - end put: (self at: i)]. 62727 ^ trailer! ! 62728 62729 62730!CompiledMethod methodsFor: 'class accessing' stamp: 'stephane.ducasse 3/30/2009 22:43'! 62731category 62732 62733 ^self methodClass organization categoryOfElement:self selector! ! 62734 62735 62736!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:10'! 62737allEmbeddedBlockMethods 62738 62739 | set | 62740 set := OrderedCollection new. 62741 1 to: self numLiterals do: [:i | | lit | 62742 lit := self literalAt: i. 62743 (lit isKindOf: CompiledMethod) ifTrue: [ 62744 set add: lit. 62745 set addAll: lit allEmbeddedBlockMethods. 62746 ] ifFalse: [(lit isKindOf: BlockClosure) ifTrue: [ 62747 set add: lit method. 62748 set addAll: lit method allEmbeddedBlockMethods 62749 ]]. 62750 ]. 62751 ^ set! ! 62752 62753!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:01'! 62754containsBlockClosures 62755 62756 ^ self embeddedBlockMethods size > 0! ! 62757 62758!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:10'! 62759createBlock: env 62760 62761 ^ BlockClosure new 62762 env: env; 62763 method: self! ! 62764 62765!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:00'! 62766embeddedBlockMethods 62767 62768 | set | 62769 set := OrderedCollection new. 62770 1 to: self numLiterals do: [:i | | lit | 62771 lit := self literalAt: i. 62772 (lit isKindOf: CompiledMethod) ifTrue: [ 62773 set add: lit. 62774 ] ifFalse: [(lit isKindOf: BlockClosure) ifTrue: [ 62775 set add: lit method. 62776 ]]. 62777 ]. 62778 ^ set! ! 62779 62780!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:08'! 62781isBlockMethod 62782 "Is this a sub-method (embedded block's method) of another method. If so the last literal points to its outer method" 62783 62784 ^ (self header bitAnd: 1 << 29) ~= 0! ! 62785 62786!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:08'! 62787isBlockMethod: bool 62788 "Use the sign bit in the header to mark methods that are sub-methods of an outer method. The outer method will be held in my last literal." 62789 62790 self objectAt: 1 put: (bool 62791 ifTrue: [self header bitOr: 1 << 29] 62792 ifFalse: [self header bitAnd: (1 << 29) bitInvert])! ! 62793 62794!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:09'! 62795isClosureCompiled: bool 62796 "Use the sign bit in the header to mark methods that have been compiled using the new closure compiler (Parser2)." 62797 62798 self objectAt: 1 put: (bool 62799 ifTrue: [(self header bitOr: 1 << 30) as31BitSmallInt] 62800 ifFalse: [(self header bitAnd: (1 << 30) bitInvert) as31BitSmallInt])! ! 62801 62802!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:09'! 62803method 62804 "polymorphic with closure" 62805 62806 ^ self! ! 62807 62808!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:09'! 62809remoteReturns 62810 "For closure methods only" 62811 62812 ^ self messages includes: #privRemoteReturnTo:! ! 62813 62814!CompiledMethod methodsFor: 'closures' stamp: 'md 1/20/2006 16:56'! 62815searchImageForHomeMethod 62816 62817 Smalltalk allObjectsDo: [:obj | 62818 obj class == CompiledMethod ifTrue: [ 62819 (obj pointsTo: self) ifTrue: [^ obj searchImageForHomeMethod] 62820 ] ifFalse: [obj class == BlockClosure ifTrue: [ 62821 (obj method == self and: [obj size = 0]) 62822 ifTrue: [^ obj searchImageForHomeMethod] 62823 ]] 62824 ]. 62825 ^ self "must be a loner block method"! ! 62826 62827 62828!CompiledMethod methodsFor: 'comparing' stamp: 'eem 7/29/2008 14:46'! 62829= method 62830 | numLits | 62831 "Answer whether the receiver implements the same code as the 62832 argument, method." 62833 (method isKindOf: CompiledMethod) ifFalse: [^false]. 62834 self size = method size ifFalse: [^false]. 62835 self header = method header ifFalse: [^false]. 62836 self initialPC to: self endPC do: 62837 [:i | (self at: i) = (method at: i) ifFalse: [^false]]. 62838 (numLits := self numLiterals) ~= method numLiterals ifTrue: [^false]. 62839 "``Dont bother checking FFI and named primitives'' 62840 (#(117 120) includes: self primitive) ifTrue: [^ true]." 62841 1 to: numLits do: 62842 [:i| | lit1 lit2 | 62843 lit1 := self literalAt: i. 62844 lit2 := method literalAt: i. 62845 lit1 = lit2 ifFalse: 62846 [(i = 1 and: [#(117 120) includes: self primitive]) 62847 ifTrue: [lit1 isArray 62848 ifTrue: 62849 [(lit2 isArray and: [lit1 allButLast = lit2 allButLast]) ifFalse: 62850 [^false]] 62851 ifFalse: "ExternalLibraryFunction" 62852 [(lit1 analogousCodeTo: lit2) ifFalse: 62853 [^false]]] ifFalse: 62854 [i = (numLits - 1) ifTrue: "properties" 62855 [(lit1 analogousCodeTo: lit2) ifFalse: 62856 [^false]] ifFalse: 62857 [lit1 isFloat 62858 ifTrue: 62859 ["Floats match if values are close, due to roundoff error." 62860 (lit1 closeTo: lit2) ifFalse: [^false]. self flag: 'just checking'. self halt] 62861 ifFalse: 62862 ["any other discrepancy is a failure" 62863 ^ false]]]]]. 62864 ^true! ! 62865 62866!CompiledMethod methodsFor: 'comparing' stamp: 'md 2/16/2006 17:07'! 62867equivalentTo: aCompiledMethod 62868 "does not work yet with non-RB parseTrees" 62869 ^ self = aCompiledMethod 62870 or: [self class == aCompiledMethod class 62871 and: [self numArgs == aCompiledMethod numArgs 62872 and: [self decompile = aCompiledMethod decompile]]].! ! 62873 62874 62875!CompiledMethod methodsFor: 'debugger support' stamp: 'eem 6/5/2008 10:32'! 62876abstractPCForConcretePC: concretePC 62877 "Answer the abstractPC matching concretePC." 62878 62879 | abstractPC scanner client | 62880 self flag: 'belongs in DebuggerMethodMap?'. 62881 abstractPC := 1. 62882 scanner := InstructionStream on: self. 62883 client := InstructionClient new. 62884 [(scanner atEnd 62885 or: [scanner pc >= concretePC]) ifTrue: 62886 [^abstractPC]. 62887 abstractPC := abstractPC + 1. 62888 scanner interpretNextInstructionFor: client. 62889 true] whileTrue! ! 62890 62891!CompiledMethod methodsFor: 'debugger support' stamp: 'eem 6/3/2008 16:15'! 62892blockExtentsInto: aDictionary from: initialPC to: endPC scanner: scanner numberer: numbererBlock 62893 "Support routine for startpcsToBlockExtents" 62894 | extentStart blockSizeOrLocator | 62895 self flag: 'belongs in DebuggerMethodMap'. 62896 extentStart := numbererBlock value. 62897 [scanner pc <= endPC] whileTrue: 62898 [blockSizeOrLocator := scanner interpretNextInstructionFor: BlockStartLocator new. 62899 blockSizeOrLocator isInteger ifTrue: 62900 [self 62901 blockExtentsInto: aDictionary 62902 from: scanner pc 62903 to: scanner pc + blockSizeOrLocator - 1 62904 scanner: scanner 62905 numberer: numbererBlock]]. 62906 aDictionary at: initialPC put: (extentStart to: numbererBlock value). 62907 ^aDictionary! ! 62908 62909!CompiledMethod methodsFor: 'debugger support' stamp: 'eem 6/30/2009 12:37'! 62910blockExtentsToTempsMap 62911 "If the receiver has been copied with temp names answer a 62912 map from blockExtent to temps map in the same format as 62913 BytecodeEncoder>>blockExtentsToTempNamesMap. if the 62914 receiver has not been copied with temps answer nil." 62915 ^self holdsTempNames ifTrue: 62916 [self mapFromBlockKeys: ((self startpcsToBlockExtents associations asSortedCollection: 62917 [:a1 :a2| a1 key < a2 key]) collect: 62918 [:assoc| assoc value]) 62919 toSchematicTemps: self tempNamesString]! ! 62920 62921!CompiledMethod methodsFor: 'debugger support' stamp: 'eem 6/5/2008 09:10'! 62922debuggerMap 62923 ^DebuggerMethodMap forMethod: self! ! 62924 62925!CompiledMethod methodsFor: 'debugger support' stamp: 'emm 5/30/2002 09:22'! 62926hasBreakpoint 62927 ^BreakpointManager methodHasBreakpoint: self! ! 62928 62929!CompiledMethod methodsFor: 'debugger support' stamp: 'eem 6/29/2009 09:48'! 62930mapFromBlockKeys: keys toSchematicTemps: schematicTempNamesString 62931 "Decode a schematicTempNamesString that encodes the layout of temp names 62932 in a method and any closures/blocks within it, matching keys in keys to 62933 vectors of temp names." 62934 | map tempNames | 62935 map := Dictionary new. 62936 tempNames := schematicTempNamesString readStream. 62937 keys do: 62938 [:key| | tempSequence tempIndex | 62939 tempSequence := OrderedCollection new. 62940 tempIndex := 0. 62941 [(tempNames skipSeparators; peek) ifNil: [true] ifNotNil: [:ch| '[]' includes: ch]] whileFalse: 62942 [tempNames peek = $( 62943 ifTrue: [tempSequence addAllLast: ((self tempsSubSequenceFrom: (tempNames next; yourself)) withIndexCollect: 62944 [:temp :index| 62945 { temp. { tempIndex + 1. index } }]). 62946 tempNames peek ~= $) ifTrue: [self error: 'parse error']. 62947 tempIndex := tempIndex + 1. 62948 tempNames next] 62949 ifFalse: [tempSequence addAllLast: ((self tempsSubSequenceFrom: tempNames) withIndexCollect: 62950 [:temp :index| 62951 { temp. tempIndex := tempIndex + 1 }])]]. 62952 map at: key put: tempSequence asArray. 62953 [tempNames peek = $]] whileTrue: [tempNames next]. 62954 tempNames peek = $[ ifTrue: 62955 [tempNames next]]. 62956 ^map! ! 62957 62958!CompiledMethod methodsFor: 'debugger support' stamp: 'eem 6/14/2008 18:58'! 62959pcPreviousTo: pc 62960 | scanner client prevPc | 62961 self flag: 'belongs in DebuggerMethodMap?'. 62962 pc > self endPC ifTrue: [^self endPC]. 62963 scanner := InstructionStream on: self. 62964 client := InstructionClient new. 62965 [scanner pc < pc] whileTrue: 62966 [prevPc := scanner pc. 62967 scanner interpretNextInstructionFor: client]. 62968 ^prevPc! ! 62969 62970!CompiledMethod methodsFor: 'debugger support' stamp: 'eem 6/29/2009 09:50'! 62971startpcsToBlockExtents 62972 "Answer a Dictionary of startpc to Interval of blockExtent, using the 62973 identical numbering scheme described in and orchestrated by 62974 BlockNode>>analyseArguments:temporaries:rootNode:. This is 62975 used in part to find the temp names for any block in a method, as 62976 needed by the debugger. The other half is to recompile the method, 62977 obtaining the temp names for each block extent. By indirecting through 62978 the blockExtent instead of using the startpc directly we decouple the 62979 debugger's access to temp names from the exact bytecode; insulating 62980 debugging from minor changes in the compiler (e.g. changes in literal 62981 pooling, adding prefix bytecodes, adding inst vars to CompiledMethod 62982 in literals towards the end of the literal frame, etc). If the recompilation 62983 doesn't produce exactly the same bytecode at exactly the same offset 62984 no matter; the blockExtents will be the same." 62985 | index | 62986 self flag: 'belongs in DebuggerMethodMap'. 62987 index := 0. 62988 ^self 62989 blockExtentsInto: Dictionary new 62990 from: self initialPC 62991 to: self endPC 62992 scanner: (InstructionStream on: self) 62993 numberer: [| value | value := index. index := index + 2. value]! ! 62994 62995!CompiledMethod methodsFor: 'debugger support' stamp: 'eem 7/1/2009 10:09'! 62996tempsSubSequenceFrom: tempNamesStream 62997 ^Array streamContents: 62998 [:tsss| 62999 [tempNamesStream skipSeparators. 63000 tempNamesStream atEnd 63001 or: ['[]()' includes: tempNamesStream peek]] whileFalse: 63002 [tsss nextPut: (String streamContents: 63003 [:s| 63004 [s nextPut: tempNamesStream next. 63005 tempNamesStream peek 63006 ifNil: [true] 63007 ifNotNil: [:peek| ' []()' includes: peek]] whileFalse])]] 63008 63009 "thisContext method tempsSubSequenceFrom: 'les temps perdu(sont n''est pas la)' readStream" 63010 "thisContext method tempsSubSequenceFrom: ('les temps perdu(sont n''est pas la)' readStream skipTo: $(; yourself)"! ! 63011 63012 63013!CompiledMethod methodsFor: 'decompiling' stamp: 'eem 4/30/2009 18:13'! 63014compilerClass 63015 ^self methodClass 63016 ifNil: [Compiler] 63017 ifNotNil: [:class | class compilerClass].! ! 63018 63019!CompiledMethod methodsFor: 'decompiling' stamp: 'md 2/16/2006 17:08'! 63020decompile 63021 "Return the decompiled parse tree that represents self" 63022 63023 | class selector | 63024 class := self methodClass ifNil: [Object]. 63025 selector := self selector ifNil: [self defaultSelector]. 63026 ^class decompilerClass new decompile: selector in: class method: self.! ! 63027 63028!CompiledMethod methodsFor: 'decompiling' stamp: 'md 2/22/2006 15:59'! 63029decompileWithTemps 63030 "Return the decompiled parse tree that represents self, but get the temp names 63031 by compiling the sourcecode..." 63032 63033 | class selector | 63034 class := self methodClass ifNil: [Object]. 63035 selector := self selector ifNil: [self defaultSelector]. 63036 63037 (self fileIndex > 0 and: [(SourceFiles at: self fileIndex) isNil]) ifTrue: [ 63038 "Emergency or no source file -- decompile without temp names " 63039 ^self decompile. 63040 ]. 63041 ^((self decompilerClass new withTempNames: self methodNode tempNames) 63042 decompile: selector 63043 in: class 63044 method: self)! ! 63045 63046!CompiledMethod methodsFor: 'decompiling' stamp: 'eem 9/5/2009 14:17'! 63047decompilerClass 63048 ^self compilerClass decompilerClass! ! 63049 63050!CompiledMethod methodsFor: 'decompiling' stamp: 'eem 7/6/2009 15:57'! 63051methodNode 63052 "Return the parse tree that represents self" 63053 | aClass source | 63054 aClass := self methodClass. 63055 source := self 63056 getSourceFor: (self selector ifNil: [self defaultSelector]) 63057 in: aClass. 63058 ^(aClass parserClass new 63059 encoderClass: (self isBlueBookCompiled 63060 ifTrue: [EncoderForV3] 63061 ifFalse: [EncoderForV3PlusClosures]); 63062 parse: source class: aClass) 63063 sourceText: source; 63064 yourself! ! 63065 63066!CompiledMethod methodsFor: 'decompiling' stamp: 'alain.plantec 5/18/2009 15:52'! 63067methodNodeFormatted 63068 "Answer a method node made from pretty-printed (and colorized, if decorate is true) 63069 source text." 63070 63071 | class source node | 63072 63073 source := self getSourceFromFile. 63074 class := self methodClass ifNil: [self sourceClass]. 63075 source ifNil: [^self decompile]. 63076 source := class prettyPrinterClass 63077 format: source 63078 in: class 63079 notifying: nil. 63080 node := class parserClass new parse: source class: class. 63081 node sourceText: source. 63082 ^node! ! 63083 63084!CompiledMethod methodsFor: 'decompiling' stamp: 'eem 4/30/2009 18:14'! 63085parserClass 63086 ^self methodClass 63087 ifNil: [Compiler parserClass] 63088 ifNotNil: [:class | class parserClass].! ! 63089 63090 63091!CompiledMethod methodsFor: 'evaluating' stamp: 'ajh 1/28/2003 12:33'! 63092valueWithReceiver: aReceiver arguments: anArray 63093 63094 ^ aReceiver withArgs: anArray executeMethod: self! ! 63095 63096 63097!CompiledMethod methodsFor: 'file in/out' stamp: 'yo 10/28/2004 22:38'! 63098objectForDataStream: refStrm 63099 63100 self primitive = 117 ifTrue: [self literals first at: 4 put: 0]. 63101! ! 63102 63103!CompiledMethod methodsFor: 'file in/out' stamp: 'tk 10/6/2000 14:22'! 63104readDataFrom: aDataStream size: varsOnDisk 63105 "Fill in my fields. My header and number of literals are already installed. Must read both objects for the literals and bytes for the bytecodes." 63106 63107 self error: 'Must use readMethod'.! ! 63108 63109!CompiledMethod methodsFor: 'file in/out' stamp: 'tk 3/26/98 09:10'! 63110storeDataOn: aDataStream 63111 "Store myself on a DataStream. I am a mixture of objects and raw data bytes. Only use this for blocks. Normal methodDictionaries should not be put out using ReferenceStreams. Their fileOut should be attached to the beginning of the file." 63112 63113 | byteLength lits | 63114 "No inst vars of the normal type" 63115 byteLength := self basicSize. 63116 aDataStream 63117 beginInstance: self class 63118 size: byteLength. 63119 lits := self numLiterals + 1. "counting header" 63120 1 to: lits do: 63121 [:ii | aDataStream nextPut: (self objectAt: ii)]. 63122 lits*4+1 to: byteLength do: 63123 [:ii | aDataStream byteStream nextPut: (self basicAt: ii)]. 63124 "write bytes straight through to the file"! ! 63125 63126!CompiledMethod methodsFor: 'file in/out' stamp: 'tk 8/19/1998 16:20'! 63127veryDeepCopyWith: deepCopier 63128 "Return self. I am always shared. Do not record me. Only use this for blocks. Normally methodDictionaries should not be copied this way."! ! 63129 63130!CompiledMethod methodsFor: 'file in/out' stamp: 'RAA 8/21/2001 23:10'! 63131zapSourcePointer 63132 63133 "clobber the source pointer since it will be wrong" 63134 0 to: 3 do: [ :i | self at: self size - i put: 0]. 63135! ! 63136 63137 63138!CompiledMethod methodsFor: 'initialize-release'! 63139copyWithTrailerBytes: bytes 63140"Testing: 63141 (CompiledMethod compiledMethodAt: #copyWithTrailerBytes:) 63142 tempNamesPut: 'copy end ' 63143" 63144 | copy end start | 63145 start := self initialPC. 63146 end := self endPC. 63147 copy := CompiledMethod newMethod: end - start + 1 + bytes size 63148 header: self header. 63149 1 to: self numLiterals do: [:i | copy literalAt: i put: (self literalAt: i)]. 63150 start to: end do: [:i | copy at: i put: (self at: i)]. 63151 1 to: bytes size do: [:i | copy at: end + i put: (bytes at: i)]. 63152 ^ copy! ! 63153 63154!CompiledMethod methodsFor: 'initialize-release' stamp: 'di 10/22/1999 13:14'! 63155needsFrameSize: newFrameSize 63156 "Set the largeFrameBit to accomodate the newFrameSize" 63157 | largeFrameBit header | 63158 largeFrameBit := 16r20000. 63159 (self numTemps + newFrameSize) > LargeFrame ifTrue: 63160 [^ self error: 'Cannot compile -- stack including temps is too deep']. 63161 header := self objectAt: 1. 63162 (header bitAnd: largeFrameBit) ~= 0 63163 ifTrue: [header := header - largeFrameBit]. 63164 self objectAt: 1 put: header 63165 + ((self numTemps + newFrameSize) > SmallFrame 63166 ifTrue: [largeFrameBit] 63167 ifFalse: [0])! ! 63168 63169 63170!CompiledMethod methodsFor: 'literals' stamp: 'eem 5/6/2008 11:28'! 63171allLiterals 63172 ^self literals! ! 63173 63174!CompiledMethod methodsFor: 'literals' stamp: 'eem 11/29/2008 11:37'! 63175hasLiteral: literal 63176 "Answer whether the receiver references the argument, literal." 63177 2 to: self numLiterals - 1 "exclude superclass + selector/properties" 63178 do:[:index | 63179 literal == (self objectAt: index) ifTrue: [^true]]. 63180 ^false! ! 63181 63182!CompiledMethod methodsFor: 'literals' stamp: 'eem 11/29/2008 17:01'! 63183hasLiteralSuchThat: litBlock 63184 "Answer true if litBlock returns true for any literal in this method, even if embedded in array structure." 63185 (self penultimateLiteral isMethodProperties 63186 and: [self penultimateLiteral hasLiteralSuchThat: litBlock]) ifTrue: 63187 [^true]. 63188 2 to: self numLiterals + 1 do: 63189 [:index | | lit | 63190 lit := self objectAt: index. 63191 ((litBlock value: lit) 63192 or: [lit isArray and: [lit hasLiteralSuchThat: litBlock]]) ifTrue: 63193 [^true]]. 63194 ^false! ! 63195 63196!CompiledMethod methodsFor: 'literals' stamp: 'eem 8/7/2009 11:43'! 63197hasLiteralThorough: literal 63198 "Answer true if any literal in this method is literal, 63199 even if embedded in array structure." 63200 63201 (self penultimateLiteral isMethodProperties 63202 and: [self penultimateLiteral hasLiteralThorough: literal]) ifTrue:[^true]. 63203 2 to: self numLiterals - 1 "exclude superclass + selector/properties" 63204 do:[:index | | lit | 63205 ((lit := self objectAt: index) == literal 63206 or: [(lit isVariableBinding and: [lit key == literal]) 63207 or: [lit isArray and: [lit hasLiteral: literal]]]) ifTrue: 63208 [^ true]]. 63209 ^ false ! ! 63210 63211!CompiledMethod methodsFor: 'literals'! 63212header 63213 "Answer the word containing the information about the form of the 63214 receiver and the form of the context needed to run the receiver." 63215 63216 ^self objectAt: 1! ! 63217 63218!CompiledMethod methodsFor: 'literals' stamp: 'eem 7/29/2008 17:23'! 63219headerDescription 63220 "Answer a description containing the information about the form of the 63221 receiver and the form of the context needed to run the receiver." 63222 63223 | s | 63224 s := '' writeStream. 63225 self header printOn: s. 63226 s cr; nextPutAll: '"primitive: '. 63227 self primitive printOn: s. 63228 s cr; nextPutAll: ' numArgs: '. 63229 self numArgs printOn: s. 63230 s cr; nextPutAll: ' numTemps: '. 63231 self numTemps printOn: s. 63232 s cr; nextPutAll: ' numLiterals: '. 63233 self numLiterals printOn: s. 63234 s cr; nextPutAll: ' frameSize: '. 63235 self frameSize printOn: s. 63236 s cr; nextPutAll: ' isClosureCompiled: '. 63237 self isBlueBookCompiled not printOn: s. 63238 s nextPut: $"; cr. 63239 ^ s contents! ! 63240 63241!CompiledMethod methodsFor: 'literals' stamp: 'eem 11/29/2008 11:38'! 63242indexOfLiteral: literal 63243 "Answer the literal index of the argument, literal, or zero if none." 63244 2 to: self numLiterals - 1 "exclude superclass + selector/properties" 63245 do: 63246 [:index | 63247 literal == (self objectAt: index) ifTrue: [^index - 1]]. 63248 ^0! ! 63249 63250!CompiledMethod methodsFor: 'literals'! 63251literalAt: index 63252 "Answer the literal indexed by the argument." 63253 63254 ^self objectAt: index + 1! ! 63255 63256!CompiledMethod methodsFor: 'literals'! 63257literalAt: index put: value 63258 "Replace the literal indexed by the first argument with the second 63259 argument. Answer the second argument." 63260 63261 ^self objectAt: index + 1 put: value! ! 63262 63263!CompiledMethod methodsFor: 'literals' stamp: 'eem 4/30/2009 18:03'! 63264literalStrings 63265 | litStrs | 63266 litStrs := OrderedCollection new: self numLiterals. 63267 self literalsDo: 63268 [:lit | 63269 (lit isVariableBinding) 63270 ifTrue: [litStrs addLast: lit key] 63271 ifFalse: [(lit isSymbol) 63272 ifTrue: [litStrs addAll: lit keywords] 63273 ifFalse: [litStrs addLast: lit printString]]]. 63274 ^ litStrs! ! 63275 63276!CompiledMethod methodsFor: 'literals' stamp: 'marcus.denker 9/29/2008 08:44'! 63277literals 63278 "Answer an Array of the literals referenced by the receiver." 63279 | literals numberLiterals | 63280 literals := Array new: (numberLiterals := self numLiterals). 63281 1 to: numberLiterals do: [:index | 63282 literals at: index put: (self objectAt: index + 1)]. 63283 ^literals! ! 63284 63285!CompiledMethod methodsFor: 'literals' stamp: 'eem 10/28/2008 10:47'! 63286literalsDo: aBlock 63287 "Evaluate aBlock for each of the literals referenced by the receiver." 63288 1 to: self numLiterals do: 63289 [:index | 63290 aBlock value: (self objectAt: index + 1)]! ! 63291 63292!CompiledMethod methodsFor: 'literals'! 63293objectAt: index 63294 "Primitive. Answer the method header (if index=1) or a literal (if index 63295 >1) from the receiver. Essential. See Object documentation 63296 whatIsAPrimitive." 63297 63298 <primitive: 68> 63299 self primitiveFailed! ! 63300 63301!CompiledMethod methodsFor: 'literals'! 63302objectAt: index put: value 63303 "Primitive. Store the value argument into a literal in the receiver. An 63304 index of 2 corresponds to the first literal. Fails if the index is less than 2 63305 or greater than the number of literals. Answer the value as the result. 63306 Normally only the compiler sends this message, because only the 63307 compiler stores values in CompiledMethods. Essential. See Object 63308 documentation whatIsAPrimitive." 63309 63310 <primitive: 69> 63311 self primitiveFailed! ! 63312 63313!CompiledMethod methodsFor: 'literals' stamp: 'JohanBrichau 10/8/2009 10:07'! 63314refersToLiteral: aLiteral 63315 "Answer true if any literal in this method is literal, even if embedded in array structure or within its pragmas." 63316 "only iterate to numLiterals - 1, as the last has the classBinding and the last-but-one needs special treatment" 63317 2 63318 to: self numLiterals - 1 63319 do: 63320 [ :index | 63321 | literal | 63322 literal := self objectAt: index. 63323 literal == aLiteral ifTrue: [ ^ true ]. 63324 (literal refersToLiteral: aLiteral) ifTrue: [ ^ true ] ]. 63325 "last-but-one has the additional method state -or- the method's own selector!!" 63326 ^ (self objectAt: self numLiterals) refersToLiteral: aLiteral. 63327! ! 63328 63329!CompiledMethod methodsFor: 'literals' stamp: 'dvf 11/12/2002 00:44'! 63330sendsSelector: aSymbol 63331 63332 ^ self messages includes: aSymbol! ! 63333 63334 63335!CompiledMethod methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 00:59'! 63336abstractSymbolic 63337 "Answer a String that contains a list of all the byte codes in a method with a 63338 short description of each, using relative addresses and not including code bytes." 63339 63340 | aStream | 63341 aStream := (String new: 1000) writeStream. 63342 self longPrintRelativeOn: aStream indent: 0. 63343 ^aStream contents! ! 63344 63345!CompiledMethod methodsFor: 'printing' stamp: 'stephane.ducasse 8/9/2009 12:05'! 63346asString 63347 63348 ^self getSource! ! 63349 63350!CompiledMethod methodsFor: 'printing' stamp: 'sw 7/29/2002 02:24'! 63351dateMethodLastSubmitted 63352 "Answer a Date object indicating when a method was last submitted. If there is no date stamp, return nil" 63353 "(CompiledMethod compiledMethodAt: #dateMethodLastSubmitted) dateMethodLastSubmitted" 63354 63355 | aStamp tokens | 63356 aStamp := self timeStamp. 63357 tokens := aStamp findBetweenSubStrs: ' 63358'. "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance" 63359 ^ tokens size > 1 63360 ifTrue: 63361 [[tokens second asDate] ifError: [nil]] 63362 ifFalse: 63363 [nil]! ! 63364 63365!CompiledMethod methodsFor: 'printing' stamp: 'md 2/16/2006 13:26'! 63366decompileString 63367 ^self decompile decompileString! ! 63368 63369!CompiledMethod methodsFor: 'printing' stamp: 'ajh 2/9/2003 14:17'! 63370longPrintOn: aStream 63371 "List of all the byte codes in a method with a short description of each" 63372 63373 self longPrintOn: aStream indent: 0! ! 63374 63375!CompiledMethod methodsFor: 'printing' stamp: 'ar 6/28/2003 00:08'! 63376longPrintOn: aStream indent: tabs 63377 "List of all the byte codes in a method with a short description of each" 63378 63379 self isQuick ifTrue: 63380 [self isReturnSpecial ifTrue: 63381 [^ aStream tab: tabs; nextPutAll: 'Quick return ' , 63382 (#('self' 'true' 'false' 'nil' '-1' '0' '1' '2') at: self primitive - 255)]. 63383 ^ aStream nextPutAll: 'Quick return field ' , self returnField printString , ' (0-based)']. 63384 63385 self primitive = 0 ifFalse: [ 63386 aStream tab: tabs. 63387 self printPrimitiveOn: aStream. 63388 ]. 63389 (InstructionPrinter on: self) indent: tabs; printInstructionsOn: aStream. 63390! ! 63391 63392!CompiledMethod methodsFor: 'printing' stamp: 'eem 5/15/2008 10:57'! 63393longPrintRelativeOn: aStream indent: tabs 63394 "List of all the byte codes in a method with a short description of each" 63395 63396 self isQuick ifTrue: 63397 [^self longPrintOn: aStream indent: tabs]. 63398 self primitive = 0 ifFalse: 63399 [aStream tab: tabs. self printPrimitiveOn: aStream]. 63400 (RelativeInstructionPrinter on: self) 63401 indent: tabs; 63402 printCode: false; 63403 printInstructionsOn: aStream. 63404! ! 63405 63406!CompiledMethod methodsFor: 'printing' stamp: 'eem 1/19/2009 10:28'! 63407primitiveErrorVariableName 63408 "Answer the primitive error code temp name, or nil if none." 63409 self primitive > 0 ifTrue: 63410 [self pragmas do: 63411 [:pragma| | kwds ecIndex | 63412 ((kwds := pragma keyword keywords) first = 'primitive:' 63413 and: [(ecIndex := kwds indexOf: 'error:') > 0]) ifTrue: 63414 [^pragma argumentAt: ecIndex]]]. 63415 ^nil! ! 63416 63417!CompiledMethod methodsFor: 'printing' stamp: 'ar 1/9/2008 11:21'! 63418printOn: aStream 63419 "Overrides method inherited from the byte arrayed collection." 63420 63421 self printNameOn: aStream. 63422 aStream nextPut: $(; print: self identityHash; nextPutAll: ': '; 63423 print: self methodClass; nextPutAll: '>>'; nextPutAll: self selector; nextPut: $). 63424 "aStream space; nextPutAll: self identityHashPrintString" 63425! ! 63426 63427!CompiledMethod methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:09'! 63428printOnStream: aStream 63429 "Overrides method inherited from the byte arrayed collection." 63430 63431 aStream print: 'a CompiledMethod'! ! 63432 63433!CompiledMethod methodsFor: 'printing' stamp: 'eem 12/5/2008 09:48'! 63434printPrimitiveOn: aStream 63435 "Print the primitive on aStream" 63436 | primIndex primDecl | 63437 (primIndex := self primitive) = 0 ifTrue: 63438 [^self]. 63439 primIndex = 120 ifTrue: "External call spec" 63440 [^aStream print: (self literalAt: 1); cr]. 63441 aStream nextPutAll: '<primitive: '. 63442 primIndex = 117 63443 ifTrue: 63444 [primDecl := self literalAt: 1. 63445 (primDecl at: 2) asString printOn: aStream. 63446 (primDecl at: 1) ifNotNil: 63447 [:moduleName| 63448 aStream nextPutAll:' module: '. 63449 moduleName asString printOn: aStream]] 63450 ifFalse: 63451 [aStream print: primIndex]. 63452 self primitiveErrorVariableName ifNotNil: 63453 [:primitiveErrorVariableName| 63454 aStream nextPutAll: ' error: '; nextPutAll: primitiveErrorVariableName]. 63455 aStream nextPut: $>; cr! ! 63456 63457!CompiledMethod methodsFor: 'printing'! 63458storeLiteralsOn: aStream forClass: aBehavior 63459 "Store the literals referenced by the receiver on aStream, each terminated by a space." 63460 63461 | literal | 63462 2 to: self numLiterals + 1 do: 63463 [:index | 63464 aBehavior storeLiteral: (self objectAt: index) on: aStream. 63465 aStream space]! ! 63466 63467!CompiledMethod methodsFor: 'printing'! 63468storeOn: aStream 63469 | noneYet | 63470 aStream nextPutAll: '(('. 63471 aStream nextPutAll: self class name. 63472 aStream nextPutAll: ' newMethod: '. 63473 aStream store: self size - self initialPC + 1. 63474 aStream nextPutAll: ' header: '. 63475 aStream store: self header. 63476 aStream nextPut: $). 63477 noneYet := self storeElementsFrom: self initialPC to: self endPC on: aStream. 63478 1 to: self numLiterals do: 63479 [:index | 63480 noneYet 63481 ifTrue: [noneYet := false] 63482 ifFalse: [aStream nextPut: $;]. 63483 aStream nextPutAll: ' literalAt: '. 63484 aStream store: index. 63485 aStream nextPutAll: ' put: '. 63486 aStream store: (self literalAt: index)]. 63487 noneYet ifFalse: [aStream nextPutAll: '; yourself']. 63488 aStream nextPut: $)! ! 63489 63490!CompiledMethod methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 01:00'! 63491symbolic 63492 "Answer a String that contains a list of all the byte codes in a method 63493 with a short description of each." 63494 63495 | aStream | 63496 aStream := (String new: 1000) writeStream. 63497 self longPrintOn: aStream. 63498 ^aStream contents! ! 63499 63500!CompiledMethod methodsFor: 'printing' stamp: 'eem 5/29/2008 13:59'! 63501symbolicLinesDo: aBlock 63502 "Evaluate aBlock with each of the lines in the symbolic output." 63503 63504 | aStream pc | 63505 aStream := ReadWriteStream on: (String new: 64). 63506 self isQuick ifTrue: 63507 [self longPrintOn: aStream. 63508 aBlock value: 0 value: aStream contents. 63509 ^self]. 63510 63511 self primitive ~= 0 ifTrue: 63512 [self printPrimitiveOn: aStream. 63513 aBlock value: 1 value: aStream contents. 63514 aStream resetContents]. 63515 63516 pc := self initialPC. 63517 (InstructionPrinter on: self) 63518 indent: 0; 63519 printPC: false; "explorer provides pc anyway" 63520 printInstructionsOn: aStream 63521 do: [:printer :scanner :stream| | line index | 63522 line := stream contents allButLast. 63523 (line includes: Character cr) ifTrue: 63524 [line := (line copyUpTo: Character cr), '...'' (continues)']. 63525 (index := line indexOf: $>) > 0 ifTrue: 63526 [[(line at: index + 1) isSeparator] whileTrue: [index := index + 1]. 63527 line := ((line copyFrom: 1 to: index) copyReplaceAll: (String with: Character tab) with: (String new: 8 withAll: Character space)), 63528 (line copyFrom: index + 1 to: line size)]. 63529 aBlock value: pc value: line. 63530 pc := scanner pc. 63531 stream resetContents]! ! 63532 63533!CompiledMethod methodsFor: 'printing' stamp: 'AlexandreBergel 7/30/2008 13:32'! 63534timeStamp 63535 "Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available." 63536 63537 "(CompiledMethod compiledMethodAt: #timeStamp) timeStamp" 63538 63539 | file preamble stamp tokens tokenCount | 63540 self fileIndex == 0 ifTrue: [^ String new]. "no source pointer for this method" 63541 file := SourceFiles at: self fileIndex. 63542 file ifNil: [^ String new]. "sources file not available" 63543 "file does not exist happens in secure mode" 63544 file := [file readOnlyCopy] 63545 on: FileDoesNotExistException 63546 do:[:ex| ^ String new]. 63547 preamble := self getPreambleFrom: file at: (0 max: self filePosition - 3). 63548 stamp := String new. 63549 tokens := (preamble findString: 'methodsFor:' startingAt: 1) > 0 63550 ifTrue: [Scanner new scanTokens: preamble] 63551 ifFalse: [Array new "ie cant be back ref"]. 63552 (((tokenCount := tokens size) between: 7 and: 8) and: [(tokens at: tokenCount - 5) = #methodsFor:]) 63553 ifTrue: 63554 [(tokens at: tokenCount - 3) = #stamp: 63555 ifTrue: ["New format gives change stamp and unified prior pointer" 63556 stamp := tokens at: tokenCount - 2]]. 63557 ((tokenCount between: 5 and: 6) and: [(tokens at: tokenCount - 3) = #methodsFor:]) 63558 ifTrue: 63559 [(tokens at: tokenCount - 1) = #stamp: 63560 ifTrue: ["New format gives change stamp and unified prior pointer" 63561 stamp := tokens at: tokenCount]]. 63562 file close. 63563 ^ stamp 63564! ! 63565 63566!CompiledMethod methodsFor: 'printing' stamp: 'eem 6/11/2008 17:08'! 63567who 63568 "Answer an Array of the class in which the receiver is defined and the 63569 selector to which it corresponds." 63570 63571 self hasNewPropertyFormat ifTrue:[^{self methodClass. self selector}]. 63572 self systemNavigation allBehaviorsDo: 63573 [:class | 63574 (class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: 63575 [:sel| ^Array with: class with: sel]]. 63576 ^Array with: #unknown with: #unknown! ! 63577 63578 63579!CompiledMethod methodsFor: 'scanning' stamp: 'md 4/27/2006 15:12'! 63580hasInstVarRef 63581 "Answer whether the method references an instance variable." 63582 63583 | scanner end printer | 63584 63585 scanner := InstructionStream on: self. 63586 printer := InstVarRefLocator new. 63587 end := self endPC. 63588 63589 [scanner pc <= end] whileTrue: [ 63590 (printer interpretNextInstructionUsing: scanner) ifTrue: [^true]. 63591 ]. 63592 ^false! ! 63593 63594!CompiledMethod methodsFor: 'scanning' stamp: 'marcus.denker 9/29/2008 08:50'! 63595messages 63596 "Answer a Set of all the message selectors sent by this method." 63597 63598 | scanner aSet | 63599 aSet := Set new. 63600 scanner := InstructionStream on: self. 63601 scanner scanFor: [:x | 63602 scanner addSelectorTo: aSet. 63603 false "keep scanning"]. 63604 ^aSet! ! 63605 63606!CompiledMethod methodsFor: 'scanning' stamp: 'dvf 11/12/2002 00:44'! 63607messagesDo: aBlock 63608 63609 ^ self messages do:aBlock.! ! 63610 63611!CompiledMethod methodsFor: 'scanning' stamp: 'eem 12/13/2008 15:48'! 63612messagesSequence 63613 "Answer a Set of all the message selectors sent by this method." 63614 63615 ^Array streamContents: 63616 [:str| | scanner | 63617 scanner := InstructionStream on: self. 63618 scanner scanFor: 63619 [:x | | selectorOrSelf | 63620 (selectorOrSelf := scanner selectorToSendOrSelf) == scanner ifFalse: 63621 [str nextPut: selectorOrSelf]. 63622 false "keep scanning"]]! ! 63623 63624!CompiledMethod methodsFor: 'scanning' stamp: 'eem 6/19/2008 09:21'! 63625readsField: varIndex 63626 "Answer whether the receiver loads the instance variable indexed by the 63627 argument." 63628 "eem 5/24/2008 Rewritten to no longer assume the compiler uses the 63629 most compact encoding available (for EncoderForLongFormV3 support)." 63630 | varIndexCode scanner | 63631 varIndexCode := varIndex - 1. 63632 self isReturnField ifTrue: [^self returnField = varIndexCode]. 63633 ^(scanner := InstructionStream on: self) scanFor: 63634 [:b| 63635 b < 16 63636 ifTrue: [b = varIndexCode] 63637 ifFalse: 63638 [b = 128 63639 ifTrue: [scanner followingByte = varIndexCode and: [varIndexCode <= 63]] 63640 ifFalse: 63641 [b = 132 63642 and: [(scanner followingByte between: 64 and: 95) 63643 and: [scanner thirdByte = varIndexCode]]]]]! ! 63644 63645!CompiledMethod methodsFor: 'scanning' stamp: 'eem 5/24/2008 16:19'! 63646readsRef: literalAssociation 63647 "Answer whether the receiver loads the argument." 63648 "eem 5/24/2008 Rewritten to no longer assume the compler uses the 63649 most compact encoding available (for EncoderForLongFormV3 support)." 63650 | litIndex scanner | 63651 (litIndex := self indexOfLiteral: literalAssociation) = 0 ifTrue: 63652 [^false]. 63653 litIndex := litIndex - 1. 63654 ^(scanner := InstructionStream on: self) scanFor: 63655 [:b| 63656 b >= 64 63657 and: 63658 [b <= 95 63659 ifTrue: [b - 64 = litIndex] 63660 ifFalse: 63661 [b = 128 63662 ifTrue: [scanner followingByte - 192 = litIndex] 63663 ifFalse: 63664 [b = 132 63665 and: [(scanner followingByte between: 128 and: 159) 63666 and: [scanner thirdByte = litIndex]]]]]]! ! 63667 63668!CompiledMethod methodsFor: 'scanning'! 63669scanFor: byte 63670 "Answer whether the receiver contains the argument as a bytecode." 63671 63672 ^ (InstructionStream on: self) scanFor: [:instr | instr = byte] 63673" 63674Smalltalk browseAllSelect: [:m | m scanFor: 134] 63675"! ! 63676 63677!CompiledMethod methodsFor: 'scanning'! 63678scanLongLoad: extension 63679 "Answer whether the receiver contains a long load whose extension is the 63680 argument." 63681 63682 | scanner | 63683 scanner := InstructionStream on: self. 63684 ^scanner scanFor: [:instr | instr = 128 and: [scanner followingByte = extension]]! ! 63685 63686!CompiledMethod methodsFor: 'scanning'! 63687scanLongStore: extension 63688 "Answer whether the receiver contains a long store whose extension is 63689 the argument." 63690 | scanner | 63691 scanner := InstructionStream on: self. 63692 ^scanner scanFor: 63693 [:instr | (instr = 129 or: [instr = 130]) and: [scanner followingByte = extension]]! ! 63694 63695!CompiledMethod methodsFor: 'scanning'! 63696scanVeryLongLoad: extension offset: offset 63697 "Answer whether the receiver contains a long load whose extension is the 63698 argument." 63699 | scanner | 63700 scanner := InstructionStream on: self. 63701 ^ scanner scanFor: [:instr | (instr = 132 and: [scanner followingByte = extension]) 63702 and: [scanner thirdByte = offset]]! ! 63703 63704!CompiledMethod methodsFor: 'scanning' stamp: 'eem 6/11/2008 17:07'! 63705scanVeryLongStore: extension offset: offset 63706 "Answer whether the receiver contains a long load with the given offset. 63707 Note that the constant +32 is the known difference between a 63708 store and a storePop for instVars, and it will always fail on literal variables, 63709 but these only use store (followed by pop) anyway." 63710 | scanner | 63711 scanner := InstructionStream on: self. 63712 ^scanner scanFor: 63713 [:instr | | ext | 63714 (instr = 132 and: [(ext := scanner followingByte) = extension 63715 or: ["might be a store/pop into rcvr" 63716 ext = (extension+32)]]) 63717 and: [scanner thirdByte = offset]]! ! 63718 63719!CompiledMethod methodsFor: 'scanning'! 63720sendsToSuper 63721 "Answer whether the receiver sends any message to super." 63722 | scanner | 63723 scanner := InstructionStream on: self. 63724 ^ scanner scanFor: 63725 [:instr | instr = 16r85 or: [instr = 16r84 63726 and: [scanner followingByte between: 16r20 and: 16r3F]]]! ! 63727 63728!CompiledMethod methodsFor: 'scanning' stamp: 'eem 5/24/2008 16:21'! 63729writesField: varIndex 63730 "Answer whether the receiver stores into the instance variable indexed 63731 by the argument." 63732 "eem 5/24/2008 Rewritten to no longer assume the compler uses the 63733 most compact encoding available (for EncoderForLongFormV3 support)." 63734 63735 | varIndexCode scanner | 63736 self isQuick ifTrue: [^false]. 63737 varIndexCode := varIndex - 1. 63738 ^(scanner := InstructionStream on: self) scanFor: 63739 [:b| 63740 b >= 96 63741 and: [b <= 103 63742 ifTrue: [b - 96 = varIndexCode] 63743 ifFalse: 63744 [(b = 129 or: [b = 130]) 63745 ifTrue: [scanner followingByte = varIndexCode and: [varIndexCode <= 63]] 63746 ifFalse: 63747 [b = 132 63748 and: [(scanner followingByte between: 160 and: 223) 63749 and: [scanner thirdByte = varIndexCode]]]]]]! ! 63750 63751!CompiledMethod methodsFor: 'scanning' stamp: 'eem 5/24/2008 16:14'! 63752writesRef: literalAssociation 63753 "Answer whether the receiver stores into the argument." 63754 "eem 5/24/2008 Rewritten to no longer assume the compler uses the 63755 most compact encoding available (for EncoderForLongFormV3 support)." 63756 | litIndex scanner | 63757 (litIndex := self indexOfLiteral: literalAssociation) = 0 ifTrue: 63758 [^false]. 63759 litIndex := litIndex - 1. 63760 ^(scanner := InstructionStream on: self) scanFor: 63761 [:b| 63762 (b = 129 or: [b = 130]) 63763 ifTrue: [scanner followingByte - 192 = litIndex] 63764 ifFalse: 63765 [b = 132 63766 and: [scanner followingByte >= 224 63767 and: [scanner thirdByte = litIndex]]]]! ! 63768 63769 63770!CompiledMethod methodsFor: 'source code management' stamp: 'tk 12/7/2000 12:28'! 63771checkOKToAdd: size at: filePosition 63772 "Issue several warnings as the end of the changes file approaches its limit, 63773 and finally halt with an error when the end is reached." 63774 63775 | fileSizeLimit margin | 63776 fileSizeLimit := 16r2000000. 63777 3 to: 1 by: -1 do: 63778 [:i | margin := i*100000. 63779 (filePosition + size + margin) > fileSizeLimit 63780 ifTrue: [(filePosition + margin) > fileSizeLimit ifFalse: 63781 [self inform: 'WARNING: your changes file is within 63782' , margin printString , ' characters of its size limit. 63783You should take action soon to reduce its size. 63784You may proceed.']] 63785 ifFalse: [^ self]]. 63786 (filePosition + size > fileSizeLimit) ifFalse: [^ self]. 63787 self error: 'You have reached the size limit of the changes file. 63788You must take action now to reduce it. 63789Close this error. Do not attempt to proceed.'! ! 63790 63791!CompiledMethod methodsFor: 'source code management' stamp: 'di 1/7/2004 15:32'! 63792copyWithTempNames: tempNames 63793 | tempStr compressed | 63794 tempStr := String streamContents: 63795 [:strm | tempNames do: [:n | strm nextPutAll: n; space]]. 63796 compressed := self qCompress: tempStr firstTry: true. 63797 compressed ifNil: 63798 ["failure case (tempStr too big) will just decompile with tNN names" 63799 ^ self copyWithTrailerBytes: #(0 0 0 0)]. 63800 ^ self copyWithTrailerBytes: compressed! ! 63801 63802!CompiledMethod methodsFor: 'source code management' stamp: 'eem 6/8/2009 14:32'! 63803copyWithTempsFromMethodNode: aMethodNode 63804 ^self copyWithTrailerBytes: (self qCompress: aMethodNode schematicTempNamesString)! ! 63805 63806!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:44'! 63807fileIndex 63808 ^SourceFiles fileIndexFromSourcePointer: self sourcePointer! ! 63809 63810!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:45'! 63811filePosition 63812 ^SourceFiles filePositionFromSourcePointer: self sourcePointer! ! 63813 63814!CompiledMethod methodsFor: 'source code management' stamp: 'yo 3/16/2004 12:23'! 63815getPreambleFrom: aFileStream at: position 63816 | writeStream | 63817 writeStream := String new writeStream. 63818 position 63819 to: 0 63820 by: -1 63821 do: [:p | 63822 | c | 63823 aFileStream position: p. 63824 c := aFileStream basicNext. 63825 c == $!! 63826 ifTrue: [^ writeStream contents reverse] 63827 ifFalse: [writeStream nextPut: c]]! ! 63828 63829!CompiledMethod methodsFor: 'source code management' stamp: 'AdrianLienhard 10/11/2009 20:28'! 63830getSource 63831 ^ self getSourceFor: self selector in: self methodClass! ! 63832 63833!CompiledMethod methodsFor: 'source code management' stamp: 'AdrianLienhard 10/11/2009 19:52'! 63834getSourceFor: selector in: class 63835 "Retrieve or reconstruct the source code for this method." 63836 | flagByte source | 63837 flagByte := self last. 63838 (flagByte = 0 63839 or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0" 63840 and: [((1 to: 3) allSatisfy: [:i | (self at: self size - i) = 0])]]) 63841 ifTrue: 63842 ["No source pointer -- decompile without temp names" 63843 ^ (class decompilerClass new decompile: selector in: class method: self) 63844 decompileString]. 63845 flagByte < 252 ifTrue: 63846 ["Magic sources -- decompile with temp names" 63847 ^ ((class decompilerClass new withTempNames: self tempNamesString) 63848 decompile: selector in: class method: self) 63849 decompileString]. 63850 63851 "Situation normal; read the sourceCode from the file" 63852 63853 source := [self getSourceFromFile] 63854 on: Error 63855 "An error can happen here if, for example, the changes file has been truncated by an aborted download. The present solution is to ignore the error and fall back on the decompiler. A more thorough solution should probably trigger a systematic invalidation of all source pointers past the end of the changes file. Consider that, as time goes on, the changes file will eventually grow large enough to cover the lost code, and then instead of falling into this error case, random source code will get returned." 63856 do: [ :ex | ex return: nil]. 63857 63858 source ifNotNil: [ ^ source ]. 63859 63860 "Something really wrong -- decompile blind (no temps)" 63861 ^ (class decompilerClass new decompile: selector in: class method: self) 63862 decompileString! ! 63863 63864!CompiledMethod methodsFor: 'source code management' stamp: 'tk 12/12/97 13:03'! 63865getSourceFromFile 63866 "Read the source code from file, determining source file index and 63867 file position from the last 3 bytes of this method." 63868 | position | 63869 (position := self filePosition) = 0 ifTrue: [^ nil]. 63870 ^ (RemoteString newFileNumber: self fileIndex position: position) 63871 text! ! 63872 63873!CompiledMethod methodsFor: 'source code management' stamp: 'eem 5/29/2009 12:16'! 63874holdsTempNames 63875 "Are tempNames stored in trailer bytes" 63876 63877 | flagByte | 63878 flagByte := self last. 63879 (flagByte = 0 or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0" 63880 and: [(1 to: 3) allSatisfy: [:i | (self at: self size - i) = 0]]]) 63881 ifTrue: [^ false]. "No source pointer & no temp names" 63882 flagByte < 252 ifTrue: [^ true]. "temp names compressed" 63883 ^ false "Source pointer" 63884! ! 63885 63886!CompiledMethod methodsFor: 'source code management' stamp: 'damiencassou 5/30/2008 10:56'! 63887linesOfCode 63888 "An approximate measure of lines of code. 63889 Includes comments, but excludes blank lines." 63890 | strm line lines | 63891 lines := 0. 63892 strm := self getSource readStream. 63893 [ strm atEnd ] whileFalse: 63894 [ line := strm upTo: Character cr. 63895 line isEmpty ifFalse: [ lines := lines + 1 ] ]. 63896 ^ lines! ! 63897 63898!CompiledMethod methodsFor: 'source code management'! 63899putSource: sourceStr fromParseNode: methodNode class: class category: catName 63900 inFile: fileIndex priorMethod: priorMethod 63901 63902 ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: 63903 [:file | class printCategoryChunk: catName on: file priorMethod: priorMethod. 63904 file cr]! ! 63905 63906!CompiledMethod methodsFor: 'source code management' stamp: '6/5/97 di'! 63907putSource: sourceStr fromParseNode: methodNode class: class category: catName 63908 withStamp: changeStamp inFile: fileIndex priorMethod: priorMethod 63909 63910 ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: 63911 [:file | 63912 class printCategoryChunk: catName on: file 63913 withStamp: changeStamp priorMethod: priorMethod. 63914 file cr]! ! 63915 63916!CompiledMethod methodsFor: 'source code management' stamp: 'eem 7/1/2009 13:52'! 63917putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock 63918 "Store the source code for the receiver on an external file. 63919 If no sources are available, i.e., SourceFile is nil, then store 63920 temp names for decompilation at the end of the method. 63921 If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes, 63922 in each case, storing a 4-byte source code pointer at the method end." 63923 63924 | file remoteString | 63925 (SourceFiles == nil or: [(file := SourceFiles at: fileIndex) == nil]) ifTrue: 63926 [^self become: (self copyWithTempsFromMethodNode: methodNode)]. 63927 63928 SmalltalkImage current assureStartupStampLogged. 63929 file setToEnd. 63930 63931 preambleBlock value: file. "Write the preamble" 63932 remoteString := RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file. 63933 file nextChunkPut: ' '. 63934 InMidstOfFileinNotification signal ifFalse: [file flush]. 63935 self checkOKToAdd: sourceStr size at: remoteString position. 63936 self setSourcePosition: remoteString position inFile: fileIndex! ! 63937 63938!CompiledMethod methodsFor: 'source code management' stamp: 'eem 7/21/2009 13:26'! 63939qCompress: string 63940 "A very simple text compression routine designed for method temp names. 63941 Most common 11 chars get values 1-11 packed in one 4-bit nibble; 63942 the next most common get values 12-15 (2 bits) * 16 plus next nibble; 63943 unusual ones get three nibbles, the first being the escape nibble 0. 63944 CompiledMethod>>endPC determines the maximum length of encoded 63945 output, which means 1 to (251 - 128) * 128 + 127, or 15871 bytes" 63946 string isEmpty ifTrue: 63947 [^self qCompress: ' ']. 63948 ^ ByteArray streamContents: 63949 [:strm | | ix oddNibble sz | 63950 oddNibble := nil. 63951 string do: 63952 [:char | 63953 ix := 'ear tonsilcmbdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345[]()' 63954 indexOf: char ifAbsent: 0. 63955 (ix = 0 63956 ifTrue: 63957 [char asInteger > 255 ifTrue: [^nil]. "Could use UTF8 here; too lazy right now" 63958 { 0. char asInteger // 16. char asInteger \\ 16 }] 63959 ifFalse: 63960 [ix <= 11 63961 ifTrue: [{ ix }] 63962 ifFalse: [{ ix//16+12. ix\\16 }]]) 63963 do: [:nibble | 63964 oddNibble 63965 ifNotNil: [strm nextPut: oddNibble*16 + nibble. oddNibble := nil] 63966 ifNil: [oddNibble := nibble]]]. 63967 oddNibble ifNotNil: "4 = 'ear tonsil' indexOf: Character space" 63968 [strm nextPut: oddNibble * 16 + 4]. 63969 (sz := strm position) > ((251 - 128) * 128 + 127) ifTrue: 63970 [^nil]. 63971 sz <= 127 63972 ifTrue: [strm nextPut: sz] 63973 ifFalse: 63974 [strm nextPut: sz \\ 128; nextPut: sz // 128 + 128]]! ! 63975 63976!CompiledMethod methodsFor: 'source code management' stamp: 'eem 6/24/2008 14:27'! 63977qCompress: string firstTry: firstTry 63978 "A very simple text compression routine designed for method temp names. 63979 Most common 12 chars get values 0-11 packed in one 4-bit nibble; 63980 others get values 12-15 (2 bits) * 16 plus next nibble. 63981 Last char of str must be a space so it may be dropped without 63982 consequence if output ends on odd nibble. 63983 Normal call is with firstTry == true." 63984 | charTable odd ix oddNibble names shorterStr maybe str temps | 63985 str := string isOctetString 63986 ifTrue: [string] 63987 ifFalse: [temps := string findTokens: ' '. 63988 String 63989 streamContents: [:stream | 1 63990 to: temps size 63991 do: [:index | 63992 stream nextPut: $t. 63993 stream nextPutAll: index asString. 63994 stream space]]]. 63995 charTable := "Character encoding table must match qDecompress:" 63996 ' eatrnoislcm_bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'. 63997 ^ ByteArray streamContents: 63998 [:strm | odd := true. "Flag for odd or even nibble out" 63999 oddNibble := nil. 64000 str do: 64001 [:char | ix := (charTable indexOf: char) - 1. 64002 (ix <= 12 ifTrue: [Array with: ix] 64003 ifFalse: [Array with: ix//16+12 with: ix\\16]) 64004 do: 64005 [:nibble | (odd := odd not) 64006 ifTrue: [strm nextPut: oddNibble*16 + nibble] 64007 ifFalse: [oddNibble := nibble]]]. 64008 strm position > 251 ifTrue: 64009 ["Only values 1...251 are available for the flag byte 64010 that signals compressed temps. See the logic in endPC." 64011 "Before giving up completely, we attempt to encode most of 64012 the temps, but with the last few shortened to tNN-style names." 64013 firstTry ifFalse: [^ nil "already tried --give up now"]. 64014 names := str findTokens: ' '. 64015 names size < 8 ifTrue: [^ nil "weird case -- give up now"]. 64016 4 to: names size//2 by: 4 do: 64017 [:i | shorterStr := String streamContents: 64018 [:s | 64019 1 to: names size - i do: [:j | s nextPutAll: (names at: j); space]. 64020 1 to: i do: [:j | s nextPutAll: 't' , j printString; space]]. 64021 (maybe := self qCompress: shorterStr firstTry: false) ifNotNil: [^ maybe]]. 64022 ^ nil]. 64023 strm nextPut: strm position] 64024" 64025 | m s | m := CompiledMethod new. 64026s := 'charTable odd ix oddNibble '. 64027^ Array with: s size with: (m qCompress: s) size 64028 with: (m qDecompress: (m qCompress: s)) 64029" 64030! ! 64031 64032!CompiledMethod methodsFor: 'source code management' stamp: 'eem 6/24/2008 14:30'! 64033qDecompress: byteArray 64034 "Decompress strings compressed by qCompress:. 64035 Most common 12 chars get values 0-11 packed in one 4-bit nibble; 64036 others get values 12-15 (2 bits) * 16 plus next nibble" 64037 | charTable extended ext | 64038 charTable := "Character encoding table must match qCompress:" 64039 ' eatrnoislcm_bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'. 64040 ^ String streamContents: 64041 [:strm | extended := false. "Flag for 2-nibble characters" 64042 byteArray do: 64043 [:byte | 64044 (Array with: byte//16 with: byte\\16) do: 64045 [:nibble | 64046 extended 64047 ifTrue: [strm nextPut: (charTable at: ext*16+nibble + 1). extended := false] 64048 ifFalse: [nibble < 12 64049 ifTrue: [strm nextPut: (charTable at: nibble + 1)] 64050 ifFalse: [ext := nibble-12. extended := true]]]]]! ! 64051 64052!CompiledMethod methodsFor: 'source code management' stamp: 'eem 6/5/2009 18:07'! 64053qDecompressFrom: input "<ReadStream on: ByteArray> ^<String>" 64054 "Decompress strings compressed by qCompress:. 64055 Most common 11 chars get values 0-10 packed in one 4-bit nibble; 64056 next most common 52 get values 12-15 (2 bits) * 16 plus next nibble; 64057 escaped chars get three nibbles" 64058 ^ String streamContents: 64059 [:strm | | nextNibble nibble peek charTable char | 64060 charTable := "Character encoding table must match qCompress:" 64061 'ear tonsilcmbdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345[]()'. 64062 peek := true. 64063 nextNibble := [peek 64064 ifTrue: [peek := false. input peek ifNil: [0] ifNotNil: [:b| b // 16]] 64065 ifFalse: [peek := true. input next ifNil: [0] ifNotNil: [:b| b \\ 16]]]. 64066 [input atEnd] whileFalse: 64067 [(nibble := nextNibble value) = 0 64068 ifTrue: [input atEnd ifFalse: 64069 [strm nextPut: (Character value: nextNibble value * 16 + nextNibble value)]] 64070 ifFalse: 64071 [nibble <= 11 64072 ifTrue: 64073 [strm nextPut: (charTable at: nibble)] 64074 ifFalse: 64075 [strm nextPut: (charTable at: nibble-12 * 16 + nextNibble value)]]]]! ! 64076 64077!CompiledMethod methodsFor: 'source code management' stamp: 'md 1/20/2006 16:36'! 64078setMySourcePointer: srcPointer 64079 64080 srcPointer = 0 ifTrue: [ 64081 self at: self size put: 0. 64082 ^self]. 64083 (srcPointer between: 16r1000000 and: 16r4FFFFFF) ifFalse: [self error: 'Source pointer out of range']. 64084 self at: self size put: (srcPointer bitShift: -24) + 251. 64085 1 to: 3 do: [:i | 64086 self at: self size-i put: ((srcPointer bitShift: (i-3)*8) bitAnd: 16rFF)]! ! 64087 64088!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 21:00'! 64089setSourcePointer: srcPointer 64090 srcPointer = 0 ifTrue: [ 64091 self at: self size put: 0. 64092 ^self]. 64093 (srcPointer between: 16r1000000 and: 16r4FFFFFF) ifFalse: [self error: 'Source pointer out of range']. 64094 self at: self size put: (srcPointer bitShift: -24) + 251. 64095 1 to: 3 do: [:i | 64096 self at: self size-i put: ((srcPointer bitShift: (i-3)*8) bitAnd: 16rFF)]! ! 64097 64098!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 21:02'! 64099setSourcePosition: position inFile: fileIndex 64100 self setSourcePointer: (SourceFiles sourcePointerFromFileIndex: fileIndex andPosition: position)! ! 64101 64102!CompiledMethod methodsFor: 'source code management' stamp: 'nice 5/1/2009 18:31'! 64103sourceClass 64104 "Get my receiver class (method class) from the preamble of my source. Return nil if not found." 64105 64106 ^ [| theFile | 64107 theFile := self sourceFileStream. 64108 [(Compiler evaluate: (theFile backChunk "blank"; backChunk "preamble")) theClass] ensure: [theFile close]] on: Error do: [nil]! ! 64109 64110!CompiledMethod methodsFor: 'source code management' stamp: 'ajh 8/13/2002 18:18'! 64111sourceFileStream 64112 "Answer the sources file stream with position set at the beginning of my source string" 64113 64114 | pos | 64115 (pos := self filePosition) = 0 ifTrue: [^ nil]. 64116 ^ (RemoteString newFileNumber: self fileIndex position: pos) fileStream! ! 64117 64118!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:44'! 64119sourcePointer 64120 "Answer the integer which can be used to find the source file and position for this method. 64121 The returned value is either 0 (if no source is stored) or a number between 16r1000000 and 16r4FFFFFF. 64122 The actual interpretation of this number is up to the SourceFileArray stored in the global variable SourceFiles." 64123 64124 | pos | 64125 self last < 252 ifTrue: [^ 0 "no source"]. 64126 pos := self last - 251. 64127 self size - 1 to: self size - 3 by: -1 do: [:i | pos := pos * 256 + (self at: i)]. 64128 ^pos! ! 64129 64130!CompiledMethod methodsFor: 'source code management' stamp: 'md 8/2/2006 20:25'! 64131sourceSelector 64132 "Answer my selector extracted from my source. If no source answer nil" 64133 64134 | sourceString | 64135 sourceString := self getSourceFromFile ifNil: [^ nil]. 64136 ^self methodClass parserClass new parseSelector: sourceString! ! 64137 64138!CompiledMethod methodsFor: 'source code management' stamp: 'ajh 7/21/2003 00:29'! 64139tempNames 64140 64141 | byteCount bytes | 64142 self holdsTempNames ifFalse: [ 64143 ^ (1 to: self numTemps) collect: [:i | 't', i printString] 64144 ]. 64145 byteCount := self at: self size. 64146 byteCount = 0 ifTrue: [^ Array new]. 64147 bytes := (ByteArray new: byteCount) 64148 replaceFrom: 1 to: byteCount with: self 64149 startingAt: self size - byteCount. 64150 ^ (self qDecompress: bytes) findTokens: ' '! ! 64151 64152!CompiledMethod methodsFor: 'source code management' stamp: 'eem 6/8/2009 10:29'! 64153tempNamesString 64154 "Decompress the encoded temp names into a schematicTempNames string." 64155 | sz flagByte | 64156 flagByte := self at: (sz := self size). 64157 (flagByte = 0 or: [flagByte > 251]) ifTrue: [^self error: 'not yet implemented']. 64158 (flagByte = 251 64159 and: [(1 to: 3) allSatisfy: [:i | (self at: self size - i) = 0]]) ifTrue: 64160 [^self error: 'not yet implemented']. 64161 ^self qDecompressFrom: (flagByte <= 127 64162 ifTrue: 64163 [ReadStream on: self from: sz - flagByte to: sz - 1] 64164 ifFalse: 64165 [ReadStream on: self from: sz - (flagByte - 128 * 128 + (self at: sz - 1)) - 1 to: sz - 2])! ! 64166 64167 64168!CompiledMethod methodsFor: 'testing' stamp: 'eem 11/29/2008 11:28'! 64169hasNewPropertyFormat 64170 "As of the closure compiler all methods have (or better have) the new 64171 format where the penultimate literal is either the method's selector 64172 or its properties and the ultimate literal is the class association." 64173 ^true! ! 64174 64175!CompiledMethod methodsFor: 'testing' stamp: 'md 1/21/2006 10:54'! 64176hasReportableSlip 64177 "Answer whether the receiver contains anything that should be brought 64178 to the attention of the author when filing out. Customize the lists here 64179 to suit your preferences. If slips do not get reported in spite of your 64180 best efforts here, make certain that the Preference 'checkForSlips' is set 64181 to true." 64182 | assoc | 64183 #(#doOnlyOnce: #halt #halt: #hottest #printDirectlyToDisplay #toRemove #personal #urgent #haltOnce #haltOnce: #haltIf: ) 64184 do: [:aLit | (self hasLiteral: aLit) 64185 ifTrue: [^ true]]. 64186 #(#Transcript #AA #BB #CC #DD #EE ) 64187 do: [:aSymbol | (assoc := Smalltalk 64188 associationAt: aSymbol 64189 ifAbsent: []) 64190 ifNotNil: [(self hasLiteral: assoc) 64191 ifTrue: [^ true]]]. 64192 ^ false! ! 64193 64194!CompiledMethod methodsFor: 'testing' stamp: 'NS 12/12/2003 15:18'! 64195isAbstract 64196 | marker | 64197 marker := self markerOrNil. 64198 ^ marker notNil and: [self class abstractMarkers includes: marker].! ! 64199 64200!CompiledMethod methodsFor: 'testing' stamp: 'eem 7/29/2008 16:51'! 64201isBlueBookCompiled 64202 "Answer whether the receiver was compiled using the closure compiler. 64203 This is used to help DebuggerMethodMap choose which mechanisms to 64204 use to inspect activations of the receiver. 64205 This method answers false negatives in that it only identifies methods 64206 that create old BlockClosures or use the new BlockClosure bytecodes. 64207 It cannot tell if a method which uses neither the old nor the new block 64208 bytecodes is compiled with the blue-book compiler or the new compiler. 64209 But since methods that don't create blocks have essentially the same 64210 code when compiled with either compiler this makes little difference." 64211 64212 ^((InstructionStream on: self) scanFor: 64213 [:instr | 64214 (instr >= 138 and: [instr <= 143]) ifTrue: [^false]. 64215 instr = 200]) 64216 or: [(self hasLiteral: #blockCopy:) 64217 and: [self messages includes: #blockCopy:]]! ! 64218 64219!CompiledMethod methodsFor: 'testing' stamp: 'eem 6/3/2008 13:30'! 64220isClosureCompiled 64221 "Answer whether the receiver was compiled using the closure compiler. 64222 This is used to help DebuggerMethodMap choose which mechanisms to 64223 use to inspect activations of the receiver. 64224 This method answers false negatives in that it only identifies methods 64225 that create new BlockClosures or use the new BlockClosure bytecodes. 64226 But since methods that don't create blocks have essentially the same 64227 code when compiled with either compiler this makes little difference." 64228 64229 ^((InstructionStream on: self) scanFor: [:instr | instr >= 138 and: [instr <= 143]]) 64230 or: [(self hasLiteral: #closureCopy:copiedValues:) 64231 and: [self messages includes: #closureCopy:copiedValues:]]! ! 64232 64233!CompiledMethod methodsFor: 'testing' stamp: 'md 11/21/2003 12:15'! 64234isCompiledMethod 64235 64236 ^ true! ! 64237 64238!CompiledMethod methodsFor: 'testing' stamp: 'al 1/23/2004 13:12'! 64239isConflict 64240 ^ self markerOrNil == self class conflictMarker! ! 64241 64242!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! 64243isDisabled 64244 ^ self isDisabled: self markerOrNil! ! 64245 64246!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! 64247isDisabled: marker 64248 ^ marker == self class disabledMarker! ! 64249 64250!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! 64251isExplicitlyRequired 64252 ^ self isExplicitlyRequired: self markerOrNil! ! 64253 64254!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! 64255isExplicitlyRequired: marker 64256 ^ marker == self class explicitRequirementMarker! ! 64257 64258!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! 64259isImplicitlyRequired 64260 ^ self isImplicitlyRequired: self markerOrNil! ! 64261 64262!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! 64263isImplicitlyRequired: marker 64264 ^ marker == self class implicitRequirementMarker! ! 64265 64266!CompiledMethod methodsFor: 'testing' stamp: 'eem 12/1/2008 11:14'! 64267isInstalled 64268 self methodClass ifNotNil: 64269 [:class| 64270 self selector ifNotNil: 64271 [:selector| 64272 ^self == (class methodDict at: selector ifAbsent: [])]]. 64273 ^false! ! 64274 64275!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:40'! 64276isProvided 64277 ^ self isProvided: self markerOrNil! ! 64278 64279!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:40'! 64280isProvided: marker 64281 marker ifNil: [^ true]. 64282 ^ (self isRequired: marker) not and: [(self isDisabled: marker) not]! ! 64283 64284!CompiledMethod methodsFor: 'testing' stamp: 'di 12/26/1998 21:31'! 64285isQuick 64286 "Answer whether the receiver is a quick return (of self or of an instance 64287 variable)." 64288 ^ self primitive between: 256 and: 519! ! 64289 64290!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'! 64291isRequired 64292 ^ self isRequired: self markerOrNil! ! 64293 64294!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'! 64295isRequired: marker 64296 marker ifNil: [^ false]. 64297 (self isImplicitlyRequired: marker) ifTrue: [^ true]. 64298 (self isExplicitlyRequired: marker) ifTrue: [^ true]. 64299 (self isSubclassResponsibility: marker) ifTrue: [^ true]. 64300 ^ false! ! 64301 64302!CompiledMethod methodsFor: 'testing' stamp: 'ar 6/2/1998 16:11'! 64303isReturnField 64304 "Answer whether the receiver is a quick return of an instance variable." 64305 ^ self primitive between: 264 and: 519! ! 64306 64307!CompiledMethod methodsFor: 'testing'! 64308isReturnSelf 64309 "Answer whether the receiver is a quick return of self." 64310 64311 ^ self primitive = 256! ! 64312 64313!CompiledMethod methodsFor: 'testing'! 64314isReturnSpecial 64315 "Answer whether the receiver is a quick return of self or constant." 64316 64317 ^ self primitive between: 256 and: 263! ! 64318 64319!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'! 64320isSubclassResponsibility 64321 ^ self isSubclassResponsibility: self markerOrNil! ! 64322 64323!CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'! 64324isSubclassResponsibility: marker 64325 ^ marker == self class subclassResponsibilityMarker! ! 64326 64327!CompiledMethod methodsFor: 'testing' stamp: 'eem 6/4/2008 16:19'! 64328usesClosureBytecodes 64329 "Answer whether the receiver was compiled using the closure compiler. 64330 This is used to help DebuggerMethodMap choose which mechanisms to 64331 use to inspect activations of the receiver. 64332 This method answers false negatives in that it only identifies methods 64333 that use the new BlockClosure bytecodes. 64334 But since methods that don't create blocks have essentially the same 64335 code when compiled with either compiler this makes little difference." 64336 64337 ^(InstructionStream on: self) scanFor: [:instr | instr >= 138 and: [instr <= 143]]! ! 64338 64339 64340!CompiledMethod methodsFor: 'private' stamp: 'PeterHugossonMiller 9/2/2009 16:04'! 64341getSourceReplacingSelectorWith: newSelector 64342 | oldKeywords newKeywords args newSelectorWithArgs source oldSelector s | 64343 source := self getSource. 64344 oldSelector := self parserClass new parseSelector: source. 64345 oldSelector = newSelector ifTrue: [ ^ source ]. 64346 oldKeywords := oldSelector keywords. 64347 newKeywords := (newSelector ifNil: [self defaultSelector]) keywords. 64348 self assert: oldKeywords size = newKeywords size. 64349 args := (self methodClass parserClass new 64350 parseArgsAndTemps: source string notifying: nil) copyFrom: 1 to: self numArgs. 64351 newSelectorWithArgs := String streamContents: [:stream | 64352 newKeywords withIndexDo: [:keyword :index | 64353 stream nextPutAll: keyword. 64354 stream space. 64355 args size >= index ifTrue: [ 64356 stream nextPutAll: (args at: index); space]]]. 64357 s := source string readStream. 64358 oldKeywords do: [ :each | s match: each ]. 64359 args isEmpty ifFalse: [ s match: args last ]. 64360 ^newSelectorWithArgs withBlanksTrimmed asText , s upToEnd! ! 64361 64362!CompiledMethod methodsFor: 'private' stamp: 'al 2/13/2006 17:44'! 64363markerOrNil 64364 "If I am a marker method, answer the symbol used to mark me. Otherwise 64365 answer nil. 64366 64367 What is a marker method? It is method with body like 64368 'self subclassResponsibility' or '^ self subclassResponsibility' 64369 used to indicate ('mark') a special property. 64370 64371 Marker methods compile to bytecode like: 64372 64373 9 <70> self 64374 10 <D0> send: <literal 1> 64375 11 <87> pop 64376 12 <78> returnSelf 64377 64378 for the first form, or 64379 64380 9 <70> self 64381 10 <D0> send: <literal 1> 64382 11 <7C> returnTop 64383 64384 for the second form." 64385 64386 | e | 64387 ((e := self endPC) = 19 or: [e = 20]) ifFalse: [^ nil]. 64388 (self numLiterals = 3) ifFalse:[^ nil]. 64389 (self at: 17) = 16r70 ifFalse:[^ nil]. "push self" 64390 (self at: 18) = 16rD0 ifFalse:[^ nil]. "send <literal 1>" 64391 "If we reach this point, we have a marker method that sends self <literal 1>" 64392 ^ self literalAt: 1 64393! ! 64394 64395!CompiledMethod methodsFor: 'private' stamp: 'eem 11/29/2008 11:10'! 64396penultimateLiteral 64397 "Answer the penultimate literal of the receiver, which holds either 64398 the receiver's selector or its properties (which will hold the selector)." 64399 | pIndex | 64400 ^(pIndex := self numLiterals - 1) > 0 64401 ifTrue: [self literalAt: pIndex] 64402 ifFalse: [nil]! ! 64403 64404!CompiledMethod methodsFor: 'private' stamp: 'eem 11/29/2008 11:52'! 64405penultimateLiteral: anObject 64406 "Answer the penultimate literal of the receiver, which holds either 64407 the receiver's selector or its properties (which will hold the selector)." 64408 | pIndex | 64409 (pIndex := self numLiterals - 1) > 0 64410 ifTrue: [self literalAt: pIndex put: anObject] 64411 ifFalse: [self error: 'insufficient literals']! ! 64412 64413!CompiledMethod methodsFor: 'private' stamp: 'md 8/2/2006 20:25'! 64414replace: oldSelector with: newSelector in: aText 64415 | oldKeywords newKeywords args newSelectorWithArgs startOfSource lastSelectorToken | 64416 oldKeywords := oldSelector keywords. 64417 newKeywords := (newSelector ifNil: [self defaultSelector]) keywords. 64418 self assert: oldKeywords size = newKeywords size. 64419 args := (self methodClass parserClass new 64420 parseArgsAndTemps: aText string notifying: nil) copyFrom: 1 to: self numArgs. 64421 newSelectorWithArgs := String streamContents: [:stream | 64422 newKeywords withIndexDo: [:keyword :index | 64423 stream nextPutAll: keyword. 64424 stream space. 64425 args size >= index ifTrue: [ 64426 stream nextPutAll: (args at: index); space]]]. 64427 lastSelectorToken := args isEmpty 64428 ifFalse: [args last] 64429 ifTrue: [oldKeywords last]. 64430 startOfSource := (aText string 64431 indexOfSubCollection: lastSelectorToken startingAt: 1) + lastSelectorToken size. 64432 ^newSelectorWithArgs withBlanksTrimmed asText , (aText copyFrom: startOfSource to: aText size)! ! 64433 64434 64435 64436!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 12/1/2008 16:58'! 64437pragmaAt: aKey 64438 "Answer the pragma with selector aKey, or nil if none." 64439 | propertiesOrSelector | 64440 ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties 64441 ifTrue: [propertiesOrSelector at: aKey ifAbsent: [nil]] 64442 ifFalse: [nil]! ! 64443 64444!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 11/29/2008 16:36'! 64445pragmas 64446 | selectorOrProperties | 64447 ^(selectorOrProperties := self penultimateLiteral) isMethodProperties 64448 ifTrue: [selectorOrProperties pragmas] 64449 ifFalse: [#()]! ! 64450 64451!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 11/29/2008 17:33'! 64452propertyKeysAndValuesDo: aBlock 64453 "Enumerate the receiver with all the keys and values." 64454 64455 | propertiesOrSelector | 64456 (propertiesOrSelector := self penultimateLiteral) isMethodProperties ifTrue: 64457 [propertiesOrSelector propertyKeysAndValuesDo: aBlock]! ! 64458 64459!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 11/29/2008 11:45'! 64460propertyValueAt: propName 64461 | propertiesOrSelector | 64462 ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties 64463 ifTrue: [propertiesOrSelector propertyValueAt: propName ifAbsent: [nil]] 64464 ifFalse: [nil]! ! 64465 64466!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 11/29/2008 11:50'! 64467propertyValueAt: propName ifAbsent: aBlock 64468 | propertiesOrSelector | 64469 ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties 64470 ifTrue: [propertiesOrSelector propertyValueAt: propName ifAbsent: aBlock] 64471 ifFalse: [aBlock value]! ! 64472 64473!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 11/30/2008 08:55'! 64474propertyValueAt: propName put: propValue 64475 "Set or add the property with key propName and value propValue. 64476 If the receiver does not yet have a method properties create one and replace 64477 the selector with it. Otherwise, either relace propValue in the method properties 64478 or replace method properties with one containing the new property." 64479 | propertiesOrSelector | 64480 (propertiesOrSelector := self penultimateLiteral) isMethodProperties ifFalse: 64481 [self penultimateLiteral: ((AdditionalMethodState 64482 selector: propertiesOrSelector 64483 with: (Association 64484 key: propName asSymbol 64485 value: propValue)) 64486 setMethod: self; 64487 yourself). 64488 ^propValue]. 64489 (propertiesOrSelector includesProperty: propName) ifTrue: 64490 [^propertiesOrSelector at: propName put: propValue]. 64491 self penultimateLiteral: (propertiesOrSelector 64492 copyWith: (Association 64493 key: propName asSymbol 64494 value: propValue)). 64495 ^propValue! ! 64496 64497!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 12/1/2008 11:02'! 64498removeProperty: propName 64499 "Remove the property propName if it exists. 64500 Do _not_ raise an error if the property is missing." 64501 | value | 64502 value := self propertyValueAt: propName ifAbsent: [^nil]. 64503 self penultimateLiteral: (self penultimateLiteral copyWithout: 64504 (Association 64505 key: propName 64506 value: value)). 64507 ^value! ! 64508 64509!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 12/1/2008 11:02'! 64510removeProperty: propName ifAbsent: aBlock 64511 "Remove the property propName if it exists. 64512 Answer the evaluation of aBlock if the property is missing." 64513 | value | 64514 value := self propertyValueAt: propName ifAbsent: [^aBlock value]. 64515 self penultimateLiteral: (self penultimateLiteral copyWithout: 64516 (Association 64517 key: propName 64518 value: value)). 64519 ^value! ! 64520 64521"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 64522 64523CompiledMethod class 64524 instanceVariableNames: ''! 64525 64526!CompiledMethod class methodsFor: 'class initialization' stamp: 'di 1/11/1999 22:13'! 64527fullFrameSize "CompiledMethod fullFrameSize" 64528 ^ LargeFrame! ! 64529 64530!CompiledMethod class methodsFor: 'class initialization' stamp: 'eem 6/5/2008 09:05'! 64531initialize "CompiledMethod initialize" 64532 "Initialize class variables specifying the size of the temporary frame 64533 needed to run instances of me." 64534 64535 SmallFrame := 16. "Context range for temps+stack" 64536 LargeFrame := 56! ! 64537 64538!CompiledMethod class methodsFor: 'class initialization' stamp: 'ajh 7/18/2001 02:04'! 64539smallFrameSize 64540 64541 ^ SmallFrame! ! 64542 64543 64544!CompiledMethod class methodsFor: 'constants' stamp: 'NS 12/12/2003 15:17'! 64545abstractMarkers 64546 ^ #(subclassResponsibility shouldNotImplement)! ! 64547 64548!CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! 64549conflictMarker 64550 ^ #traitConflict! ! 64551 64552!CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! 64553disabledMarker 64554 ^ #shouldNotImplement! ! 64555 64556!CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! 64557explicitRequirementMarker 64558 ^ #explicitRequirement! ! 64559 64560!CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! 64561implicitRequirementMarker 64562 ^ #requirement! ! 64563 64564!CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! 64565subclassResponsibilityMarker 64566 ^ #subclassResponsibility! ! 64567 64568 64569!CompiledMethod class methodsFor: 'instance creation' stamp: 'tk 9/9/2000 20:36'! 64570basicNew: size 64571 64572 self error: 'CompiledMethods may only be created with newMethod:header:' ! ! 64573 64574!CompiledMethod class methodsFor: 'instance creation'! 64575new 64576 "This will not make a meaningful method, but it could be used 64577 to invoke some otherwise useful method in this class." 64578 ^ self newMethod: 0 header: 0! ! 64579 64580!CompiledMethod class methodsFor: 'instance creation' stamp: 'tk 1/21/2000 15:25'! 64581new: size 64582 64583 self error: 'CompiledMethods may only be created with newMethod:header:'! ! 64584 64585!CompiledMethod class methodsFor: 'instance creation' stamp: 'md 7/14/2006 21:21'! 64586newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex 64587 "Answer an instance of me. The header is specified by the message 64588 arguments. The remaining parts are not as yet determined." 64589 | largeBit primBits method | 64590 nTemps > 63 ifTrue: 64591 [^ self error: 'Cannot compile -- too many temporary variables']. 64592 nLits > 255 ifTrue: 64593 [^ self error: 'Cannot compile -- too many literals variables']. 64594 largeBit := (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0]. 64595 primBits := primitiveIndex <= 16r1FF 64596 ifTrue: [primitiveIndex] 64597 ifFalse: ["For now the high bit of primitive no. is in the 29th bit of header" 64598 primitiveIndex > 16r3FF ifTrue: [self error: 'prim num too large']. 64599 (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19)]. 64600 method := self newMethod: numberOfBytes + trailer size 64601 header: (nArgs bitShift: 24) + 64602 (nTemps bitShift: 18) + 64603 (largeBit bitShift: 17) + 64604 (nLits bitShift: 9) + 64605 primBits. 64606 1 to: trailer size do: "Copy the source code trailer to the end" 64607 [:i | method at: method size - trailer size + i put: (trailer at: i)]. 64608 ^ method! ! 64609 64610!CompiledMethod class methodsFor: 'instance creation' stamp: 'md 7/14/2006 21:21'! 64611newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex flag: flag 64612 "Answer an instance of me. The header is specified by the message 64613 arguments. The remaining parts are not as yet determined." 64614 | largeBit primBits method flagBit | 64615 nTemps > 63 ifTrue: 64616 [^ self error: 'Cannot compile -- too many temporary variables']. 64617 nLits > 255 ifTrue: 64618 [^ self error: 'Cannot compile -- too many literals variables']. 64619 largeBit := (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0]. 64620 64621 "For now the high bit of the primitive no. is in a high bit of the header" 64622 primBits := (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19). 64623 64624 flagBit := flag ifTrue: [ 1 ] ifFalse: [ 0 ]. 64625 64626 method := self newMethod: numberOfBytes + trailer size 64627 header: (nArgs bitShift: 24) + 64628 (nTemps bitShift: 18) + 64629 (largeBit bitShift: 17) + 64630 (nLits bitShift: 9) + 64631 primBits + 64632 (flagBit bitShift: 29). 64633 64634 "Copy the source code trailer to the end" 64635 1 to: trailer size do: 64636 [:i | method at: method size - trailer size + i put: (trailer at: i)]. 64637 64638 ^ method! ! 64639 64640!CompiledMethod class methodsFor: 'instance creation' stamp: 'NS 12/12/2003 15:03'! 64641newFrom: aCompiledMethod 64642 | inst | 64643 inst := super basicNew: aCompiledMethod size. 64644 1 to: aCompiledMethod size do: [:index | 64645 inst at: index put: (aCompiledMethod at: index)]. 64646 ^ inst.! ! 64647 64648!CompiledMethod class methodsFor: 'instance creation' stamp: 'NS 12/12/2003 15:08'! 64649newInstanceFrom: oldInstance variable: variable size: instSize map: map 64650 "Create a new instance of the receiver based on the given old instance. 64651 The supplied map contains a mapping of the old instVar names into 64652 the receiver's instVars" 64653 | new | 64654 new := self newFrom: oldInstance. 64655 1 to: instSize do: 64656 [:offset | (map at: offset) > 0 ifTrue: 64657 [new instVarAt: offset 64658 put: (oldInstance instVarAt: (map at: offset))]]. 64659 ^new! ! 64660 64661!CompiledMethod class methodsFor: 'instance creation'! 64662newMethod: numberOfBytes header: headerWord 64663 "Primitive. Answer an instance of me. The number of literals (and other 64664 information) is specified the headerWord. The first argument specifies 64665 the number of fields for bytecodes in the method. Fail if either 64666 argument is not a SmallInteger, or if numberOfBytes is negative. Once 64667 the header of a method is set by this primitive, it cannot be changed in 64668 any way. Essential. See Object documentation whatIsAPrimitive." 64669 64670 <primitive: 79> 64671 (numberOfBytes isInteger and: 64672 [headerWord isInteger and: 64673 [numberOfBytes >= 0]]) ifTrue: [ 64674 "args okay; space must be low" 64675 Smalltalk signalLowSpace. 64676 "retry if user proceeds" 64677 ^ self newMethod: numberOfBytes header: headerWord 64678 ]. 64679 ^self primitiveFailed! ! 64680 64681!CompiledMethod class methodsFor: 'instance creation' stamp: 'md 2/20/2006 21:10'! 64682primitive: primNum numArgs: numArgs numTemps: numTemps stackSize: stackSize literals: literals bytecodes: bytecodes trailer: trailerBytes 64683 "Create method with given attributes. numTemps includes numArgs. stackSize does not include numTemps." 64684 64685 | compiledMethod | 64686 compiledMethod := self 64687 newBytes: bytecodes size 64688 trailerBytes: trailerBytes 64689 nArgs: numArgs 64690 nTemps: numTemps 64691 nStack: stackSize 64692 nLits: literals size 64693 primitive: primNum. 64694 (WriteStream with: compiledMethod) 64695 position: compiledMethod initialPC - 1; 64696 nextPutAll: bytecodes. 64697 literals withIndexDo: [:obj :i | compiledMethod literalAt: i put: obj]. 64698 ^ compiledMethod! ! 64699 64700!CompiledMethod class methodsFor: 'instance creation' stamp: 'md 8/5/2005 17:06'! 64701toReturnConstant: index trailerBytes: trailer 64702 "Answer an instance of me that is a quick return of the constant 64703 indexed in (true false nil -1 0 1 2)." 64704 64705 ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 + index 64706! ! 64707 64708!CompiledMethod class methodsFor: 'instance creation' stamp: 'md 8/5/2005 17:06'! 64709toReturnField: field trailerBytes: trailer 64710 "Answer an instance of me that is a quick return of the instance variable 64711 indexed by the argument, field." 64712 64713 ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 264 + field 64714! ! 64715 64716!CompiledMethod class methodsFor: 'instance creation' stamp: 'di 5/25/2000 06:51'! 64717toReturnSelf 64718 "Answer an instance of me that is a quick return of the instance (^self)." 64719 64720 ^ self toReturnSelfTrailerBytes: #(0 0 0 0)! ! 64721 64722!CompiledMethod class methodsFor: 'instance creation' stamp: 'md 8/5/2005 17:05'! 64723toReturnSelfTrailerBytes: trailer 64724 "Answer an instance of me that is a quick return of the instance (^self)." 64725 64726 ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 64727! ! 64728TestCase subclass: #CompiledMethodAsStringTest 64729 instanceVariableNames: '' 64730 classVariableNames: '' 64731 poolDictionaries: '' 64732 category: 'Tests-Compiler'! 64733 64734!CompiledMethodAsStringTest methodsFor: 'running' stamp: 'stephane.ducasse 8/9/2009 12:33'! 64735testCompiledMethodAsString 64736 "self debug: #testCompiledMethodAsString" 64737 64738 self shouldnt: [CompiledMethod allInstances first asString] raise: Error! ! 64739Inspector subclass: #CompiledMethodInspector 64740 instanceVariableNames: '' 64741 classVariableNames: '' 64742 poolDictionaries: '' 64743 category: 'Tools-Inspector'! 64744 64745!CompiledMethodInspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 64746fieldList 64747 64748 | keys | 64749 keys := OrderedCollection new. 64750 keys add: 'self'. 64751 keys add: 'all bytecodes'. 64752 keys add: 'header'. 64753 1 to: object numLiterals do: [ :i | 64754 keys add: 'literal', i printString ]. 64755 object initialPC to: object size do: [ :i | 64756 keys add: i printString ]. 64757 ^ keys asArray 64758 ! ! 64759 64760 64761!CompiledMethodInspector methodsFor: 'selecting' stamp: 'ajh 3/20/2003 00:17'! 64762contentsIsString 64763 "Hacked so contents empty when deselected" 64764 64765 ^ #(0 2 3) includes: selectionIndex! ! 64766 64767!CompiledMethodInspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'! 64768selection 64769 64770 | bytecodeIndex | 64771 selectionIndex = 0 ifTrue: [^ '']. 64772 selectionIndex = 1 ifTrue: [^ object ]. 64773 selectionIndex = 2 ifTrue: [^ object symbolic]. 64774 selectionIndex = 3 ifTrue: [^ object headerDescription]. 64775 selectionIndex <= (object numLiterals + 3) 64776 ifTrue: [ ^ object objectAt: selectionIndex - 2 ]. 64777 bytecodeIndex := selectionIndex - object numLiterals - 3. 64778 ^ object at: object initialPC + bytecodeIndex - 1! ! 64779 64780!CompiledMethodInspector methodsFor: 'selecting' stamp: 'ajh 3/20/2001 11:56'! 64781selectionUnmodifiable 64782 "Answer if the current selected variable is unmodifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable" 64783 64784 ^ true! ! 64785ClassTestCase subclass: #CompiledMethodTest 64786 instanceVariableNames: 'x y' 64787 classVariableNames: '' 64788 poolDictionaries: '' 64789 category: 'KernelTests-Methods'! 64790!CompiledMethodTest commentStamp: '<historical>' prior: 0! 64791This is the unit test for the class CompiledMethod. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 64792 - http://www.c2.com/cgi/wiki?UnitTest 64793 - http://minnow.cc.gatech.edu/squeak/1547 64794 - the sunit class category! 64795 64796 64797!CompiledMethodTest methodsFor: 'examples' stamp: 'sd 4/6/2009 21:27'! 64798readX 64799 | tmp | 64800 tmp := x. 64801 ^ tmp! ! 64802 64803!CompiledMethodTest methodsFor: 'examples' stamp: 'sd 4/6/2009 21:23'! 64804readXandY 64805 64806 ^ x + y 64807 ! ! 64808 64809!CompiledMethodTest methodsFor: 'examples' stamp: 'md 2/18/2006 20:09'! 64810returnPlusOne: anInteger 64811 ^anInteger + 1. ! ! 64812 64813!CompiledMethodTest methodsFor: 'examples' stamp: 'md 2/18/2006 20:09'! 64814returnTrue 64815 ^true ! ! 64816 64817!CompiledMethodTest methodsFor: 'examples' stamp: 'sd 4/6/2009 21:23'! 64818writeX 64819 64820 x := 33 64821 ! ! 64822 64823!CompiledMethodTest methodsFor: 'examples' stamp: 'sd 4/6/2009 21:23'! 64824writeXandY 64825 64826 x := 33. 64827 y := 66 64828 ! ! 64829 64830 64831!CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'md 2/18/2006 20:10'! 64832testMethodClass 64833 | method cls | 64834 method := self class >> #returnTrue. 64835 self assert: method selector = #returnTrue. 64836 "now make an orphaned method by just deleting the class. 64837 old: #unknown 64838 new semantics: return Absolete class" 64839 Smalltalk removeClassNamed: #TUTU. 64840 cls := Object 64841 subclass: #TUTU 64842 instanceVariableNames: '' 64843 classVariableNames: '' 64844 poolDictionaries: '' 64845 category: 'KernelTests-Methods'. 64846 cls compile: 'foo ^ 10'. 64847 method := cls >> #foo. 64848 Smalltalk removeClassNamed: #TUTU. 64849 self assert: method methodClass = cls! ! 64850 64851!CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'md 2/15/2006 20:54'! 64852testSearchForClass 64853 | method cls | 64854 64855 method := (self class)>>#returnTrue. 64856 self assert: (method searchForClass = self class). 64857 64858 "now make an orphaned method. we want to get nil as the class" 64859 64860 Smalltalk removeClassNamed: #TUTU. 64861 64862 cls := Object subclass: #TUTU 64863 instanceVariableNames: '' 64864 classVariableNames: '' 64865 poolDictionaries: '' 64866 category: 'KernelTests-Methods'. 64867 cls compile: 'foo ^ 10'. 64868 method := cls >> #foo. 64869 Smalltalk removeClassNamed: #TUTU. 64870 64871 self assert: method searchForClass = nil. 64872! ! 64873 64874!CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'md 2/15/2006 20:55'! 64875testSearchForSelector 64876 | method cls | 64877 64878 method := (self class)>>#returnTrue. 64879 self assert: (method searchForSelector = #returnTrue). 64880 64881 "now make an orphaned method. we want to get nil as the selector" 64882 64883 Smalltalk removeClassNamed: #TUTU. 64884 64885 cls := Object subclass: #TUTU 64886 instanceVariableNames: '' 64887 classVariableNames: '' 64888 poolDictionaries: '' 64889 category: 'KernelTests-Methods'. 64890 cls compile: 'foo ^ 10'. 64891 method := cls >> #foo. 64892 Smalltalk removeClassNamed: #TUTU. 64893 64894 self assert: method searchForSelector = nil. 64895! ! 64896 64897!CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'md 2/16/2006 20:28'! 64898testSelector 64899 | method cls | 64900 64901 method := (self class)>>#returnTrue. 64902 self assert: (method selector = #returnTrue). 64903 64904 "now make an orphaned method. new semantics: return corrent name" 64905 64906 Smalltalk removeClassNamed: #TUTU. 64907 64908 cls := Object subclass: #TUTU 64909 instanceVariableNames: '' 64910 classVariableNames: '' 64911 poolDictionaries: '' 64912 category: 'KernelTests-Methods'. 64913 cls compile: 'foo ^ 10'. 64914 method := cls >> #foo. 64915 Smalltalk removeClassNamed: #TUTU. 64916 64917 self assert: method selector = #foo. 64918! ! 64919 64920 64921!CompiledMethodTest methodsFor: 'tests - decompiling' stamp: 'md 2/16/2006 20:29'! 64922testDecompile 64923 "self debug: #testDecompileTree" 64924 | method cls stream | 64925 64926 Smalltalk removeClassNamed: #TUTU. 64927 64928 cls := Object subclass: #TUTU 64929 instanceVariableNames: '' 64930 classVariableNames: '' 64931 poolDictionaries: '' 64932 category: 'KernelTests-Methods'. 64933 cls compile: 'foo ^ 10'. 64934 method := cls >> #foo. 64935 Smalltalk removeClassNamed: #TUTU. 64936 stream := ReadWriteStream on: String new. 64937 method decompile printOn: stream. 64938 self assert: stream contents = 'foo 64939 ^ 10' 64940 64941 64942 ! ! 64943 64944 64945!CompiledMethodTest methodsFor: 'tests - evaluating' stamp: 'md 4/16/2003 15:30'! 64946testValueWithReceiverArguments 64947 64948 | method value | 64949 64950 method := self class compiledMethodAt: #returnTrue. 64951 64952 value := method valueWithReceiver: nil arguments: #(). 64953 self assert: (value = true). 64954 64955 method := self class compiledMethodAt: #returnPlusOne:. 64956 value := method valueWithReceiver: nil arguments: #(1). 64957 self assert: (value = 2). ! ! 64958 64959 64960!CompiledMethodTest methodsFor: 'tests - instance variable' stamp: 'sd 4/6/2009 21:30'! 64961testHasInstVarRef 64962 "self debug: #testHasInstVarRef" 64963 64964 | method | 64965 method := self class compiledMethodAt: #readX. 64966 self assert: (method hasInstVarRef). 64967 64968 method := self class compiledMethodAt: #readXandY. 64969 self assert: (method hasInstVarRef). 64970 64971 method := self class compiledMethodAt: #writeX. 64972 self assert: (method hasInstVarRef). 64973 64974 method := self class compiledMethodAt: #writeXandY. 64975 self assert: (method hasInstVarRef). 64976 ! ! 64977 64978!CompiledMethodTest methodsFor: 'tests - instance variable' stamp: 'sd 4/6/2009 21:46'! 64979testReadsField 64980 "self debug: #testReadsField" 64981 64982 | method | 64983 method := self class compiledMethodAt: #readX. 64984 self assert: (method readsField: 2). 64985 64986 method := self class compiledMethodAt: #readXandY. 64987 self assert: (method readsField: 3). 64988 64989 64990 "read is not write" 64991 method := self class compiledMethodAt: #writeX. 64992 self deny: (method readsField: 2). 64993 64994 method := self class compiledMethodAt: #writeXandY. 64995 self deny: (method readsField: 2). 64996 64997 method := self class compiledMethodAt: #writeXandY. 64998 self deny: (method readsField: 3).! ! 64999 65000!CompiledMethodTest methodsFor: 'tests - instance variable' stamp: 'sd 4/6/2009 21:48'! 65001testWritesField 65002 "self debug: #testWritesField" 65003 65004 | method | 65005 method := self class compiledMethodAt: #writeX. 65006 self assert: (method writesField: 2). 65007 65008 method := self class compiledMethodAt: #writeXandY. 65009 self assert: (method writesField: 2). 65010 65011 method := self class compiledMethodAt: #writeXandY. 65012 self assert: (method writesField: 3). 65013 65014 "write is not read" 65015 65016 method := self class compiledMethodAt: #readX. 65017 self deny: (method writesField: 2). 65018 65019 method := self class compiledMethodAt: #readXandY. 65020 self deny: (method writesField: 2). 65021 65022 method := self class compiledMethodAt: #readXandY. 65023 self deny: (method writesField: 3).! ! 65024 65025 65026!CompiledMethodTest methodsFor: 'tests - testing' stamp: 'md 2/19/2006 11:28'! 65027testHasNewPropertyFormat 65028 | method | 65029 method := (self class)>>#returnTrue. 65030 self assert: method hasNewPropertyFormat. 65031! ! 65032 65033!CompiledMethodTest methodsFor: 'tests - testing' stamp: 'md 2/18/2006 20:10'! 65034testIsInstalled 65035| method cls | 65036 65037 method := (self class)>>#returnTrue. 65038 self assert: method isInstalled. 65039 65040 "now make an orphaned method by just deleting the class." 65041 65042 Smalltalk removeClassNamed: #TUTU. 65043 65044 cls := Object subclass: #TUTU 65045 instanceVariableNames: '' 65046 classVariableNames: '' 65047 poolDictionaries: '' 65048 category: 'KernelTests-Methods'. 65049 cls compile: 'foo ^ 10'. 65050 method := cls >> #foo. 65051 Smalltalk removeClassNamed: #TUTU. 65052 65053 self deny: method isInstalled. ! ! 65054 65055!CompiledMethodTest methodsFor: 'tests - testing' stamp: 'md 4/16/2003 15:32'! 65056testIsQuick 65057 | method | 65058 65059 method := self class compiledMethodAt: #returnTrue. 65060 self assert: (method isQuick). 65061 65062 method := self class compiledMethodAt: #returnPlusOne:. 65063 self deny: (method isQuick). 65064 65065 ! ! 65066Object subclass: #CompiledMethodWithNode 65067 instanceVariableNames: 'node method' 65068 classVariableNames: '' 65069 poolDictionaries: '' 65070 category: 'Compiler-Support'! 65071 65072!CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:03'! 65073method 65074 ^ method! ! 65075 65076!CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:04'! 65077node 65078 ^ node! ! 65079 65080!CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:04'! 65081selector 65082 ^ self node selector! ! 65083 65084 65085!CompiledMethodWithNode methodsFor: 'private' stamp: 'NS 1/28/2004 09:03'! 65086method: aCompiledMethod 65087 method := aCompiledMethod! ! 65088 65089!CompiledMethodWithNode methodsFor: 'private' stamp: 'NS 1/28/2004 09:04'! 65090node: aMethodNode 65091 node := aMethodNode! ! 65092 65093"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 65094 65095CompiledMethodWithNode class 65096 instanceVariableNames: ''! 65097 65098!CompiledMethodWithNode class methodsFor: 'instance creation' stamp: 'NS 1/28/2004 09:05'! 65099generateMethodFromNode: aMethodNode trailer: bytes 65100 ^ self method: (aMethodNode generate: bytes) node: aMethodNode.! ! 65101 65102!CompiledMethodWithNode class methodsFor: 'instance creation' stamp: 'NS 1/28/2004 09:05'! 65103method: aCompiledMethod node: aMethodNode 65104 ^ self new method: aCompiledMethod; node: aMethodNode.! ! 65105Object subclass: #Compiler 65106 instanceVariableNames: 'sourceStream requestor class category context parser' 65107 classVariableNames: '' 65108 poolDictionaries: '' 65109 category: 'Compiler-Kernel'! 65110!Compiler commentStamp: '<historical>' prior: 0! 65111The compiler accepts Smalltalk source code and compiles it with respect to a given class. The user of the compiler supplies a context so that temporary variables are accessible during compilation. If there is an error, a requestor (usually a kind of StringHolderController) is sent the message notify:at:in: so that the error message can be displayed. If there is no error, then the result of compilation is a MethodNode, which is the root of a parse tree whose nodes are kinds of ParseNodes. The parse tree can be sent messages to (1) generate code for a CompiledMethod (this is done for compiling methods or evaluating expressions); (2) pretty-print the code (for formatting); or (3) produce a map from object code back to source code (used by debugger program-counter selection). See also Parser, Encoder, ParseNode.! 65112 65113 65114!Compiler methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 07:15'! 65115format: textOrStream in: aClass notifying: aRequestor contentsSymbol: aSymbol 65116 "Compile a parse tree from the argument, textOrStream. 65117 Answer a string containing the original code, formatted nicely." 65118 65119 self deprecated: 'Use ''format: in: notifying:'' instead.'. 65120 ^ self format: textOrStream in: aClass notifying: aRequestor! ! 65121 65122 65123!Compiler methodsFor: 'error handling' stamp: 'pavel.krivanek 11/21/2008 16:50'! 65124interactive 65125 65126 ^ UIManager default interactiveParserFor: requestor! ! 65127 65128!Compiler methodsFor: 'error handling'! 65129notify: aString 65130 "Refer to the comment in Object|notify:." 65131 65132 ^self notify: aString at: sourceStream position + 1! ! 65133 65134!Compiler methodsFor: 'error handling' stamp: 'eem 9/25/2008 12:41'! 65135notify: aString at: location 65136 "Refer to the comment in Object|notify:." 65137 65138 ^requestor == nil 65139 ifTrue: [SyntaxErrorNotification 65140 inClass: class 65141 category: category 65142 withCode: 65143 (sourceStream contents 65144 copyReplaceFrom: location 65145 to: location - 1 65146 with: aString) 65147 doitFlag: false 65148 errorMessage: aString 65149 location: location] 65150 ifFalse: [requestor 65151 notify: aString 65152 at: location 65153 in: sourceStream]! ! 65154 65155 65156!Compiler methodsFor: 'public access' stamp: 'md 2/28/2006 10:04'! 65157compile: textOrStream in: aClass classified: aCategory notifying: aRequestor ifFail: failBlock 65158 "Answer a MethodNode for the argument, textOrStream. If the 65159 MethodNode can not be created, notify the argument, aRequestor; if 65160 aRequestor is nil, evaluate failBlock instead. The MethodNode is the root 65161 of a parse tree. It can be told to generate a CompiledMethod to be 65162 installed in the method dictionary of the argument, aClass." 65163 65164 | methodNode | 65165 self from: textOrStream 65166 class: aClass 65167 classified: aCategory 65168 context: nil 65169 notifying: aRequestor. 65170 methodNode := self translate: sourceStream noPattern: false ifFail: failBlock. 65171 methodNode encoder requestor: requestor. 65172 ^methodNode. 65173! ! 65174 65175!Compiler methodsFor: 'public access' stamp: 'md 2/28/2006 10:45'! 65176compile: textOrStream in: aClass notifying: aRequestor ifFail: failBlock 65177 ^self compile: textOrStream in: aClass classified: nil notifying: aRequestor ifFail: failBlock ! ! 65178 65179!Compiler methodsFor: 'public access' stamp: 'vb 8/13/2001 23:11'! 65180compileNoPattern: textOrStream in: aClass context: aContext notifying: aRequestor ifFail: failBlock 65181 "Similar to #compile:in:notifying:ifFail:, but the compiled code is 65182 expected to be a do-it expression, with no message pattern." 65183 65184 self from: textOrStream 65185 class: aClass 65186 context: aContext 65187 notifying: aRequestor. 65188 ^self 65189 translate: sourceStream 65190 noPattern: true 65191 ifFail: failBlock! ! 65192 65193!Compiler methodsFor: 'public access' stamp: 'eem 9/4/2009 08:47'! 65194compiledMethodFor: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag 65195 "Compiles the sourceStream into a parse tree, then generates code 65196 into a method, and answers it. If receiver is not nil, then the text can 65197 refer to instance variables of that receiver (the Inspector uses this). 65198 If aContext is not nil, the text can refer to temporaries in that context 65199 (the Debugger uses this). If aRequestor is not nil, then it will receive a 65200 notify:at: message before the attempt to evaluate is aborted." 65201 65202 | methodNode method | 65203 class := (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class. 65204 self from: textOrStream class: class context: aContext notifying: aRequestor. 65205 methodNode := self translate: sourceStream noPattern: true ifFail: [^failBlock value]. 65206 method := methodNode generate: #(0 0 0 0). 65207 self interactive ifTrue: 65208 [method := method copyWithTempsFromMethodNode: methodNode]. 65209 logFlag ifTrue: 65210 [SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext]. 65211 ^method! ! 65212 65213!Compiler methodsFor: 'public access' stamp: 'sd 1/19/2004 20:58'! 65214evaluate: aString in: aContext to: aReceiver 65215 "evaluate aString in the given context, and return the result. 2/2/96 sw" 65216 | result | 65217 result := self 65218 evaluate: aString 65219 in: aContext 65220 to: aReceiver 65221 notifying: nil 65222 ifFail: [^ #failedDoit]. 65223 ^ result! ! 65224 65225!Compiler methodsFor: 'public access' stamp: 'NS 1/19/2004 09:05'! 65226evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock 65227 ^ self evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: false.! ! 65228 65229!Compiler methodsFor: 'public access' stamp: 'eem 7/1/2009 13:53'! 65230evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag 65231 "Compiles the sourceStream into a parse tree, then generates code into a 65232 method. This method is then installed in the receiver's class so that it 65233 can be invoked. In other words, if receiver is not nil, then the text can 65234 refer to instance variables of that receiver (the Inspector uses this). If 65235 aContext is not nil, the text can refer to temporaries in that context (the 65236 Debugger uses this). If aRequestor is not nil, then it will receive a 65237 notify:at: message before the attempt to evaluate is aborted. Finally, the 65238 compiled method is invoked from here as DoIt or (in the case of 65239 evaluation in aContext) DoItIn:. The method is subsequently removed 65240 from the class, but this will not get done if the invocation causes an 65241 error which is terminated. Such garbage can be removed by executing: 65242 Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: 65243 #DoItIn:]." 65244 65245 | methodNode method value toLog itsSelection itsSelectionString | 65246 class := (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class. 65247 self from: textOrStream class: class context: aContext notifying: aRequestor. 65248 methodNode := self translate: sourceStream noPattern: true ifFail: 65249 [^failBlock value]. 65250 method := methodNode generate: #(0 0 0 0). 65251 self interactive ifTrue: 65252 [method := method copyWithTempsFromMethodNode: methodNode]. 65253 65254 value := receiver 65255 withArgs: (context ifNil: [#()] ifNotNil: [{context}]) 65256 executeMethod: method. 65257 65258 logFlag ifTrue:[ 65259 toLog := ((requestor respondsTo: #selection) 65260 and:[(itsSelection := requestor selection) notNil 65261 and:[(itsSelectionString := itsSelection asString) isEmptyOrNil not]]) 65262 ifTrue:[itsSelectionString] 65263 ifFalse:[sourceStream contents]. 65264 SystemChangeNotifier uniqueInstance evaluated: toLog context: aContext]. 65265 ^ value! ! 65266 65267!Compiler methodsFor: 'public access' stamp: 'alain.plantec 5/18/2009 15:54'! 65268format: textOrStream in: aClass notifying: aRequestor 65269 "Compile a parse tree from the argument, textOrStream. Answer a string containing the original code, formatted nicely. If aBoolean is true, then decorate the resulting text with color and hypertext actions" 65270 | aNode | 65271 self from: textOrStream 65272 class: aClass 65273 context: nil 65274 notifying: aRequestor. 65275 aNode := self format: sourceStream noPattern: false ifFail: [^ nil]. 65276 ^ aNode decompileString! ! 65277 65278!Compiler methodsFor: 'public access' stamp: 'alain.plantec 5/30/2009 22:41'! 65279format: textOrStream in: aClass notifying: aRequestor decorated: aBoolean 65280 self deprecated: #colorWhenPrettyPrintingAsBeenRemoved. 65281 ^ self format: textOrStream in: aClass notifying: aRequestor 65282! ! 65283 65284!Compiler methodsFor: 'public access' stamp: 'marcus.denker 8/17/2008 21:14'! 65285from: textOrStream class: aClass classified: aCategory context: aContext notifying: req 65286 65287 self from: textOrStream class: aClass context: aContext notifying: req. 65288 category := aCategory 65289! ! 65290 65291!Compiler methodsFor: 'public access' stamp: 'eem 5/15/2008 15:11'! 65292parse: textOrStream in: aClass notifying: req 65293 "Compile the argument, textOrStream, with respect to the class, aClass, and 65294 answer the MethodNode that is the root of the resulting parse tree. Notify the 65295 argument, req, if an error occurs. The failBlock is defaulted to an empty block." 65296 65297 self from: textOrStream class: aClass context: nil notifying: req. 65298 ^self parser 65299 parse: sourceStream 65300 class: class 65301 noPattern: false 65302 context: context 65303 notifying: requestor 65304 ifFail: []! ! 65305 65306!Compiler methodsFor: 'public access' stamp: 'eem 5/15/2008 15:13'! 65307parser 65308 65309 parser ifNil: [parser := self parserClass new]. 65310 ^parser! ! 65311 65312!Compiler methodsFor: 'public access' stamp: 'eem 5/15/2008 15:07'! 65313parser: aParser 65314 65315 parser := aParser! ! 65316 65317!Compiler methodsFor: 'public access' stamp: 'eem 5/15/2008 15:05'! 65318parserClass 65319 65320 ^parser ifNil: [self class parserClass] ifNotNil: [parser class]! ! 65321 65322!Compiler methodsFor: 'public access' stamp: 'eem 5/15/2008 15:06'! 65323parserClass: aParserClass 65324 65325 parser := aParserClass new! ! 65326 65327!Compiler methodsFor: 'public access' stamp: 'md 2/20/2006 21:16'! 65328translate: aStream noPattern: noPattern ifFail: failBlock parser: parser 65329 | tree | 65330 tree := parser 65331 parse: aStream 65332 class: class 65333 noPattern: noPattern 65334 context: context 65335 notifying: requestor 65336 ifFail: [^ failBlock value]. 65337 ^ tree! ! 65338 65339 65340!Compiler methodsFor: 'private' stamp: 'eem 5/15/2008 15:10'! 65341format: aStream noPattern: noPattern ifFail: failBlock 65342 ^self parser 65343 parse: aStream 65344 class: class 65345 noPattern: noPattern 65346 context: context 65347 notifying: requestor 65348 ifFail: [^failBlock value]! ! 65349 65350!Compiler methodsFor: 'private' stamp: 'PeterHugossonMiller 9/2/2009 16:05'! 65351from: textOrStream class: aClass context: aContext notifying: req 65352 65353 (textOrStream isKindOf: PositionableStream) 65354 ifTrue: [sourceStream := textOrStream] 65355 ifFalse: [sourceStream := textOrStream asString readStream]. 65356 class := aClass. 65357 context := aContext. 65358 requestor := req! ! 65359 65360!Compiler methodsFor: 'private' stamp: 'eem 5/15/2008 15:11'! 65361translate: aStream noPattern: noPattern ifFail: failBlock 65362 ^self parser 65363 parse: aStream 65364 class: class 65365 category: category 65366 noPattern: noPattern 65367 context: context 65368 notifying: requestor 65369 ifFail: [^failBlock value]! ! 65370 65371"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 65372 65373Compiler class 65374 instanceVariableNames: ''! 65375 65376!Compiler class methodsFor: 'accessing' stamp: 'nk 8/30/2004 07:56'! 65377couldEvaluate: anObject 65378 "Answer true if anObject can be passed to my various #evaluate: methods." 65379 ^anObject isString or: [ anObject isText or: [ anObject isStream ]]! ! 65380 65381!Compiler class methodsFor: 'accessing' stamp: 'md 3/1/2006 21:12'! 65382decompilerClass 65383 ^Decompiler! ! 65384 65385!Compiler class methodsFor: 'accessing' stamp: 'eem 5/15/2008 15:12'! 65386new 65387 ^ super new parser: self parserClass new! ! 65388 65389!Compiler class methodsFor: 'accessing' stamp: 'eem 5/13/2008 11:37'! 65390parserClass 65391 "Answer a parser class to use for parsing methods compiled by instances of the receiver." 65392 65393 ^Parser! ! 65394 65395 65396!Compiler class methodsFor: 'deprecated' stamp: 'stephane.ducasse 6/8/2009 22:31'! 65397format: textOrStream in: aClass notifying: aRequestor contentsSymbol: aSymbol 65398 65399 ^ self new format: textOrStream in: aClass notifying: aRequestor contentsSymbol: aSymbol! ! 65400 65401!Compiler class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 07:50'! 65402format: textOrStream in: aClass notifying: aRequestor decorated: aBoolean 65403 self deprecated: 'colorization when PrettyPrinting has been removed.'. 65404 ^ self format: textOrStream in: aClass notifying: aRequestor 65405! ! 65406 65407 65408!Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 10:07'! 65409evaluate: textOrString 65410 "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, 65411 a Syntax Error view is created rather than notifying any requestor. 65412 Compilation is carried out with respect to nil, i.e., no object, and the 65413 invocation is not logged." 65414 65415 ^self evaluate: textOrString for: nil logged: false! ! 65416 65417!Compiler class methodsFor: 'evaluating'! 65418evaluate: textOrString for: anObject logged: logFlag 65419 "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, 65420 a Syntax Error view is created rather than notifying any requestor." 65421 65422 ^self evaluate: textOrString for: anObject notifying: nil logged: logFlag! ! 65423 65424!Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 09:50'! 65425evaluate: textOrString for: anObject notifying: aController logged: logFlag 65426 "Compile and execute the argument, textOrString with respect to the class 65427 of anObject. If a compilation error occurs, notify aController. If both 65428 compilation and execution are successful then, if logFlag is true, log 65429 (write) the text onto a system changes file so that it can be replayed if 65430 necessary." 65431 65432 ^ self new 65433 evaluate: textOrString 65434 in: nil 65435 to: anObject 65436 notifying: aController 65437 ifFail: [^nil] 65438 logged: logFlag.! ! 65439 65440!Compiler class methodsFor: 'evaluating'! 65441evaluate: textOrString logged: logFlag 65442 "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, 65443 a Syntax Error view is created rather than notifying any requestor. 65444 Compilation is carried out with respect to nil, i.e., no object." 65445 65446 ^self evaluate: textOrString for: nil logged: logFlag! ! 65447 65448!Compiler class methodsFor: 'evaluating'! 65449evaluate: textOrString notifying: aController logged: logFlag 65450 "See Compiler|evaluate:for:notifying:logged:. Compilation is carried out 65451 with respect to nil, i.e., no object." 65452 65453 ^self evaluate: textOrString for: nil notifying: aController logged: logFlag! ! 65454 65455!Compiler class methodsFor: 'evaluating' stamp: 'alain.plantec 5/18/2009 15:53'! 65456format: textOrStream in: aClass notifying: aRequestor 65457 ^self new format: textOrStream in: aClass notifying: aRequestor! ! 65458 65459 65460!Compiler class methodsFor: 'utilities' stamp: 'al 1/13/2006 00:02'! 65461recompileAll 65462 "Recompile all classes, starting with given name." 65463 65464 Smalltalk forgetDoIts. 65465 Smalltalk allClassesAndTraits do: [:classOrTrait | classOrTrait compileAll] displayingProgress: 'Recompiling all classes and traits'. 65466 65467 65468! ! 65469 65470!Compiler class methodsFor: 'utilities' stamp: 'sd 9/25/2004 15:07'! 65471recompileAllFrom: firstName 65472 "Recompile all classes, starting with given name." 65473 65474 Smalltalk forgetDoIts. 65475 Smalltalk allClassesDo: 65476 [:class | class name >= firstName 65477 ifTrue: 65478 [Transcript show: class name; cr. 65479 class compileAll]] 65480 65481 "Compiler recompileAllFrom: 'AAABodyShop'." 65482! ! 65483TestCase subclass: #CompilerExceptionsTest 65484 instanceVariableNames: '' 65485 classVariableNames: '' 65486 poolDictionaries: '' 65487 category: 'Tests-Compiler'! 65488 65489!CompilerExceptionsTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/25/2009 20:27'! 65490griffle | goo |! ! 65491 65492 65493!CompilerExceptionsTest methodsFor: 'emulating' stamp: 'cwp 8/25/2009 20:23'! 65494select 65495 ! ! 65496 65497!CompilerExceptionsTest methodsFor: 'emulating' stamp: 'cwp 8/25/2009 20:23'! 65498selectFrom: start to: end 65499 ! ! 65500 65501!CompilerExceptionsTest methodsFor: 'emulating' stamp: 'cwp 8/25/2009 20:22'! 65502selectionInterval 65503 ^ 1 to: 0! ! 65504 65505!CompilerExceptionsTest methodsFor: 'emulating' stamp: 'cwp 8/25/2009 20:26'! 65506text 65507 ^ self unusedVariableSource! ! 65508 65509 65510!CompilerExceptionsTest methodsFor: 'tests' stamp: 'cwp 8/25/2009 20:25'! 65511testUnknownSelector 65512 self 65513 should: 65514 [self class 65515 compile: 'griffle self reallyHopeThisIsntImplementedAnywhere' 65516 notifying: self] 65517 raise: UnknownSelector! ! 65518 65519 65520!CompilerExceptionsTest methodsFor: 'private' stamp: 'cwp 8/25/2009 20:28'! 65521unusedVariableSource 65522 ^ 'griffle 65523 | goo | 65524 ^ nil'! ! 65525TestCase subclass: #CompilerTest 65526 instanceVariableNames: '' 65527 classVariableNames: '' 65528 poolDictionaries: '' 65529 category: 'Tests-Compiler'! 65530!CompilerTest commentStamp: 'nice 12/3/2007 22:15' prior: 0! 65531CompilerTest is a holder for SUnit test of Compiler! 65532 65533 65534!CompilerTest methodsFor: 'literals' stamp: 'nice 12/3/2007 22:20'! 65535testScaledDecimalLiterals 65536 "Equal ScaledDecimal with different scales should use different slots 65537 This is related to http://bugs.squeak.org/view.php?id=6797" 65538 65539 "This correctly works when evaluated separately" 65540 self deny: (Compiler evaluate: '0.5s1') scale = (Compiler evaluate: '0.5s2') scale. 65541 65542 "But not when evaluated together if literal reduction is too agressive" 65543 self deny: (Compiler evaluate: '0.5s1 scale = 0.5s2 scale').! ! 65544Object subclass: #Complex 65545 instanceVariableNames: 'real imaginary' 65546 classVariableNames: '' 65547 poolDictionaries: '' 65548 category: 'Kernel-Numbers'! 65549!Complex commentStamp: 'mk 10/31/2003 22:19' prior: 0! 65550I represent a complex number. 65551 65552real -- real part of the complex number 65553imaginary -- imaginary part of the complex number 65554 65555Complex number constructors: 65556 65557 5 i 65558 6 + 7 i. 65559 5.6 - 8 i. 65560 Complex real: 10 imaginary: 5. 65561 Complex abs: 5 arg: (Float pi / 4) 65562 65563Arithmetic operation with other complex or non-complex numbers work. 65564 65565 (5 - 6 i) + (-5 + 8 i). "Arithmetic between two complex numbers." 65566 5 * (5 - 6 i). "Arithmetic between a non-complex and a complex number." 65567 65568It is also possible to perform arithmetic operations between a complex number 65569and a array of (complex) numbers: 65570 65571 2 * {1 + 2i. 65572 3 + 4i. 65573 5 + 6i} 65574 65575 5 + 5i * {1 + 2i. 65576 3. 65577 5 + 6i} 65578 65579It behaves analogously as it is with normal numbers and an array. 65580 65581NOTE: Although Complex something similiar to the Smalltalk's Number class, it would 65582not be a good idea to make a Complex to be a subclass of a Number because: 65583- Number is subclass of Magnitude and Complex is certainly not a magnitude. 65584 Complex does not behave very well as a Magnitude. Operations such as 65585 < 65586 > 65587 <= 65588 >= 65589 do not have sense in case of complex numbers. 65590- Methods in the following Number methods' categories do not have sense for a Complex numbers 65591 trucation and round off 65592 testing 65593 intervals 65594 comparing 65595- However the following Number methods' categories do have sense for a Complex number 65596 arithmetic (with the exception of operation 65597 // 65598 \\ 65599 quo: 65600 rem: 65601 mathematical functions 65602 65603Thus Complex is somewhat similar to a Number but it is not a subclass of it. Some operations 65604we would like to inherit (e.g. #abs, #negated, #reciprocal) but some of the Number operation 65605do not have sens to inherit or to overload. Classes are not always neat mechanism. 65606 65607!!!!!! We had to COPY the implementation of the 65608 abs 65609 negated 65610 reciprocal 65611 log: 65612 isZero 65613 reciprocal 65614 ... 65615 methods from the Number class to the Complex class. Awful solution. Now I begin to 65616 appreciate the Self. 65617 65618Missing methods 65619 String | converting | asComplex 65620 Complex | mathematical functions | arcSin 65621 Complex | mathematical functions | arcCos 65622 Complex | mathematical functions | arcTan! 65623 65624 65625!Complex methodsFor: 'accessing' stamp: 'mk 10/27/2003 17:39'! 65626imaginary 65627 ^ imaginary! ! 65628 65629!Complex methodsFor: 'accessing' stamp: 'mk 10/27/2003 17:39'! 65630real 65631 ^ real! ! 65632 65633 65634!Complex methodsFor: 'arithmetic' stamp: 'md 7/21/2004 11:25'! 65635* anObject 65636 "Answer the result of multiplying the receiver by aNumber." 65637 | a b c d newReal newImaginary | 65638 anObject isComplex 65639 ifTrue: 65640 [a := self real. 65641 b := self imaginary. 65642 c := anObject real. 65643 d := anObject imaginary. 65644 newReal := (a * c) - (b * d). 65645 newImaginary := (a * d) + (b * c). 65646 ^ Complex real: newReal imaginary: newImaginary] 65647 ifFalse: 65648 [^ anObject adaptToComplex: self andSend: #*]! ! 65649 65650!Complex methodsFor: 'arithmetic' stamp: 'mk 1/18/2004 23:31'! 65651+ anObject 65652 "Answer the sum of the receiver and aNumber." 65653 | a b c d newReal newImaginary | 65654 anObject isComplex 65655 ifTrue: 65656 [a := self real. 65657 b := self imaginary. 65658 c := anObject real. 65659 d := anObject imaginary. 65660 newReal := a + c. 65661 newImaginary := b + d. 65662 ^ Complex real: newReal imaginary: newImaginary] 65663 ifFalse: 65664 [^ anObject adaptToComplex: self andSend: #+]! ! 65665 65666!Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:45'! 65667- anObject 65668 "Answer the difference between the receiver and aNumber." 65669 | a b c d newReal newImaginary | 65670 anObject isComplex 65671 ifTrue: 65672 [a := self real. 65673 b := self imaginary. 65674 c := anObject real. 65675 d := anObject imaginary. 65676 newReal := a - c. 65677 newImaginary := b - d. 65678 ^ Complex real: newReal imaginary: newImaginary] 65679 ifFalse: 65680 [^ anObject adaptToComplex: self andSend: #-]! ! 65681 65682!Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:45'! 65683/ anObject 65684 "Answer the result of dividing receiver by aNumber" 65685 | a b c d newReal newImaginary | 65686 anObject isComplex ifTrue: 65687 [a := self real. 65688 b := self imaginary. 65689 c := anObject real. 65690 d := anObject imaginary. 65691 newReal := ((a * c) + (b * d)) / ((c * c) + (d * d)). 65692 newImaginary := ((b * c) - (a * d)) / ((c * c) + (d * d)). 65693 ^ Complex real: newReal imaginary: newImaginary]. 65694 ^ anObject adaptToComplex: self andSend: #/.! ! 65695 65696!Complex methodsFor: 'arithmetic' stamp: 'mk 10/27/2003 20:48'! 65697abs 65698 "Answer the distance of the receiver from zero (0 + 0 i)." 65699 65700 ^ ((real * real) + (imaginary * imaginary)) sqrt! ! 65701 65702!Complex methodsFor: 'arithmetic' stamp: 'mk 10/27/2003 22:08'! 65703arg 65704 "Answer the argument of the receiver." 65705 65706 self isZero ifTrue: [self error: 'zero has no argument.']. 65707 0 < real ifTrue: [^ (imaginary / real) arcTan]. 65708 0 = real ifTrue: 65709 [0 < imaginary 65710 ifTrue: [^ Float pi / 2] 65711 ifFalse: [^ (Float pi / 2) negated]]. 65712 real < 0 ifTrue: 65713 [0 <= imaginary 65714 ifTrue: [^ (imaginary / real) arcTan + Float pi] 65715 ifFalse: [^ (imaginary / real) arcTan - Float pi]]! ! 65716 65717!Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:48'! 65718divideFastAndSecureBy: anObject 65719 "Answer the result of dividing receiver by aNumber" 65720 " Both operands are scaled to avoid arithmetic overflow. 65721 This algorithm works for a wide range of values, and it needs only three divisions. 65722 Note: #reciprocal uses #/ for devision " 65723 65724 | r d newReal newImaginary | 65725 anObject isComplex ifTrue: 65726 [anObject real abs > anObject imaginary abs 65727 ifTrue: 65728 [r := anObject imaginary / anObject real. 65729 d := r*anObject imaginary + anObject real. 65730 newReal := r*imaginary + real/d. 65731 newImaginary := r negated * real + imaginary/d. 65732 ] 65733 ifFalse: 65734 [r := anObject real / anObject imaginary. 65735 d := r*anObject real + anObject imaginary. 65736 newReal := r*real + imaginary/d. 65737 newImaginary := r*imaginary - real/d. 65738 ]. 65739 65740 ^ Complex real: newReal imaginary: newImaginary]. 65741 ^ anObject adaptToComplex: self andSend: #/.! ! 65742 65743!Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:48'! 65744divideSecureBy: anObject 65745 "Answer the result of dividing receiver by aNumber" 65746 " Both operands are scaled to avoid arithmetic overflow. This algorithm 65747 works for a wide range of values, but it requires six divisions. 65748 #divideFastAndSecureBy: is also quite good, but it uses only 3 divisions. 65749 Note: #reciprocal uses #/ for devision" 65750 65751 | s ars ais brs bis newReal newImaginary | 65752 anObject isComplex ifTrue: 65753 [s := anObject real abs + anObject imaginary abs. 65754 ars := self real / s. 65755 ais := self imaginary / s. 65756 brs := anObject real / s. 65757 bis := anObject imaginary / s. 65758 s := brs squared + bis squared. 65759 65760 newReal := ars*brs + (ais*bis) /s. 65761 newImaginary := ais*brs - (ars*bis)/s. 65762 ^ Complex real: newReal imaginary: newImaginary]. 65763 ^ anObject adaptToComplex: self andSend: #/.! ! 65764 65765!Complex methodsFor: 'arithmetic' stamp: 'mk 10/27/2003 19:33'! 65766negated 65767 "Answer a Number that is the negation of the receiver." 65768 65769 ^0 - self! ! 65770 65771!Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:47'! 65772reciprocal 65773 "Answer 1 divided by the receiver. Create an error notification if the 65774 receiver is 0." 65775 65776 self = 0 65777 ifTrue: [^ (ZeroDivide dividend: self) signal] 65778 ifFalse: [^1 / self] 65779 ! ! 65780 65781 65782!Complex methodsFor: 'comparing' stamp: 'hmm 11/1/2006 23:29'! 65783= anObject 65784 anObject isNumber ifFalse: [^false]. 65785 anObject isComplex 65786 ifTrue: [^ (real = anObject real) & (imaginary = anObject imaginary)] 65787 ifFalse: [^ anObject adaptToComplex: self andSend: #=]! ! 65788 65789!Complex methodsFor: 'comparing' stamp: 'mk 10/27/2003 20:35'! 65790hash 65791 "Hash is reimplemented because = is implemented." 65792 65793 ^ real hash bitXor: imaginary hash.! ! 65794 65795 65796!Complex methodsFor: 'converting' stamp: 'mk 10/27/2003 21:51'! 65797adaptToCollection: rcvr andSend: selector 65798 "If I am involved in arithmetic with a Collection, return a Collection of 65799 the results of each element combined with me in that expression." 65800 65801 ^ rcvr collect: [:element | element perform: selector with: self]! ! 65802 65803!Complex methodsFor: 'converting' stamp: 'mk 10/27/2003 18:32'! 65804adaptToFloat: rcvr andSend: selector 65805 "If I am involved in arithmetic with a Float, convert it to a Complex number." 65806 ^ rcvr asComplex perform: selector with: self! ! 65807 65808!Complex methodsFor: 'converting' stamp: 'mk 10/27/2003 18:32'! 65809adaptToFraction: rcvr andSend: selector 65810 "If I am involved in arithmetic with a Fraction, convert it to a Complex number." 65811 ^ rcvr asComplex perform: selector with: self! ! 65812 65813!Complex methodsFor: 'converting' stamp: 'mk 10/27/2003 18:31'! 65814adaptToInteger: rcvr andSend: selector 65815 "If I am involved in arithmetic with an Integer, convert it to a Complex number." 65816 ^ rcvr asComplex perform: selector with: self! ! 65817 65818 65819!Complex methodsFor: 'mathematical functions' stamp: 'md 7/16/2004 16:16'! 65820cos 65821 "Answer receiver's cosine." 65822 65823 | iself | 65824 iself := 1 i * self. 65825 ^ (iself exp + iself negated exp) / 2! ! 65826 65827!Complex methodsFor: 'mathematical functions' stamp: 'mk 10/27/2003 21:34'! 65828cosh 65829 "Answer receiver's hyperbolic cosine." 65830 65831 ^ (self exp + self negated exp) / 2! ! 65832 65833!Complex methodsFor: 'mathematical functions' stamp: 'md 7/16/2004 16:16'! 65834exp 65835 "Answer the exponential of the receiver." 65836 65837 ^ real exp * (imaginary cos + (1 i * imaginary sin))! ! 65838 65839!Complex methodsFor: 'mathematical functions' stamp: 'laza 9/26/2005 10:25'! 65840ln 65841 "Answer the natural log of the receiver." 65842 65843 ^ self abs ln + (1 i * self arg)! ! 65844 65845!Complex methodsFor: 'mathematical functions' stamp: 'mk 10/27/2003 22:05'! 65846log: aNumber 65847 "Answer the log base aNumber of the receiver." 65848 65849 ^self ln / aNumber ln! ! 65850 65851!Complex methodsFor: 'mathematical functions' stamp: 'md 7/16/2004 16:16'! 65852sin 65853 "Answer receiver's sine." 65854 65855 | iself | 65856 iself := 1 i * self. 65857 ^ (iself exp - iself negated exp) / 2 i! ! 65858 65859!Complex methodsFor: 'mathematical functions' stamp: 'mk 10/27/2003 21:33'! 65860sinh 65861 "Answer receiver's hyperbolic sine." 65862 65863 ^ (self exp - self negated exp) / 2! ! 65864 65865!Complex methodsFor: 'mathematical functions' stamp: 'md 7/20/2004 12:02'! 65866squared 65867 "Answer the receiver multipled by itself." 65868 65869 ^self * self! ! 65870 65871!Complex methodsFor: 'mathematical functions' stamp: 'mk 10/27/2003 22:04'! 65872tan 65873 "Answer receivers tangent." 65874 65875 ^ self sin / self cos! ! 65876 65877 65878!Complex methodsFor: 'printing' stamp: 'mk 10/27/2003 18:02'! 65879printOn: aStream 65880 real printOn: aStream. 65881 aStream nextPut: Character space. 65882 0 <= imaginary 65883 ifTrue: [aStream nextPut: $+] 65884 ifFalse: [aStream nextPut: $-]. 65885 aStream nextPut: Character space. 65886 imaginary abs printOn: aStream. 65887 aStream nextPut: Character space. 65888 aStream nextPut: $i 65889! ! 65890 65891 65892!Complex methodsFor: 'testing' stamp: 'mk 10/27/2003 17:33'! 65893isComplex 65894 ^ true! ! 65895 65896!Complex methodsFor: 'testing' stamp: 'hmm 11/1/2006 23:34'! 65897isNumber 65898 ^ true! ! 65899 65900!Complex methodsFor: 'testing' stamp: 'mk 10/27/2003 20:06'! 65901isZero 65902 ^ self = 0! ! 65903 65904 65905!Complex methodsFor: 'private' stamp: 'mk 10/27/2003 17:26'! 65906imaginary: aNumber 65907 imaginary := aNumber.! ! 65908 65909!Complex methodsFor: 'private' stamp: 'mk 10/27/2003 17:26'! 65910real: aNumber 65911 real := aNumber.! ! 65912 65913"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 65914 65915Complex class 65916 instanceVariableNames: ''! 65917 65918!Complex class methodsFor: 'instance creation' stamp: 'mk 10/27/2003 21:03'! 65919abs: aNumber1 arg: aNumber2 65920 | real imaginary | 65921 real := aNumber1 * aNumber2 cos. 65922 imaginary := aNumber1 * aNumber2 sin. 65923 ^ real + imaginary i! ! 65924 65925!Complex class methodsFor: 'instance creation' stamp: 'mk 10/27/2003 17:28'! 65926new 65927 ^ self real: 0 imaginary: 0! ! 65928 65929!Complex class methodsFor: 'instance creation' stamp: 'mk 10/27/2003 17:27'! 65930real: aNumber1 imaginary: aNumber2 65931 | newComplex | 65932 newComplex := super new. 65933 newComplex 65934 real: aNumber1; 65935 imaginary: aNumber2. 65936 ^ newComplex! ! 65937SimpleBorder subclass: #ComplexBorder 65938 instanceVariableNames: 'style colors lineStyles' 65939 classVariableNames: '' 65940 poolDictionaries: '' 65941 category: 'Morphic-Borders'! 65942!ComplexBorder commentStamp: 'kfr 10/27/2003 10:18' prior: 0! 65943see BorderedMorph. 65944 65945poly _ polygon250 65946 65947baseColor _ Color blue twiceLighter. 65948border _ (ComplexBorder framed: 10) baseColor: poly color. 65949border frameRectangle: ((100@100 extent: 200@200) insetBy: -5) on: Display getCanvas. 65950baseColor _ Color red twiceLighter. 65951border _ (ComplexBorder framed: 10) baseColor: baseColor. 65952border drawPolygon: {100@100. 300@100. 300@300. 100@300} on: Display getCanvas. 65953 65954border drawPolyPatchFrom: 100@200 via: 100@100 via: 200@100 to: 200@200 on: Display getCanvas. 65955border drawPolyPatchFrom: 100@100 via: 200@100 via: 200@200 to: 100@200 on: Display getCanvas. 65956border drawPolyPatchFrom: 200@100 via: 200@200 via: 100@200 to: 100@100 on: Display getCanvas. 65957border drawPolyPatchFrom: 200@200 via: 100@200 via: 100@100 to: 200@100 on: Display getCanvas. 65958 65959border _ (ComplexBorder raised: 10) baseColor: poly color. 65960border drawPolygon: poly getVertices on: Display getCanvas 65961 65962360 / 16.0 22.5 65963points _ (0 to: 15) collect:[:i| (Point r: 100 degrees: i*22.5) + 200]. 65964Display getCanvas fillOval: (100@100 extent: 200@200) color: baseColor. 65965border drawPolygon: points on: Display getCanvas. 65966 65967-1 to: points size + 1 do:[:i| 65968 border drawPolyPatchFrom: (points atWrap: i) via: (points atWrap: i+1) via: (points atWrap: i+2) to: (points atWrap: i+3) on: Display getCanvas. 65969]. 65970 65971Display getCanvas fillOval: (100@100 extent: 200@200) color: baseColor. 659720 to: 36 do:[:i| 65973 border drawLineFrom: (Point r: 100 degrees: i*10) + 200 to: (Point r: 100 degrees: i+1*10) + 200 65974 on: Display getCanvas. 65975]. 65976drawPolygon: 65977Point r: 1.0 degrees: 10 65978MessageTally spyOn:[ 65979Display deferUpdates: true. 65980t1 _ [1 to: 1000 do:[:i| 65981 border drawLineFrom: (100@100) to: (300@100) on: Display getCanvas. 65982 border drawLineFrom: (300@100) to: (300@300) on: Display getCanvas. 65983 border drawLineFrom: (300@300) to: (100@300) on: Display getCanvas. 65984 border drawLineFrom: (100@300) to: (100@100) on: Display getCanvas]] timeToRun. 65985Display deferUpdates: false. 65986]. 65987 65988MessageTally spyOn:[ 65989Display deferUpdates: true. 65990t2 _ [1 to: 1000 do:[:i| 65991 border drawLine2From: (100@100) to: (300@100) on: Display getCanvas. 65992 border drawLine2From: (300@100) to: (300@300) on: Display getCanvas. 65993 border drawLine2From: (300@300) to: (100@300) on: Display getCanvas. 65994 border drawLine2From: (100@300) to: (100@100) on: Display getCanvas]] timeToRun. 65995Display deferUpdates: false. 65996]. 65997 65998! 65999 66000 66001!ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:13'! 66002colors 66003 ^colors ifNil:[colors := self computeColors].! ! 66004 66005!ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:22'! 66006style 66007 ^style! ! 66008 66009!ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:22'! 66010style: newStyle 66011 style == newStyle ifTrue:[^self]. 66012 style := newStyle. 66013 self releaseCachedState.! ! 66014 66015!ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:14'! 66016widthForRounding 66017 ^0! ! 66018 66019 66020!ComplexBorder methodsFor: 'color tracking' stamp: 'ar 8/25/2001 18:17'! 66021trackColorFrom: aMorph 66022 baseColor ifNil:[self color: aMorph raisedColor].! ! 66023 66024 66025!ComplexBorder methodsFor: 'drawing' stamp: 'aoy 2/17/2003 01:08'! 66026drawLineFrom: startPoint to: stopPoint on: aCanvas 66027 "Here we're using the balloon engine since this is much faster than BitBlt w/ brushes." 66028 66029 | delta length dir cos sin tfm w h w1 w2 h1 h2 fill | 66030 width isPoint 66031 ifTrue: 66032 [w := width x. 66033 h := width y] 66034 ifFalse: [w := h := width]. 66035 w1 := w // 2. 66036 w2 := w - w1. 66037 h1 := h // 2. 66038 h2 := h - h1. 66039 "Compute the rotational transform from (0@0) -> (1@0) to startPoint -> stopPoint" 66040 delta := stopPoint - startPoint. 66041 length := delta r. 66042 dir := length > 1.0e-10 ifTrue: [delta / length] ifFalse: [ 1 @ 0]. 66043 cos := dir dotProduct: 1 @ 0. 66044 sin := dir crossProduct: 1 @ 0. 66045 tfm := (MatrixTransform2x3 new) 66046 a11: cos; 66047 a12: sin; 66048 a21: sin negated; 66049 a22: cos. 66050 "Install the start point offset" 66051 tfm offset: startPoint. 66052 "Now get the fill style appropriate for the given direction" 66053 fill := self fillStyleForDirection: dir. 66054 "And draw..." 66055 aCanvas asBalloonCanvas transformBy: tfm 66056 during: 66057 [:cc | 66058 cc drawPolygon: { 66059 (0 - w1) @ (0 - h1). "top left" 66060 (length + w2) @ (0 - h1). "top right" 66061 (length + w2) @ h2. "bottom right" 66062 (0 - w1) @ h2 "bottom left"} 66063 fillStyle: fill]! ! 66064 66065!ComplexBorder methodsFor: 'drawing' stamp: 'ar 11/26/2001 15:10'! 66066drawPolyPatchFrom: startPoint to: stopPoint on: aCanvas usingEnds: endsArray 66067 66068 | cos sin tfm fill dir fsOrigin fsDirection points x y | 66069 dir := (stopPoint - startPoint) normalized. 66070 "Compute the rotational transform from (0@0) -> (1@0) to startPoint -> stopPoint" 66071 cos := dir dotProduct: (1@0). 66072 sin := dir crossProduct: (1@0). 66073 "Now get the fill style appropriate for the given direction" 66074 fill := self fillStyleForDirection: dir. 66075false ifTrue:[ 66076 "Transform the fill appropriately" 66077 fill := fill clone. 66078 "Note: Code below is inlined from tfm transformPoint:/transformDirection:" 66079 x := fill origin x. y := fill origin y. 66080 fsOrigin := ((x * cos) + (y * sin) + startPoint x) @ 66081 ((y * cos) - (x * sin) + startPoint y). 66082 x := fill direction x. y := fill direction y. 66083 fsDirection := ((x * cos) + (y * sin)) @ ((y * cos) - (x * sin)). 66084 fill origin: fsOrigin; 66085 direction: fsDirection rounded; "NOTE: This is a bug in the balloon engine!!!!!!" 66086 normal: nil. 66087 aCanvas asBalloonCanvas drawPolygon: endsArray fillStyle: fill. 66088] ifFalse:[ 66089 "Transform the points rather than the fills" 66090 tfm := (MatrixTransform2x3 new) a11: cos; a12: sin; a21: sin negated; a22: cos. 66091 "Install the start point offset" 66092 tfm offset: startPoint. 66093 points := endsArray collect:[:pt| tfm invertPoint: pt]. 66094 aCanvas asBalloonCanvas transformBy: tfm during:[:cc| 66095 cc drawPolygon: points fillStyle: fill. 66096 ]. 66097].! ! 66098 66099!ComplexBorder methodsFor: 'drawing' stamp: 'ar 9/4/2001 19:51'! 66100framePolygon2: vertices on: aCanvas 66101 | dir1 dir2 dir3 nrm1 nrm2 nrm3 point1 point2 point3 66102 cross1 cross2 pointA pointB pointC pointD w p1 p2 p3 p4 balloon ends | 66103 balloon := aCanvas asBalloonCanvas. 66104 balloon == aCanvas ifFalse:[balloon deferred: true]. 66105 ends := Array new: 4. 66106 w := width * 0.5. 66107 pointA := nil. 66108 1 to: vertices size do:[:i| 66109 p1 := vertices atWrap: i. 66110 p2 := vertices atWrap: i+1. 66111 p3 := vertices atWrap: i+2. 66112 p4 := vertices atWrap: i+3. 66113 66114 dir1 := p2 - p1. 66115 dir2 := p3 - p2. 66116 dir3 := p4 - p3. 66117 66118 i = 1 ifTrue:[ 66119 "Compute the merge points of p1->p2 with p2->p3" 66120 cross1 := dir2 crossProduct: dir1. 66121 nrm1 := dir1 normalized. nrm1 := (nrm1 y * w) @ (0 - nrm1 x * w). 66122 nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w). 66123 cross1 < 0 ifTrue:[nrm1 := nrm1 negated. nrm2 := nrm2 negated]. 66124 point1 := (p1 x + nrm1 x) @ (p1 y + nrm1 y). 66125 point2 := (p2 x + nrm2 x) @ (p2 y + nrm2 y). 66126 pointA := self intersectFrom: point1 with: dir1 to: point2 with: dir2. 66127 point1 := (p1 x - nrm1 x) @ (p1 y - nrm1 y). 66128 point2 := (p2 x - nrm2 x) @ (p2 y - nrm2 y). 66129 pointB := self intersectFrom: point1 with: dir1 to: point2 with: dir2. 66130 pointB ifNotNil:[ 66131 (pointB x - p2 x) abs + (pointB y - p2 y) abs > (4*w) ifTrue:[pointA := pointB := nil]. 66132 ]. 66133 ]. 66134 66135 "Compute the merge points of p2->p3 with p3->p4" 66136 cross2 := dir3 crossProduct: dir2. 66137 nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w). 66138 nrm3 := dir3 normalized. nrm3 := (nrm3 y * w) @ (0 - nrm3 x * w). 66139 cross2 < 0 ifTrue:[nrm2 := nrm2 negated. nrm3 := nrm3 negated]. 66140 point2 := (p2 x + nrm2 x) @ (p2 y + nrm2 y). 66141 point3 := (p3 x + nrm3 x) @ (p3 y + nrm3 y). 66142 pointC := self intersectFrom: point2 with: dir2 to: point3 with: dir3. 66143 point2 := (p2 x - nrm2 x) @ (p2 y - nrm2 y). 66144 point3 := (p3 x - nrm3 x) @ (p3 y - nrm3 y). 66145 pointD := self intersectFrom: point2 with: dir2 to: point3 with: dir3. 66146 pointD ifNotNil:[ 66147 (pointD x - p3 x) abs + (pointD y - p3 y) abs > (4*w) ifTrue:[pointC := pointD := nil]. 66148 ]. 66149 cross1 * cross2 < 0.0 ifTrue:[ 66150 point1 := pointA. 66151 pointA := pointB. 66152 pointB := point1. 66153 cross1 := 0.0 - cross1]. 66154 ends at: 1 put: pointA; at: 2 put: pointB; at: 3 put: pointD; at: 4 put: pointC. 66155 pointA ifNil:["degenerate and slow" 66156 nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w). 66157 cross1 < 0 ifTrue:[nrm2 := nrm2 negated]. 66158 point2 := (p2 x + nrm2 x) @ (p2 y + nrm2 y). 66159 ends at: 1 put: point2]. 66160 pointB ifNil:["degenerate and slow" 66161 nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w). 66162 cross1 < 0 ifTrue:[nrm2 := nrm2 negated]. 66163 point2 := (p2 x - nrm2 x) @ (p2 y - nrm2 y). 66164 ends at: 2 put: point2]. 66165 pointC ifNil:["degenerate and slow" 66166 nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w). 66167 cross2 < 0 ifTrue:[nrm2 := nrm2 negated]. 66168 point2 := (p3 x + nrm2 x) @ (p3 y + nrm2 y). 66169 ends at: 4 put: point2]. 66170 pointD ifNil:["degenerate and slow" 66171 nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w). 66172 cross2 < 0 ifTrue:[nrm2 := nrm2 negated]. 66173 point2 := (p3 x - nrm2 x) @ (p3 y - nrm2 y). 66174 ends at: 3 put: point2]. 66175 66176 self drawPolyPatchFrom: p2 to: p3 on: balloon usingEnds: ends. 66177 pointA := pointC. 66178 pointB := pointD. 66179 cross1 := cross2. 66180 ]. 66181 balloon == aCanvas ifFalse:[balloon flush].! ! 66182 66183!ComplexBorder methodsFor: 'drawing' stamp: 'ar 9/4/2001 19:50'! 66184framePolygon: vertices on: aCanvas 66185 | dir1 dir2 dir3 nrm1 nrm2 nrm3 point1 point2 point3 66186 cross1 cross2 pointA pointB pointC pointD w p1 p2 p3 p4 balloon ends pointE pointF | 66187 balloon := aCanvas asBalloonCanvas. 66188 balloon == aCanvas ifFalse:[balloon deferred: true]. 66189 ends := Array new: 6. 66190 w := width * 0.5. 66191 pointA := nil. 66192 1 to: vertices size do:[:i| 66193 p1 := vertices atWrap: i. 66194 p2 := vertices atWrap: i+1. 66195 p3 := vertices atWrap: i+2. 66196 p4 := vertices atWrap: i+3. 66197 66198 dir1 := p2 - p1. 66199 dir2 := p3 - p2. 66200 dir3 := p4 - p3. 66201 66202 (i = 1 | true) ifTrue:[ 66203 "Compute the merge points of p1->p2 with p2->p3" 66204 cross1 := dir2 crossProduct: dir1. 66205 nrm1 := dir1 normalized. nrm1 := (nrm1 y * w) @ (0 - nrm1 x * w). 66206 nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w). 66207 cross1 < 0 ifTrue:[nrm1 := nrm1 negated. nrm2 := nrm2 negated]. 66208 point1 := (p1 x + nrm1 x) @ (p1 y + nrm1 y). 66209 point2 := (p2 x + nrm2 x) @ (p2 y + nrm2 y). 66210 pointA := self intersectFrom: point1 with: dir1 to: point2 with: dir2. 66211 point1 := (p1 x - nrm1 x) @ (p1 y - nrm1 y). 66212 point2 := (p2 x - nrm2 x) @ (p2 y - nrm2 y). 66213 pointB := point1 + dir1 + point2 * 0.5. 66214 pointB := p2 + ((pointB - p2) normalized * w). 66215 pointC := point2. 66216 ]. 66217 66218 "Compute the merge points of p2->p3 with p3->p4" 66219 cross2 := dir3 crossProduct: dir2. 66220 nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w). 66221 nrm3 := dir3 normalized. nrm3 := (nrm3 y * w) @ (0 - nrm3 x * w). 66222 cross2 < 0 ifTrue:[nrm2 := nrm2 negated. nrm3 := nrm3 negated]. 66223 point2 := (p2 x + nrm2 x) @ (p2 y + nrm2 y). 66224 point3 := (p3 x + nrm3 x) @ (p3 y + nrm3 y). 66225 pointD := self intersectFrom: point2 with: dir2 to: point3 with: dir3. 66226 point2 := (p2 x - nrm2 x) @ (p2 y - nrm2 y). 66227 point3 := (p3 x - nrm3 x) @ (p3 y - nrm3 y). 66228 pointF := point2 + dir2. 66229 pointE := pointF + point3 * 0.5. 66230 pointE := p3 + ((pointE - p3) normalized * w). 66231 cross1 * cross2 < 0.0 ifTrue:[ 66232 ends 66233 at: 1 put: pointA; 66234 at: 2 put: pointB; 66235 at: 3 put: pointC; 66236 at: 4 put: pointD; 66237 at: 5 put: pointE; 66238 at: 6 put: pointF. 66239 ] ifFalse:[ 66240 ends 66241 at: 1 put: pointA; 66242 at: 2 put: pointB; 66243 at: 3 put: pointC; 66244 at: 4 put: pointF; 66245 at: 5 put: pointE; 66246 at: 6 put: pointD. 66247 ]. 66248 self drawPolyPatchFrom: p2 to: p3 on: balloon usingEnds: ends. 66249 pointA := pointD. 66250 pointB := pointE. 66251 pointC := pointF. 66252 cross1 := cross2. 66253 ]. 66254 balloon == aCanvas ifFalse:[balloon flush].! ! 66255 66256!ComplexBorder methodsFor: 'drawing' stamp: 'ar 8/26/2001 19:01'! 66257frameRectangle: aRectangle on: aCanvas 66258 "Note: This uses BitBlt since it's roughly a factor of two faster for rectangles" 66259 | w h r | 66260 self colors ifNil:[^super frameRectangle: aRectangle on: aCanvas]. 66261 w := self width. 66262 w isPoint ifTrue:[h := w y. w := w x] ifFalse:[h := w]. 66263 1 to: h do:[:i| "top/bottom" 66264 r := (aRectangle topLeft + (i-1)) extent: (aRectangle width - (i-1*2))@1. "top" 66265 aCanvas fillRectangle: r color: (colors at: i). 66266 r := (aRectangle bottomLeft + (i @ (0-i))) extent: (aRectangle width - (i-1*2) - 1)@1. "bottom" 66267 aCanvas fillRectangle: r color: (colors at: colors size - i + 1). 66268 ]. 66269 1 to: w do:[:i| "left/right" 66270 r := (aRectangle topLeft + (i-1)) extent: 1@(aRectangle height - (i-1*2)). "left" 66271 aCanvas fillRectangle: r color: (colors at: i). 66272 r := aRectangle topRight + ((0-i)@i) extent: 1@(aRectangle height - (i-1*2) - 1). "right" 66273 aCanvas fillRectangle: r color: (colors at: colors size - i + 1). 66274 ].! ! 66275 66276 66277!ComplexBorder methodsFor: 'initialize' stamp: 'ar 11/26/2001 14:43'! 66278releaseCachedState 66279 colors := nil. 66280 lineStyles := nil.! ! 66281 66282 66283!ComplexBorder methodsFor: 'testing' stamp: 'ar 8/26/2001 19:30'! 66284isComplex 66285 ^true! ! 66286 66287 66288!ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:02'! 66289colorsForDirection: direction 66290 "Return an array of colors describing the receiver in the given direction" 66291 66292 | colorArray dT cc | 66293 cc := self colors. 66294 direction x * direction y <= 0 66295 ifTrue: 66296 ["within up->right or down->left transition; no color blend needed" 66297 66298 colorArray := (direction x > 0 or: [direction y < 0]) 66299 ifTrue: 66300 ["up->right" 66301 cc copyFrom: 1 to: width] 66302 ifFalse: 66303 ["down->left" 66304 "colors are stored in reverse direction when following a line" 66305 (cc copyFrom: width + 1 to: cc size) reversed]] 66306 ifFalse: 66307 ["right->down or left->up transition; need color blend" 66308 66309 colorArray := Array new: width. 66310 dT := direction x asFloat / (direction x + direction y). 66311 (direction x > 0 or: [direction y >= 0]) 66312 ifTrue: 66313 ["top-right" 66314 66315 1 to: width 66316 do: 66317 [:i | 66318 colorArray at: i put: ((cc at: i) mixed: dT with: (cc at: cc size - i + 1))]] 66319 ifFalse: 66320 ["bottom-left" 66321 66322 1 to: width 66323 do: 66324 [:i | 66325 colorArray at: i put: ((cc at: cc size - i + 1) mixed: dT with: (cc at: i))]]]. 66326 ^colorArray! ! 66327 66328!ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:16'! 66329computeAltFramedColors 66330 | base light dark w hw colorArray param | 66331 base := self color asColor. 66332 light := Color white. 66333 dark := Color black. 66334 w := self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width]. 66335 w := w asInteger. 66336 w = 1 ifTrue:[^{base mixed: 0.5 with: light. base mixed: 0.5 with: dark}]. 66337 colorArray := Array new: w. 66338 hw := w // 2. 66339 "brighten" 66340 0 to: hw-1 do:[:i| 66341 param := 0.5 + (i asFloat / hw * 0.5). 66342 colorArray at: i+1 put: (base mixed: param with: dark). "brighten" 66343 colorArray at: w-i put: (base mixed: param with: light). "darken" 66344 ]. 66345 w odd ifTrue:[colorArray at: hw+1 put: base]. 66346 ^colorArray, colorArray! ! 66347 66348!ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:03'! 66349computeAltInsetColors 66350 | base light dark w colorArray param hw | 66351 base := self color asColor. 66352 light := Color white. 66353 dark := Color black. 66354 w := self width isPoint 66355 ifTrue: [self width x max: self width y] 66356 ifFalse: [self width]. 66357 w := w asInteger. 66358 colorArray := Array new: w * 2. 66359 hw := 0.5 / w. 66360 0 to: w - 1 66361 do: 66362 [:i | 66363 param := false 66364 ifTrue: 66365 ["whats this ???!! false ifTrue:[]" 66366 66367 0.5 + (hw * i)] 66368 ifFalse: [0.5 + (hw * (w - i))]. 66369 colorArray at: i + 1 put: (base mixed: param with: dark). "darken" 66370 colorArray at: colorArray size - i put: (base mixed: param with: light) "brighten"]. 66371 ^colorArray! ! 66372 66373!ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:05'! 66374computeAltRaisedColors 66375 | base light dark w colorArray param hw | 66376 base := self color asColor. 66377 light := Color white. 66378 dark := Color black. 66379 w := self width isPoint 66380 ifTrue: [self width x max: self width y] 66381 ifFalse: [self width]. 66382 w := w asInteger. 66383 colorArray := Array new: w * 2. 66384 hw := 0.5 / w. 66385 0 to: w - 1 66386 do: 66387 [:i | "again !! false ifTrue:[] ?!!" 66388 param := false ifTrue: [0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. 66389 colorArray at: i + 1 put: (base mixed: param with: light). "brighten" 66390 colorArray at: colorArray size - i put: (base mixed: param with: dark) "darken"]. 66391 ^colorArray! ! 66392 66393!ComplexBorder methodsFor: 'private' stamp: 'ar 11/26/2001 15:00'! 66394computeColors 66395 width = 0 ifTrue:[^colors := #()]. 66396 style == #complexFramed ifTrue:[^self computeFramedColors]. 66397 style == #complexAltFramed ifTrue:[^self computeAltFramedColors]. 66398 style == #complexRaised ifTrue:[^self computeRaisedColors]. 66399 style == #complexAltRaised ifTrue:[^self computeAltRaisedColors]. 66400 style == #complexInset ifTrue:[^self computeInsetColors]. 66401 style == #complexAltInset ifTrue:[^self computeAltInsetColors]. 66402 self error:'Unknown border style: ', style printString.! ! 66403 66404!ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:35'! 66405computeFramedColors 66406 | base light dark w hw colorArray param | 66407 base := self color asColor. 66408 light := Color white. 66409 dark := Color black. 66410 w := self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width]. 66411 w := w asInteger. 66412 w = 1 ifTrue:[^{base mixed: 0.5 with: light. base mixed: 0.5 with: dark}]. 66413 colorArray := Array new: w. 66414 hw := w // 2. 66415 "brighten" 66416 0 to: hw-1 do:[:i| 66417 param := 0.5 + (i asFloat / hw * 0.5). 66418 colorArray at: i+1 put: (base mixed: param with: light). "brighten" 66419 colorArray at: w-i put: (base mixed: param with: dark). "darken" 66420 ]. 66421 w odd ifTrue:[colorArray at: hw+1 put: base]. 66422 ^colorArray, colorArray! ! 66423 66424!ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:06'! 66425computeInsetColors 66426 | base light dark w colorArray param hw | 66427 base := self color asColor. 66428 light := Color white. 66429 dark := Color black. 66430 w := self width isPoint 66431 ifTrue: [self width x max: self width y] 66432 ifFalse: [self width]. 66433 w := w asInteger. 66434 colorArray := Array new: w * 2. 66435 hw := 0.5 / w. 66436 0 to: w - 1 66437 do: 66438 [:i | 66439 param := true 66440 ifTrue: [ 0.5 + (hw * i)] 66441 ifFalse: [0.5 + (hw * (w - i))]. 66442 colorArray at: i + 1 put: (base mixed: param with: dark). "darken" 66443 colorArray at: colorArray size - i put: (base mixed: param with: light) "brighten"]. 66444 ^colorArray! ! 66445 66446!ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:07'! 66447computeRaisedColors 66448 | base light dark w colorArray param hw | 66449 base := self color asColor. 66450 light := Color white. 66451 dark := Color black. 66452 w := self width isPoint 66453 ifTrue: [self width x max: self width y] 66454 ifFalse: [self width]. 66455 w := w asInteger. 66456 colorArray := Array new: w * 2. 66457 hw := 0.5 / w. 66458 0 to: w - 1 66459 do: 66460 [:i | 66461 param := true ifTrue: [0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. 66462 colorArray at: i + 1 put: (base mixed: param with: light). "brighten" 66463 colorArray at: colorArray size - i put: (base mixed: param with: dark) "darken"]. 66464 ^colorArray! ! 66465 66466!ComplexBorder methodsFor: 'private' stamp: 'ar 9/4/2001 19:51'! 66467fillStyleForDirection: direction 66468 "Fill the given form describing the receiver's look at a particular direction" 66469 | index fill dir | 66470 index := direction degrees truncated // 10 + 1. 66471 lineStyles ifNotNil:[ 66472 fill := lineStyles at: index. 66473 fill ifNotNil:[^fill]. 66474 ]. 66475 dir := Point r: 1.0 degrees: index - 1 * 10 + 5. 66476 fill := GradientFillStyle colors: (self colorsForDirection: dir). 66477 fill direction: 0 @ width asPoint y; radial: false. 66478 fill origin: ((width asPoint x // 2) @ (width asPoint y // 2)) negated. 66479 fill pixelRamp: (fill computePixelRampOfSize: 16). 66480 fill isTranslucent. "precompute" 66481 lineStyles ifNil:[lineStyles := Array new: 37]. 66482 lineStyles at: index put: fill. 66483 ^fill! ! 66484 66485!ComplexBorder methodsFor: 'private' stamp: 'ar 8/26/2001 23:39'! 66486intersectFrom: startPt with: startDir to: endPt with: endDir 66487 "Compute the intersection of two lines. Return nil if either 66488 * the intersection does not exist, or 66489 * the intersection is 'before' startPt, or 66490 * the intersection is 'after' endPt 66491 " 66492 | det deltaPt alpha beta | 66493 det := (startDir x * endDir y) - (startDir y * endDir x). 66494 det = 0.0 ifTrue:[^nil]. "There's no solution for it" 66495 deltaPt := endPt - startPt. 66496 alpha := (deltaPt x * endDir y) - (deltaPt y * endDir x). 66497 beta := (deltaPt x * startDir y) - (deltaPt y * startDir x). 66498 alpha := alpha / det. 66499 beta := beta / det. 66500 alpha < 0 ifTrue:[^nil]. 66501 beta > 1.0 ifTrue:[^nil]. 66502 "And compute intersection" 66503 ^(startPt x + (alpha * startDir x)) @ (startPt y + (alpha * startDir y))! ! 66504 66505"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 66506 66507ComplexBorder class 66508 instanceVariableNames: ''! 66509 66510!ComplexBorder class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:22'! 66511style: aSymbol 66512 ^self new style: aSymbol! ! 66513TestCase subclass: #ComplexTest 66514 instanceVariableNames: '' 66515 classVariableNames: '' 66516 poolDictionaries: '' 66517 category: 'KernelTests-Numbers'! 66518 66519!ComplexTest methodsFor: 'testing' stamp: 'nice 2/8/2006 22:09'! 66520testEquality 66521 "self run: #testEquality" 66522 "self debug: #testEquality" 66523 66524 self assert: 0i = 0. 66525 self assert: (2 - 5i) = ((1 -4 i) + (1 - 1i)). 66526 self assert: 0i isZero. 66527 self deny: (1 + 3 i) = 1. 66528 self deny: (1 + 3 i) = (1 + 2i). 66529 66530"Some more stuff" 66531 self deny: (1 i) = nil. 66532 self deny: nil = (1 i). 66533 66534 self deny: (1 i) = #(1 2 3). 66535 self deny: #(1 2 3) = (1 i). 66536 66537 self deny: (1 i) = 0. 66538 self deny: 0 = (1 i). 66539 66540 self assert: (1 + 0 i) = 1. 66541 self assert: 1 = (1+ 0 i). 66542 66543 self assert: (1 + 0 i) = 1.0. 66544 self assert: 1.0 = (1+ 0 i). 66545 66546 self assert: (1/2 + 0 i) = (1/2). 66547 self assert: (1/2) = (1/2+ 0 i).! ! 66548 66549 66550!ComplexTest methodsFor: 'testing - bugs' stamp: 'md 2/18/2006 16:53'! 66551testBug1 66552 66553 self assert: (0.5 * (2+0i) ln) exp = (0.5 * 2 ln) exp.! ! 66554 66555 66556!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:00'! 66557testAbs 66558 "self run: #testAbs" 66559 "self debug: #testAbs" 66560 66561 | c | 66562 c := (6 - 6 i). 66563 self assert: c abs = 72 sqrt. 66564 ! ! 66565 66566!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 13:59'! 66567testAdding 66568 "self run: #testAdding" 66569 66570 | c | 66571 c := (5 - 6 i) + (-5 + 8 i). "Complex with Complex" 66572 self assert: (c = (0 + 2 i)).! ! 66573 66574!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:02'! 66575testArg 66576 "self run: #testArg" 66577 "self debug: #testArg" 66578 66579 | c | 66580 c := (0 + 5 i) . 66581 self assert: c arg = (Float pi/ 2). 66582 ! ! 66583 66584!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:13'! 66585testComplexCollection 66586 "self run: #testComplexCollection" 66587 "self debug: #testComplexCollection" 66588 66589 | array array2 | 66590 array := Array with: 1 + 2i with: 3 + 4i with: 5 + 6i. 66591 array2 := 2 * array. 66592 array with: array2 do: [:one :two | self assert: (2 * one) = two ] ! ! 66593 66594!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:16'! 66595testConversion 66596 "self run: #testConversion" 66597 "self debug: #testConversion" 66598 66599 self assert: ((1 + 2i) + 1) = (2 + 2 i). 66600 self assert: (1 + (1 + 2i)) = (2 + 2 i). 66601 self assert: ((1 + 2i) + 1.0) = (2.0 + 2 i). 66602 self assert: (1.0 + (1 + 2i)) = (2.0 + 2 i). 66603 self assert: ((1 + 2i) + (2/3)) = ((5/3) + 2 i ). 66604 self assert: ((2/3) + (1 + 2i)) = ((5/3) + 2 i )! ! 66605 66606!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 13:59'! 66607testCreation 66608 "self run: #testCreation" 66609 66610 | c | 66611 c := 5 i. 66612 self assert: (c real = 0). 66613 self assert: (c imaginary = 5). 66614 66615 c := 6 + 7 i. 66616 self assert: (c real = 6). 66617 self assert: ( c imaginary = 7). 66618 66619 c := 5.6 - 8 i. 66620 self assert: (c real = 5.6). 66621 self assert: (c imaginary = -8). 66622 66623 c := Complex real: 10 imaginary: 5. 66624 self assert: (c real = 10). 66625 self assert: (c imaginary = 5). 66626 66627 c := Complex abs: 5 arg: (Float pi/2). 66628 self assert: (c real rounded = 0). 66629 self assert: (c imaginary = 5). 66630 ! ! 66631 66632!ComplexTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:29'! 66633testDivision1 66634 "self run: #testDivision1" 66635 "self debug: #testDivision1" 66636 66637 | c1 c2 quotient | 66638 c1 := 2.0e252 + 3.0e70 i. 66639 c2 := c1. 66640 quotient := c1 / c2. 66641 self deny: (quotient - 1) isZero. 66642 66643 "This test fails due to the wonders of floating point arithmetic. 66644 Please have a look at Complex>>divideSecureBy: and #divideFastAndSecureBy: 66645 how this can be avoided." 66646 66647! ! 66648 66649!ComplexTest methodsFor: 'tests' stamp: 'laza 9/26/2005 10:24'! 66650testLn 66651 self assert: (Float e + 0 i) ln = Float e ln "See Bug 1815 on Mantis"! ! 66652 66653!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:03'! 66654testNegated 66655 "self run: #testNegated" 66656 "self debug: #testNegated" 66657 66658 | c | 66659 c := (2 + 5 i) . 66660 self assert: c negated = (-2 - 5i). 66661 ! ! 66662 66663!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:05'! 66664testReciprocal 66665 "self run: #testReciprocal" 66666 "self debug: #testReciprocal" 66667 66668 | c | 66669 c := (2 + 5 i). 66670 self assert: c reciprocal = ((2/29) - (5/29)i). 66671 ! ! 66672 66673!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 14:07'! 66674testReciprocalError 66675 "self run: #testReciprocalError" 66676 "self debug: #testReciprocalError" 66677 66678 | c | 66679 c := (0 i). 66680 self should: [c reciprocal] raise: ZeroDivide 66681 ! ! 66682 66683!ComplexTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:29'! 66684testSecureDivision1 66685 "self run: #testSecureDivision1" 66686 "self debug: #testSecureDivision1" 66687 66688 | c1 c2 quotient | 66689 c1 := 2.0e252 + 3.0e70 i. 66690 c2 := c1. 66691 quotient := c1 divideSecureBy: c2. 66692 self assert: (quotient - 1) isZero. 66693 ! ! 66694 66695!ComplexTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:29'! 66696testSecureDivision2 66697 "self run: #testSecureDivision2" 66698 "self debug: #testSecureDivision2" 66699 66700 | c1 c2 quotient | 66701 c1 := 2.0e252 + 3.0e70 i. 66702 c2 := c1. 66703 quotient := c1 divideFastAndSecureBy: c2. 66704 self assert: (quotient - 1) isZero. 66705 ! ! 66706 66707!ComplexTest methodsFor: 'tests' stamp: 'sd 7/17/2004 13:24'! 66708testSquared 66709 "self run: #testSquared" 66710 "self debug: #testSquared" 66711 66712 | c c2 | 66713 c := (6 - 6 i). 66714 c2 := (c squared). 66715 self assert: c2 imaginary = -72. 66716 self assert: c2 real = 0.! ! 66717MorphicModel subclass: #ComposableMorph 66718 uses: TEasilyThemed 66719 instanceVariableNames: '' 66720 classVariableNames: '' 66721 poolDictionaries: '' 66722 category: 'Polymorph-Widgets'! 66723!ComposableMorph commentStamp: 'gvc 5/18/2007 13:32' prior: 0! 66724Morph with an inset border by default and theme access.! 66725 66726 66727!ComposableMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 09:39'! 66728defaultBorderColor 66729 "Answer the default border color/fill style for the receiver" 66730 66731 ^#inset! ! 66732 66733!ComposableMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 09:39'! 66734defaultBorderWidth 66735 "Answer the default border width for the receiver." 66736 66737 ^ 1! ! 66738 66739!ComposableMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/29/2006 18:25'! 66740defaultTitle 66741 "Answer the default title label for the receiver." 66742 66743 ^'Composite' translated! ! 66744 66745!ComposableMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/29/2008 15:41'! 66746newWindow 66747 "Answer a new window with the receiver as model, 66748 except when the receiver is a morph (which can cause 66749 an infinte loop asking for #requestor, from Services)." 66750 66751 |w| 66752 w := StandardWindow new 66753 model: (self isMorph ifFalse: [self]); 66754 title: self defaultTitle; 66755 addMorph: self 66756 fullFrame: (LayoutFrame fractions: (0@0 corner: 1@1)); 66757 yourself. 66758 self 66759 borderWidth: 0. 66760 ^w! ! 66761 66762 66763!ComposableMorph methodsFor: 'controls'! 66764newAlphaImage: aForm help: helpText 66765 "Answer an alpha image morph." 66766 66767 ^self theme 66768 newAlphaImageIn: self 66769 image: aForm 66770 help: helpText! ! 66771 66772!ComposableMorph methodsFor: 'controls'! 66773newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText 66774 "Answer an alpha channel selector with the given selectors." 66775 66776 ^self theme 66777 newAlphaSelectorIn: self 66778 for: aModel 66779 getAlpha: getSel 66780 setAlpha: setSel 66781 help: helpText! ! 66782 66783!ComposableMorph methodsFor: 'controls'! 66784newAutoAcceptTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 66785 "Answer a text editor for the given model." 66786 66787 ^self theme 66788 newAutoAcceptTextEditorIn: self 66789 for: aModel 66790 getText: getSel 66791 setText: setSel 66792 getEnabled: enabledSel! ! 66793 66794!ComposableMorph methodsFor: 'controls'! 66795newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText 66796 "Answer a text entry for the given model." 66797 66798 ^self theme 66799 newAutoAcceptTextEntryIn: self 66800 for: aModel 66801 get: getSel 66802 set: setSel 66803 class: aClass 66804 getEnabled: enabledSel 66805 font: aFont 66806 help: helpText! ! 66807 66808!ComposableMorph methodsFor: 'controls'! 66809newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText 66810 "Answer a text entry for the given model." 66811 66812 ^self theme 66813 newAutoAcceptTextEntryIn: self 66814 for: aModel 66815 get: getSel 66816 set: setSel 66817 class: aClass 66818 getEnabled: enabledSel 66819 help: helpText! ! 66820 66821!ComposableMorph methodsFor: 'controls'! 66822newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText 66823 "Answer a text entry for the given model." 66824 66825 ^self theme 66826 newAutoAcceptTextEntryIn: self 66827 for: aModel 66828 get: getSel 66829 set: setSel 66830 class: String 66831 getEnabled: enabledSel 66832 font: aFont 66833 help: helpText 66834! ! 66835 66836!ComposableMorph methodsFor: 'controls'! 66837newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText 66838 "Answer a text entry for the given model." 66839 66840 ^self theme 66841 newAutoAcceptTextEntryIn: self 66842 for: aModel 66843 get: getSel 66844 set: setSel 66845 class: String 66846 getEnabled: enabledSel 66847 help: helpText! ! 66848 66849!ComposableMorph methodsFor: 'controls'! 66850newBalloonHelp: aTextStringOrMorph for: aMorph 66851 "Answer a new balloon help with the given contents for aMorph 66852 at a given corner." 66853 66854 ^self theme 66855 newBalloonHelpIn: self 66856 contents: aTextStringOrMorph 66857 for: aMorph 66858 corner: #bottomLeft! ! 66859 66860!ComposableMorph methodsFor: 'controls'! 66861newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol 66862 "Answer a new balloon help with the given contents for aMorph 66863 at a given corner." 66864 66865 ^self theme 66866 newBalloonHelpIn: self 66867 contents: aTextStringOrMorph 66868 for: aMorph 66869 corner: cornerSymbol! ! 66870 66871!ComposableMorph methodsFor: 'controls'! 66872newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText 66873 "Answer a bracket slider with the given selectors." 66874 66875 ^self theme 66876 newBracketSliderIn: self 66877 for: aModel 66878 getValue: getSel 66879 setValue: setSel 66880 min: minValue 66881 max: maxValue 66882 quantum: quantum 66883 getEnabled: enabledSel 66884 help: helpText! ! 66885 66886!ComposableMorph methodsFor: 'controls'! 66887newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText 66888 "Answer a bracket slider with the given selectors." 66889 66890 ^self 66891 newBracketSliderFor: aModel 66892 getValue: getSel 66893 setValue: setSel 66894 min: minValue 66895 max: maxValue 66896 quantum: quantum 66897 getEnabled: nil 66898 help: helpText! ! 66899 66900!ComposableMorph methodsFor: 'controls'! 66901newButtonFor: aModel action: actionSel getEnabled: enabledSel label: stringOrText help: helpText 66902 "Answer a new button." 66903 66904 ^self 66905 newButtonFor: aModel 66906 getState: nil 66907 action: actionSel 66908 arguments: nil 66909 getEnabled: enabledSel 66910 label: stringOrText 66911 help: helpText! ! 66912 66913!ComposableMorph methodsFor: 'controls'! 66914newButtonFor: aModel action: actionSel label: stringOrText help: helpText 66915 "Answer a new button." 66916 66917 ^self 66918 newButtonFor: aModel 66919 getState: nil 66920 action: actionSel 66921 arguments: nil 66922 getEnabled: nil 66923 label: stringOrText 66924 help: helpText! ! 66925 66926!ComposableMorph methodsFor: 'controls'! 66927newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText 66928 "Answer a new button." 66929 66930 ^self theme 66931 newButtonIn: self for: aModel 66932 getState: stateSel 66933 action: actionSel 66934 arguments: args 66935 getEnabled: enabledSel 66936 getLabel: labelSel 66937 help: helpText! ! 66938 66939!ComposableMorph methodsFor: 'controls'! 66940newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText 66941 "Answer a new button." 66942 66943 ^self theme 66944 newButtonIn: self for: aModel 66945 getState: stateSel 66946 action: actionSel 66947 arguments: args 66948 getEnabled: enabledSel 66949 label: stringOrText 66950 help: helpText! ! 66951 66952!ComposableMorph methodsFor: 'controls'! 66953newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel labelForm: aForm help: helpText 66954 "Answer a new button." 66955 66956 ^self theme 66957 newButtonIn: self for: aModel 66958 getState: stateSel 66959 action: actionSel 66960 arguments: args 66961 getEnabled: enabledSel 66962 label: (AlphaImageMorph new image: aForm) 66963 help: helpText! ! 66964 66965!ComposableMorph methodsFor: 'controls'! 66966newCancelButton 66967 "Answer a new cancel button." 66968 66969 ^self newCancelButtonFor: self! ! 66970 66971!ComposableMorph methodsFor: 'controls'! 66972newCancelButtonFor: aModel 66973 "Answer a new cancel button." 66974 66975 ^self theme 66976 newCancelButtonIn: self 66977 for: aModel! ! 66978 66979!ComposableMorph methodsFor: 'controls'! 66980newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText 66981 "Answer a checkbox with the given label." 66982 66983 ^self theme 66984 newCheckboxIn: self 66985 for: aModel 66986 getSelected: getSel 66987 setSelected: setSel 66988 getEnabled: enabledSel 66989 label: stringOrText 66990 help: helpText! ! 66991 66992!ComposableMorph methodsFor: 'controls'! 66993newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText 66994 "Answer a checkbox with the given label." 66995 66996 ^self theme 66997 newCheckboxIn: self 66998 for: aModel 66999 getSelected: getSel 67000 setSelected: setSel 67001 getEnabled: nil 67002 label: stringOrText 67003 help: helpText! ! 67004 67005!ComposableMorph methodsFor: 'controls'! 67006newCloseButton 67007 "Answer a new close button." 67008 67009 ^self newCloseButtonFor: self ! ! 67010 67011!ComposableMorph methodsFor: 'controls'! 67012newCloseButtonFor: aModel 67013 "Answer a new close button." 67014 67015 ^self theme 67016 newCloseButtonIn: self 67017 for: aModel! ! 67018 67019!ComposableMorph methodsFor: 'controls'! 67020newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText 67021 "Answer a color chooser with the given selectors." 67022 67023 ^self theme 67024 newColorChooserIn: self 67025 for: aModel 67026 getColor: getSel 67027 setColor: setSel 67028 getEnabled: enabledSel 67029 help: helpText! ! 67030 67031!ComposableMorph methodsFor: 'controls'! 67032newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText 67033 "Answer a color chooser with the given selectors." 67034 67035 ^self theme 67036 newColorChooserIn: self 67037 for: aModel 67038 getColor: getSel 67039 setColor: setSel 67040 getEnabled: nil 67041 help: helpText! ! 67042 67043!ComposableMorph methodsFor: 'controls'! 67044newColorPickerFor: target getter: getterSymbol setter: setterSymbol 67045 "Answer a new color picker for the given morph and accessors." 67046 67047 ^self theme 67048 newColorPickerIn: self 67049 for: target 67050 getter: getterSymbol 67051 setter: setterSymbol! ! 67052 67053!ComposableMorph methodsFor: 'controls'! 67054newColorPresenterFor: aModel getColor: getSel help: helpText 67055 "Answer a color presenter with the given selectors." 67056 67057 ^self theme 67058 newColorPresenterIn: self 67059 for: aModel 67060 getColor: getSel 67061 help: helpText! ! 67062 67063!ComposableMorph methodsFor: 'controls'! 67064newColumn: controls 67065 "Answer a morph laid out with a column of controls." 67066 67067 ^self theme 67068 newColumnIn: self 67069 for: controls! ! 67070 67071!ComposableMorph methodsFor: 'controls'! 67072newDialogPanel 67073 "Answer a new main dialog panel." 67074 67075 ^self theme 67076 newDialogPanelIn: self! ! 67077 67078!ComposableMorph methodsFor: 'controls'! 67079newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText 67080 "Answer a drop list for the given model." 67081 67082 ^self theme 67083 newDropListIn: self 67084 for: aModel 67085 list: listSel 67086 getSelected: getSel 67087 setSelected: setSel 67088 getEnabled: enabledSel 67089 useIndex: true 67090 help: helpText! ! 67091 67092!ComposableMorph methodsFor: 'controls'! 67093newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 67094 "Answer a drop list for the given model." 67095 67096 ^self theme 67097 newDropListIn: self 67098 for: aModel 67099 list: listSel 67100 getSelected: getSel 67101 setSelected: setSel 67102 getEnabled: enabledSel 67103 useIndex: useIndex 67104 help: helpText! ! 67105 67106!ComposableMorph methodsFor: 'controls'! 67107newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText 67108 "Answer a drop list for the given model." 67109 67110 ^self 67111 newDropListFor: aModel 67112 list: listSel 67113 getSelected: getSel 67114 setSelected: setSel 67115 getEnabled: nil 67116 useIndex: true 67117 help: helpText! ! 67118 67119!ComposableMorph methodsFor: 'controls'! 67120newEmbeddedMenu 67121 "Answer a new menu." 67122 67123 ^self theme 67124 newEmbeddedMenuIn: self 67125 for: self! ! 67126 67127!ComposableMorph methodsFor: 'controls'! 67128newExpander: aString 67129 "Answer an expander with the given label." 67130 67131 ^self theme 67132 newExpanderIn: self 67133 label: aString 67134 forAll: #()! ! 67135 67136!ComposableMorph methodsFor: 'controls'! 67137newExpander: aString for: aControl 67138 "Answer an expander with the given label and control." 67139 67140 ^self theme 67141 newExpanderIn: self 67142 label: aString 67143 forAll: {aControl}! ! 67144 67145!ComposableMorph methodsFor: 'controls'! 67146newExpander: aString forAll: controls 67147 "Answer an expander with the given label and controls." 67148 67149 ^self theme 67150 newExpanderIn: self 67151 label: aString 67152 forAll: controls! ! 67153 67154!ComposableMorph methodsFor: 'controls'! 67155newFuzzyLabel: aString 67156 "Answer a new fuzzy label." 67157 67158 ^self theme 67159 newFuzzyLabelIn: self 67160 for: nil 67161 label: aString 67162 offset: 1 67163 alpha: 0.5 67164 getEnabled: nil! ! 67165 67166!ComposableMorph methodsFor: 'controls'! 67167newFuzzyLabelFor: aModel label: aString getEnabled: enabledSel 67168 "Answer a new fuzzy label." 67169 67170 ^self theme 67171 newFuzzyLabelIn: self 67172 for: aModel 67173 label: aString 67174 offset: 1 67175 alpha: 0.5 67176 getEnabled: enabledSel! ! 67177 67178!ComposableMorph methodsFor: 'controls'! 67179newFuzzyLabelFor: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel 67180 "Answer a new fuzzy label." 67181 67182 ^self theme 67183 newFuzzyLabelIn: self 67184 for: aModel 67185 label: aString 67186 offset: offset 67187 alpha: alpha 67188 getEnabled: enabledSel! ! 67189 67190!ComposableMorph methodsFor: 'controls'! 67191newGroupbox 67192 "Answer a plain groupbox." 67193 67194 ^self theme 67195 newGroupboxIn: self! ! 67196 67197!ComposableMorph methodsFor: 'controls'! 67198newGroupbox: aString 67199 "Answer a groupbox with the given label." 67200 67201 ^self theme 67202 newGroupboxIn: self 67203 label: aString! ! 67204 67205!ComposableMorph methodsFor: 'controls'! 67206newGroupbox: aString for: control 67207 "Answer a groupbox with the given label and control." 67208 67209 ^self theme 67210 newGroupboxIn: self 67211 label: aString 67212 for: control! ! 67213 67214!ComposableMorph methodsFor: 'controls'! 67215newGroupbox: aString forAll: controls 67216 "Answer a groupbox with the given label and controls." 67217 67218 ^self theme 67219 newGroupboxIn: self 67220 label: aString 67221 forAll: controls! ! 67222 67223!ComposableMorph methodsFor: 'controls'! 67224newGroupboxFor: control 67225 "Answer a plain groupbox with the given control." 67226 67227 ^self theme 67228 newGroupboxIn: self 67229 for: control! ! 67230 67231!ComposableMorph methodsFor: 'controls'! 67232newGroupboxForAll: controls 67233 "Answer a plain groupbox with the given controls." 67234 67235 ^self theme 67236 newGroupboxIn: self 67237 forAll: controls! ! 67238 67239!ComposableMorph methodsFor: 'controls'! 67240newHSVASelector: aColor help: helpText 67241 "Answer a hue-saturation-volume selector with the given color." 67242 67243 ^self theme 67244 newHSVASelectorIn: self 67245 color: aColor 67246 help: helpText! ! 67247 67248!ComposableMorph methodsFor: 'controls'! 67249newHSVSelector: aColor help: helpText 67250 "Answer a hue-saturation-volume selector with the given color." 67251 67252 ^self theme 67253 newHSVSelectorIn: self 67254 color: aColor 67255 help: helpText! ! 67256 67257!ComposableMorph methodsFor: 'controls'! 67258newHueSelector: aModel getHue: getSel setHue: setSel help: helpText 67259 "Answer a hue selector with the given selectors." 67260 67261 ^self theme 67262 newHueSelectorIn: self 67263 for: aModel 67264 getHue: getSel 67265 setHue: setSel 67266 help: helpText! ! 67267 67268!ComposableMorph methodsFor: 'controls'! 67269newImage: aForm 67270 "Answer a new image." 67271 67272 ^self theme 67273 newImageIn: self 67274 form: aForm! ! 67275 67276!ComposableMorph methodsFor: 'controls'! 67277newImage: aForm size: aPoint 67278 "Answer a new image." 67279 67280 ^self theme 67281 newImageIn: self 67282 form: aForm 67283 size: aPoint! ! 67284 67285!ComposableMorph methodsFor: 'controls'! 67286newIncrementalSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText 67287 "Answer an inremental slider with the given selectors." 67288 67289 ^self theme 67290 newIncrementalSliderIn: self 67291 for: aModel 67292 getValue: getSel 67293 setValue: setSel 67294 min: min 67295 max: max 67296 quantum: quantum 67297 getEnabled: enabledSel 67298 help: helpText! ! 67299 67300!ComposableMorph methodsFor: 'controls'! 67301newLabel: aString 67302 "Answer a new text label." 67303 67304 ^self 67305 newLabelFor: nil 67306 label: aString 67307 getEnabled: nil! ! 67308 67309!ComposableMorph methodsFor: 'controls'! 67310newLabelFor: aModel label: aString getEnabled: enabledSel 67311 "Answer a new text label." 67312 67313 ^self theme 67314 newLabelIn: self 67315 for: aModel 67316 label: aString 67317 getEnabled: enabledSel! ! 67318 67319!ComposableMorph methodsFor: 'controls'! 67320newLabelGroup: labelsAndControls 67321 "Answer a morph laid out with a column of labels and a column of associated controls." 67322 67323 ^self theme 67324 newLabelGroupIn: self 67325 for: labelsAndControls 67326 spaceFill: false! ! 67327 67328!ComposableMorph methodsFor: 'controls'! 67329newLabelGroup: labelsAndControls font: aFont labelColor: aColor 67330 "Answer a morph laid out with a column of labels and a column of associated controls." 67331 67332 ^self theme 67333 newLabelGroupIn: self 67334 for: labelsAndControls 67335 spaceFill: false 67336 font: aFont 67337 labelColor: aColor 67338! ! 67339 67340!ComposableMorph methodsFor: 'controls'! 67341newLabelGroupSpread: labelsAndControls 67342 "Answer a morph laid out with a column of labels and a column of associated controls." 67343 67344 ^self theme 67345 newLabelGroupIn: self 67346 for: labelsAndControls 67347 spaceFill: true! ! 67348 67349!ComposableMorph methodsFor: 'controls'! 67350newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText 67351 "Answer a list for the given model." 67352 67353 ^self theme 67354 newListIn: self 67355 for: aModel 67356 list: listSelector 67357 selected: getSelector 67358 changeSelected: setSelector 67359 getEnabled: enabledSel 67360 help: helpText! ! 67361 67362!ComposableMorph methodsFor: 'controls'! 67363newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText 67364 "Answer a list for the given model." 67365 67366 ^self 67367 newListFor: aModel 67368 list: listSelector 67369 selected: getSelector 67370 changeSelected: setSelector 67371 getEnabled: nil 67372 help: helpText! ! 67373 67374!ComposableMorph methodsFor: 'controls'! 67375newMenu 67376 "Answer a new menu." 67377 67378 ^self theme 67379 newMenuIn: self 67380 for: self! ! 67381 67382!ComposableMorph methodsFor: 'controls'! 67383newMenuFor: aModel 67384 "Answer a new menu." 67385 67386 ^self theme 67387 newMenuIn: self 67388 for: aModel! ! 67389 67390!ComposableMorph methodsFor: 'controls'! 67391newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText 67392 "Answer a morph drop list for the given model." 67393 67394 ^self 67395 newMorphDropListFor: aModel 67396 list: listSel 67397 getSelected: getSel 67398 setSelected: setSel 67399 getEnabled: enabledSel 67400 useIndex: true 67401 help: helpText! ! 67402 67403!ComposableMorph methodsFor: 'controls'! 67404newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 67405 "Answer a morph drop list for the given model." 67406 67407 ^self theme 67408 newMorphDropListIn: self 67409 for: aModel 67410 list: listSel 67411 getSelected: getSel 67412 setSelected: setSel 67413 getEnabled: enabledSel 67414 useIndex: useIndex 67415 help: helpText! ! 67416 67417!ComposableMorph methodsFor: 'controls'! 67418newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText 67419 "Answer a morph drop list for the given model." 67420 67421 ^self 67422 newMorphDropListFor: aModel 67423 list: listSel 67424 getSelected: getSel 67425 setSelected: setSel 67426 getEnabled: nil 67427 useIndex: true 67428 help: helpText! ! 67429 67430!ComposableMorph methodsFor: 'controls'! 67431newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText 67432 "Answer a morph list for the given model." 67433 67434 ^self theme 67435 newMorphListIn: self 67436 for: aModel 67437 list: listSelector 67438 getSelected: getSelector 67439 setSelected: setSelector 67440 getEnabled: enabledSel 67441 help: helpText! ! 67442 67443!ComposableMorph methodsFor: 'controls'! 67444newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText 67445 "Answer a morph list for the given model." 67446 67447 ^self 67448 newMorphListFor: aModel 67449 list: listSelector 67450 getSelected: getSelector 67451 setSelected: setSelector 67452 getEnabled: nil 67453 help: helpText! ! 67454 67455!ComposableMorph methodsFor: 'controls'! 67456newNoButton 67457 "Answer a new No button." 67458 67459 ^self newNoButtonFor: self! ! 67460 67461!ComposableMorph methodsFor: 'controls'! 67462newNoButtonFor: aModel 67463 "Answer a new No button." 67464 67465 ^self theme 67466 newNoButtonIn: self 67467 for: aModel! ! 67468 67469!ComposableMorph methodsFor: 'controls'! 67470newOKButton 67471 "Answer a new OK button." 67472 67473 ^self newOKButtonFor: self! ! 67474 67475!ComposableMorph methodsFor: 'controls'! 67476newOKButtonFor: aModel 67477 "Answer a new OK button." 67478 67479 ^self 67480 newOKButtonFor: aModel 67481 getEnabled: nil! ! 67482 67483!ComposableMorph methodsFor: 'controls'! 67484newOKButtonFor: aModel getEnabled: enabledSel 67485 "Answer a new OK button." 67486 67487 ^self theme 67488 newOKButtonIn: self 67489 for: aModel 67490 getEnabled: enabledSel! ! 67491 67492!ComposableMorph methodsFor: 'controls'! 67493newPanel 67494 "Answer a new panel." 67495 67496 ^self theme 67497 newPanelIn: self! ! 67498 67499!ComposableMorph methodsFor: 'controls'! 67500newPluggableDialogWindow 67501 "Answer a new pluggable dialog." 67502 67503 ^self 67504 newPluggableDialogWindow: 'Dialog'! ! 67505 67506!ComposableMorph methodsFor: 'controls'! 67507newPluggableDialogWindow: title 67508 "Answer a new pluggable dialog with the given content." 67509 67510 ^self 67511 newPluggableDialogWindow: title 67512 for: nil! ! 67513 67514!ComposableMorph methodsFor: 'controls'! 67515newPluggableDialogWindow: title for: contentMorph 67516 "Answer a new pluggable dialog with the given content." 67517 67518 ^self theme 67519 newPluggableDialogWindowIn: self 67520 title: title 67521 for: contentMorph! ! 67522 67523!ComposableMorph methodsFor: 'controls'! 67524newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText 67525 "Answer a checkbox (radio button appearance) with the given label." 67526 67527 ^self theme 67528 newRadioButtonIn: self 67529 for: aModel 67530 getSelected: getSel 67531 setSelected: setSel 67532 getEnabled: enabledSel 67533 label: stringOrText 67534 help: helpText! ! 67535 67536!ComposableMorph methodsFor: 'controls'! 67537newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText 67538 "Answer a checkbox (radio button appearance) with the given label." 67539 67540 ^self 67541 newRadioButtonFor: aModel 67542 getSelected: getSel 67543 setSelected: setSel 67544 getEnabled: nil 67545 label: stringOrText 67546 help: helpText! ! 67547 67548!ComposableMorph methodsFor: 'controls'! 67549newRow 67550 "Answer a morph laid out as a row." 67551 67552 ^self theme 67553 newRowIn: self 67554 for: #()! ! 67555 67556!ComposableMorph methodsFor: 'controls'! 67557newRow: controls 67558 "Answer a morph laid out with a row of controls." 67559 67560 ^self theme 67561 newRowIn: self 67562 for: controls! ! 67563 67564!ComposableMorph methodsFor: 'controls'! 67565newSVSelector: aColor help: helpText 67566 "Answer a saturation-volume selector with the given color." 67567 67568 ^self theme 67569 newSVSelectorIn: self 67570 color: aColor 67571 help: helpText! ! 67572 67573!ComposableMorph methodsFor: 'controls'! 67574newSeparator 67575 "Answer an horizontal separator." 67576 67577 ^self theme 67578 newSeparatorIn: self! ! 67579 67580!ComposableMorph methodsFor: 'controls'! 67581newSliderFor: aModel getValue: getSel setValue: setSel getEnabled: enabledSel help: helpText 67582 "Answer a slider with the given selectors." 67583 67584 ^self theme 67585 newSliderIn: self 67586 for: aModel 67587 getValue: getSel 67588 setValue: setSel 67589 min: 0 67590 max: 1 67591 quantum: nil 67592 getEnabled: enabledSel 67593 help: helpText! ! 67594 67595!ComposableMorph methodsFor: 'controls'! 67596newSliderFor: aModel getValue: getSel setValue: setSel help: helpText 67597 "Answer a slider with the given selectors." 67598 67599 ^self theme 67600 newSliderIn: self 67601 for: aModel 67602 getValue: getSel 67603 setValue: setSel 67604 min: 0 67605 max: 1 67606 quantum: nil 67607 getEnabled: nil 67608 help: helpText! ! 67609 67610!ComposableMorph methodsFor: 'controls'! 67611newSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText 67612 "Answer a slider with the given selectors." 67613 67614 ^self theme 67615 newSliderIn: self 67616 for: aModel 67617 getValue: getSel 67618 setValue: setSel 67619 min: min 67620 max: max 67621 quantum: quantum 67622 getEnabled: enabledSel 67623 help: helpText! ! 67624 67625!ComposableMorph methodsFor: 'controls'! 67626newString: aStringOrText 67627 "Answer a new embossed string." 67628 67629 ^self theme 67630 newStringIn: self 67631 label: aStringOrText 67632 font: self theme labelFont 67633 style: #plain! ! 67634 67635!ComposableMorph methodsFor: 'controls'! 67636newString: aStringOrText font: aFont style: aStyle 67637 "Answer a new embossed string." 67638 67639 ^self theme 67640 newStringIn: self 67641 label: aStringOrText 67642 font: aFont 67643 style: aStyle! ! 67644 67645!ComposableMorph methodsFor: 'controls'! 67646newString: aStringOrText style: aStyle 67647 "Answer a new embossed string." 67648 67649 ^self theme 67650 newStringIn: self 67651 label: aStringOrText 67652 font: self theme labelFont 67653 style: aStyle! ! 67654 67655!ComposableMorph methodsFor: 'controls'! 67656newTabGroup: labelsAndPages 67657 "Answer a tab group with the given tab labels associated with pages." 67658 67659 ^self theme 67660 newTabGroupIn: self 67661 for: labelsAndPages! ! 67662 67663!ComposableMorph methodsFor: 'controls'! 67664newText: aStringOrText 67665 "Answer a new text." 67666 67667 ^self theme 67668 newTextIn: self 67669 text: aStringOrText! ! 67670 67671!ComposableMorph methodsFor: 'controls'! 67672newTextEditorFor: aModel getText: getSel setText: setSel 67673 "Answer a text editor for the given model." 67674 67675 ^self 67676 newTextEditorFor: aModel 67677 getText: getSel 67678 setText: setSel 67679 getEnabled: nil! ! 67680 67681!ComposableMorph methodsFor: 'controls'! 67682newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 67683 "Answer a text editor for the given model." 67684 67685 ^self theme 67686 newTextEditorIn: self 67687 for: aModel 67688 getText: getSel 67689 setText: setSel 67690 getEnabled: enabledSel ! ! 67691 67692!ComposableMorph methodsFor: 'controls'! 67693newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText 67694 "Answer a text entry for the given model." 67695 67696 ^self theme 67697 newTextEntryIn: self 67698 for: aModel 67699 get: getSel 67700 set: setSel 67701 class: aClass 67702 getEnabled: enabledSel 67703 help: helpText! ! 67704 67705!ComposableMorph methodsFor: 'controls'! 67706newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText 67707 "Answer a text entry for the given model." 67708 67709 ^self theme 67710 newTextEntryIn: self 67711 for: aModel 67712 get: getSel 67713 set: setSel 67714 class: String 67715 getEnabled: enabledSel 67716 help: helpText! ! 67717 67718!ComposableMorph methodsFor: 'controls'! 67719newTextEntryFor: aModel getText: getSel setText: setSel help: helpText 67720 "Answer a text entry for the given model." 67721 67722 ^self 67723 newTextEntryFor: aModel 67724 get: getSel 67725 set: setSel 67726 class: String 67727 getEnabled: nil 67728 help: helpText! ! 67729 67730!ComposableMorph methodsFor: 'controls'! 67731newTitle: aString for: control 67732 "Answer a morph laid out with a column with a title." 67733 67734 ^self theme 67735 newTitleIn: self 67736 label: aString 67737 for: control! ! 67738 67739!ComposableMorph methodsFor: 'controls'! 67740newToolDockingBar 67741 "Answer a tool docking bar." 67742 67743 ^self theme 67744 newToolDockingBarIn: self! ! 67745 67746!ComposableMorph methodsFor: 'controls'! 67747newToolSpacer 67748 "Answer a tool spacer." 67749 67750 ^self theme 67751 newToolSpacerIn: self! ! 67752 67753!ComposableMorph methodsFor: 'controls'! 67754newToolbar 67755 "Answer a toolbar." 67756 67757 ^self theme 67758 newToolbarIn: self! ! 67759 67760!ComposableMorph methodsFor: 'controls'! 67761newToolbar: controls 67762 "Answer a toolbar with the given controls." 67763 67764 ^self theme 67765 newToolbarIn: self 67766 for: controls! ! 67767 67768!ComposableMorph methodsFor: 'controls'! 67769newToolbarHandle 67770 "Answer a toolbar handle." 67771 67772 ^self theme 67773 newToolbarHandleIn: self! ! 67774 67775!ComposableMorph methodsFor: 'controls'! 67776newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector 67777 "Answer a new tree morph." 67778 67779 ^self theme 67780 newTreeIn: self 67781 for: aModel 67782 list: listSelector 67783 selected: getSelector 67784 changeSelected: setSelector! ! 67785 67786!ComposableMorph methodsFor: 'controls'! 67787newVerticalSeparator 67788 "Answer a vertical separator." 67789 67790 ^self theme 67791 newVerticalSeparatorIn: self! ! 67792 67793!ComposableMorph methodsFor: 'controls'! 67794newYesButton 67795 "Answer a new Yes button." 67796 67797 ^self newYesButtonFor: self! ! 67798 67799!ComposableMorph methodsFor: 'controls'! 67800newYesButtonFor: aModel 67801 "Answer a new yes button." 67802 67803 ^self theme 67804 newYesButtonIn: self 67805 for: aModel! ! 67806 67807 67808!ComposableMorph methodsFor: 'services'! 67809abort: aStringOrText 67810 "Open an error dialog." 67811 67812 ^self abort: aStringOrText title: 'Error' translated! ! 67813 67814!ComposableMorph methodsFor: 'services'! 67815abort: aStringOrText title: aString 67816 "Open an error dialog." 67817 67818 ^self theme 67819 abortIn: self 67820 text: aStringOrText 67821 title: aString! ! 67822 67823!ComposableMorph methodsFor: 'services'! 67824alert: aStringOrText 67825 "Open an alert dialog." 67826 67827 ^self alert: aStringOrText title: 'Alert' translated! ! 67828 67829!ComposableMorph methodsFor: 'services'! 67830alert: aStringOrText title: aString 67831 "Open an alert dialog." 67832 67833 ^self 67834 alert: aStringOrText 67835 title: aString 67836 configure: [:d | ]! ! 67837 67838!ComposableMorph methodsFor: 'services'! 67839alert: aStringOrText title: aString configure: aBlock 67840 "Open an alert dialog. 67841 Configure the dialog with the 1 argument block 67842 before opening modally." 67843 67844 ^self theme 67845 alertIn: self 67846 text: aStringOrText 67847 title: aString 67848 configure: aBlock! ! 67849 67850!ComposableMorph methodsFor: 'services'! 67851chooseColor 67852 "Answer the result of a color selector dialog ." 67853 67854 ^self chooseColor: Color black! ! 67855 67856!ComposableMorph methodsFor: 'services'! 67857chooseColor: aColor 67858 "Answer the result of a color selector dialog with the given color." 67859 67860 ^self theme 67861 chooseColorIn: self 67862 title: 'Colour Selector' translated 67863 color: aColor! ! 67864 67865!ComposableMorph methodsFor: 'services'! 67866chooseColor: aColor title: title 67867 "Answer the result of a color selector dialog with the given title and initial colour." 67868 67869 ^self theme 67870 chooseColorIn: self 67871 title: title 67872 color: aColor! ! 67873 67874!ComposableMorph methodsFor: 'services'! 67875chooseDirectory: title 67876 "Answer the result of a file dialog with the given title, answer a directory." 67877 67878 ^self 67879 chooseDirectory: title 67880 path: nil! ! 67881 67882!ComposableMorph methodsFor: 'services'! 67883chooseDirectory: title path: path 67884 "Answer the result of a file dialog with the given title, answer a directory." 67885 67886 ^self theme 67887 chooseDirectoryIn: self 67888 title: title 67889 path: path! ! 67890 67891!ComposableMorph methodsFor: 'services'! 67892chooseDropList: aStringOrText list: aList 67893 "Open a drop list chooser dialog." 67894 67895 ^self 67896 chooseDropList: aStringOrText 67897 title: 'Choose' translated 67898 list: aList! ! 67899 67900!ComposableMorph methodsFor: 'services'! 67901chooseDropList: aStringOrText title: aString list: aList 67902 "Open a drop list chooser dialog." 67903 67904 ^self theme 67905 chooseDropListIn: self 67906 text: aStringOrText 67907 title: aString 67908 list: aList! ! 67909 67910!ComposableMorph methodsFor: 'services'! 67911chooseFileName: title extensions: exts path: path preview: preview 67912 "Answer the result of a file name chooser dialog with the given title, extensions 67913 to show, path and preview type." 67914 67915 ^self theme 67916 chooseFileNameIn: self 67917 title: title 67918 extensions: exts 67919 path: path 67920 preview: preview! ! 67921 67922!ComposableMorph methodsFor: 'services'! 67923chooseFont 67924 "Answer the result of a font selector dialog." 67925 67926 ^self chooseFont: nil! ! 67927 67928!ComposableMorph methodsFor: 'services'! 67929chooseFont: aFont 67930 "Answer the result of a font selector dialog with the given initial font." 67931 67932 ^self theme 67933 chooseFontIn: self 67934 title: 'Font Selector' translated 67935 font: aFont! ! 67936 67937!ComposableMorph methodsFor: 'services'! 67938deny: aStringOrText 67939 "Open a denial dialog." 67940 67941 ^self deny: aStringOrText title: 'Access Denied' translated! ! 67942 67943!ComposableMorph methodsFor: 'services'! 67944deny: aStringOrText title: aString 67945 "Open a denial dialog." 67946 67947 ^self theme 67948 denyIn: self 67949 text: aStringOrText 67950 title: aString! ! 67951 67952!ComposableMorph methodsFor: 'services'! 67953fileOpen: title 67954 "Answer the result of a file open dialog with the given title." 67955 67956 ^self 67957 fileOpen: title 67958 extensions: nil! ! 67959 67960!ComposableMorph methodsFor: 'services'! 67961fileOpen: title extensions: exts 67962 "Answer the result of a file open dialog with the given title and extensions to show." 67963 67964 ^self 67965 fileOpen: title 67966 extensions: exts 67967 path: nil! ! 67968 67969!ComposableMorph methodsFor: 'services'! 67970fileOpen: title extensions: exts path: path 67971 "Answer the result of a file open dialog with the given title, extensions to show and path." 67972 67973 ^self 67974 fileOpen: title 67975 extensions: exts 67976 path: path 67977 preview: nil! ! 67978 67979!ComposableMorph methodsFor: 'services'! 67980fileOpen: title extensions: exts path: path preview: preview 67981 "Answer the result of a file open dialog with the given title, extensions to show, path and preview type." 67982 67983 ^self theme 67984 fileOpenIn: self 67985 title: title 67986 extensions: exts 67987 path: path 67988 preview: preview! ! 67989 67990!ComposableMorph methodsFor: 'services'! 67991fileSave: title 67992 "Answer the result of a file save dialog with the given title." 67993 67994 ^self 67995 fileSave: title 67996 extensions: nil 67997 path: nil! ! 67998 67999!ComposableMorph methodsFor: 'services'! 68000fileSave: title extensions: exts 68001 "Answer the result of a file save dialog with the given title." 68002 68003 ^self 68004 fileSave: title 68005 extensions: exts 68006 path: nil! ! 68007 68008!ComposableMorph methodsFor: 'services'! 68009fileSave: title extensions: exts path: path 68010 "Answer the result of a file save dialog with the given title, extensions to show and path." 68011 68012 ^self theme 68013 fileSaveIn: self 68014 title: title 68015 extensions: exts 68016 path: path! ! 68017 68018!ComposableMorph methodsFor: 'services'! 68019fileSave: title path: path 68020 "Answer the result of a file save open dialog with the given title." 68021 68022 ^self 68023 fileSave: title 68024 extensions: nil 68025 path: path! ! 68026 68027!ComposableMorph methodsFor: 'services'! 68028longMessage: aStringOrText title: aString 68029 "Open a (long) message dialog." 68030 68031 ^self theme 68032 longMessageIn: self 68033 text: aStringOrText 68034 title: aString! ! 68035 68036!ComposableMorph methodsFor: 'services'! 68037message: aStringOrText 68038 "Open a message dialog." 68039 68040 ^self message: aStringOrText title: 'Information' translated! ! 68041 68042!ComposableMorph methodsFor: 'services'! 68043message: aStringOrText title: aString 68044 "Open a message dialog." 68045 68046 ^self theme 68047 messageIn: self 68048 text: aStringOrText 68049 title: aString! ! 68050 68051!ComposableMorph methodsFor: 'services'! 68052proceed: aStringOrText 68053 "Open a proceed dialog." 68054 68055 ^self proceed: aStringOrText title: 'Proceed' translated! ! 68056 68057!ComposableMorph methodsFor: 'services'! 68058proceed: aStringOrText title: aString 68059 "Open a proceed dialog and answer true if not cancelled, false otherwise." 68060 68061 ^self theme 68062 proceedIn: self 68063 text: aStringOrText 68064 title: aString! ! 68065 68066!ComposableMorph methodsFor: 'services'! 68067question: aStringOrText 68068 "Open a question dialog." 68069 68070 ^self question: aStringOrText title: 'Question' translated! ! 68071 68072!ComposableMorph methodsFor: 'services'! 68073question: aStringOrText title: aString 68074 "Open a question dialog and answer true if yes, 68075 false if no and nil if cancelled." 68076 68077 ^self theme 68078 questionIn: self 68079 text: aStringOrText 68080 title: aString! ! 68081 68082!ComposableMorph methodsFor: 'services'! 68083questionWithoutCancel: aStringOrText 68084 "Open a question dialog." 68085 68086 ^self questionWithoutCancel: aStringOrText title: 'Question' translated! ! 68087 68088!ComposableMorph methodsFor: 'services'! 68089questionWithoutCancel: aStringOrText title: aString 68090 "Open a question dialog and answer true if yes, 68091 false if no and nil if cancelled." 68092 68093 ^self theme 68094 questionWithoutCancelIn: self 68095 text: aStringOrText 68096 title: aString! ! 68097 68098!ComposableMorph methodsFor: 'services'! 68099textEntry: aStringOrText 68100 "Open a text entry dialog." 68101 68102 ^self textEntry: aStringOrText title: 'Entry' translated! ! 68103 68104!ComposableMorph methodsFor: 'services'! 68105textEntry: aStringOrText title: aString 68106 "Open a text entry dialog." 68107 68108 ^self 68109 textEntry: aStringOrText 68110 title: aString 68111 entryText: ''! ! 68112 68113!ComposableMorph methodsFor: 'services'! 68114textEntry: aStringOrText title: aString entryText: defaultEntryText 68115 "Open a text entry dialog." 68116 68117 ^self theme 68118 textEntryIn: self 68119 text: aStringOrText 68120 title: aString 68121 entryText: defaultEntryText! ! 68122 68123 68124!ComposableMorph methodsFor: 'theme'! 68125theme 68126 "Answer the ui theme that provides controls." 68127 68128 ^UITheme current! ! 68129 68130"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 68131 68132ComposableMorph class 68133 uses: TEasilyThemed classTrait 68134 instanceVariableNames: ''! 68135SimpleBorder subclass: #CompositeBorder 68136 instanceVariableNames: 'borders' 68137 classVariableNames: '' 68138 poolDictionaries: '' 68139 category: 'Polymorph-Widgets-Borders'! 68140!CompositeBorder commentStamp: 'gvc 5/18/2007 13:28' prior: 0! 68141Border supporting multiple "sub-borders".! 68142 68143 68144!CompositeBorder methodsFor: 'accessing' stamp: 'gvc 3/12/2007 11:15'! 68145borders 68146 "Answer the value of borders" 68147 68148 ^ borders! ! 68149 68150!CompositeBorder methodsFor: 'accessing' stamp: 'gvc 3/12/2007 11:15'! 68151borders: anObject 68152 "Set the value of borders" 68153 68154 borders := anObject! ! 68155 68156 68157!CompositeBorder methodsFor: 'as yet unclassified' stamp: 'gvc 3/29/2007 17:32'! 68158= aBorderStyle 68159 "Check the sub-borders too" 68160 68161 ^super = aBorderStyle and: [ 68162 self borders = aBorderStyle borders]! ! 68163 68164!CompositeBorder methodsFor: 'as yet unclassified' stamp: 'gvc 3/12/2007 12:13'! 68165colorsAtCorners 68166 "Return the colors of the first border." 68167 68168 ^self borders first colorsAtCorners! ! 68169 68170!CompositeBorder methodsFor: 'as yet unclassified' stamp: 'gvc 3/14/2007 10:47'! 68171frameRectangle: aRectangle on: aCanvas 68172 "Draw each border in turn." 68173 68174 |r| 68175 r := aRectangle. 68176 self borders do: [:b | 68177 b frameRectangle: r on: aCanvas. 68178 r := r insetBy: b width]! ! 68179 68180!CompositeBorder methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 13:29'! 68181hash 68182 "Since #= is overridden." 68183 68184 ^super hash bitXor: self borders hash! ! 68185 68186!CompositeBorder methodsFor: 'as yet unclassified' stamp: 'gvc 3/14/2007 10:32'! 68187isComposite 68188 "Answer true." 68189 68190 ^true! ! 68191FillStyle subclass: #CompositeFillStyle 68192 instanceVariableNames: 'fillStyles' 68193 classVariableNames: '' 68194 poolDictionaries: '' 68195 category: 'Polymorph-Widgets-FillStyles'! 68196!CompositeFillStyle commentStamp: 'gvc 9/23/2008 12:05' prior: 0! 68197Fillstyle supporting compositing of multiple sub-fillstyles.! 68198 68199 68200!CompositeFillStyle methodsFor: 'accessing' stamp: 'gvc 3/20/2008 23:05'! 68201fillStyles 68202 "Answer the value of fillStyles. The first item in the collection is considered 68203 to be topmost when rendered." 68204 68205 ^ fillStyles! ! 68206 68207!CompositeFillStyle methodsFor: 'accessing' stamp: 'gvc 3/21/2008 16:24'! 68208fillStyles: aCollection 68209 "Set the value of fillStyles. The first item in the collection is considered 68210 to be topmost when rendering." 68211 68212 fillStyles := aCollection! ! 68213 68214!CompositeFillStyle methodsFor: 'accessing' stamp: 'gvc 3/20/2008 23:02'! 68215initialize 68216 "Initialize the receiver." 68217 68218 super initialize. 68219 self 68220 fillStyles: OrderedCollection new! ! 68221 68222 68223!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/21/2008 17:25'! 68224addFillStyleMenuItems: aMenu hand: aHand from: aMorph 68225 "Add the items for changing the current fill style of the receiver" 68226 aMenu add: 'change origin' translated target: self selector: #changeOriginIn:event: argument: aMorph. 68227 aMenu add: 'change orientation' translated target: self selector: #changeOrientationIn:event: argument: aMorph.! ! 68228 68229!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 5/27/2008 21:02'! 68230asColor 68231 "Answer a colour that is a best match to the receiver. 68232 Simple approach for the moment." 68233 68234 ^self fillStyles 68235 ifEmpty: [Color transparent] 68236 ifNotEmpty: [self fillStyles last asColor]! ! 68237 68238!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/21/2008 17:25'! 68239changeOrientationIn: aMorph event: evt 68240 "Interactively change the origin of the receiver" 68241 | handle | 68242 handle := HandleMorph new forEachPointDo:[:pt| 68243 self direction: pt - self origin. 68244 self normal: nil. 68245 aMorph changed]. 68246 evt hand attachMorph: handle. 68247 handle startStepping.! ! 68248 68249!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/21/2008 17:25'! 68250changeOriginIn: aMorph event: evt 68251 "Interactively change the origin of the receiver" 68252 | handle | 68253 handle := HandleMorph new forEachPointDo:[:pt| 68254 self origin: pt. 68255 aMorph changed]. 68256 evt hand attachMorph: handle. 68257 handle startStepping.! ! 68258 68259!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 5/27/2008 21:01'! 68260direction 68261 "Answer an effective direction of any oriented fill styles. 68262 Answer the bottom-right maxima." 68263 68264 |dir| 68265 dir := nil. 68266 self fillStyles reverseDo: [:fs | 68267 fs isOrientedFill ifTrue: [ 68268 dir := dir 68269 ifNil: [fs direction] 68270 ifNotNil: [dir max: fs direction]]]. 68271 ^dir ifNil: [0@0] "just in case"! ! 68272 68273!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 5/27/2008 21:01'! 68274direction: aPoint 68275 "Change the effective direction of any oriented fill styles." 68276 68277 |delta| 68278 delta := aPoint - self direction. 68279 self fillStyles reverseDo: [:fs | 68280 fs isOrientedFill ifTrue: [ 68281 fs direction: fs direction + delta]]! ! 68282 68283!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 5/27/2008 20:32'! 68284fillRectangle: aRectangle on: aCanvas 68285 "Fill the given rectangle on the given canvas with the receiver. 68286 Render from bottom to top." 68287 68288 self fillStyles do: [:fs | 68289 fs fillRectangle: aRectangle on: aCanvas]! ! 68290 68291!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/20/2008 23:04'! 68292isCompositeFill 68293 "Answer whether the receiver is a composite fill. 68294 True for kinds of the receiver's class." 68295 68296 ^true! ! 68297 68298!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 5/27/2008 20:37'! 68299isGradientFill 68300 "Answer whether any of the composited fill styles are gradients." 68301 68302 self fillStyles reverseDo: [:fs | 68303 fs isGradientFill ifTrue: [^true]]. 68304 ^false! ! 68305 68306!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 5/27/2008 20:38'! 68307isOrientedFill 68308 "Answer whether any of the composited fill styles are oriented." 68309 68310 self fillStyles reverseDo: [:fs | 68311 fs isOrientedFill ifTrue: [^true]]. 68312 ^false! ! 68313 68314!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/20/2008 23:07'! 68315isTranslucent 68316 "Answer whether all of the composited fill styles are transparent." 68317 68318 ^self fillStyles allSatisfy: [:fs | fs isTranslucent]! ! 68319 68320!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/20/2008 23:07'! 68321isTransparent 68322 "Answer whether all of the composited fill styles are transparent." 68323 68324 ^self fillStyles allSatisfy: [:fs | fs isTransparent]! ! 68325 68326!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 5/27/2008 21:00'! 68327normal 68328 "Answer an effective normal of any oriented fill styles. 68329 Answer the top-left minima (probably not an accurate assumption)." 68330 68331 |normal| 68332 normal := nil. 68333 self fillStyles reverseDo: [:fs | 68334 fs isOrientedFill ifTrue: [ 68335 normal := normal 68336 ifNil: [fs normal] 68337 ifNotNil: [normal min: fs normal]]]. 68338 ^normal ifNil: [0@0] "just in case"! ! 68339 68340!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 5/27/2008 21:01'! 68341normal: aPoint 68342 "Change the effective normal of any oriented fill styles." 68343 68344 |delta| 68345 aPoint ifNil: [ 68346 self fillStyles reverseDo: [:fs | 68347 fs isOrientedFill ifTrue: [ 68348 fs normal: nil]]. 68349 ^self]. 68350 delta := aPoint - self normal. 68351 self fillStyles reverseDo: [:fs | 68352 fs isOrientedFill ifTrue: [ 68353 fs normal: fs normal + delta]]! ! 68354 68355!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 5/27/2008 21:01'! 68356origin 68357 "Answer an effective origin of any oriented fill styles. 68358 Answer the top-left minima." 68359 68360 |origin| 68361 origin := nil. 68362 self fillStyles reverseDo: [:fs | 68363 fs isOrientedFill ifTrue: [ 68364 origin := origin 68365 ifNil: [fs origin] 68366 ifNotNil: [origin min: fs origin]]]. 68367 ^origin ifNil: [0@0] "just in case"! ! 68368 68369!CompositeFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 5/27/2008 21:01'! 68370origin: aPoint 68371 "Change the effective origin of any oriented fill styles." 68372 68373 |delta| 68374 delta := aPoint - self origin. 68375 self fillStyles reverseDo: [:fs | 68376 fs isOrientedFill ifTrue: [ 68377 fs origin: fs origin + delta]] 68378 ! ! 68379 68380"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 68381 68382CompositeFillStyle class 68383 instanceVariableNames: ''! 68384 68385!CompositeFillStyle class methodsFor: 'as yet unclassified' stamp: 'gvc 3/21/2008 16:49'! 68386fillStyles: aCollection 68387 "Answer a new instance of the receiver with the specfied fill styles." 68388 68389 ^self new fillStyles: aCollection! ! 68390WidgetStub subclass: #CompositeStub 68391 instanceVariableNames: 'children' 68392 classVariableNames: '' 68393 poolDictionaries: '' 68394 category: 'ToolBuilder-SUnit'! 68395 68396!CompositeStub methodsFor: 'accessing' stamp: 'cwp 4/25/2005 03:50'! 68397children 68398 ^children! ! 68399 68400!CompositeStub methodsFor: 'accessing' stamp: 'cwp 4/25/2005 03:50'! 68401children: anObject 68402 children := anObject! ! 68403 68404!CompositeStub methodsFor: 'accessing' stamp: 'cwp 4/25/2005 03:51'! 68405eventAccessors 68406 ^ #(children)! ! 68407 68408!CompositeStub methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! 68409widgetNamed: aString 68410 self name = aString 68411 ifTrue: [^ self] 68412 ifFalse: [children do: [:ea | (ea widgetNamed: aString) ifNotNil: [:w | ^ w]]]. 68413 ^ nil! ! 68414DisplayTransform subclass: #CompositeTransform 68415 instanceVariableNames: 'globalTransform localTransform' 68416 classVariableNames: '' 68417 poolDictionaries: '' 68418 category: 'Graphics-Transformations'! 68419!CompositeTransform commentStamp: '<historical>' prior: 0! 68420A composite transform provides the effect of several levels of coordinate transformations.! 68421 68422 68423!CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 17:06'! 68424angle 68425 ^ localTransform angle + globalTransform angle! ! 68426 68427!CompositeTransform methodsFor: 'accessing' stamp: 'ar 11/2/1998 19:45'! 68428inverseTransformation 68429 "Return the inverse transformation of the receiver" 68430 ^self species new 68431 globalTransform: localTransform inverseTransformation 68432 localTransform: globalTransform inverseTransformation! ! 68433 68434!CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 15:40'! 68435offset 68436 ^ (self localPointToGlobal: 0@0) negated! ! 68437 68438!CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 15:39'! 68439scale 68440 ^ localTransform scale * globalTransform scale! ! 68441 68442 68443!CompositeTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:00'! 68444asCompositeTransform 68445 ^self! ! 68446 68447!CompositeTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 19:56'! 68448asMatrixTransform2x3 68449 ^globalTransform asMatrixTransform2x3 68450 composedWithLocal: localTransform asMatrixTransform2x3! ! 68451 68452!CompositeTransform methodsFor: 'converting' stamp: 'di 10/26/1999 17:03'! 68453asMorphicTransform 68454 "Squash a composite transform down to a simple one" 68455 ^ MorphicTransform offset: self offset angle: self angle scale: self scale! ! 68456 68457 68458!CompositeTransform methodsFor: 'initialization' stamp: 'di 10/26/1999 17:08'! 68459composedWith: aTransform 68460 "Return a new transform that has the effect of transforming points first by the receiver and then by the argument." 68461 68462 self isIdentity ifTrue: [^ aTransform]. 68463 aTransform isIdentity ifTrue: [^ self]. 68464 ^ CompositeTransform new globalTransform: self 68465 localTransform: aTransform! ! 68466 68467!CompositeTransform methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 68468globalTransform: gt localTransform: lt 68469 globalTransform := gt. 68470 localTransform := lt! ! 68471 68472 68473!CompositeTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:00'! 68474isCompositeTransform 68475 ^true! ! 68476 68477!CompositeTransform methodsFor: 'testing' stamp: 'di 3/4/98 19:18'! 68478isIdentity 68479 ^ globalTransform isIdentity and: [localTransform isIdentity]! ! 68480 68481!CompositeTransform methodsFor: 'testing' stamp: 'di 3/4/98 19:18'! 68482isPureTranslation 68483 ^ globalTransform isPureTranslation and: [localTransform isPureTranslation]! ! 68484 68485 68486!CompositeTransform methodsFor: 'transformations' stamp: 'di 10/1/1998 13:51'! 68487invert: aPoint 68488 ^ globalTransform invert: (localTransform invert: aPoint)! ! 68489 68490!CompositeTransform methodsFor: 'transformations' stamp: 'di 3/4/98 19:20'! 68491transform: aPoint 68492 ^ localTransform transform: (globalTransform transform: aPoint)! ! 68493 68494 68495!CompositeTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:39'! 68496globalPointToLocal: aPoint 68497 "Transform aPoint from global coordinates into local coordinates" 68498 ^localTransform globalPointToLocal: 68499 (globalTransform globalPointToLocal: aPoint)! ! 68500 68501!CompositeTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:39'! 68502localPointToGlobal: aPoint 68503 "Transform aPoint from global coordinates into local coordinates" 68504 ^globalTransform localPointToGlobal: 68505 (localTransform localPointToGlobal: aPoint)! ! 68506 68507"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 68508 68509CompositeTransform class 68510 instanceVariableNames: ''! 68511 68512!CompositeTransform class methodsFor: 'instance creation' stamp: 'ls 3/19/2000 16:44'! 68513globalTransform: gt localTransform: lt 68514 ^self new globalTransform: gt localTransform: lt! ! 68515CharacterScanner subclass: #CompositionScanner 68516 instanceVariableNames: 'spaceX spaceIndex lineHeight baseline lineHeightAtSpace baselineAtSpace' 68517 classVariableNames: '' 68518 poolDictionaries: 'TextConstants' 68519 category: 'Graphics-Text'! 68520!CompositionScanner commentStamp: '<historical>' prior: 0! 68521CompositionScanners are used to measure text and determine where line breaks and space padding should occur.! 68522 68523 68524!CompositionScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 11:13'! 68525columnBreak 68526 68527 "Answer true. Set up values for the text line interval currently being 68528 composed." 68529 68530 pendingKernX := 0. 68531 line stop: lastIndex. 68532 spaceX := destX. 68533 line paddingWidth: rightMargin - spaceX. 68534 ^true! ! 68535 68536!CompositionScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 11:14'! 68537cr 68538 "Answer true. Set up values for the text line interval currently being 68539 composed." 68540 68541 pendingKernX := 0. 68542 line stop: lastIndex. 68543 spaceX := destX. 68544 line paddingWidth: rightMargin - spaceX. 68545 ^true! ! 68546 68547!CompositionScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 11:14'! 68548crossedX 68549 "There is a word that has fallen across the right edge of the composition 68550 rectangle. This signals the need for wrapping which is done to the last 68551 space that was encountered, as recorded by the space stop condition." 68552 68553 pendingKernX := 0. 68554 spaceCount >= 1 ifTrue: 68555 ["The common case. First back off to the space at which we wrap." 68556 line stop: spaceIndex. 68557 lineHeight := lineHeightAtSpace. 68558 baseline := baselineAtSpace. 68559 spaceCount := spaceCount - 1. 68560 spaceIndex := spaceIndex - 1. 68561 68562 "Check to see if any spaces preceding the one at which we wrap. 68563 Double space after punctuation, most likely." 68564 [(spaceCount > 1 and: [(text at: spaceIndex) = Space])] 68565 whileTrue: 68566 [spaceCount := spaceCount - 1. 68567 "Account for backing over a run which might 68568 change width of space." 68569 font := text fontAt: spaceIndex withStyle: textStyle. 68570 spaceIndex := spaceIndex - 1. 68571 spaceX := spaceX - (font widthOf: Space)]. 68572 line paddingWidth: rightMargin - spaceX. 68573 line internalSpaces: spaceCount] 68574 ifFalse: 68575 ["Neither internal nor trailing spaces -- almost never happens." 68576 lastIndex := lastIndex - 1. 68577 [destX <= rightMargin] 68578 whileFalse: 68579 [destX := destX - (font widthOf: (text at: lastIndex)). 68580 lastIndex := lastIndex - 1]. 68581 spaceX := destX. 68582 line paddingWidth: rightMargin - destX. 68583 line stop: (lastIndex max: line first)]. 68584 ^true! ! 68585 68586!CompositionScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 11:14'! 68587space 68588 "Record left x and character index of the space character just encounted. 68589 Used for wrap-around. Answer whether the character has crossed the 68590 right edge of the composition rectangle of the paragraph." 68591 68592 pendingKernX := 0. 68593 spaceX := destX. 68594 destX := spaceX + spaceWidth. 68595 spaceIndex := lastIndex. 68596 lineHeightAtSpace := lineHeight. 68597 baselineAtSpace := baseline. 68598 lastIndex := lastIndex + 1. 68599 spaceCount := spaceCount + 1. 68600 destX > rightMargin ifTrue: [^self crossedX]. 68601 ^false 68602! ! 68603 68604!CompositionScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 11:15'! 68605tab 68606 "Advance destination x according to tab settings in the paragraph's 68607 textStyle. Answer whether the character has crossed the right edge of 68608 the composition rectangle of the paragraph." 68609 68610 pendingKernX := 0. 68611 destX := textStyle 68612 nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin. 68613 destX > rightMargin ifTrue: [^self crossedX]. 68614 lastIndex := lastIndex + 1. 68615 ^false 68616! ! 68617 68618 68619!CompositionScanner methodsFor: 'accessing' stamp: 'ar 1/8/2000 14:35'! 68620rightX 68621 "Meaningful only when a line has just been composed -- refers to the 68622 line most recently composed. This is a subtrefuge to allow for easy 68623 resizing of a composition rectangle to the width of the maximum line. 68624 Useful only when there is only one line in the form or when each line 68625 is terminated by a carriage return. Handy for sizing menus and lists." 68626 68627 ^spaceX! ! 68628 68629 68630!CompositionScanner methodsFor: 'intialize-release' stamp: 'ar 5/17/2000 19:14'! 68631forParagraph: aParagraph 68632 "Initialize the receiver for scanning the given paragraph." 68633 68634 self 68635 initializeFromParagraph: aParagraph 68636 clippedBy: aParagraph clippingRectangle. 68637! ! 68638 68639 68640!CompositionScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 68641composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide 68642 "Answer an instance of TextLineInterval that represents the next line in the paragraph." 68643 "Set up margins" 68644 | runLength done stopCondition | 68645 leftMargin := lineRectangle left. 68646 leftSide ifTrue: 68647 [ leftMargin := leftMargin + (firstLine 68648 ifTrue: [ textStyle firstIndent ] 68649 ifFalse: [ textStyle restIndent ]) ]. 68650 destX := spaceX := leftMargin. 68651 rightMargin := lineRectangle right. 68652 rightSide ifTrue: [ rightMargin := rightMargin - textStyle rightIndent ]. 68653 lastIndex := startIndex. "scanning sets last index" 68654 destY := lineRectangle top. 68655 lineHeight := baseline := 0. "Will be increased by setFont" 68656 self setStopConditions. "also sets font" 68657 runLength := text runLengthFor: startIndex. 68658 runStopIndex := (lastIndex := startIndex) + (runLength - 1). 68659 line := (TextLine 68660 start: lastIndex 68661 stop: 0 68662 internalSpaces: 0 68663 paddingWidth: 0) rectangle: lineRectangle. 68664 spaceCount := 0. 68665 self handleIndentation. 68666 leftMargin := destX. 68667 line leftMargin: leftMargin. 68668 done := false. 68669 [ done ] whileFalse: 68670 [ stopCondition := self 68671 scanCharactersFrom: lastIndex 68672 to: runStopIndex 68673 in: text string 68674 rightX: rightMargin 68675 stopConditions: stopConditions 68676 kern: kern. 68677 "See setStopConditions for stopping conditions for composing." 68678 (self perform: stopCondition) ifTrue: 68679 [ ^ line 68680 lineHeight: lineHeight + textStyle leading 68681 baseline: baseline + textStyle leading ] ]! ! 68682 68683!CompositionScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 68684composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph 68685 "Answer an instance of TextLineInterval that represents the next line in the paragraph." 68686 | runLength done stopCondition | 68687 destX := spaceX := leftMargin := aParagraph leftMarginForCompositionForLine: lineIndex. 68688 destY := 0. 68689 rightMargin := aParagraph rightMarginForComposition. 68690 leftMargin >= rightMargin ifTrue: [ self error: 'No room between margins to compose' ]. 68691 lastIndex := startIndex. "scanning sets last index" 68692 lineHeight := textStyle lineGrid. "may be increased by setFont:..." 68693 baseline := textStyle baseline. 68694 self setStopConditions. "also sets font" 68695 self handleIndentation. 68696 runLength := text runLengthFor: startIndex. 68697 runStopIndex := (lastIndex := startIndex) + (runLength - 1). 68698 line := TextLineInterval 68699 start: lastIndex 68700 stop: 0 68701 internalSpaces: 0 68702 paddingWidth: 0. 68703 spaceCount := 0. 68704 done := false. 68705 [ done ] whileFalse: 68706 [ stopCondition := self 68707 scanCharactersFrom: lastIndex 68708 to: runStopIndex 68709 in: text string 68710 rightX: rightMargin 68711 stopConditions: stopConditions 68712 kern: kern. 68713 "See setStopConditions for stopping conditions for composing." 68714 (self perform: stopCondition) ifTrue: 68715 [ ^ line 68716 lineHeight: lineHeight + textStyle leading 68717 baseline: baseline + textStyle leading ] ]! ! 68718 68719!CompositionScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 68720setActualFont: aFont 68721 "Keep track of max height and ascent for auto lineheight" 68722 | descent | 68723 super setActualFont: aFont. 68724 lineHeight == nil 68725 ifTrue: 68726 [ descent := font descent. 68727 baseline := font ascent. 68728 lineHeight := baseline + descent ] 68729 ifFalse: 68730 [ descent := lineHeight - baseline max: font descent. 68731 baseline := baseline max: font ascent. 68732 lineHeight := lineHeight max: baseline + descent ]! ! 68733 68734 68735!CompositionScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! 68736endOfRun 68737 "Answer true if scanning has reached the end of the paragraph. 68738 Otherwise step conditions (mostly install potential new font) and answer 68739 false." 68740 | runLength | 68741 lastIndex = text size 68742 ifTrue: 68743 [ line stop: lastIndex. 68744 spaceX := destX. 68745 line paddingWidth: rightMargin - destX. 68746 ^ true ] 68747 ifFalse: 68748 [ runLength := text runLengthFor: (lastIndex := lastIndex + 1). 68749 runStopIndex := lastIndex + (runLength - 1). 68750 self setStopConditions. 68751 ^ false ]! ! 68752 68753!CompositionScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! 68754placeEmbeddedObject: anchoredMorph 68755 "Workaround: The following should really use #textAnchorType" 68756 | descent | 68757 anchoredMorph relativeTextAnchorPosition ifNotNil: [ ^ true ]. 68758 (super placeEmbeddedObject: anchoredMorph) ifFalse: 68759 [ "It doesn't fit" 68760 "But if it's the first character then leave it here" 68761 lastIndex < line first ifFalse: 68762 [ line stop: lastIndex - 1. 68763 ^ false ] ]. 68764 descent := lineHeight - baseline. 68765 lineHeight := lineHeight max: anchoredMorph height. 68766 baseline := lineHeight - descent. 68767 line stop: lastIndex. 68768 ^ true! ! 68769 68770!CompositionScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! 68771setFont 68772 super setFont. 68773 stopConditions == DefaultStopConditions ifTrue: [ stopConditions := stopConditions copy ]. 68774 stopConditions 68775 at: Space asciiValue + 1 68776 put: #space. 68777 wantsColumnBreaks == true ifTrue: 68778 [ stopConditions 68779 at: TextComposer characterForColumnBreak asciiValue + 1 68780 put: #columnBreak ]! ! 68781 68782!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/8/2000 14:37'! 68783setStopConditions 68784 "Set the font and the stop conditions for the current run." 68785 68786 self setFont! ! 68787TextConverter subclass: #CompoundTextConverter 68788 instanceVariableNames: 'state' 68789 classVariableNames: '' 68790 poolDictionaries: '' 68791 category: 'Multilingual-TextConversion'! 68792!CompoundTextConverter commentStamp: '<historical>' prior: 0! 68793Text converter for X Compound Text.! 68794 68795 68796!CompoundTextConverter methodsFor: 'conversion' stamp: 'ar 4/9/2005 22:25'! 68797nextFromStream: aStream 68798 68799 | character character2 size leadingChar offset result | 68800 aStream isBinary ifTrue: [^ aStream basicNext]. 68801 68802 character := aStream basicNext. 68803 character ifNil: [^ nil]. 68804 character == Character escape ifTrue: [ 68805 self parseShiftSeqFromStream: aStream. 68806 character := aStream basicNext. 68807 character ifNil: [^ nil]]. 68808 character asciiValue < 128 ifTrue: [ 68809 size := state g0Size. 68810 leadingChar := state g0Leading. 68811 offset := 16r21. 68812 ] ifFalse: [ 68813 size :=state g1Size. 68814 leadingChar := state g1Leading. 68815 offset := 16rA1. 68816 ]. 68817 size = 1 ifTrue: [ 68818 leadingChar = 0 68819 ifTrue: [^ character] 68820 ifFalse: [^ Character leadingChar: leadingChar code: character asciiValue] 68821 ]. 68822 size = 2 ifTrue: [ 68823 character2 := aStream basicNext. 68824 character2 ifNil: [^ nil. "self errorMalformedInput"]. 68825 character := character asciiValue - offset. 68826 character2 := character2 asciiValue - offset. 68827 result := Character leadingChar: leadingChar code: character * 94 + character2. 68828 ^ result asUnicodeChar. 68829 "^ self toUnicode: result" 68830 ]. 68831 self error: 'unsupported encoding'. 68832! ! 68833 68834!CompoundTextConverter methodsFor: 'conversion' stamp: 'ar 4/12/2005 14:10'! 68835nextPut: aCharacter toStream: aStream 68836 68837 | ascii leadingChar class | 68838 aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream]. 68839 aCharacter isTraditionalDomestic ifFalse: [ 68840 class := (EncodedCharSet charsetAt: aCharacter leadingChar) traditionalCharsetClass. 68841 ascii := (class charFromUnicode: aCharacter asUnicode) charCode. 68842 leadingChar := class leadingChar. 68843 ] ifTrue: [ 68844 ascii := aCharacter charCode. 68845 leadingChar := aCharacter leadingChar. 68846 ]. 68847 68848 self nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForLeadingChar: leadingChar. 68849! ! 68850 68851 68852!CompoundTextConverter methodsFor: 'friend' stamp: 'yo 8/18/2003 17:50'! 68853emitSequenceToResetStateIfNeededOn: aStream 68854 68855 Latin1 emitSequenceToResetStateIfNeededOn: aStream forState: state. 68856! ! 68857 68858!CompoundTextConverter methodsFor: 'friend' stamp: 'yo 11/4/2002 12:33'! 68859restoreStateOf: aStream with: aConverterState 68860 68861 state := aConverterState copy. 68862 aStream position: state streamPosition. 68863! ! 68864 68865!CompoundTextConverter methodsFor: 'friend' stamp: 'yo 11/4/2002 13:52'! 68866saveStateOf: aStream 68867 68868 | inst | 68869 inst := state clone. 68870 inst streamPosition: aStream position. 68871 ^ inst. 68872! ! 68873 68874 68875!CompoundTextConverter methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:49'! 68876initialize 68877 super initialize. 68878 state := CompoundTextConverterState 68879 g0Size: 1 g1Size: 1 g0Leading: 0 g1Leading: 0 charSize: 1 streamPosition: 0. 68880 68881" unused 68882 acceptingEncodings := #(ascii iso88591 jisx0208 gb2312 ksc5601 ksx1001 ) copy." 68883! ! 68884 68885 68886!CompoundTextConverter methodsFor: 'private' stamp: 'yo 11/4/2002 14:36'! 68887nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForLeadingChar: leadingChar 68888 68889 | charset | 68890 charset := EncodedCharSet charsetAt: leadingChar. 68891 charset ifNotNil: [ 68892 charset nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state. 68893 ] ifNil: [ 68894 "..." 68895 ]. 68896! ! 68897 68898!CompoundTextConverter methodsFor: 'private' stamp: 'marcus.denker 9/14/2008 21:14'! 68899parseShiftSeqFromStream: aStream 68900 68901 | c set target id | 68902 c := aStream basicNext. 68903 c = $$ ifTrue: [ 68904 set := #multibyte. 68905 c := aStream basicNext. 68906 c = $( ifTrue: [target := 1]. 68907 c = $) ifTrue: [target := 2]. 68908 target ifNil: [target := 1. id := c] 68909 ifNotNil: [id := aStream basicNext]. 68910 ] ifFalse: [ 68911 c = $( ifTrue: [target := 1. set := #nintyfour]. 68912 c = $) ifTrue: [target := 2. set := #nintyfour]. 68913 c = $- ifTrue: [target := 2. set := #nintysix]. 68914 id := aStream basicNext. 68915 ]. 68916 (set = #multibyte and: [id = $B]) ifTrue: [ 68917 state charSize: 2. 68918 target = 1 ifTrue: [ 68919 state g0Size: 2. 68920 state g0Leading: 1. 68921 ] ifFalse: [ 68922 state g1Size: 2. 68923 state g1Leading: 1. 68924 ]. 68925 ^ self 68926 ]. 68927 (set = #multibyte and: [id = $A]) ifTrue: [ 68928 state charSize: 2. 68929 target = 1 ifTrue: [ 68930 state g0Size: 2. 68931 state g0Leading: 2. 68932 ] ifFalse: [ 68933 state g1Size: 2. 68934 state g1Leading: 2. 68935 ]. 68936 ^ self 68937 ]. 68938 68939 (set = #nintyfour and: [id = $B or: [id = $J]]) ifTrue: [ 68940 state charSize: 1. 68941 state g0Size: 1. 68942 state g0Leading: 0. 68943 ^ self 68944 ]. 68945 (set = #nintysix and: [id = $A]) ifTrue: [ 68946 state charSize: 1. 68947 state g1Size: 1. 68948 state g1Leading: 0. 68949 ^ self 68950 ].! ! 68951 68952"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 68953 68954CompoundTextConverter class 68955 instanceVariableNames: ''! 68956 68957!CompoundTextConverter class methodsFor: 'utilities' stamp: 'yo 10/24/2002 14:16'! 68958encodingNames 68959 68960 ^ #('iso-2022-jp' 'x-ctext') copy 68961! ! 68962Object subclass: #CompoundTextConverterState 68963 instanceVariableNames: 'g0Size g1Size g0Leading g1Leading charSize streamPosition' 68964 classVariableNames: '' 68965 poolDictionaries: '' 68966 category: 'Multilingual-TextConversion'! 68967!CompoundTextConverterState commentStamp: '<historical>' prior: 0! 68968This represents the state of CompoundTextConverter.! 68969 68970 68971!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:30'! 68972charSize 68973 68974 ^ charSize 68975! ! 68976 68977!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! 68978charSize: s 68979 68980 charSize := s. 68981! ! 68982 68983!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'! 68984g0Leading 68985 68986 ^ g0Leading 68987! ! 68988 68989!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! 68990g0Leading: l 68991 68992 g0Leading := l. 68993! ! 68994 68995!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'! 68996g0Size 68997 68998 ^ g0Size 68999! ! 69000 69001!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! 69002g0Size: s 69003 69004 g0Size := s. 69005! ! 69006 69007!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 14:37'! 69008g0Size: g0 g1Size: g1 g0Leading: g0l g1Leading: g1l charSize: cSize streamPosition: pos 69009 69010 g0Size := g0. 69011 g1Size := g1. 69012 g0Leading := g0l. 69013 g1Leading := g1l. 69014 charSize := cSize. 69015 streamPosition := pos. 69016! ! 69017 69018!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:30'! 69019g1Leading 69020 69021 ^ g1Leading 69022! ! 69023 69024!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! 69025g1Leading: l 69026 69027 g1Leading := l. 69028! ! 69029 69030!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'! 69031g1Size 69032 69033 ^ g1Size 69034! ! 69035 69036!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! 69037g1Size: s 69038 69039 g1Size := s. 69040! ! 69041 69042!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 11/4/2002 12:31'! 69043printOn: aStream 69044 69045 aStream nextPut: $(; 69046 nextPutAll: g0Size printString; space; 69047 nextPutAll: g1Size printString; space; 69048 nextPutAll: g0Leading printString; space; 69049 nextPutAll: g1Leading printString; space; 69050 nextPutAll: charSize printString; space; 69051 nextPutAll: streamPosition printString. 69052 aStream nextPut: $). 69053! ! 69054 69055!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:30'! 69056streamPosition 69057 69058 ^ streamPosition 69059! ! 69060 69061!CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:40'! 69062streamPosition: pos 69063 69064 streamPosition := pos. 69065! ! 69066 69067"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 69068 69069CompoundTextConverterState class 69070 instanceVariableNames: ''! 69071 69072!CompoundTextConverterState class methodsFor: 'instance creation' stamp: 'yo 8/19/2002 17:04'! 69073g0Size: g0 g1Size: g1 g0Leading: g0l g1Leading: g1l charSize: cSize streamPosition: pos 69074 69075 ^ (self new) 69076 g0Size: g0 69077 g1Size: g1 69078 g0Leading: g0l 69079 g1Leading: g1l 69080 charSize: cSize 69081 streamPosition: pos 69082 ; yourself. 69083! ! 69084Object subclass: #CompressedBoundaryShape 69085 instanceVariableNames: 'points leftFills rightFills lineWidths lineFills fillStyles' 69086 classVariableNames: '' 69087 poolDictionaries: '' 69088 category: 'Balloon-Geometry'! 69089!CompressedBoundaryShape commentStamp: '<historical>' prior: 0! 69090This class represents a very compact representation of a boundary shape. It consists of a number of compressed arrays that can be handled by the balloon engine directly. Due to this, there are certain restrictions (see below). Boundaries are always represented by three subsequent points that define a quadratic bezier segment. It is recommended that for straight line segments the control point is set either to the previous or the next point. 69091 69092Instance variables: 69093 points <PointArray | ShortPointArray> Point storage area 69094 leftFills <ShortRunArray> Containing the "left" fill index of each segment 69095 rightFills <ShortRunArray> Containing the "right" fill index of each segment 69096 lineWidths <ShortRunArray> Containing the line width of each segment 69097 lineFills <ShortRunArray> Containing the line fill (e.g., line color) of each segment 69098 fillStyles <Collections> Contains the actual fill styles referenced by the indexes 69099 69100RESTRICTIONS: 69101None of the ShortRunArrays may contain a run of length Zero. 69102Also, due to the use of ShortRunArrays 69103 a) you cannot have more than 32768 different fill styles 69104 b) you cannot have a line width that exceeds 32768 69105In case you have trouble with a), try to merge some of the fills into one. You might do so by converting colors to 32bit pixel values. In case you have trouble with b) you might change the general resolution of the compressed shape to have less accuracy. 69106! 69107 69108 69109!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ls 10/10/1999 6911013:52'! 69111bounds 69112 | min max width | 69113 points isEmpty ifTrue:[^0@0 corner: 1@1]. 69114 min := max := points first. 69115 points do:[:pt| 69116 min := min min: pt. 69117 max := max max: pt 69118 ]. 69119 width := 0. 69120 lineWidths valuesDo:[:w| width := width max: w]. 69121 ^(min corner: max) insetBy: (width negated asPoint)! ! 69122 69123!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'! 69124fillStyles 69125 ^fillStyles! ! 69126 69127!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'! 69128leftFills 69129 ^leftFills! ! 69130 69131!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'! 69132lineFills 69133 ^lineFills! ! 69134 69135!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'! 69136lineWidths 69137 ^lineWidths! ! 69138 69139!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/4/1998 13:50'! 69140numSegments 69141 ^points size // 3! ! 69142 69143!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 20:42'! 69144points 69145 ^points! ! 69146 69147!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'! 69148rightFills 69149 ^rightFills! ! 69150 69151!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 01:01'! 69152segments 69153 "Return all the segments in the receiver" 69154 | out | 69155 out := Array new writeStream. 69156 self segmentsDo:[:seg| out nextPut: seg]. 69157 ^out contents! ! 69158 69159 69160!CompressedBoundaryShape methodsFor: 'editing' stamp: 'ar 11/12/1998 21:12'! 69161collectFills: aBlock 69162 fillStyles := fillStyles collect: aBlock.! ! 69163 69164!CompressedBoundaryShape methodsFor: 'editing' stamp: 'ar 11/12/1998 21:11'! 69165copyAndCollectFills: aBlock 69166 ^self copy collectFills: aBlock! ! 69167 69168 69169!CompressedBoundaryShape methodsFor: 'enumerating' stamp: 'ar 11/9/1998 14:10'! 69170segmentsDo: aBlock 69171 "Enumerate all segments in the receiver and execute aBlock" 69172 | p1 p2 p3 | 69173 1 to: points size by: 3 do:[:i| 69174 p1 := points at: i. 69175 p2 := points at: i+1. 69176 p3 := points at: i+2. 69177 (p1 = p2 or:[p2 = p3]) ifTrue:[ 69178 aBlock value: (LineSegment from: p1 to: p3). 69179 ] ifFalse:[ 69180 aBlock value: (Bezier2Segment from: p1 via: p2 to: p3). 69181 ]. 69182 ].! ! 69183 69184 69185!CompressedBoundaryShape methodsFor: 'morphing' stamp: 'ar 9/3/1999 17:19'! 69186morphFrom: srcShape to: dstShape at: ratio 69187 | scale unscale srcPoints dstPoints pt1 pt2 x y | 69188 scale := (ratio * 1024) asInteger. 69189 scale < 0 ifTrue:[scale := 0]. 69190 scale > 1024 ifTrue:[scale := 1024]. 69191 unscale := 1024 - scale. 69192 srcPoints := srcShape points. 69193 dstPoints := dstShape points. 69194 1 to: points size do:[:i| 69195 pt1 := srcPoints at: i. 69196 pt2 := dstPoints at: i. 69197 x := ((pt1 x * unscale) + (pt2 x * scale)) bitShift: -10. 69198 y := ((pt1 y * unscale) + (pt2 y * scale)) bitShift: -10. 69199 points at: i put: x@y].! ! 69200 69201 69202!CompressedBoundaryShape methodsFor: 'private' stamp: 'ar 11/3/1998 18:03'! 69203setPoints: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList 69204 points := pointList. 69205 leftFills := leftFillList. 69206 rightFills := rightFillList. 69207 lineWidths := lineWidthList. 69208 lineFills := lineFillList. 69209 fillStyles := fillStyleList.! ! 69210 69211"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 69212 69213CompressedBoundaryShape class 69214 instanceVariableNames: ''! 69215 69216!CompressedBoundaryShape class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 18:02'! 69217points: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList 69218 ^self new setPoints: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList! ! 69219ReadWriteStream subclass: #CompressedSourceStream 69220 instanceVariableNames: 'segmentFile segmentSize nSegments segmentTable segmentIndex dirty endOfFile' 69221 classVariableNames: '' 69222 poolDictionaries: '' 69223 category: 'Files-System'! 69224!CompressedSourceStream commentStamp: 'di 11/3/2003 17:58' prior: 0! 69225I implement a file format that compresses segment by segment to allow incremental writing and browsing. Note that the file can only be written at the end. 69226 69227Structure: 69228segmentFile The actual compressed file. 69229segmentSize This is the quantum of compression. The virtual file is sliced up 69230 into segments of this size. 69231nSegments The maximum number of segments to which this file can be grown. 69232endOfFile The user's endOfFile pointer. 69233segmentTable When a file is open, this table holds the physical file positions 69234 of the compressed segments. 69235segmentIndex Index of the most recently accessed segment. 69236 69237Inherited from ReadWriteStream... 69238collection The segment buffer, uncompressed 69239position This is the position *local* to the current segment buffer 69240readLimit ReadLimit for the current buffer 69241writeLimit WriteLimit for the current buffer 69242 69243Great care must be exercised to distinguish between the position relative to the segment buffer and the full file position (and, or course, the segment file position ;-). 69244 69245The implementation defaults to a buffer size of 20k, and a max file size of 34MB (conveniently chosen to be greater than the current 33MB limit of source code pointers). The format of the file is as follows: 69246 segmentSize 4 bytes 69247 nSegments 4 bytes 69248 endOfFile 4 bytes 69249 segmentTable 4 bytes * (nSegments+1) 69250 beginning of first compressed segment 69251 69252It is possible to override the default allocation by sending the message #segmentSize:nSegments: immediately after opening a new file for writing, as follows: 69253 69254 bigFile _ (CompressedSourceStream on: (FileStream newFileNamed: 'biggy.stc')) 69255 segmentSize: 50000 maxSize: 200000000 69256 69257The difference between segment table entries reveals the size of each compressed segment. When a file is being written, it may lack the final segment, but any flush, position:, or close will force a dirty segment to be written.! 69258 69259 69260!CompressedSourceStream methodsFor: 'access' stamp: 'di 11/3/2003 00:41'! 69261atEnd 69262 69263 position >= readLimit ifFalse: [^ false]. "more in segment" 69264 ^ self position >= endOfFile "more in file"! ! 69265 69266!CompressedSourceStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'! 69267contentsOfEntireFile 69268 | contents | 69269 self position: 0. 69270 contents := self next: self size. 69271 self close. 69272 ^ contents! ! 69273 69274!CompressedSourceStream methodsFor: 'access' stamp: 'di 11/1/2003 19:50'! 69275flush 69276 dirty ifTrue: 69277 ["Write buffer, compressed, to file, and also write the segment offset and eof" 69278 self writeSegment].! ! 69279 69280!CompressedSourceStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'! 69281next 69282 <primitive: 65> 69283 position >= readLimit 69284 ifTrue: [^ (self next: 1) at: 1] 69285 ifFalse: [^ collection at: (position := position + 1)]! ! 69286 69287!CompressedSourceStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'! 69288next: n 69289 | str | 69290 n <= (readLimit - position) ifTrue: 69291 ["All characters are available in buffer" 69292 str := collection copyFrom: position + 1 to: position + n. 69293 position := position + n. 69294 ^ str]. 69295 69296 "Read limit could be segment boundary or real end of file" 69297 (readLimit + self segmentOffset) = endOfFile ifTrue: 69298 ["Real end of file -- just return what's available" 69299 ^ self next: readLimit - position]. 69300 69301 "Read rest of segment. Then (after positioning) read what remains" 69302 str := self next: readLimit - position. 69303 self position: self position. 69304 ^ str , (self next: n - str size) 69305! ! 69306 69307!CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 11:27'! 69308nextPut: char 69309 "Slow, but we don't often write, and then not a lot" 69310 self nextPutAll: char asString. 69311 ^ char! ! 69312 69313!CompressedSourceStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'! 69314nextPutAll: str 69315 | n nInSeg | 69316 n := str size. 69317 n <= (writeLimit - position) ifTrue: 69318 ["All characters fit in buffer" 69319 collection replaceFrom: position + 1 to: position + n with: str. 69320 dirty := true. 69321 position := position + n. 69322 readLimit := readLimit max: position. 69323 endOfFile := endOfFile max: self position. 69324 ^ str]. 69325 69326 "Write what fits in segment. Then (after positioning) write what remains" 69327 nInSeg := writeLimit - position. 69328 nInSeg = 0 69329 ifTrue: [self position: self position. 69330 self nextPutAll: str] 69331 ifFalse: [self nextPutAll: (str first: nInSeg). 69332 self position: self position. 69333 self nextPutAll: (str allButFirst: nInSeg)] 69334 69335! ! 69336 69337!CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 09:27'! 69338position 69339 69340 ^ position + self segmentOffset! ! 69341 69342!CompressedSourceStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'! 69343position: newPosition 69344 | compressedBuffer newSegmentIndex | 69345 newPosition > endOfFile ifTrue: 69346 [self error: 'Attempt to position beyond the end of file']. 69347 newSegmentIndex := (newPosition // segmentSize) + 1. 69348 newSegmentIndex ~= segmentIndex ifTrue: 69349 [self flush. 69350 segmentIndex := newSegmentIndex. 69351 newSegmentIndex > nSegments ifTrue: 69352 [self error: 'file size limit exceeded']. 69353 segmentFile position: (segmentTable at: segmentIndex). 69354 (segmentTable at: segmentIndex+1) = 0 69355 ifTrue: 69356 [newPosition ~= endOfFile ifTrue: 69357 [self error: 'Internal logic error']. 69358 collection size = segmentSize ifFalse: 69359 [self error: 'Internal logic error']. 69360 "just leave garbage beyond end of file"] 69361 ifFalse: 69362 [compressedBuffer := segmentFile next: ((segmentTable at: segmentIndex+1) - (segmentTable at: segmentIndex)). 69363 collection := (GZipReadStream on: compressedBuffer) upToEnd asString]. 69364 readLimit := collection size min: endOfFile - self segmentOffset]. 69365 position := newPosition \\ segmentSize. 69366 ! ! 69367 69368!CompressedSourceStream methodsFor: 'access' stamp: 'di 11/1/2003 11:41'! 69369size 69370 ^ endOfFile ifNil: [0]! ! 69371 69372 69373!CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/1/2003 22:36'! 69374binary 69375 self error: 'Compressed source files are ascii to the user (though binary underneath)'! ! 69376 69377!CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/1/2003 22:36'! 69378close 69379 self flush. 69380 segmentFile close! ! 69381 69382!CompressedSourceStream methodsFor: 'open/close' stamp: 'stephaneducasse 2/4/2006 20:31'! 69383openOn: aFile 69384 "Open the receiver." 69385 segmentFile := aFile. 69386 segmentFile binary. 69387 segmentFile size > 0 69388 ifTrue: 69389 [self readHeaderInfo. "If file exists, then read the parameters"] 69390 ifFalse: 69391 [self segmentSize: 20000 maxSize: 34000000. "Otherwise write default values"]! ! 69392 69393!CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/3/2003 10:13'! 69394openReadOnly 69395 69396 segmentFile openReadOnly! ! 69397 69398!CompressedSourceStream methodsFor: 'open/close' stamp: 'stephaneducasse 2/4/2006 20:31'! 69399readHeaderInfo 69400 | valid a b | 69401 segmentFile position: 0. 69402 segmentSize := segmentFile nextNumber: 4. 69403 nSegments := segmentFile nextNumber: 4. 69404 endOfFile := segmentFile nextNumber: 4. 69405 segmentFile size < (nSegments+1 + 3 * 4) ifTrue: "Check for reasonable segment info" 69406 [self error: 'This file is not in valid compressed source format']. 69407 segmentTable := (1 to: nSegments+1) collect: [:x | segmentFile nextNumber: 4]. 69408 segmentTable first ~= self firstSegmentLoc ifTrue: 69409 [self error: 'This file is not in valid compressed source format']. 69410 valid := true. 69411 1 to: nSegments do: "Check that segment offsets are ascending" 69412 [:i | a := segmentTable at: i. b := segmentTable at: i+1. 69413 (a = 0 and: [b ~= 0]) ifTrue: [valid := false]. 69414 (a ~= 0 and: [b ~= 0]) ifTrue: [b <= a ifTrue: [valid := false]]]. 69415 valid ifFalse: 69416 [self error: 'This file is not in valid compressed source format']. 69417 dirty := false. 69418 self position: 0.! ! 69419 69420!CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/3/2003 10:09'! 69421readOnlyCopy 69422 69423 ^ self class on: segmentFile readOnlyCopy! ! 69424 69425!CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/2/2003 23:07'! 69426test 69427 "FileDirectory default deleteFileNamed: 'test.stc'. 69428 (CompressedSourceStream on: (FileStream newFileNamed: 'test.stc')) fileOutChanges" 69429 69430 "FileDirectory default deleteFileNamed: 'test2.stc'. 69431 ((CompressedSourceStream on: (FileStream newFileNamed: 'test2.stc')) 69432 segmentSize: 100 nSegments: 1000) fileOutChanges" 69433 69434 "FileDirectory default deleteFileNamed: 'test3.st'. 69435 (FileStream newFileNamed: 'test3.st') fileOutChanges" 69436 69437 "(CompressedSourceStream on: (FileStream oldFileNamed: 'test.stc')) contentsOfEntireFile" 69438! ! 69439 69440 69441!CompressedSourceStream methodsFor: 'private' stamp: 'di 11/20/2003 12:45'! 69442fileID "Only needed for OSProcess stuff" 69443 ^ segmentFile fileID 69444! ! 69445 69446!CompressedSourceStream methodsFor: 'private' stamp: 'di 11/2/2003 09:35'! 69447firstSegmentLoc 69448 "First segment follows 3 header words and segment table" 69449 ^ (3 + nSegments+1) * 4! ! 69450 69451!CompressedSourceStream methodsFor: 'private' stamp: 'di 11/2/2003 09:24'! 69452segmentOffset 69453 69454 ^ segmentIndex - 1 * segmentSize! ! 69455 69456!CompressedSourceStream methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'! 69457segmentSize: segSize maxSize: maxSize 69458 "Note that this method can be called after the initial open, provided that no 69459 writing has yet taken place. This is how to override the default segmentation." 69460 self size = 0 ifFalse: [self error: 'Cannot set parameters after the first write']. 69461 segmentFile position: 0. 69462 segmentFile nextNumber: 4 put: (segmentSize := segSize). 69463 segmentFile nextNumber: 4 put: (nSegments := maxSize // segSize + 2). 69464 segmentFile nextNumber: 4 put: (endOfFile := 0). 69465 segmentTable := Array new: nSegments+1 withAll: 0. 69466 segmentTable at: 1 put: self firstSegmentLoc. "Loc of first segment, always." 69467 segmentTable do: [:i | segmentFile nextNumber: 4 put: i]. 69468 segmentIndex := 1. 69469 collection := String new: segmentSize. 69470 writeLimit := segmentSize. 69471 readLimit := 0. 69472 position := 0. 69473 endOfFile := 0. 69474 self writeSegment. 69475! ! 69476 69477!CompressedSourceStream methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'! 69478writeSegment 69479 "The current segment must be the last in the file." 69480 | compressedSegment | 69481 segmentFile position: (segmentTable at: segmentIndex). 69482 compressedSegment := ByteArray streamContents: 69483 [:strm | (GZipWriteStream on: strm) nextPutAll: collection asByteArray; close]. 69484 segmentFile nextPutAll: compressedSegment. 69485 segmentTable at: segmentIndex + 1 put: segmentFile position. 69486 69487 segmentFile position: 2 * 4. 69488 segmentFile nextNumber: 4 put: endOfFile. 69489 segmentFile position: (segmentIndex + 3) * 4. 69490 segmentFile nextNumber: 4 put: (segmentTable at: segmentIndex + 1). 69491 dirty := false! ! 69492 69493"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 69494 69495CompressedSourceStream class 69496 instanceVariableNames: ''! 69497 69498!CompressedSourceStream class methodsFor: 'as yet unclassified' stamp: 'di 11/1/2003 22:58'! 69499on: aFile 69500 ^ self basicNew openOn: aFile! ! 69501NetworkError subclass: #ConnectionClosed 69502 instanceVariableNames: '' 69503 classVariableNames: '' 69504 poolDictionaries: '' 69505 category: 'Network-Kernel'! 69506!ConnectionClosed commentStamp: 'mir 5/12/2003 18:12' prior: 0! 69507Signals a prematurely closed connection. 69508! 69509 69510Object subclass: #ConnectionQueue 69511 instanceVariableNames: 'portNumber maxQueueLength connections accessSema socket process' 69512 classVariableNames: '' 69513 poolDictionaries: '' 69514 category: 'Network-Kernel'! 69515!ConnectionQueue commentStamp: '<historical>' prior: 0! 69516A ConnectionQueue listens on a given port number and collects a queue of client connections. In order to handle state changes quickly, a ConnectionQueue has its own process that: (a) tries to keep a socket listening on the port whenever the queue isn't already full of connections and (b) prunes stale connections out of the queue to make room for fresh ones. 69517! 69518 69519 69520!ConnectionQueue methodsFor: 'public' stamp: 'jm 3/10/98 17:31'! 69521connectionCount 69522 "Return an estimate of the number of currently queued connections. This is only an estimate since a new connection could be made, or an existing one aborted, at any moment." 69523 69524 | count | 69525 self pruneStaleConnections. 69526 accessSema critical: [count := connections size]. 69527 ^ count 69528! ! 69529 69530!ConnectionQueue methodsFor: 'public' stamp: 'jm 3/9/98 14:34'! 69531destroy 69532 "Terminate the listener process and destroy all sockets in my possesion." 69533 69534 process ifNotNil: [ 69535 process terminate. 69536 process := nil]. 69537 socket ifNotNil: [ 69538 socket destroy. 69539 socket := nil]. 69540 connections do: [:s | s destroy]. 69541 connections := OrderedCollection new. 69542! ! 69543 69544!ConnectionQueue methodsFor: 'public' stamp: 'jm 3/10/98 09:18'! 69545getConnectionOrNil 69546 "Return a connected socket, or nil if no connection has been established." 69547 69548 | result | 69549 accessSema critical: [ 69550 connections isEmpty 69551 ifTrue: [result := nil] 69552 ifFalse: [ 69553 result := connections removeFirst. 69554 ((result isValid) and: [result isConnected]) ifFalse: [ "stale connection" 69555 result destroy. 69556 result := nil]]]. 69557 ^ result 69558! ! 69559 69560!ConnectionQueue methodsFor: 'public' stamp: 'RAA 7/15/2000 12:36'! 69561getConnectionOrNilLenient 69562 "Return a connected socket, or nil if no connection has been established." 69563 69564 | result | 69565 accessSema critical: [ 69566 connections isEmpty ifTrue: [ 69567 result := nil 69568 ] ifFalse: [ 69569 result := connections removeFirst. 69570 (result isValid and: [result isConnected or: [result isOtherEndClosed]]) ifFalse: [ 69571 "stale connection" 69572 result destroy. 69573 result := nil 69574 ] 69575 ] 69576 ]. 69577 ^ result 69578! ! 69579 69580!ConnectionQueue methodsFor: 'public' stamp: 'ls 9/26/1999 15:34'! 69581isValid 69582 ^process notNil! ! 69583 69584 69585!ConnectionQueue methodsFor: 'private' stamp: 'jm 3/10/98 11:07'! 69586initPortNumber: anInteger queueLength: queueLength 69587 "Private!! Initialize the receiver to listen on the given port number. Up to queueLength connections will be queued." 69588 69589 portNumber := anInteger. 69590 maxQueueLength := queueLength. 69591 connections := OrderedCollection new. 69592 accessSema := Semaphore forMutualExclusion. 69593 socket := nil. 69594 process := [self listenLoop] newProcess. 69595 process priority: Processor highIOPriority. 69596 process resume. 69597! ! 69598 69599!ConnectionQueue methodsFor: 'private' stamp: 'bf 6/29/2007 17:58'! 69600listenLoop 69601 "Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port." 69602 "Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection." 69603 "Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms." 69604 69605 69606 | newConnection adressInfos | 69607 NetNameResolver useOldNetwork 69608 ifTrue: [^self oldListenLoop]. 69609 69610 adressInfos := SocketAddressInformation 69611 forHost: '' service: portNumber asString 69612 flags: SocketAddressInformation passiveFlag 69613 addressFamily: SocketAddressInformation addressFamilyINET4 69614 socketType: SocketAddressInformation socketTypeStream 69615 protocol: SocketAddressInformation protocolTCP. 69616 "We'll accept four simultanous connections at the same time" 69617 socket := adressInfos first listenWithBacklog: 4. 69618 "If the listener is not valid then the we cannot use the 69619 BSD style accept() mechanism." 69620 socket isValid ifFalse: [^self oldStyleListenLoop]. 69621 [true] whileTrue: [ 69622 socket isValid ifFalse: [ 69623 "socket has stopped listening for some reason" 69624 socket destroy. 69625 (Delay forMilliseconds: 10) wait. 69626 ^self listenLoop ]. 69627 newConnection := socket waitForAcceptFor: 10. 69628 (newConnection notNil and:[newConnection isConnected]) ifTrue: 69629 [accessSema critical: [connections addLast: newConnection]. 69630 newConnection := nil]. 69631 self pruneStaleConnections]. ! ! 69632 69633!ConnectionQueue methodsFor: 'private' stamp: 'bf 6/29/2007 17:29'! 69634oldListenLoop 69635 "Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port." 69636 "Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection." 69637 "Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms." 69638 69639 69640 | newConnection | 69641 socket := Socket newTCP. 69642 "We'll accept four simultanous connections at the same time" 69643 socket listenOn: portNumber backlogSize: 4. 69644 "If the listener is not valid then the we cannot use the 69645 BSD style accept() mechanism." 69646 socket isValid ifFalse: [^self oldStyleListenLoop]. 69647 [true] whileTrue: [ 69648 socket isValid ifFalse: [ 69649 "socket has stopped listening for some reason" 69650 socket destroy. 69651 (Delay forMilliseconds: 10) wait. 69652 ^self oldListenLoop ]. 69653 newConnection := socket waitForAcceptFor: 10. 69654 (newConnection notNil and:[newConnection isConnected]) ifTrue: 69655 [accessSema critical: [connections addLast: newConnection]. 69656 newConnection := nil]. 69657 self pruneStaleConnections]. ! ! 69658 69659!ConnectionQueue methodsFor: 'private' stamp: 'mir 5/15/2003 18:28'! 69660oldStyleListenLoop 69661 "Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port." 69662 "Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection." 69663 "Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms." 69664 69665 [true] whileTrue: [ 69666 ((socket == nil) and: [connections size < maxQueueLength]) ifTrue: [ 69667 "try to create a new socket for listening" 69668 socket := Socket createIfFail: [nil]]. 69669 69670 socket == nil 69671 ifTrue: [(Delay forMilliseconds: 100) wait] 69672 ifFalse: [ 69673 socket isUnconnected ifTrue: [socket listenOn: portNumber]. 69674 [socket waitForConnectionFor: 10] 69675 on: ConnectionTimedOut 69676 do: [:ex | 69677 socket isConnected 69678 ifTrue: [ "connection established" 69679 accessSema critical: [connections addLast: socket]. 69680 socket := nil] 69681 ifFalse: [ 69682 socket isWaitingForConnection 69683 ifFalse: [socket destroy. socket := nil]]]]. "broken socket; start over" 69684 self pruneStaleConnections]. 69685! ! 69686 69687!ConnectionQueue methodsFor: 'private' stamp: 'jm 3/10/98 17:30'! 69688pruneStaleConnections 69689 "Private!! The client may establish a connection and then disconnect while it is still in the connection queue. This method is called periodically to prune such sockets out of the connection queue and make room for fresh connections." 69690 69691 | foundStaleConnection | 69692 accessSema critical: [ 69693 foundStaleConnection := false. 69694 connections do: [:s | 69695 s isUnconnected ifTrue: [ 69696 s destroy. 69697 foundStaleConnection := true]]. 69698 foundStaleConnection ifTrue: [ 69699 connections := connections select: [:s | s isValid]]]. 69700! ! 69701 69702"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 69703 69704ConnectionQueue class 69705 instanceVariableNames: ''! 69706 69707!ConnectionQueue class methodsFor: 'instance creation' stamp: 'jm 3/9/98 14:09'! 69708portNumber: anInteger queueLength: queueLength 69709 69710 ^ self new initPortNumber: anInteger queueLength: queueLength 69711! ! 69712NetworkError subclass: #ConnectionRefused 69713 instanceVariableNames: 'host port' 69714 classVariableNames: '' 69715 poolDictionaries: '' 69716 category: 'Network-Kernel'! 69717!ConnectionRefused commentStamp: 'mir 5/12/2003 18:14' prior: 0! 69718Signals that a connection to the specified host and port was refused. 69719 69720 host host which refused the connection 69721 port prot to which the connection was refused 69722! 69723 69724 69725!ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:58'! 69726host 69727 ^ host! ! 69728 69729!ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:39'! 69730host: addressOrHostName port: portNumber 69731 host := addressOrHostName. 69732 port := portNumber! ! 69733 69734!ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:58'! 69735port 69736 ^ port! ! 69737 69738"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 69739 69740ConnectionRefused class 69741 instanceVariableNames: ''! 69742 69743!ConnectionRefused class methodsFor: 'instance creation' stamp: 'len 12/14/2002 11:39'! 69744host: addressOrHostName port: portNumber 69745 ^ self new host: addressOrHostName port: portNumber! ! 69746NetworkError subclass: #ConnectionTimedOut 69747 instanceVariableNames: '' 69748 classVariableNames: '' 69749 poolDictionaries: '' 69750 category: 'Network-Kernel'! 69751!ConnectionTimedOut commentStamp: 'mir 5/12/2003 18:14' prior: 0! 69752Signals that a connection attempt timed out. 69753! 69754 69755TestCase subclass: #ContextCompilationTest 69756 instanceVariableNames: '' 69757 classVariableNames: '' 69758 poolDictionaries: '' 69759 category: 'Tests-Compiler'! 69760 69761!ContextCompilationTest methodsFor: 'tests' stamp: 'eem 6/19/2008 10:11'! 69762testVariablesAndOffsetsDo 69763 69764 "ContextCompilationTest new testVariablesAndOffsetsDo" 69765 | contextClasses | 69766 contextClasses := ContextPart withAllSuperclasses, ContextPart allSubclasses asArray. 69767 contextClasses do: 69768 [:class| 69769 class variablesAndOffsetsDo: 69770 [:var :offset| 69771 self assert: offset < 0. 69772 self assert: (class instVarNameForIndex: offset negated) == var]]. 69773 69774 InstructionStream withAllSuperclasses, InstructionStream allSubclasses asArray do: 69775 [:class| 69776 (contextClasses includes: class) ifFalse: 69777 [class variablesAndOffsetsDo: 69778 [:var :offset| 69779 (InstructionStream instVarNames includes: var) ifFalse: 69780 [self assert: offset > 0. 69781 self assert: (class instVarNameForIndex: offset) == var]]]]! ! 69782InstructionStream subclass: #ContextPart 69783 instanceVariableNames: 'stackp' 69784 classVariableNames: 'PrimitiveFailToken QuickStep' 69785 poolDictionaries: '' 69786 category: 'Kernel-Methods'! 69787!ContextPart commentStamp: '<historical>' prior: 0! 69788To the instruction parsing ability of InstructionStream I add the actual semantics for execution. The execution state is stored in the indexable fields of my subclasses. This includes temporary variables and a stack of values used in evaluating expressions. The actual semantics of execution can be found in my category "system simulation" and "instruction decode". These methods exactly parallel the operation of the Smalltalk machine itself. 69789 69790The simulator is a group of my methods that do what the Smalltalk interpreter does: execute Smalltalk bytecodes. By adding code to the simulator, you may take statistics on the running of Smalltalk methods. For example, 69791 Transcript show: (ContextPart runSimulated: [3 factorial]) printString.! 69792 69793 69794!ContextPart methodsFor: 'accessing' stamp: 'stephane.ducasse 3/1/2009 08:41'! 69795arguments 69796 "returns the arguments of a message invocation" 69797 69798 | arguments numargs | 69799 numargs := self method numArgs. 69800 arguments := Array new: numargs. 69801 1 to: numargs do: [:i | arguments at: i put: (self tempAt: i) ]. 69802 ^ arguments! ! 69803 69804!ContextPart methodsFor: 'accessing' stamp: 'eem 6/27/2008 15:55'! 69805at: index 69806 "Primitive. Assumes receiver is indexable. Answer the value of an 69807 indexable element in the receiver. Fail if the argument index is not an 69808 Integer or is out of bounds. Essential. See Object documentation 69809 whatIsAPrimitive. Override the default primitive to give latitude to 69810 the VM in context management." 69811 69812 <primitive: 210> 69813 index isInteger ifTrue: 69814 [self errorSubscriptBounds: index]. 69815 index isNumber 69816 ifTrue: [^self at: index asInteger] 69817 ifFalse: [self errorNonIntegerIndex]! ! 69818 69819!ContextPart methodsFor: 'accessing' stamp: 'eem 6/27/2008 15:57'! 69820at: index put: value 69821 "Primitive. Assumes receiver is indexable. Answer the value of an 69822 indexable element in the receiver. Fail if the argument index is not 69823 an Integer or is out of bounds. Essential. See Object documentation 69824 whatIsAPrimitive. Override the default primitive to give latitude to 69825 the VM in context management." 69826 69827 <primitive: 211> 69828 index isInteger ifTrue: 69829 [self errorSubscriptBounds: index]. 69830 index isNumber 69831 ifTrue: [^self at: index asInteger put: value] 69832 ifFalse: [self errorNonIntegerIndex]! ! 69833 69834!ContextPart methodsFor: 'accessing' stamp: 'eem 6/27/2008 15:56'! 69835basicAt: index 69836 "Primitive. Assumes receiver is indexable. Answer the value of an 69837 indexable element in the receiver. Fail if the argument index is not an 69838 Integer or is out of bounds. Essential. See Object documentation 69839 whatIsAPrimitive. Override the default primitive to give latitude to 69840 the VM in context management." 69841 69842 <primitive: 210> 69843 index isInteger ifTrue: 69844 [self errorSubscriptBounds: index]. 69845 index isNumber 69846 ifTrue: [^self at: index asInteger] 69847 ifFalse: [self errorNonIntegerIndex]! ! 69848 69849!ContextPart methodsFor: 'accessing' stamp: 'eem 6/27/2008 15:57'! 69850basicAt: index put: value 69851 "Primitive. Assumes receiver is indexable. Answer the value of an 69852 indexable element in the receiver. Fail if the argument index is not 69853 an Integer or is out of bounds. Essential. See Object documentation 69854 whatIsAPrimitive. Override the default primitive to give latitude to 69855 the VM in context management." 69856 69857 <primitive: 211> 69858 index isInteger ifTrue: 69859 [self errorSubscriptBounds: index]. 69860 index isNumber 69861 ifTrue: [^self at: index asInteger put: value] 69862 ifFalse: [self errorNonIntegerIndex]! ! 69863 69864!ContextPart methodsFor: 'accessing' stamp: 'eem 6/27/2008 10:45'! 69865basicSize 69866 "Primitive. Answer the number of indexable variables in the receiver. 69867 This value is the same as the largest legal subscript. Essential. Do not 69868 override in any subclass. See Object documentation whatIsAPrimitive. Override the default primitive to give latitude to 69869 the VM in context management." 69870 69871 <primitive: 212> 69872 "The number of indexable fields of fixed-length objects is 0" 69873 ^self primitiveFail! ! 69874 69875!ContextPart methodsFor: 'accessing'! 69876client 69877 "Answer the client, that is, the object that sent the message that created this context." 69878 69879 ^sender receiver! ! 69880 69881!ContextPart methodsFor: 'accessing' stamp: 'eem 6/15/2008 11:31'! 69882contextForLocalVariables 69883 "Answer the context in which local variables (temporaries) are stored." 69884 69885 self subclassResponsibility! ! 69886 69887!ContextPart methodsFor: 'accessing'! 69888home 69889 "Answer the context in which the receiver was defined." 69890 69891 self subclassResponsibility! ! 69892 69893!ContextPart methodsFor: 'accessing'! 69894method 69895 "Answer the method of this context." 69896 69897 self subclassResponsibility! ! 69898 69899!ContextPart methodsFor: 'accessing' stamp: 'ar 4/11/2006 01:49'! 69900methodNode 69901 ^ self method methodNode.! ! 69902 69903!ContextPart methodsFor: 'accessing' stamp: 'eem 6/15/2008 11:27'! 69904methodReturnContext 69905 "Answer the context from which an ^-return should return from." 69906 69907 self subclassResponsibility! ! 69908 69909!ContextPart methodsFor: 'accessing' stamp: 'lr 3/22/2009 19:15'! 69910methodSelector 69911 ^ self method selector! ! 69912 69913!ContextPart methodsFor: 'accessing'! 69914receiver 69915 "Answer the receiver of the message that created this context." 69916 69917 self subclassResponsibility! ! 69918 69919!ContextPart methodsFor: 'accessing' stamp: 'eem 6/27/2008 10:46'! 69920size 69921 "Primitive. Answer the number of indexable variables in the receiver. 69922 This value is the same as the largest legal subscript. Essential. See Object 69923 documentation whatIsAPrimitive. Override the default primitive to give latitude to 69924 the VM in context management." 69925 69926 <primitive: 212> 69927 "The number of indexable fields of fixed-length objects is 0" 69928 ^self primitiveFail! ! 69929 69930!ContextPart methodsFor: 'accessing'! 69931tempAt: index 69932 "Answer the value of the temporary variable whose index is the 69933 argument, index." 69934 69935 self subclassResponsibility! ! 69936 69937!ContextPart methodsFor: 'accessing'! 69938tempAt: index put: value 69939 "Store the argument, value, as the temporary variable whose index is the 69940 argument, index." 69941 69942 self subclassResponsibility! ! 69943 69944!ContextPart methodsFor: 'accessing' stamp: 'md 2/9/2007 17:34'! 69945tempNamed: aName 69946 "Answer the value of the temporary variable whose name is the 69947 argument, aName." 69948 69949 self subclassResponsibility! ! 69950 69951!ContextPart methodsFor: 'accessing' stamp: 'md 2/9/2007 17:34'! 69952tempNamed: aName put: value 69953 "Store the argument, value, as the temporary variable whose name is the 69954 argument, aName." 69955 69956 self subclassResponsibility! ! 69957 69958 69959!ContextPart methodsFor: 'controlling'! 69960activateMethod: newMethod withArgs: args receiver: rcvr class: class 69961 "Answer a ContextPart initialized with the arguments." 69962 69963 ^MethodContext 69964 sender: self 69965 receiver: rcvr 69966 method: newMethod 69967 arguments: args! ! 69968 69969!ContextPart methodsFor: 'controlling' stamp: 'eem 6/14/2008 19:17'! 69970blockCopy: numArgs 69971 "Primitive. Distinguish a block of code from its enclosing method by 69972 creating a new BlockContext for that block. The compiler inserts into all 69973 methods that contain blocks the bytecodes to send the message 69974 blockCopy:. Do not use blockCopy: in code that you write!! Only the 69975 compiler can decide to send the message blockCopy:. Fail if numArgs is 69976 not a SmallInteger. Optional. No Lookup. See Object documentation 69977 whatIsAPrimitive." 69978 69979 <primitive: 80> 69980 ^ (BlockContext newForMethod: self method) 69981 home: self home 69982 startpc: pc + 2 69983 nargs: numArgs! ! 69984 69985!ContextPart methodsFor: 'controlling' stamp: 'eem 8/29/2008 06:27'! 69986closureCopy: numArgs copiedValues: anArray 69987 "Distinguish a block of code from its enclosing method by 69988 creating a BlockClosure for that block. The compiler inserts into all 69989 methods that contain blocks the bytecodes to send the message 69990 closureCopy:copiedValues:. Do not use closureCopy:copiedValues: in code that you write!! Only the 69991 compiler can decide to send the message closureCopy:copiedValues:. Fail if numArgs is 69992 not a SmallInteger. Optional. No Lookup. See Object documentation 69993 whatIsAPrimitive." 69994 69995 <primitive: 200> 69996 ^BlockClosure outerContext: self startpc: pc + 2 numArgs: numArgs copiedValues: anArray! ! 69997 69998!ContextPart methodsFor: 'controlling'! 69999hasSender: context 70000 "Answer whether the receiver is strictly above context on the stack." 70001 70002 | s | 70003 self == context ifTrue: [^false]. 70004 s := sender. 70005 [s == nil] 70006 whileFalse: 70007 [s == context ifTrue: [^true]. 70008 s := s sender]. 70009 ^false! ! 70010 70011!ContextPart methodsFor: 'controlling' stamp: 'ajh 3/25/2004 00:07'! 70012jump 70013 "Abandon thisContext and resume self instead (using the same current process). You may want to save thisContext's sender before calling this so you can jump back to it. 70014 Self MUST BE a top context (ie. a suspended context or a abandoned context that was jumped out of). A top context already has its return value on its stack (see Interpreter>>primitiveSuspend and other suspending primitives). 70015 thisContext's sender is converted to a top context (by pushing a nil return value on its stack) so it can be jump back to." 70016 70017 | top | 70018 "Make abandoned context a top context (has return value (nil)) so it can be jumped back to" 70019 thisContext sender push: nil. 70020 70021 "Pop self return value then return it to self (since we jump to self by returning to it)" 70022 stackp = 0 ifTrue: [self stepToSendOrReturn]. 70023 stackp = 0 ifTrue: [self push: nil]. "must be quick return self/constant" 70024 top := self pop. 70025 thisContext privSender: self. 70026 ^ top! ! 70027 70028!ContextPart methodsFor: 'controlling' stamp: 'di 1/11/1999 22:40'! 70029pop 70030 "Answer the top of the receiver's stack and remove the top of the stack." 70031 | val | 70032 val := self at: stackp. 70033 self stackp: stackp - 1. 70034 ^ val! ! 70035 70036!ContextPart methodsFor: 'controlling' stamp: 'di 1/11/1999 22:39'! 70037push: val 70038 "Push val on the receiver's stack." 70039 70040 self stackp: stackp + 1. 70041 self at: stackp put: val! ! 70042 70043!ContextPart methodsFor: 'controlling' stamp: 'hmm 7/17/2001 20:57'! 70044quickSend: selector to: receiver with: arguments super: superFlag 70045 "Send the given selector with arguments in an environment which closely resembles the non-simulating environment, with an interjected unwind-protected block to catch nonlocal returns. 70046 Attention: don't get lost!!" 70047 | oldSender contextToReturnTo result lookupClass | 70048 contextToReturnTo := self. 70049 lookupClass := superFlag 70050 ifTrue: [(self method literalAt: self method numLiterals) value superclass] 70051 ifFalse: [receiver class]. 70052 [oldSender := thisContext sender swapSender: self. 70053 result := receiver perform: selector withArguments: arguments inSuperclass: lookupClass. 70054 thisContext sender swapSender: oldSender] ifCurtailed: [ 70055 contextToReturnTo := thisContext sender receiver. "The block context returning nonlocally" 70056 contextToReturnTo jump: -1. "skip to front of return bytecode causing this unwind" 70057 contextToReturnTo nextByte = 16r7C ifTrue: [ 70058 "If it was a returnTop, push the value to be returned. 70059 Otherwise the value is implicit in the bytecode" 70060 contextToReturnTo push: (thisContext sender tempAt: 1)]. 70061 thisContext swapSender: thisContext home sender. "Make this block return to the method's sender" 70062 contextToReturnTo]. 70063 contextToReturnTo push: result. 70064 ^contextToReturnTo! ! 70065 70066!ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:32'! 70067restart 70068 "Unwind thisContext to self and resume from beginning. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" 70069 70070 | ctxt unwindBlock | 70071 self isDead ifTrue: [self cannotReturn: nil to: self]. 70072 self privRefresh. 70073 ctxt := thisContext. 70074 [ ctxt := ctxt findNextUnwindContextUpTo: self. 70075 ctxt isNil 70076 ] whileFalse: [ 70077 unwindBlock := ctxt tempAt: 1. 70078 unwindBlock ifNotNil: [ 70079 ctxt tempAt: 1 put: nil. 70080 thisContext terminateTo: ctxt. 70081 unwindBlock value]. 70082 ]. 70083 thisContext terminateTo: self. 70084 self jump. 70085! ! 70086 70087!ContextPart methodsFor: 'controlling' stamp: 'ajh 6/27/2003 22:17'! 70088resume 70089 "Roll back thisContext to self and resume. Execute unwind blocks when rolling back. ASSUMES self is a sender of thisContext" 70090 70091 self resume: nil! ! 70092 70093!ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:32'! 70094resume: value 70095 "Unwind thisContext to self and resume with value as result of last send. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" 70096 70097 | ctxt unwindBlock | 70098 self isDead ifTrue: [self cannotReturn: value to: self]. 70099 ctxt := thisContext. 70100 [ ctxt := ctxt findNextUnwindContextUpTo: self. 70101 ctxt isNil 70102 ] whileFalse: [ 70103 unwindBlock := ctxt tempAt: 1. 70104 unwindBlock ifNotNil: [ 70105 ctxt tempAt: 1 put: nil. 70106 thisContext terminateTo: ctxt. 70107 unwindBlock value]. 70108 ]. 70109 thisContext terminateTo: self. 70110 ^ value 70111! ! 70112 70113!ContextPart methodsFor: 'controlling' stamp: 'ajh 1/21/2003 19:27'! 70114return 70115 "Unwind until my sender is on top" 70116 70117 self return: self receiver! ! 70118 70119!ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:27'! 70120return: value 70121 "Unwind thisContext to self and return value to self's sender. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext" 70122 70123 sender ifNil: [self cannotReturn: value to: sender]. 70124 sender resume: value! ! 70125 70126!ContextPart methodsFor: 'controlling' stamp: 'ajh 1/24/2003 15:30'! 70127return: value to: sendr 70128 "Simulate the return of value to sendr." 70129 70130 self releaseTo: sendr. 70131 sendr ifNil: [^ nil]. 70132 ^ sendr push: value! ! 70133 70134!ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:20'! 70135runUntilErrorOrReturnFrom: aSender 70136 "ASSUMES aSender is a sender of self. Execute self's stack until aSender returns or an unhandled exception is raised. Return a pair containing the new top context and a possibly nil exception. The exception is not nil if it was raised before aSender returned and it was not handled. The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it." 70137 "Self is run by jumping directly to it (the active process abandons thisContext and executes self). However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated. We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised. In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext." 70138 70139 | error ctxt here topContext | 70140 here := thisContext. 70141 70142 "Insert ensure and exception handler contexts under aSender" 70143 error := nil. 70144 ctxt := aSender insertSender: (ContextPart 70145 contextOn: UnhandledError do: [:ex | 70146 error ifNil: [ 70147 error := ex exception. 70148 topContext := thisContext. 70149 ex resumeUnchecked: here jump] 70150 ifNotNil: [ex pass] 70151 ]). 70152 ctxt := ctxt insertSender: (ContextPart 70153 contextEnsure: [error ifNil: [ 70154 topContext := thisContext. 70155 here jump] 70156 ]). 70157 self jump. "Control jumps to self" 70158 70159 "Control resumes here once above ensure block or exception handler is executed" 70160 ^ error ifNil: [ 70161 "No error was raised, remove ensure context by stepping until popped" 70162 [ctxt isDead] whileFalse: [topContext := topContext stepToCallee]. 70163 {topContext. nil} 70164 70165 ] ifNotNil: [ 70166 "Error was raised, remove inserted above contexts then return signaler context" 70167 aSender terminateTo: ctxt sender. "remove above ensure and handler contexts" 70168 {topContext. error} 70169 ]. 70170! ! 70171 70172!ContextPart methodsFor: 'controlling' stamp: 'di 11/26/1999 19:34'! 70173send: selector to: rcvr with: args super: superFlag 70174 "Simulate the action of sending a message with selector, selector, and 70175 arguments, args, to receiver. The argument, superFlag, tells whether the 70176 receiver of the message was specified with 'super' in the source method." 70177 70178 | class meth val | 70179 class := superFlag 70180 ifTrue: [(self method literalAt: self method numLiterals) value superclass] 70181 ifFalse: [rcvr class]. 70182 meth := class lookupSelector: selector. 70183 meth == nil 70184 ifTrue: [^ self send: #doesNotUnderstand: 70185 to: rcvr 70186 with: (Array with: (Message selector: selector arguments: args)) 70187 super: superFlag] 70188 ifFalse: [val := self tryPrimitiveFor: meth 70189 receiver: rcvr 70190 args: args. 70191 val == PrimitiveFailToken ifFalse: [^ val]. 70192 (selector == #doesNotUnderstand: and: [class == ProtoObject]) ifTrue: 70193 [^ self error: 'Simulated message ' , (args at: 1) selector 70194 , ' not understood']. 70195 ^ self activateMethod: meth 70196 withArgs: args 70197 receiver: rcvr 70198 class: class]! ! 70199 70200!ContextPart methodsFor: 'controlling' stamp: 'ajh 1/24/2003 00:56'! 70201terminate 70202 "Make myself unresumable." 70203 70204 sender := nil. 70205 pc := nil. 70206! ! 70207 70208!ContextPart methodsFor: 'controlling' stamp: 'ar 3/6/2001 14:26'! 70209terminateTo: previousContext 70210 "Terminate all the Contexts between me and previousContext, if previousContext is on my Context stack. Make previousContext my sender." 70211 70212 | currentContext sendingContext | 70213 <primitive: 196> 70214 (self hasSender: previousContext) ifTrue: [ 70215 currentContext := sender. 70216 [currentContext == previousContext] whileFalse: [ 70217 sendingContext := currentContext sender. 70218 currentContext terminate. 70219 currentContext := sendingContext]]. 70220 sender := previousContext! ! 70221 70222!ContextPart methodsFor: 'controlling'! 70223top 70224 "Answer the top of the receiver's stack." 70225 70226 ^self at: stackp! ! 70227 70228 70229!ContextPart methodsFor: 'debugger access' stamp: 'ajh 9/25/2001 00:12'! 70230contextStack 70231 "Answer an Array of the contexts on the receiver's sender chain." 70232 70233 ^self stackOfSize: 100000! ! 70234 70235!ContextPart methodsFor: 'debugger access'! 70236depthBelow: aContext 70237 "Answer how many calls there are between this and aContext." 70238 70239 | this depth | 70240 this := self. 70241 depth := 0. 70242 [this == aContext or: [this == nil]] 70243 whileFalse: 70244 [this := this sender. 70245 depth := depth + 1]. 70246 ^depth! ! 70247 70248!ContextPart methodsFor: 'debugger access' stamp: 'stephane.ducasse 5/2/2009 14:58'! 70249errorReportOn: strm 70250 "Write a detailed error report on the stack (above me) on a 70251 stream. For both the error file, and emailing a bug report. 70252 Suppress any errors while getting printStrings. Limit the length." 70253 70254 | cnt aContext startPos | 70255 strm print: Date today; space; print: Time now; cr. 70256 strm cr. 70257 strm nextPutAll: 'VM: '; 70258 nextPutAll: SmalltalkImage current platformName asString; 70259 nextPutAll: ' - '; 70260 nextPutAll: SmalltalkImage current platformSubtype asString; 70261 nextPutAll: ' - '; 70262 nextPutAll: SmalltalkImage current osVersion asString; 70263 nextPutAll: ' - '; 70264 nextPutAll: SmalltalkImage current vmVersion asString; 70265 cr. 70266 strm nextPutAll: 'Image: '; 70267 nextPutAll: SystemVersion current version asString; 70268 nextPutAll: ' ['; 70269 nextPutAll: SmalltalkImage current lastUpdateString asString; 70270 nextPutAll: ']'; 70271 cr. 70272 strm cr. 70273 SecurityManager default printStateOn: strm. 70274 "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." 70275 cnt := 0. 70276 startPos := strm position. 70277 aContext := self. 70278 [aContext notNil and: [(cnt := cnt + 1) < 40]] 70279 whileTrue: [aContext printDetails: strm. "variable values" 70280 strm cr. 70281 aContext := aContext sender]. 70282 strm cr; nextPutAll: '--- The full stack ---'; cr. 70283 aContext := self. 70284 cnt := 0. 70285 [aContext == nil] whileFalse: 70286 [cnt := cnt + 1. 70287 cnt = 40 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - 70288 - - - - - - - - - - - - - - - - - -'; cr]. 70289 strm print: aContext; cr. "just class>>selector" 70290 strm position > (startPos+150000) 70291 ifTrue: [strm nextPutAll: '...etc...'. 70292 ^ self]. "exit early" 70293 cnt > 200 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. 70294 aContext := aContext sender].! ! 70295 70296!ContextPart methodsFor: 'debugger access' stamp: 'RAA 5/16/2000 12:14'! 70297longStack 70298 "Answer a String showing the top 100 contexts on my sender chain." 70299 70300 ^ String streamContents: 70301 [:strm | 70302 (self stackOfSize: 100) 70303 do: [:item | strm print: item; cr]]! ! 70304 70305!ContextPart methodsFor: 'debugger access' stamp: 'md 2/17/2006 18:41'! 70306methodClass 70307 "Answer the class in which the receiver's method was found." 70308 70309 ^self method methodClass ifNil:[self receiver class].! ! 70310 70311!ContextPart methodsFor: 'debugger access' stamp: 'eem 7/17/2008 14:49'! 70312namedTempAt: index 70313 "Answer the value of the temp at index in the receiver's sequence of tempNames." 70314 ^self debuggerMap namedTempAt: index in: self! ! 70315 70316!ContextPart methodsFor: 'debugger access' stamp: 'eem 6/24/2008 12:24'! 70317namedTempAt: index put: aValue 70318 "Set the value of the temp at index in the receiver's sequence of tempNames. 70319 (Note that if the value is a copied value it is also set out along the lexical chain, 70320 but alas not in along the lexical chain.)." 70321 ^self debuggerMap namedTempAt: index put: aValue in: self! ! 70322 70323!ContextPart methodsFor: 'debugger access' stamp: 'ar 7/13/2007 16:52'! 70324print: anObject on: aStream 70325 "Safely print anObject in the face of direct ProtoObject subclasses" 70326 | title | 70327 (anObject class canUnderstand: #printOn:) 70328 ifTrue:[^anObject printOn: aStream]. 70329 title := anObject class name. 70330 aStream 70331 nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']); 70332 nextPutAll: title! ! 70333 70334!ContextPart methodsFor: 'debugger access'! 70335release 70336 "Remove information from the receiver and all of the contexts on its 70337 sender chain in order to break circularities." 70338 70339 self releaseTo: nil! ! 70340 70341!ContextPart methodsFor: 'debugger access'! 70342releaseTo: caller 70343 "Remove information from the receiver and the contexts on its sender 70344 chain up to caller in order to break circularities." 70345 70346 | c s | 70347 c := self. 70348 [c == nil or: [c == caller]] 70349 whileFalse: 70350 [s := c sender. 70351 c singleRelease. 70352 c := s]! ! 70353 70354!ContextPart methodsFor: 'debugger access' stamp: 'md 2/17/2006 18:47'! 70355selector 70356 "Answer the selector of the method that created the receiver." 70357 70358 ^self method selector ifNil: [self method defaultSelector].! ! 70359 70360!ContextPart methodsFor: 'debugger access'! 70361sender 70362 "Answer the context that sent the message that created the receiver." 70363 70364 ^sender! ! 70365 70366!ContextPart methodsFor: 'debugger access' stamp: 'di 8/31/1999 09:42'! 70367shortStack 70368 "Answer a String showing the top ten contexts on my sender chain." 70369 70370 ^ String streamContents: 70371 [:strm | 70372 (self stackOfSize: 10) 70373 do: [:item | strm print: item; cr]]! ! 70374 70375!ContextPart methodsFor: 'debugger access' stamp: 'ajh 1/24/2003 00:03'! 70376singleRelease 70377 "Remove information from the receiver in order to break circularities." 70378 70379 stackp == nil ifFalse: [1 to: stackp do: [:i | self at: i put: nil]]. 70380 sender := nil. 70381 pc := nil. 70382! ! 70383 70384!ContextPart methodsFor: 'debugger access' stamp: 'md 2/22/2006 16:58'! 70385sourceCode 70386 ^self method getSource. 70387 70388 "Note: The above is a bit safer than 70389 ^ methodClass sourceCodeAt: selector 70390 which may fail if the receiver's method has been changed in 70391 the debugger (e.g., the method is no longer in the methodDict 70392 and thus the above selector is something like #Doit:with:with:with:) 70393 but the source code is still available."! ! 70394 70395!ContextPart methodsFor: 'debugger access'! 70396stack 70397 "Answer an Array of the contexts on the receiver's sender chain." 70398 70399 ^self stackOfSize: 9999! ! 70400 70401!ContextPart methodsFor: 'debugger access' stamp: 'eem 6/1/2008 09:43'! 70402stackOfSize: limit 70403 "Answer an OrderedCollection of the top 'limit' contexts 70404 on the receiver's sender chain." 70405 70406 | stack ctxt | 70407 stack := OrderedCollection new. 70408 stack addLast: (ctxt := self). 70409 [(ctxt := ctxt sender) ~~ nil 70410 and: [stack size < limit]] whileTrue: 70411 [stack addLast: ctxt]. 70412 ^stack! ! 70413 70414!ContextPart methodsFor: 'debugger access'! 70415swapSender: coroutine 70416 "Replace the receiver's sender with coroutine and answer the receiver's 70417 previous sender. For use in coroutining." 70418 70419 | oldSender | 70420 oldSender := sender. 70421 sender := coroutine. 70422 ^oldSender! ! 70423 70424!ContextPart methodsFor: 'debugger access' stamp: 'eem 6/10/2008 09:42'! 70425tempNames 70426 "Answer a SequenceableCollection of the names of the receiver's temporary 70427 variables, which are strings." 70428 70429 ^ self debuggerMap tempNamesForContext: self! ! 70430 70431!ContextPart methodsFor: 'debugger access' stamp: 'JorgeRessia 10/18/2009 12:42'! 70432tempScopedNames 70433 "Answer a SequenceableCollection of the names of the receiver's temporary 70434 variables, which are strings." 70435 70436 ^ self debuggerMap tempNamesScopedForContext: self! ! 70437 70438!ContextPart methodsFor: 'debugger access' stamp: 'eem 6/10/2008 09:47'! 70439tempsAndValues 70440 "Return a string of the temporary variabls and their current values" 70441 ^self debuggerMap tempsAndValuesForContext: self! ! 70442 70443!ContextPart methodsFor: 'debugger access' stamp: 'JorgeRessia 10/18/2009 12:42'! 70444tempsAndValuesLimitedTo: sizeLimit indent: indent 70445 "Return a string of the temporary variabls and their current values" 70446 70447 | aStream | 70448 aStream := (String new: 100) writeStream. 70449 self tempScopedNames 70450 doWithIndex: [:title :index | 70451 indent timesRepeat: [aStream tab]. 70452 aStream nextPutAll: title; nextPut: $:; space; tab. 70453 aStream nextPutAll: 70454 ((self tempAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)). 70455 aStream cr]. 70456 ^aStream contents! ! 70457 70458 70459!ContextPart methodsFor: 'instruction decoding'! 70460doDup 70461 "Simulate the action of a 'duplicate top of stack' bytecode." 70462 70463 self push: self top! ! 70464 70465!ContextPart methodsFor: 'instruction decoding'! 70466doPop 70467 "Simulate the action of a 'remove top of stack' bytecode." 70468 70469 self pop! ! 70470 70471!ContextPart methodsFor: 'instruction decoding'! 70472jump: distance 70473 "Simulate the action of a 'unconditional jump' bytecode whose offset is 70474 the argument, distance." 70475 70476 pc := pc + distance! ! 70477 70478!ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 7/6/2003 20:38'! 70479jump: distance if: condition 70480 "Simulate the action of a 'conditional jump' bytecode whose offset is the 70481 argument, distance, and whose condition is the argument, condition." 70482 70483 | bool | 70484 bool := self pop. 70485 (bool == true or: [bool == false]) ifFalse: [ 70486 ^self 70487 send: #mustBeBooleanIn: 70488 to: bool 70489 with: {self} 70490 super: false]. 70491 (bool eqv: condition) ifTrue: [self jump: distance]! ! 70492 70493!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:27'! 70494methodReturnConstant: value 70495 "Simulate the action of a 'return constant' bytecode whose value is the 70496 argument, value. This corresponds to a source expression like '^0'." 70497 70498 ^self return: value from: self methodReturnContext! ! 70499 70500!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:27'! 70501methodReturnReceiver 70502 "Simulate the action of a 'return receiver' bytecode. This corresponds to 70503 the source expression '^self'." 70504 70505 ^self return: self receiver from: self methodReturnContext! ! 70506 70507!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:27'! 70508methodReturnTop 70509 "Simulate the action of a 'return top of stack' bytecode. This corresponds 70510 to source expressions like '^something'." 70511 70512 ^self return: self pop from: self methodReturnContext! ! 70513 70514!ContextPart methodsFor: 'instruction decoding'! 70515popIntoLiteralVariable: value 70516 "Simulate the action of bytecode that removes the top of the stack and 70517 stores it into a literal variable of my method." 70518 70519 value value: self pop! ! 70520 70521!ContextPart methodsFor: 'instruction decoding'! 70522popIntoReceiverVariable: offset 70523 "Simulate the action of bytecode that removes the top of the stack and 70524 stores it into an instance variable of my receiver." 70525 70526 self receiver instVarAt: offset + 1 put: self pop! ! 70527 70528!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 5/27/2008 11:38'! 70529popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 70530 "Simulate the action of bytecode that removes the top of the stack and stores 70531 it into an offset in one of my local variables being used as a remote temp vector." 70532 70533 (self at: tempVectorIndex + 1) at: remoteTempIndex + 1 put: self pop! ! 70534 70535!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:34'! 70536popIntoTemporaryVariable: offset 70537 "Simulate the action of bytecode that removes the top of the stack and 70538 stores it into one of my temporary variables." 70539 70540 self contextForLocalVariables at: offset + 1 put: self pop! ! 70541 70542!ContextPart methodsFor: 'instruction decoding'! 70543pushActiveContext 70544 "Simulate the action of bytecode that pushes the the active context on the 70545 top of its own stack." 70546 70547 self push: self! ! 70548 70549!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 8/29/2008 06:28'! 70550pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize 70551 "Simulate the action of a 'closure copy' bytecode whose result is the 70552 new BlockClosure for the following code" 70553 | copiedValues | 70554 numCopied > 0 70555 ifTrue: 70556 [copiedValues := Array new: numCopied. 70557 numCopied to: 1 by: -1 do: 70558 [:i| 70559 copiedValues at: i put: self pop]] 70560 ifFalse: 70561 [copiedValues := nil]. 70562 self push: (BlockClosure 70563 outerContext: self 70564 startpc: pc 70565 numArgs: numArgs 70566 copiedValues: copiedValues). 70567 self jump: blockSize! ! 70568 70569!ContextPart methodsFor: 'instruction decoding'! 70570pushConstant: value 70571 "Simulate the action of bytecode that pushes the constant, value, on the 70572 top of the stack." 70573 70574 self push: value! ! 70575 70576!ContextPart methodsFor: 'instruction decoding'! 70577pushLiteralVariable: value 70578 "Simulate the action of bytecode that pushes the contents of the literal 70579 variable whose index is the argument, index, on the top of the stack." 70580 70581 self push: value value! ! 70582 70583!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 5/27/2008 11:32'! 70584pushNewArrayOfSize: arraySize 70585 self push: (Array new: arraySize)! ! 70586 70587!ContextPart methodsFor: 'instruction decoding'! 70588pushReceiver 70589 "Simulate the action of bytecode that pushes the active context's receiver 70590 on the top of the stack." 70591 70592 self push: self receiver! ! 70593 70594!ContextPart methodsFor: 'instruction decoding'! 70595pushReceiverVariable: offset 70596 "Simulate the action of bytecode that pushes the contents of the receiver's 70597 instance variable whose index is the argument, index, on the top of the 70598 stack." 70599 70600 self push: (self receiver instVarAt: offset + 1)! ! 70601 70602!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 5/27/2008 11:44'! 70603pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 70604 "Simulate the action of bytecode that pushes the value at remoteTempIndex 70605 in one of my local variables being used as a remote temp vector." 70606 self push: ((self at: tempVectorIndex + 1) at: remoteTempIndex + 1)! ! 70607 70608!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:34'! 70609pushTemporaryVariable: offset 70610 "Simulate the action of bytecode that pushes the contents of the 70611 temporary variable whose index is the argument, index, on the top of 70612 the stack." 70613 70614 self push: (self contextForLocalVariables at: offset + 1)! ! 70615 70616!ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 3/5/2004 03:44'! 70617return: value from: aSender 70618 "For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self" 70619 70620 | newTop ctxt | 70621 aSender isDead ifTrue: [ 70622 ^ self send: #cannotReturn: to: self with: {value} super: false]. 70623 newTop := aSender sender. 70624 ctxt := self findNextUnwindContextUpTo: newTop. 70625 ctxt ifNotNil: [ 70626 ^ self send: #aboutToReturn:through: to: self with: {value. ctxt} super: false]. 70627 self releaseTo: newTop. 70628 newTop ifNotNil: [newTop push: value]. 70629 ^ newTop 70630! ! 70631 70632!ContextPart methodsFor: 'instruction decoding' stamp: 'hmm 7/17/2001 20:52'! 70633send: selector super: superFlag numArgs: numArgs 70634 "Simulate the action of bytecodes that send a message with selector, 70635 selector. The argument, superFlag, tells whether the receiver of the 70636 message was specified with 'super' in the source method. The arguments 70637 of the message are found in the top numArgs locations on the stack and 70638 the receiver just below them." 70639 70640 | receiver arguments answer | 70641 arguments := Array new: numArgs. 70642 numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop]. 70643 receiver := self pop. 70644 selector == #doPrimitive:method:receiver:args: 70645 ifTrue: [answer := receiver 70646 doPrimitive: (arguments at: 1) 70647 method: (arguments at: 2) 70648 receiver: (arguments at: 3) 70649 args: (arguments at: 4). 70650 self push: answer. 70651 ^self]. 70652 QuickStep == self ifTrue: [ 70653 QuickStep := nil. 70654 ^self quickSend: selector to: receiver with: arguments super: superFlag]. 70655 ^self send: selector to: receiver with: arguments super: superFlag! ! 70656 70657!ContextPart methodsFor: 'instruction decoding'! 70658storeIntoLiteralVariable: value 70659 "Simulate the action of bytecode that stores the top of the stack into a 70660 literal variable of my method." 70661 70662 value value: self top! ! 70663 70664!ContextPart methodsFor: 'instruction decoding'! 70665storeIntoReceiverVariable: offset 70666 "Simulate the action of bytecode that stores the top of the stack into an 70667 instance variable of my receiver." 70668 70669 self receiver instVarAt: offset + 1 put: self top! ! 70670 70671!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 5/27/2008 11:53'! 70672storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 70673 "Simulate the action of bytecode that stores the top of the stack at 70674 an offset in one of my local variables being used as a remote temp vector." 70675 70676 (self at: tempVectorIndex + 1) at: remoteTempIndex + 1 put: self top! ! 70677 70678!ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:34'! 70679storeIntoTemporaryVariable: offset 70680 "Simulate the action of bytecode that stores the top of the stack into one 70681 of my temporary variables." 70682 70683 self contextForLocalVariables at: offset + 1 put: self top! ! 70684 70685 70686!ContextPart methodsFor: 'objects from disk' stamp: 'tk 9/28/2000 22:54'! 70687storeDataOn: aDataStream 70688 "Contexts are not allowed go to out in DataStreams. They must be included inside an ImageSegment." 70689 70690 aDataStream insideASegment ifTrue: [^ super storeDataOn: aDataStream]. 70691 70692 self error: 'This Context was not included in the ImageSegment'. 70693 "or perhaps ImageSegments were not used at all" 70694 ^ nil! ! 70695 70696 70697!ContextPart methodsFor: 'printing' stamp: 'tk 10/19/2001 11:24'! 70698printDetails: strm 70699 "Put my class>>selector and arguments and temporaries on the stream. Protect against errors during printing." 70700 70701 | str | 70702 self printOn: strm. 70703 70704 strm cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr. 70705 str := [self tempsAndValuesLimitedTo: 80 indent: 2] ifError: [:err :rcvr | 70706 '<<error during printing>>']. 70707 strm nextPutAll: str. 70708 strm peekLast == Character cr ifFalse: [strm cr].! ! 70709 70710!ContextPart methodsFor: 'printing' stamp: 'md 2/17/2006 15:41'! 70711printOn: aStream 70712 | selector class mclass | 70713 self method == nil ifTrue: [^ super printOn: aStream]. 70714 class := self receiver class. 70715 mclass := self methodClass. 70716 selector := self selector ifNil:[self method defaultSelector]. 70717 aStream nextPutAll: class name. 70718 mclass == class 70719 ifFalse: 70720 [aStream nextPut: $(. 70721 aStream nextPutAll: mclass name. 70722 aStream nextPut: $)]. 70723 aStream nextPutAll: '>>'. 70724 aStream nextPutAll: selector. 70725 selector = #doesNotUnderstand: ifTrue: [ 70726 aStream space. 70727 (self tempAt: 1) selector printOn: aStream. 70728 ]. 70729! ! 70730 70731 70732!ContextPart methodsFor: 'query' stamp: 'ajh 7/21/2003 09:59'! 70733bottomContext 70734 "Return the last context (the first context invoked) in my sender chain" 70735 70736 ^ self findContextSuchThat: [:c | c sender isNil]! ! 70737 70738!ContextPart methodsFor: 'query' stamp: 'ajh 1/27/2003 18:35'! 70739copyStack 70740 70741 ^ self copyTo: nil! ! 70742 70743!ContextPart methodsFor: 'query' stamp: 'ajh 1/27/2003 21:20'! 70744copyTo: aContext 70745 "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home. It is best to use BlockClosures instead. They only hold a ContextTag, which will work for all copies of the original home context." 70746 70747 ^ self copyTo: aContext blocks: IdentityDictionary new! ! 70748 70749!ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 00:12'! 70750findContextSuchThat: testBlock 70751 "Search self and my sender chain for first one that satisfies testBlock. Return nil if none satisfy" 70752 70753 | ctxt | 70754 ctxt := self. 70755 [ctxt isNil] whileFalse: [ 70756 (testBlock value: ctxt) ifTrue: [^ ctxt]. 70757 ctxt := ctxt sender. 70758 ]. 70759 ^ nil! ! 70760 70761!ContextPart methodsFor: 'query' stamp: 'md 1/20/2006 16:15'! 70762findSecondToOldestSimilarSender 70763 "Search the stack for the second-to-oldest occurance of self's method. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning." 70764 70765 | sec ctxt bot | 70766 sec := self. 70767 ctxt := self. 70768 [ bot := ctxt findSimilarSender. 70769 bot isNil 70770 ] whileFalse: [ 70771 sec := ctxt. 70772 ctxt := bot. 70773 ]. 70774 ^ sec 70775! ! 70776 70777!ContextPart methodsFor: 'query' stamp: 'md 1/20/2006 16:14'! 70778findSimilarSender 70779 "Return the closest sender with the same method, return nil if none found" 70780 70781 | meth | 70782 meth := self method. 70783 ^ self sender findContextSuchThat: [:c | c method == meth]! ! 70784 70785!ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 19:42'! 70786hasContext: aContext 70787 "Answer whether aContext is me or one of my senders" 70788 70789 ^ (self findContextSuchThat: [:c | c == aContext]) notNil! ! 70790 70791!ContextPart methodsFor: 'query' stamp: 'eem 12/31/2008 11:28'! 70792isBottomContext 70793 "Answer if this is the last context (the first context invoked) in my sender chain" 70794 70795 ^sender isNil! ! 70796 70797!ContextPart methodsFor: 'query' stamp: 'md 1/20/2006 16:14'! 70798isClosureContext 70799 70800 ^ false! ! 70801 70802!ContextPart methodsFor: 'query' stamp: 'eem 11/26/2008 20:21'! 70803isContext 70804 ^true! ! 70805 70806!ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 00:04'! 70807isDead 70808 "Has self finished" 70809 70810 ^ pc isNil! ! 70811 70812!ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 22:28'! 70813secondFromBottom 70814 "Return the second from bottom of my sender chain" 70815 70816 self sender ifNil: [^ nil]. 70817 ^ self findContextSuchThat: [:c | c sender sender isNil]! ! 70818 70819 70820!ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 20:43'! 70821completeCallee: aContext 70822 "Simulate the execution of bytecodes until a return to the receiver." 70823 | ctxt current ctxt1 | 70824 ctxt := aContext. 70825 [ctxt == current or: [ctxt hasSender: self]] 70826 whileTrue: 70827 [current := ctxt. 70828 ctxt1 := ctxt quickStep. 70829 ctxt1 ifNil: [self halt]. 70830 ctxt := ctxt1]. 70831 ^self stepToSendOrReturn! ! 70832 70833!ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/15/2001 20:58'! 70834quickStep 70835 "If the next instruction is a send, just perform it. 70836 Otherwise, do a normal step." 70837 70838 self willReallySend ifTrue: [QuickStep := self]. 70839 ^self step! ! 70840 70841!ContextPart methodsFor: 'system simulation' stamp: 'eem 6/16/2008 15:39'! 70842runSimulated: aBlock contextAtEachStep: block2 70843 "Simulate the execution of the argument, aBlock, until it ends. aBlock 70844 MUST NOT contain an '^'. Evaluate block2 with the current context 70845 prior to each instruction executed. Answer the simulated value of aBlock." 70846 | current | 70847 aBlock hasMethodReturn 70848 ifTrue: [self error: 'simulation of blocks with ^ can run loose']. 70849 current := aBlock asContext. 70850 current pushArgs: Array new from: self. 70851 [current == self] 70852 whileFalse: 70853 [block2 value: current. 70854 current := current step]. 70855 ^self pop! ! 70856 70857!ContextPart methodsFor: 'system simulation'! 70858step 70859 "Simulate the execution of the receiver's next bytecode. Answer the 70860 context that would be the active context after this bytecode." 70861 70862 ^self interpretNextInstructionFor: self! ! 70863 70864!ContextPart methodsFor: 'system simulation' stamp: 'ajh 1/24/2003 22:54'! 70865stepToCallee 70866 "Step to callee or sender" 70867 70868 | ctxt | 70869 ctxt := self. 70870 [(ctxt := ctxt step) == self] whileTrue. 70871 ^ ctxt! ! 70872 70873!ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 20:48'! 70874stepToSendOrReturn 70875 "Simulate the execution of bytecodes until either sending a message or 70876 returning a value to the receiver (that is, until switching contexts)." 70877 70878 | ctxt | 70879 [self willReallySend | self willReturn | self willStore] 70880 whileFalse: [ 70881 ctxt := self step. 70882 ctxt == self ifFalse: [self halt. 70883 "Caused by mustBeBoolean handling" 70884 ^ctxt]]! ! 70885 70886 70887!ContextPart methodsFor: 'private' stamp: 'ajh 5/20/2004 16:27'! 70888activateReturn: aContext value: value 70889 "Activate 'aContext return: value' in place of self, so execution will return to aContext's sender" 70890 70891 ^ self 70892 activateMethod: ContextPart theReturnMethod 70893 withArgs: {value} 70894 receiver: aContext 70895 class: aContext class! ! 70896 70897!ContextPart methodsFor: 'private' stamp: 'ajh 6/29/2003 15:32'! 70898cannotReturn: result to: homeContext 70899 "The receiver tried to return result to homeContext that no longer exists." 70900 70901 ^ BlockCannotReturn new 70902 result: result; 70903 deadHome: homeContext; 70904 signal! ! 70905 70906!ContextPart methodsFor: 'private' stamp: 'ajh 1/27/2003 21:18'! 70907copyTo: aContext blocks: dict 70908 "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home." 70909 70910 | copy | 70911 self == aContext ifTrue: [^ nil]. 70912 copy := self copy. 70913 dict at: self ifPresent: [:blocks | blocks do: [:b | b privHome: copy]]. 70914 self sender ifNotNil: [ 70915 copy privSender: (self sender copyTo: aContext blocks: dict)]. 70916 ^ copy! ! 70917 70918!ContextPart methodsFor: 'private' stamp: 'ajh 1/24/2003 00:50'! 70919cut: aContext 70920 "Cut aContext and its senders from my sender chain" 70921 70922 | ctxt callee | 70923 ctxt := self. 70924 [ctxt == aContext] whileFalse: [ 70925 callee := ctxt. 70926 ctxt := ctxt sender. 70927 ctxt ifNil: [aContext ifNotNil: [self error: 'aContext not a sender']]. 70928 ]. 70929 callee privSender: nil. 70930! ! 70931 70932!ContextPart methodsFor: 'private' stamp: 'MMP 8/3/2009 13:12'! 70933doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments 70934 "Simulate a primitive method whose index is primitiveIndex. The 70935 simulated receiver and arguments are given as arguments to this message. 70936 Any primitive which provikes execution needs to be intercepted and simulated 70937 to avoid execution running away." 70938 70939 | value | 70940 <primitive: 19> "Simulation guard" 70941 "If successful, push result and return resuming context, 70942 else ^ PrimitiveFailToken" 70943 (primitiveIndex = 19) ifTrue: 70944 [ToolSet 70945 debugContext: self 70946 label:'Code simulation error' 70947 contents: nil]. 70948 70949 "ContextPart>>blockCopy:; simulated to get startpc right" 70950 (primitiveIndex = 80 and: [receiver isKindOf: ContextPart]) 70951 ifTrue: [^self push: ((BlockContext newForMethod: receiver method) 70952 home: receiver home 70953 startpc: pc + 2 70954 nargs: (arguments at: 1))]. 70955 (primitiveIndex = 81 and: [receiver isMemberOf: BlockContext]) "BlockContext>>value[:value:...]" 70956 ifTrue: [^receiver pushArgs: arguments from: self]. 70957 (primitiveIndex = 82 and: [receiver isMemberOf: BlockContext]) "BlockContext>>valueWithArguments:" 70958 ifTrue: [^receiver pushArgs: arguments first from: self]. 70959 primitiveIndex = 83 "afr 9/11/1998 19:50" "Object>>perform:[with:...]" 70960 ifTrue: [^self send: arguments first to: receiver 70961 with: arguments allButFirst 70962 super: false]. 70963 primitiveIndex = 84 "afr 9/11/1998 19:50" "Object>>perform:withArguments:" 70964 ifTrue: [^self send: arguments first to: receiver 70965 with: (arguments at: 2) 70966 super: false]. 70967 primitiveIndex = 188 ifTrue: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:" 70968 [^MethodContext 70969 sender: self 70970 receiver: receiver 70971 method: (arguments at: 2) 70972 arguments: (arguments at: 1)]. 70973 70974 "Closure primitives" 70975 (primitiveIndex = 200 and: [receiver == self]) ifTrue: 70976 "ContextPart>>closureCopy:copiedValues:; simulated to get startpc right" 70977 [^self push: (BlockClosure 70978 outerContext: receiver 70979 startpc: pc + 2 70980 numArgs: arguments first 70981 copiedValues: arguments last)]. 70982 ((primitiveIndex between: 201 and: 205) "BlockClosure>>value[:value:...]" 70983 or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]" 70984 [^receiver simulateValueWithArguments: arguments caller: self]. 70985 primitiveIndex = 206 ifTrue: "BlockClosure>>valueWithArguments:" 70986 [^receiver simulateValueWithArguments: arguments first caller: self]. 70987 70988 primitiveIndex = 120 ifTrue:[ "FFI method" 70989 value := meth literals first tryInvokeWithArguments: arguments. 70990 ] ifFalse:[ 70991 arguments size > 6 ifTrue: [^PrimitiveFailToken]. 70992 value := primitiveIndex = 117 "named primitives" 70993 ifTrue:[self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments] 70994 ifFalse:[receiver tryPrimitive: primitiveIndex withArgs: arguments]. 70995 ]. 70996 ^value == PrimitiveFailToken 70997 ifTrue: [PrimitiveFailToken] 70998 ifFalse: [self push: value]! ! 70999 71000!ContextPart methodsFor: 'private' stamp: 'ajh 7/21/2003 09:59'! 71001insertSender: aContext 71002 "Insert aContext and its sender chain between me and my sender. Return new callee of my original sender." 71003 71004 | ctxt | 71005 ctxt := aContext bottomContext. 71006 ctxt privSender: self sender. 71007 self privSender: aContext. 71008 ^ ctxt! ! 71009 71010!ContextPart methodsFor: 'private' stamp: 'ajh 1/23/2003 22:35'! 71011privSender: aContext 71012 71013 sender := aContext! ! 71014 71015!ContextPart methodsFor: 'private' stamp: 'di 1/11/1999 10:12'! 71016push: numObjects fromIndexable: anIndexableCollection 71017 "Push the elements of anIndexableCollection onto the receiver's stack. 71018 Do not call directly. Called indirectly by {1. 2. 3} constructs." 71019 71020 1 to: numObjects do: 71021 [:i | self push: (anIndexableCollection at: i)]! ! 71022 71023!ContextPart methodsFor: 'private' stamp: 'eem 1/19/2009 10:23'! 71024stackPtr "For use only by the SystemTracer and the Debugger, Inspectors etc" 71025 ^ stackp! ! 71026 71027!ContextPart methodsFor: 'private' stamp: 'di 10/23/1999 17:31'! 71028stackp: newStackp 71029 "Storing into the stack pointer is a potentially dangerous thing. 71030 This primitive stores nil into any cells that become accessible as a result, 71031 and it performs the entire operation atomically." 71032 "Once this primitive is implemented, failure code should cause an error" 71033 71034 <primitive: 76> 71035 self error: 'stackp store failure'. 71036" 71037 stackp == nil ifTrue: [stackp := 0]. 71038 newStackp > stackp 'effectively checks that it is a number' 71039 ifTrue: [oldStackp := stackp. 71040 stackp := newStackp. 71041 'Nil any newly accessible cells' 71042 oldStackp + 1 to: stackp do: [:i | self at: i put: nil]] 71043 ifFalse: [stackp := newStackp] 71044"! ! 71045 71046!ContextPart methodsFor: 'private' stamp: 'ar 5/25/2000 20:41'! 71047tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments 71048 "Hack. Attempt to execute the named primitive from the given compiled method" 71049 | selector theMethod spec | 71050 arguments size > 8 ifTrue:[^PrimitiveFailToken]. 71051 selector := #( 71052 tryNamedPrimitive 71053 tryNamedPrimitive: 71054 tryNamedPrimitive:with: 71055 tryNamedPrimitive:with:with: 71056 tryNamedPrimitive:with:with:with: 71057 tryNamedPrimitive:with:with:with:with: 71058 tryNamedPrimitive:with:with:with:with:with: 71059 tryNamedPrimitive:with:with:with:with:with:with: 71060 tryNamedPrimitive:with:with:with:with:with:with:with:) at: arguments size+1. 71061 theMethod := aReceiver class lookupSelector: selector. 71062 theMethod == nil ifTrue:[^PrimitiveFailToken]. 71063 spec := theMethod literalAt: 1. 71064 spec replaceFrom: 1 to: spec size with: (aCompiledMethod literalAt: 1) startingAt: 1. 71065 ^aReceiver perform: selector withArguments: arguments! ! 71066 71067!ContextPart methodsFor: 'private' stamp: 'ar 5/25/2000 20:45'! 71068tryPrimitiveFor: method receiver: receiver args: arguments 71069 "If this method has a primitive index, then run the primitive and return its result. 71070 Otherwise (and also if the primitive fails) return PrimitiveFailToken, 71071 as an indication that the method should be activated and run as bytecodes." 71072 | primIndex | 71073 (primIndex := method primitive) = 0 ifTrue: [^ PrimitiveFailToken]. 71074 ^ self doPrimitive: primIndex method: method receiver: receiver args: arguments! ! 71075 71076 71077!ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 2/1/2003 01:30'! 71078canHandleSignal: exception 71079 "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then return true, otherwise forward this message to the next handler context. If none left, return false (see nil>>canHandleSignal:)" 71080 71081 ^ (((self tempAt: 1) handles: exception) and: [self tempAt: 3]) 71082 or: [self nextHandlerContext canHandleSignal: exception]. 71083! ! 71084 71085!ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/28/2000 19:27'! 71086findNextHandlerContextStarting 71087 "Return the next handler marked context, returning nil if there is none. Search starts with self and proceeds up to nil." 71088 71089 | ctx | 71090 <primitive: 197> 71091 ctx := self. 71092 [ctx isHandlerContext ifTrue:[^ctx]. 71093 (ctx := ctx sender) == nil ] whileFalse. 71094 ^nil! ! 71095 71096!ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/23/2000 16:37'! 71097findNextUnwindContextUpTo: aContext 71098 "Return the next unwind marked above the receiver, returning nil if there is none. Search proceeds up to but not including aContext." 71099 71100 | ctx | 71101 <primitive: 195> 71102 ctx := self. 71103 [(ctx := ctx sender) == nil or: [ctx == aContext]] whileFalse: 71104 [ ctx isUnwindContext ifTrue: [^ctx]]. 71105 ^nil! ! 71106 71107!ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 6/27/2003 20:47'! 71108handleSignal: exception 71109 "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then execute my handle block (second arg), otherwise forward this message to the next handler context. If none left, execute exception's defaultAction (see nil>>handleSignal:)." 71110 71111 | val | 71112 (((self tempAt: 1) handles: exception) and: [self tempAt: 3]) ifFalse: [ 71113 ^ self nextHandlerContext handleSignal: exception]. 71114 71115 exception privHandlerContext: self contextTag. 71116 self tempAt: 3 put: false. "disable self while executing handle block" 71117 val := [(self tempAt: 2) valueWithPossibleArgs: {exception}] 71118 ensure: [self tempAt: 3 put: true]. 71119 self return: val. "return from self if not otherwise directed in handle block" 71120! ! 71121 71122!ContextPart methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 21:29'! 71123isHandlerContext 71124 ^false! ! 71125 71126!ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/28/2000 15:45'! 71127isUnwindContext 71128 71129 ^false! ! 71130 71131!ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 2/1/2003 00:20'! 71132nextHandlerContext 71133 71134 ^ self sender findNextHandlerContextStarting! ! 71135 71136!ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 1/21/2003 17:59'! 71137unwindTo: aContext 71138 71139 | ctx unwindBlock | 71140 ctx := self. 71141 [(ctx := ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [ 71142 unwindBlock := ctx tempAt: 1. 71143 unwindBlock == nil ifFalse: [ 71144 ctx tempAt: 1 put: nil. 71145 unwindBlock value] 71146 ]. 71147! ! 71148 71149"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 71150 71151ContextPart class 71152 instanceVariableNames: ''! 71153 71154!ContextPart class methodsFor: 'examples'! 71155tallyInstructions: aBlock 71156 "This method uses the simulator to count the number of occurrences of 71157 each of the Smalltalk instructions executed during evaluation of aBlock. 71158 Results appear in order of the byteCode set." 71159 | tallies | 71160 tallies := Bag new. 71161 thisContext sender 71162 runSimulated: aBlock 71163 contextAtEachStep: 71164 [:current | tallies add: current nextByte]. 71165 ^tallies sortedElements 71166 71167 "ContextPart tallyInstructions: [3.14159 printString]"! ! 71168 71169!ContextPart class methodsFor: 'examples'! 71170tallyMethods: aBlock 71171 "This method uses the simulator to count the number of calls on each method 71172 invoked in evaluating aBlock. Results are given in order of decreasing counts." 71173 | prev tallies | 71174 tallies := Bag new. 71175 prev := aBlock. 71176 thisContext sender 71177 runSimulated: aBlock 71178 contextAtEachStep: 71179 [:current | 71180 current == prev ifFalse: "call or return" 71181 [prev sender == nil ifFalse: "call only" 71182 [tallies add: current printString]. 71183 prev := current]]. 71184 ^tallies sortedCounts 71185 71186 "ContextPart tallyMethods: [3.14159 printString]"! ! 71187 71188!ContextPart class methodsFor: 'examples' stamp: 'sma 4/22/2000 17:03'! 71189trace: aBlock "ContextPart trace: [3 factorial]" 71190 "This method uses the simulator to print calls and returned values in the Transcript." 71191 71192 Transcript clear. 71193 ^ self trace: aBlock on: Transcript! ! 71194 71195!ContextPart class methodsFor: 'examples' stamp: 'AdrianLienhard 10/11/2009 19:39'! 71196trace: aBlock on: aStream "ContextPart trace: [3 factorial]" 71197 "This method uses the simulator to print calls to a file." 71198 | prev | 71199 prev := aBlock. 71200 ^ thisContext sender 71201 runSimulated: aBlock 71202 contextAtEachStep: 71203 [:current | 71204 Sensor anyButtonPressed ifTrue: [^ nil]. 71205 current == prev 71206 ifFalse: 71207 [prev sender ifNil: 71208 [ 71209 "Following does not work anymore due to closures?" 71210 " 71211 aStream space; nextPut: $^. 71212 self carefullyPrint: current top on: aStream 71213 "]. 71214 aStream cr. 71215 (current depthBelow: aBlock) timesRepeat: [aStream space]. 71216 self carefullyPrint: current receiver on: aStream. 71217 aStream space; nextPutAll: current selector; flush. 71218 prev := current]]! ! 71219 71220!ContextPart class methodsFor: 'examples' stamp: 'sma 4/22/2000 17:05'! 71221trace: aBlock onFileNamed: fileName "ContextPart trace: [3 factorial] onFileNamed: 'trace'" 71222 "This method uses the simulator to print calls to a file." 71223 71224 | aStream | 71225 ^ [aStream := FileStream fileNamed: fileName. 71226 self trace: aBlock on: aStream] ensure: [aStream close]! ! 71227 71228 71229!ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'! 71230basicNew: size 71231 71232 self error: 'Contexts must only be created with newForMethod:'! ! 71233 71234!ContextPart class methodsFor: 'instance creation' stamp: 'sw 5/5/2000 00:30'! 71235initializedInstance 71236 ^ nil! ! 71237 71238!ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'! 71239new 71240 71241 self error: 'Contexts must only be created with newForMethod:'! ! 71242 71243!ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'! 71244new: size 71245 71246 self error: 'Contexts must only be created with newForMethod:'! ! 71247 71248!ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:55'! 71249newForMethod: aMethod 71250 "This is the only method for creating new contexts, other than primitive cloning. 71251 Any other attempts, such as inherited methods like shallowCopy, should be 71252 avoided or must at least be rewritten to determine the proper size from the 71253 method being activated. This is because asking a context its size (even basicSize!!) 71254 will not return the real object size but only the number of fields currently 71255 accessible, as determined by stackp." 71256 71257 ^ super basicNew: aMethod frameSize! ! 71258 71259 71260!ContextPart class methodsFor: 'simulation' stamp: 'di 2/10/1999 22:15'! 71261initialize 71262 71263 "A unique object to be returned when a primitive fails during simulation" 71264 PrimitiveFailToken := Object new ! ! 71265 71266!ContextPart class methodsFor: 'simulation' stamp: 'di 2/10/1999 22:15'! 71267primitiveFailToken 71268 71269 ^ PrimitiveFailToken! ! 71270 71271!ContextPart class methodsFor: 'simulation'! 71272runSimulated: aBlock 71273 "Simulate the execution of the argument, current. Answer the result it 71274 returns." 71275 71276 ^ thisContext sender 71277 runSimulated: aBlock 71278 contextAtEachStep: [:ignored] 71279 71280 "ContextPart runSimulated: [Pen new defaultNib: 5; go: 100]"! ! 71281 71282 71283!ContextPart class methodsFor: 'special context creation' stamp: 'ajh 1/24/2003 14:31'! 71284contextEnsure: block 71285 "Create an #ensure: context that is ready to return from executing its receiver" 71286 71287 | ctxt chain | 71288 ctxt := thisContext. 71289 [chain := thisContext sender cut: ctxt. ctxt jump] ensure: block. 71290 "jump above will resume here without unwinding chain" 71291 ^ chain! ! 71292 71293!ContextPart class methodsFor: 'special context creation' stamp: 'ajh 1/24/2003 14:31'! 71294contextOn: exceptionClass do: block 71295 "Create an #on:do: context that is ready to return from executing its receiver" 71296 71297 | ctxt chain | 71298 ctxt := thisContext. 71299 [chain := thisContext sender cut: ctxt. ctxt jump] on: exceptionClass do: block. 71300 "jump above will resume here without unwinding chain" 71301 ^ chain! ! 71302 71303!ContextPart class methodsFor: 'special context creation' stamp: 'ajh 5/20/2004 16:25'! 71304theReturnMethod 71305 71306 | meth | 71307 meth := self lookupSelector: #return:. 71308 meth primitive = 0 ifFalse: [^ self error: 'expected #return: to not be a primitive']. 71309 ^ meth! ! 71310 71311 71312!ContextPart class methodsFor: 'private' stamp: 'sma 4/22/2000 17:01'! 71313carefullyPrint: anObject on: aStream 71314 aStream nextPutAll: ([anObject printString] 71315 on: Error 71316 do: ['unprintable ' , anObject class name])! ! 71317 71318!ContextPart class methodsFor: 'private' stamp: 'eem 6/19/2008 10:00'! 71319isContextClass 71320 ^true! ! 71321Inspector subclass: #ContextVariablesInspector 71322 instanceVariableNames: 'fieldList' 71323 classVariableNames: '' 71324 poolDictionaries: '' 71325 category: 'Tools-Debugger'! 71326!ContextVariablesInspector commentStamp: '<historical>' prior: 0! 71327I represent a query path into the internal representation of a ContextPart. Typically this is a context at a point in the query path of a Debugger. As a StringHolder, the string I represent is the value of the currently selected variable of the observed temporary variable of the context.! 71328 71329 71330!ContextVariablesInspector methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 10/17/2009 10:25'! 71331contents 71332 ^super contents! ! 71333 71334!ContextVariablesInspector methodsFor: 'accessing' stamp: 'eem 5/21/2008 12:31'! 71335fieldList 71336 "Refer to the comment in Inspector|fieldList." 71337 71338 object == nil ifTrue: [^Array with: 'thisContext']. 71339 ^fieldList ifNil:[fieldList := (Array with: 'thisContext' with: 'stack top' with: 'all temp vars') , object tempNames]! ! 71340 71341!ContextVariablesInspector methodsFor: 'accessing' stamp: 'ar 4/11/2006 02:33'! 71342inspect: anObject 71343 "Initialize the receiver so that it is inspecting anObject. There is no 71344 current selection. 71345 71346 Because no object's inspectorClass method answers this class, it is OK for this method to 71347 override Inspector >> inspect: " 71348 fieldList := nil. 71349 object := anObject. 71350 self initialize. 71351 ! ! 71352 71353 71354!ContextVariablesInspector methodsFor: 'code'! 71355doItContext 71356 71357 ^object! ! 71358 71359!ContextVariablesInspector methodsFor: 'code'! 71360doItReceiver 71361 71362 ^object receiver! ! 71363 71364 71365!ContextVariablesInspector methodsFor: 'selecting' stamp: 'eem 7/18/2008 11:18'! 71366replaceSelectionValue: anObject 71367 "Refer to the comment in Inspector|replaceSelectionValue:." 71368 71369 ^selectionIndex = 1 71370 ifTrue: [object] 71371 ifFalse: [object namedTempAt: selectionIndex - 3 put: anObject]! ! 71372 71373!ContextVariablesInspector methodsFor: 'selecting' stamp: 'eem 6/10/2008 09:37'! 71374selection 71375 "Refer to the comment in Inspector|selection." 71376 selectionIndex = 0 ifTrue:[^'']. 71377 selectionIndex = 1 ifTrue: [^object]. 71378 selectionIndex = 2 ifTrue: [^object stackPtr > 0 ifTrue: [object top]]. 71379 selectionIndex = 3 ifTrue: [^object tempsAndValues]. 71380 ^object debuggerMap namedTempAt: selectionIndex - 3 in: object! ! 71381 71382 71383!ContextVariablesInspector methodsFor: 'nil' stamp: 'HenrikSperreJohansen 10/17/2009 10:39'! 71384contentsIsString 71385 "Hacked so contents empty when deselected" 71386 71387 ^ #(0 3) includes: selectionIndex! ! 71388PluggableButtonMorphPlus subclass: #ControlButtonMorph 71389 instanceVariableNames: '' 71390 classVariableNames: '' 71391 poolDictionaries: '' 71392 category: 'Polymorph-Widgets'! 71393!ControlButtonMorph commentStamp: 'gvc 9/23/2008 12:04' prior: 0! 71394Specially themed "control" button. Used for drop-lists, expanders etc.! 71395 71396 71397!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:23'! 71398disabledBorderStyle 71399 "Return the disabled borderStyle of the receiver." 71400 71401 ^self theme controlButtonDisabledBorderStyleFor: self! ! 71402 71403!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:24'! 71404disabledFillStyle 71405 "Return the disabled fillStyle of the receiver." 71406 71407 ^self theme controlButtonDisabledFillStyleFor: self! ! 71408 71409!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/5/2008 14:58'! 71410initialize 71411 "Initialize the receiver." 71412 71413 super initialize. 71414 self layoutInset: (self theme controlButtonLabelInsetFor: self)! ! 71415 71416!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/28/2009 17:12'! 71417minWidth 71418 "Consult the theme also." 71419 71420 ^self perform: #minWidth withArguments: #() inSuperclass: Morph! ! 71421 71422!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:23'! 71423mouseOverBorderStyle 71424 "Return the mouse over borderStyle of the receiver." 71425 71426 ^self theme controlButtonMouseOverBorderStyleFor: self! ! 71427 71428!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:23'! 71429mouseOverFillStyle 71430 "Return the mouse over fillStyle of the receiver." 71431 71432 ^self theme controlButtonMouseOverFillStyleFor: self! ! 71433 71434!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:23'! 71435normalBorderStyle 71436 "Return the normal borderStyle of the receiver." 71437 71438 ^self theme controlButtonNormalBorderStyleFor: self! ! 71439 71440!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/28/2007 16:52'! 71441normalFillStyle 71442 "Return the normal fillStyle of the receiver." 71443 71444 ^self theme controlButtonNormalFillStyleFor: self! ! 71445 71446!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:58'! 71447pressedBorderStyle 71448 "Return the pressed borderStyle of the receiver." 71449 71450 ^self theme controlButtonPressedBorderStyleFor: self! ! 71451 71452!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:59'! 71453pressedFillStyle 71454 "Return the pressed fillStyle of the receiver." 71455 71456 ^self theme controlButtonPressedFillStyleFor: self! ! 71457 71458!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:25'! 71459selectedDisabledBorderStyle 71460 "Return the selected disabled borderStyle of the receiver." 71461 71462 ^self theme controlButtonSelectedDisabledBorderStyleFor: self! ! 71463 71464!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:25'! 71465selectedDisabledFillStyle 71466 "Return the selected disabled fillStyle of the receiver." 71467 71468 ^self theme controlButtonSelectedDisabledFillStyleFor: self! ! 71469 71470!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/9/2008 13:04'! 71471selectedFillStyle 71472 "Return the selected fillStyle of the receiver." 71473 71474 ^self theme controlButtonSelectedFillStyleFor: self! ! 71475 71476!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:24'! 71477selectedMouseOverBorderStyle 71478 "Return the selected mouse over borderStyle of the receiver." 71479 71480 ^self theme controlButtonSelectedMouseOverBorderStyleFor: self! ! 71481 71482!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:24'! 71483selectedMouseOverFillStyle 71484 "Return the selected mouse over fillStyle of the receiver." 71485 71486 ^self theme controlButtonSelectedMouseOverFillStyleFor: self! ! 71487 71488!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:24'! 71489selectedPressedBorderStyle 71490 "Return the selected pressed borderStyle of the receiver." 71491 71492 ^self theme controlButtonSelectedPressedBorderStyleFor: self! ! 71493 71494!ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:25'! 71495selectedPressedFillStyle 71496 "Return the selected pressed fillStyle of the receiver." 71497 71498 ^self theme controlButtonSelectedPressedFillStyleFor: self! ! 71499Object subclass: #Controller 71500 instanceVariableNames: 'model sensor' 71501 classVariableNames: '' 71502 poolDictionaries: '' 71503 category: 'ST80-Kernel-Remnants'! 71504!Controller commentStamp: '<historical>' prior: 0! 71505A Controller coordinates a View, its model, and user actions. It provides scheduling (control) behavior to determine when the user wants to communicate with the model or view.! 71506 71507 71508!Controller methodsFor: 'basic control sequence'! 71509controlInitialize 71510 "Sent by Controller|startUp as part of the standard control sequence, it 71511 provides a place in the standard control sequence for initializing the 71512 receiver (taking into account the current state of its model and view). It 71513 should be redefined in subclasses to perform some specific action." 71514 71515 ^self! ! 71516 71517!Controller methodsFor: 'basic control sequence'! 71518controlTerminate 71519 "Provide a place in the standard control sequence for terminating the 71520 receiver (taking into account the current state of its model and view). It 71521 should be redefined in subclasses to perform some specific action." 71522 71523 ^self! ! 71524 71525!Controller methodsFor: 'basic control sequence'! 71526terminateAndInitializeAround: aBlock 71527 "1/12/96 sw" 71528 self controlTerminate. 71529 aBlock value. 71530 self controlInitialize! ! 71531 71532 71533!Controller methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:49'! 71534initialize 71535 "Initialize the state of the receiver. Subclasses should include 'super 71536 initialize' when redefining this message to insure proper initialization." 71537 super initialize. 71538 sensor := InputSensor default! ! 71539 71540!Controller methodsFor: 'initialization' stamp: 'alain.plantec 6/11/2008 12:02'! 71541release 71542 "Breaks the cycle between the receiver and its view. It is usually not 71543 necessary to send release provided the receiver's view has been properly 71544 released independently." 71545 71546 model := nil. 71547! ! 71548 71549 71550!Controller methodsFor: 'model access'! 71551model 71552 "Answer the receiver's model which is the same as the model of the 71553 receiver's view." 71554 71555 ^model! ! 71556 71557!Controller methodsFor: 'model access' stamp: 'alain.plantec 6/11/2008 12:18'! 71558model: aModel 71559 "Controller|model: and Controller|view: are sent by View|controller: in 71560 order to coordinate the links between the model, view, and controller. In 71561 ordinary usage, the receiver is created and passed as the parameter to 71562 View|controller: so that the receiver's model and view links can be set 71563 up by the view." 71564 71565 model := aModel! ! 71566 71567 71568!Controller methodsFor: 'sensor access'! 71569sensor 71570 "Answer the receiver's sensor. Subclasses may use other objects that are 71571 not instances of Sensor or its subclasses if more general kinds of 71572 input/output functions are required." 71573 71574 ^sensor! ! 71575 71576!Controller methodsFor: 'sensor access' stamp: 'alain.plantec 6/11/2008 12:18'! 71577sensor: aSensor 71578 "Set the receiver's sensor to aSensor." 71579 71580 sensor := aSensor! ! 71581AbstractResizerMorph subclass: #CornerGripMorph 71582 instanceVariableNames: 'target' 71583 classVariableNames: '' 71584 poolDictionaries: '' 71585 category: 'Morphic-Windows'! 71586!CornerGripMorph commentStamp: 'jmv 1/29/2006 17:15' prior: 0! 71587I am the superclass of a hierarchy of morph specialized in allowing the user to resize windows.! 71588 71589 71590!CornerGripMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 14:06'! 71591mouseDown: anEvent 71592 "Remember the receiver and target offsets too." 71593 71594 |cp| 71595 cp := anEvent cursorPoint. 71596 lastMouse := {cp. cp - self position. cp - self targetPoint}! ! 71597 71598!CornerGripMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/12/2007 16:28'! 71599target 71600 "Answer the target." 71601 71602 ^target! ! 71603 71604!CornerGripMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/12/2007 16:36'! 71605targetPoint 71606 "Answer the reference point of the target." 71607 71608 ^self target bounds pointAtSideOrCorner: self ptName! ! 71609 71610!CornerGripMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 14:07'! 71611targetPoint: aPoint 71612 "Set the reference point of the target." 71613 71614 |minExt rect| 71615 rect := self target bounds withSideOrCorner: self ptName setToPoint: aPoint. 71616 minExt := self target minimumExtent. 71617 rect width <= minExt x ifTrue: [ 71618 (self ptName = #topLeft or: [self ptName = #bottomLeft]) 71619 ifTrue: [rect := rect withSideOrCorner: #left setToPoint: self target bounds bottomRight - minExt] 71620 ifFalse: [rect := rect withSideOrCorner: #right setToPoint: self target bounds topLeft + minExt]]. 71621 rect height <= minExt y ifTrue: [ 71622 (self ptName = #topLeft or: [self ptName = #topRight]) 71623 ifTrue: [rect := rect withSideOrCorner: #top setToPoint: self target bounds bottomRight - minExt] 71624 ifFalse: [rect := rect withSideOrCorner: #bottom setToPoint: self target bounds topLeft + minExt]]. 71625 self target bounds: rect! ! 71626 71627 71628!CornerGripMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/26/2007 12:08'! 71629initialize 71630 super initialize. 71631 self extent: self defaultWidth @ self defaultHeight. 71632 self layoutFrame: self gripLayoutFrame! ! 71633 71634!CornerGripMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/12/2007 16:36'! 71635mouseMove: anEvent 71636 "Track the mouse for resizing." 71637 71638 target ifNil: [^ self]. 71639 target fastFramingOn 71640 ifTrue: [target doFastWindowReframe: self ptName] 71641 ifFalse: [ 71642 lastMouse at: 1 put: anEvent cursorPoint. 71643 self targetPoint: lastMouse first - lastMouse last. 71644 self position: (lastMouse first - lastMouse second)].! ! 71645 71646!CornerGripMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/27/2008 21:50'! 71647target: aMorph 71648 71649 target := aMorph. 71650 aMorph ifNotNil: [ 71651 self fillStyle: (aMorph theme resizerGripNormalFillStyleFor: self)]! ! 71652 71653 71654!CornerGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:24'! 71655defaultHeight 71656 ^ 22! ! 71657 71658!CornerGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:24'! 71659defaultWidth 71660 ^ 22! ! 71661Object subclass: #CornerRounder 71662 instanceVariableNames: 'cornerMasks cornerOverlays underBits' 71663 classVariableNames: 'CR0 CR1 CR2' 71664 poolDictionaries: '' 71665 category: 'Graphics-Display Objects'! 71666!CornerRounder commentStamp: '<historical>' prior: 0! 71667This class is a quick hack to support rounded corners in morphic. 71668 71669Rather than produce rounded rectangles, it tweaks the display of corners. 71670Rather than work for any radius, it only supports a radius of 6. 71671Rather than work for any border width, it only supports widths 0, 1 and 2. 71672The corners, while apparently transparent, still behave opaquely to mouse clicks. 71673 71674Worse than this, the approach relies on the ability to extract underlying bits from the canvas prior to display. This ran afoul of top-down display, it seems, in SystemWindow spawnReframeHandle: (qv). It will also make a postscript printer very unhappy. 71675 71676But, hey, it's cute.! 71677 71678 71679!CornerRounder methodsFor: 'all' stamp: 'di 6/24/1999 09:35'! 71680masterMask: maskForm masterOverlay: overlayForm 71681 71682 cornerMasks := #(none left pi right) collect: 71683 [:dir | (maskForm rotateBy: dir centerAt: 0@0) offset: 0@0]. 71684 cornerOverlays := #(none left pi right) collect: 71685 [:dir | (overlayForm rotateBy: dir centerAt: 0@0) offset: 0@0]. 71686! ! 71687 71688!CornerRounder methodsFor: 'all' stamp: 'ar 1/5/2002 17:26'! 71689saveBitsUnderCornersOf: aMorph on: aCanvas in: bounds corners: cornerList 71690 71691 | offset corner mask form corners rect | 71692 underBits := Array new: 4. 71693 corners := bounds corners. 71694 cornerList do:[:i| 71695 mask := cornerMasks at: i. 71696 corner := corners at: i. 71697 i = 1 ifTrue: [offset := 0@0]. 71698 i = 2 ifTrue: [offset := 0@mask height negated]. 71699 i = 3 ifTrue: [offset := mask extent negated]. 71700 i = 4 ifTrue: [offset := mask width negated@0]. 71701 rect := corner + offset extent: mask extent. 71702 (aCanvas isVisible: rect) ifTrue:[ 71703 form := aCanvas contentsOfArea: rect. 71704 form copyBits: form boundingBox from: mask at: 0@0 clippingBox: form boundingBox rule: Form and fillColor: nil map: (Bitmap with: 16rFFFFFFFF with: 0). 71705 underBits at: i put: form]]. 71706! ! 71707 71708!CornerRounder methodsFor: 'all' stamp: 'kfr 8/4/2003 23:28'! 71709tweakCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: cornerList 71710 "This variant has a cornerList argument, to allow some corners to be rounded and others not" 71711 | offset corner saveBits fourColors mask outBits shadowColor corners | 71712 shadowColor := aCanvas shadowColor. 71713 aCanvas shadowColor: nil. "for tweaking it's essential" 71714 w > 0 ifTrue:[ 71715 fourColors := shadowColor 71716 ifNil:[aMorph borderStyle colorsAtCorners] 71717 ifNotNil:[Array new: 4 withAll: Color transparent]]. 71718 mask := Form extent: cornerMasks first extent depth: aCanvas depth. 71719 corners := bounds corners. 71720 cornerList do:[:i| 71721 corner := corners at: i. 71722 saveBits := underBits at: i. 71723 saveBits ifNotNil:[ 71724 i = 1 ifTrue: [offset := 0@0]. 71725 i = 2 ifTrue: [offset := 0@saveBits height negated]. 71726 i = 3 ifTrue: [offset := saveBits extent negated]. 71727 i = 4 ifTrue: [offset := saveBits width negated@0]. 71728 71729 "Mask out corner area (painting saveBits won't clear if transparent)." 71730 mask copyBits: mask boundingBox from: (cornerMasks at: i) at: 0@0 clippingBox: mask boundingBox rule: Form over fillColor: nil map: (Bitmap with: 0 with: 16rFFFFFFFF). 71731 outBits := aCanvas contentsOfArea: (corner + offset extent: mask extent). 71732 mask displayOn: outBits at: 0@0 rule: Form and. 71733 "Paint back corner bits." 71734 saveBits displayOn: outBits at: 0@0 rule: Form paint. 71735 "Paint back corner bits." 71736 aCanvas drawImage: outBits at: corner + offset. 71737 71738 w > 0 ifTrue:[ 71739 71740 aCanvas stencil: (cornerOverlays at: i) at: corner + offset 71741 color: (fourColors at: i)]]]. 71742 aCanvas shadowColor: shadowColor. "restore shadow color" 71743! ! 71744 71745"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 71746 71747CornerRounder class 71748 instanceVariableNames: ''! 71749 71750!CornerRounder class methodsFor: 'all' stamp: 'di 6/28/1999 15:51'! 71751initialize "CornerRounder initialize" 71752 71753 CR0 := CR1 := self new 71754 masterMask: 71755 (Form extent: 6@6 71756 fromArray: #(2r1e26 2r111e26 2r1111e26 2r11111e26 2r11111e26 2r111111e26) 71757 offset: 0@0) 71758 masterOverlay: 71759 (Form extent: 6@6 71760 fromArray: #(2r1e26 2r110e26 2r1000e26 2r10000e26 2r10000e26 2r100000e26) 71761 offset: 0@0). 71762 CR2 := self new 71763 masterMask: 71764 (Form extent: 6@6 71765 fromArray: #(2r1e26 2r111e26 2r1111e26 2r11111e26 2r11111e26 2r111111e26) 71766 offset: 0@0) 71767 masterOverlay: 71768 (Form extent: 6@6 71769 fromArray: #(2r1e26 2r111e26 2r1111e26 2r11100e26 2r11000e26 2r111000e26) 71770 offset: 0@0). 71771 71772! ! 71773 71774!CornerRounder class methodsFor: 'all' stamp: 'di 3/25/2000 11:12'! 71775rectWithinCornersOf: aRectangle 71776 "Return a single sub-rectangle that lies entirely inside corners 71777 that are made by me. 71778 Used to identify large regions of window that do not need to be redrawn." 71779 71780 ^ aRectangle insetBy: 0@6! ! 71781 71782!CornerRounder class methodsFor: 'all' stamp: 'ar 1/5/2002 17:24'! 71783roundCornersOf: aMorph on: aCanvas in: bounds displayBlock: displayBlock borderWidth: w corners: aList 71784 71785 | rounder | 71786 rounder := CR0. 71787 w = 1 ifTrue: [rounder := CR1]. 71788 w = 2 ifTrue: [rounder := CR2]. 71789 rounder := rounder copy. 71790 rounder saveBitsUnderCornersOf: aMorph on: aCanvas in: bounds corners: aList. 71791 displayBlock value. 71792 rounder tweakCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: aList! ! 71793StandardFileStream subclass: #CrLfFileStream 71794 instanceVariableNames: 'lineEndConvention' 71795 classVariableNames: 'Cr CrLf Lf LineEndDefault LineEndStrings LookAheadCount' 71796 poolDictionaries: '' 71797 category: 'Files-Kernel'! 71798!CrLfFileStream commentStamp: 'ls 11/10/2002 13:32' prior: 0! 71799I am the same as a regular file stream, except that when I am in text mode, I will automatically convert line endings between the underlying platform's convention, and Squeak's convention of carriage-return only. The goal is that Squeak text files can be treated as OS text files, and vice versa. 71800 71801In binary mode, I behave identically to a StandardFileStream. 71802 71803To enable CrLfFileStream as the default file stream class for an entire image, modify FileStream class concreteStream . 71804 71805 71806There are two caveats on programming with CrLfFileStream. 71807 71808First, the choice of text mode versus binary mode affects which characters are visible in Squeak, and no longer just affects whether those characters are returned as Character's or as Integer's. Thus the choice of mode needs to be made very carefully, and must be based on intent instead of convenience of representation. The methods asString, asByteArray, asCharacter, and asInteger can be used to convert between character and integer representations. (Arguably, file streams should accept either strings or characters in nextPut: and nextPutAll:, but that is not the case right now.) 71809 71810Second, arithmetic on positions no longer works, because one character that Squeak sees (carriage return) could map to two characters in the underlying file (carriage return plus line feed, on MS Windows and MS DOS). Comparison between positions still works. (This caveat could perhaps be fixed by maintaining a map between Squeak positions and positions in the underlying file, but it is complicated. Consider, for example, updates to the middle of the file. Also, consider that text files are rarely updated in the middle of the file, and that general random access to a text file is rarely very useful. If general random access with specific file counts is desired, then the file is starting to sound like a binary file instead of a text file.) 71811 71812! 71813 71814 71815!CrLfFileStream methodsFor: '*monticello' stamp: 'stephaneducasse 2/4/2006 20:47'! 71816lineEndingConvention: aSymbol 71817 lineEndConvention := aSymbol! ! 71818 71819 71820!CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:16'! 71821ascii 71822 super ascii. 71823 self detectLineEndConvention! ! 71824 71825!CrLfFileStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'! 71826binary 71827 super binary. 71828 lineEndConvention := nil! ! 71829 71830!CrLfFileStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'! 71831detectLineEndConvention 71832 "Detect the line end convention used in this stream. The result may be either #cr, #lf or #crlf." 71833 | char numRead pos | 71834 self isBinary ifTrue: [^ self error: 'Line end conventions are not used on binary streams']. 71835 lineEndConvention := LineEndDefault. 71836 "Default if nothing else found" 71837 numRead := 0. 71838 pos := super position. 71839 [super atEnd not and: [numRead < LookAheadCount]] 71840 whileTrue: 71841 [char := super next. 71842 char = Lf 71843 ifTrue: 71844 [super position: pos. 71845 ^ lineEndConvention := #lf]. 71846 char = Cr 71847 ifTrue: 71848 [super peek = Lf 71849 ifTrue: [lineEndConvention := #crlf] 71850 ifFalse: [lineEndConvention := #cr]. 71851 super position: pos. 71852 ^ lineEndConvention]. 71853 numRead := numRead + 1]. 71854 super position: pos. 71855 ^ lineEndConvention! ! 71856 71857!CrLfFileStream methodsFor: 'access' stamp: 'nk 9/5/2004 12:58'! 71858lineEndConvention 71859 71860 ^lineEndConvention! ! 71861 71862!CrLfFileStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'! 71863next 71864 | char secondChar | 71865 char := super next. 71866 self isBinary ifTrue: [^char]. 71867 char == Cr ifTrue: 71868 [secondChar := super next. 71869 secondChar ifNotNil: [secondChar == Lf ifFalse: [self skip: -1]]. 71870 ^Cr]. 71871 char == Lf ifTrue: [^Cr]. 71872 ^char! ! 71873 71874!CrLfFileStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'! 71875next: n 71876 71877 | string peekChar | 71878 string := super next: n. 71879 string size = 0 ifTrue: [ ^string ]. 71880 self isBinary ifTrue: [ ^string ]. 71881 71882 "if we just read a CR, and the next character is an LF, then skip the LF" 71883 ( string last = Character cr ) ifTrue: [ 71884 peekChar := super next. "super peek doesn't work because it relies on #next" 71885 peekChar ~= Character lf ifTrue: [ 71886 super position: (super position - 1) ]. ]. 71887 71888 string := string withSqueakLineEndings. 71889 71890 string size = n ifTrue: [ ^string ]. 71891 71892 "string shrunk due to embedded crlfs; make up the difference" 71893 ^string, (self next: n - string size)! ! 71894 71895!CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18'! 71896nextPut: char 71897 (lineEndConvention notNil and: [char = Cr]) 71898 ifTrue: [super nextPutAll: (LineEndStrings at: lineEndConvention)] 71899 ifFalse: [super nextPut: char]. 71900 ^ char! ! 71901 71902!CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18'! 71903nextPutAll: aString 71904 super nextPutAll: (self convertStringFromCr: aString). 71905 ^ aString 71906! ! 71907 71908!CrLfFileStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:31'! 71909peek 71910 "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " 71911 | next pos | 71912 self atEnd ifTrue: [^ nil]. 71913 pos := self position. 71914 next := self next. 71915 self position: pos. 71916 ^ next! ! 71917 71918!CrLfFileStream methodsFor: 'access' stamp: 'PeterHugossonMiller 9/3/2009 01:05'! 71919upTo: aCharacter 71920 | newStream char | 71921 newStream := (String new: 100) writeStream. 71922 [(char := self next) isNil or: [char == aCharacter]] 71923 whileFalse: [newStream nextPut: char]. 71924 ^ newStream contents 71925! ! 71926 71927!CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18'! 71928verbatim: aString 71929 super verbatim: (self convertStringFromCr: aString). 71930 ^ aString! ! 71931 71932 71933!CrLfFileStream methodsFor: 'open/close' stamp: 'stephaneducasse 2/4/2006 20:31'! 71934open: aFileName forWrite: writeMode 71935 "Open the receiver. If writeMode is true, allow write, else access will be 71936 read-only. " 71937 | result | 71938 result := super open: aFileName forWrite: writeMode. 71939 result ifNotNil: [self detectLineEndConvention]. 71940 ^ result! ! 71941 71942 71943!CrLfFileStream methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 01:04'! 71944convertStringFromCr: aString 71945 | inStream outStream | 71946 lineEndConvention ifNil: [^ aString]. 71947 lineEndConvention == #cr ifTrue: [^ aString]. 71948 lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Cr with: Lf]. 71949 "lineEndConvention == #crlf" 71950 inStream := aString readStream. 71951 outStream := (String new: aString size) writeStream. 71952 [inStream atEnd] 71953 whileFalse: 71954 [outStream nextPutAll: (inStream upTo: Cr). 71955 (inStream atEnd not or: [aString last = Cr]) 71956 ifTrue: [outStream nextPutAll: CrLf]]. 71957 ^ outStream contents! ! 71958 71959!CrLfFileStream methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 01:04'! 71960convertStringToCr: aString 71961 | inStream outStream | 71962 lineEndConvention ifNil: [^ aString]. 71963 lineEndConvention == #cr ifTrue: [^ aString]. 71964 lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Lf with: Cr]. 71965 "lineEndConvention == #crlf" 71966 inStream := aString readStream. 71967 outStream := (String new: aString size) writeStream. 71968 [inStream atEnd] 71969 whileFalse: 71970 [outStream nextPutAll: (inStream upTo: Cr). 71971 (inStream atEnd not or: [aString last = Cr]) 71972 ifTrue: 71973 [outStream nextPut: Cr. 71974 inStream peek = Lf ifTrue: [inStream next]]]. 71975 ^ outStream contents! ! 71976 71977"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 71978 71979CrLfFileStream class 71980 instanceVariableNames: ''! 71981 71982!CrLfFileStream class methodsFor: 'initialization' stamp: 'ar 1/20/98 16:10'! 71983defaultToCR 71984 "CrLfFileStream defaultToCR" 71985 LineEndDefault := #cr.! ! 71986 71987!CrLfFileStream class methodsFor: 'initialization' stamp: 'ar 1/20/98 16:10'! 71988defaultToCRLF 71989 "CrLfFileStream defaultToCRLF" 71990 LineEndDefault := #crlf.! ! 71991 71992!CrLfFileStream class methodsFor: 'initialization' stamp: 'ar 1/20/98 16:10'! 71993defaultToLF 71994 "CrLfFileStream defaultToLF" 71995 LineEndDefault := #lf.! ! 71996 71997!CrLfFileStream class methodsFor: 'initialization' stamp: 'norbert_hartl 6/13/2009 10:57'! 71998guessDefaultLineEndConvention 71999 "Lets try to guess the line end convention from what we know about the path name delimiter from FileDirectory." 72000 FileDirectory pathNameDelimiter = $: ifTrue:[^self defaultToCR]. 72001 FileDirectory pathNameDelimiter = $/ 72002 ifTrue:[((SmalltalkImage current getSystemAttribute: 1002) 72003 beginsWith: 'darwin') 72004 ifTrue: [^ self defaultToCR] 72005 ifFalse: [^ self defaultToLF]]. 72006 FileDirectory pathNameDelimiter = $\ ifTrue:[^self defaultToCRLF]. 72007 "in case we don't know" 72008 ^self defaultToCR! ! 72009 72010!CrLfFileStream class methodsFor: 'initialization' stamp: 'di 2/4/1999 09:16'! 72011initialize 72012 "CrLfFileStream initialize" 72013 Cr := Character cr. 72014 Lf := Character lf. 72015 CrLf := String with: Cr with: Lf. 72016 LineEndStrings := Dictionary new. 72017 LineEndStrings at: #cr put: (String with: Character cr). 72018 LineEndStrings at: #lf put: (String with: Character lf). 72019 LineEndStrings at: #crlf put: (String with: Character cr with: Character lf). 72020 LookAheadCount := 2048. 72021 Smalltalk addToStartUpList: self. 72022 self startUp.! ! 72023 72024!CrLfFileStream class methodsFor: 'initialization' stamp: 'yo 2/21/2004 04:46'! 72025new 72026 72027 ^ (MultiByteFileStream new) wantsLineEndConversion: true; yourself. 72028 72029! ! 72030 72031!CrLfFileStream class methodsFor: 'initialization' stamp: 'djp 1/28/1999 22:08'! 72032startUp 72033 self guessDefaultLineEndConvention! ! 72034Array variableSubclass: #Cubic 72035 instanceVariableNames: '' 72036 classVariableNames: '' 72037 poolDictionaries: '' 72038 category: 'Morphic-Collections-Arrayed'! 72039!Cubic commentStamp: 'wiz 6/17/2004 20:31' prior: 0! 72040I am a segment between to points. In the form of a cubic polynomial that can be evaluated between 0..1 to obtain the end points and intermediate values. 72041! 72042 72043 72044!Cubic methodsFor: 'cubic support' stamp: 'wiz 6/17/2004 22:32'! 72045bestSegments 72046 "Return the smallest integer number of segments that give the 72047 best curve." 72048 ^ self honeIn: self calcEnoughSegments! ! 72049 72050!Cubic methodsFor: 'cubic support' stamp: 'wiz 6/18/2004 23:12'! 72051calcEnoughSegments 72052 "Find the power of two that represents a sufficient number of 72053 segments for this cubic. 72054 The measure is the sum of distances for the segments. 72055 We want this to be close enough not affect the straightness of 72056 the drawn lines. Which means within one pixel." 72057 "^ self 72058 enough: 2 72059 withMeasure: (self measureFor: 1) 72060 withIn: self leeway 72061 This ran into a problem when the curve was an s-curve with 72062 inflections. Besides honeIn will check to see if 1 is better than 72063 two so we lose nothing by starting a little higher." 72064 ^ self 72065 enough: 4 72066 withMeasure: (self measureFor: 2) 72067 withIn: self leeway! ! 72068 72069!Cubic methodsFor: 'cubic support' stamp: 'wiz 7/18/2004 22:50'! 72070enough: nTry withMeasure: lastMeasure withIn: closeEnough 72071"See comment in calcEnoughSegments for which I am a helper" 72072 | measure | 72073 measure := self measureFor: nTry. 72074 measure > (lastMeasure + closeEnough) 72075 ifFalse: [^ nTry // 2]. 72076 ^ self 72077 enough: 2 * nTry 72078 withMeasure: measure 72079 withIn: closeEnough! ! 72080 72081!Cubic methodsFor: 'cubic support' stamp: 'wiz 6/17/2004 23:51'! 72082honeIn: enough 72083 "Find if there is a smaller n than enough that give the same 72084 measure for n." 72085 self 72086 assert: [enough isPowerOfTwo]. 72087 enough < 2 72088 ifTrue: [^ enough]. 72089 ^ self 72090 honeIn: enough 72091 step: enough // 2 72092 measure: (self measureFor: enough) 72093 withIn: self leeway! ! 72094 72095!Cubic methodsFor: 'cubic support' stamp: 'wiz 6/17/2004 23:45'! 72096honeIn: centerN step: step measure: measure withIn: closeEnough 72097 "Pick the best n by binary search." 72098 | nTry | 72099 step < 1 72100 ifTrue: [^ centerN]. 72101 nTry := centerN - step. 72102 ^ measure > (closeEnough 72103 + (self measureFor: nTry)) 72104 ifTrue: [self 72105 honeIn: centerN 72106 step: step // 2 72107 measure: measure 72108 withIn: closeEnough] 72109 ifFalse: [self 72110 honeIn: nTry 72111 step: step // 2 72112 measure: measure 72113 withIn: closeEnough]! ! 72114 72115!Cubic methodsFor: 'cubic support' stamp: 'wiz 6/19/2004 00:00'! 72116leeway 72117 "How close can measure be" 72118 ^ 0.1! ! 72119 72120!Cubic methodsFor: 'cubic support' stamp: 'wiz 1/30/2005 20:59'! 72121measureFor: n 72122 "Return a distance measure for cubic curve with n segments. 72123 For convienence and accuracy we use the sum of the 72124 distances. " 72125 "first point is poly of 0." 72126 | p1 p2 measure | 72127 p1 := self first. 72128 measure := 0. 72129 (1 to: n) 72130 do: [:i | 72131 p2 := self polynomialEval: i / n asFloat. 72132 measure := measure 72133 + (p2 dist: p1). 72134 p1 := p2]. 72135 ^ measure! ! 72136 72137"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 72138 72139Cubic class 72140 instanceVariableNames: ''! 72141 72142!Cubic class methodsFor: 'instance creation' stamp: 'stephane.ducasse 12/21/2008 11:00'! 72143with: pt1 with: pt2 with: pt3 with: pt4 72144 "a cubic object is composed of 4 points" 72145 72146 ^ self withAll: {pt1 . pt2 . pt3 . pt4}! ! 72147Form subclass: #Cursor 72148 instanceVariableNames: '' 72149 classVariableNames: 'BlankCursor BottomLeftCursor BottomRightCursor CornerCursor CrossHairCursor CurrentCursor DownCursor MarkerCursor MenuCursor MoveCursor NormalCursor OriginCursor ReadCursor ResizeLeftCursor ResizeTopCursor ResizeTopLeftCursor ResizeTopRightCursor RightArrowCursor SquareCursor TargetCursor TopLeftCursor TopRightCursor UpCursor WaitCursor WebLinkCursor WriteCursor XeqCursor' 72150 poolDictionaries: '' 72151 category: 'Graphics-Display Objects'! 72152!Cursor commentStamp: '<historical>' prior: 0! 72153I am a Form that is a possible appearance for a mouse cursor. My size is always 16x16, ever since the original implementation on the Alto. 72154 72155There are many examples available in the "current cursor" category of class methods. For example, "Cursor normal" and "Cursor wait". For example: 72156 72157 Cursor wait show 72158 72159! 72160 72161 72162!Cursor methodsFor: 'converting' stamp: 'RAA 8/14/2000 10:14'! 72163asCursorForm 72164 | form | 72165 form := StaticForm extent: self extent depth: 8. 72166 form fillShape: self fillColor: Color black at: offset negated. 72167 ^ form offset: offset! ! 72168 72169!Cursor methodsFor: 'converting' stamp: 'bf 2/2/1999 19:32'! 72170withMask 72171 ^CursorWithMask derivedFrom: self! ! 72172 72173 72174!Cursor methodsFor: 'displaying' stamp: 'ls 6/17/2002 11:56'! 72175show 72176 "Make the hardware's mouse cursor look like the receiver" 72177 72178 Sensor currentCursor: self! ! 72179 72180!Cursor methodsFor: 'displaying'! 72181showGridded: gridPoint 72182 "Make the current cursor shape be the receiver, forcing the location of the cursor to the point nearest gridPoint." 72183 72184 Sensor cursorPoint: (Sensor cursorPoint grid: gridPoint). 72185 Sensor currentCursor: self! ! 72186 72187!Cursor methodsFor: 'displaying' stamp: 'bf 10/13/1999 13:05'! 72188showWhile: aBlock 72189 "While evaluating the argument, aBlock, make the receiver be the cursor 72190 shape." 72191 72192 | oldcursor | 72193 oldcursor := Sensor currentCursor. 72194 self show. 72195 ^aBlock ensure: [oldcursor show] 72196! ! 72197 72198 72199!Cursor methodsFor: 'primitives'! 72200beCursor 72201 "Primitive. Tell the interpreter to use the receiver as the current cursor 72202 image. Fail if the receiver does not match the size expected by the 72203 hardware. Essential. See Object documentation whatIsAPrimitive." 72204 72205 <primitive: 101> 72206 self primitiveFailed! ! 72207 72208!Cursor methodsFor: 'primitives' stamp: 'jm 9/22/1998 23:33'! 72209beCursorWithMask: maskForm 72210 "Primitive. Tell the interpreter to use the receiver as the current cursor image with the given mask Form. Both the receiver and the mask should have extent 16@16 and a depth of one. The mask and cursor bits are combined as follow: 72211 mask cursor effect 72212 0 0 transparent (underlying pixel shows through) 72213 1 1 opaque black 72214 1 0 opaque white 72215 0 1 invert the underlying pixel" 72216"Essential. See Object documentation whatIsAPrimitive." 72217 72218 <primitive: 101> 72219 self primitiveFailed 72220! ! 72221 72222 72223!Cursor methodsFor: 'printing'! 72224printOn: aStream 72225 72226 self storeOn: aStream base: 2! ! 72227 72228 72229!Cursor methodsFor: 'testing' stamp: 'bf 2/2/1999 19:34'! 72230hasMask 72231 ^false! ! 72232 72233 72234!Cursor methodsFor: 'updating' stamp: 'ls 6/17/2002 12:00'! 72235changed: aParameter 72236 "overriden to reinstall the cursor if it is the active cursor, in case the appearance has changed. (Is this used anywhere? Do cursors really change in place these days?)" 72237 self == CurrentCursor ifTrue: [self beCursor]. 72238 super changed: aParameter! ! 72239 72240"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 72241 72242Cursor class 72243 instanceVariableNames: ''! 72244 72245!Cursor class methodsFor: 'constants'! 72246blank 72247 "Answer the instance of me that is all white." 72248 72249 ^BlankCursor! ! 72250 72251!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:13'! 72252bottomLeft 72253 "Cursor bottomLeft showWhile: [Sensor waitButton]" 72254 ^BottomLeftCursor 72255! ! 72256 72257!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:13'! 72258bottomRight 72259 "Cursor bottomRight showWhile: [Sensor waitButton]" 72260 ^BottomRightCursor 72261! ! 72262 72263!Cursor class methodsFor: 'constants'! 72264corner 72265 "Answer the instance of me that is the shape of the bottom right corner 72266 of a rectangle." 72267 72268 ^CornerCursor! ! 72269 72270!Cursor class methodsFor: 'constants'! 72271crossHair 72272 "Answer the instance of me that is the shape of a cross." 72273 72274 ^CrossHairCursor! ! 72275 72276!Cursor class methodsFor: 'constants'! 72277down 72278 "Answer the instance of me that is the shape of an arrow facing 72279 downward." 72280 72281 ^DownCursor! ! 72282 72283!Cursor class methodsFor: 'constants'! 72284execute 72285 "Answer the instance of me that is the shape of an arrow slanted left 72286 with a star next to it." 72287 72288 ^XeqCursor! ! 72289 72290!Cursor class methodsFor: 'constants'! 72291marker 72292 "Answer the instance of me that is the shape of a small ball." 72293 72294 ^MarkerCursor! ! 72295 72296!Cursor class methodsFor: 'constants'! 72297menu 72298 "Answer the instance of me that is the shape of a menu." 72299 72300 ^MenuCursor! ! 72301 72302!Cursor class methodsFor: 'constants'! 72303move 72304 "Answer the instance of me that is the shape of a cross inside a square." 72305 72306 ^MoveCursor! ! 72307 72308!Cursor class methodsFor: 'constants'! 72309normal 72310 "Answer the instance of me that is the shape of an arrow slanted left." 72311 72312 ^NormalCursor! ! 72313 72314!Cursor class methodsFor: 'constants'! 72315origin 72316 "Answer the instance of me that is the shape of the top left corner of a 72317 rectangle." 72318 72319 ^OriginCursor! ! 72320 72321!Cursor class methodsFor: 'constants'! 72322read 72323 "Answer the instance of me that is the shape of eyeglasses." 72324 72325 ^ReadCursor! ! 72326 72327!Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:48'! 72328resizeBottom 72329 "Cursor resizeBottom showWhile: [Sensor waitButton]" 72330 ^self resizeTop! ! 72331 72332!Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:46'! 72333resizeBottomLeft 72334 "Cursor resizeBottomLeft showWhile: [Sensor waitButton]" 72335 ^self resizeTopRight! ! 72336 72337!Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:45'! 72338resizeBottomRight 72339 "Cursor resizeBottomRight showWhile: [Sensor waitButton]" 72340 ^self resizeTopLeft! ! 72341 72342!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 18:58'! 72343resizeLeft 72344 "Cursor resizeLeft showWhile: [Sensor waitButton]" 72345 ^ResizeLeftCursor! ! 72346 72347!Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:45'! 72348resizeRight 72349 "Cursor resizeRight showWhile: [Sensor waitButton]" 72350 ^self resizeLeft! ! 72351 72352!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:19'! 72353resizeTop 72354 "Cursor resizeTop showWhile: [Sensor waitButton]" 72355 ^ResizeTopCursor! ! 72356 72357!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00'! 72358resizeTopLeft 72359 "Cursor resizeTopLeft showWhile: [Sensor waitButton]" 72360 ^ ResizeTopLeftCursor! ! 72361 72362!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00'! 72363resizeTopRight 72364 "Cursor resizeTopRight showWhile: [Sensor waitButton]" 72365 ^ResizeTopRightCursor! ! 72366 72367!Cursor class methodsFor: 'constants'! 72368rightArrow 72369 "Answer the instance of me that is the shape of an arrow pointing to the right." 72370 72371 ^RightArrowCursor! ! 72372 72373!Cursor class methodsFor: 'constants'! 72374square 72375 "Answer the instance of me that is the shape of a square." 72376 72377 ^SquareCursor! ! 72378 72379!Cursor class methodsFor: 'constants' stamp: 'ar 3/1/2006 22:42'! 72380target 72381 "Answer the instance of me that is the shape of a gunsight." 72382 "Cursor target show" 72383 ^TargetCursor ifNil:[self initTarget]! ! 72384 72385!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:01'! 72386topLeft 72387 "Cursor topLeft showWhile: [Sensor waitButton]" 72388 ^ TopLeftCursor! ! 72389 72390!Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:02'! 72391topRight 72392 "Cursor topRight showWhile: [Sensor waitButton]" 72393 ^ TopRightCursor! ! 72394 72395!Cursor class methodsFor: 'constants'! 72396up 72397 "Answer the instance of me that is the shape of an arrow facing upward." 72398 72399 ^UpCursor! ! 72400 72401!Cursor class methodsFor: 'constants' stamp: 'sw 8/15/97 13:28'! 72402wait 72403 "Answer the instance of me that is the shape of an Hourglass (was in the 72404 shape of three small balls)." 72405 72406 ^WaitCursor! ! 72407 72408!Cursor class methodsFor: 'constants' stamp: 'ar 9/26/2001 22:37'! 72409webLink 72410 "Return a cursor that can be used for emphasizing web links" 72411 "Cursor webLink showWhile: [Sensor waitButton]" 72412 ^WebLinkCursor ifNil:[ 72413 WebLinkCursor := (CursorWithMask extent: 16@16 72414 fromArray: #(3072 4608 4608 4608 4608 5046 4681 29257 37449 37449 32769 32769 49155 16386 24582 16380 ) 72415 offset: -5@0) setMaskForm: 72416 (Form extent: 16@16 72417 fromArray: (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 ) collect: [:bits | bits bitShift: 16]) 72418 offset: 0@0)].! ! 72419 72420!Cursor class methodsFor: 'constants'! 72421write 72422 "Answer the instance of me that is the shape of a pen writing." 72423 72424 ^WriteCursor! ! 72425 72426 72427!Cursor class methodsFor: 'current cursor'! 72428currentCursor 72429 "Answer the instance of Cursor that is the one currently displayed." 72430 72431 ^CurrentCursor! ! 72432 72433!Cursor class methodsFor: 'current cursor' stamp: 'marcus.denker 8/17/2008 21:19'! 72434currentCursor: aCursor 72435 "Make the instance of cursor, aCursor, be the current cursor. Display it. 72436 Create an error if the argument is not a Cursor." 72437 72438 (aCursor isKindOf: self) 72439 ifTrue: [CurrentCursor := aCursor. 72440 aCursor beCursor] 72441 ifFalse: [self error: 'The new cursor must be an instance of class Cursor']! ! 72442 72443 72444!Cursor class methodsFor: 'initialization' stamp: 'JMM 10/21/2003 18:57'! 72445initBottomLeft 72446 72447 BottomLeftCursor := 72448 (Cursor extent: 16@16 72449 fromArray: #( 72450 2r1100000000000000 72451 2r1100000000000000 72452 2r1100000000000000 72453 2r1100000000000000 72454 2r1100000000000000 72455 2r1100000000000000 72456 2r1100000000000000 72457 2r1100000000000000 72458 2r1100000000000000 72459 2r1100000000000000 72460 2r1100000000000000 72461 2r1100000000000000 72462 2r1100000000000000 72463 2r1100000000000000 72464 2r1111111111111111 72465 2r1111111111111111) 72466 offset: 0@-16). 72467! ! 72468 72469!Cursor class methodsFor: 'initialization' stamp: 'JMM 10/21/2003 18:57'! 72470initBottomRight 72471 72472 BottomRightCursor := 72473 (Cursor extent: 16@16 72474 fromArray: #( 72475 2r0000000000000011 72476 2r0000000000000011 72477 2r0000000000000011 72478 2r0000000000000011 72479 2r0000000000000011 72480 2r0000000000000011 72481 2r0000000000000011 72482 2r0000000000000011 72483 2r0000000000000011 72484 2r0000000000000011 72485 2r0000000000000011 72486 2r0000000000000011 72487 2r0000000000000011 72488 2r0000000000000011 72489 2r1111111111111111 72490 2r1111111111111111) 72491 offset: -16@-16). 72492! ! 72493 72494!Cursor class methodsFor: 'initialization'! 72495initCorner 72496 72497 CornerCursor := 72498 (Cursor 72499 extent: 16@16 72500 fromArray: #( 72501 2r0000000000000011 72502 2r0000000000000011 72503 2r0000000000000011 72504 2r0000000000000011 72505 2r0000000000000011 72506 2r0000000000000011 72507 2r0000000000000011 72508 2r0000000000000011 72509 2r0000000000000011 72510 2r0000000000000011 72511 2r0000000000000011 72512 2r0000000000000011 72513 2r0000000000000011 72514 2r0000000000000011 72515 2r1111111111111111 72516 2r1111111111111111) 72517 offset: -16@-16). 72518! ! 72519 72520!Cursor class methodsFor: 'initialization' stamp: 'kfr 7/12/2003 21:02'! 72521initCrossHair 72522 72523 CrossHairCursor := 72524 (Cursor 72525 extent: 16@16 72526 fromArray: #( 72527 2r0000000000000000 72528 2r0000000100000000 72529 2r0000000100000000 72530 2r0000000100000000 72531 2r0000000100000000 72532 2r0000000100000000 72533 2r0000000100000000 72534 2r0111111111111100 72535 2r0000000100000000 72536 2r0000000100000000 72537 2r0000000100000000 72538 2r0000000100000000 72539 2r0000000100000000 72540 2r0000000100000000 72541 2r0000000000000000 72542 2r0) 72543 offset: -7@-7). 72544 72545 ! ! 72546 72547!Cursor class methodsFor: 'initialization'! 72548initDown 72549 72550 DownCursor := 72551 (Cursor 72552 extent: 16@16 72553 fromArray: #( 72554 2r11000000000000 72555 2r11000000000000 72556 2r11000000000000 72557 2r11000000000000 72558 2r11000000000000 72559 2r11000000000000 72560 2r11000000000000 72561 2r1111110000000000 72562 2r111100000000000 72563 2r11000000000000 72564 2r0 72565 2r0 72566 2r0 72567 2r0 72568 2r0 72569 2r0) 72570 offset: 0@0). 72571! ! 72572 72573!Cursor class methodsFor: 'initialization'! 72574initMarker 72575 72576 MarkerCursor := 72577 Cursor 72578 extent: 16@16 72579 fromArray: #( 72580 2r0111000000000000 72581 2r1111100000000000 72582 2r1111100000000000 72583 2r0111000000000000 72584 2r0 72585 2r0 72586 2r0 72587 2r0 72588 2r0 72589 2r0 72590 2r0 72591 2r0 72592 2r0 72593 2r0 72594 2r0 72595 2r0) 72596 offset: 0@0. 72597! ! 72598 72599!Cursor class methodsFor: 'initialization' stamp: 'di 7/30/2001 10:32'! 72600initMenu 72601 72602 MenuCursor := 72603 (Cursor 72604 extent: 16@16 72605 fromArray: #( 72606 2r1111111111100000 72607 2r1000000000100000 72608 2r1010011000100000 72609 2r1000000000100000 72610 2r1101001101100000 72611 2r1111111111100000 72612 2r1000000000100000 72613 2r1011001010100000 72614 2r1000000000100000 72615 2r1010110010100000 72616 2r1000000000100000 72617 2r1010010100100000 72618 2r1000000000100000 72619 2r1111111111100000 72620 0) 72621 offset: 0@0). 72622! ! 72623 72624!Cursor class methodsFor: 'initialization' stamp: 'kfr 7/12/2003 21:10'! 72625initMove 72626 72627 MoveCursor := 72628 Cursor 72629 extent: 16@16 72630 fromArray: #( 72631 2r1111111111111100 72632 2r1111111111111100 72633 2r1100001100001100 72634 2r1100001100001100 72635 2r1100001100001100 72636 2r1100001100001100 72637 2r1111111111111100 72638 2r1111111111111100 72639 2r1100001100001100 72640 2r1100001100001100 72641 2r1100001100001100 72642 2r1100001100001100 72643 2r1111111111111100 72644 2r1111111111111100 72645 0) 72646 offset: 0@0. 72647! ! 72648 72649!Cursor class methodsFor: 'initialization'! 72650initNormal 72651 72652 NormalCursor := 72653 (Cursor 72654 extent: 16@16 72655 fromArray: #( 72656 2r1000000000000000 72657 2r1100000000000000 72658 2r1110000000000000 72659 2r1111000000000000 72660 2r1111100000000000 72661 2r1111110000000000 72662 2r1111111000000000 72663 2r1111100000000000 72664 2r1111100000000000 72665 2r1001100000000000 72666 2r0000110000000000 72667 2r0000110000000000 72668 2r0000011000000000 72669 2r0000011000000000 72670 2r0000001100000000 72671 2r0000001100000000) 72672 offset: 0@0). 72673 72674 72675 ! ! 72676 72677!Cursor class methodsFor: 'initialization' stamp: 'di 10/8/1998 17:04'! 72678initNormalWithMask "Cursor initNormalWithMask. Cursor normal show" 72679 "Next two lines work simply for any cursor..." 72680 self initNormal. 72681 NormalCursor := CursorWithMask derivedFrom: NormalCursor. 72682 72683 "But for a good looking cursor, you have to tweak things..." 72684 NormalCursor := (CursorWithMask extent: 16@16 depth: 1 72685 fromArray: #( 0 1073741824 1610612736 1879048192 72686 2013265920 2080374784 2113929216 2130706432 72687 2080374784 2080374784 1275068416 100663296 72688 100663296 50331648 50331648 0) 72689 offset: -1@-1) 72690 setMaskForm: (Form extent: 16@16 depth: 1 72691 fromArray: #( 3221225472 3758096384 4026531840 4160749568 72692 4227858432 4261412864 4278190080 4286578688 72693 4278190080 4261412864 4261412864 3472883712 72694 251658240 125829120 125829120 50331648) 72695 offset: 0@0).! ! 72696 72697!Cursor class methodsFor: 'initialization'! 72698initOrigin 72699 72700 OriginCursor := 72701 (Cursor 72702 extent: 16@16 72703 fromArray: #( 72704 2r1111111111111111 72705 2r1111111111111111 72706 2r1100000000000000 72707 2r1100000000000000 72708 2r1100000000000000 72709 2r1100000000000000 72710 2r1100000000000000 72711 2r1100000000000000 72712 2r1100000000000000 72713 2r1100000000000000 72714 2r1100000000000000 72715 2r1100000000000000 72716 2r1100000000000000 72717 2r1100000000000000 72718 2r1100000000000000 72719 2r1100000000000000) 72720 offset: 0@0). 72721! ! 72722 72723!Cursor class methodsFor: 'initialization' stamp: 'kfr 7/12/2003 22:55'! 72724initRead 72725 72726 ReadCursor := 72727 (Cursor 72728 extent: 16@16 72729 fromArray: #( 72730 2r0000000000000000 72731 2r0000000000000000 72732 2r0001000000001000 72733 2r0010100000010100 72734 2r0100000000100000 72735 2r1111101111100000 72736 2r1000010000100000 72737 2r1000010000100000 72738 2r1011010110100000 72739 2r0111101111000000 72740 2r0 72741 2r0 72742 2r0 72743 2r0 72744 2r0 72745 2r0) 72746 offset: 0@0). 72747! ! 72748 72749!Cursor class methodsFor: 'initialization' stamp: 'jrp 8/6/2005 22:50'! 72750initResizeLeft 72751 72752 ResizeLeftCursor := 72753 (Cursor extent: 16@16 fromArray: #( 72754 2r0000000000000000 72755 2r0000000000000000 72756 2r0000000000000000 72757 2r0000000000000000 72758 2r0000100000010000 72759 2r0001100000011000 72760 2r0011100000011100 72761 2r0111111111111110 72762 2r0011100000011100 72763 2r0001100000011000 72764 2r0000100000010000 72765 2r0000000000000000 72766 2r0000000000000000 72767 2r0000000000000000 72768 2r0000000000000000 72769 2r0000000000000000 ) 72770 offset: -7@-7 ) withMask! ! 72771 72772!Cursor class methodsFor: 'initialization' stamp: 'jrp 8/6/2005 22:54'! 72773initResizeTop 72774 "Cursor initResizeTop" 72775 ResizeTopCursor := 72776 (Cursor extent: 16@16 fromArray: #( 72777 2r000000100000000 72778 2r000001110000000 72779 2r000011111000000 72780 2r000111111100000 72781 2r000000100000000 72782 2r000000100000000 72783 2r000000100000000 72784 2r000000100000000 72785 2r000000100000000 72786 2r000000100000000 72787 2r000111111100000 72788 2r000011111000000 72789 2r000001110000000 72790 2r000000100000000 72791 2r000000000000000) 72792 offset: -7@-7) withMask! ! 72793 72794!Cursor class methodsFor: 'initialization' stamp: 'jrp 8/6/2005 22:55'! 72795initResizeTopLeft 72796 72797 ResizeTopLeftCursor := 72798 (Cursor extent: 16@16 fromArray: #( 72799 2r0000000000000000 72800 2r0111110000000000 72801 2r0111100000000000 72802 2r0111000000000000 72803 2r0110100000000000 72804 2r0100010000000000 72805 2r0000001000000000 72806 2r0000000100000000 72807 2r0000000010000000 72808 2r0000000001000100 72809 2r0000000000101100 72810 2r0000000000011100 72811 2r0000000000111100 72812 2r0000000001111100 72813 2r0000000000000000 72814 2r0000000000000000) 72815 offset: -7@-7) withMask! ! 72816 72817!Cursor class methodsFor: 'initialization' stamp: 'jrp 8/7/2005 07:54'! 72818initResizeTopRight 72819 72820 ResizeTopRightCursor := 72821 (Cursor extent: 16@16 fromArray: #( 72822 2r0000000000000000 72823 2r0000000001111100 72824 2r0000000000111100 72825 2r0000000000011100 72826 2r0000000000101100 72827 2r0000000001000100 72828 2r0000000010000000 72829 2r0000000100000000 72830 2r0000001000000000 72831 2r0100010000000000 72832 2r0110100000000000 72833 2r0111000000000000 72834 2r0111100000000000 72835 2r0111110000000000 72836 2r0000000000000000 72837 2r0000000000000000) 72838 offset: -7@-7) withMask! ! 72839 72840!Cursor class methodsFor: 'initialization'! 72841initRightArrow 72842 72843 RightArrowCursor := 72844 (Cursor 72845 extent: 16@16 72846 fromArray: #( 72847 2r100000000000 72848 2r111000000000 72849 2r1111111110000000 72850 2r111000000000 72851 2r100000000000 72852 2r0 72853 2r0 72854 2r0 72855 2r0 72856 2r0 72857 2r0 72858 2r0 72859 2r0 72860 2r0 72861 2r0 72862 2r0) 72863 offset: 0@0). 72864 72865 "Cursor initRightArrow"! ! 72866 72867!Cursor class methodsFor: 'initialization'! 72868initSquare 72869 72870 SquareCursor := 72871 (Cursor 72872 extent: 16@16 72873 fromArray: #( 72874 2r0 72875 2r0 72876 2r0 72877 2r0 72878 2r0 72879 2r0000001111000000 72880 2r0000001111000000 72881 2r0000001111000000 72882 2r0000001111000000 72883 2r0 72884 2r0 72885 2r0 72886 2r0 72887 2r0 72888 2r0 72889 2r0) 72890 offset: -8@-8). 72891 72892 ! ! 72893 72894!Cursor class methodsFor: 'initialization' stamp: 'ar 3/1/2006 22:42'! 72895initTarget 72896 ^TargetCursor := Cursor 72897 extent: 16 @ 16 72898 fromArray: #(1984 6448 8456 16644 17284 33026 35106 65278 35106 33026 17284 16644 8456 6448 1984 0) 72899 offset: -7 @ -7! ! 72900 72901!Cursor class methodsFor: 'initialization' stamp: 'JMM 10/21/2003 19:01'! 72902initTopLeft 72903 TopLeftCursor := 72904 (Cursor extent: 16@16 72905 fromArray: #( 72906 2r1111111111111111 72907 2r1111111111111111 72908 2r1100000000000000 72909 2r1100000000000000 72910 2r1100000000000000 72911 2r1100000000000000 72912 2r1100000000000000 72913 2r1100000000000000 72914 2r1100000000000000 72915 2r1100000000000000 72916 2r1100000000000000 72917 2r1100000000000000 72918 2r1100000000000000 72919 2r1100000000000000 72920 2r1100000000000000 72921 2r1100000000000000) 72922 offset: 0@0). 72923! ! 72924 72925!Cursor class methodsFor: 'initialization' stamp: 'JMM 10/21/2003 19:02'! 72926initTopRight 72927 TopRightCursor := 72928 (Cursor extent: 16@16 72929 fromArray: #( 72930 2r1111111111111111 72931 2r1111111111111111 72932 2r0000000000000011 72933 2r0000000000000011 72934 2r0000000000000011 72935 2r0000000000000011 72936 2r0000000000000011 72937 2r0000000000000011 72938 2r0000000000000011 72939 2r0000000000000011 72940 2r0000000000000011 72941 2r0000000000000011 72942 2r0000000000000011 72943 2r0000000000000011 72944 2r0000000000000011 72945 2r0000000000000011) 72946 offset: -16@0). 72947! ! 72948 72949!Cursor class methodsFor: 'initialization'! 72950initUp 72951 72952 UpCursor := 72953 (Cursor 72954 extent: 16@16 72955 fromArray: #( 72956 2r11000000000000 72957 2r111100000000000 72958 2r1111110000000000 72959 2r11000000000000 72960 2r11000000000000 72961 2r11000000000000 72962 2r11000000000000 72963 2r11000000000000 72964 2r11000000000000 72965 2r11000000000000 72966 2r0 72967 2r0 72968 2r0 72969 2r0 72970 2r0 72971 2r0) 72972 offset: 0@0). 72973! ! 72974 72975!Cursor class methodsFor: 'initialization' stamp: 'kfr 7/12/2003 21:27'! 72976initWait 72977 72978 WaitCursor := 72979 (Cursor 72980 extent: 16@16 72981 fromArray: #( 72982 2r1111111111111100 72983 2r1000000000000100 72984 2r0100000000001000 72985 2r0010000000010000 72986 2r0001110011100000 72987 2r0000111111000000 72988 2r0000011110000000 72989 2r0000011110000000 72990 2r0000100101000000 72991 2r0001000100100000 72992 2r0010000110010000 72993 2r0100001111001000 72994 2r1000111111110100 72995 2r1111111111111100 72996 0) 72997 offset: 0@0). 72998! ! 72999 73000!Cursor class methodsFor: 'initialization' stamp: 'kfr 7/12/2003 22:52'! 73001initWrite 73002 73003 WriteCursor := (Cursor 73004 extent: 16@16 73005 fromArray: #( 73006 2r0000000000011000 73007 2r0000000000111100 73008 2r0000000001001000 73009 2r0000000010010000 73010 2r0000000100100000 73011 2r0000001001000100 73012 2r0000010010000100 73013 2r0000100100001100 73014 2r0001001000010000 73015 2r0010010000010000 73016 2r0111100000001000 73017 2r0101000011111000 73018 2r1110000110000000 73019 2r0111111100000000 73020 2r0 73021 2r0) 73022 offset: 0@0). 73023! ! 73024 73025!Cursor class methodsFor: 'initialization'! 73026initXeq 73027 73028 XeqCursor := 73029 (Cursor 73030 extent: 16@16 73031 fromArray: #( 73032 2r1000000000010000 73033 2r1100000000010000 73034 2r1110000000111000 73035 2r1111000111111111 73036 2r1111100011000110 73037 2r1111110001000100 73038 2r1111111001111100 73039 2r1111000001101100 73040 2r1101100011000110 73041 2r1001100010000010 73042 2r0000110000000000 73043 2r0000110000000000 73044 2r0000011000000000 73045 2r0000011000000000 73046 2r0000001100000000 73047 2r0000001100000000) 73048 offset: 0@0). 73049! ! 73050 73051!Cursor class methodsFor: 'initialization' stamp: 'stephane.ducasse 7/3/2009 22:32'! 73052initialize 73053 "Create all the standard cursors..." 73054 self initOrigin. 73055 self initRightArrow. 73056 self initMenu. 73057 self initCorner. 73058 self initRead. 73059 self initWrite. 73060 self initWait. 73061 BlankCursor := Cursor new. 73062 self initXeq. 73063 self initSquare. 73064 self initNormalWithMask. 73065 self initCrossHair. 73066 self initMarker. 73067 self initUp. 73068 self initDown. 73069 self initMove. 73070 self initBottomLeft. 73071 self initBottomRight. 73072 self initResizeLeft. 73073 self initResizeTop. 73074 self initResizeTopLeft. 73075 self initResizeTopRight. 73076 self initTopLeft. 73077 self initTopRight. 73078 self initTarget. 73079 self makeCursorsWithMask. 73080 73081 "Cursor initialize" 73082! ! 73083 73084!Cursor class methodsFor: 'initialization' stamp: 'bf 2/2/1999 19:33'! 73085makeCursorsWithMask 73086 "Cursor initialize;makeCursorsWithMask" 73087 73088 self classPool associationsDo: [:var | 73089 var value hasMask 73090 ifFalse: [var value: var value withMask]] ! ! 73091 73092!Cursor class methodsFor: 'initialization'! 73093startUp 73094 self currentCursor: self currentCursor! ! 73095 73096 73097!Cursor class methodsFor: 'instance creation'! 73098extent: extentPoint fromArray: anArray offset: offsetPoint 73099 "Answer a new instance of me with width and height specified by 73100 extentPoint, offset by offsetPoint, and bits from anArray. 73101 NOTE: This has been kluged to take an array of 16-bit constants, 73102 and shift them over so they are left-justified in a 32-bit bitmap" 73103 73104 extentPoint = (16 @ 16) 73105 ifTrue: 73106 [^ super 73107 extent: extentPoint 73108 fromArray: (anArray collect: [:bits | bits bitShift: 16]) 73109 offset: offsetPoint] 73110 ifFalse: [self error: 'cursors must be 16@16']! ! 73111 73112!Cursor class methodsFor: 'instance creation' stamp: 'di 10/6/1998 13:53'! 73113new 73114 73115 ^ self extent: 16 @ 16 73116 fromArray: (Array new: 16 withAll: 0) 73117 offset: 0 @ 0 73118 73119 "Cursor new bitEdit show"! ! 73120 73121!Cursor class methodsFor: 'instance creation' stamp: 'ar 8/16/2001 15:52'! 73122resizeForEdge: aSymbol 73123 "Cursor resizeForEdge: #top" 73124 "Cursor resizeForEdge: #bottomLeft" 73125 ^self perform: ('resize', aSymbol first asString asUppercase, (aSymbol copyFrom: 2 to: aSymbol size)) asSymbol.! ! 73126Cursor subclass: #CursorWithMask 73127 instanceVariableNames: 'maskForm' 73128 classVariableNames: '' 73129 poolDictionaries: '' 73130 category: 'Graphics-Display Objects'! 73131!CursorWithMask commentStamp: '<historical>' prior: 0! 73132A Cursor which additionally has a 16x16 transparency bitmap called a "mask". See the comment of beCursorWithMask: for details on how the mask is treated.! 73133]style[(97 17 40)f3,f3LCursor beCursorWithMask:;,f3! 73134 73135 73136!CursorWithMask methodsFor: 'converting' stamp: 'RAA 8/14/2000 10:14'! 73137asCursorForm 73138 | form | 73139 form := StaticForm extent: self extent depth: 8. 73140 form fillShape: maskForm fillColor: Color white. 73141 form fillShape: self fillColor: Color black at: offset negated. 73142 ^ form offset: offset! ! 73143 73144 73145!CursorWithMask methodsFor: 'mask' stamp: 'bf 2/2/1999 19:34'! 73146hasMask 73147 ^true! ! 73148 73149!CursorWithMask methodsFor: 'mask' stamp: 'di 10/8/1998 16:46'! 73150maskForm 73151 ^ maskForm! ! 73152 73153!CursorWithMask methodsFor: 'mask' stamp: 'di 10/8/1998 16:46'! 73154setMaskForm: aForm 73155 maskForm := aForm! ! 73156 73157!CursorWithMask methodsFor: 'mask' stamp: 'bf 2/2/1999 19:30'! 73158storeOn: aStream base: anInteger 73159 73160 aStream nextPut: $(. 73161 super storeOn: aStream base: anInteger. 73162 aStream nextPutAll: ' setMaskForm: '. 73163 maskForm storeOn: aStream base: anInteger. 73164 aStream nextPut: $)! ! 73165 73166!CursorWithMask methodsFor: 'mask' stamp: 'bf 2/2/1999 19:31'! 73167withMask 73168 ^self! ! 73169 73170 73171!CursorWithMask methodsFor: 'primitives' stamp: 'di 10/6/1998 15:16'! 73172beCursor 73173 maskForm unhibernate. 73174 ^ self beCursorWithMask: maskForm! ! 73175 73176"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 73177 73178CursorWithMask class 73179 instanceVariableNames: ''! 73180 73181!CursorWithMask class methodsFor: 'as yet unclassified' stamp: 'di 2/18/1999 08:56'! 73182derivedFrom: aForm "Cursor initNormalWithMask. Cursor normal show" 73183 "aForm is presumably a cursor" 73184 | cursor mask ext | 73185 ext := aForm extent. 73186 cursor := self extent: ext. 73187 cursor copy: (1@1 extent: ext) from: 0@0 in: aForm rule: Form over. 73188 mask := Form extent: ext. 73189 (1@1) eightNeighbors do: 73190 [:p | mask copy: (p extent: ext) from: 0@0 in: aForm rule: Form under]. 73191 cursor setMaskForm: mask. 73192 cursor offset: ((aForm offset - (1@1)) max: ext negated). 73193 ^ cursor! ! 73194Path subclass: #CurveFitter 73195 instanceVariableNames: '' 73196 classVariableNames: '' 73197 poolDictionaries: '' 73198 category: 'ST80-Paths'! 73199!CurveFitter commentStamp: '<historical>' prior: 0! 73200I represent a conic section determined by three points p1, p2 and p3. I interpolate p1 and p3 and am tangent to line p1, p2 at p1 and line p3, p2 at p3.! 73201 73202 73203!CurveFitter methodsFor: 'displaying'! 73204displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm 73205 73206 | pa pb k s p1 p2 p3 line | 73207 line := Line new. 73208 line form: self form. 73209 collectionOfPoints size < 3 ifTrue: [self error: 'Curve must have three points']. 73210 p1 := self firstPoint. 73211 p2 := self secondPoint. 73212 p3 := self thirdPoint. 73213 s := Path new. 73214 s add: p1. 73215 pa := p2 - p1. 73216 pb := p3 - p2. 73217 k := 5 max: pa x abs + pa y abs + pb x abs + pb y abs // 20. 73218 "k is a guess as to how many line segments to use to approximate 73219 the curve." 73220 1 to: k do: 73221 [:i | 73222 s add: pa * i // k + p1 * (k - i) + (pb * (i - 1) // k + p2 * (i - 1)) // (k - 1)]. 73223 s add: p3. 73224 1 to: s size - 1 do: 73225 [:i | 73226 line beginPoint: (s at: i). 73227 line endPoint: (s at: i + 1). 73228 line displayOn: aDisplayMedium 73229 at: aPoint 73230 clippingBox: clipRect 73231 rule: anInteger 73232 fillColor: aForm]! ! 73233 73234!CurveFitter methodsFor: 'displaying' stamp: '6/9/97 10:16 di'! 73235displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm 73236 73237 | transformedPath newCurveFitter | 73238 transformedPath := aTransformation applyTo: self. 73239 newCurveFitter := CurveFitter new. 73240 newCurveFitter firstPoint: transformedPath firstPoint. 73241 newCurveFitter secondPoint: transformedPath secondPoint. 73242 newCurveFitter thirdPoint: transformedPath thirdPoint. 73243 newCurveFitter form: self form. 73244 newCurveFitter 73245 displayOn: aDisplayMedium 73246 at: 0 @ 0 73247 clippingBox: clipRect 73248 rule: anInteger 73249 fillColor: aForm! ! 73250 73251"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 73252 73253CurveFitter class 73254 instanceVariableNames: ''! 73255 73256!CurveFitter class methodsFor: 'examples' stamp: '6/9/97 10:16 di'! 73257example 73258 "Designate three locations on the screen by clicking any button. The 73259 curve determined by the points will be displayed with a long black form." 73260 73261 | aCurveFitter aForm | 73262 aForm := Form extent: 1@30. "make a long thin Form for display " 73263 aForm fillBlack. "turn it black" 73264 aCurveFitter := CurveFitter new. 73265 aCurveFitter form: aForm. "set the form for display" 73266 "collect three Points and show them on the dispaly" 73267 aCurveFitter firstPoint: Sensor waitButton. Sensor waitNoButton. 73268 aForm displayOn: Display at: aCurveFitter firstPoint. 73269 aCurveFitter secondPoint: Sensor waitButton. Sensor waitNoButton. 73270 aForm displayOn: Display at: aCurveFitter secondPoint. 73271 aCurveFitter thirdPoint: Sensor waitButton. Sensor waitNoButton. 73272 aForm displayOn: Display at: aCurveFitter thirdPoint. 73273 73274 aCurveFitter displayOn: Display "display the CurveFitter" 73275 73276 "CurveFitter example"! ! 73277 73278 73279!CurveFitter class methodsFor: 'instance creation'! 73280new 73281 73282 | newSelf | 73283 newSelf := super new: 3. 73284 newSelf add: 0@0. 73285 newSelf add: 0@0. 73286 newSelf add: 0@0. 73287 ^newSelf! ! 73288PolygonMorph subclass: #CurveMorph 73289 instanceVariableNames: '' 73290 classVariableNames: '' 73291 poolDictionaries: '' 73292 category: 'Morphic-Basic'! 73293!CurveMorph commentStamp: '<historical>' prior: 0! 73294This is really only a shell for creating Shapes with smooth outlines.! 73295 73296 73297!CurveMorph methodsFor: 'initialization' stamp: 'di 9/10/2000 14:28'! 73298initialize 73299 73300 super initialize. 73301 self beSmoothCurve. 73302! ! 73303 73304 73305!CurveMorph methodsFor: 'parts bin' stamp: 'sw 6/28/2001 11:32'! 73306initializeToStandAlone 73307 73308 super initializeToStandAlone. 73309 self beSmoothCurve. 73310! ! 73311 73312 73313!CurveMorph methodsFor: 'testing' stamp: 'wiz 1/7/2005 20:02'! 73314isCurvier 73315 "Test used by smoothing routines. If true use true closed curve splines for closed curves. If not mimic old stodgy curveMorph curves with one sharp bend. Curve overrides this test for backward compatability.." 73316 ^ (false)! ! 73317 73318"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 73319 73320CurveMorph class 73321 instanceVariableNames: ''! 73322 73323!CurveMorph class methodsFor: 'instance creation' stamp: 'tk 11/14/2001 17:47'! 73324arrowPrototype 73325 73326 | aa | 73327 aa := PolygonMorph vertices: (Array with: 5@40 with: 5@8 with: 35@8 with: 35@40) 73328 color: Color black 73329 borderWidth: 2 73330 borderColor: Color black. 73331 aa beSmoothCurve; makeOpen; makeForwardArrow. "is already open" 73332 aa dashedBorder: {10. 10. Color red}. 73333 "A dash spec is a 3- or 5-element array with 73334 { length of normal border color. 73335 length of alternate border color. 73336 alternate border color}" 73337 aa computeBounds. 73338 ^ aa! ! 73339PolygonMorph subclass: #CurvierMorph 73340 instanceVariableNames: '' 73341 classVariableNames: '' 73342 poolDictionaries: '' 73343 category: 'Morphic-Basic-NewCurve'! 73344!CurvierMorph commentStamp: '<historical>' prior: 0! 73345I want to be merged into PolygonMorph. 73346I implement Closed Cubic Curves and restructured routines to ease maintence and development. 73347 73348 73349 73350New way to calculate curves. 73351 73352cVariables 73353SlopeConstantsCache anArray size 2 indexed by nVerts \\2 . 73354 Each element is an array of integers. The integers represent the constants for 73355 calculating slopes for closed cubic curves from the vertices. 73356 73357 73358 73359 73360Class Variable SlopeConstantsCache holds a pair of arrays for even and odd number of vertices( aka knots). 73361Each array holds a series of constants in Integer form. 73362This allows slopes to be calculated directly from the array of knots. 73363Wonderfully it turns out that only two arrays are needed. 73364By matching up the knots equidistant from the point in question; 73365Summing the weighted differences of the pairs the unscaled slope can be arrived at. 73366The scale needed to get the slopes needed is trice the reciprical of the next integer in the series. 73367We leave the division til last to get the full benifit of the integer arithmetic. 73368 73369Rounding the vertices before calculation is recommended. 73370 73371 73372Instead of calculating the number of curve subsegments in lineSegDo we add a ninth array to curve state to allow the number to be precalculated. 73373Getting better looking curves motivates finding a better way of guessing n. So this provides a framework for trying. 73374 73375For the first pass we just used the constant 12 for every thing. 73376In the second pass we judge the number of segments by starting with two and doubling the number until the distance of the curve no longer increases. 73377Then we hone in using a binary search to find the smallest number of segments with that same curve length. 73378 73379 73380We have changed some assumptions. Previously curves were figured by solving for the second derivative first and using the results to determine the slope and the third derivative. So lineSegDo counted on the last second deriv being a number it could use in its calculation of the number of subsegments. 73381 73382Currently we just solve for slopes and the second and third derivs are derived from that. 73383Also the derivation for the second and third derivs only assume C(1) (first derivitive continuity). The calculations for the slopes are the only calcs using C(2) continuity. Therefore the slopes can alternately be chosen to fit some other chriteria and the resulting curves will still be smooth to the first degree. 73384A useful variant of closed slopes is to scale them by a constant. 73385 73386 73387Also the last of each element of curvestate always reflects a closing segment. And we don't add an extra row for closed curves anymore. 73388That is now lineSegDo's responsibility to be aware of as it was already doing with segmented curves. So the last n does not track its old value. 73389 73390Preferences: 73391A Preference has been added to toggle between the old (ugly) closed curves based on natural cubic slopes and the new smooth algorythim. This doesn't make much difference while newcurves are a subclass of polygons but the ambition is for newcurves to supercede polygons. This will allow backwards compatibility. 73392 73393Shapes: With closed curves a smooth oval results from rectagular or diamond vertices. So two menuitems have been added (to PolygonMorph) that allow the vertices to be set to these shapes using the current bounds of the polygon. The former state of vertices will be lost but it seems useful to lose a complicated shape and start fresh with a simple symmetrical one. 73394 73395Furthur on: Modify curveState to only contain slope and higher deriv information. Let the information about the knots only be held only in the vertices of the polygon. Once that is done curvestate will not have to be recalcutaled each time the polygon is moved but only when its shape changes. 73396 73397There is also some possible speed up to be had by refining or experimenting with other number of segment calculating schemes but not as much as preserving curvestate over a move. 73398 73399Furthur furthur on: Figure out how to combine straight and curved segments into a single shape in a pleasing way. 73400 73401 73402 73403 73404 73405 73406 73407 73408 73409! 73410 73411 73412!CurvierMorph methodsFor: 'initialization' stamp: 'wiz 11/16/2004 21:35'! 73413initialize 73414 "We use an oval shape because we wear it well." 73415 super initialize. 73416 self beSmoothCurve. 73417 self diamondOval! ! 73418 73419"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 73420 73421CurvierMorph class 73422 instanceVariableNames: ''! 73423 73424!CurvierMorph class methodsFor: 'initialization' stamp: 'wiz 11/6/2004 23:16'! 73425initialize 73426 "CurvierMorph initialize" 73427 Preferences 73428 preferenceAt: #Curvier 73429 ifAbsent: [Preferences 73430 addPreference: #Curvier 73431 category: #morphic 73432 default: true 73433 balloonHelp: 'if true, closed CurvierMorphs will be smoother and more symmetrical all about. If false they will mimic the old curve shapes with the one sharp bend.']. 73434 self registerInFlapsRegistry! ! 73435 73436!CurvierMorph class methodsFor: 'initialization' stamp: 'wiz 11/6/2004 23:17'! 73437registerInFlapsRegistry 73438 "Register the receiver in the system's flaps registry" 73439 self environment 73440 at: #Flaps 73441 ifPresent: [:cl | 73442 cl registerQuad: #(#CurvierMorph #authoringPrototype 'Curvier' 'A curve' ) forFlapNamed: 'PlugIn Supplies'. 73443 cl registerQuad: #(#CurvierMorph #authoringPrototype 'Curvier' 'A curve' ) forFlapNamed: 'Supplies']! ! 73444SelectionMenu subclass: #CustomMenu 73445 instanceVariableNames: 'labels dividers lastDivider title targets arguments' 73446 classVariableNames: '' 73447 poolDictionaries: '' 73448 category: 'ST80-Menus'! 73449!CustomMenu commentStamp: '<historical>' prior: 0! 73450I am used to build menus on-the-fly. I maintain lists of menu items, actions (usually symbols to be sent as messages), and menu section dividing lines to which my clients may append new entries and lines by sending me the messages: 73451 73452 add: aString action: anAction 73453 addLine 73454 73455After the menu is constructed, it may be invoked with one of the following messages: 73456 73457 startUp: initialSelection 73458 startUp 73459 73460I am a subclass of ActionMenu, so I inherit a number of instance variables. The ones I am particularly concerned with are: 73461 73462 items _ an OrderedCollection of strings to appear in the menu 73463 selectors _ an OrderedCollection of Symbols to be used as message selectors 73464 lineArray _ an OrderedCollection of line positions 73465 lastLine _ used to keep track of the last line to avoid making duplicate entries in lineArray! 73466 73467 73468!CustomMenu methodsFor: '*morphic-invocation' stamp: 'wiz 7/20/2004 12:18'! 73469startUp: initialSelection withCaption: caption at: aPoint 73470 "Build and invoke this menu with the given initial selection and caption. 73471 Answer the selection associated with the menu item chosen by the user 73472 or nil if none is chosen." 73473 self build. 73474 initialSelection notNil 73475 ifTrue: [self preSelect: initialSelection]. 73476 ^ super startUpWithCaption: caption at: aPoint! ! 73477 73478!CustomMenu methodsFor: '*morphic-invocation' stamp: 'wiz 7/20/2004 12:20'! 73479startUpWithCaption: caption at: aPoint 73480 "Build and invoke this menu with no initial selection. Answer the 73481 selection associated with the menu item chosen by the user or nil if 73482 none is chosen; use the provided caption" 73483 ^ self startUp: nil withCaption: caption at: aPoint! ! 73484 73485 73486!CustomMenu methodsFor: 'compatibility' stamp: 'ads 2/20/2003 08:59'! 73487add: aString subMenu: aMenu target: target selector: aSymbol argumentList: argList 73488 "Create a sub-menu with the given label. This isn't really a sub-menu the way Morphic does it; it'll just pop up another menu." 73489 73490 self 73491 add: aString 73492 target: aMenu 73493 selector: #invokeOn: 73494 argumentList: argList asArray.! ! 73495 73496!CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:23'! 73497add: aString target: target selector: aSymbol argument: arg 73498 "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument." 73499 73500 self add: aString 73501 target: target 73502 selector: aSymbol 73503 argumentList: (Array with: arg)! ! 73504 73505!CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:18'! 73506add: aString target: target selector: aSymbol argumentList: argList 73507 "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument." 73508 73509 self add: aString action: aSymbol. 73510 targets addLast: target. 73511 arguments addLast: argList asArray 73512! ! 73513 73514!CustomMenu methodsFor: 'compatibility' stamp: 'nk 2/15/2004 16:19'! 73515addService: aService for: serviceUser 73516 "Append a menu item with the given service. If the item is selected, it will perform the given service." 73517 73518 aService addServiceFor: serviceUser toMenu: self.! ! 73519 73520!CustomMenu methodsFor: 'compatibility' stamp: 'nk 2/15/2004 16:02'! 73521addServices2: services for: served extraLines: linesArray 73522 73523 services withIndexDo: [:service :i | 73524 service addServiceFor: served toMenu: self. 73525 (linesArray includes: i) ifTrue: [self addLine] ]! ! 73526 73527!CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:20'! 73528addServices: services for: served extraLines: linesArray 73529 73530 services withIndexDo: [:service :i | 73531 self addService: service for: served. 73532 (linesArray includes: i) | service useLineAfter 73533 ifTrue: [self addLine]]! ! 73534 73535!CustomMenu methodsFor: 'compatibility' stamp: 'sw 2/16/2002 00:57'! 73536arguments 73537 "Answer my arguments, initializing them to an empty collection if they're found to be nil." 73538 73539 ^ arguments ifNil: [arguments := OrderedCollection new]! ! 73540 73541!CustomMenu methodsFor: 'compatibility' stamp: 'sw 2/16/2002 00:57'! 73542targets 73543 "Answer my targets, initializing them to an empty collection if found to be nil" 73544 73545 ^ targets ifNil: [targets := OrderedCollection new]! ! 73546 73547 73548!CustomMenu methodsFor: 'construction' stamp: 'dhhi 9/14/2000 22:39'! 73549add: aString action: actionItem 73550 "Add the given string as the next menu item. If it is selected, the given action (usually but not necessarily a symbol) will be returned to the client." 73551 73552 | s | 73553 aString ifNil: [^ self addLine]. 73554 s := String new: aString size + 2. 73555 s at: 1 put: Character space. 73556 s replaceFrom: 2 to: s size - 1 with: aString. 73557 s at: s size put: Character space. 73558 labels addLast: s. 73559 selections addLast: actionItem.! ! 73560 73561!CustomMenu methodsFor: 'construction'! 73562addLine 73563 "Append a line to the menu after the last entry. Suppress duplicate lines." 73564 73565 (lastDivider ~= selections size) ifTrue: [ 73566 lastDivider := selections size. 73567 dividers addLast: lastDivider].! ! 73568 73569!CustomMenu methodsFor: 'construction' stamp: 'sd 3/1/2008 21:35'! 73570addList: listOfTuplesAndDashes 73571 "Add a menu item to the receiver for each tuple in the given list of the form (<what to show> <selector>). Add a line for each dash (-) in the list. The tuples may have an optional third element, providing balloon help for the item, but such an element is ignored in mvc." 73572 73573 listOfTuplesAndDashes do: [:aTuple | 73574 aTuple == #- 73575 ifTrue: [self addLine] 73576 ifFalse: [self add: aTuple first capitalized action: aTuple second]] 73577 73578 "CustomMenu new addList: #( 73579 ('apples' buyApples) 73580 ('oranges' buyOranges) 73581 - 73582 ('milk' buyMilk)); startUp" 73583 73584! ! 73585 73586!CustomMenu methodsFor: 'construction' stamp: 'sw 8/12/2002 17:14'! 73587addStayUpItem 73588 "For compatibility with MenuMorph. Here it is a no-op"! ! 73589 73590!CustomMenu methodsFor: 'construction' stamp: 'nk 11/25/2003 10:00'! 73591addTranslatedList: listOfTuplesAndDashes 73592 "Add a menu item to the receiver for each tuple in the given list of the form (<what to show> <selector>). Add a line for each dash (-) in the list. The tuples may have an optional third element, providing balloon help for the item, but such an element is ignored in mvc. 73593 The first element will be translated." 73594 73595 listOfTuplesAndDashes do: [:aTuple | 73596 aTuple == #- 73597 ifTrue: [self addLine] 73598 ifFalse: [self add: aTuple first translated action: aTuple second]] 73599 73600 "CustomMenu new addTranslatedList: #( 73601 ('apples' buyApples) 73602 ('oranges' buyOranges) 73603 - 73604 ('milk' buyMilk)); startUp" 73605 73606! ! 73607 73608!CustomMenu methodsFor: 'construction' stamp: 'sw 7/20/1999 18:47'! 73609balloonTextForLastItem: aString 73610 "Vacuous backstop provided for compatibility with MorphicMenu"! ! 73611 73612!CustomMenu methodsFor: 'construction' stamp: 'jm 73613 8/20/1998 08:34'! 73614labels: aString font: aFont lines: anArrayOrNil 73615 "This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:." 73616 73617 | labelList linesArray | 73618 labelList := (aString findTokens: String cr) asArray. 73619 anArrayOrNil 73620 ifNil: [linesArray := #()] 73621 ifNotNil: [linesArray := anArrayOrNil]. 73622 1 to: labelList size do: [:i | 73623 self add: (labelList at: i) action: (labelList at: i). 73624 (linesArray includes: i) ifTrue: [self addLine]]. 73625 font ifNotNil: [font := aFont]. 73626! ! 73627 73628!CustomMenu methodsFor: 'construction' stamp: 'yo 8/28/2002 22:34'! 73629labels: labelList lines: linesArray selections: selectionsArray 73630 "This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:." 73631 "Labels can be either a sting with embedded crs, or a collection of strings." 73632 73633 | labelArray | 73634 labelList isString 73635 ifTrue: [labelArray := labelList findTokens: String cr] 73636 ifFalse: [labelArray := labelList]. 73637 1 to: labelArray size do: [:i | 73638 self add: (labelArray at: i) action: (selectionsArray at: i). 73639 (linesArray includes: i) ifTrue: [self addLine]]. 73640! ! 73641 73642 73643!CustomMenu methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:50'! 73644initialize 73645 73646 super initialize. 73647 labels := OrderedCollection new. 73648 selections := OrderedCollection new. 73649 dividers := OrderedCollection new. 73650 lastDivider := 0. 73651 targets := OrderedCollection new. 73652 arguments := OrderedCollection new ! ! 73653 73654!CustomMenu methodsFor: 'initialization' stamp: 'sw 8/18/1998 12:01'! 73655title: aTitle 73656 title := aTitle! ! 73657 73658 73659!CustomMenu methodsFor: 'invocation' stamp: 'sw 2/17/2002 04:48'! 73660invokeOn: targetObject 73661 "Pop up this menu and return the result of sending to the target object the selector corresponding to the menu item selected by the user. Return nil if no item is selected. If the chosen selector has arguments, obtain them from my arguments" 73662 73663 ^ self invokeOn: targetObject orSendTo: nil! ! 73664 73665!CustomMenu methodsFor: 'invocation' stamp: 'marcus.denker 9/14/2008 21:15'! 73666invokeOn: targetObject defaultSelection: defaultSelection 73667 "Invoke the menu with the given default selection (i.e. one of my 'action' symbols). Answer the 'action' selector associated with the menu item chosen by the user or nil if none is chosen." 73668 73669 | sel | 73670 sel := self startUp: defaultSelection. 73671 sel ifNotNil: [ 73672 sel numArgs = 0 73673 ifTrue: [^ targetObject perform: sel] 73674 ifFalse: [^ targetObject perform: sel with: nil]]. 73675 ^ nil 73676! ! 73677 73678!CustomMenu methodsFor: 'invocation' stamp: 'sw 11/16/2002 23:45'! 73679invokeOn: targetObject orSendTo: anObject 73680 "Pop up this menu and return the result of sending to the target object the selector corresponding to the menu item selected by the user. Return nil if no item is selected. If the chosen selector has arguments, obtain appropriately. If the recipient does not respond to the resulting message, send it to the alternate object provided" 73681 73682 | aSelector anIndex recipient | 73683 ^ (aSelector := self startUp) ifNotNil: 73684 [anIndex := self selection. 73685 recipient := ((targets := self targets) isEmptyOrNil or: [anIndex > targets size]) 73686 ifTrue: 73687 [targetObject] 73688 ifFalse: 73689 [targets at: anIndex]. 73690 aSelector numArgs == 0 73691 ifTrue: 73692 [recipient perform: aSelector orSendTo: anObject] 73693 ifFalse: 73694 [recipient perform: aSelector withArguments: (self arguments at: anIndex)]]! ! 73695 73696!CustomMenu methodsFor: 'invocation'! 73697startUp 73698 "Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen." 73699 73700 ^ self startUp: nil! ! 73701 73702!CustomMenu methodsFor: 'invocation' stamp: 'sw 8/18/1998 12:01'! 73703startUp: initialSelection 73704 "Build and invoke this menu with the given initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen." 73705 73706 ^ self startUp: initialSelection withCaption: title! ! 73707 73708!CustomMenu methodsFor: 'invocation'! 73709startUp: initialSelection withCaption: caption 73710 "Build and invoke this menu with the given initial selection and caption. Answer the selection associated with the menu item chosen by the user or nil if none is chosen." 73711 73712 self build. 73713 (initialSelection notNil) ifTrue: [self preSelect: initialSelection]. 73714 ^ super startUpWithCaption: caption! ! 73715 73716!CustomMenu methodsFor: 'invocation' stamp: 'sw 7/31/97 19:31'! 73717startUpWithCaption: caption 73718 "Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen; use the provided caption" 73719 73720 ^ self startUp: nil withCaption: caption! ! 73721 73722 73723!CustomMenu methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 01:05'! 73724build 73725 "Turn myself into an invokable ActionMenu." 73726 73727 | stream | 73728 stream := (String new) writeStream. 73729 labels do: [:label | stream nextPutAll: label; cr]. 73730 (labels isEmpty) ifFalse: [stream skip: -1]. "remove final cr" 73731 super labels: stream contents 73732 font: MenuStyle defaultFont 73733 lines: dividers! ! 73734 73735!CustomMenu methodsFor: 'private' stamp: 'di 4/14/1999 21:28'! 73736preSelect: action 73737 "Pre-select and highlight the menu item associated with the given action." 73738 73739 | i | 73740 i := selections indexOf: action ifAbsent: [^ self]. 73741 marker ifNil: [self computeForm]. 73742 marker := marker 73743 align: marker topLeft 73744 with: (marker left)@(frame inside top + (marker height * (i - 1))). 73745 selection := i.! ! 73746 73747"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 73748 73749CustomMenu class 73750 instanceVariableNames: ''! 73751 73752!CustomMenu class methodsFor: 'example' stamp: 'sw 11/8/1999 17:27'! 73753example 73754 "CustomMenu example" 73755 73756 | menu | 73757 menu := CustomMenu new. 73758 menu add: 'apples' action: #apples. 73759 menu add: 'oranges' action: #oranges. 73760 menu addLine. 73761 menu addLine. "extra lines ignored" 73762 menu add: 'peaches' action: #peaches. 73763 menu addLine. 73764 menu add: 'pears' action: #pears. 73765 menu addLine. 73766 ^ menu startUp: #apples 73767 73768 73769"NB: The following is equivalent to the above, but uses the compact #fromArray: consruct: 73770 (CustomMenu fromArray: 73771 #( ('apples' apples) 73772 ('oranges' oranges) 73773 - 73774 - 73775 ('peaches' peaches) 73776 - 73777 ('pears' pears) 73778 -)) 73779 startUp: #apples"! ! 73780QuestionWithoutCancelDialogWindow subclass: #CustomQuestionDialogWindow 73781 instanceVariableNames: 'yesButton noButton' 73782 classVariableNames: '' 73783 poolDictionaries: '' 73784 category: 'Polymorph-Widgets-Windows'! 73785!CustomQuestionDialogWindow commentStamp: 'gvc 9/23/2008 11:59' prior: 0! 73786QuestionDialog supporting custom text/buttons for yes/no choices.! 73787 73788 73789!CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/10/2008 11:30'! 73790noButton 73791 "Answer the value of noButton" 73792 73793 ^ noButton! ! 73794 73795!CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/10/2008 11:30'! 73796noButton: anObject 73797 "Set the value of noButton" 73798 73799 noButton := anObject! ! 73800 73801!CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/10/2008 11:30'! 73802yesButton 73803 "Answer the value of yesButton" 73804 73805 ^ yesButton! ! 73806 73807!CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/10/2008 11:30'! 73808yesButton: anObject 73809 "Set the value of yesButton" 73810 73811 yesButton := anObject! ! 73812 73813 73814!CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2008 11:31'! 73815defaultNoButton 73816 "Answer a default no button." 73817 73818 ^self newNoButton! ! 73819 73820!CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/23/2008 12:02'! 73821defaultYesButton 73822 "Answer a default yes button." 73823 73824 ^self newYesButton isDefault: true! ! 73825 73826!CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2008 11:42'! 73827initialize 73828 "Initialize the receiver." 73829 73830 self 73831 yesButton: self defaultYesButton; 73832 noButton: self defaultNoButton. 73833 super initialize! ! 73834 73835!CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/23/2008 12:02'! 73836newButtons 73837 "Answer new buttons as appropriate." 73838 73839 ^{self yesButton. self noButton}! ! 73840 73841!CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2008 11:47'! 73842noText: aStringOrText help: helpString 73843 "Set the no button label." 73844 73845 self noButton 73846 hResizing: #shrinkWrap; 73847 label: aStringOrText; 73848 setBalloonText: helpString! ! 73849 73850!CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2008 11:47'! 73851yesText: aStringOrText help: helpString 73852 "Set the yes button label." 73853 73854 self yesButton 73855 hResizing: #shrinkWrap; 73856 label: aStringOrText; 73857 setBalloonText: helpString! ! 73858Object subclass: #DamageRecorder 73859 instanceVariableNames: 'invalidRects totalRepaint' 73860 classVariableNames: '' 73861 poolDictionaries: '' 73862 category: 'Morphic-Support'! 73863 73864!DamageRecorder methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/27/2006 12:26'! 73865recordInvalidRect: newRect 73866 "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle." 73867 "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle." 73868 73869 | mergeRect a | 73870 totalRepaint ifTrue: [^ self]. "planning full repaint; don't bother collecting damage" 73871 73872 invalidRects do: 73873 [:rect | 73874 ((a := (rect intersect: newRect) area) > 40 73875 and: ["Avoid combining a vertical and horizontal rects. 73876 Can make a big diff and we only test when likely." 73877 a > (newRect area // 4) or: [a > (rect area // 4)]]) 73878 ifTrue: 73879 ["merge rectangle in place (see note below) if there is significant overlap" 73880 rect setOrigin: (rect origin min: newRect origin) truncated 73881 corner: (rect corner max: newRect corner) truncated. 73882 ^ self]]. 73883 73884 73885 invalidRects size >= 50 ifTrue: 73886 ["if there are too many separate areas, merge them all" 73887 mergeRect := Rectangle merging: invalidRects. 73888 self reset. 73889 invalidRects addLast: mergeRect]. 73890 73891 "add the given rectangle to the damage list" 73892 "Note: We make a deep copy of all rectangles added to the damage list, 73893 since rectangles in this list may be extended in place." 73894 invalidRects addLast: 73895 (newRect topLeft truncated corner: newRect bottomRight truncated). 73896! ! 73897 73898 73899!DamageRecorder methodsFor: 'initialization' stamp: 'sma 6/5/2000 11:55'! 73900reset 73901 "Clear the damage list." 73902 73903 invalidRects := OrderedCollection new: 15. 73904 totalRepaint := false 73905! ! 73906 73907 73908!DamageRecorder methodsFor: 'recording'! 73909doFullRepaint 73910 "Record that a full redisplay is needed. No further damage rectangles will be recorded until after the next reset." 73911 73912 ^ totalRepaint := true. 73913! ! 73914 73915!DamageRecorder methodsFor: 'recording'! 73916invalidRectsFullBounds: aRectangle 73917 "Return a collection of damaged rectangles for the given canvas. If a total repaint has been requested, return the given rectangle." 73918 73919 totalRepaint 73920 ifTrue: [^ Array with: aRectangle] 73921 ifFalse: [^ invalidRects copy]. 73922 73923! ! 73924 73925 73926!DamageRecorder methodsFor: 'testing' stamp: 'dgd 2/22/2003 14:43'! 73927updateIsNeeded 73928 "Return true if the display needs to be updated." 73929 73930 ^totalRepaint or: [invalidRects notEmpty]! ! 73931 73932"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 73933 73934DamageRecorder class 73935 instanceVariableNames: ''! 73936 73937!DamageRecorder class methodsFor: 'instance creation'! 73938new 73939 73940 ^ super new reset 73941! ! 73942SimpleBorder subclass: #DashedBorder 73943 instanceVariableNames: 'dashColors dashLengths' 73944 classVariableNames: '' 73945 poolDictionaries: '' 73946 category: 'Polymorph-Widgets-Borders'! 73947!DashedBorder commentStamp: 'gvc 5/18/2007 13:28' prior: 0! 73948Border style supporting dashed lines of configurable patterns and colours.! 73949 73950 73951!DashedBorder methodsFor: 'accessing' stamp: 'gvc 4/24/2007 15:48'! 73952dashColors 73953 "Answer the value of dashColors" 73954 73955 ^ dashColors! ! 73956 73957!DashedBorder methodsFor: 'accessing' stamp: 'gvc 4/24/2007 15:48'! 73958dashColors: anObject 73959 "Set the value of dashColors" 73960 73961 dashColors := anObject! ! 73962 73963!DashedBorder methodsFor: 'accessing' stamp: 'gvc 4/24/2007 15:59'! 73964dashColors: cols dashLengths: lens 73965 "Set the colours and lengths." 73966 73967 cols size = lens size ifFalse: [self error: 'Colors and Lengths must have the same size']. 73968 self 73969 dashColors: cols; 73970 dashLengths: lens! ! 73971 73972!DashedBorder methodsFor: 'accessing' stamp: 'gvc 4/24/2007 15:48'! 73973dashLengths 73974 "Answer the value of dashLengths" 73975 73976 ^ dashLengths! ! 73977 73978!DashedBorder methodsFor: 'accessing' stamp: 'gvc 4/24/2007 15:48'! 73979dashLengths: anObject 73980 "Set the value of dashLengths" 73981 73982 dashLengths := anObject! ! 73983 73984 73985!DashedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 15:51'! 73986frameRectangle: aRectangle on: aCanvas 73987 "Frame the given rectangle on aCanvas" 73988 73989 (aRectangle width < self width or: [aRectangle height < self width]) 73990 ifTrue: [^self]." don't do if too small" 73991 aCanvas 73992 frameRectangle: aRectangle 73993 width: self width 73994 colors: self dashColors 73995 dashes: self dashLengths! ! 73996 73997!DashedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 15:50'! 73998initialize 73999 "Initialize the receiver." 74000 74001 super initialize. 74002 self 74003 dashColors: {Color black. Color white}; 74004 dashLengths: #(1 1)! ! 74005 74006!DashedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 17:21'! 74007style 74008 "Answer #dashed." 74009 74010 ^#dashed! ! 74011 74012"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 74013 74014DashedBorder class 74015 instanceVariableNames: ''! 74016 74017!DashedBorder class methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 16:39'! 74018width: width dashColors: cols dashLengths: lens 74019 "Answer a new instance of the receiver with the given 74020 width, colours and lengths." 74021 74022 ^self new 74023 width: width; 74024 dashColors: cols dashLengths: lens! ! 74025Stream subclass: #DataStream 74026 instanceVariableNames: 'byteStream topCall basePos' 74027 classVariableNames: 'TypeMap' 74028 poolDictionaries: '' 74029 category: 'System-Object Storage'! 74030!DataStream commentStamp: '<historical>' prior: 0! 74031This is the save-to-disk facility. A DataStream can store one or more objects in a persistent form. 74032 74033To handle objects with sharing and cycles, you must use a 74034ReferenceStream instead of a DataStream. (Or SmartRefStream.) ReferenceStream is typically 74035faster and produces smaller files because it doesn't repeatedly write the same Symbols. 74036 74037Here is the way to use DataStream and ReferenceStream: 74038 rr _ ReferenceStream fileNamed: 'test.obj'. 74039 rr nextPut: <your object>. 74040 rr close. 74041 74042To get it back: 74043 rr _ ReferenceStream fileNamed: 'test.obj'. 74044 <your object> _ rr next. 74045 rr close. 74046 74047Each object to be stored has two opportunities to control what gets stored. On the high level, objectToStoreOnDataStream allows you to substitute another object on the way out. The low level hook is storeDataOn:. The read-in counterparts to these messages are comeFullyUpOnReload and (class) readDataFrom:size:. See these methods, and the class DiskProxy, for more information about externalizing and internalizing. 74048 74049NOTE: A DataStream should be treated as a write-stream for writing. It is a read-stream for reading. It is not a ReadWriteStream. 74050! 74051 74052 74053!DataStream methodsFor: 'other'! 74054atEnd 74055 "Answer true if the stream is at the end." 74056 74057 ^ byteStream atEnd! ! 74058 74059!DataStream methodsFor: 'other'! 74060byteStream 74061 ^ byteStream! ! 74062 74063!DataStream methodsFor: 'other'! 74064close 74065 "Close the stream." 74066 74067 | bytes | 74068 byteStream closed 74069 ifFalse: [ 74070 bytes := byteStream position. 74071 byteStream close] 74072 ifTrue: [bytes := 'unknown']. 74073 ^ bytes! ! 74074 74075!DataStream methodsFor: 'other' stamp: 'nk 3/12/2004 21:56'! 74076contents 74077 ^byteStream contents! ! 74078 74079!DataStream methodsFor: 'other' stamp: 'yo 12/3/2004 17:14'! 74080errorWriteReference: anInteger 74081 "PRIVATE -- Raise an error because this case of nextPut:'s perform: 74082 shouldn't be called. -- 11/15/92 jhm" 74083 74084 self error: 'This should never be called'! ! 74085 74086!DataStream methodsFor: 'other'! 74087flush 74088 "Guarantee that any writes to me are actually recorded on disk. -- 11/17/92 jhm" 74089 74090 ^ byteStream flush! ! 74091 74092!DataStream methodsFor: 'other'! 74093next: anInteger 74094 "Answer an Array of the next anInteger objects in the stream." 74095 | array | 74096 74097 array := Array new: anInteger. 74098 1 to: anInteger do: [:i | 74099 array at: i put: self next]. 74100 ^ array! ! 74101 74102!DataStream methodsFor: 'other' stamp: 'tk 3/5/2002 09:51'! 74103nextAndClose 74104 "Speedy way to grab one object. Only use when we are inside an object binary file. Do not use for the start of a SmartRefStream mixed code-and-object file." 74105 74106 | obj | 74107 obj := self next. 74108 self close. 74109 ^ obj! ! 74110 74111!DataStream methodsFor: 'other' stamp: 'ar 2/24/2001 22:45'! 74112project 74113 ^nil! ! 74114 74115!DataStream methodsFor: 'other'! 74116reset 74117 "Reset the stream." 74118 74119 byteStream reset! ! 74120 74121!DataStream methodsFor: 'other' stamp: 'tk 5/29/97'! 74122rootObject 74123 "Return the object at the root of the tree we are filing out. " 74124 74125 ^ topCall! ! 74126 74127!DataStream methodsFor: 'other' stamp: 'tk 5/29/97'! 74128rootObject: anObject 74129 "Return the object at the root of the tree we are filing out. " 74130 74131 topCall := anObject! ! 74132 74133!DataStream methodsFor: 'other' stamp: '6/9/97 08:03 di'! 74134setStream: aStream 74135 "PRIVATE -- Initialization method." 74136 74137 aStream binary. 74138 basePos := aStream position. "Remember where we start. Earlier part of file contains a class or method file-in. Allow that to be edited. We don't deal in absolute file locations." 74139 byteStream := aStream.! ! 74140 74141!DataStream methodsFor: 'other' stamp: 'tk 8/18/1998 08:59'! 74142setStream: aStream reading: isReading 74143 "PRIVATE -- Initialization method." 74144 74145 aStream binary. 74146 basePos := aStream position. "Remember where we start. Earlier part of file contains a class or method file-in. Allow that to be edited. We don't deal in absolute file locations." 74147 byteStream := aStream.! ! 74148 74149!DataStream methodsFor: 'other'! 74150size 74151 "Answer the stream's size." 74152 74153 ^ byteStream size! ! 74154 74155!DataStream methodsFor: 'other' stamp: 'tk 7/12/1998 13:16'! 74156vacantRef 74157 "Answer the magic 32-bit constant we use ***ON DISK*** as a stream 'reference 74158 position' to identify a reference that's not yet filled in. This must be a 74159 value that won't be used as an ordinary reference. Cf. outputReference: and 74160 readReference. -- 74161 NOTE: We could use a different type ID for vacant-refs rather than writing 74162 object-references with a magic value. (The type ID and value are 74163 overwritten by ordinary object-references when weak refs are fullfilled.)" 74164 74165 ^ SmallInteger maxVal! ! 74166 74167 74168!DataStream methodsFor: 'write and read' stamp: '6/9/97 08:14 tk'! 74169beginInstance: aClass size: anInteger 74170 "This is for use by storeDataOn: methods. 74171 Cf. Object>>storeDataOn:." 74172 74173 "Addition of 1 seems to make extra work, since readInstance 74174 has to compensate. Here for historical reasons dating back 74175 to Kent Beck's original implementation in late 1988. 74176 74177 In ReferenceStream, class is just 5 bytes for shared symbol. 74178 74179 SmartRefStream puts out the names and number of class's instances variables for checking." 74180 74181 byteStream nextNumber: 4 put: anInteger + 1. 74182 74183 self nextPut: aClass name! ! 74184 74185!DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:12'! 74186beginReference: anObject 74187 "We're starting to read anObject. Remember it and its reference 74188 position (if we care; ReferenceStream cares). Answer the 74189 reference position." 74190 74191 ^ 0! ! 74192 74193!DataStream methodsFor: 'write and read'! 74194getCurrentReference 74195 "PRIVATE -- Return the currentReference posn. 74196 Overridden by ReferenceStream." 74197 74198 ^ 0! ! 74199 74200!DataStream methodsFor: 'write and read' stamp: 'tk 4/8/1999 13:11'! 74201maybeBeginReference: internalObject 74202 "Do nothing. See ReferenceStream|maybeBeginReference:" 74203 74204 ^ internalObject! ! 74205 74206!DataStream methodsFor: 'write and read' stamp: 'ar 4/10/2005 20:31'! 74207next 74208 "Answer the next object in the stream." 74209 | type selector anObject isARefType pos internalObject | 74210 74211 type := byteStream next. 74212 type ifNil: [pos := byteStream position. "absolute!!!!" 74213 byteStream close. "clean up" 74214 byteStream position = 0 74215 ifTrue: [self error: 'The file did not exist in this directory'] 74216 ifFalse: [self error: 'Unexpected end of object file']. 74217 pos. "so can see it in debugger" 74218 ^ nil]. 74219 type = 0 ifTrue: [pos := byteStream position. "absolute!!!!" 74220 byteStream close. "clean up" 74221 self error: 'Expected start of object, but found 0'. 74222 ^ nil]. 74223 isARefType := self noteCurrentReference: type. 74224 selector := #(readNil readTrue readFalse readInteger "<-4" 74225 readStringOld readSymbol readByteArray "<-7" 74226 readArray readInstance readReference readBitmap "<-11" 74227 readClass readUser readFloat readRectangle readShortInst "<-16" 74228 readString readWordArray readWordArrayForSegment "<-19" 74229 readWordLike readMethod "<-21") at: type. 74230 selector == 0 ifTrue: [pos := byteStream position. "absolute!!!!" 74231 byteStream close. 74232 self error: 'file is more recent than this system'. ^ nil]. 74233 anObject := self perform: selector. "A method that recursively 74234 calls next (readArray, readInstance, objectAt:) must save & 74235 restore the current reference position." 74236 isARefType ifTrue: [self beginReference: anObject]. 74237 74238 "After reading the externalObject, internalize it. 74239 #readReference is a special case. Either: 74240 (1) We actually have to read the object, recursively calling 74241 next, which internalizes the object. 74242 (2) We just read a reference to an object already read and 74243 thus already interalized. 74244 Either way, we must not re-internalize the object here." 74245 selector == #readReference ifTrue: [^ anObject]. 74246 internalObject := anObject comeFullyUpOnReload: self. 74247 internalObject == String ifTrue:[ 74248 "This is a hack to figure out if we're loading a String class 74249 that really should be a ByteString. Note that these days this 74250 will no longer be necessary since we use #withClassVersion: 74251 for constructing the global thus using a different classVersion 74252 will perfectly do the trick." 74253 ((anObject isKindOf: DiskProxy) 74254 and:[anObject globalObjectName == #String 74255 and:[anObject constructorSelector == #yourself]]) ifTrue:[ 74256 internalObject := ByteString]]. 74257 ^ self maybeBeginReference: internalObject! ! 74258 74259!DataStream methodsFor: 'write and read' stamp: 'tk 10/4/2000 10:35'! 74260nextPut: anObject 74261 "Write anObject to the receiver stream. Answer anObject." 74262 | typeID selector objectToStore | 74263 74264 typeID := self typeIDFor: anObject. 74265 (self tryToPutReference: anObject typeID: typeID) 74266 ifTrue: [^ anObject]. 74267 74268 objectToStore := (self objectIfBlocked: anObject) objectForDataStream: self. 74269 objectToStore == anObject ifFalse: [typeID := self typeIDFor: objectToStore]. 74270 74271 byteStream nextPut: typeID. 74272 selector := #(writeNil: writeTrue: writeFalse: writeInteger: 74273 writeStringOld: writeSymbol: writeByteArray: 74274 writeArray: writeInstance: errorWriteReference: writeBitmap: 74275 writeClass: writeUser: writeFloat: writeRectangle: == "<-16 short inst" 74276 writeString: writeBitmap: writeBitmap: writeWordLike: 74277 writeInstance: "CompiledMethod") at: typeID. 74278 self perform: selector with: objectToStore. 74279 74280 ^ anObject 74281 74282 74283"NOTE: If anObject is a reference type (one that we write cross-references to) but its externalized form (result of objectForDataStream:) isn't (e.g. CompiledMethod and ViewState), then we should remember its externalized form 74284 but not add to 'references'. Putting that object again should just put its 74285 external form again. That's more compact and avoids seeks when reading. 74286 But we just do the simple thing here, allowing backward-references for 74287 non-reference types like nil. So objectAt: has to compensate. Objects that 74288 externalize nicely won't contain the likes of ViewStates, so this shouldn't 74289 hurt much. 74290 writeReference: -> errorWriteReference:."! ! 74291 74292!DataStream methodsFor: 'write and read'! 74293nextPutAll: aCollection 74294 "Write each of the objects in aCollection to the 74295 receiver stream. Answer aCollection." 74296 74297 ^ aCollection do: [:each | self nextPut: each]! ! 74298 74299!DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:25'! 74300noteCurrentReference: typeID 74301 "PRIVATE -- If we support references for type typeID, remember 74302 the current byteStream position so we can add the next object to 74303 the 'objects' dictionary, and return true. Else return false. 74304 This method is here to be overridden by ReferenceStream" 74305 74306 ^ false! ! 74307 74308!DataStream methodsFor: 'write and read' stamp: ' 74309 6/9/97'! 74310objectAt: anInteger 74311 "PRIVATE -- Read & return the object at a given stream position. 08:18 tk anInteger is a relative file position. " 74312 | savedPosn anObject refPosn | 74313 74314 savedPosn := byteStream position. "absolute" 74315 refPosn := self getCurrentReference. "relative position" 74316 74317 byteStream position: anInteger + basePos. "was relative" 74318 anObject := self next. 74319 74320 self setCurrentReference: refPosn. "relative position" 74321 byteStream position: savedPosn. "absolute" 74322 ^ anObject! ! 74323 74324!DataStream methodsFor: 'write and read' stamp: 'tk 3/13/98 22:16'! 74325objectIfBlocked: anObject 74326 "We don't do any blocking" 74327 74328 ^ anObject! ! 74329 74330!DataStream methodsFor: 'write and read' stamp: '6/9/97 08:46 tk'! 74331outputReference: referencePosn 74332 "PRIVATE -- Output a reference to the object at integer stream position referencePosn (relative to basePos). To output a weak reference to an object not yet written, supply (self vacantRef) for referencePosn." 74333 74334 byteStream nextPut: 10. "reference typeID" 74335 byteStream nextNumber: 4 put: referencePosn "relative position"! ! 74336 74337!DataStream methodsFor: 'write and read' stamp: '6/9/97 08:32 tk'! 74338readArray 74339 "PRIVATE -- Read the contents of an Array. 74340 We must do beginReference: here after instantiating the Array 74341 but before reading its contents, in case the contents reference 74342 the Array. beginReference: will be sent again when we return to 74343 next, but that's ok as long as we save and restore the current 74344 reference position over recursive calls to next." 74345 | count array refPosn | 74346 74347 count := byteStream nextNumber: 4. 74348 74349 refPosn := self beginReference: (array := Array new: count). "relative pos" 74350 1 to: count do: [:i | 74351 array at: i put: self next]. 74352 self setCurrentReference: refPosn. "relative pos" 74353 ^ array! ! 74354 74355!DataStream methodsFor: 'write and read'! 74356readBitmap 74357 "PRIVATE -- Read the contents of a Bitmap." 74358 74359 ^ Bitmap newFromStream: byteStream 74360 "Note that the reader knows that the size is in long words, but the data is in bytes."! ! 74361 74362!DataStream methodsFor: 'write and read'! 74363readBoolean 74364 "PRIVATE -- Read the contents of a Boolean. 74365 This is here only for compatibility with old data files." 74366 74367 ^ byteStream next ~= 0! ! 74368 74369!DataStream methodsFor: 'write and read' stamp: 'jm 8/19/1998 17:00'! 74370readByteArray 74371 "PRIVATE -- Read the contents of a ByteArray." 74372 74373 | count | 74374 count := byteStream nextNumber: 4. 74375 ^ byteStream next: count "assume stream is in binary mode" 74376! ! 74377 74378!DataStream methodsFor: 'write and read' stamp: 'tk 3/24/98 10:29'! 74379readClass 74380 "Should never be executed because a DiskProxy, not a clas comes in." 74381 74382 ^ self error: 'Classes should be filed in'! ! 74383 74384!DataStream methodsFor: 'write and read'! 74385readFalse 74386 "PRIVATE -- Read the contents of a False." 74387 74388 ^ false! ! 74389 74390!DataStream methodsFor: 'write and read'! 74391readFloat 74392 "PRIVATE -- Read the contents of a Float. 74393 This is the fast way to read a Float. 74394 We support 8-byte Floats here. Non-IEEE" 74395 74396 | new | 74397 new := Float new: 2. "To get an instance" 74398 new at: 1 put: (byteStream nextNumber: 4). 74399 new at: 2 put: (byteStream nextNumber: 4). 74400 ^ new! ! 74401 74402!DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:12'! 74403readFloatString 74404 "PRIVATE -- Read the contents of a Float string. 74405 This is the slow way to read a Float--via its string rep'n. 74406 It's here for compatibility with old data files." 74407 74408 ^ Float readFrom: (byteStream next: (byteStream nextNumber: 4))! ! 74409 74410!DataStream methodsFor: 'write and read' stamp: 'tk 1/8/97'! 74411readInstance 74412 "PRIVATE -- Read the contents of an arbitrary instance. 74413 ASSUMES: readDataFrom:size: sends me beginReference: after it 74414 instantiates the new object but before reading nested objects. 74415 NOTE: We must restore the current reference position after 74416 recursive calls to next. 74417 Let the instance, not the class read the data. " 74418 | instSize aSymbol refPosn anObject newClass | 74419 74420 instSize := (byteStream nextNumber: 4) - 1. 74421 refPosn := self getCurrentReference. 74422 aSymbol := self next. 74423 newClass := Smalltalk at: aSymbol asSymbol. 74424 anObject := newClass isVariable "Create object here" 74425 ifFalse: [newClass basicNew] 74426 ifTrue: [newClass basicNew: instSize - (newClass instSize)]. 74427 self setCurrentReference: refPosn. "before readDataFrom:size:" 74428 anObject := anObject readDataFrom: self size: instSize. 74429 self setCurrentReference: refPosn. "before returning to next" 74430 ^ anObject! ! 74431 74432!DataStream methodsFor: 'write and read'! 74433readInteger 74434 "PRIVATE -- Read the contents of a SmallInteger." 74435 74436 ^ byteStream nextInt32 "signed!!!!!!"! ! 74437 74438!DataStream methodsFor: 'write and read' stamp: 'tk 10/6/2000 14:36'! 74439readMethod 74440 "PRIVATE -- Read the contents of an arbitrary instance. 74441 ASSUMES: readDataFrom:size: sends me beginReference: after it 74442 instantiates the new object but before reading nested objects. 74443 NOTE: We must restore the current reference position after 74444 recursive calls to next. 74445 Let the instance, not the class read the data. " 74446 | instSize refPosn newClass className xxHeader nLits byteCodeSizePlusTrailer newMethod lits | 74447 74448 instSize := (byteStream nextNumber: 4) - 1. 74449 refPosn := self getCurrentReference. 74450 className := self next. 74451 newClass := Smalltalk at: className asSymbol. 74452 74453 xxHeader := self next. 74454 "nArgs := (xxHeader >> 24) bitAnd: 16rF." 74455 "nTemps := (xxHeader >> 18) bitAnd: 16r3F." 74456 "largeBit := (xxHeader >> 17) bitAnd: 1." 74457 nLits := (xxHeader >> 9) bitAnd: 16rFF. 74458 "primBits := ((xxHeader >> 19) bitAnd: 16r600) + (xxHeader bitAnd: 16r1FF)." 74459 byteCodeSizePlusTrailer := instSize - (newClass instSize "0") - (nLits + 1 * 4). 74460 74461 newMethod := newClass 74462 newMethod: byteCodeSizePlusTrailer 74463 header: xxHeader. 74464 74465 self setCurrentReference: refPosn. "before readDataFrom:size:" 74466 self beginReference: newMethod. 74467 lits := newMethod numLiterals + 1. "counting header" 74468 2 to: lits do: 74469 [:ii | newMethod objectAt: ii put: self next]. 74470 lits*4+1 to: newMethod basicSize do: 74471 [:ii | newMethod basicAt: ii put: byteStream next]. 74472 "Get raw bytes directly from the file" 74473 self setCurrentReference: refPosn. "before returning to next" 74474 ^ newMethod! ! 74475 74476!DataStream methodsFor: 'write and read'! 74477readNil 74478 "PRIVATE -- Read the contents of an UndefinedObject." 74479 74480 ^ nil! ! 74481 74482!DataStream methodsFor: 'write and read' stamp: ' 6/9/97'! 74483readRectangle 74484 "Read a compact Rectangle. Rectangles with values outside +/- 2047 were stored as normal objects (type=9). They will not come here. 17:22 tk" 74485 74486 "Encoding is four 12-bit signed numbers. 48 bits in next 6 bytes. 17:24 tk" 74487 | acc left top right bottom | 74488 acc := byteStream nextNumber: 3. 74489 left := acc bitShift: -12. 74490 (left bitAnd: 16r800) ~= 0 ifTrue: [left := left - 16r1000]. "sign" 74491 top := acc bitAnd: 16rFFF. 74492 (top bitAnd: 16r800) ~= 0 ifTrue: [top := top - 16r1000]. "sign" 74493 74494 acc := byteStream nextNumber: 3. 74495 right := acc bitShift: -12. 74496 (right bitAnd: 16r800) ~= 0 ifTrue: [right := right - 16r1000]. "sign" 74497 bottom := acc bitAnd: 16rFFF. 74498 (bottom bitAnd: 16r800) ~= 0 ifTrue: [bottom := bottom - 16r1000]. "sign" 74499 74500 ^ Rectangle left: left right: right top: top bottom: bottom 74501! ! 74502 74503!DataStream methodsFor: 'write and read' stamp: 'tk 1/5/2000 11:47'! 74504readReference 74505 "Read the contents of an object reference. (Cf. outputReference:) File is not now positioned at this object." 74506 | referencePosition | 74507 74508 ^ (referencePosition := (byteStream nextNumber: 4)) = self vacantRef "relative" 74509 ifTrue: [nil] 74510 ifFalse: [self objectAt: referencePosition] "relative pos"! ! 74511 74512!DataStream methodsFor: 'write and read' stamp: 'tk 1/8/97'! 74513readShortInst 74514 "Read the contents of an arbitrary instance that has a short header. 74515 ASSUMES: readDataFrom:size: sends me beginReference: after it 74516 instantiates the new object but before reading nested objects. 74517 NOTE: We must restore the current reference position after 74518 recursive calls to next. 74519 Let the instance, not the class read the data. " 74520 | instSize aSymbol refPosn anObject newClass | 74521 74522 instSize := (byteStream next) - 1. "one byte of size" 74523 refPosn := self getCurrentReference. 74524 aSymbol := self readShortRef. "class symbol in two bytes of file pos" 74525 newClass := Smalltalk at: aSymbol asSymbol. 74526 anObject := newClass isVariable "Create object here" 74527 ifFalse: [newClass basicNew] 74528 ifTrue: [newClass basicNew: instSize - (newClass instSize)]. 74529 self setCurrentReference: refPosn. "before readDataFrom:size:" 74530 anObject := anObject readDataFrom: self size: instSize. 74531 self setCurrentReference: refPosn. "before returning to next" 74532 ^ anObject! ! 74533 74534!DataStream methodsFor: 'write and read' stamp: 'tk 7/12/1998 13:32'! 74535readShortRef 74536 "Read an object reference from two bytes only. Original object must be in first 65536 bytes of the file. Relative to start of data. vacantRef not a possibility." 74537 74538 ^ self objectAt: (byteStream nextNumber: 2)! ! 74539 74540!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:03'! 74541readString 74542 74543 | str | 74544 byteStream ascii. 74545 str := byteStream nextString. 74546 byteStream binary. 74547 ^ str 74548! ! 74549 74550!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:27'! 74551readStringOld 74552 74553 ^ byteStream nextStringOld! ! 74554 74555!DataStream methodsFor: 'write and read'! 74556readSymbol 74557 "PRIVATE -- Read the contents of a Symbol." 74558 74559 ^ self readString asSymbol! ! 74560 74561!DataStream methodsFor: 'write and read'! 74562readTrue 74563 "PRIVATE -- Read the contents of a True." 74564 74565 ^ true! ! 74566 74567!DataStream methodsFor: 'write and read' stamp: 'tk 3/4/1999 22:58'! 74568readUser 74569 "Reconstruct both the private class and the instance. Still used??" 74570 74571 ^ self readInstance. "Will create new unique class" 74572! ! 74573 74574!DataStream methodsFor: 'write and read' stamp: 'tk 1/24/2000 23:20'! 74575readWordArray 74576 "PRIVATE -- Read the contents of a WordArray." 74577 74578 ^ WordArray newFromStream: byteStream 74579 "Size is number of long words."! ! 74580 74581!DataStream methodsFor: 'write and read' stamp: 'tk 1/24/2000 23:23'! 74582readWordArrayForSegment 74583 "Read the contents of a WordArray ignoring endianness." 74584 74585 ^ WordArrayForSegment newFromStream: byteStream 74586 "Size is number of long words."! ! 74587 74588!DataStream methodsFor: 'write and read' stamp: 'tk 2/3/2000 21:11'! 74589readWordLike 74590 | refPosn aSymbol newClass anObject | 74591 "Can be used by any class that is bits and not bytes (WordArray, Bitmap, SoundBuffer, etc)." 74592 74593 refPosn := self getCurrentReference. 74594 aSymbol := self next. 74595 newClass := Smalltalk at: aSymbol asSymbol. 74596 anObject := newClass newFromStream: byteStream. 74597 "Size is number of long words." 74598 self setCurrentReference: refPosn. "before returning to next" 74599 ^ anObject 74600! ! 74601 74602!DataStream methodsFor: 'write and read' stamp: 'tk 9/24/2000 15:39'! 74603replace: original with: proxy 74604 "We may wish to remember that in some field, the original object is being replaced by the proxy. For the hybred scheme that collects with a DummyStream and writes an ImageSegment, it needs to hold onto the originals so they will appear in outPointers, and be replaced." 74605 74606 "do nothing"! ! 74607 74608!DataStream methodsFor: 'write and read'! 74609setCurrentReference: refPosn 74610 "PRIVATE -- Set currentReference to refPosn. 74611 Noop here. Cf. ReferenceStream."! ! 74612 74613!DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 16:59'! 74614tryToPutReference: anObject typeID: typeID 74615 "PRIVATE -- If we support references for type typeID, and if 74616 anObject already appears in my output stream, then put a 74617 reference to the place where anObject already appears. If we 74618 support references for typeID but didn't already put anObject, 74619 then associate the current stream position with anObject in 74620 case one wants to nextPut: it again. 74621 Return true after putting a reference; false if the object still 74622 needs to be put. 74623 For DataStream this is trivial. ReferenceStream overrides this." 74624 74625 ^ false! ! 74626 74627!DataStream methodsFor: 'write and read' stamp: 'tk 2/20/1999 23:02'! 74628typeIDFor: anObject 74629 "Return the typeID for anObject's class. This is where the tangle of objects is clipped to stop everything from going out. 74630 Classes can control their instance variables by defining objectToStoreOnDataStream. 74631 Any object in blockers is not written out. See ReferenceStream.objectIfBlocked: and DataStream nextPut:. 74632 Morphs do not write their owners. See Morph.storeDataOn: Each morph tells itself to 'prepareToBeSaved' before writing out." 74633 74634 ^ TypeMap at: anObject class ifAbsent: [9 "instance of any normal class"] 74635"See DataStream initialize. nil=1. true=2. false=3. a SmallInteger=4. (a String was 5). a Symbol=6. a ByteArray=7. an Array=8. other = 9. a Bitmap=11. a Metaclass=12. a Float=14. a Rectangle=15. any instance that can have a short header=16. a String=17 (new format). a WordArray=18."! ! 74636 74637!DataStream methodsFor: 'write and read'! 74638writeArray: anArray 74639 "PRIVATE -- Write the contents of an Array." 74640 74641 byteStream nextNumber: 4 put: anArray size. 74642 self nextPutAll: anArray.! ! 74643 74644!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:07'! 74645writeBitmap: aBitmap 74646 "PRIVATE -- Write the contents of a Bitmap." 74647 74648 aBitmap writeOn: byteStream 74649 "Note that this calls (byteStream nextPutAll: aBitmap) which knows enough to put 4-byte quantities on the stream!! Reader must know that size is in long words."! ! 74650 74651!DataStream methodsFor: 'write and read'! 74652writeBoolean: aBoolean 74653 "PRIVATE -- Write the contents of a Boolean. 74654 This method is now obsolete." 74655 74656 byteStream nextPut: (aBoolean ifTrue: [1] ifFalse: [0])! ! 74657 74658!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:06'! 74659writeByteArray: aByteArray 74660 "PRIVATE -- Write the contents of a ByteArray." 74661 74662 byteStream nextNumber: 4 put: aByteArray size. 74663 "May have to convert types here..." 74664 byteStream nextPutAll: aByteArray.! ! 74665 74666!DataStream methodsFor: 'write and read' stamp: 'tk 3/24/98 10:27'! 74667writeClass: aClass 74668 "Write out a DiskProxy for the class. It will look up the class's name in Smalltalk in the new sustem. Never write classes or methodDictionaries as objects. For novel classes, front part of file is a fileIn of the new class." 74669 74670 "This method never executed because objectToStoreOnDataStream returns a DiskProxy. See DataStream.nextPut:" 74671 ^ self error: 'Write a DiskProxy instead'! ! 74672 74673!DataStream methodsFor: 'write and read'! 74674writeFalse: aFalse 74675 "PRIVATE -- Write the contents of a False."! ! 74676 74677!DataStream methodsFor: 'write and read'! 74678writeFloat: aFloat 74679 "PRIVATE -- Write the contents of a Float. 74680 We support 8-byte Floats here." 74681 74682 byteStream nextNumber: 4 put: (aFloat at: 1). 74683 byteStream nextNumber: 4 put: (aFloat at: 2). 74684! ! 74685 74686!DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:07'! 74687writeFloatString: aFloat 74688 "PRIVATE -- Write the contents of a Float string. 74689 This is the slow way to write a Float--via its string rep'n." 74690 74691 self writeByteArray: (aFloat printString)! ! 74692 74693!DataStream methodsFor: 'write and read'! 74694writeInstance: anObject 74695 "PRIVATE -- Write the contents of an arbitrary instance." 74696 74697 ^ anObject storeDataOn: self! ! 74698 74699!DataStream methodsFor: 'write and read'! 74700writeInteger: anInteger 74701 "PRIVATE -- Write the contents of a SmallInteger." 74702 74703 byteStream nextInt32Put: anInteger "signed!!!!!!!!!!"! ! 74704 74705!DataStream methodsFor: 'write and read'! 74706writeNil: anUndefinedObject 74707 "PRIVATE -- Write the contents of an UndefinedObject."! ! 74708 74709!DataStream methodsFor: 'write and read' stamp: 'jm 7/31/97 16:16'! 74710writeRectangle: anObject 74711 "Write the contents of a Rectangle. See if it can be a compact Rectangle (type=15). Rectangles with values outside +/- 2047 were stored as normal objects (type=9). 17:22 tk" 74712 74713 | ok right bottom top left acc | 74714 ok := true. 74715 (right := anObject right) > 2047 ifTrue: [ok := false]. 74716 right < -2048 ifTrue: [ok := false]. 74717 (bottom := anObject bottom) > 2047 ifTrue: [ok := false]. 74718 bottom < -2048 ifTrue: [ok := false]. 74719 (top := anObject top) > 2047 ifTrue: [ok := false]. 74720 top < -2048 ifTrue: [ok := false]. 74721 (left := anObject left) > 2047 ifTrue: [ok := false]. 74722 left < -2048 ifTrue: [ok := false]. 74723 ok := ok & left isInteger & right isInteger & top isInteger & bottom isInteger. 74724 74725 ok ifFalse: [ 74726 byteStream skip: -1; nextPut: 9; skip: 0. "rewrite type to be normal instance" 74727 ^ anObject storeDataOn: self]. 74728 74729 acc := ((left bitAnd: 16rFFF) bitShift: 12) + (top bitAnd: 16rFFF). 74730 byteStream nextNumber: 3 put: acc. 74731 acc := ((right bitAnd: 16rFFF) bitShift: 12) + (bottom bitAnd: 16rFFF). 74732 byteStream nextNumber: 3 put: acc.! ! 74733 74734!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 20:57'! 74735writeString: aString 74736 "PRIVATE -- Write the contents of a String." 74737 74738 byteStream nextStringPut: aString.! ! 74739 74740!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:23'! 74741writeStringOld: aString 74742 "PRIVATE -- Write the contents of a String." 74743 74744 | length | 74745 aString size < 16384 74746 ifTrue: [ 74747 (length := aString size) < 192 74748 ifTrue: [byteStream nextPut: length] 74749 ifFalse: 74750 [byteStream nextPut: (length // 256 + 192). 74751 byteStream nextPut: (length \\ 256)]. 74752 aString do: [:char | byteStream nextPut: char asciiValue]] 74753 ifFalse: [self writeByteArray: aString]. "takes more space"! ! 74754 74755!DataStream methodsFor: 'write and read'! 74756writeSymbol: aSymbol 74757 "PRIVATE -- Write the contents of a Symbol." 74758 74759 self writeString: aSymbol! ! 74760 74761!DataStream methodsFor: 'write and read'! 74762writeTrue: aTrue 74763 "PRIVATE -- Write the contents of a True."! ! 74764 74765!DataStream methodsFor: 'write and read'! 74766writeUser: anObject 74767 "Write the contents of an arbitrary User instance (and its devoted class)." 74768 " 7/29/96 tk" 74769 74770 "If anObject is an instance of a unique user class, will lie and say it has a generic class" 74771 ^ anObject storeDataOn: self! ! 74772 74773!DataStream methodsFor: 'write and read' stamp: 'tk 2/5/2000 21:53'! 74774writeWordLike: aWordArray 74775 "Note that we put the class name before the size." 74776 74777 self nextPut: aWordArray class name. 74778 aWordArray writeOn: byteStream 74779 "Note that this calls (byteStream nextPutAll: aBitmap) which knows enough to put 4-byte quantities on the stream!! Reader must know that size is in long words or double-bytes."! ! 74780 74781"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 74782 74783DataStream class 74784 instanceVariableNames: ''! 74785 74786!DataStream class methodsFor: 'as yet unclassified'! 74787example 74788 "An example and test of DataStream/ReferenceStream. 74789 11/19/92 jhm: Use self testWith:." 74790 "DataStream example" 74791 "ReferenceStream example" 74792 | input sharedPoint | 74793 74794 "Construct the test data." 74795 input := Array new: 9. 74796 input at: 1 put: nil. 74797 input at: 2 put: true. 74798 input at: 3 put: (Form extent: 63 @ 50 depth: 8). 74799 (input at: 3) fillWithColor: Color lightBlue. 74800 input at: 4 put: #(3 3.0 'three'). 74801 input at: 5 put: false. 74802 input at: 6 put: 1024 @ -2048. 74803 input at: 7 put: #x. 74804 input at: 8 put: (Array with: (sharedPoint := 0 @ -30000)). 74805 input at: 9 put: sharedPoint. 74806 74807 "Write it out, read it back, and return it for inspection." 74808 ^ self testWith: input! ! 74809 74810!DataStream class methodsFor: 'as yet unclassified'! 74811exampleWithPictures 74812 "DataStream exampleWithPictures" 74813 | file result | 74814 file := FileStream fileNamed: 'Test-Picture'. 74815 file binary. 74816 (DataStream on: file) nextPut: (Form fromUser). 74817 file close. 74818 74819 file := FileStream fileNamed: 'Test-Picture'. 74820 file binary. 74821 result := (DataStream on: file) next. 74822 file close. 74823 result display. 74824 ^ result! ! 74825 74826!DataStream class methodsFor: 'as yet unclassified'! 74827fileNamed: aString 74828 "Here is the way to use DataStream and ReferenceStream: 74829rr := ReferenceStream fileNamed: 'test.obj'. 74830rr nextPut: <your object>. 74831rr close. 74832" 74833 74834 | strm | 74835 strm := self on: (FileStream fileNamed: aString). "will be binary" 74836 strm byteStream setFileTypeToObject. 74837 "Type and Creator not to be text, so can attach correctly to an email msg" 74838 ^ strm! ! 74839 74840!DataStream class methodsFor: 'as yet unclassified' stamp: 'adrian_lienhard 7/27/2009 20:11'! 74841initialize 74842 "TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats. nextPut: writes these IDs to the data stream. NOTE: Changing these type ID numbers will invalidate all extant data stream files. Adding new ones is OK. 74843 Classes named here have special formats in the file. If such a class has a subclass, it will use type 9 and write correctly. It will just be slow. (Later write the class name in the special format, then subclasses can use the type also.) 74844 See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:" 74845 "DataStream initialize" 74846 74847 | refTypes t | 74848 refTypes := OrderedCollection new. 74849 t := TypeMap := Dictionary new: 80. "sparse for fast hashing" 74850 74851 t at: UndefinedObject put: 1. refTypes add: 0. 74852 t at: True put: 2. refTypes add: 0. 74853 t at: False put: 3. refTypes add: 0. 74854 t at: SmallInteger put: 4. refTypes add: 0. 74855 t at: ByteString put: 5. refTypes add: 1. 74856 t at: ByteSymbol put: 6. refTypes add: 1. 74857 t at: ByteArray put: 7. refTypes add: 1. 74858 t at: Array put: 8. refTypes add: 1. 74859 "(type ID 9 is for arbitrary instances of any class, cf. typeIDFor:)" 74860 refTypes add: 1. 74861 "(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)" 74862 refTypes add: 0. 74863 t at: Bitmap put: 11. refTypes add: 1. 74864 t at: Metaclass put: 12. refTypes add: 0. 74865 "Type ID 13 is used for HyperSqueak User classes that must be reconstructed." 74866 refTypes add: 1. 74867 t at: Float put: 14. refTypes add: 1. 74868 t at: Rectangle put: 15. refTypes add: 1. "Allow compact Rects." 74869 "type ID 16 is an instance with short header. See beginInstance:size:" 74870 refTypes add: 1. 74871self flag: #ByteArray. 74872 t at: ByteString put: 17. refTypes add: 1. "new String format, 1 or 4 bytes of length" 74873 t at: WordArray put: 18. refTypes add: 1. "bitmap-like" 74874 t at: WordArrayForSegment put: 19. refTypes add: 1. "bitmap-like" 74875 Smalltalk at: #SoundBuffer ifPresent: [ :class | 74876 t at: class put: 20. refTypes add: 1. "And all other word arrays, both 74877 16-bit and 32-bit. See methods in ArrayedCollection. Overridden in SoundBuffer." 74878 ]. 74879 t at: CompiledMethod put: 21. refTypes add: 1. "special creation method" 74880 "t at: put: 22. refTypes add: 0." 74881 ReferenceStream refTypes: refTypes. "save it" 74882 74883 "For all classes that are like WordArrays, store them the way ColorArray is stored. As bits, and able to change endianness." 74884 Smalltalk do: [:cls | 74885 cls isInMemory ifTrue: [ 74886 cls isBehavior ifTrue: [ 74887 cls isPointers not & cls isVariable & cls isWords ifTrue: [ 74888 (t includesKey: cls) ifFalse: [t at: cls put: 20]]]]].! ! 74889 74890!DataStream class methodsFor: 'as yet unclassified' stamp: 'di 2/15/98 14:03'! 74891new 74892 ^ self basicNew! ! 74893 74894!DataStream class methodsFor: 'as yet unclassified'! 74895newFileNamed: aString 74896 "Here is the way to use DataStream and ReferenceStream: 74897rr := ReferenceStream fileNamed: 'test.obj'. 74898rr nextPut: <your object>. 74899rr close. 74900" 74901 74902 | strm | 74903 strm := self on: (FileStream newFileNamed: aString). "will be binary" 74904 strm byteStream setFileTypeToObject. 74905 "Type and Creator not to be text, so can attach correctly to an email msg" 74906 ^ strm! ! 74907 74908!DataStream class methodsFor: 'as yet unclassified'! 74909oldFileNamed: aString 74910 "Here is the way to use DataStream and ReferenceStream: 74911rr := ReferenceStream oldFileNamed: 'test.obj'. 74912^ rr nextAndClose. 74913" 74914 74915 | strm ff | 74916 ff := FileStream oldFileOrNoneNamed: aString. 74917 ff ifNil: [^ nil]. 74918 strm := self on: (ff binary). 74919 ^ strm! ! 74920 74921!DataStream class methodsFor: 'as yet unclassified' stamp: 'di 6/24/97 00:18'! 74922on: aStream 74923 "Open a new DataStream onto a low-level I/O stream." 74924 74925 ^ self basicNew setStream: aStream 74926 "aStream binary is in setStream:" 74927! ! 74928 74929!DataStream class methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 08:38'! 74930streamedRepresentationOf: anObject 74931 74932 | file | 74933 file := (RWBinaryOrTextStream on: (ByteArray new: 5000)). 74934 file binary. 74935 (self on: file) nextPut: anObject. 74936 ^file contents! ! 74937 74938!DataStream class methodsFor: 'as yet unclassified' stamp: 'jm 12/3/97 19:36'! 74939testWith: anObject 74940 "As a test of DataStream/ReferenceStream, write out anObject and read it back. 74941 11/19/92 jhm: Set the file type. More informative file name." 74942 "DataStream testWith: 'hi'" 74943 "ReferenceStream testWith: 'hi'" 74944 | file result | 74945 74946 file := FileStream fileNamed: (self name, ' test'). 74947 file binary. 74948 (self on: file) nextPut: anObject. 74949 file close. 74950 74951 file := FileStream fileNamed: (self name, ' test'). 74952 file binary. 74953 result := (self on: file) next. 74954 file close. 74955 ^ result! ! 74956 74957!DataStream class methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 08:33'! 74958unStream: aString 74959 74960 ^(self on: ((RWBinaryOrTextStream with: aString) reset; binary)) next! ! 74961Timespan subclass: #Date 74962 instanceVariableNames: '' 74963 classVariableNames: '' 74964 poolDictionaries: 'ChronologyConstants' 74965 category: 'Kernel-Chronology'! 74966!Date commentStamp: '<historical>' prior: 0! 74967Instances of Date are Timespans with duration of 1 day. 74968Their default creation assumes a start of midnight in the local time zone.! 74969 74970 74971!Date methodsFor: 'printing' stamp: 'sd 3/16/2008 14:43'! 74972mmddyyyy 74973 "Answer the receiver rendered in standard U.S.A format mm/dd/yyyy. 74974 Note that the name here is slightly misleading -- the month and day numbers don't show leading zeros, 74975 so that for example February 1 1996 is 2/1/96" 74976 74977 ^ self printFormat: #(2 1 3 $/ 1 1)! ! 74978 74979!Date methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 01:05'! 74980printFormat: formatArray 74981 "Answer a String describing the receiver using the argument formatArray." 74982 74983 | aStream | 74984 aStream := (String new: 16) writeStream. 74985 self printOn: aStream format: formatArray. 74986 ^ aStream contents! ! 74987 74988!Date methodsFor: 'printing' stamp: 'BP 3/23/2001 12:27'! 74989printOn: aStream 74990 74991 self printOn: aStream format: #(1 2 3 $ 3 1 )! ! 74992 74993!Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:05'! 74994printOn: aStream format: formatArray 74995 "Print a description of the receiver on aStream using the format 74996 denoted the argument, formatArray: 74997 74998 #(item item item sep monthfmt yearfmt twoDigits) 74999 75000 items: 1=day 2=month 3=year will appear in the order given, 75001 75002 separated by sep which is eaither an ascii code or character. 75003 75004 monthFmt: 1=09 2=Sep 3=September 75005 75006 yearFmt: 1=1996 2=96 75007 75008 digits: (missing or)1=9 2=09. 75009 75010 See the examples in printOn: and mmddyy" 75011 | gregorian twoDigits element monthFormat | 75012 gregorian := self dayMonthYearDo: [ :d :m :y | {d. m. y} ]. 75013 twoDigits := formatArray size > 6 and: [(formatArray at: 7) > 1]. 75014 1 to: 3 do: 75015 [ :i | 75016 element := formatArray at: i. 75017 element = 1 75018 ifTrue: [twoDigits 75019 ifTrue: [aStream 75020 nextPutAll: (gregorian first asString 75021 padded: #left 75022 to: 2 75023 with: $0)] 75024 ifFalse: [gregorian first printOn: aStream]]. 75025 element = 2 75026 ifTrue: [monthFormat := formatArray at: 5. 75027 monthFormat = 1 75028 ifTrue: [twoDigits 75029 ifTrue: [aStream 75030 nextPutAll: (gregorian middle asString 75031 padded: #left 75032 to: 2 75033 with: $0)] 75034 ifFalse: [gregorian middle printOn: aStream]]. 75035 monthFormat = 2 75036 ifTrue: [aStream 75037 nextPutAll: ((Month nameOfMonth: gregorian middle) 75038 copyFrom: 1 75039 to: 3)]. 75040 monthFormat = 3 75041 ifTrue: [aStream 75042 nextPutAll: (Month nameOfMonth: gregorian middle)]]. 75043 element = 3 75044 ifTrue: [(formatArray at: 6) 75045 = 1 75046 ifTrue: [gregorian last printOn: aStream] 75047 ifFalse: [aStream 75048 nextPutAll: ((gregorian last \\ 100) asString 75049 padded: #left 75050 to: 2 75051 with: $0)]]. 75052 i < 3 75053 ifTrue: [(formatArray at: 4) 75054 ~= 0 75055 ifTrue: [aStream nextPut: (formatArray at: 4) asCharacter]]] 75056! ! 75057 75058!Date methodsFor: 'printing' stamp: 'BP 3/23/2001 12:27'! 75059storeOn: aStream 75060 75061 aStream print: self printString; nextPutAll: ' asDate'! ! 75062 75063!Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:04'! 75064yyyymmdd 75065 "Format the date in ISO 8601 standard like '2002-10-22'." 75066 75067 ^ self printFormat: #(3 2 1 $- 1 1 2)! ! 75068 75069 75070!Date methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:09'! 75071addDays: dayCount 75072 75073 ^ (self asDateAndTime + (dayCount days)) asDate! ! 75074 75075!Date methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:08'! 75076asSeconds 75077 "Answer the seconds since the Squeak epoch: 1 January 1901" 75078 75079 ^ start asSeconds! ! 75080 75081!Date methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:08'! 75082leap 75083 "Answer whether the receiver's year is a leap year." 75084 75085 ^ start isLeapYear ifTrue: [1] ifFalse: [0].! ! 75086 75087!Date methodsFor: 'smalltalk-80' stamp: 'brp 1/16/2004 14:30'! 75088previous: dayName 75089 "Answer the previous date whose weekday name is dayName." 75090 75091 | days | 75092 days := 7 + self weekdayIndex - (self class dayOfWeek: dayName) \\ 7. 75093 days = 0 ifTrue: [ days := 7 ]. 75094 ^ self subtractDays: days 75095! ! 75096 75097!Date methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:09'! 75098subtractDate: aDate 75099 "Answer the number of days between self and aDate" 75100 75101 ^ (self start - aDate asDateAndTime) days! ! 75102 75103!Date methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:05'! 75104subtractDays: dayCount 75105 75106 ^ (self asDateAndTime - (dayCount days)) asDate! ! 75107 75108!Date methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 12:04'! 75109weekday 75110 "Answer the name of the day of the week on which the receiver falls." 75111 75112 ^ self dayOfWeekName! ! 75113 75114!Date methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 12:04'! 75115weekdayIndex 75116 "Sunday=1, ... , Saturday=7" 75117 75118 ^ self dayOfWeek! ! 75119 75120 75121!Date methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 14:43'! 75122asDate 75123 75124 ^ self! ! 75125 75126!Date methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:10'! 75127dayMonthYearDo: aBlock 75128 "Supply integers for day, month and year to aBlock and return the result" 75129 75130 ^ start dayMonthYearDo: aBlock! ! 75131 75132!Date methodsFor: 'squeak protocol' stamp: 'avi 2/21/2004 18:12'! 75133month 75134 ^ self asMonth! ! 75135 75136!Date methodsFor: 'squeak protocol' stamp: 'avi 2/29/2004 13:10'! 75137monthIndex 75138 ^ super month! ! 75139 75140 75141!Date methodsFor: 'utils' stamp: 'tbn 7/11/2006 10:30'! 75142addMonths: monthCount 75143 |year month maxDaysInMonth day | 75144 year := self year + (monthCount + self monthIndex - 1 // 12). 75145 month := self monthIndex + monthCount - 1 \\ 12 + 1. 75146 maxDaysInMonth := Month daysInMonth: month forYear: year. 75147 day := self dayOfMonth > maxDaysInMonth 75148 ifTrue: [maxDaysInMonth] 75149 ifFalse: [self dayOfMonth]. 75150 ^ Date 75151 newDay: day 75152 month: month 75153 year: year! ! 75154 75155!Date methodsFor: 'utils' stamp: 'spfa 3/8/2004 13:52'! 75156onNextMonth 75157 75158 ^ self addMonths: 1 75159! ! 75160 75161!Date methodsFor: 'utils' stamp: 'spfa 3/8/2004 13:52'! 75162onPreviousMonth 75163 75164 ^ self addMonths: -1 75165! ! 75166 75167"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 75168 75169Date class 75170 instanceVariableNames: ''! 75171 75172!Date class methodsFor: 'general inquiries' stamp: 'BG 3/16/2005 14:57'! 75173easterDateFor: year 75174 75175 " compute the easter date. 75176 source: Physikalisch-Technische Bundesanstalt Braunschweig. 75177 Lichtenberg, H.: Zur Interpretation der Gaussschen Osterformel 75178 und ihrer Ausnahmeregeln, 75179 Historia Mathematica 24 (1997), pp. 441-444 75180 75181 http://www.ptb.de/de/org/4/44/441/oste.htm 75182 " 75183 75184 | k m s a d r og sz oe day | 75185 75186 k := year // 100. 75187 m := 15 + (3*k + 3//4) - (8*k + 13//25). 75188 s := 2 - (3*k + 3// 4). 75189 a := year \\ 19. 75190 d := 19*a + m \\ 30. 75191 r := d//29 + ((d//28) - (d//29)* (a// 11)). 75192 75193 og := 21 + d - r. 75194 sz := 7 - (year//4 + year + s\\7). 75195 oe := 7 - (og - sz\\7). 75196 day := og + oe. 75197 ^day <= 31 75198 ifTrue: [Date newDay: day month: 3 year: year ] 75199 ifFalse: [Date newDay: day - 31 month: 4 year: year].! ! 75200 75201!Date class methodsFor: 'general inquiries' stamp: 'BG 3/16/2005 14:48'! 75202orthodoxEasterDateFor: year 75203 75204 " compute the easter date according to the rules of the orthodox calendar. 75205 source: 75206 http://www.smart.net/~mmontes/ortheast.html 75207 " 75208 | r1 r2 r3 r4 ra rb r5 rc date | 75209 75210 r1 := year \\ 19. 75211 r2 := year \\ 4. 75212 r3 := year \\ 7. 75213 ra := 19*r1 + 16. 75214 r4 := ra \\ 30. 75215 rb := r2 + r2 + (4*r3) + (6*r4). 75216 r5 := rb \\ 7. 75217 rc := r4 + r5. 75218 date := Date newDay: 3 month: 4 year: year. 75219 ^date addDays: rc.! ! 75220 75221 75222!Date class methodsFor: 'smalltalk-80' stamp: 'sd 3/16/2008 14:57'! 75223dateAndTimeNow 75224 "Answer an Array whose with Date today and Time now." 75225 75226 ^ Time dateAndTimeNow! ! 75227 75228!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:35'! 75229dayOfWeek: dayName 75230 75231 ^ Week indexOfDay: dayName! ! 75232 75233!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:59'! 75234daysInMonth: monthName forYear: yearInteger 75235 75236 ^ Month daysInMonth: monthName forYear: yearInteger. 75237! ! 75238 75239!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:53'! 75240daysInYear: yearInteger 75241 75242 ^ Year daysInYear: yearInteger.! ! 75243 75244!Date class methodsFor: 'smalltalk-80' stamp: 'brp 1/16/2004 14:35'! 75245firstWeekdayOfMonth: month year: year 75246 "Answer the weekday index of the first day in <month> in the <year>." 75247 75248 ^ (self newDay: 1 month: month year: year) weekdayIndex 75249! ! 75250 75251!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:01'! 75252fromDays: dayCount 75253 "Days since 1 January 1901" 75254 75255 ^ self julianDayNumber: dayCount + SqueakEpoch! ! 75256 75257!Date class methodsFor: 'smalltalk-80' stamp: 'sd 3/16/2008 14:57'! 75258fromSeconds: seconds 75259 "Answer an instance of me which is 'seconds' seconds after January 1, 1901." 75260 75261 ^ self fromDays: ((Duration seconds: seconds) days)! ! 75262 75263!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:39'! 75264indexOfMonth: aMonthName 75265 75266 ^ Month indexOfMonth: aMonthName. 75267! ! 75268 75269!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:56'! 75270leapYear: yearInteger 75271 75272 ^ Year leapYear: yearInteger! ! 75273 75274!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:37'! 75275nameOfDay: dayIndex 75276 75277 ^ Week nameOfDay: dayIndex ! ! 75278 75279!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:40'! 75280nameOfMonth: anIndex 75281 75282 ^ Month nameOfMonth: anIndex. 75283! ! 75284 75285!Date class methodsFor: 'smalltalk-80' stamp: 'sd 3/16/2008 14:57'! 75286newDay: day month: month year: year 75287 75288 ^ self year: year month: month day: day! ! 75289 75290!Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:01'! 75291newDay: dayCount year: yearInteger 75292 75293 ^ self year: yearInteger day: dayCount! ! 75294 75295!Date class methodsFor: 'smalltalk-80' stamp: 'sd 3/16/2008 14:57'! 75296today 75297 75298 ^ self current! ! 75299 75300 75301!Date class methodsFor: 'squeak protocol' stamp: 'md 7/15/2006 18:06'! 75302fromString: aString 75303 "Answer an instance of created from a string with format mm.dd.yyyy." 75304 75305 ^ self readFrom: aString readStream.! ! 75306 75307!Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 18:25'! 75308julianDayNumber: aJulianDayNumber 75309 75310 ^ self starting: (DateAndTime julianDayNumber: aJulianDayNumber)! ! 75311 75312!Date class methodsFor: 'squeak protocol' stamp: 'PeterHugossonMiller 9/3/2009 01:06'! 75313readFrom: aStream 75314 "Read a Date from the stream in any of the forms: 75315 <day> <monthName> <year> (5 April 1982; 5-APR-82) 75316 <monthName> <day> <year> (April 5, 1982) 75317 <monthNumber> <day> <year> (4/5/82) 75318 <day><monthName><year> (5APR82)" 75319 | day month year | 75320 aStream peek isDigit 75321 ifTrue: [day := Integer readFrom: aStream]. 75322 [aStream peek isAlphaNumeric] 75323 whileFalse: [aStream skip: 1]. 75324 aStream peek isLetter 75325 ifTrue: ["number/name... or name..." 75326 month := (String new: 10) writeStream. 75327 [aStream peek isLetter] 75328 whileTrue: [month nextPut: aStream next]. 75329 month := month contents. 75330 day isNil 75331 ifTrue: ["name/number..." 75332 [aStream peek isAlphaNumeric] 75333 whileFalse: [aStream skip: 1]. 75334 day := Integer readFrom: aStream]] 75335 ifFalse: ["number/number..." 75336 month := Month nameOfMonth: day. 75337 day := Integer readFrom: aStream]. 75338 [aStream peek isAlphaNumeric] 75339 whileFalse: [aStream skip: 1]. 75340 year := Integer readFrom: aStream. 75341 year < 10 ifTrue: [year := 2000 + year] 75342 ifFalse: [ year < 1900 ifTrue: [ year := 1900 + year]]. 75343 75344 ^ self 75345 year: year 75346 month: month 75347 day: day! ! 75348 75349!Date class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 14:58'! 75350starting: aDateAndTime 75351 75352 ^ super starting: (aDateAndTime midnight) duration: (Duration days: 1) 75353! ! 75354 75355!Date class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 18:09'! 75356tomorrow 75357 75358 ^ self today next! ! 75359 75360!Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 22:03'! 75361year: year day: dayOfYear 75362 75363 ^ self starting: (DateAndTime year: year day: dayOfYear) 75364! ! 75365 75366!Date class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 14:58'! 75367year: year month: month day: day 75368 75369 ^ self starting: (DateAndTime year: year month: month day: day) 75370! ! 75371 75372!Date class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 18:09'! 75373yesterday 75374 75375 ^ self today previous! ! 75376Magnitude subclass: #DateAndTime 75377 instanceVariableNames: 'seconds offset jdn nanos' 75378 classVariableNames: 'LocalTimeZone' 75379 poolDictionaries: 'ChronologyConstants' 75380 category: 'Kernel-Chronology'! 75381!DateAndTime commentStamp: 'sd 3/16/2008 14:58' prior: 0! 75382I represent a point in UTC time as defined by ISO 8601. I have zero duration. 75383 75384 75385My implementation uses three SmallIntegers and a Duration: 75386jdn - julian day number. 75387seconds - number of seconds since midnight. 75388nanos - the number of nanoseconds since the second. 75389 75390offset - duration from UTC. 75391 75392The nanosecond attribute is almost always zero but it defined for full ISO compliance and is suitable for timestamping. 75393! 75394 75395 75396!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 7/9/2005 08:45'! 75397+ operand 75398 "operand conforms to protocol Duration" 75399 75400 | ticks | 75401 ticks := self ticks + (operand asDuration ticks) . 75402 75403 ^ self class basicNew 75404 ticks: ticks 75405 offset: self offset; 75406 yourself. 75407! ! 75408 75409!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 1/9/2004 05:39'! 75410- operand 75411 "operand conforms to protocol DateAndTime or protocol Duration" 75412 75413 ^ (operand respondsTo: #asDateAndTime) 75414 ifTrue: 75415 [ | lticks rticks | 75416 lticks := self asLocal ticks. 75417 75418 rticks := operand asDateAndTime asLocal ticks. 75419 Duration 75420 seconds: (SecondsInDay *(lticks first - rticks first)) + 75421 (lticks second - rticks second) 75422 nanoSeconds: (lticks third - rticks third) ] 75423 75424 ifFalse: 75425 75426 [ self + (operand negated) ]. 75427! ! 75428 75429!DateAndTime methodsFor: 'ansi protocol' stamp: 'nk 3/30/2004 09:09'! 75430< comparand 75431 "comparand conforms to protocol DateAndTime, 75432 or can be converted into something that conforms." 75433 | lticks rticks comparandAsDateAndTime | 75434 comparandAsDateAndTime := comparand asDateAndTime. 75435 offset = comparandAsDateAndTime offset 75436 ifTrue: [lticks := self ticks. 75437 rticks := comparandAsDateAndTime ticks] 75438 ifFalse: [lticks := self asUTC ticks. 75439 rticks := comparandAsDateAndTime asUTC ticks]. 75440 ^ lticks first < rticks first 75441 or: [lticks first > rticks first 75442 ifTrue: [false] 75443 ifFalse: [lticks second < rticks second 75444 or: [lticks second > rticks second 75445 ifTrue: [false] 75446 ifFalse: [lticks third < rticks third]]]] 75447! ! 75448 75449!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 7/28/2004 16:14'! 75450= comparand 75451 "comparand conforms to protocol DateAndTime, 75452 or can be converted into something that conforms." 75453 | comparandAsDateAndTime | 75454 self == comparand 75455 ifTrue: [^ true]. 75456 [comparandAsDateAndTime := comparand asDateAndTime] 75457 on: MessageNotUnderstood 75458 do: [^ false]. 75459 ^ self offset = comparandAsDateAndTime offset 75460 ifTrue: [self hasEqualTicks: comparandAsDateAndTime ] 75461 ifFalse: [self asUTC ticks = comparandAsDateAndTime asUTC ticks] 75462! ! 75463 75464!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:04'! 75465asLocal 75466 75467 ^ (self offset = self class localOffset) 75468 ifTrue: [self] 75469 ifFalse: [self utcOffset: self class localOffset] 75470! ! 75471 75472!DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 4/13/2006 10:21'! 75473asUTC 75474 75475 ^ offset isZero 75476 ifTrue: [self] 75477 ifFalse: [self utcOffset: 0] 75478! ! 75479 75480!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:04'! 75481dayOfMonth 75482 "Answer which day of the month is represented by the receiver." 75483 75484 ^ self dayMonthYearDo: [ :d :m :y | d ]! ! 75485 75486!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:04'! 75487dayOfWeek 75488 "Sunday=1, ... , Saturday=7" 75489 75490 ^ (jdn + 1 rem: 7) + 1! ! 75491 75492!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:04'! 75493dayOfWeekAbbreviation 75494 75495 ^ self dayOfWeekName copyFrom: 1 to: 3! ! 75496 75497!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:04'! 75498dayOfWeekName 75499 75500 ^ Week nameOfDay: self dayOfWeek 75501! ! 75502 75503!DateAndTime methodsFor: 'ansi protocol' stamp: 'adrian_lienhard 1/7/2009 18:23'! 75504dayOfYear 75505 "This code was contributed by Dan Ingalls. It is equivalent to the terser 75506 ^ jdn - (Year year: self year) start julianDayNumber + 1 but much quicker." 75507 75508 | monthStart | 75509 ^ self dayMonthYearDo: 75510 [ :d :m :y | 75511 monthStart := #(1 32 60 91 121 152 182 213 244 274 305 335) at: m. 75512 (m > 2 and: [ Year isLeapYear: y ]) 75513 ifTrue: [ monthStart + d ] 75514 ifFalse: [ monthStart + d - 1 ]]! ! 75515 75516!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:04'! 75517hash 75518 75519 ^ self asUTC ticks hash 75520! ! 75521 75522!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:04'! 75523hour 75524 75525 ^ self hour24 75526! ! 75527 75528!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:05'! 75529hour12 75530 "Answer an <integer> between 1 and 12, inclusive, representing the hour 75531 of the day in the 12-hour clock of the local time of the receiver." 75532 75533 ^ self hour24 - 1 \\ 12 + 1! ! 75534 75535!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:05'! 75536hour24 75537 75538 ^ (Duration seconds: seconds) hours! ! 75539 75540!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:05'! 75541isLeapYear 75542 75543 ^ Year isLeapYear: self year. 75544! ! 75545 75546!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:05'! 75547meridianAbbreviation 75548 75549 ^ self asTime meridianAbbreviation! ! 75550 75551!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:05'! 75552minute 75553 75554 ^ (Duration seconds: seconds) minutes 75555! ! 75556 75557!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:05'! 75558month 75559 75560 ^ self dayMonthYearDo: [ :d :m :y | m ].! ! 75561 75562!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:05'! 75563monthAbbreviation 75564 75565 ^ self monthName copyFrom: 1 to: 3 75566! ! 75567 75568!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:05'! 75569monthName 75570 75571 ^ Month nameOfMonth: self month 75572! ! 75573 75574!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:06'! 75575offset 75576 75577 ^ offset 75578! ! 75579 75580!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:06'! 75581offset: anOffset 75582 "Answer a <DateAndTime> equivalent to the receiver but with its local time 75583 being offset from UTC by offset." 75584 75585 ^ self class basicNew 75586 ticks: self ticks offset: anOffset asDuration; 75587 yourself 75588 ! ! 75589 75590!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:06'! 75591second 75592 75593 ^ (Duration seconds: seconds) seconds 75594! ! 75595 75596!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:06'! 75597timeZoneAbbreviation 75598 75599 ^ self class localTimeZone abbreviation 75600! ! 75601 75602!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:06'! 75603timeZoneName 75604 75605 ^ self class localTimeZone name 75606! ! 75607 75608!DateAndTime methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:06'! 75609year 75610 ^ self dayMonthYearDo: [:d :m :y | y ]! ! 75611 75612 75613!DateAndTime methodsFor: 'converting' stamp: 'pc 2/20/2009 15:35'! 75614asUnixTime 75615 ^ self asTimeStamp asSeconds - 2177452800! ! 75616 75617 75618!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 21:03'! 75619asSeconds 75620 "Return the number of seconds since the Squeak epoch" 75621 75622 ^ (self - (self class epoch)) asSeconds 75623 ! ! 75624 75625!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 17:53'! 75626day 75627 75628 ^ self dayOfYear! ! 75629 75630!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 07:48'! 75631daysInMonth 75632 "Answer the number of days in the month represented by the receiver." 75633 75634 75635 ^ self asMonth daysInMonth! ! 75636 75637!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 07:48'! 75638daysInYear 75639 75640 "Answer the number of days in the year represented by the receiver." 75641 75642 ^ self asYear daysInYear 75643 ! ! 75644 75645!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 15:44'! 75646daysLeftInYear 75647 "Answer the number of days in the year after the date of the receiver." 75648 75649 ^ self daysInYear - self dayOfYear 75650 ! ! 75651 75652!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 15:44'! 75653firstDayOfMonth 75654 75655 ^ self asMonth start day! ! 75656 75657!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 18:30'! 75658hours 75659 75660 ^ self hour! ! 75661 75662!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 1/7/2004 15:45'! 75663minutes 75664 75665 ^ self minute! ! 75666 75667!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 07:50'! 75668monthIndex 75669 75670 75671 ^ self month 75672 ! ! 75673 75674!DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 18:31'! 75675seconds 75676 75677 ^ self second! ! 75678 75679 75680!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:00'! 75681asDate 75682 75683 ^ Date starting: self! ! 75684 75685!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:00'! 75686asDateAndTime 75687 75688 ^ self 75689! ! 75690 75691!DateAndTime methodsFor: 'squeak protocol' stamp: 'gk 8/31/2006 00:55'! 75692asDuration 75693 "Answer the duration since midnight." 75694 75695 ^ Duration seconds: seconds nanoSeconds: nanos 75696! ! 75697 75698!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:01'! 75699asMonth 75700 75701 ^ Month starting: self 75702! ! 75703 75704!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:01'! 75705asNanoSeconds 75706 "Answer the number of nanoseconds since midnight" 75707 75708 ^ self asDuration asNanoSeconds 75709! ! 75710 75711!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:01'! 75712asTime 75713 75714 ^ Time seconds: seconds nanoSeconds: nanos! ! 75715 75716!DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 00:02'! 75717asTimeStamp 75718 75719 ^ self as: TimeStamp! ! 75720 75721!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:01'! 75722asWeek 75723 75724 ^ Week starting: self 75725! ! 75726 75727!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:01'! 75728asYear 75729 75730 ^ Year starting: self! ! 75731 75732!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:01'! 75733dayMonthYearDo: aBlock 75734 "Evaluation the block with three arguments: day month, year." 75735 75736 | l n i j dd mm yyyy | 75737 l := jdn + 68569. 75738 n := 4 * l // 146097. 75739 l := l - (146097 * n + 3 // 4). 75740 i := 4000 * (l + 1) // 1461001. 75741 l := l - (1461 * i // 4) + 31. 75742 j := 80 * l // 2447. 75743 dd := l - (2447 * j // 80). 75744 l := j // 11. 75745 mm := j + 2 - (12 * l). 75746 yyyy := 100 * (n - 49) + i + l. 75747 75748 ^ aBlock 75749 value: dd 75750 value: mm 75751 value: yyyy.! ! 75752 75753!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:01'! 75754duration 75755 75756 ^ Duration zero! ! 75757 75758!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:02'! 75759julianDayNumber 75760 75761 ^ jdn! ! 75762 75763!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:02'! 75764middleOf: aDuration 75765 "Return a Timespan where the receiver is the middle of the Duration" 75766 75767 | duration | 75768 duration := aDuration asDuration. 75769 ^ Timespan starting: (self - (duration / 2)) duration: duration. 75770 ! ! 75771 75772!DateAndTime methodsFor: 'squeak protocol' stamp: 'HenrikSperreJohansen 10/15/2009 14:42'! 75773midnight 75774 "Answer a DateAndTime starting at midnight local time" 75775 75776 ^self class basicNew 75777 setJdn: jdn 75778 seconds: 0 75779 nano: 0 75780 offset: self class localOffset! ! 75781 75782!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:02'! 75783nanoSecond 75784 75785 ^ nanos 75786! ! 75787 75788!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:02'! 75789noon 75790 "Answer a DateAndTime starting at noon" 75791 75792 ^ self dayMonthYearDo: 75793 [ :d :m :y | self class year: y month: m day: d hour: 12 minute: 0 second: 0 ]! ! 75794 75795!DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:03'! 75796printHMSOn: aStream 75797 "Print just hh:mm:ss" 75798 aStream 75799 nextPutAll: (self hour asString padded: #left to: 2 with: $0); 75800 nextPut: $:; 75801 nextPutAll: (self minute asString padded: #left to: 2 with: $0); 75802 nextPut: $:; 75803 nextPutAll: (self second asString padded: #left to: 2 with: $0). 75804! ! 75805 75806!DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:38'! 75807printOn: aStream 75808 "Print as per ISO 8601 sections 5.3.3 and 5.4.1. 75809 Prints either: 75810 'YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years)" 75811 75812 ^self printOn: aStream withLeadingSpace: false 75813! ! 75814 75815!DateAndTime methodsFor: 'squeak protocol' stamp: 'dtl 10/31/2004 01:20'! 75816printOn: aStream withLeadingSpace: printLeadingSpaceToo 75817 "Print as per ISO 8601 sections 5.3.3 and 5.4.1. 75818 If printLeadingSpaceToo is false, prints either: 75819 'YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years) 75820 If printLeadingSpaceToo is true, prints either: 75821 ' YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years) 75822 " 75823 75824 self printYMDOn: aStream withLeadingSpace: printLeadingSpaceToo. 75825 aStream nextPut: $T. 75826 self printHMSOn: aStream. 75827 self nanoSecond ~= 0 ifTrue: 75828 [ | z ps | 75829 ps := self nanoSecond printString padded: #left to: 9 with: $0. 75830 z := ps findLast: [ :c | c asciiValue > $0 asciiValue ]. 75831 (z > 0) ifTrue: [aStream nextPut: $.]. 75832 ps from: 1 to: z do: [ :c | aStream nextPut: c ] ]. 75833 aStream 75834 nextPut: (offset positive ifTrue: [$+] ifFalse: [$-]); 75835 nextPutAll: (offset hours abs asString padded: #left to: 2 with: $0); 75836 nextPut: $:; 75837 nextPutAll: (offset minutes abs asString padded: #left to: 2 with: $0). 75838 offset seconds = 0 ifFalse: 75839 [ aStream 75840 nextPut: $:; 75841 nextPutAll: (offset seconds abs truncated asString) ]. 75842! ! 75843 75844!DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:29'! 75845printYMDOn: aStream 75846 "Print just YYYY-MM-DD part. 75847 If the year is negative, prints out '-YYYY-MM-DD'." 75848 75849 ^self printYMDOn: aStream withLeadingSpace: false. 75850! ! 75851 75852!DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:29'! 75853printYMDOn: aStream withLeadingSpace: printLeadingSpaceToo 75854 "Print just the year, month, and day on aStream. 75855 75856 If printLeadingSpaceToo is true, then print as: 75857 ' YYYY-MM-DD' (if the year is positive) or '-YYYY-MM-DD' (if the year is negative) 75858 otherwise print as: 75859 'YYYY-MM-DD' or '-YYYY-MM-DD' " 75860 75861 | year month day | 75862 self dayMonthYearDo: [ :d :m :y | year := y. month := m. day := d ]. 75863 year negative 75864 ifTrue: [ aStream nextPut: $- ] 75865 ifFalse: [ printLeadingSpaceToo ifTrue: [ aStream space ]]. 75866 aStream 75867 nextPutAll: (year abs asString padded: #left to: 4 with: $0); 75868 nextPut: $-; 75869 nextPutAll: (month asString padded: #left to: 2 with: $0); 75870 nextPut: $-; 75871 nextPutAll: (day asString padded: #left to: 2 with: $0) 75872! ! 75873 75874!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:03'! 75875to: anEnd 75876 "Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan" 75877 75878 ^ Timespan starting: self ending: (anEnd asDateAndTime). 75879! ! 75880 75881!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:03'! 75882to: anEnd by: aDuration 75883 "Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan" 75884 75885 ^ (Schedule starting: self ending: (anEnd asDateAndTime)) 75886 schedule: (Array with: aDuration asDuration); 75887 yourself. 75888! ! 75889 75890!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:03'! 75891to: anEnd by: aDuration do: aBlock 75892 "Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan" 75893 75894 ^ (self to: anEnd by: aDuration) scheduleDo: aBlock 75895! ! 75896 75897!DateAndTime methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:03'! 75898utcOffset: anOffset 75899 "Answer a <DateAndTime> equivalent to the receiver but offset from UTC by anOffset" 75900 75901 | equiv | 75902 equiv := self + (anOffset asDuration - self offset). 75903 ^ equiv ticks: (equiv ticks) offset: anOffset asDuration; yourself 75904! ! 75905 75906 75907!DateAndTime methodsFor: 'private' stamp: 'brp 7/28/2004 16:22'! 75908hasEqualTicks: aDateAndTime 75909 75910 ^ (jdn = aDateAndTime julianDayNumber) 75911 and: [ (seconds = aDateAndTime secondsSinceMidnight) 75912 and: [ nanos = aDateAndTime nanoSecond ] ] 75913 75914! ! 75915 75916!DateAndTime methodsFor: 'private' stamp: 'gk 8/30/2006 22:59'! 75917normalize: i ticks: ticks base: base 75918 75919 | tick div quo rem | 75920 tick := ticks at: i. 75921 div := tick digitDiv: base neg: tick negative. 75922 quo := (div at: 1) normalize. 75923 rem := (div at: 2) normalize. 75924 rem < 0 ifTrue: [ quo := quo - 1. rem := base + rem ]. 75925 ticks at: (i-1) put: ((ticks at: i-1) + quo). 75926 ticks at: i put: rem 75927! ! 75928 75929!DateAndTime methodsFor: 'private' stamp: 'brp 7/28/2004 16:20'! 75930secondsSinceMidnight 75931 75932 ^ seconds! ! 75933 75934!DateAndTime methodsFor: 'private' stamp: 'HenrikSperreJohansen 10/15/2009 14:36'! 75935setJdn: julDays seconds: secs nano: nanoSecs offset: anOffset 75936 jdn := julDays. 75937 seconds := secs. 75938 nanos := nanoSecs. 75939 offset := anOffset.! ! 75940 75941!DateAndTime methodsFor: 'private' stamp: 'sd 3/16/2008 15:03'! 75942ticks 75943 "Private - answer an array with our instance variables. Assumed to be UTC " 75944 75945 ^ Array with: jdn with: seconds with: nanos.! ! 75946 75947!DateAndTime methodsFor: 'private' stamp: 'adrian_lienhard 1/7/2009 18:23'! 75948ticks: ticks offset: utcOffset 75949 "ticks is {julianDayNumber. secondCount. nanoSeconds}" 75950 75951 self normalize: 3 ticks: ticks base: NanosInSecond. 75952 self normalize: 2 ticks: ticks base: SecondsInDay. 75953 75954 jdn := ticks at: 1. 75955 seconds := ticks at: 2. 75956 nanos := ticks at: 3. 75957 offset := utcOffset! ! 75958 75959"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 75960 75961DateAndTime class 75962 instanceVariableNames: ''! 75963 75964!DateAndTime class methodsFor: 'ansi protocol' stamp: 'gk 8/31/2006 00:49'! 75965clockPrecision 75966 "One nanosecond precision" 75967 75968 ^ Duration seconds: 0 nanoSeconds: 1 75969! ! 75970 75971!DateAndTime class methodsFor: 'ansi protocol' stamp: 'gk 8/30/2006 23:01'! 75972now 75973 ^ self basicNew 75974 ticks: (Array with: SqueakEpoch with: Time totalSeconds with: 0) 75975 offset: self localTimeZone offset 75976! ! 75977 75978!DateAndTime class methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 14:59'! 75979year: year day: dayOfYear hour: hour minute: minute second: second 75980 75981 ^ self 75982 year: year 75983 day: dayOfYear 75984 hour: hour 75985 minute: minute 75986 second: second 75987 offset: self localOffset. 75988! ! 75989 75990!DateAndTime class methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 14:59'! 75991year: year day: dayOfYear hour: hour minute: minute second: second offset: offset 75992 "Return a DataAndTime" 75993 75994 | y d | 75995 y := self 75996 year: year 75997 month: 1 75998 day: 1 75999 hour: hour 76000 minute: minute 76001 second: second 76002 nanoSecond: 0 76003 offset: offset. 76004 d := Duration days: (dayOfYear - 1). 76005 ^ y + d! ! 76006 76007!DateAndTime class methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 14:59'! 76008year: year month: month day: day hour: hour minute: minute second: second 76009 "Return a DateAndTime" 76010 76011 ^ self 76012 year: year 76013 month: month 76014 day: day 76015 hour: hour 76016 minute: minute 76017 second: second 76018 offset: self localOffset 76019! ! 76020 76021!DateAndTime class methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:00'! 76022year: year month: month day: day hour: hour minute: minute second: second offset: offset 76023 76024 ^ self 76025 year: year 76026 month: month 76027 day: day 76028 hour: hour 76029 minute: minute 76030 second: second 76031 nanoSecond: 0 76032 offset: offset 76033! ! 76034 76035 76036!DateAndTime class methodsFor: 'creation' stamp: 'pc 2/20/2009 15:34'! 76037fromUnixTime: anInteger 76038 ^ self fromSeconds: anInteger + 76039 2177452800 "unix epoch constant"! ! 76040 76041 76042!DateAndTime class methodsFor: 'smalltalk-80' stamp: 'dtl 6/21/2009 23:37'! 76043fromSeconds: seconds 76044 "Answer a DateAndTime since the Squeak epoch: 1 January 1901" 76045 76046 | integerSeconds nanos | 76047 integerSeconds := seconds truncated. 76048 integerSeconds = seconds 76049 ifTrue: [nanos := 0] 76050 ifFalse: [nanos := (seconds - integerSeconds * NanosInSecond) asInteger]. 76051 ^ self basicNew 76052 ticks: (Array 76053 with: SqueakEpoch 76054 with: integerSeconds 76055 with: nanos) 76056 offset: self localOffset! ! 76057 76058!DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:00'! 76059millisecondClockValue 76060 76061 ^ Time millisecondClockValue! ! 76062 76063!DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:01'! 76064totalSeconds 76065 76066 ^ Time totalSeconds! ! 76067 76068 76069!DateAndTime class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:07'! 76070current 76071 76072 ^ self now 76073! ! 76074 76075!DateAndTime class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:07'! 76076date: aDate time: aTime 76077 76078 ^ self 76079 year: aDate year 76080 day: aDate dayOfYear 76081 hour: aTime hour 76082 minute: aTime minute 76083 second: aTime second 76084! ! 76085 76086!DateAndTime class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:07'! 76087epoch 76088 "Answer a DateAndTime representing the Squeak epoch: 1 January 1901" 76089 76090 ^ self julianDayNumber: SqueakEpoch 76091 ! ! 76092 76093!DateAndTime class methodsFor: 'squeak protocol' stamp: 'damiencassou 5/30/2008 10:56'! 76094fromString: aString 76095 ^ self readFrom: aString readStream! ! 76096 76097!DateAndTime class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:07'! 76098julianDayNumber: aJulianDayNumber 76099 76100 ^ self basicNew 76101 ticks: aJulianDayNumber days ticks offset: self localOffset; 76102 yourself! ! 76103 76104!DateAndTime class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:07'! 76105localOffset 76106 "Answer the duration we are offset from UTC" 76107 76108 ^ self localTimeZone offset 76109! ! 76110 76111!DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 9/4/2003 06:39'! 76112localTimeZone 76113 "Answer the local time zone" 76114 76115 ^ LocalTimeZone ifNil: [ LocalTimeZone := TimeZone default ] 76116 76117! ! 76118 76119!DateAndTime class methodsFor: 'squeak protocol' stamp: 'nk 3/30/2004 09:53'! 76120localTimeZone: aTimeZone 76121 "Set the local time zone" 76122 76123 " 76124 DateAndTime localTimeZone: (TimeZone offset: 0 hours name: 'Universal Time' abbreviation: 'UTC'). 76125 DateAndTime localTimeZone: (TimeZone offset: -8 hours name: 'Pacific Standard Time' abbreviation: 'PST'). 76126 " 76127 76128 LocalTimeZone := aTimeZone 76129 76130 76131! ! 76132 76133!DateAndTime class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:07'! 76134midnight 76135 76136 ^ self now midnight 76137! ! 76138 76139!DateAndTime class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:07'! 76140new 76141 "Answer a DateAndTime representing the Squeak epoch: 1 January 1901" 76142 76143 ^ self epoch 76144 ! ! 76145 76146!DateAndTime class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:08'! 76147noon 76148 76149 ^ self now noon! ! 76150 76151!DateAndTime class methodsFor: 'squeak protocol' stamp: 'PeterHugossonMiller 9/3/2009 01:10'! 76152readFrom: aStream 76153 | bc year month day hour minute second nanos offset buffer ch | 76154 76155 76156 aStream peek = $- ifTrue: [ aStream next. bc := -1] ifFalse: [bc := 1]. 76157 year := (aStream upTo: $-) asInteger * bc. 76158 month := (aStream upTo: $-) asInteger ifNil: [1]. 76159 day := (aStream upTo: $T) asInteger ifNil: [1]. 76160 hour := (aStream upTo: $:) asInteger ifNil: [0]. 76161 buffer := '00:' copy. ch := nil. 76162 minute := buffer writeStream. 76163 [ aStream atEnd | (ch = $:) | (ch = $+) | (ch = $-) ] 76164 whileFalse: [ ch := minute nextPut: aStream next. ]. 76165 (ch isNil or: [ch isDigit]) ifTrue: [ ch := $: ]. 76166 minute := (buffer readStream upTo: ch) asInteger. 76167 buffer := '00.' copy. 76168 second := buffer writeStream. 76169 [ aStream atEnd | (ch = $.) | (ch = $+) | (ch = $-) ] 76170 whileFalse: [ ch := second nextPut: aStream next. ]. 76171 (ch isNil or: [ch isDigit]) ifTrue: [ ch := $. ]. 76172 second := (buffer readStream upTo: ch) asInteger. 76173 buffer := '000000000' copy. 76174 (ch = $.) ifTrue: [ 76175 nanos := buffer writeStream. 76176 [ aStream atEnd | ((ch := aStream next) = $+) | (ch = $-) ] 76177 whileFalse: [ nanos nextPut: ch. ]. 76178 (ch isNil or: [ch isDigit]) ifTrue: [ ch := $+ ]. 76179 ]. 76180 76181 nanos := buffer asInteger. 76182 aStream atEnd 76183 ifTrue: [ offset := self localOffset ] 76184 76185 ifFalse: 76186 [offset := Duration fromString: (ch asString, '0:', aStream upToEnd). 76187 76188 (offset = self localOffset) ifTrue: [ offset := self localOffset ]]. 76189 ^ self 76190 year: year 76191 month: month 76192 day: day 76193 hour: hour 76194 minute: minute 76195 76196 second: second 76197 nanoSecond: nanos 76198 76199 offset: offset. 76200 76201 76202 " '-1199-01-05T20:33:14.321-05:00' asDateAndTime 76203 ' 2002-05-16T17:20:45.1+01:01' asDateAndTime 76204 76205 ' 2002-05-16T17:20:45.02+01:01' asDateAndTime 76206 76207 ' 2002-05-16T17:20:45.003+01:01' asDateAndTime 76208 76209 ' 2002-05-16T17:20:45.0004+01:01' asDateAndTime 76210 ' 2002-05-16T17:20:45.00005' asDateAndTime 76211 ' 2002-05-16T17:20:45.000006+01:01' asDateAndTime 76212 76213 ' 2002-05-16T17:20:45.0000007+01:01' asDateAndTime 76214 ' 2002-05-16T17:20:45.00000008-01:01' asDateAndTime 76215 ' 2002-05-16T17:20:45.000000009+01:01' asDateAndTime 76216 ' 2002-05-16T17:20:45.0000000001+01:01' asDateAndTime 76217 76218 ' 2002-05-16T17:20' asDateAndTime 76219 ' 2002-05-16T17:20:45' asDateAndTime 76220 ' 2002-05-16T17:20:45+01:57' asDateAndTime 76221 ' 2002-05-16T17:20:45-02:34' asDateAndTime 76222 ' 2002-05-16T17:20:45+00:00' asDateAndTime 76223 ' 1997-04-26T01:02:03+01:02:3' asDateAndTime 76224 " 76225! ! 76226 76227!DateAndTime class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:08'! 76228today 76229 76230 ^ self midnight 76231! ! 76232 76233!DateAndTime class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:08'! 76234tomorrow 76235 76236 ^ self today asDate next asDateAndTime! ! 76237 76238!DateAndTime class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:08'! 76239year: year day: dayOfYear 76240 "Return a DateAndTime" 76241 76242 ^ self 76243 year: year 76244 day: dayOfYear 76245 hour: 0 76246 minute: 0 76247 second: 0! ! 76248 76249!DateAndTime class methodsFor: 'squeak protocol' stamp: 'HenrikSperreJohansen 10/15/2009 14:44'! 76250year: year month: month day: day 76251 "Return a DateAndTime, midnight local time" 76252 ^ self 76253 year: year 76254 month: month 76255 day: day 76256 hour: 0 76257 minute: 0! ! 76258 76259!DateAndTime class methodsFor: 'squeak protocol' stamp: 'HenrikSperreJohansen 10/15/2009 14:44'! 76260year: year month: month day: day hour: hour minute: minute 76261 "Return a DateAndTime" 76262 76263 ^ self 76264 year: year 76265 month: month 76266 day: day 76267 hour: hour 76268 minute: minute 76269 second: 0! ! 76270 76271!DateAndTime class methodsFor: 'squeak protocol' stamp: 'HenrikSperreJohansen 10/15/2009 14:42'! 76272year: year month: month day: day hour: hour minute: minute second: second nanoSecond: nanoCount offset: offset 76273 "Return a DateAndTime" 76274 76275 | monthIndex daysInMonth p q r s julianDayNumber | 76276 76277 monthIndex := month isInteger ifTrue: [month] ifFalse: [Month indexOfMonth: month]. 76278 daysInMonth := Month 76279 daysInMonth: monthIndex 76280 forYear: year. 76281 day < 1 ifTrue: [self error: 'day may not be zero or negative']. 76282 day > daysInMonth ifTrue: [self error: 'day is after month ends']. 76283 76284 p := (monthIndex - 14) quo: 12. 76285 q := year + 4800 + p. 76286 r := monthIndex - 2 - (12 * p). 76287 s := (year + 4900 + p) quo: 100. 76288 76289 julianDayNumber := 76290 ((1461 * q) quo: 4) + 76291 ((367 * r) quo: 12) - 76292 ((3 * s) quo: 4) + 76293 (day - 32075). 76294 76295 ^self basicNew 76296 setJdn: julianDayNumber 76297 seconds: hour * 60 + minute * 60 + second 76298 nano: nanoCount 76299 offset: offset; 76300 yourself! ! 76301 76302!DateAndTime class methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 15:09'! 76303yesterday 76304 76305 ^ self today asDate previous asDateAndTime 76306! ! 76307TestCase subclass: #DateAndTimeEpochTest 76308 instanceVariableNames: 'aDateAndTime aDuration aTimeZone localTimeZoneToRestore' 76309 classVariableNames: '' 76310 poolDictionaries: '' 76311 category: 'KernelTests-Chronology'! 76312!DateAndTimeEpochTest commentStamp: 'tlk 1/6/2004 18:27' prior: 0! 76313I represent one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. The other Chronology sunit test cases are: 76314 DateTestCase 76315 DateAndTimeLeapTestCase, 76316 DurationTestCase, 76317 ScheduleTestCase 76318 TimeStampTestCase 76319 TimespanDoTestCase, 76320 TimespanDoSpanAYearTestCase, 76321 TimespanTestCase, 76322 YearMonthWeekTestCase. 76323These tests attempt to exercise all public and private methods. Except, they do not explicitly depreciated methods. tlk 76324My fixtures are: 76325aDateAndTime = January 01, 1901 midnight (the start of the Squeak epoch) with localTimeZone = Grenwhich Meridian (local offset = 0 hours) 76326aDuration = 1 day, 2 hours, 3, minutes, 4 seconds and 5 nano seconds. 76327aTimeZone = 'Epoch Test Time Zone', 'ETZ' , offset: 12 hours, 15 minutes. ! 76328 76329 76330!DateAndTimeEpochTest methodsFor: 'running' stamp: 'tlk 1/2/2004 10:58'! 76331setUp 76332 localTimeZoneToRestore := DateAndTime localTimeZone. 76333 aDateAndTime := DateAndTime localTimeZone: TimeZone default; epoch. 76334 aTimeZone := TimeZone offset: (Duration minutes: 135) name: 'Epoch Test Time Zone' abbreviation: 'ETZ'. 76335 aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5 ! ! 76336 76337!DateAndTimeEpochTest methodsFor: 'running' stamp: 'tlk 1/2/2004 11:04'! 76338tearDown 76339 DateAndTime localTimeZone: localTimeZoneToRestore. 76340 "wish I could remove the time zones I added earlier, tut there is no method for that" 76341! ! 76342 76343 76344!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:01'! 76345testAsDate 76346 self assert: aDateAndTime asDate = 'January 1, 1901' asDate. 76347 76348! ! 76349 76350!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:31'! 76351testAsDateAndTime 76352 self assert: aDateAndTime asDateAndTime = aDateAndTime 76353 76354! ! 76355 76356!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:34'! 76357testAsDuration 76358 self assert: aDateAndTime asDuration = 0 asDuration 76359 76360! ! 76361 76362!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:06'! 76363testAsLocal 76364 self assert: aDateAndTime asLocal = aDateAndTime. 76365 self assert: aDateAndTime asLocal = (aDateAndTime utcOffset: aDateAndTime class localOffset) 76366 76367! ! 76368 76369!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:27'! 76370testAsMonth 76371 self assert: aDateAndTime asMonth = (Month month: 'January' year: 1901). 76372! ! 76373 76374!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:59'! 76375testAsNanoSeconds 76376 self assert: aDateAndTime asNanoSeconds = 0 asDuration asNanoSeconds 76377 76378! ! 76379 76380!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 14:01'! 76381testAsSeconds 76382 self assert: aDateAndTime asSeconds = 0 asDuration asSeconds 76383 76384! ! 76385 76386!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:32'! 76387testAsTime 76388 self assert: aDateAndTime asTime = Time midnight. 76389! ! 76390 76391!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 14:51'! 76392testAsTimeStamp 76393 self assert: aDateAndTime asTimeStamp = TimeStamp new. 76394! ! 76395 76396!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:07'! 76397testAsUTC 76398 self assert: aDateAndTime asUTC = aDateAndTime 76399 ! ! 76400 76401!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:43'! 76402testAsWeek 76403 self assert: aDateAndTime asWeek = (Week starting: '12-31-1900' asDate). 76404 76405! ! 76406 76407!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:43'! 76408testAsYear 76409 self assert: aDateAndTime asYear = (Year starting: '01-01-1901' asDate). 76410! ! 76411 76412!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:28'! 76413testCurrent 76414 self deny: aDateAndTime = (DateAndTime current). 76415! ! 76416 76417!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:46'! 76418testDateTime 76419 self assert: aDateAndTime = (DateAndTime date: '01-01-1901' asDate time: '00:00:00' asTime) 76420! ! 76421 76422!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:01'! 76423testDay 76424 self assert: aDateAndTime day = DateAndTime new day 76425! ! 76426 76427!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:08'! 76428testDayMonthYearDo 76429 |iterations| 76430 iterations := 0. 76431 self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | iterations := iterations + 1]) = 1. 76432 self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachYear]) = 1901. 76433 self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachMonth]) = 1. 76434 self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachDay]) = 1. 76435! ! 76436 76437!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 15:45'! 76438testDayOfMonth 76439 self assert: aDateAndTime dayOfMonth = 1. 76440! ! 76441 76442!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:47'! 76443testDayOfWeek 76444 self assert: aDateAndTime dayOfWeek = 3. 76445 self assert: aDateAndTime dayOfWeekAbbreviation = 'Tue'. 76446 self assert: aDateAndTime dayOfWeekName = 'Tuesday'. 76447! ! 76448 76449!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:01'! 76450testDayOfYear 76451 self assert: aDateAndTime dayOfYear = 1. 76452 76453! ! 76454 76455!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! 76456testDaysInMonth 76457 self assert: aDateAndTime daysInMonth = 31. 76458 76459! ! 76460 76461!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! 76462testDaysInYear 76463 self assert: aDateAndTime daysInYear = 365. 76464 76465! ! 76466 76467!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! 76468testDaysLeftInYear 76469 self assert: aDateAndTime daysLeftInYear = 364. 76470 76471! ! 76472 76473!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 16:24'! 76474testDuration 76475 self assert: aDateAndTime duration = 0 asDuration. 76476 76477! ! 76478 76479!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:25'! 76480testEpoch 76481 self assert: aDateAndTime = '1901-01-01T00:00:00+00:00'. 76482! ! 76483 76484!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:44'! 76485testFirstDayOfMonth 76486 self assert: aDateAndTime firstDayOfMonth = 1 76487! ! 76488 76489!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:25'! 76490testFromSeconds 76491 self assert: aDateAndTime = (DateAndTime fromSeconds: 0). 76492! ! 76493 76494!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:26'! 76495testFromString 76496 self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00:00+00:00'). 76497 self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00:00'). 76498 self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00'). 76499 self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00:00+00:00'). 76500! ! 76501 76502!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'al 6/12/2008 21:56'! 76503testHash 76504 self assert: aDateAndTime hash = DateAndTime new hash! ! 76505 76506!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 16:59'! 76507testHour 76508 self assert: aDateAndTime hour = aDateAndTime hour24. 76509 self assert: aDateAndTime hour = 0. 76510 self assert: aDateAndTime hour = aDateAndTime hours 76511! ! 76512 76513!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 3/12/2004 15:21'! 76514testHour12 76515 self assert: aDateAndTime hour12 = DateAndTime new hour12. 76516 self assert: aDateAndTime hour12 = 12 76517! ! 76518 76519!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! 76520testIsLeapYear 76521 self deny: aDateAndTime isLeapYear 76522! ! 76523 76524!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 17:18'! 76525testJulianDayNumber 76526 self assert: aDateAndTime = (DateAndTime julianDayNumber: 2415386). 76527 self assert: aDateAndTime julianDayNumber = 2415386.! ! 76528 76529!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:20'! 76530testLessThan 76531 self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). 76532 self assert: aDateAndTime + -1 < aDateAndTime. 76533 ! ! 76534 76535!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:40'! 76536testMeridianAbbreviation 76537 self assert: aDateAndTime meridianAbbreviation = 'AM'. 76538 76539 ! ! 76540 76541!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:37'! 76542testMiddleOf 76543 self assert: (aDateAndTime middleOf: '2:00:00:00' asDuration) = 76544 (Timespan starting: '12-31-1900' asDate duration: 2 days). 76545 76546! ! 76547 76548!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 17:39'! 76549testMidnight 76550 self assert: aDateAndTime midnight = aDateAndTime 76551! ! 76552 76553!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:03'! 76554testMinus 76555 self assert: aDateAndTime - aDateAndTime = '0:00:00:00' asDuration. 76556 self assert: aDateAndTime - '0:00:00:00' asDuration = aDateAndTime. 76557 self assert: aDateAndTime - aDuration = (DateAndTime year: 1900 month: 12 day: 30 hour: 21 minute: 56 second: 55 nanoSecond: 999999995 offset: 0 hours ). 76558 " I believe this Failure is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! 76559 76560!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:35'! 76561testMinute 76562 self assert: aDateAndTime minute = 0 76563 76564! ! 76565 76566!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:41'! 76567testMinutes 76568 self assert: aDateAndTime minutes = 0 76569! ! 76570 76571!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:46'! 76572testMonth 76573 self assert: aDateAndTime month = 1. 76574 self assert: aDateAndTime monthAbbreviation = 'Jan'. 76575 self assert: aDateAndTime monthName = 'January'. 76576 self assert: aDateAndTime monthIndex = 1.! ! 76577 76578!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:47'! 76579testNanoSecond 76580 self assert: aDateAndTime nanoSecond = 0 76581 76582! ! 76583 76584!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:27'! 76585testNew 76586 self assert: aDateAndTime = (DateAndTime new). 76587! ! 76588 76589!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:49'! 76590testNoon 76591 self assert: aDateAndTime noon = '1901-01-01T12:00:00+00:00'. 76592! ! 76593 76594!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:28'! 76595testNow 76596 self deny: aDateAndTime = (DateAndTime now). 76597! ! 76598 76599!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:41'! 76600testOffset 76601 self assert: aDateAndTime offset = '0:00:00:00' asDuration. 76602 self assert: (aDateAndTime offset: '0:12:00:00') = '1901-01-01T00:00:00+12:00'. 76603! ! 76604 76605!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 11:03'! 76606testPlus 76607 self assert: aDateAndTime + '0:00:00:00' = aDateAndTime. 76608 self assert: aDateAndTime + 0 = aDateAndTime. 76609 self assert: aDateAndTime + aDuration = (DateAndTime year: 1901 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours ) 76610 " I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" 76611 76612! ! 76613 76614!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 76615testPrintOn 76616 | cs rw | 76617 cs := '1901-01-01T00:00:00+00:00' readStream. 76618 rw := ReadWriteStream on: ''. 76619 aDateAndTime printOn: rw. 76620 self assert: rw contents = cs contents. 76621 cs := 'a TimeZone(ETZ)' readStream. 76622 rw := ReadWriteStream on: ''. 76623 aTimeZone printOn: rw. 76624 self assert: rw contents = cs contents! ! 76625 76626!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:22'! 76627testSecond 76628 self assert: aDateAndTime second = 0 76629 76630! ! 76631 76632!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:22'! 76633testSeconds 76634 self assert: aDateAndTime seconds = 0 76635 76636! ! 76637 76638!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:25'! 76639testTicks 76640 self assert: aDateAndTime ticks = (DateAndTime julianDayNumber: 2415386) ticks. 76641 self assert: aDateAndTime ticks = #(2415386 0 0)! ! 76642 76643!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:31'! 76644testTicksOffset 76645 self assert: aDateAndTime = (aDateAndTime ticks: #(2415386 0 0) offset: DateAndTime localOffset). 76646! ! 76647 76648!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:42'! 76649testTo 76650 self assert: (aDateAndTime to: aDateAndTime) = (DateAndTime new to: DateAndTime new) 76651 "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! 76652 76653!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:43'! 76654testToBy 76655 self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days) = 76656 (DateAndTime new to: DateAndTime new + 10 days by: 5 days ) 76657 "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! 76658 76659!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:53'! 76660testToByDo 76661 "self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days do: []) = " 76662 "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! 76663 76664!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 17:35'! 76665testToday 76666 self deny: aDateAndTime = (DateAndTime today). 76667! ! 76668 76669!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:45'! 76670testTommorrow 76671 self assert: (DateAndTime today + 24 hours) = (DateAndTime tomorrow). 76672 self deny: aDateAndTime = (DateAndTime tomorrow). 76673 "MessageNotUnderstood: Date class>>starting:"! ! 76674 76675!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:58'! 76676testUtcOffset 76677 self assert: (aDateAndTime utcOffset: '0:12:00:00') = '1901-01-01T12:00:00+12:00'. 76678! ! 76679 76680!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 21:00'! 76681testYear 76682 self assert: aDateAndTime year = 1901. 76683 76684 ! ! 76685 76686!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:30'! 76687testYearDay 76688 self assert: aDateAndTime = (DateAndTime year: 1901 day: 1). 76689! ! 76690 76691!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'! 76692testYearDayHourMinuteSecond 76693 self assert: aDateAndTime = (DateAndTime year: 1901 day: 1 hour: 0 minute: 0 second: 0). 76694! ! 76695 76696!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'! 76697testYearMonthDay 76698 self assert: aDateAndTime = (DateAndTime year: 1901 month: 1 day: 1). 76699! ! 76700 76701!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'! 76702testYearMonthDayHourMinuteSecond 76703 self assert: aDateAndTime = (DateAndTime year: 1901 month: 1 day: 1 hour: 0 minute: 0 second: 0). 76704! ! 76705 76706!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:23'! 76707testYearMonthDayHourMinuteSecondNanosSecondOffset 76708 self assert: aDateAndTime = (DateAndTime year: 1901 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset:0 hours ). 76709 self assert: ((DateAndTime year: 1 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset: 0 hours ) + 76710 (Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5) ) = 76711 (DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours ) 76712 " I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)"" I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" 76713! ! 76714 76715!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:47'! 76716testYesterday 76717 self deny: aDateAndTime = (DateAndTime yesterday). 76718! ! 76719 76720!DateAndTimeEpochTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:26'! 76721testtimeZone 76722 self assert: aDateAndTime timeZoneName = 'Universal Time'. 76723 self assert: aDateAndTime timeZoneAbbreviation = 'UTC' 76724 76725! ! 76726TestCase subclass: #DateAndTimeLeapTest 76727 instanceVariableNames: 'aDateAndTime aDuration aTimeZone localTimeZoneToRestore' 76728 classVariableNames: '' 76729 poolDictionaries: '' 76730 category: 'KernelTests-Chronology'! 76731!DateAndTimeLeapTest commentStamp: 'tlk 1/6/2004 17:54' prior: 0! 76732I represent one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. tlk. 76733My fixtures are: 76734aDateAndTime = February 29, 2004 1:33 PM with offset: 2 hours 76735aDuration = 15 days, 14 hours, 13 minutes, 12 seconds and 11 nano seconds. 76736aTimeZone = Grenwhich Meridian (local offset = 0 hours) ! 76737 76738 76739!DateAndTimeLeapTest methodsFor: 'running' stamp: 'nk 3/12/2004 11:00'! 76740setUp 76741 localTimeZoneToRestore := DateAndTime localTimeZone. 76742 DateAndTime localTimeZone: TimeZone default. 76743 aDateAndTime := (DateAndTime year: 2004 month: 2 day: 29 hour: 13 minute: 33 second: 0 offset: 2 hours). 76744 aTimeZone := TimeZone default. 76745 aDuration := Duration days: 0 hours: 13 minutes: 33 seconds: 0 nanoSeconds: 0 76746! ! 76747 76748!DateAndTimeLeapTest methodsFor: 'running' stamp: 'tlk 1/2/2004 21:30'! 76749tearDown 76750 DateAndTime localTimeZone: localTimeZoneToRestore. 76751 "wish I could remove the time zones I added earlier, tut there is no method for that" 76752! ! 76753 76754 76755!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:00'! 76756testAsDate 76757 self assert: aDateAndTime asDate = 'February 29, 2004' asDate. 76758 76759! ! 76760 76761!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:55'! 76762testAsDuration 76763 self assert: aDateAndTime asDuration = aDuration 76764 76765! ! 76766 76767!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:00'! 76768testAsLocal 76769 self assert: aDateAndTime asLocal = aDateAndTime. 76770 self assert: aDateAndTime asLocal = (aDateAndTime utcOffset: aDateAndTime class localOffset) 76771 76772 76773! ! 76774 76775!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:24'! 76776testAsMonth 76777 self assert: aDateAndTime asMonth = (Month month: 'February' year: 2004). 76778! ! 76779 76780!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:59'! 76781testAsNanoSeconds 76782 self assert: aDateAndTime asNanoSeconds = aDuration asNanoSeconds. 76783 self assert: aDateAndTime asNanoSeconds = 48780000000000 76784 76785! ! 76786 76787!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 22:05'! 76788testAsSeconds 76789 self assert: aDuration asSeconds = 48780. 76790 self assert: aDateAndTime asSeconds = 3255507180 76791 76792! ! 76793 76794!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:26'! 76795testAsTime 76796 self assert: aDateAndTime asTime = (Time hour: 13 minute: 33 second: 0) 76797! ! 76798 76799!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:31'! 76800testAsTimeStamp 76801 self assert: aDateAndTime asTimeStamp = ((TimeStamp readFrom: '2-29-2004 1:33 pm' readStream) offset: 2 hours). 76802 76803! ! 76804 76805!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:59'! 76806testAsUTC 76807 self assert: aDateAndTime asUTC = aDateAndTime 76808 76809 ! ! 76810 76811!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:30'! 76812testAsWeek 76813 self assert: aDateAndTime asWeek = (Week starting: '02-29-2004' asDate). 76814! ! 76815 76816!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:36'! 76817testAsYear 76818 self assert: aDateAndTime asYear = (Year starting: '02-29-2004' asDate). 76819 self deny: aDateAndTime asYear = (Year starting: '01-01-2004' asDate) 76820! ! 76821 76822!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:23'! 76823testDay 76824 self assert: aDateAndTime day = 60. 76825 self deny: aDateAndTime day = 29 ! ! 76826 76827!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 22:16'! 76828testDayMonthYearDo 76829 self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachYear]) = 2004. 76830 self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachMonth]) = 2. 76831 self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachDay]) = 29. 76832! ! 76833 76834!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 22:17'! 76835testDayOfMonth 76836 self assert: aDateAndTime dayOfMonth = 29. 76837! ! 76838 76839!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:34'! 76840testDayOfWeek 76841 self assert: aDateAndTime dayOfWeek = 1. 76842 self assert: aDateAndTime dayOfWeekAbbreviation = 'Sun'. 76843 self assert: aDateAndTime dayOfWeekName = 'Sunday'. 76844! ! 76845 76846!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:59'! 76847testDayOfYear 76848 self assert: aDateAndTime dayOfYear = 60. 76849 76850! ! 76851 76852!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! 76853testDaysInMonth 76854 self assert: aDateAndTime daysInMonth = 29. 76855 76856! ! 76857 76858!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! 76859testDaysInYear 76860 self assert: aDateAndTime daysInYear = 366. 76861 76862! ! 76863 76864!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! 76865testDaysLeftInYear 76866 self assert: aDateAndTime daysLeftInYear = 306. 76867 76868! ! 76869 76870!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:38'! 76871testFirstDayOfMonth 76872 self deny: aDateAndTime firstDayOfMonth = 1. 76873 self assert: aDateAndTime firstDayOfMonth = 32 76874! ! 76875 76876!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 10:43'! 76877testFromString 76878 self assert: aDateAndTime = (DateAndTime fromString: ' 2004-02-29T13:33:00+02:00'). 76879 76880! ! 76881 76882!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 10:48'! 76883testHour 76884 self assert: aDateAndTime hour = aDateAndTime hour24. 76885 self assert: aDateAndTime hour = 13. 76886 self assert: aDateAndTime hour = aDateAndTime hours 76887! ! 76888 76889!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'brp 3/12/2004 15:19'! 76890testHour12 76891 self assert: aDateAndTime hour12 = 1. 76892! ! 76893 76894!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:35'! 76895testIsLeapYear 76896 self assert: aDateAndTime isLeapYear 76897! ! 76898 76899!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! 76900testLessThan 76901 self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). 76902 self assert: aDateAndTime + -1 < aDateAndTime. 76903 ! ! 76904 76905!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:42'! 76906testMeridianAbbreviation 76907 self assert: aDateAndTime meridianAbbreviation = 'PM'. 76908 76909 ! ! 76910 76911!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:12'! 76912testMiddleOf 76913 self assert: (aDateAndTime middleOf: aDuration) = 76914 (Timespan starting: (DateAndTime year: 2004 month: 2 day: 29 hour: 6 minute: 46 second: 30 offset: 2 hours) 76915 duration: (Duration days: 0 hours: 13 minutes: 33 seconds: 0 nanoSeconds: 0 )) 76916 ! ! 76917 76918!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:57'! 76919testMidnight 76920 self assert: aDateAndTime midnight = '2004-02-29T00:00:00+00:00'. 76921 self deny: aDateAndTime midnight = '2004-02-29T00:00:00+02:00' 76922! ! 76923 76924!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:00'! 76925testMinute 76926 self assert: aDateAndTime minute = 33 76927 76928! ! 76929 76930!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:44'! 76931testMinutes 76932 self assert: aDateAndTime minutes = 33 76933! ! 76934 76935!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:02'! 76936testMonth 76937 self assert: aDateAndTime month = 2. 76938 self assert: aDateAndTime monthAbbreviation = 'Feb'. 76939 self assert: aDateAndTime monthName = 'February'. 76940 self assert: aDateAndTime monthIndex = 2.! ! 76941 76942!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! 76943testNanoSecond 76944 self assert: aDateAndTime nanoSecond = 0 76945 76946! ! 76947 76948!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:03'! 76949testNoon 76950 self assert: aDateAndTime noon = '2004-02-29T12:00:00+00:00'. 76951! ! 76952 76953!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:07'! 76954testOffset 76955 self assert: aDateAndTime offset = '0:02:00:00' asDuration. 76956 self assert: (aDateAndTime offset: '0:12:00:00') = '2004-02-29T13:33:00+12:00'. 76957! ! 76958 76959!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 76960testPrintOn 76961 | cs rw | 76962 cs := '2004-02-29T13:33:00+02:00' readStream. 76963 rw := ReadWriteStream on: ''. 76964 aDateAndTime printOn: rw. 76965 self assert: rw contents = cs contents. 76966 cs := 'a TimeZone(UTC)' readStream. 76967 rw := ReadWriteStream on: ''. 76968 aTimeZone printOn: rw. 76969 self assert: rw contents = cs contents! ! 76970 76971!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! 76972testSecond 76973 self assert: aDateAndTime second = 0 76974 76975! ! 76976 76977!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! 76978testSeconds 76979 self assert: aDateAndTime seconds = 0 76980 76981! ! 76982 76983!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:12'! 76984testTicks 76985 self assert: aDateAndTime ticks = ((DateAndTime julianDayNumber: 2453065) + 48780 seconds) ticks. 76986 self assert: aDateAndTime ticks = #(2453065 48780 0)! ! 76987 76988!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:52'! 76989testTicksOffset 76990 self assert: aDateAndTime = (aDateAndTime ticks: #(2453065 48780 0) offset: DateAndTime localOffset). 76991 76992! ! 76993 76994!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:51'! 76995testUtcOffset 76996 self assert: (aDateAndTime utcOffset: '0:02:00:00') = '2004-02-29T13:33:00+02:00'. 76997 76998! ! 76999 77000!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:17'! 77001testYear 77002 self assert: aDateAndTime year = 2004. 77003 77004 ! ! 77005 77006!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:21'! 77007testYearDayHourMinuteSecond 77008 self assert: aDateAndTime = ((DateAndTime year: 2004 day: 60 hour: 13 minute: 33 second: 0) offset: 2 hours). 77009! ! 77010 77011!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:23'! 77012testYearMonthDayHourMinuteSecond 77013 self assert: aDateAndTime = ((DateAndTime year: 2004 month: 2 day: 29 hour: 13 minute: 33 second: 0) offset: 2 hours). 77014! ! 77015 77016!DateAndTimeLeapTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:26'! 77017testtimeZone 77018 self assert: aDateAndTime timeZoneName = 'Universal Time'. 77019 self assert: aDateAndTime timeZoneAbbreviation = 'UTC' 77020 77021! ! 77022ClassTestCase subclass: #DateAndTimeTest 77023 instanceVariableNames: '' 77024 classVariableNames: '' 77025 poolDictionaries: '' 77026 category: 'KernelTests-Chronology'! 77027 77028!DateAndTimeTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 09:25'! 77029classToBeTested 77030 77031 ^ DateAndTime 77032 77033! ! 77034 77035!DateAndTimeTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 09:25'! 77036selectorsToBeIgnored 77037 77038 | private | 77039 private := #( #printOn: ). 77040 77041 ^ super selectorsToBeIgnored, private 77042! ! 77043 77044 77045!DateAndTimeTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 17:00'! 77046testArithmeticAcrossDateBoundary 77047 77048 | t1 t2 | 77049 t1 := '2004-01-07T11:55:00+00:00' asDateAndTime. 77050 t2 := t1 - ( (42900+1) seconds). 77051 77052 self 77053 assert: t2 = ('2004-01-06T23:59:59+00:00' asDateAndTime) 77054 77055! ! 77056 77057!DateAndTimeTest methodsFor: 'Tests' stamp: 'dtl 11/7/2004 13:00'! 77058testDateTimeDenotation1 77059 "DateAndTimeTest new testDateTimeDenotation1" 77060 77061 " Detroit is 5 hours behind UTC, this offset to UTC is therefore written with a minus sign. This example tests the correct interpretation of the DateAndTime denotation. " 77062 77063 | twoPmInLondon twoPmUTCInLocalTimeOfDetroit nineAmInDetroit | 77064 twoPmInLondon := DateAndTime 77065 year: 2004 77066 month: 11 77067 day: 2 77068 hour: 14 77069 minute: 0 77070 second: 0 77071 offset: 0 hours. 77072 twoPmUTCInLocalTimeOfDetroit := twoPmInLondon utcOffset: -5 hours. 77073 nineAmInDetroit := '2004-11-02T09:00:00-05:00' asDateAndTime. 77074 self assert: twoPmUTCInLocalTimeOfDetroit = nineAmInDetroit. 77075 77076! ! 77077 77078!DateAndTimeTest methodsFor: 'Tests' stamp: 'dtl 11/7/2004 13:01'! 77079testDateTimeDenotation2 77080 "DateAndTimeTest new testDateTimeDenotation2" 77081 77082 " Moscow is 3 hours ahead UTC, this offset to UTC is therefore positive. This example tests the correct interpretation of the DateAndTime denotation. " 77083 77084 | lateEveningInLondon lateEveningInLocalTimeOfMoscow 77085 localMoscowTimeFromDenotation | 77086 lateEveningInLondon := DateAndTime 77087 year: 2004 77088 month: 11 77089 day: 30 77090 hour: 23 77091 minute: 30 77092 second: 0 77093 offset: 0 hours. 77094 lateEveningInLocalTimeOfMoscow := lateEveningInLondon utcOffset: 3 hours. 77095 localMoscowTimeFromDenotation := '2004-12-01T02:30:00+03:00' asDateAndTime. 77096 self assert: lateEveningInLocalTimeOfMoscow = localMoscowTimeFromDenotation. 77097 77098! ! 77099 77100!DateAndTimeTest methodsFor: 'Tests' stamp: 'bvs 9/29/2004 16:22'! 77101testErrorWhenDayIsAfterMonthEnd 77102 77103 self 77104 should: 77105 [DateAndTime 77106 year: 2004 77107 month: 2 77108 day: 30] 77109 raise: Error. 77110 77111 self 77112 shouldnt: 77113 [DateAndTime 77114 year: 2004 77115 month: 2 77116 day: 29] 77117 raise: Error. 77118 ! ! 77119 77120!DateAndTimeTest methodsFor: 'Tests' stamp: 'bvs 9/29/2004 16:29'! 77121testErrorWhenDayIsBeforeMonthStart 77122 77123 self 77124 should: 77125 [DateAndTime 77126 year: 2004 77127 month: 2 77128 day: -1] 77129 raise: Error. 77130 77131 self 77132 should: 77133 [DateAndTime 77134 year: 2004 77135 month: 2 77136 day: 0] 77137 raise: Error. 77138 77139 self 77140 shouldnt: 77141 [DateAndTime 77142 year: 2004 77143 month: 2 77144 day: 1] 77145 raise: Error. 77146 ! ! 77147 77148!DateAndTimeTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 15:37'! 77149testInstanceCreation 77150 77151 | t | 77152 t := DateAndTime 77153 year: 1 month: 1 day: 2 77154 hour: 2 minute: 3 second: 4 nanoSecond: 5 77155 offset: 6 hours. 77156 self 77157 assert: (t julianDayNumber = 1721427); 77158 assert: (t offset = 6 hours); 77159 assert: (t hour = 2); 77160 assert: (t minute = 3); 77161 assert: (t second = 4); 77162 assert: (t nanoSecond = 5). 77163 77164! ! 77165 77166!DateAndTimeTest methodsFor: 'Tests' stamp: 'nk 3/12/2004 11:06'! 77167testMonotonicity 77168 77169 | t1 t2 t3 t4 | 77170 t1 := DateAndTime now. 77171 t2 := DateAndTime now. 77172 (Delay forMilliseconds: 1000) wait. 77173 t3 := DateAndTime now. 77174 t4 := DateAndTime now. 77175 77176 self 77177 assert: ( t1 <= t2); 77178 assert: ( t2 < t3); 77179 assert: ( t3 <= t4). 77180! ! 77181 77182!DateAndTimeTest methodsFor: 'Tests' stamp: 'dtl 11/5/2004 05:45'! 77183testPrintString 77184 77185 "(self new setTestSelector: #testPrintString) debug" 77186 77187 | dt | 77188 dt :=DateAndTime 77189 year: 2004 77190 month: 11 77191 day: 2 77192 hour: 14 77193 minute: 3 77194 second: 5 77195 nanoSecond: 12345 77196 offset: (Duration seconds: (5 * 3600)). 77197 self assert: dt printString = '2004-11-02T14:03:05.000012345+05:00' 77198 77199 77200! ! 77201 77202!DateAndTimeTest methodsFor: 'Tests' stamp: 'stephane.ducasse 5/21/2009 14:25'! 77203testReadFromFoolProofExtension 77204 "Convenient extension without a time, only a date" 77205 "self debug: #testReadFromFoolProofExtension" 77206 77207 self assert: ('2008' asDateAndTime printString = '2008-01-01T00:00:00+00:00'). 77208 self assert: ('2008-08' asDateAndTime printString = '2008-08-01T00:00:00+00:00'). 77209 self assert: ('2006-08-28' asDateAndTime printString = '2006-08-28T00:00:00+00:00'). 77210 "Regular nanoseconds" 77211 self assert: ('2006-08-28T00:00:00.123456789' asDateAndTime printString = '2006-08-28T00:00:00.123456789+00:00'). 77212 "Extra picoseconds precision should not spoil the DateAndTime" 77213 self assert: ('2006-08-28T00:00:00.123456789000' asDateAndTime printString = '2006-08-28T00:00:00.123456789+00:00').! ! 77214 77215!DateAndTimeTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 15:43'! 77216testSmalltalk80Accessors 77217 77218 | t | 77219 t := DateAndTime 77220 year: 1 month: 1 day: 2 77221 hour: 2 minute: 3 second: 4 nanoSecond: 5 77222 offset: 6 hours. 77223 self 77224 assert: (t hours = t hours); 77225 assert: (t minutes = t minute); 77226 assert: (t seconds = t second). 77227! ! 77228 77229!DateAndTimeTest methodsFor: 'Tests' stamp: 'BG 11/7/2004 12:18'! 77230testTimeZoneEquivalence 77231 "DateAndTimeTest new testTimeZoneEquivalence" 77232 "When the clock on the wall in Detroit says 9:00am, the clock on the wall 77233 in London says 2:00pm. The Duration difference between the corresponding 77234 DateAndTime values should be zero." 77235 77236 " Detroit is 5 hours behind UTC, this offset to UTC is therefore written with a minus sign. This example tests both the correct interpretation of the DateAndTime denotation and correct DateAndTime arithmetics. " 77237 77238 | twoPmInLondon nineAmInDetroit durationDifference | 77239 twoPmInLondon := '2004-11-02T14:00:00+00:00' asDateAndTime. 77240 nineAmInDetroit := '2004-11-02T09:00:00-05:00' asDateAndTime. 77241 durationDifference := twoPmInLondon - nineAmInDetroit. 77242 self assert: durationDifference asSeconds = 0. 77243 self assert: twoPmInLondon = nineAmInDetroit 77244! ! 77245 77246!DateAndTimeTest methodsFor: 'Tests' stamp: 'BG 11/7/2004 12:17'! 77247testTimeZoneEquivalence2 77248 "DateAndTimeTest new testTimeZoneEquivalence2" 77249 "This example demonstates the fact that 77250 2004-05-24T22:40:00 UTC is 77251 2004-05-25T01:40:00 in Moscow 77252 (Moscow is 3 hours ahead of UTC) " 77253 77254 | thisMoment thisMomentInMoscow | 77255 thisMoment := DateAndTime year: 2004 month: 5 day: 24 hour: 22 minute: 40. 77256 thisMomentInMoscow := thisMoment utcOffset: 3 hours. 77257 self assert: (thisMoment - thisMomentInMoscow) asSeconds = 0. 77258 self assert: thisMoment = thisMomentInMoscow 77259! ! 77260ClassTestCase subclass: #DateTest 77261 instanceVariableNames: 'date aDate aTime' 77262 classVariableNames: '' 77263 poolDictionaries: '' 77264 category: 'KernelTests-Chronology'! 77265!DateTest commentStamp: 'brp 7/26/2003 16:58' prior: 0! 77266This is the unit test for the class Date. ! 77267 77268 77269!DateTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 13:01'! 77270classToBeTested 77271 77272 ^ self dateClass! ! 77273 77274!DateTest methodsFor: 'Coverage' stamp: 'brp 1/30/2005 09:03'! 77275selectorsToBeIgnored 77276 77277 | deprecated private special | 77278 deprecated := #(). 77279 private := #(). 77280 special := #( #< #= #new #next #previous #printOn: #printOn:format: #storeOn: #fromString: ). 77281 77282 ^ super selectorsToBeIgnored, deprecated, private, special! ! 77283 77284 77285!DateTest methodsFor: 'Running' stamp: 'brp 1/21/2004 18:46'! 77286setUp 77287 77288 date := self dateClass newDay: 153 year: 1973. "2 June 1973" 77289 77290 aDate := Date readFrom: '01-23-2004' readStream. 77291 aTime := Time readFrom: '12:34:56 pm' readStream! ! 77292 77293 77294!DateTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 16:07'! 77295testAccessing 77296 77297 self 77298 assert: date day = 153; 77299 assert: date julianDayNumber = 2441836; 77300 assert: date leap = 0; 77301 assert: date monthIndex = 6; 77302 assert: date monthName = #June; 77303 assert: date weekday = #Saturday; 77304 assert: date weekdayIndex = 7; 77305 assert: date year = 1973. 77306! ! 77307 77308!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:10'! 77309testArithmetic 77310 | d | 77311 d := date addDays: 32. "4 July 1973" 77312 77313 self 77314 assert: d year = 1973; 77315 assert: d monthIndex = 7; 77316 assert: d dayOfMonth = 4. 77317 self 77318 assert: (d subtractDate: date) = 32; 77319 assert: (date subtractDate: d) = -32. 77320 self 77321 assert: (d subtractDays: 32) = date. 77322! ! 77323 77324!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:54'! 77325testComparing 77326 | d1 d2 d3 | 77327 d1 := self dateClass newDay: 2 month: #June year: 1973. 77328 d2 := self dateClass newDay: 97 year: 2003. "7 April 2003" 77329 d3 := self dateClass newDay: 250 year: 1865. "7 September 1865" 77330 77331 self 77332 assert: date = d1; 77333 assert: date = date copy; 77334 assert: date hash = d1 hash. 77335 self 77336 assert: date < d2; 77337 deny: date < d3. 77338! ! 77339 77340!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:15'! 77341testConverting 77342 77343 self 77344 assert: date asDate = date; 77345 assert: '2 June 1973' asDate = date; 77346 assert: date asSeconds = 2285280000. 77347 77348 date dayMonthYearDo: [ :d :m :y | self assert: d = 2; assert: m = 6; assert: y = 1973 ].! ! 77349 77350!DateTest methodsFor: 'Tests' stamp: 'brp 1/21/2004 18:47'! 77351testFromDays 77352 | epoch d0 d1 d2 | 77353 epoch := self dateClass newDay: 1 year: 1901. 77354 d0 := self dateClass fromDays: 0. "1 January 1901" 77355 self assert: d0 = epoch. 77356 77357 d1 := self dateClass fromDays: 26450. "2 June 1973" 77358 self assert: d1 = date. 77359 77360 d2 := self dateClass fromDays: -100000. "18 March 1627" 77361 self assert: d2 julianDayNumber = 2315386. 77362 77363 self assert: aDate = (Date fromDays: 37642). 77364 self assert: aDate = (Date fromDays: 103*365 + 22 + 25 "leap days") . 77365 ! ! 77366 77367!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:17'! 77368testFromSeconds 77369 | d | 77370 d := self dateClass fromSeconds: 2285280000. 77371 self 77372 assert: d = date. 77373! ! 77374 77375!DateTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 16:37'! 77376testGeneralInquiries 77377 77378 | shuffled indices names now | 77379 77380 shuffled := #(#January #February #March #April #May #June #July 77381 #August #September #October #November #December) shuffled. 77382 indices := shuffled collect: [ :m | self dateClass indexOfMonth: m ]. 77383 names := indices collect: [ :i | self dateClass nameOfMonth: i ]. 77384 self assert: names = shuffled. 77385 77386 shuffled := #(#Monday #Tuesday #Wednesday #Thursday #Friday #Saturday #Sunday) shuffled. 77387 indices := shuffled collect: [ :m | self dateClass dayOfWeek: m ]. 77388 names := indices collect: [ :i | self dateClass nameOfDay: i ]. 77389 self assert: names = shuffled. 77390 77391 now := self dateClass dateAndTimeNow. 77392 self 77393 assert: now size = 2; 77394 assert: now first = self dateClass today. 77395 77396 self assert: (self dateClass firstWeekdayOfMonth: #June year: 1973) = 6. 77397 77398 self 77399 assert: (self dateClass leapYear: 1973) = 0; 77400 assert: (self dateClass leapYear: 1972) = 1; 77401 assert: (self dateClass daysInYear: 1973) = 365; 77402 assert: (self dateClass daysInYear: 1972) = 366; 77403 assert: (self dateClass daysInMonth: #February forYear: 1973) = 28; 77404 assert: (self dateClass daysInMonth: #February forYear: 1972) = 29. 77405! ! 77406 77407!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:17'! 77408testInitialization 77409 77410 self should: [ self dateClass initialize. true ]. 77411! ! 77412 77413!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:18'! 77414testInquiries 77415 77416 self 77417 assert: date dayOfMonth = 2; 77418 assert: date dayOfYear = 153; 77419 assert: date daysInMonth = 30; 77420 assert: date daysInYear = 365; 77421 assert: date daysLeftInYear = (365 - 153); 77422 assert: date firstDayOfMonth = 152. 77423! ! 77424 77425!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:05'! 77426testNew 77427 | epoch | 77428 epoch := self dateClass newDay: 1 year: 1901. 77429 self assert: (self dateClass new = epoch).! ! 77430 77431!DateTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 16:33'! 77432testPreviousNext 77433 | n p pt ps | 77434 n := date next. 77435 p := date previous. 77436 77437 self 77438 assert: n year = 1973; 77439 assert: n dayOfYear = 154; 77440 assert: p year = 1973; 77441 assert: p dayOfYear = 152. 77442 77443 pt := date previous: #Thursday. "31 May 1973" 77444 self 77445 assert: pt year = 1973; 77446 assert: pt dayOfYear = 151. 77447 77448 ps := date previous: #Saturday. " 26 May 1973" 77449 self 77450 assert: ps year = 1973; 77451 assert: ps dayOfYear = (153-7). 77452! ! 77453 77454!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:21'! 77455testPrinting 77456 77457 self 77458 assert: date mmddyyyy = '6/2/1973'; 77459 assert: date yyyymmdd = '1973-06-02'; 77460 assert: (date printFormat: #(3 1 2 $!! 2 1 1)) = '1973!!2!!Jun'. 77461! ! 77462 77463!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:23'! 77464testReadFrom 77465 | s1 s2 s3 s4 s5 | 77466 s1 := '2 June 1973'. 77467 s2 := '2-JUN-73'. 77468 s3 := 'June 2, 1973'. 77469 s4 := '6/2/73'. 77470 s5 := '2JUN73'. 77471 77472 self 77473 assert: date = (self dateClass readFrom: s1 readStream); 77474 assert: date = (self dateClass readFrom: s2 readStream); 77475 assert: date = (self dateClass readFrom: s3 readStream); 77476 assert: date = (self dateClass readFrom: s4 readStream); 77477 assert: date = (self dateClass readFrom: s5 readStream).! ! 77478 77479!DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:05'! 77480testStoring 77481 77482 self 77483 assert: date storeString = '''2 June 1973'' asDate'; 77484 assert: date = ('2 June 1973' asDate). 77485! ! 77486 77487 77488!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77489testAddDays 77490 self assert: (aDate addDays: 00) yyyymmdd = '2004-01-23'. 77491 self assert: (aDate addDays: 30) yyyymmdd = '2004-02-22'. 77492 self assert: (aDate addDays: 60) yyyymmdd = '2004-03-23'. 77493 self assert: (aDate addDays: 90) yyyymmdd = '2004-04-22'. 77494 self assert: (aDate addDays:120) yyyymmdd = '2004-05-22'! ! 77495 77496!DateTest methodsFor: 'testing' stamp: 'tbn 7/11/2006 10:37'! 77497testAddMonths 77498 self assert: (aDate addMonths: 0) yyyymmdd = '2004-01-23'. 77499 self assert: (aDate addMonths: 1) yyyymmdd = '2004-02-23'. 77500 self assert: (aDate addMonths: 2) yyyymmdd = '2004-03-23'. 77501 self assert: (aDate addMonths: 3) yyyymmdd = '2004-04-23'. 77502 self assert: (aDate addMonths: 12) yyyymmdd = '2005-01-23'. 77503 77504 self assert: ((Date readFrom: '05-31-2017' readStream) addMonths: 1) yyyymmdd = '2017-06-30'. 77505 self assert: ((Date readFrom: '02-29-2000' readStream) addMonths: 12) yyyymmdd = '2001-02-28'! ! 77506 77507!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77508testAsDate 77509 self assert: (aDate asDate) = aDate 77510! ! 77511 77512!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77513testAsSeconds 77514 self assert: (aDate asSeconds) = 3252268800. 77515 self assert: (aDate asSeconds) = ((103*365*24*60*60) + (22+25"leap days"*24*60*60)) . 77516 self assert: aDate = (Date fromSeconds: 3252268800).! ! 77517 77518!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77519testDateAndTimeNow 77520 "Not a great test: could falsely fail if midnight come in between the two executions and doesnt catch time errors" 77521 self assert: Date dateAndTimeNow first = Date today 77522! ! 77523 77524!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77525testDayMonthYearDo 77526 self assert: (aDate dayMonthYearDo: [:day :month :year | day asString , month asString, year asString]) = '2312004' 77527! ! 77528 77529!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77530testDaysInMonthForYear 77531 self assert: (Date daysInMonth: 'February' forYear: 2008) = 29. 77532 self assert: (Date daysInMonth: 'February' forYear: 2000) = 29. 77533 self assert: (Date daysInMonth: 'February' forYear: 2100) = 28. 77534 self assert: (Date daysInMonth: 'July' forYear: 2100) = 31. ! ! 77535 77536!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77537testDaysInYear 77538 self assert: (Date daysInYear: 2008) = 366. 77539 self assert: (Date daysInYear: 2000) = 366. 77540 self assert: (Date daysInYear: 2100) = 365 77541! ! 77542 77543!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77544testDuration 77545 self assert: aDate duration = 24 hours! ! 77546 77547!DateTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 77548testEqual 77549 self assert: aDate = (Date readFrom: 'January 23, 2004' readStream)! ! 77550 77551!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77552testFirstWeekdayOfMonthYear 77553 self assert: (Date firstWeekdayOfMonth: 'January' year: 2004) = 5. 77554! ! 77555 77556!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77557testIndexOfMonth 77558 self assert: (Date indexOfMonth: 'January') = 1. 77559 self assert: (Date indexOfMonth: 'December') = 12. ! ! 77560 77561!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77562testJulianDayNumber 77563 self assert: aDate = (Date julianDayNumber: ((4713+2004)*365 +1323) ). ! ! 77564 77565!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77566testLeap 77567 self assert: aDate leap = 1. 77568 77569! ! 77570 77571!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77572testLeapNot 77573 self assert: (aDate addDays: 365) leap = 0 77574! ! 77575 77576!DateTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 77577testLessThan 77578 self assert: aDate < (Date readFrom: '01-24-2004' readStream)! ! 77579 77580!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77581testMmddyyyy 77582 self assert: aDate mmddyyyy = '1/23/2004'! ! 77583 77584!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77585testNameOfMonth 77586 self assert: (Date nameOfMonth: 5) = 'May'. 77587 self assert: (Date nameOfMonth: 8) = 'August' ! ! 77588 77589!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77590testNewDayMonthYear 77591 self assert: aDate = (Date newDay: 23 month: 1 year: 2004) 77592! ! 77593 77594!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77595testNewDayYear 77596 self assert: aDate = (Date newDay: 23 year: 2004) 77597! ! 77598 77599!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77600testPreviousFriday 77601 self assert: (aDate previous: 'Friday') yyyymmdd = '2004-01-16' 77602 77603! ! 77604 77605!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77606testPreviousThursday 77607 self assert: (aDate previous: 'Thursday') yyyymmdd = '2004-01-22' 77608 77609! ! 77610 77611!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77612testPrintFormat 77613 self assert: (aDate printFormat: #(1 2 3 $? 2 2)) = '23?Jan?04'! ! 77614 77615!DateTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 77616testPrintOn 77617 | cs rw | 77618 cs := '23 January 2004' readStream. 77619 rw := ReadWriteStream on: ''. 77620 aDate printOn: rw. 77621 self assert: rw contents = cs contents! ! 77622 77623!DateTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 77624testPrintOnFormat 77625 | cs rw | 77626 cs := '04*Jan*23' readStream. 77627 rw := ReadWriteStream on: ''. 77628 aDate 77629 printOn: rw 77630 format: #(3 2 1 $* 2 2 ). 77631 self assert: rw contents = cs contents! ! 77632 77633!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77634testStarting 77635 self assert: aDate = (Date starting: (DateAndTime fromString: '2004-01-23T12:12')). ! ! 77636 77637!DateTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 77638testStoreOn 77639 | cs rw | 77640 cs := '''23 January 2004'' asDate' readStream. 77641 rw := ReadWriteStream on: ''. 77642 aDate storeOn: rw. 77643 self assert: rw contents = cs contents! ! 77644 77645!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77646testSubtractDate 77647 self assert: (aDate subtractDate:(aDate addDays: 30)) = -30. 77648 self assert: (aDate subtractDate:(aDate subtractDays: 00)) = 0. 77649 self assert: (aDate subtractDate:(aDate subtractDays: 30)) = 30. 77650 77651! ! 77652 77653!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77654testSubtractDays 77655 self assert: (aDate subtractDays: 00) yyyymmdd = '2004-01-23'. 77656 self assert: (aDate subtractDays: 30) yyyymmdd = '2003-12-24'. 77657 self assert: (aDate subtractDays: 60) yyyymmdd = '2003-11-24' 77658! ! 77659 77660!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77661testTomorrow 77662 "Not a great test: could falsely fail if midnight come in between the two executions and doesnt catch many errors" 77663 self assert: Date tomorrow > Date today 77664! ! 77665 77666!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77667testWeekday 77668 self assert: aDate weekday = 'Friday'. 77669 self assert: aDate weekdayIndex = 6. 77670 self assert: (Date dayOfWeek: aDate weekday ) =6. 77671 self assert: (Date nameOfDay: 6 ) = 'Friday' ! ! 77672 77673!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77674testYesterday 77675 "Not a great test: doesnt catch many errors" 77676 self assert: Date yesterday < Date today 77677! ! 77678 77679!DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! 77680testYyyymmdd 77681 self assert: aDate yyyymmdd = '2004-01-23'! ! 77682 77683 77684!DateTest methodsFor: 'Private' stamp: 'brp 8/24/2003 00:10'! 77685dateClass 77686 77687 ^ Date! ! 77688CodeHolder subclass: #Debugger 77689 instanceVariableNames: 'interruptedProcess interruptedController contextStack contextStackTop contextStackIndex contextStackList receiverInspector contextVariablesInspector externalInterrupt proceedValue selectingPC debuggerMap savedCursor isolationHead failedProject errorWasInUIProcess labelString' 77690 classVariableNames: 'ContextStackKeystrokes ErrorRecursion' 77691 poolDictionaries: '' 77692 category: 'Tools-Debugger'! 77693!Debugger commentStamp: '<historical>' prior: 0! 77694I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. The debugger is typically viewed through a window that views the stack of suspended contexts, the code for, and execution point in, the currently selected message, and inspectors on both the receiver of the currently selected message, and the variables in the current context. 77695 77696Special note on recursive errors: 77697Some errors affect Squeak's ability to present a debugger. This is normally an unrecoverable situation. However, if such an error occurs in an isolation layer, Squeak will attempt to exit from the isolation layer and then present a debugger. Here is the chain of events in such a recovery. 77698 77699 * A recursive error is detected. 77700 * The current project is queried for an isolationHead 77701 * Changes in the isolationHead are revoked 77702 * The parent project of isolated project is returned to 77703 * The debugger is opened there and execution resumes. 77704 77705If the user closes that debugger, execution continues in the outer project and layer. If, after repairing some damage, the user proceeds from the debugger, then the isolationHead is re-invoked, the failed project is re-entered, and execution resumes in that world. ! 77706 77707 77708!Debugger methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/27/2009 12:59'! 77709addOptionalButtonsTo: window at: fractions plus: verticalOffset 77710 "Add button panes to the window. A row of custom 77711 debugger-specific buttons (Proceed, Restart, etc.) is always 77712 added, and if optionalButtons is in force, then the standard 77713 code-tool buttons are also added. Answer the verticalOffset 77714 plus the height added." 77715 | delta buttons anOffset | 77716 anOffset := (Preferences optionalButtons 77717 and: [Preferences extraDebuggerButtons]) 77718 ifTrue: [super 77719 addOptionalButtonsTo: window 77720 at: fractions 77721 plus: verticalOffset] 77722 ifFalse: [verticalOffset]. 77723 buttons := self customButtonRow. 77724 delta := self defaultButtonPaneHeight max: (buttons minExtent y + 1). 77725 buttons color: Color white; borderWidth: 0. 77726 window 77727 addMorph: buttons 77728 fullFrame: (LayoutFrame 77729 fractions: fractions 77730 offsets: (0 @ anOffset corner: 0 @ (anOffset + delta - 1))). 77731 ^ anOffset + delta! ! 77732 77733!Debugger methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 12/5/2008 15:11'! 77734buildMorphicNotifierLabelled: label message: messageString 77735 | notifyPane window extentToUse row| 77736 self expandStack. 77737 window := (PreDebugWindow labelled: label) model: self. 77738 extentToUse := 450 @ 156. "nice and wide to show plenty of the error msg" 77739 window 77740 addMorph: (row := self buttonRowForPreDebugWindow: window) 77741 fullFrame: (LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@row minExtent y)). 77742 row color: Color transparent. 77743 Preferences eToyFriendly | messageString notNil 77744 ifFalse: 77745 [notifyPane := PluggableListMorph on: self list: #contextStackList 77746 selected: #contextStackIndex changeSelected: #debugAt: 77747 menu: nil keystroke: nil] 77748 ifTrue: 77749 [notifyPane := PluggableTextMorph on: self text: nil accept: nil 77750 readSelection: nil menu: #debugProceedMenu:. 77751 notifyPane editString: (self preDebugNotifierContentsFrom: messageString); 77752 askBeforeDiscardingEdits: false]. 77753 window 77754 addMorph: notifyPane 77755 fullFrame: (LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@24 corner: 0@0)). 77756 window setBalloonTextForCloseBox. 77757 window openInWorldExtent: extentToUse. 77758 window currentWorld displayWorld. "helps with interrupt not working somehow." 77759 ^window! ! 77760 77761!Debugger methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/27/2009 13:06'! 77762buttonRowForPreDebugWindow: aDebugWindow 77763 "Answer a row of button for a pre-debug notifier." 77764 77765 | buttons quads | 77766 buttons := OrderedCollection with: (AlignmentMorph newVariableTransparentSpacer). 77767 quads := OrderedCollection withAll: self preDebugButtonQuads. 77768 (self interruptedContext selector == #doesNotUnderstand:) ifTrue: [ 77769 quads add: { 'Create'. #createMethod. #magenta. 'create the missing method' }]. 77770 quads do: [:quad | 77771 buttons add: ((PluggableButtonMorph 77772 on: aDebugWindow 77773 getState: nil 77774 action: quad second) 77775 label: quad first; 77776 setBalloonText: quad fourth; 77777 useSquareCorners; 77778 hResizing: #shrinkWrap; 77779 vResizing: #spaceFill). 77780 buttons add: AlignmentMorph newVariableTransparentSpacer]. 77781 ^(UITheme builder newRow: buttons) 77782 cellInset: 2! ! 77783 77784!Debugger methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/27/2009 12:58'! 77785customButtonRow 77786 "Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'customButtonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane" 77787 77788 77789 | buttons aLabel | 77790 buttons := OrderedCollection new. 77791 self customButtonSpecs do: [:tuple | 77792 aLabel := Preferences abbreviatedBrowserButtons 77793 ifTrue: [self abbreviatedWordingFor: tuple second]. 77794 buttons add: ((PluggableButtonMorph 77795 on: self 77796 getState: nil 77797 action: tuple second) 77798 hResizing: #spaceFill; 77799 vResizing: #spaceFill; 77800 askBeforeChanging: (#(proceed restart send doStep stepIntoBlock fullStack where) includes: tuple second); 77801 label: (aLabel ifNil: [tuple first asString]); 77802 setBalloonText: (tuple size > 2 ifTrue: [tuple third]))]. 77803 ^(UITheme builder newRow: buttons) 77804 layoutInset: (0@0 corner: 0@1); 77805 cellInset: 2! ! 77806 77807!Debugger methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/27/2009 12:55'! 77808optionalButtonRow 77809 "Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'buttonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane" 77810 77811 | buttons aLabel | 77812 buttons := OrderedCollection new. 77813 self optionalButtonPairs do: [:tuple | 77814 aLabel := Preferences abbreviatedBrowserButtons 77815 ifTrue: [self abbreviatedWordingFor: tuple second]. 77816 buttons add: ((PluggableButtonMorph 77817 on: self 77818 getState: nil 77819 action: tuple second) 77820 hResizing: #spaceFill; 77821 vResizing: #spaceFill; 77822 askBeforeChanging: (#(proceed restart send doStep stepIntoBlock fullStack where) includes: tuple second); 77823 label: (aLabel ifNil: [tuple first asString]); 77824 setBalloonText: (tuple size > 2 ifTrue: [tuple third]))]. 77825 ^(UITheme builder newRow: buttons) 77826 cellInset: 2! ! 77827 77828 77829!Debugger methodsFor: 'accessing' stamp: 'di 10/9/1998 17:15'! 77830contents 77831 "Depending on the current selection, different information is retrieved. 77832 Answer a string description of that information. This information is the 77833 method in the currently selected context." 77834 77835 contents == nil ifTrue: [^ String new]. 77836 ^ contents copy! ! 77837 77838!Debugger methodsFor: 'accessing' stamp: 'hfm 9/30/2009 03:57'! 77839contents: aText notifying: aController 77840 "The retrieved information has changed and its source must now be updated. 77841 In this case, the retrieved information is the method of the selected context." 77842 | result selector classOfMethod category h ctxt newMethod | 77843 contextStackIndex = 0 ifTrue: 77844 [^false]. 77845 self selectedContext isExecutingBlock ifTrue: 77846 [h := self selectedContext activeHome. 77847 h ifNil: 77848 [self inform: 'Method for block not found on stack, can''t edit and continue'. 77849 ^false]. 77850 (self confirm: 'I will have to revert to the method from\which this block originated. Is that OK?' withCRs) ifFalse: 77851 [^false]. 77852 self resetContext: h. 77853 result := self contents: aText notifying: aController. 77854 self contentsChanged. 77855 ^result]. 77856 77857 classOfMethod := self selectedClass. 77858 category := self selectedMessageCategoryName. 77859 selector := self selectedClass parserClass new parseSelector: aText. 77860 (selector == self selectedMessageName 77861 or: [(self selectedMessageName beginsWith: 'DoIt') 77862 and: [selector numArgs = self selectedMessageName numArgs]]) ifFalse: 77863 [self inform: 'can''t change selector'. 77864 ^false]. 77865 selector := classOfMethod 77866 compile: aText 77867 classified: category 77868 notifying: aController. 77869 selector ifNil: [^false]. "compile cancelled" 77870 contents := aText. 77871 newMethod := classOfMethod compiledMethodAt: selector. 77872 newMethod isQuick ifTrue: 77873 [self down. 77874 self selectedContext jump: (self selectedContext previousPc - self selectedContext pc)]. 77875 ctxt := interruptedProcess popTo: self selectedContext. 77876 ctxt == self selectedContext 77877 ifFalse: 77878 [self inform: 'Method saved, but current context unchanged\because of unwind error. Click OK to see error' withCRs] 77879 ifTrue: 77880 [newMethod isQuick ifFalse: 77881 [interruptedProcess 77882 restartTopWith: newMethod; 77883 stepToSendOrReturn]. 77884 contextVariablesInspector object: nil]. 77885 self resetContext: ctxt. 77886 World 77887 addAlarm: #changed: 77888 withArguments: #(contentsSelection) 77889 for: self 77890 at: (Time millisecondClockValue + 200). 77891 ^true! ! 77892 77893!Debugger methodsFor: 'accessing'! 77894contextVariablesInspector 77895 "Answer the instance of Inspector that is providing a view of the 77896 variables of the selected context." 77897 77898 ^contextVariablesInspector! ! 77899 77900!Debugger methodsFor: 'accessing'! 77901interruptedContext 77902 "Answer the suspended context of the interrupted process." 77903 77904 ^contextStackTop! ! 77905 77906!Debugger methodsFor: 'accessing'! 77907interruptedProcess 77908 "Answer the interrupted process." 77909 77910 ^interruptedProcess! ! 77911 77912!Debugger methodsFor: 'accessing' stamp: 'tk 4/16/1998 15:47'! 77913isNotifier 77914 "Return true if this debugger has not been expanded into a full sized window" 77915 77916 ^ receiverInspector == nil! ! 77917 77918!Debugger methodsFor: 'accessing' stamp: 'hmm 7/16/2001 21:54'! 77919labelString 77920 ^labelString! ! 77921 77922!Debugger methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 77923labelString: aString 77924 labelString := aString. 77925 self changed: #relabel! ! 77926 77927!Debugger methodsFor: 'accessing'! 77928proceedValue 77929 "Answer the value to return to the selected context when the interrupted 77930 process proceeds." 77931 77932 ^proceedValue! ! 77933 77934!Debugger methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 77935proceedValue: anObject 77936 "Set the value to be returned to the selected context when the interrupted 77937 process proceeds." 77938 77939 proceedValue := anObject! ! 77940 77941!Debugger methodsFor: 'accessing'! 77942receiver 77943 "Answer the receiver of the selected context, if any. Answer nil 77944 otherwise." 77945 77946 contextStackIndex = 0 77947 ifTrue: [^nil] 77948 ifFalse: [^self selectedContext receiver]! ! 77949 77950!Debugger methodsFor: 'accessing'! 77951receiverInspector 77952 "Answer the instance of Inspector that is providing a view of the 77953 variables of the selected context's receiver." 77954 77955 ^receiverInspector! ! 77956 77957!Debugger methodsFor: 'accessing' stamp: 'md 2/20/2006 18:52'! 77958receiverInspectorObject: obj context: ctxt 77959 77960 "set context before object so it can refer to context when building field list" 77961 receiverInspector context: ctxt. 77962 receiverInspector object: obj. 77963! ! 77964 77965 77966!Debugger methodsFor: 'as yet unclassified' stamp: 'hfm 12/21/2008 22:57'! 77967runToSelection 77968 77969 | currentContext selectionInterval | 77970 77971 selectionInterval := self codeTextMorph selectionInterval. 77972 self pc first >= selectionInterval first 77973 ifTrue: [ ^self ]. 77974 currentContext := self selectedContext. 77975 [ currentContext == self selectedContext and: [ self pc first < selectionInterval first ] ] 77976 whileTrue: [ self doStep ].! ! 77977 77978 77979!Debugger methodsFor: 'breakpoints' stamp: 'marcus.denker 10/9/2008 20:32'! 77980toggleBreakOnEntry 77981 "Install or uninstall a halt-on-entry breakpoint" 77982 77983 | selectedMethod | 77984 self selectedClassOrMetaClass isNil ifTrue:[^self]. 77985 selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName. 77986 selectedMethod hasBreakpoint 77987 ifTrue: [BreakpointManager unInstall: selectedMethod] 77988 ifFalse: [BreakpointManager 77989 installInClass: self selectedClassOrMetaClass 77990 selector: self selectedMessageName].! ! 77991 77992 77993!Debugger methodsFor: 'class list' stamp: 'md 2/17/2006 09:32'! 77994selectedClass 77995 "Answer the class in which the currently selected context's method was 77996 found." 77997 77998 ^self selectedContext methodClass! ! 77999 78000 78001!Debugger methodsFor: 'code pane' stamp: 'tk 4/15/1998 18:31'! 78002contentsSelection 78003 78004 ^ self pcRange! ! 78005 78006!Debugger methodsFor: 'code pane'! 78007doItContext 78008 "Answer the context in which a text selection can be evaluated." 78009 78010 contextStackIndex = 0 78011 ifTrue: [^super doItContext] 78012 ifFalse: [^self selectedContext]! ! 78013 78014!Debugger methodsFor: 'code pane'! 78015doItReceiver 78016 "Answer the object that should be informed of the result of evaluating a 78017 text selection." 78018 78019 ^self receiver! ! 78020 78021!Debugger methodsFor: 'code pane' stamp: 'tk 5/2/1998 10:04'! 78022pc 78023 78024 ^ self pcRange! ! 78025 78026!Debugger methodsFor: 'code pane' stamp: 'eem 3/12/2009 14:54'! 78027pcRange 78028 "Answer the indices in the source code for the method corresponding to 78029 the selected context's program counter value." 78030 78031 (selectingPC and: [contextStackIndex ~= 0]) ifFalse: 78032 [^1 to: 0]. 78033 self selectedContext isDead ifTrue: 78034 [^1 to: 0]. 78035 ^self selectedContext debuggerMap 78036 rangeForPC: self selectedContext pc 78037 contextIsActiveContext: contextStackIndex = 1! ! 78038 78039 78040!Debugger methodsFor: 'code pane menu' stamp: 'nk 8/6/2003 13:52'! 78041codePaneMenu: aMenu shifted: shifted 78042 aMenu add: 'run to here' target: self selector: #runToSelection: argument: thisContext sender receiver selectionInterval. 78043 aMenu addLine. 78044 super codePaneMenu: aMenu shifted: shifted. 78045 ^aMenu.! ! 78046 78047!Debugger methodsFor: 'code pane menu' stamp: 'sd 11/20/2005 21:27'! 78048perform: selector orSendTo: otherTarget 78049 "Selector was just chosen from a menu by a user. If can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." 78050 78051 | result | 78052 (#(debug proceed) includes: selector) "When I am a notifier window" 78053 ifTrue: [^ self perform: selector] 78054 ifFalse: [result := super perform: selector orSendTo: otherTarget. 78055 selector == #doIt ifTrue: [ 78056 result ~~ #failedDoit ifTrue: [self proceedValue: result]]. 78057 ^ result]! ! 78058 78059!Debugger methodsFor: 'code pane menu' stamp: 'sd 11/20/2005 21:27'! 78060runToSelection: selectionInterval 78061 | currentContext | 78062 self pc first >= selectionInterval first ifTrue: [ ^self ]. 78063 currentContext := self selectedContext. 78064 [ currentContext == self selectedContext and: [ self pc first < selectionInterval first ] ] whileTrue: [ self doStep ].! ! 78065 78066 78067!Debugger methodsFor: 'context stack (message list)'! 78068contextStackIndex 78069 "Answer the index of the selected context." 78070 78071 ^contextStackIndex! ! 78072 78073!Debugger methodsFor: 'context stack (message list)'! 78074contextStackList 78075 "Answer the array of contexts." 78076 78077 ^contextStackList! ! 78078 78079!Debugger methodsFor: 'context stack (message list)' stamp: 'sd 11/20/2005 21:27'! 78080expandStack 78081 "A Notifier is being turned into a full debugger. Show a substantial amount of stack in the context pane." 78082 78083 self newStack: (contextStackTop stackOfSize: 20). 78084 contextStackIndex := 0. 78085 receiverInspector := Inspector inspect: nil. 78086 contextVariablesInspector := ContextVariablesInspector inspect: nil. 78087 proceedValue := nil! ! 78088 78089!Debugger methodsFor: 'context stack (message list)' stamp: 'ajh 9/25/2001 00:14'! 78090fullyExpandStack 78091 "Expand the stack to include all of it, rather than the first four or five 78092 contexts." 78093 78094 self okToChange ifFalse: [^ self]. 78095 self newStack: contextStackTop contextStack. 78096 self changed: #contextStackList! ! 78097 78098!Debugger methodsFor: 'context stack (message list)'! 78099messageListIndex 78100 "Answer the index of the currently selected context." 78101 78102 ^contextStackIndex! ! 78103 78104!Debugger methodsFor: 'context stack (message list)' stamp: 'eem 3/12/2009 14:54'! 78105selectedMessage 78106 "Answer the source code of the currently selected context." 78107 ^contents := self selectedContext debuggerMap sourceText asText makeSelectorBold! ! 78108 78109!Debugger methodsFor: 'context stack (message list)' stamp: 'eem 9/5/2008 13:57'! 78110selectedMessageName 78111 "Answer the message selector of the currently selected context. 78112 If the method is unbound we can still usefully answer its old selector." 78113 78114 | selector | 78115 selector := self selectedContext methodSelector. 78116 ^(selector ~~ self selectedContext method selector 78117 and: [selector beginsWith: 'DoIt']) 78118 ifTrue: [self selectedContext method selector] 78119 ifFalse: [selector]! ! 78120 78121!Debugger methodsFor: 'context stack (message list)'! 78122toggleContextStackIndex: anInteger 78123 "If anInteger is the same as the index of the selected context, deselect it. 78124 Otherwise, the context whose index is anInteger becomes the selected 78125 context." 78126 78127 self contextStackIndex: 78128 (contextStackIndex = anInteger 78129 ifTrue: [0] 78130 ifFalse: [anInteger]) 78131 oldContextWas: 78132 (contextStackIndex = 0 78133 ifTrue: [nil] 78134 ifFalse: [contextStack at: contextStackIndex])! ! 78135 78136 78137!Debugger methodsFor: 'context stack menu' stamp: 'DamienCassou 9/23/2009 08:33'! 78138askForCategoryIn: aClass default: aString 78139 | categories index category | 78140 categories := OrderedCollection with: 'new ...'. 78141 categories addAll: (aClass allMethodCategoriesIntegratedThrough: Object). 78142 index := UIManager default 78143 chooseFrom: categories 78144 title: 'Please provide a good category for the new method!!' translated. 78145 index = 0 ifTrue: [^ aString]. 78146 category := index = 1 ifTrue: [UIManager default request: 'Enter category name:'] 78147 ifFalse: [categories at: index]. 78148 ^ category isEmptyOrNil ifTrue: [^ aString] ifFalse: [category]! ! 78149 78150!Debugger methodsFor: 'context stack menu' stamp: 'wod 5/15/1998 00:24'! 78151browseMessages 78152 "Present a menu of all messages sent by the currently selected message. 78153 Open a message set browser of all implementors of the message chosen. 78154 Do nothing if no message is chosen." 78155 78156 contextStackIndex = 0 ifTrue: [^ self]. 78157 super browseMessages.! ! 78158 78159!Debugger methodsFor: 'context stack menu' stamp: 'wod 5/15/1998 00:23'! 78160browseSendersOfMessages 78161 "Present a menu of the currently selected message, as well as all 78162 messages sent by it. Open a message set browser of all implementors 78163 of the message chosen." 78164 78165 contextStackIndex = 0 ifTrue: [^ self]. 78166 super browseSendersOfMessages! ! 78167 78168!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'! 78169browseVersions 78170 "Create and schedule a message set browser on all versions of the 78171 currently selected message selector." 78172 78173 | class selector | 78174 class := self selectedClassOrMetaClass. 78175 selector := self selectedMessageName. 78176 VersionsBrowser 78177 browseVersionsOf: (class compiledMethodAt: selector) 78178 class: self selectedClass theNonMetaClass 78179 meta: class isMeta 78180 category: self selectedMessageCategoryName 78181 selector: selector! ! 78182 78183!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/6/98 23:00'! 78184buildMessageBrowser 78185 "Create and schedule a message browser on the current method." 78186 78187 contextStackIndex = 0 ifTrue: [^ self]. 78188 ^ Browser 78189 openMessageBrowserForClass: self selectedClassOrMetaClass 78190 selector: self selectedMessageName 78191 editString: nil! ! 78192 78193!Debugger methodsFor: 'context stack menu'! 78194close: aScheduledController 78195 "The argument is a controller on a view of the receiver. 78196 That view is closed." 78197 78198 aScheduledController close 78199! ! 78200 78201!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'! 78202contextStackKey: aChar from: view 78203 "Respond to a keystroke in the context list" 78204 78205 | selector | 78206 selector := ContextStackKeystrokes at: aChar ifAbsent: [nil]. 78207 selector ifNil: [self messageListKey: aChar from: view] 78208 ifNotNil: [self perform: selector]! ! 78209 78210!Debugger methodsFor: 'context stack menu' stamp: 'alain.plantec 5/30/2008 11:42'! 78211contextStackMenu: aMenu shifted: shifted 78212 "Set up the menu appropriately for the context-stack-list, either shifted 78213 or unshifted as per the parameter provided" 78214 ^ shifted 78215 ifTrue: [aMenu 78216 labels: 'browse class hierarchy 78217browse class 78218browse method (O) 78219implementors of sent messages 78220change sets with this method 78221inspect instances 78222inspect subinstances 78223revert to previous version 78224remove from current change set 78225revert & remove from changes 78226more...' 78227 lines: #(5 7 10 ) 78228 selections: #(#classHierarchy #browseClass #openSingleMessageBrowser #browseAllMessages #findMethodInChangeSets #inspectInstances #inspectSubInstances #revertToPreviousVersion #removeFromCurrentChanges #revertAndForget #unshiftedYellowButtonActivity )] 78229 ifFalse: [self selectedContext selector = #doesNotUnderstand: 78230 ifTrue: [aMenu 78231 add: 'implement in...' 78232 subMenu: (self 78233 populateImplementInMenu: (MenuMorph new defaultTarget: self)) 78234 target: nil 78235 selector: nil 78236 argumentList: #(nil )]. 78237 aMenu 78238 labels: 'fullStack (f) 78239restart (r) 78240proceed (p) 78241step (t) 78242step through (T) 78243send (e) 78244where (w) 78245peel to first like this 78246return entered value 78247toggle break on entry 78248senders of... (n) 78249implementors of... (m) 78250inheritance (i) 78251versions (v) 78252inst var refs... 78253inst var defs... 78254class var refs... 78255class variables 78256class refs (N) 78257browse full (b) 78258file out 78259mail out bug report 78260more...' 78261 lines: #(8 9 13 15 18 21 ) 78262 selections: #(#fullStack #restart #proceed #doStep #stepIntoBlock #send #where #peelToFirst #returnValue #toggleBreakOnEntry #browseSendersOfMessages #browseMessages #methodHierarchy #browseVersions #browseInstVarRefs #browseInstVarDefs #browseClassVarRefs #browseClassVariables #browseClassRefs #browseMethodFull #fileOutMessage #mailOutBugReport #shiftedYellowButtonActivity )]! ! 78263 78264!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/16/1998 12:19'! 78265debugProceedMenu: aMenu 78266 ^ aMenu labels: 78267'proceed 78268debug' 78269 lines: #() 78270 selections: #(proceed debug ) 78271! ! 78272 78273!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'! 78274doStep 78275 "Send the selected message in the accessed method, and regain control 78276 after the invoked method returns." 78277 78278 | currentContext newContext | 78279 self okToChange ifFalse: [^ self]. 78280 self checkContextSelection. 78281 currentContext := self selectedContext. 78282 newContext := interruptedProcess completeStep: currentContext. 78283 newContext == currentContext ifTrue: [ 78284 newContext := interruptedProcess stepToSendOrReturn]. 78285 self contextStackIndex > 1 78286 ifTrue: [self resetContext: newContext] 78287 ifFalse: [newContext == currentContext 78288 ifTrue: [self changed: #contentsSelection. 78289 self updateInspectors] 78290 ifFalse: [self resetContext: newContext]]. 78291! ! 78292 78293!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:55'! 78294down 78295 "move down the context stack to the previous (enclosing) context" 78296 78297 self toggleContextStackIndex: contextStackIndex+1! ! 78298 78299!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/17/1998 18:06'! 78300fullStack 78301 "Change from displaying the minimal stack to a full one." 78302 78303 self contextStackList size > 20 "Already expanded" 78304 ifTrue: 78305 [self changed: #flash] 78306 ifFalse: 78307 [self contextStackIndex = 0 ifFalse: [ 78308 self toggleContextStackIndex: self contextStackIndex]. 78309 self fullyExpandStack]! ! 78310 78311!Debugger methodsFor: 'context stack menu' stamp: 'eem 5/21/2008 10:39'! 78312implement: aMessage inClass: aClass 78313 78314 aClass 78315 compile: aMessage createStubMethod 78316 classified: (self askForCategoryIn: aClass default: 'as yet unclassified'). 78317 self setContentsToForceRefetch. 78318 self selectedContext privRefreshWith: (aClass lookupSelector: aMessage selector). 78319 self selectedContext method numArgs > 0 ifTrue: 78320 [(self selectedContext tempAt: 1) arguments withIndexDo: 78321 [:arg :index| 78322 self selectedContext tempAt: index put: arg]]. 78323 self resetContext: self selectedContext. 78324 self debug. 78325! ! 78326 78327!Debugger methodsFor: 'context stack menu' stamp: 'PeterHugossonMiller 9/3/2009 01:11'! 78328mailOutBugReport 78329 "Compose a useful bug report showing the state of the process as well as vital image statistics as suggested by Chris Norton - 78330'Squeak could pre-fill the bug form with lots of vital, but 78331oft-repeated, information like what is the image version, last update 78332number, VM version, platform, available RAM, author...' 78333 78334and address it to the list with the appropriate subject prefix." 78335 78336 | messageStrm | 78337 MailSender default ifNil: [^self]. 78338 78339 Cursor write 78340 showWhile: 78341 ["Prepare the message" 78342 messageStrm := (String new: 1500) writeStream. 78343 messageStrm nextPutAll: 'From: '; 78344 nextPutAll: MailSender userName; 78345 cr; 78346 nextPutAll: 'To: Pharo-project@lists.gforge.inria.fr'; 78347 cr; 78348 nextPutAll: 'Subject: '; 78349 nextPutAll: '[BUG]'; nextPutAll: self interruptedContext printString; 78350 cr;cr; 78351 nextPutAll: 'here insert explanation of what you were doing, suspect changes you''ve made and so forth.';cr;cr. 78352 self interruptedContext errorReportOn: messageStrm. 78353 78354 MailSender sendMessage: (MailMessage from: messageStrm contents)]. 78355! ! 78356 78357!Debugger methodsFor: 'context stack menu' stamp: 'sw 3/16/2001 17:20'! 78358messageListMenu: aMenu shifted: shifted 78359 "The context-stack menu takes the place of the message-list menu in the debugger, so pass it on" 78360 78361 ^ self contextStackMenu: aMenu shifted: shifted! ! 78362 78363!Debugger methodsFor: 'context stack menu' stamp: 'md 2/20/2006 20:23'! 78364peelToFirst 78365 "Peel the stack back to the second occurance of the currently selected message. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning. Also frees a lot of space!!" 78366 78367 | ctxt | 78368 contextStackIndex = 0 ifTrue: [^ Beeper beep]. 78369 "self okToChange ifFalse: [^ self]." 78370 ctxt := interruptedProcess popTo: self selectedContext findSecondToOldestSimilarSender. 78371 self resetContext: ctxt. 78372! ! 78373 78374!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'! 78375populateImplementInMenu: aMenu 78376 78377 | msg | 78378 msg := self selectedContext at: 1. 78379 self selectedContext receiver class withAllSuperclasses do: 78380 [:each | 78381 aMenu add: each name target: self selector: #implement:inClass: argumentList: (Array with: msg with: each)]. 78382 ^ aMenu 78383 78384! ! 78385 78386!Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:07'! 78387proceed 78388 "Proceed execution of the receiver's model, starting after the expression at 78389 which an interruption occurred." 78390 78391 Smalltalk okayToProceedEvenIfSpaceIsLow ifTrue: [ 78392 self proceed: self topView]. 78393! ! 78394 78395!Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:29'! 78396proceed: aTopView 78397 "Proceed from the interrupted state of the currently selected context. The 78398 argument is the topView of the receiver. That view is closed." 78399 78400 self okToChange ifFalse: [^ self]. 78401 self checkContextSelection. 78402 self resumeProcess: aTopView! ! 78403 78404!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'! 78405restart 78406 "Proceed from the initial state of the currently selected context. The 78407 argument is a controller on a view of the receiver. That view is closed." 78408 "Closing now depends on a preference #restartAlsoProceeds - hmm 9/7/2001 16:46" 78409 78410 | ctxt noUnwindError | 78411 self okToChange ifFalse: [^ self]. 78412 self checkContextSelection. 78413 ctxt := interruptedProcess popTo: self selectedContext. 78414 noUnwindError := false. 78415 ctxt == self selectedContext ifTrue: [ 78416 noUnwindError := true. 78417 interruptedProcess restartTop; stepToSendOrReturn]. 78418 self resetContext: ctxt. 78419 (Preferences restartAlsoProceeds and: [noUnwindError]) ifTrue: [self proceed]. 78420! ! 78421 78422!Debugger methodsFor: 'context stack menu' stamp: 'rbb 3/1/2005 10:50'! 78423returnValue 78424 "Force a return of a given value to the previous context!!" 78425 78426 | previous selectedContext expression value | 78427 contextStackIndex = 0 ifTrue: [^Beeper beep]. 78428 selectedContext := self selectedContext. 78429 expression := UIManager default request: 'Enter expression for return value:'. 78430 value := Compiler new 78431 evaluate: expression 78432 in: selectedContext 78433 to: selectedContext receiver. 78434 previous := selectedContext sender. 78435 self resetContext: previous. 78436 interruptedProcess popTo: previous value: value! ! 78437 78438!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'! 78439selectPC 78440 "Toggle the flag telling whether to automatically select the expression 78441 currently being executed by the selected context." 78442 78443 selectingPC := selectingPC not! ! 78444 78445!Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:29'! 78446send 78447 "Send the selected message in the accessed method, and take control in 78448 the method invoked to allow further step or send." 78449 78450 self okToChange ifFalse: [^ self]. 78451 self checkContextSelection. 78452 interruptedProcess step: self selectedContext. 78453 self resetContext: interruptedProcess stepToSendOrReturn. 78454! ! 78455 78456!Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:46'! 78457stepIntoBlock 78458 "Send messages until you return to the present method context. 78459 Used to step into a block in the method." 78460 78461 interruptedProcess stepToHome: self selectedContext. 78462 self resetContext: interruptedProcess stepToSendOrReturn.! ! 78463 78464!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:55'! 78465up 78466 "move up the context stack to the next (enclosed) context" 78467 78468 contextStackIndex > 1 ifTrue: [self toggleContextStackIndex: contextStackIndex-1]! ! 78469 78470!Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'! 78471where 78472 "Select the expression whose evaluation was interrupted." 78473 78474 selectingPC := true. 78475 self contextStackIndex: contextStackIndex oldContextWas: self selectedContext 78476! ! 78477 78478 78479!Debugger methodsFor: 'dependents access' stamp: 'di 1/14/1999 09:28'! 78480step 78481 "Update the inspectors." 78482 78483 receiverInspector ifNotNil: [receiverInspector step]. 78484 contextVariablesInspector ifNotNil: [contextVariablesInspector step]. 78485! ! 78486 78487!Debugger methodsFor: 'dependents access' stamp: 'hmm 7/15/2001 19:48'! 78488updateInspectors 78489 "Update the inspectors on the receiver's variables." 78490 78491 receiverInspector == nil ifFalse: [receiverInspector update]. 78492 contextVariablesInspector == nil ifFalse: [contextVariablesInspector update]! ! 78493 78494!Debugger methodsFor: 'dependents access' stamp: 'di 1/14/1999 09:25'! 78495wantsSteps 78496 78497 ^ true! ! 78498 78499 78500!Debugger methodsFor: 'initialize' stamp: 'stephane.ducasse 10/26/2008 15:42'! 78501buildNotifierLabelled: label message: messageString 78502 | notifyPane window contentTop extentToUse | 78503 self expandStack. 78504 window := (PreDebugWindow labelled: label) model: self. 78505 78506 contentTop := 0.25. 78507 extentToUse := 450 @ 156. "nice and wide to show plenty of the error msg" 78508 window addMorph: (self buttonRowForPreDebugWindow: window) 78509 frame: (0@0 corner: 1 @ contentTop). 78510 78511 messageString notNil 78512 ifFalse: 78513 [notifyPane := PluggableListMorph on: self list: #contextStackList 78514 selected: #contextStackIndex changeSelected: #debugAt: 78515 menu: nil keystroke: nil] 78516 ifTrue: 78517 [notifyPane := PluggableTextMorph on: self text: nil accept: nil 78518 readSelection: nil menu: #debugProceedMenu:. 78519 notifyPane editString: (self preDebugNotifierContentsFrom: messageString); 78520 askBeforeDiscardingEdits: false]. 78521 78522 window addMorph: notifyPane frame: (0@contentTop corner: 1@1). 78523 "window deleteCloseBox. 78524 chickened out by commenting the above line out, sw 8/14/2000 12:54" 78525 window setBalloonTextForCloseBox. 78526 78527 ^ window openInWorldExtent: extentToUse! ! 78528 78529!Debugger methodsFor: 'initialize' stamp: 'hfm 12/21/2008 22:44'! 78530customButtonSpecs 78531 "Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger." 78532 78533 | list | 78534 list := #(('Proceed' proceed 'close the debugger and proceed.') 78535 ('Restart' restart 'reset this context to its start.') 78536 ('Into' send 'step Into message sends') 78537 ('Over' doStep 'step Over message sends') 78538 ('Through' stepIntoBlock 'step into a block') 78539 ('Full Stack' fullStack 'show full stack') 78540 ('Run to Here' runToSelection 'run to selection') 78541 ('Where' where 'select current pc range')). 78542 Preferences restartAlsoProceeds ifTrue: 78543 [list := list collect: [:each | 78544 each second == #restart 78545 ifTrue: [each copy at: 3 put: 'proceed from the beginning of this context.'; yourself] 78546 ifFalse: [each]]]. 78547 ^ list! ! 78548 78549!Debugger methodsFor: 'initialize' stamp: 'kfr 10/4/2000 22:13'! 78550debugAt: anInteger 78551 self toggleContextStackIndex: anInteger. 78552 ^ self debug.! ! 78553 78554!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'! 78555errorWasInUIProcess: boolean 78556 78557 errorWasInUIProcess := boolean! ! 78558 78559!Debugger methodsFor: 'initialize' stamp: 'tk 5/9/2003 11:20'! 78560initialExtent 78561 "Make the full debugger longer!!" 78562 78563 dependents size < 9 ifTrue: [^ super initialExtent]. "Pre debug window" 78564 RealEstateAgent standardWindowExtent y < 400 "a tiny screen" 78565 ifTrue: [^ super initialExtent]. 78566 78567 ^ 600@700 78568! ! 78569 78570!Debugger methodsFor: 'initialize' stamp: 'sw 12/28/1999 13:07'! 78571notifierButtonHeight 78572 78573 ^ 18! ! 78574 78575!Debugger methodsFor: 'initialize' stamp: 'wiz 2/25/2006 20:22'! 78576openFullMorphicLabel: aLabelString 78577 "Open a full morphic debugger with the given label" 78578 78579 | window aListMorph oldContextStackIndex | 78580 oldContextStackIndex := contextStackIndex. 78581 self expandStack. "Sets contextStackIndex to zero." 78582 78583 window := (SystemWindow labelled: aLabelString) model: self. 78584 aListMorph := PluggableListMorph on: self list: #contextStackList 78585 selected: #contextStackIndex changeSelected: #toggleContextStackIndex: 78586 menu: #contextStackMenu:shifted: keystroke: #contextStackKey:from:. 78587 aListMorph menuTitleSelector: #messageListSelectorTitle. 78588 window addMorph: aListMorph 78589 frame: (0@0 corner: 1@0.25). 78590 78591 self addLowerPanesTo: window at: (0@0.25 corner: 1@0.8) with: nil. 78592 78593 window addMorph: (( 78594 PluggableListMorph new 78595 doubleClickSelector: #inspectSelection; 78596 78597 on: self receiverInspector list: #fieldList 78598 selected: #selectionIndex changeSelected: #toggleIndex: 78599 menu: #fieldListMenu: keystroke: #inspectorKey:from:) 78600 autoDeselect: false) 78601 "For doubleClick to work best disable autoDeselect" 78602 78603 frame: (0@0.8 corner: 0.2@1). 78604 window addMorph: (PluggableTextMorph on: self receiverInspector 78605 text: #contents accept: #accept: 78606 readSelection: #contentsSelection menu: #codePaneMenu:shifted:) 78607 frame: (0.2@0.8 corner: 0.5@1). 78608 window addMorph: ( 78609 PluggableListMorph new 78610 doubleClickSelector: #inspectSelection; 78611 78612 on: self contextVariablesInspector list: #fieldList 78613 selected: #selectionIndex changeSelected: #toggleIndex: 78614 menu: #fieldListMenu: keystroke: #inspectorKey:from:) 78615 frame: (0.5@0.8 corner: 0.7@1). 78616 window addMorph: (PluggableTextMorph on: self contextVariablesInspector 78617 text: #contents accept: #accept: 78618 readSelection: #contentsSelection menu: #codePaneMenu:shifted:) 78619 frame: (0.7@0.8 corner: 1@1). 78620 window openInWorld. 78621 self toggleContextStackIndex: oldContextStackIndex. 78622 ^ window ! ! 78623 78624!Debugger methodsFor: 'initialize' stamp: 'alain.plantec 5/30/2008 11:45'! 78625openFullNoSuspendLabel: aString 78626 "Create and schedule a full debugger with the given label. Do not 78627 terminate the current active process." 78628 self openFullMorphicLabel: aString. 78629 errorWasInUIProcess := Project spawnNewProcessIfThisIsUI: interruptedProcess! ! 78630 78631!Debugger methodsFor: 'initialize' stamp: 'alain.plantec 5/30/2008 11:51'! 78632openNotifierContents: msgString label: label 78633 "Create and schedule a notifier view with the given label and message. 78634 A notifier view shows just the message or the first several lines of the 78635 stack, with a menu that allows the user to open a full debugger if so 78636 desired. " 78637 "NOTE: When this method returns, a new process has been scheduled to 78638 run the windows, and thus this notifier, but the previous active porcess 78639 has not been suspended. The sender will do this." 78640 | msg | 78641 Sensor flushKeyboard. 78642 savedCursor := Sensor currentCursor. 78643 Sensor currentCursor: Cursor normal. 78644 (label beginsWith: 'Space is low') 78645 ifTrue: [msg := self lowSpaceChoices 78646 , (msgString 78647 ifNil: [''])] 78648 ifFalse: [msg := msgString]. 78649 isolationHead 78650 ifNotNil: ["We have already revoked the isolation layer -- now jump to the 78651 parent project." 78652 msg := self isolationRecoveryAdvice , msgString. 78653 failedProject := Project current. 78654 isolationHead parent enterForEmergencyRecovery]. 78655 self buildNotifierLabelled: label message: msg. 78656 errorWasInUIProcess := Project spawnNewProcessIfThisIsUI: interruptedProcess! ! 78657 78658!Debugger methodsFor: 'initialize' stamp: 'sbw 12/23/1999 09:50'! 78659optionalAnnotationHeight 78660 78661 ^ 10! ! 78662 78663!Debugger methodsFor: 'initialize' stamp: 'stephane.ducasse 10/26/2008 15:32'! 78664preDebugButtonQuads 78665 ^ { 78666 {'Proceed' translated. #proceed. #blue. 'continue execution' translated}. 78667 {'Abandon' translated. #abandon. #black. 'abandon this execution by closing this window' translated}. 78668 {'Debug' translated. #debug. #red. 'bring up a debugger' translated} 78669 } 78670! ! 78671 78672!Debugger methodsFor: 'initialize' stamp: 'stephane.ducasse 10/26/2008 15:33'! 78673preDebugNotifierContentsFrom: messageString 78674 78675 ^ messageString 78676 ! ! 78677 78678!Debugger methodsFor: 'initialize' stamp: 'jm 8/20/1998 18:31'! 78679release 78680 78681 self windowIsClosing. 78682 super release. 78683! ! 78684 78685!Debugger methodsFor: 'initialize' stamp: 'sw 1/24/2001 21:22'! 78686wantsOptionalButtons 78687 "The debugger benefits so majorly from the optional buttons that we put them up regardless of the global setting. Some traditionalists will want to change this method manually!!" 78688 78689 ^ true! ! 78690 78691!Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'! 78692windowIsClosing 78693 "My window is being closed; clean up. Restart the low space watcher." 78694 78695 interruptedProcess == nil ifTrue: [^ self]. 78696 interruptedProcess terminate. 78697 interruptedProcess := nil. 78698 interruptedController := nil. 78699 contextStack := nil. 78700 contextStackTop := nil. 78701 receiverInspector := nil. 78702 contextVariablesInspector := nil. 78703 Smalltalk installLowSpaceWatcher. "restart low space handler" 78704! ! 78705 78706 78707!Debugger methodsFor: 'notifier menu' stamp: 'alain.plantec 5/30/2008 11:43'! 78708debug 78709 "Open a full DebuggerView." 78710 | topView | 78711 topView := self topView. 78712 topView model: nil. 78713 "so close won't release me." 78714 self breakDependents. 78715 topView delete. 78716 ^ self openFullMorphicLabel: topView label! ! 78717 78718!Debugger methodsFor: 'notifier menu' stamp: 'adrian_lienhard 7/18/2009 15:54'! 78719storeLog 78720 | logFileName | 78721 logFileName := Preferences debugLogTimestamp 78722 ifTrue: ['PharoDebug-' , Time totalSeconds printString , '.log'] 78723 ifFalse: ['PharoDebug.log']. 78724 Smalltalk logError: labelString printString inContext: contextStackTop to: logFileName 78725 ! ! 78726 78727 78728!Debugger methodsFor: 'tally support' stamp: 'ab 3/23/2005 16:43'! 78729getSelectedText 78730 | m interval text | 78731 m := self getTextMorph. 78732 interval := m selectionInterval. 78733 text := m text. 78734 ^ text copyFrom: interval first to: interval last 78735 ! ! 78736 78737!Debugger methodsFor: 'tally support' stamp: 'ab 3/23/2005 16:43'! 78738getTextMorph 78739 ^ (self dependents select: [:m| m class == PluggableTextMorph]) first! ! 78740 78741!Debugger methodsFor: 'tally support' stamp: 'ab 3/23/2005 16:42'! 78742tally 78743 78744 self getTextMorph tallyIt. 78745! ! 78746 78747 78748!Debugger methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 18:30'! 78749buildFullWith: builder 78750 | windowSpec listSpec textSpec panelSpec extent | 78751 windowSpec := builder pluggableWindowSpec new. 78752 windowSpec model: self. 78753 windowSpec label: 'Debugger'. 78754 Display height < 800 "a small screen" 78755 ifTrue:[extent := RealEstateAgent standardWindowExtent] 78756 ifFalse:[extent := 600@700]. 78757 windowSpec extent: extent. 78758 windowSpec children: OrderedCollection new. 78759 78760 listSpec := builder pluggableListSpec new. 78761 listSpec 78762 model: self; 78763 list: #contextStackList; 78764 getIndex: #contextStackIndex; 78765 setIndex: #toggleContextStackIndex:; 78766 menu: #contextStackMenu:shifted:; 78767 keyPress: #contextStackKey:from:; 78768 frame: (0@0 corner: 1@0.25). 78769 windowSpec children add: listSpec. 78770 78771 78772 panelSpec := self buildOptionalButtonsWith: builder. 78773 panelSpec frame: (0@0.25 corner: 1@0.3). 78774 windowSpec children add: panelSpec. 78775 78776 textSpec := builder pluggableTextSpec new. 78777 textSpec 78778 model: self; 78779 getText: #contents; 78780 setText: #contents:notifying:; 78781 selection: #contentsSelection; 78782 menu: #codePaneMenu:shifted:; 78783 frame: (0@0.3corner: 1@0.8). 78784 windowSpec children add: textSpec. 78785 78786 listSpec := builder pluggableListSpec new. 78787 listSpec 78788 model: self receiverInspector; 78789 list: #fieldList; 78790 getIndex: #selectionIndex; 78791 setIndex: #toggleIndex:; 78792 menu: #fieldListMenu:; 78793 keyPress: #inspectorKey:from:; 78794 frame: (0@0.8 corner: 0.2@1). 78795 windowSpec children add: listSpec. 78796 78797 textSpec := builder pluggableTextSpec new. 78798 textSpec 78799 model: self receiverInspector; 78800 getText: #contents; 78801 setText: #accept:; 78802 selection: #contentsSelection; 78803 menu: #codePaneMenu:shifted:; 78804 frame: (0.2@0.8 corner: 0.5@1). 78805 windowSpec children add: textSpec. 78806 78807 listSpec := builder pluggableListSpec new. 78808 listSpec 78809 model: self contextVariablesInspector; 78810 list: #fieldList; 78811 getIndex: #selectionIndex; 78812 setIndex: #toggleIndex:; 78813 menu: #fieldListMenu:; 78814 keyPress: #inspectorKey:from:; 78815 frame: (0.5@0.8 corner: 0.7@1). 78816 windowSpec children add: listSpec. 78817 78818 textSpec := builder pluggableTextSpec new. 78819 textSpec 78820 model: self contextVariablesInspector; 78821 getText: #contents; 78822 setText: #accept:; 78823 selection: #contentsSelection; 78824 menu: #codePaneMenu:shifted:; 78825 frame: (0.7@0.8 corner: 1@1). 78826 windowSpec children add: textSpec. 78827 78828 ^builder build: windowSpec! ! 78829 78830!Debugger methodsFor: 'toolbuilder' stamp: 'stephane.ducasse 10/26/2008 15:42'! 78831buildNotifierWith: builder label: label message: messageString 78832 | windowSpec listSpec textSpec panelSpec buttonSpec | 78833 windowSpec := builder pluggableWindowSpec new. 78834 windowSpec model: self. 78835 windowSpec extent: 450 @ 156. "nice and wide to show plenty of the error msg" 78836 windowSpec label: label. 78837 windowSpec children: OrderedCollection new. 78838 78839 panelSpec := builder pluggablePanelSpec new. 78840 panelSpec children: OrderedCollection new. 78841 self preDebugButtonQuads do:[:spec| 78842 buttonSpec := builder pluggableButtonSpec new. 78843 buttonSpec model: self. 78844 buttonSpec label: spec first. 78845 buttonSpec action: spec second. 78846 buttonSpec help: spec fourth. 78847 panelSpec children add: buttonSpec. 78848 ]. 78849 panelSpec layout: #horizontal. "buttons" 78850 panelSpec frame: (0@0 corner: 1@0.2). 78851 windowSpec children add: panelSpec. 78852 78853 messageString notNil ifTrue:[ 78854 listSpec := builder pluggableListSpec new. 78855 listSpec 78856 model: self; 78857 list: #contextStackList; 78858 getIndex: #contextStackIndex; 78859 setIndex: #debugAt:; 78860 frame: (0@0.2 corner: 1@1). 78861 windowSpec children add: listSpec. 78862 ] ifFalse:[ 78863 textSpec := builder pluggableTextSpec new. 78864 textSpec 78865 model: self; 78866 getText: #preDebugMessageString; 78867 setText: nil; 78868 selection: nil; 78869 menu: #debugProceedMenu:; 78870 frame: (0@0.2corner: 1@1). 78871 windowSpec children add: textSpec. 78872 ]. 78873 78874 ^windowSpec! ! 78875 78876!Debugger methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 16:24'! 78877buildWith: aBuilder 78878 ^self buildFullWith: aBuilder! ! 78879 78880!Debugger methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 16:25'! 78881preDebugMessageString 78882 ^'An error has occurred; you should probably just hit ''abandon''. Sorry!!'! ! 78883 78884 78885!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! 78886askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock 78887 | classes chosenClassIndex | 78888 classes := aClass withAllSuperclasses. 78889 chosenClassIndex := UIManager default 78890 chooseFrom: (classes collect: [:c | c name]) 78891 title: 'Define #', aSelector, ' in which class?'. 78892 chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. 78893 ^ classes at: chosenClassIndex! ! 78894 78895!Debugger methodsFor: 'private' stamp: 'yo 8/12/2003 16:34'! 78896checkContextSelection 78897 78898 contextStackIndex = 0 ifTrue: [self contextStackIndex: 1 oldContextWas: nil]. 78899! ! 78900 78901!Debugger methodsFor: 'private' stamp: 'eem 3/12/2009 14:55'! 78902contextStackIndex: anInteger oldContextWas: oldContext 78903 "Change the context stack index to anInteger, perhaps in response to user selection." 78904 78905 | isNewMethod selectedContextSlotName index | 78906 contextStackIndex := anInteger. 78907 anInteger = 0 ifTrue: 78908 [currentCompiledMethod := contents := nil. 78909 self changed: #contextStackIndex. 78910 self decorateButtons. 78911 self contentsChanged. 78912 contextVariablesInspector object: nil. 78913 receiverInspector object: self receiver. 78914 ^self]. 78915 selectedContextSlotName := contextVariablesInspector selectedSlotName. 78916 isNewMethod := oldContext == nil 78917 or: [oldContext method ~~ (currentCompiledMethod := self selectedContext method)]. 78918 isNewMethod ifTrue: 78919 [contents := self selectedMessage. 78920 self contentsChanged. 78921 self pcRange]. 78922 self changed: #contextStackIndex. 78923 self decorateButtons. 78924 contextVariablesInspector object: self selectedContext. 78925 ((index := contextVariablesInspector fieldList indexOf: selectedContextSlotName) ~= 0 78926 and: [index ~= contextVariablesInspector selectionIndex]) ifTrue: 78927 [contextVariablesInspector toggleIndex: index]. 78928 receiverInspector object: self receiver. 78929 isNewMethod ifFalse: 78930 [self changed: #contentsSelection]! ! 78931 78932!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! 78933createMethod 78934 "Should only be called when this Debugger was created in response to a 78935 MessageNotUnderstood exception. Create a stub for the method that was 78936 missing and proceed into it." 78937 78938 | msg chosenClass | 78939 msg := contextStackTop tempAt: 1. 78940 chosenClass := self 78941 askForSuperclassOf: contextStackTop receiver class 78942 toImplement: msg selector 78943 ifCancel: [^self]. 78944 self implement: msg inClass: chosenClass. 78945! ! 78946 78947!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! 78948externalInterrupt: aBoolean 78949 78950 externalInterrupt := aBoolean ! ! 78951 78952!Debugger methodsFor: 'private' stamp: 'tk 8/17/2000 15:36'! 78953isolationRecoveryAdvice 78954 "Return a notifier message string to be presented in case of recovery from recursive error by revoking the changes in an isolation layer. This surely ranks as one of Squeak's longer help messages." 78955 78956 ^ 'Warning!! You have encountered a recursive error situation. 78957 78958Don''t panic, but do read the following advice. If you were just fooling around, the simplest thing to do is to quit and NOT save, and restart Squeak. If you care about recovery, then read on... 78959 78960In the process of diagnosing one error, further errors occurred, making it impossible to give you a debugger to work with. Squeak has jumped to an outer project where many of the objects and code changes that might have caused this problem are not involved in normal operation. If you are looking at this window, chances are that this first level of recovery was successful. If there are changes you care a lot about, try to save them now. Then, hopefully, from the state in this debugger, you can determine what the problem was and fix it. Do not save this image until you are confident of its recovery. 78961 78962You are no longer in the world that is damaged. The two most likely causes of recursive errors are malformed objects (for instance a corrupt value encountered in any display of the desktop) and recurring code errors (such as a change that causes errors in any attempt to display the desktop). 78963 78964In the case of malformed objects, you can attempt to repair them by altering various bindings in the corrupted environment. Open this debugger and examine the state of the objects closest to the error. 78965 78966In the case of code errors, note that you are no longer in a world where the erroneous code is in effect. The only simple option available is for you to browse to the changeSet for the project in distress, and remove one or more of the changes (later it will be possible to edit the code remotely from here). 78967 78968If you feel you have repaired the problem, then you may proceed from this debugger. This will put you back in the project that failed with the changes that failed for another try. Note that the debugger from which you are proceeding is the second one that occurred; you will likely find the first one waiting for you when you reenter the failed project!! Also note that if your error occurred while displaying a morph, it may now be flagged as undisplayable (red with yellow cross); if so, use the morph debug menu to choose ''start drawing again''. 78969 78970If you have not repaired the problem, you should close this debugger and delete the failed project after retrieving whatever may be of value in it. 78971 78972Good luck. 78973 78974 - The Squeak Fairy Godmother 78975 78976PS: If you feel you need the help of a quantum mechanic, do NOT close this window. Instead, the best thing to do (after saving anything that seems safe to save) would be to use the ''save as...'' command in the world menu, and give it a new image name, such as OOPS. There is a good chance that someone who knows their way around Squeak can help you out. 78977'! ! 78978 78979!Debugger methodsFor: 'private' stamp: 'adrian_lienhard 7/18/2009 15:53'! 78980lowSpaceChoices 78981 "Return a notifier message string to be presented when space is running low." 78982 78983 ^ 'Warning!! Pharo is almost out of memory!! 78984 78985Low space detection is now disabled. It will be restored when you close or proceed from this error notifier. Don''t panic, but do proceed with caution. 78986 78987Here are some suggestions: 78988 78989 If you suspect an infinite recursion (the same methods calling each other again and again), then close this debugger, and fix the problem. 78990 78991 If you want this computation to finish, then make more space available (read on) and choose "proceed" in this debugger. Here are some ways to make more space available... 78992 > Close any windows that are not needed. 78993 > Get rid of some large objects (e.g., images). 78994 > Leave this window on the screen, choose "save as..." from the screen menu, quit, restart the Pharo VM with a larger memory allocation, then restart the image you just saved, and choose "proceed" in this window. 78995 78996 If you want to investigate further, choose "debug" in this window. Do not use the debugger "fullStack" command unless you are certain that the stack is not very deep. (Trying to show the full stack will definitely use up all remaining memory if the low-space problem is caused by an infinite recursion!!). 78997 78998' 78999! ! 79000 79001!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! 79002newStack: stack 79003 | oldStack diff | 79004 oldStack := contextStack. 79005 contextStack := stack. 79006 (oldStack == nil or: [oldStack last ~~ stack last]) 79007 ifTrue: [contextStackList := contextStack collect: [:ctx | ctx printString]. 79008 ^ self]. 79009 "May be able to re-use some of previous list" 79010 diff := stack size - oldStack size. 79011 contextStackList := diff <= 0 79012 ifTrue: [contextStackList copyFrom: 1-diff to: oldStack size] 79013 ifFalse: [diff > 1 79014 ifTrue: [contextStack collect: [:ctx | ctx printString]] 79015 ifFalse: [(Array with: stack first printString) , contextStackList]]! ! 79016 79017!Debugger methodsFor: 'private' stamp: 'di 4/14/2000 16:24'! 79018process: aProcess controller: aController context: aContext 79019 79020 ^ self process: aProcess controller: aController context: aContext isolationHead: nil! ! 79021 79022!Debugger methodsFor: 'private' stamp: 'alain.plantec 5/30/2008 11:59'! 79023process: aProcess controller: aController context: aContext isolationHead: projectOrNil 79024 super initialize. 79025 Smalltalk 79026 at: #MessageTally 79027 ifPresentAndInMemory: [:c | c new close]. 79028 contents := nil. 79029 interruptedProcess := aProcess. 79030 interruptedController := aController. 79031 contextStackTop := aContext. 79032 self 79033 newStack: (contextStackTop stackOfSize: 1). 79034 contextStackIndex := 1. 79035 externalInterrupt := false. 79036 selectingPC := true. 79037 isolationHead := projectOrNil. 79038 errorWasInUIProcess := false! ! 79039 79040!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! 79041resetContext: aContext 79042 "Used when a new context becomes top-of-stack, for instance when the 79043 method of the selected context is re-compiled, or the simulator steps or 79044 returns to a new method. There is room for much optimization here, first 79045 to save recomputing the whole stack list (and text), and secondly to avoid 79046 recomposing all that text (by editing the paragraph instead of recreating it)." 79047 79048 | oldContext | 79049 oldContext := self selectedContext. 79050 contextStackTop := aContext. 79051 self newStack: contextStackTop contextStack. 79052 self changed: #contextStackList. 79053 self contextStackIndex: 1 oldContextWas: oldContext. 79054 self contentsChanged. 79055! ! 79056 79057!Debugger methodsFor: 'private' stamp: 'alain.plantec 5/30/2008 12:04'! 79058resumeProcess: aTopView 79059 savedCursor 79060 ifNotNil: [Sensor currentCursor: savedCursor]. 79061 isolationHead 79062 ifNotNil: [failedProject enterForEmergencyRecovery. 79063 isolationHead invoke. 79064 isolationHead := nil]. 79065 interruptedProcess isTerminated 79066 ifFalse: [errorWasInUIProcess 79067 ifTrue: [Project resumeProcess: interruptedProcess] 79068 ifFalse: [interruptedProcess resume]]. 79069 "if old process was terminated, just terminate current one" 79070 interruptedProcess := nil. 79071 "Before delete, so release doesn't terminate it" 79072 aTopView delete. 79073 World displayWorld. 79074 Smalltalk installLowSpaceWatcher. 79075 "restart low space handler" 79076 errorWasInUIProcess == false 79077 ifFalse: [Processor terminateActive]! ! 79078 79079!Debugger methodsFor: 'private'! 79080selectedContext 79081 79082 contextStackIndex = 0 79083 ifTrue: [^contextStackTop] 79084 ifFalse: [^contextStack at: contextStackIndex]! ! 79085 79086"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 79087 79088Debugger class 79089 instanceVariableNames: ''! 79090 79091!Debugger class methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:28'! 79092initialize 79093 ErrorRecursion := false. 79094 ContextStackKeystrokes := Dictionary new 79095 at: $e put: #send; 79096 at: $t put: #doStep; 79097 at: $T put: #stepIntoBlock; 79098 at: $p put: #proceed; 79099 at: $r put: #restart; 79100 at: $f put: #fullStack; 79101 at: $w put: #where; 79102 yourself. 79103 79104 "Debugger initialize"! ! 79105 79106!Debugger class methodsFor: 'initialization' stamp: 'adrian_lienhard 7/18/2009 15:54'! 79107openContext: aContext label: aString contents: contentsStringOrNil 79108 | isolationHead | 79109 "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." 79110 <primitive: 19> "Simulation guard" 79111 ErrorRecursion not & Preferences logDebuggerStackToFile ifTrue: 79112 [Smalltalk logError: aString inContext: aContext to: 'PharoDebug.log']. 79113 ErrorRecursion ifTrue: 79114 [ErrorRecursion := false. 79115 (isolationHead := Project current isolationHead) 79116 ifNil: [self primitiveError: aString] 79117 ifNotNil: [isolationHead revoke]]. 79118 ErrorRecursion := true. 79119 self informExistingDebugger: aContext label: aString. 79120 (Debugger context: aContext isolationHead: isolationHead) 79121 openNotifierContents: contentsStringOrNil 79122 label: aString. 79123 ErrorRecursion := false. 79124 Processor activeProcess suspend. 79125! ! 79126 79127 79128!Debugger class methodsFor: 'instance creation' stamp: 'di 4/14/2000 16:29'! 79129context: aContext 79130 "Answer an instance of me for debugging the active process starting with the given context." 79131 79132 ^ self context: aContext isolationHead: nil! ! 79133 79134!Debugger class methodsFor: 'instance creation' stamp: 'alain.plantec 5/30/2008 12:06'! 79135context: aContext isolationHead: isolationHead 79136 "Answer an instance of me for debugging the active process starting with the given context." 79137 79138 ^ self new 79139 process: Processor activeProcess 79140 controller: nil 79141 context: aContext 79142 isolationHead: isolationHead 79143! ! 79144 79145!Debugger class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 79146informExistingDebugger: aContext label: aString 79147 "Walking the context chain, we try to find out if we're in a debugger stepping situation. 79148 If we find the relevant contexts, we must rearrange them so they look just like they would 79149 if the methods were excuted outside of the debugger." 79150 | ctx quickStepMethod oldSender baseContext | 79151 ctx := thisContext. 79152 quickStepMethod := ContextPart compiledMethodAt: #quickSend:to:with:super:. 79153 [ctx sender == nil or: [ctx sender method == quickStepMethod]] whileFalse: [ctx := ctx sender]. 79154 ctx sender == nil ifTrue: [^self]. 79155 baseContext := ctx. 79156 "baseContext is now the context created by the #quickSend... method." 79157 oldSender := ctx := ctx sender home sender. 79158 "oldSender is the context which originally sent the #quickSend... method" 79159 [ctx == nil or: [ctx receiver isKindOf: self]] whileFalse: [ctx := ctx sender]. 79160 ctx == nil ifTrue: [^self]. 79161 "ctx is the context of the Debugger method #doStep" 79162 ctx receiver labelString: aString. 79163 ctx receiver externalInterrupt: false; proceedValue: aContext receiver. 79164 baseContext swapSender: baseContext sender sender sender. "remove intervening contexts" 79165 thisContext swapSender: oldSender. "make myself return to debugger" 79166 ErrorRecursion := false. 79167 ^aContext! ! 79168 79169 79170!Debugger class methodsFor: 'opening' stamp: 'stephane.ducasse 10/26/2008 15:30'! 79171openInterrupt: aString onProcess: interruptedProcess 79172 "Open a notifier in response to an interrupt. An interrupt occurs when 79173 the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other 79174 systems) or when the low-space watcher detects that memory is low." 79175 | debugger | 79176 <primitive: 19> 79177 "Simulation guard" 79178 debugger := self new. 79179 debugger 79180 process: interruptedProcess 79181 controller: nil 79182 context: interruptedProcess suspendedContext. 79183 debugger externalInterrupt: true. 79184 Preferences logDebuggerStackToFile 79185 ifTrue: [(aString includesSubString: 'Space') 79186 & (aString includesSubString: 'low') 79187 ifTrue: [Smalltalk 79188 logError: aString 79189 inContext: debugger interruptedContext 79190 to: 'LowSpaceDebug.log']]. 79191 ^ debugger openNotifierContents: nil label: aString! ! 79192 79193!Debugger class methodsFor: 'opening' stamp: 'adrian_lienhard 7/18/2009 15:54'! 79194openOn: process context: context label: title contents: contentsStringOrNil fullView: bool 79195 "Open a notifier in response to an error, halt, or notify. A notifier view 79196 just shows a short view of the sender stack and provides a menu that 79197 lets the user open a full debugger." 79198 | errorWasInUIProcess | 79199 errorWasInUIProcess := Project spawnNewProcessIfThisIsUI: process. 79200 WorldState 79201 addDeferredUIMessage: [[| debugger | 79202 debugger := self new 79203 process: process 79204 controller: nil 79205 context: context. 79206 "schedule debugger in deferred UI message to address 79207 redraw problems after opening a debugger e.g. from 79208 the testrunner." 79209 "WorldState addDeferredUIMessage: [" 79210 bool 79211 ifTrue: [debugger openFullNoSuspendLabel: title] 79212 ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title]. 79213 debugger errorWasInUIProcess: errorWasInUIProcess. 79214 Preferences logDebuggerStackToFile 79215 ifTrue: [Smalltalk 79216 logError: title 79217 inContext: context 79218 to: 'PharoDebug.log']] 79219 on: Error 79220 do: [:ex | self primitiveError: 'Orginal error: ' , title asString , '. 79221 Debugger error: ' 79222 , ([ex description] 79223 on: Error 79224 do: ['a ' , ex class printString]) , ':']]. 79225 process suspend! ! 79226 79227 79228!Debugger class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:10'! 79229windowColorSpecification 79230 "Answer a WindowColorSpec object that declares my preference" 79231 79232 ^ WindowColorSpec classSymbol: self name wording: 'Debugger' brightColor: #lightRed pastelColor: #veryPaleRed helpMessage: 'The system debugger.'! ! 79233Object subclass: #DebuggerMethodMap 79234 instanceVariableNames: 'timestamp methodReference methodNode abstractSourceRanges sortedSourceMap' 79235 classVariableNames: 'MapCache MapCacheEntries' 79236 poolDictionaries: '' 79237 category: 'Tools-Debugger'! 79238!DebuggerMethodMap commentStamp: '<historical>' prior: 0! 79239I am a place-holder for information needed by the Debugger to inspect method activations. I insulate the debugger from details of code generation such as exact bytecode offsets and temporary variable locations. I have two concreate subclasses, one for methods compiled using BlueBook blocks and one for methods compiled using Closures. These classes deal with temporary variable access. My function is to abstract the source map away from actual bytecode pcs to abstract bytecode pcs. 79240 79241To reduce compilation time I try and defer as much computation to access time as possible as instances of me will be created after each compilation. 79242 79243I maintain a WeakIdentityDictionary of method to DebuggerMethodMap to cache maps. I refer to my method through a WeakArray to keep the map cache functional. If the reference from a DebuggerMethodMap to its method were strong then the method would never be dropped from the cache because the reference from its map would keep it alive.! 79244]style[(974)i! 79245 79246 79247!DebuggerMethodMap methodsFor: 'accessing' stamp: 'eem 6/3/2008 12:21'! 79248markRecentlyUsed 79249 timestamp := Time totalSeconds! ! 79250 79251!DebuggerMethodMap methodsFor: 'accessing' stamp: 'eem 6/5/2008 09:21'! 79252method 79253 ^methodReference at: 1! ! 79254 79255!DebuggerMethodMap methodsFor: 'accessing' stamp: 'eem 6/10/2008 09:44'! 79256namedTempAt: index in: aContext 79257 "Answer the value of the temp at index in aContext where index is relative 79258 to the array of temp names answered by tempNamesForContext:" 79259 self subclassResponsibility! ! 79260 79261!DebuggerMethodMap methodsFor: 'accessing' stamp: 'eem 6/10/2008 09:44'! 79262namedTempAt: index put: aValue in: aContext 79263 "Assign the value of the temp at index in aContext where index is relative 79264 to the array of temp names answered by tempNamesForContext:" 79265 self subclassResponsibility! ! 79266 79267!DebuggerMethodMap methodsFor: 'accessing' stamp: 'eem 6/10/2008 09:45'! 79268tempNamesForContext: aContext 79269 "Answer an Array of all the temp names in scope in aContext starting with 79270 the home's first local (the first argument or first temporary if no arguments)." 79271 self subclassResponsibility! ! 79272 79273!DebuggerMethodMap methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 01:12'! 79274tempsAndValuesForContext: aContext 79275 "Return a string of the temporary variabls and their current values" 79276 | aStream | 79277 aStream := (String new: 100) writeStream. 79278 (self tempNamesForContext: aContext) doWithIndex: 79279 [:title :index | 79280 aStream nextPutAll: title; nextPut: $:; space; tab. 79281 aContext print: (self namedTempAt: index in: aContext) on: aStream. 79282 aStream cr]. 79283 ^aStream contents! ! 79284 79285!DebuggerMethodMap methodsFor: 'accessing' stamp: 'eem 6/2/2008 18:32'! 79286timestamp 79287 ^timestamp! ! 79288 79289 79290!DebuggerMethodMap methodsFor: 'initialize-release' stamp: 'eem 6/5/2008 09:21'! 79291forMethod: aMethod "<CompiledMethod>" methodNode: theMethodNode "<MethodNode>" 79292 methodReference := WeakArray with: aMethod. 79293 methodNode := theMethodNode. 79294 self markRecentlyUsed! ! 79295 79296 79297!DebuggerMethodMap methodsFor: 'source mapping' stamp: 'eem 7/29/2008 17:12'! 79298abstractSourceMap 79299 "Answer with a Dictionary of abstractPC <Integer> to sourceRange <Interval>." 79300 | theMethodToScan rawSourceRanges concreteSourceRanges abstractPC scanner client | 79301 abstractSourceRanges ifNotNil: 79302 [^abstractSourceRanges]. 79303 "If the methodNode hasn't had a method generated it doesn't have pcs set in its 79304 nodes so we must generate a new method and might as well use it for scanning." 79305 methodNode rawSourceRangesAndMethodDo: 79306 [:ranges :method| 79307 rawSourceRanges := ranges. 79308 theMethodToScan := method]. 79309 concreteSourceRanges := Dictionary new. 79310 rawSourceRanges keysAndValuesDo: 79311 [:node :range| 79312 node pc ~= 0 ifTrue: 79313 [concreteSourceRanges at: node pc put: range]]. 79314 abstractPC := 1. 79315 abstractSourceRanges := Dictionary new. 79316 scanner := InstructionStream on: theMethodToScan. 79317 client := InstructionClient new. 79318 [(concreteSourceRanges includesKey: scanner pc) ifTrue: 79319 [abstractSourceRanges at: abstractPC put: (concreteSourceRanges at: scanner pc)]. 79320 abstractPC := abstractPC + 1. 79321 scanner interpretNextInstructionFor: client. 79322 scanner atEnd] whileFalse. 79323 ^abstractSourceRanges! ! 79324 79325!DebuggerMethodMap methodsFor: 'source mapping' stamp: 'eem 6/5/2008 16:43'! 79326rangeForPC: contextsConcretePC contextIsActiveContext: contextIsActiveContext 79327 "Answer the indices in the source code for the supplied pc. 79328 If the context is the actve context (is at the hot end of the stack) 79329 then its pc is the current pc. But if the context isn't, because it is 79330 suspended sending a message, then its current pc is the previous pc." 79331 79332 | pc i end | 79333 pc := self method abstractPCForConcretePC: (contextIsActiveContext 79334 ifTrue: [contextsConcretePC] 79335 ifFalse: [(self method pcPreviousTo: contextsConcretePC) 79336 ifNotNil: [:prevpc| prevpc] 79337 ifNil: [contextsConcretePC]]). 79338 (self abstractSourceMap includesKey: pc) ifTrue: 79339 [^self abstractSourceMap at: pc]. 79340 sortedSourceMap ifNil: 79341 [sortedSourceMap := self abstractSourceMap. 79342 sortedSourceMap := (sortedSourceMap keys collect: 79343 [:key| key -> (sortedSourceMap at: key)]) asSortedCollection]. 79344 (sortedSourceMap isNil or: [sortedSourceMap isEmpty]) ifTrue: [^1 to: 0]. 79345 i := sortedSourceMap indexForInserting: (pc -> nil). 79346 i < 1 ifTrue: [^1 to: 0]. 79347 i > sortedSourceMap size ifTrue: 79348 [end := sortedSourceMap inject: 0 into: 79349 [:prev :this | prev max: this value last]. 79350 ^end+1 to: end]. 79351 ^(sortedSourceMap at: i) value 79352 79353 "| method source scanner map | 79354 method := DebuggerMethodMap compiledMethodAt: #rangeForPC:contextIsActiveContext:. 79355 source := method getSourceFromFile asString. 79356 scanner := InstructionStream on: method. 79357 map := method debuggerMap. 79358 Array streamContents: 79359 [:ranges| 79360 [scanner atEnd] whileFalse: 79361 [| range | 79362 range := map rangeForPC: scanner pc contextIsActiveContext: true. 79363 ((map abstractSourceMap includesKey: scanner abstractPC) 79364 and: [range first ~= 0]) ifTrue: 79365 [ranges nextPut: (source copyFrom: range first to: range last)]. 79366 scanner interpretNextInstructionFor: InstructionClient new]]"! ! 79367 79368!DebuggerMethodMap methodsFor: 'source mapping' stamp: 'eem 7/6/2009 10:13'! 79369sourceText 79370 self method ifNotNil: 79371 [:method| 79372 method holdsTempNames ifTrue: 79373 [^method 79374 getSourceFor: (method selector ifNil: [method defaultSelector]) 79375 in: method methodClass]]. 79376 ^methodNode sourceText! ! 79377 79378"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 79379 79380DebuggerMethodMap class 79381 instanceVariableNames: ''! 79382 79383!DebuggerMethodMap class methodsFor: 'class initialization' stamp: 'eem 6/5/2008 09:14'! 79384initialize 79385 "DebuggerMethodMap initialize" 79386 79387 self voidMapCache! ! 79388 79389!DebuggerMethodMap class methodsFor: 'class initialization' stamp: 'eem 6/5/2008 09:14'! 79390voidMapCache 79391 MapCache := WeakIdentityKeyDictionary new. 79392 MapCacheEntries := 16! ! 79393 79394 79395!DebuggerMethodMap class methodsFor: 'debugger support' stamp: 'eem 6/26/2008 22:59'! 79396cacheDebugMap: aDebuggerMethodMap forMethod: aCompiledMethod 79397 MapCache finalizeValues. 79398 [MapCache size >= MapCacheEntries] whileTrue: 79399 [| mapsByAge | 79400 mapsByAge := MapCache keys asSortedCollection: 79401 [:m1 :m2| 79402 (MapCache at: m1) timestamp 79403 < (MapCache at: m2) timestamp]. 79404 mapsByAge notEmpty ifTrue: "There be race conditions and reentrancy issues here" 79405 [MapCache removeKey: mapsByAge last]]. 79406 79407 ^MapCache 79408 at: aCompiledMethod 79409 put: aDebuggerMethodMap! ! 79410 79411 79412!DebuggerMethodMap class methodsFor: 'instance creation' stamp: 'eem 6/5/2008 09:19'! 79413forMethod: aMethod "<CompiledMethod>" 79414 "Answer a DebuggerMethodMap suitable for debugging activations of aMethod. 79415 Answer an existing instance from the cache if it exists, cacheing a new one if required." 79416 ^MapCache 79417 at: aMethod 79418 ifAbsent: [self 79419 cacheDebugMap: 79420 (self 79421 forMethod: aMethod 79422 methodNode: aMethod methodNode) 79423 forMethod: aMethod]! ! 79424 79425!DebuggerMethodMap class methodsFor: 'instance creation' stamp: 'eem 7/29/2008 16:54'! 79426forMethod: aMethod "<CompiledMethod>" methodNode: methodNode "<MethodNode>" 79427 "Uncached instance creation method for private use or for tests. 79428 Please consider using forMethod: instead." 79429 ^(aMethod isBlueBookCompiled 79430 ifTrue: [DebuggerMethodMapForBlueBookMethods] 79431 ifFalse: [DebuggerMethodMapForClosureCompiledMethods]) new 79432 forMethod: aMethod 79433 methodNode: methodNode! ! 79434DebuggerMethodMap subclass: #DebuggerMethodMapForBlueBookMethods 79435 instanceVariableNames: 'tempNames' 79436 classVariableNames: '' 79437 poolDictionaries: '' 79438 category: 'Tools-Debugger'! 79439!DebuggerMethodMapForBlueBookMethods commentStamp: '<historical>' prior: 0! 79440I am a place-holder for information needed by the Debugger to inspect method activations. See my superclass's comment. I map methods compiled using Closures.! 79441]style[(158)i! 79442 79443 79444!DebuggerMethodMapForBlueBookMethods methodsFor: 'accessing' stamp: 'eem 6/3/2008 11:43'! 79445namedTempAt: index in: aContext 79446 "Answer the value of the temp at index in aContext where index is relative 79447 to the array of temp names answered by tempNamesForContext:" 79448 ^aContext tempAt: index! ! 79449 79450!DebuggerMethodMapForBlueBookMethods methodsFor: 'accessing' stamp: 'eem 6/3/2008 11:43'! 79451namedTempAt: index put: aValue in: aContext 79452 "Assign the value of the temp at index in aContext where index is relative 79453 to the array of temp names answered by tempNamesForContext:" 79454 ^aContext tempAt: index put: aValue! ! 79455 79456!DebuggerMethodMapForBlueBookMethods methodsFor: 'accessing' stamp: 'eem 6/3/2008 11:42'! 79457tempNamesForContext: aContext 79458 "Answer an Array of all the temp names in scope in aContext starting with 79459 the home's first local (the first argument or first temporary if no arguments)." 79460 ^tempNames! ! 79461 79462 79463!DebuggerMethodMapForBlueBookMethods methodsFor: 'initialize-release' stamp: 'eem 6/5/2008 10:34'! 79464forMethod: aMethod "<CompiledMethod>" methodNode: aMethodNode "<MethodNode>" 79465 super forMethod: aMethod methodNode: aMethodNode. 79466 tempNames := methodNode encoder tempNames! ! 79467DebuggerMethodMap subclass: #DebuggerMethodMapForClosureCompiledMethods 79468 instanceVariableNames: 'blockExtentsToTempRefs startpcsToTempRefs' 79469 classVariableNames: 'FirstTime' 79470 poolDictionaries: '' 79471 category: 'Tools-Debugger'! 79472!DebuggerMethodMapForClosureCompiledMethods commentStamp: '<historical>' prior: 0! 79473I am a place-holder for information needed by the Debugger to inspect method activations. See my superclass's comment. I map methods compiled using BlueBook blocks. 79474 79475Instance variables 79476 blockExtentsToTempsRefs <Dictionary of: Interval -> Array of: (Array with: String with: (Integer | (Array with: Integer with: Integer)))> 79477 maps a block extent to an Array of temp references for that block/method. 79478 Each reference is a pair of temp name and index, where the index can itself be a pair for a remote temp. 79479 startpcsToTempRefs <Dictionary of: Integer -> Array of: (Array with: String with: temp reference)> where 79480 temp reference ::= Integer 79481 | (Array with: Integer with: Integer) 79482 | (Array with: #outer with: temp reference)! 79483]style[(167 569)i,cblack;! 79484 79485 79486!DebuggerMethodMapForClosureCompiledMethods methodsFor: 'accessing' stamp: 'eem 7/29/2008 19:28'! 79487namedTempAt: index in: aContext 79488 "Answer the value of the temp at index in aContext where index is relative 79489 to the array of temp names answered by tempNamesForContext:" 79490 ^self 79491 privateTempAt: index 79492 in: aContext 79493 startpcsToBlockExtents: aContext method startpcsToBlockExtents! ! 79494 79495!DebuggerMethodMapForClosureCompiledMethods methodsFor: 'accessing' stamp: 'eem 7/29/2008 19:33'! 79496namedTempAt: index put: aValue in: aContext 79497 "Assign the value of the temp at index in aContext where index is relative 79498 to the array of temp names answered by tempNamesForContext:. 79499 If the value is a copied value we also need to set it along the lexical chain." 79500 ^self 79501 privateTempAt: index 79502 in: aContext 79503 put: aValue 79504 startpcsToBlockExtents: aContext method startpcsToBlockExtents! ! 79505 79506!DebuggerMethodMapForClosureCompiledMethods methodsFor: 'accessing' stamp: 'eem 7/29/2008 18:26'! 79507tempNamesForContext: aContext 79508 "Answer an Array of all the temp names in scope in aContext starting with 79509 the home's first local (the first argument or first temporary if no arguments)." 79510 ^(self 79511 privateTempRefsForContext: aContext 79512 startpcsToBlockExtents: aContext method startpcsToBlockExtents) collect: 79513 [:pair| pair first]! ! 79514 79515!DebuggerMethodMapForClosureCompiledMethods methodsFor: 'accessing' stamp: 'JorgeRessia 10/18/2009 12:41'! 79516tempNamesScopedForContext: aContext 79517 "Answer an Array of all the temp names in scope in aContext starting with 79518 the home's first local (the first argument or first temporary if no arguments)." 79519 ^((self 79520 privateTempRefsForContext: aContext 79521 startpcsToBlockExtents: aContext method startpcsToBlockExtents) reject: [:pair | self privateIsOuter: pair] ) 79522 collect: 79523 [:pair| pair first]! ! 79524 79525 79526!DebuggerMethodMapForClosureCompiledMethods methodsFor: 'private' stamp: 'eem 7/29/2008 20:09'! 79527ensureExtentsMapsInitialized 79528 | encoderTempRefs "<Dictionary of: Interval -> <Array of: <String | <Array of: String>>>>" | 79529 blockExtentsToTempRefs ifNotNil: [^self]. 79530 blockExtentsToTempRefs := Dictionary new. 79531 startpcsToTempRefs := Dictionary new. 79532 encoderTempRefs := methodNode blockExtentsToTempRefs. 79533 encoderTempRefs keysAndValuesDo: 79534 [:blockExtent :tempVector| 79535 blockExtentsToTempRefs 79536 at: blockExtent 79537 put: (Array streamContents: 79538 [:stream| 79539 tempVector withIndexDo: 79540 [:nameOrSequence :index| 79541 nameOrSequence isString 79542 ifTrue: 79543 [stream nextPut: {nameOrSequence. index}] 79544 ifFalse: 79545 [nameOrSequence withIndexDo: 79546 [:name :indirectIndex| 79547 stream nextPut: { name. { index. indirectIndex }}]]]])]! ! 79548 79549!DebuggerMethodMapForClosureCompiledMethods methodsFor: 'private' stamp: 'eem 7/29/2008 19:26'! 79550privateDereference: tempReference in: aContext 79551 "Fetch the temporary with reference tempReference in aContext. 79552 tempReference can be 79553 integer - direct temp reference 79554 #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index 79555 #( outer. temp reference ) - a temp reference in an outer context." 79556 ^tempReference isInteger 79557 ifTrue: [aContext tempAt: tempReference] 79558 ifFalse: 79559 [tempReference first == #outer 79560 ifTrue: [self privateDereference: tempReference last 79561 in: aContext outerContext] 79562 ifFalse: [(aContext tempAt: tempReference first) 79563 at: tempReference second]]! ! 79564 79565!DebuggerMethodMapForClosureCompiledMethods methodsFor: 'private' stamp: 'eem 7/29/2008 19:26'! 79566privateDereference: tempReference in: aContext put: aValue 79567 "Assign the temporary with reference tempReference in aContext. 79568 tempReference can be 79569 integer - direct temp reference 79570 #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index 79571 #( outer. temp reference ) - a temp reference in an outer context." 79572 ^tempReference isInteger 79573 ifTrue: [aContext tempAt: tempReference put: aValue] 79574 ifFalse: 79575 [tempReference first == #outer 79576 ifTrue: [self privateDereference: tempReference last 79577 in: aContext outerContext 79578 put: aValue] 79579 ifFalse: [(aContext tempAt: tempReference first) 79580 at: tempReference second 79581 put: aValue]]! ! 79582 79583!DebuggerMethodMapForClosureCompiledMethods methodsFor: 'private' stamp: 'JorgeRessia 10/17/2009 18:32'! 79584privateIsOuter: anObject 79585 ^anObject last isArray and: [anObject last first == #outer]! ! 79586 79587!DebuggerMethodMapForClosureCompiledMethods methodsFor: 'private' stamp: 'eem 7/29/2008 20:03'! 79588privateTempAt: index in: aContext put: aValue startpcsToBlockExtents: theContextsStartpcsToBlockExtents 79589 | nameRefPair | 79590 nameRefPair := (self privateTempRefsForContext: aContext 79591 startpcsToBlockExtents: theContextsStartpcsToBlockExtents) 79592 at: index 79593 ifAbsent: [aContext errorSubscriptBounds: index]. 79594 ^self privateDereference: nameRefPair last in: aContext put: aValue! ! 79595 79596!DebuggerMethodMapForClosureCompiledMethods methodsFor: 'private' stamp: 'eem 7/29/2008 20:02'! 79597privateTempAt: index in: aContext startpcsToBlockExtents: theContextsStartpcsToBlockExtents 79598 | nameRefPair | 79599 nameRefPair := (self privateTempRefsForContext: aContext 79600 startpcsToBlockExtents: theContextsStartpcsToBlockExtents) 79601 at: index 79602 ifAbsent: [aContext errorSubscriptBounds: index]. 79603 ^self privateDereference: nameRefPair last in: aContext! ! 79604 79605!DebuggerMethodMapForClosureCompiledMethods methodsFor: 'private' stamp: 'eem 7/6/2009 10:14'! 79606privateTempRefsForContext: aContext startpcsToBlockExtents: theContextsStartpcsToBlockExtents 79607 "Answer the sequence of temps in scope in aContext in the natural order, 79608 outermost arguments and temporaries first, innermost last. Each temp is 79609 a pair of the temp's name followed by a reference. The reference can be 79610 integer - index of temp in aContext 79611 #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index in aContext 79612 #( outer. temp reference ) - a temp reference in an outer context." 79613 blockExtentsToTempRefs ifNil: 79614 [blockExtentsToTempRefs := (aContext method holdsTempNames 79615 ifTrue: [aContext method] 79616 ifFalse: [methodNode]) blockExtentsToTempsMap. 79617 startpcsToTempRefs := Dictionary new]. 79618 ^startpcsToTempRefs 79619 at: aContext startpc 79620 ifAbsentPut: 79621 [| localRefs | 79622 localRefs := blockExtentsToTempRefs at: (theContextsStartpcsToBlockExtents at: aContext startpc). 79623 aContext outerContext 79624 ifNil: [localRefs] 79625 ifNotNil: 79626 [:outer| | outerTemps | 79627 "Present temps in the order outermost to innermost left-to-right, but replace 79628 copied outermost temps with their innermost copies" 79629 outerTemps := (self 79630 privateTempRefsForContext: outer 79631 startpcsToBlockExtents: theContextsStartpcsToBlockExtents) collect: 79632 [:outerPair| 79633 localRefs 79634 detect: [:localPair| outerPair first = localPair first] 79635 ifNone: [{ outerPair first. { #outer. outerPair last } }]]. 79636 outerTemps, 79637 (localRefs reject: [:localPair| outerTemps anySatisfy: [:outerPair| localPair first = outerPair first]])]]! ! 79638TestCase subclass: #DebuggerUnwindBug 79639 instanceVariableNames: '' 79640 classVariableNames: '' 79641 poolDictionaries: '' 79642 category: 'Tests-Tools'! 79643 79644!DebuggerUnwindBug methodsFor: 'as yet unclassified' stamp: 'al 7/14/2008 18:15'! 79645expectedFailures 79646 "See thread http://lists.squeakfoundation.org/pipermail/squeak-dev/2008-June/129360.html" 79647 79648 ^ #(testUnwindDebuggerWithStep)! ! 79649 79650!DebuggerUnwindBug methodsFor: 'as yet unclassified' stamp: 'ar 3/7/2003 01:38'! 79651testUnwindBlock 79652 "test if unwind blocks work properly" 79653 | sema process | 79654 sema := Semaphore forMutualExclusion. 79655 self assert: sema isSignaled. 79656 "deadlock on the semaphore" 79657 process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority. 79658 self deny: sema isSignaled. 79659 "terminate process" 79660 process terminate. 79661 self assert: sema isSignaled. 79662! ! 79663 79664!DebuggerUnwindBug methodsFor: 'as yet unclassified' stamp: 'ar 3/7/2003 01:41'! 79665testUnwindDebugger 79666 "test if unwind blocks work properly when a debugger is closed" 79667 | sema process debugger top | 79668 sema := Semaphore forMutualExclusion. 79669 self assert: sema isSignaled. 79670 process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority. 79671 self deny: sema isSignaled. 79672 79673 "everything set up here - open a debug notifier" 79674 debugger := Debugger openInterrupt: 'test' onProcess: process. 79675 "get into the debugger" 79676 debugger debug. 79677 top := debugger topView. 79678 "set top context" 79679 debugger toggleContextStackIndex: 1. 79680 "close debugger" 79681 top delete. 79682 79683 "and see if unwind protection worked" 79684 self assert: sema isSignaled.! ! 79685 79686!DebuggerUnwindBug methodsFor: 'as yet unclassified' stamp: 'stephane.ducasse 5/25/2008 18:53'! 79687testUnwindDebuggerWithStep 79688 "test if unwind blocks work properly when a debugger is closed" 79689 "self debug:#testUnwindDebuggerWithStep" 79690 | sema process debugger top | 79691 sema := Semaphore forMutualExclusion. 79692 self assert: sema isSignaled. 79693 process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority. 79694 self deny: sema isSignaled. 79695 79696 "everything set up here - open a debug notifier" 79697 debugger := Debugger openInterrupt: 'test' onProcess: process. 79698 "get into the debugger" 79699 debugger debug. 79700 top := debugger topView. 79701 "set top context" 79702 debugger toggleContextStackIndex: 1. 79703 "do single step" 79704 debugger doStep. 79705 "close debugger" 79706 top delete. 79707 79708 "and see if unwind protection worked" 79709 self assert: sema isSignaled.! ! 79710InstructionStream subclass: #Decompiler 79711 instanceVariableNames: 'constructor method instVars tempVars constTable stack statements lastPc exit caseExits lastJumpPc lastReturnPc limit hasValue blockStackBase numLocalTemps blockStartsToTempVars tempVarCount' 79712 classVariableNames: 'ArgumentFlag CascadeFlag CaseFlag IfNilFlag' 79713 poolDictionaries: '' 79714 category: 'Compiler-Kernel'! 79715!Decompiler commentStamp: '<historical>' prior: 0! 79716I decompile a method in three phases: 79717 Reverser: postfix byte codes -> prefix symbolic codes (nodes and atoms) 79718 Parser: prefix symbolic codes -> node tree (same as the compiler) 79719 Printer: node tree -> text (done by the nodes) 79720 79721 79722instance vars: 79723 79724 constructor 79725 method 79726 instVars 79727 tempVars 79728 constTable 79729 stack 79730 statements 79731 lastPc 79732 exit 79733 caseExits - stack of exit addresses that have been seen in the branches of caseOf:'s 79734 lastJumpPc 79735 lastReturnPc 79736 limit 79737 hasValue 79738 blockStackBase 79739 numLocaltemps - number of temps local to a block; also a flag indicating decompiling a block! 79740 79741 79742!Decompiler methodsFor: 'control' stamp: 'tao 8/20/97 22:51'! 79743blockForCaseTo: end 79744 "Decompile a range of code as in statementsForCaseTo:, but return a block node." 79745 | exprs block oldBase | 79746 oldBase := blockStackBase. 79747 blockStackBase := stack size. 79748 exprs := self statementsForCaseTo: end. 79749 block := constructor codeBlock: exprs returns: lastReturnPc = lastPc. 79750 blockStackBase := oldBase. 79751 lastReturnPc := -1. "So as not to mislead outer calls" 79752 ^block! ! 79753 79754!Decompiler methodsFor: 'control'! 79755blockTo: end 79756 "Decompile a range of code as in statementsTo:, but return a block node." 79757 | exprs block oldBase | 79758 oldBase := blockStackBase. 79759 blockStackBase := stack size. 79760 exprs := self statementsTo: end. 79761 block := constructor codeBlock: exprs returns: lastReturnPc = lastPc. 79762 blockStackBase := oldBase. 79763 lastReturnPc := -1. "So as not to mislead outer calls" 79764 ^block! ! 79765 79766!Decompiler methodsFor: 'control' stamp: 'eem 5/29/2008 13:16'! 79767checkForBlock: receiver selector: selector arguments: arguments 79768 selector == #blockCopy: ifTrue: 79769 [^self checkForBlockCopy: receiver]. 79770 self assert: selector == #closureCopy:copiedValues:. 79771 ^self checkForClosureCopy: receiver arguments: arguments! ! 79772 79773!Decompiler methodsFor: 'control' stamp: 'eem 7/29/2008 17:42'! 79774checkForBlockCopy: receiver 79775 "We just saw a blockCopy: message. Check for a following block." 79776 79777 | savePc jump args argPos block | 79778 receiver == constructor codeThisContext ifFalse: [^false]. 79779 savePc := pc. 79780 (jump := self interpretJump) ifNil: 79781 [pc := savePc. ^false]. 79782 self sawBlueBookBlock. 79783 "Definitely a block" 79784 jump := jump + pc. 79785 argPos := statements size. 79786 [self willStorePop] 79787 whileTrue: 79788 [stack addLast: ArgumentFlag. "Flag for doStore:" 79789 self interpretNextInstructionFor: self]. 79790 args := Array new: statements size - argPos. 79791 1 to: args size do: "Retrieve args" 79792 [:i | args at: i put: statements removeLast. 79793 (args at: i) scope: -1 "flag args as block temps"]. 79794 block := self blockTo: jump. 79795 stack addLast: (constructor codeArguments: args block: block). 79796 ^true! ! 79797 79798!Decompiler methodsFor: 'control' stamp: 'eem 5/29/2008 17:02'! 79799checkForClosureCopy: receiver arguments: arguments 79800 "We just saw a closureCopy:copiedValues: message. Check for and construct a following block." 79801 79802 | savePc jump | 79803 receiver == constructor codeThisContext ifFalse: [^false]. 79804 savePc := pc. 79805 (jump := self interpretJump) notNil ifFalse: 79806 [pc := savePc. 79807 ^nil]. 79808 "Definitely a block" 79809 self doClosureCopyCopiedValues: arguments last "<BraceNode>" elements 79810 numArgs: arguments first key 79811 blockSize: jump. 79812 ^true! ! 79813 79814!Decompiler methodsFor: 'control' stamp: 'eem 7/1/2009 14:37'! 79815doClosureCopyCopiedValues: blockCopiedValues numArgs: numArgs blockSize: blockSize 79816 | savedTemps savedTempVarCount savedNumLocalTemps 79817 jump blockArgs blockTemps blockTempsOffset block | 79818 savedTemps := tempVars. 79819 savedTempVarCount := tempVarCount. 79820 savedNumLocalTemps := numLocalTemps. 79821 jump := blockSize + pc. 79822 numLocalTemps := BlockLocalTempCounter tempCountForBlockAt: pc - 4 in: method. 79823 blockTempsOffset := numArgs + blockCopiedValues size. 79824 (blockStartsToTempVars notNil "implies we were intialized with temp names." 79825 and: [blockStartsToTempVars includesKey: pc]) 79826 ifTrue: 79827 [tempVars := blockStartsToTempVars at: pc] 79828 ifFalse: 79829 [blockArgs := (1 to: numArgs) collect: 79830 [:i| (constructor 79831 codeTemp: i - 1 79832 named: 't', (tempVarCount + i) printString) 79833 beBlockArg]. 79834 blockTemps := (1 to: numLocalTemps) collect: 79835 [:i| constructor 79836 codeTemp: i + blockTempsOffset - 1 79837 named: 't', (tempVarCount + i + numArgs) printString]. 79838 tempVars := blockArgs, blockCopiedValues, blockTemps]. 79839 numLocalTemps timesRepeat: 79840 [self interpretNextInstructionFor: self. 79841 stack removeLast]. 79842 tempVarCount := tempVarCount + numArgs + numLocalTemps. 79843 block := self blockTo: jump. 79844 stack addLast: (constructor 79845 codeArguments: (tempVars copyFrom: 1 to: numArgs) 79846 temps: (tempVars copyFrom: blockTempsOffset + 1 to: blockTempsOffset + numLocalTemps) 79847 block: block). 79848 tempVars := savedTemps. 79849 tempVarCount := savedTempVarCount. 79850 numLocalTemps := savedNumLocalTemps! ! 79851 79852!Decompiler methodsFor: 'control' stamp: 'ls 1/28/2004 13:29'! 79853statementsForCaseTo: end 79854 "Decompile the method from pc up to end and return an array of 79855 expressions. If at run time this block will leave a value on the stack, 79856 set hasValue to true. If the block ends with a jump or return, set exit 79857 to the destination of the jump, or the end of the method; otherwise, set 79858 exit = end. Leave pc = end. 79859 Note that stack initially contains a CaseFlag which will be removed by 79860 a subsequent Pop instruction, so adjust the StackPos accordingly." 79861 79862 | blockPos stackPos | 79863 blockPos := statements size. 79864 stackPos := stack size - 1. "Adjust for CaseFlag" 79865 [pc < end] 79866 whileTrue: 79867 [lastPc := pc. limit := end. "for performs" 79868 self interpretNextInstructionFor: self]. 79869 "If there is an additional item on the stack, it will be the value 79870 of this block." 79871 (hasValue := stack size > stackPos) 79872 ifTrue: 79873 [stack last == CaseFlag 79874 ifFalse: [ statements addLast: stack removeLast] ]. 79875 lastJumpPc = lastPc ifFalse: [exit := pc]. 79876 caseExits add: exit. 79877 ^self popTo: blockPos! ! 79878 79879!Decompiler methodsFor: 'control'! 79880statementsTo: end 79881 "Decompile the method from pc up to end and return an array of 79882 expressions. If at run time this block will leave a value on the stack, 79883 set hasValue to true. If the block ends with a jump or return, set exit 79884 to the destination of the jump, or the end of the method; otherwise, set 79885 exit = end. Leave pc = end." 79886 79887 | blockPos stackPos t | 79888 blockPos := statements size. 79889 stackPos := stack size. 79890 [pc < end] 79891 whileTrue: 79892 [lastPc := pc. limit := end. "for performs" 79893 self interpretNextInstructionFor: self]. 79894 "If there is an additional item on the stack, it will be the value 79895 of this block." 79896 (hasValue := stack size > stackPos) 79897 ifTrue: 79898 [statements addLast: stack removeLast]. 79899 lastJumpPc = lastPc ifFalse: [exit := pc]. 79900 ^self popTo: blockPos! ! 79901 79902 79903!Decompiler methodsFor: 'initialize-release' stamp: 'eem 7/1/2009 14:45'! 79904initSymbols: aClass 79905 constructor method: method class: aClass literals: method literals. 79906 constTable := constructor codeConstants. 79907 instVars := Array new: aClass instSize. 79908 tempVarCount := method numTemps. 79909 "(tempVars isNil 79910 and: [method holdsTempNames]) ifTrue: 79911 [tempVars := method tempNamesString]." 79912 tempVars isString 79913 ifTrue: 79914 [blockStartsToTempVars := self mapFromBlockStartsIn: method 79915 toTempVarsFrom: tempVars 79916 constructor: constructor. 79917 tempVars := blockStartsToTempVars at: method initialPC] 79918 ifFalse: 79919 [| namedTemps | 79920 namedTemps := tempVars ifNil: [(1 to: tempVarCount) collect: [:i| 't', i printString]]. 79921 tempVars := (1 to: tempVarCount) collect: 79922 [:i | i <= namedTemps size 79923 ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)] 79924 ifFalse: [constructor codeTemp: i - 1]]]. 79925 1 to: method numArgs do: 79926 [:i| 79927 (tempVars at: i) beMethodArg]! ! 79928 79929!Decompiler methodsFor: 'initialize-release' stamp: 'eem 6/30/2009 18:13'! 79930mapFromBlockStartsIn: aMethod toTempVarsFrom: schematicTempNamesString constructor: aDecompilerConstructor 79931 | map | 79932 map := aMethod 79933 mapFromBlockKeys: aMethod startpcsToBlockExtents keys asSortedCollection 79934 toSchematicTemps: schematicTempNamesString. 79935 map keysAndValuesDo: 79936 [:startpc :tempNameTupleVector| 79937 tempNameTupleVector isEmpty ifFalse: 79938 [| subMap numTemps tempVector | 79939 subMap := Dictionary new. 79940 "Find how many temp slots there are (direct & indirect temp vectors) 79941 and for each indirect temp vector find how big it is." 79942 tempNameTupleVector do: 79943 [:tuple| 79944 tuple last isArray 79945 ifTrue: 79946 [subMap at: tuple last first put: tuple last last. 79947 numTemps := tuple last first] 79948 ifFalse: 79949 [numTemps := tuple last]]. 79950 "create the temp vector for this scope level." 79951 tempVector := Array new: numTemps. 79952 "fill it in with any indirect temp vectors" 79953 subMap keysAndValuesDo: 79954 [:index :size| 79955 tempVector at: index put: (Array new: size)]. 79956 "fill it in with temp nodes." 79957 tempNameTupleVector do: 79958 [:tuple| | itv | 79959 tuple last isArray 79960 ifTrue: 79961 [itv := tempVector at: tuple last first. 79962 itv at: tuple last last 79963 put: (aDecompilerConstructor 79964 codeTemp: tuple last last - 1 79965 named: tuple first)] 79966 ifFalse: 79967 [tempVector 79968 at: tuple last 79969 put: (aDecompilerConstructor 79970 codeTemp: tuple last - 1 79971 named: tuple first)]]. 79972 "replace any indirect temp vectors with proper RemoteTempVectorNodes" 79973 subMap keysAndValuesDo: 79974 [:index :size| 79975 tempVector 79976 at: index 79977 put: (aDecompilerConstructor 79978 codeRemoteTemp: index 79979 remoteTemps: (tempVector at: index))]. 79980 "and update the entry in the map" 79981 map at: startpc put: tempVector]]. 79982 ^map! ! 79983 79984!Decompiler methodsFor: 'initialize-release' stamp: 'eem 6/29/2009 09:41'! 79985withTempNames: tempNames "<Array|String>" 79986 "Optionally initialize the temp names to be used when decompiling. 79987 For backward-copmpatibility, if tempNames is an Array it is a single 79988 vector of temp names, probably for a blue-book-compiled method. 79989 If tempNames is a string it is a schematic string that encodes the 79990 layout of temp vars in the method and any closures/blocks within it. 79991 Decoding encoded tempNames is done in decompile:in:method:using: 79992 which has the method from which to derive blockStarts. 79993 See e.g. BytecodeEncoder>>schematicTempNamesString for syntax." 79994 tempVars := tempNames! ! 79995 79996 79997!Decompiler methodsFor: 'instruction decoding'! 79998blockReturnTop 79999 "No action needed"! ! 80000 80001!Decompiler methodsFor: 'instruction decoding' stamp: 'PeterHugossonMiller 9/2/2009 16:08'! 80002case: dist 80003 "statements = keyStmts CascadeFlag keyValueBlock ... keyStmts" 80004 80005 | nextCase thenJump stmtStream elements b node cases otherBlock myExits | 80006 nextCase := pc + dist. 80007 80008 "Now add CascadeFlag & keyValueBlock to statements" 80009 statements addLast: stack removeLast. 80010 stack addLast: CaseFlag. "set for next pop" 80011 statements addLast: (self blockForCaseTo: nextCase). 80012 80013 stack last == CaseFlag 80014 ifTrue: "Last case" 80015 ["ensure jump is within block (in case thenExpr returns wierdly I guess)" 80016 stack removeLast. "get rid of CaseFlag" 80017 stmtStream := (self popTo: stack removeLast) readStream. 80018 80019 elements := OrderedCollection new. 80020 b := OrderedCollection new. 80021 [stmtStream atEnd] whileFalse: 80022 [(node := stmtStream next) == CascadeFlag 80023 ifTrue: 80024 [elements addLast: (constructor 80025 codeMessage: (constructor codeBlock: b returns: false) 80026 selector: (constructor codeSelector: #-> code: #macro) 80027 arguments: (Array with: stmtStream next)). 80028 b := OrderedCollection new] 80029 ifFalse: [b addLast: node]]. 80030 b size > 0 ifTrue: [self error: 'Bad cases']. 80031 cases := constructor codeBrace: elements. 80032 80033 "try find the end of the case" 80034 myExits := caseExits removeLast: elements size. 80035 myExits := myExits reject: [ :e | e isNil or: [ e < 0 or: [ e > method endPC ] ] ]. 80036 thenJump := myExits isEmpty 80037 ifTrue: [ nextCase ] 80038 ifFalse: [ myExits max ]. 80039 80040 otherBlock := self blockTo: thenJump. 80041 stack addLast: 80042 (constructor 80043 codeMessage: stack removeLast 80044 selector: (constructor codeSelector: #caseOf:otherwise: code: #macro) 80045 arguments: (Array with: cases with: otherBlock))].! ! 80046 80047!Decompiler methodsFor: 'instruction decoding'! 80048doDup 80049 80050 stack last == CascadeFlag 80051 ifFalse: 80052 ["Save position and mark cascade" 80053 stack addLast: statements size. 80054 stack addLast: CascadeFlag]. 80055 stack addLast: CascadeFlag! ! 80056 80057!Decompiler methodsFor: 'instruction decoding' stamp: 'di 2/5/2000 09:34'! 80058doPop 80059 80060 stack isEmpty ifTrue: 80061 ["Ignore pop in first leg of ifNil for value" 80062 ^ self]. 80063 stack last == CaseFlag 80064 ifTrue: [stack removeLast] 80065 ifFalse: [statements addLast: stack removeLast].! ! 80066 80067!Decompiler methodsFor: 'instruction decoding'! 80068doStore: stackOrBlock 80069 "Only called internally, not from InstructionStream. StackOrBlock is stack 80070 for store, statements for storePop." 80071 80072 | var expr | 80073 var := stack removeLast. 80074 expr := stack removeLast. 80075 stackOrBlock addLast: (expr == ArgumentFlag 80076 ifTrue: [var] 80077 ifFalse: [constructor codeAssignTo: var value: expr])! ! 80078 80079!Decompiler methodsFor: 'instruction decoding'! 80080jump: dist 80081 80082 exit := pc + dist. 80083 lastJumpPc := lastPc! ! 80084 80085!Decompiler methodsFor: 'instruction decoding' stamp: 'eem 7/1/2009 10:35'! 80086jump: dist if: condition 80087 80088 | savePc sign elsePc elseStart end cond ifExpr thenBlock elseBlock 80089 thenJump elseJump condHasValue isIfNil saveStack blockBody | 80090 stack last == CascadeFlag ifTrue: [^ self case: dist]. 80091 elsePc := lastPc. 80092 elseStart := pc + dist. 80093 end := limit. 80094 "Check for bfp-jmp to invert condition. 80095 Don't be fooled by a loop with a null body." 80096 sign := condition. 80097 savePc := pc. 80098 self interpretJump ifNotNil: 80099 [:elseDist| 80100 (elseDist >= 0 and: [elseStart = pc]) ifTrue: 80101 [sign := sign not. elseStart := pc + elseDist]]. 80102 pc := savePc. 80103 ifExpr := stack removeLast. 80104 (isIfNil := stack size > 0 and: [stack last == IfNilFlag]) ifTrue: 80105 [stack removeLast]. 80106 saveStack := stack. 80107 stack := OrderedCollection new. 80108 thenBlock := self blockTo: elseStart. 80109 condHasValue := hasValue or: [isIfNil]. 80110 "ensure jump is within block (in case thenExpr returns)" 80111 thenJump := exit <= end ifTrue: [exit] ifFalse: [elseStart]. 80112 "if jump goes back, then it's a loop" 80113 thenJump < elseStart 80114 ifTrue: 80115 ["Must be a while loop... 80116 thenJump will jump to the beginning of the while expr. In the case of while's 80117 with a block in the condition, the while expr should include more than just 80118 the last expression: find all the statements needed by re-decompiling." 80119 stack := saveStack. 80120 pc := thenJump. 80121 blockBody := self statementsTo: elsePc. 80122 "discard unwanted statements from block" 80123 blockBody size - 1 timesRepeat: [statements removeLast]. 80124 statements addLast: 80125 (constructor 80126 codeMessage: (constructor codeBlock: blockBody returns: false) 80127 selector: (constructor 80128 codeSelector: (sign 80129 ifTrue: [#whileFalse:] 80130 ifFalse: [#whileTrue:]) 80131 code: #macro) 80132 arguments: { thenBlock }). 80133 pc := elseStart. 80134 self convertToDoLoop] 80135 ifFalse: 80136 ["Must be a conditional..." 80137 elseBlock := self blockTo: thenJump. 80138 elseJump := exit. 80139 "if elseJump is backwards, it is not part of the elseExpr" 80140 elseJump < elsePc ifTrue: 80141 [pc := lastPc]. 80142 cond := isIfNil 80143 ifTrue: 80144 [constructor 80145 codeMessage: ifExpr ifNilReceiver 80146 selector: (constructor 80147 codeSelector: (sign ifTrue: [#ifNotNil:] ifFalse: [#ifNil:]) 80148 code: #macro) 80149 arguments: (Array with: thenBlock)] 80150 ifFalse: 80151 [constructor 80152 codeMessage: ifExpr 80153 selector: (constructor codeSelector: #ifTrue:ifFalse: code: #macro) 80154 arguments: (sign 80155 ifTrue: [{elseBlock. thenBlock}] 80156 ifFalse: [{thenBlock. elseBlock}])]. 80157 stack := saveStack. 80158 condHasValue 80159 ifTrue: [stack addLast: cond] 80160 ifFalse: [statements addLast: cond]]! ! 80161 80162!Decompiler methodsFor: 'instruction decoding'! 80163methodReturnConstant: value 80164 80165 self pushConstant: value; methodReturnTop! ! 80166 80167!Decompiler methodsFor: 'instruction decoding'! 80168methodReturnReceiver 80169 80170 self pushReceiver; methodReturnTop! ! 80171 80172!Decompiler methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 15:43'! 80173methodReturnTop 80174 | last | 80175 last := stack removeLast "test test" asReturnNode. 80176 stack size > blockStackBase "get effect of elided pop before return" 80177 ifTrue: [statements addLast: stack removeLast]. 80178 exit := pc. 80179 lastJumpPc := lastReturnPc := lastPc. 80180 statements addLast: last! ! 80181 80182!Decompiler methodsFor: 'instruction decoding'! 80183popIntoLiteralVariable: value 80184 80185 self pushLiteralVariable: value; doStore: statements! ! 80186 80187!Decompiler methodsFor: 'instruction decoding'! 80188popIntoReceiverVariable: offset 80189 80190 self pushReceiverVariable: offset; doStore: statements! ! 80191 80192!Decompiler methodsFor: 'instruction decoding' stamp: 'eem 6/4/2008 14:44'! 80193popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 80194 self sawClosureBytecode. 80195 self pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex; doStore: statements! ! 80196 80197!Decompiler methodsFor: 'instruction decoding' stamp: 'eem 8/4/2009 11:43'! 80198popIntoTemporaryVariable: offset 80199 | maybeTVTag tempVector start | 80200 maybeTVTag := stack last. 80201 ((maybeTVTag isMemberOf: Association) 80202 and: [maybeTVTag key == #pushNewArray]) ifTrue: 80203 [blockStartsToTempVars notNil "implies we were intialized with temp names." 80204 ifTrue: "Use the provided temps" 80205 [self assert: ((tempVector := tempVars at: offset + 1 ifAbsent: [ParseNode basicNew]) isTemp 80206 and: [tempVector isIndirectTempVector 80207 and: [tempVector remoteTemps size = maybeTVTag value size]])] 80208 ifFalse: "Synthesize some remote temps" 80209 [tempVector := maybeTVTag value. 80210 offset + 1 <= tempVars size 80211 ifTrue: 80212 [start := 2. 80213 tempVector at: 1 put: (tempVars at: offset + 1)] 80214 ifFalse: 80215 [tempVars := (Array new: offset + 1) 80216 replaceFrom: 1 80217 to: tempVars size 80218 with: tempVars. 80219 start := 1]. 80220 start to: tempVector size do: 80221 [:i| 80222 tempVector 80223 at: i 80224 put: (constructor 80225 codeTemp: numLocalTemps + offset + i - 1 80226 named: 't', (tempVarCount + i) printString)]. 80227 tempVars at: offset + 1 put: (constructor codeRemoteTemp: offset + 1 remoteTemps: tempVector)]. 80228 tempVarCount := tempVarCount + maybeTVTag value size. 80229 stack removeLast. 80230 ^self]. 80231 self pushTemporaryVariable: offset; doStore: statements! ! 80232 80233!Decompiler methodsFor: 'instruction decoding'! 80234pushActiveContext 80235 80236 stack addLast: constructor codeThisContext! ! 80237 80238!Decompiler methodsFor: 'instruction decoding' stamp: 'eem 9/5/2008 14:27'! 80239pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize 80240 | copiedValues | 80241 self sawClosureBytecode. 80242 numCopied > 0 80243 ifTrue: 80244 [copiedValues := Array new: numCopied. 80245 numLocalTemps == #decompileBlock: ifTrue: "Hack fake temps for copied values" 80246 [1 to: numCopied do: [:i| stack addLast: (constructor codeTemp: i - 1)]]. 80247 numCopied to: 1 by: -1 do: 80248 [:i| 80249 copiedValues at: i put: stack removeLast]] 80250 ifFalse: 80251 [copiedValues := #()]. 80252 self doClosureCopyCopiedValues: copiedValues numArgs: numArgs blockSize: blockSize! ! 80253 80254!Decompiler methodsFor: 'instruction decoding' stamp: 'eem 6/4/2008 14:44'! 80255pushConsArrayWithElements: numElements 80256 | array | 80257 self sawClosureBytecode. 80258 array := Array new: numElements. 80259 numElements to: 1 by: -1 do: 80260 [:i| 80261 array at: i put: stack removeLast]. 80262 stack addLast: (constructor codeBrace: array)! ! 80263 80264!Decompiler methodsFor: 'instruction decoding'! 80265pushConstant: value 80266 80267 | node | 80268 node := value == true ifTrue: [constTable at: 2] 80269 ifFalse: [value == false ifTrue: [constTable at: 3] 80270 ifFalse: [value == nil ifTrue: [constTable at: 4] 80271 ifFalse: [constructor codeAnyLiteral: value]]]. 80272 stack addLast: node! ! 80273 80274!Decompiler methodsFor: 'instruction decoding'! 80275pushLiteralVariable: assoc 80276 80277 stack addLast: (constructor codeAnyLitInd: assoc)! ! 80278 80279!Decompiler methodsFor: 'instruction decoding' stamp: 'eem 6/4/2008 14:45'! 80280pushNewArrayOfSize: size 80281 self sawClosureBytecode. 80282 stack addLast: #pushNewArray -> (Array new: size)! ! 80283 80284!Decompiler methodsFor: 'instruction decoding'! 80285pushReceiver 80286 80287 stack addLast: (constTable at: 1)! ! 80288 80289!Decompiler methodsFor: 'instruction decoding' stamp: 'nk 2/20/2004 11:56'! 80290pushReceiverVariable: offset 80291 80292 | var | 80293 (var := instVars at: offset + 1 ifAbsent: []) == nil 80294 ifTrue: 80295 ["Not set up yet" 80296 var := constructor codeInst: offset. 80297 instVars size < (offset + 1) ifTrue: [ 80298 instVars := (Array new: offset + 1) 80299 replaceFrom: 1 to: instVars size with: instVars; yourself ]. 80300 instVars at: offset + 1 put: var]. 80301 stack addLast: var! ! 80302 80303!Decompiler methodsFor: 'instruction decoding' stamp: 'eem 9/25/2008 09:48'! 80304pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 80305 self sawClosureBytecode. 80306 stack addLast: ((tempVars at: tempVectorIndex + 1) remoteTemps at: remoteTempIndex + 1)! ! 80307 80308!Decompiler methodsFor: 'instruction decoding'! 80309pushTemporaryVariable: offset 80310 80311 stack addLast: (tempVars at: offset + 1)! ! 80312 80313!Decompiler methodsFor: 'instruction decoding' stamp: 'eem 9/29/2008 19:23'! 80314send: selector super: superFlag numArgs: numArgs 80315 80316 | args rcvr selNode msgNode messages | 80317 args := Array new: numArgs. 80318 (numArgs to: 1 by: -1) do: 80319 [:i | args at: i put: stack removeLast]. 80320 rcvr := stack removeLast. 80321 superFlag ifTrue: [rcvr := constructor codeSuper]. 80322 ((#(blockCopy: closureCopy:copiedValues:) includes: selector) 80323 and: [self checkForBlock: rcvr selector: selector arguments: args]) ifFalse: 80324 [selNode := constructor codeAnySelector: selector. 80325 rcvr == CascadeFlag 80326 ifTrue: 80327 ["May actually be a cascade or an ifNil: for value." 80328 self willJumpIfFalse 80329 ifTrue: "= generated by a case macro" 80330 [selector == #= ifTrue: 80331 [" = signals a case statement..." 80332 statements addLast: args first. 80333 stack addLast: rcvr. "restore CascadeFlag" 80334 ^ self]. 80335 selector == #== ifTrue: 80336 [" == signals an ifNil: for value..." 80337 stack removeLast; removeLast. 80338 rcvr := stack removeLast. 80339 stack addLast: IfNilFlag; 80340 addLast: (constructor 80341 codeMessage: rcvr 80342 selector: selNode 80343 arguments: args). 80344 ^ self]] 80345 ifFalse: 80346 [(self willJumpIfTrue and: [selector == #==]) ifTrue: 80347 [" == signals an ifNotNil: for value..." 80348 stack removeLast; removeLast. 80349 rcvr := stack removeLast. 80350 stack addLast: IfNilFlag; 80351 addLast: (constructor 80352 codeMessage: rcvr 80353 selector: selNode 80354 arguments: args). 80355 ^ self]]. 80356 msgNode := constructor 80357 codeCascadedMessage: selNode 80358 arguments: args. 80359 stack last == CascadeFlag ifFalse: 80360 ["Last message of a cascade" 80361 statements addLast: msgNode. 80362 messages := self popTo: stack removeLast. "Depth saved by first dup" 80363 msgNode := constructor 80364 codeCascade: stack removeLast 80365 messages: messages]] 80366 ifFalse: 80367 [msgNode := constructor 80368 codeMessage: rcvr 80369 selector: selNode 80370 arguments: args]. 80371 stack addLast: msgNode]! ! 80372 80373!Decompiler methodsFor: 'instruction decoding'! 80374storeIntoLiteralVariable: assoc 80375 80376 self pushLiteralVariable: assoc; doStore: stack! ! 80377 80378!Decompiler methodsFor: 'instruction decoding'! 80379storeIntoReceiverVariable: offset 80380 80381 self pushReceiverVariable: offset; doStore: stack! ! 80382 80383!Decompiler methodsFor: 'instruction decoding' stamp: 'eem 6/4/2008 14:45'! 80384storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 80385 self sawClosureBytecode. 80386 self pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex; doStore: stack! ! 80387 80388!Decompiler methodsFor: 'instruction decoding'! 80389storeIntoTemporaryVariable: offset 80390 80391 self pushTemporaryVariable: offset; doStore: stack! ! 80392 80393 80394!Decompiler methodsFor: 'public access'! 80395decompile: aSelector in: aClass 80396 "See Decompiler|decompile:in:method:. The method is found by looking up 80397 the message, aSelector, in the method dictionary of the class, aClass." 80398 80399 ^self 80400 decompile: aSelector 80401 in: aClass 80402 method: (aClass compiledMethodAt: aSelector)! ! 80403 80404!Decompiler methodsFor: 'public access' stamp: 'eem 10/20/2008 14:09'! 80405decompile: aSelector in: aClass method: aMethod 80406 "Answer a MethodNode that is the root of the parse tree for the 80407 argument, aMethod, which is the CompiledMethod associated with the 80408 message, aSelector. Variables are determined with respect to the 80409 argument, aClass." 80410 80411 ^self 80412 decompile: aSelector 80413 in: aClass 80414 method: aMethod 80415 using: (self constructorForMethod: aMethod)! ! 80416 80417!Decompiler methodsFor: 'public access' stamp: 'eem 7/1/2009 14:45'! 80418decompile: aSelector in: aClass method: aMethod using: aConstructor 80419 80420 | block node | 80421 constructor := aConstructor. 80422 method := aMethod. 80423 self initSymbols: aClass. "create symbol tables" 80424 method isQuick 80425 ifTrue: [block := self quickMethod] 80426 ifFalse: 80427 [stack := OrderedCollection new: method frameSize. 80428 caseExits := OrderedCollection new. 80429 statements := OrderedCollection new: 20. 80430 numLocalTemps := 0. 80431 super method: method pc: method initialPC. 80432 "skip primitive error code store if necessary" 80433 (method primitive ~= 0 and: [self willStore]) ifTrue: 80434 [pc := pc + 2. 80435 tempVars := tempVars asOrderedCollection]. 80436 block := self blockTo: method endPC + 1. 80437 stack isEmpty ifFalse: [self error: 'stack not empty']]. 80438 node := constructor 80439 codeMethod: aSelector 80440 block: block 80441 tempVars: tempVars 80442 primitive: method primitive 80443 class: aClass. 80444 method primitive > 0 ifTrue: 80445 [node removeAndRenameLastTempIfErrorCode]. 80446 ^node! ! 80447 80448!Decompiler methodsFor: 'public access' stamp: 'AdrianLienhard 10/11/2009 19:18'! 80449decompileBlock: aBlock 80450 "Decompile aBlock, returning the result as a BlockNode. 80451 Show temp names from source if available." 80452 "Decompiler new decompileBlock: [3 + 4]" 80453 | startpc end homeClass blockNode methodNode home source | 80454 (home := aBlock home) ifNil: [^ nil]. 80455 method := home method. 80456 (homeClass := home methodClass) ifNil: [^ nil]. 80457 constructor := self constructorForMethod: aBlock method. 80458 method fileIndex ~~ 0 ifTrue: "got any source code?" 80459 [source := [method getSourceFromFile] 80460 on: Error 80461 do: [:ex | ^ nil]. 80462 methodNode := [homeClass compilerClass new 80463 parse: source 80464 in: homeClass 80465 notifying: nil] 80466 on: (Smalltalk classNamed: 'SyntaxErrorNotification') 80467 do: [:ex | ^ nil]. 80468 self withTempNames: methodNode schematicTempNamesString]. 80469 self initSymbols: homeClass. 80470 startpc := aBlock startpc. 80471 end := aBlock isClosure 80472 ifTrue: [(method at: startpc - 2) * 256 80473 + (method at: startpc - 1) + startpc - 1] 80474 ifFalse: 80475 [(method at: startpc - 2) \\ 16 - 4 * 256 80476 + (method at: startpc - 1) + startpc - 1]. 80477 stack := OrderedCollection new: method frameSize. 80478 caseExits := OrderedCollection new. 80479 statements := OrderedCollection new: 20. 80480 super 80481 method: method 80482 pc: (aBlock isClosure ifTrue: [startpc - 4] ifFalse: [startpc - 5]). 80483 aBlock isClosure ifTrue: 80484 [numLocalTemps := #decompileBlock: "Get pushClosureCopy... to hack fake temps for copied values"]. 80485 blockNode := self blockTo: end. 80486 stack isEmpty ifFalse: [self error: 'stack not empty']. 80487 ^blockNode statements first! ! 80488 80489!Decompiler methodsFor: 'public access'! 80490tempAt: offset 80491 "Needed by BraceConstructor<PopIntoTemporaryVariable" 80492 80493 ^tempVars at: offset + 1! ! 80494 80495 80496!Decompiler methodsFor: 'private' stamp: 'eem 9/6/2008 08:45'! 80497blockScopeRefersOnlyOnceToTemp: offset 80498 | nRefs byteCode extension scanner scan | 80499 scanner := InstructionStream on: method. 80500 nRefs := 0. 80501 scan := offset <= 15 80502 ifTrue: 80503 [byteCode := 16 + offset. 80504 [:instr | 80505 instr = byteCode ifTrue: 80506 [nRefs := nRefs + 1]. 80507 nRefs > 1]] 80508 ifFalse: 80509 [extension := 64 + offset. 80510 [:instr | 80511 (instr = 128 and: [scanner followingByte = extension]) ifTrue: 80512 [nRefs := nRefs + 1]. 80513 nRefs > 1]]. 80514 self scanBlockScopeFor: pc from: method initialPC to: method endPC with: scan scanner: scanner. 80515 ^nRefs = 1! ! 80516 80517!Decompiler methodsFor: 'private' stamp: 'eem 10/20/2008 15:49'! 80518constructorForMethod: aMethod 80519 ^(aMethod isBlueBookCompiled 80520 ifTrue: [DecompilerConstructor] 80521 ifFalse: [DecompilerConstructorForClosures]) new! ! 80522 80523!Decompiler methodsFor: 'private' stamp: 'eem 9/5/2008 18:41'! 80524convertToDoLoop 80525 "If statements contains the pattern 80526 var := startExpr. 80527 [var <= limit] whileTrue: [...statements... var := var + incConst] 80528 then replace this by 80529 startExpr to: limit by: incConst do: [:var | ...statements...]" 80530 | initStmt toDoStmt limitStmt | 80531 statements size < 2 ifTrue: [^ self]. 80532 initStmt := statements at: statements size-1. 80533 (toDoStmt := statements last toDoFromWhileWithInit: initStmt) 80534 == nil ifTrue: [^ self]. 80535 initStmt variable scope: -1. "Flag arg as block temp" 80536 statements removeLast; removeLast; addLast: toDoStmt. 80537 80538 "Attempt further conversion of the pattern 80539 limitVar := limitExpr. 80540 startExpr to: limitVar by: incConst do: [:var | ...statements...] 80541 to 80542 startExpr to: limitExpr by: incConst do: [:var | ...statements...]" 80543 statements size < 2 ifTrue: [^ self]. 80544 limitStmt := statements at: statements size-1. 80545 ((limitStmt isMemberOf: AssignmentNode) 80546 and: [limitStmt variable isTemp 80547 and: [limitStmt variable == toDoStmt arguments first 80548 and: [self blockScopeRefersOnlyOnceToTemp: limitStmt variable fieldOffset]]]) 80549 ifFalse: [^ self]. 80550 toDoStmt arguments at: 1 put: limitStmt value. 80551 limitStmt variable scope: -2. "Flag limit var so it won't print" 80552 statements removeLast; removeLast; addLast: toDoStmt. 80553 80554! ! 80555 80556!Decompiler methodsFor: 'private' stamp: 'eem 5/13/2008 15:41'! 80557interpretNextInstructionFor: client 80558 80559 | code varNames | 80560 80561"Change false here will trace all state in Transcript." 80562true ifTrue: [^ super interpretNextInstructionFor: client]. 80563 80564 varNames := self class allInstVarNames. 80565 code := (self method at: pc) radix: 16. 80566 Transcript cr; cr; print: pc; space; 80567 nextPutAll: '<' , (code copyFrom: 4 to: code size), '>'. 80568 8 to: varNames size do: 80569 [:i | i <= 10 ifTrue: [Transcript cr] 80570 ifFalse: [Transcript space; space]. 80571 Transcript nextPutAll: (varNames at: i); 80572 nextPutAll: ': '; print: (self instVarAt: i)]. 80573 Transcript endEntry. 80574 ^ super interpretNextInstructionFor: client! ! 80575 80576!Decompiler methodsFor: 'private' stamp: 'di 2/6/2000 10:55'! 80577methodRefersOnlyOnceToTemp: offset 80578 | nRefs byteCode extension scanner | 80579 nRefs := 0. 80580 offset <= 15 80581 ifTrue: 80582 [byteCode := 16 + offset. 80583 (InstructionStream on: method) scanFor: 80584 [:instr | instr = byteCode ifTrue: [nRefs := nRefs + 1]. 80585 nRefs > 1]] 80586 ifFalse: 80587 [extension := 64 + offset. 80588 scanner := InstructionStream on: method. 80589 scanner scanFor: 80590 [:instr | (instr = 128 and: [scanner followingByte = extension]) 80591 ifTrue: [nRefs := nRefs + 1]. 80592 nRefs > 1]]. 80593 ^ nRefs = 1 80594! ! 80595 80596!Decompiler methodsFor: 'private'! 80597popTo: oldPos 80598 80599 | t | 80600 t := Array new: statements size - oldPos. 80601 (t size to: 1 by: -1) do: 80602 [:i | t at: i put: statements removeLast]. 80603 ^t! ! 80604 80605!Decompiler methodsFor: 'private' stamp: 'di 12/26/1998 21:29'! 80606quickMethod 80607 | | 80608 method isReturnSpecial 80609 ifTrue: [^ constructor codeBlock: 80610 (Array with: (constTable at: method primitive - 255)) returns: true]. 80611 method isReturnField 80612 ifTrue: [^ constructor codeBlock: 80613 (Array with: (constructor codeInst: method returnField)) returns: true]. 80614 self error: 'improper short method'! ! 80615 80616!Decompiler methodsFor: 'private' stamp: 'eem 7/29/2008 17:41'! 80617sawBlueBookBlock 80618 constructor isForClosures ifTrue: 80619 [constructor primitiveChangeClassTo: DecompilerConstructor new]! ! 80620 80621!Decompiler methodsFor: 'private' stamp: 'eem 6/4/2008 14:43'! 80622sawClosureBytecode 80623 constructor isForClosures ifFalse: 80624 [constructor primitiveChangeClassTo: DecompilerConstructorForClosures new]! ! 80625 80626!Decompiler methodsFor: 'private' stamp: 'eem 9/6/2008 09:27'! 80627scanBlockScopeFor: refpc from: startpc to: endpc with: scan scanner: scanner 80628 | bsl maybeBlockSize | 80629 bsl := BlockStartLocator new. 80630 scanner pc: startpc. 80631 [scanner pc <= endpc] whileTrue: 80632 [refpc = scanner pc ifTrue: 80633 [scanner pc: startpc. 80634 [scanner pc <= endpc] whileTrue: 80635 [(scan value: scanner firstByte) ifTrue: 80636 [^endpc]. 80637 (maybeBlockSize := scanner interpretNextInstructionFor: bsl) isInteger ifTrue: 80638 [scanner pc: scanner pc + maybeBlockSize]]. 80639 ^self]. 80640 (maybeBlockSize := scanner interpretNextInstructionFor: bsl) isInteger ifTrue: 80641 [refpc <= (scanner pc + maybeBlockSize) 80642 ifTrue: [^self scanBlockScopeFor: refpc from: scanner pc to: scanner pc + maybeBlockSize with: scan scanner: scanner] 80643 ifFalse: [scanner pc: scanner pc + maybeBlockSize]]]! ! 80644 80645"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 80646 80647Decompiler class 80648 instanceVariableNames: ''! 80649 80650!Decompiler class methodsFor: 'initialization' stamp: 'di 1/28/2000 22:21'! 80651initialize 80652 80653 CascadeFlag := 'cascade'. "A unique object" 80654 CaseFlag := 'case'. "Ditto" 80655 ArgumentFlag := 'argument'. "Ditto" 80656 IfNilFlag := 'ifNil'. "Ditto" 80657 80658 "Decompiler initialize"! ! 80659 80660 80661!Decompiler class methodsFor: 'testing' stamp: 'ls 1/29/2004 23:54'! 80662recompileAllTest 80663 "[Decompiler recompileAllTest]" 80664 "decompile every method and compile it back; if the decompiler is correct then the system should keep running. :)" 80665 80666 | decompiled ast compiled | 80667 SystemNavigation default allBehaviorsDo: [ :behavior | 80668 Utilities informUser: (behavior printString) during: [ 80669 behavior selectors do: [ :sel | 80670 decompiled := Decompiler new decompile: sel in: behavior. 80671 ast := Compiler new compile: decompiled in: behavior notifying: nil ifFail: [ self error: 'failed' ]. 80672 compiled := ast generate: (behavior compiledMethodAt: sel) trailer. 80673 behavior addSelector: sel withMethod: compiled. ] ] ]! ! 80674ParseNode subclass: #DecompilerConstructor 80675 instanceVariableNames: 'method instVars nArgs literalValues tempVars' 80676 classVariableNames: '' 80677 poolDictionaries: '' 80678 category: 'Compiler-Support'! 80679!DecompilerConstructor commentStamp: '<historical>' prior: 0! 80680I construct the node tree for a Decompiler.! 80681 80682 80683!DecompilerConstructor methodsFor: 'constructor'! 80684codeAnyLitInd: association 80685 80686 ^VariableNode new 80687 name: association key 80688 key: association 80689 index: 0 80690 type: LdLitIndType! ! 80691 80692!DecompilerConstructor methodsFor: 'constructor'! 80693codeAnyLiteral: value 80694 80695 ^LiteralNode new 80696 key: value 80697 index: 0 80698 type: LdLitType! ! 80699 80700!DecompilerConstructor methodsFor: 'constructor'! 80701codeAnySelector: selector 80702 80703 ^SelectorNode new 80704 key: selector 80705 index: 0 80706 type: SendType! ! 80707 80708!DecompilerConstructor methodsFor: 'constructor'! 80709codeArguments: args block: block 80710 80711 ^block arguments: args! ! 80712 80713!DecompilerConstructor methodsFor: 'constructor' stamp: 'eem 5/21/2008 13:28'! 80714codeArguments: args temps: temps block: block 80715 block 80716 arguments: args; 80717 temporaries: temps. 80718 ^block! ! 80719 80720!DecompilerConstructor methodsFor: 'constructor'! 80721codeAssignTo: variable value: expression 80722 80723 ^AssignmentNode new variable: variable value: expression! ! 80724 80725!DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 3/3/2000 13:34'! 80726codeBlock: statements returns: returns 80727 ^ BlockNode statements: statements returns: returns! ! 80728 80729!DecompilerConstructor methodsFor: 'constructor'! 80730codeBrace: elements 80731 80732 ^BraceNode new elements: elements! ! 80733 80734!DecompilerConstructor methodsFor: 'constructor' stamp: 'di 11/19/1999 11:06'! 80735codeCascade: receiver messages: messages 80736 80737 ^ (BraceNode new matchBraceStreamReceiver: receiver messages: messages) 80738 ifNil: [CascadeNode new receiver: receiver messages: messages]! ! 80739 80740!DecompilerConstructor methodsFor: 'constructor'! 80741codeCascadedMessage: selector arguments: arguments 80742 80743 ^self 80744 codeMessage: nil 80745 selector: selector 80746 arguments: arguments! ! 80747 80748!DecompilerConstructor methodsFor: 'constructor'! 80749codeConstants 80750 "Answer with an array of the objects representing self, true, false, nil, 80751 -1, 0, 1, 2." 80752 80753 ^(Array with: NodeSelf with: NodeTrue with: NodeFalse with: NodeNil) 80754 , ((-1 to: 2) collect: [:i | LiteralNode new key: i code: LdMinus1 + i + 1])! ! 80755 80756!DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 3/3/2000 13:35'! 80757codeEmptyBlock 80758 ^ BlockNode withJust: NodeNil! ! 80759 80760!DecompilerConstructor methodsFor: 'constructor' stamp: 'eem 8/21/2008 14:02'! 80761codeInst: index 80762 80763 ^InstanceVariableNode new 80764 name: (instVars at: index + 1 ifAbsent: ['unknown', index asString]) 80765 index: index + 1! ! 80766 80767!DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 2/5/2000 12:37'! 80768codeMessage: receiver selector: selector arguments: arguments 80769 | symbol node | 80770 symbol := selector key. 80771 (node := BraceNode new 80772 matchBraceWithReceiver: receiver 80773 selector: symbol 80774 arguments: arguments) ifNotNil: [^ node]. 80775 (node := self decodeIfNilWithReceiver: receiver 80776 selector: symbol 80777 arguments: arguments) ifNotNil: [^ node]. 80778 ^ MessageNode new 80779 receiver: receiver selector: selector 80780 arguments: arguments 80781 precedence: symbol precedence! ! 80782 80783!DecompilerConstructor methodsFor: 'constructor' stamp: 'eem 9/23/2008 22:06'! 80784codeMethod: selector block: block tempVars: vars primitive: primitive class: class 80785 80786 | node methodTemps arguments temporaries | 80787 node := self codeSelector: selector code: nil. 80788 tempVars := vars. 80789 methodTemps := tempVars select: [:t | t scope >= 0]. 80790 arguments := methodTemps copyFrom: 1 to: nArgs. 80791 temporaries := methodTemps copyFrom: nArgs + 1 to: methodTemps size. 80792 block 80793 arguments: arguments; 80794 temporaries: temporaries. 80795 ^MethodNode new 80796 selector: node 80797 arguments: arguments 80798 precedence: selector precedence 80799 temporaries: temporaries 80800 block: block 80801 encoder: (Encoder new initScopeAndLiteralTables 80802 temps: tempVars 80803 literals: literalValues 80804 class: class) 80805 primitive: primitive! ! 80806 80807!DecompilerConstructor methodsFor: 'constructor'! 80808codeSelector: sel code: code 80809 80810 ^SelectorNode new key: sel code: code! ! 80811 80812!DecompilerConstructor methodsFor: 'constructor'! 80813codeSuper 80814 80815 ^NodeSuper! ! 80816 80817!DecompilerConstructor methodsFor: 'constructor'! 80818codeTemp: index 80819 80820 ^ TempVariableNode new 80821 name: 't' , (index + 1) printString 80822 index: index 80823 type: LdTempType 80824 scope: 0! ! 80825 80826!DecompilerConstructor methodsFor: 'constructor'! 80827codeTemp: index named: tempName 80828 80829 ^ TempVariableNode new 80830 name: tempName 80831 index: index 80832 type: LdTempType 80833 scope: 0! ! 80834 80835!DecompilerConstructor methodsFor: 'constructor'! 80836codeThisContext 80837 80838 ^NodeThisContext! ! 80839 80840!DecompilerConstructor methodsFor: 'constructor' stamp: 'di 1/28/2000 21:23'! 80841decodeIfNilWithReceiver: receiver selector: selector arguments: arguments 80842 80843 selector == #ifTrue:ifFalse: 80844 ifFalse: [^ nil]. 80845 (receiver isMessage: #== 80846 receiver: nil 80847 arguments: [:argNode | argNode == NodeNil]) 80848 ifFalse: [^ nil]. 80849 ^ (MessageNode new 80850 receiver: receiver 80851 selector: (SelectorNode new key: #ifTrue:ifFalse: code: #macro) 80852 arguments: arguments 80853 precedence: 3) 80854 noteSpecialSelector: #ifNil:ifNotNil:! ! 80855 80856 80857!DecompilerConstructor methodsFor: 'initialize-release'! 80858method: aMethod class: aClass literals: literals 80859 80860 method := aMethod. 80861 instVars := aClass allInstVarNames. 80862 nArgs := method numArgs. 80863 literalValues := literals! ! 80864 80865 80866!DecompilerConstructor methodsFor: 'testing' stamp: 'eem 6/4/2008 14:41'! 80867isForClosures 80868 ^false! ! 80869 80870 80871!DecompilerConstructor methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:44'! 80872accept: aVisitor 80873 "I am not really a ParseNode. Only here to access constants defined in parseNode." 80874 self shouldNotImplement! ! 80875 80876"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 80877 80878DecompilerConstructor class 80879 instanceVariableNames: ''! 80880DecompilerConstructor subclass: #DecompilerConstructorForClosures 80881 instanceVariableNames: 'tempNameCounter' 80882 classVariableNames: '' 80883 poolDictionaries: '' 80884 category: 'Compiler-Support'! 80885 80886!DecompilerConstructorForClosures methodsFor: 'constructor' stamp: 'eem 6/11/2009 17:04'! 80887codeMethod: selector block: block tempVars: vars primitive: primitive class: class 80888 80889 | blockNode selectorNode visibleTemps invisibleTemps arguments temporaries | 80890 selectorNode := self codeSelector: selector code: nil. 80891 tempVars := vars. 80892 visibleTemps := OrderedCollection new. 80893 invisibleTemps := OrderedCollection new. 80894 tempVars do: [:t| 80895 ((t isIndirectTempVector or: [t scope >= 0]) 80896 ifTrue: [visibleTemps] 80897 ifFalse: [invisibleTemps]) addLast: t]. 80898 arguments := visibleTemps copyFrom: 1 to: nArgs. 80899 temporaries := visibleTemps copyFrom: nArgs + 1 to: visibleTemps size. 80900 block 80901 arguments: arguments; 80902 temporaries: temporaries. 80903 blockNode := BytecodeAgnosticMethodNode new 80904 selector: selectorNode 80905 arguments: arguments 80906 precedence: selector precedence 80907 temporaries: temporaries 80908 block: block 80909 encoder: (EncoderForV3PlusClosures new initScopeAndLiteralTables 80910 temps: visibleTemps, invisibleTemps 80911 literals: literalValues 80912 class: class) 80913 primitive: primitive 80914 properties: method properties copy. 80915 blockNode properties method: blockNode. 80916 ^blockNode! ! 80917 80918!DecompilerConstructorForClosures methodsFor: 'constructor' stamp: 'eem 10/20/2008 13:01'! 80919codeRemoteTemp: index remoteTemps: tempVector 80920 80921 ^(RemoteTempVectorNode new 80922 name: '_r', index printString 80923 index: index 80924 type: LdTempType 80925 scope: 0) 80926 remoteTemps: tempVector; 80927 yourself! ! 80928 80929 80930!DecompilerConstructorForClosures methodsFor: 'testing' stamp: 'eem 6/4/2008 14:41'! 80931isForClosures 80932 ^true! ! 80933DecompilerTests subclass: #DecompilerTestFailuresCollector 80934 instanceVariableNames: 'failures' 80935 classVariableNames: '' 80936 poolDictionaries: '' 80937 category: 'Tests-Compiler'! 80938!DecompilerTestFailuresCollector commentStamp: '<historical>' prior: 0! 80939(| dtfc | 80940dtfc := DecompilerTestFailuresCollector new. 80941(dtfc class superclass organization listAtCategoryNamed: #tests) do: 80942 [:s| dtfc perform: s]. 80943dtfc failures) 80944 80945(Transcript nextPut: ${. 80946self do: [:mr| Transcript print: mr actualClass; nextPut: $.; space; store: mr methodSymbol; nextPut: $.; cr; flush]. 80947Transcript nextPut: $}; flush) 80948 80949eem 7/1/2009 16:13 80950{AdditionalMethodState. #keysAndValuesDo:. 80951AdditionalMethodState. #propertyKeysAndValuesDo:. 80952AdditionalMethodState. #at:ifAbsent:. 80953AdditionalMethodState. #removeKey:ifAbsent:. 80954AdditionalMethodState. #at:ifAbsentPut:. 80955AdditionalMethodState. #setMethod:. 80956AdditionalMethodState. #at:put:. 80957AdditionalMethodState. #pragmas. 80958AdditionalMethodState. #includesProperty:. 80959AdditionalMethodState. #properties. 80960AdditionalMethodState. #hasLiteralSuchThat:. 80961AdditionalMethodState. #propertyValueAt:ifAbsent:. 80962AdditionalMethodState. #hasLiteralThorough:. 80963Array. #hasLiteralSuchThat:. 80964BitBltSimulation. #initDither8Lookup. 80965BlockNode. #sizeCodeExceptLast:. 80966BlockNode. #emitCodeExceptLast:encoder:. 80967Categorizer. #changeFromCategorySpecs:. 80968Categorizer. #elementCategoryDict. 80969CColorPicker. #colors:. 80970CCustomDrawListCostume. #drawListOn:in:. 80971ChangeList. #browseCurrentVersionsOfSelections. 80972ClosureTests. #testToDoInsideTemp. 80973Cogit. #computeMaximumSizes. 80974Cogit. #outputInstructionsAt:. 80975Cogit. #generateMapAt:start:. 80976CogVMSimulator. #printFrameThing:at:. 80977CogVMSimulator. #str:n:cmp:. 80978CoInterpreter. #validStackPageBaseFrames. 80979CoInterpreter. #markAndTraceTraceLog. 80980CoInterpreter. #mapTraceLog. 80981CoInterpreter. #checkStackIntegrity. 80982CoInterpreter. #mapStackPages. 80983CoInterpreter. #updateStackZoneReferencesToCompiledCodePreCompaction. 80984CoInterpreter. #ceActivateFailingPrimitiveMethod:. 80985CoInterpreterStackPages. #initializeStack:numSlots:pageSize:stackLimitOffset:stackPageHeadroom:. 80986CompiledMethod. #=. 80987CompiledMethod. #getPreambleFrom:at:. 80988CompiledMethod. #hasLiteralThorough:. 80989CompiledMethod. #hasLiteralSuchThat:. 80990CPopUpMenuCostume. #drawMenu:on:in:. 80991CroquetParticipant. #dropFiles:. 80992CTextParagraph. #selectionRectsFrom:to:. 80993CWheelWidgetCostume. #drawOn:in:. 80994Dictionary. #scanFor:. 80995Float. #printPaddedWith:to:. 80996FMSound. #mixSampleCount:into:startingAt:leftVol:rightVol:. 80997Form. #transformColors:. 80998FTPClient. #getDataInto:. 80999GIFReadWriter. #nextImageWithPlugin. 81000GraphMorph. #drawDataOn:. 81001GZipReadStream. #on:from:to:. 81002HTTPServiceDispatcher. #errorReportFor:stack:on:. 81003HttpUrl. #checkAuthorization:retry:. 81004Integer. #benchSwitch:. 81005Interpreter. #primitiveClosureValueWithArgs. 81006Interpreter. #primitivePerformAt:. 81007Interpreter. #primitiveDoPrimitiveWithArgs. 81008Interpreter. #primitiveNewMethod. 81009InterpreterStackPages. #initializeStack:numSlots:pageSize:stackLimitOffset:stackPageHeadroom:. 81010JPEGReadWriter. #decodeBlockInto:component:dcTable:acTable:. 81011KeyedIdentitySet. #scanFor:. 81012KeyedSet. #scanFor:. 81013LargeIntegersPlugin. #isNormalized:. 81014LargeIntegersPlugin. #cBytesCopyFrom:to:len:. 81015LargeIntegersPlugin. #cDigitMultiply:len:with:len:into:. 81016LiteralDictionary. #scanFor:. 81017LoopedSampledSound. #mixSampleCount:into:startingAt:leftVol:rightVol:. 81018MethodDictionary. #scanFor:. 81019MP4BoxInfoParser. #parseMP4BoxOutput:. 81020MP4BoxNHMLTrack. #computeDTSDeltas. 81021MultiByteBinaryOrTextStream. #next:. 81022MultiByteFileStream. #next:. 81023MViewPane. #reconstructEnabledDocuments. 81024MViewPane. #reconstructOpenDocuments. 81025MViewPane. #reconstructSelectionList. 81026NewParagraph. #selectionRectsFrom:to:. 81027Object. #instanceFields. 81028OldSocket. #getResponseNoLF. 81029PasteUpMorph. #dropFiles:. 81030PlotMorphGrid. #bestStep:. 81031PluckedSound. #reset. 81032PluggableDictionary. #scanFor:. 81033PluggableSet. #scanFor:. 81034PluggableTabButtonMorph. #calculateArcLengths. 81035PluggableTabButtonMorph. #drawTabOn:. 81036PNGReadWriter. #copyPixelsGray:. 81037PNMReadWriter. #readPlainRGB. 81038PNMReadWriter. #readBWreverse:. 81039PNMReadWriter. #nextPutRGB:. 81040PNMReadWriter. #nextPutBW:reverse:. 81041PopUpMenu. #readKeyboard. 81042QFloorFan. #initialize. 81043QMinimalForum. #demoDesksUnused. 81044QNetVidReorderingBuffer. #popFramesForCTS:. 81045QNetVidTrackStreamer. #sampleIndexWithCTS:. 81046QServiceProvider. #statusReport. 81047QServicesPane. #forumMenuInto:. 81048QUserListItem. #drawOn:in:. 81049QVMProfiler. #computeHistograms:. 81050QVMProfiler. #selectSymbolsInRange. 81051QwaqParticipantUI. #onDropFiles:. 81052RelativeInstructionPrinter. #print:. 81053RemoteHandMorph. #appendNewDataToReceiveBuffer. 81054SchizophrenicClosureFormatStackInterpreter. #primitiveClosureValueWithArgs. 81055Set. #do:. 81056Set. #scanFor:. 81057SHParserST80. #isBinary. 81058ShootoutMall. #processVisitors. 81059ShortIntegerArray. #writeOn:. 81060SparseLargeArray. #analyzeSpaceSaving. 81061StackInterpreter. #validStackPageBaseFrames. 81062StackInterpreter. #divorceAllFrames. 81063StackInterpreter. #checkStackIntegrity. 81064StackInterpreter. #primitiveDoPrimitiveWithArgs. 81065StackInterpreter. #reverseDisplayFrom:to:. 81066StackInterpreter. #printOop:. 81067StackInterpreter. #mapStackPages. 81068StackInterpreter. #primitiveNewMethod. 81069StackInterpreter. #primitiveClosureValueWithArgs. 81070StrikeFontSet. #displayStringR2L:on:from:to:at:kern:. 81071String. #howManyMatch:. 81072Text. #asHtmlFragmentTextStyle:useBreaks:. 81073TextURL. #actOnClickFor:. 81074TFractalTerrain. #heightAt:. 81075TFractalTerrain. #makeFaces. 81076TFractalTerrain. #makeVertices. 81077TFractalTerrain. #makeTextureUV. 81078TFractalTerrain. #makeVertexNormals. 81079TFrame. #computeUnionSphere. 81080TMethod. #emitCCommentOn:. 81081TRFBStreamOutput. #handleRequest:. 81082TTCFontReader. #processCharacterMappingTable:. 81083TTContourConstruction. #segmentsDo:. 81084TTensor. #projectionIntegrate:. 81085TTFontReader. #processHorizontalMetricsTable:length:. 81086TTFontReader. #processCharacterMappingTable:. 81087TWaves. #step. 81088Vector. #copyFrom:. 81089Vector. #asVector3. 81090VectorColor. #copyFrom:. 81091WeakKeyDictionary. #scanForNil:. 81092WeakKeyDictionary. #scanFor:. 81093WeakSet. #scanFor:. 81094WeakSet. #scanForLoadedSymbol:. 81095}! 81096 81097 81098!DecompilerTestFailuresCollector methodsFor: 'accessing' stamp: 'eem 11/10/2008 15:46'! 81099assert: aBoolean description: aString resumable: resumableBoolean 81100 aBoolean ifFalse: 81101 [failures isNil ifTrue: 81102 [failures := OrderedCollection new]. 81103 failures addLast: (thisContext sender tempAt: 1) methodReference]! ! 81104 81105!DecompilerTestFailuresCollector methodsFor: 'accessing' stamp: 'eem 11/10/2008 15:47'! 81106failures 81107 ^failures! ! 81108Object subclass: #DecompilerTests 81109 instanceVariableNames: '' 81110 classVariableNames: '' 81111 poolDictionaries: '' 81112 category: 'Tests-Compiler'! 81113!DecompilerTests commentStamp: 'AdrianLienhard 10/11/2009 19:11' prior: 0! 81114AdrianLienhard 10/11/2009 19:08: Since many of tests are expected to fail, the super class is temporarily changed to Object so that these tests are not run anymore. Using the expected failures mechanism does not work since the tests depend on the source code loaded in the image and hence may or may not fail depending on what is loaded. 81115 81116Apparently the decompiler does not really work totally. 81117Here are a bunch of methods that can help improving the decompiler: 81118 - blockingClasses return class for which it is impossible to decompile methods 81119 - failures are problems that lead to a DNU 81120 - decompilerDiscrepancies are the results of running decompileTestHelper..as you see the pattern 81121 is quite present.! 81122 81123 81124!DecompilerTests methodsFor: 'utilities' stamp: 'sd 9/25/2004 15:30'! 81125blockingClasses 81126 81127 81128 ^ #(CompiledMethod)! ! 81129 81130!DecompilerTests methodsFor: 'utilities' stamp: 'eem 6/11/2009 17:24'! 81131checkDecompileMethod: oldMethod 81132 81133 | cls selector oldMethodNode methodNode newMethod oldCodeString newCodeString | 81134 cls := oldMethod methodClass. 81135 selector := oldMethod selector. 81136 oldMethodNode := cls decompilerClass new 81137 decompile: selector 81138 in: cls 81139 method: oldMethod. 81140 [oldMethodNode properties includesKey: #warning] whileTrue: 81141 [oldMethodNode properties removeKey: #warning]. 81142 oldCodeString := oldMethodNode decompileString. 81143 methodNode := [cls compilerClass new 81144 compile: oldCodeString 81145 in: cls 81146 notifying: nil 81147 ifFail: []] 81148 on: SyntaxErrorNotification 81149 do: [:ex| 81150 ex errorMessage = 'Cannot store into' ifTrue: 81151 [ex return: #badStore]. 81152 ex pass]. 81153 "Ignore cannot store into block arg errors; they're not our issue." 81154 methodNode ~~ #badStore ifTrue: 81155 [newMethod := methodNode generate: #(0 0 0 0). 81156 newCodeString := (cls decompilerClass new 81157 decompile: selector 81158 in: cls 81159 method: newMethod) decompileString. 81160 "(StringHolder new textContents: 81161 (TextDiffBuilder buildDisplayPatchFrom: oldCodeString to: newCodeString)) 81162 openLabel: 'Decompilation Differences for ', cls name,'>>',selector" 81163 "(StringHolder new textContents: 81164 (TextDiffBuilder buildDisplayPatchFrom: oldMethod abstractSymbolic to: newMethod abstractSymbolic)) 81165 openLabel: 'Bytecode Differences for ', cls name,'>>',selector" 81166 self assert: oldCodeString = newCodeString 81167 description: cls name asString, ' ', selector asString 81168 resumable: true]! ! 81169 81170!DecompilerTests methodsFor: 'utilities' stamp: 'eem 9/29/2008 15:07'! 81171decompileClassesSelect: aBlock 81172 81173 (Smalltalk classNames select: aBlock) do: 81174 [:cn | | cls | 81175 cls := Smalltalk at: cn. 81176 Smalltalk garbageCollect. 81177 Transcript cr; show: cn. 81178 cls selectors do: 81179 [:selector | | methodNode oldMethod newMethod oldCodeString newCodeString | 81180 (self isFailure: cls sel: selector) ifFalse: 81181 [" to help making progress 81182 (self 81183 isStoredProblems: cls theNonMetaClass 81184 sel: selector 81185 meta: cls isMeta) 81186 ifFalse: [ " 81187 Transcript nextPut: $.; flush. 81188 self checkDecompileMethod: (cls compiledMethodAt: selector)]]]! ! 81189 81190!DecompilerTests methodsFor: 'utilities' stamp: 'DamienCassou 10/6/2009 09:37'! 81191decompilerDiscrepancies 81192 "classnames, method selector, isMeta" 81193 81194 ^ #(#(#AIFFFileReader #readExtendedFloat false) #(#AbstractFont #emphasisStringFor: false) #(#AbstractString #asSmalltalkComment false) #(#AbstractString #compressWithTable: false) #(#AbstractString #howManyMatch: false) #(#Archive #addTree:removingFirstCharacters: false) #(#ArchiveViewer #createButtonBar false) #(#ArchiveViewer #extractAllPossibleInDirectory: false) #(#BMPReadWriter #nextPutImage: false) #(#Bitmap #readCompressedFrom: false) #(#BitmapStreamTests #testOtherClasses false) #(#BlobMorph #mergeSelfWithBlob:atPoint: false) #(#BookMorph #fromRemoteStream: false) #(#BookMorph #saveIndexOfOnly: false) #(#Browser #categorizeAllUncategorizedMethods false) #(#Browser #highlightMessageList:with: false) #(#Categorizer #elementCategoryDict false) #(#ChangeList #selectConflicts: false) #(#ChangeSet #containsMethodAtPosition: false) #(#ChangeSorter #removeContainedInClassCategories false) #(#CodeHolder #getSelectorAndSendQuery:to:with: false) #(#Color #initializeGrayToIndexMap false) #(#ColorForm #maskingMap false) #(#CompiledMethodInspector #fieldList false) #(#ComplexBorder #drawLineFrom:to:on: false) #(#DateAndTime #ticks:offset: false) #(#Dictionary #scanFor: false) #(#DockingBarMorph #example3 false) #(#Envelope #storeOn: false) #(#FFT #transformDataFrom:startingAt: false) #(#FMSound #mixSampleCount:into:startingAt:leftVol:rightVol: false) #(#FTPClient #getDataInto: false) #(#FWT #samples: false) #(#FWT #setAlpha:beta: false) #(#FileList #selectEncoding false) #(#FileList2 #endingSpecs false) #(#FilePackage #conflictsWithUpdatedMethods false) #(#FishEyeMorph #calculateTransform false) #(#FlapsTest #testRegisteredFlapsQuads false) #(#Float #absByteEncode:base: false) #(#Float #absPrintExactlyOn:base: false) #(#Float #absPrintOn:base: false) #(#Float #initialize false) #(#Form #dotOfSize: false) #(#Form #readNativeResourceFrom: false) #(#GIFReadWriter #exampleAnim false) #(#GZipReadStream #on:from:to: false) #(#GraphMorph #drawDataOn: false) #(#HttpUrl #checkAuthorization:retry: false) #(#ImageSegment #verify:matches:knowing: false) #(#Imports #importImageDirectory: false) #(#Integer #digitDiv:neg: false) #(#Integer #take: false) #(#Interval #valuesInclude: false) #(#JPEGHuffmanTable #makeDerivedTables false) #(#JPEGReadWriter #decodeBlockInto:component:dcTable:acTable: false) #(#KeyedIdentitySet #scanFor: false) #(#KeyedSet #scanFor: false) #(#LiteralDictionary #scanFor: false) #(#LoopedSampledSound #mixSampleCount:into:startingAt:leftVol:rightVol: false) #(#MIDIInputParser #processByte: false) #(#MIDIScore #insertEvents:at: false) #(#MPEGMoviePlayerMorph #guessVolumeSlider false) #(#MailMessage #bodyTextFormatted false) #(#MenuIcons #createIconMethodsFromDirectory: false) #(#MenuIcons #decorateMenu: false) #(#MenuMorph #addTitle:icon:updatingSelector:updateTarget: false) #(#MethodDictionary #scanFor: false) #(#MethodFinder #load: false) #(#Morph #addNestedYellowButtonItemsTo:event: false) #(#Morph #addToggleItemsToHaloMenu: false) #(#Morph #duplicateMorphCollection: false) #(#Morph #layoutMenuPropertyString:from: false) #(#Morph #printConstructorOn:indent:nodeDict: false) #(#Morph #privateAddAllMorphs:atIndex: false) #(#Morph #specialNameInModel false) #(#MultiByteBinaryOrTextStream #next: false) #(#MultiByteFileStream #next: false) #(#MultiString #indexOfAscii:inMultiString:startingAt: false) #(#MultiString #findMultiSubstring:in:startingAt:matchTable: false) #(#MultiString #multiStringCompare:with:collated: false) #(#MulticolumnLazyListMorph #setColumnWidthsFor: false) #(#NaturalLanguageTranslator #loadAvailableExternalLocales false) #(#NewParagraph #OLDcomposeLinesFrom:to:delta:into:priorLines:atY: false) #(#NewParagraph #selectionRectsFrom:to: false) #(#Object #copyFrom: false) #(#Object #storeOn: false) #(#ObjectExplorer #step false) #(#ObjectOut #xxxFixup false) #(#OrderedCollection #copyReplaceFrom:to:with: false) #(#PNGReadWriter #copyPixelsGray: false) #(#PNGReadWriter #copyPixelsGrayAlpha: false) #(#PNMReadWriter #nextPutBW:reverse: false) #(#PNMReadWriter #nextPutRGB: false) #(#PNMReadWriter #readBWreverse: false) #(#PNMReadWriter #readPlainRGB false) #(#PRServerDirectory #getPostArgsFromThingsToSearchFor: false) #(#PRServerDirectory #putSmalltalkInfoInto: false) #(#PackageInfo #foreignClasses false) #(#ParagraphEditor #cursorEnd: false) #(#ParagraphEditor #explainDelimitor: false) #(#ParseNode #nodePrintOn:indent: false) #(#ParseTreeRewriter #acceptCascadeNode: false) #(#ParseTreeSearcher #messages false) #(#PartsBin #translatedQuads: false) #(#PasteUpMorph #dropFiles: false) #(#PasteUpMorph #mouseDown: false) #(#PhonemeRecord #prunedAverageFeatures: false) #(#PluckedSound #reset false) #(#PluggableDictionary #scanFor: false) #(#PluggableListMorph #list: false) #(#PluggableMultiColumnListMorph #calculateColumnOffsetsFrom: false) #(#PluggableMultiColumnListMorph #calculateColumnWidthsFrom: false) #(#PluggableMultiColumnListMorph #layoutMorphicLists: false) #(#PluggableSet #scanFor: false) #(#PointerFinder #buildList false) #(#PointerFinder #followObject: false) #(#PolygonMorph #derivs:first:second:third: false) #(#PopUpMenu #readKeyboard false) #(#PostscriptCanvas #convertFontName: false) #(#PostscriptCanvas #fontSampler false) #(#PostscriptCanvas #postscriptFontInfoForFont: false) #(#PostscriptCanvas #postscriptFontMappingSummary false) #(#PostscriptCanvas #drawGeneralBezierShape:color:borderWidth:borderColor: false) #(#PostscriptCanvas #outlineQuadraticBezierShape: false) #(#Preferences #keihanna false) #(#Preferences #printStandardSystemFonts false) #(#Preferences #refreshFontSettings false) #(#Preferences #setDefaultFonts: false) #(#Preferences #smallLand false) #(#ProcessBrowser #dumpTallyOnTranscript: false) #(#ProcessBrowser #processNameList false) #(#ProcessorScheduler #highestPriority: false) #(#ProcessorScheduler #nextReadyProcess false) #(#Project #setFlaps false) #(#ProtoObject #pointsTo: false) #(#RBAssignmentNode #bestNodeFor: false) #(#RBFormatter #formatMessage:cascade: false) #(#RBFormatter #formatStatementCommentFor: false) #(#RBMessageNode #bestNodeFor: false) #(#RBPatternMessageNode #receiver:selectorParts:arguments: false) #(#RBPatternVariableNode #initializePatternVariables false) #(#RBProgramNode #copyList:inContext: false) #(#RBSequenceNode #= false) #(#RBSequenceNode #replaceNode:withNodes: false) #(#RemoteHandMorph #appendNewDataToReceiveBuffer false) #(#RunArray #rangeOf:startingAt: false) #(#SARInstaller #ensurePackageWithId: false) #(#SARInstaller #fileIntoChangeSetNamed:fromStream: false) #(#SARInstaller #memberNameForProjectNamed: false) #(#SMLoader #cachePackageReleaseAndOfferToCopy false) #(#SMLoader #downloadPackageRelease false) #(#SMLoader #installPackageRelease: false) #(#SMSqueakMap #accountForName: false) #(#SMSqueakMap #mapInitialsFromMinnow false) #(#SampledSound #convert8bitSignedFrom:to16Bit: false) #(#ScaledDecimalTest #testConvertFromFloat false) #(#ScrollBar #arrowSamples false) #(#ScrollBar #boxSamples false) #(#ScrollBar #doScrollDown false) #(#ScrollBar #doScrollUp false) #(#ScrollBar #scrollDown: false) #(#ScrollBar #scrollUp: false) #(#SecurityManager #flushSecurityKey: false) #(#SelectionMorph #extendByHand: false) #(#SelectorBrowser #markMatchingClasses false) #(#Set #do: false) #(#Set #scanFor: false) #(#ShortIntegerArray #writeOn: false) #(#SimpleMIDIPort #closeAllPorts false) #(#SmaCCParser #errorHandlerStates false) #(#SmaCCParser #findErrorHandlerIfNoneUseErrorNumber: false) #(#SmalltalkImage #saveImageSegments false) #(#SmartRefStream #uniClassInstVarsRefs: false) #(#SoundBuffer #normalized: false) #(#SparseLargeTable #zapDefaultOnlyEntries false) #(#Spline #derivs:first:second:third: false) #(#StrikeFont #bonk:with: false) #(#StrikeFont #buildfontNamed:fromForms:startingAtAscii:ascent:descent:maxWid: false) #(#StrikeFont #makeItalicGlyphs false) #(#StrikeFont #readFromBitFont: false) #(#StrikeFontSet #bonk:with:at: false) #(#StrikeFontSet #displayStringR2L:on:from:to:at:kern: false) #(#StrikeFontSet #makeItalicGlyphs false) #(#String #indexOfAscii:inString:startingAt: false) #(#StringTest #testAsSmalltalkComment false) #(#SymbolTest #testWithFirstCharacterDownshifted false) #(#SyntaxMorph #rename: false) #(#SystemDictionary #makeSqueaklandReleasePhaseFinalSettings false) #(#SystemDictionary #saveImageSegments false) #(#TTCFont #reorganizeForNewFontArray:name: false) #(#TTCFontReader #processCharacterMappingTable: false) #(#TTContourConstruction #segmentsDo: false) #(#TTFontReader #getGlyphFlagsFrom:size: false) #(#TTFontReader #processCharMap: false) #(#TTFontReader #processCharacterMappingTable: false) #(#TTFontReader #processHorizontalMetricsTable:length: false) #(#TestsForTextAndTextStreams #testExampleRunArray5 false) #(#TestsForTextAndTextStreams #testRangeDetection1 false) #(#TestsForTextAndTextStreams #testRangeDetection2 false) #(#TestsForTextAndTextStreams #testRangeDetection3 false) #(#TestsForTextAndTextStreams #testRangeDetection4 false) #(#Text #initTextConstants false) #(#TextConverter #allEncodingNames false) #(#TextStyle #decodeStyleName: false) #(#TextStyle #fontMenuForStyle:target:selector:highlight: false) #(#TextStyle #modalMVCStyleSelectorWithTitle: false) #(#TextStyle #modalStyleSelectorWithTitle: false) #(#TextURL #actOnClickFor: false) #(#ThreePhaseButtonMorph #initialize false) #(#TickIndicatorMorph #drawOn: false) #(#TimeProfileBrowser #setClassAndSelectorIn: false) #(#UCSTable #initializeGB2312Table false) #(#UCSTable #initializeJISX0208Table false) #(#UCSTable #initializeKSX1001Table false) #(#Utilities #decimalPlacesForFloatPrecision: false) #(#Utilities #floatPrecisionForDecimalPlaces: false) #(#WaveEditor #showEnvelope false) #(#WaveletCodec #decodeFrames:from:at:into:at: false) #(#WaveletCodec #encodeFrames:from:at:into:at: false) #(#WeakKeyDictionary #scanFor: false) #(#WeakKeyDictionary #scanForNil: false) #(#WeakSet #scanFor: false) #(#WeakSet #scanForLoadedSymbol: false) #(#WorldState #displayWorldSafely: false) #(#ZLibWriteStream #updateAdler32:from:to:in: false) #(#ZipConstants #initializeDistanceCodes false) #(#ZipWriteStream #dynamicBlockSizeFor:and:using:and: false) #(#ZipWriteStream #fixedBlockSizeFor:and: false) (SimpleMIDIPort closeAllPorts true) (Float initialize true) (FileList2 endingSpec true) (ProcessBrowser dumpTallyOnTranscript: true) (SARInstaller ensurePackageWithId: true) (SARInstaller fileIntoChangeSetNamed:fromStream: true) (Color initializeGrayToIndexMap true) (GIFReadWriter exampleAnim true) (Text initTextConstants true) (String indexOfAscii:inString:startingAt: true)(MultiString indexOfAscii:inString:startingAt: true) (ZLibWriteStream updateAdler32:from:to:in: true) (SampledSound convert8bitSignedFrom:to16Bit: true) (Form dotOfSize: true) (Preferences setDefaultFonts true)(Preferences refreshFontSettings true) (Preferences keihanna true) (Preferences smallLand true) (Preferences printStandardSystemFonts true) (ThreePhaseButtonMorph initialize true)(ScrollBar arrowSamples true) (ScrollBar boxSamples true) (DockingBarMorph example3)(PartsBin translatedQuads: true)(Utilities decimlaPlacesForFloatPrecision: true) (Utilities floatPrecisionForDecimalPlaces: true) (PostcriptCanvas postscriptFontMappingSummary true) (PostscriptCanvas convertFontName: true) (PostscriptCanvas fontSampler true) (PostScriptCanvas postscriptFontInfoForFont: true) (TextStyle decodeStyleName true) (TestStyle fontMenuForStyle:target:selector:highlight: true) (TextStyle modalMVCStyleSelectorWithTitle: true)(TextStyle modalStyleSelectorWithTitle: true) (AbstractFont emphasisStringFor: true) 81195(TTCFonr reorganizeForNewFontArray:name: true) (ZipConstants initializeDistanceCodes true) (MenuIcons createIconMethodsFromDirectory: true) (MenuIcons decorateMenu: true) (UCSTable initializeJISX0208Table true)(UCSTable initializeBG3212Table true)(UCSTable initializeKSX1001Table true) (TextConverter allEncodingNames true))! ! 81196 81197!DecompilerTests methodsFor: 'utilities' stamp: 'eem 11/10/2008 15:30'! 81198decompilerFailures 81199 "here is the list of failures: DNU resulting in trying to decompile the following methods" 81200 81201 ^ #((BalloonEngineSimulation circleCosTable "-0.3826834323650903 => -0.38268343236509 or -0.3826834323650902") 81202 (BalloonEngineSimulation circleSinTable "-0.3826834323650903 => -0.38268343236509 or -0.3826834323650902") 81203 (GeniePlugin primSameClassAbsoluteStrokeDistanceMyPoints:otherPoints:myVectors:otherVectors:mySquaredLengths:otherSquaredLengths:myAngles:otherAngles:maxSizeAndReferenceFlag:rowBase:rowInsertRemove:rowInsertRemoveCount: "Cannot compile -- stack including temps is too deep") 81204 (QPickable2D pick:) "foo ifTrue: [^bar] ifFalse: [^baz]. ^huh?" 81205 (QUsersPane userEntryCompare:to:) "foo ifTrue: [^bar] ifFalse: [^baz]. ^huh?" 81206 (TShaderProgram vertexStrings) "foo ifTrue: []. => foo. => ." 81207 (TShaderProgram fragmentStrings) "foo ifTrue: []. => foo. => ." 81208 (TWindow zoomWindow:) "foo ifTrue: [^bar] ifFalse: [^baz]. ^huh?" 81209 81210 "(PNMReadWriter nextImage) (Collection #ifEmpty:ifNotEmpty:) (Collection #ifEmpty:) (Collection #ifNotEmpty:ifEmpty:) (Text #alignmentAt:ifAbsent:) (ObjectWithDocumentation propertyAt:ifAbsent:)")! ! 81211 81212!DecompilerTests methodsFor: 'utilities' stamp: 'sd 9/25/2004 15:36'! 81213decompilerTestHelper 81214 "Decompiles the source for every method in the system, and 81215 then compiles that source and verifies that it generates (and 81216 decompiles to) identical code. This currently fails in a number 81217 of places because some different patterns (esp involving 81218 conditionals where the first branch returns) decompile the 81219 same. " 81220 "self new decompilerTestHelper" 81221 | methodNode oldMethod newMethod badOnes oldCodeString n | 81222 badOnes := OrderedCollection new. 81223 Smalltalk forgetDoIts. 81224 'Decompiling all classes...' 81225 displayProgressAt: Sensor cursorPoint 81226 from: 0 81227 to: CompiledMethod instanceCount 81228 during: [:bar | 81229 n := 0. 81230 self systemNavigation 81231 allBehaviorsDo: [:cls | 81232 (self isBlockingClass: cls) 81233 ifFalse: [ 81234 Smalltalk garbageCollect. 81235 Transcript cr; show: cls name. 81236 cls selectors 81237 do: [:selector | 81238 (n := n + 1) \\ 100 = 0 81239 ifTrue: [bar value: n]. 81240 (self isFailure: cls sel: selector) 81241 ifFalse: [oldMethod := cls compiledMethodAt: selector. 81242 oldCodeString := (cls decompilerClass new 81243 decompile: selector 81244 in: cls 81245 method: oldMethod) decompileString. 81246 methodNode := cls compilerClass new 81247 compile: oldCodeString 81248 in: cls 81249 notifying: nil 81250 ifFail: []. 81251 newMethod := methodNode generate: #(0 0 0 0 ). 81252 oldCodeString = (cls decompilerClass new 81253 decompile: selector 81254 in: cls 81255 method: newMethod) decompileString 81256 ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. 81257 badOnes add: cls name , ' ' , selector]]]]]]. 81258 self systemNavigation browseMessageList: badOnes asSortedCollection name: 'Decompiler Discrepancies'! ! 81259 81260!DecompilerTests methodsFor: 'utilities' stamp: 'sd 9/25/2004 15:30'! 81261isBlockingClass: cls 81262 "self new isBlockingClass: PNMReaderWriter" 81263 81264 ^ self blockingClasses includes: cls name asSymbol 81265! ! 81266 81267!DecompilerTests methodsFor: 'utilities' stamp: 'eem 11/10/2008 16:52'! 81268isFailure: cls sel: selector 81269 "self new isKnowProblem: PNMReaderWriter sel: #nextImage" 81270 "#((PNMReadWriter nextImage)) includes: {PNMReadWriter 81271 name asSymbol . #nextImage}." 81272 ^(#(#DoIt #DoItIn:) includes: selector) 81273 or: [self decompilerFailures includes: {cls name asSymbol. selector}]! ! 81274 81275!DecompilerTests methodsFor: 'utilities' stamp: 'sd 9/25/2004 21:28'! 81276isStoredProblems: cls sel: selector meta: aBoolean 81277 "self new isKnowProblem: PNMReaderWriter sel: #nextImage" 81278 81279 ^ self decompilerDiscrepancies includes: {cls name asSymbol. selector . aBoolean}! ! 81280 81281 81282!DecompilerTests methodsFor: 'testing' stamp: 'sd 9/26/2004 13:26'! 81283testDecompiler 81284 "self run: #testDecompiler" 81285 "self debug: #testDecompiler" 81286 | methodNode oldMethod newMethod oldCodeString | 81287 Smalltalk forgetDoIts. 81288 self systemNavigation 81289 allBehaviorsDo: [:cls | (self isBlockingClass: cls) 81290 ifFalse: [Smalltalk garbageCollect. 81291 cls selectors 81292 do: [:selector | (self isFailure: cls sel: selector) 81293 ifFalse: [" to help making progress 81294 (self 81295 isStoredProblems: cls theNonMetaClass 81296 sel: selector 81297 meta: cls isMeta) 81298 ifFalse: [ " 81299 Transcript cr; show: cls name. 81300 oldMethod := cls compiledMethodAt: selector. 81301 oldCodeString := (cls decompilerClass new 81302 decompile: selector 81303 in: cls 81304 method: oldMethod) decompileString. 81305 methodNode := cls compilerClass new 81306 compile: oldCodeString 81307 in: cls 81308 notifying: nil 81309 ifFail: []. 81310 newMethod := methodNode generate: #(0 0 0 0 ). 81311 self assert: oldCodeString = (cls decompilerClass new 81312 decompile: selector 81313 in: cls 81314 method: newMethod) decompileString 81315 description: cls name asString, ' ', selector asString 81316 resumable: true. 81317 81318 ]]]]! ! 81319 81320 81321!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81322testDecompilerInClassesAAtoAM 81323 self decompileClassesSelect: [:cn| cn first = $A and: [cn second asUppercase <= $M]]! ! 81324 81325!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81326testDecompilerInClassesANtoAZ 81327 self decompileClassesSelect: [:cn| cn first = $A and: [cn second asUppercase > $M]]! ! 81328 81329!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81330testDecompilerInClassesBAtoBM 81331 self decompileClassesSelect: [:cn| cn first = $B and: [cn second asUppercase <= $M]]! ! 81332 81333!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81334testDecompilerInClassesBNtoBZ 81335 self decompileClassesSelect: [:cn| cn first = $B and: [cn second asUppercase > $M]]! ! 81336 81337!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81338testDecompilerInClassesCAtoCM 81339 self decompileClassesSelect: [:cn| cn first = $C and: [cn second asUppercase <= $M]]! ! 81340 81341!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81342testDecompilerInClassesCNtoCZ 81343 self decompileClassesSelect: [:cn| cn first = $C and: [cn second asUppercase > $M]]! ! 81344 81345!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81346testDecompilerInClassesDAtoDM 81347 self decompileClassesSelect: [:cn| cn first = $D and: [cn second asUppercase <= $M]]! ! 81348 81349!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81350testDecompilerInClassesDNtoDZ 81351 self decompileClassesSelect: [:cn| cn first = $D and: [cn second asUppercase > $M]]! ! 81352 81353!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81354testDecompilerInClassesEAtoEM 81355 self decompileClassesSelect: [:cn| cn first = $E and: [cn second asUppercase <= $M]]! ! 81356 81357!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81358testDecompilerInClassesENtoEZ 81359 self decompileClassesSelect: [:cn| cn first = $E and: [cn second asUppercase > $M]]! ! 81360 81361!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81362testDecompilerInClassesFAtoFM 81363 self decompileClassesSelect: [:cn| cn first = $F and: [cn second asUppercase <= $M]]! ! 81364 81365!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81366testDecompilerInClassesFNtoFZ 81367 self decompileClassesSelect: [:cn| cn first = $F and: [cn second asUppercase > $M]]! ! 81368 81369!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81370testDecompilerInClassesGAtoGM 81371 self decompileClassesSelect: [:cn| cn first = $G and: [cn second asUppercase <= $M]]! ! 81372 81373!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81374testDecompilerInClassesGNtoGZ 81375 self decompileClassesSelect: [:cn| cn first = $G and: [cn second asUppercase > $M]]! ! 81376 81377!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81378testDecompilerInClassesHAtoHM 81379 self decompileClassesSelect: [:cn| cn first = $H and: [cn second asUppercase <= $M]]! ! 81380 81381!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81382testDecompilerInClassesHNtoHZ 81383 self decompileClassesSelect: [:cn| cn first = $H and: [cn second asUppercase > $M]]! ! 81384 81385!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81386testDecompilerInClassesIAtoIM 81387 self decompileClassesSelect: [:cn| cn first = $I and: [cn second asUppercase <= $M]]! ! 81388 81389!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81390testDecompilerInClassesINtoIZ 81391 self decompileClassesSelect: [:cn| cn first = $I and: [cn second asUppercase > $M]]! ! 81392 81393!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81394testDecompilerInClassesJAtoJM 81395 self decompileClassesSelect: [:cn| cn first = $J and: [cn second asUppercase <= $M]]! ! 81396 81397!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81398testDecompilerInClassesJNtoJZ 81399 self decompileClassesSelect: [:cn| cn first = $J and: [cn second asUppercase > $M]]! ! 81400 81401!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81402testDecompilerInClassesKAtoKM 81403 self decompileClassesSelect: [:cn| cn first = $K and: [cn second asUppercase <= $M]]! ! 81404 81405!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81406testDecompilerInClassesKNtoKZ 81407 self decompileClassesSelect: [:cn| cn first = $K and: [cn second asUppercase > $M]]! ! 81408 81409!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81410testDecompilerInClassesLAtoLM 81411 self decompileClassesSelect: [:cn| cn first = $L and: [cn second asUppercase <= $M]]! ! 81412 81413!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81414testDecompilerInClassesLNtoLZ 81415 self decompileClassesSelect: [:cn| cn first = $L and: [cn second asUppercase > $M]]! ! 81416 81417!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81418testDecompilerInClassesMAtoMM 81419 self decompileClassesSelect: [:cn| cn first = $M and: [cn second asUppercase <= $M]]! ! 81420 81421!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81422testDecompilerInClassesMNtoMZ 81423 self decompileClassesSelect: [:cn| cn first = $M and: [cn second asUppercase > $M]]! ! 81424 81425!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81426testDecompilerInClassesNAtoNM 81427 self decompileClassesSelect: [:cn| cn first = $N and: [cn second asUppercase <= $M]]! ! 81428 81429!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81430testDecompilerInClassesNNtoNZ 81431 self decompileClassesSelect: [:cn| cn first = $N and: [cn second asUppercase > $M]]! ! 81432 81433!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81434testDecompilerInClassesOAtoOM 81435 self decompileClassesSelect: [:cn| cn first = $O and: [cn second asUppercase <= $M]]! ! 81436 81437!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81438testDecompilerInClassesONtoOZ 81439 self decompileClassesSelect: [:cn| cn first = $O and: [cn second asUppercase > $M]]! ! 81440 81441!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81442testDecompilerInClassesPAtoPM 81443 self decompileClassesSelect: [:cn| cn first = $P and: [cn second asUppercase <= $M]]! ! 81444 81445!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81446testDecompilerInClassesPNtoPZ 81447 self decompileClassesSelect: [:cn| cn first = $P and: [cn second asUppercase > $M]]! ! 81448 81449!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81450testDecompilerInClassesQAtoQM 81451 self decompileClassesSelect: [:cn| cn first = $Q and: [cn second asUppercase <= $M]]! ! 81452 81453!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81454testDecompilerInClassesQNtoQZ 81455 self decompileClassesSelect: [:cn| cn first = $Q and: [cn second asUppercase > $M]]! ! 81456 81457!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81458testDecompilerInClassesRAtoRM 81459 self decompileClassesSelect: [:cn| cn first = $R and: [cn second asUppercase <= $M]]! ! 81460 81461!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81462testDecompilerInClassesRNtoRZ 81463 self decompileClassesSelect: [:cn| cn first = $R and: [cn second asUppercase > $M]]! ! 81464 81465!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81466testDecompilerInClassesSAtoSM 81467 self decompileClassesSelect: [:cn| cn first = $S and: [cn second asUppercase <= $M]]! ! 81468 81469!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81470testDecompilerInClassesSNtoSZ 81471 self decompileClassesSelect: [:cn| cn first = $S and: [cn second asUppercase > $M]]! ! 81472 81473!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81474testDecompilerInClassesTAtoTM 81475 self decompileClassesSelect: [:cn| cn first = $T and: [cn second asUppercase <= $M]]! ! 81476 81477!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81478testDecompilerInClassesTNtoTZ 81479 self decompileClassesSelect: [:cn| cn first = $T and: [cn second asUppercase > $M]]! ! 81480 81481!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81482testDecompilerInClassesUAtoUM 81483 self decompileClassesSelect: [:cn| cn first = $U and: [cn second asUppercase <= $M]]! ! 81484 81485!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81486testDecompilerInClassesUNtoUZ 81487 self decompileClassesSelect: [:cn| cn first = $U and: [cn second asUppercase > $M]]! ! 81488 81489!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81490testDecompilerInClassesVAtoVM 81491 self decompileClassesSelect: [:cn| cn first = $V and: [cn second asUppercase <= $M]]! ! 81492 81493!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81494testDecompilerInClassesVNtoVZ 81495 self decompileClassesSelect: [:cn| cn first = $V and: [cn second asUppercase > $M]]! ! 81496 81497!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81498testDecompilerInClassesWAtoWM 81499 self decompileClassesSelect: [:cn| cn first = $W and: [cn second asUppercase <= $M]]! ! 81500 81501!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81502testDecompilerInClassesWNtoWZ 81503 self decompileClassesSelect: [:cn| cn first = $W and: [cn second asUppercase > $M]]! ! 81504 81505!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81506testDecompilerInClassesXAtoXM 81507 self decompileClassesSelect: [:cn| cn first = $X and: [cn second asUppercase <= $M]]! ! 81508 81509!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81510testDecompilerInClassesXNtoXZ 81511 self decompileClassesSelect: [:cn| cn first = $X and: [cn second asUppercase > $M]]! ! 81512 81513!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81514testDecompilerInClassesYAtoYM 81515 self decompileClassesSelect: [:cn| cn first = $Y and: [cn second asUppercase <= $M]]! ! 81516 81517!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81518testDecompilerInClassesYNtoYZ 81519 self decompileClassesSelect: [:cn| cn first = $Y and: [cn second asUppercase > $M]]! ! 81520 81521!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81522testDecompilerInClassesZAtoZM 81523 self decompileClassesSelect: [:cn| cn first = $Z and: [cn second asUppercase <= $M]]! ! 81524 81525!DecompilerTests methodsFor: 'tests' stamp: 'eem 9/23/2008 11:16'! 81526testDecompilerInClassesZNtoZZ 81527 self decompileClassesSelect: [:cn| cn first = $Z and: [cn second asUppercase > $M]]! ! 81528Object subclass: #DeepCopier 81529 instanceVariableNames: 'references' 81530 classVariableNames: 'NextVariableCheckTime' 81531 poolDictionaries: '' 81532 category: 'System-Object Storage'! 81533!DeepCopier commentStamp: 'stephane.ducasse 9/25/2008 17:47' prior: 0! 81534DeepCopier does a veryDeepCopy. 81535 81536It is a complete tree copy using a dictionary. Any object that is in the tree twice is only copied once. All references to the object in the copy of the tree will point to the new copy. See Object|veryDeepCopy which calls (self veryDeepCopyWith: aDeepCopier). 81537 81538When a tree of morphs points at a morph outside of itself, that morph should not be copied. Use our own kind of weak pointers for the 'potentially outside' morphs. Default is that any new class will have all of its fields deeply copied. If a field needs to be weakly copied, define veryDeepInner: and veryDeepFixupWith:. 81539 veryDeepInner: has the loop that actually copies the fields. If a class defines its own copy of veryDeepInner: (to leave some fields out), then veryDeepFixupWith: will be called on that object at the end. veryDeepInner: can compute an alternate object to put in a field. (Object veryDeepCopyWith: discovers which superclasses did not define veryDeepInner:, and very deeply copies the variables defined in those classes). 81540 To decide if a class needs veryDeepInner: and veryDeepFixupWith:, ask this about an instance: If I duplicate this object, does that mean that I also want to make duplicates of the things it holds onto? If yes, (i.e. a Paragraph does want a new copy of its Text) then do nothing. If no, (i.e. an undo command does not want to copy the objects it acts upon), then define veryDeepInner: and veryDeepFixupWith:. 81541 81542Here is an analysis for the specific case of a morph being held by another morph. 81543Does field X contain a morph (or a Player whose costume is a morph)? If not, no action needed. 81544Is the morph in field X already a submorph of the object? Is it down lower in the submorph tree? 81545 If so, no action needed. 81546Could the morph in field X every appear on the screen (be a submorph of some other morph)? 81547 If not, no action needed. 81548 If it could, you must write the methods veryDeepFixupWith: and veryDeepInner:, and in them, refrain from sending veryDeepCopyWith: to the contents of field X. 81549 81550 81551----- Things Ted is still considering ----- 81552Rule: If a morph stores a uniClass class (Player 57) as an object in a field, the new uniClass will not be stored there. Each uniClass instance does have a new class created for it. (fix this by putting the old class in references and allow lookup? Wrong if encounter it before seeing an instance?) 81553 81554Rule: If object A has object C in a field, and A says (^ C) for the copy, but object B has A in a normal field and it gets deepCopied, and A in encountered first, then there will be two copies of C. (just be aware of it) 81555 81556Dependents are now fixed up. Suppose a model has a dependent view. In the DependentFields dictionary, model -> (view ...). 81557 If only the model is copied, no dependents are created (no one knows about the new model). 81558 If only the view is copied, it is inserted into DependentFields on the right side. model -> (view copiedView ...). 81559 If both are copied, the new model has the new view as its dependent. 81560 If additional things depend on a model that is copied, the caller must add them to its dependents. 81561! 81562 81563 81564!DeepCopier methodsFor: 'like fullCopy' stamp: 'eem 6/11/2008 17:21'! 81565checkDeep 81566 "Write exceptions in the Transcript. Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. This check is only run by hand once in a while to make sure nothing was forgotten. 81567(Please do not remove this method.) 81568 DeepCopier new checkDeep " 81569 81570 Transcript 81571 cr; 81572 show: 'Instance variables shared with the original object when it is copied'. 81573 (self systemNavigation allClassesImplementing: #veryDeepInner:) do: 81574 [:aClass | | mm | 81575 (mm := aClass instVarNames size) > 0 ifTrue: 81576 [aClass instSize - mm + 1 to: aClass instSize do: 81577 [:index | 81578 ((aClass compiledMethodAt: #veryDeepInner:) writesField: index) ifFalse: 81579 [Transcript 81580 cr; 81581 show: aClass name; 81582 space; 81583 show: (aClass allInstVarNames at: index)]]]]! ! 81584 81585!DeepCopier methodsFor: 'like fullCopy' stamp: 'eem 6/11/2008 17:21'! 81586checkVariables 81587 "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it. 81588 DeepCopier new checkVariables " 81589 81590 self checkBasicClasses. 81591 81592 "Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. So check that the last one is mentioned in the copy method." 81593 (self systemNavigation allClassesImplementing: #veryDeepInner:) do: 81594 [:aClass | 81595 ((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) 81596 ifFalse: 81597 [aClass instSize > 0 81598 ifTrue: [self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]]. 81599 (self systemNavigation allClassesImplementing: #veryDeepCopyWith:) do: 81600 [:aClass | | meth | 81601 meth := aClass compiledMethodAt: #veryDeepCopyWith:. 81602 meth size > 20 & (meth literals includes: #veryDeepCopyWith:) not 81603 ifTrue: 81604 [(meth writesField: aClass instSize) 81605 ifFalse: [self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]! ! 81606 81607!DeepCopier methodsFor: 'like fullCopy' stamp: 'eem 6/11/2008 17:22'! 81608fixDependents 81609 "They are not used much, but need to be right" 81610 81611 DependentsFields associationsDo: 81612 [:pair | 81613 pair value do: 81614 [:dep | 81615 (references at: dep ifAbsent: [nil]) ifNotNil: 81616 [:newDep| | newModel | 81617 newModel := references at: pair key ifAbsent: [pair key]. 81618 newModel addDependent: newDep]]]. 81619! ! 81620 81621 81622!DeepCopier methodsFor: 'like fullcopy' stamp: 'stephane.ducasse 1/30/2009 21:52'! 81623checkBasicClasses 81624 "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it. 81625 DeepCopier new checkVariables " 81626 81627 | str objCls morphCls | 81628 str := '|veryDeepCopyWith: or veryDeepInner: is out of date.'. 81629 (objCls := self objInMemory: #Object) ifNotNil: [ 81630 objCls instSize = 0 ifFalse: [self error: 81631 'Many implementers of veryDeepCopyWith: are out of date']]. 81632 (morphCls := self objInMemory: #Morph) ifNotNil: [ 81633 morphCls superclass == Object ifFalse: [self error: 'Morph', str]. 81634 (morphCls instVarNames copyFrom: 1 to: 6) = #('bounds' 'owner' 'submorphs' 81635 'fullBounds' 'color' 'extension') 81636 ifFalse: [self error: 'Morph', str]]. "added ones are OK" 81637 81638! ! 81639 81640!DeepCopier methodsFor: 'like fullcopy' stamp: 'tk 3/7/2001 15:42'! 81641checkClass: aClass 81642 | meth | 81643 "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it." 81644 81645 self checkBasicClasses. "Unlikely, but important to catch when it does happen." 81646 81647 "Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. So check that the last one is mentioned in the copy method." 81648 (aClass includesSelector: #veryDeepInner:) ifTrue: [ 81649 ((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [ 81650 aClass instSize > 0 ifTrue: [ 81651 self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]]. 81652 (aClass includesSelector: #veryDeepCopyWith:) ifTrue: [ 81653 meth := aClass compiledMethodAt: #veryDeepCopyWith:. 81654 (meth size > 20) & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [ 81655 (meth writesField: aClass instSize) ifFalse: [ 81656 self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]. 81657! ! 81658 81659!DeepCopier methodsFor: 'like fullcopy' stamp: 'alain.plantec 5/28/2009 09:50'! 81660initialize 81661 81662 super initialize. 81663 self initialize: 4096. 81664! ! 81665 81666!DeepCopier methodsFor: 'like fullcopy' stamp: 'stephane.ducasse 9/25/2008 17:46'! 81667initialize: size 81668 81669 references := IdentityDictionary new: size. 81670 ! ! 81671 81672!DeepCopier methodsFor: 'like fullcopy' stamp: 'tk 11/24/1999 17:53'! 81673intervalForChecks 81674 "set delay interval for checking for new instance variables to 10 minutes. hg 11/23/1999" 81675 81676 ^600 81677! ! 81678 81679!DeepCopier methodsFor: 'like fullcopy' stamp: 'tk 11/25/1999 14:37'! 81680isItTimeToCheckVariables 81681 81682 | now isIt | 81683 NextVariableCheckTime ifNil: [ 81684 NextVariableCheckTime := Time totalSeconds. 81685 ^ true]. 81686 now := Time totalSeconds. 81687 isIt := NextVariableCheckTime < now. 81688 isIt ifTrue: ["update time for next check" 81689 NextVariableCheckTime := now + self intervalForChecks]. 81690 ^isIt 81691! ! 81692 81693!DeepCopier methodsFor: 'like fullcopy' stamp: 'tk 3/7/2001 15:29'! 81694objInMemory: ClassSymbol 81695 | cls | 81696 "Test if this global is in memory and return it if so." 81697 81698 cls := Smalltalk at: ClassSymbol ifAbsent: [^ nil]. 81699 ^ cls isInMemory ifTrue: [cls] ifFalse: [nil].! ! 81700 81701!DeepCopier methodsFor: 'like fullcopy' stamp: 'tk 8/20/1998 22:13'! 81702references 81703 ^ references! ! 81704 81705!DeepCopier methodsFor: 'like fullcopy' stamp: 'ar 9/27/2005 20:27'! 81706warnIverNotCopiedIn: aClass sel: sel 81707 "Warn the user to update veryDeepCopyWith: or veryDeepInner:" 81708 81709 self inform: ('An instance variable was added to to class ', aClass name, ',\and it is not copied in the method ', sel, '.\Please rewrite it to handle all instance variables.\See DeepCopier class comment.') withCRs. 81710 ToolSet browse: aClass selector: sel! ! 81711Object subclass: #DefaultExternalDropHandler 81712 instanceVariableNames: '' 81713 classVariableNames: '' 81714 poolDictionaries: '' 81715 category: 'System-Support'! 81716!DefaultExternalDropHandler commentStamp: 'dgd 4/5/2004 19:07' prior: 0! 81717An alternative default handler that uses the file-list services to process files. 81718! 81719 81720 81721!DefaultExternalDropHandler methodsFor: 'event handling' stamp: 'bf 9/21/2004 18:44'! 81722handle: dropStream in: pasteUp dropEvent: anEvent 81723 "the file was just droped, let's do our job" 81724 | fileName services theOne | 81725 fileName := dropStream name. 81726 "" 81727 services := self servicesForFileNamed: fileName. 81728 "" 81729 "no service, default behavior" 81730 services isEmpty 81731 ifTrue: ["" 81732 dropStream edit. 81733 ^ self]. 81734 "" 81735 theOne := self chooseServiceFrom: services. 81736 theOne isNil 81737 81738 ifFalse: [theOne performServiceFor: dropStream]! ! 81739 81740 81741!DefaultExternalDropHandler methodsFor: 'private' stamp: 'alain.plantec 2/8/2009 22:02'! 81742chooseServiceFrom: aCollection 81743 "private - choose a service from aCollection asking the user if 81744 needed" 81745 aCollection size = 1 81746 ifTrue: [^ aCollection anyOne]. 81747 ^ UIManager default chooseFrom: (aCollection collect: [:each | each label]) values: aCollection. 81748! ! 81749 81750!DefaultExternalDropHandler methodsFor: 'private' stamp: 'dgd 4/5/2004 19:23'! 81751servicesForFileNamed: aString 81752 "private - answer a collection of file-services for the file named 81753 aString" 81754 | allServices | 81755 allServices := FileList itemsForFile: aString. 81756 ^ allServices 81757 reject: [:svc | self unwantedSelectors includes: svc selector]! ! 81758 81759!DefaultExternalDropHandler methodsFor: 'private' stamp: 'dgd 4/5/2004 19:23'! 81760unwantedSelectors 81761 "private - answer a collection well known unwanted selectors " 81762 ^ #(#removeLineFeeds: #addFileToNewZip: #compressFile: #putUpdate: )! ! 81763 81764"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 81765 81766DefaultExternalDropHandler class 81767 instanceVariableNames: ''! 81768 81769!DefaultExternalDropHandler class methodsFor: 'initialization' stamp: 'dgd 4/5/2004 19:10'! 81770initialize 81771 "initialize the receiver" 81772 ExternalDropHandler defaultHandler: self new! ! 81773 81774!DefaultExternalDropHandler class methodsFor: 'initialization' stamp: 'dgd 4/5/2004 19:09'! 81775unload 81776 "initialize the receiver" 81777 ExternalDropHandler defaultHandler: nil! ! 81778WriteStream subclass: #DeflateStream 81779 instanceVariableNames: 'hashHead hashTail hashValue blockPosition blockStart' 81780 classVariableNames: '' 81781 poolDictionaries: 'ZipConstants' 81782 category: 'Compression-Streams'! 81783 81784!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:00'! 81785goodMatchLength 81786 "Return the length that is considered to be a 'good' match. 81787 Higher values will result in better compression but take more time." 81788 ^MaxMatch "Best compression"! ! 81789 81790!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:00'! 81791hashChainLength 81792 "Return the max. number of hash chains to traverse. 81793 Higher values will result in better compression but take more time." 81794 ^4096 "Best compression"! ! 81795 81796!DeflateStream methodsFor: 'accessing' stamp: 'ar 2/19/2004 00:34'! 81797next: bytes putAll: aCollection startingAt: startPos 81798 (startPos = 1 and:[bytes = aCollection size]) 81799 ifTrue:[^self nextPutAll: aCollection]. 81800 ^self nextPutAll: (aCollection copyFrom: startPos to: startPos + bytes - 1)! ! 81801 81802!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 17:33'! 81803nextPutAll: aCollection 81804 | start count max | 81805 aCollection species = collection species 81806 ifFalse:[ 81807 aCollection do:[:ch| self nextPut: ch]. 81808 ^aCollection]. 81809 start := 1. 81810 count := aCollection size. 81811 [count = 0] whileFalse:[ 81812 position = writeLimit ifTrue:[self deflateBlock]. 81813 max := writeLimit - position. 81814 max > count ifTrue:[max := count]. 81815 collection replaceFrom: position+1 81816 to: position+max 81817 with: aCollection 81818 startingAt: start. 81819 start := start + max. 81820 count := count - max. 81821 position := position + max]. 81822 ^aCollection! ! 81823 81824!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/28/1999 17:35'! 81825pastEndPut: anObject 81826 self deflateBlock. 81827 ^self nextPut: anObject! ! 81828 81829 81830!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 20:24'! 81831compare: here with: matchPos min: minLength 81832 "Compare the two strings and return the length of matching characters. 81833 minLength is a lower bound for match lengths that will be accepted. 81834 Note: here and matchPos are zero based." 81835 | length | 81836 "First test if we can actually get longer than minLength" 81837 (collection at: here+minLength+1) = (collection at: matchPos+minLength+1) 81838 ifFalse:[^0]. 81839 (collection at: here+minLength) = (collection at: matchPos+minLength) 81840 ifFalse:[^0]. 81841 "Then test if we have an initial match at all" 81842 (collection at: here+1) = (collection at: matchPos+1) 81843 ifFalse:[^0]. 81844 (collection at: here+2) = (collection at: matchPos+2) 81845 ifFalse:[^1]. 81846 "Finally do the real comparison" 81847 length := 3. 81848 [length <= MaxMatch and:[ 81849 (collection at: here+length) = (collection at: matchPos+length)]] 81850 whileTrue:[length := length + 1]. 81851 ^length - 1! ! 81852 81853!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/31/1999 18:00'! 81854deflateBlock 81855 "Deflate the current contents of the stream" 81856 | flushNeeded lastIndex | 81857 (blockStart == nil) ifTrue:[ 81858 "One time initialization for the first block" 81859 1 to: MinMatch-1 do:[:i| self updateHashAt: i]. 81860 blockStart := 0]. 81861 81862 [blockPosition < position] whileTrue:[ 81863 (position + MaxMatch > writeLimit) 81864 ifTrue:[lastIndex := writeLimit - MaxMatch] 81865 ifFalse:[lastIndex := position]. 81866 flushNeeded := self deflateBlock: lastIndex-1 81867 chainLength: self hashChainLength 81868 goodMatch: self goodMatchLength. 81869 flushNeeded ifTrue:[ 81870 self flushBlock. 81871 blockStart := blockPosition]. 81872 "Make room for more data" 81873 self moveContentsToFront]. 81874! ! 81875 81876!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 18:05'! 81877deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch 81878 "Continue deflating the receiver's collection from blockPosition to lastIndex. 81879 Note that lastIndex must be at least MaxMatch away from the end of collection" 81880 | here matchResult flushNeeded hereMatch hereLength newMatch newLength hasMatch | 81881 blockPosition > lastIndex ifTrue:[^false]. "Nothing to deflate" 81882 hasMatch := false. 81883 here := blockPosition. 81884 [here <= lastIndex] whileTrue:[ 81885 hasMatch ifFalse:[ 81886 "Find the first match" 81887 matchResult := self findMatch: here 81888 lastLength: MinMatch-1 81889 lastMatch: here 81890 chainLength: chainLength 81891 goodMatch: goodMatch. 81892 self insertStringAt: here. "update hash table" 81893 hereMatch := matchResult bitAnd: 16rFFFF. 81894 hereLength := matchResult bitShift: -16]. 81895 81896 "Look ahead if there is a better match at the next position" 81897 matchResult := self findMatch: here+1 81898 lastLength: hereLength 81899 lastMatch: hereMatch 81900 chainLength: chainLength 81901 goodMatch: goodMatch. 81902 newMatch := matchResult bitAnd: 16rFFFF. 81903 newLength := matchResult bitShift: -16. 81904 81905 "Now check if the next match is better than the current one. 81906 If not, output the current match (provided that the current match 81907 is at least MinMatch long)" 81908 (hereLength >= newLength and:[hereLength >= MinMatch]) ifTrue:[ 81909 self assert:[self validateMatchAt: here 81910 from: hereMatch to: hereMatch + hereLength - 1]. 81911 "Encode the current match" 81912 flushNeeded := self 81913 encodeMatch: hereLength 81914 distance: here - hereMatch. 81915 "Insert all strings up to the end of the current match. 81916 Note: The first string has already been inserted." 81917 1 to: hereLength-1 do:[:i| self insertStringAt: (here := here + 1)]. 81918 hasMatch := false. 81919 here := here + 1. 81920 ] ifFalse:[ 81921 "Either the next match is better than the current one or we didn't 81922 have a good match after all (e.g., current match length < MinMatch). 81923 Output a single literal." 81924 flushNeeded := self encodeLiteral: (collection byteAt: (here + 1)). 81925 here := here + 1. 81926 (here <= lastIndex and:[flushNeeded not]) ifTrue:[ 81927 "Cache the results for the next round" 81928 self insertStringAt: here. 81929 hasMatch := true. 81930 hereMatch := newMatch. 81931 hereLength := newLength]. 81932 ]. 81933 flushNeeded ifTrue:[blockPosition := here. ^true]. 81934 ]. 81935 blockPosition := here. 81936 ^false! ! 81937 81938!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:45'! 81939findMatch: here lastLength: lastLength lastMatch: lastMatch chainLength: maxChainLength goodMatch: goodMatch 81940 "Find the longest match for the string starting at here. 81941 If there is no match longer than lastLength return lastMatch/lastLength. 81942 Traverse at most maxChainLength entries in the hash table. 81943 Stop if a match of at least goodMatch size has been found." 81944 | matchResult matchPos distance chainLength limit bestLength length | 81945 "Compute the default match result" 81946 matchResult := (lastLength bitShift: 16) bitOr: lastMatch. 81947 81948 "There is no way to find a better match than MaxMatch" 81949 lastLength >= MaxMatch ifTrue:[^matchResult]. 81950 81951 "Start position for searches" 81952 matchPos := hashHead at: (self updateHashAt: here + MinMatch) + 1. 81953 81954 "Compute the distance to the (possible) match" 81955 distance := here - matchPos. 81956 81957 "Note: It is required that 0 < distance < MaxDistance" 81958 (distance > 0 and:[distance < MaxDistance]) ifFalse:[^matchResult]. 81959 81960 chainLength := maxChainLength. "Max. nr of match chain to search" 81961 here > MaxDistance "Limit for matches that are too old" 81962 ifTrue:[limit := here - MaxDistance] 81963 ifFalse:[limit := 0]. 81964 81965 "Best match length so far (current match must be larger to take effect)" 81966 bestLength := lastLength. 81967 81968 ["Compare the current string with the string at match position" 81969 length := self compare: here with: matchPos min: bestLength. 81970 "Truncate accidental matches beyound stream position" 81971 (here + length > position) ifTrue:[length := position - here]. 81972 "Ignore very small matches if they are too far away" 81973 (length = MinMatch and:[(here - matchPos) > (MaxDistance // 4)]) 81974 ifTrue:[length := MinMatch - 1]. 81975 length > bestLength ifTrue:["We have a new (better) match than before" 81976 "Compute the new match result" 81977 matchResult := (length bitShift: 16) bitOr: matchPos. 81978 bestLength := length. 81979 "There is no way to find a better match than MaxMatch" 81980 bestLength >= MaxMatch ifTrue:[^matchResult]. 81981 "But we may have a good, fast match" 81982 bestLength > goodMatch ifTrue:[^matchResult]. 81983 ]. 81984 (chainLength := chainLength - 1) > 0] whileTrue:[ 81985 "Compare with previous entry in hash chain" 81986 matchPos := hashTail at: (matchPos bitAnd: WindowMask) + 1. 81987 matchPos <= limit ifTrue:[^matchResult]. "Match position is too old" 81988 ]. 81989 ^matchResult! ! 81990 81991!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/28/1999 17:37'! 81992flushBlock 81993 "Flush a deflated block"! ! 81994 81995!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:46'! 81996insertStringAt: here 81997 "Insert the string at the given start position into the hash table. 81998 Note: The hash value is updated starting at MinMatch-1 since 81999 all strings before have already been inserted into the hash table 82000 (and the hash value is updated as well)." 82001 | prevEntry | 82002 hashValue := self updateHashAt: (here + MinMatch). 82003 prevEntry := hashHead at: hashValue+1. 82004 hashHead at: hashValue+1 put: here. 82005 hashTail at: (here bitAnd: WindowMask)+1 put: prevEntry.! ! 82006 82007!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:48'! 82008updateHash: nextValue 82009 "Update the running hash value based on the next input byte. 82010 Return the new updated hash value." 82011 ^((hashValue bitShift: HashShift) bitXor: nextValue) bitAnd: HashMask.! ! 82012 82013!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:47'! 82014updateHashAt: here 82015 "Update the hash value at position here (one based)" 82016 ^self updateHash: (collection byteAt: here)! ! 82017 82018!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/28/1999 17:43'! 82019validateMatchAt: pos from: startPos to: endPos 82020 | here | 82021 here := pos. 82022 startPos+1 to: endPos+1 do:[:i| 82023 (collection at: i) = (collection at: (here := here + 1)) 82024 ifFalse:[^self error:'Not a match']]. 82025 ^true! ! 82026 82027 82028!DeflateStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:04'! 82029encodeLiteral: literal 82030 "Encode the given literal. 82031 Return true if the current block needs to be flushed." 82032 ^false! ! 82033 82034!DeflateStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:04'! 82035encodeMatch: matchLength distance: matchDistance 82036 "Encode a match of the given length and distance. 82037 Return true if the current block should be flushed." 82038 ^false! ! 82039 82040 82041!DeflateStream methodsFor: 'initialization' stamp: 'ar 12/29/1999 17:30'! 82042flush 82043 "Force compression" 82044 self deflateBlock.! ! 82045 82046!DeflateStream methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:51'! 82047initialize 82048 super initialize. 82049 blockStart := nil. 82050 blockPosition := 0. 82051 hashValue := 0. 82052 self initializeHashTables.! ! 82053 82054!DeflateStream methodsFor: 'initialization' stamp: 'ar 12/29/1999 17:32'! 82055initializeHashTables 82056 hashHead := WordArray new: 1 << HashBits. 82057 hashTail := WordArray new: WindowSize. 82058! ! 82059 82060!DeflateStream methodsFor: 'initialization' stamp: 'ar 12/29/1999 17:33'! 82061on: aCollection 82062 self initialize. 82063 super on: (aCollection species new: WindowSize * 2).! ! 82064 82065!DeflateStream methodsFor: 'initialization' stamp: 'ar 12/28/1999 17:34'! 82066on: aCollection from: firstIndex to: lastIndex 82067 "Not for DeflateStreams please" 82068 ^self shouldNotImplement! ! 82069 82070 82071!DeflateStream methodsFor: 'private' stamp: 'ar 12/29/1999 17:50'! 82072moveContentsToFront 82073 "Move the contents of the receiver to the front" 82074 | delta | 82075 delta := (blockPosition - WindowSize). 82076 delta <= 0 ifTrue:[^self]. 82077 "Move collection" 82078 collection 82079 replaceFrom: 1 82080 to: collection size - delta 82081 with: collection 82082 startingAt: delta+1. 82083 position := position - delta. 82084 "Move hash table entries" 82085 blockPosition := blockPosition - delta. 82086 blockStart := blockStart - delta. 82087 self updateHashTable: hashHead delta: delta. 82088 self updateHashTable: hashTail delta: delta.! ! 82089 82090!DeflateStream methodsFor: 'private' stamp: 'ar 2/2/2001 15:47'! 82091updateHashTable: table delta: delta 82092 | pos | 82093 <primitive: 'primitiveDeflateUpdateHashTable' module: 'ZipPlugin'> 82094 1 to: table size do:[:i| 82095 "Discard entries that are out of range" 82096 (pos := table at: i) >= delta 82097 ifTrue:[table at: i put: pos - delta] 82098 ifFalse:[table at: i put: 0]].! ! 82099Object subclass: #Delay 82100 instanceVariableNames: 'delayDuration resumptionTime delaySemaphore beingWaitedOn' 82101 classVariableNames: 'AccessProtect ActiveDelay ActiveDelayStartTime DelaySuspended FinishedDelay RunTimerEventLoop ScheduledDelay SuspendedDelays TimerEventLoop TimingSemaphore' 82102 poolDictionaries: '' 82103 category: 'Kernel-Processes'! 82104!Delay commentStamp: 'stephaneducasse 10/1/2005 21:07' prior: 0! 82105I am the main way that a process may pause for some amount of time. The simplest usage is like this: 82106 82107 (Delay forSeconds: 5) wait. 82108 82109An instance of Delay responds to the message 'wait' by suspending the caller's process for a certain amount of time. The duration of the pause is specified when the Delay is created with the message forMilliseconds: or forSeconds:. A Delay can be used again when the current wait has finished. For example, a clock process might repeatedly wait on a one-second Delay. 82110 82111The maximum delay is (SmallInteger maxVal // 2) milliseconds, or about six days. A delay in progress when an image snapshot is saved is resumed when the snapshot is re-started. Delays work across millisecond clock roll-overs. 82112 82113 82114For a more complex example, see #testDelayOf:for:rect: . 82115 82116A word of advice: 82117This is THE highest priority code which is run in Squeak, in other words it is time-critical. The speed of this code is critical for accurate responses, it is critical for network services, it affects every last part of the system. 82118 82119In short: Don't fix it if it ain't broken!! This code isn't supposed to be beautiful, it's supposed to be fast!! The reason for duplicating code is to make it fast. The reason for not using ifNil:[]ifNotNil:[] is that the compiler may not inline those. Since the effect of changes are VERY hard to predict it is best to leave things as they are for now unless there is an actual need to change anything! 82120 82121 82122!Delay methodsFor: 'delaying' stamp: 'nk 3/14/2001 08:52'! 82123isExpired 82124 82125 ^delaySemaphore isSignaled. 82126! ! 82127 82128!Delay methodsFor: 'delaying' stamp: 'ar 8/30/2007 19:32'! 82129wait 82130 "Schedule this Delay, then wait on its semaphore. The current process will be suspended for the amount of time specified when this Delay was created." 82131 82132 self schedule. 82133 [delaySemaphore wait] ifCurtailed:[self unschedule]. 82134! ! 82135 82136 82137!Delay methodsFor: 'printing' stamp: 'ar 7/10/2007 22:12'! 82138printOn: aStream 82139 super printOn: aStream. 82140 aStream nextPutAll: '('; print: delayDuration; nextPutAll: ' msecs'. 82141 beingWaitedOn ifTrue:[ 82142 aStream nextPutAll: '; '; print: resumptionTime - Time millisecondClockValue; nextPutAll: ' msecs remaining'. 82143 ]. 82144 aStream nextPutAll: ')'.! ! 82145 82146 82147!Delay methodsFor: 'public' stamp: 'ar 7/10/2007 21:49'! 82148beingWaitedOn 82149 "Answer whether this delay is currently scheduled, e.g., being waited on" 82150 ^beingWaitedOn! ! 82151 82152!Delay methodsFor: 'public' stamp: 'ar 7/10/2007 21:49'! 82153beingWaitedOn: aBool 82154 "Indicate whether this delay is currently scheduled, e.g., being waited on" 82155 beingWaitedOn := aBool! ! 82156 82157!Delay methodsFor: 'public' stamp: 'ar 7/10/2007 20:56'! 82158delayDuration 82159 ^delayDuration! ! 82160 82161!Delay methodsFor: 'public' stamp: 'brp 10/21/2004 16:05'! 82162delaySemaphore 82163 82164 ^ delaySemaphore! ! 82165 82166 82167!Delay methodsFor: 'private' stamp: 'jm 9/11/97 14:49'! 82168adjustResumptionTimeOldBase: oldBaseTime newBase: newBaseTime 82169 "Private!! Adjust the value of the system's millisecond clock at which this Delay will be awoken. Used to adjust resumption times after a snapshot or clock roll-over." 82170 82171 resumptionTime := newBaseTime + (resumptionTime - oldBaseTime). 82172! ! 82173 82174!Delay methodsFor: 'private' stamp: 'jm 9/11/97 11:54'! 82175resumptionTime 82176 "Answer the value of the system's millisecondClock at which the receiver's suspended Process will resume." 82177 82178 ^ resumptionTime 82179! ! 82180 82181!Delay methodsFor: 'private' stamp: 'ar 9/21/2009 22:19'! 82182schedule 82183 "Schedule this delay" 82184 beingWaitedOn ifTrue: [^self error: 'This Delay has already been scheduled.']. 82185 resumptionTime := Time millisecondClockValue + delayDuration. 82186 AccessProtect critical:[ 82187 ScheduledDelay := self. 82188 TimingSemaphore signal. 82189 ].! ! 82190 82191!Delay methodsFor: 'private' stamp: 'nice 4/19/2009 21:18'! 82192setDelay: milliseconds forSemaphore: aSemaphore 82193 "Private!! Initialize this delay to signal the given semaphore after the given number of milliseconds." 82194 82195 delayDuration := milliseconds asInteger. 82196 delayDuration < 0 ifTrue: [self error: 'delay times cannot be negative']. 82197 delaySemaphore := aSemaphore. 82198 beingWaitedOn := false.! ! 82199 82200!Delay methodsFor: 'private' stamp: 'jm 9/11/97 11:54'! 82201signalWaitingProcess 82202 "The delay time has elapsed; signal the waiting process." 82203 82204 beingWaitedOn := false. 82205 delaySemaphore signal. 82206! ! 82207 82208!Delay methodsFor: 'private' stamp: 'ar 3/2/2009 14:42'! 82209unschedule 82210 AccessProtect critical:[ 82211 FinishedDelay := self. 82212 TimingSemaphore signal. 82213 ].! ! 82214 82215"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 82216 82217Delay class 82218 instanceVariableNames: ''! 82219 82220!Delay class methodsFor: 'class initialization' stamp: 'ar 7/11/2007 18:16'! 82221initialize 82222 "Delay initialize" 82223 self startTimerEventLoop.! ! 82224 82225 82226!Delay class methodsFor: 'example' stamp: 'jm 9/11/97 11:23'! 82227testDelayOf: delay for: testCount rect: r 82228 "Delay testDelayOf: 100 for: 20 rect: (10@10 extent: 30@30). 82229 Delay testDelayOf: 400 for: 20 rect: (50@10 extent: 30@30)." 82230 82231 | onDelay offDelay | 82232 onDelay := Delay forMilliseconds: 50. 82233 offDelay := Delay forMilliseconds: delay - 50. 82234 Display fillBlack: r. 82235 [1 to: testCount do: [:i | 82236 Display fillWhite: r. 82237 onDelay wait. 82238 Display reverse: r. 82239 offDelay wait]. 82240 ] forkAt: Processor userInterruptPriority. 82241! ! 82242 82243 82244!Delay class methodsFor: 'instance creation' stamp: 'brp 9/25/2003 13:43'! 82245forDuration: aDuration 82246 82247 ^ self forMilliseconds: aDuration asMilliSeconds 82248 ! ! 82249 82250!Delay class methodsFor: 'instance creation' stamp: 'laza 1/30/2005 22:10'! 82251forMilliseconds: aNumber 82252 "Return a new Delay for the given number of milliseconds. Sending 'wait' to this Delay will cause the sender's process to be suspended for approximately that length of time." 82253 82254 ^ self new setDelay: aNumber forSemaphore: Semaphore new 82255! ! 82256 82257!Delay class methodsFor: 'instance creation' stamp: 'laza 1/30/2005 22:11'! 82258forSeconds: aNumber 82259 ^ self forMilliseconds: aNumber * 1000 82260! ! 82261 82262!Delay class methodsFor: 'instance creation' stamp: 'laza 1/6/2008 06:35'! 82263timeoutSemaphore: aSemaphore afterMSecs: anInteger 82264 "Create and schedule a Delay to signal the given semaphore when the given number of milliseconds has elapsed. Return the scheduled Delay. The timeout can be cancelled by sending 'unschedule' to this Delay." 82265 "Details: This mechanism is used to provide a timeout when waiting for an external event, such as arrival of data over a network connection, to signal a semaphore. The timeout ensures that the semaphore will be signalled within a reasonable period of time even if the event fails to occur. Typically, the waiting process cancels the timeout request when awoken, then determines if the awaited event has actually occurred." 82266 82267 ^ (self new setDelay: anInteger forSemaphore: aSemaphore) schedule 82268! ! 82269 82270 82271!Delay class methodsFor: 'primitives' stamp: 'ar 3/2/2009 14:43'! 82272primSignal: aSemaphore atMilliseconds: aSmallInteger 82273 "Signal the semaphore when the millisecond clock reaches the value of the second argument. Fail if the first argument is neither a Semaphore nor nil. Essential. See Object documentation whatIsAPrimitive." 82274 <primitive: 136> 82275 ^self primitiveFailed! ! 82276 82277 82278!Delay class methodsFor: 'snapshotting' stamp: 'ar 3/2/2009 14:44'! 82279restoreResumptionTimes 82280 "Private!! Restore the resumption times of all scheduled Delays after a snapshot or clock roll-over. This method should be called only while the AccessProtect semaphore is held." 82281 82282 | newBaseTime | 82283 newBaseTime := Time millisecondClockValue. 82284 SuspendedDelays do: [:d | d adjustResumptionTimeOldBase: 0 newBase: newBaseTime]. 82285 ActiveDelay == nil ifFalse: [ 82286 ActiveDelay adjustResumptionTimeOldBase: 0 newBase: newBaseTime. 82287 ]. 82288! ! 82289 82290!Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 15:15'! 82291saveResumptionTimes 82292 "Private!! Record the resumption times of all Delays relative to a base time of zero. This is done prior to snapshotting or adjusting the resumption times after a clock roll-over. This method should be called only while the AccessProtect semaphore is held." 82293 82294 | oldBaseTime | 82295 oldBaseTime := Time millisecondClockValue. 82296 ActiveDelay == nil 82297 ifFalse: [ 82298 oldBaseTime < ActiveDelayStartTime 82299 ifTrue: [oldBaseTime := ActiveDelayStartTime]. "clock rolled over" 82300 ActiveDelay adjustResumptionTimeOldBase: oldBaseTime newBase: 0]. 82301 SuspendedDelays do: 82302 [:d | d adjustResumptionTimeOldBase: oldBaseTime newBase: 0]. 82303! ! 82304 82305!Delay class methodsFor: 'snapshotting' stamp: 'ar 9/30/2007 12:46'! 82306shutDown 82307 "Suspend the active delay, if any, before snapshotting. It will be reactived when the snapshot is resumed." 82308 "Details: This prevents a timer interrupt from waking up the active delay in the midst snapshoting, since the active delay will be restarted when resuming the snapshot and we don't want to process the delay twice." 82309 82310 AccessProtect wait. 82311 self primSignal: nil atMilliseconds: 0. 82312 self saveResumptionTimes. 82313 DelaySuspended := true.! ! 82314 82315!Delay class methodsFor: 'snapshotting' stamp: 'ar 3/2/2009 14:44'! 82316startUp 82317 "Restart active delay, if any, when resuming a snapshot." 82318 82319 DelaySuspended ifFalse:[^self error: 'Trying to activate Delay twice']. 82320 DelaySuspended := false. 82321 self restoreResumptionTimes. 82322 AccessProtect signal. 82323! ! 82324 82325 82326!Delay class methodsFor: 'testing' stamp: 'ar 9/6/1999 17:05'! 82327anyActive 82328 "Return true if there is any delay currently active" 82329 ^ActiveDelay notNil! ! 82330 82331!Delay class methodsFor: 'testing'! 82332nextWakeUpTime 82333 ^ AccessProtect 82334 critical: [ActiveDelay isNil 82335 ifTrue: [0] 82336 ifFalse: [ActiveDelay resumptionTime]]! ! 82337 82338 82339!Delay class methodsFor: 'timer process' stamp: 'ar 8/24/2007 12:36'! 82340handleTimerEvent 82341 "Handle a timer event; which can be either: 82342 - a schedule request (ScheduledDelay notNil) 82343 - an unschedule request (FinishedDelay notNil) 82344 - a timer signal (not explicitly specified) 82345 We check for timer expiry every time we get a signal." 82346 | nowTick nextTick | 82347 "Wait until there is work to do." 82348 TimingSemaphore wait. 82349 82350 "Process any schedule requests" 82351 ScheduledDelay ifNotNil:[ 82352 "Schedule the given delay" 82353 self scheduleDelay: ScheduledDelay. 82354 ScheduledDelay := nil. 82355 ]. 82356 82357 "Process any unschedule requests" 82358 FinishedDelay ifNotNil:[ 82359 self unscheduleDelay: FinishedDelay. 82360 FinishedDelay := nil. 82361 ]. 82362 82363 "Check for clock wrap-around." 82364 nowTick := Time millisecondClockValue. 82365 nowTick < ActiveDelayStartTime ifTrue: [ 82366 "clock wrapped" 82367 self saveResumptionTimes. 82368 self restoreResumptionTimes. 82369 ]. 82370 ActiveDelayStartTime := nowTick. 82371 82372 "Signal any expired delays" 82373 [ActiveDelay notNil and:[nowTick >= ActiveDelay resumptionTime]] whileTrue:[ 82374 ActiveDelay signalWaitingProcess. 82375 SuspendedDelays isEmpty 82376 ifTrue: [ActiveDelay := nil] 82377 ifFalse:[ActiveDelay := SuspendedDelays removeFirst]. 82378 ]. 82379 82380 "And signal when the next request is due. We sleep at most 1sec here 82381 as a soft busy-loop so that we don't accidentally miss signals." 82382 nextTick := nowTick + 1000. 82383 ActiveDelay ifNotNil:[nextTick := nextTick min: ActiveDelay resumptionTime]. 82384 nextTick := nextTick min: SmallInteger maxVal. 82385 82386 "Since we have processed all outstanding requests, reset the timing semaphore so 82387 that only new work will wake us up again. Do this RIGHT BEFORE setting the next 82388 wakeup call from the VM because it is only signaled once so we mustn't miss it." 82389 TimingSemaphore initSignals. 82390 Delay primSignal: TimingSemaphore atMilliseconds: nextTick. 82391 82392 "This last test is necessary for the obscure case that the msecs clock rolls over 82393 after nowTick has been computed (unlikely but not impossible). In this case we'd 82394 wait for MillisecondClockMask msecs (roughly six days) or until another delay gets 82395 scheduled (which may not be any time soon). In any case, since handling the 82396 condition is easy, let's just deal with it" 82397 Time millisecondClockValue < nowTick ifTrue:[TimingSemaphore signal]. "retry" 82398! ! 82399 82400!Delay class methodsFor: 'timer process' stamp: 'ar 3/2/2009 14:40'! 82401runTimerEventLoop 82402 "Run the timer event loop." 82403 [RunTimerEventLoop] whileTrue: [self handleTimerEvent]! ! 82404 82405!Delay class methodsFor: 'timer process' stamp: 'ar 7/10/2007 22:32'! 82406scheduleDelay: aDelay 82407 "Private. Schedule this Delay." 82408 aDelay beingWaitedOn: true. 82409 ActiveDelay ifNil:[ 82410 ActiveDelay := aDelay 82411 ] ifNotNil:[ 82412 aDelay resumptionTime < ActiveDelay resumptionTime ifTrue:[ 82413 SuspendedDelays add: ActiveDelay. 82414 ActiveDelay := aDelay. 82415 ] ifFalse: [SuspendedDelays add: aDelay]. 82416 ]. 82417! ! 82418 82419!Delay class methodsFor: 'timer process' stamp: 'ar 3/2/2009 14:40'! 82420startTimerEventLoop 82421 "Start the timer event loop" 82422 "Delay startTimerEventLoop" 82423 self stopTimerEventLoop. 82424 AccessProtect := Semaphore forMutualExclusion. 82425 ActiveDelayStartTime := Time millisecondClockValue. 82426 SuspendedDelays := 82427 Heap withAll: (SuspendedDelays ifNil:[#()]) 82428 sortBlock: [:d1 :d2 | d1 resumptionTime <= d2 resumptionTime]. 82429 TimingSemaphore := Semaphore new. 82430 RunTimerEventLoop := true. 82431 TimerEventLoop := [self runTimerEventLoop] newProcess. 82432 TimerEventLoop priority: Processor timingPriority. 82433 TimerEventLoop resume. 82434 TimingSemaphore signal. "get going" 82435! ! 82436 82437!Delay class methodsFor: 'timer process' stamp: 'ar 7/10/2007 21:26'! 82438stopTimerEventLoop 82439 "Stop the timer event loop" 82440 RunTimerEventLoop := false. 82441 TimingSemaphore signal. 82442 TimerEventLoop := nil.! ! 82443 82444!Delay class methodsFor: 'timer process' stamp: 'ar 8/30/2007 19:59'! 82445unscheduleDelay: aDelay 82446 "Private. Unschedule this Delay." 82447 aDelay beingWaitedOn ifFalse:[^self]. 82448 ActiveDelay == aDelay ifTrue: [ 82449 SuspendedDelays isEmpty ifTrue:[ 82450 ActiveDelay := nil. 82451 ] ifFalse: [ 82452 ActiveDelay := SuspendedDelays removeFirst. 82453 ] 82454 ] ifFalse:[ 82455 SuspendedDelays remove: aDelay ifAbsent: []. 82456 ]. 82457 aDelay beingWaitedOn: false.! ! 82458TestCase subclass: #DelayTest 82459 instanceVariableNames: '' 82460 classVariableNames: '' 82461 poolDictionaries: '' 82462 category: 'KernelTests-Processes'! 82463 82464!DelayTest methodsFor: 'testing' stamp: 'nice 4/19/2009 21:21'! 82465testBounds 82466 "self run: #testBounds" 82467 82468 self should: [Delay forMilliseconds: -1] raise: Error. 82469 self shouldnt: [Delay forMilliseconds: SmallInteger maxVal // 2 + 1] raise: Error. 82470 self shouldnt: [Delay forMilliseconds: SmallInteger maxVal + 1] raise: Error. 82471 self shouldnt: [(Delay forMilliseconds: Float pi) wait] raise: Error. "Wait 3ms" 82472! ! 82473 82474!DelayTest methodsFor: 'testing' stamp: 'laza 1/6/2008 06:46'! 82475testSemaphore 82476 "When we provide our own semaphore for a Delay, it should be used" 82477 "See http://bugs.squeak.org/view.php?id=6834" 82478 82479 "self run: #testSemaphore" 82480 82481 | sem process | 82482 sem := Semaphore new. 82483 [ 82484 process := [Delay timeoutSemaphore: sem afterMSecs: 0. sem wait] newProcess. 82485 process priority: Processor highIOPriority. 82486 process resume. 82487 self assert: process isTerminated. 82488 ] ensure: [sem signal]! ! 82489 82490 82491!DelayTest methodsFor: 'testing-limits' stamp: 'ar 9/21/2009 22:14'! 82492testMultiProcessWaitOnSameDelay 82493 "Ensure that waiting on the same delay from multiple processes raises an error" 82494 | delay p1 p2 wasRun | 82495 delay := Delay forSeconds: 1. 82496 wasRun := false. 82497 p1 := [delay wait] forkAt: Processor activePriority+1. 82498 p2 := [ 82499 self should:[delay wait] raise: Error. 82500 wasRun := true. 82501 ] forkAt: Processor activePriority+1. 82502 p1 terminate. 82503 p2 terminate. 82504 self assert: wasRun. 82505 82506! ! 82507 82508!DelayTest methodsFor: 'testing-limits' stamp: 'ar 9/21/2009 22:12'! 82509testMultiSchedule 82510 "Ensure that scheduling the same delay twice raises an error" 82511 | delay | 82512 delay := Delay forSeconds: 1. 82513 delay schedule. 82514 self should:[delay schedule] raise: Error. 82515! ! 82516Delay subclass: #DelayWaitTimeout 82517 instanceVariableNames: 'process expired' 82518 classVariableNames: '' 82519 poolDictionaries: '' 82520 category: 'Kernel-Processes'! 82521!DelayWaitTimeout commentStamp: '<historical>' prior: 0! 82522DelayWaitTimeout is a special kind of Delay used in waitTimeoutMSecs: to avoid signaling the underlying semaphore when the wait times out.! 82523 82524 82525!DelayWaitTimeout methodsFor: 'signaling' stamp: 'ar 3/24/2009 23:24'! 82526signalWaitingProcess 82527 "Release the given process from the semaphore it is waiting on. 82528 This method relies on running at highest priority so that it cannot be preempted 82529 by the process being released." 82530 beingWaitedOn := false. 82531 "Release the process but only if it is still waiting on its original list" 82532 process suspendingList == delaySemaphore ifTrue:[ 82533 expired := true. 82534 process suspend; resume. 82535 ]. 82536! ! 82537 82538 82539!DelayWaitTimeout methodsFor: 'testing' stamp: 'ar 3/23/2009 16:37'! 82540isExpired 82541 "Did this timeout fire before the associated semaphore was signaled?" 82542 ^expired! ! 82543 82544 82545!DelayWaitTimeout methodsFor: 'waiting' stamp: 'ar 3/27/2009 22:26'! 82546wait 82547 "Wait until either the semaphore is signaled or the delay times out" 82548 [self schedule. 82549 "It is critical that the following has no suspension point so that 82550 the test and the wait primitive are atomic. In addition, if the delay 82551 is no longer being waited on while entering the way we know that it 82552 is expired because the delay has already fired." 82553 beingWaitedOn 82554 ifTrue:[delaySemaphore wait] 82555 ifFalse:[expired := true]] ensure:[self unschedule]. 82556 ^self isExpired 82557! ! 82558 82559 82560!DelayWaitTimeout methodsFor: 'private' stamp: 'ar 3/23/2009 16:38'! 82561setDelay: anInteger forSemaphore: aSemaphore 82562 super setDelay: anInteger forSemaphore: aSemaphore. 82563 process := Processor activeProcess. 82564 expired := false.! ! 82565MessageDialogWindow subclass: #DenyDialogWindow 82566 instanceVariableNames: '' 82567 classVariableNames: '' 82568 poolDictionaries: '' 82569 category: 'Polymorph-Widgets-Windows'! 82570!DenyDialogWindow commentStamp: 'gvc 5/18/2007 13:27' prior: 0! 82571Dialog window displaying a message with a single OK button. Escape/return will close. Icon is a themed lock icon.! 82572 82573 82574!DenyDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 10:27'! 82575icon 82576 "Answer an icon for the receiver." 82577 82578 ^self theme lockIcon! ! 82579 82580"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 82581 82582DenyDialogWindow class 82583 instanceVariableNames: ''! 82584 82585!DenyDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 11:52'! 82586taskbarIcon 82587 "Answer the icon for the receiver in a task bar." 82588 82589 ^self theme smallLockIcon! ! 82590Array weakSubclass: #DependentsArray 82591 instanceVariableNames: '' 82592 classVariableNames: '' 82593 poolDictionaries: '' 82594 category: 'Kernel-Objects'! 82595!DependentsArray commentStamp: '<historical>' prior: 0! 82596An array of (weak) dependents of some object.! 82597 82598 82599!DependentsArray methodsFor: 'copying' stamp: 'bf 7/21/2006 17:04'! 82600copyWith: newElement 82601 "Re-implemented to not copy any niled out dependents." 82602 | copy i | 82603 copy := self class new: self size + 1. 82604 i := 0. 82605 self do: [:item | copy at: (i:=i+1) put: item]. 82606 copy at: (i:=i+1) put: newElement. 82607 ^copy! ! 82608 82609!DependentsArray methodsFor: 'copying' stamp: 'GabrielOmarCotelli 5/25/2009 16:22'! 82610size 82611 82612 "No nil verification required. See do: implementation that only evaluates not nil objects" 82613 ^self inject: 0 into: [:size :anObject | size + 1]! ! 82614 82615 82616!DependentsArray methodsFor: 'enumerating' stamp: 'nk 3/11/2004 09:34'! 82617do: aBlock 82618 "Refer to the comment in Collection|do:." 82619 | dep | 82620 1 to: self basicSize do:[:i| 82621 (dep := self at: i) ifNotNil:[aBlock value: dep]].! ! 82622 82623!DependentsArray methodsFor: 'enumerating' stamp: 'PeterHugossonMiller 9/3/2009 01:12'! 82624select: aBlock 82625 "Refer to the comment in Collection|select:." 82626 | aStream | 82627 aStream := (self species new: self size) writeStream. 82628 self do:[:obj| 82629 (aBlock value: obj) 82630 ifTrue: [aStream nextPut: obj]]. 82631 ^ aStream contents! ! 82632 82633"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 82634 82635DependentsArray class 82636 instanceVariableNames: ''! 82637TestCase subclass: #DependentsArrayTest 82638 instanceVariableNames: '' 82639 classVariableNames: '' 82640 poolDictionaries: '' 82641 category: 'KernelTests-Objects'! 82642 82643!DependentsArrayTest methodsFor: 'test' stamp: 'GabrielOmarCotelli 5/25/2009 16:16'! 82644testSize 82645 82646 self 82647 assert: (DependentsArray with: nil) size = 0; 82648 assert: (DependentsArray with: nil with: 1 with: nil) size = 1; 82649 assert: (DependentsArray with: 1 with: 3) size = 2; 82650 assert: (DependentsArray with: nil with: nil with: nil) size = 0! ! 82651Warning subclass: #Deprecation 82652 instanceVariableNames: 'methodReference explanationString deprecationDate versionString' 82653 classVariableNames: 'Log' 82654 poolDictionaries: '' 82655 category: 'Exceptions-Kernel'! 82656!Deprecation commentStamp: 'dew 5/21/2003 17:46' prior: 0! 82657This Warning is signalled by methods which are deprecated. 82658 82659The use of Object>>#deprecatedExplanation: aString and Object>>#deprecated: aBlock explanation: aString is recommended. 82660 82661Idiom: Imagine I want to deprecate the message #foo. 82662 82663foo 82664 ^ 'foo' 82665 82666I can replace it with: 82667 82668foo 82669 self deprecatedExplanation: 'The method #foo was not good. Use Bar>>newFoo instead.' 82670 ^ 'foo' 82671 82672Or, for certain cases such as when #foo implements a primitive, #foo can be renamed to #fooDeprecated. 82673 82674fooDeprecated 82675 ^ <primitive> 82676 82677foo 82678 ^ self deprecated: [self fooDeprecated] explanation: 'The method #foo was not good. Use Bar>>newFoo instead.' 82679! 82680 82681 82682!Deprecation methodsFor: 'accessing' stamp: 'eem 7/3/2009 19:07'! 82683deprecationDate 82684 "Answer the value of deprecationDate" 82685 82686 ^ deprecationDate! ! 82687 82688!Deprecation methodsFor: 'accessing' stamp: 'eem 7/3/2009 19:07'! 82689explanationString 82690 "Answer the value of explanationString" 82691 82692 ^ explanationString! ! 82693 82694!Deprecation methodsFor: 'accessing' stamp: 'AndrewBlack 8/31/2009 03:15'! 82695messageText 82696 "Return an exception's message text." 82697 82698 ^ 'The method ', methodReference stringVersion, ' has been deprecated. 82699', explanationString! ! 82700 82701!Deprecation methodsFor: 'accessing' stamp: 'eem 7/3/2009 19:07'! 82702methodReference 82703 "Answer the value of methodReference" 82704 82705 ^ methodReference! ! 82706 82707!Deprecation methodsFor: 'accessing' stamp: 'eem 7/3/2009 19:07'! 82708versionString 82709 "Answer the value of versionString" 82710 82711 ^ versionString! ! 82712 82713 82714!Deprecation methodsFor: 'comparing' stamp: 'eem 7/3/2009 19:10'! 82715= anObject 82716 ^self class == anObject class 82717 and: [methodReference = anObject methodReference 82718 and: [methodReference 82719 ifNil: [explanationString = anObject explanationString] 82720 ifNotNil: [true]]]! ! 82721 82722!Deprecation methodsFor: 'comparing' stamp: 'eem 7/3/2009 19:08'! 82723hash 82724 ^(methodReference ifNil: [explanationString]) hash! ! 82725 82726 82727!Deprecation methodsFor: 'handling' stamp: 'AndrewBlack 9/1/2009 07:45'! 82728defaultAction 82729 Log ifNotNil: [:log| log add: self]. 82730 Preferences showDeprecationWarnings ifTrue: 82731 [Transcript nextPutAll: self messageText; cr; flush]. 82732 Preferences raiseDeprecatedWarnings ifTrue: 82733 [super defaultAction]! ! 82734 82735 82736!Deprecation methodsFor: 'initialize-release' stamp: 'eem 7/3/2009 18:57'! 82737method: aCompiledMethod explanation: anExplanationString on: dateString in: aVersionString 82738 methodReference := aCompiledMethod methodReference. 82739 explanationString := anExplanationString. 82740 deprecationDate := dateString. 82741 versionString := aVersionString ! ! 82742 82743"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 82744 82745Deprecation class 82746 instanceVariableNames: ''! 82747 82748!Deprecation class methodsFor: 'class initialization' stamp: 'eem 7/3/2009 19:11'! 82749initialize 82750 "Deprecation initialize" 82751 Preferences 82752 addBooleanPreference: #showDeprecationWarnings 82753 category: #general "programming?" 82754 default: true 82755 balloonHelp: 'If enabled, use of deprecated APIs is reported to the transcript.'. 82756 Preferences 82757 addBooleanPreference: #raiseDeprecatedWarnings 82758 category: #general "programming?" 82759 default: true 82760 balloonHelp: 'If enabled, use of a deprecated API raises a Deprecated warning.'.! ! 82761 82762 82763!Deprecation class methodsFor: 'instance creation' stamp: 'eem 7/3/2009 19:15'! 82764method: aCompiledMethod explanation: anExplanationString on: dateString in: aVersionString 82765 ^self new method: aCompiledMethod explanation: anExplanationString on: dateString in: aVersionString! ! 82766 82767 82768!Deprecation class methodsFor: 'logging' stamp: 'eem 7/3/2009 19:13'! 82769deprecationsWhile: aBlock 82770 | oldLog result | 82771 oldLog := Log. 82772 Log := Set new. 82773 aBlock value. 82774 result := Log. 82775 oldLog ifNotNil: [oldLog addAll: result]. 82776 Log := oldLog. 82777 ^result! ! 82778StandardWindow subclass: #DialogWindow 82779 instanceVariableNames: 'cancelled' 82780 classVariableNames: '' 82781 poolDictionaries: '' 82782 category: 'Polymorph-Widgets-Windows'! 82783!DialogWindow commentStamp: 'gvc 5/18/2007 13:26' prior: 0! 82784Dialog style window with no window controls (expand, collapse etc). Usually opened modally (the morph that is used to modally open determines the modal scope, use of World implies "system modal"). 82785Designed to be subclassed with content. 82786Supports Escape key for cancel and Enter key for default button.! 82787 82788 82789!DialogWindow methodsFor: 'accessing' stamp: 'gvc 8/14/2006 14:12'! 82790cancelled 82791 "Answer the value of cancelled" 82792 82793 ^ cancelled! ! 82794 82795!DialogWindow methodsFor: 'accessing' stamp: 'gvc 8/14/2006 14:12'! 82796cancelled: anObject 82797 "Set the value of cancelled" 82798 82799 cancelled := anObject! ! 82800 82801 82802!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/27/2006 11:15'! 82803acceptTextMorphs 82804 "Accept any text morphs except for those that have no edits." 82805 82806 self allMorphs do: [:p | 82807 ((p respondsTo: #accept) and: [ 82808 (p respondsTo: #hasUnacceptedEdits) and: [ 82809 p hasUnacceptedEdits]]) ifTrue: [p accept]]! ! 82810 82811!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/25/2006 10:25'! 82812addInitialPanel 82813 "Add the panel." 82814 82815 self addMainPanel! ! 82816 82817!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 16:52'! 82818addMainPanel 82819 "Add the main panel." 82820 82821 self addMorph: self newMainPanel frame: (0@0 corner: 1@1)! ! 82822 82823!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/27/2006 11:11'! 82824applyChanges 82825 "Apply the changes." 82826 82827 self acceptTextMorphs! ! 82828 82829!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/12/2009 18:14'! 82830buttons 82831 "Answer the buttons in the button row" 82832 82833 ^self paneMorphs last lastSubmorph submorphs! ! 82834 82835!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2009 11:16'! 82836canBeMaximized 82837 "Answer whether we are not we can be maximised." 82838 82839 ^self isResizeable 82840 ifTrue: [super canBeMaximized] 82841 ifFalse: [false]! ! 82842 82843!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/25/2006 10:10'! 82844cancel 82845 "Cancel and close." 82846 82847 self close! ! 82848 82849!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/25/2006 10:10'! 82850close 82851 "Close the window." 82852 82853 self delete! ! 82854 82855!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 13:23'! 82856defaultButton 82857 "Answer the default button." 82858 82859 ^self 82860 findDeepSubmorphThat: [:m | 82861 (m isKindOf: PluggableButtonMorph) and: [m isDefault]] 82862 ifAbsent: [] ! ! 82863 82864!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/14/2006 12:40'! 82865defaultLabel 82866 "Answer the default label for the receiver." 82867 82868 ^'Dialog' translated! ! 82869 82870!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 13:42'! 82871escapePressed 82872 "Default is to cancel." 82873 82874 self cancel! ! 82875 82876!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2009 11:14'! 82877isResizeable 82878 "Answer whether we are not we can be resized." 82879 82880 ^false! ! 82881 82882!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 2/2/2009 13:15'! 82883mainPanel 82884 "Anwer the main panel morph or nil if not yet present." 82885 82886 ^self paneMorphs isEmpty 82887 ifFalse: [self paneMorphs first]! ! 82888 82889!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 12/3/2008 17:35'! 82890newButtonRow 82891 "Answer a new ok/cancel button row." 82892 82893 |answer buttons e| 82894 buttons := self newButtons. 82895 e := 0@0. 82896 buttons do: [:b | e := e max: b minExtent]. 82897 buttons do: [:b | b extent: e]. 82898 answer := Morph new 82899 color: Color transparent; 82900 changeTableLayout; 82901 cellInset: 8; 82902 listDirection: #leftToRight; 82903 listCentering: #bottomRight; 82904 hResizing: #spaceFill; 82905 vResizing: #shrinkWrap. 82906 buttons do: [:b | answer addMorphBack: b]. 82907 ^answer! ! 82908 82909!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 13:50'! 82910newButtons 82911 "Answer new buttons as appropriate." 82912 82913 ^{self newOKButton isDefault: true. self newCancelButton}! ! 82914 82915!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/14/2006 11:58'! 82916newContentMorph 82917 "Answer a new content morph." 82918 82919 ^Morph new 82920 color: Color transparent; 82921 hResizing: #spaceFill; 82922 vResizing: #spaceFill! ! 82923 82924!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/15/2007 17:40'! 82925newMainPanel 82926 "Answer a new main panel." 82927 82928 ^self newDialogPanel 82929 addMorphBack: self newContentMorph; 82930 addMorphBack: self newButtonRow; 82931 yourself! ! 82932 82933!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/14/2006 14:12'! 82934ok 82935 "Apply the changes and close." 82936 82937 self 82938 cancelled: false; 82939 applyChanges; 82940 delete! ! 82941 82942!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 13:48'! 82943returnPressed 82944 "Default is to do the default button." 82945 82946 (self defaultButton ifNil: [^self]) performAction! ! 82947 82948!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/12/2009 18:13'! 82949setButtonFont: aFont 82950 "Set the font for the buttons." 82951 82952 |buttons e hRes vRes| 82953 buttons := self buttons. 82954 e := 0@0. 82955 buttons do: [:b | 82956 hRes := b hResizing. 82957 vRes := b vResizing. 82958 b 82959 hResizing: #shrinkWrap; 82960 vResizing: #shrinkWrap. 82961 b label: b label font: aFont. 82962 e := e max: b minExtent. 82963 b 82964 hResizing: hRes; 82965 vResizing: vRes]. 82966 buttons do: [:b | b extent: e]! ! 82967 82968!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2007 21:31'! 82969setLabelWidgetAllowance 82970 "Set the extra space required, in general, apart from the label. 82971 No extra needed for dialogs." 82972 82973 ^labelWidgetAllowance := 0! ! 82974 82975!DialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2009 11:16'! 82976wantsGrips 82977 "Answer whether the window wants edge and corner grips." 82978 82979 ^self isResizeable! ! 82980 82981 82982!DialogWindow methodsFor: 'controls' stamp: 'gvc 1/15/2007 17:14'! 82983title: aString 82984 "Set the window title." 82985 82986 super title: aString. 82987 label fitContents. 82988 self minimumExtent: ((label width + 20 min: (Display width // 2))@ self minimumExtent y)! ! 82989 82990 82991!DialogWindow methodsFor: 'event handling' stamp: 'gvc 9/22/2009 11:17'! 82992doubleClick: event 82993 "Handle a double click. Maximize/restore the window. 82994 Not for dialogs if not resizeable..." 82995 82996 self isResizeable ifTrue: [super doubleClick: event]! ! 82997 82998!DialogWindow methodsFor: 'event handling' stamp: 'gvc 7/30/2009 12:21'! 82999handlesKeyboard: evt 83000 "Return true if the receiver wishes to handle the given keyboard event" 83001 83002 (super handlesKeyboard: evt) ifTrue: [^true]. 83003 ^evt keyCharacter = Character escape or: [ 83004 (self defaultButton notNil and: [ 83005 evt keyCharacter = Character cr])] 83006 ! ! 83007 83008!DialogWindow methodsFor: 'event handling' stamp: 'gvc 7/30/2009 12:32'! 83009keyStroke: evt 83010 "Check for return and escape keys." 83011 83012 super keyStroke: evt. 83013 (self defaultButton notNil and: [evt keyCharacter = Character cr]) ifTrue: [self returnPressed. ^true]. 83014 evt keyCharacter = Character escape ifTrue: [self escapePressed. ^true]. 83015 ^false! ! 83016 83017!DialogWindow methodsFor: 'event handling' stamp: 'gvc 9/21/2007 14:36'! 83018keyboardFocusChange: aBoolean 83019 "Set the focus to the default button." 83020 83021 aBoolean ifTrue: [ 83022 self defaultFocusMorph ifNotNilDo: [:b | 83023 b takeKeyboardFocus]]! ! 83024 83025 83026!DialogWindow methodsFor: 'focus handling' stamp: 'gvc 4/25/2007 16:03'! 83027defaultFocusMorph 83028 "Answer the morph that should have the keyboard 83029 focus by default when the dialog is opened." 83030 83031 ^self defaultButton 83032 ifNil: [(self respondsTo: #nextMorphWantingFocus) 83033 ifTrue: [ self nextMorphWantingFocus]] 83034 ifNotNilDo: [:b | b enabled ifTrue: [b]]! ! 83035 83036 83037!DialogWindow methodsFor: 'initialization' stamp: 'gvc 4/3/2008 11:52'! 83038initialize 83039 "Initialize the receiver." 83040 83041 super initialize. 83042 self 83043 cancelled: true; 83044 addInitialPanel! ! 83045 83046!DialogWindow methodsFor: 'initialization' stamp: 'gvc 10/25/2007 16:45'! 83047initializeLabelArea 83048 "Initialize the label area (titlebar) for the window." 83049 83050 super initializeLabelArea. 83051 self removeBoxes. 83052 self replaceBoxes! ! 83053 83054!DialogWindow methodsFor: 'initialization' stamp: 'gvc 6/1/2009 12:21'! 83055setFramesForLabelArea 83056 "Delegate to theme." 83057 83058 self theme configureDialogWindowLabelAreaFrameFor: self! ! 83059 83060 83061!DialogWindow methodsFor: 'open/close' stamp: 'gvc 9/22/2009 11:15'! 83062initialExtent 83063 "Answer the default extent for the receiver." 83064 83065 |rl paneExt ext| 83066 rl := self getRawLabel. 83067 paneExt := self mainPanel 83068 ifNil: [0@0] 83069 ifNotNilDo: [:pane | pane minExtent]. 83070 ext := paneExt + (2@ self labelHeight) + (2 * self class borderWidth) 83071 max: rl extent + 20. 83072 self isResizeable ifTrue: [ 83073 self title: self title "adjust minimumExtent". 83074 self minimumExtent: (ext x max: self minimumExtent x)@(ext y max: self minimumExtent y)]. 83075 ^ext! ! 83076 83077 83078!DialogWindow methodsFor: 'theme' stamp: 'gvc 5/24/2007 11:35'! 83079activeFillStyle 83080 "Return the active fillStyle for the receiver." 83081 83082 ^self theme dialogWindowActiveFillStyleFor: self! ! 83083 83084!DialogWindow methodsFor: 'theme' stamp: 'gvc 4/24/2007 16:19'! 83085animateClose 83086 "Animate closing."! ! 83087 83088!DialogWindow methodsFor: 'theme' stamp: 'gvc 5/24/2007 11:36'! 83089inactiveFillStyle 83090 "Return the active fillStyle for the receiver." 83091 83092 ^self theme dialogWindowInactiveFillStyleFor: self! ! 83093 83094!DialogWindow methodsFor: 'theme' stamp: 'gvc 6/2/2009 10:26'! 83095preferredCornerStyle 83096 "Answer the preferred corner style." 83097 83098 ^self theme dialogWindowPreferredCornerStyleFor: self! ! 83099 83100!DialogWindow methodsFor: 'theme' stamp: 'gvc 6/2/2009 10:36'! 83101wantsRoundedCorners 83102 "Answer whether rounded corners are wanted." 83103 83104 ^(self theme dialogWindowPreferredCornerStyleFor: self) == #rounded! ! 83105 83106 83107!DialogWindow methodsFor: 'top window' stamp: 'gvc 12/4/2007 16:32'! 83108activate 83109 "Set the default focus for now, will want to 83110 remember it at some point." 83111 83112 super activate. 83113 self world ifNil: [^self]. 83114 self rememberedKeyboardFocus 83115 ifNil: [self defaultFocusMorph ifNotNilDo: [:m | 83116 m takeKeyboardFocus]]! ! 83117Set subclass: #Dictionary 83118 instanceVariableNames: '' 83119 classVariableNames: '' 83120 poolDictionaries: '' 83121 category: 'Collections-Unordered'! 83122!Dictionary commentStamp: '<historical>' prior: 0! 83123I represent a set of elements that can be viewed from one of two perspectives: a set of associations, or a container of values that are externally named where the name can be any object that responds to =. The external name is referred to as the key. I inherit many operations from Set.! 83124 83125 83126!Dictionary methodsFor: '*compiler' stamp: 'ar 5/17/2003 14:07'! 83127bindingOf: varName 83128 ^self associationAt: varName ifAbsent:[nil]! ! 83129 83130!Dictionary methodsFor: '*compiler' stamp: 'ar 5/18/2003 20:33'! 83131bindingsDo: aBlock 83132 ^self associationsDo: aBlock! ! 83133 83134 83135!Dictionary methodsFor: '*tools-inspector' stamp: 'ar 9/27/2005 18:32'! 83136inspectorClass 83137 "Answer the class of the inspector to be used on the receiver. Called by inspect; 83138 use basicInspect to get a normal (less useful) type of inspector." 83139 83140 ^ DictionaryInspector! ! 83141 83142 83143!Dictionary methodsFor: 'accessing'! 83144associationAt: key 83145 ^ self associationAt: key ifAbsent: [self errorKeyNotFound]! ! 83146 83147!Dictionary methodsFor: 'accessing'! 83148associationAt: key ifAbsent: aBlock 83149 "Answer the association with the given key. 83150 If key is not found, return the result of evaluating aBlock." 83151 83152 | index assoc | 83153 index := self findElementOrNil: key. 83154 assoc := array at: index. 83155 nil == assoc ifTrue: [ ^ aBlock value ]. 83156 ^ assoc! ! 83157 83158!Dictionary methodsFor: 'accessing' stamp: 'eem 6/11/2008 17:25'! 83159associationDeclareAt: aKey 83160 "Return an existing association, or create and return a new one. Needed as a single message by ImageSegment.prepareToBeSaved." 83161 83162 ^ self associationAt: aKey ifAbsent: [| existing | 83163 (Undeclared includesKey: aKey) 83164 ifTrue: 83165 [existing := Undeclared associationAt: aKey. 83166 Undeclared removeKey: aKey. 83167 self add: existing] 83168 ifFalse: 83169 [self add: aKey -> false]]! ! 83170 83171!Dictionary methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 01:12'! 83172associations 83173 "Answer a Collection containing the receiver's associations." 83174 | out | 83175 out := (Array new: self size) writeStream. 83176 self associationsDo: [:value | out nextPut: value]. 83177 ^ out contents! ! 83178 83179!Dictionary methodsFor: 'accessing'! 83180at: key 83181 "Answer the value associated with the key." 83182 83183 ^ self at: key ifAbsent: [self errorKeyNotFound]! ! 83184 83185!Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 15:01'! 83186at: key ifAbsentPut: aBlock 83187 "Return the value at the given key. 83188 If key is not included in the receiver store the result 83189 of evaluating aBlock as new value." 83190 83191 ^ self at: key ifAbsent: [self at: key put: aBlock value]! ! 83192 83193!Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 14:59'! 83194at: key ifAbsent: aBlock 83195 "Answer the value associated with the key or, if key isn't found, 83196 answer the result of evaluating aBlock." 83197 83198 | assoc | 83199 assoc := array at: (self findElementOrNil: key). 83200 assoc ifNil: [^ aBlock value]. 83201 ^ assoc value! ! 83202 83203!Dictionary methodsFor: 'accessing' stamp: 'di 3/7/2001 15:29'! 83204at: key ifPresentAndInMemory: aBlock 83205 "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil." 83206 83207 | v | 83208 v := self at: key ifAbsent: [^ nil]. 83209 v isInMemory ifFalse: [^ nil]. 83210 ^ aBlock value: v 83211! ! 83212 83213!Dictionary methodsFor: 'accessing' stamp: 'jm 5/15/1998 07:20'! 83214at: key ifPresent: aBlock 83215 "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil." 83216 83217 | v | 83218 v := self at: key ifAbsent: [^ nil]. 83219 ^ aBlock value: v 83220! ! 83221 83222!Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 15:00'! 83223at: key put: anObject 83224 "Set the value at key to be anObject. If key is not found, create a 83225 new entry for key and set is value to anObject. Answer anObject." 83226 83227 | index assoc | 83228 index := self findElementOrNil: key. 83229 assoc := array at: index. 83230 assoc 83231 ifNil: [self atNewIndex: index put: (Association key: key value: anObject)] 83232 ifNotNil: [assoc value: anObject]. 83233 ^ anObject! ! 83234 83235!Dictionary methodsFor: 'accessing' stamp: 'yo 8/27/2008 23:16'! 83236customizeExplorerContents 83237 83238 ^ true. 83239! ! 83240 83241!Dictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:16'! 83242keyAtIdentityValue: value 83243 "Answer the key that is the external name for the argument, value. If 83244 there is none, answer nil. 83245 Note: There can be multiple keys with the same value. Only one is returned." 83246 83247 ^self keyAtIdentityValue: value ifAbsent: [self errorValueNotFound]! ! 83248 83249!Dictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:16'! 83250keyAtIdentityValue: value ifAbsent: exceptionBlock 83251 "Answer the key that is the external name for the argument, value. If 83252 there is none, answer the result of evaluating exceptionBlock. 83253 Note: There can be multiple keys with the same value. Only one is returned." 83254 83255 self associationsDo: 83256 [:association | value == association value ifTrue: [^association key]]. 83257 ^exceptionBlock value! ! 83258 83259!Dictionary methodsFor: 'accessing' stamp: 'pmm 7/4/2009 18:01'! 83260keyAtValue: value 83261 "Answer the key that is the external name for the argument, value. If 83262 there is none, signal an error." 83263 83264 ^self keyAtValue: value ifAbsent: [self errorValueNotFound]! ! 83265 83266!Dictionary methodsFor: 'accessing' stamp: 'tk 2/18/97'! 83267keyAtValue: value ifAbsent: exceptionBlock 83268 "Answer the key that is the external name for the argument, value. If 83269 there is none, answer the result of evaluating exceptionBlock. 83270 : Use =, not ==, so stings like 'this' can be found. Note that MethodDictionary continues to use == so it will be fast." 83271 83272 self associationsDo: 83273 [:association | value = association value ifTrue: [^association key]]. 83274 ^exceptionBlock value! ! 83275 83276!Dictionary methodsFor: 'accessing'! 83277keys 83278 "Answer a Set containing the receiver's keys." 83279 | aSet | 83280 aSet := Set new: self size. 83281 self keysDo: [:key | aSet add: key]. 83282 ^ aSet! ! 83283 83284!Dictionary methodsFor: 'accessing' stamp: 'sma 6/18/2000 12:56'! 83285keysSortedSafely 83286 "Answer a SortedCollection containing the receiver's keys." 83287 | sortedKeys | 83288 sortedKeys := SortedCollection new: self size. 83289 sortedKeys sortBlock: 83290 [:x :y | "Should really be use <obj, string, num> compareSafely..." 83291 ((x isString and: [y isString]) 83292 or: [x isNumber and: [y isNumber]]) 83293 ifTrue: [x < y] 83294 ifFalse: [x class == y class 83295 ifTrue: [x printString < y printString] 83296 ifFalse: [x class name < y class name]]]. 83297 self keysDo: [:each | sortedKeys addLast: each]. 83298 ^ sortedKeys reSort! ! 83299 83300!Dictionary methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 01:13'! 83301values 83302 "Answer a Collection containing the receiver's values." 83303 | out | 83304 out := (Array new: self size) writeStream. 83305 self valuesDo: [:value | out nextPut: value]. 83306 ^ out contents! ! 83307 83308 83309!Dictionary methodsFor: 'adding' stamp: 'raok 12/17/2003 16:01'! 83310addAll: aKeyedCollection 83311 aKeyedCollection == self ifFalse: [ 83312 aKeyedCollection keysAndValuesDo: [:key :value | 83313 self at: key put: value]]. 83314 ^aKeyedCollection! ! 83315 83316!Dictionary methodsFor: 'adding'! 83317add: anAssociation 83318 | index element | 83319 index := self findElementOrNil: anAssociation key. 83320 element := array at: index. 83321 element == nil 83322 ifTrue: [self atNewIndex: index put: anAssociation] 83323 ifFalse: [element value: anAssociation value]. 83324 ^ anAssociation! ! 83325 83326!Dictionary methodsFor: 'adding'! 83327declare: key from: aDictionary 83328 "Add key to the receiver. If key already exists, do nothing. If aDictionary 83329 includes key, then remove it from aDictionary and use its association as 83330 the element of the receiver." 83331 83332 (self includesKey: key) ifTrue: [^ self]. 83333 (aDictionary includesKey: key) 83334 ifTrue: 83335 [self add: (aDictionary associationAt: key). 83336 aDictionary removeKey: key] 83337 ifFalse: 83338 [self add: key -> nil]! ! 83339 83340 83341!Dictionary methodsFor: 'comparing' stamp: 'cyrille.delaunay 7/17/2009 15:45'! 83342= aDictionary 83343 "Two dictionaries are equal if 83344 (a) they are the same 'kind' of thing. 83345 (b) they have the same set of keys. 83346 (c) for each (common) key, they have the same value" 83347 83348 self == aDictionary ifTrue: [ ^ true ]. 83349 (aDictionary isDictionary) ifFalse: [^false]. 83350 self size = aDictionary size ifFalse: [^false]. 83351 self associationsDo: [:assoc| 83352 (aDictionary at: assoc key ifAbsent: [^false]) = assoc value 83353 ifFalse: [^false]]. 83354 ^true 83355 83356! ! 83357 83358 83359!Dictionary methodsFor: 'enumerating'! 83360associationsDo: aBlock 83361 "Evaluate aBlock for each of the receiver's elements (key/value 83362 associations)." 83363 83364 super do: aBlock! ! 83365 83366!Dictionary methodsFor: 'enumerating' stamp: 'dtl 2/17/2003 09:40'! 83367associationsSelect: aBlock 83368 "Evaluate aBlock with each of my associations as the argument. Collect 83369 into a new dictionary, only those associations for which aBlock evaluates 83370 to true." 83371 83372 | newCollection | 83373 newCollection := self species new. 83374 self associationsDo: 83375 [:each | 83376 (aBlock value: each) ifTrue: [newCollection add: each]]. 83377 ^newCollection! ! 83378 83379!Dictionary methodsFor: 'enumerating' stamp: 'ar 6/13/2008 00:16'! 83380collect: aBlock 83381 "Evaluate aBlock with each of my values as the argument. Collect the 83382 resulting values into a collection that is like me. Answer with the new 83383 collection." 83384 | newCollection | 83385 newCollection := self species new. 83386 self associationsDo:[:each | 83387 newCollection at: each key put: (aBlock value: each value). 83388 ]. 83389 ^newCollection! ! 83390 83391!Dictionary methodsFor: 'enumerating'! 83392do: aBlock 83393 83394 super do: [:assoc | aBlock value: assoc value]! ! 83395 83396!Dictionary methodsFor: 'enumerating' stamp: 'ar 7/11/1999 08:04'! 83397keysAndValuesDo: aBlock 83398 ^self associationsDo:[:assoc| 83399 aBlock value: assoc key value: assoc value].! ! 83400 83401!Dictionary methodsFor: 'enumerating'! 83402keysDo: aBlock 83403 "Evaluate aBlock for each of the receiver's keys." 83404 83405 self associationsDo: [:association | aBlock value: association key]! ! 83406 83407!Dictionary methodsFor: 'enumerating' stamp: 'nice 5/22/2008 14:30'! 83408select: aBlock 83409 "Evaluate aBlock with each of my values as the argument. Collect into a 83410 new dictionary, only those associations for which aBlock evaluates to 83411 true." 83412 83413 | newCollection | 83414 newCollection := self copyEmpty. 83415 self associationsDo: 83416 [:each | 83417 (aBlock value: each value) ifTrue: [newCollection add: each]]. 83418 ^newCollection! ! 83419 83420!Dictionary methodsFor: 'enumerating' stamp: 'dtl 2/17/2003 09:48'! 83421valuesDo: aBlock 83422 "Evaluate aBlock for each of the receiver's values." 83423 83424 self associationsDo: [:association | aBlock value: association value]! ! 83425 83426 83427!Dictionary methodsFor: 'printing' stamp: 'MPW 1/4/1901 08:33'! 83428flattenOnStream:aStream 83429 ^aStream writeDictionary:self. 83430! ! 83431 83432!Dictionary methodsFor: 'printing' stamp: 'apb 7/14/2004 12:48'! 83433printElementsOn: aStream 83434 aStream nextPut: $(. 83435 self size > 100 83436 ifTrue: [aStream nextPutAll: 'size '. 83437 self size printOn: aStream] 83438 ifFalse: [self keysSortedSafely 83439 do: [:key | aStream print: key; 83440 nextPutAll: '->'; 83441 print: (self at: key); 83442 space]]. 83443 aStream nextPut: $)! ! 83444 83445!Dictionary methodsFor: 'printing'! 83446storeOn: aStream 83447 | noneYet | 83448 aStream nextPutAll: '(('. 83449 aStream nextPutAll: self class name. 83450 aStream nextPutAll: ' new)'. 83451 noneYet := true. 83452 self associationsDo: 83453 [:each | 83454 noneYet 83455 ifTrue: [noneYet := false] 83456 ifFalse: [aStream nextPut: $;]. 83457 aStream nextPutAll: ' add: '. 83458 aStream store: each]. 83459 noneYet ifFalse: [aStream nextPutAll: '; yourself']. 83460 aStream nextPut: $)! ! 83461 83462 83463!Dictionary methodsFor: 'removing' stamp: 'di 4/4/2000 11:47'! 83464keysAndValuesRemove: keyValueBlock 83465 "Removes all entries for which keyValueBlock returns true." 83466 "When removing many items, you must not do it while iterating over the dictionary, since it may be changing. This method takes care of tallying the removals in a first pass, and then performing all the deletions afterward. Many places in the sytem could be simplified by using this method." 83467 83468 | removals | 83469 removals := OrderedCollection new. 83470 self associationsDo: 83471 [:assoc | (keyValueBlock value: assoc key value: assoc value) 83472 ifTrue: [removals add: assoc key]]. 83473 removals do: 83474 [:aKey | self removeKey: aKey]! ! 83475 83476!Dictionary methodsFor: 'removing'! 83477removeKey: key 83478 "Remove key from the receiver. 83479 If key is not in the receiver, notify an error." 83480 83481 ^ self removeKey: key ifAbsent: [self errorKeyNotFound]! ! 83482 83483!Dictionary methodsFor: 'removing'! 83484removeKey: key ifAbsent: aBlock 83485 "Remove key (and its associated value) from the receiver. If key is not in 83486 the receiver, answer the result of evaluating aBlock. Otherwise, answer 83487 the value externally named by key." 83488 83489 | index assoc | 83490 index := self findElementOrNil: key. 83491 assoc := array at: index. 83492 assoc == nil ifTrue: [ ^ aBlock value ]. 83493 array at: index put: nil. 83494 tally := tally - 1. 83495 self fixCollisionsFrom: index. 83496 ^ assoc value! ! 83497 83498!Dictionary methodsFor: 'removing'! 83499removeUnreferencedKeys "Undeclared removeUnreferencedKeys" 83500 83501 ^ self unreferencedKeys do: [:key | self removeKey: key].! ! 83502 83503!Dictionary methodsFor: 'removing'! 83504remove: anObject 83505 83506 self shouldNotImplement! ! 83507 83508!Dictionary methodsFor: 'removing'! 83509remove: anObject ifAbsent: exceptionBlock 83510 83511 self shouldNotImplement! ! 83512 83513!Dictionary methodsFor: 'removing' stamp: 'dvf 8/23/2003 11:51'! 83514unreferencedKeys 83515 "TextConstants unreferencedKeys" 83516 83517 | n | 83518 ^'Scanning for references . . .' 83519 displayProgressAt: Sensor cursorPoint 83520 from: 0 83521 to: self size 83522 during: 83523 [:bar | 83524 n := 0. 83525 self keys select: 83526 [:key | 83527 bar value: (n := n + 1). 83528 (self systemNavigation allCallsOn: (self associationAt: key)) isEmpty]]! ! 83529 83530 83531!Dictionary methodsFor: 'testing' stamp: 'tween 9/13/2004 10:11'! 83532hasBindingThatBeginsWith: aString 83533 "Answer true if the receiver has a key that begins with aString, false otherwise" 83534 83535 self keysDo:[:each | 83536 (each beginsWith: aString) 83537 ifTrue:[^true]]. 83538 ^false! ! 83539 83540!Dictionary methodsFor: 'testing' stamp: 'ab 9/17/2004 00:39'! 83541includesAssociation: anAssociation 83542 ^ (self 83543 associationAt: anAssociation key 83544 ifAbsent: [ ^ false ]) value = anAssociation value 83545! ! 83546 83547!Dictionary methodsFor: 'testing' stamp: 'sw 2/14/2000 14:34'! 83548includesIdentity: anObject 83549 "Answer whether anObject is one of the values of the receiver. Contrast #includes: in which there is only an equality check, here there is an identity check" 83550 83551 self do: [:each | anObject == each ifTrue: [^ true]]. 83552 ^ false! ! 83553 83554!Dictionary methodsFor: 'testing' stamp: 'RAA 8/23/2001 12:56'! 83555includesKey: key 83556 "Answer whether the receiver has a key equal to the argument, key." 83557 83558 self at: key ifAbsent: [^false]. 83559 ^true! ! 83560 83561!Dictionary methodsFor: 'testing'! 83562includes: anObject 83563 83564 self do: [:each | anObject = each ifTrue: [^true]]. 83565 ^false! ! 83566 83567!Dictionary methodsFor: 'testing' stamp: 'md 8/11/2005 16:49'! 83568isDictionary 83569 ^true! ! 83570 83571!Dictionary methodsFor: 'testing' stamp: 'sw 3/23/2000 01:12'! 83572keyForIdentity: anObject 83573 "If anObject is one of the values of the receive, return its key, else return nil. Contrast #keyAtValue: in which there is only an equality check, here there is an identity check" 83574 83575 self associationsDo: [:assoc | assoc value == anObject ifTrue: [^ assoc key]]. 83576 ^ nil! ! 83577 83578!Dictionary methodsFor: 'testing'! 83579occurrencesOf: anObject 83580 "Answer how many of the receiver's elements are equal to anObject." 83581 83582 | count | 83583 count := 0. 83584 self do: [:each | anObject = each ifTrue: [count := count + 1]]. 83585 ^count! ! 83586 83587 83588!Dictionary methodsFor: 'user interface' stamp: 'yo 8/27/2008 23:44'! 83589explorerContentsWithIndexCollect: twoArgBlock 83590 83591 | sortedKeys | 83592 sortedKeys := self keys asSortedCollection: [:x :y | 83593 ((x isString and: [y isString]) 83594 or: [x isNumber and: [y isNumber]]) 83595 ifTrue: [x < y] 83596 ifFalse: [x class == y class 83597 ifTrue: [x printString < y printString] 83598 ifFalse: [x class name < y class name]]]. 83599 ^ sortedKeys collect: [:k | twoArgBlock value: (self at: k) value: k]. 83600! ! 83601 83602 83603!Dictionary methodsFor: 'private' stamp: 'raok 4/22/2002 12:09'! 83604copy 83605 "Must copy the associations, or later store will affect both the 83606original and the copy" 83607 83608 ^ self shallowCopy withArray: 83609 (array collect: [:assoc | 83610 assoc ifNil: [nil] 83611 ifNotNil: [Association key: assoc key 83612value: assoc value]])! ! 83613 83614!Dictionary methodsFor: 'private'! 83615errorKeyNotFound 83616 83617 self error: 'key not found'! ! 83618 83619!Dictionary methodsFor: 'private'! 83620errorValueNotFound 83621 83622 self error: 'value not found'! ! 83623 83624!Dictionary methodsFor: 'private'! 83625keyAt: index 83626 "May be overridden by subclasses so that fixCollisions will work" 83627 | assn | 83628 assn := array at: index. 83629 assn == nil ifTrue: [^ nil] 83630 ifFalse: [^ assn key]! ! 83631 83632!Dictionary methodsFor: 'private'! 83633noCheckAdd: anObject 83634 "Must be defined separately for Dictionary because (self findElementOrNil:) expects a key, not an association. 9/7/96 tk" 83635 83636 array at: (self findElementOrNil: anObject key) put: anObject. 83637 tally := tally + 1! ! 83638 83639!Dictionary methodsFor: 'private'! 83640rehash 83641 "Smalltalk rehash." 83642 | newSelf | 83643 newSelf := self species new: self size. 83644 self associationsDo: [:each | newSelf noCheckAdd: each]. 83645 array := newSelf array! ! 83646 83647!Dictionary methodsFor: 'private' stamp: 'md 10/5/2005 15:42'! 83648scanFor: anObject 83649 "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 83650 | element start finish | 83651 finish := array size. 83652 start := (anObject hash \\ finish) + 1. 83653 83654 "Search from (hash mod size) to the end." 83655 start to: finish do: 83656 [:index | ((element := array at: index) == nil or: [element key = anObject]) 83657 ifTrue: [^ index ]]. 83658 83659 "Search from 1 to where we started." 83660 1 to: start-1 do: 83661 [:index | ((element := array at: index) == nil or: [element key = anObject]) 83662 ifTrue: [^ index ]]. 83663 83664 ^ 0 "No match AND no empty slot"! ! 83665 83666!Dictionary methodsFor: 'private'! 83667valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary 83668 "Support for coordinating class variable and global declarations 83669 with variables that have been put in Undeclared so as to 83670 redirect all references to the undeclared variable." 83671 83672 (aDictionary includesKey: aKey) 83673 ifTrue: 83674 [self atNewIndex: index 83675 put: ((aDictionary associationAt: aKey) value: anObject). 83676 aDictionary removeKey: aKey] 83677 ifFalse: 83678 [self atNewIndex: index put: (Association key: aKey value: anObject)]! ! 83679 83680"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 83681 83682Dictionary class 83683 instanceVariableNames: ''! 83684 83685!Dictionary class methodsFor: 'instance creation'! 83686newFrom: aDict 83687 "Answer an instance of me containing the same associations as aDict. 83688 Error if any key appears twice." 83689 | newDictionary | 83690 newDictionary := self new: aDict size. 83691 aDict associationsDo: 83692 [:x | 83693 (newDictionary includesKey: x key) 83694 ifTrue: [self error: 'Duplicate key: ', x key printString] 83695 ifFalse: [newDictionary add: x]]. 83696 ^ newDictionary 83697 83698" NewDictionary newFrom: {1->#a. 2->#b. 3->#c} 83699 {1->#a. 2->#b. 3->#c} as: NewDictionary 83700 NewDictionary newFrom: {1->#a. 2->#b. 1->#c} 83701 {1->#a. 2->#b. 1->#c} as: NewDictionary 83702"! ! 83703 83704!Dictionary class methodsFor: 'instance creation' stamp: 'bgf 10/25/2006 17:08'! 83705newFromPairs: anArray 83706 83707 "Answer an instance of me associating (anArray at:i) to (anArray at: i+i) 83708 for each odd i. anArray must have an even number of entries." 83709 83710 | newDictionary | 83711 83712 newDictionary := self new: (anArray size/2). 83713 1 to: (anArray size-1) by: 2 do: [ :i| 83714 newDictionary at: (anArray at: i) put: (anArray at: i+1). 83715 ]. 83716 ^ newDictionary 83717 83718 " Dictionary newFromPairs: {'Red' . Color red . 'Blue' . Color blue . 'Green' . Color green}. "! ! 83719Inspector subclass: #DictionaryInspector 83720 instanceVariableNames: 'keyArray' 83721 classVariableNames: '' 83722 poolDictionaries: '' 83723 category: 'Tools-Inspector'! 83724 83725!DictionaryInspector methodsFor: 'accessing' stamp: 'apb 8/20/2004 23:06'! 83726fieldList 83727 ^ self baseFieldList 83728 , (keyArray collect: [:key | key printString])! ! 83729 83730 83731!DictionaryInspector methodsFor: 'initialization' stamp: 'PHK 7/21/2004 18:00'! 83732initialize 83733 super initialize. 83734 self calculateKeyArray! ! 83735 83736 83737!DictionaryInspector methodsFor: 'menu' stamp: 'rbb 3/1/2005 10:51'! 83738addEntry 83739 | newKey aKey | 83740 83741 newKey := UIManager default request: 83742'Enter new key, then type RETURN. 83743(Expression will be evaluated for value.) 83744Examples: #Fred ''a string'' 3+4'. 83745 aKey := Compiler evaluate: newKey. 83746 object at: aKey put: nil. 83747 self calculateKeyArray. 83748 selectionIndex := self numberOfFixedFields + (keyArray indexOf: aKey). 83749 self changed: #inspectObject. 83750 self changed: #selectionIndex. 83751 self changed: #fieldList. 83752 self update! ! 83753 83754!DictionaryInspector methodsFor: 'menu' stamp: 'apb 8/20/2004 21:19'! 83755copyName 83756 "Copy the name of the current variable, so the user can paste it into the 83757 window below and work with is. If collection, do (xxx at: 1)." 83758 | sel | 83759 self selectionIndex <= self numberOfFixedFields 83760 ifTrue: [super copyName] 83761 ifFalse: [sel := String streamContents: [:strm | 83762 strm nextPutAll: '(self at: '. 83763 (keyArray at: selectionIndex - self numberOfFixedFields) 83764 storeOn: strm. 83765 strm nextPutAll: ')']. 83766 Clipboard clipboardText: sel asText "no undo allowed"]! ! 83767 83768!DictionaryInspector methodsFor: 'menu' stamp: 'ar 10/31/2004 17:25'! 83769fieldListMenu: aMenu 83770 83771 ^ aMenu labels: 83772'inspect 83773copy name 83774references 83775objects pointing to this value 83776senders of this key 83777refresh view 83778add key 83779rename key 83780remove 83781basic inspect' 83782 lines: #(6 9) 83783 selections: #(inspectSelection copyName selectionReferences objectReferencesToSelection sendersOfSelectedKey refreshView addEntry renameEntry removeSelection inspectBasic) 83784! ! 83785 83786!DictionaryInspector methodsFor: 'menu' stamp: 'sd 11/20/2005 21:27'! 83787removeSelection 83788 selectionIndex = 0 ifTrue: [^ self changed: #flash]. 83789 object removeKey: (keyArray at: selectionIndex - self numberOfFixedFields). 83790 selectionIndex := 0. 83791 contents := ''. 83792 self calculateKeyArray. 83793 self changed: #inspectObject. 83794 self changed: #selectionIndex. 83795 self changed: #fieldList. 83796 self changed: #selection.! ! 83797 83798!DictionaryInspector methodsFor: 'menu' stamp: 'rbb 3/1/2005 10:51'! 83799renameEntry 83800 | newKey aKey value | 83801 83802 value := object at: (keyArray at: selectionIndex - self numberOfFixedFields). 83803 newKey := UIManager default request: 83804'Enter new key, then type RETURN. 83805(Expression will be evaluated for value.) 83806Examples: #Fred ''a string'' 3+4' 83807 initialAnswer: (keyArray at: selectionIndex - self numberOfFixedFields) printString. 83808 aKey := Compiler evaluate: newKey. 83809 object removeKey: (keyArray at: selectionIndex - self numberOfFixedFields). 83810 object at: aKey put: value. 83811 self calculateKeyArray. 83812 selectionIndex := self numberOfFixedFields + (keyArray indexOf: aKey). 83813 self changed: #selectionIndex. 83814 self changed: #inspectObject. 83815 self changed: #fieldList. 83816 self update! ! 83817 83818!DictionaryInspector methodsFor: 'menu' stamp: 'ar 10/31/2004 17:26'! 83819selectionReferences 83820 "Create a browser on all references to the association of the current selection." 83821 83822 self selectionIndex = 0 ifTrue: [^ self changed: #flash]. 83823 object class == MethodDictionary ifTrue: [^ self changed: #flash]. 83824 self systemNavigation browseAllCallsOn: (object associationAt: (keyArray at: selectionIndex - self numberOfFixedFields)). 83825! ! 83826 83827!DictionaryInspector methodsFor: 'menu' stamp: 'ar 4/10/2005 22:17'! 83828sendersOfSelectedKey 83829 "Create a browser on all senders of the selected key" 83830 | aKey | 83831 self selectionIndex = 0 83832 ifTrue: [^ self changed: #flash]. 83833 ((aKey := keyArray at: selectionIndex - self numberOfFixedFields) isSymbol) 83834 ifFalse: [^ self changed: #flash]. 83835 SystemNavigation default browseAllCallsOn: aKey! ! 83836 83837 83838!DictionaryInspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'! 83839addEntry: aKey 83840 object at: aKey put: nil. 83841 self calculateKeyArray. 83842 selectionIndex := self numberOfFixedFields + (keyArray indexOf: aKey). 83843 self changed: #inspectObject. 83844 self changed: #selectionIndex. 83845 self changed: #fieldList. 83846 self update! ! 83847 83848!DictionaryInspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'! 83849calculateKeyArray 83850 "Recalculate the KeyArray from the object being inspected" 83851 83852 keyArray := object keysSortedSafely asArray. 83853 selectionIndex := 0. 83854! ! 83855 83856!DictionaryInspector methodsFor: 'selecting' stamp: 'di 9/22/1998 21:25'! 83857contentsIsString 83858 "Hacked so contents empty when deselected" 83859 83860 ^ (selectionIndex = 0)! ! 83861 83862!DictionaryInspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'! 83863refreshView 83864 | i | 83865 i := selectionIndex. 83866 self calculateKeyArray. 83867 selectionIndex := i. 83868 self changed: #fieldList. 83869 self changed: #contents.! ! 83870 83871!DictionaryInspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 22:37'! 83872replaceSelectionValue: anObject 83873 selectionIndex <= self numberOfFixedFields 83874 ifTrue: [^ super replaceSelectionValue: anObject]. 83875 ^ object 83876 at: (keyArray at: selectionIndex - self numberOfFixedFields) 83877 put: anObject! ! 83878 83879!DictionaryInspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 21:55'! 83880selection 83881 83882 selectionIndex <= (self numberOfFixedFields) ifTrue: [^ super selection]. 83883 ^ object at: (keyArray at: selectionIndex - self numberOfFixedFields) ifAbsent:[nil]! ! 83884 83885 83886!DictionaryInspector methodsFor: 'private' stamp: 'apb 8/20/2004 21:15'! 83887numberOfFixedFields 83888 ^ 2 + object class instSize! ! 83889CollectionRootTest subclass: #DictionaryTest 83890 uses: TIncludesTest + TDictionaryAddingTest + TDictionaryComparingTest + TDictionaryCopyingTest + TDictionaryEnumeratingTest + TDictionaryPrintingTest - {#testPrintElementsOn. #testStoreOn} + TDictionaryRemovingTest + TPutBasicTest - {#testAtPutOutOfBounds} + TAsStringCommaAndDelimiterTest + TPrintTest + TConvertTest + TConvertAsSortedTest + TCopyTest - {#testCopyEmptyWithout. #testCopyNonEmptyWithout. #testCopyNonEmptyWithoutNotIncluded} + TSetArithmetic + TDictionaryIncludesWithIdentityCheckTest + TDictionaryValueAccessTest + TDictionaryKeysValuesAssociationsAccess + TDictionaryKeyAccessTest + TDictionaryAssociationAccessTest + TStructuralEqualityTest + TOccurrencesForMultiplinessTest 83891 instanceVariableNames: 'emptyDict nonEmptyDict nonEmpty5ElementsNoDuplicates indexArray valueArray nonEmpty1Element collectionNotIncluded collectionIncluded associationNotIn valueNotIn keyNotIn dictionaryNotIncluded nonEmptyWithFloat dictionaryWithDuplicateValues duplicateValue' 83892 classVariableNames: '' 83893 poolDictionaries: '' 83894 category: 'CollectionsTests-Unordered'! 83895 83896!DictionaryTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:24'! 83897aValue 83898 83899 ^ 33! ! 83900 83901!DictionaryTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:25'! 83902anIndex 83903 83904 ^ #GG! ! 83905 83906!DictionaryTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:25'! 83907anotherValue 83908 83909 ^ 66! ! 83910 83911 83912!DictionaryTest methodsFor: 'requirement' stamp: 'stephane.ducasse 11/21/2008 15:05'! 83913anotherElementNotIn 83914 ^ 42! ! 83915 83916!DictionaryTest methodsFor: 'requirement' stamp: 'delaunay 5/5/2009 14:16'! 83917associationWithKeyAlreadyInToAdd 83918 " return an association that will be used to add to nonEmptyDict (the key of this association is already included in nonEmptyDict)" 83919 ^ (self nonEmptyDict keys anyOne)->valueNotIn .! ! 83920 83921!DictionaryTest methodsFor: 'requirement' stamp: 'delaunay 5/5/2009 14:15'! 83922associationWithKeyNotInToAdd 83923 " return an association that will be used to add to nonEmptyDict" 83924 ^ associationNotIn ! ! 83925 83926!DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/13/2009 16:15'! 83927collection 83928 ^ self nonEmptyDict! ! 83929 83930!DictionaryTest methodsFor: 'requirement' stamp: 'delaunay 4/2/2009 11:53'! 83931elementNotInForOccurrences 83932 ^ 666! ! 83933 83934!DictionaryTest methodsFor: 'requirement' stamp: 'stephane.ducasse 11/21/2008 15:04'! 83935empty 83936 ^ emptyDict! ! 83937 83938!DictionaryTest methodsFor: 'requirement' stamp: 'AlexandreBergel 1/6/2009 15:06'! 83939emptyDict 83940 ^ emptyDict! ! 83941 83942!DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/21/2009 18:22'! 83943expectedElementByDetect 83944 ^ 30! ! 83945 83946!DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/30/2009 17:44'! 83947expectedSizeAfterReject 83948 self flag: 'what should this return?'! ! 83949 83950!DictionaryTest methodsFor: 'requirement' stamp: 'AlexandreBergel 1/6/2009 15:09'! 83951newEmptyDict 83952 ^ self emptyDict copy! ! 83953 83954!DictionaryTest methodsFor: 'requirement' stamp: 'AlexandreBergel 1/6/2009 15:06'! 83955nonEmptyDict 83956 ^ nonEmptyDict ! ! 83957 83958!DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/13/2009 16:35'! 83959result 83960 ^ Dictionary newFromPairs: { 83961 #a . SmallInteger . 83962 #b . SmallInteger . 83963 #c . SmallInteger . 83964 #d . SmallInteger }! ! 83965 83966!DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/13/2009 16:55'! 83967sizeCollection 83968 ^ nonEmptyDict! ! 83969 83970!DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/21/2009 18:04'! 83971speciesClass 83972 ^ Dictionary! ! 83973 83974 83975!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 11:56'! 83976anotherElementOrAssociationIn 83977 " return an element (or an association for Dictionary ) present in 'collection' " 83978 ^ self collection associations anyOne.! ! 83979 83980!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 11:56'! 83981anotherElementOrAssociationNotIn 83982 " return an element (or an association for Dictionary )not present in 'collection' " 83983 ^ associationNotIn ! ! 83984 83985!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 11:32'! 83986collectionClass 83987" return the class to be used to create instances of the class tested" 83988 ^ Dictionary! ! 83989 83990!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 10:16'! 83991collectionNotIncluded 83992" return a collection for wich each element is not included in 'nonEmpty' " 83993 ^collectionNotIncluded ! ! 83994 83995!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 16:05'! 83996collectionWithElement 83997 "Returns a collection that already includes what is returned by #element." 83998 ^ nonEmpty5ElementsNoDuplicates add: self element ;yourself.! ! 83999 84000!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 11:09'! 84001collectionWithElementsToRemove 84002" return a collection of elements included in 'nonEmpty' " 84003 ^ collectionIncluded ! ! 84004 84005!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:54'! 84006collectionWithEqualElements 84007" return a collecition including atLeast two elements equal" 84008 84009^ dictionaryWithDuplicateValues ! ! 84010 84011!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 10:45'! 84012collectionWithSortableElements 84013" return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" 84014 ^ nonEmpty5ElementsNoDuplicates ! ! 84015 84016!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 15:52'! 84017collectionWithoutEqualElements 84018" return a collection without equal elements" 84019 ^ nonEmpty5ElementsNoDuplicates ! ! 84020 84021!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 15:19'! 84022collectionWithoutNilElements 84023" return a collection that doesn't includes a nil element and that doesn't includes equal elements'" 84024 ^nonEmpty5ElementsNoDuplicates ! ! 84025 84026!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 16:08'! 84027element 84028 ^ 30! ! 84029 84030!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 14:51'! 84031elementNotIn 84032 "return an element not included in 'nonEmpty' " 84033 ^ valueNotIn! ! 84034 84035!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 10:17'! 84036elementToAdd 84037" return an element of type 'nonEmpy' elements'type'" 84038 ^ #u->5.! ! 84039 84040!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:54'! 84041elementTwiceInForOccurrences 84042" return an element included exactly two time in # collectionWithEqualElements" 84043^ duplicateValue ! ! 84044 84045!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 10:12'! 84046indexInNonEmpty 84047" return an index between bounds of 'nonEmpty' " 84048 84049 ^ #a! ! 84050 84051!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 15:52'! 84052integerCollectionWithoutEqualElements 84053" return a collection of integer without equal elements" 84054 ^ nonEmpty5ElementsNoDuplicates ! ! 84055 84056!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 16:05'! 84057keyNotIn 84058" return a key not included in nonEmpty" 84059^ keyNotIn ! ! 84060 84061!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 15:00'! 84062keyNotInNonEmpty 84063 " return a key not included in nonEmpty" 84064 ^ keyNotIn ! ! 84065 84066!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/5/2009 15:21'! 84067keyNotInNonEmptyDict 84068" return a key not included in nonEmptyDict" 84069 ^ keyNotIn ! ! 84070 84071!DictionaryTest methodsFor: 'requirements' stamp: 'stephane.ducasse 11/21/2008 15:04'! 84072nonEmpty 84073 ^ nonEmptyDict! ! 84074 84075!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 15:24'! 84076nonEmpty1Element 84077" return a collection of size 1 including one element" 84078 ^ nonEmpty1Element ! ! 84079 84080!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/6/2009 10:09'! 84081nonEmptyDifferentFromNonEmptyDict 84082" return a dictionary for which all keys are not included in nonEmptyDict" 84083^ dictionaryNotIncluded ! ! 84084 84085!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/12/2009 11:07'! 84086nonEmptyWithCopyNonIdentical. 84087" return a collection including elements for wich copy is not identical to the initial element ( this is not the cas of Integer )" 84088^nonEmptyWithFloat ! ! 84089 84090!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/5/2009 10:41'! 84091nonEmptyWithoutEqualsValues 84092" return a dictionary that doesn't include equal values'" 84093^nonEmpty5ElementsNoDuplicates ! ! 84094 84095!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 16:04'! 84096otherCollection 84097 "Returns a collection that does not include what is returned by #element." 84098 ^ nonEmpty5ElementsNoDuplicates ! ! 84099 84100!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/5/2009 10:41'! 84101valueNotIn 84102" return a value not included in nonEmpty " 84103^valueNotIn ! ! 84104 84105!DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 15:00'! 84106valueNotInNonEmpty 84107 " return a value not included in nonEmpty" 84108 ^ valueNotIn ! ! 84109 84110 84111!DictionaryTest methodsFor: 'setup' stamp: 'AlexandreBergel 1/14/2009 15:14'! 84112classToBeTested 84113 84114 ^ Dictionary! ! 84115 84116!DictionaryTest methodsFor: 'setup' stamp: 'delaunay 5/13/2009 15:54'! 84117setUp 84118 emptyDict := self classToBeTested new. 84119 nonEmptyDict := self classToBeTested new. 84120 nonEmptyDict 84121 at: #a 84122 put: self elementTwiceIn; 84123 at: #b 84124 put: 30; 84125 at: #c 84126 put: self elementTwiceIn; 84127 at: #d 84128 put: -2. 84129 nonEmpty5ElementsNoDuplicates := self classToBeTested new 84130 at: #a 84131 put: 5; 84132 at: #b 84133 put: 4; 84134 at: #c 84135 put: 7; 84136 at: #d 84137 put: 6; 84138 at: #e 84139 put: 9; 84140 yourself. 84141 valueNotIn := 666. 84142 keyNotIn := #z . 84143 associationNotIn := keyNotIn->valueNotIn. 84144 dictionaryNotIncluded := Dictionary new add: associationNotIn ;yourself. 84145 collectionNotIncluded := { valueNotIn. valueNotIn }. 84146 collectionIncluded := { (self elementTwiceIn) }. 84147 indexArray := #(2 3 1 ). 84148 valueArray := #(5 5 5 ). 84149 nonEmpty1Element := self classToBeTested new 84150 at: #a 84151 put: 5; 84152 yourself. 84153 nonEmptyWithFloat := Dictionary new add: #A->2.5; add: #b->3.5 ; yourself. 84154 duplicateValue := 2.5. 84155 dictionaryWithDuplicateValues := Dictionary new add: #A->duplicateValue ; add: #b->3.5 ; add: #C->duplicateValue ; yourself. 84156 84157! ! 84158 84159 84160!DictionaryTest methodsFor: 'test - adding' stamp: 'delaunay 5/5/2009 12:08'! 84161testAdd 84162 "| dict | 84163 dict := self emptyDict. 84164 dict add: #a -> 1. 84165 dict add: #b -> 2. 84166 self assert: (dict at: #a) = 1. 84167 self assert: (dict at: #b) = 2" 84168 | dictionary result | 84169 dictionary := self nonEmptyDict. 84170 result := dictionary add: self associationWithKeyNotInToAdd. 84171 self assert: result = self associationWithKeyNotInToAdd! ! 84172 84173!DictionaryTest methodsFor: 'test - adding'! 84174testAddAll 84175 84176 | collectionToAdd collection result oldSize | 84177 collection := self nonEmptyDict . 84178 oldSize := collection size. 84179 collectionToAdd := Dictionary new add: self associationWithKeyAlreadyInToAdd ; add: self associationWithKeyNotInToAdd ; yourself. 84180 84181 result := collection addAll: collectionToAdd . 84182 84183 self assert: result = collectionToAdd . 84184 " the association with the key already in should have replaced the oldest :" 84185 self assert: collection size = (oldSize + 1). 84186 84187 result associationsDo: [:assoc | self assert: (collection at: (assoc key) ) = assoc value].! ! 84188 84189!DictionaryTest methodsFor: 'test - adding' stamp: 'delaunay 5/5/2009 12:08'! 84190testAddWithKeyAlreadyIn 84191 | dictionary result association | 84192 dictionary := self nonEmptyDict. 84193 association := self associationWithKeyNotInToAdd. 84194 result := dictionary add: association. 84195 self assert: result = association. 84196 self assert: (dictionary at: association key) = association value! ! 84197 84198!DictionaryTest methodsFor: 'test - adding' stamp: 'delaunay 5/5/2009 12:08'! 84199testAddWithKeyNotIn 84200 | dictionary result association | 84201 dictionary := self nonEmptyDict. 84202 association := self associationWithKeyNotInToAdd. 84203 result := dictionary add: association. 84204 self assert: result = association. 84205 self assert: (dictionary at: association key) = association value! ! 84206 84207!DictionaryTest methodsFor: 'test - adding'! 84208testDeclareFrom 84209 | newDict v dictionary keyIn associationKeyNotIn | 84210 dictionary := self nonEmptyDict. 84211 keyIn := dictionary keys anyOne. 84212 associationKeyNotIn := self associationWithKeyNotInToAdd . 84213 newDict := Dictionary new add: associationKeyNotIn ; yourself. 84214 84215 84216 84217 "if the key already exist, nothing changes" 84218 v := dictionary at: keyIn. 84219 dictionary declare: keyIn from: newDict. 84220 self assert: (dictionary at: keyIn ) = v. 84221 84222 "if the key does not exist, then it gets removed from newDict and is added to the receiver" 84223 self nonEmptyDict declare: associationKeyNotIn key from: newDict. 84224 self assert: (dictionary at: associationKeyNotIn key) = associationKeyNotIn value. 84225 self assert: (newDict size = 0)! ! 84226 84227 84228!DictionaryTest methodsFor: 'test - comparing'! 84229testEquality 84230 | nonEmptyDict2 | 84231 nonEmptyDict2 := self nonEmpty class new. 84232 self nonEmpty keysAndValuesDo: [ :key :value | nonEmptyDict2 at: key put: value ]. 84233 84234 self assert: (self nonEmptyDict = nonEmptyDict2)! ! 84235 84236 84237!DictionaryTest methodsFor: 'test - copying'! 84238testDictionaryConcatenationWithCommonKeys 84239 84240 | dictionary1 dictionary2 result | 84241 dictionary1 := self nonEmptyDict. 84242 dictionary2 := self nonEmptyDict. 84243 result := dictionary1 , dictionary2. 84244 self assert: result size = ( dictionary2 size). 84245 84246 dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! ! 84247 84248!DictionaryTest methodsFor: 'test - copying'! 84249testDictionaryConcatenationWithCommonKeysDifferentValues 84250 84251 | dictionary1 dictionary2 result value | 84252 84253 dictionary1 := self nonEmptyDict. 84254 value := self nonEmptyDifferentFromNonEmptyDict values anyOne. 84255 dictionary2 := dictionary1 copy. 84256 dictionary2 keys do: [ :key | dictionary2 at: key put: value ]. 84257 84258 84259 result := dictionary1 , dictionary2. 84260 self assert: result size = ( dictionary2 size). 84261 84262 dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! ! 84263 84264!DictionaryTest methodsFor: 'test - copying' stamp: 'delaunay 5/6/2009 10:12'! 84265testDictionaryConcatenationWithoutCommonKeys 84266 "self run: #testDictionaryConcatenation" 84267 "| dict1 dict2 dict3 | 84268 dict1 := self emptyDict. 84269 dict1 at: #a put: 'Nicolas' ; at: #b put: 'Damien'. 84270 84271 dict2 := self emptyDict. 84272 dict2 at: #a put: 'Christophe' ; at: #c put: 'Anthony'. 84273 dict3 := dict1, dict2. 84274 84275 self assert: (dict3 at: #a) = 'Christophe'. 84276 self assert: (dict3 at: #b) = 'Damien'. 84277 self assert: (dict3 at: #c) = 'Anthony'. 84278 84279" 84280 | dictionary1 dictionary2 result | 84281 dictionary1 := self nonEmptyDict. 84282 dictionary2 := self nonEmptyDifferentFromNonEmptyDict. 84283 result := dictionary1 , dictionary2. 84284 self assert: result size = (dictionary1 size + dictionary2 size). 84285 dictionary1 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]. 84286 dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! ! 84287 84288 84289!DictionaryTest methodsFor: 'test - equality'! 84290testEqualSign 84291 "self debug: #testEqualSign" 84292 84293 self deny: (self empty = self nonEmpty).! ! 84294 84295!DictionaryTest methodsFor: 'test - equality'! 84296testEqualSignIsTrueForNonIdenticalButEqualCollections 84297 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 84298 84299 self assert: (self empty = self empty copy). 84300 self assert: (self empty copy = self empty). 84301 self assert: (self empty copy = self empty copy). 84302 84303 self assert: (self nonEmpty = self nonEmpty copy). 84304 self assert: (self nonEmpty copy = self nonEmpty). 84305 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 84306 84307!DictionaryTest methodsFor: 'test - equality'! 84308testEqualSignOfIdenticalCollectionObjects 84309 "self debug: #testEqualSignOfIdenticalCollectionObjects" 84310 84311 self assert: (self empty = self empty). 84312 self assert: (self nonEmpty = self nonEmpty). 84313 ! ! 84314 84315 84316!DictionaryTest methodsFor: 'test - new' stamp: 'delaunay 5/4/2009 14:24'! 84317testNew 84318 | d | 84319 d := self classToBeTested new: 10. 84320 self assert: d size = 0. 84321 84322 "Why 14? Mysterious" 84323 "self assert: d capacity = 14"! ! 84324 84325 84326!DictionaryTest methodsFor: 'test - removing'! 84327testKeysAndValuesRemove 84328 | oldSize collection keyIn | 84329 84330 collection := self nonEmptyDict . 84331 oldSize := collection size. 84332 keyIn := collection keys anyOne. 84333 84334 collection keysAndValuesRemove: [:key :value | key == self keyNotInNonEmptyDict ]. 84335 self assert: (collection size = (oldSize )). 84336 84337 collection keysAndValuesRemove: [:key :value | key == keyIn ]. 84338 self assert: (collection size = (oldSize - 1)). 84339 self should: [ collection at: keyIn ] raise: Error.! ! 84340 84341!DictionaryTest methodsFor: 'test - removing'! 84342testRemove 84343 84344 self should: [self nonEmptyDict remove: nil] raise: Error. 84345 self should: [self nonEmptyDict remove: nil ifAbsent: ['What ever here']] raise: Error.! ! 84346 84347!DictionaryTest methodsFor: 'test - removing'! 84348testRemoveKey 84349 "self debug: #testRemoveKey" 84350 84351 | collection oldSize keyIn | 84352 collection := self nonEmptyDict . 84353 oldSize := collection size. 84354 keyIn := collection keys anyOne. 84355 84356 collection removeKey: keyIn . 84357 self assert: (collection size = (oldSize - 1)). 84358 self should: [ (collection at: keyIn )] raise: Error. 84359 84360 self should: [collection removeKey: self keyNotInNonEmptyDict ] raise: Error! ! 84361 84362!DictionaryTest methodsFor: 'test - removing'! 84363testRemoveKeyIfAbsent 84364 84365 | collection oldSize keyIn value result | 84366 collection := self nonEmptyDict . 84367 oldSize := collection size. 84368 keyIn := collection keys anyOne. 84369 value := collection at: keyIn . 84370 84371 result := collection removeKey: keyIn ifAbsent: [888]. 84372 84373 self assert: result = value. 84374 self assert: (collection size = (oldSize - 1)). 84375 self should: [ (collection at: keyIn )] raise: Error. 84376 84377 self assert: (collection removeKey: self keyNotInNonEmptyDict ifAbsent: [888] ) = 888.! ! 84378 84379 84380!DictionaryTest methodsFor: 'test - testing' stamp: 'AlexandreBergel 1/6/2009 11:56'! 84381testHasBindingThatBeginsWith 84382 | newDict | 84383 newDict := Dictionary new at: #abc put: 10; at: #abcd put: 100; at: #def put: 20; yourself. 84384 self assert: (newDict hasBindingThatBeginsWith: 'ab'). 84385 self assert: (newDict hasBindingThatBeginsWith: 'def'). 84386 self deny: (newDict hasBindingThatBeginsWith: 'defg').! ! 84387 84388!DictionaryTest methodsFor: 'test - testing' stamp: 'damienpollet 1/30/2009 17:55'! 84389testIncludeAssociation 84390 self assert: (nonEmptyDict includesAssociation: #a -> self elementTwiceIn). 84391 self assert: (nonEmptyDict includesAssociation: (nonEmptyDict associations first)). 84392! ! 84393 84394!DictionaryTest methodsFor: 'test - testing' stamp: 'damienpollet 1/30/2009 17:57'! 84395testIncludes 84396 | o1 o2 newDict | 84397 self assert: (nonEmptyDict includes: self element). 84398 84399 o1 := 2 @ 3. 84400 o2 := 2 @ 3. 84401 self deny: (o1 == o2). 84402 self assert: (o1 = o2). 84403 newDict := Dictionary new. 84404 newDict at: #a put: o1. 84405 84406 self assert: (newDict includes: o2). 84407! ! 84408 84409!DictionaryTest methodsFor: 'test - testing' stamp: 'GabrielOmarCotelli 6/6/2009 19:07'! 84410testIncludesAssociationNoValue 84411 84412 | association dictionary | 84413 84414 association := Association key: #key. 84415 84416 self assert: association value isNil. 84417 84418 dictionary := Dictionary new. 84419 84420 dictionary add: association. 84421 84422 self assert: (dictionary at: #key) isNil 84423 84424 84425 84426 ! ! 84427 84428!DictionaryTest methodsFor: 'test - testing' stamp: 'GabrielOmarCotelli 6/6/2009 19:08'! 84429testIncludesAssociationWithValue 84430 84431 | association dictionary | 84432 84433 association := Association key: #key value: 1. 84434 dictionary := Dictionary new. 84435 dictionary add: association. 84436 84437 self assert: (dictionary at: #key) = 1 84438 84439 84440 84441 ! ! 84442 84443!DictionaryTest methodsFor: 'test - testing' stamp: 'AlexandreBergel 1/6/2009 13:48'! 84444testIsDictionary 84445 self deny: Object new isDictionary. 84446 self assert: nonEmptyDict isDictionary. 84447 self assert: emptyDict isDictionary.! ! 84448 84449!DictionaryTest methodsFor: 'test - testing' stamp: 'damienpollet 1/30/2009 17:57'! 84450testKeyForIdentity 84451 self assert: (nonEmptyDict keyForIdentity: 30) = #b. 84452 84453 "The value 20 is associated to two different associations" 84454 self assert: (#(a c) includes: (nonEmptyDict keyForIdentity: self elementTwiceIn))! ! 84455 84456!DictionaryTest methodsFor: 'test - testing' stamp: 'stephane.ducasse 5/20/2009 18:08'! 84457testOccurrencesOf 84458 "self run:#testOccurrencesOf" 84459 84460 | dict | 84461 dict := Dictionary new. 84462 dict at: #a put: 1. 84463 dict at: #b put: 2. 84464 dict at: #c put: 1. 84465 dict at: #d put: 3. 84466 dict at: nil put: nil. 84467 dict at: #z put: nil. 84468 84469 84470 self assert: (dict occurrencesOf: 1 ) = 2. 84471 self assert: (dict occurrencesOf: nil ) = 2. 84472 84473 84474 84475 ! ! 84476 84477 84478!DictionaryTest methodsFor: 'tests - Dictionary keys values associations access'! 84479testAssociations 84480 84481 | collection result | 84482 collection := self nonEmpty . 84483 result := collection associations. 84484 84485 self assert: result size = collection size. 84486 result do: [:assoc | self assert: (assoc value) = (collection at: assoc key) ]. 84487 "keys do: [ :key | self assert: ( result at: key ) = ( collection at: key )] ." 84488 ! ! 84489 84490!DictionaryTest methodsFor: 'tests - Dictionary keys values associations access'! 84491testKeys 84492 84493 | collection result | 84494 collection := self nonEmpty. 84495 result := collection keys. 84496 84497 result do: [ :key | self shouldnt: [collection at: key ] raise:Error ]. 84498 self assert: result size = collection size . 84499 84500 self should: [result detect: [:each | (result occurrencesOf: each ) > 1] ] raise: Error. ! ! 84501 84502!DictionaryTest methodsFor: 'tests - Dictionary keys values associations access'! 84503testKeysSortedSafely 84504 | collection result | 84505 collection := self nonEmpty. 84506 result := collection keysSortedSafely . 84507 84508 result do: [ :key | self shouldnt: [collection at: key ] raise:Error ]. 84509 self assert: result size = collection size . 84510 84511 self should: [result detect: [:each | (result occurrencesOf: each ) > 1] ] raise: Error. 84512 self assert: result asArray isSorted.! ! 84513 84514!DictionaryTest methodsFor: 'tests - Dictionary keys values associations access'! 84515testValues 84516 84517 | collection result | 84518 collection := self nonEmpty . 84519 result := collection values. 84520 84521 self assert: result size = collection size. 84522 result do: [:each | self assert: (collection occurrencesOf:each ) = (result occurrencesOf: each) ]. 84523 ! ! 84524 84525 84526!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing'! 84527testAt 84528 | collection association | 84529 collection := self nonEmpty . 84530 association := collection associations anyOne. 84531 84532 self assert: (collection at: association key) = association value.! ! 84533 84534!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing'! 84535testAtError 84536 "self run: #testAtError" 84537 84538 | dict keyNotIn keyIn | 84539 dict := self nonEmpty . 84540 keyNotIn := self keyNotIn . 84541 keyIn := dict keys anyOne. 84542 84543 self shouldnt: [ dict at: keyIn ] raise: Error. 84544 84545 self should: [ dict at: keyNotIn ] raise: Error. 84546 84547 ! ! 84548 84549!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing'! 84550testAtIfAbsent 84551 | collection association | 84552 collection := self nonEmpty . 84553 association := collection associations anyOne. 84554 84555 self assert: (collection at: association key ifAbsent: [ 888 ]) = association value. 84556 self assert: (collection at: self keyNotIn ifAbsent: [ 888 ]) = 888.! ! 84557 84558!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing'! 84559testAtIfAbsentPut 84560 | collection association | 84561 collection := self nonEmpty . 84562 association := collection associations anyOne. 84563 84564 collection at: association key ifAbsentPut: [ 888 ]. 84565 self assert: (collection at: association key) = association value. 84566 84567 collection at: self keyNotIn ifAbsentPut: [ 888 ]. 84568 self assert: ( collection at: self keyNotIn ) = 888.! ! 84569 84570!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing'! 84571testAtIfPresent 84572 "self run: #testAtIfAbsent" 84573 84574 | t collection association keyNotIn | 84575 collection := self nonEmpty . 84576 association := collection associations anyOne. 84577 keyNotIn := self keyNotIn . 84578 84579 t := false. 84580 self nonEmptyDict at: association key ifPresent: [:x | t := (x = association value)]. 84581 self assert: t. 84582 84583 self assert: (self nonEmptyDict at: association key ifPresent: [:x | 'ABCDEF']) = 'ABCDEF'. 84584 84585 self assert: (self nonEmptyDict at: keyNotIn ifPresent: [:x | Error signal]) isNil 84586! ! 84587 84588!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing'! 84589testAtPutDict 84590 "self run: #testAtPutDict" 84591 "self debug: #testAtPutDict" 84592 84593 | adictionary keyIn | 84594 adictionary := self nonEmpty . 84595 keyIn := adictionary keys anyOne. 84596 84597 adictionary at: keyIn put: 'new'. 84598 self assert: (adictionary at: keyIn ) = 'new'. 84599 84600 adictionary at: keyIn put: 'newnew'. 84601 self assert: (adictionary at: keyIn ) = 'newnew'. 84602 84603 adictionary at: self keyNotIn put: 666. 84604 self assert: (adictionary at: self keyNotIn ) = 666.! ! 84605 84606!DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing'! 84607testAtPutNil 84608 "self run: #testAtPut" 84609 "self debug: #testAtPut" 84610 84611 | dict keyIn | 84612 dict := self nonEmpty . 84613 keyIn := dict keys anyOne. 84614 84615 dict at: nil put: 'new'. 84616 self assert: (dict at: nil) = 'new'. 84617 84618 dict at: keyIn put: nil. 84619 self assert: (dict at: keyIn ) isNil. 84620 84621 dict at: self keyNotIn put: nil. 84622 self assert: ( dict at: self keyNotIn ) isNil. 84623 84624 dict at: nil put: nil. 84625 self assert: (dict at: nil) isNil.! ! 84626 84627 84628!DictionaryTest methodsFor: 'tests - as sorted collection'! 84629testAsSortedArray 84630 | result collection | 84631 collection := self collectionWithSortableElements . 84632 result := collection asSortedArray. 84633 self assert: (result class includesBehavior: Array). 84634 self assert: result isSorted. 84635 self assert: result size = collection size! ! 84636 84637!DictionaryTest methodsFor: 'tests - as sorted collection'! 84638testAsSortedCollection 84639 84640 | aCollection result | 84641 aCollection := self collectionWithSortableElements . 84642 result := aCollection asSortedCollection. 84643 84644 self assert: (result class includesBehavior: SortedCollection). 84645 result do: 84646 [ :each | 84647 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 84648 84649 self assert: result size = aCollection size.! ! 84650 84651!DictionaryTest methodsFor: 'tests - as sorted collection'! 84652testAsSortedCollectionWithSortBlock 84653 | result tmp | 84654 result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. 84655 self assert: (result class includesBehavior: SortedCollection). 84656 result do: 84657 [ :each | 84658 self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 84659 self assert: result size = self collectionWithSortableElements size. 84660 tmp:=result at: 1. 84661 result do: [:each| self assert: tmp>=each. tmp:=each]. 84662 ! ! 84663 84664 84665!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable'! 84666testAsCommaStringEmpty 84667 84668 self assert: self empty asCommaString = ''. 84669 self assert: self empty asCommaStringAnd = ''. 84670 84671! ! 84672 84673!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable'! 84674testAsCommaStringMore 84675 84676 | result resultAnd index allElementsAsString tmp | 84677 result:= self nonEmpty asCommaString . 84678 resultAnd:= self nonEmpty asCommaStringAnd . 84679 tmp :=OrderedCollection new. 84680 self nonEmpty do: [ :each | tmp add: each asString]. 84681 84682 "verifying result :" 84683 index := 1. 84684 allElementsAsString := (result findBetweenSubStrs: ', ' ). 84685 allElementsAsString do: 84686 [:each | 84687 self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). 84688 ]. 84689 84690 "verifying esultAnd :" 84691 allElementsAsString:=(resultAnd findBetweenSubStrs: ', ' ). 84692 1 to: allElementsAsString size do: 84693 [:i | 84694 i<(allElementsAsString size-1 ) | i= allElementsAsString size 84695 ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. 84696 i=(allElementsAsString size-1) 84697 ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. 84698 ].! ! 84699 84700!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable'! 84701testAsCommaStringOne 84702 84703 self nonEmpty1Element do: 84704 [:each | 84705 self assert: each asString =self nonEmpty1Element asCommaString. 84706 self assert: each asString=self nonEmpty1Element asCommaStringAnd.]. 84707 84708 ! ! 84709 84710!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable'! 84711testAsStringOnDelimiterEmpty 84712 84713 | delim emptyStream | 84714 delim := ', '. 84715 emptyStream := ReadWriteStream on: ''. 84716 self empty asStringOn: emptyStream delimiter: delim. 84717 self assert: emptyStream contents = ''. 84718! ! 84719 84720!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable'! 84721testAsStringOnDelimiterLastEmpty 84722 84723 | delim emptyStream | 84724 delim := ', '. 84725 emptyStream := ReadWriteStream on: ''. 84726 self empty asStringOn: emptyStream delimiter: delim last:'and'. 84727 self assert: emptyStream contents = ''. 84728! ! 84729 84730!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable'! 84731testAsStringOnDelimiterLastMore 84732 84733 | delim multiItemStream result last allElementsAsString tmp | 84734 84735 delim := ', '. 84736 last := 'and'. 84737 result:=''. 84738 tmp := self nonEmpty collect: [:each | each asString]. 84739 multiItemStream := ReadWriteStream on:result. 84740 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 84741 84742 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 84743 1 to: allElementsAsString size do: 84744 [:i | 84745 i<(allElementsAsString size-1 ) | i= allElementsAsString size 84746 ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. 84747 i=(allElementsAsString size-1) 84748 ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. 84749 ]. 84750! ! 84751 84752!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable'! 84753testAsStringOnDelimiterLastOne 84754 84755 | delim oneItemStream result | 84756 84757 delim := ', '. 84758 result:=''. 84759 oneItemStream := ReadWriteStream on: result. 84760 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 84761 oneItemStream do: 84762 [:each1 | 84763 self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] 84764 ]. 84765 84766 84767! ! 84768 84769!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable'! 84770testAsStringOnDelimiterMore 84771 84772 | delim multiItemStream result allElementsAsString tmp | 84773 84774 84775 delim := ', '. 84776 result:=''. 84777 tmp:= self nonEmpty collect:[:each | each asString]. 84778 multiItemStream := ReadWriteStream on:result. 84779 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 84780 84781 allElementsAsString := (result findBetweenSubStrs: ', ' ). 84782 allElementsAsString do: 84783 [:each | 84784 self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). 84785 ].! ! 84786 84787!DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable'! 84788testAsStringOnDelimiterOne 84789 84790 | delim oneItemStream result | 84791 84792 delim := ', '. 84793 result:=''. 84794 oneItemStream := ReadWriteStream on: result. 84795 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 84796 oneItemStream do: 84797 [:each1 | 84798 self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] 84799 ]. 84800 84801! ! 84802 84803 84804!DictionaryTest methodsFor: 'tests - at put'! 84805testAtPut 84806 "self debug: #testAtPut" 84807 84808 self nonEmpty at: self anIndex put: self aValue. 84809 self assert: (self nonEmpty at: self anIndex) = self aValue. 84810 ! ! 84811 84812!DictionaryTest methodsFor: 'tests - at put'! 84813testAtPutTwoValues 84814 "self debug: #testAtPutTwoValues" 84815 84816 self nonEmpty at: self anIndex put: self aValue. 84817 self nonEmpty at: self anIndex put: self anotherValue. 84818 self assert: (self nonEmpty at: self anIndex) = self anotherValue.! ! 84819 84820 84821!DictionaryTest methodsFor: 'tests - converting'! 84822assertNoDuplicates: aCollection whenConvertedTo: aClass 84823 | result | 84824 result := self collectionWithEqualElements asIdentitySet. 84825 self assert: (result class includesBehavior: IdentitySet). 84826 self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! 84827 84828!DictionaryTest methodsFor: 'tests - converting'! 84829assertNonDuplicatedContents: aCollection whenConvertedTo: aClass 84830 | result | 84831 result := aCollection perform: ('as' , aClass name) asSymbol. 84832 self assert: (result class includesBehavior: aClass). 84833 result do: 84834 [ :each | 84835 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 84836 ^ result! ! 84837 84838!DictionaryTest methodsFor: 'tests - converting'! 84839assertSameContents: aCollection whenConvertedTo: aClass 84840 | result | 84841 result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. 84842 self assert: result size = aCollection size! ! 84843 84844!DictionaryTest methodsFor: 'tests - converting'! 84845testAsArray 84846 "self debug: #testAsArray3" 84847 self 84848 assertSameContents: self collectionWithoutEqualElements 84849 whenConvertedTo: Array! ! 84850 84851!DictionaryTest methodsFor: 'tests - converting'! 84852testAsBag 84853 84854 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! 84855 84856!DictionaryTest methodsFor: 'tests - converting'! 84857testAsByteArray 84858| res | 84859self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 84860 self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . 84861 84862 res := true. 84863 self integerCollectionWithoutEqualElements 84864 detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] 84865 ifNone: [ res := false ]. 84866 self assert: res = false. 84867 84868 84869 self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! 84870 84871!DictionaryTest methodsFor: 'tests - converting'! 84872testAsIdentitySet 84873 "test with a collection without equal elements :" 84874 self 84875 assertSameContents: self collectionWithoutEqualElements 84876 whenConvertedTo: IdentitySet. 84877! ! 84878 84879!DictionaryTest methodsFor: 'tests - converting'! 84880testAsOrderedCollection 84881 84882 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! 84883 84884!DictionaryTest methodsFor: 'tests - converting'! 84885testAsSet 84886 | | 84887 "test with a collection without equal elements :" 84888 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. 84889 ! ! 84890 84891 84892!DictionaryTest methodsFor: 'tests - copy'! 84893testCopyEmptyWith 84894 "self debug: #testCopyWith" 84895 | res element | 84896 element := self elementToAdd. 84897 res := self empty copyWith: element. 84898 self assert: res size = (self empty size + 1). 84899 self assert: (res includes: (element value))! ! 84900 84901!DictionaryTest methodsFor: 'tests - copy'! 84902testCopyEmptyWithoutAll 84903 "self debug: #testCopyEmptyWithoutAll" 84904 | res | 84905 res := self empty copyWithoutAll: self collectionWithElementsToRemove. 84906 self assert: res size = self empty size. 84907 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! 84908 84909!DictionaryTest methodsFor: 'tests - copy'! 84910testCopyNonEmptyWith 84911 "self debug: #testCopyNonEmptyWith" 84912 | res element | 84913 element := self elementToAdd . 84914 res := self nonEmpty copyWith: element. 84915 "here we do not test the size since for a non empty set we would get a problem. 84916 Then in addition copy is not about duplicate management. The element should 84917 be in at the end." 84918 self assert: (res includes: (element value)). 84919 self nonEmpty do: [ :each | res includes: each ]! ! 84920 84921!DictionaryTest methodsFor: 'tests - copy'! 84922testCopyNonEmptyWithoutAll 84923 "self debug: #testCopyNonEmptyWithoutAll" 84924 | res | 84925 res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. 84926 "here we do not test the size since for a non empty set we would get a problem. 84927 Then in addition copy is not about duplicate management. The element should 84928 be in at the end." 84929 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. 84930 self nonEmpty do: 84931 [ :each | 84932 (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! 84933 84934!DictionaryTest methodsFor: 'tests - copy'! 84935testCopyNonEmptyWithoutAllNotIncluded 84936 "self debug: #testCopyNonEmptyWithoutAllNotIncluded" 84937 | res | 84938 res := self nonEmpty copyWithoutAll: self collectionNotIncluded. 84939 "here we do not test the size since for a non empty set we would get a problem. 84940 Then in addition copy is not about duplicate management. The element should 84941 be in at the end." 84942 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 84943 84944 84945!DictionaryTest methodsFor: 'tests - copy - clone'! 84946testCopyCreatesNewObject 84947 "self debug: #testCopyCreatesNewObject" 84948 84949 | copy | 84950 copy := self nonEmpty copy. 84951 self deny: self nonEmpty == copy. 84952 ! ! 84953 84954!DictionaryTest methodsFor: 'tests - copy - clone'! 84955testCopyEmpty 84956 "self debug: #testCopyEmpty" 84957 84958 | copy | 84959 copy := self empty copy. 84960 self assert: copy isEmpty.! ! 84961 84962!DictionaryTest methodsFor: 'tests - copy - clone'! 84963testCopyNonEmpty 84964 "self debug: #testCopyNonEmpty" 84965 84966 | copy | 84967 copy := self nonEmpty copy. 84968 self deny: copy isEmpty. 84969 self assert: copy size = self nonEmpty size. 84970 self nonEmpty do: 84971 [:each | copy includes: each]! ! 84972 84973 84974!DictionaryTest methodsFor: 'tests - dictionary assocition access'! 84975testAssociationAt 84976 84977| collection keyIn result | 84978collection := self nonEmpty. 84979keyIn := collection keys anyOne. 84980 84981result := collection associationAt: keyIn. 84982 84983self assert: (result key) = keyIn. 84984self assert: (result value ) = (collection at: keyIn ).! ! 84985 84986!DictionaryTest methodsFor: 'tests - dictionary assocition access'! 84987testAssociationAtError 84988 84989| collection keyNotIn | 84990collection := self nonEmpty. 84991keyNotIn := self keyNotIn . 84992 84993self should: [collection associationAt: keyNotIn] raise: Error. 84994 84995! ! 84996 84997!DictionaryTest methodsFor: 'tests - dictionary assocition access'! 84998testAssociationAtIfAbsent 84999 85000| collection keyIn result | 85001collection := self nonEmpty. 85002keyIn := collection keys anyOne. 85003 85004result := collection associationAt: keyIn ifAbsent: [888]. 85005 85006self assert: (result key) = keyIn. 85007self assert: (result value ) = (collection at: keyIn ). 85008 85009self assert: (collection associationAt: self keyNotIn ifAbsent: [888] ) = 888! ! 85010 85011!DictionaryTest methodsFor: 'tests - dictionary assocition access'! 85012testAssociationDeclareAt 85013 85014| collection keyIn result | 85015collection := self nonEmpty. 85016keyIn := collection keys anyOne. 85017 85018result := collection associationDeclareAt: keyIn . 85019self assert: (result key) = keyIn. 85020self assert: (result value ) = (collection at: keyIn ). 85021 85022result := collection associationDeclareAt: self keyNotIn . 85023self shouldnt: [collection at: self keyNotIn ] raise: Error. 85024self assert: (collection at: self keyNotIn ) = false.! ! 85025 85026 85027!DictionaryTest methodsFor: 'tests - dictionary including'! 85028testIncludesAssociation 85029 85030| associationNotIn associationIn keyIn valueIn | 85031 85032keyIn := self nonEmpty keys anyOne. 85033valueIn := self nonEmpty values anyOne. 85034associationNotIn := self keyNotInNonEmpty -> self valueNotInNonEmpty . 85035associationIn := self nonEmpty associations anyOne. 85036 85037self assert: (self nonEmpty includesAssociation: associationIn ). 85038self deny: (self nonEmpty includesAssociation: associationNotIn ). 85039" testing the case where key is included but not with the same value :" 85040self deny: (self nonEmpty includesAssociation: (keyIn-> self valueNotInNonEmpty )). 85041" testing the case where value is included but not corresponding key :" 85042self deny: (self nonEmpty includesAssociation: (self keyNotInNonEmpty -> valueIn )). 85043 85044 85045 85046! ! 85047 85048!DictionaryTest methodsFor: 'tests - dictionary including'! 85049testIncludesComportementForDictionnary 85050 | valueIn collection keyIn | 85051 collection := self nonEmpty. 85052 valueIn := collection values anyOne. 85053 keyIn := collection keys anyOne. 85054 self assert: (collection includes: valueIn). 85055 self deny: (collection includes: self valueNotInNonEmpty). 85056 " testing that includes take only care of values :" 85057 self deny: (collection includes: keyIn)! ! 85058 85059!DictionaryTest methodsFor: 'tests - dictionary including'! 85060testIncludesIdentityBasicComportement 85061 85062| valueIn collection | 85063collection := self nonEmpty . 85064valueIn := collection values anyOne. 85065 85066self assert: (collection includesIdentity: valueIn ) . 85067self deny: (collection includesIdentity: self valueNotInNonEmpty ).! ! 85068 85069!DictionaryTest methodsFor: 'tests - dictionary including'! 85070testIncludesIdentitySpecificComportement 85071 85072| valueIn collection | 85073collection := self nonEmptyWithCopyNonIdentical . 85074valueIn := collection values anyOne. 85075 85076self assert: (collection includesIdentity: valueIn ) . 85077self deny: (collection includesIdentity: valueIn copy ) . 85078! ! 85079 85080!DictionaryTest methodsFor: 'tests - dictionary including'! 85081testIncludesKey 85082 85083| collection keyIn keyNotIn | 85084 85085collection := self nonEmpty . 85086keyIn := collection keys anyOne. 85087keyNotIn := self keyNotInNonEmpty. 85088 85089self assert: ( collection includesKey: keyIn ). 85090self deny: ( collection includesKey: keyNotIn ).! ! 85091 85092 85093!DictionaryTest methodsFor: 'tests - dictionary key access'! 85094testKeyAtIdentityValue 85095 85096 85097 | dict value result | 85098 dict := self nonEmpty . 85099 value := dict values anyOne. 85100 85101 result := dict keyAtIdentityValue: value. 85102 self assert: (dict at: result) = value. 85103 85104 self should: [dict keyAtIdentityValue: self valueNotIn ] raise: Error 85105 85106 ! ! 85107 85108!DictionaryTest methodsFor: 'tests - dictionary key access'! 85109testKeyAtIdentityValueIfAbsent 85110 "self run: #testKeyAtValue" 85111 "self debug: #testKeyAtValue" 85112 85113 | dict value result | 85114 dict := self nonEmpty . 85115 value := dict values anyOne. 85116 85117 result := dict keyAtIdentityValue: value ifAbsent: [nil]. 85118 self assert: (dict at: result) = value. 85119 85120 self assert: (dict keyAtIdentityValue: self valueNotIn ifAbsent: [nil] ) = nil. 85121 ! ! 85122 85123!DictionaryTest methodsFor: 'tests - dictionary key access'! 85124testKeyAtValue 85125 "self run: #testKeyAtValue" 85126 "self debug: #testKeyAtValue" 85127 85128 | dict value result | 85129 dict := self nonEmpty . 85130 value := dict values anyOne. 85131 85132 result := dict keyAtValue: value. 85133 self assert: (dict at: result) = value. 85134 85135 self should: [dict keyAtValue: self valueNotIn ] raise: Error 85136 85137 ! ! 85138 85139!DictionaryTest methodsFor: 'tests - dictionary key access'! 85140testKeyAtValueIfAbsent 85141 "self run: #testKeyAtValue" 85142 "self debug: #testKeyAtValue" 85143 85144 | dict value result | 85145 dict := self nonEmpty . 85146 value := dict values anyOne. 85147 85148 result := dict keyAtValue: value ifAbsent: [nil]. 85149 self assert: (dict at: result) = value. 85150 85151 self assert: (dict keyAtValue: self valueNotIn ifAbsent: [nil] ) = nil. 85152 85153 ! ! 85154 85155 85156!DictionaryTest methodsFor: 'tests - dictionnary enumerating'! 85157testAssociationsDo 85158 85159 | collection keys | 85160 collection := self nonEmptyDict . 85161 85162 keys := OrderedCollection new. 85163 85164 collection associationsDo: [ :assoc | 85165 keys add: assoc key. 85166 self assert: ( collection at: assoc key ) = assoc value. 85167 ]. 85168 85169 collection keys do: [:key | self assert: ( keys occurrencesOf: key ) = (collection keys occurrencesOf: key)].! ! 85170 85171!DictionaryTest methodsFor: 'tests - dictionnary enumerating'! 85172testAssociationsSelect 85173 | collection keys result | 85174 collection := self nonEmptyDict . 85175 keys := OrderedCollection new. 85176 result := collection associationsSelect: [ :assoc | 85177 keys add: assoc key. 85178 true]. 85179 85180 collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)]. 85181 self assert: result = collection.! ! 85182 85183!DictionaryTest methodsFor: 'tests - dictionnary enumerating'! 85184testCollect 85185 | collection values result | 85186 collection := self nonEmptyDict . 85187 values := OrderedCollection new. 85188 result := collection collect: [ :value | 85189 values add: value. 85190 ]. 85191 85192 collection values do: [ :value | self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)]. 85193 self assert: result = collection.! ! 85194 85195!DictionaryTest methodsFor: 'tests - dictionnary enumerating'! 85196testDo 85197 | t collection | 85198 collection := self nonEmptyDict . 85199 t := OrderedCollection new. 85200 collection do: [: 85201 value | t add: value 85202 ]. 85203 85204 t do: [ :each | self assert: (t occurrencesOf: each ) = ( collection values occurrencesOf: each) ].! ! 85205 85206!DictionaryTest methodsFor: 'tests - dictionnary enumerating'! 85207testKeysAndValuesDo 85208 85209 85210 | collection keys | 85211 collection := self nonEmptyDict . 85212 keys := OrderedCollection new. 85213 collection keysAndValuesDo: [ :key :value | 85214 keys add: key. 85215 self assert: (collection at: key) = value ]. 85216 85217 collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)]! ! 85218 85219!DictionaryTest methodsFor: 'tests - dictionnary enumerating'! 85220testKeysDo 85221 | collection keys | 85222 collection := self nonEmptyDict . 85223 keys := OrderedCollection new. 85224 collection keysDo: [ :key | 85225 keys add: key. 85226 ]. 85227 85228 collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)]! ! 85229 85230!DictionaryTest methodsFor: 'tests - dictionnary enumerating'! 85231testReject 85232 "Ensure that Dictionary>>reject: answers a dictionary not something else" 85233 85234 | collection result | 85235 collection := self nonEmptyDict . 85236 result := collection reject: [ :each | false]. 85237 85238 self assert: result = collection. ! ! 85239 85240!DictionaryTest methodsFor: 'tests - dictionnary enumerating'! 85241testSelect 85242 | collection values result | 85243 collection := self nonEmptyDict . 85244 values := OrderedCollection new. 85245 result := collection select: [ :value | 85246 values add: value. 85247 true]. 85248 85249 collection values do: [ :value| self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)]. 85250 self assert: result = collection.! ! 85251 85252!DictionaryTest methodsFor: 'tests - dictionnary enumerating'! 85253testValuesDo 85254 | collection values | 85255 collection := self nonEmptyDict . 85256 values := OrderedCollection new. 85257 collection valuesDo: [ :value | 85258 values add: value. 85259 ]. 85260 85261 collection values do: [ :value | self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)]! ! 85262 85263 85264!DictionaryTest methodsFor: 'tests - fixture'! 85265test0CopyTest 85266 self shouldnt: [ self empty ]raise: Error. 85267 self assert: self empty size = 0. 85268 self shouldnt: [ self nonEmpty ]raise: Error. 85269 self assert: (self nonEmpty size = 0) not. 85270 self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. 85271 self assert: (self collectionWithElementsToRemove size = 0) not. 85272 self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. 85273 85274 self shouldnt: [ self elementToAdd ]raise: Error. 85275 self deny: (self nonEmpty includes: self elementToAdd ). 85276 self shouldnt: [ self collectionNotIncluded ]raise: Error. 85277 self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! 85278 85279!DictionaryTest methodsFor: 'tests - fixture'! 85280test0FixtureAsStringCommaAndDelimiterTest 85281 85282 self shouldnt: [self nonEmpty] raise:Error . 85283 self deny: self nonEmpty isEmpty. 85284 85285 self shouldnt: [self empty] raise:Error . 85286 self assert: self empty isEmpty. 85287 85288 self shouldnt: [self nonEmpty1Element ] raise:Error . 85289 self assert: self nonEmpty1Element size=1.! ! 85290 85291!DictionaryTest methodsFor: 'tests - fixture'! 85292test0FixtureCloneTest 85293 85294self shouldnt: [ self nonEmpty ] raise: Error. 85295self deny: self nonEmpty isEmpty. 85296 85297self shouldnt: [ self empty ] raise: Error. 85298self assert: self empty isEmpty. 85299 85300! ! 85301 85302!DictionaryTest methodsFor: 'tests - fixture'! 85303test0FixtureConverAsSortedTest 85304 85305 self shouldnt: [self collectionWithSortableElements ] raise: Error. 85306 self deny: self collectionWithSortableElements isEmpty .! ! 85307 85308!DictionaryTest methodsFor: 'tests - fixture'! 85309test0FixtureDictionaryAddingTest 85310 85311 85312self shouldnt: [ self nonEmptyDict ]raise: Error. 85313self deny: self nonEmptyDict isEmpty. 85314 85315self shouldnt: [ self associationWithKeyNotInToAdd ]raise: Error. 85316self deny: (self nonEmptyDict keys includes: self associationWithKeyNotInToAdd key ). 85317 85318self shouldnt: [ self associationWithKeyAlreadyInToAdd ]raise: Error. 85319self assert: (self nonEmptyDict keys includes: self associationWithKeyAlreadyInToAdd key ). 85320! ! 85321 85322!DictionaryTest methodsFor: 'tests - fixture'! 85323test0FixtureDictionaryAssocitionAccess 85324 85325self shouldnt: [self nonEmpty ] raise: Error. 85326self deny: self nonEmpty isEmpty. 85327 85328self shouldnt: [self keyNotIn ] raise: Error. 85329self deny: ( self nonEmpty keys includes: self keyNotIn ).! ! 85330 85331!DictionaryTest methodsFor: 'tests - fixture'! 85332test0FixtureDictionaryCopyingTest 85333 85334| duplicateKey | 85335self shouldnt: [ self nonEmptyDict ] raise: Error. 85336self deny: self nonEmptyDict isEmpty. 85337 85338self shouldnt: [ self nonEmptyDifferentFromNonEmptyDict ] raise: Error. 85339self deny: self nonEmptyDifferentFromNonEmptyDict isEmpty. 85340 85341duplicateKey := true. 85342self nonEmptyDict keys detect: [ :key | self nonEmptyDifferentFromNonEmptyDict includes: key ] ifNone: [ duplicateKey := false ] . 85343self assert: duplicateKey = false. 85344! ! 85345 85346!DictionaryTest methodsFor: 'tests - fixture'! 85347test0FixtureDictionaryElementAccess 85348 85349| in | 85350self shouldnt: [ self nonEmpty ] raise: Error. 85351self deny: self nonEmpty isEmpty. 85352 85353self shouldnt: [ self keyNotIn ] raise: Error. 85354in := true. 85355self nonEmpty keys detect: [ :key | key = self keyNotIn ] ifNone: [ in := false]. 85356self assert: in = false.! ! 85357 85358!DictionaryTest methodsFor: 'tests - fixture'! 85359test0FixtureDictionaryEnumeratingTest 85360 85361self shouldnt: [ self nonEmptyDict ] raise: Error. 85362self deny: self nonEmptyDict isEmpty.! ! 85363 85364!DictionaryTest methodsFor: 'tests - fixture'! 85365test0FixtureDictionaryIncludes 85366 | in | 85367 self shouldnt: [ self nonEmpty ]raise: Error. 85368 self deny: self nonEmpty isEmpty. 85369 85370 85371 self shouldnt: [ self valueNotInNonEmpty ] raise: Error. 85372 in := false. 85373 self nonEmpty valuesDo: [ :assoc | assoc = self valueNotInNonEmpty ifTrue: [ in := true ] ]. 85374 self assert: in = false. 85375 85376 85377 self shouldnt: [ self keyNotInNonEmpty ] raise: Error. 85378 in := false. 85379 self nonEmpty keysDo: [ :assoc | assoc = self keyNotInNonEmpty ifTrue: [ in := true ] ]. 85380 self assert: in = false! ! 85381 85382!DictionaryTest methodsFor: 'tests - fixture'! 85383test0FixtureDictionaryIncludesIdentity 85384 | | 85385 self shouldnt: [ self nonEmptyWithCopyNonIdentical ]raise: Error. 85386 self deny: self nonEmptyWithCopyNonIdentical isEmpty. 85387 85388 self nonEmptyWithCopyNonIdentical do: [ :each | self deny: each == each copy ]. 85389 85390 ! ! 85391 85392!DictionaryTest methodsFor: 'tests - fixture'! 85393test0FixtureDictionaryKeyAccess 85394 85395| collection equals | 85396self shouldnt: [ self nonEmptyWithoutEqualsValues ] raise: Error. 85397self deny: self nonEmptyWithoutEqualsValues isEmpty. 85398 85399equals := true. 85400collection := self nonEmptyWithoutEqualsValues values. 85401collection detect: [:each | (collection occurrencesOf: each) > 1 ] ifNone: [ equals := false]. 85402self assert: equals = false. 85403 85404self shouldnt: [ self valueNotIn ] raise: Error. 85405self deny: (self nonEmptyWithoutEqualsValues values includes: self valueNotIn )! ! 85406 85407!DictionaryTest methodsFor: 'tests - fixture'! 85408test0FixtureDictionaryKeysValuesAssociationsAccess 85409 85410 self shouldnt: [self nonEmpty ] raise: Error. 85411 self deny: self nonEmpty isEmpty .! ! 85412 85413!DictionaryTest methodsFor: 'tests - fixture'! 85414test0FixtureDictionaryRemovingTest 85415 85416self shouldnt: [self nonEmptyDict ] raise: Error. 85417self deny: self nonEmptyDict isEmpty. 85418 85419self shouldnt: [self keyNotInNonEmptyDict ] raise: Error. 85420self deny: (self nonEmptyDict keys includes: self keyNotInNonEmptyDict ).! ! 85421 85422!DictionaryTest methodsFor: 'tests - fixture'! 85423test0FixtureIncludeTest 85424 | elementIn | 85425 self shouldnt: [ self nonEmpty ]raise: Error. 85426 self deny: self nonEmpty isEmpty. 85427 85428 self shouldnt: [ self elementNotIn ]raise: Error. 85429 85430 elementIn := true. 85431 self nonEmpty detect: 85432 [ :each | each = self elementNotIn ] 85433 ifNone: [ elementIn := false ]. 85434 self assert: elementIn = false. 85435 85436 self shouldnt: [ self anotherElementNotIn ]raise: Error. 85437 85438 elementIn := true. 85439 self nonEmpty detect: 85440 [ :each | each = self anotherElementNotIn ] 85441 ifNone: [ elementIn := false ]. 85442 self assert: elementIn = false. 85443 85444 self shouldnt: [ self empty ] raise: Error. 85445 self assert: self empty isEmpty. 85446 85447! ! 85448 85449!DictionaryTest methodsFor: 'tests - fixture'! 85450test0FixtureOccurrencesForMultiplinessTest 85451 | cpt element collection | 85452 self shouldnt: [self collectionWithEqualElements ]raise: Error. 85453self shouldnt: [self collectionWithEqualElements ]raise: Error. 85454 85455self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 85456element := self elementTwiceInForOccurrences . 85457collection := self collectionWithEqualElements . 85458 85459cpt := 0 . 85460" testing with identity check ( == ) so that identy collections can use this trait : " 85461self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. 85462self assert: cpt = 2.! ! 85463 85464!DictionaryTest methodsFor: 'tests - fixture'! 85465test0FixtureOccurrencesTest 85466 | tmp | 85467 self shouldnt: [self empty ]raise: Error. 85468 self assert: self empty isEmpty. 85469 85470 self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. 85471 self deny: self collectionWithoutEqualElements isEmpty. 85472 85473 tmp := OrderedCollection new. 85474 self collectionWithoutEqualElements do: [ 85475 :each | 85476 self deny: (tmp includes: each). 85477 tmp add: each. 85478 ]. 85479 85480 85481 self shouldnt: [ self elementNotInForOccurrences ] raise: Error. 85482 self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! 85483 85484!DictionaryTest methodsFor: 'tests - fixture'! 85485test0FixturePrintTest 85486 85487 self shouldnt: [self nonEmpty ] raise: Error. 85488 self deny: self nonEmpty isEmpty.! ! 85489 85490!DictionaryTest methodsFor: 'tests - fixture'! 85491test0FixturePutTest 85492 self shouldnt: self aValue raise: Error. 85493 self shouldnt: self anotherValue raise: Error. 85494 85495 self shouldnt: self anIndex raise: Error. 85496 self nonEmpty isDictionary 85497 ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. 85498 85499 self shouldnt: self empty raise: Error. 85500 self assert: self empty isEmpty . 85501 85502 self shouldnt: self nonEmpty raise: Error. 85503 self deny: self nonEmpty isEmpty.! ! 85504 85505!DictionaryTest methodsFor: 'tests - fixture'! 85506test0FixtureSetAritmeticTest 85507 self 85508 shouldnt: [ self collection ] 85509 raise: Error. 85510 self deny: self collection isEmpty. 85511 self 85512 shouldnt: [ self nonEmpty ] 85513 raise: Error. 85514 self deny: self nonEmpty isEmpty. 85515 self 85516 shouldnt: [ self anotherElementOrAssociationNotIn ] 85517 raise: Error. 85518 self collection isDictionary 85519 ifTrue: 85520 [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] 85521 ifFalse: 85522 [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. 85523 self 85524 shouldnt: [ self collectionClass ] 85525 raise: Error! ! 85526 85527!DictionaryTest methodsFor: 'tests - fixture'! 85528test0FixtureTConvertTest 85529 "a collection of number without equal elements:" 85530 | res | 85531 self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. 85532 85533 res := true. 85534 self collectionWithoutEqualElements 85535 detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] 85536 ifNone: [ res := false ]. 85537 self assert: res = false. 85538 85539 85540! ! 85541 85542!DictionaryTest methodsFor: 'tests - fixture'! 85543test0TStructuralEqualityTest 85544 self shouldnt: [self empty] raise: Error. 85545 self shouldnt: [self nonEmpty] raise: Error. 85546 self assert: self empty isEmpty. 85547 self deny: self nonEmpty isEmpty.! ! 85548 85549 85550!DictionaryTest methodsFor: 'tests - includes'! 85551testIdentityIncludesNonSpecificComportement 85552 " test the same comportement than 'includes: ' " 85553 | collection | 85554 collection := self nonEmpty . 85555 85556 self deny: (collection identityIncludes: self elementNotIn ). 85557 self assert:(collection identityIncludes: collection anyOne) 85558! ! 85559 85560!DictionaryTest methodsFor: 'tests - includes'! 85561testIncludesAllOfAllThere 85562 "self debug: #testIncludesAllOfAllThere'" 85563 self assert: (self empty includesAllOf: self empty). 85564 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 85565 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 85566 85567!DictionaryTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 85568testIncludesAllOfNoneThere 85569 "self debug: #testIncludesAllOfNoneThere'" 85570 self deny: (self empty includesAllOf: self collection). 85571 self deny: (self nonEmpty includesAllOf: { 85572 (self elementNotIn). 85573 (self anotherElementNotIn) 85574 })! ! 85575 85576!DictionaryTest methodsFor: 'tests - includes'! 85577testIncludesAnyOfAllThere 85578 "self debug: #testIncludesAnyOfAllThere'" 85579 self deny: (self nonEmpty includesAnyOf: self empty). 85580 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 85581 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 85582 85583!DictionaryTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 85584testIncludesAnyOfNoneThere 85585 "self debug: #testIncludesAnyOfNoneThere'" 85586 self deny: (self nonEmpty includesAnyOf: self empty). 85587 self deny: (self nonEmpty includesAnyOf: { 85588 (self elementNotIn). 85589 (self anotherElementNotIn) 85590 })! ! 85591 85592!DictionaryTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 85593testIncludesElementIsNotThere 85594 "self debug: #testIncludesElementIsNotThere" 85595 self deny: (self nonEmpty includes: self elementNotInForOccurrences). 85596 self assert: (self nonEmpty includes: self nonEmpty anyOne). 85597 self deny: (self empty includes: self elementNotInForOccurrences)! ! 85598 85599!DictionaryTest methodsFor: 'tests - includes'! 85600testIncludesElementIsThere 85601 "self debug: #testIncludesElementIsThere" 85602 85603 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 85604 85605!DictionaryTest methodsFor: 'tests - includes' stamp: 'delaunay 4/9/2009 10:44'! 85606testIncludesSubstringAnywhere 85607 "self debug: #testIncludesSubstringAnywher'" 85608 self assert: (self empty includesAllOf: self empty). 85609 self assert: (self nonEmpty includesAllOf: { (self nonEmpty anyOne) }). 85610 self assert: (self nonEmpty includesAllOf: self nonEmpty)! ! 85611 85612 85613!DictionaryTest methodsFor: 'tests - occurrencesOf'! 85614testOccurrencesOfEmpty 85615 | result | 85616 result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). 85617 self assert: result = 0! ! 85618 85619!DictionaryTest methodsFor: 'tests - occurrencesOf'! 85620testOccurrencesOfNotIn 85621 | result | 85622 result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. 85623 self assert: result = 0! ! 85624 85625 85626!DictionaryTest methodsFor: 'tests - occurrencesOf for multipliness'! 85627testOccurrencesOfForMultipliness 85628 85629| collection element | 85630collection := self collectionWithEqualElements . 85631element := self elementTwiceInForOccurrences . 85632 85633self assert: (collection occurrencesOf: element ) = 2. ! ! 85634 85635 85636!DictionaryTest methodsFor: 'tests - printing'! 85637testPrintElementsOn 85638 85639 | aStream result allElementsAsString tmp | 85640 result:=''. 85641 aStream:= ReadWriteStream on: result. 85642 tmp:= OrderedCollection new. 85643 self nonEmpty do: [:each | tmp add: each asString]. 85644 85645 self nonEmpty printElementsOn: aStream . 85646 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 85647 1 to: allElementsAsString size do: 85648 [:i | 85649 self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)). 85650 ].! ! 85651 85652!DictionaryTest methodsFor: 'tests - printing'! 85653testPrintNameOn 85654 85655 | aStream result | 85656 result:=''. 85657 aStream:= ReadWriteStream on: result. 85658 85659 self nonEmpty printNameOn: aStream . 85660 Transcript show: result asString. 85661 self nonEmpty class name first isVowel 85662 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 85663 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 85664 85665!DictionaryTest methodsFor: 'tests - printing'! 85666testPrintOn 85667 | aStream result allElementsAsString tmp | 85668 result:=''. 85669 aStream:= ReadWriteStream on: result. 85670 tmp:= OrderedCollection new. 85671 self nonEmpty do: [:each | tmp add: each asString]. 85672 85673 self nonEmpty printOn: aStream . 85674 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 85675 1 to: allElementsAsString size do: 85676 [:i | 85677 i=1 85678 ifTrue:[ 85679 self accessCollection class name first isVowel 85680 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 85681 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 85682 i=2 85683 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 85684 i>2 85685 ifTrue:[self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)).]. 85686 ].! ! 85687 85688!DictionaryTest methodsFor: 'tests - printing'! 85689testPrintOnDelimiter 85690 | aStream result allElementsAsString tmp | 85691 result:=''. 85692 aStream:= ReadWriteStream on: result. 85693 tmp:= OrderedCollection new. 85694 self nonEmpty do: [:each | tmp add: each asString]. 85695 85696 85697 85698 self nonEmpty printOn: aStream delimiter: ', ' . 85699 85700 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 85701 1 to: allElementsAsString size do: 85702 [:i | 85703 self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)) 85704 ].! ! 85705 85706!DictionaryTest methodsFor: 'tests - printing'! 85707testPrintOnDelimiterLast 85708 85709 | aStream result allElementsAsString tmp | 85710 result:=''. 85711 aStream:= ReadWriteStream on: result. 85712 tmp:= OrderedCollection new. 85713 self nonEmpty do: [:each | tmp add: each asString]. 85714 85715 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 85716 85717 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 85718 1 to: allElementsAsString size do: 85719 [:i | 85720 i<(allElementsAsString size-1 ) 85721 ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. 85722 i=(allElementsAsString size-1) 85723 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 85724 i=(allElementsAsString size) 85725 ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. 85726 ].! ! 85727 85728!DictionaryTest methodsFor: 'tests - printing'! 85729testStoreOn 85730" for the moment work only for collection that include simple elements such that Integer" 85731 85732"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 85733string := ''. 85734str := ReadWriteStream on: string. 85735elementsAsStringExpected := OrderedCollection new. 85736elementsAsStringObtained := OrderedCollection new. 85737self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 85738 85739self nonEmpty storeOn: str. 85740result := str contents . 85741cuttedResult := ( result findBetweenSubStrs: ';' ). 85742 85743index := 1. 85744 85745cuttedResult do: 85746 [ :each | 85747 index = 1 85748 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 85749 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 85750 elementsAsStringObtained add: tmp. 85751 index := index + 1. ] 85752 ifFalse: [ 85753 index < cuttedResult size 85754 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 85755 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 85756 elementsAsStringObtained add: tmp. 85757 index := index + 1.] 85758 ifFalse: [self assert: ( each = ' yourself)' ) ]. 85759 ] 85760 85761 ]. 85762 85763 85764 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 85765 85766! ! 85767 85768 85769!DictionaryTest methodsFor: 'tests - set arithmetic'! 85770containsAll: union of: one andOf: another 85771 85772 self assert: (one allSatisfy: [:each | union includes: each]). 85773 self assert: (another allSatisfy: [:each | union includes: each])! ! 85774 85775!DictionaryTest methodsFor: 'tests - set arithmetic'! 85776numberOfSimilarElementsInIntersection 85777 ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! 85778 85779!DictionaryTest methodsFor: 'tests - set arithmetic'! 85780testDifference 85781 "Answer the set theoretic difference of two collections." 85782 "self debug: #testDifference" 85783 85784 self assert: (self collection difference: self collection) isEmpty. 85785 self assert: (self empty difference: self collection) isEmpty. 85786 self assert: (self collection difference: self empty) = self collection 85787! ! 85788 85789!DictionaryTest methodsFor: 'tests - set arithmetic'! 85790testDifferenceWithNonNullIntersection 85791 "Answer the set theoretic difference of two collections." 85792 "self debug: #testDifferenceWithNonNullIntersection" 85793 " #(1 2 3) difference: #(2 4) 85794 -> #(1 3)" 85795 | res overlapping | 85796 overlapping := self collectionClass 85797 with: self anotherElementOrAssociationNotIn 85798 with: self anotherElementOrAssociationIn. 85799 res := self collection difference: overlapping. 85800 self deny: (res includes: self anotherElementOrAssociationIn). 85801 overlapping do: [ :each | self deny: (res includes: each) ]! ! 85802 85803!DictionaryTest methodsFor: 'tests - set arithmetic'! 85804testDifferenceWithSeparateCollection 85805 "Answer the set theoretic difference of two collections." 85806 "self debug: #testDifferenceWithSeparateCollection" 85807 | res separateCol | 85808 separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. 85809 res := self collection difference: separateCol. 85810 self deny: (res includes: self anotherElementOrAssociationNotIn). 85811 self assert: res = self collection. 85812 res := separateCol difference: self collection. 85813 self deny: (res includes: self collection anyOne). 85814 self assert: res = separateCol! ! 85815 85816!DictionaryTest methodsFor: 'tests - set arithmetic'! 85817testIntersectionBasic 85818 "self debug: #testIntersectionBasic" 85819 | inter | 85820 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 85821 self deny: inter isEmpty. 85822 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 85823 85824!DictionaryTest methodsFor: 'tests - set arithmetic'! 85825testIntersectionEmpty 85826 "self debug: #testIntersectionEmpty" 85827 85828 | inter | 85829 inter := self empty intersection: self empty. 85830 self assert: inter isEmpty. 85831 inter := self empty intersection: self collection . 85832 self assert: inter = self empty. 85833 ! ! 85834 85835!DictionaryTest methodsFor: 'tests - set arithmetic'! 85836testIntersectionItself 85837 "self debug: #testIntersectionItself" 85838 85839 self assert: (self collection intersection: self collection) = self collection. 85840 ! ! 85841 85842!DictionaryTest methodsFor: 'tests - set arithmetic'! 85843testIntersectionTwoSimilarElementsInIntersection 85844 "self debug: #testIntersectionBasic" 85845 | inter | 85846 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 85847 self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. 85848 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 85849 85850!DictionaryTest methodsFor: 'tests - set arithmetic'! 85851testUnion 85852 "self debug: #testUnionOfEmpties" 85853 85854 | union | 85855 union := self empty union: self nonEmpty. 85856 self containsAll: union of: self empty andOf: self nonEmpty. 85857 union := self nonEmpty union: self empty. 85858 self containsAll: union of: self empty andOf: self nonEmpty. 85859 union := self collection union: self nonEmpty. 85860 self containsAll: union of: self collection andOf: self nonEmpty.! ! 85861 85862!DictionaryTest methodsFor: 'tests - set arithmetic'! 85863testUnionOfEmpties 85864 "self debug: #testUnionOfEmpties" 85865 85866 self assert: (self empty union: self empty) isEmpty. 85867 85868 ! ! 85869 85870 85871!DictionaryTest methodsFor: 'tests' stamp: 'nice 9/14/2009 21:07'! 85872testRemoveAll 85873 "Allows one to remove all elements of a collection" 85874 85875 | dict1 dict2 s2 | 85876 dict1 := Dictionary new. 85877 dict1 at: #a put:1 ; at: #b put: 2. 85878 dict2 := dict1 copy. 85879 s2 := dict2 size. 85880 85881 dict1 removeAll. 85882 85883 self assert: dict1 size = 0. 85884 self assert: dict2 size = s2 description: 'the copy has not been modified'.! ! 85885 85886"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 85887 85888DictionaryTest class 85889 uses: TIncludesTest classTrait + TDictionaryAddingTest classTrait + TDictionaryComparingTest classTrait + TDictionaryCopyingTest classTrait + TDictionaryEnumeratingTest classTrait + TDictionaryPrintingTest classTrait + TDictionaryRemovingTest classTrait + TPutBasicTest classTrait + TAsStringCommaAndDelimiterTest classTrait + TPrintTest classTrait + TConvertTest classTrait + TConvertAsSortedTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TDictionaryValueAccessTest classTrait + TDictionaryKeysValuesAssociationsAccess classTrait + TDictionaryKeyAccessTest classTrait + TDictionaryAssociationAccessTest classTrait + TDictionaryIncludesWithIdentityCheckTest classTrait + TStructuralEqualityTest classTrait + TOccurrencesForMultiplinessTest classTrait 85890 instanceVariableNames: 'testToto pt1'! 85891ProportionalSplitterMorph subclass: #DiffJoinMorph 85892 instanceVariableNames: 'srcOffset dstOffset mappings' 85893 classVariableNames: '' 85894 poolDictionaries: '' 85895 category: 'Polymorph-Tools-Diff'! 85896 85897!DiffJoinMorph methodsFor: 'accessing' stamp: 'gvc 10/24/2006 16:02'! 85898dstOffset 85899 "Answer the value of dstOffset" 85900 85901 ^ dstOffset! ! 85902 85903!DiffJoinMorph methodsFor: 'accessing' stamp: 'gvc 10/31/2006 11:33'! 85904dstOffset: anInteger 85905 "Set the dstOffset." 85906 85907 dstOffset := anInteger. 85908 self mappings do: [:j | 85909 j dstOffset: anInteger]! ! 85910 85911!DiffJoinMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 11:50'! 85912mappings 85913 "Answer the value of mappings" 85914 85915 ^ mappings! ! 85916 85917!DiffJoinMorph methodsFor: 'accessing' stamp: 'gvc 10/31/2006 13:19'! 85918mappings: anObject 85919 "Set the value of mappings" 85920 85921 mappings := anObject. 85922 self updateMappings. 85923 self changed! ! 85924 85925!DiffJoinMorph methodsFor: 'accessing' stamp: 'gvc 10/24/2006 16:02'! 85926srcOffset 85927 "Answer the value of srcOffset" 85928 85929 ^ srcOffset! ! 85930 85931!DiffJoinMorph methodsFor: 'accessing' stamp: 'gvc 10/31/2006 11:33'! 85932srcOffset: anInteger 85933 "Set the srcOffset." 85934 85935 srcOffset := anInteger. 85936 self mappings do: [:j | 85937 j srcOffset: anInteger]! ! 85938 85939 85940!DiffJoinMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:43'! 85941compositeText 85942 "Answer the composite text based on the selection state 85943 of the joins." 85944 85945 |t| 85946 t := Text new. 85947 self mappings do: [:j | 85948 j appendToCompositeText: t]. 85949 ^t! ! 85950 85951!DiffJoinMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/20/2006 14:21'! 85952defaultColor 85953 "Answer the default color for the receiver." 85954 85955 ^Color transparent! ! 85956 85957!DiffJoinMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 12:08'! 85958drawOn: aCanvas 85959 "Draw the indicators for the mappings." 85960 85961 super drawOn: aCanvas. 85962 aCanvas translateBy: self topLeft clippingTo: self clippingBounds during: [:c | 85963 self mappings do: [:j | j drawOn: c]]! ! 85964 85965!DiffJoinMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 13:18'! 85966extent: aPoint 85967 "Update the shapes of the joins." 85968 85969 super extent: aPoint. 85970 self updateMappings! ! 85971 85972!DiffJoinMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 11:44'! 85973initialize 85974 "Initialize the receiver." 85975 85976 super initialize. 85977 self 85978 mappings: OrderedCollection new; 85979 srcOffset: 0@0; 85980 dstOffset: 0@0! ! 85981 85982!DiffJoinMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 13:18'! 85983layoutBounds: aRectangle 85984 "Set the bounds for laying out children of the receiver." 85985 85986 super layoutBounds: aRectangle. 85987 self updateMappings! ! 85988 85989!DiffJoinMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 12:00'! 85990mouseDown: evt 85991 "Check for a click." 85992 85993 |cj| 85994 cj := self mappings 85995 detect: [:j | j containsPoint: evt position - self topLeft] 85996 ifNone: []. 85997 cj ifNotNil: [ 85998 cj clicked. 85999 self triggerEvent: #joinClicked]. 86000 super mouseDown: evt! ! 86001 86002!DiffJoinMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 13:18'! 86003updateMappings 86004 "Update the shapes of the joins." 86005 86006 self mappings do: [:j | 86007 j width: self width]! ! 86008BorderedMorph subclass: #DiffMapMorph 86009 instanceVariableNames: 'mappings' 86010 classVariableNames: '' 86011 poolDictionaries: '' 86012 category: 'Polymorph-Tools-Diff'! 86013 86014!DiffMapMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 15:11'! 86015adoptPaneColor: paneColor 86016 "Change our border color too." 86017 86018 |c| 86019 super adoptPaneColor: paneColor. 86020 paneColor ifNil: [^self]. 86021 c := paneColor alphaMixed: 0.1 with: Color white. 86022 self fillStyle: ((GradientFillStyle 86023 ramp: (self gradientRampForColor: c)) 86024 origin: self bounds topLeft; 86025 direction: 0@ self height). 86026 self borderStyle baseColor: paneColor! ! 86027 86028!DiffMapMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 14:10'! 86029defaultColor 86030 "Answer the default color for the receiver." 86031 86032 ^Color white! ! 86033 86034!DiffMapMorph methodsFor: 'accessing' stamp: 'gvc 3/21/2008 17:14'! 86035extent: newExtent 86036 "Update the gradient." 86037 86038 super extent: newExtent. 86039 (self fillStyle notNil and: [self fillStyle isOrientedFill]) 86040 ifTrue: [self fillStyle direction: 0@self height]! ! 86041 86042!DiffMapMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 15:12'! 86043gradientRampForColor: c 86044 "Answer the background gradient ramp to use." 86045 86046 ^{0.0->c darker duller. 0.1-> c lighter. 86047 0.9->c twiceLighter. 1.0->c darker}! ! 86048 86049!DiffMapMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 14:08'! 86050initialize 86051 "Initialize the receiver." 86052 86053 super initialize. 86054 self 86055 mappings: #()! ! 86056 86057!DiffMapMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 13:57'! 86058mappings 86059 "Answer the value of mappings" 86060 86061 ^ mappings! ! 86062 86063!DiffMapMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 14:15'! 86064mappings: anObject 86065 "Set the value of mappings" 86066 86067 mappings := anObject. 86068 self changed! ! 86069 86070 86071!DiffMapMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 10:51'! 86072mappingsHeight 86073 "Answer the maximum y of all the mappings." 86074 86075 self mappings ifEmpty: [^0]. 86076 ^self mappings last dst range last ! ! 86077 86078 86079!DiffMapMorph methodsFor: 'nil' stamp: 'gvc 10/26/2006 15:05'! 86080drawOn: aCanvas 86081 "Draw the indicators for the mappings." 86082 86083 |b f| 86084 b := self innerBounds insetBy: 2. 86085 super drawOn: aCanvas. 86086 b height < 1 ifTrue: [^self]. 86087 f := self mappingsHeight. 86088 f < 1 ifTrue: [^self]. 86089 f := b height / f. 86090 aCanvas clipBy: self clippingBounds during: [:c | 86091 self mappings do: [:j | 86092 j drawMapOn: c in: b scale: f]]! ! 86093ComposableMorph subclass: #DiffMorph 86094 instanceVariableNames: 'srcText dstText prettyPrint contextClass srcMorph dstMorph scrollbarMorph mapMorph joinMorph difference joinMappings' 86095 classVariableNames: '' 86096 poolDictionaries: '' 86097 category: 'Polymorph-Tools-Diff'! 86098 86099!DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:38'! 86100contextClass 86101 "Answer the value of contextClass" 86102 86103 ^ contextClass! ! 86104 86105!DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:38'! 86106contextClass: anObject 86107 "Set the value of contextClass" 86108 86109 contextClass := anObject! ! 86110 86111!DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 11:27'! 86112difference 86113 "Answer the value of difference" 86114 86115 ^ difference! ! 86116 86117!DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 11:27'! 86118difference: anObject 86119 "Set the value of difference" 86120 86121 difference := anObject! ! 86122 86123!DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! 86124dstMorph 86125 "Answer the value of dstMorph" 86126 86127 ^ dstMorph! ! 86128 86129!DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! 86130dstMorph: anObject 86131 "Set the value of dstMorph" 86132 86133 dstMorph := anObject! ! 86134 86135!DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! 86136dstText 86137 "Answer the value of dstText" 86138 86139 ^ dstText! ! 86140 86141!DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! 86142dstText: anObject 86143 "Set the value of dstText" 86144 86145 dstText := anObject! ! 86146 86147!DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/24/2006 15:55'! 86148joinMappings 86149 "Answer the join parameters between src and dst." 86150 86151 ^joinMappings ifNil: [self calculateJoinMappings]! ! 86152 86153!DiffMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2009 13:42'! 86154joinMappings: aCollection 86155 "Set the join parameters between src and dst." 86156 86157 joinMappings := aCollection! ! 86158 86159!DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! 86160joinMorph 86161 "Answer the value of joinMorph" 86162 86163 ^ joinMorph! ! 86164 86165!DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! 86166joinMorph: anObject 86167 "Set the value of joinMorph" 86168 86169 joinMorph := anObject! ! 86170 86171!DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! 86172mapMorph 86173 "Answer the value of mapMorph" 86174 86175 ^ mapMorph! ! 86176 86177!DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! 86178mapMorph: anObject 86179 "Set the value of mapMorph" 86180 86181 mapMorph := anObject! ! 86182 86183!DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! 86184prettyPrint 86185 "Answer the value of prettyPrint" 86186 86187 ^ prettyPrint! ! 86188 86189!DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:22'! 86190prettyPrint: aBoolean 86191 "Set the value of prettyPrint" 86192 86193 prettyPrint == aBoolean ifTrue: [^self]. 86194 prettyPrint := aBoolean. 86195 self updateText 86196 ! ! 86197 86198!DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/23/2006 15:47'! 86199scrollbarMorph 86200 "Answer the value of scrollbarMorph" 86201 86202 ^ scrollbarMorph! ! 86203 86204!DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/23/2006 15:47'! 86205scrollbarMorph: anObject 86206 "Set the value of scrollbarMorph" 86207 86208 scrollbarMorph := anObject! ! 86209 86210!DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! 86211srcMorph 86212 "Answer the value of srcMorph" 86213 86214 ^ srcMorph! ! 86215 86216!DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! 86217srcMorph: anObject 86218 "Set the value of srcMorph" 86219 86220 srcMorph := anObject! ! 86221 86222!DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! 86223srcText 86224 "Answer the value of srcText" 86225 86226 ^ srcText! ! 86227 86228!DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! 86229srcText: anObject 86230 "Set the value of srcText" 86231 86232 srcText := anObject! ! 86233 86234 86235!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 12:34'! 86236additionColor 86237 "Answer the color used to show additions." 86238 86239 ^Color paleGreen alpha: 0.5! ! 86240 86241!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/29/2006 18:23'! 86242adoptPaneColor: paneColor 86243 "Change our border color too." 86244 86245 super adoptPaneColor: paneColor. 86246 paneColor ifNil: [^self]. 86247 self borderStyle baseColor: paneColor! ! 86248 86249!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 10:52'! 86250applyHighlights 86251 "Apply the relevant highlights to src and dst." 86252 86253 self srcMorph highlights: (self joinMappings gather: [:j | j src highlights]). 86254 self dstMorph highlights: (self joinMappings gather: [:j | j dst highlights])! ! 86255 86256!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 11:11'! 86257applyJoin 86258 "Apply the join mappings to the join morph." 86259 86260 self joinMorph mappings: self joinMappings! ! 86261 86262!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 14:11'! 86263applyMap 86264 "Apply the join mappings to the map morph." 86265 86266 self mapMorph mappings: self joinMappings! ! 86267 86268!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/20/2006 13:11'! 86269calculateDifference 86270 "Calculate the difference of the src and dst." 86271 86272 self difference: ((TextDiffBuilder 86273 from: self oldText asString to: self newText asString) 86274 buildPatchSequence)! ! 86275 86276!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 15:56'! 86277calculateJoinMappings 86278 "Calculate the join parameters between src and dst 86279 and store in joinMappings." 86280 86281 self joinMappings: self calculatedJoinMappings! ! 86282 86283!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 11:51'! 86284calculatedJoinMappings 86285 "Calculate the join parameters between src and dst 86286 and answer. 86287 sl = src line, dl = dst line, j = joins, ds = dst run start, ss = src run start 86288 de = dst run end, se = dst run end, mds = match dst start, mss = match src start" 86289 86290 |sl dl j ds ss de se mds mss| 86291 sl := dl := 0. 86292 j := OrderedCollection new. 86293 ds := de:= ss := se := mss := mds := 0. 86294 self difference do: [:p | 86295 p key = #match ifTrue: [ 86296 sl := sl + 1. 86297 dl := dl + 1. 86298 mss = 0 ifTrue: [mss := sl. mds := dl]. 86299 (ds > 0 or: [ss > 0]) ifTrue: [ 86300 ss = 0 ifTrue: [ss := sl]. 86301 ds = 0 ifTrue: [ds := dl]. 86302 se = 0 ifTrue: [se := ss - 1]. 86303 de = 0 ifTrue: [de := ds - 1]. 86304 j add: (self newJoinSectionFrom: (ss to: se) to: (ds to: de)). 86305 ds := de := ss := se := 0]]. 86306 p key = #remove ifTrue: [ 86307 mss > 0 ifTrue: [ 86308 j add: (self newMatchJoinSectionFrom: (mss to: sl) to: (mds to: dl)). 86309 mss := mds := 0]. 86310 sl := sl + 1. 86311 ss = 0 ifTrue: [ss := sl]. 86312 se := sl]. 86313 p key = #insert ifTrue: [ 86314 mss > 0 ifTrue: [ 86315 j add: (self newMatchJoinSectionFrom: (mss to: sl) to: (mds to: dl)). 86316 mss := mds := 0]. 86317 dl := dl + 1. 86318 ss > 0 ifTrue: [ 86319 se = 0 ifTrue: [se := ss]. 86320 de = 0 ifTrue: [de := ds]. 86321 j add: (self newJoinSectionFrom: (ss to: se) to: (ds to: de)). 86322 ds := de := ss := se := 0]. 86323 ds = 0 ifTrue: [ds := dl]. 86324 de := dl]]. 86325 sl := sl + 1. 86326 dl := dl + 1. 86327 (ds > 0 or: [ss > 0]) ifTrue: [ 86328 ss = 0 ifTrue: [ss := sl ]. 86329 ds = 0 ifTrue: [ds := dl]. 86330 se = 0 ifTrue: [se := ss - 1]. 86331 de = 0 ifTrue: [de := ds - 1]. 86332 j add: (self newJoinSectionFrom: (ss to: se) to: (ds to: de))]. 86333 mss > 0 ifTrue: [ 86334 j add: (self newMatchJoinSectionFrom: (mss to: sl - 1) to: (mds to: dl - 1))]. 86335 ^j! ! 86336 86337!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/23/2006 16:29'! 86338calibrateScrollbar 86339 "Set the scrollbar parameters to match the texts." 86340 86341 |maxY range delta innerH| 86342 self fullBounds. 86343 maxY := self srcMorph textExtent y max: self dstMorph textExtent y. 86344 innerH := self dstMorph innerBounds height. 86345 delta := self dstMorph textMorph defaultLineHeight. 86346 range := maxY - innerH max: 0. 86347 range = 0 ifTrue: [^self scrollbarMorph scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; setValue: 0.0]. 86348 self scrollbarMorph 86349 scrollDelta: (delta / range) asFloat 86350 pageDelta: ((innerH - delta) / range) asFloat; 86351 interval: (innerH / maxY) asFloat; 86352 setValue: ((self srcMorph scroller offset y max: self dstMorph scroller offset y) 86353 / range min: 1.0) asFloat! ! 86354 86355!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 14:29'! 86356colorForType: type 86357 "Anwser the color to use for the given change type." 86358 86359 ^{self matchColor. self additionColor. self removalColor. self modificationColor} 86360 at: (#(match addition removal modification) indexOf: type)! ! 86361 86362!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 14:10'! 86363defaultColor 86364 "Answer the default color for the receiver." 86365 86366 ^Color white! ! 86367 86368!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 11:04'! 86369defaultTitle 86370 "Answer the default title label for the receiver." 86371 86372 ^'Diff' translated! ! 86373 86374!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:22'! 86375dstScroll: scrollValue 86376 "Called from dst when scrolled by keyboard etc." 86377 86378 self scrollbarMorph value: scrollValue. 86379 self srcMorph vScrollBarValue: scrollValue. 86380 self updateJoinOffsets! ! 86381 86382!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 12:35'! 86383edgeColor 86384 "Answer the color used to show the border of the changes." 86385 86386 ^Color gray alpha: 0.5! ! 86387 86388!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/23/2006 16:27'! 86389extent: newExtent 86390 "Update the scrollbar." 86391 86392 super extent: newExtent. 86393 self calibrateScrollbar! ! 86394 86395!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 13:23'! 86396font: aFont 86397 "Set the font on the src and dst morphs." 86398 86399 self srcMorph font: aFont. 86400 self dstMorph font: aFont! ! 86401 86402!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2008 15:24'! 86403from: old to: new 86404 "Set the old (src) and new (dst) text." 86405 86406 self 86407 srcText: old; 86408 dstText: new. 86409 self 86410 setText; 86411 calculateDifference; 86412 calculateJoinMappings; 86413 calibrateScrollbar; 86414 applyHighlights; 86415 applyJoin; 86416 applyMap! ! 86417 86418!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2008 15:45'! 86419from: old to: new contextClass: aClass 86420 "Set the old (src) and new (dst) text." 86421 86422 self 86423 contextClass: aClass; 86424 srcText: old; 86425 dstText: new. 86426 self 86427 setText; 86428 calculateDifference; 86429 calculateJoinMappings; 86430 calibrateScrollbar; 86431 applyHighlights; 86432 applyJoin; 86433 applyMap! ! 86434 86435!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/23/2006 16:12'! 86436hideOrShowScrollBar 86437 "Do nothing" 86438 ! ! 86439 86440!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 17:55'! 86441join: aJoin selected: aBoolean 86442 "Set the selection for the given join and update the 86443 src dst and join morphs." 86444 86445 aJoin selected: aBoolean. 86446 self srcMorph changed. 86447 self joinMorph changed. 86448 self dstMorph changed! ! 86449 86450!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 12:08'! 86451joinColor 86452 "Answer the color used for the join bar." 86453 86454 ^Color paleBlue duller! ! 86455 86456!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:12'! 86457joinSectionClass 86458 "Answer the class to use for a new join section." 86459 86460 ^JoinSection! ! 86461 86462!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 14:29'! 86463matchColor 86464 "Answer the color used to show matches." 86465 86466 ^Color transparent! ! 86467 86468!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 12:34'! 86469modificationColor 86470 "Answer the color used to show changes." 86471 86472 ^Color paleYellow alpha: 0.5! ! 86473 86474!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 13:52'! 86475newDstMorph 86476 "Answer a new dst text morph." 86477 86478 ^self newSrcMorph! ! 86479 86480!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 12:54'! 86481newHighlight 86482 "Anewser a new highlight." 86483 86484 ^TextHighlight new 86485 color: self modificationColor; 86486 borderWidth: 1; 86487 borderColor: self edgeColor! ! 86488 86489!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 13:39'! 86490newHighlight: type 86491 "Anewser a new highlight." 86492 86493 ^TextHighlight new 86494 color: (self colorForType: type); 86495 borderWidth: 1; 86496 borderColor: self edgeColor; 86497 fillWidth: true! ! 86498 86499!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:15'! 86500newJoinMorph 86501 "Answer a new join morph." 86502 86503 ^DiffJoinMorph new 86504 hResizing: #shrinkWrap; 86505 vResizing: #spaceFill; 86506 extent: 30@4; 86507 minWidth: 30; 86508 color: self joinColor! ! 86509 86510!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:11'! 86511newJoinSection 86512 "Answer a new join section." 86513 86514 ^self joinSectionClass new 86515 srcColor: self modificationColor; 86516 dstColor: self modificationColor; 86517 borderWidth: 1; 86518 borderColor: self edgeColor; 86519 addDependent: self; 86520 yourself! ! 86521 86522!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 14:08'! 86523newJoinSectionFrom: srcRange to: dstRange 86524 "Answer a new join section." 86525 86526 |spl dpl sy1 sy2 dy1 dy2 t c| 86527 spl := self srcMorph textMorph paragraph lines. 86528 dpl := self dstMorph textMorph paragraph lines. 86529 t := #modification. 86530 sy1 := srcRange first > spl size 86531 ifTrue: [t := #addition. 86532 spl last bottom truncated - 1] 86533 ifFalse: [(spl at: srcRange first) top truncated - 1]. 86534 sy2 := srcRange size < 1 86535 ifTrue: [t := #addition. 86536 sy1 + 3] 86537 ifFalse: [srcRange last > spl size 86538 ifTrue: [spl last bottom truncated + 3] 86539 ifFalse: [(spl at: srcRange last) bottom truncated - 1]]. 86540 dy1 := dstRange first > dpl size 86541 ifTrue: [t := #removal. 86542 dpl last bottom truncated - 1] 86543 ifFalse: [(dpl at: dstRange first) top truncated - 1]. 86544 dy2 := dstRange size < 1 86545 ifTrue: [t := #removal. 86546 dy1 + 3] 86547 ifFalse: [dstRange last > dpl size 86548 ifTrue: [dpl last bottom truncated + 3] 86549 ifFalse: [(dpl at: dstRange last) bottom truncated - 1]]. 86550 c := self colorForType: t. 86551 ^self newJoinSection 86552 type: t; 86553 srcColor: c; 86554 dstColor: c; 86555 srcLineRange: srcRange; 86556 dstLineRange: dstRange; 86557 srcRange: (sy1 to: sy2); 86558 dstRange: (dy1 to: dy2); 86559 createHighlightsFrom: self srcMorph textMorph paragraph 86560 to: self dstMorph textMorph paragraph! ! 86561 86562!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 14:16'! 86563newMapMorph 86564 "Answer a new map morph." 86565 86566 ^DiffMapMorph new 86567 hResizing: #shrinkWrap; 86568 vResizing: #spaceFill; 86569 extent: 20@4; 86570 minWidth: 20; 86571 borderStyle: (BorderStyle inset width: 1)! ! 86572 86573!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 11:07'! 86574newMatchJoinSectionFrom: srcRange to: dstRange 86575 "Answer a new match join section." 86576 86577 |spl dpl sy1 sy2 dy1 dy2 c| 86578 spl := self srcMorph textMorph paragraph lines. 86579 dpl := self dstMorph textMorph paragraph lines. 86580 sy1 := (spl at: srcRange first) top truncated. 86581 sy2 := (spl at: srcRange last) bottom truncated. 86582 dy1 := (dpl at: dstRange first) top truncated. 86583 dy2 := (dpl at: dstRange last) bottom truncated. 86584 c := self colorForType: #match. 86585 ^self newJoinSection 86586 type: #match; 86587 borderWidth: 0; 86588 srcColor: c; 86589 dstColor: c; 86590 srcLineRange: srcRange; 86591 dstLineRange: dstRange; 86592 srcRange: (sy1 to: sy2); 86593 dstRange: (dy1 to: dy2); 86594 createHighlightsFrom: self srcMorph textMorph paragraph 86595 to: self dstMorph textMorph paragraph! ! 86596 86597!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2008 15:56'! 86598newPrettyPrintCheckboxMorph 86599 "Answer a new checkbox for specifying whether to use 86600 pretty printing for the diff texts." 86601 86602 ^self 86603 newCheckboxFor: self 86604 getSelected: #prettyPrint 86605 setSelected: #prettyPrint: 86606 getEnabled: nil 86607 label: 'Pretty print' translated 86608 help: 'If selected, pretty print will be applied to any displayed method source (eliminates trivial formatting changes)' translated! ! 86609 86610!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/1/2008 11:48'! 86611newScrollbarMorph 86612 "Answer a new scrollbar morph." 86613 86614 ^ScrollBar new 86615 model: self; 86616 setValueSelector: #vScroll:; 86617 vResizing: #spaceFill; 86618 width: self theme scrollbarThickness! ! 86619 86620!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 13:52'! 86621newSrcMorph 86622 "Answer a new src text morph." 86623 86624 ^(self newTextEditorFor: nil 86625 getText: nil 86626 setText: nil 86627 getEnabled: nil) 86628 hideVScrollBarIndefinitely: true; 86629 borderWidth: 0; 86630 enabled: false; 86631 wrapFlag: false; 86632 selectionColor: self textSelectionColor; 86633 setText: ''! ! 86634 86635!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/20/2006 11:26'! 86636newText 86637 "Answer the new (dst) text." 86638 86639 ^self dstMorph text! ! 86640 86641!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/20/2006 11:26'! 86642oldText 86643 "Answer the old (src) text." 86644 86645 ^self srcMorph text! ! 86646 86647!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 12:34'! 86648removalColor 86649 "Answer the color used to show removals." 86650 86651 ^Color paleRed alpha: 0.5! ! 86652 86653!DiffMorph methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/18/2009 15:54'! 86654setText 86655 "Set the src and dst text in the morphs applying 86656 prettyPrint if required." 86657 86658 |src dst ctx| 86659 src := self srcText. 86660 dst := self dstText. 86661 ctx := self contextClass. 86662 (self prettyPrint and: [ctx notNil]) 86663 ifTrue: [src isEmpty ifFalse: [ 86664 src := ctx prettyPrinterClass 86665 format: src 86666 in: ctx 86667 notifying: nil]. 86668 dst isEmpty ifFalse: [ 86669 dst := ctx prettyPrinterClass 86670 format: dst 86671 in: ctx 86672 notifying: nil]]. 86673 self srcMorph setText: src; font: self theme textFont. 86674 self dstMorph setText: dst; font: self theme textFont! ! 86675 86676!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:22'! 86677srcScroll: scrollValue 86678 "Called from src when scrolled by keyboard etc.." 86679 86680 self scrollbarMorph value: scrollValue. 86681 self dstMorph vScrollBarValue: scrollValue. 86682 self updateJoinOffsets! ! 86683 86684!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 16:11'! 86685textSelectionColor 86686 "Answer the color used for thew text selection." 86687 86688 ^Preferences textHighlightColor alpha: 0.5! ! 86689 86690!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/1/2008 12:27'! 86691themeChanged 86692 "Update the scrollbar width/frame." 86693 86694 |offset| 86695 super themeChanged. 86696 self scrollbarMorph width: self theme scrollbarThickness. 86697 offset := self scrollbarMorph width negated - self mapMorph width. 86698 self scrollbarMorph layoutFrame leftOffset: offset. 86699 self dstMorph layoutFrame rightOffset: offset! ! 86700 86701!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 16:09'! 86702updateJoinOffsets 86703 "Update the src and dst offsets in the join morph 86704 to match the src and dst tex scroll offsets." 86705 86706 self joinMorph 86707 srcOffset: 0 @ self srcMorph scroller offset y negated; 86708 dstOffset: 0 @ self dstMorph scroller offset y negated; 86709 changed! ! 86710 86711!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2008 15:23'! 86712updateText 86713 "Reset the text if we have some." 86714 86715 (self srcText notNil and: [self dstText notNil]) ifTrue: [ 86716 self from: self srcText to: self dstText]! ! 86717 86718!DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:22'! 86719vScroll: scrollValue 86720 "Called from standalone scroolbar. 86721 Scroll the srcMorph and redo the join." 86722 86723 self srcMorph vScrollBarValue: scrollValue. 86724 self dstMorph vScrollBarValue: scrollValue. 86725 self updateJoinOffsets! ! 86726 86727 86728!DiffMorph methodsFor: 'initialization' stamp: 'gvc 9/2/2008 16:21'! 86729initialize 86730 "Initialize the receiver." 86731 86732 |exv exh opts ppCheckbox| 86733 super initialize. 86734 self prettyPrint: Preferences diffsWithPrettyPrint. 86735 ppCheckbox := self newPrettyPrintCheckboxMorph. 86736 opts := self newPanel 86737 addMorph: ((self newRow: {ppCheckbox}) 86738 listCentering: #bottomRight). 86739 opts vResizing: #shrinkWrap. 86740 opts extent: opts minExtent. 86741 self 86742 srcMorph: self newSrcMorph; 86743 joinMorph: self newJoinMorph; 86744 dstMorph: self newDstMorph; 86745 scrollbarMorph: self newScrollbarMorph; 86746 mapMorph: self newMapMorph; 86747 changeProportionalLayout; 86748 addMorph: self srcMorph fullFrame: (LayoutFrame 86749 fractions: (0@0 corner: 0.5@1) offsets: (0@0 corner: self joinMorph width negated@opts height negated)); 86750 addMorph: self joinMorph fullFrame: (LayoutFrame 86751 fractions: (0.5@0 corner: 0.5@1) offsets: (self joinMorph width negated@0 corner: 0@opts height negated)); 86752 addMorph: self dstMorph fullFrame: (LayoutFrame 86753 fractions: (0.5@0 corner: 1@1) offsets: (0@0 corner: self scrollbarMorph width negated - self mapMorph width@opts height negated)); 86754 addMorph: self scrollbarMorph fullFrame: (LayoutFrame 86755 fractions: (1@0 corner: 1@1) offsets: (self scrollbarMorph width negated - self mapMorph width@0 corner: self mapMorph width negated@opts height negated)); 86756 addMorph: self mapMorph fullFrame: (LayoutFrame 86757 fractions: (1@0 corner: 1@1) offsets: (self mapMorph width negated@0 corner: 0@opts height negated)); 86758 addMorph: opts fullFrame: (LayoutFrame 86759 fractions: (0@1 corner: 1@1) offsets: (0@opts height negated corner: 0@0)). 86760 exv := ExclusiveWeakMessageSend newSharedState. 86761 exh := ExclusiveWeakMessageSend newSharedState. 86762 self srcMorph 86763 when: #vScroll send: #srcScroll: to: self exclusive: exv; 86764 when: #hScroll send: #hScrollValue: to: self dstMorph exclusive: exh. 86765 self dstMorph 86766 when: #vScroll send: #dstScroll: to: self exclusive: exv; 86767 when: #hScroll send: #hScrollValue: to: self srcMorph exclusive: exh. 86768 self 86769 linkSubmorphsToSplitters; 86770 extent: self initialExtent! ! 86771 86772"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 86773 86774DiffMorph class 86775 instanceVariableNames: ''! 86776 86777!DiffMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 10/20/2006 11:26'! 86778from: old to: new 86779 "Answer a new instance of the receiver with the given 86780 old and new text." 86781 86782 ^self new 86783 from: old 86784 to: new! ! 86785 86786!DiffMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2008 15:46'! 86787from: old to: new contextClass: aClass 86788 "Answer a new instance of the receiver with the given 86789 old and new text." 86790 86791 ^self new 86792 from: old 86793 to: new 86794 contextClass: aClass! ! 86795Object subclass: #DigitalSignatureAlgorithm 86796 instanceVariableNames: 'randKey randSeed' 86797 classVariableNames: 'HighBitOfByte SmallPrimes' 86798 poolDictionaries: '' 86799 category: 'System-Digital Signatures'! 86800!DigitalSignatureAlgorithm commentStamp: '<historical>' prior: 0! 86801This class implements the Digital Signature Algorithm (DSA) of the U.S. government's "Digital Signature Standard" (DSS). The DSA algorithm was proposed in 1991 and became a standard in May 1994. The official description is available as a Federal Information Processing Standards Publication (FIPS PUB 186, May 19, 1994). A companion standard, the Secure Hash Standard, or SHS (FIPS PUB 180-1, April 17, 1995), describes a 160-bit message digest algorithm known as the Secure Hash Algorithm (SHA). This message digest is used to compute the document signature. 86802 86803Here's how to use it: 86804 86805 1. The "signer" creates a pair of keys. One of these must be kept private. The other may be freely distributed. For example, it could be built into the signature checking code of an application. 86806 86807 2. When the signer wishes to sign a packet of data (a "message") , he uses the secure hash algorithm to create a 160-bit message digest (hash) which is used as the input to DSA. The result of this is a pair of large numbers called a "signature" that is attached to the original message. 86808 86809 3. When someone receives a signed message purported to have come from the signer, they compute the 160-bit hash of the message and pass that, along with the message signature and the signer's public key, to the signature verification algorithm. If the signature checks, then it is virtually guaranteed that the message originated from someone who had the signer's private key. That is, the message is not a forgery and has not been modified since it was signed. For example, if the message contains a program, and the recipient trusts the signer, then the recipient can run the program with the assurance that it won't do anything harmful. (At least, not intentionally. A digital signature is no guarantee against bugs!! :->) 86810 86811The signer must keep the private key secure, since anyone who has the private key can forge the signer's signature on any message they like. As long as the secret key is not stolen, cryptographers believe it to be virtually impossible either to forge a signature, to find a message that matches an existing sigature, or to discover the signer's private key by analyzing message signatures. Knowing the public key (which, for example, could be recovered from an application that had it built in), does not weaken the security at all. 86812 86813An excellent reference work on digital signatures and cryptography in general is: 86814 86815 Schneier, Bruce 86816 "Applied Cryptography: Protocols, Algorithms, and Source Code in C" 86817 John Wiley and Sons, 1996. 86818 86819I used this book as a guide to implementing many of the numerical algorithms required by DSA. 86820 86821Patents and Export Restrictions: 86822 86823Many digital signature technologies are patented. DSA is also patented, but the patent is owned by the U.S. government which has made DSA available royalty-free. There is a claim that the government patent infringes on an earlier patent by Schnorr, but the government is requiring the use of DSA, so they apparently believe this claim is not strong enough to be a serious threat to their own patent. 86824 86825Most cryptography technology, including digital signature technology, requires an export license for it to be distributed outside the U.S. Recent legislation may have relaxed the export license requirements, but it would be prudent to check the current regulations before exporting this code.! 86826 86827 86828!DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'jm 1/11/2000 00:25'! 86829initRandom: randomInteger 86830 "Initialize the the secure random number generator with the given value. The argument should be a positive integer of up to 512 bits chosen randomly to avoid someone being able to predict the sequence of random values generated." 86831 "Note: The random generator must be initialized before generating a key set or signature. Signature verification does not require initialization of the random generator." 86832 86833 randSeed := 16rEFCDAB8998BADCFE10325476C3D2E1F067452301. "initial seed" 86834 randKey := randomInteger. 86835 Transcript show: 'Random seed: ', randomInteger printString; cr. 86836! ! 86837 86838!DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'ar 2/1/2001 20:18'! 86839initRandomFromString: aString 86840 "Ask the user to type a long random string and use the result to seed the secure random number generator." 86841 86842 | s k srcIndex | 86843 s := aString. 86844 k := LargePositiveInteger new: (s size min: 64). 86845 srcIndex := 0. 86846 k digitLength to: 1 by: -1 do: [:i | 86847 k digitAt: i put: (s at: (srcIndex := srcIndex + 1)) asciiValue]. 86848 k := k + (Random new next * 16r7FFFFFFF) asInteger. "a few additional bits randomness" 86849 k highBit > 512 ifTrue: [k := k bitShift: k highBit - 512]. 86850 self initRandom: k. 86851! ! 86852 86853!DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'DamienCassou 9/23/2009 08:37'! 86854initRandomFromUser 86855 "Ask the user to type a long random string and use the result to seed the secure random number generator." 86856 86857 | s k srcIndex | 86858 s := UIManager default request: 'Enter a long random string to seed the random generator.'. 86859 s isNil ifTrue: [s := '']. 86860 k := LargePositiveInteger new: (s size min: 64). 86861 srcIndex := 0. 86862 k digitLength to: 1 by: -1 do: [:i | 86863 k digitAt: i put: (s at: (srcIndex := srcIndex + 1)) asciiValue]. 86864 k := k + (Random new next * 16r7FFFFFFF) asInteger. "a few additional bits randomness" 86865 k highBit > 512 ifTrue: [k := k bitShift: k highBit - 512]. 86866 self initRandom: k. 86867! ! 86868 86869!DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'gk 2/26/2004 09:52'! 86870initRandomNonInteractively 86871 [self initRandom: (SoundService default randomBitsFromSoundInput: 512)] 86872 ifError: [self initRandomFromString: 86873 Time millisecondClockValue printString, 86874 Date today printString, 86875 SmalltalkImage current platformName printString].! ! 86876 86877 86878!DigitalSignatureAlgorithm methodsFor: 'large integer arithmetic' stamp: 'jm 12/9/1999 21:49'! 86879inverseOf: x mod: n 86880 "Answer the inverse of x modulus n. That is, the integer y such that (x * y) \\ n is 1. Both x and n must be positive, and it is assumed that x < n and that x and n are integers." 86881 "Details: Use the extended Euclidean algorithm, Schneier, p. 247." 86882 86883 | v u k u1 u2 u3 t1 t2 t3 tmp | 86884 ((x <= 0) or: [n <= 0]) ifTrue: [self error: 'x and n must be greater than zero']. 86885 x >= n ifTrue: [self error: 'x must be < n']. 86886 86887 v := x. 86888 u := n. 86889 k := 0. 86890 [x even and: [n even and: [u > 0]]] whileTrue: [ "eliminate common factors of two" 86891 k := k + 1. 86892 u := u bitShift: -1. 86893 v := v bitShift: -1]. 86894 86895 u1 := 1. u2 := 0. u3 := u. 86896 t1 := v. t2 := u - 1. t3 := v. 86897 [ [u3 even ifTrue: [ 86898 ((u1 odd) or: [u2 odd]) ifTrue: [ 86899 u1 := u1 + v. 86900 u2 := u2 + u]. 86901 u1 := u1 bitShift: -1. 86902 u2 := u2 bitShift: -1. 86903 u3 := u3 bitShift: -1]. 86904 ((t3 even) or: [u3 < t3]) ifTrue: [ 86905 tmp := u1. u1 := t1. t1 := tmp. 86906 tmp := u2. u2 := t2. t2 := tmp. 86907 tmp := u3. u3 := t3. t3 := tmp]. 86908 u3 even and: [u3 > 0]] whileTrue: ["loop while u3 is even"]. 86909 86910 [((u1 < t1) or: [u2 < t2]) and: [u1 > 0]] whileTrue: [ 86911 u1 := u1 + v. 86912 u2 := u2 + u]. 86913 86914 u1 := u1 - t1. 86915 u2 := u2 - t2. 86916 u3 := u3 - t3. 86917 t3 > 0] whileTrue: ["loop while t3 > 0"]. 86918 86919 [u1 >= v and: [u2 >= u]] whileTrue: [ 86920 u1 := u1 - v. 86921 u2 := u2 - u]. 86922 86923 u1 := u1 bitShift: k. 86924 u2 := u2 bitShift: k. 86925 u3 := u3 bitShift: k. 86926 86927 u3 = 1 ifFalse: [self error: 'no inverse']. 86928 ^ u - u2 86929! ! 86930 86931!DigitalSignatureAlgorithm methodsFor: 'large integer arithmetic' stamp: 'adrian-lienhard 5/18/2009 21:08'! 86932isProbablyPrime: p 86933 "Answer true if p is prime with very high probability. Such a number is sometimes called an 'industrial grade prime'--a large number that is so extremely likely to be prime that it can assumed that it actually is prime for all practical purposes. This implementation uses the Rabin-Miller algorithm (Schneier, p. 159)." 86934 86935 | iterations factor pMinusOne b m r a j z couldBePrime | 86936 iterations := 50. "Note: The DSA spec requires >50 iterations; Schneier says 5 are enough (p. 260)" 86937 86938 "quick elimination: check for p divisible by a small prime" 86939 SmallPrimes ifNil: [ "generate list of small primes > 2" 86940 SmallPrimes := Integer primesUpTo: 2000. 86941 SmallPrimes := SmallPrimes copyFrom: 2 to: SmallPrimes size]. 86942 factor := SmallPrimes detect: [:f | (p \\ f) = 0] ifNone: [nil]. 86943 factor ifNotNil: [^ p = factor]. 86944 86945 pMinusOne := p - 1. 86946 b := self logOfLargestPowerOfTwoDividing: pMinusOne. 86947 m := pMinusOne // (2 raisedTo: b). 86948 "Assert: pMinusOne = m * (2 raisedTo: b) and m is odd" 86949 86950 Transcript show: ' Prime test pass '. 86951 r := Random new. 86952 1 to: iterations do: [:i | 86953 Transcript show: i printString; space. 86954 a := (r next * 16rFFFFFF) truncated. 86955 j := 0. 86956 z := (a raisedTo: m modulo: p) normalize. 86957 couldBePrime := z = 1. 86958 [couldBePrime] whileFalse: [ 86959 z = 1 ifTrue: [Transcript show: 'failed!!'; cr. ^ false]. "not prime" 86960 z = pMinusOne 86961 ifTrue: [couldBePrime := true] 86962 ifFalse: [ 86963 (j := j + 1) < b 86964 ifTrue: [z := (z * z) \\ p] 86965 ifFalse: [Transcript show: 'failed!!'; cr. ^ false]]]]. "not prime" 86966 86967 Transcript show: 'passed!!'; cr. 86968 ^ true "passed all tests; probably prime." 86969! ! 86970 86971 86972!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'adrian-lienhard 5/18/2009 21:07'! 86973computeSignatureForMessageHash: hash privateKey: privateKey 86974 "Answer the digital signature of the given message hash using the given private key. A signature is a pair of large integers. The private key is an array of four large integers: (p, q, g, x)." 86975 86976 | p q g x r s k tmp | 86977 p := privateKey first. 86978 q := privateKey second. 86979 g := privateKey third. 86980 x := privateKey fourth. 86981 86982 r := s := 0. 86983 [r = 0 or: [s = 0]] whileTrue: [ 86984 k := self nextRandom160 \\ q. 86985 r := (g raisedTo: k modulo: p) \\ q. 86986 tmp := (hash + (x * r)) \\ q. 86987 s := ((self inverseOf: k mod: q) * tmp) \\ q]. 86988 86989 ^ Array with: r with: s. 86990! ! 86991 86992!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'adrian-lienhard 5/18/2009 21:08'! 86993generateKeySet 86994 "Generate and answer a key set for DSA. The result is a pair (<private key><public key>). Each key is an array of four large integers. The private key is (p, q, g, x); the public one is (p, q, g, y). The signer must be sure to record (p, q, g, x), and must keep x secret to prevent someone from forging their signature." 86995 "Note: Key generation can take some time. Open a transcript so you can see what's happening and take a coffee break!!" 86996 86997 | qAndPandS q p exp g h x y | 86998 qAndPandS := self generateQandP. 86999 Transcript show: 'Computing g...'. 87000 q := qAndPandS first. 87001 p := qAndPandS second. 87002 exp := (p - 1) / q. 87003 h := 2. 87004 [g := h raisedTo: exp modulo: p. g = 1] whileTrue: [h := h + 1]. 87005 Transcript show: 'done.'; cr. 87006 Transcript show: 'Computing x and y...'. 87007 x := self nextRandom160. 87008 y := g raisedTo: x modulo: p. 87009 Transcript show: 'done.'; cr. 87010 Transcript show: 'Key generation complete!!'; cr. 87011 ^ Array 87012 with: (Array with: p with: q with: g with: x) 87013 with: (Array with: p with: q with: g with: y). 87014! ! 87015 87016!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'PeterHugossonMiller 9/3/2009 01:13'! 87017signatureToString: aSignature 87018 "Answer a string representation of the given signature. This string can be parsed using the stringToSignature: method." 87019 87020 | s | 87021 s := (String new: 2000) writeStream. 87022 s nextPutAll: '[DSA digital signature '. 87023 s nextPutAll: aSignature first printStringHex. 87024 s space. 87025 s nextPutAll: aSignature second printStringHex. 87026 s nextPutAll: ']'. 87027 ^ s contents 87028! ! 87029 87030!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'dc 5/30/2008 10:17'! 87031stringToSignature: aString 87032 "Answer the signature stored in the given string. A signature string has the format: 87033 87034 '[DSA digital signature <r> <s>]' 87035 87036 where <r> and <s> are large positive integers represented by strings of hexidecimal digits." 87037 | prefix stream r s | 87038 prefix := '[DSA digital signature '. 87039 (aString beginsWith: prefix) ifFalse: [ self error: 'bad signature prefix' ]. 87040 stream := aString readStream. 87041 stream position: prefix size. 87042 r := Integer 87043 readFrom: stream 87044 base: 16. 87045 stream next. 87046 s := Integer 87047 readFrom: stream 87048 base: 16. 87049 ^ Array 87050 with: r 87051 with: s! ! 87052 87053!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'adrian-lienhard 5/18/2009 21:08'! 87054verifySignature: aSignature ofMessageHash: hash publicKey: publicKey 87055 "Answer true if the given signature is the authentic signature of the given message hash. That is, if the signature must have been computed using the private key set corresponding to the given public key. The public key is an array of four large integers: (p, q, g, y)." 87056 87057 | p q g y r s w u1 u2 v0 v | 87058 p := publicKey first. 87059 q := publicKey second. 87060 g := publicKey third. 87061 y := publicKey fourth. 87062 r := aSignature first. 87063 s := aSignature last. 87064 ((r > 0) and: [r < q]) ifFalse: [^ false]. "reject" 87065 ((s > 0) and: [s < q]) ifFalse: [^ false]. "reject" 87066 87067 w := self inverseOf: s mod: q. 87068 u1 := (hash * w) \\ q. 87069 u2 := (r * w) \\ q. 87070 v0 := (g raisedTo: u1 modulo: p) * (y raisedTo: u2 modulo: p). 87071 v := ( v0 \\ p) \\ q. 87072 ^ v = r. 87073! ! 87074 87075 87076!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'raa 5/30/2000 15:47'! 87077generateQandP 87078 "Generate the two industrial-grade primes, q (160-bits) and p (512-bit) needed to build a key set. Answer the array (q, p, s), where s is the seed that from which q and p were created. This seed is normally discarded, but can be used to verify the key generation process if desired." 87079 87080 | pBits halfTwoToTheP chunkCount sAndq q twoQ n c w x p s | 87081 pBits := 512. "desired size of p in bits" 87082 halfTwoToTheP := 2 raisedTo: (pBits - 1). 87083 chunkCount := pBits // 160. 87084 87085 Transcript show: 'Searching for primes q and p...'; cr. 87086 [true] whileTrue: [ 87087 sAndq := self generateSandQ. 87088 Transcript show: ' Found a candidate q.'; cr. 87089 s := sAndq first. 87090 q := sAndq last. 87091 twoQ := q bitShift: 1. 87092 n := 2. 87093 c := 0. 87094 [c < 4096] whileTrue: [ 87095 w := self generateRandomLength: pBits s: s n: n. 87096 x := w + halfTwoToTheP. 87097 p := (x - ( x \\ twoQ)) + 1. 87098 p highBit = pBits ifTrue: [ 87099 Transcript show: ' Testing potential p ', (c + 1) printString, '...'; cr. 87100 (self isProbablyPrime: p) ifTrue: [ 87101 Transcript show: ' Found p!!'; cr. 87102 ^ Array with: q with: p with: s]]. 87103 n := n + chunkCount + 1. 87104 c := c + 1]]. 87105! ! 87106 87107!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'jm 12/13/1999 16:36'! 87108generateRandomLength: bitLength s: s n: n 87109 "Answer a random number of bitLength bits generated using the secure hash algorithm." 87110 87111 | sha out count extraBits v | 87112 sha := SecureHashAlgorithm new. 87113 out := 0. 87114 count := (bitLength // 160). 87115 extraBits := bitLength - (count * 160). 87116 0 to: count do: [:k | 87117 v := sha hashInteger: (s + n + k). 87118 k = count ifTrue: [ 87119 v := v - ((v >> extraBits) << extraBits)]. 87120 out := out bitOr: (v bitShift: (160 * k))]. 87121 ^ out 87122! ! 87123 87124!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'raa 5/30/2000 15:46'! 87125generateSandQ 87126 "Generate a 160-bit random seed s and an industrial grade prime q." 87127 87128 | hasher s sPlusOne u q | 87129 hasher := SecureHashAlgorithm new. 87130 [true] whileTrue: [ 87131 s := self nextRandom160. 87132 sPlusOne := s + 1. 87133 sPlusOne highBit > 160 ifTrue: [sPlusOne := sPlusOne \\ (2 raisedTo: 160)]. 87134 u := (hasher hashInteger: s) bitXor: (hasher hashInteger: sPlusOne). 87135 q := u bitOr: ((1 bitShift: 159) bitOr: 1). 87136 (self isProbablyPrime: q) ifTrue: [^ Array with: s with: q]]. 87137! ! 87138 87139!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'jm 12/13/1999 11:12'! 87140logOfLargestPowerOfTwoDividing: aPositiveInteger 87141 "Answer the base-2 log of the largest power of two that divides the given integer. For example, the largest power of two that divides 24 is 8, whose log base-2 is 3. Do this efficiently even when the given number is a large integer. Assume that the given integer is > 0." 87142 "DigitalSignatureAlgorithm new largestPowerOfTwoDividing: (32 * 3)" 87143 87144 | digitIndex power d | 87145 digitIndex := (1 to: aPositiveInteger digitLength) detect: [:i | (aPositiveInteger digitAt: i) ~= 0]. 87146 power := (digitIndex - 1) * 8. 87147 d := aPositiveInteger digitAt: digitIndex. 87148 [d odd] whileFalse: [ 87149 power := power + 1. 87150 d := d bitShift: -1]. 87151 ^ power 87152! ! 87153 87154!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'jm 12/13/1999 14:39'! 87155nextRandom160 87156 "Answer a newly generated 160-bit random number in the range [1..(2^160 - 1)]." 87157 "Details: Try again in the extremely unlikely chance that zero is encountered." 87158 87159 | result | 87160 result := 0. 87161 [result = 0] whileTrue: [ 87162 result := SecureHashAlgorithm new hashInteger: randKey seed: randSeed. 87163 randKey := randKey + result + 1]. 87164 ^ result 87165! ! 87166 87167"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 87168 87169DigitalSignatureAlgorithm class 87170 instanceVariableNames: ''! 87171 87172!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'jm 12/22/1999 11:23'! 87173example 87174 "Example of signing a message and verifying its signature." 87175 "Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature." 87176 "DigitalSignatureAlgorithm example" 87177 87178 | msg keys sig | 87179 msg := 'This is a test...'. 87180 keys := self testKeySet. 87181 sig := self sign: msg privateKey: keys first. 87182 self inform: 'Signature created'. 87183 (self verify: sig isSignatureOf: msg publicKey: keys last) 87184 ifTrue: [self inform: 'Signature verified.'] 87185 ifFalse: [self error: 'ERROR!! Signature verification failed']. 87186! ! 87187 87188!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'mdr 8/31/2000 18:43'! 87189testExamplesFromDisk 87190 "verify messages from file on disk" 87191 "Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature." 87192 "DigitalSignatureAlgorithm testExamplesFromDisk" 87193 87194 | msg sig file publicKey | 87195 87196 file := FileStream readOnlyFileNamed: 'dsa.test.out'. 87197 [ 87198 [file atEnd] whileFalse: [ 87199 sig := file nextChunk. 87200 msg := file nextChunk. 87201 publicKey := Compiler evaluate: file nextChunk. 87202 (self verify: sig isSignatureOf: msg publicKey: publicKey) ifTrue: [ 87203 Transcript show: 'SUCCESS: ',msg; cr. 87204 ] ifFalse: [ 87205 self error: 'ERROR!! Signature verification failed' 87206 ]. 87207 ]. 87208 ] ensure: [file close] 87209! ! 87210 87211!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'jm 12/22/1999 11:28'! 87212testKeySet 87213 "Answer a pair of keys for testing. The first key is the private key, the second one is the public key." 87214 "WARNING: This test key set is public should be used only for testing!! In a real application, the user would create a set of keys using generateKeySet and would keep the private key secret." 87215 87216 ^ #( 87217 (8343811888543852523216773185009428259187948644369498021763210776677854991854533186365944349987509452133156416880596803846631577352387751880552969116768071 1197175832754339660404549606408619548226315875117 1433467472198821951822151391684734233265646022897503720591270330985699984763922266163182803556189497900262038518780931942996381297743579119123094520048965 957348690772296812) 87218 (8343811888543852523216773185009428259187948644369498021763210776677854991854533186365944349987509452133156416880596803846631577352387751880552969116768071 1197175832754339660404549606408619548226315875117 1433467472198821951822151391684734233265646022897503720591270330985699984763922266163182803556189497900262038518780931942996381297743579119123094520048965 4645213122572190617807944614677917601101008235397095646475699959851618402406173485853587185431290863173614335452934961425661774118334228449202337038283799)) 87219! ! 87220 87221!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'RAA 5/31/2000 08:46'! 87222timeDecode: count 87223 "Example of signing a message and verifying its signature." 87224 "Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature." 87225 "DigitalSignatureAlgorithm timeDecode: 20" 87226 87227 | msg keys sig s dsa | 87228 87229 dsa := DigitalSignatureAlgorithm new. 87230 dsa initRandomFromUser. 87231 87232 #(1 10 100 1000 10000 100000) do: [ :extraLen | 87233 s := String new: extraLen. 87234 1 to: s size do: [ :i | s at: i put: (Character value: 200 atRandom)]. 87235 msg := 'This is a test...',s. 87236 keys := self testKeySet. 87237 sig := self sign: msg privateKey: keys first dsa: dsa. 87238 "self inform: 'Signature created'." 87239 self timeDirect: [ 87240 count timesRepeat: [ 87241 (self verify: sig isSignatureOf: msg publicKey: keys last) 87242 ifFalse: [self error: 'ERROR!! Signature verification failed']. 87243 ]. 87244 ] as: 'verify msgLen = ',msg size printString count: count 87245 ]. 87246! ! 87247 87248!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'RAA 5/31/2000 13:13'! 87249writeExamplesToDisk 87250 "Example of signing a message and verifying its signature. Used to create samples from one implementation that could later be tested with a different implementation" 87251 "Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature." 87252 "DigitalSignatureAlgorithm writeExamplesToDisk" 87253 87254 | sig file keyList dsa msgList | 87255 87256 dsa := DigitalSignatureAlgorithm new. 87257 dsa initRandomFromUser. 87258 self inform: 'About to generate 5 key sets. Will take a while'. 87259 keyList := {self testKeySet},((1 to: 5) collect: [ :ignore | self generateKeySet]). 87260 msgList := {'This is a test...'. 'This is the second test period.'. 'And finally, a third message'}. 87261 file := FileStream newFileNamed: 'dsa.test.out'. 87262 [ 87263 msgList do: [ :msg | 87264 keyList do: [ :keys | 87265 sig := self sign: msg privateKey: keys first dsa: dsa. 87266 (self verify: sig isSignatureOf: msg publicKey: keys last) ifTrue: [ 87267 file 87268 nextChunkPut: sig; 87269 nextChunkPut: msg; 87270 nextChunkPut: keys last storeString. 87271 ] ifFalse: [ 87272 self error: 'ERROR!! Signature verification failed' 87273 ]. 87274 ]. 87275 ]. 87276 ] ensure: [file close] 87277! ! 87278 87279 87280!DigitalSignatureAlgorithm class methodsFor: 'initialization' stamp: 'NorbertHartl 6/13/2008 11:38'! 87281initialize 87282 "DigitalSignatureAlgorithm initialize" 87283 87284 "SmallPrimes is a list of small primes greater than two." 87285 SmallPrimes := Integer primesUpTo: 2000. 87286 SmallPrimes := SmallPrimes copyFrom: 2 to: SmallPrimes size. 87287 87288 "HighBitOfByte maps a byte to the index of its top non-zero bit." 87289 HighBitOfByte := (0 to: 255) collect: [:byte | byte highBit]. 87290! ! 87291 87292 87293!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'ads 7/31/2003 14:01'! 87294generateKeySet 87295 "Generate and answer a key set for code signing. The result is a pair (<private key><public key>). Each key is an array of four large integers. The signer must be sure to record this keys set and must keep the private key secret to prevent someone from forging their signature." 87296 "Note: Key generation can take some time. Open a transcript so you can see what's happening and take a coffee break!!" 87297 "Note: Unguessable random numbers are needed for key generation. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before generating a key set. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams." 87298 "DigitalSignatureAlgorithm generateKeySet" 87299 87300 | dsa | 87301 dsa := DigitalSignatureAlgorithm new. 87302 (self confirm: 'Shall I seed the random generator from the current sound input?') 87303 ifTrue: [dsa initRandomNonInteractively] 87304 ifFalse: [dsa initRandomFromUser]. 87305 ^ dsa generateKeySet 87306 ! ! 87307 87308!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'stephane.ducasse 5/25/2008 15:23'! 87309sign: aStringOrStream privateKey: privateKey 87310 "Sign the given message (a stream or string) and answer a signature string." 87311 "Note: Unguessable random numbers are needed for message signing. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before signing a message. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams." 87312 | dsa hasher h sig | 87313 dsa := DigitalSignatureAlgorithm new. 87314 dsa initRandomFromUser. 87315 hasher := SecureHashAlgorithm new. 87316 h := aStringOrStream class isBytes 87317 ifTrue: [ hasher hashMessage: aStringOrStream ] 87318 ifFalse: [ hasher hashStream: aStringOrStream ]. 87319 sig := dsa 87320 computeSignatureForMessageHash: h 87321 privateKey: privateKey. 87322 ^ dsa signatureToString: sig! ! 87323 87324!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'stephane.ducasse 5/25/2008 15:23'! 87325sign: aStringOrStream privateKey: privateKey dsa: dsa 87326 "Sign the given message (a stream or string) and answer a signature string." 87327 "Note: Unguessable random numbers are needed for message signing. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before signing a message. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams." 87328 | hasher h sig | 87329 hasher := SecureHashAlgorithm new. 87330 h := aStringOrStream class isBytes 87331 ifTrue: [ hasher hashMessage: aStringOrStream ] 87332 ifFalse: [ hasher hashStream: aStringOrStream ]. 87333 sig := dsa 87334 computeSignatureForMessageHash: h 87335 privateKey: privateKey. 87336 ^ dsa signatureToString: sig! ! 87337 87338!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'stephane.ducasse 5/25/2008 15:23'! 87339verify: signatureString isSignatureOf: aStringOrStream publicKey: publicKey 87340 "Answer true if the given signature string signs the given message (a stream or string)." 87341 "Note: Random numbers are not needed for signature verification; thus, there is no need to call initRandomFromUser before verifying a signature." 87342 | dsa hasher h sig | 87343 dsa := DigitalSignatureAlgorithm new. 87344 hasher := SecureHashAlgorithm new. 87345 h := aStringOrStream class isBytes 87346 ifTrue: [ hasher hashMessage: aStringOrStream ] 87347 ifFalse: [ hasher hashStream: aStringOrStream ]. 87348 sig := dsa stringToSignature: signatureString. 87349 ^ dsa 87350 verifySignature: sig 87351 ofMessageHash: h 87352 publicKey: publicKey! ! 87353 87354 87355!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:21'! 87356time: aBlock as: aString count: anInteger 87357 87358 ^{anInteger. aString. (Time millisecondsToRun: aBlock)}! ! 87359 87360!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:40'! 87361timeDirect: aBlock as: aString count: anInteger 87362 87363 Transcript show: anInteger asStringWithCommas,' ', 87364 aString ,' took ', 87365 (Time millisecondsToRun: aBlock) asStringWithCommas,' ms'; cr 87366! ! 87367ArrayedCollection subclass: #DirectoryEntry 87368 instanceVariableNames: 'name creationTime modificationTime dirFlag fileSize' 87369 classVariableNames: '' 87370 poolDictionaries: '' 87371 category: 'Files-Directories'! 87372!DirectoryEntry commentStamp: '<historical>' prior: 0! 87373an entry in a directory; a reference to either a file or a directory.! 87374 87375 87376!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:37'! 87377creationTime 87378 "time the entry was created. (what's its type?)" 87379 ^creationTime! ! 87380 87381!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:38'! 87382fileSize 87383 "size of the entry, if it's a file" 87384 ^fileSize! ! 87385 87386!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:38'! 87387isDirectory 87388 "whether this entry represents a directory" 87389 ^dirFlag! ! 87390 87391!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:37'! 87392modificationTime 87393 "time the entry was last modified" 87394 ^modificationTime! ! 87395 87396!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:37'! 87397name 87398 "name of the entry" 87399 ^name! ! 87400 87401 87402!DirectoryEntry methodsFor: 'access-compatibility' stamp: 'ls 7/15/1998 22:29'! 87403at: index 87404 "compatibility interface" 87405 "self halt: 'old-style access to DirectoryEntry'" 87406 index = 1 ifTrue: [ ^self name ]. 87407 index = 2 ifTrue: [ ^self creationTime ]. 87408 index = 3 ifTrue: [ ^self modificationTime ]. 87409 index = 4 ifTrue:[ ^self isDirectory ]. 87410 index = 5 ifTrue:[ ^self fileSize ]. 87411 self error: 'invalid index specified'.! ! 87412 87413!DirectoryEntry methodsFor: 'access-compatibility' stamp: 'ls 7/15/1998 22:16'! 87414size 87415 ^5! ! 87416 87417 87418!DirectoryEntry methodsFor: 'multilingual system' stamp: 'stephaneducasse 2/4/2006 20:31'! 87419convertFromSystemName 87420 87421 name := (FilePath pathName: name isEncoded: true) asSqueakPathName! ! 87422 87423 87424!DirectoryEntry methodsFor: 'private-initialization' stamp: 'stephaneducasse 2/4/2006 20:31'! 87425privateName: name0 creationTime: creationTime0 modificationTime: modificationTime0 isDirectory: isDirectory0 fileSize: fileSize0 87426 name := name0. 87427 creationTime := creationTime0. 87428 modificationTime := modificationTime0. 87429 dirFlag := isDirectory0. 87430 fileSize := fileSize0.! ! 87431 87432"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 87433 87434DirectoryEntry class 87435 instanceVariableNames: ''! 87436 87437!DirectoryEntry class methodsFor: 'instance creation' stamp: 'ls 7/15/1998 21:42'! 87438fromArray: array 87439 ^self name: (array at: 1) creationTime: (array at: 2) modificationTime: (array at: 3) isDirectory: (array at: 4) fileSize: (array at: 5) ! ! 87440 87441!DirectoryEntry class methodsFor: 'instance creation' stamp: 'ls 7/15/1998 21:41'! 87442name: name0 creationTime: creationTime modificationTime: modificationTime isDirectory: isDirectory fileSize: fileSize 87443 ^self new privateName: name0 creationTime: creationTime modificationTime: modificationTime isDirectory: isDirectory fileSize: fileSize! ! 87444HierarchicalURI subclass: #DirectoryURI 87445 instanceVariableNames: '' 87446 classVariableNames: '' 87447 poolDictionaries: '' 87448 category: 'Network-URI'! 87449Object subclass: #DiskProxy 87450 instanceVariableNames: 'globalObjectName preSelector constructorSelector constructorArgs' 87451 classVariableNames: '' 87452 poolDictionaries: '' 87453 category: 'System-Object Storage'! 87454!DiskProxy commentStamp: '<historical>' prior: 0! 87455A DiskProxy is an externalized form of an object to write on a 87456DataStream. It contains a "constructor" message to regenerate 87457the object, in context, when sent a comeFullyUpOnReload message 87458(i.e. "internalize"). 87459 87460We are now using DiskProxy for shared system objects like StrikeFonts. 87461 87462The idea is to define, for each kind of object that needs special 87463externalization, a class method that will internalize the object by 87464reconstructing it from its defining state. We call this a 87465"constructor" method. Then externalize such an object as a frozen 87466message that invokes this method--a DiskProxy. 87467 87468(Here is the old comment: 87469Constructing a new object is good for any object that (1) can not be 87470externalized simply by snapshotting and reloading its instance 87471variables (like a CompiledMethod or a Picture), or (2) wants to be 87472free to evolve its internal representation without making stored 87473instances obsolete (and dangerous). Snapshotting and reloading an 87474object"s instance variables is a dangerous breach of encapsulation. 87475 87476The internal structure of the class is then free to evolve. All 87477externalized instances will be useful as long as the 87478constructor methods are maintained with the same semantics. 87479 87480There may be several constructor methods for a particular class. This 87481is useful for (1) instances with characteristically different 87482defining state, and (2) newer, evolved forms of an object and its 87483constructors, with the old constructor methods kept around so old 87484data can still be properly loaded.) 87485 87486Create one like this example from class Picture 87487 87488 DiskProxy global: #Picture 87489 selector: #fromByteArray: 87490 args: (Array with: self storage asByteArray) 87491 87492* See also subclass DiskProxyQ that will construct an object in 87493the above manner and then send it a sequence of messages. This may save 87494creating a wide variety of constructor methods. It is also useful because 87495the newly read-in DiskProxyQ can catch messages like #objectContainedIn: 87496(via #doesNotUnderstand:) and add them to the queue of messages to 87497send to the new object. 87498 87499* We may also want a subclass of DiskProxy that evaluates a string 87500expression to compute the receiver of the constructor message. 87501 87502My instance variables: 87503* globalObjectName -- the Symbol name of a global object in the 87504 System dictionary (usually a class). 87505* constructorSelector -- the constructor message selector Symbol to 87506 send to the global object (perform:withArguments:), typically a 87507 variation on newFrom:. 87508* constructorArgs -- the Array of arguments to pass in the 87509 constructor message. 87510 87511-- 11/9/92 Jerry Morrison 87512! 87513 87514 87515!DiskProxy methodsFor: 'accessing' stamp: 'tk 3/10/2000 23:50'! 87516constructorArgs 87517 ^ constructorArgs! ! 87518 87519!DiskProxy methodsFor: 'accessing' stamp: 'tk 11/6/2000 22:38'! 87520constructorSelector 87521 ^ constructorSelector! ! 87522 87523!DiskProxy methodsFor: 'accessing' stamp: 'tk 11/6/2000 22:38'! 87524globalObjectName 87525 ^ globalObjectName! ! 87526 87527!DiskProxy methodsFor: 'accessing' stamp: 'tk 11/6/2000 22:35'! 87528preSelector 87529 87530 ^ preSelector! ! 87531 87532!DiskProxy methodsFor: 'accessing' stamp: 'tk 4/8/1999 12:54'! 87533preSelector: aSelector 87534 87535 preSelector := aSelector! ! 87536 87537!DiskProxy methodsFor: 'accessing' stamp: 'tk 10/6/2000 15:18'! 87538simpleGlobalOrNil 87539 "Return the object I refer to if it is a simple global in Smalltalk." 87540 87541 preSelector ifNotNil: [^ nil]. 87542 constructorSelector == #yourself ifFalse: [^ nil]. 87543 ^ Smalltalk at: globalObjectName ifAbsent: [nil]. 87544! ! 87545 87546 87547!DiskProxy methodsFor: 'exceptions' stamp: 'tk 3/14/2000 16:27'! 87548enter 87549 "Enter the new project" 87550 self enter: false revert: false saveForRevert: false.! ! 87551 87552!DiskProxy methodsFor: 'exceptions' stamp: 'RAA 5/17/2000 11:51'! 87553loadFromServer 87554 87555 "In support of check for newer version in ProjectViewMorph menu" 87556 87557 self enter 87558! ! 87559 87560 87561!DiskProxy methodsFor: 'i/o' stamp: 'stephane.ducasse 7/10/2009 17:44'! 87562comeFullyUpOnReload: smartRefStream 87563 "Internalize myself into a fully alive object after raw loading from a 87564 DataStream. (See my class comment.) DataStream will substitute the 87565 object from this eval for the DiskProxy." 87566 | globalObj symbol arrayIndex | 87567 symbol := globalObjectName. 87568 "See if class is mapped to another name" 87569 (smartRefStream respondsTo: #renamed) 87570 ifTrue: ["If in outPointers in an ImageSegment, remember original class 87571 name. 87572 See mapClass:installIn:. Would be lost otherwise." 87573 (thisContext sender sender sender sender sender sender sender sender receiver class == ImageSegment 87574 and: [thisContext sender sender sender sender method 87575 == (DataStream compiledMethodAt: #readArray)]) 87576 ifTrue: [arrayIndex := thisContext sender sender sender sender tempAt: 4. 87577 "index var in readArray. Later safer to find i on stack 87578 of context." 87579 smartRefStream renamedConv at: arrayIndex put: symbol]. 87580 "save original name" 87581 symbol := smartRefStream renamed 87582 at: symbol 87583 ifAbsent: [symbol]]. 87584 "map" 87585 globalObj := Smalltalk 87586 at: symbol 87587 ifAbsent: [preSelector == nil & (constructorSelector = #yourself) 87588 ifTrue: [Transcript cr; show: symbol , ' is undeclared.'. 87589 (Undeclared includesKey: symbol) 87590 ifTrue: [^ Undeclared at: symbol]. 87591 Undeclared at: symbol put: nil. 87592 ^ nil]. 87593 ^ self error: 'Global "' , symbol , '" not found']. 87594 preSelector 87595 ifNotNil: [Symbol 87596 hasInterned: preSelector 87597 ifTrue: [:selector | [globalObj := globalObj perform: selector] 87598 on: Error 87599 do: [:ex | 87600 ex messageText = 'key not found' 87601 ifTrue: [^ nil]. 87602 ^ ex signal]]]. 87603 "keep the Proxy if Project does not exist" 87604 constructorSelector 87605 ifNil: [^ globalObj]. 87606 Symbol 87607 hasInterned: constructorSelector 87608 ifTrue: [:selector | [^ globalObj perform: selector withArguments: constructorArgs] 87609 on: Error 87610 do: [:ex | 87611 ex messageText = 'key not found' 87612 ifTrue: [^ nil]. 87613 ^ ex signal]]. 87614 "args not checked against Renamed" 87615 ^ nil! ! 87616 87617!DiskProxy methodsFor: 'i/o' stamp: 'tk 3/26/98 11:17'! 87618storeDataOn: aDataStream 87619 "Besides just storing, get me inserted into references, so structures will know about class DiskProxy." 87620 87621 super storeDataOn: aDataStream. 87622 aDataStream references at: self put: #none. 87623 "just so instVarInfo: will find it and put it into structures"! ! 87624 87625 87626!DiskProxy methodsFor: 'initialization' stamp: 'tk 4/8/1999 12:58'! 87627global: globalNameSymbol preSelector: aSelector selector: selectorSymbol args: argArray 87628 "Initialize self as a DiskProxy constructor with the given 87629 globalNameSymbol, selectorSymbol, and argument Array. 87630 I will internalize by looking up the global object name in the 87631 SystemDictionary (Smalltalk) and sending it this message with 87632 these arguments." 87633 87634 globalObjectName := globalNameSymbol asSymbol. 87635 preSelector := aSelector asSymbol. 87636 constructorSelector := selectorSymbol asSymbol. 87637 constructorArgs := argArray.! ! 87638 87639!DiskProxy methodsFor: 'initialization' stamp: 'tk 11/4/1999 19:28'! 87640global: globalNameSymbol selector: selectorSymbol args: argArray 87641 "Initialize self as a DiskProxy constructor with the given 87642 globalNameSymbol, selectorSymbol, and argument Array. 87643 I will internalize by looking up the global object name in the 87644 SystemDictionary (Smalltalk) and sending it this message with 87645 these arguments." 87646 87647 (globalNameSymbol beginsWith: 'AnObsolete') ifTrue: [ 87648 self error: 'Trying to write out, ', globalNameSymbol]. 87649 globalObjectName := globalNameSymbol asSymbol. 87650 constructorSelector := selectorSymbol asSymbol. 87651 constructorArgs := argArray.! ! 87652 87653 87654!DiskProxy methodsFor: 'printing' stamp: 'ar 4/10/2005 18:46'! 87655printOn: aStream 87656 "Try to report the name of the project" 87657 87658 globalObjectName == #Project ifFalse: [^ super printOn: aStream]. 87659 constructorArgs size > 0 ifFalse: [^ super printOn: aStream]. 87660 constructorArgs first isString ifFalse: [^ super printOn: aStream]. 87661 aStream nextPutAll: constructorArgs first, ' (on server)'! ! 87662 87663"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 87664 87665DiskProxy class 87666 instanceVariableNames: ''! 87667 87668!DiskProxy class methodsFor: 'instance creation'! 87669global: globalNameSymbol selector: selectorSymbol args: argArray 87670 "Create a new DiskProxy constructor with the given 87671 globalNameSymbol, selectorSymbol, and argument Array. 87672 It will internalize itself by looking up the global object name 87673 in the SystemDictionary (Smalltalk) and sending it this message 87674 with these arguments." 87675 87676 ^ self new global: globalNameSymbol 87677 selector: selectorSymbol 87678 args: argArray! ! 87679DisplayScreen subclass: #DisplayHostWindow 87680 instanceVariableNames: 'windowProxy title windowType' 87681 classVariableNames: 'ActiveWindowIndex' 87682 poolDictionaries: '' 87683 category: 'Graphics-External-Ffenestri'! 87684!DisplayHostWindow commentStamp: '<historical>' prior: 0! 87685A subclass of DisplayScreen that uses a (platform appropriate) HostWindowProxy 87686to do its displaying in a separate host OS window. This is just one example of a 87687client for HostWindowProxy. 87688See #test #test2 and HostWindowTests for example usage.! 87689 87690 87691!DisplayHostWindow methodsFor: 'basic api' stamp: 'tpr 9/21/2004 16:57'! 87692forceToScreen 87693 "update the area defined by my bounds" 87694 self forceToScreen: self boundingBox! ! 87695 87696!DisplayHostWindow methodsFor: 'basic api' stamp: 'tpr 10/7/2004 10:51'! 87697forceToScreen: damageRectangle 87698 "update the area defined by damageRectangle" 87699 windowProxy ifNotNil:[ windowProxy forceToScreen: damageRectangle]! ! 87700 87701!DisplayHostWindow methodsFor: 'basic api' stamp: 'tpr 10/11/2004 16:56'! 87702windowPosition 87703 "return the current position of the window" 87704 87705 ^windowProxy ifNotNil:[ windowProxy windowPosition]! ! 87706 87707!DisplayHostWindow methodsFor: 'basic api' stamp: 'tpr 10/11/2004 16:56'! 87708windowPosition: aPoint 87709 "set the position of the window and then return the new position" 87710 ^windowProxy ifNotNil:[ windowProxy windowPosition: aPoint]! ! 87711 87712!DisplayHostWindow methodsFor: 'basic api' stamp: 'tpr 10/11/2004 16:56'! 87713windowSize 87714 "return the current size of the window - not neccessarily the same as my bitmap" 87715 87716 ^windowProxy ifNotNil:[ windowProxy windowSize]! ! 87717 87718!DisplayHostWindow methodsFor: 'basic api' stamp: 'tpr 10/11/2004 16:56'! 87719windowSize: aPoint 87720 "Set the size of the window and then return the current size of the window - 87721not neccessarily the same " 87722 87723 ^windowProxy ifNotNil:[ windowProxy windowSize: aPoint]! ! 87724 87725!DisplayHostWindow methodsFor: 'basic api' stamp: 'lr 7/4/2009 10:42'! 87726windowTitle: titleString 87727 "set the label in the window titlebar to titleString" 87728 title := titleString. 87729 windowProxy ifNotNil: [ windowProxy windowTitle: title ]! ! 87730 87731 87732!DisplayHostWindow methodsFor: 'initialize-release' stamp: 'lr 7/4/2009 10:42'! 87733close 87734 "close this window" 87735 windowProxy ifNil: [ ^ self error: 'cannot close never opened window' ]. 87736 "We don't use 'self windowProxy close' here because if we've never setup the window why do it now only to close it immediately?" 87737 windowProxy close. 87738 windowProxy := nil! ! 87739 87740!DisplayHostWindow methodsFor: 'initialize-release' stamp: 'lr 7/4/2009 10:42'! 87741open 87742 "open the host window" 87743 windowProxy ifNil: [ windowProxy := HostWindowProxy on: self ]. 87744 windowType ifNil: [ windowType := #defaultWindowType ]. 87745 windowProxy perform: windowType. 87746 ^ windowProxy open! ! 87747 87748 87749!DisplayHostWindow methodsFor: 'snapshots' stamp: 'tpr 10/14/2004 16:13'! 87750actualScreenSize 87751"return the host window size as if it were 'the' screen" 87752 ^self windowSize! ! 87753 87754!DisplayHostWindow methodsFor: 'snapshots' stamp: 'lr 7/4/2009 10:42'! 87755resetProxy 87756 "private - for use when resuming a snapshot file only. If the windowProxy had previously been created, nil it and reopen cleanly. IF you try to use this in a 'live' system it will NOT close the windows since startup conditions assume that proxies are invalid so we don't attempt to close them - since that could cause other problems" 87757 windowProxy ifNotNil: 87758 [ windowProxy := nil. 87759 self open ]! ! 87760 87761 87762!DisplayHostWindow methodsFor: 'testing' stamp: 'lr 7/4/2009 10:42'! 87763test 87764 "((DisplayHostWindow extent: 400@400 depth: 16 ) translateBy: 210@450) test" 87765 "Should 87766 a) open a window with the upper left portion of the current Display 87767 b) find the window size 87768 f) close the window" 87769 | size | 87770 self open. 87771 Display displayOn: self. 87772 self forceToScreen: self boundingBox. 87773 size := self windowSize. 87774 self close. 87775 ^ size! ! 87776 87777!DisplayHostWindow methodsFor: 'testing' stamp: 'tpr 10/6/2004 21:46'! 87778test2 87779 "((DisplayHostWindow extent: 400@400 depth: 16 ) translateBy: 210@450) test2" 87780 "Should 87781 a) open a window with the upper left portion of the current Display 87782 b) update the middle area with part of Display 87783 c) move the window from 210@450 to 300@300 87784 d) change the window title 87785 e) change the window size from 400@400 to 600@400 87786 f) wait 4 seconds so you can see the result 87787 g) close the window via the garbage collecttor finalizing it" 87788 self open. 87789 Display displayOn: self. 87790 self forceToScreen. 87791 Display displayOn: self at: -100@-200. 87792 self forceToScreen: (100@100 extent: 200@200). 87793 self windowPosition: 300@300. 87794 self windowTitle: 'YooHoo!! New title'. 87795 self windowSize: 600@400. 87796 (Delay forSeconds: 4) wait.! ! 87797 87798 87799!DisplayHostWindow methodsFor: 'private' stamp: 'tpr 10/14/2004 16:12'! 87800setExtent: extent depth: bitsPerPixel 87801"reset the host window size to suit the extent chosen" 87802 self windowSize: extent. 87803 ^super setExtent: extent depth: bitsPerPixel 87804! ! 87805DisplayObject subclass: #DisplayMedium 87806 instanceVariableNames: '' 87807 classVariableNames: '' 87808 poolDictionaries: '' 87809 category: 'Graphics-Display Objects'! 87810!DisplayMedium commentStamp: '<historical>' prior: 0! 87811I am a display object which can both paint myself on a medium (displayOn: messages), and can act as a medium myself. My chief subclass is Form.! 87812 87813 87814!DisplayMedium methodsFor: 'bordering'! 87815border: aRectangle width: borderWidth 87816 "Paint a border whose rectangular area is defined by aRectangle. The 87817 width of the border of each side is borderWidth. Uses black for 87818 drawing the border." 87819 87820 self border: aRectangle width: borderWidth fillColor: Color black. 87821! ! 87822 87823!DisplayMedium methodsFor: 'bordering'! 87824border: aRectangle width: borderWidth fillColor: aHalfTone 87825 "Paint a border whose rectangular area is defined by aRectangle. The 87826 width of the border of each side is borderWidth. Uses aHalfTone for 87827 drawing the border." 87828 87829 self border: aRectangle 87830 widthRectangle: 87831 (Rectangle 87832 left: borderWidth 87833 right: borderWidth 87834 top: borderWidth 87835 bottom: borderWidth) 87836 rule: Form over 87837 fillColor: aHalfTone! ! 87838 87839!DisplayMedium methodsFor: 'bordering'! 87840border: aRectangle width: borderWidth rule: combinationRule fillColor: aHalfTone 87841 "Paint a border whose rectangular area is defined by aRectangle. The 87842 width of the border of each side is borderWidth. Uses aHalfTone for 87843 drawing the border." 87844 87845 self border: aRectangle 87846 widthRectangle: 87847 (Rectangle 87848 left: borderWidth 87849 right: borderWidth 87850 top: borderWidth 87851 bottom: borderWidth) 87852 rule: combinationRule 87853 fillColor: aHalfTone! ! 87854 87855!DisplayMedium methodsFor: 'bordering'! 87856border: aRectangle widthRectangle: insets rule: combinationRule fillColor: aHalfTone 87857 "Paint a border whose rectangular area is defined by aRectangle. The 87858 width of each edge of the border is determined by the four coordinates 87859 of insets. Uses aHalfTone and combinationRule for drawing the border." 87860 87861 (aRectangle areasOutside: (aRectangle insetBy: insets)) do: 87862 [:edgeStrip | self fill: edgeStrip rule: combinationRule fillColor: aHalfTone]! ! 87863 87864 87865!DisplayMedium methodsFor: 'coloring'! 87866fill: aRectangle fillColor: aForm 87867 "Replace a rectangular area of the receiver with the pattern described by 87868 aForm according to the rule over." 87869 87870 self fill: aRectangle rule: Form over fillColor: aForm! ! 87871 87872!DisplayMedium methodsFor: 'coloring'! 87873fill: aRectangle rule: anInteger fillColor: aForm 87874 "Replace a rectangular area of the receiver with the pattern described by 87875 aForm according to the rule anInteger." 87876 87877 self subclassResponsibility! ! 87878 87879!DisplayMedium methodsFor: 'coloring'! 87880fillBlack 87881 "Set all bits in the receiver to black (ones)." 87882 87883 self fill: self boundingBox fillColor: Color black! ! 87884 87885!DisplayMedium methodsFor: 'coloring'! 87886fillBlack: aRectangle 87887 "Set all bits in the receiver's area defined by aRectangle to black (ones)." 87888 87889 self fill: aRectangle rule: Form over fillColor: Color black! ! 87890 87891!DisplayMedium methodsFor: 'coloring'! 87892fillColor: aColor 87893 "Set all pixels in the receiver to the color. Must be a correct color for this depth of medium. TK 1 Jun 96" 87894 87895 self fill: self boundingBox fillColor: aColor! ! 87896 87897!DisplayMedium methodsFor: 'coloring'! 87898fillGray 87899 "Set all bits in the receiver to gray." 87900 87901 self fill: self boundingBox fillColor: Color gray! ! 87902 87903!DisplayMedium methodsFor: 'coloring'! 87904fillGray: aRectangle 87905 "Set all bits in the receiver's area defined by aRectangle to the gray mask." 87906 87907 self fill: aRectangle rule: Form over fillColor: Color gray! ! 87908 87909!DisplayMedium methodsFor: 'coloring'! 87910fillShape: aShapeForm fillColor: aColor 87911 "Fill a region corresponding to 1 bits in aShapeForm with aColor" 87912 87913 ^ self fillShape: aShapeForm fillColor: aColor at: 0@0! ! 87914 87915!DisplayMedium methodsFor: 'coloring' stamp: 'ar 5/28/2000 12:06'! 87916fillShape: aShapeForm fillColor: aColor at: location 87917 "Fill a region corresponding to 1 bits in aShapeForm with aColor" 87918 87919 ((BitBlt current destForm: self sourceForm: aShapeForm fillColor: aColor 87920 combinationRule: Form paint 87921 destOrigin: location + aShapeForm offset sourceOrigin: 0@0 87922 extent: self extent clipRect: self boundingBox) 87923 colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) 87924 copyBits! ! 87925 87926!DisplayMedium methodsFor: 'coloring'! 87927fillWhite 87928 "Set all bits in the form to white." 87929 87930 self fill: self boundingBox fillColor: Color white. 87931! ! 87932 87933!DisplayMedium methodsFor: 'coloring'! 87934fillWhite: aRectangle 87935 "Set all bits in the receiver's area defined by aRectangle to white." 87936 87937 self fill: aRectangle rule: Form over fillColor: Color white. 87938! ! 87939 87940!DisplayMedium methodsFor: 'coloring'! 87941fillWithColor: aColor 87942 "Fill the receiver's bounding box with the given color." 87943 87944 self fill: self boundingBox fillColor: aColor. 87945! ! 87946 87947!DisplayMedium methodsFor: 'coloring' stamp: 'jm 6/18/1999 19:01'! 87948reverse 87949 "Change all the bits in the receiver that are white to black, and the ones 87950 that are black to white." 87951 87952 self fill: self boundingBox rule: Form reverse fillColor: (Color quickHighLight: self depth)! ! 87953 87954!DisplayMedium methodsFor: 'coloring' stamp: 'jm 6/18/1999 19:00'! 87955reverse: aRectangle 87956 "Change all the bits in the receiver's area that intersects with aRectangle 87957 that are white to black, and the ones that are black to white." 87958 87959 self fill: aRectangle rule: Form reverse fillColor: (Color quickHighLight: self depth)! ! 87960 87961!DisplayMedium methodsFor: 'coloring'! 87962reverse: aRectangle fillColor: aMask 87963 "Change all the bits in the receiver's area that intersects with aRectangle 87964 according to the mask. Black does not necessarily turn to white, rather it 87965 changes with respect to the rule and the bit in a corresponding mask 87966 location. Bound to give a surprise." 87967 87968 self fill: aRectangle rule: Form reverse fillColor: aMask! ! 87969 87970 87971!DisplayMedium methodsFor: 'displaying'! 87972copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm 87973 "Make up a BitBlt table and copy the bits." 87974 87975 self subclassResponsibility! ! 87976 87977!DisplayMedium methodsFor: 'displaying' stamp: 'hmm 9/16/2000 21:27'! 87978deferUpdatesIn: aRectangle while: aBlock 87979 "DisplayScreen overrides with something more involved..." 87980 ^aBlock value! ! 87981 87982!DisplayMedium methodsFor: 'displaying'! 87983drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger fillColor: aForm 87984 "Draw line by copying the argument, sourceForm, starting at location 87985 beginPoint and ending at endPoint, clipped by the rectangle, clipRect. 87986 The rule and mask for copying are the arguments anInteger and aForm." 87987 87988 self subclassResponsibility! ! 87989Object subclass: #DisplayObject 87990 instanceVariableNames: '' 87991 classVariableNames: '' 87992 poolDictionaries: '' 87993 category: 'Graphics-Display Objects'! 87994!DisplayObject commentStamp: '<historical>' prior: 0! 87995The abstract protocol for most display primitives that are used by Views for presenting information on the screen.! 87996 87997 87998!DisplayObject methodsFor: 'accessing'! 87999extent 88000 "Answer the point that represents the width and height of the receiver's 88001 bounding box." 88002 88003 ^self boundingBox extent! ! 88004 88005!DisplayObject methodsFor: 'accessing'! 88006height 88007 "Answer the number that represents the height of the receiver's 88008 bounding box." 88009 88010 ^self boundingBox height! ! 88011 88012!DisplayObject methodsFor: 'accessing'! 88013offset 88014 "Answer the amount by which the receiver should be offset when it is 88015 displayed or its position is tested." 88016 88017 self subclassResponsibility! ! 88018 88019!DisplayObject methodsFor: 'accessing'! 88020offset: aPoint 88021 "Set the amount by which the receiver's position is offset." 88022 88023 ^self! ! 88024 88025!DisplayObject methodsFor: 'accessing'! 88026relativeRectangle 88027 "Answer a Rectangle whose top left corner is the receiver's offset position 88028 and whose width and height are the same as the receiver." 88029 88030 ^Rectangle origin: self offset extent: self extent! ! 88031 88032!DisplayObject methodsFor: 'accessing'! 88033width 88034 "Answer the number that represents the width of the receiver's bounding 88035 box." 88036 88037 ^self boundingBox width! ! 88038 88039 88040!DisplayObject methodsFor: 'display box access'! 88041boundingBox 88042 "Answer the rectangular area that represents the boundaries of the 88043 receiver's space of information." 88044 88045 ^self computeBoundingBox! ! 88046 88047!DisplayObject methodsFor: 'display box access'! 88048center 88049 88050 ^ self boundingBox center! ! 88051 88052!DisplayObject methodsFor: 'display box access'! 88053computeBoundingBox 88054 "Answer the rectangular area that represents the boundaries of the 88055 receiver's area for displaying information. This is the primitive for 88056 computing the area if it is not already known." 88057 88058 self subclassResponsibility! ! 88059 88060!DisplayObject methodsFor: 'display box access'! 88061initialExtent 88062 "Included here for when a FormView is being opened 88063 as a window. (4@4) covers border widths." 88064 88065 ^ self extent + (4@4) ! ! 88066 88067 88068!DisplayObject methodsFor: 'displaying-display'! 88069display 88070 "Display the receiver on the Display at location 0,0." 88071 88072 self displayOn: Display! ! 88073 88074!DisplayObject methodsFor: 'displaying-display'! 88075follow: locationBlock while: durationBlock 88076 "Move an image around on the Display. Restore the background 88077 continuously without causing flashing. The argument, locationBlock, 88078 supplies each new location, and the argument, durationBlock, supplies 88079 true to continue, and then false to stop. 88080 8/20/96 sw: call follow:while:bitsBehind: to do the real work. Note that th 88081method 88082 now returns the final bits behind as method value." 88083 88084 | bitsBehind loc | 88085 bitsBehind := Form fromDisplay: ((loc := locationBlock value) extent: self extent). 88086 ^ self follow: locationBlock while: durationBlock bitsBehind: bitsBehind startingLoc: loc! ! 88087 88088!DisplayObject methodsFor: 'displaying-display' stamp: 'ar 5/28/2000 12:06'! 88089follow: locationBlock while: durationBlock bitsBehind: initialBitsBehind startingLoc: loc 88090 "Move an image around on the Display. Restore the background continuously without causing flashing. The argument, locationBlock, supplies each new location, and the argument, durationBlock, supplies true to continue or false to stop. This variant takes the bitsBehind as an input argument, and returns the final saved saved bits as method value." 88091 88092 | location rect1 save1 save1Blt buffer bufferBlt newLoc rect2 bothRects | 88093 location := loc. 88094 rect1 := location extent: self extent. 88095 save1 := initialBitsBehind. 88096 save1Blt := BitBlt current toForm: save1. 88097 buffer := Form extent: self extent*2 depth: Display depth. "Holds overlapping region" 88098 bufferBlt := BitBlt current toForm: buffer. 88099 Display deferUpdates: true. 88100 self displayOn: Display at: location rule: Form paint. 88101 Display deferUpdates: false; forceToScreen: (location extent: self extent). 88102 [durationBlock value] whileTrue: [ 88103 newLoc := locationBlock value. 88104 newLoc ~= location ifTrue: [ 88105 rect2 := newLoc extent: self extent. 88106 bothRects := rect1 merge: rect2. 88107 (rect1 intersects: rect2) 88108 ifTrue: [ "when overlap, buffer background for both rectangles" 88109 bufferBlt copyFrom: bothRects in: Display to: 0@0. 88110 bufferBlt copyFrom: save1 boundingBox in: save1 to: rect1 origin - bothRects origin. 88111 "now buffer is clean background; get new bits for save1" 88112 save1Blt copy: (0@0 extent: self extent) from: rect2 origin - bothRects origin in: buffer. 88113 self displayOnPort: bufferBlt at: rect2 origin - bothRects origin rule: Form paint. 88114 Display deferUpdates: true. 88115 Display copy: bothRects from: 0@0 in: buffer rule: Form over. 88116 Display deferUpdates: false; forceToScreen: bothRects] 88117 ifFalse: [ "when no overlap, do the simple thing (both rects might be too big)" 88118 Display deferUpdates: true. 88119 Display copy: (location extent: save1 extent) from: 0@0 in: save1 rule: Form over. 88120 save1Blt copyFrom: rect2 in: Display to: 0@0. 88121 self displayOn: Display at: newLoc rule: Form paint. 88122 Display deferUpdates: false; 88123 forceToScreen: (location extent: save1 extent); 88124 forceToScreen: (newLoc extent: self extent)]. 88125 location := newLoc. 88126 rect1 := rect2]]. 88127 88128 ^ save1 displayOn: Display at: location 88129! ! 88130 88131!DisplayObject methodsFor: 'displaying-display' stamp: 'di 9/12/97 11:09'! 88132isTransparent 88133 ^ false! ! 88134 88135!DisplayObject methodsFor: 'displaying-display'! 88136slideFrom: startPoint to: stopPoint nSteps: nSteps 88137 "does not display at the first point, but does at the last" 88138 | i p delta | 88139 i:=0. p:= startPoint. 88140 delta := (stopPoint-startPoint) // nSteps. 88141 ^ self follow: [p:= p+delta] 88142 while: [(i:=i+1) < nSteps]! ! 88143 88144!DisplayObject methodsFor: 'displaying-display' stamp: 'jm 10/22/97 07:43'! 88145slideFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs 88146 "Slide this object across the display over the given number of steps, pausing for the given number of milliseconds after each step." 88147 "Note: Does not display at the first point, but does at the last." 88148 88149 | i p delta | 88150 i := 0. 88151 p := startPoint. 88152 delta := (stopPoint - startPoint) / nSteps asFloat. 88153 ^ self 88154 follow: [(p := p + delta) truncated] 88155 while: [ 88156 (Delay forMilliseconds: milliSecs) wait. 88157 (i := i + 1) < nSteps] 88158! ! 88159 88160!DisplayObject methodsFor: 'displaying-display' stamp: 'di 10/19/97 12:05'! 88161slideFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs andStay: stayAtEnd 88162 "Does not display at the first point, but does at the last. 88163 Moreover, if stayAtEnd is true, it leaves the dragged image at the stopPoint" 88164 | i done | 88165 i := 0. 88166 ^ self follow: [startPoint + ((stopPoint-startPoint) * i // nSteps)] 88167 while: [milliSecs ifNotNil: [(Delay forMilliseconds: milliSecs) wait]. 88168 ((done := (i := i+1) > nSteps) and: [stayAtEnd]) 88169 ifTrue: [^ self "Return without clearing the image"]. 88170 done not]! ! 88171 88172!DisplayObject methodsFor: 'displaying-display' stamp: 'sr 6/6/2000 05:37'! 88173slideWithFirstFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs 88174 "Slide this object across the display over the given number of steps, 88175 pausing for the given number of milliseconds after each step." 88176 "Note: Does display at the first point and at the last." 88177 | i p delta | 88178 i := 0. 88179 delta := stopPoint - startPoint / nSteps asFloat. 88180 p := startPoint - delta. 88181 ^ self follow: [(p := p + delta) truncated] 88182 while: 88183 [(Delay forMilliseconds: milliSecs) wait. 88184 (i := i + 1) <= nSteps]! ! 88185 88186 88187!DisplayObject methodsFor: 'displaying-generic'! 88188displayAt: aDisplayPoint 88189 "Display the receiver located at aDisplayPoint with default settings for 88190 the displayMedium, rule and halftone." 88191 88192 self displayOn: Display 88193 at: aDisplayPoint 88194 clippingBox: Display boundingBox 88195 rule: Form over 88196 fillColor: nil! ! 88197 88198!DisplayObject methodsFor: 'displaying-generic'! 88199displayOn: aDisplayMedium 88200 "Simple default display in order to see the receiver in the upper left 88201 corner of screen." 88202 88203 self displayOn: aDisplayMedium at: 0 @ 0! ! 88204 88205!DisplayObject methodsFor: 'displaying-generic'! 88206displayOn: aDisplayMedium at: aDisplayPoint 88207 "Display the receiver located at aDisplayPoint with default settings for 88208 rule and halftone." 88209 88210 self displayOn: aDisplayMedium 88211 at: aDisplayPoint 88212 clippingBox: aDisplayMedium boundingBox 88213 rule: Form over 88214 fillColor: nil! ! 88215 88216!DisplayObject methodsFor: 'displaying-generic'! 88217displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle 88218 "Display the receiver located at aDisplayPoint with default settings for 88219 rule and halftone. Information to be displayed must be confined to the 88220 area that intersects with clipRectangle." 88221 88222 self displayOn: aDisplayMedium 88223 at: aDisplayPoint 88224 clippingBox: clipRectangle 88225 rule: Form over 88226 fillColor: nil! ! 88227 88228!DisplayObject methodsFor: 'displaying-generic'! 88229displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 88230 "This is the basic display primitive for graphic display objects. Display 88231 the receiver located at aDisplayPoint with rule, ruleInteger, and mask, 88232 aForm. Information to be displayed must be confined to the area that 88233 intersects with clipRectangle." 88234 88235 self subclassResponsibility! ! 88236 88237!DisplayObject methodsFor: 'displaying-generic'! 88238displayOn: aDisplayMedium at: aDisplayPoint rule: ruleInteger 88239 "Display the receiver located at aPoint with default setting for the 88240 halftone and clippingBox." 88241 88242 self displayOn: aDisplayMedium 88243 at: aDisplayPoint 88244 clippingBox: aDisplayMedium boundingBox 88245 rule: ruleInteger 88246 fillColor: nil! ! 88247 88248!DisplayObject methodsFor: 'displaying-generic'! 88249displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle 88250 "Display primitive for the receiver where a DisplayTransformation is 88251 provided as an argument. Alignment is defaulted to the receiver's 88252 rectangle. Information to be displayed must be confined to the area that 88253 intersects with clipRectangle." 88254 88255 self displayOn: aDisplayMedium 88256 transformation: displayTransformation 88257 clippingBox: clipRectangle 88258 align: self relativeRectangle center 88259 with: self relativeRectangle center 88260 rule: Form over 88261 fillColor: nil! ! 88262 88263!DisplayObject methodsFor: 'displaying-generic'! 88264displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint 88265 "Display primitive where a DisplayTransformation is provided as an 88266 argument, rule is over and mask is Form black. Information to be 88267 displayed must be confined to the area that intersects with clipRectangle." 88268 88269 self displayOn: aDisplayMedium 88270 transformation: displayTransformation 88271 clippingBox: clipRectangle 88272 align: alignmentPoint 88273 with: relativePoint 88274 rule: Form over 88275 fillColor: nil! ! 88276 88277!DisplayObject methodsFor: 'displaying-generic'! 88278displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 88279 "Display the receiver where a DisplayTransformation is provided as an 88280 argument, rule is ruleInteger and mask is aForm. Translate by 88281 relativePoint-alignmentPoint. Information to be displayed must be 88282 confined to the area that intersects with clipRectangle." 88283 88284 | absolutePoint | 88285 absolutePoint := displayTransformation applyTo: relativePoint. 88286 self displayOn: aDisplayMedium 88287 at: (absolutePoint - alignmentPoint) 88288 clippingBox: clipRectangle 88289 rule: ruleInteger 88290 fillColor: aForm ! ! 88291 88292!DisplayObject methodsFor: 'displaying-generic'! 88293displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle fixedPoint: aPoint 88294 "Display the receiver where a DisplayTransformation is provided as an 88295 argument, rule is over and mask is Form black. No translation. 88296 Information to be displayed must be confined to the area that intersects 88297 with clipRectangle." 88298 88299 self displayOn: aDisplayMedium 88300 transformation: displayTransformation 88301 clippingBox: clipRectangle 88302 align: aPoint 88303 with: aPoint 88304 rule: Form over 88305 fillColor: nil! ! 88306 88307!DisplayObject methodsFor: 'displaying-generic'! 88308displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 88309 "Display the receiver where a DisplayTransformation is provided as an 88310 argument, rule is ruleInteger and mask is aForm. No translation. 88311 Information to be displayed must be confined to the area that intersects 88312 with clipRectangle." 88313 88314 self displayOn: aDisplayMedium 88315 transformation: displayTransformation 88316 clippingBox: clipRectangle 88317 align: self relativeRectangle origin 88318 with: self relativeRectangle origin 88319 rule: ruleInteger 88320 fillColor: aForm! ! 88321 88322!DisplayObject methodsFor: 'displaying-generic'! 88323displayOnPort: aPort 88324 self displayOnPort: aPort at: 0@0! ! 88325 88326!DisplayObject methodsFor: 'displaying-generic' stamp: 'jm 10/21/97 16:56'! 88327displayOnPort: port at: location rule: rule 88328 88329 port copyForm: self to: location rule: rule. 88330! ! 88331 88332!DisplayObject methodsFor: 'displaying-generic'! 88333followCursor 88334 "Just show the Form following the mouse. 6/21/96 tk" 88335 Cursor blank showWhile: 88336 [self follow: [Sensor cursorPoint] while: [Sensor noButtonPressed]] 88337! ! 88338 88339 88340!DisplayObject methodsFor: 'filein/out'! 88341writeOnFileNamed: fileName 88342 "Saves the receiver on the file fileName in the format: 88343 fileCode, depth, extent, offset, bits." 88344 | file | 88345 file := FileStream newFileNamed: fileName. 88346 file binary. 88347 file nextPut: 2. "file code = 2" 88348 self writeOn: file. 88349 file close 88350" 88351 | f | 88352[(f := Form fromUser) boundingBox area>25] whileTrue: 88353 [f writeOnFileNamed: 'test.form'. 88354 (Form newFromFileNamed: 'test.form') display]. 88355"! ! 88356 88357!DisplayObject methodsFor: 'filein/out' stamp: 'tk 2/19/1999 07:20'! 88358writeUncompressedOnFileNamed: fileName 88359 "Saves the receiver on the file fileName in the format: 88360 fileCode, depth, extent, offset, bits." 88361 | file | 88362 file := FileStream newFileNamed: fileName. 88363 file binary. 88364 file nextPut: 2. "file code = 2" 88365 self writeUncompressedOn: file. 88366 file close 88367" 88368 | f | 88369[(f := Form fromUser) boundingBox area>25] whileTrue: 88370 [f writeUncompressedOnFileNamed: 'test.form'. 88371 (Form fromBinaryStream: (FileStream oldFileNamed: 'test.form')) display]. 88372"! ! 88373 88374 88375!DisplayObject methodsFor: 'transforming'! 88376align: alignmentPoint with: relativePoint 88377 "Translate the receiver's offset such that alignmentPoint aligns with 88378 relativePoint." 88379 88380 self offset: (self offset translateBy: relativePoint - alignmentPoint)! ! 88381 88382!DisplayObject methodsFor: 'transforming'! 88383scaleBy: aPoint 88384 "Scale the receiver's offset by aPoint." 88385 88386 self offset: (self offset scaleBy: aPoint)! ! 88387 88388!DisplayObject methodsFor: 'transforming'! 88389translateBy: aPoint 88390 "Translate the receiver's offset." 88391 88392 self offset: (self offset translateBy: aPoint)! ! 88393 88394 88395!DisplayObject methodsFor: 'truncation and round off'! 88396rounded 88397 "Convert the offset of the receiver to integer coordinates." 88398 88399 self offset: self offset rounded! ! 88400 88401"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 88402 88403DisplayObject class 88404 instanceVariableNames: ''! 88405 88406!DisplayObject class methodsFor: 'filein/out' stamp: 'mdr 8/31/2000 19:11'! 88407collectionFromFileNamed: fileName 88408 "Answer a collection of Forms read from the external file 88409 named fileName. The file format is: fileCode, {depth, extent, offset, bits}." 88410 88411 | formList f fileCode | 88412 formList := OrderedCollection new. 88413 f := (FileStream readOnlyFileNamed: fileName) binary. 88414 fileCode := f next. 88415 fileCode = 1 88416 ifTrue: [ 88417 [f atEnd] whileFalse: [formList add: (self new readFromOldFormat: f)]] 88418 ifFalse: [ 88419 fileCode = 2 ifFalse: [self error: 'unknown Form file format'. ^ formList]. 88420 [f atEnd] whileFalse: [formList add: (self new readFrom: f)]]. 88421 f close. 88422 ^ formList 88423! ! 88424 88425!DisplayObject class methodsFor: 'filein/out'! 88426writeCollection: coll onFileNamed: fileName 88427 "Saves a collection of Forms on the file fileName in the format: 88428 fileCode, {depth, extent, offset, bits}." 88429 | file | 88430 file := FileStream newFileNamed: fileName. 88431 file binary. 88432 file nextPut: 2. "file code = 2" 88433 coll do: [:f | f writeOn: file]. 88434 file close 88435" 88436 | f c | c := OrderedCollection new. 88437[(f := Form fromUser) boundingBox area>25] whileTrue: [c add: f]. 88438Form writeCollection: c onFileNamed: 'test.forms'. 88439c := Form collectionFromFileNamed: 'test.forms'. 884401 to: c size do: [:i | (c at: i) displayAt: 0@(i*100)]. 88441"! ! 88442CharacterScanner subclass: #DisplayScanner 88443 instanceVariableNames: 'bitBlt lineY runX foregroundColor backgroundColor fillBlt lineHeight paragraph paragraphColor morphicOffset ignoreColorChanges' 88444 classVariableNames: '' 88445 poolDictionaries: '' 88446 category: 'Graphics-Text'! 88447!DisplayScanner commentStamp: '<historical>' prior: 0! 88448My instances are used to scan text and display it on the screen or in a hidden form.! 88449 88450 88451!DisplayScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 12:51'! 88452paddedSpace 88453 "Each space is a stop condition when the alignment is right justified. 88454 Padding must be added to the base width of the space according to 88455 which space in the line this space is and according to the amount of 88456 space that remained at the end of the line when it was composed." 88457 88458 spaceCount := spaceCount + 1. 88459 destX := destX + spaceWidth + (line justifiedPadFor: spaceCount font: font). 88460 lastIndex := lastIndex + 1. 88461 ^ false! ! 88462 88463 88464!DisplayScanner methodsFor: 'mvc-compatibility' stamp: 'lr 7/4/2009 10:42'! 88465displayLines: linesInterval in: aParagraph clippedBy: visibleRectangle 88466 "The central display routine. The call on the primitive 88467 (scanCharactersFrom:to:in:rightX:) will be interrupted according to an 88468 array of stop conditions passed to the scanner at which time the code to 88469 handle the stop condition is run and the call on the primitive continued 88470 until a stop condition returns true (which means the line has 88471 terminated)." 88472 "leftInRun is the # of characters left to scan in the current run; 88473 when 0, it is time to call 'self setStopConditions'" 88474 | runLength done stopCondition leftInRun startIndex string lastPos | 88475 morphicOffset := 0 @ 0. 88476 leftInRun := 0. 88477 self 88478 initializeFromParagraph: aParagraph 88479 clippedBy: visibleRectangle. 88480 ignoreColorChanges := false. 88481 paragraph := aParagraph. 88482 foregroundColor := paragraphColor := aParagraph foregroundColor. 88483 backgroundColor := aParagraph backgroundColor. 88484 aParagraph backgroundColor isTransparent 88485 ifTrue: [ fillBlt := nil ] 88486 ifFalse: 88487 [ fillBlt := bitBlt copy. "Blt to fill spaces, tabs, margins" 88488 fillBlt 88489 sourceForm: nil; 88490 sourceOrigin: 0 @ 0. 88491 fillBlt fillColor: aParagraph backgroundColor ]. 88492 rightMargin := aParagraph rightMarginForDisplay. 88493 lineY := aParagraph topAtLineIndex: linesInterval first. 88494 bitBlt destForm 88495 deferUpdatesIn: visibleRectangle 88496 while: 88497 [ linesInterval do: 88498 [ :lineIndex | 88499 line := aParagraph lines at: lineIndex. 88500 lastIndex := line first. 88501 self setStopConditions. " causes an assignment to inst var. alignment " 88502 leftMargin := aParagraph 88503 leftMarginForDisplayForLine: lineIndex 88504 alignment: (alignment ifNil: [ textStyle alignment ]). 88505 destX := runX := leftMargin. 88506 line := aParagraph lines at: lineIndex. 88507 lineHeight := line lineHeight. 88508 fillBlt == nil ifFalse: 88509 [ fillBlt 88510 destX: visibleRectangle left 88511 destY: lineY 88512 width: visibleRectangle width 88513 height: lineHeight; 88514 copyBits ]. 88515 lastIndex := line first. 88516 leftInRun <= 0 ifTrue: 88517 [ self setStopConditions. "also sets the font" 88518 leftInRun := text runLengthFor: line first ]. 88519 destY := lineY + line baseline - font ascent. "Should have happened in setFont" 88520 runLength := leftInRun. 88521 runStopIndex := lastIndex + (runLength - 1) min: line last. 88522 leftInRun := leftInRun - (runStopIndex - lastIndex + 1). 88523 spaceCount := 0. 88524 done := false. 88525 string := text string. 88526 self handleIndentation. 88527 [ done ] whileFalse: 88528 [ startIndex := lastIndex. 88529 lastPos := destX @ destY. 88530 stopCondition := self 88531 scanCharactersFrom: lastIndex 88532 to: runStopIndex 88533 in: string 88534 rightX: rightMargin 88535 stopConditions: stopConditions 88536 kern: kern. 88537 lastIndex >= startIndex ifTrue: 88538 [ font 88539 displayString: string 88540 on: bitBlt 88541 from: startIndex 88542 to: lastIndex 88543 at: lastPos 88544 kern: kern ]. 88545 "see setStopConditions for stopping conditions for displaying." 88546 done := self perform: stopCondition ]. 88547 fillBlt == nil ifFalse: 88548 [ fillBlt 88549 destX: destX 88550 destY: lineY 88551 width: visibleRectangle right - destX 88552 height: lineHeight; 88553 copyBits ]. 88554 lineY := lineY + lineHeight ] ]! ! 88555 88556!DisplayScanner methodsFor: 'mvc-compatibility' stamp: 'pavel.krivanek 11/21/2008 16:52'! 88557initializeFromParagraph: aParagraph clippedBy: clippingRectangle 88558 super 88559 initializeFromParagraph: aParagraph 88560 clippedBy: clippingRectangle. 88561 bitBlt := UIManager default grafPort toForm: aParagraph destinationForm. 88562 bitBlt 88563 sourceX: 0; 88564 width: 0. "Init BitBlt so that the first call to a primitive will not fail" 88565 bitBlt combinationRule: (Display depth = 1 88566 ifTrue: [ aParagraph rule ] 88567 ifFalse: [ Form paint ]). 88568 bitBlt colorMap: (Bitmap 88569 with: 0 88570 with: (bitBlt destForm pixelValueFor: aParagraph foregroundColor)). "Assumes 1-bit deep fonts" 88571 bitBlt clipRect: clippingRectangle! ! 88572 88573 88574!DisplayScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 88575displayLine: textLine offset: offset leftInRun: leftInRun 88576 "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." 88577 | done stopCondition nowLeftInRun startIndex string lastPos | 88578 line := textLine. 88579 morphicOffset := offset. 88580 lineY := line top + offset y. 88581 lineHeight := line lineHeight. 88582 rightMargin := line rightMargin + offset x. 88583 lastIndex := line first. 88584 leftInRun <= 0 ifTrue: [ self setStopConditions ]. 88585 leftMargin := (line leftMarginForAlignment: alignment) + offset x. 88586 destX := runX := leftMargin. 88587 fillBlt == nil ifFalse: 88588 [ "Not right" 88589 fillBlt 88590 destX: line left 88591 destY: lineY 88592 width: line width left 88593 height: lineHeight; 88594 copyBits ]. 88595 lastIndex := line first. 88596 leftInRun <= 0 88597 ifTrue: [ nowLeftInRun := text runLengthFor: lastIndex ] 88598 ifFalse: [ nowLeftInRun := leftInRun ]. 88599 destY := lineY + line baseline - font ascent. 88600 runStopIndex := lastIndex + (nowLeftInRun - 1) min: line last. 88601 spaceCount := 0. 88602 done := false. 88603 string := text string. 88604 [ done ] whileFalse: 88605 [ startIndex := lastIndex. 88606 lastPos := destX @ destY. 88607 stopCondition := self 88608 scanCharactersFrom: lastIndex 88609 to: runStopIndex 88610 in: string 88611 rightX: rightMargin 88612 stopConditions: stopConditions 88613 kern: kern. 88614 lastIndex >= startIndex ifTrue: 88615 [ font 88616 displayString: string 88617 on: bitBlt 88618 from: startIndex 88619 to: lastIndex 88620 at: lastPos 88621 kern: kern ]. 88622 "see setStopConditions for stopping conditions for displaying." 88623 done := self perform: stopCondition. 88624 lastIndex > runStopIndex ifTrue: [ done := true ] ]. 88625 ^ runStopIndex - lastIndex "Number of characters remaining in the current run"! ! 88626 88627!DisplayScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 88628placeEmbeddedObject: anchoredMorph 88629 anchoredMorph relativeTextAnchorPosition ifNotNil: 88630 [ anchoredMorph position: anchoredMorph relativeTextAnchorPosition + (anchoredMorph owner textBounds origin x @ 0) - (0 @ morphicOffset y) + (0 @ lineY). 88631 ^ true ]. 88632 (super placeEmbeddedObject: anchoredMorph) ifFalse: [ ^ false ]. 88633 anchoredMorph isMorph 88634 ifTrue: 88635 [ anchoredMorph position: (destX - anchoredMorph width) @ lineY - morphicOffset ] 88636 ifFalse: 88637 [ destY := lineY. 88638 runX := destX. 88639 anchoredMorph 88640 displayOn: bitBlt destForm 88641 at: (destX - anchoredMorph width) @ destY 88642 clippingBox: bitBlt clipRect ]. 88643 ^ true! ! 88644 88645 88646!DisplayScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! 88647cr 88648 "When a carriage return is encountered, simply increment the pointer 88649 into the paragraph." 88650 lastIndex := lastIndex + 1. 88651 ^ false! ! 88652 88653!DisplayScanner methodsFor: 'stop conditions' stamp: 'di 9/3/2000 16:24'! 88654crossedX 88655 "This condition will sometimes be reached 'legally' during display, when, 88656 for instance the space that caused the line to wrap actually extends over 88657 the right boundary. This character is allowed to display, even though it 88658 is technically outside or straddling the clipping ectangle since it is in 88659 the normal case not visible and is in any case appropriately clipped by 88660 the scanner." 88661 88662 ^ true ! ! 88663 88664!DisplayScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! 88665endOfRun 88666 "The end of a run in the display case either means that there is actually 88667 a change in the style (run code) to be associated with the string or the 88668 end of this line has been reached." 88669 | runLength | 88670 lastIndex = line last ifTrue: [ ^ true ]. 88671 runX := destX. 88672 runLength := text runLengthFor: (lastIndex := lastIndex + 1). 88673 runStopIndex := lastIndex + (runLength - 1) min: line last. 88674 self setStopConditions. 88675 ^ false! ! 88676 88677!DisplayScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! 88678plainTab 88679 | oldX | 88680 oldX := destX. 88681 super plainTab. 88682 fillBlt == nil ifFalse: 88683 [ fillBlt 88684 destX: oldX 88685 destY: destY 88686 width: destX - oldX 88687 height: font height; 88688 copyBits ]! ! 88689 88690!DisplayScanner methodsFor: 'stop conditions' stamp: 'yo 10/4/2002 20:43'! 88691setStopConditions 88692 "Set the font and the stop conditions for the current run." 88693 88694 self setFont. 88695 self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]). 88696 88697" 88698 alignment = Justified ifTrue: [ 88699 stopConditions == DefaultStopConditions 88700 ifTrue:[stopConditions _ stopConditions copy]. 88701 stopConditions at: Space asciiValue + 1 put: #paddedSpace] 88702"! ! 88703 88704!DisplayScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! 88705tab 88706 self plainTab. 88707 lastIndex := lastIndex + 1. 88708 ^ false! ! 88709 88710 88711!DisplayScanner methodsFor: 'private' stamp: 'ar 5/17/2000 19:26'! 88712setDestForm: df 88713 bitBlt setDestForm: df.! ! 88714 88715!DisplayScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 88716setFont 88717 foregroundColor := paragraphColor. 88718 super setFont. "Sets font and emphasis bits, and maybe foregroundColor" 88719 font 88720 installOn: bitBlt 88721 foregroundColor: foregroundColor 88722 backgroundColor: Color transparent. 88723 text ifNotNil: [ destY := lineY + line baseline - font ascent ]! ! 88724 88725!DisplayScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 88726setPort: aBitBlt 88727 "Install the BitBlt to use" 88728 bitBlt := aBitBlt. 88729 bitBlt 88730 sourceX: 0; 88731 width: 0. "Init BitBlt so that the first call to a primitive will not fail" 88732 bitBlt sourceForm: nil "Make sure font installation won't be confused"! ! 88733 88734!DisplayScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 88735text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode 88736 text := t. 88737 textStyle := ts. 88738 foregroundColor := paragraphColor := foreColor. 88739 (backgroundColor := backColor) isTransparent ifFalse: 88740 [ fillBlt := blt. 88741 fillBlt fillColor: backgroundColor ]. 88742 ignoreColorChanges := shadowMode! ! 88743 88744!DisplayScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 88745textColor: textColor 88746 ignoreColorChanges ifTrue: [ ^ self ]. 88747 foregroundColor := textColor! ! 88748 88749"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 88750 88751DisplayScanner class 88752 instanceVariableNames: ''! 88753 88754!DisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:39'! 88755defaultFont 88756 ^ TextStyle defaultFont! ! 88757Form subclass: #DisplayScreen 88758 instanceVariableNames: 'clippingBox extraRegions' 88759 classVariableNames: 'DeferringUpdates DisplayChangeSignature LastScreenModeSelected ScreenSave' 88760 poolDictionaries: '' 88761 category: 'Graphics-Display Objects'! 88762!DisplayScreen commentStamp: '<historical>' prior: 0! 88763There is only one instance of me, Display. It is a global and is used to handle general user requests to deal with the whole display screen. 88764 Although I offer no protocol, my name provides a way to distinguish this special instance from all other Forms. This is useful, for example, in dealing with saving and restoring the system. 88765 To change the depth of your Display... 88766 Display newDepth: 16. 88767 Display newDepth: 8. 88768 Display newDepth: 1. 88769Valid display depths are 1, 2, 4, 8, 16 and 32. It is suggested that you run with your monitors setting the same, for better speed and color fidelity. Note that this can add up to 4Mb for the Display form. Finally, note that newDepth: ends by executing a 'ControlManager restore' which currently terminates the active process, so nothing that follows in the doit will get executed. 88770 88771Depths 1, 2, 4 and 8 bits go through a color map to put color on the screen, but 16 and 32-bit color use the pixel values directly for RGB color (5 and 8 bits per, respectivlely). The color choice an be observed by executing Color fromUser in whatever depth you are using. 88772! 88773 88774 88775!DisplayScreen methodsFor: 'blitter defaults' stamp: 'ar 5/28/2000 12:01'! 88776defaultBitBltClass 88777 "Return the BitBlt version to use when I am active" 88778 ^BitBlt! ! 88779 88780!DisplayScreen methodsFor: 'blitter defaults' stamp: 'ar 5/28/2000 12:02'! 88781defaultCanvasClass 88782 "Return the WarpBlt version to use when I am active" 88783 ^FormCanvas! ! 88784 88785!DisplayScreen methodsFor: 'blitter defaults' stamp: 'ar 5/28/2000 12:01'! 88786defaultWarpBltClass 88787 "Return the WarpBlt version to use when I am active" 88788 ^WarpBlt! ! 88789 88790 88791!DisplayScreen methodsFor: 'disk i/o' stamp: 'tk 9/28/2000 15:41'! 88792objectForDataStream: refStrm 88793 | dp | 88794 "I am about to be written on an object file. Write a reference to the Display in the other system instead. " 88795 88796 "A path to me" 88797 dp := DiskProxy global: #Display selector: #yourself args: #(). 88798 refStrm replace: self with: dp. 88799 ^ dp 88800! ! 88801 88802 88803!DisplayScreen methodsFor: 'displaying' stamp: 'ar 4/19/2001 05:44'! 88804addExtraRegion: aRectangle for: regionDrawer 88805 "Register the given rectangle as a region which is drawn by the specified region drawer. The region will be excluded from any updates when #forceDamageToScreen: is called. Note that the rectangle is only valid for a single update cycle; once #forceDamageToScreen: has been called, the region drawer and its region are being removed from the list" 88806 extraRegions ifNil:[extraRegions := #()]. 88807 extraRegions := extraRegions copyWith: (Array with: regionDrawer with: aRectangle). 88808! ! 88809 88810!DisplayScreen methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:07'! 88811copyBits: rect from: sf at: destOrigin clippingBox: clipRect rule: cr fillColor: hf 88812 (BitBlt current 88813 destForm: self 88814 sourceForm: sf 88815 fillColor: hf 88816 combinationRule: cr 88817 destOrigin: destOrigin 88818 sourceOrigin: rect origin 88819 extent: rect extent 88820 clipRect: (clipRect intersect: clippingBox)) copyBits! ! 88821 88822!DisplayScreen methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:07'! 88823copyBits: rect from: sf at: destOrigin clippingBox: clipRect rule: cr fillColor: hf map: map 88824 ((BitBlt current 88825 destForm: self 88826 sourceForm: sf 88827 fillColor: hf 88828 combinationRule: cr 88829 destOrigin: destOrigin 88830 sourceOrigin: rect origin 88831 extent: rect extent 88832 clipRect: (clipRect intersect: clippingBox)) colorMap: map) copyBits! ! 88833 88834!DisplayScreen methodsFor: 'displaying' stamp: 'jm 5/22/1998 01:23'! 88835flash: aRectangle 88836 "Flash the area of the screen defined by the given rectangle." 88837 88838 self reverse: aRectangle. 88839 self forceDisplayUpdate. 88840 (Delay forMilliseconds: 100) wait. 88841 self reverse: aRectangle. 88842 self forceDisplayUpdate. 88843! ! 88844 88845!DisplayScreen methodsFor: 'displaying' stamp: 'RAA 6/2/2000 12:09'! 88846flash: aRectangle andWait: msecs 88847 "Flash the area of the screen defined by the given rectangle." 88848 88849 self reverse: aRectangle. 88850 self forceDisplayUpdate. 88851 (Delay forMilliseconds: msecs) wait. 88852 self reverse: aRectangle. 88853 self forceDisplayUpdate. 88854 (Delay forMilliseconds: msecs) wait. 88855! ! 88856 88857!DisplayScreen methodsFor: 'displaying' stamp: 'sw 1/1/2005 01:31'! 88858flashAll: rectangleList andWait: msecs 88859 "Flash the areas of the screen defined by the given rectangles." 88860 88861 rectangleList do: [:aRectangle | self reverse: aRectangle]. 88862 self forceDisplayUpdate. 88863 (Delay forMilliseconds: msecs) wait. 88864 rectangleList do: [:aRectangle | self reverse: aRectangle]. 88865 self forceDisplayUpdate. 88866 (Delay forMilliseconds: msecs) wait. 88867! ! 88868 88869!DisplayScreen methodsFor: 'displaying' stamp: 'PeterHugossonMiller 9/3/2009 01:14'! 88870forceDamageToScreen: allDamage 88871 "Force all the damage rects to the screen." 88872 | rectList excluded remaining regions | 88873 rectList := allDamage. 88874 "Note: Reset extra regions at the beginning to prevent repeated errors" 88875 regions := extraRegions. 88876 extraRegions := nil. 88877 regions ifNotNil:[ 88878 "exclude extra regions" 88879 regions do:[:drawerAndRect| 88880 excluded := drawerAndRect at: 2. 88881 remaining := Array new writeStream. 88882 rectList do:[:r| 88883 remaining nextPutAll:(r areasOutside: excluded)]. 88884 rectList := remaining contents]. 88885 ]. 88886 rectList do:[:r| self forceToScreen: r]. 88887 regions ifNotNil:[ 88888 "Have the drawers paint what is needed" 88889 regions do:[:drawerAndRect| (drawerAndRect at: 1) forceToScreen]. 88890 ].! ! 88891 88892 88893!DisplayScreen methodsFor: 'initialization' stamp: 'ar 5/26/2000 00:07'! 88894release 88895 "I am no longer Display. Release any resources if necessary"! ! 88896 88897!DisplayScreen methodsFor: 'initialization' stamp: 'ar 5/28/2000 11:25'! 88898shutDown 88899 "Minimize Display memory saved in image" 88900 self setExtent: 240@120 depth: depth! ! 88901 88902 88903!DisplayScreen methodsFor: 'other'! 88904boundingBox 88905 clippingBox == nil 88906 ifTrue: [clippingBox := super boundingBox]. 88907 ^ clippingBox! ! 88908 88909!DisplayScreen methodsFor: 'other' stamp: 'alain.plantec 6/10/2008 22:29'! 88910clippingTo: aRect do: aBlock 88911 "Display clippingTo: Rectangle fromUser do:" 88912 | saveClip | 88913 saveClip := clippingBox. 88914 clippingBox := aRect. 88915 aBlock value. 88916 clippingBox := saveClip! ! 88917 88918!DisplayScreen methodsFor: 'other' stamp: 'hmm 6/18/2000 19:16'! 88919deferUpdates: aBoolean 88920 | wasDeferred | 88921 "Set the deferUpdates flag in the virtual machine. When this flag is true, BitBlt operations on the Display are not automatically propagated to the screen. If this underlying platform does not support deferred updates, this primitive will fail. Answer whether updates were deferred before if the primitive succeeds, nil if it fails." 88922 88923 wasDeferred := DeferringUpdates == true. 88924 DeferringUpdates := aBoolean. 88925 ^(self primitiveDeferUpdates: aBoolean) ifNotNil: [wasDeferred]! ! 88926 88927!DisplayScreen methodsFor: 'other' stamp: 'hmm 2/2/2001 10:14'! 88928deferUpdatesIn: aRectangle while: aBlock 88929 | result | 88930 (self deferUpdates: true) ifTrue: [^aBlock value]. 88931 result := aBlock value. 88932 self deferUpdates: false. 88933 self forceToScreen: aRectangle. 88934 ^result! ! 88935 88936!DisplayScreen methodsFor: 'other' stamp: 'RAA 11/27/1999 15:48'! 88937displayChangeSignature 88938 88939 ^DisplayChangeSignature! ! 88940 88941!DisplayScreen methodsFor: 'other' stamp: 'jm 5/21/1998 23:48'! 88942forceDisplayUpdate 88943 "On platforms that buffer screen updates, force the screen to be updated immediately. On other platforms, or if the primitive is not implemented, do nothing." 88944 88945 <primitive: 231> 88946 "do nothing if primitive fails"! ! 88947 88948!DisplayScreen methodsFor: 'other' stamp: 'ar 2/11/1999 18:14'! 88949forceToScreen 88950 "Force the entire display area to the screen" 88951 ^self forceToScreen: self boundingBox! ! 88952 88953!DisplayScreen methodsFor: 'other' stamp: 'jm 5/19/1998 17:50'! 88954forceToScreen: aRectangle 88955 "Force the given rectangular section of the Display to be copied to the screen. The primitive call does nothing if the primitive is not implemented. Typically used when the deferUpdates flag in the virtual machine is on; see deferUpdates:." 88956 88957 self primShowRectLeft: aRectangle left 88958 right: aRectangle right 88959 top: aRectangle top 88960 bottom: aRectangle bottom. 88961! ! 88962 88963!DisplayScreen methodsFor: 'other'! 88964fullBoundingBox 88965 ^ super boundingBox! ! 88966 88967!DisplayScreen methodsFor: 'other'! 88968fullScreen "Display fullScreen" 88969 88970 ScreenSave notNil ifTrue: [Display := ScreenSave]. 88971 clippingBox := super boundingBox! ! 88972 88973!DisplayScreen methodsFor: 'other' stamp: 'sd 6/7/2003 19:46'! 88974fullScreenMode: aBoolean 88975 "On platforms that support it, set full-screen mode to the value of the argument. (Note: you'll need to restore the Display after calling this primitive." 88976 "Display fullScreenMode: true. Display newDepth: Display depth" 88977 88978 <primitive: 233> 88979 self primitiveFailed 88980! ! 88981 88982!DisplayScreen methodsFor: 'other'! 88983height 88984 ^ self boundingBox height! ! 88985 88986!DisplayScreen methodsFor: 'other' stamp: 'alain.plantec 5/30/2008 12:43'! 88987newDepth: pixelSize 88988 " 88989 Display newDepth: 8. 88990 Display newDepth: 1 88991 " 88992 (self supportsDisplayDepth: pixelSize) 88993 ifFalse: [^ self inform: 'Display depth ' , pixelSize printString , ' is not supported on this system']. 88994 self newDepthNoRestore: pixelSize. 88995 self restore! ! 88996 88997!DisplayScreen methodsFor: 'other' stamp: 'hmm 6/18/2000 19:14'! 88998primitiveDeferUpdates: aBoolean 88999 "Set the deferUpdates flag in the virtual machine. When this flag is true, BitBlt operations on the Display are not automatically propagated to the screen. If this underlying platform does not support deferred updates, this primitive will fail. Answer the receiver if the primitive succeeds, nil if it fails." 89000 89001 <primitive: 126> 89002 ^ nil "answer nil if primitive fails" 89003! ! 89004 89005!DisplayScreen methodsFor: 'other'! 89006replacedBy: aForm do: aBlock 89007 "Permits normal display to draw on aForm instead of the display." 89008 89009 ScreenSave := self. 89010 Display := aForm. 89011 aBlock value. 89012 Display := self. 89013 ScreenSave := nil.! ! 89014 89015!DisplayScreen methodsFor: 'other' stamp: 'alain.plantec 5/30/2008 12:52'! 89016restore 89017 World fullRepaintNeeded! ! 89018 89019!DisplayScreen methodsFor: 'other' stamp: 'alain.plantec 5/30/2008 12:55'! 89020restoreAfter: aBlock 89021 "Evaluate the block, wait for a mouse click, and then restore the screen." 89022 89023 aBlock value. 89024 Sensor waitButton. 89025 self restore! ! 89026 89027!DisplayScreen methodsFor: 'other' stamp: 'ar 5/17/2001 21:02'! 89028supportedDisplayDepths 89029 "Return all pixel depths supported on the current host platform." 89030 ^#(1 2 4 8 16 32 -1 -2 -4 -8 -16 -32) select: [:d | self supportsDisplayDepth: d]! ! 89031 89032!DisplayScreen methodsFor: 'other' stamp: 'ar 5/5/1999 23:45'! 89033supportsDisplayDepth: pixelDepth 89034 "Return true if this pixel depth is supported on the current host platform. 89035 Primitive. Optional." 89036 <primitive: 91> 89037 ^#(1 2 4 8 16 32) includes: pixelDepth! ! 89038 89039!DisplayScreen methodsFor: 'other'! 89040usableArea 89041 "Answer the usable area of the receiver. 5/22/96 sw." 89042 89043 ^ self boundingBox deepCopy! ! 89044 89045!DisplayScreen methodsFor: 'other'! 89046width 89047 ^ self boundingBox width! ! 89048 89049 89050!DisplayScreen methodsFor: 'screen managing' stamp: 'RobRothwell 2/23/2009 22:21'! 89051fullScreen: aBoolean 89052 89053 Display fullScreenMode: (LastScreenModeSelected := aBoolean). 89054 DisplayScreen checkForNewScreenSize. 89055 World restoreMorphicDisplay! ! 89056 89057!DisplayScreen methodsFor: 'screen managing' stamp: 'RobRothwell 2/23/2009 22:22'! 89058fullScreenOff 89059 89060 self fullScreen: false! ! 89061 89062!DisplayScreen methodsFor: 'screen managing' stamp: 'RobRothwell 2/23/2009 22:23'! 89063fullScreenOn 89064 89065 self fullScreen: true! ! 89066 89067!DisplayScreen methodsFor: 'screen managing' stamp: 'RobRothwell 2/23/2009 22:23'! 89068isFullScreen 89069 ^ self lastScreenModeSelected.! ! 89070 89071!DisplayScreen methodsFor: 'screen managing' stamp: 'RobRothwell 2/23/2009 22:22'! 89072lastScreenModeSelected 89073 ^ LastScreenModeSelected 89074 ifNil: [LastScreenModeSelected := false]! ! 89075 89076!DisplayScreen methodsFor: 'screen managing' stamp: 'RobRothwell 2/23/2009 22:23'! 89077toggleFullScreen 89078 self fullScreen: self isFullScreen not! ! 89079 89080 89081!DisplayScreen methodsFor: 'testing' stamp: 'ar 5/25/2000 23:34'! 89082isDisplayScreen 89083 ^true! ! 89084 89085 89086!DisplayScreen methodsFor: 'private'! 89087beDisplay 89088 "Primitive. Tell the interpreter to use the receiver as the current display 89089 image. Fail if the form is too wide to fit on the physical display. 89090 Essential. See Object documentation whatIsAPrimitive." 89091 89092 <primitive: 102> 89093 self primitiveFailed! ! 89094 89095!DisplayScreen methodsFor: 'private' stamp: 'di 3/3/1999 10:00'! 89096copyFrom: aForm 89097 "Take on all state of aForm, with complete sharing" 89098 89099 super copyFrom: aForm. 89100 clippingBox := super boundingBox! ! 89101 89102!DisplayScreen methodsFor: 'private' stamp: 'adrian_lienhard 7/18/2009 15:54'! 89103findAnyDisplayDepth 89104 "Return any display depth that is supported on this system." 89105 ^self findAnyDisplayDepthIfNone:[ 89106 "Ugh .... now this is a biggie - a system that does not support 89107 any of the display depths at all." 89108 Smalltalk 89109 logError:'Fatal error: This system has no support for any display depth at all.' 89110 inContext: thisContext 89111 to: 'PharoDebug.log'. 89112 Smalltalk quitPrimitive. "There is no way to continue from here" 89113 ].! ! 89114 89115!DisplayScreen methodsFor: 'private' stamp: 'ar 5/17/2001 21:03'! 89116findAnyDisplayDepthIfNone: aBlock 89117 "Return any display depth that is supported on this system. 89118 If there is none, evaluate aBlock." 89119 #(1 2 4 8 16 32 -1 -2 -4 -8 -16 -32) do:[:bpp| 89120 (self supportsDisplayDepth: bpp) ifTrue:[^bpp]. 89121 ]. 89122 ^aBlock value! ! 89123 89124!DisplayScreen methodsFor: 'private' stamp: 'alain.plantec 5/30/2008 12:42'! 89125newDepthNoRestore: pixelSize 89126 "Change depths. Check if there is enough space!! , di" 89127 | area need | 89128 pixelSize = depth 89129 ifTrue: [^ self"no change"]. 89130 pixelSize abs < self depth 89131 ifFalse: ["Make sure there is enough space" 89132 area := Display boundingBox area. 89133 "pixels" 89134 need := area * (pixelSize abs - self depth) // 8 + Smalltalk lowSpaceThreshold. 89135 "new bytes needed" 89136 (Smalltalk garbageCollectMost <= need 89137 and: [Smalltalk garbageCollect <= need]) 89138 ifTrue: [self error: 'Insufficient free space']]. 89139 self setExtent: self extent depth: pixelSize. 89140 DisplayScreen startUp! ! 89141 89142!DisplayScreen methodsFor: 'private' stamp: 'jm 6/3/1998 13:00'! 89143primRetryShowRectLeft: l right: r top: t bottom: b 89144 "Copy the given rectangular section of the Display to to the screen. This primitive is not implemented on all platforms. Do nothing if it fails. " 89145 89146 <primitive: 127> 89147 "do nothing if primitive fails" 89148! ! 89149 89150!DisplayScreen methodsFor: 'private' stamp: 'jm 6/3/1998 13:02'! 89151primShowRectLeft: l right: r top: t bottom: b 89152 "Copy the given rectangular section of the Display to to the screen. This primitive is not implemented on all platforms. If this fails, retry integer coordinates." 89153 89154 <primitive: 127> 89155 "if this fails, coerce coordinates to integers and try again" 89156 self primRetryShowRectLeft: l truncated 89157 right: r rounded 89158 top: t truncated 89159 bottom: b rounded. 89160! ! 89161 89162!DisplayScreen methodsFor: 'private' stamp: 'bf 5/16/2006 11:35'! 89163setExtent: aPoint depth: bitsPerPixel "DisplayScreen startUp" 89164 "This method is critical. If the setExtent fails, there will be no 89165 proper display on which to show the error condition..." 89166 "ar 5/1/1999: ... and that is exactly why we check for the available display depths first." 89167 89168 "RAA 27 Nov 99 - if depth and extent are the same and acceptable, why go through this. 89169 also - record when we change so worlds can tell if it is time to repaint" 89170 89171 (depth == bitsPerPixel and: [aPoint = self extent and: 89172 [self supportsDisplayDepth: bitsPerPixel]]) ifFalse: [ 89173 bits := nil. "Free up old bitmap in case space is low" 89174 DisplayChangeSignature := (DisplayChangeSignature ifNil: [0]) + 1. 89175 (self supportsDisplayDepth: bitsPerPixel) 89176 ifTrue:[super setExtent: aPoint depth: bitsPerPixel] 89177 ifFalse:[(self supportsDisplayDepth: bitsPerPixel negated) 89178 ifTrue:[super setExtent: aPoint depth: bitsPerPixel negated] 89179 ifFalse:["Search for a suitable depth" 89180 super setExtent: aPoint depth: self findAnyDisplayDepth]]. 89181 ]. 89182 clippingBox := super boundingBox! ! 89183 89184"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 89185 89186DisplayScreen class 89187 instanceVariableNames: ''! 89188 89189!DisplayScreen class methodsFor: 'display box access'! 89190boundingBox 89191 "Answer the bounding box for the form representing the current display 89192 screen." 89193 89194 ^Display boundingBox! ! 89195 89196!DisplayScreen class methodsFor: 'display box access' stamp: 'marcus.denker 9/17/2008 20:46'! 89197checkForNewScreenSize 89198 "Check whether the screen size has changed and if so take appropriate 89199 actions " 89200 Display extent = DisplayScreen actualScreenSize ifTrue: [^ self]. 89201 DisplayScreen startUp. 89202 World restoreMorphicDisplay. 89203 World repositionFlapsAfterScreenSizeChange! ! 89204 89205!DisplayScreen class methodsFor: 'display box access' stamp: 'pavel.krivanek 12/3/2008 21:00'! 89206depth: depthInteger width: widthInteger height: heightInteger fullscreen: aBoolean 89207 "Force Squeak's window (if there's one) into a new size and depth." 89208 "DisplayScreen depth: 8 width: 1024 height: 768 fullscreen: false" 89209 89210 <primitive: 92> 89211 self primitiveFailed ! ! 89212 89213 89214!DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 2/5/2001 17:24'! 89215actualScreenDepth 89216 <primitive: 'primitiveScreenDepth'> 89217 ^ Display depth! ! 89218 89219!DisplayScreen class methodsFor: 'snapshots'! 89220actualScreenSize 89221 <primitive: 106> 89222 ^ 640@480! ! 89223 89224!DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 5/28/2000 11:26'! 89225shutDown 89226 "Minimize Display memory saved in image" 89227 Display shutDown.! ! 89228 89229!DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 5/17/2001 15:50'! 89230startUp "DisplayScreen startUp" 89231 Display setExtent: self actualScreenSize depth: Display nativeDepth. 89232 Display beDisplay! ! 89233DisplayObject subclass: #DisplayText 89234 instanceVariableNames: 'text textStyle offset form foreColor backColor' 89235 classVariableNames: '' 89236 poolDictionaries: 'TextConstants' 89237 category: 'Graphics-Display Objects'! 89238!DisplayText commentStamp: '<historical>' prior: 0! 89239I represent Text whose emphasis changes are mapped to a set of fonts. My instances have an offset used in determining screen placement for displaying. They get used two different ways in the system. In the user interface, they mainly hold onto some text which is viewed by some form of ParagraphEditor. However, as a DisplayObject, they may need to display efficiently, so my instances have a cache for the bits.! 89240 89241 89242!DisplayText methodsFor: 'accessing'! 89243alignedTo: alignPointSelector 89244 "Return a copy with offset according to alignPointSelector which is one of... 89245 #(topLeft, topCenter, topRight, leftCenter, center, etc)" 89246 | boundingBox | 89247 boundingBox := 0@0 corner: self form extent. 89248 ^ self shallowCopy offset: (0@0) - (boundingBox perform: alignPointSelector)! ! 89249 89250!DisplayText methodsFor: 'accessing'! 89251fontsUsed 89252 "Return a list of all fonts used currently in this text. 8/19/96 tk" 89253 89254 ^ text runs values asSet collect: [:each | textStyle fontAt: each]! ! 89255 89256!DisplayText methodsFor: 'accessing'! 89257form 89258 "Answer the form into which the receiver's display bits are cached." 89259 89260 form == nil ifTrue: [self composeForm]. 89261 ^form! ! 89262 89263!DisplayText methodsFor: 'accessing' stamp: 'MarcusDenker 9/30/2009 11:53'! 89264form: aForm 89265 form := aForm! ! 89266 89267!DisplayText methodsFor: 'accessing'! 89268lineGrid 89269 "Answer the relative space between lines of the receiver's text." 89270 89271 ^textStyle lineGrid! ! 89272 89273!DisplayText methodsFor: 'accessing'! 89274numberOfLines 89275 "Answer the number of lines of text in the receiver." 89276 89277 ^self height // text lineGrid! ! 89278 89279!DisplayText methodsFor: 'accessing'! 89280offset 89281 "Refer to the comment in DisplayObject|offset." 89282 89283 ^offset! ! 89284 89285!DisplayText methodsFor: 'accessing'! 89286offset: aPoint 89287 "Refer to the comment in DisplayObject|offset:." 89288 89289 offset := aPoint! ! 89290 89291!DisplayText methodsFor: 'accessing'! 89292string 89293 "Answer the string of the characters displayed by the receiver." 89294 89295 ^text string! ! 89296 89297!DisplayText methodsFor: 'accessing'! 89298text 89299 "Answer the text displayed by the receiver." 89300 89301 ^text! ! 89302 89303!DisplayText methodsFor: 'accessing'! 89304text: aText 89305 "Set the receiver to display the argument, aText." 89306 89307 text := aText. 89308 form := nil. 89309 self changed. 89310 ! ! 89311 89312!DisplayText methodsFor: 'accessing'! 89313textStyle 89314 "Answer the style by which the receiver displays its text." 89315 89316 ^textStyle! ! 89317 89318!DisplayText methodsFor: 'accessing'! 89319textStyle: aTextStyle 89320 "Set the style by which the receiver should display its text." 89321 89322 textStyle := aTextStyle. 89323 form := nil. 89324 self changed. 89325 ! ! 89326 89327 89328!DisplayText methodsFor: 'color'! 89329backgroundColor 89330 backColor == nil ifTrue: [^ Color transparent]. 89331 ^ backColor! ! 89332 89333!DisplayText methodsFor: 'color'! 89334foregroundColor 89335 foreColor == nil ifTrue: [^ Color black]. 89336 ^ foreColor! ! 89337 89338!DisplayText methodsFor: 'color'! 89339foregroundColor: cf backgroundColor: cb 89340 foreColor := cf. 89341 backColor := cb! ! 89342 89343 89344!DisplayText methodsFor: 'converting' stamp: 'tk 10/21/97 12:28'! 89345asParagraph 89346 "Answer a Paragraph whose text and style are identical to that of the 89347 receiver." 89348 | para | 89349 para := Paragraph withText: text style: textStyle. 89350 para foregroundColor: foreColor backgroundColor: backColor. 89351 backColor isTransparent ifTrue: [para rule: Form paint]. 89352 ^ para! ! 89353 89354 89355!DisplayText methodsFor: 'display box access'! 89356boundingBox 89357 "Refer to the comment in DisplayObject|boundingBox." 89358 89359 ^self form boundingBox! ! 89360 89361!DisplayText methodsFor: 'display box access'! 89362computeBoundingBox 89363 "Compute minimum enclosing rectangle around characters." 89364 89365 | character font width carriageReturn lineWidth lineHeight | 89366 carriageReturn := Character cr. 89367 width := lineWidth := 0. 89368 font := textStyle defaultFont. 89369 lineHeight := textStyle lineGrid. 89370 1 to: text size do: 89371 [:i | 89372 character := text at: i. 89373 character = carriageReturn 89374 ifTrue: 89375 [lineWidth := lineWidth max: width. 89376 lineHeight := lineHeight + textStyle lineGrid. 89377 width := 0] 89378 ifFalse: [width := width + (font widthOf: character)]]. 89379 lineWidth := lineWidth max: width. 89380 ^offset extent: lineWidth @ lineHeight! ! 89381 89382 89383!DisplayText methodsFor: 'displaying' stamp: 'yo 6/23/2003 20:05'! 89384displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 89385 "For TT font, rule 34 is used if possible." 89386 "Refer to the comment in 89387 DisplayObject|displayOn:at:clippingBox:rule:mask:." 89388 89389 | form1 rule | 89390 form1 := self form. 89391 rule := (ruleInteger = Form over and: [backColor isTransparent]) 89392 ifTrue: [form1 depth = 32 ifTrue: [rule := 34] ifFalse: [Form paint]] 89393 ifFalse: [ruleInteger]. 89394 form1 depth = 32 ifTrue: [rule := 34]. 89395 form1 89396 displayOn: aDisplayMedium 89397 at: aDisplayPoint + offset 89398 clippingBox: clipRectangle 89399 rule: rule 89400 fillColor: aForm! ! 89401 89402!DisplayText methodsFor: 'displaying'! 89403displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 89404 "Refer to the comment in 89405 DisplayObject|displayOn:transformation:clippingBox:align:with:rule:mask:." 89406 89407 | absolutePoint | 89408 absolutePoint := displayTransformation applyTo: relativePoint. 89409 absolutePoint := absolutePoint x asInteger @ absolutePoint y asInteger. 89410 self displayOn: aDisplayMedium 89411 at: absolutePoint - alignmentPoint 89412 clippingBox: clipRectangle 89413 rule: ruleInteger 89414 fillColor: aForm! ! 89415 89416!DisplayText methodsFor: 'displaying'! 89417displayOnPort: aPort at: location 89418 self form displayOnPort: aPort at: location + offset! ! 89419 89420 89421!DisplayText methodsFor: 'private' stamp: 'pavel.krivanek 11/21/2008 16:52'! 89422composeForm 89423 89424 form := UIManager default composeFormFor: self. 89425 ^ form! ! 89426 89427!DisplayText methodsFor: 'private'! 89428setText: aText textStyle: aTextStyle offset: aPoint 89429 89430 text := aText. 89431 textStyle := aTextStyle. 89432 offset := aPoint. 89433 form := nil! ! 89434 89435"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 89436 89437DisplayText class 89438 instanceVariableNames: ''! 89439 89440!DisplayText class methodsFor: 'examples' stamp: 'tk 11/28/2001 16:03'! 89441example 89442 "Continually prints two lines of text wherever you point with the cursor. Terminate by pressing any button on the 89443 mouse." 89444 | tx | 89445 tx := 'this is a line of characters and 89446this is the second line.' asDisplayText. 89447 tx foregroundColor: Color black backgroundColor: Color transparent. 89448 tx := tx alignedTo: #center. 89449 [Sensor anyButtonPressed] 89450 whileFalse: 89451 [tx displayOn: Display at: Sensor cursorPoint] 89452 89453 "DisplayText example."! ! 89454 89455 89456!DisplayText class methodsFor: 'instance creation'! 89457text: aText 89458 "Answer an instance of me such that the text displayed is aText 89459 according to the system's default text style." 89460 89461 ^self new 89462 setText: aText 89463 textStyle: DefaultTextStyle copy 89464 offset: 0 @ 0! ! 89465 89466!DisplayText class methodsFor: 'instance creation'! 89467text: aText textStyle: aTextStyle 89468 "Answer an instance of me such that the text displayed is aText 89469 according to the style specified by aTextStyle." 89470 89471 ^self new 89472 setText: aText 89473 textStyle: aTextStyle 89474 offset: 0 @ 0! ! 89475 89476!DisplayText class methodsFor: 'instance creation'! 89477text: aText textStyle: aTextStyle offset: aPoint 89478 "Answer an instance of me such that the text displayed is aText 89479 according to the style specified by aTextStyle. The display of the 89480 information should be offset by the amount given as the argument, 89481 aPoint." 89482 89483 ^self new 89484 setText: aText 89485 textStyle: aTextStyle 89486 offset: aPoint! ! 89487Object subclass: #DisplayTransform 89488 instanceVariableNames: '' 89489 classVariableNames: '' 89490 poolDictionaries: '' 89491 category: 'Graphics-Transformations'! 89492!DisplayTransform commentStamp: '<historical>' prior: 0! 89493This class represents a base for generic transformations of 2D points between different coordinate systems (including scaling and rotation). The transformations map objects between one coordinate system and another where it is assumed that a nested hierarchy of transformations can be defined. 89494 89495It is assumed that transformations deal with Integer points. All transformations should return Integer coordinates (even though float points may be passed in as argument). 89496 89497Compositions of transformations MUST work in the following order. A 'global' transformation (the argument in #composedWithGlobal:) is defined as a transformation that takes place between the receiver (the 'local') transformation and any 'global' point computations, whereas a 'local' transformation (e.g., the argument in #composedWithLocal:) takes place between the receiver ('global') and any 'local' points. For the transformation methods this means that combining a global and a local transformation will result in the following order: 89498 89499 globalPointToLocal: globalPoint 89500 "globalPoint -> globalTransform -> localTransform -> locaPoint" 89501 ^localTransform globalPointToLocal: 89502 (globalTransform globalPointToLocal: globalPoint) 89503 89504 localPointToGlobal: localPoint 89505 "localPoint -> localTransform -> globalTransform -> globalPoint" 89506 ^globalTransform localPointToGlobal: 89507 (localTransform localPointToGlobal: localPoint) 89508 89509! 89510 89511 89512!DisplayTransform methodsFor: 'accessing' stamp: 'ar 11/2/1998 19:43'! 89513inverseTransformation 89514 "Return the inverse transformation of the receiver" 89515 ^self subclassResponsibility! ! 89516 89517 89518!DisplayTransform methodsFor: 'composing' stamp: 'ar 11/2/1998 16:15'! 89519composedWithGlobal: aTransformation 89520 "Return the composition of the receiver and the global transformation passed in. 89521 A 'global' transformation is defined as a transformation that takes place 89522 between the receiver (the 'local') transformation and any 'global' point 89523 computations, e.g., for the methods 89524 89525 globalPointToLocal: globalPoint 89526 globalPoint -> globalTransform -> localTransform -> locaPoint 89527 89528 localPointToGlobal: localPoint 89529 localPoint -> localTransform -> globalTransform -> globalPoint 89530 89531 " 89532 ^aTransformation composedWithLocal: self! ! 89533 89534!DisplayTransform methodsFor: 'composing' stamp: 'ar 11/2/1998 16:41'! 89535composedWithLocal: aTransformation 89536 "Return the composition of the receiver and the local transformation passed in. 89537 A 'local' transformation is defined as a transformation that takes place 89538 between the receiver (the 'global') transformation and any 'local' point 89539 computations, e.g., for the methods 89540 89541 globalPointToLocal: globalPoint 89542 globalPoint -> globalTransform -> localTransform -> locaPoint 89543 89544 localPointToGlobal: localPoint 89545 localPoint -> localTransform -> globalTransform -> globalPoint 89546 89547 " 89548 self isIdentity ifTrue:[^ aTransformation]. 89549 aTransformation isIdentity ifTrue:[^ self]. 89550 ^ CompositeTransform new globalTransform: self 89551 localTransform: aTransformation! ! 89552 89553 89554!DisplayTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 19:59'! 89555asCompositeTransform 89556 "Represent the receiver as a composite transformation" 89557 ^CompositeTransform new 89558 globalTransform: self 89559 localTransform: self species identity! ! 89560 89561!DisplayTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:01'! 89562asMatrixTransform2x3 89563 "Represent the receiver as a 2x3 matrix transformation" 89564 ^self subclassResponsibility! ! 89565 89566 89567!DisplayTransform methodsFor: 'initialize' stamp: 'ar 11/2/1998 23:18'! 89568setIdentity 89569 "Initialize the receiver to the identity transformation (e.g., not affecting points)" 89570 ^self subclassResponsibility! ! 89571 89572 89573!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:47'! 89574isCompositeTransform 89575 "Return true if the receiver is a composite transformation. 89576 Composite transformations may have impact on the accuracy." 89577 ^false! ! 89578 89579!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 16:17'! 89580isIdentity 89581 "Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself." 89582 ^self subclassResponsibility! ! 89583 89584!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:48'! 89585isMatrixTransform2x3 89586 "Return true if the receiver is 2x3 matrix transformation" 89587 ^false! ! 89588 89589!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:48'! 89590isMorphicTransform 89591 "Return true if the receiver is a MorphicTransform, that is specifies the transformation values explicitly." 89592 ^false! ! 89593 89594!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 16:16'! 89595isPureTranslation 89596 "Return true if the receiver specifies no rotation or scaling." 89597 ^self subclassResponsibility! ! 89598 89599 89600!DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:17'! 89601globalPointToLocal: aPoint 89602 "Transform aPoint from global coordinates into local coordinates" 89603 ^self subclassResponsibility! ! 89604 89605!DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/9/1998 14:35'! 89606globalPointsToLocal: inArray 89607 "Transform all the points of inArray from global into local coordinates" 89608 ^inArray collect:[:pt| self globalPointToLocal: pt]! ! 89609 89610!DisplayTransform methodsFor: 'transforming points' stamp: 'gh 10/22/2001 13:24'! 89611invertBoundsRect: aRectangle 89612 "Return a rectangle whose coordinates have been transformed 89613 from local back to global coordinates." 89614 89615 ^self subclassResponsibility! ! 89616 89617!DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:18'! 89618localPointToGlobal: aPoint 89619 "Transform aPoint from local coordinates into global coordinates" 89620 ^self subclassResponsibility! ! 89621 89622!DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/9/1998 14:35'! 89623localPointsToGlobal: inArray 89624 "Transform all the points of inArray from local into global coordinates" 89625 ^inArray collect:[:pt| self localPointToGlobal: pt]! ! 89626 89627 89628!DisplayTransform methodsFor: 'transforming rects' stamp: 'ar 11/2/1998 16:19'! 89629globalBoundsToLocal: aRectangle 89630 "Transform aRectangle from global coordinates into local coordinates" 89631 ^Rectangle encompassing: (self globalPointsToLocal: aRectangle corners)! ! 89632 89633!DisplayTransform methodsFor: 'transforming rects' stamp: 'ar 11/2/1998 16:19'! 89634localBoundsToGlobal: aRectangle 89635 "Transform aRectangle from local coordinates into global coordinates" 89636 ^Rectangle encompassing: (self localPointsToGlobal: aRectangle corners)! ! 89637 89638!DisplayTransform methodsFor: 'transforming rects' stamp: 'di 10/25/1999 12:49'! 89639sourceQuadFor: aRectangle 89640 ^ aRectangle innerCorners collect: 89641 [:p | self globalPointToLocal: p]! ! 89642 89643"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 89644 89645DisplayTransform class 89646 instanceVariableNames: ''! 89647 89648!DisplayTransform class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 20:55'! 89649identity 89650 ^self new setIdentity! ! 89651AbstractEvent subclass: #DoItEvent 89652 instanceVariableNames: 'context' 89653 classVariableNames: '' 89654 poolDictionaries: '' 89655 category: 'System-Change Notification'! 89656 89657!DoItEvent methodsFor: 'accessing' stamp: 'rw 7/14/2003 11:29'! 89658context 89659 89660 ^context! ! 89661 89662 89663!DoItEvent methodsFor: 'printing' stamp: 'rw 7/14/2003 10:15'! 89664printEventKindOn: aStream 89665 89666 aStream nextPutAll: 'DoIt'! ! 89667 89668 89669!DoItEvent methodsFor: 'testing' stamp: 'rw 7/14/2003 10:15'! 89670isDoIt 89671 89672 ^true! ! 89673 89674 89675!DoItEvent methodsFor: 'private-accessing' stamp: 'rw 7/14/2003 11:29'! 89676context: aContext 89677 89678 context := aContext! ! 89679 89680"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 89681 89682DoItEvent class 89683 instanceVariableNames: ''! 89684 89685!DoItEvent class methodsFor: 'accessing' stamp: 'rw 7/14/2003 10:19'! 89686changeKind 89687 89688 ^#DoIt! ! 89689 89690!DoItEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:23'! 89691supportedKinds 89692 ^ Array with: self expressionKind! ! 89693 89694 89695!DoItEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 09:47'! 89696expression: stringOrStream context: aContext 89697 | instance | 89698 instance := self item: stringOrStream kind: AbstractEvent expressionKind. 89699 instance context: aContext. 89700 ^instance! ! 89701AlignmentMorph subclass: #DockingBarMorph 89702 instanceVariableNames: 'originalColor gradientRamp fillsOwner avoidVisibleBordersAtEdge autoGradient selectedItem activeSubMenu' 89703 classVariableNames: '' 89704 poolDictionaries: '' 89705 category: 'Morphic-DockingBar'! 89706 89707!DockingBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/29/2007 15:31'! 89708add: wordingString font: aFont icon: aForm help: helpString subMenu: aMenuMorph 89709 "Append the given submenu with the given label." 89710 89711 | item | 89712 item := ToggleMenuItemMorph new. 89713 item 89714 font: aFont; 89715 contents: wordingString; 89716 subMenu: aMenuMorph; 89717 icon: aForm. 89718 helpString isNil 89719 ifFalse: [item setBalloonText: helpString]. 89720 self addMorphBack: item! ! 89721 89722!DockingBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/25/2006 13:37'! 89723adoptPaneColor: paneColor 89724 "Change our color too." 89725 89726 super adoptPaneColor: paneColor. 89727 paneColor ifNil: [^self]. 89728 originalColor := paneColor. 89729 self borderStyle baseColor: paneColor. 89730 self updateColor! ! 89731 89732!DockingBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/26/2007 15:27'! 89733originalColor 89734 "Answer the original color." 89735 89736 ^originalColor! ! 89737 89738 89739!DockingBarMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2007 14:24'! 89740extent: aPoint 89741 "Change the receiver's extent. 89742 optimized to not keep updating the (gradient) color!!" 89743 89744 |old| 89745 old := self extent. 89746 super extent: aPoint. 89747 self extent = old ifTrue: [^self]. 89748 self updateColor! ! 89749 89750!DockingBarMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 11/14/2006 15:37'! 89751updatePosition 89752 "private - update the receiver's position. 89753 Fixed so as not to keep changing position!! 89754 (called twice if adhereing)" 89755 89756 | edgeSymbol margin | 89757 edgeSymbol := self edgeToAdhereTo. 89758 edgeSymbol == #none 89759 ifTrue: [self 89760 perform: (edgeSymbol , ':') asSymbol 89761 with: (self owner perform: edgeSymbol)]. 89762 "" 89763 margin := self avoidVisibleBordersAtEdge 89764 ifTrue: [self borderWidth asPoint] 89765 ifFalse: [0 asPoint]. 89766 "" 89767 self isAdheringToTop 89768 ifTrue: [| usedHeight | 89769 usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top ). 89770 self topLeft: self owner topLeft - margin + (0 @ usedHeight)]. 89771 self isAdheringToBottom 89772 ifTrue: [| usedHeight | 89773 usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#bottom ). 89774 self bottomLeft: self owner bottomLeft + (-1 @ 1 * margin) - (0 @ usedHeight)]. 89775 "" 89776 self isAdheringToLeft 89777 ifTrue: [| usedHeight usedWidth | 89778 usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top ). 89779 usedWidth := self usedWidthByPredominantDockingBarsOfChastes: #(#left ). 89780 self topLeft: self owner topLeft - margin + (usedWidth @ usedHeight)]. 89781 self isAdheringToRight 89782 ifTrue: [| usedHeight usedWidth | 89783 usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top ). 89784 usedWidth := self usedWidthByPredominantDockingBarsOfChastes: #(#right ). 89785 self topRight: self owner topRight + (1 @ -1 * margin) + (usedWidth negated @ usedHeight)]! ! 89786 89787!DockingBarMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/16/2007 14:41'! 89788wantsYellowButtonMenu 89789 "Answer true if the receiver wants a yellow button menu. 89790 Fixed for when generalizedYellowButtonMenu pref is off" 89791 89792 ^Preferences noviceMode not and: [Preferences generalizedYellowButtonMenu]! ! 89793 89794 89795!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 9/13/2004 19:59'! 89796addBlankIconsIfNecessary: anIcon 89797 "If any of my items have an icon, ensure that all do by using 89798 anIcon for those that don't" 89799 self items 89800 reject: [:each | each hasIconOrMarker] 89801 thenDo: [:each | each icon: anIcon]! ! 89802 89803!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:01'! 89804adhereToBottom 89805 "Instract the receiver to adhere to bottom" 89806 self adhereTo:#bottom! ! 89807 89808!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:01'! 89809adhereToLeft 89810 "Instract the receiver to adhere to left" 89811 self adhereTo: #left! ! 89812 89813!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:01'! 89814adhereToRight 89815 "Instract the receiver to adhere to right" 89816 self adhereTo: #right! ! 89817 89818!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:01'! 89819adhereToTop 89820 "Instract the receiver to adhere to top" 89821 self adhereTo: #top! ! 89822 89823!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 14:28'! 89824autoGradient 89825 "Answer if the receiver is in autoGradient mode" 89826 ^ autoGradient! ! 89827 89828!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 14:28'! 89829autoGradient: aBoolean 89830 "Instruct the receiver to fill the owner or not" 89831 autoGradient := aBoolean. 89832 self updateColor! ! 89833 89834!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 13:38'! 89835avoidVisibleBordersAtEdge 89836"Answer if the receiver is in avoidVisibleBordersAtEdge mode" 89837 ^ avoidVisibleBordersAtEdge! ! 89838 89839!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 13:57'! 89840avoidVisibleBordersAtEdge: aBoolean 89841 "Instruct the receiver to avoid showing the borders at edge" 89842 avoidVisibleBordersAtEdge := aBoolean. 89843self updateLayoutProperties.! ! 89844 89845!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:02'! 89846beFloating 89847 "Instract the receiver to be floating" 89848 self adhereTo: #none! ! 89849 89850!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 11/2/2004 12:00'! 89851color: aColor 89852 "Set the receiver's color." 89853 super color: aColor. 89854 originalColor := aColor asColor. 89855"" 89856self updateColor! ! 89857 89858!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 13:35'! 89859fillsOwner 89860 "Answer if the receiver is in fillOwner mode" 89861 ^ fillsOwner! ! 89862 89863!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 13:57'! 89864fillsOwner: aBoolean 89865 "Instruct the receiver to fill the owner or not" 89866 fillsOwner := aBoolean. 89867self updateLayoutProperties! ! 89868 89869!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:57'! 89870isAdheringToBottom 89871 "Answer true if the receiver is adhering to bottom" 89872 ^ self edgeToAdhereTo == #bottom! ! 89873 89874!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:57'! 89875isAdheringToLeft 89876 "Answer true if the receiver is adhering to left" 89877 ^ self edgeToAdhereTo == #left! ! 89878 89879!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:57'! 89880isAdheringToRight 89881 "Answer true if the receiver is adhering to right" 89882 ^ self edgeToAdhereTo == #right! ! 89883 89884!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:57'! 89885isAdheringToTop 89886 "Answer true if the receiver is adhering to top" 89887 ^ self edgeToAdhereTo == #top! ! 89888 89889!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/30/2004 23:13'! 89890isFloating 89891 "Answer true if the receiver has a float layout" 89892 ^ self isHorizontal not 89893 and: [self isVertical not]! ! 89894 89895!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:58'! 89896isHorizontal 89897 "Answer true if the receiver has a horizontal layout" 89898 ^ self isAdheringToTop 89899 or: [self isAdheringToBottom]! ! 89900 89901!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:58'! 89902isVertical 89903 "Answer true if the receiver has a vertical layout" 89904 ^ self isAdheringToLeft 89905 or: [self isAdheringToRight] 89906! ! 89907 89908!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 9/9/2004 19:45'! 89909rootMenu 89910 ^ self! ! 89911 89912!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 9/1/2004 16:39'! 89913stayUp 89914 ^ false! ! 89915 89916!DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 16:33'! 89917wantsToBeTopmost 89918 "Answer if the receiver want to be one of the topmost objects in 89919 its owner" 89920 ^ true! ! 89921 89922 89923!DockingBarMorph methodsFor: 'change reporting' stamp: 'dgd 9/1/2004 15:29'! 89924ownerChanged 89925"The receiver's owner has changed its layout. " 89926 self updateBounds. 89927 ^ super ownerChanged! ! 89928 89929 89930!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 7/28/2005 12:08'! 89931addDefaultSpace 89932 "Add a new space of the given size to the receiver." 89933 ^ self addSpace: (Preferences tinyDisplay ifFalse:[10] ifTrue:[3])! ! 89934 89935!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 9/1/2004 19:10'! 89936addLine 89937 "Append a divider line to this menu. Suppress duplicate lines." 89938 89939 submorphs isEmpty ifTrue: [^ self]. 89940 (self lastSubmorph isKindOf: MenuLineMorph) 89941 ifFalse: [self addMorphBack: MenuLineMorph new]. 89942! ! 89943 89944!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 8/31/2004 11:34'! 89945addSpacer 89946 "Add a new spacer to the receiver. 89947 89948 Spacer are objects that try to use as much space as they can" 89949 self 89950 addMorphBack: (AlignmentMorph newSpacer: Color transparent)! ! 89951 89952!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 8/31/2004 11:34'! 89953addSpace: sizePointOrNumber 89954 "Add a new space of the given size to the receiver." 89955 | space | 89956 space := RectangleMorph new. 89957 space extent: sizePointOrNumber asPoint. 89958 space color: Color transparent. 89959 space borderWidth: 0. 89960 self addMorphBack: space! ! 89961 89962!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 9/10/2004 16:48'! 89963add: wordingString icon: aForm help: helpString subMenu: aMenuMorph 89964 "Append the given submenu with the given label." 89965 | item | 89966 item := MenuItemMorph new. 89967 item contents: wordingString. 89968 item subMenu: aMenuMorph. 89969 item icon: aForm. 89970 helpString isNil 89971 ifFalse: [item setBalloonText: helpString]. 89972 self addMorphBack: item! ! 89973 89974!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 9/10/2004 16:48'! 89975add: wordingString icon: aForm subMenu: aMenuMorph 89976 "Append the given submenu with the given label." 89977^ self add: wordingString icon: aForm help: nil subMenu: aMenuMorph ! ! 89978 89979!DockingBarMorph methodsFor: 'construction' stamp: 'dgd 9/1/2004 19:08'! 89980add: aString subMenu: aMenuMorph 89981 "Append the given submenu with the given label." 89982 self add: aString icon: nil subMenu: aMenuMorph ! ! 89983 89984 89985!DockingBarMorph methodsFor: 'control' stamp: 'dgd 9/9/2004 21:48'! 89986activeSubmenu: aSubmenu 89987 activeSubMenu isNil 89988 ifFalse: [activeSubMenu delete]. 89989 activeSubMenu := aSubmenu. 89990 aSubmenu isNil 89991 ifTrue: [^ self]. 89992 "" 89993 activeSubMenu selectItem: nil event: nil. 89994 MenuIcons decorateMenu: activeSubMenu. 89995 activeSubMenu activatedFromDockingBar: self. 89996 activeSubMenu borderColor: self borderColor. 89997 activeSubMenu beSticky. 89998 activeSubMenu resistsRemoval: true. 89999activeSubMenu removeMatchString.! ! 90000 90001!DockingBarMorph methodsFor: 'control' stamp: 'dgd 9/1/2004 16:48'! 90002deleteIfPopUp: evt 90003 evt 90004 ifNotNil: [evt hand releaseMouseFocus: self]! ! 90005 90006!DockingBarMorph methodsFor: 'control' stamp: 'dgd 9/1/2004 16:40'! 90007selectItem: aMenuItem event: anEvent 90008 selectedItem 90009 ifNotNil: [selectedItem deselect: anEvent]. 90010 selectedItem := aMenuItem. 90011 selectedItem 90012 ifNotNil: [selectedItem select: anEvent]! ! 90013 90014 90015!DockingBarMorph methodsFor: 'dropping/grabbing' stamp: 'dgd 9/7/2004 14:47'! 90016aboutToBeGrabbedBy: aHand 90017 "The morph is about to be grabbed, make it float" 90018 self beFloating. 90019 self updateBounds. 90020 self updateColor. 90021 (self bounds containsPoint: aHand position) 90022 ifFalse: [self center: aHand position]. 90023self owner restoreFlapsDisplay! ! 90024 90025!DockingBarMorph methodsFor: 'dropping/grabbing' stamp: 'dgd 8/31/2004 14:37'! 90026justDroppedInto: aMorph event: anEvent 90027 | ownerBounds leftRegion droppedPosition rightRegion topRegion bottomRegion | 90028 super justDroppedInto: aMorph event: anEvent. 90029 "" 90030 self owner isNil 90031 ifTrue: [^ self]. 90032 "" 90033 ownerBounds := aMorph bounds. 90034 topRegion := ownerBounds bottom: ownerBounds top + (ownerBounds height // 5). 90035 bottomRegion := ownerBounds top: ownerBounds bottom - (ownerBounds height // 5). 90036 "" 90037 leftRegion := ownerBounds right: ownerBounds left + (ownerBounds width // 5). 90038 leftRegion := leftRegion top: topRegion bottom. 90039 leftRegion := leftRegion bottom: bottomRegion top. 90040 "" 90041 rightRegion := ownerBounds left: ownerBounds right - (ownerBounds width // 5). 90042 rightRegion := rightRegion top: topRegion bottom. 90043 rightRegion := rightRegion bottom: bottomRegion top. 90044 "" 90045 droppedPosition := anEvent position. 90046 (topRegion containsPoint: droppedPosition) 90047 ifTrue: [ 90048 ^ self adhereToTop]. 90049 (bottomRegion containsPoint: droppedPosition) 90050 ifTrue: [ 90051 ^ self adhereToBottom]. 90052 (leftRegion containsPoint: droppedPosition) 90053 ifTrue: [ 90054 ^ self adhereToLeft]. 90055 (rightRegion containsPoint: droppedPosition) 90056 ifTrue: [ 90057 ^ self adhereToRight]. 90058 "" 90059 self beFloating! ! 90060 90061 90062!DockingBarMorph methodsFor: 'events' stamp: 'dgd 9/1/2004 19:29'! 90063activate: evt 90064 "Receiver should be activated; e.g., so that control passes 90065 correctly." 90066 evt hand newMouseFocus: self! ! 90067 90068 90069!DockingBarMorph methodsFor: 'events-processing' stamp: 'dgd 9/9/2004 21:43'! 90070handleFocusEvent: evt 90071 "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." 90072 90073 (evt isMouse and:[ evt isMouseUp ]) ifTrue:[^ self]. 90074 90075 self processEvent: evt. 90076 90077 "Need to handle keyboard input if we have the focus." 90078 evt isKeyboard ifTrue: [^ self handleEvent: evt]. 90079 90080 "We need to handle button clicks outside and transitions to local popUps so throw away everything else" 90081 (evt isMouseOver or:[evt isMouse not]) ifTrue:[^self]. 90082 "What remains are mouse buttons and moves" 90083 evt isMove ifFalse:[^self handleEvent: evt]. "handle clicks outside by regular means" 90084 "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." 90085 selectedItem ifNotNil:[(selectedItem activateSubmenu: evt) ifTrue:[^self]]. 90086! ! 90087 90088 90089!DockingBarMorph methodsFor: 'initialization' stamp: 'dgd 9/2/2004 11:03'! 90090initialize 90091 "initialize the receiver" 90092 super initialize. 90093 "" 90094 selectedItem := nil. 90095 activeSubMenu := nil. 90096 fillsOwner := true. 90097 avoidVisibleBordersAtEdge := true. 90098 autoGradient := Preferences gradientMenu. 90099 "" 90100 self setDefaultParameters. 90101 "" 90102 self beFloating. 90103 "" 90104 self layoutInset: 0. 90105 ! ! 90106 90107!DockingBarMorph methodsFor: 'initialization' stamp: 'dgd 8/30/2004 22:17'! 90108setDefaultParameters 90109 "private - set the default parameter using Preferences as the inspiration source" 90110 | colorFromMenu worldColor menuColor menuBorderColor | 90111 colorFromMenu := Preferences menuColorFromWorld 90112 and: [Display depth > 4] 90113 and: [(worldColor := self currentWorld color) isColor]. 90114 "" 90115 menuColor := colorFromMenu 90116 ifTrue: [worldColor luminance > 0.7 90117 ifTrue: [worldColor mixed: 0.85 with: Color black] 90118 ifFalse: [worldColor mixed: 0.4 with: Color white]] 90119 ifFalse: [Preferences menuColor]. 90120 "" 90121 menuBorderColor := Preferences menuAppearance3d 90122 ifTrue: [#raised] 90123 ifFalse: [colorFromMenu 90124 ifTrue: [worldColor muchDarker] 90125 ifFalse: [Preferences menuBorderColor]]. 90126 "" 90127 self 90128 setColor: menuColor 90129 borderWidth: Preferences menuBorderWidth 90130 borderColor: menuBorderColor! ! 90131 90132 90133!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:31'! 90134addCustomMenuItems: aMenu hand: aHandMorph 90135 "Populate aMenu with appropriate menu items for a 90136 yellow-button (context menu) click." 90137 super addCustomMenuItems: aMenu hand: aHandMorph. 90138 "" 90139 aMenu addLine. 90140 aMenu addUpdating: #autoGradientString action: #toggleAutoGradient. 90141 self isFloating 90142 ifFalse: ["" 90143 aMenu addUpdating: #fillsOwnerString action: #toggleFillsOwner. 90144 aMenu addUpdating: #avoidVisibleBordersAtEdgeString action: #toggleAvoidVisibleBordersAtEdge]! ! 90145 90146!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:25'! 90147autoGradientString 90148 "Answer the string to be shown in a menu to represent the 90149 'resistsRemoval' status" 90150 ^ (self autoGradient 90151 ifTrue: ['<on>'] 90152 ifFalse: ['<off>']) 90153 , 'auto gradient' translated! ! 90154 90155!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:25'! 90156avoidVisibleBordersAtEdgeString 90157 "Answer the string to be shown in a menu to represent the 90158 'resistsRemoval' status" 90159 ^ (self avoidVisibleBordersAtEdge 90160 ifTrue: ['<on>'] 90161 ifFalse: ['<off>']) 90162 , 'avoid visible borders at edge' translated! ! 90163 90164!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:23'! 90165fillsOwnerString 90166 "Answer the string to be shown in a menu to represent the 90167 'resistsRemoval' status" 90168 ^ (self fillsOwner 90169 ifTrue: ['<on>'] 90170 ifFalse: ['<off>']) 90171 , 'fills owner' translated 90172! ! 90173 90174!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:27'! 90175toggleAutoGradient 90176 self autoGradient: self autoGradient not! ! 90177 90178!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:26'! 90179toggleAvoidVisibleBordersAtEdge 90180 self avoidVisibleBordersAtEdge: self avoidVisibleBordersAtEdge not! ! 90181 90182!DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:24'! 90183toggleFillsOwner 90184 self fillsOwner: self fillsOwner not! ! 90185 90186 90187!DockingBarMorph methodsFor: 'menus' stamp: 'dgd 9/1/2004 15:29'! 90188snapToEdgeIfAppropriate 90189 (self owner isNil 90190 or: [self owner isHandMorph]) 90191 ifTrue: [^ self]. 90192 "" 90193 self updateBounds! ! 90194 90195 90196!DockingBarMorph methodsFor: 'rounding' stamp: 'dgd 8/31/2004 14:16'! 90197roundedCorners 90198 "Return a list of those corners to round" 90199 self isAdheringToTop 90200 ifTrue: [^ #(2 3 )]. 90201 self isAdheringToBottom 90202 ifTrue: [^ #(1 4 )]. 90203 self isAdheringToLeft 90204 ifTrue: [^ #(3 4 )]. 90205 self isAdheringToRight 90206 ifTrue: [^ #(1 2 )]. 90207 ^ #(1 2 3 4 )! ! 90208 90209 90210!DockingBarMorph methodsFor: 'submorphs-accessing' stamp: 'dgd 9/1/2004 18:41'! 90211noteNewOwner: aMorph 90212 "I have just been added as a submorph of aMorph" 90213 super noteNewOwner: aMorph. 90214 90215 self submorphs 90216 do: [:each | each adjustLayoutBounds]. 90217! ! 90218 90219 90220!DockingBarMorph methodsFor: 'submorphs-add/remove' stamp: 'dgd 9/1/2004 19:26'! 90221delete 90222 activeSubMenu 90223 ifNotNil: [activeSubMenu delete]. 90224 ^ super delete! ! 90225 90226 90227!DockingBarMorph methodsFor: 'testing' stamp: 'dgd 8/31/2004 15:00'! 90228isDockingBar 90229 "Return true if the receiver is a docking bar" 90230 ^ true! ! 90231 90232 90233!DockingBarMorph methodsFor: 'wiw support' stamp: 'dgd 9/7/2004 19:25'! 90234morphicLayerNumber 90235 "helpful for insuring some morphs always appear in front of or 90236 behind others. smaller numbers are in front" 90237 ^ 11! ! 90238 90239 90240!DockingBarMorph methodsFor: 'private' stamp: 'dgd 9/9/2004 21:24'! 90241selectedItem 90242 selectedItem isNil 90243 ifTrue: [^ nil]. 90244 ^ selectedItem isSelected 90245 ifTrue: [ selectedItem] 90246 ifFalse: [ nil]! ! 90247 90248 90249!DockingBarMorph methodsFor: 'private - accessing' stamp: 'dgd 8/31/2004 14:35'! 90250adhereTo: edgeSymbol 90251 "Private - Instruct the receiver to adhere to the given edge. 90252 90253 Options: #left #top #right #bottom or #none" 90254 "" 90255 (#(#left #top #right #bottom #none ) includes: edgeSymbol) 90256 ifFalse: [^ self error: 'invalid option']. 90257 "" 90258 self setToAdhereToEdge: edgeSymbol. 90259 self updateLayoutProperties. 90260 self updateColor! ! 90261 90262!DockingBarMorph methodsFor: 'private - accessing' stamp: 'dgd 8/31/2004 13:56'! 90263edgeToAdhereTo 90264 "private - answer the edge where the receiver is adhering to" 90265 ^ self 90266 valueOfProperty: #edgeToAdhereTo 90267 ifAbsent: [#none]! ! 90268 90269!DockingBarMorph methodsFor: 'private - accessing' stamp: 'dgd 9/1/2004 15:19'! 90270predominantDockingBarsOfChastes: predominantChastes 90271 "Private - Answer a collection of the docking bar of my owner 90272 that are predominant to the receiver. 90273 90274 By 'predominant' we mean docking bar that have the right to 90275 get a position before the receiver. 90276 90277 The predominance of individual living in the same chaste is 90278 determinated by the arrival order. 90279 " 90280 | allDockingBars byChaste byArrival | 90281 (self owner isNil 90282 or: [self owner isHandMorph]) 90283 ifTrue: [^ #()]. 90284 "" 90285 allDockingBars := self owner dockingBars. 90286 "" 90287 byChaste := allDockingBars 90288 select: [:each | predominantChastes includes: each edgeToAdhereTo]. 90289 "" 90290 (predominantChastes includes: self edgeToAdhereTo) 90291 ifFalse: [^ byChaste]. 90292 "" 90293 byChaste := byChaste 90294 reject: [:each | each edgeToAdhereTo = self edgeToAdhereTo]. 90295 "" 90296 byArrival := allDockingBars 90297 select: [:each | each edgeToAdhereTo = self edgeToAdhereTo]. 90298 90299 byArrival := byArrival copyAfter: self. 90300 "" 90301 ^ byChaste , byArrival! ! 90302 90303!DockingBarMorph methodsFor: 'private - accessing' stamp: 'dgd 9/1/2004 19:39'! 90304usedHeightByPredominantDockingBarsOfChastes: predominantChastes 90305 "Private - convenience" 90306 | predominants | 90307 predominants := self predominantDockingBarsOfChastes: predominantChastes. 90308 ^ predominants isEmpty 90309 ifTrue: [0] 90310 ifFalse: [(predominants 90311 collect: [:each | each height]) sum]! ! 90312 90313!DockingBarMorph methodsFor: 'private - accessing' stamp: 'dgd 9/1/2004 19:38'! 90314usedWidthByPredominantDockingBarsOfChastes: predominantChastes 90315 "Private - convenience" 90316 | predominants | 90317 predominants := self predominantDockingBarsOfChastes: predominantChastes. 90318 ^ predominants isEmpty 90319 ifTrue: [0] 90320 ifFalse: [(predominants 90321 collect: [:each | each width]) sum]! ! 90322 90323 90324!DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 11/2/2004 11:59'! 90325gradientRamp 90326 ^ gradientRamp ifNil:[{0.0 -> originalColor muchLighter. 1.0 -> originalColor twiceDarker}]! ! 90327 90328!DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 11/2/2004 12:00'! 90329gradientRamp: colorRamp 90330 gradientRamp := colorRamp. 90331"" 90332self updateColor! ! 90333 90334!DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 9/1/2004 15:29'! 90335updateBounds 90336 "private - update the receiver's bounds" 90337 self updateExtent. 90338 self isFloating 90339 ifFalse: [self updatePosition]! ! 90340 90341!DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 11/2/2004 11:55'! 90342updateColor 90343 "private - update the receiver's color" 90344 | fill | 90345 self autoGradient 90346 ifFalse: [^ self]. 90347 "" 90348 fill := GradientFillStyle ramp: self gradientRamp. 90349 "" 90350 fill origin: self topLeft. 90351 self isVertical 90352 ifTrue: [fill direction: self width @ 0] 90353 ifFalse: [fill direction: 0 @ self height]. 90354 "" 90355 self fillStyle: fill! ! 90356 90357!DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 9/1/2004 15:20'! 90358updateExtent 90359 "private - update the receiver's extent" 90360 | margin | 90361 self fullBounds. 90362 self fillsOwner 90363 ifFalse: [^ self]. 90364 "" 90365 margin := self avoidVisibleBordersAtEdge 90366 ifTrue: [self borderWidth * 2] 90367 ifFalse: [0]."" 90368 self isHorizontal 90369 ifTrue: [self width: self owner width + margin]."" 90370 self isVertical 90371 ifTrue: [| usedHeight | 90372 usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top #bottom ). 90373 self height: self owner height + margin - usedHeight]! ! 90374 90375!DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 8/31/2004 14:03'! 90376updateLayoutProperties 90377 "private - update the layout properties based on adhering, 90378 fillsOwner and avoidVisibleBordersAtEdge preferencs" 90379 "" 90380 (self isHorizontal 90381 or: [self isFloating]) 90382 ifTrue: [self listDirection: #leftToRight] 90383 ifFalse: [self listDirection: #topToBottom]. 90384 "" 90385 self hResizing: #shrinkWrap. 90386 self vResizing: #shrinkWrap. 90387 self fillsOwner 90388 ifTrue: ["" 90389 self isHorizontal 90390 ifTrue: [self hResizing: #spaceFill]. 90391 self isVertical 90392 ifTrue: [self vResizing: #spaceFill]]. 90393 ! ! 90394 90395"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 90396 90397DockingBarMorph class 90398 instanceVariableNames: ''! 90399 90400!DockingBarMorph class methodsFor: 'samples' stamp: 'dgd 9/1/2004 20:12'! 90401squeakMenu 90402 | menu | 90403 menu := MenuMorph new defaultTarget: self. 90404 menu 90405 add: 'Hello' 90406 target: self 90407 selector: #inform: 90408 argument: 'Hello World!!'. 90409 menu 90410 add: 'Long Hello' 90411 target: self 90412 selector: #inform: 90413 argument: 'Helloooo World!!'. 90414 menu 90415 add: 'A very long Hello' 90416 target: self 90417 selector: #inform: 90418 argument: 'Hellooooooooooooooo World!!'. 90419 menu 90420 add: 'An incredible long Hello' 90421 target: self 90422 selector: #inform: 90423 argument: 'Hellooooooooooooooooooooooo World!!'. 90424 ^ menu! ! 90425 90426 90427!DockingBarMorph class methodsFor: 'scripting' stamp: 'dgd 8/31/2004 14:26'! 90428defaultNameStemForInstances 90429 ^ 'DockingBar'! ! 90430FileDirectory subclass: #DosFileDirectory 90431 instanceVariableNames: '' 90432 classVariableNames: '' 90433 poolDictionaries: '' 90434 category: 'Files-Directories'! 90435!DosFileDirectory commentStamp: '<historical>' prior: 0! 90436I represent a DOS or Windows FileDirectory. 90437! 90438 90439 90440!DosFileDirectory methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'! 90441checkName: aFileName fixErrors: fixing 90442 "Check if the file name contains any invalid characters" 90443 | fName badChars hasBadChars | 90444 fName := super checkName: aFileName fixErrors: fixing. 90445 badChars := #( $: $< $> $| $/ $\ $? $* $") asSet. 90446 hasBadChars := fName includesAnyOf: badChars. 90447 (hasBadChars and:[fixing not]) ifTrue:[^self error:'Invalid file name']. 90448 hasBadChars ifFalse:[^ fName]. 90449 ^ fName collect: 90450 [:char | (badChars includes: char) 90451 ifTrue:[$#] 90452 ifFalse:[char]]! ! 90453 90454!DosFileDirectory methodsFor: 'as yet unclassified' stamp: 'bf 3/21/2000 17:06'! 90455setPathName: pathString 90456 "Ensure pathString is absolute - relative directories aren't supported on all platforms." 90457 90458 (pathString isEmpty 90459 or: [pathString first = $\ 90460 or: [pathString size >= 2 and: [pathString second = $: and: [pathString first isLetter]]]]) 90461 ifTrue: [^ super setPathName: pathString]. 90462 90463 self error: 'Fully qualified path expected'! ! 90464 90465 90466!DosFileDirectory methodsFor: 'path access' stamp: 'stephaneducasse 2/4/2006 20:31'! 90467driveName 90468 90469 "return a possible drive letter and colon at the start of a Path name, empty string otherwise" 90470 90471 | firstTwoChars | 90472 90473 ( pathName asSqueakPathName size >= 2 ) ifTrue: [ 90474 firstTwoChars := (pathName asSqueakPathName copyFrom: 1 to: 2). 90475 (self class isDrive: firstTwoChars) ifTrue: [^firstTwoChars] 90476 ]. 90477 ^''! ! 90478 90479!DosFileDirectory methodsFor: 'path access' stamp: 'nk 7/18/2004 17:26'! 90480fullNameFor: fileName 90481 "Return a corrected, fully-qualified name for the given file name. If the given name is already a full path (i.e., it contains a delimiter character), assume it is already a fully-qualified name. Otherwise, prefix it with the path to this directory. In either case, correct the local part of the file name." 90482 fileName ifNil:[^fileName]. 90483 "Check for fully qualified names" 90484 ((fileName size >= 2 and: [fileName first isLetter and: [fileName second = $:]]) 90485 or: [(fileName beginsWith: '\\') and: [(fileName occurrencesOf: $\) >= 2]]) 90486 ifTrue:[^fileName]. 90487 ^super fullNameFor: fileName! ! 90488 90489!DosFileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'! 90490fullPathFor: path 90491 "Return the fully-qualified path name for the given file." 90492 path isEmpty ifTrue:[^pathName asSqueakPathName]. 90493 (path at: 1) = $\ ifTrue:[ 90494 (path size >= 2 and:[(path at: 2) = $\]) ifTrue:[^path]. "e.g., \\pipe\" 90495 ^self driveName , path "e.g., \windows\"]. 90496 (path size >= 2 and:[(path at: 2) = $: and:[path first isLetter]]) 90497 ifTrue:[^path]. "e.g., c:" 90498 ^pathName asSqueakPathName, self slash, path! ! 90499 90500!DosFileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'! 90501relativeNameFor: path 90502 "Return the full name for path, assuming that path is a name relative to me." 90503 path isEmpty ifTrue:[^pathName asSqueakPathName]. 90504 (path at: 1) = $\ ifTrue:[ 90505 (path size >= 2 and:[(path at: 2) = $\]) ifTrue:[^super relativeNameFor: path allButFirst ]. "e.g., \\pipe\" 90506 ^super relativeNameFor: path "e.g., \windows\"]. 90507 (path size >= 2 and:[(path at: 2) = $: and:[path first isLetter]]) 90508 ifTrue:[^super relativeNameFor: (path copyFrom: 3 to: path size) ]. "e.g., c:" 90509 ^pathName asSqueakPathName, self slash, path! ! 90510 90511"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 90512 90513DosFileDirectory class 90514 instanceVariableNames: ''! 90515 90516!DosFileDirectory class methodsFor: '*network-uri' stamp: 'pg 1/29/2006 15:37'! 90517privateFullPathForURI: aURI 90518 | path | 90519 path := aURI path unescapePercents. 90520 90521 "Check for drive notation (a: etc)" 90522 path size > 1 90523 ifTrue: [ 90524 ((path at: 3) = $:) 90525 ifTrue: [path := path copyFrom: 2 to: path size] 90526 ifFalse: [ 90527 "All other cases should be network path names (\\xxx\sdsd etc)" 90528 path := '/' , path]]. 90529 90530 ^path copyReplaceAll: '/' with: self slash! ! 90531 90532 90533!DosFileDirectory class methodsFor: 'platform specific' stamp: 'ar 5/1/1999 01:48'! 90534isCaseSensitive 90535 "Return true if file names are treated case sensitive" 90536 ^false! ! 90537 90538!DosFileDirectory class methodsFor: 'platform specific' stamp: 'ar 3/6/2004 03:46'! 90539isDrive: fullName 90540 "Answer whether the given full name describes a 'drive', e.g., one of the root directories of a Win32 file system. We allow two forms here - the classic one where a drive is specified by a letter followed by a colon, e.g., 'C:', 'D:' etc. and the network share form starting with double-backslashes e.g., '\\server'." 90541 ^ (fullName size = 2 and: [fullName first isLetter and: [fullName last = $:]]) 90542 or: [(fullName beginsWith: '\\') and: [(fullName occurrencesOf: $\) = 2]]! ! 90543 90544!DosFileDirectory class methodsFor: 'platform specific' stamp: 'jm 5/8/1998 20:45'! 90545maxFileNameLength 90546 90547 ^ 255 90548! ! 90549 90550!DosFileDirectory class methodsFor: 'platform specific' stamp: 'jm 12/4/97 22:57'! 90551pathNameDelimiter 90552 90553 ^ $\ 90554! ! 90555 90556!DosFileDirectory class methodsFor: 'platform specific' stamp: 'ar 3/6/2004 04:14'! 90557splitName: fullName to: pathAndNameBlock 90558 "Take the file name and convert it to the path name of a directory and a local file name within that directory. 90559 IMPORTANT NOTE: For 'drives', e.g., roots of the file system on Windows we treat the full name of that 'drive' as the local name rather than the path. This is because conceptually, all of these 'drives' hang off the virtual root of the entire Squeak file system, specified by FileDirectory root. In order to be consistent with, e.g., 90560 90561 DosFileDirectory localNameFor: 'C:\Windows' -> 'Windows' 90562 DosFileDirectory dirPathFor: 'C:\Windows' -> 'C:' 90563 90564 we expect the following to be true: 90565 90566 DosFileDirectory localNameFor: 'C:' -> 'C:' 90567 DosFileDirectory dirPathFor: 'C:'. -> '' 90568 DosFileDirectory localNameFor: '\\server' -> '\\server'. 90569 DosFileDirectory dirPathFor: '\\server' -> ''. 90570 90571 so that in turn the following relations hold: 90572 90573 | fd | 90574 fd := DosFileDirectory on: 'C:\Windows'. 90575 fd containingDirectory includes: fd localName. 90576 fd := DosFileDirectory on: 'C:'. 90577 fd containingDirectory includes: fd localName. 90578 fd := DosFileDirectory on: '\\server'. 90579 fd containingDirectory includes: fd localName. 90580 " 90581 (self isDrive: fullName) 90582 ifTrue: [^ pathAndNameBlock value:'' value: fullName]. 90583 ^ super splitName: fullName to: pathAndNameBlock! ! 90584TestCase subclass: #DosFileDirectoryTests 90585 instanceVariableNames: '' 90586 classVariableNames: '' 90587 poolDictionaries: '' 90588 category: 'Tests-Files'! 90589 90590!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:03'! 90591testFileDirectoryContainingDirectory 90592 "Hoping that you have 'C:' of course..." 90593 | fd | 90594 FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. 90595 fd := FileDirectory on: 'C:'. 90596 self assert: fd containingDirectory pathName = ''. 90597! ! 90598 90599!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:05'! 90600testFileDirectoryContainingDirectoryExistence 90601 "Hoping that you have 'C:' of course..." 90602 | fd | 90603 FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. 90604 fd := FileDirectory on: 'C:'. 90605 self assert: (fd containingDirectory fileOrDirectoryExists: 'C:').! ! 90606 90607!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:04'! 90608testFileDirectoryContainingEntry 90609 "Hoping that you have 'C:' of course..." 90610 | fd | 90611 FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. 90612 fd := FileDirectory on: 'C:'. 90613 self assert: (fd containingDirectory entryAt: fd localName) notNil. 90614! ! 90615 90616!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:04'! 90617testFileDirectoryDirectoryEntry 90618 "Hoping that you have 'C:' of course..." 90619 | fd | 90620 FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. 90621 fd := FileDirectory on: 'C:'. 90622 self assert: fd directoryEntry notNil.! ! 90623 90624!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2004 23:28'! 90625testFileDirectoryEntryFor 90626 "Hoping that you have 'C:' of course..." 90627 | fd | 90628 FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. 90629 fd := FileDirectory root directoryEntryFor: 'C:'. 90630 self assert: (fd name sameAs: 'C:').! ! 90631 90632!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2004 23:21'! 90633testFileDirectoryExists 90634 "Hoping that you have 'C:' of course..." 90635 FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. 90636 self assert: (FileDirectory root directoryExists: 'C:').! ! 90637 90638!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:04'! 90639testFileDirectoryLocalName 90640 "Hoping that you have 'C:' of course..." 90641 | fd | 90642 FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. 90643 fd := FileDirectory on: 'C:'. 90644 self assert: fd localName = 'C:'. 90645! ! 90646 90647!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2004 23:19'! 90648testFileDirectoryNamed 90649 "Hoping that you have 'C:' of course..." 90650 | fd | 90651 FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. 90652 fd := FileDirectory root directoryNamed: 'C:'. 90653 self assert: fd pathName = 'C:'.! ! 90654 90655!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'DF 5/26/2006 11:57'! 90656testFileDirectoryNonExistence 90657 90658 | inexistentFileName | 90659 90660 "Hoping that you have 'C:' of course..." 90661 FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. 90662 90663 inexistentFileName := DosFileDirectory default nextNameFor: 'DosFileDirectoryTest' extension: 'temp'. 90664 90665 "This test can fail if another process creates a file with the same name as inexistentFileName 90666 (the probability of that is very very remote)" 90667 90668 self deny: (DosFileDirectory default fileOrDirectoryExists: inexistentFileName)! ! 90669 90670!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:13'! 90671testFileDirectoryRootExistence 90672 "Hoping that you have 'C:' of course..." 90673 FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. 90674 self assert: (FileDirectory root fileOrDirectoryExists: 'C:').! ! 90675 90676!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2004 23:28'! 90677testFullNameFor 90678 "Hoping that you have 'C:' of course..." 90679 FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. 90680 self assert: (FileDirectory default fullNameFor: 'C:') = 'C:'. 90681 self assert: (FileDirectory default fullNameFor: 'C:\test') = 'C:\test'. 90682 self assert: (FileDirectory default fullNameFor: '\\share') = '\\share'. 90683 self assert: (FileDirectory default fullNameFor: '\\share\test') = '\\share\test'. 90684 self assert: (FileDirectory default fullNameFor: '\test') = (FileDirectory default pathParts first, '\test'). 90685! ! 90686 90687!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:17'! 90688testIsDriveForDrive 90689 self assert: (DosFileDirectory isDrive: 'C:'). 90690 self deny: (DosFileDirectory isDrive: 'C:\'). 90691 self deny: (DosFileDirectory isDrive: 'C:\foo'). 90692 self deny: (DosFileDirectory isDrive: 'C:foo').! ! 90693 90694!DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:17'! 90695testIsDriveForShare 90696 self assert: (DosFileDirectory isDrive: '\\server'). 90697 self deny: (DosFileDirectory isDrive: '\\server\'). 90698 self deny: (DosFileDirectory isDrive: '\\server\foo'). 90699! ! 90700MorphicEvent subclass: #DropEvent 90701 instanceVariableNames: 'position contents wasHandled' 90702 classVariableNames: '' 90703 poolDictionaries: '' 90704 category: 'Morphic-Events'! 90705 90706!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:33'! 90707contents 90708 ^contents! ! 90709 90710!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 19:21'! 90711cursorPoint 90712 "For compatibility with mouse events" 90713 ^position! ! 90714 90715!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:33'! 90716position 90717 ^position! ! 90718 90719!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:33'! 90720type 90721 ^#dropEvent! ! 90722 90723!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:44'! 90724wasHandled 90725 ^wasHandled! ! 90726 90727!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:44'! 90728wasHandled: aBool 90729 wasHandled := aBool.! ! 90730 90731 90732!DropEvent methodsFor: 'dispatching' stamp: 'ar 1/10/2001 21:24'! 90733sentTo: anObject 90734 "Dispatch the receiver into anObject" 90735 self type == #dropEvent ifTrue:[^anObject handleDropMorph: self].! ! 90736 90737 90738!DropEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:19'! 90739copyHandlerState: anEvent 90740 "Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events." 90741 wasHandled := anEvent wasHandled.! ! 90742 90743!DropEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:18'! 90744resetHandlerFields 90745 "Reset anything that is used to cross-communicate between two eventual handlers during event dispatch" 90746 wasHandled := false.! ! 90747 90748 90749!DropEvent methodsFor: 'printing' stamp: 'JMM 9/29/2004 13:24'! 90750printOn: aStream 90751 90752 aStream nextPut: $[. 90753 aStream nextPutAll: self position printString; space. 90754 aStream nextPutAll: self type; space. 90755 aStream nextPutAll: self windowIndex printString. 90756 aStream nextPut: $].! ! 90757 90758 90759!DropEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 18:33'! 90760isDropEvent 90761 ^true! ! 90762 90763 90764!DropEvent methodsFor: 'transforming' stamp: 'ar 10/7/2000 18:28'! 90765transformBy: aMorphicTransform 90766 "Transform the receiver into a local coordinate system." 90767 position := aMorphicTransform globalPointToLocal: position.! ! 90768 90769!DropEvent methodsFor: 'transforming' stamp: 'ar 10/7/2000 18:28'! 90770transformedBy: aMorphicTransform 90771 "Return the receiver transformed by the given transform into a local coordinate system." 90772 ^self shallowCopy transformBy: aMorphicTransform! ! 90773 90774 90775!DropEvent methodsFor: 'private' stamp: 'ar 9/13/2000 19:23'! 90776setPosition: pos contents: aMorph hand: aHand 90777 position := pos. 90778 contents := aMorph. 90779 source := aHand. 90780 wasHandled := false.! ! 90781DropEvent subclass: #DropFilesEvent 90782 instanceVariableNames: '' 90783 classVariableNames: '' 90784 poolDictionaries: '' 90785 category: 'Morphic-Events'! 90786 90787!DropFilesEvent methodsFor: 'accessing' stamp: 'ar 1/10/2001 21:35'! 90788type 90789 ^#dropFilesEvent! ! 90790 90791 90792!DropFilesEvent methodsFor: 'dispatching' stamp: 'ar 1/10/2001 21:35'! 90793sentTo: anObject 90794 "Dispatch the receiver into anObject" 90795 self type == #dropFilesEvent ifTrue:[^anObject handleDropFiles: self].! ! 90796MorphicModel subclass: #DropListMorph 90797 uses: TEnableOnHaloMenu 90798 instanceVariableNames: 'contentMorph listMorph buttonMorph list listSelectionIndex getListSelector getIndexSelector setIndexSelector getEnabledSelector enabled useSelectionIndex' 90799 classVariableNames: '' 90800 poolDictionaries: '' 90801 category: 'Polymorph-Widgets'! 90802!DropListMorph commentStamp: 'gvc 5/23/2007 14:12' prior: 0! 90803Displays a selected item and a drop button. When pressed will popup a list to enable changing of the selection. Supports enablement.! 90804 90805 90806!DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/22/2006 13:25'! 90807buttonMorph 90808 "Answer the value of buttonMorph" 90809 90810 ^ buttonMorph! ! 90811 90812!DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/22/2006 13:25'! 90813buttonMorph: anObject 90814 "Set the value of buttonMorph" 90815 90816 buttonMorph := anObject! ! 90817 90818!DropListMorph methodsFor: 'accessing' stamp: 'gvc 6/17/2006 11:45'! 90819contentMorph 90820 "Answer the value of contentMorph" 90821 90822 ^ contentMorph! ! 90823 90824!DropListMorph methodsFor: 'accessing' stamp: 'gvc 6/17/2006 11:45'! 90825contentMorph: anObject 90826 "Set the value of contentMorph" 90827 90828 contentMorph := anObject! ! 90829 90830!DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/14/2006 13:18'! 90831enabled 90832 "Answer the value of enabled" 90833 90834 ^ enabled! ! 90835 90836!DropListMorph methodsFor: 'accessing' stamp: 'gvc 9/1/2006 15:57'! 90837enabled: anObject 90838 "Set the value of enabled" 90839 90840 enabled = anObject ifTrue: [^self]. 90841 enabled := anObject. 90842 anObject ifFalse: [self hideList]. 90843 self changed: #enabled. 90844 self 90845 adoptPaneColor: self paneColor; 90846 changed! ! 90847 90848!DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/14/2006 13:16'! 90849getEnabledSelector 90850 "Answer the value of getEnabledSelector" 90851 90852 ^ getEnabledSelector! ! 90853 90854!DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/14/2006 13:30'! 90855getEnabledSelector: anObject 90856 "Set the value of getEnabledSelector" 90857 90858 getEnabledSelector := anObject. 90859 self updateEnabled! ! 90860 90861!DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! 90862getIndexSelector 90863 "Answer the value of getIndexSelector" 90864 90865 ^ getIndexSelector! ! 90866 90867!DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! 90868getIndexSelector: anObject 90869 "Set the value of getIndexSelector" 90870 90871 getIndexSelector := anObject! ! 90872 90873!DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! 90874getListSelector 90875 "Answer the value of getListSelector" 90876 90877 ^ getListSelector! ! 90878 90879!DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! 90880getListSelector: anObject 90881 "Set the value of getListSelector" 90882 90883 getListSelector := anObject! ! 90884 90885!DropListMorph methodsFor: 'accessing' stamp: 'gvc 6/17/2006 11:07'! 90886listMorph 90887 "Answer the value of listMorph" 90888 90889 ^ listMorph! ! 90890 90891!DropListMorph methodsFor: 'accessing' stamp: 'gvc 6/17/2006 11:07'! 90892listMorph: anObject 90893 "Set the value of listMorph" 90894 90895 listMorph := anObject! ! 90896 90897!DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! 90898setIndexSelector 90899 "Answer the value of setIndexSelector" 90900 90901 ^ setIndexSelector! ! 90902 90903!DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! 90904setIndexSelector: anObject 90905 "Set the value of setIndexSelector" 90906 90907 setIndexSelector := anObject! ! 90908 90909!DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:53'! 90910useSelectionIndex 90911 "Answer the value of useSelectionIndex" 90912 90913 ^ useSelectionIndex! ! 90914 90915!DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:53'! 90916useSelectionIndex: anObject 90917 "Set the value of useSelectionIndex" 90918 90919 useSelectionIndex := anObject! ! 90920 90921 90922!DropListMorph methodsFor: 'as yet unclassified'! 90923addToggleItemsToHaloMenu: aCustomMenu 90924 "Add toggle-items to the halo menu" 90925 90926 super addToggleItemsToHaloMenu: aCustomMenu. 90927 aCustomMenu 90928 addUpdating: #enabledString 90929 target: self 90930 action: #toggleEnabled! ! 90931 90932!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/22/2009 15:35'! 90933adoptPaneColor: paneColor 90934 "Pass on to the list morph and border too." 90935 90936 super adoptPaneColor: paneColor. 90937 paneColor ifNil: [^self]. 90938 self fillStyle: self fillStyleToUse. 90939 self borderWidth > 0 ifTrue: [ 90940 self borderStyle: self borderStyleToUse]. 90941 self buttonMorph cornerStyle: self cornerStyle. 90942 self updateContentColor: paneColor. 90943 self listPaneColor: paneColor. 90944 self changed: #buttonLabel! ! 90945 90946!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:04'! 90947borderStyleToUse 90948 "Answer the borderStyle that should be used for the receiver." 90949 90950 ^self enabled 90951 ifTrue: [self theme dropListNormalBorderStyleFor: self] 90952 ifFalse: [self theme dropListDisabledBorderStyleFor: self]! ! 90953 90954!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/23/2009 13:12'! 90955buttonExtent 90956 "Answer based on theme and preferences." 90957 90958 ^self buttonWidth @ self buttonHeight! ! 90959 90960!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/23/2009 13:12'! 90961buttonHeight 90962 "Answer based on theme." 90963 90964 ^self theme buttonMinHeight! ! 90965 90966!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/1/2009 11:40'! 90967buttonLabel 90968 "Answer the label for the button." 90969 90970 ^self theme dropListButtonLabelFor: self! ! 90971 90972!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/28/2009 17:08'! 90973buttonWidth 90974 "Answer based on scrollbar size." 90975 90976 ^(Preferences scrollBarsNarrow ifTrue: [12] ifFalse: [16]) 90977 max: self theme dropListControlButtonWidth! ! 90978 90979!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/22/2006 13:31'! 90980cornerStyle: aSymbol 90981 "Pass on to list and button too." 90982 90983 super cornerStyle: aSymbol. 90984 self listMorph cornerStyle: aSymbol. 90985 self buttonMorph cornerStyle: aSymbol.! ! 90986 90987!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/17/2006 11:17'! 90988defaultColor 90989 "Answer the default color of the receiver." 90990 90991 ^Color white! ! 90992 90993!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 12:18'! 90994disable 90995 "Disable the receiver." 90996 90997 self enabled: false! ! 90998 90999!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/31/2007 15:16'! 91000drawSubmorphsOn: aCanvas 91001 "Display submorphs back to front. 91002 Draw the focus here since we are using inset bounds 91003 for the focus rectangle." 91004 91005 super drawSubmorphsOn: aCanvas. 91006 self hasKeyboardFocus ifTrue: [ 91007 self drawKeyboardFocusOn: aCanvas]! ! 91008 91009!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 12:18'! 91010enable 91011 "Enable the receiver." 91012 91013 self enabled: true! ! 91014 91015!DropListMorph methodsFor: 'as yet unclassified'! 91016enabledString 91017 "Answer the string to be shown in a menu to represent the 91018 'enabled' status" 91019 91020 ^ (self enabled 91021 ifTrue: ['<on>'] 91022 ifFalse: ['<off>']), 'enabled' translated! ! 91023 91024!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:04'! 91025extent: newExtent 91026 "Update the gradient." 91027 91028 super extent: newExtent. 91029 (self fillStyle notNil and: [self fillStyle isSolidFill not]) 91030 ifTrue: [self fillStyle: self fillStyleToUse]! ! 91031 91032!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:03'! 91033fillStyleToUse 91034 "Answer the fillStyle that should be used for the receiver." 91035 91036 ^self enabled 91037 ifTrue: [self theme dropListNormalFillStyleFor: self] 91038 ifFalse: [self theme dropListDisabledFillStyleFor: self]! ! 91039 91040!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/20/2009 16:38'! 91041focusBounds 91042 "Answer the bounds for drawing the focus indication." 91043 91044 ^self theme dropListFocusBoundsFor: self! ! 91045 91046!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/20/2009 16:40'! 91047focusIndicatorCornerRadius 91048 "Answer the corner radius preferred for the focus indicator 91049 for the receiver for themes that support this." 91050 91051 ^self theme dropListFocusIndicatorCornerRadiusFor: self ! ! 91052 91053!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2006 15:07'! 91054font 91055 "Answer the list font" 91056 91057 ^self listMorph font! ! 91058 91059!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/31/2007 12:34'! 91060font: aFont 91061 "Set the list and content font" 91062 91063 self listMorph font: aFont. 91064 self contentMorph beAllFont: aFont! ! 91065 91066!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 14:15'! 91067getCurrentSelection 91068 "Answer the current selection from the model." 91069 91070 |selection| 91071 selection := self model perform: self getIndexSelector. 91072 ^(self list includes: selection) 91073 ifTrue: [selection]! ! 91074 91075!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/17/2006 12:30'! 91076getCurrentSelectionIndex 91077 "Answer the index of the current selection." 91078 91079 self getIndexSelector ifNil: [^0]. 91080 ^self model perform: self getIndexSelector! ! 91081 91082!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2006 11:30'! 91083handlesKeyboard: evt 91084 "Return true if the receiver wishes to handle the given keyboard event." 91085 91086 ^true! ! 91087 91088!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/13/2009 13:54'! 91089hideList 91090 "Hide the list." 91091 91092 self listMorph ifNil: [^self]. 91093 self listVisible ifFalse: [^self]. 91094 self listMorph delete. 91095 self listMorph selectionIndex = self listSelectionIndex 91096 ifFalse: [self listMorph changeModelSelection: self listMorph selectionIndex]. 91097 self roundedCorners: #(1 2 3 4). 91098 (self buttonMorph ifNil: [^self]) roundedCorners: (self roundedCorners copyWithoutAll: #(1 2)). 91099 self changed. 91100 self wantsKeyboardFocus 91101 ifTrue: [self takeKeyboardFocus]! ! 91102 91103!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/23/2009 12:20'! 91104initialize 91105 "Initialize the receiver." 91106 91107 super initialize. 91108 listSelectionIndex := 0. 91109 enabled := true. 91110 list := #(). 91111 self 91112 useSelectionIndex: true; 91113 clipSubmorphs: true; 91114 layoutPolicy: RowLayout new; 91115 layoutInset: (self theme dropListInsetFor: self); 91116 cellPositioning: #center; 91117 listMorph: self newListMorph; 91118 contentMorph: self newContentMorph; 91119 buttonMorph: self newButtonMorph; 91120 borderStyle: self borderStyleToUse; 91121 addMorphBack: self contentMorph; 91122 addMorphBack: (self addDependent: self buttonMorph); 91123 on: #mouseDown send: #popList to: self. 91124 self listMorph fillStyle: (self theme dropListNormalListFillStyleFor: self)! ! 91125 91126!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/8/2007 13:31'! 91127keyStroke: event 91128 "Pass on to the list." 91129 91130 (self navigationKey: event) ifTrue: [^self]. 91131 self listMorph keyStroke: event ! ! 91132 91133!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/6/2007 14:37'! 91134keyboardFocusChange: aBoolean 91135 "The message is sent to a morph when its keyboard focus changes. 91136 Update for focus feedback." 91137 91138 self focusChanged! ! 91139 91140!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/17/2006 11:27'! 91141list 91142 "Answer the list contents." 91143 91144 ^list! ! 91145 91146!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/17/2006 11:31'! 91147list: aCollection 91148 "Set the list contents." 91149 91150 list := aCollection. 91151 self changed: #list! ! 91152 91153!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/29/2006 12:16'! 91154listHeight 91155 "Answer the height for the list." 91156 91157 ^(self listMorph listMorph height + 6 max: 38) min: 200! ! 91158 91159!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/17/2006 11:42'! 91160listMorphClass 91161 "Answer the class for a new list morph" 91162 91163 ^PluggableListMorph! ! 91164 91165!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/22/2006 15:44'! 91166listMouseDown: evt 91167 "Click outside the list." 91168 91169 (self listMorph fullContainsPoint: evt position) 91170 ifTrue: [self listMorph selectionIndex: (self listMorph rowAtLocation: evt position)] 91171 ifFalse: [self hideList]! ! 91172 91173!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/13/2009 14:01'! 91174listPaneColor: paneColor 91175 "Set the pane color for the list." 91176 91177 self listMorph ifNil: [^self]. 91178 self listMorph 91179 adoptPaneColor: paneColor; 91180 fillStyle: (self theme dropListNormalListFillStyleFor: self); 91181 borderStyle: (self theme dropListNormalListBorderStyleFor: self)! ! 91182 91183!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/17/2006 11:28'! 91184listSelectionIndex 91185 "Answer the list selection." 91186 91187 ^listSelectionIndex! ! 91188 91189!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 16:08'! 91190listSelectionIndex: anInteger 91191 "Set the list selection." 91192 91193 self hideList. 91194 anInteger = 0 ifTrue: [^self]. 91195 listSelectionIndex := anInteger. 91196 self 91197 changed: #listSelectionIndex; 91198 updateContents; 91199 triggerEvent: #selectionIndex with: anInteger. 91200 self model ifNotNilDo: [:m | 91201 self setIndexSelector ifNotNilDo: [:s | 91202 self useSelectionIndex 91203 ifTrue: [m perform: s with: anInteger] 91204 ifFalse: [m perform: s with: self selectedItem]]]! ! 91205 91206!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/17/2006 12:26'! 91207listVisible 91208 "Answer whether the list is visible." 91209 91210 ^self listMorph owner notNil! ! 91211 91212!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/17/2006 12:27'! 91213morphicLayerNumber 91214 "Answer the layer number." 91215 91216 ^self listVisible ifTrue: [10] ifFalse: [super morphicLayerNumber]! ! 91217 91218!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/23/2009 13:12'! 91219newButtonMorph 91220 "Answer a new button morph" 91221 91222 ^(ControlButtonMorph 91223 on: self 91224 getState: nil 91225 action: #popList 91226 label: #buttonLabel) 91227 roundedCorners: #(3 4); 91228 getEnabledSelector: #enabled; 91229 label: self buttonLabel; 91230 vResizing: #spaceFill; 91231 hResizing: #rigid; 91232 extent: self buttonExtent; 91233 setProperty: #wantsKeyboardFocusNavigation toValue: false; 91234 cornerStyle: self cornerStyle! ! 91235 91236!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/5/2007 09:23'! 91237newContentMorph 91238 "Answer a new content morph" 91239 91240 ^TextMorphForFieldView new 91241 contents: ' '; 91242 margins: (2@0 corner: 2@1); 91243 vResizing: #shrinkWrap; 91244 hResizing: #spaceFill; 91245 autoFit: false; 91246 lock! ! 91247 91248!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/13/2009 14:01'! 91249newListMorph 91250 "Answer a new list morph" 91251 91252 |m| 91253 m := (self listMorphClass 91254 on: self 91255 list: #list 91256 selected: #listSelectionIndex 91257 changeSelected: #listSelectionIndex: 91258 menu: nil 91259 keystroke: nil) 91260 roundedCorners: #(2 3); 91261 setProperty: #morphicLayerNumber toValue: 5; 91262 color: self color; 91263 borderStyle: (self theme dropListNormalListBorderStyleFor: self); 91264 on: #mouseDown send: #listMouseDown: to: self. 91265 ^m! ! 91266 91267!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 15:58'! 91268on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel 91269 "Set the receiver to the given model parameterized by the given message selectors." 91270 91271 getListSel isSymbol 91272 ifTrue: [self getListSelector: getListSel] 91273 ifFalse: [self list: getListSel]. "allow direct list" 91274 self 91275 model: anObject; 91276 getIndexSelector: getSelectionSel; 91277 setIndexSelector: setSelectionSel; 91278 updateList; 91279 updateListSelectionIndex; 91280 updateContents! ! 91281 91282!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/8/2006 10:13'! 91283outOfWorld: aWorld 91284 "Get rid of the list if visible." 91285 91286 self hideList. 91287 ^super outOfWorld: aWorld! ! 91288 91289!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/22/2006 15:00'! 91290popList 91291 "Hide / show the list." 91292 91293 self enabled ifFalse: [^self]. 91294 self listMorph owner isNil 91295 ifTrue: [self showList] 91296 ifFalse: [self hideList]! ! 91297 91298!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2009 18:15'! 91299roundedCorners: anArray 91300 "Set the corners to round." 91301 91302 super roundedCorners: anArray. 91303 self buttonMorph ifNotNilDo: [:b | 91304 b roundedCorners: (anArray copyWithoutAll: #(1 2))]! ! 91305 91306!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 14:12'! 91307selectedItem 91308 "Answer the selected list item." 91309 91310 ^(self listSelectionIndex between: 1 and: self list size) ifTrue: [ 91311 self list at: self listSelectionIndex]! ! 91312 91313!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/12/2006 13:58'! 91314selectionColor 91315 "Answer the selection color for the receiver." 91316 91317 ^self listMorph selectionColor! ! 91318 91319!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/12/2006 13:58'! 91320selectionColor: aColor 91321 "Set the selection color for the receiver." 91322 91323 self listMorph selectionColor: aColor! ! 91324 91325!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/13/2009 12:07'! 91326showList 91327 "Show the list." 91328 91329 self listMorph owner isNil 91330 ifTrue: [self listMorph 91331 bounds: (self boundsInWorld bottomLeft extent: self width @ self listHeight). 91332 self listPaneColor: self paneColor. 91333 self world addMorphInLayer: self listMorph. 91334 self buttonMorph roundedCorners: (self roundedCorners copyWithoutAll: #(1 2 3)). 91335 self roundedCorners: (self roundedCorners copyWithoutAll: #(2 3)). 91336 self changed. 91337 self listMorph wantsKeyboardFocus ifTrue: [ 91338 self listMorph takeKeyboardFocus]. 91339 self activeHand 91340 newMouseFocus: self listMorph]! ! 91341 91342!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2007 14:37'! 91343step 91344 "Reset mouse focus to the list if it is showing." 91345 91346 self listVisible ifTrue: [ 91347 self activeHand mouseFocus ifNil: [ 91348 self listMorph wantsKeyboardFocus ifTrue: [ 91349 self listMorph takeKeyboardFocus]. 91350 self activeHand newMouseFocus: self listMorph]]! ! 91351 91352!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/6/2006 12:48'! 91353stepTime 91354 "Answer the desired time between steps in milliseconds." 91355 91356 ^100! ! 91357 91358!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2007 12:30'! 91359takesKeyboardFocus 91360 "Answer whether the receiver can normally take keyboard focus." 91361 91362 ^true! ! 91363 91364!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/23/2009 13:13'! 91365themeChanged 91366 "Update the selection colour." 91367 91368 self selectionColor ifNotNil: [ 91369 self selectionColor: self theme selectionColor]. 91370 self layoutInset: (self theme dropListInsetFor: self). 91371 self buttonMorph extent: self buttonExtent. 91372 super themeChanged! ! 91373 91374!DropListMorph methodsFor: 'as yet unclassified'! 91375toggleEnabled 91376 "Toggle the enabled state." 91377 91378 self enabled: self enabled not! ! 91379 91380!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/14/2006 13:18'! 91381update: aSymbol 91382 "Refer to the comment in View|update:." 91383 91384 aSymbol == getListSelector ifTrue: 91385 [self updateList. 91386 ^ self]. 91387 aSymbol == getIndexSelector ifTrue: 91388 [self updateListSelectionIndex. 91389 ^ self]. 91390 aSymbol == getEnabledSelector ifTrue: 91391 [self updateEnabled. 91392 ^ self]. 91393! ! 91394 91395!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:16'! 91396updateContentColor: paneColor 91397 "Change the content text color." 91398 91399 self enabled 91400 ifTrue: [self contentMorph textColor: Color black] 91401 ifFalse: [self contentMorph textColor: paneColor duller]! ! 91402 91403!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2006 15:35'! 91404updateContents 91405 "Update the contents." 91406 91407 |sel| 91408 self contentMorph 91409 contents: (self listSelectionIndex > 0 91410 ifTrue: [sel := self list at: self listSelectionIndex. 91411 sel isText 91412 ifTrue: [sel] 91413 ifFalse: [sel asString]] 91414 ifFalse: [' ']) "needs something to keep font"! ! 91415 91416!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:25'! 91417updateEnabled 91418 "Update the enablement state." 91419 91420 self model ifNotNil: [ 91421 self getEnabledSelector ifNotNil: [ 91422 self enabled: (self model perform: self getEnabledSelector)]]! ! 91423 91424!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 15:57'! 91425updateList 91426 "Refresh the list." 91427 91428 self getListSelector isSymbol ifTrue: [ 91429 self list: (self model perform: self getListSelector). 91430 listSelectionIndex := 0]! ! 91431 91432!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/17/2008 12:34'! 91433updateListSelectionIndex 91434 "Update the list selection." 91435 91436 |i| 91437 self useSelectionIndex 91438 ifTrue: [i := self getCurrentSelectionIndex. 91439 listSelectionIndex == i ifTrue: [^self]. 91440 listSelectionIndex := i] 91441 ifFalse: [i := self getCurrentSelection. 91442 listSelectionIndex := i isNil 91443 ifTrue: [0] 91444 ifFalse: [self list indexOf: i]]. 91445 self 91446 changed: #listSelectionIndex; 91447 updateContents; 91448 triggerEvent: #selectionIndex with: i! ! 91449 91450!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 15:53'! 91451useIndex 91452 "Use the model as returning the selected index rather than item." 91453 91454 self useSelectionIndex: true! ! 91455 91456!DropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 15:53'! 91457useSelection 91458 "Use the model as returning the selected item rather than index." 91459 91460 self useSelectionIndex: false! ! 91461 91462"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 91463 91464DropListMorph class 91465 uses: TEnableOnHaloMenu classTrait 91466 instanceVariableNames: ''! 91467 91468!DropListMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 7/17/2006 12:25'! 91469on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel 91470 "Answer a new instance of the receiver on the given model using 91471 the given selectors as the interface." 91472 91473 ^self new 91474 on: anObject 91475 list: getListSel 91476 selected: getSelectionSel 91477 changeSelected: setSelectionSel! ! 91478 91479!DropListMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 16:05'! 91480on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel useIndex: useIndex 91481 "Answer a new instance of the receiver on the given model using 91482 the given selectors as the interface." 91483 91484 ^self new 91485 useSelectionIndex: useIndex; 91486 on: anObject 91487 list: getListSel 91488 selected: getSelectionSel 91489 changeSelected: setSelectionSel! ! 91490Model subclass: #DualChangeSorter 91491 instanceVariableNames: 'leftCngSorter rightCngSorter' 91492 classVariableNames: '' 91493 poolDictionaries: '' 91494 category: 'Tools-Changes'! 91495!DualChangeSorter commentStamp: '<historical>' prior: 0! 91496This class presents a view of a two change sets at once, and supports copying changes between change sets. 91497! 91498 91499 91500!DualChangeSorter methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/23/2009 16:31'! 91501modelWakeUp 91502 "A window with me as model is being entered. Make sure I am up-to-date with the changeSets. 91503 Treat each side individually rather than going through the . Changed here to avoid endless confirm dialogs." 91504 91505 leftCngSorter canDiscardEdits ifTrue: [leftCngSorter updateIfNecessary]. 91506 rightCngSorter canDiscardEdits ifTrue: [rightCngSorter updateIfNecessary]! ! 91507 91508 91509!DualChangeSorter methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 91510morphicWindow 91511 91512 | window | 91513 leftCngSorter := ChangeSorter new myChangeSet: ChangeSet current. 91514 leftCngSorter parent: self. 91515 rightCngSorter := ChangeSorter new myChangeSet: 91516 ChangeSorter secondaryChangeSet. 91517 rightCngSorter parent: self. 91518 91519 window := (SystemWindow labelled: leftCngSorter label) model: self. 91520 "topView minimumSize: 300 @ 200." 91521 leftCngSorter openAsMorphIn: window rect: (0@0 extent: 0.5@1). 91522 rightCngSorter openAsMorphIn: window rect: (0.5@0 extent: 0.5@1). 91523 ^ window 91524! ! 91525 91526!DualChangeSorter methodsFor: 'initialization' stamp: 'di 5/20/1998 21:44'! 91527okToChange 91528 ^ leftCngSorter okToChange & rightCngSorter okToChange! ! 91529 91530!DualChangeSorter methodsFor: 'initialization' stamp: 'alain.plantec 5/30/2008 13:00'! 91531open 91532 ^ self openAsMorph. 91533! ! 91534 91535!DualChangeSorter methodsFor: 'initialization' stamp: 'sw 3/6/1999 09:34'! 91536openAsMorph 91537 ^ self morphicWindow openInWorld 91538! ! 91539 91540!DualChangeSorter methodsFor: 'initialization'! 91541release 91542 leftCngSorter release. 91543 rightCngSorter release.! ! 91544 91545 91546!DualChangeSorter methodsFor: 'other'! 91547isLeftSide: theOne 91548 "Which side am I?" 91549 ^ theOne == leftCngSorter! ! 91550 91551!DualChangeSorter methodsFor: 'other' stamp: 'sd 11/20/2005 21:27'! 91552labelString 91553 "The window label" 91554 91555 | leftName rightName changesName | 91556 leftName := leftCngSorter changeSetCategory categoryName. 91557 rightName := rightCngSorter changeSetCategory categoryName. 91558 changesName := 'Changes go to "', ChangeSet current name, '"'. 91559 ^ ((leftName ~~ #All) or: [rightName ~~ #All]) 91560 ifTrue: 91561 ['(', leftName, ') - ', changesName, ' - (', rightName, ')'] 91562 ifFalse: 91563 [changesName]! ! 91564 91565!DualChangeSorter methodsFor: 'other'! 91566other: theOne 91567 "Return the other side's ChangeSorter" 91568 ^ theOne == leftCngSorter 91569 ifTrue: [rightCngSorter] 91570 ifFalse: [leftCngSorter]! ! 91571 91572 91573!DualChangeSorter methodsFor: 'toolbuilder' stamp: 'sd 11/20/2005 21:27'! 91574buildWith: builder 91575 | windowSpec | 91576 leftCngSorter := ChangeSorter new myChangeSet: ChangeSet current. 91577 leftCngSorter parent: self. 91578 rightCngSorter := ChangeSorter new myChangeSet: 91579 ChangeSorter secondaryChangeSet. 91580 rightCngSorter parent: self. 91581 91582 windowSpec := builder pluggableWindowSpec new. 91583 windowSpec model: self. 91584 windowSpec label: 'Change Sorter'. 91585 windowSpec children: OrderedCollection new. 91586 leftCngSorter buildWith: builder in: windowSpec rect: (0@0 extent: 0.5@1). 91587 rightCngSorter buildWith: builder in: windowSpec rect: (0.5@0 extent: 0.5@1). 91588 ^builder build: windowSpec 91589! ! 91590 91591"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 91592 91593DualChangeSorter class 91594 instanceVariableNames: ''! 91595 91596!DualChangeSorter class methodsFor: 'initialization' stamp: 'asm 4/10/2003 12:44'! 91597registerInFlapsRegistry 91598 "Register the receiver in the system's flaps registry" 91599 self environment 91600 at: #Flaps 91601 ifPresent: [:cl | cl registerQuad: #(DualChangeSorter prototypicalToolWindow 'Change Sorter' 'Shows two change sets side by side') 91602 forFlapNamed: 'Tools']! ! 91603 91604!DualChangeSorter class methodsFor: 'initialization' stamp: 'asm 4/11/2003 12:33'! 91605unload 91606 "Unload the receiver from global registries" 91607 91608 self environment at: #Flaps ifPresent: [:cl | 91609 cl unregisterQuadsWithReceiver: self] ! ! 91610 91611 91612!DualChangeSorter class methodsFor: 'opening' stamp: 'sw 3/24/1999 17:50'! 91613open 91614 "Open a new instance of the receiver's class" 91615 91616 self new open! ! 91617 91618!DualChangeSorter class methodsFor: 'opening' stamp: 'sw 6/11/2001 17:38'! 91619prototypicalToolWindow 91620 "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" 91621 91622 ^ self new morphicWindow applyModelExtent! ! 91623 91624 91625!DualChangeSorter class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:12'! 91626windowColorSpecification 91627 "Answer a WindowColorSpec object that declares my preference" 91628 91629 ^ WindowColorSpec classSymbol: self name wording: 'Dual Change Sorter' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'Lets you view and manipulate two change sets concurrently.'! ! 91630AbstractSoundSystem subclass: #DummySoundSystem 91631 instanceVariableNames: '' 91632 classVariableNames: '' 91633 poolDictionaries: '' 91634 category: 'System-Support'! 91635!DummySoundSystem commentStamp: 'gk 2/24/2004 23:14' prior: 0! 91636This is a dummy sound system registered in SoundService to absorb all sound playing and to use the primitive beep instead of sampled sounds when playing a beep.! 91637 91638 91639!DummySoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 20:48'! 91640randomBitsFromSoundInput: bitCount 91641 "I'm not sure what the right thing to do here is." 91642 91643 self error: 'Can not provide random data.'! ! 91644 91645!DummySoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:54'! 91646sampledSoundChoices 91647 "No choices other than this." 91648 91649 ^ #('silence')! ! 91650 91651!DummySoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:55'! 91652soundNamed: soundName 91653 "There are no sounds to look up." 91654 91655 ^ nil! ! 91656 91657 91658!DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/24/2004 23:53'! 91659beep 91660 "Make a primitive beep." 91661 91662 Beeper beepPrimitive! ! 91663 91664!DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:53'! 91665playSampledSound: samples rate: rate 91666 "Do nothing." 91667 ! ! 91668 91669!DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:54'! 91670playSoundNamed: soundName 91671 "Do nothing."! ! 91672 91673!DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:54'! 91674playSoundNamed: soundName ifAbsentReadFrom: aifFileName 91675 "Do nothing."! ! 91676 91677!DummySoundSystem methodsFor: 'playing' stamp: 'gk 4/8/2005 14:15'! 91678playSoundNamedOrBeep: soundName 91679 "There is no sound support, so we make the beep." 91680 91681 self beep! ! 91682 91683"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 91684 91685DummySoundSystem class 91686 instanceVariableNames: ''! 91687 91688!DummySoundSystem class methodsFor: 'initialization' stamp: 'gk 2/23/2004 21:08'! 91689initialize 91690 SoundService register: self new.! ! 91691 91692!DummySoundSystem class methodsFor: 'initialization' stamp: 'gk 2/23/2004 21:08'! 91693unload 91694 SoundService registeredClasses do: [:ss | 91695 (ss isKindOf: self) ifTrue: [SoundService unregister: ss]].! ! 91696Stream subclass: #DummyStream 91697 instanceVariableNames: '' 91698 classVariableNames: '' 91699 poolDictionaries: '' 91700 category: 'System-Object Storage'! 91701!DummyStream commentStamp: '<historical>' prior: 0! 91702The purpose of this class is to absorb all steam messages and do nothing. This is so ReferenceStream can pretend to write on it while traversing all objects it would normally write. We need to know what those object are. 8/17/96 tk 91703! 91704 91705 91706!DummyStream methodsFor: 'accessing'! 91707nextInt32Put: arg 91708 "do nothing"! ! 91709 91710!DummyStream methodsFor: 'accessing'! 91711nextNumber: cnt put: num 91712 "do nothing"! ! 91713 91714!DummyStream methodsFor: 'accessing' stamp: 'tk 6/8/1998 21:06'! 91715nextPutAll: aByteArray 91716 "do nothing"! ! 91717 91718!DummyStream methodsFor: 'accessing' stamp: 'tk 6/8/1998 21:07'! 91719nextPut: aByte 91720 "do nothing"! ! 91721 91722!DummyStream methodsFor: 'accessing'! 91723nextStringPut: aString 91724 "do nothing"! ! 91725 91726!DummyStream methodsFor: 'accessing' stamp: 'tk 3/6/2000 11:10'! 91727originalContents 91728 91729 ^ ''! ! 91730 91731!DummyStream methodsFor: 'accessing'! 91732position 91733 "Return any random number. Here is where the real lying begins. We are a DummyStream afterall. 8/17/96 tk" 91734 91735 ^ 47 ! ! 91736 91737!DummyStream methodsFor: 'accessing' stamp: 'tk 7/12/1998 12:51'! 91738position: anOffset 91739 "Pretend to position wherever the caller says!!" 91740! ! 91741 91742 91743!DummyStream methodsFor: 'error handling'! 91744subclassResponsibility 91745 "Do nothing. Most messages to class Stream are defined as subclassResponsibility. Just accept them. 8/17/96 tk" 91746 91747 "No error. Just go on."! ! 91748 91749 91750!DummyStream methodsFor: 'positioning' stamp: '6/10/97 17:14 tk'! 91751skip: aNumber 91752 "Do nothing."! ! 91753 91754"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 91755 91756DummyStream class 91757 instanceVariableNames: ''! 91758 91759!DummyStream class methodsFor: 'instance creation' stamp: 'jm 12/3/97 20:25'! 91760on: aFile 91761 "Return a new DummyStream instance, ignoring the argument." 91762 91763 ^ self basicNew 91764! ! 91765Magnitude subclass: #Duration 91766 instanceVariableNames: 'nanos seconds' 91767 classVariableNames: '' 91768 poolDictionaries: 'ChronologyConstants' 91769 category: 'Kernel-Chronology'! 91770!Duration commentStamp: 'marcus.denker 6/5/2009 11:27' prior: 0! 91771I represent a duration of time. I have nanosecond precision! 91772 91773 91774!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:59'! 91775* operand 91776 "operand is a Number" ^ self class nanoSeconds: ( (self asNanoSeconds * operand) asInteger) 91777! ! 91778 91779!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:59'! 91780+ operand 91781 91782 "operand is a Duration" ^ self class nanoSeconds: (self asNanoSeconds + operand asNanoSeconds) 91783 ! ! 91784 91785!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:59'! 91786- operand 91787 "operand is a Duration" ^ self + operand negated 91788 ! ! 91789 91790!Duration methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:36'! 91791/ operand 91792 "operand is a Duration or a Number" 91793 91794 ^ operand isNumber 91795 ifTrue: [ self class nanoSeconds: (self asNanoSeconds / operand) asInteger ] 91796 ifFalse: [ self asNanoSeconds / operand asDuration asNanoSeconds ] 91797 91798 ! ! 91799 91800!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:00'! 91801< comparand 91802 91803 ^ self asNanoSeconds < comparand asNanoSeconds 91804 ! ! 91805 91806!Duration methodsFor: 'ansi protocol' stamp: 'brp 1/9/2004 06:25'! 91807= comparand 91808 "Answer whether the argument is a <Duration> representing the same 91809 period of time as the receiver." 91810 91811 ^ self == comparand 91812 ifTrue: [true] 91813 ifFalse: 91814 [self species = comparand species 91815 ifTrue: [self asNanoSeconds = comparand asNanoSeconds] 91816 ifFalse: [false] ]! ! 91817 91818!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'! 91819abs 91820 91821 ^ self class seconds: seconds abs nanoSeconds: nanos abs 91822 ! ! 91823 91824!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'! 91825asDuration 91826 91827 ^ self 91828 ! ! 91829 91830!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'! 91831asSeconds 91832 91833 91834 ^ seconds 91835 ! ! 91836 91837!Duration methodsFor: 'ansi protocol' stamp: 'gk 8/30/2006 23:42'! 91838days 91839 "Answer the number of days the receiver represents." 91840 91841 ^ seconds quo: SecondsInDay 91842! ! 91843 91844!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'! 91845hash ^seconds bitXor: nanos 91846 ! ! 91847 91848!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'! 91849hours 91850 "Answer the number of hours the receiver represents." 91851 91852 91853 ^ (seconds rem: SecondsInDay) quo: SecondsInHour 91854 ! ! 91855 91856!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'! 91857minutes 91858 91859 "Answer the number of minutes the receiver represents." 91860 91861 91862 ^ (seconds rem: SecondsInHour) quo: SecondsInMinute 91863 ! ! 91864 91865!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:02'! 91866negated 91867 91868 ^ self class seconds: seconds negated nanoSeconds: nanos negated 91869 ! ! 91870 91871!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:02'! 91872negative 91873 91874 91875 ^ self positive not 91876 ! ! 91877 91878!Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:02'! 91879positive 91880 91881 91882 ^ seconds = 0 ifTrue: [ nanos positive ] ifFalse: [ seconds positive ] 91883 ! ! 91884 91885!Duration methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 10:03'! 91886seconds 91887 "Answer the number of seconds the receiver represents." 91888 91889 ^ (seconds rem: SecondsInMinute) + (nanos / NanosInSecond)! ! 91890 91891 91892!Duration methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:51'! 91893initialize 91894 super initialize. 91895 self seconds: 0 nanoSeconds: 0. 91896! ! 91897 91898 91899!Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 14:29'! 91900// operand 91901 91902 "operand is a Duration or a Number" 91903 91904 91905 ^ operand isNumber 91906 ifTrue: [ self class nanoSeconds: (self asNanoSeconds // operand) asInteger ] 91907 ifFalse: [ self asNanoSeconds // operand asDuration asNanoSeconds ] 91908 ! ! 91909 91910!Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 15:07'! 91911\\ operand 91912 91913 "modulo. Remainder defined in terms of //. Answer a Duration with the 91914 same sign as aDuration. operand is a Duration or a Number." 91915 91916 ^ operand isNumber 91917 ifTrue: [ self class nanoSeconds: (self asNanoSeconds \\ operand) ] 91918 ifFalse: [ self - (operand * (self // operand)) ] 91919 ! ! 91920 91921!Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 13:42'! 91922asDelay 91923 91924 ^ Delay forDuration: self! ! 91925 91926!Duration methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:03'! 91927asMilliSeconds 91928 91929 91930 ^ ((seconds * NanosInSecond) + nanos) // (10 raisedToInteger: 6) 91931 ! ! 91932 91933!Duration methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:03'! 91934asNanoSeconds 91935 91936 ^ (seconds * NanosInSecond) + nanos 91937 ! ! 91938 91939!Duration methodsFor: 'squeak protocol' stamp: 'brp 4/13/2006 10:20'! 91940isZero 91941 91942 ^ seconds = 0 and: [ nanos = 0 ] 91943! ! 91944 91945!Duration methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:03'! 91946nanoSeconds 91947 91948 91949 ^ nanos 91950 ! ! 91951 91952!Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 13:22'! 91953printOn: aStream 91954 "Format as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]" | d h m s n | 91955 d := self days abs. 91956 h := self hours abs. 91957 m := self minutes abs. 91958 s := self seconds abs truncated. 91959 n := self nanoSeconds abs. self negative ifTrue: [ aStream nextPut: $- ]. 91960 d printOn: aStream. aStream nextPut: $:. 91961 h < 10 ifTrue: [ aStream nextPut: $0. ]. 91962 h printOn: aStream. aStream nextPut: $:. 91963 m < 10 ifTrue: [ aStream nextPut: $0. ]. 91964 m printOn: aStream. aStream nextPut: $:. 91965 s < 10 ifTrue: [ aStream nextPut: $0. ]. 91966 s printOn: aStream. 91967 n = 0 ifFalse: 91968 [ | z ps | 91969 aStream nextPut: $.. 91970 ps := n printString padded: #left to: 9 with: $0. 91971 z := ps findLast: [ :c | c asciiValue > $0 asciiValue ]. 91972 ps from: 1 to: z do: [ :c | aStream nextPut: c ] ]. 91973! ! 91974 91975!Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 15:42'! 91976roundTo: aDuration 91977 "e.g. if the receiver is 5 minutes, 37 seconds, and aDuration is 2 minutes, answer 6 minutes." 91978 91979 ^ self class nanoSeconds: (self asNanoSeconds roundTo: aDuration asNanoSeconds) 91980 91981 ! ! 91982 91983!Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 15:38'! 91984truncateTo: aDuration 91985 "e.g. if the receiver is 5 minutes, 37 seconds, and aDuration is 2 minutes, answer 4 minutes." 91986 91987 ^ self class 91988 nanoSeconds: (self asNanoSeconds truncateTo: aDuration asNanoSeconds) 91989 91990 ! ! 91991 91992 91993!Duration methodsFor: 'private' stamp: 'adrian_lienhard 1/7/2009 18:19'! 91994seconds: secondCount nanoSeconds: nanoCount 91995 "Private - only used by Duration class" 91996 91997 seconds := secondCount. 91998 nanos := nanoCount rounded! ! 91999 92000!Duration methodsFor: 'private' stamp: 'brp 9/25/2003 14:42'! 92001storeOn: aStream 92002 92003 aStream 92004 nextPut: $(; 92005 nextPutAll: self className; 92006 nextPutAll: ' seconds: '; 92007 print: seconds; 92008 nextPutAll: ' nanoSeconds: '; 92009 print: nanos; 92010 nextPut: $). 92011 ! ! 92012 92013!Duration methodsFor: 'private' stamp: 'adrian_lienhard 1/7/2009 18:21'! 92014ticks 92015 "Answer an array {days. seconds. nanoSeconds}. Used by DateAndTime and Time." 92016 92017 | days | 92018 days := self days. 92019 ^ Array 92020 with: days 92021 with: seconds - (days * SecondsInDay) 92022 with: nanos! ! 92023 92024"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 92025 92026Duration class 92027 instanceVariableNames: ''! 92028 92029!Duration class methodsFor: 'ansi protocol' stamp: 'gk 8/31/2006 01:09'! 92030days: days hours: hours minutes: minutes seconds: seconds 92031 92032 ^ self days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: 0! ! 92033 92034!Duration class methodsFor: 'ansi protocol' stamp: 'gk 8/30/2006 23:18'! 92035days: days seconds: seconds 92036 92037 ^ self basicNew seconds: days * SecondsInDay + seconds nanoSeconds: 0 92038! ! 92039 92040!Duration class methodsFor: 'ansi protocol' stamp: 'gk 8/31/2006 01:34'! 92041seconds: seconds 92042 92043 ^ self seconds: seconds nanoSeconds: 0 92044! ! 92045 92046!Duration class methodsFor: 'ansi protocol' stamp: 'gk 8/31/2006 00:09'! 92047zero 92048 92049 ^ self basicNew seconds: 0 nanoSeconds: 0 92050! ! 92051 92052 92053!Duration class methodsFor: 'squeak protocol' stamp: 'gk 8/31/2006 01:25'! 92054days: aNumber 92055 92056 ^ self seconds: aNumber * SecondsInDay nanoSeconds: 0! ! 92057 92058!Duration class methodsFor: 'squeak protocol' stamp: 'gk 8/31/2006 01:26'! 92059days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: nanos 92060 92061 ^ self seconds: ((days * SecondsInDay) 92062 + (hours * SecondsInHour) 92063 + (minutes * SecondsInMinute) 92064 + seconds) 92065 nanoSeconds: nanos 92066! ! 92067 92068!Duration class methodsFor: 'squeak protocol' stamp: 'PeterHugossonMiller 9/2/2009 16:18'! 92069fromString: aString 92070 92071 ^ self readFrom: aString readStream 92072! ! 92073 92074!Duration class methodsFor: 'squeak protocol' stamp: 'gk 8/31/2006 01:26'! 92075hours: aNumber 92076 92077 ^ self seconds: aNumber * SecondsInHour nanoSeconds: 0! ! 92078 92079!Duration class methodsFor: 'squeak protocol' stamp: 'gk 8/31/2006 01:35'! 92080milliSeconds: milliCount 92081 "Since seconds is 0 we can call the instance directly." 92082 92083 ^ self basicNew seconds: 0 nanoSeconds: milliCount * NanosInMillisecond! ! 92084 92085!Duration class methodsFor: 'squeak protocol' stamp: 'gk 8/31/2006 01:27'! 92086minutes: aNumber 92087 92088 ^ self seconds: aNumber * SecondsInMinute nanoSeconds: 0! ! 92089 92090!Duration class methodsFor: 'squeak protocol' stamp: 'brp 1/9/2004 17:20'! 92091month: aMonth 92092 "aMonth is an Integer or a String" 92093 92094 ^ (Month month: aMonth year: Year current year) duration 92095! ! 92096 92097!Duration class methodsFor: 'squeak protocol' stamp: 'adrian_lienhard 1/7/2009 18:22'! 92098nanoSeconds: nanos 92099 "This method is slow. If you have nanos less than 10^6 you should use #seconds:nanoSeconds: instead." 92100 92101 | quo | 92102 quo := nanos quo: NanosInSecond. 92103 ^ self basicNew 92104 seconds: quo 92105 nanoSeconds: nanos - (quo * NanosInSecond)! ! 92106 92107!Duration class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 12:47'! 92108readFrom: aStream 92109 "Formatted as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S] 92110 To assiste DateAndTime>>#readFrom: SS may be unpadded or absent." 92111 92112 | sign days hours minutes seconds nanos ws ch | 92113 sign := (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. 92114 92115 days := (aStream upTo: $:) asInteger sign: sign. 92116 hours := (aStream upTo: $:) asInteger sign: sign. 92117 minutes := (aStream upTo: $:) asInteger sign: sign. 92118 92119 aStream atEnd 92120 ifTrue: [seconds := 0. nanos := 0] 92121 ifFalse: 92122 [ ws := String new writeStream. 92123 [ch := aStream next. (ch isNil) | (ch = $.)] 92124 whileFalse: [ ws nextPut: ch ]. 92125 seconds := ws contents asInteger sign: sign. 92126 ws reset. 92127 9 timesRepeat: 92128 [ ch := aStream next. 92129 ws nextPut: (ch ifNil: [$0] ifNotNil: [ch]) ]. 92130 nanos := ws contents asInteger sign: sign]. 92131 92132 ^ self days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: nanos. 92133 92134 " '0:00:00:00' asDuration 92135 '0:00:00:00.000000001' asDuration 92136 '0:00:00:00.999999999' asDuration 92137 '0:00:00:00.100000000' asDuration 92138 '0:00:00:00.10' asDuration 92139 '0:00:00:00.1' asDuration 92140 '0:00:00:01' asDuration 92141 '0:12:45:45' asDuration 92142 '1:00:00:00' asDuration 92143 '365:00:00:00' asDuration 92144 '-7:09:12:06.10' asDuration 92145 '+0:01:02' asDuration 92146 '+0:01:02:3' asDuration 92147 " 92148! ! 92149 92150!Duration class methodsFor: 'squeak protocol' stamp: 'adrian_lienhard 1/7/2009 18:19'! 92151seconds: seconds nanoSeconds: nanos 92152 ^ self basicNew 92153 seconds: seconds truncated 92154 nanoSeconds: seconds fractionPart * NanosInSecond + nanos! ! 92155 92156!Duration class methodsFor: 'squeak protocol' stamp: 'gk 8/30/2006 23:20'! 92157weeks: aNumber 92158 92159 ^ self days: (aNumber * 7) seconds: 0 92160! ! 92161ClassTestCase subclass: #DurationTest 92162 instanceVariableNames: 'aDuration' 92163 classVariableNames: '' 92164 poolDictionaries: '' 92165 category: 'KernelTests-Chronology'! 92166 92167!DurationTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 14:30'! 92168classToBeTested 92169 92170 ^ Duration 92171 92172 92173! ! 92174 92175!DurationTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 14:30'! 92176selectorsToBeIgnored 92177 92178 | private | 92179 private := #( #printOn: ). 92180 92181 ^ super selectorsToBeIgnored, private 92182! ! 92183 92184 92185!DurationTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 06:32'! 92186testComparing 92187 92188 | d1 d2 d3 | 92189 d1 := Duration seconds: 10 nanoSeconds: 1. 92190 d2 := Duration seconds: 10 nanoSeconds: 1. 92191 d3 := Duration seconds: 10 nanoSeconds: 2. 92192 92193 self 92194 assert: (d1 = d1); 92195 assert: (d1 = d2); 92196 deny: (d1 = d3); 92197 assert: (d1 < d3) 92198! ! 92199 92200!DurationTest methodsFor: 'Tests' stamp: 'brp 1/21/2004 18:36'! 92201testModulo 92202 92203 | d1 d2 d3 | 92204 d1 := 11.5 seconds. 92205 d2 := d1 \\ 3. 92206 self assert: d2 = (Duration nanoSeconds: 1). 92207 92208 d3 := d1 \\ (3 seconds). 92209 self assert: d3 = (Duration seconds: 2 nanoSeconds: 500000000). 92210 92211 self assert: aDuration \\ aDuration = 92212 (Duration days: 0 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0). 92213 self assert: aDuration \\ 2 = 92214 (Duration days: 0 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 1). 92215 92216 92217! ! 92218 92219!DurationTest methodsFor: 'Tests' stamp: 'brp 1/16/2004 14:17'! 92220testMonthDurations 92221 92222 | jan feb dec | 92223 jan := Duration month: #January. 92224 feb := Duration month: #February. 92225 dec := Duration month: #December. 92226 92227 self 92228 assert: jan = (Year current months first duration); 92229 assert: feb = (Year current months second duration); 92230 assert: dec = (Year current months last duration) 92231 92232 92233! ! 92234 92235!DurationTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 06:28'! 92236testNumberConvenienceMethods 92237 92238 self 92239 assert: 1 week = (Duration days: 7); 92240 assert: -1 week = (Duration days: -7); 92241 assert: 1 day = (Duration days: 1); 92242 assert: -1 day = (Duration days: -1); 92243 assert: 1 hours = (Duration hours: 1); 92244 assert: -1 hour = (Duration hours: -1); 92245 assert: 1 minute = (Duration seconds: 60); 92246 assert: -1 minute = (Duration seconds: -60); 92247 assert: 1 second = (Duration seconds: 1); 92248 assert: -1 second = (Duration seconds: -1); 92249 assert: 1 milliSecond = (Duration milliSeconds: 1); 92250 assert: -1 milliSecond = (Duration milliSeconds: -1); 92251 assert: 1 nanoSecond = (Duration nanoSeconds: 1); 92252 assert: -1 nanoSecond = (Duration nanoSeconds: -1) 92253 ! ! 92254 92255!DurationTest methodsFor: 'Tests' stamp: 'brp 9/25/2003 14:57'! 92256testQuotient 92257 92258 | d1 d2 q | 92259 d1 := 11.5 seconds. 92260 d2 := d1 // 3. 92261 self assert: d2 = (Duration seconds: 3 nanoSeconds: 833333333). 92262 92263 q := d1 // (3 seconds). 92264 self assert: q = 3. 92265 92266! ! 92267 92268!DurationTest methodsFor: 'Tests' stamp: 'brp 1/21/2004 18:38'! 92269testRoundTo 92270 92271 self assert: ((5 minutes + 37 seconds) roundTo: (2 minutes)) = (6 minutes). 92272 92273 self assert: (aDuration roundTo: (Duration days: 1)) = 92274 (Duration days: 1 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0). 92275 self assert: (aDuration roundTo: (Duration hours: 1)) = 92276 (Duration days: 1 hours: 2 minutes: 0 seconds: 0 nanoSeconds: 0). 92277 self assert: (aDuration roundTo: (Duration minutes: 1)) = 92278 (Duration days: 1 hours: 2 minutes: 3 seconds: 0 nanoSeconds: 0).! ! 92279 92280!DurationTest methodsFor: 'Tests' stamp: 'brp 1/21/2004 18:37'! 92281testTruncateTo 92282 92283 self assert: ((5 minutes + 37 seconds) truncateTo: (2 minutes)) = (4 minutes). 92284 self assert: (aDuration truncateTo: (Duration days: 1)) = 92285 (Duration days: 1 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0). 92286 self assert: (aDuration truncateTo: (Duration hours: 1)) = 92287 (Duration days: 1 hours: 2 minutes: 0 seconds: 0 nanoSeconds: 0). 92288 self assert: (aDuration truncateTo: (Duration minutes: 1)) = 92289 (Duration days: 1 hours: 2 minutes: 3 seconds: 0 nanoSeconds: 0).! ! 92290 92291 92292!DurationTest methodsFor: 'running' stamp: 'brp 1/21/2004 18:36'! 92293setUp 92294 aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5 ! ! 92295 92296 92297!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92298testAbs 92299 self assert: aDuration abs = aDuration. 92300 self assert: (Duration nanoSeconds: -5) abs = (Duration nanoSeconds: 5). 92301! ! 92302 92303!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92304testAsDelay 92305 self deny: aDuration asDelay = aDuration. 92306 "want to come up with a more meaningful test" 92307! ! 92308 92309!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92310testAsDuration 92311 self assert: aDuration asDuration = aDuration 92312 92313! ! 92314 92315!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92316testAsMilliSeconds 92317 self assert: (Duration nanoSeconds: 1000000) asMilliSeconds = 1. 92318 self assert: (Duration seconds: 1) asMilliSeconds = 1000. 92319 self assert: (Duration nanoSeconds: 1000000) asMilliSeconds = 1. 92320 self assert: (Duration nanoSeconds: 1000000) asMilliSeconds = 1. 92321 self assert: aDuration asMilliSeconds = 93784000.! ! 92322 92323!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92324testAsNanoSeconds 92325 self assert: (Duration nanoSeconds: 1) asNanoSeconds = 1. 92326 self assert: (Duration seconds: 1) asNanoSeconds = 1000000000. 92327 self assert: aDuration asNanoSeconds = 93784000000005.! ! 92328 92329!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92330testAsSeconds 92331 self assert: (Duration nanoSeconds: 1000000000) asSeconds = 1. 92332 self assert: (Duration seconds: 1) asSeconds = 1. 92333 self assert: aDuration asSeconds = 93784.! ! 92334 92335!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92336testDays 92337 self assert: aDuration days = 1. 92338 self assert: (Duration days: 1) days= 1. ! ! 92339 92340!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92341testDivide 92342 self assert: aDuration / aDuration = 1. 92343 self assert: aDuration / 2 = (Duration days: 0 hours: 13 minutes: 1 seconds: 32 nanoSeconds: 2). 92344 self assert: aDuration / (1/2) = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). 92345! ! 92346 92347!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92348testFromString 92349 self assert: aDuration = (Duration fromString: '1:02:03:04.000000005'). 92350! ! 92351 92352!DurationTest methodsFor: 'testing' stamp: 'al 6/12/2008 21:57'! 92353testHash 92354 self assert: aDuration hash = (Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5) hash! ! 92355 92356!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92357testHours 92358 self assert: aDuration hours = 2. 92359 self assert: (Duration hours: 2) hours = 2. ! ! 92360 92361!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92362testIntegerDivision 92363 self assert: aDuration // aDuration = 1. 92364 self assert: aDuration // 2 = (aDuration / 2). 92365 "is there ever a case where this is not true, since precision is always to the nano second?"! ! 92366 92367!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92368testLessThan 92369 self assert: aDuration < (aDuration + 1 day ). 92370 self deny: aDuration < aDuration. 92371 ! ! 92372 92373!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92374testMilliSeconds 92375 self assert: (Duration milliSeconds: 5) nanoSeconds = 5000000. ! ! 92376 92377!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92378testMinus 92379 self assert: aDuration - aDuration = (Duration seconds: 0). 92380 self assert: aDuration - (Duration days: -1 hours: -2 minutes: -3 seconds: -4 nanoSeconds: -5) = 92381 (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). 92382 self assert: aDuration - (Duration days: 0 hours: 1 minutes: 2 seconds: 3 nanoSeconds: 4) = 92383 (Duration days: 1 hours: 1 minutes: 1 seconds: 1 nanoSeconds: 1). 92384 self assert: aDuration - (Duration days: 0 hours: 3 minutes: 0 seconds: 5 nanoSeconds: 0) = 92385 (Duration days: 0 hours: 23 minutes: 2 seconds: 59 nanoSeconds: 5). ! ! 92386 92387!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92388testMinutes 92389 self assert: aDuration minutes = 3. 92390 self assert: (Duration minutes: 3) minutes = 3. ! ! 92391 92392!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92393testMultiply 92394 self assert: aDuration * 2 = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). ! ! 92395 92396!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92397testNanoSeconds 92398 self assert: aDuration nanoSeconds = 5. 92399 self assert: (Duration nanoSeconds: 5) nanoSeconds = 5. ! ! 92400 92401!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92402testNegated 92403 self assert: aDuration + aDuration negated = (Duration seconds: 0). 92404! ! 92405 92406!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92407testNegative 92408 self deny: aDuration negative. 92409 self assert: aDuration negated negative 92410! ! 92411 92412!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92413testNew 92414 "self assert: Duration new = (Duration seconds: 0)." 92415 "new is not valid as a creation method: MessageNotUnderstood: UndefinedObject>>quo:, where Duration seconds is nil"! ! 92416 92417!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92418testPlus 92419 self assert: (aDuration + 0 hours) = aDuration. 92420 self assert: (aDuration + aDuration) = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). ! ! 92421 92422!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92423testPositive 92424 self assert: (Duration nanoSeconds: 0) positive. 92425 self assert: aDuration positive. 92426 self deny: aDuration negated positive 92427! ! 92428 92429!DurationTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 92430testPrintOn 92431 | cs rw | 92432 cs := '1:02:03:04.000000005' readStream. 92433 rw := ReadWriteStream on: ''. 92434 aDuration printOn: rw. 92435 self assert: rw contents = cs contents! ! 92436 92437!DurationTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 92438testReadFrom 92439 self assert: aDuration = (Duration readFrom: '1:02:03:04.000000005' readStream)! ! 92440 92441!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92442testSeconds 92443 self assert: aDuration seconds = (800000001/200000000). 92444 self assert: (Duration nanoSeconds: 2) seconds = (2/1000000000). 92445 self assert: (Duration seconds: 2) seconds = 2. 92446 self assert: (Duration days: 1 hours: 2 minutes: 3 seconds:4) seconds = (4). 92447 self deny: (Duration days: 1 hours: 2 minutes: 3 seconds:4) seconds = (1*24*60*60+(2*60*60)+(3*60)+4). ! ! 92448 92449!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92450testSecondsNanoSeconds 92451 self assert: (Duration seconds: 0 nanoSeconds: 5) = (Duration nanoSeconds: 5). 92452 "not sure I should include in sunit since its Private " 92453 self assert: (aDuration seconds: 0 nanoSeconds: 1) = (Duration nanoSeconds: 1). 92454! ! 92455 92456!DurationTest methodsFor: 'testing' stamp: 'PeterHugossonMiller 9/3/2009 16:02'! 92457testStoreOn 92458 | stream | 92459 aDuration storeOn: (stream := (String new: 20) writeStream). 92460 self assert: stream contents = '(Duration seconds: 93784 nanoSeconds: 5)'. 92461 92462! ! 92463 92464!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92465testTicks 92466 self assert: aDuration ticks = #(1 7384 5)! ! 92467 92468!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92469testWeeks 92470 self assert: (Duration weeks: 1) days= 7. ! ! 92471 92472!DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! 92473testZero 92474 self assert: (Duration zero) = (Duration seconds: 0). ! ! 92475ProcessSpecificVariable subclass: #DynamicVariable 92476 instanceVariableNames: '' 92477 classVariableNames: '' 92478 poolDictionaries: '' 92479 category: 'Kernel-Processes'! 92480!DynamicVariable commentStamp: 'mvl 3/13/2007 13:55' prior: 0! 92481My subclasses are dynamic variables: each subclass represents a variable 92482whose value persists inside the block passed to #value:during:. There is 92483no way to change the value inside such a block, but it is possible to 92484temporarirly rebind it in a nested manner.! 92485 92486 92487"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 92488 92489DynamicVariable class 92490 instanceVariableNames: ''! 92491 92492!DynamicVariable class methodsFor: 'accessing' stamp: 'mvl 3/13/2007 14:26'! 92493value: anObject during: aBlock 92494 92495 | p oldValue | 92496 92497 p := Processor activeProcess. 92498 oldValue := p environmentAt: self ifAbsent: [self default]. 92499 [ 92500 p environmentAt: self put: anObject. 92501 aBlock value. 92502 ] ensure: [ 92503 p environmentAt: self put: oldValue 92504 ].! ! 92505BDFFontReader subclass: #EFontBDFFontReader 92506 instanceVariableNames: '' 92507 classVariableNames: '' 92508 poolDictionaries: '' 92509 category: 'Multilingual-Display'! 92510 92511!EFontBDFFontReader methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 20:28'! 92512readCharactersInRangeFrom: start to: stop totalNums: upToNum storeInto: chars 92513 92514 | array form code | 92515 1 to: upToNum do: [:i | 92516 array := self readOneCharacter. 92517 code := array at: 2. 92518 code > stop ifTrue: [^ self]. 92519 (code between: start and: stop) ifTrue: [ 92520 form := array at: 1. 92521 form ifNotNil: [ 92522 chars add: array. 92523 ]. 92524 ]. 92525 ]. 92526! ! 92527 92528!EFontBDFFontReader methodsFor: 'as yet unclassified' stamp: 'lr 7/4/2009 10:42'! 92529readFrom: start to: end 92530 | xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx width blt lastAscii pointSize ret lastValue | 92531 form := encoding := bbx := nil. 92532 self initialize. 92533 self readAttributes. 92534 height := Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). 92535 ascent := Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. 92536 descent := Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. 92537 (properties includesKey: 'POINT_SIZE' asSymbol) 92538 ifTrue: 92539 [ pointSize := (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10 ] 92540 ifFalse: [ pointSize := (ascent + descent) * 72 // 96 ]. 92541 maxWidth := 0. 92542 minAscii := 2097152. 92543 strikeWidth := 0. 92544 maxAscii := 0. 92545 charsNum := Integer readFromString: (properties at: #CHARS) first. 92546 chars := Set new: charsNum. 92547 self 92548 readCharactersInRangeFrom: start 92549 to: end 92550 totalNums: charsNum 92551 storeInto: chars. 92552 chars := chars asSortedCollection: [ :x :y | (x at: 2) <= (y at: 2) ]. 92553 charsNum := chars size. "undefined encodings make this different" 92554 chars do: 92555 [ :array | 92556 encoding := array at: 2. 92557 bbx := array at: 3. 92558 width := bbx at: 1. 92559 maxWidth := maxWidth max: width. 92560 minAscii := minAscii min: encoding. 92561 maxAscii := maxAscii max: encoding. 92562 strikeWidth := strikeWidth + width ]. 92563 glyphs := Form extent: strikeWidth @ height. 92564 blt := BitBlt toForm: glyphs. 92565 "xTable := XTableForUnicodeFont new ranges: (Array with: (Array with: start with: end))." 92566 xTable := SparseLargeTable 92567 new: end + 3 92568 chunkSize: 32 92569 arrayClass: Array 92570 base: start + 1 92571 defaultValue: -1. 92572 lastAscii := start. 92573 1 92574 to: charsNum 92575 do: 92576 [ :i | 92577 form := (chars at: i) first. 92578 encoding := (chars at: i) second. 92579 bbx := (chars at: i) third. 92580 "lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)]." 92581 lastValue := xTable at: lastAscii + 1 + 1. 92582 xTable 92583 at: encoding + 1 92584 put: lastValue. 92585 blt 92586 copy: ((xTable at: encoding + 1) @ (ascent - (bbx at: 2) - (bbx at: 4)) extent: (bbx at: 1) @ (bbx at: 2)) 92587 from: 0 @ 0 92588 in: form. 92589 xTable 92590 at: encoding + 2 92591 put: (xTable at: encoding + 1) + (bbx at: 1). 92592 lastAscii := encoding ]. 92593 xTable zapDefaultOnlyEntries. 92594 ret := Array new: 8. 92595 ret 92596 at: 1 92597 put: xTable. 92598 ret 92599 at: 2 92600 put: glyphs. 92601 ret 92602 at: 3 92603 put: minAscii. 92604 ret 92605 at: 4 92606 put: maxAscii. 92607 ret 92608 at: 5 92609 put: maxWidth. 92610 ret 92611 at: 6 92612 put: ascent. 92613 ret 92614 at: 7 92615 put: descent. 92616 ret 92617 at: 8 92618 put: pointSize. 92619 ^ ret 92620 " ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}"! ! 92621EFontBDFFontReader subclass: #EFontBDFFontReaderForRanges 92622 instanceVariableNames: '' 92623 classVariableNames: '' 92624 poolDictionaries: '' 92625 category: 'Multilingual-Display'! 92626 92627!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 20:32'! 92628additionalRangesForJapanese 92629 92630 | basics | 92631 basics := { 92632 Array with: 16r5C with: 16rFF3C. 92633 Array with: 16r3013 with: 16rFFFD. 92634 }. 92635 ^ basics 92636! ! 92637 92638!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 20:32'! 92639additionalRangesForKorean 92640 92641 | basics | 92642 basics := { 92643 Array with: 16rA1 with: 16rFFE6C. 92644 Array with: 16r3000 with: 16rFFFD. 92645 }. 92646 ^ basics 92647! ! 92648 92649!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'damiencassou 5/30/2008 15:30'! 92650override: chars with: otherFileName ranges: pairArray transcodingTable: table additionalRange: additionalRange 92651 | other rangeStream currentRange newChars code form u newArray j | 92652 other := BDFFontReader readOnlyFileNamed: otherFileName. 92653 rangeStream := pairArray readStream. 92654 currentRange := rangeStream next. 92655 newChars := PluggableSet new. 92656 newChars hashBlock: [ :elem | (elem at: 2) hash ]. 92657 newChars equalBlock: [ :a :b | (a at: 2) = (b at: 2) ]. 92658 other readChars do: 92659 [ :array | 92660 code := array at: 2. 92661 "code printStringHex printString displayAt: 0@0." 92662 code > currentRange last ifTrue: 92663 [ 92664 [ rangeStream atEnd not and: 92665 [ currentRange := rangeStream next. 92666 currentRange last < code ] ] whileTrue. 92667 rangeStream atEnd ifTrue: 92668 [ newChars addAll: chars. 92669 ^ newChars ] ]. 92670 (code 92671 between: currentRange first 92672 and: currentRange last) ifTrue: 92673 [ form := array at: 1. 92674 form ifNotNil: 92675 [ j := array at: 2. 92676 u := table at: (j // 256 - 33) * 94 + (j \\ 256 - 33) + 1. 92677 u ~= -1 ifTrue: 92678 [ array 92679 at: 2 92680 put: u. 92681 newChars add: array. 92682 additionalRange do: 92683 [ :e | 92684 e first = (array at: 2) ifTrue: 92685 [ newArray := array clone. 92686 newArray 92687 at: 2 92688 put: e second. 92689 newChars add: newArray ] ] ] ] ] ]. 92690 self error: 'should not reach here'! ! 92691 92692!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 20:34'! 92693rangesForJapanese 92694 92695 | basics etc | 92696 basics := { 92697 Array with: 16r5C with: 16r5C. 92698 Array with: 16rA2 with: 16rA3. 92699 Array with: 16rA7 with: 16rA8. 92700 Array with: 16rAC with: 16rAC. 92701 Array with: 16rB0 with: 16rB1. 92702 Array with: 16rB4 with: 16rB4. 92703 Array with: 16rB6 with: 16rB6. 92704 Array with: 16rD7 with: 16rD7. 92705 Array with: 16rF7 with: 16rF7 92706 }. 92707 etc := { 92708 Array with: 16r370 with: 16r3FF. "greek" 92709 Array with: 16r400 with: 16r52F. "cyrillic" 92710 Array with: 16r1D00 with: 16r1D7F. "phonetic" 92711 Array with: 16r1E00 with: 16r1EFF. "latin extended additional" 92712 Array with: 16r2000 with: 16r206F. "general punctuation" 92713 Array with: 16r20A0 with: 16r20CF. "currency symbols" 92714 Array with: 16r2100 with: 16r214F. "letterlike" 92715 Array with: 16r2150 with: 16r218F. "number form" 92716 Array with: 16r2190 with: 16r21FF. "arrows" 92717 Array with: 16r2200 with: 16r22FF. "math operators" 92718 Array with: 16r2300 with: 16r23FF. "misc tech" 92719 Array with: 16r2460 with: 16r24FF. "enclosed alnum" 92720 Array with: 16r2500 with: 16r257F. "box drawing" 92721 Array with: 16r2580 with: 16r259F. "box elem" 92722 Array with: 16r25A0 with: 16r25FF. "geometric shapes" 92723 Array with: 16r2600 with: 16r26FF. "misc symbols" 92724 Array with: 16r2700 with: 16r27BF. "dingbats" 92725 Array with: 16r27C0 with: 16r27EF. "misc math A" 92726 Array with: 16r27F0 with: 16r27FF. "supplimental arrow A" 92727 Array with: 16r2900 with: 16r297F. "supplimental arrow B" 92728 Array with: 16r2980 with: 16r29FF. "misc math B" 92729 Array with: 16r2A00 with: 16r2AFF. "supplimental math op" 92730 Array with: 16r2900 with: 16r297F. "supplimental arrow B" 92731 Array with: 16r2E80 with: 16r2EFF. "cjk radicals suppliment" 92732 Array with: 16r2F00 with: 16r2FDF. "kangxi radicals" 92733 Array with: 16r3000 with: 16r303F. "cjk symbols" 92734 Array with: 16r3040 with: 16r309F. "hiragana" 92735 Array with: 16r30A0 with: 16r30FF. "katakana" 92736 Array with: 16r3190 with: 16r319F. "kanbun" 92737 Array with: 16r31F0 with: 16r31FF. "katakana extension" 92738 Array with: 16r3200 with: 16r32FF. "enclosed CJK" 92739 Array with: 16r3300 with: 16r33FF. "CJK compatibility" 92740 Array with: 16r3400 with: 16r4DBF. "CJK unified extension A" 92741 Array with: 16r4E00 with: 16r9FAF. "CJK ideograph" 92742 Array with: 16rF900 with: 16rFAFF. "CJK compatiblity ideograph" 92743 Array with: 16rFE30 with: 16rFE4F. "CJK compatiblity forms" 92744 Array with: 16rFF00 with: 16rFFEF. "half and full" 92745 Array with: 16rFFFF with: 16rFFFF. "sentinel" 92746 }. 92747 92748 ^ basics, etc. 92749! ! 92750 92751!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 20:34'! 92752rangesForKorean 92753 92754 | basics etc | 92755 basics := { 92756 Array with: 16rA1 with: 16rFF 92757 }. 92758 etc := { 92759 Array with: 16r100 with: 16r17F. "extended latin" 92760 Array with: 16r370 with: 16r3FF. "greek" 92761 Array with: 16r400 with: 16r52F. "cyrillic" 92762 Array with: 16r2000 with: 16r206F. "general punctuation" 92763 Array with: 16r2100 with: 16r214F. "letterlike" 92764 Array with: 16r2150 with: 16r218F. "number form" 92765 Array with: 16r2190 with: 16r21FF. "arrows" 92766 Array with: 16r2200 with: 16r22FF. "math operators" 92767 Array with: 16r2300 with: 16r23FF. "misc tech" 92768 Array with: 16r2460 with: 16r24FF. "enclosed alnum" 92769 Array with: 16r2500 with: 16r257F. "box drawing" 92770 Array with: 16r2580 with: 16r259F. "box elem" 92771 Array with: 16r25A0 with: 16r25FF. "geometric shapes" 92772 Array with: 16r2600 with: 16r26FF. "misc symbols" 92773 Array with: 16r3000 with: 16r303F. "cjk symbols" 92774 Array with: 16r3040 with: 16r309F. "hiragana" 92775 Array with: 16r30A0 with: 16r30FF. "katakana" 92776 Array with: 16r3190 with: 16r319F. "kanbun" 92777 Array with: 16r31F0 with: 16r31FF. "katakana extension" 92778 Array with: 16r3200 with: 16r32FF. "enclosed CJK" 92779 Array with: 16r3300 with: 16r33FF. "CJK compatibility" 92780 Array with: 16r4E00 with: 16r9FAF. "CJK ideograph" 92781 Array with: 16rAC00 with: 16rD7AF. "Hangul Syllables" 92782 Array with: 16rF900 with: 16rFAFF. "CJK compatiblity ideograph" 92783 Array with: 16rFF00 with: 16rFFEF. "half and full" 92784 }. 92785 92786 ^ basics, etc. 92787! ! 92788 92789!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 1/19/2005 11:20'! 92790rangesForLatin2 92791 92792 ^ { 92793 Array with: 0 with: 16r17F. 92794 Array with: 16r2B0 with: 16r2FF. 92795 Array with: 16r2000 with: 16r206F. 92796 Array with: 16r2122 with: 16r2122. 92797 Array with: 16rFFFF with: 16rFFFF. "sentinel" 92798 }. 92799! ! 92800 92801!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'damiencassou 5/30/2008 15:30'! 92802readCharactersInRanges: ranges storeInto: chars 92803 | array form code rangeStream currentRange | 92804 rangeStream := ranges readStream. 92805 currentRange := rangeStream next. 92806 [ true ] whileTrue: 92807 [ array := self readOneCharacter. 92808 array second ifNil: [ ^ self ]. 92809 code := array at: 2. 92810 code > currentRange last ifTrue: 92811 [ 92812 [ rangeStream atEnd not and: 92813 [ currentRange := rangeStream next. 92814 currentRange last < code ] ] whileTrue. 92815 rangeStream atEnd ifTrue: [ ^ self ] ]. 92816 (code 92817 between: currentRange first 92818 and: currentRange last) ifTrue: 92819 [ form := array at: 1. 92820 form ifNotNil: [ chars add: array ] ] ]! ! 92821 92822!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:09'! 92823readRanges: ranges 92824 92825 | xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx width blt lastAscii pointSize ret lastValue start end | 92826 form := encoding := bbx := nil. 92827 self initialize. 92828 self readAttributes. 92829 height := Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). 92830 ascent := Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. 92831 descent := Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. 92832 (properties includesKey: 'POINT_SIZE' asSymbol) ifTrue: [ 92833 pointSize := (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. 92834 ] ifFalse: [ 92835 pointSize := (ascent + descent) * 72 // 96. 92836 ]. 92837 92838 maxWidth := 0. 92839 minAscii := 16r200000. 92840 strikeWidth := 0. 92841 maxAscii := 0. 92842 92843 charsNum := Integer readFromString: (properties at: #CHARS) first. 92844 chars := Set new: charsNum. 92845 92846 self readCharactersInRanges: ranges storeInto: chars. 92847 92848 chars := chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)]. 92849 charsNum := chars size. "undefined encodings make this different" 92850 92851 chars do: [:array | 92852 encoding := array at: 2. 92853 bbx := array at: 3.. 92854 width := bbx at: 1. 92855 maxWidth := maxWidth max: width. 92856 minAscii := minAscii min: encoding. 92857 maxAscii := maxAscii max: encoding. 92858 strikeWidth := strikeWidth + width. 92859 ]. 92860 92861 glyphs := Form extent: strikeWidth@height. 92862 blt := BitBlt toForm: glyphs. 92863 start := (ranges collect: [:r | r first]) min. 92864 end := (ranges collect: [:r | r second]) max + 3. 92865 92866 xTable := SparseLargeTable new: end chunkSize: 64 arrayClass: Array base: start +1 defaultValue: -1. 92867 lastAscii := start. 92868 xTable at: lastAscii + 2 put: 0. 92869 1 to: charsNum do: [:i | 92870 form := (chars at: i) first. 92871 encoding := (chars at: i) second. 92872 bbx := (chars at: i) third. 92873 "lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)]." 92874 lastValue := xTable at: lastAscii + 1 + 1. 92875 xTable at: encoding + 1 put: lastValue. 92876 blt copy: (((xTable at: encoding+1)@(ascent - (bbx at: 2) - (bbx at: 4))) 92877 extent: (bbx at: 1)@(bbx at: 2)) 92878 from: 0@0 in: form. 92879 xTable at: encoding+2 put: (xTable at: encoding+1)+(bbx at: 1). 92880 lastAscii := encoding. 92881 ]. 92882 xTable at: xTable size put: (xTable at: xTable size - 1). 92883 xTable zapDefaultOnlyEntries. 92884 ret := Array new: 8. 92885 ret at: 1 put: xTable. 92886 ret at: 2 put: glyphs. 92887 ret at: 3 put: minAscii. 92888 ret at: 4 put: maxAscii. 92889 ret at: 5 put: maxWidth. 92890 ret at: 6 put: ascent. 92891 ret at: 7 put: descent. 92892 ret at: 8 put: pointSize. 92893 ^ret. 92894" ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}" 92895! ! 92896 92897!EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 20:39'! 92898readRanges: ranges overrideWith: otherFileName otherRanges: otherRanges additionalOverrideRange: additionalRange 92899 92900 | xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx width blt lastAscii pointSize ret lastValue start end | 92901 form := encoding := bbx := nil. 92902 self initialize. 92903 self readAttributes. 92904 height := Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). 92905 ascent := Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. 92906 descent := Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. 92907 (properties includesKey: 'POINT_SIZE' asSymbol) ifTrue: [ 92908 pointSize := (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. 92909 ] ifFalse: [ 92910 pointSize := (ascent + descent) * 72 // 96. 92911 ]. 92912 92913 92914 maxWidth := 0. 92915 minAscii := 16r200000. 92916 strikeWidth := 0. 92917 maxAscii := 0. 92918 92919 charsNum := Integer readFromString: (properties at: #CHARS) first. 92920 chars := Set new: charsNum. 92921 92922 self readCharactersInRanges: ranges storeInto: chars. 92923 chars := self override: chars with: otherFileName ranges: otherRanges transcodingTable: (UCSTable jisx0208Table) additionalRange: additionalRange. 92924 92925 chars := chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)]. 92926 charsNum := chars size. "undefined encodings make this different" 92927 92928 chars do: [:array | 92929 encoding := array at: 2. 92930 bbx := array at: 3.. 92931 width := bbx at: 1. 92932 maxWidth := maxWidth max: width. 92933 minAscii := minAscii min: encoding. 92934 maxAscii := maxAscii max: encoding. 92935 strikeWidth := strikeWidth + width. 92936 ]. 92937 92938 glyphs := Form extent: strikeWidth@height. 92939 blt := BitBlt toForm: glyphs. 92940 start := ((ranges collect: [:r | r first]), (additionalRange collect: [:r2 | r2 first])) min. 92941 end := ((ranges collect: [:r | r second]), (additionalRange collect: [:r2 | r2 second])) max + 3. 92942 "xRange := Array with: (Array with: ((ranges collect: [:r | r first]), (additionalRange collect: [:r2 | r2 first])) min 92943 with: (((ranges collect: [:r | r second]), (additionalRange collect: [:r2 | r2 second])) max + 2))." 92944 "xTable := XTableForUnicodeFont new 92945 ranges: xRange." 92946 xTable := SparseLargeTable new: end chunkSize: 64 arrayClass: Array base: start defaultValue: -1. 92947 lastAscii := start. 92948 xTable at: lastAscii + 2 put: 0. 92949 1 to: charsNum do: [:i | 92950 form := (chars at: i) first. 92951 encoding := (chars at: i) second. 92952 bbx := (chars at: i) third. 92953 "lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)]." 92954 lastValue := xTable at: lastAscii + 1 + 1. 92955 xTable at: encoding + 1 put: lastValue. 92956 blt copy: (((xTable at: encoding+1)@(ascent - (bbx at: 2) - (bbx at: 4))) 92957 extent: (bbx at: 1)@(bbx at: 2)) 92958 from: 0@0 in: form. 92959 xTable at: encoding+2 put: (xTable at: encoding+1)+(bbx at: 1). 92960 lastAscii := encoding. 92961 ]. 92962 xTable at: xTable size put: (xTable at: xTable size - 1). 92963 xTable zapDefaultOnlyEntries. 92964 ret := Array new: 8. 92965 ret at: 1 put: xTable. 92966 ret at: 2 put: glyphs. 92967 ret at: 3 put: minAscii. 92968 ret at: 4 put: maxAscii. 92969 ret at: 5 put: maxWidth. 92970 ret at: 6 put: ascent. 92971 ret at: 7 put: descent. 92972 ret at: 8 put: pointSize. 92973 ^ret. 92974" ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}" 92975! ! 92976 92977"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 92978 92979EFontBDFFontReaderForRanges class 92980 instanceVariableNames: ''! 92981 92982!EFontBDFFontReaderForRanges class methodsFor: 'as yet unclassified' stamp: 'yo 1/19/2005 11:24'! 92983rangesForGreek 92984 92985 ^ { 92986 Array with: 16r1 with: 16rFF. 92987 Array with: 16r370 with: 16r3FF. 92988 Array with: 16r1F00 with: 16r1FFF. 92989 Array with: 16r2000 with: 16r206F. 92990 Array with: 16r20A0 with: 16r20AF 92991 }. 92992! ! 92993 92994!EFontBDFFontReaderForRanges class methodsFor: 'as yet unclassified' stamp: 'yo 1/19/2005 11:24'! 92995rangesForLatin2 92996 92997 ^ { 92998 Array with: 0 with: 16r17F. 92999 Array with: 16r2B0 with: 16r2FF. 93000 Array with: 16r2000 with: 16r206F. 93001 Array with: 16r2122 with: 16r2122. 93002 Array with: 16rFFFF with: 16rFFFF. "sentinel" 93003 }. 93004! ! 93005 93006!EFontBDFFontReaderForRanges class methodsFor: 'as yet unclassified' stamp: 'yo 12/11/2007 11:19'! 93007rangesForRussian 93008 93009 ^ { 93010 Array with: 16r1 with: 16rFF. 93011 Array with: 16r400 with: 16r513. 93012 Array with: 16r2219 with: 16r2219. 93013 Array with: 16r221A with: 16r221A. 93014 Array with: 16r2248 with: 16r2248. 93015 Array with: 16r2264 with: 16r2265. 93016 Array with: 16r2320 with: 16r2321. 93017 Array with: 16r2500 with: 16r25A0. 93018 }. 93019! ! 93020EUCTextConverter subclass: #EUCJPTextConverter 93021 instanceVariableNames: '' 93022 classVariableNames: '' 93023 poolDictionaries: '' 93024 category: 'Multilingual-TextConversion'! 93025!EUCJPTextConverter commentStamp: '<historical>' prior: 0! 93026Text converter for Japanese variation of EUC.! 93027 93028 93029!EUCJPTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'! 93030languageEnvironment 93031 93032 ^ JapaneseEnvironment. 93033! ! 93034 93035!EUCJPTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 10:09'! 93036leadingChar 93037 93038 ^ JISX0208 leadingChar 93039! ! 93040 93041"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 93042 93043EUCJPTextConverter class 93044 instanceVariableNames: ''! 93045 93046!EUCJPTextConverter class methodsFor: 'utilities' stamp: 'yo 12/19/2003 22:00'! 93047encodingNames 93048 93049 ^ #('euc-jp' 'eucjp') copy 93050! ! 93051EUCTextConverter subclass: #EUCKRTextConverter 93052 instanceVariableNames: '' 93053 classVariableNames: '' 93054 poolDictionaries: '' 93055 category: 'Multilingual-TextConversion'! 93056!EUCKRTextConverter commentStamp: '<historical>' prior: 0! 93057Text converter for Korean variation of EUC.! 93058 93059 93060!EUCKRTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'! 93061languageEnvironment 93062 93063 ^ KoreanEnvironment. 93064! ! 93065 93066!EUCKRTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 15:19'! 93067leadingChar 93068 93069 ^ KSX1001 leadingChar 93070! ! 93071 93072"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 93073 93074EUCKRTextConverter class 93075 instanceVariableNames: ''! 93076 93077!EUCKRTextConverter class methodsFor: 'utilities' stamp: 'yo 2/17/2004 18:45'! 93078encodingNames 93079 93080 ^ #('euc-kr' 'ks-c-5601-1987' 'euckr') copy 93081! ! 93082TextConverter subclass: #EUCTextConverter 93083 instanceVariableNames: '' 93084 classVariableNames: '' 93085 poolDictionaries: '' 93086 category: 'Multilingual-TextConversion'! 93087!EUCTextConverter commentStamp: '<historical>' prior: 0! 93088Text converter for Extended Unix Character. This is an abstract class. The CJK variations are implemented as subclasses.! 93089 93090 93091!EUCTextConverter methodsFor: 'conversion' stamp: 'marcus.denker 9/14/2008 21:15'! 93092nextFromStream: aStream 93093 93094 | character1 character2 offset value1 value2 nonUnicodeChar | 93095 aStream isBinary ifTrue: [^ aStream basicNext]. 93096 character1 := aStream basicNext. 93097 character1 isNil ifTrue: [^ nil]. 93098 character1 asciiValue <= 127 ifTrue: [^ character1]. 93099 character2 := aStream basicNext. 93100 character2 isNil ifTrue: [^ nil]. 93101 offset := 16rA1. 93102 value1 := character1 asciiValue - offset. 93103 value2 := character2 asciiValue - offset. 93104 (value1 < 0 or: [value1 > 93]) ifTrue: [^ nil]. 93105 (value2 < 0 or: [value2 > 93]) ifTrue: [^ nil]. 93106 93107 nonUnicodeChar := Character leadingChar: self leadingChar code: value1 * 94 + value2. 93108 ^ Character leadingChar: self languageEnvironment leadingChar code: nonUnicodeChar asUnicode. 93109! ! 93110 93111!EUCTextConverter methodsFor: 'conversion' stamp: 'ar 4/12/2005 14:10'! 93112nextPut: aCharacter toStream: aStream 93113 | value leadingChar nonUnicodeChar value1 value2 | 93114 aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream]. 93115 value := aCharacter charCode. 93116 leadingChar := aCharacter leadingChar. 93117 (leadingChar = 0 and: [value < 128]) ifTrue: [ 93118 aStream basicNextPut: (Character value: value). 93119 ^ aStream 93120 ]. 93121 93122 (128 <= value and: [value < 256]) ifTrue: [^ aStream]. 93123 aCharacter isTraditionalDomestic ifFalse: [ 93124 nonUnicodeChar := self nonUnicodeClass charFromUnicode: value. 93125 ] ifTrue: [ 93126 nonUnicodeChar :=(Character value: value) 93127 ]. 93128 nonUnicodeChar ifNotNil: [ 93129 value := nonUnicodeChar charCode. 93130 value1 := value // 94 + 161. 93131 value2 := value \\ 94 + 161. 93132 aStream basicNextPut: (Character value: value1). 93133 aStream basicNextPut: (Character value: value2). 93134 ^ aStream 93135 ] 93136! ! 93137 93138 93139!EUCTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:40'! 93140languageEnvironment 93141 93142 self subclassResponsibility 93143! ! 93144 93145!EUCTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 10:09'! 93146leadingChar 93147 93148 ^ self subclassResponsibility 93149! ! 93150 93151!EUCTextConverter methodsFor: 'private' stamp: 'yo 10/4/2003 15:48'! 93152nonUnicodeClass 93153 93154 ^ (EncodedCharSet charsetAt: self leadingChar). 93155! ! 93156AbstractResizerMorph subclass: #EdgeGripMorph 93157 instanceVariableNames: 'target edgeName' 93158 classVariableNames: '' 93159 poolDictionaries: '' 93160 category: 'Polymorph-Widgets'! 93161!EdgeGripMorph commentStamp: 'gvc 9/23/2008 11:58' prior: 0! 93162Similar to a ProportionalSplitterMorph but designed to attach to an edge of a single morph only.! 93163 93164 93165!EdgeGripMorph methodsFor: 'accessing' stamp: 'gvc 10/1/2007 13:03'! 93166edgeName 93167 "Answer the value of edgeName" 93168 93169 ^ edgeName! ! 93170 93171!EdgeGripMorph methodsFor: 'accessing' stamp: 'gvc 10/1/2007 13:23'! 93172edgeName: anObject 93173 "Set the value of edgeName" 93174 93175 edgeName := anObject. 93176 self 93177 layoutFrame: self gripLayoutFrame; 93178 layoutChanged! ! 93179 93180!EdgeGripMorph methodsFor: 'accessing' stamp: 'gvc 2/12/2007 16:43'! 93181target 93182 "Answer the value of target" 93183 93184 ^ target! ! 93185 93186!EdgeGripMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2009 13:58'! 93187target: aMorph 93188 "Set the value of target" 93189 93190 target := aMorph! ! 93191 93192 93193!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:26'! 93194adoptPaneColor: paneColor 93195 "Change our color too." 93196 93197 super adoptPaneColor: paneColor. 93198 self fillStyle: self normalFillStyle! ! 93199 93200!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 13:53'! 93201bottomLayoutFrame 93202 "Answer the layout frame for a bottom edge." 93203 93204 ^LayoutFrame 93205 fractions: (0 @ 1 corner: 1 @ 1) 93206 offsets: (22 @ SystemWindow borderWidth negated corner: -22 @ 0)! ! 93207 93208!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/12/2007 16:56'! 93209defaultHeight 93210 "Answer the default height for the receiver." 93211 93212 ^22! ! 93213 93214!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/12/2007 16:56'! 93215defaultWidth 93216 "Answer the default width for the receiver." 93217 93218 ^22! ! 93219 93220!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/19/2007 21:25'! 93221extent: aPoint 93222 "If our minor extent changes then adopt the pane colour to 93223 reflect any size based gradient in the theme. 93224 Assumes fillStyle will not change on the major extent for 93225 performance reasons." 93226 93227 |ext| 93228 ext := self extent. 93229 super extent: aPoint. 93230 self isHorizontal 93231 ifTrue: [self extent y ~= ext y ifTrue: [ 93232 self adoptPaneColor: self paneColor]] 93233 ifFalse: [self extent x ~= ext x ifTrue: [ 93234 self adoptPaneColor: self paneColor]] 93235 ! ! 93236 93237!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:03'! 93238gripLayoutFrame 93239 "Answer the layout frame dependinbg on our edge." 93240 93241 self edgeName == #top ifTrue: [^self topLayoutFrame]. 93242 self edgeName == #bottom ifTrue: [^self bottomLayoutFrame]. 93243 self edgeName == #left ifTrue: [^self leftLayoutFrame]. 93244 ^self rightLayoutFrame! ! 93245 93246!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 13:53'! 93247initialize 93248 "Initialize the receiver." 93249 93250 super initialize. 93251 self 93252 edgeName: #right; 93253 extent: self defaultWidth+2 @ (self defaultHeight+2); 93254 hResizing: #spaceFill; 93255 vResizing: #spaceFill! ! 93256 93257!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:20'! 93258isHorizontal 93259 "Answer true if the receiver has a horizontal layout." 93260 93261 ^self edgeName == #top 93262 or: [self edgeName == #bottom]! ! 93263 93264!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:07'! 93265leftLayoutFrame 93266 "Answer the layout frame for a left edge." 93267 93268 ^LayoutFrame 93269 fractions: (0 @ 0 corner: 0 @ 1) 93270 offsets: (0 @ -7 corner: SystemWindow borderWidth @ (SystemWindow borderWidth - 26))! ! 93271 93272!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:27'! 93273mouseDown: anEvent 93274 "Remember the receiver and target offsets too." 93275 93276 |cp| 93277 (self bounds containsPoint: anEvent cursorPoint) 93278 ifTrue: [self fillStyle: self pressedFillStyle]. 93279 cp := anEvent cursorPoint. 93280 lastMouse := {cp. cp - self position. cp - self targetPoint}! ! 93281 93282!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 13:05'! 93283mouseMove: anEvent 93284 "Track the mouse for resizing." 93285 93286 target ifNil: [^self]. 93287 Preferences fastDragWindowForMorphic 93288 ifTrue: [target doFastWindowReframe: self edgeName] 93289 ifFalse: [ 93290 lastMouse at: 1 put: anEvent cursorPoint. 93291 self targetPoint: lastMouse first - lastMouse last. 93292 self positionPoint: (lastMouse first - lastMouse second)].! ! 93293 93294!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:33'! 93295mouseUp: anEvent 93296 "Change the cursor back to normal if necessary and change the color back to normal." 93297 93298 (self bounds containsPoint: anEvent cursorPoint) 93299 ifFalse: [anEvent hand showTemporaryCursor: nil]. 93300 self adoptPaneColor: self paneColor! ! 93301 93302!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:23'! 93303normalFillStyle 93304 "Return the normal fillStyle of the receiver." 93305 93306 ^self theme splitterNormalFillStyleFor: self! ! 93307 93308!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 13:05'! 93309positionPoint: aPoint 93310 "Reposition based on ptName." 93311 93312 (#(top bottom) includes: self edgeName) 93313 ifTrue: [^self position: self left @ aPoint y]. 93314 (#(left right) includes: self edgeName) 93315 ifTrue: [^self position: aPoint x @ self top]. 93316 ^self position: aPoint! ! 93317 93318!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:23'! 93319pressedFillStyle 93320 "Return the pressed fillStyle of the receiver." 93321 93322 ^self theme splitterPressedFillStyleFor: self! ! 93323 93324!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 13:05'! 93325resizeCursor 93326 93327 ^ Cursor resizeForEdge: self edgeName! ! 93328 93329!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:09'! 93330rightLayoutFrame 93331 "Answer the layout frame for a right edge." 93332 93333 ^LayoutFrame 93334 fractions: (1 @ 0 corner: 1 @ 1) 93335 offsets: (SystemWindow borderWidth negated @ -7 corner: 0 @ (SystemWindow borderWidth - 26))! ! 93336 93337!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/3/2007 15:11'! 93338splitsTopAndBottom 93339 "Answer true if the receiver has a horizontal layout." 93340 93341 ^self isHorizontal! ! 93342 93343!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 13:05'! 93344targetPoint 93345 "Answer the reference point of the target." 93346 93347 ^self target bounds pointAtSideOrCorner: self edgeName! ! 93348 93349!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/17/2008 12:34'! 93350targetPoint: aPoint 93351 "Set the reference point of the target." 93352 93353 |minExt rect| 93354 rect := self target bounds withSideOrCorner: self edgeName setToPoint: aPoint. 93355 minExt := self target minimumExtent. 93356 rect width <= minExt x ifTrue: [ 93357 rect := self edgeName = #left 93358 ifTrue: [rect withSideOrCorner: #left setToPoint: self target bounds bottomRight - minExt] 93359 ifFalse: [rect withSideOrCorner: #right setToPoint: self target bounds topLeft + minExt]]. 93360 rect height <= minExt y ifTrue: [ 93361 rect := self edgeName = #top 93362 ifTrue: [rect withSideOrCorner: #top setToPoint: self target bounds bottomRight - minExt] 93363 ifFalse: [rect withSideOrCorner: #bottom setToPoint: self target bounds topLeft + minExt]]. 93364 self target bounds: rect! ! 93365 93366!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2007 14:26'! 93367themeChanged 93368 "Update the fill style." 93369 93370 self fillStyle: self normalFillStyle. 93371 super themeChanged! ! 93372 93373!EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:47'! 93374topLayoutFrame 93375 "Answer the layout frame for a top edge." 93376 93377 ^LayoutFrame 93378 fractions: (0 @ 0 corner: 1 @ 0) 93379 offsets: (22 @ -29 corner: -22 @ (SystemWindow borderWidth - 29))! ! 93380Object subclass: #EditCommand 93381 instanceVariableNames: 'textMorph phase replacedText replacedTextInterval newText newTextInterval' 93382 classVariableNames: '' 93383 poolDictionaries: '' 93384 category: 'Morphic-Text Support'! 93385!EditCommand commentStamp: '<historical>' prior: 0! 93386This class handles all paragraph surgery in VI. In general, subclasses of EditCommand should be able to rely on the super class' undo/redo machinery -- only the repeat command needs to be overridden in most cases. This assumes, of course, that the newText, replacedText, newTextInterval, and replacedTextInterval have been set correctly. 93387 93388When setting the interval, use normal mode style selections, not insert mode selections (see class comment of VIMorphEditor). 93389 93390Possible useful expressions for doIt or printIt. 93391 93392Structure: 93393 instVar1 type -- comment about the purpose of instVar1 93394 instVar2 type -- comment about the purpose of instVar2 93395 93396Any further useful comments about the general approach of this implementation.! 93397 93398 93399!EditCommand methodsFor: 'accessors' stamp: 'sps 1/11/2002 17:12'! 93400iEditCommand 93401 ^true! ! 93402 93403!EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:36'! 93404newText 93405 ^newText! ! 93406 93407!EditCommand methodsFor: 'accessors' stamp: 'sps 1/4/2002 22:37'! 93408newTextInterval 93409 ^newTextInterval! ! 93410 93411!EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:36'! 93412newTextInterval: anInterval 93413 ^newText := anInterval! ! 93414 93415!EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:36'! 93416newText: aText 93417 ^newText := aText! ! 93418 93419!EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 17:01'! 93420pEditor 93421 ^textMorph editor 93422! ! 93423 93424!EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 13:40'! 93425phase 93426 ^phase 93427! ! 93428 93429!EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 13:40'! 93430phase: aSymbol 93431 ^phase := aSymbol 93432! ! 93433 93434!EditCommand methodsFor: 'accessors' stamp: 'sps 1/11/2002 20:58'! 93435printOn: aStream 93436 93437 | | 93438 aStream 93439 nextPutAll: self class name; 93440 nextPut: $[; 93441 nextPutAll: ('new: ', newTextInterval asString,' -> "', newText, '", rText: ', replacedTextInterval asString,' -> "', replacedText, '"'); 93442 nextPut: $].! ! 93443 93444!EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:37'! 93445replacedText 93446 ^replacedText! ! 93447 93448!EditCommand methodsFor: 'accessors' stamp: 'sps 1/4/2002 22:30'! 93449replacedTextInterval 93450 ^replacedTextInterval! ! 93451 93452!EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:36'! 93453replacedTextInterval: anInterval 93454 ^replacedTextInterval := anInterval! ! 93455 93456!EditCommand methodsFor: 'accessors' stamp: 'sps 1/5/2002 16:37'! 93457replacedText: aText 93458 ^replacedText := aText! ! 93459 93460!EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 17:04'! 93461textMorphEditor 93462 ^textMorph editor 93463! ! 93464 93465!EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 17:05'! 93466textMorphString 93467 ^textMorph text string 93468! ! 93469 93470!EditCommand methodsFor: 'accessors' stamp: 'sps 7/24/2003 17:02'! 93471textMorphStringSize 93472 ^textMorph text string size 93473! ! 93474 93475 93476!EditCommand methodsFor: 'command execution' stamp: 'sps 1/7/2002 21:37'! 93477doCommand 93478 93479 ^self redoCommand 93480 93481 ! ! 93482 93483!EditCommand methodsFor: 'command execution' stamp: 'sps 7/24/2003 17:04'! 93484redoCommand 93485 93486 | | 93487 93488"Debug dShow: ('rInterval: ', replacedTextInterval asString, '. rText: ', replacedText string, ' nInterval: ', newTextInterval asString, ' nText: ', newText string)." 93489 self textMorphEditor 93490 noUndoReplace: replacedTextInterval 93491 with: newText. 93492 93493"Debug dShow: ('lastSelInt: ', lastSelectionInterval asString)." 93494! ! 93495 93496!EditCommand methodsFor: 'command execution' stamp: 'sps 7/24/2003 17:04'! 93497undoCommand 93498 93499"Debug dShow: ('new Interval: ', newTextInterval asString, '. rText: ', replacedText string)." 93500 93501 self textMorphEditor 93502 noUndoReplace: newTextInterval 93503 with: replacedText. 93504 93505 93506! ! 93507 93508 93509!EditCommand methodsFor: 'initialization' stamp: 'sps 7/24/2003 17:01'! 93510textMorph: tm 93511replacedText: rText 93512replacedTextInterval: rInterval 93513newText: nText 93514newTextInterval: nInterval 93515 93516 93517 textMorph := tm. 93518 replacedText := rText. 93519 replacedTextInterval := rInterval. 93520 newText := nText. 93521 newTextInterval := nInterval. 93522 93523! ! 93524 93525 93526!EditCommand methodsFor: 'selection' stamp: 'sps 1/7/2002 19:54'! 93527doSelectionInterval 93528 ^self redoSelectionInterval! ! 93529 93530!EditCommand methodsFor: 'selection' stamp: 'sps 7/24/2003 17:34'! 93531redoSelectionInterval 93532"Return an interval to be displayed as a subtle selection after undo, or nil" 93533 93534 ^newTextInterval 93535! ! 93536 93537!EditCommand methodsFor: 'selection' stamp: 'sps 7/24/2003 17:36'! 93538undoSelection 93539"Return an interval to be displayed as a selection after undo, or nil" 93540 93541 ^replacedTextInterval first to: (replacedTextInterval first + replacedText size - 1) 93542! ! 93543 93544!EditCommand methodsFor: 'selection' stamp: 'sps 7/24/2003 17:03'! 93545undoSelectionInterval 93546"Return an interval to be displayed as a selection after undo, or nil" 93547 93548 | i | 93549 i := (replacedTextInterval first min: self textMorphStringSize). 93550 ^i to: i - 1 93551! ! 93552 93553"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 93554 93555EditCommand class 93556 instanceVariableNames: ''! 93557 93558!EditCommand class methodsFor: 'instance creation' stamp: 'sps 7/24/2003 17:08'! 93559textMorph: tm 93560replacedText: replacedText 93561replacedTextInterval: replacedTextInterval 93562newText: newText 93563newTextInterval: newTextInterval 93564 93565 93566 ^(self new) 93567 textMorph: tm 93568 replacedText: replacedText 93569 replacedTextInterval: replacedTextInterval 93570 newText: newText 93571 newTextInterval: newTextInterval; 93572 yourself 93573 93574! ! 93575ObjectWithDocumentation subclass: #ElementCategory 93576 instanceVariableNames: 'categoryName keysInOrder elementDictionary' 93577 classVariableNames: '' 93578 poolDictionaries: '' 93579 category: 'Tools-Changes'! 93580!ElementCategory commentStamp: '<historical>' prior: 0! 93581ElementCategory 93582 93583Contains a list of elements that affords keyed access but also has an inherent order. 93584 93585Add items to the category by sending it elementAt:put:. 93586Obtain the elements in order by sending #elementsInOrder 93587Obtain the value of an element at a given key by sending #elementAt:! 93588 93589 93590!ElementCategory methodsFor: 'category name' stamp: 'sw 1/26/2001 22:45'! 93591categoryName 93592 "Answer the formal name of the category" 93593 93594 ^ categoryName! ! 93595 93596!ElementCategory methodsFor: 'category name' stamp: 'stephaneducasse 2/4/2006 20:39'! 93597categoryName: aName 93598 "Set the category name" 93599 93600 categoryName := aName! ! 93601 93602 93603!ElementCategory methodsFor: 'copying' stamp: 'sw 12/1/2000 22:45'! 93604copy 93605 "Answer a copy of the receiver" 93606 93607 ^ super copy copyFrom: self! ! 93608 93609!ElementCategory methodsFor: 'copying' stamp: 'stephaneducasse 2/4/2006 20:39'! 93610copyFrom: donor 93611 "Copy the receiver's contents from the donor" 93612 93613 keysInOrder := donor keysInOrder. 93614 elementDictionary := donor copyOfElementDictionary! ! 93615 93616!ElementCategory methodsFor: 'copying' stamp: 'sw 12/1/2000 22:46'! 93617copyOfElementDictionary 93618 "Answer a copy of the element dictionary" 93619 93620 ^ elementDictionary copy! ! 93621 93622 93623!ElementCategory methodsFor: 'elements' stamp: 'sw 12/1/2000 22:46'! 93624elementAt: aKey 93625 "Answer the element at the given key" 93626 93627 ^ elementDictionary at: aKey ifAbsent: [nil]! ! 93628 93629!ElementCategory methodsFor: 'elements' stamp: 'sw 1/26/2001 22:54'! 93630elementAt: sym put: element 93631 "Add symbol at the end of my sorted list (unless it is already present), and put the element in the dictionary" 93632 93633 (keysInOrder includes: sym) ifFalse: [keysInOrder add: sym]. 93634 ^ elementDictionary at: sym put: element! ! 93635 93636!ElementCategory methodsFor: 'elements' stamp: 'sw 9/12/2001 22:59'! 93637elementSymbol 93638 "Answer the element symbol for the receiver. Here, the categoryName dominates" 93639 93640 ^ categoryName! ! 93641 93642!ElementCategory methodsFor: 'elements' stamp: 'sw 12/1/2000 22:47'! 93643elementsInOrder 93644 "Answer the elements in order" 93645 93646 ^ keysInOrder collect: [:aKey | elementDictionary at: aKey]! ! 93647 93648!ElementCategory methodsFor: 'elements' stamp: 'sw 4/3/2001 11:06'! 93649fasterElementAt: sym put: element 93650 "Add symbol at the end of my sorted list and put the element in the dictionary. This variant adds the key at the end of the keys list without checking whether it already exists." 93651 93652 keysInOrder add: sym. 93653 ^ elementDictionary at: sym put: element! ! 93654 93655!ElementCategory methodsFor: 'elements' stamp: 'sw 4/11/2001 20:08'! 93656removeElementAt: aKey 93657 "Remove the element at the given key" 93658 93659 elementDictionary removeKey: aKey ifAbsent: [^ self]. 93660 keysInOrder remove: aKey ifAbsent: []! ! 93661 93662 93663!ElementCategory methodsFor: 'initialization' stamp: 'sw 3/30/2001 00:12'! 93664addCategoryItem: anItem 93665 "Add the item at the end, obtaining its key from itself (it must respond to #categoryName)" 93666 93667 self elementAt: anItem categoryName put: anItem! ! 93668 93669!ElementCategory methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:39'! 93670clear 93671 "Clear the receiber's keysInOrder and elementDictionary" 93672 93673 keysInOrder := OrderedCollection new. 93674 elementDictionary := IdentityDictionary new! ! 93675 93676!ElementCategory methodsFor: 'initialization' stamp: 'sw 3/28/2001 19:47'! 93677initialize 93678 "Initialize the receiver (automatically called when instances are created via 'new')" 93679 93680 super initialize. 93681 self clear! ! 93682 93683 93684!ElementCategory methodsFor: 'keys' stamp: 'sw 12/11/2000 15:36'! 93685includesKey: aKey 93686 "Answer whether the receiver's dictionary holds the given key" 93687 93688 ^ elementDictionary includesKey: aKey! ! 93689 93690!ElementCategory methodsFor: 'keys' stamp: 'sw 12/1/2000 22:47'! 93691keysInOrder 93692 "Answer the keys in their sorted order" 93693 93694 ^ keysInOrder copy! ! 93695 93696 93697!ElementCategory methodsFor: 'printing' stamp: 'sw 1/26/2001 22:47'! 93698printOn: aStream 93699 "Append to the argument, aStream, a sequence of characters that identifies the receiver." 93700 93701 super printOn: aStream. 93702 categoryName ifNotNil: [aStream nextPutAll: ' named ', categoryName asString]! ! 93703 93704 93705!ElementCategory methodsFor: 'translation' stamp: 'dgd 12/4/2003 20:22'! 93706translated 93707 "answer the receiver translated to the current language" 93708 93709 ^ self class new categoryName: categoryName asString translated asSymbol! ! 93710 93711 93712!ElementCategory methodsFor: 'private' stamp: 'sw 8/6/2004 10:34'! 93713initWordingAndDocumentation 93714 "Initialize wording and documentation (helpMessage) for getters and setters" 93715 93716 self wording: self categoryName! ! 93717Object subclass: #EllipseMidpointTracer 93718 instanceVariableNames: 'rect x y a b aSquared bSquared d1 d2 inFirstRegion' 93719 classVariableNames: '' 93720 poolDictionaries: '' 93721 category: 'Morphic-Support'! 93722 93723!EllipseMidpointTracer methodsFor: 'computing' stamp: 'ar 6/28/1999 15:35'! 93724stepInY 93725 "Step to the next y value" 93726 inFirstRegion ifTrue:[ 93727 "In the upper region we must step until we reach the next y value" 93728 [(aSquared * (y-0.5)) > (bSquared * (x+1))] whileTrue:[ 93729 d1 < 0.0 93730 ifTrue:[d1 := d1 + (bSquared * (2*x+3)). 93731 x := x + 1] 93732 ifFalse:[d1 := d1 + (bSquared * (2*x+3)) + (aSquared * (-2*y+2)). 93733 y := y - 1. 93734 ^x := x + 1]]. 93735 "Stepping into second region" 93736 d2 := (bSquared * (x + 0.5) squared) + (aSquared * (y-1) squared) - (aSquared * bSquared). 93737 inFirstRegion := false. 93738 ]. 93739 "In the lower region each step is a y-step" 93740 d2 < 0.0 93741 ifTrue:[d2 := d2 + (bSquared * (2*x+2)) + (aSquared * (-2*y+3)). 93742 x := x + 1] 93743 ifFalse:[d2 := d2 + (aSquared * (-2*y+3))]. 93744 y := y - 1. 93745 ^x! ! 93746 93747 93748!EllipseMidpointTracer methodsFor: 'initialize' stamp: 'ar 6/28/1999 15:33'! 93749on: aRectangle 93750 rect := aRectangle. 93751 a := rect width // 2. 93752 b := rect height // 2. 93753 x := 0. 93754 y := b. 93755 aSquared := a * a. 93756 bSquared := b * b. 93757 d1 := bSquared - (aSquared * b) + (0.25 * aSquared). 93758 d2 := nil. 93759 inFirstRegion := true.! ! 93760BorderedMorph subclass: #EllipseMorph 93761 instanceVariableNames: '' 93762 classVariableNames: '' 93763 poolDictionaries: '' 93764 category: 'Morphic-Basic'! 93765!EllipseMorph commentStamp: 'kfr 10/27/2003 10:32' prior: 0! 93766A round BorderedMorph. Supports borderWidth and borderColor. 93767Only simple borderStyle is implemented. 93768 93769EllipseMorph new borderWidth:10; borderColor: Color green; openInWorld. 93770EllipseMorph new borderStyle:(SimpleBorder width: 5 color: Color blue); openInWorld.! 93771 93772 93773!EllipseMorph methodsFor: 'accessing' stamp: 'sw 11/24/1999 14:59'! 93774couldHaveRoundedCorners 93775 ^ false! ! 93776 93777!EllipseMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:29'! 93778doesBevels 93779 ^ false! ! 93780 93781 93782!EllipseMorph methodsFor: 'drawing' stamp: 'di 6/24/1998 14:27'! 93783areasRemainingToFill: aRectangle 93784 "Could be improved by quick check of inner rectangle" 93785 93786 ^ Array with: aRectangle! ! 93787 93788!EllipseMorph methodsFor: 'drawing' stamp: 'di 5/25/2001 01:37'! 93789drawOn: aCanvas 93790 93791 aCanvas isShadowDrawing 93792 ifTrue: [^ aCanvas fillOval: bounds fillStyle: self fillStyle borderWidth: 0 borderColor: nil]. 93793 aCanvas fillOval: bounds fillStyle: self fillStyle borderWidth: borderWidth borderColor: borderColor. 93794! ! 93795 93796 93797!EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:25'! 93798bottomLeftCorner 93799 ^self intersectionWithLineSegmentFromCenterTo: bounds bottomLeft 93800! ! 93801 93802!EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:23'! 93803bottomRightCorner 93804 ^self intersectionWithLineSegmentFromCenterTo: bounds bottomRight 93805! ! 93806 93807!EllipseMorph methodsFor: 'geometry' stamp: 'nk 2/15/2001 16:08'! 93808closestPointTo: aPoint 93809 ^self intersectionWithLineSegmentFromCenterTo: aPoint! ! 93810 93811!EllipseMorph methodsFor: 'geometry' stamp: 'nk 2/13/2001 18:16'! 93812intersectionWithLineSegmentFromCenterTo: aPoint 93813 | dx aSquared bSquared m mSquared xSquared x y dy | 93814 (self containsPoint: aPoint) 93815 ifTrue: [ ^aPoint ]. 93816 dx := aPoint x - self center x. 93817 dy := aPoint y - self center y. 93818 dx = 0 93819 ifTrue: [ ^self bounds pointNearestTo: aPoint ]. 93820 m := dy / dx. 93821 mSquared := m squared. 93822 aSquared := (self bounds width / 2) squared. 93823 bSquared := (self bounds height / 2) squared. 93824 xSquared := 1 / ((1 / aSquared) + (mSquared / bSquared)). 93825 x := xSquared sqrt. 93826 dx < 0 ifTrue: [ x := x negated ]. 93827 y := m * x. 93828 ^ self center + (x @ y) asIntegerPoint. 93829! ! 93830 93831!EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:23'! 93832topLeftCorner 93833 ^self intersectionWithLineSegmentFromCenterTo: bounds topLeft 93834! ! 93835 93836!EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:26'! 93837topRightCorner 93838 ^self intersectionWithLineSegmentFromCenterTo: bounds topRight 93839! ! 93840 93841 93842!EllipseMorph methodsFor: 'geometry testing' stamp: 'di 11/14/97 13:50'! 93843containsPoint: aPoint 93844 93845 | radius other delta xOverY | 93846 (bounds containsPoint: aPoint) ifFalse: [^ false]. "quick elimination" 93847 (bounds width = 1 or: [bounds height = 1]) 93848 ifTrue: [^ true]. "Degenerate case -- code below fails by a bit" 93849 93850 radius := bounds height asFloat / 2. 93851 other := bounds width asFloat / 2. 93852 delta := aPoint - bounds topLeft - (other@radius). 93853 xOverY := bounds width asFloat / bounds height asFloat. 93854 ^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared! ! 93855 93856 93857!EllipseMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'! 93858defaultBorderWidth 93859 "answer the default border width for the receiver" 93860 ^ 1! ! 93861 93862!EllipseMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:26'! 93863defaultColor 93864 "answer the default color/fill style for the receiver" 93865 ^ Color yellow! ! 93866 93867 93868!EllipseMorph methodsFor: 'rounding' stamp: 'ka 12/4/2005 00:52'! 93869cornerStyle: aSymbol 93870 "Set the receiver's corner style. But, in this case, do *not*" 93871 93872 self removeProperty: #cornerStyle. 93873 self changed! ! 93874 93875 93876!EllipseMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:08'! 93877canDrawBorder: aBorderStyle 93878 ^aBorderStyle style == #simple! ! 93879 93880 93881!EllipseMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:14'! 93882canHaveFillStyles 93883 "Return true if the receiver can have general fill styles; not just colors. 93884 This method is for gradually converting old morphs." 93885 ^true! ! 93886MenuMorph subclass: #EmbeddedMenuMorph 93887 instanceVariableNames: '' 93888 classVariableNames: '' 93889 poolDictionaries: '' 93890 category: 'Polymorph-Widgets'! 93891!EmbeddedMenuMorph commentStamp: 'gvc 5/18/2007 13:18' prior: 0! 93892Menu designed to be embedded in another morph rather than popped up directly.! 93893 93894 93895!EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/17/2008 17:04'! 93896allEnabledSiblingItems 93897 "Answer the receiver's submorphs followed by the (wrapping) owner's 93898 submorph items. Answer only enabled items." 93899 93900 ^self allSiblingItems select: [:item | item isEnabled]! ! 93901 93902!EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/20/2008 21:18'! 93903allSiblingItems 93904 "Answer the receiver's submorphs followed by the (wrapping) owner's 93905 submorph items. Nasty." 93906 93907 |menus str index| 93908 str := (Array new: 40) writeStream. 93909 menus := self owner submorphs select: [:m | m isKindOf: self class]. 93910 menus := (menus copyFrom: (index := menus indexOf: self) to: menus size), (menus copyFrom: 1 to: index - 1). 93911 menus do: [:menu | 93912 str nextPutAll: menu items]. 93913 ^str contents! ! 93914 93915!EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 14:17'! 93916drawOn: aCanvas 93917 "Draw the receiver on the canvas." 93918 93919 self perform: #drawOn: withArguments: {aCanvas} inSuperclass: Morph. 93920 self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOn: aCanvas]! ! 93921 93922!EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 14:22'! 93923handlesKeyboard: evt 93924 "Answer whether the receiver handles the keystroke represented by the event" 93925 93926 ^true! ! 93927 93928!EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2007 14:37'! 93929keyStroke: evt 93930 "Handle tabbing and arrows and cr/space." 93931 93932 |char selectable| 93933 (self navigationKey: evt) ifTrue: [^self]. 93934 char := evt keyCharacter. 93935 char = Character space 93936 ifTrue: 93937 [selectedItem ifNotNil: 93938 [selectedItem hasSubMenu 93939 ifTrue: 93940 [evt hand newMouseFocus: selectedItem subMenu. 93941 ^selectedItem subMenu takeKeyboardFocus] 93942 ifFalse: 93943 [^selectedItem invokeWithEvent: evt]]. 93944 (selectable := self items) size = 1 93945 ifTrue: [^selectable first invokeWithEvent: evt]. 93946 ^self]. 93947 (char = Character arrowLeft or: [char = Character arrowRight]) ifTrue: [ 93948 (selectedItem notNil and: [selectedItem hasSubMenu]) ifTrue: [ 93949 evt hand newMouseFocus: selectedItem subMenu. 93950 selectedItem subMenu moveSelectionDown: 1 event: evt. 93951 ^evt hand newKeyboardFocus: selectedItem subMenu]]. 93952 char = Character arrowUp ifTrue: [^self moveSelectionDown: -1 event: evt]. "up arrow key" 93953 char = Character arrowDown ifTrue: [^self moveSelectionDown: 1 event: evt]. "down arrow key" 93954 char = Character pageUp ifTrue: [^self moveSelectionDown: -5 event: evt]. "page up key" 93955 char = Character pageDown ifTrue: [^self moveSelectionDown: 5 event: evt]. "page down key" 93956! ! 93957 93958!EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/6/2008 10:31'! 93959keyboardFocusChange: aBoolean 93960 "Nasty hack for scrolling upon keyboard focus." 93961 93962 super keyboardFocusChange: aBoolean. 93963 aBoolean 93964 ifTrue: [(self ownerThatIsA: GeneralScrollPane) ifNotNilDo: [:sp | 93965 sp scrollToShow: self bounds]] 93966 ifFalse: [self selectItem: nil event: nil]! ! 93967 93968!EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/17/2008 17:17'! 93969moveSelectionDown: anInteger event: anEvent 93970 "Move the selection down or up (negative number) by (at least) 93971 the specified amount. If the item is not enabled, scan one at a time 93972 in that direction. If we move off the top/bottom then switch focus to any 93973 sibling menu and start scanning at the relevant end." 93974 93975 |index allEnabledSiblingItems m| 93976 allEnabledSiblingItems := self allEnabledSiblingItems. 93977 index := (allEnabledSiblingItems indexOf: selectedItem ifAbsent: [0 + (anInteger negative ifTrue: [1] ifFalse: [0])]) + anInteger. 93978 allEnabledSiblingItems do: "Ensure finite" 93979 [:unused | m := allEnabledSiblingItems atWrap: index. 93980 ((m isKindOf: MenuItemMorph) and: [m isEnabled]) ifTrue: 93981 [m owner = self owner ifFalse: [ 93982 anEvent hand newKeyboardFocus: m owner]. 93983 ^m owner selectItem: m event: anEvent]. 93984 "Keep looking for an enabled item" 93985 index := index + anInteger sign]. 93986 ^self selectItem: nil event: anEvent! ! 93987 93988!EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/6/2008 14:56'! 93989selectItem: aMenuItem event: anEvent 93990 "Deselect any sibling menus." 93991 93992 |menus| 93993 menus := self owner submorphs select: [:m | (m isKindOf: self class) and: [m ~~ self]]. 93994 menus do: [:menu | 93995 menu perform: #selectItem:event: withArguments: {nil. anEvent} inSuperclass: self class superclass]. 93996 ^super selectItem: aMenuItem event: anEvent! ! 93997 93998!EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/12/2008 13:28'! 93999selectLastPrefix: aString 94000 "Answer the last subitem that has text that matches the given prefix. 94001 Answer nil if none. 94002 Disable non-matching items and enable matching items." 94003 94004 |firstMatch match| 94005 self items reverseDo: [:item | 94006 match := aString isEmpty or: [item contents asString asLowercase beginsWith: aString]. 94007 item isEnabled: match. 94008 (match and: [firstMatch isNil]) ifTrue: [firstMatch := item]]. 94009 ^firstMatch! ! 94010 94011!EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/12/2008 13:28'! 94012selectPrefix: aString 94013 "Answer the first subitem that has text that matches the given prefix. 94014 Answer nil if none. 94015 Disable non-matching items and enable matching items." 94016 94017 |firstMatch match| 94018 self items do: [:item | 94019 match := aString isEmpty or: [item contents asString asLowercase beginsWith: aString]. 94020 item isEnabled: match. 94021 (match and: [firstMatch isNil]) ifTrue: [firstMatch := item]]. 94022 ^firstMatch! ! 94023StringMorph subclass: #EmbossedStringMorph 94024 instanceVariableNames: 'style trackPaneColor' 94025 classVariableNames: '' 94026 poolDictionaries: '' 94027 category: 'Polymorph-Widgets'! 94028!EmbossedStringMorph commentStamp: 'gvc 5/18/2007 13:15' prior: 0! 94029A label that underdraws to the top-left and/or bottom-right with a lighter and/or darker colour to the receiver.! 94030 94031 94032!EmbossedStringMorph methodsFor: 'accessing' stamp: 'gvc 4/27/2006 12:09'! 94033style 94034 "Answer the value of style" 94035 94036 ^ style! ! 94037 94038!EmbossedStringMorph methodsFor: 'accessing' stamp: 'gvc 5/10/2006 15:26'! 94039style: anObject 94040 "Set the value of style" 94041 94042 style := anObject. 94043 self changed! ! 94044 94045!EmbossedStringMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 11:52'! 94046trackPaneColor 94047 "Answer the value of trackPaneColor" 94048 94049 ^ trackPaneColor! ! 94050 94051!EmbossedStringMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 11:52'! 94052trackPaneColor: anObject 94053 "Set the value of trackPaneColor" 94054 94055 trackPaneColor := anObject! ! 94056 94057 94058!EmbossedStringMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:53'! 94059adoptPaneColor: paneColor 94060 "Set the color." 94061 94062 (paneColor notNil and: [self trackPaneColor]) 94063 ifTrue: [self color: paneColor]. 94064 super adoptPaneColor: paneColor! ! 94065 94066!EmbossedStringMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 17:03'! 94067drawOn: aCanvas 94068 "Draw the hi/lowlights too." 94069 94070 |box| 94071 self style == #plain 94072 ifTrue: [^super drawOn: aCanvas]. 94073 box := self bounds. 94074 (self style == #inset or: [self style == #insetNoHighlight]) 94075 ifTrue: [self style == #insetNoHighlight 94076 ifFalse: [aCanvas drawString: self contents in: (box translateBy: 1) 94077 font: self fontToUse color: self color veryMuchLighter]. 94078 aCanvas 94079 drawString: self contents in: (box translateBy: -1) 94080 font: self fontToUse color: self color muchDarker; 94081 drawString: self contents in: box 94082 font: self fontToUse color: self color] 94083 ifFalse: [self style == #raisedNoHighlight 94084 ifFalse: [aCanvas drawString: self contents in: (box translateBy: -1) 94085 font: self fontToUse color: self color veryMuchLighter]. 94086 aCanvas 94087 drawString: self contents in: (box translateBy: 1) 94088 font: self fontToUse color: self color muchDarker; 94089 drawString: self contents in: box 94090 font: self fontToUse color: self color]! ! 94091 94092!EmbossedStringMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:55'! 94093initWithContents: aString font: aFont emphasis: emphasisCode 94094 "Grrr, why do they do basicNew?" 94095 94096 super initWithContents: aString font: aFont emphasis: emphasisCode. 94097 self 94098 style: #inset; 94099 trackPaneColor: true.! ! 94100 94101!EmbossedStringMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:52'! 94102initialize 94103 "Initialize the receiver." 94104 94105 super initialize. 94106 self 94107 style: #inset; 94108 trackPaneColor: true! ! 94109 94110!EmbossedStringMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 13:16'! 94111measureContents 94112 "Measure the contents for fitting. Add 2@2 for hi/lowlights." 94113 94114 ^super measureContents + 2! ! 94115 94116!EmbossedStringMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:35'! 94117styleSymbols 94118 "Answer the valid styles." 94119 94120 ^#(plain inset insetNoHighlight raised raisedNoHighlight)! ! 94121Object subclass: #EncodedCharSet 94122 instanceVariableNames: '' 94123 classVariableNames: 'EncodedCharSets' 94124 poolDictionaries: '' 94125 category: 'Multilingual-Encodings'! 94126!EncodedCharSet commentStamp: 'yo 10/19/2004 19:08' prior: 0! 94127An abstract superclasss of the classes that represent encoded character sets. In the old implementation, the charsets had more important role. However, in the current implementation, the subclasses are used only for keeping the backward compatibility. 94128 94129 The other confusion comes from the name of "Latin1" class. It used to mean the Latin-1 (ISO-8859-1) character set, but now it primarily means that the "Western European languages that are covered by the characters in Latin-1 character set. 94130! 94131 94132 94133"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 94134 94135EncodedCharSet class 94136 instanceVariableNames: 'compoundTextSequence'! 94137 94138!EncodedCharSet class methodsFor: 'accessing - displaying' stamp: 'yo 12/18/2002 12:34'! 94139isBreakableAt: index in: text 94140 94141 self subclassResponsibility. 94142! ! 94143 94144!EncodedCharSet class methodsFor: 'accessing - displaying' stamp: 'yo 9/4/2002 22:51'! 94145printingDirection 94146 94147 self subclassResponsibility. 94148! ! 94149 94150 94151!EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:55'! 94152canBeGlobalVarInitial: char 94153 94154 | leadingChar | 94155 leadingChar := char leadingChar. 94156 94157 leadingChar = 0 ifTrue: [^ self isUppercase: char]. 94158 ^ self isLetter: char. 94159! ! 94160 94161!EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 17:18'! 94162canBeNonGlobalVarInitial: char 94163 94164 | leadingChar | 94165 leadingChar := char leadingChar. 94166 94167 leadingChar = 0 ifTrue: [^ self isLowercase: char]. 94168 ^ self isLetter: char. 94169! ! 94170 94171!EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:44'! 94172isDigit: char 94173 "Answer whether the receiver is a digit." 94174 94175 | value | 94176 value := char asciiValue. 94177 ^ value >= 48 and: [value <= 57]. 94178! ! 94179 94180!EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:40'! 94181isLetter: char 94182 "Answer whether the receiver is a letter." 94183 94184 | value | 94185 value := char asciiValue. 94186 ^ (8r141 <= value and: [value <= 8r172]) or: [8r101 <= value and: [value <= 8r132]]. 94187! ! 94188 94189!EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:40'! 94190isLowercase: char 94191 "Answer whether the receiver is a lowercase letter. 94192 (The old implementation answered whether the receiver is not an uppercase letter.)" 94193 94194 | value | 94195 value := char asciiValue. 94196 ^ 8r141 <= value and: [value <= 8r172]. 94197! ! 94198 94199!EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:44'! 94200isUppercase: char 94201 "Answer whether the receiver is an uppercase letter. 94202 (The old implementation answered whether the receiver is not a lowercase letter.)" 94203 94204 | value | 94205 value := char asciiValue. 94206 ^ 8r101 <= value and: [value <= 8r132]. 94207! ! 94208 94209 94210!EncodedCharSet class methodsFor: 'class methods' stamp: 'tak 11/5/2005 18:14'! 94211charFromUnicode: unicode 94212 94213 | table index | 94214 unicode < 128 ifTrue: [^ Character value: unicode]. 94215 94216 table := self ucsTable. 94217 index := table indexOf: unicode. 94218 index = 0 ifTrue: [ 94219 ^ nil. 94220 ]. 94221 94222 ^ Character leadingChar: self leadingChar code: index - 1. 94223 94224! ! 94225 94226!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 9/4/2002 22:57'! 94227charsetAt: encoding 94228 94229 ^ EncodedCharSets at: encoding + 1 ifAbsent: [EncodedCharSets at: 1]. 94230! ! 94231 94232!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 12/1/2003 19:29'! 94233digitValue: char 94234 "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 94235 otherwise. This is used to parse literal numbers of radix 2-36." 94236 94237 | value | 94238 value := char charCode. 94239 value <= $9 asciiValue 94240 ifTrue: [^value - $0 asciiValue]. 94241 value >= $A asciiValue 94242 ifTrue: [value <= $Z asciiValue ifTrue: [^value - $A asciiValue + 10]]. 94243 ^ -1 94244! ! 94245 94246!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 6/12/2008 14:38'! 94247initialize 94248" 94249 self initialize 94250" 94251 self allSubclassesDo: [:each | each initialize]. 94252 94253 EncodedCharSets := Array new: 256. 94254 94255 EncodedCharSets at: 0+1 put: Latin1Environment. 94256 EncodedCharSets at: 1+1 put: JISX0208. 94257 EncodedCharSets at: 2+1 put: GB2312. 94258 EncodedCharSets at: 3+1 put: KSX1001. 94259 EncodedCharSets at: 4+1 put: JISX0208. 94260 EncodedCharSets at: 5+1 put: JapaneseEnvironment. 94261 EncodedCharSets at: 6+1 put: SimplifiedChineseEnvironment. 94262 EncodedCharSets at: 7+1 put: KoreanEnvironment. 94263 EncodedCharSets at: 8+1 put: GB2312. 94264 "EncodedCharSets at: 9+1 put: UnicodeTraditionalChinese." 94265 "EncodedCharSets at: 10+1 put: UnicodeVietnamese." 94266 EncodedCharSets at: 12+1 put: KSX1001. 94267 EncodedCharSets at: 13+1 put: GreekEnvironment. 94268 EncodedCharSets at: 14+1 put: Latin2Environment. 94269 EncodedCharSets at: 15+1 put: RussianEnvironment. 94270 EncodedCharSets at: 15+1 put: NepaleseEnvironment. 94271 EncodedCharSets at: 256 put: Unicode. 94272! ! 94273 94274!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 12/2/2004 16:13'! 94275isCharset 94276 94277 ^ true. 94278! ! 94279 94280!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 9/2/2002 16:32'! 94281leadingChar 94282 94283 self subclassResponsibility. 94284! ! 94285 94286!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 11/4/2002 14:43'! 94287nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state 94288 94289 self subclassResponsibility. 94290! ! 94291 94292!EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'! 94293ucsTable 94294 94295 ^ UCSTable latin1Table. 94296! ! 94297ParseNode subclass: #Encoder 94298 instanceVariableNames: 'scopeTable nTemps supered requestor class selector literalStream selectorSet litIndSet litSet sourceRanges globalSourceRanges addedSelectorAndMethodClassLiterals' 94299 classVariableNames: '' 94300 poolDictionaries: '' 94301 category: 'Compiler-Kernel'! 94302!Encoder commentStamp: '<historical>' prior: 0! 94303I encode names and literals into tree nodes with byte codes for the compiler. Byte codes for literals are not assigned until the tree-sizing pass of the compiler, because only then is it known which literals are actually needed. I also keep track of sourceCode ranges during parsing and code generation so I can provide an inverse map for the debugger.! 94304 94305 94306!Encoder methodsFor: 'accessing' stamp: 'eem 5/29/2008 09:36'! 94307methodNodeClass 94308 ^MethodNode! ! 94309 94310!Encoder methodsFor: 'accessing' stamp: 'ar 9/9/2006 12:06'! 94311selector 94312 ^selector! ! 94313 94314!Encoder methodsFor: 'accessing' stamp: 'ar 9/9/2006 12:06'! 94315selector: aSymbol 94316 selector := aSymbol! ! 94317 94318 94319!Encoder methodsFor: 'encoding'! 94320cantStoreInto: varName 94321 94322 ^StdVariables includesKey: varName! ! 94323 94324!Encoder methodsFor: 'encoding' stamp: 'eem 9/5/2009 20:04'! 94325doItInContextName 94326 ^'ThisContext'! ! 94327 94328!Encoder methodsFor: 'encoding'! 94329encodeLiteral: object 94330 94331 ^self 94332 name: object 94333 key: (class literalScannedAs: object notifying: self) 94334 class: LiteralNode 94335 type: LdLitType 94336 set: litSet! ! 94337 94338!Encoder methodsFor: 'encoding'! 94339encodeSelector: selector 94340 94341 ^self 94342 name: selector 94343 key: selector 94344 class: SelectorNode 94345 type: SendType 94346 set: selectorSet! ! 94347 94348!Encoder methodsFor: 'encoding' stamp: 'di 12/4/1999 20:09'! 94349encodeVariable: name 94350 ^ self encodeVariable: name sourceRange: nil ifUnknown: [ self undeclared: name ]! ! 94351 94352!Encoder methodsFor: 'encoding' stamp: 'ls 1/19/2001 12:59'! 94353encodeVariable: name ifUnknown: action 94354 ^self encodeVariable: name sourceRange: nil ifUnknown: action! ! 94355 94356!Encoder methodsFor: 'encoding' stamp: 'eem 4/30/2009 17:03'! 94357encodeVariable: name sourceRange: range ifUnknown: action 94358 | varNode | 94359 varNode := scopeTable at: name 94360 ifAbsent: 94361 [(self lookupInPools: name 94362 ifFound: [:assoc | varNode := self global: assoc name: name]) 94363 ifTrue: [varNode] 94364 ifFalse: [^action value]]. 94365 range ifNotNil: [ 94366 name first canBeGlobalVarInitial ifTrue: 94367 [globalSourceRanges addLast: { name. range. false }]. ]. 94368 94369 (varNode isTemp and: [varNode scope < 0]) ifTrue: [ 94370 OutOfScopeNotification signal ifFalse: [ ^self notify: 'out of scope']. 94371 ]. 94372 ^ varNode! ! 94373 94374!Encoder methodsFor: 'encoding' stamp: 'eem 5/27/2009 09:25'! 94375environment 94376 "Answer the environment of the current compilation context, 94377 be it in a class or global (e.g. a workspace)" 94378 ^class == nil 94379 ifTrue: [Smalltalk] 94380 ifFalse: [class environment]! ! 94381 94382!Encoder methodsFor: 'encoding'! 94383litIndex: literal 94384 | p | 94385 p := literalStream position. 94386 p = 256 ifTrue: 94387 [self notify: 'More than 256 literals referenced. 94388You must split or otherwise simplify this method. 94389The 257th literal is: ', literal printString. ^nil]. 94390 "Would like to show where it is in the source code, 94391 but that info is hard to get." 94392 literalStream nextPut: literal. 94393 ^ p! ! 94394 94395!Encoder methodsFor: 'encoding' stamp: 'eem 5/16/2008 18:30'! 94396sharableLitIndex: literal 94397 "Special access prevents multiple entries for post-allocated super send special selectors" 94398 1 to: literalStream position do: 94399 [:index| 94400 (litSet literalEquality: literal and: (literalStream originalContents at: index)) ifTrue: 94401 [^index - 1]]. 94402 ^self litIndex: literal! ! 94403 94404!Encoder methodsFor: 'encoding' stamp: 'eem 7/27/2008 17:41'! 94405undeclared: name 94406 | sym | 94407 requestor interactive ifTrue: 94408 [requestor requestor == #error: ifTrue: 94409 [requestor error: 'Undeclared']. 94410 ^self notify: 'Undeclared']. 94411 "Allow knowlegeable clients to squash the undeclared warning if they want (e.g. 94412 Diffing pretty printers that are simply formatting text). As this breaks 94413 compilation it should only be used by clients that want to discard the result 94414 of the compilation. To squash the warning use e.g. 94415 [Compiler format: code in: class notifying: nil decorated: false] 94416 on: UndeclaredVariableWarning 94417 do: [:ex| ex resume: false]" 94418 sym := name asSymbol. 94419 ^(UndeclaredVariableWarning new name: name selector: selector class: class) signal 94420 ifTrue: 94421 [Undeclared at: sym put: nil. 94422 self global: (Undeclared associationAt: sym) name: sym] 94423 ifFalse: 94424 [self global: (Association key: sym) name: sym]! ! 94425 94426 94427!Encoder methodsFor: 'error handling'! 94428notify: string 94429 "Put a separate notifier on top of the requestor's window" 94430 | req | 94431 requestor == nil 94432 ifFalse: 94433 [req := requestor. 94434 self release. 94435 req notify: string]. 94436 ^false! ! 94437 94438!Encoder methodsFor: 'error handling'! 94439notify: string at: location 94440 94441 | req | 94442 requestor == nil 94443 ifFalse: 94444 [req := requestor. 94445 self release. 94446 req notify: string at: location]. 94447 ^false! ! 94448 94449!Encoder methodsFor: 'error handling'! 94450requestor: req 94451 "Often the requestor is a BrowserCodeController" 94452 requestor := req! ! 94453 94454 94455!Encoder methodsFor: 'initialize-release' stamp: 'PeterHugossonMiller 9/2/2009 16:18'! 94456fillDict: dict with: nodeClass mapping: keys to: codeArray 94457 | codeStream | 94458 codeStream := codeArray readStream. 94459 keys do: 94460 [:key | dict 94461 at: key 94462 put: (nodeClass new name: key key: key code: codeStream next)]! ! 94463 94464!Encoder methodsFor: 'initialize-release' stamp: 'eem 6/24/2008 14:24'! 94465init: aClass context: aContext notifying: req 94466 requestor := req. 94467 class := aClass. 94468 nTemps := 0. 94469 supered := false. 94470 self initScopeAndLiteralTables. 94471 class variablesAndOffsetsDo: 94472 [:variable "<String|CFieldDefinition>" :offset "<Integer|nil>" | 94473 offset isNil 94474 ifTrue: [scopeTable at: variable name put: (FieldNode new fieldDefinition: variable)] 94475 ifFalse: [scopeTable 94476 at: variable 94477 put: (offset >= 0 94478 ifTrue: [InstanceVariableNode new 94479 name: variable index: offset] 94480 ifFalse: [MaybeContextInstanceVariableNode new 94481 name: variable index: offset negated])]]. 94482 aContext ~~ nil ifTrue: 94483 [| homeNode | 94484 homeNode := self bindTemp: self doItInContextName. 94485 "0th temp = aContext passed as arg" 94486 aContext tempNames withIndexDo: 94487 [:variable :index| 94488 scopeTable 94489 at: variable 94490 put: (MessageAsTempNode new 94491 receiver: homeNode 94492 selector: #namedTempAt: 94493 arguments: (Array with: (self encodeLiteral: index)) 94494 precedence: 3 94495 from: self)]]. 94496 sourceRanges := Dictionary new: 32. 94497 globalSourceRanges := OrderedCollection new: 32! ! 94498 94499!Encoder methodsFor: 'initialize-release' stamp: 'PeterHugossonMiller 9/3/2009 01:24'! 94500initScopeAndLiteralTables 94501 94502 scopeTable := StdVariables copy. 94503 litSet := StdLiterals copy. 94504 "comments can be left hanging on nodes from previous compilations. 94505 probably better than this hack fix is to create the nodes afresh on each compilation." 94506 scopeTable do: 94507 [:varNode| varNode comment: nil]. 94508 litSet do: 94509 [:varNode| varNode comment: nil]. 94510 selectorSet := StdSelectors copy. 94511 litIndSet := Dictionary new: 16. 94512 literalStream := (Array new: 32) writeStream. 94513 addedSelectorAndMethodClassLiterals := false! ! 94514 94515!Encoder methodsFor: 'initialize-release' stamp: 'PeterHugossonMiller 9/2/2009 16:17'! 94516nTemps: n literals: lits class: cl 94517 "Decompile." 94518 94519 supered := false. 94520 class := cl. 94521 nTemps := n. 94522 (literalStream := lits readStream) position: lits size. 94523 sourceRanges := Dictionary new: 32. 94524 globalSourceRanges := OrderedCollection new: 32. 94525! ! 94526 94527!Encoder methodsFor: 'initialize-release'! 94528noteSuper 94529 94530 supered := true! ! 94531 94532!Encoder methodsFor: 'initialize-release'! 94533release 94534 94535 requestor := nil! ! 94536 94537!Encoder methodsFor: 'initialize-release' stamp: 'PeterHugossonMiller 9/2/2009 16:17'! 94538temps: tempVars literals: lits class: cl 94539 "Decompile." 94540 94541 supered := false. 94542 class := cl. 94543 nTemps := tempVars size. 94544 tempVars do: [:node | scopeTable at: node name put: node]. 94545 (literalStream := lits readStream) position: lits size. 94546 sourceRanges := Dictionary new: 32. 94547 globalSourceRanges := OrderedCollection new: 32. 94548! ! 94549 94550 94551!Encoder methodsFor: 'results' stamp: 'bgf 3/12/2009 17:42'! 94552allLiterals 94553 ((literalStream isKindOf: WriteStream) 94554 and: [ (addedSelectorAndMethodClassLiterals ifNil: [ false ]) not]) ifTrue: 94555 [addedSelectorAndMethodClassLiterals := true. 94556 self litIndex: nil. 94557 self litIndex: self associationForClass]. 94558 ^literalStream contents 94559 94560 "The funky ifNil: [false], even though the init method initializes addedSAMCL, 94561 is simply so that Monticello can load and compile this update without 94562 killing the encoder that is compiling that update itself..."! ! 94563 94564!Encoder methodsFor: 'results' stamp: 'eem 5/27/2009 09:25'! 94565associationForClass 94566 | assoc | 94567 assoc := self environment associationAt: class name ifAbsent: [nil]. 94568 ^assoc value == class 94569 ifTrue: [assoc] 94570 ifFalse: [Association new value: class]! ! 94571 94572!Encoder methodsFor: 'results'! 94573literals 94574 "Should only be used for decompiling primitives" 94575 ^ literalStream contents! ! 94576 94577!Encoder methodsFor: 'results' stamp: 'di 10/12/1999 16:12'! 94578tempNames 94579 94580 ^ self tempNodes collect: 94581 [:node | (node isMemberOf: MessageAsTempNode) 94582 ifTrue: [scopeTable keyAtValue: node] 94583 ifFalse: [node key]]! ! 94584 94585!Encoder methodsFor: 'results' stamp: 'eem 5/27/2008 12:07'! 94586tempNodes 94587 | tempNodes | 94588 tempNodes := SortedCollection sortBlock: [:n1 :n2 | n1 code <= n2 code]. 94589 scopeTable associationsDo: 94590 [:assn | 94591 assn value isArray 94592 ifTrue: [assn value do: [:temp| tempNodes add: temp]] 94593 ifFalse: [assn value isTemp ifTrue: [tempNodes add: assn value]]]. 94594 ^tempNodes! ! 94595 94596!Encoder methodsFor: 'results' stamp: 'eem 9/8/2008 18:27'! 94597tempsAndBlockArgs 94598 | tempNodes | 94599 tempNodes := OrderedCollection new. 94600 scopeTable associationsDo: 94601 [:assn | | var | 94602 var := assn value. 94603 (var isTemp 94604 and: [var isMethodArg not 94605 and: [var scope = 0 or: [var scope = -1]]]) ifTrue: 94606 [tempNodes add: var]]. 94607 ^tempNodes! ! 94608 94609!Encoder methodsFor: 'results' stamp: 'eem 6/24/2008 14:24'! 94610unusedTempNames 94611 | unused | 94612 unused := OrderedCollection new. 94613 scopeTable associationsDo: 94614 [:assn | | name | 94615 (assn value isUnusedTemp) ifTrue: 94616 [name := assn value key. 94617 name ~= self doItInContextName ifTrue: [unused add: name]]]. 94618 ^ unused! ! 94619 94620 94621!Encoder methodsFor: 'source mapping' stamp: 'di 12/4/1999 22:27'! 94622globalSourceRanges 94623 94624 ^ globalSourceRanges! ! 94625 94626!Encoder methodsFor: 'source mapping'! 94627noteSourceRange: range forNode: node 94628 94629 sourceRanges at: node put: range! ! 94630 94631!Encoder methodsFor: 'source mapping' stamp: 'RAA 8/21/1999 06:52'! 94632rawSourceRanges 94633 94634 ^ sourceRanges ! ! 94635 94636!Encoder methodsFor: 'source mapping'! 94637sourceMap 94638 "Answer with a sorted set of associations (pc range)." 94639 94640 ^ (sourceRanges keys collect: 94641 [:key | Association key: key pc value: (sourceRanges at: key)]) 94642 asSortedCollection! ! 94643 94644!Encoder methodsFor: 'source mapping' stamp: 'ar 11/19/2002 14:41'! 94645sourceRangeFor: node 94646 94647 ^sourceRanges at: node! ! 94648 94649 94650!Encoder methodsFor: 'temps' stamp: 'ar 9/9/2006 12:05'! 94651autoBind: name 94652 "Declare a block argument as a temp if not already declared." 94653 | node | 94654 node := scopeTable 94655 at: name 94656 ifAbsent: 94657 [(self lookupInPools: name ifFound: [:assoc | assoc]) 94658 ifTrue: [self warnAboutShadowed: name]. 94659 ^ (self reallyBind: name) nowHasDef nowHasRef scope: 1]. 94660 node isTemp 94661 ifTrue: [node scope >= 0 ifTrue: 94662 [^ self notify: 'Name already used in this method']. 94663 node nowHasDef nowHasRef scope: 1] 94664 ifFalse: [^ self notify: 'Name already used in this class']. 94665 ^node! ! 94666 94667!Encoder methodsFor: 'temps' stamp: 'di 10/12/1999 16:53'! 94668bindAndJuggle: name 94669 94670 | node nodes first thisCode | 94671 node := self reallyBind: name. 94672 94673 "Declared temps must precede block temps for decompiler and debugger to work right" 94674 nodes := self tempNodes. 94675 (first := nodes findFirst: [:n | n scope > 0]) > 0 ifTrue: 94676 [node == nodes last ifFalse: [self error: 'logic error']. 94677 thisCode := (nodes at: first) code. 94678 first to: nodes size - 1 do: 94679 [:i | (nodes at: i) key: (nodes at: i) key 94680 code: (nodes at: i+1) code]. 94681 nodes last key: nodes last key code: thisCode]. 94682 94683 ^ node! ! 94684 94685!Encoder methodsFor: 'temps' stamp: 'jm 9/18/97 21:06'! 94686bindArg: name 94687 "Declare an argument." 94688 | node | 94689 nTemps >= 15 94690 ifTrue: [^self notify: 'Too many arguments']. 94691 node := self bindTemp: name. 94692 ^ node nowHasDef nowHasRef! ! 94693 94694!Encoder methodsFor: 'temps' stamp: 'eem 5/30/2008 12:05'! 94695bindBlockArg: name within: aBlockNode 94696 "With standard Smalltalk-80 (BlueBook) blocks it used to be legal to use a 94697 method temp as a block argument. This shouldn't be the case with the 94698 current compiler, which checks for temp names already being used as 94699 block arguments. But it is easily fooled by local block temps in optimized 94700 blocks, e.g. 94701 false 94702 ifTrue: [| temp |] 94703 ifFalse:[[:temp|]] 94704 Rather than fix this we keep the semantics and fix it in the closure compiler." 94705 ^self autoBind: name! ! 94706 94707!Encoder methodsFor: 'temps' stamp: 'crl 2/26/1999 12:18'! 94708bindBlockTemp: name 94709 "Declare a temporary block variable; complain if it's not a field or class variable." 94710 94711 | node | 94712 94713 node := scopeTable at: name ifAbsent: [^self reallyBind: name]. 94714 node isTemp 94715 ifTrue: [ 94716 node scope >= 0 ifTrue: [^ self notify: 'Name already used in this method']. 94717 node scope: 0] 94718 ifFalse: [^self notify: 'Name already used in this class']. 94719 ^node 94720! ! 94721 94722!Encoder methodsFor: 'temps' stamp: 'eem 5/30/2008 14:14'! 94723bindBlockTemp: name within: aBlockNode 94724 "The BlockContext compiler (the Smalltalk-80 BlueBook compiler) 94725 does provide support for ANSI block syntax, but not for ANSI block 94726 semantics. Here all temps live at the same level, the method level. 94727 The approach taken to two block-local temps in different blocks is to 94728 merge them into a single temp. e.g. 94729 expr 94730 ifTrue: [|temp| self statementOne] 94731 ifFalse: [|temp| self statementTwo] 94732 is effectvely transformed into 94733 | temp | 94734 expr 94735 ifTrue: [self statementOne] 94736 ifFalse: [self statementTwo] 94737 and 94738 expr do: [:each| | temp | ...]. 94739 expr do: [:each| | temp | ...]. 94740 is also effectively transformed into 94741 | temp | 94742 expr do: [:each| ...]. 94743 expr do: [:each| ...]. 94744 94745 The closure compiler treats the former similarly, but not the latter. 94746 The indirection through #bindBlockTemp:within: allows the closure encoder to do this." 94747 ^self bindBlockTemp: name! ! 94748 94749!Encoder methodsFor: 'temps' stamp: 'ar 9/9/2006 12:06'! 94750bindTemp: name 94751 "Declare a temporary; error not if a field or class variable." 94752 scopeTable at: name ifPresent:[:node| 94753 "When non-interactive raise the error only if its a duplicate" 94754 (node isTemp) 94755 ifTrue:[^self notify:'Name is already defined'] 94756 ifFalse:[self warnAboutShadowed: name]]. 94757 ^self reallyBind: name! ! 94758 94759!Encoder methodsFor: 'temps' stamp: 'mir 1/17/2004 12:31'! 94760bindTemp: name in: methodSelector 94761 "Declare a temporary; error not if a field or class variable." 94762 scopeTable at: name ifPresent:[:node| 94763 "When non-interactive raise the error only if its a duplicate" 94764 (node isTemp or:[requestor interactive]) 94765 ifTrue:[^self notify:'Name is already defined'] 94766 ifFalse:[Transcript 94767 show: '(', name, ' is shadowed in "' , class printString , '>>' , methodSelector printString , '")']]. 94768 ^self reallyBind: name! ! 94769 94770!Encoder methodsFor: 'temps' stamp: 'eem 12/1/2008 12:07'! 94771fixTemp: name 94772 | node | 94773 node := scopeTable at: name ifAbsent: []. 94774 node class ~~ TempVariableNode ifTrue: 94775 [self error: 'can only fix a floating temp var']. 94776 node index: nTemps. 94777 nTemps := nTemps + 1. 94778 ^node! ! 94779 94780!Encoder methodsFor: 'temps' stamp: 'eem 7/13/2007 14:13'! 94781floatTemp: node 94782 (node ~~ (scopeTable at: node name ifAbsent: []) 94783 or: [node class ~~ TempVariableNode 94784 or: [node code ~= (node code: nTemps - 1 type: LdTempType)]]) ifTrue: 94785 [self error: 'can only float the last allocated temp var']. 94786 nTemps := nTemps - 1! ! 94787 94788!Encoder methodsFor: 'temps'! 94789maxTemp 94790 94791 ^nTemps! ! 94792 94793!Encoder methodsFor: 'temps'! 94794newTemp: name 94795 94796 nTemps := nTemps + 1. 94797 ^ TempVariableNode new 94798 name: name 94799 index: nTemps - 1 94800 type: LdTempType 94801 scope: 0! ! 94802 94803 94804!Encoder methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:44'! 94805accept: aVisitor 94806 "I am not really a ParseNode. Only here to access constants defined in parseNode." 94807 self shouldNotImplement! ! 94808 94809 94810!Encoder methodsFor: 'private'! 94811classEncoding 94812 "This is a hack so that the parser may findout what class it was parsing for when it wants to create a syntax error view." 94813 ^ class! ! 94814 94815!Encoder methodsFor: 'private' stamp: 'ar 8/14/2001 23:12'! 94816global: ref name: name 94817 94818 ^self 94819 name: name 94820 key: ref 94821 class: LiteralVariableNode 94822 type: LdLitIndType 94823 set: litIndSet! ! 94824 94825!Encoder methodsFor: 'private' stamp: 'ar 3/26/2004 15:44'! 94826interactive 94827 ^requestor interactive! ! 94828 94829!Encoder methodsFor: 'private' stamp: 'eem 9/10/2008 14:03'! 94830lookupInPools: varName ifFound: assocBlock 94831 94832 ^Symbol 94833 hasInterned: varName 94834 ifTrue: 94835 [:sym| 94836 (class bindingOf: sym) 94837 ifNil: [^false] 94838 ifNotNil: [:assoc| assocBlock value: assoc]]! ! 94839 94840!Encoder methodsFor: 'private' stamp: 'eem 6/11/2008 17:31'! 94841name: name key: key class: leafNodeClass type: type set: dict 94842 94843 ^dict 94844 at: key 94845 ifAbsent: 94846 [dict 94847 at: key 94848 put: (leafNodeClass new 94849 name: name 94850 key: key 94851 index: nil 94852 type: type)]! ! 94853 94854!Encoder methodsFor: 'private' stamp: 'ar 1/2/2002 14:53'! 94855possibleNamesFor: proposedName 94856 | results | 94857 results := class possibleVariablesFor: proposedName continuedFrom: nil. 94858 ^ proposedName correctAgainst: nil continuedFrom: results. 94859! ! 94860 94861!Encoder methodsFor: 'private' stamp: 'yo 11/11/2002 10:23'! 94862possibleVariablesFor: proposedVariable 94863 94864 | results | 94865 results := proposedVariable correctAgainstDictionary: scopeTable 94866 continuedFrom: nil. 94867 proposedVariable first canBeGlobalVarInitial ifTrue: 94868 [ results := class possibleVariablesFor: proposedVariable 94869 continuedFrom: results ]. 94870 ^ proposedVariable correctAgainst: nil continuedFrom: results. 94871! ! 94872 94873!Encoder methodsFor: 'private'! 94874reallyBind: name 94875 94876 | node | 94877 node := self newTemp: name. 94878 scopeTable at: name put: node. 94879 ^node! ! 94880 94881!Encoder methodsFor: 'private' stamp: 'eem 6/19/2008 13:02'! 94882warnAboutShadowed: name 94883 requestor addWarning: name,' is shadowed'. 94884 selector ifNotNil: 94885 [Transcript cr; show: class name,'>>', selector, '(', name,' is shadowed)']! ! 94886BytecodeEncoder subclass: #EncoderForLongFormV3 94887 instanceVariableNames: '' 94888 classVariableNames: '' 94889 poolDictionaries: '' 94890 category: 'Compiler-Kernel'! 94891!EncoderForLongFormV3 commentStamp: '<historical>' prior: 0! 94892I am an alternate to EncoderForV3 that tries to use thje longest forms of bytecodes possible so as to avoid using as many bytecode as possible to allow for the unused portions of the bytecode set this makes available to be reassigned. 94893 94894 94895 94896I do not use the following ranges 94897 948980 through 111 94899 94900 0- 15 0000iiii Push Receiver Variable #iiii 94901 94902 16- 31 0001iiii Push Temporary Location #iiii 94903 94904 32- 63 001iiiii Push Literal Constant #iiiii 94905 94906 64- 95 010iiiii Push Literal Variable #iiiii 94907 94908 96-103 01100iii Pop and Store Receiver Variable #iii 94909 94910 104-111 01101iii Pop and Store Temporary Location #iii 94911 94912138-159 94913 94914 138-143 Unused. 94915 94916 144-151 10010iii Jump iii + 1 (i.e., 1 through 8). 94917 94918 152-159 10011iii Pop and Jump 0n False iii +1 (i.e., 1 through 8). 94919 94920176-255 94921 94922 176-191 1011iiii Send Arithmetic Message #iiii 94923 94924 192-207 1100iiii Send Special Message #iiii 94925 94926 208-223 1101iiii Send Literal Selector #iiii With No Arguments 94927 94928 224-239 1110iiii Send Literal Selector #iiii With 1 Argument 94929 94930 240-255 1111iiii Send Literal Selector #iiii With 2 Arguments 94931 94932= 112 + (160 - 138) + (256 - 176) = 214, or 84% of the bytecodes! 94933 94934 94935!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:52'! 94936genBranchPopFalse: distance 94937 "See BlueBook page 596" 94938 distance < 0 ifTrue: 94939 [^self outOfRangeError: 'distance' index: distance range: 0 to: 1023]. 94940 distance < 1024 ifTrue: 94941 ["172-175 101011ii jjjjjjjj Pop and Jump On False ii *256+jjjjjjjj" 94942 stream 94943 nextPut: 172 + (distance bitShift: -8); 94944 nextPut: distance + 1024 \\ 256. 94945 ^self]. 94946 ^self outOfRangeError: 'distance' index: distance range: 0 to: 1023! ! 94947 94948!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:53'! 94949genBranchPopTrue: distance 94950 "See BlueBook page 596" 94951 distance < 0 ifTrue: 94952 [^self outOfRangeError: 'distance' index: distance range: 0 to: 1023]. 94953 distance < 1024 ifTrue: 94954 ["168-171 101010ii jjjjjjjj Pop and Jump On True ii *256+jjjjjjjj" 94955 stream 94956 nextPut: 168 + (distance bitShift: -8); 94957 nextPut: distance + 1024 \\ 256. 94958 ^self]. 94959 ^self outOfRangeError: 'distance' index: distance range: 0 to: 1023! ! 94960 94961!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! 94962genDup 94963 "See BlueBook page 596" 94964 "136 10001000 Duplicate Stack Top" 94965 stream nextPut: 136! ! 94966 94967!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:20'! 94968genJump: distance 94969 "See BlueBook page 596" 94970 ^self genJumpLong: distance! ! 94971 94972!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:53'! 94973genJumpLong: distance 94974 "See BlueBook page 596" 94975 (distance >= -1024 and: [distance < 1024]) ifTrue: 94976 ["160-167 10100iii jjjjjjjj Jump(iii - 4) *256+jjjjjjjj" 94977 stream 94978 nextPut: 160 + (distance + 1024 bitShift: -8); 94979 nextPut: distance + 1024 \\ 256. 94980 ^self]. 94981 ^self outOfRangeError: 'distance' index: distance range: -1024 to: 1023! ! 94982 94983!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! 94984genPop 94985 "See BlueBook page 596" 94986 "135 10000111 Pop Stack Top" 94987 stream nextPut: 135! ! 94988 94989!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:46'! 94990genPushInstVar: instVarIndex 94991 "See BlueBook page 596" 94992 (instVarIndex >= 0 and: [instVarIndex < 64]) ifTrue: 94993 ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" 94994 stream 94995 nextPut: 128; 94996 nextPut: instVarIndex. 94997 ^self]. 94998 self genPushInstVarLong: instVarIndex! ! 94999 95000!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:51'! 95001genPushInstVarLong: instVarIndex 95002 "See BlueBook page 596" 95003 "See also MaybeContextInstanceVariableNode" 95004 (instVarIndex >= 0 and: [instVarIndex < 256]) ifTrue: 95005 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95006 stream 95007 nextPut: 132; 95008 nextPut: 64; 95009 nextPut: instVarIndex. 95010 ^self]. 95011 ^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 255! ! 95012 95013!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:54'! 95014genPushLiteral: literalIndex 95015 "See BlueBook page 596" 95016 literalIndex < 0 ifTrue: 95017 [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. 95018 literalIndex < 64 ifTrue: 95019 ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" 95020 stream 95021 nextPut: 128; 95022 nextPut: 128 + literalIndex. 95023 ^self]. 95024 literalIndex < 256 ifTrue: 95025 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95026 stream 95027 nextPut: 132; 95028 nextPut: 96; 95029 nextPut: literalIndex. 95030 ^self]. 95031 ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! 95032 95033!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:54'! 95034genPushLiteralVar: literalIndex 95035 "See BlueBook page 596" 95036 literalIndex < 0 ifTrue: 95037 [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. 95038 literalIndex < 64 ifTrue: 95039 ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" 95040 stream 95041 nextPut: 128; 95042 nextPut: 192 + literalIndex. 95043 ^self]. 95044 literalIndex < 256 ifTrue: 95045 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95046 stream 95047 nextPut: 132; 95048 nextPut: 128; 95049 nextPut: literalIndex. 95050 ^self]. 95051 ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! 95052 95053!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! 95054genPushReceiver 95055 "See BlueBook page 596" 95056 "112-119 01110iii Push (receiver, true, false, nil, -1, 0, 1, 2) [iii]" 95057 stream nextPut: 112! ! 95058 95059!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! 95060genPushSpecialLiteral: aLiteral 95061 "112-119 01110iii Push (receiver, true, false, nil, -1, 0, 1, 2) [iii]" 95062 | index | 95063 index := #(true false nil -1 0 1 2) indexOf: aLiteral ifAbsent: 0. 95064 index = 0 ifTrue: 95065 [^self error: 'push special literal: ', aLiteral printString, ' is not one of true false nil -1 0 1 2']. 95066 stream nextPut: index + 112! ! 95067 95068!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:54'! 95069genPushTemp: tempIndex 95070 "See BlueBook page 596" 95071 tempIndex < 0 ifTrue: 95072 [^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63]. 95073 tempIndex < 64 ifTrue: 95074 ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" 95075 stream 95076 nextPut: 128; 95077 nextPut: 64 + tempIndex. 95078 ^self]. 95079 ^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63! ! 95080 95081!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! 95082genPushThisContext 95083 "See BlueBook page 596" 95084 "137 10001001 Push Active Context" 95085 stream nextPut: 137! ! 95086 95087!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! 95088genReturnReceiver 95089 "See BlueBook page 596" 95090 "120-123 011110ii Return (receiver, true, false, nil) [ii] From Message" 95091 stream nextPut: 120! ! 95092 95093!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! 95094genReturnSpecialLiteral: aLiteral 95095 "120-123 011110ii Return (receiver, true, false, nil) [ii] From Message" 95096 | index | 95097 index := #(true false nil) indexOf: aLiteral ifAbsent: 0. 95098 index = 0 ifTrue: 95099 [^self error: 'return special literal: ', aLiteral printString, ' is not one of true false nil']. 95100 stream nextPut: 120 + index! ! 95101 95102!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! 95103genReturnTop 95104 "See BlueBook page 596" 95105 "124-125 0111110i Return Stack Top From (Message, Block) [i]" 95106 stream nextPut: 124! ! 95107 95108!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! 95109genReturnTopToCaller 95110 "See BlueBook page 596" 95111 "124-125 0111110i Return Stack Top From (Message, Block) [i]" 95112 stream nextPut: 125! ! 95113 95114!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:56'! 95115genSend: selectorLiteralIndex numArgs: nArgs 95116 "See BlueBook page 596 (with exceptions for 132 & 134)" 95117 nArgs < 0 ifTrue: 95118 [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31 "!!!!"]. 95119 selectorLiteralIndex < 0 ifTrue: 95120 ["No special selector sends in long form." 95121 ^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]. 95122 (selectorLiteralIndex < 32 and: [nArgs < 8]) ifTrue: 95123 [" 131 10000011 jjjkkkkk Send Literal Selector #kkkkk With jjj Arguments" 95124 stream 95125 nextPut: 131; 95126 nextPut: ((nArgs bitShift: 5) + selectorLiteralIndex). 95127 ^self]. 95128 (selectorLiteralIndex < 64 and: [nArgs < 4]) ifTrue: 95129 ["In Squeak V3 95130 134 10000110 jjjjjjjj kkkkkkkk Send Literal Selector #kkkkkkkk To Superclass With jjjjjjjj Arguments 95131 is replaced by 95132 134 10000110 jjkkkkkk Send Literal Selector #kkkkkk With jj Arguments" 95133 stream 95134 nextPut: 134; 95135 nextPut: ((nArgs bitShift: 6) + selectorLiteralIndex). 95136 ^self]. 95137 (selectorLiteralIndex <= 255 and: [nArgs <= 31]) ifTrue: 95138 ["In Squeak V3 95139 132 10000100 jjjjjjjj kkkkkkkk Send Literal Selector #kkkkkkkk With jjjjjjjj Arguments 95140 is replaced by 95141 132 10000100 ooojjjjj kkkkkkkk 95142 ooo = 0 => Send Literal Selector #kkkkkkkk With jjjjj Arguments 95143 ooo = 1 => Send Literal Selector #kkkkkkkk To Superclass With jjjjj Arguments" 95144 stream 95145 nextPut: 132; 95146 nextPut: nArgs; 95147 nextPut: selectorLiteralIndex. 95148 ^self]. 95149 nArgs > 31 ifTrue: 95150 [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31]. 95151 selectorLiteralIndex > 255 ifTrue: 95152 [^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]! ! 95153 95154!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:55'! 95155genSendSuper: selectorLiteralIndex numArgs: nArgs 95156 "See BlueBook page 596 (with exceptions for 132 & 134)" 95157 nArgs < 0 ifTrue: 95158 [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31 "!!!!"]. 95159 selectorLiteralIndex < 0 ifTrue: 95160 [^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]. 95161 (selectorLiteralIndex < 32 and: [nArgs < 8]) ifTrue: 95162 [" 133 10000011 jjjkkkkk Send Literal Selector #kkkkk To Superclass With jjj Arguments" 95163 stream 95164 nextPut: 133; 95165 nextPut: ((nArgs bitShift: 5) + selectorLiteralIndex). 95166 ^self]. 95167 (selectorLiteralIndex <= 255 and: [nArgs <= 31]) ifTrue: 95168 ["In Squeak V3 95169 132 10000100 jjjjjjjj kkkkkkkk Send Literal Selector #kkkkkkkk With jjjjjjjj Arguments 95170 is replaced by 95171 132 10000100 ooojjjjj kkkkkkkk 95172 ooo = 0 => Send Literal Selector #kkkkkkkk With jjjjj Arguments 95173 ooo = 1 => Send Literal Selector #kkkkkkkk To Superclass With jjjjj Arguments" 95174 stream 95175 nextPut: 132; 95176 nextPut: 32 + nArgs; 95177 nextPut: selectorLiteralIndex. 95178 ^self]. 95179 nArgs > 31 ifTrue: 95180 [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31]. 95181 selectorLiteralIndex > 255 ifTrue: 95182 [^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]! ! 95183 95184!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:48'! 95185genStoreInstVar: instVarIndex 95186 "See BlueBook page 596" 95187 (instVarIndex >= 0 and: [instVarIndex < 64]) ifTrue: 95188 ["129 10000001 jjkkkkkk Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" 95189 stream 95190 nextPut: 129; 95191 nextPut: instVarIndex. 95192 ^self]. 95193 self genStoreInstVarLong: instVarIndex! ! 95194 95195!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:51'! 95196genStoreInstVarLong: instVarIndex 95197 "See BlueBook page 596" 95198 "See also MaybeContextInstanceVariableNode" 95199 (instVarIndex >= 0 and: [instVarIndex < 256]) ifTrue: 95200 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95201 stream 95202 nextPut: 132; 95203 nextPut: 160; 95204 nextPut: instVarIndex. 95205 ^self]. 95206 ^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 255! ! 95207 95208!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:57'! 95209genStoreLiteralVar: literalIndex 95210 "See BlueBook page 596" 95211 literalIndex < 0 ifTrue: 95212 [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. 95213 literalIndex < 64 ifTrue: 95214 ["129 10000001 jjkkkkkk Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" 95215 stream 95216 nextPut: 129; 95217 nextPut: 192 + literalIndex. 95218 ^self]. 95219 literalIndex <= 255 ifTrue: 95220 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95221 stream 95222 nextPut: 132; 95223 nextPut: 224; 95224 nextPut: literalIndex. 95225 ^self]. 95226 ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! 95227 95228!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:50'! 95229genStorePopInstVar: instVarIndex 95230 "See BlueBook page 596" 95231 (instVarIndex >= 0 and: [instVarIndex < 64]) ifTrue: 95232 ["130 10000010 jjkkkkkk Pop and Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" 95233 stream 95234 nextPut: 130; 95235 nextPut: instVarIndex. 95236 ^self]. 95237 self genStorePopInstVarLong: instVarIndex! ! 95238 95239!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:51'! 95240genStorePopInstVarLong: instVarIndex 95241 "See BlueBook page 596" 95242 "See also MaybeContextInstanceVariableNode" 95243 (instVarIndex >= 0 and: [instVarIndex < 256]) ifTrue: 95244 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95245 stream 95246 nextPut: 132; 95247 nextPut: 192; 95248 nextPut: instVarIndex. 95249 ^self]. 95250 ^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 255! ! 95251 95252!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:58'! 95253genStorePopLiteralVar: literalIndex 95254 "See BlueBook page 596" 95255 literalIndex < 0 ifTrue: 95256 [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. 95257 literalIndex < 64 ifTrue: 95258 ["130 10000010 jjkkkkkk Pop and Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" 95259 stream 95260 nextPut: 130; 95261 nextPut: 192 + literalIndex. 95262 ^self]. 95263 literalIndex <= 255 ifTrue: 95264 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95265 stream 95266 nextPut: 132; 95267 nextPut: 224; 95268 nextPut: literalIndex. 95269 self genPop. 95270 ^self]. 95271 ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! 95272 95273!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:58'! 95274genStorePopTemp: tempIndex 95275 "See BlueBook page 596" 95276 tempIndex < 0 ifTrue: 95277 [^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63]. 95278 tempIndex < 64 ifTrue: 95279 ["130 10000010 jjkkkkkk Pop and Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" 95280 stream 95281 nextPut: 130; 95282 nextPut: 64 + tempIndex. 95283 ^self]. 95284 ^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63! ! 95285 95286!EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:58'! 95287genStoreTemp: tempIndex 95288 "See BlueBook page 596" 95289 tempIndex < 0 ifTrue: 95290 [^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63]. 95291 tempIndex < 64 ifTrue: 95292 ["129 10000001 jjkkkkkk Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" 95293 stream 95294 nextPut: 129; 95295 nextPut: 64 + tempIndex. 95296 ^self]. 95297 ^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63! ! 95298 95299 95300!EncoderForLongFormV3 methodsFor: 'initialize-release' stamp: 'eem 5/15/2008 14:11'! 95301initScopeAndLiteralTables 95302 super initScopeAndLiteralTables. 95303 "Start with an empty selector set to avoid the special selectors." 95304 selectorSet := Dictionary new: 16! ! 95305EncoderForLongFormV3 subclass: #EncoderForLongFormV3PlusClosures 95306 instanceVariableNames: '' 95307 classVariableNames: '' 95308 poolDictionaries: '' 95309 category: 'Compiler-Kernel'! 95310!EncoderForLongFormV3PlusClosures commentStamp: '<historical>' prior: 0! 95311An encoder for the V3 bytecode set augmented with the following bytecodes that are part of the full closure implementation. 95312 138 10001010 jkkkkkkk Push (Array new: kkkkkkk) (j = 0) 95313 or Pop kkkkkkk elements into: (Array new: kkkkkkk) (j = 1) 95314 95315 140 10001100 kkkkkkkk jjjjjjjj Push Temp At kkkkkkkk In Temp Vector At: jjjjjjjj 95316 141 10001101 kkkkkkkk jjjjjjjj Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj 95317 142 10001110 kkkkkkkk jjjjjjjj Pop and Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj 95318 143 10001111 llllkkkk jjjjjjjj iiiiiiii Push Closure Num Copied llll Num Args kkkk BlockSize jjjjjjjjiiiiiiii 95319This is an exact duplicate of EncoderForV3PlusClosures. 95320Could be a trait (or in Newspeak, a Mixin). 95321For now we impose upon you to synchronise any and all changes between these two classes.! 95322 95323 95324!EncoderForLongFormV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:10'! 95325genPushClosureCopyNumCopiedValues: numCopied numArgs: numArgs jumpSize: jumpSize 95326 "143 10001111 llllkkkk jjjjjjjj iiiiiiii Push Closure Num Copied llll Num Args kkkk BlockSize jjjjjjjjiiiiiiii" 95327 (jumpSize < 0 or: [jumpSize > 65535]) ifTrue: 95328 [^self outOfRangeError: 'block size' index: jumpSize range: 0 to: 65535]. 95329 (numCopied < 0 or: [numCopied > 15]) ifTrue: 95330 [^self outOfRangeError: 'num copied' index: numCopied range: 0 to: 15]. 95331 (numArgs < 0 or: [numArgs > 15]) ifTrue: 95332 [^self outOfRangeError: 'num args' index: numArgs range: 0 to: 15]. 95333 stream 95334 nextPut: 143; 95335 nextPut: numArgs + (numCopied bitShift: 4); 95336 nextPut: (jumpSize bitShift: -8); 95337 nextPut: (jumpSize bitAnd: 16rFF)! ! 95338 95339!EncoderForLongFormV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:06'! 95340genPushConsArray: size 95341 (size < 0 or: [size > 127]) ifTrue: 95342 [^self outOfRangeError: 'numElements' index: size range: 0 to: 127]. 95343 "138 10001010 1kkkkkkk Pop kkkkkkk into: (Array new: kkkkkkk)" 95344 stream 95345 nextPut: 138; 95346 nextPut: size + 128! ! 95347 95348!EncoderForLongFormV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:05'! 95349genPushNewArray: size 95350 (size < 0 or: [size > 127]) ifTrue: 95351 [^self outOfRangeError: 'size' index: size range: 0 to: 127]. 95352 "138 10001010 0kkkkkkk Push (Array new: kkkkkkk)" 95353 stream 95354 nextPut: 138; 95355 nextPut: size! ! 95356 95357!EncoderForLongFormV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 6/16/2008 09:45'! 95358genPushRemoteTemp: tempIndex inVectorAt: tempVectorIndex 95359 (tempIndex >= 0 and: [tempIndex < 256 95360 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: 95361 ["140 10001100 kkkkkkkk jjjjjjjj Push Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" 95362 stream 95363 nextPut: 140; 95364 nextPut: tempIndex; 95365 nextPut: tempVectorIndex. 95366 ^self]. 95367 tempIndex >= 256 ifTrue: 95368 [^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255]. 95369 tempVectorIndex >= 256 ifTrue: 95370 [^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 255]! ! 95371 95372!EncoderForLongFormV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:04'! 95373genStorePopRemoteTemp: tempIndex inVectorAt: tempVectorIndex 95374 "142 10001110 kkkkkkkk jjjjjjjj Pop and Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" 95375 (tempIndex >= 0 and: [tempIndex < 256 95376 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: 95377 [stream 95378 nextPut: 142; 95379 nextPut: tempIndex; 95380 nextPut: tempVectorIndex. 95381 ^self]. 95382 tempIndex >= 256 ifTrue: 95383 [^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255]. 95384 tempVectorIndex >= 256 ifTrue: 95385 [^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 255]! ! 95386 95387!EncoderForLongFormV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:04'! 95388genStoreRemoteTemp: tempIndex inVectorAt: tempVectorIndex 95389 "141 10001101 kkkkkkkk jjjjjjjj Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" 95390 (tempIndex >= 0 and: [tempIndex < 256 95391 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: 95392 [stream 95393 nextPut: 141; 95394 nextPut: tempIndex; 95395 nextPut: tempVectorIndex. 95396 ^self]. 95397 tempIndex >= 256 ifTrue: 95398 [^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255]. 95399 tempVectorIndex >= 256 ifTrue: 95400 [^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 255]! ! 95401 95402 95403!EncoderForLongFormV3PlusClosures methodsFor: 'testing' stamp: 'eem 5/24/2008 18:12'! 95404supportsClosureOpcodes 95405 ^true! ! 95406 95407"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 95408 95409EncoderForLongFormV3PlusClosures class 95410 instanceVariableNames: ''! 95411BytecodeEncoder subclass: #EncoderForV3 95412 instanceVariableNames: '' 95413 classVariableNames: '' 95414 poolDictionaries: '' 95415 category: 'Compiler-Kernel'! 95416!EncoderForV3 commentStamp: '<historical>' prior: 0! 95417I add behaviour to Encoder to size and emit bytecodes for the Squeak V3.x VM bytecode set. The intention is for another subclass to restrict the range of bytecodes used to long forms only, allowing the bytecode set to be redefined by avoiding using the many short forms. The short forms may then be reassigned.! 95418 95419 95420!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:59'! 95421genBranchPopFalse: distance 95422 "See BlueBook page 596" 95423 distance < 0 ifTrue: 95424 [^self outOfRangeError: 'distance' index: distance range: 0 to: 1023]. 95425 (distance > 0 and: [distance < 9]) ifTrue: 95426 ["152-159 10011iii Pop and Jump 0n False iii +1 (i.e., 1 through 8)" 95427 stream nextPut: 152 + distance - 1. 95428 ^self]. 95429 distance < 1024 ifTrue: 95430 ["172-175 101011ii jjjjjjjj Pop and Jump On False ii *256+jjjjjjjj" 95431 stream 95432 nextPut: 172 + (distance bitShift: -8); 95433 nextPut: distance + 1024 \\ 256. 95434 ^self]. 95435 ^self outOfRangeError: 'distance' index: distance range: 0 to: 1023! ! 95436 95437!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:59'! 95438genBranchPopTrue: distance 95439 "See BlueBook page 596" 95440 distance < 0 ifTrue: 95441 [^self outOfRangeError: 'distance' index: distance range: 0 to: 1023]. 95442 distance < 1024 ifTrue: 95443 ["168-171 101010ii jjjjjjjj Pop and Jump On True ii *256+jjjjjjjj" 95444 stream 95445 nextPut: 168 + (distance bitShift: -8); 95446 nextPut: distance + 1024 \\ 256. 95447 ^self]. 95448 ^self outOfRangeError: 'distance' index: distance range: 0 to: 1023! ! 95449 95450!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 09:40'! 95451genDup 95452 "See BlueBook page 596" 95453 "136 10001000 Duplicate Stack Top" 95454 stream nextPut: 136! ! 95455 95456!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:41'! 95457genJump: distance 95458 "See BlueBook page 596" 95459 (distance > 0 and: [distance < 9]) ifTrue: 95460 ["144-151 10010iii Jump iii + 1 (i.e., 1 through 8)" 95461 stream nextPut: 144 + distance - 1. 95462 ^self]. 95463 "160-167 10100iii jjjjjjjj Jump(iii - 4) *256+jjjjjjjj" 95464 ^self genJumpLong: distance! ! 95465 95466!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:59'! 95467genJumpLong: distance 95468 "See BlueBook page 596" 95469 (distance >= -1024 and: [distance < 1024]) ifTrue: 95470 ["160-167 10100iii jjjjjjjj Jump(iii - 4) *256+jjjjjjjj" 95471 stream 95472 nextPut: 160 + (distance + 1024 bitShift: -8); 95473 nextPut: distance + 1024 \\ 256. 95474 ^self]. 95475 ^self outOfRangeError: 'distance' index: distance range: -1024 to: 1023! ! 95476 95477!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:27'! 95478genPop 95479 "See BlueBook page 596" 95480 "135 10000111 Pop Stack Top" 95481 stream nextPut: 135! ! 95482 95483!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:40'! 95484genPushInstVar: instVarIndex 95485 "See BlueBook page 596" 95486 instVarIndex >= 0 ifTrue: 95487 [instVarIndex < 16 ifTrue: 95488 ["0-15 0000iiii Push Receiver Variable #iiii" 95489 stream nextPut: 0 + instVarIndex. 95490 ^self]. 95491 instVarIndex < 64 ifTrue: 95492 ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" 95493 stream 95494 nextPut: 128; 95495 nextPut: instVarIndex. 95496 ^self]]. 95497 self genPushInstVarLong: instVarIndex! ! 95498 95499!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:51'! 95500genPushInstVarLong: instVarIndex 95501 "See BlueBook page 596" 95502 "See also MaybeContextInstanceVariableNode" 95503 (instVarIndex >= 0 and: [instVarIndex < 256]) ifTrue: 95504 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95505 stream 95506 nextPut: 132; 95507 nextPut: 64; 95508 nextPut: instVarIndex. 95509 ^self]. 95510 ^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 255! ! 95511 95512!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:00'! 95513genPushLiteral: literalIndex 95514 "See BlueBook page 596" 95515 literalIndex < 0 ifTrue: 95516 [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. 95517 literalIndex < 32 ifTrue: 95518 ["32-63 001iiiii Push Literal Constant #iiiii" 95519 stream nextPut: 32 + literalIndex. 95520 ^self]. 95521 literalIndex < 64 ifTrue: 95522 ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" 95523 stream 95524 nextPut: 128; 95525 nextPut: 128 + literalIndex. 95526 ^self]. 95527 literalIndex < 256 ifTrue: 95528 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95529 stream 95530 nextPut: 132; 95531 nextPut: 96; 95532 nextPut: literalIndex. 95533 ^self]. 95534 ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! 95535 95536!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:59'! 95537genPushLiteralVar: literalIndex 95538 "See BlueBook page 596" 95539 literalIndex < 0 ifTrue: 95540 [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. 95541 literalIndex < 32 ifTrue: 95542 ["64-95 010iiiii Push Literal Variable #iiiii" 95543 stream nextPut: 64 + literalIndex. 95544 ^self]. 95545 literalIndex < 64 ifTrue: 95546 ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" 95547 stream 95548 nextPut: 128; 95549 nextPut: 192 + literalIndex. 95550 ^self]. 95551 literalIndex < 256 ifTrue: 95552 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95553 stream 95554 nextPut: 132; 95555 nextPut: 128; 95556 nextPut: literalIndex. 95557 ^self]. 95558 ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! 95559 95560!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 16:16'! 95561genPushReceiver 95562 "See BlueBook page 596" 95563 "112-119 01110iii Push (receiver, true, false, nil, -1, 0, 1, 2) [iii]" 95564 stream nextPut: 112! ! 95565 95566!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:38'! 95567genPushSpecialLiteral: aLiteral 95568 "112-119 01110iii Push (receiver, true, false, nil, -1, 0, 1, 2) [iii]" 95569 | index | 95570 index := #(true false nil -1 0 1 2) indexOf: aLiteral ifAbsent: 0. 95571 index = 0 ifTrue: 95572 [^self error: 'push special literal: ', aLiteral printString, ' is not one of true false nil -1 0 1 2']. 95573 stream nextPut: index + 112! ! 95574 95575!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:00'! 95576genPushTemp: tempIndex 95577 "See BlueBook page 596" 95578 tempIndex < 0 ifTrue: 95579 [^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63]. 95580 tempIndex < 16 ifTrue: 95581 ["16-31 0001iiii Push Temporary Location #iiii" 95582 stream nextPut: 16 + tempIndex. 95583 ^self]. 95584 tempIndex < 64 ifTrue: 95585 ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" 95586 stream 95587 nextPut: 128; 95588 nextPut: 64 + tempIndex. 95589 ^self]. 95590 ^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63! ! 95591 95592!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:36'! 95593genPushThisContext 95594 "See BlueBook page 596" 95595 "137 10001001 Push Active Context" 95596 stream nextPut: 137! ! 95597 95598!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:40'! 95599genReturnReceiver 95600 "See BlueBook page 596" 95601 "120-123 011110ii Return (receiver, true, false, nil) [ii] From Message" 95602 stream nextPut: 120! ! 95603 95604!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:39'! 95605genReturnSpecialLiteral: aLiteral 95606 "120-123 011110ii Return (receiver, true, false, nil) [ii] From Message" 95607 | index | 95608 index := #(true false nil) indexOf: aLiteral ifAbsent: 0. 95609 index = 0 ifTrue: 95610 [^self error: 'return special literal: ', aLiteral printString, ' is not one of true false nil']. 95611 stream nextPut: 120 + index! ! 95612 95613!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:35'! 95614genReturnTop 95615 "See BlueBook page 596" 95616 "124-125 0111110i Return Stack Top From (Message, Block) [i]" 95617 stream nextPut: 124! ! 95618 95619!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:35'! 95620genReturnTopToCaller 95621 "See BlueBook page 596" 95622 "124-125 0111110i Return Stack Top From (Message, Block) [i]" 95623 stream nextPut: 125! ! 95624 95625!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:00'! 95626genSend: selectorLiteralIndex numArgs: nArgs 95627 "See BlueBook page 596 (with exceptions for 132 & 134)" 95628 nArgs < 0 ifTrue: 95629 [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31 "!!!!"]. 95630 selectorLiteralIndex < 0 ifTrue: 95631 ["Special selector sends. 95632 176-191 1011iiii Send Arithmetic Message #iiii 95633 192-207 1100iiii Send Special Message #iiii" 95634 self flag: #yuck. 95635 (selectorLiteralIndex negated between: 176 and: 207) ifFalse: 95636 [^self outOfRangeError: 'special selector code' index: selectorLiteralIndex negated range: 176 to: 207]. 95637 stream nextPut: selectorLiteralIndex negated. 95638 ^self]. 95639 (selectorLiteralIndex < 16 and: [nArgs < 3]) ifTrue: 95640 [" 208-223 1101iiii Send Literal Selector #iiii With No Arguments 95641 224-239 1110iiii Send Literal Selector #iiii With 1 Argument 95642 240-255 1111iiii Send Literal Selector #iiii With 2 Arguments" 95643 stream nextPut: 208 + (nArgs * 16) + selectorLiteralIndex. 95644 ^self]. 95645 (selectorLiteralIndex < 32 and: [nArgs < 8]) ifTrue: 95646 [" 131 10000011 jjjkkkkk Send Literal Selector #kkkkk With jjj Arguments" 95647 stream 95648 nextPut: 131; 95649 nextPut: ((nArgs bitShift: 5) + selectorLiteralIndex). 95650 ^self]. 95651 (selectorLiteralIndex < 64 and: [nArgs < 4]) ifTrue: 95652 ["In Squeak V3 95653 134 10000110 jjjjjjjj kkkkkkkk Send Literal Selector #kkkkkkkk To Superclass With jjjjjjjj Arguments 95654 is replaced by 95655 134 10000110 jjkkkkkk Send Literal Selector #kkkkkk With jj Arguments" 95656 stream 95657 nextPut: 134; 95658 nextPut: ((nArgs bitShift: 6) + selectorLiteralIndex). 95659 ^self]. 95660 (selectorLiteralIndex < 256 and: [nArgs < 32]) ifTrue: 95661 ["In Squeak V3 95662 132 10000100 jjjjjjjj kkkkkkkk Send Literal Selector #kkkkkkkk With jjjjjjjj Arguments 95663 is replaced by 95664 132 10000100 ooojjjjj kkkkkkkk 95665 ooo = 0 => Send Literal Selector #kkkkkkkk With jjjjj Arguments 95666 ooo = 1 => Send Literal Selector #kkkkkkkk To Superclass With jjjjj Arguments" 95667 stream 95668 nextPut: 132; 95669 nextPut: nArgs; 95670 nextPut: selectorLiteralIndex. 95671 ^self]. 95672 nArgs >= 32 ifTrue: 95673 [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31]. 95674 selectorLiteralIndex >= 256 ifTrue: 95675 [^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]! ! 95676 95677!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:00'! 95678genSendSuper: selectorLiteralIndex numArgs: nArgs 95679 "See BlueBook page 596 (with exceptions for 132 & 134)" 95680 nArgs < 0 ifTrue: 95681 [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31 "!!!!"]. 95682 selectorLiteralIndex < 0 ifTrue: 95683 [^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]. 95684 (selectorLiteralIndex < 32 and: [nArgs < 8]) ifTrue: 95685 [" 133 10000011 jjjkkkkk Send Literal Selector #kkkkk To Superclass With jjj Arguments" 95686 stream 95687 nextPut: 133; 95688 nextPut: ((nArgs bitShift: 5) + selectorLiteralIndex). 95689 ^self]. 95690 (selectorLiteralIndex < 256 and: [nArgs < 32]) ifTrue: 95691 ["In Squeak V3 95692 132 10000100 jjjjjjjj kkkkkkkk Send Literal Selector #kkkkkkkk With jjjjjjjj Arguments 95693 is replaced by 95694 132 10000100 ooojjjjj kkkkkkkk 95695 ooo = 0 => Send Literal Selector #kkkkkkkk With jjjjj Arguments 95696 ooo = 1 => Send Literal Selector #kkkkkkkk To Superclass With jjjjj Arguments" 95697 stream 95698 nextPut: 132; 95699 nextPut: 32 + nArgs; 95700 nextPut: selectorLiteralIndex. 95701 ^self]. 95702 nArgs >= 32 ifTrue: 95703 [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31]. 95704 selectorLiteralIndex >= 256 ifTrue: 95705 [^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]! ! 95706 95707!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:37'! 95708genStoreInstVar: instVarIndex 95709 "See BlueBook page 596" 95710 (instVarIndex >= 0 and: [instVarIndex < 64]) ifTrue: 95711 ["129 10000001 jjkkkkkk Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" 95712 stream 95713 nextPut: 129; 95714 nextPut: instVarIndex. 95715 ^self]. 95716 self genStoreInstVarLong: instVarIndex! ! 95717 95718!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:51'! 95719genStoreInstVarLong: instVarIndex 95720 "See BlueBook page 596" 95721 "See also MaybeContextInstanceVariableNode" 95722 (instVarIndex >= 0 and: [instVarIndex < 256]) ifTrue: 95723 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95724 stream 95725 nextPut: 132; 95726 nextPut: 160; 95727 nextPut: instVarIndex. 95728 ^self]. 95729 ^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 255! ! 95730 95731!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:01'! 95732genStoreLiteralVar: literalIndex 95733 "See BlueBook page 596" 95734 literalIndex < 0 ifTrue: 95735 [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. 95736 literalIndex < 64 ifTrue: 95737 ["129 10000001 jjkkkkkk Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" 95738 stream 95739 nextPut: 129; 95740 nextPut: 192 + literalIndex. 95741 ^self]. 95742 literalIndex < 256 ifTrue: 95743 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95744 stream 95745 nextPut: 132; 95746 nextPut: 224; 95747 nextPut: literalIndex. 95748 ^self]. 95749 ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! 95750 95751!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:43'! 95752genStorePopInstVar: instVarIndex 95753 "See BlueBook page 596" 95754 instVarIndex >= 0 ifTrue: 95755 [instVarIndex < 8 ifTrue: 95756 ["96-103 01100iii Pop and Store Receiver Variable #iii" 95757 stream nextPut: 96 + instVarIndex. 95758 ^self]. 95759 instVarIndex < 64 ifTrue: 95760 ["130 10000010 jjkkkkkk Pop and Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" 95761 stream 95762 nextPut: 130; 95763 nextPut: instVarIndex. 95764 ^self]]. 95765 self genStorePopInstVarLong: instVarIndex! ! 95766 95767!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:52'! 95768genStorePopInstVarLong: instVarIndex 95769 "See BlueBook page 596" 95770 "See also MaybeContextInstanceVariableNode" 95771 (instVarIndex >= 0 and: [instVarIndex < 256]) ifTrue: 95772 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95773 stream 95774 nextPut: 132; 95775 nextPut: 192; 95776 nextPut: instVarIndex. 95777 ^self]. 95778 ^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 255! ! 95779 95780!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:01'! 95781genStorePopLiteralVar: literalIndex 95782 "See BlueBook page 596" 95783 literalIndex < 0 ifTrue: 95784 [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. 95785 literalIndex < 64 ifTrue: 95786 ["130 10000010 jjkkkkkk Pop and Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" 95787 stream 95788 nextPut: 130; 95789 nextPut: 192 + literalIndex. 95790 ^self]. 95791 literalIndex < 256 ifTrue: 95792 ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" 95793 stream 95794 nextPut: 132; 95795 nextPut: 224; 95796 nextPut: literalIndex. 95797 self genPop. 95798 ^self]. 95799 ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! 95800 95801!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:01'! 95802genStorePopTemp: tempIndex 95803 "See BlueBook page 596" 95804 tempIndex < 0 ifTrue: 95805 [^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63]. 95806 tempIndex < 8 ifTrue: 95807 ["104-111 01101iii Pop and Store Temporary Location #iii" 95808 stream nextPut: 104 + tempIndex. 95809 ^self]. 95810 tempIndex < 64 ifTrue: 95811 ["130 10000010 jjkkkkkk Pop and Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" 95812 stream 95813 nextPut: 130; 95814 nextPut: 64 + tempIndex. 95815 ^self]. 95816 ^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63! ! 95817 95818!EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:01'! 95819genStoreTemp: tempIndex 95820 "See BlueBook page 596" 95821 tempIndex < 0 ifTrue: 95822 [^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63]. 95823 tempIndex < 64 ifTrue: 95824 ["129 10000001 jjkkkkkk Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" 95825 stream 95826 nextPut: 129; 95827 nextPut: 64 + tempIndex. 95828 ^self]. 95829 ^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63! ! 95830EncoderForV3 subclass: #EncoderForV3PlusClosures 95831 instanceVariableNames: '' 95832 classVariableNames: '' 95833 poolDictionaries: '' 95834 category: 'Compiler-Kernel'! 95835!EncoderForV3PlusClosures commentStamp: '<historical>' prior: 0! 95836An encoder for the V3 bytecode set augmented with the following bytecodes that are part of the full closure implementation. 95837 138 10001010 jkkkkkkk Push (Array new: kkkkkkk) (j = 0) 95838 or Pop kkkkkkk elements into: (Array new: kkkkkkk) (j = 1) 95839 95840 140 10001100 kkkkkkkk jjjjjjjj Push Temp At kkkkkkkk In Temp Vector At: jjjjjjjj 95841 141 10001101 kkkkkkkk jjjjjjjj Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj 95842 142 10001110 kkkkkkkk jjjjjjjj Pop and Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj 95843 143 10001111 llllkkkk jjjjjjjj iiiiiiii Push Closure Num Copied llll Num Args kkkk BlockSize jjjjjjjjiiiiiiii 95844This is an exact duplicate of EncoderForLongFormV3PlusClosures. 95845Could be a trait (or in Newspeak, a Mixin). 95846For now we impose upon you to synchronise any and all changes between these two classes.! 95847 95848 95849!EncoderForV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:11'! 95850genPushClosureCopyNumCopiedValues: numCopied numArgs: numArgs jumpSize: jumpSize 95851 "143 10001111 llllkkkk jjjjjjjj iiiiiiii Push Closure Num Copied llll Num Args kkkk BlockSize jjjjjjjjiiiiiiii" 95852 (jumpSize < 0 or: [jumpSize > 65535]) ifTrue: 95853 [^self outOfRangeError: 'block size' index: jumpSize range: 0 to: 65535]. 95854 (numCopied < 0 or: [numCopied > 15]) ifTrue: 95855 [^self outOfRangeError: 'num copied' index: numCopied range: 0 to: 15]. 95856 (numArgs < 0 or: [numArgs > 15]) ifTrue: 95857 [^self outOfRangeError: 'num args' index: numArgs range: 0 to: 15]. 95858 stream 95859 nextPut: 143; 95860 nextPut: numArgs + (numCopied bitShift: 4); 95861 nextPut: (jumpSize bitShift: -8); 95862 nextPut: (jumpSize bitAnd: 16rFF)! ! 95863 95864!EncoderForV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:03'! 95865genPushConsArray: size 95866 (size < 0 or: [size > 127]) ifTrue: 95867 [^self outOfRangeError: 'numElements' index: size range: 0 to: 127]. 95868 "138 10001010 1kkkkkkk Push (Array new: kkkkkkk)" 95869 stream 95870 nextPut: 138; 95871 nextPut: size + 128! ! 95872 95873!EncoderForV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:06'! 95874genPushNewArray: size 95875 (size < 0 or: [size > 127]) ifTrue: 95876 [^self outOfRangeError: 'numElements' index: size range: 0 to: 127]. 95877 "138 10001010 0kkkkkkk Pop kkkkkkk into: (Array new: kkkkkkk)" 95878 stream 95879 nextPut: 138; 95880 nextPut: size! ! 95881 95882!EncoderForV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 6/16/2008 09:45'! 95883genPushRemoteTemp: tempIndex inVectorAt: tempVectorIndex 95884 (tempIndex >= 0 and: [tempIndex < 256 95885 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: 95886 ["140 10001100 kkkkkkkk jjjjjjjj Push Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" 95887 stream 95888 nextPut: 140; 95889 nextPut: tempIndex; 95890 nextPut: tempVectorIndex. 95891 ^self]. 95892 tempIndex >= 256 ifTrue: 95893 [^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255]. 95894 tempVectorIndex >= 256 ifTrue: 95895 [^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 255]! ! 95896 95897!EncoderForV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:02'! 95898genStorePopRemoteTemp: tempIndex inVectorAt: tempVectorIndex 95899 "142 10001110 kkkkkkkk jjjjjjjj Pop and Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" 95900 (tempIndex >= 0 and: [tempIndex < 256 95901 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: 95902 [stream 95903 nextPut: 142; 95904 nextPut: tempIndex; 95905 nextPut: tempVectorIndex. 95906 ^self]. 95907 tempIndex >= 256 ifTrue: 95908 [^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255]. 95909 tempVectorIndex >= 256 ifTrue: 95910 [^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 255]! ! 95911 95912!EncoderForV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:02'! 95913genStoreRemoteTemp: tempIndex inVectorAt: tempVectorIndex 95914 "141 10001101 kkkkkkkk jjjjjjjj Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" 95915 (tempIndex >= 0 and: [tempIndex < 256 95916 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: 95917 [stream 95918 nextPut: 141; 95919 nextPut: tempIndex; 95920 nextPut: tempVectorIndex. 95921 ^self]. 95922 tempIndex >= 256 ifTrue: 95923 [^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255]. 95924 tempVectorIndex >= 256 ifTrue: 95925 [^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 255]! ! 95926 95927 95928!EncoderForV3PlusClosures methodsFor: 'testing' stamp: 'eem 5/24/2008 18:12'! 95929supportsClosureOpcodes 95930 ^true! ! 95931 95932"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 95933 95934EncoderForV3PlusClosures class 95935 instanceVariableNames: ''! 95936Error subclass: #EndOfStream 95937 instanceVariableNames: '' 95938 classVariableNames: '' 95939 poolDictionaries: '' 95940 category: 'Exceptions-Extensions'! 95941!EndOfStream commentStamp: '<historical>' prior: 0! 95942Signalled when ReadStream>>next encounters a premature end.! 95943 95944 95945!EndOfStream methodsFor: 'description' stamp: 'mir 9/25/2008 15:16'! 95946isResumable 95947 "EndOfStream is resumable, so ReadStream>>next can answer." 95948 95949 ^ true! ! 95950 95951 95952!EndOfStream methodsFor: 'exceptiondescription' stamp: 'RAA 5/17/2000 03:10'! 95953defaultAction 95954 "Answer ReadStream>>next default reply." 95955 95956 ^ nil! ! 95957PrototypeTester subclass: #EqualityTester 95958 instanceVariableNames: '' 95959 classVariableNames: '' 95960 poolDictionaries: '' 95961 category: 'SUnit-Utilities'! 95962!EqualityTester commentStamp: 'mjr 8/20/2003 13:04' prior: 0! 95963I provide a simple way to test the equality properties of any object.! 95964 95965 95966!EqualityTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! 95967resultFor: runs 95968 "Test that equality is the same over runs and answer the result" 95969 1 95970 to: runs 95971 do: [:i | self prototype = self prototype 95972 ifFalse: [^ false]]. 95973 ^ true! ! 95974Exception subclass: #Error 95975 instanceVariableNames: '' 95976 classVariableNames: '' 95977 poolDictionaries: '' 95978 category: 'Exceptions-Kernel'! 95979!Error commentStamp: '<historical>' prior: 0! 95980>From the ANSI standard: 95981This protocol describes the behavior of instances of class Error. These are used to represent error conditions that prevent the normal continuation of processing. Actual error exceptions used by an application may be subclasses of this class. 95982As Error is explicitly specified to be subclassable, conforming implementations must implement its behavior in a non-fragile manner. 95983 95984Additional notes: 95985Error>defaultAction uses an explicit test for the presence of the Debugger class to decide whether or not it is in development mode. In the future, TFEI hopes to enhance the semantics of #defaultAction to improve support for pluggable default handlers.! 95986 95987 95988!Error methodsFor: 'exceptiondescription' stamp: 'ajh 9/4/2002 19:24'! 95989defaultAction 95990 "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" 95991 95992 UnhandledError signalForException: self! ! 95993 95994 95995!Error methodsFor: 'private' stamp: 'ajh 2/1/2003 00:54'! 95996isResumable 95997 "Determine whether an exception is resumable." 95998 95999 ^ false! ! 96000MessageDialogWindow subclass: #ErrorDialogWindow 96001 instanceVariableNames: '' 96002 classVariableNames: '' 96003 poolDictionaries: '' 96004 category: 'Polymorph-Widgets-Windows'! 96005!ErrorDialogWindow commentStamp: 'gvc 5/18/2007 14:51' prior: 0! 96006A message dialog with an error icon.! 96007 96008 96009!ErrorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 14:52'! 96010icon 96011 "Answer an icon for the receiver." 96012 96013 ^self theme errorIcon! ! 96014 96015"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 96016 96017ErrorDialogWindow class 96018 instanceVariableNames: ''! 96019 96020!ErrorDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 11:54'! 96021taskbarIcon 96022 "Answer the icon for the receiver in a task bar." 96023 96024 ^self theme smallErrorIcon! ! 96025Object subclass: #EventHandler 96026 instanceVariableNames: 'mouseDownRecipient mouseDownSelector mouseMoveRecipient mouseMoveSelector mouseStillDownRecipient mouseStillDownSelector mouseUpRecipient mouseUpSelector mouseEnterRecipient mouseEnterSelector mouseLeaveRecipient mouseLeaveSelector mouseEnterDraggingRecipient mouseEnterDraggingSelector mouseLeaveDraggingRecipient mouseLeaveDraggingSelector keyStrokeRecipient keyStrokeSelector valueParameter startDragRecipient startDragSelector doubleClickSelector doubleClickRecipient doubleClickTimeoutSelector doubleClickTimeoutRecipient clickSelector clickRecipient' 96027 classVariableNames: '' 96028 poolDictionaries: '' 96029 category: 'Morphic-Events'! 96030!EventHandler commentStamp: '<historical>' prior: 0! 96031Events in Morphic originate in a Hand, pass to a target morph, and are then dispatched by an EventHandler. EventHandlers support redirection of mouse and keyboard activity by specifying and independent recipient object and message selector for each of the possible events. In addition each eventHandler can supply an optional value parameter for distinguishing between, eg, events from a number of otherwise identical source morphs. 96032 96033The basic protocol of an event handler is to receive a message of the form 96034 mouseDown: event in: targetMorph 96035and redirect this as one of 96036 mouseDownRecipient perform: mouseDownSelector0 96037 mouseDownRecipient perform: mouseDownSelector1 with: event 96038 mouseDownRecipient perform: mouseDownSelector2 with: event with: targetMorph 96039 mouseDownRecipient perform: mouseDownSelector3 with: event with: targetMorph with: valueParameter 96040depending on the arity of the mouseDownSelector. 96041! 96042 96043 96044!EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 17:33'! 96045allRecipients 96046 "Answer a list, without duplication, of all the objects serving as recipients to any of the events I handle. Intended for debugging/documentation use only" 96047 | aList | 96048 aList := OrderedCollection with: mouseDownRecipient with: mouseStillDownRecipient with: mouseUpRecipient with: mouseEnterRecipient with: mouseLeaveRecipient. 96049 aList addAll: (OrderedCollection with: mouseEnterDraggingRecipient with: mouseLeaveDraggingRecipient with: doubleClickRecipient with: keyStrokeRecipient). 96050 aList add: mouseMoveRecipient. 96051 ^ (aList copyWithout: nil) asSet asArray! ! 96052 96053!EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 17:34'! 96054firstMouseSelector 96055 "Answer the selector corresponding to the first mouse-handling selector fielded. Created in support of providing balloon-help for halo handles, triggered by the selector handled" 96056 96057 mouseDownSelector ifNotNil: [^ mouseDownSelector]. 96058 mouseMoveSelector ifNotNil:[^mouseMoveSelector]. 96059 mouseStillDownSelector ifNotNil: [^ mouseStillDownSelector]. 96060 mouseUpSelector ifNotNil: [^ mouseUpSelector]. 96061 mouseEnterSelector ifNotNil: [^ mouseEnterSelector]. 96062 mouseLeaveSelector ifNotNil: [^ mouseLeaveSelector]. 96063 mouseEnterDraggingSelector ifNotNil: [^ mouseEnterDraggingSelector]. 96064 mouseLeaveDraggingSelector ifNotNil: [^ mouseLeaveDraggingSelector]. 96065 doubleClickSelector ifNotNil: [^ doubleClickSelector]. 96066 ^ nil! ! 96067 96068!EventHandler methodsFor: 'access'! 96069messageList 96070 "Return a list of 'Class selector' for each message I can send. tk 96071 9/13/97" 96072 | list | 96073 self flag: #mref. 96074 "is this still needed? I replaced the one use that I could spot with 96075 #methodRefList " 96076 list := SortedCollection new. 96077 mouseDownRecipient 96078 ifNotNil: [list add: (mouseDownRecipient class whichClassIncludesSelector: mouseDownSelector) name , ' ' , mouseDownSelector]. 96079 mouseMoveRecipient 96080 ifNotNil: [list add: (mouseMoveRecipient class whichClassIncludesSelector: mouseMoveSelector) name , ' ' , mouseMoveSelector]. 96081 mouseStillDownRecipient 96082 ifNotNil: [list add: (mouseStillDownRecipient class whichClassIncludesSelector: mouseStillDownSelector) name , ' ' , mouseStillDownSelector]. 96083 mouseUpRecipient 96084 ifNotNil: [list add: (mouseUpRecipient class whichClassIncludesSelector: mouseUpSelector) name , ' ' , mouseUpSelector]. 96085 mouseEnterRecipient 96086 ifNotNil: [list add: (mouseEnterRecipient class whichClassIncludesSelector: mouseEnterSelector) name , ' ' , mouseEnterSelector]. 96087 mouseLeaveRecipient 96088 ifNotNil: [list add: (mouseLeaveRecipient class whichClassIncludesSelector: mouseLeaveSelector) name , ' ' , mouseLeaveSelector]. 96089 mouseEnterDraggingRecipient 96090 ifNotNil: [list add: (mouseEnterDraggingRecipient class whichClassIncludesSelector: mouseEnterDraggingSelector) name , ' ' , mouseEnterDraggingSelector]. 96091 mouseLeaveDraggingRecipient 96092 ifNotNil: [list add: (mouseLeaveDraggingRecipient class whichClassIncludesSelector: mouseLeaveDraggingSelector) name , ' ' , mouseLeaveDraggingSelector]. 96093 doubleClickRecipient 96094 ifNotNil: [list add: (doubleClickRecipient class whichClassIncludesSelector: doubleClickSelector) name , ' ' , doubleClickSelector]. 96095 keyStrokeRecipient 96096 ifNotNil: [list add: (keyStrokeRecipient class whichClassIncludesSelector: keyStrokeSelector) name , ' ' , keyStrokeSelector]. 96097 ^ list! ! 96098 96099!EventHandler methodsFor: 'access'! 96100methodRefList 96101 "Return a MethodReference for each message I can send. tk 9/13/97, raa 96102 5/29/01 " 96103 | list adder | 96104 list := SortedCollection new. 96105 adder := [:recip :sel | recip 96106 ifNotNil: [list 96107 add: (MethodReference new 96108 setStandardClass: (recip class whichClassIncludesSelector: sel) 96109 methodSymbol: sel)]]. 96110 adder value: mouseDownRecipient value: mouseDownSelector. 96111 adder value: mouseMoveRecipient value: mouseMoveSelector. 96112 adder value: mouseStillDownRecipient value: mouseStillDownSelector. 96113 adder value: mouseUpRecipient value: mouseUpSelector. 96114 adder value: mouseEnterRecipient value: mouseEnterSelector. 96115 adder value: mouseLeaveRecipient value: mouseLeaveSelector. 96116 adder value: mouseEnterDraggingRecipient value: mouseEnterDraggingSelector. 96117 adder value: mouseLeaveDraggingRecipient value: mouseLeaveDraggingSelector. 96118 adder value: doubleClickRecipient value: doubleClickSelector. 96119 adder value: keyStrokeRecipient value: keyStrokeSelector. 96120 ^ list! ! 96121 96122!EventHandler methodsFor: 'access' stamp: 'di 9/14/1998 08:32'! 96123mouseDownSelector 96124 ^ mouseDownSelector! ! 96125 96126!EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 18:27'! 96127mouseStillDownRecipient 96128 ^mouseStillDownRecipient! ! 96129 96130!EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 18:27'! 96131mouseStillDownSelector 96132 ^mouseStillDownSelector! ! 96133 96134!EventHandler methodsFor: 'access' stamp: 'di 9/14/1998 08:32'! 96135mouseUpSelector 96136 ^ mouseUpSelector! ! 96137 96138 96139!EventHandler methodsFor: 'copying' stamp: 'tk 1/22/2001 17:43'! 96140veryDeepFixupWith: deepCopier 96141 | old | 96142 "ALL inst vars were weakly copied. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 96143 96144super veryDeepFixupWith: deepCopier. 961451 to: self class instSize do: 96146 [:ii | old := self instVarAt: ii. 96147 self instVarAt: ii put: (deepCopier references at: old ifAbsent: [old])]. 96148 96149! ! 96150 96151!EventHandler methodsFor: 'copying' stamp: 'nk 2/14/2004 18:24'! 96152veryDeepInner: deepCopier 96153 "ALL fields are weakly copied!! Can't duplicate an object by duplicating a button that activates it. See DeepCopier." 96154 96155 super veryDeepInner: deepCopier. 96156 "just keep old pointers to all fields" 96157! 96158]style[(25 108 10 78)f1b,f1,f1LDeepCopier Comment;,f1! ! 96159 96160 96161!EventHandler methodsFor: 'events' stamp: 'ar 10/7/2000 22:55'! 96162click: event fromMorph: sourceMorph 96163 "This message is sent only when double clicks are handled." 96164 ^ self 96165 send: clickSelector 96166 to: clickRecipient 96167 withEvent: event 96168 fromMorph: sourceMorph! ! 96169 96170!EventHandler methodsFor: 'events' stamp: 'LC 2/14/2000 08:38'! 96171doubleClick: event fromMorph: sourceMorph 96172 ^ self 96173 send: doubleClickSelector 96174 to: doubleClickRecipient 96175 withEvent: event 96176 fromMorph: sourceMorph! ! 96177 96178!EventHandler methodsFor: 'events' stamp: 'jcg 9/21/2001 13:06'! 96179doubleClickTimeout: event fromMorph: sourceMorph 96180 ^ self 96181 send: doubleClickTimeoutSelector 96182 to: doubleClickTimeoutRecipient 96183 withEvent: event 96184 fromMorph: sourceMorph! ! 96185 96186!EventHandler methodsFor: 'events'! 96187keyStroke: event fromMorph: sourceMorph 96188 ^ self send: keyStrokeSelector to: keyStrokeRecipient withEvent: event fromMorph: sourceMorph! ! 96189 96190!EventHandler methodsFor: 'events' stamp: 'ar 10/7/2000 22:54'! 96191mouseDown: event fromMorph: sourceMorph 96192 "Take double-clicks into account." 96193 ((self handlesClickOrDrag: event) and:[event redButtonPressed]) ifTrue:[ 96194 event hand waitForClicksOrDrag: sourceMorph event: event. 96195 ]. 96196 ^self 96197 send: mouseDownSelector 96198 to: mouseDownRecipient 96199 withEvent: event 96200 fromMorph: sourceMorph. 96201! ! 96202 96203!EventHandler methodsFor: 'events'! 96204mouseEnter: event fromMorph: sourceMorph 96205 ^ self send: mouseEnterSelector to: mouseEnterRecipient withEvent: event fromMorph: sourceMorph! ! 96206 96207!EventHandler methodsFor: 'events' stamp: 'di 9/15/1998 16:35'! 96208mouseEnterDragging: event fromMorph: sourceMorph 96209 ^ self send: mouseEnterDraggingSelector to: mouseEnterDraggingRecipient withEvent: event fromMorph: sourceMorph! ! 96210 96211!EventHandler methodsFor: 'events'! 96212mouseLeave: event fromMorph: sourceMorph 96213 ^ self send: mouseLeaveSelector to: mouseLeaveRecipient withEvent: event fromMorph: sourceMorph! ! 96214 96215!EventHandler methodsFor: 'events' stamp: 'di 9/15/1998 16:35'! 96216mouseLeaveDragging: event fromMorph: sourceMorph 96217 ^ self send: mouseLeaveDraggingSelector to: mouseLeaveDraggingRecipient withEvent: event fromMorph: sourceMorph! ! 96218 96219!EventHandler methodsFor: 'events' stamp: 'ar 10/25/2000 17:32'! 96220mouseMove: event fromMorph: sourceMorph 96221 ^ self send: mouseMoveSelector to: mouseMoveRecipient withEvent: event fromMorph: sourceMorph! ! 96222 96223!EventHandler methodsFor: 'events'! 96224mouseStillDown: event fromMorph: sourceMorph 96225 ^ self send: mouseStillDownSelector to: mouseStillDownRecipient withEvent: event fromMorph: sourceMorph! ! 96226 96227!EventHandler methodsFor: 'events'! 96228mouseUp: event fromMorph: sourceMorph 96229 ^ self send: mouseUpSelector to: mouseUpRecipient withEvent: event fromMorph: sourceMorph! ! 96230 96231!EventHandler methodsFor: 'events' stamp: 'ar 3/17/2001 14:34'! 96232send: selector to: recipient withEvent: event fromMorph: sourceMorph 96233 | arity | 96234 recipient ifNil: [^ self]. 96235 arity := selector numArgs. 96236 arity = 0 ifTrue: 96237 [^ recipient perform: selector]. 96238 arity = 1 ifTrue: 96239 [^ recipient perform: selector with: event]. 96240 arity = 2 ifTrue: 96241 [^ recipient perform: selector with: event with: sourceMorph]. 96242 arity = 3 ifTrue: 96243 [^ recipient perform: selector with: valueParameter with: event with: sourceMorph]. 96244 self error: 'Event handling selectors must be Symbols and take 0-3 arguments'! ! 96245 96246!EventHandler methodsFor: 'events' stamp: 'mir 5/23/2000 17:43'! 96247startDrag: event fromMorph: sourceMorph 96248 ^ self 96249 send: startDragSelector 96250 to: startDragRecipient 96251 withEvent: event 96252 fromMorph: sourceMorph! ! 96253 96254 96255!EventHandler methodsFor: 'fixups' stamp: 'stephane.ducasse 11/18/2008 21:50'! 96256fixReversedValueMessages 96257 "ar 3/18/2001: Due to the change in the ordering of the value parameter old event handlers may have messages that need to be fixed up. Do this here." 96258 96259 self replaceSendsIn: #( renameCharAction:sourceMorph:requestor: makeGetter:from:forPart: makeSetter:from:forPart: clickOnLine:evt:envelope: limitHandleMoveEvent:from:index: mouseUpEvent:linkMorph:formData: mouseUpEvent:linkMorph:browserAndUrl: mouseDownEvent:noteMorph:pitch: mouseMoveEvent:noteMorph:pitch: mouseUpEvent:noteMorph:pitch: dragVertex:fromHandle:vertIndex: dropVertex:fromHandle:vertIndex: newVertex:fromHandle:afterVert: prefMenu:rcvr:pref: event:arrow:upDown:) 96260 with: #( renameCharAction:event:sourceMorph: makeGetter:event:from: makeSetter:event:from: clickOn:evt:from: limitHandleMove:event:from: mouseUpFormData:event:linkMorph: mouseUpBrowserAndUrl:event:linkMorph: mouseDownPitch:event:noteMorph: mouseMovePitch:event:noteMorph: mouseUpPitch:event:noteMorph: dragVertex:event:fromHandle: dropVertex:event:fromHandle: newVertex:event:fromHandle: prefMenu:event:rcvr: upDown:event:arrow:). 96261 96262"sw 3/28/2001 extended Andreas's original lists by one item"! ! 96263 96264!EventHandler methodsFor: 'fixups' stamp: 'ar 3/18/2001 17:18'! 96265replaceSendsIn: array1 with: array2 96266 "Replace all the sends that occur in array1 with those in array2. Used for fixing old event handlers in files." 96267 | old index | 96268 1 to: self class instSize do:[:i| 96269 old := self instVarAt: i. 96270 index := array1 identityIndexOf: old. 96271 index > 0 ifTrue:[self instVarAt: i put: (array2 at: index)]].! ! 96272 96273 96274!EventHandler methodsFor: 'initialization' stamp: 'nk 2/15/2004 08:16'! 96275on: eventName send: selector to: recipient 96276 eventName == #mouseDown ifTrue: 96277 [mouseDownRecipient := recipient. mouseDownSelector := selector. ^ self]. 96278 eventName == #mouseMove ifTrue: 96279 [mouseMoveRecipient := recipient. mouseMoveSelector := selector. ^ self]. 96280 eventName == #mouseStillDown ifTrue: 96281 [mouseStillDownRecipient := recipient. mouseStillDownSelector := selector. ^ self]. 96282 eventName == #mouseUp ifTrue: 96283 [mouseUpRecipient := recipient. mouseUpSelector := selector. ^ self]. 96284 eventName == #mouseEnter ifTrue: 96285 [mouseEnterRecipient := recipient. mouseEnterSelector := selector. ^ self]. 96286 eventName == #mouseLeave ifTrue: 96287 [mouseLeaveRecipient := recipient. mouseLeaveSelector := selector. ^ self]. 96288 eventName == #mouseEnterDragging ifTrue: 96289 [mouseEnterDraggingRecipient := recipient. mouseEnterDraggingSelector := selector. ^ self]. 96290 eventName == #mouseLeaveDragging ifTrue: 96291 [mouseLeaveDraggingRecipient := recipient. mouseLeaveDraggingSelector := selector. ^ self]. 96292 eventName == #click ifTrue: 96293 [clickRecipient := recipient. clickSelector := selector. ^ self]. 96294 eventName == #doubleClick ifTrue: 96295 [doubleClickRecipient := recipient. doubleClickSelector := selector. ^ self]. 96296 eventName == #doubleClickTimeout ifTrue: 96297 [doubleClickTimeoutRecipient := recipient. doubleClickTimeoutSelector := selector. ^ self]. 96298 eventName == #startDrag ifTrue: 96299 [startDragRecipient := recipient. startDragSelector := selector. ^ self]. 96300 eventName == #keyStroke ifTrue: 96301 [keyStrokeRecipient := recipient. keyStrokeSelector := selector. ^ self]. 96302 eventName == #gesture ifTrue: 96303 [ ^self onGestureSend: selector to: recipient ]. 96304 self error: 'Event name, ' , eventName , ' is not recognizable.' 96305! ! 96306 96307!EventHandler methodsFor: 'initialization' stamp: 'wiz 8/21/2005 01:44'! 96308on: eventName send: selector to: recipient withValue: value 96309 selector numArgs = 3 ifFalse: 96310 [self halt: 'Warning: value parameters are passed as first of 3 arguments']. 96311 self on: eventName send: selector to: recipient. 96312 valueParameter := value 96313! ! 96314 96315!EventHandler methodsFor: 'initialization' stamp: 'nk 2/15/2004 08:59'! 96316onGestureSend: selector to: recipient! ! 96317 96318 96319!EventHandler methodsFor: 'printing' stamp: 'dgd 2/22/2003 18:40'! 96320printOn: aStream 96321 | aVal recipients | 96322 super printOn: aStream. 96323 #('mouseDownSelector' 'mouseStillDownSelector' 'mouseUpSelector' 'mouseEnterSelector' 'mouseLeaveSelector' 'mouseEnterDraggingSelector' 'mouseLeaveDraggingSelector' 'doubleClickSelector' 'keyStrokeSelector') 96324 do: 96325 [:aName | 96326 (aVal := self instVarNamed: aName) notNil 96327 ifTrue: [aStream nextPutAll: '; ' , aName , '=' , aVal]]. 96328 (recipients := self allRecipients) notEmpty 96329 ifTrue: 96330 [aStream nextPutAll: ' recipients: '. 96331 recipients printOn: aStream]! ! 96332 96333 96334!EventHandler methodsFor: 'testing' stamp: 'ar 10/7/2000 22:56'! 96335handlesClickOrDrag: evt 96336 clickRecipient ifNotNil:[^true]. 96337 doubleClickRecipient ifNotNil:[^true]. 96338 startDragRecipient ifNotNil:[^true]. 96339 ^false! ! 96340 96341!EventHandler methodsFor: 'testing' stamp: 'nk 2/15/2004 08:57'! 96342handlesGestureStart: evt 96343 "Does the associated morph want to handle gestures?" 96344 ^false! ! 96345 96346!EventHandler methodsFor: 'testing' stamp: 'ar 10/28/2000 22:17'! 96347handlesKeyboard: evt 96348 keyStrokeRecipient ifNotNil: [^ true]. 96349 ^ false! ! 96350 96351!EventHandler methodsFor: 'testing' stamp: 'nk 2/15/2004 08:13'! 96352handlesMouseDown: evt 96353 mouseDownRecipient ifNotNil: [^ true]. 96354 mouseStillDownRecipient ifNotNil: [^ true]. 96355 mouseUpRecipient ifNotNil: [^ true]. 96356 (self handlesClickOrDrag: evt) ifTrue:[^true]. 96357 ^self handlesGestureStart: evt! ! 96358 96359!EventHandler methodsFor: 'testing' stamp: 'ar 10/25/2000 17:33'! 96360handlesMouseMove: evt 96361 ^mouseMoveRecipient notNil and:[mouseMoveSelector notNil]! ! 96362 96363!EventHandler methodsFor: 'testing'! 96364handlesMouseOver: evt 96365 mouseEnterRecipient ifNotNil: [^ true]. 96366 mouseLeaveRecipient ifNotNil: [^ true]. 96367 ^ false! ! 96368 96369!EventHandler methodsFor: 'testing' stamp: 'di 9/15/1998 16:35'! 96370handlesMouseOverDragging: evt 96371 mouseEnterDraggingRecipient ifNotNil: [^ true]. 96372 mouseLeaveDraggingRecipient ifNotNil: [^ true]. 96373 ^ false! ! 96374 96375!EventHandler methodsFor: 'testing' stamp: 'ar 10/22/2000 17:05'! 96376handlesMouseStillDown: evt 96377 ^mouseStillDownRecipient notNil and:[mouseStillDownSelector notNil]! ! 96378EventHandler subclass: #EventHandlerPlus 96379 instanceVariableNames: 'mouseOverRecipient mouseOverSelector' 96380 classVariableNames: '' 96381 poolDictionaries: '' 96382 category: 'Polymorph-Widgets'! 96383!EventHandlerPlus commentStamp: 'gvc 5/18/2007 13:13' prior: 0! 96384Support for handling mouseOver events (no button down).! 96385 96386 96387!EventHandlerPlus methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 17:19'! 96388handlesMouseOver: evt 96389 "Answer whether we can handle the event." 96390 96391 mouseOverRecipient ifNotNil: [^ true]. 96392 ^super handlesMouseOver: evt! ! 96393 96394!EventHandlerPlus methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 17:23'! 96395methodRefList 96396 "Return a MethodReference for each message I can send." 96397 96398 |list adder| 96399 list := super methodRefList. 96400 adder := [:recip :sel | recip 96401 ifNotNil: [list 96402 add: (MethodReference new 96403 setStandardClass: (recip class whichClassIncludesSelector: sel) 96404 methodSymbol: sel)]]. 96405 adder value: mouseOverRecipient value: mouseOverSelector. 96406 ^list! ! 96407 96408!EventHandlerPlus methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 17:20'! 96409mouseOver: event fromMorph: sourceMorph 96410 "Relay the event." 96411 96412 ^ self send: mouseOverSelector to: mouseOverRecipient withEvent: event fromMorph: sourceMorph! ! 96413 96414!EventHandlerPlus methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 17:24'! 96415on: eventName send: selector to: recipient 96416 "Register the selector and recipient for the given event name." 96417 96418 eventName == #mouseOver ifTrue: 96419 [mouseOverRecipient := recipient. mouseOverSelector := selector. ^ self]. 96420 ^super on: eventName send: selector to: recipient! ! 96421Object subclass: #EventManager 96422 instanceVariableNames: 'actionMap' 96423 classVariableNames: 'ActionMaps' 96424 poolDictionaries: '' 96425 category: 'System-Object Events'! 96426!EventManager commentStamp: 'tlk 5/7/2006 20:01' prior: 0! 96427An EventManager is used to registers a 'observer' object's interest in in changes to an 'observed' object. Then when the observered object is changed, EventManager broadcasts the an update message to all objects with a registered interest. Finally, the Event manager can be used to remove an object from the list of observer object. 96428 96429An interested object is said to be a dependant on the target object. Registering an interest in an event is called adding a dependant. Deregistering is called removing a dependant. The EventManager's action map is a WeakIdentityDictionary that maps events (selectors) to dependants (objects & selectors) in a way that ensures the mapping is to specific objects (hence identity) and in a way that allows the object to be garbage collected if not other used (hence weak.) EventManager class has ActionMaps which has one actionMap for each object. 96430 96431Classic uses of an EventManager are to implement the Observer Pattern, see ChangeNotification or the MorphicModle as examples.! 96432 96433 96434!EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:37'! 96435actionMap 96436 96437 ^actionMap == nil 96438 ifTrue: [self createActionMap] 96439 ifFalse: [actionMap]! ! 96440 96441!EventManager methodsFor: 'accessing' stamp: 'reThink 3/3/2001 10:07'! 96442changedEventSelector 96443 96444 ^#changed:! ! 96445 96446!EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:39'! 96447releaseActionMap 96448 96449 actionMap := nil! ! 96450 96451!EventManager methodsFor: 'accessing' stamp: 'reThink 3/3/2001 10:07'! 96452updateEventSelector 96453 96454 ^#update:! ! 96455 96456!EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:38'! 96457updateableActionMap 96458 96459 actionMap == nil 96460 ifTrue: [actionMap := self createActionMap]. 96461 ^actionMap! ! 96462 96463 96464!EventManager methodsFor: 'copying' stamp: 'reThink 3/3/2001 10:22'! 96465copy 96466 96467 | answer | 96468 answer := super copy. 96469 answer release. 96470 ^answer! ! 96471 96472 96473!EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:07'! 96474addDependent: anObject 96475 "Make the given object one of the receiver's dependents." 96476 96477 self 96478 when: self changedEventSelector 96479 send: self updateEventSelector 96480 to: anObject. 96481 ^anObject! ! 96482 96483!EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:07'! 96484breakDependents 96485 "Remove all of the receiver's dependents." 96486 96487 self removeActionsForEvent: self changedEventSelector! ! 96488 96489!EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:18'! 96490dependents 96491 96492 ^(self actionSequenceForEvent: self changedEventSelector) asSet 96493 collect: 96494 [:each | each receiver]! ! 96495 96496!EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:07'! 96497removeDependent: anObject 96498 "Remove the given object as one of the receiver's dependents." 96499 96500 self 96501 removeActionsWithReceiver: anObject 96502 forEvent: self changedEventSelector. 96503 ^ anObject! ! 96504 96505 96506!EventManager methodsFor: 'updating' stamp: 'reThink 3/3/2001 10:20'! 96507changed: aParameter 96508 "Receiver changed. The change is denoted by the argument aParameter. 96509 Usually the argument is a Symbol that is part of the dependent's change 96510 protocol. Inform all of the dependents." 96511 96512 self 96513 triggerEvent: self changedEventSelector 96514 with: aParameter! ! 96515 96516"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 96517 96518EventManager class 96519 instanceVariableNames: ''! 96520 96521!EventManager class methodsFor: 'accessing' stamp: 'reThink 2/18/2001 14:42'! 96522actionMapFor: anObject 96523 96524 ^self actionMaps 96525 at: anObject 96526 ifAbsent: [self createActionMap]! ! 96527 96528!EventManager class methodsFor: 'accessing' stamp: 'rww 10/2/2001 07:20'! 96529actionMaps 96530 96531 ActionMaps == nil 96532 ifTrue: [ActionMaps := WeakIdentityKeyDictionary new]. 96533 ^ActionMaps! ! 96534 96535!EventManager class methodsFor: 'accessing' stamp: 'reThink 2/25/2001 08:52'! 96536updateableActionMapFor: anObject 96537 96538 ^self actionMaps 96539 at: anObject 96540 ifAbsentPut: [self createActionMap]! ! 96541 96542 96543!EventManager class methodsFor: 'initialization' stamp: 'rw 2/10/2002 13:09'! 96544flushEvents 96545 "Object flushEvents" 96546 | msgSet | 96547 self actionMaps keysAndValuesDo:[:rcvr :evtDict| rcvr ifNotNil:[ 96548 "make sure we don't modify evtDict while enumerating" 96549 evtDict keys do:[:evtName| 96550 msgSet := evtDict at: evtName ifAbsent:[nil]. 96551 (msgSet == nil) ifTrue:[rcvr removeActionsForEvent: evtName]]]]. 96552 EventManager actionMaps finalizeValues. ! ! 96553 96554 96555!EventManager class methodsFor: 'releasing' stamp: 'reThink 2/18/2001 15:34'! 96556releaseActionMapFor: anObject 96557 96558 self actionMaps 96559 removeKey: anObject 96560 ifAbsent: []! ! 96561ClassTestCase subclass: #EventManagerTest 96562 instanceVariableNames: 'eventSource eventListener succeeded' 96563 classVariableNames: '' 96564 poolDictionaries: '' 96565 category: 'Tests-Object Events'! 96566 96567!EventManagerTest methodsFor: 'running' stamp: 'JWS 9/7/2000 17:19'! 96568setUp 96569 96570 super setUp. 96571 eventSource := EventManager new. 96572 eventListener := Bag new. 96573 succeeded := false! ! 96574 96575!EventManagerTest methodsFor: 'running' stamp: 'jws 11/28/2000 16:25'! 96576tearDown 96577 96578 eventSource releaseActionMap. 96579 eventSource := nil. 96580 eventListener := nil. 96581 super tearDown. 96582! ! 96583 96584 96585!EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:21'! 96586testMultipleValueSuppliers 96587 96588 eventSource 96589 when: #needsValue 96590 send: #getFalse 96591 to: self. 96592 eventSource 96593 when: #needsValue 96594 send: #getTrue 96595 to: self. 96596 succeeded := eventSource triggerEvent: #needsValue. 96597 self should: [succeeded]! ! 96598 96599!EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:21'! 96600testMultipleValueSuppliersEventHasArguments 96601 96602 eventSource 96603 when: #needsValue: 96604 send: #getFalse: 96605 to: self. 96606 eventSource 96607 when: #needsValue: 96608 send: #getTrue: 96609 to: self. 96610 succeeded := eventSource triggerEvent: #needsValue: with: 'kolme'. 96611 self should: [succeeded]! ! 96612 96613!EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:22'! 96614testNoValueSupplier 96615 96616 succeeded := eventSource 96617 triggerEvent: #needsValue 96618 ifNotHandled: [true]. 96619 self should: [succeeded]! ! 96620 96621!EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:22'! 96622testNoValueSupplierHasArguments 96623 96624 succeeded := eventSource 96625 triggerEvent: #needsValue: 96626 with: 'nelja' 96627 ifNotHandled: [true]. 96628 self should: [succeeded]! ! 96629 96630!EventManagerTest methodsFor: 'running-broadcast query' stamp: 'jws 11/28/2000 15:52'! 96631testSingleValueSupplier 96632 96633 eventSource 96634 when: #needsValue 96635 send: #getTrue 96636 to: self. 96637 succeeded := eventSource triggerEvent: #needsValue. 96638 self should: [succeeded]! ! 96639 96640 96641!EventManagerTest methodsFor: 'running-copying' stamp: 'SqR 11/12/2000 19:38'! 96642testCopy 96643 "Ensure that the actionMap is zapped when 96644 you make a copy of anEventManager" 96645 96646 eventSource when: #blah send: #yourself to: eventListener. 96647 self assert: eventSource actionMap keys isEmpty not. 96648 self assert: eventSource copy actionMap keys isEmpty! ! 96649 96650 96651!EventManagerTest methodsFor: 'running-dependent action' stamp: 'ar 8/26/2009 21:37'! 96652testBlockReceiverNoArgs 96653 eventSource when: #anEvent evaluate:[self heardEvent]. 96654 eventSource triggerEvent: #anEvent. 96655 self should: [succeeded]! ! 96656 96657!EventManagerTest methodsFor: 'running-dependent action' stamp: 'ar 8/26/2009 21:37'! 96658testBlockReceiverOneArg 96659 eventSource when: #anEvent: evaluate:[:arg1| eventListener add: arg1]. 96660 eventSource triggerEvent: #anEvent: with: 9. 96661 self should: [eventListener includes: 9]! ! 96662 96663!EventManagerTest methodsFor: 'running-dependent action' stamp: 'ar 8/26/2009 21:38'! 96664testBlockReceiverTwoArgs 96665 eventSource when: #anEvent:info: evaluate:[:arg1 :arg2| self addArg1: arg1 addArg2: arg2]. 96666 eventSource triggerEvent: #anEvent:info: withArguments: #( 9 42 ). 96667 self should: [(eventListener includes: 9) and: [eventListener includes: 42]]! ! 96668 96669!EventManagerTest methodsFor: 'running-dependent action' stamp: 'jws 9/7/2000 16:39'! 96670testNoArgumentEvent 96671 96672 eventSource when: #anEvent send: #heardEvent to: self. 96673 eventSource triggerEvent: #anEvent. 96674 self should: [succeeded]! ! 96675 96676!EventManagerTest methodsFor: 'running-dependent action' stamp: 'JWS 9/7/2000 17:20'! 96677testOneArgumentEvent 96678 96679 eventSource when: #anEvent: send: #add: to: eventListener. 96680 eventSource triggerEvent: #anEvent: with: 9. 96681 self should: [eventListener includes: 9]! ! 96682 96683!EventManagerTest methodsFor: 'running-dependent action' stamp: 'JWS 9/7/2000 17:20'! 96684testTwoArgumentEvent 96685 96686 eventSource when: #anEvent:info: send: #addArg1:addArg2: to: self. 96687 eventSource triggerEvent: #anEvent:info: withArguments: #( 9 42 ). 96688 self should: [(eventListener includes: 9) and: [eventListener includes: 42]]! ! 96689 96690 96691!EventManagerTest methodsFor: 'running-dependent action supplied arguments' stamp: 'JWS 9/7/2000 17:20'! 96692testNoArgumentEventDependentSuppliedArgument 96693 96694 eventSource when: #anEvent send: #add: to: eventListener with: 'boundValue'. 96695 eventSource triggerEvent: #anEvent. 96696 self should: [eventListener includes: 'boundValue']! ! 96697 96698!EventManagerTest methodsFor: 'running-dependent action supplied arguments' stamp: 'JWS 9/7/2000 17:21'! 96699testNoArgumentEventDependentSuppliedArguments 96700 96701 eventSource 96702 when: #anEvent 96703 send: #addArg1:addArg2: 96704 to: self 96705 withArguments: #('hello' 'world'). 96706 eventSource triggerEvent: #anEvent. 96707 self should: [(eventListener includes: 'hello') and: [eventListener includes: 'world']]! ! 96708 96709 96710!EventManagerTest methodsFor: 'running-dependent value' stamp: 'JWS 9/7/2000 17:21'! 96711testReturnValueWithManyListeners 96712 96713 | value newListener | 96714 newListener := 'busybody'. 96715 eventSource 96716 when: #needsValue 96717 send: #yourself 96718 to: eventListener. 96719 eventSource 96720 when: #needsValue 96721 send: #yourself 96722 to: newListener. 96723 value := eventSource triggerEvent: #needsValue. 96724 self should: [value == newListener]! ! 96725 96726!EventManagerTest methodsFor: 'running-dependent value' stamp: 'JWS 9/7/2000 17:21'! 96727testReturnValueWithNoListeners 96728 96729 | value | 96730 value := eventSource triggerEvent: #needsValue. 96731 self should: [value == nil]! ! 96732 96733!EventManagerTest methodsFor: 'running-dependent value' stamp: 'JWS 9/7/2000 17:21'! 96734testReturnValueWithOneListener 96735 96736 | value | 96737 eventSource 96738 when: #needsValue 96739 send: #yourself 96740 to: eventListener. 96741 value := eventSource triggerEvent: #needsValue. 96742 self should: [value == eventListener]! ! 96743 96744 96745!EventManagerTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:01'! 96746testRemoveActionsForEvent 96747 96748 eventSource 96749 when: #anEvent send: #size to: eventListener; 96750 when: #anEvent send: #getTrue to: self; 96751 when: #anEvent: send: #fizzbin to: self. 96752 eventSource removeActionsForEvent: #anEvent. 96753 self shouldnt: [eventSource hasActionForEvent: #anEvent]! ! 96754 96755!EventManagerTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:01'! 96756testRemoveActionsTwiceForEvent 96757 96758 eventSource 96759 when: #anEvent send: #size to: eventListener; 96760 when: #anEvent send: #getTrue to: self; 96761 when: #anEvent: send: #fizzbin to: self. 96762 eventSource removeActionsForEvent: #anEvent. 96763 self assert: (eventSource hasActionForEvent: #anEvent) not. 96764 eventSource removeActionsForEvent: #anEvent. 96765 self assert: (eventSource hasActionForEvent: #anEvent) not.! ! 96766 96767!EventManagerTest methodsFor: 'running-remove actions' stamp: 'gk 8/14/2007 23:51'! 96768testRemoveActionsWithReceiver 96769 96770 | action | 96771 eventSource 96772 when: #anEvent send: #size to: eventListener; 96773 when: #anEvent send: #getTrue to: self; 96774 when: #anEvent: send: #fizzbin to: self. 96775 self assert: (eventSource hasActionsWithReceiver: self). 96776 eventSource removeActionsWithReceiver: self. 96777 action := eventSource actionForEvent: #anEvent. 96778 self assert: (action respondsTo: #receiver). 96779 self assert: ((action receiver == self) not). 96780 self assert: ((eventSource hasActionsWithReceiver: self) not)! ! 96781 96782 96783!EventManagerTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:37'! 96784addArg1: arg1 96785addArg2: arg2 96786 96787 eventListener 96788 add: arg1; 96789 add: arg2! ! 96790 96791!EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! 96792getFalse 96793 96794 ^false! ! 96795 96796!EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! 96797getFalse: anArg 96798 96799 ^false! ! 96800 96801!EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! 96802getTrue 96803 96804 ^true! ! 96805 96806!EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! 96807getTrue: anArg 96808 96809 ^true! ! 96810 96811!EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:20'! 96812heardEvent 96813 96814 succeeded := true! ! 96815InputSensor subclass: #EventSensor 96816 instanceVariableNames: 'mouseButtons mousePosition keyboardBuffer interruptKey interruptSemaphore eventQueue inputSemaphore lastEventPoll hasInputSemaphore' 96817 classVariableNames: 'EventPollPeriod EventTicklerProcess' 96818 poolDictionaries: 'EventSensorConstants' 96819 category: 'Kernel-Processes'! 96820!EventSensor commentStamp: 'nk 4/13/2004 11:18' prior: 0! 96821EventSensor is a replacement for InputSensor based on a set of (optional) event primitives. An EventSensor updates its state when events are received so that all state based users of Sensor (e.g., Sensor keyboard, Sensor leftShiftDown, Sensor mouseButtons) will work exactly as before, by moving the current VM mechanisms into EventSensor itself. An optional input semaphore is part of the new design. 96822 96823For platforms that support true asynchronous event notification, the semaphore will be signaled to indicate pending events. 96824On platforms that do not support asynchronous notifications about events, the UI will have to poll EventSensor periodically to read events from the VM. 96825 96826Instance variables: 96827 mouseButtons <Integer> - mouse button state as replacement for primMouseButtons 96828 mousePosition <Point> - mouse position as replacement for primMousePt 96829 keyboardBuffer <SharedQueue> - keyboard input buffer 96830 interruptKey <Integer> - currently defined interrupt key 96831 interruptSemaphore <Semaphore> - the semaphore signaled when the interruptKey is detected 96832 eventQueue <SharedQueue> - an optional event queue for event driven applications 96833 inputSemaphore <Semaphore>- the semaphore signaled by the VM if asynchronous event notification is supported 96834 lastEventPoll <Integer> - the last millisecondClockValue at which we called fetchMoreEvents 96835 hasInputSemaphore <Boolean> - true if my inputSemaphore has actually been signaled at least once. 96836 96837Class variables: 96838 EventPollPeriod <Integer> - the number of milliseconds to wait between polling for more events in the userInterruptHandler. 96839 EventTicklerProcess <Process> - the process that makes sure that events are polled for often enough (at least every EventPollPeriod milliseconds). 96840 96841Event format: 96842The current event format is very simple. Each event is recorded into an 8 element array. All events must provide some SmallInteger ID (the first field in the event buffer) and a time stamp (the second field in the event buffer), so that the difference between the time stamp of an event and the current time can be reported. 96843 96844Currently, the following events are defined: 96845 96846Null event 96847============= 96848The Null event is returned when the ST side asks for more events but no more events are available. 96849Structure: 96850[1] - event type 0 96851[2-8] - unused 96852 96853Mouse event structure 96854========================== 96855Mouse events are generated when mouse input is detected. 96856Structure: 96857[1] - event type 1 96858[2] - time stamp 96859[3] - mouse x position 96860[4] - mouse y position 96861[5] - button state; bitfield with the following entries: 96862 1 - yellow (e.g., right) button 96863 2 - blue (e.g., middle) button 96864 4 - red (e.g., left) button 96865 [all other bits are currently undefined] 96866[6] - modifier keys; bitfield with the following entries: 96867 1 - shift key 96868 2 - ctrl key 96869 4 - (Mac specific) option key 96870 8 - Cmd/Alt key 96871 [all other bits are currently undefined] 96872[7] - reserved. 96873[8] - reserved. 96874 96875Keyboard events 96876==================== 96877Keyboard events are generated when keyboard input is detected. 96878[1] - event type 2 96879[2] - time stamp 96880[3] - character code 96881 For now the character code is in Mac Roman encoding. 96882[4] - press state; integer with the following meaning 96883 0 - character 96884 1 - key press (down) 96885 2 - key release (up) 96886[5] - modifier keys (same as in mouse events) 96887[6] - reserved. 96888[7] - reserved. 96889[8] - reserved. 96890! 96891 96892 96893!EventSensor methodsFor: 'accessing' stamp: 'ar 7/23/2000 14:37'! 96894eventQueue 96895 "Return the current event queue" 96896 ^eventQueue! ! 96897 96898!EventSensor methodsFor: 'accessing' stamp: 'nk 4/12/2004 19:36'! 96899eventTicklerProcess 96900 "Answer my event tickler process, if any" 96901 ^EventTicklerProcess! ! 96902 96903!EventSensor methodsFor: 'accessing' stamp: 'JMM 10/5/2001 13:46'! 96904flushAllButDandDEvents 96905 | newQueue oldQueue | 96906 96907 newQueue := SharedQueue new. 96908 self eventQueue ifNil: 96909 [self eventQueue: newQueue. 96910 ^self]. 96911 oldQueue := self eventQueue. 96912 [oldQueue size > 0] whileTrue: 96913 [| item type | 96914 item := oldQueue next. 96915 type := item at: 1. 96916 type = EventTypeDragDropFiles ifTrue: [ newQueue nextPut: item]]. 96917 self eventQueue: newQueue. 96918! ! 96919 96920!EventSensor methodsFor: 'accessing' stamp: 'ar 2/7/2001 17:13'! 96921flushEvents 96922 eventQueue ifNotNil:[eventQueue flush].! ! 96923 96924!EventSensor methodsFor: 'accessing' stamp: 'marcus.denker 9/14/2008 22:00'! 96925nextEvent 96926 "Return the next event from the receiver." 96927 eventQueue 96928 ifNil:[^self nextEventSynthesized] 96929 ifNotNil:[^self nextEventFromQueue] 96930! ! 96931 96932!EventSensor methodsFor: 'accessing' stamp: 'JMM 11/7/2005 14:38'! 96933peekButtons 96934 self wait2ms. 96935 self fetchMoreEvents. 96936 ^mouseButtons! ! 96937 96938!EventSensor methodsFor: 'accessing' stamp: 'JMM 1/15/2007 11:21'! 96939peekEvent 96940 "Look ahead at the next event." 96941 self fetchMoreEvents. 96942 ^self eventQueue peek! ! 96943 96944!EventSensor methodsFor: 'accessing' stamp: 'tpr 1/5/2005 17:34'! 96945peekKeyboardEvent 96946 "Return the next keyboard char event from the receiver or nil if none available" 96947 ^eventQueue nextOrNilSuchThat: 96948 [:buf | 96949 buf first = EventTypeKeyboard and: [(buf fourth) = EventKeyChar]]! ! 96950 96951!EventSensor methodsFor: 'accessing' stamp: 'ar 2/8/2001 21:45'! 96952peekMousePt 96953 ^mousePosition! ! 96954 96955!EventSensor methodsFor: 'accessing' stamp: 'JMM 11/7/2005 14:38'! 96956peekPosition 96957 self wait2ms. 96958 self fetchMoreEvents. 96959 ^mousePosition! ! 96960 96961 96962!EventSensor methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:52'! 96963initialize 96964 "Initialize the receiver" 96965 super initialize. 96966 mouseButtons := 0. 96967 mousePosition := 0 @ 0. 96968 keyboardBuffer := SharedQueue new. 96969 eventQueue := SharedQueue new. 96970 self setInterruptKey: (interruptKey ifNil: [$. asciiValue bitOr: 16r0800 ]). "cmd-." 96971 interruptSemaphore := (Smalltalk specialObjectsArray at: 31) ifNil: [Semaphore new]. 96972 self flushAllButDandDEvents. 96973 inputSemaphore := Semaphore new. 96974 hasInputSemaphore := false.! ! 96975 96976!EventSensor methodsFor: 'initialize' stamp: 'nk 4/12/2004 20:13'! 96977shutDown 96978 super shutDown. 96979 EventTicklerProcess ifNotNil: [ 96980 EventTicklerProcess terminate. 96981 EventTicklerProcess := nil. ]. 96982 inputSemaphore ifNotNil:[Smalltalk unregisterExternalObject: inputSemaphore]. 96983! ! 96984 96985!EventSensor methodsFor: 'initialize' stamp: 'pavel.krivanek 11/21/2008 16:54'! 96986startUp 96987 "Run the I/O process" 96988 self initialize. 96989 self 96990 primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore). 96991 super startUp. 96992 self installEventTickler. 96993 UIManager default onEventSensorStartup: self.. 96994 "Attempt to discover whether the input semaphore is actually being 96995 signaled. " 96996 hasInputSemaphore := false. 96997 inputSemaphore initSignals! ! 96998 96999 97000!EventSensor methodsFor: 'mouse' stamp: 'ar 5/18/2003 18:27'! 97001createMouseEvent 97002 "create and return a new mouse event from the current mouse 97003 position; this is useful for restarting normal event queue 97004 processing after manual polling" 97005 97006 | buttons modifiers pos mapped eventBuffer | 97007 eventBuffer := Array new: 8. 97008 buttons := self primMouseButtons. 97009 pos := self primMousePt. 97010 modifiers := buttons bitShift: -3. 97011 buttons := buttons bitAnd: 7. 97012 mapped := self mapButtons: buttons modifiers: modifiers. 97013 eventBuffer 97014 at: 1 97015 put: EventTypeMouse; 97016 at: 2 put: Time millisecondClockValue; 97017 at: 3 put: pos x; 97018 at: 4 put: pos y; 97019 at: 5 put: mapped; 97020 at: 6 put: modifiers. 97021 ^ eventBuffer! ! 97022 97023 97024!EventSensor methodsFor: 'private' stamp: 'nk 4/12/2004 20:16'! 97025eventTickler 97026 "Poll infrequently to make sure that the UI process is not been stuck. 97027 If it has been stuck, then spin the event loop so that I can detect the 97028 interrupt key." 97029 | delay | 97030 delay := Delay forMilliseconds: self class eventPollPeriod. 97031 self lastEventPoll. "ensure not nil." 97032 [| delta | 97033 [ delay wait. 97034 delta := Time millisecondClockValue - lastEventPoll. 97035 (delta < 0 97036 or: [delta > self class eventPollPeriod]) 97037 ifTrue: ["force check on rollover" 97038 self fetchMoreEvents]] on: Error do: [:ex | ]. 97039 true ] whileTrue.! ! 97040 97041!EventSensor methodsFor: 'private' stamp: 'di 10/1/2001 20:52'! 97042flushNonKbdEvents 97043 eventQueue ifNil: [^ self]. 97044 eventQueue flushAllSuchThat: 97045 [:buf | (self isKbdEvent: buf) not] 97046! ! 97047 97048!EventSensor methodsFor: 'private' stamp: 'nk 6/21/2004 10:40'! 97049installEventTickler 97050 "Initialize the interrupt watcher process. Terminate the old process if any." 97051 "Sensor installEventTickler" 97052 97053 EventTicklerProcess ifNotNil: [EventTicklerProcess terminate]. 97054 EventTicklerProcess := [self eventTickler] forkAt: Processor lowIOPriority. 97055! ! 97056 97057!EventSensor methodsFor: 'private' stamp: 'di 10/1/2001 20:51'! 97058isKbdEvent: buf 97059 ^ (buf at: 1) = EventTypeKeyboard and: [(buf at: 4) = EventKeyChar]! ! 97060 97061!EventSensor methodsFor: 'private' stamp: 'nk 3/18/2004 13:21'! 97062lastEventPoll 97063 "Answer the last clock value at which fetchMoreEvents was called." 97064 ^lastEventPoll ifNil: [ lastEventPoll := Time millisecondClockValue ]! ! 97065 97066!EventSensor methodsFor: 'private' stamp: 'JMM 7/22/2004 14:08'! 97067nextEventFromQueue 97068 "Return the next event from the receiver." 97069 self eventQueue isEmpty ifTrue:[self fetchMoreEvents]. 97070 self eventQueue isEmpty 97071 ifTrue:[^nil] 97072 ifFalse:[^self eventQueue next]! ! 97073 97074!EventSensor methodsFor: 'private' stamp: 'nk 3/17/2004 07:09'! 97075nextEventSynthesized 97076 "Return a synthesized event. This method is called if an event driven client wants to receive events but the primary user interface is not event-driven (e.g., the receiver does not have an event queue but only updates its state). This can, for instance, happen if a Morphic World is run in an MVC window. To simplify the clients work this method will always return all available keyboard events first, and then (repeatedly) the mouse events. Since mouse events come last, the client can assume that after one mouse event has been received there are no more to come. Note that it is impossible for EventSensor to determine if a mouse event has been issued before so the client must be aware of the possible problem of getting repeatedly the same mouse events. See HandMorph>>processEvents for an example on how to deal with this." 97077 | kbd array buttons pos modifiers mapped | 97078 "First check for keyboard" 97079 array := Array new: 8. 97080 kbd := self primKbdNext. 97081 kbd ifNotNil: 97082 ["simulate keyboard event" 97083 array at: 1 put: EventTypeKeyboard. "evt type" 97084 array at: 2 put: Time millisecondClockValue. "time stamp" 97085 array at: 3 put: (kbd bitAnd: 255). "char code" 97086 array at: 4 put: EventKeyChar. "key press/release" 97087 array at: 5 put: (kbd bitShift: -8). "modifier keys" 97088 ^ array]. 97089 97090 "Then check for mouse" 97091 pos := self primMousePt. 97092 buttons := mouseButtons. 97093 modifiers := buttons bitShift: -3. 97094 buttons := buttons bitAnd: 7. 97095 mapped := self mapButtons: buttons modifiers: modifiers. 97096 array 97097 at: 1 put: EventTypeMouse; 97098 at: 2 put: Time millisecondClockValue; 97099 at: 3 put: pos x; 97100 at: 4 put: pos y; 97101 at: 5 put: mapped; 97102 at: 6 put: modifiers. 97103 ^ array 97104 97105! ! 97106 97107!EventSensor methodsFor: 'private' stamp: 'ar 7/23/2000 00:34'! 97108primInterruptSemaphore: aSemaphore 97109 "Primitive. Install the argument as the semaphore to be signalled whenever the user presses the interrupt key. The semaphore will be signaled once each time the interrupt key is pressed." 97110 interruptSemaphore := aSemaphore. 97111 "backward compatibility: use the old primitive which is obsolete now" 97112 super primInterruptSemaphore: aSemaphore! ! 97113 97114!EventSensor methodsFor: 'private' stamp: 'michael.rueger 2/5/2009 13:59'! 97115primKbdNext 97116 "Allows for use of old Sensor protocol to get at the keyboard, 97117 as when running kbdTest or the InterpreterSimulator in Morphic" 97118 | evtBuf | 97119 self wait2ms. 97120 self fetchMoreEvents. 97121 keyboardBuffer isEmpty ifFalse:[^ keyboardBuffer next]. 97122 evtBuf := self eventQueue nextOrNilSuchThat: [:buf | self isKbdEvent: buf]. 97123 self flushNonKbdEvents. 97124 ^ evtBuf ifNotNil: [evtBuf at: 6]! ! 97125 97126!EventSensor methodsFor: 'private' stamp: 'michael.rueger 2/5/2009 13:59'! 97127primKbdPeek 97128 "Allows for use of old Sensor protocol to get at the keyboard, 97129 as when running kbdTest or the InterpreterSimulator in Morphic" 97130 | char | 97131 self wait2ms. 97132 self fetchMoreEvents. 97133 keyboardBuffer isEmpty ifFalse: [^ keyboardBuffer peek]. 97134 char := nil. 97135 self eventQueue nextOrNilSuchThat: "NOTE: must not return out of this block, so loop to end" 97136 [:buf | (self isKbdEvent: buf) ifTrue: [char ifNil: [char := buf at: 6]]. 97137 false "NOTE: block value must be false so Queue won't advance"]. 97138 ^ char! ! 97139 97140!EventSensor methodsFor: 'private' stamp: 'JMM 11/7/2005 14:39'! 97141primMouseButtons 97142 self wait2ms. 97143 self fetchMoreEvents. 97144 self flushNonKbdEvents. 97145 ^ mouseButtons! ! 97146 97147!EventSensor methodsFor: 'private' stamp: 'JMM 11/7/2005 14:39'! 97148primMousePt 97149 self wait2ms. 97150 self fetchMoreEvents. 97151 self flushNonKbdEvents. 97152 ^ mousePosition! ! 97153 97154!EventSensor methodsFor: 'private' stamp: 'ls 10/23/2000 14:14'! 97155primSetInterruptKey: anInteger 97156 "Primitive. Register the given keycode as the user interrupt key. The low byte of the keycode is the ISO character and its next four bits are the Smalltalk modifer bits <cmd><opt><ctrl><shift>." 97157 interruptKey := anInteger. 97158 "backward compatibility: use the old primitive which is obsolete now" 97159 super primSetInterruptKey: anInteger! ! 97160 97161!EventSensor methodsFor: 'private' stamp: 'JMM 11/7/2005 14:37'! 97162wait2ms 97163 (Delay forMilliseconds: 2) wait.! ! 97164 97165 97166!EventSensor methodsFor: 'private-I/O' stamp: 'nk 4/12/2004 20:01'! 97167fetchMoreEvents 97168 "Fetch more events from the VM" 97169 | eventBuffer type | 97170 97171 "Reset input semaphore so clients can wait for the next events after this one." 97172 inputSemaphore isSignaled 97173 ifTrue: [ hasInputSemaphore := true. 97174 inputSemaphore initSignals ]. 97175 97176 "Remember the last time that I checked for events." 97177 lastEventPoll := Time millisecondClockValue. 97178 97179 eventBuffer := Array new: 8. 97180 [self primGetNextEvent: eventBuffer. 97181 type := eventBuffer at: 1. 97182 type = EventTypeNone] 97183 whileFalse: [self processEvent: eventBuffer]. 97184! ! 97185 97186!EventSensor methodsFor: 'private-I/O' stamp: 'ar 7/30/2000 18:12'! 97187mapButtons: buttons modifiers: modifiers 97188 "Map the buttons to yellow or blue based on the given modifiers. 97189 If only the red button is pressed, then map 97190 Ctrl-RedButton -> BlueButton. 97191 Cmd-RedButton -> YellowButton. 97192 " 97193 (buttons = RedButtonBit) 97194 ifFalse:[^buttons]. 97195 (modifiers allMask: CtrlKeyBit) 97196 ifTrue:[^BlueButtonBit]. 97197 (modifiers allMask: CommandKeyBit) 97198 ifTrue:[^YellowButtonBit]. 97199 ^buttons! ! 97200 97201!EventSensor methodsFor: 'private-I/O' stamp: 'marcus.denker 9/14/2008 21:15'! 97202primGetNextEvent: array 97203 "Store the next OS event available into the provided array. 97204 Essential. If the VM is not event driven the ST code will fall 97205 back to the old-style mechanism and use the state based 97206 primitives instead." 97207 | kbd buttons modifiers pos mapped | 97208 <primitive: 94> 97209 "Simulate the events" 97210 array at: 1 put: EventTypeNone. "assume no more events" 97211 97212 "First check for keyboard" 97213 kbd := super primKbdNext. 97214 kbd isNil ifFalse:[ 97215 "simulate keyboard event" 97216 array at: 1 put: EventTypeKeyboard. "evt type" 97217 array at: 2 put: Time millisecondClockValue. "time stamp" 97218 array at: 3 put: (kbd bitAnd: 255). "char code" 97219 array at: 4 put: EventKeyChar. "key press/release" 97220 array at: 5 put: (kbd bitShift: -8). "modifier keys" 97221 ^self]. 97222 97223 "Then check for mouse" 97224 buttons := super primMouseButtons. 97225 pos := super primMousePt. 97226 modifiers := buttons bitShift: -3. 97227 buttons := buttons bitAnd: 7. 97228 mapped := self mapButtons: buttons modifiers: modifiers. 97229 (pos = mousePosition and:[(mapped bitOr: (modifiers bitShift: 3)) = mouseButtons]) 97230 ifTrue:[^self]. 97231 array 97232 at: 1 put: EventTypeMouse; 97233 at: 2 put: Time millisecondClockValue; 97234 at: 3 put: pos x; 97235 at: 4 put: pos y; 97236 at: 5 put: mapped; 97237 at: 6 put: modifiers. 97238! ! 97239 97240!EventSensor methodsFor: 'private-I/O' stamp: 'ar 7/30/2000 18:16'! 97241primSetInputSemaphore: semaIndex 97242 "Set the input semaphore the VM should use for asynchronously signaling the availability of events. Primitive. Optional." 97243 <primitive: 93> 97244 ^nil! ! 97245 97246!EventSensor methodsFor: 'private-I/O' stamp: 'JMM 1/15/2007 13:10'! 97247processEvent: evt 97248 "Process a single event. This method is run at high priority." 97249 | type window | 97250 type := evt at: 1. 97251 97252 97253 window := evt at: 8. 97254 (window isNil or: [window isZero]) ifTrue: 97255 [window := 1. 97256 evt at: 8 put: window]. 97257 window := evt at: 8. 97258 (window isNil or: [window isZero]) ifTrue: 97259 [window := 1. 97260 evt at: 8 put: window]. 97261 97262 97263 "Tackle mouse events first" 97264 type = EventTypeMouse 97265 ifTrue: [evt 97266 at: 5 97267 put: (ButtonDecodeTable at: (evt at: 5) 97268 + 1). 97269 self queueEvent: evt. 97270 self processMouseEvent: evt . 97271 ^self]. 97272 97273 97274 "Store the event in the queue if there's any" 97275 type = EventTypeKeyboard 97276 ifTrue: [ "Check if the event is a user interrupt" 97277 ((evt at: 4) = 0 97278 and: [((evt at: 3) 97279 bitOr: (((evt at: 5) 97280 bitAnd: 8) 97281 bitShift: 8)) 97282 = interruptKey]) 97283 ifTrue: ["interrupt key is meta - not reported as event" 97284 ^ interruptSemaphore signal]. 97285 "Else swap ctrl/alt keys if neeeded.wi" 97286 KeyDecodeTable 97287 at: {evt at: 3. evt at: 5} 97288 ifPresent: [:a | evt at: 3 put: a first; 97289 at: 5 put: a second]. 97290 self queueEvent: evt. 97291 self processKeyboardEvent: evt . 97292 ^self ]. 97293 97294 97295 EventTypeWindow = type ifTrue: 97296 [self processWindowEvent: evt. 97297 ^self]. 97298 97299 EventTypeMenu = type ifTrue: 97300 [self processMenuEvent: evt. 97301 ^self]. 97302 97303 "Handle all events other than Keyborad or Mouse." 97304 self queueEvent: evt. 97305 ! ! 97306 97307!EventSensor methodsFor: 'private-I/O' stamp: 'marcus.denker 9/14/2008 21:15'! 97308processKeyboardEvent: evt 97309 "process a keyboard event, updating InputSensor state" 97310 | charCode pressCode | 97311 "Never update keyboardBuffer if we have an eventQueue active" 97312 mouseButtons := (mouseButtons bitAnd: 7) bitOr: ((evt at: 5) bitShift: 3). 97313 eventQueue ifNotNil:[^self]. 97314 charCode := evt at: 3. 97315 charCode isNil ifTrue:[^self]. "extra characters not handled in MVC" 97316 pressCode := evt at: 4. 97317 pressCode = EventKeyChar ifFalse:[^self]. "key down/up not handled in MVC" 97318 "mix in modifiers" 97319 charCode := charCode bitOr: ((evt at: 5) bitShift: 8). 97320 keyboardBuffer nextPut: charCode.! ! 97321 97322!EventSensor methodsFor: 'private-I/O' stamp: 'JMM 11/12/2004 14:12'! 97323processMenuEvent: evt 97324 | handler localCopyOfEvt | 97325 97326 localCopyOfEvt := evt clone. 97327 handler := (HostSystemMenus 97328 defaultMenuBarForWindowIndex: (localCopyOfEvt at: 8)) 97329 getHandlerForMenu: (localCopyOfEvt at: 3) item: (localCopyOfEvt at: 4). 97330 [[handler handler value: localCopyOfEvt] ifError: [:err :rcvr | ]] forkAt: Processor activePriority.! ! 97331 97332!EventSensor methodsFor: 'private-I/O' stamp: 'ar 8/16/2000 22:07'! 97333processMouseEvent: evt 97334 "process a mouse event, updating InputSensor state" 97335 | modifiers buttons mapped | 97336 mousePosition := (evt at: 3) @ (evt at: 4). 97337 buttons := evt at: 5. 97338 modifiers := evt at: 6. 97339 mapped := self mapButtons: buttons modifiers: modifiers. 97340 mouseButtons := mapped bitOr: (modifiers bitShift: 3).! ! 97341 97342!EventSensor methodsFor: 'private-I/O' stamp: 'JMM 10/4/2004 17:41'! 97343processWindowEvent: evt 97344! ! 97345 97346!EventSensor methodsFor: 'private-I/O' stamp: 'ar 7/23/2000 14:55'! 97347queueEvent: evt 97348 "Queue the given event in the event queue (if any). 97349 Note that the event buffer must be copied since it 97350 will be reused later on." 97351 eventQueue ifNil:[^self]. 97352 eventQueue nextPut: evt clone.! ! 97353 97354"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 97355 97356EventSensor class 97357 instanceVariableNames: ''! 97358 97359!EventSensor class methodsFor: 'class initialization' stamp: 'nk 4/12/2004 18:55'! 97360eventPollPeriod 97361 ^EventPollPeriod ifNil: [ EventPollPeriod := 500 ].! ! 97362 97363!EventSensor class methodsFor: 'class initialization' stamp: 'nk 4/12/2004 18:55'! 97364eventPollPeriod: msec 97365 "Set the number of milliseconds between checking for events to msec." 97366 97367 EventPollPeriod := msec max: 10.! ! 97368 97369!EventSensor class methodsFor: 'class initialization' stamp: 'ar 7/23/2000 15:06'! 97370install "EventSensor install" 97371 "Install an EventSensor in place of the current Sensor." 97372 | newSensor | 97373 Sensor shutDown. 97374 newSensor := self new. 97375 newSensor startUp. 97376 "Note: We must use #become: here to replace all references to the old sensor with the new one, since Sensor is referenced from all the existing controllers." 97377 Sensor becomeForward: newSensor. "done"! ! 97378SharedPool subclass: #EventSensorConstants 97379 instanceVariableNames: '' 97380 classVariableNames: 'BlueButtonBit CommandKeyBit CtrlKeyBit EventKeyChar EventKeyDown EventKeyUp EventTypeDragDropFiles EventTypeKeyboard EventTypeMenu EventTypeMouse EventTypeNone EventTypeWindow OptionKeyBit RedButtonBit ShiftKeyBit WindowEventActivated WindowEventClose WindowEventIconise WindowEventMetricChange WindowEventPaint YellowButtonBit' 97381 poolDictionaries: '' 97382 category: 'Kernel-Processes'! 97383 97384"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 97385 97386EventSensorConstants class 97387 instanceVariableNames: ''! 97388 97389!EventSensorConstants class methodsFor: 'pool initialization' stamp: 'John M McIntosh 10/31/2008 14:34'! 97390initialize 97391 "EventSensorConstants initialize" 97392 RedButtonBit := 4. 97393 BlueButtonBit := 2. 97394 YellowButtonBit := 1. 97395 97396 ShiftKeyBit := 1. 97397 CtrlKeyBit := 2. 97398 OptionKeyBit := 4. 97399 CommandKeyBit := 8. 97400 97401 "Types of events" 97402 EventTypeNone := 0. 97403 EventTypeMouse := 1. 97404 EventTypeKeyboard := 2. 97405 EventTypeDragDropFiles := 3. 97406 EventTypeMenu := 4. 97407 EventTypeWindow := 5. 97408 97409 "Press codes for keyboard events" 97410 EventKeyChar := 0. 97411 EventKeyDown := 1. 97412 EventKeyUp := 2. 97413 97414 "Window event action codes" 97415 WindowEventMetricChange := 1. " size or position of window changed - value1-4 are left/top/right/bottom values " 97416 WindowEventClose := 2. " window close icon pressed " 97417 WindowEventIconise := 3. " window iconised or hidden etc " 97418 WindowEventActivated :=4. " window made active - some platforms only - do not rely upon this " 97419 WindowEventPaint := 5. " window area (in value1-4) needs updating. Some platforms do not need to send this, do not rely on it in image " 97420! ! 97421TestCase subclass: #EventTest 97422 instanceVariableNames: 'eventSource eventListener succeeded' 97423 classVariableNames: '' 97424 poolDictionaries: '' 97425 category: 'Tests-Object Events'! 97426 97427!EventTest methodsFor: 'running' stamp: 'jws 9/7/2000 16:37'! 97428setUp 97429 97430 super setUp. 97431 eventSource := Object new. 97432 eventListener := Bag new. 97433 succeeded := false! ! 97434 97435!EventTest methodsFor: 'running' stamp: 'jws 11/28/2000 16:25'! 97436tearDown 97437 97438 eventSource releaseActionMap. 97439 eventSource := nil. 97440 eventListener := nil. 97441 super tearDown. 97442! ! 97443 97444 97445!EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:41'! 97446testMultipleValueSuppliers 97447 97448 eventSource 97449 when: #needsValue 97450 send: #getFalse 97451 to: self. 97452 eventSource 97453 when: #needsValue 97454 send: #getTrue 97455 to: self. 97456 succeeded := eventSource triggerEvent: #needsValue. 97457 self should: [succeeded]! ! 97458 97459!EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:41'! 97460testMultipleValueSuppliersEventHasArguments 97461 97462 eventSource 97463 when: #needsValue: 97464 send: #getFalse: 97465 to: self. 97466 eventSource 97467 when: #needsValue: 97468 send: #getTrue: 97469 to: self. 97470 succeeded := eventSource triggerEvent: #needsValue: with: 'kolme'. 97471 self should: [succeeded]! ! 97472 97473!EventTest methodsFor: 'running-broadcast query' stamp: 'marcus.denker 9/14/2008 21:15'! 97474testMultipleValueSuppliersEventHasArgumentsWithGC 97475 97476 eventSource 97477 when: #needsValue: 97478 send: #getFalse: 97479 to: self 97480 with: Object new. 97481 eventSource 97482 when: #needsValue: 97483 send: #getTrue: 97484 to: self 97485 with: Object new. 97486 Smalltalk garbageCollectMost. 97487 succeeded := eventSource triggerEvent: #needsValue: with: 'kolme'. 97488 self should: [succeeded isNil] 97489! ! 97490 97491!EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:41'! 97492testNoValueSupplier 97493 97494 succeeded := eventSource 97495 triggerEvent: #needsValue 97496 ifNotHandled: [true]. 97497 self should: [succeeded]! ! 97498 97499!EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:41'! 97500testNoValueSupplierHasArguments 97501 97502 succeeded := eventSource 97503 triggerEvent: #needsValue: 97504 with: 'nelja' 97505 ifNotHandled: [true]. 97506 self should: [succeeded]! ! 97507 97508!EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:42'! 97509testSingleValueSupplier 97510 97511 eventSource 97512 when: #needsValue 97513 send: #getTrue 97514 to: self. 97515 succeeded := eventSource triggerEvent: #needsValue. 97516 self should: [succeeded]! ! 97517 97518 97519!EventTest methodsFor: 'running-dependent action' stamp: 'jws 9/7/2000 16:39'! 97520testNoArgumentEvent 97521 97522 eventSource when: #anEvent send: #heardEvent to: self. 97523 eventSource triggerEvent: #anEvent. 97524 self should: [succeeded]! ! 97525 97526!EventTest methodsFor: 'running-dependent action' stamp: 'jws 9/7/2000 16:39'! 97527testOneArgumentEvent 97528 97529 eventSource when: #anEvent: send: #add: to: eventListener. 97530 eventSource triggerEvent: #anEvent: with: 9. 97531 self should: [eventListener includes: 9]! ! 97532 97533!EventTest methodsFor: 'running-dependent action' stamp: 'jws 9/7/2000 16:39'! 97534testTwoArgumentEvent 97535 97536 eventSource when: #anEvent:info: send: #addArg1:addArg2: to: self. 97537 eventSource triggerEvent: #anEvent:info: withArguments: #( 9 42 ). 97538 self should: [(eventListener includes: 9) and: [eventListener includes: 42]]! ! 97539 97540 97541!EventTest methodsFor: 'running-dependent action supplied arguments' stamp: 'jws 9/7/2000 16:39'! 97542testNoArgumentEventDependentSuppliedArgument 97543 97544 eventSource when: #anEvent send: #add: to: eventListener with: 'boundValue'. 97545 eventSource triggerEvent: #anEvent. 97546 self should: [eventListener includes: 'boundValue']! ! 97547 97548!EventTest methodsFor: 'running-dependent action supplied arguments' stamp: 'jws 9/7/2000 16:40'! 97549testNoArgumentEventDependentSuppliedArguments 97550 97551 eventSource 97552 when: #anEvent 97553 send: #addArg1:addArg2: 97554 to: self 97555 withArguments: #('hello' 'world'). 97556 eventSource triggerEvent: #anEvent. 97557 self should: [(eventListener includes: 'hello') and: [eventListener includes: 'world']]! ! 97558 97559 97560!EventTest methodsFor: 'running-dependent value' stamp: 'jws 9/7/2000 16:40'! 97561testReturnValueWithManyListeners 97562 97563 | value newListener | 97564 newListener := 'busybody'. 97565 eventSource 97566 when: #needsValue 97567 send: #yourself 97568 to: eventListener. 97569 eventSource 97570 when: #needsValue 97571 send: #yourself 97572 to: newListener. 97573 value := eventSource triggerEvent: #needsValue. 97574 self should: [value == newListener]! ! 97575 97576!EventTest methodsFor: 'running-dependent value' stamp: 'jws 9/7/2000 16:40'! 97577testReturnValueWithNoListeners 97578 97579 | value | 97580 value := eventSource triggerEvent: #needsValue. 97581 self should: [value == nil]! ! 97582 97583!EventTest methodsFor: 'running-dependent value' stamp: 'jws 9/7/2000 16:40'! 97584testReturnValueWithOneListener 97585 97586 | value | 97587 eventSource 97588 when: #needsValue 97589 send: #yourself 97590 to: eventListener. 97591 value := eventSource triggerEvent: #needsValue. 97592 self should: [value == eventListener]! ! 97593 97594 97595!EventTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:04'! 97596testRemoveActionsForEvent 97597 97598 eventSource 97599 when: #anEvent send: #size to: eventListener; 97600 when: #anEvent send: #getTrue to: self; 97601 when: #anEvent: send: #fizzbin to: self. 97602 eventSource removeActionsForEvent: #anEvent. 97603 self shouldnt: [eventSource hasActionForEvent: #anEvent]! ! 97604 97605!EventTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:05'! 97606testRemoveActionsTwiceForEvent 97607 97608 eventSource 97609 when: #anEvent send: #size to: eventListener; 97610 when: #anEvent send: #getTrue to: self; 97611 when: #anEvent: send: #fizzbin to: self. 97612 eventSource removeActionsForEvent: #anEvent. 97613 self assert: (eventSource hasActionForEvent: #anEvent) not. 97614 eventSource removeActionsForEvent: #anEvent. 97615 self assert: (eventSource hasActionForEvent: #anEvent) not.! ! 97616 97617!EventTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:05'! 97618testRemoveActionsWithReceiver 97619 97620 | action | 97621 eventSource 97622 when: #anEvent send: #size to: eventListener; 97623 when: #anEvent send: #getTrue to: self; 97624 when: #anEvent: send: #fizzbin to: self. 97625 eventSource removeActionsWithReceiver: self. 97626 action := eventSource actionForEvent: #anEvent. 97627 self assert: (action respondsTo: #receiver). 97628 self assert: ((action receiver == self) not)! ! 97629 97630 97631!EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:37'! 97632addArg1: arg1 97633addArg2: arg2 97634 97635 eventListener 97636 add: arg1; 97637 add: arg2! ! 97638 97639!EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:37'! 97640getFalse 97641 97642 ^false! ! 97643 97644!EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:37'! 97645getFalse: anArg 97646 97647 ^false! ! 97648 97649!EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:38'! 97650getTrue 97651 97652 ^true! ! 97653 97654!EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:38'! 97655getTrue: anArg 97656 97657 ^true! ! 97658 97659!EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:38'! 97660heardEvent 97661 97662 succeeded := true! ! 97663MorphicModel subclass: #ExampleBuilderMorph 97664 uses: TEasilyThemed 97665 instanceVariableNames: '' 97666 classVariableNames: '' 97667 poolDictionaries: '' 97668 category: 'Polymorph-Widgets'! 97669!ExampleBuilderMorph commentStamp: 'gvc 7/19/2007 16:49' prior: 0! 97670Morph with an inset border by default and theme access. Overrides openModal: to allow multiple free example dialogs to be presented.! 97671 97672 97673!ExampleBuilderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/11/2007 16:53'! 97674openModal: aSystemWindow 97675 "Open the given window an available position without modality. 97676 Answer the system window." 97677 97678 |baseArea areas searching foundRect| 97679 aSystemWindow extent: aSystemWindow initialExtent. 97680 areas := World submorphs 97681 select: [:m | m isKindOf: DialogWindow] 97682 thenCollect: [:m | m bounds expandBy: 8]. . 97683 baseArea := (RealEstateAgent reduceByFlaps: RealEstateAgent maximumUsableArea) 97684 insetBy: 8. 97685 searching := true. 97686 baseArea allAreasOutsideList: areas do: [:rect | 97687 searching ifTrue: [ 97688 aSystemWindow extent <= (rect insetBy: 8) extent 97689 ifTrue: [foundRect := rect. 97690 searching := false]]]. 97691 searching ifTrue: [foundRect := baseArea]. 97692 aSystemWindow setWindowColor: self theme windowColor. 97693 aSystemWindow position: foundRect topLeft + 8. 97694 aSystemWindow openAsIs. 97695 ^aSystemWindow! ! 97696 97697 97698!ExampleBuilderMorph methodsFor: 'controls'! 97699newAlphaImage: aForm help: helpText 97700 "Answer an alpha image morph." 97701 97702 ^self theme 97703 newAlphaImageIn: self 97704 image: aForm 97705 help: helpText! ! 97706 97707!ExampleBuilderMorph methodsFor: 'controls'! 97708newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText 97709 "Answer an alpha channel selector with the given selectors." 97710 97711 ^self theme 97712 newAlphaSelectorIn: self 97713 for: aModel 97714 getAlpha: getSel 97715 setAlpha: setSel 97716 help: helpText! ! 97717 97718!ExampleBuilderMorph methodsFor: 'controls'! 97719newAutoAcceptTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 97720 "Answer a text editor for the given model." 97721 97722 ^self theme 97723 newAutoAcceptTextEditorIn: self 97724 for: aModel 97725 getText: getSel 97726 setText: setSel 97727 getEnabled: enabledSel! ! 97728 97729!ExampleBuilderMorph methodsFor: 'controls'! 97730newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText 97731 "Answer a text entry for the given model." 97732 97733 ^self theme 97734 newAutoAcceptTextEntryIn: self 97735 for: aModel 97736 get: getSel 97737 set: setSel 97738 class: aClass 97739 getEnabled: enabledSel 97740 font: aFont 97741 help: helpText! ! 97742 97743!ExampleBuilderMorph methodsFor: 'controls'! 97744newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText 97745 "Answer a text entry for the given model." 97746 97747 ^self theme 97748 newAutoAcceptTextEntryIn: self 97749 for: aModel 97750 get: getSel 97751 set: setSel 97752 class: aClass 97753 getEnabled: enabledSel 97754 help: helpText! ! 97755 97756!ExampleBuilderMorph methodsFor: 'controls'! 97757newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText 97758 "Answer a text entry for the given model." 97759 97760 ^self theme 97761 newAutoAcceptTextEntryIn: self 97762 for: aModel 97763 get: getSel 97764 set: setSel 97765 class: String 97766 getEnabled: enabledSel 97767 font: aFont 97768 help: helpText 97769! ! 97770 97771!ExampleBuilderMorph methodsFor: 'controls'! 97772newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText 97773 "Answer a text entry for the given model." 97774 97775 ^self theme 97776 newAutoAcceptTextEntryIn: self 97777 for: aModel 97778 get: getSel 97779 set: setSel 97780 class: String 97781 getEnabled: enabledSel 97782 help: helpText! ! 97783 97784!ExampleBuilderMorph methodsFor: 'controls'! 97785newBalloonHelp: aTextStringOrMorph for: aMorph 97786 "Answer a new balloon help with the given contents for aMorph 97787 at a given corner." 97788 97789 ^self theme 97790 newBalloonHelpIn: self 97791 contents: aTextStringOrMorph 97792 for: aMorph 97793 corner: #bottomLeft! ! 97794 97795!ExampleBuilderMorph methodsFor: 'controls'! 97796newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol 97797 "Answer a new balloon help with the given contents for aMorph 97798 at a given corner." 97799 97800 ^self theme 97801 newBalloonHelpIn: self 97802 contents: aTextStringOrMorph 97803 for: aMorph 97804 corner: cornerSymbol! ! 97805 97806!ExampleBuilderMorph methodsFor: 'controls'! 97807newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText 97808 "Answer a bracket slider with the given selectors." 97809 97810 ^self theme 97811 newBracketSliderIn: self 97812 for: aModel 97813 getValue: getSel 97814 setValue: setSel 97815 min: minValue 97816 max: maxValue 97817 quantum: quantum 97818 getEnabled: enabledSel 97819 help: helpText! ! 97820 97821!ExampleBuilderMorph methodsFor: 'controls'! 97822newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText 97823 "Answer a bracket slider with the given selectors." 97824 97825 ^self 97826 newBracketSliderFor: aModel 97827 getValue: getSel 97828 setValue: setSel 97829 min: minValue 97830 max: maxValue 97831 quantum: quantum 97832 getEnabled: nil 97833 help: helpText! ! 97834 97835!ExampleBuilderMorph methodsFor: 'controls'! 97836newButtonFor: aModel action: actionSel getEnabled: enabledSel label: stringOrText help: helpText 97837 "Answer a new button." 97838 97839 ^self 97840 newButtonFor: aModel 97841 getState: nil 97842 action: actionSel 97843 arguments: nil 97844 getEnabled: enabledSel 97845 label: stringOrText 97846 help: helpText! ! 97847 97848!ExampleBuilderMorph methodsFor: 'controls'! 97849newButtonFor: aModel action: actionSel label: stringOrText help: helpText 97850 "Answer a new button." 97851 97852 ^self 97853 newButtonFor: aModel 97854 getState: nil 97855 action: actionSel 97856 arguments: nil 97857 getEnabled: nil 97858 label: stringOrText 97859 help: helpText! ! 97860 97861!ExampleBuilderMorph methodsFor: 'controls'! 97862newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText 97863 "Answer a new button." 97864 97865 ^self theme 97866 newButtonIn: self for: aModel 97867 getState: stateSel 97868 action: actionSel 97869 arguments: args 97870 getEnabled: enabledSel 97871 getLabel: labelSel 97872 help: helpText! ! 97873 97874!ExampleBuilderMorph methodsFor: 'controls'! 97875newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText 97876 "Answer a new button." 97877 97878 ^self theme 97879 newButtonIn: self for: aModel 97880 getState: stateSel 97881 action: actionSel 97882 arguments: args 97883 getEnabled: enabledSel 97884 label: stringOrText 97885 help: helpText! ! 97886 97887!ExampleBuilderMorph methodsFor: 'controls'! 97888newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel labelForm: aForm help: helpText 97889 "Answer a new button." 97890 97891 ^self theme 97892 newButtonIn: self for: aModel 97893 getState: stateSel 97894 action: actionSel 97895 arguments: args 97896 getEnabled: enabledSel 97897 label: (AlphaImageMorph new image: aForm) 97898 help: helpText! ! 97899 97900!ExampleBuilderMorph methodsFor: 'controls'! 97901newCancelButton 97902 "Answer a new cancel button." 97903 97904 ^self newCancelButtonFor: self! ! 97905 97906!ExampleBuilderMorph methodsFor: 'controls'! 97907newCancelButtonFor: aModel 97908 "Answer a new cancel button." 97909 97910 ^self theme 97911 newCancelButtonIn: self 97912 for: aModel! ! 97913 97914!ExampleBuilderMorph methodsFor: 'controls'! 97915newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText 97916 "Answer a checkbox with the given label." 97917 97918 ^self theme 97919 newCheckboxIn: self 97920 for: aModel 97921 getSelected: getSel 97922 setSelected: setSel 97923 getEnabled: enabledSel 97924 label: stringOrText 97925 help: helpText! ! 97926 97927!ExampleBuilderMorph methodsFor: 'controls'! 97928newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText 97929 "Answer a checkbox with the given label." 97930 97931 ^self theme 97932 newCheckboxIn: self 97933 for: aModel 97934 getSelected: getSel 97935 setSelected: setSel 97936 getEnabled: nil 97937 label: stringOrText 97938 help: helpText! ! 97939 97940!ExampleBuilderMorph methodsFor: 'controls'! 97941newCloseButton 97942 "Answer a new close button." 97943 97944 ^self newCloseButtonFor: self ! ! 97945 97946!ExampleBuilderMorph methodsFor: 'controls'! 97947newCloseButtonFor: aModel 97948 "Answer a new close button." 97949 97950 ^self theme 97951 newCloseButtonIn: self 97952 for: aModel! ! 97953 97954!ExampleBuilderMorph methodsFor: 'controls'! 97955newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText 97956 "Answer a color chooser with the given selectors." 97957 97958 ^self theme 97959 newColorChooserIn: self 97960 for: aModel 97961 getColor: getSel 97962 setColor: setSel 97963 getEnabled: enabledSel 97964 help: helpText! ! 97965 97966!ExampleBuilderMorph methodsFor: 'controls'! 97967newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText 97968 "Answer a color chooser with the given selectors." 97969 97970 ^self theme 97971 newColorChooserIn: self 97972 for: aModel 97973 getColor: getSel 97974 setColor: setSel 97975 getEnabled: nil 97976 help: helpText! ! 97977 97978!ExampleBuilderMorph methodsFor: 'controls'! 97979newColorPickerFor: target getter: getterSymbol setter: setterSymbol 97980 "Answer a new color picker for the given morph and accessors." 97981 97982 ^self theme 97983 newColorPickerIn: self 97984 for: target 97985 getter: getterSymbol 97986 setter: setterSymbol! ! 97987 97988!ExampleBuilderMorph methodsFor: 'controls'! 97989newColorPresenterFor: aModel getColor: getSel help: helpText 97990 "Answer a color presenter with the given selectors." 97991 97992 ^self theme 97993 newColorPresenterIn: self 97994 for: aModel 97995 getColor: getSel 97996 help: helpText! ! 97997 97998!ExampleBuilderMorph methodsFor: 'controls'! 97999newColumn: controls 98000 "Answer a morph laid out with a column of controls." 98001 98002 ^self theme 98003 newColumnIn: self 98004 for: controls! ! 98005 98006!ExampleBuilderMorph methodsFor: 'controls'! 98007newDialogPanel 98008 "Answer a new main dialog panel." 98009 98010 ^self theme 98011 newDialogPanelIn: self! ! 98012 98013!ExampleBuilderMorph methodsFor: 'controls'! 98014newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText 98015 "Answer a drop list for the given model." 98016 98017 ^self theme 98018 newDropListIn: self 98019 for: aModel 98020 list: listSel 98021 getSelected: getSel 98022 setSelected: setSel 98023 getEnabled: enabledSel 98024 useIndex: true 98025 help: helpText! ! 98026 98027!ExampleBuilderMorph methodsFor: 'controls'! 98028newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 98029 "Answer a drop list for the given model." 98030 98031 ^self theme 98032 newDropListIn: self 98033 for: aModel 98034 list: listSel 98035 getSelected: getSel 98036 setSelected: setSel 98037 getEnabled: enabledSel 98038 useIndex: useIndex 98039 help: helpText! ! 98040 98041!ExampleBuilderMorph methodsFor: 'controls'! 98042newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText 98043 "Answer a drop list for the given model." 98044 98045 ^self 98046 newDropListFor: aModel 98047 list: listSel 98048 getSelected: getSel 98049 setSelected: setSel 98050 getEnabled: nil 98051 useIndex: true 98052 help: helpText! ! 98053 98054!ExampleBuilderMorph methodsFor: 'controls'! 98055newEmbeddedMenu 98056 "Answer a new menu." 98057 98058 ^self theme 98059 newEmbeddedMenuIn: self 98060 for: self! ! 98061 98062!ExampleBuilderMorph methodsFor: 'controls'! 98063newExpander: aString 98064 "Answer an expander with the given label." 98065 98066 ^self theme 98067 newExpanderIn: self 98068 label: aString 98069 forAll: #()! ! 98070 98071!ExampleBuilderMorph methodsFor: 'controls'! 98072newExpander: aString for: aControl 98073 "Answer an expander with the given label and control." 98074 98075 ^self theme 98076 newExpanderIn: self 98077 label: aString 98078 forAll: {aControl}! ! 98079 98080!ExampleBuilderMorph methodsFor: 'controls'! 98081newExpander: aString forAll: controls 98082 "Answer an expander with the given label and controls." 98083 98084 ^self theme 98085 newExpanderIn: self 98086 label: aString 98087 forAll: controls! ! 98088 98089!ExampleBuilderMorph methodsFor: 'controls'! 98090newFuzzyLabel: aString 98091 "Answer a new fuzzy label." 98092 98093 ^self theme 98094 newFuzzyLabelIn: self 98095 for: nil 98096 label: aString 98097 offset: 1 98098 alpha: 0.5 98099 getEnabled: nil! ! 98100 98101!ExampleBuilderMorph methodsFor: 'controls'! 98102newFuzzyLabelFor: aModel label: aString getEnabled: enabledSel 98103 "Answer a new fuzzy label." 98104 98105 ^self theme 98106 newFuzzyLabelIn: self 98107 for: aModel 98108 label: aString 98109 offset: 1 98110 alpha: 0.5 98111 getEnabled: enabledSel! ! 98112 98113!ExampleBuilderMorph methodsFor: 'controls'! 98114newFuzzyLabelFor: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel 98115 "Answer a new fuzzy label." 98116 98117 ^self theme 98118 newFuzzyLabelIn: self 98119 for: aModel 98120 label: aString 98121 offset: offset 98122 alpha: alpha 98123 getEnabled: enabledSel! ! 98124 98125!ExampleBuilderMorph methodsFor: 'controls'! 98126newGroupbox 98127 "Answer a plain groupbox." 98128 98129 ^self theme 98130 newGroupboxIn: self! ! 98131 98132!ExampleBuilderMorph methodsFor: 'controls'! 98133newGroupbox: aString 98134 "Answer a groupbox with the given label." 98135 98136 ^self theme 98137 newGroupboxIn: self 98138 label: aString! ! 98139 98140!ExampleBuilderMorph methodsFor: 'controls'! 98141newGroupbox: aString for: control 98142 "Answer a groupbox with the given label and control." 98143 98144 ^self theme 98145 newGroupboxIn: self 98146 label: aString 98147 for: control! ! 98148 98149!ExampleBuilderMorph methodsFor: 'controls'! 98150newGroupbox: aString forAll: controls 98151 "Answer a groupbox with the given label and controls." 98152 98153 ^self theme 98154 newGroupboxIn: self 98155 label: aString 98156 forAll: controls! ! 98157 98158!ExampleBuilderMorph methodsFor: 'controls'! 98159newGroupboxFor: control 98160 "Answer a plain groupbox with the given control." 98161 98162 ^self theme 98163 newGroupboxIn: self 98164 for: control! ! 98165 98166!ExampleBuilderMorph methodsFor: 'controls'! 98167newGroupboxForAll: controls 98168 "Answer a plain groupbox with the given controls." 98169 98170 ^self theme 98171 newGroupboxIn: self 98172 forAll: controls! ! 98173 98174!ExampleBuilderMorph methodsFor: 'controls'! 98175newHSVASelector: aColor help: helpText 98176 "Answer a hue-saturation-volume selector with the given color." 98177 98178 ^self theme 98179 newHSVASelectorIn: self 98180 color: aColor 98181 help: helpText! ! 98182 98183!ExampleBuilderMorph methodsFor: 'controls'! 98184newHSVSelector: aColor help: helpText 98185 "Answer a hue-saturation-volume selector with the given color." 98186 98187 ^self theme 98188 newHSVSelectorIn: self 98189 color: aColor 98190 help: helpText! ! 98191 98192!ExampleBuilderMorph methodsFor: 'controls'! 98193newHueSelector: aModel getHue: getSel setHue: setSel help: helpText 98194 "Answer a hue selector with the given selectors." 98195 98196 ^self theme 98197 newHueSelectorIn: self 98198 for: aModel 98199 getHue: getSel 98200 setHue: setSel 98201 help: helpText! ! 98202 98203!ExampleBuilderMorph methodsFor: 'controls'! 98204newImage: aForm 98205 "Answer a new image." 98206 98207 ^self theme 98208 newImageIn: self 98209 form: aForm! ! 98210 98211!ExampleBuilderMorph methodsFor: 'controls'! 98212newImage: aForm size: aPoint 98213 "Answer a new image." 98214 98215 ^self theme 98216 newImageIn: self 98217 form: aForm 98218 size: aPoint! ! 98219 98220!ExampleBuilderMorph methodsFor: 'controls'! 98221newIncrementalSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText 98222 "Answer an inremental slider with the given selectors." 98223 98224 ^self theme 98225 newIncrementalSliderIn: self 98226 for: aModel 98227 getValue: getSel 98228 setValue: setSel 98229 min: min 98230 max: max 98231 quantum: quantum 98232 getEnabled: enabledSel 98233 help: helpText! ! 98234 98235!ExampleBuilderMorph methodsFor: 'controls'! 98236newLabel: aString 98237 "Answer a new text label." 98238 98239 ^self 98240 newLabelFor: nil 98241 label: aString 98242 getEnabled: nil! ! 98243 98244!ExampleBuilderMorph methodsFor: 'controls'! 98245newLabelFor: aModel label: aString getEnabled: enabledSel 98246 "Answer a new text label." 98247 98248 ^self theme 98249 newLabelIn: self 98250 for: aModel 98251 label: aString 98252 getEnabled: enabledSel! ! 98253 98254!ExampleBuilderMorph methodsFor: 'controls'! 98255newLabelGroup: labelsAndControls 98256 "Answer a morph laid out with a column of labels and a column of associated controls." 98257 98258 ^self theme 98259 newLabelGroupIn: self 98260 for: labelsAndControls 98261 spaceFill: false! ! 98262 98263!ExampleBuilderMorph methodsFor: 'controls'! 98264newLabelGroup: labelsAndControls font: aFont labelColor: aColor 98265 "Answer a morph laid out with a column of labels and a column of associated controls." 98266 98267 ^self theme 98268 newLabelGroupIn: self 98269 for: labelsAndControls 98270 spaceFill: false 98271 font: aFont 98272 labelColor: aColor 98273! ! 98274 98275!ExampleBuilderMorph methodsFor: 'controls'! 98276newLabelGroupSpread: labelsAndControls 98277 "Answer a morph laid out with a column of labels and a column of associated controls." 98278 98279 ^self theme 98280 newLabelGroupIn: self 98281 for: labelsAndControls 98282 spaceFill: true! ! 98283 98284!ExampleBuilderMorph methodsFor: 'controls'! 98285newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText 98286 "Answer a list for the given model." 98287 98288 ^self theme 98289 newListIn: self 98290 for: aModel 98291 list: listSelector 98292 selected: getSelector 98293 changeSelected: setSelector 98294 getEnabled: enabledSel 98295 help: helpText! ! 98296 98297!ExampleBuilderMorph methodsFor: 'controls'! 98298newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText 98299 "Answer a list for the given model." 98300 98301 ^self 98302 newListFor: aModel 98303 list: listSelector 98304 selected: getSelector 98305 changeSelected: setSelector 98306 getEnabled: nil 98307 help: helpText! ! 98308 98309!ExampleBuilderMorph methodsFor: 'controls'! 98310newMenu 98311 "Answer a new menu." 98312 98313 ^self theme 98314 newMenuIn: self 98315 for: self! ! 98316 98317!ExampleBuilderMorph methodsFor: 'controls'! 98318newMenuFor: aModel 98319 "Answer a new menu." 98320 98321 ^self theme 98322 newMenuIn: self 98323 for: aModel! ! 98324 98325!ExampleBuilderMorph methodsFor: 'controls'! 98326newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText 98327 "Answer a morph drop list for the given model." 98328 98329 ^self 98330 newMorphDropListFor: aModel 98331 list: listSel 98332 getSelected: getSel 98333 setSelected: setSel 98334 getEnabled: enabledSel 98335 useIndex: true 98336 help: helpText! ! 98337 98338!ExampleBuilderMorph methodsFor: 'controls'! 98339newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 98340 "Answer a morph drop list for the given model." 98341 98342 ^self theme 98343 newMorphDropListIn: self 98344 for: aModel 98345 list: listSel 98346 getSelected: getSel 98347 setSelected: setSel 98348 getEnabled: enabledSel 98349 useIndex: useIndex 98350 help: helpText! ! 98351 98352!ExampleBuilderMorph methodsFor: 'controls'! 98353newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText 98354 "Answer a morph drop list for the given model." 98355 98356 ^self 98357 newMorphDropListFor: aModel 98358 list: listSel 98359 getSelected: getSel 98360 setSelected: setSel 98361 getEnabled: nil 98362 useIndex: true 98363 help: helpText! ! 98364 98365!ExampleBuilderMorph methodsFor: 'controls'! 98366newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText 98367 "Answer a morph list for the given model." 98368 98369 ^self theme 98370 newMorphListIn: self 98371 for: aModel 98372 list: listSelector 98373 getSelected: getSelector 98374 setSelected: setSelector 98375 getEnabled: enabledSel 98376 help: helpText! ! 98377 98378!ExampleBuilderMorph methodsFor: 'controls'! 98379newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText 98380 "Answer a morph list for the given model." 98381 98382 ^self 98383 newMorphListFor: aModel 98384 list: listSelector 98385 getSelected: getSelector 98386 setSelected: setSelector 98387 getEnabled: nil 98388 help: helpText! ! 98389 98390!ExampleBuilderMorph methodsFor: 'controls'! 98391newNoButton 98392 "Answer a new No button." 98393 98394 ^self newNoButtonFor: self! ! 98395 98396!ExampleBuilderMorph methodsFor: 'controls'! 98397newNoButtonFor: aModel 98398 "Answer a new No button." 98399 98400 ^self theme 98401 newNoButtonIn: self 98402 for: aModel! ! 98403 98404!ExampleBuilderMorph methodsFor: 'controls'! 98405newOKButton 98406 "Answer a new OK button." 98407 98408 ^self newOKButtonFor: self! ! 98409 98410!ExampleBuilderMorph methodsFor: 'controls'! 98411newOKButtonFor: aModel 98412 "Answer a new OK button." 98413 98414 ^self 98415 newOKButtonFor: aModel 98416 getEnabled: nil! ! 98417 98418!ExampleBuilderMorph methodsFor: 'controls'! 98419newOKButtonFor: aModel getEnabled: enabledSel 98420 "Answer a new OK button." 98421 98422 ^self theme 98423 newOKButtonIn: self 98424 for: aModel 98425 getEnabled: enabledSel! ! 98426 98427!ExampleBuilderMorph methodsFor: 'controls'! 98428newPanel 98429 "Answer a new panel." 98430 98431 ^self theme 98432 newPanelIn: self! ! 98433 98434!ExampleBuilderMorph methodsFor: 'controls'! 98435newPluggableDialogWindow 98436 "Answer a new pluggable dialog." 98437 98438 ^self 98439 newPluggableDialogWindow: 'Dialog'! ! 98440 98441!ExampleBuilderMorph methodsFor: 'controls'! 98442newPluggableDialogWindow: title 98443 "Answer a new pluggable dialog with the given content." 98444 98445 ^self 98446 newPluggableDialogWindow: title 98447 for: nil! ! 98448 98449!ExampleBuilderMorph methodsFor: 'controls'! 98450newPluggableDialogWindow: title for: contentMorph 98451 "Answer a new pluggable dialog with the given content." 98452 98453 ^self theme 98454 newPluggableDialogWindowIn: self 98455 title: title 98456 for: contentMorph! ! 98457 98458!ExampleBuilderMorph methodsFor: 'controls'! 98459newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText 98460 "Answer a checkbox (radio button appearance) with the given label." 98461 98462 ^self theme 98463 newRadioButtonIn: self 98464 for: aModel 98465 getSelected: getSel 98466 setSelected: setSel 98467 getEnabled: enabledSel 98468 label: stringOrText 98469 help: helpText! ! 98470 98471!ExampleBuilderMorph methodsFor: 'controls'! 98472newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText 98473 "Answer a checkbox (radio button appearance) with the given label." 98474 98475 ^self 98476 newRadioButtonFor: aModel 98477 getSelected: getSel 98478 setSelected: setSel 98479 getEnabled: nil 98480 label: stringOrText 98481 help: helpText! ! 98482 98483!ExampleBuilderMorph methodsFor: 'controls'! 98484newRow 98485 "Answer a morph laid out as a row." 98486 98487 ^self theme 98488 newRowIn: self 98489 for: #()! ! 98490 98491!ExampleBuilderMorph methodsFor: 'controls'! 98492newRow: controls 98493 "Answer a morph laid out with a row of controls." 98494 98495 ^self theme 98496 newRowIn: self 98497 for: controls! ! 98498 98499!ExampleBuilderMorph methodsFor: 'controls'! 98500newSVSelector: aColor help: helpText 98501 "Answer a saturation-volume selector with the given color." 98502 98503 ^self theme 98504 newSVSelectorIn: self 98505 color: aColor 98506 help: helpText! ! 98507 98508!ExampleBuilderMorph methodsFor: 'controls'! 98509newSeparator 98510 "Answer an horizontal separator." 98511 98512 ^self theme 98513 newSeparatorIn: self! ! 98514 98515!ExampleBuilderMorph methodsFor: 'controls'! 98516newSliderFor: aModel getValue: getSel setValue: setSel getEnabled: enabledSel help: helpText 98517 "Answer a slider with the given selectors." 98518 98519 ^self theme 98520 newSliderIn: self 98521 for: aModel 98522 getValue: getSel 98523 setValue: setSel 98524 min: 0 98525 max: 1 98526 quantum: nil 98527 getEnabled: enabledSel 98528 help: helpText! ! 98529 98530!ExampleBuilderMorph methodsFor: 'controls'! 98531newSliderFor: aModel getValue: getSel setValue: setSel help: helpText 98532 "Answer a slider with the given selectors." 98533 98534 ^self theme 98535 newSliderIn: self 98536 for: aModel 98537 getValue: getSel 98538 setValue: setSel 98539 min: 0 98540 max: 1 98541 quantum: nil 98542 getEnabled: nil 98543 help: helpText! ! 98544 98545!ExampleBuilderMorph methodsFor: 'controls'! 98546newSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText 98547 "Answer a slider with the given selectors." 98548 98549 ^self theme 98550 newSliderIn: self 98551 for: aModel 98552 getValue: getSel 98553 setValue: setSel 98554 min: min 98555 max: max 98556 quantum: quantum 98557 getEnabled: enabledSel 98558 help: helpText! ! 98559 98560!ExampleBuilderMorph methodsFor: 'controls'! 98561newString: aStringOrText 98562 "Answer a new embossed string." 98563 98564 ^self theme 98565 newStringIn: self 98566 label: aStringOrText 98567 font: self theme labelFont 98568 style: #plain! ! 98569 98570!ExampleBuilderMorph methodsFor: 'controls'! 98571newString: aStringOrText font: aFont style: aStyle 98572 "Answer a new embossed string." 98573 98574 ^self theme 98575 newStringIn: self 98576 label: aStringOrText 98577 font: aFont 98578 style: aStyle! ! 98579 98580!ExampleBuilderMorph methodsFor: 'controls'! 98581newString: aStringOrText style: aStyle 98582 "Answer a new embossed string." 98583 98584 ^self theme 98585 newStringIn: self 98586 label: aStringOrText 98587 font: self theme labelFont 98588 style: aStyle! ! 98589 98590!ExampleBuilderMorph methodsFor: 'controls'! 98591newTabGroup: labelsAndPages 98592 "Answer a tab group with the given tab labels associated with pages." 98593 98594 ^self theme 98595 newTabGroupIn: self 98596 for: labelsAndPages! ! 98597 98598!ExampleBuilderMorph methodsFor: 'controls'! 98599newText: aStringOrText 98600 "Answer a new text." 98601 98602 ^self theme 98603 newTextIn: self 98604 text: aStringOrText! ! 98605 98606!ExampleBuilderMorph methodsFor: 'controls'! 98607newTextEditorFor: aModel getText: getSel setText: setSel 98608 "Answer a text editor for the given model." 98609 98610 ^self 98611 newTextEditorFor: aModel 98612 getText: getSel 98613 setText: setSel 98614 getEnabled: nil! ! 98615 98616!ExampleBuilderMorph methodsFor: 'controls'! 98617newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 98618 "Answer a text editor for the given model." 98619 98620 ^self theme 98621 newTextEditorIn: self 98622 for: aModel 98623 getText: getSel 98624 setText: setSel 98625 getEnabled: enabledSel ! ! 98626 98627!ExampleBuilderMorph methodsFor: 'controls'! 98628newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText 98629 "Answer a text entry for the given model." 98630 98631 ^self theme 98632 newTextEntryIn: self 98633 for: aModel 98634 get: getSel 98635 set: setSel 98636 class: aClass 98637 getEnabled: enabledSel 98638 help: helpText! ! 98639 98640!ExampleBuilderMorph methodsFor: 'controls'! 98641newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText 98642 "Answer a text entry for the given model." 98643 98644 ^self theme 98645 newTextEntryIn: self 98646 for: aModel 98647 get: getSel 98648 set: setSel 98649 class: String 98650 getEnabled: enabledSel 98651 help: helpText! ! 98652 98653!ExampleBuilderMorph methodsFor: 'controls'! 98654newTextEntryFor: aModel getText: getSel setText: setSel help: helpText 98655 "Answer a text entry for the given model." 98656 98657 ^self 98658 newTextEntryFor: aModel 98659 get: getSel 98660 set: setSel 98661 class: String 98662 getEnabled: nil 98663 help: helpText! ! 98664 98665!ExampleBuilderMorph methodsFor: 'controls'! 98666newTitle: aString for: control 98667 "Answer a morph laid out with a column with a title." 98668 98669 ^self theme 98670 newTitleIn: self 98671 label: aString 98672 for: control! ! 98673 98674!ExampleBuilderMorph methodsFor: 'controls'! 98675newToolDockingBar 98676 "Answer a tool docking bar." 98677 98678 ^self theme 98679 newToolDockingBarIn: self! ! 98680 98681!ExampleBuilderMorph methodsFor: 'controls'! 98682newToolSpacer 98683 "Answer a tool spacer." 98684 98685 ^self theme 98686 newToolSpacerIn: self! ! 98687 98688!ExampleBuilderMorph methodsFor: 'controls'! 98689newToolbar 98690 "Answer a toolbar." 98691 98692 ^self theme 98693 newToolbarIn: self! ! 98694 98695!ExampleBuilderMorph methodsFor: 'controls'! 98696newToolbar: controls 98697 "Answer a toolbar with the given controls." 98698 98699 ^self theme 98700 newToolbarIn: self 98701 for: controls! ! 98702 98703!ExampleBuilderMorph methodsFor: 'controls'! 98704newToolbarHandle 98705 "Answer a toolbar handle." 98706 98707 ^self theme 98708 newToolbarHandleIn: self! ! 98709 98710!ExampleBuilderMorph methodsFor: 'controls'! 98711newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector 98712 "Answer a new tree morph." 98713 98714 ^self theme 98715 newTreeIn: self 98716 for: aModel 98717 list: listSelector 98718 selected: getSelector 98719 changeSelected: setSelector! ! 98720 98721!ExampleBuilderMorph methodsFor: 'controls'! 98722newVerticalSeparator 98723 "Answer a vertical separator." 98724 98725 ^self theme 98726 newVerticalSeparatorIn: self! ! 98727 98728!ExampleBuilderMorph methodsFor: 'controls'! 98729newYesButton 98730 "Answer a new Yes button." 98731 98732 ^self newYesButtonFor: self! ! 98733 98734!ExampleBuilderMorph methodsFor: 'controls'! 98735newYesButtonFor: aModel 98736 "Answer a new yes button." 98737 98738 ^self theme 98739 newYesButtonIn: self 98740 for: aModel! ! 98741 98742 98743!ExampleBuilderMorph methodsFor: 'services'! 98744abort: aStringOrText 98745 "Open an error dialog." 98746 98747 ^self abort: aStringOrText title: 'Error' translated! ! 98748 98749!ExampleBuilderMorph methodsFor: 'services'! 98750abort: aStringOrText title: aString 98751 "Open an error dialog." 98752 98753 ^self theme 98754 abortIn: self 98755 text: aStringOrText 98756 title: aString! ! 98757 98758!ExampleBuilderMorph methodsFor: 'services'! 98759alert: aStringOrText 98760 "Open an alert dialog." 98761 98762 ^self alert: aStringOrText title: 'Alert' translated! ! 98763 98764!ExampleBuilderMorph methodsFor: 'services'! 98765alert: aStringOrText title: aString 98766 "Open an alert dialog." 98767 98768 ^self 98769 alert: aStringOrText 98770 title: aString 98771 configure: [:d | ]! ! 98772 98773!ExampleBuilderMorph methodsFor: 'services'! 98774alert: aStringOrText title: aString configure: aBlock 98775 "Open an alert dialog. 98776 Configure the dialog with the 1 argument block 98777 before opening modally." 98778 98779 ^self theme 98780 alertIn: self 98781 text: aStringOrText 98782 title: aString 98783 configure: aBlock! ! 98784 98785!ExampleBuilderMorph methodsFor: 'services'! 98786chooseColor 98787 "Answer the result of a color selector dialog ." 98788 98789 ^self chooseColor: Color black! ! 98790 98791!ExampleBuilderMorph methodsFor: 'services'! 98792chooseColor: aColor 98793 "Answer the result of a color selector dialog with the given color." 98794 98795 ^self theme 98796 chooseColorIn: self 98797 title: 'Colour Selector' translated 98798 color: aColor! ! 98799 98800!ExampleBuilderMorph methodsFor: 'services'! 98801chooseColor: aColor title: title 98802 "Answer the result of a color selector dialog with the given title and initial colour." 98803 98804 ^self theme 98805 chooseColorIn: self 98806 title: title 98807 color: aColor! ! 98808 98809!ExampleBuilderMorph methodsFor: 'services'! 98810chooseDirectory: title 98811 "Answer the result of a file dialog with the given title, answer a directory." 98812 98813 ^self 98814 chooseDirectory: title 98815 path: nil! ! 98816 98817!ExampleBuilderMorph methodsFor: 'services'! 98818chooseDirectory: title path: path 98819 "Answer the result of a file dialog with the given title, answer a directory." 98820 98821 ^self theme 98822 chooseDirectoryIn: self 98823 title: title 98824 path: path! ! 98825 98826!ExampleBuilderMorph methodsFor: 'services'! 98827chooseDropList: aStringOrText list: aList 98828 "Open a drop list chooser dialog." 98829 98830 ^self 98831 chooseDropList: aStringOrText 98832 title: 'Choose' translated 98833 list: aList! ! 98834 98835!ExampleBuilderMorph methodsFor: 'services'! 98836chooseDropList: aStringOrText title: aString list: aList 98837 "Open a drop list chooser dialog." 98838 98839 ^self theme 98840 chooseDropListIn: self 98841 text: aStringOrText 98842 title: aString 98843 list: aList! ! 98844 98845!ExampleBuilderMorph methodsFor: 'services'! 98846chooseFileName: title extensions: exts path: path preview: preview 98847 "Answer the result of a file name chooser dialog with the given title, extensions 98848 to show, path and preview type." 98849 98850 ^self theme 98851 chooseFileNameIn: self 98852 title: title 98853 extensions: exts 98854 path: path 98855 preview: preview! ! 98856 98857!ExampleBuilderMorph methodsFor: 'services'! 98858chooseFont 98859 "Answer the result of a font selector dialog." 98860 98861 ^self chooseFont: nil! ! 98862 98863!ExampleBuilderMorph methodsFor: 'services'! 98864chooseFont: aFont 98865 "Answer the result of a font selector dialog with the given initial font." 98866 98867 ^self theme 98868 chooseFontIn: self 98869 title: 'Font Selector' translated 98870 font: aFont! ! 98871 98872!ExampleBuilderMorph methodsFor: 'services'! 98873deny: aStringOrText 98874 "Open a denial dialog." 98875 98876 ^self deny: aStringOrText title: 'Access Denied' translated! ! 98877 98878!ExampleBuilderMorph methodsFor: 'services'! 98879deny: aStringOrText title: aString 98880 "Open a denial dialog." 98881 98882 ^self theme 98883 denyIn: self 98884 text: aStringOrText 98885 title: aString! ! 98886 98887!ExampleBuilderMorph methodsFor: 'services'! 98888fileOpen: title 98889 "Answer the result of a file open dialog with the given title." 98890 98891 ^self 98892 fileOpen: title 98893 extensions: nil! ! 98894 98895!ExampleBuilderMorph methodsFor: 'services'! 98896fileOpen: title extensions: exts 98897 "Answer the result of a file open dialog with the given title and extensions to show." 98898 98899 ^self 98900 fileOpen: title 98901 extensions: exts 98902 path: nil! ! 98903 98904!ExampleBuilderMorph methodsFor: 'services'! 98905fileOpen: title extensions: exts path: path 98906 "Answer the result of a file open dialog with the given title, extensions to show and path." 98907 98908 ^self 98909 fileOpen: title 98910 extensions: exts 98911 path: path 98912 preview: nil! ! 98913 98914!ExampleBuilderMorph methodsFor: 'services'! 98915fileOpen: title extensions: exts path: path preview: preview 98916 "Answer the result of a file open dialog with the given title, extensions to show, path and preview type." 98917 98918 ^self theme 98919 fileOpenIn: self 98920 title: title 98921 extensions: exts 98922 path: path 98923 preview: preview! ! 98924 98925!ExampleBuilderMorph methodsFor: 'services'! 98926fileSave: title 98927 "Answer the result of a file save dialog with the given title." 98928 98929 ^self 98930 fileSave: title 98931 extensions: nil 98932 path: nil! ! 98933 98934!ExampleBuilderMorph methodsFor: 'services'! 98935fileSave: title extensions: exts 98936 "Answer the result of a file save dialog with the given title." 98937 98938 ^self 98939 fileSave: title 98940 extensions: exts 98941 path: nil! ! 98942 98943!ExampleBuilderMorph methodsFor: 'services'! 98944fileSave: title extensions: exts path: path 98945 "Answer the result of a file save dialog with the given title, extensions to show and path." 98946 98947 ^self theme 98948 fileSaveIn: self 98949 title: title 98950 extensions: exts 98951 path: path! ! 98952 98953!ExampleBuilderMorph methodsFor: 'services'! 98954fileSave: title path: path 98955 "Answer the result of a file save open dialog with the given title." 98956 98957 ^self 98958 fileSave: title 98959 extensions: nil 98960 path: path! ! 98961 98962!ExampleBuilderMorph methodsFor: 'services'! 98963longMessage: aStringOrText title: aString 98964 "Open a (long) message dialog." 98965 98966 ^self theme 98967 longMessageIn: self 98968 text: aStringOrText 98969 title: aString! ! 98970 98971!ExampleBuilderMorph methodsFor: 'services'! 98972message: aStringOrText 98973 "Open a message dialog." 98974 98975 ^self message: aStringOrText title: 'Information' translated! ! 98976 98977!ExampleBuilderMorph methodsFor: 'services'! 98978message: aStringOrText title: aString 98979 "Open a message dialog." 98980 98981 ^self theme 98982 messageIn: self 98983 text: aStringOrText 98984 title: aString! ! 98985 98986!ExampleBuilderMorph methodsFor: 'services'! 98987proceed: aStringOrText 98988 "Open a proceed dialog." 98989 98990 ^self proceed: aStringOrText title: 'Proceed' translated! ! 98991 98992!ExampleBuilderMorph methodsFor: 'services'! 98993proceed: aStringOrText title: aString 98994 "Open a proceed dialog and answer true if not cancelled, false otherwise." 98995 98996 ^self theme 98997 proceedIn: self 98998 text: aStringOrText 98999 title: aString! ! 99000 99001!ExampleBuilderMorph methodsFor: 'services'! 99002question: aStringOrText 99003 "Open a question dialog." 99004 99005 ^self question: aStringOrText title: 'Question' translated! ! 99006 99007!ExampleBuilderMorph methodsFor: 'services'! 99008question: aStringOrText title: aString 99009 "Open a question dialog and answer true if yes, 99010 false if no and nil if cancelled." 99011 99012 ^self theme 99013 questionIn: self 99014 text: aStringOrText 99015 title: aString! ! 99016 99017!ExampleBuilderMorph methodsFor: 'services'! 99018questionWithoutCancel: aStringOrText 99019 "Open a question dialog." 99020 99021 ^self questionWithoutCancel: aStringOrText title: 'Question' translated! ! 99022 99023!ExampleBuilderMorph methodsFor: 'services'! 99024questionWithoutCancel: aStringOrText title: aString 99025 "Open a question dialog and answer true if yes, 99026 false if no and nil if cancelled." 99027 99028 ^self theme 99029 questionWithoutCancelIn: self 99030 text: aStringOrText 99031 title: aString! ! 99032 99033!ExampleBuilderMorph methodsFor: 'services'! 99034textEntry: aStringOrText 99035 "Open a text entry dialog." 99036 99037 ^self textEntry: aStringOrText title: 'Entry' translated! ! 99038 99039!ExampleBuilderMorph methodsFor: 'services'! 99040textEntry: aStringOrText title: aString 99041 "Open a text entry dialog." 99042 99043 ^self 99044 textEntry: aStringOrText 99045 title: aString 99046 entryText: ''! ! 99047 99048!ExampleBuilderMorph methodsFor: 'services'! 99049textEntry: aStringOrText title: aString entryText: defaultEntryText 99050 "Open a text entry dialog." 99051 99052 ^self theme 99053 textEntryIn: self 99054 text: aStringOrText 99055 title: aString 99056 entryText: defaultEntryText! ! 99057 99058 99059!ExampleBuilderMorph methodsFor: 'theme'! 99060theme 99061 "Answer the ui theme that provides controls." 99062 99063 ^UITheme current! ! 99064 99065"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 99066 99067ExampleBuilderMorph class 99068 uses: TEasilyThemed classTrait 99069 instanceVariableNames: ''! 99070Object subclass: #ExampleRadioButtonModel 99071 instanceVariableNames: 'option' 99072 classVariableNames: '' 99073 poolDictionaries: '' 99074 category: 'Polymorph-Widgets'! 99075!ExampleRadioButtonModel commentStamp: 'gvc 9/23/2008 11:58' prior: 0! 99076Model used for radio buttons in example of basic controls (see "UITheme exampleBasicControls").! 99077 99078 99079!ExampleRadioButtonModel methodsFor: 'accessing' stamp: 'gvc 8/7/2007 13:13'! 99080option 99081 "Answer the value of option" 99082 99083 ^ option! ! 99084 99085!ExampleRadioButtonModel methodsFor: 'accessing' stamp: 'gvc 8/7/2007 13:15'! 99086option: aSymbol 99087 "Set the value of option" 99088 99089 option := aSymbol. 99090 self 99091 changed: #isLeft; 99092 changed: #isCenter; 99093 changed: #isRight! ! 99094 99095 99096!ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:17'! 99097beCenter 99098 "Set the option to #center." 99099 99100 self option: #center! ! 99101 99102!ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:17'! 99103beLeft 99104 "Set the option to #left." 99105 99106 self option: #left! ! 99107 99108!ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:17'! 99109beRight 99110 "Set the option to #right." 99111 99112 self option: #right! ! 99113 99114!ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:17'! 99115initialize 99116 "Initialize the receiver." 99117 99118 super initialize. 99119 self 99120 option: #left! ! 99121 99122!ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:16'! 99123isCenter 99124 "Answer whether the option if #center." 99125 99126 ^self option == #center! ! 99127 99128!ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:16'! 99129isLeft 99130 "Answer whether the option if #left." 99131 99132 ^self option == #left! ! 99133 99134!ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:16'! 99135isRight 99136 "Answer whether the option if #right." 99137 99138 ^self option == #right! ! 99139Object subclass: #Exception 99140 instanceVariableNames: 'messageText tag signalContext handlerContext outerContext' 99141 classVariableNames: '' 99142 poolDictionaries: '' 99143 category: 'Exceptions-Kernel'! 99144!Exception commentStamp: '<historical>' prior: 0! 99145This is the main class used to implement the exception handling system (EHS). It plays two distinct roles: that of the exception, and that of the exception handler. More specifically, it implements the bulk of the protocols laid out in the ANSI specification - those protocol names are reflected in the message categories. 99146 99147Exception is an abstract class. Instances should neither be created nor trapped. In most cases, subclasses should inherit from Error or Notification rather than directly from Exception. 99148 99149In implementing this EHS, The Fourth Estate Inc. incorporated some ideas and code from Craig Latta's EHS. His insights were crucial in allowing us to implement BlockContext>>valueUninterruptably (and by extension, #ensure: and #ifCurtailed:), and we imported the following methods with little or no modification: 99150 99151ContextPart>>terminateTo: 99152ContextPart>>terminate 99153MethodContext>>receiver: 99154MethodContext>>answer: 99155 99156Thanks, Craig!!! 99157 99158 99159!Exception methodsFor: 'exceptionbuilder' stamp: 'pnm 8/16/2000 15:23'! 99160tag: t 99161 "This message is not specified in the ANSI protocol, but that looks like an oversight because #tag is specified, and the spec states that the signaler may store the tag value." 99162 99163 tag := t! ! 99164 99165 99166!Exception methodsFor: 'exceptiondescription' stamp: 'pnm 8/16/2000 14:54'! 99167tag 99168 "Return an exception's tag value." 99169 99170 ^tag == nil 99171 ifTrue: [self messageText] 99172 ifFalse: [tag]! ! 99173 99174 99175!Exception methodsFor: 'handling' stamp: 'ajh 2/1/2003 01:32'! 99176isNested 99177 "Determine whether the current exception handler is within the scope of another handler for the same exception." 99178 99179 ^ handlerContext nextHandlerContext canHandleSignal: self! ! 99180 99181!Exception methodsFor: 'handling' stamp: 'ajh 6/27/2003 22:13'! 99182outer 99183 "Evaluate the enclosing exception action and return to here instead of signal if it resumes (see #resumeUnchecked:)." 99184 99185 | prevOuterContext | 99186 self isResumable ifTrue: [ 99187 prevOuterContext := outerContext. 99188 outerContext := thisContext contextTag. 99189 ]. 99190 self pass. 99191! ! 99192 99193!Exception methodsFor: 'handling' stamp: 'ajh 2/1/2003 01:33'! 99194pass 99195 "Yield control to the enclosing exception action for the receiver." 99196 99197 handlerContext nextHandlerContext handleSignal: self! ! 99198 99199!Exception methodsFor: 'handling' stamp: 'ajh 1/22/2003 23:04'! 99200resignalAs: replacementException 99201 "Signal an alternative exception in place of the receiver." 99202 99203 self resumeUnchecked: replacementException signal! ! 99204 99205!Exception methodsFor: 'handling' stamp: 'ajh 1/13/2002 15:09'! 99206resume 99207 "Return from the message that signaled the receiver." 99208 99209 self resume: nil! ! 99210 99211!Exception methodsFor: 'handling' stamp: 'ajh 6/27/2003 22:30'! 99212resumeUnchecked: resumptionValue 99213 "Return resumptionValue as the value of #signal, unless this was called after an #outer message, then return resumptionValue as the value of #outer." 99214 99215 | ctxt | 99216 outerContext ifNil: [ 99217 signalContext return: resumptionValue 99218 ] ifNotNil: [ 99219 ctxt := outerContext. 99220 outerContext := ctxt tempAt: 1. "prevOuterContext in #outer" 99221 ctxt return: resumptionValue 99222 ]. 99223! ! 99224 99225!Exception methodsFor: 'handling' stamp: 'ajh 1/13/2002 15:14'! 99226resume: resumptionValue 99227 "Return resumptionValue as the value of the signal message." 99228 99229 self isResumable ifFalse: [IllegalResumeAttempt signal]. 99230 self resumeUnchecked: resumptionValue! ! 99231 99232!Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:36'! 99233retry 99234 "Abort an exception handler and re-evaluate its protected block." 99235 99236 handlerContext restart! ! 99237 99238!Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:37'! 99239retryUsing: alternativeBlock 99240 "Abort an exception handler and evaluate a new block in place of the handler's protected block." 99241 99242 handlerContext restartWithNewReceiver: alternativeBlock 99243! ! 99244 99245!Exception methodsFor: 'handling' stamp: 'ajh 9/30/2001 15:33'! 99246return 99247 "Return nil as the value of the block protected by the active exception handler." 99248 99249 self return: nil! ! 99250 99251!Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:37'! 99252return: returnValue 99253 "Return the argument as the value of the block protected by the active exception handler." 99254 99255 handlerContext return: returnValue! ! 99256 99257!Exception methodsFor: 'handling' stamp: 'ajh 2/16/2003 17:37'! 99258searchFrom: aContext 99259 " Set the context where the handler search will start. " 99260 99261 signalContext := aContext contextTag! ! 99262 99263 99264!Exception methodsFor: 'printing' stamp: 'pnm 8/16/2000 14:53'! 99265description 99266 "Return a textual description of the exception." 99267 99268 | desc mt | 99269 desc := self class name asString. 99270 ^(mt := self messageText) == nil 99271 ifTrue: [desc] 99272 ifFalse: [desc, ': ', mt]! ! 99273 99274!Exception methodsFor: 'printing' stamp: 'ajh 9/30/2001 15:33'! 99275messageText 99276 "Return an exception's message text." 99277 99278 ^messageText! ! 99279 99280!Exception methodsFor: 'printing' stamp: 'ajh 9/30/2001 15:33'! 99281printOn: stream 99282 99283 stream nextPutAll: self description! ! 99284 99285!Exception methodsFor: 'printing' stamp: 'ajh 10/22/2001 14:24'! 99286receiver 99287 99288 ^ self signalerContext receiver! ! 99289 99290!Exception methodsFor: 'printing' stamp: 'ar 6/28/2003 00:13'! 99291signalerContext 99292 "Find the first sender of signal(:)" 99293 99294 ^ signalContext findContextSuchThat: [:ctxt | 99295 (ctxt receiver == self or: [ctxt receiver == self class]) not]! ! 99296 99297 99298!Exception methodsFor: 'priv handling' stamp: 'ajh 9/30/2001 15:33'! 99299defaultAction 99300 "The default action taken if the exception is signaled." 99301 99302 self subclassResponsibility! ! 99303 99304!Exception methodsFor: 'priv handling' stamp: 'ajh 2/1/2003 00:58'! 99305isResumable 99306 "Determine whether an exception is resumable." 99307 99308 ^ true! ! 99309 99310!Exception methodsFor: 'priv handling' stamp: 'ajh 1/29/2003 13:44'! 99311privHandlerContext: aContextTag 99312 99313 handlerContext := aContextTag! ! 99314 99315 99316!Exception methodsFor: 'signaling' stamp: 'ajh 9/30/2001 15:33'! 99317messageText: signalerText 99318 "Set an exception's message text." 99319 99320 messageText := signalerText! ! 99321 99322!Exception methodsFor: 'signaling' stamp: 'ajh 2/1/2003 01:33'! 99323signal 99324 "Ask ContextHandlers in the sender chain to handle this signal. The default is to execute and return my defaultAction." 99325 99326 signalContext := thisContext contextTag. 99327 ^ thisContext nextHandlerContext handleSignal: self! ! 99328 99329!Exception methodsFor: 'signaling' stamp: 'ajh 9/30/2001 20:13'! 99330signal: signalerText 99331 "Signal the occurrence of an exceptional condition with a specified textual description." 99332 99333 self messageText: signalerText. 99334 ^ self signal! ! 99335 99336"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 99337 99338Exception class 99339 instanceVariableNames: ''! 99340 99341!Exception class methodsFor: 'exceptioninstantiator' stamp: 'ajh 9/30/2001 21:54'! 99342signal 99343 "Signal the occurrence of an exceptional condition." 99344 99345 ^ self new signal! ! 99346 99347!Exception class methodsFor: 'exceptioninstantiator' stamp: 'ajh 9/30/2001 21:54'! 99348signal: signalerText 99349 "Signal the occurrence of an exceptional condition with a specified textual description." 99350 99351 ^ self new signal: signalerText! ! 99352 99353 99354!Exception class methodsFor: 'exceptionselector' stamp: 'ajh 9/30/2001 15:33'! 99355, anotherException 99356 "Create an exception set." 99357 99358 ^ExceptionSet new 99359 add: self; 99360 add: anotherException; 99361 yourself! ! 99362 99363!Exception class methodsFor: 'exceptionselector' stamp: 'ajh 8/5/2003 11:33'! 99364handles: exception 99365 "Determine whether an exception handler will accept a signaled exception." 99366 99367 ^ exception isKindOf: self! ! 99368Notification subclass: #ExceptionAboutToReturn 99369 instanceVariableNames: '' 99370 classVariableNames: '' 99371 poolDictionaries: '' 99372 category: 'Exceptions-Kernel'! 99373!ExceptionAboutToReturn commentStamp: '<historical>' prior: 0! 99374This class is private to the EHS implementation. Its use allows for ensured execution to survive code such as: 99375 99376[self doThis. 99377^nil] 99378 ensure: [self doThat] 99379 99380Signaling or handling this exception is not recommended. Not even slightly.! 99381 99382Object subclass: #ExceptionSet 99383 instanceVariableNames: 'exceptions' 99384 classVariableNames: '' 99385 poolDictionaries: '' 99386 category: 'Exceptions-Kernel'! 99387!ExceptionSet commentStamp: '<historical>' prior: 0! 99388An ExceptionSet is a grouping of exception handlers which acts as a single handler. Within the group, the most recently added handler will be the last handler found during a handler search (in the case where more than one handler in the group is capable of handling a given exception). ! 99389 99390 99391!ExceptionSet methodsFor: 'exceptionselector' stamp: 'tfei 6/4/1999 18:37'! 99392, anException 99393 "Return an exception set that contains the receiver and the argument exception. This is commonly used to specify a set of exception selectors for an exception handler." 99394 99395 self add: anException. 99396 ^self! ! 99397 99398!ExceptionSet methodsFor: 'exceptionselector' stamp: 'pnm 8/16/2000 15:15'! 99399handles: anException 99400 "Determine whether an exception handler will accept a signaled exception." 99401 99402 exceptions do: 99403 [:ex | 99404 (ex handles: anException) 99405 ifTrue: [^true]]. 99406 ^false! ! 99407 99408 99409!ExceptionSet methodsFor: 'private' stamp: 'tfei 7/16/1999 1:07'! 99410add: anException 99411 99412 exceptions add: anException! ! 99413 99414!ExceptionSet methodsFor: 'private' stamp: 'alain.plantec 5/28/2009 09:52'! 99415initialize 99416 99417 super initialize. 99418 exceptions := OrderedCollection new! ! 99419Object subclass: #ExceptionTester 99420 instanceVariableNames: 'log suiteLog iterationsBeforeTimeout' 99421 classVariableNames: '' 99422 poolDictionaries: '' 99423 category: 'Tests-Exceptions'! 99424 99425!ExceptionTester methodsFor: 'accessing' stamp: 'dtl 6/1/2004 21:53'! 99426basicANSISignaledExceptionTestSelectors 99427 99428 ^#( simpleIsNestedTest simpleOuterTest doubleOuterTest doubleOuterPassTest doublePassOuterTest simplePassTest simpleResignalAsTest simpleResumeTest simpleRetryTest simpleRetryUsingTest simpleReturnTest)! ! 99429 99430!ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:54'! 99431basicTestSelectors 99432 ^ #(#simpleEnsureTest #simpleEnsureTestWithNotification #simpleEnsureTestWithUparrow #simpleEnsureTestWithError #signalFromHandlerActionTest #resumableFallOffTheEndHandler #nonResumableFallOffTheEndHandler #doubleResumeTest #simpleTimeoutWithZeroDurationTest #simpleTimeoutTest simpleNoTimeoutTest)! ! 99433 99434!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'! 99435doSomethingElseString 99436 99437 ^'Do something else.'! ! 99438 99439!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'! 99440doSomethingExceptionalString 99441 99442 ^'Do something exceptional.'! ! 99443 99444!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:13'! 99445doSomethingString 99446 99447 ^'Do something.'! ! 99448 99449!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:15'! 99450doYetAnotherThingString 99451 99452 ^'Do yet another thing.'! ! 99453 99454!ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:15'! 99455iterationsBeforeTimeout 99456 99457 ^ iterationsBeforeTimeout! ! 99458 99459!ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:16'! 99460iterationsBeforeTimeout: anInteger 99461 99462 iterationsBeforeTimeout := anInteger! ! 99463 99464!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/7/1999 15:03'! 99465log 99466 99467 log == nil 99468 ifTrue: [log := OrderedCollection new]. 99469 ^log! ! 99470 99471!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:30'! 99472suiteLog 99473 99474 suiteLog == nil 99475 ifTrue: [suiteLog := OrderedCollection new]. 99476 ^suiteLog! ! 99477 99478!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:15'! 99479testString 99480 99481 ^'This is only a test.'! ! 99482 99483 99484!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/8/1999 09:17'! 99485clearLog 99486 99487 log := nil! ! 99488 99489!ExceptionTester methodsFor: 'logging' stamp: 'PeterHugossonMiller 9/3/2009 01:25'! 99490contents 99491 99492 ^( self log 99493 inject: (String new: 80) writeStream 99494 into: 99495 [:result :item | 99496 result 99497 cr; 99498 nextPutAll: item; 99499 yourself] ) contents! ! 99500 99501!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/7/1999 15:03'! 99502log: aString 99503 99504 self log add: aString! ! 99505 99506!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/12/1999 23:07'! 99507logTest: aSelector 99508 99509 self suiteLog add: aSelector! ! 99510 99511!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/8/1999 09:38'! 99512logTestResult: aString 99513 99514 | index | 99515 index := self suiteLog size. 99516 self suiteLog 99517 at: index 99518 put: ((self suiteLog at: index), ' ', aString)! ! 99519 99520 99521!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:13'! 99522doSomething 99523 99524 self log: self doSomethingString! ! 99525 99526!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:14'! 99527doSomethingElse 99528 99529 self log: self doSomethingElseString! ! 99530 99531!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:14'! 99532doSomethingExceptional 99533 99534 self log: self doSomethingExceptionalString! ! 99535 99536!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:15'! 99537doYetAnotherThing 99538 99539 self log: self doYetAnotherThingString! ! 99540 99541!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:16'! 99542methodWithError 99543 99544 MyTestError signal: self testString! ! 99545 99546!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:16'! 99547methodWithNotification 99548 99549 MyTestNotification signal: self testString! ! 99550 99551 99552!ExceptionTester methodsFor: 'results' stamp: 'tfei 11/14/1999 17:29'! 99553doubleResumeTestResults 99554 99555 ^OrderedCollection new 99556 add: self doSomethingString; 99557 add: self doSomethingElseString; 99558 add: self doYetAnotherThingString; 99559 yourself! ! 99560 99561!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 09:21'! 99562nonResumableFallOffTheEndHandlerResults 99563 99564 ^OrderedCollection new 99565 add: self doSomethingString; 99566 add: self doSomethingExceptionalString; 99567 add: self doYetAnotherThingString; 99568 yourself! ! 99569 99570!ExceptionTester methodsFor: 'results' stamp: 'tfei 8/19/1999 02:39'! 99571resumableFallOffTheEndHandlerResults 99572 99573 ^OrderedCollection new 99574 add: self doSomethingString; 99575 add: self doSomethingExceptionalString; 99576 add: self doYetAnotherThingString; 99577 yourself! ! 99578 99579!ExceptionTester methodsFor: 'results' stamp: 'tfei 8/19/1999 01:51'! 99580signalFromHandlerActionTestResults 99581 99582 ^OrderedCollection new 99583 add: self doSomethingString; 99584 add: self doYetAnotherThingString; 99585 add: 'Unhandled Exception'; 99586 yourself! ! 99587 99588!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 09:47'! 99589simpleEnsureTestResults 99590 99591 ^OrderedCollection new 99592 add: self doSomethingString; 99593 add: self doSomethingElseString; 99594 add: self doYetAnotherThingString; 99595 yourself! ! 99596 99597!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/9/1999 17:44'! 99598simpleEnsureTestWithErrorResults 99599 99600 ^OrderedCollection new 99601 add: self doSomethingString; 99602 add: 'Unhandled Exception'; 99603 add: self doYetAnotherThingString; 99604 yourself! ! 99605 99606!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 10:13'! 99607simpleEnsureTestWithNotificationResults 99608 99609 ^OrderedCollection new 99610 add: self doSomethingString; 99611 add: self doSomethingElseString; 99612 add: self doYetAnotherThingString; 99613 yourself! ! 99614 99615!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 18:55'! 99616simpleEnsureTestWithUparrowResults 99617 99618 ^OrderedCollection new 99619 add: self doSomethingString; 99620" add: self doSomethingElseString;" 99621 add: self doYetAnotherThingString; 99622 yourself! ! 99623 99624!ExceptionTester methodsFor: 'results' stamp: 'brp 10/21/2004 16:54'! 99625simpleNoTimeoutTestResults 99626 99627 ^OrderedCollection new 99628 add: self doSomethingString; 99629 yourself! ! 99630 99631!ExceptionTester methodsFor: 'results' stamp: 'brp 10/21/2004 17:44'! 99632simpleTimeoutTestResults 99633 99634 | things | 99635 things := OrderedCollection new: self iterationsBeforeTimeout. 99636 99637 self iterationsBeforeTimeout timesRepeat: [ things add: self doSomethingString ]. 99638 things add: self doSomethingElseString. 99639 99640 ^ things! ! 99641 99642!ExceptionTester methodsFor: 'results' stamp: 'brp 10/21/2004 16:52'! 99643simpleTimeoutWithZeroDurationTestResults 99644 99645 ^OrderedCollection new 99646 add: self doSomethingElseString; 99647 yourself! ! 99648 99649 99650!ExceptionTester methodsFor: 'signaledexception results' stamp: 'dtl 6/1/2004 21:56'! 99651doubleOuterPassTestResults 99652 99653 ^OrderedCollection new 99654 add: self doSomethingString; 99655 add: self doYetAnotherThingString; 99656 add: self doSomethingElseString; 99657 yourself! ! 99658 99659!ExceptionTester methodsFor: 'signaledexception results' stamp: 'dtl 6/1/2004 21:56'! 99660doublePassOuterTestResults 99661 99662 ^OrderedCollection new 99663 add: self doSomethingString; 99664 add: self doYetAnotherThingString; 99665 add: self doSomethingElseString; 99666 yourself! ! 99667 99668!ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 01:09'! 99669simpleIsNestedTestResults 99670 99671 ^OrderedCollection new 99672 add: self doSomethingString; 99673 add: self doYetAnotherThingString; 99674 add: self doSomethingElseString; 99675 yourself! ! 99676 99677!ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 01:10'! 99678simpleOuterTestResults 99679 99680 ^OrderedCollection new 99681 add: self doSomethingString; 99682 add: self doYetAnotherThingString; 99683 add: self doSomethingElseString; 99684 yourself! ! 99685 99686!ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 01:10'! 99687simplePassTestResults 99688 99689 ^OrderedCollection new 99690 add: self doSomethingString; 99691 add: self doYetAnotherThingString; 99692 add: 'Unhandled Exception'; 99693 yourself! ! 99694 99695!ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 01:11'! 99696simpleResignalAsTestResults 99697 99698 ^OrderedCollection new 99699 add: self doSomethingString; 99700 add: 'Unhandled Exception'; 99701 yourself! ! 99702 99703!ExceptionTester methodsFor: 'signaledexception results' stamp: 'RAA 12/8/2000 12:59'! 99704simpleResumeTestResults 99705 99706 "see if we can resume twice" 99707 99708 ^OrderedCollection new 99709 add: self doSomethingString; 99710 add: self doYetAnotherThingString; 99711 add: self doSomethingElseString; 99712 add: self doYetAnotherThingString; 99713 add: self doSomethingElseString; 99714 yourself! ! 99715 99716!ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 01:23'! 99717simpleRetryTestResults 99718 99719 ^OrderedCollection new 99720 add: self doSomethingString; 99721 add: self doYetAnotherThingString; 99722 add: self doSomethingString; 99723 add: self doSomethingElseString; 99724 yourself! ! 99725 99726!ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 01:23'! 99727simpleRetryUsingTestResults 99728 99729 ^OrderedCollection new 99730 add: self doSomethingString; 99731 add: self doYetAnotherThingString; 99732 yourself! ! 99733 99734!ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 02:22'! 99735simpleReturnTestResults 99736 99737 ^OrderedCollection new 99738 add: self doSomethingString; 99739 add: self doYetAnotherThingString; 99740 yourself! ! 99741 99742 99743!ExceptionTester methodsFor: 'signaledexception tests' stamp: 'dtl 6/1/2004 21:51'! 99744doubleOuterPassTest 99745 "uses #resume" 99746 99747 [[[self doSomething. 99748 MyTestNotification signal. 99749 self doSomethingExceptional] 99750 on: MyTestNotification 99751 do: [:ex | ex outer. 99752 self doSomethingElse]] 99753 on: MyTestNotification 99754 do: [:ex | ex pass. 99755 self doSomethingExceptional]] 99756 on: MyTestNotification 99757 do: [:ex | self doYetAnotherThing. ex resume]! ! 99758 99759!ExceptionTester methodsFor: 'signaledexception tests' stamp: 'dtl 6/1/2004 21:49'! 99760doubleOuterTest 99761 "uses #resume" 99762 99763 [[[self doSomething. 99764 MyTestNotification signal. 99765 self doSomethingExceptional] 99766 on: MyTestNotification 99767 do: [:ex | ex outer. 99768 self doSomethingExceptional]] 99769 on: MyTestNotification 99770 do: [:ex | ex outer. 99771 self doSomethingElse]] 99772 on: MyTestNotification 99773 do: [:ex | self doYetAnotherThing. ex resume]! ! 99774 99775!ExceptionTester methodsFor: 'signaledexception tests' stamp: 'dtl 6/1/2004 21:52'! 99776doublePassOuterTest 99777 "uses #resume" 99778 99779 [[[self doSomething. 99780 MyTestNotification signal. 99781 self doSomethingExceptional] 99782 on: MyTestNotification 99783 do: [:ex | ex pass. 99784 self doSomethingExceptional]] 99785 on: MyTestNotification 99786 do: [:ex | ex outer. 99787 self doSomethingElse]] 99788 on: MyTestNotification 99789 do: [:ex | self doYetAnotherThing. ex resume]! ! 99790 99791!ExceptionTester methodsFor: 'signaledexception tests' stamp: 'tfei 6/13/1999 01:27'! 99792simpleIsNestedTest 99793 "uses resignalAs:" 99794 99795 [self doSomething. 99796 MyTestError signal. 99797 self doSomethingElse] 99798 on: MyTestError 99799 do: 99800 [:ex | 99801 ex isNested "expecting to detect handler in #runTest:" 99802 ifTrue: 99803 [self doYetAnotherThing. 99804 ex resignalAs: MyTestNotification new]]! ! 99805 99806!ExceptionTester methodsFor: 'signaledexception tests' stamp: 'tpr 5/27/2004 21:50'! 99807simpleOuterTest 99808 "uses #resume" 99809 99810 [[self doSomething. 99811 MyTestNotification signal. 99812 "self doSomethingElse" 99813 self doSomethingExceptional] 99814 on: MyTestNotification 99815 do: [:ex | ex outer. self doSomethingElse]] 99816 on: MyTestNotification 99817 do: [:ex | self doYetAnotherThing. ex resume]! ! 99818 99819!ExceptionTester methodsFor: 'signaledexception tests' stamp: 'tfei 6/13/1999 00:37'! 99820simplePassTest 99821 99822 [self doSomething. 99823 MyTestError signal. 99824 self doSomethingElse] 99825 on: MyTestError 99826 do: 99827 [:ex | 99828 self doYetAnotherThing. 99829 ex pass "expecting handler in #runTest:"]! ! 99830 99831!ExceptionTester methodsFor: 'signaledexception tests' stamp: 'tfei 6/13/1999 02:12'! 99832simpleResignalAsTest 99833 "ExceptionTester new simpleResignalAsTest" 99834 99835 [self doSomething. 99836 MyTestNotification signal. 99837 self doSomethingElse] 99838 on: MyTestNotification 99839 do: 99840 [:ex | ex resignalAs: MyTestError new]! ! 99841 99842!ExceptionTester methodsFor: 'signaledexception tests' stamp: 'RAA 12/8/2000 12:58'! 99843simpleResumeTest 99844 99845 "see if we can resume twice" 99846 99847 | it | 99848 [self doSomething. 99849 it := MyResumableTestError signal. 99850 it = 3 ifTrue: [self doSomethingElse]. 99851 it := MyResumableTestError signal. 99852 it = 3 ifTrue: [self doSomethingElse]. 99853 ] 99854 on: MyResumableTestError 99855 do: 99856 [:ex | 99857 self doYetAnotherThing. 99858 ex resume: 3]! ! 99859 99860!ExceptionTester methodsFor: 'signaledexception tests' stamp: 'tfei 6/13/1999 01:02'! 99861simpleRetryTest 99862 99863 | theMeaningOfLife | 99864 theMeaningOfLife := nil. 99865 [self doSomething. 99866 theMeaningOfLife == nil 99867 ifTrue: [MyTestError signal] 99868 ifFalse: [self doSomethingElse]] 99869 on: MyTestError 99870 do: 99871 [:ex | 99872 theMeaningOfLife := 42. 99873 self doYetAnotherThing. 99874 ex retry]! ! 99875 99876!ExceptionTester methodsFor: 'signaledexception tests' stamp: 'tfei 6/13/1999 01:03'! 99877simpleRetryUsingTest 99878 99879 [self doSomething. 99880 MyTestError signal. 99881 self doSomethingElse] 99882 on: MyTestError 99883 do: 99884 [:ex | ex retryUsing: [self doYetAnotherThing]]! ! 99885 99886!ExceptionTester methodsFor: 'signaledexception tests' stamp: 'tfei 6/13/1999 00:59'! 99887simpleReturnTest 99888 99889 | it | 99890 it := 99891 [self doSomething. 99892 MyTestError signal. 99893 self doSomethingElse] 99894 on: MyTestError 99895 do: [:ex | ex return: 3]. 99896 it = 3 ifTrue: [self doYetAnotherThing]! ! 99897 99898 99899!ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/13/1999 01:25'! 99900runAllTests 99901 "ExceptionTester new runAllTests" 99902 99903 self 99904 runBasicTests; 99905 runBasicANSISignaledExceptionTests! ! 99906 99907!ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/12/1999 23:54'! 99908runBasicANSISignaledExceptionTests 99909 99910 self basicANSISignaledExceptionTestSelectors 99911 do: 99912 [:eachTestSelector | 99913 self runTest: eachTestSelector]! ! 99914 99915!ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/9/1999 16:06'! 99916runBasicTests 99917 99918 self basicTestSelectors 99919 do: 99920 [:eachTestSelector | 99921 self runTest: eachTestSelector]! ! 99922 99923 99924!ExceptionTester methodsFor: 'testing' stamp: 'brp 10/21/2004 17:40'! 99925runTest: aSelector 99926 99927 | actualResult expectedResult | 99928 [ self 99929 logTest: aSelector; 99930 clearLog; 99931 perform: aSelector ] 99932 on: MyTestError do: 99933 [ :ex | self log: 'Unhandled Exception'. 99934 ex return: nil ]. 99935 99936 actualResult := self log. 99937 expectedResult := self perform: (aSelector, #Results) asSymbol. 99938 99939 actualResult = expectedResult 99940 ifTrue: [self logTestResult: 'succeeded'] 99941 ifFalse: [self logTestResult: 'failed' ]. 99942! ! 99943 99944 99945!ExceptionTester methodsFor: 'tests' stamp: 'tfei 11/14/1999 17:26'! 99946doubleResumeTest 99947 99948 [self doSomething. 99949 MyResumableTestError signal. 99950 self doSomethingElse. 99951 MyResumableTestError signal. 99952 self doYetAnotherThing] 99953 on: MyResumableTestError 99954 do: [:ex | ex resume].! ! 99955 99956!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/7/1999 13:43'! 99957nonResumableFallOffTheEndHandler 99958 99959 [self doSomething. 99960 MyTestError signal. 99961 self doSomethingElse] 99962 on: MyTestError 99963 do: [:ex | self doSomethingExceptional]. 99964 self doYetAnotherThing! ! 99965 99966!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/9/1999 16:07'! 99967resumableFallOffTheEndHandler 99968 99969 [self doSomething. 99970 MyTestNotification signal. 99971 self doSomethingElse] 99972 on: MyTestNotification 99973 do: [:ex | self doSomethingExceptional]. 99974 self doYetAnotherThing! ! 99975 99976!ExceptionTester methodsFor: 'tests' stamp: 'tfei 8/19/1999 01:39'! 99977signalFromHandlerActionTest 99978 99979 [self doSomething. 99980 MyTestError signal. 99981 self doSomethingElse] 99982 on: MyTestError 99983 do: 99984 [self doYetAnotherThing. 99985 MyTestError signal]! ! 99986 99987!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 09:44'! 99988simpleEnsureTest 99989 99990 [self doSomething. 99991 self doSomethingElse] 99992 ensure: 99993 [self doYetAnotherThing]. 99994 ! ! 99995 99996!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 12:50'! 99997simpleEnsureTestWithError 99998 99999 [self doSomething. 100000 MyTestError signal. 100001 self doSomethingElse] 100002 ensure: 100003 [self doYetAnotherThing]. 100004 ! ! 100005 100006!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 10:15'! 100007simpleEnsureTestWithNotification 100008 100009 [self doSomething. 100010 self methodWithNotification. 100011 self doSomethingElse] 100012 ensure: 100013 [self doYetAnotherThing]. 100014 ! ! 100015 100016!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/9/1999 16:04'! 100017simpleEnsureTestWithUparrow 100018 100019 [self doSomething. 100020 true ifTrue: [^nil]. 100021 self doSomethingElse] 100022 ensure: 100023 [self doYetAnotherThing]. 100024 ! ! 100025 100026!ExceptionTester methodsFor: 'tests' stamp: 'brp 10/22/2004 12:00'! 100027simpleNoTimeoutTest 100028 100029 [ self doSomething ] 100030 valueWithin: 1 day onTimeout: 100031 [ self doSomethingElse ]. 100032 ! ! 100033 100034!ExceptionTester methodsFor: 'tests' stamp: 'brp 10/22/2004 12:00'! 100035simpleTimeoutTest 100036 100037 | n | 100038 [1 to: 1000000 do: [ :i | n := i. self doSomething ] ] 100039 valueWithin: 50 milliSeconds onTimeout: 100040 [ self iterationsBeforeTimeout: n. 100041 self doSomethingElse ]! ! 100042 100043!ExceptionTester methodsFor: 'tests' stamp: 'brp 10/22/2004 12:00'! 100044simpleTimeoutWithZeroDurationTest 100045 100046 [ self doSomething ] 100047 valueWithin: 0 seconds onTimeout: 100048 [ self doSomethingElse ]. 100049 ! ! 100050 100051!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/7/1999 14:28'! 100052warningTest 100053 100054 self log: 'About to signal warning.'. 100055 Warning signal: 'Ouch'. 100056 self log: 'Warning signal handled and resumed.'! ! 100057TestCase subclass: #ExceptionTests 100058 instanceVariableNames: '' 100059 classVariableNames: '' 100060 poolDictionaries: '' 100061 category: 'Tests-Exceptions'! 100062 100063!ExceptionTests methodsFor: 'testing' stamp: 'brp 10/21/2004 16:42'! 100064testNoTimeout 100065 self assertSuccess: (ExceptionTester new runTest: #simpleNoTimeoutTest ) ! ! 100066 100067!ExceptionTests methodsFor: 'testing' stamp: 'brp 10/21/2004 16:41'! 100068testTimeoutWithZeroDuration 100069 self assertSuccess: (ExceptionTester new runTest: #simpleTimeoutWithZeroDurationTest ) ! ! 100070 100071 100072!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'dtl 6/1/2004 21:54'! 100073testDoubleOuterPass 100074 self assertSuccess: (ExceptionTester new runTest: #doubleOuterPassTest ) ! ! 100075 100076!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'dtl 6/1/2004 21:54'! 100077testDoublePassOuter 100078 self assertSuccess: (ExceptionTester new runTest: #doublePassOuterTest ) ! ! 100079 100080!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:43'! 100081testDoubleResume 100082 self assertSuccess: (ExceptionTester new runTest: #doubleResumeTest ) ! ! 100083 100084!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:44'! 100085testNonResumableFallOffTheEndHandler 100086 self assertSuccess: (ExceptionTester new runTest: #nonResumableFallOffTheEndHandler ) ! ! 100087 100088!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:44'! 100089testResumableFallOffTheEndHandler 100090 self assertSuccess: (ExceptionTester new runTest: #resumableFallOffTheEndHandler ) ! ! 100091 100092!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:44'! 100093testSignalFromHandlerActionTest 100094 self assertSuccess: (ExceptionTester new runTest: #signalFromHandlerActionTest ) ! ! 100095 100096!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:48'! 100097testSimpleEnsure 100098 self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTest ) ! ! 100099 100100!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:45'! 100101testSimpleEnsureTestWithError 100102 self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithError ) ! ! 100103 100104!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:46'! 100105testSimpleEnsureTestWithNotification 100106 self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithNotification ) ! ! 100107 100108!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:45'! 100109testSimpleEnsureTestWithUparrow 100110 self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithUparrow ) ! ! 100111 100112!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:46'! 100113testSimpleIsNested 100114 self assertSuccess: (ExceptionTester new runTest: #simpleIsNestedTest ) ! ! 100115 100116!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:41'! 100117testSimpleOuter 100118 self assertSuccess: (ExceptionTester new runTest: #simpleOuterTest ) ! ! 100119 100120!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:42'! 100121testSimplePass 100122 self assertSuccess: (ExceptionTester new runTest: #simplePassTest ) ! ! 100123 100124!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:43'! 100125testSimpleResignalAs 100126 self assertSuccess: (ExceptionTester new runTest: #simpleResignalAsTest ) ! ! 100127 100128!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:48'! 100129testSimpleResume 100130 self assertSuccess: (ExceptionTester new runTest: #simpleResumeTest ) ! ! 100131 100132!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:48'! 100133testSimpleRetry 100134 self assertSuccess: (ExceptionTester new runTest: #simpleRetryTest ) ! ! 100135 100136!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:47'! 100137testSimpleRetryUsing 100138 self assertSuccess: (ExceptionTester new runTest: #simpleRetryUsingTest ) ! ! 100139 100140!ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:48'! 100141testSimpleReturn 100142 self assertSuccess: (ExceptionTester new runTest: #simpleReturnTest ) ! ! 100143 100144 100145!ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 21:59'! 100146testNonResumableOuter 100147 100148 self should: [ 100149 [Error signal. 4] 100150 on: Error 100151 do: [:ex | ex outer. ex return: 5] 100152 ] raise: Error 100153! ! 100154 100155!ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 22:00'! 100156testNonResumablePass 100157 100158 self should: [ 100159 [Error signal. 4] 100160 on: Error 100161 do: [:ex | ex pass. ex return: 5] 100162 ] raise: Error 100163! ! 100164 100165!ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 22:00'! 100166testResumableOuter 100167 100168 | result | 100169 result := [Notification signal. 4] 100170 on: Notification 100171 do: [:ex | ex outer. ex return: 5]. 100172 self assert: result == 5 100173! ! 100174 100175!ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 22:00'! 100176testResumablePass 100177 100178 | result | 100179 result := [Notification signal. 4] 100180 on: Notification 100181 do: [:ex | ex pass. ex return: 5]. 100182 self assert: result == 4 100183! ! 100184 100185 100186!ExceptionTests methodsFor: 'private' stamp: 'md 3/25/2003 23:40'! 100187assertSuccess: anExceptionTester 100188 self should: [ ( anExceptionTester suiteLog first) endsWith: 'succeeded'].! ! 100189NonReentrantWeakMessageSend weakSubclass: #ExclusiveWeakMessageSend 100190 instanceVariableNames: '' 100191 classVariableNames: '' 100192 poolDictionaries: '' 100193 category: 'Polymorph-EventEnhancements'! 100194 100195!ExclusiveWeakMessageSend methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:39'! 100196basicExecuting: aValueHolder 100197 "Set the shared value holder." 100198 100199 executing := aValueHolder! ! 100200 100201!ExclusiveWeakMessageSend methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:07'! 100202executing 100203 "Answer from the shared value holder." 100204 100205 ^executing contents! ! 100206 100207!ExclusiveWeakMessageSend methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:06'! 100208executing: aBoolean 100209 "Set on the shared value holder." 100210 100211 executing contents: aBoolean! ! 100212 100213!ExclusiveWeakMessageSend methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:13'! 100214initialize 100215 "Initialize the receiver." 100216 100217 executing := self class newSharedState. 100218 super initialize.! ! 100219 100220"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 100221 100222ExclusiveWeakMessageSend class 100223 instanceVariableNames: ''! 100224 100225!ExclusiveWeakMessageSend class methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:13'! 100226newSharedState 100227 "Answer a new ValueHolder with false as the contents." 100228 100229 ^ValueHolder new contents: false! ! 100230PanelMorph subclass: #ExpanderMorph 100231 instanceVariableNames: 'titleMorph' 100232 classVariableNames: '' 100233 poolDictionaries: '' 100234 category: 'Polymorph-Widgets'! 100235!ExpanderMorph commentStamp: 'gvc 5/18/2007 13:13' prior: 0! 100236A morph that can expand or collapse to show its contents.! 100237 100238 100239!ExpanderMorph methodsFor: 'accessing' stamp: 'gvc 7/27/2006 10:30'! 100240titleMorph 100241 "Answer the value of titleMorph" 100242 100243 ^ titleMorph! ! 100244 100245!ExpanderMorph methodsFor: 'accessing' stamp: 'gvc 7/27/2006 10:35'! 100246titleMorph: aMorph 100247 "Set the value of titleMorph" 100248 100249 titleMorph ifNotNil: [titleMorph delete; removeDependent: self]. 100250 titleMorph := aMorph. 100251 aMorph ifNotNil: [ 100252 aMorph addDependent: self. 100253 self addMorph: aMorph]! ! 100254 100255 100256!ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 11:24'! 100257addedMorph: aMorph 100258 "Notify the receiver that the given morph was just added." 100259 100260 aMorph == self titleMorph ifFalse: [ 100261 self titleMorph ifNotNil: [ 100262 aMorph 100263 visible: self expanded; 100264 disableTableLayout: self expanded not]]! ! 100265 100266!ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 10:33'! 100267defaultTitleMorph 100268 "Answer a default title morph for the receiver." 100269 100270 ^ExpanderTitleMorph new 100271 hResizing: #spaceFill; 100272 vResizing: #shrinkWrap! ! 100273 100274!ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 11:23'! 100275expanded 100276 "Answer whether the title is expanded." 100277 100278 ^self titleMorph expanded! ! 100279 100280!ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 11:23'! 100281expanded: aBoolean 100282 "Set whether the title is expanded." 100283 100284 self titleMorph expanded: aBoolean! ! 100285 100286!ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/18/2006 11:57'! 100287fixLayout 100288 "Fix the owner layout, nasty!!" 100289 100290 self owner ifNil: [^self]. 100291 self owner allMorphsDo: [:m | 100292 (m respondsTo: #resetExtent) ifTrue: [ 100293 WorldState addDeferredUIMessage: 100294 (MessageSend receiver: m selector: #resetExtent). 100295 WorldState addDeferredUIMessage: 100296 (MessageSend receiver: m selector: #setScrollDeltas)]. 100297 (m isKindOf: self class) 100298 ifTrue: [WorldState addDeferredUIMessage: 100299 (MessageSend receiver: m selector: #adoptPaneColor)]]. 100300 WorldState addDeferredUIMessage: 100301 (MessageSend receiver: self owner selector: #changed)! ! 100302 100303!ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/13/2006 10:29'! 100304font 100305 "Answer the title font" 100306 100307 ^self titleMorph font! ! 100308 100309!ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/13/2006 10:30'! 100310font: aFont 100311 "Set the title font" 100312 100313 self titleMorph font: aFont! ! 100314 100315!ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 10:37'! 100316initialize 100317 "Initialize the receiver." 100318 100319 super initialize. 100320 self 100321 changeTableLayout; 100322 listDirection: #topToBottom; 100323 hResizing: #spaceFill; 100324 vResizing: #shrinkWrap; 100325 titleMorph: self defaultTitleMorph! ! 100326 100327!ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 11:32'! 100328showMorphs: aBoolean 100329 "Hide/Show the other morphs." 100330 100331 self submorphs do: [:m | 100332 m == self titleMorph ifFalse: [ 100333 m 100334 visible: aBoolean; 100335 disableTableLayout: aBoolean not]]! ! 100336 100337!ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 10:55'! 100338titleText: aStringOrText 100339 "Set the text if the title morph is capable." 100340 100341 (self titleMorph respondsTo: #titleText:) 100342 ifTrue: [self titleMorph titleText: aStringOrText]! ! 100343 100344!ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/28/2006 11:26'! 100345update: aspect 100346 "Update the receiver." 100347 100348 aspect = #expanded 100349 ifTrue: [self vResizing: (self expanded 100350 ifTrue: [#spaceFill] 100351 ifFalse: [#shrinkWrap]). 100352 self showMorphs: self expanded. 100353 self fixLayout]! ! 100354 100355"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 100356 100357ExpanderMorph class 100358 instanceVariableNames: ''! 100359 100360!ExpanderMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 10:54'! 100361titleText: aStringOrText 100362 "Answer a new instance of the receiver with the given title text." 100363 100364 ^self new titleText: aStringOrText! ! 100365PanelMorph subclass: #ExpanderTitleMorph 100366 instanceVariableNames: 'labelMorph buttonMorph expanded' 100367 classVariableNames: '' 100368 poolDictionaries: '' 100369 category: 'Polymorph-Widgets'! 100370!ExpanderTitleMorph commentStamp: 'gvc 5/18/2007 13:12' prior: 0! 100371The titlebar area for and ExpanderMorph. Includes title label and expand/collapse button.! 100372 100373 100374!ExpanderTitleMorph methodsFor: 'accessing' stamp: 'gvc 1/22/2009 15:37'! 100375buttonMorph 100376 "Answer the value of buttonMorph" 100377 100378 ^ buttonMorph! ! 100379 100380!ExpanderTitleMorph methodsFor: 'accessing' stamp: 'gvc 1/22/2009 15:37'! 100381buttonMorph: anObject 100382 "Set the value of buttonMorph" 100383 100384 buttonMorph := anObject! ! 100385 100386!ExpanderTitleMorph methodsFor: 'accessing' stamp: 'gvc 7/27/2006 10:16'! 100387expanded 100388 "Answer the value of expanded" 100389 100390 ^ expanded! ! 100391 100392!ExpanderTitleMorph methodsFor: 'accessing' stamp: 'gvc 7/27/2006 10:24'! 100393expanded: aBoolean 100394 "Set the value of expanded" 100395 100396 expanded := aBoolean. 100397 self 100398 changed: #expanded; 100399 changed: #expandLabel! ! 100400 100401!ExpanderTitleMorph methodsFor: 'accessing' stamp: 'gvc 9/13/2006 10:23'! 100402labelMorph 100403 "Answer the value of labelMorph" 100404 100405 ^ labelMorph! ! 100406 100407!ExpanderTitleMorph methodsFor: 'accessing' stamp: 'gvc 3/12/2007 12:55'! 100408labelMorph: anObject 100409 "Set the value of labelMorph. 100410 need to wrap to provide clipping!!" 100411 100412 labelMorph ifNotNil: [self removeMorph: labelMorph owner]. 100413 labelMorph := anObject. 100414 labelMorph ifNotNil: [self addMorph: ( 100415 Morph new 100416 color: Color transparent; 100417 changeTableLayout; 100418 listDirection: #leftToRight; 100419 listCentering: #center; 100420 hResizing: #spaceFill; 100421 vResizing: #shrinkWrap; 100422 clipSubmorphs: true; 100423 addMorph: labelMorph)]! ! 100424 100425 100426!ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/23/2009 16:30'! 100427adoptPaneColor: paneColor 100428 "Update the fill styles, corner styles, label colour 100429 and expansion button indicator." 100430 100431 super adoptPaneColor: paneColor. 100432 paneColor ifNil: [^self]. 100433 self fillStyle: self normalFillStyle. 100434 self borderStyle baseColor: paneColor twiceDarker. 100435 self buttonMorph cornerStyle: self cornerStyle. 100436 self labelMorph color: paneColor contrastingColor. 100437 self changed: #expandLabel! ! 100438 100439!ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/28/2009 17:08'! 100440buttonWidth 100441 "Answer based on scrollbar size." 100442 100443 ^(Preferences scrollBarsNarrow ifTrue: [12] ifFalse: [16]) 100444 max: self theme expanderTitleControlButtonWidth! ! 100445 100446!ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/23/2006 16:46'! 100447defaultBorderStyle 100448 "Answer the default border style for the receiver." 100449 100450 ^BorderStyle raised width: 1! ! 100451 100452!ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/31/2009 16:41'! 100453expandLabel 100454 "Answer the label for the expand button." 100455 100456 ^AlphaImageMorph new image: ( 100457 ScrollBar 100458 arrowOfDirection: (self expanded ifTrue: [#top] ifFalse: [#bottom]) 100459 size: self buttonWidth - 3 100460 color: self paneColor darker)! ! 100461 100462!ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/13/2006 10:29'! 100463font 100464 "Answer the label font" 100465 100466 ^((self labelMorph isKindOf: StringMorph) or: [self labelMorph isTextMorph]) 100467 ifTrue: [self labelMorph font]! ! 100468 100469!ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/13/2006 10:28'! 100470font: aFont 100471 "Set the label font" 100472 100473 ((self labelMorph isKindOf: StringMorph) or: [self labelMorph isTextMorph]) 100474 ifTrue: [self labelMorph font: aFont]! ! 100475 100476!ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/22/2009 15:37'! 100477initialize 100478 "Initialize the receiver." 100479 100480 super initialize. 100481 self 100482 expanded: false; 100483 changeTableLayout; 100484 borderStyle: self defaultBorderStyle; 100485 layoutInset: (self theme expanderTitleInsetFor: self); 100486 listDirection: #leftToRight; 100487 listCentering: #center; 100488 wrapCentering: #center; 100489 buttonMorph: self newExpandButtonMorph; 100490 addMorph: self buttonMorph; 100491 labelMorph: self newLabelMorph; 100492 on: #mouseUp send: #toggleExpanded to: self! ! 100493 100494!ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/22/2009 15:35'! 100495newExpandButtonMorph 100496 "Answer a new expand button." 100497 100498 ^(ControlButtonMorph 100499 on: self 100500 getState: nil 100501 action: #toggleExpanded 100502 label: #expandLabel) 100503 hResizing: #rigid; 100504 vResizing: #spaceFill; 100505 cornerStyle: self cornerStyle; 100506 extent: self buttonWidth asPoint! ! 100507 100508!ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/12/2007 12:57'! 100509newLabelMorph 100510 "Answer a new label morph for the receiver." 100511 100512 ^TextMorph new 100513 hResizing: #spaceFill; 100514 vResizing: #shrinkWrap; 100515 margins: (3@3 corner: 3@0); 100516 lock! ! 100517 100518!ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 14:28'! 100519normalFillStyle 100520 "Return the normal fillStyle of the receiver." 100521 100522 ^self theme expanderTitleNormalFillStyleFor: self! ! 100523 100524!ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/18/2006 11:15'! 100525titleText 100526 "Answer the text if the title morph is capable." 100527 100528 ^((self labelMorph isKindOf: StringMorph) or: [self labelMorph isTextMorph]) 100529 ifTrue: [self labelMorph contents] 100530 ifFalse: ['']! ! 100531 100532!ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/13/2006 10:24'! 100533titleText: aStringOrText 100534 "Set the text if the title morph is capable." 100535 100536 ((self labelMorph isKindOf: StringMorph) or: [self labelMorph isTextMorph]) 100537 ifTrue: [self labelMorph contents: aStringOrText]! ! 100538 100539!ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 10:23'! 100540toggleExpanded 100541 "Toggle the expanded state." 100542 100543 self expanded: self expanded not! ! 100544Clipboard subclass: #ExternalClipboard 100545 instanceVariableNames: 'clipboard' 100546 classVariableNames: '' 100547 poolDictionaries: '' 100548 category: 'System-Clipboard'! 100549!ExternalClipboard commentStamp: 'michael.rueger 3/2/2009 13:25' prior: 0! 100550An ExternalClipboard is the abstract superclass for the platform specific clipboards based on the clipboard plugin (former ExtendedClipboardInterface originally developed for Sophie). 100551 100552Instance Variables 100553 clipboard: SmallInteger 100554 100555clipboard 100556 - handle for the external clipboard. If 0 the external clipboard is invalid 100557! 100558 100559 100560!ExternalClipboard methodsFor: 'accessing' stamp: 'michael.rueger 3/2/2009 13:42'! 100561clearClipboard 100562 clipboard = 0 ifTrue: [^self]. 100563 ^ self primClearClipboard: clipboard.! ! 100564 100565!ExternalClipboard methodsFor: 'accessing' stamp: 'michael.rueger 6/10/2009 13:42'! 100566clipboardText 100567 "Return the text currently in the clipboard. If the system clipboard is empty, or if it differs from the Smalltalk clipboard text, use the Smalltalk clipboard. This is done since (a) the Mac clipboard gives up on very large chunks of text and (b) since not all platforms support the notion of a clipboard." 100568 100569 | decodedString bytes | 100570 clipboard = 0 ifTrue: 100571 [^super clipboardText]. 100572 bytes := self primReadClipboardData: clipboard format: 'public.utf8-plain-text'. 100573 bytes 100574 ifNil: [^super clipboardText]. 100575 decodedString := bytes asString convertFromWithConverter: UTF8TextConverter new. 100576 decodedString := decodedString replaceAll: 10 asCharacter with: 13 asCharacter. 100577 ^decodedString = contents asString 100578 ifTrue: [contents] 100579 ifFalse: [decodedString asText]. 100580! ! 100581 100582!ExternalClipboard methodsFor: 'accessing' stamp: 'michael.rueger 3/25/2009 14:47'! 100583clipboardText: text 100584 100585 | string data | 100586 string := text asString. 100587 self noteRecentClipping: text asText. 100588 contents := text asText. 100589 data := (string convertToWithConverter: UTF8TextConverter new) asByteArray. 100590 clipboard = 0 ifTrue: 100591 [^super clipboardText: text]. 100592 self clearClipboard. 100593 self primAddClipboardData: clipboard data: data dataFormat: 'public.utf8-plain-text'! ! 100594 100595 100596!ExternalClipboard methodsFor: 'initialize' stamp: 'StephaneDucasse 8/30/2009 14:55'! 100597initialize 100598 super initialize. 100599 clipboard := [self createClipboard] on: Error do: [:ex | clipboard := 0]! ! 100600 100601 100602!ExternalClipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/25/2009 14:22'! 100603addClipboardData: data dataFormat: aFormat 100604 clipboard = 0 ifTrue: 100605 [Clipboard clipboardText: data asString. 100606 ^self]. 100607 self primAddClipboardData: clipboard data: data dataFormat: aFormat! ! 100608 100609!ExternalClipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/25/2009 14:25'! 100610primAddClipboardData: aClipboard data: data dataFormat: aFormat 100611 100612 <primitive:'ioAddClipboardData' module: 'ClipboardExtendedPlugin'> 100613 ^ self primitiveFailed! ! 100614 100615!ExternalClipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/2/2009 13:42'! 100616primClearClipboard: aClipboard 100617 <primitive:'ioClearClipboard' module: 'ClipboardExtendedPlugin'> 100618 ^ self primitiveFailed. 100619! ! 100620 100621!ExternalClipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/2/2009 13:42'! 100622primCreateClipboard 100623 <primitive:'ioCreateClipboard' module: 'ClipboardExtendedPlugin'> 100624 ^ self primitiveFailed. 100625! ! 100626 100627!ExternalClipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/25/2009 14:25'! 100628primGetClipboardFormat: aClipboard formatNumber: formatNumber 100629 100630 <primitive:'ioGetClipboardFormat' module: 'ClipboardExtendedPlugin'> 100631 ^ self primitiveFailed! ! 100632 100633!ExternalClipboard methodsFor: 'primitives' stamp: 'marcus.denker 6/11/2009 12:24'! 100634primReadClipboardData: aClipboard format: format 100635 100636 <primitive:'ioReadClipboardData' module: 'ClipboardExtendedPlugin'> 100637 ^ self primitiveFailed! ! 100638 100639 100640!ExternalClipboard methodsFor: 'private' stamp: 'michael.rueger 3/2/2009 13:42'! 100641createClipboard 100642 clipboard = 0 ifTrue: [^self]. 100643 ^ self primCreateClipboard.! ! 100644Object subclass: #ExternalDropHandler 100645 instanceVariableNames: 'action type extension' 100646 classVariableNames: 'DefaultHandler RegisteredHandlers' 100647 poolDictionaries: '' 100648 category: 'System-Support'! 100649 100650!ExternalDropHandler methodsFor: 'accessing' stamp: 'mir 1/10/2002 15:54'! 100651extension 100652 ^extension! ! 100653 100654!ExternalDropHandler methodsFor: 'accessing' stamp: 'mir 1/10/2002 17:29'! 100655handle: dropStream in: pasteUp dropEvent: anEvent 100656 | numArgs | 100657 numArgs := action numArgs. 100658 numArgs == 1 100659 ifTrue: [^action value: dropStream]. 100660 numArgs == 2 100661 ifTrue: [^action value: dropStream value: pasteUp]. 100662 numArgs == 3 100663 ifTrue: [^action value: dropStream value: pasteUp value: anEvent]. 100664 self error: 'Wrong number of args for dop action.'! ! 100665 100666!ExternalDropHandler methodsFor: 'accessing' stamp: 'mir 1/10/2002 15:54'! 100667type 100668 ^type! ! 100669 100670 100671!ExternalDropHandler methodsFor: 'initialize' stamp: 'mir 1/10/2002 17:17'! 100672type: aType extension: anExtension action: anAction 100673 action := anAction. 100674 type := aType. 100675 extension := anExtension! ! 100676 100677 100678!ExternalDropHandler methodsFor: 'testing' stamp: 'spfa 5/25/2004 13:38'! 100679matchesExtension: aExtension 100680 (self extension isNil or: [aExtension isNil]) 100681 ifTrue: [^false]. 100682 FileDirectory activeDirectoryClass isCaseSensitive 100683 ifTrue: [^extension = aExtension] 100684 ifFalse: [^extension sameAs: aExtension]! ! 100685 100686!ExternalDropHandler methodsFor: 'testing' stamp: 'mir 1/10/2002 16:35'! 100687matchesTypes: types 100688 (self type isNil or: [types isNil]) 100689 ifTrue: [^false]. 100690 ^types anySatisfy: [:mimeType | mimeType beginsWith: self type]! ! 100691 100692"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 100693 100694ExternalDropHandler class 100695 instanceVariableNames: ''! 100696 100697!ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 1/10/2002 17:17'! 100698defaultHandler 100699 DefaultHandler ifNil: [DefaultHandler := ExternalDropHandler type: nil extension: nil action: [:dropStream | dropStream edit]]. 100700 ^DefaultHandler! ! 100701 100702!ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 1/10/2002 16:54'! 100703defaultHandler: externalDropHandler 100704 DefaultHandler := externalDropHandler! ! 100705 100706!ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 8/24/2004 15:37'! 100707lookupExternalDropHandler: stream 100708 100709 | types extension serviceHandler | 100710 types := stream mimeTypes. 100711 100712 types ifNotNil: [ 100713 self registeredHandlers do: [:handler | 100714 (handler matchesTypes: types) 100715 ifTrue: [^handler]]]. 100716 100717 extension := FileDirectory extensionFor: stream name. 100718 self registeredHandlers do: [:handler | 100719 (handler matchesExtension: extension) 100720 ifTrue: [^handler]]. 100721 serviceHandler := self lookupServiceBasedHandler: stream. 100722 ^serviceHandler 100723 ifNil: [self defaultHandler]! ! 100724 100725!ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 8/24/2004 17:15'! 100726lookupServiceBasedHandler: dropStream 100727 "the file was just droped, let's do our job" 100728 | fileName services theOne | 100729 fileName := dropStream name. 100730 100731 services := (FileList itemsForFile: fileName) 100732 reject: [:svc | self unwantedSelectors includes: svc selector]. 100733 100734 "no service, default behavior" 100735 services isEmpty 100736 ifTrue: [^nil]. 100737 100738 theOne := self chooseServiceFrom: services. 100739 ^theOne 100740 ifNotNil: [ExternalDropHandler type: nil extension: nil action: [:stream | theOne performServiceFor: stream]]! ! 100741 100742!ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 1/10/2002 17:19'! 100743registerHandler: aHandler 100744 self registeredHandlers add: aHandler! ! 100745 100746 100747!ExternalDropHandler class methodsFor: 'initialization' stamp: 'mir 1/10/2002 17:37'! 100748initialize 100749 "ExternalDropHandler initialize" 100750 100751 self resetRegisteredHandlers. 100752 self 100753 registerHandler: self defaultImageHandler; 100754 registerHandler: self defaultGZipHandler; 100755 registerHandler: self defaultProjectHandler! ! 100756 100757!ExternalDropHandler class methodsFor: 'initialization' stamp: 'nk 6/12/2004 16:15'! 100758registerStandardExternalDropHandlers 100759 "ExternalDropHandler registerStandardExternalDropHandlers" 100760 100761 self registeredHandlers add: ( 100762 ExternalDropHandler 100763 type: 'image/' 100764 extension: nil 100765 action: [:stream :pasteUp :event | 100766 pasteUp addMorph: (World drawingClass withForm: (Form fromBinaryStream: stream binary)) centeredNear: event position])! ! 100767 100768 100769!ExternalDropHandler class methodsFor: 'instance creation' stamp: 'mir 1/10/2002 17:16'! 100770type: aType extension: anExtension action: anAction 100771 ^self new type: aType extension: anExtension action: anAction ! ! 100772 100773 100774!ExternalDropHandler class methodsFor: 'private' stamp: 'alain.plantec 2/8/2009 22:06'! 100775chooseServiceFrom: aCollection 100776 "private - choose a service from aCollection asking the user if 100777 needed" 100778 aCollection size = 1 100779 ifTrue: [^ aCollection anyOne]. 100780 "" 100781 ^ UIManager default chooseFrom: (aCollection collect: [:each | each label]) values: aCollection. 100782! ! 100783 100784!ExternalDropHandler class methodsFor: 'private' stamp: 'mir 1/10/2002 17:23'! 100785defaultGZipHandler 100786 ^ExternalDropHandler 100787 type: nil 100788 extension: 'gz' 100789 action: [:stream :pasteUp :event | 100790 stream viewGZipContents]! ! 100791 100792!ExternalDropHandler class methodsFor: 'private' stamp: 'stephane.ducasse 4/13/2009 21:13'! 100793defaultImageHandler 100794 | image sketch | 100795 ^ExternalDropHandler 100796 type: 'image/' 100797 extension: nil 100798 action: [:stream :pasteUp :event | 100799 stream binary. 100800 image := Form fromBinaryStream: ((RWBinaryOrTextStream with: stream contents) reset). 100801 Project current resourceManager 100802 addResource: image 100803 url: (FileDirectory urlForFileNamed: stream name) asString. 100804 sketch := World drawingClass withForm: image. 100805 pasteUp addMorph: sketch centeredNear: event position. 100806 image := sketch := nil]! ! 100807 100808!ExternalDropHandler class methodsFor: 'private' stamp: 'mir 1/10/2002 17:38'! 100809defaultProjectHandler 100810 ^ExternalDropHandler 100811 type: nil 100812 extension: 'pr' 100813 action: [:stream | 100814 ProjectLoading 100815 openName: nil 100816 stream: stream 100817 fromDirectory: nil 100818 withProjectView: nil] 100819! ! 100820 100821!ExternalDropHandler class methodsFor: 'private' stamp: 'mir 1/10/2002 15:57'! 100822registeredHandlers 100823 RegisteredHandlers ifNil: [RegisteredHandlers := OrderedCollection new]. 100824 ^RegisteredHandlers! ! 100825 100826!ExternalDropHandler class methodsFor: 'private' stamp: 'mir 1/10/2002 15:57'! 100827resetRegisteredHandlers 100828 RegisteredHandlers := nil! ! 100829 100830!ExternalDropHandler class methodsFor: 'private' stamp: 'mir 8/24/2004 15:28'! 100831unwantedSelectors 100832 "private - answer a collection well known unwanted selectors " 100833 ^ #(#removeLineFeeds: #addFileToNewZip: #compressFile: #putUpdate: )! ! 100834Object subclass: #ExternalSemaphoreTable 100835 instanceVariableNames: '' 100836 classVariableNames: 'ProtectTable' 100837 poolDictionaries: '' 100838 category: 'System-Support'! 100839!ExternalSemaphoreTable commentStamp: '<historical>' prior: 0! 100840By John M McIntosh johnmci@smalltalkconsulting.com 100841This class was written to mange the external semaphore table. When I was writing a Socket test server I discovered various race conditions on the access to the externalSemaphore table. This new class uses class side methods to restrict access using a mutex semaphore. It seemed cleaner to deligate the reponsibility here versus adding more code and another class variable to SystemDictionary 100842 100843Note that in Smalltalk recreateSpecialObjectsArray we still directly play with the table.! 100844 100845 100846"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 100847 100848ExternalSemaphoreTable class 100849 instanceVariableNames: ''! 100850 100851!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:36'! 100852clearExternalObjects 100853 "Clear the array of objects that have been registered for use in non-Smalltalk code." 100854 100855 ProtectTable critical: [Smalltalk specialObjectsArray at: 39 put: Array new]. 100856! ! 100857 100858!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 21:01'! 100859externalObjects 100860 ^ProtectTable critical: [Smalltalk specialObjectsArray at: 39].! ! 100861 100862!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:44'! 100863registerExternalObject: anObject 100864 ^ ProtectTable critical: [self safelyRegisterExternalObject: anObject] 100865! ! 100866 100867!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:57'! 100868safelyRegisterExternalObject: anObject 100869 "Register the given object in the external objects array and return its index. If it is already there, just return its index." 100870 100871 | objects firstEmptyIndex obj sz newObjects | 100872 objects := Smalltalk specialObjectsArray at: 39. 100873 100874 "find the first empty slot" 100875 firstEmptyIndex := 0. 100876 1 to: objects size do: [:i | 100877 obj := objects at: i. 100878 obj == anObject ifTrue: [^ i]. "object already there, just return its index" 100879 (obj == nil and: [firstEmptyIndex = 0]) ifTrue: [firstEmptyIndex := i]]. 100880 100881 "if no empty slots, expand the array" 100882 firstEmptyIndex = 0 ifTrue: [ 100883 sz := objects size. 100884 newObjects := objects species new: sz + 20. "grow linearly" 100885 newObjects replaceFrom: 1 to: sz with: objects startingAt: 1. 100886 firstEmptyIndex := sz + 1. 100887 Smalltalk specialObjectsArray at: 39 put: newObjects. 100888 objects := newObjects]. 100889 100890 objects at: firstEmptyIndex put: anObject. 100891 ^ firstEmptyIndex 100892! ! 100893 100894!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:59'! 100895safelyUnregisterExternalObject: anObject 100896 "Unregister the given object in the external objects array. Do nothing if it isn't registered. 100897 JMM change to return if we clear the element, since it should only appear once in the array" 100898 100899 | objects | 100900 anObject ifNil: [^ self]. 100901 objects := Smalltalk specialObjectsArray at: 39. 100902 1 to: objects size do: [:i | 100903 (objects at: i) == anObject ifTrue: 100904 [objects at: i put: nil. 100905 ^self]]. 100906! ! 100907 100908!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:45'! 100909unregisterExternalObject: anObject 100910 ProtectTable critical: [self safelyUnregisterExternalObject: anObject] 100911! ! 100912 100913 100914!ExternalSemaphoreTable class methodsFor: 'initialize' stamp: 'JMM 6/6/2000 20:32'! 100915initialize 100916 ProtectTable := Semaphore forMutualExclusion! ! 100917Object subclass: #ExternalSettings 100918 instanceVariableNames: '' 100919 classVariableNames: 'RegisteredClients' 100920 poolDictionaries: '' 100921 category: 'System-Support'! 100922!ExternalSettings commentStamp: '<historical>' prior: 0! 100923ExternalSettings manages settings kept externally, e.g. files. 100924Objects can register themselves as clients to be notified at startup time to read their settings. 100925 100926Eventually all the preferences should be managed through this mechanism. 100927! 100928 100929 100930"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 100931 100932ExternalSettings class 100933 instanceVariableNames: ''! 100934 100935!ExternalSettings class methodsFor: 'accessing' stamp: 'sw 1/25/2002 12:39'! 100936assuredPreferenceDirectory 100937 "Answer the preference directory, creating it if necessary" 100938 100939 | prefDir | 100940 prefDir := self preferenceDirectory. 100941 prefDir 100942 ifNil: 100943 [prefDir := FileDirectory default directoryNamed: self preferenceDirectoryName. 100944 prefDir assureExistence]. 100945 ^ prefDir! ! 100946 100947!ExternalSettings class methodsFor: 'accessing' stamp: 'dc 5/30/2008 10:17'! 100948parseServerEntryArgsFrom: stream 100949 "Args are in the form <argName>: <argValueString> delimited by end of line. 100950 It's not a very robust format and should be replaced by something like XML later. 100951 But it avoids evaluating the entries for security reasons." 100952 | entries lineStream entryName entryValue | 100953 entries := Dictionary new. 100954 stream skipSeparators. 100955 [ stream atEnd ] whileFalse: 100956 [ lineStream := stream nextLine readStream. 100957 entryName := lineStream upTo: $:. 100958 lineStream skipSeparators. 100959 entryValue := lineStream upToEnd. 100960 (entryName isEmptyOrNil or: [ entryValue isEmptyOrNil ]) ifFalse: 100961 [ entries 100962 at: entryName 100963 put: entryValue withoutTrailingBlanks ]. 100964 stream skipSeparators ]. 100965 ^ entries! ! 100966 100967!ExternalSettings class methodsFor: 'accessing' stamp: 'sd 9/30/2003 14:01'! 100968preferenceDirectory 100969 | prefDirName path | 100970 prefDirName := self preferenceDirectoryName. 100971 path := SmalltalkImage current vmPath. 100972 ^(FileDirectory default directoryExists: prefDirName) 100973 ifTrue: [FileDirectory default directoryNamed: prefDirName] 100974 ifFalse: [ 100975 ((FileDirectory on: path) directoryExists: prefDirName) 100976 ifTrue: [(FileDirectory on: path) directoryNamed: prefDirName] 100977 ifFalse: [nil]] 100978! ! 100979 100980!ExternalSettings class methodsFor: 'accessing' stamp: 'mir 11/16/2001 13:33'! 100981preferenceDirectoryName 100982 ^'prefs'! ! 100983 100984!ExternalSettings class methodsFor: 'accessing' stamp: 'mir 6/25/2001 18:45'! 100985registerClient: anObject 100986 "Register anObject as a settings client to be notified on startup." 100987 100988 self registeredClients add: anObject! ! 100989 100990 100991!ExternalSettings class methodsFor: 'initialization' stamp: 'ar 8/23/2001 22:56'! 100992initialize 100993 "ExternalSettings initialize" 100994 "Order: ExternalSettings, SecurityManager, AutoStart" 100995 Smalltalk addToStartUpList: self. 100996 Smalltalk addToShutDownList: self! ! 100997 100998!ExternalSettings class methodsFor: 'initialization' stamp: 'mir 8/22/2001 15:17'! 100999shutDown 101000 "Look for external defs and load them." 101001 "ExternalSettings shutDown" 101002 101003 self registeredClients do: [:client | 101004 client releaseExternalSettings]! ! 101005 101006!ExternalSettings class methodsFor: 'initialization' stamp: 'mir 11/16/2001 13:29'! 101007startUp 101008 "Look for external defs and load them." 101009 "ExternalSettings startUp" 101010 101011 | prefDir | 101012 prefDir := self preferenceDirectory. 101013 prefDir 101014 ifNil: [^self]. 101015 self registeredClients do: [:client | 101016 client fetchExternalSettingsIn: prefDir]! ! 101017 101018 101019!ExternalSettings class methodsFor: 'private' stamp: 'mir 6/25/2001 18:46'! 101020registeredClients 101021 RegisteredClients ifNil: [RegisteredClients := Set new]. 101022 ^RegisteredClients! ! 101023Object subclass: #FT2BitmapSize 101024 instanceVariableNames: 'height width size xPpEm yPpEm' 101025 classVariableNames: '' 101026 poolDictionaries: '' 101027 category: 'FreeType-Base'! 101028!FT2BitmapSize commentStamp: '<historical>' prior: 0! 101029Do not rearrange these fields!! 101030 101031This structure models the size of a bitmap strike (i.e., a bitmap 101032instance of the font for a given resolution) in a fixed-size font 101033face. It is used for the `availableSizes' field of the 101034FT2Face structure. 101035 101036<Fields> 101037height :: The (vertical) baseline-to-baseline distance in pixels. 101038It makes most sense to define the height of a bitmap 101039font in this way. 101040 101041width :: The average width of the font (in pixels). Since the 101042algorithms to compute this value are different for the 101043various bitmap formats, it can only give an additional 101044hint if the `height' value isn't sufficient to select 101045the proper font. For monospaced fonts the average width 101046is the same as the maximum width. 101047 101048size :: The point size in 26.6 fractional format this font shall 101049represent (for a given vertical resolution). 101050 101051x_ppem :: The horizontal ppem value (in 26.6 fractional format). 101052 101053y_ppem :: The vertical ppem value (in 26.6 fractional format). 101054Usually, this is the `nominal' pixel height of the font. 101055 101056<Note> 101057The values in this structure are taken from the bitmap font. If 101058the font doesn't provide a parameter it is set to zero to indicate 101059that the information is not available. 101060 101061The following formula converts from dpi to ppem: 101062 101063ppem = size * dpi / 72 101064 101065where `size' is in points. 101066 101067Windows FNT: 101068The `size' parameter is not reliable: There exist fonts (e.g., 101069app850.fon) which have a wrong size for some subfonts; x_ppem 101070and y_ppem are thus set equal to pixel width and height given in 101071in the Windows FNT header. 101072 101073TrueType embedded bitmaps: 101074`size', `width', and `height' values are not contained in the 101075bitmap strike itself. They are computed from the global font 101076parameters. 101077! 101078 101079SharedPool subclass: #FT2Constants 101080 instanceVariableNames: '' 101081 classVariableNames: 'LoadCropBitmap LoadDefault LoadForceAutohint LoadIgnoreGlobalAdvanceWidth LoadIgnoreTransform LoadLinearDesign LoadMonochrome LoadNoAutohint LoadNoBitmap LoadNoHinting LoadNoRecurse LoadNoScale LoadPedantic LoadRender LoadSbitsOnly LoadTargetLCD LoadTargetLCDV LoadTargetLight LoadTargetMono LoadTargetNormal LoadVerticalLayout PixelModeGray PixelModeGray2 PixelModeGray4 PixelModeLCD PixelModeLCDV PixelModeMono PixelModeNone RenderModeLCD RenderModeLCDV RenderModeLight RenderModeMono RenderModeNormal StyleFlagBold StyleFlagItalic' 101082 poolDictionaries: '' 101083 category: 'FreeType-Base'! 101084!FT2Constants commentStamp: '<historical>' prior: 0! 101085The various flags from the Freetype/2 header. 101086 101087The LoadXXXX flags can be used with primitiveLoadGlyph:flags: or with the Cairo primCairoFtFontCreateForFtFace:flags:scale: primitives. 101088 101089FT_LOAD_DEFAULT :: 101090 Corresponding to 0, this value is used a default glyph load. In this 101091 case, the following will happen: 101092 101093 1. FreeType looks for a bitmap for the glyph corresponding to the 101094 face's current size. If one is found, the function returns. The 101095 bitmap data can be accessed from the glyph slot (see note below). 101096 101097 2. If no embedded bitmap is searched or found, FreeType looks for a 101098 scalable outline. If one is found, it is loaded from the font 101099 file, scaled to device pixels, then "hinted" to the pixel grid in 101100 order to optimize it. The outline data can be accessed from the 101101 glyph slot (see note below). 101102 101103 Note that by default, the glyph loader doesn't render outlines into 101104 bitmaps. The following flags are used to modify this default 101105 behaviour to more specific and useful cases. 101106 101107FT_LOAD_NO_SCALE :: 101108 Don't scale the vector outline being loaded to 26.6 fractional 101109 pixels, but kept in font units. Note that this also disables 101110 hinting and the loading of embedded bitmaps. You should only use it 101111 when you want to retrieve the original glyph outlines in font units. 101112 101113FT_LOAD_NO_HINTING :: 101114 Don't hint glyph outlines after their scaling to device pixels. 101115 This generally generates "blurrier" glyphs in anti-aliased modes. 101116 101117 This flag is ignored if @FT_LOAD_NO_SCALE is set. 101118 101119FT_LOAD_RENDER :: 101120 Render the glyph outline immediately into a bitmap before the glyph 101121 loader returns. By default, the glyph is rendered for the 101122 @FT_RENDER_MODE_NORMAL mode, which corresponds to 8-bit anti-aliased 101123 bitmaps using 256 opacity levels. You can use either 101124 @FT_LOAD_TARGET_MONO or @FT_LOAD_MONOCHROME to render 1-bit 101125 monochrome bitmaps. 101126 101127 This flag is ignored if @FT_LOAD_NO_SCALE is set. 101128 101129FT_LOAD_NO_BITMAP :: 101130 Don't look for bitmaps when loading the glyph. Only scalable 101131 outlines will be loaded when available, and scaled, hinted, or 101132 rendered depending on other bit flags. 101133 101134 This does not prevent you from rendering outlines to bitmaps 101135 with @FT_LOAD_RENDER, however. 101136 101137FT_LOAD_VERTICAL_LAYOUT :: 101138 Prepare the glyph image for vertical text layout. This basically 101139 means that `face.glyph.advance' will correspond to the vertical 101140 advance height (instead of the default horizontal advance width), 101141 and that the glyph image will be translated to match the vertical 101142 bearings positions. 101143 101144FT_LOAD_FORCE_AUTOHINT :: 101145 Force the use of the FreeType auto-hinter when a glyph outline is 101146 loaded. You shouldn't need this in a typical application, since it 101147 is mostly used to experiment with its algorithm. 101148 101149FT_LOAD_CROP_BITMAP :: 101150 Indicates that the glyph loader should try to crop the bitmap (i.e., 101151 remove all space around its black bits) when loading it. This is 101152 only useful when loading embedded bitmaps in certain fonts, since 101153 bitmaps rendered with @FT_LOAD_RENDER are always cropped by default. 101154 101155FT_LOAD_PEDANTIC :: 101156 Indicates that the glyph loader should perform pedantic 101157 verifications during glyph loading, rejecting invalid fonts. This 101158 is mostly used to detect broken glyphs in fonts. By default, 101159 FreeType tries to handle broken fonts also. 101160 101161FT_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH :: 101162 Indicates that the glyph loader should ignore the global advance 101163 width defined in the font. As far as we know, this is only used by 101164 the X-TrueType font server, in order to deal correctly with the 101165 incorrect metrics contained in DynaLab's TrueType CJK fonts. 101166 101167FT_LOAD_NO_RECURSE :: 101168 This flag is only used internally. It merely indicates that the 101169 glyph loader should not load composite glyphs recursively. Instead, 101170 it should set the `num_subglyph' and `subglyphs' values of the glyph 101171 slot accordingly, and set "glyph->format" to 101172 @FT_GLYPH_FORMAT_COMPOSITE. 101173 101174 The description of sub-glyphs is not available to client 101175 applications for now. 101176 101177FT_LOAD_IGNORE_TRANSFORM :: 101178 Indicates that the glyph loader should not try to transform the 101179 loaded glyph image. This doesn't prevent scaling, hinting, or 101180 rendering. 101181 101182FT_LOAD_MONOCHROME :: 101183 This flag is used with @FT_LOAD_RENDER to indicate that you want 101184 to render a 1-bit monochrome glyph bitmap from a vectorial outline. 101185 101186 Note that this has no effect on the hinting algorithm used by the 101187 glyph loader. You should better use @FT_LOAD_TARGET_MONO if you 101188 want to render monochrome-optimized glyph images instead. 101189 101190FT_LOAD_LINEAR_DESIGN :: 101191 Return the linearly scaled metrics expressed in original font units 101192 instead of the default 16.16 pixel values. 101193 101194FT_LOAD_NO_AUTOHINT :: 101195 Indicates that the auto-hinter should never be used to hint glyph 101196 outlines. This doesn't prevent native format-specific hinters from 101197 being used. This can be important for certain fonts where unhinted 101198 output is better than auto-hinted one. 101199 101200One of following flags (as LoadTargetXXX) can be used to further specify the result. 101201 101202 FT_RENDER_MODE_NORMAL :: 101203 This is the default render mode; it corresponds to 8-bit 101204 anti-aliased bitmaps, using 256 levels of opacity. 101205 101206 FT_RENDER_MODE_LIGHT :: 101207 This is similar to @FT_RENDER_MODE_NORMAL, except that this 101208 changes the hinting to prevent stem width quantization. This 101209 results in glyph shapes that are more similar to the original, 101210 while being a bit more fuzzy ("better shapes", instead of 101211 "better contrast" if you want :-). 101212 101213 FT_RENDER_MODE_MONO :: 101214 This mode corresponds to 1-bit bitmaps. 101215 101216 FT_RENDER_MODE_LCD :: 101217 This mode corresponds to horizontal RGB/BGR sub-pixel displays, 101218 like LCD-screens. It produces 8-bit bitmaps that are 3 times 101219 the width of the original glyph outline in pixels, and which use 101220 the @FT_PIXEL_MODE_LCD mode. 101221 101222 FT_RENDER_MODE_LCD_V :: 101223 This mode corresponds to vertical RGB/BGR sub-pixel displays 101224 (like PDA screens, rotated LCD displays, etc.). It produces 101225 8-bit bitmaps that are 3 times the height of the original 101226 glyph outline in pixels and use the @FT_PIXEL_MODE_LCD_V mode. 101227 101228<Note> 101229 The LCD-optimized glyph bitmaps produced by FT_Render_Glyph are 101230 _not filtered_ to reduce color-fringes. It is up to the caller to 101231 perform this pass. 101232 101233! 101234 101235 101236"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 101237 101238FT2Constants class 101239 instanceVariableNames: ''! 101240 101241!FT2Constants class methodsFor: 'class initialization' stamp: 'tween 8/13/2006 15:55'! 101242initialize 101243 "FT2Constants initialize" 101244 101245 LoadDefault := 0. 101246 LoadNoScale := 1. 101247 LoadNoHinting := 2. 101248 LoadRender := 4. 101249 LoadNoBitmap := 8. 101250 LoadVerticalLayout := 16. 101251 LoadForceAutohint := 32. 101252 LoadCropBitmap := 64. 101253 LoadPedantic := 128. 101254 LoadIgnoreGlobalAdvanceWidth := 512. 101255 LoadNoRecurse := 1024. 101256 LoadIgnoreTransform := 2048. 101257 LoadMonochrome := 4096. 101258 LoadLinearDesign := 8192. 101259 LoadSbitsOnly := 16384. 101260 LoadNoAutohint := 32768. 101261 101262 "One of these flags may be OR'd with the above." 101263 LoadTargetNormal := 0. 101264 LoadTargetLight := 1 bitShift: 16. 101265 LoadTargetMono := 2 bitShift: 16. 101266 LoadTargetLCD := 3 bitShift: 16. 101267 LoadTargetLCDV := 4 bitShift: 16. 101268 101269 "rendering mode constants" 101270 RenderModeNormal := 0. 101271 RenderModeLight := 1. 101272 RenderModeMono := 2. 101273 RenderModeLCD := 3. 101274 RenderModeLCDV := 4. 101275 101276 "pixel mode constants" 101277 PixelModeNone := 0. 101278 PixelModeMono := 1. 101279 PixelModeGray := 2. 101280 PixelModeGray2 := 3. 101281 PixelModeGray4 := 4. 101282 PixelModeLCD := 5. 101283 PixelModeLCDV := 6. 101284 101285 StyleFlagItalic := 1. 101286 StyleFlagBold := 2. 101287! ! 101288Error subclass: #FT2Error 101289 instanceVariableNames: 'errorCode errorString' 101290 classVariableNames: '' 101291 poolDictionaries: '' 101292 category: 'FreeType-Base'! 101293!FT2Error commentStamp: '<historical>' prior: 0! 101294This is an Error that knows how to get the Freetype2 error code and string.! 101295 101296 101297!FT2Error methodsFor: 'accessing' stamp: 'nk 11/4/2004 13:31'! 101298errorCode 101299 errorCode 101300 ifNotNil: [^ errorCode]. 101301 ^ errorCode := [FT2Library errorCode] 101302 on: Error 101303 do: [:ex | ex return: 'can''t get error code']! ! 101304 101305!FT2Error methodsFor: 'accessing' stamp: 'nk 11/4/2004 13:31'! 101306errorString 101307 errorString 101308 ifNotNil: [^ errorString]. 101309 ^ errorString := [FT2Library errorString] 101310 on: Error 101311 do: [:ex | ex return: 'can''t get error string']! ! 101312 101313!FT2Error methodsFor: 'accessing' stamp: 'nk 3/17/2005 12:50'! 101314messageText 101315 ^String streamContents: [ :strm | 101316 messageText ifNotNil: [ strm nextPutAll: messageText; space ]. 101317 self errorCode isZero ifFalse: [ 101318 strm nextPutAll: '[error '; print: self errorCode; nextPutAll: ']['; 101319 nextPutAll: self errorString; 101320 nextPut: $] ]]! ! 101321FT2Handle subclass: #FT2Face 101322 instanceVariableNames: 'numFaces faceIndex faceFlags styleFlags numGlyphs familyName styleName numFixedSizes availableSizes numCharmaps charmaps bbox unitsPerEm ascender descender height maxAdvanceWidth maxAdvanceHeight underlinePosition underlineThickness glyph encoding platformId encodingId size' 101323 classVariableNames: '' 101324 poolDictionaries: '' 101325 category: 'FreeType-Base'! 101326!FT2Face commentStamp: '<historical>' prior: 0! 101327Do not rearrange these fields!! 101328New fields should go at the end, because the plugin has to know about these indexes. 101329 101330ByteArray representing a pointer to the malloc'd FT_Face struct: 101331handle 101332 101333Copied from the FT_Face struct on creation: 101334numFaces faceIndex faceFlags styleFlags numGlyphs familyName styleName numFixedSizes availableSizes numCharmaps charmaps 101335 101336Copied on creation, but only relevant to scalable outlines: 101337bbox unitsPerEm ascender descender height maxAdvanceWidth maxAdvanceHeight underlinePosition underlineThickness 101338 101339Working memory: 101340glyph -- FT2GlyphSlot, set by loadGlyph or loadChar 101341size -- the active size, set by activateSize, used by loadGlyph, getKerning, etc. 101342charmap -- set by setCharmap 101343! 101344 101345 101346!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101347ascender 101348 ^ascender! ! 101349 101350!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101351availableSizes 101352 ^availableSizes! ! 101353 101354!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 17:06'! 101355bbox 101356 bbox 101357 ifNil: [bbox := Rectangle new. 101358 self primLoadBbox: bbox]. 101359 ^ bbox! ! 101360 101361!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 21:05'! 101362charmaps 101363 "Answer an Array of Strings naming the different character maps available for setCharMap:" 101364 charmaps ifNil: [ 101365 charmaps := Array new: numCharmaps. 101366 self getCharMapsInto: charmaps ]. 101367 ^charmaps! ! 101368 101369!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101370descender 101371 ^descender! ! 101372 101373!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 20:46'! 101374encoding 101375 encoding ifNil: [ self getCharMap ]. 101376 ^encoding! ! 101377 101378!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101379faceFlags 101380 ^faceFlags! ! 101381 101382!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101383faceIndex 101384 ^faceIndex! ! 101385 101386!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101387familyName 101388 ^familyName! ! 101389 101390!FT2Face methodsFor: 'accessing' stamp: 'bf 11/17/2005 15:56'! 101391glyph 101392 glyph ifNil: [ glyph := FT2GlyphSlot fromFace: self ]. 101393 ^glyph! ! 101394 101395!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101396handle 101397 ^handle! ! 101398 101399!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101400height 101401 ^height! ! 101402 101403!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101404maxAdvanceHeight 101405 ^maxAdvanceHeight! ! 101406 101407!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101408maxAdvanceWidth 101409 ^maxAdvanceWidth! ! 101410 101411!FT2Face methodsFor: 'accessing' stamp: 'tween 7/24/2006 22:49'! 101412memoryFaceData 101413 self subclassResponsibility! ! 101414 101415!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101416numCharmaps 101417 ^numCharmaps! ! 101418 101419!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101420numFaces 101421 ^numFaces! ! 101422 101423!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101424numFixedSizes 101425 ^numFixedSizes! ! 101426 101427!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101428numGlyphs 101429 ^numGlyphs! ! 101430 101431!FT2Face methodsFor: 'accessing' stamp: 'tween 8/11/2007 11:24'! 101432postscriptName 101433 ^self primGetPostscriptName! ! 101434 101435!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101436size 101437 ^size! ! 101438 101439!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101440styleFlags 101441 ^styleFlags! ! 101442 101443!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101444styleName 101445 ^styleName! ! 101446 101447!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101448underlinePosition 101449 ^underlinePosition! ! 101450 101451!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101452underlineThickness 101453 ^underlineThickness! ! 101454 101455!FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! 101456unitsPerEm 101457 ^unitsPerEm! ! 101458 101459 101460!FT2Face methodsFor: 'charmaps' stamp: 'nk 11/3/2004 19:36'! 101461getCharMap 101462 self primGetCharMap.! ! 101463 101464!FT2Face methodsFor: 'charmaps' stamp: 'nk 11/3/2004 20:38'! 101465getCharMapsInto: array 101466 self primGetCharMapsInto: array.! ! 101467 101468!FT2Face methodsFor: 'charmaps' stamp: 'nk 11/3/2004 20:39'! 101469setCharMap: encodingString 101470 self primSetCharMap: encodingString. 101471 self primGetCharMap. 101472! ! 101473 101474 101475!FT2Face methodsFor: 'glyphs' stamp: 'jl 5/30/2006 14:08'! 101476glyphOfCharacter: aCharacter 101477 "load a glyph with outline, glyph is not scaled " 101478 | em aGlyph | 101479 em := self unitsPerEm. 101480 self validate. 101481 self setPixelWidth: em height: em. 101482 self loadCharacter: aCharacter asInteger flags: LoadIgnoreTransform. "load glyph metrics" 101483 aGlyph := self glyph shallowCopy. " copy because 'face glyph' is only a slot" 101484 aGlyph outline: (self characterOutline: aCharacter). 101485 ^aGlyph! ! 101486 101487!FT2Face methodsFor: 'glyphs' stamp: 'nk 11/3/2004 18:25'! 101488loadCharacter: index flags: flags 101489 self primLoadCharacter: index flags: flags. 101490 glyph 101491 ifNil: [ glyph := FT2GlyphSlot fromFace: self ] 101492 ifNotNil: [ glyph loadFrom: self ]. 101493! ! 101494 101495!FT2Face methodsFor: 'glyphs' stamp: 'nk 11/3/2004 18:25'! 101496loadGlyph: index flags: flags 101497 self primLoadGlyph: index flags: flags. 101498 glyph 101499 ifNil: [ glyph := FT2GlyphSlot fromFace: self ] 101500 ifNotNil: [ glyph loadFrom: self ]. 101501! ! 101502 101503!FT2Face methodsFor: 'glyphs' stamp: 'nk 11/3/2004 18:23'! 101504setPixelWidth: x height: y 101505 self primSetPixelWidth: x height: y! ! 101506 101507 101508!FT2Face methodsFor: 'initialize-release' stamp: 'tween 8/12/2006 10:01'! 101509newFaceFromExternalMemory: aFreeTypeExternalMemory index: anInteger 101510 | memSize | 101511 101512 aFreeTypeExternalMemory validate. 101513 memSize := aFreeTypeExternalMemory bytes size. 101514 [self 101515 primNewFaceFromExternalMemory: aFreeTypeExternalMemory 101516 size: memSize 101517 index: anInteger] 101518 on: FT2Error 101519 do:[:e |"need to do something here?"]. 101520 self isValid ifTrue:[self class register: self]! ! 101521 101522!FT2Face methodsFor: 'initialize-release' stamp: 'tween 3/16/2007 03:58'! 101523newFaceFromFile: fileName index: anInteger 101524 [self primNewFaceFromFile: fileName index: anInteger] 101525 on: FT2Error 101526 do:[:e | ^self "need to do something here?"]. 101527 self class register: self.! ! 101528 101529 101530!FT2Face methodsFor: 'kerning' stamp: 'tween 3/11/2007 21:17'! 101531kerningLeft: leftCharacter right: rightCharacter 101532 [^self primGetKerningLeft: (self primGetCharIndex: leftCharacter asInteger) 101533 right: (self primGetCharIndex: rightCharacter asInteger) 101534 ] on: FT2Error do:[:e | ^0@0]! ! 101535 101536 101537!FT2Face methodsFor: 'outlines' stamp: 'jl 5/24/2006 15:22'! 101538loadCharacterOutline: index flags: flags 101539 | em outline | 101540 em := unitsPerEm. 101541 self setPixelWidth: em height: em. 101542 self loadCharacter: index flags: flags. 101543 outline := FT2Outline new. 101544 outline primLoadSizesFrom: self. 101545 outline allocateArrays. 101546 outline primLoadArraysFrom: self. 101547 101548 ^outline! ! 101549 101550 101551!FT2Face methodsFor: 'printing' stamp: 'tween 7/28/2006 14:53'! 101552printOn: aStream 101553 super printOn: aStream. 101554 handle isNil ifTrue: [^self]. 101555 "self familyName isNil ifTrue: [ self loadFields ]." 101556 aStream 101557 nextPut: $[; 101558 nextPutAll: (self familyName ifNil: ['?']); 101559 space; 101560 nextPutAll: (self styleName ifNil: ['?']); 101561 nextPut: $]! ! 101562 101563 101564!FT2Face methodsFor: 'rendering' stamp: 'bf 11/21/2005 18:07'! 101565angle: angle scale: scale offset: aPoint 101566 | one matrix delta | 101567 one := (16r10000 * scale) asInteger. 101568 matrix := IntegerArray new: 4. 101569 angle isZero ifTrue: [ 101570 matrix at: 1 put: one. 101571 matrix at: 4 put: one. 101572 ] ifFalse: [ 101573 | phi cos sin | 101574 phi := angle degreesToRadians. 101575 cos := (phi sin * one) rounded. 101576 sin := (phi cos * one) rounded. 101577 matrix at: 1 put: sin. 101578 matrix at: 2 put: cos negated. 101579 matrix at: 3 put: cos. 101580 matrix at: 4 put: sin. 101581 ]. 101582 delta := IntegerArray new: 2. 101583 delta at: 1 put: (aPoint x * 64) rounded. 101584 delta at: 2 put: (aPoint y * 64) rounded. 101585 self primSetTransform: matrix delta: delta. 101586! ! 101587 101588!FT2Face methodsFor: 'rendering' stamp: 'tween 8/2/2006 10:05'! 101589angle: angle scale: scale offset: aPoint slant: slant 101590 | one matrix delta slantOne | 101591 one := (16r10000 * scale) asInteger. 101592 slantOne := (16r10000 * scale* slant) asInteger. 101593 matrix := IntegerArray new: 4. 101594 angle isZero ifTrue: [ 101595 matrix at: 1 put: one. 101596 matrix at: 2 put: slantOne. 101597 matrix at: 4 put: one. 101598 ] ifFalse: [ 101599 | phi cos sin | 101600 phi := angle degreesToRadians. 101601 cos := (phi sin * one) rounded. 101602 sin := (phi cos * one) rounded. 101603 matrix at: 1 put: sin. 101604 matrix at: 2 put: cos negated. 101605 matrix at: 3 put: cos. 101606 matrix at: 4 put: sin. 101607 ]. 101608 delta := IntegerArray new: 2. 101609 delta at: 1 put: (aPoint x * 64) rounded. 101610 delta at: 2 put: (aPoint y * 64) rounded. 101611 self primSetTransform: matrix delta: delta. 101612! ! 101613 101614!FT2Face methodsFor: 'rendering' stamp: 'tween 3/22/2006 23:07'! 101615angle: angle scalePoint: scalePoint offset: aPoint 101616 | oneX oneY matrix delta | 101617 oneX := (16r10000 * scalePoint x) asInteger. 101618 oneY := (16r10000 * scalePoint y) asInteger. 101619 matrix := IntegerArray new: 4. 101620 angle isZero ifTrue: [ 101621 matrix at: 1 put: oneX. 101622 matrix at: 4 put: oneY. 101623 ] ifFalse: [ 101624 | phi cos sin | 101625 phi := angle degreesToRadians. 101626 cos := (phi sin * oneX) rounded. 101627 sin := (phi cos * oneY) rounded. 101628 matrix at: 1 put: sin. 101629 matrix at: 2 put: cos negated. 101630 matrix at: 3 put: cos. 101631 matrix at: 4 put: sin. 101632 ]. 101633 delta := IntegerArray new: 2. 101634 delta at: 1 put: (aPoint x * 64) rounded. 101635 delta at: 2 put: (aPoint y * 64) rounded. 101636 self primSetTransform: matrix delta: delta. 101637! ! 101638 101639!FT2Face methodsFor: 'rendering' stamp: 'tween 8/2/2006 17:40'! 101640angle: angle scalePoint: scalePoint offset: aPoint slant: slant 101641 | oneX oneY matrix delta slantOne| 101642 oneX := (16r10000 * scalePoint x) asInteger. 101643 oneY := (16r10000 * scalePoint y) asInteger. 101644 slantOne := (16r10000 * scalePoint x * slant) asInteger. 101645 matrix := IntegerArray new: 4. 101646 angle isZero ifTrue: [ 101647 matrix at: 1 put: oneX. 101648 matrix at: 2 put: slantOne. 101649 matrix at: 4 put: oneY. 101650 ] ifFalse: [ 101651 | phi cos sin | 101652 phi := angle degreesToRadians. 101653 cos := (phi sin * oneX) rounded. 101654 sin := (phi cos * oneY) rounded. 101655 matrix at: 1 put: sin. 101656 matrix at: 2 put: cos negated. 101657 matrix at: 3 put: cos. 101658 matrix at: 4 put: sin. 101659 ]. 101660 delta := IntegerArray new: 2. 101661 delta at: 1 put: (aPoint x * 64) rounded. 101662 delta at: 2 put: (aPoint y * 64) rounded. 101663 self primSetTransform: matrix delta: delta. 101664! ! 101665 101666!FT2Face methodsFor: 'rendering' stamp: 'tween 8/2/2006 21:19'! 101667emboldenOutline: strength 101668 ^self primEmboldenGlyphSlotOutline: (strength * 64) rounded! ! 101669 101670!FT2Face methodsFor: 'rendering' stamp: 'bf 11/19/2005 12:56'! 101671renderGlyphIntoForm: aForm 101672 "render the current glyph (selected by loadChar/loadGlyph into the given form (1 or 8 bpp)" 101673 self primRenderGlyphIntoForm: aForm 101674! ! 101675 101676!FT2Face methodsFor: 'rendering' stamp: 'tween 8/13/2006 15:57'! 101677renderGlyphIntoForm: aForm pixelMode: anInteger 101678 "render the current glyph (selected by loadChar/loadGlyph into the given form (1 or 8 bpp) 101679 with pixel mode anInteger " 101680 self primRenderGlyphIntoForm: aForm pixelMode: anInteger 101681! ! 101682 101683!FT2Face methodsFor: 'rendering' stamp: 'tween 8/2/2006 20:47'! 101684transformOutlineAngle: angle scalePoint: scalePoint slant: slant 101685 | oneX oneY matrix slantOne| 101686 oneX := (16r10000 * scalePoint x) asInteger. 101687 oneY := (16r10000 * scalePoint y) asInteger. 101688 slantOne := (16r10000 * scalePoint x * slant) asInteger. 101689 matrix := IntegerArray new: 4. 101690 angle isZero ifTrue: [ 101691 matrix at: 1 put: oneX. 101692 matrix at: 2 put: slantOne. 101693 matrix at: 4 put: oneY. 101694 ] ifFalse: [ 101695 | phi cos sin | 101696 phi := angle degreesToRadians. 101697 cos := (phi sin * oneX) rounded. 101698 sin := (phi cos * oneY) rounded. 101699 matrix at: 1 put: sin. 101700 matrix at: 2 put: cos negated. 101701 matrix at: 3 put: cos. 101702 matrix at: 4 put: sin. 101703 ]. 101704 self primTransformGlyphSlotOutline: matrix! ! 101705 101706!FT2Face methodsFor: 'rendering' stamp: 'tween 8/2/2006 20:48'! 101707translateOutlineBy: aPoint 101708 | delta| 101709 delta := IntegerArray new: 2. 101710 delta at: 1 put: (aPoint x * 64) rounded. 101711 delta at: 2 put: (aPoint y * 64) rounded. 101712 self primTranslateGlyphSlotOutline: delta.! ! 101713 101714 101715!FT2Face methodsFor: 'testing' stamp: 'tween 8/7/2006 08:46'! 101716isBold 101717 styleFlags == nil ifTrue:[^false]. 101718 ^styleFlags allMask: StyleFlagBold! ! 101719 101720!FT2Face methodsFor: 'testing' stamp: 'tween 8/7/2006 08:47'! 101721isFixedWidth 101722 styleFlags == nil ifTrue:[^false]. 101723 ^faceFlags allMask: 4 "FT:=FACE:=FLAG:=FIXED:=WIDTH" ! ! 101724 101725!FT2Face methodsFor: 'testing' stamp: 'tween 8/7/2006 08:47'! 101726isItalic 101727 styleFlags == nil ifTrue:[^false]. 101728 ^styleFlags allMask: StyleFlagItalic! ! 101729 101730!FT2Face methodsFor: 'testing' stamp: 'tween 8/7/2006 08:47'! 101731isRegular 101732 styleFlags == nil ifTrue:[^true]. 101733 ^styleFlags = 0! ! 101734 101735 101736!FT2Face methodsFor: 'private' stamp: 'tween 7/31/2006 21:30'! 101737loadFields 101738 self isValid 101739 ifTrue:[ 101740 [self primLoadFields] 101741 on: FT2Error 101742 do:[:e | 101743 "need to do something here"]]! ! 101744 101745!FT2Face methodsFor: 'private' stamp: 'tween 7/29/2006 11:31'! 101746primLoadFields 101747 <primitive: 'primitiveLoadFaceFields' module: 'FT2Plugin'> 101748 ^self primitiveFailed! ! 101749 101750 101751!FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/6/2006 15:47'! 101752primDestroyHandle 101753 <primitive: 'primitiveDoneFacePreserveFields' module: 'FT2Plugin'> 101754 ^self primitiveFailed.! ! 101755 101756!FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/2/2006 21:14'! 101757primEmboldenGlyphSlotOutline: strengthInteger 101758 <primitive: 'primitiveEmboldenFaceGlyphSlotOutline' module: 'FT2Plugin'> 101759 ^self primitiveFailed.! ! 101760 101761!FT2Face methodsFor: 'private-primitives' stamp: 'jl 5/30/2006 13:21'! 101762primGetCharIndex: characterCode 101763 "Return the glyph index of a given character code" 101764 <primitive: 'primitiveGetFaceCharIndex' module: 'FT2Plugin'> 101765 ^self primitiveFailed. 101766! ! 101767 101768!FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 19:35'! 101769primGetCharMap 101770 <primitive: 'primitiveGetFaceCharMap' module: 'FT2Plugin'> 101771 ^self primitiveFailed! ! 101772 101773!FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:35'! 101774primGetCharMapsInto: array 101775 <primitive: 'primitiveGetFaceCharMapsIntoArray' module: 'FT2Plugin'> 101776 ^self primitiveFailed.! ! 101777 101778!FT2Face methodsFor: 'private-primitives' stamp: 'jl 5/30/2006 13:23'! 101779primGetKerningLeft: leftGlyphIndex right: rightGlyphIndex 101780 "self primGetKerningLeft: $V asInteger right: $a asInteger " 101781 <primitive: 'primitiveGetKerningLeftRight' module: 'FT2Plugin'> 101782 ^self primitiveFailed.! ! 101783 101784!FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/11/2007 11:24'! 101785primGetPostscriptName 101786 <primitive: 'primitiveGetPostscriptName' module: 'FT2Plugin'> 101787 ^nil! ! 101788 101789!FT2Face methodsFor: 'private-primitives' stamp: 'jl 5/30/2006 15:59'! 101790primGetTrackKerningPointSize: pointSize degree: degree 101791 <primitive: 'primitiveGetTrackKerningPointSizeDegree' module: 'FT2Plugin'> 101792 ^self primitiveFailed.! ! 101793 101794!FT2Face methodsFor: 'private-primitives' stamp: 'jl 5/29/2006 15:52'! 101795primHasKerning 101796 <primitive: 'primitiveHasKerning' module: 'FT2Plugin'> 101797 ^self primitiveFailed.! ! 101798 101799!FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:34'! 101800primLoadBbox: aRectangle 101801 <primitive: 'primitiveLoadFaceBbox' module: 'FT2Plugin'> 101802 ^self primitiveFailed.! ! 101803 101804!FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 18:05'! 101805primLoadCharacter: index flags: flags 101806 <primitive: 'primitiveLoadCharacter' module: 'FT2Plugin'> 101807 ^self primitiveFailed! ! 101808 101809!FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 18:05'! 101810primLoadGlyph: index flags: flags 101811 <primitive: 'primitiveLoadGlyph' module: 'FT2Plugin'> 101812 ^self primitiveFailed! ! 101813 101814!FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 15:58'! 101815primNewFaceFromFile: fileName index: anInteger 101816 <primitive: 'primitiveNewFaceFromFileAndIndex' module: 'FT2Plugin'> 101817 ^self primitiveFailed! ! 101818 101819!FT2Face methodsFor: 'private-primitives' stamp: 'tween 7/24/2006 21:10'! 101820primNewMemoryFaceByteSize: anInteger index: anInteger2 101821 <primitive: 'primitiveNewMemoryFaceByteSizeAndIndex' module: 'FT2Plugin'> 101822 ^self primitiveFailed! ! 101823 101824!FT2Face methodsFor: 'private-primitives' stamp: 'bf 11/19/2005 12:56'! 101825primRenderGlyphIntoForm: aForm 101826 <primitive: 'primitiveRenderGlyphIntoForm' module: 'FT2Plugin'> 101827 ^self primitiveFailed! ! 101828 101829!FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/13/2006 15:56'! 101830primRenderGlyphIntoForm: aForm pixelMode: anInteger 101831 <primitive: 'primitiveRenderGlyphIntoFormWithRenderMode' module: 'FT2Plugin'> 101832 ^self primitiveFailed! ! 101833 101834!FT2Face methodsFor: 'private-primitives' stamp: 'bf 11/18/2005 19:33'! 101835primSetBitmapLeft: x top: y 101836 <primitive: 'primitiveSetBitmapLefttop' module: 'FT2Plugin'> 101837 ^self primitiveFailed.! ! 101838 101839!FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 19:35'! 101840primSetCharMap: encodingString 101841 <primitive: 'primitiveSetFaceCharMap' module: 'FT2Plugin'> 101842 ^self primitiveFailed! ! 101843 101844!FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:35'! 101845primSetPixelWidth: x height: y 101846 <primitive: 'primitiveSetPixelSizes' module: 'FT2Plugin'> 101847 ^self primitiveFailed.! ! 101848 101849!FT2Face methodsFor: 'private-primitives' stamp: 'bf 11/19/2005 15:36'! 101850primSetTransform: matrixWordArray delta: deltaWordArray 101851 "matrix is 16.16 fixed point 101852 x' = x*m[0] + y*m[1] 101853 y' = x*m[2] + y*yy[3] 101854 delta is 26.6 fixed point 101855 x' = x + d[0] 101856 y' = y + d[1] 101857 " 101858 <primitive: 'primitiveSetTransform' module: 'FT2Plugin'> 101859 ^self primitiveFailed.! ! 101860 101861!FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/2/2006 20:45'! 101862primTransformGlyphSlotOutline: anIntegerArray 101863 <primitive: 'primitiveTransformFaceGlyphSlotOutline' module: 'FT2Plugin'> 101864 ^self primitiveFailed.! ! 101865 101866!FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/2/2006 20:45'! 101867primTranslateGlyphSlotOutline: anIntegerArray 101868 <primitive: 'primitiveTranslateFaceGlyphSlotOutline' module: 'FT2Plugin'> 101869 ^self primitiveFailed.! ! 101870Object subclass: #FT2GlyphSlot 101871 instanceVariableNames: 'face linearHorizontalAdvance linearVerticalAdvance advanceX advanceY format bitmapLeft bitmapTop width height hBearingX hBearingY hAdvance vBearingX vBearingY vAdvance outline' 101872 classVariableNames: '' 101873 poolDictionaries: 'FT2Constants' 101874 category: 'FreeType-Base'! 101875!FT2GlyphSlot commentStamp: '<historical>' prior: 0! 101876Do not rearrange these fields!! 101877 101878face -- the FT2Face that owns this FT2GlyphSlot. 101879 101880 101881Note that even when the glyph image is transformed, the metrics are not. 101882 101883linearHoriAdvance -- For scalable formats only, this field holds the 101884linearly scaled horizontal advance width for the glyph (i.e. the scaled 101885and unhinted value of the hori advance). This can be important to 101886perform correct WYSIWYG layout. 101887 101888Note that this value is expressed by default in 16.16 pixels. However, 101889when the glyph is loaded with the FT_LOAD_LINEAR_DESIGN flag, this field 101890contains simply the value of the advance in original font units. 101891 101892linearVertAdvance -- For scalable formats only, this field holds the 101893linearly scaled vertical advance height for the glyph. See 101894linearHoriAdvance for comments. 101895 101896advance -- This is the transformed advance width for the glyph. 101897 101898format -- This field indicates the format of the image contained in the 101899glyph slot. Typically FT_GLYPH_FORMAT_BITMAP, FT_GLYPH_FORMAT_OUTLINE, 101900and FT_GLYPH_FORMAT_COMPOSITE, but others are possible. 101901 101902bitmap -- This field is used as a bitmap descriptor when the slot format 101903is FT_GLYPH_FORMAT_BITMAP. Note that the address and content of the 101904bitmap buffer can change between calls of @FT_Load_Glyph and a few other 101905functions. 101906 101907bitmap_left -- This is the bitmap's left bearing expressed in integer 101908pixels. Of course, this is only valid if the format is 101909FT_GLYPH_FORMAT_BITMAP. 101910 101911bitmap_top -- This is the bitmap's top bearing expressed in integer 101912pixels. Remember that this is the distance from the baseline to the 101913top-most glyph scanline, upwards y-coordinates being *positive*. 101914 101915outline -- The outline descriptor for the current glyph image if its 101916format is FT_GLYPH_FORMAT_OUTLINE. 101917 101918num_subglyphs -- The number of subglyphs in a composite glyph. This 101919field is only valid for the composite glyph format that should normally 101920only be loaded with the @FT_LOAD_NO_RECURSE flag. For now this is 101921internal to FreeType. 101922 101923subglyphs -- An array of subglyph descriptors for composite glyphs. 101924There are `num_subglyphs' elements in there. Currently internal to 101925FreeType. 101926 101927control_data -- Certain font drivers can also return the control data 101928for a given glyph image (e.g. TrueType bytecode, Type 1 charstrings, 101929etc.). This field is a pointer to such data. 101930 101931control_len -- This is the length in bytes of the control data. 101932 101933other -- Really wicked formats can use this pointer to present their own 101934glyph image to client apps. Note that the app will need to know about 101935the image format. 101936 101937width, height, hBearingX, hBearingY, hAdvance, vBearingX, vBearingY, vAdvance 101938-- The metrics of the last loaded glyph in the slot. The 101939returned values depend on the last load flags (see the @FT_Load_Glyph 101940API function) and can be expressed either in 26.6 fractional pixels or 101941font units. 101942! 101943 101944 101945!FT2GlyphSlot methodsFor: 'accessing-convenience' stamp: 'bf 11/19/2005 17:16'! 101946advance 101947 ^advanceX@advanceY! ! 101948 101949!FT2GlyphSlot methodsFor: 'accessing-convenience' stamp: 'bf 11/20/2005 14:42'! 101950extent 101951 ^width@height! ! 101952 101953!FT2GlyphSlot methodsFor: 'accessing-convenience' stamp: 'bf 11/20/2005 14:56'! 101954hBearing 101955 ^hBearingX@hBearingY! ! 101956 101957!FT2GlyphSlot methodsFor: 'accessing-convenience' stamp: 'tween 8/5/2007 11:14'! 101958linearAdvance 101959 ^"("(linearHorizontalAdvance @ linearVerticalAdvance) "* 2540) rounded" 101960! ! 101961 101962!FT2GlyphSlot methodsFor: 'accessing-convenience' stamp: 'tween 3/11/2007 08:56'! 101963roundedPixelLinearAdvance 101964 "Answer the scaled linearAdvance, rounded to whole pixels" 101965 ^linearHorizontalAdvance rounded @ linearVerticalAdvance rounded 101966! ! 101967 101968 101969!FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! 101970advanceX 101971 ^advanceX! ! 101972 101973!FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! 101974advanceY 101975 ^advanceY! ! 101976 101977!FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! 101978bitmapLeft 101979 ^bitmapLeft! ! 101980 101981!FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! 101982bitmapTop 101983 ^bitmapTop! ! 101984 101985!FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! 101986format 101987 ^format! ! 101988 101989!FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'bf 11/20/2005 14:52'! 101990hBearingX 101991 ^hBearingX! ! 101992 101993!FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'bf 11/20/2005 14:52'! 101994hBearingY 101995 ^hBearingY! ! 101996 101997!FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'bf 11/20/2005 14:53'! 101998height 101999 ^height! ! 102000 102001!FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! 102002linearHorizontalAdvance 102003 ^linearHorizontalAdvance! ! 102004 102005!FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! 102006linearVerticalAdvance 102007 ^linearVerticalAdvance! ! 102008 102009!FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'bf 11/20/2005 14:53'! 102010width 102011 ^width! ! 102012 102013 102014!FT2GlyphSlot methodsFor: 'private' stamp: 'bf 11/20/2005 14:43'! 102015loadFrom: anFT2Face 102016 face := anFT2Face. 102017 self primLoadFrom: anFT2Face. 102018 format := ((SmalltalkImage current isLittleEndian) ifTrue: [ format reversed ] ifFalse: [ format ]) asString. 102019 linearHorizontalAdvance := linearHorizontalAdvance / 65536.0. 102020 linearVerticalAdvance isZero ifFalse: [ linearVerticalAdvance := linearVerticalAdvance / 65536.0 ]. 102021 advanceX := advanceX bitShift: -6. 102022 advanceY isZero ifFalse: [ advanceY := advanceY bitShift: -6 ]. 102023 width := width + 63 bitShift: -6. "round up" 102024 height := height + 63 bitShift: -6. "round up" 102025 hBearingX := hBearingX bitShift: -6. 102026 hBearingY := hBearingY bitShift: -6. 102027 hAdvance := hAdvance bitShift: -6. 102028 vBearingX := vBearingX bitShift: -6. 102029 vBearingY := vBearingY bitShift: -6. 102030 vAdvance := vAdvance bitShift: -6.! ! 102031 102032!FT2GlyphSlot methodsFor: 'private' stamp: 'nk 11/3/2004 17:58'! 102033primLoadFrom: anFT2Face 102034 <primitive: 'primitiveLoadGlyphSlotFromFace' module: 'FT2Plugin'> 102035 ^self primitiveFailed.! ! 102036 102037"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 102038 102039FT2GlyphSlot class 102040 instanceVariableNames: ''! 102041 102042!FT2GlyphSlot class methodsFor: 'instance creation' stamp: 'nk 11/3/2004 17:38'! 102043fromFace: anFT2Face 102044 ^(super new) 102045 loadFrom: anFT2Face; 102046 yourself.! ! 102047Object subclass: #FT2Handle 102048 instanceVariableNames: 'handle' 102049 classVariableNames: 'Registry' 102050 poolDictionaries: 'FT2Constants' 102051 category: 'FreeType-Base'! 102052!FT2Handle commentStamp: '<historical>' prior: 0! 102053handle holds a (typically 32-bit) pointer to an externally managed object.! 102054 102055 102056!FT2Handle methodsFor: 'error handling' stamp: 'nk 11/3/2004 13:51'! 102057errorCode 102058 <primitive: 'primitiveErrorCode' module: 'FT2Plugin'> 102059 ^self primitiveFailed! ! 102060 102061!FT2Handle methodsFor: 'error handling' stamp: 'nk 11/3/2004 21:07'! 102062errorString 102063 <primitive: 'primitiveErrorString' module: 'FT2Plugin'> 102064 ^self primitiveFailed! ! 102065 102066!FT2Handle methodsFor: 'error handling' stamp: 'nk 11/4/2004 13:32'! 102067primitiveFailed 102068 ^self primitiveFailed: 'Freetype2 primitive failed'! ! 102069 102070!FT2Handle methodsFor: 'error handling' stamp: 'nk 11/4/2004 13:33'! 102071primitiveFailed: aString 102072 ^FT2Error new 102073 signal: aString! ! 102074 102075 102076!FT2Handle methodsFor: 'finalization' stamp: 'nk 11/3/2004 12:21'! 102077finalize 102078 self pvtDestroyHandle. 102079! ! 102080 102081 102082!FT2Handle methodsFor: 'initialize-release' stamp: 'nk 3/11/2005 18:44'! 102083initialize 102084 self shouldNotImplement.! ! 102085 102086 102087!FT2Handle methodsFor: 'printing' stamp: 'nk 3/17/2005 16:40'! 102088isValid 102089 ^handle notNil and: [ handle anySatisfy: [ :b | b isZero not ] ]! ! 102090 102091!FT2Handle methodsFor: 'printing' stamp: 'nk 3/17/2005 14:08'! 102092printOn: aStream 102093 | handleHex | 102094 super printOn: aStream. 102095 handle isNil ifTrue: [ ^aStream nextPutAll: '<nil>' ]. 102096 handleHex := (handle unsignedLongAt: 1 bigEndian: SmalltalkImage current isBigEndian) printStringHex. 102097 aStream nextPutAll: '<0x'; nextPutAll: handleHex; nextPut: $>.! ! 102098 102099 102100!FT2Handle methodsFor: 'private' stamp: 'nk 11/3/2004 16:10'! 102101beNull 102102 handle := nil.! ! 102103 102104!FT2Handle methodsFor: 'private' stamp: 'nk 11/4/2004 16:44'! 102105destroyHandle 102106 self class deregister: self. 102107 self pvtDestroyHandle! ! 102108 102109!FT2Handle methodsFor: 'private' stamp: 'nk 11/3/2004 21:19'! 102110handle 102111 ^handle! ! 102112 102113!FT2Handle methodsFor: 'private' stamp: 'nk 11/3/2004 12:21'! 102114primDestroyHandle 102115 self subclassResponsibility! ! 102116 102117!FT2Handle methodsFor: 'private' stamp: 'nk 11/3/2004 16:23'! 102118pvtDestroyHandle 102119 "This should only be sent from the finalizer." 102120 handle ifNil: [ ^self ]. 102121 self primDestroyHandle. 102122 self beNull.! ! 102123 102124"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 102125 102126FT2Handle class 102127 instanceVariableNames: ''! 102128 102129!FT2Handle class methodsFor: 'class initialization' stamp: 'tween 7/28/2006 07:42'! 102130initialize 102131 "FT2Handle initialize" 102132 102133 Smalltalk removeFromStartUpList: self. "in case it was added by earlier version" 102134 Smalltalk addToShutDownList: self. 102135! ! 102136 102137 102138!FT2Handle class methodsFor: 'error reporting' stamp: 'nk 11/3/2004 13:51'! 102139errorCode 102140 <primitive: 'primitiveErrorCode' module: 'FT2Plugin'> 102141 ^self primitiveFailed! ! 102142 102143!FT2Handle class methodsFor: 'error reporting' stamp: 'nk 11/3/2004 15:49'! 102144errorString 102145 <primitive: 'primitiveErrorString' module: 'FT2Plugin'> 102146 ^self primitiveFailed! ! 102147 102148!FT2Handle class methodsFor: 'error reporting' stamp: 'nk 11/3/2004 15:50'! 102149moduleErrorCode 102150 <primitive: 'primitiveModuleErrorCode' module: 'FT2Plugin'> 102151 ^self primitiveFailed! ! 102152 102153 102154!FT2Handle class methodsFor: 'initialize-release' stamp: 'nk 11/3/2004 21:00'! 102155unload 102156 Smalltalk removeFromStartUpList: self. 102157 Smalltalk removeFromShutDownList: self. 102158! ! 102159 102160 102161!FT2Handle class methodsFor: 'system startup' stamp: 'nk 3/17/2005 16:23'! 102162clearRegistry 102163 Registry ifNotNilDo: 102164 [:r | 102165 r finalizeValues. 102166 r do: [:k | k ifNotNil: [k beNull] ]]. 102167 Registry := nil! ! 102168 102169!FT2Handle class methodsFor: 'system startup' stamp: 'AndrewTween 8/31/2009 21:40'! 102170shutDown: quitting 102171 "we must not save handles (which are pointers) in the image" 102172 self clearRegistry. 102173 FreeTypeFace allInstances do:[:i | 102174 "destroy any faces that are still being referenced" 102175 i isValid 102176 ifTrue:[i destroyHandle]]. 102177 FT2Handle allSubInstances do: [:h | h beNull]. "if some handle was not registered" 102178! ! 102179 102180 102181!FT2Handle class methodsFor: 'private-handle registry' stamp: 'nk 3/17/2005 16:28'! 102182deregister: aHandle 102183 Registry ifNotNilDo: [ :reg | | finalizer | 102184 finalizer := reg remove: aHandle ifAbsent: []. 102185 finalizer ifNotNil: [ finalizer beNull ] ]. 102186! ! 102187 102188!FT2Handle class methodsFor: 'private-handle registry' stamp: 'tween 7/25/2006 00:58'! 102189register: aHandle 102190 102191 self registry ifNotNilDo: [ :reg | 102192 reg add: aHandle. 102193 ^self ]. 102194 self error: 'WeakArrays are not supported in this VM!!' ! ! 102195 102196!FT2Handle class methodsFor: 'private-handle registry' stamp: 'nk 3/17/2005 16:51'! 102197registry 102198 WeakArray isFinalizationSupported ifFalse:[^nil]. 102199 ^Registry ifNil: [ Registry := FT2HandleRegistry new]! ! 102200WeakRegistry subclass: #FT2HandleRegistry 102201 instanceVariableNames: '' 102202 classVariableNames: '' 102203 poolDictionaries: '' 102204 category: 'FreeType-Base'! 102205 102206!FT2HandleRegistry methodsFor: 'as yet unclassified' stamp: 'nk 3/17/2005 16:54'! 102207add: anObject 102208 "Add anObject to the receiver. Store the object as well as the associated executor." 102209 | executor dup | 102210 executor := anObject executor. 102211 dup := nil. 102212 self protected:[ 102213 dup := valueDictionary detect: [ :v | v handle = executor handle ] ifNone: [ ]. 102214 valueDictionary at: anObject put: executor. 102215 ]. 102216 dup ifNotNil: [ self error: 'Duplicate object added!!'. self remove: anObject ]. 102217 ^anObject! ! 102218FT2Handle subclass: #FT2Library 102219 instanceVariableNames: '' 102220 classVariableNames: '' 102221 poolDictionaries: '' 102222 category: 'FreeType-Base'! 102223!FT2Library commentStamp: '<historical>' prior: 0! 102224This is a wrapper for the global 'library' in the plugin. 102225It is provided for the use of Cairo APIs that take an FT_Library argument.! 102226 102227 102228!FT2Library methodsFor: 'private-primitives' stamp: 'tween 3/17/2007 14:18'! 102229current 102230 ^[self primCurrentLibrary] on: Error do: [:e | nil]! ! 102231 102232!FT2Library methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:27'! 102233destroyHandle 102234 "This is not a managed handle, but a global. Do nothing."! ! 102235 102236!FT2Library methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:32'! 102237primCurrentLibrary 102238 <primitive: 'primitiveLibraryHandle' module: 'FT2Plugin'> 102239 ^self primitiveFailed! ! 102240 102241"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 102242 102243FT2Library class 102244 instanceVariableNames: ''! 102245 102246!FT2Library class methodsFor: 'instance creation' stamp: 'nk 3/17/2005 14:19'! 102247current 102248 ^[ (self basicNew) 102249 current ] on: FT2Error do: [ :ex | ex return: nil ].! ! 102250FT2Handle subclass: #FT2MemoryFaceData 102251 instanceVariableNames: 'bytes' 102252 classVariableNames: '' 102253 poolDictionaries: '' 102254 category: 'FreeType-Base'! 102255 102256!FT2MemoryFaceData methodsFor: 'accessing' stamp: 'tween 7/24/2006 23:04'! 102257bytes 102258 ^bytes 102259 ! ! 102260 102261!FT2MemoryFaceData methodsFor: 'accessing' stamp: 'tween 7/24/2006 22:43'! 102262bytes: aByteArray 102263 102264 bytes := aByteArray. 102265 ! ! 102266 102267 102268!FT2MemoryFaceData methodsFor: 'initialize-release' stamp: 'tween 7/24/2006 21:53'! 102269free 102270 ^self destroyHandle! ! 102271 102272 102273!FT2MemoryFaceData methodsFor: 'primitives' stamp: 'tween 7/24/2006 21:52'! 102274primDestroyHandle 102275 <primitive: 'primitiveFreeMemoryFaceData' module: 'FT2Plugin'> 102276 ^self primitiveFailed.! ! 102277 102278!FT2MemoryFaceData methodsFor: 'primitives' stamp: 'tween 7/24/2006 22:32'! 102279primMalloc: aByteArray 102280 "copy aByteArray into newly allocated, external memory, and store the 102281 address of that memory in the receiver's handle" 102282 <primitive: 'primitiveMallocMemoryFaceData' module: 'FT2Plugin'> 102283 ^self primitiveFailed! ! 102284 102285 102286!FT2MemoryFaceData methodsFor: 'validation' stamp: 'tween 7/31/2006 21:48'! 102287validate 102288 self isValid 102289 ifFalse: [ 102290 bytes ifNotNil:[ 102291 [self primMalloc: bytes] 102292 on: FT2Error 102293 do:[:e |"need to do something here?"]. 102294 self isValid ifTrue:[self class register: self]]]! ! 102295 102296"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 102297 102298FT2MemoryFaceData class 102299 instanceVariableNames: ''! 102300 102301!FT2MemoryFaceData class methodsFor: 'instance creation' stamp: 'tween 8/6/2006 11:11'! 102302bytes: aByteArray 102303 | answer | 102304 answer := self basicNew 102305 bytes: aByteArray; 102306 yourself. 102307 ^answer! ! 102308Object subclass: #FT2Outline 102309 instanceVariableNames: 'contoursSize pointsSize points tags contours flags' 102310 classVariableNames: '' 102311 poolDictionaries: '' 102312 category: 'FreeType-Base'! 102313!FT2Outline commentStamp: '<historical>' prior: 0! 102314@instVar: contoursSize - The number of contours in the outline. 102315@instVar: pointsSize - The number of points in the outline. 102316@instVar: points - an array of 26.6 fixed point integer pairs giving the outline's point coordinates. 102317 102318@instVar: tags - an array of pointsSize bytes, giving each outline point's type. 102319 102320(counting from 0) 102321 102322If bit 0 is unset, the point is 'off' the curve, i.e., a Bézier control point, while it is 'on' when set. 102323 102324Bit 1 is meaningful for 'off' points only. If set, it indicates a third-order Bézier arc control point; and a second-order control point if unset. 102325 102326@instVar: contours - an array of contoursSize shorts, giving the end point of each contour within the outline. For example, the first contour is defined by the points '0' to 'contours[0]', the second one is defined by the points 'contours[0]+1' to 'contours[1]', etc. 102327 102328@instVar: flags - a set of bit flags used to characterize the outline and give hints to the scan-converter and hinter on how to convert/grid-fit it.! 102329 102330 102331!FT2Outline methodsFor: 'accessing' stamp: 'jl 5/24/2006 15:19'! 102332contoursCollection 102333 "returns a list of contours with tag => points list pairs" 102334 | allPoints result start end | 102335 allPoints := self pointCollection. 102336 102337 result := OrderedCollection new. 102338 start := 1. 102339 "no normal iteration because contours size can be bigger than contourSize" 102340 1 to: contoursSize do: [ :i | 102341 end := (contours at: i) + 1. "c converion" 102342 result add: ((tags copyFrom: start to: end) -> (allPoints copyFrom: start to: end)). 102343 start := end + 1. 102344 ]. 102345 102346 ^result 102347 102348 102349 102350 102351! ! 102352 102353!FT2Outline methodsFor: 'accessing' stamp: 'jl 5/24/2006 14:26'! 102354pointCollection 102355 102356 ^(1 to: pointsSize * 2 by: 2) collect: [ :i | ((points at: i) / 64) @ ((points at: i + 1) / 64)] 102357 102358 102359 102360 102361! ! 102362 102363 102364!FT2Outline methodsFor: 'private' stamp: 'jl 5/24/2006 13:58'! 102365allocateArrays 102366 " allocate the arrays for the primLoadArraysFrom:" 102367 points := IntegerArray new: pointsSize * 2. 102368 tags := ByteArray new: pointsSize. 102369 contours := ShortIntegerArray new: contoursSize.! ! 102370 102371!FT2Outline methodsFor: 'private' stamp: 'jl 5/23/2006 17:01'! 102372primLoadArraysFrom: anFT2Face 102373 <primitive: 'primitiveLoadOutlineArraysFromFace' module: 'FT2Plugin'> 102374 ^self primitiveFailed.! ! 102375 102376!FT2Outline methodsFor: 'private' stamp: 'jl 5/23/2006 17:01'! 102377primLoadSizesFrom: anFT2Face 102378 <primitive: 'primitiveLoadOutlineSizesFromFace' module: 'FT2Plugin'> 102379 ^self primitiveFailed.! ! 102380Object subclass: #FT2Version 102381 instanceVariableNames: 'major minor patch' 102382 classVariableNames: '' 102383 poolDictionaries: '' 102384 category: 'FreeType-Base'! 102385!FT2Version commentStamp: '<historical>' prior: 0! 102386Do not rearrange these fields!! 102387 102388This is used to report FT2 version information. Its fields must remain unchanged, or you must change FT2Plugin>>primitiveVersion.! 102389 102390 102391!FT2Version methodsFor: 'accessing' stamp: 'nk 3/21/2004 11:03'! 102392major 102393 ^major! ! 102394 102395!FT2Version methodsFor: 'accessing' stamp: 'nk 3/21/2004 11:03'! 102396minor 102397 ^minor! ! 102398 102399!FT2Version methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:17'! 102400patch 102401 ^patch! ! 102402 102403 102404!FT2Version methodsFor: 'primitives' stamp: 'nk 11/3/2004 11:20'! 102405libraryVersion 102406 <primitive: 'primitiveVersion' module: 'FT2Plugin'> 102407 ^self primitiveFailed. 102408! ! 102409 102410 102411!FT2Version methodsFor: 'printing' stamp: 'nk 11/3/2004 11:22'! 102412printOn: aStream 102413 aStream print: major; nextPut: $.; print: minor; nextPut:$.; print: patch.! ! 102414 102415"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 102416 102417FT2Version class 102418 instanceVariableNames: ''! 102419 102420!FT2Version class methodsFor: 'instance creation' stamp: 'nk 11/4/2004 11:10'! 102421current 102422 " 102423 FT2Version current 102424 " 102425 ^ [(self new) 102426 libraryVersion; 102427 yourself] on: Error do: [:ex | ex return: nil]! ! 102428TelnetProtocolClient subclass: #FTPClient 102429 instanceVariableNames: 'dataSocket' 102430 classVariableNames: '' 102431 poolDictionaries: '' 102432 category: 'Network-Protocols'! 102433!FTPClient commentStamp: 'mir 5/12/2003 17:55' prior: 0! 102434A minimal FTP client program. Could store all state in inst vars, and use an instance to represent the full state of a connection in progress. But simpler to do all that in one method and have it be a complete transaction. 102435 102436Always operates in passive mode (PASV). All connections are initiated from client in order to get through firewalls. 102437 102438See ServerDirectory openFTP, ServerDirectory getFileNamed:, ServerDirectory putFile:named: for examples of use. 102439 102440See TCP/IP, second edition, by Dr. Sidnie Feit, McGraw-Hill, 1997, Chapter 14, p311.! 102441 102442 102443!FTPClient methodsFor: 'protocol' stamp: 'mir 2/13/2002 18:05'! 102444abortDataConnection 102445 self sendCommand: 'ABOR'. 102446 self closeDataSocket! ! 102447 102448!FTPClient methodsFor: 'protocol' stamp: 'mir 3/7/2002 13:36'! 102449ascii 102450 self sendCommand: 'TYPE A'. 102451 self lookForCode: 200! ! 102452 102453!FTPClient methodsFor: 'protocol' stamp: 'mir 3/7/2002 13:36'! 102454binary 102455 self sendCommand: 'TYPE I'. 102456 self lookForCode: 200! ! 102457 102458!FTPClient methodsFor: 'protocol' stamp: 'mir 11/13/2002 17:52'! 102459changeDirectoryTo: newDirName 102460 self sendCommand: 'CWD ' , newDirName. 102461 self checkResponse. 102462! ! 102463 102464!FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 17:11'! 102465deleteDirectory: dirName 102466 self sendCommand: 'RMD ' , dirName. 102467 self checkResponse. 102468! ! 102469 102470!FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 17:12'! 102471deleteFileNamed: fileName 102472 self sendCommand: 'DELE ' , fileName. 102473 self checkResponse. 102474! ! 102475 102476!FTPClient methodsFor: 'protocol' stamp: 'mir 2/20/2002 13:53'! 102477getDirectory 102478 | dirList | 102479 self openPassiveDataConnection. 102480 self sendCommand: 'LIST'. 102481 dirList := self getData. 102482 self checkResponse. 102483 self checkResponse. 102484 ^dirList 102485! ! 102486 102487!FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 16:50'! 102488getFileList 102489 | dirList | 102490 self openPassiveDataConnection. 102491 self sendCommand: 'NLST'. 102492 dirList := self getData. 102493 self checkResponse. 102494 self checkResponse. 102495 ^dirList 102496! ! 102497 102498!FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 19:23'! 102499getFileNamed: remoteFileName 102500 | data | 102501 self openPassiveDataConnection. 102502 self sendCommand: 'RETR ', remoteFileName. 102503 [self checkResponse] 102504 on: TelnetProtocolError 102505 do: [:ex | 102506 self closeDataSocket. 102507 ex pass]. 102508 data := self getData. 102509 self checkResponse. 102510 ^data 102511! ! 102512 102513!FTPClient methodsFor: 'protocol' stamp: 'mir 5/9/2003 15:50'! 102514getFileNamed: remoteFileName into: dataStream 102515 self openPassiveDataConnection. 102516 self sendCommand: 'RETR ', remoteFileName. 102517 [self checkResponse] 102518 on: TelnetProtocolError 102519 do: [:ex | 102520 self closeDataSocket. 102521 ex pass]. 102522 self getDataInto: dataStream. 102523 self closeDataSocket. 102524 self checkResponse! ! 102525 102526!FTPClient methodsFor: 'protocol' stamp: 'mir 10/31/2000 19:03'! 102527getPartial: limit fileNamed: remoteFileName into: dataStream 102528 | data | 102529 self openPassiveDataConnection. 102530 self sendCommand: 'RETR ', remoteFileName. 102531 [self checkResponse] 102532 on: TelnetProtocolError 102533 do: [:ex | 102534 self closeDataSocket. 102535 ex pass]. 102536 data := self get: limit dataInto: dataStream. 102537 self abortDataConnection. 102538 ^data 102539! ! 102540 102541!FTPClient methodsFor: 'protocol' stamp: 'mir 11/12/2002 18:39'! 102542loginUser: userName password: passwdString 102543 102544 self user: userName. 102545 self password: passwdString. 102546 102547 self login! ! 102548 102549!FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 17:10'! 102550makeDirectory: newDirName 102551 self sendCommand: 'MKD ' , newDirName. 102552 self checkResponse. 102553! ! 102554 102555!FTPClient methodsFor: 'protocol' stamp: 'mir 11/14/2002 17:51'! 102556openDataSocket: remoteHostAddress port: dataPort 102557 dataSocket := Socket new. 102558 dataSocket connectTo: remoteHostAddress port: dataPort! ! 102559 102560!FTPClient methodsFor: 'protocol' stamp: 'mir 11/14/2002 16:55'! 102561passive 102562 self sendCommand: 'PASV'. 102563 self lookForCode: 227! ! 102564 102565!FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 16:54'! 102566putFileNamed: filePath as: fileNameOnServer 102567 "FTP a file to the server." 102568 102569 102570 | fileStream | 102571 fileStream := FileStream readOnlyFileNamed: filePath. 102572 fileStream 102573 ifNil: [(FileDoesNotExistException fileName: filePath) signal]. 102574 self putFileStreamContents: fileStream as: fileNameOnServer 102575! ! 102576 102577!FTPClient methodsFor: 'protocol' stamp: 'mir 12/8/2003 16:54'! 102578putFileStreamContents: fileStream as: fileNameOnServer 102579 "FTP a file to the server." 102580 102581 102582 self openPassiveDataConnection. 102583 self sendCommand: 'STOR ', fileNameOnServer. 102584 102585 fileStream reset. 102586 102587 [self sendStreamContents: fileStream] 102588 ensure: [self closeDataSocket]. 102589 102590 self checkResponse. 102591 self checkResponse. 102592! ! 102593 102594!FTPClient methodsFor: 'protocol' stamp: 'mir 11/14/2002 16:43'! 102595pwd 102596 | result | 102597 self sendCommand: 'PWD'. 102598 self lookForCode: 257. 102599 result := self lastResponse. 102600 ^result copyFrom: (result indexOf: $")+1 to: (result lastIndexOf: $")-1! ! 102601 102602!FTPClient methodsFor: 'protocol' stamp: 'mir 10/31/2000 13:12'! 102603quit 102604 self sendCommand: 'QUIT'. 102605 self close! ! 102606 102607!FTPClient methodsFor: 'protocol' stamp: 'mir 11/13/2002 17:50'! 102608removeFileNamed: remoteFileName 102609 self sendCommand: 'DELE ', remoteFileName. 102610 self checkResponse. 102611! ! 102612 102613!FTPClient methodsFor: 'protocol' stamp: 'nk 1/26/2005 16:40'! 102614renameFileNamed: oldFileName to: newFileName 102615 self sendCommand: 'RNFR ' , oldFileName. 102616 self lookForCode: 350. 102617 self sendCommand: 'RNTO ' , newFileName. 102618 self lookForCode: 250! ! 102619 102620 102621!FTPClient methodsFor: 'private' stamp: 'mir 2/19/2002 18:27'! 102622closeDataSocket 102623 self dataSocket 102624 ifNotNil: [ 102625 self dataSocket closeAndDestroy. 102626 self dataSocket: nil] 102627! ! 102628 102629!FTPClient methodsFor: 'private' stamp: 'mir 10/31/2000 16:24'! 102630dataSocket 102631 ^dataSocket! ! 102632 102633!FTPClient methodsFor: 'private' stamp: 'mir 10/31/2000 18:23'! 102634dataSocket: aSocket 102635 dataSocket := aSocket! ! 102636 102637!FTPClient methodsFor: 'private' stamp: 'mir 4/7/2003 17:20'! 102638login 102639 102640 self user ifNil: [^self]. 102641 102642 ["repeat both USER and PASS since some servers require it" 102643 self sendCommand: 'USER ', self user. 102644 102645 "331 Password required" 102646 self lookForCode: 331. 102647 "will ask user, if needed" 102648 self sendCommand: 'PASS ', self password. 102649 102650 "230 User logged in" 102651 ([self lookForCode: 230.] 102652 on: TelnetProtocolError 102653 do: [false]) == false 102654 ] whileTrue: [ 102655 (LoginFailedException protocolInstance: self) signal: self lastResponse] 102656 102657! ! 102658 102659!FTPClient methodsFor: 'private' stamp: 'mir 11/14/2002 18:14'! 102660sendStreamContents: aStream 102661 self dataSocket sendStreamContents: aStream checkBlock: [self checkForPendingError. true]! ! 102662 102663 102664!FTPClient methodsFor: 'private protocol' stamp: 'svp 10/28/2003 11:06'! 102665get: limit dataInto: dataStream 102666 "Reel in data until the server closes the connection or the limit is reached. 102667 At the same time, watch for errors on otherSocket." 102668 102669 | buf bytesRead currentlyRead | 102670 currentlyRead := 0. 102671 buf := String new: 4000. 102672 [currentlyRead < limit and: 102673 [self dataSocket isConnected or: [self dataSocket dataAvailable]]] 102674 whileTrue: [ 102675 self checkForPendingError. 102676 bytesRead := self dataSocket receiveDataWithTimeoutInto: buf. 102677 1 to: (bytesRead min: (limit - currentlyRead)) do: [:ii | dataStream nextPut: (buf at: ii)]. 102678 currentlyRead := currentlyRead + bytesRead]. 102679 dataStream reset. "position: 0." 102680 ^ dataStream! ! 102681 102682!FTPClient methodsFor: 'private protocol' stamp: 'mir 2/13/2002 18:06'! 102683getData 102684 102685 | dataStream | 102686 dataStream := RWBinaryOrTextStream on: (String new: 4000). 102687 self getDataInto: dataStream. 102688 self closeDataSocket. 102689 ^dataStream contents 102690! ! 102691 102692!FTPClient methodsFor: 'private protocol' stamp: 'svp 10/28/2003 11:04'! 102693getDataInto: dataStream 102694 "Reel in all data until the server closes the connection. At the same time, watch for errors on otherSocket. Don't know how much is coming. Put the data on the stream." 102695 102696 | buf bytesRead | 102697 buf := String new: 4000. 102698 [self dataSocket isConnected or: [self dataSocket dataAvailable]] 102699 whileTrue: [ 102700 self checkForPendingError. 102701 bytesRead := self dataSocket receiveDataWithTimeoutInto: buf. 102702 1 to: bytesRead do: [:ii | dataStream nextPut: (buf at: ii)]]. 102703 dataStream reset. "position: 0." 102704 ^ dataStream! ! 102705 102706!FTPClient methodsFor: 'private protocol' stamp: 'gk 9/9/2005 09:31'! 102707lookForCode: code ifDifferent: handleBlock 102708 "We are expecting a certain numeric code next. 102709 However, in the FTP protocol, multiple lines are allowed. 102710 If the response is multi-line, the fourth character of the first line is a 102711 $- and the last line repeats the numeric code but the code is followed by 102712 a space. So it's possible that there are more lines left of the last response that 102713 we need to throw away. We use peekForAll: so that we don't discard the 102714 next response that is not a continuation line." 102715 102716 | headToDiscard | 102717 "check for multi-line response" 102718 (self lastResponse size > 3 102719 and: [(self lastResponse at: 4) = $-]) 102720 ifTrue: ["Discard continuation lines." 102721 [headToDiscard := self lastResponse first: 4. 102722 [[self stream peekForAll: headToDiscard] 102723 whileTrue: [self stream nextLine]] 102724 on: Exception 102725 do: [:ex | ^handleBlock value: nil]]]. 102726 ^ super lookForCode: code ifDifferent: handleBlock! ! 102727 102728!FTPClient methodsFor: 'private protocol' stamp: 'michael.rueger 6/16/2009 11:28'! 102729openPassiveDataConnection 102730 | portInfo list dataPort remoteHostAddress remoteAddressString | 102731 self sendCommand: 'PASV'. 102732 self lookForCode: 227 ifDifferent: [:response | (TelnetProtocolError protocolInstance: self) signal: 'Could not enter passive mode: ' , response]. 102733 102734 portInfo := (self lastResponse findTokens: '()') at: 2. 102735 list := portInfo findTokens: ','. 102736 remoteHostAddress := ByteArray 102737 with: (list at: 1) asNumber 102738 with: (list at: 2) asNumber 102739 with: (list at: 3) asNumber 102740 with: (list at: 4) asNumber. 102741 remoteAddressString := String streamContents: [:addrStream | remoteHostAddress 102742 do: [ :each | each printOn: addrStream ] 102743 separatedBy: [ addrStream nextPut: $. ]]. 102744 dataPort := (list at: 5) asNumber * 256 + (list at: 6) asNumber. 102745 self openDataSocket: (NetNameResolver addressForName: remoteAddressString) port: dataPort! ! 102746 102747"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 102748 102749FTPClient class 102750 instanceVariableNames: ''! 102751 102752!FTPClient class methodsFor: 'accessing' stamp: 'mir 10/30/2000 20:10'! 102753defaultPortNumber 102754 ^21! ! 102755 102756!FTPClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 19:08'! 102757logFlag 102758 ^#ftp! ! 102759 102760!FTPClient class methodsFor: 'accessing' stamp: 'mir 2/13/2002 17:50'! 102761rawResponseCodes 102762 #(200 'Command okay.' 102763 500 'Syntax error, command unrecognized. This may include errors such as command line too long.' 102764 501 'Syntax error in parameters or arguments.' 102765 202 'Command not implemented, superfluous at this site.' 102766 502 'Command not implemented.' 102767 503 'Bad sequence of commands.' 102768 504 'Command not implemented for that parameter.' 102769 110 'Restart marker reply. In this case, the text is exact and not left to the particular implementation; it must read: MARK yyyy = mmmm Where yyyy is User-process data stream marker, and mmmm server''s equivalent marker (note the spaces between markers and "=").' 102770 211 'System status, or system help reply.' 102771 212 'Directory status.' 102772 213 'File status.' 102773 214 'Help message. On how to use the server or the meaning of a particular non-standard command. This reply is useful only to the human user.' 102774 215 'NAME system type. Where NAME is an official system name from the list in the Assigned Numbers document.' 102775 120 'Service ready in nnn minutes.' 102776 102777 220 'Service ready for new user.' 102778 221 'Service closing control connection. Logged out if appropriate.' 102779 421 'Service not available, closing control connection. This may be a reply to any command if the service knows it must shut down.' 102780 125 'Data connection already open; transfer starting.' 102781 225 'Data connection open; no transfer in progress.' 102782 425 'Can''t open data connection.' 102783 226 'Closing data connection. Requested file action successful (for example, file transfer or file abort).' 102784 426 'Connection closed; transfer aborted.' 102785 227 'Entering Passive Mode (h1,h2,h3,h4,p1,p2).' 102786 102787 230 'User logged in, proceed.' 102788 530 'Not logged in.' 102789 331 'User name okay, need password.' 102790 332 'Need account for login.' 102791 532 'Need account for storing files.' 102792 150 'File status okay; about to open data connection.' 102793 250 'Requested file action okay, completed.' 102794 257 '"PATHNAME" created.' 102795 350 'Requested file action pending further information.' 102796 450 'Requested file action not taken. File unavailable (e.g., file busy).' 102797 550 'Requested action not taken. File unavailable (e.g., file not found, no access).' 102798 451 'Requested action aborted. Local error in processing.' 102799 551 'Requested action aborted. Page type unknown.' 102800 452 'Requested action not taken. Insufficient storage space in system.' 102801 552 'Requested file action aborted. Exceeded storage allocation (for current directory or dataset).' 102802 553 'Requested action not taken. File name not allowed.') 102803! ! 102804Error subclass: #FTPConnectionException 102805 instanceVariableNames: '' 102806 classVariableNames: '' 102807 poolDictionaries: '' 102808 category: 'Exceptions-Kernel'! 102809 102810!FTPConnectionException methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 07:47'! 102811defaultAction 102812 102813 self resume! ! 102814 102815!FTPConnectionException methodsFor: 'as yet unclassified' stamp: 'RAA 3/14/2001 15:57'! 102816isResumable 102817 102818 ^true! ! 102819Object subclass: #FakeClassPool 102820 instanceVariableNames: '' 102821 classVariableNames: '' 102822 poolDictionaries: '' 102823 category: 'System-Tools'! 102824!FakeClassPool commentStamp: '<historical>' prior: 0! 102825The sole purpose of this class is to allow the Browser code pane to evaluate the class variables of the class whose method it is showing. It does this by stuffing a pointer to the classpool dictionary of the class being shown into its own classpool. It does this just around a doIt in the code pane. An instance of FakeClasspool is then used as the receiver of the doIt.! 102826 102827 102828"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 102829 102830FakeClassPool class 102831 instanceVariableNames: ''! 102832 102833!FakeClassPool class methodsFor: 'initialize' stamp: 'dvf 9/27/2005 19:05'! 102834adopt: classOrNil 102835 "Temporarily use the classPool and sharedPools of another class" 102836 classOrNil isBehavior 102837 ifFalse: [classPool := nil. 102838 sharedPools := nil] 102839 ifTrue: [classPool := classOrNil classPool. 102840 sharedPools := classOrNil sharedPools] 102841! ! 102842Boolean subclass: #False 102843 instanceVariableNames: '' 102844 classVariableNames: '' 102845 poolDictionaries: '' 102846 category: 'Kernel-Objects'! 102847!False commentStamp: '<historical>' prior: 0! 102848False defines the behavior of its single instance, false -- logical negation. Notice how the truth-value checks become direct message sends, without the need for explicit testing. 102849 102850Be aware however that most of these methods are not sent as real messages in normal use. Most are inline coded by the compiler as test and jump bytecodes - avoiding the overhead of the full message sends. So simply redefining these methods here will have no effect.! 102851 102852 102853!False methodsFor: 'controlling'! 102854and: alternativeBlock 102855 "Nonevaluating conjunction -- answer with false since the receiver is false." 102856 102857 ^self! ! 102858 102859!False methodsFor: 'controlling'! 102860ifFalse: alternativeBlock 102861 "Answer the value of alternativeBlock. Execution does not actually 102862 reach here because the expression is compiled in-line." 102863 102864 ^alternativeBlock value! ! 102865 102866!False methodsFor: 'controlling'! 102867ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock 102868 "Answer the value of falseAlternativeBlock. Execution does not 102869 actually reach here because the expression is compiled in-line." 102870 102871 ^falseAlternativeBlock value! ! 102872 102873!False methodsFor: 'controlling'! 102874ifTrue: alternativeBlock 102875 "Since the condition is false, answer the value of the false alternative, 102876 which is nil. Execution does not actually reach here because the 102877 expression is compiled in-line." 102878 102879 ^nil! ! 102880 102881!False methodsFor: 'controlling'! 102882ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock 102883 "Answer the value of falseAlternativeBlock. Execution does not 102884 actually reach here because the expression is compiled in-line." 102885 102886 ^falseAlternativeBlock value! ! 102887 102888!False methodsFor: 'controlling'! 102889or: alternativeBlock 102890 "Nonevaluating disjunction -- answer value of alternativeBlock." 102891 102892 ^alternativeBlock value! ! 102893 102894 102895!False methodsFor: 'logical operations' stamp: 'md 7/30/2005 18:05'! 102896& aBoolean 102897 "Evaluating conjunction -- answer false since receiver is false." 102898 102899 ^self! ! 102900 102901!False methodsFor: 'logical operations'! 102902not 102903 "Negation -- answer true since the receiver is false." 102904 102905 ^true! ! 102906 102907!False methodsFor: 'logical operations' stamp: 'em 3/24/2009 14:05'! 102908xor: aBoolean 102909 "Posted by Eliot Miranda to squeak-dev on 3/24/2009" 102910 102911 ^aBoolean! ! 102912 102913!False methodsFor: 'logical operations'! 102914| aBoolean 102915 "Evaluating disjunction (OR) -- answer with the argument, aBoolean." 102916 102917 ^aBoolean! ! 102918 102919 102920!False methodsFor: 'printing' stamp: 'ajh 7/1/2004 10:36'! 102921asBit 102922 102923 ^ 0! ! 102924 102925!False methodsFor: 'printing'! 102926printOn: aStream 102927 102928 aStream nextPutAll: 'false'! ! 102929 102930"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 102931 102932False class 102933 instanceVariableNames: ''! 102934 102935!False class methodsFor: 'as yet unclassified' stamp: 'sw 5/8/2000 11:09'! 102936initializedInstance 102937 ^ false! ! 102938ClassTestCase subclass: #FalseTest 102939 instanceVariableNames: '' 102940 classVariableNames: '' 102941 poolDictionaries: '' 102942 category: 'KernelTests-Objects'! 102943!FalseTest commentStamp: '<historical>' prior: 0! 102944This is the unit test for the class False. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 102945 - http://www.c2.com/cgi/wiki?UnitTest 102946 - http://minnow.cc.gatech.edu/squeak/1547 102947 - the sunit class category 102948! 102949 102950 102951!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:02'! 102952testAND 102953 102954 self assert: (false & true) = false. 102955 self assert: (false & false) = false.! ! 102956 102957!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:02'! 102958testAnd 102959 102960 self assert: (false and: ['alternativeBlock']) = false.! ! 102961 102962!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'! 102963testIfFalse 102964 102965 self assert: ((false ifFalse: ['alternativeBlock']) = 'alternativeBlock'). ! ! 102966 102967!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'! 102968testIfFalseIfTrue 102969 102970 self assert: (false ifFalse: ['falseAlternativeBlock'] 102971 ifTrue: ['trueAlternativeBlock']) = 'falseAlternativeBlock'. ! ! 102972 102973!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'! 102974testIfTrue 102975 102976 self assert: (false ifTrue: ['alternativeBlock']) = nil. ! ! 102977 102978!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'! 102979testIfTrueIfFalse 102980 102981 self assert: (false ifTrue: ['trueAlternativeBlock'] 102982 ifFalse: ['falseAlternativeBlock']) = 'falseAlternativeBlock'. ! ! 102983 102984!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'! 102985testNew 102986 102987 self should: [False new] raise: TestResult error. ! ! 102988 102989!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'! 102990testNot 102991 102992 self assert: (false not = true).! ! 102993 102994!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:04'! 102995testOR 102996 102997 self assert: (false | true) = true. 102998 self assert: (false | false) = false.! ! 102999 103000!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:04'! 103001testOr 103002 103003 self assert: (false or: ['alternativeBlock']) = 'alternativeBlock'.! ! 103004 103005!FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:04'! 103006testPrintOn 103007 103008 self assert: (String streamContents: [:stream | false printOn: stream]) = 'false'. ! ! 103009 103010!FalseTest methodsFor: 'tests' stamp: 'NikoSchwarz 10/17/2009 18:20'! 103011testXor 103012 self assert: (false xor: true) = true. 103013 self assert: (false xor: false) = false. 103014 103015 self 103016 should: [(false xor: [false]) 103017 ifTrue: ["This should never be true, do not signal an Error and let the test fail"] 103018 ifFalse: [self error: 'OK, this should be false, raise an Error']] 103019 raise: Error 103020 description: 'a Block argument is not allowed. If it were, answer would be false'.! ! 103021InflateStream subclass: #FastInflateStream 103022 instanceVariableNames: '' 103023 classVariableNames: 'DistanceMap FixedDistTable FixedLitTable LiteralLengthMap' 103024 poolDictionaries: '' 103025 category: 'Compression-Streams'! 103026!FastInflateStream commentStamp: '<historical>' prior: 0! 103027This class adds the following optimizations to the basic Inflate decompression: 103028 103029a) Bit reversed access 103030If we want to fetch the bits efficiently then we have them in the wrong bit order (e.g., when we should fetch 2r100 we would get 2r001). But since the huffman tree lookup determines the efficiency of the decompression, reversing the bits before traversal is expensive. Therefore the entries in each table are stored in REVERSE BIT ORDER. This is achieved by a reverse increment of the current table index in the huffman table construction phase (see method increment:bits:). According to my measures this speeds up the implementation by about 30-40%. 103031 103032b) Inplace storage of code meanings and extra bits 103033Rather than looking up the meaning for each code during decompression of blocks we store the appropriate values directly in the huffman tables, using a pre-defined mapping. Even though this does not make a big difference in speed, it cleans up the code and allows easier translation into primitive code (which is clearly one goal of this implementation). 103034 103035c) Precomputed huffman tables for fixed blocks 103036So we don't have to compute the huffman tables from scratch. The precomputed tables are not in our superclass to avoid double storage (and my superclass is more intended for documentation anyways).! 103037 103038 103039!FastInflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:02'! 103040nextSingleBits: n 103041 "Fetch the bits all at once" 103042 ^self nextBits: n.! ! 103043 103044 103045!FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:26'! 103046distanceMap 103047 ^DistanceMap! ! 103048 103049!FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:48'! 103050increment: value bits: nBits 103051 "Increment value in reverse bit order, e.g. 103052 for a 3 bit value count as follows: 103053 000 / 100 / 010 / 110 103054 001 / 101 / 011 / 111 103055 See the class comment why we need this." 103056 | result bit | 103057 result := value. 103058 "Test the lowest bit first" 103059 bit := 1 << (nBits - 1). 103060 "If the currently tested bit is set then we need to 103061 turn this bit off and test the next bit right to it" 103062 [(result bitAnd: bit) = 0] whileFalse:[ 103063 "Turn off current bit" 103064 result := result bitXor: bit. 103065 "And continue testing the next bit" 103066 bit := bit bitShift: -1]. 103067 "Turn on the right-most bit that we haven't touched in the loop above" 103068 ^result bitXor: bit! ! 103069 103070!FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:26'! 103071literalLengthMap 103072 ^LiteralLengthMap! ! 103073 103074 103075!FastInflateStream methodsFor: 'inflating' stamp: 'ar 2/2/2001 15:47'! 103076decompressBlock: llTable with: dTable 103077 "Process the compressed data in the block. 103078 llTable is the huffman table for literal/length codes 103079 and dTable is the huffman table for distance codes." 103080 | value extra length distance oldPos oldBits oldBitPos | 103081 <primitive: 'primitiveInflateDecompressBlock' module: 'ZipPlugin'> 103082 [readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[ 103083 "Back up stuff if we're running out of space" 103084 oldBits := bitBuf. 103085 oldBitPos := bitPos. 103086 oldPos := sourcePos. 103087 value := self decodeValueFrom: llTable. 103088 value < 256 ifTrue:[ "A literal" 103089 collection byteAt: (readLimit := readLimit + 1) put: value. 103090 ] ifFalse:["length/distance or end of block" 103091 value = 256 ifTrue:["End of block" 103092 state := state bitAnd: StateNoMoreData. 103093 ^self]. 103094 "Compute the actual length value (including possible extra bits)" 103095 extra := (value bitShift: -16) - 1. 103096 length := value bitAnd: 16rFFFF. 103097 extra > 0 ifTrue:[length := length + (self nextBits: extra)]. 103098 "Compute the distance value" 103099 value := self decodeValueFrom: dTable. 103100 extra := (value bitShift: -16). 103101 distance := value bitAnd: 16rFFFF. 103102 extra > 0 ifTrue:[distance := distance + (self nextBits: extra)]. 103103 (readLimit + length >= collection size) ifTrue:[ 103104 bitBuf := oldBits. 103105 bitPos := oldBitPos. 103106 sourcePos := oldPos. 103107 ^self]. 103108 collection 103109 replaceFrom: readLimit+1 103110 to: readLimit + length + 1 103111 with: collection 103112 startingAt: readLimit - distance + 1. 103113 readLimit := readLimit + length. 103114 ]. 103115 ].! ! 103116 103117!FastInflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 19:15'! 103118processFixedBlock 103119 litTable := FixedLitTable. 103120 distTable := FixedDistTable. 103121 state := state bitOr: BlockProceedBit. 103122 self proceedFixedBlock.! ! 103123 103124"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 103125 103126FastInflateStream class 103127 instanceVariableNames: ''! 103128 103129!FastInflateStream class methodsFor: 'initialization' stamp: 'ar 12/21/1999 23:00'! 103130initialize 103131 "FastInflateStream initialize" 103132 | low high | 103133 103134 "Init literal/length map" 103135 low := #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258 ). 103136 high := #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0 0). 103137 LiteralLengthMap := WordArray new: 256 + 32. 103138 1 to: 257 do:[:i| LiteralLengthMap at: i put: i-1]. 103139 1 to: 29 do:[:i| LiteralLengthMap at: 257+i put: (low at:i) + ( (high at: i) + 1 << 16)]. 103140 103141 "Init distance map" 103142 high := #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13). 103143 low := #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769 103144 1025 1537 2049 3073 4097 6145 8193 12289 16385 24577). 103145 DistanceMap := WordArray new: 32. 103146 1 to: 30 do:[:i| DistanceMap at: i put: (low at: i) + ( (high at: i) << 16)]. 103147 103148 "Init fixed block huffman tables" 103149 FixedLitTable := self basicNew 103150 huffmanTableFrom: FixedLitCodes 103151 mappedBy: LiteralLengthMap. 103152 FixedDistTable := self basicNew 103153 huffmanTableFrom: FixedDistCodes 103154 mappedBy: DistanceMap.! ! 103155VariableNode subclass: #FieldNode 103156 instanceVariableNames: 'fieldDef rcvrNode readNode writeNode' 103157 classVariableNames: '' 103158 poolDictionaries: '' 103159 category: 'Compiler-ParseNodes'! 103160!FieldNode commentStamp: '<historical>' prior: 0! 103161FileNode handles field access in Tweak, e.g. self fieldName := foo => self fieldName: foo.! 103162]style[(90)i! 103163 103164 103165!FieldNode methodsFor: 'accessing' stamp: 'eem 5/12/2008 13:40'! 103166fieldDef 103167 ^fieldDef! ! 103168 103169 103170!FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! 103171emitForEffect: stack on: strm 103172! ! 103173 103174!FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! 103175emitForValue: stack on: aStream 103176 fieldDef accessKey ifNil:[ 103177 rcvrNode emitForValue: stack on: aStream. 103178 readNode emit: stack args: 0 on: aStream super: false. 103179 ] ifNotNil:[ 103180 rcvrNode emitForValue: stack on: aStream. 103181 super emitForValue: stack on: aStream. 103182 readNode emit: stack args: 1 on: aStream super: false. 103183 ]. 103184! ! 103185 103186!FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! 103187emitLoad: stack on: strm 103188 rcvrNode emitForValue: stack on: strm. 103189 fieldDef accessKey ifNotNil:[ 103190 super emitForValue: stack on: strm. 103191 ].! ! 103192 103193!FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! 103194emitStore: stack on: strm 103195 fieldDef accessKey ifNil:[ 103196 writeNode emit: stack args: 1 on: strm super: false. 103197 ] ifNotNil:[ 103198 writeNode emit: stack args: 2 on: strm super: false. 103199 ].! ! 103200 103201!FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! 103202emitStorePop: stack on: strm 103203 self emitStore: stack on: strm. 103204 strm nextPut: Pop. 103205 stack pop: 1.! ! 103206 103207!FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! 103208encodeReceiverOn: encoder 103209 "encode the receiver node" 103210 rcvrNode := encoder encodeVariable: 'self'.! ! 103211 103212!FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! 103213sizeForEffect: encoder 103214 ^0! ! 103215 103216!FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! 103217sizeForStore: encoder 103218 rcvrNode ifNil:[self encodeReceiverOn: encoder]. 103219 fieldDef accessKey ifNil:[ 103220 writeNode ifNil:[writeNode := encoder encodeSelector: fieldDef toSet]. 103221 ^(rcvrNode sizeForValue: encoder) + 103222 (writeNode size: encoder args: 1 super: false) 103223 ]. 103224 writeNode ifNil:[writeNode := encoder encodeSelector: #set:to:]. 103225 ^(rcvrNode sizeForValue: encoder) + 103226 (super sizeForValue: encoder) + 103227 (writeNode size: encoder args: 2 super: false)! ! 103228 103229!FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! 103230sizeForStorePop: encoder 103231 ^(self sizeForStore: encoder) + 1! ! 103232 103233!FieldNode methodsFor: 'code generation' stamp: 'eem 5/12/2008 13:40'! 103234sizeForValue: encoder 103235 rcvrNode ifNil:[self encodeReceiverOn: encoder]. 103236 fieldDef accessKey ifNil:[ 103237 readNode ifNil:[readNode := encoder encodeSelector: fieldDef toGet]. 103238 ^(rcvrNode sizeForValue: encoder) + 103239 (readNode size: encoder args: 0 super: false) 103240 ]. 103241 readNode ifNil:[readNode := encoder encodeSelector: #get:]. 103242 ^(rcvrNode sizeForValue: encoder) + 103243 (super sizeForValue: encoder) + 103244 (readNode size: encoder args: 1 super: false)! ! 103245 103246 103247!FieldNode methodsFor: 'initialize-release' stamp: 'eem 5/12/2008 13:40'! 103248fieldDefinition: fieldDefinition 103249 self name: fieldDefinition name key: fieldDefinition index: nil type: LdLitType! ! 103250 103251!FieldNode methodsFor: 'initialize-release' stamp: 'eem 5/12/2008 13:40'! 103252name: varName key: objRef index: i type: type 103253 fieldDef := objRef. 103254 ^super name: varName key: objRef key index: nil type: LdLitType! ! 103255 103256 103257!FieldNode methodsFor: 'testing' stamp: 'eem 5/12/2008 13:40'! 103258assignmentCheck: encoder at: location 103259 (encoder cantStoreInto: name) ifTrue: [^location]. 103260 fieldDef toSet ifNil:[ 103261 encoder interactive ifTrue:[^location]. 103262 fieldDef := fieldDef clone assignDefaultSetter. 103263 ]. 103264 ^-1! ! 103265 103266 103267!FieldNode methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:49'! 103268accept: aVisitor 103269 aVisitor visitFieldNode: self! ! 103270 103271 103272!FieldNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 103273emitCodeForEffect: stack encoder: encoder! ! 103274 103275!FieldNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 103276emitCodeForLoad: stack encoder: encoder 103277 rcvrNode emitCodeForValue: stack encoder: encoder. 103278 fieldDef accessKey ifNotNil:[ 103279 super emitCodeForValue: stack encoder: encoder. 103280 ].! ! 103281 103282!FieldNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 103283emitCodeForStore: stack encoder: encoder 103284 fieldDef accessKey ifNil:[ 103285 writeNode emitCode: stack args: 1 encoder: encoder super: false. 103286 ] ifNotNil:[ 103287 writeNode emitCode: stack args: 2 encoder: encoder super: false. 103288 ].! ! 103289 103290!FieldNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:18'! 103291emitCodeForStorePop: stack encoder: encoder 103292 self emitCodeForStore: stack encoder: encoder. 103293 encoder genPop. 103294 stack pop: 1.! ! 103295 103296!FieldNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 103297emitCodeForValue: stack encoder: encoder 103298 fieldDef accessKey ifNil:[ 103299 rcvrNode emitCodeForValue: stack encoder: encoder. 103300 readNode emitCode: stack args: 0 encoder: encoder super: false. 103301 ] ifNotNil:[ 103302 rcvrNode emitCodeForValue: stack encoder: encoder. 103303 super emitCodeForValue: stack encoder: encoder. 103304 readNode emitCode: stack args: 1 encoder: encoder super: false. 103305 ].! ! 103306 103307!FieldNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 103308sizeCodeForEffect: encoder 103309 ^0! ! 103310 103311!FieldNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 103312sizeCodeForStore: encoder 103313 rcvrNode ifNil:[self encodeReceiverOn: encoder]. 103314 fieldDef accessKey ifNil:[ 103315 writeNode ifNil:[writeNode := encoder encodeSelector: fieldDef toSet]. 103316 ^(rcvrNode sizeCodeForValue: encoder) + 103317 (writeNode sizeCode: encoder args: 1 super: false) 103318 ]. 103319 writeNode ifNil:[writeNode := encoder encodeSelector: #set:to:]. 103320 ^(rcvrNode sizeCodeForValue: encoder) + 103321 (super sizeCodeForValue: encoder) + 103322 (writeNode sizeCode: encoder args: 2 super: false)! ! 103323 103324!FieldNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:17'! 103325sizeCodeForStorePop: encoder 103326 ^(self sizeCodeForStore: encoder) + encoder sizePop! ! 103327 103328!FieldNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 103329sizeCodeForValue: encoder 103330 rcvrNode ifNil:[self encodeReceiverOn: encoder]. 103331 fieldDef accessKey ifNil:[ 103332 readNode ifNil:[readNode := encoder encodeSelector: fieldDef toGet]. 103333 ^(rcvrNode sizeCodeForValue: encoder) + 103334 (readNode sizeCode: encoder args: 0 super: false) 103335 ]. 103336 readNode ifNil:[readNode := encoder encodeSelector: #get:]. 103337 ^(rcvrNode sizeCodeForValue: encoder) + 103338 (super sizeCodeForValue: encoder) + 103339 (readNode sizeCode: encoder args: 1 super: false)! ! 103340Browser subclass: #FileContentsBrowser 103341 instanceVariableNames: 'packages infoString' 103342 classVariableNames: '' 103343 poolDictionaries: '' 103344 category: 'Tools-File Contents Browser'! 103345!FileContentsBrowser commentStamp: '<historical>' prior: 0! 103346I am a class browser view on a fileout (either a source file (.st) or change set (.cs)). I do not actually load the code into to the system, nor do I alter the classes in the image. Use me to vet code in a comfortable way before loading it into your image. 103347 103348From a FileList, I can be invoked by selecting a source file and selecting the "browse code" menu item from the yellow button menu. 103349 103350I use PseudoClass, PseudoClassOrganizers, and PseudoMetaclass to model the class structure of the source file.! 103351 103352 103353!FileContentsBrowser methodsFor: 'accessing'! 103354contents 103355 self updateInfoView. 103356 (editSelection == #newClass and:[self selectedPackage notNil]) 103357 ifTrue: [^self selectedPackage packageInfo]. 103358 editSelection == #editClass 103359 ifTrue:[^self modifiedClassDefinition]. 103360 ^super contents! ! 103361 103362!FileContentsBrowser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 103363contents: input notifying: aController 103364 "The retrieved information has changed and its source must now be 103365 updated. The information can be a variety of things, depending on the 103366 list selections (such as templates for class or message definition, methods) 103367 or the user menu commands (such as definition, comment, hierarchy). 103368 Answer the result of updating the source." 103369 103370 | aString aText theClass | 103371 aString := input asString. 103372 aText := input asText. 103373 103374 editSelection == #editComment 103375 ifTrue: [theClass := self selectedClass. 103376 theClass ifNil: [self inform: 'You must select a class 103377before giving it a comment.'. 103378 ^ false]. 103379 theClass comment: aText. ^ true]. 103380 editSelection == #editMessageCategories 103381 ifTrue: [^ self changeMessageCategories: aString]. 103382 103383 self inform:'You cannot change the current selection'. 103384 ^false 103385! ! 103386 103387!FileContentsBrowser methodsFor: 'accessing'! 103388packages 103389 ^packages! ! 103390 103391!FileContentsBrowser methodsFor: 'accessing'! 103392packages: aDictionary 103393 packages := aDictionary.! ! 103394 103395!FileContentsBrowser methodsFor: 'accessing'! 103396selectedPackage 103397 | cat | 103398 cat := self selectedSystemCategoryName. 103399 cat isNil ifTrue:[^nil]. 103400 ^self packages at: cat asString ifAbsent:[nil]! ! 103401 103402 103403!FileContentsBrowser methodsFor: 'class list' stamp: 'ar 9/27/2005 20:27'! 103404browseMethodFull 103405 | myClass | 103406 (myClass := self selectedClassOrMetaClass) ifNotNil: 103407 [ToolSet browse: myClass realClass selector: self selectedMessageName]! ! 103408 103409!FileContentsBrowser methodsFor: 'class list'! 103410classList 103411 "Answer an array of the class names of the selected category. Answer an 103412 empty array if no selection exists." 103413 103414 (systemCategoryListIndex = 0 or:[self selectedPackage isNil]) 103415 ifTrue: [^Array new] 103416 ifFalse: [^self selectedPackage classes keys asSortedCollection].! ! 103417 103418!FileContentsBrowser methodsFor: 'class list' stamp: 'DamienCassou 9/23/2009 08:37'! 103419findClass 103420 | pattern foundClass classNames index foundPackage | 103421 self okToChange ifFalse: [^ self classNotFound]. 103422 pattern := (UIManager default request: 'Class Name?') asLowercase. 103423 pattern isEmptyOrNil ifTrue: [^ self]. 103424 classNames := Set new. 103425 self packages do:[:p| classNames addAll: p classes keys]. 103426 classNames := classNames asArray select: 103427 [:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0]. 103428 classNames isEmpty ifTrue: [^ self]. 103429 index := classNames size == 1 103430 ifTrue: [1] 103431 ifFalse: [(UIManager default chooseFrom: classNames lines: #())]. 103432 index = 0 ifTrue: [^ self]. 103433 foundPackage := nil. 103434 foundClass := nil. 103435 self packages do:[:p| 103436 (p classes includesKey: (classNames at: index)) ifTrue:[ 103437 foundClass := p classes at: (classNames at: index). 103438 foundPackage := p]]. 103439 foundClass isNil ifTrue:[^self]. 103440 self systemCategoryListIndex: (self systemCategoryList indexOf: foundPackage packageName asSymbol). 103441 self classListIndex: (self classList indexOf: foundClass name). ! ! 103442 103443!FileContentsBrowser methodsFor: 'class list' stamp: 'DamienCassou 9/29/2009 09:11'! 103444renameClass 103445 | oldName newName | 103446 classListIndex = 0 ifTrue: [^ self]. 103447 self okToChange ifFalse: [^ self]. 103448 oldName := self selectedClass name. 103449 newName := (self request: 'Please type new class name' 103450 initialAnswer: oldName) asSymbol. 103451 (newName isEmptyOrNil or:[newName = oldName]) ifTrue: [^ self]. 103452 (self selectedPackage classes includesKey: newName) 103453 ifTrue: [^ self error: newName , ' already exists in the package']. 103454 systemOrganizer classify: newName under: self selectedSystemCategoryName. 103455 systemOrganizer removeElement: oldName. 103456 self selectedPackage renameClass: self selectedClass to: newName. 103457 self changed: #classList. 103458 self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). 103459! ! 103460 103461!FileContentsBrowser methodsFor: 'class list'! 103462selectedClass 103463 "Answer the class that is currently selected. Answer nil if no selection 103464 exists." 103465 103466 self selectedClassName == nil ifTrue: [^nil]. 103467 ^self selectedPackage classAt: self selectedClassName! ! 103468 103469 103470!FileContentsBrowser methodsFor: 'creation' stamp: 'md 2/24/2006 15:46'! 103471addLowerPanesTo: window at: nominalFractions with: editString 103472 103473 | verticalOffset row codePane infoPane infoHeight divider | 103474 103475 row := AlignmentMorph newColumn 103476 hResizing: #spaceFill; 103477 vResizing: #spaceFill; 103478 layoutInset: 0; 103479 borderWidth: 1; 103480 borderColor: Color black; 103481 layoutPolicy: ProportionalLayout new. 103482 103483 codePane := MorphicTextEditor default on: self text: #contents accept: #contents:notifying: 103484 readSelection: #contentsSelection menu: #codePaneMenu:shifted:. 103485 infoPane := PluggableTextMorph on: self text: #infoViewContents accept: nil 103486 readSelection: nil menu: nil. 103487 infoPane askBeforeDiscardingEdits: false. 103488 verticalOffset := 0. 103489 103490">>not with this browser--- at least not yet --- 103491 innerFractions := 0@0 corner: 1@0. 103492 verticalOffset := self addOptionalAnnotationsTo: row at: innerFractions plus: verticalOffset. 103493 verticalOffset := self addOptionalButtonsTo: row at: innerFractions plus: verticalOffset. 103494<<<<" 103495 103496 infoHeight := 20. 103497 row 103498 addMorph: (codePane borderWidth: 0) 103499 fullFrame: ( 103500 LayoutFrame 103501 fractions: (0@0 corner: 1@1) 103502 offsets: (0@verticalOffset corner: 0@infoHeight negated) 103503 ). 103504 divider := BorderedSubpaneDividerMorph forTopEdge. 103505 divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2. 103506 row 103507 addMorph: divider 103508 fullFrame: ( 103509 LayoutFrame 103510 fractions: (0@1 corner: 1@1) 103511 offsets: (0@infoHeight negated corner: 0@(1-infoHeight)) 103512 ). 103513 row 103514 addMorph: (infoPane borderWidth: 0; hideScrollBarsIndefinitely) 103515 fullFrame: ( 103516 LayoutFrame 103517 fractions: (0@1 corner: 1@1) 103518 offsets: (0@(1-infoHeight) corner: 0@0) 103519 ). 103520 window 103521 addMorph: row 103522 frame: nominalFractions. 103523 103524 row on: #mouseEnter send: #paneTransition: to: window. 103525 row on: #mouseLeave send: #paneTransition: to: window. 103526 103527! ! 103528 103529!FileContentsBrowser methodsFor: 'creation' stamp: 'alain.plantec 5/30/2008 13:03'! 103530createViews 103531 contentsSymbol := self defaultDiffsSymbol. 103532 "#showDiffs or #prettyDiffs" 103533 ^ self openAsMorph! ! 103534 103535!FileContentsBrowser methodsFor: 'creation' stamp: 'sd 11/20/2005 21:27'! 103536openAsMorph 103537 "Create a pluggable version of all the views for a Browser, including views and controllers." 103538 | window aListExtent next mySingletonList | 103539 window := (SystemWindow labelled: 'later') model: self. 103540 self packages size = 1 103541 ifTrue: [ 103542 aListExtent := 0.333333 @ 0.34. 103543 self systemCategoryListIndex: 1. 103544 mySingletonList := PluggableListMorph on: self list: #systemCategorySingleton 103545 selected: #indexIsOne changeSelected: #indexIsOne: 103546 menu: #packageListMenu: 103547 keystroke: #packageListKey:from:. 103548 mySingletonList hideScrollBarsIndefinitely. 103549 window addMorph: mySingletonList frame: (0@0 extent: 1.0@0.06). 103550 next := 0@0.06] 103551 ifFalse: [ 103552 aListExtent := 0.25 @ 0.4. 103553 window addMorph: (PluggableListMorph on: self list: #systemCategoryList 103554 selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: 103555 menu: #packageListMenu: 103556 keystroke: #packageListKey:from:) 103557 frame: (0@0 extent: aListExtent). 103558 next := aListExtent x @ 0]. 103559 103560 self addClassAndSwitchesTo: window at: (next extent: aListExtent) plus: 0. 103561 103562 next := next + (aListExtent x @ 0). 103563 window addMorph: (PluggableListMorph on: self list: #messageCategoryList 103564 selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: 103565 menu: #messageCategoryMenu:) 103566 frame: (next extent: aListExtent). 103567 next := next + (aListExtent x @ 0). 103568 window addMorph: (PluggableListMorph on: self list: #messageList 103569 selected: #messageListIndex changeSelected: #messageListIndex: 103570 menu: #messageListMenu: 103571 keystroke: #messageListKey:from:) 103572 frame: (next extent: aListExtent). 103573 103574 self addLowerPanesTo: window at: (0@0.4 corner: 1@1) with: nil. 103575 ^ window 103576! ! 103577 103578 103579!FileContentsBrowser methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'! 103580methodDiffFor: aString class: aPseudoClass selector: selector meta: meta 103581 "Answer the diff between the current copy of the given class/selector/meta for the string provided" 103582 103583 | theClass source | 103584 theClass := Smalltalk 103585 at: aPseudoClass name 103586 ifAbsent: [^ aString copy]. 103587 meta 103588 ifTrue: [theClass := theClass class]. 103589 (theClass includesSelector: selector) 103590 ifFalse: [^ aString copy]. 103591 source := theClass sourceCodeAt: selector. 103592 ^ Cursor wait 103593 showWhile: [TextDiffBuilder buildDisplayPatchFrom: source to: aString inClass: theClass prettyDiffs: self showingPrettyDiffs]! ! 103594 103595!FileContentsBrowser methodsFor: 'diffs'! 103596modifiedClassDefinition 103597 | pClass rClass old new diff | 103598 pClass := self selectedClassOrMetaClass. 103599 pClass hasDefinition ifFalse:[^pClass definition]. 103600 rClass := Smalltalk at: self selectedClass name asSymbol ifAbsent:[nil]. 103601 rClass isNil ifTrue:[^pClass definition]. 103602 self metaClassIndicated ifTrue:[ rClass := rClass class]. 103603 old := rClass definition. 103604 new := pClass definition. 103605 Cursor wait showWhile:[ 103606 diff := ClassDiffBuilder buildDisplayPatchFrom: old to: new 103607 ]. 103608 ^diff! ! 103609 103610 103611!FileContentsBrowser methodsFor: 'edit pane' stamp: 'md 2/13/2006 14:36'! 103612selectedBytecodes 103613 "Compile the source code for the selected message selector and extract and return 103614 the bytecode listing." 103615 | class selector | 103616 class := self selectedClassOrMetaClass. 103617 selector := self selectedMessageName. 103618 contents := class sourceCodeAt: selector. 103619 contents := Compiler new 103620 parse: contents 103621 in: class 103622 notifying: nil. 103623 contents := contents generate. 103624 ^ contents symbolic asText! ! 103625 103626!FileContentsBrowser methodsFor: 'edit pane' stamp: 'alain.plantec 5/18/2009 15:55'! 103627selectedMessage 103628 "Answer a copy of the source code for the selected message selector." 103629 103630 | class selector | 103631 class := self selectedClassOrMetaClass. 103632 selector := self selectedMessageName. 103633 contents := class sourceCodeAt: selector. 103634 Preferences browseWithPrettyPrint 103635 ifTrue: 103636 [contents := class prettyPrinterClass 103637 format: contents 103638 in: class 103639 notifying: nil]. 103640 self showingAnyKindOfDiffs 103641 ifTrue: 103642 [contents := self 103643 methodDiffFor: contents 103644 class: self selectedClass 103645 selector: self selectedMessageName 103646 meta: self metaClassIndicated]. 103647 ^contents asText makeSelectorBoldIn: class! ! 103648 103649 103650!FileContentsBrowser methodsFor: 'filein/fileout'! 103651fileInClass 103652 Cursor read showWhile:[ 103653 self selectedClass fileIn. 103654 ].! ! 103655 103656!FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'wod 6/16/1998 17:14'! 103657fileInMessage 103658 103659 self selectedMessageName ifNil: [^self]. 103660 Cursor read showWhile: [ 103661 self selectedClassOrMetaClass fileInMethod: self selectedMessageName. 103662 ].! ! 103663 103664!FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'wod 2/3/1999 18:46'! 103665fileInMessageCategories 103666 Cursor read showWhile:[ 103667 self selectedClassOrMetaClass fileInCategory: self selectedMessageCategoryName. 103668 ].! ! 103669 103670!FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'wod 5/13/1998 12:50'! 103671fileInPackage 103672 Cursor read showWhile:[ 103673 self selectedPackage fileIn. 103674 ].! ! 103675 103676!FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'ar 9/27/2005 20:07'! 103677fileIntoNewChangeSet 103678 | p ff | 103679 (p := self selectedPackage) ifNil: [^ Beeper beep]. 103680 ff := FileStream readOnlyFileNamed: p fullPackageName. 103681 ChangeSet newChangesFromStream: ff named: p packageName! ! 103682 103683!FileContentsBrowser methodsFor: 'filein/fileout'! 103684fileOutClass 103685 Cursor write showWhile:[ 103686 self selectedClass fileOut. 103687 ].! ! 103688 103689!FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'wod 6/16/1998 17:14'! 103690fileOutMessage 103691 103692 self selectedMessageName ifNil: [^self]. 103693 Cursor write showWhile: [ 103694 self selectedClassOrMetaClass fileOutMethod: self selectedMessageName].! ! 103695 103696!FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'wod 2/3/1999 18:46'! 103697fileOutMessageCategories 103698 Cursor write showWhile:[ 103699 self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName. 103700 ].! ! 103701 103702!FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'wod 5/13/1998 14:19'! 103703fileOutPackage 103704 Cursor write showWhile:[ 103705 self selectedPackage fileOut. 103706 ].! ! 103707 103708 103709!FileContentsBrowser methodsFor: 'infoview' stamp: 'sma 5/6/2000 19:19'! 103710extraInfo 103711 ^ (self 103712 methodDiffFor: (self selectedClassOrMetaClass sourceCodeAt: self selectedMessageName) 103713 class: self selectedClass 103714 selector: self selectedMessageName 103715 meta: self metaClassIndicated) unembellished 103716 ifTrue: [' - identical'] 103717 ifFalse: [' - modified']! ! 103718 103719!FileContentsBrowser methodsFor: 'infoview'! 103720infoString 103721 ^infoString isNil 103722 ifTrue:[infoString := StringHolder new] 103723 ifFalse:[infoString]! ! 103724 103725!FileContentsBrowser methodsFor: 'infoview' stamp: 'sd 11/20/2005 21:27'! 103726infoViewContents 103727 "Answer the string to show in the info view" 103728 103729 | theClass stamp exists | 103730 editSelection == #newClass ifTrue: [^ self packageInfo: self selectedPackage]. 103731 self selectedClass isNil ifTrue: [^ '']. 103732 theClass := Smalltalk at: self selectedClass name asSymbol ifAbsent: []. 103733 editSelection == #editClass ifTrue: 103734 [^ theClass notNil 103735 ifTrue: ['Class exists already in the system' translated] 103736 ifFalse: ['New class' translated]]. 103737 editSelection == #editMessage ifFalse: [^ '']. 103738 (theClass notNil and: [self metaClassIndicated]) 103739 ifTrue: [theClass := theClass class]. 103740 103741 stamp := self selectedClassOrMetaClass stampAt: self selectedMessageName. 103742 exists := theClass notNil and: [theClass includesSelector: self selectedMessageName]. 103743 ^ stamp = 'methodWasRemoved' 103744 ifTrue: 103745 [exists 103746 ifTrue: 103747 ['Existing method removed by this change-set' translated] 103748 ifFalse: 103749 ['Removal request for a method that is not present in this image' translated]] 103750 ifFalse: 103751 [stamp, ' · ', 103752 (exists 103753 ifTrue: ['Method already exists' translated , self extraInfo] 103754 ifFalse: ['New method' translated])]! ! 103755 103756!FileContentsBrowser methodsFor: 'infoview'! 103757packageInfo: p 103758 | nClasses newClasses oldClasses | 103759 p isNil ifTrue:[^'']. 103760 nClasses := newClasses := oldClasses := 0. 103761 p classes do:[:cls| 103762 nClasses := nClasses + 1. 103763 (Smalltalk includesKey: (cls name asSymbol)) 103764 ifTrue:[oldClasses := oldClasses + 1] 103765 ifFalse:[newClasses := newClasses + 1]]. 103766 ^nClasses printString,' classes (', newClasses printString, ' new / ', oldClasses printString, ' modified)'! ! 103767 103768!FileContentsBrowser methodsFor: 'infoview' stamp: 'alain.plantec 5/30/2008 13:04'! 103769updateInfoView 103770 103771 self changed: #infoViewContents! ! 103772 103773 103774!FileContentsBrowser methodsFor: 'initialization' stamp: 'dew 9/15/2001 16:19'! 103775defaultBrowserTitle 103776 ^ 'File Contents Browser'! ! 103777 103778 103779!FileContentsBrowser methodsFor: 'keys' stamp: 'sma 5/6/2000 18:48'! 103780classListKey: aChar from: view 103781 aChar == $b ifTrue: [^ self browseMethodFull]. 103782 aChar == $N ifTrue: [^ self browseClassRefs]. 103783 self packageListKey: aChar from: view! ! 103784 103785!FileContentsBrowser methodsFor: 'keys' stamp: 'sma 5/6/2000 18:50'! 103786messageListKey: aChar from: view 103787 aChar == $b ifTrue: [^ self browseMethodFull]. 103788 super messageListKey: aChar from: view! ! 103789 103790!FileContentsBrowser methodsFor: 'keys' stamp: 'sma 2/6/2000 12:05'! 103791packageListKey: aChar from: view 103792 aChar == $f ifTrue: [^ self findClass]. 103793 self arrowKey: aChar from: view! ! 103794 103795 103796!FileContentsBrowser methodsFor: 'menus' stamp: 'sma 5/6/2000 18:36'! 103797classListMenu: aMenu 103798 103799 ^ aMenu 103800 labels: 103801'definition 103802comment 103803browse full (b) 103804class refs (N) 103805fileIn 103806fileOut 103807rename... 103808remove 103809remove existing' 103810 lines: #(2 4 6 8) 103811 selections: #(editClass editComment browseMethodFull browseClassRefs fileInClass fileOutClass renameClass removeClass removeUnmodifiedCategories) 103812 103813! ! 103814 103815!FileContentsBrowser methodsFor: 'menus' stamp: 'tpr 3/11/2001 21:26'! 103816classListMenu: aMenu shifted: ignored 103817 "Answer the class list menu, ignoring the state of the shift key in this case" 103818 103819 ^ self classListMenu: aMenu! ! 103820 103821!FileContentsBrowser methodsFor: 'menus' stamp: 'sw 11/13/2001 09:12'! 103822contentsSymbolQuints 103823 "Answer a list of quintuplets representing information on the alternative views available in the code pane. For the file-contents browser, the choices are restricted to source and the two diffing options" 103824 103825 ^ self sourceAndDiffsQuintsOnly! ! 103826 103827!FileContentsBrowser methodsFor: 'menus' stamp: 'wod 5/13/1998 17:39'! 103828messageCategoryMenu: aMenu 103829 103830 ^ aMenu 103831 labels: 103832'fileIn 103833fileOut 103834reorganize 103835add item... 103836rename... 103837remove 103838remove existing' 103839 lines: #(2 3 6) 103840 selections: #(fileInMessageCategories fileOutMessageCategories editMessageCategories addCategory renameCategory removeMessageCategory removeUnmodifiedMethods)! ! 103841 103842!FileContentsBrowser methodsFor: 'menus' stamp: 'sma 2/6/2000 12:28'! 103843messageListMenu: aMenu 103844 103845 ^ aMenu 103846 labels: 103847'fileIn 103848fileOut 103849senders (n) 103850implementors (m) 103851method inheritance (h) 103852versions (v) 103853remove' 103854 lines: #(2 6) 103855 selections: #(fileInMessage fileOutMessage 103856browseSenders browseImplementors methodHierarchy browseVersions 103857removeMessage).! ! 103858 103859!FileContentsBrowser methodsFor: 'menus' stamp: 'sma 4/22/2000 20:52'! 103860packageListMenu: aMenu 103861 ^ aMenu 103862 labels: 103863'find class... (f) 103864fileIn 103865file into new changeset 103866fileOut 103867remove 103868remove existing' 103869 lines: #(1 4 5) 103870 selections: #(findClass fileInPackage fileIntoNewChangeSet fileOutPackage removePackage removeUnmodifiedClasses)! ! 103871 103872 103873!FileContentsBrowser methodsFor: 'metaclass' stamp: 'sd 11/20/2005 21:27'! 103874selectedClassOrMetaClass 103875 "Answer the selected class or metaclass." 103876 103877 | cls | 103878 self metaClassIndicated 103879 ifTrue: [^ (cls := self selectedClass) ifNotNil: [cls metaClass]] 103880 ifFalse: [^ self selectedClass]! ! 103881 103882!FileContentsBrowser methodsFor: 'metaclass' stamp: 'sd 11/20/2005 21:27'! 103883setClassOrganizer 103884 "Install whatever organization is appropriate" 103885 | theClass | 103886 classOrganizer := nil. 103887 metaClassOrganizer := nil. 103888 classListIndex = 0 ifTrue: [^ self]. 103889 classOrganizer := (theClass := self selectedClass) organization. 103890 metaClassOrganizer := theClass metaClass organization. 103891! ! 103892 103893 103894!FileContentsBrowser methodsFor: 'other' stamp: 'bkv 8/13/2003 23:59'! 103895browseSenders 103896 "Create and schedule a message set browser on all senders of the 103897 currently selected message selector. Do nothing if no message is selected." 103898 103899 messageListIndex ~= 0 103900 ifTrue: [self systemNavigation browseAllCallsOn: self selectedMessageName]! ! 103901 103902!FileContentsBrowser methodsFor: 'other' stamp: 'sd 11/20/2005 21:27'! 103903browseVersions 103904 "Create and schedule a message set browser on all versions of the 103905 currently selected message selector." 103906 | class selector | 103907 (selector := self selectedMessageName) ifNotNil: 103908 [class := self selectedClassOrMetaClass. 103909 (class exists and: [class realClass includesSelector: selector]) ifTrue: 103910 [VersionsBrowser 103911 browseVersionsOf: (class realClass compiledMethodAt: selector) 103912 class: class realClass theNonMetaClass 103913 meta: class realClass isMeta 103914 category: self selectedMessageCategoryName 103915 selector: selector]]! ! 103916 103917!FileContentsBrowser methodsFor: 'other'! 103918changeMessageCategories: aString 103919 "The characters in aString represent an edited version of the the message 103920 categories for the selected class. Update this information in the system 103921 and inform any dependents that the categories have been changed. This 103922 message is invoked because the user had issued the categories command 103923 and edited the message categories. Then the user issued the accept 103924 command." 103925 103926 self classOrMetaClassOrganizer changeFromString: aString. 103927 self unlock. 103928 self editClass. 103929 self classListIndex: classListIndex. 103930 ^ true! ! 103931 103932!FileContentsBrowser methodsFor: 'other' stamp: 'sd 11/20/2005 21:27'! 103933didCodeChangeElsewhere 103934 "Determine whether the code for the currently selected method and class has been changed somewhere else." 103935 103936 | aClass | 103937 (aClass := self selectedClassOrMetaClass) ifNil: [^ false]. 103938 103939 (aClass isKindOf: PseudoClass) ifTrue: [^ false]. "class not installed" 103940 ^super didCodeChangeElsewhere! ! 103941 103942!FileContentsBrowser methodsFor: 'other' stamp: 'sw 10/1/2001 11:16'! 103943labelString 103944 "Answer the string for the window title" 103945 103946 ^ 'File Contents Browser ', (self selectedSystemCategoryName ifNil: [''])! ! 103947 103948!FileContentsBrowser methodsFor: 'other' stamp: 'sma 2/6/2000 12:27'! 103949methodHierarchy 103950 (self selectedClassOrMetaClass isNil or: 103951 [self selectedClassOrMetaClass hasDefinition]) 103952 ifFalse: [super methodHierarchy]! ! 103953 103954 103955!FileContentsBrowser methodsFor: 'removing' stamp: 'sd 11/20/2005 21:27'! 103956removeClass 103957 | class | 103958 classListIndex = 0 ifTrue: [^ self]. 103959 class := self selectedClass. 103960 (self confirm:'Are you certain that you 103961want to delete the class ', class name, '?') ifFalse:[^self]. 103962 self selectedPackage removeClass: class. 103963 self classListIndex: 0. 103964 self changed: #classList.! ! 103965 103966!FileContentsBrowser methodsFor: 'removing' stamp: 'sd 11/20/2005 21:27'! 103967removeMessage 103968 | messageName | 103969 messageListIndex = 0 103970 ifTrue: [^ self]. 103971 self okToChange 103972 ifFalse: [^ self]. 103973 messageName := self selectedMessageName. 103974 (self selectedClass confirmRemovalOf: messageName) 103975 ifFalse: [^ false]. 103976 self selectedClassOrMetaClass removeMethod: self selectedMessageName. 103977 self messageListIndex: 0. 103978 self setClassOrganizer. 103979 "In case organization not cached" 103980 self changed: #messageList! ! 103981 103982!FileContentsBrowser methodsFor: 'removing' stamp: 'sd 11/20/2005 21:27'! 103983removeMessageCategory 103984 "If a message category is selected, create a Confirmer so the user can 103985 verify that the currently selected message category should be removed 103986 from the system. If so, remove it." 103987 103988 | messageCategoryName | 103989 messageCategoryListIndex = 0 ifTrue: [^ self]. 103990 self okToChange ifFalse: [^ self]. 103991 messageCategoryName := self selectedMessageCategoryName. 103992 (self messageList size = 0 103993 or: [self confirm: 'Are you sure you want to 103994remove this method category 103995and all its methods?']) ifFalse: [^ self]. 103996 self selectedClassOrMetaClass removeCategory: messageCategoryName. 103997 self messageCategoryListIndex: 0. 103998 self changed: #messageCategoryList.! ! 103999 104000!FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:52'! 104001removePackage 104002 systemCategoryListIndex = 0 ifTrue: [^ self]. 104003 self okToChange ifFalse: [^ self]. 104004 (self confirm: 'Are you sure you want to 104005remove this package 104006and all its classes?') ifFalse:[^self]. 104007 (systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) do:[:el| 104008 systemOrganizer removeElement: el]. 104009 self packages removeKey: self selectedPackage packageName. 104010 systemOrganizer removeCategory: self selectedSystemCategoryName. 104011 self systemCategoryListIndex: 0. 104012 self changed: #systemCategoryList! ! 104013 104014!FileContentsBrowser methodsFor: 'removing' stamp: 'sd 11/20/2005 21:27'! 104015removeUnmodifiedCategories 104016 | theClass | 104017 self okToChange ifFalse: [^self]. 104018 theClass := self selectedClass. 104019 theClass isNil ifTrue: [^self]. 104020 Cursor wait showWhile: 104021 [theClass removeUnmodifiedMethods: theClass selectors. 104022 theClass metaClass removeUnmodifiedMethods: theClass metaClass selectors]. 104023 self messageCategoryListIndex: 0. 104024 self changed: #messageCategoryList.! ! 104025 104026!FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:37'! 104027removeUnmodifiedClasses 104028 | packageList | 104029 self okToChange ifFalse:[^self]. 104030 packageList := self selectedPackage isNil 104031 ifTrue:[self packages] 104032 ifFalse:[Array with: self selectedPackage]. 104033 packageList do:[:package| 104034 package classes copy do:[:theClass| 104035 Cursor wait showWhile:[ 104036 theClass removeAllUnmodified. 104037 ]. 104038 theClass hasChanges ifFalse:[ 104039 package removeClass: theClass. 104040 ]. 104041 ]]. 104042 self classListIndex: 0. 104043 self changed: #classList.! ! 104044 104045!FileContentsBrowser methodsFor: 'removing' stamp: 'wod 2/3/1999 18:47'! 104046removeUnmodifiedMethods 104047 | theClass cat | 104048 self okToChange ifFalse:[^self]. 104049 theClass := self selectedClassOrMetaClass. 104050 theClass isNil ifTrue:[^self]. 104051 cat := self selectedMessageCategoryName. 104052 cat isNil ifTrue:[^self]. 104053 Cursor wait showWhile:[ 104054 theClass removeUnmodifiedMethods: (theClass organization listAtCategoryNamed: cat). 104055 ]. 104056 self messageListIndex: 0. 104057 self changed: #messageList.! ! 104058 104059 104060!FileContentsBrowser methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:20'! 104061buildWith: builder 104062 "Create the ui for the browser" 104063 | windowSpec listSpec textSpec buttonSpec panelSpec max | 104064 windowSpec := builder pluggableWindowSpec new. 104065 windowSpec model: self. 104066 windowSpec label: 'System Browser'. 104067 windowSpec children: OrderedCollection new. 104068 104069 max := self wantsOptionalButtons ifTrue:[0.43] ifFalse:[0.5]. 104070 listSpec := builder pluggableListSpec new. 104071 listSpec 104072 model: self; 104073 list: #systemCategoryList; 104074 getIndex: #systemCategoryListIndex; 104075 setIndex: #systemCategoryListIndex:; 104076 menu: #packageListMenu:; 104077 keyPress: #packageListKey:from:; 104078 frame: (0@0 corner: 0.25@max). 104079 windowSpec children add: listSpec. 104080 104081 listSpec := builder pluggableListSpec new. 104082 listSpec 104083 model: self; 104084 list: #classList; 104085 getIndex: #classListIndex; 104086 setIndex: #classListIndex:; 104087 menu: #classListMenu:; 104088 keyPress: #classListKey:from:; 104089 frame: (0.25@0 corner: 0.5@(max-0.1)). 104090 windowSpec children add: listSpec. 104091 104092 panelSpec := builder pluggablePanelSpec new. 104093 panelSpec frame: (0.25@(max-0.1) corner: 0.5@max). 104094 panelSpec children: OrderedCollection new. 104095 windowSpec children addLast: panelSpec. 104096 104097 buttonSpec := builder pluggableButtonSpec new. 104098 buttonSpec 104099 model: self; 104100 label: 'instance'; 104101 state: #instanceMessagesIndicated; 104102 action: #indicateInstanceMessages; 104103 frame: (0@0 corner: 0.4@1). 104104 panelSpec children addLast: buttonSpec. 104105 104106 buttonSpec := builder pluggableButtonSpec new. 104107 buttonSpec 104108 model: self; 104109 label: '?'; 104110 state: #classCommentIndicated; 104111 action: #plusButtonHit; 104112 frame: (0.4@0 corner: 0.6@1). 104113 panelSpec children addLast: buttonSpec. 104114 104115 buttonSpec := builder pluggableButtonSpec new. 104116 buttonSpec 104117 model: self; 104118 label: 'class'; 104119 state: #classMessagesIndicated; 104120 action: #indicateClassMessages; 104121 frame: (0.6@0 corner: 1@1). 104122 panelSpec children addLast: buttonSpec. 104123 104124 listSpec := builder pluggableListSpec new. 104125 listSpec 104126 model: self; 104127 list: #messageCategoryList; 104128 getIndex: #messageCategoryListIndex; 104129 setIndex: #messageCategoryListIndex:; 104130 menu: #messageCategoryMenu:; 104131 keyPress: #arrowKey:from:; 104132 frame: (0.5@0 corner: 0.75@max). 104133 windowSpec children add: listSpec. 104134 104135 listSpec := builder pluggableListSpec new. 104136 listSpec 104137 model: self; 104138 list: #messageList; 104139 getIndex: #messageListIndex; 104140 setIndex: #messageListIndex:; 104141 menu: #messageListMenu:shifted:; 104142 keyPress: #messageListKey:from:; 104143 frame: (0.75@0 corner: 1@max). 104144 windowSpec children add: listSpec. 104145 104146 self wantsOptionalButtons ifTrue:[ 104147 panelSpec := self buildOptionalButtonsWith: builder. 104148 panelSpec frame: (0@0.43 corner: 1@0.5). 104149 windowSpec children add: panelSpec. 104150 ]. 104151 104152 textSpec := builder pluggableTextSpec new. 104153 textSpec 104154 model: self; 104155 getText: #contents; 104156 setText: #contents:notifying:; 104157 selection: #contentsSelection; 104158 menu: #codePaneMenu:shifted:; 104159 frame: (0@0.5corner: 1@0.92). 104160 windowSpec children add: textSpec. 104161 104162 textSpec := builder pluggableInputFieldSpec new. 104163 textSpec 104164 model: self; 104165 getText: #infoViewContents; 104166 frame: (0@0.92corner: 1@1). 104167 windowSpec children add: textSpec. 104168 104169 ^builder build: windowSpec! ! 104170 104171"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 104172 104173FileContentsBrowser class 104174 instanceVariableNames: ''! 104175 104176!FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 6/12/2004 11:41'! 104177fileReaderServicesForDirectory: aDirectory 104178 ^{ self serviceBrowseCodeFiles }! ! 104179 104180!FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 2/17/2004 19:18'! 104181fileReaderServicesForFile: fullName suffix: suffix 104182 104183 ((FileStream isSourceFileSuffix: suffix) or: [ suffix = '*' ]) 104184 ifTrue: [ ^Array with: self serviceBrowseCode]. 104185 104186 ^(fullName endsWith: 'cs.gz') 104187 ifTrue: [ Array with: self serviceBrowseCompressedCode ] 104188 ifFalse: [#()] 104189! ! 104190 104191!FileContentsBrowser class methodsFor: 'file list services' stamp: 'DamienCassou 9/29/2009 09:11'! 104192selectAndBrowseFile: aFileList 104193 "When no file are selected you can ask to browse several of them" 104194 104195 | selectionPattern files | 104196 selectionPattern := UIManager default request:'What files?' initialAnswer: '*.cs;*.st'. 104197 selectionPattern ifNil: [selectionPattern := String new]. 104198 files := (aFileList directory fileNamesMatching: selectionPattern) 104199 collect: [:each | aFileList directory fullNameFor: each]. 104200 self browseFiles: files. 104201 104202 104203! ! 104204 104205!FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 4/29/2004 10:35'! 104206serviceBrowseCode 104207 "Answer the service of opening a file-contents browser" 104208 104209 ^ (SimpleServiceEntry 104210 provider: self 104211 label: 'code-file browser' 104212 selector: #browseStream: 104213 description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' 104214 buttonLabel: 'code') 104215 argumentGetter: [ :fileList | fileList readOnlyStream ]! ! 104216 104217!FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 6/12/2004 11:35'! 104218serviceBrowseCodeFiles 104219 104220 ^ (SimpleServiceEntry 104221 provider: self 104222 label: 'browse code files' 104223 selector: #selectAndBrowseFile:) 104224 argumentGetter: [ :fileList | fileList ]; 104225 yourself! ! 104226 104227!FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 4/29/2004 10:35'! 104228serviceBrowseCompressedCode 104229 "Answer a service for opening a changelist browser on a file" 104230 104231 ^ (SimpleServiceEntry 104232 provider: self 104233 label: 'code-file browser' 104234 selector: #browseCompressedCodeStream: 104235 description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' 104236 buttonLabel: 'code') 104237 argumentGetter: [ :fileList | fileList readOnlyStream ]! ! 104238 104239!FileContentsBrowser class methodsFor: 'file list services' stamp: 'md 11/23/2004 13:34'! 104240services 104241 "Answer potential file services associated with this class" 104242 104243 ^ {self serviceBrowseCode}.! ! 104244 104245 104246!FileContentsBrowser class methodsFor: 'initialization' stamp: 'GabrielOmarCotelli 6/4/2009 20:36'! 104247initialize 104248 104249 FileServices registerFileReader: self! ! 104250 104251!FileContentsBrowser class methodsFor: 'initialization' stamp: 'GabrielOmarCotelli 6/4/2009 20:37'! 104252unload 104253 104254 FileServices unregisterFileReader: self ! ! 104255 104256 104257!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'tak 3/16/2005 11:37'! 104258browseCompressedCodeStream: aStandardFileStream 104259 "Browse the selected file in fileIn format." 104260 | zipped unzipped | 104261 [zipped := GZipReadStream on: aStandardFileStream. 104262 unzipped := MultiByteBinaryOrTextStream with: zipped contents asString] 104263 ensure: [aStandardFileStream close]. 104264 unzipped reset. 104265 self browseStream: unzipped named: aStandardFileStream name! ! 104266 104267!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 104268browseFiles: fileList 104269 104270 | package organizer packageDict browser | 104271 Cursor wait showWhile: [ 104272 packageDict := Dictionary new. 104273 organizer := SystemOrganizer defaultList: Array new. 104274 fileList do: [:fileName | 104275 package := FilePackage fromFileNamed: fileName. 104276 packageDict 104277 at: package packageName 104278 put: package. 104279 organizer 104280 classifyAll: package classes keys 104281 under: package packageName]. 104282 (browser := self systemOrganizer: organizer) 104283 packages: packageDict]. 104284 self 104285 openBrowserView: browser createViews 104286 label: 'File Contents Browser'. 104287! ! 104288 104289!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nb 6/17/2003 12:25'! 104290browseFile: aFilename 104291 "Open a file contents browser on a file of the given name" 104292 104293 aFilename ifNil: [^ Beeper beep]. 104294 self browseFiles: (Array with: aFilename)! ! 104295 104296!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'edc 5/12/2006 07:09'! 104297browseStream: aStream 104298aStream setConverterForCode. 104299 self browseStream: aStream named: aStream name! ! 104300 104301!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 104302browseStream: aStream named: aString 104303 104304 | package organizer packageDict browser | 104305 Cursor wait showWhile: [ 104306 packageDict := Dictionary new. 104307 browser := self new. 104308 organizer := SystemOrganizer defaultList: Array new. 104309 package := (FilePackage new fullName: aString; fileInFrom: aStream). 104310 packageDict 104311 at: package packageName 104312 put: package. 104313 organizer 104314 classifyAll: package classes keys 104315 under: package packageName. 104316 (browser := self systemOrganizer: organizer) 104317 packages: packageDict]. 104318 self 104319 openBrowserView: browser createViews 104320 label: 'File Contents Browser'. 104321! ! 104322 104323 104324!FileContentsBrowser class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:25'! 104325windowColorSpecification 104326 "Answer a WindowColorSpec object that declares my preference" 104327 104328 ^ WindowColorSpec classSymbol: self name wording: 'File Contents Browser' brightColor: #tan pastelColor: #paleTan helpMessage: 'Lets you view the contents of a file as code, in a browser-like tool.'! ! 104329DialogWindow subclass: #FileDialogWindow 104330 instanceVariableNames: 'directoryTreeMorph fileListMorph directories selectedDirectory selectedFileIndex fileSelectionBlock showDirectoriesInFileList fileSortBlock fileNameText defaultExtension actionSelector answer entryCache entryCacheDirectory previewType previewMorph' 104331 classVariableNames: '' 104332 poolDictionaries: '' 104333 category: 'Polymorph-Widgets-Windows'! 104334!FileDialogWindow commentStamp: 'gvc 5/18/2007 13:10' prior: 0! 104335Dialog based file chooser for selcting or saving files. Supports various types of answer (file stream, file name, directory path etc) with optional extension filters and image or text file preview.! 104336 104337 104338!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/27/2006 10:33'! 104339actionSelector 104340 "Answer the value of actionSelector" 104341 104342 ^ actionSelector! ! 104343 104344!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/27/2006 10:33'! 104345actionSelector: anObject 104346 "Set the value of actionSelector" 104347 104348 actionSelector := anObject! ! 104349 104350!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 10/11/2006 13:33'! 104351defaultExtension 104352 "Answer the value of defaultExtension" 104353 104354 ^ defaultExtension! ! 104355 104356!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 10/11/2006 13:33'! 104357defaultExtension: anObject 104358 "Set the value of defaultExtension" 104359 104360 defaultExtension := anObject! ! 104361 104362!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 14:19'! 104363directories 104364 "Answer the value of directories" 104365 104366 ^ directories! ! 104367 104368!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 14:19'! 104369directories: anObject 104370 "Set the value of directories" 104371 104372 directories := anObject! ! 104373 104374!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 19:51'! 104375directoryTreeMorph 104376 "Answer the value of directoryTreeMorph" 104377 104378 ^ directoryTreeMorph! ! 104379 104380!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 19:51'! 104381directoryTreeMorph: anObject 104382 "Set the value of directoryTreeMorph" 104383 104384 directoryTreeMorph := anObject! ! 104385 104386!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 10:21'! 104387entryCache 104388 "Answer the value of entryCache" 104389 104390 ^ entryCache! ! 104391 104392!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 10:21'! 104393entryCache: anObject 104394 "Set the value of entryCache" 104395 104396 entryCache := anObject! ! 104397 104398!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 10:21'! 104399entryCacheDirectory 104400 "Answer the value of entryCacheDirectory" 104401 104402 ^ entryCacheDirectory! ! 104403 104404!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 10:21'! 104405entryCacheDirectory: anObject 104406 "Set the value of entryCacheDirectory" 104407 104408 entryCacheDirectory := anObject! ! 104409 104410!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 19:51'! 104411fileListMorph 104412 "Answer the value of fileListMorph" 104413 104414 ^ fileListMorph! ! 104415 104416!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 19:51'! 104417fileListMorph: anObject 104418 "Set the value of fileListMorph" 104419 104420 fileListMorph := anObject! ! 104421 104422!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:39'! 104423fileSelectionBlock 104424 "Answer the value of fileSelectionBlock" 104425 104426 ^ fileSelectionBlock! ! 104427 104428!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:45'! 104429fileSelectionBlock: anObject 104430 "Set the value of fileSelectionBlock" 104431 104432 fileSelectionBlock := anObject. 104433 self updateFiles! ! 104434 104435!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:51'! 104436fileSortBlock 104437 "Answer the value of fileSortBlock" 104438 104439 ^ fileSortBlock! ! 104440 104441!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:51'! 104442fileSortBlock: anObject 104443 "Set the value of fileSortBlock" 104444 104445 fileSortBlock := anObject! ! 104446 104447!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 13:55'! 104448previewMorph 104449 "Answer the value of previewMorph" 104450 104451 ^ previewMorph! ! 104452 104453!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 13:55'! 104454previewMorph: anObject 104455 "Set the value of previewMorph" 104456 104457 previewMorph := anObject! ! 104458 104459!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 13:30'! 104460previewType 104461 "Answer the value of previewType" 104462 104463 ^ previewType! ! 104464 104465!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/14/2007 16:42'! 104466previewType: anObject 104467 "Set the value of previewType. 104468 See #updatePreview for supported types." 104469 104470 previewType := anObject! ! 104471 104472!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 14:33'! 104473selectedDirectory 104474 "Answer the value of selectedDirectory" 104475 104476 ^ selectedDirectory! ! 104477 104478!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:49'! 104479selectedDirectory: anObject 104480 "Set the value of selectedDirectory" 104481 104482 selectedDirectory := anObject. 104483 self 104484 selectedFileIndex: 0; 104485 updateSelectedDirectory; 104486 updateFiles! ! 104487 104488!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 15:42'! 104489selectedFileIndex 104490 "Answer the value of selectedFileIndex" 104491 104492 ^ selectedFileIndex! ! 104493 104494!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:46'! 104495selectedFileIndex: anObject 104496 "Set the value of selectedFileIndex" 104497 104498 selectedFileIndex := anObject. 104499 self updateSelectedFile! ! 104500 104501!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:42'! 104502showDirectoriesInFileList 104503 "Answer the value of showDirectoriesInFileList" 104504 104505 ^ showDirectoriesInFileList! ! 104506 104507!FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:44'! 104508showDirectoriesInFileList: anObject 104509 "Set the value of showDirectoriesInFileList" 104510 104511 showDirectoriesInFileList := anObject. 104512 self updateFiles! ! 104513 104514 104515!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/24/2006 10:49'! 104516addInitialPanel 104517 "Add the panel." 104518 104519 super addInitialPanel. 104520 self selectDirectory: FileDirectory default! ! 104521 104522!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/31/2006 15:19'! 104523answer 104524 "Answer the result of performing the action selector." 104525 104526 self cancelled ifTrue: [^nil]. 104527 ^answer! ! 104528 104529!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 14:00'! 104530answer: anObject 104531 "Set the answer." 104532 104533 answer := anObject! ! 104534 104535!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/23/2007 16:04'! 104536answerDirectory 104537 "Set the receiver to answer a directory." 104538 104539 self actionSelector: #selectedAnyFileDirectory. 104540 self fileSelectionBlock: self directoryFileSelectionBlock. 104541 self changed: #okEnabled! ! 104542 104543!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/4/2007 16:08'! 104544answerFileEntry 104545 "Set the receiver to answer the selected file entry." 104546 104547 self actionSelector: #selectedFileEntry. 104548 self changed: #okEnabled! ! 104549 104550!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/4/2007 16:00'! 104551answerFileName 104552 "Set the receiver to answer the selected file name." 104553 104554 self actionSelector: #selectedFileName. 104555 self changed: #okEnabled! ! 104556 104557!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/23/2007 16:04'! 104558answerForceSaveFile 104559 "Set the receiver to answer a forced new file stream." 104560 104561 self actionSelector: #saveForcedSelectedFile. 104562 self changed: #okEnabled! ! 104563 104564!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/23/2007 16:04'! 104565answerOpenFile 104566 "Set the receiver to answer a new file stream on an existing file." 104567 104568 self actionSelector: #openSelectedFile. 104569 self changed: #okEnabled! ! 104570 104571!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/23/2007 16:04'! 104572answerPathName 104573 "Set the receiver to answer the selected path name." 104574 104575 self actionSelector: #selectedPathName. 104576 self changed: #okEnabled! ! 104577 104578!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/23/2007 16:04'! 104579answerSaveFile 104580 "Set the receiver to answer a new file stream." 104581 104582 self actionSelector: #saveSelectedFile. 104583 self changed: #okEnabled! ! 104584 104585!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/27/2006 11:38'! 104586cache: dir 104587 "Cache the contents of the given directory and answer them." 104588 104589 self entryCacheDirectory = dir 104590 ifFalse: [Cursor wait showWhile: [ 104591 self 104592 entryCache: dir entries; 104593 entryCacheDirectory: dir]]. 104594 ^self entryCache! ! 104595 104596!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 11:23'! 104597clearEntryCache 104598 "Clear the entry cache." 104599 104600 self 104601 entryCache: nil; 104602 entryCacheDirectory: nil! ! 104603 104604!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'stephane.ducasse 4/13/2009 21:06'! 104605defaultFileSelectionBlock 104606 "Answer the default file selection block." 104607 104608 ^[:de | 104609 de isDirectory 104610 ifTrue: [self showDirectoriesInFileList] 104611 ifFalse: [self fileNamePattern match: de name]]! ! 104612 104613!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'stephane.ducasse 4/13/2009 21:06'! 104614defaultFileSortBlock 104615 "Answer the default file stor block" 104616 104617 ^[:de1 :de2 | 104618 de1 isDirectory = de2 isDirectory 104619 ifTrue: [de1 name <= de2 name] 104620 ifFalse: [de1 isDirectory 104621 ifTrue: [true] 104622 ifFalse: [de2 isDirectory 104623 ifTrue: [false] 104624 ifFalse: [de1 name <= de2 name]]]]! ! 104625 104626!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/23/2006 14:19'! 104627defaultLabel 104628 "Answer the default label for the receiver." 104629 104630 ^'File' translated! ! 104631 104632!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 11:29'! 104633deleteFileOrDirectory 104634 "Delete the selected file or directory." 104635 104636 |entry| 104637 self hasSelectedFileOrDirectory ifFalse: [^self]. 104638 entry := self selectedFileEntry. 104639 entry isDirectory 104640 ifTrue: [(self 104641 proceed: 'Are you sure you wish to delete the\selected directory along with its files?' withCRs translated 104642 title: 'Delete Directory' translated) ifTrue: [ 104643 self selectedFileDirectory deleteDirectory: entry name. 104644 self 104645 clearEntryCache; 104646 updateDirectories]] 104647 ifFalse: [(self 104648 proceed: 'Are you sure you wish to delete the\file' withCRs translated, ' "', entry name, '"?' 104649 title: 'Delete Directory' translated) ifTrue: [ 104650 self selectedFileDirectory deleteFileNamed: entry name. 104651 self 104652 selectedFileIndex: 0; 104653 clearEntryCache; 104654 updateFiles]].! ! 104655 104656!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'stephane.ducasse 4/13/2009 21:06'! 104657directoryFileSelectionBlock 104658 "Answer the directory file selection block." 104659 104660 ^[:de | 104661 de isDirectory 104662 ifTrue: [self showDirectoriesInFileList] 104663 ifFalse: [false]] ! ! 104664 104665!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/23/2006 14:29'! 104666directoryNamesFor: item 104667 "Answer the filtered entries." 104668 104669 ^item directoryNames! ! 104670 104671!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/15/2007 15:13'! 104672doubleClickFile 104673 "If the selected entry is a directory then navigate it 104674 otherwise ok the dialog." 104675 104676 |fe de sm| 104677 fe := self selectedFileEntry. 104678 fe ifNil: [^self]. 104679 fe isDirectory 104680 ifTrue: [de := self selectedFileDirectory. 104681 sm := self directoryTreeMorph selectedMorph. 104682 self changed: #(openPath), de pathParts. 104683 self selectedDirectory: (sm children detect: [:w | 104684 w complexContents item localName = fe name]) complexContents] 104685 ifFalse: [self ok]! ! 104686 104687!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/16/2007 11:07'! 104688fileItems 104689 "Answer the items for the contents of the selected directory." 104690 104691 ^Cursor wait showWhile: [ 104692 self files collect: [:de | 104693 (self newRow: { 104694 ImageMorph new newForm: (self iconFor: de). 104695 StringMorph contents: de name font: self theme listFont}) 104696 hResizing: #shrinkWrap; 104697 vResizing: #shrinkWrap; 104698 fullBounds; 104699 hResizing: #rigid; 104700 vResizing: #rigid; 104701 changeNoLayout]]! ! 104702 104703!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/24/2006 16:13'! 104704fileNamePattern 104705 "Answer the file name pattern to filter on." 104706 104707 ^self fileNameText withBlanksTrimmed, '*'! ! 104708 104709!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/24/2006 15:54'! 104710fileNameText 104711 "Answer the typed file name." 104712 104713 ^fileNameText! ! 104714 104715!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/3/2007 15:19'! 104716fileNameText: aString 104717 "The typed file name has changed." 104718 104719 fileNameText = aString asString ifTrue: [^self]. 104720 fileNameText := aString asString. 104721 self updateFiles. 104722 self 104723 changed: #fileNameText; 104724 changed: #okEnabled. 104725 self selectFileFromPattern! ! 104726 104727!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/27/2006 11:39'! 104728files 104729 "Answer the contents of the selected directory." 104730 104731 ^(self selectedDirectory ifNil: [^#()]) item isNil 104732 ifTrue: [#()] 104733 ifFalse: [Cursor wait showWhile: [ 104734 ((self cache: self selectedDirectory item) select: self fileSelectionBlock) 104735 asSortedCollection: self fileSortBlock]]! ! 104736 104737!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 10:21'! 104738hasParentDirectory 104739 "Answer whether the selected directory in the tree part has a parent." 104740 104741 ^(self selectedFileDirectory ifNil: [^false]) 104742 containingDirectory pathName notEmpty! ! 104743 104744!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 10:17'! 104745hasSelectedFileOrDirectory 104746 "Answer whether a file or directopry is selected in the file list." 104747 104748 ^self selectedFileIndex ~= 0! ! 104749 104750!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/27/2006 13:50'! 104751iconFor: anEntry 104752 "Answer the icon to use for the directory entry." 104753 104754 ^anEntry isDirectory 104755 ifTrue: [MenuIcons smallOpenIcon] 104756 ifFalse: [(self isImageFile: anEntry name) 104757 ifTrue: [MenuIcons smallPaintIcon] 104758 ifFalse: [MenuIcons smallLeftFlushIcon]]! ! 104759 104760!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/23/2006 14:18'! 104761initialDirectories 104762 "Answer the initial directories." 104763 104764 | dirList | 104765 dirList := (FileDirectory on: '') directoryNames collect: [ :each | 104766 FileDirectoryWrapper with: (FileDirectory on: each) name: each model: self]. 104767 dirList isEmpty ifTrue:[ 104768 dirList := Array with: (FileDirectoryWrapper 104769 with: FileDirectory default 104770 name: FileDirectory default localName 104771 model: self)]. 104772 ^dirList! ! 104773 104774!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 14:01'! 104775initialize 104776 "Initialize the receiver." 104777 104778 selectedFileIndex := 0. 104779 fileNameText := ''. 104780 self 104781 answerPathName; 104782 directories: self initialDirectories; 104783 showDirectoriesInFileList: true; 104784 fileSelectionBlock: self defaultFileSelectionBlock; 104785 fileSortBlock: self defaultFileSortBlock. 104786 super initialize! ! 104787 104788!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2006 13:53'! 104789isImageFile: aString 104790 "Answer whether the file name indicates an image file." 104791 104792 aString ifNil: [^false]. 104793 ^#('pcx' 'bmp' 'jpeg' 'xbm' 'pnm' 'ppm' 'gif' 'pam' 'jpg' 'png' 'pbm') 104794 includes: (FileDirectory extensionFor: aString) asLowercase! ! 104795 104796!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2009 11:17'! 104797isResizeable 104798 "Answer whether we are not we can be resized." 104799 104800 ^true! ! 104801 104802!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 10:39'! 104803newActionButtonRow 104804 "Answer a new row with the action buttons." 104805 104806 ^(self newRow: { 104807 self newUpButton. 104808 self newNewDirectoryButton. 104809 self newDeleteButton}) 104810 listCentering: #bottomRight! ! 104811 104812!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2009 10:55'! 104813newContentMorph 104814 "Answer a new content morph." 104815 104816 self 104817 directoryTreeMorph: self newDirectoryTree; 104818 fileListMorph: self newFileList; 104819 previewMorph: self newPreviewMorph. 104820 ^(self newRow: { 104821 self newColumn: { 104822 self newGroupbox: 'Directory' translated for: self directoryTreeMorph. 104823 (self newLabelGroup: { 104824 'File name' translated->self newFileNameTextEntry}) 104825 vResizing: #shrinkWrap}. 104826 self newGroupbox: 'File' translated forAll: { 104827 self fileListMorph. 104828 self newActionButtonRow}}, 104829 (self previewMorph notNil 104830 ifTrue: [{self newGroupbox: 'Preview' translated for: self previewMorph}] 104831 ifFalse: [#()])) 104832 vResizing: #spaceFill! ! 104833 104834!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:00'! 104835newDeleteButton 104836 "Answer a new delete button." 104837 104838 ^self 104839 newButtonFor: self 104840 getState: nil 104841 action: #deleteFileOrDirectory 104842 arguments: nil 104843 getEnabled: #hasSelectedFileOrDirectory 104844 labelForm: MenuIcons smallDeleteIcon 104845 help: 'Press to delete the selected file or directory' translated! ! 104846 104847!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 11:19'! 104848newDirectory 104849 "Create a new directory within the selected directory." 104850 104851 |dir dirName title| 104852 dir := self selectedFileDirectory ifNil: [^self]. 104853 title := 'Create Directory' translated. 104854 dirName := self 104855 textEntry: 'Enter directory name' translated 104856 title: title. 104857 dirName ifNil: [^self]. 104858 [dir createDirectory: dirName] 104859 on: Error 104860 do: [:ex | [((dir fileExists: dirName) or: [(dir directoryNamed: dirName) exists]) 104861 ifTrue: [^self 104862 alert: 'A file or directory already exists\with the name' withCRs translated, ' "', dirName, '"' 104863 title: title]] on: Error do: []. 104864 ^self 104865 alert: 'Invalid directory name' translated, ' "', dirName, '"' 104866 title: title]. 104867 self updateDirectories! ! 104868 104869!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2009 10:54'! 104870newDirectoryTree 104871 "Answer a new directory tree." 104872 104873 ^(self newTreeFor: self 104874 list: #directories 104875 selected: #selectedDirectory 104876 changeSelected: #selectedDirectory:) 104877 minHeight: 200; 104878 minWidth: 180! ! 104879 104880!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 13:29'! 104881newFileList 104882 "Answer a new file list." 104883 104884 ^(self newMorphListFor: self 104885 list: #fileItems 104886 getSelected: #selectedFileIndex 104887 setSelected: #selectedFileIndex: 104888 help: nil) 104889 doubleClickSelector: #doubleClickFile; 104890 minWidth: 200! ! 104891 104892!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/3/2007 15:20'! 104893newFileNameTextEntry 104894 "Answer a new file name text entry morph." 104895 104896 ^self 104897 newAutoAcceptTextEntryFor: self 104898 getText: #fileNameText 104899 setText: #fileNameText: 104900 getEnabled: nil 104901 help: 'File name filter pattern' translated! ! 104902 104903!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/14/2007 16:33'! 104904newImagePreviewMorph 104905 "Answer a new image preview morph." 104906 104907 ^ImagePreviewMorph new 104908 cornerStyle: self preferredCornerStyle; 104909 image: nil 104910 size: self previewSize! ! 104911 104912!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:01'! 104913newNewDirectoryButton 104914 "Answer a new 'new directory' button." 104915 104916 ^self 104917 newButtonFor: self 104918 getState: nil 104919 action: #newDirectory 104920 arguments: nil 104921 getEnabled: nil 104922 labelForm: MenuIcons smallOpenIcon 104923 help: 'Press to create a new directory within the current directory' translated! ! 104924 104925!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/23/2007 15:59'! 104926newOKButton 104927 "Answer a new OK button." 104928 104929 ^self 104930 newOKButtonFor: self 104931 getEnabled: #okEnabled! ! 104932 104933!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/14/2007 16:24'! 104934newPreviewMorph 104935 "Answer a new preview morph." 104936 104937 self previewType == #image ifTrue: [^self newImagePreviewMorph]. 104938 self previewType == #text ifTrue: [^self newTextPreviewMorph]. 104939 ^nil! ! 104940 104941!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/14/2007 16:39'! 104942newTextPreviewMorph 104943 "Answer a new text preview morph." 104944 104945 ^(self newTextEditorFor: self 104946 getText: nil setText: nil getEnabled: nil) 104947 hResizing: #rigid; 104948 vResizing: #spaceFill; 104949 extent: self previewSize; 104950 minWidth: self previewSize x; 104951 minHeight: self previewSize y; 104952 enabled: false! ! 104953 104954!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:01'! 104955newUpButton 104956 "Answer a new up one directory level button." 104957 104958 ^self 104959 newButtonFor: self 104960 getState: nil 104961 action: #selectParentDirectory 104962 arguments: nil 104963 getEnabled: #hasParentDirectory 104964 labelForm: MenuIcons smallUndoIcon 104965 help: 'Press to switch to the parent of the current directory' translated! ! 104966 104967!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 10:41'! 104968ok 104969 "Apply the changes and close." 104970 104971 self cancelled: false. 104972 self applyChanges. 104973 self answer: (self perform: self actionSelector). 104974 answer ifNil: [ 104975 self cancelled: true. 104976 ^self delete]. 104977 super ok! ! 104978 104979!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/4/2007 16:34'! 104980okEnabled 104981 "Answer wether the ok button should be enabled." 104982 104983 (#(selectedAnyFileDirectory selectedPathName) 104984 includes: self actionSelector) ifTrue: [^true]. 104985 ((#(saveSelectedFile saveForcedSelectedFile) 104986 includes: self actionSelector) and: [self fileNameText notEmpty]) ifTrue: [^true]. 104987 (self actionSelector = #selectedFileName and: [ 104988 self selectedFileName notNil]) ifTrue: [^true]. 104989 ^self selectedFileName notNil and: [self selectedFileEntry isDirectory not]! ! 104990 104991!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/23/2007 15:51'! 104992openSelectedFile 104993 "Open a stream on the selected file if available and return it." 104994 104995 |d f| 104996 d := self selectedFileDirectory ifNil: [^nil]. 104997 f := self selectedFileName ifNil: [^nil]. 104998 self selectedFileEntry isDirectory ifTrue: [^nil]. 104999 ^ (d oldFileNamed: f) ifNil: [d readOnlyFileNamed: f]! ! 105000 105001!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/14/2007 16:38'! 105002previewSize 105003 "Answer the size of preview to use." 105004 105005 self previewType == #text ifTrue: [^256@256]. 105006 ^128@128! ! 105007 105008!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/15/2007 15:13'! 105009saveForcedSelectedFile 105010 "Open a stream on the selected file if available and return it." 105011 105012 |d f| 105013 d := self selectedFileDirectory ifNil: [^nil]. 105014 f := self selectedFileName ifNil: [self fileNameText withBlanksTrimmed]. 105015 f ifEmpty: [^nil]. 105016 ^d forceNewFileNamed: f! ! 105017 105018!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 12:22'! 105019saveSelectedFile 105020 "Open a stream on the selected file if available and return it." 105021 105022 |d f| 105023 d := self selectedFileDirectory ifNil: [^nil]. 105024 f := self selectedFileName ifNil: [self fileNameText withBlanksTrimmed]. 105025 f ifEmpty: [^nil]. 105026 ((FileDirectory extensionFor: f) isEmpty and: [self defaultExtension notNil]) 105027 ifTrue: [f := FileDirectory fileName: f extension: self defaultExtension]. 105028 ^[d newFileNamed: f] 105029 on: FileExistsException do: [ 105030 (self 105031 proceed: ('The file {1} already exists. 105032Overwrite the file?' translated format: {f printString}) 105033 title: 'Save File' translated) 105034 ifTrue: [d forceNewFileNamed: f]]! ! 105035 105036!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/24/2006 10:49'! 105037selectDirectory: aFileDirectory 105038 "Expand and select the given directory." 105039 105040 self changed: #(openPath), aFileDirectory pathParts! ! 105041 105042!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/2/2007 12:19'! 105043selectFileFromPattern 105044 "If there is a single file matching the pattern then select it. 105045 If none then try for a directory." 105046 105047 |f matches subMatches| 105048 f := self files. 105049 matches := f select: [:de | self fileNamePattern match: de name]. 105050 subMatches := matches select: [:de | de isDirectory not]. 105051 subMatches size = 1 ifTrue: [ 105052 ^self selectedFileIndex: (f indexOf: subMatches first)]. 105053 subMatches := matches select: [:de | de isDirectory]. 105054 subMatches size = 1 ifTrue: [^self selectedFileIndex: (f indexOf: subMatches first)]. 105055 self selectedFileIndex: 0! ! 105056 105057!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 10:43'! 105058selectParentDirectory 105059 "Switch to the parent directory." 105060 105061 self hasParentDirectory ifFalse: [^self]. 105062 self selectDirectory: self selectedFileDirectory containingDirectory! ! 105063 105064!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/15/2007 15:04'! 105065selectPathName: aString 105066 "Select the directory and set the file name text 105067 from the given string." 105068 105069 |dir local| 105070 (FileDirectory default directoryExists: aString) 105071 ifTrue: [self selectDirectory: (FileDirectory on: aString)] 105072 ifFalse: [((FileDirectory on: '') directoryExists: aString) 105073 ifTrue: [^self selectDirectory: (FileDirectory on: aString)]. 105074 dir := FileDirectory forFileName: aString. 105075 dir exists 105076 ifTrue: [(dir directoryExists: aString) 105077 ifTrue: [self selectDirectory: (dir directoryNamed: aString)] 105078 ifFalse: [self selectDirectory: dir. 105079 local := FileDirectory localNameFor: aString. 105080 (local notEmpty and: [FileDirectory isLegalFileName: local]) 105081 ifTrue: [self fileNameText: local]]] 105082 ifFalse: [self selectDirectory: FileDirectory default. 105083 self fileNameText: '']]! ! 105084 105085!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/15/2007 15:21'! 105086selectedAnyFileDirectory 105087 "Answer the file directory for the selected file or, if none 105088 or not a directory, the selected file directory." 105089 105090 ^self selectedFileEntry 105091 ifNil: [self selectedFileDirectory] 105092 ifNotNilDo: [:fe | self selectedFileDirectory ifNotNilDo: [:fd | 105093 fe isDirectory ifTrue: [ 105094 fd directoryNamed: fe name]]]! ! 105095 105096!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/15/2007 15:14'! 105097selectedDirectoryName 105098 "Answer the name of the selected directory." 105099 105100 ^(self selectedFileDirectory ifNil: [^nil]) name! ! 105101 105102!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/15/2007 15:13'! 105103selectedFileDirectory 105104 "Answer the selected file directory in the tree part." 105105 105106 ^(self selectedDirectory ifNil: [^nil]) item! ! 105107 105108!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 11/5/2008 12:09'! 105109selectedFileEntry 105110 "Answer the selected file." 105111 105112 self selectedFileIndex = 0 ifTrue: [^nil]. 105113 ^self files at: self selectedFileIndex ifAbsent: [nil]! ! 105114 105115!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/23/2006 17:02'! 105116selectedFileName 105117 "Answer the name of the selected file." 105118 105119 ^(self selectedFileEntry ifNil: [^nil]) name! ! 105120 105121!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/15/2007 15:14'! 105122selectedPathName 105123 "Answer the name of the selected path." 105124 105125 ^(self selectedFileDirectory ifNil: [^nil]) 105126 fullNameFor: (self selectedFileName ifNil: [^self selectedFileDirectory pathName])! ! 105127 105128!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 14:01'! 105129updateDirectories 105130 "Update the directory tree and reselect the current." 105131 105132 |dir| 105133 dir := self selectedFileDirectory. 105134 self changed: #directories. 105135 self selectDirectory: dir! ! 105136 105137!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/24/2006 08:46'! 105138updateFiles 105139 "Notify that the files have changed." 105140 105141 self 105142 changed: #files; 105143 changed: #fileItems! ! 105144 105145!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/14/2007 16:33'! 105146updateImagePreview 105147 "Update the image preview." 105148 105149 |str form| 105150 (self isImageFile: self selectedFileName) 105151 ifFalse: [^self previewMorph 105152 image: nil 105153 size: self previewSize]. 105154 str := self openSelectedFile. 105155 str ifNil: [^self]. 105156 [[str binary. 105157 form := ImageReadWriter formFromStream: str] 105158 on: Error do: []] 105159 ensure: [str close]. 105160 self previewMorph 105161 image: form 105162 size: self previewSize! ! 105163 105164!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/14/2007 16:25'! 105165updatePreview 105166 "Update the preview." 105167 105168 self previewType == #image ifTrue: [self updateImagePreview]. 105169 self previewType == #text ifTrue: [self updateTextPreview]! ! 105170 105171!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 10:41'! 105172updateSelectedDirectory 105173 "Notify that the selected directory has changed." 105174 105175 self 105176 changed: #selectedDirectory; 105177 changed: #selectedFileDirectory; 105178 changed: #selectedPathName; 105179 changed: #hasParentDirectory! ! 105180 105181!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 10:40'! 105182updateSelectedFile 105183 "Notify that the selected file has changed." 105184 105185 self 105186 changed: #selectedFileIndex; 105187 changed: #selectedFileEntry; 105188 changed: #selectedFileName; 105189 changed: #selectedPathName; 105190 changed: #okEnabled; 105191 changed: #hasSelectedFileOrDirectory. 105192 self updatePreview! ! 105193 105194!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/14/2007 16:36'! 105195updateTextPreview 105196 "Update the text preview." 105197 105198 |str text| 105199 str := self openSelectedFile. 105200 str ifNil: [^self]. 105201 [[text := str next: 5000] 105202 on: Error do: []] 105203 ensure: [str close]. 105204 text ifNil: [text := '']. 105205 self previewMorph 105206 setText: text! ! 105207 105208!FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'stephane.ducasse 4/13/2009 21:06'! 105209validExtensions: aList 105210 "Set the filter for the files to be those with the given extensions." 105211 105212 aList notEmpty 105213 ifTrue: [self defaultExtension: aList first]. 105214 self fileSelectionBlock: [:de | 105215 de isDirectory 105216 ifTrue: [self showDirectoriesInFileList] 105217 ifFalse: [(self fileNamePattern match: de name) and: [ 105218 aList includes: (FileDirectory extensionFor: de name asLowercase)]]] ! ! 105219 105220"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 105221 105222FileDialogWindow class 105223 instanceVariableNames: ''! 105224 105225!FileDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/21/2007 12:41'! 105226taskbarIcon 105227 "Answer the icon for the receiver in a task bar." 105228 105229 ^MenuIcons smallOpenIcon! ! 105230Object subclass: #FileDirectory 105231 instanceVariableNames: 'pathName' 105232 classVariableNames: 'DefaultDirectory DirectoryClass StandardMIMEMappings' 105233 poolDictionaries: '' 105234 category: 'Files-Directories'! 105235!FileDirectory commentStamp: '<historical>' prior: 0! 105236A FileDirectory represents a folder or directory in the underlying platform's file system. It carries a fully-qualified path name for the directory it represents, and can enumerate the files and directories within that directory. 105237 105238A FileDirectory can be thought of as a Dictionary whose keys are the local names of files in that directory, and whose values are directory "entries". Each entry is an array of five items: 105239 105240 <name> <creationTime> <modificationTime> <dirFlag> <fileSize> 105241 105242The times are given in seconds, and can be converted to a time and date via Time>dateAndTimeFromSeconds:. See the comment in lookupEntry:... which provides primitive access to this information. 105243! 105244 105245 105246!FileDirectory methodsFor: '*Network-MIME' stamp: 'JMM 5/14/2006 13:59'! 105247fileSuffixesForMimeType: mimeType 105248 "Return a list file suffixes for mime type. This is a suboptimal solution." 105249 105250 | results | 105251 105252 results := SortedCollection sortBlock: [:a :b | a size <= b size]. 105253 MIMEType mimeMappings keysAndValuesDo: [:k :v | 105254 v do: [: mime | 105255 mimeType = mime ifTrue: [results add: k]]]. 105256 ^results! ! 105257 105258!FileDirectory methodsFor: '*Network-MIME' stamp: 'JMM 12/1/2007 15:21'! 105259mimeTypesFor: fileName 105260 "Return a list of MIME types applicable to the receiver. This default implementation uses the file name extension to figure out what we're looking at but specific subclasses may use other means of figuring out what the type of some file is. Some systems like the macintosh use meta data on the file to indicate data type" 105261 105262 ^MIMEType forFileNameReturnMimeTypesOrDefault: fileName! ! 105263 105264 105265!FileDirectory methodsFor: '*network-uri' stamp: 'bf 1/27/2006 18:00'! 105266uri 105267 "Convert my path into a file:// type url. For odd characters use %20 notation." 105268 105269 | list | 105270 list := self pathParts. 105271 ^(String streamContents: [:strm | 105272 strm nextPutAll: 'file:'. 105273 list do: [:each | strm nextPut: $/; nextPutAll: each encodeForHTTP]. 105274 strm nextPut: $/]) asURI! ! 105275 105276!FileDirectory methodsFor: '*network-uri' stamp: 'adrian_lienhard 7/20/2009 21:33'! 105277url 105278 "Convert my path into a file:// type url String." 105279 105280 ^self asUrl asString! ! 105281 105282 105283!FileDirectory methodsFor: 'enumeration' stamp: 'yo 12/19/2003 21:15'! 105284containingDirectory 105285 "Return the directory containing this directory." 105286 105287 ^ FileDirectory on: (FileDirectory dirPathFor: pathName asSqueakPathName) 105288! ! 105289 105290!FileDirectory methodsFor: 'enumeration' stamp: 'nk 2/23/2001 11:35'! 105291directoryEntry 105292 ^self containingDirectory entryAt: self localName! ! 105293 105294!FileDirectory methodsFor: 'enumeration' stamp: 'stephaneducasse 2/4/2006 20:31'! 105295directoryEntryFor: filenameOrPath 105296 "Answer the directory entry for the given file or path. Sorta like a poor man's stat()." 105297 | fName dir | 105298 DirectoryClass splitName: filenameOrPath to:[:filePath :name | 105299 fName := name. 105300 filePath isEmpty 105301 ifTrue: [dir := self] 105302 ifFalse: [dir := FileDirectory on: filePath]]. 105303 self isCaseSensitive 105304 ifTrue:[^dir entries detect:[:entry| entry name = fName] ifNone:[nil]] 105305 ifFalse:[^dir entries detect:[:entry| entry name sameAs: fName] ifNone:[nil]]! ! 105306 105307!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:46'! 105308directoryNamed: localFileName 105309 "Return the subdirectory of this directory with the given name." 105310 105311 ^ FileDirectory on: (self fullNameFor: localFileName) 105312! ! 105313 105314!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:44'! 105315directoryNames 105316 "Return a collection of names for the subdirectories of this directory." 105317 "FileDirectory default directoryNames" 105318 105319 ^ (self entries select: [:entry | entry at: 4]) 105320 collect: [:entry | entry first] 105321! ! 105322 105323!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 12:23'! 105324entries 105325 "Return a collection of directory entries for the files and directories in this directory. Each entry is a five-element array: (<name><creationTime><modificationTime><dirFlag><fileSize>). See primLookupEntryIn:index: for further details." 105326 "FileDirectory default entries" 105327 105328 ^ self directoryContentsFor: pathName 105329! ! 105330 105331!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:39'! 105332fileAndDirectoryNames 105333 "FileDirectory default fileAndDirectoryNames" 105334 105335 ^ self entries collect: [:entry | entry first] 105336! ! 105337 105338!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:44'! 105339fileNames 105340 "Return a collection of names for the files (but not directories) in this directory." 105341 "FileDirectory default fileNames" 105342 105343 ^ (self entries select: [:entry | (entry at: 4) not]) 105344 collect: [:entry | entry first] 105345! ! 105346 105347!FileDirectory methodsFor: 'enumeration' stamp: 'yo 12/19/2003 21:15'! 105348fullName 105349 "Return the full name of this directory." 105350 105351 ^pathName asSqueakPathName 105352! ! 105353 105354!FileDirectory methodsFor: 'enumeration' stamp: 'stephaneducasse 2/4/2006 20:31'! 105355fullNamesOfAllFilesInSubtree 105356 "Answer a collection containing the full names of all the files in the subtree of the file system whose root is this directory." 105357 105358 | result todo dir | 105359 result := OrderedCollection new: 100. 105360 todo := OrderedCollection with: self. 105361 [todo size > 0] whileTrue: [ 105362 dir := todo removeFirst. 105363 dir fileNames do: [:n | result add: (dir fullNameFor: n)]. 105364 dir directoryNames do: [:n | todo add: (dir directoryNamed: n)]]. 105365 ^ result asArray 105366! ! 105367 105368!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:39'! 105369keysDo: nameBlock 105370 "Evaluate the given block for each file or directory name in this directory." 105371 105372 ^ self fileAndDirectoryNames do: nameBlock 105373! ! 105374 105375!FileDirectory methodsFor: 'enumeration' stamp: 'yo 12/19/2003 21:15'! 105376localName 105377 "Return the local name of this directory." 105378 105379 ^FileDirectory localNameFor: pathName asSqueakPathName! ! 105380 105381!FileDirectory methodsFor: 'enumeration' stamp: 'mir 8/24/2001 12:01'! 105382matchingEntries: criteria 105383 "Ignore the filter criteria for now" 105384 ^self entries! ! 105385 105386!FileDirectory methodsFor: 'enumeration' stamp: 'stephaneducasse 2/4/2006 20:31'! 105387statsForDirectoryTree: rootedPathName 105388 "Return the size statistics for the entire directory tree starting at the given root. The result is a three element array of the form: (<number of folders><number of files><total bytes in all files>). This method also serves as an example of how recursively enumerate a directory tree." 105389 "wod 6/16/1998: add Cursor wait, and use 'self pathNameDelimiter asString' rather than hardwired ':' " 105390 "FileDirectory default statsForDirectoryTree: '\smalltalk'" 105391 105392 | dirs files bytes todo p entries | 105393 Cursor wait showWhile: [ 105394 dirs := files := bytes := 0. 105395 todo := OrderedCollection with: rootedPathName. 105396 [todo isEmpty] whileFalse: [ 105397 p := todo removeFirst. 105398 entries := self directoryContentsFor: p. 105399 entries do: [:entry | 105400 (entry at: 4) 105401 ifTrue: [ 105402 todo addLast: (p, self pathNameDelimiter asString, (entry at: 1)). 105403 dirs := dirs + 1] 105404 ifFalse: [ 105405 files := files + 1. 105406 bytes := bytes + (entry at: 5)]]]]. 105407 105408 ^ Array with: dirs with: files with: bytes 105409! ! 105410 105411!FileDirectory methodsFor: 'enumeration' stamp: 'stephaneducasse 2/4/2006 20:31'! 105412withAllSubdirectoriesCollect: aBlock 105413 "Evaluate aBlock with each of the directories in the subtree of the file system whose root is this directory. 105414 Answer the results of these evaluations." 105415 105416 | result todo dir | 105417 result := OrderedCollection new: 100. 105418 todo := OrderedCollection with: self. 105419 [todo size > 0] whileTrue: [ 105420 dir := todo removeFirst. 105421 result add: (aBlock value: dir). 105422 dir directoryNames do: [:n | todo add: (dir directoryNamed: n)]]. 105423 ^ result 105424! ! 105425 105426 105427!FileDirectory methodsFor: 'file directory' stamp: 'stephaneducasse 2/4/2006 20:31'! 105428assureExistenceOfPath: lPath 105429 "Make sure the local directory exists. If necessary, create all parts in between" 105430 | localPath | 105431 localPath := lPath. 105432 localPath isEmpty ifTrue: [ ^self ]. "Assumed to exist" 105433 (self directoryExists: localPath) ifTrue: [^ self]. "exists" 105434 "otherwise check parent first and then create local dir" 105435 self containingDirectory assureExistenceOfPath: self localName. 105436 self createDirectory: localPath! ! 105437 105438!FileDirectory methodsFor: 'file directory' stamp: 'RAA 7/28/2000 13:47'! 105439localNameFor: fullName 105440 "Return the local part the given name." 105441 105442 ^self class localNameFor: fullName! ! 105443 105444!FileDirectory methodsFor: 'file directory' stamp: 'tk 12/13/1999 18:55'! 105445sleep 105446 "Leave the FileList window. Do nothing. Disk directories do not have to be shut down." 105447! ! 105448 105449!FileDirectory methodsFor: 'file directory' stamp: 'di 2/11/2000 22:37'! 105450wakeUp 105451 "Entering a FileList window. Do nothing. Disk directories do not have to be awakened." 105452! ! 105453 105454 105455!FileDirectory methodsFor: 'file name utilities' stamp: 'gk 2/10/2004 13:22'! 105456asUrl 105457 "Convert my path into a file:// type url - a FileUrl." 105458 105459 ^FileUrl pathParts: (self pathParts copyWith: '')! ! 105460 105461!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'! 105462checkName: aFileName fixErrors: fixing 105463 "Check a string aFileName for validity as a file name. Answer the original file name if it is valid. If the name is not valid (e.g., it is too long or contains illegal characters) and fixing is false, raise an error. If fixing is true, fix the name (usually by truncating and/or tranforming characters), and answer the corrected name. The default behavior is just to truncate the name to the maximum length for this platform. Subclasses can do any kind of checking and correction appropriate for their platform." 105464 105465 | maxLength | 105466 aFileName size = 0 ifTrue: [self error: 'zero length file name']. 105467 maxLength := self class maxFileNameLength. 105468 aFileName size > maxLength ifTrue: [ 105469 fixing 105470 ifTrue: [^ aFileName contractTo: maxLength] 105471 ifFalse: [self error: 'file name is too long']]. 105472 105473 ^ aFileName 105474! ! 105475 105476!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'! 105477fileNamesMatching: pat 105478 " 105479 FileDirectory default fileNamesMatching: '*' 105480 FileDirectory default fileNamesMatching: '*.image;*.changes' 105481 " 105482 105483 | files | 105484 files := OrderedCollection new. 105485 105486 (pat findTokens: ';', String crlf) do: [ :tok | 105487 files addAll: (self fileNames select: [:name | tok match: name]) ]. 105488 105489 ^files 105490! ! 105491 105492!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'! 105493fullNameFor: fileName 105494 "Return a corrected, fully-qualified name for the given file name. If the given name is already a full path (i.e., it contains a delimiter character), assume it is already a fully-qualified name. Otherwise, prefix it with the path to this directory. In either case, correct the local part of the file name." 105495 "Details: Note that path relative to a directory, such as '../../foo' are disallowed by this algorithm. Also note that this method is tolerent of a nil argument -- is simply returns nil in this case." 105496 105497 | correctedLocalName prefix | 105498 fileName ifNil: [^ nil]. 105499 DirectoryClass splitName: fileName to: 105500 [:filePath :localName | 105501 correctedLocalName := localName isEmpty 105502 ifFalse: [self checkName: localName fixErrors: true] 105503 ifTrue: [localName]. 105504 prefix := self fullPathFor: filePath]. 105505 prefix isEmpty 105506 ifTrue: [^correctedLocalName]. 105507 prefix last = self pathNameDelimiter 105508 ifTrue:[^ prefix, correctedLocalName] 105509 ifFalse:[^ prefix, self slash, correctedLocalName]! ! 105510 105511!FileDirectory methodsFor: 'file name utilities' stamp: 'jm 12/4/97 21:19'! 105512isLegalFileName: aString 105513 "Answer true if the given string is a legal file name." 105514 105515 ^ (self checkName: aString fixErrors: true) = aString 105516! ! 105517 105518!FileDirectory methodsFor: 'file name utilities' stamp: 'ar 2/27/2001 22:23'! 105519isTypeFile 105520 ^true! ! 105521 105522!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'! 105523lastNameFor: baseFileName extension: extension 105524 "Assumes a file name includes a version number encoded as '.' followed by digits 105525 preceding the file extension. Increment the version number and answer the new file name. 105526 If a version number is not found, set the version to 1 and answer a new file name" 105527 105528 | files splits | 105529 105530 files := self fileNamesMatching: (baseFileName,'*', self class dot, extension). 105531 splits := files 105532 collect: [:file | self splitNameVersionExtensionFor: file] 105533 thenSelect: [:split | (split at: 1) = baseFileName]. 105534 splits := splits asSortedCollection: [:a :b | (a at: 2) < (b at: 2)]. 105535 ^splits isEmpty 105536 ifTrue: [nil] 105537 ifFalse: [(baseFileName, '.', (splits last at: 2) asString, self class dot, extension) asFileName]! ! 105538 105539!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'! 105540nextNameFor: baseFileName extension: extension 105541 "Assumes a file name includes a version number encoded as '.' followed by digits 105542 preceding the file extension. Increment the version number and answer the new file name. 105543 If a version number is not found, set the version to 1 and answer a new file name" 105544 105545 | files splits version | 105546 105547 files := self fileNamesMatching: (baseFileName,'*', self class dot, extension). 105548 splits := files 105549 collect: [:file | self splitNameVersionExtensionFor: file] 105550 thenSelect: [:split | (split at: 1) = baseFileName]. 105551 splits := splits asSortedCollection: [:a :b | (a at: 2) < (b at: 2)]. 105552 splits isEmpty 105553 ifTrue: [version := 1] 105554 ifFalse: [version := (splits last at: 2) + 1]. 105555 ^ (baseFileName, '.', version asString, self class dot, extension) asFileName! ! 105556 105557!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'! 105558realUrl 105559 "Senders expect url without trailing slash - #url returns slash" 105560 | url | 105561 url := self url. 105562 url last = $/ ifTrue:[^url copyFrom: 1 to: url size-1]. 105563 ^url! ! 105564 105565!FileDirectory methodsFor: 'file name utilities' stamp: 'yo 12/19/2003 21:15'! 105566relativeNameFor: aFileName 105567 "Return the full name for aFileName, assuming that aFileName is a name relative to me." 105568 aFileName isEmpty ifTrue: [ ^pathName asSqueakPathName]. 105569 ^aFileName first = self pathNameDelimiter 105570 ifTrue: [ pathName asSqueakPathName, aFileName ] 105571 ifFalse: [ pathName asSqueakPathName, self slash, aFileName ] 105572! ! 105573 105574!FileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'! 105575splitNameVersionExtensionFor: fileName 105576 " answer an array with the root name, version # and extension. 105577 See comment in nextSequentialNameFor: for more details" 105578 105579 | baseName version extension i j | 105580 105581 baseName := self class baseNameFor: fileName. 105582 extension := self class extensionFor: fileName. 105583 i := j := baseName findLast: [:c | c isDigit not]. 105584 i = 0 105585 ifTrue: [version := 0] 105586 ifFalse: 105587 [(baseName at: i) = $. 105588 ifTrue: 105589 [version := (baseName copyFrom: i+1 to: baseName size) asNumber. 105590 j := j - 1] 105591 ifFalse: [version := 0]. 105592 baseName := baseName copyFrom: 1 to: j]. 105593 ^ Array with: baseName with: version with: extension! ! 105594 105595 105596!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'! 105597copyFileNamed: fileName1 toFileNamed: fileName2 105598 "Copy the contents of the existing file with the first name into a new file with the second name. Both files are assumed to be in this directory." 105599 "FileDirectory default copyFileNamed: 'todo.txt' toFileNamed: 'todocopy.txt'" 105600 105601 | file1 file2 | 105602 file1 := (self readOnlyFileNamed: fileName1) binary. 105603 file2 := (self newFileNamed: fileName2) binary. 105604 self copyFile: file1 toFile: file2. 105605 file1 close. 105606 file2 close. 105607! ! 105608 105609!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'! 105610copyFileWithoutOverwriteConfirmationNamed: fileName1 toFileNamed: fileName2 105611 "Copy the contents of the existing file with the first name into a file with the second name (which may or may not exist). If the second file exists, force an overwrite without confirming. Both files are assumed to be in this directory." 105612 "FileDirectory default copyFileWithoutOverwriteConfirmationNamed: 'todo.txt' toFileNamed: 'todocopy.txt'" 105613 105614 | file1 file2 | 105615 fileName1 = fileName2 ifTrue: [^ self]. 105616 file1 := (self readOnlyFileNamed: fileName1) binary. 105617 file2 := (self forceNewFileNamed: fileName2) binary. 105618 self copyFile: file1 toFile: file2. 105619 file1 close. 105620 file2 close.! ! 105621 105622!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'! 105623copyFile: fileStream1 toFile: fileStream2 105624 | buffer | 105625 buffer := String new: 50000. 105626 [fileStream1 atEnd] whileFalse: 105627 [fileStream2 nextPutAll: (fileStream1 nextInto: buffer)]. 105628! ! 105629 105630!FileDirectory methodsFor: 'file operations' stamp: 'yo 2/24/2005 18:33'! 105631createDirectory: localFileName 105632 "Create a directory with the given name in this directory. Fail if the name is bad or if a file or directory with that name already exists." 105633 105634 self primCreateDirectory: (self fullNameFor: localFileName) asVmPathName 105635! ! 105636 105637!FileDirectory methodsFor: 'file operations' stamp: 'yo 2/24/2005 18:33'! 105638deleteDirectory: localDirName 105639 "Delete the directory with the given name in this directory. Fail if the path is bad or if a directory by that name does not exist." 105640 105641 self primDeleteDirectory: (self fullNameFor: localDirName) asVmPathName. 105642! ! 105643 105644!FileDirectory methodsFor: 'file operations' stamp: 'jm 12/5/97 16:33'! 105645deleteFileNamed: localFileName 105646 "Delete the file with the given name in this directory." 105647 105648 self deleteFileNamed: localFileName ifAbsent: []. 105649! ! 105650 105651!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'! 105652deleteFileNamed: localFileName ifAbsent: failBlock 105653 "Delete the file of the given name if it exists, else evaluate failBlock. 105654 If the first deletion attempt fails do a GC to force finalization of any lost references. ar 3/21/98 17:53" 105655 | fullName | 105656 fullName := self fullNameFor: localFileName. 105657 (StandardFileStream 105658 retryWithGC:[self primDeleteFileNamed: (self fullNameFor: localFileName) asVmPathName] 105659 until:[:result| result notNil] 105660 forFileNamed: fullName) == nil 105661 ifTrue: [^failBlock value]. 105662! ! 105663 105664!FileDirectory methodsFor: 'file operations' stamp: 'tpr 3/26/2002 16:48'! 105665deleteLocalFiles 105666 "Delete the local files in this directory." 105667 105668 self fileNames do:[:fn| self deleteFileNamed: fn ifAbsent: [(CannotDeleteFileException new 105669 messageText: 'Could not delete the old version of file ' , (self fullNameFor: fn)) signal]] 105670! ! 105671 105672!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'! 105673fileOrDirectoryExists: filenameOrPath 105674 "Answer true if either a file or a directory file of the given name exists. The given name may be either a full path name or a local name within this directory." 105675 "FileDirectory default fileOrDirectoryExists: Smalltalk sourcesName" 105676 105677 | fName dir | 105678 DirectoryClass splitName: filenameOrPath to: 105679 [:filePath :name | 105680 fName := name. 105681 filePath isEmpty 105682 ifTrue: [dir := self] 105683 ifFalse: [dir := FileDirectory on: filePath]]. 105684 105685 ^ (dir includesKey: fName) or: [ fName = '' and:[ dir entries size > 1]]! ! 105686 105687!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'! 105688getMacFileTypeAndCreator: fileName 105689 | results typeString creatorString | 105690 "get the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. Does nothing on other platforms (where the underlying primitive is a noop)." 105691 "FileDirectory default getMacFileNamed: 'foo'" 105692 105693 typeString := ByteArray new: 4 withAll: ($? asInteger). 105694 creatorString := ByteArray new: 4 withAll: ($? asInteger). 105695 [self primGetMacFileNamed: (self fullNameFor: fileName) asVmPathName 105696 type: typeString 105697 creator: creatorString.] ensure: 105698 [typeString := typeString asString. 105699 creatorString := creatorString asString]. 105700 results := Array with: typeString convertFromSystemString with: creatorString convertFromSystemString. 105701 ^results 105702! ! 105703 105704!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'! 105705putFile: file1 named: destinationFileName 105706 "Copy the contents of the existing fileStream into the file destinationFileName in this directory. fileStream can be anywhere in the fileSystem." 105707 105708 | file2 | 105709 file1 binary. 105710 (file2 := self newFileNamed: destinationFileName) ifNil: [^ false]. 105711 file2 binary. 105712 self copyFile: file1 toFile: file2. 105713 file1 close. 105714 file2 close. 105715 ^ true 105716! ! 105717 105718!FileDirectory methodsFor: 'file operations' stamp: 'tk 2/26/2000 12:54'! 105719putFile: file1 named: destinationFileName retry: aBool 105720 "Copy the contents of the existing fileStream into the file destinationFileName in this directory. fileStream can be anywhere in the fileSystem. No retrying for local file systems." 105721 105722 ^ self putFile: file1 named: destinationFileName 105723! ! 105724 105725!FileDirectory methodsFor: 'file operations' stamp: 'tpr 3/26/2002 18:09'! 105726recursiveDelete 105727 "Delete the this directory, recursing down its tree." 105728 self directoryNames 105729 do: [:dn | (self directoryNamed: dn) recursiveDelete]. 105730 self deleteLocalFiles. 105731 "should really be some exception handling for directory deletion, but no 105732 support for it yet" 105733 self containingDirectory deleteDirectory: self localName! ! 105734 105735!FileDirectory methodsFor: 'file operations' stamp: 'alain.plantec 2/10/2009 18:08'! 105736rename: oldFileName toBe: newFileName 105737 | selection oldName newName | 105738 "Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name." 105739 "Modified for retry after GC ar 3/21/98 18:09" 105740 oldName := self fullNameFor: oldFileName. 105741 newName := self fullNameFor: newFileName. 105742 (StandardFileStream 105743 retryWithGC:[self primRename: oldName asVmPathName to: newName asVmPathName] 105744 until:[:result| result notNil] 105745 forFileNamed: oldName) ~~ nil ifTrue:[^self]. 105746 (self fileExists: oldFileName) ifFalse:[ 105747 ^self error:'Attempt to rename a non-existent file'. 105748 ]. 105749 (self fileExists: newFileName) ifTrue:[ 105750 selection := UIManager default confirm: 'Trying to rename a file to be' translated, ' 105751', newFileName , ' 105752', 'and it already exists' translated, ' 105753', 'delete old version?' translated. 105754 selection ifTrue: 105755 [self deleteFileNamed: newFileName. 105756 ^ self rename: oldFileName toBe: newFileName]]. 105757 ^self error:'Failed to rename file'.! ! 105758 105759!FileDirectory methodsFor: 'file operations' stamp: 'yo 2/24/2005 18:34'! 105760setMacFileNamed: fileName type: typeString creator: creatorString 105761 "Set the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. Does nothing on other platforms (where the underlying primitive is a noop)." 105762 "FileDirectory default setMacFileNamed: 'foo' type: 'TEXT' creator: 'ttxt'" 105763 105764 self primSetMacFileNamed: (self fullNameFor: fileName) asVmPathName 105765 type: typeString convertToSystemString 105766 creator: creatorString convertToSystemString. 105767! ! 105768 105769!FileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'! 105770upLoadProject: projectFile named: destinationFileName resourceUrl: resUrl retry: aBool 105771 "Copy the contents of the existing fileStream into the file destinationFileName in this directory. fileStream can be anywhere in the fileSystem. No retrying for local file systems." 105772 105773 | result | 105774 result := self putFile: projectFile named: destinationFileName. 105775 [self 105776 setMacFileNamed: destinationFileName 105777 type: 'SOBJ' 105778 creator: 'FAST'] 105779 on: Error 105780 do: [ "ignore" ]. 105781 ^result! ! 105782 105783 105784!FileDirectory methodsFor: 'file status' stamp: 'mdr 1/14/2000 21:16'! 105785entryAt: fileName 105786 "find the entry with local name fileName" 105787 105788 ^self entryAt: fileName ifAbsent: [ self error: 'file not in directory: ', fileName ].! ! 105789 105790!FileDirectory methodsFor: 'file status' stamp: 'stephaneducasse 2/4/2006 20:31'! 105791entryAt: fileName ifAbsent: aBlock 105792 "Find the entry with local name fileName and answer it. 105793 If not found, answer the result of evaluating aBlock." 105794 105795 | comparisonBlock | 105796 self isCaseSensitive 105797 ifTrue: [comparisonBlock := [:entry | (entry at: 1) = fileName]] 105798 ifFalse: [comparisonBlock := [:entry | (entry at: 1) sameAs: fileName]]. 105799 ^ self entries detect: comparisonBlock ifNone: [aBlock value]! ! 105800 105801 105802!FileDirectory methodsFor: 'file stream creation' stamp: 'tk 5/19/1998 09:03'! 105803fileNamed: localFileName 105804 "Open the file with the given name in this directory for writing." 105805 105806 ^ FileStream concreteStream fileNamed: (self fullNameFor: localFileName) 105807! ! 105808 105809!FileDirectory methodsFor: 'file stream creation' stamp: 'dew 10/26/2000 02:08'! 105810forceNewFileNamed: localFileName 105811 "Open the file with the given name in this directory for writing. If it already exists, delete it first without asking." 105812 105813 ^ FileStream concreteStream forceNewFileNamed: (self fullNameFor: localFileName) 105814! ! 105815 105816!FileDirectory methodsFor: 'file stream creation' stamp: 'tk 5/19/1998 09:03'! 105817newFileNamed: localFileName 105818 "Create a new file with the given name in this directory." 105819 105820 ^ FileStream concreteStream newFileNamed: (self fullNameFor: localFileName) 105821! ! 105822 105823!FileDirectory methodsFor: 'file stream creation' stamp: 'tk 5/19/1998 09:03'! 105824oldFileNamed: localFileName 105825 "Open the existing file with the given name in this directory." 105826 105827 ^ FileStream concreteStream oldFileNamed: (self fullNameFor: localFileName) 105828! ! 105829 105830!FileDirectory methodsFor: 'file stream creation' stamp: 'GabrielOmarCotelli 6/6/2009 19:11'! 105831oldFileOrNoneNamed: localFileName 105832 "If the file exists, answer a read-only FileStream on it. If it doesn't, answer nil." 105833 105834 ^ FileStream oldFileOrNoneNamed: (self fullNameFor: localFileName) 105835! ! 105836 105837!FileDirectory methodsFor: 'file stream creation' stamp: 'tk 5/19/1998 09:03'! 105838readOnlyFileNamed: localFileName 105839 "Open the existing file with the given name in this directory for read-only access." 105840 105841 ^ FileStream concreteStream readOnlyFileNamed: (self fullNameFor: localFileName) 105842! ! 105843 105844 105845!FileDirectory methodsFor: 'nil' stamp: 'adrian-lienhard 5/17/2009 22:03'! 105846assureExistence 105847 "Make sure the current directory exists. If necessary, create all parts in between" 105848 105849 self containingDirectory assureExistenceOfPath: self localName! ! 105850 105851 105852!FileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'! 105853fullPathFor: path 105854 ^path isEmpty ifTrue:[pathName asSqueakPathName] ifFalse:[path]! ! 105855 105856!FileDirectory methodsFor: 'path access' stamp: 'tk 5/18/1998 22:29'! 105857on: fullPath 105858 "Return another instance" 105859 105860 ^ self class on: fullPath! ! 105861 105862!FileDirectory methodsFor: 'path access' stamp: 'stephaneducasse 2/4/2006 20:31'! 105863pathFromUrl: aFileUrl 105864 | first | 105865 ^String streamContents: [ :s | 105866 first := false. 105867 aFileUrl path do: [ :p | 105868 first ifTrue: [ s nextPut: self pathNameDelimiter ]. 105869 first := true. 105870 s nextPutAll: p ] ].! ! 105871 105872!FileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'! 105873pathName 105874 "Return the path from the root of the file system to this directory." 105875 105876 ^ pathName asSqueakPathName. 105877 105878! ! 105879 105880!FileDirectory methodsFor: 'path access' stamp: 'jm 12/5/97 12:19'! 105881pathNameDelimiter 105882 "Return the delimiter character for this kind of directory. This depends on the current platform." 105883 105884 ^ self class pathNameDelimiter 105885! ! 105886 105887!FileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'! 105888pathParts 105889 "Return the path from the root of the file system to this directory as an array of directory names." 105890 105891 ^ pathName asSqueakPathName findTokens: self pathNameDelimiter asString! ! 105892 105893!FileDirectory methodsFor: 'path access' stamp: 'ar 12/18/1999 00:36'! 105894slash 105895 ^self class slash! ! 105896 105897 105898!FileDirectory methodsFor: 'printing' stamp: 'yo 12/19/2003 21:15'! 105899printOn: aStream 105900 "Refer to the comment in Object|printOn:." 105901 105902 aStream nextPutAll: self class name. 105903 aStream nextPutAll: ' on '. 105904 pathName asSqueakPathName printOn: aStream. 105905! ! 105906 105907 105908!FileDirectory methodsFor: 'searching' stamp: 'stephaneducasse 2/4/2006 20:31'! 105909filesContaining: searchString caseSensitive: aBoolean 105910 | aList | 105911 "Search the contents of all files in the receiver and its subdirectories for the search string. Return a list of paths found. Make the search case sensitive if aBoolean is true." 105912 105913 aList := OrderedCollection new. 105914 self withAllFilesDo: [:stream | 105915 (stream contentsOfEntireFile includesSubstring: searchString caseSensitive: aBoolean) 105916 ifTrue: [aList add: stream name]] 105917 andDirectoriesDo: [:d | d pathName]. 105918 ^ aList 105919 105920"FileDirectory default filesContaining: 'includesSubstring:' caseSensitive: true"! ! 105921 105922!FileDirectory methodsFor: 'searching' stamp: 'stephane.ducasse 4/13/2009 20:30'! 105923withAllFilesDo: fileStreamBlock andDirectoriesDo: directoryBlock 105924 105925 "For the receiver and all it's subdirectories evaluate directoryBlock. 105926 For a read only file stream on each file within the receiver 105927 and it's subdirectories evaluate fileStreamBlock." 105928 105929 | todo dir | 105930 105931 todo := OrderedCollection with: self. 105932 [todo size > 0] whileTrue: [ 105933 dir := todo removeFirst. 105934 directoryBlock value: dir. 105935 dir fileNames do: [:n | 105936 fileStreamBlock value: 105937 (FileStream readOnlyFileNamed: (dir fullNameFor: n))]. 105938 dir directoryNames do: [:n | 105939 todo add: (dir directoryNamed: n)]] 105940 105941! ! 105942 105943 105944!FileDirectory methodsFor: 'squeaklets' stamp: 'RAA 10/17/2000 14:57'! 105945directoryObject 105946 105947 ^self! ! 105948 105949!FileDirectory methodsFor: 'squeaklets' stamp: 'mir 6/17/2001 23:42'! 105950downloadUrl 105951 ^''! ! 105952 105953!FileDirectory methodsFor: 'squeaklets' stamp: 'RAA 10/12/2000 17:18'! 105954updateProjectInfoFor: aProject 105955 105956 "only swiki servers for now"! ! 105957 105958!FileDirectory methodsFor: 'squeaklets' stamp: 'dgd 12/23/2003 16:21'! 105959writeProject: aProject inFileNamed: fileNameString fromDirectory: localDirectory 105960 "write aProject (a file version can be found in the file named fileNameString in localDirectory)" 105961 aProject 105962 writeFileNamed: fileNameString 105963 fromDirectory: localDirectory 105964 toServer: self! ! 105965 105966 105967!FileDirectory methodsFor: 'testing' stamp: 'mir 6/25/2001 13:08'! 105968acceptsUploads 105969 ^true! ! 105970 105971!FileDirectory methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:31'! 105972directoryExists: filenameOrPath 105973 "Answer true if a directory of the given name exists. The given name may be either a full path name or a local directory within this directory." 105974 "FileDirectory default directoryExists: FileDirectory default pathName" 105975 105976 | fName dir | 105977 DirectoryClass splitName: filenameOrPath to: 105978 [:filePath :name | 105979 fName := name. 105980 filePath isEmpty 105981 ifTrue: [dir := self] 105982 ifFalse: [dir := self directoryNamed: filePath]]. 105983 105984 ^dir exists and: [ 105985 self isCaseSensitive 105986 ifTrue:[dir directoryNames includes: fName] 105987 ifFalse:[dir directoryNames anySatisfy: [:name| name sameAs: fName]]]. 105988! ! 105989 105990!FileDirectory methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:31'! 105991exists 105992"Answer whether the directory exists" 105993 105994 | result | 105995 result := self primLookupEntryIn: pathName asVmPathName index: 1. 105996 ^ result ~= #badDirectoryPath 105997! ! 105998 105999!FileDirectory methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:31'! 106000fileExists: filenameOrPath 106001 "Answer true if a file of the given name exists. The given name may be either a full path name or a local file within this directory." 106002 "FileDirectory default fileExists: Smalltalk sourcesName" 106003 106004 | fName dir | 106005 DirectoryClass splitName: filenameOrPath to: 106006 [:filePath :name | 106007 fName := name. 106008 filePath isEmpty 106009 ifTrue: [dir := self] 106010 ifFalse: [dir := FileDirectory on: filePath]]. 106011 self isCaseSensitive 106012 ifTrue:[^dir fileNames includes: fName] 106013 ifFalse:[^dir fileNames anySatisfy: [:name| name sameAs: fName]]. ! ! 106014 106015!FileDirectory methodsFor: 'testing' stamp: 'di 11/21/1999 20:17'! 106016includesKey: localName 106017 "Answer true if this directory includes a file or directory of the given name. Note that the name should be a local file name, in contrast with fileExists:, which takes either local or full-qualified file names." 106018 "(FileDirectory on: Smalltalk vmPath) includesKey: 'SqueakV2.sources'" 106019 self isCaseSensitive 106020 ifTrue:[^ self fileAndDirectoryNames includes: localName] 106021 ifFalse:[^ self fileAndDirectoryNames anySatisfy: [:str| str sameAs: localName]].! ! 106022 106023!FileDirectory methodsFor: 'testing' stamp: 'ar 5/30/2001 21:42'! 106024isAFileNamed: fName 106025 ^FileStream isAFileNamed: (self fullNameFor: fName)! ! 106026 106027!FileDirectory methodsFor: 'testing' stamp: 'ar 5/1/1999 01:51'! 106028isCaseSensitive 106029 "Return true if file names are treated case sensitive" 106030 ^self class isCaseSensitive! ! 106031 106032!FileDirectory methodsFor: 'testing' stamp: 'dgd 12/27/2003 10:46'! 106033isRemoteDirectory 106034 "answer whatever the receiver is a remote directory" 106035 ^ false! ! 106036 106037 106038!FileDirectory methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'! 106039directoryContentsFor: fullPath 106040 "Return a collection of directory entries for the files and directories in the directory with the given path. See primLookupEntryIn:index: for further details." 106041 "FileDirectory default directoryContentsFor: ''" 106042 106043 | entries index done entryArray f | 106044 entries := OrderedCollection new: 200. 106045 index := 1. 106046 done := false. 106047 f := fullPath asVmPathName. 106048 [done] whileFalse: [ 106049 entryArray := self primLookupEntryIn: f index: index. 106050 #badDirectoryPath = entryArray ifTrue: [ 106051 ^(InvalidDirectoryError pathName: pathName asSqueakPathName) signal]. 106052 entryArray == nil 106053 ifTrue: [done := true] 106054 ifFalse: [entries addLast: (DirectoryEntry fromArray: entryArray)]. 106055 index := index + 1]. 106056 106057 ^ entries asArray collect: [:s | s convertFromSystemName]. 106058! ! 106059 106060!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 106061primCreateDirectory: fullPath 106062 "Create a directory named by the given path. Fail if the path is bad or if a file or directory by that name already exists." 106063 106064 <primitive: 'primitiveDirectoryCreate' module: 'FilePlugin'> 106065 self primitiveFailed 106066! ! 106067 106068!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 106069primDeleteDirectory: fullPath 106070 "Delete the directory named by the given path. Fail if the path is bad or if a directory by that name does not exist." 106071 106072 <primitive: 'primitiveDirectoryDelete' module: 'FilePlugin'> 106073 self primitiveFailed 106074! ! 106075 106076!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 106077primDeleteFileNamed: aFileName 106078 "Delete the file of the given name. Return self if the primitive succeeds, nil otherwise." 106079 106080 <primitive: 'primitiveFileDelete' module: 'FilePlugin'> 106081 ^ nil 106082! ! 106083 106084!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 106085primGetMacFileNamed: fileName type: typeString creator: creatorString 106086 "Get the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. This primitive is Mac specific; it is a noop on other platforms." 106087 106088 <primitive: 'primitiveDirectoryGetMacTypeAndCreator' module: 'FilePlugin'> 106089 106090! ! 106091 106092!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 106093primLookupEntryIn: fullPath index: index 106094 "Look up the index-th entry of the directory with the given fully-qualified path (i.e., starting from the root of the file hierarchy) and return an array containing: 106095 106096 <name> <creationTime> <modificationTime> <dirFlag> <fileSize> 106097 106098 The empty string enumerates the top-level files or drives. (For example, on Unix, the empty path enumerates the contents of '/'. On Macs and PCs, it enumerates the mounted volumes/drives.) 106099 106100 The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given path is bad." 106101 106102 <primitive: 'primitiveDirectoryLookup' module: 'FilePlugin'> 106103 ^ #badDirectoryPath 106104 106105! ! 106106 106107!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 106108primRename: oldFileFullName to: newFileFullName 106109 "Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name. 106110 Changed to return nil instead of failing ar 3/21/98 18:04" 106111 106112 <primitive: 'primitiveFileRename' module: 'FilePlugin'> 106113 ^nil! ! 106114 106115!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 106116primSetMacFileNamed: fileName type: typeString creator: creatorString 106117 "Set the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. This primitive is Mac specific; it is a noop on other platforms." 106118 106119 <primitive: 'primitiveDirectorySetMacTypeAndCreator' module: 'FilePlugin'> 106120 self primitiveFailed 106121! ! 106122 106123!FileDirectory methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'! 106124setPathName: pathString 106125 106126 pathName := FilePath pathName: pathString. 106127! ! 106128 106129!FileDirectory methodsFor: 'private' stamp: 'mir 6/25/2001 18:05'! 106130storeServerEntryOn: stream 106131 106132 stream 106133 nextPutAll: 'name:'; tab; nextPutAll: self localName; cr; 106134 nextPutAll: 'directory:'; tab; nextPutAll: self pathName; cr; 106135 nextPutAll: 'type:'; tab; nextPutAll: 'file'; cr! ! 106136 106137"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 106138 106139FileDirectory class 106140 instanceVariableNames: ''! 106141 106142!FileDirectory class methodsFor: '*network-uri' stamp: 'JMM 2/3/2008 14:17'! 106143contentStreamForURI: aURI 106144 | fullPath stream | 106145 106146 fullPath := self fullPathForURI: aURI. 106147 stream := FileStream readOnlyFileFullyNamed: fullPath. 106148 ^stream binary 106149! ! 106150 106151!FileDirectory class methodsFor: '*network-uri' stamp: 'JMM 2/3/2008 14:14'! 106152contentUTF8StreamForURI: aURI 106153 | fullPath | 106154 fullPath := self fullPathForURI: aURI. 106155 ^FileStream readOnlyFileFullyNamed: fullPath 106156! ! 106157 106158!FileDirectory class methodsFor: '*network-uri' stamp: 'JMM 2/3/2008 14:17'! 106159contentUTF8WriteableStreamForURI: aURI 106160 | fullPath | 106161 fullPath := self fullPathForURI: aURI. 106162 ^FileStream oldFileFullyNamed: fullPath! ! 106163 106164!FileDirectory class methodsFor: '*network-uri' stamp: 'JMM 2/3/2008 14:17'! 106165contentWriteableStreamForURI: aURI 106166 | fullPath stream | 106167 fullPath := self fullPathForURI: aURI. 106168 stream := FileStream oldFileFullyNamed: fullPath. 106169 ^stream binary! ! 106170 106171!FileDirectory class methodsFor: '*network-uri' stamp: 'mir 6/20/2005 18:53'! 106172fullPathForURI: aURI 106173 ^self activeDirectoryClass privateFullPathForURI: (FileDirectory default uri resolveRelativeURI: aURI)! ! 106174 106175!FileDirectory class methodsFor: '*network-uri' stamp: 'mir 6/20/2005 18:53'! 106176privateFullPathForURI: aURI 106177 ^(aURI path copyReplaceAll: '/' with: self slash) unescapePercents! ! 106178 106179!FileDirectory class methodsFor: '*network-uri' stamp: 'JMM 12/1/2007 15:31'! 106180retrieveMIMEDocument: uri 106181 | file | 106182 file := [self contentStreamForURI: uri] 106183 on: FileDoesNotExistException do:[:ex| ex return: nil]. 106184 file ifNotNil: [^MIMEDocument contentStream: file 106185 mimeType: (MIMEType forURIReturnSingleMimeTypeOrDefault: uri)]. 106186 ^nil! ! 106187 106188!FileDirectory class methodsFor: '*network-uri' stamp: 'mir 6/20/2005 18:34'! 106189uri: aURI 106190 ^self on: (FileDirectory fullPathForURI: aURI)! ! 106191 106192 106193!FileDirectory class methodsFor: 'create/delete file' stamp: 'stephaneducasse 2/4/2006 20:32'! 106194deleteFilePath: fullPathToAFile 106195 "Delete the file after finding its directory" 106196 106197 | dir | 106198 dir := self on: (self dirPathFor: fullPathToAFile). 106199 dir deleteFileNamed: (self localNameFor: fullPathToAFile). 106200! ! 106201 106202!FileDirectory class methodsFor: 'create/delete file' stamp: 'stephaneducasse 2/4/2006 20:32'! 106203lookInUsualPlaces: fileName 106204 "Check the default directory, the imagePath, and the vmPath (and the vmPath's owner) for this file." 106205 106206 | vmp | 106207 (FileDirectory default fileExists: fileName) 106208 ifTrue: [^ FileDirectory default fileNamed: fileName]. 106209 106210 ((vmp := FileDirectory on: SmalltalkImage current imagePath) fileExists: fileName) 106211 ifTrue: [^ vmp fileNamed: fileName]. 106212 106213 ((vmp := FileDirectory on: SmalltalkImage current vmPath) fileExists: fileName) 106214 ifTrue: [^ vmp fileNamed: fileName]. 106215 106216 ((vmp := vmp containingDirectory) fileExists: fileName) 106217 ifTrue: [^ vmp fileNamed: fileName]. 106218 106219 ^ nil! ! 106220 106221 106222!FileDirectory class methodsFor: 'instance creation' stamp: 'jm 12/4/97 19:24'! 106223default 106224 "Answer the default directory." 106225 106226 ^ DefaultDirectory 106227! ! 106228 106229!FileDirectory class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:32'! 106230forFileName: aString 106231 106232 | path | 106233 path := self dirPathFor: aString. 106234 path isEmpty ifTrue: [^ self default]. 106235 ^ self on: path 106236! ! 106237 106238!FileDirectory class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:32'! 106239on: pathString 106240 "Return a new file directory for the given path, of the appropriate FileDirectory subclass for the current OS platform." 106241 106242 | pathName | 106243 DirectoryClass ifNil: [self setDefaultDirectoryClass]. 106244 "If path ends with a delimiter (: or /) then remove it" 106245 ((pathName := pathString) endsWith: self pathNameDelimiter asString) ifTrue: [ 106246 pathName := pathName copyFrom: 1 to: pathName size - 1]. 106247 ^ DirectoryClass new setPathName: pathName 106248! ! 106249 106250!FileDirectory class methodsFor: 'instance creation' stamp: 'jm 12/4/97 23:29'! 106251root 106252 "Answer the root directory." 106253 106254 ^ self on: '' 106255! ! 106256 106257 106258!FileDirectory class methodsFor: 'name utilities' stamp: 'stephane.ducasse 4/13/2009 20:30'! 106259baseNameFor: fileName 106260 "Return the given file name without its extension, if any. We have to remember that many (most?) OSs allow extension separators within directory names and so the leaf filename needs to be extracted, trimmed and rejoined. Yuck" 106261 "The test is 106262 FileDirectory baseNameFor: ((FileDirectory default directoryNamed: 'foo.bar') fullNameFor:'blim.blam') 106263 should end 'foo.bar/blim' (or as appropriate for your platform AND 106264 FileDirectory baseNameFor: ((FileDirectory default directoryNamed: 'foo.bar') fullNameFor:'blim') 106265 should be the same and NOT 'foo' 106266 Oh, and FileDirectory baseNameFor: 'foo.bar' should be 'foo' not '/foo' " 106267 106268 | delim i leaf | 106269 self splitName: fileName to: [:path :fn| 106270 106271 delim := DirectoryClass extensionDelimiter. 106272 i := fn findLast: [:c | c = delim]. 106273 leaf := i = 0 106274 ifTrue: [fn] 106275 ifFalse: [fn copyFrom: 1 to: i - 1]. 106276 path isEmpty ifTrue:[^leaf]. 106277 ^path, self slash, leaf] 106278! ! 106279 106280!FileDirectory class methodsFor: 'name utilities' stamp: 'TPR 5/10/1998 21:32'! 106281changeSuffix 106282"if 'changes' is not suitable, override this message to return something that is ok" 106283 ^'changes'! ! 106284 106285!FileDirectory class methodsFor: 'name utilities' stamp: 'jf 2/7/2004 17:22'! 106286checkName: fileName fixErrors: flag 106287 "Check a string fileName for validity as a file name on the current default file system. Answer the original file name if it is valid. If the name is not valid (e.g., it is too long or contains illegal characters) and fixing is false, raise an error. If fixing is true, fix the name (usually by truncating and/or tranforming characters), and answer the corrected name. The default behavior is to truncate the name to 31 chars. Subclasses can do any kind of checking and correction appropriate to the underlying platform." 106288 106289 ^ DefaultDirectory 106290 checkName: fileName 106291 fixErrors: flag 106292! ! 106293 106294!FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 10/13/2003 10:59'! 106295dirPathFor: fullName 106296 "Return the directory part the given name." 106297 DirectoryClass 106298 splitName: fullName 106299 to: [:dirPath :localName | ^ dirPath]! ! 106300 106301!FileDirectory class methodsFor: 'name utilities' stamp: 'ar 4/7/2002 15:47'! 106302directoryEntryFor: filenameOrPath 106303 ^self default directoryEntryFor: filenameOrPath! ! 106304 106305!FileDirectory class methodsFor: 'name utilities' stamp: 'stephaneducasse 2/4/2006 20:32'! 106306extensionFor: fileName 106307 "Return the extension of given file name, if any." 106308 106309 | delim i | 106310 delim := DirectoryClass extensionDelimiter. 106311 i := fileName findLast: [:c | c = delim]. 106312 i = 0 106313 ifTrue: [^ ''] 106314 ifFalse: [^ fileName copyFrom: i + 1 to: fileName size]. 106315! ! 106316 106317!FileDirectory class methodsFor: 'name utilities' stamp: 'stephaneducasse 2/4/2006 20:32'! 106318fileName: fileName extension: fileExtension 106319 | extension | 106320 extension := FileDirectory dot , fileExtension. 106321 ^(fileName endsWith: extension) 106322 ifTrue: [fileName] 106323 ifFalse: [fileName , extension].! ! 106324 106325!FileDirectory class methodsFor: 'name utilities' stamp: 'TPR 5/10/1998 21:31'! 106326imageSuffix 106327"if 'image' is not suitable, override this message to return something that is ok" 106328 ^'image'! ! 106329 106330!FileDirectory class methodsFor: 'name utilities' stamp: 'jm 12/4/97 23:40'! 106331isLegalFileName: fullName 106332 "Return true if the given string is a legal file name." 106333 106334 ^ DefaultDirectory isLegalFileName: (self localNameFor: fullName) 106335! ! 106336 106337!FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 10/13/2003 10:59'! 106338localNameFor: fullName 106339 "Return the local part the given name." 106340 DirectoryClass 106341 splitName: fullName 106342 to: [:dirPath :localName | ^ localName]! ! 106343 106344!FileDirectory class methodsFor: 'name utilities' stamp: 'stephaneducasse 2/4/2006 20:32'! 106345splitName: fullName to: pathAndNameBlock 106346 "Take the file name and convert it to the path name of a directory and a local file name within that directory. FileName must be of the form: <dirPath><delimiter><localName>, where <dirPath><delimiter> is optional. The <dirPath> part may contain delimiters." 106347 106348 | delimiter i dirName localName | 106349 delimiter := self pathNameDelimiter. 106350 (i := fullName findLast: [:c | c = delimiter]) = 0 106351 ifTrue: 106352 [dirName := String new. 106353 localName := fullName] 106354 ifFalse: 106355 [dirName := fullName copyFrom: 1 to: (i - 1 max: 1). 106356 localName := fullName copyFrom: i + 1 to: fullName size]. 106357 106358 ^ pathAndNameBlock value: dirName value: localName! ! 106359 106360!FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 12/15/2003 12:03'! 106361startUp 106362 "Establish the platform-specific FileDirectory subclass. Do any platform-specific startup." 106363 self setDefaultDirectoryClass. 106364 106365 self setDefaultDirectory: (self dirPathFor: SmalltalkImage current imageName). 106366 106367 Preferences startInUntrustedDirectory 106368 ifTrue:[ "The SecurityManager may override the default directory to prevent unwanted write access etc." 106369 self setDefaultDirectory: SecurityManager default untrustedUserDirectory. 106370 "Make sure we have a place to go to" 106371 DefaultDirectory assureExistence]. 106372 SmalltalkImage current openSourceFiles. 106373! ! 106374 106375!FileDirectory class methodsFor: 'name utilities' stamp: 'stephaneducasse 2/4/2006 20:32'! 106376urlForFileNamed: aFilename 106377 "Create a URL for the given fully qualified file name" 106378 "FileDirectory urlForFileNamed: 106379 'C:\Home\andreasr\Squeak\DSqueak3\DSqueak3:=1.1\DSqueak3.1.image' " 106380 | path localName | 106381 DirectoryClass 106382 splitName: aFilename 106383 to: [:p :n | 106384 path := p. 106385 localName := n]. 106386 ^ localName asUrlRelativeTo: (self on: path) url asUrl! ! 106387 106388 106389!FileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 08:17'! 106390dot 106391 "Return a one-character string containing the filename extension delimiter for this platform (i.e., the local equivalent of 'dot')" 106392 106393 ^ self extensionDelimiter asString 106394! ! 106395 106396!FileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 06:57'! 106397extensionDelimiter 106398 "Return the character used to delimit filename extensions on this platform. Most platforms use the period (.) character." 106399 106400 ^ $. 106401! ! 106402 106403!FileDirectory class methodsFor: 'platform specific' stamp: 'ar 5/1/1999 01:48'! 106404isCaseSensitive 106405 "Return true if file names are treated case sensitive" 106406 ^true! ! 106407 106408!FileDirectory class methodsFor: 'platform specific' stamp: 'nk 3/13/2003 10:58'! 106409makeAbsolute: path 106410 "Ensure that path looks like an absolute path" 106411 ^path first = self pathNameDelimiter 106412 ifTrue: [ path ] 106413 ifFalse: [ self slash, path ]! ! 106414 106415!FileDirectory class methodsFor: 'platform specific' stamp: 'nk 3/13/2003 10:59'! 106416makeRelative: path 106417 "Ensure that path looks like an relative path" 106418 ^path first = self pathNameDelimiter 106419 ifTrue: [ path copyWithoutFirst ] 106420 ifFalse: [ path ]! ! 106421 106422!FileDirectory class methodsFor: 'platform specific' stamp: 'jm 5/8/1998 20:45'! 106423maxFileNameLength 106424 106425 ^ 31 106426! ! 106427 106428!FileDirectory class methodsFor: 'platform specific' stamp: 'TPR 5/12/1998 22:49'! 106429pathNameDelimiter 106430"return the active directory class's directory seperator character" 106431 ^ DirectoryClass pathNameDelimiter! ! 106432 106433!FileDirectory class methodsFor: 'platform specific' stamp: 'ar 4/18/1999 18:18'! 106434slash 106435 ^ self pathNameDelimiter asString! ! 106436 106437 106438!FileDirectory class methodsFor: 'system start up' stamp: 'stephaneducasse 2/4/2006 20:32'! 106439openChanges: changesName forImage: imageName 106440"find the changes file by looking in 106441a) the directory derived from the image name 106442b) the DefaultDirectory (which will normally be the directory derived from the image name or the SecurityManager's choice) 106443If an old file is not found in either place, check for a read-only file in the same places. If that fails, return nil" 106444 | changes fd | 106445 "look for the changes file or an alias to it in the image directory" 106446 fd := FileDirectory on: (FileDirectory dirPathFor: imageName). 106447 (fd fileExists: changesName) 106448 ifTrue: [changes := fd oldFileNamed: changesName]. 106449 changes ifNotNil:[^changes]. 106450 106451 "look for the changes in the default directory" 106452 fd := DefaultDirectory. 106453 (fd fileExists: changesName) 106454 ifTrue: [changes := fd oldFileNamed: changesName]. 106455 changes ifNotNil:[^changes]. 106456 106457 "look for read-only changes in the image directory" 106458 fd := FileDirectory on: (FileDirectory dirPathFor: imageName). 106459 (fd fileExists: changesName) 106460 ifTrue: [changes := fd readOnlyFileNamed: changesName]. 106461 changes ifNotNil:[^changes]. 106462 106463 "look for read-only changes in the default directory" 106464 fd := DefaultDirectory. 106465 (fd fileExists: changesName) 106466 ifTrue: [changes := fd readOnlyFileNamed: changesName]. 106467 "this may be nil if the last try above failed to open a file" 106468 ^changes 106469! ! 106470 106471!FileDirectory class methodsFor: 'system start up' stamp: 'adrian_lienhard 7/18/2009 15:55'! 106472openSources: sourcesName andChanges: changesName forImage: imageName 106473 "Open the changes and sources files and install them in SourceFiles. Inform the user of problems regarding write permissions or CR/CRLF mixups." 106474 "Note: SourcesName and imageName are full paths; changesName is a 106475 local name." 106476 | sources changes msg wmsg | 106477 msg := 'Pharo cannot locate &fileRef. 106478 106479Please check that the file is named properly and is in the 106480same directory as this image.'. 106481 wmsg := 'Pharo cannot write to &fileRef. 106482 106483Please check that you have write permission for this file. 106484 106485You won''t be able to save this image correctly until you fix this.'. 106486 106487 sources := self openSources: sourcesName forImage: imageName. 106488 changes := self openChanges: changesName forImage: imageName. 106489 106490 ((sources == nil or: [sources atEnd]) 106491 and: [Preferences valueOfFlag: #warnIfNoSourcesFile]) 106492 ifTrue: [SmalltalkImage current platformName = 'Mac OS' 106493 ifTrue: [msg := msg , ' 106494Make sure the sources file is not an Alias.']. 106495self inform: (msg copyReplaceAll: '&fileRef' with: 'the sources file named ' , sourcesName)]. 106496 106497 (changes == nil 106498 and: [Preferences valueOfFlag: #warnIfNoChangesFile]) 106499 ifTrue: [self inform: (msg copyReplaceAll: '&fileRef' with: 'the changes file named ' , changesName)]. 106500 106501 ((Preferences valueOfFlag: #warnIfNoChangesFile) and: [changes notNil]) 106502 ifTrue: [changes isReadOnly 106503 ifTrue: [self inform: (wmsg copyReplaceAll: '&fileRef' with: 'the changes file named ' , changesName)]. 106504 106505 ((changes next: 200) 106506 includesSubString: String crlf) 106507 ifTrue: [self inform: 'The changes file named ' , changesName , ' 106508has been injured by an unpacking utility. Crs were changed to CrLfs. 106509Please set the preferences in your decompressing program to 106510"do not convert text files" and unpack the system again.']]. 106511 106512 SourceFiles := Array with: sources with: changes! ! 106513 106514!FileDirectory class methodsFor: 'system start up' stamp: 'stephaneducasse 2/4/2006 20:32'! 106515openSources: fullSourcesName forImage: imageName 106516"We first do a check to see if a compressed version ofthe sources file is present. 106517Open the .sources file read-only after searching in: 106518a) the directory where the VM lives 106519b) the directory where the image came from 106520c) the DefaultDirectory (which is likely the same as b unless the SecurityManager has changed it). 106521" 106522 106523 | sources fd sourcesName | 106524 (fullSourcesName endsWith: 'sources') ifTrue: 106525 ["Look first for a sources file in compressed format." 106526 sources := self openSources: (fullSourcesName allButLast: 7) , 'stc' 106527 forImage: imageName. 106528 sources ifNotNil: [^ CompressedSourceStream on: sources]]. 106529 106530 sourcesName := FileDirectory localNameFor: fullSourcesName. 106531 "look for the sources file or an alias to it in the VM's directory" 106532 fd := FileDirectory on: SmalltalkImage current vmPath. 106533 (fd fileExists: sourcesName) 106534 ifTrue: [sources := fd readOnlyFileNamed: sourcesName]. 106535 sources ifNotNil: [^ sources]. 106536 "look for the sources file or an alias to it in the image directory" 106537 fd := FileDirectory on: (FileDirectory dirPathFor: imageName). 106538 (fd fileExists: sourcesName) 106539 ifTrue: [sources := fd readOnlyFileNamed: sourcesName]. 106540 sources ifNotNil: [^ sources]. 106541 "look for the sources in the current directory" 106542 fd := DefaultDirectory. 106543 (fd fileExists: sourcesName) 106544 ifTrue: [sources := fd readOnlyFileNamed: sourcesName]. 106545 "sources may still be nil here" 106546 ^sources 106547! ! 106548 106549!FileDirectory class methodsFor: 'system start up' stamp: 'stephaneducasse 2/4/2006 20:32'! 106550setDefaultDirectory: directoryName 106551 "Initialize the default directory to the directory supplied. This method is called when the image starts up." 106552 | dirName | 106553 DirectoryClass := self activeDirectoryClass. 106554 dirName := (FilePath pathName: directoryName) asSqueakPathName. 106555 [dirName endsWith: self slash] whileTrue:[ 106556 dirName := dirName copyFrom: 1 to: dirName size - self slash size. 106557 ]. 106558 DefaultDirectory := self on: dirName.! ! 106559 106560!FileDirectory class methodsFor: 'system start up' stamp: 'stephaneducasse 2/4/2006 20:32'! 106561setDefaultDirectoryClass 106562 "Initialize the default directory class to suit this platform. This method is called when the image starts up - it needs to be right at the front of the list of the startup sequence" 106563 106564 DirectoryClass := self activeDirectoryClass 106565! ! 106566 106567!FileDirectory class methodsFor: 'system start up' stamp: 'stephaneducasse 2/4/2006 20:32'! 106568setDefaultDirectoryFrom: imageName 106569 "Initialize the default directory to the directory containing the Squeak image file. This method is called when the image starts up." 106570 106571 DirectoryClass := self activeDirectoryClass. 106572 DefaultDirectory := self on: (FilePath pathName: (self dirPathFor: imageName) isEncoded: true) asSqueakPathName. 106573! ! 106574 106575!FileDirectory class methodsFor: 'system start up' stamp: 'sd 11/16/2003 13:13'! 106576shutDown 106577 106578 SmalltalkImage current closeSourceFiles. 106579! ! 106580 106581 106582!FileDirectory class methodsFor: 'private' stamp: 'TPR 5/10/1998 21:47'! 106583activeDirectoryClass 106584 "Return the concrete FileDirectory subclass for the platform on which we are currently running." 106585 106586 FileDirectory allSubclasses do: [:class | 106587 class isActiveDirectoryClass ifTrue: [^ class]]. 106588 106589 "no responding subclass; use FileDirectory" 106590 ^ FileDirectory 106591! ! 106592 106593!FileDirectory class methodsFor: 'private' stamp: 'TPR 5/10/1998 21:40'! 106594isActiveDirectoryClass 106595 "Does this class claim to be that properly active subclass of FileDirectory for this platform? 106596 Default test is whether the primPathNameDelimiter matches the one for this class. Other tests are possible" 106597 106598 ^self pathNameDelimiter = self primPathNameDelimiter 106599! ! 106600 106601!FileDirectory class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 106602primPathNameDelimiter 106603 "Return the path delimiter for the underlying platform's file system." 106604 106605 <primitive: 'primitiveDirectoryDelimitor' module: 'FilePlugin'> 106606 self primitiveFailed 106607! ! 106608ClassTestCase subclass: #FileDirectoryTest 106609 instanceVariableNames: '' 106610 classVariableNames: '' 106611 poolDictionaries: '' 106612 category: 'Tests-Files'! 106613 106614!FileDirectoryTest methodsFor: 'create/delete tests' stamp: 'adrian-lienhard 6/5/2009 23:01'! 106615deleteDirectory 106616 106617 (self directory exists) ifTrue: 106618 [self directory containingDirectory deleteDirectory: self directoryName]! ! 106619 106620!FileDirectoryTest methodsFor: 'create/delete tests' stamp: 'adrian-lienhard 6/5/2009 23:02'! 106621testDeleteDirectory 106622 "Test deletion of a directory" 106623 106624 | aContainingDirectory preTestItems | 106625 aContainingDirectory := self directory containingDirectory. 106626 preTestItems := aContainingDirectory fileAndDirectoryNames. 106627 106628 self assert: self assuredDirectory exists. 106629 aContainingDirectory deleteDirectory: self directoryName. 106630 106631 self shouldnt: 106632 [aContainingDirectory directoryNames 106633 includes: self directoryName ] 106634 description: 'Should successfully delete directory.'. 106635 self should: 106636 [preTestItems = aContainingDirectory fileAndDirectoryNames] 106637 description: 'Should only delete the indicated directory.'. 106638 106639 106640 ! ! 106641 106642 106643!FileDirectoryTest methodsFor: 'existence tests' stamp: 'on 6/11/2008 16:29'! 106644testAttemptExistenceCheckWhenFile 106645 "How should a FileDirectory instance respond with an existent file name?" 106646 | directory testFile | 106647 testFile := 'aTestFile'. 106648 FileDirectory default 106649 forceNewFileNamed: testFile. 106650 directory := FileDirectory default 106651 directoryNamed: testFile. 106652 self shouldnt: [directory exists] 106653 description: 'Files are not directories.'. 106654 FileDirectory default deleteFileNamed: testFile! ! 106655 106656!FileDirectoryTest methodsFor: 'existence tests' stamp: 'adrian-lienhard 6/5/2009 23:02'! 106657testDirectoryExists 106658 106659 self assert: self assuredDirectory exists. 106660 self should: [self directory containingDirectory 106661 directoryExists: self directoryName]. 106662 106663 self directory containingDirectory deleteDirectory: self directoryName. 106664 self shouldnt: [self directory containingDirectory 106665 directoryExists: self directoryName]! ! 106666 106667!FileDirectoryTest methodsFor: 'existence tests' stamp: 'adrian-lienhard 6/5/2009 23:02'! 106668testDirectoryExistsWhenLikeNamedFileExists 106669 | testFileName | 106670 [testFileName := self assuredDirectory fullNameFor: 'zDirExistsTest.testing'. 106671 (FileStream newFileNamed: testFileName) close. 106672 106673 self should: [FileStream isAFileNamed: testFileName]. 106674 self shouldnt: [(FileDirectory on: testFileName) exists]] 106675 ensure: [self assuredDirectory deleteFileNamed: 'zDirExistsTest.testing'] 106676 106677! ! 106678 106679!FileDirectoryTest methodsFor: 'existence tests' stamp: 'adrian-lienhard 6/5/2009 23:01'! 106680testDirectoryNamed 106681 106682 self should: [(self directory containingDirectory 106683 directoryNamed: self directoryName) pathName 106684 = self directory pathName]! ! 106685 106686!FileDirectoryTest methodsFor: 'existence tests' stamp: 'adrian-lienhard 6/5/2009 23:02'! 106687testExists 106688 106689 self should: [FileDirectory default exists] 106690 description: 'Should know default directory exists.'. 106691 self should: [self assuredDirectory exists] 106692 description: 'Should know created directory exists.'. 106693 106694 self directory containingDirectory deleteDirectory: self directoryName. 106695 self shouldnt: [(self directory containingDirectory directoryNamed: self directoryName) exists] 106696 description: 'Should know that recently deleted directory no longer exists.'.! ! 106697 106698!FileDirectoryTest methodsFor: 'existence tests' stamp: 'stephaneducasse 2/4/2006 20:31'! 106699testNonExistentDirectory 106700 106701 | directory parentDirectory | 106702 directory :=FileDirectory default 106703 directoryNamed: 'nonExistentFolder'. 106704 self shouldnt: [directory exists] 106705 description: 'A FileDirectory instance should know if it points to a non-existent directory.'. 106706 106707 parentDirectory :=FileDirectory default. 106708 self shouldnt: [parentDirectory directoryExists: 'nonExistentFolder'] 106709 description: 'A FileDirectory instance should know when a directory of the given name doesn''t exist'. 106710! ! 106711 106712!FileDirectoryTest methodsFor: 'existence tests' stamp: 'adrian-lienhard 6/5/2009 23:02'! 106713testOldFileOrNoneNamed 106714 106715 | file | 106716 file := self assuredDirectory oldFileOrNoneNamed: 'test.txt'. 106717 [self assert: file isNil. 106718 106719 "Reproduction of Mantis #1049" 106720 (self assuredDirectory fileNamed: 'test.txt') 106721 nextPutAll: 'foo'; 106722 close. 106723 106724 file := self assuredDirectory oldFileOrNoneNamed: 'test.txt'. 106725 self assert: file notNil] 106726 ensure: [ 106727 file ifNotNil: [file close]. 106728 self assuredDirectory deleteFileNamed: 'test.txt' ifAbsent: nil] 106729 106730! ! 106731 106732 106733!FileDirectoryTest methodsFor: 'resources' stamp: 'adrian-lienhard 6/5/2009 23:02'! 106734assuredDirectory 106735 ^self directory assureExistence! ! 106736 106737!FileDirectoryTest methodsFor: 'resources' stamp: 'adrian-lienhard 6/5/2009 22:59'! 106738directory 106739 ^FileDirectory default directoryNamed: self directoryName! ! 106740 106741!FileDirectoryTest methodsFor: 'resources' stamp: 'adrian-lienhard 6/5/2009 22:59'! 106742directoryName 106743 ^ self class name! ! 106744 106745!FileDirectoryTest methodsFor: 'resources' stamp: 'adrian-lienhard 6/5/2009 23:03'! 106746tearDown 106747 [ self deleteDirectory ] on: Error do: [ :ex | ]! ! 106748ListItemWrapper subclass: #FileDirectoryWrapper 106749 instanceVariableNames: 'itemName balloonText hasContents' 106750 classVariableNames: '' 106751 poolDictionaries: '' 106752 category: 'Morphic-Explorer'! 106753 106754!FileDirectoryWrapper methodsFor: 'accessing' stamp: 'RAA 7/21/2000 11:00'! 106755balloonText 106756 106757 ^balloonText! ! 106758 106759!FileDirectoryWrapper methodsFor: 'accessing' stamp: 'ar 2/12/2001 16:20'! 106760contents 106761 106762 ^((model directoryNamesFor: item) sortBy: [ :a :b | a caseInsensitiveLessOrEqual: b]) collect: [ :n | 106763 FileDirectoryWrapper with: (item directoryNamed: n) name: n model: self 106764 ] 106765! ! 106766 106767!FileDirectoryWrapper methodsFor: 'accessing' stamp: 'tpr 11/28/2003 14:02'! 106768hasContents 106769 "Return whether this directory has subfolders. The value is cached to 106770 avoid a performance penalty. Also for performance reasons, the code 106771 below will just assume that the directory does indeed have contents in a 106772 few of cases: 106773 1. If the item is not a FileDirectory (thus avoiding the cost 106774 of refreshing directories that are not local) 106775 2. If it's the root directory of a given volume 106776 3. If there is an error computing the FileDirectory's contents 106777 " 106778 hasContents 106779 ifNil: [hasContents := true. "default" 106780 ["Best test I could think of for determining if this is a local directory " 106781 ((item isKindOf: FileDirectory) 106782 and: ["test to see that it's not the root directory" 106783 "there has to be a better way of doing this test -tpr" 106784 item pathParts size > 1]) 106785 ifTrue: [hasContents := self contents notEmpty]] 106786 on: Error 106787 do: [hasContents := true]]. 106788 ^ hasContents! ! 106789 106790!FileDirectoryWrapper methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:22'! 106791icon 106792 "Answer a form to be used as icon" 106793 ^ item isRemoteDirectory 106794 ifTrue: [MenuIcons smallRemoteOpenIcon] 106795 ifFalse: [MenuIcons smallOpenIcon]! ! 106796 106797 106798!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/21/2000 11:01'! 106799balloonText: aStringOrNil 106800 106801 balloonText := aStringOrNil! ! 106802 106803!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/12/2001 16:22'! 106804directoryNamesFor: anItem 106805 ^model directoryNamesFor: anItem! ! 106806 106807!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'sps 12/5/2002 16:59'! 106808setItem: anObject name: aString model: aModel 106809 106810 item := anObject. 106811 model := aModel. 106812 itemName := aString. 106813 hasContents := nil. 106814! ! 106815 106816!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 18:30'! 106817settingSelector 106818 106819 ^#setSelectedDirectoryTo:! ! 106820 106821 106822!FileDirectoryWrapper methodsFor: 'converting' stamp: 'dgd 8/27/2004 18:45'! 106823asString 106824 ^itemName translatedIfCorresponds! ! 106825 106826"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 106827 106828FileDirectoryWrapper class 106829 instanceVariableNames: ''! 106830 106831!FileDirectoryWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 6/15/2000 18:01'! 106832with: anObject name: aString model: aModel 106833 106834 ^self new 106835 setItem: anObject name: aString model: aModel! ! 106836FileStreamException subclass: #FileDoesNotExistException 106837 instanceVariableNames: 'readOnly' 106838 classVariableNames: '' 106839 poolDictionaries: '' 106840 category: 'Exceptions-Kernel'! 106841 106842!FileDoesNotExistException methodsFor: 'accessing' stamp: 'mir 7/25/2000 16:41'! 106843readOnly 106844 ^readOnly == true! ! 106845 106846!FileDoesNotExistException methodsFor: 'accessing' stamp: 'mir 7/25/2000 16:40'! 106847readOnly: aBoolean 106848 readOnly := aBoolean! ! 106849 106850 106851!FileDoesNotExistException methodsFor: 'exceptiondescription' stamp: 'mir 7/25/2000 18:22'! 106852defaultAction 106853 "The default action taken if the exception is signaled." 106854 106855 106856 ^self readOnly 106857 ifTrue: [StandardFileStream readOnlyFileDoesNotExistUserHandling: self fileName] 106858 ifFalse: [StandardFileStream fileDoesNotExistUserHandling: self fileName] 106859! ! 106860 106861"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 106862 106863FileDoesNotExistException class 106864 instanceVariableNames: ''! 106865 106866!FileDoesNotExistException class methodsFor: 'examples' stamp: 'mir 2/29/2000 11:44'! 106867example 106868 "FileDoesNotExistException example" 106869 106870 | result | 106871 result := [(StandardFileStream readOnlyFileNamed: 'error42.log') contentsOfEntireFile] 106872 on: FileDoesNotExistException 106873 do: [:ex | 'No error log']. 106874 Transcript show: result; cr! ! 106875FileStreamException subclass: #FileExistsException 106876 instanceVariableNames: 'fileClass' 106877 classVariableNames: '' 106878 poolDictionaries: '' 106879 category: 'Exceptions-Kernel'! 106880 106881!FileExistsException methodsFor: 'accessing' stamp: 'LC 10/24/2001 21:49'! 106882fileClass 106883 ^ fileClass ifNil: [StandardFileStream]! ! 106884 106885!FileExistsException methodsFor: 'accessing' stamp: 'LC 10/24/2001 21:42'! 106886fileClass: aClass 106887 fileClass := aClass! ! 106888 106889 106890!FileExistsException methodsFor: 'exceptiondescription' stamp: 'LC 10/24/2001 21:50'! 106891defaultAction 106892 "The default action taken if the exception is signaled." 106893 106894 ^ self fileClass fileExistsUserHandling: self fileName 106895! ! 106896 106897"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 106898 106899FileExistsException class 106900 instanceVariableNames: ''! 106901 106902!FileExistsException class methodsFor: 'exceptioninstantiator' stamp: 'LC 10/24/2001 21:50'! 106903fileName: aFileName fileClass: aClass 106904 ^ self new 106905 fileName: aFileName; 106906 fileClass: aClass! ! 106907StringHolder subclass: #FileList 106908 instanceVariableNames: 'fileName directory volList volListIndex list listIndex pattern sortMode brevityState currentDirectorySelected fileSelectionBlock dirSelectionBlock optionalButtonSpecs modalView directoryChangeBlock ok' 106909 classVariableNames: 'FileReaderRegistry RecentDirs' 106910 poolDictionaries: '' 106911 category: 'Morphic-FileList'! 106912!FileList commentStamp: 'BJP 11/19/2003 21:13' prior: 0! 106913Some variations on FileList that 106914- use a hierarchical pane to show folder structure 106915- use different pane combinations, button layouts and prefiltering for specific uses 106916 106917FileList2 morphicView openInWorld "an alternative to the standard FileList" 106918FileList2 morphicViewNoFile openInWorld "useful for selecting, but not viewing" 106919FileList2 morphicViewProjectLoader openInWorld "useful for finding and loading projects" 106920FileList2 modalFolderSelector "allows the user to select a folder" 106921 106922 106923 106924! 106925 106926 106927!FileList methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/6/2009 12:34'! 106928morphicPatternPane 106929 "Remove the vertical scrollbar since the minHeight would otherwise 106930 be too large to fit the layout frame. Added here for Pharo since 106931 FileList2 has been merged into FileList." 106932 106933 |pane| 106934 pane := PluggableTextMorph 106935 on: self 106936 text: #pattern 106937 accept: #pattern:. 106938 pane 106939 acceptOnCR: true; 106940 hideVScrollBarIndefinitely: true. 106941 ^pane! ! 106942 106943 106944!FileList methodsFor: 'accessing' stamp: 'hfm 11/29/2008 18:47'! 106945directory 106946 106947 ^ directory! ! 106948 106949!FileList methodsFor: 'accessing' stamp: 'stephane.ducasse 5/21/2009 14:33'! 106950directory: dir 106951 "Set the path of the volume to be displayed." 106952 106953 self okToChange ifFalse: [^ self]. 106954 self modelSleep. 106955 directory := dir ifNil: [FileDirectory on: '']. 106956 self modelWakeUp. 106957 sortMode == nil ifTrue: [sortMode := #date]. 106958 volList := ((Array with: '[]'), directory pathParts) 106959 withIndexCollect: [:each :i | ( String new: i-1 withAll: $ ), each]. 106960 volListIndex := volList size. 106961 self changed: #relabel. 106962 self changed: #volumeList. 106963 self pattern: pattern! ! 106964 106965!FileList methodsFor: 'accessing' stamp: 'hfm 11/29/2008 18:30'! 106966fileList 106967 "Answer the list of files in the current volume." 106968 106969 ^ list! ! 106970 106971!FileList methodsFor: 'accessing' stamp: 'hfm 11/29/2008 18:31'! 106972fileListIndex 106973 "Answer the index of the currently selected file." 106974 106975 ^ listIndex! ! 106976 106977!FileList methodsFor: 'accessing' stamp: 'hfm 11/29/2008 18:32'! 106978fileListIndex: anInteger 106979 "Select the file name having the given index, and display its contents." 106980 106981 | item name | 106982 self okToChange ifFalse: [^ self]. 106983 listIndex := anInteger. 106984 listIndex = 0 106985 ifTrue: [fileName := nil] 106986 ifFalse: 106987 [item := self fileNameFromFormattedItem: (list at: anInteger). 106988 (item endsWith: self folderString) 106989 ifTrue: 106990 ["remove [...] folder string and open the folder" 106991 name := item copyFrom: 1 to: item size - self folderString size. 106992 listIndex := 0. 106993 brevityState := #FileList. 106994 self addPath: name. 106995 name first = $^ 106996 ifTrue: [self directory: (ServerDirectory serverNamed: name allButFirst)] 106997 ifFalse: [volListIndex = 1 ifTrue: [name := name, directory slash]. 106998 self directory: (directory directoryNamed: name)]] 106999 ifFalse: [fileName := item]]. "open the file selected" 107000 107001 brevityState := #needToGetBrief. 107002 self changed: #fileListIndex. 107003 self changed: #contents. 107004 self updateButtonRow! ! 107005 107006!FileList methodsFor: 'accessing' stamp: 'hfm 11/29/2008 18:48'! 107007fileName 107008 107009 ^ fileName! ! 107010 107011!FileList methodsFor: 'accessing' stamp: 'hfm 11/29/2008 18:22'! 107012pattern 107013 107014 ^ pattern ifNil: ['*'] 107015! ! 107016 107017!FileList methodsFor: 'accessing' stamp: 'hfm 11/29/2008 18:22'! 107018pattern: textOrStringOrNil 107019 107020 textOrStringOrNil 107021 ifNil: [pattern := '*'] 107022 ifNotNil: [pattern := textOrStringOrNil asString]. 107023 self updateFileList. 107024 ^ true 107025! ! 107026 107027 107028!FileList methodsFor: 'as yet unclassified' stamp: 'BG 2/29/2004 23:40'! 107029specsForImageViewer 107030 107031 ^{self serviceSortByName. self serviceSortByDate. self serviceSortBySize }! ! 107032 107033 107034!FileList methodsFor: 'drag''n''drop' stamp: 'hfm 11/29/2008 19:22'! 107035acceptDroppingMorph: aTransferMorph event: evt inMorph: dest 107036 | oldName oldEntry destDirectory newName newEntry baseName response | 107037 destDirectory := self dropDestinationDirectory: dest event: evt. 107038 oldName := aTransferMorph passenger. 107039 baseName := FileDirectory localNameFor: oldName. 107040 newName := destDirectory fullNameFor: baseName. 107041 newName = oldName ifTrue: [ "Transcript nextPutAll: 'same as old name'; cr." ^ true ]. 107042 oldEntry := FileDirectory directoryEntryFor: oldName. 107043 newEntry := FileDirectory directoryEntryFor: newName. 107044 newEntry ifNotNil: [ | msg | 107045 msg := String streamContents: [ :s | 107046 s nextPutAll: 'destination file '; 107047 nextPutAll: newName; 107048 nextPutAll: ' exists already,'; 107049 cr; 107050 nextPutAll: 'and is '; 107051 nextPutAll: (oldEntry modificationTime < newEntry modificationTime 107052 ifTrue: [ 'newer' ] ifFalse: [ 'not newer' ]); 107053 nextPutAll: ' than source file '; 107054 nextPutAll: oldName; 107055 nextPut: $.; 107056 cr; 107057 nextPutAll: 'Overwrite file '; 107058 nextPutAll: newName; 107059 nextPut: $? 107060 ]. 107061 response := self confirm: msg. 107062 response ifFalse: [ ^false ]. 107063 ]. 107064 107065 aTransferMorph shouldCopy 107066 ifTrue: [ self primitiveCopyFileNamed: oldName to: newName ] 107067 ifFalse: [ directory rename: oldName toBe: newName ]. 107068 107069 self updateFileList; fileListIndex: 0. 107070 107071 aTransferMorph source model ~= self 107072 ifTrue: [ aTransferMorph source model updateFileList; fileListIndex: 0 ]. 107073 "Transcript nextPutAll: 'copied'; cr." 107074 ^true! ! 107075 107076!FileList methodsFor: 'drag''n''drop' stamp: 'hfm 11/29/2008 19:20'! 107077dragPassengerFor: item inMorph: dragSource 107078 ^self directory fullNameFor: ((self fileNameFromFormattedItem: item contents copy) 107079 copyReplaceAll: self folderString with: ''). 107080! ! 107081 107082!FileList methodsFor: 'drag''n''drop' stamp: 'hfm 11/29/2008 19:21'! 107083dragTransferTypeForMorph: aMorph 107084 ^#file! ! 107085 107086!FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/15/2003 13:07'! 107087dropDestinationDirectory: dest event: evt 107088 "Answer a FileDirectory representing the drop destination in the directory hierarchy morph dest" 107089 ^ (dest itemFromPoint: evt position) withoutListWrapper! ! 107090 107091!FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/15/2003 22:00'! 107092isDirectoryList: aMorph 107093 ^aMorph isKindOf: SimpleHierarchicalListMorph! ! 107094 107095!FileList methodsFor: 'drag''n''drop' stamp: 'hfm 11/29/2008 19:27'! 107096primitiveCopyFileNamed: srcName to: dstName 107097 "Copied from VMMaker code. 107098 This really ought to be a facility in file system. The major annoyance 107099 here is that file types and permissions are not handled by current 107100 Squeak code. 107101 NOTE that this will clobber the destination file!!" 107102 | buffer src dst | 107103 <primitive: 'primitiveFileCopyNamedTo' module:'FileCopyPlugin'> "primitiveExternalCall" 107104 "If the plugin doesn't do it, go the slow way and lose the filetype info" 107105 "This method may signal FileDoesNotExistException if either the source or 107106 dest files cannnot be opened; possibly permissions or bad name problems" 107107 [[src := FileStream readOnlyFileNamed: srcName] 107108 on: FileDoesNotExistException 107109 do: [^ self error: ('could not open file ', srcName)]. 107110 [dst := FileStream forceNewFileNamed: dstName] 107111 on: FileDoesNotExistException 107112 do: [^ self error: ('could not open file ', dstName)]. 107113 buffer := String new: 50000. 107114 [src atEnd] 107115 whileFalse: [dst 107116 nextPutAll: (src nextInto: buffer)]] 107117 ensure: [src 107118 ifNotNil: [src close]. 107119 dst 107120 ifNotNil: [dst close]]! ! 107121 107122!FileList methodsFor: 'drag''n''drop' stamp: 'hfm 11/29/2008 19:35'! 107123wantsDroppedMorph: aTransferMorph event: evt inMorph: dest 107124 | retval | 107125 retval := (aTransferMorph isKindOf: TransferMorph) 107126 and: [ aTransferMorph dragTransferType == #file ] 107127 and: [ self isDirectoryList: dest ]. 107128 "retval ifFalse: [ Transcript nextPutAll: 'drop not wanted'; cr ]." 107129 ^retval! ! 107130 107131 107132!FileList methodsFor: 'file list' stamp: 'hfm 11/29/2008 18:47'! 107133readOnlyStream 107134 "Answer a read-only stream on the selected file. For the various stream-reading services." 107135 107136 ^self directory ifNotNil: [ :dir | dir readOnlyFileNamed: self fileName ]! ! 107137 107138 107139!FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 19:24'! 107140fileContentsMenu: aMenu shifted: shifted 107141 "Construct aMenu to have items appropriate for the file browser's code pane, given the shift state provided" 107142 107143 | shiftMenu services maybeLine extraLines | 107144 shifted ifTrue: 107145 [shiftMenu := ParagraphEditor shiftedYellowButtonMenu. 107146 ^ aMenu addAllFrom: shiftMenu]. 107147 fileName ifNotNil: 107148 [services := OrderedCollection new. 107149 (#(briefHex briefFile needToGetBriefHex needToGetBrief) includes: brevityState) ifTrue: 107150 [services add: self serviceGet]. 107151 (#(fullHex briefHex needToGetFullHex needToGetBriefHex) includes: brevityState) ifFalse: 107152 [services add: self serviceGetHex]. 107153 (#(needToGetShiftJIS needToGetEUCJP needToGetCNGB needToGetEUCKR needToGetUTF8) includes: brevityState) ifFalse: 107154 [services add: self serviceGetEncodedText]. 107155 maybeLine := services size. 107156 (FileStream sourceFileSuffixes includes: self suffixOfSelectedFile) ifTrue: 107157 [services addAll: 107158 (self servicesFromSelectorSpecs: 107159 #(fileIntoNewChangeSet: fileIn: browseChangesFile: browseFile:))]. 107160 107161 extraLines := OrderedCollection new. 107162 maybeLine > 0 ifTrue: [extraLines add: maybeLine]. 107163 services size > maybeLine ifTrue: [extraLines add: services size]. 107164 aMenu 107165 addServices: services 107166 for: self fullName 107167 extraLines: extraLines]. 107168 107169 aMenu addList: { 107170 {'find...(f)' translated. #find}. 107171 {'find again (g)' translated. #findAgain}. 107172 {'set search string (h)' translated. #setSearchString}. 107173 #-. 107174 {'do again (j)' translated. #again}. 107175 {'undo (z)' translated. #undo}. 107176 #-. 107177 {'copy (c)' translated. #copySelection}. 107178 {'cut (x)' translated. #cut}. 107179 {'paste (v)' translated. #paste}. 107180 {'paste...' translated. #pasteRecent}. 107181 #-. 107182 {'do it (d)' translated. #doIt}. 107183 {'print it (p)' translated. #printIt}. 107184 {'inspect it (i)' translated. #inspectIt}. 107185 {'fileIn selection (G)' translated. #fileItIn}. 107186 #-. 107187 {'accept (s)' translated. #accept}. 107188 {'cancel (l)' translated. #cancel}. 107189 #-. 107190 {'more...' translated. #shiftedYellowButtonActivity}}. 107191 107192 107193 ^ aMenu 107194! ! 107195 107196!FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 18:41'! 107197fileListMenu: aMenu 107198 107199 fileName 107200 ifNil: [^ self noFileSelectedMenu: aMenu] 107201 ifNotNil: [^ self fileSelectedMenu: aMenu]. 107202! ! 107203 107204!FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 18:41'! 107205fileSelectedMenu: aMenu 107206 107207 | firstItems secondItems thirdItems n1 n2 n3 services | 107208 firstItems := self itemsForFile: self fullName. 107209 secondItems := self itemsForAnyFile. 107210 thirdItems := self itemsForNoFile. 107211 n1 := firstItems size. 107212 n2 := n1 + secondItems size. 107213 n3 := n2 + thirdItems size. 107214 services := firstItems, secondItems, thirdItems, self serviceAllFileOptions. 107215 services do: [ :svc | svc addDependent: self ]. 107216 ^ aMenu 107217 addServices2: services 107218 for: self 107219 extraLines: (Array with: n1 with: n2 with: n3) 107220! ! 107221 107222!FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 18:46'! 107223fullFileListMenu: aMenu shifted: aBoolean 107224 "Fill the menu with all possible items for the file list pane, regardless of 107225 selection. " 107226 | lastProvider | 107227 aMenu title: 'all possible file operations' translated. 107228 aMenu addStayUpItemSpecial. 107229 lastProvider := nil. 107230 (self itemsForFile: 'a.*') 107231 do: [:svc | 107232 (lastProvider notNil 107233 and: [svc provider ~~ lastProvider]) 107234 ifTrue: [aMenu addLine]. 107235 svc addServiceFor: self toMenu: aMenu. 107236 aMenu submorphs last setBalloonText: svc description. 107237 lastProvider := svc provider. 107238 svc addDependent: self]. 107239 ^ aMenu! ! 107240 107241!FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 18:42'! 107242itemsForAnyFile 107243 "Answer a list of universal services that could apply to any file" 107244 107245 | services | 107246 services := OrderedCollection new: 4. 107247 services add: self serviceCopyName. 107248 services add: self serviceRenameFile. 107249 services add: self serviceDeleteFile. 107250 services add: self serviceViewContentsInWorkspace. 107251 ^ services! ! 107252 107253!FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 18:57'! 107254itemsForDirectory: dir 107255 | services | 107256 services := OrderedCollection new. 107257 dir ifNotNil: [ 107258 services 107259 addAll: (self class itemsForDirectory: dir). 107260 services last useLineAfter: true. ]. 107261 services add: self serviceAddNewFile. 107262 services add: self serviceAddNewDirectory. 107263 ^ services! ! 107264 107265!FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 18:34'! 107266itemsForFile: fullName 107267 "Answer a list of services appropriate for a file of the given full name" 107268 | suffix | 107269 suffix := self class suffixOf: fullName. 107270 ^ (self class itemsForFile: fullName) , (self myServicesForFile: fullName suffix: suffix)! ! 107271 107272!FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 18:43'! 107273itemsForNoFile 107274 107275 | services | 107276 services := OrderedCollection new. 107277 services add: self serviceSortByName. 107278 services add: self serviceSortBySize. 107279 services add: (self serviceSortByDate useLineAfter: true). 107280 services addAll: (self itemsForDirectory: (self isFileSelected ifFalse: [ self directory ] ifTrue: [])). 107281 ^ services 107282 107283 ! ! 107284 107285!FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 19:26'! 107286myServicesForFile: fullName suffix: suffix 107287 107288 ^(FileStream isSourceFileSuffix: suffix) 107289 ifTrue: [ {self serviceBroadcastUpdate} ] 107290 ifFalse: [ #() ]! ! 107291 107292!FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 19:26'! 107293noFileSelectedMenu: aMenu 107294 107295 ^ aMenu 107296 addServices: self itemsForNoFile 107297 for: self 107298 extraLines: #() 107299 107300! ! 107301 107302!FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 18:46'! 107303offerAllFileOptions 107304 "Put up a menu offering all possible file options, whatever the suffix of the current selection may be. Specially useful if you're wanting to keep the menu up" 107305 107306 self offerMenuFrom: #fullFileListMenu:shifted: shifted: true! ! 107307 107308!FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 19:33'! 107309suffixOfSelectedFile 107310 "Answer the file extension of the receiver's selected file" 107311 ^ self class suffixOf: self fullName.! ! 107312 107313 107314!FileList methodsFor: 'file menu action' stamp: 'DamienCassou 9/29/2009 12:57'! 107315addNew: aString byEvaluating: aBlock 107316 "A parameterization of earlier versions of #addNewDirectory and 107317 #addNewFile. Fixes the bug in each that pushing the cancel button 107318 in the FillInTheBlank dialog gave a walkback." 107319 107320 | response newName index ending | 107321 self okToChange ifFalse: [^ self]. 107322 (response := UIManager default 107323 request: ('New {1} Name?' translated format: {aString translated}) 107324 initialAnswer: ('{1}Name' translated format: {aString translated})) 107325 isEmptyOrNil ifTrue: [^ self]. 107326 newName := response asFileName. 107327 Cursor wait showWhile: [ 107328 aBlock value: newName]. 107329 self updateFileList. 107330 index := list indexOf: newName. 107331 index = 0 ifTrue: [ending := ') ',newName. 107332 index := list findFirst: [:line | line endsWith: ending]]. 107333 self fileListIndex: index. 107334! ! 107335 107336!FileList methodsFor: 'file menu action' stamp: 'hfm 11/29/2008 19:07'! 107337addNewFile 107338 self 107339 addNew: 'File' 107340 byEvaluating: [:newName | (directory newFileNamed: newName) close] 107341! ! 107342 107343!FileList methodsFor: 'file menu action' stamp: 'hfm 11/29/2008 19:16'! 107344compressFile 107345 "Compress the currently selected file" 107346 107347 | f | 107348 f := StandardFileStream 107349 readOnlyFileNamed: (directory fullNameFor: self fullName). 107350 f compressFile. 107351 self updateFileList! ! 107352 107353!FileList methodsFor: 'file menu action' stamp: 'hfm 11/29/2008 19:10'! 107354deleteFile 107355 "Delete the currently selected file" 107356 listIndex = 0 ifTrue: [^ self]. 107357 (self confirm: ('Really delete {1}?' translated format:{fileName})) ifFalse: [^ self]. 107358 directory deleteFileNamed: fileName. 107359 self updateFileList. 107360 brevityState := #FileList. 107361 self get! ! 107362 107363!FileList methodsFor: 'file menu action' stamp: 'hfm 11/29/2008 19:11'! 107364get 107365 "Get contents of file again, it may have changed. Do this by making the cancel string be the contents, and doing a cancel." 107366 107367 Cursor read showWhile: [ 107368 self okToChange ifFalse: [^ nil]. 107369 brevityState == #briefHex 107370 ifTrue: [brevityState := #needToGetFullHex] 107371 ifFalse: [brevityState := #needToGetFull]. 107372 self changed: #contents]. 107373! ! 107374 107375!FileList methodsFor: 'file menu action' stamp: 'hfm 11/29/2008 19:24'! 107376getEncodedText 107377 107378 Cursor read showWhile: [ 107379 self selectEncoding. 107380 self changed: #contents]. 107381! ! 107382 107383!FileList methodsFor: 'file menu action' stamp: 'hfm 11/29/2008 19:24'! 107384getHex 107385 "Get contents of file again, and display in Hex. Do this by making the cancel string be the contents, and doing a cancel." 107386 107387 Cursor read showWhile: [ 107388 brevityState := #needToGetBriefHex. 107389 self changed: #contents]. 107390! ! 107391 107392!FileList methodsFor: 'file menu action' stamp: 'DamienCassou 9/29/2009 12:57'! 107393renameFile 107394 "Rename the currently selected file" 107395 | newName response | 107396 listIndex = 0 ifTrue: [^ self]. 107397 self okToChange ifFalse: [^ self]. 107398 (response := UIManager default request: 'NewFileName?' translated 107399 initialAnswer: fileName) 107400 isEmptyOrNil ifTrue: [^ self]. 107401 newName := response asFileName. 107402 newName = fileName ifTrue: [^ self]. 107403 directory rename: fileName toBe: newName. 107404 self updateFileList. 107405 listIndex := list findFirst: [:item | (self fileNameFromFormattedItem: item) = newName]. 107406 listIndex > 0 ifTrue: [fileName := newName]. 107407 self changed: #fileListIndex. 107408! ! 107409 107410!FileList methodsFor: 'file menu action' stamp: 'hfm 11/29/2008 18:51'! 107411sortByDate 107412 self resort: #date! ! 107413 107414!FileList methodsFor: 'file menu action' stamp: 'hfm 11/29/2008 18:49'! 107415sortByName 107416 self resort: #name! ! 107417 107418!FileList methodsFor: 'file menu action' stamp: 'hfm 11/29/2008 18:50'! 107419sortBySize 107420 self resort: #size! ! 107421 107422 107423!FileList methodsFor: 'initialization' stamp: 'hfm 11/29/2008 18:33'! 107424buttonSelectorsToSuppress 107425 "Answer a list of action selectors whose corresponding services we would prefer *not* to have appear in the filelist's button pane; this can be hand-jimmied to suit personal taste." 107426 107427 ^ #(removeLineFeeds: addFileToNewZip: compressFile: putUpdate:)! ! 107428 107429!FileList methodsFor: 'initialization' stamp: 'RAA 8/17/2000 13:22'! 107430directoryChangeBlock: aBlockOrNil 107431 107432 directoryChangeBlock := aBlockOrNil.! ! 107433 107434!FileList methodsFor: 'initialization' stamp: 'hfm 11/29/2008 18:31'! 107435dynamicButtonServices 107436 "Answer services for buttons that may come and go in the button pane, depending on selection" 107437 107438 ^ fileName isEmptyOrNil 107439 ifTrue: 107440 [#()] 107441 ifFalse: 107442 [ | toReject | 107443 toReject := self buttonSelectorsToSuppress. 107444 (self itemsForFile: self fullName) reject: 107445 [:svc | toReject includes: svc selector]]! ! 107446 107447!FileList methodsFor: 'initialization' stamp: 'RAA 6/16/2000 13:08'! 107448fileSelectionBlock: aBlock 107449 107450 fileSelectionBlock := aBlock! ! 107451 107452!FileList methodsFor: 'initialization' stamp: 'ar 2/12/2001 16:12'! 107453initialDirectoryList 107454 107455 | dir nameToShow dirList | 107456 dirList := (FileDirectory on: '') directoryNames collect: [ :each | 107457 FileDirectoryWrapper with: (FileDirectory on: each) name: each model: self]. 107458 dirList isEmpty ifTrue:[ 107459 dirList := Array with: (FileDirectoryWrapper 107460 with: FileDirectory default 107461 name: FileDirectory default localName 107462 model: self)]. 107463 dirList := dirList,( 107464 ServerDirectory serverNames collect: [ :n | 107465 dir := ServerDirectory serverNamed: n. 107466 nameToShow := n. 107467 (dir directoryWrapperClass with: dir name: nameToShow model: self) 107468 balloonText: dir realUrl 107469 ] 107470 ). 107471 ^dirList! ! 107472 107473!FileList methodsFor: 'initialization' stamp: 'RAA 6/16/2000 10:40'! 107474labelString 107475 ^ (directory ifNil: [^'[]']) pathName contractTo: 50! ! 107476 107477!FileList methodsFor: 'initialization' stamp: 'hfm 11/29/2008 19:25'! 107478modelSleep 107479 "User has exited or collapsed the window -- close any remote connection." 107480 107481 directory ifNotNil: [directory sleep]! ! 107482 107483!FileList methodsFor: 'initialization' stamp: 'hfm 11/29/2008 19:26'! 107484modelWakeUp 107485 "User has entered or expanded the window -- reopen any remote connection." 107486 107487 (directory notNil and:[directory isRemoteDirectory]) 107488 ifTrue: [[directory wakeUp] on: TelnetProtocolError do: [ :ex | self inform: ex printString ]] "It would be good to implement a null method wakeUp on the root of directory"! ! 107489 107490!FileList methodsFor: 'initialization' stamp: 'hfm 11/29/2008 18:29'! 107491optionalButtonRow 107492 "Answer the button row associated with a file list" 107493 107494 | aRow | 107495 aRow := AlignmentMorph newRow beSticky. 107496 aRow color: Color transparent. 107497 aRow clipSubmorphs: true. 107498 aRow layoutInset: 5@1; cellInset: 6. 107499 self universalButtonServices do: "just the three sort-by items" 107500 [:service | 107501 aRow addMorphBack: (service buttonToTriggerIn: self). 107502 (service selector == #sortBySize) 107503 ifTrue: 107504 [aRow addTransparentSpacerOfSize: (4@0)]]. 107505 aRow setNameTo: 'buttons'. 107506 aRow setProperty: #buttonRow toValue: true. "Used for dynamic retrieval later on" 107507 ^ aRow! ! 107508 107509!FileList methodsFor: 'initialization' stamp: 'hfm 12/12/2008 13:30'! 107510optionalButtonSpecs 107511 "Answer a list of services underlying the optional buttons in their initial inception." 107512 107513 ^ optionalButtonSpecs 107514 ifNil: [ { self serviceSortByName . self serviceSortByDate . self serviceSortBySize } ] 107515 107516 ! ! 107517 107518!FileList methodsFor: 'initialization' stamp: 'RAA 6/16/2000 13:01'! 107519optionalButtonSpecs: anArray 107520 107521 optionalButtonSpecs := anArray! ! 107522 107523!FileList methodsFor: 'initialization' stamp: 'hfm 11/29/2008 19:31'! 107524release 107525 107526 self modelSleep! ! 107527 107528!FileList methodsFor: 'initialization' stamp: 'hfm 11/29/2008 18:30'! 107529serviceSortByDate 107530 "Answer a service for sorting by date" 107531 107532 ^ (SimpleServiceEntry new 107533 provider: self 107534 label: 'by date' 107535 selector: #sortByDate 107536 description: 'sort entries by date') 107537 extraSelector: #sortingByDate; 107538 buttonLabel: 'date'! ! 107539 107540!FileList methodsFor: 'initialization' stamp: 'hfm 11/29/2008 18:30'! 107541serviceSortByName 107542 "Answer a service for soring by name" 107543 107544 ^ (SimpleServiceEntry new 107545 provider: self label: 'by name' selector: #sortByName 107546 description: 'sort entries by name') 107547 extraSelector: #sortingByName; 107548 buttonLabel: 'name'! ! 107549 107550!FileList methodsFor: 'initialization' stamp: 'hfm 11/29/2008 18:30'! 107551serviceSortBySize 107552 "Answer a service for sorting by size" 107553 107554 ^ (SimpleServiceEntry 107555 provider: self 107556 label: 'by size' 107557 selector: #sortBySize 107558 description: 'sort entries by size') 107559 extraSelector: #sortingBySize; 107560 buttonLabel: 'size'! ! 107561 107562!FileList methodsFor: 'initialization' stamp: 'hfm 11/29/2008 19:33'! 107563setFileStream: aStream 107564 "Used to initialize a spawned file editor. Sets directory too." 107565 107566 self directory: aStream directory. 107567 fileName := aStream localName. 107568 pattern := '*'. 107569 listIndex := 1. "pretend a file is selected" 107570 aStream close. 107571 brevityState := #needToGetBrief. 107572 self changed: #contents. 107573! ! 107574 107575!FileList methodsFor: 'initialization' stamp: 'sw 2/22/2002 02:34'! 107576universalButtonServices 107577 "Answer the services to be reflected in the receiver's buttons" 107578 107579 ^ self optionalButtonSpecs! ! 107580 107581!FileList methodsFor: 'initialization' stamp: 'hfm 11/29/2008 18:28'! 107582updateButtonRow 107583 "Dynamically update the contents of the button row, if any." 107584 107585 | aWindow aRow | 107586 aWindow := self dependents 107587 detect: [:m | (m isSystemWindow) and: [m model == self]] 107588 ifNone: [^self]. 107589 aRow := aWindow findDeepSubmorphThat: [:m | m hasProperty: #buttonRow] 107590 ifAbsent: [^self]. 107591 aRow submorphs size - 4 timesRepeat: [aRow submorphs last delete]. 107592 self dynamicButtonServices do: 107593 [:service | 107594 aRow addMorphBack: (service buttonToTriggerIn: self). 107595 service addDependent: self]! ! 107596 107597!FileList methodsFor: 'initialization' stamp: 'nk 6/14/2004 09:39'! 107598updateDirectory 107599 "directory has been changed externally, by calling directory:. 107600 Now change the view to reflect the change." 107601 self changed: #currentDirectorySelected. 107602 self postOpen.! ! 107603 107604 107605!FileList methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:53'! 107606initialize 107607 super initialize. 107608 fileSelectionBlock := [ :entry :myPattern | 107609 entry isDirectory ifTrue: [ 107610 false 107611 ] ifFalse: [ 107612 myPattern = '*' or: [myPattern match: entry name] 107613 ] 107614 ]. 107615 dirSelectionBlock := [ :dirName | true].! ! 107616 107617 107618!FileList methodsFor: 'menu messages' stamp: 'hfm 11/29/2008 19:22'! 107619copyName 107620 107621 listIndex = 0 ifTrue: [^ self]. 107622 Clipboard clipboardText: self fullName asText. 107623! ! 107624 107625!FileList methodsFor: 'menu messages' stamp: 'hfm 11/29/2008 19:27'! 107626perform: selector orSendTo: otherTarget 107627 "Selector was just chosen from a menu by a user. 107628 If it's one of the three sort-by items, handle it specially. 107629 If I can respond myself, then perform it on myself. 107630 If not, send it to otherTarget, presumably the editPane from which the menu was invoked." 107631 107632 ^ (#(sortByDate sortBySize sortByName) includes: selector) 107633 ifTrue: 107634 [self resort: selector] 107635 ifFalse: 107636 [(#(get getHex copyName openImageInWindow importImage renameFile deleteFile addNewFile) includes: selector) 107637 ifTrue: [self perform: selector] 107638 ifFalse: [super perform: selector orSendTo: otherTarget]]! ! 107639 107640 107641!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 18:59'! 107642addNewDirectory 107643 self 107644 addNew: 'Directory' 107645 byEvaluating: [:newName | directory createDirectory: newName] 107646! ! 107647 107648!FileList methodsFor: 'own services' stamp: 'nk 6/14/2004 09:42'! 107649deleteDirectory 107650 super deleteDirectory. 107651 self updateDirectory.! ! 107652 107653!FileList methodsFor: 'own services' stamp: 'sd 5/11/2003 22:15'! 107654importImage 107655 "Import the given image file and store the resulting Form in the default Imports" 107656 107657 | fname image | 107658 fname := fileName sansPeriodSuffix. 107659 image := Form fromFileNamed: self fullName. 107660 Imports default importImage: image named: fname. 107661! ! 107662 107663!FileList methodsFor: 'own services' stamp: 'sw 2/22/2002 02:35'! 107664okayAndCancelServices 107665 "Answer ok and cancel services" 107666 107667 ^ {self serviceOkay. self serviceCancel}! ! 107668 107669!FileList methodsFor: 'own services' stamp: 'alain.plantec 5/30/2008 13:12'! 107670openImageInWindow 107671 "Handle five file formats: GIF, JPG, PNG, Form stoteOn: (run coded), and 107672 BMP. Fail if file format is not recognized." 107673 | image myStream | 107674 myStream := (directory readOnlyFileNamed: fileName) binary. 107675 image := Form fromBinaryStream: myStream. 107676 myStream close. 107677 (World drawingClass withForm: image) openInWorld! ! 107678 107679!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 18:45'! 107680serviceAddNewDirectory 107681 "Answer a service entry characterizing the 'add new directory' command" 107682 107683 ^ SimpleServiceEntry 107684 provider: self 107685 label: 'add new directory' 107686 selector: #addNewDirectory 107687 description: 'adds a new, empty directory (folder)' ! ! 107688 107689!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 18:45'! 107690serviceAddNewFile 107691 "Answer a service entry characterizing the 'add new file' command" 107692 107693 ^ SimpleServiceEntry provider: self label: 'add new file' selector: #addNewFile description: 'create a new,. empty file, and add it to the current directory.'! ! 107694 107695!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 18:45'! 107696serviceAllFileOptions 107697 107698 ^ {SimpleServiceEntry provider: self label: 'more...' selector: #offerAllFileOptions description: 'show all the options available'}! ! 107699 107700!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 18:48'! 107701serviceBroadcastUpdate 107702 "Answer a service for broadcasting a file as an update" 107703 107704 ^ SimpleServiceEntry 107705 provider: self 107706 label: 'broadcast as update' 107707 selector: #putUpdate: 107708 description: 'broadcast file as update' 107709 buttonLabel: 'broadcast'! ! 107710 107711!FileList methodsFor: 'own services' stamp: 'nk 6/8/2004 17:09'! 107712serviceCancel 107713 "Answer a service for hitting the cancel button" 107714 107715 ^ (SimpleServiceEntry new 107716 provider: self label: 'cancel' selector: #cancelHit 107717 description: 'hit here to cancel ') 107718 buttonLabel: 'cancel'! ! 107719 107720!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 19:32'! 107721serviceCompressFile 107722 "Answer a service for compressing a file" 107723 107724 ^ SimpleServiceEntry provider: self label: 'compress' selector: #compressFile description: 'compress file' buttonLabel: 'compress'! ! 107725 107726!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 18:42'! 107727serviceCopyName 107728 107729 ^ (SimpleServiceEntry provider: self label: 'copy name to clipboard' selector: #copyName description:'copy name to clipboard' )! ! 107730 107731!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 18:43'! 107732serviceDeleteFile 107733 107734 ^ (SimpleServiceEntry provider: self label: 'delete' selector: #deleteFile) 107735 description: 'delete the seleted item'! ! 107736 107737!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 19:32'! 107738serviceGet 107739 "Answer a service for getting the entire file" 107740 107741 ^ (SimpleServiceEntry 107742 provider: self 107743 label: 'get entire file' 107744 selector: #get 107745 description: 'if the file has only been partially read in, because it is very large, read the entire file in at this time.')! ! 107746 107747!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 19:32'! 107748serviceGetEncodedText 107749 107750 ^ (SimpleServiceEntry 107751 provider: self 107752 label: 'view as encoded text' 107753 selector: #getEncodedText 107754 description: 'view as encoded text') 107755 107756! ! 107757 107758!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 19:32'! 107759serviceGetHex 107760 107761 ^ (SimpleServiceEntry 107762 provider: self 107763 label: 'view as hex' 107764 selector: #getHex 107765 description: 'view as hex') 107766 107767! ! 107768 107769!FileList methodsFor: 'own services' stamp: 'nk 6/8/2004 17:09'! 107770serviceOkay 107771 "Answer a service for hitting the okay button" 107772 107773 ^ (SimpleServiceEntry new 107774 provider: self label: 'okay' selector: #okHit 107775 description: 'hit here to accept the current selection') 107776 buttonLabel: 'ok'! ! 107777 107778!FileList methodsFor: 'own services' stamp: 'sw 2/22/2002 02:07'! 107779serviceOpenProjectFromFile 107780 "Answer a service for opening a .pr project file" 107781 107782 ^ SimpleServiceEntry 107783 provider: self 107784 label: 'load as project' 107785 selector: #openProjectFromFile 107786 description: 'open project from file' 107787 buttonLabel: 'load'! ! 107788 107789!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 18:42'! 107790serviceRenameFile 107791 107792 ^ (SimpleServiceEntry provider: self label: 'rename' selector: #renameFile description: 'rename file')! ! 107793 107794!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 18:43'! 107795serviceViewContentsInWorkspace 107796 "Answer a service for viewing the contents of a file in a workspace" 107797 107798 ^ (SimpleServiceEntry provider: self label: 'workspace with contents' selector: #viewContentsInWorkspace) 107799 description: 'open a new Workspace whose contents are set to the contents of this file'! ! 107800 107801!FileList methodsFor: 'own services' stamp: 'sw 2/22/2002 02:36'! 107802servicesForFolderSelector 107803 "Answer the ok and cancel servies for the folder selector" 107804 107805 ^ self okayAndCancelServices! ! 107806 107807!FileList methodsFor: 'own services' stamp: 'sw 2/22/2002 02:36'! 107808servicesForProjectLoader 107809 "Answer the services to show in the button pane for the project loader" 107810 107811 ^ {self serviceSortByName. self serviceSortByDate. self serviceSortBySize. self serviceOpenProjectFromFile}! ! 107812 107813!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 20:13'! 107814servicesFromSelectorSpecs: symbolArray 107815 "Answer an array of services represented by the incoming symbols, eliminating any that do not have a currently-registered service. Pass the symbol #- along unchanged to serve as a separator between services" 107816 107817 "FileList new servicesFromSelectorSpecs: #(fileIn: fileIntoNewChangeSet: browseChangesFile:)" 107818 107819 | res services col | 107820 col := OrderedCollection new. 107821 services := self class allRegisteredServices, (self myServicesForFile: #dummy suffix: '*'). 107822 symbolArray do: 107823 [:sel | 107824 sel == #- 107825 ifTrue: 107826 [col add: sel] 107827 ifFalse: 107828 [res := services 107829 detect: [:each | each selector = sel] ifNone: [nil]. 107830 res notNil 107831 ifTrue: [col add: res]]]. 107832 ^ col! ! 107833 107834!FileList methodsFor: 'own services' stamp: 'hfm 11/29/2008 18:51'! 107835viewContentsInWorkspace 107836 "View the contents of my selected file in a new workspace" 107837 107838 | aString aFileStream aName | 107839 aString := (aFileStream := directory readOnlyFileNamed: self fullName) setConverterForCode contentsOfEntireFile. 107840 aName := aFileStream localName. 107841 aFileStream close. 107842 UIManager default edit: aString label: 'Workspace from ', aName! ! 107843 107844 107845!FileList methodsFor: 'server list' stamp: 'stephane.ducasse 7/3/2009 21:38'! 107846askServerInfo 107847 "Get the user to create a ServerDirectory for a new server. Fill in and say Accept." 107848 | template | 107849 template := '"Please fill in the following info, then select all text and choose DoIt." 107850 107851 | aa | 107852 self flag: #ViolateNonReferenceToOtherClasses. 107853 aa := ServerDirectory new. 107854 aa server: ''st.cs.uiuc.edu''. "host" 107855 aa user: ''anonymous''. 107856 aa password: ''yourEmail@school.edu''. 107857 aa directory: ''/Smalltalk/Squeak/Goodies''. 107858 aa url: ''''. "<- this is optional. Only used when *writing* update files." 107859 ServerDirectory addServer: aa named: ''UIUCArchive''. "<- known by this name in Squeak"'. 107860 107861 (StringHolder new contents: template) openLabel: 'FTP Server Form' 107862 ! ! 107863 107864!FileList methodsFor: 'server list' stamp: 'alain.plantec 2/6/2009 16:54'! 107865putUpdate: fullFileName 107866 "Put this file out as an Update on the servers." 107867 107868 | names choice | 107869 self canDiscardEdits ifFalse: [^ self changed: #flash]. 107870 names := ServerDirectory groupNames asSortedArray. 107871 choice := UIManager default chooseFrom: names values: names. 107872 choice ifNil: [^ self]. 107873 (ServerDirectory serverInGroupNamed: choice) putUpdate: 107874 (directory oldFileNamed: fullFileName). 107875 self volumeListIndex: volListIndex. 107876! ! 107877 107878!FileList methodsFor: 'server list' stamp: 'alain.plantec 2/6/2009 16:55'! 107879removeServer 107880 107881 | choice names | 107882 self flag: #ViolateNonReferenceToOtherClasses. 107883 names := ServerDirectory serverNames asSortedArray. 107884 choice := UIManager default chooseFrom: names values: names. 107885 choice ifNil: [^ self]. 107886 ServerDirectory removeServerNamed: choice! ! 107887 107888 107889!FileList methodsFor: 'updating' stamp: 'hfm 11/29/2008 19:33'! 107890update: aParameter 107891 "Receive a change notice from an object of whom the receiver is a dependent" 107892 107893 (aParameter == #fileListChanged) ifTrue: [self updateFileList]. 107894 super update: aParameter! ! 107895 107896 107897!FileList methodsFor: 'user interface' stamp: 'stephane.ducasse 4/13/2009 21:06'! 107898blueButtonForService: aService textColor: textColor inWindow: window 107899 | block result | 107900 block := [self fullName isNil 107901 ifTrue: [self inform: 'Please select a file' translated] 107902 ifFalse: [aService performServiceFor: self]]. 107903 result := window 107904 fancyText: aService buttonLabel capitalized translated 107905 font: Preferences standardEToysFont 107906 color: textColor. 107907 result setProperty: #buttonText toValue: aService buttonLabel capitalized; 107908 hResizing: #rigid; 107909 extent: 100 @ 20; 107910 layoutInset: 4; 107911 borderWidth: ColorTheme current dialogButtonBorderWidth; 107912 useRoundedCorners; 107913 setBalloonText: aService label. 107914 result 107915 on: #mouseUp 107916 send: #value 107917 to: block. 107918 ^ result! ! 107919 107920!FileList methodsFor: 'user interface' stamp: 'RAA 2/17/2001 12:18'! 107921morphicDirectoryTreePane 107922 107923 ^self morphicDirectoryTreePaneFiltered: #initialDirectoryList 107924! ! 107925 107926!FileList methodsFor: 'user interface' stamp: 'rww 12/13/2003 13:07'! 107927morphicDirectoryTreePaneFiltered: aSymbol 107928 ^(SimpleHierarchicalListMorph 107929 on: self 107930 list: aSymbol 107931 selected: #currentDirectorySelected 107932 changeSelected: #setSelectedDirectoryTo: 107933 menu: #volumeMenu: 107934 keystroke: nil) 107935 autoDeselect: false; 107936 enableDrag: false; 107937 enableDrop: true; 107938 yourself 107939 107940! ! 107941 107942!FileList methodsFor: 'user interface' stamp: 'RAA 6/16/2000 10:53'! 107943morphicFileContentsPane 107944 107945 ^PluggableTextMorph 107946 on: self 107947 text: #contents 107948 accept: #put: 107949 readSelection: #contentsSelection 107950 menu: #fileContentsMenu:shifted: 107951! ! 107952 107953!FileList methodsFor: 'user interface' stamp: 'nk 6/15/2003 13:05'! 107954morphicFileListPane 107955 107956 ^(PluggableListMorph 107957 on: self 107958 list: #fileList 107959 selected: #fileListIndex 107960 changeSelected: #fileListIndex: 107961 menu: #fileListMenu:) 107962 enableDrag: true; 107963 enableDrop: false; 107964 yourself 107965 107966! ! 107967 107968 107969!FileList methodsFor: 'volume list and pattern' stamp: 'nk 6/14/2004 09:45'! 107970changeDirectoryTo: aFileDirectory 107971 "Change directory as requested." 107972 107973 self directory: aFileDirectory. 107974 self updateDirectory! ! 107975 107976!FileList methodsFor: 'volume list and pattern' stamp: 'hfm 11/29/2008 18:27'! 107977fileNameFormattedFrom: entry sizePad: sizePad 107978 "entry is a 5-element array of the form: 107979 (name creationTime modificationTime dirFlag fileSize)" 107980 | sizeStr nameStr dateStr | 107981 nameStr := (entry at: 4) 107982 ifTrue: [entry first , self folderString] 107983 ifFalse: [entry first]. 107984 dateStr := ((Date fromSeconds: (entry at: 3) ) 107985 printFormat: #(3 2 1 $. 1 1 2)) , ' ' , 107986 (String streamContents: [:s | 107987 (Time fromSeconds: (entry at: 3) \\ 86400) 107988 print24: true on: s]). 107989 sizeStr := (entry at: 5) asStringWithCommas. 107990 sortMode = #name ifTrue: 107991 [^ nameStr , ' (' , dateStr , ' ' , sizeStr , ')']. 107992 sortMode = #date ifTrue: 107993 [^ '(' , dateStr , ' ' , sizeStr , ') ' , nameStr]. 107994 sortMode = #size ifTrue: 107995 [^ '(' , ((sizeStr size to: sizePad) collect: [:i | $ ]) , sizeStr , ' ' , dateStr , ') ' , nameStr]. 107996! ! 107997 107998!FileList methodsFor: 'volume list and pattern' stamp: 'hfm 11/29/2008 18:25'! 107999listForPatterns: anArray 108000 "Make the list be those file names which match the pattern." 108001 108002 | sizePad newList | 108003 newList := Set new. 108004 anArray do: [ :pat | newList addAll: (self entriesMatching: pat) ]. 108005 newList := (SortedCollection sortBlock: self sortBlock) addAll: newList; yourself. 108006 sizePad := (newList inject: 0 into: [:mx :entry | mx max: (entry at: 5)]) 108007 asStringWithCommas size - 1. 108008 newList := newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ]. 108009 108010 volList size = 1 ifTrue: 108011 ["Include known servers along with other desktop volumes" 108012 ^ newList asArray , 108013 (ServerDirectory serverNames collect: [:n | '^' , n , self folderString])]. 108014 ^ newList asArray! ! 108015 108016!FileList methodsFor: 'volume list and pattern' stamp: 'hfm 11/29/2008 19:34'! 108017veryDeepFixupWith: deepCopier 108018 super veryDeepFixupWith: deepCopier. 108019 volListIndex := 1. 108020 self directory: FileDirectory default. 108021 self updateFileList! ! 108022 108023!FileList methodsFor: 'volume list and pattern' stamp: 'hfm 11/29/2008 19:34'! 108024volumeList 108025 "Answer the current list of volumes." 108026 108027 ^ volList 108028! ! 108029 108030!FileList methodsFor: 'volume list and pattern' stamp: 'hfm 11/29/2008 19:34'! 108031volumeListIndex 108032 "Answer the index of the currently selected volume." 108033 108034 ^ volListIndex 108035! ! 108036 108037!FileList methodsFor: 'volume list and pattern' stamp: 'hfm 11/29/2008 19:34'! 108038volumeListIndex: index 108039 "Select the volume name having the given index." 108040 108041 | delim path | 108042 volListIndex := index. 108043 index = 1 108044 ifTrue: [self directory: (FileDirectory on: '')] 108045 ifFalse: [delim := directory pathNameDelimiter. 108046 path := String streamContents: [:strm | 108047 2 to: index do: [:i | 108048 strm nextPutAll: (volList at: i) withBlanksTrimmed. 108049 i < index ifTrue: [strm nextPut: delim]]]. 108050 self directory: (directory on: path)]. 108051 brevityState := #FileList. 108052 self addPath: path. 108053 self changed: #fileList. 108054 self changed: #contents. 108055 self updateButtonRow! ! 108056 108057 108058!FileList methodsFor: 'volume menu' stamp: 'hfm 11/29/2008 18:57'! 108059volumeMenu: aMenu 108060 aMenu addList: { 108061 {'recent...' translated. #recentDirs}. 108062 #-. 108063 {'add server...' translated. #askServerInfo}. 108064 {'remove server...' translated. #removeServer}. 108065 #-. 108066 {'delete directory...' translated. #deleteDirectory}. 108067 #-}. 108068 aMenu 108069 addServices: (self itemsForDirectory: self directory) 108070 for: self 108071 extraLines: #(). 108072 ^aMenu.! ! 108073 108074 108075!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 19:01'! 108076addPath: aString 108077 "Add the given string to the list of recently visited directories." 108078 108079 | full | 108080 aString ifNil: [^self]. 108081 full := String streamContents: 108082 [ :strm | 2 to: volList size do: 108083 [ :i | strm nextPutAll: (volList at: i) withBlanksTrimmed. 108084 strm nextPut: FileDirectory pathNameDelimiter]]. 108085 full := full, aString. 108086"Remove and super-directories of aString from the collection." 108087 RecentDirs removeAllSuchThat: [ :aDir | ((aDir, '*') match: full)]. 108088 108089"If a sub-directory is in the list, do nothing." 108090 (RecentDirs detect: [ :aDir | ((full, '*') match: aDir)] ifNone: [nil]) 108091 ifNotNil: [^self]. 108092 108093 [RecentDirs size >= 10] 108094 whileTrue: [RecentDirs removeFirst]. 108095 RecentDirs addLast: full! ! 108096 108097!FileList methodsFor: 'private' stamp: 'RAA 4/6/2001 12:45'! 108098cancelHit 108099 108100 modalView delete. 108101 directory := fileName := currentDirectorySelected := nil.! ! 108102 108103!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 19:17'! 108104contents 108105 "Answer the contents of the file, reading it first if needed." 108106 "Possible brevityState values: 108107 FileList, 108108 fullFile, briefFile, needToGetFull, needToGetBrief, 108109 fullHex, briefHex, needToGetFullHex, needToGetBriefHex" 108110 108111 (listIndex = 0) | (brevityState == #FileList) ifTrue: [^ self defaultContents]. "no file selected" 108112 brevityState == #fullFile ifTrue: [^ contents]. 108113 brevityState == #fullHex ifTrue: [^ contents]. 108114 brevityState == #briefFile ifTrue: [^ contents]. 108115 brevityState == #briefHex ifTrue: [^ contents]. 108116 108117 brevityState == #needToGetFullHex ifTrue: [^ self readContentsHex: false]. 108118 brevityState == #needToGetBriefHex ifTrue: [^ self readContentsHex: true]. 108119 108120 brevityState == #needToGetFull ifTrue: [^ self readContentsBrief: false]. 108121 brevityState == #needToGetBrief ifTrue: [^ self readContentsBrief: true]. "default" 108122 108123 (TextConverter allEncodingNames includes: brevityState) 108124 ifTrue: [ ^self readContentsAsEncoding: brevityState]. 108125 108126 self halt: 'unknown state ' , brevityState printString! ! 108127 108128!FileList methodsFor: 'private' stamp: 'LC 1/6/2002 06:50'! 108129currentDirectorySelected 108130 ^ currentDirectorySelected 108131! ! 108132 108133!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 19:23'! 108134defaultContents 108135 contents := list == nil 108136 ifTrue: [String new] 108137 ifFalse: [String streamContents: 108138 [:s | s nextPutAll: 'NO FILE SELECTED' translated; cr. 108139 s nextPutAll: ' -- Folder Summary --' translated; cr. 108140 list do: [:item | s nextPutAll: item; cr]]]. 108141 brevityState := #FileList. 108142 ^ contents! ! 108143 108144!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 19:18'! 108145defaultEncoderFor: aFileName 108146 108147 "This method just illustrates the stupidest possible implementation of encoder selection." 108148 | l | 108149 l := aFileName asLowercase. 108150" ((l endsWith: FileStream multiCs) or: [ 108151 l endsWith: FileStream multiSt]) ifTrue: [ 108152 ^ UTF8TextConverter new. 108153 ]. 108154" 108155 ((l endsWith: FileStream cs) or: [ 108156 l endsWith: FileStream st]) ifTrue: [ 108157 ^ MacRomanTextConverter new. 108158 ]. 108159 108160 ^ Latin1TextConverter new. 108161 108162 ! ! 108163 108164!FileList methodsFor: 'private' stamp: 'ar 2/12/2001 16:20'! 108165directoryNamesFor: item 108166 "item may be file directory or server directory" 108167 | entries | 108168 entries := item directoryNames. 108169 dirSelectionBlock ifNotNil:[entries := entries select: dirSelectionBlock]. 108170 ^entries! ! 108171 108172!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 18:26'! 108173entriesMatching: patternString 108174 "Answer a list of directory entries which match the patternString. 108175 The patternString may consist of multiple patterns separated by ';'. 108176 Each pattern can include a '*' or '#' as wildcards - see String>>match:" 108177 108178 | entries patterns | 108179 entries := directory entries. 108180 patterns := patternString findTokens: ';'. 108181 (patterns anySatisfy: [:each | each = '*']) 108182 ifTrue: [^ entries]. 108183 ^ entries select: [:entry | 108184 entry isDirectory or: [patterns anySatisfy: [:each | each match: entry first]]]! ! 108185 108186!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 18:32'! 108187fileNameFromFormattedItem: item 108188 "Extract fileName and folderString from a formatted fileList item string" 108189 108190 | from to | 108191 self sortingByName 108192 ifTrue: [ 108193 from := item lastIndexOf: $( ifAbsent: [0]. 108194 to := item lastIndexOf: $) ifAbsent: [0]] 108195 ifFalse: [ 108196 from := item indexOf: $( ifAbsent: [0]. 108197 to := item indexOf: $) ifAbsent: [0]]. 108198 ^ (from * to = 0 108199 ifTrue: [item] 108200 ifFalse: [item copyReplaceFrom: from to: to with: '']) withBlanksTrimmed! ! 108201 108202!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 18:27'! 108203folderString 108204 ^ ' [...]'! ! 108205 108206!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 18:33'! 108207fullName 108208 "Answer the full name for the currently selected file; answer nil if no file is selected." 108209 108210 ^ fileName ifNotNil: [directory 108211 ifNil: 108212 [FileDirectory default fullNameFor: fileName] 108213 ifNotNil: 108214 [directory fullNameFor: fileName]] 108215! ! 108216 108217!FileList methodsFor: 'private' stamp: 'LC 1/6/2002 06:51'! 108218getSelectedDirectory 108219 ok == true ifFalse: [^ nil]. 108220 ^ currentDirectorySelected 108221! ! 108222 108223!FileList methodsFor: 'private' stamp: 'sw 9/12/2002 00:43'! 108224getSelectedFile 108225 "Answer a filestream on the selected file. If it cannot be opened for read/write, try read-only before giving up; answer nil if unsuccessful" 108226 108227 ok == true ifFalse: [^ nil]. 108228 directory ifNil: [^ nil]. 108229 fileName ifNil: [^ nil]. 108230 ^ (directory oldFileNamed: fileName) ifNil: 108231 [directory readOnlyFileNamed: fileName]! ! 108232 108233!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 18:44'! 108234isFileSelected 108235 "return if a file is currently selected" 108236 108237 ^ fileName notNil! ! 108238 108239!FileList methodsFor: 'private' stamp: 'RAA 6/21/2000 12:06'! 108240modalView: aSystemWindowOrSuch 108241 108242 modalView := aSystemWindowOrSuch! ! 108243 108244!FileList methodsFor: 'private' stamp: 'md 10/22/2003 15:27'! 108245okHit 108246 ok := true. 108247 currentDirectorySelected 108248 ifNil: [Beeper beep] 108249 ifNotNil: [modalView delete]! ! 108250 108251!FileList methodsFor: 'private' stamp: 'RAA 6/16/2000 10:48'! 108252postOpen 108253 108254 directory ifNotNil: [ 108255 self changed: #(openPath) , directory pathParts. 108256 ]. 108257! ! 108258 108259!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 19:27'! 108260put: aText 108261 "Private - put the supplied text onto the file" 108262 108263 | ff type | 108264 brevityState == #fullFile ifTrue: 108265 [ff := directory newFileNamed: self fullName. 108266 Cursor write showWhile: [ff nextPutAll: aText asString; close]. 108267 fileName = ff localName 108268 ifTrue: [contents := aText asString] 108269 ifFalse: [self updateFileList]. "user renamed the file" 108270 ^ true "accepted"]. 108271 108272 listIndex = 0 ifTrue: 108273 [self inform: 'No fileName is selected' translated. 108274 ^ false "failed"]. 108275 type := 'These'. 108276 brevityState = #briefFile ifTrue: [type := 'Abbreviated']. 108277 brevityState = #briefHex ifTrue: [type := 'Abbreviated']. 108278 brevityState = #fullHex ifTrue: [type := 'Hexadecimal']. 108279 brevityState = #FileList ifTrue: [type := 'Directory']. 108280 self inform: ('{1} contents cannot 108281meaningfully be saved at present.' translated format:{type translated}). 108282 ^ false "failed" 108283! ! 108284 108285!FileList methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 01:26'! 108286readContentsAsEncoding: encodingName 108287 | f writeStream converter c | 108288 f := directory oldFileOrNoneNamed: self fullName. 108289 f ifNil: [^ 'For some reason, this file cannot be read']. 108290 writeStream := String new writeStream. 108291 converter := TextConverter defaultConverterClassForEncoding: encodingName. 108292 converter ifNil: [^ 'This encoding is not supported']. 108293 f converter: converter new. 108294 f wantsLineEndConversion: true. 108295 [f atEnd or: [(c := f next) isNil]] 108296 whileFalse: [writeStream nextPut: c]. 108297 f close. 108298 ^ writeStream contents! ! 108299 108300!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 19:18'! 108301readContentsBrief: brevityFlag 108302 "Read the contents of the receiver's selected file, unless it is too long, in which case show just the first 5000 characters. Don't create a file if it doesn't already exist." 108303 | f fileSize first5000 | 108304 108305 brevityFlag ifTrue: [ 108306 directory isRemoteDirectory ifTrue: [^ self readServerBrief]]. 108307 f := directory oldFileOrNoneNamed: self fullName. 108308 f ifNil: [^ 'For some reason, this file cannot be read' translated]. 108309 f converter: (self defaultEncoderFor: self fullName). 108310 (brevityFlag not or: [(fileSize := f size) <= 100000]) ifTrue: 108311 [contents := f contentsOfEntireFile. 108312 brevityState := #fullFile. "don't change till actually read" 108313 ^ contents]. 108314 108315 "if brevityFlag is true, don't display long files when first selected" 108316 first5000 := f next: 5000. 108317 f close. 108318 contents := 'File ''{1}'' is {2} bytes long. 108319You may use the ''get'' command to read the entire file. 108320 108321Here are the first 5000 characters... 108322------------------------------------------ 108323{3} 108324------------------------------------------ 108325... end of the first 5000 characters.' translated format: {fileName. fileSize. first5000}. 108326 brevityState := #briefFile. "don't change till actually read" 108327 ^ contents. 108328! ! 108329 108330!FileList methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 01:28'! 108331readContentsCNGB 108332 | f stream | 108333 f := directory oldFileOrNoneNamed: self fullName. 108334 f ifNil: [^ 'For some reason, this file cannot be read']. 108335 stream := String new writeStream. 108336 f converter: CNGBTextConverter new. 108337 [f atEnd] 108338 whileFalse: [stream nextPut: f next]. 108339 f close. 108340 ^ stream contents! ! 108341 108342!FileList methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 01:28'! 108343readContentsEUCJP 108344 | f stream | 108345 f := directory oldFileOrNoneNamed: self fullName. 108346 f ifNil: [^ 'For some reason, this file cannot be read']. 108347 stream := String new writeStream. 108348 f converter: EUCJPTextConverter new. 108349 [f atEnd] 108350 whileFalse: [stream nextPut: f next]. 108351 f close. 108352 ^ stream contents! ! 108353 108354!FileList methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 01:29'! 108355readContentsEUCKR 108356 | f stream | 108357 f := directory oldFileOrNoneNamed: self fullName. 108358 f ifNil: [^ 'For some reason, this file cannot be read']. 108359 stream := String new writeStream. 108360 f converter: EUCKRTextConverter new. 108361 [f atEnd] 108362 whileFalse: [stream nextPut: f next]. 108363 f close. 108364 ^ stream contents! ! 108365 108366!FileList methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 01:30'! 108367readContentsHex: brevity 108368 "retrieve the contents from the external file unless it is too long. 108369 Don't create a file here. Check if exists." 108370 | f size data hexData s | 108371 108372 f := directory oldFileOrNoneNamed: self fullName. 108373 f == nil ifTrue: [^ 'For some reason, this file cannot be read' translated]. 108374 f binary. 108375 ((size := f size)) > 5000 & brevity 108376 ifTrue: [data := f next: 10000. f close. brevityState := #briefHex] 108377 ifFalse: [data := f contentsOfEntireFile. brevityState := #fullHex]. 108378 108379 s := (String new: data size*4) writeStream. 108380 0 to: data size-1 by: 16 do: 108381 [:loc | s nextPutAll: loc printStringHex; space; 108382 nextPut: $(; print: loc; nextPut: $); space; tab. 108383 loc+1 to: (loc+16 min: data size) do: [:i | s nextPutAll: (data at: i) printStringHex; space]. 108384 s cr]. 108385 hexData := s contents. 108386 108387 ^ contents := ((size > 5000) & brevity 108388 ifTrue: ['File ''{1}'' is {2} bytes long. 108389You may use the ''get'' command to read the entire file. 108390 108391Here are the first 5000 characters... 108392------------------------------------------ 108393{3} 108394------------------------------------------ 108395... end of the first 5000 characters.' translated format: {fileName. size. hexData}] 108396 ifFalse: [hexData]). 108397! ! 108398 108399!FileList methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 01:30'! 108400readContentsShiftJIS 108401 | f stream | 108402 f := directory oldFileOrNoneNamed: self fullName. 108403 f ifNil: [^ 'For some reason, this file cannot be read']. 108404 stream := String new writeStream. 108405 f converter: ShiftJISTextConverter new. 108406 [f atEnd] 108407 whileFalse: [stream nextPut: f next]. 108408 f close. 108409 ^ stream contents! ! 108410 108411!FileList methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 01:31'! 108412readContentsUTF8 108413 | f stream | 108414 f := directory oldFileOrNoneNamed: self fullName. 108415 f ifNil: [^ 'For some reason, this file cannot be read']. 108416 stream := String new writeStream. 108417 f converter: UTF8TextConverter new. 108418 [f atEnd] 108419 whileFalse: [stream nextPut: f next]. 108420 f close. 108421 ^ stream contents! ! 108422 108423!FileList methodsFor: 'private' stamp: 'alain.plantec 2/6/2009 16:55'! 108424recentDirs 108425 "Put up a menu and let the user select from the list of recently visited directories." 108426 108427 | dirName | 108428 RecentDirs isEmpty ifTrue: [^self]. 108429 dirName := UIManager default chooseFrom: RecentDirs values: RecentDirs. 108430 dirName ifNil: [^self]. 108431 self directory: (FileDirectory on: dirName)! ! 108432 108433!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 18:38'! 108434registeredFileReaderClasses 108435 "return the list of classes that provide file reader services" 108436 108437 ^ self class registeredFileReaderClasses! ! 108438 108439!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 18:50'! 108440resort: newMode 108441 "Re-sort the list of files." 108442 108443 | name | 108444 listIndex > 0 108445 ifTrue: [name := self fileNameFromFormattedItem: (list at: listIndex)]. 108446 sortMode := newMode. 108447 self pattern: pattern. 108448 name ifNotNil: [ 108449 fileName := name. 108450 listIndex := list findFirst: [:item | (self fileNameFromFormattedItem: item) = name. ]. 108451 self changed: #fileListIndex]. 108452 listIndex = 0 ifTrue: [self changed: #contents]. 108453 self updateButtonRow 108454! ! 108455 108456!FileList methodsFor: 'private' stamp: 'alain.plantec 2/8/2009 22:07'! 108457selectEncoding 108458 108459 | aMenu encodingItems | 108460 aMenu := CustomMenu new. 108461 encodingItems := OrderedCollection new. 108462 TextConverter allSubclasses do: [:each | | names | 108463 names := each encodingNames. 108464 names notEmpty ifTrue: [ | label | 108465 label := '' writeStream. 108466 names do: [:eachName | label nextPutAll: eachName ] separatedBy: [ label nextPutAll: ', ']. 108467 encodingItems add: {label contents. names first asSymbol}. 108468 ]. 108469 ]. 108470 aMenu addList: encodingItems. 108471 brevityState := aMenu startUp. 108472 brevityState ifNil: [brevityState := #needToGetBrief]. 108473! ! 108474 108475!FileList methodsFor: 'private' stamp: 'LC 1/6/2002 09:03'! 108476setSelectedDirectoryTo: aFileDirectoryWrapper 108477 currentDirectorySelected := aFileDirectoryWrapper. 108478 self directory: aFileDirectoryWrapper withoutListWrapper. 108479 brevityState := #FileList. 108480 "self addPath: path." 108481 self changed: #fileList. 108482 self changed: #contents. 108483 self changed: #currentDirectorySelected.! ! 108484 108485!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 18:26'! 108486sortBlock 108487 "Answer block to decide what order to display the directory entries." 108488 108489 ^ [ :x :y | 108490 (x isDirectory = y isDirectory) 108491 ifTrue: [ 108492 "sort by user-specified criterion" 108493 sortMode = #name 108494 ifTrue: [(x name compare: y name) <= 2] 108495 ifFalse: [ sortMode = #date 108496 ifTrue: [ x modificationTime = y modificationTime 108497 ifTrue: [ (x name compare: y name) <= 2 ] 108498 ifFalse: [ x modificationTime > y modificationTime ] ] 108499 ifFalse: [ "size" 108500 x fileSize = y fileSize 108501 ifTrue: [ (x name compare: y name) <= 2 ] 108502 ifFalse: [ x fileSize > y fileSize ] ] ] ] 108503 ifFalse: [ 108504 "directories always precede files" 108505 x isDirectory ] ]! ! 108506 108507!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 18:50'! 108508sortingByDate 108509 ^ sortMode == #date! ! 108510 108511!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 18:33'! 108512sortingByName 108513 ^ sortMode == #name! ! 108514 108515!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 19:33'! 108516sortingBySize 108517 ^ sortMode == #size! ! 108518 108519!FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 18:24'! 108520updateFileList 108521 "Update my files list with file names in the current directory 108522 that match the pattern. 108523 The pattern string may have embedded newlines or semicolons; these separate different patterns." 108524 | patterns | 108525 patterns := OrderedCollection new. 108526 Cursor wait showWhile: [ 108527 (pattern findTokens: (String with: Character cr with: Character lf with: $;)) 108528 do: [ :each | 108529 (each includes: $*) | (each includes: $#) 108530 ifTrue: [ patterns add: each] 108531 ifFalse: [each isEmpty 108532 ifTrue: [ patterns add: '*'] 108533 ifFalse: [ patterns add: '*' , each , '*']]]. 108534 108535 list := self listForPatterns: patterns. 108536 listIndex := 0. 108537 volListIndex := volList size. 108538 fileName := nil. 108539 contents := ''. 108540 self changed: #volumeListIndex. 108541 self changed: #fileList. 108542 self updateButtonRow]! ! 108543 108544"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 108545 108546FileList class 108547 instanceVariableNames: ''! 108548 108549!FileList class methodsFor: 'as yet unclassified' stamp: 'ar 10/10/2000 15:59'! 108550hideSqueakletDirectoryBlock 108551 ^[:dirName| (dirName sameAs: 'Squeaklets') not]! ! 108552 108553!FileList class methodsFor: 'as yet unclassified' stamp: 'stephane.ducasse 4/13/2009 21:04'! 108554projectOnlySelectionBlock 108555 108556 ^[ :entry :myPattern | 108557 entry isDirectory 108558 ifTrue: [false] 108559 ifFalse: [ #('*.pr' '*.pr.gz' '*.project') 108560 anySatisfy: [ :each | each match: entry name]]] ! ! 108561 108562!FileList class methodsFor: 'as yet unclassified' stamp: 'RAA 2/19/2001 06:57'! 108563projectOnlySelectionMethod: incomingEntries 108564 108565 | versionsAccepted basicInfoTuple basicName basicVersion | 108566 108567 "this shows only the latest version of each project" 108568 versionsAccepted := Dictionary new. 108569 incomingEntries do: [ :entry | 108570 entry isDirectory ifFalse: [ 108571 (#('*.pr' '*.pr.gz' '*.project') anySatisfy: [ :each | each match: entry name]) ifTrue: [ 108572 basicInfoTuple := Project parseProjectFileName: entry name. 108573 basicName := basicInfoTuple first. 108574 basicVersion := basicInfoTuple second. 108575 ((versionsAccepted includesKey: basicName) and: 108576 [(versionsAccepted at: basicName) first > basicVersion]) ifFalse: [ 108577 versionsAccepted at: basicName put: {basicVersion. entry} 108578 ]. 108579 ] 108580 ] 108581 ]. 108582 ^versionsAccepted asArray collect: [ :each | each second]! ! 108583 108584!FileList class methodsFor: 'as yet unclassified' stamp: 'stephane.ducasse 4/13/2009 21:04'! 108585selectionBlockForSuffixes: anArray 108586 108587 ^[ :entry :myPattern | 108588 entry isDirectory 108589 ifTrue: [false] 108590 ifFalse: [anArray anySatisfy: [ :each | each match: entry name]]] ! ! 108591 108592 108593!FileList class methodsFor: 'blue ui' stamp: 'dgd 11/3/2004 20:09'! 108594blueButtonText: aString textColor: textColor color: aColor inWindow: window 108595 | result | 108596 result := window 108597 fancyText: aString translated 108598 font: Preferences standardEToysFont 108599 color: textColor. 108600 result setProperty: #buttonText toValue: aString; 108601 hResizing: #rigid; 108602 extent: 100 @ 20; 108603 layoutInset: 4; 108604 borderWidth: ColorTheme current dialogButtonBorderWidth; 108605 useRoundedCorners. 108606 aColor isNil 108607 ifFalse: [""result color: aColor. result borderColor: aColor muchDarker]. 108608 ^ result! ! 108609 108610!FileList class methodsFor: 'blue ui' stamp: 'dgd 11/3/2004 20:13'! 108611blueButtonText: aString textColor: textColor color: aColor inWindow: window balloonText: balloonText selector: sel recipient: recip 108612 | result | 108613 result := window 108614 fancyText: aString translated 108615font: Preferences standardEToysFont 108616 color: textColor. 108617 result setProperty: #buttonText toValue: aString; 108618 hResizing: #rigid; 108619 extent: 100 @ 20; 108620 layoutInset: 4; 108621 borderWidth: ColorTheme current dialogButtonBorderWidth; 108622 useRoundedCorners; 108623 setBalloonText: balloonText. 108624 result 108625 on: #mouseUp 108626 send: sel 108627 to: recip. 108628 aColor isNil 108629 ifFalse: ["" 108630 result color: aColor. 108631 result borderColor: aColor muchDarker]. 108632 ^ result! ! 108633 108634!FileList class methodsFor: 'blue ui' stamp: 'dgd 11/2/2004 21:43'! 108635blueButtonText: aString textColor: textColor inWindow: window 108636 ^ self 108637 blueButtonText: aString 108638 textColor: textColor 108639 color: nil 108640 inWindow: window! ! 108641 108642!FileList class methodsFor: 'blue ui' stamp: 'dgd 11/3/2004 20:04'! 108643blueButtonText: aString textColor: textColor inWindow: window balloonText: balloonText selector: sel recipient: recip 108644 ^ self 108645 blueButtonText: aString 108646 textColor: textColor 108647 color: nil 108648 inWindow: window 108649 balloonText: balloonText 108650 selector: sel 108651 recipient: recip ! ! 108652 108653!FileList class methodsFor: 'blue ui' stamp: 'nk 7/16/2003 17:13'! 108654enableTypeButtons: typeButtons info: fileTypeInfo forDir: aDirectory 108655 108656 | foundSuffixes fileSuffixes firstEnabled enableIt | 108657 108658 firstEnabled := nil. 108659 foundSuffixes := (aDirectory ifNil: [ #()] ifNotNil: [ aDirectory fileNames]) collect: [ :each | (each findTokens: '.') last asLowercase]. 108660 foundSuffixes := foundSuffixes asSet. 108661 fileTypeInfo with: typeButtons do: [ :info :button | 108662 fileSuffixes := info second. 108663 enableIt := fileSuffixes anySatisfy: [ :patt | foundSuffixes includes: patt]. 108664 button 108665 setProperty: #enabled 108666 toValue: enableIt. 108667 enableIt ifTrue: [firstEnabled ifNil: [firstEnabled := button]]. 108668 ]. 108669 firstEnabled ifNotNil: [^firstEnabled mouseUp: nil]. 108670 typeButtons do: [ :each | each color: Color gray]. 108671 108672! ! 108673 108674!FileList class methodsFor: 'blue ui' stamp: 'dgd 4/3/2006 14:02'! 108675endingSpecs 108676 "Answer a collection of specs to build the selective 'find anything' tool called by the Navigator. This version uses the services registry to do so." 108677 "FileList2 morphicViewGeneralLoaderInWorld: World" 108678 | categories services specs rejects | 108679 rejects := #(addFileToNewZip: compressFile: openInZipViewer: extractAllFrom: openOn:). 108680 categories := #( 108681 ('Art' ('bmp' 'gif' 'jpg' 'jpeg' 'form' 'png' 'pcx' 'xbm' 'xpm' 'ppm' 'pbm')) 108682 ('Morphs' ('morph' 'morphs' 'sp')) 108683 ('Projects' ('extseg' 'project' 'pr')) 108684 ('MIDI' ('mid' 'midi')) 108685 ('Music' ('mp3')) 108686 ('Movies' ('movie' 'mpg' 'mpeg' 'qt' 'mov')) 108687 ('Flash' ('swf')) 108688 ). 108689 108690 "('Books' ('bo'))" 108691 "('Code' ('st' 'cs'))" 108692 "('TrueType' ('ttf'))" 108693 "('3ds' ('3ds'))" 108694 "('Tape' ('tape'))" 108695 "('Wonderland' ('wrl'))" 108696 "('HTML' ('htm' 'html'))" 108697 108698 categories first at: 2 put: ImageReadWriter allTypicalFileExtensions. 108699 specs := OrderedCollection new. 108700 categories do: [ :cat | | catSpecs catServices okExtensions | 108701 services := Dictionary new. 108702 catSpecs := Array new: 3. 108703 catServices := OrderedCollection new. 108704 okExtensions := Set new. 108705 108706 cat second do: [ :ext | (FileList itemsForFile: 'fred.',ext) do: [ :i | 108707 (rejects includes: i selector) ifFalse: [ 108708 okExtensions add: ext. 108709 services at: i label put: i ]]]. 108710 services do: [ :svc | catServices add: svc ]. 108711 services isEmpty ifFalse: [ 108712 catSpecs at: 1 put: cat first; 108713 at: 2 put: okExtensions; 108714 at: 3 put: catServices. 108715 specs add: catSpecs ] 108716 ]. 108717 ^specs 108718! ! 108719 108720!FileList class methodsFor: 'blue ui' stamp: 'stephane.ducasse 4/13/2009 21:03'! 108721morphicViewGeneralLoaderInWorld: aWorld 108722" 108723FileList morphicViewGeneralLoaderInWorld: self currentWorld 108724" 108725 | window aFileList buttons treePane textColor1 fileListPane pane2a pane2b fileTypeInfo fileTypeButtons fileTypeRow actionRow | 108726 108727 fileTypeInfo := self endingSpecs. 108728 window := AlignmentMorph newColumn. 108729 window hResizing: #shrinkWrap; vResizing: #shrinkWrap. 108730 textColor1 := Color r: 0.742 g: 0.839 b: 1.0. 108731 aFileList := self new directory: FileDirectory default. 108732 aFileList 108733 fileSelectionBlock: self projectOnlySelectionBlock; 108734 modalView: window. 108735 window 108736 setProperty: #FileList toValue: aFileList; 108737 wrapCentering: #center; cellPositioning: #topCenter; 108738 borderWidth: ColorTheme current dialogBorderWidth; 108739 borderColor: ColorTheme current dialogBorderColor; 108740 useRoundedCorners. 108741 108742 fileTypeButtons := fileTypeInfo collect: [ :each | 108743 (self blueButtonText: each first textColor: Color gray inWindow: window) 108744 setProperty: #enabled toValue: true; 108745 hResizing: #shrinkWrap; 108746 useSquareCorners 108747 ]. 108748 buttons := {{'OK'. ColorTheme current okColor}. {'Cancel'. ColorTheme current cancelColor}} collect: [ :each | 108749 self blueButtonText: each first textColor: textColor1 color: each second inWindow: window 108750 ]. 108751 108752 treePane := aFileList morphicDirectoryTreePane 108753 extent: 250@300; 108754 retractable: false; 108755 borderWidth: 0. 108756 fileListPane := aFileList morphicFileListPane 108757 extent: 350@300; 108758 retractable: false; 108759 borderWidth: 0. 108760 window addARow: {window fancyText: 'Find...' translated font: Preferences standardEToysTitleFont color: textColor1}. 108761 fileTypeRow := window addARowCentered: fileTypeButtons cellInset: 2. 108762 actionRow := window addARowCentered: { 108763 buttons first. 108764 (Morph new extent: 30@5) color: Color transparent. 108765 buttons second 108766 } cellInset: 2. 108767 window 108768 addARow: { 108769 (window inAColumn: {(pane2a := window inARow: {window inAColumn: {treePane}}) 108770 useRoundedCorners; 108771 layoutInset: 0; 108772 borderWidth: ColorTheme current dialogPaneBorderWidth; 108773 borderColor: ColorTheme current dialogPaneBorderColor 108774 }) layoutInset: 10. 108775 (window inAColumn: {(pane2b := window inARow: {window inAColumn: {fileListPane}}) 108776 useRoundedCorners; 108777 layoutInset: 0; 108778 borderWidth: ColorTheme current dialogPaneBorderWidth; 108779 borderColor: ColorTheme current dialogPaneBorderColor 108780 }) layoutInset: 10. 108781 }. 108782 window fullBounds. 108783 window fillWithRamp: ColorTheme current dialogRampOrColor oriented: 0.65. 108784 pane2a fillWithRamp: ColorTheme current dialogPaneRampOrColor oriented: (0.7 @ 0.35). 108785 pane2b fillWithRamp: ColorTheme current dialogPaneRampOrColor oriented: (0.7 @ 0.35). 108786" 108787 buttons do: [ :each | 108788 each fillWithRamp: ColorTheme current dialogButtonsRampOrColor oriented: (0.75 @ 0). 108789 ]. 108790" 108791 fileTypeButtons do: [ :each | 108792 each 108793 on: #mouseUp 108794 send: #value:value: 108795 to: [ :evt :morph | 108796 self update: actionRow in: window 108797 fileTypeRow: fileTypeRow morphUp: morph]]. 108798 buttons first on: #mouseUp send: #okHit to: aFileList. 108799 buttons second on: #mouseUp send: #cancelHit to: aFileList. 108800 aFileList postOpen. 108801 window position: aWorld topLeft + (aWorld extent - window extent // 2). 108802 aFileList directoryChangeBlock: [ :newDir | 108803 self update: actionRow in: window 108804 fileTypeRow: fileTypeRow morphUp: nil. 108805 self enableTypeButtons: fileTypeButtons 108806 info: fileTypeInfo forDir: newDir]. 108807 aFileList directory: aFileList directory. 108808 window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0). 108809 window becomeModal. 108810 ^ window openInWorld: aWorld.! ! 108811 108812 108813!FileList class methodsFor: 'file reader registration' stamp: 'hfm 11/29/2008 19:35'! 108814allRegisteredServices 108815 "self allRegisteredServices" 108816 108817 | col | 108818 col := OrderedCollection new. 108819 self registeredFileReaderClasses do: [:each | col addAll: (each services)]. 108820 ^ col! ! 108821 108822!FileList class methodsFor: 'file reader registration' stamp: 'hfm 11/29/2008 19:36'! 108823detectService: aBlock ifNone: anotherBlock 108824 "self detectService: [:each | each selector = #fileIn:] ifNone: [nil]" 108825 108826 ^ self allRegisteredServices 108827 detect: aBlock 108828 ifNone: anotherBlock! ! 108829 108830!FileList class methodsFor: 'file reader registration' stamp: 'hfm 11/29/2008 19:36'! 108831isReaderNamedRegistered: aSymbol 108832 "return if a given reader class has been registered. Note that this is on purpose that the argument is 108833 a symbol and not a class" 108834 108835 ^ (self registeredFileReaderClasses collect: [:each | each name]) includes: aSymbol 108836! ! 108837 108838!FileList class methodsFor: 'file reader registration' stamp: 'hfm 11/29/2008 19:39'! 108839unregisterFileReader: aProviderClass 108840 "unregister the given class as providing services for reading files" 108841 108842 self registeredFileReaderClasses remove: aProviderClass ifAbsent: [nil]! ! 108843 108844 108845!FileList class methodsFor: 'initialization' stamp: 'hfm 11/29/2008 19:06'! 108846initialize 108847 "FileList2 initialize" 108848 108849 RecentDirs := OrderedCollection new. 108850 (self systemNavigation allClassesImplementing: #fileReaderServicesForFile:suffix:) do: [:providerMetaclass | 108851 self registerFileReader: providerMetaclass soleInstance]! ! 108852 108853!FileList class methodsFor: 'initialization' stamp: 'hfm 11/29/2008 19:38'! 108854removeObsolete 108855 "FileList removeObsolete" 108856 self registeredFileReaderClasses copy 108857 do:[:cls| cls isObsolete ifTrue:[self unregisterFileReader: cls]]! ! 108858 108859!FileList class methodsFor: 'initialization' stamp: 'hfm 11/29/2008 19:38'! 108860unload 108861 "Unload the receiver from global registries" 108862 108863 self environment at: #Flaps ifPresent: [:cl | 108864 cl unregisterQuadsWithReceiver: self] ! ! 108865 108866 108867!FileList class methodsFor: 'instance creation' stamp: 'hfm 11/29/2008 19:35'! 108868addButtonsAndFileListPanesTo: window at: upperFraction plus: offset forFileList: aFileList 108869 | fileListMorph row buttonHeight fileListTop divider dividerDelta buttons | 108870 fileListMorph := PluggableListMorph 108871 on: aFileList 108872 list: #fileList 108873 selected: #fileListIndex 108874 changeSelected: #fileListIndex: 108875 menu: #fileListMenu:. 108876 fileListMorph enableDrag: true; enableDrop: false. 108877 aFileList wantsOptionalButtons 108878 ifTrue: [buttons := aFileList optionalButtonRow. 108879 divider := BorderedSubpaneDividerMorph forBottomEdge. 108880 dividerDelta := 0. 108881 buttons color: Color transparent. 108882 buttons 108883 submorphsDo: [:m | m borderWidth: 2; 108884 borderColor: #raised]. 108885divider extent: 4 @ 4; 108886 color: Color transparent; 108887 borderColor: #raised; 108888 borderWidth: 2. 108889 fileListMorph borderColor: Color transparent. 108890 dividerDelta := 3. 108891 row := AlignmentMorph newColumn hResizing: #spaceFill; 108892 vResizing: #spaceFill; 108893 layoutInset: 0; 108894 borderWidth: 2; 108895 layoutPolicy: ProportionalLayout new. 108896 buttonHeight := self defaultButtonPaneHeight. 108897 row 108898 addMorph: buttons 108899 fullFrame: (LayoutFrame 108900 fractions: (0 @ 0 corner: 1 @ 0) 108901 offsets: (0 @ 0 corner: 0 @ buttonHeight)). 108902 row 108903 addMorph: divider 108904 fullFrame: (LayoutFrame 108905 fractions: (0 @ 0 corner: 1 @ 0) 108906 offsets: (0 @ buttonHeight corner: 0 @ buttonHeight + dividerDelta)). 108907 row 108908 addMorph: fileListMorph 108909 fullFrame: (LayoutFrame 108910 fractions: (0 @ 0 corner: 1 @ 1) 108911 offsets: (0 @ buttonHeight + dividerDelta corner: 0 @ 0)). 108912 window 108913 addMorph: row 108914 fullFrame: (LayoutFrame 108915 fractions: upperFraction 108916 offsets: (0 @ offset corner: 0 @ 0)). 108917 row borderWidth: 2] 108918 ifFalse: [fileListTop := 0. 108919 window 108920 addMorph: fileListMorph 108921 frame: (0.3 @ fileListTop corner: 1 @ 0.3)].! ! 108922 108923!FileList class methodsFor: 'instance creation' stamp: 'md 2/24/2006 15:59'! 108924addVolumesAndPatternPanesTo: window at: upperFraction plus: offset forFileList: aFileList 108925 | row patternHeight volumeListMorph patternMorph divider dividerDelta | 108926 row := AlignmentMorph newColumn hResizing: #spaceFill; 108927 vResizing: #spaceFill; 108928 layoutInset: 0; 108929 borderWidth: 0; 108930 layoutPolicy: ProportionalLayout new. 108931 patternHeight := 25. 108932 volumeListMorph := (PluggableListMorph 108933 on: aFileList 108934 list: #volumeList 108935 selected: #volumeListIndex 108936 changeSelected: #volumeListIndex: 108937 menu: #volumeMenu:) 108938 autoDeselect: false. 108939 volumeListMorph enableDrag: false; enableDrop: true. 108940 patternMorph := PluggableTextMorph 108941 on: aFileList 108942 text: #pattern 108943 accept: #pattern:. 108944 patternMorph acceptOnCR: true. 108945 patternMorph hideScrollBarsIndefinitely. 108946 divider := BorderedSubpaneDividerMorph horizontal. 108947 dividerDelta := 0. 108948 divider extent: 4 @ 4; 108949 color: Color transparent; 108950 borderColor: #raised; 108951 borderWidth: 2. 108952 volumeListMorph borderColor: Color transparent. 108953 patternMorph borderColor: Color transparent. 108954 dividerDelta := 3. 108955 row 108956 addMorph: (volumeListMorph autoDeselect: false) 108957 fullFrame: (LayoutFrame 108958 fractions: (0 @ 0 corner: 1 @ 1) 108959 offsets: (0 @ 0 corner: 0 @ patternHeight negated - dividerDelta)). 108960 row 108961 addMorph: divider 108962 fullFrame: (LayoutFrame 108963 fractions: (0 @ 1 corner: 1 @ 1) 108964 offsets: (0 @ patternHeight negated - dividerDelta corner: 0 @ patternHeight negated)). 108965 row 108966 addMorph: patternMorph 108967 fullFrame: (LayoutFrame 108968 fractions: (0 @ 1 corner: 1 @ 1) 108969 offsets: (0 @ patternHeight negated corner: 0 @ 0)). 108970 window 108971 addMorph: row 108972 fullFrame: (LayoutFrame 108973 fractions: upperFraction 108974 offsets: (0 @ offset corner: 0 @ 0)). 108975 row borderWidth: 2! ! 108976 108977!FileList class methodsFor: 'instance creation' stamp: 'hfm 11/29/2008 19:36'! 108978defaultButtonPaneHeight 108979 "Answer the user's preferred default height for new button panes." 108980 108981 ^ Preferences 108982 parameterAt: #defaultButtonPaneHeight 108983 ifAbsentPut: [25]! ! 108984 108985!FileList class methodsFor: 'instance creation' stamp: 'hfm 11/29/2008 19:36'! 108986open 108987 "Open a view of an instance of me on the default directory." 108988 "FileList open openInWorld" 108989 ^ self openAsMorph! ! 108990 108991!FileList class methodsFor: 'instance creation' stamp: 'hfm 11/29/2008 19:37'! 108992openAsMorph 108993 "Open a morphic view of a FileList on the default directory." 108994 | dir aFileList window upperFraction offset | 108995 dir := FileDirectory default. 108996 aFileList := self new directory: dir. 108997 window := (SystemWindow labelled: dir pathName) 108998 model: aFileList. 108999 upperFraction := 0.3. 109000 offset := 0. 109001 self 109002 addVolumesAndPatternPanesTo: window 109003 at: (0 @ 0 corner: 0.3 @ upperFraction) 109004 plus: offset 109005 forFileList: aFileList. 109006 self 109007 addButtonsAndFileListPanesTo: window 109008 at: (0.3 @ 0 corner: 1.0 @ upperFraction) 109009 plus: offset 109010 forFileList: aFileList. 109011 window 109012 addMorph: (PluggableTextMorph 109013 on: aFileList 109014 text: #contents 109015 accept: #put: 109016 readSelection: #contentsSelection 109017 menu: #fileContentsMenu:shifted:) 109018 frame: (0 @ 0.3 corner: 1 @ 1). 109019 ^ window! ! 109020 109021!FileList class methodsFor: 'instance creation' stamp: 'hfm 11/29/2008 19:37'! 109022openEditorOn: aFileStream editString: editString 109023 "Open an editor on the given FileStream." 109024 ^ (self openMorphOn: aFileStream editString: editString) openInWorld! ! 109025 109026!FileList class methodsFor: 'instance creation' stamp: 'hfm 11/29/2008 19:37'! 109027openFileDirectly 109028 109029 | aResult | 109030 (aResult := StandardFileMenu oldFile) ifNotNil: 109031 [self openEditorOn: (aResult directory readOnlyFileNamed: aResult name) editString: nil]! ! 109032 109033!FileList class methodsFor: 'instance creation' stamp: 'hfm 11/29/2008 19:37'! 109034openMorphOn: aFileStream editString: editString 109035 "Open a morphic view of a FileList on the given file." 109036 | fileModel window fileContentsView | 109037 109038 fileModel := FileList new setFileStream: aFileStream. "closes the stream" 109039 window := (SystemWindow labelled: aFileStream fullName) model: fileModel. 109040 109041 window addMorph: (fileContentsView := PluggableTextMorph on: fileModel 109042 text: #contents accept: #put: 109043 readSelection: #contentsSelection 109044 menu: #fileContentsMenu:shifted:) 109045 frame: (0@0 corner: 1@1). 109046 editString ifNotNil: [fileContentsView editString: editString. 109047 fileContentsView hasUnacceptedEdits: true]. 109048 109049 ^ window! ! 109050 109051!FileList class methodsFor: 'instance creation' stamp: 'nk 7/12/2000 11:03'! 109052openMorphicViewInWorld 109053 "FileList2 openMorphicViewInWorld" 109054 ^self morphicView openInWorld! ! 109055 109056!FileList class methodsFor: 'instance creation' stamp: 'nk 6/14/2004 08:41'! 109057prototypicalToolWindow 109058 "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" 109059 109060 ^ self morphicView applyModelExtent! ! 109061 109062!FileList class methodsFor: 'instance creation' stamp: 'hfm 11/29/2008 19:04'! 109063registerFileReader: aProviderClass 109064 "register the given class as providing services for reading files" 109065 109066 | registeredReaders | 109067 registeredReaders := self registeredFileReaderClasses. 109068 (registeredReaders includes: aProviderClass) 109069 ifFalse: [ registeredReaders addLast: aProviderClass ]! ! 109070 109071!FileList class methodsFor: 'instance creation' stamp: 'hfm 11/29/2008 19:38'! 109072registerInFlapsRegistry 109073 "Register the receiver in the system's flaps registry" 109074 self environment 109075 at: #Flaps 109076 ifPresent: [:cl | cl registerQuad: #(FileList prototypicalToolWindow 'File List' 'A File List is a tool for browsing folders and files on disks and on ftp types.') 109077 forFlapNamed: 'Tools']! ! 109078 109079 109080!FileList class methodsFor: 'modal dialogs' stamp: 'miki 8/15/2005 18:35'! 109081modalFileSelector 109082 109083 | window | 109084 109085 window := self morphicViewFileSelector. 109086 window openCenteredInWorld. 109087 self modalLoopOn: window. 109088 ^(window valueOfProperty: #fileListModel) getSelectedFile! ! 109089 109090!FileList class methodsFor: 'modal dialogs' stamp: 'miki 8/15/2005 18:34'! 109091modalFileSelectorForSuffixes: aList 109092 109093 | window aFileList | 109094 109095 window := self morphicViewFileSelectorForSuffixes: aList. 109096 aFileList := window valueOfProperty: #fileListModel. 109097 window openCenteredInWorld. 109098 self modalLoopOn: window. 109099 ^aFileList getSelectedFile! ! 109100 109101!FileList class methodsFor: 'modal dialogs' stamp: 'miki 8/15/2005 18:34'! 109102modalFileSelectorForSuffixes: aList directory: aDirectory 109103 109104 | window aFileList | 109105 109106 window := self morphicViewFileSelectorForSuffixes: aList directory: aDirectory. 109107 aFileList := window valueOfProperty: #fileListModel. 109108 window openCenteredInWorld. 109109 self modalLoopOn: window. 109110 ^aFileList getSelectedFile! ! 109111 109112!FileList class methodsFor: 'modal dialogs' stamp: 'gh 9/16/2002 10:33'! 109113modalFolderSelector 109114 109115 ^self modalFolderSelector: FileDirectory default! ! 109116 109117!FileList class methodsFor: 'modal dialogs' stamp: 'miki 8/15/2005 18:33'! 109118modalFolderSelector: aDir 109119 109120 | window fileModel | 109121 window := self morphicViewFolderSelector: aDir. 109122 fileModel := window model. 109123 window openInWorld: self currentWorld extent: 300@400. 109124 self modalLoopOn: window. 109125 ^fileModel getSelectedDirectory withoutListWrapper! ! 109126 109127 109128!FileList class methodsFor: 'morphic ui' stamp: 'btr 1/30/2004 00:56'! 109129morphicView 109130 ^ self morphicViewOnDirectory: FileDirectory default! ! 109131 109132!FileList class methodsFor: 'morphic ui' stamp: 'RAA 3/6/2001 12:47'! 109133morphicViewFileSelector 109134 109135 ^self morphicViewFileSelectorForSuffixes: nil 109136! ! 109137 109138!FileList class methodsFor: 'morphic ui' stamp: 'miki 8/14/2005 21:21'! 109139morphicViewFileSelectorForSuffixes: aList 109140 "Answer a morphic file-selector tool for the given suffix list." 109141 109142 ^self 109143 morphicViewFileSelectorForSuffixes: aList 109144 directory: FileDirectory default.! ! 109145 109146!FileList class methodsFor: 'morphic ui' stamp: 'stephane.ducasse 4/13/2009 21:06'! 109147morphicViewFileSelectorForSuffixes: aList directory: dir 109148 "Answer a morphic file-selector tool for the given suffix list and the given directory." 109149 109150 | aFileList window fixedSize midLine gap | 109151 aFileList := self new directory: dir. 109152 aFileList optionalButtonSpecs: aFileList okayAndCancelServices. 109153 aList ifNotNil: 109154 [aFileList fileSelectionBlock: [:entry :myPattern | 109155 entry isDirectory 109156 ifTrue: 109157 [false] 109158 ifFalse: 109159 [aList includes: (FileDirectory extensionFor: entry name asLowercase)]]]. 109160 window := BorderedMorph new 109161 layoutPolicy: ProportionalLayout new; 109162 color: Color lightBlue; 109163 borderColor: Color blue; 109164 borderWidth: 4; 109165 layoutInset: 4; 109166 extent: 600@400; 109167 useRoundedCorners. 109168 window setProperty: #fileListModel toValue: aFileList. 109169 aFileList modalView: window. 109170 midLine := 0.4. 109171 fixedSize := 25. 109172 gap := 5. 109173 self addFullPanesTo: window from: { 109174 {self textRow: 'Please select a file'. 0 @ 0 corner: 1 @ 0. 0@0 corner: 0@fixedSize}. 109175 {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 0@fixedSize corner: 0@(fixedSize * 2)}. 109176 {aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. 109177 gap @(fixedSize * 2) corner: gap negated@0}. 109178 {aFileList morphicFileListPane. midLine @ 0 corner: 1@1. 109179 gap@(fixedSize * 2) corner: gap negated@0}. 109180 }. 109181 109182 aFileList postOpen. 109183 109184 ^ window ! ! 109185 109186!FileList class methodsFor: 'morphic ui' stamp: 'gh 9/16/2002 10:30'! 109187morphicViewFolderSelector 109188 109189 ^self morphicViewFolderSelector: FileDirectory default! ! 109190 109191!FileList class methodsFor: 'morphic ui' stamp: 'bkv 11/12/2002 16:55'! 109192morphicViewFolderSelector: aDir 109193 "Answer a tool that allows the user to select a folder" 109194 109195 | aFileList window fixedSize | 109196 aFileList := self new directory: aDir. 109197 aFileList optionalButtonSpecs: aFileList servicesForFolderSelector. 109198 window := (SystemWindow labelled: aDir pathName) model: aFileList. 109199 aFileList modalView: window. 109200 109201 fixedSize := 25. 109202 self addFullPanesTo: window from: { 109203 {self textRow: 'Please select a folder'. 0 @ 0 corner: 1 @ 0. 109204 0@0 corner: 0@fixedSize}. 109205 {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 109206 0@fixedSize corner: 0@(fixedSize * 2)}. 109207 {aFileList morphicDirectoryTreePane. 0@0 corner: 1@1. 109208 0@(fixedSize * 2) corner: 0@0}. 109209 }. 109210 aFileList postOpen. 109211 ^ window ! ! 109212 109213!FileList class methodsFor: 'morphic ui' stamp: 'stephane.ducasse 4/13/2009 21:07'! 109214morphicViewImageViewer 109215 109216 | dir aFileList window midLine fixedSize | 109217 109218 dir := FileDirectory default. 109219 aFileList := self new directory: dir. 109220 aFileList optionalButtonSpecs: aFileList specsForImageViewer. 109221 aFileList fileSelectionBlock: [ :entry :myPattern | 109222 entry isDirectory 109223 ifTrue: [false] 109224 ifFalse: [ 109225 #('bmp' 'gif' 'jpg' 'form' 'png') includes: 109226 (FileDirectory extensionFor: entry name asLowercase)]]. 109227 window := (SystemWindow labelled: dir pathName) model: aFileList. 109228 109229 fixedSize := 25. 109230 midLine := 0.4. 109231 self addFullPanesTo: window from: { 109232 {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 109233 0@0 corner: 0@fixedSize}. 109234 {aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. 109235 0@fixedSize corner: 0@0}. 109236 {aFileList morphicFileListPane. midLine @ 0 corner: 1@1. 109237 0@fixedSize corner: 0@0}. 109238 }. 109239 aFileList postOpen. 109240 ^ window ! ! 109241 109242!FileList class methodsFor: 'morphic ui' stamp: 'RAA 1/8/2001 21:39'! 109243morphicViewNoFile 109244 109245 | dir aFileList window midLine fixedSize | 109246 109247 dir := FileDirectory default. 109248 aFileList := self new directory: dir. 109249 window := (SystemWindow labelled: dir pathName) model: aFileList. 109250 109251 fixedSize := 25. 109252 midLine := 0.4. 109253 self addFullPanesTo: window from: { 109254 {aFileList morphicPatternPane. 0@0 corner: 0.3@0. 0@0 corner: 0@fixedSize}. 109255 {aFileList optionalButtonRow. 0.3 @ 0 corner: 1@0. 0@0 corner: 0@fixedSize}. 109256 {aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. 0@fixedSize corner: 0@0}. 109257 {aFileList morphicFileListPane. midLine @ 0 corner: 1@1. 0@fixedSize corner: 0@0}. 109258 }. 109259 aFileList postOpen. 109260 ^ window ! ! 109261 109262!FileList class methodsFor: 'morphic ui' stamp: 'gk 5/5/2006 02:05'! 109263morphicViewOnDirectory: aFileDirectory 109264 | aFileList window fileListBottom midLine fileListTopOffset buttonPane | 109265 109266 aFileList := self new directory: aFileDirectory. 109267 window := (SystemWindow labelled: aFileDirectory pathName) model: aFileList. 109268 109269 fileListTopOffset := (TextStyle defaultFont pointSize * 2) + 14. 109270 fileListBottom := 0.4. 109271 midLine := 0.4. 109272 buttonPane := aFileList optionalButtonRow addMorph: 109273 (aFileList morphicPatternPane vResizing: #spaceFill; yourself). 109274 self addFullPanesTo: window from: { 109275 {buttonPane. 0@0 corner: 1@0. 0@0 corner: 0@fileListTopOffset}. 109276 {aFileList morphicDirectoryTreePane. 0@0 corner: midLine@fileListBottom. 109277 0@fileListTopOffset corner: 0@0}. 109278 {aFileList morphicFileListPane. midLine @ 0 corner: 1@fileListBottom. 109279 0@fileListTopOffset corner: 0@0}. 109280 {aFileList morphicFileContentsPane. 0@fileListBottom corner: 1@1. nil}. 109281 }. 109282 aFileList postOpen. 109283 ^ window ! ! 109284 109285!FileList class methodsFor: 'morphic ui' stamp: 'sw 2/22/2002 02:02'! 109286morphicViewProjectLoader 109287 109288 | dir aFileList window midLine fixedSize | 109289 109290 dir := FileDirectory default. 109291 aFileList := self new directory: dir. 109292 aFileList optionalButtonSpecs: aFileList servicesForProjectLoader. 109293 aFileList fileSelectionBlock: self projectOnlySelectionBlock. 109294 window := (SystemWindow labelled: dir pathName) model: aFileList. 109295 109296 fixedSize := 25. 109297 midLine := 0.4. 109298 self addFullPanesTo: window from: { 109299 {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 0@0 corner: 0@fixedSize}. 109300 {aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. 0@fixedSize corner: 0@0}. 109301 {aFileList morphicFileListPane. midLine @ 0 corner: 1@1. 0@fixedSize corner: 0@0}. 109302 }. 109303 aFileList postOpen. 109304 ^ window ! ! 109305 109306!FileList class methodsFor: 'morphic ui' stamp: 'dgd 4/3/2006 14:04'! 109307update: actionRow in: window fileTypeRow: fileTypeRow morphUp: morph 109308 109309 | fileTypeInfo info2 buttons textColor1 fileSuffixes fileActions aFileList fileTypeString | 109310 109311 (morph notNil and:[(morph valueOfProperty: #enabled) not]) ifTrue: [^self]. 109312 fileTypeRow submorphsDo: [ :sub | 109313 sub color: ( 109314 sub == morph 109315 ifTrue: [Color white] 109316 ifFalse: [(sub valueOfProperty: #enabled) 109317 ifTrue: [Color transparent] ifFalse: [Color gray]] 109318 ). 109319 ]. 109320 fileTypeString := morph isNil ifTrue:['xxxx'] ifFalse:[morph valueOfProperty: #buttonText]. 109321 109322 aFileList := window valueOfProperty: #FileList. 109323 textColor1 := Color r: 0.742 g: 0.839 b: 1.0. 109324 actionRow removeAllMorphs. 109325 fileTypeInfo := self endingSpecs. 109326 info2 := fileTypeInfo detect: [ :each | each first = fileTypeString] ifNone: [ nil ]. 109327 info2 isNil 109328 ifTrue:[ 109329 buttons := OrderedCollection new 109330 ] 109331 ifFalse:[ 109332 fileSuffixes := info2 second. 109333 fileActions := info2 third. 109334 buttons := fileActions collect: [ :each | aFileList blueButtonForService: each textColor: textColor1 inWindow: window ]. 109335 buttons do: [ :each | 109336 each fillWithRamp: ColorTheme current okColor oriented: (0.75 @ 0). 109337 ]. 109338 ]. 109339 buttons addLast: (self 109340 blueButtonText: 'Cancel' 109341 textColor: textColor1 109342 color: ColorTheme current cancelColor 109343 inWindow: window 109344 balloonText: 'Cancel this search' selector: #cancelHit recipient: aFileList). 109345 buttons do: [ :each | actionRow addMorphBack: each]. 109346 window fullBounds. 109347 fileSuffixes isNil ifFalse:[ 109348 aFileList fileSelectionBlock: ( 109349 self selectionBlockForSuffixes: (fileSuffixes collect: [ :each | '*.',each]) 109350 ). 109351 ]. 109352 aFileList updateFileList.! ! 109353 109354 109355!FileList class methodsFor: 'utility' stamp: 'RAA 1/8/2001 21:23'! 109356addFullPanesTo: window from: aCollection 109357 109358 | frame | 109359 109360 aCollection do: [ :each | 109361 frame := LayoutFrame 109362 fractions: each second 109363 offsets: each third. 109364 window addMorph: each first fullFrame: frame. 109365 ]! ! 109366 109367!FileList class methodsFor: 'utility' stamp: 'hfm 11/29/2008 18:58'! 109368itemsForDirectory: aFileDirectory 109369 "Answer a list of services appropriate when no file is selected." 109370 109371 | services | 109372 services := OrderedCollection new. 109373 self registeredFileReaderClasses do: [:reader | 109374 reader ifNotNil: [services addAll: (reader fileReaderServicesForDirectory: aFileDirectory) ]]. 109375 ^ services! ! 109376 109377!FileList class methodsFor: 'utility' stamp: 'hfm 11/29/2008 18:35'! 109378itemsForFile: fullName 109379 "Answer a list of services appropriate for a file of the given full name" 109380 109381 | services suffix | 109382 suffix := self suffixOf: fullName. 109383 services := OrderedCollection new. 109384 self registeredFileReaderClasses do: [:reader | 109385 reader ifNotNil: [services addAll: (reader fileReaderServicesForFile: fullName suffix: suffix)]]. 109386 ^ services! ! 109387 109388!FileList class methodsFor: 'utility' stamp: 'miki 8/15/2005 18:34'! 109389modalLoopOn: aMorph 109390 [aMorph world notNil] whileTrue: [ 109391 aMorph outermostWorldMorph doOneCycle. 109392 ].! ! 109393 109394!FileList class methodsFor: 'utility' stamp: 'hfm 11/29/2008 18:37'! 109395registeredFileReaderClasses 109396 FileReaderRegistry := nil. "wipe it out" 109397 ^FileServices registeredFileReaderClasses 109398 ! ! 109399 109400!FileList class methodsFor: 'utility' stamp: 'hfm 11/29/2008 18:35'! 109401suffixOf: aName 109402 "Answer the file extension of the given file" 109403 ^ aName 109404 ifNil: 109405 [''] 109406 ifNotNil: 109407 [(FileDirectory extensionFor: aName) asLowercase]! ! 109408 109409!FileList class methodsFor: 'utility' stamp: 'RAA 3/6/2001 12:39'! 109410textRow: aString 109411 109412 ^AlignmentMorph newRow 109413 wrapCentering: #center; cellPositioning: #leftCenter; 109414 color: Color transparent; 109415 layoutInset: 0; 109416 addMorph: ( 109417 AlignmentMorph newColumn 109418 wrapCentering: #center; cellPositioning: #topCenter; 109419 color: Color transparent; 109420 vResizing: #shrinkWrap; 109421 layoutInset: 0; 109422 addMorph: ( 109423 AlignmentMorph newRow 109424 wrapCentering: #center; cellPositioning: #leftCenter; 109425 color: Color transparent; 109426 hResizing: #shrinkWrap; 109427 vResizing: #shrinkWrap; 109428 layoutInset: 0; 109429 addMorph: ((StringMorph contents: aString) color: Color blue; lock) 109430 ) 109431 )! ! 109432 109433 109434!FileList class methodsFor: 'window color' stamp: 'hfm 11/29/2008 19:39'! 109435windowColorSpecification 109436 "Answer a WindowColorSpec object that declares my preference" 109437 109438 ^ WindowColorSpec 109439 classSymbol: self name 109440 wording: 'File List' 109441 brightColor: #lightMagenta 109442 pastelColor: #paleMagenta 109443 helpMessage: 'A tool for looking at files'! ! 109444SimpleServiceEntry subclass: #FileModifyingSimpleServiceEntry 109445 instanceVariableNames: '' 109446 classVariableNames: '' 109447 poolDictionaries: '' 109448 category: 'System-FileRegistry'! 109449!FileModifyingSimpleServiceEntry commentStamp: 'nk 11/26/2002 12:03' prior: 0! 109450I represent a service that may change the contents of a directory. 109451Such changes include: 109452* file creation 109453* file deletion 109454* file modification! 109455 109456 109457!FileModifyingSimpleServiceEntry methodsFor: 'as yet unclassified' stamp: 'nk 11/26/2002 12:08'! 109458performServiceFor: anObject 109459 | retval | 109460 retval := super performServiceFor: anObject. 109461 self changed: #fileListChanged. 109462 ^retval "is this used anywhere?"! ! 109463Object subclass: #FilePackage 109464 instanceVariableNames: 'fullName sourceSystem classes doIts classOrder' 109465 classVariableNames: 'LogFileStream' 109466 poolDictionaries: '' 109467 category: 'System-FilePackage'! 109468 109469!FilePackage methodsFor: '*monticello' stamp: 'al 12/2/2005 13:58'! 109470classDefinition: string with: chgRec 109471 | tokens theClass | 109472 109473 self flag: #traits. 109474 109475 tokens := Scanner new scanTokens: string. 109476 109477 "tokens size = 11 ifFalse:[^doIts add: chgRec]." 109478 109479 theClass := self getClass: (tokens at: 3). 109480 theClass definition: string. 109481 classOrder add: theClass.! ! 109482 109483!FilePackage methodsFor: '*monticello' stamp: 'avi 1/19/2004 23:47'! 109484doIts 109485 ^ doIts! ! 109486 109487 109488!FilePackage methodsFor: 'accessing'! 109489classAt: className 109490 ^self classes at: className! ! 109491 109492!FilePackage methodsFor: 'accessing'! 109493classes 109494 ^classes! ! 109495 109496!FilePackage methodsFor: 'accessing' stamp: 'nk 2/18/2004 18:31'! 109497fixClassOrder 109498 "Essentially bubble sort the classOrder so that superclasses appear before subclasses" 109499 | superClass index subClass superIndex | 109500 index := 0. 109501 [index < classOrder size] whileTrue:[ 109502 subClass := classOrder at: (index := index + 1). 109503 superClass := nil. 109504 subClass isMeta ifTrue:[ 109505 "Treat non-meta as superclass" 109506 superClass := self classes at: subClass name ifAbsent:[nil]. 109507 ] ifFalse:[ 109508 subClass hasDefinition ifTrue:[ 109509 superClass := self classes 109510 at: (Scanner new scanTokens: subClass definition) first ifAbsent:[nil]. 109511 superClass ifNotNil:[superClass hasDefinition ifFalse:[superClass := nil]]. 109512 ]. 109513 ]. 109514 superClass ifNotNil:[ 109515 superIndex := classOrder indexOf: superClass ifAbsent:[self error:'Where is the class?']. 109516 superIndex > index ifTrue:[ 109517 "Move superClass before index" 109518 classOrder remove: superClass. 109519 classOrder add: superClass before: subClass. 109520 "Rewind index - we need to check superClass itself" 109521 index := index - 1. 109522 ]. 109523 ]. 109524 ]. 109525! ! 109526 109527!FilePackage methodsFor: 'accessing' stamp: 'pnm 1095288/23/2000 17:10'! 109529fullName: aString 109530 fullName := aString! ! 109531 109532!FilePackage methodsFor: 'accessing'! 109533fullPackageName 109534 ^fullName! ! 109535 109536!FilePackage methodsFor: 'accessing'! 109537packageInfo 109538 ^String streamContents:[:s| 109539 s nextPutAll:'Package: '. 109540 s nextPutAll: self fullPackageName; cr; cr. 109541 sourceSystem isEmpty ifFalse:[ 109542 s nextPutAll: sourceSystem; cr; cr]. 109543 doIts isEmpty ifFalse:[ 109544 s nextPutAll:'Unresolvable doIts:'; cr; cr. 109545 doIts do:[:chgRec| 109546 s nextPut:$!!; nextPutAll: chgRec string; nextPut: $!!; cr]]].! ! 109547 109548!FilePackage methodsFor: 'accessing' stamp: 'pnm 1095498/23/2000 17:12'! 109550packageName 109551 ^FileDirectory localNameFor: self fullPackageName! ! 109552 109553!FilePackage methodsFor: 'accessing'! 109554removeClass: aPseudoClass 109555 (self classes removeKey: aPseudoClass name). 109556 classOrder copy do:[:cls| 109557 cls name = aPseudoClass name ifTrue:[ classOrder remove: cls]. 109558 ].! ! 109559 109560!FilePackage methodsFor: 'accessing' stamp: 'ar 2/5/2004 15:11'! 109561removeDoIts 109562 doIts := OrderedCollection new.! ! 109563 109564!FilePackage methodsFor: 'accessing'! 109565renameClass: aPseudoClass to: newName 109566 | oldName | 109567 oldName := aPseudoClass name. 109568 self classes removeKey: oldName. 109569 self classes at: newName put: aPseudoClass. 109570 aPseudoClass renameTo: newName.! ! 109571 109572 109573!FilePackage methodsFor: 'change record types'! 109574classComment: chgRec 109575 109576 (self getClass: chgRec methodClassName) classComment: chgRec! ! 109577 109578!FilePackage methodsFor: 'change record types'! 109579doIt: chgRec 109580 | string | 109581 string := chgRec string. 109582 ('*ubclass:*instanceVariableNames:*classVariableNames:*poolDictionaries:*category:*' 109583 match: string) ifTrue:[^self classDefinition: string with: chgRec]. 109584 ('* class*instanceVariableNames:*' 109585 match: string) ifTrue:[^self metaClassDefinition: string with: chgRec]. 109586 ('* removeSelector: *' 109587 match: string) ifTrue:[^self removedMethod: string with: chgRec]. 109588 ('* comment:*' 109589 match: string) ifTrue:[^self msgClassComment: string with: chgRec]. 109590 ('* initialize' 109591 match: string) ifTrue:[^self]. "Initialization is done based on class>>initialize" 109592 ('''From *' 109593 match: string) ifTrue:[^self possibleSystemSource: chgRec]. 109594 doIts add: chgRec.! ! 109595 109596!FilePackage methodsFor: 'change record types'! 109597method: chgRec 109598 (self getClass: chgRec methodClassName) methodChange: chgRec! ! 109599 109600!FilePackage methodsFor: 'change record types'! 109601preamble: chgRec 109602 self doIt: chgRec! ! 109603 109604 109605!FilePackage methodsFor: 'conflict checker' stamp: 'dew 2/14/2004 00:12'! 109606checkForMoreRecentUpdateThanChangeSet: updateNumberChangeSet pseudoClass: pseudoClass selector: selector 109607 "Returns the source code for a conflict if a conflict is found, otherwise returns nil." 109608 109609 | classOrMeta allChangeSets moreRecentChangeSets conflictingChangeSets changeRecordSource classAndMethodPrintString | 109610 109611 classAndMethodPrintString := pseudoClass name, (pseudoClass hasMetaclass ifTrue: [' class'] ifFalse: ['']), '>>', selector asString. 109612 109613 changeRecordSource := pseudoClass sourceCode at: selector. 109614 changeRecordSource isText 109615 ifTrue: [changeRecordSource := Text 109616 fromString: 'method: ', classAndMethodPrintString, ' was removed'] 109617 ifFalse: [changeRecordSource stamp isEmptyOrNil ifTrue: 109618 [self notify: 'Warning: ', classAndMethodPrintString, ' in ', self packageName, ' has no timestamp/initials!!']]. 109619 109620 pseudoClass exists ifFalse: 109621 [(self classes at: pseudoClass name) hasDefinition 109622 ifTrue: [^ nil "a method was added for a newly defined class; not a conflict"] 109623 ifFalse: [self class logCr; log: 'CONFLICT found for ', classAndMethodPrintString, '... class ', pseudoClass name asString, ' does not exist in the image and is not defined in the file'. 109624 ^ changeRecordSource]]. 109625 109626 classOrMeta := pseudoClass realClass. 109627 109628 "Only printout the replacing methods here, but we still check for removed methods too in the rest of this method." 109629 (self class verboseConflicts and: [classOrMeta includesSelector: selector]) 109630 ifTrue: [self class logCr; log: '...checking ', classOrMeta asString, '>>', selector asString]. 109631 109632 allChangeSets := ChangeSorter allChangeSets. 109633 moreRecentChangeSets := allChangeSets 109634 copyFrom: (allChangeSets indexOf: updateNumberChangeSet) 109635 to: (allChangeSets size). 109636 conflictingChangeSets := (moreRecentChangeSets select: 109637 [:cs | (cs atSelector: selector class: classOrMeta) ~~ #none]). 109638 conflictingChangeSets isEmpty ifTrue: [^ nil]. 109639 109640 self class logCr; log: 'CONFLICT found for ', classAndMethodPrintString, 109641 (' with newer changeset' asPluralBasedOn: conflictingChangeSets). 109642 conflictingChangeSets do: [:cs | self class log: ' ', cs name]. 109643 ^ changeRecordSource 109644! ! 109645 109646!FilePackage methodsFor: 'conflict checker' stamp: 'DamienCassou 9/23/2009 08:40'! 109647conflictsWithUpdatedMethods 109648 "Check this package for conflicts with methods in the image which are in newer updates." 109649 109650 | localFileName stream updateNumberString updateNumber imageUpdateNumber updateNumberChangeSet conflicts fileStream | 109651 109652 localFileName := FileDirectory localNameFor: fullName. 109653 stream := sourceSystem readStream. 109654 stream upToAll: 'latest update: #'. 109655 updateNumberString := stream upTo: $]. 109656 stream close. 109657 109658 fileStream := FileStream readOnlyFileNamed: fullName. 109659 (fileStream contentsOfEntireFile includes: Character linefeed) 109660 ifTrue: [self notifyWithLabel: 'The changeset file ', localFileName, ' contains linefeeds. Proceed if... 109661you know that this is okay (e.g. the file contains raw binary data).']. 109662 fileStream close. 109663 109664 updateNumberString isEmpty ifFalse: "remove prepended junk, if any" 109665 [updateNumberString := (updateNumberString findTokens: Character space) last]. 109666 updateNumberString asInteger ifNil: 109667 [(self confirm: 'Error: ', localFileName, ' has no valid Latest Update number in its header. 109668Do you want to enter an update number for this file?') 109669 ifFalse: [^ self] 109670 ifTrue: [updateNumberString := UIManager default 109671 request: 'Please enter the estimated update number (e.g. 4332).' translated]]. 109672 (updateNumberString isEmptyOrNil or: [updateNumberString asInteger isNil]) 109673 ifTrue: [self inform: 'Conflict check cancelled.' translated. ^ self]. 109674 updateNumber := updateNumberString asInteger. 109675 109676 imageUpdateNumber := SystemVersion current highestUpdate. 109677 updateNumber > imageUpdateNumber ifTrue: 109678 [(self confirm: 'Warning: The update number for this file (#', updateNumberString, ') 109679is greater than the highest update number for this image (#', imageUpdateNumber asString, '). 109680This probably means you need to update your image. 109681Should we proceed anyway as if the file update number is #', imageUpdateNumber asString, '?') 109682 ifTrue: 109683 [updateNumber := imageUpdateNumber. 109684 updateNumberString := imageUpdateNumber asString] 109685 ifFalse: [^ self]]. 109686 109687 updateNumberChangeSet := self findUpdateChangeSetMatching: updateNumber. 109688 updateNumberChangeSet ifNil: [^ self]. 109689 109690 self currentWorld findATranscript: self currentEvent. 109691 self class logCr; logCr; log: 'Checking ', localFileName, ' (#', updateNumberString, ') for method conflicts with changesets after ', updateNumberChangeSet name, ' ...'. 109692 109693 conflicts := OrderedCollection new. 109694 self classes values do: [:pseudoClass | 109695 (Array with: pseudoClass with: pseudoClass metaClass) do: [:classOrMeta | 109696 classOrMeta selectors do: [:selector | | conflict | 109697 conflict := self 109698 checkForMoreRecentUpdateThanChangeSet: updateNumberChangeSet 109699 pseudoClass: classOrMeta 109700 selector: selector. 109701 conflict ifNotNil: [conflicts add: conflict]. 109702 ]. 109703 ]. 109704 ]. 109705 self class logCr; log: conflicts size asString, (' conflict' asPluralBasedOn: conflicts), ' found.'; logCr. 109706 self class closeLog. 109707 ^ conflicts! ! 109708 109709!FilePackage methodsFor: 'conflict checker' stamp: 'dew 10/19/2003 21:29'! 109710findUpdateChangeSetMatching: updateNumber 109711 "Find update-changeset beginning with updateNumber, or reasonably close." 109712 "This is to account for the fact that many changeset files are output from final releases, but may be tested for conflicts in a following alpha image, which will often not include that particular update-changeset from the final release but will contain ones near it. For example, if the file updateNumber is 5180 (from 3.5 final), but the image has no update-changeset beginning with 5180 because it's a 3.6alpha image (which starts at 5181), it will try up to 5190 and down to 5170 for a close match." 109713 | updateNumberChangeSet updateNumberToTry | 109714 109715 updateNumberToTry := updateNumber. 109716 updateNumberChangeSet := nil. 109717 [updateNumberChangeSet isNil and: [updateNumberToTry notNil]] whileTrue: 109718 [updateNumberChangeSet := ChangeSorter allChangeSets 109719 detect: [:cs | (cs name beginsWith: updateNumberToTry asString) 109720 and: [(cs name at: (updateNumberToTry asString size + 1)) isDigit not]] 109721 ifNone: [nil]. 109722 updateNumberToTry >= updateNumber ifTrue: 109723 [updateNumberToTry < (updateNumber + 10) 109724 ifTrue: [updateNumberToTry := updateNumberToTry + 1] 109725 ifFalse: [updateNumberToTry := updateNumber]]. 109726 updateNumberToTry <= updateNumber ifTrue: 109727 [updateNumberToTry > (updateNumber - 10) 109728 ifTrue: [updateNumberToTry := updateNumberToTry - 1] 109729 ifFalse: [updateNumberToTry := nil "we're done trying"]]. 109730 ]. 109731 109732 updateNumberChangeSet ifNil: 109733 [(self confirm: 'Warning: No changeset beginning with ', 109734updateNumber asString, ' (within +/- 10) was found in the image. 109735You must have changesets going back this far in your image 109736in order to accurately check for conflicts. 109737Proceed anyway?') 109738 ifTrue: [updateNumberChangeSet := ChangeSorter allChangeSets first]]. 109739 109740 ^ updateNumberChangeSet! ! 109741 109742 109743!FilePackage methodsFor: 'filein/fileout' stamp: 'alain.plantec 2/6/2009 17:01'! 109744askForDoits 109745 | choice choices | 109746 choices := {'do not process' translated. 'at the beginning' translated. 'at the end' translated}. 109747 choice := nil. 109748 [choices includes: choice] whileFalse: [ 109749 choice := UIManager default 109750 chooseFrom: choices 109751 values: choices 109752 title: 'Unprocessed doIts found. When to process those?' translated. 109753 choice ifNil: [^0]]. 109754 ^choices indexOf: choice! ! 109755 109756!FilePackage methodsFor: 'filein/fileout' stamp: 'alain.plantec 2/6/2009 17:02'! 109757fileIn 109758 | doitsMark | 109759 doitsMark := 1. 109760 doIts isEmpty ifFalse:[doitsMark := self askForDoits]. 109761 doitsMark = 0 ifTrue: [^nil]. 109762 doitsMark = 2 ifTrue:[self fileInDoits]. 109763 classOrder do:[:cls| 109764 cls fileInDefinition. 109765 ]. 109766 classes do:[:cls| 109767 Transcript cr; show:'Filing in ', cls name. 109768 cls fileInMethods. 109769 cls hasMetaclass ifTrue:[cls metaClass fileInMethods]. 109770 ]. 109771 doitsMark = 3 ifTrue:[self fileInDoits].! ! 109772 109773!FilePackage methodsFor: 'filein/fileout'! 109774fileInDoits 109775 doIts do:[:chgRec| chgRec fileIn].! ! 109776 109777!FilePackage methodsFor: 'filein/fileout' stamp: 'ar 7/17/2005 03:36'! 109778fileOut 109779 | fileName stream | 109780 fileName := UIManager default request: 'Enter the file name' initialAnswer:''. 109781 stream := FileStream newFileNamed: fileName. 109782 sourceSystem isEmpty ifFalse:[ 109783 stream nextChunkPut: sourceSystem printString;cr ]. 109784 self fileOutOn: stream. 109785 stream cr; cr. 109786 self classes do:[:cls| 109787 cls needsInitialize ifTrue:[ 109788 stream cr; nextChunkPut: cls name,' initialize']]. 109789 stream cr. 109790 stream close. 109791 109792 "DeepCopier new checkVariables." 109793! ! 109794 109795!FilePackage methodsFor: 'filein/fileout'! 109796fileOutDoits: aStream 109797 doIts do:[:chgRec| chgRec fileOutOn: aStream].! ! 109798 109799!FilePackage methodsFor: 'filein/fileout' stamp: 'alain.plantec 2/6/2009 17:02'! 109800fileOutOn: aStream 109801 | doitsMark | 109802 doitsMark := 1. 109803 doIts isEmpty ifFalse:[doitsMark := self askForDoits]. 109804 doitsMark = 0 ifTrue: [^nil]. 109805 doitsMark = 2 ifTrue:[self fileOutDoits: aStream]. 109806 classOrder do:[:cls| 109807 cls fileOutDefinitionOn: aStream. 109808 ]. 109809 classes do:[:cls| 109810 cls fileOutMethodsOn: aStream. 109811 cls hasMetaclass ifTrue:[cls metaClass fileOutMethodsOn: aStream]. 109812 ]. 109813 doitsMark = 3 ifTrue:[self fileOutDoits: aStream].! ! 109814 109815 109816!FilePackage methodsFor: 'initialize' stamp: 'yo 8/17/2004 09:53'! 109817fromFileNamed: aName 109818 | stream | 109819 fullName := aName. 109820 stream := FileStream readOnlyFileNamed: aName. 109821 stream setConverterForCode. 109822 [self fileInFrom: stream] ensure:[stream close].! ! 109823 109824!FilePackage methodsFor: 'initialize' stamp: 'yo 8/17/2004 09:54'! 109825fromFileNamed: aName encoding: encodingName 109826 | stream | 109827 fullName := aName. 109828 stream := FileStream readOnlyFileNamed: aName. 109829 stream converter: (TextConverter newForEncoding: encodingName). 109830 self fileInFrom: stream.! ! 109831 109832!FilePackage methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:54'! 109833initialize 109834 super initialize. 109835 classes := Dictionary new. 109836 classOrder := OrderedCollection new. 109837 sourceSystem := ''. 109838 doIts := OrderedCollection new.! ! 109839 109840 109841!FilePackage methodsFor: 'reading' stamp: 'ar 7/16/2005 15:05'! 109842fileInFrom: aStream 109843 | chgRec changes | 109844 changes := ChangeSet scanFile: aStream from: 0 to: aStream size. 109845 aStream close. 109846 ('Processing ', self packageName) 109847 displayProgressAt: Sensor cursorPoint 109848 from: 1 109849 to: changes size 109850 during:[:bar| 109851 1 to: changes size do:[:i| 109852 bar value: i. 109853 chgRec := changes at: i. 109854 self perform: (chgRec type copyWith: $:) asSymbol 109855with: chgRec. 109856 ]. 109857 ].! ! 109858 109859 109860!FilePackage methodsFor: 'private'! 109861getClass: className 109862 | pseudoClass | 109863 (classes includesKey: className) ifTrue:[ 109864 ^classes at: className. 109865 ]. 109866 pseudoClass := PseudoClass new. 109867 pseudoClass name: className. 109868 classes at: className put: pseudoClass. 109869 ^pseudoClass.! ! 109870 109871!FilePackage methodsFor: 'private'! 109872metaClassDefinition: string with: chgRec 109873 | tokens theClass | 109874 tokens := Scanner new scanTokens: string. 109875 theClass := self getClass: (tokens at: 1). 109876 theClass metaClass definition: string. 109877 classOrder add: theClass metaClass.! ! 109878 109879!FilePackage methodsFor: 'private' stamp: 'ar 4/10/2005 18:46'! 109880msgClassComment: string with: chgRec 109881 | tokens theClass | 109882 tokens := Scanner new scanTokens: string. 109883 (tokens size = 3 and:[(tokens at: 3) isString]) ifTrue:[ 109884 theClass := self getClass: tokens first. 109885 ^theClass commentString: tokens last]. 109886 (tokens size = 4 and:[(tokens at: 3) asString = 'class' and:[(tokens at: 4) isString]]) ifTrue:[ 109887 theClass := self getClass: tokens first. 109888 theClass metaClass commentString: tokens last]. 109889! ! 109890 109891!FilePackage methodsFor: 'private' stamp: 'ar 4/10/2005 18:46'! 109892possibleSystemSource: chgRec 109893 | tokens | 109894 sourceSystem isEmpty ifTrue:[ 109895 tokens := Scanner new scanTokens: chgRec string. 109896 (tokens size = 1 and:[tokens first isString]) ifTrue:[ 109897 sourceSystem := tokens first. 109898 ^self]]. 109899 doIts add: chgRec.! ! 109900 109901!FilePackage methodsFor: 'private'! 109902removedMethod: string with: chgRec 109903 | class tokens | 109904 tokens := Scanner new scanTokens: string. 109905 (tokens size = 3 and:[(tokens at: 2) == #removeSelector: ]) ifTrue:[ 109906 class := self getClass: (tokens at: 1). 109907 ^class removeSelector: (tokens at: 3). 109908 ]. 109909 (tokens size = 4 and:[(tokens at: 2) == #class and:[(tokens at: 3) == #removeSelector:]]) ifTrue:[ 109910 class := self getClass: (tokens at: 1). 109911 ^class metaClass removeSelector: (tokens at: 4). 109912 ]. 109913 doIts add: chgRec! ! 109914 109915!FilePackage methodsFor: 'private'! 109916sampleMethod 109917" In an existing method there are always a number of changes. 109918 Other stuff 109919 will be deleted 109920 Or even better, 109921 some things may be just modified. 109922"! ! 109923 109924"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 109925 109926FilePackage class 109927 instanceVariableNames: ''! 109928 109929!FilePackage class methodsFor: 'conflict checker logging' stamp: 'dew 2/13/2004 23:33'! 109930closeLog 109931 self logFileStream close. 109932 LogFileStream := nil.! ! 109933 109934!FilePackage class methodsFor: 'conflict checker logging' stamp: 'dew 2/14/2004 23:03'! 109935logCr 109936 Transcript cr. 109937 self logFileStream nextPut: Character cr. 109938! ! 109939 109940!FilePackage class methodsFor: 'conflict checker logging' stamp: 'stephaneducasse 11/1/2005 15:39'! 109941logFileStream 109942 109943 LogFileStream ifNil: 109944 [LogFileStream := FileStream fileNamed: 'ConflictChecker.log'. 109945 LogFileStream setToEnd]. 109946 ^ LogFileStream! ! 109947 109948!FilePackage class methodsFor: 'conflict checker logging' stamp: 'dew 2/14/2004 23:03'! 109949log: aString 109950 Transcript show: aString. 109951 self logFileStream nextPutAll: aString. 109952! ! 109953 109954 109955!FilePackage class methodsFor: 'conflict checker preferences' stamp: 'dew 12/22/2002 00:19'! 109956showIdenticalConflicts 109957 "(Not implemented yet. Need to implement versionFromChangeSet first for this to work for the 'false' case.)" 109958 "Set this to true if we want to show conflicts with methods which have an identical timestamp to the one being checked. This type of conflict usually just proves that you've already loaded the changeset (or some part of it) in your image." 109959 ^ true 109960! ! 109961 109962!FilePackage class methodsFor: 'conflict checker preferences' stamp: 'dew 2/13/2004 23:32'! 109963verboseConflicts 109964 "Set this to true if we want to list each replacing (potentially conflicting) method being checked." 109965 ^ true! ! 109966 109967 109968!FilePackage class methodsFor: 'instance creation' stamp: 'dew 10/26/2003 22:08'! 109969conflictsWithUpdatedMethods: fullName 109970 | conflicts changeList | 109971 conflicts := (self fromFileNamed: fullName) conflictsWithUpdatedMethods. 109972 conflicts isEmpty ifTrue: [^ self]. 109973 changeList := ChangeList new. 109974 changeList 109975 changes: conflicts 109976 file: (FileDirectory default readOnlyFileNamed: fullName) close; 109977 openAsMorphName: 'Conflicts for ', (FileDirectory localNameFor: fullName) 109978 multiSelect: true 109979! ! 109980 109981!FilePackage class methodsFor: 'instance creation'! 109982fromFileNamed: aName 109983 ^self new fromFileNamed: aName! ! 109984 109985 109986!FilePackage class methodsFor: 'reader service' stamp: 'dew 12/16/2002 18:29'! 109987fileReaderServicesForFile: fullName suffix: suffix 109988 109989 ^(suffix = 'st') | (suffix = 'cs') | (suffix = '*') 109990 ifTrue: [self services] 109991 ifFalse: [#()]! ! 109992 109993!FilePackage class methodsFor: 'reader service' stamp: 'dew 12/16/2002 18:29'! 109994serviceConflictsWithUpdatedMethods 109995 ^ SimpleServiceEntry 109996 provider: self 109997 label: 'conflicts with updated methods' 109998 selector: #conflictsWithUpdatedMethods: 109999 description: 'check for conflicts with more recently updated methods in the image, showing the conflicts in a transcript window' 110000 buttonLabel: 'conflicts'! ! 110001 110002!FilePackage class methodsFor: 'reader service' stamp: 'dew 12/16/2002 18:28'! 110003services 110004 ^ Array with: self serviceConflictsWithUpdatedMethods! ! 110005Object subclass: #FilePath 110006 instanceVariableNames: 'squeakPathName vmPathName converter' 110007 classVariableNames: '' 110008 poolDictionaries: '' 110009 category: 'Files-Directories'! 110010!FilePath commentStamp: 'yo 10/19/2004 21:36' prior: 0! 110011This class absorb the difference of internal and external representation of the file path. The idea is to keep the internal one as much as possible, and only when it goes to a primitive, the encoded file path, i.e. the native platform representation is passsed to the primitive. 110012 110013 The converter used is obtained by "LanguageEnvironment defaultFileNameConverter". 110014! 110015 110016 110017!FilePath methodsFor: 'conversion' stamp: 'yo 12/19/2003 21:10'! 110018asSqueakPathName 110019 110020 ^ self pathName. 110021! ! 110022 110023!FilePath methodsFor: 'conversion' stamp: 'ar 1/31/2005 11:16'! 110024asString 110025 ^self asSqueakPathName! ! 110026 110027!FilePath methodsFor: 'conversion' stamp: 'yo 2/24/2005 18:45'! 110028asVmPathName 110029 110030 ^ vmPathName. 110031! ! 110032 110033!FilePath methodsFor: 'conversion' stamp: 'stephaneducasse 2/4/2006 20:31'! 110034coverter: aTextConverter 110035 110036 converter class ~= aTextConverter class ifTrue: [ 110037 converter := aTextConverter. 110038 vmPathName := squeakPathName convertToWithConverter: converter 110039 ]. 110040! ! 110041 110042!FilePath methodsFor: 'conversion' stamp: 'yo 12/19/2003 21:07'! 110043pathName 110044 110045 ^ squeakPathName. 110046! ! 110047 110048!FilePath methodsFor: 'conversion' stamp: 'stephaneducasse 2/4/2006 20:31'! 110049pathName: p isEncoded: isEncoded 110050 110051 converter := LanguageEnvironment defaultFileNameConverter. 110052 isEncoded ifTrue: [ 110053 squeakPathName := p convertFromWithConverter: converter. 110054 vmPathName := p. 110055 ] ifFalse: [ 110056 squeakPathName := p isOctetString ifTrue: [p asOctetString] ifFalse: [p]. 110057 vmPathName := squeakPathName convertToWithConverter: converter. 110058 ]. 110059! ! 110060 110061!FilePath methodsFor: 'conversion' stamp: 'yo 12/19/2003 21:07'! 110062printOn: aStream 110063 110064 aStream nextPutAll: 'FilePath('''. 110065 aStream nextPutAll: squeakPathName. 110066 aStream nextPutAll: ''')'. 110067! ! 110068 110069 110070!FilePath methodsFor: 'file in/out' stamp: 'stephaneducasse 2/4/2006 20:31'! 110071copySystemToVm 110072 110073 (self class instVarNames includes: 'systemPathName') ifTrue: [ 110074 vmPathName := self instVarNamed: 'systemPathName'. 110075 ]. 110076 110077! ! 110078 110079 110080!FilePath methodsFor: 'testing' stamp: 'tpr 11/5/2004 11:39'! 110081isNullPath 110082 "an empty path is used to represent the root path(s) when calling the primitive to list directory entries. Some users need to check for this and this is cleaner than grabbing the pathname and assuming it is a plain String" 110083 ^self pathName isEmpty! ! 110084 110085"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 110086 110087FilePath class 110088 instanceVariableNames: ''! 110089 110090!FilePath class methodsFor: 'as yet unclassified' stamp: 'yo 2/24/2005 18:38'! 110091classVersion 110092 110093 ^ 1. 110094! ! 110095 110096 110097!FilePath class methodsFor: 'instance creation' stamp: 'yo 12/19/2003 16:30'! 110098pathName: pathName 110099 110100 ^ self pathName: pathName isEncoded: false. 110101! ! 110102 110103!FilePath class methodsFor: 'instance creation' stamp: 'yo 12/19/2003 16:30'! 110104pathName: pathName isEncoded: aBoolean 110105 110106 ^ (self new) pathName: pathName isEncoded: aBoolean; yourself. 110107! ! 110108Object subclass: #FileServices 110109 instanceVariableNames: '' 110110 classVariableNames: 'FileReaderRegistry' 110111 poolDictionaries: '' 110112 category: 'System-FileRegistry'! 110113 110114"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 110115 110116FileServices class 110117 instanceVariableNames: ''! 110118 110119!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 16:59'! 110120allRegisteredServices 110121 "self allRegisteredServices" 110122 110123 | col | 110124 col := OrderedCollection new. 110125 self registeredFileReaderClasses do: [:each | col addAll: (each services)]. 110126 ^ col! ! 110127 110128!FileServices class methodsFor: 'accessing' stamp: 'ar 9/29/2005 12:30'! 110129initialize 110130 "FileServices initialize" 110131 Smalltalk allClassesDo:[:aClass| 110132 (aClass class includesSelector: #fileReaderServicesForFile:suffix:) 110133 ifTrue:[self registerFileReader: aClass]].! ! 110134 110135!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:00'! 110136isReaderNamedRegistered: aSymbol 110137 "return if a given reader class has been registered. Note that this is on purpose that the argument is 110138 a symbol and not a class" 110139 110140 ^ (self registeredFileReaderClasses collect: [:each | each name]) includes: aSymbol 110141! ! 110142 110143!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:00'! 110144itemsForDirectory: aFileDirectory 110145 "Answer a list of services appropriate when no file is selected." 110146 110147 | services | 110148 services := OrderedCollection new. 110149 self registeredFileReaderClasses do: [:reader | 110150 reader ifNotNil: [services addAll: (reader fileReaderServicesForDirectory: aFileDirectory) ]]. 110151 ^ services! ! 110152 110153!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:00'! 110154itemsForFile: fullName 110155 "Answer a list of services appropriate for a file of the given full name" 110156 110157 | services suffix | 110158 suffix := self suffixOf: fullName. 110159 services := OrderedCollection new. 110160 self registeredFileReaderClasses do: [:reader | 110161 reader ifNotNil: [services addAll: (reader fileReaderServicesForFile: fullName suffix: suffix)]]. 110162 ^ services! ! 110163 110164!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 16:59'! 110165registeredFileReaderClasses 110166 FileReaderRegistry ifNil: [FileReaderRegistry := OrderedCollection new]. 110167 ^ FileReaderRegistry! ! 110168 110169!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:00'! 110170registerFileReader: aProviderClass 110171 "register the given class as providing services for reading files" 110172 110173 | registeredReaders | 110174 registeredReaders := self registeredFileReaderClasses. 110175 (registeredReaders includes: aProviderClass) 110176 ifFalse: [ registeredReaders addLast: aProviderClass ]! ! 110177 110178!FileServices class methodsFor: 'accessing' stamp: 'ar 7/17/2005 02:36'! 110179removeObsolete 110180 "FileServices removeObsolete" 110181 self registeredFileReaderClasses copy 110182 do:[:cls| cls isObsolete ifTrue:[self unregisterFileReader: cls]]! ! 110183 110184!FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:00'! 110185unregisterFileReader: aProviderClass 110186 "unregister the given class as providing services for reading files" 110187 110188 self registeredFileReaderClasses remove: aProviderClass ifAbsent: [nil]! ! 110189ReadWriteStream subclass: #FileStream 110190 instanceVariableNames: 'rwmode' 110191 classVariableNames: '' 110192 poolDictionaries: '' 110193 category: 'Files-Kernel'! 110194!FileStream commentStamp: '<historical>' prior: 0! 110195I represent a Stream that accesses a FilePage from a File. One use for my instance is to access larger "virtual Strings" than can be stored contiguously in main memory. I restrict the objects stored and retrieved to be Integers or Characters. An end of file pointer terminates reading; it can be extended by writing past it, or the file can be explicitly truncated. 110196 110197To use the file system for most applications, you typically create a FileStream. This is done by sending a message to a FileDirectory (file:, oldFile:, newFile:, rename:newName:) which creates an instance of me. Accesses to the file are then done via my instance. 110198 110199*** On DOS, files cannot be shortened!! *** To overwrite a file with a shorter one, first delete the old file (FileDirectory deleteFilePath: 'Hard Disk:aFolder:dataFolder:foo') or (aFileDirectory deleteFileNamed: 'foo'). Then write your new shorter version.! 110200 110201 110202!FileStream methodsFor: '*network-uri' stamp: 'bf 1/27/2006 18:01'! 110203uri 110204 ^self directory uri resolveRelativeURI: self localName encodeForHTTP! ! 110205 110206!FileStream methodsFor: '*network-uri' stamp: 'fbs 2/2/2005 13:23'! 110207url 110208 "Convert my path into a file:// type url String." 110209 110210 ^self asUrl asString! ! 110211 110212 110213!FileStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'! 110214contents 110215 "Return the contents of the receiver. Do not close or otherwise touch the receiver. Return data in whatever mode the receiver is in (e.g., binary or text)." 110216 | s savePos | 110217 savePos := self position. 110218 self position: 0. 110219 s := self next: self size. 110220 self position: savePos. 110221 ^s! ! 110222 110223!FileStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'! 110224contentsOfEntireFile 110225 "Read all of the contents of the receiver." 110226 110227 | s binary | 110228 self readOnly. 110229 binary := self isBinary. 110230 self reset. "erases knowledge of whether it is binary" 110231 binary ifTrue: [self binary]. 110232 s := self next: self size. 110233 self close. 110234 ^s! ! 110235 110236!FileStream methodsFor: 'accessing' stamp: 'nk 2/22/2001 17:07'! 110237directoryEntry 110238 ^self directory entryAt: self localName! ! 110239 110240!FileStream methodsFor: 'accessing' stamp: 'ar 1/25/2001 19:33'! 110241mimeTypes 110242 ^FileDirectory default mimeTypesFor: self name.! ! 110243 110244!FileStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'! 110245next 110246 110247 (position >= readLimit and: [self atEnd]) 110248 ifTrue: [^nil] 110249 ifFalse: [^collection at: (position := position + 1)]! ! 110250 110251!FileStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'! 110252next: anInteger 110253 110254 | newCollection howManyRead increment | 110255 newCollection := collection species new: anInteger. 110256 howManyRead := 0. 110257 [howManyRead < anInteger] whileTrue: 110258 [self atEnd ifTrue: 110259 [(howManyRead + 1) to: anInteger do: [:i | newCollection at: i put: (self next)]. 110260 ^newCollection]. 110261 increment := (readLimit - position) min: (anInteger - howManyRead). 110262 newCollection replaceFrom: (howManyRead + 1) 110263 to: (howManyRead := howManyRead + increment) 110264 with: collection 110265 startingAt: (position + 1). 110266 position := position + increment]. 110267 ^newCollection! ! 110268 110269!FileStream methodsFor: 'accessing'! 110270nextPut: aByte 110271 "1/31/96 sw: subclassResponsibility" 110272 110273 self subclassResponsibility! ! 110274 110275!FileStream methodsFor: 'accessing'! 110276nextPutAll: aCollection 110277 "1/31/96 sw: made subclass responsibility" 110278 110279 self subclassResponsibility! ! 110280 110281!FileStream methodsFor: 'accessing'! 110282size 110283 "Answer the size of the file in characters. 110284 1/31/96 sw: made subclass responsibility" 110285 110286 self subclassResponsibility! ! 110287 110288 110289!FileStream methodsFor: 'converting' stamp: 'tk 2/4/2000 09:16'! 110290asBinaryOrTextStream 110291 "I can switch between binary and text data" 110292 110293 ^ self! ! 110294 110295 110296!FileStream methodsFor: 'editing' stamp: 'di 5/20/1998 23:20'! 110297edit 110298 "Create and schedule an editor on this file." 110299 110300 FileList openEditorOn: self editString: nil. 110301! ! 110302 110303!FileStream methodsFor: 'editing' stamp: 'stephaneducasse 2/4/2006 20:31'! 110304viewGZipContents 110305 "View the contents of a gzipped file" 110306 110307 | stringContents | 110308 self binary. 110309 stringContents := self contentsOfEntireFile. 110310 Cursor wait showWhile: [stringContents := (GZipReadStream on: stringContents) upToEnd]. 110311 stringContents := stringContents asString withSqueakLineEndings. 110312 110313 Workspace new 110314 contents: stringContents; 110315 openLabel: 'Decompressed contents of: ', self localName! ! 110316 110317 110318!FileStream methodsFor: 'file accessing' stamp: 'gk 2/10/2004 13:21'! 110319asUrl 110320 "Convert my path into a file:// type url - a FileUrl." 110321 110322 ^FileUrl pathParts: (self directory pathParts copyWith: self localName)! ! 110323 110324!FileStream methodsFor: 'file accessing'! 110325file 110326 "Answer the file for the page the receiver is streaming over. 110327 1/31/96 sw: made subclass responsibility" 110328 110329 self subclassResponsibility! ! 110330 110331!FileStream methodsFor: 'file accessing' stamp: 'jm 12/5/97 12:53'! 110332localName 110333 110334 ^ FileDirectory localNameFor: self name 110335! ! 110336 110337!FileStream methodsFor: 'file accessing'! 110338name 110339 "Answer the name of the file for the page the receiver is streaming over. 1/31/96 sw: made subclassResponsibility" 110340 110341 self subclassResponsibility! ! 110342 110343 110344!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:01'! 110345ascii 110346 "Set this file to ascii (text) mode." 110347 110348 self subclassResponsibility 110349! ! 110350 110351!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 12:59'! 110352binary 110353 "Set this file to binary mode." 110354 110355 self subclassResponsibility 110356! ! 110357 110358!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 12:59'! 110359readOnly 110360 "Set this file's mode to read-only." 110361 110362 self subclassResponsibility 110363! ! 110364 110365!FileStream methodsFor: 'file modes' stamp: 'mir 8/24/2004 17:58'! 110366readOnlyStream 110367 ^self readOnly! ! 110368 110369!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:00'! 110370readWrite 110371 "Set this file's mode to read-write." 110372 110373 self subclassResponsibility 110374! ! 110375 110376!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:01'! 110377text 110378 "Set this file to text (ascii) mode." 110379 110380 self ascii. 110381! ! 110382 110383 110384!FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:02'! 110385close 110386 "Close this file." 110387 110388 self subclassResponsibility 110389! ! 110390 110391!FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:02'! 110392closed 110393 "Answer true if this file is closed." 110394 110395 self subclassResponsibility 110396! ! 110397 110398!FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:03'! 110399flush 110400 "When writing, flush the current buffer out to disk." 110401 110402 self subclassResponsibility 110403! ! 110404 110405!FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:04'! 110406reopen 110407 "Ensure that the receiver is open, re-open it if necessary." 110408 "Details: Files that were open when a snapshot occurs are no longer valid when the snapshot is resumed. This operation re-opens the file if that has happened." 110409 110410 self subclassResponsibility 110411! ! 110412 110413 110414!FileStream methodsFor: 'filein/out' stamp: 'sw 11/19/1998 16:42'! 110415fileIn 110416 "Guarantee that the receiver is readOnly before fileIn for efficiency and 110417 to eliminate remote sharing conflicts." 110418 110419 self readOnly. 110420 self fileInAnnouncing: 'Loading ', self localName! ! 110421 110422!FileStream methodsFor: 'filein/out' stamp: 'tk 1/21/2000 16:38'! 110423fileInObjectAndCode 110424 "Read the file directly, do not use an RWBinaryOrTextStream." 110425 110426 self text. 110427 ^ super fileInObjectAndCode 110428! ! 110429 110430!FileStream methodsFor: 'filein/out' stamp: 'di 10/31/2001 12:07'! 110431fileIntoNewChangeSet 110432 "File all of my contents into a new change set." 110433 110434 self readOnly. 110435 ChangeSorter newChangesFromStream: self named: (self localName) 110436! ! 110437 110438 110439!FileStream methodsFor: 'positioning'! 110440position 110441 "Answer the current character position in the file. 110442 1/31/96 sw: subclassResponsibility" 110443 110444 self subclassResponsibility! ! 110445 110446!FileStream methodsFor: 'positioning'! 110447position: pos 110448 "Set the current character position in the file to pos. 110449 1/31/96 sw: made subclassResponsibility" 110450 110451 self subclassResponsibility! ! 110452 110453!FileStream methodsFor: 'positioning'! 110454reset 110455 "Set the current character position to the beginning of the file. 110456 1/31/96 sw: subclassResponsibility" 110457 110458 self subclassResponsibility! ! 110459 110460!FileStream methodsFor: 'positioning'! 110461setToEnd 110462 "Set the current character position to the end of the File. The same as 110463 self position: self size. 1/31/96 sw: made subclassResponsibility" 110464 110465 self subclassResponsibility! ! 110466 110467!FileStream methodsFor: 'positioning'! 110468skip: n 110469 "Set the character position to n characters from the current position. 110470 Error if not enough characters left in the file 110471 1/31/96 sw: made subclassResponsibility." 110472 110473 self subclassResponsibility! ! 110474 110475!FileStream methodsFor: 'positioning' stamp: 'JMM 5/24/2001 22:58'! 110476truncate: pos 110477 "Truncate file to pos" 110478 110479 self subclassResponsibility! ! 110480 110481 110482!FileStream methodsFor: 'printing' stamp: 'tk 12/5/2001 09:12'! 110483longPrintOn: aStream 110484 "Do nothing, so it will print short. Called to print the error file. If the error was in a file operation, we can't read the contents of that file. Just print its name instead." 110485! ! 110486 110487!FileStream methodsFor: 'printing' stamp: 'tk 12/5/2001 09:32'! 110488longPrintOn: aStream limitedTo: sizeLimit indent: indent 110489 110490 "Do nothing, so it will print short. Called to print the error file. If the error was in a file operation, we can't read the contents of that file. Just print its name instead." 110491 110492 aStream cr! ! 110493 110494!FileStream methodsFor: 'printing'! 110495printOn: aStream 110496 110497 super printOn: aStream. 110498 aStream nextPutAll: ' on '. 110499 self file printOn: aStream! ! 110500 110501 110502!FileStream methodsFor: 'remote file compatibility' stamp: 'RAA 9/24/2000 18:00'! 110503dataIsValid 110504 110505 self flag: #bob. "we needed this if a remote stream, but could be local as well"! ! 110506 110507 110508!FileStream methodsFor: 'testing'! 110509atEnd 110510 "Answer true if the current position is >= the end of file position. 110511 1/31/96 sw: subclassResponsibility" 110512 110513 self subclassResponsibility! ! 110514 110515"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 110516 110517FileStream class 110518 instanceVariableNames: ''! 110519 110520!FileStream class methodsFor: '*network-uri' stamp: 'JMM 2/3/2008 14:17'! 110521oldFileFullyNamed: t1 110522 ^ self concreteStream 110523 oldFileNamed: t1! ! 110524 110525!FileStream class methodsFor: '*network-uri' stamp: 'JMM 2/3/2008 14:14'! 110526readOnlyFileFullyNamed: t1 110527 ^ self concreteStream 110528 readOnlyFileFullyNamed: t1! ! 110529 110530 110531!FileStream class methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'! 110532httpPostDocument: url args: argsDict 110533 | argString | 110534 argString := argsDict 110535 ifNotNil: [argString := HTTPSocket argString: argsDict] 110536 ifNil: ['']. 110537 ^self post: argString url: url , argString ifError: [self halt]! ! 110538 110539!FileStream class methodsFor: 'browser requests' stamp: 'PeterHugossonMiller 9/3/2009 01:33'! 110540httpPostMultipart: url args: argsDict 110541 | mimeBorder argsStream crLf fieldValue resultStream result | 110542 " do multipart/form-data encoding rather than x-www-urlencoded " 110543 110544 crLf := String crlf. 110545 mimeBorder := '----squeak-', Time millisecondClockValue printString, '-stuff-----'. 110546 "encode the arguments dictionary" 110547 argsStream := String new writeStream. 110548 argsDict associationsDo: [:assoc | 110549 assoc value do: [ :value | 110550 "print the boundary" 110551 argsStream nextPutAll: '--', mimeBorder, crLf. 110552 " check if it's a non-text field " 110553 argsStream nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"'. 110554 (value isKindOf: MIMEDocument) 110555 ifFalse: [fieldValue := value] 110556 ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', crLf, 'Content-Type: ', value contentType. 110557 fieldValue := (value content 110558 ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile] 110559 ifNotNil: [value content]) asString]. 110560" Transcript show: 'field=', key, '; value=', fieldValue; cr. " 110561 argsStream nextPutAll: crLf, crLf, fieldValue, crLf. 110562 ]]. 110563 argsStream nextPutAll: '--', mimeBorder, '--'. 110564 110565 resultStream := self 110566 post: 110567 ('Content-type: multipart/form-data; boundary=', mimeBorder, crLf, 110568 'Content-length: ', argsStream contents size printString, crLf, crLf, 110569 argsStream contents) 110570 url: url ifError: [^'Error in post ' url asString]. 110571 "get the header of the reply" 110572 result := resultStream upToEnd. 110573 ^MIMEDocument content: result! ! 110574 110575!FileStream class methodsFor: 'browser requests' stamp: 'mir 2/2/2001 14:23'! 110576post: data target: target url: url ifError: errorBlock 110577 ^self concreteStream new post: data target: target url: url ifError: errorBlock! ! 110578 110579!FileStream class methodsFor: 'browser requests' stamp: 'mir 2/2/2001 14:23'! 110580post: data url: url ifError: errorBlock 110581 ^self post: data target: nil url: url ifError: errorBlock! ! 110582 110583!FileStream class methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'! 110584requestURL: url target: target 110585 "FileStream requestURL:'http://isgwww.cs.uni-magdeburg.de/~raab' target: ':=blank' " 110586 ^self concreteStream new requestURL: url target: target! ! 110587 110588!FileStream class methodsFor: 'browser requests'! 110589requestURLStream: url 110590 "FileStream requestURLStream:'http://isgwww.cs.uni-magdeburg.de/~raab'" 110591 ^self concreteStream new requestURLStream: url! ! 110592 110593!FileStream class methodsFor: 'browser requests'! 110594requestURLStream: url ifError: errorBlock 110595 "FileStream requestURLStream:'http://isgwww.cs.uni-magdeburg.de/~raab'" 110596 ^self concreteStream new requestURLStream: url ifError: errorBlock! ! 110597 110598 110599!FileStream class methodsFor: 'concrete classes' stamp: 'yo 7/5/2004 20:18'! 110600concreteStream 110601 "Who should we really direct class queries to? " 110602 ^ MultiByteFileStream. 110603! ! 110604 110605 110606!FileStream class methodsFor: 'dnd requests' stamp: 'ar 1/10/2001 19:41'! 110607requestDropStream: dropIndex 110608 "Request a read-only stream for some file that was dropped onto Squeak" 110609 ^self concreteStream new requestDropStream: dropIndex.! ! 110610 110611 110612!FileStream class methodsFor: 'file reader services' stamp: 'yo 7/5/2004 21:01'! 110613cs 110614 110615 ^ 'cs' clone. 110616! ! 110617 110618!FileStream class methodsFor: 'file reader services' stamp: 'stephaneducasse 2/4/2006 20:32'! 110619fileIn: fullName 110620 "File in the entire contents of the file specified by the name provided" 110621 110622 | ff | 110623 fullName ifNil: [^ Beeper beep]. 110624 ff := self readOnlyFileNamed: (GZipReadStream uncompressedFileName: fullName). 110625 ff fileIn. 110626! ! 110627 110628!FileStream class methodsFor: 'file reader services' stamp: 'nk 7/16/2003 15:49'! 110629fileReaderServicesForFile: fullName suffix: suffix 110630 "Answer services for the given file" 110631 110632 ^ ((self isSourceFileSuffix: suffix) or: [ suffix = '*' ]) 110633 ifTrue: 110634 [{self serviceRemoveLineFeeds. 110635 self serviceFileIn}] 110636 ifFalse: 110637 [#()]! ! 110638 110639!FileStream class methodsFor: 'file reader services' stamp: 'tpr 9/15/2005 15:06'! 110640isSourceFileSuffix: suffix 110641 110642 ^ FileStream sourceFileSuffixes includes: suffix 110643! ! 110644 110645!FileStream class methodsFor: 'file reader services' stamp: 'yo 7/5/2004 21:00'! 110646multiCs 110647 110648 ^ 'mcs' clone. 110649! ! 110650 110651!FileStream class methodsFor: 'file reader services' stamp: 'yo 7/5/2004 21:01'! 110652multiSt 110653 110654 ^ 'mst' clone. 110655! ! 110656 110657!FileStream class methodsFor: 'file reader services' stamp: 'stephaneducasse 2/4/2006 20:32'! 110658removeLineFeeds: fullName 110659 | fileContents | 110660 fileContents := ((FileStream readOnlyFileNamed: fullName) wantsLineEndConversion: true) contentsOfEntireFile. 110661 (FileStream newFileNamed: fullName) 110662 nextPutAll: fileContents; 110663 close.! ! 110664 110665!FileStream class methodsFor: 'file reader services' stamp: 'sw 2/17/2002 01:38'! 110666serviceFileIn 110667 "Answer a service for filing in an entire file" 110668 110669 ^ SimpleServiceEntry 110670 provider: self 110671 label: 'fileIn entire file' 110672 selector: #fileIn: 110673 description: 'file in the entire contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format' 110674 buttonLabel: 'filein'! ! 110675 110676!FileStream class methodsFor: 'file reader services' stamp: 'nk 11/26/2002 12:49'! 110677serviceRemoveLineFeeds 110678 "Answer a service for removing linefeeds from a file" 110679 110680 ^ FileModifyingSimpleServiceEntry 110681 provider: self 110682 label: 'remove line feeds' 110683 selector: #removeLineFeeds: 110684 description: 'remove line feeds in file' 110685 buttonLabel: 'remove lfs'! ! 110686 110687!FileStream class methodsFor: 'file reader services' stamp: 'sd 2/1/2002 22:28'! 110688services 110689 110690 ^ Array 110691 with: self serviceRemoveLineFeeds 110692 with: self serviceFileIn 110693 ! ! 110694 110695!FileStream class methodsFor: 'file reader services' stamp: 'yo 7/7/2004 09:43'! 110696sourceFileSuffixes 110697 110698 ^ {FileStream st. FileStream cs. FileStream multiSt. FileStream multiCs} asSet asArray. 110699 110700! ! 110701 110702!FileStream class methodsFor: 'file reader services' stamp: 'yo 7/5/2004 21:01'! 110703st 110704 110705 ^ 'st' clone. 110706! ! 110707 110708!FileStream class methodsFor: 'file reader services' stamp: 'sd 4/25/2008 15:31'! 110709writeSourceCodeFrom: aStream baseName: baseName isSt: stOrCsFlag 110710 110711 | extension converter f fileName | 110712 aStream contents isAsciiString ifTrue: [ 110713 stOrCsFlag ifTrue: [ 110714 extension := (FileDirectory dot, FileStream st). 110715 ] ifFalse: [ 110716 extension := (FileDirectory dot, FileStream cs). 110717 ]. 110718 converter := MacRomanTextConverter new. 110719 ] ifFalse: [ 110720 stOrCsFlag ifTrue: [ 110721 extension := (FileDirectory dot, FileStream st "multiSt"). 110722 ] ifFalse: [ 110723 extension := (FileDirectory dot, FileStream cs "multiCs"). 110724 ]. 110725 converter := UTF8TextConverter new. 110726 ]. 110727 fileName := baseName, extension. 110728 f := FileStream newFileNamed: fileName. 110729 f ifNil: [^ self error: 'Cannot open file']. 110730 (converter isMemberOf: UTF8TextConverter) 110731 ifTrue: [f binary. 110732 UTF8TextConverter writeBOMOn: f]. 110733 f text. 110734 f converter: converter. 110735 f nextPutAll: aStream contents. 110736 f close. 110737! ! 110738 110739 110740!FileStream class methodsFor: 'initialization' stamp: 'GabrielOmarCotelli 6/4/2009 20:36'! 110741unload 110742 110743 FileServices unregisterFileReader: self ! ! 110744 110745 110746!FileStream class methodsFor: 'initialize-release' stamp: 'GabrielOmarCotelli 6/4/2009 20:35'! 110747initialize 110748 110749 FileServices registerFileReader: self! ! 110750 110751 110752!FileStream class methodsFor: 'instance creation' stamp: 'CdG 10/19/2005 23:21'! 110753detectFile: aBlock do: anotherBlock 110754 110755 | file | 110756 110757 file := aBlock value. 110758 ^ file 110759 ifNil: [ nil ] 110760 ifNotNil: [ [anotherBlock value: file] ensure: [file close]]! ! 110761 110762!FileStream class methodsFor: 'instance creation'! 110763fileNamed: fileName 110764 ^ self concreteStream fileNamed: (self fullName: fileName)! ! 110765 110766!FileStream class methodsFor: 'instance creation' stamp: 'bkv 1/22/2004 17:28'! 110767fileNamed: fileName do: aBlock 110768 "Avi Bryant says, ''This idiom is quite common in other languages that make heavy use of closures (i.e. Lisp (with-file 'foo' (f) ...) and Ruby (File.open('foo'){|f|...})). It's time Squeak had it, too.'' 110769 110770 Returns the result of aBlock." 110771 110772 ^ self detectFile: [ self fileNamed: fileName ] do: aBlock! ! 110773 110774!FileStream class methodsFor: 'instance creation' stamp: 'tpr 10/16/2001 12:49'! 110775forceNewFileNamed: fileName 110776 "Create a new file with the given name, and answer a stream opened for writing on that file. If the file already exists, delete it without asking before creating the new file." 110777 110778 ^self concreteStream forceNewFileNamed: fileName! ! 110779 110780!FileStream class methodsFor: 'instance creation' stamp: 'bkv 1/22/2004 17:29'! 110781forceNewFileNamed: fileName do: aBlock 110782 "Avi Bryant says, ''This idiom is quite common in other languages that make heavy use of closures (i.e. Lisp (with-file 'foo' (f) ...) and Ruby (File.open('foo'){|f|...})). It's time Squeak had it, too.'' 110783 110784 Returns the result of aBlock." 110785 110786 ^ self detectFile: [ self forceNewFileNamed: fileName ] do: aBlock! ! 110787 110788!FileStream class methodsFor: 'instance creation'! 110789fullName: fileName 110790 ^ FileDirectory default fullNameFor: fileName! ! 110791 110792!FileStream class methodsFor: 'instance creation' stamp: 'TPR 8/26/1999 10:49'! 110793isAFileNamed: fName 110794 "return whether a file exists with the given name" 110795 ^self concreteStream isAFileNamed: (self fullName: fName)! ! 110796 110797!FileStream class methodsFor: 'instance creation' stamp: 'di 2/15/98 14:03'! 110798new 110799 ^ self basicNew! ! 110800 110801!FileStream class methodsFor: 'instance creation'! 110802newFileNamed: fileName 110803 ^ self concreteStream newFileNamed: (self fullName: fileName)! ! 110804 110805!FileStream class methodsFor: 'instance creation' stamp: 'bkv 1/22/2004 17:28'! 110806newFileNamed: fileName do: aBlock 110807 "Avi Bryant says, ''This idiom is quite common in other languages that make heavy use of closures (i.e. Lisp (with-file 'foo' (f) ...) and Ruby (File.open('foo'){|f|...})). It's time Squeak had it, too.'' 110808 110809 Returns the result of aBlock." 110810 110811 ^ self detectFile: [ self newFileNamed: fileName ] do: aBlock! ! 110812 110813!FileStream class methodsFor: 'instance creation'! 110814oldFileNamed: fileName 110815 ^ self concreteStream oldFileNamed: (self fullName: fileName)! ! 110816 110817!FileStream class methodsFor: 'instance creation' stamp: 'bkv 1/22/2004 17:29'! 110818oldFileNamed: fileName do: aBlock 110819 "Avi Bryant says, ''This idiom is quite common in other languages that make heavy use of closures (i.e. Lisp (with-file 'foo' (f) ...) and Ruby (File.open('foo'){|f|...})). It's time Squeak had it, too.'' 110820 110821 Returns the result of aBlock." 110822 110823 ^ self detectFile: [ self oldFileNamed: fileName ] do: aBlock! ! 110824 110825!FileStream class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:32'! 110826oldFileOrNoneNamed: fileName 110827 "If the file exists, answer a read-only FileStream on it. If it doesn't, answer nil." 110828 110829 | fullName | 110830 fullName := self fullName: fileName. 110831 (self concreteStream isAFileNamed: fullName) 110832 ifTrue: [^ self concreteStream readOnlyFileNamed: fullName] 110833 ifFalse: [^ nil]. 110834! ! 110835 110836!FileStream class methodsFor: 'instance creation'! 110837readOnlyFileNamed: fileName 110838 ^ self concreteStream readOnlyFileNamed: (self fullName: fileName)! ! 110839 110840!FileStream class methodsFor: 'instance creation' stamp: 'bkv 1/22/2004 17:29'! 110841readOnlyFileNamed: fileName do: aBlock 110842 "Avi Bryant says, ''This idiom is quite common in other languages that make heavy use of closures (i.e. Lisp (with-file 'foo' (f) ...) and Ruby (File.open('foo'){|f|...})). It's time Squeak had it, too.'' 110843 110844 Returns the result of aBlock." 110845 110846 ^ self detectFile: [ self readOnlyFileNamed: fileName ] do: aBlock! ! 110847 110848 110849!FileStream class methodsFor: 'utils' stamp: 'stephane.ducasse 7/10/2009 16:30'! 110850convertCRtoLF: fileName 110851 "Convert the given file to LF line endings. Put the result in a file with the extention '.lf'" 110852 110853 | in out c justPutCR | 110854 in := (self readOnlyFileNamed: fileName) binary. 110855 out := (self newFileNamed: fileName, '.lf') binary. 110856 justPutCR := false. 110857 [in atEnd] whileFalse: [ 110858 c := in next. 110859 c = 10 110860 ifTrue: [ 110861 out nextPut: 13. 110862 justPutCR := true] 110863 ifFalse: [ 110864 (justPutCR and: [c = 10]) ifFalse: [out nextPut: c]. 110865 justPutCR := false]]. 110866 in close. 110867 out close. 110868! ! 110869 110870 110871!FileStream class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 07:51'! 110872writeSourceCodeFrom: aStream baseName: baseName isSt: stOrCsFlag useHtml: useHtml 110873 110874 | extension converter f fileName | 110875 self deprecated: 'Use ''writeSourceCodeFrom: aStream baseName: baseName isSt: stOrCsFlag'' instead.'. 110876 110877 aStream contents isAsciiString ifTrue: [ 110878 stOrCsFlag ifTrue: [ 110879 extension := (FileDirectory dot, FileStream st). 110880 ] ifFalse: [ 110881 extension := (FileDirectory dot, FileStream cs). 110882 ]. 110883 converter := MacRomanTextConverter new. 110884 ] ifFalse: [ 110885 stOrCsFlag ifTrue: [ 110886 extension := (FileDirectory dot, FileStream st "multiSt"). 110887 ] ifFalse: [ 110888 extension := (FileDirectory dot, FileStream cs "multiCs"). 110889 ]. 110890 converter := UTF8TextConverter new. 110891 ]. 110892 fileName := useHtml ifTrue: [baseName, '.html'] ifFalse: [baseName, extension]. 110893 f := FileStream newFileNamed: fileName. 110894 f ifNil: [^ self error: 'Cannot open file']. 110895 (converter isMemberOf: UTF8TextConverter) 110896 ifTrue: [f binary. 110897 UTF8TextConverter writeBOMOn: f]. 110898 f text. 110899 f converter: converter. 110900 f nextPutAll: aStream contents. 110901 f close. 110902! ! 110903Error subclass: #FileStreamException 110904 instanceVariableNames: 'fileName' 110905 classVariableNames: '' 110906 poolDictionaries: '' 110907 category: 'Exceptions-Kernel'! 110908 110909!FileStreamException methodsFor: 'exceptionbuilder' stamp: 'mir 2/23/2000 20:13'! 110910fileName: aFileName 110911 fileName := aFileName! ! 110912 110913 110914!FileStreamException methodsFor: 'exceptiondescription' stamp: 'mir 2/25/2000 17:29'! 110915fileName 110916 ^fileName! ! 110917 110918!FileStreamException methodsFor: 'exceptiondescription' stamp: 'mir 2/23/2000 20:13'! 110919isResumable 110920 "Determine whether an exception is resumable." 110921 110922 ^true! ! 110923 110924!FileStreamException methodsFor: 'exceptiondescription' stamp: 'mir 2/23/2000 20:14'! 110925messageText 110926 110927 "Return an exception's message text." 110928 110929 ^messageText == nil 110930 ifTrue: [fileName printString] 110931 ifFalse: [messageText]! ! 110932 110933"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 110934 110935FileStreamException class 110936 instanceVariableNames: ''! 110937 110938!FileStreamException class methodsFor: 'exceptioninstantiator' stamp: 'mir 2/23/2000 20:12'! 110939fileName: aFileName 110940 ^self new fileName: aFileName! ! 110941ClassTestCase subclass: #FileStreamTest 110942 instanceVariableNames: '' 110943 classVariableNames: '' 110944 poolDictionaries: '' 110945 category: 'Tests-Files'! 110946 110947!FileStreamTest methodsFor: 'as yet unclassified' stamp: 'SergeStinckwich 5/27/2008 23:14'! 110948testDetectFileDo 110949 [(FileDirectory default forceNewFileNamed: 'filestream.tst') nextPutAll: '42'; 110950 close. 110951 FileStream 110952 detectFile: [FileDirectory default oldFileNamed: 'filestream.tst'] 110953 do: [:file | 110954 self assert: file notNil. 110955 self deny: file closed. 110956 self assert: file contentsOfEntireFile = '42']] 110957 ensure: [FileDirectory default deleteFileNamed: 'filestream.tst' ifAbsent: nil]! ! 110958Url subclass: #FileUrl 110959 instanceVariableNames: 'host path isAbsolute' 110960 classVariableNames: '' 110961 poolDictionaries: '' 110962 category: 'Network-Url'! 110963!FileUrl commentStamp: 'gk 10/21/2005 10:58' prior: 0! 110964This class models a file URL according to (somewhat) RFC1738, see http://www.w3.org/Addressing/rfc1738.txt 110965 110966Here is the relevant part of the RFC: 110967 1109683.10 FILES 110969 110970 The file URL scheme is used to designate files accessible on a 110971 particular host computer. This scheme, unlike most other URL schemes, 110972 does not designate a resource that is universally accessible over the 110973 Internet. 110974 110975 A file URL takes the form: 110976 110977 file://<host>/<path> 110978 110979 where <host> is the fully qualified domain name of the system on 110980 which the <path> is accessible, and <path> is a hierarchical 110981 directory path of the form <directory>/<directory>/.../<name>. 110982 110983 For example, a VMS file 110984 110985 DISK$USER:[MY.NOTES]NOTE123456.TXT 110986 110987 might become 110988 110989 <URL:file://vms.host.edu/disk$user/my/notes/note12345.txt> 110990 110991 As a special case, <host> can be the string "localhost" or the empty 110992 string; this is interpreted as `the machine from which the URL is 110993 being interpreted'. 110994 110995 The file URL scheme is unusual in that it does not specify an 110996 Internet protocol or access method for such files; as such, its 110997 utility in network protocols between hosts is limited. 110998 110999From the above we can conclude that the RFC says that the <path> part never starts or ends with a slash and is always absolute. If the last name can be a directory instead of a file is not specified clearly. 111000 111001The path is stored as a SequenceableCollection of path parts. 111002 111003Notes regarding non RFC features in this class: 111004 111005- If the last path part is the empty string, then the FileUrl is referring to a directory. This is also shown with a trailing slash when converted to a String. 111006 111007- The FileUrl has an attribute isAbsolute which signals if the path should be considered absolute or relative to the current directory. This distinction is not visible in the String representation of FileUrl, since the RFC does not have that. 111008 111009- Fragment is supported (kept for historical reasons) 111010 111011! 111012 111013 111014!FileUrl methodsFor: 'access' stamp: 'gk 10/21/2005 10:21'! 111015directoryUrl 111016 "The path always has at least one element so this works." 111017 111018 ^self copy path: (path copyFrom: 1 to: path size - 1)! ! 111019 111020!FileUrl methodsFor: 'access' stamp: 'gk 10/21/2005 11:14'! 111021fileName 111022 "Return the last part of the path, 111023 most often a filename but can also be a directory." 111024 111025 ^self path last! ! 111026 111027!FileUrl methodsFor: 'access' stamp: 'ar 10/13/2004 17:54'! 111028pathForFile 111029 "Path using local file system's delimiter. $\ or $:" 111030 ^FileDirectory default pathFromUrl: self! ! 111031 111032 111033!FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 10:16'! 111034host 111035 "Return the host name, either 'localhost', '', or a fully qualified domain name." 111036 111037 ^host ifNil: ['']! ! 111038 111039!FileUrl methodsFor: 'accessing' stamp: 'gk 2/12/2004 16:22'! 111040host: hostName 111041 "Set the host name, either 'localhost', '', or a fully qualified domain name." 111042 111043 host := hostName! ! 111044 111045!FileUrl methodsFor: 'accessing' stamp: 'gk 10/21/2005 11:12'! 111046isAbsolute 111047 "Should the path be considered absolute to 111048 the filesystem instead of relative to the default directory?" 111049 111050 ^isAbsolute! ! 111051 111052!FileUrl methodsFor: 'accessing' stamp: 'gk 10/21/2005 11:13'! 111053isAbsolute: aBoolean 111054 "Set if the path should be considered absolute to 111055 the filesystem instead of relative to the default directory." 111056 111057 isAbsolute := aBoolean! ! 111058 111059!FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 00:15'! 111060path 111061 "Return an ordered collection of the path elements." 111062 111063 ^path! ! 111064 111065!FileUrl methodsFor: 'accessing' stamp: 'gk 10/21/2005 11:11'! 111066path: aCollection 111067 "Set the collection of path elements." 111068 111069 path := aCollection! ! 111070 111071 111072!FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34'! 111073scheme 111074 ^self class schemeName! ! 111075 111076!FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34'! 111077schemeName 111078 ^self class schemeName! ! 111079 111080 111081!FileUrl methodsFor: 'copying' stamp: 'gk 10/21/2005 11:15'! 111082copy 111083 "Be sure not to share the path with the copy." 111084 111085 ^self clone path: path copy! ! 111086 111087 111088!FileUrl methodsFor: 'downloading' stamp: 'gk 2/10/2004 13:06'! 111089default 111090 "Use the default local Squeak file directory." 111091 111092 | local | 111093 local := self class pathParts: (FileDirectory default pathParts), #('') isAbsolute: true. 111094 self privateInitializeFromText: self pathString relativeTo: local. 111095 "sets absolute also"! ! 111096 111097!FileUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:42'! 111098hasContents 111099 ^true! ! 111100 111101!FileUrl methodsFor: 'downloading' stamp: 'PeterHugossonMiller 9/3/2009 01:33'! 111102retrieveContents 111103 | file pathString s type entries | 111104 pathString := self pathForFile. 111105 111106 "We pursue the execution even if the file is not found" 111107 [file := FileStream readOnlyFileNamed: pathString. 111108 type := file mimeTypes. 111109 type ifNotNil: [type := type first]. 111110 type ifNil: [type := MIMEDocument guessTypeFromName: self path last]. 111111 ^MIMELocalFileDocument 111112 contentStream: file 111113 mimeType: type] on: FileDoesNotExistException do:[:ex| ]. 111114 111115 "see if it's a directory... If not, then nil is returned" 111116 entries := [(FileDirectory on: pathString) entries] 111117 on: InvalidDirectoryError do: [:ex| ^ nil]. 111118 111119 s := String new writeStream. 111120 (pathString endsWith: '/') ifFalse: [ pathString := pathString, '/' ]. 111121 s nextPutAll: '<title>Directory Listing for ', pathString, '</title>'. 111122 s nextPutAll: '<h1>Directory Listing for ', pathString, '</h1>'. 111123 s nextPutAll: '<ul>'. 111124 s cr. 111125 entries do: [ :entry | 111126 s nextPutAll: '<li><a href="'. 111127 s nextPutAll: entry name. 111128 s nextPutAll: '">'. 111129 s nextPutAll: entry name. 111130 s nextPutAll: '</a>'. 111131 s cr. ]. 111132 s nextPutAll: '</ul>'. 111133 ^MIMEDocument contentType: 'text/html' content: s contents url: ('file://', pathString)! ! 111134 111135 111136!FileUrl methodsFor: 'paths' stamp: 'gk 2/10/2004 00:19'! 111137pathDirString 111138 "Path to directory as url, using slash as delimiter. 111139 Filename is left out." 111140 111141 ^String streamContents: [ :s | 111142 isAbsolute ifTrue: [ s nextPut: $/ ]. 111143 1 to: self path size - 1 do: [ :ii | 111144 s nextPutAll: (path at: ii); nextPut: $/]]! ! 111145 111146!FileUrl methodsFor: 'paths' stamp: 'gk 10/21/2005 10:01'! 111147pathForDirectory 111148 "Path using local file system's pathname delimiter. 111149 DOS paths with drive letters should not 111150 be prepended with a delimiter even though 111151 they are absolute. Filename is left out." 111152 111153 | delimiter | 111154 delimiter := FileDirectory default pathNameDelimiter. 111155 ^String streamContents: [ :s | 111156 (self isAbsolute and: [self firstPartIsDriveLetter not]) 111157 ifTrue: [ s nextPut: delimiter ]. 111158 1 to: self path size - 1 do: [ :ii | 111159 s nextPutAll: (path at: ii); nextPut: delimiter]]! ! 111160 111161!FileUrl methodsFor: 'paths' stamp: 'gk 2/10/2004 10:22'! 111162pathString 111163 "Path as it appears in a URL with $/ as delimiter." 111164 111165 | first | 111166 ^String streamContents: [ :s | 111167 "isAbsolute ifTrue:[ s nextPut: $/ ]." 111168 first := true. 111169 self path do: [ :p | 111170 first ifFalse: [ s nextPut: $/ ]. 111171 first := false. 111172 s nextPutAll: p encodeForHTTP ] ]! ! 111173 111174 111175!FileUrl methodsFor: 'printing' stamp: 'fbs 2/2/2005 13:09'! 111176printOn: aStream 111177 "Return the FileUrl according to RFC1738 plus supporting fragments: 111178 'file://<host>/<path>#<fragment>' 111179 Note that <host> being '' is equivalent to 'localhost'. 111180 Note: The pathString can not start with a leading $/ 111181 to indicate an 'absolute' file path. 111182 This is not according to RFC1738 where the path should have 111183 no leading or trailing slashes, and always 111184 be considered absolute relative to the filesystem." 111185 111186 aStream nextPutAll: self schemeName, '://'. 111187 111188 host ifNotNil: [aStream nextPutAll: host]. 111189 111190 aStream 111191 nextPut: $/; 111192 nextPutAll: self pathString. 111193 111194 fragment ifNotNil: 111195 [aStream 111196 nextPut: $#; 111197 nextPutAll: fragment encodeForHTTP].! ! 111198 111199 111200!FileUrl methodsFor: 'testing' stamp: 'gk 2/9/2004 20:32'! 111201firstPartIsDriveLetter 111202 "Return true if the first part of the path is a letter 111203 followed by a $: like 'C:' " 111204 111205 | firstPart | 111206 path isEmpty ifTrue: [^false]. 111207 firstPart := path first. 111208 ^firstPart size = 2 and: [ 111209 firstPart first isLetter 111210 and: [firstPart last = $:]]! ! 111211 111212 111213!FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/10/2004 13:05'! 111214host: aHostString pathParts: aCollection isAbsolute: aBoolean 111215 111216 host := aHostString. 111217 path := aCollection. 111218 isAbsolute := aBoolean! ! 111219 111220!FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/12/2004 16:01'! 111221initializeFromPathString: aPathString 111222 "<aPathString> is a file path as a String. 111223 We construct a path collection using various heuristics." 111224 111225 | pathString hasDriveLetter | 111226 pathString := aPathString. 111227 pathString isEmpty ifTrue: [pathString := '/']. 111228 path := (pathString findTokens: '/') collect: [:token | token unescapePercents]. 111229 111230 "A path like 'C:' refers in practice to 'c:/'" 111231 ((pathString endsWith: '/') or: 111232 [(hasDriveLetter := self firstPartIsDriveLetter) and: [path size = 1]]) 111233 ifTrue: [path add: '']. 111234 111235 "Decide if we are absolute by checking for leading $/ or 111236 beginning with drive letter. Smarts for other OSes?" 111237 self isAbsolute: ((pathString beginsWith: '/') 111238 or: [hasDriveLetter ifNil: [self firstPartIsDriveLetter]])! ! 111239 111240!FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/10/2004 13:04'! 111241pathParts: aCollection isAbsolute: aBoolean 111242 111243 ^self host: nil pathParts: aCollection isAbsolute: aBoolean! ! 111244 111245!FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/12/2004 16:11'! 111246privateInitializeFromText: aString 111247 "Calculate host and path from a file URL in String format. 111248 Some malformed formats are allowed and interpreted by guessing." 111249 111250 | schemeName pathString bare hasDriveLetter stream char i | 111251 bare := aString withBlanksTrimmed. 111252 schemeName := Url schemeNameForString: bare. 111253 (schemeName isNil or: [schemeName ~= self schemeName]) 111254 ifTrue: [ 111255 host := ''. 111256 pathString := bare] 111257 ifFalse: [ 111258 "First remove schemeName and colon" 111259 bare := bare copyFrom: (schemeName size + 2) to: bare size. 111260 "A proper file URL then has two slashes before host, 111261 A malformed URL is interpreted as using syntax file:<path>." 111262 (bare beginsWith: '//') 111263 ifTrue: [i := bare indexOf: $/ startingAt: 3. 111264 i=0 ifTrue: [ 111265 host := bare copyFrom: 3 to: bare size. 111266 pathString := ''] 111267 ifFalse: [ 111268 host := bare copyFrom: 3 to: i-1. 111269 pathString := bare copyFrom: host size + 3 to: bare size]] 111270 ifFalse: [host := ''. 111271 pathString := bare]]. 111272 self initializeFromPathString: pathString 111273! ! 111274 111275!FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/12/2004 16:29'! 111276privateInitializeFromText: pathString relativeTo: aUrl 111277 "<pathString> should be a filesystem path. 111278 This url is adjusted to be aUrl + the path." 111279 111280 | bare newPath | 111281 self host: aUrl host. 111282 self initializeFromPathString: pathString. 111283 self isAbsolute: aUrl isAbsolute. 111284 111285 newPath := aUrl path copy. 111286 newPath removeLast. "empty string that says its a directory" 111287 path do: [ :token | 111288 ((token ~= '..') and: [token ~= '.']) ifTrue: [ 111289 newPath addLast: token unescapePercents ]. 111290 token = '..' ifTrue: [ 111291 newPath isEmpty ifFalse: [ 111292 newPath last = '..' ifFalse: [ newPath removeLast ] ] ]. 111293 "token = '.' do nothing" ]. 111294 path := newPath 111295 111296 ! ! 111297 111298"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 111299 111300FileUrl class 111301 instanceVariableNames: ''! 111302 111303!FileUrl class methodsFor: 'constants' stamp: 'gk 2/10/2004 10:33'! 111304schemeName 111305 ^'file'! ! 111306 111307 111308!FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 12:16'! 111309absoluteFromText: aString 111310 "Method that can be called explicitly to create a FileUrl." 111311 111312 ^self new privateInitializeFromText: aString! ! 111313 111314!FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 13:04'! 111315host: aHost pathParts: aCollectionOfPathParts isAbsolute: aBoolean 111316 "Create a FileUrl." 111317 111318 ^self new host: aHost pathParts: aCollectionOfPathParts isAbsolute: aBoolean! ! 111319 111320!FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 13:10'! 111321pathParts: aCollectionOfPathParts 111322 "Create a FileUrl." 111323 111324 ^self host: nil pathParts: aCollectionOfPathParts isAbsolute: true! ! 111325 111326!FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 13:06'! 111327pathParts: aCollectionOfPathParts isAbsolute: aBoolean 111328 "Create a FileUrl." 111329 111330 ^self host: nil pathParts: aCollectionOfPathParts isAbsolute: aBoolean! ! 111331ClassTestCase subclass: #FileUrlTest 111332 instanceVariableNames: '' 111333 classVariableNames: '' 111334 poolDictionaries: '' 111335 category: 'NetworkTests-Url'! 111336 111337!FileUrlTest methodsFor: 'testing' stamp: 'fbs 2/2/2005 12:43'! 111338testAsString 111339 | target url | 111340 target := 'file://localhost/etc/rc.conf'. 111341 url := target asUrl. 111342 self assert: url asString = target. 111343 ! ! 111344StringHolder subclass: #FillInTheBlank 111345 instanceVariableNames: 'acceptOnCR done responseUponCancel' 111346 classVariableNames: '' 111347 poolDictionaries: '' 111348 category: 'ST80-Menus'! 111349!FillInTheBlank commentStamp: '<historical>' prior: 0! 111350I represent a prompt for string input from the user. The user is asked to type in and edit a string. The resulting string is supplied as the argument to a client-supplied action block. 111351! 111352 111353 111354!FillInTheBlank methodsFor: 'accessing' stamp: 'jm 4/28/1998 06:18'! 111355acceptOnCR 111356 "Answer whether a carriage return should cause input to be accepted." 111357 111358 ^ acceptOnCR 111359! ! 111360 111361!FillInTheBlank methodsFor: 'accessing' stamp: 'jm 4/28/1998 06:18'! 111362acceptOnCR: aBoolean 111363 111364 acceptOnCR := aBoolean. 111365! ! 111366 111367!FillInTheBlank methodsFor: 'accessing' stamp: 'jm 5/6/1998 15:13'! 111368done 111369 "Answer whether the user has ended the interaction." 111370 111371 ^ done 111372! ! 111373 111374!FillInTheBlank methodsFor: 'accessing' stamp: 'jm 5/6/1998 15:13'! 111375done: aBoolean 111376 111377 done := aBoolean. 111378! ! 111379 111380!FillInTheBlank methodsFor: 'accessing' stamp: 'sw 1/31/2000 14:45'! 111381responseUponCancel: resp 111382 responseUponCancel := resp! ! 111383 111384!FillInTheBlank methodsFor: 'accessing' stamp: 'sw 1/31/2000 14:47'! 111385setResponseForCancel 111386 self contents: responseUponCancel! ! 111387 111388 111389!FillInTheBlank methodsFor: 'initialization' stamp: 'sw 1/31/2000 14:42'! 111390initialize 111391 111392 super initialize. 111393 acceptOnCR := false. 111394 done := false. 111395 responseUponCancel := '' 111396! ! 111397 111398"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 111399 111400FillInTheBlank class 111401 instanceVariableNames: ''! 111402 111403!FillInTheBlank class methodsFor: 'instance creation' stamp: 'alain.plantec 5/30/2008 13:16'! 111404multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight 111405 "Create a multi-line instance of me whose question is queryString with 111406 the given initial answer. Invoke it centered at the given point, and 111407 answer the string the user accepts. Answer nil if the user cancels. An 111408 empty string returned means that the ussr cleared the editing area and 111409 then hit 'accept'. Because multiple lines are invited, we ask that the user 111410 use the ENTER key, or (in morphic anyway) hit the 'accept' button, to 111411 submit; that way, the return key can be typed to move to the next line. 111412 NOTE: The ENTER key does not work on Windows platforms." 111413 111414 "FillInTheBlank 111415 multiLineRequest: 111416'Enter several lines; end input by accepting 111417or canceling via menu or press Alt+s/Alt+l' 111418 centerAt: Display center 111419 initialAnswer: 'Once upon a time...' 111420 answerHeight: 200" 111421 111422 ^self fillInTheBlankMorphClass 111423 request: queryString 111424 initialAnswer: defaultAnswer 111425 centerAt: aPoint 111426 inWorld: self currentWorld 111427 onCancelReturn: nil 111428 acceptOnCR: false! ! 111429 111430!FillInTheBlank class methodsFor: 'instance creation' stamp: 'ar 3/18/2001 00:53'! 111431request: queryString 111432 "Create an instance of me whose question is queryString. Invoke it 111433 centered at the cursor, and answer the string the user accepts. Answer 111434 the empty string if the user cancels." 111435 111436 "FillInTheBlank request: 'Your name?'" 111437 111438 ^ self 111439 request: queryString 111440 initialAnswer: '' 111441 centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint! ! 111442 111443!FillInTheBlank class methodsFor: 'instance creation' stamp: 'ar 3/18/2001 00:54'! 111444request: queryString initialAnswer: defaultAnswer 111445 "Create an instance of me whose question is queryString with the given 111446 initial answer. Invoke it centered at the given point, and answer the 111447 string the user accepts. Answer the empty string if the user cancels." 111448 111449 "FillInTheBlank 111450 request: 'What is your favorite color?' 111451 initialAnswer: 'red, no blue. Ahhh!!'" 111452 111453 ^ self 111454 request: queryString 111455 initialAnswer: defaultAnswer 111456 centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint! ! 111457 111458!FillInTheBlank class methodsFor: 'instance creation' stamp: 'alain.plantec 5/30/2008 13:17'! 111459request: queryString initialAnswer: defaultAnswer centerAt: aPoint 111460 "Create an instance of me whose question is queryString with the given 111461 initial answer. Invoke it centered at the given point, and answer the 111462 string the user accepts. Answer the empty string if the user cancels." 111463 111464 "FillInTheBlank 111465 request: 'Type something, then type CR.' 111466 initialAnswer: 'yo ho ho!!' 111467 centerAt: Display center" 111468 111469 ^self fillInTheBlankMorphClass 111470 request: queryString 111471 initialAnswer: defaultAnswer 111472 centerAt: aPoint! ! 111473 111474!FillInTheBlank class methodsFor: 'instance creation' stamp: 'alain.plantec 5/30/2008 13:18'! 111475requestPassword: queryString 111476 "Create an instance of me whose question is queryString. Invoke it centered 111477 at the cursor, and answer the string the user accepts. Answer the empty 111478 string if the user cancels." 111479 111480 "FillInTheBlank requestPassword: 'POP password'" 111481 111482 ^self fillInTheBlankMorphClass requestPassword: queryString! ! 111483 111484 111485!FillInTheBlank class methodsFor: 'private' stamp: 'sma 6/18/2000 10:39'! 111486fillInTheBlankMorphClass 111487 "By factoring out this class references, it becomes possible to discard 111488 morphic by simply removing this class. All calls to this method needs 111489 to be protected by 'Smalltalk isMorphic' tests." 111490 111491 ^ FillInTheBlankMorph! ! 111492RectangleMorph subclass: #FillInTheBlankMorph 111493 instanceVariableNames: 'response done textPane responseUponCancel' 111494 classVariableNames: '' 111495 poolDictionaries: '' 111496 category: 'Morphic-Windows'! 111497 111498!FillInTheBlankMorph methodsFor: '*services-base' stamp: 'rr 1/9/2006 11:52'! 111499selection 111500 "answers what is actually selected in the morph" 111501 ^ textPane selectionInterval! ! 111502 111503 111504!FillInTheBlankMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 14:03'! 111505response 111506 111507 ^ response 111508! ! 111509 111510!FillInTheBlankMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 14:22'! 111511response: aText 111512 "Sent when text pane accepts." 111513 111514 response := aText asString. 111515 done := true. 111516 ^ true 111517! ! 111518 111519!FillInTheBlankMorph methodsFor: 'accessing' stamp: 'di 5/22/1998 00:58'! 111520selectionInterval 111521 ^ 1 to: response size 111522! ! 111523 111524 111525!FillInTheBlankMorph methodsFor: 'event handling' stamp: 'ar 10/7/2000 15:47'! 111526handlesMouseDown: evt 111527 ^true! ! 111528 111529!FillInTheBlankMorph methodsFor: 'event handling' stamp: 'md 10/22/2003 16:20'! 111530mouseDown: evt 111531 (self containsPoint: evt position) ifFalse:[^ Beeper beep]. "sent in response to outside modal click" 111532 evt hand grabMorph: self. "allow repositioning"! ! 111533 111534 111535!FillInTheBlankMorph methodsFor: 'geometry' stamp: 'jrp 7/6/2005 21:42'! 111536extent: aPoint 111537 "change the receiver's extent" 111538 111539 super extent: aPoint . 111540 self setDefaultParameters. 111541 self updateColor! ! 111542 111543 111544!FillInTheBlankMorph methodsFor: 'grabbing/dropping' stamp: 'ar 10/7/2000 15:50'! 111545undoGrabCommand 111546 ^nil! ! 111547 111548 111549!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'dgd 4/3/2006 13:34'! 111550createAcceptButton 111551 "create the [accept] button" 111552 | result frame | 111553 result := SimpleButtonMorph new target: self; 111554 color: ColorTheme current okColor. 111555 result 111556 borderColor: (Preferences menuAppearance3d 111557 ifTrue: [#raised] 111558 ifFalse: [result color twiceDarker]). 111559 result label: 'Accept(s)' translated; 111560 actionSelector: #accept. 111561 result setNameTo: 'accept'. 111562 frame := LayoutFrame new. 111563 frame rightFraction: 0.5; 111564 rightOffset: -10; 111565 bottomFraction: 1.0; 111566 bottomOffset: -2. 111567 result layoutFrame: frame. 111568 self addMorph: result. 111569 self 111570 updateColor: result 111571 color: result color 111572 intensity: 2. 111573 ^ result! ! 111574 111575!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'dgd 4/3/2006 13:34'! 111576createCancelButton 111577 "create the [cancel] button" 111578 | result frame | 111579 result := SimpleButtonMorph new target: self; 111580 color: ColorTheme current cancelColor. 111581 result 111582 borderColor: (Preferences menuAppearance3d 111583 ifTrue: [#raised] 111584 ifFalse: [result color twiceDarker]). 111585 result label: 'Cancel(l)' translated; 111586 actionSelector: #cancel. 111587 result setNameTo: 'cancel'. 111588 frame := LayoutFrame new. 111589 frame leftFraction: 0.5; 111590 leftOffset: 10; 111591 bottomFraction: 1.0; 111592 bottomOffset: -2. 111593 result layoutFrame: frame. 111594 self addMorph: result. 111595 self 111596 updateColor: result 111597 color: result color 111598 intensity: 2. 111599 ^ result! ! 111600 111601!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'yo 7/2/2004 17:52'! 111602createQueryTextMorph: queryString 111603 "create the queryTextMorph" 111604 | result frame | 111605 result := TextMorph new contents: queryString. 111606 result setNameTo: 'query' translated. 111607 result lock. 111608 frame := LayoutFrame new. 111609 frame topFraction: 0.0; 111610 topOffset: 2. 111611 frame leftFraction: 0.5; 111612 leftOffset: (result width // 2) negated. 111613 result layoutFrame: frame. 111614 self addMorph: result. 111615 ^ result! ! 111616 111617!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:56'! 111618createTextPaneExtent: answerExtent acceptBoolean: acceptBoolean topOffset: topOffset buttonAreaHeight: buttonAreaHeight 111619 "create the textPane" 111620 | result frame | 111621 result := PluggableTextMorph 111622 on: self 111623 text: #response 111624 accept: #response: 111625 readSelection: #selectionInterval 111626 menu: #codePaneMenu:shifted:. 111627 result extent: answerExtent. 111628 result hResizing: #spaceFill; 111629 vResizing: #spaceFill. 111630 result borderWidth: 1. 111631 result hasUnacceptedEdits: true. 111632 result acceptOnCR: acceptBoolean. 111633 result setNameTo: 'textPane'. 111634 frame := LayoutFrame new. 111635 frame leftFraction: 0.0; 111636 rightFraction: 1.0; 111637 topFraction: 0.0; 111638 topOffset: topOffset; 111639 bottomFraction: 1.0; 111640 bottomOffset: buttonAreaHeight negated. 111641 result layoutFrame: frame. 111642 self addMorph: result. 111643 ^ result! ! 111644 111645!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! 111646defaultColor 111647 "answer the default color/fill style for the receiver" 111648 ^ Color white! ! 111649 111650!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 22:35'! 111651delete 111652 111653 self breakDependents. 111654 super delete.! ! 111655 111656!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:57'! 111657initialize 111658 111659 super initialize. 111660 self setDefaultParameters. 111661 self extent: 400 @ 150. 111662 responseUponCancel := ''. 111663 Preferences roundedMenuCorners 111664 ifTrue: [self useRoundedCorners]. 111665 ! ! 111666 111667!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sw 1/31/2000 11:01'! 111668responseUponCancel: anObject 111669 responseUponCancel := anObject 111670! ! 111671 111672!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'dgd 4/3/2006 10:54'! 111673setDefaultParameters 111674 "change the receiver's appareance parameters" 111675 111676 | colorFromMenu worldColor menuColor | 111677 111678 colorFromMenu := Preferences menuColorFromWorld 111679 and: [Display depth > 4] 111680 and: [(worldColor := self currentWorld color) isColor]. 111681 111682 menuColor := colorFromMenu 111683 ifTrue: [worldColor luminance > 0.7 111684 ifTrue: [worldColor mixed: 0.85 with: Color black] 111685 ifFalse: [worldColor mixed: 0.4 with: Color white]] 111686 ifFalse: [Preferences menuColor]. 111687 111688 self color: menuColor. 111689 self borderWidth: Preferences menuBorderWidth. 111690 111691 Preferences menuAppearance3d ifTrue: [ 111692 self borderStyle: BorderStyle thinGray. 111693 self 111694 addDropShadow; 111695 shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.666); 111696 shadowOffset: 1 @ 1 111697 ] 111698 ifFalse: [ 111699 | menuBorderColor | 111700 menuBorderColor := colorFromMenu 111701 ifTrue: [worldColor muchDarker] 111702 ifFalse: [Preferences menuBorderColor]. 111703 self borderColor: menuBorderColor. 111704 ]. 111705 111706 111707 self layoutInset: 3. 111708! ! 111709 111710!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'ar 11/4/2000 23:21'! 111711setPasswordQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: acceptBoolean 111712 | pane | 111713 self setQuery: queryString 111714 initialAnswer: initialAnswer 111715 answerHeight: answerHeight 111716 acceptOnCR: acceptBoolean. 111717 pane := self submorphNamed: 'textPane'. 111718 pane font: (StrikeFont passwordFontSize: 12).! ! 111719 111720!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:58'! 111721setQuery: queryString initialAnswer: initialAnswer answerExtent: answerExtent acceptOnCR: acceptBoolean 111722 | query topOffset accept cancel buttonAreaHeight | 111723 response := initialAnswer. 111724 done := false. 111725 self removeAllMorphs. 111726 self layoutPolicy: ProportionalLayout new. 111727 query := self createQueryTextMorph: queryString. 111728 topOffset := query height + 4. 111729 accept := self createAcceptButton. 111730 cancel := self createCancelButton. 111731 buttonAreaHeight := (accept height max: cancel height) 111732 + 4. 111733 textPane := self 111734 createTextPaneExtent: answerExtent 111735 acceptBoolean: acceptBoolean 111736 topOffset: topOffset 111737 buttonAreaHeight: buttonAreaHeight. 111738 self extent: (query extent x max: answerExtent x) 111739 + 4 @ (topOffset + answerExtent y + 4 + buttonAreaHeight). 111740 ! ! 111741 111742!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'NS 8/1/2000 11:44'! 111743setQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: acceptBoolean 111744 self setQuery: queryString initialAnswer: initialAnswer 111745 answerExtent: (self class defaultAnswerExtent x @ answerHeight) 111746 acceptOnCR: acceptBoolean 111747! ! 111748 111749!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:58'! 111750updateColor 111751 "update the recevier's fillStyle" 111752 | textPaneBorderColor | 111753 self 111754 updateColor: self 111755 color: self color 111756 intensity: 1. 111757 textPane isNil 111758 ifTrue: [^ self]. 111759 textPaneBorderColor := self borderColor == #raised 111760 ifTrue: [#inset] 111761 ifFalse: [self borderColor]. 111762 textPane borderColor: textPaneBorderColor! ! 111763 111764!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jrp 7/6/2005 21:44'! 111765updateColor: aMorph color: aColor intensity: anInteger 111766 "update the apareance of aMorph" 111767 | fill | 111768 Preferences gradientMenu 111769 ifFalse: [^ self]. 111770 111771 fill := GradientFillStyle ramp: {0.0 -> Color white. 1 -> aColor}. 111772 fill radial: false; 111773 origin: aMorph topLeft; 111774 direction: 0 @ aMorph height. 111775 aMorph fillStyle: fill! ! 111776 111777 111778!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'marcus.denker 11/10/2008 10:04'! 111779getUserResponse 111780 "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." 111781 "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." 111782 111783 | w | 111784 w := self world. 111785 w ifNil: [^ response]. 111786 111787 (ProvideAnswerNotification signal: 111788 (self findA: TextMorph) userString) ifNotNil: 111789 [:answer | 111790 self delete. 111791 w doOneCycle. 111792 ^ response := (answer == #default) ifTrue: [response] ifFalse: [answer]]. 111793 111794 done := false. 111795 w activeHand newKeyboardFocus: textPane. 111796 [done] whileFalse: [w doOneCycle]. 111797 self delete. 111798 w doOneCycle. 111799 ^ response 111800! ! 111801 111802!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'RAA 7/19/2000 20:40'! 111803morphicLayerNumber 111804 111805 ^10.6! ! 111806 111807 111808!FillInTheBlankMorph methodsFor: 'menu' stamp: 'jm 5/4/1998 14:21'! 111809accept 111810 "Sent by the accept button." 111811 111812 textPane accept. 111813! ! 111814 111815!FillInTheBlankMorph methodsFor: 'menu' stamp: 'sw 1/31/2000 11:11'! 111816cancel 111817 "Sent by the cancel button." 111818 111819 response := responseUponCancel. 111820 done := true. 111821! ! 111822 111823!FillInTheBlankMorph methodsFor: 'menu' stamp: 'jm 5/4/1998 15:15'! 111824codePaneMenu: aMenu shifted: shifted 111825 111826 ^ StringHolder new codePaneMenu: aMenu shifted: shifted. 111827! ! 111828 111829"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 111830 111831FillInTheBlankMorph class 111832 instanceVariableNames: ''! 111833 111834!FillInTheBlankMorph class methodsFor: 'default constants' stamp: 'dgd 4/27/2003 17:10'! 111835defaultAnswerExtent 111836 ^ (200@60 * (Preferences standardMenuFont height / 12)) rounded! ! 111837 111838 111839!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'ar 3/18/2001 00:54'! 111840request: queryString 111841 "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels." 111842 "FillInTheBlankMorph request: 'What is your favorite color?'" 111843 111844 ^ self 111845 request: queryString 111846 initialAnswer: '' 111847 centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint! ! 111848 111849!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'ar 3/18/2001 00:54'! 111850request: queryString initialAnswer: defaultAnswer 111851 "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels." 111852 "FillInTheBlankMorph 111853 request: 'What is your favorite color?' 111854 initialAnswer: 'red, no blue. Ahhh!!'" 111855 111856 ^ self 111857 request: queryString 111858 initialAnswer: defaultAnswer 111859 centerAt: ActiveHand cursorPoint! ! 111860 111861!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'ar 3/17/2001 23:43'! 111862request: queryString initialAnswer: defaultAnswer centerAt: aPoint 111863 "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels. 111864 This variant is only for calling from within a Morphic project." 111865 "FillInTheBlankMorph 111866 request: 'Type something, then type CR.' 111867 initialAnswer: 'yo ho ho!!' 111868 centerAt: Display center" 111869 111870 ^ self 111871 request: queryString 111872 initialAnswer: defaultAnswer 111873 centerAt: aPoint 111874 inWorld: ActiveWorld 111875! ! 111876 111877!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'sw 1/31/2000 11:03'! 111878request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld 111879 "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels." 111880 "FillInTheBlankMorph 111881 request: 'Type something, then type CR.' 111882 initialAnswer: 'yo ho ho!!' 111883 centerAt: Display center" 111884 111885 ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: ''! ! 111886 111887!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'sw 2/2/2000 22:43'! 111888request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel 111889 "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel. If user hits cr, treat it as a normal accept." 111890 111891 "FillInTheBlankMorph 111892 request: 'Type something, then type CR.' 111893 initialAnswer: 'yo ho ho!!' 111894 centerAt: Display center" 111895 111896 ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: true! ! 111897 111898!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'NS 8/1/2000 11:44'! 111899request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean 111900 "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel." 111901 111902 ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint 111903 inWorld: aWorld onCancelReturn: returnOnCancel 111904 acceptOnCR: acceptBoolean answerExtent: self defaultAnswerExtent! ! 111905 111906!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'NS 8/1/2000 11:39'! 111907request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean answerExtent: answerExtent 111908 "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel." 111909 "FillInTheBlankMorph 111910 request: 'Type something, then type CR.' 111911 initialAnswer: 'yo ho ho!!' 111912 centerAt: Display center" 111913 111914 | aFillInTheBlankMorph | 111915 aFillInTheBlankMorph := self new 111916 setQuery: queryString 111917 initialAnswer: defaultAnswer 111918 answerExtent: answerExtent 111919 acceptOnCR: acceptBoolean. 111920 aFillInTheBlankMorph responseUponCancel: returnOnCancel. 111921 aWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint. 111922 ^ aFillInTheBlankMorph getUserResponse 111923! ! 111924 111925!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'NS 8/1/2000 11:43'! 111926request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean answerHeight: answerHeight 111927 "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel." 111928 ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint 111929 inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean 111930 answerExtent: self defaultAnswerExtent x @ answerHeight! ! 111931 111932!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'bolot 5/18/2000 13:57'! 111933requestPassword: queryString 111934 "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels." 111935 "use password font" 111936 "FillInTheBlankMorph requestPassword: 'Password?'" 111937 111938 ^ self 111939 requestPassword: queryString 111940 initialAnswer: '' 111941 centerAt: Sensor cursorPoint 111942 inWorld: World 111943 onCancelReturn: '' 111944 acceptOnCR: true 111945! ! 111946 111947!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'bolot 5/18/2000 13:53'! 111948requestPassword: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean 111949 "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel." 111950 "FillInTheBlankMorph 111951 request: 'Type something, then type CR.' 111952 initialAnswer: 'yo ho ho!!' 111953 centerAt: Display center" 111954 111955 | aFillInTheBlankMorph | 111956 aFillInTheBlankMorph := self new 111957 setPasswordQuery: queryString 111958 initialAnswer: defaultAnswer 111959 answerHeight: 50 111960 acceptOnCR: acceptBoolean. 111961 aFillInTheBlankMorph responseUponCancel: returnOnCancel. 111962 aWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint. 111963 ^ aFillInTheBlankMorph getUserResponse 111964! ! 111965Object subclass: #FillStyle 111966 instanceVariableNames: '' 111967 classVariableNames: '' 111968 poolDictionaries: '' 111969 category: 'Balloon-Fills'! 111970!FillStyle commentStamp: '<historical>' prior: 0! 111971FillStyle is an abstract base class for fills in the BalloonEngine.! 111972 111973 111974!FillStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/21/2008 16:35'! 111975fillRectangle: aRectangle on: aCanvas 111976 "Fill the given rectangle on the given canvas with the receiver." 111977 111978 aCanvas fillRectangle: aRectangle basicFillStyle: self! ! 111979 111980!FillStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/20/2008 23:03'! 111981isCompositeFill 111982 "Answer whether the receiver is a composite fill. 111983 False by default." 111984 111985 ^false! ! 111986 111987 111988!FillStyle methodsFor: 'accessing' stamp: 'ar 1/14/1999 15:23'! 111989scaledPixelValue32 111990 "Return a pixel value of depth 32 for the primary color in the fill style" 111991 ^self asColor scaledPixelValue32! ! 111992 111993 111994!FillStyle methodsFor: 'converting' stamp: 'ar 11/9/1998 13:53'! 111995asColor 111996 ^self subclassResponsibility! ! 111997 111998!FillStyle methodsFor: 'converting' stamp: 'ar 6/4/2001 00:41'! 111999mixed: fraction with: aColor 112000 ^self asColor mixed: fraction with: aColor! ! 112001 112002 112003!FillStyle methodsFor: 'testing' stamp: 'ar 11/9/1998 13:54'! 112004isBitmapFill 112005 ^false! ! 112006 112007!FillStyle methodsFor: 'testing' stamp: 'ar 11/9/1998 13:54'! 112008isGradientFill 112009 ^false! ! 112010 112011!FillStyle methodsFor: 'testing' stamp: 'ar 6/18/1999 07:57'! 112012isOrientedFill 112013 "Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)" 112014 ^false! ! 112015 112016!FillStyle methodsFor: 'testing' stamp: 'ar 11/9/1998 13:54'! 112017isSolidFill 112018 ^false! ! 112019 112020!FillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:28'! 112021isTranslucent 112022 ^true "Since we don't know better"! ! 112023 112024!FillStyle methodsFor: 'testing' stamp: 'ar 10/26/2000 19:24'! 112025isTransparent 112026 ^false! ! 112027SimpleBorder subclass: #FillStyleBorder 112028 instanceVariableNames: 'fillStyle' 112029 classVariableNames: '' 112030 poolDictionaries: '' 112031 category: 'Polymorph-Widgets-Borders'! 112032!FillStyleBorder commentStamp: 'gvc 9/23/2008 11:56' prior: 0! 112033BorderStyle supporting general (potentially composite) fillstyles. ! 112034 112035 112036!FillStyleBorder methodsFor: 'accessing' stamp: 'gvc 6/24/2008 16:18'! 112037fillStyle 112038 "Answer the value of fillStyle" 112039 112040 ^fillStyle ifNil: [self color]! ! 112041 112042!FillStyleBorder methodsFor: 'accessing' stamp: 'gvc 6/24/2008 16:20'! 112043fillStyle: anObject 112044 "Set the value of fillStyle" 112045 112046 fillStyle := anObject. 112047 anObject ifNotNil: [self baseColor: anObject asColor]! ! 112048 112049 112050!FillStyleBorder methodsFor: 'drawing' stamp: 'gvc 6/24/2008 16:15'! 112051frameRectangle: aRectangle on: aCanvas 112052 "Fill the border areas with the fill style, clipping for each segment." 112053 112054 (self borderRectsFor: aRectangle) do: [:r | 112055 aCanvas 112056 fillRectangle: r 112057 fillStyle: self fillStyle]! ! 112058 112059 112060!FillStyleBorder methodsFor: 'geometry' stamp: 'gvc 6/24/2008 16:19'! 112061borderRectsFor: aRectangle 112062 "Answer a collection of rectangles to fill. 112063 Just four here for a rectangular border." 112064 112065 |rTop rBottom rLeft rRight w| 112066 w := self width. 112067 rTop := aRectangle topLeft corner: aRectangle right @ (aRectangle top + w). 112068 rBottom := aRectangle left @ (aRectangle bottom - w) corner: aRectangle bottomRight. 112069 rLeft := aRectangle left @ (aRectangle top + w) corner: aRectangle left + w @ (aRectangle bottom - w). 112070 rRight := aRectangle right - w @ (aRectangle top + w) corner: aRectangle right @ (aRectangle bottom - w). 112071 ^{rTop. rBottom. rLeft. rRight}! ! 112072 112073 112074!FillStyleBorder methodsFor: 'testing' stamp: 'gvc 6/25/2008 12:11'! 112075hasFillStyle 112076 "Answer true." 112077 112078 ^true! ! 112079Object subclass: #FixUnderscores 112080 instanceVariableNames: '' 112081 classVariableNames: '' 112082 poolDictionaries: '' 112083 category: 'FixUnderscores'! 112084 112085"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 112086 112087FixUnderscores class 112088 instanceVariableNames: ''! 112089 112090!FixUnderscores class methodsFor: 'fixing' stamp: 'bf 4/7/2006 14:47'! 112091arrowChar 112092 "FIXME: this should rather be (Character leftArrow)" 112093 ^Character value: 16r8F! ! 112094 112095!FixUnderscores class methodsFor: 'fixing' stamp: 'bf 11/26/2004 21:52'! 112096fixFonts 112097 "self fixFonts" 112098 112099 StrikeFont allInstances 112100 do: [:fnt | self fixFont: fnt] 112101 displayingProgress: 'Fixing Bitmap Fonts'.! ! 112102 112103!FixUnderscores class methodsFor: 'fixing' stamp: 'bf 10/18/2005 19:05'! 112104fixFont: aFont 112105 | glyph underline | 112106 glyph := aFont characterFormAt: $_. 112107 "save arrow glyph to arrowChar codepoint" 112108 ((glyph copy: (0@aFont ascent corner: glyph extent)) isAllWhite 112109 and: [(aFont characterFormAt: self arrowChar) isAllWhite]) 112110 ifTrue: [aFont characterFormAt: self arrowChar put: glyph]. 112111 "make underscore glyph" 112112 glyph fillWhite. 112113 underline := aFont ascent + 1. 112114 glyph fillBlack: (1@underline extent: glyph width-1@1). 112115 aFont characterFormAt: $_ put: glyph.! ! 112116 112117!FixUnderscores class methodsFor: 'fixing' stamp: 'sd 3/16/2008 15:28'! 112118fixLFPackages: packageNames 112119 "FixUnderscores fixLFPackages: #('FixUnderscores')" 112120 112121 | failed | 112122 failed := OrderedCollection new. 112123 112124 packageNames 112125 do: [:pkgName | (PackageInfo named: pkgName) methods 112126 do: [:mRef | mRef fixLFInvisible ifFalse: [failed add: mRef]] 112127 displayingProgress: pkgName] 112128 displayingProgress: 'Fixing ...'. 112129 112130 failed isEmpty ifFalse: [ 112131 MessageSet openMessageList: failed 112132 name: 'These methods with lf were not fixed' 112133 autoSelect: Character lf asString].! ! 112134 112135!FixUnderscores class methodsFor: 'fixing' stamp: 'bf 4/7/2006 15:23'! 112136fixPackages: packageNames 112137 "FixUnderscores fixPackages: #('FixUnderscores' 'Bert')" 112138 112139 | failed | 112140 failed := OrderedCollection new. 112141 112142 packageNames 112143 do: [:pkgName | (PackageInfo named: pkgName) methods 112144 do: [:mRef | mRef fixUnderscores ifFalse: [failed add: mRef]] 112145 displayingProgress: pkgName] 112146 displayingProgress: 'Fixing ...'. 112147 112148 failed isEmpty ifFalse: [ 112149 MessageSet openMessageList: failed 112150 name: 'These methods with literal underscores were not fixed' 112151 autoSelect: '_'].! ! 112152 112153!FixUnderscores class methodsFor: 'fixing' stamp: 'bf 4/7/2006 15:11'! 112154fixPackage: aPackageName 112155 ^self fixPackages: {aPackageName} 112156 112157! ! 112158 112159 112160!FixUnderscores class methodsFor: 'initialization' stamp: 'bf 10/18/2005 12:13'! 112161initialize 112162 "self initialize" 112163 112164 self fixFonts. 112165 self inform: 'Fonts were _fixed_.\The arrow glyph is now Character value ' withCRs, 112166 self arrowChar asInteger hex, ' ($', self arrowChar asString, ')'. 112167! ! 112168 112169 112170!FixUnderscores class methodsFor: 'tests' stamp: 'sd 3/16/2008 15:29'! 112171asSeconds 112172 "Answer the seconds since the Squeak epoch: 1 January 1901" 112173 112174 ^ 12 asSeconds! ! 112175AbstractFont subclass: #FixedFaceFont 112176 instanceVariableNames: 'baseFont substitutionCharacter displaySelector' 112177 classVariableNames: '' 112178 poolDictionaries: '' 112179 category: 'Multilingual-Display'! 112180!FixedFaceFont commentStamp: 'tak 12/22/2004 01:45' prior: 0! 112181I am a font for special purpose like password or fallback. 112182I can show same form whenever someone requests any character. 112183 112184Variable displaySelector is future use to show a form dynamically. 112185(Although it would be unnecessary...)! 112186 112187 112188!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:58'! 112189ascent 112190 ^baseFont ascent! ! 112191 112192!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'! 112193baseFont 112194 ^baseFont! ! 112195 112196!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'! 112197baseFont: aFont 112198 baseFont := aFont! ! 112199 112200!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:59'! 112201baseKern 112202 ^baseFont baseKern! ! 112203 112204!FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/22/2004 02:01'! 112205characterFormAt: character 112206 ^ baseFont characterFormAt: substitutionCharacter! ! 112207 112208!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 17:00'! 112209descent 112210 ^baseFont descent! ! 112211 112212!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:58'! 112213descentKern 112214 ^baseFont descentKern! ! 112215 112216!FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:10'! 112217emphasized: emph 112218 ^self class new baseFont: (baseFont emphasized: emph)! ! 112219 112220!FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:25'! 112221familyName 112222 ^baseFont familyName, '-pw'! ! 112223 112224!FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:19'! 112225fontSize: aNumber 112226 self baseFont: (StrikeFont familyName: baseFont familyName size: aNumber) copy! ! 112227 112228!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'! 112229height 112230 ^baseFont height! ! 112231 112232!FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:26'! 112233lineGrid 112234 ^baseFont lineGrid! ! 112235 112236!FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:51'! 112237maxAscii 112238 ^ SmallInteger maxVal! ! 112239 112240!FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:59'! 112241passwordCharacter 112242 ^$*! ! 112243 112244!FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:28'! 112245pointSize 112246 ^baseFont pointSize! ! 112247 112248 112249!FixedFaceFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:48'! 112250releaseCachedState 112251 baseFont releaseCachedState.! ! 112252 112253 112254!FixedFaceFont methodsFor: 'displaying' stamp: 'tak 12/20/2004 18:06'! 112255displayErrorOn: aCanvas length: length at: aPoint kern: kernDelta 112256 | maskedString | 112257 maskedString := String new: length. 112258 maskedString atAllPut: substitutionCharacter. 112259 ^ baseFont 112260 displayString: maskedString 112261 on: aCanvas 112262 from: 1 112263 to: length 112264 at: aPoint 112265 kern: kernDelta! ! 112266 112267!FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:49'! 112268displayErrorOn: aCanvas length: length at: aPoint kern: kernDelta baselineY: baselineY 112269 | maskedString | 112270 maskedString := String new: length. 112271 maskedString atAllPut: substitutionCharacter. 112272 ^ baseFont 112273 displayString: maskedString 112274 on: aCanvas 112275 from: 1 112276 to: length 112277 at: aPoint 112278 kern: kernDelta 112279 baselineY: baselineY! ! 112280 112281!FixedFaceFont methodsFor: 'displaying' stamp: 'tak 12/20/2004 18:06'! 112282displayPasswordOn: aCanvas length: length at: aPoint kern: kernDelta 112283 | maskedString | 112284 maskedString := String new: length. 112285 maskedString atAllPut: substitutionCharacter. 112286 ^ baseFont 112287 displayString: maskedString 112288 on: aCanvas 112289 from: 1 112290 to: length 112291 at: aPoint 112292 kern: kernDelta! ! 112293 112294!FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:50'! 112295displayPasswordOn: aCanvas length: length at: aPoint kern: kernDelta baselineY: baselineY 112296 | maskedString | 112297 maskedString := String new: length. 112298 maskedString atAllPut: substitutionCharacter. 112299 ^ baseFont 112300 displayString: maskedString 112301 on: aCanvas 112302 from: 1 112303 to: length 112304 at: aPoint 112305 kern: kernDelta 112306 baselineY: baselineY! ! 112307 112308!FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 12:00'! 112309displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta 112310 | size | 112311 size := stopIndex - startIndex + 1. 112312 ^ self perform: displaySelector withArguments: (Array with: aDisplayContext with: size with: aPoint with: kernDelta with: aPoint y + self ascent).! ! 112313 112314!FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 12:19'! 112315displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY 112316 | size | 112317 size := stopIndex - startIndex + 1. 112318 ^ self perform: displaySelector withArguments: (Array with: aDisplayContext with: size with: aPoint with: kernDelta with: baselineY).! ! 112319 112320!FixedFaceFont methodsFor: 'displaying' stamp: 'tak 12/20/2004 11:10'! 112321displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont 112322 | destPoint | 112323 destPoint := self 112324 displayString: aString 112325 on: aBitBlt 112326 from: startIndex 112327 to: stopIndex 112328 at: aPoint 112329 kern: kernDelta. 112330 ^ Array with: stopIndex + 1 with: destPoint! ! 112331 112332!FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:51'! 112333displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont baselineY: baselineY 112334 | destPoint | 112335 destPoint := self 112336 displayString: aString 112337 on: aBitBlt 112338 from: startIndex 112339 to: stopIndex 112340 at: aPoint 112341 kern: kernDelta 112342 baselineY: baselineY. 112343 ^ Array with: stopIndex + 1 with: destPoint! ! 112344 112345!FixedFaceFont methodsFor: 'displaying' stamp: 'ar 1/5/2003 17:00'! 112346installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor 112347 ^baseFont installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor! ! 112348 112349 112350!FixedFaceFont methodsFor: 'initialization' stamp: 'yo 1/7/2005 11:59'! 112351errorFont 112352 displaySelector := #displayErrorOn:length:at:kern:baselineY:. 112353 substitutionCharacter := $?.! ! 112354 112355!FixedFaceFont methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:54'! 112356initialize 112357 super initialize. 112358 baseFont := TextStyle defaultFont. 112359 self passwordFont! ! 112360 112361!FixedFaceFont methodsFor: 'initialization' stamp: 'yo 1/7/2005 11:59'! 112362passwordFont 112363 displaySelector := #displayPasswordOn:length:at:kern:baselineY:. 112364 substitutionCharacter := $*! ! 112365 112366 112367!FixedFaceFont methodsFor: 'measuring' stamp: 'tak 12/20/2004 18:05'! 112368widthOf: aCharacter 112369 ^ baseFont widthOf: substitutionCharacter! ! 112370 112371 112372!FixedFaceFont methodsFor: 'private' stamp: 'yo 1/11/2005 18:54'! 112373glyphInfoOf: aCharacter into: glyphInfoArray 112374 112375 ^ baseFont glyphInfoOf: substitutionCharacter into: glyphInfoArray. 112376! ! 112377Array variableSubclass: #FixedIdentitySet 112378 instanceVariableNames: 'tally capacity' 112379 classVariableNames: '' 112380 poolDictionaries: '' 112381 category: 'Traits-Requires'! 112382!FixedIdentitySet commentStamp: 'NS 5/26/2005 13:00' prior: 0! 112383This is a fast but lazy implementation of fixed size identity sets. The two main difference to regular identity sets are: 112384 1123851) These identity sets have a fixed size. If they are full, adding another element doesn't have any effect. 1123862) No rehashing. If two elements were to be stored on the same position in the underlying array, one of them is simply discarded. 112387 112388As a consequence of (1) and (2), these identity sets are very fast!! Note that this class inherits form Array. This is not clean but reduces memory overhead when instances are created.! 112389 112390 112391!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 10:49'! 112392addAll: aCollection 112393 aCollection do: [:each | 112394 self isFull ifTrue: [^ self]. 112395 self add: each. 112396 ].! ! 112397 112398!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 10:50'! 112399addAll: aCollection notIn: notCollection 112400 aCollection do: [:each | 112401 self isFull ifTrue: [^ self]. 112402 (notCollection includes: each) ifFalse: [self add: each]. 112403 ].! ! 112404 112405!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 10:47'! 112406add: anObject 112407 | index old | 112408 self isFull ifTrue: [^ false]. 112409 index := self indexOf: anObject. 112410 old := self basicAt: index. 112411 old == anObject ifTrue: [^ true]. 112412 old ifNotNil: [^ false]. 112413 self basicAt: index put: anObject. 112414 tally := tally + 1. 112415 ^ true! ! 112416 112417!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 08:44'! 112418at: index 112419 self shouldNotImplement! ! 112420 112421!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 08:43'! 112422at: index put: anObject 112423 self shouldNotImplement! ! 112424 112425!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/23/2005 17:40'! 112426capacity 112427 ^ capacity! ! 112428 112429!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 10:46'! 112430destructiveAdd: anObject 112431 | index old | 112432 self isFull ifTrue: [^ false]. 112433 index := self indexOf: anObject. 112434 old := self basicAt: index. 112435 self basicAt: index put: anObject. 112436 old ifNil: [tally := tally + 1]. 112437 ^ true! ! 112438 112439!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 08:45'! 112440includes: anObject 112441 ^ (self basicAt: (self indexOf: anObject)) == anObject! ! 112442 112443!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/24/2005 13:12'! 112444remove: anObject ifAbsent: aBlock 112445 | index | 112446 index := self indexOf: anObject. 112447 ^ (self basicAt: index) == anObject 112448 ifTrue: [self basicAt: index put: nil. tally := tally - 1. anObject] 112449 ifFalse: [aBlock value].! ! 112450 112451!FixedIdentitySet methodsFor: 'accessing' stamp: 'NS 5/23/2005 13:13'! 112452size 112453 ^ tally! ! 112454 112455 112456!FixedIdentitySet methodsFor: 'comparing' stamp: 'NS 5/24/2005 08:56'! 112457hash 112458 "Answer an integer hash value for the receiver such that, 112459 -- the hash value of an unchanged object is constant over time, and 112460 -- two equal objects have equal hash values" 112461 112462 | hash | 112463 hash := self species hash. 112464 self size <= 10 ifTrue: 112465 [self do: [:elem | hash := hash bitXor: elem hash]]. 112466 ^hash bitXor: self size hash! ! 112467 112468!FixedIdentitySet methodsFor: 'comparing' stamp: 'NikoSchwarz 10/15/2009 16:02'! 112469= aCollection 112470 self == aCollection ifTrue: [^ true]. 112471 self species == aCollection species ifFalse: [^ false]. 112472 aCollection size = self size ifFalse: [^ false]. 112473 aCollection do: [:each | (self includes: each) ifFalse: [^ false]]. 112474 ^ true! ! 112475 112476 112477!FixedIdentitySet methodsFor: 'enumerating' stamp: 'NS 5/24/2005 09:04'! 112478do: aBlock 112479 | obj count | 112480 count := 0. 112481 1 to: self basicSize do: [:index | 112482 count >= tally ifTrue: [^ self]. 112483 obj := self basicAt: index. 112484 obj ifNotNil: [count := count + 1. aBlock value: obj]. 112485 ]. 112486! ! 112487 112488!FixedIdentitySet methodsFor: 'enumerating' stamp: 'NS 5/24/2005 13:52'! 112489select: aBlock 112490 | result | 112491 result := self species new: self capacity. 112492 self do: [:each | (aBlock value: each) ifTrue: [result add: each]]. 112493 ^ result.! ! 112494 112495 112496!FixedIdentitySet methodsFor: 'initialization' stamp: 'NS 5/23/2005 17:39'! 112497initializeCapacity: anInteger 112498 tally := 0. 112499 capacity := anInteger.! ! 112500 112501 112502!FixedIdentitySet methodsFor: 'printing' stamp: 'NS 5/23/2005 18:32'! 112503printOn: aStream 112504 | count | 112505 aStream nextPutAll: '#('. 112506 count := 0. 112507 self do: [:each | 112508 count := count + 1. 112509 each printOn: aStream. 112510 count < self size ifTrue: [aStream nextPut: $ ] 112511 ]. 112512 aStream nextPut: $).! ! 112513 112514 112515!FixedIdentitySet methodsFor: 'testing' stamp: 'NS 5/24/2005 10:45'! 112516isFull 112517 ^ tally >= capacity! ! 112518 112519!FixedIdentitySet methodsFor: 'testing' stamp: 'NS 5/24/2005 10:46'! 112520notFull 112521 ^ tally < capacity! ! 112522 112523 112524!FixedIdentitySet methodsFor: 'private' stamp: 'NS 5/23/2005 18:08'! 112525arraySize 112526 ^ super size! ! 112527 112528!FixedIdentitySet methodsFor: 'private' stamp: 'NS 5/24/2005 10:48'! 112529indexOf: anObject 112530 anObject isNil ifTrue: [self error: 'This class collection cannot handle nil as an element']. 112531 ^ (anObject identityHash bitAnd: self basicSize - 1) + 1! ! 112532 112533"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 112534 112535FixedIdentitySet class 112536 instanceVariableNames: ''! 112537 112538!FixedIdentitySet class methodsFor: 'constants' stamp: 'NS 5/26/2005 13:02'! 112539arraySizeForCapacity: anInteger 112540 "Because of the hash performance, the array size is always a power of 2 112541 and at least twice as big as the capacity anInteger" 112542 112543 ^ anInteger <= 0 112544 ifTrue: [0] 112545 ifFalse: [1 << (anInteger << 1 - 1) highBit].! ! 112546 112547!FixedIdentitySet class methodsFor: 'constants' stamp: 'NS 5/26/2005 13:03'! 112548defaultSize 112549 ^ 4! ! 112550 112551!FixedIdentitySet class methodsFor: 'constants' stamp: 'NS 5/23/2005 13:09'! 112552new 112553 ^ self new: self defaultSize! ! 112554 112555!FixedIdentitySet class methodsFor: 'constants' stamp: 'NS 5/23/2005 17:40'! 112556new: anInteger 112557 ^ (super new: (self arraySizeForCapacity: anInteger)) initializeCapacity: anInteger! ! 112558 112559 112560!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/26/2005 13:05'! 112561readonlyWithAll: aCollection notIn: notCollection 112562 "For performance reasons, this method may return an array rather than a FixedIdentitySet. 112563 Therefore it should only be used if the return value does not need to be modified. 112564 Use #withAll:notIn: if the return value might need to be modified." 112565 112566 | size | 112567 aCollection isEmpty ifTrue: [^ #()]. 112568 size := aCollection size = 1 112569 ifTrue: [1] 112570 ifFalse: [self sizeFor: aCollection]. 112571 ^ (self new: size) addAll: aCollection notIn: notCollection; yourself! ! 112572 112573!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 13:57'! 112574withAll: aCollection 112575 "Create a new collection containing all the elements from aCollection." 112576 112577 ^ (self new: (self sizeFor: aCollection)) 112578 addAll: aCollection; 112579 yourself! ! 112580 112581!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 13:58'! 112582withAll: aCollection notIn: notCollection 112583 ^ (self new: (self sizeFor: aCollection)) addAll: aCollection notIn: notCollection; yourself! ! 112584 112585!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 08:51'! 112586with: anObject 112587 "Answer an instance of me containing anObject." 112588 112589 ^ self new 112590 add: anObject; 112591 yourself! ! 112592 112593!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 08:51'! 112594with: firstObject with: secondObject 112595 "Answer an instance of me containing the two arguments as elements." 112596 112597 ^ self new 112598 add: firstObject; 112599 add: secondObject; 112600 yourself! ! 112601 112602!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 08:51'! 112603with: firstObject with: secondObject with: thirdObject 112604 "Answer an instance of me containing the three arguments as elements." 112605 112606 ^ self new 112607 add: firstObject; 112608 add: secondObject; 112609 add: thirdObject; 112610 yourself! ! 112611 112612!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 08:51'! 112613with: firstObject with: secondObject with: thirdObject with: fourthObject 112614 "Answer an instance of me, containing the four arguments as the elements." 112615 112616 ^ self new 112617 add: firstObject; 112618 add: secondObject; 112619 add: thirdObject; 112620 add: fourthObject; 112621 yourself! ! 112622 112623!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 08:52'! 112624with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject 112625 "Answer an instance of me, containing the five arguments as the elements." 112626 112627 ^ self new 112628 add: firstObject; 112629 add: secondObject; 112630 add: thirdObject; 112631 add: fourthObject; 112632 add: fifthObject; 112633 yourself! ! 112634 112635!FixedIdentitySet class methodsFor: 'instance creation' stamp: 'NS 5/24/2005 08:52'! 112636with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject 112637 "Answer an instance of me, containing the six arguments as the elements." 112638 112639 ^ self new 112640 add: firstObject; 112641 add: secondObject; 112642 add: thirdObject; 112643 add: fourthObject; 112644 add: fifthObject; 112645 add: sixthObject; 112646 yourself! ! 112647 112648 112649!FixedIdentitySet class methodsFor: 'private' stamp: 'NS 5/24/2005 13:57'! 112650sizeFor: aCollection 112651 ^ aCollection species == self 112652 ifTrue: [aCollection capacity] 112653 ifFalse: [self defaultSize].! ! 112654ReferenceMorph subclass: #FlapTab 112655 instanceVariableNames: 'flapShowing edgeToAdhereTo slidesOtherObjects popOutOnDragOver popOutOnMouseOver inboard dragged lastReferentThickness edgeFraction labelString' 112656 classVariableNames: '' 112657 poolDictionaries: '' 112658 category: 'Morphic-Worlds'! 112659!FlapTab commentStamp: '<historical>' prior: 0! 112660The tab associated with a flap. 112661 112662nb: slidesOtherObjects and inboard are instance variables relating to disused features. The feature implementations still exist in the system, but the UI to them has been sealed off.! 112663 112664 112665!FlapTab methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/16/2007 12:48'! 112666spanWorld 112667 "Fix for making the height/width of a solid tab be the same as the flap." 112668 112669 | container area | 112670 container := self pasteUpMorph 112671 ifNil: [self currentWorld]. 112672 area := container clearArea. 112673 self orientation == #vertical ifTrue: [ 112674 referent vResizing == #rigid 112675 ifTrue: [self isCurrentlySolid ifTrue: [self height: area height]. 112676 referent height: area height]. 112677 referent hResizing == #rigid 112678 ifTrue: [referent width: (referent width min: area width - self width)]. 112679 referent top: area top. 112680 referent bottom: (area bottom min: referent bottom) 112681 ] 112682 ifFalse: [ 112683 referent hResizing == #rigid 112684 ifTrue: [self isCurrentlySolid ifTrue: [self width: area width]. 112685 referent width: area width]. 112686 referent vResizing == #rigid 112687 ifTrue: [referent height: (referent height min: area height - self height)]. 112688 referent left: area left. 112689 referent right: (area right min: referent right) 112690 ]. 112691! ! 112692 112693 112694!FlapTab methodsFor: 'access' stamp: 'dgd 8/31/2003 18:58'! 112695acquirePlausibleFlapID 112696 "Give the receiver a flapID that is globally unique; try to hit the mark vis a vis the standard system flap id's, for the case when this method is invoked as part of the one-time transition" 112697 112698 | wording | 112699 wording := self wording. 112700 (wording isEmpty or: [wording = '---']) ifTrue: [wording := 'Flap' translated]. 112701 112702 ^ self provideDefaultFlapIDBasedOn: wording! ! 112703 112704!FlapTab methodsFor: 'access' stamp: 'sw 4/30/2001 18:39'! 112705flapID 112706 "Answer the receiver's flapID, creating it if necessary" 112707 112708 ^ self knownName ifNil: [self acquirePlausibleFlapID]! ! 112709 112710!FlapTab methodsFor: 'access' stamp: 'sw 4/30/2001 18:39'! 112711flapID: anID 112712 "Set the receiver's flapID" 112713 112714 self setNameTo: anID! ! 112715 112716!FlapTab methodsFor: 'access' stamp: 'sw 5/4/2001 23:25'! 112717flapIDOrNil 112718 "If the receiver has a flapID, answer it, else answer nil" 112719 112720 ^ self knownName! ! 112721 112722!FlapTab methodsFor: 'access' stamp: 'stephane.ducasse 2/14/2009 17:40'! 112723flapShowing 112724 ^ flapShowing! ! 112725 112726!FlapTab methodsFor: 'access' stamp: 'MAL 1/7/2005 12:25'! 112727orientation 112728 ^ (#left == edgeToAdhereTo or: [#right == edgeToAdhereTo]) 112729 ifTrue: [#vertical] 112730 ifFalse: [#horizontal]! ! 112731 112732!FlapTab methodsFor: 'access' stamp: 'sw 6/18/1999 13:38'! 112733referentThickness 112734 ^ (self orientation == #horizontal) 112735 ifTrue: 112736 [referent height] 112737 ifFalse: 112738 [referent width]! ! 112739 112740!FlapTab methodsFor: 'access' stamp: 'sw 2/27/1999 13:14'! 112741tabThickness 112742 ^ (self orientation == #vertical) 112743 ifTrue: 112744 [self width] 112745 ifFalse: 112746 [self height]! ! 112747 112748 112749!FlapTab methodsFor: 'accessing' stamp: 'tk 9/25/2002 18:08'! 112750labelString 112751 ^labelString! ! 112752 112753 112754!FlapTab methodsFor: 'change reporting' stamp: 'ar 10/26/2000 17:36'! 112755ownerChanged 112756 self fitOnScreen. 112757 ^super ownerChanged.! ! 112758 112759 112760!FlapTab methodsFor: 'classification' stamp: 'ar 9/28/2000 13:53'! 112761isFlapTab 112762 ^true! ! 112763 112764 112765!FlapTab methodsFor: 'disused options' stamp: 'stephane.ducasse 2/14/2009 17:40'! 112766inboard 112767 ^ inboard! ! 112768 112769!FlapTab methodsFor: 'disused options' stamp: 'sw 2/15/1999 12:57'! 112770inboard: aBoolean 112771 inboard := aBoolean! ! 112772 112773!FlapTab methodsFor: 'disused options' stamp: 'sw 2/11/1999 10:55'! 112774slidesOtherObjects 112775 ^ slidesOtherObjects! ! 112776 112777 112778!FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 20:51'! 112779applyEdgeFractionWithin: aBoundsRectangle 112780 "Make the receiver reflect remembered edgeFraction" 112781 112782 | newPosition | 112783 edgeFraction ifNil: [^ self]. 112784 self isCurrentlySolid ifTrue: [^ self]. 112785 newPosition := self 112786 ifVertical: 112787 [self left @ (self edgeFraction * (aBoundsRectangle height - self height))] 112788 ifHorizontal: 112789 [(self edgeFraction * (aBoundsRectangle width - self width) @ self top)]. 112790 112791 self position: (aBoundsRectangle origin + newPosition) 112792 ! ! 112793 112794!FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 15:01'! 112795computeEdgeFraction 112796 "Compute and remember the edge fraction" 112797 112798 | aBox aFraction | 112799 self isCurrentlySolid ifTrue: [^ edgeFraction ifNil: [self edgeFraction: 0.5]]. 112800 112801 aBox := ((owner ifNil: [ActiveWorld]) bounds) insetBy: (self extent // 2). 112802 aFraction := self 112803 ifVertical: 112804 [(self center y - aBox top) / (aBox height max: 1)] 112805 ifHorizontal: 112806 [(self center x - aBox left) / (aBox width max: 1)]. 112807 ^ self edgeFraction: aFraction! ! 112808 112809!FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 06:56'! 112810edgeFraction 112811 ^ edgeFraction ifNil: [self computeEdgeFraction]! ! 112812 112813!FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 08:38'! 112814edgeFraction: aNumber 112815 "Set my edgeFraction to the given number, without side effects" 112816 112817 edgeFraction := aNumber asFloat! ! 112818 112819!FlapTab methodsFor: 'edge' stamp: 'yo 2/10/2005 18:06'! 112820edgeString 112821 ^ 'cling to edge... (current: {1})' translated format: {edgeToAdhereTo translated}! ! 112822 112823!FlapTab methodsFor: 'edge' stamp: 'sw 2/11/1999 00:41'! 112824edgeToAdhereTo 112825 ^ edgeToAdhereTo! ! 112826 112827!FlapTab methodsFor: 'edge' stamp: 'MAL 1/7/2005 12:20'! 112828edgeToAdhereTo: e 112829 edgeToAdhereTo := e asSymbol! ! 112830 112831!FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 15:58'! 112832ifVertical: block1 ifHorizontal: block2 112833 "Evaluate and return the value of either the first or the second block, depending whether I am vertically or horizontally oriented" 112834 112835 ^ self orientation == #vertical 112836 ifTrue: 112837 [block1 value] 112838 ifFalse: 112839 [block2 value] 112840 ! ! 112841 112842!FlapTab methodsFor: 'edge' stamp: 'MAL 1/7/2005 12:24'! 112843setEdge: anEdge 112844 "Set the edge as indicated, if possible" 112845 112846 | newOrientation e | 112847 e := anEdge asSymbol. 112848 self edgeToAdhereTo = anEdge ifTrue: [^ self]. 112849 newOrientation := nil. 112850 self orientation == #vertical 112851 ifTrue: [(#top == e or: [#bottom == e]) ifTrue: 112852 [newOrientation := #horizontal]] 112853 ifFalse: [(#top == e or: [#bottom == e]) ifFalse: 112854 [newOrientation := #vertical]]. 112855 self edgeToAdhereTo: e. 112856 newOrientation ifNotNil: [self transposeParts]. 112857 referent isInWorld ifTrue: [self positionReferent]. 112858 self adjustPositionVisAVisFlap! ! 112859 112860!FlapTab methodsFor: 'edge' stamp: 'dgd 10/17/2003 22:36'! 112861setEdgeToAdhereTo 112862 | aMenu | 112863 aMenu := MenuMorph new defaultTarget: self. 112864 #(left top right bottom) do: 112865 [:sym | aMenu add: sym asString translated target: self selector: #setEdge: argument: sym]. 112866 aMenu popUpEvent: self currentEvent in: self world! ! 112867 112868 112869!FlapTab methodsFor: 'event handling' stamp: 'sw 10/31/2001 15:46'! 112870mouseMove: evt 112871 | aPosition newReferentThickness adjustedPosition thick | 112872 112873 dragged ifFalse: [(thick := self referentThickness) > 0 112874 ifTrue: [lastReferentThickness := thick]]. 112875 ((self containsPoint: (aPosition := evt cursorPoint)) and: [dragged not]) 112876 ifFalse: 112877 [flapShowing ifFalse: [self showFlap]. 112878 adjustedPosition := aPosition - evt hand targetOffset. 112879 (edgeToAdhereTo == #bottom) 112880 ifTrue: 112881 [newReferentThickness := inboard 112882 ifTrue: 112883 [self world height - adjustedPosition y] 112884 ifFalse: 112885 [self world height - adjustedPosition y - self height]]. 112886 112887 (edgeToAdhereTo == #left) 112888 ifTrue: 112889 [newReferentThickness := 112890 inboard 112891 ifTrue: 112892 [adjustedPosition x + self width] 112893 ifFalse: 112894 [adjustedPosition x]]. 112895 112896 (edgeToAdhereTo == #right) 112897 ifTrue: 112898 [newReferentThickness := 112899 inboard 112900 ifTrue: 112901 [self world width - adjustedPosition x] 112902 ifFalse: 112903 [self world width - adjustedPosition x - self width]]. 112904 112905 (edgeToAdhereTo == #top) 112906 ifTrue: 112907 [newReferentThickness := 112908 inboard 112909 ifTrue: 112910 [adjustedPosition y + self height] 112911 ifFalse: 112912 [adjustedPosition y]]. 112913 112914 self isCurrentlySolid ifFalse: 112915 [(#(left right) includes: edgeToAdhereTo) 112916 ifFalse: 112917 [self left: adjustedPosition x] 112918 ifTrue: 112919 [self top: adjustedPosition y]]. 112920 112921 self applyThickness: newReferentThickness. 112922 dragged := true. 112923 self fitOnScreen. 112924 self computeEdgeFraction]! ! 112925 112926!FlapTab methodsFor: 'event handling' stamp: 'sw 11/22/2001 08:11'! 112927mouseUp: evt 112928 "The mouse came back up, presumably after having dragged the tab. Caution: if not operating full-screen, this notification can easily be *missed*, which is why the edge-fraction-computation is also being done on mouseMove." 112929 112930 super mouseUp: evt. 112931 (self referentThickness <= 0 or: 112932 [(referent isInWorld and: [(referent boundsInWorld intersects: referent owner boundsInWorld) not])]) ifTrue: 112933 [self hideFlap. 112934 flapShowing := false]. 112935 self fitOnScreen. 112936 dragged ifTrue: 112937 [self computeEdgeFraction. 112938 dragged := false]. 112939 Flaps doAutomaticLayoutOfFlapsIfAppropriate! ! 112940 112941 112942!FlapTab methodsFor: 'events' stamp: 'stephane.ducasse 2/14/2009 17:41'! 112943tabSelected 112944 "The user clicked on the tab. Show or hide the flap. Try to be a little smart about a click on a tab whose flap is open but only just barely." 112945 112946 dragged ifTrue: [^ dragged := false]. 112947 self flapShowing 112948 ifTrue: 112949 [self referentThickness < 23 "an attractive number" 112950 ifTrue: [self openFully] 112951 ifFalse: [self hideFlap]] 112952 ifFalse: [self showFlap]! ! 112953 112954 112955!FlapTab methodsFor: 'globalness' stamp: 'sw 5/4/2001 23:25'! 112956isGlobalFlap 112957 "Answer whether the receiver is currently a shared flap" 112958 112959 ^ Flaps globalFlapTabsIfAny includes: self! ! 112960 112961!FlapTab methodsFor: 'globalness' stamp: 'dgd 8/30/2003 21:36'! 112962isGlobalFlapString 112963 "Answer a string to construct a menu item representing control 112964 over whether the receiver is or is not a shared flap" 112965 ^ (self isGlobalFlap 112966 ifTrue: ['<yes>'] 112967 ifFalse: ['<no>']) 112968 , 'shared by all projects' translated! ! 112969 112970!FlapTab methodsFor: 'globalness' stamp: 'sw 4/30/2001 18:52'! 112971toggleIsGlobalFlap 112972 "Toggle whether the receiver is currently a global flap or not" 112973 112974 | oldWorld | 112975 self hideFlap. 112976 oldWorld := self currentWorld. 112977 self isGlobalFlap 112978 ifTrue: 112979 [Flaps removeFromGlobalFlapTabList: self. 112980 oldWorld addMorphFront: self] 112981 ifFalse: 112982 [self delete. 112983 Flaps addGlobalFlap: self. 112984 self currentWorld addGlobalFlaps]. 112985 ActiveWorld reformulateUpdatingMenus 112986 ! ! 112987 112988 112989!FlapTab methodsFor: 'graphical tabs' stamp: 'sw 6/17/1999 16:07'! 112990graphicalTab 112991 self isCurrentlyGraphical 112992 ifTrue: 112993 [self changeTabGraphic] 112994 ifFalse: 112995 [self useGraphicalTab]! ! 112996 112997!FlapTab methodsFor: 'graphical tabs' stamp: 'dgd 8/30/2003 21:29'! 112998graphicalTabString 112999 ^ (self isCurrentlyGraphical 113000 ifTrue: ['choose new graphic...'] 113001 ifFalse: ['use graphical tab']) translated! ! 113002 113003 113004!FlapTab methodsFor: 'initialization' stamp: 'tk 12/11/2000 16:29'! 113005adaptToWorld 113006 | wasShowing new | 113007 (wasShowing := self flapShowing) ifTrue: 113008 [self hideFlap]. 113009 (self respondsTo: #unhibernate) ifTrue: [ 113010 (new := self unhibernate) == self ifFalse: [ 113011 ^ new adaptToWorld]]. 113012 self spanWorld. 113013 self positionObject: self. 113014 wasShowing ifTrue: 113015 [self showFlap]! ! 113016 113017!FlapTab methodsFor: 'initialization' stamp: 'stephane.ducasse 2/14/2009 17:39'! 113018initialize 113019 "initialize the state of the receiver" 113020 113021 super initialize. 113022 edgeToAdhereTo := #left. 113023 flapShowing := false. 113024 slidesOtherObjects := false. 113025 popOutOnDragOver := false. 113026 popOutOnMouseOver := false. 113027 inboard := false. 113028 dragged := false! ! 113029 113030!FlapTab methodsFor: 'initialization' stamp: 'di 11/18/2001 13:09'! 113031provideDefaultFlapIDBasedOn: aStem 113032 "Provide the receiver with a default flap id" 113033 113034 | aNumber usedIDs anID | 113035 aNumber := 0. 113036 usedIDs := FlapTab allSubInstances select: [:f | f ~~ self] thenCollect: [:f | f flapIDOrNil]. 113037 anID := aStem. 113038 [usedIDs includes: anID] whileTrue: 113039 [aNumber := aNumber + 1. 113040 anID := aStem, (aNumber asString)]. 113041 self flapID: anID. 113042 ^ anID! ! 113043 113044!FlapTab methodsFor: 'initialization' stamp: 'di 11/19/2001 21:20'! 113045setName: nameString edge: edgeSymbol color: flapColor 113046 "Set me up with the usual..." 113047 113048 self setNameTo: nameString. 113049 self edgeToAdhereTo: edgeSymbol; inboard: false. 113050 self assumeString: nameString font: Preferences standardFlapFont 113051 orientation: self orientation color: flapColor. 113052 self setToPopOutOnDragOver: true. 113053 self setToPopOutOnMouseOver: false. 113054! ! 113055 113056 113057!FlapTab methodsFor: 'layout' stamp: 'ar 10/26/2000 17:36'! 113058layoutChanged 113059 self fitOnScreen. 113060 ^super layoutChanged! ! 113061 113062 113063!FlapTab methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:21'! 113064addCustomMenuItems: aMenu hand: aHandMorph 113065 "Add further items to the menu as appropriate" 113066 113067 aMenu add: 'tab color...' translated target: self action: #changeColor. 113068 aMenu add: 'flap color...' translated target: self action: #changeFlapColor. 113069 aMenu addLine. 113070 aMenu addUpdating: #edgeString action: #setEdgeToAdhereTo. 113071 aMenu addLine. 113072 aMenu addUpdating: #textualTabString action: #textualTab. 113073 aMenu addUpdating: #graphicalTabString action: #graphicalTab. 113074 aMenu addUpdating: #solidTabString enablement: #notSolid action: #solidTab. 113075 aMenu addLine. 113076 113077 (referent isKindOf: PasteUpMorph) ifTrue: 113078 [aMenu addUpdating: #partsBinString action: #togglePartsBinMode]. 113079 aMenu addUpdating: #dragoverString action: #toggleDragOverBehavior. 113080 aMenu addUpdating: #mouseoverString action: #toggleMouseOverBehavior. 113081 aMenu addLine. 113082 aMenu addUpdating: #isGlobalFlapString enablement: #sharedFlapsAllowed action: #toggleIsGlobalFlap. 113083 aMenu balloonTextForLastItem: 'If checked, this flap will be available in all morphic projects; if not, it will be private to this project.,' translated. 113084 113085 aMenu addLine. 113086 aMenu add: 'destroy this flap' translated action: #destroyFlap. 113087 113088 "aMenu addUpdating: #slideString action: #toggleSlideBehavior. 113089 aMenu addUpdating: #inboardString action: #toggleInboardness. 113090 aMenu addUpdating: #thicknessString ('thickness... (current: ', self thickness printString, ')') action: #setThickness." 113091 113092! ! 113093 113094!FlapTab methodsFor: 'menu' stamp: 'sw 6/20/1999 23:41'! 113095applyThickness: newThickness 113096 | toUse | 113097 toUse := newThickness asNumber max: 0. 113098 (self orientation == #vertical) 113099 ifTrue: 113100 [referent width: toUse] 113101 ifFalse: 113102 [referent height: toUse]. 113103 self positionReferent. 113104 self adjustPositionVisAVisFlap! ! 113105 113106!FlapTab methodsFor: 'menu' stamp: 'dgd 9/21/2003 17:55'! 113107changeColor 113108 self isCurrentlyGraphical 113109 ifTrue: 113110 [^ self inform: 'Color only pertains to a flap tab when the 113111tab is textual or "solid". This tab is 113112currently graphical, so color-choice 113113does not apply.' translated]. 113114 super changeColor 113115 113116! ! 113117 113118!FlapTab methodsFor: 'menu' stamp: 'dgd 9/21/2003 17:55'! 113119changeFlapColor 113120 (self flapShowing) 113121 ifTrue: 113122 [referent changeColor] 113123 ifFalse: 113124 [self inform: 'The flap itself needs to be open 113125before you can change its 113126color.' translated]! ! 113127 113128!FlapTab methodsFor: 'menu' stamp: 'alain.plantec 2/6/2009 15:23'! 113129changeTabText 113130 "Allow the user to change the text on the tab" 113131 113132 | reply | 113133 reply := UIManager default 113134 request: 'New wording for this tab:' translated 113135 initialAnswer: self existingWording. 113136 reply isEmptyOrNil ifTrue: [^ self]. 113137 self changeTabText: reply. 113138! ! 113139 113140!FlapTab methodsFor: 'menu' stamp: 'dgd 9/5/2003 18:25'! 113141destroyFlap 113142 "Destroy the receiver" 113143 113144 | reply request | 113145 request := self isGlobalFlap 113146 ifTrue: 113147 ['Caution -- this would permanently 113148remove this flap, so it would no longer be 113149available in this or any other project. 113150Do you really want to this? '] 113151 ifFalse: 113152 ['Caution -- this is permanent!! Do 113153you really want to do this? ']. 113154 reply := self confirm: request translated orCancel: [^ self]. 113155 reply ifTrue: 113156 [self isGlobalFlap 113157 ifTrue: 113158 [Flaps removeFlapTab: self keepInList: false. 113159 self currentWorld reformulateUpdatingMenus] 113160 ifFalse: 113161 [referent isInWorld ifTrue: [referent delete]. 113162 self delete]]! ! 113163 113164!FlapTab methodsFor: 'menu' stamp: 'di 11/17/2001 20:17'! 113165existingWording 113166 ^ labelString! ! 113167 113168!FlapTab methodsFor: 'menu' stamp: 'sw 7/8/1999 15:44'! 113169flapMenuTitle 113170 ^ 'flap: ', self wording! ! 113171 113172!FlapTab methodsFor: 'menu' stamp: 'gm 2/22/2003 13:11'! 113173isCurrentlyTextual 113174 | first | 113175 ^submorphs notEmpty and: 113176 [((first := submorphs first) isKindOf: StringMorph) 113177 or: [first isTextMorph]]! ! 113178 113179!FlapTab methodsFor: 'menu' stamp: 'sw 6/20/1999 19:17'! 113180preserveDetails 113181 "The receiver is being switched to use a different format. Preserve the existing details (e.g. wording if textual, grapheme if graphical) so that if the user reverts back to the current format, the details will be right" 113182 113183 | thickness | 113184 color = Color transparent ifFalse: [self setProperty: #priorColor toValue: color]. 113185 self isCurrentlyTextual 113186 ifTrue: 113187 [self setProperty: #priorWording toValue: self existingWording] 113188 ifFalse: 113189 [self isCurrentlyGraphical 113190 ifTrue: 113191 [self setProperty: #priorGraphic toValue: submorphs first form] 113192 ifFalse: 113193 [thickness := (self orientation == #vertical) 113194 ifTrue: [self width] 113195 ifFalse: [self height]. 113196 self setProperty: #priorThickness toValue: thickness]]! ! 113197 113198!FlapTab methodsFor: 'menu' stamp: 'sw 4/24/2001 11:04'! 113199sharedFlapsAllowed 113200 "Answer (for the benefit of a menu item for which I am the target) whether the system presently allows shared flaps" 113201 113202 ^ Flaps sharedFlapsAllowed! ! 113203 113204!FlapTab methodsFor: 'menu' stamp: 'sw 6/14/1999 16:38'! 113205thicknessString 113206 ^ 'thickness... (currently ', self thickness printString, ')'! ! 113207 113208!FlapTab methodsFor: 'menu' stamp: 'ar 12/18/2000 16:38'! 113209wording 113210 ^ self isCurrentlyTextual 113211 ifTrue: 113212 [self existingWording] 113213 ifFalse: 113214 [self valueOfProperty: #priorWording ifAbsent: ['---']]! ! 113215 113216 113217!FlapTab methodsFor: 'menus' stamp: 'sw 6/19/1999 23:16'! 113218addTitleForHaloMenu: aMenu 113219 aMenu addTitle: self externalName updatingSelector: #flapMenuTitle updateTarget: self! ! 113220 113221 113222!FlapTab methodsFor: 'misc' stamp: 'di 11/19/2001 12:19'! 113223fitContents 113224 self isCurrentlyTextual ifFalse: [^ super fitContents]. 113225 self ifVertical: 113226 [self extent: submorphs first extent + (2 * self borderWidth) + (0@4). 113227 submorphs first position: self position + self borderWidth + (1@4)] 113228 ifHorizontal: 113229 [self extent: submorphs first extent + (2 * self borderWidth) + (8@-1). 113230 submorphs first position: self position + self borderWidth + (5@1)]! ! 113231 113232 113233!FlapTab methodsFor: 'miscellaneous' stamp: 'dgd 8/31/2003 18:43'! 113234balloonTextForFlapsMenu 113235 "Answer the balloon text to show on a menu item in the flaps menu that governs the visibility of the receiver in the current project" 113236 113237 | id | 113238 id := self flapID. 113239 #( 113240 ('Squeak' 'Has a few generally-useful controls; it is also a place where you can "park" objects') 113241 ('Tools' 'A quick way to get browsers, change sorters, file lists, etc.') 113242 ('Widgets' 'A variety of controls and media tools') 113243 ('Supplies' 'A source for many basic types of objects') 113244 ('Stack Tools' 'Tools for building stacks. Caution!! Powerful but young and underdocumented') 113245 ('Scripting' 'Tools useful when doing tile scripting') 113246 ('Navigator' 'Project navigator: includes controls for navigating through linked projects. Also supports finding, loading and publishing projects in a shared environment') 113247 ('Painting' 'A flap housing the paint palette. Click on the closed tab to make make a new painting')) do: 113248 [:pair | (FlapTab givenID: id matches: pair first translated) ifTrue: [^ pair second translated]]. 113249 113250 ^ self balloonText! ! 113251 113252 113253!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 4/7/2000 07:52'! 113254arrangeToPopOutOnDragOver: aBoolean 113255 aBoolean 113256 ifTrue: 113257 [self on: #mouseEnterDragging send: #showFlapIfHandLaden: to: self. 113258 referent on: #mouseLeaveDragging send: #maybeHideFlapOnMouseLeaveDragging to: self. 113259 self on: #mouseLeaveDragging send: #maybeHideFlapOnMouseLeaveDragging to: self] 113260 ifFalse: 113261 [self on: #mouseEnterDragging send: nil to: nil. 113262 referent on: #mouseLeaveDragging send: nil to: nil. 113263 self on: #mouseLeaveDragging send: nil to: nil]! ! 113264 113265!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 7/31/2002 00:53'! 113266arrangeToPopOutOnMouseOver: aBoolean 113267 aBoolean 113268 ifTrue: 113269 [self on: #mouseEnter send: #showFlap to: self. 113270 referent on: #mouseLeave send: #hideFlapUnlessBearingHalo to: self. 113271 self on: #mouseLeave send: #maybeHideFlapOnMouseLeave to: self] 113272 ifFalse: 113273 [self on: #mouseEnter send: nil to: nil. 113274 self on: #mouseLeave send: nil to: nil. 113275 referent on: #mouseLeave send: nil to: nil]! ! 113276 113277!FlapTab methodsFor: 'mouseover & dragover' stamp: 'dgd 8/30/2003 21:32'! 113278dragoverString 113279 "Answer the string to be shown in a menu to represent the 113280 dragover status" 113281 ^ (popOutOnDragOver 113282 ifTrue: ['<yes>'] 113283 ifFalse: ['<no>']), 'pop out on dragover' translated! ! 113284 113285!FlapTab methodsFor: 'mouseover & dragover' stamp: 'dgd 8/30/2003 21:36'! 113286mouseoverString 113287 "Answer the string to be shown in a menu to represent the 113288 mouseover status" 113289 ^ (popOutOnMouseOver 113290 ifTrue: ['<yes>'] 113291 ifFalse: ['<no>']) 113292 , 'pop out on mouseover' translated ! ! 113293 113294!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 2/25/1999 14:53'! 113295setToPopOutOnDragOver: aBoolean 113296 self arrangeToPopOutOnDragOver: (popOutOnDragOver := aBoolean)! ! 113297 113298!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 2/25/1999 14:52'! 113299setToPopOutOnMouseOver: aBoolean 113300 self arrangeToPopOutOnMouseOver: (popOutOnMouseOver := aBoolean)! ! 113301 113302!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 2/15/1999 14:10'! 113303toggleDragOverBehavior 113304 self arrangeToPopOutOnDragOver: (popOutOnDragOver := popOutOnDragOver not)! ! 113305 113306!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 2/15/1999 14:07'! 113307toggleMouseOverBehavior 113308 self arrangeToPopOutOnMouseOver: (popOutOnMouseOver := popOutOnMouseOver not)! ! 113309 113310 113311!FlapTab methodsFor: 'objects from disk' stamp: 'sw 5/4/2001 23:27'! 113312objectForDataStream: refStrm 113313 "I am about to be written on an object file. If I am a global flap, write a proxy instead." 113314 113315 | dp | 113316 self isGlobalFlap ifTrue: 113317 [dp := DiskProxy global: #Flaps selector: #globalFlapTabOrDummy: 113318 args: {self flapID}. 113319 refStrm replace: self with: dp. 113320 ^ dp]. 113321 113322 ^ super objectForDataStream: refStrm! ! 113323 113324 113325!FlapTab methodsFor: 'parts bin' stamp: 'dgd 8/30/2003 21:31'! 113326partsBinString 113327 "Answer the string to be shown in a menu to represent the 113328 parts-bin status" 113329 ^ (referent isPartsBin 113330 ifTrue: ['<yes>'] 113331 ifFalse: ['<no>']), 'parts-bin' translated! ! 113332 113333!FlapTab methodsFor: 'parts bin' stamp: 'sw 2/25/1999 13:17'! 113334togglePartsBinMode 113335 referent setPartsBinStatusTo: referent isPartsBin not! ! 113336 113337 113338!FlapTab methodsFor: 'positioning' stamp: 'sw 2/16/1999 18:13'! 113339adjustPositionVisAVisFlap 113340 | sideToAlignTo opposite | 113341 opposite := Utilities oppositeSideTo: edgeToAdhereTo. 113342 sideToAlignTo := inboard 113343 ifTrue: [opposite] 113344 ifFalse: [edgeToAdhereTo]. 113345 self perform: (Utilities simpleSetterFor: sideToAlignTo) with: (referent perform: opposite)! ! 113346 113347!FlapTab methodsFor: 'positioning' stamp: 'dgd 4/4/2006 16:12'! 113348fitOnScreen 113349 "19 sept 2000 - allow flaps in any paste up" 113350 | constrainer t l | 113351 constrainer := (owner ifNil: [self]) clearArea. 113352 self flapShowing "otherwise no point in doing this" 113353 ifTrue:[self spanWorld]. 113354 self orientation == #vertical ifTrue: [ 113355 t := ((self top min: (constrainer bottom- self height)) max: constrainer top). 113356 t = self top ifFalse: [self top: t]. 113357 ] ifFalse: [ 113358 l := ((self left min: (constrainer right - self width)) max: constrainer left). 113359 l = self left ifFalse: [self left: l]. 113360 ]. 113361 self flapShowing ifFalse: [self positionObject: self atEdgeOf: constrainer]. 113362! ! 113363 113364!FlapTab methodsFor: 'positioning' stamp: 'dgd 4/4/2006 16:08'! 113365positionObject: anObject 113366 "anObject could be myself or my referent" 113367 113368"Could consider container := referent pasteUpMorph, to allow flaps on things other than the world, but for the moment, let's skip it!!" 113369 113370 "19 sept 2000 - going for all paste ups" 113371 113372 | pum | 113373 pum := self pasteUpMorph ifNil: [^ self]. 113374 113375 ^self 113376 positionObject: anObject 113377 atEdgeOf: pum clearArea! ! 113378 113379!FlapTab methodsFor: 'positioning' stamp: 'RAA 6/14/2000 19:35'! 113380positionObject: anObject atEdgeOf: container 113381 "anObject could be myself or my referent" 113382 113383 edgeToAdhereTo == #left ifTrue: [^ anObject left: container left]. 113384 edgeToAdhereTo == #right ifTrue: [^ anObject right: container right]. 113385 edgeToAdhereTo == #top ifTrue: [^ anObject top: container top]. 113386 edgeToAdhereTo == #bottom ifTrue: [^ anObject bottom: container bottom]! ! 113387 113388!FlapTab methodsFor: 'positioning' stamp: 'sw 2/16/1999 17:58'! 113389positionReferent 113390 self positionObject: referent! ! 113391 113392!FlapTab methodsFor: 'positioning' stamp: 'sw 2/11/1999 14:46'! 113393stickOntoReferent 113394 "Place the receiver directly onto the referent -- for use when the referent is being shown as a flap" 113395 | newPosition | 113396 referent addMorph: self. 113397 edgeToAdhereTo == #left 113398 ifTrue: 113399 [newPosition := (referent width - self width) @ self top]. 113400 edgeToAdhereTo == #right 113401 ifTrue: 113402 [newPosition := (referent left @ self top)]. 113403 edgeToAdhereTo == #top 113404 ifTrue: 113405 [newPosition := self left @ (referent height - self height)]. 113406 edgeToAdhereTo == #bottom 113407 ifTrue: 113408 [newPosition := self left @ referent top]. 113409 self position: newPosition! ! 113410 113411!FlapTab methodsFor: 'positioning' stamp: 'di 11/21/2001 16:02'! 113412transposeParts 113413 "The receiver's orientation has just been changed from vertical to horizontal or vice-versa." 113414 "First expand the flap to screen size, letting the submorphs lay out to fit, 113415 and then shrink the minor dimension back to the last row." 113416 113417 self isCurrentlyTextual ifTrue: "First recreate the tab with proper orientation" 113418 [self assumeString: self existingWording font: Preferences standardFlapFont 113419 orientation: self orientation color: self color]. 113420 self orientation == #vertical 113421 ifTrue: "changed from horizontal" 113422 [referent listDirection: #topToBottom; wrapDirection: #leftToRight. 113423 referent hasSubmorphs ifTrue: 113424 [referent extent: self currentWorld extent. 113425 referent fullBounds. "Needed to trigger layout" 113426 referent width: (referent submorphs collect: [:m | m right]) max 113427 - referent left + self width]] 113428 ifFalse: 113429 [referent listDirection: #leftToRight; wrapDirection: #topToBottom. 113430 referent hasSubmorphs ifTrue: 113431 [referent extent: self currentWorld extent. 113432 referent fullBounds. "Needed to trigger layout" 113433 referent height: (referent submorphs collect: [:m | m bottom]) max 113434 - referent top + self height]]. 113435 referent hasSubmorphs ifFalse: [referent extent: 100@100]. 113436 113437 self spanWorld. 113438 flapShowing ifTrue: [self showFlap]! ! 113439 113440 113441!FlapTab methodsFor: 'printing' stamp: 'sw 11/6/2000 15:41'! 113442printOn: aStream 113443 "Append a textual representation of the receiver to aStream" 113444 113445 super printOn: aStream. 113446 aStream nextPutAll: ' "', self wording, '"'! ! 113447 113448 113449!FlapTab methodsFor: 'rounding' stamp: 'di 11/20/2001 08:20'! 113450roundedCorners 113451 edgeToAdhereTo == #bottom ifTrue: [^ #(1 4)]. 113452 edgeToAdhereTo == #right ifTrue: [^ #(1 2)]. 113453 edgeToAdhereTo == #left ifTrue: [^ #(3 4)]. 113454 ^ #(2 3) "#top and undefined" 113455! ! 113456 113457!FlapTab methodsFor: 'rounding' stamp: 'ar 12/22/2001 22:45'! 113458wantsRoundedCorners 113459 ^self isCurrentlyTextual or:[super wantsRoundedCorners]! ! 113460 113461 113462!FlapTab methodsFor: 'show & hide' stamp: 'sw 2/16/1999 17:58'! 113463adjustPositionAfterHidingFlap 113464 self positionObject: self! ! 113465 113466!FlapTab methodsFor: 'show & hide' stamp: 'tk 1/31/2001 12:27'! 113467hideFlap 113468 | aWorld | 113469 aWorld := self world ifNil: [self currentWorld]. 113470 referent privateDelete. 113471 aWorld removeAccommodationForFlap: self. 113472 flapShowing := false. 113473 self isInWorld ifFalse: [aWorld addMorphFront: self]. 113474 self adjustPositionAfterHidingFlap. 113475 aWorld haloMorphs do: 113476 [:m | m target isInWorld ifFalse: [m delete]]! ! 113477 113478!FlapTab methodsFor: 'show & hide' stamp: 'sw 12/29/1999 12:41'! 113479hideFlapUnlessBearingHalo 113480 self hasHalo ifFalse: [self hideFlapUnlessOverReferent]! ! 113481 113482!FlapTab methodsFor: 'show & hide' stamp: 'sw 11/24/2001 21:50'! 113483hideFlapUnlessOverReferent 113484 "Hide the flap unless the mouse is over my referent." 113485 113486 | aWorld where | 113487 (referent isInWorld and: 113488 [where := self outermostWorldMorph activeHand lastEvent cursorPoint. 113489 referent bounds containsPoint: (referent globalPointToLocal: where)]) 113490 ifTrue: [^ self]. 113491 (aWorld := self world) ifNil: [^ self]. "In case flap tabs just got hidden" 113492 self referent delete. 113493 aWorld removeAccommodationForFlap: self. 113494 flapShowing := false. 113495 self isInWorld ifFalse: 113496 [self inboard ifTrue: [aWorld addMorphFront: self]]. 113497 self adjustPositionAfterHidingFlap! ! 113498 113499!FlapTab methodsFor: 'show & hide' stamp: 'sw 2/12/2001 16:49'! 113500lastReferentThickness: anInteger 113501 "Set the last remembered referent thickness to the given integer" 113502 113503 lastReferentThickness := anInteger! ! 113504 113505!FlapTab methodsFor: 'show & hide' stamp: 'RAA 6/2/2000 14:07'! 113506maybeHideFlapOnMouseLeave 113507 self hasHalo ifTrue: [^ self]. 113508 referent isInWorld ifFalse: [^ self]. 113509 self hideFlapUnlessOverReferent. 113510! ! 113511 113512!FlapTab methodsFor: 'show & hide' stamp: 'sw 3/5/1999 17:42'! 113513maybeHideFlapOnMouseLeaveDragging 113514 | aWorld | 113515 self hasHalo ifTrue: [^ self]. 113516 referent isInWorld ifFalse: [^ self]. 113517 (dragged or: [referent bounds containsPoint: self cursorPoint]) 113518 ifTrue: [^ self]. 113519 aWorld := self world. 113520 referent privateDelete. "could make me worldless if I'm inboard" 113521 aWorld ifNotNil: [aWorld removeAccommodationForFlap: self]. 113522 flapShowing := false. 113523 self isInWorld ifFalse: [aWorld addMorphFront: self]. 113524 self adjustPositionAfterHidingFlap! ! 113525 113526!FlapTab methodsFor: 'show & hide' stamp: 'sw 2/12/2001 16:59'! 113527openFully 113528 "Make an educated guess at how wide or tall we are to be, and open to that thickness" 113529 113530 | thickness amt | 113531 thickness := referent boundingBoxOfSubmorphs extent max: (100 @ 100). 113532 self applyThickness: (amt := self orientation == #horizontal 113533 ifTrue: 113534 [thickness y] 113535 ifFalse: 113536 [thickness x]). 113537 self lastReferentThickness: amt. 113538 self showFlap! ! 113539 113540!FlapTab methodsFor: 'show & hide' stamp: 'dgd 8/31/2004 16:25'! 113541showFlap 113542 "Open the flap up" 113543 113544 | thicknessToUse flapOwner | 113545 113546 "19 sept 2000 - going for all paste ups <- raa note" 113547 flapOwner := self pasteUpMorph. 113548 self referentThickness <= 0 113549 ifTrue: 113550 [thicknessToUse := lastReferentThickness ifNil: [100]. 113551 self orientation == #horizontal 113552 ifTrue: 113553 [referent height: thicknessToUse] 113554 ifFalse: 113555 [referent width: thicknessToUse]]. 113556 inboard ifTrue: 113557 [self stickOntoReferent]. "makes referent my owner, and positions me accordingly" 113558 referent pasteUpMorph == flapOwner 113559 ifFalse: 113560 [flapOwner accommodateFlap: self. "Make room if needed" 113561 flapOwner addMorphFront: referent. 113562 flapOwner startSteppingSubmorphsOf: referent. 113563 self positionReferent. 113564 referent adaptToWorld: flapOwner]. 113565 inboard ifFalse: 113566 [self adjustPositionVisAVisFlap]. 113567 flapShowing := true. 113568 113569 self pasteUpMorph hideFlapsOtherThan: self ifClingingTo: edgeToAdhereTo. 113570 113571 flapOwner bringTopmostsToFront! ! 113572 113573!FlapTab methodsFor: 'show & hide' stamp: 'sw 4/7/2000 07:51'! 113574showFlapIfHandLaden: evt 113575 "The hand has drifted over the receiver with the button down. If the hand is carrying anything, show the flap. If the hand is empty, the likely cause is that it's manipulating a scrollbar or some such, so in that case don't pop the flap out." 113576 113577 evt hand hasSubmorphs ifTrue: [self showFlap]! ! 113578 113579 113580!FlapTab methodsFor: 'solid tabs' stamp: 'sw 2/27/1999 13:16'! 113581applyTabThickness: newThickness 113582 (self orientation == #vertical) 113583 ifTrue: 113584 [submorphs first width: newThickness asNumber] 113585 ifFalse: 113586 [submorphs first height: newThickness asNumber]. 113587 self fitContents. 113588 self positionReferent. 113589 self adjustPositionVisAVisFlap! ! 113590 113591!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/21/1999 11:40'! 113592changeTabSolidity 113593 "Presently no actual options associated with this menu item if the flap is currently alreadly solid, so entertain the user with an anuran sound. However, in latest scheme, the corresponding menu item is disabled in this circumstance, so this method is effectively unreachable." 113594 113595 self playSoundNamed: 'croak'! ! 113596 113597!FlapTab methodsFor: 'solid tabs' stamp: 'DamienCassou 9/29/2009 12:58'! 113598changeTabThickness 113599 | newThickness | 113600 newThickness := UIManager default request: 'New thickness:' translated initialAnswer: self tabThickness printString. 113601 newThickness isEmptyOrNil ifFalse: [self applyTabThickness: newThickness]! ! 113602 113603!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/21/1999 11:39'! 113604isCurrentlySolid 113605 "Don't never use double negatives" 113606 113607 ^ self notSolid not! ! 113608 113609!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/21/1999 11:36'! 113610notSolid 113611 "Answer whether the receiver is currenty not solid. Used for determining whether the #solidTab menu item should be enabled" 113612 113613 ^ self isCurrentlyTextual or: [self isCurrentlyGraphical]! ! 113614 113615!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/20/1999 21:34'! 113616solidTab 113617 self isCurrentlySolid 113618 ifFalse: 113619 [self useSolidTab] 113620 ifTrue: 113621 [self changeTabSolidity]! ! 113622 113623!FlapTab methodsFor: 'solid tabs' stamp: 'dgd 8/30/2003 21:31'! 113624solidTabString 113625 ^ (self isCurrentlySolid 113626 ifTrue: ['currently using solid tab'] 113627 ifFalse: ['use solid tab']) translated! ! 113628 113629!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/20/1999 20:55'! 113630useSolidTab 113631 | thickness colorToUse | 113632 self preserveDetails. 113633 113634 thickness := self valueOfProperty: #priorThickness ifAbsent: [20]. 113635 colorToUse := self valueOfProperty: #priorColor ifAbsent: [Color red muchLighter]. 113636 self color: colorToUse. 113637 self removeAllMorphs. 113638 113639 (self orientation == #vertical) 113640 ifTrue: 113641 [self width: thickness. 113642 self height: self currentWorld height. 113643 self position: (self position x @ 0)] 113644 ifFalse: 113645 [self height: thickness. 113646 self width: self currentWorld width. 113647 self position: (0 @ self position y)]. 113648 113649 self borderWidth: 0. 113650 self layoutChanged.! ! 113651 113652 113653!FlapTab methodsFor: 'submorphs-add/remove' stamp: 'rbb 2/18/2005 14:13'! 113654dismissViaHalo 113655 "Dismiss the receiver (and its referent), unless it resists" 113656 113657 self resistsRemoval ifTrue: 113658 [(UIManager default chooseFrom: #( 'Yes' 'Um, no, let me reconsider') 113659 title: 'Really throw this flap away?') = 2 ifFalse: [^ self]]. 113660 113661 referent delete. 113662 self delete! ! 113663 113664 113665!FlapTab methodsFor: 'textual tabs' stamp: 'yo 7/16/2003 15:25'! 113666assumeString: aString font: aFont orientation: orientationSymbol color: aColor 113667 | aTextMorph workString tabStyle | 113668 labelString := aString asString. 113669 workString := orientationSymbol == #vertical 113670 ifTrue: 113671 [String streamContents: 113672 [:s | 113673 labelString do: [:c | s nextPut: c] separatedBy: [s nextPut: Character cr]]] 113674 ifFalse: [labelString]. 113675 tabStyle := (TextStyle new) 113676 leading: 0; 113677 newFontArray: (Array with: aFont). 113678 aTextMorph := (TextMorph new setTextStyle: tabStyle) 113679 contents: (workString asText addAttribute: (TextKern kern: 3)). 113680 self removeAllMorphs. 113681 self 113682 borderWidth: 2; 113683 borderColor: #raised. 113684 aColor ifNotNil: [self color: aColor]. 113685 self addMorph: aTextMorph centered. 113686 aTextMorph lock 113687 " 113688FlapTab allSubInstancesDo: [:ft | ft reformatTextualTab] 113689"! ! 113690 113691!FlapTab methodsFor: 'textual tabs' stamp: 'ar 9/3/2004 14:58'! 113692changeTabText: aString 113693 113694 | label | 113695 aString isEmptyOrNil ifTrue: [^ self]. 113696 label := Locale current languageEnvironment class flapTabTextFor: aString in: self. 113697 label isEmptyOrNil ifTrue: [^ self]. 113698 self useStringTab: label. 113699 submorphs first delete. 113700 self assumeString: label 113701 font: Preferences standardFlapFont 113702 orientation: (Flaps orientationForEdge: self edgeToAdhereTo) 113703 color: nil. 113704! ! 113705 113706!FlapTab methodsFor: 'textual tabs' stamp: 'sw 12/8/1999 18:16'! 113707reformatTextualTab 113708 "The font choice possibly having changed, reformulate the receiver" 113709 113710 self isCurrentlyTextual ifFalse: [^ self]. 113711 self assumeString: self existingWording font: Preferences standardFlapFont orientation: self orientation color: self color! ! 113712 113713!FlapTab methodsFor: 'textual tabs' stamp: 'sw 6/17/1999 13:21'! 113714textualTab 113715 self isCurrentlyTextual 113716 ifTrue: 113717 [self changeTabText] 113718 ifFalse: 113719 [self useTextualTab]! ! 113720 113721!FlapTab methodsFor: 'textual tabs' stamp: 'dgd 8/30/2003 21:27'! 113722textualTabString 113723 ^ (self isCurrentlyTextual 113724 ifTrue: ['change tab wording...'] 113725 ifFalse: ['use textual tab']) translated! ! 113726 113727!FlapTab methodsFor: 'textual tabs' stamp: 'di 11/17/2001 20:22'! 113728useStringTab: aString 113729 | aLabel | 113730 labelString := aString asString. 113731 aLabel := StringMorph new contents: labelString. 113732 self addMorph: aLabel. 113733 aLabel position: self position. 113734 aLabel highlightColor: self highlightColor; regularColor: self regularColor. 113735 aLabel lock. 113736 self fitContents. 113737 self layoutChanged! ! 113738 113739!FlapTab methodsFor: 'textual tabs' stamp: 'dgd 10/8/2003 19:03'! 113740useTextualTab 113741 | stringToUse colorToUse | 113742 self preserveDetails. 113743 colorToUse := self valueOfProperty: #priorColor ifAbsent: [Color green muchLighter]. 113744 submorphs notEmpty ifTrue: [self removeAllMorphs]. 113745 stringToUse := self valueOfProperty: #priorWording ifAbsent: ['Unnamed Flap' translated]. 113746 self assumeString: stringToUse font: Preferences standardFlapFont orientation: self orientation color: colorToUse! ! 113747 113748 113749!FlapTab methodsFor: 'thumbnail' stamp: 'sw 6/16/1999 11:29'! 113750permitsThumbnailing 113751 ^ false! ! 113752 113753 113754!FlapTab methodsFor: 'wiw support' stamp: 'RAA 10/3/2000 09:24'! 113755morphicLayerNumber 113756 ^self flapShowing ifTrue: [26] ifFalse: [25] "As navigators"! ! 113757 113758"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 113759 113760FlapTab class 113761 instanceVariableNames: ''! 113762 113763!FlapTab class methodsFor: 'as yet unclassified' stamp: 'di 11/19/2001 21:59'! 113764givenID: aFlapID matches: pureID 113765 "eg, FlapTab givenID: 'Stack Tools2' matches: 'Stack Tools' " 113766 113767 ^ aFlapID = pureID or: 113768 [(aFlapID beginsWith: pureID) 113769 and: [(aFlapID copyFrom: pureID size+1 to: aFlapID size) 113770 allSatisfy: [:c | c isDigit]]]! ! 113771 113772 113773!FlapTab class methodsFor: 'new-morph participation' stamp: 'kfr 5/3/2000 12:51'! 113774includeInNewMorphMenu 113775 "Not to be instantiated from the menu" 113776 ^ false! ! 113777 113778 113779!FlapTab class methodsFor: 'printing' stamp: 'sw 2/11/1999 14:39'! 113780defaultNameStemForInstances 113781 ^ 'flap tab'! ! 113782Object subclass: #Flaps 113783 instanceVariableNames: '' 113784 classVariableNames: 'FlapsQuads SharedFlapTabs SharedFlapsAllowed' 113785 poolDictionaries: '' 113786 category: 'Morphic-Worlds'! 113787!Flaps commentStamp: 'asm 3/13/2003 12:46' prior: 0! 113788ClassVariables 113789 113790FlapsQuads quads defining predefined flaps 113791 default flaps are: 'PlugIn Supplies', 'Stack Tools', 'Supplies', 'Tools', 'Widgets' and 'Scripting' 113792 113793SharedFlapTabs an array of flaps shared between squeak projects 113794SharedFlapsAllowed boolean 113795 113796! 113797 113798 113799"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 113800 113801Flaps class 113802 instanceVariableNames: ''! 113803 113804!Flaps class methodsFor: 'construction support' stamp: 'adrian_lienhard 7/19/2009 20:53'! 113805addMorph: aMorph asElementNumber: aNumber inGlobalFlapSatisfying: flapBlock 113806 "If any global flap satisfies flapBlock, add aMorph to it at the given position. Applies to flaps that are parts bins and that like thumbnailing" 113807 113808 | aFlapTab flapPasteUp | 113809 aFlapTab := self globalFlapTabsIfAny detect: [:aTab | flapBlock value: aTab] ifNone: [^ self]. 113810 flapPasteUp := aFlapTab referent. 113811 flapPasteUp addMorph: aMorph asElementNumber: aNumber. 113812 flapPasteUp setPartsBinStatusTo: true! ! 113813 113814!Flaps class methodsFor: 'construction support' stamp: 'sw 5/4/2001 23:52'! 113815addMorph: aMorph asElementNumber: aNumber inGlobalFlapWithID: anID 113816 "If any global flap satisfies flapBlock, add aMorph to it at the given position. No senders in the image -- intended to be invoked by doits in code updates only, and applies to flaps that are parts bins and that like thumbnailing" 113817 113818 ^ self addMorph: aMorph asElementNumber: aNumber inGlobalFlapSatisfying: [:aFlap | aFlap flapID = anID]! ! 113819 113820!Flaps class methodsFor: 'construction support' stamp: 'sw 4/30/2001 18:57'! 113821addToSuppliesFlap: aMorph asElementNumber: aNumber 113822 "Add the given morph to the supplies flap. To be called by doits in updates, so don't be alarmed by its lack of senders." 113823 113824 self addMorph: aMorph asElementNumber: aNumber inGlobalFlapWithID: 'Supplies'! ! 113825 113826!Flaps class methodsFor: 'construction support' stamp: 'sw 5/5/2001 02:12'! 113827deleteMorphsSatisfying: deleteBlock fromGlobalFlapSatisfying: flapBlock 113828 "If any global flap satisfies flapBlock, then delete objects satisfying from deleteBlock from it. Occasionally called from do-its in updates or other fileouts." 113829 113830 | aFlapTab flapPasteUp | 113831 aFlapTab := self globalFlapTabsIfAny detect: [:aTab | flapBlock value: aTab] ifNone: [^ self]. 113832 flapPasteUp := aFlapTab referent. 113833 flapPasteUp submorphs do: 113834 [:aMorph | (deleteBlock value: aMorph) ifTrue: [aMorph delete]]! ! 113835 113836 113837!Flaps class methodsFor: 'flap mechanics' stamp: 'sw 2/16/1999 18:29'! 113838clobberFlapTabList 113839 "Flaps clobberFlapTabList" 113840 113841 SharedFlapTabs := nil! ! 113842 113843!Flaps class methodsFor: 'flap mechanics' stamp: 'sw 7/12/2001 22:01'! 113844freshFlapsStart 113845 "To be called manually only, as a drastic measure. Delete all flap artifacts and establish fresh default global flaps 113846 Flaps freshFlapsStart 113847 " 113848 self currentWorld deleteAllFlapArtifacts. 113849 self clobberFlapTabList. 113850 self addStandardFlaps 113851! ! 113852 113853!Flaps class methodsFor: 'flap mechanics' stamp: 'dgd 10/7/2003 22:47'! 113854reinstateDefaultFlaps 113855 "Remove all existing 'standard' global flaps clear the global list, and and add fresh ones. To be called by doits in updates etc. This is a radical step, but it does *not* clobber non-standard global flaps or local flaps. To get the effect of the *former* version of this method, call Flaps freshFlapsStart" 113856 113857 "Flaps reinstateDefaultFlaps" 113858 self globalFlapTabsIfAny do: 113859 [:aFlapTab | 113860 ({ 113861 'Painting' translated. 113862 'Stack Tools' translated. 113863 'Squeak' translated. 113864 'Menu' translated. 113865 'Widgets' translated. 113866 'Tools' translated. 113867 'Supplies' translated. 113868 'Scripting' translated. 113869 'Objects' translated. 113870 'Navigator' translated 113871 } includes: aFlapTab flapID) ifTrue: 113872 [self removeFlapTab: aFlapTab keepInList: false]]. 113873 113874 "The following reduces the risk that flaps will be created with variant IDs 113875 such as 'Stack Tools2', potentially causing some shared flap logic to fail." 113876 "Smalltalk garbageCollect." "-- see if we are OK without this" 113877 113878 self addStandardFlaps. 113879 "self disableGlobalFlapWithID: 'Scripting'. 113880 self disableGlobalFlapWithID: 'Objects'." 113881 self currentWorld addGlobalFlaps. 113882 self currentWorld reformulateUpdatingMenus. 113883! ! 113884 113885!Flaps class methodsFor: 'flap mechanics' stamp: 'sw 4/17/2001 14:47'! 113886removeFlapTab: aFlapTab keepInList: aBoolean 113887 "Remove the given flap tab from the screen, and, if aBoolean is true, also from the global list" 113888 113889 (SharedFlapTabs ~~ nil and: [SharedFlapTabs includes: aFlapTab]) 113890 ifTrue: 113891 [aBoolean ifFalse: [self removeFromGlobalFlapTabList: aFlapTab]]. 113892 aFlapTab ifNotNil: 113893 [aFlapTab referent delete. 113894 aFlapTab delete]! ! 113895 113896 113897!Flaps class methodsFor: 'flaps registry' stamp: 'adrian_lienhard 7/19/2009 17:46'! 113898defaultsQuadsDefiningScriptingFlap 113899 "Answer a structure defining the default items in the Scripting flap. 113900 previously in quadsDeiningScriptingFlap" 113901 113902 ^ #( 113903 (SimpleSliderMorph authoringPrototype 'Slider' 'A slider for showing and setting numeric values.') 113904 (JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control') 113905 (TextFieldMorph exampleBackgroundField 'Scrolling Field' 'A scrolling data field which will have a different value on every card of the background') 113906 113907 (PasteUpMorph authoringPrototype 'Playfield' 'A place for assembling parts or for staging animations') 113908 113909 (TextMorph exampleBackgroundLabel 'Background Label' 'A piece of text that will occur on every card of the background') 113910 (TextMorph exampleBackgroundField 'Background Field' 'A data field which will have a different value on every card of the background') ) asOrderedCollection! ! 113911 113912!Flaps class methodsFor: 'flaps registry' stamp: 'stephane.ducasse 1/30/2009 22:49'! 113913defaultsQuadsDefiningStackToolsFlap 113914 "Answer a structure defining the items on the default system Stack Tools flap. 113915 previously in quadsDefiningStackToolsFlap" 113916 113917 ^ #( 113918 (TextMorph authoringPrototype 'Simple Text' 'Text that you can edit into anything you wish') 113919 (TextMorph fancyPrototype 'Fancy Text' 'A text field with a rounded shadowed border, with a fancy font.')) asOrderedCollection 113920! ! 113921 113922!Flaps class methodsFor: 'flaps registry' stamp: 'stephane.ducasse 5/1/2009 22:16'! 113923defaultsQuadsDefiningSuppliesFlap 113924 "Answer a list of quads which define the objects to appear in the default Supplies flap. 113925 previously in quadsDefiningSuppliesFlap" 113926 113927 ^ #( 113928 (RectangleMorph authoringPrototype 'Rectangle' 'A rectangle') 113929 (RectangleMorph roundRectPrototype 'RoundRect' 'A rectangle with rounded corners') 113930 (EllipseMorph authoringPrototype 'Ellipse' 'An ellipse or circle') 113931 (StarMorph authoringPrototype 'Star' 'A star') 113932 (CurveMorph authoringPrototype 'Curve' 'A curve') 113933 (PolygonMorph authoringPrototype 'Polygon' 'A straight-sided figure with any number of sides') 113934 (TextMorph boldAuthoringPrototype 'Text' 'Text that you can edit into anything you desire.') 113935 (ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something') 113936 (SimpleSliderMorph authoringPrototype 'Slider' 'A slider for showing and setting numeric values.') 113937 (PasteUpMorph authoringPrototype 'Playfield' 'A place for assembling parts or for staging animations') 113938 (JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control') 113939 (ClockMorph authoringPrototype 'Clock' 'A simple digital clock') 113940 ) asOrderedCollection! ! 113941 113942!Flaps class methodsFor: 'flaps registry' stamp: 'hfm 11/29/2008 20:06'! 113943defaultsQuadsDefiningToolsFlap 113944 "Answer a structure defining the default Tools flap. 113945 previously in quadsDefiningToolsFlap" 113946 113947 ^ OrderedCollection new 113948 addAll: #( 113949 (Browser prototypicalToolWindow 'Browser' 'A Browser is a tool that allows you to view all the code of all the classes in the system') 113950 (TranscriptStream openMorphicTranscript 'Transcript' 'A Transcript is a window usable for logging and debugging; browse references to #Transcript for examples of how to write to it.') 113951 (Workspace prototypicalToolWindow 'Workspace' 'A Workspace is a simple window for editing text. You can later save the contents to a file if you desire.')); 113952 add: { FileList . 113953 #prototypicalToolWindow. 113954 'File List'. 113955 'A File List is a tool for browsing folders and files on disks and FTP servers.' }; 113956 addAll: #( 113957 (DualChangeSorter prototypicalToolWindow 'Change Sorter' 'Shows two change sets side by side') 113958 (MessageNames prototypicalToolWindow 'Message Names' 'A tool for finding, viewing, and editing all methods whose names contain a given character sequence.') 113959 (Utilities recentSubmissionsWindow 'Recent' 'A message browser that tracks the most recently-submitted methods') 113960 (ProcessBrowser prototypicalToolWindow 'Processes' 'A Process Browser shows you all the running processes') 113961 (Preferences annotationEditingWindow 'Annotations' 'Allows you to specify the annotations to be shown in the annotation panes of browsers, etc.') 113962 (Scamper newOpenableMorph 'Scamper' 'A web browser') 113963 (Celeste newOpenableMorph 'Celeste' 'Celeste -- an EMail reader') 113964 (ChangeSorter prototypicalToolWindow 'Change Set' 'A tool that allows you to view and manipulate all the code changes in a single change set')); 113965 yourself! ! 113966 113967!Flaps class methodsFor: 'flaps registry' stamp: 'adrian_lienhard 7/19/2009 19:50'! 113968defaultsQuadsDefiningWidgetsFlap 113969 "Answer a structure defining the default Widgets flap. 113970 previously in quadsDefiningWidgetsFlap" 113971 113972 ^ #( 113973 (RecordingControlsMorph authoringPrototype 'Sound' 'A device for making sound recordings.') 113974 (MPEGMoviePlayerMorph authoringPrototype 'Movie Player' 'A Player for MPEG movies') 113975 (FrameRateMorph authoringPrototype 'Frame Rate' 'An indicator of how fast your system is running') 113976 (MagnifierMorph newRound 'Magnifier' 'A magnifying glass') 113977 (BouncingAtomsMorph new 'Bouncing Atoms' 'Atoms, mate') 113978 ) asOrderedCollection! ! 113979 113980!Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 10:58'! 113981initializeFlapsQuads 113982 "initialize the list of dynamic flaps quads. 113983 self initializeFlapsQuads" 113984 FlapsQuads := nil. 113985 self registeredFlapsQuads at: 'PlugIn Supplies' put: self defaultsQuadsDefiningPlugInSuppliesFlap; 113986 at: 'Stack Tools' put: self defaultsQuadsDefiningStackToolsFlap; 113987 at: 'Supplies' put: self defaultsQuadsDefiningSuppliesFlap; 113988 at: 'Tools' put: self defaultsQuadsDefiningToolsFlap; 113989 at: 'Widgets' put: self defaultsQuadsDefiningWidgetsFlap; 113990 at: 'Scripting' put: self defaultsQuadsDefiningScriptingFlap. 113991 ^ self registeredFlapsQuads! ! 113992 113993!Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 09:55'! 113994registeredFlapsQuads 113995 "Answer the list of dynamic flaps quads" 113996 113997 FlapsQuads ifNil: [FlapsQuads := Dictionary new]. 113998 ^ FlapsQuads 113999 114000" FlapsQuads := nil. "! ! 114001 114002!Flaps class methodsFor: 'flaps registry' stamp: 'hpt 4/26/2004 16:46'! 114003registeredFlapsQuadsAt: aLabel 114004 "Answer the list of dynamic flaps quads at aLabel" 114005 114006 ^ (self registeredFlapsQuads at: aLabel) 114007 removeAllSuchThat: [:q | (self environment includesKey: q first) not or: [(self environment at: q first) isNil]] 114008! ! 114009 114010!Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 11:09'! 114011registerQuad: aQuad forFlapNamed: aLabel 114012 "If any previous registration of the same label string is already known, delete the old one." 114013 114014 "aQuad received must be an array of the form {TargetObject. #command label 'A Help String'} 114015 114016Flaps registerQuad: #(FileList2 openMorphicViewInWorld 'Enhanced File List' 'A nicer File List.') 114017 forFlapNamed: 'Tools' " 114018 114019 self unregisterQuad: aQuad forFlapNamed: aLabel. 114020 (self registeredFlapsQuads at: aLabel) add: aQuad! ! 114021 114022!Flaps class methodsFor: 'flaps registry' stamp: 'ar 9/27/2005 22:10'! 114023unregisterQuadsWithReceiver: aReceiver 114024 "delete all quads with receiver aReceiver." 114025 self registeredFlapsQuads 114026 do: [:assoc | assoc value 114027 removeAllSuchThat: [:q | (self environment at: (q first) ifAbsent:[nil]) = aReceiver ]]! ! 114028 114029!Flaps class methodsFor: 'flaps registry' stamp: 'asm 4/12/2003 14:16'! 114030unregisterQuadsWithReceiver: aReceiver fromFlapNamed: aLabel 114031 "delete all quads with receiver aReceiver." 114032 (self registeredFlapsQuads at: aLabel) removeAllSuchThat: [:q | q first = aReceiver name]! ! 114033 114034!Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 10:34'! 114035unregisterQuad: aQuad forFlapNamed: aLabel 114036 "If any previous registration at the same label string has the same receiver-command, 114037 delete the old one." 114038 (self registeredFlapsQuadsAt: aLabel) 114039 removeAllSuchThat: [:q | q first = aQuad first 114040 and: [q second = aQuad second]]! ! 114041 114042 114043!Flaps class methodsFor: 'initialization' stamp: 'nk 6/14/2004 08:37'! 114044initialize 114045 self initializeFlapsQuads! ! 114046 114047 114048!Flaps class methodsFor: 'menu commands' stamp: 'mir 8/22/2001 18:55'! 114049disableGlobalFlaps 114050 "Clobber all the shared flaps structures. First read the user her Miranda rights." 114051 114052 self disableGlobalFlaps: true! ! 114053 114054!Flaps class methodsFor: 'menu commands' stamp: 'alain.plantec 5/30/2008 13:22'! 114055disableGlobalFlaps: interactive 114056 "Clobber all the shared flaps structures. First read the user her Miranda 114057 rights. " 114058 interactive 114059 ifTrue: [(self confirm: 'CAUTION!! This will destroy all the shared 114060flaps, so that they will not be present in 114061*any* project. If, later, you want them 114062back, you will have to reenable them, from 114063this same menu, whereupon the standard 114064default set of shared flaps will be created. 114065Do you really want to go ahead and clobber 114066all shared flaps at this time?' translated) 114067 ifFalse: [^ self]]. 114068 self globalFlapTabsIfAny 114069 do: [:aFlapTab | 114070 self removeFlapTab: aFlapTab keepInList: false. 114071 aFlapTab isInWorld 114072 ifTrue: [self error: 'Flap problem' translated]]. 114073 self clobberFlapTabList. 114074 SharedFlapsAllowed := false. 114075 ActiveWorld restoreMorphicDisplay. 114076 ActiveWorld reformulateUpdatingMenus! ! 114077 114078!Flaps class methodsFor: 'menu commands' stamp: 'alain.plantec 5/30/2008 13:20'! 114079disableGlobalFlapWithID: aFlapID 114080 "Mark this project as having the given flapID disabled" 114081 114082 | disabledFlapIDs aFlapTab currentProject | 114083 (currentProject := Project current) assureFlapIntegrity. 114084 disabledFlapIDs := currentProject parameterAt: #disabledGlobalFlapIDs. 114085 (aFlapTab := self globalFlapTabWithID: aFlapID) ifNotNil: 114086 [aFlapTab hideFlap]. 114087 (disabledFlapIDs includes: aFlapID) 114088 ifFalse: 114089 [disabledFlapIDs add: aFlapID]. 114090 aFlapTab ifNotNil: [aFlapTab delete] 114091 114092 ! ! 114093 114094!Flaps class methodsFor: 'menu commands' stamp: 'alain.plantec 5/30/2008 13:23'! 114095enableDisableGlobalFlapWithID: aFlapID 114096 "Toggle the enable/disable status of the given global flap" 114097 114098 | disabledFlapIDs aFlapTab currentProject | 114099 (currentProject := Project current) assureFlapIntegrity. 114100 disabledFlapIDs := currentProject parameterAt: #disabledGlobalFlapIDs. 114101 (aFlapTab := self globalFlapTabWithID: aFlapID) ifNotNil: 114102 [aFlapTab hideFlap]. 114103 (disabledFlapIDs includes: aFlapID) 114104 ifTrue: 114105 [disabledFlapIDs remove: aFlapID. 114106 self currentWorld addGlobalFlaps] 114107 ifFalse: 114108 [disabledFlapIDs add: aFlapID. 114109 aFlapTab ifNotNil: [aFlapTab delete]]. 114110 self doAutomaticLayoutOfFlapsIfAppropriate! ! 114111 114112!Flaps class methodsFor: 'menu commands' stamp: 'alain.plantec 5/30/2008 13:24'! 114113enableGlobalFlapWithID: aFlapID 114114 "Remove any memory of this flap being disabled in this project" 114115 114116 | disabledFlapIDs currentProject | 114117 (currentProject := Project current) assureFlapIntegrity. 114118 disabledFlapIDs := currentProject parameterAt: #disabledGlobalFlapIDs ifAbsent: [^ self]. 114119 disabledFlapIDs remove: aFlapID ifAbsent: [] 114120 ! ! 114121 114122!Flaps class methodsFor: 'menu commands' stamp: 'sw 3/3/2004 15:49'! 114123explainFlaps 114124 "Open a window giving flap help." 114125 114126 (StringHolder new contents: self explainFlapsText translated) 114127 openLabel: 'Flaps' translated 114128 114129"Flaps explainFlaps" 114130 114131 114132 114133 114134 ! ! 114135 114136!Flaps class methodsFor: 'menu commands' stamp: 'sw 3/3/2004 15:51'! 114137explainFlapsText 114138 "Answer the text, in English, to show in a help-window about Flaps." 114139 114140 ^'Flaps are like drawers on the edge of the screen, which can be opened so that you can use what is inside them, and closed when you do not need them. They have many possible uses, a few of which are illustrated by the default set of flaps you can get as described below. 114141 114142''Shared flaps'' are available in every morphic project. As you move from project to project, you will see these same shared flaps in each, though there are also options, on a project-by-project basis, to choose which of the shared flaps should be shown, and also momentarily to suppress the showing of all shared flaps. 114143 114144To get started using flaps, bring up the desktop menu and choose ''flaps...'', and make the menu stay up by choosing ''keep this menu up''. If you see, in this flaps menu, a list of flap names such as ''Squeak'', ''Tools'', etc., it means that shared flaps are already set up in your image. If you do not see the list, you will instead see a menu item that invites you to ''install default shared flaps''; choose that, and new flaps will be created, and the flaps menu will change to reflect their presence. 114145 114146''Project flaps'' are flaps that belong to a single morphic project. You will see them when you are in that project, but not when you are in any other morphic project. 114147 114148If a flap is set up as a parts bin (such as the default Tools and Supplies flaps), you can use it to create new objects -- just open the flap, then find the object you want, and drag it out; when the cursor leaves the flap, the flap itself will snap closed, and you''ll be left holding the new object -- just click to place it exactly where you want it. 114149 114150If a flap is *not* set up as a parts bin (such as the default ''Squeak'' flap at the left edge of the screen) you can park objects there (this is an easy way to move objects from project to project) and you can place your own private controls there, etc. Everything in the default ''Squeak'' flap (and all the other default flaps, for that matter) is there only for illustrative purposes -- every user will want to fine-tune the flaps to suit his/her own style and needs. 114151 114152Each flap may be set up to appear on mouseover, dragover, both, or neither. See the menu items described below for more about these and other options. 114153 114154You can open a closed flap by clicking on its tab, or by dragging the tab toward the center of the screen 114155 114156You can close an open flap by clicking on its tab or by dragging the tab back off the edge of the screen. 114157 114158Drag the tab of a flap to reposition the tab and to resize the flap itself. Repositioning starts when you drag the cursor out of the original tab area. 114159 114160If flaps or their tabs seem wrongly positioned or lost, try issuing a restoreDisplay from the screen menu. 114161 114162The red-halo menu on a flap allows you to change the flap''s properties. For greatest ease of use, request ''keep this menu up'' here -- that way, you can easily explore all the options in the menu. 114163 114164tab color... Lets you change the color of the flap''s tab. 114165flap color... Lets you change the color of the flap itself. 114166 114167use textual tab... If the tab is not textual, makes it become textual. 114168change tab wording... If the tab is already textual, allows you to edit 114169 its wording. 114170 114171use graphical tab... If the tab is not graphical, makes it become 114172 graphical. 114173choose tab graphic... If the tab is already graphical, allows you 114174 to change the picture. 114175 114176use solid tab... If the tab is not solid, makes it become solid, i.e. 114177 appear as a solid band of color along the 114178 entire length or width of the screen. 114179 114180parts-bin behavior If set, then dragging an object from the flap 114181 tears off a new copy of the object. 114182 114183dragover If set, the flap opens on dragover and closes 114184 again on drag-leave. 114185 114186mouseover If set, the flap opens on mouseover and closes 114187 again on mouse-leave. 114188 114189cling to edge... Governs which edge (left, right, top, bottom) 114190 the flap adheres to. 114191 114192shared If set, the same flap will be available in all projects; if not, the 114193 flap will will occur only in one project. 114194 114195destroy this flap Deletes the flap. 114196 114197To define a new flap, use ''make a new flap'', found in the ''flaps'' menu. 114198 114199To reinstate the default system flaps, you can use ''destroy all shared flaps'' from the ''flaps'' menu, and once they are destroyed, choose ''install default shared flaps''. 114200 114201To add, delete, or edit things on a given flap, it is often wise first to suspend the flap''s mouse-over and drag-over sensitivity, so it won''t keep disappearing on you while you''re trying to work with it. 114202 114203Besides the three standard flaps delivered with the default system, there are two other flaps readily available on demand from the ''flaps'' menu -- one is called ''Stack Tools'', which provides some tools useful for building stack-like content, the other is called ''Painting'', which provides a quick way to make a new painting. Simply clicking on the appropriate checkbox in the ''flaps'' menu will toggle the corresponding flap between being visible and not being visible in the project.'! ! 114204 114205 114206!Flaps class methodsFor: 'menu support' stamp: 'sw 4/24/2001 11:03'! 114207addIndividualGlobalFlapItemsTo: aMenu 114208 "Add items governing the enablement of specific global flaps to aMenu" 114209 114210 | anItem | 114211 self globalFlapTabsIfAny do: 114212 [:aFlapTab | 114213 anItem := aMenu addUpdating: #globalFlapWithIDEnabledString: enablementSelector: #showSharedFlaps target: self selector: #enableDisableGlobalFlapWithID: argumentList: {aFlapTab flapID}. 114214 anItem wordingArgument: aFlapTab flapID. 114215 anItem setBalloonText: aFlapTab balloonTextForFlapsMenu].! ! 114216 114217!Flaps class methodsFor: 'menu support' stamp: 'alain.plantec 5/30/2008 13:25'! 114218enableGlobalFlaps 114219 "Start using global flaps, given that they were not present." 114220 Cursor wait 114221 showWhile: [SharedFlapsAllowed := true. 114222 self globalFlapTabs. 114223 "This will create them" 114224 ActiveWorld addGlobalFlaps. 114225 self doAutomaticLayoutOfFlapsIfAppropriate. 114226 FlapTab 114227 allInstancesDo: [:aTab | aTab computeEdgeFraction]. 114228 ActiveWorld reformulateUpdatingMenus]! ! 114229 114230!Flaps class methodsFor: 'menu support' stamp: 'sw 4/17/2001 13:50'! 114231globalFlapWithIDEnabledString: aFlapID 114232 "Answer the string to be shown in a menu to represent the status of the givne flap regarding whether it it should be shown in this project." 114233 114234 | aFlapTab wording | 114235 aFlapTab := self globalFlapTabWithID: aFlapID. 114236 wording := aFlapTab ifNotNil: [aFlapTab wording] ifNil: ['(', aFlapID, ')']. 114237 ^ (Project current isFlapIDEnabled: aFlapID) 114238 ifTrue: 114239 ['<on>', wording] 114240 ifFalse: 114241 ['<off>', wording]! ! 114242 114243!Flaps class methodsFor: 'menu support' stamp: 'adrian_lienhard 7/19/2009 22:21'! 114244setUpSuppliesFlapOnly 114245 "Set up the Supplies flap as the only shared flap. A special version formulated for this stand-alone use is used, defined in #newLoneSuppliesFlap" 114246 114247 | | 114248 SharedFlapTabs isEmptyOrNil ifFalse: "get rid of pre-existing guys if any" 114249 [SharedFlapTabs do: 114250 [:t | t referent delete. t delete]]. 114251 114252 SharedFlapsAllowed := true. 114253 SharedFlapTabs := OrderedCollection new. 114254 self enableGlobalFlapWithID: 'Supplies' translated. 114255 114256 ActiveWorld addGlobalFlaps. 114257 ActiveWorld reformulateUpdatingMenus! ! 114258 114259!Flaps class methodsFor: 'menu support' stamp: 'dao 10/1/2004 12:59'! 114260showSharedFlaps 114261 "Answer whether shared flaps are currently showing. Presumably it is in service of Alan's wishes to have flaps show sometimes on interior subprojects and sometomes on outer projects that Bob's CurrentProjectRefactoring is threaded into the logic here." 114262 114263 ^ Project current showSharedFlaps! ! 114264 114265!Flaps class methodsFor: 'menu support' stamp: 'dao 10/1/2004 13:12'! 114266suppressFlapsString 114267 "Answer the string to be shown in a menu to represent the suppress-flaps-in-this-project status" 114268 114269 ^ Project current suppressFlapsString! ! 114270 114271 114272!Flaps class methodsFor: 'miscellaneous' stamp: 'sw 11/22/2001 10:04'! 114273automaticFlapLayoutChanged 114274 "Sent when the automaticFlapLayout preference changes. No senders in easily traceable in the image, but this is really sent by a Preference object!!" 114275 114276 Preferences automaticFlapLayout ifTrue: 114277 [self positionNavigatorAndOtherFlapsAccordingToPreference]! ! 114278 114279!Flaps class methodsFor: 'miscellaneous' stamp: 'sw 11/22/2001 09:58'! 114280doAutomaticLayoutOfFlapsIfAppropriate 114281 "Do automatic layout of flaps if appropriate" 114282 114283 Preferences automaticFlapLayout ifTrue: 114284 [self positionNavigatorAndOtherFlapsAccordingToPreference]! ! 114285 114286!Flaps class methodsFor: 'miscellaneous' stamp: 'sd 1/16/2004 21:33'! 114287fileOutChanges 114288 "Bug workaround for squeak-flap 'fileOutChanges' buttons which for a while were mistakenly sending their requests here..." 114289 114290 ^ ChangeSet current verboseFileOut. ! ! 114291 114292!Flaps class methodsFor: 'miscellaneous' stamp: 'sw 4/17/2001 13:24'! 114293orientationForEdge: anEdge 114294 "Answer the orientation -- #horizontal or #vertical -- that corresponds to the edge symbol" 114295 114296 ^ (#(left right) includes: anEdge) 114297 ifTrue: [#vertical] 114298 ifFalse: [#horizontal]! ! 114299 114300!Flaps class methodsFor: 'miscellaneous' stamp: 'sw 11/6/2000 14:23'! 114301removeFromGlobalFlapTabList: aFlapTab 114302 "If the flap tab is in the global list, remove it" 114303 114304 SharedFlapTabs remove: aFlapTab ifAbsent: []! ! 114305 114306 114307!Flaps class methodsFor: 'new flap' stamp: 'alain.plantec 2/9/2009 12:09'! 114308addLocalFlap 114309 "Menu command -- let the user add a new project-local flap. Once the new flap is born, the user can tell it to become a shared flap. Obtain an initial name and edge for the flap, launch the flap, and also launch a menu governing the flap, so that the user can get started right away with customizing it." 114310 114311 | aMenu reply aFlapTab aWorld edge | 114312 edge := UIManager default 114313 chooseFrom: (#(left right top bottom) collect: [:e | e translated]) 114314 values: #(left right top bottom) 114315 title: 'Where should the new flap cling?' translated. 114316 edge ifNotNil: 114317 [reply := UIManager default request: 'Wording for this flap: ' translated initialAnswer: 'Flap' translated. 114318 reply isEmptyOrNil ifFalse: 114319 [aFlapTab := self newFlapTitled: reply onEdge: edge. 114320 (aWorld := self currentWorld) addMorphFront: aFlapTab. 114321 aFlapTab adaptToWorld: aWorld. 114322 aMenu := aFlapTab buildHandleMenu: ActiveHand. 114323 aFlapTab addTitleForHaloMenu: aMenu. 114324 aFlapTab computeEdgeFraction. 114325 aMenu popUpEvent: ActiveEvent in: ActiveWorld]] 114326 114327! ! 114328 114329!Flaps class methodsFor: 'new flap' stamp: 'sw 5/4/2001 23:59'! 114330defaultColorForFlapBackgrounds 114331 "Answer the color to use, by default, in new flap backgrounds" 114332 114333 ^ (Color blue mixed: 0.8 with: Color white) alpha: 0.6! ! 114334 114335!Flaps class methodsFor: 'new flap' stamp: 'sw 4/17/2001 13:24'! 114336newFlapTitled: aString onEdge: anEdge 114337 "Create a new flap with the given title and place it on the given edge" 114338 114339 ^ self newFlapTitled: aString onEdge: anEdge inPasteUp: self currentWorld 114340! ! 114341 114342!Flaps class methodsFor: 'new flap' stamp: 'di 11/19/2001 21:07'! 114343newFlapTitled: aString onEdge: anEdge inPasteUp: aPasteUpMorph 114344 "Add a flap with the given title, placing it on the given edge, in the given pasteup" 114345 114346 | aFlapBody aFlapTab | 114347 aFlapBody := PasteUpMorph newSticky. 114348 aFlapTab := FlapTab new referent: aFlapBody. 114349 aFlapTab setName: aString edge: anEdge color: (Color r: 0.516 g: 0.452 b: 1.0). 114350 114351 anEdge == #left ifTrue: 114352 [aFlapTab position: (aPasteUpMorph left @ aPasteUpMorph top). 114353 aFlapBody extent: (200 @ aPasteUpMorph height)]. 114354 anEdge == #right ifTrue: 114355 [aFlapTab position: ((aPasteUpMorph right - aFlapTab width) @ aPasteUpMorph top). 114356 aFlapBody extent: (200 @ aPasteUpMorph height)]. 114357 anEdge == #top ifTrue: 114358 [aFlapTab position: ((aPasteUpMorph left + 50) @ aPasteUpMorph top). 114359 aFlapBody extent: (aPasteUpMorph width @ 200)]. 114360 anEdge == #bottom ifTrue: 114361 [aFlapTab position: ((aPasteUpMorph left + 50) @ (aPasteUpMorph bottom - aFlapTab height)). 114362 aFlapBody extent: (aPasteUpMorph width @ 200)]. 114363 114364 aFlapBody beFlap: true. 114365 aFlapBody color: self defaultColorForFlapBackgrounds. 114366 114367 ^ aFlapTab! ! 114368 114369 114370!Flaps class methodsFor: 'predefined flaps' stamp: 'adrian_lienhard 7/19/2009 22:27'! 114371addStandardFlaps 114372 "Initialize the standard default out-of-box set of global flaps. 114373 This method creates them and places them in my class 114374 variable #SharedFlapTabs, but does not itself get them 114375 displayed. " 114376 SharedFlapTabs ifNil: [SharedFlapTabs := OrderedCollection new]. 114377 SharedFlapTabs add: self newPharoFlap. 114378 "SharedFlapTabs add: self newPaintingFlap. Temporarily commented to make flaps working again until painting morph is fixed" 114379 self disableGlobalFlapWithID: 'Stack Tools' translated. 114380 self disableGlobalFlapWithID: 'Painting' translated. 114381 ^ SharedFlapTabs! ! 114382 114383!Flaps class methodsFor: 'predefined flaps' stamp: 'adrian_lienhard 7/19/2009 19:59'! 114384defaultsQuadsDefiningPlugInSuppliesFlap 114385 "Answer a list of quads which define the objects to appear in the default Supplies flap used in the Plug-in image" 114386 114387 ^ #( 114388 (GrabPatchMorph new 'Grab Patch' 'Allows you to create a new Sketch by grabbing a rectangular patch from the screen') 114389 (LassoPatchMorph new 'Lasso' 'Allows you to create a new Sketch by lassoing an area from the screen') 114390 114391 "(StickyPadMorph newStandAlone 'Sticky Pad' 'Each time you obtain one of these pastel, translucent, borderless rectangles, it will be a different color from the previous time.') 114392 (PaintInvokingMorph new 'Paint' 'Drop this into an area to start making a fresh painting there')" 114393 (TextMorph boldAuthoringPrototype 'Text' 'Text that you can edit into anything you desire.') 114394 (RecordingControlsMorph authoringPrototype 'Sound' 'A device for making sound recordings.') 114395 (RectangleMorph authoringPrototype 'Rectangle' 'A rectangle') 114396 (RectangleMorph roundRectPrototype 'RoundRect' 'A rectangle with rounded corners') 114397 (EllipseMorph authoringPrototype 'Ellipse' 'An ellipse or circle') 114398 (StarMorph authoringPrototype 'Star' 'A star') 114399 (CurveMorph authoringPrototype 'Curve' 'A curve') 114400 (PolygonMorph authoringPrototype 'Polygon' 'A straight-sided figure with any number of sides') 114401 (PasteUpMorph authoringPrototype 'Playfield' 'A place for assembling parts or for staging animations') 114402 (SimpleSliderMorph authoringPrototype 'Slider' 'A slider for showing and setting numeric values.') 114403 (JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control') 114404 (ClockMorph authoringPrototype 'Clock' 'A simple digital clock')) asOrderedCollection! ! 114405 114406!Flaps class methodsFor: 'predefined flaps' stamp: 'sw 8/12/2001 16:55'! 114407initializeStandardFlaps 114408 "Initialize the standard default out-of-box set of global flaps. This method creates them and places them in my class variable #SharedFlapTabs, but does not itself get them displayed." 114409 114410 SharedFlapTabs := nil. 114411 self addStandardFlaps! ! 114412 114413!Flaps class methodsFor: 'predefined flaps' stamp: 'adrian_lienhard 7/19/2009 18:02'! 114414newPharoFlap 114415 "Answer a new default 'Pharo' flap for the left edge of the screen" 114416 114417 | aFlap aFlapTab aButton aClock buttonColor anOffset bb aFont | 114418 aFlap := PasteUpMorph newSticky borderWidth: 0. 114419 aFlapTab := FlapTab new referent: aFlap. 114420 aFlapTab setName: 'Pharo' translated edge: #left color: (Color gray lighter lighter). 114421 aFlapTab position: (0 @ ((Display height - aFlapTab height) // 8)). 114422 aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu. 114423 114424 aFlap cellInset: 14@14. 114425 aFlap beFlap: true. 114426 aFlap color: (Color gray muchLighter alpha: 0.8). 114427 aFlap extent: 150 @ self currentWorld height. 114428 aFlap layoutPolicy: TableLayout new. 114429 aFlap wrapCentering: #topLeft. 114430 aFlap layoutInset: 2. 114431 aFlap listDirection: #topToBottom. 114432 aFlap wrapDirection: #leftToRight. 114433 114434 "self addProjectNavigationButtonsTo: aFlap." 114435 anOffset := 16. 114436 114437 buttonColor := Color cyan muchLighter. 114438 bb := SimpleButtonMorph new target: SmalltalkImage current. 114439 bb color: buttonColor. 114440 aButton := bb copy. 114441 aButton actionSelector: #saveSession. 114442 aButton setBalloonText: 'Make a complete snapshot of the current state of the image onto disk.' translated. 114443 aButton label: 'save' translated font: (aFont := Preferences standardEToysFont). 114444 aFlap addCenteredAtBottom: aButton offset: anOffset. 114445 114446 aButton := bb copy target: Utilities. 114447 aButton actionSelector: #updateFromServer. 114448 aButton label: 'load code updates' translated font: aFont. 114449 aButton color: buttonColor. 114450 aButton setBalloonText: 'Check the Pharo server for any new code updates, and load any that are found.' translated. 114451 aFlap addCenteredAtBottom: aButton offset: anOffset. 114452 114453 aButton := SimpleButtonMorph new target: SmalltalkImage current; actionSelector: #aboutThisSystem; 114454 label: 'about this system' translated font: aFont. 114455 aButton color: buttonColor. 114456 aButton setBalloonText: 'click here to find out version information' translated. 114457 aFlap addCenteredAtBottom: aButton offset: anOffset. 114458 114459 aFlap addCenteredAtBottom: (Preferences themeChoiceButtonOfColor: buttonColor font: aFont) offset: anOffset. 114460 114461 ^ aFlapTab 114462 114463"Flaps replaceGlobalFlapwithID: 'Pharo' translated "! ! 114464 114465!Flaps class methodsFor: 'predefined flaps' stamp: 'sw 3/3/2004 13:38'! 114466quadsDefiningPlugInSuppliesFlap 114467 "Answer a list of quads which define the objects to appear in the default Supplies flap used in the Plug-in image" 114468 114469 ^ self registeredFlapsQuadsAt: 'PlugIn Supplies'! ! 114470 114471!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:25'! 114472quadsDefiningStackToolsFlap 114473 "Answer a structure defining the items on the default system Stack Tools flap" 114474 114475 ^ self registeredFlapsQuadsAt: 'Stack Tools' 114476 114477 "Flaps replaceGlobalFlapwithID: 'Stack Tools'"! ! 114478 114479!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:26'! 114480quadsDefiningSuppliesFlap 114481 "Answer a list of quads which define the objects to appear in the default Supplies flap" 114482 114483 ^ self registeredFlapsQuadsAt: 'Supplies'! ! 114484 114485!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:51'! 114486quadsDefiningToolsFlap 114487 "Answer a structure defining the default Tools flap" 114488 114489 ^ self registeredFlapsQuadsAt: 'Tools'! ! 114490 114491!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:26'! 114492quadsDefiningWidgetsFlap 114493 "Answer a structure defining the default Widgets flap" 114494 114495 ^ self registeredFlapsQuadsAt: 'Widgets'! ! 114496 114497!Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:26'! 114498quadsDeiningScriptingFlap 114499 "Answer a structure defining the default items in the Scripting flap" 114500 114501 ^ self registeredFlapsQuadsAt: 'Scripting'! ! 114502 114503!Flaps class methodsFor: 'predefined flaps' stamp: 'adrian_lienhard 7/19/2009 19:59'! 114504twiddleSuppliesButtonsIn: aStrip 114505 "Munge item(s) in the strip whose names as seen in the parts bin should be different from the names to be given to resulting torn-off instances" 114506 114507 " 114508 (aStrip submorphs detect: [:m | m target == StickyPadMorph] ifNone: [nil]) 114509 ifNotNil: 114510 [:aButton | aButton arguments: {#newStandAlone. 'tear off'}] 114511 "! ! 114512 114513 114514!Flaps class methodsFor: 'replacement' stamp: 'adrian_lienhard 7/19/2009 22:27'! 114515replaceGlobalFlapwithID: flapID 114516 "If there is a global flap with flapID, replace it with an updated one." 114517 114518 | replacement tabs | 114519 (tabs := self globalFlapTabsWithID: flapID) size = 0 ifTrue: [^ self]. 114520 tabs do: [:tab | 114521 self removeFlapTab: tab keepInList: false]. 114522 flapID = 'Pharo' translated ifTrue: [replacement := self newPharoFlap]. 114523 replacement ifNil: [^ self]. 114524 self addGlobalFlap: replacement. 114525 self currentWorld ifNotNil: [self currentWorld addGlobalFlaps] 114526 114527"Flaps replaceFlapwithID: 'Widgets' translated "! ! 114528 114529!Flaps class methodsFor: 'replacement' stamp: 'adrian_lienhard 7/19/2009 20:54'! 114530replacePartSatisfying: elementBlock inGlobalFlapSatisfying: flapBlock with: replacement 114531 "If any global flap satisfies flapBlock, look in it for a part satisfying elementBlock; if such a part is found, replace it with the replacement morph, make sure the flap's layout is made right, etc." 114532 114533 | aFlapTab flapPasteUp anElement | 114534 aFlapTab := self globalFlapTabsIfAny detect: [:aTab | flapBlock value: aTab] ifNone: [^ self]. 114535 flapPasteUp := aFlapTab referent. 114536 anElement := flapPasteUp submorphs detect: [:aMorph | elementBlock value: aMorph] ifNone: [^ self]. 114537 flapPasteUp replaceSubmorph: anElement by: replacement. 114538 flapPasteUp setPartsBinStatusTo: true. 114539 114540"Flaps replacePartSatisfying: [:el | (el isKindOf: MorphThumbnail) and: [(el morphRepresented isKindOf: SystemWindow) and: [el morphRepresented label = 'scripting area']]] 114541inGlobalFlapSatisfying: [:fl | (fl submorphs size > 0) and: [(fl submorphs first isKindOf: TextMorph) and: [(fl submorphs first contents string copyWithout: Character cr) = 'Tools']]] with: ScriptingSystem newScriptingSpace"! ! 114542 114543!Flaps class methodsFor: 'replacement' stamp: 'sw 4/17/2001 13:15'! 114544replacePartSatisfying: elementBlock inGlobalFlapWithID: aFlapID with: replacement 114545 "If a global flapl exists with the given flapID, look in it for a part satisfying elementBlock; if such a part is found, replace it with the replacement morph, make sure the flap's layout is made right, etc." 114546 114547 ^ self replacePartSatisfying: elementBlock inGlobalFlapSatisfying: [:fl | fl flapID = aFlapID] with: replacement! ! 114548 114549!Flaps class methodsFor: 'replacement' stamp: 'dgd 8/31/2003 19:41'! 114550replaceToolsFlap 114551 "if there is a global tools flap, replace it with an updated one." 114552 114553 self replaceGlobalFlapwithID: 'Tools' translated 114554 114555"Flaps replaceToolsFlap"! ! 114556 114557 114558!Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/17/2001 13:31'! 114559addGlobalFlap: aFlapTab 114560 "Add the given flap tab to the list of shared flaps" 114561 114562 SharedFlapTabs ifNil: [SharedFlapTabs := OrderedCollection new]. 114563 SharedFlapTabs add: aFlapTab! ! 114564 114565!Flaps class methodsFor: 'shared flaps' stamp: 'sw 7/24/2001 22:01'! 114566enableOnlyGlobalFlapsWithIDs: survivorList 114567 "In the current project, suppress all global flaps other than those with ids in the survivorList" 114568 114569 self globalFlapTabsIfAny do: [:aFlapTab | 114570 (survivorList includes: aFlapTab flapID) 114571 ifTrue: 114572 [self enableGlobalFlapWithID: aFlapTab flapID] 114573 ifFalse: 114574 [self disableGlobalFlapWithID: aFlapTab flapID]]. 114575 ActiveWorld addGlobalFlaps 114576 114577 "Flaps enableOnlyGlobalFlapsWithIDs: #('Supplies')"! ! 114578 114579!Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/27/2001 16:36'! 114580globalFlapTabOrDummy: aName 114581 "Answer a global flap tab in the current image with the given name. If none is found, answer a dummy StringMorph for some reason (check with tk about the use of this)" 114582 114583 | gg | 114584 (gg := self globalFlapTab: aName) ifNil: 114585 [^ StringMorph contents: aName, ' can''t be found']. 114586 ^ gg! ! 114587 114588!Flaps class methodsFor: 'shared flaps' stamp: 'sw 5/5/2001 02:41'! 114589globalFlapTabs 114590 "Answer the list of shared flap tabs, creating it if necessary. Much less aggressive is #globalFlapTabsIfAny" 114591 114592 SharedFlapTabs ifNil: [self initializeStandardFlaps]. 114593 ^ SharedFlapTabs copy! ! 114594 114595!Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/23/2001 18:04'! 114596globalFlapTabsIfAny 114597 "Answer a list of the global flap tabs, but it they don't exist, just answer an empty list" 114598 114599 ^ SharedFlapTabs copy ifNil: [Array new]! ! 114600 114601!Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/8/2002 08:41'! 114602globalFlapTabsWithID: aFlapID 114603 "Answer all flap tabs whose ids start with the given id" 114604 114605 ^ self globalFlapTabsIfAny select: 114606 [:aFlapTab | 114607 (aFlapTab flapID = aFlapID) or: [FlapTab givenID: aFlapTab flapID matches: aFlapID]] 114608 114609"Flaps globalFlapTabsWithID: 'Stack Tools'"! ! 114610 114611!Flaps class methodsFor: 'shared flaps' stamp: 'di 11/19/2001 22:07'! 114612globalFlapTabWithID: aFlapID 114613 "answer the global flap tab with the given id, or nil if none" 114614 114615 ^ self globalFlapTabsIfAny detect: [:aFlapTab | aFlapTab flapID = aFlapID] 114616 ifNone: 114617 ["Second try allows sequence numbers" 114618 self globalFlapTabsIfAny detect: [:aFlapTab | FlapTab givenID: aFlapTab flapID matches: aFlapID] 114619 ifNone: [nil]]! ! 114620 114621!Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/27/2001 16:34'! 114622globalFlapTab: aName 114623 "Answer the global flap tab in the current system whose flapID is the same as aName, or nil if none found." 114624 114625 | idToMatch | 114626 idToMatch := (aName beginsWith: 'flap: ') 114627 ifTrue: "Ted's old scheme; this convention may still be found 114628 in pre-existing content that has been externalized" 114629 [aName copyFrom: 7 to: aName size] 114630 ifFalse: 114631 [aName]. 114632 114633 ^ self globalFlapTabsIfAny detect: [:ft | ft flapID = idToMatch] ifNone: [nil]! ! 114634 114635!Flaps class methodsFor: 'shared flaps' stamp: 'marcus.denker 11/26/2008 14:19'! 114636positionNavigatorAndOtherFlapsAccordingToPreference 114637 "Lay out flaps along the designated edge right-to-left, possibly positioning the navigator flap, exceptionally, on the left." 114638 114639 114640 Flaps positionVisibleFlapsRightToLeftOnEdge: #bottom butPlaceAtLeftFlapsWithIDs: {'Navigator' translated}. 114641 114642"Flaps positionNavigatorAndOtherFlapsAccordingToPreference"! ! 114643 114644!Flaps class methodsFor: 'shared flaps' stamp: 'dgd 8/31/2003 19:29'! 114645positionVisibleFlapsRightToLeftOnEdge: edgeSymbol butPlaceAtLeftFlapsWithIDs: idList 114646 "Lay out flaps along the designated edge right-to-left, while laying left-to-right any flaps found in the exception list 114647 114648 Flaps positionVisibleFlapsRightToLeftOnEdge: #bottom butPlaceAtLeftFlapWithIDs: {'Navigator' translated. 'Supplies' translated} 114649 Flaps sharedFlapsAlongBottom" 114650 114651 | leftX flapList flapsOnRight flapsOnLeft | 114652 flapList := self globalFlapTabsIfAny select: 114653 [:aFlapTab | aFlapTab isInWorld and: [aFlapTab edgeToAdhereTo == edgeSymbol]]. 114654 flapsOnLeft := flapList select: [:fl | idList includes: fl flapID]. 114655 flapList removeAll: flapsOnLeft. 114656 114657 flapsOnRight := flapList asSortedCollection: 114658 [:f1 :f2 | f1 left > f2 left]. 114659 leftX := ActiveWorld width - 15. 114660 114661 flapsOnRight do: 114662 [:aFlapTab | 114663 aFlapTab right: leftX - 3. 114664 leftX := aFlapTab left]. 114665 114666 leftX := ActiveWorld left. 114667 flapsOnLeft := flapsOnLeft asSortedCollection: 114668 [:f1 :f2 | f1 left > f2 left]. 114669 flapsOnLeft do: 114670 [:aFlapTab | 114671 aFlapTab left: leftX + 3. 114672 leftX := aFlapTab right]. 114673 114674 (flapsOnLeft asOrderedCollection, flapsOnRight asOrderedCollection) do: 114675 [:ft | ft computeEdgeFraction. 114676 ft flapID = 'Navigator' translated ifTrue: 114677 [ft referent left: (ft center x - (ft referent width//2) max: 0)]] 114678! ! 114679 114680!Flaps class methodsFor: 'shared flaps' stamp: 'mir 8/24/2001 20:42'! 114681removeDuplicateFlapTabs 114682 "Remove flaps that were accidentally added multiple times" 114683 "Flaps removeDuplicateFlapTabs" 114684 | tabs duplicates same | 114685 SharedFlapTabs copy ifNil: [^self]. 114686 tabs := SharedFlapTabs copy. 114687 duplicates := Set new. 114688 tabs do: [:tab | 114689 same := tabs select: [:each | each wording = tab wording]. 114690 same isEmpty not 114691 ifTrue: [ 114692 same removeFirst. 114693 duplicates addAll: same]]. 114694 SharedFlapTabs removeAll: duplicates! ! 114695 114696!Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/24/2001 11:17'! 114697sharedFlapsAllowed 114698 "Answer whether the shared flaps feature is allowed in this system" 114699 114700 ^ SharedFlapsAllowed ifNil: [SharedFlapsAllowed := SharedFlapTabs isEmptyOrNil not]! ! 114701 114702!Flaps class methodsFor: 'shared flaps' stamp: 'marcus.denker 11/10/2008 10:04'! 114703sharedFlapsAlongBottom 114704 "Put all shared flaps (except Painting which can't be moved) along the bottom" 114705 "Flaps sharedFlapsAlongBottom" 114706 114707 | leftX unordered ordered | 114708 unordered := self globalFlapTabsIfAny asIdentitySet. 114709 ordered := Array streamContents: 114710 [:s | { 114711 'Squeak' translated. 114712 'Navigator' translated. 114713 'Supplies' translated. 114714 'Widgets' translated. 114715 'Stack Tools' translated. 114716 'Tools' translated. 114717 'Painting' translated. 114718 } do: 114719 [:id | (self globalFlapTabWithID: id) ifNotNil: 114720 [:ft | unordered remove: ft. 114721 id = 'Painting' translated ifFalse: [s nextPut: ft]]]]. 114722 114723 "Pace off in order from right to left, setting positions" 114724 leftX := Display width-15. 114725 ordered , unordered asArray reverseDo: 114726 [:ft | ft setEdge: #bottom. 114727 ft right: leftX - 3. leftX := ft left]. 114728 114729 "Put Nav Bar centered under tab if possible" 114730 (self globalFlapTabWithID: 'Navigator' translated) ifNotNil: 114731 [:ft | ft referent left: (ft center x - (ft referent width//2) max: 0)]. 114732 self positionNavigatorAndOtherFlapsAccordingToPreference. 114733! ! 114734 114735 114736!Flaps class methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 16:09'! 114737newSqueakFlap 114738 "Answer a new default 'Squeak' flap for the left edge of the screen" 114739 114740 | aFlap aFlapTab aButton buttonColor anOffset bb aFont | 114741 self deprecated: 'This is Pharo, use ''newPharoFlap'' instead.'. 114742 aFlap := PasteUpMorph newSticky borderWidth: 0. 114743 aFlapTab := FlapTab new referent: aFlap. 114744 aFlapTab setName: 'Squeak' translated edge: #left color: Color brown lighter lighter. 114745 aFlapTab position: (0 @ ((Display height - aFlapTab height) // 2)). 114746 aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu. 114747 114748 aFlap cellInset: 14@14. 114749 aFlap beFlap: true. 114750 aFlap color: (Color brown muchLighter lighter "alpha: 0.3"). 114751 aFlap extent: 150 @ self currentWorld height. 114752 aFlap layoutPolicy: TableLayout new. 114753 aFlap wrapCentering: #topLeft. 114754 aFlap layoutInset: 2. 114755 aFlap listDirection: #topToBottom. 114756 aFlap wrapDirection: #leftToRight. 114757 114758 "self addProjectNavigationButtonsTo: aFlap." 114759 anOffset := 16. 114760 114761 buttonColor := Color cyan muchLighter. 114762 bb := SimpleButtonMorph new target: SmalltalkImage current. 114763 bb color: buttonColor. 114764 aButton := bb copy. 114765 aButton actionSelector: #saveSession. 114766 aButton setBalloonText: 'Make a complete snapshot of the current state of the image onto disk.' translated. 114767 aButton label: 'save' translated font: (aFont := Preferences standardEToysFont). 114768 aFlap addCenteredAtBottom: aButton offset: anOffset. 114769 114770 aButton := bb copy target: Utilities. 114771 aButton actionSelector: #updateFromServer. 114772 aButton label: 'load code updates' translated font: aFont. 114773 aButton color: buttonColor. 114774 aButton setBalloonText: 'Check the Squeak server for any new code updates, and load any that are found.' translated. 114775 aFlap addCenteredAtBottom: aButton offset: anOffset. 114776 114777 aButton := SimpleButtonMorph new target: SmalltalkImage current; actionSelector: #aboutThisSystem; 114778 label: 'about this system' translated font: aFont. 114779 aButton color: buttonColor. 114780 aButton setBalloonText: 'click here to find out version information' translated. 114781 aFlap addCenteredAtBottom: aButton offset: anOffset. 114782 114783 aFlap addCenteredAtBottom: (Preferences themeChoiceButtonOfColor: buttonColor font: aFont) offset: anOffset. 114784 114785 ^ aFlapTab 114786 114787"Flaps replaceGlobalFlapwithID: 'Squeak' translated "! ! 114788NullEncoder subclass: #FlattenEncoder 114789 instanceVariableNames: '' 114790 classVariableNames: '' 114791 poolDictionaries: '' 114792 category: 'Morphic-Support'! 114793!FlattenEncoder commentStamp: '<historical>' prior: 0! 114794The simplest possible encoding: leave the objects as is. 114795! 114796 114797 114798!FlattenEncoder methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:32'! 114799elementSeparator 114800 ^target elementSeparator.! ! 114801 114802 114803!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 21:51'! 114804cr 114805 ^self print:String cr. 114806 114807! ! 114808 114809!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 21:50'! 114810writeArrayedCollection:anArrayedCollection 114811 ^self writeCollectionContents:anArrayedCollection. 114812 114813! ! 114814 114815!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 01:03'! 114816writeCollection:aCollection 114817 ^self writeCollectionContents:aCollection. 114818 114819! ! 114820 114821!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:26'! 114822writeCollectionContents:aCollection 114823 ^self writeCollectionContents:aCollection separator:self elementSeparator iterationMessage:#do:. 114824 114825! ! 114826 114827!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:26'! 114828writeCollectionContents:aCollection separator:separator 114829 ^self writeCollectionContents:aCollection separator:separator iterationMessage:#do:.! ! 114830 114831!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:25'! 114832writeCollectionContents:aCollection separator:separator iterationMessage:op 114833 | first | 114834 first := true. 114835 aCollection perform:op with: [ :each | first ifFalse:[ self writeObject:separator ]. self write:each. first:=false.]. 114836! ! 114837 114838!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:30'! 114839writeDictionary:aCollection 114840 ^self writeDictionaryContents:aCollection separator:nil. 114841 114842! ! 114843 114844!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:29'! 114845writeDictionaryContents:aCollection separator:separator 114846 ^self writeCollectionContents:aCollection separator:separator iterationMessage:#associationsDo:.! ! 114847 114848"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 114849 114850FlattenEncoder class 114851 instanceVariableNames: ''! 114852 114853!FlattenEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 00:08'! 114854filterSelector 114855 ^#flattenOnStream: 114856! ! 114857Number variableWordSubclass: #Float 114858 instanceVariableNames: '' 114859 classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 ThreePi Twopi' 114860 poolDictionaries: '' 114861 category: 'Kernel-Numbers'! 114862!Float commentStamp: '<historical>' prior: 0! 114863My instances represent IEEE-754 floating-point double-precision numbers. They have about 16 digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: 114864 114865 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 114866 114867Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Squeak Float constants. This is great for teaching about numbers, but may be confusing to the average reader: 114868 114869 3r20.2 --> 6.66666666666667 114870 8r20.2 --> 16.25 114871 114872If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... 114873 sign 1 bit 114874 exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent 114875 in the range -1023 .. +1024 114876 - 16r000: 114877 significand = 0: Float zero 114878 significand ~= 0: Denormalized number (exp = -1024, no hidden '1' bit) 114879 - 16r7FF: 114880 significand = 0: Infinity 114881 significand ~= 0: Not A Number (NaN) representation 114882 mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. 114883 114884The single-precision format is... 114885 sign 1 bit 114886 exponent 8 bits, with bias of 127, to represent -126 to +127 114887 - 0x0 and 0xFF reserved for Float zero (mantissa is ignored) 114888 - 16r7F reserved for Float underflow/overflow (mantissa is ignored) 114889 mantissa 24 bits, but only 23 are stored 114890This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. 114891 114892Thanks to Rich Harmon for asking many questions and to Tim Olson, Bruce Cohen, Rick Zaccone and others for the answers that I have collected here.! 114893 114894 114895!Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:54'! 114896* aNumber 114897 "Primitive. Answer the result of multiplying the receiver by aNumber. 114898 Fail if the argument is not a Float. Essential. See Object documentation 114899 whatIsAPrimitive." 114900 114901 <primitive: 49> 114902 ^ aNumber adaptToFloat: self andSend: #*! ! 114903 114904!Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:22'! 114905+ aNumber 114906 "Primitive. Answer the sum of the receiver and aNumber. Essential. 114907 Fail if the argument is not a Float. See Object documentation 114908 whatIsAPrimitive." 114909 114910 <primitive: 41> 114911 ^ aNumber adaptToFloat: self andSend: #+! ! 114912 114913!Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:55'! 114914- aNumber 114915 "Primitive. Answer the difference between the receiver and aNumber. 114916 Fail if the argument is not a Float. Essential. See Object documentation 114917 whatIsAPrimitive." 114918 114919 <primitive: 42> 114920 ^ aNumber adaptToFloat: self andSend: #-! ! 114921 114922!Float methodsFor: 'arithmetic' stamp: 'GabrielOmarCotelli 6/6/2009 17:12'! 114923/ aNumber 114924 "Primitive. Answer the result of dividing receiver by aNumber. 114925 Fail if the argument is not a Float. Essential. See Object documentation 114926 whatIsAPrimitive." 114927 114928 <primitive: 50> 114929 aNumber = 0.0 ifTrue: [ ZeroDivide signalWithDividend: self]. 114930 ^aNumber adaptToFloat: self andSend: #/! ! 114931 114932!Float methodsFor: 'arithmetic'! 114933abs 114934 "This is faster than using Number abs." 114935 self < 0.0 114936 ifTrue: [^ 0.0 - self] 114937 ifFalse: [^ self]! ! 114938 114939!Float methodsFor: 'arithmetic'! 114940negated 114941 "Answer a Number that is the negation of the receiver." 114942 114943 ^0.0 - self! ! 114944 114945!Float methodsFor: 'arithmetic' stamp: 'GabrielOmarCotelli 5/23/2009 20:40'! 114946reciprocal 114947 114948 "Returns the reciprocal. 114949 If self is 0.0 the / signals a ZeroDivide" 114950 114951 ^1.0 / self! ! 114952 114953 114954!Float methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:36'! 114955< aNumber 114956 "Primitive. Compare the receiver with the argument and return true 114957 if the receiver is less than the argument. Otherwise return false. 114958 Fail if the argument is not a Float. Essential. See Object documentation 114959 whatIsAPrimitive." 114960 114961 <primitive: 43> 114962 ^ aNumber adaptToFloat: self andCompare: #<! ! 114963 114964!Float methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:36'! 114965<= aNumber 114966 "Primitive. Compare the receiver with the argument and return true 114967 if the receiver is less than or equal to the argument. Otherwise return 114968 false. Fail if the argument is not a Float. Optional. See Object 114969 documentation whatIsAPrimitive." 114970 114971 <primitive: 45> 114972 ^ aNumber adaptToFloat: self andCompare: #<=! ! 114973 114974!Float methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:36'! 114975= aNumber 114976 "Primitive. Compare the receiver with the argument and return true 114977 if the receiver is equal to the argument. Otherwise return false. 114978 Fail if the argument is not a Float. Essential. See Object documentation 114979 whatIsAPrimitive." 114980 114981 <primitive: 47> 114982 aNumber isNumber ifFalse: [^ false]. 114983 ^ aNumber adaptToFloat: self andCompare: #=! ! 114984 114985!Float methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:36'! 114986> aNumber 114987 "Primitive. Compare the receiver with the argument and return true 114988 if the receiver is greater than the argument. Otherwise return false. 114989 Fail if the argument is not a Float. Essential. See Object documentation 114990 whatIsAPrimitive." 114991 114992 <primitive: 44> 114993 ^ aNumber adaptToFloat: self andCompare: #>! ! 114994 114995!Float methodsFor: 'comparing' stamp: 'nice 7/10/2009 22:14'! 114996>= aNumber 114997 "Primitive. Compare the receiver with the argument and return true 114998 if the receiver is greater than or equal to the argument. Otherwise return 114999 false. Fail if the argument is not a Float. Optional. See Object documentation 115000 whatIsAPrimitive. " 115001 115002 <primitive: 46> 115003 ^ aNumber adaptToFloat: self andCompare: #>=! ! 115004 115005!Float methodsFor: 'comparing' stamp: 'nice 7/19/2009 19:27'! 115006closeTo: num 115007 "are these two numbers close?" 115008 num isNumber ifFalse: [^[self = num] ifError: [false]]. 115009 self = 0.0 ifTrue: [^num abs < 0.0001]. 115010 num = 0 ifTrue: [^self abs < 0.0001]. 115011 ^self = num asFloat 115012 or: [(self - num) abs / (self abs max: num abs) < 0.0001]! ! 115013 115014!Float methodsFor: 'comparing' stamp: 'nice 6/11/2009 01:03'! 115015hash 115016 "Hash is reimplemented because = is implemented. Both words of the float are used; 8 bits are removed from each end to clear most of the exponent regardless of the byte ordering. (The bitAnd:'s ensure that the intermediate results do not become a large integer.) Slower than the original version in the ratios 12:5 to 2:1 depending on values. (DNS, 11 May, 1997)" 115017 115018 (self isFinite and: [self fractionPart = 0.0]) ifTrue: [^self truncated hash]. 115019 ^ (((self basicAt: 1) bitAnd: 16r00FFFF00) + 115020 ((self basicAt: 2) bitAnd: 16r00FFFF00)) bitShift: -8 115021! ! 115022 115023!Float methodsFor: 'comparing'! 115024~= aNumber 115025 "Primitive. Compare the receiver with the argument and return true 115026 if the receiver is not equal to the argument. Otherwise return false. 115027 Fail if the argument is not a Float. Optional. See Object documentation 115028 whatIsAPrimitive." 115029 115030 <primitive: 48> 115031 ^super ~= aNumber! ! 115032 115033 115034!Float methodsFor: 'converting' stamp: 'mk 10/27/2003 18:16'! 115035adaptToComplex: rcvr andSend: selector 115036 "If I am involved in arithmetic with a Complex number, convert me to a Complex number." 115037 ^ rcvr perform: selector with: self asComplex! ! 115038 115039!Float methodsFor: 'converting' stamp: 'nice 1/4/2009 20:31'! 115040adaptToFraction: rcvr andCompare: selector 115041 "If I am involved in comparison with a Fraction, convert myself to a 115042 Fraction. This way, no bit is lost and comparison is exact." 115043 115044 self isFinite 115045 ifFalse: [ 115046 selector == #= ifTrue: [^false]. 115047 selector == #~= ifTrue: [^true]. 115048 self isNaN ifTrue: [^ false]. 115049 (selector = #< or: [selector = #'<=']) 115050 ifTrue: [^ self positive]. 115051 (selector = #> or: [selector = #'>=']) 115052 ifTrue: [^ self positive not]. 115053 ^self error: 'unknow comparison selector']. 115054 115055 "Try to avoid asTrueFraction because it can cost" 115056 selector == #= ifTrue: [ 115057 rcvr denominator isPowerOfTwo ifFalse: [^false]]. 115058 selector == #~= ifTrue: [ 115059 rcvr denominator isPowerOfTwo ifFalse: [^true]]. 115060 115061 ^ rcvr perform: selector with: self asTrueFraction! ! 115062 115063!Float methodsFor: 'converting' stamp: 'di 11/6/1998 13:38'! 115064adaptToFraction: rcvr andSend: selector 115065 "If I am involved in arithmetic with a Fraction, convert it to a Float." 115066 ^ rcvr asFloat perform: selector with: self! ! 115067 115068!Float methodsFor: 'converting' stamp: 'nice 1/4/2009 20:31'! 115069adaptToInteger: rcvr andCompare: selector 115070 "If I am involved in comparison with an Integer, convert myself to a 115071 Fraction. This way, no bit is lost and comparison is exact." 115072 115073 self isFinite 115074 ifFalse: [ 115075 selector == #= ifTrue: [^false]. 115076 selector == #~= ifTrue: [^true]. 115077 self isNaN ifTrue: [^ false]. 115078 (selector = #< or: [selector = #'<=']) 115079 ifTrue: [^ self positive]. 115080 (selector = #> or: [selector = #'>=']) 115081 ifTrue: [^ self positive not]. 115082 ^self error: 'unknow comparison selector']. 115083 115084 "Try to avoid asTrueFraction because it can cost" 115085 selector == #= ifTrue: [ 115086 self fractionPart = 0.0 ifFalse: [^false]]. 115087 selector == #~= ifTrue: [ 115088 self fractionPart = 0.0 ifFalse: [^true]]. 115089 115090 ^ rcvr perform: selector with: self asTrueFraction! ! 115091 115092!Float methodsFor: 'converting' stamp: 'di 11/6/1998 13:07'! 115093adaptToInteger: rcvr andSend: selector 115094 "If I am involved in arithmetic with an Integer, convert it to a Float." 115095 ^ rcvr asFloat perform: selector with: self! ! 115096 115097!Float methodsFor: 'converting' stamp: 'st 9/17/2004 17:17'! 115098asApproximateFraction 115099 "Answer a Fraction approximating the receiver. This conversion uses the 115100 continued fraction method to approximate a floating point number." 115101 115102 ^ self asApproximateFractionAtOrder: 0! ! 115103 115104!Float methodsFor: 'converting' stamp: 'st 9/17/2004 17:14'! 115105asApproximateFractionAtOrder: maxOrder 115106 "Answer a Fraction approximating the receiver. This conversion uses the 115107 continued fraction method to approximate a floating point number. If maxOrder 115108 is zero, use maximum order" 115109 115110 | num1 denom1 num2 denom2 int frac newD temp order | 115111 num1 := self asInteger. "The first of two alternating numerators" 115112 denom1 := 1. "The first of two alternating denominators" 115113 num2 := 1. "The second numerator" 115114 denom2 := 0. "The second denominator--will update" 115115 int := num1. "The integer part of self" 115116 frac := self fractionPart. "The fractional part of self" 115117 order := maxOrder = 0 ifTrue: [-1] ifFalse: [maxOrder]. 115118 [frac = 0 or: [order = 0] ] 115119 whileFalse: 115120 ["repeat while the fractional part is not zero and max order is not reached" 115121 order := order - 1. 115122 newD := 1.0 / frac. "Take reciprocal of the fractional part" 115123 int := newD asInteger. "get the integer part of this" 115124 frac := newD fractionPart. "and save the fractional part for next time" 115125 temp := num2. "Get old numerator and save it" 115126 num2 := num1. "Set second numerator to first" 115127 num1 := num1 * int + temp. "Update first numerator" 115128 temp := denom2. "Get old denominator and save it" 115129 denom2 := denom1. "Set second denominator to first" 115130 denom1 := int * denom1 + temp. "Update first denominator" 115131 10000000000.0 < denom1 115132 ifTrue: 115133 ["Is ratio past float precision? If so, pick which 115134 of the two ratios to use" 115135 num2 = 0.0 115136 ifTrue: ["Is second denominator 0?" 115137 ^ Fraction numerator: num1 denominator: denom1]. 115138 ^ Fraction numerator: num2 denominator: denom2]]. 115139 "If fractional part is zero, return the first ratio" 115140 denom1 = 1 115141 ifTrue: ["Am I really an Integer?" 115142 ^ num1 "Yes, return Integer result"] 115143 ifFalse: ["Otherwise return Fraction result" 115144 ^ Fraction numerator: num1 denominator: denom1]! ! 115145 115146!Float methodsFor: 'converting' stamp: 'mk 10/27/2003 17:46'! 115147asComplex 115148 "Answer a Complex number that represents value of the the receiver." 115149 115150 ^ Complex real: self imaginary: 0! ! 115151 115152!Float methodsFor: 'converting'! 115153asFloat 115154 "Answer the receiver itself." 115155 115156 ^self! ! 115157 115158!Float methodsFor: 'converting' stamp: 'sma 5/3/2000 21:46'! 115159asFraction 115160 ^ self asTrueFraction ! ! 115161 115162!Float methodsFor: 'converting' stamp: 'nice 5/30/2006 02:29'! 115163asIEEE32BitWord 115164 "Convert the receiver into a 32 bit Integer value representing the same number in IEEE 32 bit format. 115165 Used for conversion in FloatArrays only." 115166 115167 | word1 word2 sign mantissa exponent destWord truncatedBits mask roundToUpper | 115168 115169 "skip fast positive and nnegative zero" 115170 self = 0.0 ifTrue: [^self basicAt: 1]. 115171 115172 "retrieve 64 bits of IEEE 754 double" 115173 word1 := self basicAt: 1. 115174 word2 := self basicAt: 2. 115175 115176 "prepare sign exponent and mantissa of 32 bits float" 115177 sign := word1 bitAnd: 16r80000000. 115178 exponent := ((word1 bitShift: -20) bitAnd: 16r7FF) - 1023 + 127. 115179 mantissa := (word2 bitShift: -29) + ((word1 bitAnd: 16rFFFFF) bitShift: 3). 115180 truncatedBits := (word2 bitAnd: 16r1FFFFFFF). 115181 115182 "We must now honour default IEEE rounding mode (round to nearest even)" 115183 115184 "we are below gradual underflow, even if rounded to upper mantissa" 115185 exponent < -24 ifTrue: [^sign "this can be negative zero"]. 115186 115187 "BEWARE: rounding occurs on less than 23bits when gradual underflow" 115188 exponent <= 0 115189 ifTrue: 115190 [mask := 1 bitShift: exponent negated. 115191 mantissa := mantissa bitOr: 16r800000. 115192 roundToUpper := (mantissa bitAnd: mask) isZero not 115193 and: [truncatedBits isZero not 115194 or: [(mantissa bitAnd: mask - 1) isZero not 115195 or: [(mantissa bitAnd: mask*2) isZero not]]]. 115196 mantissa := mantissa bitShift: exponent - 1. 115197 "exponent := exponent + 1"] 115198 ifFalse: 115199 [roundToUpper := (truncatedBits bitAnd: 16r10000000) isZero not 115200 and: [(mantissa bitAnd: 16r1) isZero not 115201 or: [(truncatedBits bitAnd: 16r0FFFFFFF) isZero not]] 115202 ]. 115203 115204 "adjust mantissa and exponent due to IEEE rounding mode" 115205 roundToUpper 115206 ifTrue: 115207 [mantissa := mantissa + 1. 115208 mantissa > 16r7FFFFF 115209 ifTrue: 115210 [mantissa := 0. 115211 exponent := exponent+1]]. 115212 115213 exponent > 254 ifTrue: ["Overflow" 115214 exponent := 255. 115215 self isNaN 115216 ifTrue: [mantissa isZero 115217 ifTrue: ["BEWARE: do not convert a NaN to infinity due to truncatedBits" 115218 mantissa := 1]] 115219 ifFalse: [mantissa := 0]]. 115220 115221 "Encode the word" 115222 destWord := (sign bitOr: ((exponent max: 0) bitShift: 23)) bitOr: mantissa. 115223 ^ destWord! ! 115224 115225!Float methodsFor: 'converting' stamp: 'nice 3/29/2006 01:01'! 115226asTrueFraction 115227 " Answer a fraction that EXACTLY represents self, 115228 a double precision IEEE floating point number. 115229 Floats are stored in the same form on all platforms. 115230 (Does handle gradual underflow but not NANs.) 115231 By David N. Smith with significant performance 115232 improvements by Luciano Esteban Notarfrancesco. 115233 (Version of 11April97)" 115234 | signexp positive expPart exp fraction fractionPart signedFraction result zeroBitsCount | 115235 self isInfinite ifTrue: [self error: 'Cannot represent infinity as a fraction']. 115236 self isNaN ifTrue: [self error: 'Cannot represent Not-a-Number as a fraction']. 115237 115238 115239 " Extract the sign and the biased exponent " 115240 signexp := (self basicAt: 1) bitShift: -20. 115241 positive := (signexp bitAnd: 16r800) = 0. 115242 expPart := signexp bitAnd: 16r7FF. 115243 115244 " Extract fractional part; answer 0 if this is a true 0.0 value " 115245 fractionPart := (((self basicAt: 1) bitAnd: 16rFFFFF) bitShift: 32)+ (self basicAt: 2). 115246 ( expPart=0 and: [ fractionPart=0 ] ) ifTrue: [ ^ 0 ]. 115247 115248 " Replace omitted leading 1 in fraction unless gradual underflow" 115249 fraction := expPart = 0 115250 ifTrue: [fractionPart bitShift: 1] 115251 ifFalse: [fractionPart bitOr: 16r0010000000000000]. 115252 signedFraction := positive ifTrue: [fraction] ifFalse: [fraction negated]. 115253 115254 "Unbias exponent: 16r3FF is bias; 52 is fraction width" 115255 exp := 16r3FF + 52 - expPart. 115256 115257 " Form the result. When exp>52, the exponent is adjusted by 115258 the number of trailing zero bits in the fraction to minimize 115259 the (huge) time otherwise spent in #gcd:. " 115260 exp negative 115261 ifTrue: [ 115262 result := signedFraction bitShift: exp negated ] 115263 ifFalse: [ 115264 zeroBitsCount := fraction lowBit - 1. 115265 exp := exp - zeroBitsCount. 115266 exp <= 0 115267 ifTrue: [ 115268 zeroBitsCount := zeroBitsCount + exp. 115269 "exp := 0." " Not needed; exp not 115270refernced again " 115271 result := signedFraction bitShift: 115272zeroBitsCount negated ] 115273 ifFalse: [ 115274 result := Fraction 115275 numerator: (signedFraction 115276bitShift: zeroBitsCount negated) 115277 denominator: (1 bitShift: 115278exp) ] ]. 115279 115280 "Low cost validation omitted after extensive testing" 115281 "(result asFloat = self) ifFalse: [self error: 'asTrueFraction validation failed']." 115282 ^ result ! ! 115283 115284!Float methodsFor: 'converting'! 115285degreesToRadians 115286 "Answer the receiver in radians. Assumes the receiver is in degrees." 115287 115288 ^self * RadiansPerDegree! ! 115289 115290!Float methodsFor: 'converting'! 115291radiansToDegrees 115292 "Answer the receiver in degrees. Assumes the receiver is in radians." 115293 115294 ^self / RadiansPerDegree! ! 115295 115296 115297!Float methodsFor: 'copying'! 115298deepCopy 115299 115300 ^self copy! ! 115301 115302!Float methodsFor: 'copying'! 115303shallowCopy 115304 115305 ^self + 0.0! ! 115306 115307!Float methodsFor: 'copying' stamp: 'tk 8/19/1998 16:08'! 115308veryDeepCopyWith: deepCopier 115309 "Return self. Do not record me." 115310 115311 ^ self clone! ! 115312 115313 115314!Float methodsFor: 'mathematical functions'! 115315arcCos 115316 "Answer the angle in radians." 115317 115318 ^ Halfpi - self arcSin! ! 115319 115320!Float methodsFor: 'mathematical functions' stamp: 'jsp 2/25/1999 11:15'! 115321arcSin 115322 "Answer the angle in radians." 115323 115324 ((self < -1.0) or: [self > 1.0]) ifTrue: [self error: 'Value out of range']. 115325 ((self = -1.0) or: [self = 1.0]) 115326 ifTrue: [^ Halfpi * self] 115327 ifFalse: [^ (self / (1.0 - (self * self)) sqrt) arcTan]! ! 115328 115329!Float methodsFor: 'mathematical functions'! 115330arcTan 115331 "Answer the angle in radians. 115332 Optional. See Object documentation whatIsAPrimitive." 115333 115334 | theta eps step sinTheta cosTheta | 115335 <primitive: 57> 115336 115337 "Newton-Raphson" 115338 self < 0.0 ifTrue: [ ^ 0.0 - (0.0 - self) arcTan ]. 115339 115340 "first guess" 115341 theta := (self * Halfpi) / (self + 1.0). 115342 115343 "iterate" 115344 eps := Halfpi * Epsilon. 115345 step := theta. 115346 [(step * step) > eps] whileTrue: [ 115347 sinTheta := theta sin. 115348 cosTheta := theta cos. 115349 step := (sinTheta * cosTheta) - (self * cosTheta * cosTheta). 115350 theta := theta - step]. 115351 ^ theta! ! 115352 115353!Float methodsFor: 'mathematical functions' stamp: 'HilaireFernandes 1/16/2006 21:47'! 115354arcTan: denominator 115355 "Answer the angle in radians. 115356 Optional. See Object documentation whatIsAPrimitive." 115357 115358 | result | 115359 115360 (self = 0.0) ifTrue: [ (denominator > 0.0) ifTrue: [ result := 0 ] 115361 ifFalse: [ result := Pi ] 115362 ] 115363 ifFalse: [(denominator = 0.0) 115364 ifTrue: [ (self > 0.0) ifTrue: [ result := Halfpi ] 115365 ifFalse: [ result := Halfpi negated ] 115366 ] 115367 ifFalse: [ (denominator > 0) ifTrue: [ result := (self / denominator) arcTan ] 115368 ifFalse: [ (self > 0) ifTrue: [result := ((self / denominator) arcTan) + Pi ] 115369 ifFalse: [result := ((self / denominator) arcTan) - Pi] 115370 ] 115371 ]. 115372 ]. 115373 115374 ^ result.! ! 115375 115376!Float methodsFor: 'mathematical functions'! 115377cos 115378 "Answer the cosine of the receiver taken as an angle in radians." 115379 115380 ^ (self + Halfpi) sin! ! 115381 115382!Float methodsFor: 'mathematical functions'! 115383degreeCos 115384 "Answer the cosine of the receiver taken as an angle in degrees." 115385 115386 ^ self degreesToRadians cos! ! 115387 115388!Float methodsFor: 'mathematical functions'! 115389degreeSin 115390 "Answer the sine of the receiver taken as an angle in degrees." 115391 115392 ^ self degreesToRadians sin! ! 115393 115394!Float methodsFor: 'mathematical functions'! 115395exp 115396 "Answer E raised to the receiver power. 115397 Optional. See Object documentation whatIsAPrimitive." 115398 115399 | base fract correction delta div | 115400 <primitive: 59> 115401 115402 "Taylor series" 115403 "check the special cases" 115404 self < 0.0 ifTrue: [^ (self negated exp) reciprocal]. 115405 self = 0.0 ifTrue: [^ 1]. 115406 self abs > MaxValLn ifTrue: [self error: 'exp overflow']. 115407 115408 "get first approximation by raising e to integer power" 115409 base := E raisedToInteger: (self truncated). 115410 115411 "now compute the correction with a short Taylor series" 115412 "fract will be 0..1, so correction will be 1..E" 115413 "in the worst case, convergance time is logarithmic with 1/Epsilon" 115414 fract := self fractionPart. 115415 fract = 0.0 ifTrue: [ ^ base ]. "no correction required" 115416 115417 correction := 1.0 + fract. 115418 delta := fract * fract / 2.0. 115419 div := 2.0. 115420 [delta > Epsilon] whileTrue: [ 115421 correction := correction + delta. 115422 div := div + 1.0. 115423 delta := delta * fract / div]. 115424 correction := correction + delta. 115425 ^ base * correction! ! 115426 115427!Float methodsFor: 'mathematical functions' stamp: 'jm 3/27/98 06:28'! 115428floorLog: radix 115429 "Answer the floor of the log base radix of the receiver." 115430 115431 ^ (self log: radix) floor 115432! ! 115433 115434!Float methodsFor: 'mathematical functions'! 115435ln 115436 "Answer the natural logarithm of the receiver. 115437 Optional. See Object documentation whatIsAPrimitive." 115438 115439 | expt n mant x div pow delta sum eps | 115440 <primitive: 58> 115441 115442 "Taylor series" 115443 self <= 0.0 ifTrue: [self error: 'ln is only defined for x > 0.0']. 115444 115445 "get a rough estimate from binary exponent" 115446 expt := self exponent. 115447 n := Ln2 * expt. 115448 mant := self timesTwoPower: 0 - expt. 115449 115450 "compute fine correction from mantinssa in Taylor series" 115451 "mant is in the range [0..2]" 115452 "we unroll the loop to avoid use of abs" 115453 x := mant - 1.0. 115454 div := 1.0. 115455 pow := delta := sum := x. 115456 x := x negated. "x <= 0" 115457 eps := Epsilon * (n abs + 1.0). 115458 [delta > eps] whileTrue: [ 115459 "pass one: delta is positive" 115460 div := div + 1.0. 115461 pow := pow * x. 115462 delta := pow / div. 115463 sum := sum + delta. 115464 "pass two: delta is negative" 115465 div := div + 1.0. 115466 pow := pow * x. 115467 delta := pow / div. 115468 sum := sum + delta]. 115469 115470 ^ n + sum 115471 115472 "2.718284 ln 1.0"! ! 115473 115474!Float methodsFor: 'mathematical functions'! 115475log 115476 "Answer the base 10 logarithm of the receiver." 115477 115478 ^ self ln / Ln10! ! 115479 115480!Float methodsFor: 'mathematical functions' stamp: 'tao 4/19/98 23:22'! 115481reciprocalFloorLog: radix 115482 "Quick computation of (self log: radix) floor, when self < 1.0. 115483 Avoids infinite recursion problems with denormalized numbers" 115484 115485 | adjust scale n | 115486 adjust := 0. 115487 scale := 1.0. 115488 [(n := radix / (self * scale)) isInfinite] 115489 whileTrue: 115490 [scale := scale * radix. 115491 adjust := adjust + 1]. 115492 ^ ((n floorLog: radix) + adjust) negated! ! 115493 115494!Float methodsFor: 'mathematical functions' stamp: 'tao 10/15/97 14:23'! 115495reciprocalLogBase2 115496 "optimized for self = 10, for use in conversion for printing" 115497 115498 ^ self = 10.0 115499 ifTrue: [Ln2 / Ln10] 115500 ifFalse: [Ln2 / self ln]! ! 115501 115502!Float methodsFor: 'mathematical functions' stamp: 'laza 12/21/1999 12:15'! 115503safeArcCos 115504 "Answer the angle in radians." 115505 (self between: -1.0 and: 1.0) 115506 ifTrue: [^ self arcCos] 115507 ifFalse: [^ self sign arcCos]! ! 115508 115509!Float methodsFor: 'mathematical functions'! 115510sin 115511 "Answer the sine of the receiver taken as an angle in radians. 115512 Optional. See Object documentation whatIsAPrimitive." 115513 115514 | sum delta self2 i | 115515 <primitive: 56> 115516 115517 "Taylor series" 115518 "normalize to the range [0..Pi/2]" 115519 self < 0.0 ifTrue: [^ (0.0 - ((0.0 - self) sin))]. 115520 self > Twopi ifTrue: [^ (self \\ Twopi) sin]. 115521 self > Pi ifTrue: [^ (0.0 - (self - Pi) sin)]. 115522 self > Halfpi ifTrue: [^ (Pi - self) sin]. 115523 115524 "unroll loop to avoid use of abs" 115525 sum := delta := self. 115526 self2 := 0.0 - (self * self). 115527 i := 2.0. 115528 [delta > Epsilon] whileTrue: [ 115529 "once" 115530 delta := (delta * self2) / (i * (i + 1.0)). 115531 i := i + 2.0. 115532 sum := sum + delta. 115533 "twice" 115534 delta := (delta * self2) / (i * (i + 1.0)). 115535 i := i + 2.0. 115536 sum := sum + delta]. 115537 ^ sum! ! 115538 115539!Float methodsFor: 'mathematical functions' stamp: 'RAH 4/25/2000 19:49'! 115540sqrt 115541 "Answer the square root of the receiver. 115542 Optional. See Object documentation whatIsAPrimitive." 115543 | exp guess eps delta | 115544 <primitive: 55> 115545 #Numeric. 115546 "Changed 200/01/19 For ANSI <number> support." 115547 "Newton-Raphson" 115548 self <= 0.0 115549 ifTrue: [self = 0.0 115550 ifTrue: [^ 0.0] 115551 ifFalse: ["v Chg" 115552 ^ FloatingPointException signal: 'undefined if less than zero.']]. 115553 "first guess is half the exponent" 115554 exp := self exponent // 2. 115555 guess := self timesTwoPower: 0 - exp. 115556 "get eps value" 115557 eps := guess * Epsilon. 115558 eps := eps * eps. 115559 delta := self - (guess * guess) / (guess * 2.0). 115560 [delta * delta > eps] 115561 whileTrue: 115562 [guess := guess + delta. 115563 delta := self - (guess * guess) / (guess * 2.0)]. 115564 ^ guess! ! 115565 115566!Float methodsFor: 'mathematical functions'! 115567tan 115568 "Answer the tangent of the receiver taken as an angle in radians." 115569 115570 ^ self sin / self cos! ! 115571 115572!Float methodsFor: 'mathematical functions'! 115573timesTwoPower: anInteger 115574 "Primitive. Answer with the receiver multiplied by 2.0 raised 115575 to the power of the argument. 115576 Optional. See Object documentation whatIsAPrimitive." 115577 115578 <primitive: 54> 115579 115580 anInteger < -29 ifTrue: [^ self * (2.0 raisedToInteger: anInteger)]. 115581 anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat]. 115582 anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat]. 115583 ^ self * (2.0 raisedToInteger: anInteger)! ! 115584 115585 115586!Float methodsFor: 'printing' stamp: 'MPW 1/1/1901 01:59'! 115587absByteEncode: aStream base: base 115588 "Print my value on a stream in the given base. Assumes that my value is strictly 115589 positive; negative numbers, zero, and NaNs have already been handled elsewhere. 115590 Based upon the algorithm outlined in: 115591 Robert G. Burger and R. Kent Dybvig 115592 Printing Floating Point Numbers Quickly and Accurately 115593 ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation 115594 June 1996. 115595 This version performs all calculations with Floats instead of LargeIntegers, and loses 115596 about 3 lsbs of accuracy compared to an exact conversion." 115597 115598 | significantBits fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount | 115599 self isInfinite ifTrue: [aStream print: 'Infinity'. ^ self]. 115600 significantBits := 50. "approximately 3 lsb's of accuracy loss during conversion" 115601 fBase := base asFloat. 115602 exp := self exponent. 115603 baseExpEstimate := (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling. 115604 exp >= 0 115605 ifTrue: 115606 [r := self. 115607 s := 1.0. 115608 mPlus := 1.0 timesTwoPower: exp - significantBits. 115609 mMinus := self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]] 115610 ifFalse: 115611 [r := self timesTwoPower: significantBits. 115612 s := 1.0 timesTwoPower: significantBits. 115613 mMinus := 1.0 timesTwoPower: (exp max: -1024). 115614 mPlus := 115615 (exp = MinValLogBase2) | (self significand ~= 1.0) 115616 ifTrue: [mMinus] 115617 ifFalse: [mMinus * 2.0]]. 115618 baseExpEstimate >= 0 115619 ifTrue: 115620 [s := s * (fBase raisedToInteger: baseExpEstimate). 115621 exp = 1023 115622 ifTrue: "scale down to prevent overflow to Infinity during conversion" 115623 [r := r / fBase. 115624 s := s / fBase. 115625 mPlus := mPlus / fBase. 115626 mMinus := mMinus / fBase]] 115627 ifFalse: 115628 [exp < -1023 115629 ifTrue: "scale up to prevent denorm reciprocals overflowing to Infinity" 115630 [d := (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling. 115631 scale := fBase raisedToInteger: d. 115632 r := r * scale. 115633 mPlus := mPlus * scale. 115634 mMinus := mMinus * scale. 115635 scale := fBase raisedToInteger: (baseExpEstimate + d) negated] 115636 ifFalse: 115637 [scale := fBase raisedToInteger: baseExpEstimate negated]. 115638 s := s / scale]. 115639 (r + mPlus >= s) 115640 ifTrue: [baseExpEstimate := baseExpEstimate + 1] 115641 ifFalse: 115642 [s := s / fBase]. 115643 (fixedFormat := baseExpEstimate between: -3 and: 6) 115644 ifTrue: 115645 [decPointCount := baseExpEstimate. 115646 baseExpEstimate <= 0 115647 ifTrue: [aStream print: ('0.000000' truncateTo: 2 - baseExpEstimate)]] 115648 ifFalse: 115649 [decPointCount := 1]. 115650 [d := (r / s) truncated. 115651 r := r - (d * s). 115652 (tc1 := r <= mMinus) | (tc2 := r + mPlus >= s)] whileFalse: 115653 [aStream print: (Character digitValue: d). 115654 r := r * fBase. 115655 mPlus := mPlus * fBase. 115656 mMinus := mMinus * fBase. 115657 decPointCount := decPointCount - 1. 115658 decPointCount = 0 ifTrue: [aStream print: $.]]. 115659 tc2 ifTrue: 115660 [tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d := d + 1]]. 115661 aStream print: (Character digitValue: d). 115662 decPointCount > 0 115663 ifTrue: 115664 [decPointCount - 1 to: 1 by: -1 do: [:i | aStream print: $0]. 115665 aStream print: '.0']. 115666 fixedFormat ifFalse: 115667 [aStream print: $e. 115668 aStream print: (baseExpEstimate - 1) printString]! ! 115669 115670!Float methodsFor: 'printing' stamp: 'tao 4/19/98 23:21'! 115671absPrintExactlyOn: aStream base: base 115672 "Print my value on a stream in the given base. Assumes that my value is strictly 115673 positive; negative numbers, zero, and NaNs have already been handled elsewhere. 115674 Based upon the algorithm outlined in: 115675 Robert G. Burger and R. Kent Dybvig 115676 Printing Floating Point Numbers Quickly and Accurately 115677 ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation 115678 June 1996. 115679 This version guarantees that the printed representation exactly represents my value 115680 by using exact integer arithmetic." 115681 115682 | fBase significand exp baseExpEstimate be be1 r s mPlus mMinus scale roundingIncludesLimits d tc1 tc2 fixedFormat decPointCount | 115683 self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. 115684 fBase := base asFloat. 115685 significand := self significandAsInteger. 115686 roundingIncludesLimits := significand even. 115687 exp := (self exponent - 52) max: MinValLogBase2. 115688 baseExpEstimate := (self exponent * fBase reciprocalLogBase2 - 1.0e-10) ceiling. 115689 exp >= 0 115690 ifTrue: 115691 [be := 1 << exp. 115692 significand ~= 16r10000000000000 115693 ifTrue: 115694 [r := significand * be * 2. 115695 s := 2. 115696 mPlus := be. 115697 mMinus := be] 115698 ifFalse: 115699 [be1 := be * 2. 115700 r := significand * be1 * 2. 115701 s := 4. 115702 mPlus := be1. 115703 mMinus := be]] 115704 ifFalse: 115705 [(exp = MinValLogBase2) | (significand ~= 16r10000000000000) 115706 ifTrue: 115707 [r := significand * 2. 115708 s := (1 << (exp negated)) * 2. 115709 mPlus := 1. 115710 mMinus := 1] 115711 ifFalse: 115712 [r := significand * 4. 115713 s := (1 << (exp negated + 1)) * 2. 115714 mPlus := 2. 115715 mMinus := 1]]. 115716 baseExpEstimate >= 0 115717 ifTrue: [s := s * (base raisedToInteger: baseExpEstimate)] 115718 ifFalse: 115719 [scale := base raisedToInteger: baseExpEstimate negated. 115720 r := r * scale. 115721 mPlus := mPlus * scale. 115722 mMinus := mMinus * scale]. 115723 (r + mPlus > s) | (roundingIncludesLimits & (r + mPlus = s)) 115724 ifTrue: [baseExpEstimate := baseExpEstimate + 1] 115725 ifFalse: 115726 [r := r * base. 115727 mPlus := mPlus * base. 115728 mMinus := mMinus * base]. 115729 (fixedFormat := baseExpEstimate between: -3 and: 6) 115730 ifTrue: 115731 [decPointCount := baseExpEstimate. 115732 baseExpEstimate <= 0 115733 ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] 115734 ifFalse: 115735 [decPointCount := 1]. 115736 [d := r // s. 115737 r := r \\ s. 115738 (tc1 := (r < mMinus) | (roundingIncludesLimits & (r = mMinus))) | 115739 (tc2 := (r + mPlus > s) | (roundingIncludesLimits & (r + mPlus = s)))] whileFalse: 115740 [aStream nextPut: (Character digitValue: d). 115741 r := r * base. 115742 mPlus := mPlus * base. 115743 mMinus := mMinus * base. 115744 decPointCount := decPointCount - 1. 115745 decPointCount = 0 ifTrue: [aStream nextPut: $.]]. 115746 tc2 ifTrue: 115747 [tc1 not | (tc1 & (r*2 >= s)) ifTrue: [d := d + 1]]. 115748 aStream nextPut: (Character digitValue: d). 115749 decPointCount > 0 115750 ifTrue: 115751 [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. 115752 aStream nextPutAll: '.0']. 115753 fixedFormat ifFalse: 115754 [aStream nextPut: $e. 115755 aStream nextPutAll: (baseExpEstimate - 1) printString]! ! 115756 115757!Float methodsFor: 'printing' stamp: 'tao 4/22/98 11:58'! 115758absPrintOn: aStream base: base 115759 "Print my value on a stream in the given base. Assumes that my value is strictly 115760 positive; negative numbers, zero, and NaNs have already been handled elsewhere. 115761 Based upon the algorithm outlined in: 115762 Robert G. Burger and R. Kent Dybvig 115763 Printing Floating Point Numbers Quickly and Accurately 115764 ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation 115765 June 1996. 115766 This version performs all calculations with Floats instead of LargeIntegers, and loses 115767 about 3 lsbs of accuracy compared to an exact conversion." 115768 115769 | significantBits fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount | 115770 self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. 115771 significantBits := 50. "approximately 3 lsb's of accuracy loss during conversion" 115772 fBase := base asFloat. 115773 exp := self exponent. 115774 baseExpEstimate := (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling. 115775 exp >= 0 115776 ifTrue: 115777 [r := self. 115778 s := 1.0. 115779 mPlus := 1.0 timesTwoPower: exp - significantBits. 115780 mMinus := self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]] 115781 ifFalse: 115782 [r := self timesTwoPower: significantBits. 115783 s := 1.0 timesTwoPower: significantBits. 115784 mMinus := 1.0 timesTwoPower: (exp max: -1024). 115785 mPlus := 115786 (exp = MinValLogBase2) | (self significand ~= 1.0) 115787 ifTrue: [mMinus] 115788 ifFalse: [mMinus * 2.0]]. 115789 baseExpEstimate >= 0 115790 ifTrue: 115791 [s := s * (fBase raisedToInteger: baseExpEstimate). 115792 exp = 1023 115793 ifTrue: "scale down to prevent overflow to Infinity during conversion" 115794 [r := r / fBase. 115795 s := s / fBase. 115796 mPlus := mPlus / fBase. 115797 mMinus := mMinus / fBase]] 115798 ifFalse: 115799 [exp < -1023 115800 ifTrue: "scale up to prevent denorm reciprocals overflowing to Infinity" 115801 [d := (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling. 115802 scale := fBase raisedToInteger: d. 115803 r := r * scale. 115804 mPlus := mPlus * scale. 115805 mMinus := mMinus * scale. 115806 scale := fBase raisedToInteger: (baseExpEstimate + d) negated] 115807 ifFalse: 115808 [scale := fBase raisedToInteger: baseExpEstimate negated]. 115809 s := s / scale]. 115810 (r + mPlus >= s) 115811 ifTrue: [baseExpEstimate := baseExpEstimate + 1] 115812 ifFalse: 115813 [s := s / fBase]. 115814 (fixedFormat := baseExpEstimate between: -3 and: 6) 115815 ifTrue: 115816 [decPointCount := baseExpEstimate. 115817 baseExpEstimate <= 0 115818 ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] 115819 ifFalse: 115820 [decPointCount := 1]. 115821 [d := (r / s) truncated. 115822 r := r - (d * s). 115823 (tc1 := r <= mMinus) | (tc2 := r + mPlus >= s)] whileFalse: 115824 [aStream nextPut: (Character digitValue: d). 115825 r := r * fBase. 115826 mPlus := mPlus * fBase. 115827 mMinus := mMinus * fBase. 115828 decPointCount := decPointCount - 1. 115829 decPointCount = 0 ifTrue: [aStream nextPut: $.]]. 115830 tc2 ifTrue: 115831 [tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d := d + 1]]. 115832 aStream nextPut: (Character digitValue: d). 115833 decPointCount > 0 115834 ifTrue: 115835 [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. 115836 aStream nextPutAll: '.0']. 115837 fixedFormat ifFalse: 115838 [aStream nextPut: $e. 115839 aStream nextPutAll: (baseExpEstimate - 1) printString]! ! 115840 115841!Float methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:02'! 115842byteEncode: aStream base: base 115843 "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" 115844 115845 self isNaN ifTrue: [aStream print: 'NaN'. ^ self]. "check for NaN before sign" 115846 self > 0.0 115847 ifTrue: [self absByteEncode: aStream base: base] 115848 ifFalse: 115849 [self sign = -1 115850 ifTrue: [aStream print: '-']. 115851 self = 0.0 115852 ifTrue: [aStream print: '0.0'. ^ self] 115853 ifFalse: [aStream writeNumber:self negated base: base]]! ! 115854 115855!Float methodsFor: 'printing' stamp: 'eem 6/11/2008 17:38'! 115856hex "If ya really want to know..." 115857 115858 ^ String streamContents: 115859 [:strm | | word nibble | 115860 1 to: 2 do: 115861 [:i | word := self at: i. 115862 1 to: 8 do: 115863 [:s | nibble := (word bitShift: -8+s*4) bitAnd: 16rF. 115864 strm nextPut: ('0123456789ABCDEF' at: nibble+1)]]] 115865" 115866(-2.0 to: 2.0) collect: [:f | f hex] 115867"! ! 115868 115869!Float methodsFor: 'printing' stamp: 'tao 4/19/98 23:31'! 115870printOn: aStream base: base 115871 "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" 115872 115873 self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" 115874 self > 0.0 115875 ifTrue: [self absPrintOn: aStream base: base] 115876 ifFalse: 115877 [self sign = -1 115878 ifTrue: [aStream nextPutAll: '-']. 115879 self = 0.0 115880 ifTrue: [aStream nextPutAll: '0.0'. ^ self] 115881 ifFalse: [self negated absPrintOn: aStream base: base]]! ! 115882 115883!Float methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 01:33'! 115884printPaddedWith: aCharacter to: aNumber 115885 "Answer the string containing the ASCII representation of the receiver 115886 padded on the left with aCharacter to be at least on aNumber 115887 integerPart characters and padded the right with aCharacter to be at 115888 least anInteger fractionPart characters." 115889 | aStream digits fPadding fLen iPadding iLen curLen periodIndex | 115890 #Numeric. 115891 "2000/03/04 Harmon R. Added Date and Time support" 115892 aStream := (String new: 10) writeStream. 115893 self printOn: aStream. 115894 digits := aStream contents. 115895 periodIndex := digits indexOf: $.. 115896 curLen := periodIndex - 1. 115897 iLen := aNumber integerPart. 115898 curLen < iLen 115899 ifTrue: [iPadding := (String new: (iLen - curLen) asInteger) atAllPut: aCharacter; 115900 yourself] 115901 ifFalse: [iPadding := '']. 115902 curLen := digits size - periodIndex. 115903 fLen := (aNumber fractionPart * (aNumber asFloat exponent * 10)) asInteger. 115904 curLen < fLen 115905 ifTrue: [fPadding := (String new: fLen - curLen) atAllPut: aCharacter; 115906 yourself] 115907 ifFalse: [fPadding := '']. 115908 ^ iPadding , digits , fPadding! ! 115909 115910!Float methodsFor: 'printing' stamp: 'nice 3/24/2008 16:56'! 115911printShowingDecimalPlaces: placesDesired 115912 "This implementation avoids any rounding error caused by rounded or roundTo:" 115913 115914 ^self asTrueFraction printShowingDecimalPlaces: placesDesired! ! 115915 115916!Float methodsFor: 'printing' stamp: 'nice 10/11/2008 21:42'! 115917storeOn: aStream base: base 115918 "Defined here to handle special cases of NaN Infinity and negative zero" 115919 115920 | abs | 115921 self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" 115922 abs := self sign = -1 "Test sign rather than > 0 for special case of negative zero" 115923 ifTrue: 115924 [aStream nextPutAll: '-'. 115925 self negated] 115926 ifFalse: [self]. 115927 abs isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. 115928 base = 10 ifFalse: [aStream print: base; nextPut: $r]. 115929 self = 0.0 115930 ifTrue: [aStream nextPutAll: '0.0'. ^ self] 115931 ifFalse: [abs absPrintOn: aStream base: base]! ! 115932 115933 115934!Float methodsFor: 'testing' stamp: 'bf 8/20/1999 12:56'! 115935hasContentsInExplorer 115936 115937 ^false! ! 115938 115939!Float methodsFor: 'testing' stamp: 'nice 3/14/2008 23:45'! 115940isFinite 115941 "simple, byte-order independent test for rejecting Not-a-Number and (Negative)Infinity" 115942 115943 ^(self - self) = 0.0! ! 115944 115945!Float methodsFor: 'testing'! 115946isFloat 115947 ^ true! ! 115948 115949!Float methodsFor: 'testing' stamp: 'jm 4/30/1998 13:50'! 115950isInfinite 115951 "Return true if the receiver is positive or negative infinity." 115952 115953 ^ self = Infinity or: [self = NegativeInfinity] 115954! ! 115955 115956!Float methodsFor: 'testing' stamp: 'nice 3/14/2008 23:49'! 115957isLiteral 115958 "There is no literal representation of NaN. 115959 However, there are literal representations of Infinity, like 1.0e1000. 115960 But since they are not able to print properly, only case of finite Float is considered." 115961 115962 ^self isFinite! ! 115963 115964!Float methodsFor: 'testing' stamp: 'tao 10/10/97 16:39'! 115965isNaN 115966 "simple, byte-order independent test for Not-a-Number" 115967 115968 ^ self ~= self! ! 115969 115970!Float methodsFor: 'testing' stamp: 'ar 6/9/2000 18:56'! 115971isPowerOfTwo 115972 "Return true if the receiver is an integral power of two. 115973 Floats never return true here." 115974 ^false! ! 115975 115976!Float methodsFor: 'testing'! 115977isZero 115978 ^self = 0.0! ! 115979 115980!Float methodsFor: 'testing' stamp: 'jm 4/28/1998 01:10'! 115981sign 115982 "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0. 115983 Handle IEEE-754 negative-zero by reporting a sign of -1" 115984 115985 self > 0 ifTrue: [^ 1]. 115986 (self < 0 or: [((self at: 1) bitShift: -31) = 1]) ifTrue: [^ -1]. 115987 ^ 0! ! 115988 115989 115990!Float methodsFor: 'truncation and round off'! 115991exponent 115992 "Primitive. Consider the receiver to be represented as a power of two 115993 multiplied by a mantissa (between one and two). Answer with the 115994 SmallInteger to whose power two is raised. Optional. See Object 115995 documentation whatIsAPrimitive." 115996 115997 | positive | 115998 <primitive: 53> 115999 self >= 1.0 ifTrue: [^self floorLog: 2]. 116000 self > 0.0 116001 ifTrue: 116002 [positive := (1.0 / self) exponent. 116003 self = (1.0 / (1.0 timesTwoPower: positive)) 116004 ifTrue: [^positive negated] 116005 ifFalse: [^positive negated - 1]]. 116006 self = 0.0 ifTrue: [^-1]. 116007 ^self negated exponent! ! 116008 116009!Float methodsFor: 'truncation and round off'! 116010fractionPart 116011 "Primitive. Answer a Float whose value is the difference between the 116012 receiver and the receiver's asInteger value. Optional. See Object 116013 documentation whatIsAPrimitive." 116014 116015 <primitive: 52> 116016 ^self - self truncated asFloat! ! 116017 116018!Float methodsFor: 'truncation and round off'! 116019integerPart 116020 "Answer a Float whose value is the receiver's truncated value." 116021 116022 ^self - self fractionPart! ! 116023 116024!Float methodsFor: 'truncation and round off' stamp: 'nice 6/11/2009 20:37'! 116025predecessor 116026 | mantissa biasedExponent | 116027 self isFinite ifFalse: [ 116028 (self isNaN or: [self negative]) ifTrue: [^self]. 116029 ^Float fmax]. 116030 self = 0.0 ifTrue: [^Float fmin negated]. 116031 mantissa := self significandAsInteger. 116032 (mantissa isPowerOfTwo and: [self positive]) ifTrue: [mantissa := mantissa bitShift: 1]. 116033 biasedExponent := self exponent - mantissa highBit + 1. 116034 ^self sign * (mantissa - self sign) asFloat timesTwoPower: biasedExponent! ! 116035 116036!Float methodsFor: 'truncation and round off' stamp: 'tk 12/30/2000 20:04'! 116037reduce 116038 "If self is close to an integer, return that integer" 116039 116040 (self closeTo: self rounded) ifTrue: [^ self rounded]! ! 116041 116042!Float methodsFor: 'truncation and round off' stamp: 'nice 7/24/2008 01:32'! 116043rounded 116044 "Answer the integer nearest the receiver. 116045 Implementation note: super would not handle tricky inexact arithmetic" 116046 116047 "self assert: 5000000000000001.0 rounded = 5000000000000001" 116048 116049 self fractionPart abs < 0.5 116050 ifTrue: [^self truncated] 116051 ifFalse: [^self truncated + self sign rounded]! ! 116052 116053!Float methodsFor: 'truncation and round off' stamp: 'tao 4/19/98 13:14'! 116054significand 116055 116056 ^ self timesTwoPower: (self exponent negated)! ! 116057 116058!Float methodsFor: 'truncation and round off' stamp: 'nice 3/23/2008 16:03'! 116059significandAsInteger 116060 116061 | exp sig | 116062 exp := self exponent. 116063 sig := (((self at: 1) bitAnd: 16r000FFFFF) bitShift: 32) bitOr: (self at: 2). 116064 (exp > -1023 and: [self ~= 0.0]) 116065 ifTrue: [sig := sig bitOr: (1 bitShift: 52)]. 116066 ^ sig.! ! 116067 116068!Float methodsFor: 'truncation and round off' stamp: 'nice 6/11/2009 20:37'! 116069successor 116070 | mantissa biasedExponent | 116071 self isFinite ifFalse: [ 116072 (self isNaN or: [self positive]) ifTrue: [^self]. 116073 ^Float fmax negated]. 116074 self = 0.0 ifTrue: [^Float fmin]. 116075 mantissa := self significandAsInteger. 116076 (mantissa isPowerOfTwo and: [self negative]) ifTrue: [mantissa := mantissa bitShift: 1]. 116077 biasedExponent := self exponent - mantissa highBit + 1. 116078 ^self sign * (mantissa + self sign) asFloat timesTwoPower: biasedExponent! ! 116079 116080!Float methodsFor: 'truncation and round off' stamp: 'nice 4/26/2006 05:09'! 116081truncated 116082 "Answer with a SmallInteger equal to the value of the receiver without 116083 its fractional part. The primitive fails if the truncated value cannot be 116084 represented as a SmallInteger. In that case, the code below will compute 116085 a LargeInteger truncated value. 116086 Essential. See Object documentation whatIsAPrimitive. " 116087 116088 <primitive: 51> 116089 (self isInfinite or: [self isNaN]) ifTrue: [self error: 'Cannot truncate this number']. 116090 116091 self abs < 2.0e16 116092 ifTrue: ["Fastest way when it may not be an integer" 116093 "^ (self quo: 1073741823.0) * 1073741823 + (self rem: 1073741823.0) truncated" 116094 | di df q r | 116095 di := (SmallInteger maxVal bitShift: -1)+1. 116096 df := di asFloat. 116097 q := self quo: df. 116098 r := self - (q asFloat * df). 116099 ^q*di+r truncated] 116100 ifFalse: [^ self asTrueFraction. "Extract all bits of the mantissa and shift if necess"] 116101 116102 116103 116104 ! ! 116105 116106 116107!Float methodsFor: 'private' stamp: 'nice 8/9/2009 21:01'! 116108absPrintOn: aStream base: base digitCount: digitCount 116109 "Print me in the given base, using digitCount significant figures." 116110 116111 | fuzz x exp q fBase scale logScale xi | 116112 self isInfinite ifTrue: [^ aStream nextPutAll: 'Inf']. 116113 fBase := base asFloat. 116114 "x is myself normalized to [1.0, fBase), exp is my exponent" 116115 exp := 116116 self < 1.0 116117 ifTrue: [self reciprocalFloorLog: fBase] 116118 ifFalse: [self floorLog: fBase]. 116119 scale := 1.0. 116120 logScale := 0. 116121 [(x := fBase raisedTo: (exp + logScale)) = 0] 116122 whileTrue: 116123 [scale := scale * fBase. 116124 logScale := logScale + 1]. 116125 x := self * scale / x. 116126 fuzz := fBase raisedTo: 1 - digitCount. 116127 "round the last digit to be printed" 116128 x := 0.5 * fuzz + x. 116129 x >= fBase 116130 ifTrue: 116131 ["check if rounding has unnormalized x" 116132 x := x / fBase. 116133 exp := exp + 1]. 116134 (exp < 6 and: [exp > -4]) 116135 ifTrue: 116136 ["decimal notation" 116137 q := 0. 116138 exp < 0 ifTrue: [1 to: 1 - exp do: [:i | aStream nextPut: ('0.0000' 116139at: i)]]] 116140 ifFalse: 116141 ["scientific notation" 116142 q := exp. 116143 exp := 0]. 116144 [x >= fuzz] 116145 whileTrue: 116146 ["use fuzz to track significance" 116147 xi := x asInteger. 116148 aStream nextPut: (Character digitValue: xi). 116149 x := x - xi asFloat * fBase. 116150 fuzz := fuzz * fBase. 116151 exp := exp - 1. 116152 exp = -1 ifTrue: [aStream nextPut: $.]]. 116153 [exp >= -1] 116154 whileTrue: 116155 [aStream nextPut: $0. 116156 exp := exp - 1. 116157 exp = -1 ifTrue: [aStream nextPut: $.]]. 116158 q ~= 0 116159 ifTrue: 116160 [aStream nextPut: $e. 116161 q printOn: aStream]! ! 116162 116163"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 116164 116165Float class 116166 instanceVariableNames: ''! 116167 116168!Float class methodsFor: 'class initialization' stamp: 'nice 3/15/2008 22:42'! 116169initialize 116170 "Float initialize" 116171 "Constants from Computer Approximations, pp. 182-183: 116172 Pi = 3.14159265358979323846264338327950288 116173 Pi/2 = 1.57079632679489661923132169163975144 116174 Pi*2 = 6.28318530717958647692528676655900576 116175 Pi/180 = 0.01745329251994329576923690768488612 116176 2.0 ln = 0.69314718055994530941723212145817657 116177 2.0 sqrt = 1.41421356237309504880168872420969808" 116178 116179 Pi := 3.14159265358979323846264338327950288. 116180 Halfpi := Pi / 2.0. 116181 Twopi := Pi * 2.0. 116182 ThreePi := Pi * 3.0. 116183 RadiansPerDegree := Pi / 180.0. 116184 116185 Ln2 := 0.69314718055994530941723212145817657. 116186 Ln10 := 10.0 ln. 116187 Sqrt2 := 1.41421356237309504880168872420969808. 116188 E := 2.718281828459045235360287471353. 116189 116190 Epsilon := 0.000000000001. "Defines precision of mathematical functions" 116191 116192 MaxVal := 1.7976931348623157e308. 116193 MaxValLn := 709.782712893384. 116194 MinValLogBase2 := -1074. 116195 116196 Infinity := MaxVal * MaxVal. 116197 NegativeInfinity := 0.0 - Infinity. 116198 NaN := Infinity - Infinity. 116199 NegativeZero := 1.0 / Infinity negated. 116200! ! 116201 116202 116203!Float class methodsFor: 'constants' stamp: 'nice 6/11/2009 12:29'! 116204denormalized 116205 "Answer whether implementation supports denormalized numbers (also known as gradual underflow)." 116206 116207 ^true! ! 116208 116209!Float class methodsFor: 'constants'! 116210e 116211 "Answer the constant, E." 116212 116213 ^E! ! 116214 116215!Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:42'! 116216emax 116217 "Answer exponent of maximal representable value" 116218 116219 ^1023! ! 116220 116221!Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:43'! 116222emin 116223 "Answer exponent of minimal normalized representable value" 116224 116225 ^-1022! ! 116226 116227!Float class methodsFor: 'constants' stamp: 'nice 6/11/2009 12:30'! 116228epsilon 116229 "Answer difference between 1.0 and previous representable value" 116230 116231 ^1.0 timesTwoPower: 1 - self precision! ! 116232 116233!Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:20'! 116234fmax 116235 "Answer the maximum finite floating point value representable." 116236 116237 ^MaxVal! ! 116238 116239!Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:33'! 116240fmin 116241 "Answer minimum positive representable value." 116242 116243 ^self denormalized 116244 ifTrue: [self fminDenormalized] 116245 ifFalse: [self fminNormalized]! ! 116246 116247!Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:22'! 116248fminDenormalized 116249 "Answer the minimum denormalized value representable." 116250 116251 ^1.0 timesTwoPower: MinValLogBase2! ! 116252 116253!Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:22'! 116254fminNormalized 116255 "Answer the minimum normalized value representable." 116256 116257 ^1.0 timesTwoPower: -1022! ! 116258 116259!Float class methodsFor: 'constants' stamp: 'sw 10/8/1999 22:59'! 116260halfPi 116261 ^ Halfpi! ! 116262 116263!Float class methodsFor: 'constants' stamp: 'tao 4/23/98 11:37'! 116264infinity 116265 "Answer the value used to represent an infinite magnitude" 116266 116267 ^ Infinity! ! 116268 116269!Float class methodsFor: 'constants' stamp: 'tao 4/23/98 11:38'! 116270nan 116271 "Answer the canonical value used to represent Not-A-Number" 116272 116273 ^ NaN! ! 116274 116275!Float class methodsFor: 'constants' stamp: 'tao 4/23/98 12:05'! 116276negativeZero 116277 116278 ^ NegativeZero! ! 116279 116280!Float class methodsFor: 'constants' stamp: 'GabrielOmarCotelli 5/25/2009 15:42'! 116281one 116282 116283 ^1.0! ! 116284 116285!Float class methodsFor: 'constants'! 116286pi 116287 "Answer the constant, Pi." 116288 116289 ^Pi! ! 116290 116291!Float class methodsFor: 'constants' stamp: 'nice 6/11/2009 12:40'! 116292precision 116293 "Answer the apparent precision of the floating point representation. 116294 That is the maximum number of radix-based digits (bits if radix=2) representable in floating point without round off error. 116295 Technically, 52 bits are stored in the representation, and normalized numbers have an implied leading 1 that does not need to be stored. 116296 Note that denormalized floating point numbers don't have the implied leading 1, and thus gradually loose precision. 116297 This format conforms IEEE 754 double precision standard." 116298 116299 ^53! ! 116300 116301!Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:16'! 116302radix 116303 "Answer the radix used for internal floating point representation." 116304 116305 ^2! ! 116306 116307!Float class methodsFor: 'constants' stamp: 'yo 6/17/2004 17:44'! 116308threePi 116309 116310 ^ ThreePi 116311! ! 116312 116313!Float class methodsFor: 'constants' stamp: 'yo 6/17/2004 17:41'! 116314twoPi 116315 116316 ^ Twopi 116317! ! 116318 116319 116320!Float class methodsFor: 'instance creation' stamp: 'nice 5/30/2006 03:13'! 116321fromIEEE32Bit: word 116322 "Convert the given 32 bit word (which is supposed to be a positive 32bit value) from a 32bit IEEE floating point representation into an actual Squeak float object (being 64bit wide). Should only be used for conversion in FloatArrays or likewise objects." 116323 116324 | sign mantissa exponent newFloat delta | 116325 word negative ifTrue: [^ self error:'Cannot deal with negative numbers']. 116326 word = 0 ifTrue: [^ 0.0]. 116327 sign := word bitAnd: 16r80000000. 116328 word = sign ifTrue: [^self negativeZero]. 116329 116330 exponent := ((word bitShift: -23) bitAnd: 16rFF) - 127. 116331 mantissa := word bitAnd: 16r7FFFFF. 116332 116333 exponent = 128 ifTrue:["Either NAN or INF" 116334 mantissa = 0 ifFalse:[^ Float nan]. 116335 sign = 0 116336 ifTrue:[^ Float infinity] 116337 ifFalse:[^ Float infinity negated]]. 116338 116339 exponent = -127 ifTrue: [ 116340 "gradual underflow (denormalized number) 116341 Remove first bit of mantissa and adjust exponent" 116342 delta := mantissa highBit. 116343 mantissa := (mantissa bitShift: 1) bitAnd: (1 bitShift: delta) - 1. 116344 exponent := exponent + delta - 23]. 116345 116346 "Create new float" 116347 newFloat := self new: 2. 116348 newFloat basicAt: 1 put: ((sign bitOr: (1023 + exponent bitShift: 20)) bitOr: (mantissa bitShift: -3)). 116349 newFloat basicAt: 2 put: ((mantissa bitAnd: 7) bitShift: 29). 116350 ^newFloat! ! 116351 116352!Float class methodsFor: 'instance creation'! 116353readFrom: aStream 116354 "Answer a new Float as described on the stream, aStream." 116355 116356 ^(super readFrom: aStream) asFloat! ! 116357 116358!Float class methodsFor: 'instance creation' stamp: 'nice 3/15/2008 00:54'! 116359readFrom: aStream ifFail: aBlock 116360 "Answer a new Float as described on the stream, aStream." 116361 116362 ^(super readFrom: aStream ifFail: [^aBlock value]) asFloat! ! 116363ArrayedCollection variableWordSubclass: #FloatArray 116364 instanceVariableNames: '' 116365 classVariableNames: '' 116366 poolDictionaries: '' 116367 category: 'Collections-Arrayed'! 116368!FloatArray commentStamp: '<historical>' prior: 0! 116369FloatArrays store 32bit IEEE floating point numbers.! 116370 116371 116372!FloatArray methodsFor: '*tools-inspector' stamp: 'ar 9/27/2005 18:33'! 116373inspectorClass 116374 "Answer the class of the inspector to be used on the receiver. Called by inspect; 116375 use basicInspect to get a normal (less useful) type of inspector." 116376 116377 ^OrderedCollectionInspector! ! 116378 116379 116380!FloatArray methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! 116381at: index 116382 <primitive: 'primitiveAt' module: 'FloatArrayPlugin'> 116383 ^Float fromIEEE32Bit: (self basicAt: index)! ! 116384 116385!FloatArray methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! 116386at: index put: value 116387 <primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'> 116388 value isFloat 116389 ifTrue:[self basicAt: index put: value asIEEE32BitWord] 116390 ifFalse:[self at: index put: value asFloat]. 116391 ^value! ! 116392 116393!FloatArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! 116394defaultElement 116395 "Return the default element of the receiver" 116396 ^0.0! ! 116397 116398!FloatArray methodsFor: 'accessing' stamp: 'laza 3/24/2000 13:08'! 116399length 116400 "Return the length of the receiver" 116401 ^self squaredLength sqrt! ! 116402 116403!FloatArray methodsFor: 'accessing' stamp: 'laza 3/24/2000 13:08'! 116404squaredLength 116405 "Return the squared length of the receiver" 116406 ^self dot: self! ! 116407 116408 116409!FloatArray methodsFor: 'arithmetic' stamp: 'nice 11/24/2007 00:10'! 116410adaptToNumber: rcvr andSend: selector 116411 "If I am involved in arithmetic with a Number. If possible, 116412 convert it to a float and perform the (more efficient) primitive operation." 116413 selector == #+ ifTrue:[^self + rcvr]. 116414 selector == #* ifTrue:[^self * rcvr]. 116415 selector == #- ifTrue:[^self negated += rcvr]. 116416 selector == #/ ifTrue:[ 116417 "DO NOT USE TRIVIAL CODE 116418 ^self reciprocal * rcvr 116419 BECAUSE OF GRADUAL UNDERFLOW 116420 self should: (1.0e-39 / (FloatArray with: 1.0e-39)) first < 2." 116421 ^(self class new: self size withAll: rcvr) / self 116422 ]. 116423 ^super adaptToNumber: rcvr andSend: selector! ! 116424 116425!FloatArray methodsFor: 'arithmetic' stamp: 'laza 3/24/2000 13:07'! 116426dot: aFloatVector 116427 "Primitive. Return the dot product of the receiver and the argument. 116428 Fail if the argument is not of the same size as the receiver." 116429 | result | 116430 "<primitive:'primitiveFloatArrayDotProduct'>" 116431 self size = aFloatVector size ifFalse:[^self error:'Must be equal size']. 116432 result := 0.0. 116433 1 to: self size do:[:i| 116434 result := result + ((self at: i) * (aFloatVector at: i)). 116435 ]. 116436 ^result! ! 116437 116438!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/7/2001 23:04'! 116439negated 116440 ^self clone *= -1! ! 116441 116442!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:33'! 116443* anObject 116444 ^self clone *= anObject! ! 116445 116446!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:49'! 116447*= anObject 116448 ^anObject isNumber 116449 ifTrue:[self primMulScalar: anObject asFloat] 116450 ifFalse:[self primMulArray: anObject]! ! 116451 116452!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:33'! 116453+ anObject 116454 ^self clone += anObject! ! 116455 116456!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:48'! 116457+= anObject 116458 ^anObject isNumber 116459 ifTrue:[self primAddScalar: anObject asFloat] 116460 ifFalse:[self primAddArray: anObject]! ! 116461 116462!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:33'! 116463- anObject 116464 ^self clone -= anObject! ! 116465 116466!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:49'! 116467-= anObject 116468 ^anObject isNumber 116469 ifTrue:[self primSubScalar: anObject asFloat] 116470 ifFalse:[self primSubArray: anObject]! ! 116471 116472!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:34'! 116473/ anObject 116474 ^self clone /= anObject! ! 116475 116476!FloatArray methodsFor: 'arithmetic' stamp: 'ar 10/7/1998 19:58'! 116477/= anObject 116478 ^anObject isNumber 116479 ifTrue:[self primDivScalar: anObject asFloat] 116480 ifFalse:[self primDivArray: anObject]! ! 116481 116482!FloatArray methodsFor: 'arithmetic' stamp: 'yo 9/14/2004 17:12'! 116483\\= other 116484 116485 other isNumber ifTrue: [ 116486 1 to: self size do: [:i | 116487 self at: i put: (self at: i) \\ other 116488 ]. 116489 ^ self. 116490 ]. 116491 1 to: (self size min: other size) do: [:i | 116492 self at: i put: (self at: i) \\ (other at: i). 116493 ]. 116494 116495! ! 116496 116497 116498!FloatArray methodsFor: 'comparing' stamp: 'ar 5/3/2001 13:02'! 116499hash 116500 | result | 116501 <primitive:'primitiveHashArray' module: 'FloatArrayPlugin'> 116502 result := 0. 116503 1 to: self size do:[:i| result := result + (self basicAt: i) ]. 116504 ^result bitAnd: 16r1FFFFFFF! ! 116505 116506!FloatArray methodsFor: 'comparing' stamp: 'ar 2/2/2001 15:47'! 116507= aFloatArray 116508 | length | 116509 <primitive: 'primitiveEqual' module: 'FloatArrayPlugin'> 116510 aFloatArray class = self class ifFalse: [^ false]. 116511 length := self size. 116512 length = aFloatArray size ifFalse: [^ false]. 116513 1 to: self size do: [:i | (self at: i) 116514 = (aFloatArray at: i) ifFalse: [^ false]]. 116515 ^ true! ! 116516 116517 116518!FloatArray methodsFor: 'converting' stamp: 'ar 9/14/1998 23:46'! 116519asFloatArray 116520 ^self! ! 116521 116522 116523!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! 116524primAddArray: floatArray 116525 116526 <primitive: 'primitiveAddFloatArray' module: 'FloatArrayPlugin'> 116527 1 to: self size do:[:i| self at: i put: (self at: i) + (floatArray at: i)].! ! 116528 116529!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! 116530primAddScalar: scalarValue 116531 116532 <primitive: 'primitiveAddScalar' module: 'FloatArrayPlugin'> 116533 1 to: self size do:[:i| self at: i put: (self at: i) + scalarValue].! ! 116534 116535!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! 116536primDivArray: floatArray 116537 116538 <primitive: 'primitiveDivFloatArray' module: 'FloatArrayPlugin'> 116539 1 to: self size do:[:i| self at: i put: (self at: i) / (floatArray at: i)].! ! 116540 116541!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! 116542primDivScalar: scalarValue 116543 116544 <primitive: 'primitiveDivScalar' module: 'FloatArrayPlugin'> 116545 1 to: self size do:[:i| self at: i put: (self at: i) / scalarValue].! ! 116546 116547!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! 116548primMulArray: floatArray 116549 116550 <primitive: 'primitiveMulFloatArray' module: 'FloatArrayPlugin'> 116551 1 to: self size do:[:i| self at: i put: (self at: i) * (floatArray at: i)].! ! 116552 116553!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! 116554primMulScalar: scalarValue 116555 116556 <primitive: 'primitiveMulScalar' module: 'FloatArrayPlugin'> 116557 1 to: self size do:[:i| self at: i put: (self at: i) * scalarValue].! ! 116558 116559!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! 116560primSubArray: floatArray 116561 116562 <primitive: 'primitiveSubFloatArray' module: 'FloatArrayPlugin'> 116563 1 to: self size do:[:i| self at: i put: (self at: i) - (floatArray at: i)].! ! 116564 116565!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! 116566primSubScalar: scalarValue 116567 116568 <primitive: 'primitiveSubScalar' module: 'FloatArrayPlugin'> 116569 1 to: self size do:[:i| self at: i put: (self at: i) - scalarValue].! ! 116570 116571!FloatArray methodsFor: 'primitives-plugin' stamp: 'jcg 6/12/2003 17:54'! 116572sum 116573 116574 <primitive: 'primitiveSum' module: 'FloatArrayPlugin'> 116575 ^ super sum! ! 116576 116577 116578!FloatArray methodsFor: 'private' stamp: 'ar 10/9/1998 11:27'! 116579replaceFrom: start to: stop with: replacement startingAt: repStart 116580 "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." 116581 <primitive: 105> 116582 super replaceFrom: start to: stop with: replacement startingAt: repStart! ! 116583CollectionRootTest subclass: #FloatArrayTest 116584 uses: TCreationWithTest + TSequencedStructuralEqualityTest + TSequencedConcatenationTest + TSetArithmetic + TAsStringCommaAndDelimiterSequenceableTest + TPrintOnSequencedTest + TEmptyTest + TBeginsEndsWith + TCloneTest + TConvertTest - {#testAsByteArray. #integerCollectionWithoutEqualElements} + TConvertAsSortedTest + TConvertAsSetForMultiplinessIdentityTest - {#testAsIdentitySetWithEqualsElements. #testAsIdentitySetWithIdentityEqualsElements} + TCopyPartOfSequenceable + TCopyPartOfSequenceableForMultipliness + TCopySequenceableSameContents + TCopySequenceableWithOrWithoutSpecificElements + TCopySequenceableWithReplacement + TCopyTest + TIncludesWithIdentityCheckTest - {#testIdentityIncludesNonSpecificComportement} + TIndexAccess - {#testIdentityIndexOf. #testIdentityIndexOfIAbsent} + TIndexAccessForMultipliness - {#testIdentityIndexOfIAbsentDuplicate. #testIdentityIndexOfDuplicate} + TIterateSequencedReadableTest + TPutTest + TPutBasicTest + TReplacementSequencedTest + TSequencedElementAccessTest + TSortTest + TSubCollectionAccess 116585 instanceVariableNames: 'nonEmpty5ElementsNoDuplicate empty elementNotIn elementTwiceIn collectionWithEqualElements nonEmpty1Element collectionWithSameAtEndAndBegining collectionWith1TimeSubcollection collectionWith2TimeSubcollection collectionNotIncluded nonEmptySubcollection elementInNonEmpty replacementCollectionSameSize sortedCollection' 116586 classVariableNames: '' 116587 poolDictionaries: '' 116588 category: 'CollectionsTests-Arrayed'! 116589!FloatArrayTest commentStamp: 'nice 5/30/2006 01:24' prior: 0! 116590These tests are used to assert that FloatArrayPlugin has same results as Float asIEEE32BitWord! 116591 116592 116593!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:22'! 116594aValue 116595" return a value to put into nonEmpty" 116596 ^ elementNotIn ! ! 116597 116598!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:23'! 116599anIndex 116600" return an index in nonEmpty bounds" 116601 ^ 2! ! 116602 116603!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:50'! 116604anotherElementNotIn 116605" return an element different of 'elementNotIn' not included in 'nonEmpty' " 116606 ^ elementNotIn ! ! 116607 116608!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:55'! 116609anotherElementOrAssociationIn 116610 " return an element (or an association for Dictionary ) present in 'collection' " 116611 ^ self collection anyOne! ! 116612 116613!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:56'! 116614anotherElementOrAssociationNotIn 116615 " return an element (or an association for Dictionary )not present in 'collection' " 116616 ^ elementNotIn ! ! 116617 116618!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:24'! 116619anotherValue 116620" return a value ( not eual to 'aValue' ) to put into nonEmpty " 116621 ^ elementInNonEmpty ! ! 116622 116623!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:56'! 116624collection 116625 116626 ^ nonEmpty5ElementsNoDuplicate ! ! 116627 116628!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 11:45'! 116629collectionClass 116630 116631 ^ FloatArray! ! 116632 116633!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:55'! 116634collectionMoreThan1NoDuplicates 116635 " return a collection of size > 1 without equal elements" 116636 ^ nonEmpty5ElementsNoDuplicate ! ! 116637 116638!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:05'! 116639collectionMoreThan5Elements 116640" return a collection including at least 5 elements" 116641 116642 ^ nonEmpty5ElementsNoDuplicate ! ! 116643 116644!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:41'! 116645collectionNotIncluded 116646" return a collection for wich each element is not included in 'nonEmpty' " 116647 ^ collectionNotIncluded 116648 ifNil: [ collectionNotIncluded := (FloatArray new: 2) at:1 put: elementNotIn ; at: 2 put: elementNotIn ; yourself ].! ! 116649 116650!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:39'! 116651collectionWith1TimeSubcollection 116652" return a collection including 'oldSubCollection' only one time " 116653 ^ collectionWith1TimeSubcollection ifNil: [ collectionWith1TimeSubcollection := collectionWithSameAtEndAndBegining , self oldSubCollection , collectionWithSameAtEndAndBegining ].! ! 116654 116655!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:35'! 116656collectionWith2TimeSubcollection 116657" return a collection including 'oldSubCollection' two or many time " 116658 ^ collectionWith2TimeSubcollection ifNil: [ collectionWith2TimeSubcollection := self collectionWith1TimeSubcollection, self oldSubCollection ].! ! 116659 116660!FloatArrayTest methodsFor: 'requirements'! 116661collectionWithCopy 116662 "return a collection of type 'self collectionWIithoutEqualsElements class' containing no elements equals ( with identity equality) 116663 but 2 elements only equals with classic equality" 116664 | result collection | 116665 collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. 116666 collection add: collection first copy. 116667 result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. 116668 ^ result! ! 116669 116670!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:50'! 116671collectionWithCopyNonIdentical 116672 " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" 116673 ^ nonEmpty5ElementsNoDuplicate ! ! 116674 116675!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:44'! 116676collectionWithElementsToRemove 116677" return a collection of elements included in 'nonEmpty' " 116678 ^ nonEmptySubcollection 116679 ifNil: [ nonEmptySubcollection := (FloatArray new:2 ) at:1 put: self nonEmpty first ; at:2 put: self nonEmpty last ; yourself ]! ! 116680 116681!FloatArrayTest methodsFor: 'requirements'! 116682collectionWithIdentical 116683 "return a collection of type : 'self collectionWIithoutEqualsElements class containing two elements equals ( with identity equality)" 116684 | result collection element | 116685 collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. 116686 element := collection first. 116687 collection add: element. 116688 result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. 116689 ^ result! ! 116690 116691!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:07'! 116692collectionWithNonIdentitySameAtEndAndBegining 116693 " return a collection with elements at end and begining equals only with classic equality (they are not the same object). 116694(others elements of the collection are not equal to those elements)" 116695 ^ collectionWithSameAtEndAndBegining ! ! 116696 116697!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:28'! 116698collectionWithSameAtEndAndBegining 116699" return a collection with elements at end and begining equals . 116700(others elements of the collection are not equal to those elements)" 116701 ^ collectionWithSameAtEndAndBegining ! ! 116702 116703!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:02'! 116704collectionWithSortableElements 116705" return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" 116706 ^ nonEmpty5ElementsNoDuplicate ! ! 116707 116708!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:01'! 116709collectionWithoutEqualElements 116710" return a collection without equal elements" 116711 ^ nonEmpty5ElementsNoDuplicate ! ! 116712 116713!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:25'! 116714collectionWithoutEqualsElements 116715 116716" return a collection not including equal elements " 116717 ^ nonEmpty5ElementsNoDuplicate ! ! 116718 116719!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:44'! 116720collectionWithoutNilElements 116721" return a collection that doesn't includes a nil element and that doesn't includes equal elements'" 116722 ^ nonEmpty5ElementsNoDuplicate ! ! 116723 116724!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:35'! 116725elementInForElementAccessing 116726" return an element inculded in 'moreThan4Elements'" 116727 ^ elementInNonEmpty ! ! 116728 116729!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:02'! 116730elementInForIndexAccessing 116731" return an element included in 'collectionMoreThan1NoDuplicates' " 116732 ^ elementInNonEmpty .! ! 116733 116734!FloatArrayTest methodsFor: 'requirements'! 116735elementInForReplacement 116736" return an element included in 'nonEmpty' " 116737^ self nonEmpty anyOne.! ! 116738 116739!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:50'! 116740elementNotIn 116741"return an element not included in 'nonEmpty' " 116742 116743 ^ elementNotIn ! ! 116744 116745!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:35'! 116746elementNotInForElementAccessing 116747" return an element not included in 'moreThan4Elements' " 116748 ^ elementNotIn ! ! 116749 116750!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:55'! 116751elementNotInForIndexAccessing 116752" return an element not included in 'collectionMoreThan1NoDuplicates' " 116753 ^ elementNotIn ! ! 116754 116755!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:45'! 116756elementToAdd 116757" return an element of type 'nonEmpy' elements'type' not yet included in nonEmpty" 116758 ^ elementNotIn ! ! 116759 116760!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:04'! 116761elementsCopyNonIdenticalWithoutEqualElements 116762 " return a collection that does niot incllude equal elements ( classic equality ) 116763 all elements included are elements for which copy is not identical to the element " 116764 ^ nonEmpty5ElementsNoDuplicate ! ! 116765 116766!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:45'! 116767empty 116768 ^ empty ! ! 116769 116770!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:55'! 116771firstCollection 116772" return a collection that will be the first part of the concatenation" 116773 ^ nonEmpty5ElementsNoDuplicate ! ! 116774 116775!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:26'! 116776firstIndex 116777" return an index between 'nonEmpty' bounds that is < to 'second index' " 116778 ^2! ! 116779 116780!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:23'! 116781indexArray 116782" return a Collection including indexes between bounds of 'nonEmpty' " 116783 116784 ^ { 1. 4. 3.}! ! 116785 116786!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:26'! 116787indexInForCollectionWithoutDuplicates 116788" return an index between 'collectionWithoutEqualsElements' bounds" 116789 ^ 2.! ! 116790 116791!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:30'! 116792indexInNonEmpty 116793" return an index between bounds of 'nonEmpty' " 116794 116795 ^ 3.! ! 116796 116797!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:44'! 116798moreThan3Elements 116799 " return a collection including atLeast 3 elements" 116800 ^ nonEmpty5ElementsNoDuplicate ! ! 116801 116802!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:36'! 116803moreThan4Elements 116804 116805" return a collection including at leat 4 elements" 116806 ^ nonEmpty5ElementsNoDuplicate ! ! 116807 116808!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:26'! 116809newElement 116810"return an element that will be put in the collection in place of another" 116811 ^ elementNotIn ! ! 116812 116813!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:45'! 116814nonEmpty 116815 116816 ^ nonEmpty5ElementsNoDuplicate ! ! 116817 116818!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:57'! 116819nonEmpty1Element 116820" return a collection of size 1 including one element" 116821 ^ nonEmpty1Element ! ! 116822 116823!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:11'! 116824nonEmptyMoreThan1Element 116825" return a collection that doesn't includes equal elements' and doesn't include nil elements'" 116826 ^nonEmpty5ElementsNoDuplicate ! ! 116827 116828!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:36'! 116829oldSubCollection 116830" return a subCollection included in collectionWith1TimeSubcollection . 116831ex : subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)" 116832 ^ nonEmpty5ElementsNoDuplicate ! ! 116833 116834!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:37'! 116835replacementCollection 116836" return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection' " 116837 ^ collectionWithSameAtEndAndBegining ! ! 116838 116839!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:34'! 116840replacementCollectionSameSize 116841" return a collection of size (secondIndex - firstIndex + 1)" 116842 ^replacementCollectionSameSize 116843 ifNil: [ replacementCollectionSameSize := FloatArray new: (self secondIndex - self firstIndex + 1). 116844 1 to: replacementCollectionSameSize size do: 116845 [ :i | replacementCollectionSameSize at:i put: elementInNonEmpty ]. 116846 replacementCollectionSameSize. 116847 ].! ! 116848 116849!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:55'! 116850secondCollection 116851" return a collection that will be the second part of the concatenation" 116852 ^ collectionWithEqualElements ! ! 116853 116854!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:27'! 116855secondIndex 116856" return an index between 'nonEmpty' bounds that is > to 'first index' " 116857 ^self firstIndex +1! ! 116858 116859!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:55'! 116860sizeCollection 116861 "Answers a collection not empty" 116862 ^ nonEmpty5ElementsNoDuplicate ! ! 116863 116864!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:41'! 116865sortedInAscendingOrderCollection 116866" return a collection sorted in an acsending order" 116867 ^ sortedCollection ifNil: [ sortedCollection := ( FloatArray new: 3)at: 1 put: 1.0 ; at: 2 put: 2.0 ; at: 3 put: 3.0 ; yourself ] 116868 ! ! 116869 116870!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:36'! 116871subCollectionNotIn 116872" return a collection for which at least one element is not included in 'moreThan4Elements' " 116873 ^ collectionNotIncluded 116874 ifNil: [ collectionNotIncluded := (FloatArray new: 2) at:1 put: elementNotIn ; at: 2 put: elementNotIn ; yourself ].! ! 116875 116876!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:37'! 116877unsortedCollection 116878" retur a collection that is not yat sorted" 116879 ^nonEmpty5ElementsNoDuplicate ! ! 116880 116881!FloatArrayTest methodsFor: 'requirements'! 116882valueArray 116883" return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty' at indexes in 'indexArray' " 116884 | result | 116885 result := Array new: self indexArray size. 116886 1 to: result size do: 116887 [:i | 116888 result at:i put: (self aValue ). 116889 ]. 116890 ^ result.! ! 116891 116892!FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:04'! 116893withEqualElements 116894 ^ collectionWithEqualElements ! ! 116895 116896 116897!FloatArrayTest methodsFor: 'running' stamp: 'delaunay 5/14/2009 16:40'! 116898setUp 116899 116900empty := FloatArray new. 116901elementInNonEmpty := 7.0. 116902nonEmpty5ElementsNoDuplicate := (FloatArray new:5) at: 1 put: 1.5 ; at: 2 put: 2.5 ; at: 3 put: elementInNonEmpty ; at: 4 put: 4.5 ; at: 5 put: 5.5 ; yourself. 116903elementNotIn := 999.0. 116904elementTwiceIn := 2.3 . 116905collectionWithEqualElements := (FloatArray new: 3) at: 1 put: 2.0 ; at: 2 put: 2.0 ; at: 3 put: 3.5 ; yourself. 116906nonEmpty1Element := ( FloatArray new: 1) at:1 put: 1.2 ; yourself. 116907collectionWithSameAtEndAndBegining := (FloatArray new: 3) at: 1 put: 2.0 ; at: 2 put: 1.0 ; at: 3 put: 2.0 copy ; yourself.! ! 116908 116909 116910!FloatArrayTest methodsFor: 'test - creation'! 116911testOfSize 116912 "self debug: #testOfSize" 116913 116914 | aCol | 116915 aCol := self collectionClass ofSize: 3. 116916 self assert: (aCol size = 3). 116917! ! 116918 116919!FloatArrayTest methodsFor: 'test - creation'! 116920testWith 116921 "self debug: #testWith" 116922 116923 | aCol element | 116924 element := self collectionMoreThan5Elements anyOne. 116925 aCol := self collectionClass with: element. 116926 self assert: (aCol includes: element).! ! 116927 116928!FloatArrayTest methodsFor: 'test - creation'! 116929testWithAll 116930 "self debug: #testWithAll" 116931 116932 | aCol collection | 116933 collection := self collectionMoreThan5Elements asOrderedCollection . 116934 aCol := self collectionClass withAll: collection . 116935 116936 collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. 116937 116938 self assert: (aCol size = collection size ).! ! 116939 116940!FloatArrayTest methodsFor: 'test - creation'! 116941testWithWith 116942 "self debug: #testWithWith" 116943 116944 | aCol collection element1 element2 | 116945 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . 116946 element1 := collection at: 1. 116947 element2 := collection at:2. 116948 116949 aCol := self collectionClass with: element1 with: element2 . 116950 self assert: (aCol occurrencesOf: element1 ) == ( collection occurrencesOf: element1). 116951 self assert: (aCol occurrencesOf: element2 ) == ( collection occurrencesOf: element2). 116952 116953 ! ! 116954 116955!FloatArrayTest methodsFor: 'test - creation'! 116956testWithWithWith 116957 "self debug: #testWithWithWith" 116958 116959 | aCol collection | 116960 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . 116961 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 116962 116963 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 116964 116965!FloatArrayTest methodsFor: 'test - creation'! 116966testWithWithWithWith 116967 "self debug: #testWithWithWithWith" 116968 116969 | aCol collection | 116970 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. 116971 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 116972 116973 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 116974 116975!FloatArrayTest methodsFor: 'test - creation'! 116976testWithWithWithWithWith 116977 "self debug: #testWithWithWithWithWith" 116978 116979 | aCol collection | 116980 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . 116981 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 116982 116983 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 116984 116985 116986!FloatArrayTest methodsFor: 'test - equality'! 116987testEqualSign 116988 "self debug: #testEqualSign" 116989 116990 self deny: (self empty = self nonEmpty).! ! 116991 116992!FloatArrayTest methodsFor: 'test - equality'! 116993testEqualSignIsTrueForNonIdenticalButEqualCollections 116994 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 116995 116996 self assert: (self empty = self empty copy). 116997 self assert: (self empty copy = self empty). 116998 self assert: (self empty copy = self empty copy). 116999 117000 self assert: (self nonEmpty = self nonEmpty copy). 117001 self assert: (self nonEmpty copy = self nonEmpty). 117002 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 117003 117004!FloatArrayTest methodsFor: 'test - equality'! 117005testEqualSignOfIdenticalCollectionObjects 117006 "self debug: #testEqualSignOfIdenticalCollectionObjects" 117007 117008 self assert: (self empty = self empty). 117009 self assert: (self nonEmpty = self nonEmpty). 117010 ! ! 117011 117012 117013!FloatArrayTest methodsFor: 'testing' stamp: 'nice 11/23/2007 23:53'! 117014testArithmeticCoercion 117015 "This test is related to http://bugs.squeak.org/view.php?id=6782" 117016 117017 self should: [3.0 / (FloatArray with: 2.0) = (FloatArray with: 1.5)]. 117018 self should: [3.0 * (FloatArray with: 2.0) = (FloatArray with: 6.0)]. 117019 self should: [3.0 + (FloatArray with: 2.0) = (FloatArray with: 5.0)]. 117020 self should: [3.0 - (FloatArray with: 2.0) = (FloatArray with: 1.0)].! ! 117021 117022!FloatArrayTest methodsFor: 'testing' stamp: 'nice 5/30/2006 03:17'! 117023testFloatArrayPluginPrimitiveAt 117024 "if FloatArrayPlugin primitive are not here, this test is dumb. 117025 Otherwise, it will compare primitive and #fromIEEE32Bit:" 117026 117027 #( 117028 "regular numbers no truncation or rounding" 117029 2r0.0 2r1.0 2r1.1 2r1.00000000000000000000001 117030 2r1.0e-10 2r1.1e-10 2r1.00000000000000000000001e-10 117031 2r1.0e10 2r1.1e10 2r1.00000000000000000000001e10 117032 117033 "smallest float32 before gradual underflow" 117034 2r1.0e-126 117035 117036 "biggest float32" 117037 2r1.11111111111111111111111e127 117038 117039 "overflow" 117040 2r1.11111111111111111111111e128 117041 117042 "gradual underflow" 117043 2r0.11111111111111111111111e-126 117044 2r0.00000000000000000000001e-126 117045 117046 "with rounding mode : tests on 25 bits" 117047 117048 2r1.0000000000000000000000001 117049 2r1.0000000000000000000000010 117050 2r1.0000000000000000000000011 117051 2r1.0000000000000000000000100 117052 2r1.0000000000000000000000101 117053 2r1.0000000000000000000000110 117054 2r1.0000000000000000000000111 117055 2r1.1111111111111111111111001 117056 2r1.1111111111111111111111010 117057 2r1.1111111111111111111111011 117058 2r1.1111111111111111111111101 117059 2r1.1111111111111111111111110 117060 2r1.1111111111111111111111111 117061 117062 "overflow" 117063 2r1.1111111111111111111111110e127 117064 117065 "gradual underflow" 117066 2r0.1111111111111111111111111e-126 117067 2r0.1111111111111111111111110e-126 117068 2r0.1111111111111111111111101e-126 117069 2r0.1111111111111111111111011e-126 117070 2r0.1111111111111111111111010e-126 117071 2r0.1111111111111111111111001e-126 117072 2r0.0000000000000000000000111e-126 117073 2r0.0000000000000000000000110e-126 117074 2r0.0000000000000000000000101e-126 117075 2r0.0000000000000000000000011e-126 117076 2r0.0000000000000000000000010e-126 117077 2r0.0000000000000000000000001e-126 117078 2r0.0000000000000000000000010000000000000000000000000001e-126 117079 ) do: [:e | 117080 self assert: ((FloatArray with: e) at: 1) = (Float fromIEEE32Bit: ((FloatArray with: e) basicAt: 1)). 117081 self assert: ((FloatArray with: e negated) at: 1) = (Float fromIEEE32Bit: ((FloatArray with: e negated) basicAt: 1))]. 117082 117083 "special cases" 117084 (Array with: Float infinity with: Float infinity negated with: Float negativeZero) 117085 do: [:e | self assert: ((FloatArray with: e) at: 1) = (Float fromIEEE32Bit: ((FloatArray with: e) basicAt: 1))]. 117086 117087 "Cannot compare NaN" 117088 (Array with: Float nan) 117089 do: [:e | self assert: (Float fromIEEE32Bit: ((FloatArray with: e) basicAt: 1)) isNaN].! ! 117090 117091!FloatArrayTest methodsFor: 'testing' stamp: 'nice 5/30/2006 03:17'! 117092testFloatArrayPluginPrimitiveAtPut 117093 "if FloatArrayPlugin primitive are not here, this test is dumb. 117094 Otherwise, it will compare primitive and #asIEEE32BitWord" 117095 117096 #( 117097 "regular numbers no truncation or rounding" 117098 2r0.0 2r1.0 2r1.1 2r1.00000000000000000000001 117099 2r1.0e-10 2r1.1e-10 2r1.00000000000000000000001e-10 117100 2r1.0e10 2r1.1e10 2r1.00000000000000000000001e10 117101 117102 "smallest float32 before gradual underflow" 117103 2r1.0e-126 117104 117105 "biggest float32" 117106 2r1.11111111111111111111111e127 117107 117108 "overflow" 117109 2r1.11111111111111111111111e128 117110 117111 "gradual underflow" 117112 2r0.11111111111111111111111e-126 117113 2r0.00000000000000000000001e-126 117114 117115 "with rounding mode : tests on 25 bits" 117116 117117 2r1.0000000000000000000000001 117118 2r1.0000000000000000000000010 117119 2r1.0000000000000000000000011 117120 2r1.0000000000000000000000100 117121 2r1.0000000000000000000000101 117122 2r1.0000000000000000000000110 117123 2r1.0000000000000000000000111 117124 2r1.1111111111111111111111001 117125 2r1.1111111111111111111111010 117126 2r1.1111111111111111111111011 117127 2r1.1111111111111111111111101 117128 2r1.1111111111111111111111110 117129 2r1.1111111111111111111111111 117130 117131 "overflow" 117132 2r1.1111111111111111111111110e127 117133 117134 "gradual underflow" 117135 2r0.1111111111111111111111111e-126 117136 2r0.1111111111111111111111110e-126 117137 2r0.1111111111111111111111101e-126 117138 2r0.1111111111111111111111011e-126 117139 2r0.1111111111111111111111010e-126 117140 2r0.1111111111111111111111001e-126 117141 2r0.0000000000000000000000111e-126 117142 2r0.0000000000000000000000110e-126 117143 2r0.0000000000000000000000101e-126 117144 2r0.0000000000000000000000011e-126 117145 2r0.0000000000000000000000010e-126 117146 2r0.0000000000000000000000001e-126 117147 2r0.0000000000000000000000010000000000000000000000000001e-126 117148 ) do: [:e | 117149 self assert: ((FloatArray with: e) basicAt: 1) = e asIEEE32BitWord. 117150 self assert: ((FloatArray with: e negated) basicAt: 1) = e negated asIEEE32BitWord]. 117151 117152 "special cases" 117153 (Array with: Float infinity with: Float infinity negated with: Float negativeZero with: Float nan) 117154 do: [:e | self assert: ((FloatArray with: e) basicAt: 1) = e asIEEE32BitWord]. 117155 ! ! 117156 117157 117158!FloatArrayTest methodsFor: 'tests - as identity set'! 117159testAsIdentitySetWithoutIdentityEqualsElements 117160 | result collection | 117161 collection := self collectionWithCopy. 117162 result := collection asIdentitySet. 117163 " no elements should have been removed as no elements are equels with Identity equality" 117164 self assert: result size = collection size. 117165 collection do: 117166 [ :each | 117167 (collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ]. 117168 self assert: result class = IdentitySet! ! 117169 117170 117171!FloatArrayTest methodsFor: 'tests - as set tests'! 117172testAsSetWithEqualsElements 117173 | result | 117174 result := self withEqualElements asSet. 117175 self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 117176 self assert: result class = Set! ! 117177 117178 117179!FloatArrayTest methodsFor: 'tests - as sorted collection'! 117180testAsSortedArray 117181 | result collection | 117182 collection := self collectionWithSortableElements . 117183 result := collection asSortedArray. 117184 self assert: (result class includesBehavior: Array). 117185 self assert: result isSorted. 117186 self assert: result size = collection size! ! 117187 117188!FloatArrayTest methodsFor: 'tests - as sorted collection'! 117189testAsSortedCollection 117190 117191 | aCollection result | 117192 aCollection := self collectionWithSortableElements . 117193 result := aCollection asSortedCollection. 117194 117195 self assert: (result class includesBehavior: SortedCollection). 117196 result do: 117197 [ :each | 117198 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 117199 117200 self assert: result size = aCollection size.! ! 117201 117202!FloatArrayTest methodsFor: 'tests - as sorted collection'! 117203testAsSortedCollectionWithSortBlock 117204 | result tmp | 117205 result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. 117206 self assert: (result class includesBehavior: SortedCollection). 117207 result do: 117208 [ :each | 117209 self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 117210 self assert: result size = self collectionWithSortableElements size. 117211 tmp:=result at: 1. 117212 result do: [:each| self assert: tmp>=each. tmp:=each]. 117213 ! ! 117214 117215 117216!FloatArrayTest methodsFor: 'tests - at put'! 117217testAtPut 117218 "self debug: #testAtPut" 117219 117220 self nonEmpty at: self anIndex put: self aValue. 117221 self assert: (self nonEmpty at: self anIndex) = self aValue. 117222 ! ! 117223 117224!FloatArrayTest methodsFor: 'tests - at put'! 117225testAtPutOutOfBounds 117226 "self debug: #testAtPutOutOfBounds" 117227 117228 self should: [self empty at: self anIndex put: self aValue] raise: Error 117229 ! ! 117230 117231!FloatArrayTest methodsFor: 'tests - at put'! 117232testAtPutTwoValues 117233 "self debug: #testAtPutTwoValues" 117234 117235 self nonEmpty at: self anIndex put: self aValue. 117236 self nonEmpty at: self anIndex put: self anotherValue. 117237 self assert: (self nonEmpty at: self anIndex) = self anotherValue.! ! 117238 117239 117240!FloatArrayTest methodsFor: 'tests - begins ends with'! 117241testsBeginsWith 117242 117243 self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty size)). 117244 self assert: (self nonEmpty beginsWith:(self nonEmpty )). 117245 self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 117246 117247!FloatArrayTest methodsFor: 'tests - begins ends with'! 117248testsBeginsWithEmpty 117249 117250 self deny: (self nonEmpty beginsWith:(self empty)). 117251 self deny: (self empty beginsWith:(self nonEmpty )). 117252! ! 117253 117254!FloatArrayTest methodsFor: 'tests - begins ends with'! 117255testsEndsWith 117256 117257 self assert: (self nonEmpty endsWith:(self nonEmpty copyWithoutFirst)). 117258 self assert: (self nonEmpty endsWith:(self nonEmpty )). 117259 self deny: (self nonEmpty endsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 117260 117261!FloatArrayTest methodsFor: 'tests - begins ends with'! 117262testsEndsWithEmpty 117263 117264 self deny: (self nonEmpty endsWith:(self empty )). 117265 self deny: (self empty endsWith:(self nonEmpty )). 117266 ! ! 117267 117268 117269!FloatArrayTest methodsFor: 'tests - comma and delimiter'! 117270testAsCommaStringEmpty 117271 117272 self assert: self empty asCommaString = ''. 117273 self assert: self empty asCommaStringAnd = ''. 117274 117275 117276! ! 117277 117278!FloatArrayTest methodsFor: 'tests - comma and delimiter'! 117279testAsCommaStringMore 117280 117281 "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. 117282 self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' 117283" 117284 117285 | result resultAnd index allElementsAsString | 117286 result:= self nonEmpty asCommaString . 117287 resultAnd:= self nonEmpty asCommaStringAnd . 117288 117289 index := 1. 117290 (result findBetweenSubStrs: ',' )do: 117291 [:each | 117292 index = 1 117293 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] 117294 ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. 117295 index:=index+1 117296 ]. 117297 117298 "verifying esultAnd :" 117299 allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 117300 1 to: allElementsAsString size do: 117301 [:i | 117302 i<(allElementsAsString size ) 117303 ifTrue: [ 117304 i = 1 117305 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] 117306 ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] 117307 ]. 117308 i=(allElementsAsString size) 117309 ifTrue:[ 117310 i = 1 117311 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 117312 ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 117313 ]. 117314 117315 117316 ].! ! 117317 117318!FloatArrayTest methodsFor: 'tests - comma and delimiter'! 117319testAsCommaStringOne 117320 117321 "self assert: self oneItemCol asCommaString = '1'. 117322 self assert: self oneItemCol asCommaStringAnd = '1'." 117323 117324 self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). 117325 self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). 117326 ! ! 117327 117328!FloatArrayTest methodsFor: 'tests - comma and delimiter'! 117329testAsStringOnDelimiterEmpty 117330 117331 | delim emptyStream | 117332 delim := ', '. 117333 emptyStream := ReadWriteStream on: ''. 117334 self empty asStringOn: emptyStream delimiter: delim. 117335 self assert: emptyStream contents = ''. 117336! ! 117337 117338!FloatArrayTest methodsFor: 'tests - comma and delimiter'! 117339testAsStringOnDelimiterLastEmpty 117340 117341 | delim emptyStream | 117342 delim := ', '. 117343 emptyStream := ReadWriteStream on: ''. 117344 self empty asStringOn: emptyStream delimiter: delim last:'and'. 117345 self assert: emptyStream contents = ''. 117346! ! 117347 117348!FloatArrayTest methodsFor: 'tests - comma and delimiter'! 117349testAsStringOnDelimiterLastMore 117350 117351 | delim multiItemStream result last allElementsAsString | 117352 117353 delim := ', '. 117354 last := 'and'. 117355 result:=''. 117356 multiItemStream := ReadWriteStream on:result. 117357 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 117358 117359 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 117360 1 to: allElementsAsString size do: 117361 [:i | 117362 i<(allElementsAsString size-1 ) 117363 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 117364 i=(allElementsAsString size-1) 117365 ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. 117366 i=(allElementsAsString size) 117367 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 117368 ]. 117369 117370! ! 117371 117372!FloatArrayTest methodsFor: 'tests - comma and delimiter'! 117373testAsStringOnDelimiterLastOne 117374 117375 | delim oneItemStream result | 117376 117377 delim := ', '. 117378 result:=''. 117379 oneItemStream := ReadWriteStream on: result. 117380 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 117381 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 117382 117383 117384 ! ! 117385 117386!FloatArrayTest methodsFor: 'tests - comma and delimiter'! 117387testAsStringOnDelimiterMore 117388 117389 | delim multiItemStream result index | 117390 "delim := ', '. 117391 multiItemStream := '' readWrite. 117392 self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. 117393 self assert: multiItemStream contents = '1, 2, 3'." 117394 117395 delim := ', '. 117396 result:=''. 117397 multiItemStream := ReadWriteStream on:result. 117398 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 117399 117400 index:=1. 117401 (result findBetweenSubStrs: ', ' )do: 117402 [:each | 117403 self assert: each= ((self nonEmpty at:index)asString). 117404 index:=index+1 117405 ].! ! 117406 117407!FloatArrayTest methodsFor: 'tests - comma and delimiter'! 117408testAsStringOnDelimiterOne 117409 117410 | delim oneItemStream result | 117411 "delim := ', '. 117412 oneItemStream := '' readWrite. 117413 self oneItemCol asStringOn: oneItemStream delimiter: delim. 117414 self assert: oneItemStream contents = '1'." 117415 117416 delim := ', '. 117417 result:=''. 117418 oneItemStream := ReadWriteStream on: result. 117419 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 117420 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 117421 117422 117423 ! ! 117424 117425 117426!FloatArrayTest methodsFor: 'tests - concatenation'! 117427testConcatenation 117428 | result index | 117429 result:= self firstCollection,self secondCollection . 117430 "first part : " 117431 index := 1. 117432 self firstCollection do: 117433 [:each | 117434 self assert: (self firstCollection at: index)=each. 117435 index := index+1.]. 117436 "second part : " 117437 1 to: self secondCollection size do: 117438 [:i | 117439 self assert: (self secondCollection at:i)= (result at:index). 117440 index:=index+1]. 117441 "size : " 117442 self assert: result size = (self firstCollection size + self secondCollection size).! ! 117443 117444!FloatArrayTest methodsFor: 'tests - concatenation'! 117445testConcatenationWithEmpty 117446 | result | 117447 result:= self empty,self secondCollection . 117448 117449 1 to: self secondCollection size do: 117450 [:i | 117451 self assert: (self secondCollection at:i)= (result at:i). 117452 ]. 117453 "size : " 117454 self assert: result size = ( self secondCollection size).! ! 117455 117456 117457!FloatArrayTest methodsFor: 'tests - converting'! 117458assertNoDuplicates: aCollection whenConvertedTo: aClass 117459 | result | 117460 result := self collectionWithEqualElements asIdentitySet. 117461 self assert: (result class includesBehavior: IdentitySet). 117462 self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! 117463 117464!FloatArrayTest methodsFor: 'tests - converting'! 117465assertNonDuplicatedContents: aCollection whenConvertedTo: aClass 117466 | result | 117467 result := aCollection perform: ('as' , aClass name) asSymbol. 117468 self assert: (result class includesBehavior: aClass). 117469 result do: 117470 [ :each | 117471 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 117472 ^ result! ! 117473 117474!FloatArrayTest methodsFor: 'tests - converting'! 117475assertSameContents: aCollection whenConvertedTo: aClass 117476 | result | 117477 result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. 117478 self assert: result size = aCollection size! ! 117479 117480!FloatArrayTest methodsFor: 'tests - converting'! 117481testAsArray 117482 "self debug: #testAsArray3" 117483 self 117484 assertSameContents: self collectionWithoutEqualElements 117485 whenConvertedTo: Array! ! 117486 117487!FloatArrayTest methodsFor: 'tests - converting'! 117488testAsBag 117489 117490 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! 117491 117492!FloatArrayTest methodsFor: 'tests - converting'! 117493testAsIdentitySet 117494 "test with a collection without equal elements :" 117495 self 117496 assertSameContents: self collectionWithoutEqualElements 117497 whenConvertedTo: IdentitySet. 117498! ! 117499 117500!FloatArrayTest methodsFor: 'tests - converting'! 117501testAsOrderedCollection 117502 117503 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! 117504 117505!FloatArrayTest methodsFor: 'tests - converting'! 117506testAsSet 117507 | | 117508 "test with a collection without equal elements :" 117509 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. 117510 ! ! 117511 117512 117513!FloatArrayTest methodsFor: 'tests - copy'! 117514testCopyEmptyWith 117515 "self debug: #testCopyWith" 117516 | res element | 117517 element := self elementToAdd. 117518 res := self empty copyWith: element. 117519 self assert: res size = (self empty size + 1). 117520 self assert: (res includes: (element value))! ! 117521 117522!FloatArrayTest methodsFor: 'tests - copy'! 117523testCopyEmptyWithout 117524 "self debug: #testCopyEmptyWithout" 117525 | res | 117526 res := self empty copyWithout: self elementToAdd. 117527 self assert: res size = self empty size. 117528 self deny: (res includes: self elementToAdd)! ! 117529 117530!FloatArrayTest methodsFor: 'tests - copy'! 117531testCopyEmptyWithoutAll 117532 "self debug: #testCopyEmptyWithoutAll" 117533 | res | 117534 res := self empty copyWithoutAll: self collectionWithElementsToRemove. 117535 self assert: res size = self empty size. 117536 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! 117537 117538!FloatArrayTest methodsFor: 'tests - copy'! 117539testCopyNonEmptyWith 117540 "self debug: #testCopyNonEmptyWith" 117541 | res element | 117542 element := self elementToAdd . 117543 res := self nonEmpty copyWith: element. 117544 "here we do not test the size since for a non empty set we would get a problem. 117545 Then in addition copy is not about duplicate management. The element should 117546 be in at the end." 117547 self assert: (res includes: (element value)). 117548 self nonEmpty do: [ :each | res includes: each ]! ! 117549 117550!FloatArrayTest methodsFor: 'tests - copy'! 117551testCopyNonEmptyWithout 117552 "self debug: #testCopyNonEmptyWithout" 117553 117554 | res anElementOfTheCollection | 117555 anElementOfTheCollection := self nonEmpty anyOne. 117556 res := (self nonEmpty copyWithout: anElementOfTheCollection). 117557 "here we do not test the size since for a non empty set we would get a problem. 117558 Then in addition copy is not about duplicate management. The element should 117559 be in at the end." 117560 self deny: (res includes: anElementOfTheCollection). 117561 self nonEmpty do: 117562 [:each | (each = anElementOfTheCollection) 117563 ifFalse: [self assert: (res includes: each)]]. 117564 117565! ! 117566 117567!FloatArrayTest methodsFor: 'tests - copy'! 117568testCopyNonEmptyWithoutAll 117569 "self debug: #testCopyNonEmptyWithoutAll" 117570 | res | 117571 res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. 117572 "here we do not test the size since for a non empty set we would get a problem. 117573 Then in addition copy is not about duplicate management. The element should 117574 be in at the end." 117575 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. 117576 self nonEmpty do: 117577 [ :each | 117578 (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! 117579 117580!FloatArrayTest methodsFor: 'tests - copy'! 117581testCopyNonEmptyWithoutAllNotIncluded 117582 "self debug: #testCopyNonEmptyWithoutAllNotIncluded" 117583 | res | 117584 res := self nonEmpty copyWithoutAll: self collectionNotIncluded. 117585 "here we do not test the size since for a non empty set we would get a problem. 117586 Then in addition copy is not about duplicate management. The element should 117587 be in at the end." 117588 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 117589 117590!FloatArrayTest methodsFor: 'tests - copy'! 117591testCopyNonEmptyWithoutNotIncluded 117592 "self debug: #testCopyNonEmptyWithoutNotIncluded" 117593 | res | 117594 res := self nonEmpty copyWithout: self elementToAdd. 117595 "here we do not test the size since for a non empty set we would get a problem. 117596 Then in addition copy is not about duplicate management. The element should 117597 be in at the end." 117598 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 117599 117600 117601!FloatArrayTest methodsFor: 'tests - copy - clone'! 117602testCopyCreatesNewObject 117603 "self debug: #testCopyCreatesNewObject" 117604 117605 | copy | 117606 copy := self nonEmpty copy. 117607 self deny: self nonEmpty == copy. 117608 ! ! 117609 117610!FloatArrayTest methodsFor: 'tests - copy - clone'! 117611testCopyEmpty 117612 "self debug: #testCopyEmpty" 117613 117614 | copy | 117615 copy := self empty copy. 117616 self assert: copy isEmpty.! ! 117617 117618!FloatArrayTest methodsFor: 'tests - copy - clone'! 117619testCopyNonEmpty 117620 "self debug: #testCopyNonEmpty" 117621 117622 | copy | 117623 copy := self nonEmpty copy. 117624 self deny: copy isEmpty. 117625 self assert: copy size = self nonEmpty size. 117626 self nonEmpty do: 117627 [:each | copy includes: each]! ! 117628 117629 117630!FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! 117631testCopyAfter 117632 | result index collection | 117633 collection := self collectionWithoutEqualsElements . 117634 index:= self indexInForCollectionWithoutDuplicates . 117635 result := collection copyAfter: (collection at:index ). 117636 117637 "verifying content: " 117638 (1) to: result size do: 117639 [:i | 117640 self assert: (collection at:(i + index ))=(result at: (i))]. 117641 117642 "verify size: " 117643 self assert: result size = (collection size - index).! ! 117644 117645!FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! 117646testCopyAfterEmpty 117647 | result | 117648 result := self empty copyAfter: self collectionWithoutEqualsElements first. 117649 self assert: result isEmpty. 117650 ! ! 117651 117652!FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! 117653testCopyAfterLast 117654 | result index collection | 117655 collection := self collectionWithoutEqualsElements . 117656 index:= self indexInForCollectionWithoutDuplicates . 117657 result := collection copyAfterLast: (collection at:index ). 117658 117659 "verifying content: " 117660 (1) to: result size do: 117661 [:i | 117662 self assert: (collection at:(i + index ))=(result at: (i))]. 117663 117664 "verify size: " 117665 self assert: result size = (collection size - index).! ! 117666 117667!FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! 117668testCopyAfterLastEmpty 117669 | result | 117670 result := self empty copyAfterLast: self collectionWithoutEqualsElements first. 117671 self assert: result isEmpty.! ! 117672 117673!FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! 117674testCopyEmptyMethod 117675 | result | 117676 result := self collectionWithoutEqualsElements copyEmpty . 117677 self assert: result isEmpty . 117678 self assert: result class= self nonEmpty class.! ! 117679 117680!FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! 117681testCopyFromTo 117682 | result index collection | 117683 collection := self collectionWithoutEqualsElements . 117684 index :=self indexInForCollectionWithoutDuplicates . 117685 result := collection copyFrom: index to: collection size . 117686 117687 "verify content of 'result' : " 117688 1 to: result size do: 117689 [:i | 117690 self assert: (result at:i)=(collection at: (i + index - 1))]. 117691 117692 "verify size of 'result' : " 117693 self assert: result size = (collection size - index + 1).! ! 117694 117695!FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! 117696testCopyUpTo 117697 | result index collection | 117698 collection := self collectionWithoutEqualsElements . 117699 index:= self indexInForCollectionWithoutDuplicates . 117700 result := collection copyUpTo: (collection at:index). 117701 117702 "verify content of 'result' :" 117703 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 117704 117705 "verify size of 'result' :" 117706 self assert: result size = (index-1). 117707 ! ! 117708 117709!FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! 117710testCopyUpToEmpty 117711 | result | 117712 result := self empty copyUpTo: self collectionWithoutEqualsElements first. 117713 self assert: result isEmpty. 117714 ! ! 117715 117716!FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! 117717testCopyUpToLast 117718 | result index collection | 117719 collection := self collectionWithoutEqualsElements . 117720 index:= self indexInForCollectionWithoutDuplicates . 117721 result := collection copyUpToLast: (collection at:index). 117722 117723 "verify content of 'result' :" 117724 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 117725 117726 "verify size of 'result' :" 117727 self assert: result size = (index-1).! ! 117728 117729!FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! 117730testCopyUpToLastEmpty 117731 | result | 117732 result := self empty copyUpToLast: self collectionWithoutEqualsElements first. 117733 self assert: result isEmpty.! ! 117734 117735 117736!FloatArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 117737testCopyAfterLastWithDuplicate 117738 | result element collection | 117739 collection := self collectionWithSameAtEndAndBegining . 117740 element := collection first. 117741 117742 " collectionWithSameAtEndAndBegining first and last elements are equals. 117743 'copyAfter:' should copy after the last occurence of element :" 117744 result := collection copyAfterLast: (element ). 117745 117746 "verifying content: " 117747 self assert: result isEmpty. 117748 117749! ! 117750 117751!FloatArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 117752testCopyAfterWithDuplicate 117753 | result element collection | 117754 collection := self collectionWithSameAtEndAndBegining . 117755 element := collection last. 117756 117757 " collectionWithSameAtEndAndBegining first and last elements are equals. 117758 'copyAfter:' should copy after the first occurence :" 117759 result := collection copyAfter: (element ). 117760 117761 "verifying content: " 117762 1 to: result size do: 117763 [:i | 117764 self assert: (collection at:(i + 1 )) = (result at: (i)) 117765 ]. 117766 117767 "verify size: " 117768 self assert: result size = (collection size - 1).! ! 117769 117770!FloatArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 117771testCopyUpToLastWithDuplicate 117772 | result element collection | 117773 collection := self collectionWithSameAtEndAndBegining . 117774 element := collection first. 117775 117776 " collectionWithSameAtEndAndBegining first and last elements are equals. 117777 'copyUpToLast:' should copy until the last occurence :" 117778 result := collection copyUpToLast: (element ). 117779 117780 "verifying content: " 117781 1 to: result size do: 117782 [:i | 117783 self assert: (result at: i ) = ( collection at: i ) 117784 ]. 117785 117786 self assert: result size = (collection size - 1). 117787 117788! ! 117789 117790!FloatArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 117791testCopyUpToWithDuplicate 117792 | result element collection | 117793 collection := self collectionWithSameAtEndAndBegining . 117794 element := collection last. 117795 117796 " collectionWithSameAtEndAndBegining first and last elements are equals. 117797 'copyUpTo:' should copy until the first occurence :" 117798 result := collection copyUpTo: (element ). 117799 117800 "verifying content: " 117801 self assert: result isEmpty. 117802 117803! ! 117804 117805 117806!FloatArrayTest methodsFor: 'tests - copying same contents'! 117807testReverse 117808 | result | 117809 result := self nonEmpty reverse . 117810 117811 "verify content of 'result: '" 117812 1 to: result size do: 117813 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 117814 "verify size of 'result' :" 117815 self assert: result size=self nonEmpty size.! ! 117816 117817!FloatArrayTest methodsFor: 'tests - copying same contents'! 117818testReversed 117819 | result | 117820 result := self nonEmpty reversed . 117821 117822 "verify content of 'result: '" 117823 1 to: result size do: 117824 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 117825 "verify size of 'result' :" 117826 self assert: result size=self nonEmpty size.! ! 117827 117828!FloatArrayTest methodsFor: 'tests - copying same contents'! 117829testShallowCopy 117830 | result | 117831 result := self nonEmpty shallowCopy . 117832 117833 "verify content of 'result: '" 117834 1 to: self nonEmpty size do: 117835 [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. 117836 "verify size of 'result' :" 117837 self assert: result size=self nonEmpty size.! ! 117838 117839!FloatArrayTest methodsFor: 'tests - copying same contents'! 117840testShallowCopyEmpty 117841 | result | 117842 result := self empty shallowCopy . 117843 self assert: result isEmpty .! ! 117844 117845!FloatArrayTest methodsFor: 'tests - copying same contents'! 117846testShuffled 117847 | result | 117848 result := self nonEmpty shuffled . 117849 117850 "verify content of 'result: '" 117851 result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. 117852 "verify size of 'result' :" 117853 self assert: result size=self nonEmpty size.! ! 117854 117855!FloatArrayTest methodsFor: 'tests - copying same contents'! 117856testSortBy 117857 " can only be used if the collection tested can include sortable elements :" 117858 | result tmp | 117859 self 117860 shouldnt: [ self collectionWithSortableElements ] 117861 raise: Error. 117862 self shouldnt: [self collectionWithSortableElements anyOne < self collectionWithSortableElements anyOne] raise: Error. 117863 result := self collectionWithSortableElements sortBy: [ :a :b | a < b ]. 117864 117865 "verify content of 'result' : " 117866 result do: 117867 [ :each | 117868 (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 117869 tmp := result first. 117870 result do: 117871 [ :each | 117872 self assert: each >= tmp. 117873 tmp := each ]. 117874 117875 "verify size of 'result' :" 117876 self assert: result size = self collectionWithSortableElements size! ! 117877 117878 117879!FloatArrayTest methodsFor: 'tests - copying with or without'! 117880testCopyWithFirst 117881 117882 | index element result | 117883 index:= self indexInNonEmpty . 117884 element:= self nonEmpty at: index. 117885 117886 result := self nonEmpty copyWithFirst: element. 117887 117888 self assert: result size = (self nonEmpty size + 1). 117889 self assert: result first = element . 117890 117891 2 to: result size do: 117892 [ :i | 117893 self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! 117894 117895!FloatArrayTest methodsFor: 'tests - copying with or without'! 117896testCopyWithSequenceable 117897 117898 | result index element | 117899 index := self indexInNonEmpty . 117900 element := self nonEmpty at: index. 117901 result := self nonEmpty copyWith: (element ). 117902 117903 self assert: result size = (self nonEmpty size + 1). 117904 self assert: result last = element . 117905 117906 1 to: (result size - 1) do: 117907 [ :i | 117908 self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! 117909 117910!FloatArrayTest methodsFor: 'tests - copying with or without'! 117911testCopyWithoutFirst 117912 117913 | result | 117914 result := self nonEmpty copyWithoutFirst. 117915 117916 self assert: result size = (self nonEmpty size - 1). 117917 117918 1 to: result size do: 117919 [:i | 117920 self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! 117921 117922!FloatArrayTest methodsFor: 'tests - copying with or without'! 117923testCopyWithoutIndex 117924 | result index | 117925 index := self indexInNonEmpty . 117926 result := self nonEmpty copyWithoutIndex: index . 117927 117928 "verify content of 'result:'" 117929 1 to: result size do: 117930 [:i | 117931 i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. 117932 i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. 117933 117934 "verify size of result : " 117935 self assert: result size=(self nonEmpty size -1).! ! 117936 117937!FloatArrayTest methodsFor: 'tests - copying with or without'! 117938testForceToPaddingStartWith 117939 117940 | result element | 117941 element := self nonEmpty at: self indexInNonEmpty . 117942 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). 117943 117944 "verify content of 'result' : " 117945 1 to: 2 do: 117946 [:i | self assert: ( element ) = ( result at:(i) ) ]. 117947 117948 3 to: result size do: 117949 [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. 117950 117951 "verify size of 'result' :" 117952 self assert: result size = (self nonEmpty size + 2).! ! 117953 117954!FloatArrayTest methodsFor: 'tests - copying with or without'! 117955testForceToPaddingWith 117956 117957 | result element | 117958 element := self nonEmpty at: self indexInNonEmpty . 117959 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). 117960 117961 "verify content of 'result' : " 117962 1 to: self nonEmpty size do: 117963 [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. 117964 117965 (result size - 1) to: result size do: 117966 [:i | self assert: ( result at:i ) = ( element ) ]. 117967 117968 "verify size of 'result' :" 117969 self assert: result size = (self nonEmpty size + 2).! ! 117970 117971 117972!FloatArrayTest methodsFor: 'tests - copying with replacement'! 117973firstIndexesOf: subCollection in: collection 117974" return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " 117975 | tmp result currentIndex | 117976 tmp:= collection. 117977 result:= OrderedCollection new. 117978 currentIndex := 1. 117979 117980 [tmp isEmpty ]whileFalse: 117981 [ 117982 (tmp beginsWith: subCollection) 117983 ifTrue: [ 117984 result add: currentIndex. 117985 1 to: subCollection size do: 117986 [:i | 117987 tmp := tmp copyWithoutFirst. 117988 currentIndex := currentIndex + 1] 117989 ] 117990 ifFalse: [ 117991 tmp := tmp copyWithoutFirst. 117992 currentIndex := currentIndex +1. 117993 ] 117994 ]. 117995 117996 ^ result. 117997 ! ! 117998 117999!FloatArrayTest methodsFor: 'tests - copying with replacement'! 118000testCopyReplaceAllWith1Occurence 118001 | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | 118002 118003 result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 118004 118005 "detecting indexes of olSubCollection" 118006 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . 118007 index:= firstIndexesOfOccurrence at: 1. 118008 118009 "verify content of 'result' : " 118010 "first part of 'result'' : '" 118011 118012 1 to: (index -1) do: 118013 [ 118014 :i | 118015 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 118016 ]. 118017 118018 " middle part containing replacementCollection : " 118019 118020 index to: (index + self replacementCollection size-1) do: 118021 [ 118022 :i | 118023 self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) 118024 ]. 118025 118026 " end part :" 118027 118028 endPartIndexResult := index + self replacementCollection size . 118029 endPartIndexCollection := index + self oldSubCollection size . 118030 118031 1 to: (result size - endPartIndexResult - 1 ) do: 118032 [ 118033 :i | 118034 self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). 118035 ]. 118036 118037 118038 ! ! 118039 118040!FloatArrayTest methodsFor: 'tests - copying with replacement'! 118041testCopyReplaceAllWithManyOccurence 118042 | result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff | 118043 " testing fixture here as this method may be not used for collection that can't contain equals element :" 118044 self shouldnt: [self collectionWith2TimeSubcollection ]raise: Error. 118045 self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection ) = 2. 118046 118047 " test :" 118048 diff := self replacementCollection size - self oldSubCollection size. 118049 result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 118050 118051 "detecting indexes of olSubCollection" 118052 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection . 118053 118054 " verifying that replacementCollection has been put in places of oldSubCollections " 118055 firstIndexesOfOccurrence do: [ 118056 :each | 118057 (firstIndexesOfOccurrence indexOf: each) = 1 118058 ifTrue: [ 118059 each to: self replacementCollection size do: 118060 [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. 118061 ] 118062 ifFalse:[ 118063 (each + diff) to: self replacementCollection size do: 118064 [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. 118065 ]. 118066 118067 ]. 118068 118069 " verifying that the 'between' parts correspond to the initial collection : " 118070 1 to: firstIndexesOfOccurrence size do: [ 118071 :i | 118072 i = 1 118073 " specific comportement for the begining of the collection :" 118074 ifTrue: [ 118075 1 to: ((firstIndexesOfOccurrence at: i) - 1 ) do: 118076 [ :j | 118077 self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] 118078 ] 118079 " between parts till the end : " 118080 ifFalse: [ 118081 resultBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self replacementCollection size. 118082 collectionBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self oldSubCollection size. 118083 118084 1 to: ( firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: 118085 [ :j | 118086 self assert: (result at: (resultBetweenPartIndex + i - 1)) = (self collectionWith2TimeSubcollection at: (collectionBetweenPartIndex +i - 1)) ] 118087 ] 118088 ]. 118089 118090 "final part :" 118091 1 to: (self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size ) ) do: 118092 [ 118093 :i | 118094 self assert: ( result at:(firstIndexesOfOccurrence last + self replacementCollection size -1) + i ) = ( self collectionWith2TimeSubcollection at:(firstIndexesOfOccurrence last + self oldSubCollection size -1) + i ) . 118095 ]! ! 118096 118097!FloatArrayTest methodsFor: 'tests - copying with replacement'! 118098testCopyReplaceFromToWith 118099 | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | 118100 118101 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 118102 lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. 118103 lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. 118104 118105 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . 118106 118107 "verify content of 'result' : " 118108 "first part of 'result' " 118109 118110 1 to: (indexOfSubcollection - 1) do: 118111 [ 118112 :i | 118113 self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) 118114 ]. 118115 118116 " middle part containing replacementCollection : " 118117 118118 (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: 118119 [ 118120 :i | 118121 self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) 118122 ]. 118123 118124 " end part :" 118125 1 to: (result size - lastIndexOfReplacementCollection ) do: 118126 [ 118127 :i | 118128 self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). 118129 ]. 118130 118131 118132 118133 118134 118135 ! ! 118136 118137!FloatArrayTest methodsFor: 'tests - copying with replacement'! 118138testCopyReplaceFromToWithInsertion 118139 | result indexOfSubcollection | 118140 118141 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 118142 118143 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . 118144 118145 "verify content of 'result' : " 118146 "first part of 'result'' : '" 118147 118148 1 to: (indexOfSubcollection -1) do: 118149 [ 118150 :i | 118151 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 118152 ]. 118153 118154 " middle part containing replacementCollection : " 118155 indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: 118156 [ 118157 :i | 118158 self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) 118159 ]. 118160 118161 " end part :" 118162 (indexOfSubcollection + self replacementCollection size) to: (result size) do: 118163 [:i| 118164 self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. 118165 118166 " verify size: " 118167 self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). 118168 118169 118170 118171 118172 118173 ! ! 118174 118175 118176!FloatArrayTest methodsFor: 'tests - element accessing'! 118177testAfter 118178 "self debug: #testAfter" 118179 self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). 118180 self 118181 should: 118182 [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] 118183 raise: Error. 118184 self 118185 should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] 118186 raise: Error! ! 118187 118188!FloatArrayTest methodsFor: 'tests - element accessing'! 118189testAfterIfAbsent 118190 "self debug: #testAfterIfAbsent" 118191 self assert: (self moreThan4Elements 118192 after: (self moreThan4Elements at: 1) 118193 ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). 118194 self assert: (self moreThan4Elements 118195 after: (self moreThan4Elements at: self moreThan4Elements size) 118196 ifAbsent: [ 33 ]) == 33. 118197 self assert: (self moreThan4Elements 118198 after: self elementNotInForElementAccessing 118199 ifAbsent: [ 33 ]) = 33! ! 118200 118201!FloatArrayTest methodsFor: 'tests - element accessing'! 118202testAt 118203 "self debug: #testAt" 118204 " 118205 self assert: (self accessCollection at: 1) = 1. 118206 self assert: (self accessCollection at: 2) = 2. 118207 " 118208 | index | 118209 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 118210 self assert: (self moreThan4Elements at: index) = self elementInForElementAccessing! ! 118211 118212!FloatArrayTest methodsFor: 'tests - element accessing'! 118213testAtAll 118214 "self debug: #testAtAll" 118215 " self flag: #theCollectionshouldbe102030intheFixture. 118216 118217 self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. 118218 self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." 118219 | result | 118220 result := self moreThan4Elements atAll: #(2 1 2 ). 118221 self assert: (result at: 1) = (self moreThan4Elements at: 2). 118222 self assert: (result at: 2) = (self moreThan4Elements at: 1). 118223 self assert: (result at: 3) = (self moreThan4Elements at: 2). 118224 self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! 118225 118226!FloatArrayTest methodsFor: 'tests - element accessing'! 118227testAtIfAbsent 118228 "self debug: #testAt" 118229 | absent | 118230 absent := false. 118231 self moreThan4Elements 118232 at: self moreThan4Elements size + 1 118233 ifAbsent: [ absent := true ]. 118234 self assert: absent = true. 118235 absent := false. 118236 self moreThan4Elements 118237 at: self moreThan4Elements size 118238 ifAbsent: [ absent := true ]. 118239 self assert: absent = false! ! 118240 118241!FloatArrayTest methodsFor: 'tests - element accessing'! 118242testAtLast 118243 "self debug: #testAtLast" 118244 | index | 118245 self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. 118246 "tmp:=1. 118247 self do: 118248 [:each | 118249 each =self elementInForIndexAccessing 118250 ifTrue:[index:=tmp]. 118251 tmp:=tmp+1]." 118252 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 118253 self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! 118254 118255!FloatArrayTest methodsFor: 'tests - element accessing'! 118256testAtLastError 118257 "self debug: #testAtLast" 118258 self 118259 should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] 118260 raise: Error! ! 118261 118262!FloatArrayTest methodsFor: 'tests - element accessing'! 118263testAtLastIfAbsent 118264 "self debug: #testAtLastIfAbsent" 118265 self assert: (self moreThan4Elements 118266 atLast: 1 118267 ifAbsent: [ nil ]) = self moreThan4Elements last. 118268 self assert: (self moreThan4Elements 118269 atLast: self moreThan4Elements size + 1 118270 ifAbsent: [ 222 ]) = 222! ! 118271 118272!FloatArrayTest methodsFor: 'tests - element accessing'! 118273testAtOutOfBounds 118274 "self debug: #testAtOutOfBounds" 118275 self 118276 should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] 118277 raise: Error. 118278 self 118279 should: [ self moreThan4Elements at: -1 ] 118280 raise: Error! ! 118281 118282!FloatArrayTest methodsFor: 'tests - element accessing'! 118283testAtPin 118284 "self debug: #testAtPin" 118285 self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. 118286 self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. 118287 self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! 118288 118289!FloatArrayTest methodsFor: 'tests - element accessing'! 118290testAtRandom 118291 | result | 118292 result := self nonEmpty atRandom . 118293 self assert: (self nonEmpty includes: result).! ! 118294 118295!FloatArrayTest methodsFor: 'tests - element accessing'! 118296testAtWrap 118297 "self debug: #testAt" 118298 " 118299 self assert: (self accessCollection at: 1) = 1. 118300 self assert: (self accessCollection at: 2) = 2. 118301 " 118302 | index | 118303 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 118304 self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. 118305 self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. 118306 self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. 118307 self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! 118308 118309!FloatArrayTest methodsFor: 'tests - element accessing'! 118310testBefore 118311 "self debug: #testBefore" 118312 self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). 118313 self 118314 should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] 118315 raise: Error. 118316 self 118317 should: [ self moreThan4Elements before: 66 ] 118318 raise: Error! ! 118319 118320!FloatArrayTest methodsFor: 'tests - element accessing'! 118321testBeforeIfAbsent 118322 "self debug: #testBefore" 118323 self assert: (self moreThan4Elements 118324 before: (self moreThan4Elements at: 1) 118325 ifAbsent: [ 99 ]) = 99. 118326 self assert: (self moreThan4Elements 118327 before: (self moreThan4Elements at: 2) 118328 ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! 118329 118330!FloatArrayTest methodsFor: 'tests - element accessing'! 118331testFirstSecondThird 118332 "self debug: #testFirstSecondThird" 118333 self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). 118334 self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). 118335 self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). 118336 self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! 118337 118338!FloatArrayTest methodsFor: 'tests - element accessing'! 118339testLast 118340 "self debug: #testLast" 118341 self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! 118342 118343!FloatArrayTest methodsFor: 'tests - element accessing'! 118344testMiddle 118345 "self debug: #testMiddle" 118346 self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! 118347 118348 118349!FloatArrayTest methodsFor: 'tests - empty'! 118350testIfEmpty 118351 118352 self nonEmpty ifEmpty: [ self assert: false] . 118353 self empty ifEmpty: [ self assert: true] . 118354 118355 118356 ! ! 118357 118358!FloatArrayTest methodsFor: 'tests - empty'! 118359testIfEmptyifNotEmpty 118360 118361 self assert: (self empty ifEmpty: [true] ifNotEmpty: [false]). 118362 self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [true]). 118363 ! ! 118364 118365!FloatArrayTest methodsFor: 'tests - empty'! 118366testIfEmptyifNotEmptyDo 118367 "self debug #testIfEmptyifNotEmptyDo" 118368 118369 self assert: (self empty ifEmpty: [true] ifNotEmptyDo: [:s | false]). 118370 self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | true]). 118371 self assert: (self nonEmpty 118372 ifEmpty: [false] 118373 ifNotEmptyDo: [:s | s]) == self nonEmpty.! ! 118374 118375!FloatArrayTest methodsFor: 'tests - empty'! 118376testIfNotEmpty 118377 118378 self empty ifNotEmpty: [self assert: false]. 118379 self nonEmpty ifNotEmpty: [self assert: true]. 118380 self assert: (self nonEmpty ifNotEmpty: [:s | s ]) = self nonEmpty 118381 ! ! 118382 118383!FloatArrayTest methodsFor: 'tests - empty'! 118384testIfNotEmptyDo 118385 118386 self empty ifNotEmptyDo: [:s | self assert: false]. 118387 self assert: (self nonEmpty ifNotEmptyDo: [:s | s]) == self nonEmpty 118388! ! 118389 118390!FloatArrayTest methodsFor: 'tests - empty'! 118391testIfNotEmptyDoifNotEmpty 118392 118393 self assert: (self empty ifNotEmptyDo: [:s | false] ifEmpty: [true]). 118394 self assert: (self nonEmpty 118395 ifNotEmptyDo: [:s | s] 118396 ifEmpty: [false]) == self nonEmpty! ! 118397 118398!FloatArrayTest methodsFor: 'tests - empty'! 118399testIfNotEmptyifEmpty 118400 118401 self assert: (self empty ifNotEmpty: [false] ifEmpty: [true]). 118402 self assert: (self nonEmpty ifNotEmpty: [true] ifEmpty: [false]). 118403 ! ! 118404 118405!FloatArrayTest methodsFor: 'tests - empty'! 118406testIsEmpty 118407 118408 self assert: (self empty isEmpty). 118409 self deny: (self nonEmpty isEmpty).! ! 118410 118411!FloatArrayTest methodsFor: 'tests - empty'! 118412testIsEmptyOrNil 118413 118414 self assert: (self empty isEmptyOrNil). 118415 self deny: (self nonEmpty isEmptyOrNil).! ! 118416 118417!FloatArrayTest methodsFor: 'tests - empty'! 118418testNotEmpty 118419 118420 self assert: (self nonEmpty notEmpty). 118421 self deny: (self empty notEmpty).! ! 118422 118423 118424!FloatArrayTest methodsFor: 'tests - equality'! 118425testEqualSignForSequenceableCollections 118426 "self debug: #testEqualSign" 118427 118428 self deny: (self nonEmpty = self nonEmpty asSet). 118429 self deny: (self nonEmpty reversed = self nonEmpty). 118430 self deny: (self nonEmpty = self nonEmpty reversed).! ! 118431 118432!FloatArrayTest methodsFor: 'tests - equality'! 118433testHasEqualElements 118434 "self debug: #testHasEqualElements" 118435 118436 self deny: (self empty hasEqualElements: self nonEmpty). 118437 self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). 118438 self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). 118439 self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! 118440 118441!FloatArrayTest methodsFor: 'tests - equality'! 118442testHasEqualElementsIsTrueForNonIdenticalButEqualCollections 118443 "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" 118444 118445 self assert: (self empty hasEqualElements: self empty copy). 118446 self assert: (self empty copy hasEqualElements: self empty). 118447 self assert: (self empty copy hasEqualElements: self empty copy). 118448 118449 self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). 118450 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). 118451 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! 118452 118453!FloatArrayTest methodsFor: 'tests - equality'! 118454testHasEqualElementsOfIdenticalCollectionObjects 118455 "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" 118456 118457 self assert: (self empty hasEqualElements: self empty). 118458 self assert: (self nonEmpty hasEqualElements: self nonEmpty). 118459 ! ! 118460 118461 118462!FloatArrayTest methodsFor: 'tests - fixture'! 118463howMany: subCollection in: collection 118464" return an integer representing how many time 'subCollection' appears in 'collection' " 118465 | tmp nTime | 118466 tmp:= collection. 118467 nTime:= 0. 118468 118469 [tmp isEmpty ]whileFalse: 118470 [ 118471 (tmp beginsWith: subCollection) 118472 ifTrue: [ 118473 nTime := nTime + 1. 118474 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] 118475 ] 118476 ifFalse: [tmp := tmp copyWithoutFirst.] 118477 ]. 118478 118479 ^ nTime. 118480 ! ! 118481 118482!FloatArrayTest methodsFor: 'tests - fixture'! 118483test0CopyTest 118484 self shouldnt: [ self empty ]raise: Error. 118485 self assert: self empty size = 0. 118486 self shouldnt: [ self nonEmpty ]raise: Error. 118487 self assert: (self nonEmpty size = 0) not. 118488 self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. 118489 self assert: (self collectionWithElementsToRemove size = 0) not. 118490 self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. 118491 118492 self shouldnt: [ self elementToAdd ]raise: Error. 118493 self deny: (self nonEmpty includes: self elementToAdd ). 118494 self shouldnt: [ self collectionNotIncluded ]raise: Error. 118495 self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! 118496 118497!FloatArrayTest methodsFor: 'tests - fixture'! 118498test0FixtureAsSetForIdentityMultiplinessTest 118499 118500 "a collection (of elements for which copy is not identical ) without equal elements:" 118501 | element res | 118502 self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ]raise: Error. 118503 element := self elementsCopyNonIdenticalWithoutEqualElements anyOne. 118504 self deny: element copy == element . 118505 118506 res := true. 118507 self elementsCopyNonIdenticalWithoutEqualElements 118508 detect: 118509 [ :each | 118510 (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] 118511 ifNone: [ res := false ]. 118512 self assert: res = false 118513 118514 ! ! 118515 118516!FloatArrayTest methodsFor: 'tests - fixture'! 118517test0FixtureAsStringCommaAndDelimiterTest 118518 118519 self shouldnt: [self nonEmpty] raise:Error . 118520 self deny: self nonEmpty isEmpty. 118521 118522 self shouldnt: [self empty] raise:Error . 118523 self assert: self empty isEmpty. 118524 118525 self shouldnt: [self nonEmpty1Element ] raise:Error . 118526 self assert: self nonEmpty1Element size=1.! ! 118527 118528!FloatArrayTest methodsFor: 'tests - fixture'! 118529test0FixtureBeginsEndsWithTest 118530 118531 self shouldnt: [self nonEmpty ] raise: Error. 118532 self deny: self nonEmpty isEmpty. 118533 self assert: self nonEmpty size>1. 118534 118535 self shouldnt: [self empty ] raise: Error. 118536 self assert: self empty isEmpty.! ! 118537 118538!FloatArrayTest methodsFor: 'tests - fixture'! 118539test0FixtureCloneTest 118540 118541self shouldnt: [ self nonEmpty ] raise: Error. 118542self deny: self nonEmpty isEmpty. 118543 118544self shouldnt: [ self empty ] raise: Error. 118545self assert: self empty isEmpty. 118546 118547! ! 118548 118549!FloatArrayTest methodsFor: 'tests - fixture'! 118550test0FixtureConverAsSortedTest 118551 118552 self shouldnt: [self collectionWithSortableElements ] raise: Error. 118553 self deny: self collectionWithSortableElements isEmpty .! ! 118554 118555!FloatArrayTest methodsFor: 'tests - fixture'! 118556test0FixtureCopyPartOfForMultipliness 118557 118558self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. 118559 118560self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 118561 118562self assert: self collectionWithSameAtEndAndBegining size > 1. 118563 1185641 to: self collectionWithSameAtEndAndBegining size do: 118565 [:i | 118566 (i > 1 ) & (i < self collectionWithSameAtEndAndBegining size) 118567 ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at:i) = (self collectionWithSameAtEndAndBegining first)]. 118568 ]! ! 118569 118570!FloatArrayTest methodsFor: 'tests - fixture'! 118571test0FixtureCopyPartOfSequenceableTest 118572 118573 self shouldnt: [self collectionWithoutEqualsElements ] raise: Error. 118574 self collectionWithoutEqualsElements do: 118575 [:each | self assert: (self collectionWithoutEqualsElements occurrencesOf: each)=1]. 118576 118577 self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. 118578 self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualsElements size. 118579 118580 self shouldnt: [self empty] raise: Error. 118581 self assert: self empty isEmpty .! ! 118582 118583!FloatArrayTest methodsFor: 'tests - fixture'! 118584test0FixtureCopySameContentsTest 118585 118586 self shouldnt: [self nonEmpty ] raise: Error. 118587 self deny: self nonEmpty isEmpty. 118588 118589 self shouldnt: [self empty ] raise: Error. 118590 self assert: self empty isEmpty. 118591 118592! ! 118593 118594!FloatArrayTest methodsFor: 'tests - fixture'! 118595test0FixtureCopyWithOrWithoutSpecificElementsTest 118596 118597 self shouldnt: [self nonEmpty ] raise: Error. 118598 self deny: self nonEmpty isEmpty . 118599 118600 self shouldnt: [self indexInNonEmpty ] raise: Error. 118601 self assert: self indexInNonEmpty > 0. 118602 self assert: self indexInNonEmpty <= self nonEmpty size.! ! 118603 118604!FloatArrayTest methodsFor: 'tests - fixture'! 118605test0FixtureCopyWithReplacementTest 118606 118607 self shouldnt: [self replacementCollection ]raise: Error. 118608 self shouldnt: [self oldSubCollection] raise: Error. 118609 118610 self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. 118611 self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. 118612 118613 ! ! 118614 118615!FloatArrayTest methodsFor: 'tests - fixture'! 118616test0FixtureCreationWithTest 118617 118618self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. 118619self assert: self collectionMoreThan5Elements size >= 5.! ! 118620 118621!FloatArrayTest methodsFor: 'tests - fixture'! 118622test0FixtureEmptyTest 118623 118624self shouldnt: [ self nonEmpty ] raise: Error. 118625self deny: self nonEmpty isEmpty. 118626 118627self shouldnt: [ self empty ] raise: Error. 118628self assert: self empty isEmpty.! ! 118629 118630!FloatArrayTest methodsFor: 'tests - fixture'! 118631test0FixtureIncludeTest 118632 | elementIn | 118633 self shouldnt: [ self nonEmpty ]raise: Error. 118634 self deny: self nonEmpty isEmpty. 118635 118636 self shouldnt: [ self elementNotIn ]raise: Error. 118637 118638 elementIn := true. 118639 self nonEmpty detect: 118640 [ :each | each = self elementNotIn ] 118641 ifNone: [ elementIn := false ]. 118642 self assert: elementIn = false. 118643 118644 self shouldnt: [ self anotherElementNotIn ]raise: Error. 118645 118646 elementIn := true. 118647 self nonEmpty detect: 118648 [ :each | each = self anotherElementNotIn ] 118649 ifNone: [ elementIn := false ]. 118650 self assert: elementIn = false. 118651 118652 self shouldnt: [ self empty ] raise: Error. 118653 self assert: self empty isEmpty. 118654 118655! ! 118656 118657!FloatArrayTest methodsFor: 'tests - fixture'! 118658test0FixtureIncludeWithIdentityTest 118659 | element | 118660 self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. 118661 element := self collectionWithCopyNonIdentical anyOne. 118662 self deny: element == element copy. 118663! ! 118664 118665!FloatArrayTest methodsFor: 'tests - fixture'! 118666test0FixtureIndexAccessFotMultipliness 118667 self 118668 shouldnt: [ self collectionWithSameAtEndAndBegining ] 118669 raise: Error. 118670 self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 118671 self assert: self collectionWithSameAtEndAndBegining size > 1. 118672 1 to: self collectionWithSameAtEndAndBegining size 118673 do: 118674 [ :i | 118675 i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: 118676 [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! 118677 118678!FloatArrayTest methodsFor: 'tests - fixture'! 118679test0FixtureIndexAccessTest 118680 | res collection element | 118681 self 118682 shouldnt: [ self collectionMoreThan1NoDuplicates ] 118683 raise: Error. 118684 self assert: self collectionMoreThan1NoDuplicates size >1. 118685 res := true. 118686 self collectionMoreThan1NoDuplicates 118687 detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] 118688 ifNone: [ res := false ]. 118689 self assert: res = false. 118690 self 118691 shouldnt: [ self elementInForIndexAccessing ] 118692 raise: Error. 118693 self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). 118694 self 118695 shouldnt: [ self elementNotInForIndexAccessing ] 118696 raise: Error. 118697 self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! 118698 118699!FloatArrayTest methodsFor: 'tests - fixture'! 118700test0FixtureIterateSequencedReadableTest 118701 118702 | res | 118703 118704 self shouldnt: self nonEmptyMoreThan1Element raise: Error. 118705 self assert: self nonEmptyMoreThan1Element size > 1. 118706 118707 118708 self shouldnt: self empty raise: Error. 118709 self assert: self empty isEmpty . 118710 118711 res := true. 118712 self nonEmptyMoreThan1Element 118713 detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] 118714 ifNone: [ res := false ]. 118715 self assert: res = false.! ! 118716 118717!FloatArrayTest methodsFor: 'tests - fixture'! 118718test0FixturePrintTest 118719 118720 self shouldnt: [self nonEmpty ] raise: Error.! ! 118721 118722!FloatArrayTest methodsFor: 'tests - fixture'! 118723test0FixturePutOneOrMoreElementsTest 118724 self shouldnt: self aValue raise: Error. 118725 118726 118727 self shouldnt: self indexArray raise: Error. 118728 self indexArray do: [ 118729 :each| 118730 self assert: each class = SmallInteger. 118731 self assert: (each>=1 & each<= self nonEmpty size). 118732 ]. 118733 118734 self assert: self indexArray size = self valueArray size. 118735 118736 self shouldnt: self empty raise: Error. 118737 self assert: self empty isEmpty . 118738 118739 self shouldnt: self nonEmpty raise: Error. 118740 self deny: self nonEmpty isEmpty.! ! 118741 118742!FloatArrayTest methodsFor: 'tests - fixture'! 118743test0FixturePutTest 118744 self shouldnt: self aValue raise: Error. 118745 self shouldnt: self anotherValue raise: Error. 118746 118747 self shouldnt: self anIndex raise: Error. 118748 self nonEmpty isDictionary 118749 ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. 118750 118751 self shouldnt: self empty raise: Error. 118752 self assert: self empty isEmpty . 118753 118754 self shouldnt: self nonEmpty raise: Error. 118755 self deny: self nonEmpty isEmpty.! ! 118756 118757!FloatArrayTest methodsFor: 'tests - fixture'! 118758test0FixtureSequencedConcatenationTest 118759 self 118760 shouldnt: self empty 118761 raise: Exception. 118762 self assert: self empty isEmpty. 118763 self 118764 shouldnt: self firstCollection 118765 raise: Exception. 118766 self 118767 shouldnt: self secondCollection 118768 raise: Exception! ! 118769 118770!FloatArrayTest methodsFor: 'tests - fixture'! 118771test0FixtureSequencedElementAccessTest 118772 self 118773 shouldnt: [ self moreThan4Elements ] 118774 raise: Error. 118775 self assert: self moreThan4Elements size >= 4. 118776 self 118777 shouldnt: [ self subCollectionNotIn ] 118778 raise: Error. 118779 self subCollectionNotIn 118780 detect: [ :each | (self moreThan4Elements includes: each) not ] 118781 ifNone: [ self assert: false ]. 118782 self 118783 shouldnt: [ self elementNotInForElementAccessing ] 118784 raise: Error. 118785 self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). 118786 self 118787 shouldnt: [ self elementInForElementAccessing ] 118788 raise: Error. 118789 self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! 118790 118791!FloatArrayTest methodsFor: 'tests - fixture'! 118792test0FixtureSetAritmeticTest 118793 self 118794 shouldnt: [ self collection ] 118795 raise: Error. 118796 self deny: self collection isEmpty. 118797 self 118798 shouldnt: [ self nonEmpty ] 118799 raise: Error. 118800 self deny: self nonEmpty isEmpty. 118801 self 118802 shouldnt: [ self anotherElementOrAssociationNotIn ] 118803 raise: Error. 118804 self collection isDictionary 118805 ifTrue: 118806 [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] 118807 ifFalse: 118808 [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. 118809 self 118810 shouldnt: [ self collectionClass ] 118811 raise: Error! ! 118812 118813!FloatArrayTest methodsFor: 'tests - fixture'! 118814test0FixtureSubcollectionAccessTest 118815 self 118816 shouldnt: [ self moreThan3Elements ] 118817 raise: Error. 118818 self assert: self moreThan3Elements size > 2! ! 118819 118820!FloatArrayTest methodsFor: 'tests - fixture'! 118821test0FixtureTConvertAsSetForMultiplinessTest 118822 "a collection with equal elements:" 118823 | res | 118824 self shouldnt: [ self withEqualElements] raise: Error. 118825 118826 res := true. 118827 self withEqualElements 118828 detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] 118829 ifNone: [ res := false ]. 118830 self assert: res = true. 118831 118832! ! 118833 118834!FloatArrayTest methodsFor: 'tests - fixture'! 118835test0FixtureTConvertTest 118836 "a collection of number without equal elements:" 118837 | res | 118838 self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. 118839 118840 res := true. 118841 self collectionWithoutEqualElements 118842 detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] 118843 ifNone: [ res := false ]. 118844 self assert: res = false. 118845 118846 118847! ! 118848 118849!FloatArrayTest methodsFor: 'tests - fixture'! 118850test0SortingArrayedTest 118851 | tmp sorted | 118852 " an unsorted collection of number " 118853 self shouldnt: [ self unsortedCollection ]raise: Error. 118854 self unsortedCollection do:[:each | each isNumber]. 118855 sorted := true. 118856 self unsortedCollection pairsDo: [ 118857 :each1 :each2 | 118858 each2 < each1 ifTrue: [ sorted := false]. 118859 ]. 118860 self assert: sorted = false. 118861 118862 118863 118864 " a collection of number sorted in an ascending order" 118865 self shouldnt: [ self sortedInAscendingOrderCollection ]raise: Error. 118866 self sortedInAscendingOrderCollection do:[:each | each isNumber]. 118867 tmp:= self sortedInAscendingOrderCollection at:1. 118868 self sortedInAscendingOrderCollection do: 118869 [: each | self assert: (each>= tmp). tmp:=each] 118870 ! ! 118871 118872!FloatArrayTest methodsFor: 'tests - fixture'! 118873test0TSequencedStructuralEqualityTest 118874 118875 self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! 118876 118877!FloatArrayTest methodsFor: 'tests - fixture'! 118878test0TStructuralEqualityTest 118879 self shouldnt: [self empty] raise: Error. 118880 self shouldnt: [self nonEmpty] raise: Error. 118881 self assert: self empty isEmpty. 118882 self deny: self nonEmpty isEmpty.! ! 118883 118884!FloatArrayTest methodsFor: 'tests - fixture'! 118885testOFixtureReplacementSequencedTest 118886 118887 self shouldnt: self nonEmpty raise: Error. 118888 self deny: self nonEmpty isEmpty. 118889 118890 self shouldnt: self elementInForReplacement raise: Error. 118891 self assert: (self nonEmpty includes: self elementInForReplacement ) . 118892 118893 self shouldnt: self newElement raise: Error. 118894 118895 self shouldnt: self firstIndex raise: Error. 118896 self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). 118897 118898 self shouldnt: self secondIndex raise: Error. 118899 self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). 118900 118901 self assert: self firstIndex <=self secondIndex . 118902 118903 self shouldnt: self replacementCollection raise: Error. 118904 118905 self shouldnt: self replacementCollectionSameSize raise: Error. 118906 self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size 118907 ! ! 118908 118909 118910!FloatArrayTest methodsFor: 'tests - includes'! 118911testIncludesAllOfAllThere 118912 "self debug: #testIncludesAllOfAllThere'" 118913 self assert: (self empty includesAllOf: self empty). 118914 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 118915 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 118916 118917!FloatArrayTest methodsFor: 'tests - includes'! 118918testIncludesAllOfNoneThere 118919 "self debug: #testIncludesAllOfNoneThere'" 118920 self deny: (self empty includesAllOf: self nonEmpty ). 118921 self deny: (self nonEmpty includesAllOf: { self elementNotIn. self anotherElementNotIn })! ! 118922 118923!FloatArrayTest methodsFor: 'tests - includes'! 118924testIncludesAnyOfAllThere 118925 "self debug: #testIncludesAnyOfAllThere'" 118926 self deny: (self nonEmpty includesAnyOf: self empty). 118927 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 118928 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 118929 118930!FloatArrayTest methodsFor: 'tests - includes'! 118931testIncludesAnyOfNoneThere 118932 "self debug: #testIncludesAnyOfNoneThere'" 118933 self deny: (self nonEmpty includesAnyOf: self empty). 118934 self deny: (self nonEmpty includesAnyOf: { self elementNotIn. self anotherElementNotIn })! ! 118935 118936!FloatArrayTest methodsFor: 'tests - includes'! 118937testIncludesElementIsNotThere 118938 "self debug: #testIncludesElementIsNotThere" 118939 118940 self deny: (self nonEmpty includes: self elementNotIn). 118941 self assert: (self nonEmpty includes: self nonEmpty anyOne). 118942 self deny: (self empty includes: self elementNotIn)! ! 118943 118944!FloatArrayTest methodsFor: 'tests - includes'! 118945testIncludesElementIsThere 118946 "self debug: #testIncludesElementIsThere" 118947 118948 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 118949 118950 118951!FloatArrayTest methodsFor: 'tests - including with identity'! 118952testIdentityIncludes 118953 " test the comportement in presence of elements 'includes' but not 'identityIncludes' " 118954 " can not be used by collections that can't include elements for wich copy doesn't return another instance " 118955 | collection element | 118956 118957 collection := self collectionWithCopyNonIdentical. 118958 element := collection anyOne copy. 118959 118960 self deny: (collection identityIncludes: element)! ! 118961 118962 118963!FloatArrayTest methodsFor: 'tests - index access'! 118964testIndexOf 118965 "self debug: #testIndexOf" 118966 | tmp index collection | 118967 collection := self collectionMoreThan1NoDuplicates. 118968 tmp := collection size. 118969 collection reverseDo: 118970 [ :each | 118971 each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. 118972 tmp := tmp - 1 ]. 118973 self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! 118974 118975!FloatArrayTest methodsFor: 'tests - index access'! 118976testIndexOfIfAbsent 118977 "self debug: #testIndexOfIfAbsent" 118978 | collection | 118979 collection := self collectionMoreThan1NoDuplicates. 118980 self assert: (collection 118981 indexOf: collection first 118982 ifAbsent: [ 33 ]) = 1. 118983 self assert: (collection 118984 indexOf: self elementNotInForIndexAccessing 118985 ifAbsent: [ 33 ]) = 33! ! 118986 118987!FloatArrayTest methodsFor: 'tests - index access'! 118988testIndexOfStartingAt 118989 "self debug: #testLastIndexOf" 118990 | element collection | 118991 collection := self collectionMoreThan1NoDuplicates. 118992 element := collection first. 118993 self assert: (collection 118994 indexOf: element 118995 startingAt: 2 118996 ifAbsent: [ 99 ]) = 99. 118997 self assert: (collection 118998 indexOf: element 118999 startingAt: 1 119000 ifAbsent: [ 99 ]) = 1. 119001 self assert: (collection 119002 indexOf: self elementNotInForIndexAccessing 119003 startingAt: 1 119004 ifAbsent: [ 99 ]) = 99! ! 119005 119006!FloatArrayTest methodsFor: 'tests - index access'! 119007testIndexOfStartingAtIfAbsent 119008 "self debug: #testLastIndexOf" 119009 | element collection | 119010 collection := self collectionMoreThan1NoDuplicates. 119011 element := collection first. 119012 self assert: (collection 119013 indexOf: element 119014 startingAt: 2 119015 ifAbsent: [ 99 ]) = 99. 119016 self assert: (collection 119017 indexOf: element 119018 startingAt: 1 119019 ifAbsent: [ 99 ]) = 1. 119020 self assert: (collection 119021 indexOf: self elementNotInForIndexAccessing 119022 startingAt: 1 119023 ifAbsent: [ 99 ]) = 99! ! 119024 119025!FloatArrayTest methodsFor: 'tests - index access'! 119026testIndexOfSubCollectionStartingAt 119027 "self debug: #testIndexOfIfAbsent" 119028 | subcollection index collection | 119029 collection := self collectionMoreThan1NoDuplicates. 119030 subcollection := self collectionMoreThan1NoDuplicates. 119031 index := collection 119032 indexOfSubCollection: subcollection 119033 startingAt: 1. 119034 self assert: index = 1. 119035 index := collection 119036 indexOfSubCollection: subcollection 119037 startingAt: 2. 119038 self assert: index = 0! ! 119039 119040!FloatArrayTest methodsFor: 'tests - index access'! 119041testIndexOfSubCollectionStartingAtIfAbsent 119042 "self debug: #testIndexOfIfAbsent" 119043 | index absent subcollection collection | 119044 collection := self collectionMoreThan1NoDuplicates. 119045 subcollection := self collectionMoreThan1NoDuplicates. 119046 absent := false. 119047 index := collection 119048 indexOfSubCollection: subcollection 119049 startingAt: 1 119050 ifAbsent: [ absent := true ]. 119051 self assert: absent = false. 119052 absent := false. 119053 index := collection 119054 indexOfSubCollection: subcollection 119055 startingAt: 2 119056 ifAbsent: [ absent := true ]. 119057 self assert: absent = true! ! 119058 119059!FloatArrayTest methodsFor: 'tests - index access'! 119060testLastIndexOf 119061 "self debug: #testLastIndexOf" 119062 | element collection | 119063 collection := self collectionMoreThan1NoDuplicates. 119064 element := collection first. 119065 self assert: (collection lastIndexOf: element) = 1. 119066 self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! 119067 119068!FloatArrayTest methodsFor: 'tests - index access'! 119069testLastIndexOfIfAbsent 119070 "self debug: #testIndexOfIfAbsent" 119071 | element collection | 119072 collection := self collectionMoreThan1NoDuplicates. 119073 element := collection first. 119074 self assert: (collection 119075 lastIndexOf: element 119076 ifAbsent: [ 99 ]) = 1. 119077 self assert: (collection 119078 lastIndexOf: self elementNotInForIndexAccessing 119079 ifAbsent: [ 99 ]) = 99! ! 119080 119081!FloatArrayTest methodsFor: 'tests - index access'! 119082testLastIndexOfStartingAt 119083 "self debug: #testLastIndexOf" 119084 | element collection | 119085 collection := self collectionMoreThan1NoDuplicates. 119086 element := collection last. 119087 self assert: (collection 119088 lastIndexOf: element 119089 startingAt: collection size 119090 ifAbsent: [ 99 ]) = collection size. 119091 self assert: (collection 119092 lastIndexOf: element 119093 startingAt: collection size - 1 119094 ifAbsent: [ 99 ]) = 99. 119095 self assert: (collection 119096 lastIndexOf: self elementNotInForIndexAccessing 119097 startingAt: collection size 119098 ifAbsent: [ 99 ]) = 99! ! 119099 119100 119101!FloatArrayTest methodsFor: 'tests - index accessing for multipliness'! 119102testIndexOfDuplicate 119103 "self debug: #testIndexOf" 119104 | collection element | 119105 collection := self collectionWithSameAtEndAndBegining. 119106 element := collection last. 119107 119108 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 119109 'indexOf: should return the position of the first occurrence :'" 119110 self assert: (collection indexOf: element) = 1! ! 119111 119112!FloatArrayTest methodsFor: 'tests - index accessing for multipliness'! 119113testIndexOfIfAbsentDuplicate 119114 "self debug: #testIndexOfIfAbsent" 119115 | collection element | 119116 collection := self collectionWithSameAtEndAndBegining. 119117 element := collection last. 119118 119119 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 119120 'indexOf:ifAbsent: should return the position of the first occurrence :'" 119121 self assert: (collection 119122 indexOf: element 119123 ifAbsent: [ 55 ]) = 1! ! 119124 119125!FloatArrayTest methodsFor: 'tests - index accessing for multipliness'! 119126testIndexOfStartingAtDuplicate 119127 "self debug: #testLastIndexOf" 119128 | collection element | 119129 collection := self collectionWithSameAtEndAndBegining. 119130 element := collection last. 119131 119132 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 119133 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" 119134 self assert: (collection 119135 indexOf: element 119136 startingAt: 1 119137 ifAbsent: [ 55 ]) = 1. 119138 self assert: (collection 119139 indexOf: element 119140 startingAt: 2 119141 ifAbsent: [ 55 ]) = collection size! ! 119142 119143!FloatArrayTest methodsFor: 'tests - index accessing for multipliness'! 119144testLastIndexOfDuplicate 119145 "self debug: #testLastIndexOf" 119146 | collection element | 119147 collection := self collectionWithSameAtEndAndBegining. 119148 element := collection first. 119149 119150 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 119151 'lastIndexOf: should return the position of the last occurrence :'" 119152 self assert: (collection lastIndexOf: element) = collection size! ! 119153 119154!FloatArrayTest methodsFor: 'tests - index accessing for multipliness'! 119155testLastIndexOfIfAbsentDuplicate 119156 "self debug: #testIndexOfIfAbsent" 119157 "self debug: #testLastIndexOf" 119158 | collection element | 119159 collection := self collectionWithSameAtEndAndBegining. 119160 element := collection first. 119161 119162 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 119163 'lastIndexOf: should return the position of the last occurrence :'" 119164 self assert: (collection 119165 lastIndexOf: element 119166 ifAbsent: [ 55 ]) = collection size! ! 119167 119168!FloatArrayTest methodsFor: 'tests - index accessing for multipliness'! 119169testLastIndexOfStartingAtDuplicate 119170 "self debug: #testLastIndexOf" 119171 | collection element | 119172 collection := self collectionWithSameAtEndAndBegining. 119173 element := collection last. 119174 119175 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 119176 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" 119177 self assert: (collection 119178 lastIndexOf: element 119179 startingAt: collection size 119180 ifAbsent: [ 55 ]) = collection size. 119181 self assert: (collection 119182 lastIndexOf: element 119183 startingAt: collection size - 1 119184 ifAbsent: [ 55 ]) = 1! ! 119185 119186 119187!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119188testAllButFirstDo 119189 119190 | result | 119191 result:= OrderedCollection new. 119192 119193 self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 119194 119195 1 to: (result size) do: 119196 [:i| 119197 self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. 119198 119199 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 119200 119201!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119202testAllButLastDo 119203 119204 | result | 119205 result:= OrderedCollection new. 119206 119207 self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 119208 119209 1 to: (result size) do: 119210 [:i| 119211 self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. 119212 119213 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 119214 119215!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119216testCollectFromTo 119217 119218 | result | 119219 result:=self nonEmptyMoreThan1Element 119220 collect: [ :each | each ] 119221 from: 1 119222 to: (self nonEmptyMoreThan1Element size - 1). 119223 119224 1 to: result size 119225 do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. 119226 self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! 119227 119228!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119229testDetectSequenced 119230" testing that detect keep the first element returning true for sequenceable collections " 119231 119232 | element result | 119233 element := self nonEmptyMoreThan1Element at:1. 119234 result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. 119235 self assert: result = element. ! ! 119236 119237!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119238testDo! ! 119239 119240!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119241testFindFirst 119242 119243 | element result | 119244 element := self nonEmptyMoreThan1Element at:1. 119245 result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. 119246 119247 self assert: result=1. ! ! 119248 119249!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119250testFindFirstNotIn 119251 119252 | result | 119253 119254 result:=self empty findFirst: [:each | true]. 119255 119256 self assert: result=0. ! ! 119257 119258!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119259testFindLast 119260 119261 | element result | 119262 element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. 119263 result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. 119264 119265 self assert: result=self nonEmptyMoreThan1Element size. ! ! 119266 119267!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119268testFindLastNotIn 119269 119270 | result | 119271 119272 result:=self empty findFirst: [:each | true]. 119273 119274 self assert: result=0. ! ! 119275 119276!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119277testFromToDo 119278 119279 | result | 119280 result:= OrderedCollection new. 119281 119282 self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 119283 119284 1 to: (self nonEmptyMoreThan1Element size -1) do: 119285 [:i| 119286 self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. 119287 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 119288 119289!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119290testKeysAndValuesDo 119291 "| result | 119292 result:= OrderedCollection new. 119293 119294 self nonEmptyMoreThan1Element keysAndValuesDo: 119295 [:i :value| 119296 result add: (value+i)]. 119297 119298 1 to: result size do: 119299 [:i| 119300 self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" 119301 | indexes elements | 119302 indexes:= OrderedCollection new. 119303 elements := OrderedCollection new. 119304 119305 self nonEmptyMoreThan1Element keysAndValuesDo: 119306 [:i :value| 119307 indexes add: (i). 119308 elements add: value]. 119309 119310 (1 to: self nonEmptyMoreThan1Element size )do: 119311 [ :i | 119312 self assert: (indexes at: i) = i. 119313 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 119314 ]. 119315 119316 self assert: indexes size = elements size. 119317 self assert: indexes size = self nonEmptyMoreThan1Element size . 119318 119319 ! ! 119320 119321!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119322testKeysAndValuesDoEmpty 119323 | result | 119324 result:= OrderedCollection new. 119325 119326 self empty keysAndValuesDo: 119327 [:i :value| 119328 result add: (value+i)]. 119329 119330 self assert: result isEmpty .! ! 119331 119332!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119333testPairsCollect 119334 119335 | index result | 119336 index:=0. 119337 119338 result:=self nonEmptyMoreThan1Element pairsCollect: 119339 [:each1 :each2 | 119340 self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). 119341 (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). 119342 ]. 119343 119344 result do: 119345 [:each | self assert: each = true]. 119346 119347! ! 119348 119349!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119350testPairsDo 119351 | index | 119352 index:=1. 119353 119354 self nonEmptyMoreThan1Element pairsDo: 119355 [:each1 :each2 | 119356 self assert:(self nonEmptyMoreThan1Element at:index)=each1. 119357 self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. 119358 index:=index+2]. 119359 119360 self nonEmptyMoreThan1Element size odd 119361 ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] 119362 ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! 119363 119364!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119365testReverseDo 119366 | result | 119367 result:= OrderedCollection new. 119368 self nonEmpty reverseDo: [: each | result add: each]. 119369 119370 1 to: result size do: 119371 [:i| 119372 self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! 119373 119374!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119375testReverseDoEmpty 119376 | result | 119377 result:= OrderedCollection new. 119378 self empty reverseDo: [: each | result add: each]. 119379 119380 self assert: result isEmpty .! ! 119381 119382!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119383testReverseWithDo 119384 119385 | secondCollection result index | 119386 result:= OrderedCollection new. 119387 index := self nonEmptyMoreThan1Element size + 1. 119388 secondCollection:= self nonEmptyMoreThan1Element copy. 119389 119390 self nonEmptyMoreThan1Element reverseWith: secondCollection do: 119391 [:a :b | 119392 self assert: (self nonEmptyMoreThan1Element indexOf: a ) = (index := index - 1 ). 119393 result add: (a = b)]. 119394 119395 1 to: result size do: 119396 [:i| 119397 self assert: (result at:i)=(true)]. 119398 self assert: result size = self nonEmptyMoreThan1Element size.! ! 119399 119400!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119401testWithCollect 119402 119403 | result newCollection index collection | 119404 119405 index := 0. 119406 collection := self nonEmptyMoreThan1Element . 119407 newCollection := collection copy. 119408 result:=collection with: newCollection collect: [:a :b | 119409 self assert: (collection indexOf: a ) = ( index := index + 1). 119410 self assert: (a = b). 119411 b]. 119412 119413 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 119414 self assert: result size = collection size.! ! 119415 119416!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119417testWithCollectError 119418 self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! 119419 119420!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119421testWithDo 119422 119423 | secondCollection result index | 119424 result:= OrderedCollection new. 119425 secondCollection:= self nonEmptyMoreThan1Element copy. 119426 index := 0. 119427 119428 self nonEmptyMoreThan1Element with: secondCollection do: 119429 [:a :b | 119430 self assert: (self nonEmptyMoreThan1Element indexOf: a) = ( index := index + 1). 119431 result add: (a =b)]. 119432 119433 1 to: result size do: 119434 [:i| 119435 self assert: (result at:i)=(true)]. 119436 self assert: result size = self nonEmptyMoreThan1Element size.! ! 119437 119438!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119439testWithDoError 119440 119441 self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! 119442 119443!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119444testWithIndexCollect 119445 119446 | result index collection | 119447 index := 0. 119448 collection := self nonEmptyMoreThan1Element . 119449 result := collection withIndexCollect: [:each :i | 119450 self assert: i = (index := index + 1). 119451 self assert: i = (collection indexOf: each) . 119452 each] . 119453 119454 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 119455 self assert: result size = collection size.! ! 119456 119457!FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 119458testWithIndexDo 119459 119460 "| result | 119461 result:=Array new: self nonEmptyMoreThan1Element size. 119462 self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 119463 119464 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" 119465 | indexes elements | 119466 indexes:= OrderedCollection new. 119467 elements := OrderedCollection new. 119468 119469 self nonEmptyMoreThan1Element withIndexDo: 119470 [:value :i | 119471 indexes add: (i). 119472 elements add: value]. 119473 119474 (1 to: self nonEmptyMoreThan1Element size )do: 119475 [ :i | 119476 self assert: (indexes at: i) = i. 119477 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 119478 ]. 119479 119480 self assert: indexes size = elements size. 119481 self assert: indexes size = self nonEmptyMoreThan1Element size . 119482 ! ! 119483 119484 119485!FloatArrayTest methodsFor: 'tests - printing'! 119486testPrintElementsOn 119487 119488 | aStream result allElementsAsString | 119489 result:=''. 119490 aStream:= ReadWriteStream on: result. 119491 119492 self nonEmpty printElementsOn: aStream . 119493 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 119494 1 to: allElementsAsString size do: 119495 [:i | 119496 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 119497 ].! ! 119498 119499!FloatArrayTest methodsFor: 'tests - printing'! 119500testPrintNameOn 119501 119502 | aStream result | 119503 result:=''. 119504 aStream:= ReadWriteStream on: result. 119505 119506 self nonEmpty printNameOn: aStream . 119507 Transcript show: result asString. 119508 self nonEmpty class name first isVowel 119509 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 119510 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 119511 119512!FloatArrayTest methodsFor: 'tests - printing'! 119513testPrintOn 119514 | aStream result allElementsAsString | 119515 result:=''. 119516 aStream:= ReadWriteStream on: result. 119517 119518 self nonEmpty printOn: aStream . 119519 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 119520 1 to: allElementsAsString size do: 119521 [:i | 119522 i=1 119523 ifTrue:[ 119524 self accessCollection class name first isVowel 119525 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 119526 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 119527 i=2 119528 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 119529 i>2 119530 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. 119531 ].! ! 119532 119533!FloatArrayTest methodsFor: 'tests - printing'! 119534testPrintOnDelimiter 119535 | aStream result allElementsAsString | 119536 result:=''. 119537 aStream:= ReadWriteStream on: result. 119538 119539 self nonEmpty printOn: aStream delimiter: ', ' . 119540 119541 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 119542 1 to: allElementsAsString size do: 119543 [:i | 119544 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 119545 ].! ! 119546 119547!FloatArrayTest methodsFor: 'tests - printing'! 119548testPrintOnDelimiterLast 119549 119550 | aStream result allElementsAsString | 119551 result:=''. 119552 aStream:= ReadWriteStream on: result. 119553 119554 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 119555 119556 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 119557 1 to: allElementsAsString size do: 119558 [:i | 119559 i<(allElementsAsString size-1 ) 119560 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 119561 i=(allElementsAsString size-1) 119562 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 119563 i=(allElementsAsString size) 119564 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 119565 ].! ! 119566 119567!FloatArrayTest methodsFor: 'tests - printing'! 119568testStoreOn 119569" for the moment work only for collection that include simple elements such that Integer" 119570 119571"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 119572string := ''. 119573str := ReadWriteStream on: string. 119574elementsAsStringExpected := OrderedCollection new. 119575elementsAsStringObtained := OrderedCollection new. 119576self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 119577 119578self nonEmpty storeOn: str. 119579result := str contents . 119580cuttedResult := ( result findBetweenSubStrs: ';' ). 119581 119582index := 1. 119583 119584cuttedResult do: 119585 [ :each | 119586 index = 1 119587 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 119588 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 119589 elementsAsStringObtained add: tmp. 119590 index := index + 1. ] 119591 ifFalse: [ 119592 index < cuttedResult size 119593 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 119594 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 119595 elementsAsStringObtained add: tmp. 119596 index := index + 1.] 119597 ifFalse: [self assert: ( each = ' yourself)' ) ]. 119598 ] 119599 119600 ]. 119601 119602 119603 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 119604 119605! ! 119606 119607 119608!FloatArrayTest methodsFor: 'tests - puting with indexes'! 119609testAtAllIndexesPut 119610 119611 self nonEmpty atAllPut: self aValue. 119612 self nonEmpty do:[ :each| self assert: each = self aValue]. 119613 ! ! 119614 119615!FloatArrayTest methodsFor: 'tests - puting with indexes'! 119616testAtAllPut 119617 | | 119618 self nonEmpty atAll: self indexArray put: self aValue.. 119619 119620 self indexArray do: 119621 [:i | self assert: (self nonEmpty at: i)=self aValue ]. 119622 ! ! 119623 119624!FloatArrayTest methodsFor: 'tests - puting with indexes'! 119625testAtAllPutAll 119626 119627 | valueArray | 119628 valueArray := self valueArray . 119629 self nonEmpty atAll: self indexArray putAll: valueArray . 119630 119631 1 to: self indexArray size do: 119632 [:i | 119633 self assert: (self nonEmpty at:(self indexArray at: i))= (valueArray at:i) ]! ! 119634 119635!FloatArrayTest methodsFor: 'tests - puting with indexes'! 119636testAtLastPut 119637 | result index | 119638 index := self indexArray anyOne. 119639 result := self nonEmpty atLast: index put: self aValue. 119640 119641 self assert: (self nonEmpty at: (self nonEmpty size +1 - index)) = self aValue .! ! 119642 119643!FloatArrayTest methodsFor: 'tests - puting with indexes'! 119644testAtWrapPut 119645 "self debug: #testAtWrapPut" 119646 | index | 119647 index := self indexArray anyOne. 119648 119649 self nonEmpty atWrap: 0 put: self aValue. 119650 self assert: (self nonEmpty at:(self nonEmpty size))=self aValue. 119651 119652 self nonEmpty atWrap: (self nonEmpty size+1) put: self aValue. 119653 self assert: (self nonEmpty at:(1))=self aValue. 119654 119655 self nonEmpty atWrap: (index ) put: self aValue. 119656 self assert: (self nonEmpty at: index ) = self aValue. 119657 119658 self nonEmpty atWrap: (self nonEmpty size+index ) put: self aValue . 119659 self assert: (self nonEmpty at:(index ))=self aValue .! ! 119660 119661!FloatArrayTest methodsFor: 'tests - puting with indexes'! 119662testFromToPut 119663 119664 | collection index | 119665 index := self indexArray anyOne. 119666 collection := self nonEmpty copy. 119667 collection from: 1 to: index put: self aValue.. 119668 1 to: index do: 119669 [:i | self assert: (collection at: i)= self aValue]. 119670 (index +1) to: collection size do: 119671 [:i | self assert: (collection at:i)= (self nonEmpty at:i)].! ! 119672 119673!FloatArrayTest methodsFor: 'tests - puting with indexes'! 119674testSwapWith 119675 "self debug: #testSwapWith" 119676 | result index | 119677 index := self indexArray anyOne. 119678 result:= self nonEmpty copy . 119679 result swap: index with: 1. 119680 self assert: (result at: index) = (self nonEmpty at:1). 119681 self assert: (result at: 1) = (self nonEmpty at: index). 119682 ! ! 119683 119684 119685!FloatArrayTest methodsFor: 'tests - replacing'! 119686testReplaceAllWith 119687 | result collection oldElement newElement | 119688 collection := self nonEmpty . 119689 result := collection copy. 119690 oldElement := self elementInForReplacement . 119691 newElement := self newElement . 119692 result replaceAll: oldElement with: newElement . 119693 119694 1 to: collection size do: 119695 [: 119696 each | 119697 ( collection at: each ) = oldElement 119698 ifTrue: [ self assert: ( result at: each ) = newElement ]. 119699 ].! ! 119700 119701!FloatArrayTest methodsFor: 'tests - replacing'! 119702testReplaceFromToWith 119703 | result collection replacementCollection firstIndex secondIndex | 119704 collection := self nonEmpty . 119705 replacementCollection := self replacementCollectionSameSize . 119706 firstIndex := self firstIndex . 119707 secondIndex := self secondIndex . 119708 result := collection copy. 119709 result replaceFrom: firstIndex to: secondIndex with: replacementCollection . 119710 119711 "verify content of 'result' : " 119712 "first part of 'result'' : '" 119713 119714 1 to: ( firstIndex - 1 ) do: [ :i | self assert: (collection at:i ) = ( result at: i ) ]. 119715 119716 " middle part containing replacementCollection : " 119717 119718 ( firstIndex ) to: ( firstIndex + replacementCollection size - 1 ) do: 119719 [ :i | 119720 self assert: ( result at: i ) = ( replacementCollection at: ( i - firstIndex +1 ) ) 119721 ]. 119722 119723 " end part :" 119724 ( firstIndex + replacementCollection size) to: (result size) do: 119725 [:i| 119726 self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ]. 119727 119728 ! ! 119729 119730!FloatArrayTest methodsFor: 'tests - replacing'! 119731testReplaceFromToWithStartingAt 119732 | result repStart collection replacementCollection firstIndex secondIndex | 119733 collection := self nonEmpty . 119734 result := collection copy. 119735 replacementCollection := self replacementCollectionSameSize . 119736 firstIndex := self firstIndex . 119737 secondIndex := self secondIndex . 119738 repStart := replacementCollection size - ( secondIndex - firstIndex + 1 ) + 1. 119739 result replaceFrom: firstIndex to: secondIndex with: replacementCollection startingAt: repStart . 119740 119741 "verify content of 'result' : " 119742 "first part of 'result'' : '" 119743 119744 1 to: ( firstIndex - 1 ) do: [ :i | self assert: ( collection at:i ) = ( result at: i ) ]. 119745 119746 " middle part containing replacementCollection : " 119747 119748 ( firstIndex ) to: ( replacementCollection size - repStart +1 ) do: 119749 [:i| 119750 self assert: (result at: i)=( replacementCollection at: ( repStart + ( i -firstIndex ) ) ) ]. 119751 119752 " end part :" 119753 ( firstIndex + replacementCollection size ) to: ( result size ) do: 119754 [ :i | 119755 self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ].! ! 119756 119757 119758!FloatArrayTest methodsFor: 'tests - set arithmetic'! 119759containsAll: union of: one andOf: another 119760 119761 self assert: (one allSatisfy: [:each | union includes: each]). 119762 self assert: (another allSatisfy: [:each | union includes: each])! ! 119763 119764!FloatArrayTest methodsFor: 'tests - set arithmetic'! 119765numberOfSimilarElementsInIntersection 119766 ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! 119767 119768!FloatArrayTest methodsFor: 'tests - set arithmetic'! 119769testDifference 119770 "Answer the set theoretic difference of two collections." 119771 "self debug: #testDifference" 119772 119773 self assert: (self collection difference: self collection) isEmpty. 119774 self assert: (self empty difference: self collection) isEmpty. 119775 self assert: (self collection difference: self empty) = self collection 119776! ! 119777 119778!FloatArrayTest methodsFor: 'tests - set arithmetic'! 119779testDifferenceWithNonNullIntersection 119780 "Answer the set theoretic difference of two collections." 119781 "self debug: #testDifferenceWithNonNullIntersection" 119782 " #(1 2 3) difference: #(2 4) 119783 -> #(1 3)" 119784 | res overlapping | 119785 overlapping := self collectionClass 119786 with: self anotherElementOrAssociationNotIn 119787 with: self anotherElementOrAssociationIn. 119788 res := self collection difference: overlapping. 119789 self deny: (res includes: self anotherElementOrAssociationIn). 119790 overlapping do: [ :each | self deny: (res includes: each) ]! ! 119791 119792!FloatArrayTest methodsFor: 'tests - set arithmetic'! 119793testDifferenceWithSeparateCollection 119794 "Answer the set theoretic difference of two collections." 119795 "self debug: #testDifferenceWithSeparateCollection" 119796 | res separateCol | 119797 separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. 119798 res := self collection difference: separateCol. 119799 self deny: (res includes: self anotherElementOrAssociationNotIn). 119800 self assert: res = self collection. 119801 res := separateCol difference: self collection. 119802 self deny: (res includes: self collection anyOne). 119803 self assert: res = separateCol! ! 119804 119805!FloatArrayTest methodsFor: 'tests - set arithmetic'! 119806testIntersectionBasic 119807 "self debug: #testIntersectionBasic" 119808 | inter | 119809 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 119810 self deny: inter isEmpty. 119811 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 119812 119813!FloatArrayTest methodsFor: 'tests - set arithmetic'! 119814testIntersectionEmpty 119815 "self debug: #testIntersectionEmpty" 119816 119817 | inter | 119818 inter := self empty intersection: self empty. 119819 self assert: inter isEmpty. 119820 inter := self empty intersection: self collection . 119821 self assert: inter = self empty. 119822 ! ! 119823 119824!FloatArrayTest methodsFor: 'tests - set arithmetic'! 119825testIntersectionItself 119826 "self debug: #testIntersectionItself" 119827 119828 self assert: (self collection intersection: self collection) = self collection. 119829 ! ! 119830 119831!FloatArrayTest methodsFor: 'tests - set arithmetic'! 119832testIntersectionTwoSimilarElementsInIntersection 119833 "self debug: #testIntersectionBasic" 119834 | inter | 119835 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 119836 self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. 119837 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 119838 119839!FloatArrayTest methodsFor: 'tests - set arithmetic'! 119840testUnion 119841 "self debug: #testUnionOfEmpties" 119842 119843 | union | 119844 union := self empty union: self nonEmpty. 119845 self containsAll: union of: self empty andOf: self nonEmpty. 119846 union := self nonEmpty union: self empty. 119847 self containsAll: union of: self empty andOf: self nonEmpty. 119848 union := self collection union: self nonEmpty. 119849 self containsAll: union of: self collection andOf: self nonEmpty.! ! 119850 119851!FloatArrayTest methodsFor: 'tests - set arithmetic'! 119852testUnionOfEmpties 119853 "self debug: #testUnionOfEmpties" 119854 119855 self assert: (self empty union: self empty) isEmpty. 119856 119857 ! ! 119858 119859 119860!FloatArrayTest methodsFor: 'tests - sorting'! 119861testIsSorted 119862 self assert: [ self sortedInAscendingOrderCollection isSorted ]. 119863 self deny: [ self unsortedCollection isSorted ]! ! 119864 119865!FloatArrayTest methodsFor: 'tests - sorting'! 119866testIsSortedBy 119867 self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a<b]). 119868 self deny: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a>b]). 119869! ! 119870 119871!FloatArrayTest methodsFor: 'tests - sorting'! 119872testSort 119873 | result tmp | 119874 result := self unsortedCollection sort. 119875 tmp := result at: 1. 119876 result do: 119877 [:each | self assert: each>=tmp. tmp:= each. ].! ! 119878 119879!FloatArrayTest methodsFor: 'tests - sorting'! 119880testSortUsingSortBlock 119881 | result tmp | 119882 result := self unsortedCollection sort: [:a :b | a>b]. 119883 tmp := result at: 1. 119884 result do: 119885 [:each | self assert: each<=tmp. tmp:= each. ].! ! 119886 119887 119888!FloatArrayTest methodsFor: 'tests - subcollections access'! 119889testAllButFirst 119890 "self debug: #testAllButFirst" 119891 | abf col | 119892 col := self moreThan3Elements. 119893 abf := col allButFirst. 119894 self deny: abf first = col first. 119895 self assert: abf size + 1 = col size! ! 119896 119897!FloatArrayTest methodsFor: 'tests - subcollections access'! 119898testAllButFirstNElements 119899 "self debug: #testAllButFirst" 119900 | abf col | 119901 col := self moreThan3Elements. 119902 abf := col allButFirst: 2. 119903 1 119904 to: abf size 119905 do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. 119906 self assert: abf size + 2 = col size! ! 119907 119908!FloatArrayTest methodsFor: 'tests - subcollections access'! 119909testAllButLast 119910 "self debug: #testAllButLast" 119911 | abf col | 119912 col := self moreThan3Elements. 119913 abf := col allButLast. 119914 self deny: abf last = col last. 119915 self assert: abf size + 1 = col size! ! 119916 119917!FloatArrayTest methodsFor: 'tests - subcollections access'! 119918testAllButLastNElements 119919 "self debug: #testAllButFirst" 119920 | abf col | 119921 col := self moreThan3Elements. 119922 abf := col allButLast: 2. 119923 1 119924 to: abf size 119925 do: [ :i | self assert: (abf at: i) = (col at: i) ]. 119926 self assert: abf size + 2 = col size! ! 119927 119928!FloatArrayTest methodsFor: 'tests - subcollections access'! 119929testFirstNElements 119930 "self debug: #testFirstNElements" 119931 | result | 119932 result := self moreThan3Elements first: self moreThan3Elements size - 1. 119933 1 119934 to: result size 119935 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. 119936 self assert: result size = (self moreThan3Elements size - 1). 119937 self 119938 should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] 119939 raise: Error! ! 119940 119941!FloatArrayTest methodsFor: 'tests - subcollections access'! 119942testLastNElements 119943 "self debug: #testLastNElements" 119944 | result | 119945 result := self moreThan3Elements last: self moreThan3Elements size - 1. 119946 1 119947 to: result size 119948 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. 119949 self assert: result size = (self moreThan3Elements size - 1). 119950 self 119951 should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] 119952 raise: Error! ! 119953 119954"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 119955 119956FloatArrayTest class 119957 uses: TCreationWithTest classTrait + TSequencedStructuralEqualityTest classTrait + TSequencedConcatenationTest classTrait + TSetArithmetic classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TPrintOnSequencedTest classTrait + TEmptyTest classTrait + TBeginsEndsWith classTrait + TCloneTest classTrait + TConvertTest classTrait + TConvertAsSortedTest classTrait + TConvertAsSetForMultiplinessIdentityTest classTrait + TCopyPartOfSequenceable classTrait + TCopyPartOfSequenceableForMultipliness classTrait + TCopySequenceableSameContents classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopySequenceableWithReplacement classTrait + TCopyTest classTrait + TIncludesWithIdentityCheckTest classTrait + TIndexAccess classTrait + TIndexAccessForMultipliness classTrait + TIterateSequencedReadableTest classTrait + TPutTest classTrait + TPutBasicTest classTrait + TReplacementSequencedTest classTrait + TSequencedElementAccessTest classTrait + TSortTest classTrait + TSubCollectionAccess classTrait 119958 instanceVariableNames: ''! 119959ClassTestCase subclass: #FloatTest 119960 instanceVariableNames: '' 119961 classVariableNames: '' 119962 poolDictionaries: '' 119963 category: 'KernelTests-Numbers'! 119964!FloatTest commentStamp: 'fbs 3/8/2004 22:13' prior: 0! 119965I provide a test suite for Float values. Examine my tests to see how Floats should behave, and see how to use them.! 119966 119967 119968!FloatTest methodsFor: 'IEEE 754' stamp: 'nice 5/30/2006 02:34'! 119969test32bitGradualUnderflow 119970 "method asIEEE32BitWord did not respect IEEE gradual underflow" 119971 119972 | conv expected exponentPart | 119973 119974 "IEEE 32 bits Float have 1 bit sign/8 bit exponent/23 bits of mantissa after leading 1 119975 2r1.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2reeeeeeee-127) * sign 119976 except when 2reeeeeeee isZero, which is a gradual underflow: 119977 2r0.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2r00000000-126) * sign 119978 and when 2reeeeeeee = 255, which is infinity if mantissa all zero or nan otherwise" 119979 119980 "case 1: This example is the first gradual underflow case" 119981 conv := 2r0.11111111111111111111111e-126 asIEEE32BitWord. 119982 119983 "expected float encoded as sign/exponent/mantissa (whithout leading 1 or 0)" 119984 exponentPart := 0. 119985 expected := exponentPart bitOr: 2r11111111111111111111111. 119986 self assert: expected = conv. 119987 119988 "case 2: smallest number" 119989 conv := 2r0.00000000000000000000001e-126 asIEEE32BitWord. 119990 expected := exponentPart bitOr: 2r1. 119991 self assert: expected = conv. 119992 119993 "case 3: round to nearest even also in underflow cases... here round to upper" 119994 conv := 2r0.000000000000000000000011e-126 asIEEE32BitWord. 119995 expected := exponentPart bitOr: 2r10. 119996 self assert: expected = conv. 119997 119998 "case 4: round to nearest even also in underflow cases... here round to lower" 119999 conv := 2r0.000000000000000000000101e-126 asIEEE32BitWord. 120000 expected := exponentPart bitOr: 2r10. 120001 self assert: expected = conv. 120002 120003 "case 5: round to nearest even also in underflow cases... here round to upper" 120004 conv := 2r0.0000000000000000000001011e-126 asIEEE32BitWord. 120005 expected := exponentPart bitOr: 2r11. 120006 self assert: expected = conv. 120007 ! ! 120008 120009!FloatTest methodsFor: 'IEEE 754' stamp: 'nice 5/30/2006 00:07'! 120010test32bitRoundingMode 120011 "method asIEEE32BitWord did not respect IEEE default rounding mode" 120012 120013 | conv expected exponentPart | 120014 120015 "IEEE 32 bits Float have 1 bit sign/8 bit exponent/23 bits of mantissa after leading 1 120016 2r1.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2reeeeeeee-127) * sign 120017 except when 2reeeeeeee isZero, which is a gradual underflow: 120018 2r0.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2r00000000-127) * sign 120019 and when 2reeeeeeee = 255, which is infinity if mantissa all zero or nan otherwise" 120020 120021 "This example has two extra bits in mantissa for testing rounding mode 120022 case 1: should obviously round to upper" 120023 conv := 2r1.0000000000000000000000111e25 asIEEE32BitWord. 120024 120025 "expected float encoded as sign/exponent/mantissa (whithout leading 1)" 120026 exponentPart := 25+127 bitShift: 23. "127 is 2r01111111 or 16r7F" 120027 expected := exponentPart bitOr: 2r10. 120028 self assert: expected = conv. 120029 120030 "case 2: exactly in the mid point of two 32 bit float: round toward nearest even (to upper)" 120031 conv := 2r1.0000000000000000000000110e25 asIEEE32BitWord. 120032 expected := exponentPart bitOr: 2r10. 120033 self assert: expected = conv. 120034 120035 "case 3: exactly in the mid point of two 32 bit float: round toward nearest even (to lower)" 120036 conv := 2r1.0000000000000000000000010e25 asIEEE32BitWord. 120037 expected := exponentPart bitOr: 2r0. 120038 self assert: expected = conv. 120039 120040 "case 4: obviously round to upper" 120041 conv := 2r1.0000000000000000000000011e25 asIEEE32BitWord. 120042 expected := exponentPart bitOr: 2r1. 120043 self assert: expected = conv. 120044! ! 120045 120046!FloatTest methodsFor: 'IEEE 754' stamp: 'al 6/22/2008 11:52'! 120047testNaN5 120048 self assert: ((Float nan asIEEE32BitWord printPaddedWith: $0 to: 32 base: 2) 120049 copyFrom: 2 to: 9) = '11111111'. 120050 self assert: (Float fromIEEE32Bit: 120051 (Integer readFrom: '01111111110000000000000000000000' readStream base: 2)) isNaN! ! 120052 120053 120054!FloatTest methodsFor: 'NaN behavior' stamp: 'sd 6/5/2005 08:31'! 120055testNaN1 120056 "FloatTest new testNaN1" 120057 120058 self assert: Float nan == Float nan. 120059 self deny: Float nan = Float nan. 120060 "a NaN is not equal to itself." 120061! ! 120062 120063!FloatTest methodsFor: 'NaN behavior' stamp: 'dtl 10/1/2004 18:26'! 120064testNaN2 120065 "Two NaN values are always considered to be different. 120066 On an little-endian machine (32 bit Intel), Float nan is 16rFFF80000 16r00000000. 120067 On a big-endian machine (PowerPC), Float nan is 16r7FF80000 16r00000000. Changing 120068 the bit pattern of the first word of a NaN produces another value that is still 120069 considered equal to NaN. This test should work on both little endian and big 120070 endian machines. However, it is not guaranteed to work on future 64 bit versions 120071 of Squeak, for which Float may have different internal representations." 120072 120073 "FloatTest new testNaN2" 120074 120075 | nan1 nan2 | 120076 nan1 := Float nan copy. 120077 nan2 := Float nan copy. 120078 120079 "test two instances of NaN with the same bit pattern" 120080 self deny: nan1 = nan2. 120081 self deny: nan1 == nan2. 120082 self deny: nan1 = nan1. 120083 self assert: nan1 == nan1. 120084 120085 "change the bit pattern of nan1" 120086 self assert: nan1 size == 2. 120087 self assert: (nan1 at: 2) = 0. 120088 nan1 at: 1 put: (nan1 at: 1) + 999. 120089 self assert: nan1 isNaN. 120090 self assert: nan2 isNaN. 120091 self deny: (nan1 at: 1) = (nan2 at: 1). 120092 120093 "test two instances of NaN with different bit patterns" 120094 self deny: nan1 = nan2. 120095 self deny: nan1 == nan2. 120096 self deny: nan1 = nan1. 120097 self assert: nan1 == nan1 120098! ! 120099 120100!FloatTest methodsFor: 'NaN behavior' stamp: 'sd 6/5/2005 08:32'! 120101testNaN3 120102 "FloatTest new testNaN3" 120103 120104 | set item identitySet | 120105 set := Set new. 120106 set add: (item := Float nan). 120107 self deny: (set includes: item). 120108 identitySet := IdentitySet new. 120109 identitySet add: (item := Float nan). 120110 self assert: (identitySet includes: item). 120111 "as a NaN is not equal to itself, it can not be retrieved from a set" 120112! ! 120113 120114!FloatTest methodsFor: 'NaN behavior' stamp: 'sd 6/5/2005 08:32'! 120115testNaN4 120116 "FloatTest new testNaN4" 120117 120118 | dict | 120119 dict := Dictionary new. 120120 dict at: Float nan put: #NaN. 120121 self deny: (dict includes: Float nan). 120122 "as a NaN is not equal to itself, it can not be retrieved when it is used as a dictionary key" 120123! ! 120124 120125!FloatTest methodsFor: 'NaN behavior' stamp: 'nice 3/14/2008 23:42'! 120126testNaNisLiteral 120127 self deny: Float nan isLiteral description: 'there is no literal representation of NaN'! ! 120128 120129!FloatTest methodsFor: 'NaN behavior' stamp: 'GabrielOmarCotelli 5/23/2009 20:38'! 120130testReciprocal 120131 120132 self 120133 assert: 1.0 reciprocal = 1.0; 120134 assert: 2.0 reciprocal = 0.5; 120135 assert: -1.0 reciprocal = -1.0; 120136 assert: -2.0 reciprocal = -0.5. 120137 120138 self should: [ 0.0 reciprocal ] raise: ZeroDivide! ! 120139 120140 120141!FloatTest methodsFor: 'characterization' stamp: 'nice 6/11/2009 20:47'! 120142testCharacterization 120143 120144 "Test the largest finite representable floating point value" 120145 self assert: Float fmax successor = Float infinity. 120146 self assert: Float infinity predecessor = Float fmax. 120147 self assert: Float fmax negated predecessor = Float infinity negated. 120148 self assert: Float infinity negated successor = Float fmax negated. 120149 120150 "Test the smallest positive representable floating point value" 120151 self assert: Float fmin predecessor = 0.0. 120152 self assert: 0.0 successor = Float fmin. 120153 self assert: Float fmin negated successor = 0.0. 120154 self assert: 0.0 predecessor = Float fmin negated. 120155 120156 "Test the relative precision" 120157 self assert: Float one + Float epsilon > Float one. 120158 self assert: Float one + Float epsilon = Float one successor. 120159 self assert: Float one + (Float epsilon / Float radix) = Float one. 120160 120161 "Test maximum and minimum exponent" 120162 self assert: Float fmax exponent = Float emax. 120163 self assert: Float fminNormalized exponent = Float emin. 120164 Float denormalized ifTrue: [ 120165 self assert: Float fminDenormalized exponent = (Float emin + 1 - Float precision)]. 120166 120167 "Alternative tests for maximum and minimum" 120168 self assert: (Float radix - Float epsilon) * (Float radix raisedTo: Float emax) = Float fmax. 120169 self assert: Float epsilon * (Float radix raisedTo: Float emin) = Float fmin. 120170 120171 "Test sucessors and predecessors" 120172 self assert: Float one predecessor successor = Float one. 120173 self assert: Float one successor predecessor = Float one. 120174 self assert: Float one negated predecessor successor = Float one negated. 120175 self assert: Float one negated successor predecessor = Float one negated. 120176 self assert: Float infinity successor = Float infinity. 120177 self assert: Float infinity negated predecessor = Float infinity negated. 120178 self assert: Float nan predecessor isNaN. 120179 self assert: Float nan successor isNaN. 120180 120181 "SPECIFIC FOR IEEE 754 double precision - 64 bits" 120182 self assert: Float fmax hex = '7FEFFFFFFFFFFFFF'. 120183 self assert: Float fminDenormalized hex = '0000000000000001'. 120184 self assert: Float fminNormalized hex = '0010000000000000'. 120185 self assert: 0.0 hex = '0000000000000000'. 120186 self assert: Float negativeZero hex = '8000000000000000'. 120187 self assert: Float one hex = '3FF0000000000000'. 120188 self assert: Float infinity hex = '7FF0000000000000'. 120189 self assert: Float infinity negated hex = 'FFF0000000000000'.! ! 120190 120191 120192!FloatTest methodsFor: 'infinity behavior' stamp: 'nice 7/14/2009 09:32'! 120193testHugeIntegerCloseTo 120194 "This is a test for bug http://bugs.squeak.org/view.php?id=7368" 120195 120196 "FloatTest new testHugeIntegerCloseTo" 120197 120198 self deny: (1.0 closeTo: 200 factorial). 120199 self deny: (200 factorial closeTo: 1.0). 120200 self assert: (Float infinity closeTo: 200 factorial) = (200 factorial closeTo: Float infinity).! ! 120201 120202!FloatTest methodsFor: 'infinity behavior' stamp: 'sd 6/5/2005 08:30'! 120203testInfinity1 120204 "FloatTest new testInfinity1" 120205 120206 | i1 i2 | 120207 120208 i1 := 10000 exp. 120209 i2 := 1000000000 exp. 120210 self assert: i1 isInfinite & i2 isInfinite & (i1 = i2). 120211 "All infinities are equal. (This is a very substantial difference to NaN's, which are never equal." 120212! ! 120213 120214!FloatTest methodsFor: 'infinity behavior' stamp: 'sd 6/5/2005 08:30'! 120215testInfinity2 120216 "FloatTest new testInfinity2" 120217 120218 | i1 i2 | 120219 i1 := 10000 exp. 120220 i2 := 1000000000 exp. 120221 i2 := 0 - i2. " this is entirely ok. You can compute with infinite values." 120222 120223 self assert: i1 isInfinite & i2 isInfinite & i1 positive & i2 negative. 120224 self deny: i1 = i2. 120225 "All infinities are signed. Negative infinity is not equal to Infinity" 120226! ! 120227 120228!FloatTest methodsFor: 'infinity behavior' stamp: 'nice 10/17/2007 23:54'! 120229testInfinityCloseTo 120230 "This is a test for bug http://bugs.squeak.org/view.php?id=6729:" 120231 120232 "FloatTest new testInfinityCloseTo" 120233 120234 self deny: (Float infinity closeTo: Float infinity negated). 120235 self deny: (Float infinity negated closeTo: Float infinity).! ! 120236 120237 120238!FloatTest methodsFor: 'printing' stamp: 'nice 10/11/2008 21:45'! 120239testStoreBase16 120240 "This bug was reported in mantis http://bugs.squeak.org/view.php?id=6695" 120241 120242 self 120243 assert: (20.0 storeStringBase: 16) = '16r14.0' 120244 description: 'the radix prefix should not be omitted, except in base 10'! ! 120245 120246 120247!FloatTest methodsFor: 'testing - arithmetic' stamp: 'st 9/20/2004 17:04'! 120248testContinuedFractions 120249 self assert: (Float pi asApproximateFractionAtOrder: 1) = (22/7). 120250 self assert: (Float pi asApproximateFractionAtOrder: 3) = (355/113)! ! 120251 120252!FloatTest methodsFor: 'testing - arithmetic' stamp: 'GabrielOmarCotelli 6/6/2009 17:14'! 120253testDivide 120254 120255 self assert: 1.5 / 2.0 = 0.75. 120256 120257 self assert: 2.0 / 1 = 2.0. 120258 120259 self should: [ 2.0 / 0 ] raise: ZeroDivide. 120260 self should: [ 2.0 / 0.0 ] raise: ZeroDivide. 120261 self should: [ 1.2 / Float negativeZero ] raise: ZeroDivide. 120262 self should: [ 1.2 / (1.3 - 1.3) ] raise: ZeroDivide 120263 ! ! 120264 120265!FloatTest methodsFor: 'testing - arithmetic' stamp: 'nice 12/1/2007 17:59'! 120266testRaisedTo 120267 "this is a test related to http://bugs.squeak.org/view.php?id=6781" 120268 120269 self should: [0.0 raisedTo: -1] raise: ZeroDivide. 120270 self should: [0.0 raisedTo: -1.0] raise: ZeroDivide.! ! 120271 120272 120273!FloatTest methodsFor: 'testing - conversion' stamp: 'nice 7/24/2008 02:04'! 120274testFloatRounded 120275 "5000000000000001 asFloat has an exact representation (no round off error). 120276 It should round to nearest integer without loosing bits. 120277 This is a no regression test on http://bugs.squeak.org/view.php?id=7134" 120278 120279 | x y int r | 120280 120281 "This is a preamble asserting exactness of representation 120282 and quality of various conversions" 120283 int := 5000000000000001. 120284 x := int asFloat. 120285 y := (5 asFloat squared squared squared squared timesTwoPower: 15) + 1. 120286 self assert: x = y. 120287 self assert: x asTrueFraction = int. 120288 120289 "this one should be true for any float 120290 in order to conform to ISO/IEC 10967-2" 120291 self assert: x rounded = x asTrueFraction rounded. 120292 self assert: x negated rounded = x negated asTrueFraction rounded. 120293 120294 "a random test" 120295 r := Random new. 120296 10000 timesRepeat: [ 120297 x := r next * 1.9999e16 + 1.0e12 . 120298 self assert: x rounded = x asTrueFraction rounded. 120299 self assert: x negated rounded = x negated asTrueFraction rounded]! ! 120300 120301!FloatTest methodsFor: 'testing - conversion' stamp: 'nice 4/26/2006 05:21'! 120302testFloatTruncated 120303 "(10 raisedTo: 16) asFloat has an exact representation (no round off error). 120304 It should convert back to integer without loosing bits. 120305 This is a no regression test on http://bugs.impara.de/view.php?id=3504" 120306 120307 | x y int r | 120308 int := 10 raisedTo: 16. 120309 x := int asFloat. 120310 y := (5 raisedTo: 16) asFloat timesTwoPower: 16. 120311 self assert: x = y. 120312 120313 self assert: x asInteger = int. 120314 120315 "this one should be true for any float" 120316 self assert: x asInteger = x asTrueFraction asInteger. 120317 120318 "a random test" 120319 r := Random new. 120320 10000 timesRepeat: [ 120321 x := r next * 1.9999e16 + 1.0e12 . 120322 self assert: x truncated = x asTrueFraction truncated]! ! 120323 120324!FloatTest methodsFor: 'testing - conversion' stamp: 'nice 5/7/2006 16:22'! 120325testFractionAsFloat 120326 "use a random test" 120327 120328 | r m frac err collec | 120329 r := Random new seed: 1234567. 120330 m := (2 raisedTo: 54) - 1. 120331 200 timesRepeat: [ 120332 frac := ((r nextInt: m) * (r nextInt: m) + 1) / ((r nextInt: m) * (r nextInt: m) + 1). 120333 err := (frac - frac asFloat asTrueFraction) * frac reciprocal * (1 bitShift: 52). 120334 self assert: err < (1/2)]. 120335 120336 collec := #(16r10000000000000 16r1FFFFFFFFFFFFF 1 2 16r20000000000000 16r20000000000001 16r3FFFFFFFFFFFFF 16r3FFFFFFFFFFFFE 16r3FFFFFFFFFFFFD). 120337 collec do: [:num | 120338 collec do: [:den | 120339 frac := Fraction numerator: num denominator: den. 120340 err := (frac - frac asFloat asTrueFraction) * frac reciprocal * (1 bitShift: 52). 120341 self assert: err <= (1/2)]].! ! 120342 120343!FloatTest methodsFor: 'testing - conversion' stamp: 'nice 1/10/2007 02:29'! 120344testFractionAsFloat2 120345 "test rounding to nearest even" 120346 120347 self assert: ((1<<52)+0+(1/4)) asFloat asTrueFraction = ((1<<52)+0). 120348 self assert: ((1<<52)+0+(1/2)) asFloat asTrueFraction = ((1<<52)+0). 120349 self assert: ((1<<52)+0+(3/4)) asFloat asTrueFraction = ((1<<52)+1). 120350 self assert: ((1<<52)+1+(1/4)) asFloat asTrueFraction = ((1<<52)+1). 120351 self assert: ((1<<52)+1+(1/2)) asFloat asTrueFraction = ((1<<52)+2). 120352 self assert: ((1<<52)+1+(3/4)) asFloat asTrueFraction = ((1<<52)+2).! ! 120353 120354!FloatTest methodsFor: 'testing - conversion' stamp: 'nice 5/6/2006 22:13'! 120355testIntegerAsFloat 120356 "assert IEEE 754 round to nearest even mode is honoured" 120357 120358 self deny: 16r1FFFFFFFFFFFF0801 asFloat = 16r1FFFFFFFFFFFF0800 asFloat. "this test is on 65 bits" 120359 self deny: 16r1FFFFFFFFFFFF0802 asFloat = 16r1FFFFFFFFFFFF0800 asFloat. "this test is on 64 bits" 120360 self assert: 16r1FFFFFFFFFFF1F800 asFloat = 16r1FFFFFFFFFFF20000 asFloat. "nearest even is upper" 120361 self assert: 16r1FFFFFFFFFFFF0800 asFloat = 16r1FFFFFFFFFFFF0000 asFloat. "nearest even is lower" 120362! ! 120363 120364!FloatTest methodsFor: 'testing - conversion' stamp: 'nice 3/14/2008 23:59'! 120365testReadFromManyDigits 120366 "A naive algorithm may interpret these representations as Infinity or NaN. 120367 This is http://bugs.squeak.org/view.php?id=6982" 120368 120369 | s1 s2 | 120370 s1 := '1' , (String new: 321 withAll: $0) , '.0e-321'. 120371 s2 := '0.' , (String new: 320 withAll: $0) , '1e321'. 120372 self assert: (Number readFrom: s1) = 1. 120373 self assert: (Number readFrom: s2) = 1.! ! 120374 120375!FloatTest methodsFor: 'testing - conversion' stamp: 'dtl 9/18/2004 12:40'! 120376testStringAsNumber 120377 "This covers parsing in Number>>readFrom:" 120378 120379 | aFloat | 120380 aFloat := '10r-12.3456' asNumber. 120381 self assert: -12.3456 = aFloat. 120382 aFloat := '10r-12.3456e2' asNumber. 120383 self assert: -1234.56 = aFloat. 120384 aFloat := '10r-12.3456d2' asNumber. 120385 self assert: -1234.56 = aFloat. 120386 aFloat := '10r-12.3456q2' asNumber. 120387 self assert: -1234.56 = aFloat. 120388 aFloat := '-12.3456q2' asNumber. 120389 self assert: -1234.56 = aFloat. 120390 aFloat := '12.3456q2' asNumber. 120391 self assert: 1234.56 = aFloat. 120392! ! 120393 120394 120395!FloatTest methodsFor: 'testing compare' stamp: 'nice 7/19/2009 19:24'! 120396testCloseTo 120397 self deny: (Float nan closeTo: Float nan) description: 'NaN isn''t close to anything'. 120398 self deny: (Float nan closeTo: 1.0) description: 'NaN isn''t close to anything'. 120399 self deny: (1.0 closeTo: Float nan) description: 'NaN isn''t close to anything'. 120400 120401 self deny: (-1.0 closeTo: 1.0). 120402 self deny: (1.0 closeTo: Float infinity). 120403 self assert: (Float infinity closeTo: Float infinity) description: 'since they are =, they also are closeTo:'. 120404 120405 self assert: (1.0/3.0 closeTo: 1/3). 120406 self assert: (1.0e-8 closeTo: 0). 120407 self assert: (0 closeTo: 1.0e-8). 120408 self assert: (1+1.0e-8 closeTo: 1.0). 120409 120410 self assert: (1000000001.0 closeTo: 1000000000.0). 120411 self deny: (1000000001 closeTo: 1000000000) description: 'exact representation are considered closeTo: only if equal'.! ! 120412 120413!FloatTest methodsFor: 'testing compare' stamp: 'nice 5/30/2008 01:23'! 120414testComparison 120415 120416 "test equality when Float conversion loose bits" 120417 | a b c | 120418 a := 16r1FFFFFFFFFFFFF1. 120419 b := 16r1FFFFFFFFFFFFF3. 120420 c := a asFloat. 120421 self assert: ((a = c) & (b = c)) ==> (a = b). 120422 120423 "Test equality when Float conversion exact" 120424 self assert: 16r1FFFFFFFFFFFFF = 16r1FFFFFFFFFFFFF asFloat. 120425 self assert: 16r1FFFFFFFFFFFFF = 16r1FFFFFFFFFFFFF asFloat asInteger. 120426 120427 "Test inequality when Float conversion loose bits" 120428 self assert: (((1 bitShift: 54)+1)/(1 bitShift: 54)) > 1. 120429 self assert: (((1 bitShift: 54)+1)/(1 bitShift: 54)) > 1.0. 120430 120431 self assert: (((1 bitShift: 54)-1)/(1 bitShift: 54)) < 1. 120432 self assert: (((1 bitShift: 54)-1)/(1 bitShift: 54)) < 1.0. 120433 120434 "Test exact vs inexact arithmetic" 120435 (1 to: 100) do: [:i | 120436 i isPowerOfTwo 120437 ifTrue: [self assert: (1/i) = (1/i) asFloat] 120438 ifFalse: [self deny: (1/i) = (1/i) asFloat]]. 120439 120440 "Test overflow (compare to infinity)" 120441 a := (11 raisedTo: 400) / 2. 120442 b := (13 raisedTo: 400) / 2. 120443 c := a asFloat. 120444 self assert: ((a = c) & (b = c)) ==> (a = b). 120445 120446 "every integer is smaller than infinity" 120447 self assert: a < Float infinity. 120448 self assert: a > Float infinity negated. 120449 120450 "Test underflow" 120451 self deny: 1 / (11 raisedTo: 400) = 0. 120452 self deny: 1 / (11 raisedTo: 400) = 0.0. 120453 120454 "Test hash code" 120455 self assert: 120456 ((Set new: 3) add: 3; add: 3.0; size) = 120457 ((Set new: 4) add: 3; add: 3.0; size).! ! 120458 120459!FloatTest methodsFor: 'testing compare' stamp: 'nice 7/10/2009 22:27'! 120460testComparisonWhenPrimitiveFails 120461 "This is related to http://bugs.squeak.org/view.php?id=7361" 120462 120463 self deny: 0.5 < (1/4). 120464 self deny: 0.5 < (1/2). 120465 self assert: 0.5 < (3/4). 120466 120467 self deny: 0.5 <= (1/4). 120468 self assert: 0.5 <= (1/2). 120469 self assert: 0.5 <= (3/4). 120470 120471 self assert: 0.5 > (1/4). 120472 self deny: 0.5 > (1/2). 120473 self deny: 0.5 > (3/4). 120474 120475 self assert: 0.5 >= (1/4). 120476 self assert: 0.5 >= (1/2). 120477 self deny: 0.5 >= (3/4). 120478 120479 self deny: 0.5 = (1/4). 120480 self assert: 0.5 = (1/2). 120481 self deny: 0.5 = (3/4). 120482 120483 self assert: 0.5 ~= (1/4). 120484 self deny: 0.5 ~= (1/2). 120485 self assert: 0.5 ~= (3/4).! ! 120486 120487 120488!FloatTest methodsFor: 'tests' stamp: 'nice 6/11/2009 01:36'! 120489testHash 120490 self assert: (2 = 2.0) ==> (2 hash = 2.0 hash). 120491 self assert: (1/2 = 0.5) ==> ((1/2) hash = 0.5 hash). 120492 120493 self shouldnt: [Float nan hash] raise: Error. 120494 self shouldnt: [Float infinity hash] raise: Error.! ! 120495 120496 120497!FloatTest methodsFor: 'zero behavior' stamp: 'md 4/16/2003 15:02'! 120498testIsZero 120499 self assert: 0.0 isZero. 120500 self deny: 0.1 isZero.! ! 120501 120502!FloatTest methodsFor: 'zero behavior' stamp: 'sd 6/5/2005 08:33'! 120503testZero1 120504 "FloatTest new testZero1" 120505 120506 self assert: Float negativeZero = 0 asFloat. 120507 self assert: (Float negativeZero at: 1) ~= (0 asFloat at: 1). 120508 120509 "The negative zero has a bit representation that is different from the bit representation of the positive zero. Nevertheless, both values are defined to be equal." 120510! ! 120511 120512!FloatTest methodsFor: 'zero behavior' stamp: 'nice 3/23/2008 16:00'! 120513testZeroSignificandAsInteger 120514 "This is about http://bugs.squeak.org/view.php?id=6990" 120515 120516 self assert: 0.0 significandAsInteger = 0! ! 120517ArithmeticError subclass: #FloatingPointException 120518 instanceVariableNames: '' 120519 classVariableNames: '' 120520 poolDictionaries: '' 120521 category: 'Exceptions-Kernel'! 120522Model subclass: #FontChooser 120523 instanceVariableNames: 'title selectedFontIndex fontList fontListStrings target getSelector setSelector pointSize fontStyleList selectedFontStyleIndex weightValue slantValue stretchValue pointSizeList' 120524 classVariableNames: '' 120525 poolDictionaries: '' 120526 category: 'FreeType-UI'! 120527 120528!FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 13:44'! 120529getSelector 120530 "Answer the value of getSelector" 120531 120532 ^ getSelector! ! 120533 120534!FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 20:16'! 120535getSelector: aSelectorSymbolOrFont 120536 "Set the value of getSelector" 120537 120538 getSelector := aSelectorSymbolOrFont! ! 120539 120540!FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 13:44'! 120541setSelector: anObject 120542 "Set the value of setSelector" 120543 120544 setSelector := anObject! ! 120545 120546!FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 13:44'! 120547target 120548 "Answer the value of target" 120549 120550 ^ target! ! 120551 120552!FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 13:44'! 120553target: anObject 120554 "Set the value of target" 120555 120556 target := anObject! ! 120557 120558!FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 13:44'! 120559title: anObject 120560 "Set the value of title" 120561 120562 title := anObject! ! 120563 120564 120565!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 13:46'! 120566apply 120567 | font | 120568 target ifNotNil:[ 120569 setSelector ifNotNil:[ 120570 font := self selectedFont. 120571 font ifNotNil:[ 120572 target perform: setSelector with: font]]].! ! 120573 120574!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 10:35'! 120575categoryList 120576 ^OrderedCollection new 120577 "add: self allCategoryLabel; 120578 addAll: preferences categoryNames asSortedCollection; 120579 add: self searchResultsCategoryLabel;" 120580 addAll: (TextStyle actualTextStyles keysSortedSafely); 120581 yourself.! ! 120582 120583!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 9/8/2007 15:14'! 120584fontList 120585 120586 fontList ifNotNil:[^fontList]. 120587 ^fontList := LogicalFontManager current allFamilies! ! 120588 120589!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/16/2007 22:30'! 120590fontListStrings 120591 120592 ^fontListStrings ifNil:[ 120593 fontListStrings := self fontList collect:[:each | each familyName]]! ! 120594 120595!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/19/2007 16:22'! 120596fontStyleList 120597 | family | 120598 family := self selectedFontFamily. 120599 family ifNotNil:[^fontStyleList := family members asSortedCollection]. 120600 ^#()! ! 120601 120602!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/17/2007 00:15'! 120603fontStyleListStrings 120604 "names of simulated styles are enclosed in parenthesis" 120605 ^self fontStyleList collect: [:fontFamilyMember | | s | 120606 s := fontFamilyMember styleName. 120607 fontFamilyMember simulated 120608 ifTrue:[s := '(', s, ')']. 120609 s]! ! 120610 120611!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 10:27'! 120612initialize 120613 super initialize. 120614 title := 'Choose A Font'.! ! 120615 120616!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 15:23'! 120617pointSize 120618 ^pointSize ifNil: [pointSize := 10.0]! ! 120619 120620!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 17:34'! 120621pointSize: aNumber 120622 pointSize := aNumber. 120623 self changed: #pointSize! ! 120624 120625!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/27/2007 23:50'! 120626pointSizeList 120627 120628 ^pointSizeList ifNil:[ pointSizeList := (1 to: 256) collect: [:each | each asString padded: #left to: 3 with: $ ]]! ! 120629 120630!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/18/2007 11:18'! 120631selectedFont 120632 | font style | 120633 120634 font := self unemphasizedSelectedFont. 120635 font ifNil:[^nil]. 120636 style := self fontStyleList at: self selectedFontStyleIndex ifAbsent:[nil]. 120637 style ifNil:[^nil]. 120638 (style isKindOf: TextStyleAsFontFamilyMember) 120639 ifTrue:[ ^font emphasized: style emphasisCode]. 120640 ^LogicalFont 120641 familyName: font familyName 120642 pointSize: pointSize 120643 stretchValue: style stretchValue 120644 weightValue: style weightValue 120645 slantValue: style slantValue 120646 120647 ! ! 120648 120649!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/16/2007 22:42'! 120650selectedFontFamily 120651 | | 120652 120653 ^self fontList at: self selectedFontIndex ifAbsent:[nil]. 120654 120655 ! ! 120656 120657!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/28/2007 00:20'! 120658selectedFontIndex 120659 | font textStyleName family | 120660 selectedFontIndex ifNotNil: [^selectedFontIndex]. 120661 selectedFontIndex := 0. 120662 font := (getSelector isSymbol and:[target notNil]) 120663 ifTrue:[target perform: getSelector] 120664 ifFalse:[getSelector]. 120665 self setStyleValuesFrom: font. 120666 (font isKindOf: AbstractFont) 120667 ifTrue:[ 120668 pointSize := font pointSize. 120669 textStyleName := font textStyleName. 120670 family := self fontList detect:[:f | f familyName = textStyleName] ifNone:[]. 120671 selectedFontIndex := self fontList indexOf: family ifAbsent:[0]]. 120672 self selectedFontIndex: selectedFontIndex. 120673 ^selectedFontIndex! ! 120674 120675!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/28/2007 00:11'! 120676selectedFontIndex: anIndex 120677 | family member newStyleIndex | 120678 anIndex = 0 120679 ifTrue: [^self]. 120680 selectedFontIndex := anIndex. 120681 "change the selected style to be the closest to the last 120682 user selected weight slant and stretch values. 120683 By user selected I mean that the user changed the style list selection, 120684 rather than a change being forced because a particular family didn't have that style" 120685 family := self fontList at: selectedFontIndex. 120686 member := family closestMemberWithStretchValue: stretchValue weightValue: weightValue slantValue: slantValue. 120687 newStyleIndex := self fontStyleList indexOf: member. 120688 selectedFontStyleIndex := newStyleIndex. 120689 self setPointSizeListFrom: member. 120690 self changed: #selectedFontIndex. 120691 self changed: #selectedFontStyleIndex.! ! 120692 120693!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/19/2007 16:23'! 120694selectedFontStyleIndex 120695 | family member | 120696 selectedFontStyleIndex ifNotNil: [ 120697 ^selectedFontStyleIndex := selectedFontStyleIndex min: self fontStyleList size]. 120698 family := self fontList at: selectedFontIndex ifAbsent:[^0]. 120699 member := family closestMemberWithStretchValue: stretchValue weightValue: weightValue slantValue: slantValue. 120700 selectedFontStyleIndex := self fontStyleList indexOf: member. 120701 ^selectedFontStyleIndex! ! 120702 120703!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/18/2007 12:07'! 120704selectedFontStyleIndex: anIndex 120705 | familyMember | 120706 anIndex = 0 120707 ifTrue: [^self]. 120708 selectedFontStyleIndex := anIndex. 120709 familyMember := self fontStyleList at: anIndex. 120710 self setStyleValuesFrom: familyMember. 120711 self changed: #selectedFontStyleIndex! ! 120712 120713!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/27/2007 23:12'! 120714selectedPointSize 120715 ^self selectedFont pointSize! ! 120716 120717!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/28/2007 00:08'! 120718selectedPointSizeIndex 120719 ^self pointSizeList indexOf: (pointSize reduce asString padded: #left to: 3 with: $ )! ! 120720 120721!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/28/2007 00:06'! 120722selectedPointSizeIndex: anIndex 120723 120724 anIndex = 0 120725 ifTrue: [^self]. 120726 pointSize := (self pointSizeList at: anIndex) withBlanksTrimmed asNumber. 120727 self changed: #pointSize! ! 120728 120729!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/28/2007 00:12'! 120730setPointSizeListFrom: aFontFamilyMember 120731 | style old new | 120732 old := pointSizeList. 120733 (aFontFamilyMember isKindOf: FontFamilyMemberAbstract) 120734 ifTrue:[ 120735 style := TextStyle named: aFontFamilyMember family familyName. 120736 style ifNotNil:[ 120737 new := style pointSizes collect: [:each | each reduce asString padded: #left to: 3 with: $ ]]]. 120738 new ifNil:[new := (1 to: 256) collect: [:each | each asString padded: #left to: 3 with: $ ]]. 120739 pointSizeList := new. 120740 old ~= new ifTrue:[self changed: #pointSizeList]! ! 120741 120742!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/18/2007 13:49'! 120743setStyleValuesFrom: aFont 120744 ((aFont isKindOf: LogicalFont) or:[aFont isKindOf: FontFamilyMemberAbstract]) 120745 ifTrue:[ 120746 weightValue := aFont weightValue. 120747 slantValue := aFont slantValue. 120748 stretchValue := aFont stretchValue] 120749 ifFalse:[ 120750 weightValue := (aFont emphasis bitAnd: 1) > 0 ifTrue:[700] ifFalse:[400]. 120751 slantValue := (aFont emphasis bitAnd: 2) > 0 ifTrue:[1] ifFalse:[0]. 120752 stretchValue := 5 "normal"]! ! 120753 120754!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/18/2007 21:10'! 120755unemphasizedSelectedFont 120756 |name font family | 120757 family := self fontList at: self selectedFontIndex ifAbsent:[nil]. 120758 family ifNil:[^nil]. 120759 (family isKindOf: TextStyleAsFontFamily) 120760 ifTrue:[^family textStyle fontOfPointSize: pointSize]. 120761 name := family familyName. 120762 font := LogicalFont 120763 familyName: name 120764 pointSize: pointSize 120765 stretchValue: 5 120766 weightValue: 400 120767 slantValue: 0. 120768 font realFont isTTCFont "true for FreeTypeFont" 120769 ifFalse: [font := font textStyle fontOfPointSize: pointSize]. 120770 ^font 120771! ! 120772 120773!FontChooser methodsFor: 'as yet unclassified' stamp: 'RobRothwell 12/15/2008 22:54'! 120774updateFontList 120775 FreeTypeFontProvider current updateFromSystem.! ! 120776 120777!FontChooser methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 10:27'! 120778windowTitle 120779 ^ title translated! ! 120780 120781"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 120782 120783FontChooser class 120784 instanceVariableNames: ''! 120785 120786!FontChooser class methodsFor: 'as yet unclassified' stamp: 'tween 2/10/2008 11:13'! 120787open 120788 " 120789 FontChooser open. 120790 " 120791 | instance morph | 120792 instance := self new. 120793 (morph := FontChooserMorph withModel: instance) 120794 openInWorld. 120795 ^morph! ! 120796 120797!FontChooser class methodsFor: 'as yet unclassified' stamp: 'RobRothwell 12/15/2008 23:21'! 120798openWithWindowTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector 120799 " 120800 FontChooser openWithWindowTitle: 'Choose the Menu Font' for: Preferences setSelector: #setMenuFontTo: getSelector: #standardMenuFont 120801 " 120802 | instance windowMorph world | 120803 instance := self new. 120804 instance 120805 title: titleString; 120806 target: anObject; 120807 setSelector: setSelector; 120808 getSelector: getSelector. 120809 world := self currentWorld. 120810 (windowMorph := FontChooserMorph withModel: instance) 120811 "position: self currentWorld primaryHand position;" 120812 position: ((World width-640)/2)@((World height-480)/2); 120813 extent: 640@480; 120814 openAsMorph. 120815 ^windowMorph 120816 " [windowMorph model notNil] 120817 whileTrue: [ world doOneCycle]. self halt. 120818 ^windowMorph result"! ! 120819 120820!FontChooser class methodsFor: 'as yet unclassified' stamp: 'tween 3/2/2008 10:43'! 120821windowTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector 120822 | instance answer | 120823 120824 instance := self new. 120825 instance 120826 title: titleString; 120827 target: anObject; 120828 setSelector: setSelector; 120829 getSelector: getSelector. 120830 (answer := FontChooserMorph withModel: instance) 120831 position: self currentWorld primaryHand position; 120832 extent: 450@220; 120833 createWindow. 120834 ^answer! ! 120835SystemWindow subclass: #FontChooserMorph 120836 instanceVariableNames: 'mainPanel fontPreviewPanel okButton cancelButton applyButton updateButton result pointSizeMorph pointSizeSlider fontListStylePanel styleList pointSizeList' 120837 classVariableNames: '' 120838 poolDictionaries: '' 120839 category: 'FreeType-UI'! 120840 120841!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 20:28'! 120842apply 120843 result := model selectedFont. 120844 model apply! ! 120845 120846!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 13:49'! 120847applyButton 120848 ^applyButton ifNil: [ 120849 applyButton := self basicButton 120850 label: ' Apply ' translated; 120851 target:self; 120852 actionSelector: #applyButtonClicked; 120853 setBalloonText: 120854 'Click here to apply your selection without closing this dialog' translated]! ! 120855 120856!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 13:49'! 120857applyButtonClicked 120858 self apply. 120859 ! ! 120860 120861!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/27/2007 16:46'! 120862basicButton 120863 | button | 120864 button := SimpleButtonMorph new. 120865 button 120866 borderWidth: 2; 120867 borderColor: #raised; 120868 on: #mouseEnter send: #value to: [button borderColor: self paneColor]; 120869 on: #mouseLeave send: #value to: [button borderColor: #raised]; 120870 "vResizing: #shrinkWrap;" 120871 useRoundedCorners; 120872 clipSubmorphs: true; 120873 color: self paneColor lighter; 120874 target: self model. 120875 ^button 120876 ! ! 120877 120878!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 13:31'! 120879cancelButton 120880 ^cancelButton ifNil: [ 120881 cancelButton := self basicButton 120882 label: ' Cancel ' translated; 120883 target:self; 120884 actionSelector: #cancelButtonClicked; 120885 setBalloonText: 120886 'Click here to cancel and close this dialog' translated]! ! 120887 120888!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 20:27'! 120889cancelButtonClicked 120890 result :=nil. 120891 self delete 120892 ! ! 120893 120894!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'RobRothwell 12/15/2008 23:11'! 120895createWindow 120896 "Create the package loader window." 120897 | buttonBarHeight b | 120898 120899 buttonBarHeight := Preferences standardDefaultTextFont height + 22. 120900 self addMorph: (self newFontList borderWidth: 0) 120901 frame: (0.0 @ 0.0 corner: 0.5 @ 0.4) . 120902 self addMorph: ((styleList := self newFontStyleList) borderWidth: 0) 120903 frame: (0.5 @ 0.0 corner: 0.9 @ 0.4). 120904 self addMorph: (pointSizeList := self newPointSizeList borderWidth:0) 120905 frame: (0.9 @ 0.0 corner: 1.0 @ 0.4). 120906 self addMorph: (self fontPreviewPanel borderWidth: 0) 120907 fullFrame: (LayoutFrame fractions: (0@0.4 corner: 1.0@1.0) offsets: (0@0 corner: 0@buttonBarHeight negated)). 120908 120909 self addMorph: (applyButton:=self applyButton) 120910 fullFrame: (LayoutFrame fractions: (0@1.0 corner: 0.25@1.0) offsets: (10@(buttonBarHeight negated + 2) corner: -10@-4)). 120911 applyButton color: self paneColor darker. 120912 120913 self addMorph: (okButton :=self okButton) 120914 fullFrame: (LayoutFrame fractions: (0.25@1.0 corner: 0.50@1.0) offsets: (10@(buttonBarHeight negated + 2) corner: -10@-4)). 120915 okButton color: self paneColor darker. 120916 120917 self addMorph: (cancelButton :=self cancelButton) 120918 fullFrame: (LayoutFrame fractions: (0.50@1.0 corner: 0.75@1.0) offsets: (10@(buttonBarHeight negated + 2) corner: -10@-4)). 120919 cancelButton color: self paneColor darker. 120920 120921 self addMorph: (updateButton:=self updateButton) 120922 fullFrame: (LayoutFrame fractions: (0.75@1.0 corner: 1.0@1.0) offsets: (10@(buttonBarHeight negated + 2) corner: -10@-4)). 120923 updateButton color: self paneColor darker. 120924 120925 self addMorph: (b :=Morph new) 120926 fullFrame: (LayoutFrame fractions: (0@1.0 corner: 1.0@1.0) offsets: (4@buttonBarHeight negated - 4 corner: 0@0)). 120927 120928 120929 b color: self paneColor lighter. 120930 updateButton comeToFront. 120931" applyButton comeToFront." 120932 okButton comeToFront. 120933 cancelButton comeToFront. 120934 self on: #mouseEnter send: #paneTransition: to: self. 120935 self on: #mouseLeave send: #paneTransition: to: self! ! 120936 120937!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 20:25'! 120938delete 120939 model := nil. 120940 super delete 120941 ! ! 120942 120943!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 11:24'! 120944fontPreviewPanel 120945 ^fontPreviewPanel ifNil: 120946 [fontPreviewPanel := ScrollPane new 120947 color: Color white; 120948 borderInset; 120949 vResizing: #spaceFill; 120950 hResizing: #spaceFill. 120951 fontPreviewPanel scroller 120952 on: #mouseEnter send: #value: 120953 to: [:event | event hand newKeyboardFocus: fontPreviewPanel scroller]; 120954 on: #keyStroke send: #keyPressed: to: self. 120955 fontPreviewPanel.]! ! 120956 120957!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 3/2/2008 19:16'! 120958initializeLabelArea 120959 super initializeLabelArea. 120960 collapseBox hide. " need to keep collapseBox for title bar to display correctly?" 120961 expandBox delete. 120962 menuBox delete. 120963 expandBox := nil. 120964 collapseBox := nil.! ! 120965 120966!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/27/2007 23:29'! 120967initializeWithModel: aFontChooser 120968 self 120969 model: aFontChooser; 120970 clipSubmorphs: true; 120971 setLabel: self model windowTitle; 120972 name: 'FontChooser'. 120973 self updatePreview! ! 120974 120975!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/27/2007 13:43'! 120976newFontList 120977 | answer fon max | 120978 answer := PluggableListMorph 120979 on: self model 120980 list: #fontListStrings 120981 selected: #selectedFontIndex 120982 changeSelected: #selectedFontIndex:. 120983 fon := answer font. 120984 max := 20. 120985 model fontList do:[:each | 120986 max := max max: (fon widthOfStringOrText: each familyName)]. 120987 answer 120988 color: Color white; 120989 borderInset; 120990 vResizing: #spaceFill; 120991 hResizing: #spaceFill; 120992 "hResizing: #rigid;" 120993 width: max + answer scrollBarThickness + (fon widthOfStringOrText: ' '); 120994 yourself. 120995 ^answer! ! 120996 120997!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/27/2007 13:13'! 120998newFontPointSizeField 120999 | answer | 121000 121001 answer := (PluggableTextMorph on: self text: #pointSizeString accept: #pointSizeString:) 121002 acceptOnCR: true; 121003 hideVScrollBarIndefinitely: true; 121004 color: Color gray veryMuchLighter; 121005 borderColor: #inset; 121006 vResizing: #rigid; 121007 hResizing: #spaceFill; 121008 width: (TextStyle defaultFont widthOfString: '99999999.99'); 121009 height: TextStyle defaultFont height + 6; 121010 "wrapFlag: true;" 121011 "autoFit: false;" 121012 "margins: 2@2;" 121013 "borderWidth: 1;" 121014 "contents: model pointSize asString;" 121015 yourself. 121016 ^answer! ! 121017 121018!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/27/2007 13:14'! 121019newFontPointSizeLabel 121020 ^StringMorph contents: 'Point size:' translated.! ! 121021 121022!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'PeterHugossonMiller 9/3/2009 01:33'! 121023newFontPreviewInnerPanel 121024 | sample i c f | 121025 sample := String new writeStream. 121026 f := model selectedFont. 121027 f isNil ifTrue:[^TextMorph new contents:''; yourself]. 121028 f isSymbolFont 121029 ifFalse:[ 121030 sample 121031 nextPutAll: 'the quick brown fox jumps over the lazy dog' ;cr; 121032 nextPutAll: 'THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG.' ;cr]. 121033 i := 0. 121034 33 to: 255 do:[:ci | 121035 sample nextPut: (c:=Character value: ci). 121036 i := i + 1. 121037 (('@Z`z' includes:c) or:[i = 30]) 121038 ifTrue:[i :=0. sample cr]]. 121039 sample := sample contents asText. 121040 "(f weightValue >= 700) ifTrue:[sample addAttribute: TextEmphasis bold]. 121041 (f slantValue ~= 0) ifTrue:[sample addAttribute: TextEmphasis italic]." 121042 ^TextMorph new 121043 contents: sample; 121044 beAllFont: f; 121045 yourself! ! 121046 121047!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/27/2007 13:13'! 121048newFontSizePanel 121049 ^Morph new 121050 borderWidth: 1; 121051 borderColor: Color black; 121052 hResizing: #spaceFill; 121053 vResizing: #shrinkwrap; 121054 color: Color transparent; 121055 layoutPolicy: TableLayout new; 121056 cellInset: 0; 121057 listCentering: #topLeft; 121058 listDirection: #leftToRight; 121059 cellPositioning: #leftCenter; 121060 clipSubmorphs: true; 121061 "addMorphBack: self newFontEmphasisBoldButton; 121062 addMorphBack: self newFontEmphasisItalicButton;" 121063 addMorphBack: self newFontPointSizeLabel; 121064 addMorphBack: (pointSizeMorph := self newFontPointSizeField) 121065 ! ! 121066 121067!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/27/2007 13:42'! 121068newFontStyleList 121069 | answer fon max | 121070 answer := PluggableListMorph 121071 on: self model 121072 list: #fontStyleListStrings 121073 selected: #selectedFontStyleIndex 121074 changeSelected: #selectedFontStyleIndex:. 121075 fon := answer font. 121076 max := fon widthOfStringOrText: 'Condensed Extra Bold Oblique' "long, but not the longest". 121077 model fontStyleList do:[:fontFamilyMember | 121078 max := max max: (fon widthOfStringOrText: fontFamilyMember styleName)]. 121079 answer 121080 color: Color white; 121081 borderInset; 121082 vResizing: #spaceFill; 121083 hResizing: #spaceFill; 121084 "hResizing: #rigid;" 121085 width: max + answer scrollBarThickness + (fon widthOfStringOrText: ' '); 121086 yourself. 121087 ^answer! ! 121088 121089!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/27/2007 23:22'! 121090newPointSizeList 121091 | answer | 121092 answer := PluggableListMorph 121093 on: self model 121094 list: #pointSizeList 121095 selected: #selectedPointSizeIndex 121096 changeSelected: #selectedPointSizeIndex:. 121097 answer 121098 color: Color white; 121099 borderInset; 121100 vResizing: #spaceFill; 121101 hResizing: #spaceFill; 121102 yourself. 121103 ^answer! ! 121104 121105!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 13:22'! 121106newSeparator 121107 ^BorderedMorph new 121108 borderWidth: 2; 121109 borderColor: Color transparent; 121110 color: self paneColor; 121111 hResizing: #rigid; 121112 width: 5; 121113 vResizing: #spaceFill; 121114 yourself! ! 121115 121116!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 13:31'! 121117okButton 121118 ^okButton ifNil: [ 121119 okButton := self basicButton 121120 label: ' OK ' translated; 121121 target:self; 121122 actionSelector: #okButtonClicked; 121123 setBalloonText: 121124 'Click here to close this dialog, and accept your selection' translated]! ! 121125 121126!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 13:37'! 121127okButtonClicked 121128 self apply. 121129 self delete 121130 ! ! 121131 121132!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/27/2007 17:19'! 121133openAsMorph 121134 ^self createWindow openAsIsIn: self currentWorld! ! 121135 121136!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/27/2007 22:58'! 121137paneColor 121138 ^Color blue muchLighter! ! 121139 121140!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 22:47'! 121141pointSizeSlider: aNumber 121142 121143 (aNumber < 1 or:[ aNumber > 1024]) 121144 ifTrue:[^self]. 121145 pointSizeMorph ifNotNil:[ 121146 pointSizeMorph 121147 setText: aNumber asString asText; 121148 hasUnacceptedEdits: false]. 121149 model pointSize: aNumber! ! 121150 121151!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 17:33'! 121152pointSizeString 121153 ^model pointSize asString! ! 121154 121155!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 22:27'! 121156pointSizeString: aText 121157 | s n| 121158 121159 s := aText asString withBlanksTrimmed. 121160 s isEmpty ifTrue:[^self]. 121161 (s detect:[:c | c isDigit not and:[c ~= $.]] ifNone:[]) ifNotNil:[^self]. 121162 [n := s asNumber asFloat] on: Error do:[:e | ^self]. 121163 (n < 1 or:[ n > 1024]) 121164 ifTrue:[^self]. 121165 pointSizeMorph ifNotNil:[pointSizeMorph hasUnacceptedEdits: false]. 121166 model pointSize: n! ! 121167 121168!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 3/2/2008 19:16'! 121169replaceBoxes 121170 super replaceBoxes. 121171 collapseBox hide. " need to keep collapseBox for title bar to display correctly?" 121172! ! 121173 121174!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 20:28'! 121175result 121176 ^result! ! 121177 121178!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/28/2007 00:02'! 121179update: aSymbol 121180 super update: aSymbol. 121181 aSymbol == #selectedFontIndex 121182 ifTrue: [ 121183 styleList ifNotNil:[styleList updateList]. 121184 pointSizeList ifNotNil:[pointSizeList updateList]. 121185 self updatePreview]. 121186 aSymbol == #selectedFontStyleIndex 121187 ifTrue: [ 121188 self updatePreview]. 121189 aSymbol == #pointSize 121190 ifTrue: [ 121191 pointSizeList ifNotNil:[pointSizeList selectionIndex: model selectedPointSizeIndex]. 121192 self updatePreview]. 121193 aSymbol == #pointSizeList 121194 ifTrue: [ 121195 pointSizeList ifNotNil:[pointSizeList updateList]. 121196 self updatePreview].! ! 121197 121198!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'RobRothwell 12/15/2008 22:57'! 121199updateButton 121200 ^updateButton ifNil: [ 121201 updateButton := self basicButton 121202 label: ' Update ' translated; 121203 target:self; 121204 actionSelector: #updateButtonClicked; 121205 setBalloonText: 121206 'Click here to rescan Font Folder and update the font list' translated]! ! 121207 121208!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'RobRothwell 12/15/2008 23:01'! 121209updateButtonClicked 121210 self updateFontList. 121211 ! ! 121212 121213!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'RobRothwell 12/15/2008 22:55'! 121214updateFontList 121215 model updateFontList! ! 121216 121217!FontChooserMorph methodsFor: 'as yet unclassified' stamp: 'tween 8/27/2007 23:26'! 121218updatePreview 121219 121220 Cursor wait showWhile: 121221 [ 121222 self fontPreviewPanel 121223 hScrollBarValue: 0; 121224 vScrollBarValue: 0. 121225 self fontPreviewPanel scroller removeAllMorphs. 121226 self fontPreviewPanel scroller addMorphBack: self newFontPreviewInnerPanel]! ! 121227 121228"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 121229 121230FontChooserMorph class 121231 instanceVariableNames: ''! 121232 121233!FontChooserMorph class methodsFor: 'as yet unclassified' stamp: 'tween 8/4/2007 10:24'! 121234withModel: aFontChooser 121235 ^self new 121236 initializeWithModel: aFontChooser; 121237 yourself.! ! 121238Object subclass: #FontFamilyAbstract 121239 instanceVariableNames: 'familyName members' 121240 classVariableNames: '' 121241 poolDictionaries: '' 121242 category: 'FreeType-FontManager'! 121243 121244!FontFamilyAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:46'! 121245familyName 121246 "Answer the value of familyName" 121247 121248 ^ familyName! ! 121249 121250!FontFamilyAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:46'! 121251familyName: anObject 121252 "Set the value of familyName" 121253 121254 familyName := anObject! ! 121255 121256!FontFamilyAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:47'! 121257members 121258 "Answer the value of members" 121259 121260 ^ members! ! 121261 121262 121263!FontFamilyAbstract methodsFor: 'member lookup' stamp: 'tween 8/18/2007 13:50'! 121264closestMemberWithStretchValue: stretchValue weightValue: weightValue slantValue: slantValue 121265 "answer the member that has weight, slant and stretch values that most closely 121266 match those given by stretchValue, weightValue, and slantValue" 121267 121268 ^(self members asSortedCollection:[:a :b | 121269 a isCloserMatchThan: b 121270 toStretch: stretchValue 121271 weight: weightValue 121272 slant: slantValue]) first. ! ! 121273 121274 121275!FontFamilyAbstract methodsFor: 'printing' stamp: 'tween 9/7/2007 19:36'! 121276printOn: aStream 121277 aStream 121278 nextPutAll: self class name asString; 121279 nextPut: $ ; 121280 nextPutAll: self familyName printString! ! 121281Object subclass: #FontFamilyMemberAbstract 121282 instanceVariableNames: 'family styleName' 121283 classVariableNames: '' 121284 poolDictionaries: '' 121285 category: 'FreeType-FontManager'! 121286 121287!FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 8/25/2007 14:22'! 121288family 121289 ^family! ! 121290 121291!FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 8/25/2007 14:22'! 121292family: aFontFamily 121293 family := aFontFamily! ! 121294 121295!FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 9/8/2007 13:24'! 121296slantValue 121297 self subclassResponsibility! ! 121298 121299!FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 9/8/2007 13:24'! 121300stretchValue 121301 self subclassResponsibility! ! 121302 121303!FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:41'! 121304styleName 121305 "Answer the value of styleName" 121306 121307 ^ styleName! ! 121308 121309!FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:41'! 121310styleName: anObject 121311 "Set the value of styleName" 121312 121313 styleName := anObject! ! 121314 121315!FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 9/8/2007 13:24'! 121316weightValue 121317 self subclassResponsibility! ! 121318 121319 121320!FontFamilyMemberAbstract methodsFor: 'comparing' stamp: 'tween 8/18/2007 13:42'! 121321closenessVector 121322 ^self closenessVectorForStretch: self stretchValue slant: self slantValue weight: self weightValue! ! 121323 121324!FontFamilyMemberAbstract methodsFor: 'comparing' stamp: 'tween 9/29/2007 13:00'! 121325closenessVectorForStretch: stretch slant: slant weight: weight 121326 | normalizedSlant | 121327 normalizedSlant := slant. 121328 normalizedSlant ~= 0 ifTrue:[ 121329 "treat italic and oblique as though they were they same" 121330 normalizedSlant := LogicalFont slantItalic]. 121331 ^{(stretch - LogicalFont stretchRegular) * 11. slant * 7. ((weight - LogicalFont weightRegular) / 100) * 5}! ! 121332 121333!FontFamilyMemberAbstract methodsFor: 'comparing' stamp: 'tween 8/18/2007 13:43'! 121334isCloserMatchThan: otherMember toStretch: inputStretch weight: inputWeight slant: inputSlant 121335 | inputVector vector otherVector distance otherDistance dotProduct otherDotProduct | 121336 121337 inputVector := self closenessVectorForStretch: inputStretch slant: inputSlant weight: inputWeight. 121338 vector := self closenessVector. 121339 otherVector := otherMember closenessVector. 121340 distance := (((inputVector first - vector first) raisedTo: 2) + 121341 ((inputVector second - vector second) raisedTo: 2) + 121342 ((inputVector third - vector third) raisedTo: 2)) sqrt. 121343 otherDistance := (((inputVector first - otherVector first) raisedTo: 2) + 121344 ((inputVector second - otherVector second) raisedTo: 2) + 121345 ((inputVector third - otherVector third) raisedTo: 2)) sqrt. 121346 distance < otherDistance ifTrue:[^true]. 121347 distance > otherDistance ifTrue:[^false]. 121348 dotProduct := (inputVector first * vector first) + 121349 (inputVector second * vector second) + 121350 (inputVector third * vector third). 121351 otherDotProduct := (inputVector first * otherVector first) + 121352 (inputVector second * otherVector second) + 121353 (inputVector third * otherVector third). 121354 dotProduct > otherDotProduct ifTrue:[^true]. 121355 dotProduct < otherDotProduct ifTrue:[^false]. 121356 vector first > otherVector first ifTrue:[^true]. 121357 vector first < otherVector first ifTrue:[^false]. 121358 vector second > otherVector second ifTrue:[^true]. 121359 vector second < otherVector second ifTrue:[^false]. 121360 vector third > otherVector third ifTrue:[^true]. 121361 vector third < otherVector third ifTrue:[^false]. 121362 ^false ! ! 121363 121364 121365!FontFamilyMemberAbstract methodsFor: 'converting' stamp: 'tween 9/8/2007 13:25'! 121366asLogicalFontOfPointSize: pointSize 121367 ^LogicalFont 121368 familyName: self family familyName 121369 pointSize: pointSize 121370 stretchValue: self stretchValue 121371 weightValue: self weightValue 121372 slantValue: self slantValue! ! 121373Object subclass: #FontProviderAbstract 121374 instanceVariableNames: '' 121375 classVariableNames: '' 121376 poolDictionaries: '' 121377 category: 'FreeType-FontManager'! 121378!FontProviderAbstract commentStamp: 'tween 3/14/2007 22:59' prior: 0! 121379Abstract superClass for fontProviders 121380 examples of possible fontProviders are 121381 StrikeFontProvider 121382 FreeTypeFontProvider 121383 Win32NativeFontProvider 121384 ! 121385 121386 121387!FontProviderAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 22:00'! 121388families 121389 self subclassResponsibility! ! 121390 121391 121392!FontProviderAbstract methodsFor: 'font lookup' stamp: 'tween 3/16/2007 17:57'! 121393fontFor: aLogicalFont 121394 ^nil! ! 121395Object subclass: #FontSet 121396 instanceVariableNames: '' 121397 classVariableNames: '' 121398 poolDictionaries: '' 121399 category: 'Graphics-Fonts'! 121400!FontSet commentStamp: '<historical>' prior: 0! 121401FontSet provides a mechanism for storing a set of fonts as a class that can be conveniently filedOut, filedIn, and installed as a TextStyle. 121402 121403The most common use is... 121404 Find a font you like. 121405 Use BitFont to convert a bunch of sizes to data files named, eg, LovelyNN.BF 121406 Use FontSet convertFontsNamed: 'Lovely' to produce a FontSet named Lovely. 121407 FileOut that FontSet for later use. 121408 Use Lovely installAsTextStyle to make all sizes available in a TextStyle 121409 named #Lovely in the TextConstants dictionary. 121410 Use ctrl-k in any text pane to select the new Lovely style for that paragraph. 121411 Then use cmd-1 through 5 or cmd-k to set the point-size for any selection. 121412! 121413 121414 121415"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 121416 121417FontSet class 121418 instanceVariableNames: ''! 121419 121420!FontSet class methodsFor: 'as yet unclassified' stamp: 'di 9/15/97 12:01'! 121421convertFontsNamed: familyName "FontSet convertFontsNamed: 'Palatino' " 121422 ^ self convertFontsNamed: familyName inDirectoryNamed: ''! ! 121423 121424 121425!FontSet class methodsFor: 'compiling' stamp: 'sma 12/29/1999 11:48'! 121426acceptsLoggingOfCompilation 121427 "Dont log sources for my subclasses, so as not to waste time 121428 and space storing printString versions of the string literals." 121429 121430 ^ self == FontSet! ! 121431 121432!FontSet class methodsFor: 'compiling' stamp: 'lr 7/4/2009 10:42'! 121433compileFont: strikeFont 121434 | tempName literalString header sizeStr familyName | 121435 tempName := 'FontTemp.sf2'. 121436 strikeFont writeAsStrike2named: tempName. 121437 literalString := (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: tempName) binary) contents fullPrintString. 121438 sizeStr := strikeFont pointSize asString. 121439 familyName := strikeFont name first: (strikeFont name findLast: [ :x | x isDigit not ]). 121440 header := 'size' , sizeStr , ' 121441 ^ self fontNamed: ''' , familyName , sizeStr , ''' fromMimeLiteral: 121442'. 121443 self class 121444 compile: header , literalString 121445 classified: 'fonts' 121446 notifying: nil. 121447 FileDirectory default deleteFileNamed: tempName! ! 121448 121449 121450!FontSet class methodsFor: 'converting' stamp: 'lr 7/4/2009 10:42'! 121451convertFontsNamed: familyName inDirectoryNamed: dirName 121452 "FontSet convertFontsNamed: 'Tekton' inDirectoryNamed: 'Tekton Fonts' " 121453 "This utility is for use after you have used BitFont to produce data files 121454 for the fonts you wish to use. It will read the BitFont files and build 121455 a fontset class from them. If one already exists, the sizes that can be 121456 found will be overwritten." 121457 "For this utility to work as is, the BitFont data files must be named 'familyNN.BF', 121458 and must reside in the directory named by dirName (use '' for the current directory)." 121459 "Check first for matching file names and usable FontSet class name." 121460 | allFontNames fontSet dir | 121461 dir := dirName isEmpty 121462 ifTrue: [ FileDirectory default ] 121463 ifFalse: [ FileDirectory default directoryNamed: dirName ]. 121464 allFontNames := dir fileNamesMatching: familyName , '##.BF'. 121465 allFontNames isEmpty ifTrue: [ ^ self error: 'No files found like ' , familyName , 'NN.BF' ]. 121466 fontSet := self fontSetClass: familyName. 121467 allFontNames do: 121468 [ :each | 121469 Transcript 121470 cr; 121471 show: each. 121472 fontSet compileFont: (StrikeFont new readFromBitFont: (dir fullNameFor: each)) ]! ! 121473 121474!FontSet class methodsFor: 'converting' stamp: 'lr 7/4/2009 10:42'! 121475convertTextStyleNamed: aString 121476 | style fontSet | 121477 (style := TextStyle named: aString) ifNil: [ ^ self error: 'unknown text style ' , aString ]. 121478 fontSet := self fontSetClass: aString. 121479 style fontArray do: [ :each | fontSet compileFont: each ]! ! 121480 121481 121482!FontSet class methodsFor: 'filein/out' stamp: 'sma 12/29/1999 11:49'! 121483fileOut 121484 "FileOut and then change the properties of the file so that it won't be 121485 treated as text by, eg, email attachment facilities" 121486 121487 super fileOut. 121488 (FileStream oldFileNamed: self name , '.st') setFileTypeToObject; close! ! 121489 121490 121491!FontSet class methodsFor: 'installing' stamp: 'damiencassou 5/30/2008 14:51'! 121492fontNamed: fontName fromLiteral: aString 121493 "NOTE -- THIS IS AN OBSOLETE METHOD THAT MAY CAUSE ERRORS. 121494 121495The old form of fileOut for FontSets produced binary literal strings which may not be accurately read in systems with support for international character sets. If possible, file the FontSet out again from a system that produces the newer MIME encoding (current def of compileFont:), and uses the corresponding altered version of this method. If this is not easy, then 121496 file the fontSet into an older system (3.7 or earlier), 121497 assume it is called FontSetZork... 121498 execute FontSetZork installAsTextStyle. 121499 copy the compileFont: method from this system into that older one. 121500 remove the class FontSetZork. 121501 Execute: FontSet convertTextStyleNamed: 'Zork', and see that it creates a new FontSetZork. 121502 FileOut the new class FontSetZork. 121503 The resulting file should be able to be read into this system. 121504" 121505 ^ StrikeFont new 121506 name: fontName; 121507 readFromStrike2Stream: aString asByteArray readStream! ! 121508 121509!FontSet class methodsFor: 'installing' stamp: 'di 1/24/2005 11:13'! 121510fontNamed: fontName fromMimeLiteral: aString 121511 "This method allows a font set to be captured as sourcecode in a subclass. 121512 The string literals will presumably be created by printing, eg, 121513 (FileStream readOnlyFileNamed: 'Palatino24.sf2') contentsOfEntireFile, 121514 and following the logic in compileFont: to encode and add a heading. 121515 121516 See the method installAsTextStyle to see how this can be used." 121517 121518 ^ StrikeFont new 121519 name: fontName; 121520 readFromStrike2Stream: (Base64MimeConverter mimeDecodeToBytes: aString readStream)! ! 121521 121522!FontSet class methodsFor: 'installing' stamp: 'alain.plantec 2/6/2009 17:03'! 121523installAsDefault "FontSetNewYork installAsDefault" 121524 (self confirm: 'Do you want to install' translated, ' 121525''' , self fontName , ''' as default font?' translated) 121526 ifFalse: [^ self]. 121527 self installAsTextStyle. 121528 "TextConstants at: #OldDefaultTextStyle put: TextStyle default." 121529 TextConstants at: #DefaultTextStyle put: (TextStyle named: self fontName). 121530 ListParagraph initialize. 121531 "rbb 2/18/2005 13:20 - How should this change for UIManger, if at all?" 121532 PopUpMenu initialize. 121533 "SelectionMenu notify: 'The old text style has been saved 121534as ''OldDefaultTextStyle''.'"! ! 121535 121536!FontSet class methodsFor: 'installing' stamp: 'lr 7/4/2009 10:42'! 121537installAsTextStyle 121538 "FontSetNewYork installAsTextStyle" 121539 | selectors | 121540 (TextConstants includesKey: self fontName) ifTrue: 121541 [ (self confirm: self fontName , ' is already defined in TextConstants. 121542Do you want to replace that definition?') ifFalse: [ ^ self ] ]. 121543 selectors := (self class selectors select: [ :s | s beginsWith: 'size' ]) asSortedCollection. 121544 TextConstants 121545 at: self fontName 121546 put: (TextStyle fontArray: (selectors collect: [ :each | self perform: each ]))! ! 121547 121548!FontSet class methodsFor: 'installing' stamp: 'nk 8/31/2004 09:23'! 121549size: pointSize fromLiteral: aString 121550 "This method allows a font set to be captured as sourcecode in a subclass. 121551 The string literals will presumably be created by printing, eg, 121552 (FileStream readOnlyFileNamed: 'Palatino24.sf2') contentsOfEntireFile, 121553 and then pasting into a browser after a heading like, eg, 121554size24 121555 ^ self size: 24 fromLiteral: 121556 '--unreadable binary data--' 121557 121558 See the method installAsTextStyle to see how this can be used." 121559 121560 "This method is old and for backward compatibility only. 121561 please use fontNamed:fromLiteral: instead." 121562 121563 self flag: #bob. "used in Alan's projects" 121564 ^(StrikeFont new) 121565 name: self fontName , (pointSize < 10 121566 ifTrue: ['0' , pointSize printString] 121567 ifFalse: [pointSize printString]); 121568 readFromStrike2Stream: ((RWBinaryOrTextStream with: aString) 121569 reset; 121570 binary); 121571 yourself! ! 121572 121573 121574!FontSet class methodsFor: 'private' stamp: 'sma 12/29/1999 12:58'! 121575fontCategory 121576 ^ 'Graphics-Fonts' asSymbol! ! 121577 121578!FontSet class methodsFor: 'private' stamp: 'RAA 6/20/2000 13:29'! 121579fontName 121580 121581 self flag: #bob. "temporary hack until I figure out what's happening here" 121582 (self name beginsWith: superclass name) ifFalse: [^self name]. 121583 ^ (self name copyFrom: superclass name size + 1 to: self name size) asSymbol! ! 121584 121585!FontSet class methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 121586fontSetClass: aString 121587 | className fontSet | 121588 className := (self name , (aString select: [ :c | c isAlphaNumeric ]) capitalized) asSymbol. 121589 fontSet := Smalltalk 121590 at: className 121591 ifAbsentPut: 121592 [ self 121593 subclass: className 121594 instanceVariableNames: '' 121595 classVariableNames: '' 121596 poolDictionaries: '' 121597 category: self fontCategory ]. 121598 (fontSet inheritsFrom: self) ifFalse: [ ^ self error: 'The name ' , className , ' is already in use' ]. 121599 ^ fontSet! ! 121600Notification subclass: #FontSubstitutionDuringLoading 121601 instanceVariableNames: 'familyName pixelSize' 121602 classVariableNames: '' 121603 poolDictionaries: '' 121604 category: 'System-Support'! 121605!FontSubstitutionDuringLoading commentStamp: '<historical>' prior: 0! 121606signaled by font loading code when reading a DiskProxy that calls for a missing font.! 121607 121608 121609!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:04'! 121610defaultAction 121611 familyName ifNil: [ familyName := 'NoName' ]. 121612 pixelSize ifNil: [ pixelSize := 12 ]. 121613 121614 ^((familyName beginsWith: 'Comic') 121615 ifTrue: [ TextStyle named: (Preferences standardEToysFont familyName) ] 121616 ifFalse: [ TextStyle default ]) fontOfSize: pixelSize.! ! 121617 121618!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'! 121619familyName 121620 "Answer the value of familyName" 121621 121622 ^ familyName! ! 121623 121624!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'! 121625familyName: anObject 121626 "Set the value of familyName" 121627 121628 familyName := anObject! ! 121629 121630!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'! 121631pixelSize 121632 "Answer the value of pixelSize" 121633 121634 ^ pixelSize! ! 121635 121636!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'! 121637pixelSize: anObject 121638 "Set the value of pixelSize" 121639 121640 pixelSize := anObject! ! 121641 121642!FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 16:55'! 121643printOn: aStream 121644 super printOn: aStream. 121645 aStream nextPut: $(; 121646 nextPutAll: familyName; 121647 nextPut: $-; 121648 print: pixelSize; 121649 nextPut: $).! ! 121650 121651"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 121652 121653FontSubstitutionDuringLoading class 121654 instanceVariableNames: ''! 121655 121656!FontSubstitutionDuringLoading class methodsFor: 'instance creation' stamp: 'nk 11/8/2004 15:07'! 121657forFamilyName: aName pixelSize: aSize 121658 ^(self new) 121659 familyName: aName; 121660 pixelSize: aSize; 121661 yourself.! ! 121662TestCase subclass: #FontTest 121663 instanceVariableNames: '' 121664 classVariableNames: '' 121665 poolDictionaries: '' 121666 category: 'Tests-Multilingual'! 121667!FontTest commentStamp: 'tak 3/11/2005 14:31' prior: 0! 121668I am mainly a test for fallback font. 121669FontTest buildSuite run! 121670 121671 121672!FontTest methodsFor: 'testing' stamp: 'sd 2/4/2008 21:10'! 121673testDisplay 121674 "self debug: #testDisplay" 121675 | text font bb destPoint width | 121676 text := 'test' asText. 121677 font := TextStyle default fontOfSize: 21. 121678 text addAttribute: (TextFontReference toFont: font). 121679 bb := (Form extent: 100 @ 30) getCanvas privatePort. 121680 bb combinationRule: Form paint. 121681 121682 font installOn: bb foregroundColor: Color black backgroundColor: Color white. 121683 destPoint := font displayString: text on: bb from: 1 to: 4 at: 0@0 kern: 1. 121684 121685 width := text inject: 0 into: [:max :char | max + (font widthOf: char)]. 121686 self assert: destPoint x = (width + 4). 121687 "bb destForm asMorph openInHand." 121688! ! 121689 121690!FontTest methodsFor: 'testing' stamp: 'sd 2/4/2008 21:10'! 121691testFallback 121692 "self debug: #testFallback" 121693 | text font bb destPoint | 121694 text := (Character value: 257) asString asText. 121695 font := TextStyle default fontOfSize: 21. 121696 text addAttribute: (TextFontReference toFont: font). 121697 bb := (Form extent: 100 @ 30) getCanvas privatePort. 121698 bb combinationRule: Form paint. 121699 121700 font installOn: bb foregroundColor: Color black backgroundColor: Color white. 121701 destPoint := font displayString: text on: bb from: 1 to: 1 at: 0@0 kern: 1. 121702 121703 "bb destForm asMorph openInHand." 121704 self assert: destPoint x = ((font widthOf: $?) + 1). 121705! ! 121706 121707!FontTest methodsFor: 'testing' stamp: 'tak 12/21/2004 18:02'! 121708testMultistringFont 121709 "self debug: #testMultistringFont" 121710 | text p style height width | 121711 [(TextStyle default fontArray at: JapaneseEnvironment leadingChar) 121712 ifNil: [^ self]] 121713 ifError: [:err :rcvr | ^ self]. 121714 text := ((#(20983874 20983876 20983878 ) 121715 collect: [:e | e asCharacter]) 121716 as: String) asText. 121717 p := MultiNewParagraph new. 121718 style := TextStyle default. 121719 p 121720 compose: text 121721 style: style 121722 from: 1 121723 in: (0 @ 0 corner: 100 @ 100). 121724 "See CompositionScanner>>setActualFont: & 121725 CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide:" 121726 height := style defaultFont height + style leading. 121727 width := text 121728 inject: 0 121729 into: [:tally :next | tally 121730 + (style defaultFont widthOf: next)]. 121731 p adjustRightX. 121732 self assert: p extent = (width @ height). 121733 "Display getCanvas 121734 paragraph: p 121735 bounds: (10 @ 10 extent: 100 @ 100) 121736 color: Color black"! ! 121737 121738!FontTest methodsFor: 'testing' stamp: 'tak 12/21/2004 14:50'! 121739testParagraph 121740 "self debug: #testParagraph" 121741 | text p style height width | 121742 text := 'test' asText. 121743 p := MultiNewParagraph new. 121744 style := TextStyle default. 121745 p 121746 compose: text 121747 style: style 121748 from: 1 121749 in: (0 @ 0 corner: 100 @ 100). 121750 "See CompositionScanner>>setActualFont: & 121751 CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide:" 121752 height := style defaultFont height + style leading. 121753 width := text 121754 inject: 0 121755 into: [:tally :next | tally 121756 + (style defaultFont widthOf: next)]. 121757 p adjustRightX. 121758 self assert: p extent = (width @ height)! ! 121759 121760!FontTest methodsFor: 'testing' stamp: 'tak 12/21/2004 17:19'! 121761testParagraphFallback 121762 "self debug: #testParagraphFallback" 121763 | text p style height width e expect | 121764 e := (Character value: 257) asString. 121765 text := ('test' , e , e , e , e , 'test') asText. 121766 expect := 'test????test'. 121767 p := MultiNewParagraph new. 121768 style := TextStyle default. 121769 p 121770 compose: text 121771 style: style 121772 from: 1 121773 in: (0 @ 0 corner: 100 @ 100). 121774 "See CompositionScanner>>setActualFont: & 121775 CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide:" 121776 height := style defaultFont height + style leading. 121777 width := expect 121778 inject: 0 121779 into: [:tally :next | tally 121780 + (style defaultFont widthOf: next)]. 121781 p adjustRightX. 121782 self assert: p extent = (width @ height). 121783 "Display getCanvas 121784 paragraph: p 121785 bounds: (10 @ 10 extent: 100 @ 100) 121786 color: Color black"! ! 121787 121788!FontTest methodsFor: 'testing' stamp: 'sd 2/4/2008 21:11'! 121789testResetAfterEmphasized 121790 "self debug: #testResetAfterEmphasized" 121791 | normal derivative | 121792 normal := TextStyle defaultFont. 121793 derivative := normal emphasized: 3. 121794 self assert: (normal derivativeFonts at: 3) == derivative. 121795 normal reset. 121796 self assert: normal derivativeFonts isEmpty 121797! ! 121798DisplayMedium subclass: #Form 121799 instanceVariableNames: 'bits width height depth offset' 121800 classVariableNames: '' 121801 poolDictionaries: '' 121802 category: 'Graphics-Display Objects'! 121803!Form commentStamp: 'ls 1/4/2004 17:16' prior: 0! 121804A rectangular array of pixels, used for holding images. All pictures, including character images are Forms. The depth of a Form is how many bits are used to specify the color at each pixel. The actual bits are held in a Bitmap, whose internal structure is different at each depth. Class Color allows you to deal with colors without knowing how they are actually encoded inside a Bitmap. 121805 The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. 121806 Forms are indexed starting at 0 instead of 1; thus, the top-left pixel of a Form has coordinates 0@0. 121807 Forms are combined using BitBlt. See the comment in class BitBlt. Forms that repeat many times to fill a large destination are InfiniteForms. 121808 121809 colorAt: x@y Returns the abstract Color at this location 121810 displayAt: x@y shows this form on the screen 121811 displayOn: aMedium at: x@y shows this form in a Window, a Form, or other DisplayMedium 121812 fillColor: aColor Set all the pixels to the color. 121813 edit launch an editor to change the bits of this form. 121814 pixelValueAt: x@y The encoded color. The encoding depends on the depth. 121815! 121816]style[(223 6 62 5 374 6 11 23 64 12 40 5 337)f1,f1LBitmap Definition;,f1,f1LColor Definition;,f1,f1LBitBlt Definition;,f1,f1LBitBlt Comment;,f1,f1LInfiniteForm Definition;,f1,f1RColor;,f1! 121817 121818 121819!Form methodsFor: '*morphic' stamp: 'ar 7/8/2006 21:01'! 121820iconOrThumbnailOfSize: aNumberOrPoint 121821 "Answer an appropiate form to represent the receiver" 121822 ^ self scaledIntoFormOfSize: aNumberOrPoint! ! 121823 121824!Form methodsFor: '*morphic' stamp: 'ar 7/8/2006 21:01'! 121825scaledIntoFormOfSize: aNumberOrPoint 121826 "Scale and center the receiver into a form of a given size" 121827 121828 | extent scale scaledForm result | 121829 121830 extent := aNumberOrPoint asPoint. 121831 extent = self extent ifTrue: [^ self]. 121832 121833 (self height isZero or: [self width isZero]) 121834 ifTrue: [^ Form extent: extent depth: self depth]. 121835 121836 scale := extent y / self height min: extent x / self width. 121837 scaledForm := self 121838 magnify: self boundingBox 121839 by: scale 121840 smoothing: 8. 121841 121842 result := Form extent: extent depth: 32. 121843 result getCanvas 121844 translucentImage: scaledForm 121845 at: extent - scaledForm extent // 2. 121846 121847 ^ result 121848! ! 121849 121850 121851!Form methodsFor: 'accessing'! 121852bits 121853 "Answer the receiver's Bitmap containing its bits." 121854 121855 ^ bits! ! 121856 121857!Form methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:41'! 121858bitsSize 121859 | pixPerWord | 121860 depth == nil ifTrue: [depth := 1]. 121861 pixPerWord := 32 // self depth. 121862 ^ width + pixPerWord - 1 // pixPerWord * height! ! 121863 121864!Form methodsFor: 'accessing'! 121865bits: aBitmap 121866 "Reset the Bitmap containing the receiver's bits." 121867 121868 bits := aBitmap! ! 121869 121870!Form methodsFor: 'accessing' stamp: 'tk 3/9/97'! 121871center 121872 "Note that offset is ignored here. Are we really going to embrace offset? " 121873 ^ (width @ height) // 2! ! 121874 121875!Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 12:03'! 121876defaultCanvasClass 121877 "Return the default canvas used for drawing onto the receiver" 121878 ^Display defaultCanvasClass! ! 121879 121880!Form methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45'! 121881depth 121882 ^ depth < 0 ifTrue:[0-depth] ifFalse:[depth]! ! 121883 121884!Form methodsFor: 'accessing'! 121885depth: bitsPerPixel 121886 (bitsPerPixel > 32 or: 121887 [(bitsPerPixel bitAnd: bitsPerPixel-1) ~= 0]) 121888 ifTrue: [self halt: 'bitsPerPixel must be 1, 2, 4, 8, 16 or 32']. 121889 depth := bitsPerPixel! ! 121890 121891!Form methodsFor: 'accessing' stamp: 'ar 5/27/2000 16:56'! 121892displayScreen 121893 "Return the display screen the receiver is allocated on. 121894 Forms in general are Squeak internal and not allocated on any particular display." 121895 ^nil! ! 121896 121897!Form methodsFor: 'accessing'! 121898extent 121899 ^ width @ height! ! 121900 121901!Form methodsFor: 'accessing'! 121902form 121903 "Answer the receiver's form. For vanilla Forms, this degenerates to self. Makes several methods that operate on both Forms and MaskedForms much more straightforward. 6/1/96 sw" 121904 121905 ^ self! ! 121906 121907!Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 12:03'! 121908getCanvas 121909 "Return a Canvas that can be used to draw onto the receiver" 121910 ^self defaultCanvasClass on: self! ! 121911 121912!Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 00:48'! 121913hasBeenModified 121914 "Return true if something *might* have been drawn into the receiver" 121915 ^(bits == nil or:[bits class == ByteArray]) not 121916 "Read the above as: If the receiver has forgotten its contents (bits == nil) 121917 or is still hibernated it can't be modified."! ! 121918 121919!Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 00:48'! 121920hasBeenModified: aBool 121921 "Change the receiver to reflect the modification state" 121922 aBool ifTrue:[^self unhibernate]. 121923 self shouldPreserveContents 121924 ifTrue:[self hibernate] 121925 ifFalse:[bits := nil]! ! 121926 121927!Form methodsFor: 'accessing'! 121928height 121929 ^ height! ! 121930 121931!Form methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:50'! 121932nativeDepth 121933 "Return the 'native' depth of the receiver, e.g., including the endianess" 121934 ^depth! ! 121935 121936!Form methodsFor: 'accessing' stamp: 'ar 2/16/2000 22:00'! 121937offset 121938 ^offset ifNil:[0@0]! ! 121939 121940!Form methodsFor: 'accessing'! 121941offset: aPoint 121942 121943 offset := aPoint! ! 121944 121945!Form methodsFor: 'accessing'! 121946size 121947 "Should no longer be used -- use bitsSize instead. length of variable part of instance." 121948 ^ super size! ! 121949 121950!Form methodsFor: 'accessing'! 121951width 121952 ^ width! ! 121953 121954 121955!Form methodsFor: 'analyzing' stamp: 'jm 12/5/97 19:48'! 121956colorsUsed 121957 "Return a list of the Colors this form uses." 121958 121959 | tallies tallyDepth usedColors | 121960 tallies := self tallyPixelValues. 121961 tallyDepth := (tallies size log: 2) asInteger. 121962 usedColors := OrderedCollection new. 121963 tallies doWithIndex: [:count :i | 121964 count > 0 ifTrue: [ 121965 usedColors add: (Color colorFromPixelValue: i - 1 depth: tallyDepth)]]. 121966 ^ usedColors asArray 121967! ! 121968 121969!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:40'! 121970dominantColor 121971 | tally max maxi | 121972 self depth > 16 ifTrue: 121973 [^(self asFormOfDepth: 16) dominantColor]. 121974 tally := self tallyPixelValues. 121975 max := maxi := 0. 121976 tally withIndexDo: [:n :i | n > max ifTrue: [max := n. maxi := i]]. 121977 ^ Color colorFromPixelValue: maxi - 1 depth: self depth! ! 121978 121979!Form methodsFor: 'analyzing'! 121980innerPixelRectFor: pv orNot: not 121981 "Return a rectangle describing the smallest part of me that includes 121982 all pixels of value pv. 121983 Note: If orNot is true, then produce a copy that includes all pixels 121984 that are DIFFERENT from the supplied (background) value" 121985 121986 | xTally yTally | 121987 xTally := self xTallyPixelValue: pv orNot: not. 121988 yTally := self yTallyPixelValue: pv orNot: not. 121989 ^ ((xTally findFirst: [:t | t>0]) - 1) @ ((yTally findFirst: [:t | t>0]) - 1) 121990 corner: 121991 (xTally findLast: [:t | t>0])@(yTally findLast: [:t | t>0])! ! 121992 121993!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:40'! 121994pixelCompare: aRect with: otherForm at: otherLoc 121995 "Compare the selected bits of this form (those within aRect) against 121996 those in a similar rectangle of otherFrom. Return the sum of the 121997 absolute value of the differences of the color values of every pixel. 121998 Obviously, this is most useful for rgb (16- or 32-bit) pixels but, 121999 in the case of 8-bits or less, this will return the sum of the differing 122000 bits of the corresponding pixel values (somewhat less useful)" 122001 | pixPerWord temp | 122002 pixPerWord := 32//self depth. 122003 (aRect left\\pixPerWord = 0 and: [aRect right\\pixPerWord = 0]) ifTrue: 122004 ["If word-aligned, use on-the-fly difference" 122005 ^ (BitBlt current toForm: self) copy: aRect from: otherLoc in: otherForm 122006 fillColor: nil rule: 32]. 122007 "Otherwise, combine in a word-sized form and then compute difference" 122008 temp := self copy: aRect. 122009 temp copy: aRect from: otherLoc in: otherForm rule: 21. 122010 ^ (BitBlt current toForm: temp) copy: aRect from: otherLoc in: nil 122011 fillColor: (Bitmap with: 0) rule: 32 122012" Dumb example prints zero only when you move over the original rectangle... 122013 | f diff | f := Form fromUser. 122014[Sensor anyButtonPressed] whileFalse: 122015 [diff := f pixelCompare: f boundingBox 122016 with: Display at: Sensor cursorPoint. 122017 diff printString , ' ' displayAt: 0@0] 122018"! ! 122019 122020!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:42'! 122021primCountBits 122022 "Count the non-zero pixels of this form." 122023 self depth > 8 ifTrue: 122024 [^(self asFormOfDepth: 8) primCountBits]. 122025 ^ (BitBlt current toForm: self) 122026 fillColor: (Bitmap with: 0); 122027 destRect: (0@0 extent: width@height); 122028 combinationRule: 32; 122029 copyBits! ! 122030 122031!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:37'! 122032rectangleEnclosingPixelsNotOfColor: aColor 122033 "Answer the smallest rectangle enclosing all the pixels of me that are different from the given color. Useful for extracting a foreground graphic from its background." 122034 122035 | cm slice copyBlt countBlt top bottom newH left right | 122036 "map the specified color to 1 and all others to 0" 122037 cm := Bitmap new: (1 bitShift: (self depth min: 15)). 122038 cm primFill: 1. 122039 cm at: (aColor indexInMap: cm) put: 0. 122040 122041 "build a 1-pixel high horizontal slice and BitBlts for counting pixels of interest" 122042 slice := Form extent: width@1 depth: 1. 122043 copyBlt := (BitBlt current toForm: slice) 122044 sourceForm: self; 122045 combinationRule: Form over; 122046 destX: 0 destY: 0 width: width height: 1; 122047 colorMap: cm. 122048 countBlt := (BitBlt current toForm: slice) 122049 fillColor: (Bitmap with: 0); 122050 destRect: (0@0 extent: slice extent); 122051 combinationRule: 32. 122052 122053 "scan in from top and bottom" 122054 top := (0 to: height) 122055 detect: [:y | 122056 copyBlt sourceOrigin: 0@y; copyBits. 122057 countBlt copyBits > 0] 122058 ifNone: [^ 0@0 extent: 0@0]. 122059 bottom := (height - 1 to: top by: -1) 122060 detect: [:y | 122061 copyBlt sourceOrigin: 0@y; copyBits. 122062 countBlt copyBits > 0]. 122063 122064 "build a 1-pixel wide vertical slice and BitBlts for counting pixels of interest" 122065 newH := bottom - top + 1. 122066 slice := Form extent: 1@newH depth: 1. 122067 copyBlt := (BitBlt current toForm: slice) 122068 sourceForm: self; 122069 combinationRule: Form over; 122070 destX: 0 destY: 0 width: 1 height: newH; 122071 colorMap: cm. 122072 countBlt := (BitBlt current toForm: slice) 122073 fillColor: (Bitmap with: 0); 122074 destRect: (0@0 extent: slice extent); 122075 combinationRule: 32. 122076 122077 "scan in from left and right" 122078 left := (0 to: width) 122079 detect: [:x | 122080 copyBlt sourceOrigin: x@top; copyBits. 122081 countBlt copyBits > 0]. 122082 right := (width - 1 to: left by: -1) 122083 detect: [:x | 122084 copyBlt sourceOrigin: x@top; copyBits. 122085 countBlt copyBits > 0]. 122086 122087 ^ left@top corner: (right + 1)@(bottom + 1) 122088! ! 122089 122090!Form methodsFor: 'analyzing' stamp: 'jm 6/18/1999 18:41'! 122091tallyPixelValues 122092 "Answer a Bitmap whose elements contain the number of pixels in this Form with the pixel value corresponding to their index. Note that the pixels of multiple Forms can be tallied together using tallyPixelValuesInRect:into:." 122093 122094 ^ self tallyPixelValuesInRect: self boundingBox 122095 into: (Bitmap new: (1 bitShift: (self depth min: 15))) 122096" 122097Move a little rectangle around the screen and print its tallies... 122098 | r tallies nonZero | 122099Cursor blank showWhile: [ 122100[Sensor anyButtonPressed] whileFalse: 122101 [r := Sensor cursorPoint extent: 10@10. 122102 Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil. 122103 tallies := (Display copy: r) tallyPixelValues. 122104 nonZero := (1 to: tallies size) select: [:i | (tallies at: i) > 0] 122105 thenCollect: [:i | (tallies at: i) -> (i-1)]. 122106 nonZero printString , ' ' displayAt: 0@0. 122107 Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]] 122108" 122109! ! 122110 122111!Form methodsFor: 'analyzing' stamp: 'ar 5/28/2000 12:09'! 122112tallyPixelValuesInRect: destRect into: valueTable 122113 "Tally the selected pixels of this Form into valueTable, a Bitmap of depth 2^depth similar to a color map. Answer valueTable." 122114 122115 (BitBlt current toForm: self) 122116 sourceForm: self; "src must be given for color map ops" 122117 sourceOrigin: 0@0; 122118 tallyMap: valueTable; 122119 combinationRule: 33; 122120 destRect: destRect; 122121 copyBits. 122122 ^ valueTable 122123 122124" 122125Move a little rectangle around the screen and print its tallies... 122126 | r tallies nonZero | 122127Cursor blank showWhile: [ 122128[Sensor anyButtonPressed] whileFalse: 122129 [r := Sensor cursorPoint extent: 10@10. 122130 Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil. 122131 tallies := (Display copy: r) tallyPixelValues. 122132 nonZero := (1 to: tallies size) select: [:i | (tallies at: i) > 0] 122133 thenCollect: [:i | (tallies at: i) -> (i-1)]. 122134 nonZero printString , ' ' displayAt: 0@0. 122135 Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]] 122136"! ! 122137 122138!Form methodsFor: 'analyzing' stamp: 'ar 5/28/2000 12:09'! 122139xTallyPixelValue: pv orNot: not 122140 "Return an array of the number of pixels with value pv by x-value. 122141 Note that if not is true, then this will tally those different from pv." 122142 | cm slice countBlt copyBlt | 122143 cm := self newColorMap. "Map all colors but pv to zero" 122144 not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" 122145 cm at: pv+1 put: 1 - (cm at: pv+1). 122146 slice := Form extent: 1@height. 122147 copyBlt := (BitBlt current destForm: slice sourceForm: self 122148 halftoneForm: nil combinationRule: Form over 122149 destOrigin: 0@0 sourceOrigin: 0@0 extent: 1 @ slice height 122150 clipRect: slice boundingBox) colorMap: cm. 122151 countBlt := (BitBlt current toForm: slice) 122152 fillColor: (Bitmap with: 0); 122153 destRect: (0@0 extent: slice extent); 122154 combinationRule: 32. 122155 ^ (0 to: width-1) collect: 122156 [:x | 122157 copyBlt sourceOrigin: x@0; copyBits. 122158 countBlt copyBits]! ! 122159 122160!Form methodsFor: 'analyzing' stamp: 'ar 5/28/2000 12:09'! 122161yTallyPixelValue: pv orNot: not 122162 "Return an array of the number of pixels with value pv by y-value. 122163 Note that if not is true, then this will tally those different from pv." 122164 | cm slice copyBlt countBlt | 122165 cm := self newColorMap. "Map all colors but pv to zero" 122166 not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" 122167 cm at: pv+1 put: 1 - (cm at: pv+1). 122168 slice := Form extent: width@1. 122169 copyBlt := (BitBlt current destForm: slice sourceForm: self 122170 halftoneForm: nil combinationRule: Form over 122171 destOrigin: 0@0 sourceOrigin: 0@0 extent: slice width @ 1 122172 clipRect: slice boundingBox) colorMap: cm. 122173 countBlt := (BitBlt current toForm: slice) 122174 fillColor: (Bitmap with: 0); 122175 destRect: (0@0 extent: slice extent); 122176 combinationRule: 32. 122177 ^ (0 to: height-1) collect: 122178 [:y | 122179 copyBlt sourceOrigin: 0@y; copyBits. 122180 countBlt copyBits]! ! 122181 122182 122183!Form methodsFor: 'bordering' stamp: 'ar 5/17/2001 15:42'! 122184borderFormOfWidth: borderWidth sharpCorners: sharpen 122185 "Smear this form around and then subtract the original to produce 122186 an outline. If sharpen is true, then cause right angles to be outlined 122187 by right angles (takes an additional diagonal smears ANDed with both 122188 horizontal and vertical smears)." 122189 | smearForm bigForm smearPort all cornerForm cornerPort nbrs | 122190 self depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms." 122191 bigForm := self deepCopy. 122192 all := bigForm boundingBox. 122193 smearForm := Form extent: self extent. 122194 smearPort := BitBlt current toForm: smearForm. 122195 sharpen ifTrue: 122196 [cornerForm := Form extent: self extent. 122197 cornerPort := BitBlt current toForm: cornerForm]. 122198 nbrs := (0@0) fourNeighbors. 122199 1 to: borderWidth do: 122200 [:i | "Iterate to get several layers of 'skin'" 122201 nbrs do: 122202 [:d | "Smear the self in 4 directions to grow each layer of skin" 122203 smearPort copyForm: bigForm to: d rule: Form under]. 122204 sharpen ifTrue: 122205 ["Special treatment to smear sharp corners" 122206 nbrs with: ((2 to: 5) collect: [:i2 | nbrs atWrap: i2]) do: 122207 [:d1 :d2 | 122208 "Copy corner points diagonally" 122209 cornerPort copyForm: bigForm to: d1+d2 rule: Form over. 122210 "But only preserve if there were dots on either side" 122211 cornerPort copyForm: bigForm to: d1+d1+d2 rule: Form and. 122212 cornerPort copyForm: bigForm to: d1+d2+d2 rule: Form and. 122213 smearPort copyForm: cornerForm to: 0@0 rule: Form under]. 122214 ]. 122215 bigForm copy: all from: 0@0 in: smearForm rule: Form over. 122216 ]. 122217 "Now erase the original shape to obtain the outline" 122218 bigForm copy: all from: 0@0 in: self rule: Form erase. 122219 ^ bigForm! ! 122220 122221!Form methodsFor: 'bordering'! 122222borderWidth: anInteger 122223 "Set the width of the border for the receiver to be anInteger and paint it 122224 using black as the border color." 122225 122226 self border: self boundingBox width: anInteger fillColor: Color black! ! 122227 122228!Form methodsFor: 'bordering'! 122229borderWidth: anInteger color: aMask 122230 "Set the width of the border for the receiver to be anInteger and paint it 122231 using aMask as the border color." 122232 122233 self border: self boundingBox width: anInteger fillColor: aMask! ! 122234 122235!Form methodsFor: 'bordering'! 122236borderWidth: anInteger fillColor: aMask 122237 "Set the width of the border for the receiver to be anInteger and paint it 122238 using aMask as the border color." 122239 122240 self border: self boundingBox width: anInteger fillColor: aMask! ! 122241 122242!Form methodsFor: 'bordering' stamp: 'ar 5/28/2000 12:07'! 122243border: rect width: borderWidth rule: rule fillColor: fillColor 122244 "Paint a border whose rectangular area is defined by rect. The 122245width of the border of each side is borderWidth. Uses fillColor for drawing 122246the border." 122247 | blt | 122248 blt := (BitBlt current toForm: self) combinationRule: rule; fillColor: fillColor. 122249 blt sourceOrigin: 0@0. 122250 blt destOrigin: rect origin. 122251 blt width: rect width; height: borderWidth; copyBits. 122252 blt destY: rect corner y - borderWidth; copyBits. 122253 blt destY: rect origin y + borderWidth. 122254 blt height: rect height - borderWidth - borderWidth; width: 122255borderWidth; copyBits. 122256 blt destX: rect corner x - borderWidth; copyBits! ! 122257 122258!Form methodsFor: 'bordering' stamp: 'di 10/21/2001 09:39'! 122259shapeBorder: aColor width: borderWidth 122260 "A simplified version for shapes surrounded by transparency (as SketchMorphs). 122261 Note also this returns a new form that may be larger, and does not affect the original." 122262 | shapeForm borderForm newForm | 122263 newForm := Form extent: self extent + (borderWidth*2) depth: self depth. 122264 newForm fillColor: Color transparent. 122265 self displayOn: newForm at: (0@0) + borderWidth. 122266 "First identify the shape in question as a B/W form" 122267 shapeForm := (newForm makeBWForm: Color transparent) reverse. 122268 "Now find the border of that shape" 122269 borderForm := shapeForm borderFormOfWidth: borderWidth sharpCorners: false. 122270 "Finally use that shape as a mask to paint the border with color" 122271 ^ newForm fillShape: borderForm fillColor: aColor! ! 122272 122273!Form methodsFor: 'bordering'! 122274shapeBorder: aColor width: borderWidth interiorPoint: interiorPoint 122275 sharpCorners: sharpen internal: internal 122276 "Identify the shape (region of identical color) at interiorPoint, 122277 and then add an outline of width=borderWidth and color=aColor. 122278 If sharpen is true, then cause right angles to be outlined by 122279 right angles. If internal is true, then produce a border that lies 122280 within the identified shape. Thus one can put an internal border 122281 around the whole background, thus effecting a normal border 122282 around every other foreground image." 122283 | shapeForm borderForm interiorColor | 122284 "First identify the shape in question as a B/W form" 122285 interiorColor := self colorAt: interiorPoint. 122286 shapeForm := (self makeBWForm: interiorColor) reverse 122287 findShapeAroundSeedBlock: 122288 [:form | form pixelValueAt: interiorPoint put: 1]. 122289 "Reverse the image to grow the outline inward" 122290 internal ifTrue: [shapeForm reverse]. 122291 "Now find the border fo that shape" 122292 borderForm := shapeForm borderFormOfWidth: borderWidth sharpCorners: sharpen. 122293 "Finally use that shape as a mask to paint the border with color" 122294 self fillShape: borderForm fillColor: aColor! ! 122295 122296 122297!Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! 122298balancedPatternFor: aColor 122299 "Return the pixel word for representing the given color on the receiver" 122300 self hasNonStandardPalette 122301 ifTrue:[^self bitPatternFor: aColor] 122302 ifFalse:[^aColor balancedPatternForDepth: self depth]! ! 122303 122304!Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! 122305bitPatternFor: aColor 122306 "Return the pixel word for representing the given color on the receiver" 122307 aColor isColor ifFalse:[^aColor bitPatternForDepth: self depth]. 122308 self hasNonStandardPalette 122309 ifTrue:[^Bitmap with: (self pixelWordFor: aColor)] 122310 ifFalse:[^aColor bitPatternForDepth: self depth]! ! 122311 122312!Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! 122313colormapFromARGB 122314 "Return a ColorMap mapping from canonical ARGB space into the receiver. 122315 Note: This version is optimized for Squeak forms." 122316 | map nBits | 122317 self hasNonStandardPalette 122318 ifTrue:[^ColorMap mappingFromARGB: self rgbaBitMasks]. 122319 self depth <= 8 ifTrue:[ 122320 map := Color colorMapIfNeededFrom: 32 to: self depth. 122321 map size = 512 ifTrue:[nBits := 3]. 122322 map size = 4096 ifTrue:[nBits := 4]. 122323 map size = 32768 ifTrue:[nBits := 5]. 122324 ^ColorMap 122325 shifts: (Array 122326 with: 3 * nBits - 24 122327 with: 2 * nBits - 16 122328 with: 1 * nBits - 8 122329 with: 0) 122330 masks: (Array 122331 with: (1 << nBits) - 1 << (24 - nBits) 122332 with: (1 << nBits) - 1 << (16 - nBits) 122333 with: (1 << nBits) - 1 << (8 - nBits) 122334 with: 0) 122335 colors: map]. 122336 self depth = 16 ifTrue:[ 122337 ^ColorMap 122338 shifts: #(-9 -6 -3 0) 122339 masks: #(16rF80000 16rF800 16rF8 0)]. 122340 self depth = 32 ifTrue:[ 122341 ^ColorMap 122342 shifts: #(0 0 0 0) 122343 masks: #(16rFF0000 16rFF00 16rFF 16rFF000000)]. 122344 self error:'Bad depth'! ! 122345 122346!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:42'! 122347colormapIfNeededForDepth: destDepth 122348 "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." 122349 122350 self depth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" 122351 ^ Color colorMapIfNeededFrom: self depth to: destDepth 122352! ! 122353 122354!Form methodsFor: 'color mapping' stamp: 'ar 5/16/2001 22:23'! 122355colormapIfNeededFor: destForm 122356 "Return a ColorMap mapping from the receiver to destForm." 122357 (self hasNonStandardPalette or:[destForm hasNonStandardPalette]) 122358 ifTrue:[^self colormapFromARGB mappingTo: destForm colormapFromARGB] 122359 ifFalse:[^self colormapIfNeededForDepth: destForm depth]! ! 122360 122361!Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! 122362colormapToARGB 122363 "Return a ColorMap mapping from the receiver into canonical ARGB space." 122364 self hasNonStandardPalette 122365 ifTrue:[^self colormapFromARGB inverseMap]. 122366 self depth <= 8 ifTrue:[ 122367 ^ColorMap 122368 shifts: #(0 0 0 0) 122369 masks: #(16rFF0000 16rFF00 16rFF 16rFF000000) 122370 colors: (Color colorMapIfNeededFrom: self depth to: 32)]. 122371 self depth = 16 ifTrue:[ 122372 ^ColorMap 122373 shifts: #( 9 6 3 0) 122374 masks: #(16r7C00 16r3E0 16r1F 0)]. 122375 self depth = 32 ifTrue:[ 122376 ^ColorMap 122377 shifts: #(0 0 0 0) 122378 masks: #(16rFF0000 16rFF00 16rFF 16rFF000000)]. 122379 self error:'Bad depth'! ! 122380 122381!Form methodsFor: 'color mapping'! 122382makeBWForm: foregroundColor 122383 "Map this form into a B/W form with 1's in the foreground regions." 122384 | bwForm map | 122385 bwForm := Form extent: self extent. 122386 map := self newColorMap. "All non-foreground go to 0's" 122387 map at: (foregroundColor indexInMap: map) put: 1. 122388 bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map. 122389 ^ bwForm! ! 122390 122391!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:40'! 122392mapColors: oldColorBitsCollection to: newColorBits 122393 "Make all pixels of the given color in this Form to the given new color." 122394 "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." 122395 122396 | map | 122397 self depth < 16 122398 ifTrue: [map := (Color cachedColormapFrom: self depth to: self depth) copy] 122399 ifFalse: [ 122400 "use maximum resolution color map" 122401 "source is 16-bit or 32-bit RGB; use colormap with 5 bits per color component" 122402 map := Color computeRGBColormapFor: self depth bitsPerColor: 5]. 122403 oldColorBitsCollection do:[ :oldColor | map at: oldColor put: newColorBits]. 122404 122405 (BitBlt current toForm: self) 122406 sourceForm: self; 122407 sourceOrigin: 0@0; 122408 combinationRule: Form over; 122409 destX: 0 destY: 0 width: width height: height; 122410 colorMap: map; 122411 copyBits. 122412! ! 122413 122414!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:38'! 122415mapColor: oldColor to: newColor 122416 "Make all pixels of the given color in this Form to the given new color." 122417 "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." 122418 122419 | map | 122420 map := (Color cachedColormapFrom: self depth to: self depth) copy. 122421 map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: self depth). 122422 (BitBlt current toForm: self) 122423 sourceForm: self; 122424 sourceOrigin: 0@0; 122425 combinationRule: Form over; 122426 destX: 0 destY: 0 width: width height: height; 122427 colorMap: map; 122428 copyBits. 122429! ! 122430 122431!Form methodsFor: 'color mapping' stamp: 'ar 12/14/2001 18:11'! 122432maskingMap 122433 "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero." 122434 ^Color maskingMap: self depth! ! 122435 122436!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:41'! 122437newColorMap 122438 "Return an uninitialized color map array appropriate to this Form's depth." 122439 122440 ^ Bitmap new: (1 bitShift: (self depth min: 15)) 122441! ! 122442 122443!Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! 122444pixelValueFor: aColor 122445 "Return the pixel word for representing the given color on the receiver" 122446 self hasNonStandardPalette 122447 ifTrue:[^self colormapFromARGB mapPixel: (aColor pixelValueForDepth: 32)] 122448 ifFalse:[^aColor pixelValueForDepth: self depth]! ! 122449 122450!Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! 122451pixelWordFor: aColor 122452 "Return the pixel word for representing the given color on the receiver" 122453 | basicPattern | 122454 self hasNonStandardPalette 122455 ifFalse:[^aColor pixelWordForDepth: self depth]. 122456 basicPattern := self pixelValueFor: aColor. 122457 self depth = 32 122458 ifTrue:[^basicPattern] 122459 ifFalse:[^aColor pixelWordFor: self depth filledWith: basicPattern]! ! 122460 122461!Form methodsFor: 'color mapping' stamp: 'di 10/16/2001 15:23'! 122462reducedPaletteOfSize: nColors 122463 "Return an array of colors of size nColors, such that those colors 122464 represent well the pixel values actually found in this form." 122465 | threshold tallies colorTallies dist delta palette cts top cluster | 122466 tallies := self tallyPixelValues. "An array of tallies for each pixel value" 122467 threshold := width * height // 500. 122468 122469 "Make an array of (color -> tally) for all tallies over threshold" 122470 colorTallies := Array streamContents: 122471 [:s | tallies withIndexDo: 122472 [:v :i | v >= threshold ifTrue: 122473 [s nextPut: (Color colorFromPixelValue: i-1 depth: depth) -> v]]]. 122474 122475 "Extract a set of clusters by picking the top tally, and then removing all others 122476 whose color is within dist of it. Iterate the process, adjusting dist until we get nColors." 122477 dist := 0.2. delta := dist / 2. 122478 [cts := colorTallies copy. 122479 palette := Array streamContents: [:s | 122480 [cts isEmpty] whileFalse: 122481 [top := cts detectMax: [:a | a value]. 122482 cluster := cts select: [:a | (a key diff: top key) < dist]. 122483 s nextPut: top key -> (cluster detectSum: [:a | a value]). 122484 cts := cts copyWithoutAll: cluster]]. 122485 palette size = nColors or: [delta < 0.001]] 122486 whileFalse: 122487 [palette size > nColors 122488 ifTrue: [dist := dist + delta] 122489 ifFalse: [dist := dist - delta]. 122490 delta := delta / 2]. 122491 ^ palette collect: [:a | a key] 122492! ! 122493 122494!Form methodsFor: 'color mapping' stamp: 'ar 5/27/2000 20:14'! 122495rgbaBitMasks 122496 "Return the masks for specifying the R,G,B, and A components in the receiver" 122497 self depth <= 8 122498 ifTrue:[^#(16rFF0000 16rFF00 16rFF 16rFF000000)]. 122499 self depth = 16 122500 ifTrue:[^#(16r7C00 16r3E0 16r1F 16r0)]. 122501 self depth = 32 122502 ifTrue:[^#(16rFF0000 16rFF00 16rFF 16rFF000000)]. 122503 self error:'Bad depth for form'! ! 122504 122505 122506!Form methodsFor: 'converting' stamp: 'jm 11/12/97 19:28'! 122507as8BitColorForm 122508 "Simple conversion of zero pixels to transparent. Force it to 8 bits." 122509 122510 | f map | 122511 f := ColorForm extent: self extent depth: 8. 122512 self displayOn: f at: self offset negated. 122513 map := Color indexedColors copy. 122514 map at: 1 put: Color transparent. 122515 f colors: map. 122516 f offset: self offset. 122517 ^ f 122518! ! 122519 122520!Form methodsFor: 'converting' stamp: 'RAA 8/14/2000 10:13'! 122521asCursorForm 122522 122523 ^ self as: StaticForm! ! 122524 122525!Form methodsFor: 'converting' stamp: 'ar 6/16/2002 17:44'! 122526asFormOfDepth: d 122527 | newForm | 122528 d = self depth ifTrue:[^self]. 122529 newForm := Form extent: self extent depth: d. 122530 (BitBlt current toForm: newForm) 122531 colorMap: (self colormapIfNeededFor: newForm); 122532 copy: (self boundingBox) 122533 from: 0@0 in: self 122534 fillColor: nil rule: Form over. 122535 ^newForm! ! 122536 122537!Form methodsFor: 'converting' stamp: 'ar 5/17/2001 15:39'! 122538asGrayScale 122539 "Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.)" 122540 | f32 srcForm result map bb grays | 122541 self depth = 32 ifFalse: [ 122542 f32 := Form extent: width@height depth: 32. 122543 self displayOn: f32. 122544 ^ f32 asGrayScale]. 122545 self unhibernate. 122546 srcForm := Form extent: (width * 4)@height depth: 8. 122547 srcForm bits: bits. 122548 result := ColorForm extent: width@height depth: 8. 122549 map := Bitmap new: 256. 122550 2 to: 256 do: [:i | map at: i put: i - 1]. 122551 map at: 1 put: 1. "map zero pixel values to near-black" 122552 bb := (BitBlt current toForm: result) 122553 sourceForm: srcForm; 122554 combinationRule: Form over; 122555 colorMap: map. 122556 0 to: width - 1 do: [:dstX | 122557 bb sourceRect: (((dstX * 4) + 2)@0 extent: 1@height); 122558 destOrigin: dstX@0; 122559 copyBits]. 122560 122561 "final BitBlt to zero-out pixels that were truely transparent in the original" 122562 map := Bitmap new: 512. 122563 map at: 1 put: 16rFF. 122564 (BitBlt current toForm: result) 122565 sourceForm: self; 122566 sourceRect: self boundingBox; 122567 destOrigin: 0@0; 122568 combinationRule: Form erase; 122569 colorMap: map; 122570 copyBits. 122571 122572 grays := (0 to: 255) collect: [:brightness | Color gray: brightness asFloat / 255.0]. 122573 grays at: 1 put: Color transparent. 122574 result colors: grays. 122575 ^ result 122576! ! 122577 122578!Form methodsFor: 'converting' stamp: 'ar 11/7/1999 20:29'! 122579asMorph 122580 ^ImageMorph new image: self! ! 122581 122582!Form methodsFor: 'converting' stamp: 'ar 2/7/2004 18:16'! 122583asSourceForm 122584 ^self! ! 122585 122586!Form methodsFor: 'converting' stamp: 'marcus.denker 9/14/2008 21:16'! 122587colorReduced 122588 "Return a color-reduced ColorForm version of the receiver, if possible, or the receiver itself if not." 122589 122590 | tally tallyDepth colorCount newForm cm oldPixelValues newFormColors nextColorIndex c | 122591 tally := self tallyPixelValues asArray. 122592 tallyDepth := (tally size log: 2) asInteger. 122593 colorCount := 0. 122594 tally do: [:n | n > 0 ifTrue: [colorCount := colorCount + 1]]. 122595 (tally at: 1) = 0 ifTrue: [colorCount := colorCount + 1]. "include transparent" 122596 colorCount > 256 ifTrue: [^ self]. "cannot reduce" 122597 newForm := self formForColorCount: colorCount. 122598 122599 "build an array of just the colors used, and a color map to translate 122600 old pixel values to their indices into this color array" 122601 cm := Bitmap new: tally size. 122602 oldPixelValues := self colormapIfNeededForDepth: 32. 122603 newFormColors := Array new: colorCount. 122604 newFormColors at: 1 put: Color transparent. 122605 nextColorIndex := 2. 122606 2 to: cm size do: [:i | 122607 (tally at: i) > 0 ifTrue: [ 122608 oldPixelValues isNil 122609 ifTrue: [c := Color colorFromPixelValue: i - 1 depth: tallyDepth] 122610 ifFalse: [c := Color colorFromPixelValue: (oldPixelValues at: i) depth: 32]. 122611 newFormColors at: nextColorIndex put: c. 122612 cm at: i put: nextColorIndex - 1. "pixel values are zero-based indices" 122613 nextColorIndex := nextColorIndex + 1]]. 122614 122615 "copy pixels into new ColorForm, mapping to new pixel values" 122616 newForm copyBits: self boundingBox 122617 from: self 122618 at: 0@0 122619 clippingBox: self boundingBox 122620 rule: Form over 122621 fillColor: nil 122622 map: cm. 122623 newForm colors: newFormColors. 122624 newForm offset: offset. 122625 ^ newForm 122626! ! 122627 122628!Form methodsFor: 'converting' stamp: 'di 10/16/2001 19:23'! 122629copyWithColorsReducedTo: nColors 122630 "Note: this has not been engineered. 122631 There are better solutions in the literature." 122632 | palette colorMap pc closest | 122633 palette := self reducedPaletteOfSize: nColors. 122634 colorMap := (1 to: (1 bitShift: depth)) collect: 122635 [:i | pc := Color colorFromPixelValue: i-1 depth: depth. 122636 closest := palette detectMin: [:c | c diff: pc]. 122637 closest pixelValueForDepth: depth]. 122638 ^ self deepCopy copyBits: self boundingBox from: self at: 0@0 colorMap: (colorMap as: Bitmap) 122639 ! ! 122640 122641!Form methodsFor: 'converting' stamp: 'ar 7/23/1999 17:04'! 122642orderedDither32To16 122643 "Do an ordered dithering for converting from 32 to 16 bit depth." 122644 | ditherMatrix ii out inBits outBits index pv dmv r di dmi dmo g b pvOut outIndex | 122645 self depth = 32 ifFalse:[^self error:'Must be 32bit for this']. 122646 ditherMatrix := #( 0 8 2 10 122647 12 4 14 6 122648 3 11 1 9 122649 15 7 13 5). 122650 ii := (0 to: 31) collect:[:i| i]. 122651 out := Form extent: self extent depth: 16. 122652 inBits := self bits. 122653 outBits := out bits. 122654 index := outIndex := 0. 122655 pvOut := 0. 122656 0 to: self height-1 do:[:y| 122657 0 to: self width-1 do:[:x| 122658 pv := inBits at: (index := index + 1). 122659 dmv := ditherMatrix at: (y bitAnd: 3) * 4 + (x bitAnd: 3) + 1. 122660 r := pv bitAnd: 255. di := r * 496 bitShift: -8. 122661 dmi := di bitAnd: 15. dmo := di bitShift: -4. 122662 r := dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. 122663 g := (pv bitShift: -8) bitAnd: 255. di := g * 496 bitShift: -8. 122664 dmi := di bitAnd: 15. dmo := di bitShift: -4. 122665 g := dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. 122666 b := (pv bitShift: -16) bitAnd: 255. di := b * 496 bitShift: -8. 122667 dmi := di bitAnd: 15. dmo := di bitShift: -4. 122668 b := dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. 122669 pvOut := (pvOut bitShift: 16) + 122670 (b bitShift: 10) + (g bitShift: 5) + r. 122671 (x bitAnd: 1) = 1 ifTrue:[ 122672 outBits at: (outIndex := outIndex+1) put: pvOut. 122673 pvOut := 0]. 122674 ]. 122675 (self width bitAnd: 1) = 1 ifTrue:[ 122676 outBits at: (outIndex := outIndex+1) put: (pvOut bitShift: -16). 122677 pvOut := 0]. 122678 ]. 122679 ^out! ! 122680 122681 122682!Form methodsFor: 'copying' stamp: 'RAA 9/28/1999 11:20'! 122683blankCopyOf: aRectangle scaledBy: scale 122684 122685 ^ self class extent: (aRectangle extent * scale) truncated depth: depth! ! 122686 122687!Form methodsFor: 'copying' stamp: 'ar 6/9/2000 18:59'! 122688contentsOfArea: aRect 122689 "Return a new form which derives from the portion of the original form delineated by aRect." 122690 ^self contentsOfArea: aRect 122691 into: (self class extent: aRect extent depth: depth).! ! 122692 122693!Form methodsFor: 'copying' stamp: 'ar 6/9/2000 19:00'! 122694contentsOfArea: aRect into: newForm 122695 "Return a new form which derives from the portion of the original form delineated by aRect." 122696 ^ newForm copyBits: aRect from: self at: 0@0 122697 clippingBox: newForm boundingBox rule: Form over fillColor: nil! ! 122698 122699!Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:08'! 122700copyBits: sourceForm at: destOrigin translucent: factor 122701 "Make up a BitBlt table and copy the bits with the given colorMap." 122702 (BitBlt current 122703 destForm: self 122704 sourceForm: sourceForm 122705 halftoneForm: nil 122706 combinationRule: 30 122707 destOrigin: destOrigin 122708 sourceOrigin: 0@0 122709 extent: sourceForm extent 122710 clipRect: self boundingBox) 122711 copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) 122712" 122713 | f f2 f3 | f := Form fromUser. f2 := Form fromDisplay: (0@0 extent: f extent). f3 := f2 deepCopy. 1227140.0 to: 1.0 by: 1.0/32 do: 122715 [:t | f3 := f2 deepCopy. f3 copyBits: f at: 0@0 translucent: t. 122716 f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. 122717"! ! 122718 122719!Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:08'! 122720copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm 122721 "Make up a BitBlt table and copy the bits." 122722 122723 (BitBlt current 122724 destForm: self 122725 sourceForm: sourceForm 122726 fillColor: aForm 122727 combinationRule: rule 122728 destOrigin: destOrigin 122729 sourceOrigin: sourceRect origin 122730 extent: sourceRect extent 122731 clipRect: clipRect) copyBits! ! 122732 122733!Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:08'! 122734copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm map: map 122735 "Make up a BitBlt table and copy the bits. Use a colorMap." 122736 122737 ((BitBlt current 122738 destForm: self 122739 sourceForm: sourceForm 122740 fillColor: aForm 122741 combinationRule: rule 122742 destOrigin: destOrigin 122743 sourceOrigin: sourceRect origin 122744 extent: sourceRect extent 122745 clipRect: clipRect) colorMap: map) copyBits! ! 122746 122747!Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:08'! 122748copyBits: sourceRect from: sourceForm at: destOrigin colorMap: map 122749 "Make up a BitBlt table and copy the bits with the given colorMap." 122750 ((BitBlt current 122751 destForm: self 122752 sourceForm: sourceForm 122753 halftoneForm: nil 122754 combinationRule: Form over 122755 destOrigin: destOrigin 122756 sourceOrigin: sourceRect origin 122757 extent: sourceRect extent 122758 clipRect: self boundingBox) colorMap: map) copyBits! ! 122759 122760!Form methodsFor: 'copying'! 122761copy: aRect 122762 "Return a new form which derives from the portion of the original form delineated by aRect." 122763 | newForm | 122764 newForm := self class extent: aRect extent depth: depth. 122765 ^ newForm copyBits: aRect from: self at: 0@0 122766 clippingBox: newForm boundingBox rule: Form over fillColor: nil! ! 122767 122768!Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:08'! 122769copy: destRectangle from: sourcePt in: sourceForm rule: rule 122770 "Make up a BitBlt table and copy the bits." 122771 (BitBlt current toForm: self) 122772 copy: destRectangle 122773 from: sourcePt in: sourceForm 122774 fillColor: nil rule: rule! ! 122775 122776!Form methodsFor: 'copying'! 122777copy: sourceRectangle from: sourceForm to: destPt rule: rule 122778 ^ self copy: (destPt extent: sourceRectangle extent) 122779 from: sourceRectangle topLeft in: sourceForm rule: rule! ! 122780 122781!Form methodsFor: 'copying' stamp: 'jm 2/27/98 09:35'! 122782deepCopy 122783 122784 ^ self shallowCopy 122785 bits: bits copy; 122786 offset: offset copy 122787! ! 122788 122789!Form methodsFor: 'copying' stamp: 'tk 8/19/1998 16:11'! 122790veryDeepCopyWith: deepCopier 122791 "Return self. I am immutable in the Morphic world. Do not record me." 122792 ^ self! ! 122793 122794 122795!Form methodsFor: 'display box access'! 122796boundingBox 122797 ^ Rectangle origin: 0 @ 0 122798 corner: width @ height! ! 122799 122800!Form methodsFor: 'display box access'! 122801computeBoundingBox 122802 ^ Rectangle origin: 0 @ 0 122803 corner: width @ height! ! 122804 122805 122806!Form methodsFor: 'displaying' stamp: 'ar 2/13/2001 22:13'! 122807displayInterpolatedIn: aRectangle on: aForm 122808 "Display the receiver on aForm, using interpolation if necessary. 122809 Form fromUser displayInterpolatedOn: Display. 122810 Note: When scaling we attempt to use bilinear interpolation based 122811 on the 3D engine. If the engine is not there then we use WarpBlt. 122812 " 122813 | engine adjustedR | 122814 self extent = aRectangle extent ifTrue:[^self displayOn: aForm at: aRectangle origin]. 122815 Smalltalk at: #B3DRenderEngine 122816 ifPresent:[:engineClass| engine := (engineClass defaultForPlatformOn: aForm)]. 122817 engine ifNil:[ 122818 "We've got no bilinear interpolation. Use WarpBlt instead" 122819 (WarpBlt current toForm: aForm) 122820 sourceForm: self destRect: aRectangle; 122821 combinationRule: 3; 122822 cellSize: 2; 122823 warpBits. 122824 ^self 122825 ]. 122826 122827 "Otherwise use the 3D engine for our purposes" 122828 122829 "there seems to be a slight bug in B3D which the following adjusts for" 122830 adjustedR := (aRectangle withRight: aRectangle right + 1) translateBy: 0@1. 122831 engine viewport: adjustedR. 122832 engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white). 122833 engine texture: self. 122834 engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect). 122835 engine finish.! ! 122836 122837!Form methodsFor: 'displaying' stamp: 'ar 2/13/2001 22:12'! 122838displayInterpolatedOn: aForm 122839 "Display the receiver on aForm, using interpolation if necessary. 122840 Form fromUser displayInterpolatedOn: Display. 122841 Note: When scaling we attempt to use bilinear interpolation based 122842 on the 3D engine. If the engine is not there then we use WarpBlt. 122843 " 122844 | engine | 122845 self extent = aForm extent ifTrue:[^self displayOn: aForm]. 122846 Smalltalk at: #B3DRenderEngine 122847 ifPresent:[:engineClass| engine := (engineClass defaultForPlatformOn: aForm)]. 122848 engine ifNil:[ 122849 "We've got no bilinear interpolation. Use WarpBlt instead" 122850 (WarpBlt current toForm: aForm) 122851 sourceForm: self destRect: aForm boundingBox; 122852 combinationRule: 3; 122853 cellSize: 2; 122854 warpBits. 122855 ^self 122856 ]. 122857 "Otherwise use the 3D engine for our purposes" 122858 engine viewport: aForm boundingBox. 122859 engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white). 122860 engine texture: self. 122861 engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect). 122862 engine finish.! ! 122863 122864!Form methodsFor: 'displaying'! 122865displayOnPort: port at: location 122866 port copyForm: self to: location rule: Form over! ! 122867 122868!Form methodsFor: 'displaying' stamp: 'ar 5/14/2001 23:33'! 122869displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: rule fillColor: aForm 122870 122871 aDisplayMedium copyBits: self boundingBox 122872 from: self 122873 at: aDisplayPoint + self offset 122874 clippingBox: clipRectangle 122875 rule: rule 122876 fillColor: aForm 122877 map: (self colormapIfNeededFor: aDisplayMedium). 122878! ! 122879 122880!Form methodsFor: 'displaying'! 122881displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 122882 "Graphically, it means nothing to scale a Form by floating point values. 122883 Because scales and other display parameters are kept in floating point to 122884 minimize round off errors, we are forced in this routine to round off to the 122885 nearest integer." 122886 122887 | absolutePoint scale magnifiedForm | 122888 absolutePoint := displayTransformation applyTo: relativePoint. 122889 absolutePoint := absolutePoint x asInteger @ absolutePoint y asInteger. 122890 displayTransformation noScale 122891 ifTrue: [magnifiedForm := self] 122892 ifFalse: 122893 [scale := displayTransformation scale. 122894 scale := scale x @ scale y. 122895 (1@1 = scale) 122896 ifTrue: [scale := nil. magnifiedForm := self] 122897 ifFalse: [magnifiedForm := self magnify: self boundingBox by: scale]]. 122898 magnifiedForm 122899 displayOn: aDisplayMedium 122900 at: absolutePoint - alignmentPoint 122901 clippingBox: clipRectangle 122902 rule: ruleInteger 122903 fillColor: aForm! ! 122904 122905!Form methodsFor: 'displaying' stamp: 'ar 5/17/2001 15:40'! 122906displayResourceFormOn: aForm 122907 "a special display method for blowing up resource thumbnails" 122908 | engine tx cmap blitter | 122909 self extent = aForm extent ifTrue:[^self displayOn: aForm]. 122910 Smalltalk at: #B3DRenderEngine ifPresentAndInMemory: 122911 [:engineClass | engine := engineClass defaultForPlatformOn: aForm]. 122912 engine ifNil:[ 122913 "We've got no bilinear interpolation. Use WarpBlt instead" 122914 (WarpBlt current toForm: aForm) 122915 sourceForm: self destRect: aForm boundingBox; 122916 combinationRule: 3; 122917 cellSize: 2; 122918 warpBits. 122919 ^self 122920 ]. 122921 tx := self asTexture. 122922 (blitter := BitBlt current toForm: tx) 122923 sourceForm: self; destRect: aForm boundingBox; 122924 sourceOrigin: 0@0; 122925 combinationRule: Form paint. 122926 "map transparency to current World background color" 122927 (World color respondsTo: #pixelWordForDepth:) ifTrue: [ 122928 cmap := Bitmap new: (self depth <= 8 ifTrue: [1 << self depth] ifFalse: [4096]). 122929 cmap at: 1 put: (tx pixelWordFor: World color). 122930 blitter colorMap: cmap. 122931 ]. 122932 blitter copyBits. 122933 engine viewport: aForm boundingBox. 122934 engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white). 122935 engine texture: tx. 122936 engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect). 122937 engine finish. 122938 "the above, using bilinear interpolation doesn't leave transparent pixel values intact" 122939 (WarpBlt current toForm: aForm) 122940 sourceForm: self destRect: aForm boundingBox; 122941 combinationRule: Form and; 122942 colorMap: (Color maskingMap: self depth); 122943 warpBits.! ! 122944 122945!Form methodsFor: 'displaying' stamp: 'ar 3/2/2001 21:32'! 122946displayScaledOn: aForm 122947 "Display the receiver on aForm, scaling if necessary. 122948 Form fromUser displayScaledOn: Display. 122949 " 122950 self extent = aForm extent ifTrue:[^self displayOn: aForm]. 122951 (WarpBlt current toForm: aForm) 122952 sourceForm: self destRect: aForm boundingBox; 122953 combinationRule: Form paint; 122954 cellSize: 2; 122955 warpBits.! ! 122956 122957!Form methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:08'! 122958drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger fillColor: aForm 122959 "Refer to the comment in 122960 DisplayMedium|drawLine:from:to:clippingBox:rule:mask:." 122961 122962 | dotSetter | 122963 "set up an instance of BitBlt for display" 122964 dotSetter := BitBlt current 122965 destForm: self 122966 sourceForm: sourceForm 122967 fillColor: aForm 122968 combinationRule: anInteger 122969 destOrigin: beginPoint 122970 sourceOrigin: 0 @ 0 122971 extent: sourceForm extent 122972 clipRect: clipRect. 122973 dotSetter drawFrom: beginPoint to: endPoint! ! 122974 122975!Form methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:08'! 122976paintBits: sourceForm at: destOrigin translucent: factor 122977 "Make up a BitBlt table and copy the bits with the given colorMap." 122978 (BitBlt current destForm: self 122979 sourceForm: sourceForm 122980 halftoneForm: nil 122981 combinationRule: 31 122982 destOrigin: destOrigin 122983 sourceOrigin: 0@0 122984 extent: sourceForm extent 122985 clipRect: self boundingBox) 122986 copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) 122987" 122988 | f f2 f3 | f := Form fromUser. f replaceColor: f peripheralColor withColor: Color transparent. 122989f2 := Form fromDisplay: (0@0 extent: f extent). f3 := f2 deepCopy. 1229900.0 to: 1.0 by: 1.0/32 do: 122991 [:t | f3 := f2 deepCopy. f3 paintBits: f at: 0@0 translucent: t. 122992 f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. 122993"! ! 122994 122995 122996!Form methodsFor: 'filein/out' stamp: 'ar 2/24/2001 22:41'! 122997comeFullyUpOnReload: smartRefStream 122998 bits isForm ifFalse:[^self]. 122999 "make sure the resource gets loaded afterwards" 123000 ResourceCollector current ifNil:[^self]. 123001 ResourceCollector current noteResource: bits replacing: self. 123002! ! 123003 123004!Form methodsFor: 'filein/out' stamp: 'di 8/5/1998 11:37'! 123005hibernate 123006 "Replace my bitmap with a compactly encoded representation (a ByteArray). It is vital that BitBlt and any other access to the bitmap (such as writing to a file) not be used when in this state. Since BitBlt will fail if the bitmap size is wrong (not = bitsSize), we do not allow replacement by a byteArray of the same (or larger) size." 123007 123008 "NOTE: This method copies code from Bitmap compressToByteArray so that it can 123009 nil out the old bits during the copy, thus avoiding 2x need for extra storage." 123010 | compactBits lastByte | 123011 (bits isMemberOf: Bitmap) ifFalse: [^ self "already hibernated or weird state"]. 123012 compactBits := ByteArray new: (bits size*4) + 7 + (bits size//1984*3). 123013 lastByte := bits compress: bits toByteArray: compactBits. 123014 lastByte < (bits size*4) ifTrue: 123015 [bits := nil. "Let GC reclaim the old bits before the copy if necessary" 123016 bits := compactBits copyFrom: 1 to: lastByte]! ! 123017 123018!Form methodsFor: 'filein/out' stamp: 'ar 3/3/2001 16:16'! 123019objectForDataStream: refStream 123020 | prj repl | 123021 prj := refStream project. 123022 prj ifNil:[^super objectForDataStream: refStream]. 123023 ResourceCollector current ifNil:[^super objectForDataStream: refStream]. 123024 repl := ResourceCollector current objectForDataStream: refStream fromForm: self. 123025 ^repl! ! 123026 123027!Form methodsFor: 'filein/out' stamp: 'di 3/15/1999 14:50'! 123028printOn: aStream 123029 aStream 123030 nextPutAll: self class name; 123031 nextPut: $(; print: width; 123032 nextPut: $x; print: height; 123033 nextPut: $x; print: depth; 123034 nextPut: $). 123035! ! 123036 123037!Form methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:44'! 123038readAttributesFrom: aBinaryStream 123039 | offsetX offsetY | 123040 depth := aBinaryStream next. 123041 (self depth isPowerOfTwo and: [self depth between: 1 and: 32]) 123042 ifFalse: [self error: 'invalid depth; bad Form file?']. 123043 width := aBinaryStream nextWord. 123044 height := aBinaryStream nextWord. 123045 offsetX := aBinaryStream nextWord. 123046 offsetY := aBinaryStream nextWord. 123047 offsetX > 32767 ifTrue: [offsetX := offsetX - 65536]. 123048 offsetY > 32767 ifTrue: [offsetY := offsetY - 65536]. 123049 offset := Point x: offsetX y: offsetY. 123050 123051! ! 123052 123053!Form methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:43'! 123054readBitsFrom: aBinaryStream 123055 123056 bits := Bitmap newFromStream: aBinaryStream. 123057 bits size = self bitsSize ifFalse: [self error: 'wrong bitmap size; bad Form file?']. 123058 ^ self 123059! ! 123060 123061!Form methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:44'! 123062readFrom: aBinaryStream 123063 "Reads the receiver from the given binary stream with the format: 123064 depth, extent, offset, bits." 123065 self readAttributesFrom: aBinaryStream. 123066 self readBitsFrom: aBinaryStream! ! 123067 123068!Form methodsFor: 'filein/out' stamp: 'jm 3/27/98 16:54'! 123069readFromOldFormat: aBinaryStream 123070 "Read a Form in the original ST-80 format." 123071 123072 | w h offsetX offsetY newForm theBits pos | 123073 self error: 'this method must be updated to read into 32-bit word bitmaps'. 123074 w := aBinaryStream nextWord. 123075 h := aBinaryStream nextWord. 123076 offsetX := aBinaryStream nextWord. 123077 offsetY := aBinaryStream nextWord. 123078 offsetX > 32767 ifTrue: [offsetX := offsetX - 65536]. 123079 offsetY > 32767 ifTrue: [offsetY := offsetY - 65536]. 123080 newForm := Form extent: w @ h offset: offsetX @ offsetY. 123081 theBits := newForm bits. 123082 pos := 0. 123083 1 to: w + 15 // 16 do: [:j | 123084 1 to: h do: [:i | 123085 theBits at: (pos := pos+1) put: aBinaryStream nextWord]]. 123086 newForm bits: theBits. 123087 ^ newForm 123088! ! 123089 123090!Form methodsFor: 'filein/out' stamp: 'ar 2/24/2001 22:39'! 123091replaceByResource: aForm 123092 "Replace the receiver by some resource that just got loaded" 123093 (self extent = aForm extent and:[self depth = aForm depth]) ifTrue:[ 123094 bits := aForm bits. 123095 ].! ! 123096 123097!Form methodsFor: 'filein/out' stamp: 'nk 12/31/2003 16:06'! 123098store15To24HexBitsOn:aStream 123099 123100 | buf i lineWidth | 123101 123102 "write data for 16-bit form, optimized for encoders writing directly to files to do one single file write rather than 12. I'm not sure I understand the significance of the shifting pattern, but I think I faithfully translated it from the original" 123103 123104 lineWidth := 0. 123105 buf := String new: 12. 123106 bits do: [:word | 123107 i := 0. 123108 "upper pixel" 123109 buf at: (i := i + 1) put: ((word bitShift: -27) bitAnd: 15) asHexDigit. 123110 buf at: (i := i + 1) put: ((word bitShift: -32) bitAnd: 8) asHexDigit. 123111 123112 buf at: (i := i + 1) put: ((word bitShift: -22) bitAnd: 15) asHexDigit. 123113 buf at: (i := i + 1) put: ((word bitShift: -27) bitAnd: 8) asHexDigit. 123114 123115 buf at: (i := i + 1) put: ((word bitShift: -17) bitAnd: 15) asHexDigit. 123116 buf at: (i := i + 1) put: ((word bitShift: -22) bitAnd: 8) asHexDigit. 123117 123118 "lower pixel" 123119 123120 buf at: (i := i + 1) put: ((word bitShift: -11) bitAnd: 15) asHexDigit. 123121 buf at: (i := i + 1) put: ((word bitShift: -16) bitAnd: 8) asHexDigit. 123122 123123 buf at: (i := i + 1) put: ((word bitShift: -6) bitAnd: 15) asHexDigit. 123124 buf at: (i := i + 1) put: ((word bitShift: -11) bitAnd: 8) asHexDigit. 123125 123126 buf at: (i := i + 1) put: ((word bitShift: -1) bitAnd: 15) asHexDigit. 123127 buf at: (i := i + 1) put: ((word bitShift: -6) bitAnd: 8) asHexDigit. 123128 aStream nextPutAll: buf. 123129 lineWidth := lineWidth + 12. 123130 lineWidth > 100 ifTrue: [ aStream cr. lineWidth := 0 ]. 123131 "#( 31 26 21 15 10 5 ) do:[:startBit | ]" 123132 ].! ! 123133 123134!Form methodsFor: 'filein/out'! 123135store32To24HexBitsOn:aStream 123136 ^self storeBits:20 to:0 on:aStream.! ! 123137 123138!Form methodsFor: 'filein/out'! 123139storeBits:startBit to:stopBit on:aStream 123140 bits storeBits:startBit to:stopBit on:aStream.! ! 123141 123142!Form methodsFor: 'filein/out' stamp: 'laza 3/29/2004 12:21'! 123143storeBitsOn:aStream base:anInteger 123144 bits do: [:word | 123145 anInteger = 10 123146 ifTrue: [aStream space] 123147 ifFalse: [aStream crtab: 2]. 123148 word storeOn: aStream base: anInteger]. 123149! ! 123150 123151!Form methodsFor: 'filein/out'! 123152storeHexBitsOn:aStream 123153 ^self storeBits:28 to:0 on:aStream.! ! 123154 123155!Form methodsFor: 'filein/out'! 123156storeOn: aStream 123157 123158 self storeOn: aStream base: 10! ! 123159 123160!Form methodsFor: 'filein/out'! 123161storeOn: aStream base: anInteger 123162 "Store the receiver out as an expression that can be evaluated to recreate a Form with the same contents as the original." 123163 123164 self unhibernate. 123165 aStream nextPut: $(. 123166 aStream nextPutAll: self species name. 123167 aStream crtab: 1. 123168 aStream nextPutAll: 'extent: '. 123169 self extent printOn: aStream. 123170 aStream crtab: 1. 123171 aStream nextPutAll: 'depth: '. 123172 self depth printOn: aStream. 123173 aStream crtab: 1. 123174 aStream nextPutAll: 'fromArray: #('. 123175 self storeBitsOn:aStream base:anInteger. 123176 aStream nextPut: $). 123177 aStream crtab: 1. 123178 aStream nextPutAll: 'offset: '. 123179 self offset printOn: aStream. 123180 aStream nextPut: $). 123181! ! 123182 123183!Form methodsFor: 'filein/out' stamp: 'ar 3/3/2001 15:50'! 123184unhibernate 123185 "If my bitmap has been compressed into a ByteArray, 123186 then expand it now, and return true." 123187 | resBits | 123188 bits isForm ifTrue:[ 123189 resBits := bits. 123190 bits := Bitmap new: self bitsSize. 123191 resBits displayResourceFormOn: self. 123192 ^true]. 123193 bits == nil ifTrue:[bits := Bitmap new: self bitsSize. ^true]. 123194 (bits isMemberOf: ByteArray) 123195 ifTrue: [bits := Bitmap decompressFromByteArray: bits. ^ true]. 123196 ^ false! ! 123197 123198!Form methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:35'! 123199writeAttributesOn: file 123200 self unhibernate. 123201 file nextPut: depth. 123202 file nextWordPut: width. 123203 file nextWordPut: height. 123204 file nextWordPut: ((self offset x) >=0 123205 ifTrue: [self offset x] 123206 ifFalse: [self offset x + 65536]). 123207 file nextWordPut: ((self offset y) >=0 123208 ifTrue: [self offset y] 123209 ifFalse: [self offset y + 65536]). 123210 ! ! 123211 123212!Form methodsFor: 'filein/out' stamp: 'ar 6/16/2002 17:53'! 123213writeBMPfileNamed: fName "Display writeBMPfileNamed: 'display.bmp'" 123214 BMPReadWriter putForm: self onFileNamed: fName! ! 123215 123216!Form methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:35'! 123217writeBitsOn: file 123218 bits writeOn: file! ! 123219 123220!Form methodsFor: 'filein/out' stamp: 'sw 2/20/2002 15:37'! 123221writeJPEGfileNamed: fileName 123222 "Write a JPEG file to the given filename using default settings" 123223 123224 self writeJPEGfileNamed: fileName progressive: false 123225 123226" 123227Display writeJPEGfileNamed: 'display.jpeg' 123228Form fromUser writeJPEGfileNamed: 'yourPatch.jpeg' 123229"! ! 123230 123231!Form methodsFor: 'filein/out' stamp: 'sw 2/20/2002 15:29'! 123232writeJPEGfileNamed: fileName progressive: aBoolean 123233 "Write a JPEG file to the given filename using default settings. Make it progressive or not, depending on the boolean argument" 123234 123235 JPEGReadWriter2 putForm: self quality: -1 "default" progressiveJPEG: aBoolean onFileNamed: fileName 123236 123237" 123238Display writeJPEGfileNamed: 'display.jpeg' progressive: false. 123239Form fromUser writeJPEGfileNamed: 'yourPatch.jpeg' progressive: true 123240"! ! 123241 123242!Form methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:36'! 123243writeOn: file 123244 "Write the receiver on the file in the format 123245 depth, extent, offset, bits." 123246 self writeAttributesOn: file. 123247 self writeBitsOn: file! ! 123248 123249!Form methodsFor: 'filein/out' stamp: 'di 7/6/1998 23:00'! 123250writeOnMovie: file 123251 "Write just my bits on the file." 123252 self unhibernate. 123253 bits writeUncompressedOn: file! ! 123254 123255!Form methodsFor: 'filein/out' stamp: 'tk 2/19/1999 07:30'! 123256writeUncompressedOn: file 123257 "Write the receiver on the file in the format depth, extent, offset, bits. Warning: Caller must put header info on file!! Use writeUncompressedOnFileNamed: instead." 123258 self unhibernate. 123259 file binary. 123260 file nextPut: depth. 123261 file nextWordPut: width. 123262 file nextWordPut: height. 123263 file nextWordPut: ((self offset x) >=0 123264 ifTrue: [self offset x] 123265 ifFalse: [self offset x + 65536]). 123266 file nextWordPut: ((self offset y) >=0 123267 ifTrue: [self offset y] 123268 ifFalse: [self offset y + 65536]). 123269 bits writeUncompressedOn: file! ! 123270 123271 123272!Form methodsFor: 'filling' stamp: 'di 2/19/1999 07:07'! 123273anyShapeFill 123274 "Fill the interior of the outermost outlined region in the receiver, a 1-bit deep form. Typically the resulting form is used with fillShape:fillColor: to paint a solid color. See also convexShapeFill:" 123275 123276 | shape | 123277 "Draw a seed line around the edge and fill inward from the outside." 123278 shape := self findShapeAroundSeedBlock: [:f | f borderWidth: 1]. 123279 "Reverse so that this becomes solid in the middle" 123280 shape := shape reverse. 123281 "Finally erase any bits from the original so the fill is only elsewhere" 123282 shape copy: shape boundingBox from: self to: 0@0 rule: Form erase. 123283 ^ shape! ! 123284 123285!Form methodsFor: 'filling'! 123286bitPatternForDepth: suspectedDepth 123287 "Only called when a Form is being used as a fillColor. Use a Pattern or InfiniteForm instead for this purpose. 123288 Interpret me as an array of (32/depth) Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk" 123289 123290 ^ self! ! 123291 123292!Form methodsFor: 'filling' stamp: 'di 9/11/1998 16:25'! 123293convexShapeFill: aMask 123294 "Fill the interior of the outtermost outlined region in the receiver. The outlined region must not be concave by more than 90 degrees. Typically aMask is Color black, to produce a solid fill. then the resulting form is used with fillShape: to paint a solid color. See also anyShapeFill" 123295 | destForm tempForm | 123296 destForm := Form extent: self extent. destForm fillBlack. 123297 tempForm := Form extent: self extent. 123298 (0@0) fourNeighbors do: 123299 [:dir | "Smear self in all 4 directions, and AND the result" 123300 self displayOn: tempForm at: (0@0) - self offset. 123301 tempForm smear: dir distance: (dir dotProduct: tempForm extent) abs. 123302 tempForm displayOn: destForm at: 0@0 123303 clippingBox: destForm boundingBox 123304 rule: Form and fillColor: nil]. 123305 destForm displayOn: self at: 0@0 123306 clippingBox: self boundingBox 123307 rule: Form over fillColor: aMask! ! 123308 123309!Form methodsFor: 'filling' stamp: 'di 10/17/2001 10:09'! 123310eraseShape: bwForm 123311 "use bwForm as a mask to clear all pixels where bwForm has 1's" 123312 ((BitBlt current destForm: self sourceForm: bwForm 123313 fillColor: nil 123314 combinationRule: Form erase1bitShape "Cut a hole in the picture with my mask" 123315 destOrigin: bwForm offset 123316 sourceOrigin: 0@0 123317 extent: self extent clipRect: self boundingBox) 123318 colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) 123319 copyBits. 123320! ! 123321 123322!Form methodsFor: 'filling'! 123323fillFromXColorBlock: colorBlock 123324 "Horizontal Gradient Fill. 123325 Supply relative x in [0.0 ... 1.0] to colorBlock, 123326 and paint each pixel with the color that comes back" 123327 | xRel | 123328 0 to: width-1 do: 123329 [:x | xRel := x asFloat / (width-1) asFloat. 123330 self fill: (x@0 extent: 1@height) 123331 fillColor: (colorBlock value: xRel)] 123332" 123333((Form extent: 100@100 depth: Display depth) 123334 fillFromXColorBlock: [:x | Color r: x g: 0.0 b: 0.5]) display 123335"! ! 123336 123337!Form methodsFor: 'filling' stamp: 'ar 5/17/2001 15:38'! 123338fillFromXYColorBlock: colorBlock 123339 "General Gradient Fill. 123340 Supply relative x and y in [0.0 ... 1.0] to colorBlock, 123341 and paint each pixel with the color that comes back" 123342 | poker yRel xRel | 123343 poker := BitBlt current bitPokerToForm: self. 123344 0 to: height-1 do: 123345 [:y | yRel := y asFloat / (height-1) asFloat. 123346 0 to: width-1 do: 123347 [:x | xRel := x asFloat / (width-1) asFloat. 123348 poker pixelAt: x@y 123349 put: ((colorBlock value: xRel value: yRel) pixelWordForDepth: self depth)]] 123350" 123351 | d | 123352((Form extent: 100@20 depth: Display depth) 123353 fillFromXYColorBlock: 123354 [:x :y | d := 1.0 - (x - 0.5) abs - (y - 0.5) abs. 123355 Color r: d g: 0 b: 1.0-d]) display 123356"! ! 123357 123358!Form methodsFor: 'filling'! 123359fillFromYColorBlock: colorBlock 123360 "Vertical Gradient Fill. 123361 Supply relative y in [0.0 ... 1.0] to colorBlock, 123362 and paint each pixel with the color that comes back" 123363 | yRel | 123364 0 to: height-1 do: 123365 [:y | yRel := y asFloat / (height-1) asFloat. 123366 self fill: (0@y extent: width@1) 123367 fillColor: (colorBlock value: yRel)] 123368" 123369((Form extent: 100@100 depth: Display depth) 123370 fillFromYColorBlock: [:y | Color r: y g: 0.0 b: 0.5]) display 123371"! ! 123372 123373!Form methodsFor: 'filling' stamp: 'ar 5/28/2000 12:08'! 123374fill: aRectangle rule: anInteger fillColor: aForm 123375 "Replace a rectangular area of the receiver with the pattern described by aForm 123376 according to the rule anInteger." 123377 (BitBlt current toForm: self) 123378 copy: aRectangle 123379 from: 0@0 in: nil 123380 fillColor: aForm rule: anInteger! ! 123381 123382!Form methodsFor: 'filling' stamp: 'ar 5/17/2001 15:38'! 123383findShapeAroundSeedBlock: seedBlock 123384 "Build a shape that is black in any region marked by seedBlock. 123385 SeedBlock will be supplied a form, in which to blacken various 123386 pixels as 'seeds'. Then the seeds are smeared until 123387 there is no change in the smear when it fills the region, ie, 123388 when smearing hits a black border and thus goes no further." 123389 | smearForm previousSmear all count smearPort | 123390 self depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms." 123391 all := self boundingBox. 123392 smearForm := Form extent: self extent. 123393 smearPort := BitBlt current toForm: smearForm. 123394 seedBlock value: smearForm. "Blacken seeds to be smeared" 123395 smearPort copyForm: self to: 0@0 rule: Form erase. "Clear any in black" 123396 previousSmear := smearForm deepCopy. 123397 count := 1. 123398 [count = 10 and: "check for no change every 10 smears" 123399 [count := 1. 123400 previousSmear copy: all from: 0@0 in: smearForm rule: Form reverse. 123401 previousSmear isAllWhite]] 123402 whileFalse: 123403 [smearPort copyForm: smearForm to: 1@0 rule: Form under. 123404 smearPort copyForm: smearForm to: -1@0 rule: Form under. 123405 "After horiz smear, trim around the region border" 123406 smearPort copyForm: self to: 0@0 rule: Form erase. 123407 smearPort copyForm: smearForm to: 0@1 rule: Form under. 123408 smearPort copyForm: smearForm to: 0@-1 rule: Form under. 123409 "After vert smear, trim around the region border" 123410 smearPort copyForm: self to: 0@0 rule: Form erase. 123411 count := count+1. 123412 count = 9 ifTrue: "Save penultimate smear for comparison" 123413 [previousSmear copy: all from: 0@0 in: smearForm rule: Form over]]. 123414 "Now paint the filled region in me with aHalftone" 123415 ^ smearForm! ! 123416 123417!Form methodsFor: 'filling' stamp: 'ar 5/14/2001 23:46'! 123418floodFill2: aColor at: interiorPoint 123419 "Fill the shape (4-connected) at interiorPoint. The algorithm is based on Paul Heckbert's 'A Seed Fill Algorithm', Graphic Gems I, Academic Press, 1990. 123420 NOTE: This is a less optimized variant for flood filling which is precisely along the lines of Heckbert's algorithm. For almost all cases #floodFill:at: will be faster (see the comment there) but this method is left in both as reference and as a fallback if such a strange case is encountered in reality." 123421 | peeker poker stack old new x y top x1 x2 dy left goRight | 123422 peeker := BitBlt current bitPeekerFromForm: self. 123423 poker := BitBlt current bitPokerToForm: self. 123424 stack := OrderedCollection new: 50. 123425 "read old pixel value" 123426 old := peeker pixelAt: interiorPoint. 123427 "compute new value" 123428 new := self pixelValueFor: aColor. 123429 old = new ifTrue:[^self]. "no point, is there?!!" 123430 123431 x := interiorPoint x. 123432 y := interiorPoint y. 123433 (y >= 0 and:[y < height]) ifTrue:[ 123434 stack addLast: {y. x. x. 1}. "y, left, right, dy" 123435 stack addLast: {y+1. x. x. -1}]. 123436 [stack isEmpty] whileFalse:[ 123437 top := stack removeLast. 123438 y := top at: 1. x1 := top at: 2. x2 := top at: 3. dy := top at: 4. 123439 y := y + dy. 123440 "Segment of scanline (y-dy) for x1 <= x <= x2 was previously filled. 123441 Now explore adjacent pixels in scanline y." 123442 x := x1. 123443 [x >= 0 and:[(peeker pixelAt: x@y) = old]] whileTrue:[ 123444 poker pixelAt: x@y put: new. 123445 x := x - 1]. 123446 goRight := x < x1. 123447 left := x+1. 123448 (left < x1 and:[y-dy >= 0 and:[y-dy < height]]) 123449 ifTrue:[stack addLast: {y. left. x1-1. 0-dy}]. 123450 goRight ifTrue:[x := x1 + 1]. 123451 [ 123452 goRight ifTrue:[ 123453 [x < width and:[(peeker pixelAt: x@y) = old]] whileTrue:[ 123454 poker pixelAt: x@y put: new. 123455 x := x + 1]. 123456 (y+dy >= 0 and:[y+dy < height]) 123457 ifTrue:[stack addLast: {y. left. x-1. dy}]. 123458 (x > (x2+1) and:[y-dy >= 0 and:[y-dy >= 0]]) 123459 ifTrue:[stack addLast: {y. x2+1. x-1. 0-dy}]]. 123460 [(x := x + 1) <= x2 and:[(peeker pixelAt: x@y) ~= old]] whileTrue. 123461 left := x. 123462 goRight := true. 123463 x <= x2] whileTrue. 123464 ]. 123465! ! 123466 123467!Form methodsFor: 'filling' stamp: 'di 10/20/2001 10:09'! 123468floodFillMapFrom: sourceForm to: scanlineForm mappingColorsWithin: dist to: centerPixVal 123469 "This is a helper routine for floodFill. It's written for clarity (scanning the entire 123470 map using colors) rather than speed (which would require hacking rgb components 123471 in the nieghborhood of centerPixVal. Note that some day a better proximity metric 123472 would be (h s v) where tolerance could be reduced in hue." 123473 123474 | colorMap centerColor | 123475 scanlineForm depth = 32 ifFalse: [self error: 'depth 32 assumed']. 123476 "First get a modifiable identity map" 123477 colorMap := (Color cachedColormapFrom: sourceForm depth to: scanlineForm depth) copy. 123478 centerColor := Color colorFromPixelValue: (centerPixVal bitOr: 16rFFe6) depth: scanlineForm depth. 123479 "Now replace all entries that are close to the centerColor" 123480 1 to: colorMap size do: 123481 [:i | ((Color colorFromPixelValue: ((colorMap at: i) bitOr: 16rFFe6) depth: scanlineForm depth) 123482 diff: centerColor) <= dist ifTrue: [colorMap at: i put: centerPixVal]]. 123483 ^ colorMap! ! 123484 123485!Form methodsFor: 'filling' stamp: 'di 10/20/2001 22:03'! 123486floodFill: aColor at: interiorPoint 123487 Preferences areaFillsAreVeryTolerant ifTrue: 123488 [^ self floodFill: aColor at: interiorPoint tolerance: 0.2]. 123489 Preferences areaFillsAreTolerant ifTrue: 123490 [^ self floodFill: aColor at: interiorPoint tolerance: 0.1]. 123491 ^ self floodFill: aColor at: interiorPoint tolerance: 0 123492! ! 123493 123494!Form methodsFor: 'filling' stamp: 'di 10/20/2001 08:47'! 123495floodFill: aColor at: interiorPoint tolerance: tolerance 123496 "Fill the shape (4-connected) at interiorPoint. The algorithm is based on Paul Heckbert's 'A Seed Fill Algorithm', Graphic Gems I, Academic Press, 1990. 123497 NOTE (ar): This variant has been heavily optimized to prevent the overhead of repeated calls to BitBlt. Usually this is a really big winner but the runtime now depends a bit on the complexity of the shape to be filled. For extremely complex shapes (say, a Hilbert curve) with very few pixels to fill it can be slower than #floodFill2:at: since it needs to repeatedly read the source bits. However, in all practical cases I found this variant to be 15-20 times faster than anything else. 123498 Further note (di): I have added a feature that allows this routine to fill areas of approximately constant color (such as photos, scans, and jpegs). It does this by computing a color map for the peeker that maps all colors close to 'old' into colors identical to old. This mild colorblindness achieves the desired effect with no further change or degradation of the algorithm. tolerance should be 0 (exact match), or a value corresponding to those returned by Color>>diff:, with 0.1 being a reasonable starting choice." 123499 123500 | peeker poker stack old new x y top x1 x2 dy left goRight span spanBits w box debug | 123501 debug := false. "set it to true to see the filling process" 123502 box := interiorPoint extent: 1@1. 123503 span := Form extent: width@1 depth: 32. 123504 spanBits := span bits. 123505 123506 peeker := BitBlt current toForm: span. 123507 peeker 123508 sourceForm: self; 123509 combinationRule: 3; 123510 width: width; 123511 height: 1. 123512 123513 "read old pixel value" 123514 peeker sourceOrigin: interiorPoint; destOrigin: interiorPoint x @ 0; width: 1; copyBits. 123515 old := spanBits at: interiorPoint x + 1. 123516 123517 "compute new value (take care since the algorithm will fail if old = new)" 123518 new := self privateFloodFillValue: aColor. 123519 old = new ifTrue: [^ box]. 123520 tolerance > 0 ifTrue: 123521 ["Set up color map for approximate fills" 123522 peeker colorMap: (self floodFillMapFrom: self to: span mappingColorsWithin: tolerance to: old)]. 123523 123524 poker := BitBlt current toForm: self. 123525 poker 123526 fillColor: aColor; 123527 combinationRule: 3; 123528 width: width; 123529 height: 1. 123530 123531 stack := OrderedCollection new: 50. 123532 x := interiorPoint x. 123533 y := interiorPoint y. 123534 (y >= 0 and:[y < height]) ifTrue:[ 123535 stack addLast: {y. x. x. 1}. "y, left, right, dy" 123536 stack addLast: {y+1. x. x. -1}]. 123537 123538 [stack isEmpty] whileFalse:[ 123539 debug ifTrue:[self displayOn: Display]. 123540 top := stack removeLast. 123541 y := top at: 1. x1 := top at: 2. x2 := top at: 3. dy := top at: 4. 123542 y := y + dy. 123543 debug ifTrue:[ 123544 (Line from: (x1-1)@y to: (x2+1)@y 123545 withForm: (Form extent: 1@1 depth: 8) fillWhite) displayOn: Display]. 123546 "Segment of scanline (y-dy) for x1 <= x <= x2 was previously filled. 123547 Now explore adjacent pixels in scanline y." 123548 peeker sourceOrigin: 0@y; destOrigin: 0@0; width: width; copyBits. 123549 "Note: above is necessary since we don't know where we'll end up filling" 123550 x := x1. 123551 w := 0. 123552 [x >= 0 and:[(spanBits at: x+1) = old]] whileTrue:[ 123553 w := w + 1. 123554 x := x - 1]. 123555 w > 0 ifTrue:[ 123556 "overwrite pixels" 123557 poker destOrigin: x+1@y; width: w; copyBits. 123558 box := box quickMerge: ((x+1@y) extent: w@1)]. 123559 goRight := x < x1. 123560 left := x+1. 123561 (left < x1 and:[y-dy >= 0 and:[y-dy < height]]) 123562 ifTrue:[stack addLast: {y. left. x1-1. 0-dy}]. 123563 goRight ifTrue:[x := x1 + 1]. 123564 [ 123565 goRight ifTrue:[ 123566 w := 0. 123567 [x < width and:[(spanBits at: x+1) = old]] whileTrue:[ 123568 w := w + 1. 123569 x := x + 1]. 123570 w > 0 ifTrue:[ 123571 "overwrite pixels" 123572 poker destOrigin: (x-w)@y; width: w; copyBits. 123573 box := box quickMerge: ((x-w@y) extent: w@1)]. 123574 (y+dy >= 0 and:[y+dy < height]) 123575 ifTrue:[stack addLast: {y. left. x-1. dy}]. 123576 (x > (x2+1) and:[y-dy >= 0 and:[y-dy >= 0]]) 123577 ifTrue:[stack addLast: {y. x2+1. x-1. 0-dy}]]. 123578 [(x := x + 1) <= x2 and:[(spanBits at: x+1) ~= old]] whileTrue. 123579 left := x. 123580 goRight := true. 123581 x <= x2] whileTrue. 123582 ]. 123583 ^box! ! 123584 123585!Form methodsFor: 'filling' stamp: 'di 10/17/2001 10:10'! 123586shapeFill: aColor interiorPoint: interiorPoint 123587 "Identify the shape (region of identical color) at interiorPoint, 123588 and then fill that shape with the new color, aColor 123589 : modified di's original method such that it returns the bwForm, for potential use by the caller" 123590 123591 | bwForm interiorPixVal map ppd color ind | 123592 self depth = 1 ifTrue: 123593 [^ self shapeFill: aColor 123594 seedBlock: [:form | form pixelValueAt: interiorPoint put: 1]]. 123595 123596 "First map this form into a B/W form with 0's in the interior region." 123597 "bwForm := self makeBWForm: interiorColor." "won't work for two whites" 123598 interiorPixVal := self pixelValueAt: interiorPoint. 123599 bwForm := Form extent: self extent. 123600 map := Bitmap new: (1 bitShift: (self depth min: 12)). "Not calling newColorMap. All 123601 non-foreground go to 0. Length is 2 to 4096." 123602 ppd := self depth. "256 long color map in depth 8 is not one of the following cases" 123603 3 to: 5 do: [:bitsPerColor | 123604 (2 raisedTo: bitsPerColor*3) = map size 123605 ifTrue: [ppd := bitsPerColor*3]]. "ready for longer maps than 512" 123606 123607 ppd <= 8 123608 ifTrue: [map at: interiorPixVal+1 put: 1] 123609 ifFalse: [interiorPixVal = 0 123610 ifFalse: [color := Color colorFromPixelValue: interiorPixVal depth: self depth. 123611 ind := color pixelValueForDepth: ppd. 123612 map at: ind+1 put: 1] 123613 ifTrue: [map at: 1 put: 1]]. 123614 bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map. 123615 bwForm reverse. "Make interior region be 0's" 123616 123617 "Now fill the interior region and return that shape" 123618 bwForm := bwForm findShapeAroundSeedBlock: 123619 [:form | form pixelValueAt: interiorPoint put: 1]. 123620 123621 "Finally use that shape as a mask to flood the region with color" 123622 self eraseShape: bwForm. 123623 self fillShape: bwForm fillColor: aColor. 123624 ^ bwForm! ! 123625 123626!Form methodsFor: 'filling' stamp: 'ar 5/17/2001 15:38'! 123627shapeFill: aColor seedBlock: seedBlock 123628 self depth > 1 ifTrue: [self error: 'This call only meaningful for B/W forms']. 123629 (self findShapeAroundSeedBlock: seedBlock) 123630 displayOn: self at: 0@0 clippingBox: self boundingBox 123631 rule: Form under fillColor: aColor ! ! 123632 123633 123634!Form methodsFor: 'image manipulation' stamp: 'ar 5/17/2001 15:40'! 123635replaceColor: oldColor withColor: newColor 123636 "Replace one color with another everywhere is this form" 123637 123638 | cm newInd target ff | 123639 self depth = 32 123640 ifTrue: [cm := (Color cachedColormapFrom: 16 to: 32) copy] 123641 ifFalse: [cm := Bitmap new: (1 bitShift: (self depth min: 15)). 123642 1 to: cm size do: [:i | cm at: i put: i - 1]]. 123643 newInd := newColor pixelValueForDepth: self depth. 123644 cm at: (oldColor pixelValueForDepth: (self depth min: 16))+1 put: newInd. 123645 target := newColor isTransparent 123646 ifTrue: [ff := Form extent: self extent depth: depth. 123647 ff fillWithColor: newColor. ff] 123648 ifFalse: [self]. 123649 (BitBlt current toForm: target) 123650 sourceForm: self; 123651 sourceOrigin: 0@0; 123652 combinationRule: Form paint; 123653 destX: 0 destY: 0 width: width height: height; 123654 colorMap: cm; 123655 copyBits. 123656 newColor = Color transparent 123657 ifTrue: [target displayOn: self].! ! 123658 123659!Form methodsFor: 'image manipulation' stamp: 'ar 5/28/2000 12:09'! 123660smear: dir distance: dist 123661 "Smear any black pixels in this form in the direction dir in Log N steps" 123662 | skew bb | 123663 bb := BitBlt current destForm: self sourceForm: self fillColor: nil 123664 combinationRule: Form under destOrigin: 0@0 sourceOrigin: 0@0 123665 extent: self extent clipRect: self boundingBox. 123666 skew := 1. 123667 [skew < dist] whileTrue: 123668 [bb destOrigin: dir*skew; copyBits. 123669 skew := skew+skew]! ! 123670 123671!Form methodsFor: 'image manipulation' stamp: 'LB 8/26/2002 18:08'! 123672stencil 123673 "return a 1-bit deep, black-and-white stencil of myself" 123674 123675 | canvas | 123676 canvas := FormCanvas extent: self extent depth: 1. 123677 canvas fillColor: (Color white). 123678 123679 canvas stencil: self at: 0@0 123680 sourceRect: (Rectangle origin: 0@0 corner: self extent) color: Color black. 123681 123682 ^ canvas form 123683! ! 123684 123685!Form methodsFor: 'image manipulation' stamp: 'jm 6/30/1999 15:36'! 123686trimBordersOfColor: aColor 123687 "Answer a copy of this Form with each edge trimmed in to the first pixel that is not of the given color. (That is, border strips of the given color are removed)." 123688 123689 | r | 123690 r := self rectangleEnclosingPixelsNotOfColor: aColor. 123691 ^ self copy: r 123692! ! 123693 123694 123695!Form methodsFor: 'initialization' stamp: 'ar 5/17/2001 22:54'! 123696allocateForm: extentPoint 123697 "Allocate a new form which is similar to the receiver and can be used for accelerated blts" 123698 ^Form extent: extentPoint depth: self nativeDepth! ! 123699 123700!Form methodsFor: 'initialization' stamp: 'ar 5/26/2000 00:46'! 123701finish 123702 "If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect."! ! 123703 123704!Form methodsFor: 'initialization' stamp: 'ar 5/26/2000 00:45'! 123705flush 123706 "If there are any pending operations on the receiver start doing them. In time, they will show up on the receiver but not necessarily immediately after this method returns."! ! 123707 123708!Form methodsFor: 'initialization'! 123709fromDisplay: aRectangle 123710 "Create a virtual bit map from a user specified rectangular area on the 123711 display screen. Reallocates bitmap only if aRectangle ~= the receiver's 123712 extent." 123713 123714 (width = aRectangle width and: [height = aRectangle height]) 123715 ifFalse: [self setExtent: aRectangle extent depth: depth]. 123716 self 123717 copyBits: (aRectangle origin extent: self extent) 123718 from: Display 123719 at: 0 @ 0 123720 clippingBox: self boundingBox 123721 rule: Form over 123722 fillColor: nil! ! 123723 123724!Form methodsFor: 'initialization' stamp: 'ar 5/28/2000 18:45'! 123725shutDown 123726 "The system is going down. Try to preserve some space" 123727 self hibernate! ! 123728 123729!Form methodsFor: 'initialization' stamp: 'ar 6/16/2002 18:39'! 123730swapEndianness 123731 "Swap from big to little endian pixels and vice versa" 123732 depth := 0 - depth.! ! 123733 123734 123735!Form methodsFor: 'other' stamp: 'ar 12/12/2003 18:24'! 123736fixAlpha 123737 "Fix the alpha channel if the receiver is 32bit" 123738 | bb | 123739 self depth = 32 ifFalse:[^self]. 123740 bb := BitBlt toForm: self. 123741 bb combinationRule: 40 "fixAlpha:with:". 123742 bb copyBits.! ! 123743 123744!Form methodsFor: 'other' stamp: 'jm 9/27/97 21:02'! 123745formForColorCount: colorCount 123746 "Return a ColorForm of sufficient depth to represent the given number of colors. The maximum number of colors is 256." 123747 123748 colorCount > 256 ifTrue: [^ self error: 'too many colors']. 123749 123750 colorCount > 16 ifTrue: [^ ColorForm extent: self extent depth: 8]. 123751 colorCount > 4 ifTrue: [^ ColorForm extent: self extent depth: 4]. 123752 colorCount > 2 ifTrue: [^ ColorForm extent: self extent depth: 2]. 123753 ^ ColorForm extent: self extent depth: 1 123754! ! 123755 123756!Form methodsFor: 'other' stamp: 'jm 1/6/98 10:37'! 123757primPrintHScale: hScale vScale: vScale landscape: aBoolean 123758 "On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer." 123759 "(Form extent: 10@10) primPrintHScale: 1.0 vScale: 1.0 landscape: true" 123760 123761 <primitive: 232> 123762 self primitiveFailed 123763! ! 123764 123765!Form methodsFor: 'other' stamp: 'RAA 1/30/2002 16:42'! 123766relativeTextAnchorPosition 123767 123768 ^nil "so forms can be in TextAnchors"! ! 123769 123770!Form methodsFor: 'other' stamp: 'alain.plantec 5/30/2008 13:28'! 123771setAsBackground 123772 "Set this form as a background image." 123773 | world newColor | 123774 world := self currentWorld. 123775 newColor := InfiniteForm with: self. 123776 self rememberCommand: (Command new cmdWording: 'set background to a picture' translated; 123777 123778 undoTarget: world 123779 selector: #color: 123780 argument: world color; 123781 123782 redoTarget: world 123783 selector: #color: 123784 argument: newColor). 123785 world color: newColor! ! 123786 123787 123788!Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:42'! 123789colorAt: aPoint 123790 "Return the color in the pixel at the given point. " 123791 123792 ^ Color 123793 colorFromPixelValue: (self pixelValueAt: aPoint) 123794 depth: self depth 123795! ! 123796 123797!Form methodsFor: 'pixel access' stamp: 'ar 5/14/2001 23:46'! 123798colorAt: aPoint put: aColor 123799 "Store a Color into the pixel at coordinate aPoint. " 123800 123801 self pixelValueAt: aPoint put: (self pixelValueFor: aColor). 123802 123803"[Sensor anyButtonPressed] whileFalse: 123804 [Display colorAt: Sensor cursorPoint put: Color red]" 123805! ! 123806 123807!Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:39'! 123808isTransparentAt: aPoint 123809 "Return true if the receiver is transparent at the given point." 123810 123811 self depth = 1 ifTrue: [^ false]. "no transparency at depth 1" 123812 ^ (self pixelValueAt: aPoint) = (self pixelValueFor: Color transparent) 123813! ! 123814 123815!Form methodsFor: 'pixel access' stamp: 'ar 5/28/2000 12:08'! 123816pixelValueAt: aPoint 123817 "Return the raw pixel value at the given point. This pixel value depends on the receiver's depth. Typical clients use colorAt: to get a Color. " 123818 123819 ^ (BitBlt current bitPeekerFromForm: self) pixelAt: aPoint 123820! ! 123821 123822!Form methodsFor: 'pixel access' stamp: 'ar 5/28/2000 12:08'! 123823pixelValueAt: aPoint put: pixelValue 123824 "Store the given raw pixel value at the given point. Typical clients use colorAt:put: to store a color. " 123825 123826 (BitBlt current bitPokerToForm: self) pixelAt: aPoint put: pixelValue. 123827! ! 123828 123829 123830!Form methodsFor: 'postscript generation' stamp: 'ar 5/17/2001 15:36'! 123831bitsPerComponent 123832 ^self depth <= 8 ifTrue:[self depth] ifFalse:[8]. 123833! ! 123834 123835!Form methodsFor: 'postscript generation' stamp: 'mpw 11/14/1999 22:22'! 123836bytesPerRow 123837 ^ self numComponents * self paddedWidth * self bitsPerComponent / 8.! ! 123838 123839!Form methodsFor: 'postscript generation' stamp: 'ar 5/17/2001 15:39'! 123840decodeArray 123841 ^self depth <= 8 ifTrue:['[1 0]'] ifFalse:['[0 1 0 1 0 1 ]']. 123842! ! 123843 123844!Form methodsFor: 'postscript generation' stamp: 'ar 5/17/2001 15:43'! 123845numComponents 123846 ^self depth <= 8 ifTrue:[1] ifFalse:[3]. 123847! ! 123848 123849!Form methodsFor: 'postscript generation'! 123850paddedWidth 123851 ^ (self width + (self rowPadding-1)// self rowPadding) * self rowPadding.! ! 123852 123853!Form methodsFor: 'postscript generation' stamp: 'nk 12/31/2003 15:46'! 123854printPostscript: aStream operator: operator 123855 aStream preserveStateDuring: 123856 [:inner | 123857 inner rectclip: (0 @ 0 extent: width @ height). 123858 self setColorspaceOn: inner. 123859 inner 123860 print: '[ '; 123861 cr; 123862 print: '/ImageType 1'; 123863 cr; 123864 print: '/ImageMatrix [1 0 0 1 0 0]'; 123865 cr; 123866 print: '/MultipleDataSources false'; 123867 cr; 123868 print: '/DataSource level1 { { currentfile '; 123869 write: self bytesPerRow; 123870 print: ' string readhexstring pop }} bind { currentfile /ASCIIHexDecode filter } ifelse'; 123871 cr; 123872 print: '/Width '; 123873 write: self paddedWidth; 123874 cr; 123875 print: '/Height '; 123876 write: self height; 123877 cr; 123878 print: '/Decode '; 123879 print: self decodeArray; 123880 cr; 123881 print: '/BitsPerComponent '; 123882 write: self bitsPerComponent; 123883 cr; 123884 print: 'makeDict '; 123885 print: operator; 123886 cr. 123887 self storePostscriptHexOn: inner. 123888 inner 123889 print: $>; 123890 cr. 123891 inner cr]. 123892 aStream cr! ! 123893 123894!Form methodsFor: 'postscript generation' stamp: 'mpw 11/15/1999 08:34'! 123895rowPadding 123896 ^ 32 // self depth! ! 123897 123898!Form methodsFor: 'postscript generation'! 123899setColorspaceOn:aStream 123900 self numComponents = 1 ifTrue:[aStream print:'/DeviceGray setcolorspace 0 setgray'; cr.] 123901 ifFalse:[aStream print:'/DeviceRGB setcolorspace'; cr.].! ! 123902 123903!Form methodsFor: 'postscript generation' stamp: 'nk 12/31/2003 15:46'! 123904storePostscriptHexOn: inner 123905 self depth <= 8 ifTrue: [self storeHexBitsOn: inner]. 123906 self depth = 16 ifTrue: [self store15To24HexBitsOn: inner]. 123907 self depth = 32 ifTrue: [self store32To24HexBitsOn: inner]! ! 123908 123909 123910!Form methodsFor: 'resources' stamp: 'ar 12/9/2002 16:04'! 123911readNativeResourceFrom: byteStream 123912 | img aStream | 123913 (byteStream isKindOf: FileStream) ifTrue:[ 123914 "Ugly, but ImageReadWriter will send #reset which is implemented as #reopen and we may not be able to do so." 123915 aStream := RWBinaryOrTextStream with: byteStream contents. 123916 ] ifFalse:[ 123917 aStream := byteStream. 123918 ]. 123919 img := [ImageReadWriter formFromStream: aStream] on: Error do:[:ex| nil]. 123920 img ifNil:[^nil]. 123921 (img isColorForm and:[self isColorForm]) ifTrue:[ 123922 | cc | 123923 cc := img colors. 123924 img colors: nil. 123925 img displayOn: self. 123926 img colors: cc. 123927 ] ifFalse:[ 123928 img displayOn: self. 123929 ]. 123930 img := nil.! ! 123931 123932!Form methodsFor: 'resources' stamp: 'nk 7/30/2004 17:53'! 123933readResourceFrom: aStream 123934 "Store a resource representation of the receiver on aStream. 123935 Must be specific to the receiver so that no code is filed out." 123936 123937 | bitsSize msb | 123938 (aStream next: 4) asString = self resourceTag 123939 ifFalse: 123940 [aStream position: aStream position - 4. 123941 ^self readNativeResourceFrom: aStream]. 123942 width := aStream nextNumber: 4. 123943 height := aStream nextNumber: 4. 123944 depth := aStream nextNumber: 4. 123945 bitsSize := aStream nextNumber: 4. 123946 bitsSize = 0 123947 ifFalse: 123948 [bits := aStream next: bitsSize. 123949 ^self]. 123950 msb := (aStream nextNumber: 4) = 1. 123951 bitsSize := aStream nextNumber: 4. 123952 bits := Bitmap new: self bitsSize. 123953 (Form 123954 extent: width @ height 123955 depth: depth 123956 bits: (aStream next: bitsSize * 4)) displayOn: self. 123957 msb = SmalltalkImage current isBigEndian 123958 ifFalse: 123959 [Bitmap 123960 swapBytesIn: bits 123961 from: 1 123962 to: bits size]! ! 123963 123964!Form methodsFor: 'resources' stamp: 'ar 2/27/2001 14:56'! 123965resourceTag 123966 ^'FORM'! ! 123967 123968!Form methodsFor: 'resources' stamp: 'sd 9/30/2003 13:41'! 123969storeResourceOn: aStream 123970 "Store a resource representation of the receiver on aStream. 123971 Must be specific to the receiver so that no code is filed out." 123972 self hibernate. 123973 aStream nextPutAll: self resourceTag asByteArray. "tag" 123974 aStream nextNumber: 4 put: width. 123975 aStream nextNumber: 4 put: height. 123976 aStream nextNumber: 4 put: depth. 123977 (bits isMemberOf: ByteArray) ifFalse:[ 123978 "must store bitmap" 123979 aStream nextNumber: 4 put: 0. "tag" 123980 aStream nextNumber: 4 put: (SmalltalkImage current isBigEndian ifTrue:[1] ifFalse:[0]). 123981 ]. 123982 aStream nextNumber: 4 put: bits size. 123983 aStream nextPutAll: bits. 123984! ! 123985 123986 123987!Form methodsFor: 'scaling, rotation' stamp: 'ar 5/14/2001 23:33'! 123988flipBy: direction centerAt: aPoint 123989 "Return a copy of the receiver flipped either #vertical or #horizontal." 123990 | newForm quad | 123991 newForm := self class extent: self extent depth: depth. 123992 quad := self boundingBox innerCorners. 123993 quad := (direction = #vertical ifTrue: [#(2 1 4 3)] ifFalse: [#(4 3 2 1)]) 123994 collect: [:i | quad at: i]. 123995 (WarpBlt current toForm: newForm) 123996 sourceForm: self; 123997 colorMap: (self colormapIfNeededFor: newForm); 123998 combinationRule: 3; 123999 copyQuad: quad toRect: newForm boundingBox. 124000 newForm offset: (self offset flipBy: direction centerAt: aPoint). 124001 ^ newForm 124002" 124003[Sensor anyButtonPressed] whileFalse: 124004 [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) 124005 flipBy: #vertical centerAt: 0@0) display] 124006" 124007"Consistency test... 124008 | f f2 p | [Sensor anyButtonPressed] whileFalse: 124009 [f := Form fromDisplay: ((p := Sensor cursorPoint) extent: 31@41). 124010 Display fillBlack: (p extent: 31@41). 124011 f2 := f flipBy: #vertical centerAt: 0@0. 124012 (f2 flipBy: #vertical centerAt: 0@0) displayAt: p] 124013" 124014! ! 124015 124016!Form methodsFor: 'scaling, rotation' stamp: 'tpr 9/28/2004 17:00'! 124017magnifyBy: scale 124018 "Answer a Form created as a scaling of the receiver. 124019 Scale may be a Float or even a Point, and may be greater or less than 1.0." 124020 124021 ^ self magnify: self boundingBox by: scale 124022 smoothing: (scale < 1 ifTrue: [2] ifFalse: [1])! ! 124023 124024!Form methodsFor: 'scaling, rotation'! 124025magnify: aRectangle by: scale 124026 "Answer a Form created as a scaling of the receiver. 124027 Scale may be a Float, and may be greater or less than 1.0." 124028 ^ self magnify: aRectangle by: scale smoothing: 1 124029 124030"Dynamic test... 124031[Sensor anyButtonPressed] whileFalse: 124032 [(Display magnify: (Sensor cursorPoint extent: 31@41) by: 5@3) display] 124033" 124034"Scaling test... 124035| f cp | f := Form fromDisplay: (Rectangle originFromUser: 100@100). 124036Display restoreAfter: [Sensor waitNoButton. 124037[Sensor anyButtonPressed] whileFalse: 124038 [cp := Sensor cursorPoint. 124039 (f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent) display]] 124040" 124041"Consistency test... 124042 | f f2 p | [Sensor anyButtonPressed] whileFalse: 124043 [f := Form fromDisplay: ((p := Sensor cursorPoint) extent: 31@41). 124044 Display fillBlack: (p extent: 31@41). 124045 f2 := f magnify: f boundingBox by: 5@3. 124046 (f2 shrink: f2 boundingBox by: 5@3) displayAt: p] 124047" 124048! ! 124049 124050!Form methodsFor: 'scaling, rotation' stamp: 'tpr 9/28/2004 17:00'! 124051magnify: aRectangle by: scale smoothing: cellSize 124052 "Answer a Form created as a scaling of the receiver. 124053 Scale may be a Float or even a Point, and may be greater or less than 1.0." 124054 | newForm | 124055 newForm := self blankCopyOf: aRectangle scaledBy: scale. 124056 (WarpBlt current toForm: newForm) 124057 sourceForm: self; 124058 colorMap: (self colormapIfNeededFor: newForm); 124059 cellSize: cellSize; "installs a new colormap if cellSize > 1" 124060 combinationRule: 3; 124061 copyQuad: aRectangle innerCorners toRect: newForm boundingBox. 124062 ^ newForm 124063 124064"Dynamic test... 124065[Sensor anyButtonPressed] whileFalse: 124066 [(Display magnify: (Sensor cursorPoint extent: 131@81) by: 0.5 smoothing: 2) display] 124067" 124068"Scaling test... 124069| f cp | f := Form fromDisplay: (Rectangle originFromUser: 100@100). 124070Display restoreAfter: [Sensor waitNoButton. 124071[Sensor anyButtonPressed] whileFalse: 124072 [cp := Sensor cursorPoint. 124073 (f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent smoothing: 2) display]] 124074"! ! 124075 124076!Form methodsFor: 'scaling, rotation'! 124077rotateBy: deg 124078 "Rotate the receiver by the indicated number of degrees." 124079 "rot is the destination form, bit enough for any angle." 124080 124081 ^ self rotateBy: deg smoothing: 1 124082" 124083 | a f | f := Form fromDisplay: (0@0 extent: 200@200). a := 0. 124084[Sensor anyButtonPressed] whileFalse: 124085 [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) 124086 rotateBy: (a := a+5)) display]. 124087f display 124088"! ! 124089 124090!Form methodsFor: 'scaling, rotation' stamp: 'wiz 1/22/2006 01:15'! 124091rotateBy: direction centerAt: aPoint 124092 "Return a rotated copy of the receiver. 124093 direction = #none, #right, #left, or #pi" 124094 | newForm quad rot scale | 124095 direction == #none ifTrue: [^ self]. 124096 scale := (direction = #pi ifTrue: [width@height] ifFalse: [height@width]) / self extent . 124097 newForm := self blankCopyOf: self boundingBox scaledBy: scale. 124098 quad := self boundingBox innerCorners. 124099 rot := #(right pi left) indexOf: direction. 124100 (WarpBlt current toForm: newForm) 124101 sourceForm: self; 124102 colorMap: (self colormapIfNeededFor: newForm); 124103 combinationRule: 3; 124104 copyQuad: ((1+rot to: 4+rot) collect: [:i | quad atWrap: i]) 124105 toRect: newForm boundingBox. 124106 newForm offset: (self offset rotateBy: direction centerAt: aPoint). 124107 ^ newForm 124108" 124109[Sensor anyButtonPressed] whileFalse: 124110 [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) 124111 rotateBy: #left centerAt: 0@0) display] 124112" 124113"Consistency test... 124114 | f f2 p | [Sensor anyButtonPressed] whileFalse: 124115 [f := Form fromDisplay: ((p := Sensor cursorPoint) extent: 31@41). 124116 Display fillBlack: (p extent: 31@41). 124117 f2 := f rotateBy: #left centerAt: 0@0. 124118 (f2 rotateBy: #right centerAt: 0@0) displayAt: p] 124119" 124120! ! 124121 124122!Form methodsFor: 'scaling, rotation' stamp: 'ar 3/1/2006 23:04'! 124123rotateBy: deg magnify: scale smoothing: cellSize 124124 "Rotate the receiver by the indicated number of degrees and magnify. scale can be a Point to make for interesting 3D effects " 124125 "rot is the destination form, big enough for any angle." 124126 124127 | side rot warp r1 pts p bigSide | 124128 side := 1 + self extent r asInteger. 124129 bigSide := (side asPoint * scale) rounded. 124130 rot := self blankCopyOf: self boundingBox scaledBy: ( bigSide / self extent ). 124131 warp := (WarpBlt current toForm: rot) 124132 sourceForm: self; 124133 colorMap: (self colormapIfNeededFor: rot); 124134 cellSize: cellSize; "installs a new colormap if cellSize > 1" 124135 combinationRule: Form paint. 124136 r1 := (0@0 extent: side@side) align: (side@side)//2 with: self boundingBox center. 124137 124138 "Rotate the corners of the source rectangle." 124139 pts := r1 innerCorners collect: 124140 [:pt | p := pt - r1 center. 124141 (r1 center x asFloat + (p x asFloat*deg degreeCos) + (p y asFloat*deg degreeSin)) @ 124142 (r1 center y asFloat - (p x asFloat*deg degreeSin) + (p y asFloat*deg degreeCos))]. 124143 warp copyQuad: pts toRect: rot boundingBox. 124144 ^ rot 124145" 124146 | a f | f := Form fromDisplay: (0@0 extent: 200@200). a := 0. 124147[Sensor anyButtonPressed] whileFalse: 124148 [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) 124149 rotateBy: (a := a+5) magnify: 0.75@2 smoothing: 2) display]. 124150f display 124151"! ! 124152 124153!Form methodsFor: 'scaling, rotation' stamp: 'tpr 9/28/2004 16:55'! 124154rotateBy: deg smoothing: cellSize 124155 "Rotate the receiver by the indicated number of degrees." 124156 ^self rotateBy: deg magnify: 1 smoothing: cellSize 124157" 124158 | a f | f := Form fromDisplay: (0@0 extent: 200@200). a := 0. 124159[Sensor anyButtonPressed] whileFalse: 124160 [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) 124161 rotateBy: (a := a+5) smoothing: 2) display]. 124162f display 124163"! ! 124164 124165!Form methodsFor: 'scaling, rotation' stamp: 'RAA 7/13/2000 12:09'! 124166scaledToSize: newExtent 124167 124168 | scale | 124169 124170 newExtent = self extent ifTrue: [^self]. 124171 scale := newExtent x / self width min: newExtent y / self height. 124172 ^self magnify: self boundingBox by: scale smoothing: 2. 124173! ! 124174 124175!Form methodsFor: 'scaling, rotation'! 124176shrink: aRectangle by: scale 124177 | scalePt | 124178 scalePt := scale asPoint. 124179 ^ self magnify: aRectangle by: (1.0 / scalePt x asFloat) @ (1.0 / scalePt y asFloat)! ! 124180 124181 124182!Form methodsFor: 'testing' stamp: 'ar 5/15/2001 16:14'! 124183hasNonStandardPalette 124184 "Return true if the receiver has a non-standard palette. 124185 Non-standard means that RGBA components may be located 124186 at positions differing from the standard Squeak RGBA layout 124187 at the receiver's depth." 124188 ^false! ! 124189 124190!Form methodsFor: 'testing' stamp: 'ar 7/21/2007 21:37'! 124191isAllWhite 124192 "Answer whether all bits in the receiver are white" 124193 | word | 124194 self unhibernate. 124195 word := Color white pixelWordForDepth: self depth. 124196 1 to: bits size do: [:i | (bits at: i) = word ifFalse: [^ false]]. 124197 ^ true! ! 124198 124199!Form methodsFor: 'testing' stamp: 'ar 5/17/2001 15:46'! 124200isBigEndian 124201 "Return true if the receiver contains big endian pixels, meaning the left-most pixel is stored in the most significant bits of a word." 124202 ^depth > 0! ! 124203 124204!Form methodsFor: 'testing' stamp: 'ar 5/28/2000 14:58'! 124205isBltAccelerated: ruleInteger for: sourceForm 124206 "Return true if the receiver can perform accelerated blts operations by itself" 124207 ^false! ! 124208 124209!Form methodsFor: 'testing' stamp: 'ar 5/28/2000 15:04'! 124210isDisplayScreen 124211 ^false! ! 124212 124213!Form methodsFor: 'testing' stamp: 'ar 5/27/2000 16:54'! 124214isExternalForm 124215 ^false! ! 124216 124217!Form methodsFor: 'testing' stamp: 'ar 5/28/2000 14:58'! 124218isFillAccelerated: ruleInteger for: aColor 124219 "Return true if the receiver can perform accelerated fill operations by itself" 124220 ^false! ! 124221 124222!Form methodsFor: 'testing' stamp: 'ar 10/30/2000 23:23'! 124223isForm 124224 ^true! ! 124225 124226!Form methodsFor: 'testing' stamp: 'ar 5/17/2001 15:47'! 124227isLittleEndian 124228 "Return true if the receiver contains little endian pixels, meaning the left-most pixel is stored in the least significant bits of a word." 124229 ^depth < 0! ! 124230 124231!Form methodsFor: 'testing' stamp: 'RAA 8/14/2000 10:00'! 124232isStatic 124233 124234 ^false! ! 124235 124236!Form methodsFor: 'testing' stamp: 'ar 2/10/2004 17:18'! 124237isTranslucent 124238 "Answer whether this form may be translucent" 124239 ^self depth = 32! ! 124240 124241!Form methodsFor: 'testing' stamp: 'ar 5/28/2000 14:58'! 124242shouldPreserveContents 124243 "Return true if the receiver should preserve it's contents when flagged to be clean. Most forms can not be trivially restored by some drawing operation but some may." 124244 ^true! ! 124245 124246 124247!Form methodsFor: 'transitions' stamp: 'ar 5/17/2001 15:42'! 124248fadeImageCoarse: otherImage at: topLeft 124249 "Display fadeImageCoarse: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40" 124250 | pix j d | 124251 d := self depth. 124252 ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: 124253 [:i :mask | 124254 i=1 ifTrue: [pix := (1 bitShift: d) - 1. 124255 1 to: 8//d-1 do: [:q | pix := pix bitOr: (pix bitShift: d*4)]]. 124256 i <= 16 ifTrue: 124257 [j := i-1//4+1. 124258 (0 to: 28 by: 4) do: [:k | 124259 mask bits at: j+k 124260 put: ((mask bits at: j+k) bitOr: (pix bitShift: i-1\\4*d))]. 124261 "mask display." true] 124262 ifFalse: [false]]! ! 124263 124264!Form methodsFor: 'transitions' stamp: 'ar 5/17/2001 15:41'! 124265fadeImageFine: otherImage at: topLeft 124266 "Display fadeImageFine: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40" 124267 | pix j ii d | 124268 d := self depth. 124269 ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: 124270 [:i :mask | 124271 i=1 ifTrue: [pix := (1 bitShift: d) - 1. 124272 1 to: 8//d-1 do: 124273 [:q | pix := pix bitOr: (pix bitShift: d*4)]]. 124274 i <= 16 ifTrue: 124275 [ii := #(0 10 2 8 7 13 5 15 1 11 3 9 6 12 4 14) at: i. 124276 j := ii//4+1. 124277 (0 to: 28 by: 4) do: 124278 [:k | mask bits at: j+k put: 124279 ((mask bits at: j+k) bitOr: (pix bitShift: ii\\4*d))]. 124280 true] 124281 ifFalse: [false]]! ! 124282 124283!Form methodsFor: 'transitions'! 124284fadeImageHorFine: otherImage at: topLeft 124285 "Display fadeImageHorFine: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10" 124286 ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: 124287 [:i :mask | 124288 mask fill: (0@(i-1) extent: mask width@1) fillColor: Color black. 124289 mask fill: (0@(i-1+16) extent: mask width@1) fillColor: Color black. 124290 (i*2) <= mask width]! ! 124291 124292!Form methodsFor: 'transitions'! 124293fadeImageHor: otherImage at: topLeft 124294 "Display fadeImageHor: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10" 124295 ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: 124296 [:i :mask | 124297 mask fill: (0@(mask height//2-i) extent: mask width@(i*2)) fillColor: Color black. 124298 (i*2) <= mask width]! ! 124299 124300!Form methodsFor: 'transitions'! 124301fadeImageSquares: otherImage at: topLeft 124302 "Display fadeImageSquares: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40" 124303 ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: 124304 [:i :mask | 124305 mask fill: ((16-i) asPoint extent: (i*2) asPoint) fillColor: Color black. 124306 i <= 16]! ! 124307 124308!Form methodsFor: 'transitions' stamp: 'ar 5/17/2001 15:39'! 124309fadeImageVert: otherImage at: topLeft 124310 "Display fadeImageVert: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10" 124311 | d | 124312 d := self depth. 124313 ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: 124314 [:i :mask | 124315 mask fill: ((mask width//2//d-i*d)@0 extent: i*2*d@mask height) fillColor: Color black. 124316 i <= (mask width//d)]! ! 124317 124318!Form methodsFor: 'transitions' stamp: 'jm 5/21/1998 23:46'! 124319fadeImage: otherImage at: topLeft 124320 indexAndMaskDo: indexAndMaskBlock 124321 "This fade uses halftones as a blending hack. 124322 Zeros in the halftone produce the original image (self), and 124323 ones in the halftone produce the 'otherImage'. 124324 IndexAndMaskBlock gets evaluated prior to each cycle, 124325 and the resulting boolean determines whether to continue cycling." 124326 | index imageRect maskForm resultForm | 124327 imageRect := otherImage boundingBox. 124328 resultForm := self copy: (topLeft extent: imageRect extent). 124329 maskForm := Form extent: 32@32. 124330 index := 0. 124331 [indexAndMaskBlock value: (index := index+1) value: maskForm] 124332 whileTrue: 124333 [maskForm reverse. 124334 resultForm copyBits: imageRect from: resultForm at: 0@0 124335 clippingBox: imageRect rule: Form over fillColor: maskForm. 124336 maskForm reverse. 124337 resultForm copyBits: imageRect from: otherImage at: 0@0 124338 clippingBox: imageRect rule: Form under fillColor: maskForm. 124339 self copyBits: imageRect from: resultForm at: topLeft 124340 clippingBox: self boundingBox rule: Form over fillColor: nil. 124341 Display forceDisplayUpdate]! ! 124342 124343!Form methodsFor: 'transitions' stamp: 'jm 6/1/1998 10:55'! 124344pageImage: otherImage at: topLeft corner: corner 124345 "Produce a page-turning illusion that gradually reveals otherImage 124346 located at topLeft in this form. Corner specifies which corner, as 124347 1=topLeft, 2=topRight, 3=bottomRight, 4=bottomLeft." 124348 | bb maskForm resultForm delta maskLoc maskRect stepSize cornerSel smallRect | 124349 stepSize := 10. 124350 bb := otherImage boundingBox. 124351 resultForm := self copy: (topLeft extent: bb extent). 124352 maskForm := Form extent: ((otherImage width min: otherImage height) + stepSize) asPoint. 124353 124354 "maskLoc := starting loc rel to topLeft" 124355 otherImage width > otherImage height 124356 ifTrue: ["wide image; motion is horizontal." 124357 (corner between: 2 and: 3) not ifTrue: 124358 ["motion is to the right" 124359 delta := 1@0. 124360 maskLoc := bb topLeft - (corner = 1 124361 ifTrue: [maskForm width@0] 124362 ifFalse: [maskForm width@stepSize])] 124363 ifFalse: 124364 ["motion is to the left" 124365 delta := -1@0. 124366 maskLoc := bb topRight - (corner = 2 124367 ifTrue: [0@0] 124368 ifFalse: [0@stepSize])]] 124369 ifFalse: ["tall image; motion is vertical." 124370 corner <= 2 ifTrue: 124371 ["motion is downward" 124372 delta := 0@1. 124373 maskLoc := bb topLeft - (corner = 1 124374 ifTrue: [0@maskForm height] 124375 ifFalse: [stepSize@maskForm height])] 124376 ifFalse: 124377 ["motion is upward" 124378 delta := 0@-1. 124379 maskLoc := bb bottomLeft - (corner = 3 124380 ifTrue: [stepSize@0] 124381 ifFalse: [0@0])]]. 124382 124383 "Build a solid triangle in the mask form" 124384 (Pen newOnForm: maskForm) in: [:p | 124385 corner even "Draw 45-degree line" 124386 ifTrue: [p place: 0@0; turn: 135; go: maskForm width*3//2] 124387 ifFalse: [p place: 0@(maskForm height-1); turn: 45; go: maskForm width*3//2]]. 124388 maskForm smear: delta negated distance: maskForm width. 124389 "Copy the mask to full resolution for speed. Make it be the reversed 124390 so that it can be used for ORing in the page-corner color" 124391 maskForm := (Form extent: maskForm extent depth: otherImage depth) 124392 copyBits: maskForm boundingBox from: maskForm at: 0@0 124393 colorMap: (Bitmap with: 16rFFFFFFFF with: 0). 124394 124395 "Now move the triangle maskForm across the resultForm selecting the 124396 triangular part of otherImage to display, and across the resultForm, 124397 selecting the part of the original image to erase." 124398 cornerSel := #(topLeft topRight bottomRight bottomLeft) at: corner. 124399 1 to: (otherImage width + otherImage height // stepSize)+1 do: 124400 [:i | "Determine the affected square" 124401 maskRect := (maskLoc extent: maskForm extent) intersect: bb. 124402 ((maskLoc x*delta x) + (maskLoc y*delta y)) < 0 ifTrue: 124403 [smallRect := 0@0 extent: (maskRect width min: maskRect height) asPoint. 124404 maskRect := smallRect align: (smallRect perform: cornerSel) 124405 with: (maskRect perform: cornerSel)]. 124406 124407 "AND otherForm with triangle mask, and OR into result" 124408 resultForm copyBits: bb from: otherImage at: 0@0 124409 clippingBox: maskRect rule: Form over fillColor: nil. 124410 resultForm copyBits: maskForm boundingBox from: maskForm at: maskLoc 124411 clippingBox: maskRect rule: Form erase fillColor: nil. 124412 resultForm copyBits: maskForm boundingBox from: maskForm at: maskLoc 124413 clippingBox: maskRect rule: Form under fillColor: Color lightBrown. 124414 124415 "Now update Display in a single BLT." 124416 self copyBits: maskRect from: resultForm at: topLeft + maskRect topLeft 124417 clippingBox: self boundingBox rule: Form over fillColor: nil. 124418 Display forceDisplayUpdate. 124419 maskLoc := maskLoc + (delta*stepSize)] 124420" 1244211 to: 4 do: [:corner | Display pageImage: 124422 (Form fromDisplay: (10@10 extent: 200@300)) reverse 124423 at: 10@10 corner: corner] 124424" 124425! ! 124426 124427!Form methodsFor: 'transitions' stamp: 'ar 5/28/2000 12:12'! 124428pageWarp: otherImage at: topLeft forward: forward 124429 "Produce a page-turning illusion that gradually reveals otherImage 124430 located at topLeft in this form. 124431 forward == true means turn pages toward you, else away. [ignored for now]" 124432 | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | 124433 pageRect := otherImage boundingBox. 124434 oldPage := self copy: (pageRect translateBy: topLeft). 124435 (forward ifTrue: [oldPage] ifFalse: [otherImage]) 124436 border: pageRect 124437 widthRectangle: (Rectangle 124438 left: 0 124439 right: 2 124440 top: 1 124441 bottom: 1) 124442 rule: Form over 124443 fillColor: Color black. 124444 oldBottom := self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). 124445 nSteps := 8. 124446 buffer := Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. 124447 d := pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. 124448 1 to: nSteps-1 do: 124449 [:i | forward 124450 ifTrue: [buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. 124451 p := pageRect topRight + (d * i // nSteps)] 124452 ifFalse: [buffer copy: pageRect from: oldPage to: 0@0 rule: Form over. 124453 p := pageRect topRight + (d * (nSteps-i) // nSteps)]. 124454 buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. 124455 leafRect := pageRect topLeft corner: p x @ (pageRect bottom + p y). 124456 sourceQuad := Array with: pageRect topLeft 124457 with: pageRect bottomLeft + (0@p y) 124458 with: pageRect bottomRight 124459 with: pageRect topRight - (0@p y). 124460 warp := (WarpBlt current toForm: buffer) 124461 clipRect: leafRect; 124462 sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); 124463 combinationRule: Form paint. 124464 warp copyQuad: sourceQuad toRect: leafRect. 124465 self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. 124466 Display forceDisplayUpdate]. 124467 124468 buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. 124469 buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. 124470 self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. 124471 Display forceDisplayUpdate. 124472" 1244731 to: 4 do: [:corner | Display pageWarp: 124474 (Form fromDisplay: (10@10 extent: 200@300)) reverse 124475 at: 10@10 forward: false] 124476" 124477! ! 124478 124479!Form methodsFor: 'transitions' stamp: 'jm 5/21/1998 23:46'! 124480slideImage: otherImage at: topLeft delta: delta 124481 "Display slideImage: (Form fromDisplay: (40@40 extent: 300@300)) reverse 124482 at: 40@40 delta: 3@-4" 124483 | bb nSteps clipRect | 124484 bb := otherImage boundingBox. 124485 clipRect := topLeft extent: otherImage extent. 124486 nSteps := 1. 124487 delta x = 0 ifFalse: [nSteps := nSteps max: (bb width//delta x abs) + 1]. 124488 delta y = 0 ifFalse: [nSteps := nSteps max: (bb height//delta y abs) + 1]. 124489 1 to: nSteps do: 124490 [:i | self copyBits: bb from: otherImage 124491 at: delta*(i-nSteps) + topLeft 124492 clippingBox: clipRect rule: Form paint fillColor: nil. 124493 Display forceDisplayUpdate]! ! 124494 124495!Form methodsFor: 'transitions' stamp: 'jm 6/18/1998 12:57'! 124496wipeImage: otherImage at: topLeft clippingBox: clipBox rectForIndex: rectForIndexBlock 124497 124498 | i clipRect t rectOrList waitTime | 124499 i := 0. 124500 clipRect := topLeft extent: otherImage extent. 124501 clipBox ifNotNil: [clipRect := clipRect intersect: clipBox]. 124502 [rectOrList := rectForIndexBlock value: (i := i + 1). 124503 rectOrList == nil] 124504 whileFalse: [ 124505 t := Time millisecondClockValue. 124506 rectOrList asOrderedCollection do: [:r | 124507 self copyBits: r from: otherImage at: topLeft + r topLeft 124508 clippingBox: clipRect rule: Form over fillColor: nil]. 124509 Display forceDisplayUpdate. 124510 waitTime := 3 - (Time millisecondClockValue - t). 124511 waitTime > 0 ifTrue: 124512 ["(Delay forMilliseconds: waitTime) wait"]]. 124513! ! 124514 124515!Form methodsFor: 'transitions' stamp: 'jm 10/16/97 15:21'! 124516wipeImage: otherImage at: topLeft delta: delta 124517 "Display wipeImage: (Form fromDisplay: (40@40 extent: 300@300)) reverse 124518 at: 40@40 delta: 0@-2" 124519 124520 self wipeImage: otherImage at: topLeft delta: delta clippingBox: nil. 124521! ! 124522 124523!Form methodsFor: 'transitions' stamp: 'jm 10/16/97 15:17'! 124524wipeImage: otherImage at: topLeft delta: delta clippingBox: clipBox 124525 124526 | wipeRect bb nSteps | 124527 bb := otherImage boundingBox. 124528 wipeRect := delta x = 0 124529 ifTrue: 124530 [delta y = 0 ifTrue: [nSteps := 1. bb "allow 0@0"] ifFalse: [ 124531 nSteps := bb height//delta y abs + 1. "Vertical movement" 124532 delta y > 0 124533 ifTrue: [bb topLeft extent: bb width@delta y] 124534 ifFalse: [bb bottomLeft+delta extent: bb width@delta y negated]]] 124535 ifFalse: 124536 [nSteps := bb width//delta x abs + 1. "Horizontal movement" 124537 delta x > 0 124538 ifTrue: [bb topLeft extent: delta x@bb height] 124539 ifFalse: [bb topRight+delta extent: delta x negated@bb height]]. 124540 ^ self wipeImage: otherImage at: topLeft clippingBox: clipBox rectForIndex: 124541 [:i | i <= nSteps 124542 ifTrue: [wipeRect translateBy: (delta* (i-1))] 124543 ifFalse: [nil]]! ! 124544 124545!Form methodsFor: 'transitions' stamp: 'di 3/2/98 09:14'! 124546zoomInTo: otherImage at: topLeft 124547 "Display zoomInTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40" 124548 ^ self zoomIn: true orOutTo: otherImage at: topLeft 124549 vanishingPoint: otherImage extent//2+topLeft! ! 124550 124551!Form methodsFor: 'transitions' stamp: 'di 1/28/1999 09:20'! 124552zoomIn: goingIn orOutTo: otherImage at: topLeft vanishingPoint: vp 124553 "Display zoomInTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40. 124554 Display zoomOutTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40." 124555 | nSteps j bigR lilR minTime startTime lead | 124556 nSteps := 16. 124557 minTime := 500. "milliseconds" 124558 startTime := Time millisecondClockValue. 124559 ^ self wipeImage: otherImage at: topLeft clippingBox: nil rectForIndex: 124560 [:i | "i runs from 1 to nsteps" 124561 i > nSteps 124562 ifTrue: [nil "indicates all done"] 124563 ifFalse: 124564 ["If we are going too fast, delay for a bit" 124565 lead := startTime + (i-1*minTime//nSteps) - Time millisecondClockValue. 124566 lead > 10 ifTrue: [(Delay forMilliseconds: lead) wait]. 124567 124568 "Return an array with the difference rectangles for this step." 124569 j := goingIn ifTrue: [i] ifFalse: [nSteps+1-i]. 124570 bigR := vp - (vp*(j)//nSteps) corner: 124571 vp + (otherImage extent-vp*(j)//nSteps). 124572 lilR := vp - (vp*(j-1)//nSteps) corner: 124573 vp + (otherImage extent-vp*(j-1)//nSteps). 124574 bigR areasOutside: lilR]]! ! 124575 124576!Form methodsFor: 'transitions' stamp: 'di 3/2/98 09:15'! 124577zoomOutTo: otherImage at: topLeft 124578 "Display zoomOutTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40" 124579 ^ self zoomIn: false orOutTo: otherImage at: topLeft 124580 vanishingPoint: otherImage extent//2+topLeft! ! 124581 124582 124583!Form methodsFor: 'private' stamp: 'tk 3/13/2000 15:21'! 124584hackBits: bitThing 124585 "This method provides an initialization so that BitBlt may be used, eg, to 124586 copy ByteArrays and other non-pointer objects efficiently. 124587 The resulting form looks 4 wide, 8 deep, and bitThing-size-in-words high." 124588 width := 4. 124589 depth := 8. 124590 bitThing class isBits ifFalse: [self error: 'bitThing must be a non-pointer object']. 124591 bitThing class isBytes 124592 ifTrue: [height := bitThing basicSize // 4] 124593 ifFalse: [height := bitThing basicSize]. 124594 bits := bitThing! ! 124595 124596!Form methodsFor: 'private'! 124597initFromArray: array 124598 "Fill the bitmap from array. If the array is shorter, 124599 then cycle around in its contents until the bitmap is filled." 124600 | ax aSize array32 i j word16 | 124601 ax := 0. 124602 aSize := array size. 124603 aSize > bits size ifTrue: 124604 ["backward compatibility with old 16-bit bitmaps and their forms" 124605 array32 := Array new: height * (width + 31 // 32). 124606 i := j := 0. 124607 1 to: height do: 124608 [:y | 1 to: width+15//16 do: 124609 [:x16 | word16 := array at: (i := i + 1). 124610 x16 odd ifTrue: [array32 at: (j := j+1) put: (word16 bitShift: 16)] 124611 ifFalse: [array32 at: j put: ((array32 at: j) bitOr: word16)]]]. 124612 ^ self initFromArray: array32]. 124613 1 to: bits size do: 124614 [:index | 124615 (ax := ax + 1) > aSize ifTrue: [ax := 1]. 124616 bits at: index put: (array at: ax)]! ! 124617 124618!Form methodsFor: 'private' stamp: 'ar 12/19/2000 16:23'! 124619privateFloodFillValue: aColor 124620 "Private. Compute the pixel value in the receiver's depth but take into account implicit color conversions by BitBlt." 124621 | f1 f2 bb | 124622 f1 := Form extent: 1@1 depth: depth. 124623 f2 := Form extent: 1@1 depth: 32. 124624 bb := BitBlt toForm: f1. 124625 bb fillColor: aColor; 124626 destRect: (0@0 corner: 1@1); 124627 combinationRule: 3; 124628 copyBits. 124629 bb := BitBlt toForm: f2. 124630 bb sourceForm: f1; 124631 sourceOrigin: 0@0; 124632 destRect: (0@0 corner: 1@1); 124633 combinationRule: 3; 124634 copyBits. 124635 ^f2 pixelValueAt: 0@0.! ! 124636 124637!Form methodsFor: 'private' stamp: '6/9/97 16:10 di'! 124638setExtent: extent depth: bitsPerPixel 124639 "Create a virtual bit map with the given extent and bitsPerPixel." 124640 124641 width := extent x asInteger. 124642 width < 0 ifTrue: [width := 0]. 124643 height := extent y asInteger. 124644 height < 0 ifTrue: [height := 0]. 124645 depth := bitsPerPixel. 124646 bits := Bitmap new: self bitsSize! ! 124647 124648!Form methodsFor: 'private' stamp: 'ar 5/28/2000 15:49'! 124649setExtent: extent depth: bitsPerPixel bits: bitmap 124650 "Create a virtual bit map with the given extent and bitsPerPixel." 124651 124652 width := extent x asInteger. 124653 width < 0 ifTrue: [width := 0]. 124654 height := extent y asInteger. 124655 height < 0 ifTrue: [height := 0]. 124656 depth := bitsPerPixel. 124657 (bits isNil or:[self bitsSize = bitmap size]) ifFalse:[^self error:'Bad dimensions']. 124658 bits := bitmap! ! 124659 124660!Form methodsFor: 'private' stamp: 'ar 10/30/2000 23:22'! 124661setResourceBits: aForm 124662 "Private. Really. Used for setting the 'resource bits' when externalizing some form" 124663 bits := aForm.! ! 124664 124665"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 124666 124667Form class 124668 instanceVariableNames: ''! 124669 124670!Form class methodsFor: 'bmp file reading' stamp: 'ar 6/16/2002 17:41'! 124671fromBMPFile: aBinaryStream 124672 "Obsolete" 124673 ^self fromBinaryStream: aBinaryStream.! ! 124674 124675!Form class methodsFor: 'bmp file reading' stamp: 'ar 6/16/2002 17:41'! 124676fromBMPFileNamed: fileName 124677 "Obsolete" 124678 ^self fromFileNamed: fileName 124679! ! 124680 124681 124682!Form class methodsFor: 'examples'! 124683exampleBorder "Form exampleBorder" 124684 "This example demonstrates the border finding algorithm. Start 124685 by having the user sketch on the screen (end with option-click) and then select a rectangular 124686 area of the screen which includes all of the area to be filled. Finally, 124687 (with crosshair cursor), the user points at the interior of the region to be 124688 outlined, and the region begins with that place as its seed." 124689 | f r interiorPoint | 124690 Form exampleSketch. "sketch a little area with an enclosed region" 124691 r := Rectangle fromUser. 124692 f := Form fromDisplay: r. 124693 Cursor crossHair showWhile: 124694 [interiorPoint := Sensor waitButton - r origin]. 124695 Cursor execute showWhile: 124696 [f shapeBorder: Color blue width: 2 interiorPoint: interiorPoint 124697 sharpCorners: false internal: false]. 124698 f displayOn: Display at: r origin ! ! 124699 124700!Form class methodsFor: 'examples'! 124701exampleEdits 124702 "In Form category editing are messages edit and bitEdit that make it possible to 124703 create editors on instances of Form. 124704 124705 This is the general form editor: 124706 | f | 124707 f := Form fromUser. 124708 f edit. 124709 124710 This is the general bit editor: 124711 | f | 124712 f := Form fromUser. 124713 f bitEdit."! ! 124714 124715!Form class methodsFor: 'examples'! 124716exampleMagnify 124717 124718 | f m | 124719 f := Form fromUser. 124720 m := f magnify: f boundingBox by: 5 @ 5. 124721 m displayOn: Display at: Sensor waitButton 124722 124723 "Form exampleMagnify."! ! 124724 124725!Form class methodsFor: 'examples'! 124726exampleShrink 124727 124728 | f s | 124729 f := Form fromUser. 124730 s := f shrink: f boundingBox by: 2 @ 5. 124731 s displayOn: Display at: Sensor waitButton 124732 124733 "Form exampleShrink."! ! 124734 124735!Form class methodsFor: 'examples'! 124736exampleSketch 124737 "This is a simple drawing algorithm to get a sketch on the display screen. 124738 Draws whenever mouse button down. Ends with option-click." 124739 | aPen color | 124740 aPen := Pen new. 124741 color := 0. 124742 [Sensor yellowButtonPressed] 124743 whileFalse: 124744 [aPen place: Sensor cursorPoint; color: (color := color + 1). 124745 [Sensor redButtonPressed] 124746 whileTrue: [aPen goto: Sensor cursorPoint]]. 124747 Sensor waitNoButton. 124748 124749 "Form exampleSketch"! ! 124750 124751!Form class methodsFor: 'examples'! 124752exampleSpaceFill "Form exampleSpaceFill" 124753 "This example demonstrates the area filling algorithm. Starts by having 124754 the user sketch on the screen (ended by option-click) and then select a rectangular 124755 area of the screen which includes all of the area to be filled. Finally, 124756 (with crosshair cursor), the user points at the interior of some region to be 124757 filled, and the filling begins with that place as its seed." 124758 | f r interiorPoint | 124759 Form exampleSketch. "sketch a little area with an enclosed region" 124760 r := Rectangle fromUser. 124761 f := Form fromDisplay: r. 124762 Cursor crossHair showWhile: 124763 [interiorPoint := Sensor waitButton - r origin]. 124764 Cursor execute showWhile: 124765 [f shapeFill: Color gray interiorPoint: interiorPoint]. 124766 f displayOn: Display at: r origin ! ! 124767 124768!Form class methodsFor: 'examples'! 124769makeStar "See the similar example in OpaqueForm" 124770 | sampleForm pen | 124771 sampleForm := Form extent: 50@50. "Make a form" 124772 pen := Pen newOnForm: sampleForm. 124773 pen place: 24@50; turn: 18. "Draw a 5-pointed star on it." 124774 1 to: 5 do: [:i | pen go: 19; turn: 72; go: 19; turn: -144]. 124775 ^ sampleForm 124776" 124777Form makeStar follow: [Sensor cursorPoint] 124778 while: [Sensor noButtonPressed] 124779"! ! 124780 124781!Form class methodsFor: 'examples' stamp: 'tk 7/4/2000 12:08'! 124782toothpaste: diam "Display restoreAfter: [Form toothpaste: 30]" 124783 "Draws wormlike lines by laying down images of spheres. 124784 See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. 124785 Draw with mouse button down; terminate by option-click." 124786 | facade ball filter point queue port color q colors colr colr2 | 124787 colors := Display depth = 1 124788 ifTrue: [Array with: Color black] 124789 ifFalse: [Color red wheel: 12]. 124790 facade := Form extent: diam@diam offset: (diam//-2) asPoint. 124791 (Form dotOfSize: diam) displayOn: facade 124792 at: (diam//2) asPoint clippingBox: facade boundingBox 124793 rule: Form under fillColor: Color white. 124794 #(1 2 3) do: 124795 [:x | "simulate facade by circles of gray" 124796 (Form dotOfSize: x*diam//5) displayOn: facade 124797 at: (diam*2//5) asPoint clippingBox: facade boundingBox 124798 rule: Form under 124799 fillColor: (Color perform: 124800 (#(black gray lightGray) at: x)). 124801 "facade displayAt: 50*x@50"]. 124802 ball := Form dotOfSize: diam. 124803 color := 8. 124804 [ true ] whileTrue: 124805 [port := BitBlt current toForm: Display. 124806 "Expand 1-bit forms to any pixel depth" 124807 port colorMap: (Bitmap with: 0 with: 16rFFFFFFFF). 124808 queue := OrderedCollection new: 32. 124809 16 timesRepeat: [queue addLast: -20@-20]. 124810 Sensor waitButton. 124811 Sensor yellowButtonPressed ifTrue: [^ self]. 124812 filter := Sensor cursorPoint. 124813 colr := colors atWrap: (color := color + 5). "choose increment relatively prime to colors size" 124814 colr2 := colr alphaMixed: 0.3 with: Color white. 124815 [Sensor redButtonPressed or: [queue size > 0]] whileTrue: 124816 [filter := filter * 4 + Sensor cursorPoint // 5. 124817 point := Sensor redButtonPressed 124818 ifTrue: [filter] ifFalse: [-20@-20]. 124819 port copyForm: ball to: point rule: Form paint fillColor: colr. 124820 (q := queue removeFirst) == nil ifTrue: [^ self]. "exit" 124821 Display depth = 1 124822 ifTrue: [port copyForm: facade to: q rule: Form erase] 124823 ifFalse: [port copyForm: facade to: q rule: Form paint fillColor: colr2]. 124824 Sensor redButtonPressed ifTrue: [queue addLast: point]]]. 124825! ! 124826 124827!Form class methodsFor: 'examples'! 124828xorHack: size "Display restoreAfter: [Form xorHack: 256]" 124829 "Draw a smiley face or stick figure, and end with option-click. 124830 Thereafter image gets 'processed' as long as you have button down. 124831 If you stop at just the right time, you'll see you figure upside down, 124832 and at the end of a full cycle, you'll see it perfectly restored. 124833 Dude -- this works in color too!!" 124834 | rect form i bb | 124835 rect := 5@5 extent: size@size. 124836 Display fillWhite: rect; border: (rect expandBy: 2) width: 2. 124837 Display border: (rect topRight - (0@2) extent: rect extent*2 + 4) width: 2. 124838 Form exampleSketch. 124839 form := Form fromDisplay: rect. 124840 bb := form boundingBox. 124841 i := 0. 124842 [Sensor yellowButtonPressed] whileFalse: 124843 [[Sensor redButtonPressed] whileTrue: 124844 [i := i + 1. 124845 (Array with: 0@1 with: 0@-1 with: 1@0 with: -1@0) do: 124846 [:d | form copyBits: bb from: form at: d 124847 clippingBox: bb rule: Form reverse fillColor: nil]. 124848 form displayAt: rect topLeft. 124849 i+2\\size < 4 ifTrue: [(Delay forMilliseconds: 300) wait]]. 124850 (form magnify: form boundingBox by: 2@2) displayAt: rect topRight + (2@0). 124851 Sensor waitButton].! ! 124852 124853 124854!Form class methodsFor: 'file list services' stamp: 'nk 6/12/2004 12:56'! 124855fileReaderServicesForDirectory: aFileDirectory 124856 ^{ 124857 self serviceImageImportDirectory. 124858 self serviceImageImportDirectoryWithSubdirectories. 124859 }! ! 124860 124861!Form class methodsFor: 'file list services' stamp: 'nk 7/16/2003 18:01'! 124862fileReaderServicesForFile: fullName suffix: suffix 124863 124864 ^((ImageReadWriter allTypicalFileExtensions add: '*'; add: 'form'; yourself) 124865 includes: suffix) 124866 ifTrue: [ self services ] 124867 ifFalse: [#()] 124868! ! 124869 124870!Form class methodsFor: 'file list services' stamp: 'alain.plantec 5/30/2008 13:32'! 124871openImageInWindow: fullName 124872 "Handle five file formats: GIF, JPG, PNG, Form storeOn: (run coded), and 124873 BMP. Fail if file format is not recognized." 124874 | image myStream | 124875 myStream := (FileStream readOnlyFileNamed: fullName) binary. 124876 image := self fromBinaryStream: myStream. 124877 myStream close. 124878 Project current resourceManager addResource: image url: (FileDirectory urlForFileNamed: fullName) asString. 124879 (World drawingClass withForm: image) openInWorld! ! 124880 124881!Form class methodsFor: 'file list services' stamp: 'GabrielOmarCotelli 6/4/2009 20:42'! 124882serviceImageAsBackground 124883 "Answer a service for setting the desktop background from a given graphical file's contents" 124884 124885 ^ SimpleServiceEntry 124886 provider: self 124887 label: 'use graphic as background' 124888 selector: #setBackgroundFromImageFileNamed: 124889 description: 'use the graphic as the background for the desktop' 124890 buttonLabel: 'background'! ! 124891 124892!Form class methodsFor: 'file list services' stamp: 'nk 6/12/2004 13:16'! 124893serviceImageImportDirectory 124894 "Answer a service for reading a graphic into ImageImports" 124895 124896 ^(SimpleServiceEntry 124897 provider: self 124898 label: 'import all images from this directory' 124899 selector: #importImageDirectory: 124900 description: 'Load all graphics found in this directory, adding them to the ImageImports repository.' 124901 buttonLabel: 'import dir') 124902 argumentGetter: [ :fileList | fileList directory ]; 124903 yourself 124904! ! 124905 124906!Form class methodsFor: 'file list services' stamp: 'nk 6/12/2004 13:15'! 124907serviceImageImportDirectoryWithSubdirectories 124908 "Answer a service for reading all graphics from a directory and its subdirectories into ImageImports" 124909 124910 ^(SimpleServiceEntry 124911 provider: self 124912 label: 'import all images from here and subdirectories' 124913 selector: #importImageDirectoryWithSubdirectories: 124914 description: 'Load all graphics found in this directory and its subdirectories, adding them to the ImageImports repository.' 124915 buttonLabel: 'import subdirs') 124916 argumentGetter: [ :fileList | fileList directory ]; 124917 yourself 124918! ! 124919 124920!Form class methodsFor: 'file list services' stamp: 'sw 2/17/2002 01:39'! 124921serviceImageImports 124922 "Answer a service for reading a graphic into ImageImports" 124923 124924 ^ SimpleServiceEntry 124925 provider: self 124926 label: 'read graphic into ImageImports' 124927 selector: #importImage: 124928 description: 'Load a graphic, placing it in the ImageImports repository.' 124929 buttonLabel: 'import'! ! 124930 124931!Form class methodsFor: 'file list services' stamp: 'sw 2/17/2002 00:31'! 124932serviceOpenImageInWindow 124933 "Answer a service for opening a graphic in a window" 124934 124935 ^ SimpleServiceEntry 124936 provider: self 124937 label: 'open graphic in a window' 124938 selector: #openImageInWindow: 124939 description: 'open a graphic file in a window' 124940 buttonLabel: 'open'! ! 124941 124942!Form class methodsFor: 'file list services' stamp: 'sd 2/1/2002 21:43'! 124943services 124944 124945 ^ Array 124946 with: self serviceImageImports 124947 with: self serviceOpenImageInWindow 124948 with: self serviceImageAsBackground ! ! 124949 124950!Form class methodsFor: 'file list services' stamp: 'GabrielOmarCotelli 6/4/2009 20:42'! 124951setBackgroundFromImageFileNamed: aFileName 124952 124953 (self fromFileNamed: aFileName) setAsBackground! ! 124954 124955 124956!Form class methodsFor: 'filein/out' stamp: 'nk 6/12/2004 12:47'! 124957importImage: fullName 124958 "Import the given image file and store the resulting Form in the default Imports. 124959 The image is named with the short filename up to the first period, possibly with additions from the directory path to make it unique." 124960 124961 Imports default importImageFromFileNamed: fullName. 124962! ! 124963 124964!Form class methodsFor: 'filein/out' stamp: 'nk 6/12/2004 13:08'! 124965importImageDirectory: dir 124966 "Import the given image file and store the resulting Form in the default Imports. 124967 The image is named with the short filename up to the first period, possibly with additions from the directory path to make it unique." 124968 124969 Imports default importImageDirectory: dir 124970! ! 124971 124972!Form class methodsFor: 'filein/out' stamp: 'nk 6/12/2004 12:55'! 124973importImageDirectoryWithSubdirectories: dir 124974 "Import the given image file and store the resulting Form in the default Imports. 124975 The image is named with the short filename up to the first period, possibly with additions from the directory path to make it unique." 124976 124977 Imports default importImageDirectoryWithSubdirectories: dir 124978! ! 124979 124980 124981!Form class methodsFor: 'initialization' stamp: 'GabrielOmarCotelli 6/4/2009 20:34'! 124982unload 124983 124984 FileServices unregisterFileReader: self ! ! 124985 124986 124987!Form class methodsFor: 'initialize-release' stamp: 'GabrielOmarCotelli 6/4/2009 20:34'! 124988initialize 124989 124990 FileServices registerFileReader: self! ! 124991 124992 124993!Form class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:07'! 124994dotOfSize: diameter 124995 "Create a form which contains a round black dot." 124996 | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | 124997 radius := diameter//2. 124998 form := self extent: diameter@diameter offset: (0@0) - (radius@radius). 124999 bb := (BitBlt current toForm: form) 125000 sourceX: 0; sourceY: 0; 125001 combinationRule: Form over; 125002 fillColor: Color black. 125003 rect := form boundingBox. 125004 centerX := rect center x. 125005 centerY := rect center y. 125006 centerYBias := rect height odd ifTrue: [0] ifFalse: [1]. 125007 centerXBias := rect width odd ifTrue: [0] ifFalse: [1]. 125008 radiusSquared := (rect height asFloat / 2.0) squared - 0.01. 125009 xOverY := rect width asFloat / rect height asFloat. 125010 maxy := rect height - 1 // 2. 125011 125012 "First do the inner fill, and collect x values" 125013 0 to: maxy do: 125014 [:dy | 125015 dx := ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. 125016 bb destX: centerX - centerXBias - dx 125017 destY: centerY - centerYBias - dy 125018 width: dx + dx + centerXBias + 1 125019 height: 1; 125020 copyBits. 125021 bb destY: centerY + dy; 125022 copyBits]. 125023 ^ form 125024" 125025Time millisecondsToRun: 125026 [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] 125027"! ! 125028 125029!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:27'! 125030extent: extentPoint 125031 "Answer an instance of me with a blank bitmap of depth 1." 125032 125033 ^ self extent: extentPoint depth: 1 125034! ! 125035 125036!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:36'! 125037extent: extentPoint depth: bitsPerPixel 125038 "Answer an instance of me with blank bitmap of the given dimensions and depth." 125039 125040 ^ self basicNew setExtent: extentPoint depth: bitsPerPixel 125041! ! 125042 125043!Form class methodsFor: 'instance creation' stamp: 'ar 10/9/1998 23:44'! 125044extent: extentPoint depth: bitsPerPixel bits: aBitmap 125045 "Answer an instance of me with blank bitmap of the given dimensions and depth." 125046 125047 ^ self basicNew setExtent: extentPoint depth: bitsPerPixel bits: aBitmap! ! 125048 125049!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:35'! 125050extent: extentPoint depth: bitsPerPixel fromArray: anArray offset: offsetPoint 125051 "Answer an instance of me with a pixmap of the given depth initialized from anArray." 125052 125053 ^ (self extent: extentPoint depth: bitsPerPixel) 125054 offset: offsetPoint; 125055 initFromArray: anArray 125056! ! 125057 125058!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:33'! 125059extent: extentPoint fromArray: anArray offset: offsetPoint 125060 "Answer an instance of me of depth 1 with bitmap initialized from anArray." 125061 125062 ^ (self extent: extentPoint depth: 1) 125063 offset: offsetPoint; 125064 initFromArray: anArray 125065! ! 125066 125067!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:28'! 125068extent: extentPoint fromStipple: fourNibbles 125069 "Answer an instance of me with bitmap initialized from 125070 a repeating 4x4 bit stipple encoded in a 16-bit constant." 125071 | nibble | 125072 ^ (self extent: extentPoint depth: 1) 125073 initFromArray: ((1 to: 4) collect: 125074 [:i | nibble := (fourNibbles bitShift: -4*(4-i)) bitAnd: 16rF. 125075 16r11111111 * nibble]) "fill 32 bits with each 4-bit nibble" 125076! ! 125077 125078!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:26'! 125079extent: extentPoint offset: offsetPoint 125080 "Answer an instance of me with a blank bitmap of depth 1." 125081 125082 ^ (self extent: extentPoint depth: 1) offset: offsetPoint 125083! ! 125084 125085!Form class methodsFor: 'instance creation' stamp: 'nk 7/7/2003 18:19'! 125086fromBinaryStream: aBinaryStream 125087 "Read a Form or ColorForm from given file, using the first byte of the file to guess its format. Currently handles: GIF, uncompressed BMP, and both old and new DisplayObject writeOn: formats, JPEG, and PCX. Return nil if the file could not be read or was of an unrecognized format." 125088 125089 | firstByte | 125090 aBinaryStream binary. 125091 firstByte := aBinaryStream next. 125092 firstByte = 1 ifTrue: [ 125093 "old Squeakform format" 125094 ^ self new readFromOldFormat: aBinaryStream]. 125095 firstByte = 2 ifTrue: [ 125096 "new Squeak form format" 125097 ^ self new readFrom: aBinaryStream]. 125098 125099 "Try for JPG, GIF, or PCX..." 125100 "Note: The following call closes the stream." 125101 ^ ImageReadWriter formFromStream: aBinaryStream 125102! ! 125103 125104!Form class methodsFor: 'instance creation'! 125105fromDisplay: aRectangle 125106 "Answer an instance of me with bitmap initialized from the area of the 125107 display screen defined by aRectangle." 125108 125109 ^ (self extent: aRectangle extent depth: Display depth) 125110 fromDisplay: aRectangle! ! 125111 125112!Form class methodsFor: 'instance creation'! 125113fromDisplay: aRectangle using: oldForm 125114 "Like fromDisplay: only if oldForm is the right size, copy into it and answer it instead." 125115 125116 ((oldForm ~~ nil) and: [oldForm extent = aRectangle extent]) 125117 ifTrue: 125118 [oldForm fromDisplay: aRectangle. 125119 ^ oldForm] 125120 ifFalse: 125121 [^ self fromDisplay: aRectangle]! ! 125122 125123!Form class methodsFor: 'instance creation' stamp: 'alain.plantec 5/30/2008 13:31'! 125124fromFileNamed: fileName 125125 "Read a Form or ColorForm from the given file." 125126 | file form | 125127 file := (FileStream readOnlyFileNamed: fileName) binary. 125128 form := self fromBinaryStream: file. 125129 Project current resourceManager addResource: form url: (FileDirectory urlForFileNamed: file name) asString. 125130 file close. 125131 ^ form! ! 125132 125133!Form class methodsFor: 'instance creation'! 125134fromUser 125135 "Answer an instance of me with bitmap initialized from the area of the 125136 display screen designated by the user. The grid for selecting an area is 125137 1@1." 125138 125139 ^self fromUser: 1 @ 1! ! 125140 125141!Form class methodsFor: 'instance creation' stamp: 'ar 3/1/2006 22:50'! 125142fromUser: gridPoint 125143 "Answer an instance of me with bitmap initialized from the area of the 125144 display screen designated by the user. The grid for selecting an area is 125145 aPoint. Ensures that the returned form has positive extent." 125146 | rect | 125147 rect := Rectangle fromUser: gridPoint. 125148 ^ self fromDisplay: (rect origin extent: (rect extent max: gridPoint))! ! 125149 125150!Form class methodsFor: 'instance creation' stamp: 'jm 12/5/97 19:32'! 125151fromUserWithExtent: anExtent 125152 "Answer an instance of me with bitmap initialized from the area of the 125153 display screen whose origin is designated by the user and whose size is anExtent" 125154 125155 ^ self fromDisplay: (Rectangle originFromUser: anExtent) 125156 125157"(Form fromUserWithExtent: 50@50) displayAt: 10@10"! ! 125158 125159 125160!Form class methodsFor: 'mode constants'! 125161and 125162 "Answer the integer denoting the logical 'and' combination rule." 125163 125164 ^1! ! 125165 125166!Form class methodsFor: 'mode constants'! 125167blend 125168 "Answer the integer denoting BitBlt's alpha blend combination rule." 125169 ^24! ! 125170 125171!Form class methodsFor: 'mode constants' stamp: 'di 12/31/1998 14:02'! 125172blendAlpha 125173 "Answer the integer denoting BitBlt's blend-with-constant-alpha rule." 125174 125175 ^ 30! ! 125176 125177!Form class methodsFor: 'mode constants'! 125178erase 125179 "Answer the integer denoting mode erase." 125180 125181 ^4! ! 125182 125183!Form class methodsFor: 'mode constants'! 125184erase1bitShape 125185 "Answer the integer denoting mode erase." 125186 125187 ^ 26! ! 125188 125189!Form class methodsFor: 'mode constants'! 125190oldErase1bitShape 125191 "Answer the integer denoting mode erase." 125192 125193 ^ 17! ! 125194 125195!Form class methodsFor: 'mode constants'! 125196oldPaint 125197 "Answer the integer denoting the 'paint' combination rule." 125198 125199 ^16! ! 125200 125201!Form class methodsFor: 'mode constants'! 125202over 125203 "Answer the integer denoting mode over." 125204 125205 ^3! ! 125206 125207!Form class methodsFor: 'mode constants'! 125208paint 125209 "Answer the integer denoting the 'paint' combination rule." 125210 125211 ^25! ! 125212 125213!Form class methodsFor: 'mode constants' stamp: 'di 12/31/1998 14:02'! 125214paintAlpha 125215 "Answer the integer denoting BitBlt's paint-with-constant-alpha rule." 125216 125217 ^ 31! ! 125218 125219!Form class methodsFor: 'mode constants'! 125220reverse 125221 "Answer the integer denoting mode reverse." 125222 125223 ^6! ! 125224 125225!Form class methodsFor: 'mode constants'! 125226under 125227 "Answer the integer denoting mode under." 125228 125229 ^7! ! 125230 125231 125232!Form class methodsFor: 'shut down' stamp: 'ar 5/28/2000 23:35'! 125233shutDown "Form shutDown" 125234 "Compress all instances in the system. Will decompress on demand..." 125235 Form allInstancesDo: [:f | f hibernate]. 125236 ColorForm allInstancesDo: [:f | f hibernate].! ! 125237 125238 125239!Form class methodsFor: 'utils' stamp: 'stephane.ducasse 7/10/2009 16:15'! 125240showFormsAcrossTopOfScreen: aFormList 125241 "Display the given array of forms across the top of the screen, wrapping to subsequent lines if needed. Useful for example for looking at sets of rotations and animations. 6/10/96 sw" 125242 "self showFormsAcrossTopOfScreen: {Cursor currentCursor asCursorForm}" 125243 125244 | position maxHeight screenBox ceiling | 125245 125246 position := 20. 125247 maxHeight := 0. 125248 ceiling := 0. 125249 screenBox := Display boundingBox. 125250 aFormList do: 125251 [:elem | elem displayAt: (position @ ceiling). 125252 maxHeight := maxHeight max: elem boundingBox height. 125253 position := position + elem boundingBox width + 5. 125254 position > (screenBox right - 100) ifTrue: 125255 [position := 20. 125256 ceiling := ceiling + maxHeight + 10. 125257 maxHeight := 0]]! ! 125258 125259!Form class methodsFor: 'utils' stamp: 'stephane.ducasse 7/10/2009 16:25'! 125260showFormsDictAcrossTopOfScreen: formDict 125261 "Display the given Dictionary of forms across the top of the screen, wrapping to subsequent lines if needed. Beneath each, put the name of the associated key." 125262 125263 " 125264 | dict methods | 125265 dict := Dictionary new. 125266 methods := MenuIcons class selectors select: [:each | '*Icon' match: each asString]. 125267 methods do: [:each | dict at: each put: (MenuIcons perform: each)]. 125268 self showFormsDictAcrossTopOfScreen: dict" 125269 125270 | position maxHeight screenBox ceiling elem box h labelWidth keyString | 125271 125272 position := 20. 125273 maxHeight := 0. 125274 ceiling := 0. 125275 screenBox := Display boundingBox. 125276 formDict associationsDo: 125277 [:assoc | (elem := assoc value) displayAt: (position @ ceiling). 125278 box := elem boundingBox. 125279 h := box height. 125280 keyString := (assoc key isString) ifTrue: [assoc key] ifFalse: [assoc key printString]. 125281 keyString displayAt: (position @ (ceiling + h)). 125282 labelWidth := TextStyle default defaultFont widthOfString: keyString. 125283 maxHeight := maxHeight max: h. 125284 position := position + (box width max: labelWidth) + 5. 125285 position > (screenBox right - 100) ifTrue: 125286 [position := 20. 125287 ceiling := ceiling + maxHeight + 15. 125288 maxHeight := 0]]! ! 125289Canvas subclass: #FormCanvas 125290 instanceVariableNames: 'origin clipRect form port shadowColor' 125291 classVariableNames: '' 125292 poolDictionaries: '' 125293 category: 'Morphic-Support'! 125294!FormCanvas commentStamp: '<historical>' prior: 0! 125295Note that when shadowDrawing is true, shadowStipple may be either a color, for a solid shadow of the given color, or it may be a stipple used to simulate gray shading when the display cannot support alpha blending.! 125296 125297 125298!FormCanvas methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/21/2008 16:37'! 125299fillRectangle: aRectangle basicFillStyle: aFillStyle 125300 "Fill the given rectangle with the given, non-composite, fill style." 125301 125302 | pattern | 125303 self shadowColor ifNotNil: 125304 [^self fillRectangle: aRectangle color: aFillStyle asColor]. 125305 125306 (aFillStyle isKindOf: InfiniteForm) ifTrue: [ 125307 ^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle 125308 ]. 125309 125310 (aFillStyle isSolidFill) 125311 ifTrue:[^self fillRectangle: aRectangle color: aFillStyle asColor]. 125312 "We have a very special case for filling with infinite forms" 125313 (aFillStyle isBitmapFill and:[aFillStyle origin = (0@0)]) ifTrue:[ 125314 pattern := aFillStyle form. 125315 (aFillStyle direction = (pattern width @ 0) 125316 and:[aFillStyle normal = (0@pattern height)]) ifTrue:[ 125317 "Can use an InfiniteForm" 125318 ^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)]. 125319 ]. 125320 "Use a BalloonCanvas instead" 125321 self balloonFillRectangle: aRectangle fillStyle: aFillStyle.! ! 125322 125323 125324!FormCanvas methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/16/2009 13:36'! 125325balloonFillRectangle: aRectangle fillStyle: aFillStyle 125326 125327 self asBalloonCanvas fillRectangle: aRectangle basicFillStyle: aFillStyle! ! 125328 125329!FormCanvas methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/21/2008 16:38'! 125330fillRectangle: aRectangle fillStyle: aFillStyle 125331 "Fill the given rectangle. Double-dispatched via the fill style." 125332 125333 aFillStyle fillRectangle: aRectangle on: self! ! 125334 125335!FormCanvas methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/7/2008 14:02'! 125336infiniteFillRectangle: aRectangle fillStyle: aFillStyle 125337 125338 | additionalOffset rInPortTerms clippedPort targetTopLeft clipOffset ex | 125339 125340 "this is a bit of a kludge to get the form to be aligned where I *think* it should be. 125341 something better is needed, but not now" 125342 125343 additionalOffset := 0@0. 125344 ex := aFillStyle form extent. 125345 rInPortTerms := (aRectangle intersect: aFillStyle boundingBox) translateBy: origin. 125346 clippedPort := port clippedBy: rInPortTerms. 125347 targetTopLeft := clippedPort clipRect topLeft truncateTo: ex. 125348 clipOffset := rInPortTerms topLeft - targetTopLeft. 125349 additionalOffset := (clipOffset \\ ex) - ex. 125350 ^aFillStyle 125351 displayOnPort: clippedPort 125352 offsetBy: additionalOffset 125353! ! 125354 125355 125356!FormCanvas methodsFor: 'accessing' stamp: 'ar 5/28/2000 17:11'! 125357allocateForm: extentPoint 125358 "Allocate a new form which is similar to the receiver" 125359 ^form allocateForm: extentPoint! ! 125360 125361!FormCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:06'! 125362clipRect 125363 "Return the currently active clipping rectangle" 125364 ^ clipRect translateBy: origin negated! ! 125365 125366!FormCanvas methodsFor: 'accessing' stamp: 'ar 12/31/2001 03:26'! 125367contentsOfArea: aRectangle into: aForm 125368 | bb | 125369 self flush. 125370 bb := BitBlt toForm: aForm. 125371 bb sourceForm: form; combinationRule: Form over; 125372 sourceX: (aRectangle left + origin x); sourceY: (aRectangle top + origin y); 125373 width: aRectangle width; height: aRectangle height; 125374 copyBits. 125375 ^aForm! ! 125376 125377!FormCanvas methodsFor: 'accessing'! 125378depth 125379 125380 ^ form depth 125381! ! 125382 125383!FormCanvas methodsFor: 'accessing'! 125384extent 125385 125386 ^ form extent! ! 125387 125388!FormCanvas methodsFor: 'accessing'! 125389form 125390 125391 ^ form! ! 125392 125393!FormCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:10'! 125394origin 125395 "Return the current origin for drawing operations" 125396 ^ origin! ! 125397 125398!FormCanvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 00:26'! 125399shadowColor 125400 ^shadowColor! ! 125401 125402!FormCanvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 00:26'! 125403shadowColor: aColor 125404 shadowColor := aColor! ! 125405 125406 125407!FormCanvas methodsFor: 'converting' stamp: 'ar 2/17/2000 00:17'! 125408asShadowDrawingCanvas 125409 "Note: This is sort of an optimization here since since the logic is all there" 125410 ^self copy shadowColor: (Color black alpha: 0.5)! ! 125411 125412!FormCanvas methodsFor: 'converting' stamp: 'ar 2/17/2000 00:16'! 125413asShadowDrawingCanvas: aColor 125414 "Note: This is sort of an optimization here since since the logic is all there" 125415 ^self copy shadowColor: aColor! ! 125416 125417 125418!FormCanvas methodsFor: 'copying' stamp: 'jm 8/2/97 14:00'! 125419copy 125420 "Make a copy the receiver on the same underlying Form but with its own grafPort." 125421 125422 ^ self clone resetGrafPort 125423! ! 125424 125425!FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:51'! 125426copyClipRect: aRectangle 125427 ^ self copyOrigin: origin clipRect: (aRectangle translateBy: origin) 125428! ! 125429 125430!FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'! 125431copyOffset: aPoint 125432 ^ self copyOrigin: origin + aPoint clipRect: clipRect! ! 125433 125434!FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'! 125435copyOffset: aPoint clipRect: sourceClip 125436 "Make a copy of me offset by aPoint, and further clipped 125437 by sourceClip, a rectangle in the un-offset coordinates" 125438 ^ self copyOrigin: aPoint + origin 125439 clipRect: ((sourceClip translateBy: origin) intersect: clipRect)! ! 125440 125441!FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'! 125442copyOrigin: aPoint clipRect: aRectangle 125443 "Return a copy of this canvas with the given origin. The clipping rectangle of this canvas is the intersection of the given rectangle and the receiver's current clipping rectangle. This allows the clipping rectangles of nested clipping morphs to be composed." 125444 ^ self copy 125445 setOrigin: aPoint 125446 clipRect: (clipRect intersect: aRectangle)! ! 125447 125448 125449!FormCanvas methodsFor: 'drawing' stamp: 'ar 5/14/2000 15:50'! 125450fillColor: c 125451 "Note: This always fills, even if the color is transparent." 125452 self setClearColor: c. 125453 port fillRect: form boundingBox offset: origin.! ! 125454 125455!FormCanvas methodsFor: 'drawing' stamp: 'ar 5/14/2001 23:34'! 125456line: pt1 to: pt2 brushForm: brush 125457 | offset | 125458 offset := origin. 125459 self setPaintColor: Color black. 125460 port sourceForm: brush; fillColor: nil; 125461 sourceRect: brush boundingBox; 125462 colorMap: (brush colormapIfNeededFor: form); 125463 drawFrom: (pt1 + offset) to: (pt2 + offset)! ! 125464 125465!FormCanvas methodsFor: 'drawing' stamp: 'ar 2/16/2000 22:07'! 125466line: pt1 to: pt2 width: w color: c 125467 | offset | 125468 offset := origin - (w // 2) asPoint. 125469 self setFillColor: c. 125470 port width: w; height: w; 125471 drawFrom: (pt1 + offset) to: (pt2 + offset)! ! 125472 125473!FormCanvas methodsFor: 'drawing' stamp: 'yo 1/23/2003 17:50'! 125474paragraph3: para bounds: bounds color: c 125475 125476 | scanner | 125477 self setPaintColor: c. 125478 scanner := (port clippedBy: (bounds translateBy: origin)) displayScannerForMulti: para 125479 foreground: (self shadowColor ifNil:[c]) background: Color transparent 125480 ignoreColorChanges: self shadowColor notNil. 125481 para displayOnTest: (self copyClipRect: bounds) using: scanner at: origin+ bounds topLeft. 125482! ! 125483 125484!FormCanvas methodsFor: 'drawing' stamp: 'di 9/12/2001 21:38'! 125485paragraph: para bounds: bounds color: c 125486 125487 | scanner | 125488 self setPaintColor: c. 125489 scanner := (port clippedBy: (bounds translateBy: origin)) displayScannerFor: para 125490 foreground: (self shadowColor ifNil:[c]) background: Color transparent 125491 ignoreColorChanges: self shadowColor notNil. 125492 para displayOn: (self copyClipRect: bounds) using: scanner at: origin+ bounds topLeft. 125493! ! 125494 125495!FormCanvas methodsFor: 'drawing'! 125496point: pt color: c 125497 125498 form colorAt: (pt + origin) put: c.! ! 125499 125500!FormCanvas methodsFor: 'drawing' stamp: 'ar 9/9/2000 22:18'! 125501render: anObject 125502 "Do some 3D operations with the object if possible" 125503 ^self asBalloonCanvas render: anObject! ! 125504 125505 125506!FormCanvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:58'! 125507roundCornersOf: aMorph in: bounds during: aBlock 125508 aMorph wantsRoundedCorners ifFalse:[^aBlock value]. 125509 (self seesNothingOutside: (CornerRounder rectWithinCornersOf: bounds)) 125510 ifTrue: ["Don't bother with corner logic if the region is inside them" 125511 ^ aBlock value]. 125512 CornerRounder roundCornersOf: aMorph on: self in: bounds 125513 displayBlock: aBlock 125514 borderWidth: aMorph borderWidthForRounding 125515 corners: aMorph roundedCorners! ! 125516 125517 125518!FormCanvas methodsFor: 'drawing-images' stamp: 'tpr 9/15/2004 10:27'! 125519stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor 125520 "Flood this canvas with aColor wherever stencilForm has non-zero pixels" 125521 self setPaintColor: aColor. 125522 port colorMap: stencilForm maskingMap. 125523 port stencil: stencilForm 125524 at: aPoint + origin 125525 sourceRect: sourceRect.! ! 125526 125527!FormCanvas methodsFor: 'drawing-images' stamp: 'ar 12/30/2001 16:36'! 125528warpImage: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize 125529 "Warp the given using the appropriate transform and offset." 125530 | tfm | 125531 tfm := (MatrixTransform2x3 withOffset: origin) composedWithLocal: aTransform. 125532 ^self privateWarp: aForm transform: tfm at: extraOffset sourceRect: sourceRect cellSize: cellSize! ! 125533 125534 125535!FormCanvas methodsFor: 'drawing-ovals' stamp: 'RAA 11/6/2000 15:21'! 125536balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc 125537 125538 self asBalloonCanvas 125539 fillOval: aRectangle 125540 fillStyle: aFillStyle 125541 borderWidth: bw 125542 borderColor: bc! ! 125543 125544!FormCanvas methodsFor: 'drawing-ovals' stamp: 'di 5/25/2001 01:40'! 125545fillOval: r color: fillColor borderWidth: borderWidth borderColor: borderColor 125546 | rect | 125547 "draw the border of the oval" 125548 rect := (r translateBy: origin) truncated. 125549 (borderWidth = 0 or: [borderColor isTransparent]) ifFalse:[ 125550 self setFillColor: borderColor. 125551 (r area > 10000 or: [fillColor isTranslucent]) 125552 ifTrue: [port frameOval: rect borderWidth: borderWidth] 125553 ifFalse: [port fillOval: rect]]. "faster this way" 125554 "fill the inside" 125555 fillColor isTransparent ifFalse: 125556 [self setFillColor: fillColor. 125557 port fillOval: (rect insetBy: borderWidth)]. 125558! ! 125559 125560!FormCanvas methodsFor: 'drawing-ovals' stamp: 'RAA 11/6/2000 16:42'! 125561fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc 125562 "Fill the given oval." 125563 125564 self flag: #bob. "this and its siblings could be moved up to Canvas with the 125565 right #balloonFillOval:..." 125566 125567 self shadowColor ifNotNil: 125568 [^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc]. 125569 (aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[ 125570 self flag: #fixThis. 125571 ^self fillOval: aRectangle color: aFillStyle borderWidth: bw borderColor: bc]. 125572 (aFillStyle isSolidFill) ifTrue:[ 125573 ^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc]. 125574 "Use a BalloonCanvas instead" 125575 self balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc! ! 125576 125577 125578!FormCanvas methodsFor: 'drawing-polygons' stamp: 'ar 6/18/1999 08:57'! 125579drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc 125580 "Generalize for the BalloonCanvas" 125581 ^self drawPolygon: vertices fillStyle: aColor borderWidth: bw borderColor: bc! ! 125582 125583!FormCanvas methodsFor: 'drawing-polygons' stamp: 'ar 12/6/2000 14:59'! 125584drawPolygon: vertices fillStyle: aFillStyle borderWidth: bw borderColor: bc 125585 "Use a BalloonCanvas" 125586 self asBalloonCanvas 125587 drawPolygon: vertices asArray 125588 fillStyle: (self shadowColor ifNil:[aFillStyle]) 125589 borderWidth: bw 125590 borderColor: bc! ! 125591 125592 125593!FormCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 5/14/2000 15:50'! 125594frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor 125595 | rect | 125596 rect := r translateBy: origin. 125597 "draw the border of the rectangle" 125598 borderColor isTransparent ifFalse:[ 125599 self setFillColor: borderColor. 125600 (r area > 10000 or: [fillColor isTranslucent]) ifTrue: [ 125601 port frameRect: rect borderWidth: borderWidth. 125602 ] ifFalse: ["for small rectangles, it's faster to fill the entire outer rectangle 125603 than to compute and fill the border rects" 125604 port fillRect: rect offset: origin]]. 125605 125606 "fill the inside" 125607 fillColor isTransparent ifFalse: 125608 [self setFillColor: fillColor. 125609 port fillRect: (rect insetBy: borderWidth) offset: origin].! ! 125610 125611!FormCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 2/16/2000 22:07'! 125612frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor 125613 125614 | w h rect | 125615 "First use quick code for top and left borders and fill" 125616 self frameAndFillRectangle: r 125617 fillColor: fillColor 125618 borderWidth: borderWidth 125619 borderColor: topLeftColor. 125620 125621 "Now use slow code for bevelled bottom and right borders" 125622 bottomRightColor isTransparent ifFalse: [ 125623 borderWidth isNumber 125624 ifTrue: [w := h := borderWidth] 125625 ifFalse: [w := borderWidth x. h := borderWidth y]. 125626 rect := r translateBy: origin. 125627 self setFillColor: bottomRightColor. 125628 port 125629 frameRectRight: rect width: w; 125630 frameRectBottom: rect height: h]. 125631! ! 125632 125633 125634!FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:02'! 125635clipBy: aRectangle during: aBlock 125636 "Set a clipping rectangle active only during the execution of aBlock. 125637 Note: In the future we may want to have more general clip shapes - not just rectangles" 125638 ^aBlock value: (self copyClipRect: aRectangle)! ! 125639 125640!FormCanvas methodsFor: 'drawing-support' stamp: 'ar 10/18/2004 00:05'! 125641transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize 125642 125643 "Note: This method has been originally copied from TransformationMorph." 125644 | innerRect patchRect sourceQuad warp start subCanvas | 125645 (aDisplayTransform isPureTranslation) ifTrue:[ 125646 ^aBlock value: (self copyOffset: aDisplayTransform offset negated truncated 125647 clipRect: aClipRect) 125648 ]. 125649 "Prepare an appropriate warp from patch to innerRect" 125650 innerRect := aClipRect. 125651 patchRect := (aDisplayTransform globalBoundsToLocal: innerRect) truncated. 125652 sourceQuad := (aDisplayTransform sourceQuadFor: innerRect) 125653 collect: [:p | p - patchRect topLeft]. 125654 warp := self warpFrom: sourceQuad toRect: innerRect. 125655 warp cellSize: cellSize. 125656 125657 "Render the submorphs visible in the clipping rectangle, as patchForm" 125658 start := (self depth = 1 and: [self isShadowDrawing not]) 125659 "If this is true B&W, then we need a first pass for erasure." 125660 ifTrue: [1] ifFalse: [2]. 125661 start to: 2 do: 125662 [:i | "If i=1 we first make a shadow and erase it for opaque whites in B&W" 125663 subCanvas := self class extent: patchRect extent depth: self depth. 125664 i=1 ifTrue: [subCanvas shadowColor: Color black. 125665 warp combinationRule: Form erase] 125666 ifFalse: [self isShadowDrawing ifTrue: 125667 [subCanvas shadowColor: self shadowColor]. 125668 warp combinationRule: Form paint]. 125669 subCanvas translateBy: patchRect topLeft negated 125670 during:[:offsetCanvas| aBlock value: offsetCanvas]. 125671 warp sourceForm: subCanvas form; warpBits. 125672 warp sourceForm: nil. subCanvas := nil "release space for next loop"] 125673! ! 125674 125675!FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:02'! 125676translateBy: delta during: aBlock 125677 "Set a translation only during the execution of aBlock." 125678 ^aBlock value: (self copyOffset: delta)! ! 125679 125680!FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 02:55'! 125681translateTo: newOrigin clippingTo: aRectangle during: aBlock 125682 "Set a new origin and clipping rectangle only during the execution of aBlock." 125683 aBlock value: (self copyOrigin: newOrigin clipRect: aRectangle)! ! 125684 125685 125686!FormCanvas methodsFor: 'drawing-text' stamp: 'ar 2/5/2002 19:03'! 125687drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: c 125688 | font | 125689 port colorMap: nil. 125690 font := fontOrNil ifNil: [TextStyle defaultFont]. 125691 port combinationRule: Form paint. 125692 font installOn: port 125693 foregroundColor: (self shadowColor ifNil:[c]) 125694 backgroundColor: Color transparent. 125695 font displayString: aString on: port 125696 from: firstIndex to: lastIndex at: (origin + aPoint) kern: 0.! ! 125697 125698!FormCanvas methodsFor: 'drawing-text' stamp: 'ar 2/5/2002 19:03'! 125699drawString: aString from: firstIndex to: lastIndex in: bounds font: fontOrNil color: c 125700 | font portRect | 125701 port colorMap: nil. 125702 portRect := port clipRect. 125703 port clipByX1: bounds left + origin x 125704 y1: bounds top + origin y 125705 x2: bounds right + origin x 125706 y2: bounds bottom + origin y. 125707 font := fontOrNil ifNil: [TextStyle defaultFont]. 125708 port combinationRule: Form paint. 125709 font installOn: port 125710 foregroundColor: (self shadowColor ifNil:[c]) 125711 backgroundColor: Color transparent. 125712 font displayString: aString asString on: port 125713 from: firstIndex to: lastIndex at: (bounds topLeft + origin) kern: 0. 125714 port clipRect: portRect.! ! 125715 125716!FormCanvas methodsFor: 'drawing-text' stamp: 'tween 3/10/2009 08:05'! 125717drawString: aString from: firstIndex to: lastIndex in: bounds font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc 125718 | font portRect endPoint | 125719 port colorMap: nil. 125720 portRect := port clipRect. 125721 port clipByX1: bounds left + origin x 125722 y1: bounds top + origin y 125723 x2: bounds right + origin x 125724 y2: bounds bottom + origin y. 125725 font := fontOrNil ifNil: [TextStyle defaultFont]. 125726 port combinationRule: Form paint. 125727 font installOn: port 125728 foregroundColor: (self shadowColor ifNil:[c]) 125729 backgroundColor: Color transparent. 125730 endPoint := font displayString: aString asString on: port 125731 from: firstIndex to: lastIndex at: (bounds topLeft + origin) kern: 0. 125732 underline ifTrue:[ 125733 font installOn: port 125734 foregroundColor: (self shadowColor ifNil:[uc]) 125735 backgroundColor: Color transparent. 125736 font displayUnderlineOn: port from: (bounds topLeft + origin + (0@font ascent)) to: endPoint. 125737 ]. 125738 port clipRect: portRect.! ! 125739 125740 125741!FormCanvas methodsFor: 'initialization' stamp: 'ar 5/27/2000 21:51'! 125742finish 125743 "If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect." 125744 form finish! ! 125745 125746!FormCanvas methodsFor: 'initialization' stamp: 'ar 2/17/2000 00:21'! 125747reset 125748 125749 origin := 0@0. "origin of the top-left corner of this cavas" 125750 clipRect := (0@0 corner: 10000@10000). "default clipping rectangle" 125751 self shadowColor: nil.! ! 125752 125753 125754!FormCanvas methodsFor: 'other' stamp: 'ar 11/11/1998 22:57'! 125755asBalloonCanvas 125756 ^(BalloonCanvas on: form) setOrigin: origin clipRect: clipRect! ! 125757 125758!FormCanvas methodsFor: 'other'! 125759flushDisplay 125760 Display deferUpdates: false; forceDisplayUpdate.! ! 125761 125762!FormCanvas methodsFor: 'other'! 125763forceToScreen:rect 125764 ^Display forceToScreen:rect. 125765! ! 125766 125767!FormCanvas methodsFor: 'other'! 125768showAt: pt 125769 125770 ^ form displayAt: pt! ! 125771 125772!FormCanvas methodsFor: 'other' stamp: 'ar 5/28/2000 12:09'! 125773showAt: pt invalidRects: updateRects 125774 | blt | 125775 blt := (BitBlt current toForm: Display) 125776 sourceForm: form; 125777 combinationRule: Form over. 125778 updateRects do: 125779 [:rect | 125780 blt sourceRect: rect; 125781 destOrigin: rect topLeft + pt; 125782 copyBits]! ! 125783 125784!FormCanvas methodsFor: 'other' stamp: 'ar 5/28/2000 12:12'! 125785warpFrom: sourceQuad toRect: destRect 125786 ^ (WarpBlt current toForm: port destForm) 125787 combinationRule: Form paint; 125788 sourceQuad: sourceQuad destRect: (destRect translateBy: origin); 125789 clipRect: clipRect! ! 125790 125791 125792!FormCanvas methodsFor: 'printing' stamp: 'ar 5/28/2000 17:07'! 125793printOn: aStream 125794 super printOn: aStream. 125795 aStream nextPutAll:' on: '; print: form.! ! 125796 125797 125798!FormCanvas methodsFor: 'testing' stamp: 'ar 2/17/2000 00:24'! 125799isShadowDrawing 125800 ^ self shadowColor notNil! ! 125801 125802!FormCanvas methodsFor: 'testing' stamp: 'ar 6/22/1999 14:08'! 125803isVisible: aRectangle 125804 "Optimization" 125805 (aRectangle right + origin x) < clipRect left ifTrue: [^ false]. 125806 (aRectangle left + origin x) > clipRect right ifTrue: [^ false]. 125807 (aRectangle bottom + origin y) < clipRect top ifTrue: [^ false]. 125808 (aRectangle top + origin y) > clipRect bottom ifTrue: [^ false]. 125809 ^ true 125810! ! 125811 125812 125813!FormCanvas methodsFor: 'private' stamp: 'ar 5/14/2001 23:34'! 125814image: aForm at: aPoint sourceRect: sourceRect rule: rule 125815 "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." 125816 port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. 125817 port image: aForm at: aPoint + origin sourceRect: sourceRect rule: rule.! ! 125818 125819!FormCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:21'! 125820image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha 125821 "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." 125822 port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. 125823 port image: aForm at: aPoint + origin sourceRect: sourceRect rule: rule alpha: sourceAlpha.! ! 125824 125825!FormCanvas methodsFor: 'private' stamp: 'pavel.krivanek 11/21/2008 16:55'! 125826portClass 125827 125828 "Return the class used as port" 125829 ^ UIManager default grafPort! ! 125830 125831!FormCanvas methodsFor: 'private' stamp: 'RAA 12/17/2000 13:24'! 125832privateClipRect 125833 125834 ^clipRect! ! 125835 125836!FormCanvas methodsFor: 'private' stamp: 'RAA 12/17/2000 13:25'! 125837privatePort 125838 125839 ^port! ! 125840 125841!FormCanvas methodsFor: 'private' stamp: 'yo 6/18/2004 15:11'! 125842privateWarp: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize 125843 "Warp the given using the appropriate transform and offset." 125844 | globalRect sourceQuad warp tfm | 125845 tfm := aTransform. 125846 globalRect := tfm localBoundsToGlobal: sourceRect. 125847 sourceQuad := (tfm sourceQuadFor: globalRect) collect:[:p| p - sourceRect topLeft]. 125848 extraOffset ifNotNil:[globalRect := globalRect translateBy: extraOffset]. 125849 warp := (WarpBlt current toForm: port destForm) 125850 combinationRule: Form paint; 125851 sourceQuad: sourceQuad destRect: (globalRect origin corner: globalRect corner+(1@1)); 125852 clipRect: port clipRect. 125853 warp cellSize: cellSize. 125854 warp sourceForm: aForm. 125855 warp warpBits! ! 125856 125857!FormCanvas methodsFor: 'private' stamp: 'ar 5/25/2000 17:25'! 125858resetGrafPort 125859 "Private!! Create a new grafPort for a new copy." 125860 125861 port := self portClass toForm: form. 125862 port clipRect: clipRect. 125863! ! 125864 125865!FormCanvas methodsFor: 'private' stamp: 'tpr 9/15/2004 10:28'! 125866setClearColor: aColor 125867 "Install a new clear color - e.g., a color is used for clearing the background" 125868 | clearColor | 125869 clearColor := aColor ifNil:[Color transparent]. 125870 clearColor isColor ifFalse:[ 125871 (clearColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color']. 125872 ^port fillPattern: clearColor; combinationRule: Form over]. 125873 "Okay, so clearColor really *is* a color" 125874 port sourceForm: nil. 125875 port combinationRule: Form over. 125876 port fillPattern: clearColor. 125877 self depth = 8 ifTrue:[ 125878 "Use a stipple pattern" 125879 port fillColor: (form balancedPatternFor: clearColor)]. 125880! ! 125881 125882!FormCanvas methodsFor: 'private' stamp: 'tpr 9/15/2004 10:28'! 125883setFillColor: aColor 125884 "Install a new color used for filling." 125885 | screen patternWord fillColor | 125886 fillColor := self shadowColor ifNil:[aColor]. 125887 fillColor ifNil:[fillColor := Color transparent]. 125888 fillColor isColor ifFalse:[ 125889 (fillColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color']. 125890 ^port fillPattern: fillColor; combinationRule: Form over]. 125891 "Okay, so fillColor really *is* a color" 125892 port sourceForm: nil. 125893 fillColor isTranslucent ifFalse:[ 125894 port combinationRule: Form over. 125895 port fillPattern: fillColor. 125896 self depth = 8 ifTrue:[ 125897 "In 8 bit depth it's usually a good idea to use a stipple pattern" 125898 port fillColor: (form balancedPatternFor: fillColor)]. 125899 ^self]. 125900 "fillColor is some translucent color" 125901 125902 self depth > 8 ifTrue:[ 125903 "BitBlt setup for alpha masked transfer" 125904 port fillPattern: fillColor. 125905 self depth = 16 125906 ifTrue:[port alphaBits: fillColor privateAlpha; combinationRule: 30] 125907 ifFalse:[port combinationRule: Form blend]. 125908 ^self]. 125909 "Can't represent actual transparency -- use stipple pattern" 125910 screen := Color translucentMaskFor: fillColor alpha depth: self depth. 125911 patternWord := form pixelWordFor: fillColor. 125912 port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]). 125913 port combinationRule: Form paint. 125914! ! 125915 125916!FormCanvas methodsFor: 'private' stamp: 'ar 5/25/2000 17:25'! 125917setForm: aForm 125918 125919 self reset. 125920 form := aForm. 125921 port := self portClass toForm: form. 125922! ! 125923 125924!FormCanvas methodsFor: 'private' stamp: 'ar 6/22/1999 14:06'! 125925setOrigin: aPoint clipRect: aRectangle 125926 125927 origin := aPoint. 125928 clipRect := aRectangle. 125929 port clipRect: aRectangle. 125930! ! 125931 125932!FormCanvas methodsFor: 'private' stamp: 'tpr 9/15/2004 10:28'! 125933setPaintColor: aColor 125934 "Install a new color used for filling." 125935 | paintColor screen patternWord | 125936 paintColor := self shadowColor ifNil:[aColor]. 125937 paintColor ifNil:[paintColor := Color transparent]. 125938 paintColor isColor ifFalse:[ 125939 (paintColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color']. 125940 ^port fillPattern: paintColor; combinationRule: Form paint]. 125941 "Okay, so paintColor really *is* a color" 125942 port sourceForm: nil. 125943 (paintColor isTranslucent) ifFalse:[ 125944 port fillPattern: paintColor. 125945 port combinationRule: Form paint. 125946 self depth = 8 ifTrue:[ 125947 port fillColor: (form balancedPatternFor: paintColor)]. 125948 ^self]. 125949 "paintColor is translucent color" 125950 125951 self depth > 8 ifTrue:[ 125952 "BitBlt setup for alpha mapped transfer" 125953 port fillPattern: paintColor. 125954 self depth = 16 125955 ifTrue:[port alphaBits: paintColor privateAlpha; combinationRule: 31] 125956 ifFalse:[port combinationRule: Form blend]. 125957 ^self]. 125958 125959 "Can't represent actual transparency -- use stipple pattern" 125960 screen := Color translucentMaskFor: paintColor alpha depth: self depth. 125961 patternWord := form pixelWordFor: paintColor. 125962 port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]). 125963 port combinationRule: Form paint 125964! ! 125965 125966"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 125967 125968FormCanvas class 125969 instanceVariableNames: ''! 125970 125971!FormCanvas class methodsFor: 'instance creation'! 125972extent: aPoint 125973 125974 ^ self extent: aPoint depth: Display depth 125975! ! 125976 125977!FormCanvas class methodsFor: 'instance creation'! 125978extent: extent depth: depth 125979 125980 ^ self new setForm: (Form extent: extent depth: depth)! ! 125981 125982!FormCanvas class methodsFor: 'instance creation' stamp: 'nk 7/4/2003 10:11'! 125983extent: extent depth: depth origin: aPoint clipRect: aRectangle 125984 125985 ^ self new 125986 setForm: (Form extent: extent depth: depth); 125987 setOrigin: aPoint clipRect: aRectangle; 125988 yourself! ! 125989 125990!FormCanvas class methodsFor: 'instance creation' stamp: 'jm 8/2/97 13:54'! 125991on: aForm 125992 125993 ^ self new setForm: aForm 125994! ! 125995 125996 125997!FormCanvas class methodsFor: 'testing' stamp: 'ar 12/31/2001 02:26'! 125998test1 125999 "FormCanvas test1" 126000 126001 | canvas | 126002 canvas := FormCanvas extent: 200@200. 126003 canvas fillColor: (Color black). 126004 canvas line: 10@10 to: 50@30 width: 1 color: (Color red). 126005 canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: (Color green). 126006 canvas point: 100@100 color: (Color black). 126007 canvas drawString: 'Hello, World!!' at: 40@40 font: nil color: (Color cyan). 126008 canvas fillRectangle: ((10@80) corner: (31@121)) color: (Color magenta). 126009 canvas fillOval: ((10@80) corner: (31@121)) color: (Color cyan). 126010 canvas frameOval: ((40@80) corner: (61@121)) color: (Color blue). 126011 canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: (Color red alpha: 0.2). 126012 canvas fillRectangle: ((130@30) corner: (170@80)) color: (Color lightYellow). 126013 canvas showAt: 0@0. 126014! ! 126015 126016!FormCanvas class methodsFor: 'testing' stamp: 'ar 12/31/2001 02:26'! 126017test2 126018 "FormCanvas test2" 126019 126020 | baseCanvas p | 126021 baseCanvas := FormCanvas extent: 200@200. 126022 p := Sensor cursorPoint. 126023 [Sensor anyButtonPressed] whileFalse: [ 126024 baseCanvas translateBy: (Sensor cursorPoint - p) during:[:canvas| 126025 canvas fillColor: Color white. 126026 canvas line: 10@10 to: 50@30 width: 1 color: Color red. 126027 canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: Color green. 126028 canvas point: 100@100 color: Color black. 126029 canvas drawString: 'Hello, World!!' at: 40@40 font: nil color: Color cyan. 126030 canvas fillRectangle: ((10@80) corner: (31@121)) color: Color magenta. 126031 canvas fillOval: ((10@80) corner: (31@121)) color: Color cyan. 126032 canvas frameOval: ((40@80) corner: (61@121)) color: Color blue. 126033 canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: Color red. 126034 canvas fillRectangle: ((130@30) corner: (170@80)) color: Color lightYellow. 126035 canvas showAt: 0@0]]. 126036! ! 126037 126038!FormCanvas class methodsFor: 'testing' stamp: 'ar 12/31/2001 02:25'! 126039test3 126040 "FormCanvas test3" 126041 126042 | baseCanvas | 126043 baseCanvas := FormCanvas extent: 200@200. 126044 baseCanvas fillColor: Color white. 126045 baseCanvas translateBy: 10@10 during:[:canvas| 126046 canvas shadowColor: (Color black alpha: 0.5). 126047 canvas line: 10@10 to: 50@30 width: 1 color: Color red. 126048 canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: Color green. 126049 canvas point: 100@100 color: Color black. 126050 canvas drawString: 'Hello, World!!' at: 40@40 font: nil color: Color cyan. 126051 canvas fillRectangle: ((10@80) corner: (31@121)) color: Color magenta. 126052 canvas fillOval: ((10@80) corner: (31@121)) color: Color cyan. 126053 canvas frameOval: ((40@80) corner: (61@121)) color: Color blue. 126054 canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: Color red. 126055 canvas fillRectangle: ((130@30) corner: (170@80)) color: Color lightYellow. 126056 canvas showAt: 0@0. 126057 ].! ! 126058StrikeFont subclass: #FormSetFont 126059 instanceVariableNames: '' 126060 classVariableNames: '' 126061 poolDictionaries: '' 126062 category: 'Graphics-Fonts'! 126063!FormSetFont commentStamp: '<historical>' prior: 0! 126064FormSetFonts are designed to capture individual images as character forms for imbedding in normal text. While most often used to insert an isolated glyph in some text, the code is actually desinged to support an entire user-defined font. The TextAttribute subclass TextFontReference is specifically designed for such in-line insertion of exceptional fonts in normal text.! 126065 126066 126067!FormSetFont methodsFor: 'as yet unclassified' stamp: 'lr 7/4/2009 10:42'! 126068fromFormArray: formArray asciiStart: asciiStart ascent: ascentVal 126069 | height width x badChar | 126070 type := 2. 126071 name := 'aFormFont'. 126072 minAscii := asciiStart. 126073 maxAscii := minAscii + formArray size - 1. 126074 ascent := ascentVal. 126075 subscript := superscript := emphasis := 0. 126076 height := width := 0. 126077 maxWidth := 0. 126078 formArray do: 126079 [ :f | 126080 width := width + f width. 126081 maxWidth := maxWidth max: f width. 126082 height := height max: f height + f offset y ]. 126083 badChar := (Form extent: 7 @ height) borderWidth: 1. 126084 width := width + badChar width. 126085 descent := height - ascent. 126086 pointSize := height. 126087 glyphs := Form 126088 extent: width @ height 126089 depth: formArray first depth. 126090 xTable := Array 126091 new: maxAscii + 3 126092 withAll: 0. 126093 x := 0. 126094 formArray doWithIndex: 126095 [ :f :i | 126096 f 126097 displayOn: glyphs 126098 at: x @ 0. 126099 xTable 126100 at: minAscii + i + 1 126101 put: (x := x + f width) ]. 126102 badChar 126103 displayOn: glyphs 126104 at: x @ 0. 126105 xTable 126106 at: maxAscii + 3 126107 put: x + badChar width. 126108 characterToGlyphMap := nil! ! 126109 126110!FormSetFont methodsFor: 'as yet unclassified'! 126111reset "Ignored by FormSetFonts"! ! 126112 126113"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 126114 126115FormSetFont class 126116 instanceVariableNames: ''! 126117 126118!FormSetFont class methodsFor: 'examples' stamp: 'ar 1/15/2001 18:38'! 126119copy: charForm toClipBoardAs: char ascent: ascent 126120 Clipboard clipboardText: 126121 (Text string: char asString 126122 attribute: (TextFontReference toFont: 126123 (FormSetFont new 126124 fromFormArray: (Array with: charForm) 126125 asciiStart: char asciiValue 126126 ascent: ascent))) 126127" 126128 The S in the Squeak welcome window was installed by doing the following 126129 in a workspace (where the value of, eg, charForm will persist through BitEdit... 126130 f _ TextStyle default fontAt: 4. 126131 oldS _ f characterFormAt: $S. 126132 charForm _ Form extent: oldS extent depth: 8. 126133 oldS displayOn: charForm. 126134 charForm bitEdit. 126135 ...Play around with the BitEditor, then accept and close... 126136 FormSetFont copy: charForm toClipBoardAs: $S ascent: f ascent. 126137 ...Then do a paste into the Welcome window 126138"! ! 126139 126140!FormSetFont class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 126141example 126142 "FormSetFont example" 126143 "Lets the user select a (small) area of the screen to represent the 126144 character A, then copies 'A' to the clipboard with that as the letter form. 126145 Thereafter, a paste operation will imbed that character in any text." 126146 | charForm | 126147 charForm := Form fromUser. 126148 self 126149 copy: charForm 126150 toClipBoardAs: $A 126151 ascent: charForm height! ! 126152Form subclass: #FormStub 126153 instanceVariableNames: 'locator' 126154 classVariableNames: '' 126155 poolDictionaries: '' 126156 category: 'Graphics-Display Objects'! 126157 126158!FormStub methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:02'! 126159locator 126160 ^locator! ! 126161 126162!FormStub methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:02'! 126163locator: aString 126164 locator := aString! ! 126165 126166 126167!FormStub methodsFor: 'filein/out' stamp: 'ar 2/27/2001 21:36'! 126168objectForDataStream: refStream 126169 "Force me into outPointers so that I get notified about startup" 126170 refStream replace: self with: self. 126171 ^self! ! 126172ClassTestCase subclass: #FormTest 126173 instanceVariableNames: '' 126174 classVariableNames: '' 126175 poolDictionaries: '' 126176 category: 'GraphicsTests-Primitives'! 126177!FormTest commentStamp: 'ar 7/21/2007 21:39' prior: 0! 126178Various tests for class form.! 126179 126180 126181!FormTest methodsFor: 'tests' stamp: 'ar 7/21/2007 21:41'! 126182testIsAllWhite "self run: #testIsAllWhite" 126183 "Make sure #isAllWhite works for all bit depths" 126184 | form | 126185 #(-32 -16 -8 -4 -2 -1 1 2 4 8 16 32) do:[:d| 126186 form := Form extent: 16@16 depth: d. 126187 form fillBlack. 126188 self deny: form isAllWhite. 126189 form fillWhite. 126190 self assert: form isAllWhite. 126191 ]. 126192! ! 126193Number subclass: #Fraction 126194 instanceVariableNames: 'numerator denominator' 126195 classVariableNames: '' 126196 poolDictionaries: '' 126197 category: 'Kernel-Numbers'! 126198!Fraction commentStamp: '<historical>' prior: 0! 126199Fraction provides methods for dealing with fractions like 1/3 as fractions (not as 0.33333...). All public arithmetic operations answer reduced fractions (see examples). 126200 126201instance variables: 'numerator denominator ' 126202 126203Examples: (note the parentheses required to get the right answers in Smalltalk and Squeak): 126204 126205(2/3) + (2/3) 126206(2/3) + (1/2) "answers shows the reduced fraction" 126207(2/3) raisedToInteger: 5 "fractions also can have exponents" 126208! 126209 126210 126211!Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'! 126212* aNumber 126213 "Answer the result of multiplying the receiver by aNumber." 126214 | d1 d2 | 126215 aNumber isFraction ifTrue: 126216 [d1 := numerator gcd: aNumber denominator. 126217 d2 := denominator gcd: aNumber numerator. 126218 (d2 = denominator and: [d1 = aNumber denominator]) 126219 ifTrue: [^ numerator // d1 * (aNumber numerator // d2)]. 126220 ^ Fraction numerator: numerator // d1 * (aNumber numerator // d2) 126221 denominator: denominator // d2 * (aNumber denominator // d1)]. 126222 ^ aNumber adaptToFraction: self andSend: #*! ! 126223 126224!Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'! 126225+ aNumber 126226 "Answer the sum of the receiver and aNumber." 126227 | n d d1 d2 | 126228 aNumber isFraction ifTrue: 126229 [d := denominator gcd: aNumber denominator. 126230 n := numerator * (d1 := aNumber denominator // d) + (aNumber numerator * (d2 := denominator // d)). 126231 d1 := d1 * d2. 126232 n := n // (d2 := n gcd: d). 126233 (d := d1 * (d // d2)) = 1 ifTrue: [^ n]. 126234 ^ Fraction numerator: n denominator: d]. 126235 ^ aNumber adaptToFraction: self andSend: #+! ! 126236 126237!Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'! 126238- aNumber 126239 "Answer the difference between the receiver and aNumber." 126240 aNumber isFraction ifTrue: 126241 [^ self + aNumber negated]. 126242 ^ aNumber adaptToFraction: self andSend: #-! ! 126243 126244!Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'! 126245/ aNumber 126246 "Answer the result of dividing the receiver by aNumber." 126247 aNumber isFraction 126248 ifTrue: [^self * aNumber reciprocal]. 126249 ^ aNumber adaptToFraction: self andSend: #/! ! 126250 126251!Fraction methodsFor: 'arithmetic'! 126252negated 126253 "Refer to the comment in Number|negated." 126254 126255 ^ Fraction 126256 numerator: numerator negated 126257 denominator: denominator! ! 126258 126259 126260!Fraction methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:37'! 126261< aNumber 126262 aNumber isFraction ifTrue: 126263 [^ numerator * aNumber denominator < (aNumber numerator * denominator)]. 126264 ^ aNumber adaptToFraction: self andCompare: #<! ! 126265 126266!Fraction methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:41'! 126267= aNumber 126268 aNumber isNumber ifFalse: [^ false]. 126269 aNumber isFraction 126270 ifTrue: [numerator = 0 ifTrue: [^ aNumber numerator = 0]. 126271 ^ (numerator * aNumber denominator) = 126272 (aNumber numerator * denominator) 126273 "Note: used to just compare num and denom, 126274 but this fails for improper fractions"]. 126275 ^ aNumber adaptToFraction: self andCompare: #=! ! 126276 126277!Fraction methodsFor: 'comparing' stamp: 'nice 6/11/2009 02:52'! 126278hash 126279 "Hash is reimplemented because = is implemented. 126280 Care is taken that a Fraction equal to a Float also have an equal hash" 126281 126282 | tmp | 126283 denominator isPowerOfTwo ifTrue: [ 126284 "If denominator is a power of two, I can be exactly equal to a Float" 126285 tmp := self asFloat. 126286 tmp isFinite ifTrue: [^tmp hash]]. 126287 126288 "Else, I cannot be exactly equal to a Float, use own hash algorithm. 126289 (Assume the fraction is already reduced)" 126290 ^numerator hash bitXor: denominator hash! ! 126291 126292 126293!Fraction methodsFor: 'converting' stamp: 'mk 10/27/2003 18:13'! 126294adaptToComplex: rcvr andSend: selector 126295 "If I am involved in arithmetic with a Complex number, convert me to a Complex number." 126296 ^ rcvr perform: selector with: self asComplex! ! 126297 126298!Fraction methodsFor: 'converting' stamp: 'di 11/6/1998 13:10'! 126299adaptToInteger: rcvr andSend: selector 126300 "If I am involved in arithmetic with an Integer, convert it to a Fraction." 126301 ^ rcvr asFraction perform: selector with: self! ! 126302 126303!Fraction methodsFor: 'converting' stamp: 'mk 10/27/2003 18:13'! 126304asComplex 126305 "Answer a Complex number that represents value of the the receiver." 126306 126307 ^ Complex real: self imaginary: 0! ! 126308 126309!Fraction methodsFor: 'converting' stamp: 'nice 1/10/2007 02:07'! 126310asFloat 126311 "Answer a Float that closely approximates the value of the receiver. 126312 This implementation will answer the closest floating point number to 126313 the receiver. 126314 It uses the IEEE 754 round to nearest even mode 126315 (can happen in case denominator is a power of two)" 126316 126317 | a b q r exponent floatExponent n ha hb hq q1 | 126318 a := numerator abs. 126319 b := denominator abs. 126320 ha := a highBit. 126321 hb := b highBit. 126322 126323 "If both numerator and denominator are represented exactly in floating point number, 126324 then fastest thing to do is to use hardwired float division" 126325 (ha < 54 and: [hb < 54]) ifTrue: [^numerator asFloat / denominator asFloat]. 126326 126327 "Try and obtain a mantissa with 54 bits. 126328 First guess is rough, we might get one more bit or one less" 126329 exponent := ha - hb - 54. 126330 exponent > 0 126331 ifTrue: [b := b bitShift: exponent] 126332 ifFalse: [a := a bitShift: exponent negated]. 126333 q := a quo: b. 126334 r := a - (q * b). 126335 hq := q highBit. 126336 126337 "check for gradual underflow, in which case we should use less bits" 126338 floatExponent := exponent + hq - 1. 126339 n := floatExponent > -1023 126340 ifTrue: [54] 126341 ifFalse: [54 + floatExponent + 1022]. 126342 126343 hq > n 126344 ifTrue: [exponent := exponent + hq - n. 126345 r := (q bitAnd: (1 bitShift: hq - n) - 1) * b + r. 126346 q := q bitShift: n - hq]. 126347 hq < n 126348 ifTrue: [exponent := exponent + hq - n. 126349 q1 := (r bitShift: n - hq) quo: b. 126350 q := (q bitShift: n - hq) bitAnd: q1. 126351 r := (r bitShift: n - hq) - (q1 * b)]. 126352 126353 "check if we should round upward. 126354 The case of exact half (q bitAnd: 1) isZero not & (r isZero) 126355 will be handled by Integer>>asFloat" 126356 ((q bitAnd: 1) isZero or: [r isZero]) 126357 ifFalse: [q := q + 1]. 126358 126359 ^ (self positive 126360 ifTrue: [q asFloat] 126361 ifFalse: [q asFloat negated]) 126362 timesTwoPower: exponent! ! 126363 126364!Fraction methodsFor: 'converting'! 126365asFraction 126366 "Answer the receiver itself." 126367 126368 ^self! ! 126369 126370!Fraction methodsFor: 'converting'! 126371isFraction 126372 ^ true! ! 126373 126374 126375!Fraction methodsFor: 'mathematical functions' stamp: 'LC 4/22/1998 14:03'! 126376raisedToInteger: anInteger 126377 "See Number | raisedToInteger:" 126378 anInteger = 0 ifTrue: [^ 1]. 126379 anInteger < 0 ifTrue: [^ self reciprocal raisedToInteger: anInteger negated]. 126380 ^ Fraction numerator: (numerator raisedToInteger: anInteger) 126381 denominator: (denominator raisedToInteger: anInteger)! ! 126382 126383!Fraction methodsFor: 'mathematical functions' stamp: 'LC 4/22/1998 14:05'! 126384squared 126385 "See Fraction (Number) | squared" 126386 ^ Fraction numerator: numerator squared denominator: denominator squared! ! 126387 126388 126389!Fraction methodsFor: 'printing'! 126390printOn: aStream 126391 126392 aStream nextPut: $(. 126393 numerator printOn: aStream. 126394 aStream nextPut: $/. 126395 denominator printOn: aStream. 126396 aStream nextPut: $). 126397! ! 126398 126399!Fraction methodsFor: 'printing' stamp: 'laza 3/29/2004 12:56'! 126400printOn: aStream base: base 126401 126402 aStream nextPut: $(. 126403 numerator printOn: aStream base: base. 126404 aStream nextPut: $/. 126405 denominator printOn: aStream base: base. 126406 aStream nextPut: $). 126407! ! 126408 126409!Fraction methodsFor: 'printing' stamp: 'laza 3/29/2004 13:25'! 126410storeOn: aStream base: base 126411 126412 aStream nextPut: $(. 126413 numerator storeOn: aStream base: base. 126414 aStream nextPut: $/. 126415 denominator storeOn: aStream base: base. 126416 aStream nextPut: $). 126417! ! 126418 126419 126420!Fraction methodsFor: 'self evaluating' stamp: 'apb 4/20/2006 18:41'! 126421isSelfEvaluating 126422 ^ true! ! 126423 126424 126425!Fraction methodsFor: 'truncation and round off'! 126426truncated 126427 "Refer to the comment in Number|truncated." 126428 126429 ^numerator quo: denominator! ! 126430 126431 126432!Fraction methodsFor: 'private'! 126433denominator 126434 126435 ^denominator! ! 126436 126437!Fraction methodsFor: 'private'! 126438numerator 126439 126440 ^numerator! ! 126441 126442!Fraction methodsFor: 'private' stamp: 'GabrielOmarCotelli 5/23/2009 20:36'! 126443reciprocal 126444 126445 numerator abs = 1 ifTrue: [^denominator * numerator]. 126446 ^self class numerator: denominator denominator: numerator! ! 126447 126448!Fraction methodsFor: 'private'! 126449reduced 126450 126451 | gcd numer denom | 126452 numerator = 0 ifTrue: [^0]. 126453 gcd := numerator gcd: denominator. 126454 numer := numerator // gcd. 126455 denom := denominator // gcd. 126456 denom = 1 ifTrue: [^numer]. 126457 ^Fraction numerator: numer denominator: denom! ! 126458 126459!Fraction methodsFor: 'private' stamp: 'tfei 4/12/1999 12:45'! 126460setNumerator: n denominator: d 126461 126462 d = 0 126463 ifTrue: [^(ZeroDivide dividend: n) signal] 126464 ifFalse: 126465 [numerator := n asInteger. 126466 denominator := d asInteger abs. "keep sign in numerator" 126467 d < 0 ifTrue: [numerator := numerator negated]]! ! 126468 126469"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 126470 126471Fraction class 126472 instanceVariableNames: ''! 126473 126474!Fraction class methodsFor: 'instance creation' stamp: 'di 8/31/1999 10:16'! 126475numerator: numInteger denominator: denInteger 126476 "Answer an instance of me (numInteger/denInteger). 126477 NOTE: This primitive initialization method will not reduce improper fractions, 126478 so normal usage should be coded as, eg, 126479 (Fraction numerator: a denominator: b) reduced 126480 or, more simply, as 126481 a / b." 126482 126483 ^self new setNumerator: numInteger denominator: denInteger! ! 126484ClassTestCase subclass: #FractionTest 126485 instanceVariableNames: '' 126486 classVariableNames: '' 126487 poolDictionaries: '' 126488 category: 'KernelTests-Numbers'! 126489 126490!FractionTest methodsFor: 'tests - printing' stamp: 'laza 3/30/2004 09:28'! 126491testFractionPrinting 126492 126493 self assert: (353/359) printString = '(353/359)'. 126494 self assert: ((2/3) printStringBase: 2) = '(10/11)'. 126495 self assert: ((2/3) storeStringBase: 2) = '(2r10/2r11)'. 126496 self assert: ((5/7) printStringBase: 3) = '(12/21)'. 126497 self assert: ((5/7) storeStringBase: 3) = '(3r12/3r21)'. 126498 self assert: ((11/13) printStringBase: 4) = '(23/31)'. 126499 self assert: ((11/13) storeStringBase: 4) = '(4r23/4r31)'. 126500 self assert: ((17/19) printStringBase: 5) = '(32/34)'. 126501 self assert: ((17/19) storeStringBase: 5) = '(5r32/5r34)'. 126502 self assert: ((23/29) printStringBase: 6) = '(35/45)'. 126503 self assert: ((23/29) storeStringBase: 6) = '(6r35/6r45)'. 126504 self assert: ((31/37) printStringBase: 7) = '(43/52)'. 126505 self assert: ((31/37) storeStringBase: 7) = '(7r43/7r52)'. 126506 self assert: ((41/43) printStringBase: 8) = '(51/53)'. 126507 self assert: ((41/43) storeStringBase: 8) = '(8r51/8r53)'. 126508 self assert: ((47/53) printStringBase: 9) = '(52/58)'. 126509 self assert: ((47/53) storeStringBase: 9) = '(9r52/9r58)'. 126510 self assert: ((59/61) printStringBase: 10) = '(59/61)'. 126511 self assert: ((59/61) storeStringBase: 10) = '(59/61)'. 126512 self assert: ((67/71) printStringBase: 11) = '(61/65)'. 126513 self assert: ((67/71) storeStringBase: 11) = '(11r61/11r65)'. 126514 self assert: ((73/79) printStringBase: 12) = '(61/67)'. 126515 self assert: ((73/79) storeStringBase: 12) = '(12r61/12r67)'. 126516 self assert: ((83/89) printStringBase: 13) = '(65/6B)'. 126517 self assert: ((83/89) storeStringBase: 13) = '(13r65/13r6B)'. 126518 self assert: ((97/101) printStringBase: 14) = '(6D/73)'. 126519 self assert: ((97/101) storeStringBase: 14) = '(14r6D/14r73)'. 126520 self assert: ((103/107) printStringBase: 15) = '(6D/72)'. 126521 self assert: ((103/107) storeStringBase: 15) = '(15r6D/15r72)'. 126522 self assert: ((109/113) printStringBase: 16) = '(6D/71)'. 126523 self assert: ((109/113) storeStringBase: 16) = '(16r6D/16r71)'. 126524 self assert: ((127/131) printStringBase: 17) = '(78/7C)'. 126525 self assert: ((127/131) storeStringBase: 17) = '(17r78/17r7C)'. 126526 self assert: ((137/139) printStringBase: 18) = '(7B/7D)'. 126527 self assert: ((137/139) storeStringBase: 18) = '(18r7B/18r7D)'. 126528 self assert: ((149/151) printStringBase: 19) = '(7G/7I)'. 126529 self assert: ((149/151) storeStringBase: 19) = '(19r7G/19r7I)'. 126530 self assert: ((157/163) printStringBase: 20) = '(7H/83)'. 126531 self assert: ((157/163) storeStringBase: 20) = '(20r7H/20r83)'. 126532 self assert: ((167/173) printStringBase: 21) = '(7K/85)'. 126533 self assert: ((167/173) storeStringBase: 21) = '(21r7K/21r85)'. 126534 self assert: ((179/181) printStringBase: 22) = '(83/85)'. 126535 self assert: ((179/181) storeStringBase: 22) = '(22r83/22r85)'. 126536 self assert: ((191/193) printStringBase: 23) = '(87/89)'. 126537 self assert: ((191/193) storeStringBase: 23) = '(23r87/23r89)'. 126538 self assert: ((197/199) printStringBase: 24) = '(85/87)'. 126539 self assert: ((197/199) storeStringBase: 24) = '(24r85/24r87)'. 126540 self assert: ((211/223) printStringBase: 25) = '(8B/8N)'. 126541 self assert: ((211/223) storeStringBase: 25) = '(25r8B/25r8N)'. 126542 self assert: ((227/229) printStringBase: 26) = '(8J/8L)'. 126543 self assert: ((227/229) storeStringBase: 26) = '(26r8J/26r8L)'. 126544 self assert: ((233/239) printStringBase: 27) = '(8H/8N)'. 126545 self assert: ((233/239) storeStringBase: 27) = '(27r8H/27r8N)'. 126546 self assert: ((241/251) printStringBase: 28) = '(8H/8R)'. 126547 self assert: ((241/251) storeStringBase: 28) = '(28r8H/28r8R)'. 126548 self assert: ((257/263) printStringBase: 29) = '(8P/92)'. 126549 self assert: ((257/263) storeStringBase: 29) = '(29r8P/29r92)'. 126550 self assert: ((269/271) printStringBase: 30) = '(8T/91)'. 126551 self assert: ((269/271) storeStringBase: 30) = '(30r8T/30r91)'. 126552 self assert: ((277/281) printStringBase: 31) = '(8T/92)'. 126553 self assert: ((277/281) storeStringBase: 31) = '(31r8T/31r92)'. 126554 self assert: ((283/293) printStringBase: 32) = '(8R/95)'. 126555 self assert: ((283/293) storeStringBase: 32) = '(32r8R/32r95)'. 126556 self assert: ((307/311) printStringBase: 33) = '(9A/9E)'. 126557 self assert: ((307/311) storeStringBase: 33) = '(33r9A/33r9E)'. 126558 self assert: ((313/317) printStringBase: 34) = '(97/9B)'. 126559 self assert: ((313/317) storeStringBase: 34) = '(34r97/34r9B)'. 126560 self assert: ((331/337) printStringBase: 35) = '(9G/9M)'. 126561 self assert: ((331/337) storeStringBase: 35) = '(35r9G/35r9M)'. 126562 self assert: ((347/349) printStringBase: 36) = '(9N/9P)'. 126563 self assert: ((347/349) storeStringBase: 36) = '(36r9N/36r9P)'. 126564 126565 self assert: ((-2/3) printStringBase: 2) = '(-10/11)'. 126566 self assert: ((-2/3) storeStringBase: 2) = '(-2r10/2r11)'. 126567 self assert: ((5/-7) printStringBase: 3) = '(-12/21)'. 126568 self assert: ((5/-7) storeStringBase: 3) = '(-3r12/3r21)'. 126569! ! 126570 126571 126572!FractionTest methodsFor: 'tests - sinuses' stamp: 'sd 3/4/2004 21:13'! 126573testDegreeCos 126574 "self run: #testDegreeCos" 126575 126576 self shouldnt: [ (4/3) degreeCos] raise: Error. 126577 self assert: (1/3) degreeCos printString = '0.999983076857744'! ! 126578 126579!FractionTest methodsFor: 'tests - sinuses' stamp: 'sd 3/5/2004 14:54'! 126580testDegreeSin 126581 "self run: #testDegreeSin" 126582 126583 self shouldnt: [ (4/3) degreeSin] raise: Error. 126584 self assert: (1/3) degreeSin printString = '0.005817731354993834'.! ! 126585 126586!FractionTest methodsFor: 'tests - sinuses' stamp: 'GabrielOmarCotelli 5/23/2009 20:19'! 126587testReciprocal 126588 126589 self 126590 assert: (1/2) reciprocal = 2; 126591 assert: (3/4) reciprocal = (4/3); 126592 assert: (-1/3) reciprocal = -3; 126593 assert: (-3/5) reciprocal = (-5/3)! ! 126594Object subclass: #FreeTypeCache 126595 instanceVariableNames: 'maximumSize used fontTable fifo' 126596 classVariableNames: '' 126597 poolDictionaries: 'FreeTypeCacheConstants' 126598 category: 'FreeType-Cache'! 126599 126600!FreeTypeCache methodsFor: 'add-remove' stamp: 'tween 8/10/2006 19:34'! 126601atFont: aFreeTypeFont charCode: charCodeInteger type: typeFlag 126602 | entry charCodeTable typeTable | 126603 (charCodeTable := fontTable at: aFreeTypeFont ifAbsent:[]) 126604 ifNotNil:[ 126605 (typeTable := charCodeTable at: charCodeInteger ifAbsent:[]) 126606 ifNotNil:[ 126607 (entry := typeTable at: typeFlag ifAbsent:[]) 126608 ifNotNil:[ 126609 fifo moveDown: entry. 126610 ^entry object]]]. 126611 self error: 'Not found'! ! 126612 126613!FreeTypeCache methodsFor: 'add-remove' stamp: 'tween 8/10/2006 21:20'! 126614atFont: aFreeTypeFont charCode: charCodeInteger type: typeFlag ifAbsentPut: aBlock 126615 | charCodeTable typeTable entry v vSize | 126616 126617 charCodeTable := fontTable at: aFreeTypeFont ifAbsentPut:[self dictionaryClass new: 60]. 126618 typeTable := charCodeTable at: charCodeInteger ifAbsentPut:[self dictionaryClass new: 10]. 126619 entry := typeTable at: typeFlag ifAbsent:[]. 126620 entry 126621 ifNotNil:[ 126622 fifo moveDown: entry. 126623 ^entry object]. 126624 v := aBlock value. 126625 vSize := self sizeOf: v. 126626 (maximumSize notNil and:[vSize > maximumSize]) 126627 ifTrue:[^v]. 126628 used := used + vSize. 126629 entry := (self fifoEntryClass new 126630 font: aFreeTypeFont; 126631 charCode: charCodeInteger; 126632 type: typeFlag; 126633 object: v; 126634 yourself). 126635 typeTable at: typeFlag put: entry. 126636 fifo addLast: entry. 126637 maximumSize ifNotNil:[self shrinkTo: maximumSize]. 126638 ^v 126639 ! ! 126640 126641!FreeTypeCache methodsFor: 'add-remove' stamp: 'tween 8/10/2006 21:20'! 126642atFont: aFreeTypeFont charCode: charCodeInteger type: typeFlag put: anObject 126643 | charCodeTable typeTable anObjectSize oldEntry oldEntrySize entry | 126644 126645 anObjectSize := self sizeOf: anObject. 126646 (maximumSize notNil and:[anObjectSize > maximumSize]) 126647 ifTrue:[^anObject]. 126648 (charCodeTable := fontTable at: aFreeTypeFont ifAbsentPut:[self dictionaryClass new: 60]) 126649 ifNotNil:[ 126650 (typeTable := charCodeTable at: charCodeInteger ifAbsentPut:[self dictionaryClass new: 10]) 126651 ifNotNil:[ 126652 oldEntry := typeTable at: typeFlag ifAbsent:[]. 126653 oldEntrySize := (oldEntry isNil 126654 ifTrue:[0] 126655 ifFalse:[self sizeOf: oldEntry object]). 126656 entry := (self fifoEntryClass new 126657 font: aFreeTypeFont; 126658 charCode: charCodeInteger; 126659 type: typeFlag; 126660 object: anObject; 126661 yourself). 126662 typeTable at: typeFlag put: entry]]. 126663 used := used + anObjectSize - oldEntrySize. 126664 oldEntry ifNotNil: [fifo remove: oldEntry]. 126665 fifo addLast: entry. 126666 maximumSize ifNotNil:[self shrinkTo: maximumSize]. 126667 ^anObject 126668 ! ! 126669 126670!FreeTypeCache methodsFor: 'add-remove' stamp: 'tween 8/10/2006 13:40'! 126671removeAll 126672 fontTable := self dictionaryClass new: 100. 126673 fifo := self fifoClass new. 126674 used := 0. 126675 126676 ! ! 126677 126678!FreeTypeCache methodsFor: 'add-remove' stamp: 'tween 8/10/2006 15:03'! 126679removeAllForFont: aFreeTypeFont 126680 | toRemove d | 126681 126682 (fontTable includesKey: aFreeTypeFont) ifFalse:[^self]. 126683 toRemove := IdentitySet new. 126684 fifo do:[:entry | 126685 entry font = aFreeTypeFont 126686 ifTrue:[toRemove add: entry]]. 126687 toRemove do:[:entry | 126688 fifo remove: entry. 126689 d := (fontTable at: entry font) at: entry charCode. 126690 d removeKey: entry type. 126691 used := used - (self sizeOf: entry object) ]. 126692 126693 ! ! 126694 126695!FreeTypeCache methodsFor: 'add-remove' stamp: 'tween 8/10/2006 15:28'! 126696removeAllForType: typeFlag 126697 | toRemove d | 126698 126699 toRemove := IdentitySet new. 126700 fifo do:[:entry | 126701 entry type = typeFlag 126702 ifTrue:[toRemove add: entry]]. 126703 toRemove do:[:entry | 126704 fifo remove: entry. 126705 d := (fontTable at: entry font) at: entry charCode. 126706 d removeKey: entry type. 126707 used := used - (self sizeOf: entry object) ]. 126708 126709 ! ! 126710 126711 126712!FreeTypeCache methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:54'! 126713initialize 126714 super initialize. 126715 maximumSize := self class defaultMaximumSize. 126716 fontTable := self dictionaryClass new: 100. 126717 used := 0. 126718 fifo := self fifoClass new 126719 ! ! 126720 126721 126722!FreeTypeCache methodsFor: 'public' stamp: 'tween 8/10/2006 12:56'! 126723maximumSize: anIntegerOrNil 126724 126725 maximumSize := anIntegerOrNil. 126726 maximumSize ifNotNil:[ 126727 used > maximumSize 126728 ifTrue:["shrink" 126729 self shrinkTo: maximumSize]]! ! 126730 126731!FreeTypeCache methodsFor: 'public' stamp: 'tween 8/10/2006 13:46'! 126732report 126733 "answer a description of the current state of the cache" 126734 | usedPercent | 126735 usedPercent := maximumSize isNil 126736 ifTrue:[0] 126737 ifFalse:[(used * 100 / maximumSize) asFloat rounded]. 126738 ^usedPercent asString,'% Full (maximumSize: ', maximumSize asString, ' , used: ', used asString,')'! ! 126739 126740!FreeTypeCache methodsFor: 'public' stamp: 'tween 8/10/2006 15:14'! 126741sizeOf: anObject 126742 ^(anObject isKindOf: Form) 126743 ifTrue:[(anObject bitsSize * 4) + 32] 126744 ifFalse:[4] 126745 ! ! 126746 126747 126748!FreeTypeCache methodsFor: 'private' stamp: 'tween 8/10/2006 13:20'! 126749dictionaryClass 126750 ^Dictionary! ! 126751 126752!FreeTypeCache methodsFor: 'private' stamp: 'tween 8/10/2006 19:03'! 126753fifoClass 126754 ^FreeTypeCacheLinkedList! ! 126755 126756!FreeTypeCache methodsFor: 'private' stamp: 'tween 8/10/2006 13:22'! 126757fifoEntryClass 126758 ^FreeTypeCacheEntry! ! 126759 126760!FreeTypeCache methodsFor: 'private' stamp: 'tween 9/29/2007 20:10'! 126761shrinkTo: newSize 126762 "if the used size is greater than newSize, then remove all the receiver's entries" 126763 126764 used > newSize ifTrue:[self removeAll]! ! 126765 126766"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 126767 126768FreeTypeCache class 126769 instanceVariableNames: 'current'! 126770 126771!FreeTypeCache class methodsFor: 'accessing' stamp: 'tween 8/10/2006 15:33'! 126772clearCurrent 126773 " 126774 self clearCurrent. 126775 " 126776 current := nil! ! 126777 126778!FreeTypeCache class methodsFor: 'accessing' stamp: 'tween 8/10/2006 17:03'! 126779current 126780 current isNil ifFalse:[^current]. 126781 ^current := self new! ! 126782 126783!FreeTypeCache class methodsFor: 'accessing' stamp: 'tween 8/10/2006 09:30'! 126784defaultMaximumSize 126785 "answer the default maximumSize in bytes" 126786 ^1024*5000 "5 Megabytes"! ! 126787 126788!FreeTypeCache class methodsFor: 'accessing' stamp: 'tween 8/10/2006 15:45'! 126789initialize 126790 " 126791 self initialize. 126792 " 126793 126794 Smalltalk addToShutDownList: self. "should it be at a particular place in the list?"! ! 126795 126796!FreeTypeCache class methodsFor: 'accessing' stamp: 'tween 8/10/2006 15:45'! 126797shutDown: quitting 126798 126799 (current notNil and: [self clearCacheOnShutdown]) 126800 ifTrue:[self current removeAll]! ! 126801 126802 126803!FreeTypeCache class methodsFor: 'system shutdown' stamp: 'tween 8/10/2006 15:44'! 126804clearCacheOnShutdown 126805 "answer true if the cache should be cleared on image shutdown" 126806 126807 ^true! ! 126808SharedPool subclass: #FreeTypeCacheConstants 126809 instanceVariableNames: '' 126810 classVariableNames: 'FreeTypeCacheGlyph FreeTypeCacheGlyphLCD FreeTypeCacheGlyphMono FreeTypeCacheLinearWidth FreeTypeCacheWidth' 126811 poolDictionaries: '' 126812 category: 'FreeType-Cache'! 126813 126814"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 126815 126816FreeTypeCacheConstants class 126817 instanceVariableNames: ''! 126818 126819!FreeTypeCacheConstants class methodsFor: 'class initialization' stamp: 'tween 3/31/2007 21:31'! 126820initialize 126821 " 126822 FreeTypeCacheConstants initialize 126823 " 126824 126825 FreeTypeCacheWidth := 0. 126826 FreeTypeCacheGlyph := 100. "start at 100 and allow room for 64 subpixel positioned glyphs" 126827 FreeTypeCacheGlyphLCD := 200. "start at 200 and allow room for 64 subpixel positioned glyphs" 126828 FreeTypeCacheGlyphMono := 3. 126829 FreeTypeCacheLinearWidth := 4 126830 ! ! 126831Link subclass: #FreeTypeCacheEntry 126832 instanceVariableNames: 'font charCode type object previousLink' 126833 classVariableNames: '' 126834 poolDictionaries: '' 126835 category: 'FreeType-Cache'! 126836 126837!FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 13:16'! 126838charCode 126839 "Answer the value of charCode" 126840 126841 ^ charCode! ! 126842 126843!FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 13:16'! 126844charCode: anObject 126845 "Set the value of charCode" 126846 126847 charCode := anObject! ! 126848 126849!FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 13:16'! 126850font 126851 "Answer the value of font" 126852 126853 ^ font! ! 126854 126855!FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 13:16'! 126856font: anObject 126857 "Set the value of font" 126858 126859 font := anObject! ! 126860 126861!FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 14:55'! 126862object 126863 "Answer the value of object" 126864 126865 ^ object! ! 126866 126867!FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 14:55'! 126868object: anObject 126869 "Set the value of object" 126870 126871 object := anObject! ! 126872 126873!FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 17:56'! 126874previousLink 126875 "Answer the value of previousLink" 126876 126877 ^ previousLink! ! 126878 126879!FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 17:56'! 126880previousLink: anObject 126881 "Set the value of previousLink" 126882 126883 previousLink := anObject! ! 126884 126885!FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 13:16'! 126886type 126887 "Answer the value of type" 126888 126889 ^ type! ! 126890 126891!FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 13:16'! 126892type: anObject 126893 "Set the value of type" 126894 126895 type := anObject! ! 126896 126897 126898!FreeTypeCacheEntry methodsFor: 'comparing' stamp: 'tween 8/10/2006 14:58'! 126899= aFreeTypeCacheEntry 126900 "equailty based on font,charcode, type, object, but not nextLink" 126901 126902 (aFreeTypeCacheEntry isKindOf: FreeTypeCacheEntry) 126903 ifFalse:[^false]. 126904 ^font = aFreeTypeCacheEntry font and: [ 126905 charCode = aFreeTypeCacheEntry charCode 126906 and: [type = aFreeTypeCacheEntry type 126907 and:[object = aFreeTypeCacheEntry object]]]! ! 126908 126909!FreeTypeCacheEntry methodsFor: 'comparing' stamp: 'tween 8/10/2006 13:34'! 126910hash 126911 ^charCode hash! ! 126912LinkedList subclass: #FreeTypeCacheLinkedList 126913 instanceVariableNames: '' 126914 classVariableNames: '' 126915 poolDictionaries: '' 126916 category: 'FreeType-Cache'! 126917 126918!FreeTypeCacheLinkedList methodsFor: 'adding' stamp: 'tween 8/10/2006 18:47'! 126919add: link after: otherLink 126920 "Add otherLink after link in the list. Answer aLink." 126921 126922 | savedLink | 126923 126924 savedLink := otherLink nextLink. 126925 otherLink nextLink: link. 126926 link nextLink: savedLink. 126927 savedLink == nil ifFalse:[savedLink previousLink: link]. 126928 link previousLink: otherLink. 126929 ^link. 126930 126931 ! ! 126932 126933!FreeTypeCacheLinkedList methodsFor: 'adding' stamp: 'tween 8/10/2006 18:47'! 126934add: link before: otherLink 126935 | savedLink | 126936 firstLink == otherLink ifTrue: [^ self addFirst: link]. 126937 otherLink 126938 ifNotNil:[ 126939 savedLink := otherLink previousLink. 126940 link nextLink: otherLink. 126941 link previousLink: savedLink. 126942 otherLink previousLink: link. 126943 savedLink == nil ifFalse:[savedLink nextLink: link]]. 126944 ^ self errorNotFound: otherLink! ! 126945 126946!FreeTypeCacheLinkedList methodsFor: 'adding' stamp: 'tween 8/10/2006 18:52'! 126947addFirst: aLink 126948 "Add aLink to the beginning of the receiver's list. Answer aLink." 126949 126950 self isEmpty 126951 ifTrue: [^lastLink :=firstLink := aLink]. 126952 aLink nextLink: firstLink. 126953 aLink previousLink: nil. 126954 firstLink == nil ifFalse: [firstLink previousLink: aLink]. 126955 firstLink := aLink. 126956 ^aLink! ! 126957 126958!FreeTypeCacheLinkedList methodsFor: 'adding' stamp: 'tween 8/10/2006 18:52'! 126959addLast: aLink 126960 "Add aLink to the end of the receiver's list. Answer aLink." 126961 126962 self isEmpty 126963 ifTrue: [^firstLink := lastLink := aLink]. 126964 aLink previousLink: lastLink. 126965 aLink nextLink: nil. 126966 lastLink == nil ifFalse: [lastLink nextLink: aLink]. 126967 lastLink := aLink. 126968 ^aLink! ! 126969 126970 126971!FreeTypeCacheLinkedList methodsFor: 'removing' stamp: 'tween 8/10/2006 18:48'! 126972remove: aLink ifAbsent: aBlock 126973 | prev next | 126974 126975 prev := aLink previousLink. 126976 next := aLink nextLink. 126977 prev == nil ifFalse: [prev nextLink: next]. 126978 next == nil ifFalse: [next previousLink: prev]. 126979 aLink == firstLink ifTrue:[firstLink := next]. 126980 aLink == lastLink ifTrue:[lastLink := prev]. 126981 aLink nextLink: nil. 126982 aLink previousLink: nil. 126983 ^aLink! ! 126984 126985!FreeTypeCacheLinkedList methodsFor: 'removing' stamp: 'tween 8/10/2006 21:06'! 126986removeFirst 126987 "Remove the first element and answer it. If the receiver is empty, create 126988 an error notification." 126989 126990 | oldLink | 126991 self emptyCheck. 126992 oldLink := firstLink. 126993 oldLink previousLink: nil. 126994 lastLink == firstLink 126995 ifTrue:[ 126996 lastLink := firstLink := nil. 126997 oldLink nextLink: nil. 126998 ^oldLink]. 126999 firstLink := oldLink nextLink. 127000 firstLink == nil 127001 ifTrue:[firstLink := lastLink := nil] 127002 ifFalse:[firstLink previousLink: nil]. 127003 oldLink nextLink: nil. 127004 ^oldLink! ! 127005 127006!FreeTypeCacheLinkedList methodsFor: 'removing' stamp: 'tween 8/10/2006 21:09'! 127007removeLast 127008 "Remove the first element and answer it. If the receiver is empty, create 127009 an error notification." 127010 127011 | oldLink | 127012 self emptyCheck. 127013 oldLink := lastLink. 127014 oldLink nextLink: nil. 127015 lastLink == firstLink 127016 ifTrue:[ 127017 lastLink := firstLink := nil. 127018 oldLink previousLink: nil. 127019 ^oldLink]. 127020 lastLink := oldLink previousLink. 127021 lastLink == nil 127022 ifTrue:[firstLink := lastLink := nil] 127023 ifFalse:[lastLink nextLink: nil]. 127024 oldLink previousLink: nil. 127025 ^oldLink! ! 127026 127027 127028!FreeTypeCacheLinkedList methodsFor: 'reordering' stamp: 'tween 3/31/2007 12:31'! 127029moveDown: aLink 127030 | e1 e2 e3 e4 | 127031 127032 (e3 := aLink nextLink) ifNil:[^self]. 127033 e2 := aLink. 127034 e4 := e3 nextLink. 127035 e1 := e2 previousLink. 127036 "swap e2 & e3" 127037 e1 ifNotNil:[e1 nextLink: e2]. 127038 e2 nextLink: e3. 127039 e3 nextLink: e4. 127040 e4 ifNotNil:[e4 previousLink: e3]. 127041 e3 previousLink: e2. 127042 e2 previousLink: e1 127043 127044 ! ! 127045TestCase subclass: #FreeTypeCacheTest 127046 instanceVariableNames: 'cache cache1K fullCache font1 font1XGlyph font1ZGlyph font1YGlyph font2 font3' 127047 classVariableNames: '' 127048 poolDictionaries: 'FreeTypeCacheConstants' 127049 category: 'FreeTypeTests-cache'! 127050 127051!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 3/23/2007 08:07'! 127052setUp 127053 127054 cache := FreeTypeCache new. 127055 font1 := FreeTypeFont basicNew. 127056 font2 := FreeTypeFont basicNew. 127057 font3 := FreeTypeFont basicNew. 127058 font1XGlyph := (GlyphForm extent: 100@100 depth: 32) 127059 advance: 100; 127060 linearAdvance: 10000; 127061 yourself. 127062 font1YGlyph := (GlyphForm extent: 100@100 depth: 32) 127063 advance: 100; 127064 linearAdvance: 10000; 127065 yourself. 127066 font1ZGlyph := (GlyphForm extent: 100@100 depth: 32) 127067 advance: 100; 127068 linearAdvance: 10000; 127069 yourself. 127070 fullCache := FreeTypeCache new. 127071 fullCache 127072 maximumSize: (10*(fullCache sizeOf: font1YGlyph)).. 127073 1 to: 10 do:[:i | 127074 fullCache atFont: font1 charCode: i type: FreeTypeCacheGlyph put: font1YGlyph]. ! ! 127075 127076!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 10:29'! 127077testConstants 127078 127079 | constants | 127080 constants := {FreeTypeCacheWidth. FreeTypeCacheGlyphMono. FreeTypeCacheGlyphLCD.FreeTypeCacheGlyph}. 127081 self assert: constants asSet size = constants size. "no 2 have same value" 127082 self assert: (constants detect:[:x | x isNil] ifNone:[]) isNil. "no value is nil" 127083 127084 ! ! 127085 127086!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 9/29/2007 20:02'! 127087testEntriesRemovedFIFO 127088 | | 127089 cache maximumSize: 10*(cache sizeOf: font1XGlyph). 127090 1 to: 10 do:[:i | 127091 cache 127092 atFont: font1 127093 charCode: (1000-i) 127094 type: FreeTypeCacheGlyph 127095 put: font1XGlyph]. 127096 self validateCollections: cache. 127097 11 to:1000 do:[:i | 127098 cache 127099 atFont: font1 127100 charCode: (1000-i) 127101 type: FreeTypeCacheGlyph 127102 put: font1XGlyph. 127103 self validateSizes: cache. 127104 self validateCollections: cache. 127105 "i-9 to: i do:[:i2 | 127106 self 127107 shouldnt: [cache atFont: font1 charCode: 1000-i2 type: FreeTypeCacheGlyph] 127108 raise: Error]." 127109 self 127110 should: [cache atFont: font1 charCode: 1000-(i-10) type: FreeTypeCacheGlyph] 127111 raise: Error]. 127112 self validateSizes: cache. 127113 127114 ! ! 127115 127116!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 11:19'! 127117testFailedGet 127118 | | 127119 127120 self 127121 should: [cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph] 127122 raise: Error. 127123 self assert: (cache instVarNamed: #fontTable) isEmpty. 127124 self assert: (cache instVarNamed: #used) = 0. 127125 self validateSizes: cache 127126 ! ! 127127 127128!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 14:57'! 127129testFreeTypeCacheEntry 127130 | f f2 f3 | 127131 f := FreeTypeCacheEntry new. 127132 f charCode: 1; font: font1; type: FreeTypeCacheGlyph; object: font1XGlyph. 127133 f2 := FreeTypeCacheEntry new. 127134 f2 charCode: 2; font: font1; type: FreeTypeCacheGlyphLCD; object: font1XGlyph. 127135 f nextLink: f2. 127136 self assert: f ~= f2. 127137 self assert: f nextLink = f2 . 127138 127139 f3 := f copy. 127140 f3 nextLink: nil. 127141 self assert: f = f3. "equality not based on nextLink"! ! 127142 127143!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 13:41'! 127144testInstanceInitialization 127145 self assert: (cache instVarNamed: #maximumSize) = FreeTypeCache defaultMaximumSize. 127146 self assert: (cache instVarNamed: #used) = 0. 127147 self assert: (cache instVarNamed: #fontTable) class = cache dictionaryClass. 127148 self assert: (cache instVarNamed: #fontTable) isEmpty. 127149 self assert: (cache instVarNamed: #fifo) class = cache fifoClass. 127150 self assert: (cache instVarNamed: #fifo) isEmpty. 127151 ! ! 127152 127153!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 9/29/2007 20:05'! 127154testMaximumSizeRespectedOnIfAbsentPut 127155 | | 127156 cache maximumSize: (cache sizeOf: font1XGlyph). 127157 cache 127158 atFont: font1 127159 charCode: $X asInteger 127160 type: FreeTypeCacheGlyph 127161 ifAbsentPut: font1XGlyph. 127162 self validateSizes: cache. 127163 self validateCollections: cache. 127164 cache 127165 atFont: font1 127166 charCode: $Y asInteger 127167 type: FreeTypeCacheGlyph 127168 ifAbsentPut: font1XGlyph. 127169 self assert: (cache instVarNamed:#used) = 0. "cache has been cleared on reaching max size" 127170 self validateSizes: cache. 127171 self validateCollections: cache. 127172 self 127173 should: [cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph] 127174 raise: Error. 127175 self 127176 should: [cache atFont: font1 charCode: $Y asInteger type: FreeTypeCacheGlyph] 127177 raise: Error. 127178 ! ! 127179 127180!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 9/29/2007 20:06'! 127181testMaximumSizeRespectedOnPut 127182 | | 127183 cache maximumSize: (cache sizeOf: font1XGlyph). 127184 cache 127185 atFont: font1 127186 charCode: $X asInteger 127187 type: FreeTypeCacheGlyph 127188 put: font1XGlyph. 127189 self validateSizes: cache. 127190 self validateCollections: cache. 127191 cache 127192 atFont: font1 127193 charCode: $Y asInteger 127194 type: FreeTypeCacheGlyph 127195 put: font1XGlyph. 127196 self assert: (cache instVarNamed:#used) = 0. "cache has been cleared on reaching max size" 127197 self validateSizes: cache. 127198 self validateCollections: cache. 127199 self 127200 should: [cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph] 127201 raise: Error. 127202 self 127203 should: [cache atFont: font1 charCode: $Y asInteger type: FreeTypeCacheGlyph] 127204 raise: Error. 127205 ! ! 127206 127207!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 15:52'! 127208testNormalGetIfAbsentPut 127209 | u g r | 127210 cache maximumSize: nil. 127211 u := cache instVarNamed: #used. 127212 r := cache 127213 atFont: font1 127214 charCode: $X asInteger 127215 type: FreeTypeCacheGlyph 127216 ifAbsentPut: [font1XGlyph]. 127217 self assert: (r isKindOf: GlyphForm). 127218 self assert: (cache instVarNamed: #used) > u. "grown" 127219 self validateSizes: cache. 127220 g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph. 127221 self assert: g == font1XGlyph. 127222 self validateSizes: cache. 127223 self validateCollections: cache 127224 ! ! 127225 127226!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 3/31/2007 12:26'! 127227testNormalGetIfAbsentPutTwice 127228 | u g r | 127229 cache maximumSize: nil. 127230 u := cache instVarNamed: #used. 127231 r := cache 127232 atFont: font1 127233 charCode: $X asInteger 127234 type: FreeTypeCacheGlyph 127235 ifAbsentPut: [font1XGlyph]. 127236 r := cache 127237 atFont: font1 127238 charCode: $X asInteger 127239 type: FreeTypeCacheGlyph 127240 ifAbsentPut: [font1XGlyph]. 127241 self assert: (r isKindOf: GlyphForm). 127242 self assert: (cache instVarNamed: #used) > u. "grown" 127243 self validateSizes: cache. 127244 g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph. 127245 self assert: g == font1XGlyph. 127246 self validateSizes: cache. 127247 self validateCollections: cache 127248 ! ! 127249 127250!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 3/31/2007 12:26'! 127251testNormalGetIfAbsentPutTwiceIntoNonEmptyCache 127252 | u g r | 127253 cache maximumSize: nil. 127254 u := cache instVarNamed: #used. 127255 r := cache 127256 atFont: font1 127257 charCode: $Z asInteger 127258 type: FreeTypeCacheGlyph 127259 ifAbsentPut: [font1XGlyph]. 127260 r := cache 127261 atFont: font1 127262 charCode: $X asInteger 127263 type: FreeTypeCacheGlyph 127264 ifAbsentPut: [font1XGlyph]. 127265 r := cache 127266 atFont: font1 127267 charCode: $X asInteger 127268 type: FreeTypeCacheGlyph 127269 ifAbsentPut: [font1XGlyph]. 127270 self assert: (r isKindOf: GlyphForm). 127271 self assert: (cache instVarNamed: #used) > u. "grown" 127272 self validateSizes: cache. 127273 g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph. 127274 self assert: g == font1XGlyph. 127275 self validateSizes: cache. 127276 self validateCollections: cache 127277 ! ! 127278 127279!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 12:47'! 127280testNormalPutGet 127281 | u g | 127282 cache maximumSize: nil. 127283 u := cache instVarNamed: #used. 127284 cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph put: font1XGlyph. 127285 self assert: (cache instVarNamed: #used) > u. "grown" 127286 self validateSizes: cache. 127287 g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph. 127288 self assert: g == font1XGlyph. 127289 self validateSizes: cache. 127290 self validateCollections: cache 127291 ! ! 127292 127293!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 3/31/2007 12:21'! 127294testNormalPutGetTwice 127295 | u g | 127296 cache maximumSize: nil. 127297 u := cache instVarNamed: #used. 127298 cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph put: font1XGlyph. 127299 self assert: (cache instVarNamed: #used) > u. "grown" 127300 self validateSizes: cache. 127301 g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph. 127302 g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph. 127303 self assert: g == font1XGlyph. 127304 self validateSizes: cache. 127305 self validateCollections: cache 127306 ! ! 127307 127308!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 15:12'! 127309testNormalPutGetWidth 127310 | u g | 127311 cache maximumSize: nil. 127312 u := cache instVarNamed: #used. 127313 cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheWidth put: 100. 127314 self assert: (cache instVarNamed: #used) > u. "grown" 127315 self validateSizes: cache. 127316 g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheWidth. 127317 self assert: g = 100. 127318 self validateSizes: cache. 127319 self validateCollections: cache 127320 ! ! 127321 127322!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 14:41'! 127323testPutSameElementTwice 127324 | | 127325 cache maximumSize: nil. 127326 cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph put: font1XGlyph. 127327 self assert: (cache instVarNamed: #used) = (cache sizeOf: font1XGlyph). 127328 self validateSizes: cache. 127329 self validateCollections: cache. 127330 cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph put: font1XGlyph. 127331 self assert: (cache instVarNamed: #used) = (cache sizeOf: font1XGlyph). 127332 self validateSizes: cache. 127333 self validateCollections: cache 127334 ! ! 127335 127336!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 13:05'! 127337testRemoveAll 127338 | m fifo fontTable | 127339 m := fullCache instVarNamed: #maximumSize. 127340 fifo := fullCache instVarNamed: #fifo. 127341 fontTable := fullCache instVarNamed: #fontTable. 127342 fullCache removeAll. 127343 self assert: (fullCache instVarNamed: #fifo) isEmpty. 127344 self assert: (fullCache instVarNamed: #fontTable) isEmpty. 127345 self assert: (fullCache instVarNamed: #used) = 0. 127346 self assert: m = (fullCache instVarNamed: #maximumSize). 127347 self assert: fifo class = (fullCache instVarNamed: #fifo) class. 127348 self assert: fontTable class = (fullCache instVarNamed: #fontTable) class. ! ! 127349 127350!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 14:21'! 127351testRemoveAllForFont 127352 | fifo | 127353 127354 fullCache maximumSize: nil. 127355 1 to: 100 do:[:i | 127356 fullCache atFont: font1 charCode: i type: 1 put: font1XGlyph]. 127357 1 to: 100 do:[:i | 127358 fullCache atFont: font2 charCode: i type: 2 put: font1YGlyph]. 127359 1 to: 100 do:[:i | 127360 fullCache atFont: font3 charCode: i type: 3 put: font1ZGlyph]. 127361 fifo := fullCache instVarNamed: #fifo. 127362 self assert: (fifo detect:[:each | each font = font1] ifNone:[]) notNil. 127363 self assert: (fifo detect:[:each | each font = font2] ifNone:[]) notNil. 127364 self assert: (fifo detect:[:each | each font = font3] ifNone:[]) notNil. 127365 fullCache removeAllForFont: font1. 127366 self validateSizes: fullCache. 127367 self validateCollections: fullCache. 127368 fifo := (fullCache instVarNamed: #fifo). 127369 self assert: (fifo detect:[:each | each font = font1] ifNone:[]) isNil. 127370 self assert: (fifo detect:[:each | each font = font2] ifNone:[]) notNil. 127371 self assert: (fifo detect:[:each | each font = font2] ifNone:[]) notNil. 127372 ! ! 127373 127374!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 15:29'! 127375testRemoveAllForType 127376 | fifo | 127377 127378 fullCache maximumSize: nil. 127379 1 to: 100 do:[:i | 127380 fullCache atFont: font1 charCode: i type: 1 put: font1XGlyph]. 127381 1 to: 100 do:[:i | 127382 fullCache atFont: font2 charCode: i type: 2 put: font1YGlyph]. 127383 1 to: 100 do:[:i | 127384 fullCache atFont: font3 charCode: i type: 3 put: font1ZGlyph]. 127385 fifo := fullCache instVarNamed: #fifo. 127386 self assert: (fifo detect:[:each | each type = 1] ifNone:[]) notNil. 127387 self assert: (fifo detect:[:each | each type = 2] ifNone:[]) notNil. 127388 self assert: (fifo detect:[:each | each type = 3] ifNone:[]) notNil. 127389 fullCache removeAllForType: 1. 127390 self validateSizes: fullCache. 127391 self validateCollections: fullCache. 127392 fifo := (fullCache instVarNamed: #fifo). 127393 self assert: (fifo detect:[:each | each type = 1] ifNone:[]) isNil. 127394 self assert: (fifo detect:[:each | each type = 2] ifNone:[]) notNil. 127395 self assert: (fifo detect:[:each | each type = 3] ifNone:[]) notNil. 127396 ! ! 127397 127398!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 13:52'! 127399testReport 127400 self assert: fullCache report = '100% Full (maximumSize: 400320 , used: 400320)'. 127401 fullCache maximumSize: 800640. 127402 self assert: fullCache report = '50% Full (maximumSize: 800640 , used: 400320)'. 127403 self assert: cache report = '0% Full (maximumSize: 5120000 , used: 0)'. 127404 cache maximumSize: nil. 127405 self assert: cache report = '0% Full (maximumSize: nil , used: 0)'. ! ! 127406 127407!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 12:48'! 127408testSetMaximumSize 127409 127410 cache maximumSize: 0. 127411 self assert: (cache instVarNamed: #maximumSize) = 0. 127412 cache maximumSize: 99999999999999999. 127413 self assert: (cache instVarNamed: #maximumSize) = 99999999999999999. 127414 cache maximumSize: nil. "unbounded" 127415 self assert: (cache instVarNamed: #maximumSize) = nil. 127416 self validateSizes: cache. 127417 self validateCollections: cache 127418! ! 127419 127420!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 12:48'! 127421testSetMaximumSizeGrow 127422 | u m | 127423 127424 u := fullCache instVarNamed: #used. 127425 m := fullCache instVarNamed: #maximumSize. 127426 fullCache maximumSize: m * 2 . "grow" 127427 self assert: u = (fullCache instVarNamed: #used). 127428 self validateSizes: cache. 127429 self validateCollections: cache! ! 127430 127431!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 9/29/2007 20:07'! 127432testSetMaximumSizeShrink 127433 | m | 127434 127435 m := fullCache instVarNamed: #maximumSize. 127436 fullCache maximumSize: m // 2 . "shrink" 127437 self assert: (fullCache instVarNamed: #used) = 0. "cache is cleared when used > maximumSize" 127438 self validateSizes: fullCache. 127439 self validateCollections: fullCache. 127440 127441 ! ! 127442 127443!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 12:48'! 127444testSetMaximumSizeUnbounded 127445 127446 | u | 127447 u := fullCache instVarNamed: #used. 127448 fullCache maximumSize: nil. "unbounded" 127449 self assert: u = (fullCache instVarNamed: #used). 127450 self validateSizes: cache. 127451 self validateCollections: cache 127452! ! 127453 127454!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 09:24'! 127455testSingleton 127456 self assert: FreeTypeCache current class = FreeTypeCache. 127457 self assert: FreeTypeCache current == FreeTypeCache current. 127458 ! ! 127459 127460!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 3/31/2007 12:12'! 127461validateCollections: aFreeTypeCache 127462 "check that the fifo list entries match the fontTable dict hierarchy" 127463 | fontTable fontTableEntries fifo lastLink | 127464 fontTable := aFreeTypeCache instVarNamed: #fontTable. 127465 fifo := aFreeTypeCache instVarNamed: #fifo. 127466 lastLink := (fifo instVarNamed:#lastLink). 127467 fontTableEntries := Set new. 127468 fontTable keysAndValuesDo:[:k1 :v1 | 127469 v1 keysAndValuesDo:[:k2 :v2 | 127470 v2 keysAndValuesDo:[:k3 :v3 | 127471 fontTableEntries add: v3 ]]]. 127472 self assert: fifo size = fontTableEntries size. 127473 self assert: (fifo asSet = fontTableEntries). 127474 self assert: (lastLink isNil or:[lastLink nextLink isNil]) 127475 127476 127477 ! ! 127478 127479!FreeTypeCacheTest methodsFor: 'as yet unclassified' stamp: 'tween 8/10/2006 15:04'! 127480validateSizes: aFreeTypeCache 127481 "check that the used, maximumSize, and caches entries are valid" 127482 | fontTable calcSize max used | 127483 fontTable := aFreeTypeCache instVarNamed: #fontTable. 127484 used := aFreeTypeCache instVarNamed: #used. 127485 max := aFreeTypeCache instVarNamed: #maximumSize. 127486 calcSize := 0. 127487 fontTable do:[:charCodeTable | 127488 charCodeTable do:[:typeTable | 127489 typeTable do:[:entry | 127490 calcSize := calcSize + (aFreeTypeCache sizeOf: entry object)]]]. 127491 self assert: calcSize = used. 127492 self assert: (max isNil or:[used <= max]) 127493 ! ! 127494FreeTypeFileInfoAbstract subclass: #FreeTypeEmbeddedFileInfo 127495 instanceVariableNames: 'fileContents baseName' 127496 classVariableNames: '' 127497 poolDictionaries: '' 127498 category: 'FreeType-FontManager'! 127499 127500!FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:21'! 127501baseName 127502 "Answer the value of baseName" 127503 127504 ^ baseName! ! 127505 127506!FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:19'! 127507baseName: anObject 127508 "Set the value of baseName" 127509 127510 baseName := anObject! ! 127511 127512!FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 9/29/2007 08:21'! 127513familyGroupName 127514 127515 ^familyGroupName 127516 ! ! 127517 127518!FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:19'! 127519fileContents 127520 "Answer the value of fileContents" 127521 127522 ^ fileContents! ! 127523 127524!FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:19'! 127525fileContents: anObject 127526 "Set the value of fileContents" 127527 127528 fileContents := anObject! ! 127529 127530!FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/28/2007 12:43'! 127531fileSize 127532 ^fileContents size! ! 127533 127534!FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:16'! 127535locationType 127536 "Answer the value of locationType" 127537 127538 ^ #embedded! ! 127539 127540 127541!FreeTypeEmbeddedFileInfo methodsFor: 'printing' stamp: 'tween 8/16/2007 01:08'! 127542printOn: aStream 127543 "super printOn: aStream." 127544 aStream 127545 nextPutAll: '{', self locationType asString,'}'; 127546 nextPutAll: '(' , fileContents size asString, ' bytes )'; 127547 nextPutAll: '[',index asString,'] '; 127548 nextPutAll: familyName asString; 127549 nextPutAll: ' - ', styleName asString; 127550 nextPutAll: ' - ', postscriptName asString; 127551 nextPutAll: ' ',(bold ifTrue:['B'] ifFalse:['']); 127552 nextPutAll: ' ',(italic ifTrue:['I'] ifFalse:['']); 127553 nextPutAll: ' ',(fixedWidth ifTrue:['Monospaced'] ifFalse:['']); 127554 nextPutAll: ' ',(stretchValue asString); 127555 nextPutAll: ' ',(weightValue asString); 127556 cr! ! 127557 127558 127559!FreeTypeEmbeddedFileInfo methodsFor: 'testing' stamp: 'tween 7/16/2007 00:31'! 127560isEmbedded 127561 ^true! ! 127562FT2Handle subclass: #FreeTypeExternalMemory 127563 instanceVariableNames: 'bytes' 127564 classVariableNames: '' 127565 poolDictionaries: '' 127566 category: 'FreeType-Base'! 127567 127568!FreeTypeExternalMemory methodsFor: 'accessing' stamp: 'tween 8/12/2006 08:40'! 127569bytes 127570 ^bytes! ! 127571 127572!FreeTypeExternalMemory methodsFor: 'accessing' stamp: 'tween 8/12/2006 08:40'! 127573bytes: aByteArray 127574 bytes := aByteArray! ! 127575 127576 127577!FreeTypeExternalMemory methodsFor: 'primitives' stamp: 'tween 8/12/2006 10:25'! 127578primCopyToExternalMemory: aByteArray 127579 "copy aByteArray into newly allocated, external memory, and store the 127580 address of that memory in the receiver's handle" 127581 <primitive: 'primitiveCopyToExternalMemory' module: 'FT2Plugin'> 127582 ^self primitiveFailed! ! 127583 127584!FreeTypeExternalMemory methodsFor: 'primitives' stamp: 'tween 8/12/2006 10:24'! 127585primDestroyHandle 127586 <primitive: 'primitiveFreeExternalMemory' module: 'FT2Plugin'> 127587 ^self primitiveFailed! ! 127588 127589 127590!FreeTypeExternalMemory methodsFor: 'validation' stamp: 'tween 8/12/2006 10:25'! 127591validate 127592 self isValid 127593 ifFalse: [ 127594 bytes ifNotNil:[ 127595 [self primCopyToExternalMemory: bytes] 127596 on: FT2Error 127597 do:[:e |"need to do something here?"]. 127598 self isValid ifTrue:[self class register: self]]]! ! 127599 127600"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 127601 127602FreeTypeExternalMemory class 127603 instanceVariableNames: ''! 127604 127605!FreeTypeExternalMemory class methodsFor: 'instance creation' stamp: 'tween 8/12/2006 08:42'! 127606bytes: aByteArray 127607 | answer | 127608 answer := self basicNew 127609 bytes: aByteArray; 127610 yourself. 127611 ^answer! ! 127612FT2Face subclass: #FreeTypeFace 127613 instanceVariableNames: 'filename index fileContentsExternalMemory valid hasKerning' 127614 classVariableNames: '' 127615 poolDictionaries: '' 127616 category: 'FreeType-Fonts'! 127617 127618!FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! 127619familyName 127620 ^super familyName ifNil:['?']! ! 127621 127622!FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! 127623fileContentsExternalMemory: aFreeTypeExternalMemory 127624 fileContentsExternalMemory := aFreeTypeExternalMemory! ! 127625 127626!FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! 127627fileContentsExternalMemoryBytes 127628 ^fileContentsExternalMemory ifNotNil:[fileContentsExternalMemory bytes]! ! 127629 127630!FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! 127631filename 127632 ^filename! ! 127633 127634!FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! 127635filename: aString 127636 filename := aString! ! 127637 127638!FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! 127639index 127640 ^index! ! 127641 127642!FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! 127643index: anInteger 127644 index := anInteger! ! 127645 127646!FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! 127647styleName 127648 ^super styleName ifNil:['']! ! 127649 127650 127651!FreeTypeFace methodsFor: 'caching' stamp: 'tween 3/31/2007 16:36'! 127652releaseCachedState 127653 127654 hasKerning := nil. 127655 self destroyHandle. 127656! ! 127657 127658 127659!FreeTypeFace methodsFor: 'initialize-release' stamp: 'tween 3/16/2007 12:44'! 127660actAsExecutor 127661 super actAsExecutor. 127662 filename := '<finalizer>'.! ! 127663 127664!FreeTypeFace methodsFor: 'initialize-release' stamp: 'tween 3/16/2007 12:53'! 127665beNull 127666 super beNull. 127667 valid := nil 127668 ! ! 127669 127670 127671!FreeTypeFace methodsFor: 'testing' stamp: 'tween 3/16/2007 12:44'! 127672hasFamilyName 127673 ^super familyName notNil! ! 127674 127675!FreeTypeFace methodsFor: 'testing' stamp: 'tween 3/31/2007 14:52'! 127676hasKerning 127677 ^hasKerning ifNil:[ 127678 [hasKerning := self primHasKerning = 64] 127679 on: Error do:[:e | hasKerning := false]. 127680 hasKerning]! ! 127681 127682!FreeTypeFace methodsFor: 'testing' stamp: 'tween 3/16/2007 12:44'! 127683hasStyleName 127684 ^super styleName notNil! ! 127685 127686!FreeTypeFace methodsFor: 'testing' stamp: 'tween 3/31/2007 16:18'! 127687isValid 127688 ^valid ifNil:[valid := super isValid]! ! 127689 127690 127691!FreeTypeFace methodsFor: 'validation' stamp: 'tween 3/16/2007 12:44'! 127692create 127693 "create me in the FT2Plugin. This gets my handle, and loads the fields" 127694 127695 fileContentsExternalMemory isNil 127696 ifTrue:[ 127697 self 127698 newFaceFromFile: (self class fontPathFor: filename) 127699 index: index] 127700 ifFalse:[ 127701 self newFaceFromExternalMemory: fileContentsExternalMemory index: index]. 127702 self loadFields 127703! ! 127704 127705!FreeTypeFace methodsFor: 'validation' stamp: 'tween 3/17/2007 12:21'! 127706newFaceFromExternalMemory: aFreeTypeExternalMemory index: anInteger 127707 | answer | 127708 valid := nil. 127709 answer := super newFaceFromExternalMemory: aFreeTypeExternalMemory index: anInteger. 127710 valid := super isValid. 127711 ^answer 127712 ! ! 127713 127714!FreeTypeFace methodsFor: 'validation' stamp: 'tween 3/17/2007 12:19'! 127715newFaceFromFile: fileName index: anInteger 127716 | answer | 127717 valid := nil. 127718 answer := super newFaceFromFile: fileName index: anInteger. 127719 valid := super isValid. 127720 ^answer 127721 ! ! 127722 127723!FreeTypeFace methodsFor: 'validation' stamp: 'tween 3/16/2007 12:44'! 127724primNewFaceFromExternalMemory: aFreeTypeExternalMemory size: anInteger index: anInteger2 127725 <primitive: 'primitiveNewMemoryFaceFromExternalMemoryAndIndex' module: 'FT2Plugin'> 127726 ^self primitiveFailed! ! 127727 127728!FreeTypeFace methodsFor: 'validation' stamp: 'tween 3/16/2007 12:44'! 127729validate 127730 "If the receiver is not valid (has a nil handle), then create the 127731 receiver to obtain a handle and load the receiver's fields" 127732 127733 self isValid ifFalse: [self create]! ! 127734 127735"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 127736 127737FreeTypeFace class 127738 instanceVariableNames: ''! 127739 127740!FreeTypeFace class methodsFor: 'font dirs' stamp: 'tween 3/16/2007 12:44'! 127741fontPathFor: aFilename 127742 "aFilename is local. Try hard to return a valid path to be handed to freetype library" 127743 127744 "temporary solution ;-)" 127745 ^(FileDirectory default 127746 directoryNamed: 'Fonts') 127747 fullPathFor: aFilename! ! 127748 127749!FreeTypeFace class methodsFor: 'font dirs' stamp: 'tween 3/16/2007 12:44'! 127750rememberFontDir: aDirecory! ! 127751 127752 127753!FreeTypeFace class methodsFor: 'instance creation' stamp: 'tween 3/16/2007 12:44'! 127754fromBytes: aByteArray index: anInteger 127755 "share alike instances" 127756 127757 self allInstancesDo: [:inst | 127758 (inst fileContentsExternalMemoryBytes = aByteArray and: [inst index = anInteger]) 127759 ifTrue: [^inst "validate"]]. 127760 ^(self basicNew) 127761 fileContentsExternalMemory: (FreeTypeExternalMemory bytes: aByteArray); 127762 index: anInteger; 127763 yourself! ! 127764 127765!FreeTypeFace class methodsFor: 'instance creation' stamp: 'tween 3/16/2007 12:44'! 127766fromFile: aFileName index: anInteger 127767 "share alike instances" 127768 ^FileDirectory splitName: aFileName to: [:dir :fname | 127769 self rememberFontDir: dir. 127770 self allInstancesDo: [:inst | 127771 (inst filename = aFileName and: [inst index = anInteger]) 127772 ifTrue: [^inst "validate"]]. 127773 (self basicNew) 127774 filename: aFileName; 127775 index: anInteger; 127776 yourself]! ! 127777FreeTypeFileInfoAbstract subclass: #FreeTypeFileInfo 127778 instanceVariableNames: 'absoluteOrRelativePath absolutePath locationType modificationTime fileSize' 127779 classVariableNames: '' 127780 poolDictionaries: '' 127781 category: 'FreeType-FontManager'! 127782 127783!FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/15/2007 18:29'! 127784absoluteOrRelativePath 127785 "Answer the value of absoluteOrRelativePath" 127786 127787 ^ absoluteOrRelativePath! ! 127788 127789!FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/15/2007 18:29'! 127790absoluteOrRelativePath: anObject 127791 "Set the value of absoluteOrRelativePath" 127792 127793 absoluteOrRelativePath := anObject! ! 127794 127795!FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 04:26'! 127796absolutePath 127797 "Answer the value of absolutePath" 127798 127799 ^ absolutePath! ! 127800 127801!FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 04:26'! 127802absolutePath: anObject 127803 "Set the value of absolutePath" 127804 127805 absolutePath := anObject! ! 127806 127807!FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 8/12/2007 16:53'! 127808baseName 127809 ^(FileDirectory baseNameFor: (FileDirectory localNameFor: absolutePath))! ! 127810 127811!FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 9/29/2007 08:22'! 127812familyGroupName 127813 127814 ^familyGroupName! ! 127815 127816!FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 00:55'! 127817fileSize 127818 "Answer the value of fileSize" 127819 127820 ^ fileSize! ! 127821 127822!FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 00:55'! 127823fileSize: anObject 127824 "Set the value of fileSize" 127825 127826 fileSize := anObject! ! 127827 127828!FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/15/2007 17:31'! 127829locationType 127830 "Answer the value of locationType" 127831 127832 ^ locationType! ! 127833 127834!FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/15/2007 17:31'! 127835locationType: anObject 127836 "Set the value of locationType" 127837 127838 locationType := anObject! ! 127839 127840!FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 01:14'! 127841modificationTime 127842 "Answer the value of modificationTime" 127843 127844 ^ modificationTime! ! 127845 127846!FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 01:14'! 127847modificationTime: anObject 127848 "Set the value of modificationTime" 127849 127850 modificationTime := anObject! ! 127851 127852 127853!FreeTypeFileInfo methodsFor: 'printing' stamp: 'tween 8/16/2007 01:08'! 127854printOn: aStream 127855 "super printOn: aStream." 127856 aStream 127857 nextPutAll: familyGroupName asString, '::',styleNameExtracted asString, ' '; 127858 nextPutAll: 127859 (locationType = #absolute 127860 ifTrue:[''] 127861 ifFalse:['{',locationType asString,'}']); 127862 nextPutAll: absoluteOrRelativePath asString; 127863 nextPutAll: '[',index asString,'] '; 127864 nextPutAll: familyName asString; 127865 nextPutAll: ' - ', styleName asString; 127866 nextPutAll: ' - ', postscriptName asString; 127867 nextPutAll: ' ',(bold ifTrue:['B'] ifFalse:['']); 127868 nextPutAll: ' ',(italic ifTrue:['I'] ifFalse:['']); 127869 nextPutAll: ' ',(fixedWidth ifTrue:['Monospaced'] ifFalse:['']); 127870 nextPutAll: ' ',(stretchValue asString); 127871 nextPutAll: ' ',(weightValue asString); 127872 cr! ! 127873Object subclass: #FreeTypeFileInfoAbstract 127874 instanceVariableNames: 'index familyName styleName postscriptName bold italic fixedWidth numFaces familyGroupName slant slantValue weight stretch weightValue stretchValue styleNameExtracted upright' 127875 classVariableNames: '' 127876 poolDictionaries: '' 127877 category: 'FreeType-FontManager'! 127878 127879!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 127880bold 127881 "Answer the value of bold" 127882 127883 ^ bold! ! 127884 127885!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 127886bold: anObject 127887 "Set the value of bold" 127888 127889 bold := anObject! ! 127890 127891!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 9/8/2007 22:34'! 127892extractAttributesFromNames 127893 "derive values for the receiver's style(italic), weight, and stretch inst vars. 127894 Also set the familyGroupName and styleNameExtracted" 127895 127896 | p | 127897 127898 p:= FreeTypeNameParser new 127899 familyNameIn: self validFamilyName; 127900 styleNameIn: self validStyleName; 127901 italicFlag: italic; 127902 boldFlag: bold; 127903 parse. 127904 familyGroupName := p familyName. 127905 slant := p extractedSlant. 127906 slantValue := p extractedSlantValue. 127907 weight := p extractedWeight. 127908 weightValue := p extractedWeightValue. 127909 stretch := p extractedStretch. 127910 stretchValue := p extractedStretchValue. 127911 upright := p extractedUpright. 127912 styleNameExtracted := ''. 127913 stretch ifNotNil:[ 127914 styleNameExtracted := styleNameExtracted ,stretch]. 127915 (weight notNil "and:[weight asLowercase ~= 'medium']") 127916 ifTrue:[ 127917 styleNameExtracted := styleNameExtracted , ' ', weight]. 127918 slant ifNotNil:[ 127919 styleNameExtracted := styleNameExtracted , ' ', slant]. 127920 styleNameExtracted := styleNameExtracted withBlanksTrimmed. 127921 styleNameExtracted ifEmpty: [ 127922 styleNameExtracted := upright ifNil:['Regular']]. 127923 127924 ! ! 127925 127926!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 127927familyGroupName 127928 "Answer the value of familyGroupName" 127929 127930 ^ familyGroupName! ! 127931 127932!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 127933familyName 127934 "Answer the value of familyName" 127935 127936 ^ familyName! ! 127937 127938!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 127939familyName: anObject 127940 "Set the value of familyName" 127941 127942 familyName := anObject! ! 127943 127944!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 127945fixedWidth 127946 "Answer the value of fixedWidth" 127947 127948 ^ fixedWidth! ! 127949 127950!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 127951fixedWidth: anObject 127952 "Set the value of fixedWidth" 127953 127954 fixedWidth := anObject! ! 127955 127956!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 127957index 127958 "Answer the value of index" 127959 127960 ^ index! ! 127961 127962!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 127963index: anObject 127964 "Set the value of index" 127965 127966 index := anObject! ! 127967 127968!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 9/29/2007 10:42'! 127969isBolderThan: val 127970 ^self weightValue >= val! ! 127971 127972!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 9/29/2007 10:41'! 127973isItalicOrOblique 127974 ^self slantValue > 0! ! 127975 127976!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 127977italic 127978 "Answer the value of italic" 127979 127980 ^ italic! ! 127981 127982!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 127983italic: anObject 127984 "Set the value of italic" 127985 127986 italic := anObject! ! 127987 127988!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 127989numFaces 127990 "Answer the value of numFaces" 127991 127992 ^ numFaces! ! 127993 127994!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 127995numFaces: anObject 127996 "Set the value of numFaces" 127997 127998 numFaces := anObject! ! 127999 128000!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 128001postscriptName 128002 "Answer the value of postscriptName" 128003 128004 ^ postscriptName! ! 128005 128006!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 128007postscriptName: anObject 128008 "Set the value of postscriptName" 128009 128010 postscriptName := anObject! ! 128011 128012!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:59'! 128013slant 128014 "Answer the value of slant" 128015 128016 ^ slant! ! 128017 128018!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 21:39'! 128019slantValue 128020 ^slantValue! ! 128021 128022!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/11/2007 14:22'! 128023stretch 128024 "Answer the value of stretch" 128025 128026 ^ stretch! ! 128027 128028!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:04'! 128029stretchValue 128030 "Answer the value of stretchValue" 128031 128032 ^ stretchValue! ! 128033 128034!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:04'! 128035stretchValue: anObject 128036 "Set the value of stretchValue" 128037 128038 stretchValue := anObject! ! 128039 128040!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:59'! 128041style 128042 "Answer the value of slant" 128043 128044 ^ slant! ! 128045 128046!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 128047styleName 128048 "Answer the value of styleName" 128049 128050 ^ styleName! ! 128051 128052!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! 128053styleName: anObject 128054 "Set the value of styleName" 128055 128056 styleName := anObject! ! 128057 128058!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/12/2007 19:27'! 128059styleNameExtracted 128060 ^styleNameExtracted! ! 128061 128062!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 9/8/2007 23:23'! 128063styleNameWithItalicForcedToBe: aString 128064 | answer | 128065 answer := ''. 128066 stretch ifNotNil:[ 128067 answer := answer ,stretch]. 128068 (weight notNil "and:[weight asLowercase ~= 'medium']") 128069 ifTrue:[ 128070 answer := answer , ' ', weight]. 128071 answer := answer , ' ', aString. 128072 answer := answer withBlanksTrimmed. 128073 ^answer 128074 128075 ! ! 128076 128077!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:59'! 128078styleNameWithWeightForcedToBe: aString 128079 | answer | 128080 answer := ''. 128081 stretch ifNotNil:[ 128082 answer := answer ,stretch]. 128083 answer := answer , ' ', aString. 128084 slant ifNotNil:[ 128085 answer := answer , ' ', slant]. 128086 answer := answer withBlanksTrimmed. 128087 ^answer 128088 128089 ! ! 128090 128091!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 02:31'! 128092styleNameWithWeightForcedToBe: aString italicForcedToBe: aString2 128093 | answer | 128094 answer := ''. 128095 stretch ifNotNil:[ 128096 answer := answer ,stretch]. 128097 answer := answer , ' ', aString. 128098 answer := answer , ' ', aString2. 128099 answer := answer withBlanksTrimmed. 128100 ^answer 128101 128102 ! ! 128103 128104!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 9/1/2007 18:38'! 128105validFamilyName 128106 "answer the receiver's familyName, or an alternative 128107 name to use if the familyName is invalid for some reason" 128108 128109 (familyName copyWithout: $? ) 128110 ifEmpty:[ 128111 "workaround problem with FreeType 2.2.1 and MS Gothic, MS Mincho 128112 where familyName is not read correctly. This may be fixed in later versions 128113 of FreeType" 128114 self baseName asUppercase = 'MSGOTHIC' 128115 ifTrue:[ 128116 index = 0 ifTrue:[^'MS Gothic']. 128117 index = 1 ifTrue:[^'MS PGothic']. 128118 index = 2 ifTrue:[^'MS UI Gothic']]. 128119 self baseName asUppercase = 'MSMINCHO' 128120 ifTrue:[ 128121 index = 0 ifTrue:[^'MS Mincho']. 128122 index = 1 ifTrue:[^'MS PMincho']. 128123 ^self baseName asUppercase, ' ', index asString]]. 128124 ^familyName! ! 128125 128126!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/12/2007 17:06'! 128127validStyleName 128128 "answer the receiver's styleName, or an alternative 128129 name to use if the styleName is invalid for some reason" 128130 128131 | answer | 128132 (styleName copyWithout: $? ) 128133 ifEmpty:[ 128134 "workaround problem with FreeType 2.2.1 and MS Gothic, MS Mincho 128135 where familyName is not read correctly. This may be fixed in later versions 128136 of FreeType" 128137 answer := ''. 128138 italic ifTrue:[answer := answer , 'Italic ']. 128139 bold ifTrue:[answer := answer, 'Bold ']. 128140 (italic or:[bold]) not ifTrue:[answer := answer, 'Regular ']. 128141 ^answer withBlanksTrimmed]. 128142 ^styleName! ! 128143 128144!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/11/2007 14:22'! 128145weight 128146 "Answer the value of weight" 128147 128148 ^ weight! ! 128149 128150!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:04'! 128151weightValue 128152 "Answer the value of weightValue" 128153 128154 ^ weightValue! ! 128155 128156!FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:04'! 128157weightValue: anObject 128158 "Set the value of weightValue" 128159 128160 weightValue := anObject! ! 128161 128162 128163!FreeTypeFileInfoAbstract methodsFor: 'testing' stamp: 'tween 7/16/2007 00:31'! 128164isEmbedded 128165 ^false! ! 128166AbstractFont subclass: #FreeTypeFont 128167 instanceVariableNames: 'face pointSize simulatedEmphasis pixelSize widthAndKernedWidthCache cachedHeight cachedAscent cachedDescent subPixelPositioned symbolFont' 128168 classVariableNames: '' 128169 poolDictionaries: 'FT2Constants FreeTypeCacheConstants' 128170 category: 'FreeType-Fonts'! 128171 128172!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 7/15/2007 22:00'! 128173clearCachedMetrics 128174 widthAndKernedWidthCache := cachedHeight := cachedAscent := cachedDescent := subPixelPositioned := nil! ! 128175 128176!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 9/29/2007 09:44'! 128177defaultSimulatedItalicSlant 128178 ^0.22! ! 128179 128180!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:27'! 128181depth 128182 128183 ^ 32.! ! 128184 128185!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:33'! 128186face 128187 "Validate, and answer, the receiver's face" 128188 128189 ^face validate! ! 128190 128191!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:34'! 128192face: aFace 128193 face := aFace! ! 128194 128195!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/31/2007 11:57'! 128196hash 128197 ^pointSize hash! ! 128198 128199!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:44'! 128200maxAscii 128201 "should have default in AbstractFont" 128202 ^SmallInteger maxVal! ! 128203 128204!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:44'! 128205minAscii 128206 "should have default in AbstractFont" 128207 ^0! ! 128208 128209!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 8/27/2007 10:02'! 128210postscriptName 128211 ^self face postscriptName! ! 128212 128213!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:47'! 128214setFace: aFreetypeFace pointSize: anInteger 128215 face := aFreetypeFace. 128216 pointSize := anInteger.! ! 128217 128218!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 9/29/2007 09:43'! 128219simulatedBoldStrength 128220 "Answer the amount by which glyphs need to be emboldened/lightened 128221 according to the receiver's simulated emphasis and the face's real emphasis" 128222 | bold faceBold | 128223 128224 self isSimulated ifFalse:[^0]. 128225 bold := self isSimulatedBold. 128226 faceBold := face isBold. 128227 (bold and: [faceBold not]) 128228 ifTrue:[^self pixelSize/24]. 128229 ^0! ! 128230 128231!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 9/29/2007 09:42'! 128232simulatedEmphasis 128233 "Answer the simulatedEmphasis. 128234 This is 128235 0 - normal (no simulatedEmphasis, or simulated regular). 128236 1 - bold 128237 2 - italic 128238 3 - bold & italic" 128239 ^simulatedEmphasis ifNil:[0]! ! 128240 128241!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 9/29/2007 09:43'! 128242simulatedEmphasis: anIntegerOrNil 128243 "Set the simulatedEmphasis. 128244 This is 128245 nil - no simulated emphasis 128246 0 - normal (simulated regular). 128247 1 - bold 128248 2 - italic 128249 3 - bold & italic" 128250 simulatedEmphasis := anIntegerOrNil! ! 128251 128252!FreeTypeFont methodsFor: 'accessing' stamp: 'tween 9/29/2007 09:44'! 128253simulatedItalicSlant 128254 "Answer the slant that needs to be added to italicize/un-italicize 128255 glyphs according to the receiver's simulated emphasis and the face's 128256 real emphasis" 128257 | italic faceItalic | 128258 128259 self isSimulated ifFalse:[^0]. 128260 italic := self isSimulatedItalic. 128261 faceItalic := face isItalic. 128262 (italic and: [faceItalic not]) 128263 ifTrue:[^self defaultSimulatedItalicSlant]. 128264 ^0! ! 128265 128266 128267!FreeTypeFont methodsFor: 'displaying' stamp: 'tween 9/1/2007 10:32'! 128268displayLineGlyphOn: aDisplayContext from: startPoint to: endPoint 128269 | oldCombinationRule oldHalftoneForm originalColorMap clr depth foreColorVal foreColorAlpha glyph width height 128270 startPointX startPointY endPointX endPointY foreColor | 128271 oldCombinationRule := aDisplayContext combinationRule . 128272 oldHalftoneForm := aDisplayContext halftoneForm . 128273 originalColorMap := aDisplayContext colorMap. 128274 clr := (foreColor := aDisplayContext lastFontForegroundColor ifNil:[Color black asNontranslucentColor]) 128275 pixelValueForDepth: 32. 128276 depth := aDisplayContext destForm depth. 128277 foreColorVal := clr bitAnd: 16rFFFFFF. 128278 foreColorAlpha := (clr bitAnd: 16rFF000000) >> 24. 128279 depth <= 8 128280 ifTrue:[ 128281 aDisplayContext colorMap: (aDisplayContext cachedFontColormapFrom:32 to: depth)] 128282 ifFalse:[ 128283 aDisplayContext colorMap: nil]. 128284 startPointX := startPoint x truncated. 128285 startPointY := startPoint y. 128286 endPointX := endPoint x ceiling. 128287 endPointY := endPoint y. 128288 width := endPointX - startPointX. 128289 height := endPointY - startPointY. 128290 glyph := (Form extent: width@height depth: 32) fillWhite. "we could cache a big white glyph somewhere to save having to create this. Clipping will make only a part of it display" 128291 aDisplayContext sourceForm: glyph. 128292 aDisplayContext destOrigin: startPointX@startPointY. 128293 aDisplayContext width: width. 128294 aDisplayContext height: height. 128295 aDisplayContext 128296 sourceOrigin: 0@0; 128297 halftoneForm: nil. 128298 (FreeTypeSettings current bitBltSubPixelAvailable and: [depth >= 8]) 128299 ifTrue:[ 128300 aDisplayContext 128301 combinationRule: 41. 128302 aDisplayContext 128303 copyBitsColor: foreColorVal 128304 alpha: foreColorAlpha 128305 gammaTable: FreeTypeSettings current gammaTable 128306 ungammaTable: FreeTypeSettings current gammaInverseTable] 128307 ifFalse:[ 128308 glyph fillWithColor: foreColor. 128309 aDisplayContext combinationRule: (depth <= 8 ifTrue: [Form paint] ifFalse: [34]). 128310 aDisplayContext copyBits]. 128311 aDisplayContext 128312 colorMap: originalColorMap; 128313 combinationRule: oldCombinationRule; 128314 halftoneForm: oldHalftoneForm. 128315 128316 ! ! 128317 128318!FreeTypeFont methodsFor: 'displaying' stamp: 'tween 3/17/2007 11:30'! 128319displayStrikeoutOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint 128320 | top bottom strikeoutThickness s e | 128321 128322 "the strikeout size/position for TrueType fonts should really come from the TT:=OS2 table. 128323 This needs to be read by the plugin when the face is created. 128324 For now, we use the underlineThickness, and 1/4 of the ascender from the baseline" 128325 strikeoutThickness := (self face underlineThickness * self pixelSize / self face unitsPerEm). 128326 top := ((self face ascender / 4) * self pixelSize / self face unitsPerEm) negated - (strikeoutThickness/2). 128327 top := top rounded. 128328 bottom := top + strikeoutThickness ceiling. 128329 s := baselineStartPoint + (0@top). 128330 e := baselineEndPoint + (0@bottom). 128331 self displayLineGlyphOn: aDisplayContext from: s to: e 128332 ! ! 128333 128334!FreeTypeFont methodsFor: 'displaying' stamp: 'tween 3/17/2007 11:30'! 128335displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta 128336 128337 ^self displayString: aString 128338 on: aDisplayContext 128339 from: startIndex 128340 to: stopIndex 128341 at: aPoint 128342 kern: kernDelta 128343 baselineY: aPoint y + self ascent! ! 128344 128345!FreeTypeFont methodsFor: 'displaying' stamp: 'tween 4/5/2007 09:32'! 128346displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY 128347 | glyph depth foreColorVal foreColorAlpha originalColorMap clr subPixelPosition widthAndKernedWidth char nextChar floatDestX destX destY offset gammaTable gammaInverseTable useRule41 | 128348 128349 useRule41 := FreeTypeSettings current bitBltSubPixelAvailable and: [aBitBlt destForm depth >= 8]. 128350 depth := aBitBlt destForm depth. 128351 originalColorMap := aBitBlt colorMap. 128352 clr := (aBitBlt lastFontForegroundColor ifNil:[Color black asNontranslucentColor]) 128353 pixelValueForDepth: 32. 128354 useRule41 128355 ifTrue:[ 128356 foreColorVal := clr bitAnd: 16rFFFFFF. 128357 foreColorAlpha := (clr bitAnd: 16rFF000000) >> 24. 128358 gammaTable := FreeTypeSettings current gammaTable. 128359 gammaInverseTable := FreeTypeSettings current gammaInverseTable.] 128360 ifFalse:[ 128361 foreColorVal := clr]. 128362 depth <= 8 128363 ifTrue:[ 128364 aBitBlt colorMap: (aBitBlt cachedFontColormapFrom:32 to: depth)] 128365 ifFalse:[ 128366 aBitBlt colorMap: nil]. 128367 destX := aPoint x. 128368 destY := baselineY. 128369 floatDestX := aPoint x. 128370 widthAndKernedWidth := Array new: 2. 128371 startIndex to: stopIndex do: [:i | 128372 subPixelPosition := ((floatDestX \\ 1) roundTo: "1/64" 0.015625) * 64. 128373 subPixelPosition = 64 128374 ifTrue:[ 128375 subPixelPosition := 0. 128376 destX := destX + 1]. 128377 char := aString at: i. 128378 glyph := self 128379 glyphOf: char 128380 destDepth: depth 128381 colorValue: foreColorVal 128382 subpixelPosition: subPixelPosition. 128383 aBitBlt sourceForm: glyph. 128384 offset := glyph offset. 128385 aBitBlt destX: destX + offset x. 128386 aBitBlt destY: destY + offset y. 128387 aBitBlt width: glyph width. 128388 aBitBlt height: glyph height. 128389 useRule41 128390 ifTrue:[ 128391 aBitBlt 128392 copyBitsColor: foreColorVal 128393 alpha: foreColorAlpha 128394 gammaTable: gammaTable 128395 ungammaTable: gammaInverseTable] 128396 ifFalse:[ 128397 aBitBlt copyBits]. 128398 nextChar := (i + 1 <= stopIndex) 128399 ifTrue:[aString at: i + 1] 128400 ifFalse:[nil]. 128401 self 128402 widthAndKernedWidthOfLeft: char 128403 right: nextChar 128404 into: widthAndKernedWidth. 128405 floatDestX := floatDestX + (widthAndKernedWidth at: 2) + kernDelta. 128406 destX := floatDestX ]. 128407 aBitBlt colorMap: originalColorMap. 128408 ^ destX @ destY 128409! ! 128410 128411!FreeTypeFont methodsFor: 'displaying' stamp: 'tween 3/17/2007 11:32'! 128412displayUnderlineOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint 128413 | underlineTop underlineBottom underlineThickness s e | 128414 128415 underlineThickness := (self face underlineThickness * self pixelSize / self face unitsPerEm). 128416 underlineTop := (self face underlinePosition * self pixelSize / self face unitsPerEm) negated - (underlineThickness/2). 128417 underlineTop := underlineTop rounded + 1. "needs the +1 , possibly because glyph origins are moved down by 1 so that their baselines line up with strike fonts" 128418 underlineBottom := underlineTop + underlineThickness ceiling. 128419 s := baselineStartPoint + (0@underlineTop). 128420 e := baselineEndPoint + (0@(underlineBottom)). 128421 self displayLineGlyphOn: aDisplayContext from: s to: e! ! 128422 128423!FreeTypeFont methodsFor: 'displaying' stamp: 'tween 4/5/2007 08:15'! 128424installOn: aBitBlt foregroundColor: foreColor backgroundColor: backColor 128425 128426 | | 128427 "fcolor := foreColor pixelValueForDepth: 32." 128428 aBitBlt installFreeTypeFont: self foregroundColor: foreColor backgroundColor: backColor. 128429! ! 128430 128431 128432!FreeTypeFont methodsFor: 'glyph lookup' stamp: 'tween 9/1/2007 09:54'! 128433characterFormAt: aCharacter 128434 FreeTypeSettings current 128435 forceNonSubPixelDuring:[ 128436 ^self 128437 glyphOf: aCharacter 128438 destDepth: 32 128439 colorValue: (Color black pixelValueForDepth: 32) 128440 subpixelPosition: 0]! ! 128441 128442!FreeTypeFont methodsFor: 'glyph lookup' stamp: 'tween 4/4/2007 19:13'! 128443glyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub 128444 128445 | | 128446 ^FreeTypeCache current 128447 atFont: self 128448 charCode: aCharacter asUnicode asInteger 128449 type: ((1+sub) << 32) + aColorValue 128450 ifAbsentPut: [ 128451 FreeTypeGlyphRenderer current 128452 glyphOf: aCharacter 128453 colorValue: aColorValue 128454 mono: monoBoolean 128455 subpixelPosition: sub 128456 font: self] 128457 128458! ! 128459 128460!FreeTypeFont methodsFor: 'glyph lookup' stamp: 'tween 9/1/2007 15:35'! 128461glyphOf: aCharacter destDepth: destDepth colorValue: aColorValue subpixelPosition: sub 128462 "sub can be between 0 and 63 and denotes the sub-pixel position of the glyph" 128463 | validSub | 128464 validSub := self isSubPixelPositioned 128465 ifTrue: [((sub asInteger max: 0) min: 63) "bitAnd: 2r111000"] 128466 ifFalse:[0]. 128467 ^(destDepth >=8 and:[FreeTypeSettings current subPixelAntiAliasing]) 128468 ifTrue:[ 128469 self 128470 subGlyphOf: aCharacter 128471 colorValue: aColorValue 128472 mono: FreeTypeSettings current monoHinting 128473 subpixelPosition: validSub] 128474 ifFalse:[ 128475 (destDepth >= 8 and:[FreeTypeSettings current bitBltSubPixelAvailable]) 128476 ifTrue:[ 128477 self 128478 mode41GlyphOf: aCharacter 128479 colorValue: aColorValue 128480 mono: FreeTypeSettings current monoHinting 128481 subpixelPosition: validSub] 128482 ifFalse:[ 128483 self 128484 glyphOf: aCharacter 128485 colorValue: aColorValue 128486 mono: FreeTypeSettings current monoHinting 128487 subpixelPosition: validSub]]! ! 128488 128489!FreeTypeFont methodsFor: 'glyph lookup' stamp: 'tween 4/4/2007 19:14'! 128490mode41GlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub 128491 128492 | | 128493 ^FreeTypeCache current 128494 atFont: self 128495 charCode: aCharacter asUnicode asInteger 128496 type: (FreeTypeCacheGlyph + sub) 128497 ifAbsentPut: [ 128498 FreeTypeGlyphRenderer current 128499 mode41GlyphOf: aCharacter 128500 colorValue: aColorValue 128501 mono: monoBoolean 128502 subpixelPosition: sub 128503 font: self] 128504 128505! ! 128506 128507!FreeTypeFont methodsFor: 'glyph lookup' stamp: 'tween 4/4/2007 19:13'! 128508subGlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub 128509 128510 | | 128511 ^FreeTypeCache current 128512 atFont: self 128513 charCode: aCharacter asUnicode asInteger 128514 type: FreeTypeCacheGlyphLCD + sub 128515 ifAbsentPut: [ 128516 FreeTypeGlyphRenderer current 128517 subGlyphOf: aCharacter 128518 colorValue: aColorValue 128519 mono: monoBoolean 128520 subpixelPosition: sub 128521 font: self] 128522 128523! ! 128524 128525 128526!FreeTypeFont methodsFor: 'initialize-release' stamp: 'tween 3/17/2007 11:39'! 128527initialize: aFont 128528 128529 self face: aFont face.! ! 128530 128531!FreeTypeFont methodsFor: 'initialize-release' stamp: 'tween 3/17/2007 11:45'! 128532releaseCachedState 128533 face releaseCachedState. 128534 FreeTypeCache current removeAllForFont: self.! ! 128535 128536 128537!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/3/2007 17:22'! 128538ascent 128539 | asc desc h | 128540 cachedAscent ifNotNil:[^cachedAscent]. 128541 asc := self basicAscent. 128542 desc := self descent. 128543 h := self height. 128544 asc + desc < h ifFalse:[^cachedAscent := asc]. 128545 "height is greater than asc+desc, adjust ascent to include the difference" 128546 ^cachedAscent := h - desc ! ! 128547 128548!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/26/2007 13:14'! 128549basicAscent 128550 128551 ^(self face ascender * self pixelSize // self face unitsPerEm). 128552! ! 128553 128554!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/3/2007 17:24'! 128555descent 128556 ^cachedDescent ifNil:[ 128557 cachedDescent := ((self face descender * self pixelSize // self face unitsPerEm) negated) ]! ! 128558 128559!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/17/2007 11:28'! 128560descentKern 128561 "should have default in AbstractFont" 128562 ^0! ! 128563 128564!FreeTypeFont methodsFor: 'measuring' stamp: 'michael.rueger 2/5/2009 17:03'! 128565getLinearWidthOf: aCharacter 128566 | em glyph la charCode | 128567 128568 aCharacter < $ ifTrue: [^self getLinearWidthOf: $ ]. 128569 charCode := aCharacter asUnicode asInteger. 128570 (self face charmaps includes:'unic') 128571 ifTrue:[ 128572 (self isSymbolFont and:[charCode >= 16r20 and: [charCode <= 16rFF ] ]) 128573 ifTrue:[charCode := charCode + 16rF000]] 128574 ifFalse:[ 128575 (self face charmaps includes:'armn') 128576 ifTrue:[ "select apple roman char map, and map character from unicode to mac encoding" 128577 self face setCharMap:'armn'. 128578 charCode := aCharacter unicodeToMacRoman asUnicode asInteger. "check this!!"]]. 128579 em := self pixelSize. 128580 face validate. 128581 face setPixelWidth: em height: em. 128582 [face loadCharacter: charCode flags: (LoadNoBitmap bitOr: (LoadIgnoreTransform bitOr: "FreeTypeSettings current hintingFlags" 2 "no hinting"))] 128583 on: FT2Error do:[:e | 128584 face loadGlyph: 0 flags: (LoadNoBitmap bitOr: (LoadIgnoreTransform bitOr: FreeTypeSettings current hintingFlags "no hinting")) ]. 128585 glyph := face glyph. 128586 la := glyph linearHorizontalAdvance. 128587 la isZero ifTrue:[ 128588 "FreeType 2.2.1 sometimes screws up when getting metrics, 128589 Maybe the bug is in the plugin? 128590 For example Calibri pixel size 13 gives linearAdvance x of zero !! 128591 We try again at double the size, and half the result" 128592 em := self pixelSize * 2. 128593 face validate. 128594 face setPixelWidth: em height: em. 128595 face loadCharacter: charCode flags:(LoadNoBitmap bitOr: (LoadIgnoreTransform bitOr: "FreeTypeSettings current hintingFlags" 2 "no hinting")). "load glyph metrics" 128596 glyph := face glyph. 128597 la := glyph linearHorizontalAdvance / 2.0]. 128598 ^la 128599! ! 128600 128601!FreeTypeFont methodsFor: 'measuring' stamp: 'michael.rueger 2/5/2009 17:03'! 128602getWidthOf: aCharacter 128603 "Glyphs are either 1 or 8 bit deep. For 32 bpp we use 8 bits, otherwise 1" 128604 | em glyph hintingFlags flags charCode | 128605 128606 aCharacter < $ ifTrue: [^self getWidthOf: $ ]. 128607 charCode := aCharacter asUnicode asInteger. 128608 (self face charmaps includes:'unic') 128609 ifTrue:[ 128610 (self isSymbolFont and:[charCode >= 16r20 and: [charCode <= 16rFF ] ]) 128611 ifTrue:[charCode := charCode + 16rF000]] 128612 ifFalse:[ 128613 (self face charmaps includes:'armn') 128614 ifTrue:[ "select apple roman char map, and map character from unicode to mac encoding" 128615 self face setCharMap:'armn'. 128616 charCode := aCharacter unicodeToMacRoman asUnicode asInteger. "check this!!"]]. 128617 em := self pixelSize. 128618 face validate. 128619 face isValid ifFalse:[^0]. 128620 face setPixelWidth: em height: em. 128621 hintingFlags := FreeTypeSettings current hintingFlags. 128622 flags := LoadNoBitmap bitOr:( LoadIgnoreTransform bitOr: hintingFlags). 128623 [face loadCharacter: charCode flags: flags. 128624 ] on:FT2Error do:[:e | "character not in map?"^0]. 128625 glyph := face glyph. 128626 "When not hinting FreeType sets the advance to the truncated linearAdvance. 128627 The characters appear squashed together. Rounding is probably better, so we 128628 answer the rounded linear advance here" 128629 ^self subPixelPositioned 128630 ifTrue:[ glyph roundedPixelLinearAdvance x] 128631 ifFalse:[ glyph advance x]. 128632! ! 128633 128634!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/3/2007 17:25'! 128635height 128636 128637 ^cachedHeight ifNil:[ 128638 cachedHeight := (self face height * self pixelSize / self face unitsPerEm) ceiling ]! ! 128639 128640!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/3/2007 16:42'! 128641hintedKerningLeft: leftChar right: rightChar 128642 ^(self linearKerningLeft: leftChar right: rightChar) rounded! ! 128643 128644!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/31/2007 23:08'! 128645hintedWidthOf: aCharacter 128646 "retrieve advance width for character. try to use cached glyph if possible" 128647 | charCode answer | 128648 128649 charCode := aCharacter asUnicode asInteger. 128650 answer := FreeTypeCache current 128651 atFont: self 128652 charCode: charCode 128653 type: FreeTypeCacheWidth 128654 ifAbsentPut: [self getWidthOf: aCharacter]. 128655 ^answer 128656! ! 128657 128658!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 7/15/2007 21:59'! 128659kerningLeft: leftChar right: rightChar 128660 ^self isSubPixelPositioned 128661 ifTrue: [self linearKerningLeft: leftChar right: rightChar] 128662 ifFalse:[self hintedKerningLeft: leftChar right: rightChar]! ! 128663 128664!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/17/2007 11:43'! 128665lineGrid 128666 128667 ^self height! ! 128668 128669!FreeTypeFont methodsFor: 'measuring' stamp: 'michael.rueger 2/5/2009 17:04'! 128670linearKerningLeft: leftChar right: rightChar 128671 | f l r | 128672 128673 f := self face. 128674 f hasKerning ifFalse:[^0]. 128675 l := leftChar asUnicode. 128676 r := rightChar asUnicode. 128677 (self face charmaps includes:'unic') 128678 ifTrue:[ 128679 self isSymbolFont 128680 ifTrue:[ 128681 (l asInteger >= 16r20 and:[l asInteger <= 16rFF ]) 128682 ifTrue:[l := (Character value: l asInteger + 16rF000) asUnicode]. 128683 (r asInteger >= 16r20 and:[ r asInteger <= 16rFF ]) 128684 ifTrue:[r := (Character value: r asInteger + 16rF000) asUnicode]]] 128685 ifFalse:[ 128686 (self face charmaps includes:'armn') 128687 ifTrue:[ "select apple roman char map, and map characters from unicode to mac encoding" 128688 self face setCharMap:'armn'. 128689 (l asInteger >= 16r20 and:[l asInteger <= 16rFF ]) 128690 ifTrue:[l := (Character value: l asInteger) unicodeToMacRoman]. 128691 (r asInteger >= 16r20 and:[ r asInteger <= 16rFF ]) 128692 ifTrue:[r := (Character value: r asInteger) unicodeToMacRoman]]]. 128693 ^(f kerningLeft: l right: r) x asFloat * self pixelSize / f unitsPerEm! ! 128694 128695!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/31/2007 20:18'! 128696linearWidthOf: aCharacter 128697 "retrieve linear advance width for character. try to use cached glyph if possible. 128698 This is the scaled, unrounded advance width." 128699 | charCode answer | 128700 128701 charCode := aCharacter asUnicode asInteger. 128702 answer := FreeTypeCache current 128703 atFont: self 128704 charCode: charCode 128705 type: FreeTypeCacheLinearWidth 128706 ifAbsentPut: [self getLinearWidthOf: aCharacter]. 128707 ^answer 128708! ! 128709 128710!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/31/2007 11:38'! 128711pixelSize 128712 ^pixelSize ifNil:[pixelSize := super pixelSize rounded]! ! 128713 128714!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/17/2007 11:45'! 128715pointSize 128716 ^pointSize! ! 128717 128718!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/17/2007 11:45'! 128719pointSize: aSize 128720 pointSize := aSize! ! 128721 128722!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/2/2007 22:10'! 128723widthAndKernedWidthCache 128724 ^widthAndKernedWidthCache ifNil:[widthAndKernedWidthCache := Dictionary new]! ! 128725 128726!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/2/2007 22:11'! 128727widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray 128728 "Set the first element of aTwoElementArray to the width of leftCharacter and 128729 the second element to the width of left character when kerned with 128730 rightCharacterOrNil. Answer the receiver 128731 128732 We use a widthAndKernedWidthCache to store these values for speed" 128733 | privateArray | 128734 128735 privateArray := (self widthAndKernedWidthCache at: leftCharacter ifAbsentPut:[Dictionary new]) 128736 at: (rightCharacterOrNil ifNil:[0 asCharacter]) 128737 ifAbsentPut:[ 128738 super 128739 widthAndKernedWidthOfLeft: leftCharacter 128740 right: rightCharacterOrNil 128741 into: (Array new: 2)]. 128742 "We can't answer privateArray, we MUST copy its elements into aTwoElementArray" 128743 aTwoElementArray 128744 at: 1 put: (privateArray at: 1); 128745 at: 2 put: (privateArray at: 2). 128746 ^aTwoElementArray! ! 128747 128748!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 7/15/2007 22:00'! 128749widthOf: aCharacter 128750 "retrieve advance width for character. try to use cached glyph if possible" 128751 ^self isSubPixelPositioned 128752 ifTrue:[self linearWidthOf: aCharacter] 128753 ifFalse: [self hintedWidthOf: aCharacter] 128754! ! 128755 128756!FreeTypeFont methodsFor: 'measuring' stamp: 'tween 7/4/2009 12:58'! 128757widthOfString: aString from: startIndex to: stopIndex 128758 "Measure the length of the given string between start and stop index. 128759 Currently this allows for the right side bearing of the last char, but does not allow for the left side bearing of the first char. We really need a new method - boundingBoxOfString that allows for both. Senders of this will also need to know the LSB of the first char, and position their text accordingly" 128760 | char nextChar resultX glyph a subPixelPosition | 128761 128762 a := Array new: 2. 128763 "FreeTypeSettings current hinting ifFalse:[ 128764 ^self linearWidthOfString: aString from: startIndex to: stopIndex]." 128765 resultX := 0. 128766 startIndex to: stopIndex do:[:i | 128767 char := aString at: i. 128768 nextChar := (i + 1 <= stopIndex) 128769 ifTrue:[ aString at: i + 1] 128770 ifFalse:[nil]. 128771 self widthAndKernedWidthOfLeft: char right: nextChar into: a. 128772 resultX := resultX + (a at:2). 128773 i = stopIndex 128774 ifTrue:[ 128775 subPixelPosition := (((resultX \\ 1) roundTo: "1/64" 0.015625) * 64) asInteger. 128776 subPixelPosition = 64 128777 ifTrue:[ 128778 subPixelPosition := 0. 128779 resultX := resultX + 1 ]. 128780 subPixelPosition := (subPixelPosition max: 0) min: 63. 128781 glyph := self glyphOf: char colorValue: 0 mono: FreeTypeSettings current monoHinting subpixelPosition: subPixelPosition. 128782 glyph ifNotNil:[ 128783 "currently the glyph is too wide. This is to allow for some extra space to ensure 128784 the glyph is not clipped when it is produced. Either make the width accurate, 128785 or hold the RSB value separately, or hold an accurate width separately" 128786 resultX := resultX "+ 2" + glyph offset x "negated" + (glyph width - (a at: 2) "glyph linearAdvance x floor")]]]. 128787 ^resultX ceiling ! ! 128788 128789 128790!FreeTypeFont methodsFor: 'notifications' stamp: 'tween 4/3/2007 16:48'! 128791pixelsPerInchChanged 128792 "the TextStyle pixels per inch setting has changed" 128793 128794 pixelSize := nil. 128795 widthAndKernedWidthCache := nil. 128796 FreeTypeCache current removeAllForFont: self.! ! 128797 128798 128799!FreeTypeFont methodsFor: 'printing' stamp: 'tween 3/17/2007 11:45'! 128800printOn: aStream 128801 128802 aStream 128803 nextPutAll: self class name; 128804 nextPut: $(; 128805 print: face familyName; 128806 space; 128807 print: face styleName; 128808 space; 128809 print: pointSize; 128810 nextPut: $)! ! 128811 128812 128813!FreeTypeFont methodsFor: 'testing' stamp: 'tween 3/29/2007 13:48'! 128814hasDistinctGlyphsForAll: asciiString 128815 "Answer true if the receiver has glyphs for all the characters 128816 in asciiString and no single glyph is shared by more than one character, false otherwise. 128817 The default behaviour is to answer true, but subclasses may reimplement" 128818 | setOfIndices i | 128819 self face isValid ifFalse:[^false]. 128820 setOfIndices := Set new. 128821 asciiString asSet do:[:c | 128822 (i := self face primGetCharIndex: c asInteger) = 0 128823 ifTrue:[^false] 128824 ifFalse:[ 128825 (setOfIndices includes: i) 128826 ifTrue:[^false] 128827 ifFalse:[setOfIndices add: i]]]. 128828 ^true! ! 128829 128830!FreeTypeFont methodsFor: 'testing' stamp: 'tween 3/29/2007 13:28'! 128831hasGlyphsForAll: asciiString 128832 "Answer true if the receiver has glyphs for all the characters 128833 in asciiString, false otherwise. 128834 The default behaviour is to answer true, but subclasses may reimplement" 128835 128836 self face isValid ifFalse:[^false]. 128837 asciiString do:[:c | 128838 (self face primGetCharIndex: c asInteger) = 0 128839 ifTrue:[^false]]. 128840 ^true! ! 128841 128842!FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:49'! 128843isBold 128844 ^(simulatedEmphasis == nil and:[self face isBold]) 128845 or:[self isSimulatedBold]! ! 128846 128847!FreeTypeFont methodsFor: 'testing' stamp: 'tween 3/17/2007 11:41'! 128848isFixedWidth 128849 ^self face isFixedWidth ! ! 128850 128851!FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:48'! 128852isItalic 128853 ^(simulatedEmphasis == nil and:[self face isItalic]) 128854 or:[self isSimulatedItalic]! ! 128855 128856!FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:49'! 128857isRegular 128858 ^(simulatedEmphasis == nil and:[self face isRegular]) 128859 or: [self isSimulatedRegular]! ! 128860 128861!FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:41'! 128862isSimulated 128863 ^simulatedEmphasis notNil! ! 128864 128865!FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:42'! 128866isSimulatedBold 128867 ^self simulatedEmphasis anyMask: 1! ! 128868 128869!FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:45'! 128870isSimulatedItalic 128871 ^self simulatedEmphasis anyMask: 2! ! 128872 128873!FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:45'! 128874isSimulatedRegular 128875 ^simulatedEmphasis = 0! ! 128876 128877!FreeTypeFont methodsFor: 'testing' stamp: 'tween 7/15/2007 21:55'! 128878isSubPixelPositioned 128879 "Answer true if the receiver is currently using subpixel positioned 128880 glyphs, false otherwise. This affects how padded space sizes are calculated 128881 when composing text. 128882 Currently, only FreeTypeFonts are subPixelPositioned, and only when not 128883 Hinted" 128884 128885 ^self subPixelPositioned! ! 128886 128887!FreeTypeFont methodsFor: 'testing' stamp: 'tween 8/1/2007 01:08'! 128888isSymbolFont 128889 | charmaps | 128890 symbolFont ifNotNil:[^symbolFont]. 128891 self face isValid ifFalse:[^false]. 128892 charmaps := self face charmaps. 128893 (charmaps includes: 'symb') ifTrue:[^symbolFont := true]."MS Symbol font" 128894 ^symbolFont := false! ! 128895 128896!FreeTypeFont methodsFor: 'testing' stamp: 'tween 3/17/2007 11:42'! 128897isTTCFont 128898 "not really - look for senders of this" 128899 ^true! ! 128900 128901!FreeTypeFont methodsFor: 'testing' stamp: 'tween 7/15/2007 21:57'! 128902subPixelPositioned 128903 "Answer true if the receiver is currently using subpixel positioned 128904 glyphs, false otherwise. This affects how padded space sizes are calculated 128905 when composing text." 128906 | settings | 128907 ^subPixelPositioned 128908 ifNil:[ 128909 settings := FreeTypeSettings current. 128910 subPixelPositioned := settings hinting not or:[settings lightHinting]]! ! 128911 128912"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 128913 128914FreeTypeFont class 128915 instanceVariableNames: ''! 128916 128917!FreeTypeFont class methodsFor: 'instance creation' stamp: 'tween 6/10/2009 12:12'! 128918forLogicalFont: aLogicalFont fileInfo: aFreeTypeFileInfoAbstract 128919 | pointSize index | 128920 pointSize := aLogicalFont pointSize. 128921 index := aFreeTypeFileInfoAbstract index. 128922 ^aFreeTypeFileInfoAbstract isEmbedded 128923 ifTrue:[ 128924 self 128925 fromBytes: aFreeTypeFileInfoAbstract fileContents 128926 pointSize: pointSize 128927 index: index] 128928 ifFalse:[ 128929 self 128930 fromFile: "aFreeTypeFileInfoAbstract absolutePath" (FreeTypeFontProvider current absolutePathFor: aFreeTypeFileInfoAbstract absoluteOrRelativePath locationType: aFreeTypeFileInfoAbstract locationType) 128931 pointSize: pointSize 128932 index: index]! ! 128933 128934!FreeTypeFont class methodsFor: 'instance creation' stamp: 'tween 7/16/2007 00:33'! 128935fromBytes: aByteArray pointSize: anInteger index: i 128936 ^self new 128937 setFace: (FreeTypeFace fromBytes: aByteArray index: i) pointSize: anInteger; 128938 yourself! ! 128939 128940!FreeTypeFont class methodsFor: 'instance creation' stamp: 'marcus.denker 12/16/2008 11:17'! 128941fromFile: aFileName pointSize: anInteger index: i 128942 ^self new 128943 setFace: (FreeTypeFace fromFile: aFileName index: i) pointSize: anInteger; 128944 yourself! ! 128945 128946!FreeTypeFont class methodsFor: 'instance creation' stamp: 'tween 9/29/2007 07:43'! 128947new 128948 128949 ^super new! ! 128950 128951 128952!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/2/2007 21:42'! 128953profileHintedComposition 128954 " 128955 self profileHintedComposition 128956 " 128957 | t f m text | 128958 Preferences enable: #HintingNone. 128959 Preferences enable: #HintingLight. "cache is now clear" 128960 t := TextStyle named: 'Arial'. 128961f := t fontOfPointSize: 12. 128962m := TextMorph new. 128963m width: 200; height: 200. 128964m backgroundColor: Color white. 128965text := 'Welcome to the finale version of 3.9 of 7 of November 2006 128966 128967You will find more recent versions at http://www.squeak.org/ 128968This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 128969 128970We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 128971 128972You can also participate to Squeak at different kinds of levels. This can be as simple as: 128973 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 128974 or in the dev list (squeak-dev@lists.squeakfoundation.org) 128975 - answering questions 128976 - finding and reporting bugs at: http://bugs.impara.de 128977 - fixing them, testing fixes and commenting them 128978 - writing tests for uncovered parts 128979 - helping for the website 128980 - creating new cool products, frameworks, applications in squeak 128981 - writing articles.... 128982 128983We wish you a lot of fun and we would like to thanks all the 128984persons that participated to make this release a really good one. 128985We know who you are!! 128986 128987 Stephane Ducasse and Marcus Denker 128988 stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. 128989text addAttribute: (TextFontReference toFont: f). 128990m contents: text. 128991m openInWorld. 128992TimeProfileBrowser onBlock: [ 128993 2 timesRepeat:[m justified; leftFlush]]. 128994m delete 128995! ! 128996 128997!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/2/2007 23:01'! 128998profileHintedDisplayCached 128999 " 129000 self profileHintedDisplayCached 129001 " 129002 | t f m text canvas | 129003 Preferences enable: #HintingNone. 129004 Preferences enable: #HintingLight. "cache is now clear" 129005 t := TextStyle named: 'Arial'. 129006f := t fontOfPointSize: 12. 129007m := TextMorph new. 129008m width: 200; height: 200. 129009m backgroundColor: Color white. 129010text := 'Welcome to the finale version of 3.9 of 7 of November 2006 129011 129012You will find more recent versions at http://www.squeak.org/ 129013This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129014 129015We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129016 129017You can also participate to Squeak at different kinds of levels. This can be as simple as: 129018 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129019 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129020 - answering questions 129021 - finding and reporting bugs at: http://bugs.impara.de 129022 - fixing them, testing fixes and commenting them 129023 - writing tests for uncovered parts 129024 - helping for the website 129025 - creating new cool products, frameworks, applications in squeak 129026 - writing articles.... 129027 129028We wish you a lot of fun and we would like to thanks all the 129029persons that participated to make this release a really good one. 129030We know who you are!! 129031 129032 Stephane Ducasse and Marcus Denker 129033 stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. 129034text addAttribute: (TextFontReference toFont: f). 129035m contents: text. 129036m openInWorld. 129037canvas := (FormCanvas on: (Form extent: 1000@1000 depth: 32)). 129038m drawOn: canvas. "this fills the cache" 129039TimeProfileBrowser onBlock: [ 129040 2 timesRepeat: [m drawOn: canvas ]]. 129041m delete 129042! ! 129043 129044!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/2/2007 23:31'! 129045profileHintedDisplayCachedUsingMode34 129046 " 129047 self profileHintedDisplayCachedUsingMode34 129048 " 129049 | t f m text canvas | 129050 Preferences enable: #HintingNone. 129051 Preferences enable: #HintingLight. "cache is now clear" 129052 t := TextStyle named: 'Arial'. 129053f := t fontOfPointSize: 12. 129054m := TextMorph new. 129055m width: 200; height: 200. 129056m backgroundColor: Color white. 129057text := 'Welcome to the finale version of 3.9 of 7 of November 2006 129058 129059You will find more recent versions at http://www.squeak.org/ 129060This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129061 129062We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129063 129064You can also participate to Squeak at different kinds of levels. This can be as simple as: 129065 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129066 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129067 - answering questions 129068 - finding and reporting bugs at: http://bugs.impara.de 129069 - fixing them, testing fixes and commenting them 129070 - writing tests for uncovered parts 129071 - helping for the website 129072 - creating new cool products, frameworks, applications in squeak 129073 - writing articles.... 129074 129075We wish you a lot of fun and we would like to thanks all the 129076persons that participated to make this release a really good one. 129077We know who you are!! 129078 129079 Stephane Ducasse and Marcus Denker 129080 stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. 129081text addAttribute: (TextFontReference toFont: f). 129082m contents: text. 129083m openInWorld. 129084FreeTypeSettings current pretendBitBltSubPixelUnavailableDuring:[ 129085 canvas := (FormCanvas on: (Form extent: 1000@1000 depth: 32)). 129086 m drawOn: canvas. "this fills the cache" 129087 TimeProfileBrowser onBlock: [ 129088 2 timesRepeat: [m drawOn: canvas ]]]. 129089m delete 129090! ! 129091 129092!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/3/2007 08:50'! 129093profileHintedWidthOfString 129094 " 129095 self profileHintedWidthOfString 129096 " 129097 | t f string | 129098 Preferences enable: #HintingNone. 129099 Preferences enable: #HintingLight. "cache is now clear" 129100 t := TextStyle named: 'Arial'. 129101 f := t fontOfPointSize: 12. 129102string := 'Welcome to the finale version of 3.9 of 7 of November 2006 129103 129104You will find more recent versions at http://www.squeak.org/ 129105This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129106 129107We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129108 129109You can also participate to Squeak at different kinds of levels. This can be as simple as: 129110 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129111 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129112 - answering questions 129113 - finding and reporting bugs at: http://bugs.impara.de 129114 - fixing them, testing fixes and commenting them 129115 - writing tests for uncovered parts 129116 - helping for the website 129117 - creating new cool products, frameworks, applications in squeak 129118 - writing articles.... 129119 129120We wish you a lot of fun and we would like to thanks all the 129121persons that participated to make this release a really good one. 129122We know who you are!! 129123 129124 Stephane Ducasse and Marcus Denker 129125 stephane.ducasse@free.fr and denker@iam.unibe.ch' . 129126 129127TimeProfileBrowser onBlock: [ 129128 200 timesRepeat:[f widthOfString: string]]. 129129! ! 129130 129131!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/3/2007 08:50'! 129132profileHintedWidthOfStringCached 129133 " 129134 self profileHintedWidthOfStringCached 129135 " 129136 | t f string | 129137 Preferences enable: #HintingNone. 129138 Preferences enable: #HintingLight. "cache is now clear" 129139 t := TextStyle named: 'Arial'. 129140 f := t fontOfPointSize: 12. 129141string := 'Welcome to the finale version of 3.9 of 7 of November 2006 129142 129143You will find more recent versions at http://www.squeak.org/ 129144This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129145 129146We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129147 129148You can also participate to Squeak at different kinds of levels. This can be as simple as: 129149 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129150 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129151 - answering questions 129152 - finding and reporting bugs at: http://bugs.impara.de 129153 - fixing them, testing fixes and commenting them 129154 - writing tests for uncovered parts 129155 - helping for the website 129156 - creating new cool products, frameworks, applications in squeak 129157 - writing articles.... 129158 129159We wish you a lot of fun and we would like to thanks all the 129160persons that participated to make this release a really good one. 129161We know who you are!! 129162 129163 Stephane Ducasse and Marcus Denker 129164 stephane.ducasse@free.fr and denker@iam.unibe.ch' . 129165f widthOfString: string. "this fills any caches" 129166TimeProfileBrowser onBlock: [ 129167 200 timesRepeat:[f widthOfString: string]]. 129168! ! 129169 129170!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/3/2007 08:54'! 129171profileHintedWidthOfStringCachedMulti 129172 " 129173 self profileHintedWidthOfStringCachedMulti 129174 " 129175 | t f string | 129176 Preferences enable: #HintingNone. 129177 Preferences enable: #HintingLight. "cache is now clear" 129178 t := TextStyle named: 'Arial'. 129179 f := t fontOfPointSize: 12. 129180string := 'Welcome to the finale version of 3.9 of 7 of November 2006 129181 129182You will find more recent versions at http://www.squeak.org/ 129183This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129184 129185We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129186 129187You can also participate to Squeak at different kinds of levels. This can be as simple as: 129188 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129189 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129190 - answering questions 129191 - finding and reporting bugs at: http://bugs.impara.de 129192 - fixing them, testing fixes and commenting them 129193 - writing tests for uncovered parts 129194 - helping for the website 129195 - creating new cool products, frameworks, applications in squeak 129196 - writing articles.... 129197 129198We wish you a lot of fun and we would like to thanks all the 129199persons that participated to make this release a really good one. 129200We know who you are!! 129201 129202 Stephane Ducasse and Marcus Denker 129203 stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString. 129204f widthOfString: string. "this fills any caches" 129205TimeProfileBrowser onBlock: [ 129206 200 timesRepeat:[f widthOfString: string]]. 129207! ! 129208 129209!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/3/2007 08:55'! 129210profileHintedWidthOfStringMulti 129211 " 129212 self profileHintedWidthOfStringMulti 129213 " 129214 | t f string | 129215 Preferences enable: #HintingNone. 129216 Preferences enable: #HintingLight. "cache is now clear" 129217 t := TextStyle named: 'Arial'. 129218 f := t fontOfPointSize: 12. 129219string := 'Welcome to the finale version of 3.9 of 7 of November 2006 129220 129221You will find more recent versions at http://www.squeak.org/ 129222This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129223 129224We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129225 129226You can also participate to Squeak at different kinds of levels. This can be as simple as: 129227 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129228 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129229 - answering questions 129230 - finding and reporting bugs at: http://bugs.impara.de 129231 - fixing them, testing fixes and commenting them 129232 - writing tests for uncovered parts 129233 - helping for the website 129234 - creating new cool products, frameworks, applications in squeak 129235 - writing articles.... 129236 129237We wish you a lot of fun and we would like to thanks all the 129238persons that participated to make this release a really good one. 129239We know who you are!! 129240 129241 Stephane Ducasse and Marcus Denker 129242 stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString. 129243 129244TimeProfileBrowser onBlock: [ 129245 200 timesRepeat:[f widthOfString: string]]. 129246! ! 129247 129248!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/2/2007 18:56'! 129249profileUnhinted 129250 " 129251 self profileUnhinted 129252 " 129253 | t f m text | 129254 t := TextStyle named: 'Arial'. 129255f := t fontOfPointSize: 12. 129256m := TextMorph new. 129257m width: 200; height: 200. 129258m backgroundColor: Color white. 129259text := 'Welcome to the finale version of 3.9 of 7 of November 2006 129260 129261You will find more recent versions at http://www.squeak.org/ 129262This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129263 129264We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129265 129266You can also participate to Squeak at different kinds of levels. This can be as simple as: 129267 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129268 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129269 - answering questions 129270 - finding and reporting bugs at: http://bugs.impara.de 129271 - fixing them, testing fixes and commenting them 129272 - writing tests for uncovered parts 129273 - helping for the website 129274 - creating new cool products, frameworks, applications in squeak 129275 - writing articles.... 129276 129277We wish you a lot of fun and we would like to thanks all the 129278persons that participated to make this release a really good one. 129279We know who you are!! 129280 129281 Stephane Ducasse and Marcus Denker 129282 stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. 129283text addAttribute: (TextFontReference toFont: f). 129284m contents: text. 129285m openInWorld. 129286TimeProfileBrowser onBlock: [m justified; leftFlush]. 129287m delete 129288! ! 129289 129290!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/2/2007 21:43'! 129291profileUnhintedComposition 129292 " 129293 self profileUnhintedComposition 129294 " 129295 | t f m text | 129296 Preferences enable: #HintingLight. 129297 Preferences enable: #HintingNone. "cache is now clear" 129298 t := TextStyle named: 'Arial'. 129299f := t fontOfPointSize: 12. 129300m := TextMorph new. 129301m width: 200; height: 200. 129302m backgroundColor: Color white. 129303text := 'Welcome to the finale version of 3.9 of 7 of November 2006 129304 129305You will find more recent versions at http://www.squeak.org/ 129306This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129307 129308We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129309 129310You can also participate to Squeak at different kinds of levels. This can be as simple as: 129311 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129312 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129313 - answering questions 129314 - finding and reporting bugs at: http://bugs.impara.de 129315 - fixing them, testing fixes and commenting them 129316 - writing tests for uncovered parts 129317 - helping for the website 129318 - creating new cool products, frameworks, applications in squeak 129319 - writing articles.... 129320 129321We wish you a lot of fun and we would like to thanks all the 129322persons that participated to make this release a really good one. 129323We know who you are!! 129324 129325 Stephane Ducasse and Marcus Denker 129326 stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. 129327text addAttribute: (TextFontReference toFont: f). 129328m contents: text. 129329m openInWorld. 129330TimeProfileBrowser onBlock: [ 129331 2 timesRepeat:[m justified; leftFlush]]. 129332m delete 129333! ! 129334 129335!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/2/2007 23:32'! 129336profileUnhintedCompositionMulti 129337 " 129338 self profileUnhintedCompositionMulti 129339 " 129340 | t f m text | 129341 Preferences enable: #HintingLight. 129342 Preferences enable: #HintingNone. "cache is now clear" 129343 t := TextStyle named: 'Arial'. 129344f := t fontOfPointSize: 12. 129345m := TextMorph new. 129346m width: 200; height: 200. 129347m backgroundColor: Color white. 129348text := ('Welcome to the finale version of 3.9 of 7 of November 2006 129349 129350You will find more recent versions at http://www.squeak.org/ 129351This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129352 129353We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129354 129355You can also participate to Squeak at different kinds of levels. This can be as simple as: 129356 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129357 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129358 - answering questions 129359 - finding and reporting bugs at: http://bugs.impara.de 129360 - fixing them, testing fixes and commenting them 129361 - writing tests for uncovered parts 129362 - helping for the website 129363 - creating new cool products, frameworks, applications in squeak 129364 - writing articles.... 129365 129366We wish you a lot of fun and we would like to thanks all the 129367persons that participated to make this release a really good one. 129368We know who you are!! 129369 129370 Stephane Ducasse and Marcus Denker 129371 stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString) asText. 129372text addAttribute: (TextFontReference toFont: f). 129373m contents: text. 129374m openInWorld. 129375TimeProfileBrowser onBlock: [ 129376 2 timesRepeat:[m justified; leftFlush]]. 129377m delete 129378! ! 129379 129380!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/2/2007 22:42'! 129381profileUnhintedDisplay 129382 " 129383 self profileUnhintedDisplay 129384 " 129385 | t f m text canvas | 129386 Preferences enable: #HintingLight. 129387 Preferences enable: #HintingNone. "cache is now clear" 129388 t := TextStyle named: 'Arial'. 129389f := t fontOfPointSize: 12. 129390m := TextMorph new. 129391m width: 200; height: 200. 129392m backgroundColor: Color white. 129393text := 'Welcome to the finale version of 3.9 of 7 of November 2006 129394 129395You will find more recent versions at http://www.squeak.org/ 129396This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129397 129398We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129399 129400You can also participate to Squeak at different kinds of levels. This can be as simple as: 129401 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129402 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129403 - answering questions 129404 - finding and reporting bugs at: http://bugs.impara.de 129405 - fixing them, testing fixes and commenting them 129406 - writing tests for uncovered parts 129407 - helping for the website 129408 - creating new cool products, frameworks, applications in squeak 129409 - writing articles.... 129410 129411We wish you a lot of fun and we would like to thanks all the 129412persons that participated to make this release a really good one. 129413We know who you are!! 129414 129415 Stephane Ducasse and Marcus Denker 129416 stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. 129417text addAttribute: (TextFontReference toFont: f). 129418m contents: text. 129419m openInWorld. 129420canvas := (FormCanvas on: (Form extent: 1000@1000 depth: 32)). 129421TimeProfileBrowser onBlock: [ 129422 2 timesRepeat: [m drawOn: canvas ]]. 129423m delete 129424! ! 129425 129426!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/2/2007 22:43'! 129427profileUnhintedDisplayCached 129428 " 129429 self profileUnhintedDisplayCached 129430 " 129431 | t f m text canvas | 129432 Preferences enable: #HintingLight. 129433 Preferences enable: #HintingNone. "cache is now clear" 129434 t := TextStyle named: 'Arial'. 129435f := t fontOfPointSize: 12. 129436m := TextMorph new. 129437m width: 200; height: 200. 129438m backgroundColor: Color white. 129439text := 'Welcome to the finale version of 3.9 of 7 of November 2006 129440 129441You will find more recent versions at http://www.squeak.org/ 129442This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129443 129444We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129445 129446You can also participate to Squeak at different kinds of levels. This can be as simple as: 129447 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129448 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129449 - answering questions 129450 - finding and reporting bugs at: http://bugs.impara.de 129451 - fixing them, testing fixes and commenting them 129452 - writing tests for uncovered parts 129453 - helping for the website 129454 - creating new cool products, frameworks, applications in squeak 129455 - writing articles.... 129456 129457We wish you a lot of fun and we would like to thanks all the 129458persons that participated to make this release a really good one. 129459We know who you are!! 129460 129461 Stephane Ducasse and Marcus Denker 129462 stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. 129463text addAttribute: (TextFontReference toFont: f). 129464m contents: text. 129465m openInWorld. 129466canvas := (FormCanvas on: (Form extent: 1000@1000 depth: 32)). 129467m drawOn: canvas. "this fills the cache" 129468TimeProfileBrowser onBlock: [ 129469 2 timesRepeat: [m drawOn: canvas ]]. 129470m delete 129471! ! 129472 129473!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/2/2007 23:41'! 129474profileUnhintedDisplayCachedMulti 129475 " 129476 self profileUnhintedDisplayCachedMulti 129477 " 129478 | t f m text canvas | 129479 Preferences enable: #HintingLight. 129480 Preferences enable: #HintingNone. "cache is now clear" 129481 t := TextStyle named: 'Arial'. 129482f := t fontOfPointSize: 12. 129483m := TextMorph new. 129484m width: 200; height: 200. 129485m backgroundColor: Color white. 129486text := ('Welcome to the finale version of 3.9 of 7 of November 2006 129487 129488You will find more recent versions at http://www.squeak.org/ 129489This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129490 129491We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129492 129493You can also participate to Squeak at different kinds of levels. This can be as simple as: 129494 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129495 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129496 - answering questions 129497 - finding and reporting bugs at: http://bugs.impara.de 129498 - fixing them, testing fixes and commenting them 129499 - writing tests for uncovered parts 129500 - helping for the website 129501 - creating new cool products, frameworks, applications in squeak 129502 - writing articles.... 129503 129504We wish you a lot of fun and we would like to thanks all the 129505persons that participated to make this release a really good one. 129506We know who you are!! 129507 129508 Stephane Ducasse and Marcus Denker 129509 stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString) asText. 129510text addAttribute: (TextFontReference toFont: f). 129511m contents: text. 129512m openInWorld. 129513canvas := (FormCanvas on: (Form extent: 1000@1000 depth: 32)). 129514m drawOn: canvas. "this fills the cache" 129515TimeProfileBrowser onBlock: [ 129516 2 timesRepeat: [m drawOn: canvas ]]. 129517m delete 129518! ! 129519 129520!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/2/2007 23:40'! 129521profileUnhintedDisplayMulti 129522 " 129523 self profileUnhintedDisplayMulti 129524 " 129525 | t f m text canvas | 129526 Preferences enable: #HintingLight. 129527 Preferences enable: #HintingNone. "cache is now clear" 129528 t := TextStyle named: 'Arial'. 129529f := t fontOfPointSize: 12. 129530m := TextMorph new. 129531m width: 200; height: 200. 129532m backgroundColor: Color white. 129533text := ('Welcome to the finale version of 3.9 of 7 of November 2006 129534 129535You will find more recent versions at http://www.squeak.org/ 129536This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129537 129538We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129539 129540You can also participate to Squeak at different kinds of levels. This can be as simple as: 129541 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129542 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129543 - answering questions 129544 - finding and reporting bugs at: http://bugs.impara.de 129545 - fixing them, testing fixes and commenting them 129546 - writing tests for uncovered parts 129547 - helping for the website 129548 - creating new cool products, frameworks, applications in squeak 129549 - writing articles.... 129550 129551We wish you a lot of fun and we would like to thanks all the 129552persons that participated to make this release a really good one. 129553We know who you are!! 129554 129555 Stephane Ducasse and Marcus Denker 129556 stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString) asText. 129557text addAttribute: (TextFontReference toFont: f). 129558m contents: text. 129559m openInWorld. 129560canvas := (FormCanvas on: (Form extent: 1000@1000 depth: 32)). 129561TimeProfileBrowser onBlock: [ 129562 2 timesRepeat: [m drawOn: canvas ]]. 129563m delete 129564! ! 129565 129566!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/3/2007 08:51'! 129567profileUnhintedWidthOfString 129568 " 129569 self profileUnhintedWidthOfString 129570 " 129571 | t f string | 129572 Preferences enable: #HintingLight. 129573 Preferences enable: #HintingNone. "cache is now clear" 129574 t := TextStyle named: 'Arial'. 129575 f := t fontOfPointSize: 12. 129576string := 'Welcome to the finale version of 3.9 of 7 of November 2006 129577 129578You will find more recent versions at http://www.squeak.org/ 129579This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129580 129581We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129582 129583You can also participate to Squeak at different kinds of levels. This can be as simple as: 129584 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129585 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129586 - answering questions 129587 - finding and reporting bugs at: http://bugs.impara.de 129588 - fixing them, testing fixes and commenting them 129589 - writing tests for uncovered parts 129590 - helping for the website 129591 - creating new cool products, frameworks, applications in squeak 129592 - writing articles.... 129593 129594We wish you a lot of fun and we would like to thanks all the 129595persons that participated to make this release a really good one. 129596We know who you are!! 129597 129598 Stephane Ducasse and Marcus Denker 129599 stephane.ducasse@free.fr and denker@iam.unibe.ch' . 129600 129601TimeProfileBrowser onBlock: [ 129602 200 timesRepeat:[f widthOfString: string]]. 129603! ! 129604 129605!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/3/2007 08:51'! 129606profileUnhintedWidthOfStringCached 129607 " 129608 self profileUnhintedWidthOfStringCached 129609 " 129610 | t f string | 129611 Preferences enable: #HintingLight. 129612 Preferences enable: #HintingNone. "cache is now clear" 129613 t := TextStyle named: 'Arial'. 129614 f := t fontOfPointSize: 12. 129615string := 'Welcome to the finale version of 3.9 of 7 of November 2006 129616 129617You will find more recent versions at http://www.squeak.org/ 129618This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129619 129620We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129621 129622You can also participate to Squeak at different kinds of levels. This can be as simple as: 129623 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129624 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129625 - answering questions 129626 - finding and reporting bugs at: http://bugs.impara.de 129627 - fixing them, testing fixes and commenting them 129628 - writing tests for uncovered parts 129629 - helping for the website 129630 - creating new cool products, frameworks, applications in squeak 129631 - writing articles.... 129632 129633We wish you a lot of fun and we would like to thanks all the 129634persons that participated to make this release a really good one. 129635We know who you are!! 129636 129637 Stephane Ducasse and Marcus Denker 129638 stephane.ducasse@free.fr and denker@iam.unibe.ch' . 129639f widthOfString: string. "this fills any caches" 129640TimeProfileBrowser onBlock: [ 129641 200 timesRepeat:[f widthOfString: string]]. 129642! ! 129643 129644!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/3/2007 08:52'! 129645profileUnhintedWidthOfStringCachedMulti 129646 " 129647 self profileUnhintedWidthOfStringCachedMulti 129648 " 129649 | t f string | 129650 Preferences enable: #HintingLight. 129651 Preferences enable: #HintingNone. "cache is now clear" 129652 t := TextStyle named: 'Arial'. 129653 f := t fontOfPointSize: 12. 129654string := 'Welcome to the finale version of 3.9 of 7 of November 2006 129655 129656You will find more recent versions at http://www.squeak.org/ 129657This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129658 129659We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129660 129661You can also participate to Squeak at different kinds of levels. This can be as simple as: 129662 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129663 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129664 - answering questions 129665 - finding and reporting bugs at: http://bugs.impara.de 129666 - fixing them, testing fixes and commenting them 129667 - writing tests for uncovered parts 129668 - helping for the website 129669 - creating new cool products, frameworks, applications in squeak 129670 - writing articles.... 129671 129672We wish you a lot of fun and we would like to thanks all the 129673persons that participated to make this release a really good one. 129674We know who you are!! 129675 129676 Stephane Ducasse and Marcus Denker 129677 stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString. 129678f widthOfString: string. "this fills any caches" 129679TimeProfileBrowser onBlock: [ 129680 200 timesRepeat:[f widthOfString: string]]. 129681! ! 129682 129683!FreeTypeFont class methodsFor: 'profiling' stamp: 'tween 4/3/2007 08:53'! 129684profileUnhintedWidthOfStringMulti 129685 " 129686 self profileUnhintedWidthOfStringMulti 129687 " 129688 | t f string | 129689 Preferences enable: #HintingLight. 129690 Preferences enable: #HintingNone. "cache is now clear" 129691 t := TextStyle named: 'Arial'. 129692 f := t fontOfPointSize: 12. 129693string := 'Welcome to the finale version of 3.9 of 7 of November 2006 129694 129695You will find more recent versions at http://www.squeak.org/ 129696This image will be used to produce other distributions such as a developer image and a fun with Squeak image. 129697 129698We hope that you will really appreciate this version and that Squeak will help you making your projects reality. 129699 129700You can also participate to Squeak at different kinds of levels. This can be as simple as: 129701 - asking questions in the beginner list (beginners@lists.squeakfoundation.org) 129702 or in the dev list (squeak-dev@lists.squeakfoundation.org) 129703 - answering questions 129704 - finding and reporting bugs at: http://bugs.impara.de 129705 - fixing them, testing fixes and commenting them 129706 - writing tests for uncovered parts 129707 - helping for the website 129708 - creating new cool products, frameworks, applications in squeak 129709 - writing articles.... 129710 129711We wish you a lot of fun and we would like to thanks all the 129712persons that participated to make this release a really good one. 129713We know who you are!! 129714 129715 Stephane Ducasse and Marcus Denker 129716 stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString. 129717 129718TimeProfileBrowser onBlock: [ 129719 200 timesRepeat:[f widthOfString: string]]. 129720! ! 129721FontFamilyAbstract subclass: #FreeTypeFontFamily 129722 instanceVariableNames: '' 129723 classVariableNames: '' 129724 poolDictionaries: '' 129725 category: 'FreeType-FontManager'! 129726 129727!FreeTypeFontFamily methodsFor: 'accessing' stamp: 'tween 8/25/2007 14:26'! 129728addMember: aFreeTypeFontFamilyMember 129729 aFreeTypeFontFamilyMember family: self. 129730 members add: aFreeTypeFontFamilyMember! ! 129731 129732!FreeTypeFontFamily methodsFor: 'accessing' stamp: 'tween 8/16/2007 22:58'! 129733addMembersFromFileInfos: aCollectionOfFreeTypeFileInfo 129734 129735 | member | 129736 aCollectionOfFreeTypeFileInfo do:[:aFileInfo | 129737 member := FreeTypeFontFamilyMember fromFileInfo: aFileInfo. 129738 (self memberWithStyleName: member styleName) 129739 ifNil:[self addMember: member]]. 129740 ! ! 129741 129742!FreeTypeFontFamily methodsFor: 'accessing' stamp: 'tween 8/16/2007 22:59'! 129743memberWithStyleName: aString 129744 ^members detect:[:each | each styleName = aString] ifNone:[] 129745! ! 129746 129747 129748!FreeTypeFontFamily methodsFor: 'initialize-release' stamp: 'tween 8/16/2007 20:44'! 129749initialize 129750 super initialize. 129751 members := OrderedCollection new.! ! 129752 129753 129754!FreeTypeFontFamily methodsFor: 'simulated members' stamp: 'tween 9/29/2007 12:57'! 129755addSimulatedMembers 129756 | membersBySlantAndStretch heaviest membersByWeightAndStretch regular oblique | 129757 membersBySlantAndStretch := Dictionary new. 129758 members do:[:each| 129759 (membersBySlantAndStretch 129760 at: {each slantValue. each stretchValue} 129761 ifAbsentPut:[OrderedCollection new]) 129762 add: each]. 129763 membersBySlantAndStretch keysAndValuesDo:[:key :col | 129764 heaviest := col ifNotEmpty:[col first]. 129765 col do:[:each | 129766 heaviest weightValue < each weightValue 129767 ifTrue:[heaviest := each]]. 129768 (heaviest weightValue between: (LogicalFont weightRegular - 50) and: (LogicalFont weightMedium + 50)) 129769 ifTrue:[ members add: heaviest asSimulatedBold]]. 129770 membersByWeightAndStretch := Dictionary new. 129771 members do:[:each| | normalizedWeight | 129772 normalizedWeight := each weightValue. 129773 each weightValue = LogicalFont weightMedium ifTrue:[normalizedWeight := LogicalFont weightRegular]. 129774 "regular and medium weights are used interchangeably. 129775 For example, FreeSans has Regular-weightMedium(500), and Oblique-weightRegular(400). 129776 We don't want to simulate oblique-weightMedium(500) when a real 129777 Oblique-weightMedium(500) exists, so we normalize any weightMedium(500) 129778 values to weightRegular(400) to prevent this happening" 129779 (membersByWeightAndStretch 129780 at: {normalizedWeight. each stretchValue} 129781 ifAbsentPut:[OrderedCollection new]) 129782 add: each]. 129783 membersByWeightAndStretch keysAndValuesDo:[:key :col | 129784 regular := col detect: [:each | each slantValue = 0] ifNone:[]. 129785 oblique := col detect:[:each | each slantValue > 0] ifNone:[]. "oblique or italic" 129786 (oblique isNil and:[regular notNil]) 129787 ifTrue:[ 129788 regular simulated 129789 ifTrue:[members add: regular asSimulatedBoldOblique] 129790 ifFalse:[ members add: regular asSimulatedOblique]]]! ! 129791 129792!FreeTypeFontFamily methodsFor: 'simulated members' stamp: 'tween 8/18/2007 22:22'! 129793rebuildSimulatedMembers 129794 "FOR TESTING ONLY" 129795 129796 members := members reject:[:each| each simulated]. 129797 self addSimulatedMembers.! ! 129798FontFamilyMemberAbstract subclass: #FreeTypeFontFamilyMember 129799 instanceVariableNames: 'fileInfo stretchName stretchValue weightName weightValue slantName slantValue simulated' 129800 classVariableNames: '' 129801 poolDictionaries: '' 129802 category: 'FreeType-FontManager'! 129803 129804!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:46'! 129805fileInfo 129806 "Answer the value of fileInfo" 129807 129808 ^ fileInfo! ! 129809 129810!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:46'! 129811fileInfo: anObject 129812 "Set the value of fileInfo" 129813 129814 fileInfo := anObject! ! 129815 129816!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129817simulated 129818 "Answer the value of simulated" 129819 129820 ^ simulated! ! 129821 129822!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129823simulated: anObject 129824 "Set the value of simulated" 129825 129826 simulated := anObject! ! 129827 129828!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129829slantName 129830 "Answer the value of slantName" 129831 129832 ^ slantName! ! 129833 129834!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129835slantName: anObject 129836 "Set the value of slantName" 129837 129838 slantName := anObject! ! 129839 129840!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129841slantValue 129842 "Answer the value of slantValue" 129843 129844 ^ slantValue! ! 129845 129846!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129847slantValue: anObject 129848 "Set the value of slantValue" 129849 129850 slantValue := anObject! ! 129851 129852!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129853stretchName 129854 "Answer the value of stretchName" 129855 129856 ^ stretchName! ! 129857 129858!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129859stretchName: anObject 129860 "Set the value of stretchName" 129861 129862 stretchName := anObject! ! 129863 129864!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129865stretchValue 129866 "Answer the value of stretchValue" 129867 129868 ^ stretchValue! ! 129869 129870!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129871stretchValue: anObject 129872 "Set the value of stretchValue" 129873 129874 stretchValue := anObject! ! 129875 129876!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129877weightName 129878 "Answer the value of weightName" 129879 129880 ^ weightName! ! 129881 129882!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129883weightName: anObject 129884 "Set the value of weightName" 129885 129886 weightName := anObject! ! 129887 129888!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129889weightValue 129890 "Answer the value of weightValue" 129891 129892 ^ weightValue! ! 129893 129894!FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! 129895weightValue: anObject 129896 "Set the value of weightValue" 129897 129898 weightValue := anObject! ! 129899 129900 129901!FreeTypeFontFamilyMember methodsFor: 'comparing' stamp: 'tween 8/16/2007 23:23'! 129902<= aFreeTypeFontFamilyMember 129903 ^self sortValue <= aFreeTypeFontFamilyMember sortValue! ! 129904 129905!FreeTypeFontFamilyMember methodsFor: 'comparing' stamp: 'tween 9/29/2007 12:51'! 129906sortValue 129907 | v normalizedWeight | 129908 normalizedWeight := weightValue. 129909 normalizedWeight = LogicalFont weightMedium 129910 ifTrue:["sort medium and regular weights as though they were the same" 129911 normalizedWeight := LogicalFont weightRegular]. 129912 v :=self simulated ifTrue:[10000] ifFalse:[0]. 129913 v := v + (stretchValue * 1000). 129914 v := v + (normalizedWeight). 129915 v := v + (slantValue). 129916 ^v 129917! ! 129918 129919 129920!FreeTypeFontFamilyMember methodsFor: 'copying' stamp: 'tween 9/29/2007 12:49'! 129921asSimulatedBold 129922 ^self copy 129923 weightValue: LogicalFont weightBold; 129924 styleName: (fileInfo styleNameWithWeightForcedToBe: 'Bold'); 129925 simulated: true; 129926 yourself! ! 129927 129928!FreeTypeFontFamilyMember methodsFor: 'copying' stamp: 'tween 9/29/2007 12:50'! 129929asSimulatedBoldOblique 129930 ^self copy 129931 slantValue: LogicalFont slantItalic; "treat italic and oblique the same" 129932 weightValue:LogicalFont weightBold; 129933 styleName: (fileInfo styleNameWithWeightForcedToBe: 'Bold' italicForcedToBe: 'Oblique'); 129934 simulated: true; 129935 yourself! ! 129936 129937!FreeTypeFontFamilyMember methodsFor: 'copying' stamp: 'tween 9/29/2007 12:50'! 129938asSimulatedOblique 129939 ^self copy 129940 slantValue: LogicalFont slantItalic; "treat italic and oblique the same" 129941 styleName: (fileInfo styleNameWithItalicForcedToBe: 'Oblique'); 129942 simulated: true; 129943 yourself! ! 129944 129945"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 129946 129947FreeTypeFontFamilyMember class 129948 instanceVariableNames: ''! 129949 129950!FreeTypeFontFamilyMember class methodsFor: 'instance creation' stamp: 'tween 8/16/2007 21:39'! 129951fromFileInfo: aFreeTypeFileInfo 129952 129953 ^self new 129954 fileInfo: aFreeTypeFileInfo; 129955 simulated: false; 129956 styleName: aFreeTypeFileInfo styleNameExtracted; 129957 stretchName: aFreeTypeFileInfo stretch; 129958 stretchValue: aFreeTypeFileInfo stretchValue; 129959 weightName: aFreeTypeFileInfo weight; 129960 weightValue: aFreeTypeFileInfo weightValue; 129961 slantName: aFreeTypeFileInfo slant; 129962 slantValue: aFreeTypeFileInfo slantValue; 129963 yourself 129964 ! ! 129965FontProviderAbstract subclass: #FreeTypeFontProvider 129966 instanceVariableNames: 'fileInfos fileInfoCache tempFileInfos embeddedFileInfoCache families tempFamilies' 129967 classVariableNames: '' 129968 poolDictionaries: '' 129969 category: 'FreeType-FontManager'! 129970!FreeTypeFontProvider commentStamp: 'tween 3/15/2007 17:23' prior: 0! 129971A FreeTypeFontProvider is xxxxxxxxx. 129972 129973Instance Variables 129974 fontInfoCache: <Object> 129975 fontInfos: <Object> 129976 129977fontInfoCache 129978 - xxxxx 129979 129980fontInfos 129981 - set of FreeTypeFontInfo. Info about all the fonts that are available 129982! 129983 129984 129985!FreeTypeFontProvider methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:39'! 129986addFileInfo: aFreeTypeFileInfo index: i 129987 fileInfos add: aFreeTypeFileInfo 129988 129989 129990 129991 129992 129993 129994 129995 129996 ! ! 129997 129998!FreeTypeFontProvider methodsFor: 'accessing' stamp: 'tween 7/28/2007 13:28'! 129999addFirstFileInfo: aFreeTypeFileInfo index: i 130000 fileInfos addFirst: aFreeTypeFileInfo 130001 130002 130003 130004 130005 130006 130007 130008 130009 ! ! 130010 130011!FreeTypeFontProvider methodsFor: 'accessing' stamp: 'tween 8/12/2007 12:31'! 130012addFromFileContents: bytes baseName: originalFileBaseName 130013 | i face numFaces info externalMem cachedInfo cachedNumFaces | 130014 130015 i:= 0. 130016 [(cachedInfo := self validEmbeddedCachedInfoFor: bytes index: i) notNil] 130017 whileTrue:[ 130018 i = 0 ifTrue:[cachedNumFaces := cachedInfo numFaces]. 130019 self addFirstFileInfo: cachedInfo index: i. 130020 i := i + 1.]. 130021 (cachedNumFaces notNil and:[i >= cachedNumFaces]) ifTrue:[^self]. 130022 [externalMem := FreeTypeExternalMemory bytes: bytes. 130023 externalMem validate. 130024 face := FreeTypeFace basicNew fileContentsExternalMemory: externalMem . 130025 [ "we use the primNewFaceFromFile:index: method because we want to do this as fast as possible and we don't need the face registered because it will be explicitly destroyed later" 130026 face primNewFaceFromExternalMemory: externalMem size: bytes size index: i. 130027 face loadFields] 130028 on: FT2Error 130029 do:[:e | 130030 self failedToOpen:face index: i. 130031 ^externalMem destroyHandle.]. 130032 (face height notNil and:[face hasFamilyName and:[face hasStyleName and:[face isValid]]]) 130033 ifFalse:[ 130034 self failedToOpen:face index: i. 130035 ^externalMem destroyHandle.] 130036 ifTrue:[ 130037 numFaces isNil ifTrue:[numFaces := face numFaces]. 130038 info :=FreeTypeEmbeddedFileInfo new 130039 baseName: originalFileBaseName; 130040 fileContents: bytes; 130041 index: i; 130042 familyName: face familyName; 130043 styleName: face styleName; 130044 postscriptName: face postscriptName; 130045 bold: face isBold; 130046 italic: face isItalic; 130047 fixedWidth: face isFixedWidth; 130048 numFaces: numFaces; 130049 extractAttributesFromNames; 130050 yourself. 130051 self addFirstFileInfo: info index: i. 130052 self cacheEmbeddedFileInfo: info index: i. 130053 "Transcript show: 'from file : ', info asString." 130054 face destroyHandle. 130055 externalMem destroyHandle]. 130056 i := i + 1. 130057 i < numFaces "note, we use < rather than <= , because i is zero based"] whileTrue:[]. 130058 130059 130060 130061 130062 130063 130064 130065 130066 ! ! 130067 130068!FreeTypeFontProvider methodsFor: 'accessing' stamp: 'tween 7/28/2007 13:50'! 130069cacheEmbeddedFileInfo: aFreeTypeEmbeddedFileInfo index: i 130070 130071 (embeddedFileInfoCache at: {aFreeTypeEmbeddedFileInfo fileSize. i} ifAbsentPut:[Set new]) 130072 add: aFreeTypeEmbeddedFileInfo 130073 130074 130075 130076 130077 130078 130079 130080 130081 ! ! 130082 130083!FreeTypeFontProvider methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:41'! 130084cacheFileInfo: aFreeTypeFileInfo index: i 130085 130086 (fileInfoCache at: {aFreeTypeFileInfo fileSize. i} ifAbsentPut:[Set new]) 130087 add: aFreeTypeFileInfo 130088 130089 130090 130091 130092 130093 130094 130095 130096 ! ! 130097 130098!FreeTypeFontProvider methodsFor: 'accessing' stamp: 'tween 7/15/2007 23:45'! 130099fileInfosByFamilyAndGroup 130100 "Answer a Dictionary of Dictionaries of Sets. 130101 familyName->familyGroupName->Set(FreeTypeFileInfo) 130102 130103 self current fileInfosByFamilyAndGroup 130104 " 130105 | answer family group | 130106 answer := Dictionary new. 130107 "file could be in fileInfos twice? 130108 need to only process once, need directory precedence?" 130109 fileInfos do:[:info | 130110 family := answer at: info familyName ifAbsentPut:[Dictionary new]. 130111 group := family at: info familyGroupName ifAbsentPut: [OrderedCollection new]. 130112 group 130113 detect:[:each| 130114 each bold = info bold 130115 and:[ each italic = info italic 130116 and:[each fixedWidth = info fixedWidth 130117 and:[ each postscriptName = info postscriptName 130118 and:[each styleName = info styleName]]]]] 130119 ifNone:[group add: info]]. 130120 ^answer ! ! 130121 130122 130123!FreeTypeFontProvider methodsFor: 'error handling' stamp: 'tween 3/16/2007 12:04'! 130124failedToOpen:face from: path index: i 130125 face destroyHandle. 130126 "Transcript cr; show: 'Failed : ', path asString, '[', i asString,']'." 130127 "remove all cache entries for path with index >= i" 130128 130129 130130 130131 130132 130133 ! ! 130134 130135!FreeTypeFontProvider methodsFor: 'error handling' stamp: 'tween 7/28/2007 12:36'! 130136failedToOpen:face index: i 130137 face destroyHandle. 130138 "Transcript cr; show: 'Failed : ', path asString, '[', i asString,']'." 130139 "remove all cache entries for path with index >= i" 130140 130141 130142 130143 130144 130145 ! ! 130146 130147 130148!FreeTypeFontProvider methodsFor: 'file paths' stamp: 'tween 3/15/2007 19:06'! 130149absoluteOrRelativePathFor: absolutePath locationType: aSymbol 130150 "answer a relative path from an absolute path according to the location type aSymbol" 130151 | p | 130152 130153 aSymbol = #absolute ifTrue:[^absolutePath]. 130154 aSymbol = #imageRelative ifTrue:[p := SmalltalkImage current imagePath]. 130155 aSymbol = #vmRelative ifTrue:[p := SmalltalkImage current vmPath]. 130156 (p notNil and:[absolutePath asLowercase beginsWith: p asLowercase]) 130157 ifTrue:[^absolutePath copyFrom: p size + 1 to: absolutePath size]. 130158 ^absolutePath 130159 130160 130161 130162 130163 130164 ! ! 130165 130166!FreeTypeFontProvider methodsFor: 'file paths' stamp: 'tween 3/16/2007 11:02'! 130167absolutePathFor: path locationType: aSymbol 130168 "answer an absolute path from an absolute or relative path according to the location type aSymbol" 130169 130170 aSymbol = #imageRelative 130171 ifTrue:[^SmalltalkImage current imagePath, FileDirectory slash, path ]. 130172 aSymbol = #vmRelative 130173 ifTrue:[^SmalltalkImage current vmPath ", FileDirectory slash" , path]. 130174 ^path 130175 130176 130177 130178 130179 130180 ! ! 130181 130182!FreeTypeFontProvider methodsFor: 'file paths' stamp: 'tween 4/28/2007 10:49'! 130183getMacOSXFontFolderPaths 130184 "Answer the Mac OS X font folder paths. 130185 This needs some FFI code, but for the time being, we guess these and omit the user fonts folder" 130186 130187 ^#('/System/Library/Fonts' '/Library/Fonts')! ! 130188 130189!FreeTypeFontProvider methodsFor: 'file paths' stamp: 'tween 4/13/2007 08:25'! 130190getUnixFontFolderPaths 130191 "Answer the unix/linux font folder paths" 130192 ^#('/usr/share/fonts' '/usr/local/share/fonts')! ! 130193 130194!FreeTypeFontProvider methodsFor: 'file paths' stamp: 'tween 3/25/2007 14:48'! 130195getWindowsFontFolderPath 130196 "Answer the windows font folder path. 130197 This is obtained through the Windows API if FFI is present, 130198 otherwise it is a guess !!" 130199 | externalLibraryClass externalTypeClass fun buff r | 130200 130201 externalLibraryClass := Smalltalk at: #ExternalLibraryFunction ifAbsent:[]. 130202 externalTypeClass := Smalltalk at: #ExternalType ifAbsent:[]. 130203 (externalLibraryClass isNil or:[externalTypeClass isNil]) 130204 ifTrue:[^self guessWindowsFontFolderPath]. 130205 fun := externalLibraryClass 130206 name: 'SHGetFolderPathA' 130207 module: 'shfolder.dll' 130208 callType: 1 130209 returnType: externalTypeClass long 130210 argumentTypes: { 130211 externalTypeClass long. 130212 externalTypeClass long. 130213 externalTypeClass long. 130214 externalTypeClass long. 130215 externalTypeClass char asPointerType}. 130216 buff := ByteArray new: 1024. 130217 [r := fun 130218 invokeWith: 0 130219 with: "CSIDL:=FONTS" 16r0014 130220 with: 0 130221 with: 0 130222 with: buff] on: Error do: [:e | 130223 "will get error if ffiplugin is missing" 130224 ^self guessWindowsFontFolderPath]. 130225 ^(buff copyFrom: 1 to: (buff indexOf: 0) - 1) asString ! ! 130226 130227!FreeTypeFontProvider methodsFor: 'file paths' stamp: 'tween 3/25/2007 14:25'! 130228guessWindowsFontFolderPath 130229 "Guess the location of the Windows font folder" 130230 | possibles d | 130231 130232 possibles := Set new. 130233 'cdefghijklmnopqrstuvwxyz' do:[:drive | 130234 #('\windows\fonts' '\winnt\fonts') do:[:path | 130235 (d := FileDirectory on: drive asString, ':', path) exists 130236 ifTrue:[possibles add: d]]]. 130237 possibles := possibles asSortedCollection: [:a :b | a directoryEntry creationTime >= b directoryEntry creationTime]. 130238 possibles ifNotEmpty:[^possibles first pathName]. 130239 ^nil 130240 130241 130242 ! ! 130243 130244!FreeTypeFontProvider methodsFor: 'file paths' stamp: 'tween 4/28/2007 11:09'! 130245platformAbsoluteDirectories 130246 | answer dir path | 130247 130248 answer := OrderedCollection new. 130249 SmalltalkImage current platformName = 'Win32' 130250 ifTrue:[ 130251 path := self getWindowsFontFolderPath. 130252 (path notNil and:[(dir := FileDirectory on: path) exists]) 130253 ifTrue:[answer add: dir]]. 130254 SmalltalkImage current platformName = 'unix' 130255 ifTrue:[ 130256 self getUnixFontFolderPaths do:[:each | 130257 (dir := FileDirectory on: each) exists 130258 ifTrue:[answer add: dir]]]. 130259 SmalltalkImage current platformName = 'Mac OS' 130260 ifTrue:[ 130261 SmalltalkImage current osVersion asNumber >= 1000 130262 ifTrue:["OS X" 130263 self getMacOSXFontFolderPaths do:[:each | 130264 (dir := FileDirectory on: each) exists 130265 ifTrue:[answer add: dir]]]]. 130266 ^answer! ! 130267 130268!FreeTypeFontProvider methodsFor: 'file paths' stamp: 'tween 3/26/2007 22:57'! 130269platformImageRelativeDirectories 130270 | answer path fontDirectory | 130271 130272 answer := OrderedCollection new. 130273 (path := SmalltalkImage current imagePath) 130274 ifNotEmpty:[ 130275 (path endsWith: FileDirectory slash) ifFalse:[path := path, FileDirectory slash]. 130276 (fontDirectory := FileDirectory on: path, 'Fonts') exists 130277 ifTrue:[answer addLast: fontDirectory]]. 130278 ^answer! ! 130279 130280!FreeTypeFontProvider methodsFor: 'file paths' stamp: 'tween 3/26/2007 22:58'! 130281platformVMRelativeDirectories 130282 | answer path fontDirectory | 130283 130284 answer := OrderedCollection new. 130285 (path := SmalltalkImage current vmPath) 130286 ifNotEmpty:[ 130287 (path endsWith: FileDirectory slash) ifFalse:[path := path, FileDirectory slash]. 130288 (fontDirectory := FileDirectory on: path, 'Fonts') exists 130289 ifTrue:[answer addLast: fontDirectory]]. 130290 ^answer! ! 130291 130292 130293!FreeTypeFontProvider methodsFor: 'font families' stamp: 'tween 8/16/2007 20:39'! 130294buildFamilies 130295 | familyNames family | 130296 families := Dictionary new. 130297 familyNames := (fileInfos collect:[:each | each familyGroupName]) asSet asSortedCollection asArray. 130298 familyNames do:[:familyName | 130299 family := self buildFamilyNamed: familyName. 130300 families at: familyName put: family]. 130301 130302 130303 130304 ! ! 130305 130306!FreeTypeFontProvider methodsFor: 'font families' stamp: 'tween 8/16/2007 21:43'! 130307buildFamilyNamed: aFamilyGroupName 130308 | infos family| 130309 family := FreeTypeFontFamily new 130310 familyName: aFamilyGroupName; 130311 yourself. 130312 infos := fileInfos select:[:each | each familyGroupName = aFamilyGroupName]. 130313 family addMembersFromFileInfos: infos. 130314 family addSimulatedMembers. 130315 ^family 130316 130317 130318 130319 ! ! 130320 130321!FreeTypeFontProvider methodsFor: 'font families' stamp: 'tween 8/18/2007 14:19'! 130322families 130323 130324 ^tempFamilies ifNil:[families]! ! 130325 130326 130327!FreeTypeFontProvider methodsFor: 'font lookup' stamp: 'tween 9/29/2007 10:48'! 130328fontFor: aLogicalFont familyName: familyName 130329 | info answer simulatedSqueakEmphasis needsSimulatedBold needsSimulatedSlant 130330 squeakBoldEmphasis squeakItalicEmphasis | 130331 130332 FT2Library current == nil ifTrue:[^nil]. 130333 info:= self fontInfoFor: aLogicalFont familyName: familyName. 130334 info ifNil:[^nil]. 130335 answer := FreeTypeFont forLogicalFont: aLogicalFont fileInfo: info. 130336 needsSimulatedBold := aLogicalFont isBoldOrBolder and:[(info isBolderThan: 500) not]. 130337 needsSimulatedSlant := aLogicalFont isItalicOrOblique and: [info isItalicOrOblique not]. 130338 (needsSimulatedBold or:[needsSimulatedSlant]) 130339 ifTrue:[ 130340 squeakBoldEmphasis := 1. 130341 squeakItalicEmphasis := 2. 130342 simulatedSqueakEmphasis := 0. 130343 needsSimulatedBold 130344 ifTrue:[ 130345 simulatedSqueakEmphasis := simulatedSqueakEmphasis + squeakBoldEmphasis]. 130346 needsSimulatedSlant 130347 ifTrue:[ 130348 simulatedSqueakEmphasis := simulatedSqueakEmphasis + squeakItalicEmphasis]. 130349 answer simulatedEmphasis: simulatedSqueakEmphasis]. 130350 answer face validate. 130351 answer face isValid ifFalse:[^nil]. "we may get this if startup causes text display BEFORE receiver has been updated from the system" 130352 ^answer! ! 130353 130354!FreeTypeFontProvider methodsFor: 'font lookup' stamp: 'tween 8/27/2007 11:33'! 130355fontInfoFor: aLogicalFont familyName: familyName 130356 | family member | 130357 130358 "use tempFileInfos if not nil, i.e. during an update" 130359 "^self fontInfoFor: aLogicalFont in: (tempFileInfos ifNil:[fileInfos]) " 130360 family := self families at: familyName ifAbsent:[]. 130361 family ifNil:[^nil]. 130362 member := family 130363 closestMemberWithStretchValue: aLogicalFont stretchValue 130364 weightValue: aLogicalFont weightValue 130365 slantValue: aLogicalFont slantValue. 130366 member ifNil:[^nil]. 130367 ^member fileInfo! ! 130368 130369 130370!FreeTypeFontProvider methodsFor: 'initialize-release' stamp: 'DamienCassou 8/22/2009 15:14'! 130371initialize 130372 super initialize. 130373 fileInfos := OrderedCollection new: 100. 130374 fileInfoCache := Dictionary new: 100. "keyed by file size" 130375 embeddedFileInfoCache := Dictionary new: 10. "keyed by file size" 130376 families := Dictionary new. 130377 ! ! 130378 130379 130380!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'tween 7/28/2007 14:22'! 130381embedFilesInDirectory: aFileDirectory 130382 "embed all the files in aFileDirectory 130383 130384 FreeTypeFontProvider current embedFilesInDirectory: (FileDirectory default directoryNamed: 'Fonts') 130385 " 130386 | filestream bytes basename | 130387 aFileDirectory fileNames do:[:filename | 130388 filestream := aFileDirectory fileNamed: filename. 130389 filestream binary. 130390 bytes := filestream contents. 130391 filestream close. 130392 basename := FileDirectory baseNameFor: filename. 130393 self addFromFileContents: bytes baseName: basename]. 130394 "update so that missing text styles are created." 130395 self updateFromSystem. 130396 "clear all the logicalFonts realFonts so that embedded fonts take precedence over external ones" 130397 LogicalFont allInstances do:[:logFont | logFont clearRealFont] 130398 ! ! 130399 130400!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'tween 3/14/2007 23:17'! 130401loadFromSystem 130402 self updateFromSystem. 130403 ! ! 130404 130405!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'tween 3/29/2007 17:16'! 130406updateFromDirectory: aDirectory locationType: aSymbol done: aSet 130407 "get info from fonts in aDirectory" 130408 130409 (aSet includes: aDirectory) ifTrue:[^self]. 130410 aSet add: aDirectory. 130411 aDirectory entries do:[:each | 130412 each isDirectory ifFalse:[ 130413 "SUSE 10.2 has lots of files ending .gz that aren't fonts. 130414 We skip them to save time'" 130415 ((each name beginsWith:'.') or:[each name asLowercase endsWith:'.gz']) 130416 ifFalse:[ 130417 self updateFromFileEntry: each directory: aDirectory locationType: aSymbol]]]. 130418 aDirectory entries do:[:each | 130419 each isDirectory ifTrue:[ 130420 self updateFromDirectory: (aDirectory directoryNamed: each name) locationType: aSymbol done: aSet]]. 130421 130422 130423 ! ! 130424 130425!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'tween 8/12/2007 12:31'! 130426updateFromFileEntry: aDirectoryEntry directory: aFileDirectory locationType: aSymbol 130427 | i face numFaces cachedInfo info cachedNumFaces path | 130428 "(path findString: '\\') > 0 ifTrue:[self halt]." 130429 i:= 0. 130430 [(cachedInfo := self validCachedInfoFor: aDirectoryEntry directory: aFileDirectory index: i) notNil] 130431 whileTrue:[ 130432 i = 0 ifTrue:[cachedNumFaces := cachedInfo numFaces]. 130433 self addFileInfo: cachedInfo index: i. 130434 i := i + 1.]. 130435 (cachedNumFaces notNil and:[i >= cachedNumFaces]) ifTrue:[^self]. 130436 path := aFileDirectory fullNameFor: aDirectoryEntry name . 130437 [face := FreeTypeFace basicNew filename: path; index: i. 130438 ["we use the primNewFaceFromFile:index: method because we want to do this as fast as possible and we don't need the face registered because it will be explicitly destroyed later" 130439 face primNewFaceFromFile: path index: i. 130440 face loadFields] 130441 on: FT2Error 130442 do:[:e | ^self failedToOpen:face from: path index: i]. 130443 (face height notNil and:[face hasFamilyName and:[face hasStyleName and:[face isValid]]]) 130444 ifFalse:[^self failedToOpen:face from: path index: i] 130445 ifTrue:[ 130446 numFaces isNil ifTrue:[numFaces := face numFaces]. 130447 info :=FreeTypeFileInfo new 130448 absoluteOrRelativePath: (self absoluteOrRelativePathFor: path locationType: aSymbol); 130449 absolutePath: path; "used for quick lookup on same platform" 130450 locationType: aSymbol; 130451 index: i; 130452 fileSize: aDirectoryEntry fileSize; 130453 modificationTime: aDirectoryEntry modificationTime; 130454 familyName: face familyName; 130455 styleName: face styleName; 130456 postscriptName: face postscriptName; 130457 bold: face isBold; 130458 italic: face isItalic; 130459 fixedWidth: face isFixedWidth; 130460 numFaces: numFaces; 130461 extractAttributesFromNames; 130462 yourself. 130463 self addFileInfo: info index: i. 130464 self cacheFileInfo: info index: i. 130465 "Transcript show: 'from file : ', info asString." 130466 face destroyHandle]. 130467 i := i + 1. 130468 i < numFaces "note, we use < rather than <= , because i is zero based"] whileTrue:[]. 130469 130470 130471 130472 130473 130474 130475 130476 130477 ! ! 130478 130479!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'tween 8/19/2007 16:57'! 130480updateFromSystem 130481 | done platformDirs vmDirs imageDirs i | 130482 130483 i := 0. 130484 tempFileInfos := fileInfos. "tempFileInfos will be used during update" 130485 tempFamilies := families. "tempFamilies will be used during update" 130486 fileInfos := OrderedCollection new: 100. 130487 'FreeType' displayProgressAt: Display center from: 0 to: 3 during:[:mainBar | 130488 'Updating cached file info' displayProgressAt: Display center from: 0 to: fileInfoCache size during:[:bar | 130489 fileInfoCache valuesDo:[:col | 130490 col copy do:[:each | | dir | 130491 dir := FileDirectory on: (FileDirectory dirPathFor: each absolutePath). 130492 (dir exists not or:[(dir isAFileNamed: (dir localNameFor: each absolutePath)) not]) 130493 ifTrue:[col remove: each]]. 130494 bar value: (i := i + 1).]]. 130495 mainBar value: 1. 130496 FT2Library current == nil 130497 ifFalse:[ 130498 "Add all the embedded file infos" 130499 embeddedFileInfoCache valuesDo:[:eachSet | 130500 eachSet do:[:each | fileInfos addFirst: each]]. 130501 done := Set new. "visited directories are tracked in done, so that they are not processed twice" 130502 platformDirs := self platformAbsoluteDirectories. 130503 vmDirs := self platformVMRelativeDirectories. 130504 imageDirs := self platformImageRelativeDirectories. 130505 i := 0. 130506 'Loading font files' displayProgressAt: Display center from: 0 to: 3 during:[:bar | 130507 imageDirs do:[:each | 130508 self updateFromDirectory: each locationType: #imageRelative done: done ]. 130509 bar value: (i := i + 1). 130510 vmDirs do:[:each | 130511 self updateFromDirectory: each locationType: #vmRelative done: done ]. 130512 bar value: (i := i + 1). 130513 platformDirs do:[:each | 130514 self updateFromDirectory: each locationType: #absolute done: done ]. 130515 bar value: (i := i + 1) ]]. 130516 mainBar value: 2. 130517 i := 0. 130518 'Calculating available font families' displayProgressAt: Display center from: 0 to: 1 during:[:bar | 130519 "self removeUnavailableTextStyles." 130520 "self addTextStylesWithPointSizes: #(8 10 12 15 24)." 130521 tempFileInfos := nil. 130522 self buildFamilies. 130523 tempFamilies := nil. 130524 bar value: (i := i + 1)]. 130525 mainBar value: 3]. 130526 LogicalFont allInstances do:[:each | each clearRealFont]. "in case they have a bad one" 130527 ! ! 130528 130529!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'tween 3/17/2007 10:16'! 130530validCachedInfoFor: aDirectoryEntry directory: aFileDirectory index: i 130531 "answer info from cache if the file on the disk has the same size/timestamp as the cached info, otherwise answer nil" 130532 | cacheEntry fileSize modificationTime path| 130533 130534 fileSize := aDirectoryEntry fileSize. 130535 modificationTime := aDirectoryEntry modificationTime. 130536 cacheEntry := (fileInfoCache at: {fileSize. i} ifAbsentPut:[Set new]) 130537 detect:[:each | 130538 path := path ifNil:["only build path when needed" aFileDirectory fullNameFor: aDirectoryEntry name]. 130539 each modificationTime = modificationTime 130540 and: [(self absolutePathFor: each absoluteOrRelativePath locationType: each locationType) = path]] 130541 ifNone:[]. 130542 "cacheEntry ifNotNil:[Transcript cr; show: 'from cache : ', cacheEntry asString]." 130543 ^cacheEntry 130544 ! ! 130545 130546!FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'tween 7/28/2007 13:34'! 130547validEmbeddedCachedInfoFor: bytes index: i 130548 "answer info from cache if the bytes are the same as the cached info, otherwise answer nil" 130549 | cacheEntry fileSize | 130550 130551 fileSize := bytes size. 130552 cacheEntry := (embeddedFileInfoCache at: {fileSize. i} ifAbsentPut:[Set new]) 130553 detect:[:each | each fileContents = bytes] 130554 ifNone:[]. 130555 ^cacheEntry 130556 ! ! 130557 130558"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 130559 130560FreeTypeFontProvider class 130561 instanceVariableNames: 'current'! 130562 130563!FreeTypeFontProvider class methodsFor: 'accessing' stamp: 'tween 3/23/2007 09:59'! 130564current 130565 " 130566 current := nil. 130567 TimeProfileBrowser onBlock: [FreeTypeFontProvider current] 130568 " 130569 ^current 130570 ifNil:[ 130571 current := self new. 130572 current updateFromSystem]! ! 130573 130574 130575!FreeTypeFontProvider class methodsFor: 'class initialization' stamp: 'tween 2/5/2008 22:42'! 130576initialize 130577 " 130578 self initialize 130579 " 130580 Smalltalk removeFromStartUpList: self. 130581 Smalltalk addToStartUpList: self after: SecurityManager. "actually it needs to be before AutoStart" 130582 130583 "ensure that other classes have also been initialized by forcefully initializing them now. 130584 It then does not matter which order they are initialized in during the package load" 130585 FT2Constants initialize. 130586 FreeTypeCache initialize. 130587 FreeTypeCacheConstants initialize. 130588 FreeTypeSettings initialize. 130589 130590 "an instVar, pendingKernX, is added to both CharacterScanner and MultiCharacterScanner by 130591 the preamble of the package. However, some versions of the monticello loader don't run the 130592 preamble code. So, we check if the instVars have been added, and if not add them now" 130593 (CharacterScanner instVarNames includes: 'pendingKernX') ifFalse:[ 130594 Compiler evaluate: 'Object subclass: #CharacterScanner 130595 instanceVariableNames: ''destX lastIndex xTable destY stopConditions text textStyle alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern indentationLevel wantsColumnBreaks pendingKernX'' 130596 classVariableNames: ''DefaultStopConditions NilCondition PaddedSpaceCondition SpaceCondition'' 130597 poolDictionaries: ''TextConstants'' 130598 category: ''Graphics-Text'' ']. 130599 (MultiCharacterScanner instVarNames includes: 'pendingKernX') ifFalse:[ 130600Compiler evaluate: 'Object subclass: #MultiCharacterScanner 130601 instanceVariableNames: ''destX lastIndex xTable destY stopConditions text textStyle alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern indentationLevel wantsColumnBreaks presentation presentationLine numOfComposition baselineY firstDestX pendingKernX'' 130602 classVariableNames: ''DefaultStopConditions NilCondition PaddedSpaceCondition SpaceCondition'' 130603 poolDictionaries: ''TextConstants'' 130604 category: ''Multilingual-Scanning'' ']. 130605 130606 self current. "this creates an instance of me, and updates from the system"! ! 130607 130608 130609!FreeTypeFontProvider class methodsFor: 'startup' stamp: 'torsten.bergmann 3/25/2009 04:56'! 130610startUp: resuming 130611 (Preferences UpdateFontsAtImageStartup and: [resuming]) 130612 ifTrue:[ 130613 self current updateFromSystem]! ! 130614AbstractFontSelectorDialogWindow subclass: #FreeTypeFontSelectorDialogWindow 130615 instanceVariableNames: '' 130616 classVariableNames: '' 130617 poolDictionaries: '' 130618 category: 'Polymorph-Widgets-Windows'! 130619 130620!FreeTypeFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 16:01'! 130621defaultFontFamilies 130622 "Answer the set of available fonts families that are supported in the font that they represent." 130623 130624 |fonts defaultFont| 130625 defaultFont := TextStyle default fontOfPointSize: self theme listFont pointSize. 130626 fonts := (LogicalFontManager current allFamilies asSortedCollection: [:a :b | 130627 a familyName <= b familyName]) collect: [:ff | 130628 (ff 130629 closestMemberWithStretchValue: LogicalFont stretchRegular 130630 weightValue: LogicalFont weightRegular 130631 slantValue: LogicalFont slantRegular) 130632 asLogicalFontOfPointSize: self theme listFont pointSize]. 130633 ^fonts collect: [:f | |dispFont| 130634 dispFont := (f isSymbolFont or: [(f hasDistinctGlyphsForAll: f familyName) not]) 130635 ifTrue: [defaultFont] 130636 ifFalse: [f]. 130637 f familyName asText 130638 addAttribute: (TextFontReference toFont: dispFont)]! ! 130639 130640!FreeTypeFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:14'! 130641matchingFont 130642 "Answer the font that matches the selections." 130643 130644 |lf emp| 130645 self familyName ifNil: [^TextStyle defaultFont]. 130646 lf := LogicalFont 130647 familyName: self familyName 130648 pointSize: (self fontSize ifNil: [10]). 130649 emp := self isBold 130650 ifTrue: [TextEmphasis bold emphasisCode] 130651 ifFalse: [TextEmphasis normal emphasisCode]. 130652 self isItalic 130653 ifTrue: [emp := emp + TextEmphasis italic emphasisCode]. 130654 self isUnderlined 130655 ifTrue: [emp := emp + TextEmphasis underlined emphasisCode]. 130656 self isStruckOut 130657 ifTrue: [emp := emp + TextEmphasis struckOut emphasisCode]. 130658 lf := lf emphasis: emp. 130659 lf realFont ifNil: [^TextStyle defaultFont]. 130660 ^lf ! ! 130661 130662!FreeTypeFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:49'! 130663newFontStyleButtonRowMorph 130664 "Answer a new font style button row morph." 130665 130666 ^self newRow: { 130667 self newBoldButtonMorph. 130668 self newItalicButtonMorph}! ! 130669 130670!FreeTypeFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:26'! 130671updateFromSelectedFont 130672 "Update our state based on the selected font." 130673 130674 |font| 130675 font := self selectedFont ifNil: [TextStyle defaultFont]. 130676 fontFamilyIndex := (self fontFamilies indexOf: font familyName). 130677 fontSizeIndex := (self fontSizes indexOf: font pointSize). 130678 isBold := (font emphasis allMask: TextEmphasis bold emphasisCode). 130679 isItalic := (font emphasis allMask: TextEmphasis italic emphasisCode). 130680 self 130681 changed: #fontFamilyIndex; 130682 changed: #fontSizeIndex; 130683 changed: #isBold; 130684 changed: #isItalic. 130685 self textPreviewMorph ifNotNilDo: [:tp | 130686 tp font: self selectedFont. 130687 self changed: #previewText]! ! 130688Object subclass: #FreeTypeGlyphRenderer 130689 instanceVariableNames: '' 130690 classVariableNames: '' 130691 poolDictionaries: 'FT2Constants' 130692 category: 'FreeType-GlyphRendering'! 130693!FreeTypeGlyphRenderer commentStamp: 'tween 4/4/2007 09:48' prior: 0! 130694This class produces glyphs for a FreeTypeFont. 130695It can be subclassed to provide, for example, sub-pixel anti-aliased glyphs.! 130696 130697 130698!FreeTypeGlyphRenderer methodsFor: 'public' stamp: 'tween 4/4/2007 10:35'! 130699glyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: aFreeTypeFont 130700 130701 | f | 130702 f := self 130703 renderGlyph: aCharacter 130704 depth: (monoBoolean ifTrue:[1] ifFalse:[8]) 130705 subpixelPosition: sub 130706 font: aFreeTypeFont. 130707 monoBoolean 130708 ifTrue:[ 130709 f := self fixBytesForMono: f. 130710 f := f asFormOfDepth: 8]. 130711 f := self convert8to32: f colorValue: aColorValue. 130712 ^f 130713 ! ! 130714 130715!FreeTypeGlyphRenderer methodsFor: 'public' stamp: 'tween 4/4/2007 20:53'! 130716mode41GlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: aFreeTypeFont 130717 130718 | f | 130719 f := self 130720 renderGlyph: aCharacter 130721 depth: (monoBoolean ifTrue:[1] ifFalse:[8]) 130722 subpixelPosition: sub 130723 font: aFreeTypeFont. 130724 monoBoolean 130725 ifTrue:[ 130726 f := self fixBytesForMono: f. 130727 f := f asFormOfDepth: 32] 130728 ifFalse:[ 130729 f := self convert8To32: f]. 130730 ^f! ! 130731 130732!FreeTypeGlyphRenderer methodsFor: 'public' stamp: 'tween 4/4/2007 19:25'! 130733subGlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: aFreeTypeFont 130734 "the default renderer does not support sub-pixel anti-aliasing, 130735 so answer an ordinary glyph" 130736 ^self mode41GlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: aFreeTypeFont 130737! ! 130738 130739 130740!FreeTypeGlyphRenderer methodsFor: 'private' stamp: 'tween 4/4/2007 10:25'! 130741convert8To32: aGlyphForm 130742 "convert aGlyphForm from the 8 bit deep form produced by FreeType, where each byte represents the intensity of a single pixel, to a 32 bit deep form" 130743 | w h s answer rowstart bytes word littleEndian shift v a colorVal | 130744 130745 bytes := aGlyphForm bits. 130746 w := aGlyphForm width. 130747 h := aGlyphForm height. 130748 answer := aGlyphForm class extent: w@h depth: 32. 130749 answer 130750 offset: (aGlyphForm offset x) @(aGlyphForm offset y); 130751 advance: aGlyphForm advance; 130752 linearAdvance: aGlyphForm linearAdvance. 130753 s := w + 3 >> 2. 130754 littleEndian := aGlyphForm isLittleEndian. 130755 0 to: h - 1 do: [:y | 130756 rowstart := (y * s)+1. 130757 0 to: w - 1 do:[:x | 130758 word := bytes at: rowstart + (x//4). 130759 shift := 8* (littleEndian 130760 ifTrue:[x bitAnd: 3] 130761 ifFalse:[3-(x bitAnd: 3)]). 130762 v := word >>shift bitAnd: 16rFF. 130763 a := v > 0 ifTrue:[16rFF] ifFalse:[0]. 130764 colorVal := v + (v bitShift: 8) + (v bitShift: 16) + (a bitShift: 24). 130765 answer bits integerAt: (y*w)+(x+1) put: colorVal]]. 130766 ^answer! ! 130767 130768!FreeTypeGlyphRenderer methodsFor: 'private' stamp: 'tween 4/4/2007 21:24'! 130769convert8to32: aGlyphForm colorValue: foreColorValue 130770 "convert from the 8 bit deep form produced by FreeType, where each byte represents the intensity of a single pixel, to a 32 bit deep form with pixels of color foreColorValue " 130771 | w h s answer rowstart bytes word littleEndian shift v a colorVal foreColorVal foreColorA foreColorR foreColorG foreColorB r g b | 130772 130773 foreColorVal := foreColorValue. 130774 foreColorA := foreColorVal >> 24. 130775 foreColorR := foreColorVal >> 16 bitAnd: 16rFF. 130776 foreColorG := foreColorVal >> 8 bitAnd: 16rFF. 130777 foreColorB := foreColorVal bitAnd: 16rFF. 130778 bytes := aGlyphForm bits. 130779 w := aGlyphForm width. 130780 h := aGlyphForm height. 130781 answer := aGlyphForm class extent: w@h depth: 32. 130782 answer 130783 offset: (aGlyphForm offset x) @ (aGlyphForm offset y); 130784 advance: aGlyphForm advance; 130785 linearAdvance: aGlyphForm linearAdvance. 130786 s := w + 3 >> 2. 130787 littleEndian := aGlyphForm isLittleEndian. 130788 0 to: h - 1 do: [:y | 130789 rowstart := (y * s)+1. 130790 0 to: w - 1 do:[:x | 130791 word := bytes at: rowstart + (x//4). 130792 shift := 8* (littleEndian 130793 ifTrue:[x bitAnd: 3] 130794 ifFalse:[3-(x bitAnd: 3)]). 130795 v := word >>shift bitAnd: 16rFF. 130796 a := v > 0 ifTrue:[v * foreColorA // 16rFF] ifFalse:[0]. 130797 r := v > 0 ifTrue:[a * foreColorR // 16rFF] ifFalse:[0]. 130798 g := v > 0 ifTrue:[a * foreColorG // 16rFF] ifFalse:[0]. 130799 b := v > 0 ifTrue:[a * foreColorB // 16rFF] ifFalse:[0]. 130800 colorVal := (a bitShift: 24) + (r bitShift: 16) + (g bitShift: 8) + b. 130801 answer bits integerAt: (y*w)+(x+1) put: colorVal]]. 130802 ^answer! ! 130803 130804!FreeTypeGlyphRenderer methodsFor: 'private' stamp: 'tween 4/4/2007 10:28'! 130805fixBytesForMono: aGlyphForm 130806 "On Windows, the bits in each byte are in reverse order, and inverted. 130807 i.e. 2r10100000 should be 2r11111010 to display correctly. 130808 This needs further investigation" 130809 | b newB bits | 130810 bits := aGlyphForm bits. 130811 1 to: bits byteSize do:[:i | 130812 b := bits byteAt: i. 130813 newB := ((((((((b bitAnd: 2r10000000) bitShift: -7) 130814 bitOr: ((b bitAnd: 2r1000000) bitShift: -5)) 130815 bitOr: ((b bitAnd: 2r100000) bitShift: -3)) 130816 bitOr: ((b bitAnd: 2r10000) bitShift: -1)) 130817 bitOr: ((b bitAnd: 2r1000) bitShift: 1)) 130818 bitOr: ((b bitAnd: 2r100) bitShift: 3)) 130819 bitOr: ((b bitAnd: 2r10) bitShift: 5)) 130820 bitOr: ((b bitAnd: 2r1) bitShift: 7). 130821 bits byteAt: i put: (newB bitXor: 2r11111111)]. 130822 ^aGlyphForm! ! 130823 130824!FreeTypeGlyphRenderer methodsFor: 'private' stamp: 'michael.rueger 2/5/2009 17:03'! 130825renderGlyph: aCharacter depth: depth subpixelPosition: sub font: aFreeTypeFont 130826 "Glyphs are either 1 or 8 bit deep. For 32 bpp we use 8 bits, otherwise 1" 130827 | em form glyph charCode slant extraWidth extraHeight boldExtra offsetX offsetY s 130828 synthBoldStrength hintingFlags flags face | 130829 130830 charCode := aCharacter asUnicode asInteger. 130831 (aFreeTypeFont face charmaps includes:'unic') 130832 ifTrue:[ 130833 (aFreeTypeFont isSymbolFont and:[charCode >= 16r20 and: [charCode <= 16rFF ] ]) 130834 ifTrue:[charCode := charCode + 16rF000]] 130835 ifFalse:[ 130836 (aFreeTypeFont face charmaps includes:'armn') 130837 ifTrue:[ "select apple roman char map, and map character from unicode to mac encoding" 130838 aFreeTypeFont face setCharMap:'armn'. 130839 charCode := aCharacter unicodeToMacRoman asUnicode asInteger. "check this!!"]]. 130840 aCharacter < $ ifTrue: ["charCode := $ asUnicode asInteger" 130841 ^(GlyphForm extent: 0@0 depth: depth) 130842 advance: 0@0; 130843 linearAdvance: 0@0; 130844 offset:0@0; 130845 yourself ]. 130846 em := aFreeTypeFont pixelSize. 130847 [face := aFreeTypeFont face. 130848 face setPixelWidth: em height: em. 130849 hintingFlags := FreeTypeSettings current hintingFlags. 130850 flags := LoadNoBitmap bitOr:( LoadIgnoreTransform bitOr: hintingFlags). 130851 face loadCharacter:charCode flags: flags] 130852 on: FT2Error do:[:e | 130853 ^(GlyphForm extent: 0@0 depth: depth) 130854 advance: 0@0; 130855 linearAdvance: 0@0; 130856 offset:0@0; 130857 yourself]. 130858 glyph := face glyph. 130859 slant := aFreeTypeFont simulatedItalicSlant. 130860 extraWidth := (glyph height * slant) abs ceiling. 130861 synthBoldStrength := aFreeTypeFont simulatedBoldStrength. 130862 boldExtra := 4 * synthBoldStrength abs ceiling. 130863 extraWidth := extraWidth + boldExtra. 130864 sub > 0 ifTrue:[ extraWidth := extraWidth + 1]. 130865 extraHeight := boldExtra. 130866 form := GlyphForm extent: (glyph width + extraWidth + 1)@(glyph height + extraHeight+ 1) depth: depth. 130867 s := (glyph height-glyph hBearingY) * slant. 130868 s := s sign * (s abs ceiling). 130869 offsetX := glyph hBearingX negated + s + (boldExtra // 2) . 130870 offsetY := glyph height - glyph hBearingY + (boldExtra//2). 130871 synthBoldStrength ~= 0 130872 ifTrue:[face emboldenOutline: synthBoldStrength]. 130873 face transformOutlineAngle: 0 scalePoint: 1@1 slant: slant. 130874 face translateOutlineBy: (offsetX+(sub/64))@offsetY. 130875 face renderGlyphIntoForm: form. 130876 form offset: (glyph hBearingX - s - (boldExtra // 2) ) @ (glyph hBearingY + 1 + (boldExtra / 2) ceiling ) negated. 130877 "When not hinting FreeType sets the advance to the truncated linearAdvance. 130878 The characters appear squashed together. Rounding is probably better, so we fix the advance here" 130879 aFreeTypeFont subPixelPositioned 130880 ifTrue:[ form advance: glyph roundedPixelLinearAdvance] 130881 ifFalse:[ form advance: glyph advance]. 130882 form linearAdvance: glyph linearAdvance. 130883 ^form! ! 130884 130885"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 130886 130887FreeTypeGlyphRenderer class 130888 instanceVariableNames: 'current'! 130889 130890!FreeTypeGlyphRenderer class methodsFor: 'accessing' stamp: 'tween 4/4/2007 09:50'! 130891current: aKindOfFreeTypeGlyphRender 130892 current := aKindOfFreeTypeGlyphRender! ! 130893 130894 130895!FreeTypeGlyphRenderer class methodsFor: 'instance creation' stamp: 'tween 4/4/2007 19:24'! 130896current 130897 " 130898 FreeTypeGlyphRenderer current 130899 " 130900 ^current ifNil:[current := self new]! ! 130901Object subclass: #FreeTypeNameParser 130902 instanceVariableNames: 'combinedName familyNameIn styleNameIn delimiters tokens extractedSlant extractedSlantValue extractedUpright extractedStretch extractedWeight italicFlag boldFlag extractedWeightValue extractedStretchValue' 130903 classVariableNames: '' 130904 poolDictionaries: '' 130905 category: 'FreeType-FontManager'! 130906 130907!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/12/2007 20:14'! 130908boldFlag: aBoolean 130909 boldFlag := aBoolean! ! 130910 130911!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 21:32'! 130912extractedSlant 130913 ^extractedSlant! ! 130914 130915!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 21:33'! 130916extractedSlantValue 130917 ^extractedSlantValue! ! 130918 130919!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/12/2007 12:29'! 130920extractedStretch 130921 ^extractedStretch! ! 130922 130923!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 00:55'! 130924extractedStretchValue 130925 ^extractedStretchValue! ! 130926 130927!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:16'! 130928extractedUpright 130929 ^extractedUpright! ! 130930 130931!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/12/2007 12:29'! 130932extractedWeight 130933 ^extractedWeight! ! 130934 130935!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 00:55'! 130936extractedWeightValue 130937 ^extractedWeightValue! ! 130938 130939!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/12/2007 00:14'! 130940familyName 130941 ^combinedName withBlanksTrimmed! ! 130942 130943!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/11/2007 18:06'! 130944familyName: familyName 130945 familyNameIn := familyName. 130946 130947 ! ! 130948 130949!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/11/2007 23:39'! 130950familyNameIn: familyName 130951 familyNameIn := familyName. 130952 130953 ! ! 130954 130955!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/12/2007 20:14'! 130956italicFlag: aBoolean 130957 italicFlag := aBoolean! ! 130958 130959!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/11/2007 18:06'! 130960styleName: styleName 130961 130962 styleNameIn := styleName. 130963! ! 130964 130965!FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/11/2007 23:39'! 130966styleNameIn: styleName 130967 130968 styleNameIn := styleName. 130969! ! 130970 130971 130972!FreeTypeNameParser methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:55'! 130973initialize 130974 super initialize. 130975 delimiters := ',.-:='. 130976 Character separators do:[:c | delimiters := delimiters , c asString]. 130977! ! 130978 130979 130980!FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 8/16/2007 02:54'! 130981italicAndObliqueNames 130982 ^self class italicAndObliqueNames! ! 130983 130984!FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 8/16/2007 02:12'! 130985italicNames 130986 ^self class italicNames! ! 130987 130988!FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 8/25/2007 13:28'! 130989normalNames 130990 ^self class normalNames 130991! ! 130992 130993!FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 9/29/2007 11:41'! 130994stretchNames 130995 ^self class stretchNames! ! 130996 130997!FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 9/29/2007 11:41'! 130998weightNames 130999 ^self class weightNames 131000 ! ! 131001 131002 131003!FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 8/13/2007 23:02'! 131004addStyleNameToCombinedName: aStyleString 131005 | lcCombined lcStyleName addStyle index | 131006 lcCombined := combinedName asLowercase. 131007 lcStyleName := aStyleString asLowercase. 131008 addStyle := true. 131009 (index := lcCombined findString: lcStyleName) > 0 131010 ifTrue:[ 131011 (index = 1 or:[delimiters includes: (lcCombined at: index - 1)]) 131012 ifTrue:[ 131013 ((index + lcStyleName size > lcCombined size) or:[ delimiters includes: (lcCombined at: index + lcStyleName size) ]) 131014 ifTrue:["don't add the style to the combinedName, because it already contains it" 131015 addStyle := false]]]. 131016 addStyle ifTrue:[combinedName := combinedName , ' ', aStyleString]. 131017 ! ! 131018 131019!FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 9/29/2007 12:03'! 131020extractSlant 131021 131022 | matches start end | 131023 131024 "match and remove last italic/oblique token" 131025 extractedSlant := nil. 131026 extractedSlantValue := LogicalFont slantRegular. "not italic or oblique" 131027 (self italicAndObliqueNames 131028 detect: [:each | 131029 (matches := self lastMatchValueSequence: {each}) notNil] 131030 ifNone:[]) ifNotNil:[ 131031 start := matches first second. 131032 end := matches last third. 131033 extractedSlant := combinedName copyFrom: start to: end. 131034 "extractedSlantValue := (self italicNames includes: extractedSlant asLowercase) 131035 ifTrue:[1] 131036 ifFalse:[2]." 131037 extractedSlantValue := LogicalFont slantItalic. "treat italic and oblique the same, as italic" 131038 [start > 1 and:[delimiters includes: (combinedName at: start - 1)]] "also remove delimiters before token" 131039 whileTrue:[start := start - 1]. 131040 [end < combinedName size and:[delimiters includes: (combinedName at: end + 1)]] "also remove delimiters after token" 131041 whileTrue:[end := end + 1]. 131042 combinedName := combinedName copyReplaceFrom: start to: end with: ' '.]. 131043 (extractedSlant isNil and:[italicFlag]) 131044 ifTrue:["no italic specified in familyName or styleName; force it to be 'Italic'" 131045 extractedSlant := 'Italic'. 131046 extractedSlantValue := LogicalFont slantItalic] ! ! 131047 131048!FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 9/29/2007 12:35'! 131049extractStretch 131050 "match and remove last stretch tokens" 131051 | matches start end | 131052 131053 extractedStretchValue := LogicalFont stretchRegular. 131054 (self stretchNames 131055 detect: [:each | 131056 matches := self lastMatchValueSequence: each allButFirst. 131057 matches ifNotNil:[extractedStretchValue := each first]. 131058 matches notNil] 131059 ifNone:[]) ifNotNil:[ 131060 start := matches first second. 131061 end := matches last third. 131062 extractedStretch := combinedName copyFrom: start to: end. 131063 [start > 1 and:[delimiters includes: (combinedName at: start - 1)]] "also remove delimiters before token" 131064 whileTrue:[start := start - 1]. 131065 [end < combinedName size and:[delimiters includes: (combinedName at: end + 1)]] "also remove delimiters after token" 131066 whileTrue:[end := end + 1]. 131067 combinedName := combinedName copyReplaceFrom: start to: end with: ' '. 131068 "re-tokenize" 131069 "tokens := self tokenize: combinedName delimiters: delimiters"]. ! ! 131070 131071!FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 8/14/2007 22:01'! 131072extractUpright 131073 "extract from current combined name. 131074 answer new combinedName" 131075 | normalTok start end | 131076 131077 normalTok := tokens reversed 131078 detect: [:tok | 131079 (self normalNames 131080 detect: [:str | str asLowercase = tok first asLowercase] 131081 ifNone:[]) notNil ] 131082 ifNone:[]. 131083 normalTok ifNotNil:[ 131084 "remove it from combinedName" 131085 start := normalTok second. 131086 end := normalTok third. 131087 extractedUpright := combinedName copyFrom: start to: end. 131088 [start > 1 and:[delimiters includes: (combinedName at: start - 1)]] 131089 whileTrue:[start := start - 1]. 131090 [end < combinedName size and:[delimiters includes: (combinedName at: end + 1)]] 131091 whileTrue:[end := end + 1]. 131092 combinedName := combinedName copyReplaceFrom: start to: end with: ' ']. 131093 131094 ! ! 131095 131096!FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 9/29/2007 12:34'! 131097extractWeight 131098 "match and remove last weight tokens" 131099 | matches start end | 131100 131101 extractedWeightValue := LogicalFont weightRegular. 131102 (self weightNames 131103 detect: [:each | 131104 matches := self lastMatchValueSequence: each allButFirst. 131105 matches ifNotNil:[extractedWeightValue := each first]. 131106 matches notNil] 131107 ifNone:[]) ifNotNil:[ 131108 start := matches first second. 131109 end := matches last third. 131110 extractedWeight := combinedName copyFrom: start to: end. 131111 [start > 1 and:[delimiters includes: (combinedName at: start - 1)]] "also remove delimiters before token" 131112 whileTrue:[start := start - 1]. 131113 [end < combinedName size and:[delimiters includes: (combinedName at: end + 1)]] "also remove delimiters after token" 131114 whileTrue:[end := end + 1]. 131115 combinedName := combinedName copyReplaceFrom: start to: end with: ' '.]. 131116 (extractedWeight isNil and:[boldFlag]) 131117 ifTrue:["no weight specified in familyName or styleName; force it to be 'Bold'" 131118 extractedWeight := 'Bold'. 131119 extractedWeightValue := LogicalFont weightBold] ! ! 131120 131121!FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 8/11/2007 18:23'! 131122lastMatchValueSequence: values 131123 "answer the last contiguous tokens that match pattern tokens, 131124 or nil if not found. 131125 matching is case insensitive " 131126 | answer nullToken match tok | 131127 nullToken := {''. nil. nil}. 131128 tokens size - values size + 1 to: 1 by: -1 do:[:ti | 131129 match := true. 131130 answer := Array new. 131131 1 to: values size do:[:vi | 131132 tok := tokens at: ti + vi - 1 ifAbsent: [nullToken]. 131133 (match and: [tok first asLowercase = ( values at: vi) asLowercase]) 131134 ifFalse:[match := false] 131135 ifTrue:[answer := answer, {tok} ]]. 131136 match ifTrue:[^answer]]. 131137 ^nil 131138 131139! ! 131140 131141!FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 8/16/2007 21:32'! 131142parse 131143 131144 | styleName | 131145 styleNameIn := self splitBadTokensIn: styleNameIn. 131146 combinedName := styleNameIn withBlanksTrimmed. 131147 tokens := self tokenize: combinedName. 131148 self extractUpright. 131149 styleName := combinedName. 131150 combinedName := familyNameIn withBlanksTrimmed. 131151 self addStyleNameToCombinedName: styleName.. 131152 tokens := self tokenize: combinedName. 131153 self extractSlant. 131154 tokens := self tokenize: combinedName. 131155 self extractStretch. 131156 tokens := self tokenize: combinedName. 131157 self extractWeight. 131158 ! ! 131159 131160!FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 8/14/2007 22:11'! 131161splitBadTokensIn: aString 131162 "split tokens such as BoldOblique, that should be two words" 131163 | i str | 131164 str := aString. 131165 #( ('bold' 'oblique') ('bold' 'italic') 131166 ) do:[:pair | 131167 (i := str asLowercase findString: pair first, pair second startingAt: 1) > 0 131168 ifTrue:[ 131169 str := (str first: i + pair first size - 1), ' ', (str last: (str size - (i + pair first size - 1)))]]. 131170 ^str! ! 131171 131172!FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 8/11/2007 18:08'! 131173tokenize: aString 131174 "answer an OrderedCollection of {string. start. end} tuples. 131175 tokens are separated by $- $:= $, $. and whitespace" 131176 | tokens answer start | 131177 131178 tokens := aString findTokens: delimiters keep: delimiters. 131179 answer := OrderedCollection new. 131180 start := 1. 131181 tokens do:[:tok | 131182 (delimiters includes: tok first) 131183 ifFalse:[answer add: {tok. start. start+tok size - 1}]. 131184 start := start + tok size]. 131185 ^answer! ! 131186 131187"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 131188 131189FreeTypeNameParser class 131190 instanceVariableNames: 'weightNames stretchNames obliqueNames normalNames italicNames'! 131191 131192!FreeTypeNameParser class methodsFor: 'known names' stamp: 'tween 8/16/2007 02:47'! 131193italicAndObliqueNames 131194 ^self italicNames, self obliqueNames! ! 131195 131196!FreeTypeNameParser class methodsFor: 'known names' stamp: 'tween 9/30/2007 12:44'! 131197italicNames 131198 "Answer a sequence of String tokens that indicate an italic font 131199 within a font family-style name" 131200 " 131201 TO RE-INITIALIZE... 131202 self instVarNamed: #italicNames put: nil. 131203 " 131204 italicNames ifNotNil:[^italicNames]. 131205 ^italicNames := #( 131206 'ita' 131207 'ital' 131208 'italic' 131209 'cursive' 131210 'kursiv').! ! 131211 131212!FreeTypeNameParser class methodsFor: 'known names' stamp: 'tween 9/30/2007 12:44'! 131213normalNames 131214 "Answer a sequence of String tokens that indicate a Regular 131215 (i.e. non-oblique, non-italic) font within a font family-style name" 131216 " 131217 TO RE-INITIALIZE... 131218 self instVarNamed: #normalNames put: nil. 131219 " 131220 normalNames ifNotNil:[^normalNames]. 131221 ^normalNames := #('Book' 'Normal' 'Regular' 'Roman' 'Upright').! ! 131222 131223!FreeTypeNameParser class methodsFor: 'known names' stamp: 'tween 9/30/2007 12:43'! 131224obliqueNames 131225 "Answer a sequence of String tokens that indicate an oblique font 131226 within a font family-style name" 131227 " 131228 TO RE-INITIALIZE... 131229 self instVarNamed: #obliqueNames put: nil. 131230 " 131231 obliqueNames ifNotNil:[^obliqueNames]. 131232 ^obliqueNames := #( 131233 'inclined' 131234 'oblique' 131235 'backslanted' 131236 'backslant' 131237 'slanted').! ! 131238 131239!FreeTypeNameParser class methodsFor: 'known names' stamp: 'tween 9/30/2007 12:42'! 131240stretchNames 131241 "Answer a sequence of arrays. 131242 Each array has an integer stretch value as its first element (1 - 9). 131243 The remaining elements are String tokens which might appear 131244 within a font family-style name" 131245 " 131246 TO RE-INITIALIZE... 131247 self instVarNamed: #stretchNames put: nil. 131248 " 131249 stretchNames ifNotNil:[^stretchNames]. 131250 ^stretchNames := { 131251 {LogicalFont stretchExtraCompressed. 'extra'. 'compressed'}. 131252 {LogicalFont stretchExtraCompressed. 'extracompressed'}. 131253 {LogicalFont stretchExtraCompressed. 'ext'. 'compressed'}. 131254 {LogicalFont stretchExtraCompressed. 'extcompressed'}. 131255 {LogicalFont stretchUltraCompressed. 'ultra'. 'compressed'}. 131256 {LogicalFont stretchUltraCompressed. 'ultracompressed'}. 131257 {LogicalFont stretchUltraCondensed. 'ultra'. 'condensed'}. 131258 {LogicalFont stretchUltraCondensed. 'ultracondensed'}. 131259 {LogicalFont stretchUltraCondensed. 'ultra'. 'cond'}. 131260 {LogicalFont stretchUltraCondensed. 'ultracond'}. 131261 {LogicalFont stretchCompressed. 'compressed'}. 131262 {LogicalFont stretchExtraCondensed. 'extra'. 'condensed'}. 131263 {LogicalFont stretchExtraCondensed. 'extracondensed'}. 131264 {LogicalFont stretchExtraCondensed. 'ext'. 'condensed'}. 131265 {LogicalFont stretchExtraCondensed. 'extcondensed'}. 131266 {LogicalFont stretchExtraCondensed. 'extra'. 'cond'}. 131267 {LogicalFont stretchExtraCondensed. 'extracond'}. 131268 {LogicalFont stretchExtraCondensed. 'ext'. 'cond'}. 131269 {LogicalFont stretchExtraCondensed. 'extcond'}. 131270 {LogicalFont stretchNarrow. 'narrow'}. 131271 {LogicalFont stretchCompact. 'compact'}. 131272 {LogicalFont stretchSemiCondensed. 'semi'. 'condensed'}. 131273 {LogicalFont stretchSemiCondensed. 'semicondensed'}. 131274 {LogicalFont stretchSemiCondensed. 'semi'. 'cond'}. 131275 {LogicalFont stretchSemiCondensed. 'semicond'}. 131276 {LogicalFont stretchWide. 'wide'}. 131277 {LogicalFont stretchSemiExpanded. 'semi'. 'expanded'}. 131278 {LogicalFont stretchSemiExpanded. 'semiexpanded'}. 131279 {LogicalFont stretchSemiExtended. 'semi'. 'extended'}. 131280 {LogicalFont stretchSemiExtended. 'semiextended'}. 131281 {LogicalFont stretchExtraExpanded. 'extra'. 'expanded'}. 131282 {LogicalFont stretchExtraExpanded. 'extraexpanded'}. 131283 {LogicalFont stretchExtraExpanded. 'ext'. 'expanded'}. 131284 {LogicalFont stretchExtraExpanded. 'extexpanded'}. 131285 {LogicalFont stretchExtraExtended. 'extra'. 'extended'}. 131286 {LogicalFont stretchExtraExtended. 'extraextended'}. 131287 {LogicalFont stretchExtraExtended. 'ext'. 'extended'}. 131288 {LogicalFont stretchExtraExtended. 'extextended'}. 131289 {LogicalFont stretchUltraExpanded. 'ultra'. 'expanded'}. 131290 {LogicalFont stretchUltraExpanded. 'ultraexpanded'}. 131291 {LogicalFont stretchUltraExtended. 'ultra'. 'extended'}. 131292 {LogicalFont stretchUltraExtended. 'ultraextended'}. 131293 {LogicalFont stretchCondensed. 'condensed'}. 131294 {LogicalFont stretchCondensed. 'cond'}. 131295 {LogicalFont stretchExpanded. 'expanded'}. 131296 {LogicalFont stretchExtended. 'extended'} 131297 }. "search for them in the order given here" 131298! ! 131299 131300!FreeTypeNameParser class methodsFor: 'known names' stamp: 'tween 9/30/2007 12:41'! 131301weightNames 131302 "Answer a sequence of arrays. 131303 Each array has an integer weight value as its first element. 131304 The remaining elements are String tokens which might appear 131305 within a font family-style name" 131306 " 131307 TO RE-INITIALIZE... 131308 self instVarNamed: #weightNames put: nil. 131309 " 131310 weightNames ifNotNil:[^weightNames]. 131311 ^weightNames := { 131312 {LogicalFont weightExtraThin. 'extra'. 'thin'}. 131313 {LogicalFont weightExtraThin.'extrathin'}. 131314 {LogicalFont weightExtraThin. 'ext'. 'thin'}. 131315 {LogicalFont weightExtraThin. 'extthin'}. 131316 {LogicalFont weightUltraThin.'ultra'. 'thin'}. 131317 {LogicalFont weightUltraThin.'ultrathin'}. 131318 {LogicalFont weightExtraLight. 'extra'. 'light'}. 131319 {LogicalFont weightExtraLight. 'extralight'}. 131320 {LogicalFont weightExtraLight. 'ext'. 'light'}. 131321 {LogicalFont weightExtraLight. 'extlight'}. 131322 {LogicalFont weightUltraLight. 'ultra'. 'light'}. 131323 {LogicalFont weightUltraLight. 'ultralight'}. 131324 {LogicalFont weightSemiBold. 'semi'. 'bold'}. 131325 {LogicalFont weightSemiBold. 'semibold'}. 131326 {LogicalFont weightDemiBold. 'demi'. 'bold'}. 131327 {LogicalFont weightDemiBold. 'demibold'}. 131328 {LogicalFont weightExtraBold. 'extra'. 'bold'}. 131329 {LogicalFont weightExtraBold. 'extrabold'}. 131330 {LogicalFont weightExtraBold. 'ext'. 'bold'}. 131331 {LogicalFont weightExtraBold. 'extbold'}. 131332 {LogicalFont weightUltraBold. 'ultra'. 'bold'}. 131333 {LogicalFont weightUltraBold. 'ultrabold'}. 131334 {LogicalFont weightExtraBlack. 'extra'. 'black'}. 131335 {LogicalFont weightExtraBlack. 'extrablack'}. 131336 {LogicalFont weightExtraBlack. 'ext'. 'black'}. 131337 {LogicalFont weightExtraBlack. 'extblack'}. 131338 {LogicalFont weightUltraBlack.'ultra'. 'black'}. 131339 {LogicalFont weightUltraBlack. 'ultrablack'}. 131340 {LogicalFont weightBold. 'bold'}. 131341 {LogicalFont weightThin.'thin'}. 131342 {LogicalFont weightLight. 'light'}. 131343 {LogicalFont weightMedium. 'medium'}. 131344 {LogicalFont weightBlack. 'black'}. 131345 {LogicalFont weightHeavy. 'heavy'}. 131346 {LogicalFont weightNord. 'nord'}. 131347 {LogicalFont weightDemi. 'demi'}. 131348 {LogicalFont weightUltra. 'ultra'}. 131349 } 131350 ! ! 131351Object subclass: #FreeTypeSettings 131352 instanceVariableNames: 'gamma hinting lightHinting subPixelAntiAliasing forceAutoHinting lcdHinting lcdvHinting monoHinting bitBltSubPixelAvailable subPixelFilters forceNonSubPixelCount gammaTable gammaInverseTable' 131353 classVariableNames: '' 131354 poolDictionaries: 'FT2Constants FreeTypeCacheConstants' 131355 category: 'FreeType-Settings'! 131356 131357!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 4/5/2007 08:17'! 131358bitBltSubPixelAvailable 131359 "Answer true if the the subPixel combination rule is available, false otherwise. 131360 to test :- 131361 131362 bitBltSubPixelAvailable := false. 131363 FreeTypeCache current removeAll. 131364 Smalltalk isMorphic 131365 ifTrue:[World restoreMorphicDisplay] 131366 131367 " 131368 131369 | form bitBlt color | 131370 bitBltSubPixelAvailable == nil ifFalse:[^bitBltSubPixelAvailable]. 131371 form := Form extent: 10@10 depth: 32. 131372 bitBlt := GrafPort toForm: form. 131373 bitBlt combinationRule: 41. 131374 bitBlt sourceForm: (Form extent: 5@5 depth: 32). 131375 bitBlt destOrigin: 1@1. 131376 bitBlt width: 5; height: 5. 131377 color := Color black asNontranslucentColor pixelValueForDepth: 32. 131378 [bitBlt 131379 copyBitsColor: (color bitAnd: 16rFFFFFF) 131380 alpha: (color bitAnd: 16rFF000000) >> 24 131381 gammaTable: nil 131382 ungammaTable: nil] 131383 on: Error do:[:e | ^bitBltSubPixelAvailable := false]. 131384 #toDo. "need to check that rule 41 has done the right thing, and isn't someone elses new BitBlt rule" 131385 ^bitBltSubPixelAvailable := true 131386 ! ! 131387 131388!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:04'! 131389clearBitBltSubPixelAvailable 131390 131391 bitBltSubPixelAvailable := nil.! ! 131392 131393!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:03'! 131394clearForceNonSubPixelCount 131395 131396 forceNonSubPixelCount := nil. ! ! 131397 131398!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:12'! 131399defaultSubPixelFilterRatios 131400 ^#((1 3 5 3 1) (1 3 5 3 1) (1 3 5 3 1))! ! 131401 131402!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:12'! 131403forceAutoHinting 131404 ^forceAutoHinting ifNil:[forceAutoHinting := false]! ! 131405 131406!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:13'! 131407forceNonSubPixelCount 131408 ^forceNonSubPixelCount ifNil:[forceNonSubPixelCount := 0]! ! 131409 131410!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:13'! 131411forceNonSubPixelDuring: aBlock 131412 forceNonSubPixelCount ifNil:[forceNonSubPixelCount := 0]. 131413 forceNonSubPixelCount := forceNonSubPixelCount + 1. 131414 aBlock ensure:[forceNonSubPixelCount := forceNonSubPixelCount - 1]! ! 131415 131416!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:13'! 131417gamma 131418 ^gamma ifNil:[gamma := 1.0]! ! 131419 131420!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:25'! 131421gammaInverseTable 131422 ^gammaInverseTable! ! 131423 131424!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:25'! 131425gammaTable 131426 ^gammaTable! ! 131427 131428!FreeTypeSettings methodsFor: 'accessing' stamp: 'marcus.denker 11/29/2008 10:42'! 131429glyphContrastPreferenceChanged 131430 " value between 1 and 100. 131431 100 is highest contrast and maps to gamma 0.25 131432 1 is lowest contrast and maps to gamma 2.22" 131433 | v g | 131434 v := (((Preferences GlyphContrast asNumber) min: 100) max: 1) asFloat. 131435 (v closeTo: 50.0) 131436 ifTrue:[g := 1.0] 131437 ifFalse:[ 131438 g := ((100 - v)+50/100.0) raisedTo: 2]. 131439 self setGamma: g. 131440 World restoreMorphicDisplay. 131441! ! 131442 131443!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:13'! 131444hinting 131445 ^hinting ifNil:[hinting := true]! ! 131446 131447!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:15'! 131448hintingFlags 131449 | answer | 131450 answer := 0. 131451 self hinting 131452 ifTrue:[ 131453 self forceAutoHinting ifTrue:[answer := answer bitOr: 32 "forceAutoHinting"]. 131454 self lightHinting ifTrue:[answer := answer bitOr: LoadTargetLight]. 131455 self monoHinting ifTrue:[answer := answer bitOr: LoadTargetMono]. 131456 self lcdHinting ifTrue:[answer := answer bitOr: LoadTargetLCD]. 131457 self lcdvHinting ifTrue:[answer := answer bitOr: LoadTargetLCDV]] 131458 ifFalse:[answer := 2 "no hinting"]. 131459 ^answer! ! 131460 131461!FreeTypeSettings methodsFor: 'accessing' stamp: 'marcus.denker 11/29/2008 10:42'! 131462hintingFullPreferenceChanged 131463 Preferences HintingFull 131464 ifTrue:[Preferences disable: #HintingNone; disable: #HintingLight; disable: #HintingNormal] 131465 ifFalse:[ 131466 (Preferences HintingNone or:[Preferences HintingLight or:[Preferences HintingNormal]]) 131467 ifFalse:[ 131468 "turn it back on again" 131469 ^Preferences enable: #HintingFull]]. 131470 monoHinting := Preferences HintingFull. 131471 lightHinting := Preferences HintingLight. 131472 hinting := monoHinting or:[lightHinting or:[Preferences HintingNormal]]. 131473 FreeTypeCache current removeAll. 131474 FreeTypeFont allSubInstances do:[:each | each clearCachedMetrics]. 131475 NewParagraph allSubInstances do:[:each | each composeAll]. 131476 World restoreMorphicDisplay. 131477 131478! ! 131479 131480!FreeTypeSettings methodsFor: 'accessing' stamp: 'marcus.denker 11/29/2008 10:42'! 131481hintingLightPreferenceChanged 131482 Preferences HintingLight 131483 ifTrue:[Preferences disable: #HintingFull; disable: #HintingNone; disable: #HintingNormal] 131484 ifFalse:[ 131485 (Preferences HintingFull or:[Preferences HintingNone or:[Preferences HintingNormal]]) 131486 ifFalse:[ 131487 "turn it back on again" 131488 ^Preferences enable: #HintingLight]]. 131489 monoHinting := Preferences HintingFull. 131490 lightHinting := Preferences HintingLight. 131491 hinting := monoHinting or:[lightHinting or:[Preferences HintingNormal]]. 131492 FreeTypeCache current removeAll. 131493 FreeTypeFont allSubInstances do:[:each | each clearCachedMetrics]. 131494 NewParagraph allSubInstances do:[:each | each composeAll]. 131495 World restoreMorphicDisplay. 131496! ! 131497 131498!FreeTypeSettings methodsFor: 'accessing' stamp: 'marcus.denker 11/29/2008 10:42'! 131499hintingNonePreferenceChanged 131500 Preferences HintingNone 131501 ifTrue:[Preferences disable: #HintingFull; disable: #HintingLight; disable: #HintingNormal] 131502 ifFalse:[ 131503 (Preferences HintingFull or:[Preferences HintingLight or:[Preferences HintingNormal]]) 131504 ifFalse:[ 131505 "turn it back on again" 131506 ^Preferences enable: #HintingNone]]. 131507 monoHinting := Preferences HintingFull. 131508 lightHinting := Preferences HintingLight. 131509 hinting := monoHinting or:[lightHinting or:[Preferences HintingNormal]]. 131510 FreeTypeCache current removeAll. 131511 FreeTypeFont allSubInstances do:[:each | each clearCachedMetrics]. 131512 NewParagraph allSubInstances do:[:each | each composeAll]. 131513 World restoreMorphicDisplay.! ! 131514 131515!FreeTypeSettings methodsFor: 'accessing' stamp: 'marcus.denker 11/29/2008 10:43'! 131516hintingNormalPreferenceChanged 131517 Preferences HintingNormal 131518 ifTrue:[Preferences disable: #HintingNone; disable: #HintingLight; disable: #HintingFull ] 131519 ifFalse:[ 131520 (Preferences HintingNone or:[Preferences HintingLight or:[Preferences HintingFull]]) 131521 ifFalse:[ 131522 "turn it back on again" 131523 ^Preferences enable: #HintingNormal]]. 131524 monoHinting := Preferences HintingFull. 131525 lightHinting := Preferences HintingLight. 131526 hinting := monoHinting or:[lightHinting or:[Preferences HintingNormal]]. 131527 FreeTypeCache current removeAll. 131528 FreeTypeFont allSubInstances do:[:each | each clearCachedMetrics]. 131529 NewParagraph allSubInstances do:[:each | each composeAll]. 131530 World restoreMorphicDisplay. 131531 131532! ! 131533 131534!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:15'! 131535lcdHinting 131536 ^lcdHinting ifNil:[lcdHinting := false]! ! 131537 131538!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:15'! 131539lcdvHinting 131540 ^lcdvHinting ifNil:[lcdvHinting := false]! ! 131541 131542!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:16'! 131543lightHinting 131544 ^lightHinting ifNil:[lightHinting := true]! ! 131545 131546!FreeTypeSettings methodsFor: 'accessing' stamp: 'marcus.denker 11/29/2008 10:43'! 131547monitorTypeCRTPreferenceChanged 131548 Preferences MonitorTypeCRT 131549 ifTrue:[Preferences disable: #MonitorTypeLCD] 131550 ifFalse:[ 131551 Preferences MonitorTypeLCD 131552 ifFalse:[ 131553 "turn it back on again" 131554 ^Preferences enable: #MonitorTypeCRT]]. 131555 subPixelAntiAliasing := Preferences MonitorTypeLCD. 131556 World restoreMorphicDisplay. 131557 ! ! 131558 131559!FreeTypeSettings methodsFor: 'accessing' stamp: 'marcus.denker 11/25/2008 15:22'! 131560monitorTypeLCDPreferenceChanged 131561 Preferences MonitorTypeLCD 131562 ifTrue:[Preferences disable: #MonitorTypeCRT] 131563 ifFalse:[ 131564 Preferences MonitorTypeCRT 131565 ifFalse:[ 131566 "turn it back on again" 131567 ^Preferences enable: #MonitorTypeLCD]]. 131568 subPixelAntiAliasing := Preferences MonitorTypeLCD. 131569 World restoreMorphicDisplay.! ! 131570 131571!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:17'! 131572monoHinting 131573 ^monoHinting ifNil:[monoHinting := false]! ! 131574 131575!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 4/2/2007 23:29'! 131576pretendBitBltSubPixelUnavailableDuring: aBlock 131577 " 131578 For testing/profiling only. 131579 131580 Answer true if the the subPixel combination rule is available, false otherwise. 131581 to test :- 131582 131583 bitBltSubPixelAvailable := false. 131584 FreeTypeCache current removeAll. 131585 Smalltalk isMorphic 131586 ifTrue:[World restoreMorphicDisplay] 131587 131588 " 131589 | old | 131590 old := bitBltSubPixelAvailable. 131591 [bitBltSubPixelAvailable := false. 131592 FreeTypeCache current removeAll. 131593 aBlock value. 131594 ] ensure:[ 131595 bitBltSubPixelAvailable := old. 131596 FreeTypeCache current removeAll.]! ! 131597 131598!FreeTypeSettings methodsFor: 'accessing' stamp: 'marcus.denker 11/29/2008 10:41'! 131599setGamma: aFloat 131600 131601 (aFloat closeTo: self gamma) 131602 ifFalse:[ 131603 gamma := aFloat. 131604 (gamma closeTo: 1.0) 131605 ifTrue:[gammaTable := gammaInverseTable := nil] 131606 ifFalse:[ 131607 gammaTable := ByteArray new: 256. 131608 gammaInverseTable := ByteArray new: 256. 131609 0 to: 255 do:[:i | 131610 | g ug | 131611 g := ((i / 255.0) raisedTo: (1.0/gamma)) * 255. 131612 ug := ((i / 255.0) raisedTo: gamma) * 255. 131613 g := (g rounded min: 255) max: 0 . 131614 ug := (ug rounded min: 255) max: 0 . 131615 gammaTable at: i + 1 put: g. 131616 gammaInverseTable at: i + 1 put: ug]]. 131617 World restoreMorphicDisplay]! ! 131618 131619!FreeTypeSettings methodsFor: 'accessing' stamp: 'marcus.denker 11/29/2008 10:43'! 131620setSubPixelFilter: ratiosArray 131621 "Set the subPixelFilters from ratiosArray. 131622 the ratiosArray can specify the red, green, and blue filter ratios separately. 131623 e.g. #((1 3 5 3 1) (1 4 7 4 1) (1 2 3 2 1)) 131624 or, as single set of ratios e.g. #(1 3 5 3 1)" 131625 131626 | validArray newFilters | 131627 validArray := ratiosArray. 131628 (ratiosArray size = 5) 131629 ifTrue:[validArray := {ratiosArray. ratiosArray. ratiosArray}]. 131630 newFilters := self subPixelFiltersFromRatios: validArray. 131631 (newFilters = subPixelFilters) 131632 ifFalse:[ 131633 subPixelFilters := newFilters. 131634 FreeTypeCache current removeAllForType: FreeTypeCacheGlyphLCD. 131635 World restoreMorphicDisplay]! ! 131636 131637!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:20'! 131638subPixelAntiAliasing 131639 self bitBltSubPixelAvailable ifFalse:[^false]. 131640 self forceNonSubPixelCount > 0 ifTrue:[^false]. 131641 ^subPixelAntiAliasing ifNil:[false]! ! 131642 131643!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:22'! 131644subPixelFilters 131645 ^subPixelFilters ifNil:[subPixelFilters := self subPixelFiltersFromRatios: self defaultSubPixelFilterRatios]! ! 131646 131647!FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:22'! 131648subPixelFiltersFromRatios: anArray 131649 "Convert the ratios in anArray to a similar array containing the filter proportions as floats. 131650 Example: 131651 if <array3ofArrays5> = #((1 3 5 3 1) (1 3 5 3 1) (1 3 5 3 1)) 131652 Then the answer is #(#(0.0769230769230769 0.2307692307692308 0.3846153846153846 0.2307692307692308 0.0769230769230769) #(0.0769230769230769 0.2307692307692308 0.3846153846153846 0.2307692307692308 0.0769230769230769) #(0.0769230769230769 0.2307692307692308 0.3846153846153846 0.2307692307692308 0.0769230769230769))" 131653 131654 | r g b rRatios gRatios bRatios rsum gsum bsum rfilter gfilter bfilter blurR blurG blurB | 131655 131656 r := "Color red luminance" 1.0 . 131657 g := "Color green luminance" 1.0 . 131658 b := "Color blue luminance"1.0 . 131659 blurR := anArray first. 131660 blurG := anArray second. 131661 blurB := anArray third. 131662 rRatios := blurR collect:[:i | r*i]. 131663 gRatios := blurG collect:[:i | g*i]. 131664 bRatios := blurB collect:[:i | b*i]. 131665 "rRatios := {g*blurR first . b*blurR second. r*blurR third. g*bl. b*blur*blur }. 131666 gRatios := {b*blur*blur. r*blur. g. b*blur. r*blur*blur}. 131667 bRatios := {r*blur*blur. g*blur. b. r*blur. g*blur*blur }." 131668 rsum := rRatios inject:0 into:[:t :i | t+i]. 131669 gsum := gRatios inject:0 into:[:t :i | t+i]. 131670 bsum := bRatios inject:0 into:[:t :i | t+i]. 131671 rfilter := rRatios collect:[:e | e / rsum]. 131672 gfilter := gRatios collect:[:e | e / gsum]. 131673 bfilter := bRatios collect:[:e | e / bsum]. 131674 ^{rfilter. gfilter. bfilter}! ! 131675 131676"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 131677 131678FreeTypeSettings class 131679 instanceVariableNames: 'current'! 131680 131681!FreeTypeSettings class methodsFor: 'class initialization' stamp: 'tween 8/31/2007 17:58'! 131682initialize 131683 " 131684 self initialize 131685 " 131686 Smalltalk removeFromStartUpList: self. 131687 Smalltalk addToStartUpList: self . 131688 Smalltalk removeFromShutDownList: self. 131689 Smalltalk addToShutDownList: self. 131690 self initializePreferences! ! 131691 131692!FreeTypeSettings class methodsFor: 'class initialization' stamp: 'torsten.bergmann 3/25/2009 04:52'! 131693initializePreferences 131694 "create preferences for all my settings if they are missing 131695 self initializePreferences 131696 " 131697 Preferences 131698 addBooleanPreference: #UpdateFontsAtImageStartup 131699 categories: {'FreeType'} 131700 default: true 131701 balloonHelp: 'Update font settings at image startup'. 131702 Preferences 131703 addBooleanPreference: #HintingFull 131704 categories: {'FreeType'} 131705 default: false 131706 balloonHelp: 'Changes glyph shapes so that their features are snapped to pixel boundaries. Glyphs are monochrome, with no anti-aliasing. This option changes the shapes the most.' 131707 projectLocal: false 131708 changeInformee: self 131709 changeSelector: #HintingFullPreferenceChanged. 131710 Preferences 131711 addBooleanPreference: #HintingNormal 131712 categories: {'FreeType'} 131713 default: false 131714 balloonHelp: 'Changes glyph shapes so that their features are snapped to pixel boundaries. Glyphs are anti-aliased' 131715 projectLocal: false 131716 changeInformee: self 131717 changeSelector: #HintingNormalPreferenceChanged. 131718 Preferences 131719 addBooleanPreference: #HintingLight 131720 categories: {'FreeType'} 131721 default: true 131722 balloonHelp: 'Changes glyph shapes so that their features are partially snapped to pixel boundaries. This option changes the shapes less than HintingFull, resulting in better shapes, but less contrast.' 131723 projectLocal: false 131724 changeInformee: self 131725 changeSelector: #HintingLightPreferenceChanged. 131726 Preferences 131727 addBooleanPreference: #HintingNone 131728 categories: {'FreeType'} 131729 default: false 131730 balloonHelp: 'Uses the original glyph shapes without snapping their features to pixel boundaries. This gives the best shapes, but with less contrast and more fuzziness.' 131731 projectLocal: false 131732 changeInformee: self 131733 changeSelector: #HintingNonePreferenceChanged. 131734 Preferences 131735 addPreference: #GlyphContrast 131736 categories: {'FreeType'} 131737 default: 50 131738 balloonHelp: 'Change the contrast level for glyphs. This is an integer between 1 and 100. (the default value is 50)' 131739 projectLocal: false 131740 changeInformee: self 131741 changeSelector: #GlyphContrastPreferenceChanged 131742 viewRegistry: (Smalltalk at: #PreferenceViewRegistry ifPresent:[:c | c ofNumericPreferences]) . 131743 Preferences 131744 addPreference: #FreeTypeCacheSize 131745 categories: {'FreeType'} 131746 default: 5000 131747 balloonHelp: 'The size of the cache in KBytes (default is 5000K)' 131748 projectLocal: false 131749 changeInformee: self 131750 changeSelector: #FreeTypeCacheSizePreferenceChanged 131751 viewRegistry: (Smalltalk at: #PreferenceViewRegistry ifPresent:[:c | c ofNumericPreferences]) ! ! 131752 131753 131754!FreeTypeSettings class methodsFor: 'instance creation' stamp: 'tween 3/30/2007 17:54'! 131755current 131756 current == nil ifFalse:[^current]. 131757 ^current := self new! ! 131758 131759 131760!FreeTypeSettings class methodsFor: 'preferences notifications' stamp: 'tween 3/30/2007 19:06'! 131761FreeTypeCacheSizePreferenceChanged 131762 FreeTypeCache current 131763 maximumSize: Preferences FreeTypeCacheSize * 1024 131764 ! ! 131765 131766!FreeTypeSettings class methodsFor: 'preferences notifications' stamp: 'tween 3/30/2007 18:50'! 131767GlyphContrastPreferenceChanged 131768 self current glyphContrastPreferenceChanged 131769 131770 ! ! 131771 131772!FreeTypeSettings class methodsFor: 'preferences notifications' stamp: 'tween 3/30/2007 18:10'! 131773HintingFullPreferenceChanged 131774 self current hintingFullPreferenceChanged 131775 131776 ! ! 131777 131778!FreeTypeSettings class methodsFor: 'preferences notifications' stamp: 'tween 3/30/2007 18:10'! 131779HintingLightPreferenceChanged 131780 self current hintingLightPreferenceChanged 131781 131782 ! ! 131783 131784!FreeTypeSettings class methodsFor: 'preferences notifications' stamp: 'tween 3/30/2007 18:10'! 131785HintingNonePreferenceChanged 131786 self current hintingNonePreferenceChanged 131787 131788 ! ! 131789 131790!FreeTypeSettings class methodsFor: 'preferences notifications' stamp: 'tween 7/15/2007 22:35'! 131791HintingNormalPreferenceChanged 131792 self current hintingNormalPreferenceChanged 131793 131794 ! ! 131795 131796!FreeTypeSettings class methodsFor: 'preferences notifications' stamp: 'tween 3/30/2007 18:10'! 131797MonitorTypeCRTPreferenceChanged 131798 self current monitorTypeCRTPreferenceChanged 131799 131800 ! ! 131801 131802!FreeTypeSettings class methodsFor: 'preferences notifications' stamp: 'tween 3/30/2007 18:10'! 131803MonitorTypeLCDPreferenceChanged 131804 self current monitorTypeLCDPreferenceChanged 131805 131806 ! ! 131807 131808 131809!FreeTypeSettings class methodsFor: 'shutdown' stamp: 'tween 8/31/2007 18:00'! 131810shutDown: quitting 131811 self current clearBitBltSubPixelAvailable. 131812 self current clearForceNonSubPixelCount! ! 131813 131814 131815!FreeTypeSettings class methodsFor: 'startup' stamp: 'tween 3/30/2007 18:03'! 131816startUp: resuming 131817 resuming 131818 ifTrue:[ 131819 self current 131820 clearBitBltSubPixelAvailable; 131821 clearForceNonSubPixelCount]! ! 131822FreeTypeGlyphRenderer subclass: #FreeTypeSubPixelAntiAliasedGlyphRenderer 131823 instanceVariableNames: '' 131824 classVariableNames: '' 131825 poolDictionaries: 'FT2Constants' 131826 category: 'FreeTypeSubPixelAntiAliasing-GlyphRendering'! 131827 131828!FreeTypeSubPixelAntiAliasedGlyphRenderer methodsFor: 'rendering' stamp: 'tween 4/4/2007 18:42'! 131829filter: aGlyphForm 131830 "aGlyphForm should be 3x stretched 8 bit GlyphForm" 131831 | w h s answer rowstart bytes word littleEndian shift v a colorVal i 131832 prevG prevB r g b nextR nextG filters rfilter gfilter bfilter 131833 balR balG balB | 131834 131835 "correctionFactor := 0.0 ." 131836 filters := FreeTypeSettings current subPixelFilters. 131837 rfilter := filters at: 1. 131838 gfilter := filters at: 2. 131839 bfilter := filters at: 3. 131840 bytes := aGlyphForm bits. 131841 w := aGlyphForm width. 131842 h := aGlyphForm height. 131843 answer := aGlyphForm class extent: ((aGlyphForm width / 3) ceiling + 2)@h depth: 32. 131844 answer 131845 offset: (aGlyphForm offset x / 3) rounded@(aGlyphForm offset y); 131846 advance: (aGlyphForm advance / 3) rounded; 131847 linearAdvance: aGlyphForm linearAdvance. 131848 s := w + 3 >> 2. 131849 littleEndian := aGlyphForm isLittleEndian. 131850 0 to: h - 1 do: [:y | 131851 rowstart := (y * s)+1. 131852 prevG := prevB :=0. 131853 0 to: w - 1 by: 3 do:[:x | 131854 0 to: 2 do:[:subpixelindex | 131855 i := x + subpixelindex. 131856 word := bytes at: rowstart + (i//4). 131857 shift := -8* (littleEndian 131858 ifTrue:[i bitAnd: 3] 131859 ifFalse:[3-(i bitAnd: 3)]). 131860 v := (word bitShift: shift) bitAnd: 16rFF. 131861 subpixelindex = 0 ifTrue:[r := v]. 131862 subpixelindex = 1 ifTrue:[g := v]. 131863 subpixelindex = 2 ifTrue:[b := v]]. 131864 x >= (w-3) 131865 ifTrue:[nextR := nextG := 0] 131866 ifFalse:[ 131867 0 to: 1 do:[:subpixelindex | 131868 i := x + 3 + subpixelindex. 131869 word := bytes at: rowstart + (i//4). 131870 shift := -8* (littleEndian 131871 ifTrue:[i bitAnd: 3] 131872 ifFalse:[3-(i bitAnd: 3)]). 131873 v := (word bitShift: shift) bitAnd: 16rFF. 131874 subpixelindex = 0 ifTrue:[nextR := v]. 131875 subpixelindex = 1 ifTrue:[nextG := v]]]. 131876 "balance r g b" 131877 balR := (prevG*(rfilter at: 1))+ 131878 (prevB*(rfilter at: 2))+ 131879 (r*(rfilter at: 3))+ 131880 (g*(rfilter at: 4))+ 131881 (b*(rfilter at: 5)). 131882 balG := (prevB*(gfilter at: 1))+ 131883 (r*(gfilter at: 2))+ 131884 (g*(gfilter at: 3))+ 131885 (b*(gfilter at: 4))+ 131886 (nextR*(gfilter at: 5)). 131887 balB := (r*(bfilter at: 1))+ 131888 (g*(bfilter at: 2))+ 131889 (b*(bfilter at: 3))+ 131890 (nextR*(bfilter at: 4))+ 131891 (nextG*(bfilter at: 5)). 131892 "luminance := (0.299*balR)+(0.587*balG)+(0.114*balB). 131893 balR := balR + ((luminance - balR)*correctionFactor). 131894 balG := balG + ((luminance - balG)*correctionFactor). 131895 balB := balB + ((luminance - balB)*correctionFactor)." 131896 balR := balR truncated. 131897 balR < 0 ifTrue:[balR := 0] ifFalse:[balR > 255 ifTrue:[balR := 255]]. 131898 balG := balG truncated. 131899 balG < 0 ifTrue:[balG := 0] ifFalse:[balG > 255 ifTrue:[balG := 255]]. 131900 balB := balB truncated. 131901 balB < 0 ifTrue:[balB := 0] ifFalse:[balB > 255 ifTrue:[balB := 255]]. 131902 a := balR + balG + balB > 0 ifTrue:[16rFF] ifFalse:[0]. 131903 colorVal := balB + (balG bitShift: 8) + (balR bitShift: 16) + (a bitShift: 24). 131904 answer bits integerAt: (y*answer width)+(x//3+1) put: colorVal. 131905 prevB := b. prevG := g. "remember the unbalanced values" ]]. 131906 ^answer! ! 131907 131908!FreeTypeSubPixelAntiAliasedGlyphRenderer methodsFor: 'rendering' stamp: 'michael.rueger 2/5/2009 17:03'! 131909renderStretchedGlyph: aCharacter depth: depth subpixelPosition: sub font: aFreeTypeFont 131910 "Glyphs are either 1 or 8 bit deep. For 32 bpp we use 8 bits, otherwise 1" 131911 | em form glyph scaleX charCode slant extraWidth s offsetX offsetY synthBoldStrength boldExtra extraHeight hintingFlags flags face | 131912 131913 charCode := aCharacter asUnicode asInteger. 131914 (aFreeTypeFont face charmaps includes:'unic') 131915 ifTrue:[ 131916 (aFreeTypeFont isSymbolFont and:[charCode >= 16r20 and: [charCode <= 16rFF ] ]) 131917 ifTrue:[charCode := charCode + 16rF000]] 131918 ifFalse:[ 131919 (aFreeTypeFont face charmaps includes:'armn') 131920 ifTrue:[ "select apple roman char map, and map character from unicode to mac encoding" 131921 aFreeTypeFont face setCharMap:'armn'. 131922 charCode := aCharacter unicodeToMacRoman asUnicode asInteger. "check this!!"]]. 131923 aCharacter < $ ifTrue: ["charCode := $ asUnicode asInteger" 131924 ^(GlyphForm extent: 0@0 depth: depth) 131925 advance: 0@0; 131926 linearAdvance: 0@0; 131927 offset:0@0; 131928 yourself ]. 131929 scaleX := 3. 131930 em := aFreeTypeFont pixelSize. 131931 [face := aFreeTypeFont face. 131932 face setPixelWidth: em height: em. 131933 hintingFlags := FreeTypeSettings current hintingFlags. 131934 flags := LoadNoBitmap bitOr:( LoadIgnoreTransform bitOr: hintingFlags). 131935 face loadCharacter:charCode flags: flags. 131936 ] on: FT2Error do:[:e | 131937 ^(GlyphForm extent: 0@0 depth: depth) 131938 advance: 0@0; 131939 linearAdvance: 0@0; 131940 offset:0@0; 131941 yourself]. 131942 glyph := face glyph. 131943 slant := aFreeTypeFont simulatedItalicSlant. 131944 synthBoldStrength := aFreeTypeFont simulatedBoldStrength. 131945 synthBoldStrength ~= 0 131946 ifTrue:[face emboldenOutline: synthBoldStrength]. 131947 boldExtra := 4 * synthBoldStrength abs ceiling. 131948 face transformOutlineAngle: 0 scalePoint: scaleX@1 slant: slant. 131949 extraWidth := (glyph height * slant) abs ceiling. 131950 extraWidth := extraWidth + boldExtra. 131951 sub > 0 ifTrue:[ extraWidth := extraWidth + 3]. 131952 extraHeight := boldExtra. 131953 form := GlyphForm 131954 extent: ((glyph width + extraWidth "+ 6" + 1 + 2)*scaleX)@(glyph height +extraHeight + 1) 131955 depth: depth. 131956 s := (glyph height-glyph hBearingY) * slant. 131957 s := s sign * (s abs ceiling). 131958 offsetX := (glyph hBearingX negated + s + (boldExtra // 2) + 1) * scaleX . 131959 offsetY := glyph height - glyph hBearingY + (boldExtra//2). 131960 face translateOutlineBy: (offsetX+(sub*scaleX/64))@offsetY. 131961 face renderGlyphIntoForm: form. 131962 form offset: ((glyph hBearingX - s - 1 - (boldExtra // 2)) * scaleX)@ (glyph hBearingY + 1 + (boldExtra / 2) ceiling) negated. 131963 "When not hinting FreeType sets the advance to the truncated linearAdvance. 131964 The characters appear squashed together. Rounding is probably better, so we fix the advance here" 131965 aFreeTypeFont subPixelPositioned 131966 ifTrue:[ form advance: glyph roundedPixelLinearAdvance * (scaleX@1)] 131967 ifFalse:[ form advance: glyph advance x * scaleX@glyph advance y]. 131968 form linearAdvance: glyph linearAdvance. 131969 ^form! ! 131970 131971!FreeTypeSubPixelAntiAliasedGlyphRenderer methodsFor: 'rendering' stamp: 'tween 4/4/2007 18:43'! 131972subGlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: aFreeTypeFont 131973 131974 | f | 131975 monoBoolean 131976 ifFalse:[ 131977 f := self 131978 renderStretchedGlyph: aCharacter 131979 depth: 8 131980 subpixelPosition: sub 131981 font: aFreeTypeFont. 131982 f := self filter: f] 131983 ifTrue:[ 131984 f := self 131985 renderGlyph: aCharacter 131986 depth: 1 131987 subpixelPosition: sub 131988 font: aFreeTypeFont. 131989 f := self fixBytesForMono: f. 131990 f := f asFormOfDepth: 32]. 131991 ^f! ! 131992 131993"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 131994 131995FreeTypeSubPixelAntiAliasedGlyphRenderer class 131996 instanceVariableNames: ''! 131997 131998!FreeTypeSubPixelAntiAliasedGlyphRenderer class methodsFor: 'class initialization' stamp: 'tween 4/4/2007 18:55'! 131999initialize 132000 " 132001 self initialize 132002 " 132003 FreeTypeGlyphRenderer current: self new. 132004 Preferences 132005 addBooleanPreference: #MonitorTypeLCD 132006 categories: {'FreeType'} 132007 default: true 132008 balloonHelp: 'Choose this if you are using an LCD monitor.' 132009 projectLocal: false 132010 changeInformee: FreeTypeSettings 132011 changeSelector: #MonitorTypeLCDPreferenceChanged. 132012 Preferences 132013 addBooleanPreference: #MonitorTypeCRT 132014 categories: {'FreeType'} 132015 default: false 132016 balloonHelp: 'Choose this if you are using a CRT monitor (i.e. not LCD)' 132017 projectLocal: false 132018 changeInformee: FreeTypeSettings 132019 changeSelector: #MonitorTypeCRTPreferenceChanged. 132020 FreeTypeSettings MonitorTypeLCDPreferenceChanged! ! 132021HierarchicalUrl subclass: #FtpUrl 132022 instanceVariableNames: '' 132023 classVariableNames: '' 132024 poolDictionaries: '' 132025 category: 'Network-Url'! 132026!FtpUrl commentStamp: 'ls 6/15/2003 13:44' prior: 0! 132027a reference to a file which may be downloaded by anonymous ftp . 132028 132029 132030 132031TODO: use the username and password, if specified 132032! 132033 132034 132035!FtpUrl methodsFor: 'access' stamp: 'ls 7/24/1998 00:18'! 132036pathString 132037 self path isEmpty ifTrue: [ ^'/' copy ]. 132038 132039 ^String streamContents: [ :s | 132040 self path do: [ :p | 132041 s nextPut: $/. 132042 s nextPutAll: p ] ]! ! 132043 132044 132045!FtpUrl methodsFor: 'downloading' stamp: 'PeterHugossonMiller 9/3/2009 01:34'! 132046downloadUrl 132047 "Returns a http download url for the location defined by this url." 132048 | ans | 132049 ans := String new writeStream. 132050 ans nextPutAll: self schemeName. 132051 ans nextPutAll: '://'. 132052 ans nextPutAll: self authority. 132053 port ifNotNil: [ans nextPut: $:; print: port]. 132054 path do: [ :pathElem | 132055 ans nextPut: $/. 132056 ans nextPutAll: pathElem encodeForHTTP. ]. 132057 self query isNil ifFalse: [ 132058 ans nextPut: $?. 132059 ans nextPutAll: self query. ]. 132060 self fragment isNil ifFalse: [ 132061 ans nextPut: $#. 132062 ans nextPutAll: self fragment encodeForHTTP. ]. 132063 132064 ^ans contents! ! 132065 132066!FtpUrl methodsFor: 'downloading' stamp: 'adrian_lienhard 7/18/2009 15:56'! 132067retrieveContents 132068 "currently assumes directories end in /, and things that don't end in / are files. Also, doesn't handle errors real well...." 132069 | server contents pathString listing auth idx fileName serverName userName password | 132070 pathString := self pathString. 132071 pathString := pathString copyFrom: 2 to: pathString size. "remove the leading /" 132072 pathString last = $/ ifTrue:["directory?!!" 132073 fileName := nil. 132074 ] ifFalse:[ 132075 fileName := pathString copyFrom: (pathString lastIndexOf: $/)+1 to: pathString size. 132076 pathString := pathString copyFrom: 1 to: (pathString lastIndexOf: $/) - 1. 132077 ]. 132078 auth := self authority. 132079 idx := auth indexOf: $@. 132080 idx > 0 ifTrue:[ 132081 serverName := (auth copyFrom: idx+1 to: auth size). 132082 userName := (auth copyFrom: 1 to: idx-1). 132083 password := nil. 132084 ] ifFalse:[ 132085 serverName := auth. 132086 userName := 'anonymous'. 132087 password := 'user'. 132088 ]. 132089 server := ServerDirectory servers 132090 detect:[:s| s isTypeFTP and:[s server asLowercase = serverName asLowercase]] 132091 ifNone:[nil]. 132092 server ifNil:[ 132093 server := ServerDirectory new. 132094 server server: serverName. 132095 ] ifNotNil:[server := server copy reset]. 132096 server user: userName. 132097 password ifNotNil:[server password: password]. 132098 server directory: pathString. 132099 132100 fileName == nil ifFalse:[ 132101 "a file" 132102 contents := (server getFileNamed: fileName). 132103 server sleep. 132104 ^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self path last) content: contents]. 132105 132106 "a directory?" 132107 listing := String streamContents: [ :stream | 132108 stream nextPutAll: '<title>', self pathString, '</title>'; cr. 132109 stream nextPutAll: '<h1>Listing for ', self pathString, '</h1>'; cr. 132110 stream nextPutAll: '<ul>'; cr. 132111 server entries do: [ :entry | 132112 stream nextPutAll: '<li>'; 132113 nextPutAll: '<a href="', entry name encodeForHTTP. 132114 entry isDirectory ifTrue: [ stream nextPut: $/ ]. 132115 stream nextPutAll: '">'; 132116 nextPutAll: entry name; 132117 nextPutAll: '</a>'; 132118 cr ] ]. 132119 server sleep. 132120 ^MIMEDocument contentType: 'text/html' content: listing! ! 132121 132122 132123!FtpUrl methodsFor: 'testing' stamp: 'ar 2/27/2001 22:07'! 132124hasRemoteContents 132125 "Return true if the receiver describes some remotely accessible content. 132126 Typically, this should only return if we could retrieve the contents 132127 on an arbitrary place in the outside world using a standard browser. 132128 In other words: If you can get to it from the next Internet Cafe, 132129 return true, else return false." 132130 ^true! ! 132131RequiresSpeedTestCase subclass: #FullMERequiresSpeedTestCase 132132 instanceVariableNames: '' 132133 classVariableNames: '' 132134 poolDictionaries: '' 132135 category: 'Tests-Traits'! 132136 132137!FullMERequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/8/2005 11:37'! 132138getInformationFor: classes 132139 classes do: 132140 [:interestingCl | 132141 interestingCl withAllSuperclassesDo: 132142 [:cl | 132143 LocalSends current for: cl. 132144 ProvidedSelectors current for: cl. 132145 RequiredSelectors current for: cl]]! ! 132146 132147!FullMERequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/9/2005 23:15'! 132148loseInterestInClasses: classes 132149 classes do: [:interestingCl | 132150 RequiredSelectors current lostInterest: self in: interestingCl. 132151 interestingCl withAllSuperclassesDo: [:cl | 132152 ProvidedSelectors current lostInterest: self in: cl. 132153 LocalSends current lostInterest: self in: cl]]! ! 132154 132155!FullMERequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/9/2005 23:11'! 132156noteInterestInClasses: classes 132157 classes do: 132158 [:interestingCl | 132159 interestingCl withAllSuperclassesDo: 132160 [:cl | 132161 LocalSends current noteInterestOf: self in: cl. 132162 ProvidedSelectors current noteInterestOf: self in: cl]. 132163 RequiredSelectors current noteInterestOf: self in: interestingCl]! ! 132164 132165!FullMERequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/8/2005 11:37'! 132166prepareAllCaches 132167 | classes | 132168 classes := displayedClasses , focusedClasses. 132169 self noteInterestInClasses: classes. 132170 self getInformationFor: classes! ! 132171Morph subclass: #FullscreenMorph 132172 instanceVariableNames: '' 132173 classVariableNames: '' 132174 poolDictionaries: '' 132175 category: 'Polymorph-Widgets'! 132176!FullscreenMorph commentStamp: 'gvc 5/18/2007 13:04' prior: 0! 132177Provides for another morph to occupy the full screen area (less docking bars).! 132178 132179 132180!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/3/2007 12:40'! 132181areasRemainingToFill: aRectangle 132182 "Optimised like BorderedMorph." 132183 132184 self fillStyle isTranslucent 132185 ifTrue: [^ Array with: aRectangle]. 132186 self wantsRoundedCorners 132187 ifTrue: [(self borderWidth > 0 132188 and: [self borderColor isColor 132189 and: [self borderColor isTranslucent]]) 132190 ifTrue: [^ aRectangle 132191 areasOutside: (self innerBounds intersect: self boundsWithinCorners)] 132192 ifFalse: [^ aRectangle areasOutside: self boundsWithinCorners]] 132193 ifFalse: [(self borderWidth > 0 132194 and: [self borderColor isColor 132195 and: [self borderColor isTranslucent]]) 132196 ifTrue: [^ aRectangle areasOutside: self innerBounds] 132197 ifFalse: [^ aRectangle areasOutside: self bounds]]! ! 132198 132199!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/30/2006 10:44'! 132200contentMorph 132201 "Answer the current content." 132202 132203 ^self submorphs first! ! 132204 132205!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/3/2007 12:39'! 132206defaultColor 132207 "Return the receiver's default color." 132208 132209 ^Color white! ! 132210 132211!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 16:21'! 132212edgeToAdhereTo 132213 "Must implement. Answer #none." 132214 132215 ^#none! ! 132216 132217!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 12:57'! 132218initialize 132219 "Initialize the receiver." 132220 132221 super initialize. 132222 self 132223 changeProportionalLayout; 132224 bounds: World clearArea; 132225 beSticky! ! 132226 132227!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 16:15'! 132228isAdheringToBottom 132229 "Must implement. Answer false." 132230 132231 ^false! ! 132232 132233!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 16:15'! 132234isAdheringToLeft 132235 "Must implement. Answer false." 132236 132237 ^false! ! 132238 132239!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 16:15'! 132240isAdheringToRight 132241 "Must implement. Answer false." 132242 132243 ^false! ! 132244 132245!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 16:15'! 132246isAdheringToTop 132247 "Must implement. Answer false." 132248 132249 ^false! ! 132250 132251!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 16:11'! 132252isDockingBar 132253 "Answer yes so we get updated when the Display is resized." 132254 132255 ^true! ! 132256 132257!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/3/2007 12:39'! 132258layoutChanged 132259 "Don't pass to owner, since the receiver doesn't care!! Improves frame rate." 132260 132261 fullBounds := nil. 132262 self layoutPolicy ifNotNilDo:[:l | l flushLayoutCache].! ! 132263 132264!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/30/2006 14:06'! 132265openAsIs 132266 "Open in the current world with the current position and extent." 132267 132268 ^self openAsIsIn: self currentWorld 132269! ! 132270 132271!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 10:03'! 132272openAsIsIn: aWorld 132273 "Start stepping." 132274 132275 aWorld addMorph: self. 132276 (self submorphs notEmpty and: [self submorphs first isSystemWindow]) 132277 ifTrue: [self submorphs first openedFullscreen]. 132278 aWorld startSteppingSubmorphsOf: self! ! 132279 132280!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 09:04'! 132281openInWorld: aWorld 132282 "Open as is." 132283 132284 ^self openAsIsIn: aWorld! ! 132285 132286!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 09:08'! 132287setContentMorph: aMorph 132288 "Replace the submorphs with aMorph." 132289 132290 self removeAllMorphs. 132291 self 132292 addMorph: aMorph 132293 fullFrame: (LayoutFrame fractions: (0@0 corner: 1@1))! ! 132294 132295!FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 19:27'! 132296updateBounds 132297 "Update the receiver's bounds to fill the world." 132298 132299 self bounds: self owner clearArea 132300 ! ! 132301 132302"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 132303 132304FullscreenMorph class 132305 instanceVariableNames: ''! 132306 132307!FullscreenMorph class methodsFor: 'as yet unclassified' stamp: 'damiencassou 7/3/2009 13:13'! 132308initialize 132309 "Set up the editableStringMorphs preferences here to allow for restricting 132310 access in a deployed image." 132311 132312 Preferences 132313 addPreference: #editableStringMorphs 132314 categories: #(morphic) 132315 default: false 132316 balloonHelp: 'Determines whether shift-clicking on a string morph will make the text editable.'! ! 132317LabelMorph subclass: #FuzzyLabelMorph 132318 instanceVariableNames: 'offset alpha' 132319 classVariableNames: '' 132320 poolDictionaries: '' 132321 category: 'Polymorph-Widgets'! 132322!FuzzyLabelMorph commentStamp: 'gvc 5/18/2007 13:16' prior: 0! 132323A label that underdraws to the top-left, top-right, bottom-right and bottom left by a specifed offset in a contrasting colour to the receiver's with a specified alpha value.! 132324 132325 132326!FuzzyLabelMorph methodsFor: 'accessing' stamp: 'gvc 3/26/2007 16:57'! 132327alpha 132328 "Answer the value of alpha" 132329 132330 ^ alpha! ! 132331 132332!FuzzyLabelMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 12:51'! 132333alpha: anObject 132334 "Set the value of alpha" 132335 132336 alpha := anObject. 132337 self changed! ! 132338 132339!FuzzyLabelMorph methodsFor: 'accessing' stamp: 'gvc 3/16/2007 10:45'! 132340offset 132341 "Answer the value of offset" 132342 132343 ^ offset! ! 132344 132345!FuzzyLabelMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 13:06'! 132346offset: anObject 132347 "Set the value of offset" 132348 132349 offset := anObject. 132350 self fitContents! ! 132351 132352 132353!FuzzyLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/10/2009 11:45'! 132354drawOn: aCanvas 132355 "Draw based on enablement." 132356 132357 |pc fuzzColor labelColor| 132358 pc := self paneColor. 132359 labelColor := self enabled 132360 ifTrue: [self color] 132361 ifFalse: [pc twiceDarker]. 132362 fuzzColor := self enabled 132363 ifTrue: [labelColor twiceDarker darker contrastingColor alpha: self alpha] 132364 ifFalse: [Color transparent]. 132365 aCanvas depth < 8 ifTrue: [fuzzColor := Color transparent]. 132366 aCanvas 132367 drawString: self contents 132368 in: (self bounds translateBy: 0@-1) 132369 font: self fontToUse 132370 color: fuzzColor; 132371 drawString: self contents 132372 in: (self bounds translateBy: (self offset * 2)@-1) 132373 font: self fontToUse 132374 color: fuzzColor; 132375 drawString: self contents 132376 in: (self bounds translateBy: (self offset * 2)@(self offset * 2 - 1)) 132377 font: self fontToUse 132378 color: fuzzColor; 132379 drawString: self contents 132380 in: (self bounds translateBy: 0@(self offset * 2 - 1)) 132381 font: self fontToUse 132382 color: fuzzColor; 132383 drawString: self contents 132384 in: (self bounds translateBy: self offset@(self offset - 1)) 132385 font: self fontToUse 132386 color: labelColor! ! 132387 132388!FuzzyLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 12:52'! 132389initWithContents: aString font: aFont emphasis: emphasisCode 132390 "Grrr, why do they do basicNew?" 132391 132392 offset := 1. 132393 alpha := 0.5. 132394 super initWithContents: aString font: aFont emphasis: emphasisCode! ! 132395 132396!FuzzyLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 12:52'! 132397initialize 132398 "Initialize the receiver." 132399 132400 offset := 1. 132401 alpha := 0.5. 132402 super initialize! ! 132403 132404!FuzzyLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/29/2007 17:02'! 132405measureContents 132406 "Add 2 times offset." 132407 132408 ^super measureContents ceiling + (self offset * 2) asPoint! ! 132409 132410!FuzzyLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/29/2007 17:22'! 132411setWidth: width 132412 "Set the width/extent." 132413 132414 self extent: width @ (self fontToUse height ceiling + (2 * self offset))! ! 132415EncodedCharSet subclass: #GB2312 132416 instanceVariableNames: '' 132417 classVariableNames: '' 132418 poolDictionaries: '' 132419 category: 'Multilingual-Encodings'! 132420!GB2312 commentStamp: 'yo 10/19/2004 19:52' prior: 0! 132421This class represents the domestic character encoding called GB 2312 used for simplified Chinese. 132422! 132423 132424 132425"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 132426 132427GB2312 class 132428 instanceVariableNames: ''! 132429 132430!GB2312 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! 132431compoundTextSequence 132432 ^ compoundTextSequence! ! 132433 132434!GB2312 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! 132435initialize 132436 " 132437 GB2312 initialize 132438" 132439 compoundTextSequence := String streamContents: 132440 [ :stream | 132441 stream nextPut: Character escape. 132442 stream nextPut: $$. 132443 stream nextPut: $(. 132444 stream nextPut: $A ]! ! 132445 132446!GB2312 class methodsFor: 'class methods' stamp: 'yo 8/6/2003 05:30'! 132447isLetter: char 132448 132449 | value leading | 132450 132451 leading := char leadingChar. 132452 value := char charCode. 132453 132454 leading = 0 ifTrue: [^ super isLetter: char]. 132455 132456 value := value // 94 + 1. 132457 ^ 1 <= value and: [value < 84]. 132458! ! 132459 132460!GB2312 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:51'! 132461leadingChar 132462 132463 ^ 2. 132464! ! 132465 132466!GB2312 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! 132467nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state 132468 | c1 c2 | 132469 state charSize: 2. 132470 state g0Leading ~= self leadingChar ifTrue: 132471 [ state g0Leading: self leadingChar. 132472 state g0Size: 2. 132473 aStream basicNextPutAll: compoundTextSequence ]. 132474 c1 := ascii // 94 + 33. 132475 c2 := ascii \\ 94 + 33. 132476 ^ aStream 132477 basicNextPut: (Character value: c1); 132478 basicNextPut: (Character value: c2)! ! 132479 132480!GB2312 class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'! 132481ucsTable 132482 132483 ^ UCSTable gb2312Table. 132484! ! 132485ImageReadWriter subclass: #GIFReadWriter 132486 instanceVariableNames: 'width height bitsPerPixel colorPalette rowByteSize xpos ypos pass interlace codeSize clearCode eoiCode freeCode maxCode prefixTable suffixTable remainBitCount bufByte bufStream transparentIndex mapOf32 localColorTable delay loopCount offset' 132487 classVariableNames: 'Extension ImageSeparator Terminator' 132488 poolDictionaries: '' 132489 category: 'Graphics-Files'! 132490!GIFReadWriter commentStamp: '<historical>' prior: 0! 132491Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved. 132492 132493Used with permission. Modified for use in Squeak.! 132494 132495 132496!GIFReadWriter methodsFor: 'accessing' stamp: 'bf 5/29/2003 01:43'! 132497delay: aNumberOrNil 132498 "Set delay for next image in hundredth (1/100) of seconds" 132499 delay := aNumberOrNil! ! 132500 132501!GIFReadWriter methodsFor: 'accessing' stamp: 'bf 5/29/2003 01:39'! 132502loopCount: aNumber 132503 "Set looping. This must be done before any image is written!!" 132504 loopCount := aNumber! ! 132505 132506!GIFReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 132507nextImage 132508 "Read in the next GIF image from the stream. Read it all into 132509memory first for speed." 132510 | f thisImageColorTable | 132511 stream class == ReadWriteStream ifFalse: 132512 [ stream binary. 132513 self on: (ReadWriteStream with: stream contentsOfEntireFile) ]. 132514 localColorTable := nil. 132515 self readHeader. 132516 f := self readBody. 132517 self close. 132518 f == nil ifTrue: [ ^ self error: 'corrupt GIF file' ]. 132519 thisImageColorTable := localColorTable ifNil: [ colorPalette ]. 132520 transparentIndex ifNotNil: 132521 [ transparentIndex + 1 > thisImageColorTable size ifTrue: 132522 [ thisImageColorTable := thisImageColorTable 132523 forceTo: transparentIndex + 1 132524 paddingWith: Color white ]. 132525 thisImageColorTable 132526 at: transparentIndex + 1 132527 put: Color transparent ]. 132528 f colors: thisImageColorTable. 132529 ^ f! ! 132530 132531!GIFReadWriter methodsFor: 'accessing' stamp: 'ar 10/24/2005 22:52'! 132532nextPutImage: aForm 132533 132534 | reduced tempForm | 132535 aForm unhibernate. 132536 aForm depth > 8 ifTrue:[ 132537 reduced := aForm colorReduced. "minimize depth" 132538 reduced depth > 8 ifTrue: [ 132539 "Not enough color space; do it the hard way." 132540 reduced := reduced asFormOfDepth: 8]. 132541 ] ifFalse:[reduced := aForm]. 132542 reduced depth < 8 ifTrue: [ 132543 "writeBitData: expects depth of 8" 132544 tempForm := reduced class extent: reduced extent depth: 8. 132545 (reduced isColorForm) ifTrue:[ 132546 tempForm 132547 copyBits: reduced boundingBox 132548 from: reduced at: 0@0 132549 clippingBox: reduced boundingBox 132550 rule: Form over 132551 fillColor: nil 132552 map: nil. 132553 tempForm colors: reduced colors. 132554 ] ifFalse: [reduced displayOn: tempForm]. 132555 reduced := tempForm. 132556 ]. 132557 (reduced isColorForm) ifTrue:[ 132558 (reduced colorsUsed includes: Color transparent) ifTrue: [ 132559 transparentIndex := (reduced colors indexOf: Color transparent) - 1. 132560 ] 132561 ] ifFalse: [transparentIndex := nil]. 132562 width := reduced width. 132563 height := reduced height. 132564 bitsPerPixel := reduced depth. 132565 colorPalette := reduced colormapIfNeededForDepth: 32. 132566 interlace := false. 132567 self writeHeader. 132568 self writeBitData: reduced bits. 132569! ! 132570 132571!GIFReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 132572setStream: aStream 132573 "Feed it in from an existing source" 132574 stream := aStream! ! 132575 132576!GIFReadWriter methodsFor: 'accessing' stamp: 'di 9/15/1998 09:53'! 132577understandsImageFormat 132578 ^('abc' collect: [:x | stream next asCharacter]) = 'GIF'! ! 132579 132580 132581!GIFReadWriter methodsFor: 'stream access' stamp: 'bf 5/29/2003 01:23'! 132582close 132583 "Write terminator" 132584 self nextPut: Terminator. 132585 ^super close! ! 132586 132587 132588!GIFReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 132589checkCodeSize 132590 (freeCode > maxCode and: [ codeSize < 12 ]) ifTrue: 132591 [ codeSize := codeSize + 1. 132592 maxCode := (1 bitShift: codeSize) - 1 ]! ! 132593 132594!GIFReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 132595setParameters: initCodeSize 132596 clearCode := 1 bitShift: initCodeSize. 132597 eoiCode := clearCode + 1. 132598 freeCode := clearCode + 2. 132599 codeSize := initCodeSize + 1. 132600 maxCode := (1 bitShift: codeSize) - 1! ! 132601 132602!GIFReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 132603updatePixelPosition 132604 (xpos := xpos + 1) >= width ifFalse: [ ^ self ]. 132605 xpos := 0. 132606 interlace ifFalse: 132607 [ ypos := ypos + 1. 132608 ^ self ]. 132609 pass = 0 ifTrue: 132610 [ (ypos := ypos + 8) >= height ifTrue: 132611 [ pass := pass + 1. 132612 ypos := 4 ]. 132613 ^ self ]. 132614 pass = 1 ifTrue: 132615 [ (ypos := ypos + 8) >= height ifTrue: 132616 [ pass := pass + 1. 132617 ypos := 2 ]. 132618 ^ self ]. 132619 pass = 2 ifTrue: 132620 [ (ypos := ypos + 4) >= height ifTrue: 132621 [ pass := pass + 1. 132622 ypos := 1 ]. 132623 ^ self ]. 132624 pass = 3 ifTrue: 132625 [ ypos := ypos + 2. 132626 ^ self ]. 132627 ^ self error: 'can''t happen'! ! 132628 132629 132630!GIFReadWriter methodsFor: 'private-bits access' stamp: 'lr 7/4/2009 10:42'! 132631flushBits 132632 remainBitCount = 0 ifFalse: 132633 [ self nextBytePut: bufByte. 132634 remainBitCount := 0 ]. 132635 self flushBuffer! ! 132636 132637!GIFReadWriter methodsFor: 'private-bits access' stamp: 'lr 7/4/2009 10:42'! 132638nextBits 132639 | integer readBitCount shiftCount byte | 132640 integer := 0. 132641 remainBitCount = 0 132642 ifTrue: 132643 [ readBitCount := 8. 132644 shiftCount := 0 ] 132645 ifFalse: 132646 [ readBitCount := remainBitCount. 132647 shiftCount := remainBitCount - 8 ]. 132648 [ readBitCount < codeSize ] whileTrue: 132649 [ byte := self nextByte. 132650 byte == nil ifTrue: [ ^ eoiCode ]. 132651 integer := integer + (byte bitShift: shiftCount). 132652 shiftCount := shiftCount + 8. 132653 readBitCount := readBitCount + 8 ]. 132654 (remainBitCount := readBitCount - codeSize) = 0 132655 ifTrue: [ byte := self nextByte ] 132656 ifFalse: [ byte := self peekByte ]. 132657 byte == nil ifTrue: [ ^ eoiCode ]. 132658 ^ integer + (byte bitShift: shiftCount) bitAnd: maxCode! ! 132659 132660!GIFReadWriter methodsFor: 'private-bits access' stamp: 'lr 7/4/2009 10:42'! 132661nextBitsPut: anInteger 132662 | integer writeBitCount shiftCount | 132663 shiftCount := 0. 132664 remainBitCount = 0 132665 ifTrue: 132666 [ writeBitCount := 8. 132667 integer := anInteger ] 132668 ifFalse: 132669 [ writeBitCount := remainBitCount. 132670 integer := bufByte + (anInteger bitShift: 8 - remainBitCount) ]. 132671 [ writeBitCount < codeSize ] whileTrue: 132672 [ self nextBytePut: ((integer bitShift: shiftCount) bitAnd: 255). 132673 shiftCount := shiftCount - 8. 132674 writeBitCount := writeBitCount + 8 ]. 132675 (remainBitCount := writeBitCount - codeSize) = 0 132676 ifTrue: [ self nextBytePut: (integer bitShift: shiftCount) ] 132677 ifFalse: [ bufByte := integer bitShift: shiftCount ]. 132678 ^ anInteger! ! 132679 132680 132681!GIFReadWriter methodsFor: 'private-decoding' stamp: 'tbn 11/15/2008 21:03'! 132682readBitData 132683 "using modified Lempel-Ziv Welch algorithm." 132684 | outCodes outCount bitMask initCodeSize code curCode oldCode inCode finChar i bytes f c packedBits hasLocalColor localColorSize maxOutCodes | 132685 maxOutCodes := 4096. 132686 offset := self readWord @ self readWord. "Image Left@Image Top" 132687 width := self readWord. 132688 height := self readWord. 132689 132690 "--- 132691 Local Color Table Flag 1 Bit 132692 Interlace Flag 1 Bit 132693 Sort Flag 1 Bit 132694 Reserved 2 Bits 132695 Size of Local Color Table 3 Bits 132696 ----" 132697 packedBits := self next. 132698 interlace := (packedBits bitAnd: 64) ~= 0. 132699 hasLocalColor := (packedBits bitAnd: 128) ~= 0. 132700 localColorSize := 1 bitShift: (packedBits bitAnd: 7) + 1. 132701 hasLocalColor ifTrue: [ localColorTable := self readColorTable: localColorSize ]. 132702 pass := 0. 132703 xpos := 0. 132704 ypos := 0. 132705 rowByteSize := (width + 3) // 4 * 4. 132706 remainBitCount := 0. 132707 bufByte := 0. 132708 bufStream := ByteArray new readStream. 132709 outCodes := ByteArray new: maxOutCodes + 1. 132710 outCount := 0. 132711 prefixTable := Array new: 4096. 132712 suffixTable := Array new: 4096. 132713 initCodeSize := self next. 132714 bitMask := (1 bitShift: initCodeSize) - 1. 132715 self setParameters: initCodeSize. 132716 bitsPerPixel > 8 ifTrue: [ ^ self error: 'never heard of a GIF that deep' ]. 132717 bytes := ByteArray new: rowByteSize * height. 132718 [ (code := self readCode) = eoiCode ] whileFalse: 132719 [ code = clearCode 132720 ifTrue: 132721 [ self setParameters: initCodeSize. 132722 curCode := oldCode := code := self readCode. 132723 finChar := curCode bitAnd: bitMask. 132724 "Horrible hack to avoid running off the end of the bitmap. Seems to cure problem reading some gifs!!? tk 6/24/97 20:16" 132725 xpos = 0 132726 ifTrue: 132727 [ ypos < height ifTrue: 132728 [ bytes 132729 at: ypos * rowByteSize + xpos + 1 132730 put: finChar ] ] 132731 ifFalse: 132732 [ bytes 132733 at: ypos * rowByteSize + xpos + 1 132734 put: finChar ]. 132735 self updatePixelPosition ] 132736 ifFalse: 132737 [ curCode := inCode := code. 132738 curCode >= freeCode ifTrue: 132739 [ curCode := oldCode. 132740 outCodes 132741 at: (outCount := outCount + 1) 132742 put: finChar ]. 132743 [ curCode > bitMask ] whileTrue: 132744 [ outCount > maxOutCodes ifTrue: [ ^ self error: 'corrupt GIF file (OutCount)' ]. 132745 outCodes 132746 at: (outCount := outCount + 1) 132747 put: (suffixTable at: curCode + 1). 132748 curCode := prefixTable at: curCode + 1 ]. 132749 finChar := curCode bitAnd: bitMask. 132750 outCodes 132751 at: (outCount := outCount + 1) 132752 put: finChar. 132753 i := outCount. 132754 [ i > 0 ] whileTrue: 132755 [ "self writePixel: (outCodes at: i) to: bits" 132756 bytes 132757 at: ypos * rowByteSize + xpos + 1 132758 put: (outCodes at: i). 132759 self updatePixelPosition. 132760 i := i - 1 ]. 132761 outCount := 0. 132762 prefixTable 132763 at: freeCode + 1 132764 put: oldCode. 132765 suffixTable 132766 at: freeCode + 1 132767 put: finChar. 132768 oldCode := inCode. 132769 freeCode := freeCode + 1. 132770 self checkCodeSize ] ]. 132771 prefixTable := suffixTable := nil. 132772 f := ColorForm 132773 extent: width @ height 132774 depth: 8. 132775 f bits copyFromByteArray: bytes. 132776 "Squeak can handle depths 1, 2, 4, and 8" 132777 bitsPerPixel > 4 ifTrue: [ ^ f ]. 132778 "reduce depth to save space" 132779 c := ColorForm 132780 extent: width @ height 132781 depth: (bitsPerPixel = 3 132782 ifTrue: [ 4 ] 132783 ifFalse: [ bitsPerPixel ]). 132784 f displayOn: c. 132785 ^ c! ! 132786 132787!GIFReadWriter methodsFor: 'private-decoding' stamp: 'lr 7/4/2009 10:42'! 132788readBody 132789 "Read the GIF blocks. Modified to return a form. " 132790 | form extype block blocksize packedFields delay1 | 132791 form := nil. 132792 [ stream atEnd ] whileFalse: 132793 [ block := self next. 132794 block = Terminator ifTrue: [ ^ form ]. 132795 block = ImageSeparator 132796 ifTrue: 132797 [ form isNil 132798 ifTrue: [ form := self readBitData ] 132799 ifFalse: [ self skipBitData ] ] 132800 ifFalse: 132801 [ block = Extension ifFalse: [ ^ form "^ self error: 'Unknown block type'" ]. 132802 "Extension block" 132803 extype := self next. "extension type" 132804 extype = 249 132805 ifTrue: 132806 [ "graphics control" 132807 self next = 4 ifFalse: [ ^ form "^ self error: 'corrupt GIF file'" ]. 132808 "==== 132809 Reserved 3 Bits 132810 Disposal Method 3 Bits 132811 User Input Flag 1 Bit 132812 Transparent Color Flag 1 Bit 132813 ===" 132814 packedFields := self next. 132815 delay1 := self next. "delay time 1" 132816 delay := (self next * 256 + delay1) * 10. "delay time 2" 132817 transparentIndex := self next. 132818 (packedFields bitAnd: 1) = 0 ifTrue: [ transparentIndex := nil ]. 132819 self next = 0 ifFalse: [ ^ form "^ self error: 'corrupt GIF file'" ] ] 132820 ifFalse: 132821 [ "Skip blocks" 132822 [ (blocksize := self next) > 0 ] whileTrue: 132823 [ "Read the block and ignore it and eat the block terminator" 132824 self next: blocksize ] ] ] ]! ! 132825 132826!GIFReadWriter methodsFor: 'private-decoding'! 132827readCode 132828 ^self nextBits! ! 132829 132830!GIFReadWriter methodsFor: 'private-decoding' stamp: 'lr 7/4/2009 10:42'! 132831readColorTable: numberOfEntries 132832 | array r g b | 132833 array := Array new: numberOfEntries. 132834 1 132835 to: array size 132836 do: 132837 [ :i | 132838 r := self next. 132839 g := self next. 132840 b := self next. 132841 array 132842 at: i 132843 put: (Color 132844 r: r 132845 g: g 132846 b: b 132847 range: 255) ]. 132848 ^ array! ! 132849 132850!GIFReadWriter methodsFor: 'private-decoding' stamp: 'lr 7/4/2009 10:42'! 132851readHeader 132852 | is89 byte hasColorMap | 132853 (self hasMagicNumber: 'GIF87a' asByteArray) 132854 ifTrue: [ is89 := false ] 132855 ifFalse: 132856 [ (self hasMagicNumber: 'GIF89a' asByteArray) 132857 ifTrue: [ is89 := true ] 132858 ifFalse: [ ^ self error: 'This does not appear to be a GIF file' ] ]. 132859 self readWord. "skip Screen Width" 132860 self readWord. "skip Screen Height" 132861 byte := self next. 132862 hasColorMap := (byte bitAnd: 128) ~= 0. 132863 bitsPerPixel := (byte bitAnd: 7) + 1. 132864 byte := self next. "skip background color." 132865 self next ~= 0 ifTrue: 132866 [ is89 ifFalse: [ ^ self error: 'corrupt GIF file (screen descriptor)' ] ]. 132867 hasColorMap 132868 ifTrue: [ colorPalette := self readColorTable: (1 bitShift: bitsPerPixel) ] 132869 ifFalse: 132870 [ "Transcript cr; show: 'GIF file does not have a color map.'." 132871 colorPalette := nil "Palette monochromeDefault" ]! ! 132872 132873!GIFReadWriter methodsFor: 'private-decoding'! 132874readWord 132875 ^self next + (self next bitShift: 8)! ! 132876 132877!GIFReadWriter methodsFor: 'private-decoding' stamp: 'lr 7/4/2009 10:42'! 132878skipBitData 132879 | misc blocksize | 132880 self readWord. "skip Image Left" 132881 self readWord. "skip Image Top" 132882 self readWord. "width" 132883 self readWord. "height" 132884 misc := self next. 132885 (misc bitAnd: 128) = 0 ifFalse: 132886 [ "skip colormap" 132887 1 132888 to: (1 bitShift: (misc bitAnd: 7) + 1) 132889 do: 132890 [ :i | 132891 self 132892 next; 132893 next; 132894 next ] ]. 132895 self next. "minimum code size" 132896 [ (blocksize := self next) > 0 ] whileTrue: [ self next: blocksize ]! ! 132897 132898 132899!GIFReadWriter methodsFor: 'private-encoding'! 132900flushCode 132901 self flushBits! ! 132902 132903!GIFReadWriter methodsFor: 'private-encoding' stamp: 'lr 7/4/2009 10:42'! 132904readPixelFrom: bits 132905 "Since bits is a Bitmap with 32 bit values, watch out for the 132906padding at the end of each row. But, GIF format already wants padding to 13290732 bit boundary!! OK as is. tk 9/14/97" 132908 | pixel | 132909 ypos >= height ifTrue: [ ^ nil ]. 132910 pixel := bits byteAt: ypos * rowByteSize + xpos + 1. 132911 self updatePixelPosition. 132912 ^ pixel! ! 132913 132914!GIFReadWriter methodsFor: 'private-encoding' stamp: 'PeterHugossonMiller 9/3/2009 01:35'! 132915writeBitData: bits 132916 "using modified Lempel-Ziv Welch algorithm." 132917 | maxBits maxMaxCode tSize initCodeSize ent tShift fCode pixel index disp nomatch | 132918 pass := 0. 132919 xpos := 0. 132920 ypos := 0. 132921 rowByteSize := (width * 8 + 31) // 32 * 4. 132922 remainBitCount := 0. 132923 bufByte := 0. 132924 bufStream := (ByteArray new: 256) writeStream. 132925 maxBits := 12. 132926 maxMaxCode := 1 bitShift: maxBits. 132927 tSize := 5003. 132928 prefixTable := Array new: tSize. 132929 suffixTable := Array new: tSize. 132930 initCodeSize := bitsPerPixel <= 1 132931 ifTrue: [ 2 ] 132932 ifFalse: [ bitsPerPixel ]. 132933 self nextPut: initCodeSize. 132934 self setParameters: initCodeSize. 132935 tShift := 0. 132936 fCode := tSize. 132937 [ fCode < 65536 ] whileTrue: 132938 [ tShift := tShift + 1. 132939 fCode := fCode * 2 ]. 132940 tShift := 8 - tShift. 132941 1 132942 to: tSize 132943 do: 132944 [ :i | 132945 suffixTable 132946 at: i 132947 put: -1 ]. 132948 self writeCodeAndCheckCodeSize: clearCode. 132949 ent := self readPixelFrom: bits. 132950 [ (pixel := self readPixelFrom: bits) == nil ] whileFalse: 132951 [ fCode := (pixel bitShift: maxBits) + ent. 132952 index := ((pixel bitShift: tShift) bitXor: ent) + 1. 132953 (suffixTable at: index) = fCode 132954 ifTrue: [ ent := prefixTable at: index ] 132955 ifFalse: 132956 [ nomatch := true. 132957 (suffixTable at: index) >= 0 ifTrue: 132958 [ disp := tSize - index + 1. 132959 index = 1 ifTrue: [ disp := 1 ]. 132960 "probe" 132961 132962 [ (index := index - disp) < 1 ifTrue: [ index := index + tSize ]. 132963 (suffixTable at: index) = fCode ifTrue: 132964 [ ent := prefixTable at: index. 132965 nomatch := false 132966 "continue whileFalse:" ]. 132967 nomatch and: [ (suffixTable at: index) > 0 ] ] whileTrue: 132968 [ "probe" 132969 ] ]. 132970 "nomatch" 132971 nomatch ifTrue: 132972 [ self writeCodeAndCheckCodeSize: ent. 132973 ent := pixel. 132974 freeCode < maxMaxCode 132975 ifTrue: 132976 [ prefixTable 132977 at: index 132978 put: freeCode. 132979 suffixTable 132980 at: index 132981 put: fCode. 132982 freeCode := freeCode + 1 ] 132983 ifFalse: 132984 [ self writeCodeAndCheckCodeSize: clearCode. 132985 1 132986 to: tSize 132987 do: 132988 [ :i | 132989 suffixTable 132990 at: i 132991 put: -1 ]. 132992 self setParameters: initCodeSize ] ] ] ]. 132993 prefixTable := suffixTable := nil. 132994 self writeCodeAndCheckCodeSize: ent. 132995 self writeCodeAndCheckCodeSize: eoiCode. 132996 self flushCode. 132997 self nextPut: 0 "zero-length packet"! ! 132998 132999!GIFReadWriter methodsFor: 'private-encoding'! 133000writeCode: aCode 133001 self nextBitsPut: aCode! ! 133002 133003!GIFReadWriter methodsFor: 'private-encoding'! 133004writeCodeAndCheckCodeSize: aCode 133005 self writeCode: aCode. 133006 self checkCodeSize! ! 133007 133008!GIFReadWriter methodsFor: 'private-encoding' stamp: 'lr 7/4/2009 10:42'! 133009writeHeader 133010 | byte | 133011 stream position = 0 ifTrue: 133012 [ "For first image only" 133013 self nextPutAll: 'GIF89a' asByteArray. 133014 self writeWord: width. "Screen Width" 133015 self writeWord: height. "Screen Height" 133016 byte := 128. "has color map" 133017 byte := byte bitOr: (bitsPerPixel - 1 bitShift: 5). "color resolution" 133018 byte := byte bitOr: bitsPerPixel - 1. "bits per pixel" 133019 self nextPut: byte. 133020 self nextPut: 0. "background color." 133021 self nextPut: 0. "reserved" 133022 colorPalette do: 133023 [ :pixelValue | 133024 self 133025 nextPut: ((pixelValue bitShift: -16) bitAnd: 255); 133026 nextPut: ((pixelValue bitShift: -8) bitAnd: 255); 133027 nextPut: (pixelValue bitAnd: 255) ]. 133028 loopCount notNil ifTrue: 133029 [ "Write a Netscape loop chunk" 133030 self nextPut: Extension. 133031 self nextPutAll: #( 133032 255 133033 11 133034 78 133035 69 133036 84 133037 83 133038 67 133039 65 133040 80 133041 69 133042 50 133043 46 133044 48 133045 3 133046 1 133047 ) asByteArray. 133048 self writeWord: loopCount. 133049 self nextPut: 0 ] ]. 133050 delay notNil | transparentIndex notNil ifTrue: 133051 [ self 133052 nextPut: Extension; 133053 nextPutAll: #(249 4 ) asByteArray; 133054 nextPut: (transparentIndex isNil 133055 ifTrue: [ 0 ] 133056 ifFalse: [ 9 ]); 133057 writeWord: (delay isNil 133058 ifTrue: [ 0 ] 133059 ifFalse: [ delay ]); 133060 nextPut: (transparentIndex isNil 133061 ifTrue: [ 0 ] 133062 ifFalse: [ transparentIndex ]); 133063 nextPut: 0 ]. 133064 self nextPut: ImageSeparator. 133065 self writeWord: 0. "Image Left" 133066 self writeWord: 0. "Image Top" 133067 self writeWord: width. "Image Width" 133068 self writeWord: height. "Image Height" 133069 byte := interlace 133070 ifTrue: [ 64 ] 133071 ifFalse: [ 0 ]. 133072 self nextPut: byte! ! 133073 133074!GIFReadWriter methodsFor: 'private-encoding'! 133075writeWord: aWord 133076 self nextPut: (aWord bitAnd: 255). 133077 self nextPut: ((aWord bitShift: -8) bitAnd: 255). 133078 ^aWord! ! 133079 133080 133081!GIFReadWriter methodsFor: 'private-packing' stamp: 'damiencassou 5/30/2008 14:51'! 133082fillBuffer 133083 | packSize | 133084 packSize := self next. 133085 bufStream := (self next: packSize) readStream! ! 133086 133087!GIFReadWriter methodsFor: 'private-packing' stamp: 'PeterHugossonMiller 9/3/2009 01:34'! 133088flushBuffer 133089 bufStream isEmpty ifTrue: [ ^ self ]. 133090 self nextPut: bufStream size. 133091 self nextPutAll: bufStream contents. 133092 bufStream := (ByteArray new: 256) writeStream.! ! 133093 133094!GIFReadWriter methodsFor: 'private-packing'! 133095nextByte 133096 bufStream atEnd 133097 ifTrue: 133098 [self atEnd ifTrue: [^nil]. 133099 self fillBuffer]. 133100 ^bufStream next! ! 133101 133102!GIFReadWriter methodsFor: 'private-packing'! 133103nextBytePut: aByte 133104 bufStream nextPut: aByte. 133105 bufStream size >= 254 ifTrue: [self flushBuffer]! ! 133106 133107!GIFReadWriter methodsFor: 'private-packing'! 133108peekByte 133109 bufStream atEnd 133110 ifTrue: 133111 [self atEnd ifTrue: [^nil]. 133112 self fillBuffer]. 133113 ^bufStream peek! ! 133114 133115"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 133116 133117GIFReadWriter class 133118 instanceVariableNames: ''! 133119 133120!GIFReadWriter class methodsFor: 'examples' stamp: 'bf 5/29/2003 01:56'! 133121exampleAnim 133122 "GIFReadWriter exampleAnim" 133123 133124 | writer extent center | 133125 writer := GIFReadWriter on: (FileStream newFileNamed: 'anim.gif'). 133126 writer loopCount: 20. "Repeat 20 times" 133127 writer delay: 10. "Wait 10/100 seconds" 133128 extent := 42@42. 133129 center := extent / 2. 133130 Cursor write showWhile: [ 133131 [2 to: center x - 1 by: 2 do: [:r | 133132 "Make a fancy anim without using Canvas - inefficient as hell" 133133 | image | 133134 image := ColorForm extent: extent depth: 8. 133135 0.0 to: 359.0 do: [:theta | image colorAt: (center + (Point r: r degrees: theta)) rounded put: Color red]. 133136 writer nextPutImage: image] 133137 ] ensure: [writer close]].! ! 133138 133139!GIFReadWriter class methodsFor: 'examples' stamp: 'adrian_lienhard 7/18/2009 15:56'! 133140grabScreenAndSaveOnDisk 133141 "GIFReaderWriter grabScreenAndSaveOnDisk" 133142 | form fileName | 133143 form := Form fromUser. 133144 form bits size = 0 ifTrue: [ ^ Beeper beep ]. 133145 fileName := FileDirectory default 133146 nextNameFor: 'Pharo' 133147 extension: 'gif'. 133148 UIManager default 133149 informUser: 'Writing ' translated, fileName 133150 during: 133151 [ GIFReadWriter 133152 putForm: form 133153 onFileNamed: fileName ]! ! 133154 133155 133156!GIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! 133157typicalFileExtensions 133158 "Answer a collection of file extensions (lowercase) which files that I can 133159 read might commonly have" 133160 133161 self 133162 allSubclasses detect: [:cls | cls wantsToHandleGIFs ] 133163 ifNone: ["if none of my subclasses wants , then i''ll have to do" 133164 ^ #('gif' )]. 133165 ^ #( )! ! 133166 133167!GIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! 133168wantsToHandleGIFs 133169 ^ false! ! 133170 133171 133172!GIFReadWriter class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 133173initialize 133174 "GIFReadWriter initialize" 133175 ImageSeparator := $, asInteger. 133176 Extension := $!! asInteger. 133177 Terminator := $; asInteger! ! 133178SharedPool subclass: #GZipConstants 133179 instanceVariableNames: '' 133180 classVariableNames: 'GZipAsciiFlag GZipCommentFlag GZipContinueFlag GZipDeflated GZipEncryptFlag GZipExtraField GZipMagic GZipNameFlag GZipReservedFlags' 133181 poolDictionaries: '' 133182 category: 'Compression-Streams'! 133183 133184"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 133185 133186GZipConstants class 133187 instanceVariableNames: ''! 133188 133189!GZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:00'! 133190gzipMagic 133191 ^GZipMagic! ! 133192 133193!GZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:00'! 133194initialize 133195 "GZipConstants initialize" 133196 GZipMagic := 16r8B1F. "GZIP magic number" 133197 GZipDeflated := 8. "Compression method" 133198 133199 GZipAsciiFlag := 16r01. "Contents is ASCII" 133200 GZipContinueFlag := 16r02. "Part of a multi-part archive" 133201 GZipExtraField := 16r04. "Archive has extra fields" 133202 GZipNameFlag := 16r08. "Archive has original file name" 133203 GZipCommentFlag := 16r10. "Archive has comment" 133204 GZipEncryptFlag := 16r20. "Archive is encrypted" 133205 GZipReservedFlags := 16rC0. "Reserved" ! ! 133206FastInflateStream subclass: #GZipReadStream 133207 instanceVariableNames: '' 133208 classVariableNames: '' 133209 poolDictionaries: 'GZipConstants' 133210 category: 'Compression-Streams'! 133211 133212!GZipReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 03:30'! 133213updateCrc: oldCrc from: start to: stop in: aCollection 133214 "Answer an updated CRC for the range of bytes in aCollection" 133215 ^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection.! ! 133216 133217!GZipReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:20'! 133218verifyCrc 133219 | stored | 133220 stored := 0. 133221 0 to: 24 by: 8 do: [ :i | 133222 sourcePos >= sourceLimit ifTrue: [ ^ self crcError: 'No checksum (proceed to ignore)' ]. 133223 stored := stored + (self nextByte bitShift: i) ]. 133224 stored := stored bitXor: 16rFFFFFFFF. 133225 stored = crc ifFalse: [ ^ self crcError: 'Wrong checksum (proceed to ignore)' ]. 133226 ^stored! ! 133227 133228 133229!GZipReadStream methodsFor: 'initialize' stamp: 'ar 2/29/2004 03:32'! 133230on: aCollection from: firstIndex to: lastIndex 133231 "Check the header of the GZIP stream." 133232 | method magic flags length | 133233 super on: aCollection from: firstIndex to: lastIndex. 133234 crc := 16rFFFFFFFF. 133235 magic := self nextBits: 16. 133236 (magic = GZipMagic) 133237 ifFalse:[^self error:'Not a GZipped stream']. 133238 method := self nextBits: 8. 133239 (method = GZipDeflated) 133240 ifFalse:[^self error:'Bad compression method']. 133241 flags := self nextBits: 8. 133242 (flags anyMask: GZipEncryptFlag) 133243 ifTrue:[^self error:'Cannot decompress encrypted stream']. 133244 (flags anyMask: GZipReservedFlags) 133245 ifTrue:[^self error:'Cannot decompress stream with unknown flags']. 133246 "Ignore stamp, extra flags, OS type" 133247 self nextBits: 16; nextBits: 16. "stamp" 133248 self nextBits: 8. "extra flags" 133249 self nextBits: 8. "OS type" 133250 (flags anyMask: GZipContinueFlag) "Number of multi-part archive - ignored" 133251 ifTrue:[self nextBits: 16]. 133252 (flags anyMask: GZipExtraField) "Extra fields - ignored" 133253 ifTrue:[ length := self nextBits: 16. 133254 1 to: length do:[:i| self nextBits: 8]]. 133255 (flags anyMask: GZipNameFlag) "Original file name - ignored" 133256 ifTrue:[[(self nextBits: 8) = 0] whileFalse]. 133257 (flags anyMask: GZipCommentFlag) "Comment - ignored" 133258 ifTrue:[[(self nextBits: 8) = 0] whileFalse]. 133259! ! 133260 133261"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 133262 133263GZipReadStream class 133264 instanceVariableNames: ''! 133265 133266!GZipReadStream class methodsFor: 'filein/out' stamp: 'yo 8/18/2004 20:24'! 133267fileIn: fullFileName 133268 "FileIn the contents of a gzipped file" 133269 | zipped unzipped | 133270 zipped := self on: (FileStream readOnlyFileNamed: fullFileName). 133271 unzipped := MultiByteBinaryOrTextStream with: (zipped contents asString). 133272 unzipped reset. 133273 unzipped fileIn. 133274! ! 133275 133276!GZipReadStream class methodsFor: 'filein/out' stamp: 'yo 7/5/2004 21:32'! 133277fileIntoNewChangeSet: fullFileName 133278 "FileIn the contents of a gzipped file" 133279 | zipped unzipped cs | 133280 cs := Smalltalk at: #ChangeSorter ifAbsent: [ ^self ]. 133281 zipped := self on: (FileStream readOnlyFileNamed: fullFileName). 133282 unzipped := MultiByteBinaryOrTextStream with: zipped contents asString. 133283 unzipped reset. 133284 cs newChangesFromStream: unzipped named: (FileDirectory localNameFor: fullFileName) 133285! ! 133286 133287!GZipReadStream class methodsFor: 'filein/out' stamp: 'yo 7/5/2004 21:10'! 133288fileReaderServicesForFile: fullName suffix: suffix 133289 | services | 133290 (suffix = 'gz') | (suffix = '*') 133291 ifFalse: [^ #()]. 133292 services := OrderedCollection new. 133293 (suffix = '*') | (fullName asLowercase endsWith: '.cs.gz') | (fullName asLowercase endsWith: '.mcs.gz') 133294 ifTrue: [services add: self serviceFileIn. 133295 (Smalltalk includesKey: #ChangeSorter) 133296 ifTrue: [services add: self serviceFileIntoNewChangeSet]]. 133297 services addAll: self services. 133298 ^ services! ! 133299 133300!GZipReadStream class methodsFor: 'filein/out' stamp: 'LEG 10/24/2001 23:56'! 133301saveContents: fullFileName 133302 "Save the contents of a gzipped file" 133303 | zipped buffer unzipped newName | 133304 newName := fullFileName copyUpToLast: FileDirectory extensionDelimiter. 133305 unzipped := FileStream newFileNamed: newName. 133306 unzipped binary. 133307 zipped := GZipReadStream on: (FileStream readOnlyFileNamed: fullFileName). 133308 buffer := ByteArray new: 50000. 133309 'Extracting ' , fullFileName 133310 displayProgressAt: Sensor cursorPoint 133311 from: 0 133312 to: zipped sourceStream size 133313 during: 133314 [:bar | 133315 [zipped atEnd] 133316 whileFalse: 133317 [bar value: zipped sourceStream position. 133318 unzipped nextPutAll: (zipped nextInto: buffer)]. 133319 zipped close. 133320 unzipped close]. 133321 ^ newName! ! 133322 133323!GZipReadStream class methodsFor: 'filein/out' stamp: 'nk 11/26/2002 12:11'! 133324serviceDecompressToFile 133325 133326 ^ FileModifyingSimpleServiceEntry 133327 provider: self 133328 label: 'decompress to file' 133329 selector: #saveContents: 133330 description: 'decompress to file'! ! 133331 133332!GZipReadStream class methodsFor: 'filein/out' stamp: 'nk 12/13/2002 11:14'! 133333serviceFileIn 133334 "Answer a service for filing in an entire file" 133335 133336 ^ SimpleServiceEntry 133337 provider: self 133338 label: 'fileIn entire file' 133339 selector: #fileIn: 133340 description: 'file in the entire decompressed contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format' 133341 buttonLabel: 'filein' 133342 133343! ! 133344 133345!GZipReadStream class methodsFor: 'filein/out' stamp: 'nk 12/13/2002 11:26'! 133346serviceFileIntoNewChangeSet 133347 "Answer a service for filing in an entire file" 133348 ^ SimpleServiceEntry 133349 provider: self 133350 label: 'install into new change set' 133351 selector: #fileIntoNewChangeSet: 133352 description: 'install the decompressed contents of the file as a body of code in the image: create a new change set and file-in the selected file into it' 133353 buttonLabel: 'install'! ! 133354 133355!GZipReadStream class methodsFor: 'filein/out' stamp: 'sd 2/1/2002 22:15'! 133356serviceViewDecompress 133357 133358 ^ SimpleServiceEntry 133359 provider: self 133360 label: 'view decompressed' 133361 selector: #viewContents: 133362 description: 'view decompressed' 133363! ! 133364 133365!GZipReadStream class methodsFor: 'filein/out' stamp: 'sd 2/1/2002 22:16'! 133366services 133367 133368 ^ Array 133369 with: self serviceViewDecompress 133370 with: self serviceDecompressToFile 133371 ! ! 133372 133373!GZipReadStream class methodsFor: 'filein/out' stamp: 'dgd 9/21/2003 17:46'! 133374uncompressedFileName: fullName 133375 ^((fullName endsWith: '.gz') and: [self confirm: ('{1} 133376appears to be a compressed file. 133377Do you want to uncompress it?' translated format:{fullName})]) 133378 ifFalse: [fullName] 133379 ifTrue:[self saveContents: fullName]! ! 133380 133381!GZipReadStream class methodsFor: 'filein/out' stamp: 'marcus.denker 11/10/2008 10:04'! 133382viewContents: fullFileName 133383 "Open the decompressed contents of the .gz file with the given name. This method is only required for the registering-file-list of Squeak 3.3a and beyond, but does no harm in an earlier system" 133384 133385 (FileStream readOnlyFileNamed: fullFileName) ifNotNil: 133386 [:aStream | aStream viewGZipContents]! ! 133387 133388 133389!GZipReadStream class methodsFor: 'initialization' stamp: 'SD 11/15/2001 22:21'! 133390unload 133391 133392 FileList unregisterFileReader: self ! ! 133393Object subclass: #GZipSurrogateStream 133394 instanceVariableNames: 'gZipStream zippedFileStream bufferStream positionThusFar' 133395 classVariableNames: '' 133396 poolDictionaries: '' 133397 category: 'Compression-Streams'! 133398!GZipSurrogateStream commentStamp: '<historical>' prior: 0! 133399A pseudo stream that allows SmartRefStream to write directly to a gzipped file. There are some peculiarities of the project exporting process that require: 133400 1334011. We ignore #close since the file is closed and may be reopened to continue writing. We implement #reallyClose for when we know that all writing is over. 133402 1334032. We use a BitBlt to write WordArrayForSegment objects. Bit of a hack, but there it is. 133404 133405| fileStream wa | 133406 133407wa _ WordArrayForSegment new: 30000. 1334081 to: wa size do: [ :i | wa at: i put: i]. 133409fileStream _ GZipSurrogateStream newFileNamed: 'xxx3.gz' inDirectory: FileDirectory default. 133410fileStream nextPutAll: 'this is a test'. 133411fileStream nextPutAll: wa. 133412fileStream reallyClose. 133413! 133414 133415 133416!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'! 133417ascii 133418 133419 self bufferStream ascii! ! 133420 133421!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:42'! 133422binary 133423 133424 self bufferStream binary! ! 133425 133426!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:43'! 133427bufferStream 133428 133429 ^bufferStream ifNil: [bufferStream := RWBinaryOrTextStream on: (ByteArray new: 5000)]. 133430! ! 133431 133432!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:26'! 133433close 133434 133435 "we don't want to until user is really done" 133436 133437 133438! ! 133439 133440!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:26'! 133441closed 133442 133443 ^false! ! 133444 133445!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:59'! 133446command: aString 133447 "Overridden by HtmlFileStream to append commands directly without translation. 4/5/96 tk" 133448 "We ignore any HTML commands. Do nothing"! ! 133449 133450!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'! 133451cr 133452 133453 self bufferStream cr! ! 133454 133455!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'sd 4/24/2008 22:18'! 133456fileOutClass: extraClass andObject: theObject 133457 "Write a file that has both the source code for the named class and an object as bits. Any instance-specific object will get its class written automatically." 133458 133459 | class srefStream | 133460 133461 self timeStamp. 133462 133463 extraClass ifNotNil: [ 133464 class := extraClass. "A specific class the user wants written" 133465 class hasSharedPools ifTrue: [ 133466 class shouldFileOutPools ifTrue: [class fileOutSharedPoolsOn: self] 133467 ]. 133468 class fileOutOn: self moveSource: false toFile: 0 133469 ]. 133470 133471 "Append the object's raw data" 133472 srefStream := SmartRefStream on: self. 133473 srefStream nextPut: theObject. "and all subobjects" 133474 srefStream close. "also closes me - well it thinks it does, anyway" 133475! ! 133476 133477!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:16'! 133478flushBuffer 133479 133480 | data | 133481 bufferStream ifNil: [^self]. 133482 data := bufferStream contents asByteArray. 133483 gZipStream nextPutAll: data. 133484 positionThusFar := positionThusFar + data size. 133485 bufferStream := nil. 133486! ! 133487 133488!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 18:36'! 133489header 133490 133491 "ignore"! ! 133492 133493!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:12'! 133494newFileNamed: fName inDirectory: aDirectory 133495 133496 positionThusFar := 0. 133497 zippedFileStream := aDirectory newFileNamed: fName. 133498 zippedFileStream binary; setFileTypeToObject. 133499 "Type and Creator not to be text, so can be enclosed in an email" 133500 gZipStream := GZipWriteStream on: zippedFileStream. 133501! ! 133502 133503!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:23'! 133504next 133505 133506 ^self bufferStream next! ! 133507 133508!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:42'! 133509nextChunkPut: aString 133510 133511 self bufferStream nextChunkPut: aString! ! 133512 133513!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:42'! 133514nextInt32Put: int32 133515 133516 ^self bufferStream nextInt32Put: int32 133517! ! 133518 133519!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'! 133520nextNumber: n put: v 133521 133522 ^self bufferStream nextNumber: n put: v 133523! ! 133524 133525!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'! 133526nextPut: aByte 133527 133528 ^self bufferStream nextPut: aByte 133529! ! 133530 133531!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:24'! 133532nextPutAll: aString 133533 133534 ^aString writeOnGZIPByteStream: self 133535! ! 133536 133537!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'! 133538nextPutAllBytes: aString 133539 133540 ^self bufferStream nextPutAll: aString 133541! ! 133542 133543!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 11:36'! 133544nextPutAllWordArray: aWordArray 133545 133546 | ba hackwa hackba blt rowsAtATime sourceOrigin rowsRemaining | 133547 133548 self flag: #bob. "do we need to be concerned by bytesPerElement??" 133549 ba := nil. 133550 rowsAtATime := 2000. "or 8000 bytes" 133551 hackwa := Form new hackBits: aWordArray. 133552 sourceOrigin := 0@0. 133553 [(rowsRemaining := hackwa height - sourceOrigin y) > 0] whileTrue: [ 133554 rowsAtATime := rowsAtATime min: rowsRemaining. 133555 (ba isNil or: [ba size ~= (rowsAtATime * 4)]) ifTrue: [ 133556 ba := ByteArray new: rowsAtATime * 4. 133557 hackba := Form new hackBits: ba. 133558 blt := (BitBlt toForm: hackba) sourceForm: hackwa. 133559 ]. 133560 blt 133561 combinationRule: Form over; 133562 sourceOrigin: sourceOrigin; 133563 destX: 0 destY: 0 width: 4 height: rowsAtATime; 133564 copyBits. 133565 self bufferStream nextPutAll: ba. 133566 self flushBuffer. 133567 sourceOrigin := sourceOrigin x @ (sourceOrigin y + rowsAtATime). 133568 ]. 133569! ! 133570 133571!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 18:42'! 133572nextStringPut: s 133573 "Append the string, s, to the receiver. Only used by DataStream. Max size of 64*256*256*256." 133574 133575 | length | 133576 (length := s size) < 192 133577 ifTrue: [self nextPut: length] 133578 ifFalse: 133579 [self nextPut: (length digitAt: 4)+192. 133580 self nextPut: (length digitAt: 3). 133581 self nextPut: (length digitAt: 2). 133582 self nextPut: (length digitAt: 1)]. 133583 self nextPutAll: s. 133584 ^s! ! 133585 133586!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'ar 5/17/2001 19:08'! 133587nextWordsPutAll: aCollection 133588 "Write the argument a word-like object in big endian format on the receiver. 133589 May be used to write other than plain word-like objects (such as ColorArray)." 133590 ^self nextPutAllWordArray: aCollection! ! 133591 133592!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 11:22'! 133593originalContents 133594 133595 ^'' "used only to determine if we are byte-structured"! ! 133596 133597!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:26'! 133598padToEndWith: aChar 133599 "We don't have pages, so we are at the end, and don't need to pad."! ! 133600 133601!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:12'! 133602position 133603 133604 ^self bufferStream position + positionThusFar! ! 133605 133606!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:13'! 133607reallyClose 133608 133609 self flushBuffer. 133610 gZipStream close. 133611! ! 133612 133613!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:30'! 133614reopen 133615 133616 "ignore"! ! 133617 133618!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 18:36'! 133619setFileTypeToObject 133620 133621 "ignore"! ! 133622 133623!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:30'! 133624setToEnd 133625 133626 "ignore"! ! 133627 133628!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:21'! 133629skip: aNumber 133630 133631 ^self bufferStream skip: aNumber 133632! ! 133633 133634!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'nk 7/29/2004 10:10'! 133635timeStamp 133636 "Append the current time to the receiver as a String." 133637 self bufferStream nextChunkPut: "double string quotes and !!s" 133638 (String streamContents: [:s | SmalltalkImage current timeStamp: s]) printString. 133639 self bufferStream cr! ! 133640 133641!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 18:37'! 133642trailer 133643 133644 "ignore"! ! 133645 133646"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 133647 133648GZipSurrogateStream class 133649 instanceVariableNames: ''! 133650 133651!GZipSurrogateStream class methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 11:50'! 133652newFileNamed: fName inDirectory: aDirectory 133653 133654 ^self new newFileNamed: fName inDirectory: aDirectory! ! 133655ZipWriteStream subclass: #GZipWriteStream 133656 instanceVariableNames: '' 133657 classVariableNames: '' 133658 poolDictionaries: 'GZipConstants' 133659 category: 'Compression-Streams'! 133660 133661!GZipWriteStream methodsFor: 'initialization' stamp: 'nk 2/19/2004 08:31'! 133662writeFooter 133663 "Write some footer information for the crc" 133664 super writeFooter. 133665 0 to: 3 do:[:i| encoder nextBytePut: (crc >> (i*8) bitAnd: 255)]. 133666 0 to: 3 do:[:i| encoder nextBytePut: (bytesWritten >> (i*8) bitAnd: 255)].! ! 133667 133668!GZipWriteStream methodsFor: 'initialization' stamp: 'ar 12/30/1999 11:41'! 133669writeHeader 133670 "Write the GZip header" 133671 encoder nextBits: 16 put: GZipMagic. 133672 encoder nextBits: 8 put: GZipDeflated. 133673 encoder nextBits: 8 put: 0. "No flags" 133674 encoder nextBits: 32 put: 0. "no time stamp" 133675 encoder nextBits: 8 put: 0. "No extra flags" 133676 encoder nextBits: 8 put: 0. "No OS type" 133677! ! 133678 133679"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 133680 133681GZipWriteStream class 133682 instanceVariableNames: ''! 133683 133684!GZipWriteStream class methodsFor: 'file list services' stamp: 'sw 11/30/2002 00:11'! 133685compressFile: fileName 133686 "Create a compressed file from the file of the given name" 133687 133688 (FileStream readOnlyFileNamed: fileName) compressFile! ! 133689 133690!GZipWriteStream class methodsFor: 'file list services' stamp: 'st 9/18/2004 23:44'! 133691fileReaderServicesForFile: fullName suffix: suffix 133692 "Don't offer to compress already-compressed files 133693 sjc 3-May 2003-added jpeg extension" 133694 133695 ^({ 'gz' . 'sar' . 'zip' . 'gif' . 'jpg' . 'jpeg'. 'pr'. 'png'} includes: suffix) 133696 ifTrue: [ #() ] 133697 ifFalse: [ self services ] 133698! ! 133699 133700!GZipWriteStream class methodsFor: 'file list services' stamp: 'nk 11/26/2002 13:17'! 133701serviceCompressFile 133702 133703 ^ FileModifyingSimpleServiceEntry 133704 provider: self 133705 label: 'compress file' 133706 selector: #compressFile: 133707 description: 'compress file using gzip compression, making a new file'! ! 133708 133709!GZipWriteStream class methodsFor: 'file list services' stamp: 'nk 11/26/2002 13:10'! 133710services 133711 ^ { self serviceCompressFile }! ! 133712 133713 133714!GZipWriteStream class methodsFor: 'initialization' stamp: 'nk 11/26/2002 13:09'! 133715initialize 133716 FileList registerFileReader: self! ! 133717 133718!GZipWriteStream class methodsFor: 'initialization' stamp: 'nk 11/26/2002 13:09'! 133719unload 133720 FileList unregisterFileReader: self! ! 133721ScrollBar subclass: #GeneralScrollBar 133722 instanceVariableNames: '' 133723 classVariableNames: '' 133724 poolDictionaries: '' 133725 category: 'Polymorph-Widgets'! 133726!GeneralScrollBar commentStamp: 'gvc 5/18/2007 13:01' prior: 0! 133727Support for GeneralScrollPane.! 133728 133729 133730!GeneralScrollBar methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 13:45'! 133731setValue: newValue 133732 "Bypass screwed up scrollbar!!" 133733 133734 ^self perform: #setValue: withArguments: {newValue} inSuperclass: Slider! ! 133735Morph subclass: #GeneralScrollPane 133736 instanceVariableNames: 'scroller hScrollbar vScrollbar' 133737 classVariableNames: '' 133738 poolDictionaries: '' 133739 category: 'Polymorph-Widgets'! 133740!GeneralScrollPane commentStamp: 'gvc 5/18/2007 13:01' prior: 0! 133741A scroll pane that handles its contents accurately.! 133742 133743 133744!GeneralScrollPane methodsFor: 'accessing' stamp: 'gvc 9/7/2006 10:16'! 133745hScrollbar 133746 "Answer the value of hScrollbar" 133747 133748 ^ hScrollbar! ! 133749 133750!GeneralScrollPane methodsFor: 'accessing' stamp: 'gvc 9/7/2006 10:16'! 133751hScrollbar: anObject 133752 "Set the value of hScrollbar" 133753 133754 hScrollbar := anObject! ! 133755 133756!GeneralScrollPane methodsFor: 'accessing' stamp: 'gvc 9/7/2006 09:40'! 133757scroller 133758 "Answer the value of scroller" 133759 133760 ^ scroller! ! 133761 133762!GeneralScrollPane methodsFor: 'accessing' stamp: 'gvc 9/7/2006 09:40'! 133763scroller: anObject 133764 "Set the value of scroller" 133765 133766 scroller := anObject! ! 133767 133768!GeneralScrollPane methodsFor: 'accessing' stamp: 'gvc 9/7/2006 10:16'! 133769vScrollbar 133770 "Answer the value of vScrollbar" 133771 133772 ^ vScrollbar! ! 133773 133774!GeneralScrollPane methodsFor: 'accessing' stamp: 'gvc 9/7/2006 10:16'! 133775vScrollbar: anObject 133776 "Set the value of vScrollbar" 133777 133778 vScrollbar := anObject! ! 133779 133780 133781!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 16:03'! 133782adoptPaneColor: paneColor 133783 "Adopt the given pane color." 133784 133785 super adoptPaneColor: paneColor. 133786 self hScrollbar adoptPaneColor: paneColor. 133787 self vScrollbar adoptPaneColor: paneColor. 133788 paneColor ifNil: [^self]. 133789 self color: (self scrollTarget isNil 133790 ifTrue: [self paneColor] 133791 ifFalse: [self scrollTarget color]) 133792! ! 133793 133794!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 12:23'! 133795defaultColor 133796 "Answer the default color/fill style for the receiver." 133797 133798 ^ Color transparent! ! 133799 133800!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:43'! 133801defaultScrollTarget 133802 "Answer a new default scroll target." 133803 133804 ^RectangleMorph new 133805 extent: 200@150! ! 133806 133807!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2006 11:06'! 133808extent: newExtent 133809 "Update the receiver's extent. Hide/show the scrollbars and resize the scroller 133810 as neccessary." 133811 133812 |scrollbarChange| 133813 bounds extent = newExtent ifTrue: [^ self]. 133814 super extent: newExtent. 133815 scrollbarChange := (self vScrollbarShowing = self vScrollbarNeeded) not. 133816 scrollbarChange := scrollbarChange or: [(self hScrollbarShowing = self hScrollbarNeeded) not]. 133817 self updateScrollbars. 133818 scrollbarChange ifFalse: [self resizeScroller] "if there is a scrollbar change then done already"! ! 133819 133820!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/3/2008 13:07'! 133821fitScrollTarget 133822 "If the scroller is bigger than the scroll target then 133823 resize the scroll target to fill the scroller." 133824 133825 |extra| 133826 extra := 0. 133827 self scroller width > self scrollTarget width 133828 ifTrue: [self scrollTarget width: self scroller width] 133829 ifFalse: [extra := self scrollBarThickness]. 133830 self scroller height - extra > self scrollTarget height 133831 ifTrue: [self scrollTarget height: self scroller height + extra]! ! 133832 133833!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:25'! 133834hHideScrollbar 133835 "Hide the horizontal scrollbar." 133836 133837 self hScrollbarShowing ifFalse: [^self]. 133838 self removeMorph: self hScrollbar. 133839 self vResizeScrollbar. 133840 self resizeScroller! ! 133841 133842!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:49'! 133843hPageDelta 133844 "Answer the horizontal page delta." 133845 133846 |pd tw sw| 133847 tw := self scrollTarget width. 133848 sw := self scrollBounds width. 133849 pd := tw - sw max: 0. 133850 pd = 0 ifFalse: [pd := sw / pd]. 133851 ^pd! ! 133852 133853!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/3/2008 13:07'! 133854hResizeScrollbar 133855 "Resize the horizontal scrollbar to fit the receiver." 133856 133857 |b| 133858 b := self innerBounds. 133859 b := b top: b bottom - self scrollBarThickness. 133860 self vScrollbarShowing ifTrue: [ 133861 b := b right: b right - self scrollBarThickness]. 133862 self hScrollbar bounds: b! ! 133863 133864!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 13:37'! 133865hScrollbarInterval 133866 "Answer the computed size of the thumb of the horizontal scrollbar." 133867 133868 ^self scrollBounds width asFloat / self scrollTarget width min: 1.0.! ! 133869 133870!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:30'! 133871hScrollbarNeeded 133872 "Return whether the horizontal scrollbar is needed." 133873 133874 ^self scrollTarget width > self innerBounds width! ! 133875 133876!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:07'! 133877hScrollbarShowing 133878 "Answer whether the horizontal scrollbar is showing." 133879 133880 ^self hScrollbar owner notNil 133881 ! ! 133882 133883!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:49'! 133884hScrollbarValue 133885 "Answer the computed horizontal scrollbar value." 133886 133887 |tw sw v| 133888 tw := self scrollTarget width. 133889 sw := self scrollBounds width. 133890 v := tw - sw max: 0. 133891 v = 0 ifFalse: [v := self scroller offset x asFloat / v min: 1.0]. 133892 ^v! ! 133893 133894!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/19/2006 10:30'! 133895hScrollbarValue: scrollValue 133896 "Set the offset of the scroller to match the 0.0-1.0 scroll value." 133897 133898 |r| 133899 r := self scrollTarget width - self scrollBounds width max: 0. 133900 self scroller 133901 offset: (r * scrollValue) rounded @ self scroller offset y! ! 133902 133903!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:50'! 133904hSetScrollDelta 133905 "Set the horizontal scrollbar delta, value and interval, based on the current scroll bounds and offset." 133906 133907 |pd| 133908 pd := self hPageDelta. 133909 self hScrollbar 133910 scrollDelta: pd / 10 133911 pageDelta: pd; 133912 interval: self hScrollbarInterval; 133913 setValue: self hScrollbarValue! ! 133914 133915!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:28'! 133916hShowScrollbar 133917 "Show the horizontal scrollbar." 133918 133919 self hResizeScrollbar. 133920 self hScrollbarShowing ifTrue: [^self]. 133921 self privateAddMorph: self hScrollbar atIndex: 1. 133922 self vResizeScrollbar. 133923 self resizeScroller! ! 133924 133925!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 12/9/2008 12:06'! 133926hUpdateScrollbar 133927 "Update the visibility and dimensions of the horizontal scrollbar as needed." 133928 133929 self hScrollbarNeeded 133930 ifTrue: [self 133931 hShowScrollbar; 133932 hResizeScrollbar] 133933 ifFalse: [self hHideScrollbar]! ! 133934 133935!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 12:16'! 133936handlesKeyboard: evt 133937 "Yes for page up/down." 133938 133939 ^true! ! 133940 133941!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 1/28/2008 16:49'! 133942handlesMouseWheel: evt 133943 "Do I want to receive mouseWheel events?." 133944 133945 ^true! ! 133946 133947!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:54'! 133948initialize 133949 "Initialize the receiver." 133950 133951 super initialize. 133952 self 133953 scroller: self newScroller; 133954 hScrollbar: self newHScrollbar; 133955 vScrollbar: self newVScrollbar; 133956 scrollTarget: self defaultScrollTarget. 133957 self 133958 addMorph: self scroller; 133959 resizeScroller! ! 133960 133961!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 12:16'! 133962keyStroke: evt 133963 "If pane is not empty, pass the event to the last submorph, 133964 assuming it is the most appropriate recipient (!!)" 133965 133966 (self scrollByKeyboard: evt) ifTrue: [^self]. 133967 self scrollTarget keyStroke: evt! ! 133968 133969!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 1/28/2008 16:55'! 133970mouseWheel: event 133971 "Handle a mouseWheel event." 133972 133973 (self scrollTarget handlesMouseWheel: event) 133974 ifTrue: [^self scrollTarget mouseWheel: event]. "pass on" 133975 event direction = #up ifTrue: [ 133976 vScrollbar scrollUp: 3]. 133977 event direction = #down ifTrue: [ 133978 vScrollbar scrollDown: 3]! ! 133979 133980!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 13:45'! 133981newHScrollbar 133982 "Answer a new horizontal scrollbar." 133983 133984 ^GeneralScrollBar new 133985 model: self; 133986 setValueSelector: #hScrollbarValue:! ! 133987 133988!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 09:50'! 133989newScroller 133990 "Answer a new scroller." 133991 133992 ^TransformMorph new 133993 color: Color transparent! ! 133994 133995!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 13:45'! 133996newVScrollbar 133997 "Answer a new vertical scrollbar." 133998 133999 ^GeneralScrollBar new 134000 model: self; 134001 setValueSelector: #vScrollbarValue:! ! 134002 134003!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 09:57'! 134004resizeScroller 134005 "Resize the scroller to fit the scroll bounds." 134006 134007 self scroller bounds: self scrollBounds! ! 134008 134009!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/3/2008 13:06'! 134010scrollBarThickness 134011 "Answer the width or height of a scrollbar as appropriate to 134012 its orientation." 134013 134014 ^self theme scrollbarThickness! ! 134015 134016!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/3/2008 13:07'! 134017scrollBounds 134018 "Return the visible scroll area taking into account whether 134019 the scrollbars need to be shown." 134020 134021 |b| 134022 b := self innerBounds. 134023 self vScrollbarNeeded ifTrue: [b := b right: (b right - self scrollBarThickness)]. 134024 self hScrollbarNeeded ifTrue: [b := b bottom: (b bottom - self scrollBarThickness)]. 134025 ^b! ! 134026 134027!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:50'! 134028scrollByKeyboard: event 134029 "If event is ctrl+up/down then scroll and answer true." 134030 134031 |sb| 134032 sb := event commandKeyPressed 134033 ifTrue: [self hScrollbar] 134034 ifFalse: [self vScrollbar]. 134035 (event keyValue = 30 or: [event keyValue = 11]) ifTrue: [ 134036 sb scrollUp: 3. 134037 ^true]. 134038 (event keyValue = 31 or: [event keyValue = 12])ifTrue: [ 134039 sb scrollDown: 3. 134040 ^true]. 134041 ^false! ! 134042 134043!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 09:48'! 134044scrollTarget 134045 "Answer the morph that is scrolled." 134046 134047 ^self scroller submorphs first! ! 134048 134049!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:48'! 134050scrollTarget: aMorph 134051 "Set the morph that is scrolled." 134052 134053 self scroller 134054 removeAllMorphs; 134055 addMorph: aMorph. 134056 self updateScrollbars! ! 134057 134058!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 2/6/2008 10:19'! 134059scrollToShow: aRectangle 134060 "Scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space." 134061 134062 |offset| 134063 offset := self scroller offset. 134064 ((aRectangle top - offset y) >= 0 and: [ 134065 (aRectangle bottom - offset y) <= self innerBounds height]) 134066 ifFalse: [offset := offset x @ ( 134067 (aRectangle top min: self scrollTarget height - self innerBounds height))]. 134068 ((aRectangle left - offset x) >= 0 and: [ 134069 (aRectangle right - offset x) <= self innerBounds width]) 134070 ifFalse: [offset := (aRectangle left min: self scrollTarget width - self innerBounds width) @ offset y]. 134071 offset = self scroller offset ifFalse: [ 134072 self scroller offset: offset. 134073 self setScrollDeltas]! ! 134074 134075!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 09:56'! 134076scrollbarThickness 134077 "Answer the width or height of a scrollbar as appropriate to 134078 its orientation." 134079 134080 ^Preferences scrollBarsNarrow 134081 ifTrue: [10] 134082 ifFalse: [14]! ! 134083 134084!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 11:16'! 134085setScrollDeltas 134086 "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range." 134087 134088 self 134089 hSetScrollDelta; 134090 vSetScrollDelta! ! 134091 134092!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 11:16'! 134093updateScrollbars 134094 "Update the visibility, dimensions and values of the scrollbars as needed." 134095 134096 self 134097 vUpdateScrollbar; 134098 hUpdateScrollbar; 134099 setScrollDeltas! ! 134100 134101!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:25'! 134102vHideScrollbar 134103 "Hide the vertical scrollbar." 134104 134105 self vScrollbarShowing ifFalse: [^self]. 134106 self removeMorph: self vScrollbar. 134107 self hResizeScrollbar. 134108 self resizeScroller! ! 134109 134110!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 13:47'! 134111vLeftoverScrollRange 134112 "Return the entire scrolling range minus the currently viewed area." 134113 134114 ^self scrollTarget height - self scrollBounds height max: 0 134115! ! 134116 134117!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:50'! 134118vPageDelta 134119 "Answer the vertical page delta." 134120 134121 |pd tw sw| 134122 tw := self scrollTarget height. 134123 sw := self scrollBounds height. 134124 pd := tw - sw max: 0. 134125 pd = 0 ifFalse: [pd := sw / pd]. 134126 ^pd! ! 134127 134128!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/3/2008 13:07'! 134129vResizeScrollbar 134130 "Resize the vertical scrollbar to fit the receiver." 134131 134132 |b| 134133 b := self innerBounds. 134134 b := b left: b right - self scrollBarThickness. 134135 self hScrollbarShowing ifTrue: [ 134136 b := b bottom: b bottom - self scrollBarThickness]. 134137 self vScrollbar bounds: b! ! 134138 134139!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 13:48'! 134140vScrollbarInterval 134141 "Answer the computed size of the thumb of the vertical scrollbar." 134142 134143 ^self scrollBounds height asFloat / self scrollTarget height min: 1.0.! ! 134144 134145!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:30'! 134146vScrollbarNeeded 134147 "Return whether the vertical scrollbar is needed." 134148 134149 ^self scrollTarget height > self innerBounds height! ! 134150 134151!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:15'! 134152vScrollbarShowing 134153 "Answer whether the vertical scrollbar is showing." 134154 134155 ^self vScrollbar owner notNil 134156 ! ! 134157 134158!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:50'! 134159vScrollbarValue 134160 "Answer the computed vertical scrollbar value." 134161 134162 |tw sw v| 134163 tw := self scrollTarget height. 134164 sw := self scrollBounds height. 134165 v := tw - sw max: 0. 134166 v = 0 ifFalse: [v := self scroller offset y asFloat / v min: 1.0]. 134167 ^v! ! 134168 134169!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/19/2006 10:30'! 134170vScrollbarValue: scrollValue 134171 "Set the offset of the scroller to match the 0.0-1.0 scroll value." 134172 134173 |r| 134174 r := self scrollTarget height - self scrollBounds height max: 0. 134175 self scroller 134176 offset: self scroller offset x @ (r * scrollValue) rounded! ! 134177 134178!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:51'! 134179vSetScrollDelta 134180 "Set the vertical scrollbar delta, value and interval, based on the current scroll bounds and offset." 134181 134182 |pd| 134183 pd := self vPageDelta. 134184 self vScrollbar 134185 scrollDelta: pd / 10 134186 pageDelta: pd; 134187 interval: self vScrollbarInterval; 134188 setValue: self vScrollbarValue! ! 134189 134190!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:28'! 134191vShowScrollbar 134192 "Show the vertical scrollbar." 134193 134194 self vResizeScrollbar. 134195 self vScrollbarShowing ifTrue: [^self]. 134196 self privateAddMorph: self vScrollbar atIndex: 1. 134197 self hResizeScrollbar. 134198 self resizeScroller! ! 134199 134200!GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:03'! 134201vUpdateScrollbar 134202 "Update the visibility and dimensions of the vertical scrollbar as needed." 134203 134204 self vScrollbarNeeded 134205 ifTrue: [self 134206 vShowScrollbar; 134207 vResizeScrollbar] 134208 ifFalse: [self vHideScrollbar]! ! 134209Url subclass: #GenericUrl 134210 instanceVariableNames: 'schemeName locator' 134211 classVariableNames: '' 134212 poolDictionaries: '' 134213 category: 'Network-Url'! 134214!GenericUrl commentStamp: '<historical>' prior: 0! 134215a URL type that can't be broken down in any systematic way. For example, mailto: and telnet: URLs. The part after the scheme name is stored available via the #locator message.! 134216 134217 134218!GenericUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:46'! 134219locator 134220 ^locator! ! 134221 134222!GenericUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:46'! 134223schemeName 134224 ^schemeName! ! 134225 134226 134227!GenericUrl methodsFor: 'classification' stamp: 'FBS 11/20/2003 13:39'! 134228scheme 134229 ^ self schemeName.! ! 134230 134231 134232!GenericUrl methodsFor: 'parsing' stamp: 'ls 8/4/1998 01:28'! 134233privateInitializeFromText: aString 134234 schemeName := Url schemeNameForString: aString. 134235 schemeName ifNil: [ self error: 'opaque URL with no scheme--shouldn''t happen!!'. ]. 134236 locator := aString copyFrom: (schemeName size+2) to: aString size.! ! 134237 134238!GenericUrl methodsFor: 'parsing' stamp: 'ls 8/4/1998 01:28'! 134239privateInitializeFromText: aString relativeTo: aUrl 134240 schemeName := aUrl schemeName. 134241 locator := aString.! ! 134242 134243 134244!GenericUrl methodsFor: 'printing' stamp: 'fbs 2/2/2005 13:06'! 134245printOn: aStream 134246 134247 aStream nextPutAll: self schemeName. 134248 aStream nextPut: $:. 134249 aStream nextPutAll: self locator. 134250 134251 self fragment ifNotNil: 134252 [aStream nextPut: $#. 134253 aStream nextPutAll: self fragment].! ! 134254 134255 134256!GenericUrl methodsFor: 'private' stamp: 'ls 6/20/1998 19:46'! 134257schemeName: schemeName0 locator: locator0 134258 schemeName := schemeName0. 134259 locator := locator0.! ! 134260 134261"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 134262 134263GenericUrl class 134264 instanceVariableNames: ''! 134265 134266!GenericUrl class methodsFor: 'instance creation' stamp: 'ls 6/20/1998 19:46'! 134267schemeName: schemeName locator: locator 134268 ^self new schemeName: schemeName locator: locator! ! 134269 134270 134271!GenericUrl class methodsFor: 'parsing' stamp: 'ls 7/26/1998 21:24'! 134272absoluteFromText: aString 134273 | schemeName locator | 134274 schemeName := Url schemeNameForString: aString. 134275 schemeName ifNil: [ ^self schemeName: 'xnoscheme' locator: aString ]. 134276 locator := aString copyFrom: (schemeName size + 2) to: aString size. 134277 ^self schemeName: schemeName locator: locator! ! 134278ClassTestCase subclass: #GenericUrlTest 134279 instanceVariableNames: '' 134280 classVariableNames: '' 134281 poolDictionaries: '' 134282 category: 'NetworkTests-Url'! 134283 134284!GenericUrlTest methodsFor: 'testing' stamp: 'fbs 2/2/2005 12:56'! 134285testAsString 134286 | url | 134287 url := GenericUrl new schemeName: 'sip' locator: 'foo@bar'. 134288 self assert: url asString = 'sip:foo@bar'.! ! 134289Form subclass: #GlyphForm 134290 instanceVariableNames: 'advance linearAdvance' 134291 classVariableNames: '' 134292 poolDictionaries: '' 134293 category: 'FreeType-Fonts'! 134294 134295!GlyphForm methodsFor: 'accessing' stamp: 'tween 4/23/2006 20:54'! 134296advance 134297 ^advance! ! 134298 134299!GlyphForm methodsFor: 'accessing' stamp: 'tween 4/23/2006 20:54'! 134300advance: aNumber 134301 ^advance := aNumber! ! 134302 134303!GlyphForm methodsFor: 'accessing' stamp: 'tween 8/6/2006 21:10'! 134304linearAdvance 134305 ^linearAdvance 134306! ! 134307 134308!GlyphForm methodsFor: 'accessing' stamp: 'tween 8/6/2006 21:10'! 134309linearAdvance: aNumber 134310 ^linearAdvance := aNumber! ! 134311 134312 134313!GlyphForm methodsFor: 'converting' stamp: 'tween 8/6/2006 21:57'! 134314asFormOfDepth: d 134315 | newForm | 134316 d = self depth ifTrue:[^self]. 134317 newForm := self class extent: self extent depth: d. 134318 (BitBlt current toForm: newForm) 134319 colorMap: (self colormapIfNeededFor: newForm); 134320 copy: (self boundingBox) 134321 from: 0@0 in: self 134322 fillColor: nil rule: Form over. 134323 newForm 134324 offset: offset; 134325 advance:advance; 134326 linearAdvance: linearAdvance. 134327 ^newForm! ! 134328Object subclass: #Gofer 134329 instanceVariableNames: 'references repository' 134330 classVariableNames: '' 134331 poolDictionaries: '' 134332 category: 'Gofer-Core'! 134333!Gofer commentStamp: 'lr 10/17/2009 14:51' prior: 0! 134334: Gofer, a person who runs errands. Origin 1960s: from go for, i.e. go and fetch. 134335: ''The New Oxford American Dictionary'' 134336 134337Gofer is a small tool on top of Monticello that loads, updates, merges, diffs, reverts, commits, recompiles and unloads groups of Monticello packages. Contrary to existing tools Gofer makes sure that these operations are performed as clean as possible: 134338 134339- Gofer treats packages from one or more repository in one operation. 134340- Gofer works with fixed versions or tries to find the "latest" version using a given name prefix. 134341- Gofer automatically assigns repositories to all packages, so that the other tools are ready to be used on individual packages. 134342- Gofer makes sure that there is only one repository instance registered for a single physical location. 134343- Gofer works with Monticello dependencies and uniformly treats them like the primary package. 134344- Gofer cleans up after Monticello, no empty class categories and no empty method protocols are to be expected. 134345 134346To get started with Gofer in Pharo use the following script: 134347 134348== ScriptLoader new installGofer 134349 134350To use Gofer to load the "latest" Seaside 2.8 packages (==addPackage:==) together with exact versions of its prerequisites (==addVersion:==) one would write and evaluate the following code: 134351 134352== Gofer new 134353== squeaksource: 'KomHttpServer'; 134354== addVersion: 'DynamicBindings-gc.7'; 134355== addVersion: 'KomServices-gc.19'; 134356== addVersion: 'KomHttpServer-gc.32'; 134357== squeaksource: 'Seaside'; 134358== addPackage: 'Seaside2.8a'; 134359== addPackage: 'Scriptaculous'; 134360== load 134361 134362However, this is only the beginning. Developers might want to keep the Gofer specification in a workspace to perform other actions on the specified set of packages: 134363 134364== gofer := Gofer new. 134365== gofer 134366== squeaksource: 'KomHttpServer'; 134367== addVersion: 'DynamicBindings-gc.7'; 134368== addVersion: 'KomServices-gc.19'; 134369== addVersion: 'KomHttpServer-gc.32'; 134370== squeaksource: 'Seaside'; 134371== addPackage: 'Seaside2.8a'; 134372== addPackage: 'Scriptaculous'. 134373 134374Now the following expressions can be used at any time: 134375 134376| ==gofer load== | Load all packages. 134377| ==gofer update== | Update all packages. 134378| ==gofer merge== | Merge all packages into their working copies. 134379| ==gofer diff== | Display the difference between the working copy and the base version of all packages. 134380| ==gofer commit== | Commit all modified packages. 134381| ==gofer commit: aString== | Commit all modified packages with the commit comment aString. 134382| ==gofer revert== | Revert all packages to their base version. 134383| ==gofer recompile== | Recompile all packages. 134384| ==gofer unload== | Unload all packages.! 134385 134386 134387!Gofer methodsFor: 'adding' stamp: 'lr 10/12/2009 23:56'! 134388add: aReference 134389 "Add aReference to the list of packages." 134390 134391 ^ aReference isString 134392 ifTrue: [ self notify: 'Please note that adding package references as strings (such as ' , aReference printString , ') is no longer supported, because Gofer cannot guess your naming conventions. Adapt your code to either call #addPackage: (for full package names, e.g. ''Gofer''), #addVersion: (for complete version names, e.g. ''Gofer-lr.54'') or #addQuery:do: (for full package names, e.g. ''Gofer'', with the possiblity to add additional conditions, e.g. reference author: ''lr''; branch: ''super''). This lets Gofer know what exactly you want, and in return it will more likely do what you expect.' ] 134393 ifFalse: [ self references addLast: aReference ]! ! 134394 134395!Gofer methodsFor: 'adding' stamp: 'lr 10/12/2009 23:52'! 134396addPackage: aString 134397 "Add the package aString to the receiver." 134398 134399 ^ self add: (GoferPackageReference name: aString repository: self repository)! ! 134400 134401!Gofer methodsFor: 'adding' stamp: 'lr 10/17/2009 14:26'! 134402addPackage: aString constraint: aOneArgumentBlock 134403 "Add the package aString to the receiver, constraint the resulting versions further with aOneArgumentBlock." 134404 134405 | reference | 134406 reference := GoferConstraintReference 134407 name: aString repository: self repository. 134408 reference constraintBlock: aOneArgumentBlock. 134409 ^ self add: reference! ! 134410 134411!Gofer methodsFor: 'adding' stamp: 'lr 10/12/2009 23:52'! 134412addVersion: aString 134413 "Add the version aString to the receiver." 134414 134415 ^ self add: (GoferVersionReference name: aString repository: self repository)! ! 134416 134417 134418!Gofer methodsFor: 'actions' stamp: 'obi 10/3/2009 19:03'! 134419changeLog 134420 "Display all changeLogs between the working copy and the latest package version." 134421 134422 ^ self execute: GoferChangeLog! ! 134423 134424!Gofer methodsFor: 'actions' stamp: 'lr 10/3/2009 11:31'! 134425cleanup 134426 "Cleans the specified packages." 134427 134428 ^ self execute: GoferCleanup! ! 134429 134430!Gofer methodsFor: 'actions' stamp: 'lr 10/2/2009 10:08'! 134431commit 134432 "Commit the specified packages." 134433 134434 ^ self execute: GoferCommit! ! 134435 134436!Gofer methodsFor: 'actions' stamp: 'lr 10/2/2009 10:09'! 134437commit: aString 134438 "Commit the specified packages with the given commit message aString." 134439 134440 ^ self execute: GoferCommit do: [ :operation | operation message: aString ]! ! 134441 134442!Gofer methodsFor: 'actions' stamp: 'lr 8/20/2009 10:14'! 134443diff 134444 "Display the differences between the working copy and the base of the specified packages." 134445 134446 ^ self execute: GoferDiff! ! 134447 134448!Gofer methodsFor: 'actions' stamp: 'lr 8/20/2009 10:14'! 134449load 134450 "Load the specified packages." 134451 134452 ^ self execute: GoferLoad! ! 134453 134454!Gofer methodsFor: 'actions' stamp: 'lr 8/20/2009 10:14'! 134455merge 134456 "Merge the specified packages." 134457 134458 ^ self execute: GoferMerge! ! 134459 134460!Gofer methodsFor: 'actions' stamp: 'lr 8/20/2009 11:44'! 134461recompile 134462 "Recompile the specified packages." 134463 134464 ^ self execute: GoferRecompile! ! 134465 134466!Gofer methodsFor: 'actions' stamp: 'lr 8/20/2009 10:15'! 134467revert 134468 "Revert the specified packages to the currently loaded version." 134469 134470 ^ self execute: GoferRevert! ! 134471 134472!Gofer methodsFor: 'actions' stamp: 'lr 9/3/2009 11:57'! 134473unload 134474 "Update the specified packages, this is the same as loading." 134475 134476 ^ self execute: GoferUnload! ! 134477 134478!Gofer methodsFor: 'actions' stamp: 'lr 9/18/2009 18:12'! 134479update 134480 "Update the specified packages." 134481 134482 ^ self execute: GoferUpdate! ! 134483 134484 134485!Gofer methodsFor: 'repositories' stamp: 'lr 7/10/2009 16:27'! 134486croquet: aString 134487 self url: 'http://hedgehog.software.umn.edu:8888/' , aString! ! 134488 134489!Gofer methodsFor: 'repositories' stamp: 'dkh 10/16/2009 10:04'! 134490gemsource: aString 134491 self url: 'http://seaside.gemstone.com/ss/' , aString! ! 134492 134493!Gofer methodsFor: 'repositories' stamp: 'lr 7/10/2009 16:27'! 134494impara: aString 134495 self url: 'http://source.impara.de/' , aString! ! 134496 134497!Gofer methodsFor: 'repositories' stamp: 'lr 7/10/2009 16:25'! 134498renggli: aString 134499 self url: 'http://source.lukas-renggli.ch/' , aString! ! 134500 134501!Gofer methodsFor: 'repositories' stamp: 'lr 7/10/2009 16:29'! 134502saltypickle: aString 134503 self url: 'http://squeak.saltypickle.com/' , aString! ! 134504 134505!Gofer methodsFor: 'repositories' stamp: 'lr 7/10/2009 16:28'! 134506squeakfoundation: aString 134507 self url: 'http://source.squeakfoundation.org/' , aString! ! 134508 134509!Gofer methodsFor: 'repositories' stamp: 'lr 7/10/2009 16:28'! 134510squeaksource: aString 134511 self url: 'http://www.squeaksource.com/' , aString! ! 134512 134513!Gofer methodsFor: 'repositories' stamp: 'lr 9/7/2009 20:11'! 134514url: aString 134515 "Set the repository URL aString as the location for the following package additions." 134516 134517 self url: aString username: String new password: String new! ! 134518 134519!Gofer methodsFor: 'repositories' stamp: 'lr 9/7/2009 20:12'! 134520url: aString username: aUsernameString password: aPasswordString 134521 "Set the repository URL aString as the location for the following package additions." 134522 134523 self repository: (MCHttpRepository 134524 location: aString 134525 user: aUsernameString 134526 password: aPasswordString)! ! 134527 134528!Gofer methodsFor: 'repositories' stamp: 'lr 7/10/2009 16:26'! 134529wiresong: aString 134530 self url: 'http://source.wiresong.ca/' , aString! ! 134531 134532 134533!Gofer methodsFor: 'private' stamp: 'lr 10/2/2009 10:11'! 134534execute: anOperationClass 134535 ^ self execute: anOperationClass do: nil! ! 134536 134537!Gofer methodsFor: 'private' stamp: 'lr 10/2/2009 10:11'! 134538execute: anOperationClass do: aBlock 134539 | operation | 134540 ^ GoferVersionCache during: [ 134541 operation := anOperationClass on: self. 134542 aBlock isNil 134543 ifFalse: [ aBlock value: operation ]. 134544 operation execute ]! ! 134545 134546 134547!Gofer methodsFor: 'initialization' stamp: 'lr 10/2/2009 10:09'! 134548initialize 134549 references := OrderedCollection new! ! 134550 134551 134552!Gofer methodsFor: 'copying' stamp: 'lr 10/2/2009 10:09'! 134553postCopy 134554 super postCopy. 134555 references := references copy! ! 134556 134557 134558!Gofer methodsFor: 'accessing' stamp: 'lr 10/1/2009 21:08'! 134559references 134560 "Answer a list of references." 134561 134562 ^ references! ! 134563 134564!Gofer methodsFor: 'accessing' stamp: 'lr 10/2/2009 10:08'! 134565repository 134566 "Answer a current repository or nil." 134567 134568 ^ repository! ! 134569 134570!Gofer methodsFor: 'accessing' stamp: 'lr 10/2/2009 10:21'! 134571repository: aRepository 134572 "Set the repository aRepository as the location for the following package additions." 134573 134574 MCRepositoryGroup default 134575 addRepository: aRepository. 134576 repository := MCRepositoryGroup default repositories 134577 detect: [ :each | each = aRepository ] 134578 ifNone: [ self error: 'Internal error' ]. 134579 repository copyFrom: aRepository! ! 134580 134581"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 134582 134583Gofer class 134584 instanceVariableNames: ''! 134585 134586!Gofer class methodsFor: 'examples' stamp: 'lr 10/2/2009 10:17'! 134587gofer 134588 "Create a Gofer instance of Gofer." 134589 134590 ^ self new 134591 renggli: 'flair'; 134592 addPackage: 'Gofer'; 134593 yourself! ! 134594 134595!Gofer class methodsFor: 'examples' stamp: 'lr 10/2/2009 10:18'! 134596komanche 134597 "Create a Gofer instance of Komanche." 134598 134599 ^ self new 134600 squeaksource: 'KomHttpServer'; 134601 addPackage: 'DynamicBindings'; 134602 addPackage: 'KomServices'; 134603 addPackage: 'KomHttpServer'; 134604 yourself! ! 134605 134606!Gofer class methodsFor: 'examples' stamp: 'lr 10/2/2009 10:18'! 134607magritte 134608 "Create a Gofer instance of Magritte." 134609 134610 ^ self new 134611 renggli: 'magritte'; 134612 addPackage: 'Magritte-Model'; 134613 addPackage: 'Magritte-Tests'; 134614 addPackage: 'Magritte-Seaside'; 134615 addPackage: 'Magritte-Morph'; 134616 yourself! ! 134617 134618!Gofer class methodsFor: 'examples' stamp: 'lr 10/2/2009 10:18'! 134619omnibrowser 134620 "Create a Gofer instance of OmniBrowser." 134621 134622 ^ self new 134623 renggli: 'omnibrowser'; 134624 addPackage: 'OmniBrowser'; 134625 addPackage: 'OB-Standard'; 134626 addPackage: 'OB-Morphic'; 134627 addPackage: 'OB-Refactory'; 134628 addPackage: 'OB-Regex'; 134629 addPackage: 'OB-SUnitIntegration'; 134630 yourself! ! 134631 134632!Gofer class methodsFor: 'examples' stamp: 'lr 10/2/2009 10:18'! 134633pier 134634 "Create a Gofer instance of Pier." 134635 134636 ^ self new 134637 renggli: 'pier'; 134638 addPackage: 'Pier-Model'; 134639 addPackage: 'Pier-Tests'; 134640 addPackage: 'Pier-Seaside'; 134641 addPackage: 'Pier-Blog'; 134642 addPackage: 'Pier-Security'; 134643 addPackage: 'Pier-Squeak-Persistency'; 134644 yourself! ! 134645 134646!Gofer class methodsFor: 'examples' stamp: 'lr 10/2/2009 10:19'! 134647pierAddons 134648 "Create a Gofer instance of Pier Addons." 134649 134650 ^ self new 134651 renggli: 'pieraddons'; 134652 addPackage: 'Pier-Design'; 134653 addPackage: 'Pier-Documents'; 134654 addPackage: 'Pier-EditorEnh'; 134655 addPackage: 'Pier-Google'; 134656 addPackage: 'Pier-Links'; 134657 addPackage: 'Pier-Randomizer'; 134658 addPackage: 'Pier-TagCloud'; 134659 addPackage: 'Pier-Slideshow'; 134660 addPackage: 'Pier-Setup'; 134661 yourself! ! 134662 134663!Gofer class methodsFor: 'examples' stamp: 'lr 10/2/2009 10:19'! 134664refactoring 134665 "Create a Gofer instance of the refactoring tools." 134666 134667 ^ self new 134668 squeaksource: 'AST'; 134669 addPrefix: 'AST-lr'; 134670 squeaksource: 'RefactoringEngine'; 134671 addPrefix: 'Refactoring-Core-lr'; 134672 addPrefix: 'Refactoring-Spelling-lr'; 134673 yourself! ! 134674 134675!Gofer class methodsFor: 'examples' stamp: 'lr 10/2/2009 10:19'! 134676seaside28 134677 "Create a Gofer instance of Seaside 2.8." 134678 134679 ^ self new 134680 squeaksource: 'Seaside'; 134681 addPrefix: 'Seaside2.8a1-lr'; 134682 addPrefix: 'Scriptaculous-lr'; 134683 addPrefix: 'Comet-lr'; 134684 squeaksource: 'rsrss'; 134685 addPackage: 'RSRSS2'; 134686 yourself! ! 134687 134688!Gofer class methodsFor: 'examples' stamp: 'lr 10/2/2009 10:19'! 134689tools 134690 "Create a Gofer instance of several development tools." 134691 134692 ^ self new 134693 renggli: 'unsorted'; 134694 addPackage: 'Shout'; 134695 addPackage: 'RoelTyper'; 134696 addPackage: 'ECompletion'; 134697 addPackage: 'ECompletionOmniBrowser'; 134698 yourself! ! 134699 134700 134701!Gofer class methodsFor: 'instance creation' stamp: 'lr 8/20/2009 09:54'! 134702new 134703 ^ self basicNew initialize! ! 134704GoferTest subclass: #GoferApiTest 134705 instanceVariableNames: 'gofer' 134706 classVariableNames: '' 134707 poolDictionaries: '' 134708 category: 'Gofer-Test'! 134709 134710!GoferApiTest methodsFor: 'running' stamp: 'lr 10/1/2009 21:59'! 134711setUp 134712 super setUp. 134713 gofer := Gofer new! ! 134714 134715 134716!GoferApiTest methodsFor: 'testing-repositories' stamp: 'lr 10/1/2009 21:59'! 134717testCroquet 134718 gofer croquet: 'Hermes'. 134719 self assert: gofer repository locationWithTrailingSlash = 'http://hedgehog.software.umn.edu:8888/Hermes/'! ! 134720 134721!GoferApiTest methodsFor: 'testing-repositories' stamp: 'dkh 10/16/2009 11:02'! 134722testGemsource 134723 gofer gemsource: 'Seaside29'. 134724 self assert: gofer repository locationWithTrailingSlash = 'http://seaside.gemstone.com/ss/Seaside29/'! ! 134725 134726!GoferApiTest methodsFor: 'testing-repositories' stamp: 'lr 10/1/2009 21:59'! 134727testImpara 134728 gofer impara: 'Tweak'. 134729 self assert: gofer repository locationWithTrailingSlash = 'http://source.impara.de/Tweak/'! ! 134730 134731!GoferApiTest methodsFor: 'testing-repositories' stamp: 'lr 10/1/2009 21:59'! 134732testRenggli 134733 gofer renggli: 'pier'. 134734 self assert: gofer repository locationWithTrailingSlash = 'http://source.lukas-renggli.ch/pier/'! ! 134735 134736!GoferApiTest methodsFor: 'testing-repositories' stamp: 'lr 10/1/2009 21:59'! 134737testSaltypickle 134738 gofer saltypickle: 'GraphViz'. 134739 self assert: gofer repository locationWithTrailingSlash = 'http://squeak.saltypickle.com/GraphViz/'! ! 134740 134741!GoferApiTest methodsFor: 'testing-repositories' stamp: 'lr 10/1/2009 21:59'! 134742testSqueakfoundation 134743 gofer squeakfoundation: '39a'. 134744 self assert: gofer repository locationWithTrailingSlash = 'http://source.squeakfoundation.org/39a/'! ! 134745 134746!GoferApiTest methodsFor: 'testing-repositories' stamp: 'lr 10/1/2009 21:59'! 134747testSqueaksource 134748 gofer squeaksource: 'Seaside29'. 134749 self assert: gofer repository locationWithTrailingSlash = 'http://www.squeaksource.com/Seaside29/'! ! 134750 134751!GoferApiTest methodsFor: 'testing-repositories' stamp: 'lr 10/1/2009 21:59'! 134752testWiresong 134753 gofer wiresong: 'ob'. 134754 self assert: gofer repository locationWithTrailingSlash = 'http://source.wiresong.ca/ob/'! ! 134755 134756 134757!GoferApiTest methodsFor: 'testing' stamp: 'lr 10/1/2009 22:03'! 134758testInitialized 134759 self assert: gofer repository isNil. 134760 self assert: gofer references isEmpty! ! 134761 134762 134763!GoferApiTest methodsFor: 'testing-accessing' stamp: 'lr 10/1/2009 21:59'! 134764testRepository 134765 gofer repository: MCDirectoryRepository new. 134766 self assert: (gofer repository isKindOf: MCDirectoryRepository)! ! 134767 134768!GoferApiTest methodsFor: 'testing-accessing' stamp: 'lr 10/1/2009 21:59'! 134769testUrl 134770 gofer url: 'http://source.lukas-renggli.ch/pier'. 134771 self assert: (gofer repository isKindOf: MCHttpRepository). 134772 self assert: (gofer repository locationWithTrailingSlash = 'http://source.lukas-renggli.ch/pier/'). 134773 self assert: (gofer repository user isEmpty). 134774 self assert: (gofer repository password isEmpty)! ! 134775 134776!GoferApiTest methodsFor: 'testing-accessing' stamp: 'lr 10/1/2009 21:59'! 134777testUrlUsernamePassword 134778 gofer url: 'http://source.lukas-renggli.ch/pier' username: 'foo' password: 'bar'. 134779 self assert: (gofer repository isKindOf: MCHttpRepository). 134780 self assert: (gofer repository locationWithTrailingSlash = 'http://source.lukas-renggli.ch/pier/'). 134781 self assert: (gofer repository user = 'foo'). 134782 self assert: (gofer repository password = 'bar')! ! 134783GoferWorking subclass: #GoferChangeLog 134784 instanceVariableNames: 'latestVersions' 134785 classVariableNames: '' 134786 poolDictionaries: '' 134787 category: 'Gofer-Core'! 134788 134789!GoferChangeLog methodsFor: 'private' stamp: 'obi 10/3/2009 23:35'! 134790addReference: aReference requiredCopy: aWorkingCopy repositories: anArray 134791 super addReference: aReference requiredCopy: aWorkingCopy repositories: anArray. 134792 latestVersions at: aWorkingCopy put: aReference versionReference version info. 134793! ! 134794 134795!GoferChangeLog methodsFor: 'private' stamp: 'obi 10/3/2009 21:06'! 134796allVersionsFrom: currentVersion to: latestVersion 134797 "return nil if the current version is not part of my ancestors" 134798 | result | 134799 result := OrderedCollection new. 134800 result add: latestVersion. 134801 latestVersion breadthFirstAncestors do: [:version | version = currentVersion ifTrue: [^result] ifFalse: [result add: version] ]. 134802 ^nil! ! 134803 134804!GoferChangeLog methodsFor: 'private' stamp: 'obi 10/3/2009 20:30'! 134805cr 134806 self defaultLogger cr! ! 134807 134808!GoferChangeLog methodsFor: 'private' stamp: 'obi 10/3/2009 20:29'! 134809defaultLogger 134810 ^Transcript! ! 134811 134812!GoferChangeLog methodsFor: 'private' stamp: 'obi 10/3/2009 20:29'! 134813log: aString 134814 self defaultLogger show: aString! ! 134815 134816!GoferChangeLog methodsFor: 'private' stamp: 'obi 10/3/2009 20:31'! 134817logCR: aString 134818 self defaultLogger show: aString; cr! ! 134819 134820!GoferChangeLog methodsFor: 'private' stamp: 'obi 10/3/2009 20:48'! 134821logIndent: aString 134822 | stream | 134823 stream := aString readStream. 134824 [ stream atEnd ] whileFalse: [ 134825 self log: ' '. 134826 self log: stream nextLine. 134827 stream atEnd ifFalse: [ self cr ] ]. 134828 self cr! ! 134829 134830 134831!GoferChangeLog methodsFor: 'running' stamp: 'obi 10/3/2009 21:11'! 134832execute 134833 | currentVersion versions | 134834 latestVersions keysAndValuesDo: [:wc :targetVersion | 134835 currentVersion := wc ancestors first. 134836 currentVersion = targetVersion 134837 ifFalse: [ 134838 self cr; logCR: 'Change log for: ', currentVersion name. 134839 self logCR: '--------------------------------------------------------------------------------------------------'. 134840 versions := self allVersionsFrom: currentVersion to: targetVersion. 134841 versions isNil 134842 ifTrue: [self logCR: '*** Warning: The current version is not included in the ancestry path of the latest version ***'] 134843 ifFalse: [ 134844 versions 134845 do: [:each | 134846 self 134847 log: each name; 134848 logCR: (' [', each timeString, ']'); 134849 logIndent: each message] ]. 134850 self logCR: '--------------------------------------------------------------------------------------------------' ] ]! ! 134851 134852 134853!GoferChangeLog methodsFor: 'initialization' stamp: 'obi 10/3/2009 20:03'! 134854initialize 134855 super initialize. 134856 latestVersions := Dictionary new! ! 134857GoferWorking subclass: #GoferCleanup 134858 instanceVariableNames: '' 134859 classVariableNames: '' 134860 poolDictionaries: '' 134861 category: 'Gofer-Core'! 134862 134863!GoferCleanup methodsFor: 'cleaning' stamp: 'lr 10/3/2009 11:37'! 134864cleanup: aWorkingCopy 134865 self cleanupCategories: aWorkingCopy. 134866 self cleanupProtocols: aWorkingCopy! ! 134867 134868!GoferCleanup methodsFor: 'cleaning' stamp: 'dkh 10/12/2009 12:59'! 134869cleanupCategories: aWorkingCopy 134870 aWorkingCopy packageInfo systemCategories do: [ :category | 134871 (SystemOrganization goferClassesInCategory: category) isEmpty 134872 ifTrue: [ SystemOrganization removeSystemCategory: category ] ]! ! 134873 134874!GoferCleanup methodsFor: 'cleaning' stamp: 'lr 10/3/2009 11:37'! 134875cleanupProtocols: aWorkingCopy 134876 aWorkingCopy packageInfo extensionClasses do: [ :class | 134877 (aWorkingCopy packageInfo extensionCategoriesForClass: class) do: [ :category | 134878 (class organization listAtCategoryNamed: category) isEmpty 134879 ifTrue: [ class organization removeCategory: category ] ] ]. 134880 aWorkingCopy packageInfo classesAndMetaClasses do: [ :class | 134881 (aWorkingCopy packageInfo coreCategoriesForClass: class) do: [ :category | 134882 (class organization listAtCategoryNamed: category) isEmpty 134883 ifTrue: [ class organization removeCategory: category ] ] ]! ! 134884 134885 134886!GoferCleanup methodsFor: 'running' stamp: 'lr 10/3/2009 11:30'! 134887execute 134888 self workingCopies 134889 do: [ :each | self cleanup: each ]! ! 134890GoferWorking subclass: #GoferCommit 134891 instanceVariableNames: 'repositories message' 134892 classVariableNames: '' 134893 poolDictionaries: '' 134894 category: 'Gofer-Core'! 134895 134896!GoferCommit methodsFor: 'private' stamp: 'lr 10/2/2009 10:05'! 134897addReference: aPackage requiredCopy: aWorkingCopy repositories: anArray 134898 super addReference: aPackage requiredCopy: aWorkingCopy repositories: anArray. 134899 repositories at: aWorkingCopy put: anArray! ! 134900 134901 134902!GoferCommit methodsFor: 'running' stamp: 'lr 9/24/2009 17:32'! 134903execute 134904 self workingCopies do: [ :workingCopy | 134905 workingCopy needsSaving 134906 ifTrue: [ self execute: workingCopy ] ]! ! 134907 134908!GoferCommit methodsFor: 'running' stamp: 'lr 10/13/2009 00:29'! 134909execute: aWorkingCopy 134910 | targets version | 134911 targets := repositories at: aWorkingCopy. 134912 targets isEmpty 134913 ifTrue: [ self error: 'No repository found for ' , aWorkingCopy packageName printString ]. 134914 version := [ aWorkingCopy newVersion ] 134915 on: MCVersionNameAndMessageRequest 134916 do: [ :notifcation | 134917 self message isNil 134918 ifTrue: [ message := notifcation outer last ]. 134919 notifcation resume: (Array with: notifcation suggestedName with: self message) ]. 134920 targets first 134921 storeVersion: version! ! 134922 134923 134924!GoferCommit methodsFor: 'initialization' stamp: 'lr 8/20/2009 12:14'! 134925initialize 134926 super initialize. 134927 repositories := Dictionary new! ! 134928 134929 134930!GoferCommit methodsFor: 'accessing' stamp: 'lr 10/2/2009 10:12'! 134931message 134932 ^ message! ! 134933 134934!GoferCommit methodsFor: 'accessing' stamp: 'lr 10/2/2009 10:12'! 134935message: aString 134936 message := aString! ! 134937GoferPackageReference subclass: #GoferConstraintReference 134938 instanceVariableNames: 'constraintBlock' 134939 classVariableNames: '' 134940 poolDictionaries: '' 134941 category: 'Gofer-Core'! 134942 134943!GoferConstraintReference methodsFor: 'accessing' stamp: 'lr 10/17/2009 14:25'! 134944constraintBlock: aOneArgumentBlock 134945 constraintBlock := aOneArgumentBlock! ! 134946 134947 134948!GoferConstraintReference methodsFor: 'initialization' stamp: 'lr 10/17/2009 14:25'! 134949initialize 134950 super initialize. 134951 self constraintBlock: [ :author | true ]! ! 134952 134953 134954!GoferConstraintReference methodsFor: 'private' stamp: 'lr 10/17/2009 14:25'! 134955matchesVersionReference: aVersionReference 134956 ^ (super matchesVersionReference: aVersionReference) and: [ constraintBlock value: aVersionReference ]! ! 134957GoferWorking subclass: #GoferDiff 134958 instanceVariableNames: '' 134959 classVariableNames: '' 134960 poolDictionaries: '' 134961 category: 'Gofer-Core'! 134962 134963!GoferDiff methodsFor: 'private' stamp: 'lr 10/2/2009 10:25'! 134964addReference: aReference requiredCopy: aWorkingCopy repositories: anArray 134965 | source target patch | 134966 super addReference: aReference requiredCopy: aWorkingCopy repositories: anArray. 134967 source := aWorkingCopy package. 134968 target := aReference versionReference version. 134969 patch := source snapshot patchRelativeToBase: target snapshot. 134970 aWorkingCopy modified: patch isEmpty not. 134971 self model operations addAll: patch operations! ! 134972 134973!GoferDiff methodsFor: 'private' stamp: 'lr 8/19/2009 14:02'! 134974defaultModel 134975 ^ MCPatch operations: OrderedCollection new! ! 134976 134977 134978!GoferDiff methodsFor: 'running' stamp: 'lr 8/19/2009 14:06'! 134979execute 134980 self model isEmpty 134981 ifFalse: [ self model browse ]! ! 134982GoferOperation subclass: #GoferLoad 134983 instanceVariableNames: 'versions repositories' 134984 classVariableNames: '' 134985 poolDictionaries: '' 134986 category: 'Gofer-Core'! 134987 134988!GoferLoad methodsFor: 'private' stamp: 'lr 10/2/2009 09:57'! 134989addReference: aReference 134990 | version | 134991 version := aReference versionReference version. 134992 version withAllDependenciesDo: [ :dependency | 134993 versions addLast: dependency. 134994 (repositories at: dependency ifAbsentPut: [ Set new ]) 134995 addAll: aReference repositories ]. 134996 model addVersion: version! ! 134997 134998!GoferLoad methodsFor: 'private' stamp: 'lr 9/3/2009 11:00'! 134999defaultModel 135000 ^ MCVersionLoader new! ! 135001 135002!GoferLoad methodsFor: 'private' stamp: 'lr 9/20/2009 13:43'! 135003updateCategories 135004 "This method makes sure that the categories are ordered in load-order and as specified in the packages." 135005 135006 | categories | 135007 categories := OrderedCollection new. 135008 versions do: [ :version | 135009 version snapshot definitions do: [ :definition | 135010 definition isOrganizationDefinition ifTrue: [ 135011 definition categories do: [ :category | 135012 (categories includes: category) 135013 ifFalse: [ categories addLast: category ] ] ] ] ]. 135014 (MCOrganizationDefinition categories: categories) 135015 postloadOver: nil! ! 135016 135017!GoferLoad methodsFor: 'private' stamp: 'lr 10/3/2009 12:02'! 135018updateRepositories 135019 "This code makes sure that all packages have a repository assigned, including the dependencies." 135020 135021 repositories keysAndValuesDo: [ :version :collection | 135022 collection do: [ :repository | 135023 version workingCopy repositoryGroup 135024 addRepository: repository ] ]! ! 135025 135026 135027!GoferLoad methodsFor: 'running' stamp: 'dkh 10/12/2009 12:56'! 135028execute 135029 self model goferHasVersions 135030 ifTrue: [ self model load ]. 135031 self updateRepositories. 135032 self updateCategories! ! 135033 135034 135035!GoferLoad methodsFor: 'initialization' stamp: 'lr 9/3/2009 11:00'! 135036initialize 135037 super initialize. 135038 versions := OrderedCollection new. 135039 repositories := Dictionary new! ! 135040 135041!GoferLoad methodsFor: 'initialization' stamp: 'lr 10/2/2009 10:14'! 135042initializeOn: aGofer 135043 super initializeOn: aGofer. 135044 aGofer references 135045 do: [ :each | self addReference: each ]! ! 135046GoferUpdate subclass: #GoferMerge 135047 instanceVariableNames: '' 135048 classVariableNames: '' 135049 poolDictionaries: '' 135050 category: 'Gofer-Core'! 135051 135052!GoferMerge methodsFor: 'private' stamp: 'lr 8/19/2009 14:01'! 135053defaultModel 135054 ^ MCVersionMerger new! ! 135055 135056 135057!GoferMerge methodsFor: 'running' stamp: 'lr 10/3/2009 11:39'! 135058execute 135059 [ [ self model merge ] 135060 on: MCMergeResolutionRequest 135061 do: [ :request | 135062 request merger conflicts isEmpty 135063 ifTrue: [ request resume: true ] 135064 ifFalse: [ request pass ] ] ] 135065 valueSupplyingAnswers: #(('No Changes' true)). 135066 self gofer cleanup! ! 135067Object subclass: #GoferOperation 135068 instanceVariableNames: 'gofer model' 135069 classVariableNames: '' 135070 poolDictionaries: '' 135071 category: 'Gofer-Core'! 135072 135073!GoferOperation methodsFor: 'private' stamp: 'lr 8/19/2009 14:01'! 135074defaultModel 135075 ^ nil! ! 135076 135077 135078!GoferOperation methodsFor: 'running' stamp: 'lr 8/17/2009 14:40'! 135079execute 135080 "Execute the receiving action." 135081 135082 self subclassResponsibility! ! 135083 135084 135085!GoferOperation methodsFor: 'accessing' stamp: 'lr 10/3/2009 11:38'! 135086gofer 135087 "Answer the Gofer instance that triggered this operation." 135088 135089 ^ gofer! ! 135090 135091!GoferOperation methodsFor: 'accessing' stamp: 'lr 8/20/2009 10:13'! 135092model 135093 "Answer the Monticello model of this operation." 135094 135095 ^ model! ! 135096 135097 135098!GoferOperation methodsFor: 'initialization' stamp: 'lr 8/19/2009 14:01'! 135099initialize 135100 model := self defaultModel! ! 135101 135102!GoferOperation methodsFor: 'initialization' stamp: 'lr 10/3/2009 11:28'! 135103initializeOn: aGofer 135104 gofer := aGofer copy. 135105 self initialize! ! 135106 135107"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 135108 135109GoferOperation class 135110 instanceVariableNames: ''! 135111 135112!GoferOperation class methodsFor: 'instance creation' stamp: 'lr 9/3/2009 10:28'! 135113new 135114 self shouldNotImplement! ! 135115 135116!GoferOperation class methodsFor: 'instance creation' stamp: 'lr 8/20/2009 12:01'! 135117on: aGofer 135118 ^ self basicNew initializeOn: aGofer! ! 135119GoferReference subclass: #GoferPackageReference 135120 instanceVariableNames: 'packageName' 135121 classVariableNames: '' 135122 poolDictionaries: '' 135123 category: 'Gofer-Core'! 135124!GoferPackageReference commentStamp: 'lr 10/17/2009 14:17' prior: 0! 135125A GoferPackageReference refers to the latest version of a Monticello package within a specified group of repositories.! 135126 135127 135128!GoferPackageReference methodsFor: 'private' stamp: 'lr 10/13/2009 00:00'! 135129matchesVersionReference: aVersionReference 135130 ^ self packageName = aVersionReference packageName! ! 135131 135132 135133!GoferPackageReference methodsFor: 'accessing' stamp: 'lr 10/12/2009 23:41'! 135134packageName 135135 ^ packageName! ! 135136 135137!GoferPackageReference methodsFor: 'accessing' stamp: 'lr 10/13/2009 00:00'! 135138versionReference 135139 | versions | 135140 versions := self 135141 findVersions: [ :each | self matchesVersionReference: each ]. 135142 versions isEmpty 135143 ifTrue: [ self error: 'No versions for package ' , self packageName printString , ' found.' ]. 135144 ^ versions last! ! 135145 135146 135147!GoferPackageReference methodsFor: 'initialization' stamp: 'lr 10/12/2009 23:41'! 135148setName: aString 135149 packageName := aString! ! 135150GoferWorking subclass: #GoferRecompile 135151 instanceVariableNames: '' 135152 classVariableNames: '' 135153 poolDictionaries: '' 135154 category: 'Gofer-Core'! 135155 135156!GoferRecompile methodsFor: 'running' stamp: 'lr 8/20/2009 11:44'! 135157execute 135158 self workingCopies 135159 do: [ :copy | self recompile: copy ]! ! 135160 135161!GoferRecompile methodsFor: 'running' stamp: 'lr 8/20/2009 11:47'! 135162recompile: aWorkingCopy 135163 aWorkingCopy packageInfo methods 135164 do: [ :each | each actualClass recompile: each methodSymbol ]! ! 135165Object subclass: #GoferReference 135166 instanceVariableNames: 'repository' 135167 classVariableNames: '' 135168 poolDictionaries: '' 135169 category: 'Gofer-Core'! 135170 135171!GoferReference methodsFor: 'utilities' stamp: 'lr 10/12/2009 23:40'! 135172findVersions: aBlock 135173 "Answer a sorted array of version references that match aBlock." 135174 135175 | versions | 135176 versions := SortedCollection new. 135177 self repositories do: [ :repo | 135178 (GoferVersionCache versionsIn: repo) do: [ :version | 135179 (aBlock value: version) 135180 ifTrue: [ versions add: version ] ] ]. 135181 ^ versions asArray! ! 135182 135183 135184!GoferReference methodsFor: 'private' stamp: 'lr 10/12/2009 23:44'! 135185matchesWorkingCopy: aWorkingCopy 135186 ^ self packageName = aWorkingCopy packageName! ! 135187 135188 135189!GoferReference methodsFor: 'accessing' stamp: 'lr 10/12/2009 23:42'! 135190packageName 135191 "Answer the package name." 135192 135193 self subclassResponsibility! ! 135194 135195!GoferReference methodsFor: 'accessing' stamp: 'lr 10/2/2009 10:56'! 135196repositories 135197 "Answer an ordered collection of repositories." 135198 135199 | repositories | 135200 repositories := OrderedCollection new. 135201 self repository isNil 135202 ifTrue: [ 135203 self workingCopy isNil 135204 ifFalse: [ repositories addAll: self workingCopy repositoryGroup repositories ] ] 135205 ifFalse: [ 135206 self repository isRepositoryGroup 135207 ifFalse: [ repositories add: self repository ] 135208 ifTrue: [ repositories addAll: self repository repositories ] ]. 135209 repositories := repositories select: [ :each | 135210 each isValid and: [ each ~= MCCacheRepository default ] ]. 135211 ^ repositories! ! 135212 135213!GoferReference methodsFor: 'accessing' stamp: 'lr 10/12/2009 23:39'! 135214repository 135215 "Answer the configured repository." 135216 135217 ^ repository! ! 135218 135219!GoferReference methodsFor: 'accessing' stamp: 'lr 10/1/2009 20:05'! 135220versionReference 135221 "Answer a version reference that can be directly operated on." 135222 135223 self subclassResponsibility! ! 135224 135225!GoferReference methodsFor: 'accessing' stamp: 'lr 10/12/2009 23:44'! 135226workingCopy 135227 "Answer a working copy, or nil if the package is not loaded." 135228 135229 ^ MCWorkingCopy allManagers 135230 detect: [ :each | self matchesWorkingCopy: each ] 135231 ifNone: [ nil ]! ! 135232 135233 135234!GoferReference methodsFor: 'initialization' stamp: 'lr 10/12/2009 23:36'! 135235setName: aString 135236 self subclassResponsibility! ! 135237 135238!GoferReference methodsFor: 'initialization' stamp: 'lr 10/1/2009 19:39'! 135239setRepository: aRepository 135240 repository := aRepository! ! 135241 135242"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 135243 135244GoferReference class 135245 instanceVariableNames: ''! 135246 135247!GoferReference class methodsFor: 'instance-creation' stamp: 'lr 10/12/2009 23:37'! 135248name: aString 135249 ^ self new setName: aString! ! 135250 135251!GoferReference class methodsFor: 'instance-creation' stamp: 'lr 10/2/2009 09:41'! 135252name: aString repository: aRepository 135253 ^ (self name: aString) setRepository: aRepository! ! 135254GoferTest subclass: #GoferReferenceTest 135255 instanceVariableNames: '' 135256 classVariableNames: '' 135257 poolDictionaries: '' 135258 category: 'Gofer-Test'! 135259 135260!GoferReferenceTest methodsFor: 'testing' stamp: 'lr 10/2/2009 09:43'! 135261testPackageShouldFindLatestVersion 135262 | packageReference versionReference | 135263 packageReference := GoferPackageReference name: 'Gofer' repository: self goferRepository. 135264 versionReference := packageReference versionReference. 135265 self assert: versionReference packageName = 'Gofer'. 135266 self assert: versionReference versionNumber > 55! ! 135267 135268!GoferReferenceTest methodsFor: 'testing' stamp: 'lr 10/2/2009 09:48'! 135269testPackageShouldFindWorkingCopy 135270 | packageReference workingCopy | 135271 packageReference := GoferPackageReference name: 'Gofer'. 135272 workingCopy := packageReference workingCopy. 135273 self assert: workingCopy packageName = 'Gofer'! ! 135274 135275!GoferReferenceTest methodsFor: 'testing' stamp: 'lr 10/17/2009 14:27'! 135276testQueryShouldFindLatestVersion 135277 | queryReference versionReference | 135278 queryReference := GoferConstraintReference name: 'Gofer' repository: self goferRepository. 135279 versionReference := queryReference versionReference. 135280 self assert: versionReference packageName = 'Gofer'. 135281 self assert: versionReference versionNumber > 20. 135282 self assert: versionReference branchName = ''. 135283 135284 queryReference constraintBlock: [ :ref | ref versionNumber < 20 ]. 135285 versionReference := queryReference versionReference. 135286 self assert: versionReference packageName = 'Gofer'. 135287 self assert: versionReference versionNumber = 19. 135288 self assert: versionReference authorName = 'lr'. 135289 self assert: versionReference branchName = ''. 135290 135291 queryReference constraintBlock: [ :ref | ref versionNumber < 20 and: [ ref authorName = 'tg' ] ]. 135292 versionReference := queryReference versionReference. 135293 self assert: versionReference packageName = 'Gofer'. 135294 self assert: versionReference versionNumber = 10. 135295 self assert: versionReference authorName = 'tg'. 135296 self assert: versionReference branchName = '' 135297 135298! ! 135299 135300!GoferReferenceTest methodsFor: 'testing' stamp: 'lr 10/17/2009 14:24'! 135301testQueryShouldFindWorkingCopy 135302 | queryReference workingCopy | 135303 queryReference := GoferConstraintReference name: 'Gofer'. 135304 workingCopy := queryReference workingCopy. 135305 self assert: workingCopy packageName = 'Gofer'! ! 135306 135307!GoferReferenceTest methodsFor: 'testing' stamp: 'lr 10/2/2009 09:51'! 135308testVersionShouldFindLatestVersion 135309 | versionReference otherReference | 135310 versionReference := GoferVersionReference name: 'Gofer-lr.18' repository: self goferRepository. 135311 otherReference := versionReference versionReference. 135312 self assert: versionReference packageName = 'Gofer'. 135313 self assert: versionReference authorName = 'lr'. 135314 self assert: versionReference versionNumber = 18. 135315 self assert: otherReference = versionReference. 135316 self assert: otherReference == versionReference! ! 135317 135318!GoferReferenceTest methodsFor: 'testing' stamp: 'lr 10/2/2009 09:51'! 135319testVersionShouldFindWorkingCopy 135320 | versionReference workingCopy | 135321 versionReference := GoferVersionReference name: 'Gofer-lr.18' repository: self goferRepository. 135322 workingCopy := versionReference workingCopy. 135323 self assert: workingCopy packageName = 'Gofer'! ! 135324 135325!GoferReferenceTest methodsFor: 'testing' stamp: 'dkh 10/16/2009 11:08'! 135326testVersionShouldParseComplexName 135327 | queryReference | 135328 queryReference := GoferVersionReference name: 'Seaside-Core-pmm.2'. 135329 self assert: queryReference packageName = 'Seaside-Core'. 135330 self assert: queryReference authorName = 'pmm'. 135331 self assert: queryReference branchName = ''. 135332 self assert: queryReference versionNumber = 2. 135333 135334 queryReference := GoferVersionReference name: 'Seaside-Core-jf.configcleanup.3'. 135335 self assert: queryReference packageName = 'Seaside-Core'. 135336 self assert: queryReference authorName = 'jf'. 135337 self assert: queryReference branchName = 'configcleanup'. 135338 self assert: queryReference versionNumber = 3. 135339 135340 queryReference := GoferVersionReference name: 'Seaside-Core-lr.configcleanup.extraspeedup.69'. 135341 self assert: queryReference packageName = 'Seaside-Core'. 135342 self assert: queryReference authorName = 'lr'. 135343 self assert: queryReference branchName = 'configcleanup.extraspeedup'. 135344 self assert: queryReference versionNumber = 69. 135345 135346 queryReference := GoferVersionReference name: 'Seaside-Core-lr.configcleanup42.extraspeedup.69'. 135347 self assert: queryReference packageName = 'Seaside-Core'. 135348 self assert: queryReference authorName = 'lr'. 135349 self assert: queryReference branchName = 'configcleanup42.extraspeedup'. 135350 self assert: queryReference versionNumber = 69. 135351! ! 135352 135353 135354!GoferReferenceTest methodsFor: 'testing-accessing' stamp: 'lr 10/17/2009 14:24'! 135355testShouldKnowPackageName 135356 | package | 135357 package := GoferPackageReference name: 'Gofer'. 135358 self assert: package packageName = 'Gofer'. 135359 135360 package := GoferConstraintReference name: 'Gofer'. 135361 self assert: package packageName = 'Gofer'. 135362 135363 package := GoferVersionReference name: 'Gofer-lr.34'. 135364 self assert: package packageName = 'Gofer'! ! 135365 135366!GoferReferenceTest methodsFor: 'testing-accessing' stamp: 'lr 10/17/2009 14:24'! 135367testShouldKnowRepository 135368 | package | 135369 package := GoferPackageReference name: 'Gofer' repository: self goferRepository. 135370 self assert: package repository locationWithTrailingSlash = 'http://source.lukas-renggli.ch/flair/'. 135371 135372 package := GoferConstraintReference name: 'Gofer' repository: self goferRepository. 135373 self assert: package repository locationWithTrailingSlash = 'http://source.lukas-renggli.ch/flair/'. 135374 135375 package := GoferVersionReference name: 'Gofer-lr.34' repository: self goferRepository. 135376 self assert: package repository locationWithTrailingSlash = 'http://source.lukas-renggli.ch/flair/'! ! 135377GoferUpdate subclass: #GoferRevert 135378 instanceVariableNames: '' 135379 classVariableNames: '' 135380 poolDictionaries: '' 135381 category: 'Gofer-Core'! 135382 135383!GoferRevert methodsFor: 'running' stamp: 'lr 9/19/2009 13:15'! 135384execute 135385 self workingCopies 135386 do: [ :each | each modified: false ]. 135387 super execute! ! 135388 135389 135390!GoferRevert methodsFor: 'private' stamp: 'lr 10/2/2009 10:30'! 135391findVersion: aReference workingCopy: aWorkingCopy repositories: anArray 135392 ^ (MCRepositoryGroup withAll: anArray) versionWithInfo: aWorkingCopy ancestors first! ! 135393GoferTest subclass: #GoferScenarioTest 135394 instanceVariableNames: 'gofer' 135395 classVariableNames: '' 135396 poolDictionaries: '' 135397 category: 'Gofer-Test'! 135398 135399!GoferScenarioTest methodsFor: 'assertions' stamp: 'lr 8/20/2009 20:58'! 135400assertClass: aClassSymbol 135401 self assert: (Smalltalk hasClassNamed: aClassSymbol)! ! 135402 135403!GoferScenarioTest methodsFor: 'assertions' stamp: 'lr 8/20/2009 21:04'! 135404assertClass: aClassSymbol selector: aMethodSymbol 135405 self assertClass: aClassSymbol. 135406 self assert: ((Smalltalk at: aClassSymbol) includesSelector: aMethodSymbol)! ! 135407 135408 135409!GoferScenarioTest methodsFor: 'utilities' stamp: 'lr 8/20/2009 21:03'! 135410compile: aClassSelector method: aString 135411 self assertClass: aClassSelector. 135412 (Smalltalk at: aClassSelector) compile: aString.! ! 135413 135414!GoferScenarioTest methodsFor: 'utilities' stamp: 'lr 8/20/2009 21:04'! 135415evaluate: aClassSelector selector: aMethodSelector 135416 self assertClass: aClassSelector selector: aMethodSelector. 135417 ^ (Smalltalk at: aClassSelector) new perform: aMethodSelector! ! 135418 135419!GoferScenarioTest methodsFor: 'utilities' stamp: 'lr 8/20/2009 21:14'! 135420hasPackage: aString 135421 | package | 135422 package := MCWorkingCopy allManagers 135423 detect: [ :each | each packageName = aString ] 135424 ifNone: [ nil ]. 135425 ^ package notNil! ! 135426 135427 135428!GoferScenarioTest methodsFor: 'running' stamp: 'dkh 10/16/2009 10:02'! 135429setUp 135430 gofer := Gofer new. 135431 gofer gemsource: 'bogus'; addPackage: 'BogusInfo'! ! 135432 135433!GoferScenarioTest methodsFor: 'running' stamp: 'lr 8/20/2009 21:12'! 135434tearDown 135435 [ gofer unload ] 135436 on: Error 135437 do: [ :err | "assume it is not there" ]! ! 135438 135439 135440!GoferScenarioTest methodsFor: 'testing' stamp: 'lr 9/28/2009 23:39'! 135441testCommit 135442 "dunno how to test yet"! ! 135443 135444!GoferScenarioTest methodsFor: 'testing' stamp: 'lr 9/28/2009 23:39'! 135445testDiff 135446 "dunno how to test yet"! ! 135447 135448!GoferScenarioTest methodsFor: 'testing' stamp: 'lr 8/20/2009 21:15'! 135449testLoad 135450 self shouldnt: [ gofer load ] raise: Error. 135451 self assert: (self hasPackage: 'Bogus'); assertClass: #BogusA. 135452 self assert: (self hasPackage: 'BogusExt'); assertClass: #BogusA selector: #isFake. 135453 self assert: (self hasPackage: 'BogusInfo'); assertClass: #BogusInfo! ! 135454 135455!GoferScenarioTest methodsFor: 'testing' stamp: 'lr 9/28/2009 23:40'! 135456testMerge 135457 "dunno how to test yet"! ! 135458 135459!GoferScenarioTest methodsFor: 'testing' stamp: 'lr 8/20/2009 21:13'! 135460testRecompile 135461 gofer load. 135462 self shouldnt: [ gofer recompile ] raise: Error! ! 135463 135464!GoferScenarioTest methodsFor: 'testing' stamp: 'lr 8/20/2009 21:09'! 135465testRevert 135466 gofer load. 135467 self assert: (self evaluate: #BogusA selector: #isFake). 135468 self compile: #BogusA method: 'isFake ^ false'. 135469 self deny: (self evaluate: #BogusA selector: #isFake). 135470 self shouldnt: [ gofer revert ] raise: Error. 135471 self assert: (self evaluate: #BogusA selector: #isFake)! ! 135472 135473!GoferScenarioTest methodsFor: 'testing' stamp: 'lr 8/20/2009 21:15'! 135474testUnload 135475 gofer load. 135476 self shouldnt: [ gofer unload ] raise: Error. 135477 self deny: (self hasPackage: 'Bogus'). 135478 self deny: (self hasPackage: 'BogusExt'). 135479 self deny: (self hasPackage: 'BogusInfo')! ! 135480 135481!GoferScenarioTest methodsFor: 'testing' stamp: 'lr 9/19/2009 14:13'! 135482testUpdate 135483 gofer load. 135484 self shouldnt: [ gofer update ] raise: Error. 135485 self assert: (self hasPackage: 'Bogus'). 135486 self assert: (self hasPackage: 'BogusExt'). 135487 self assert: (self hasPackage: 'BogusInfo')! ! 135488TestCase subclass: #GoferTest 135489 instanceVariableNames: '' 135490 classVariableNames: '' 135491 poolDictionaries: '' 135492 category: 'Gofer-Test'! 135493 135494!GoferTest methodsFor: 'accessing' stamp: 'lr 10/1/2009 21:58'! 135495bogusRepository 135496 ^ MCHttpRepository location: 'http://source.wiresong.ca/ob' user: '' password: ''! ! 135497 135498!GoferTest methodsFor: 'accessing' stamp: 'lr 10/1/2009 21:58'! 135499goferRepository 135500 ^ MCHttpRepository location: 'http://source.lukas-renggli.ch/flair' user: '' password: ''! ! 135501 135502 135503!GoferTest methodsFor: 'running' stamp: 'lr 10/1/2009 21:59'! 135504runCase 135505 GoferVersionCache during: [ super runCase ]! ! 135506 135507"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 135508 135509GoferTest class 135510 instanceVariableNames: ''! 135511 135512!GoferTest class methodsFor: 'testing' stamp: 'lr 10/1/2009 22:00'! 135513isAbstract 135514 ^ self name = #GoferTest! ! 135515 135516 135517!GoferTest class methodsFor: 'accessing' stamp: 'lr 10/1/2009 21:53'! 135518packageNamesUnderTest 135519 ^ #('Gofer')! ! 135520GoferWorking subclass: #GoferUnload 135521 instanceVariableNames: '' 135522 classVariableNames: '' 135523 poolDictionaries: '' 135524 category: 'Gofer-Core'! 135525 135526!GoferUnload methodsFor: 'private' stamp: 'dkh 10/12/2009 13:04'! 135527defaultModel 135528 135529 Smalltalk at: #MCMultiPackageLoader ifPresent: [:cl | ^ cl new ]. 135530 ^MCPackageLoader new! ! 135531 135532 135533!GoferUnload methodsFor: 'running' stamp: 'lr 10/3/2009 11:45'! 135534execute 135535 self workingCopies 135536 do: [ :copy | self unload: copy ]. 135537 self model load. 135538 self gofer cleanup. 135539 self workingCopies 135540 do: [ :copy | self unregister: copy ]! ! 135541 135542 135543!GoferUnload methodsFor: 'unloading' stamp: 'lr 10/3/2009 11:46'! 135544unload: aWorkingCopy 135545 self unloadClasses: aWorkingCopy. 135546 self unloadPackage: aWorkingCopy 135547! ! 135548 135549!GoferUnload methodsFor: 'unloading' stamp: 'lr 8/19/2009 13:50'! 135550unloadClasses: aWorkingCopy 135551 aWorkingCopy packageInfo classes do: [ :class | 135552 (class selectors includes: #unload) 135553 ifTrue: [ class unload ] ]! ! 135554 135555!GoferUnload methodsFor: 'unloading' stamp: 'lr 8/19/2009 14:00'! 135556unloadPackage: aWorkingCopy 135557 self model unloadPackage: aWorkingCopy package! ! 135558 135559 135560!GoferUnload methodsFor: 'unregistering' stamp: 'lr 8/19/2009 13:49'! 135561unregister: aWorkingCopy 135562 self unregisterWorkingCopy: aWorkingCopy. 135563 self unregisterRepositories: aWorkingCopy. 135564 self unregisterPackageInfo: aWorkingCopy! ! 135565 135566!GoferUnload methodsFor: 'unregistering' stamp: 'lr 8/19/2009 13:50'! 135567unregisterPackageInfo: aWorkingCopy 135568 PackageOrganizer default 135569 unregisterPackage: aWorkingCopy packageInfo! ! 135570 135571!GoferUnload methodsFor: 'unregistering' stamp: 'lr 8/19/2009 13:50'! 135572unregisterRepositories: aWorkingCopy 135573 aWorkingCopy repositoryGroup repositories allButFirst do: [ :repository | 135574 MCWorkingCopy allManagers do: [ :copy | 135575 (copy repositoryGroup includes: repository) 135576 ifTrue: [ ^ self ] ]. 135577 MCRepositoryGroup default 135578 removeRepository: repository ]! ! 135579 135580!GoferUnload methodsFor: 'unregistering' stamp: 'lr 8/20/2009 11:54'! 135581unregisterWorkingCopy: aWorkingCopy 135582 aWorkingCopy unregister! ! 135583GoferWorking subclass: #GoferUpdate 135584 instanceVariableNames: '' 135585 classVariableNames: '' 135586 poolDictionaries: '' 135587 category: 'Gofer-Core'! 135588 135589!GoferUpdate methodsFor: 'private' stamp: 'lr 10/2/2009 10:30'! 135590addReference: aReference workingCopy: aWorkingCopy repositories: anArray 135591 super addReference: aReference workingCopy: aWorkingCopy repositories: anArray. 135592 self model addVersion: (self findVersion: aReference workingCopy: aWorkingCopy repositories: anArray)! ! 135593 135594!GoferUpdate methodsFor: 'private' stamp: 'lr 9/18/2009 18:13'! 135595defaultModel 135596 ^ MCVersionLoader new! ! 135597 135598!GoferUpdate methodsFor: 'private' stamp: 'lr 10/2/2009 10:27'! 135599findVersion: aReference workingCopy: aWorkingCopy repositories: anArray 135600 ^ aReference versionReference version! ! 135601 135602 135603!GoferUpdate methodsFor: 'running' stamp: 'dkh 10/12/2009 12:55'! 135604execute 135605 self model goferHasVersions 135606 ifTrue: [ self model load ]. 135607 self gofer cleanup! ! 135608Notification subclass: #GoferVersionCache 135609 instanceVariableNames: '' 135610 classVariableNames: '' 135611 poolDictionaries: '' 135612 category: 'Gofer-Core'! 135613 135614!GoferVersionCache methodsFor: 'accessing' stamp: 'lr 9/28/2009 23:38'! 135615defaultAction 135616 ^ Dictionary new! ! 135617 135618"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 135619 135620GoferVersionCache class 135621 instanceVariableNames: ''! 135622 135623!GoferVersionCache class methodsFor: 'private' stamp: 'lr 10/2/2009 09:41'! 135624basicVersionsIn: aRepository 135625 | versions | 135626 versions := OrderedCollection new. 135627 aRepository allVersionNames 135628 do: [ :each | versions addLast: (GoferVersionReference name: each repository: aRepository) ]. 135629 ^ versions! ! 135630 135631 135632!GoferVersionCache class methodsFor: 'public' stamp: 'lr 9/29/2009 21:47'! 135633during: aBlock 135634 | cache | 135635 cache := Dictionary new. 135636 ^ aBlock 135637 on: self 135638 do: [ :notification | notification resume: cache ]! ! 135639 135640!GoferVersionCache class methodsFor: 'public' stamp: 'lr 9/29/2009 21:45'! 135641versionsIn: aRepository 135642 ^ self signal at: aRepository ifAbsentPut: [ self basicVersionsIn: aRepository ]! ! 135643GoferReference subclass: #GoferVersionReference 135644 instanceVariableNames: 'fullName packageName authorName branchName versionNumber' 135645 classVariableNames: '' 135646 poolDictionaries: '' 135647 category: 'Gofer-Core'! 135648!GoferVersionReference commentStamp: 'lr 10/17/2009 14:18' prior: 0! 135649A GoferVersionReference refers to a specific version of a Monticello package.! 135650 135651 135652!GoferVersionReference methodsFor: 'comparing' stamp: 'lr 10/1/2009 21:02'! 135653<= aVersion 135654 ^ self packageName = aVersion packageName 135655 ifFalse: [ self packageName <= aVersion packageName ] 135656 ifTrue: [ self versionNumber <= aVersion versionNumber ]! ! 135657 135658 135659!GoferVersionReference methodsFor: 'accessing' stamp: 'lr 10/1/2009 21:01'! 135660authorName 135661 "Answer the author name of this version." 135662 135663 ^ authorName! ! 135664 135665!GoferVersionReference methodsFor: 'accessing' stamp: 'lr 10/13/2009 00:13'! 135666branchName 135667 "Answer the branch name of this version." 135668 135669 ^ branchName! ! 135670 135671!GoferVersionReference methodsFor: 'accessing' stamp: 'lr 10/12/2009 23:43'! 135672fullName 135673 "Answer the full name of this version." 135674 135675 ^ fullName! ! 135676 135677!GoferVersionReference methodsFor: 'accessing' stamp: 'lr 10/1/2009 21:01'! 135678packageName 135679 "Answer the package name of this version." 135680 135681 ^ packageName! ! 135682 135683!GoferVersionReference methodsFor: 'accessing' stamp: 'lr 10/13/2009 00:22'! 135684version 135685 "Answer the Monticello version of the receiver." 135686 135687 ^ self repository loadVersionFromFileNamed: self fullName , '.mcz'! ! 135688 135689!GoferVersionReference methodsFor: 'accessing' stamp: 'lr 10/1/2009 21:02'! 135690versionNumber 135691 "Answer the version number of this version." 135692 135693 ^ versionNumber! ! 135694 135695!GoferVersionReference methodsFor: 'accessing' stamp: 'lr 10/1/2009 19:56'! 135696versionReference 135697 ^ self! ! 135698 135699 135700!GoferVersionReference methodsFor: 'initialization' stamp: 'dkh 10/16/2009 11:07'! 135701setName: aString 135702 | name | 135703 name := aString last isDigit 135704 ifTrue: [ aString ] 135705 ifFalse: [ (aString copyUpToLast: $.) copyUpTo: $( ]. 135706 fullName := aString. 135707 packageName := name copyUpToLast: $-. 135708 authorName := (name copyAfterLast: $-) copyUpTo: $.. 135709 versionNumber := ((name copyAfterLast: $-) copyAfter: $.). 135710 versionNumber first isDigit 135711 ifTrue: [ 135712 branchName := ''. 135713 versionNumber := versionNumber asInteger ] 135714 ifFalse: [ 135715 branchName := versionNumber copyUpToLast: $.. 135716 versionNumber := (versionNumber copyAfterLast: $.) asInteger ]! ! 135717GoferOperation subclass: #GoferWorking 135718 instanceVariableNames: 'workingCopies' 135719 classVariableNames: '' 135720 poolDictionaries: '' 135721 category: 'Gofer-Core'! 135722 135723!GoferWorking methodsFor: 'private' stamp: 'lr 10/2/2009 10:22'! 135724addReference: aReference 135725 self addReference: aReference workingCopy: aReference workingCopy repositories: aReference repositories! ! 135726 135727!GoferWorking methodsFor: 'private' stamp: 'lr 10/2/2009 10:04'! 135728addReference: aPackage requiredCopy: aWorkingCopy repositories: anArray 135729 (workingCopies includes: aWorkingCopy) 135730 ifTrue: [ ^ self ]. 135731 workingCopies addLast: aWorkingCopy. 135732 aWorkingCopy requiredPackages 135733 reverseDo: [ :each | self addReference: aPackage requiredCopy: each workingCopy repositories: anArray ]! ! 135734 135735!GoferWorking methodsFor: 'private' stamp: 'lr 10/2/2009 10:06'! 135736addReference: aPackage workingCopy: aWorkingCopy repositories: anArray 135737 self addReference: aPackage requiredCopy: aWorkingCopy repositories: anArray! ! 135738 135739 135740!GoferWorking methodsFor: 'initialization' stamp: 'lr 8/19/2009 13:14'! 135741initialize 135742 super initialize. 135743 workingCopies := OrderedCollection new! ! 135744 135745!GoferWorking methodsFor: 'initialization' stamp: 'lr 10/2/2009 10:12'! 135746initializeOn: aGofer 135747 super initializeOn: aGofer. 135748 aGofer references 135749 do: [ :each | self addReference: each ]! ! 135750 135751 135752!GoferWorking methodsFor: 'accessing' stamp: 'lr 9/24/2009 16:55'! 135753workingCopies 135754 "Answer the working copies to be operated on." 135755 135756 ^ workingCopies! ! 135757OrientedFillStyle subclass: #GradientFillStyle 135758 instanceVariableNames: 'colorRamp pixelRamp radial isTranslucent' 135759 classVariableNames: 'PixelRampCache' 135760 poolDictionaries: '' 135761 category: 'Balloon-Fills'! 135762!GradientFillStyle commentStamp: 'efc 8/30/2005 21:44' prior: 0! 135763A gradient fill style is a fill which interpolates smoothly between any number of colors. 135764 135765Instance variables: 135766 colorRamp <Array of: Association> Contains the colors and their relative positions along the fill, which is a number between zero and one. 135767 pixelRamp <Bitmap> A cached version of the colorRamp to avoid needless recomputations. 135768 radial <Boolean> If true, this fill describes a radial gradient. If false, it is a linear gradient. 135769 isTranslucent <Boolean> A (cached) flag determining if there are any translucent colors involved. 135770 135771Class variables: 135772 PixelRampCache <LRUCache> Recently used pixelRamps. They tend to have high temporal locality and this saves space and time.! 135773 135774 135775!GradientFillStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 12:22'! 135776= anGradientFillStyle 135777 "Answer whether equal." 135778 135779 ^super = anGradientFillStyle 135780 and: [self pixelRamp == anGradientFillStyle pixelRamp] "LRU should make identity equal"! ! 135781 135782!GradientFillStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 12:22'! 135783hash 135784 "Hash is implemented because #= is implemented." 135785 135786 ^super hash bitXor: self pixelRamp hash! ! 135787 135788 135789!GradientFillStyle methodsFor: '*morphic-balloon' stamp: 'dgd 10/17/2003 22:37'! 135790addFillStyleMenuItems: aMenu hand: aHand from: aMorph 135791 "Add the items for changing the current fill style of the receiver" 135792 self isRadialFill ifTrue:[ 135793 aMenu add: 'linear gradient' translated target: self selector: #beLinearGradientIn: argument: aMorph. 135794 ] ifFalse:[ 135795 aMenu add: 'radial gradient' translated target: self selector: #beRadialGradientIn: argument: aMorph. 135796 ]. 135797 aMenu addLine. 135798 aMenu add: 'change first color' translated target: self selector: #changeFirstColorIn:event: argument: aMorph. 135799 aMenu add: 'change second color' translated target: self selector: #changeSecondColorIn:event: argument: aMorph. 135800 aMenu addLine. 135801 super addFillStyleMenuItems: aMenu hand: aHand from: aMorph.! ! 135802 135803!GradientFillStyle methodsFor: '*morphic-balloon' stamp: 'ar 6/18/1999 09:49'! 135804addNewColorIn: aMorph event: evt 135805 ^self inform:'not yet implemented'! ! 135806 135807!GradientFillStyle methodsFor: '*morphic-balloon' stamp: 'ar 6/18/1999 07:25'! 135808beLinearGradientIn: aMorph 135809 self radial: false. 135810 aMorph changed.! ! 135811 135812!GradientFillStyle methodsFor: '*morphic-balloon' stamp: 'ar 6/18/1999 07:25'! 135813beRadialGradientIn: aMorph 135814 self radial: true. 135815 aMorph changed.! ! 135816 135817!GradientFillStyle methodsFor: '*morphic-balloon' stamp: 'sw 9/8/2000 18:13'! 135818changeColorSelector: aSymbol hand: aHand morph: aMorph originalColor: originalColor 135819 "Change either the firstColor or the lastColor (depending on aSymbol). Put up a color picker to hande it. We always use a modal picker so that the user can adjust both colors concurrently." 135820 135821 ColorPickerMorph new 135822 initializeModal: false; 135823 sourceHand: aHand; 135824 target: self; 135825 selector: aSymbol; 135826 argument: aMorph; 135827 originalColor: originalColor; 135828 putUpFor: aMorph near: aMorph fullBoundsInWorld! ! 135829 135830!GradientFillStyle methodsFor: '*morphic-balloon' stamp: 'di 9/3/1999 11:34'! 135831changeFirstColorIn: aMorph event: evt 135832 ^self changeColorSelector: #firstColor:forMorph:hand: hand: evt hand morph: aMorph originalColor: colorRamp first value! ! 135833 135834!GradientFillStyle methodsFor: '*morphic-balloon' stamp: 'di 9/3/1999 11:34'! 135835changeSecondColorIn: aMorph event: evt 135836 ^self changeColorSelector: #lastColor:forMorph:hand: hand: evt hand morph: aMorph originalColor: colorRamp last value! ! 135837 135838!GradientFillStyle methodsFor: '*morphic-balloon' stamp: 'nk 7/18/2003 16:35'! 135839firstColor: aColor forMorph: aMorph hand: aHand 135840 colorRamp first value: aColor. 135841 isTranslucent := nil. 135842 pixelRamp := nil. 135843 aMorph changed.! ! 135844 135845!GradientFillStyle methodsFor: '*morphic-balloon' stamp: 'nk 7/18/2003 16:35'! 135846lastColor: aColor forMorph: aMorph hand: aHand 135847 colorRamp last value: aColor. 135848 isTranslucent := nil. 135849 pixelRamp := nil. 135850 aMorph changed.! ! 135851 135852 135853!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/7/1998 22:10'! 135854colorRamp 135855 ^colorRamp! ! 135856 135857!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 9/2/1999 14:30'! 135858colorRamp: anArray 135859 colorRamp := anArray. 135860 pixelRamp := nil. 135861 isTranslucent := nil.! ! 135862 135863!GradientFillStyle methodsFor: 'accessing' stamp: 'efc 8/30/2005 21:42'! 135864pixelRamp 135865 135866"Compute a pixel ramp, and cache it for future accesses" 135867 135868^pixelRamp ifNil:[ 135869 "Insure the PixelRampCache is in place" 135870 PixelRampCache ifNil:[ self class initPixelRampCache ]. 135871 135872 "Ask my cache for an existing instance if one is available" 135873 pixelRamp := PixelRampCache at: colorRamp 135874].! ! 135875 135876!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/9/1998 14:06'! 135877pixelRamp: aBitmap 135878 pixelRamp := aBitmap! ! 135879 135880!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 8/31/2004 11:06'! 135881radial 135882 ^radial ifNil:[false]! ! 135883 135884!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/7/1998 22:11'! 135885radial: aBoolean 135886 radial := aBoolean! ! 135887 135888 135889!GradientFillStyle methodsFor: 'converting' stamp: 'ar 8/25/2001 21:02'! 135890asColor 135891 "Guess..." 135892 ^colorRamp first value mixed: 0.5 with: colorRamp last value! ! 135893 135894!GradientFillStyle methodsFor: 'converting' stamp: 'ar 6/4/2001 00:42'! 135895mixed: fraction with: aColor 135896 ^self copy colorRamp: (colorRamp collect:[:assoc| assoc key -> (assoc value mixed: fraction with: aColor)])! ! 135897 135898 135899!GradientFillStyle methodsFor: 'testing' stamp: 'ar 11/7/1998 22:12'! 135900isGradientFill 135901 ^true! ! 135902 135903!GradientFillStyle methodsFor: 'testing' stamp: 'ar 11/7/1998 22:13'! 135904isRadialFill 135905 ^radial == true! ! 135906 135907!GradientFillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:29'! 135908isTranslucent 135909 ^isTranslucent ifNil:[isTranslucent := self checkTranslucency]! ! 135910 135911 135912!GradientFillStyle methodsFor: 'private' stamp: 'di 11/21/1999 20:18'! 135913checkTranslucency 135914 ^colorRamp anySatisfy: [:any| any value isTranslucent]! ! 135915 135916!GradientFillStyle methodsFor: 'private' stamp: 'ar 7/16/2000 18:32'! 135917computePixelRampOfSize: length 135918 "Compute the pixel ramp in the receiver" 135919 | bits lastColor lastIndex nextIndex nextColor distance theta lastValue ramp lastWord nextWord step | 135920 ramp := colorRamp asSortedCollection:[:a1 :a2| a1 key < a2 key]. 135921 bits := Bitmap new: length. 135922 lastColor := ramp first value. 135923 lastWord := lastColor pixelWordForDepth: 32. 135924 lastIndex := 0. 135925 ramp do:[:assoc| 135926 nextIndex := (assoc key * length) rounded. 135927 nextColor := assoc value. 135928 nextWord := nextColor pixelWordForDepth: 32. 135929 distance := (nextIndex - lastIndex). 135930 distance = 0 ifTrue:[distance := 1]. 135931 step := 1.0 / distance asFloat. 135932 theta := 0.0. 135933 lastIndex+1 to: nextIndex do:[:i| 135934 theta := theta + step. 135935 "The following is an open-coded version of: 135936 color := nextColor alphaMixed: theta with: lastColor. 135937 bits at: i put: (color scaledPixelValue32). 135938 " 135939 bits at: i put: (self scaledAlphaMix: theta of: lastWord with: nextWord). 135940 ]. 135941 lastIndex := nextIndex. 135942 lastColor := nextColor. 135943 lastWord := nextWord. 135944 ]. 135945 lastValue := lastColor scaledPixelValue32. 135946 lastIndex+1 to: length do:[:i| bits at: i put: lastValue]. 135947 ^bits! ! 135948 135949!GradientFillStyle methodsFor: 'private' stamp: 'ar 11/9/1998 16:56'! 135950display 135951 | f ramp | 135952 ramp := self pixelRamp. 135953 f := Form extent: ramp size @ 1 depth: 32 bits: ramp. 135954 1 to: 100 do:[:i| f displayAt: 1@i]. 135955 [Sensor anyButtonPressed] whileFalse. 135956 [Sensor anyButtonPressed] whileTrue.! ! 135957 135958!GradientFillStyle methodsFor: 'private' stamp: 'ar 7/11/2000 16:47'! 135959scaledAlphaMix: theta of: lastWord with: nextWord 135960 "Open-coded version of alpha mixing two 32bit pixel words and returning the scaled pixel value." 135961 | word0 word1 a0 a1 alpha v0 v1 vv value | 135962 word0 := lastWord. 135963 word1 := nextWord. 135964 "note: extract alpha first so we'll be in SmallInteger range afterwards" 135965 a0 := word0 bitShift: -24. a1 := word1 bitShift: -24. 135966 alpha := a0 + (a1 - a0 * theta) truncated. 135967 "Now make word0 and word1 SmallIntegers" 135968 word0 := word0 bitAnd: 16rFFFFFF. word1 := word1 bitAnd: 16rFFFFFF. 135969 "Compute first component value" 135970 v0 := (word0 bitAnd: 255). v1 := (word1 bitAnd: 255). 135971 vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255. 135972 value := vv. 135973 "Compute second component value" 135974 v0 := ((word0 bitShift: -8) bitAnd: 255). v1 := ((word1 bitShift: -8) bitAnd: 255). 135975 vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255. 135976 value := value bitOr: (vv bitShift: 8). 135977 "Compute third component value" 135978 v0 := ((word0 bitShift: -16) bitAnd: 255). v1 := ((word1 bitShift: -16) bitAnd: 255). 135979 vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255. 135980 value := value bitOr: (vv bitShift: 16). 135981 "Return result" 135982 ^value bitOr: (alpha bitShift: 24)! ! 135983 135984"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 135985 135986GradientFillStyle class 135987 instanceVariableNames: ''! 135988 135989!GradientFillStyle class methodsFor: 'initialization' stamp: 'md 8/31/2005 17:33'! 135990initPixelRampCache 135991 135992"Create an LRUCache to use for accessing pixel ramps." 135993 135994"Details: when a new pixel ramp is needed, a temporary GradientFillStyle is created so that it can be used to create a new pixel ramp" 135995 135996^PixelRampCache := LRUCache size: 32 factory:[:key| 135997 (GradientFillStyle new colorRamp: key) computePixelRampOfSize: 512] ! ! 135998 135999!GradientFillStyle class methodsFor: 'initialization' stamp: 'md 8/31/2005 17:33'! 136000pixelRampCache 136001 136002"Allow access to my cache of pixel ramps. This is mainly for debugging and profiling purposes." 136003 136004^PixelRampCache ! ! 136005 136006 136007!GradientFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 23:09'! 136008colors: colorArray 136009 "Create a gradient fill style from an array of equally spaced colors" 136010 ^self ramp: (colorArray withIndexCollect: 136011 [:color :index| (index-1 asFloat / (colorArray size - 1 max: 1)) -> color]).! ! 136012 136013!GradientFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/9/1998 14:05'! 136014ramp: colorRamp 136015 ^self new colorRamp: colorRamp! ! 136016 136017!GradientFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/10/1998 19:13'! 136018sample 136019 "GradientFill sample" 136020 ^(self ramp: { 0.0 -> Color red. 0.5 -> Color green. 1.0 -> Color blue}) 136021 origin: 300 @ 300; 136022 direction: 400@0; 136023 normal: 0@400; 136024 radial: true; 136025 yourself! ! 136026BitBlt subclass: #GrafPort 136027 instanceVariableNames: 'alpha fillPattern lastFont lastFontForegroundColor lastFontBackgroundColor' 136028 classVariableNames: '' 136029 poolDictionaries: '' 136030 category: 'Morphic-Support'! 136031 136032!GrafPort methodsFor: '*FreeType-addition' stamp: 'tween 4/5/2007 08:39'! 136033installFreeTypeFont: aFreeTypeFont foregroundColor: foregroundColor backgroundColor: backgroundColor 136034 136035 super installFreeTypeFont: aFreeTypeFont foregroundColor: foregroundColor backgroundColor: backgroundColor. 136036 lastFont := aFreeTypeFont. 136037 lastFontForegroundColor := foregroundColor. 136038 lastFontBackgroundColor := backgroundColor. 136039! ! 136040 136041!GrafPort methodsFor: '*FreeType-addition' stamp: 'tween 4/5/2007 08:03'! 136042lastFontForegroundColor 136043 ^lastFontForegroundColor! ! 136044 136045 136046!GrafPort methodsFor: '*FreeType-override' stamp: 'tween 6/8/2008 12:29'! 136047installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor 136048 super installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor. 136049 aStrikeFont glyphs depth = 1 ifTrue: [ 136050 alpha := foregroundColor privateAlpha. 136051 "dynamically switch between blend modes to support translucent text" 136052 "To handle the transition from TTCFont to StrikeFont, rule 34 must be taken into account." 136053 alpha = 255 ifTrue:[ 136054 combinationRule = 30 ifTrue: [combinationRule := Form over]. 136055 combinationRule = 31 ifTrue: [combinationRule := Form paint]. 136056 combinationRule = 34 ifTrue: [combinationRule := Form paint]. 136057 combinationRule = 41 ifTrue: [combinationRule := Form paint]. "41 is SPRmode" 136058 ] ifFalse:[ 136059 combinationRule = Form over ifTrue: [combinationRule := 30]. 136060 combinationRule = Form paint ifTrue: [combinationRule := 31]. 136061 combinationRule = 34 ifTrue: [combinationRule := 31]. 136062 combinationRule = 41 ifTrue: [combinationRule := 31]. "41 is SPR mode" 136063 ] 136064 ]. 136065 lastFont := aStrikeFont. 136066 lastFontForegroundColor := foregroundColor. 136067 lastFontBackgroundColor := backgroundColor. 136068! ! 136069 136070 136071!GrafPort methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:07'! 136072alphaBits: a 136073 alpha := a! ! 136074 136075!GrafPort methodsFor: 'accessing' stamp: 'ar 5/28/2000 14:41'! 136076contentsOfArea: aRectangle into: aForm 136077 destForm 136078 displayOn: aForm 136079 at: aRectangle origin 136080 clippingBox: (0@0 extent: aRectangle extent). 136081 ^aForm! ! 136082 136083!GrafPort methodsFor: 'accessing' stamp: 'gvc 5/31/2007 16:06'! 136084displayScannerFor: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode 136085 "Fixed to answer a MultiDisplayScanner when the paragraph is any kind of 136086 MultiNewParagraph (rather than an instance of the one class) or the paragraph 136087 text string is a WideString." 136088 136089 ((para isKindOf: MultiNewParagraph) or: [para text string isByteString 136090 or: [para text string isWideString]]) ifTrue: [ 136091 ^ (MultiDisplayScanner new text: para text textStyle: para textStyle 136092 foreground: foreColor background: backColor fillBlt: self 136093 ignoreColorChanges: shadowMode) 136094 setPort: self clone 136095 ]. 136096 ^ (DisplayScanner new text: para text textStyle: para textStyle 136097 foreground: foreColor background: backColor fillBlt: self 136098 ignoreColorChanges: shadowMode) 136099 setPort: self clone 136100! ! 136101 136102!GrafPort methodsFor: 'accessing' stamp: 'ar 4/10/2005 18:56'! 136103displayScannerForMulti: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode 136104 136105 ((para isMemberOf: MultiNewParagraph) or: [para text string isByteString]) ifTrue: [ 136106 ^ (MultiDisplayScanner new text: para presentationText textStyle: para textStyle 136107 foreground: foreColor background: backColor fillBlt: self 136108 ignoreColorChanges: shadowMode) 136109 setPort: self clone 136110 ]. 136111 ^ (DisplayScanner new text: para text textStyle: para textStyle 136112 foreground: foreColor background: backColor fillBlt: self 136113 ignoreColorChanges: shadowMode) 136114 setPort: self clone 136115! ! 136116 136117!GrafPort methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:09'! 136118fillPattern: anObject 136119 fillPattern := anObject. 136120 self fillColor: anObject.! ! 136121 136122 136123!GrafPort methodsFor: 'copying' stamp: 'ar 12/30/2001 20:32'! 136124clippedBy: aRectangle 136125 ^ self copy clipBy: aRectangle! ! 136126 136127!GrafPort methodsFor: 'copying' stamp: 'dgd 2/21/2003 22:38'! 136128copyBits 136129 "Override copybits to do translucency if desired" 136130 136131 (combinationRule >= 30 and: [combinationRule <= 31]) 136132 ifTrue: 136133 [alpha isNil 136134 ifTrue: [self copyBitsTranslucent: 255] 136135 ifFalse: [self copyBitsTranslucent: alpha]] 136136 ifFalse: [super copyBits]! ! 136137 136138 136139!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/16/2000 22:32'! 136140fillOval: rect 136141 | centerX centerY nextY yBias xBias outer nextOuterX | 136142 rect area <= 0 ifTrue: [^ self]. 136143 height := 1. 136144 yBias := rect height odd ifTrue: [0] ifFalse: [-1]. 136145 xBias := rect width odd ifTrue: [1] ifFalse: [0]. 136146 centerX := rect center x. 136147 centerY := rect center y. 136148 outer := EllipseMidpointTracer new on: rect. 136149 nextY := rect height // 2. 136150 [nextY > 0] whileTrue:[ 136151 nextOuterX := outer stepInY. 136152 width := (nextOuterX bitShift: 1) + xBias. 136153 destX := centerX - nextOuterX. 136154 destY := centerY - nextY. 136155 self copyBits. 136156 destY := centerY + nextY + yBias. 136157 self copyBits. 136158 nextY := nextY - 1. 136159 ]. 136160 destY := centerY. 136161 height := 1 + yBias. 136162 width := rect width. 136163 destX := rect left. 136164 self copyBits. 136165! ! 136166 136167!GrafPort methodsFor: 'drawing support' stamp: 'ar 5/17/2000 21:20'! 136168fillRect: rect offset: aPoint 136169 "The offset is really just for stupid InfiniteForms." 136170 | fc | 136171 fillPattern class == InfiniteForm ifTrue:[ 136172 fc := halftoneForm. 136173 self fillColor: nil. 136174 fillPattern displayOnPort: ((self clippedBy: rect) colorMap: nil) at: aPoint. 136175 halftoneForm := fc. 136176 ^self]. 136177 136178 destX := rect left. 136179 destY := rect top. 136180 sourceX := 0. 136181 sourceY := 0. 136182 width := rect width. 136183 height := rect height. 136184 self copyBits.! ! 136185 136186!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/16/2000 22:26'! 136187frameOval: rect borderWidth: borderWidth 136188 | centerX centerY nextY yBias xBias wp outer inner nextOuterX nextInnerX fillAlpha | 136189 rect area <= 0 ifTrue: [^ self]. 136190 height := 1. 136191 wp := borderWidth asPoint. 136192 yBias := rect height odd ifTrue: [0] ifFalse: [-1]. 136193 xBias := rect width odd ifTrue: [1] ifFalse: [0]. 136194 centerX := rect center x. 136195 centerY := rect center y. 136196 outer := EllipseMidpointTracer new on: rect. 136197 inner := EllipseMidpointTracer new on: (rect insetBy: wp). 136198 nextY := rect height // 2. 136199 1 to: (wp y min: nextY) do:[:i| 136200 nextOuterX := outer stepInY. 136201 width := (nextOuterX bitShift: 1) + xBias. 136202 destX := centerX - nextOuterX. 136203 destY := centerY - nextY. 136204 self copyBits. 136205 destY := centerY + nextY + yBias. 136206 self copyBits. 136207 nextY := nextY - 1. 136208 ]. 136209 [nextY > 0] whileTrue:[ 136210 nextOuterX := outer stepInY. 136211 nextInnerX := inner stepInY. 136212 destX := centerX - nextOuterX. 136213 destY := centerY - nextY. 136214 width := nextOuterX - nextInnerX. 136215 self copyBits. 136216 destX := centerX + nextInnerX + xBias. 136217 self copyBits. 136218 destX := centerX - nextOuterX. 136219 destY := centerY + nextY + yBias. 136220 self copyBits. 136221 destX := centerX + nextInnerX + xBias. 136222 self copyBits. 136223 nextY := nextY - 1. 136224 ]. 136225 destY := centerY. 136226 height := 1 + yBias. 136227 width := wp x. 136228 destX := rect left. 136229 self copyBits. 136230 destX := rect right - wp x. 136231 self copyBits. 136232! ! 136233 136234!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 14:44'! 136235frameRect: rect borderWidth: borderWidth 136236 sourceX := 0. 136237 sourceY := 0. 136238 (rect areasOutside: (rect insetBy: borderWidth)) do: 136239 [:edgeStrip | self destRect: edgeStrip; copyBits]. 136240! ! 136241 136242!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'! 136243frameRectBottom: rect height: h 136244 136245 destX := rect left + 1. 136246 destY := rect bottom - 1. 136247 width := rect width - 2. 136248 height := 1. 136249 1 to: h do: [:i | 136250 self copyBits. 136251 destX := destX + 1. 136252 destY := destY - 1. 136253 width := width - 2]. 136254! ! 136255 136256!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'! 136257frameRectRight: rect width: w 136258 136259 width := 1. 136260 height := rect height - 1. 136261 destX := rect right - 1. 136262 destY := rect top + 1. 136263 1 to: w do: [:i | 136264 self copyBits. 136265 destX := destX - 1. 136266 destY := destY + 1. 136267 height := height - 2]. 136268! ! 136269 136270!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'! 136271image: aForm at: aPoint sourceRect: sourceRect rule: rule 136272 "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." 136273 136274 sourceForm := aForm. 136275 combinationRule := rule. 136276 self sourceRect: sourceRect. 136277 self destOrigin: aPoint. 136278 self copyBits! ! 136279 136280!GrafPort methodsFor: 'drawing support' stamp: 'ar 8/8/2001 14:26'! 136281image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha 136282 "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." 136283 136284 sourceForm := aForm. 136285 combinationRule := rule. 136286 self sourceRect: sourceRect. 136287 self destOrigin: aPoint. 136288 self copyBitsTranslucent: (alpha := (sourceAlpha * 255) truncated min: 255 max: 0).! ! 136289 136290!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 00:31'! 136291stencil: stencilForm at: aPoint sourceRect: aRect 136292 "Paint using aColor wherever stencilForm has non-zero pixels" 136293 self sourceForm: stencilForm; 136294 destOrigin: aPoint; 136295 sourceRect: aRect. 136296 self copyBits! ! 136297 136298 136299!GrafPort methodsFor: 'private' stamp: 'yo 1/8/2005 09:12'! 136300installStrikeFont: aStrikeFont 136301 136302 ^ self installStrikeFont: aStrikeFont foregroundColor: (lastFontForegroundColor ifNil: [Color black]) backgroundColor: (lastFontBackgroundColor ifNil: [Color transparent]). 136303! ! 136304 136305!GrafPort methodsFor: 'private' stamp: 'yo 1/12/2005 16:39'! 136306installTTCFont: aTTCFont 136307 136308 ^ self installTTCFont: aTTCFont foregroundColor: (lastFontForegroundColor ifNil: [Color black]) backgroundColor: (lastFontBackgroundColor ifNil: [Color transparent]). 136309! ! 136310 136311!GrafPort methodsFor: 'private' stamp: 'yo 1/8/2005 09:12'! 136312installTTCFont: aTTCFont foregroundColor: foregroundColor backgroundColor: backgroundColor 136313 136314 super installTTCFont: aTTCFont foregroundColor: foregroundColor backgroundColor: backgroundColor. 136315 lastFont := aTTCFont. 136316 lastFontForegroundColor := foregroundColor. 136317 lastFontBackgroundColor := backgroundColor. 136318! ! 136319 136320!GrafPort methodsFor: 'private' stamp: 'yo 1/8/2005 09:13'! 136321lastFont 136322 136323 ^ lastFont. 136324! ! 136325LanguageEnvironment subclass: #GreekEnvironment 136326 instanceVariableNames: '' 136327 classVariableNames: '' 136328 poolDictionaries: '' 136329 category: 'Multilingual-Languages'! 136330!GreekEnvironment commentStamp: '<historical>' prior: 0! 136331This class provides the support for Greek. It is here, but most of the methods are not implemented yet. 136332! 136333 136334 136335"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 136336 136337GreekEnvironment class 136338 instanceVariableNames: ''! 136339 136340!GreekEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/31/2007 15:22'! 136341defaultEncodingName 136342 | platformName osVersion | 136343 platformName := SmalltalkImage current platformName. 136344 osVersion := SmalltalkImage current getSystemAttribute: 1002. 136345 (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8' copy]. 136346 (#('Win32') includes: platformName) 136347 ifTrue: [^'cp-1253' copy]. 136348 (#('unix') includes: platformName) ifTrue: [^'iso8859-7' copy]. 136349 ^'mac-roman'! ! 136350 136351!GreekEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 00:38'! 136352leadingChar 136353 136354 ^ 13. 136355! ! 136356 136357!GreekEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 18:23'! 136358supportedLanguages 136359 "Return the languages that this class supports. 136360 Any translations for those languages will use this class as their environment." 136361 136362 ^#('el' )! ! 136363 136364!GreekEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/31/2007 15:25'! 136365systemConverterClass 136366 136367 (#('Win32') includes: SmalltalkImage current platformName) 136368 ifTrue: [^CP1253TextConverter ]. 136369 136370 ^ ISO88597TextConverter. 136371! ! 136372MorphicModel subclass: #GroupboxMorph 136373 instanceVariableNames: 'contentMorph labelMorph' 136374 classVariableNames: '' 136375 poolDictionaries: '' 136376 category: 'Polymorph-Widgets'! 136377!GroupboxMorph commentStamp: 'gvc 5/18/2007 12:36' prior: 0! 136378Groupbox with title with a vertical layout. Appears in a lighter colour than the owner's pane colour.! 136379 136380 136381!GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 8/19/2006 16:31'! 136382contentMorph 136383 "Answer the value of contentMorph" 136384 136385 ^ contentMorph! ! 136386 136387!GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 8/19/2006 16:31'! 136388contentMorph: anObject 136389 "Set the value of contentMorph" 136390 136391 contentMorph := anObject! ! 136392 136393!GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:55'! 136394font 136395 "Answer the label font" 136396 136397 ^self labelMorph font! ! 136398 136399!GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:55'! 136400font: aFont 136401 "Set the label font" 136402 136403 self labelMorph font: aFont! ! 136404 136405!GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 8/19/2006 16:31'! 136406labelMorph 136407 "Answer the value of labelMorph" 136408 136409 ^ labelMorph! ! 136410 136411!GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 8/19/2006 16:31'! 136412labelMorph: anObject 136413 "Set the value of labelMorph" 136414 136415 labelMorph := anObject! ! 136416 136417 136418!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/20/2006 11:24'! 136419addContentMorph: aMorph 136420 "Add a morph to the content." 136421 136422 ^self contentMorph addMorphBack: aMorph! ! 136423 136424!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/25/2008 14:55'! 136425adoptPaneColor: paneColor 136426 "Pass on to the content morph." 136427 136428 |c| 136429 paneColor ifNil: [^super adoptPaneColor: paneColor]. 136430 c := self theme subgroupColorFrom: paneColor. 136431 super adoptPaneColor: c. 136432 self contentMorph borderStyle: (self theme groupPanelBorderStyleFor: self). 136433 self labelMorph 136434 color: paneColor blacker muchDarker; 136435 backgroundColor: c; 136436 borderStyle: (self theme groupLabelBorderStyleFor: self)! ! 136437 136438!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 10:05'! 136439containsPoint: aPoint 136440 "Override here to check the label and content instead." 136441 136442 ^(super containsPoint: aPoint) and: [ 136443 (self labelMorph containsPoint: aPoint) or: [ 136444 self contentMorph containsPoint: aPoint]]! ! 136445 136446!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/20/2006 11:47'! 136447cornerStyle: aSymbol 136448 "Pass on to list too." 136449 136450 super cornerStyle: aSymbol. 136451 self labelMorph cornerStyle: aSymbol. 136452 self contentMorph cornerStyle: aSymbol! ! 136453 136454!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/12/2007 10:49'! 136455initialColorInSystemWindow: aSystemWindow 136456 "Answer the colour the receiver should be when added to a SystemWindow." 136457 136458 ^Color transparent! ! 136459 136460!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/25/2008 14:46'! 136461initialize 136462 "Initialize the receiver." 136463 136464 super initialize. 136465 self 136466 roundedCorners: #(2 3 4); 136467 borderWidth: 0; 136468 changeTableLayout; 136469 cellPositioning: #topLeft; 136470 cellInset: 0@-1; 136471 reverseTableCells: true; 136472 labelMorph: self newLabelMorph; 136473 contentMorph: self newContentMorph; 136474 addMorphBack: self contentMorph; 136475 addMorphBack: self labelMorph! ! 136476 136477!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/20/2006 11:26'! 136478label 136479 "Answer the contents of the label morph." 136480 136481 ^self labelMorph contents! ! 136482 136483!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/25/2008 14:31'! 136484label: aString 136485 "Set the contents of the label morph." 136486 136487 aString ifNil: [ 136488 self roundedCorners: #(1 2 3 4). 136489 self labelMorph delete. ^self]. 136490 self roundedCorners: #(2 3 4). 136491 self labelMorph owner ifNil: [ 136492 self addMorph: self labelMorph]. 136493 self labelMorph contents: aString! ! 136494 136495!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 15:34'! 136496minExtent 136497 "Answer the minmum extent of the receiver. 136498 Based on label and rounding." 136499 136500 ^super minExtent max: self labelMorph minExtent + (8@0)! ! 136501 136502!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/25/2008 14:33'! 136503newContentMorph 136504 "Answer a new content morph" 136505 136506 |p| 136507 p := PanelMorph new 136508 roundedCorners: self roundedCorners; 136509 changeTableLayout; 136510 layoutInset: (4@4 corner: 4@4); 136511 cellInset: 8; 136512 vResizing: #spaceFill; 136513 hResizing: #spaceFill. 136514 p borderStyle: (self theme groupPanelBorderStyleFor: p). 136515 ^p! ! 136516 136517!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/27/2009 17:49'! 136518newLabelMorph 136519 "Answer a new label morph" 136520 136521 ^TextMorph new 136522 roundedCorners: #(1 4); 136523 margins: (2@1 corner: 2@-1); 136524 contents: 'groupbox'; 136525 vResizing: #shrinkWrap; 136526 hResizing: #shrinkWrap; 136527 lock! ! 136528 136529!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2008 13:36'! 136530paneColorOrNil 136531 "Answer the window's pane color or nil otherwise." 136532 136533 ^super paneColorOrNil ifNotNilDo: [:c | self theme subgroupColorFrom: c]! ! 136534 136535!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2009 18:16'! 136536roundedCorners: anArray 136537 "Set the corners to round." 136538 136539 super roundedCorners: anArray. 136540 self contentMorph ifNotNilDo: [:cm | cm roundedCorners: self roundedCorners]! ! 136541 136542!GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/25/2008 14:39'! 136543selectedTab 136544 "Answer the label morph for compatibility with TabPanelBorder." 136545 136546 ^self labelMorph owner 136547 ifNotNil: [self labelMorph]! ! 136548BracketSliderMorph subclass: #HColorSelectorMorph 136549 instanceVariableNames: '' 136550 classVariableNames: '' 136551 poolDictionaries: '' 136552 category: 'Polymorph-Widgets'! 136553!HColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:58' prior: 0! 136554ColorComponentSelector showing a hue rainbow palette.! 136555 136556 136557!HColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 14:13'! 136558color: aColor 136559 "Ignore to preserve fill style." 136560 ! ! 136561 136562!HColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/3/2009 13:44'! 136563defaultFillStyle 136564 "Answer the hue gradient." 136565 136566 ^(GradientFillStyle colors: ((0.0 to: 359.9 by: 0.1) collect: [:a | Color h: a s: 1.0 v: 1.0])) 136567 origin: self topLeft; 136568 direction: (self bounds isWide 136569 ifTrue: [self width@0] 136570 ifFalse: [0@self height])! ! 136571Object subclass: #HMAC 136572 instanceVariableNames: 'hash key ipad epad' 136573 classVariableNames: '' 136574 poolDictionaries: '' 136575 category: 'System-Hashing-Core'! 136576!HMAC commentStamp: '<historical>' prior: 0! 136577HMAC is a mechanism for message authentication using cryptographic hash functions. HMAC can be used with any iterative cryptographic hash function, e.g., MD5, SHA-1, in combination with a secret shared key. The cryptographic strength of HMAC depends on the properties of the underlying hash function. 136578 136579See RFC 2114.! 136580 136581 136582!HMAC methodsFor: 'accessing' stamp: 'cmm 12/2/2006 14:57'! 136583destroy 136584 key destroy! ! 136585 136586!HMAC methodsFor: 'accessing' stamp: 'len 10/16/2002 16:43'! 136587digestMessage: aByteArray 136588 ^ hash hashMessage: (key bitXor: epad), (hash hashMessage: (key bitXor: ipad), aByteArray)! ! 136589 136590!HMAC methodsFor: 'accessing' stamp: 'len 8/3/2002 02:06'! 136591digestSize 136592 ^ hash hashSize! ! 136593 136594!HMAC methodsFor: 'accessing' stamp: 'StephaneDucasse 10/17/2009 17:15'! 136595key: aByteArray 136596 key := aByteArray. 136597 key size > hash blockSize ifTrue: [ key := hash hashMessage: key ]. 136598 key size < hash blockSize ifTrue: [ key := key , (ByteArray new: hash blockSize - key size) ]! ! 136599 136600 136601!HMAC methodsFor: 'initialization' stamp: 'StephaneDucasse 10/17/2009 17:15'! 136602setHash: aHash 136603 hash := aHash. 136604 ipad := ByteArray 136605 new: aHash blockSize 136606 withAll: 54. 136607 epad := ByteArray 136608 new: aHash blockSize 136609 withAll: 92! ! 136610 136611 136612!HMAC methodsFor: 'printing' stamp: 'len 8/3/2002 02:08'! 136613printOn: aStream 136614 aStream nextPutAll: 'HMAC-'; print: hash! ! 136615 136616"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 136617 136618HMAC class 136619 instanceVariableNames: ''! 136620 136621!HMAC class methodsFor: 'instance creation' stamp: 'len 8/15/2002 01:42'! 136622on: aHashFunction 136623 ^ self new setHash: aHashFunction! ! 136624Morph subclass: #HSVAColorSelectorMorph 136625 instanceVariableNames: 'hsvMorph aMorph' 136626 classVariableNames: '' 136627 poolDictionaries: '' 136628 category: 'Polymorph-Widgets'! 136629!HSVAColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:55' prior: 0! 136630Colour selector featuring a saturation/volume area, hue selection strip and alpha selection strip.! 136631 136632 136633!HSVAColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/20/2006 14:05'! 136634aMorph 136635 "Answer the value of aMorph" 136636 136637 ^ aMorph! ! 136638 136639!HSVAColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/20/2006 14:05'! 136640aMorph: anObject 136641 "Set the value of aMorph" 136642 136643 aMorph := anObject! ! 136644 136645!HSVAColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/20/2006 14:05'! 136646hsvMorph 136647 "Answer the value of hsvMorph" 136648 136649 ^ hsvMorph! ! 136650 136651!HSVAColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/20/2006 14:05'! 136652hsvMorph: anObject 136653 "Set the value of hsvMorph" 136654 136655 hsvMorph := anObject! ! 136656 136657 136658!HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:58'! 136659alphaSelected: aFloat 136660 "The alpha has changed." 136661 136662 self triggerSelectedColor! ! 136663 136664!HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:58'! 136665colorSelected: aColor 136666 "A color has been selected. Set the base color for the alpha channel." 136667 136668 self aMorph color: aColor. 136669 self triggerSelectedColor! ! 136670 136671!HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 13:44'! 136672defaultColor 136673 "Answer the default color/fill style for the receiver." 136674 136675 ^Color transparent 136676! ! 136677 136678!HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 16:47'! 136679initialize 136680 "Initialize the receiver." 136681 136682 super initialize. 136683 self 136684 extent: 180@168; 136685 changeTableLayout; 136686 cellInset: 4; 136687 aMorph: self newAColorMorph; 136688 hsvMorph: self newHSVColorMorph; 136689 addMorphBack: self hsvMorph; 136690 addMorphBack: self aMorph. 136691 self aMorph color: self hsvMorph selectedColor! ! 136692 136693!HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 10:11'! 136694newAColorMorph 136695 "Answer a new alpha color morph." 136696 136697 ^AColorSelectorMorph new 136698 model: self; 136699 hResizing: #spaceFill; 136700 vResizing: #rigid; 136701 setValueSelector: #alphaSelected:; 136702 extent: 24@24! ! 136703 136704!HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 14:00'! 136705newHSVColorMorph 136706 "Answer a new hue/saturation/volume color morph." 136707 136708 ^HSVColorSelectorMorph new 136709 hResizing: #spaceFill; 136710 vResizing: #spaceFill; 136711 when: #colorSelected send: #colorSelected: to: self! ! 136712 136713!HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 14:18'! 136714selectedColor 136715 "Answer the selected color." 136716 136717 ^self hsvMorph selectedColor alpha: self aMorph value! ! 136718 136719!HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 11:12'! 136720selectedColor: aColor 136721 "Set the hue and sv components." 136722 136723 self aMorph value: aColor alpha. 136724 self hsvMorph selectedColor: aColor asNontranslucentColor! ! 136725 136726!HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:57'! 136727triggerSelectedColor 136728 "Trigger the event for the selected colour" 136729 136730 self triggerEvent: #selectedColor with: self selectedColor! ! 136731Morph subclass: #HSVColorSelectorMorph 136732 instanceVariableNames: 'svMorph hMorph' 136733 classVariableNames: '' 136734 poolDictionaries: '' 136735 category: 'Polymorph-Widgets'! 136736!HSVColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:55' prior: 0! 136737Colour selector featuring a saturation/volume area and a hue selection strip.! 136738 136739 136740!HSVColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/21/2006 13:30'! 136741hMorph 136742 "Answer the value of hMorph" 136743 136744 ^ hMorph! ! 136745 136746!HSVColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/21/2006 13:30'! 136747hMorph: anObject 136748 "Set the value of hMorph" 136749 136750 hMorph := anObject! ! 136751 136752!HSVColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 12:26'! 136753svMorph 136754 "Answer the value of svMorph" 136755 136756 ^ svMorph! ! 136757 136758!HSVColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 12:26'! 136759svMorph: anObject 136760 "Set the value of svMorph" 136761 136762 svMorph := anObject! ! 136763 136764 136765!HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 16:28'! 136766colorSelected: aColor 136767 "A color has been selected. Make the hue match." 136768 136769 "self hMorph value: aColor hue / 360. 136770 self svMorph basicColor: (Color h: aColor hue s: 1.0 v: 1.0)." 136771 self triggerEvent: #colorSelected with: aColor! ! 136772 136773!HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 13:44'! 136774defaultColor 136775 "Answer the default color/fill style for the receiver." 136776 136777 ^Color transparent 136778! ! 136779 136780!HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 16:23'! 136781hue: aFloat 136782 "Set the hue in the range 0.0 - 1.0. Update the SV morph and hMorph." 136783 136784 self hMorph value: aFloat. 136785 self svMorph color: (Color h: aFloat * 359.9 s: 1.0 v: 1.0)! ! 136786 136787!HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2006 12:25'! 136788initialize 136789 "Initialize the receiver." 136790 136791 super initialize. 136792 self 136793 borderWidth: 0; 136794 changeTableLayout; 136795 cellInset: 4; 136796 listDirection: #leftToRight; 136797 cellPositioning: #topLeft; 136798 svMorph: self newSVColorMorph; 136799 hMorph: self newHColorMorph; 136800 addMorphBack: self svMorph; 136801 addMorphBack: self hMorph; 136802 extent: 192@152; 136803 hue: 0.5! ! 136804 136805!HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 12:33'! 136806newHColorMorph 136807 "Answer a new hue color morph." 136808 136809 ^HColorSelectorMorph new 136810 model: self; 136811 setValueSelector: #hue:; 136812 hResizing: #rigid; 136813 vResizing: #spaceFill; 136814 extent: 36@36! ! 136815 136816!HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 12:54'! 136817newSVColorMorph 136818 "Answer a new saturation/volume color morph." 136819 136820 ^SVColorSelectorMorph new 136821 extent: 152@152; 136822 hResizing: #spaceFill; 136823 vResizing: #spaceFill; 136824 when: #colorSelected send: #colorSelected: to: self! ! 136825 136826!HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 13:41'! 136827selectedColor 136828 "Answer the selected color." 136829 136830 ^self svMorph selectedColor! ! 136831 136832!HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 13:38'! 136833selectedColor: aColor 136834 "Set the hue and sv components." 136835 136836 self hue: aColor hue / 360. 136837 self svMorph selectedColor: aColor! ! 136838Object subclass: #HTTPClient 136839 instanceVariableNames: '' 136840 classVariableNames: 'BrowserSupportsAPI RunningInBrowser' 136841 poolDictionaries: '' 136842 category: 'System-Support'! 136843 136844"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 136845 136846HTTPClient class 136847 instanceVariableNames: ''! 136848 136849!HTTPClient class methodsFor: 'examples' stamp: 'adrian_lienhard 7/18/2009 15:56'! 136850exampleMailTo 136851 "HTTPClient exampleMailTo" 136852 136853 HTTPClient mailTo: 'm.rueger@acm.org' message: 'A test message from within Pharo' 136854! ! 136855 136856!HTTPClient class methodsFor: 'examples' stamp: 'md 7/28/2005 10:33'! 136857examplePostArgs 136858 "HTTPClient examplePostArgs" 136859 136860 | args result | 136861 args := Dictionary new. 136862 args 136863 at: 'arg1' put: #('val1'); 136864 at: 'arg2' put: #('val2'); 136865 yourself. 136866 result := HTTPClient httpPostDocument: 'http://www.squeaklet.com/cgi-bin/thrd.pl [^]' args: args. 136867 Transcript show: result content; cr; cr. 136868 136869! ! 136870 136871!HTTPClient class methodsFor: 'examples' stamp: 'mir 2/2/2001 17:44'! 136872examplePostMultipart 136873 "HTTPClient examplePostMultipart" 136874 136875 | args result | 136876 args := Dictionary new. 136877 args 136878 at: 'arg1' put: #('val1'); 136879 at: 'arg2' put: #('val2'); 136880 yourself. 136881 result := HTTPClient httpPostMultipart: 'http://www.squeaklet.com/cgi-bin/thrd.pl' args: args. 136882 Transcript show: result content; cr; cr. 136883 136884! ! 136885 136886 136887!HTTPClient class methodsFor: 'initialization' stamp: 'mir 4/2/2002 15:37'! 136888browserSupportsAPI 136889 ^BrowserSupportsAPI == true! ! 136890 136891!HTTPClient class methodsFor: 'initialization' stamp: 'mir 4/2/2002 15:36'! 136892browserSupportsAPI: aBoolean 136893 BrowserSupportsAPI := aBoolean! ! 136894 136895!HTTPClient class methodsFor: 'initialization' stamp: 'mir 2/2/2001 17:27'! 136896determineIfRunningInBrowser 136897 "HTTPClient determineIfRunningInBrowser" 136898 136899 RunningInBrowser := StandardFileStream isRunningAsBrowserPlugin 136900! ! 136901 136902 136903!HTTPClient class methodsFor: 'post/get' stamp: 'nk 8/30/2004 07:50'! 136904httpGet: url 136905 | document | 136906 document := self httpGetDocument: url. 136907 ^(document isString) 136908 ifTrue: [ 136909 "strings indicate errors" 136910 document] 136911 ifFalse: [(RWBinaryOrTextStream with: document content) reset]! ! 136912 136913!HTTPClient class methodsFor: 'post/get' stamp: 'mir 5/11/2001 12:55'! 136914httpGetDocument: url 136915 | stream content | 136916 ^self shouldUsePluginAPI 136917 ifTrue: [ 136918 stream := FileStream requestURLStream: url ifError: [self error: 'Error in get from ' , url printString]. 136919 stream ifNil: [^'']. 136920 stream position: 0. 136921 content := stream upToEnd. 136922 stream close. 136923 MIMEDocument content: content] 136924 ifFalse: [HTTPSocket httpGetDocument: url]! ! 136925 136926!HTTPClient class methodsFor: 'post/get' stamp: 'mir 5/1/2001 15:04'! 136927httpPostDocument: url args: argsDict 136928 ^self httpPostDocument: url target: nil args: argsDict! ! 136929 136930!HTTPClient class methodsFor: 'post/get' stamp: 'mir 5/1/2001 15:06'! 136931httpPostDocument: url target: target args: argsDict 136932 | argString stream content | 136933 ^self shouldUsePluginAPI 136934 ifTrue: [ 136935 argString := argsDict 136936 ifNotNil: [argString := HTTPSocket argString: argsDict] 136937 ifNil: ['']. 136938 stream := FileStream post: argString , ' ' target: target url: url , argString ifError: [self error: 'Error in post to ' , url printString]. 136939 stream position: 0. 136940 content := stream upToEnd. 136941 stream close. 136942 MIMEDocument content: content] 136943 ifFalse: [HTTPSocket httpPostDocument: url args: argsDict]! ! 136944 136945!HTTPClient class methodsFor: 'post/get' stamp: 'mir 5/1/2001 12:51'! 136946httpPostMultipart: url args: argsDict 136947 " do multipart/form-data encoding rather than x-www-urlencoded " 136948 136949 ^self shouldUsePluginAPI 136950 ifTrue: [self pluginHttpPostMultipart: url args: argsDict] 136951 ifFalse: [HTTPSocket httpPostMultipart: url args: argsDict accept: nil request: '']! ! 136952 136953!HTTPClient class methodsFor: 'post/get' stamp: 'mir 4/2/2002 15:52'! 136954requestURL: url target: target 136955 ^self shouldUsePluginAPI 136956 ifTrue: [FileStream requestURL: url target: target] 136957 ifFalse: [self error: 'Requesting a new URL target is not supported.']! ! 136958 136959 136960!HTTPClient class methodsFor: 'testing' stamp: 'ccn 3/14/2001 19:56'! 136961isRunningInBrowser 136962 136963 RunningInBrowser isNil 136964 ifTrue: [self determineIfRunningInBrowser]. 136965 ^RunningInBrowser! ! 136966 136967!HTTPClient class methodsFor: 'testing' stamp: 'mir 8/4/2003 13:44'! 136968isRunningInBrowser: aBoolean 136969 "Override the automatic process. 136970 This should be used with caution. 136971 One way to determine it without using the primitive is to check for parameters typically only encountered when running as a plugin." 136972 136973 RunningInBrowser := aBoolean! ! 136974 136975!HTTPClient class methodsFor: 'testing' stamp: 'RobRothwell 2/23/2009 22:41'! 136976shouldUsePluginAPI 136977 "HTTPClient shouldUsePluginAPI" 136978 136979 self isRunningInBrowser 136980 ifFalse: [^false]. 136981 self browserSupportsAPI 136982 ifFalse: [^false]. 136983 "The Mac plugin calls do not work in full screen mode" 136984 ^((SmalltalkImage current platformName = 'Mac OS') 136985 and: [Display isFullScreen]) not! ! 136986 136987 136988!HTTPClient class methodsFor: 'utilities' stamp: 'PeterHugossonMiller 9/3/2009 09:59'! 136989composeMailTo: address subject: subject body: body 136990 "HTTPClient composeMailTo: 'michael.rueger@squeakland.org' subject: 'test subject' body: 'message' " 136991 | mailTo | 136992 mailTo := String new writeStream. 136993 mailTo nextPutAll: 'mailto:'. 136994 mailTo 136995 nextPutAll: address; 136996 nextPut: $?. 136997 subject isEmptyOrNil 136998 ifFalse: [mailTo nextPutAll: 'subject='; nextPutAll: subject; nextPut: $&]. 136999 body isEmptyOrNil 137000 ifFalse: [mailTo nextPutAll: 'body='; nextPutAll: body]. 137001 137002 self httpGet: mailTo contents! ! 137003 137004!HTTPClient class methodsFor: 'utilities' stamp: 'mir 5/13/2003 10:43'! 137005getDirectoryListing: dirListURL 137006 "HTTPClient getDirectoryListing: 'http://www.squeakalpha.org/uploads' " 137007 | answer ftpEntries | 137008" answer := self 137009 httpPostDocument: dirListURL 137010 args: Dictionary new." 137011 "Workaround for Mac IE problem" 137012 answer := self httpGetDocument: dirListURL. 137013 answer isString 137014 ifTrue: [^self error: 'Listing failed: ' , answer] 137015 ifFalse: [answer := answer content]. 137016 answer first == $< 137017 ifTrue: [self error: 'Listing failed: ' , answer]. 137018 ftpEntries := answer findTokens: String crlf. 137019 ^ ftpEntries 137020 collect:[:ftpEntry | ServerDirectory parseFTPEntry: ftpEntry] 137021 thenSelect: [:entry | entry notNil]! ! 137022 137023!HTTPClient class methodsFor: 'utilities' stamp: 'mir 5/1/2001 12:51'! 137024mailTo: address message: aString 137025 HTTPClient shouldUsePluginAPI 137026 ifFalse: [^self error: 'You need to run inside a web browser.']. 137027 FileStream post: aString url: 'mailto:' , address ifError: [self error: 'Can not send mail']! ! 137028 137029!HTTPClient class methodsFor: 'utilities' stamp: 'mir 2/2/2001 17:59'! 137030uploadFileNamed: aFilename to: baseUrl user: user passwd: passwd 137031 137032 | fileContents remoteFilename | 137033 remoteFilename := (baseUrl endsWith: '/') 137034 ifTrue: [baseUrl , '/' , aFilename] 137035 ifFalse: [baseUrl , aFilename]. 137036 fileContents := (StandardFileStream readOnlyFileNamed: aFilename) contentsOfEntireFile. 137037 HTTPSocket httpPut: fileContents to: remoteFilename user: user passwd: passwd! ! 137038 137039 137040!HTTPClient class methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 09:59'! 137041pluginHttpPostMultipart: url args: argsDict 137042 | mimeBorder argsStream crLf fieldValue resultStream result | 137043 " do multipart/form-data encoding rather than x-www-urlencoded " 137044 137045 crLf := String crlf. 137046 mimeBorder := '----pharo-', Time millisecondClockValue printString, '-stuff-----'. 137047 "encode the arguments dictionary" 137048 argsStream := String new writeStream. 137049 argsDict associationsDo: [:assoc | 137050 assoc value do: [ :value | 137051 "print the boundary" 137052 argsStream nextPutAll: '--', mimeBorder, crLf. 137053 " check if it's a non-text field " 137054 argsStream nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"'. 137055 (value isKindOf: MIMEDocument) 137056 ifFalse: [fieldValue := value] 137057 ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', crLf, 'Content-Type: ', value contentType. 137058 fieldValue := (value content 137059 ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile] 137060 ifNotNil: [value content]) asString]. 137061" Transcript show: 'field=', key, '; value=', fieldValue; cr. " 137062 argsStream nextPutAll: crLf, crLf, fieldValue, crLf. 137063 ]]. 137064 argsStream nextPutAll: '--', mimeBorder, '--'. 137065 resultStream := FileStream 137066 post: 137067 ('ACCEPT: text/html', crLf, 137068 'User-Agent: Pharo', crLf, 137069 'Content-type: multipart/form-data; boundary=', mimeBorder, crLf, 137070 'Content-length: ', argsStream contents size printString, crLf, crLf, 137071 argsStream contents) 137072 url: url ifError: [^'Error in post ' url asString]. 137073 "get the header of the reply" 137074 result := resultStream 137075 ifNil: [''] 137076 ifNotNil: [resultStream upToEnd]. 137077 ^MIMEDocument content: result! ! 137078Object subclass: #HTTPDownloadRequest 137079 instanceVariableNames: 'semaphore url content loader process' 137080 classVariableNames: '' 137081 poolDictionaries: '' 137082 category: 'System-Download'! 137083 137084!HTTPDownloadRequest methodsFor: 'accessing' stamp: 'mir 10/4/1999 18:26'! 137085content: retrievedContent 137086 content := retrievedContent. 137087 semaphore signal! ! 137088 137089!HTTPDownloadRequest methodsFor: 'accessing' stamp: 'ar 5/30/2001 21:03'! 137090contentStream 137091 "Return a stream on the content of a previously completed HTTP request" 137092 semaphore wait. 137093 ^content ifNotNil:[content contentStream]! ! 137094 137095!HTTPDownloadRequest methodsFor: 'accessing' stamp: 'mir 10/4/1999 18:25'! 137096contents 137097 semaphore wait. 137098 ^content! ! 137099 137100!HTTPDownloadRequest methodsFor: 'accessing' stamp: 'mir 10/7/1999 16:57'! 137101process: aProcess 137102 process := aProcess! ! 137103 137104!HTTPDownloadRequest methodsFor: 'accessing' stamp: 'mir 1/15/2000 22:55'! 137105signalAbort 137106 loader removeProcess: process. 137107 self content: 'Retrieval aborted'. 137108 process ifNotNil: [process terminate]! ! 137109 137110!HTTPDownloadRequest methodsFor: 'accessing' stamp: 'mir 1/10/2000 18:33'! 137111startRetrieval 137112 self content: url asUrl retrieveContents! ! 137113 137114!HTTPDownloadRequest methodsFor: 'accessing' stamp: 'mir 1/20/2000 13:33'! 137115url 137116 ^url! ! 137117 137118 137119!HTTPDownloadRequest methodsFor: 'initialize' stamp: 'KR 9/4/2005 10:33'! 137120for: aUrl in: aLoader 137121 url := aUrl. 137122 loader := aLoader. 137123 semaphore := Semaphore new.! ! 137124 137125 137126!HTTPDownloadRequest methodsFor: 'testing' stamp: 'ar 3/2/2001 16:53'! 137127isSemaphoreSignaled 137128 "Return true if the associated semaphore is currently signaled. This information can be used to determine whether the download has finished given that there is no other process waiting on the semaphore." 137129 ^semaphore isSignaled! ! 137130 137131 137132!HTTPDownloadRequest methodsFor: 'private' stamp: 'yo 7/29/2005 16:04'! 137133httpEncodeSafely: aUrl 137134 "Encode the url but skip $/ and $:." 137135 137136 | unescaped | 137137 unescaped := aUrl unescapePercents. 137138 137139 ^ unescaped encodeForHTTPWithTextEncoding: 'utf-8' 137140 conditionBlock: [:c | c isSafeForHTTP or: [c = $/ or: [c = $:]]]. 137141! ! 137142 137143"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 137144 137145HTTPDownloadRequest class 137146 instanceVariableNames: ''! 137147 137148!HTTPDownloadRequest class methodsFor: 'instance creation' stamp: 'mir 10/7/1999 16:59'! 137149for: aUrl in: aLoader 137150 ^self new for: aUrl in: aLoader! ! 137151Object subclass: #HTTPLoader 137152 instanceVariableNames: 'requests downloads' 137153 classVariableNames: 'DefaultLoader MaxNrOfConnections' 137154 poolDictionaries: '' 137155 category: 'System-Download'! 137156 137157!HTTPLoader methodsFor: 'initialize/release' stamp: 'alain.plantec 5/28/2009 09:56'! 137158initialize 137159 super initialize. 137160 requests := SharedQueue new. 137161 downloads := OrderedCollection new! ! 137162 137163!HTTPLoader methodsFor: 'initialize/release' stamp: 'mir 10/7/1999 16:59'! 137164release 137165 self abort. 137166 downloads := nil. 137167 requests := nil! ! 137168 137169 137170!HTTPLoader methodsFor: 'requests' stamp: 'mir 1/15/2000 22:59'! 137171abort 137172 | oldRequests | 137173 "Abort all requests" 137174 oldRequests := requests. 137175 requests := SharedQueue new. 137176 [oldRequests isEmpty] whileFalse: [ 137177 oldRequests next signalAbort]. 137178 downloads do: [:each | each ifNotNil: [each terminate]]. 137179 downloads := OrderedCollection new 137180! ! 137181 137182!HTTPLoader methodsFor: 'requests' stamp: 'mir 4/16/2001 17:48'! 137183retrieveContentsFor: url 137184 | request | 137185 request := self class httpRequestClass for: url in: self. 137186 self addRequest: request. 137187 ^request contents! ! 137188 137189!HTTPLoader methodsFor: 'requests' stamp: 'nk 8/30/2004 07:50'! 137190retrieveObjectsFor: aURL 137191 "Load a remote image segment and extract the root objects. 137192 Check if the remote file is a zip archive." 137193 "'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.extSeg' 137194 asUrl loadRemoteObjects" 137195 "'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.zip' 137196 asUrl loadRemoteObjects" 137197 137198 | stream info data | 137199 data := self retrieveContentsFor: aURL. 137200 (data isString) 137201 ifTrue: [^self error: data] 137202 ifFalse: [data := data content]. 137203 (data beginsWith: 'error') 137204 ifTrue: [^self error: data]. 137205 data := data unzipped. 137206 stream := RWBinaryOrTextStream on: data. 137207 stream reset. 137208 info := stream fileInObjectAndCode. 137209 stream close. 137210 ^info originalRoots! ! 137211 137212 137213!HTTPLoader methodsFor: 'private' stamp: 'mir 1/16/2000 16:11'! 137214addRequest: aHTTPRequest 137215 requests nextPut: aHTTPRequest. 137216 self startDownload! ! 137217 137218!HTTPLoader methodsFor: 'private' stamp: 'mir 10/4/1999 18:31'! 137219maxNrOfConnections 137220 ^MaxNrOfConnections! ! 137221 137222!HTTPLoader methodsFor: 'private' stamp: 'mir 10/7/1999 18:16'! 137223nextRequest 137224 ^requests next! ! 137225 137226!HTTPLoader methodsFor: 'private' stamp: 'md 11/14/2003 16:38'! 137227removeProcess: downloadProcess 137228 downloads remove: downloadProcess ifAbsent: []! ! 137229 137230!HTTPLoader methodsFor: 'private' stamp: 'mir 10/7/1999 17:02'! 137231removeRequest: request 137232 requests remove: request! ! 137233 137234!HTTPLoader methodsFor: 'private' stamp: 'mir 5/12/2003 18:10'! 137235startDownload 137236 | newDownloadProcess | 137237 137238 downloads size >= self maxNrOfConnections ifTrue: [^self]. 137239 requests size <= 0 ifTrue: [^self]. 137240 137241 newDownloadProcess := [ 137242 [ 137243 self nextRequest startRetrieval 137244 ] on: FTPConnectionException do: [ :ex | 137245 Cursor normal show. 137246 self removeProcess: Processor activeProcess. 137247 self startDownload 137248 ]. 137249 self removeProcess: Processor activeProcess. 137250 self startDownload 137251 ] newProcess. 137252 downloads add: newDownloadProcess. 137253 newDownloadProcess resume! ! 137254 137255"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 137256 137257HTTPLoader class 137258 instanceVariableNames: ''! 137259 137260!HTTPLoader class methodsFor: 'accessing' stamp: 'mir 10/4/1999 18:41'! 137261default 137262 DefaultLoader ifNil: [ 137263 DefaultLoader := HTTPLoader new]. 137264 ^DefaultLoader! ! 137265 137266!HTTPLoader class methodsFor: 'accessing' stamp: 'avi 4/30/2004 01:40'! 137267httpRequestClass 137268 ^HTTPClient shouldUsePluginAPI 137269 ifTrue: [PluginHTTPDownloadRequest] 137270 ifFalse: [HTTPDownloadRequest]! ! 137271 137272 137273!HTTPLoader class methodsFor: 'initialization' stamp: 'mir 3/8/2001 16:31'! 137274initialize 137275 "HTTPLoader initialize" 137276 137277 MaxNrOfConnections := 4. 137278 DefaultLoader ifNotNil: [ 137279 DefaultLoader release. 137280 DefaultLoader := nil]! ! 137281ProjectSwikiServer subclass: #HTTPServerDirectory 137282 instanceVariableNames: '' 137283 classVariableNames: '' 137284 poolDictionaries: '' 137285 category: 'Network-RemoteDirectory'! 137286 137287!HTTPServerDirectory methodsFor: 'accessing' stamp: 'tak 3/16/2005 17:25'! 137288dirListUrl 137289 | listURL | 137290 listURL := self altUrl 137291 ifNil: [^ nil]. 137292 ^ listURL last ~= $/ 137293 ifTrue: [listURL , '/'] 137294 ifFalse: [listURL]! ! 137295 137296!HTTPServerDirectory methodsFor: 'accessing' stamp: 'mir 4/16/2001 18:02'! 137297directoryNamed: localFileName 137298 | newDir | 137299 newDir := super directoryNamed: localFileName. 137300 newDir altUrl: (self altUrl , '/' , localFileName). 137301 ^newDir! ! 137302 137303!HTTPServerDirectory methodsFor: 'accessing' stamp: 'mir 6/25/2001 17:17'! 137304typeForPrefs 137305 137306 ^'http'! ! 137307 137308 137309!HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/20/2001 18:44'! 137310directoryNames 137311 | dirNames projectNames entries | 137312 "Return a collection of names for the subdirectories of this directory but filter out project directories." 137313 137314 entries := self entries. 137315 dirNames := (entries select: [:entry | entry at: 4]) 137316 collect: [:entry | entry first]. 137317 projectNames := Set new. 137318 entries do: [:entry | 137319 ((entry at: 4) not 137320 and: ['*.pr' match: entry first]) 137321 ifTrue: [projectNames add: (entry first copyFrom: 1 to: entry first size-3)]]. 137322 ^dirNames reject: [:each | projectNames includes: each] 137323! ! 137324 137325!HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/20/2001 18:43'! 137326entries 137327 ^HTTPClient getDirectoryListing: self dirListUrl! ! 137328 137329!HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/20/2001 18:26'! 137330fileNames 137331 "Return a collection of names for the files (but not directories) in this directory." 137332 "(ServerDirectory serverNamed: 'UIUCArchive') fileNames" 137333 137334 self dirListUrl 137335 ifNil: [^self error: 'No URL set for fetching the directory listing.' ]. 137336 ^(self entries select: [:entry | (entry at: 4) not]) 137337 collect: [:entry | entry first] 137338! ! 137339 137340!HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/16/2001 17:54'! 137341oldFileNamed: aName 137342 137343 | contents | 137344 contents := HTTPLoader default retrieveContentsFor: (self altUrl , '/' , aName). 137345 ^(SwikiPseudoFileStream with: contents content) 137346 reset; 137347 directory: self; 137348 localName: aName; 137349 yourself 137350! ! 137351 137352!HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 6/5/2001 16:40'! 137353pathName 137354 "Path name as used in reading the file. with slashes for ftp, with local file delimiter (:) for a file: url" 137355 137356 urlObject ifNotNil: [^ urlObject pathForFile]. 137357 directory size = 0 ifTrue: [^ server]. 137358 ^(directory at: 1) = self pathNameDelimiter 137359 ifTrue: [server, directory] 137360 ifFalse: [user 137361 ifNil: [server, self pathNameDelimiter asString, directory] 137362 ifNotNil: [user, '@', server, self pathNameDelimiter asString, directory]]! ! 137363 137364!HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 5/30/2001 19:55'! 137365readOnlyFileNamed: aName 137366 137367 ^self oldFileNamed: aName! ! 137368Socket subclass: #HTTPSocket 137369 instanceVariableNames: 'headerTokens headers responseCode' 137370 classVariableNames: 'HTTPBlabEmail HTTPPort HTTPProxyCredentials HTTPProxyExceptions ParamDelimiters' 137371 poolDictionaries: '' 137372 category: 'Network-Protocols'! 137373!HTTPSocket commentStamp: '<historical>' prior: 0! 137374HTTPSockets support HTTP requests, either directly or via an HTTP proxy server. An HTTPSocket saves the parse of the last ASCII header it saw, to avoid having to parse it repeatedly. 137375 137376The real action is in httpGet:accept:. See the examples in the class, especially httpFileInNewChangeSet: and httpShowGif:.! 137377 137378 137379!HTTPSocket methodsFor: 'accessing' stamp: 'adrian-lienhard 6/5/2009 22:05'! 137380contentType 137381 | type i | 137382 type := self getHeader: 'content-type' default: nil. 137383 type ifNil: [ ^nil ]. 137384 type := type withBlanksTrimmed. 137385 i := type indexOf: $;. 137386 i = 0 ifTrue: [ ^type ]. 137387 ^(type copyFrom: 1 to: i-1) withBlanksTrimmed ! ! 137388 137389!HTTPSocket methodsFor: 'accessing' stamp: 'dc 10/21/2008 08:49'! 137390contentType: header 137391 "extract the content type from the header. Content-type: text/plain<cr><lf>, User may look in headerTokens afterwards." 137392 137393 | this | 137394 headerTokens ifNil: [ headerTokens := header findTokens: ParamDelimiters keep: String cr]. 137395 1 to: headerTokens size do: [:ii | 137396 this := headerTokens at: ii. 137397 (this first asLowercase = $c and: [#('content-type:' 'content type') includes: this asLowercase]) ifTrue: [ 137398 ^ (headerTokens at: ii+1)]]. 137399 ^ nil "not found"! ! 137400 137401!HTTPSocket methodsFor: 'accessing' stamp: 'dc 10/21/2008 08:49'! 137402contentsLength: header 137403 "extract the data length from the header. Content-length: 1234<cr><lf>, User may look in headerTokens afterwards." 137404 137405 | this | 137406 headerTokens := header findTokens: ParamDelimiters keep: String cr. 137407 1 to: headerTokens size do: [:ii | 137408 this := headerTokens at: ii. 137409 (this first asLowercase = $c and: [this asLowercase = 'content-length:']) ifTrue: [ 137410 ^ (headerTokens at: ii+1) asNumber]]. 137411 ^ nil "not found"! ! 137412 137413!HTTPSocket methodsFor: 'accessing' stamp: 'adrian-lienhard 6/5/2009 22:00'! 137414getHeader: name 137415 ^self getHeader: name default: nil! ! 137416 137417!HTTPSocket methodsFor: 'accessing' stamp: 'adrian-lienhard 6/5/2009 22:01'! 137418getHeader: name default: defaultValue 137419 ^headers at: name ifAbsent: [defaultValue]! ! 137420 137421!HTTPSocket methodsFor: 'accessing' stamp: 'dc 10/21/2008 08:50'! 137422header: headerText 137423 "set the headers. Then getHeader: can be used" 137424 137425 "divide into basic lines" 137426 | lines foldedLines i statusLine | 137427 lines := headerText findTokens: String crlf. 137428 statusLine := lines first. 137429 lines := lines copyFrom: 2 to: lines size. 137430 137431 "parse the status (pretty trivial right now)" 137432 responseCode := (statusLine findTokens: ' ') second. 137433 137434 "fold lines that start with spaces into the previous line" 137435 foldedLines := OrderedCollection new. 137436 lines do: [ :line | 137437 line first isSeparator ifTrue: [ 137438 foldedLines at: foldedLines size put: (foldedLines last, line) ] 137439 ifFalse: [ foldedLines add: line ] ]. 137440 137441 "make a dictionary mapping headers to header contents" 137442 headers := Dictionary new. 137443 foldedLines do: [ :line | 137444 i := line indexOf: $:. 137445 i > 0 ifTrue: [ 137446 headers 137447 at: (line copyFrom: 1 to: i-1) asLowercase 137448 put: (line copyFrom: i+1 to: line size) withBlanksTrimmed ] ]. 137449! ! 137450 137451!HTTPSocket methodsFor: 'accessing' stamp: 'ls 8/12/1998 00:41'! 137452responseCode 137453 ^responseCode! ! 137454 137455 137456!HTTPSocket methodsFor: 'receiving' stamp: 'nice 4/29/2009 21:21'! 137457getResponseUpTo: markerString 137458 "Keep reading until the marker is seen. Return three parts: header, marker, beginningOfData. Fails if no marker in first 2000 chars." 137459 137460 | buf response bytesRead tester mm tries | 137461 buf := String new: 2000. 137462 response := WriteStream on: buf. 137463 tester := 1. mm := 1. 137464 tries := 3. 137465 [tester := tester - markerString size + 1 max: 1. "rewind a little, in case the marker crosses a read boundary" 137466 tester to: response position do: [:tt | 137467 (buf at: tt) = (markerString at: mm) ifTrue: [mm := mm + 1] ifFalse: [mm := 1]. 137468 "Not totally correct for markers like xx0xx" 137469 mm > markerString size ifTrue: ["got it" 137470 ^ Array with: (buf copyFrom: 1 to: tt+1-mm) 137471 with: markerString 137472 with: (buf copyFrom: tt+1 to: response position)]]. 137473 tester := 1 max: response position. "OK if mm in the middle" 137474 (response position < buf size) & (self isConnected | self dataAvailable) 137475 & ((tries := tries - 1) >= 0)] whileTrue: [ 137476 self waitForDataFor: 5 ifClosed: [ 137477 Transcript show: ' <connection closed> '] 137478 ifTimedOut: [ 137479 Transcript show: ' <response was late> ']. 137480 bytesRead := self primSocket: socketHandle receiveDataInto: buf 137481 startingAt: response position + 1 count: buf size - response position. 137482 "response position+1 to: response position+bytesRead do: [:ii | 137483 response nextPut: (buf at: ii)]. totally redundant, but needed to advance position!!" 137484 response instVarAt: 2 "position" put: 137485 (response position + bytesRead)]. "horrible, but fast" 137486 137487 ^ Array with: response contents 137488 with: '' 137489 with: '' "Marker not found and connection closed" 137490! ! 137491 137492!HTTPSocket methodsFor: 'receiving' stamp: 'nice 4/29/2009 21:23'! 137493getResponseUpTo: markerString ignoring: ignoreString 137494 "Keep reading, until the marker is seen, skipping characters in ignoreString when 137495 comparing to the marker. Return three parts: header, marker, beginningOfData. 137496 Fails if no marker in first 2000 chars." 137497 137498 | buf response bytesRead tester mm skipped | 137499 buf := String new: 2000. 137500 response := WriteStream on: buf. 137501 tester := 1. mm := 1. 137502 skipped := 0. 137503 [tester := tester - markerString size + 1 max: 1. "rewind a little, in case the marker crosses a read boundary" 137504 tester to: response position do: [:tt | 137505 (buf at: tt) = (markerString at: mm) ifFalse: 137506 [[ignoreString includes: (markerString at: mm)] whileTrue: 137507 [mm := mm + 1. skipped := skipped + 1]]. 137508 (buf at: tt) = (markerString at: mm) 137509 ifTrue: [mm := mm + 1] 137510 ifFalse: [mm := 1. skipped := 0]. 137511 "Not totally correct for markers like xx0xx" 137512 mm > markerString size ifTrue: ["got it" 137513 ^ Array with: (buf copyFrom: 1 to: tt+1-mm+skipped) 137514 with: markerString 137515 with: (buf copyFrom: tt+1 to: response position)]]. 137516 tester := 1 max: response position. "OK if mm in the middle" 137517 (response position < buf size) & (self isConnected | self dataAvailable)] whileTrue: [ 137518 self waitForDataFor: 5 ifClosed: [ 137519 Transcript show: ' <connection closed> '] 137520 ifTimedOut: [ 137521 Transcript show: 'data was late']. 137522 bytesRead := self primSocket: socketHandle receiveDataInto: buf 137523 startingAt: response position + 1 count: buf size - response position. 137524 "response position+1 to: response position+bytesRead do: [:ii | 137525 response nextPut: (buf at: ii)]. totally redundant, but needed to advance position!!" 137526 response instVarAt: 2 "position" put: 137527 (response position + bytesRead)]. "horrible, but fast" 137528 137529 ^ Array with: response contents 137530 with: '' 137531 with: '' "Marker not found and connection closed" 137532! ! 137533 137534!HTTPSocket methodsFor: 'receiving' stamp: 'adrian-lienhard 6/5/2009 22:34'! 137535getRestOfBuffer: beginning 137536 "We don't know the length. Keep going until connection is closed. Part of it has already been received. Response is of type text, not binary." 137537 137538 | buf response bytesRead | 137539 response := RWBinaryOrTextStream on: (String new: 2000). 137540 response nextPutAll: beginning. 137541 buf := String new: 2000. 137542 137543 [self isConnected | self dataAvailable] 137544 whileTrue: [ 137545 self waitForDataFor: 5 ifClosed: [ 137546 Transcript show: ' <connection closed> '] 137547 ifTimedOut: [ 137548 Transcript show: 'data was slow']. 137549 bytesRead := self primSocket: socketHandle receiveDataInto: buf 137550 startingAt: 1 count: buf size. 137551 bytesRead > 0 ifTrue: [ 137552 response nextPutAll: (buf copyFrom: 1 to: bytesRead)] ]. 137553 response reset. "position: 0." 137554 ^ response 137555! ! 137556 137557!HTTPSocket methodsFor: 'receiving' stamp: 'nice 4/29/2009 21:24'! 137558getRestOfBuffer: beginning totalLength: length 137559 "Reel in a string of a fixed length. Part of it has already been received. Close the connection after all chars are received. We do not strip out linefeed chars. tk 6/16/97 22:32" 137560 "if length is nil, read until connection close. Response is of type text, not binary." 137561 137562 | buf response bytesRead | 137563 length ifNil: [^ self getRestOfBuffer: beginning]. 137564 buf := String new: length. 137565 response := RWBinaryOrTextStream on: buf. 137566 response nextPutAll: beginning. 137567 buf := String new: length. 137568 137569 [(response position < length) & (self isConnected | self dataAvailable)] 137570 whileTrue: [ 137571 self waitForDataFor: 5 ifClosed: [ 137572 Transcript show: ' <connection closed> '] 137573 ifTimedOut: [ 137574 Transcript show: 'data was slow']. 137575 bytesRead := self primSocket: socketHandle receiveDataInto: buf startingAt: 1 137576 count: (length - response position). 137577 bytesRead > 0 ifTrue: [ 137578 response nextPutAll: (buf copyFrom: 1 to: bytesRead)] ]. 137579 "Transcript cr; show: 'data byte count: ', response position printString." 137580 "Transcript cr; show: ((self isConnected) ifTrue: ['Over length by: ', bytesRead printString] 137581 ifFalse: ['Socket closed'])." 137582 response position < length ifTrue: [^ 'server aborted early']. 137583 response reset. "position: 0." 137584 ^ response! ! 137585 137586!HTTPSocket methodsFor: 'receiving' stamp: 'adrian-lienhard 6/5/2009 22:02'! 137587redirect 137588 "See if the header has a 'Location: url CrLf' in it. If so, return the new URL of this page. tk 6/24/97 18:03" 137589 137590 | this | 137591 1 to: headerTokens size do: [:ii | 137592 this := headerTokens at: ii. 137593 (this first asLowercase = $l and: [this asLowercase = 'location:']) ifTrue: [ 137594 ^ (headerTokens at: ii+1)]]. 137595 ^ nil "not found" 137596! ! 137597 137598"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 137599 137600HTTPSocket class 137601 instanceVariableNames: ''! 137602 137603!HTTPSocket class methodsFor: 'deprecated-ROLL OVER PROBLEM' stamp: 'hpt 12/9/2004 22:54'! 137604initHTTPSocket: httpUrl wait: timeout ifError: aBlock 137605 "Retrieve the server and port information from the URL, match it to the proxy settings and open a http socket for the request." 137606 137607 | serverName port serverAddr s | 137608 Socket initializeNetwork. 137609 137610 serverName := httpUrl authority. 137611 port := httpUrl port ifNil: [self defaultPort]. 137612 137613 (self shouldUseProxy: serverName) ifTrue: [ 137614 serverName := self httpProxyServer. 137615 port := self httpProxyPort]. 137616 137617 "make the request" 137618 serverAddr := NetNameResolver addressForName: serverName timeout: 20. 137619 serverAddr ifNil: [ 137620 aBlock value: 'Error: Could not resolve the server named: ', serverName]. 137621 137622 s := HTTPSocket new. 137623 s connectTo: serverAddr port: port. 137624 (s waitForConnectionUntil: timeout) ifFalse: [ 137625 Socket deadServer: httpUrl authority. 137626 s destroy. 137627 ^aBlock value: 'Error: Server ',httpUrl authority,' is not responding']. 137628 ^s 137629! ! 137630 137631 137632!HTTPSocket class methodsFor: 'digest' stamp: 'damiencassou 2/17/2009 09:53'! 137633digestFor: serverText method: method url: url user: user password: password 137634 "RFC2069" 137635 | sock | 137636 sock := HTTPSocket new. "header decoder is on instance side" 137637 sock header: (serverText readStream upToAll: String crlf, String crlf). 137638 ^self digestFrom: sock method: method url: url user: user password: password! ! 137639 137640!HTTPSocket class methodsFor: 'digest' stamp: 'damiencassou 2/17/2009 09:54'! 137641digestFrom: sock method: method url: url user: user password: password 137642 "RFC2069" 137643 | auth fields realm nonce uri a1 a2 response | 137644 sock responseCode = '401' ifFalse: [^nil]. 137645 auth := sock getHeader: 'www-authenticate'. 137646 (auth asLowercase beginsWith: 'digest') ifFalse: [^nil]. 137647 137648 fields := (((auth allButFirst: 6) findTokens: ', ') collect: [:ea | 137649 (ea copyUpTo: $=) asLowercase -> (ea copyAfter: $=) withoutQuoting]) as: Dictionary. 137650 137651 realm := fields at: 'realm'. 137652 nonce := fields at: 'nonce'. 137653 uri := url readStream upToAll: '://'; skipTo: $/; skip: -1; upTo: $#. 137654 a1 := self md5Hash: user, ':', realm, ':', password. 137655 a2 := self md5Hash: method, ':', uri. 137656 a1 ifNil: [^nil "no MD5 support"]. 137657 response := self md5Hash: a1, ':', nonce, ':', a2. 137658 137659 ^String streamContents: [:digest | 137660 digest 137661 nextPutAll: 'username="', user, '"'; 137662 nextPutAll: ', realm="', realm, '"'; 137663 nextPutAll: ', nonce="', nonce, '"'; 137664 nextPutAll: ', uri="', uri, '"'; 137665 nextPutAll: ', response="', response, '"'. 137666 fields at: 'opaque' ifPresent: [:opaque | 137667 digest nextPutAll: ', opaque="', opaque, '"']. 137668 ] 137669! ! 137670 137671!HTTPSocket class methodsFor: 'digest' stamp: 'damiencassou 2/17/2009 10:15'! 137672md5Hash: aString 137673 "Answer hash of aString as lowercase 32 digit hex String. 137674 There are several providers of MD5 hash ..." 137675 "(self md5Hash: 'user:realm:passwd') = '007e68e539ed680c24f6d9a370f3bcb1'" 137676 | hash | 137677 hash := Smalltalk at: #CMD5Hasher ifPresent: [:cls | 137678 cls hashMessage: aString]. 137679 hash ifNil: [ 137680 hash := Smalltalk at: #TCryptoRandom ifPresent: [:cls | 137681 (cls basicNew md5HashMessage: aString) asInteger]]. 137682 hash ifNotNil: [ 137683 hash := hash hex asLowercase. 137684 (hash beginsWith: '16r') ifTrue: [hash := hash allButFirst: 3]. 137685 hash := hash padded: #left to: 32 with: $0]. 137686 ^hash! ! 137687 137688 137689!HTTPSocket class methodsFor: 'get the page' stamp: 'ar 9/27/2005 20:07'! 137690httpFileInNewChangeSet: url 137691 "Do a regular file-in of a file that is served from a web site. Put it into a new changeSet." 137692 "Notes: To store a file on an HTTP server, use the program 'Fetch'. After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc. Use any file extension as long as it is not one of the common ones." 137693 " HTTPSocket httpFileInNewChangeSet: '206.18.68.12/squeak/updates/83tk:=test.cs' " 137694 137695 | doc | 137696 doc := self httpGet: url accept: 'application/octet-stream'. 137697 doc isString ifTrue: 137698 [self inform: 'Cannot seem to contact the web site']. 137699 doc reset. 137700 ChangeSet newChangesFromStream: doc 137701 named: (url findTokens: '/') last.! ! 137702 137703!HTTPSocket class methodsFor: 'get the page' stamp: 'ar 4/10/2005 18:47'! 137704httpFileIn: url 137705 "Do a regular file-in of a file that is served from a web site. If the file contains an EToy, then open it. Might just be code instead. tk 7/23/97 17:10" 137706 "Notes: To store a file on an HTTP server, use the program 'Fetch'. After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc. Use any file extension as long as it is not one of the common ones. The server does not have to know about the .sqo extension in order to send your file. (We do not need a new MIME type and .sqo does not have to be registered with the server.)" 137707 " HTTPSocket httpFileIn: 'www.webPage.com/~kaehler2/sample.etoy' " 137708 " HTTPSocket httpFileIn: '206.18.68.12/squeak/car.sqo' " 137709 " HTTPSocket httpFileIn: 'jumbo/tedk/sample.etoy' " 137710 137711 | doc eToyHolder | 137712 doc := self httpGet: url accept: 'application/octet-stream'. 137713 doc isString ifTrue: 137714 [self inform: 'Cannot seem to contact the web site']. 137715 doc reset. 137716 eToyHolder := doc fileInObjectAndCode. 137717 137718 eToyHolder ifNotNil: [eToyHolder open]. 137719 "Later may want to return it, instead of open it" 137720! ! 137721 137722!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:25'! 137723httpGetDocument: url 137724 "Return the exact contents of a web page or other web object. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:21" 137725 " HTTPSocket httpShowPage: 'http://www.altavista.digital.com/index.html' " 137726 " HTTPSocket httpShowPage: 'www.webPage.com/~kaehler2/ab.html' " 137727 " HTTPSocket httpShowPage: 'www.exploratorium.edu/index.html' " 137728 " HTTPSocket httpShowPage: 'www.apple.com/default.html' " 137729 " HTTPSocket httpShowPage: 'www.altavista.digital.com/' " 137730 " HTTPSocket httpShowPage: 'jumbo/tedk/ab.html' " 137731 137732 ^ self httpGetDocument: url args: nil accept: 'application/octet-stream' request: '' 137733! ! 137734 137735!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:26'! 137736httpGetDocument: url accept: mimeType 137737 "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:12" 137738 ^self httpGetDocument: url args: nil accept: mimeType request: ''! ! 137739 137740!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:26'! 137741httpGetDocument: url args: args 137742 "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:12" 137743 "Note: To fetch raw data, you can use the MIMI type 'application/octet-stream'." 137744 ^self httpGetDocument: url args: args accept: 'application/octet-stream' request: ''! ! 137745 137746!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 17:48'! 137747httpGetDocument: url args: args accept: mimeType 137748 "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. Note: To fetch raw data, you can use the MIME type 'application/octet-stream'." 137749 137750 ^ self httpGetDocument: url args: args accept: mimeType request: ''! ! 137751 137752!HTTPSocket class methodsFor: 'get the page' stamp: 'adrian-lienhard 5/18/2009 21:18'! 137753httpGetDocument: url args: args accept: mimeType request: requestString 137754 "Return the exact contents of a web object. Asks for the given MIME 137755type. If mimeType is nil, use 'text/html'. An extra requestString may be 137756submitted and must end with crlf. The parsed header is saved. Use a 137757proxy server if one has been registered. tk 7/23/97 17:12" 137758 "Note: To fetch raw data, you can use the MIME type 137759'application/octet-stream'." 137760 137761 | serverName serverAddr port sock header length bare page list firstData 137762aStream index connectToHost connectToPort type newUrl | 137763 Socket initializeNetwork. 137764 bare := (url asLowercase beginsWith: 'http://') 137765 ifTrue: [url copyFrom: 8 to: url size] 137766 ifFalse: [url]. 137767 bare := bare copyUpTo: $#. "remove fragment, if specified" 137768 serverName := bare copyUpTo: $/. 137769 page := bare copyFrom: serverName size + 1 to: bare size. 137770 (serverName includes: $:) 137771 ifTrue: [ index := serverName indexOf: $:. 137772 port := (serverName copyFrom: index+1 to: serverName size) asNumber. 137773 serverName := serverName copyFrom: 1 to: index-1. ] 137774 ifFalse: [ port := self defaultPort ]. 137775 page size = 0 ifTrue: [page := '/']. 137776 "add arguments" 137777 args ifNotNil: [page := page, (self argString: args) ]. 137778 137779 137780 (self shouldUseProxy: serverName) 137781 ifFalse: [ 137782 connectToHost := serverName. 137783 connectToPort := port ] 137784 ifTrue: [ 137785 page := 'http://', serverName, ':', port printString, page. "put back 137786together" 137787 connectToHost := self httpProxyServer. 137788 connectToPort := self httpProxyPort]. 137789 137790 137791 serverAddr := NetNameResolver addressForName: connectToHost timeout: 20. 137792 serverAddr ifNil: [ 137793 ^ 'Could not resolve the server named: ', connectToHost]. 137794 1377953 timesRepeat: [ 137796 sock := HTTPSocket new. 137797 sock connectTo: serverAddr port: connectToPort. 137798 (sock waitForConnectionFor: 30 ifTimedOut: [false]) ifFalse: [ 137799 Socket deadServer: connectToHost. sock destroy. 137800 ^ 'Server ',connectToHost,' is not responding']. 137801 "Transcript cr;show: url; cr. 137802 Transcript show: page; cr." 137803 sock sendCommand: 'GET ', page, ' HTTP/1.0', String crlf, 137804 (mimeType ifNotNil: ['ACCEPT: ', mimeType, String crlf] ifNil: ['']), 137805 'ACCEPT: text/html', String crlf, "Always accept plain text" 137806 HTTPProxyCredentials, 137807 HTTPBlabEmail, "may be empty" 137808 requestString, "extra user request. Authorization" 137809 self userAgentString, String crlf, 137810 'Host: ', serverName, ':', port printString, String crlf. "blank line 137811automatically added" 137812 137813 list := sock getResponseUpTo: String crlf, String crlf ignoring: String cr. "list = header, CrLf, CrLf, 137814beginningOfData" 137815 header := list at: 1. 137816 "Transcript show: page; cr; show: header; cr." 137817 firstData := list at: 3. 137818 header isEmpty 137819 ifTrue: [aStream := 'server aborted early'] 137820 ifFalse: [ 137821 "dig out some headers" 137822 sock header: header. 137823 length := sock getHeader: 'content-length'. 137824 length ifNotNil: [ length := length asNumber ]. 137825 type := sock getHeader: 'content-type'. 137826 sock responseCode first = $3 ifTrue: [ 137827 newUrl := sock getHeader: 'location'. 137828 newUrl ifNotNil: [ 137829 Transcript show: 'redirecting to ', newUrl; cr. 137830 sock destroy. 137831 newUrl := self expandUrl: newUrl ip: serverAddr port: connectToPort. 137832 ^self httpGetDocument: newUrl args: args accept: mimeType request: requestString] ]. 137833 aStream := sock getRestOfBuffer: firstData totalLength: length. 137834 "a 400-series error" 137835 sock responseCode first = $4 ifTrue: [^ header, aStream contents]. 137836 ]. 137837 sock destroy. "Always OK to destroy!!" 137838 aStream class ~~ String ifTrue: [ 137839 ^ MIMEDocument contentType: type content: aStream contents url: url]. 137840 aStream = 'server aborted early' ifTrue: [ ^aStream ]. 137841 ]. 137842 137843{'HTTPSocket class>>httpGetDocument:args:accept:request:'. aStream. url} inspect. 137844 137845 ^'some other bad thing happened!!'! ! 137846 137847!HTTPSocket class methodsFor: 'get the page' stamp: 'dc 10/21/2008 08:55'! 137848httpGetNoError: url args: args accept: mimeType 137849 "Return the exact contents of a web file. Do better error checking. Asks for the given MIME type. To fetch raw data, you can use the MIMI type 'application/octet-stream'. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered." 137850 137851"Edited to remove a lineFeed from the source 4/4/99 - di" 137852 137853 | document data | 137854 document := self httpGetDocument: url args: args accept: mimeType. 137855 (document isString) ifTrue: [ 137856 "strings indicate errors" 137857 ^ document ]. 137858 data := document content. 137859 (data beginsWith: '<HTML><HEAD>' , String lf , '<TITLE>4') 137860 ifTrue: ["an error message 404 File not found" 137861 ^ data copyFrom: 21 to: data size-16]. 137862 137863 ^ (RWBinaryOrTextStream with: data) reset 137864! ! 137865 137866!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 12/7/2001 17:36'! 137867httpGet: url 137868 "Return the exact contents of a web page or other web object. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:21" 137869 " HTTPSocket httpShowPage: 'http://www.altavista.digital.com/index.html' " 137870 " HTTPSocket httpShowPage: 'www.webPage.com/~kaehler2/ab.html' " 137871 " HTTPSocket httpShowPage: 'www.exploratorium.edu/index.html' " 137872 " HTTPSocket httpShowPage: 'www.apple.com/default.html' " 137873 " HTTPSocket httpShowPage: 'www.altavista.digital.com/' " 137874 " HTTPSocket httpShowPage: 'jumbo/tedk/ab.html' " 137875 137876 ^ self httpGet: url accept: '*/*' 137877! ! 137878 137879!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 12/7/2001 17:37'! 137880httpGet: url accept: mimeType 137881 "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. 137882 Note: To fetch raw data, you can use the MIME type 'application/octet-stream'. To accept anything, use '*/*'." 137883 137884 ^self httpGet: url args: nil accept: mimeType! ! 137885 137886!HTTPSocket class methodsFor: 'get the page' stamp: 'tak 9/25/2008 15:09'! 137887httpGet: url args: args accept: mimeType 137888 ^self httpGet: url args: args accept: mimeType request: ''! ! 137889 137890!HTTPSocket class methodsFor: 'get the page' stamp: 'damiencassou 2/17/2009 10:27'! 137891httpGet: url args: args accept: mimeType request: requestString 137892 "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:12" 137893 "Note: To fetch raw data, you can use the MIME type 'application/octet-stream'." 137894 137895 | document | 137896 document := self httpGetDocument: url args: args accept: mimeType request: requestString. 137897 (document isString) ifTrue: [ 137898 "strings indicate errors" 137899 ^ document ]. 137900 137901 ^ (RWBinaryOrTextStream with: document content) reset 137902! ! 137903 137904!HTTPSocket class methodsFor: 'get the page' stamp: 'damiencassou 2/17/2009 09:55'! 137905httpGet: url args: args user: user passwd: passwd 137906 | authorization result | 137907 authorization := (Base64MimeConverter mimeEncode: (user , ':' , passwd) readStream) contents. 137908 result := self 137909 httpGet: url args: args accept: '*/*' 137910 request: 'Authorization: Basic ' , authorization , String crlf. 137911 result isString ifFalse: [^result]. 137912 137913 authorization := self digestFor: result method: 'GET' url: url user: user password: passwd. 137914 authorization ifNil: [^result]. 137915 ^self 137916 httpGet: url args: args accept: '*/*' 137917 request: 'Authorization: Digest ' , authorization , String crlf. 137918! ! 137919 137920!HTTPSocket class methodsFor: 'get the page' stamp: 'ar 4/10/2005 18:48'! 137921httpGif: url 137922 "Fetch the given URL, parse it using the GIF reader, and return the resulting Form." 137923 " HTTPSocket httpShowGif: 'www.altavista.digital.com/av/pix/default/av-adv.gif' " 137924 " HTTPSocket httpShowGif: 'www.webPage.com/~kaehler2/ainslie.gif' " 137925 137926 | doc ggg | 137927 doc := self httpGet: url accept: 'image/gif'. 137928 doc isString ifTrue: [ 137929 self inform: 'The server with that GIF is not responding'. 137930 ^ ColorForm extent: 20@20 depth: 8]. 137931 doc binary; reset. 137932 (ggg := GIFReadWriter new) setStream: doc. 137933 ^ ggg nextImage. 137934! ! 137935 137936!HTTPSocket class methodsFor: 'get the page' stamp: 'nk 7/7/2003 18:37'! 137937httpJpeg: url 137938 "Fetch the given URL, parse it using the JPEG reader, and return the resulting Form." 137939 137940 | doc ggg | 137941 doc := self httpGet: url. 137942 doc binary; reset. 137943 (ggg := JPEGReadWriter new) setStream: doc. 137944 ^ ggg nextImage. 137945! ! 137946 137947!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:27'! 137948httpPostDocument: url args: argsDict 137949 "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" 137950 137951 ^self httpPostDocument: url args: argsDict accept: 'application/octet-stream' request: ''! ! 137952 137953!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 20:16'! 137954httpPostDocument: url args: argsDict accept: mimeType 137955 "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" 137956 137957 ^ self httpPostDocument: url args: argsDict accept: mimeType request: '' 137958! ! 137959 137960!HTTPSocket class methodsFor: 'get the page' stamp: 'nice 4/28/2009 21:43'! 137961httpPostDocument: url args: argsDict accept: mimeType request: requestString 137962 "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" 137963 137964 | s header length page list firstData aStream type newUrl httpUrl argString | 137965 Socket initializeNetwork. 137966 httpUrl := Url absoluteFromText: url. 137967 page := httpUrl fullPath. 137968 "add arguments" 137969 argString := argsDict 137970 ifNotNil: [ 137971 argString := self argString: argsDict. 137972 argString first = $? ifTrue: [ argString := argString copyFrom: 2 to: argString size]] 137973 ifNil: ['']. 137974 137975 s := HTTPSocket new. 137976 s := self initHTTPSocket: httpUrl timeoutSecs: 30 ifError: [:errorString | ^errorString]. 137977 s sendCommand: 'POST ', page, ' HTTP/1.0', String crlf, 137978 (mimeType ifNotNil: ['ACCEPT: ', mimeType, String crlf] ifNil: ['']), 137979 'ACCEPT: text/html', String crlf, "Always accept plain text" 137980 HTTPProxyCredentials, 137981 HTTPBlabEmail, "may be empty" 137982 requestString, "extra user request. Authorization" 137983 self userAgentString, String crlf, 137984 'Content-type: application/x-www-form-urlencoded', String crlf, 137985 'Content-length: ', argString size printString, String crlf, 137986 'Host: ', httpUrl authority, String crlf. "blank line automatically added" 137987 137988 "umur - IE sends argString without a $? and swiki expects so" 137989 s sendCommand: argString. 137990 137991 "get the header of the reply" 137992 list := s getResponseUpTo: String crlf, String crlf ignoring: String cr. "list = header, CrLf, CrLf, beginningOfData" 137993 header := list at: 1. 137994 "Transcript show: page; cr; show: argsStream contents; cr; show: header; cr." 137995 firstData := list at: 3. 137996 137997 "dig out some headers" 137998 s header: header. 137999 length := s getHeader: 'content-length'. 138000 length ifNotNil: [ length := length asNumber ]. 138001 type := s getHeader: 'content-type'. 138002 s responseCode first = $3 ifTrue: [ 138003 newUrl := s getHeader: 'location'. 138004 newUrl ifNotNil: [ 138005 "umur 6/25/2003 12:58 - If newUrl is relative then we need to make it absolute." 138006 newUrl := (httpUrl newFromRelativeText: newUrl) asString. 138007 self flag: #refactor. "get, post, postmultipart are almost doing the same stuff" 138008 s destroy. 138009 "^self httpPostDocument: newUrl args: argsDict accept: mimeType" 138010 ^self httpGetDocument: newUrl accept: mimeType ] ]. 138011 138012 aStream := s getRestOfBuffer: firstData totalLength: length. 138013 s responseCode = '401' ifTrue: [^ header, aStream contents]. 138014 s destroy. "Always OK to destroy!!" 138015 138016 ^ MIMEDocument contentType: type content: aStream contents url: url! ! 138017 138018!HTTPSocket class methodsFor: 'get the page' stamp: 'PeterHugossonMiller 9/3/2009 01:45'! 138019httpPostMultipart: url args: argsDict accept: mimeType request: requestString 138020 " do multipart/form-data encoding rather than x-www-urlencoded " 138021 " by Bolot Kerimbaev, 1998 " 138022 " this version is a memory hog: puts the whole file in memory " 138023 "bolot 12/14/2000 18:28 -- minor fixes to make it comply with RFC 1867" 138024 138025 | serverName serverAddr s header length bare page list firstData aStream port argsStream specifiedServer type newUrl mimeBorder fieldValue | 138026 Socket initializeNetwork. 138027 138028 "parse url" 138029 bare := (url asLowercase beginsWith: 'http://') 138030 ifTrue: [url copyFrom: 8 to: url size] 138031 ifFalse: [url]. 138032 serverName := bare copyUpTo: $/. 138033 specifiedServer := serverName. 138034 (serverName includes: $:) ifFalse: [ port := self defaultPort ] ifTrue: [ 138035 port := (serverName copyFrom: (serverName indexOf: $:) + 1 to: serverName size) asNumber. 138036 serverName := serverName copyUpTo: $:. 138037 ]. 138038 138039 page := bare copyFrom: (bare indexOf: $/) to: bare size. 138040 page size = 0 ifTrue: [page := '/']. 138041 (self shouldUseProxy: serverName) ifTrue: [ 138042 page := 'http://', serverName, ':', port printString, page. "put back together" 138043 serverName := self httpProxyServer. 138044 port := self httpProxyPort]. 138045 138046 mimeBorder := '----squeak-georgia-tech-', Time millisecondClockValue printString, '-csl-cool-stuff-----'. 138047 "encode the arguments dictionary" 138048 argsStream := String new writeStream. 138049 argsDict associationsDo: [:assoc | 138050 assoc value do: [ :value | 138051 "print the boundary" 138052 argsStream nextPutAll: '--', mimeBorder, String crlf. 138053 " check if it's a non-text field " 138054 argsStream nextPutAll: 'Content-disposition: multipart/form-data; name="', assoc key, '"'. 138055 (value isKindOf: MIMEDocument) 138056 ifFalse: [fieldValue := value] 138057 ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', String crlf, 'Content-Type: ', value contentType. 138058 fieldValue := (value content 138059 ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile] 138060 ifNotNil: [value content]) asString]. 138061" Transcript show: 'field=', key, '; value=', fieldValue; cr. " 138062 argsStream nextPutAll: String crlf, String crlf, fieldValue, String crlf. 138063 ]]. 138064 argsStream nextPutAll: '--', mimeBorder, '--'. 138065 138066 "make the request" 138067 serverAddr := NetNameResolver addressForName: serverName timeout: 20. 138068 serverAddr ifNil: [ 138069 ^ 'Could not resolve the server named: ', serverName]. 138070 138071 138072 s := HTTPSocket new. 138073 s connectTo: serverAddr port: port. 138074 s waitForConnectionFor: self standardTimeout. 138075 Transcript cr; show: serverName, ':', port asString; cr. 138076 s sendCommand: 'POST ', page, ' HTTP/1.1', String crlf, 138077 (mimeType ifNotNil: ['ACCEPT: ', mimeType, String crlf] ifNil: ['']), 138078 'ACCEPT: text/html', String crlf, "Always accept plain text" 138079 HTTPProxyCredentials, 138080 HTTPBlabEmail, "may be empty" 138081 requestString, "extra user request. Authorization" 138082 self userAgentString, String crlf, 138083 'Content-type: multipart/form-data; boundary=', mimeBorder, String crlf, 138084 'Content-length: ', argsStream contents size printString, String crlf, 138085 'Host: ', specifiedServer, String crlf. "blank line automatically added" 138086 138087 s sendCommand: argsStream contents. 138088 138089 "get the header of the reply" 138090 list := s getResponseUpTo: String crlf, String crlf. "list = header, CrLf, CrLf, beginningOfData" 138091 header := list at: 1. 138092 "Transcript show: page; cr; show: argsStream contents; cr; show: header; cr." 138093 firstData := list at: 3. 138094 138095 "dig out some headers" 138096 s header: header. 138097 length := s getHeader: 'content-length'. 138098 length ifNotNil: [ length := length asNumber ]. 138099 type := s getHeader: 'content-type'. 138100 s responseCode first = $3 ifTrue: [ 138101 "redirected - don't re-post automatically" 138102 "for now, just do a GET, without discriminating between 301/302 codes" 138103 newUrl := s getHeader: 'location'. 138104 newUrl ifNotNil: [ 138105 (newUrl beginsWith: 'http://') 138106 ifFalse: [ 138107 (newUrl beginsWith: '/') 138108 ifTrue: [newUrl := (bare copyUpTo: $/), newUrl] 138109 ifFalse: [newUrl := url, newUrl. self flag: #todo 138110 "should do a relative URL"] 138111 ]. 138112 Transcript show: 'redirecting to: ', newUrl; cr. 138113 s destroy. 138114 ^self httpGetDocument: newUrl 138115 "for some codes, may do: 138116 ^self httpPostMultipart: newUrl args: argsDict accept: mimeType request: requestString"] ]. 138117 138118 aStream := s getRestOfBuffer: firstData totalLength: length. 138119 s responseCode = '401' ifTrue: [^ header, aStream contents]. 138120 s destroy. "Always OK to destroy!!" 138121 138122 ^ MIMEDocument contentType: type content: aStream contents url: url! ! 138123 138124!HTTPSocket class methodsFor: 'get the page' stamp: 'nice 4/28/2009 21:40'! 138125httpPostToSuperSwiki: url args: argsDict accept: mimeType request: requestString 138126 138127 | serverName serverAddr s header length bare page list firstData aStream port specifiedServer type mimeBorder contentsData | 138128 138129 Socket initializeNetwork. 138130 138131 "parse url" 138132 bare := (url asLowercase beginsWith: 'http://') 138133 ifTrue: [url copyFrom: 8 to: url size] 138134 ifFalse: [url]. 138135 serverName := bare copyUpTo: $/. 138136 specifiedServer := serverName. 138137 (serverName includes: $:) ifFalse: [ port := self defaultPort ] ifTrue: [ 138138 port := (serverName copyFrom: (serverName indexOf: $:) + 1 to: serverName size) asNumber. 138139 serverName := serverName copyUpTo: $:. 138140 ]. 138141 138142 page := bare copyFrom: (bare indexOf: $/ ifAbsent: [^'error']) to: bare size. 138143 page size = 0 ifTrue: [page := '/']. 138144 (self shouldUseProxy: serverName) ifTrue: [ 138145 page := 'http://', serverName, ':', port printString, page. "put back together" 138146 serverName := self httpProxyServer. 138147 port := self httpProxyPort]. 138148 138149 mimeBorder := '---------SuperSwiki',Time millisecondClockValue printString,'-----'. 138150 contentsData := String streamContents: [ :strm | 138151 strm nextPutAll: mimeBorder, String crlf. 138152 argsDict associationsDo: [:assoc | 138153 assoc value do: [ :value | 138154 strm 138155 nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"'; 138156 nextPutAll: String crlf; 138157 nextPutAll: String crlf; 138158 nextPutAll: value; 138159 nextPutAll: String crlf; 138160 nextPutAll: String crlf; 138161 nextPutAll: mimeBorder; 138162 nextPutAll: String crlf. 138163 ] 138164 ]. 138165 ]. 138166 138167 "make the request" 138168 serverAddr := NetNameResolver addressForName: serverName timeout: 20. 138169 serverAddr ifNil: [ 138170 ^ 'Could not resolve the server named: ', serverName]. 138171 138172 s := HTTPSocket new. 138173 s connectTo: serverAddr port: port. 138174 s waitForConnectionFor: self standardTimeout. 138175 s sendCommand: 'POST ', page, ' HTTP/1.1', String crlf, 138176 (mimeType ifNotNil: ['ACCEPT: ', mimeType, String crlf] ifNil: ['']), 138177 'ACCEPT: text/html', String crlf, "Always accept plain text" 138178 HTTPProxyCredentials, 138179 HTTPBlabEmail, "may be empty" 138180 requestString, "extra user request. Authorization" 138181 self userAgentString, String crlf, 138182 'Content-type: multipart/form-data; boundary=', mimeBorder, String crlf, 138183 'Content-length: ', contentsData size printString, String crlf, 138184 'Host: ', specifiedServer, String crlf. "blank line automatically added" 138185 138186 s sendCommand: contentsData. 138187 138188 list := s getResponseUpTo: String crlf, String crlf. "list = header, CrLf, CrLf, beginningOfData" 138189 header := list at: 1. 138190 firstData := list at: 3. 138191 138192 header isEmpty ifTrue: [ 138193 s destroy. 138194 ^'no response' 138195 ]. 138196 s header: header. 138197 length := s getHeader: 'content-length'. 138198 length ifNotNil: [ length := length asNumber ]. 138199 type := s getHeader: 'content-type'. 138200 aStream := s getRestOfBuffer: firstData totalLength: length. 138201 s responseCode = '401' ifTrue: [^ header, aStream contents]. 138202 s destroy. "Always OK to destroy!!" 138203 138204 ^ MIMEDocument contentType: type content: aStream contents url: url! ! 138205 138206!HTTPSocket class methodsFor: 'get the page' stamp: 'nk 8/30/2004 07:50'! 138207httpPost: url args: argsDict accept: mimeType 138208 "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" 138209 | document | 138210 document := self httpPostDocument: url args: argsDict accept: mimeType request: ''. 138211 (document isString) ifTrue: [ 138212 "strings indicate errors" 138213 ^document ]. 138214 138215 138216 ^RWBinaryOrTextStream with: document content! ! 138217 138218!HTTPSocket class methodsFor: 'get the page' stamp: 'damiencassou 2/17/2009 10:11'! 138219httpPost: url args: args user: user passwd: passwd 138220 | authorization result | 138221 authorization := (Base64MimeConverter mimeEncode: (user , ':' , passwd) readStream) contents. 138222 result := self 138223 httpPostDocument: url args: args accept: '*/*' 138224 request: 'Authorization: Basic ' , authorization , String crlf. 138225 result isString ifFalse: [^result]. 138226 138227 authorization := self digestFor: result method: 'POST' url: url user: user password: passwd. 138228 authorization ifNil: [^result]. 138229 ^self 138230 httpPostDocument: url args: args accept: '*/*' 138231 request: 'Authorization: Digest ' , authorization , String crlf. 138232! ! 138233 138234!HTTPSocket class methodsFor: 'get the page' stamp: 'nice 4/28/2009 21:40'! 138235httpPut: contents to: url user: user passwd: passwd 138236 "Upload the contents of the stream to a file on the server" 138237 138238 | bare serverName specifiedServer port page serverAddr authorization s list header firstData length aStream command digest | 138239 Socket initializeNetwork. 138240 138241 "parse url" 138242 bare := (url asLowercase beginsWith: 'http://') 138243 ifTrue: [url copyFrom: 8 to: url size] 138244 ifFalse: [url]. 138245 serverName := bare copyUpTo: $/. 138246 specifiedServer := serverName. 138247 (serverName includes: $:) ifFalse: [ port := self defaultPort ] ifTrue: [ 138248 port := (serverName copyFrom: (serverName indexOf: $:) + 1 138249 to: serverName size) asNumber. 138250 serverName := serverName copyUpTo: $:. 138251 ]. 138252 138253 page := bare copyFrom: (bare indexOf: $/) to: bare size. 138254 page size = 0 ifTrue: [page := '/']. 138255 (self shouldUseProxy: serverName) ifTrue: [ 138256 page := 'http://', serverName, ':', port printString, page. "put back together" 138257 serverName := self httpProxyServer. 138258 port := self httpProxyPort]. 138259 138260 "make the request" 138261 serverAddr := NetNameResolver addressForName: serverName timeout: 20. 138262 serverAddr ifNil: [ 138263 ^ 'Could not resolve the server named: ', serverName]. 138264 138265 authorization := ' Basic ', (Base64MimeConverter mimeEncode: (user , ':' , passwd) readStream) contents. 138266[ 138267 s := HTTPSocket new. 138268 s connectTo: serverAddr port: port. 138269 s waitForConnectionFor: self standardTimeout. 138270 Transcript cr; show: url; cr. 138271 command := 138272 'PUT ', page, ' HTTP/1.0', String crlf, 138273 self userAgentString, String crlf, 138274 'Host: ', specifiedServer, String crlf, 138275 'ACCEPT: */*', String crlf, 138276 HTTPProxyCredentials, 138277 'Authorization: ' , authorization , String crlf , 138278 'Content-length: ', contents size printString, String crlf , String crlf , 138279 contents. 138280 s sendCommand: command. 138281 "get the header of the reply" 138282 list := s getResponseUpTo: String crlf, String crlf ignoring: String cr. "list = header, CrLf, CrLf, beginningOfData" 138283 header := list at: 1. 138284 "Transcript show: page; cr; show: argsStream contents; cr; show: header; cr." 138285 firstData := list at: 3. 138286 138287 "dig out some headers" 138288 s header: header. 138289 138290(authorization beginsWith: 'Digest ') not 138291and: [(digest := self digestFrom: s method: 'PUT' url: url user: user password: passwd) notNil]] 138292 whileTrue: [authorization := 'Digest ', digest]. 138293 138294 length := s getHeader: 'content-length'. 138295 length ifNotNil: [ length := length asNumber ]. 138296 138297 aStream := s getRestOfBuffer: firstData totalLength: length. 138298 s destroy. "Always OK to destroy!!" 138299 ^ header, aStream contents! ! 138300 138301!HTTPSocket class methodsFor: 'get the page' stamp: 'ar 4/10/2005 18:48'! 138302httpShowChunk: url 138303 "From a Swiki server, get a text chunk in the changes file. Show its text in a window with style. Vertical bar separates class and selector. BE SURE TO USE ; instead of : in selectors!!" 138304 " HTTPSocket httpShowChunk: 'http://206.16.12.145:80/OurOwnArea.chunk.Socket|Comment' " 138305 " HTTPSocket httpShowChunk: 'http://206.16.12.145:80/OurOwnArea.chunk.Point|class|x;y;' " 138306 138307 | doc text | 138308 doc := (self httpGet: url accept: 'application/octet-stream'). 138309" doc size = 0 ifTrue: [doc := 'The server does not seem to be responding']." 138310 doc isString ifTrue: [text := doc] ifFalse: [text := doc nextChunkText]. 138311 (StringHolder new contents: text) openLabel: url. 138312! ! 138313 138314!HTTPSocket class methodsFor: 'get the page' stamp: 'sma 4/30/2000 09:50'! 138315httpShowGif: url 138316 "Display the picture retrieved from the given URL, which is assumed to be a GIF file. 138317 See examples in httpGif:." 138318 138319 self showImage: (self httpGif: url) named: (url findTokens: '/') last! ! 138320 138321!HTTPSocket class methodsFor: 'get the page' stamp: 'sma 4/30/2000 09:51'! 138322httpShowJpeg: url 138323 "Display the picture retrieved from the given URL, which is assumed to be a JPEG file. 138324 See examples in httpGif:." 138325 138326 self showImage: (self httpJpeg: url) named: (url findTokens: '/') last! ! 138327 138328!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 5/4/1998 17:01'! 138329httpShowPage: url 138330 "Display the exact contents of the given URL as text. See examples in httpGet:" 138331 138332 | doc | 138333 doc := (self httpGet: url accept: 'application/octet-stream') contents. 138334 doc size = 0 ifTrue: [^ self error: 'Document could not be fetched']. 138335 (StringHolder new contents: doc) openLabel: url. 138336! ! 138337 138338 138339!HTTPSocket class methodsFor: 'initialization' stamp: 'tk 9/21/1998 10:45'! 138340blabEmail: aRequest 138341 "Of the form 'From: me@isp.com <crlf>'" 138342 HTTPBlabEmail := aRequest! ! 138343 138344!HTTPSocket class methodsFor: 'initialization' stamp: 'dc 10/21/2008 08:58'! 138345initialize 138346 "HTTPSocket initialize" 138347 138348 ParamDelimiters := ' ', String crlf. 138349 HTTPPort := 80. 138350 self httpProxyServer: nil. 138351 HTTPBlabEmail := ''. " 'From: somebody@no.where', CrLf " 138352 HTTPProxyCredentials := ''. 138353 138354 ExternalSettings registerClient: self! ! 138355 138356 138357!HTTPSocket class methodsFor: 'magic numbers' stamp: 'ls 9/17/1998 07:17'! 138358defaultPort 138359 "default port to connect on" 138360 ^80! ! 138361 138362 138363!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 23:18'! 138364addHTTPProxyPreferences 138365 " This method will add to Squeak the HTTP Proxy preferences. " 138366 Preferences addTextPreference: #httpProxyServer category: #'http proxy' default: '' balloonHelp: 'HTTP Proxy Server. Leave blank if you don''t want to use a Proxy'. 138367 Preferences addNumericPreference: #httpProxyPort category: #'http proxy' default: 80 balloonHelp: 'HTTP Proxy Port'.! ! 138368 138369!HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 7/30/1999 16:08'! 138370addProxyException: domainName 138371 "Add a (partial, wildcard) domain name to the list of proxy exceptions" 138372 "HTTPSocket addProxyException: '*.online.disney.com'" 138373 138374 self httpProxyExceptions add: domainName! ! 138375 138376!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 22:40'! 138377checkHTTPProxyPreferences 138378 Preferences preferenceAt: #httpProxyPort ifAbsent: [self addHTTPProxyPreferences]. 138379 Preferences preferenceAt: #httpProxyServer ifAbsent: [self addHTTPProxyPreferences].! ! 138380 138381!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/9/2004 22:51'! 138382fetchExternalSettingsIn: aDirectory 138383 "Scan for server configuration files" 138384 "HTTPSocket fetchExternalSettingsIn: (FileDirectory default directoryNamed: 'prefs')" 138385 138386 | stream entries | 138387 (aDirectory fileExists: self proxySettingsFileName) 138388 ifFalse: [^self]. 138389 stream := aDirectory readOnlyFileNamed: self proxySettingsFileName. 138390 stream 138391 ifNotNil: [ 138392 [entries := ExternalSettings parseServerEntryArgsFrom: stream] 138393 ensure: [stream close]]. 138394 138395 entries ifNil: [^self]. 138396 138397 self httpProxyServer: (entries at: 'host' ifAbsent: [nil]). 138398 self httpProxyPort: ((entries at: 'port' ifAbsent: ['80']) asInteger ifNil: [self defaultPort]). 138399 HTTPSocket addProxyException: (entries at: 'exception' ifAbsent: [nil])! ! 138400 138401!HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 7/30/1999 15:03'! 138402httpProxyExceptions 138403 HTTPProxyExceptions ifNil: [HTTPProxyExceptions := OrderedCollection new]. 138404 ^HTTPProxyExceptions! ! 138405 138406!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 22:39'! 138407httpProxyPort 138408 "answer the httpProxyPort" 138409 self checkHTTPProxyPreferences. 138410 ^Preferences valueOfPreference: #httpProxyPort.! ! 138411 138412!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 23:20'! 138413httpProxyPort: aPortNumber 138414 self checkHTTPProxyPreferences. 138415 Preferences setPreference: #httpProxyPort toValue: aPortNumber.! ! 138416 138417!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 23:19'! 138418httpProxyServer 138419 "answer the httpProxyServer. Take into account that as a Preference the Server might appear as an empty string but HTTPSocket expect it to be nil" 138420 self checkHTTPProxyPreferences. 138421 ^Preferences valueOfPreference: #httpProxyServer. 138422! ! 138423 138424!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/10/2004 23:17'! 138425httpProxyServer: aStringOrNil 138426 | serverName | 138427 self checkHTTPProxyPreferences. 138428 serverName := aStringOrNil 138429 ifNil: [''] 138430 ifNotNil: [aStringOrNil withBlanksTrimmed ]. 138431 Preferences setPreference: #httpProxyServer toValue: serverName! ! 138432 138433!HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 8/23/2002 14:29'! 138434proxySettingsFileName 138435 ^'proxySettings'! ! 138436 138437!HTTPSocket class methodsFor: 'proxy settings' stamp: 'jm 9/15/97 12:06'! 138438proxyTestingComment 138439 "Test Kevin's SmartCache on this machine" 138440 " HTTPSocket useProxyServerNamed: '127.0.0.1' port: 8080. 138441 HTTPSocket httpShowPage: 'http://www.disneyblast.com/default.html'. 138442 HTTPSocket stopUsingProxyServer. " 138443 138444 "Test getting to outside world from DOL" 138445 " HTTPSocket useProxyServerNamed: 'web-proxy.online.disney.com' port: 8080. 138446 HTTPSocket httpShowPage: 'http://www.apple.com/default.html'. 138447 HTTPSocket stopUsingProxyServer. " 138448 138449 "Test Windows Machine in our cubicle at DOL" 138450 " HTTPSocket useProxyServerNamed: '206.18.67.150' port: 8080. 138451 HTTPSocket httpShowPage: 'http://kids.online.disney.com/~kevin/squeak/k:=t.morph'. 138452 HTTPSocket stopUsingProxyServer. " 138453 138454 " HTTPSocket httpShowPage: 'kids.online.disney.com/' " 138455 " HTTPSocket httpShowGif: 'kids.online.disney.com/~kevin/images/dlogo.gif' " 138456! ! 138457 138458!HTTPSocket class methodsFor: 'proxy settings' stamp: 'al 1/8/2004 12:27'! 138459proxyUser: userName password: password 138460 "Store HTTP 1.0 basic authentication credentials 138461 Note: this is an ugly hack that stores your password 138462 in your image. It's just enought to get you going 138463 if you use a firewall that requires authentication" 138464 138465 | stream encodedStream | 138466 stream := ReadWriteStream on: (String new: 16). 138467 stream nextPutAll: userName ,':' , password. 138468 encodedStream := Base64MimeConverter mimeEncode: stream. 138469 HTTPProxyCredentials := 'Proxy-Authorization: Basic ' , (encodedStream contents) , String crlf! ! 138470 138471!HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 7/30/1999 15:03'! 138472removeProxyException: domainName 138473 "Remove a (partial, wildcard) domain name from the list of proxy exceptions" 138474 138475 self httpProxyExceptions remove: domainName ifAbsent: []! ! 138476 138477!HTTPSocket class methodsFor: 'proxy settings' stamp: 'hpt 12/9/2004 22:55'! 138478stopUsingProxyServer 138479 "Stop directing HTTP request through a proxy server." 138480 138481 self httpProxyServer: nil. 138482 self httpProxyPort: 80. 138483 HTTPProxyCredentials := '' 138484! ! 138485 138486!HTTPSocket class methodsFor: 'proxy settings' stamp: 'md 8/29/2005 17:29'! 138487useProxyServerNamed: proxyServerName port: portNum 138488 "Direct all HTTP requests to the HTTP proxy server with the given name and port number." 138489 138490 proxyServerName ifNil: [ "clear proxy settings" 138491 self httpProxyServer: nil. 138492 self httpProxyPort: 80. 138493 ^ self]. 138494 138495 proxyServerName isString 138496 ifFalse: [self error: 'Server name must be a String or nil']. 138497 self httpProxyServer: proxyServerName. 138498 138499 self httpProxyPort: portNum. 138500 self httpProxyPort class == String ifTrue: [HTTPPort := portNum asNumber]. 138501 self httpProxyPort ifNil: [self httpProxyPort: self defaultPort].! ! 138502 138503!HTTPSocket class methodsFor: 'proxy settings' stamp: 'al 1/8/2004 12:54'! 138504useProxyServerNamed: proxyServerName port: portNum proxyUser: aString password: anotherString 138505 self useProxyServerNamed: proxyServerName port: portNum. 138506 self proxyUser: aString password: anotherString! ! 138507 138508 138509!HTTPSocket class methodsFor: 'utilities' stamp: 'PeterHugossonMiller 9/3/2009 01:44'! 138510argStringUnencoded: args 138511 "Return the args in a long string, as encoded in a url" 138512 138513 | argsString first | 138514 args isString ifTrue: ["sent in as a string, not a dictionary" 138515 ^ (args first = $? ifTrue: [''] ifFalse: ['?']), args]. 138516 argsString := String new writeStream. 138517 argsString nextPut: $?. 138518 first := true. 138519 args associationsDo: [ :assoc | 138520 assoc value do: [ :value | 138521 first ifTrue: [ first := false ] ifFalse: [ argsString nextPut: $& ]. 138522 argsString nextPutAll: assoc key. 138523 argsString nextPut: $=. 138524 argsString nextPutAll: value. ] ]. 138525 ^ argsString contents 138526! ! 138527 138528!HTTPSocket class methodsFor: 'utilities' stamp: 'PeterHugossonMiller 9/3/2009 01:44'! 138529argString: args 138530 "Return the args in a long string, as encoded in a url" 138531 138532 | argsString first | 138533 args isString ifTrue: ["sent in as a string, not a dictionary" 138534 ^ (args first = $? ifTrue: [''] ifFalse: ['?']), args]. 138535 argsString := String new writeStream. 138536 argsString nextPut: $?. 138537 first := true. 138538 args associationsDo: [ :assoc | 138539 assoc value do: [ :value | 138540 first ifTrue: [ first := false ] ifFalse: [ argsString nextPut: $& ]. 138541 argsString nextPutAll: assoc key encodeForHTTP. 138542 argsString nextPut: $=. 138543 argsString nextPutAll: value encodeForHTTP. ] ]. 138544 ^ argsString contents 138545! ! 138546 138547!HTTPSocket class methodsFor: 'utilities' stamp: 'tk 12/7/2001 12:24'! 138548expandUrl: newUrl ip: byteArrayIP port: portNum 138549 138550^ (newUrl beginsWith: '../') 138551 ifTrue: [ 138552 String streamContents: [:strm | 138553 byteArrayIP do: [:bb | bb printOn: strm. strm nextPut: $.]. 138554 strm skip: -1; nextPut: $:. 138555 portNum printOn: strm. 138556 strm nextPutAll: (newUrl allButFirst: 2)]] 138557 ifFalse: [newUrl]! ! 138558 138559!HTTPSocket class methodsFor: 'utilities' stamp: 'nice 4/28/2009 21:42'! 138560initHTTPSocket: httpUrl ifError: aBlock 138561 "Retrieve the server and port information from the URL, match it to the proxy settings and open a http socket for the request." 138562 138563 ^self initHTTPSocket: httpUrl timeoutSecs: self standardTimeout ifError: aBlock! ! 138564 138565!HTTPSocket class methodsFor: 'utilities' stamp: 'nice 4/29/2009 21:31'! 138566initHTTPSocket: httpUrl timeoutSecs: timeout ifError: aBlock 138567 "Retrieve the server and port information from the URL, match it to the proxy settings and open a http socket for the request." 138568 138569 | serverName port serverAddr s | 138570 Socket initializeNetwork. 138571 138572 serverName := httpUrl authority. 138573 port := httpUrl port ifNil: [self defaultPort]. 138574 138575 (self shouldUseProxy: serverName) ifTrue: [ 138576 serverName := self httpProxyServer. 138577 port := self httpProxyPort]. 138578 138579 "make the request" 138580 serverAddr := NetNameResolver addressForName: serverName timeout: 20. 138581 serverAddr ifNil: [ 138582 aBlock value: 'Error: Could not resolve the server named: ', serverName]. 138583 138584 s := HTTPSocket new. 138585 s connectTo: serverAddr port: port. 138586 (s waitForConnectionFor: timeout ifTimedOut: [false]) ifFalse: [ 138587 Socket deadServer: httpUrl authority. 138588 s destroy. 138589 ^aBlock value: 'Error: Server ',httpUrl authority,' is not responding']. 138590 ^s 138591! ! 138592 138593!HTTPSocket class methodsFor: 'utilities' stamp: 'rbb 2/18/2005 13:23'! 138594retry: tryBlock asking: troubleString ifGiveUp: abortActionBlock 138595 "Execute the given block. If it evaluates to true, return true. If it evaluates to false, prompt the user with the given string to see if he wants to try again. If not, evaluate the abortActionBlock and return false." 138596 138597 | response | 138598 [tryBlock value] whileFalse: [ 138599 | sema | 138600 sema := Semaphore new. 138601 WorldState addDeferredUIMessage: [ 138602 response := UIManager default chooseFrom: #('Retry' 'Give Up') 138603 title: troubleString. 138604 sema signal. 138605 ]. 138606 sema wait. 138607 response = 2 ifTrue: [abortActionBlock value. ^ false]]. 138608 ^ true 138609! ! 138610 138611!HTTPSocket class methodsFor: 'utilities' stamp: 'hpt 12/10/2004 23:21'! 138612shouldUseProxy: serverName 138613 "Retrieve the server and port information from the URL, match it to the proxy settings and open a http socket for the request." 138614 138615 self httpProxyServer ifNotEmpty: [ 138616 self httpProxyExceptions 138617 detect: [:domainName | domainName match: serverName] 138618 ifNone: [^true]]. 138619 ^false 138620! ! 138621 138622!HTTPSocket class methodsFor: 'utilities' stamp: 'alain.plantec 5/30/2008 13:33'! 138623showImage: image named: imageName 138624 HandMorph attach: (World drawingClass withForm: image)! ! 138625 138626!HTTPSocket class methodsFor: 'utilities' stamp: 'tak 9/25/2008 15:09'! 138627userAgentString 138628 "self userAgentString." 138629 138630 ^'User-Agent: ', 138631 SystemVersion current version, '-', 138632 SystemVersion current highestUpdate printString! ! 138633Morph subclass: #HaloMorph 138634 instanceVariableNames: 'target innerTarget positionOffset angleOffset growingOrRotating directionArrowAnchor haloBox simpleMode originalExtent' 138635 classVariableNames: '' 138636 poolDictionaries: '' 138637 category: 'Morphic-Widgets'! 138638!HaloMorph commentStamp: '<historical>' prior: 0! 138639This morph provides a halo of handles for its target morph. Dragging, duplicating, rotating, and resizing to be done by mousing down on the appropriate handle. There are also handles for help and for a menu of infrequently used operations.! 138640 138641 138642!HaloMorph methodsFor: 'accessing' stamp: 'gvc 3/17/2009 10:52'! 138643borderStyle 138644 "Answer the border style to use for the receiver. 138645 Depends on the target and preference." 138646 138647 ^(target notNil and: [Preferences showBoundsInHalo and: [target isWorldMorph not]]) 138648 ifTrue: [super borderStyle] 138649 ifFalse: [SimpleBorder width: 0 color: Color transparent]! ! 138650 138651!HaloMorph methodsFor: 'accessing' stamp: 'sw 1/26/2000 15:36'! 138652haloBox: aBox 138653 haloBox := aBox! ! 138654 138655!HaloMorph methodsFor: 'accessing' stamp: 'jm 5/22/1998 16:28'! 138656innerTarget 138657 138658 ^ innerTarget 138659! ! 138660 138661!HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:35'! 138662isMagicHalo 138663 ^self valueOfProperty: #isMagicHalo ifAbsent:[false].! ! 138664 138665!HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 15:37'! 138666isMagicHalo: aBool 138667 self setProperty: #isMagicHalo toValue: aBool. 138668 aBool ifFalse:[ 138669 "Reset everything" 138670 self stopStepping. "get rid of all" 138671 self startStepping. "only those of interest" 138672 ].! ! 138673 138674!HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:28'! 138675magicAlpha 138676 ^self valueOfProperty: #magicAlpha ifAbsent:[1.0]! ! 138677 138678!HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:42'! 138679magicAlpha: alpha 138680 self setProperty: #magicAlpha toValue: alpha. 138681 self changed.! ! 138682 138683!HaloMorph methodsFor: 'accessing' stamp: 'nk 6/12/2004 21:56'! 138684setTarget: aMorph 138685 "Private!! Set the target without adding handles." 138686 138687 target := aMorph topRendererOrSelf. 138688 innerTarget := target renderedMorph. 138689 innerTarget wantsDirectionHandles 138690 ifTrue: [self showDirectionHandles: true addHandles: false]. 138691 target hasHalo: true. 138692 138693! ! 138694 138695!HaloMorph methodsFor: 'accessing' stamp: 'jm 7/16/97 06:51'! 138696target 138697 138698 ^ target 138699! ! 138700 138701!HaloMorph methodsFor: 'accessing' stamp: 'jm 5/7/1998 15:42'! 138702target: aMorph 138703 138704 self setTarget: aMorph. 138705 target ifNotNil: [self addHandles]. 138706! ! 138707 138708!HaloMorph methodsFor: 'accessing' stamp: 'dgd 9/9/2004 22:55'! 138709wantsToBeTopmost 138710 "Answer if the receiver want to be one of the topmost objects in 138711 its owner" 138712 ^ true! ! 138713 138714 138715!HaloMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 17:37'! 138716veryDeepFixupWith: deepCopier 138717 "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 138718 138719super veryDeepFixupWith: deepCopier. 138720target := deepCopier references at: target ifAbsent: [target]. 138721innerTarget := deepCopier references at: innerTarget ifAbsent: [innerTarget]. 138722! ! 138723 138724!HaloMorph methodsFor: 'copying' stamp: 'st 9/14/2004 13:03'! 138725veryDeepInner: deepCopier 138726 "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." 138727 138728 super veryDeepInner: deepCopier. 138729 "target := target. Weakly copied" 138730 "innerTarget := innerTarget. Weakly copied" 138731 positionOffset := positionOffset veryDeepCopyWith: deepCopier. 138732 angleOffset := angleOffset veryDeepCopyWith: deepCopier. 138733 growingOrRotating := growingOrRotating veryDeepCopyWith: deepCopier. 138734 directionArrowAnchor := directionArrowAnchor. 138735 simpleMode := simpleMode. 138736 haloBox := haloBox. 138737 originalExtent := originalExtent 138738! ! 138739 138740 138741!HaloMorph methodsFor: 'drawing' stamp: 'ar 8/8/2001 15:13'! 138742drawSubmorphsOn: aCanvas 138743 | alpha | 138744 ((alpha := self magicAlpha) = 1.0) 138745 ifTrue:[^super drawSubmorphsOn: aCanvas]. 138746 ^super drawSubmorphsOn: (aCanvas asAlphaBlendingCanvas: alpha)! ! 138747 138748 138749!HaloMorph methodsFor: 'dropping/grabbing' stamp: 'stephane.ducasse 11/8/2008 19:38'! 138750startDrag: evt with: dragHandle 138751 "Drag my target without removing it from its owner." 138752 138753 self obtainHaloForEvent: evt andRemoveAllHandlesBut: dragHandle. 138754 positionOffset := dragHandle center - (target point: target position in: owner).! ! 138755 138756 138757!HaloMorph methodsFor: 'event handling' stamp: 'tk 7/14/2001 11:04'! 138758mouseMove: evt 138759 "Drag our target around" 138760 | thePoint | 138761 thePoint := target point: (evt position - positionOffset) from: owner. 138762 target setConstrainedPosition: thePoint hangOut: true.! ! 138763 138764!HaloMorph methodsFor: 'event handling' stamp: 'sw 5/21/1998 15:41'! 138765wantsKeyboardFocusFor: aSubmorph 138766 "to allow the name to be edited in the halo in the old tty way; when we morphic-text-ize the name editing, presumably this method should be removed" 138767 ^ true! ! 138768 138769 138770!HaloMorph methodsFor: 'events' stamp: 'tk 7/14/2001 11:04'! 138771dragTarget: event 138772 "Begin dragging the target" 138773 | thePoint | 138774 thePoint := target point: event position - positionOffset from: owner. 138775 target setConstrainedPosition: thePoint hangOut: true. 138776 event hand newMouseFocus: self.! ! 138777 138778!HaloMorph methodsFor: 'events' stamp: 'aoy 2/17/2003 01:27'! 138779popUpFor: aMorph event: evt 138780 "This message is sent by morphs that explicitly request the halo on a button click. Note: anEvent is in aMorphs coordinate frame." 138781 138782 | hand anEvent | 138783 self flag: #workAround. "We should really have some event/hand here..." 138784 anEvent := evt isNil 138785 ifTrue: 138786 [hand := aMorph world activeHand. 138787 hand ifNil: [hand := aMorph world primaryHand]. 138788 hand lastEvent transformedBy: (aMorph transformedFrom: nil)] 138789 ifFalse: 138790 [hand := evt hand. 138791 evt]. 138792 self target: aMorph. 138793 hand halo: self. 138794 hand world addMorphFront: self. 138795 positionOffset := anEvent position 138796 - (aMorph point: aMorph position in: owner). 138797 self startStepping. 138798 (Preferences haloTransitions or: [self isMagicHalo]) 138799 ifTrue: 138800 [self magicAlpha: 0.0. 138801 self startSteppingSelector: #fadeInInitially]! ! 138802 138803!HaloMorph methodsFor: 'events' stamp: 'ar 8/8/2001 15:50'! 138804popUpMagicallyFor: aMorph hand: aHand 138805 "Programatically pop up a halo for a given hand." 138806 Preferences magicHalos ifTrue:[ 138807 self isMagicHalo: true. 138808 self magicAlpha: 0.2]. 138809 self target: aMorph. 138810 aHand halo: self. 138811 aHand world addMorphFront: self. 138812 Preferences haloTransitions ifTrue:[ 138813 self magicAlpha: 0.0. 138814 self startSteppingSelector: #fadeInInitially. 138815 ]. 138816 positionOffset := aHand position - (aMorph point: aMorph position in: owner). 138817 self startStepping.! ! 138818 138819!HaloMorph methodsFor: 'events' stamp: 'ar 10/4/2000 19:26'! 138820staysUpWhenMouseIsDownIn: aMorph 138821 ^ ((aMorph == target) or: [aMorph hasOwner: self])! ! 138822 138823!HaloMorph methodsFor: 'events' stamp: 'ar 10/10/2000 19:09'! 138824transferHalo: event 138825 "Transfer the halo to the next likely recipient" 138826 target ifNil:[^self delete]. 138827 target transferHalo: (event transformedBy: (target transformedFrom: self)) from: target.! ! 138828 138829 138830!HaloMorph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 16:54'! 138831containsPoint: aPoint event: anEvent 138832 "Blue buttons are handled by the halo" 138833 (anEvent isMouse and:[anEvent isMouseDown and:[anEvent blueButtonPressed]]) 138834 ifFalse:[^super containsPoint: aPoint event: anEvent]. 138835 ^bounds containsPoint: anEvent position! ! 138836 138837!HaloMorph methodsFor: 'events-processing' stamp: 'nk 6/26/2002 07:19'! 138838handleListenEvent: anEvent 138839 "We listen for possible drop events here to add back those handles after a dup/grab operation" 138840 138841 (anEvent isMouse and:[anEvent isMove not]) ifFalse:[^ self]. "not interested" 138842 anEvent hand removeMouseListener: self. "done listening" 138843 (self world ifNil: [target world]) ifNil: [^ self]. 138844 self addHandles "and get those handles back"! ! 138845 138846!HaloMorph methodsFor: 'events-processing' stamp: 'ar 10/10/2000 22:00'! 138847rejectsEvent: anEvent 138848 "Return true to reject the given event. Rejecting an event means neither the receiver nor any of it's submorphs will be given any chance to handle it." 138849 (super rejectsEvent: anEvent) ifTrue:[^true]. 138850 anEvent isDropEvent ifTrue:[^true]. "never attempt to drop on halos" 138851 ^false! ! 138852 138853 138854!HaloMorph methodsFor: 'geometry' stamp: 'di 9/26/2000 21:03'! 138855position: pos 138856 "Halos display imprefectly if their coordinates are non-integral 138857 -- especially the direction handles." 138858 138859 ^ super position: pos asIntegerPoint! ! 138860 138861 138862!HaloMorph methodsFor: 'geometry testing' stamp: 'dgd 2/22/2003 13:46'! 138863containsPoint: aPoint 138864 "This method is overridden so that, once up, the handles will stay up as long as the mouse is within the box that encloses all the handles even if it is not over any handle or over its owner." 138865 138866 target isNil ifTrue: [^super containsPoint: aPoint] ifFalse: [^false]! ! 138867 138868 138869!HaloMorph methodsFor: 'halos and balloon help' stamp: 'nk 6/12/2004 09:34'! 138870addSimpleHandlesTo: aHaloMorph box: aBox 138871 | aHandle | 138872 simpleMode := true. 138873 138874 target isWorldMorph ifTrue: [^ self addSimpleHandlesForWorldHalos]. 138875 138876 self removeAllMorphs. "remove old handles, if any" 138877 138878 self bounds: target renderedMorph worldBoundsForHalo. "update my size" 138879 138880 self addHandleAt: (((aBox topLeft + aBox leftCenter) // 2) + self simpleFudgeOffset) color: Color paleBuff icon: 'Halo-MoreHandles' 138881 on: #mouseDown send: #addFullHandles to: self. 138882 138883 aHandle := self addGraphicalHandle: #Rotate at: aBox bottomLeft on: #mouseDown send: #startRot:with: to: self. 138884 aHandle on: #mouseMove send: #doRot:with: to: self. 138885 138886 target isFlexMorph 138887 ifTrue: [(self addGraphicalHandle: #Scale at: aBox bottomRight on: #mouseDown send: #startScale:with: to: self) 138888 on: #mouseMove send: #doScale:with: to: self] 138889 ifFalse: [(self addGraphicalHandle: #Scale at: aBox bottomRight on: #mouseDown send: #startGrow:with: to: self) 138890 on: #mouseMove send: #doGrow:with: to: self]. 138891 138892 innerTarget wantsSimpleSketchMorphHandles ifTrue: 138893 [self addSimpleSketchMorphHandlesInBox: aBox]. 138894 138895 growingOrRotating := false. 138896 self layoutChanged. 138897 self changed. 138898! ! 138899 138900 138901!HaloMorph methodsFor: 'handles' stamp: 'nk 6/12/2004 09:24'! 138902addChooseGraphicHandle: haloSpec 138903 "If the target is a sketch morph, and if the governing preference is set, add a halo handle allowing the user to select a new graphic" 138904 138905 (Preferences showChooseGraphicHaloHandle and: [innerTarget isSketchMorph]) ifTrue: 138906 [self addHandle: haloSpec 138907 on: #mouseDown send: #chooseNewGraphicFromHalo to: innerTarget] 138908! ! 138909 138910!HaloMorph methodsFor: 'handles' stamp: 'sw 12/13/2001 14:07'! 138911addCollapseHandle: handleSpec 138912 "Add the collapse handle, with all of its event handlers set up, unless the target's owner is not the world or the hand." 138913 138914 | collapseHandle | 138915 (target owner notNil "nil happens, amazingly" 138916 and: [target owner isWorldOrHandMorph]) 138917 ifFalse: [^ self]. 138918 collapseHandle := self addHandle: handleSpec 138919 on: #mouseDown send: #mouseDownInCollapseHandle:with: to: self. 138920 collapseHandle on: #mouseUp send: #maybeCollapse:with: to: self. 138921 collapseHandle on: #mouseMove send: #setDismissColor:with: to: self 138922! ! 138923 138924!HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 15:51'! 138925addDebugHandle: handleSpec 138926 Preferences debugHaloHandle ifTrue: 138927 [self addHandle: handleSpec 138928 on: #mouseDown send: #doDebug:with: to: self] 138929! ! 138930 138931!HaloMorph methodsFor: 'handles' stamp: 'sw 11/27/2001 11:18'! 138932addDismissHandle: handleSpec 138933 "Add the dismiss handle according to the spec, unless selectiveHalos is on and my target resists dismissal" 138934 138935 | dismissHandle | 138936 (target okayToAddDismissHandle or: [Preferences selectiveHalos not]) ifTrue: 138937 [dismissHandle := self addHandle: handleSpec 138938 on: #mouseDown send: #mouseDownInDimissHandle:with: to: self. 138939 dismissHandle on: #mouseUp send: #maybeDismiss:with: to: self. 138940 dismissHandle on: #mouseDown send: #setDismissColor:with: to: self. 138941 dismissHandle on: #mouseMove send: #setDismissColor:with: to: self] 138942! ! 138943 138944!HaloMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:48'! 138945addDragHandle: haloSpec 138946 (self addHandle: haloSpec on: #mouseDown send: #startDrag:with: to: self) 138947 on: #mouseMove send: #doDrag:with: to: self 138948 138949 138950! ! 138951 138952!HaloMorph methodsFor: 'handles' stamp: 'stephane.ducasse 11/8/2008 19:52'! 138953addDupHandle: haloSpec 138954 "Add the halo that offers duplication, or, when shift is down, make-sibling" 138955 138956 self addHandle: haloSpec on: #mouseDown send: #doDup:with: to: self 138957 138958! ! 138959 138960!HaloMorph methodsFor: 'handles' stamp: 'sw 1/28/2000 09:59'! 138961addFewerHandlesHandle: haloSpec 138962 self addHandle: haloSpec on: #mouseDown send: #addSimpleHandles to: self 138963! ! 138964 138965!HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13'! 138966addFontEmphHandle: haloSpec 138967 (innerTarget isTextMorph) 138968 ifTrue: 138969 [self 138970 addHandle: haloSpec 138971 on: #mouseDown 138972 send: #chooseEmphasisOrAlignment 138973 to: innerTarget]! ! 138974 138975!HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13'! 138976addFontSizeHandle: haloSpec 138977 (innerTarget isTextMorph) 138978 ifTrue: 138979 [self 138980 addHandle: haloSpec 138981 on: #mouseDown 138982 send: #chooseFont 138983 to: innerTarget]! ! 138984 138985!HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13'! 138986addFontStyleHandle: haloSpec 138987 (innerTarget isTextMorph) 138988 ifTrue: 138989 [self 138990 addHandle: haloSpec 138991 on: #mouseDown 138992 send: #chooseStyle 138993 to: innerTarget]! ! 138994 138995!HaloMorph methodsFor: 'handles' stamp: 'sw 10/27/2000 17:22'! 138996addGrabHandle: haloSpec 138997 "If appropriate, add the black halo handle for picking up the target" 138998 138999 innerTarget okayToAddGrabHandle ifTrue: 139000 [self addHandle: haloSpec on: #mouseDown send: #doGrab:with: to: self] 139001 139002! ! 139003 139004!HaloMorph methodsFor: 'handles' stamp: 'dgd 8/28/2004 18:13'! 139005addGrowHandle: haloSpec 139006 target isFlexMorph ifFalse: 139007 [(self addHandle: haloSpec 139008 on: #mouseDown send: #startGrow:with: to: self) 139009 on: #mouseMove send: #doGrow:with: to: self] 139010 "This or addScaleHandle:, but not both, will prevail at any one time" 139011! ! 139012 139013!HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 16:16'! 139014addHelpHandle: haloSpec 139015 target balloonText ifNotNil: 139016 [(self addHandle: haloSpec on: #mouseDown send: #mouseDownOnHelpHandle: to: innerTarget) 139017 on: #mouseUp send: #deleteBalloon to: innerTarget] 139018! ! 139019 139020!HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 16:05'! 139021addMenuHandle: haloSpec 139022 self addHandle: haloSpec on: #mouseDown send: #doMenu:with: to: self! ! 139023 139024!HaloMorph methodsFor: 'handles' stamp: 'RAA 3/15/2001 11:24'! 139025addRecolorHandle: haloSpec 139026 "Add a recolor handle to the receiver, if appropriate" 139027 139028 | recolorHandle | 139029 139030 "since this halo now opens a more general properties panel, allow it in all cases" 139031 "innerTarget canSetColor ifTrue:" 139032 139033 recolorHandle := self addHandle: haloSpec on: #mouseUp send: #doRecolor:with: to: self. 139034 recolorHandle on: #mouseUp send: #doRecolor:with: to: self 139035 139036! ! 139037 139038!HaloMorph methodsFor: 'handles' stamp: 'nk 6/12/2004 09:24'! 139039addRepaintHandle: haloSpec 139040 (innerTarget isSketchMorph) ifTrue: 139041 [self addHandle: haloSpec 139042 on: #mouseDown send: #editDrawing to: innerTarget] 139043! ! 139044 139045!HaloMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:49'! 139046addRotateHandle: haloSpec 139047 (self addHandle: haloSpec on: #mouseDown send: #startRot:with: to: self) 139048 on: #mouseMove send: #doRot:with: to: self 139049 139050! ! 139051 139052!HaloMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:49'! 139053addScaleHandle: haloSpec 139054 target isFlexMorph ifTrue: 139055 [(self addHandle: haloSpec 139056 on: #mouseDown send: #startScale:with: to: self) 139057 on: #mouseMove send: #doScale:with: to: self]. 139058 "This or addGrowHandle:, but not both, will prevail at any one time" 139059! ! 139060 139061!HaloMorph methodsFor: 'handles' stamp: 'ar 1/30/2001 23:32'! 139062positionIn: aBox horizontalPlacement: horiz verticalPlacement: vert 139063 | xCoord yCoord | 139064 139065 horiz == #left 139066 ifTrue: [xCoord := aBox left]. 139067 horiz == #leftCenter 139068 ifTrue: [xCoord := aBox left + (aBox width // 4)]. 139069 horiz == #center 139070 ifTrue: [xCoord := (aBox left + aBox right) // 2]. 139071 horiz == #rightCenter 139072 ifTrue: [xCoord := aBox left + ((3 * aBox width) // 4)]. 139073 horiz == #right 139074 ifTrue: [xCoord := aBox right]. 139075 139076 vert == #top 139077 ifTrue: [yCoord := aBox top]. 139078 vert == #topCenter 139079 ifTrue: [yCoord := aBox top + (aBox height // 4)]. 139080 vert == #center 139081 ifTrue: [yCoord := (aBox top + aBox bottom) // 2]. 139082 vert == #bottomCenter 139083 ifTrue: [yCoord := aBox top + ((3 * aBox height) // 4)]. 139084 vert == #bottom 139085 ifTrue: [yCoord := aBox bottom]. 139086 139087 ^ xCoord asInteger @ yCoord asInteger! ! 139088 139089 139090!HaloMorph methodsFor: 'initialization' stamp: 'sw 10/2/2001 21:20'! 139091acceptNameEdit 139092 "If the name is currently under edit, accept the changes" 139093 139094 | label | 139095 (label := self findA: NameStringInHalo) ifNotNil: 139096 [label hasFocus ifTrue: 139097 [label lostFocusWithoutAccepting]]! ! 139098 139099!HaloMorph methodsFor: 'initialization' stamp: 'gvc 3/17/2009 10:42'! 139100defaultColor 139101 "Answer the default color/fill style for the receiver." 139102 139103 ^Color transparent! ! 139104 139105!HaloMorph methodsFor: 'initialization' stamp: 'gvc 3/17/2009 10:55'! 139106initialize 139107 "initialize the state of the receiver" 139108 super initialize. 139109 "" 139110 growingOrRotating := false. 139111 simpleMode := Preferences simpleHalosInForce. 139112 self borderStyle: (SimpleBorder 139113 width: 2 139114 color: (Preferences menuSelectionColor ifNil: [Color blue]))! ! 139115 139116 139117!HaloMorph methodsFor: 'menu' stamp: 'dgd 9/20/2004 19:35'! 139118wantsYellowButtonMenu 139119 "Answer true if the receiver wants a yellow button menu" 139120 ^ false! ! 139121 139122 139123!HaloMorph methodsFor: 'meta-actions' stamp: 'jcg 9/21/2001 13:18'! 139124blueButtonDown: event 139125 "Transfer the halo to the next likely recipient" 139126 target ifNil:[^self delete]. 139127 event hand obtainHalo: self. 139128 positionOffset := event position - (target point: target position in: owner). 139129 self isMagicHalo ifTrue:[ 139130 self isMagicHalo: false. 139131 ^self magicAlpha: 1.0]. 139132 "wait for drags or transfer" 139133 event hand 139134 waitForClicksOrDrag: self 139135 event: event 139136 selectors: { #transferHalo:. nil. nil. #dragTarget:. } 139137 threshold: 5.! ! 139138 139139!HaloMorph methodsFor: 'meta-actions' stamp: 'ar 9/15/2000 16:42'! 139140handlerForBlueButtonDown: anEvent 139141 "Blue button was clicked within the receiver" 139142 ^self! ! 139143 139144 139145!HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 14:56'! 139146fadeIn 139147 self magicAlpha >= 1.0 ifTrue:[self stopSteppingSelector: #fadeIn]. 139148 self magicAlpha: ((self magicAlpha + 0.1) min: 1.0) 139149! ! 139150 139151!HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 15:44'! 139152fadeInInitially 139153 | max | 139154 max := self isMagicHalo ifTrue:[0.3] ifFalse:[1.0]. 139155 self magicAlpha >= max ifTrue:[self stopSteppingSelector: #fadeInInitially]. 139156 self magicAlpha: ((self magicAlpha + (max * 0.1)) min: max) 139157! ! 139158 139159!HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 14:57'! 139160fadeOut 139161 self magicAlpha <= 0.3 ifTrue:[self stopSteppingSelector: #fadeOut]. 139162 self magicAlpha: ((self magicAlpha - 0.1) max: 0.3) 139163! ! 139164 139165!HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 15:46'! 139166fadeOutFinally 139167 self magicAlpha <= 0.05 ifTrue:[^super delete]. 139168 self magicAlpha <= 0.3 ifTrue:[ 139169 ^self magicAlpha: (self magicAlpha - 0.03 max: 0.0)]. 139170 self magicAlpha: ((self magicAlpha * 0.5) max: 0.0) 139171! ! 139172 139173!HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 15:38'! 139174handleEntered 139175 self isMagicHalo ifFalse:[^self]. 139176 self stopStepping; startStepping. 139177 self startSteppingSelector: #fadeIn. 139178! ! 139179 139180!HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 15:38'! 139181handleLeft 139182 self isMagicHalo ifFalse:[^self]. 139183 self stopStepping; startStepping. 139184 self startSteppingSelector: #fadeOut.! ! 139185 139186!HaloMorph methodsFor: 'stepping' stamp: 'nk 6/27/2003 12:28'! 139187localHaloBoundsFor: aMorph 139188 139189 "aMorph may be in the hand and perhaps not in our world" 139190 139191 | r | 139192 139193 r := aMorph worldBoundsForHalo truncated. 139194 aMorph world = self world ifFalse: [^r]. 139195 ^((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated! ! 139196 139197!HaloMorph methodsFor: 'stepping' stamp: 'nk 6/27/2003 12:32'! 139198step 139199 | newBounds | 139200 target 139201 ifNil: [^ self]. 139202 newBounds := target isWorldMorph 139203 ifTrue: [target bounds] 139204 ifFalse: [self localHaloBoundsFor: target renderedMorph]. 139205 newBounds = self bounds 139206 ifTrue: [^ self]. 139207 newBounds extent = self bounds extent 139208 ifTrue: [^ self position: newBounds origin]. 139209 growingOrRotating 139210 ifFalse: [submorphs size > 1 139211 ifTrue: [self addHandles]]. 139212 "adjust halo bounds if appropriate" 139213 self bounds: newBounds! ! 139214 139215 139216!HaloMorph methodsFor: 'submorphs-add/remove' stamp: 'marcus.denker 11/21/2008 22:09'! 139217delete 139218 "Delete the halo. Tell the target that it no longer has the halo; accept any pending edits to the name; and then actually delete myself" 139219 139220 target ifNotNil: [target hasHalo: false]. 139221 self acceptNameEdit. 139222 self isMagicHalo: false. 139223 super delete.! ! 139224 139225 139226!HaloMorph methodsFor: 'testing' stamp: 'jm 7/16/97 06:54'! 139227stepTime 139228 139229 ^ 0 "every cycle" 139230! ! 139231 139232 139233!HaloMorph methodsFor: 'updating' stamp: 'di 11/17/2001 10:56'! 139234changed 139235 "Quicker to invalidate handles individually if target is large (especially the world)" 139236 139237 self extent > (200@200) 139238 ifTrue: [(target notNil and: [target ~~ self world]) ifTrue: 139239 ["Invalidate 4 outer strips first, thus subsuming separate damage." 139240 (self fullBounds areasOutside: target bounds) do: 139241 [:r | self invalidRect: r]]. 139242 self submorphsDo: [:m | m changed]] 139243 ifFalse: [super changed]. 139244! ! 139245 139246 139247!HaloMorph methodsFor: 'wiw support' stamp: 'RAA 6/27/2000 19:12'! 139248morphicLayerNumber 139249 139250 "helpful for insuring some morphs always appear in front of or behind others. 139251 smaller numbers are in front" 139252 139253 ^7 "Halos are very front-like things"! ! 139254 139255 139256!HaloMorph methodsFor: 'private' stamp: 'sw 4/27/2000 13:39'! 139257addCircleHandles 139258 | box | 139259 simpleMode := false. 139260 target isWorldMorph ifTrue: [^ self addHandlesForWorldHalos]. 139261 139262 self removeAllMorphs. "remove old handles, if any" 139263 self bounds: target renderedMorph worldBoundsForHalo. "update my size" 139264 box := self basicBox. 139265 139266 target addHandlesTo: self box: box. 139267 139268 self addName. 139269 growingOrRotating := false. 139270 self layoutChanged. 139271 self changed. 139272! ! 139273 139274!HaloMorph methodsFor: 'private' stamp: 'dgd 4/4/2006 16:56'! 139275addDirectionHandles 139276 139277 | centerHandle d w directionShaft patch patchColor crossHairColor | 139278 self showingDirectionHandles ifFalse: [^ self]. 139279 139280 directionArrowAnchor := (target point: target referencePosition in: self world) rounded. 139281 patch := target imageFormForRectangle: (Rectangle center: directionArrowAnchor extent: 3@3). 139282 patchColor := patch colorAt: 1@1. 139283 139284 (directionShaft := LineMorph newSticky makeForwardArrow) 139285 borderWidth: 2; borderColor: (Color green orColorUnlike: patchColor). 139286 self positionDirectionShaft: directionShaft. 139287 self addMorphFront: directionShaft. 139288 directionShaft setCenteredBalloonText: 'Set forward direction' translated; 139289 on: #mouseDown send: #doDirection:with: to: self; 139290 on: #mouseMove send: #trackDirectionArrow:with: to: self; 139291 on: #mouseUp send: #setDirection:with: to: self. 139292 139293 d := 15. "diameter" w := 3. "borderWidth" 139294 crossHairColor := Color red orColorUnlike: patchColor. 139295 (centerHandle := EllipseMorph newBounds: (0@0 extent: d@d) color: Color transparent) 139296 borderWidth: w; borderColor: (Color blue orColorUnlike: patchColor); 139297 addMorph: (LineMorph from: (d//2)@w to: (d//2)@(d-w-1) color: crossHairColor width: 1) lock; 139298 addMorph: (LineMorph from: w@(d//2) to: (d-w-1)@(d//2) color: crossHairColor width: 1) lock; 139299 align: centerHandle bounds center with: directionArrowAnchor. 139300 centerHandle wantsYellowButtonMenu: false. 139301 self addMorph: centerHandle. 139302 centerHandle setCenteredBalloonText: 'Rotation center (hold down the shift key and drag from here to change it)' translated; 139303 on: #mouseDown send: #prepareToTrackCenterOfRotation:with: to: self; 139304 on: #mouseMove send: #trackCenterOfRotation:with: to: self; 139305 on: #mouseUp send: #setCenterOfRotation:with: to: self 139306! ! 139307 139308!HaloMorph methodsFor: 'private' stamp: 'sw 10/29/1999 15:31'! 139309addFullHandles 139310 "Later, obey a preference to choose between circle-iconic and solid-circles" 139311 self addCircleHandles! ! 139312 139313!HaloMorph methodsFor: 'private' stamp: 'dgd 9/18/2004 18:23'! 139314addGraphicalHandleFrom: formKey at: aPoint 139315 "Add the supplied form as a graphical handle centered at the given point. Return the handle." 139316 | handle aForm | 139317 aForm := (ScriptingSystem formAtKey: formKey) ifNil: [ScriptingSystem formAtKey: #SolidMenu]. 139318 handle := ImageMorph new image: aForm; bounds: (Rectangle center: aPoint extent: aForm extent). 139319 handle wantsYellowButtonMenu: false. 139320 self addMorph: handle. 139321 handle on: #mouseUp send: #endInteraction to: self. 139322 ^ handle 139323! ! 139324 139325!HaloMorph methodsFor: 'private' stamp: 'dgd 8/28/2003 15:15'! 139326addGraphicalHandle: formKey at: aPoint on: eventName send: selector to: recipient 139327 "Add the supplied form as a graphical handle centered at the given point, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." 139328 | handle | 139329 handle := self addGraphicalHandleFrom: formKey at: aPoint. 139330 handle on: eventName send: selector to: recipient. 139331 handle setBalloonText: (target balloonHelpTextForHandle: handle) translated. 139332 ^ handle 139333! ! 139334 139335!HaloMorph methodsFor: 'private' stamp: 'dgd 9/26/2004 19:39'! 139336addHandleAt: aPoint color: aColor icon: iconName on: eventName send: selector to: recipient 139337 "Add a handle centered at the given point with the given color, 139338 and set it up to respond to the given event by sending the 139339 given selector to the given recipient. Return the handle." 139340 | handle | 139341 handle := self createHandleAt: aPoint color: aColor iconName: iconName. 139342 self addMorph: handle. 139343 139344 handle on: #mouseUp send: #endInteraction to: self. 139345 handle on: eventName send: selector to: recipient. 139346 handle setBalloonText: (target balloonHelpTextForHandle: handle) translated. 139347 139348 ^ handle ! ! 139349 139350!HaloMorph methodsFor: 'private' stamp: 'sw 1/29/2000 18:36'! 139351addHandleAt: aPoint color: aColor on: eventName send: selector to: recipient 139352 ^ self addHandleAt: aPoint color: aColor icon: nil on: eventName send: selector to: recipient 139353! ! 139354 139355!HaloMorph methodsFor: 'private' stamp: 'sw 1/28/2000 09:57'! 139356addHandles 139357 simpleMode == true 139358 ifTrue: 139359 [self addSimpleHandles] 139360 ifFalse: 139361 [self addCircleHandles] 139362! ! 139363 139364!HaloMorph methodsFor: 'private' stamp: 'ar 10/4/2000 16:27'! 139365addHandlesForWorldHalos 139366 "Add handles for world halos, like the man said" 139367 139368 | box w | 139369 w := self world ifNil:[target world]. 139370 self removeAllMorphs. "remove old handles, if any" 139371 self bounds: target bounds. 139372 box := w bounds insetBy: 9. 139373 target addWorldHandlesTo: self box: box. 139374 139375 Preferences uniqueNamesInHalos ifTrue: 139376 [innerTarget assureExternalName]. 139377 self addNameBeneath: (box insetBy: (0@0 corner: 0@10)) string: innerTarget externalName. 139378 growingOrRotating := false. 139379 self layoutChanged. 139380 self changed. 139381! ! 139382 139383!HaloMorph methodsFor: 'private' stamp: 'dgd 9/26/2004 19:37'! 139384addHandle: handleSpec on: eventName send: selector to: recipient 139385 "Add a handle within the halo box as per the haloSpec, and set 139386 it up to respond to the given event by sending the given 139387 selector to the given recipient. Return the handle." 139388 | handle aPoint | 139389 139390 aPoint := self 139391 positionIn: haloBox 139392 horizontalPlacement: handleSpec horizontalPlacement 139393 verticalPlacement: handleSpec verticalPlacement. 139394 139395 handle := self 139396 addHandleAt: aPoint 139397 color: (Color colorFrom: handleSpec color) 139398 icon: handleSpec iconSymbol 139399 on: eventName 139400 send: selector 139401 to: recipient. 139402 139403 self isMagicHalo 139404 ifTrue: [ 139405 handle on: #mouseEnter send: #handleEntered to: self. 139406 handle on: #mouseLeave send: #handleLeft to: self]. 139407 139408 ^ handle! ! 139409 139410!HaloMorph methodsFor: 'private' stamp: 'sw 8/16/2000 17:41'! 139411addName 139412 "Add a name readout at the bottom of the halo." 139413 139414 Preferences uniqueNamesInHalos ifTrue: 139415 [target assureExternalName]. 139416 139417 self addNameBeneath: self basicBox string: target externalName 139418! ! 139419 139420!HaloMorph methodsFor: 'private' stamp: 'stephane.ducasse 11/29/2008 16:32'! 139421addNameBeneath: outerRectangle string: aString 139422 "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." 139423 139424 | nameMorph namePosition w | 139425 w := self world ifNil:[target world]. 139426 nameMorph := NameStringInHalo contents: aString font: Preferences standardHaloLabelFont. 139427 nameMorph wantsYellowButtonMenu: false. 139428 nameMorph color: Color black. 139429 nameMorph useStringFormat; target: innerTarget; putSelector: #renameTo:. 139430 namePosition := outerRectangle bottomCenter - 139431 ((nameMorph width // 2) @ (self handleSize negated // 2 - 1)). 139432 nameMorph position: (namePosition min: w viewBox bottomRight - nameMorph extent y + 2). 139433 nameMorph balloonTextSelector: #objectNameInHalo. 139434 self addMorph: nameMorph. 139435 ^ nameMorph! ! 139436 139437!HaloMorph methodsFor: 'private' stamp: 'sw 4/27/2000 13:40'! 139438addSimpleHandles 139439 target isWorldMorph ifTrue: [^ self addHandlesForWorldHalos]. 139440 self removeAllMorphs. "remove old handles, if any" 139441 self bounds: target renderedMorph worldBoundsForHalo. "update my size" 139442 self innerTarget addSimpleHandlesTo: self box: self basicBoxForSimpleHalos 139443 139444! ! 139445 139446!HaloMorph methodsFor: 'private' stamp: 'sw 10/28/1999 15:39'! 139447addSimpleHandlesForWorldHalos 139448 "Nothing special at present here -- just use the regular handles. Cannot rotate or resize world" 139449 139450 self addHandlesForWorldHalos 139451! ! 139452 139453!HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 17:37'! 139454addSimpleSketchMorphHandlesInBox: box 139455 139456 self addGraphicalHandle: #PaintTab at: box bottomCenter on: #mouseDown send: #editDrawing to: self innerTarget. 139457 139458 self addDirectionHandles! ! 139459 139460!HaloMorph methodsFor: 'private' stamp: 'ar 10/7/2000 23:36'! 139461basicBox 139462 | aBox minSide anExtent w | 139463 minSide := 4 * self handleSize. 139464 anExtent := ((self width + self handleSize + 8) max: minSide) @ 139465 ((self height + self handleSize + 8) max: minSide). 139466 aBox := Rectangle center: self center extent: anExtent. 139467 w := self world ifNil:[target outermostWorldMorph]. 139468 ^ w 139469 ifNil: 139470 [aBox] 139471 ifNotNil: 139472 [aBox intersect: (w viewBox insetBy: 8@8)] 139473! ! 139474 139475!HaloMorph methodsFor: 'private' stamp: 'ar 10/7/2000 23:36'! 139476basicBoxForSimpleHalos 139477 | w | 139478 w := self world ifNil:[target outermostWorldMorph]. 139479 ^ (target topRendererOrSelf worldBoundsForHalo expandBy: self handleAllowanceForIconicHalos) 139480 intersect: (w bounds insetBy: 8@8) 139481! ! 139482 139483!HaloMorph methodsFor: 'private' stamp: 'dgd 9/29/2004 19:51'! 139484createHandleAt: aPoint color: aColor iconName: iconName 139485 | bou handle | 139486 bou := Rectangle center: aPoint extent: self handleSize asPoint. 139487 Preferences alternateHandlesLook 139488 ifTrue: [ 139489 handle := RectangleMorph newBounds: bou color: aColor. 139490 handle borderWidth: 1. 139491 handle useRoundedCorners. 139492 self setColor: aColor toHandle: handle] 139493 ifFalse: [handle := EllipseMorph newBounds: bou color: aColor]. 139494 "" 139495 handle borderColor: aColor muchDarker. 139496 handle wantsYellowButtonMenu: false. 139497 "" 139498 iconName isNil 139499 ifFalse: [| form | 139500 form := ScriptingSystem formAtKey: iconName. 139501 form isNil 139502 ifFalse: [| image | 139503 image := ImageMorph new. 139504 image image: form. 139505 image color: aColor makeForegroundColor. 139506 image lock. 139507 handle addMorphCentered: image]]. 139508 "" 139509 ^ handle! ! 139510 139511!HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:16'! 139512directionArrowLength 139513 ^ 25! ! 139514 139515!HaloMorph methodsFor: 'private' stamp: 'sw 10/27/2002 09:27'! 139516doDebug: evt with: menuHandle 139517 "Ask hand to invoke the a debugging menu for my inner target. If shift key is down, immediately put up an inspector on the inner target" 139518 139519 | menu | 139520 self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil. 139521 self world displayWorld. 139522 evt shiftPressed ifTrue: 139523 [self delete. 139524 ^ innerTarget inspectInMorphic: evt]. 139525 139526 menu := innerTarget buildDebugMenu: evt hand. 139527 menu addTitle: (innerTarget externalName truncateWithElipsisTo: 40). 139528 menu popUpEvent: evt in: self world! ! 139529 139530!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:41'! 139531doDirection: anEvent with: directionHandle 139532 anEvent hand obtainHalo: self. 139533 self removeAllHandlesBut: directionHandle! ! 139534 139535!HaloMorph methodsFor: 'private' stamp: 'tk 7/14/2001 11:04'! 139536doDrag: evt with: dragHandle 139537 | thePoint | 139538 evt hand obtainHalo: self. 139539 thePoint := target point: evt position - positionOffset from: owner. 139540 target setConstrainedPosition:(target griddedPoint: thePoint) hangOut: true. 139541! ! 139542 139543!HaloMorph methodsFor: 'private' stamp: 'jcg 5/30/2002 09:12'! 139544doDup: evt with: dupHandle 139545 "Ask hand to duplicate my target." 139546 139547 (target isKindOf: SelectionMorph) ifTrue: 139548 [^ target doDup: evt fromHalo: self handle: dupHandle]. 139549 139550 self obtainHaloForEvent: evt andRemoveAllHandlesBut: dupHandle. 139551 self setTarget: (target duplicateMorph: evt). 139552 evt hand grabMorph: target. 139553 self step. "update position if necessary" 139554 evt hand addMouseListener: self. "Listen for the drop"! ! 139555 139556!HaloMorph methodsFor: 'private' stamp: 'sw 10/2/2001 22:35'! 139557doGrab: evt with: grabHandle 139558 "Ask hand to grab my target." 139559 139560 self obtainHaloForEvent: evt andRemoveAllHandlesBut: grabHandle. 139561 evt hand grabMorph: target. 139562 self step. "update position if necessary" 139563 evt hand addMouseListener: self. "Listen for the drop"! ! 139564 139565!HaloMorph methodsFor: 'private' stamp: 'marcus.denker 11/10/2008 10:04'! 139566doGrow: evt with: growHandle 139567 "Called while the mouse is down in the grow handle" 139568 139569 | newExtent extentToUse scale | 139570 evt hand obtainHalo: self. 139571 newExtent := (target pointFromWorld: (target griddedPoint: evt cursorPoint - positionOffset)) 139572 - target topLeft. 139573 evt shiftPressed ifTrue: [ 139574 scale := (newExtent x / (originalExtent x max: 1)) min: 139575 (newExtent y / (originalExtent y max: 1)). 139576 newExtent := (originalExtent x * scale) asInteger @ (originalExtent y * scale) asInteger 139577 ]. 139578 (newExtent x < 1 or: [newExtent y < 1 ]) ifTrue: [^ self]. 139579 target renderedMorph setExtentFromHalo: (extentToUse := newExtent). 139580 growHandle position: evt cursorPoint - (growHandle extent // 2). 139581 self layoutChanged. 139582 (self valueOfProperty: #commandInProgress) ifNotNil: 139583 [:cmd | "Update the final extent" 139584 cmd redoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: extentToUse] 139585! ! 139586 139587!HaloMorph methodsFor: 'private' stamp: 'ar 11/29/2001 20:01'! 139588doMenu: evt with: menuHandle 139589 "Ask hand to invoke the halo menu for my inner target." 139590 139591 | menu | 139592 self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil. 139593 self world displayWorld. 139594 menu := innerTarget buildHandleMenu: evt hand. 139595 innerTarget addTitleForHaloMenu: menu. 139596 menu popUpEvent: evt in: self world. 139597! ! 139598 139599!HaloMorph methodsFor: 'private' stamp: 'marcus.denker 11/20/2008 12:24'! 139600doRecolor: evt with: aHandle 139601 "The mouse went down in the 'recolor' halo handle. Allow the user to change the color of the innerTarget" 139602 139603 evt hand obtainHalo: self. 139604 (aHandle containsPoint: evt cursorPoint) 139605 ifFalse: "only do it if mouse still in handle on mouse up" 139606 [self delete. 139607 target addHalo: evt] 139608 ifTrue: [innerTarget changeColor]. 139609 self showingDirectionHandles ifTrue: [self addHandles]! ! 139610 139611!HaloMorph methodsFor: 'private' stamp: 'marcus.denker 11/10/2008 10:04'! 139612doRot: evt with: rotHandle 139613 "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." 139614 139615 | degrees | 139616 evt hand obtainHalo: self. 139617 degrees := (evt cursorPoint - (target pointInWorld: target referencePosition)) degrees. 139618 degrees := degrees - angleOffset degrees. 139619 degrees := degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false. 139620 degrees = 0.0 139621 ifTrue: [self setColor: Color lightBlue toHandle: rotHandle] 139622 ifFalse: [self setColor: Color blue toHandle: rotHandle]. 139623 rotHandle submorphsDo: 139624 [:m | m color: rotHandle color makeForegroundColor]. 139625 self removeAllHandlesBut: rotHandle. 139626 self showingDirectionHandles ifFalse: 139627 [self showDirectionHandles: true addHandles: false]. 139628 self addDirectionHandles. 139629 139630 target rotationDegrees: degrees. 139631 139632 rotHandle position: evt cursorPoint - (rotHandle extent // 2). 139633 (self valueOfProperty: #commandInProgress) ifNotNil: 139634 [:cmd | "Update the final rotation" 139635 cmd redoTarget: target renderedMorph selector: #heading: argument: degrees]. 139636 self layoutChanged! ! 139637 139638!HaloMorph methodsFor: 'private' stamp: 'marcus.denker 11/10/2008 10:04'! 139639doScale: evt with: scaleHandle 139640 "Update the scale of my target if it is scalable." 139641 | newHandlePos colorToUse | 139642 evt hand obtainHalo: self. 139643 newHandlePos := evt cursorPoint - (scaleHandle extent // 2). 139644 target scaleToMatch: newHandlePos. 139645 colorToUse := target scale = 1.0 139646 ifTrue: [Color yellow] 139647 ifFalse: [Color orange]. 139648 self setColor: colorToUse toHandle: scaleHandle. 139649 scaleHandle 139650 submorphsDo: [:m | m color: colorToUse makeForegroundColor]. 139651 scaleHandle position: newHandlePos. 139652 self layoutChanged. 139653 139654 (self valueOfProperty: #commandInProgress) ifNotNil:[:cmd | 139655 "Update the final extent" 139656 cmd redoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: target extent 139657 ]. 139658! ! 139659 139660!HaloMorph methodsFor: 'private' stamp: 'marcus.denker 11/10/2008 10:04'! 139661endInteraction 139662 "Clean up after a user interaction with the a halo control" 139663 139664 | m | 139665 self isMagicHalo: false. "no longer" 139666 self magicAlpha: 1.0. 139667 (target isInWorld not or: [owner isNil]) ifTrue: [^self]. 139668 [target isFlexMorph and: [target hasNoScaleOrRotation]] whileTrue: 139669 [m := target firstSubmorph. 139670 target removeFlexShell. 139671 target := m]. 139672 self isInWorld 139673 ifTrue: 139674 ["make sure handles show in front, even if flex shell added" 139675 139676 self comeToFront. 139677 self addHandles]. 139678 (self valueOfProperty: #commandInProgress) ifNotNil: 139679 [:cmd | 139680 self rememberCommand: cmd. 139681 self removeProperty: #commandInProgress]! ! 139682 139683!HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 18:42'! 139684handleAllowanceForIconicHalos 139685 ^ 12! ! 139686 139687!HaloMorph methodsFor: 'private' stamp: 'dgd 5/17/2004 20:18'! 139688handleSize 139689 ^ Preferences biggerHandles 139690 ifTrue: [20] 139691 ifFalse: [16]! ! 139692 139693!HaloMorph methodsFor: 'private' stamp: 'aoy 2/15/2003 21:10'! 139694maybeCollapse: evt with: collapseHandle 139695 "Ask hand to collapse my target if mouse comes up in it." 139696 139697 evt hand obtainHalo: self. 139698 self delete. 139699 (collapseHandle containsPoint: evt cursorPoint) 139700 ifFalse: 139701 [ 139702 target addHalo: evt] 139703 ifTrue: 139704 [ 139705 target collapse]! ! 139706 139707!HaloMorph methodsFor: 'private' stamp: 'alain.plantec 2/6/2009 11:05'! 139708maybeDismiss: evt with: dismissHandle 139709 "Ask hand to dismiss my target if mouse comes up 139710 in it." 139711 evt hand obtainHalo: self. 139712 (dismissHandle containsPoint: evt cursorPoint) 139713 ifTrue: [target resistsRemoval 139714 ifTrue: [(self confirm: 'Really throw this away ?' translated) 139715 ifFalse: [^ self]]. 139716 evt hand removeHalo. 139717 self delete. 139718 target dismissViaHalo] 139719 ifFalse: [self delete. 139720 target addHalo: evt]! ! 139721 139722!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:42'! 139723maybeDoDup: evt with: dupHandle 139724 evt hand obtainHalo: self. 139725 ^ target okayToDuplicate ifTrue: 139726 [self doDup: evt with: dupHandle]! ! 139727 139728!HaloMorph methodsFor: 'private' stamp: 'sw 10/3/2001 00:21'! 139729mouseDownInCollapseHandle: evt with: collapseHandle 139730 "The mouse went down in the collapse handle; collapse the morph" 139731 139732 self obtainHaloForEvent: evt andRemoveAllHandlesBut: collapseHandle. 139733 self setDismissColor: evt with: collapseHandle! ! 139734 139735!HaloMorph methodsFor: 'private' stamp: 'adrian_lienhard 7/19/2009 17:34'! 139736mouseDownInDimissHandle: evt with: dismissHandle 139737 evt hand obtainHalo: self. 139738 self removeAllHandlesBut: dismissHandle. 139739 self setColor: Color darkGray toHandle: dismissHandle. 139740! ! 139741 139742!HaloMorph methodsFor: 'private' stamp: 'sw 10/2/2001 22:16'! 139743obtainHaloForEvent: evt andRemoveAllHandlesBut: aHandle 139744 "Make sure the event's hand correlates with the receiver, and remove all handles except the given one. If nil is provided as the handles argument, the result is that all handles are removed. Note that any pending edits to the name-string in the halo are accepted at this time." 139745 139746 evt hand obtainHalo: self. 139747 self acceptNameEdit. 139748 self removeAllHandlesBut: aHandle! ! 139749 139750!HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:12'! 139751positionDirectionShaft: shaft 139752 "Position the shaft." 139753 | alphaRadians unitVector | 139754 "Pretty crude and slow approach at present, but a stake in the ground" 139755 alphaRadians := target heading degreesToRadians. 139756 unitVector := alphaRadians sin @ alphaRadians cos negated. 139757 shaft setVertices: {unitVector * 6 + directionArrowAnchor. "6 = radius of deadeye circle" 139758 unitVector * self directionArrowLength + directionArrowAnchor} 139759! ! 139760 139761!HaloMorph methodsFor: 'private' stamp: 'ar 10/8/2001 14:35'! 139762prepareToTrackCenterOfRotation: evt with: rotationHandle 139763 evt hand obtainHalo: self. 139764 evt shiftPressed ifTrue:[ 139765 self removeAllHandlesBut: rotationHandle. 139766 ] ifFalse:[ 139767 rotationHandle setProperty: #dragByCenterOfRotation toValue: true. 139768 self startDrag: evt with: rotationHandle 139769 ]. 139770 evt hand showTemporaryCursor: Cursor blank! ! 139771 139772!HaloMorph methodsFor: 'private' stamp: 'dgd 9/10/2004 13:38'! 139773removeAllHandlesBut: h 139774 "Remove all handles except h." 139775 (Preferences maintainHalos and:[h isNil]) 139776 ifTrue:[self removeHalo] 139777 ifFalse:[ 139778 submorphs copy do: 139779 [:m | m == h ifFalse: [m delete]] 139780 ]. 139781! ! 139782 139783!HaloMorph methodsFor: 'private' stamp: 'ar 10/8/2001 14:33'! 139784setCenterOfRotation: evt with: rotationHandle 139785 | localPt | 139786 evt hand obtainHalo: self. 139787 evt hand showTemporaryCursor: nil. 139788 (rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[ 139789 localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center. 139790 innerTarget setRotationCenterFrom: localPt. 139791 ]. 139792 rotationHandle removeProperty: #dragByCenterOfRotation. 139793 self endInteraction 139794! ! 139795 139796!HaloMorph methodsFor: 'private' stamp: 'dgd 9/29/2004 19:51'! 139797setColor: aColor toHandle: aHandle 139798 "private - change the color to the given handle, applying the 139799 alternate look if corresponds" 139800 aHandle color: aColor. 139801 Preferences alternateHandlesLook 139802 ifTrue: [| fill | 139803 fill := GradientFillStyle ramp: {0.0 -> aColor muchLighter. 1.0 -> aColor darker}. 139804 fill origin: aHandle topLeft. 139805 fill direction: aHandle extent. 139806 aHandle fillStyle: fill] ! ! 139807 139808!HaloMorph methodsFor: 'private' stamp: 'ar 6/12/2001 05:24'! 139809setDirection: anEvent with: directionHandle 139810 "The user has let up after having dragged the direction arrow; now set the forward direction of the actual SketchMorph accordingly" 139811 anEvent hand obtainHalo: self. 139812 target setDirectionFrom: directionHandle center. 139813 self endInteraction! ! 139814 139815!HaloMorph methodsFor: 'private' stamp: 'dgd 9/29/2004 19:56'! 139816setDismissColor: evt with: dismissHandle 139817 "Called on mouseStillDown in the dismiss handle; set the color appropriately." 139818 139819 | colorToUse | 139820 evt hand obtainHalo: self. 139821 colorToUse := (dismissHandle containsPoint: evt cursorPoint) 139822 ifFalse: 139823 [Color red muchLighter] 139824 ifTrue: 139825 [Color lightGray]. 139826 self setColor: colorToUse toHandle: dismissHandle. 139827! ! 139828 139829!HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:25'! 139830showDirectionHandles: wantToShow 139831 139832 self showDirectionHandles: wantToShow addHandles: true "called from menu" 139833! ! 139834 139835!HaloMorph methodsFor: 'private' stamp: 'aoy 2/17/2003 01:27'! 139836showDirectionHandles: wantToShow addHandles: needHandles 139837 directionArrowAnchor := wantToShow 139838 ifTrue: [target referencePositionInWorld "not nil means show"] 139839 ifFalse: [nil]. 139840 needHandles ifTrue: [self addHandles] ! ! 139841 139842!HaloMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 19:04'! 139843showingDirectionHandles 139844 ^directionArrowAnchor notNil! ! 139845 139846!HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 18:43'! 139847simpleFudgeOffset 139848 "account for the difference in basicBoxes between regular and simple handles" 139849 139850 ^ 0@0 139851! ! 139852 139853!HaloMorph methodsFor: 'private' stamp: 'sw 2/2/2006 02:46'! 139854startGrow: evt with: growHandle 139855 "Initialize resizing of my target. Launch a command representing it, to support Undo" 139856 139857 | botRt | 139858 self obtainHaloForEvent: evt andRemoveAllHandlesBut: growHandle. 139859 botRt := target point: target bottomRight in: owner. 139860 positionOffset := (self world viewBox containsPoint: botRt) 139861 ifTrue: [evt cursorPoint - botRt] 139862 ifFalse: [0@0]. 139863 139864 self setProperty: #commandInProgress toValue: 139865 (Command new 139866 cmdWording: ('resize ' translated, target nameForUndoWording); 139867 undoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: target extent). 139868 139869 originalExtent := target extent! ! 139870 139871!HaloMorph methodsFor: 'private' stamp: 'stephane.ducasse 11/8/2008 19:37'! 139872startRot: evt with: rotHandle 139873 "Initialize rotation of my target if it is rotatable. Launch a command object to represent the action" 139874 139875 self obtainHaloForEvent: evt andRemoveAllHandlesBut: rotHandle. 139876 target isFlexMorph ifFalse: [target addFlexShellIfNecessary]. 139877 growingOrRotating := true. 139878 139879 self removeAllHandlesBut: rotHandle. "remove all other handles" 139880 angleOffset := evt cursorPoint - (target pointInWorld: target referencePosition). 139881 angleOffset := Point 139882 r: angleOffset r 139883 degrees: angleOffset degrees - target rotationDegrees. 139884 self setProperty: #commandInProgress toValue: 139885 (Command new 139886 cmdWording: ('rotate ' translated, target nameForUndoWording); 139887 undoTarget: target renderedMorph selector: #heading: argument: target rotationDegrees) 139888 139889! ! 139890 139891!HaloMorph methodsFor: 'private' stamp: 'sw 2/2/2006 00:28'! 139892startScale: evt with: scaleHandle 139893 "Initialize scaling of my target." 139894 139895 self obtainHaloForEvent: evt andRemoveAllHandlesBut: scaleHandle. 139896 target isFlexMorph ifFalse: [target addFlexShellIfNecessary]. 139897 growingOrRotating := true. 139898 positionOffset := 0@0. 139899 139900 self setProperty: #commandInProgress toValue: 139901 (Command new 139902 cmdWording: ('resize ' translated, target nameForUndoWording); 139903 undoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: target extent). 139904 originalExtent := target extent 139905! ! 139906 139907!HaloMorph methodsFor: 'private' stamp: 'ar 10/8/2001 14:32'! 139908trackCenterOfRotation: anEvent with: rotationHandle 139909 (rotationHandle hasProperty: #dragByCenterOfRotation) 139910 ifTrue:[^self doDrag: anEvent with: rotationHandle]. 139911 anEvent hand obtainHalo: self. 139912 rotationHandle center: anEvent cursorPoint.! ! 139913 139914!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:43'! 139915trackDirectionArrow: anEvent with: shaft 139916 anEvent hand obtainHalo: self. 139917 shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}. 139918 self layoutChanged! ! 139919Object subclass: #HaloSpec 139920 instanceVariableNames: 'addHandleSelector horizontalPlacement verticalPlacement color iconSymbol' 139921 classVariableNames: '' 139922 poolDictionaries: '' 139923 category: 'Morphic-Widgets'! 139924!HaloSpec commentStamp: 'kfr 10/27/2003 16:23' prior: 0! 139925Sets spec's for how handles are layed out in a halo.! 139926 139927 139928!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 19:54'! 139929addHandleSelector 139930 ^ addHandleSelector! ! 139931 139932!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 18:41'! 139933color 139934 ^ color! ! 139935 139936!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 18:41'! 139937horizontalPlacement 139938 ^ horizontalPlacement! ! 139939 139940!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 19:54'! 139941horizontalPlacement: hp verticalPlacement: vp color: col iconSymbol: is addHandleSelector: sel 139942 horizontalPlacement := hp. 139943 verticalPlacement := vp. 139944 color:= col. 139945 iconSymbol := is asSymbol. 139946 addHandleSelector := sel! ! 139947 139948!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 18:41'! 139949iconSymbol 139950 ^ iconSymbol! ! 139951 139952!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 18:41'! 139953verticalPlacement 139954 ^ verticalPlacement! ! 139955 139956 139957!HaloSpec methodsFor: 'printing' stamp: 'sw 11/15/2001 16:31'! 139958printOn: aStream 139959 "Add a textual printout representing the receiver to a stream" 139960 139961 super printOn: aStream. 139962 aStream nextPutAll: ' (', addHandleSelector asString, ' ', iconSymbol asString, ')'! ! 139963PreferenceView subclass: #HaloThemePreferenceView 139964 instanceVariableNames: '' 139965 classVariableNames: '' 139966 poolDictionaries: '' 139967 category: 'System-Support'! 139968!HaloThemePreferenceView commentStamp: '<historical>' prior: 0! 139969I am responsible for building the view for the preference that choose the halo theme! 139970 139971 139972!HaloThemePreferenceView methodsFor: 'user interface' stamp: 'md 12/18/2008 16:22'! 139973haloThemeRadioButtons 139974 "Answer a column of butons representing the choices of halo theme" 139975 139976 | buttonColumn aRow aRadioButton aStringMorph | 139977 buttonColumn := AlignmentMorph newColumn beTransparent. 139978 #( (iconicHaloSpecifications iconic iconicHalosInForce 'circular halos with icons inside') 139979 (classicHaloSpecs classic classicHalosInForce 'plain circular halos') 139980 (customHaloSpecs custom customHalosInForce 'customizable halos')) do: 139981 139982 [:quad | 139983 aRow := AlignmentMorph newRow beTransparent. 139984 aRow addMorph: (aRadioButton := UpdatingThreePhaseButtonMorph radioButton). 139985 aRadioButton target: Preferences. 139986 aRadioButton setBalloonText: quad fourth. 139987 aRadioButton actionSelector: #installHaloTheme:. 139988 aRadioButton getSelector: quad third. 139989 aRadioButton arguments: (Array with: quad first). 139990 aRow addTransparentSpacerOfSize: (4 @ 0). 139991 aRow addMorphBack: (aStringMorph := StringMorph contents: quad second asString). 139992 aStringMorph setBalloonText: quad fourth. 139993 buttonColumn addMorphBack: aRow]. 139994 ^ buttonColumn 139995 139996 "(Preferences preferenceAt: #haloTheme) view tearOffButton"! ! 139997 139998!HaloThemePreferenceView methodsFor: 'user interface' stamp: 'hpt 9/24/2004 23:11'! 139999representativeButtonWithColor: aColor inPanel: aPreferencesPanel 140000 | outerButton editButton | 140001 editButton := SimpleButtonMorph new 140002 target: Preferences; 140003 color: Color transparent; 140004 actionSelector: #editCustomHalos; 140005 label: 'Edit custom halos' translated; 140006 setBalloonText: 'Click here to edit the method that defines the custom halos' translated. 140007 140008 outerButton := AlignmentMorph newColumn. 140009 outerButton 140010 color: (aColor ifNil: [Color r: 0.645 g: 1.0 b: 1.0]); 140011 hResizing: (aPreferencesPanel ifNil: [#shrinkWrap] ifNotNil: [#spaceFill]); 140012 vResizing: #shrinkWrap; 140013 addTransparentSpacerOfSize: (0@4); 140014 addMorphBack: self haloThemeRadioButtons; 140015 addTransparentSpacerOfSize: (0@4); 140016 addMorphBack: editButton. 140017 140018 ^outerButton. 140019 140020 "(Preferences preferenceAt: #haloTheme) view tearOffButton" ! ! 140021 140022"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 140023 140024HaloThemePreferenceView class 140025 instanceVariableNames: ''! 140026 140027!HaloThemePreferenceView class methodsFor: 'initialization' stamp: 'hpt 9/26/2004 15:58'! 140028initialize 140029 "adding the halo theme preference to Preferences and registering myself as its view" 140030 PreferenceViewRegistry ofHaloThemePreferences register: self. 140031 Preferences 140032 addPreference: #haloTheme 140033 categories: {#halos} 140034 default: #iconicHaloSpecifications 140035 balloonHelp: '' 140036 projectLocal: false 140037 changeInformee: nil 140038 changeSelector: nil 140039 viewRegistry: PreferenceViewRegistry ofHaloThemePreferences.! ! 140040 140041!HaloThemePreferenceView class methodsFor: 'initialization' stamp: 'hpt 9/26/2004 15:58'! 140042unload 140043 PreferenceViewRegistry ofHaloThemePreferences unregister: self.! ! 140044 140045 140046!HaloThemePreferenceView class methodsFor: 'view registry' stamp: 'alain.plantec 6/6/2009 22:38'! 140047handlesPanel: aPreferencePanel 140048 ^false! ! 140049Exception subclass: #Halt 140050 instanceVariableNames: '' 140051 classVariableNames: '' 140052 poolDictionaries: '' 140053 category: 'Exceptions-Extensions'! 140054!Halt commentStamp: '<historical>' prior: 0! 140055Halt is provided to support Object>>halt.! 140056 140057 140058!Halt methodsFor: 'priv handling' stamp: 'ajh 8/5/2003 11:30'! 140059defaultAction 140060 "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" 140061 140062 UnhandledError signalForException: self! ! 140063TestCase subclass: #HandBugs 140064 instanceVariableNames: '' 140065 classVariableNames: '' 140066 poolDictionaries: '' 140067 category: 'Tests-Bugs'! 140068 140069!HandBugs methodsFor: 'as yet unclassified' stamp: 'wiz 4/18/2007 00:57'! 140070testTargetPoint 140071"self new testTargetPoint" 140072"self run: #testTargetPoint" 140073 140074self shouldnt: [ ActiveHand targetPoint ] raise: Error . 140075 140076! ! 140077Morph subclass: #HandMorph 140078 instanceVariableNames: 'mouseFocus keyboardFocus eventListeners mouseListeners keyboardListeners mouseClickState mouseOverHandler lastMouseEvent targetOffset damageRecorder cacheCanvas cachedCanvasHasHoles temporaryCursor temporaryCursorOffset hardwareCursor hasChanged savedPatch userInitials lastEventBuffer lastKeyScanCode combinedChar' 140079 classVariableNames: 'CompositionWindowManager DoubleClickTime EventStats NormalCursor PasteBuffer ShowEvents VirtualKeys' 140080 poolDictionaries: 'EventSensorConstants' 140081 category: 'Morphic-Kernel'! 140082!HandMorph commentStamp: '<historical>' prior: 0! 140083The cursor may be thought of as the HandMorph. The hand's submorphs hold anything being carried by dragging. 140084 140085There is some minimal support for multiple hands in the same world.! 140086 140087 140088!HandMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/24/2009 10:36'! 140089fullDrawOn: aCanvas 140090 "A HandMorph has unusual drawing requirements: 140091 1. the hand itself (i.e., the cursor) appears in front of its submorphs 140092 2. morphs being held by the hand cast a shadow on the world/morphs below 140093 The illusion is that the hand plucks up morphs and carries them above the world." 140094 140095 "Note: This version caches an image of the morphs being held by the hand for 140096 better performance. This cache is invalidated if one of those morphs changes." 140097 140098 | disableCaching subBnds roundCorners rounded | 140099 self visible ifFalse: [^self]. 140100 (aCanvas isVisible: self fullBounds) ifFalse: [^self]. 140101 disableCaching := false. 140102 disableCaching 140103 ifTrue: 140104 [self nonCachingFullDrawOn: aCanvas. 140105 ^self]. 140106 submorphs isEmpty 140107 ifTrue: 140108 [cacheCanvas := nil. 140109 ^self drawOn: aCanvas]. "just draw the hand itself" 140110 subBnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]). 140111 self updateCacheCanvas: aCanvas. 140112 (cacheCanvas isNil 140113 or: [cachedCanvasHasHoles and: [cacheCanvas depth = 1]]) 140114 ifTrue: 140115 ["could not use caching due to translucency; do full draw" 140116 140117 self nonCachingFullDrawOn: aCanvas. 140118 ^self]. 140119 140120 "--> begin rounded corners hack <---" 140121 roundCorners := cachedCanvasHasHoles == false 140122 and: [submorphs size = 1 and: [submorphs first wantsRoundedCorners]]. 140123 roundCorners 140124 ifTrue: 140125 [rounded := submorphs first. 140126 aCanvas asShadowDrawingCanvas translateBy: self shadowOffset 140127 during: 140128 [:shadowCanvas | 140129 shadowCanvas roundCornersOf: rounded 140130 during: 140131 [(subBnds areasOutside: (rounded boundsWithinCorners 140132 translateBy: self shadowOffset negated)) 140133 do: [:r | shadowCanvas fillRectangle: r color: Color black]]]. 140134 aCanvas roundCornersOf: rounded 140135 during: 140136 [aCanvas 140137 drawImage: cacheCanvas form 140138 at: subBnds origin 140139 sourceRect: cacheCanvas form boundingBox]. 140140 ^self drawOn: aCanvas "draw the hand itself in front of morphs"]. 140141 "--> end rounded corners hack <---" 140142 140143 "draw the shadow" 140144 (submorphs anySatisfy: [:m | m handlesDropShadowInHand not]) ifTrue: [ 140145 aCanvas asShadowDrawingCanvas translateBy: self shadowOffset 140146 during: 140147 [:shadowCanvas | 140148 cachedCanvasHasHoles 140149 ifTrue: 140150 ["Have to draw the real shadow of the form" 140151 140152 shadowCanvas paintImage: cacheCanvas form at: subBnds origin] 140153 ifFalse: 140154 ["Much faster if only have to shade the edge of a solid rectangle" 140155 140156 (subBnds areasOutside: (subBnds translateBy: self shadowOffset negated)) 140157 do: [:r | shadowCanvas fillRectangle: r color: Color black]]]]. 140158 140159 "draw morphs in front of the shadow using the cached Form" 140160 aCanvas translucentImage: cacheCanvas form at: subBnds origin. 140161 self drawOn: aCanvas "draw the hand itself in front of morphs"! ! 140162 140163 140164!HandMorph methodsFor: '*etoys-scripting' stamp: 'ar 3/17/2001 20:11'! 140165adaptedToWorld: aWorld 140166 "If I refer to a world or a hand, return the corresponding items in the new world." 140167 ^aWorld primaryHand! ! 140168 140169 140170!HandMorph methodsFor: 'accessing' stamp: 'tk 10/20/2004 15:54'! 140171anyButtonPressed 140172 ^lastMouseEvent anyButtonPressed! ! 140173 140174!HandMorph methodsFor: 'accessing' stamp: 'sw 2/11/98 18:00'! 140175colorForInsets 140176 "Morphs being dragged by the hand use the world's color" 140177 ^ owner colorForInsets! ! 140178 140179!HandMorph methodsFor: 'accessing' stamp: 'ar 10/5/2000 23:17'! 140180lastEvent 140181 ^ lastMouseEvent! ! 140182 140183!HandMorph methodsFor: 'accessing' stamp: 'ar 9/25/2000 14:24'! 140184mouseOverHandler 140185 ^mouseOverHandler ifNil:[mouseOverHandler := MouseOverHandler new].! ! 140186 140187!HandMorph methodsFor: 'accessing' stamp: 'tk 10/20/2004 15:54'! 140188noButtonPressed 140189 "Answer whether any mouse button is not being pressed." 140190 140191 ^self anyButtonPressed not! ! 140192 140193!HandMorph methodsFor: 'accessing' stamp: 'ar 12/22/2008 12:04'! 140194shiftPressed 140195 ^lastMouseEvent shiftPressed! ! 140196 140197!HandMorph methodsFor: 'accessing'! 140198targetOffset 140199 "Return the offset of the last mouseDown location relative to the origin of the recipient morph. During menu interactions, this is the absolute location of the mouse down event that invoked the menu." 140200 140201 ^ targetOffset 140202! ! 140203 140204!HandMorph methodsFor: 'accessing' stamp: 'wiz 12/4/2006 00:16'! 140205targetPoint 140206 "Return the new position of the target. 140207 I.E. return the position of the hand less 140208 the original distance between hand and target position" 140209 140210 ^ self position - targetOffset 140211! ! 140212 140213!HandMorph methodsFor: 'accessing'! 140214userInitials 140215 140216 ^ userInitials! ! 140217 140218!HandMorph methodsFor: 'accessing' stamp: 'ar 10/26/2000 15:18'! 140219userPicture 140220 ^self valueOfProperty: #remoteUserPicture 140221 140222! ! 140223 140224!HandMorph methodsFor: 'accessing' stamp: 'ar 10/26/2000 15:34'! 140225userPicture: aFormOrNil 140226 ^self setProperty: #remoteUserPicture toValue: aFormOrNil 140227! ! 140228 140229 140230!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 16:49'! 140231balloonHelp 140232 "Return the balloon morph associated with this hand" 140233 ^self valueOfProperty: #balloonHelpMorph! ! 140234 140235!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 16:51'! 140236balloonHelp: aBalloonMorph 140237 "Return the balloon morph associated with this hand" 140238 | oldHelp | 140239 oldHelp := self balloonHelp. 140240 oldHelp ifNotNil:[oldHelp delete]. 140241 aBalloonMorph 140242 ifNil:[self removeProperty: #balloonHelpMorph] 140243 ifNotNil:[self setProperty: #balloonHelpMorph toValue: aBalloonMorph]! ! 140244 140245!HandMorph methodsFor: 'balloon help' stamp: 'sw 10/15/2002 20:01'! 140246deleteBalloonTarget: aMorph 140247 "Delete any existing balloon help. This is now done unconditionally, whether or not the morph supplied is the same as the current balloon target" 140248 140249 self balloonHelp: nil 140250 140251" | h | 140252 h := self balloonHelp ifNil: [^ self]. 140253 h balloonOwner == aMorph ifTrue: [self balloonHelp: nil]"! ! 140254 140255!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/6/2000 00:14'! 140256removePendingBalloonFor: aMorph 140257 "Get rid of pending balloon help." 140258 self removeAlarm: #spawnBalloonFor:. 140259 self deleteBalloonTarget: aMorph.! ! 140260 140261!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 17:15'! 140262spawnBalloonFor: aMorph 140263 aMorph showBalloon: aMorph balloonText hand: self.! ! 140264 140265!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 17:14'! 140266triggerBalloonFor: aMorph after: timeOut 140267 "Trigger balloon help after the given time out for some morph" 140268 self addAlarm: #spawnBalloonFor: with: aMorph after: timeOut.! ! 140269 140270 140271!HandMorph methodsFor: 'caching' stamp: 'ar 10/26/2000 15:28'! 140272releaseCachedState 140273 | oo ui | 140274 ui := userInitials. 140275 super releaseCachedState. 140276 cacheCanvas := nil. 140277 oo := owner. 140278 self removeAllMorphs. 140279 self initialize. "nuke everything" 140280 self privateOwner: oo. 140281 self releaseAllFoci. 140282 self userInitials: ui andPicture: (self userPicture).! ! 140283 140284 140285!HandMorph methodsFor: 'change reporting' stamp: 'ar 12/30/2001 17:32'! 140286invalidRect: damageRect from: aMorph 140287 "Note that a change has occurred and record the given damage rectangle relative to the origin this hand's cache." 140288 hasChanged := true. 140289 aMorph == self ifTrue:[^self]. 140290 damageRecorder recordInvalidRect: damageRect. 140291! ! 140292 140293 140294!HandMorph methodsFor: 'classification'! 140295isHandMorph 140296 140297 ^ true! ! 140298 140299 140300!HandMorph methodsFor: 'copying' stamp: 'ar 10/6/2000 00:11'! 140301veryDeepCopyWith: deepCopier 140302 "Return self. Do not copy hands this way." 140303 ^ self! ! 140304 140305 140306!HandMorph methodsFor: 'cursor' stamp: 'di 3/6/1999 23:52'! 140307showTemporaryCursor: cursorOrNil 140308 "Set the temporary cursor to the given Form. If the argument is nil, revert to the normal cursor." 140309 140310 self showTemporaryCursor: cursorOrNil hotSpotOffset: 0@0 140311! ! 140312 140313!HandMorph methodsFor: 'cursor' stamp: 'JW 9/6/2005 23:12'! 140314showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset 140315 "Set the temporary cursor to the given Form. 140316 If the argument is nil, revert to the normal hardware cursor." 140317 140318 self changed. 140319 temporaryCursorOffset 140320 ifNotNil: [bounds := bounds translateBy: temporaryCursorOffset negated]. 140321 cursorOrNil isNil 140322 ifTrue: [temporaryCursor := temporaryCursorOffset := hardwareCursor := nil] 140323 ifFalse: 140324 [temporaryCursor := cursorOrNil asCursorForm. 140325 temporaryCursorOffset := temporaryCursor offset - hotSpotOffset. 140326 (cursorOrNil isKindOf: Cursor) ifTrue: [hardwareCursor := cursorOrNil]]. 140327 bounds := self cursorBounds. 140328 self 140329 userInitials: userInitials andPicture: self userPicture; 140330 layoutChanged; 140331 changed! ! 140332 140333!HandMorph methodsFor: 'cursor' stamp: 'NS 2/17/2001 11:01'! 140334temporaryCursor 140335 ^ temporaryCursor! ! 140336 140337 140338!HandMorph methodsFor: 'double click support' stamp: 'ar 9/18/2000 17:16'! 140339resetClickState 140340 "Reset the double-click detection state to normal (i.e., not waiting for a double-click)." 140341 mouseClickState := nil.! ! 140342 140343!HandMorph methodsFor: 'double click support' stamp: 'nk 7/26/2004 10:29'! 140344waitForClicksOrDrag: aMorph event: evt 140345 "Wait for mouse button and movement events, informing aMorph about events interesting to it via callbacks. 140346 This message is typically sent to the Hand by aMorph when it first receives a mouse-down event. 140347 The callback methods invoked on aMorph (which are passed a copy of evt) are: 140348 #click: sent when the mouse button goes up within doubleClickTime. 140349 #doubleClick: sent when the mouse goes up, down, and up again all within DoubleClickTime. 140350 #doubleClickTimeout: sent when the mouse does not have a doubleClick within DoubleClickTime. 140351 #startDrag: sent when the mouse moves more than 10 pixels from evt's position within DoubleClickTime. 140352 Note that mouseMove: and mouseUp: events are not sent to aMorph until it becomes the mouse focus, 140353 which is typically done by aMorph in its click:, doubleClick:, or drag: methods." 140354 140355 ^self waitForClicksOrDrag: aMorph event: evt selectors: #( #click: #doubleClick: #doubleClickTimeout: #startDrag:) threshold: 10 140356! ! 140357 140358!HandMorph methodsFor: 'double click support' stamp: 'nk 7/26/2004 10:32'! 140359waitForClicksOrDrag: aMorph event: evt selectors: clickAndDragSelectors threshold: threshold 140360 140361 "Wait for mouse button and movement events, informing aMorph about events interesting to it via callbacks. 140362 This message is typically sent to the Hand by aMorph when it first receives a mouse-down event. 140363 The callback methods, named in clickAndDragSelectors and passed a copy of evt, are: 140364 1 (click) sent when the mouse button goes up within doubleClickTime. 140365 2 (doubleClick) sent when the mouse goes up, down, and up again all within DoubleClickTime. 140366 3 (doubleClickTimeout) sent when the mouse does not have a doubleClick within DoubleClickTime. 140367 4 (startDrag) sent when the mouse moves more than threshold pixels from evt's position within DoubleClickTime. 140368 Note that mouseMove: and mouseUp: events are not sent to aMorph until it becomes the mouse focus, 140369 which is typically done by aMorph in its click:, doubleClick:, or drag: methods." 140370 140371 mouseClickState := 140372 MouseClickState new 140373 client: aMorph 140374 click: clickAndDragSelectors first 140375 dblClick: clickAndDragSelectors second 140376 dblClickTime: DoubleClickTime 140377 dblClickTimeout: clickAndDragSelectors third 140378 drag: clickAndDragSelectors fourth 140379 threshold: threshold 140380 event: evt. 140381! ! 140382 140383 140384!HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:43'! 140385drawOn: aCanvas 140386 "Draw the hand itself (i.e., the cursor)." 140387 140388 | userPic | 140389 temporaryCursor isNil 140390 ifTrue: [aCanvas paintImage: NormalCursor at: bounds topLeft] 140391 ifFalse: [aCanvas paintImage: temporaryCursor at: bounds topLeft]. 140392 self hasUserInformation 140393 ifTrue: 140394 [aCanvas 140395 drawString: userInitials 140396 at: self cursorBounds topRight + (0 @ 4) 140397 font: nil 140398 color: color. 140399 (userPic := self userPicture) ifNotNil: 140400 [aCanvas paintImage: userPic at: self cursorBounds topRight + (0 @ 24)]]! ! 140401 140402!HandMorph methodsFor: 'drawing' stamp: 'ls 4/3/2000 20:30'! 140403hasChanged 140404 "Return true if this hand has changed, either because it has moved or because some morph it is holding has changed." 140405 140406 ^ hasChanged ifNil: [ true ] 140407! ! 140408 140409!HandMorph methodsFor: 'drawing' stamp: 'HilaireFernandes 12/9/2008 10:33'! 140410hasUserInformation 140411 ^self userInitials notEmpty or: [self userPicture notNil]! ! 140412 140413!HandMorph methodsFor: 'drawing' stamp: 'JW 9/6/2005 23:28'! 140414needsToBeDrawn 140415 "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty and there are any visible submorphs. If using the software cursor, ensure that the hardware cursor is hidden." 140416 "Details: Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor and shadow from the display." 140417 | cursor | 140418 (savedPatch notNil 140419 or: [ (submorphs anySatisfy: [ :ea | ea visible ]) 140420 or: [ (temporaryCursor notNil and: [hardwareCursor isNil]) 140421 or: [ self hasUserInformation ]]]) 140422 ifTrue: [ 140423 "using the software cursor; hide the hardware one" 140424 Sensor currentCursor == Cursor blank ifFalse: [Cursor blank show]. 140425 ^ true]. 140426 "Switch from one hardware cursor to another, if needed." 140427 cursor := hardwareCursor ifNil: [Cursor normal]. 140428 Sensor currentCursor == cursor ifFalse: [cursor show]. 140429 ^ false 140430! ! 140431 140432!HandMorph methodsFor: 'drawing' stamp: 'ar 2/18/2000 15:19'! 140433nonCachingFullDrawOn: aCanvas 140434 | shadowForm | 140435 "A HandMorph has unusual drawing requirements: 140436 1. the hand itself (i.e., the cursor) appears in front of its submorphs 140437 2. morphs being held by the hand cast a shadow on the world/morphs below 140438 The illusion is that the hand plucks up morphs and carries them above the world." 140439 "Note: This version does not cache an image of the morphs being held by the hand. 140440 Thus, it is slower for complex morphs, but consumes less space." 140441 140442 submorphs isEmpty ifTrue: [^ self drawOn: aCanvas]. "just draw the hand itself" 140443 aCanvas asShadowDrawingCanvas 140444 translateBy: self shadowOffset during:[:shadowCanvas| 140445 "Note: We use a shadow form here to prevent drawing 140446 overlapping morphs multiple times using the transparent 140447 shadow color." 140448 shadowForm := self shadowForm. 140449" 140450shadowForm displayAt: shadowForm offset negated. Display forceToScreen: (0@0 extent: shadowForm extent). 140451" 140452 shadowCanvas paintImage: shadowForm at: shadowForm offset. "draw shadows" 140453 ]. 140454 "draw morphs in front of shadows" 140455 self drawSubmorphsOn: aCanvas. 140456 self drawOn: aCanvas. "draw the hand itself in front of morphs" 140457! ! 140458 140459!HandMorph methodsFor: 'drawing' stamp: 'JW 9/6/2005 23:10'! 140460restoreSavedPatchOn: aCanvas 140461 "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." 140462 | cursor | 140463 140464 hasChanged := false. 140465 savedPatch ifNotNil: 140466 [aCanvas drawImage: savedPatch at: savedPatch offset. 140467 self hasUserInformation ifTrue: [^self]. "cannot use hw cursor if so" 140468 submorphs notEmpty ifTrue: [^self]. 140469 (temporaryCursor notNil and: [hardwareCursor isNil]) ifTrue: [^self]. 140470 140471 "Make the transition to using hardware cursor. Clear savedPatch and 140472 report one final damage rectangle to erase the image of the software cursor." 140473 super invalidRect: (savedPatch offset 140474 extent: savedPatch extent + self shadowOffset) 140475 from: self. 140476 cursor := hardwareCursor ifNil: [Cursor normal]. 140477 Sensor currentCursor == cursor ifFalse: [cursor show]. "show hardware cursor" 140478 savedPatch := nil]! ! 140479 140480!HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:49'! 140481savePatchFrom: aCanvas 140482 "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." 140483 140484 "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." 140485 140486 | damageRect myBnds | 140487 damageRect := myBnds := self fullBounds. 140488 savedPatch ifNotNil: 140489 [damageRect := myBnds merge: (savedPatch offset extent: savedPatch extent)]. 140490 (savedPatch isNil or: [savedPatch extent ~= myBnds extent]) 140491 ifTrue: 140492 ["allocate new patch form if needed" 140493 140494 savedPatch := aCanvas form allocateForm: myBnds extent]. 140495 aCanvas contentsOfArea: (myBnds translateBy: aCanvas origin) 140496 into: savedPatch. 140497 savedPatch offset: myBnds topLeft. 140498 ^damageRect! ! 140499 140500!HandMorph methodsFor: 'drawing' stamp: 'JW 7/12/2005 20:13'! 140501shadowForm 140502 "Return a 1-bit shadow of my submorphs. Assumes submorphs is not empty" 140503 | bnds canvas | 140504 bnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]). 140505 canvas := (Display defaultCanvasClass extent: bnds extent depth: 1) 140506 asShadowDrawingCanvas: Color black. 140507 canvas translateBy: bnds topLeft negated 140508 during:[:tempCanvas| self drawSubmorphsOn: tempCanvas]. 140509 ^ canvas form offset: bnds topLeft! ! 140510 140511!HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:49'! 140512updateCacheCanvas: aCanvas 140513 "Update the cached image of the morphs being held by this hand." 140514 140515 "Note: The following is an attempt to quickly get out if there's no change" 140516 140517 | subBnds rectList nPix | 140518 subBnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]). 140519 rectList := damageRecorder invalidRectsFullBounds: subBnds. 140520 damageRecorder reset. 140521 (rectList isEmpty 140522 and: [cacheCanvas notNil and: [cacheCanvas extent = subBnds extent]]) 140523 ifTrue: [^self]. 140524 140525 "Always check for real translucency -- can't be cached in a form" 140526 self submorphsDo: 140527 [:m | 140528 m wantsToBeCachedByHand 140529 ifFalse: 140530 [cacheCanvas := nil. 140531 cachedCanvasHasHoles := true. 140532 ^self]]. 140533 (cacheCanvas isNil or: [cacheCanvas extent ~= subBnds extent]) 140534 ifTrue: 140535 [cacheCanvas := (aCanvas allocateForm: subBnds extent) getCanvas. 140536 cacheCanvas translateBy: subBnds origin negated 140537 during: [:tempCanvas | self drawSubmorphsOn: tempCanvas]. 140538 self submorphsDo: 140539 [:m | 140540 (m areasRemainingToFill: subBnds) isEmpty 140541 ifTrue: [^cachedCanvasHasHoles := false]]. 140542 nPix := cacheCanvas form tallyPixelValues first. 140543 "--> begin rounded corners hack <---" 140544 cachedCanvasHasHoles := (nPix = 48 140545 and: [submorphs size = 1 and: [submorphs first wantsRoundedCorners]]) 140546 ifTrue: [false] 140547 ifFalse: [nPix > 0]. 140548 "--> end rounded corners hack <---" 140549 ^self]. 140550 140551 "incrementally update the cache canvas" 140552 cacheCanvas translateBy: subBnds origin negated 140553 during: 140554 [:cc | 140555 rectList do: 140556 [:r | 140557 cc clipBy: r 140558 during: 140559 [:c | 140560 c fillColor: Color transparent. 140561 self drawSubmorphsOn: c]]]! ! 140562 140563!HandMorph methodsFor: 'drawing' stamp: 'nk 10/24/2003 22:12'! 140564visible: aBoolean 140565 self needsToBeDrawn ifFalse: [ ^self ]. 140566 super visible: aBoolean! ! 140567 140568 140569!HandMorph methodsFor: 'drop shadows'! 140570shadowOffset 140571 140572 ^ 6@8! ! 140573 140574 140575!HandMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:43'! 140576cursorPoint 140577 "Implemented for allowing embedded worlds in an event cycle to query a hand's position and get it in its coordinates. The same can be achieved by #point:from: but this is simply much more convenient since it will look as if the hand is in the lower world." 140578 140579 | pos | 140580 pos := self position. 140581 (ActiveWorld isNil or: [ActiveWorld == owner]) ifTrue: [^pos]. 140582 ^ActiveWorld point: pos from: owner! ! 140583 140584!HandMorph methodsFor: 'event handling' stamp: 'ar 10/5/2000 23:17'! 140585flushEvents 140586 "Flush any events that may be pending" 140587 self flag: #arNote. "Remove it and fix senders" 140588 Sensor flushEvents.! ! 140589 140590!HandMorph methodsFor: 'event handling' stamp: 'ar 9/25/2000 14:27'! 140591noticeMouseOver: aMorph event: anEvent 140592 mouseOverHandler ifNil:[^self]. 140593 mouseOverHandler noticeMouseOver: aMorph event: anEvent.! ! 140594 140595!HandMorph methodsFor: 'event handling' stamp: 'adrian_lienhard 7/19/2009 18:42'! 140596pauseEventRecorderIn: aWorld 140597 "Suspend any recorder prior to a project change, and return it. 140598 It will be resumed after starting the new project." 140599 eventListeners ifNil:[^nil]. 140600 Smalltalk at: #EventRecorderMorph ifPresent: [ :class |. 140601 eventListeners do: 140602 [:er | (er isKindOf: class) ifTrue: [^ er pauseIn: aWorld]]]. 140603 ^ nil! ! 140604 140605 140606!HandMorph methodsFor: 'events-processing' stamp: 'JMM 1/15/2007 11:01'! 140607handleEvent: anEvent 140608 | evt ofs | 140609 owner ifNil:[^self]. 140610 evt := anEvent. 140611 140612 EventStats ifNil:[EventStats := IdentityDictionary new]. 140613 EventStats at: #count put: (EventStats at: #count ifAbsent:[0]) + 1. 140614 EventStats at: evt type put: (EventStats at: evt type ifAbsent:[0]) + 1. 140615 140616 evt isWindowEvent ifTrue: [^self]. 140617 evt isMouseOver ifTrue:[^self sendMouseEvent: evt]. 140618 140619ShowEvents == true ifTrue:[ 140620 Display fill: (0@0 extent: 250@120) rule: Form over fillColor: Color white. 140621 ofs := (owner hands indexOf: self) - 1 * 60. 140622 evt printString displayAt: (0@ofs) + (evt isKeyboard ifTrue:[0@30] ifFalse:[0@0]). 140623 self keyboardFocus printString displayAt: (0@ofs)+(0@45). 140624]. 140625 "Notify listeners" 140626 self sendListenEvent: evt to: self eventListeners. 140627 140628 evt isKeyboard ifTrue:[ 140629 self sendListenEvent: evt to: self keyboardListeners. 140630 self sendKeyboardEvent: evt. 140631 ^self mouseOverHandler processMouseOver: lastMouseEvent]. 140632 140633 evt isDropEvent ifTrue:[ 140634 self sendEvent: evt focus: nil. 140635 ^self mouseOverHandler processMouseOver: lastMouseEvent]. 140636 140637 evt isMouse ifTrue:[ 140638 self sendListenEvent: evt to: self mouseListeners. 140639 lastMouseEvent := evt]. 140640 140641 "Check for pending drag or double click operations." 140642 mouseClickState ifNotNil:[ 140643 (mouseClickState handleEvent: evt from: self) ifFalse:[ 140644 "Possibly dispatched #click: or something and will not re-establish otherwise" 140645 ^self mouseOverHandler processMouseOver: lastMouseEvent]]. 140646 140647 evt isMove ifTrue:[ 140648 self position: evt position. 140649 self sendMouseEvent: evt. 140650 ] ifFalse:[ 140651 "Issue a synthetic move event if we're not at the position of the event" 140652 (evt position = self position) ifFalse:[self moveToEvent: evt]. 140653 "Drop submorphs on button events" 140654 (self hasSubmorphs) 140655 ifTrue:[self dropMorphs: evt] 140656 ifFalse:[self sendMouseEvent: evt]. 140657 ]. 140658 ShowEvents == true ifTrue:[self mouseFocus printString displayAt: (0@ofs) + (0@15)]. 140659 self mouseOverHandler processMouseOver: lastMouseEvent. 140660! ! 140661 140662 140663!HandMorph methodsFor: 'focus handling' stamp: 'yo 11/7/2002 19:10'! 140664compositionWindowManager 140665 140666 ^ self class compositionWindowManager. 140667! ! 140668 140669!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'! 140670keyboardFocus 140671 ^ keyboardFocus! ! 140672 140673!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:30'! 140674keyboardFocus: aMorphOrNil 140675 keyboardFocus := aMorphOrNil! ! 140676 140677!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:10'! 140678mouseFocus 140679 ^mouseFocus! ! 140680 140681!HandMorph methodsFor: 'focus handling' stamp: 'nk 2/14/2004 18:44'! 140682mouseFocus: aMorphOrNil 140683 mouseFocus := aMorphOrNil! ! 140684 140685!HandMorph methodsFor: 'focus handling' stamp: 'yo 11/7/2002 19:11'! 140686newKeyboardFocus: aMorphOrNil 140687 "Make the given morph the new keyboard focus, canceling the previous keyboard focus if any. If the argument is nil, the current keyboard focus is cancelled." 140688 | oldFocus | 140689 oldFocus := self keyboardFocus. 140690 self keyboardFocus: aMorphOrNil. 140691 oldFocus ifNotNil: [oldFocus == aMorphOrNil ifFalse: [oldFocus keyboardFocusChange: false]]. 140692 aMorphOrNil ifNotNil: [aMorphOrNil keyboardFocusChange: true. self compositionWindowManager keyboardFocusForAMorph: aMorphOrNil]. 140693! ! 140694 140695!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:32'! 140696newMouseFocus: aMorphOrNil 140697 "Make the given morph the new mouse focus, canceling the previous mouse focus if any. If the argument is nil, the current mouse focus is cancelled." 140698 self mouseFocus: aMorphOrNil. 140699! ! 140700 140701!HandMorph methodsFor: 'focus handling' stamp: 'dgd 2/21/2003 22:48'! 140702newMouseFocus: aMorph event: event 140703 aMorph isNil 140704 ifFalse: [targetOffset := event cursorPoint - aMorph position]. 140705 ^self newMouseFocus: aMorph! ! 140706 140707!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'! 140708releaseAllFoci 140709 mouseFocus := nil. 140710 keyboardFocus := nil. 140711! ! 140712 140713!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'! 140714releaseKeyboardFocus 140715 "Release the current keyboard focus unconditionally" 140716 self newKeyboardFocus: nil. 140717! ! 140718 140719!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:31'! 140720releaseKeyboardFocus: aMorph 140721 "If the given morph had the keyboard focus before, release it" 140722 self keyboardFocus == aMorph ifTrue:[self releaseKeyboardFocus].! ! 140723 140724!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:10'! 140725releaseMouseFocus 140726 "Release the current mouse focus unconditionally." 140727 self newMouseFocus: nil.! ! 140728 140729!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:10'! 140730releaseMouseFocus: aMorph 140731 "If the given morph had the mouse focus before, release it" 140732 self mouseFocus == aMorph ifTrue:[self releaseMouseFocus].! ! 140733 140734 140735!HandMorph methodsFor: 'geometry' stamp: 'ar 3/20/2001 20:34'! 140736position 140737 140738 ^temporaryCursor 140739 ifNil: [bounds topLeft] 140740 ifNotNil: [bounds topLeft - temporaryCursorOffset]! ! 140741 140742!HandMorph methodsFor: 'geometry' stamp: 'nk 8/20/2003 17:39'! 140743position: aPoint 140744 "Overridden to align submorph origins to the grid if gridding is on." 140745 | adjustedPosition delta box | 140746 adjustedPosition := aPoint. 140747 temporaryCursor ifNotNil: [adjustedPosition := adjustedPosition + temporaryCursorOffset]. 140748 140749 "Copied from Morph to avoid owner layoutChanged" 140750 "Change the position of this morph and and all of its submorphs." 140751 delta := adjustedPosition - bounds topLeft. 140752 (delta x = 0 and: [delta y = 0]) ifTrue: [^ self]. "Null change" 140753 box := self fullBounds. 140754 (delta dotProduct: delta) > 100 ifTrue:[ 140755 "e.g., more than 10 pixels moved" 140756 self invalidRect: box. 140757 self invalidRect: (box translateBy: delta). 140758 ] ifFalse:[ 140759 self invalidRect: (box merge: (box translateBy: delta)). 140760 ]. 140761 self privateFullMoveBy: delta. 140762! ! 140763 140764!HandMorph methodsFor: 'geometry' stamp: 'ar 12/30/2001 20:44'! 140765userInitials: aString andPicture: aForm 140766 140767 | cb pictRect initRect f | 140768 140769 userInitials := aString. 140770 pictRect := initRect := cb := self cursorBounds. 140771 userInitials isEmpty ifFalse: [ 140772 f := TextStyle defaultFont. 140773 initRect := cb topRight + (0@4) extent: (f widthOfString: userInitials)@(f height). 140774 ]. 140775 self userPicture: aForm. 140776 aForm ifNotNil: [ 140777 pictRect := (self cursorBounds topRight + (0@24)) extent: aForm extent. 140778 ]. 140779 self bounds: ((cb merge: initRect) merge: pictRect). 140780 140781 140782! ! 140783 140784 140785!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 10/8/2000 23:42'! 140786attachMorph: m 140787 "Position the center of the given morph under this hand, then grab it. 140788 This method is used to grab far away or newly created morphs." 140789 | delta | 140790 self releaseMouseFocus. "Break focus" 140791 delta := m bounds extent // 2. 140792 m position: (self position - delta). 140793 m formerPosition: m position. 140794 targetOffset := m position - self position. 140795 self addMorphBack: m.! ! 140796 140797!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 10/5/2000 16:23'! 140798dropMorphs 140799 "Drop the morphs at the hands position" 140800 self dropMorphs: lastMouseEvent.! ! 140801 140802!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 9/14/2000 11:22'! 140803dropMorphs: anEvent 140804 "Drop the morphs at the hands position" 140805 self submorphsReverseDo:[:m| 140806 "Drop back to front to maintain z-order" 140807 self dropMorph: m event: anEvent. 140808 ].! ! 140809 140810!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 8/13/2003 11:39'! 140811dropMorph: aMorph event: anEvent 140812 "Drop the given morph which was carried by the hand" 140813 | event dropped | 140814 (anEvent isMouseUp and:[aMorph shouldDropOnMouseUp not]) ifTrue:[^self]. 140815 140816 "Note: For robustness in drag and drop handling we remove the morph BEFORE we drop him, but we keep his owner set to the hand. This prevents system lockups when there is a problem in drop handling (for example if there's an error in #wantsToBeDroppedInto:). THIS TECHNIQUE IS NOT RECOMMENDED FOR CASUAL USE." 140817 self privateRemove: aMorph. 140818 aMorph privateOwner: self. 140819 140820 dropped := aMorph. 140821 (dropped hasProperty: #addedFlexAtGrab) 140822 ifTrue:[dropped := aMorph removeFlexShell]. 140823 event := DropEvent new setPosition: self position contents: dropped hand: self. 140824 self sendEvent: event focus: nil. 140825 event wasHandled ifFalse:[aMorph rejectDropMorphEvent: event]. 140826 aMorph owner == self ifTrue:[aMorph delete]. 140827 self mouseOverHandler processMouseOver: anEvent.! ! 140828 140829!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 4/23/2001 15:17'! 140830grabMorph: aMorph from: formerOwner 140831 "Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand." 140832 140833 | grabbed offset targetPoint grabTransform fullTransform | 140834 self releaseMouseFocus. "Break focus" 140835 grabbed := aMorph. 140836 aMorph keepsTransform ifTrue:[ 140837 grabTransform := fullTransform := IdentityTransform new. 140838 ] ifFalse:[ 140839 "Compute the transform to apply to the grabbed morph" 140840 grabTransform := formerOwner 140841 ifNil: [IdentityTransform new] 140842 ifNotNil: [formerOwner grabTransform]. 140843 "Compute the full transform for the grabbed morph" 140844 fullTransform := formerOwner 140845 ifNil: [IdentityTransform new] 140846 ifNotNil: [formerOwner transformFrom: owner]. 140847 ]. 140848 "targetPoint is point in aMorphs reference frame" 140849 targetPoint := fullTransform globalPointToLocal: self position. 140850 "but current position will be determined by grabTransform, so compute offset" 140851 offset := targetPoint - (grabTransform globalPointToLocal: self position). 140852 "apply the transform that should be used after grabbing" 140853 grabbed := grabbed transformedBy: grabTransform. 140854 grabbed == aMorph 140855 ifFalse: [grabbed setProperty: #addedFlexAtGrab toValue: true]. 140856 "offset target to compensate for differences in transforms" 140857 grabbed position: grabbed position - offset asIntegerPoint. 140858 "And compute distance from hand's position" 140859 targetOffset := grabbed position - self position. 140860 self addMorphBack: grabbed. 140861 grabbed justGrabbedFrom: formerOwner.! ! 140862 140863 140864!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/4/2000 13:40'! 140865halo: newHalo 140866 "Set halo associated with this hand" 140867 | oldHalo | 140868 oldHalo := self halo. 140869 (oldHalo isNil or:[oldHalo == newHalo]) ifFalse:[oldHalo delete]. 140870 newHalo 140871 ifNil:[self removeProperty: #halo] 140872 ifNotNil:[self setProperty: #halo toValue: newHalo]! ! 140873 140874!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/24/2000 18:40'! 140875obtainHalo: aHalo 140876 "Used for transfering halos between hands" 140877 | formerOwner | 140878 self halo == aHalo ifTrue:[^self]. 140879 "Find former owner" 140880 formerOwner := self world hands detect:[:h| h halo == aHalo] ifNone:[nil]. 140881 formerOwner ifNotNil:[formerOwner releaseHalo: aHalo]. 140882 self halo: aHalo! ! 140883 140884!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/24/2000 18:40'! 140885releaseHalo: aHalo 140886 "Used for transfering halos between hands" 140887 self removeProperty: #halo! ! 140888 140889!HandMorph methodsFor: 'halo handling' stamp: 'dgd 4/4/2006 16:14'! 140890removeHalo 140891 "remove the receiver's halo (if any)" 140892 | halo | 140893 halo := self halo. 140894 halo 140895 ifNil: [^ self]. 140896 halo delete. 140897 self removeProperty: #halo! ! 140898 140899!HandMorph methodsFor: 'halo handling' stamp: 'dgd 9/9/2004 22:44'! 140900removeHaloFromClick: anEvent on: aMorph 140901 | halo | 140902 halo := self halo 140903 ifNil: [^ self]. 140904 (halo target hasOwner: self) 140905 ifTrue: [^ self]. 140906 (halo staysUpWhenMouseIsDownIn: aMorph) 140907 ifFalse: [self removeHalo]! ! 140908 140909!HandMorph methodsFor: 'halo handling' stamp: 'ar 8/8/2001 14:49'! 140910removePendingHaloFor: aMorph 140911 "Get rid of pending balloon help or halo actions." 140912 self removeAlarm: #spawnMagicHaloFor:.! ! 140913 140914!HandMorph methodsFor: 'halo handling' stamp: 'ar 8/8/2001 14:50'! 140915spawnMagicHaloFor: aMorph 140916 (self halo notNil and:[self halo target == aMorph]) ifTrue:[^self]. 140917 aMorph addMagicHaloFor: self.! ! 140918 140919!HandMorph methodsFor: 'halo handling' stamp: 'ar 8/8/2001 14:51'! 140920triggerHaloFor: aMorph after: timeOut 140921 "Trigger automatic halo after the given time out for some morph" 140922 self addAlarm: #spawnMagicHaloFor: with: aMorph after: timeOut! ! 140923 140924 140925!HandMorph methodsFor: 'halos and balloon help' stamp: 'ar 10/4/2000 13:40'! 140926halo 140927 "Return the halo associated with this hand, if any" 140928 ^self valueOfProperty: #halo! ! 140929 140930 140931!HandMorph methodsFor: 'initialization' stamp: 'marcus.denker 8/24/2008 21:41'! 140932initForEvents 140933 mouseOverHandler := nil. 140934 lastMouseEvent := MouseEvent basicNew setType: #mouseMove position: 0@0 buttons: 0 hand: self. 140935 lastEventBuffer := {1. 0. 0. 0. 0. 0. nil. nil}. 140936 self resetClickState.! ! 140937 140938!HandMorph methodsFor: 'initialization' stamp: 'ar 10/26/2000 14:58'! 140939initialize 140940 super initialize. 140941 self initForEvents. 140942 keyboardFocus := nil. 140943 mouseFocus := nil. 140944 bounds := 0@0 extent: Cursor normal extent. 140945 userInitials := ''. 140946 damageRecorder := DamageRecorder new. 140947 cachedCanvasHasHoles := false. 140948 temporaryCursor := temporaryCursorOffset := nil. 140949 self initForEvents.! ! 140950 140951!HandMorph methodsFor: 'initialization' stamp: 'nk 2/14/2004 18:28'! 140952interrupted 140953 "Something went wrong - we're about to bring up a debugger. 140954 Release some stuff that could be problematic." 140955 self releaseAllFoci. "or else debugger might not handle clicks" 140956! ! 140957 140958!HandMorph methodsFor: 'initialization' stamp: 'ar 3/3/2001 15:27'! 140959resourceJustLoaded 140960 "In case resource relates to me" 140961 cacheCanvas := nil.! ! 140962 140963 140964!HandMorph methodsFor: 'layout' stamp: 'jm 2/20/98 18:55'! 140965fullBounds 140966 "Extend my bounds by the shadow offset when carrying morphs." 140967 140968 | bnds | 140969 bnds := super fullBounds. 140970 submorphs isEmpty 140971 ifTrue: [^ bnds ] 140972 ifFalse: [^ bnds topLeft corner: bnds bottomRight + self shadowOffset]. 140973! ! 140974 140975 140976!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:43'! 140977addEventListener: anObject 140978 "Make anObject a listener for all events. All events will be reported to the object." 140979 self eventListeners: (self addListener: anObject to: self eventListeners)! ! 140980 140981!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:40'! 140982addListener: anObject to: aListenerGroup 140983 "Add anObject to the given listener group. Return the new group." 140984 | listeners | 140985 listeners := aListenerGroup. 140986 (listeners notNil and:[listeners includes: anObject]) ifFalse:[ 140987 listeners 140988 ifNil:[listeners := WeakArray with: anObject] 140989 ifNotNil:[listeners := listeners copyWith: anObject]]. 140990 listeners := listeners copyWithout: nil. "obsolete entries" 140991 ^listeners! ! 140992 140993!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:42'! 140994addMouseListener: anObject 140995 "Make anObject a listener for mouse events. All mouse events will be reported to the object." 140996 self mouseListeners: (self addListener: anObject to: self mouseListeners)! ! 140997 140998!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'! 140999eventListeners 141000 ^eventListeners! ! 141001 141002!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'! 141003eventListeners: anArrayOrNil 141004 eventListeners := anArrayOrNil! ! 141005 141006!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:28'! 141007keyboardListeners 141008 ^keyboardListeners! ! 141009 141010!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:28'! 141011mouseListeners 141012 ^mouseListeners! ! 141013 141014!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'! 141015mouseListeners: anArrayOrNil 141016 mouseListeners := anArrayOrNil! ! 141017 141018!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:41'! 141019removeEventListener: anObject 141020 "Remove anObject from the current event listeners." 141021 self eventListeners: (self removeListener: anObject from: self eventListeners).! ! 141022 141023!HandMorph methodsFor: 'listeners' stamp: 'dgd 2/21/2003 22:48'! 141024removeListener: anObject from: aListenerGroup 141025 "Remove anObject from the given listener group. Return the new group." 141026 141027 | listeners | 141028 aListenerGroup ifNil: [^nil]. 141029 listeners := aListenerGroup. 141030 listeners := listeners copyWithout: anObject. 141031 listeners := listeners copyWithout: nil. "obsolete entries" 141032 listeners isEmpty ifTrue: [listeners := nil]. 141033 ^listeners! ! 141034 141035!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:41'! 141036removeMouseListener: anObject 141037 "Remove anObject from the current mouse listeners." 141038 self mouseListeners: (self removeListener: anObject from: self mouseListeners).! ! 141039 141040 141041!HandMorph methodsFor: 'meta-actions' stamp: 'ar 11/6/2000 13:07'! 141042copyToPasteBuffer: aMorph 141043 "Save this morph in the paste buffer. This is mostly useful for copying morphs between projects." 141044 aMorph ifNil:[^PasteBuffer := nil]. 141045 Cursor wait showWhile:[ 141046 PasteBuffer := aMorph topRendererOrSelf veryDeepCopy. 141047 PasteBuffer privateOwner: nil]. 141048 141049! ! 141050 141051!HandMorph methodsFor: 'meta-actions' stamp: 'adrian_lienhard 3/5/2009 22:44'! 141052grabMorph: aMorph 141053 "Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand." 141054 141055 | grabbed | 141056 aMorph = World ifTrue: [^ self]. 141057 self releaseMouseFocus. 141058 grabbed := aMorph aboutToBeGrabbedBy: self. 141059 grabbed ifNil: [^self]. 141060 grabbed := grabbed topRendererOrSelf. 141061 ^self grabMorph: grabbed from: grabbed owner! ! 141062 141063 141064!HandMorph methodsFor: 'nil' stamp: 'di 3/14/1999 10:03'! 141065cursorBounds 141066 141067 temporaryCursor == nil 141068 ifTrue: [^ self position extent: NormalCursor extent] 141069 ifFalse: [^ self position + temporaryCursorOffset 141070 extent: temporaryCursor extent]! ! 141071 141072 141073!HandMorph methodsFor: 'objects from disk' stamp: 'ar 10/5/2000 19:48'! 141074objectForDataStream: refStrm 141075 | dp | 141076 "I am about to be written on an object file. Write a path to me in the other system instead." 141077 141078 (refStrm project world hands includes: self) ifTrue: [ 141079 ^ self]. "owned by the project" 141080 dp := DiskProxy global: #World selector: #primaryHand args: #(). 141081 refStrm replace: self with: dp. 141082 ^ dp 141083 "Note, when this file is loaded in an MVC project, this will return nil. The MenuItemMorph that has this in a field will have that item not work. Maybe warn the user at load time?"! ! 141084 141085 141086!HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:10'! 141087objectToPaste 141088 "It may need to be sent #startRunning by the client" 141089 ^ Cursor wait showWhile: [PasteBuffer veryDeepCopy] 141090 141091 "PasteBuffer usableDuplicateIn: self world" 141092! ! 141093 141094!HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:10'! 141095pasteBuffer 141096 "Return the paste buffer associated with this hand" 141097 ^ PasteBuffer! ! 141098 141099!HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:11'! 141100pasteBuffer: aMorphOrNil 141101 "Set the contents of the paste buffer." 141102 PasteBuffer := aMorphOrNil. 141103 141104! ! 141105 141106!HandMorph methodsFor: 'paste buffer' stamp: 'stephane.ducasse 9/25/2008 18:08'! 141107pasteMorph 141108 141109 | aPastee | 141110 PasteBuffer ifNil: [^ self inform: 'Nothing to paste.' translated]. 141111 self attachMorph: (aPastee := self objectToPaste). 141112 aPastee align: aPastee center with: self position. 141113 ! ! 141114 141115 141116!HandMorph methodsFor: 'selected object' stamp: 'dgd 8/28/2004 16:30'! 141117selectedObject 141118 "answer the selected object for the hand or nil is none" 141119 | halo | 141120 halo := self halo. 141121 halo isNil 141122 ifTrue: [^ nil]. 141123 ^ halo target renderedMorph! ! 141124 141125 141126!HandMorph methodsFor: 'updating' stamp: 'jm 2/20/98 19:54'! 141127changed 141128 141129 hasChanged := true. 141130! ! 141131 141132 141133!HandMorph methodsFor: 'private events' stamp: 'dgd 3/31/2003 18:22'! 141134generateDropFilesEvent: evtBuf 141135 "Generate the appropriate mouse event for the given raw event buffer" 141136 141137 "Note: This is still in an experimental phase and will need more work" 141138 141139 | position buttons modifiers stamp numFiles dragType | 141140 stamp := evtBuf second. 141141 stamp = 0 ifTrue: [stamp := Time millisecondClockValue]. 141142 dragType := evtBuf third. 141143 position := evtBuf fourth @ evtBuf fifth. 141144 buttons := 0. 141145 modifiers := evtBuf sixth. 141146 buttons := buttons bitOr: (modifiers bitShift: 3). 141147 numFiles := evtBuf seventh. 141148 dragType = 4 141149 ifTrue: 141150 ["e.g., drop" 141151 141152 owner borderWidth: 0. 141153 ^DropFilesEvent new 141154 setPosition: position 141155 contents: numFiles 141156 hand: self]. 141157 "the others are currently not handled by morphs themselves" 141158 dragType = 1 141159 ifTrue: 141160 ["experimental drag enter" 141161 141162 owner 141163 borderWidth: 4; 141164 borderColor: owner color asColor negated]. 141165 dragType = 2 141166 ifTrue: 141167 ["experimental drag move" 141168 141169 ]. 141170 dragType = 3 141171 ifTrue: 141172 ["experimental drag leave" 141173 141174 owner borderWidth: 0]. 141175 ^nil! ! 141176 141177!HandMorph methodsFor: 'private events' stamp: 'michael.rueger 3/30/2009 15:29'! 141178generateKeyboardEvent: evtBuf 141179 "Generate the appropriate mouse event for the given raw event buffer" 141180 141181 | buttons modifiers type pressType stamp charCode keyValue keyEvent | 141182 stamp := evtBuf second. 141183 stamp = 0 ifTrue: [stamp := Time millisecondClockValue]. 141184 pressType := evtBuf fourth. 141185 pressType = EventKeyDown 141186 ifTrue: [ 141187 type := #keyDown. 141188 lastKeyScanCode := evtBuf third]. 141189 pressType = EventKeyUp ifTrue: [type := #keyUp]. 141190 pressType = EventKeyChar ifTrue: [ 141191 type := #keystroke]. 141192 modifiers := evtBuf fifth. 141193 buttons := modifiers bitShift: 3. 141194 keyValue := evtBuf third. 141195 charCode := evtBuf sixth. 141196 (charCode isNil 141197 or: [charCode = 0]) 141198 ifTrue: [charCode := keyValue]. 141199 141200 type = #keystroke 141201 ifTrue: [combinedChar 141202 ifNil: [ 141203 | peekedEvent | 141204 peekedEvent := Sensor peekEvent. 141205 (peekedEvent notNil 141206 and: [peekedEvent fourth = EventKeyDown]) 141207 ifTrue: [ 141208 (CombinedChar isCompositionCharacter: charCode) 141209 ifTrue: [ 141210 combinedChar := CombinedChar new. 141211 combinedChar simpleAdd: charCode asCharacter. 141212 ^nil]]] 141213 ifNotNil: [ 141214 (combinedChar simpleAdd: charCode asCharacter) 141215 ifTrue: [charCode := combinedChar combined charCode]. 141216 combinedChar := nil]]. 141217 141218 (type = #keystroke and: [(buttons anyMask: 16) 141219 and: [charCode = 30 or: [charCode = 31]]]) 141220 ifTrue: [^MouseWheelEvent new 141221 setType: #mouseWheel 141222 position: lastMouseEvent cursorPoint 141223 direction: (charCode = 30 ifTrue: [#up] ifFalse: [#down]) 141224 buttons: buttons 141225 hand: self 141226 stamp: stamp]. 141227 keyEvent := KeyboardEvent new 141228 setType: type 141229 buttons: buttons 141230 position: self position 141231 keyValue: keyValue 141232 charCode: charCode 141233 hand: self 141234 stamp: stamp. 141235 keyEvent scanCode: lastKeyScanCode. 141236 ^keyEvent 141237! ! 141238 141239!HandMorph methodsFor: 'private events' stamp: 'marcus.denker 8/24/2008 21:40'! 141240generateMouseEvent: evtBuf 141241 "Generate the appropriate mouse event for the given raw event buffer" 141242 141243 | position buttons modifiers type trail stamp oldButtons evtChanged | 141244 evtBuf first = lastEventBuffer first 141245 ifTrue: 141246 ["Workaround for Mac VM bug, *always* generating 3 events on clicks" 141247 141248 evtChanged := false. 141249 3 to: evtBuf size 141250 do: [:i | (lastEventBuffer at: i) = (evtBuf at: i) ifFalse: [evtChanged := true]]. 141251 evtChanged ifFalse: [^nil]]. 141252 stamp := evtBuf second. 141253 stamp = 0 ifTrue: [stamp := Time millisecondClockValue]. 141254 position := evtBuf third @ evtBuf fourth. 141255 buttons := evtBuf fifth. 141256 modifiers := evtBuf sixth. 141257 type := buttons = 0 141258 ifTrue: 141259 [lastEventBuffer fifth = 0 ifTrue: [#mouseMove] ifFalse: [#mouseUp]] 141260 ifFalse: 141261 [lastEventBuffer fifth = 0 141262 ifTrue: [#mouseDown] 141263 ifFalse: [#mouseMove]]. 141264 buttons := buttons bitOr: (modifiers bitShift: 3). 141265 oldButtons := lastEventBuffer fifth 141266 bitOr: (lastEventBuffer sixth bitShift: 3). 141267 lastEventBuffer := evtBuf. 141268 type == #mouseMove 141269 ifTrue: 141270 [trail := self mouseTrailFrom: evtBuf. 141271 ^MouseMoveEvent basicNew 141272 setType: type 141273 startPoint: (self position) 141274 endPoint: trail last 141275 trail: trail 141276 buttons: buttons 141277 hand: self 141278 stamp: stamp]. 141279 ^MouseButtonEvent basicNew 141280 setType: type 141281 position: position 141282 which: (oldButtons bitXor: buttons) 141283 buttons: buttons 141284 hand: self 141285 stamp: stamp! ! 141286 141287!HandMorph methodsFor: 'private events' stamp: 'PeterHugossonMiller 9/3/2009 02:00'! 141288mouseTrailFrom: currentBuf 141289 "Current event, a mouse event buffer, is about to be processed. If there are other similar mouse events queued up, then drop them from the queue, and report the positions inbetween." 141290 141291 | nextEvent trail | 141292 trail := (Array new: 1) writeStream. 141293 trail nextPut: currentBuf third @ currentBuf fourth. 141294 [(nextEvent := Sensor peekEvent) isNil] whileFalse: 141295 [nextEvent first = currentBuf first 141296 ifFalse: [^trail contents "different event type"]. 141297 nextEvent fifth = currentBuf fifth 141298 ifFalse: [^trail contents "buttons changed"]. 141299 nextEvent sixth = currentBuf sixth 141300 ifFalse: [^trail contents "modifiers changed"]. 141301 "nextEvent is similar. Remove it from the queue, and check the next." 141302 nextEvent := Sensor nextEvent. 141303 trail nextPut: nextEvent third @ nextEvent fourth]. 141304 ^trail contents! ! 141305 141306!HandMorph methodsFor: 'private events' stamp: 'marcus.denker 8/24/2008 21:40'! 141307moveToEvent: anEvent 141308 "Issue a mouse move event to make the receiver appear at the given position" 141309 self handleEvent: (MouseMoveEvent basicNew 141310 setType: #mouseMove 141311 startPoint: self position 141312 endPoint: anEvent position 141313 trail: (Array with: self position with: anEvent position) 141314 buttons: anEvent buttons 141315 hand: self 141316 stamp: anEvent timeStamp)! ! 141317 141318!HandMorph methodsFor: 'private events' stamp: 'gvc 3/25/2008 12:41'! 141319processEvents 141320 "Process user input events from the local input devices." 141321 141322 | evt evtBuf type hadAny | 141323 ActiveEvent ifNotNil: 141324 ["Meaning that we were invoked from within an event response. 141325 Make sure z-order is up to date" 141326 141327 self mouseOverHandler processMouseOver: lastMouseEvent]. 141328 hadAny := false. 141329 [(evtBuf := Sensor nextEvent) isNil] whileFalse: 141330 [evt := nil. "for unknown event types" 141331 type := evtBuf first. 141332 type = EventTypeMouse ifTrue: [evt := self generateMouseEvent: evtBuf]. 141333 type = EventTypeKeyboard 141334 ifTrue: [evt := self generateKeyboardEvent: evtBuf]. 141335 type = EventTypeDragDropFiles 141336 ifTrue: [evt := self generateDropFilesEvent: evtBuf]. 141337 "All other events are ignored" 141338 (type ~= EventTypeDragDropFiles and: [evt isNil]) ifTrue: [^self]. 141339 evt isNil 141340 ifFalse: 141341 ["Finally, handle it" 141342 141343 self handleEvent: evt. 141344 hadAny := true. 141345 141346 "For better user feedback, return immediately after a mouse event has been processed." 141347 (evt isMouse and: [evt isMouseWheel not]) ifTrue: [^self]]]. 141348 "note: if we come here we didn't have any mouse events" 141349 mouseClickState notNil 141350 ifTrue: 141351 ["No mouse events during this cycle. Make sure click states time out accordingly" 141352 141353 mouseClickState handleEvent: lastMouseEvent asMouseMove from: self]. 141354 hadAny 141355 ifFalse: 141356 ["No pending events. Make sure z-order is up to date" 141357 141358 self mouseOverHandler processMouseOver: lastMouseEvent]! ! 141359 141360!HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:43'! 141361sendEvent: anEvent focus: focusHolder 141362 "Send the event to the morph currently holding the focus, or if none to the owner of the hand." 141363 ^self sendEvent: anEvent focus: focusHolder clear:[nil]! ! 141364 141365!HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:42'! 141366sendEvent: anEvent focus: focusHolder clear: aBlock 141367 "Send the event to the morph currently holding the focus, or if none to the owner of the hand." 141368 | result | 141369 focusHolder ifNotNil:[^self sendFocusEvent: anEvent to: focusHolder clear: aBlock]. 141370 ActiveEvent := anEvent. 141371 result := owner processEvent: anEvent. 141372 ActiveEvent := nil. 141373 ^result! ! 141374 141375!HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:42'! 141376sendFocusEvent: anEvent to: focusHolder clear: aBlock 141377 "Send the event to the morph currently holding the focus" 141378 | result w | 141379 w := focusHolder world ifNil:[^ aBlock value]. 141380 w becomeActiveDuring:[ 141381 ActiveHand := self. 141382 ActiveEvent := anEvent. 141383 result := focusHolder handleFocusEvent: 141384 (anEvent transformedBy: (focusHolder transformedFrom: self)). 141385 ]. 141386 ^result! ! 141387 141388!HandMorph methodsFor: 'private events' stamp: 'rr 3/9/2006 15:36'! 141389sendKeyboardEvent: anEvent 141390 "Send the event to the morph currently holding the focus, or if none to 141391 the owner of the hand." 141392 ServiceShortcuts handleKeystroke: anEvent. 141393 ^ self 141394 sendEvent: anEvent 141395 focus: self keyboardFocus 141396 clear: [self keyboardFocus: nil]! ! 141397 141398!HandMorph methodsFor: 'private events' stamp: 'ar 10/26/2000 01:43'! 141399sendListenEvent: anEvent to: listenerGroup 141400 "Send the event to the given group of listeners" 141401 listenerGroup ifNil:[^self]. 141402 listenerGroup do:[:listener| 141403 listener ifNotNil:[listener handleListenEvent: anEvent copy]].! ! 141404 141405!HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:45'! 141406sendMouseEvent: anEvent 141407 "Send the event to the morph currently holding the focus, or if none to the owner of the hand." 141408 ^self sendEvent: anEvent focus: self mouseFocus clear:[self mouseFocus: nil]! ! 141409 141410"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 141411 141412HandMorph class 141413 instanceVariableNames: ''! 141414 141415!HandMorph class methodsFor: 'accessing' stamp: 'nk 7/30/2004 21:39'! 141416compositionWindowManager 141417 CompositionWindowManager ifNotNil: [^CompositionWindowManager]. 141418 SmalltalkImage current platformName = 'Win32' 141419 ifTrue: [^CompositionWindowManager := ImmWin32 new]. 141420 (SmalltalkImage current platformName = 'unix' 141421 and: [(SmalltalkImage current getSystemAttribute: 1005) = 'X11']) 141422 ifTrue: [^CompositionWindowManager := ImmX11 new]. 141423 ^CompositionWindowManager := ImmAbstractPlatform new! ! 141424 141425!HandMorph class methodsFor: 'accessing'! 141426doubleClickTime 141427 141428 ^ DoubleClickTime 141429! ! 141430 141431!HandMorph class methodsFor: 'accessing'! 141432doubleClickTime: milliseconds 141433 141434 DoubleClickTime := milliseconds. 141435! ! 141436 141437 141438!HandMorph class methodsFor: 'class initialization' stamp: 'kfr 7/13/2003 14:15'! 141439initialize 141440 "HandMorph initialize" 141441 141442 PasteBuffer := nil. 141443 DoubleClickTime := 350. 141444 NormalCursor := CursorWithMask normal asCursorForm. 141445! ! 141446 141447 141448!HandMorph class methodsFor: 'initialization' stamp: 'yo 8/13/2003 15:49'! 141449clearCompositionWindowManager 141450 141451 CompositionWindowManager := nil. 141452! ! 141453 141454!HandMorph class methodsFor: 'initialization' stamp: 'yo 8/13/2003 15:45'! 141455clearInterpreters 141456 141457 self allInstances do: [:each | each clearKeyboardInterpreter]. 141458! ! 141459 141460!HandMorph class methodsFor: 'initialization' stamp: 'michael.rueger 1/27/2009 17:41'! 141461startUp 141462 141463 self clearCompositionWindowManager! ! 141464 141465 141466!HandMorph class methodsFor: 'new-morph participation' stamp: 'di 6/22/97 09:07'! 141467includeInNewMorphMenu 141468 "Not to be instantiated from the menu" 141469 ^ false! ! 141470 141471 141472!HandMorph class methodsFor: 'utilities' stamp: 'sma 4/30/2000 10:34'! 141473attach: aMorph 141474 "Attach aMorph the current world's primary hand." 141475 141476 self currentWorld primaryHand attachMorph: aMorph! ! 141477 141478!HandMorph class methodsFor: 'utilities' stamp: 'nk 7/20/2003 10:03'! 141479showEvents: aBool 141480 "HandMorph showEvents: true" 141481 "HandMorph showEvents: false" 141482 ShowEvents := aBool. 141483 aBool ifFalse: [ ActiveWorld invalidRect: (0@0 extent: 250@120) ].! ! 141484EllipseMorph subclass: #HandleMorph 141485 instanceVariableNames: 'pointBlock lastPointBlock' 141486 classVariableNames: '' 141487 poolDictionaries: '' 141488 category: 'Morphic-Widgets'! 141489!HandleMorph commentStamp: '<historical>' prior: 0! 141490A HandleMorph provides mouse-up control behavior.! 141491 141492 141493!HandleMorph methodsFor: 'dropping/grabbing' stamp: 'dgd 9/10/2004 13:40'! 141494justDroppedInto: aMorph event: anEvent 141495 "So that when the hand drops me (into the world) I go away" 141496 self removeHalo. 141497 lastPointBlock ifNotNil: [lastPointBlock value: self center]. 141498 self flag: #arNote. "Probably unnecessary" 141499 anEvent hand releaseKeyboardFocus: self. 141500 self changed. 141501 self delete. 141502! ! 141503 141504 141505!HandleMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 23:30'! 141506keyStroke: evt 141507 "Check for cursor keys" 141508 | keyValue | 141509 owner isHandMorph ifFalse:[^self]. 141510 keyValue := evt keyValue. 141511 keyValue = 28 ifTrue:[^self position: self position - (1@0)]. 141512 keyValue = 29 ifTrue:[^self position: self position + (1@0)]. 141513 keyValue = 30 ifTrue:[^self position: self position - (0@1)]. 141514 keyValue = 31 ifTrue:[^self position: self position + (0@1)]. 141515 "Special case for return" 141516 keyValue = 13 ifTrue:[ 141517 "Drop the receiver and be done" 141518 self flag: #arNote. "Probably unnecessary" 141519 owner releaseKeyboardFocus: self. 141520 self delete]. 141521! ! 141522 141523 141524!HandleMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:30'! 141525initialize 141526 "initialize the state of the receiver" 141527 super initialize. 141528 "" 141529 self extent: 8 @ 8. 141530 ! ! 141531 141532 141533!HandleMorph methodsFor: 'initialize' stamp: 'di 11/3/97 16:34'! 141534forEachPointDo: aBlock 141535 pointBlock := aBlock! ! 141536 141537!HandleMorph methodsFor: 'initialize' stamp: 'di 8/30/2000 21:48'! 141538forEachPointDo: aBlock lastPointDo: otherBlock 141539 pointBlock := aBlock. 141540 lastPointBlock := otherBlock! ! 141541 141542 141543!HandleMorph methodsFor: 'stepping and presenter' stamp: 'ar 9/15/2000 23:24'! 141544startStepping 141545 "Make the receiver the keyboard focus for editing" 141546 super startStepping. 141547 "owner isHandMorph ifTrue:[owner newKeyboardFocus: self]." 141548self flag: #arNote. "make me #handleKeyboard:"! ! 141549 141550!HandleMorph methodsFor: 'stepping and presenter' stamp: 'di 11/3/97 16:34'! 141551step 141552 pointBlock value: self center! ! 141553 141554 141555!HandleMorph methodsFor: 'testing' stamp: 'JMM 10/21/2003 18:15'! 141556stepTime 141557 "Update every hundredth of a second." 141558 ^ 10 141559! ! 141560TestCase subclass: #HashAndEqualsTestCase 141561 instanceVariableNames: 'prototypes' 141562 classVariableNames: '' 141563 poolDictionaries: '' 141564 category: 'SUnit-Utilities'! 141565!HashAndEqualsTestCase commentStamp: 'mjr 8/20/2003 17:37' prior: 0! 141566I am a simple TestCase that tests for correct operation of #hash and #=. 141567 141568Subclasses of me need to fill my prototypes with suitable objects to be tested.! 141569 141570 141571!HashAndEqualsTestCase methodsFor: 'running' stamp: 'stephaneducasse 2/3/2006 22:39'! 141572setUp 141573 "subclasses will add their prototypes into this collection" 141574 prototypes := OrderedCollection new ! ! 141575 141576 141577!HashAndEqualsTestCase methodsFor: 'testing' stamp: 'mjr 8/20/2003 18:56'! 141578testEquality 141579 "Check that TextFontChanges report equality correctly" 141580 prototypes 141581 do: [:p | self 141582 should: [(EqualityTester with: p) result]] ! ! 141583 141584!HashAndEqualsTestCase methodsFor: 'testing' stamp: 'al 6/12/2008 21:58'! 141585testHash 141586 "test that TextFontChanges hash correctly" 141587 prototypes do: [:p | 141588 self should: [(HashTester with: p) result]] ! ! 141589Object subclass: #HashFunction 141590 instanceVariableNames: '' 141591 classVariableNames: '' 141592 poolDictionaries: '' 141593 category: 'System-Hashing-Core'! 141594 141595!HashFunction methodsFor: 'accessing' stamp: 'len 8/15/2002 01:43'! 141596blockSize 141597 ^ self class blockSize! ! 141598 141599!HashFunction methodsFor: 'accessing' stamp: 'cmm 2/20/2006 23:22'! 141600doubleHashMessage: aStringOrByteArray 141601 "SHA1 new doubleHashMessage: 'foo'" 141602 ^ self doubleHashStream: aStringOrByteArray asByteArray readStream! ! 141603 141604!HashFunction methodsFor: 'accessing' stamp: 'cmm 2/20/2006 23:21'! 141605doubleHashStream: aStream 141606 ^ self hashStream: ((self hashStream: aStream) asByteArray readStream)! ! 141607 141608!HashFunction methodsFor: 'accessing' stamp: 'len 8/7/2002 16:30'! 141609hashMessage: aStringOrByteArray 141610 "MD5 new hashMessage: 'foo'" 141611 ^ self hashStream: aStringOrByteArray asByteArray readStream! ! 141612 141613!HashFunction methodsFor: 'accessing' stamp: 'len 8/9/2002 13:17'! 141614hashSize 141615 ^ self class hashSize! ! 141616 141617!HashFunction methodsFor: 'accessing' stamp: 'len 8/2/2002 02:21'! 141618hashStream: aStream 141619 ^ self subclassResponsibility! ! 141620 141621 141622!HashFunction methodsFor: 'converting' stamp: 'len 8/3/2002 02:42'! 141623hmac 141624 ^ HMAC on: self! ! 141625 141626"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 141627 141628HashFunction class 141629 instanceVariableNames: ''! 141630 141631!HashFunction class methodsFor: 'accessing' stamp: 'len 8/15/2002 01:43'! 141632blockSize 141633 ^ self subclassResponsibility! ! 141634 141635!HashFunction class methodsFor: 'accessing' stamp: 'len 8/9/2002 13:17'! 141636hashSize 141637 ^ self subclassResponsibility! ! 141638 141639 141640!HashFunction class methodsFor: 'hashing' stamp: 'len 8/2/2002 02:20'! 141641hashMessage: aStringOrByteArray 141642 ^ self new hashMessage: aStringOrByteArray! ! 141643 141644!HashFunction class methodsFor: 'hashing' stamp: 'len 8/2/2002 02:20'! 141645hashStream: aPositionableStream 141646 ^ self new hashStream: aPositionableStream! ! 141647PrototypeTester subclass: #HashTester 141648 instanceVariableNames: '' 141649 classVariableNames: '' 141650 poolDictionaries: '' 141651 category: 'SUnit-Utilities'! 141652!HashTester commentStamp: 'mjr 8/20/2003 12:48' prior: 0! 141653I provide a simple way to test the hash properties of any object. 141654 141655I am given an object that should be tested and I treat it like a prototype. I take a copy of it when I am given it so that it can't change whilst I am holding on to it. I can then test that multiple copies of this object all hash to the same value.! 141656 141657 141658!HashTester methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/3/2006 22:39'! 141659resultFor: runs 141660 "Test that the hash is the same over runs and answer the result" 141661 | hash | 141662 hash := self prototype hash. 141663 1 141664 to: runs 141665 do: [:i | hash = self prototype hash 141666 ifFalse: [^ false]]. 141667 ^ true ! ! 141668TestCase subclass: #HashTesterTest 141669 instanceVariableNames: '' 141670 classVariableNames: '' 141671 poolDictionaries: '' 141672 category: 'SUnit-Utilities'! 141673!HashTesterTest commentStamp: 'mjr 8/20/2003 12:48' prior: 0! 141674I am a simple test case to check that HashTester works correctly! 141675 141676 141677!HashTesterTest methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! 141678testBasicBehaviour 141679 self 141680 should: [(HashTester with: 1) 141681 resultFor: 100]. 141682 self 141683 should: [(HashTester with: 'fred') 141684 resultFor: 100]. 141685 self 141686 shouldnt: [(HashTester with: BadHasher new) 141687 resultFor: 100] ! ! 141688SequenceableCollection subclass: #Heap 141689 instanceVariableNames: 'array tally sortBlock indexUpdateBlock' 141690 classVariableNames: '' 141691 poolDictionaries: '' 141692 category: 'Collections-Sequenceable'! 141693!Heap commentStamp: '<historical>' prior: 0! 141694Class Heap implements a special data structure commonly referred to as 'heap'. Heaps are more efficient than SortedCollections if: 141695a) Elements are only removed at the beginning 141696b) Elements are added with arbitrary sort order. 141697The sort time for a heap is O(n log n) in all cases. 141698 141699Instance variables: 141700 array <Array> The data repository 141701 tally <Integer> The number of elements in the heap 141702 sortBlock <Block|nil> A two-argument block defining the sort order, 141703 or nil in which case the default sort order is 141704 [:element1 :element2| element1 <= element2] 141705 indexUpdateBlock <Block|nil> 141706 A two-argument block of the form [:data :index | ... ] 141707 which allows an application object to keep track of its 141708 index within the heap. Useful for quick heap update 141709 when object's sort value changes (for example, when an 141710 object in a priority queue has its priority increased 141711 by an external event, you don't want to have to search 141712 through the whole heap to find the index before fixing 141713 the heap). No update occurs if nil.! 141714 141715 141716!Heap methodsFor: 'accessing' stamp: 'ar 9/10/1999 13:02'! 141717at: index 141718 "Return the element at the given position within the receiver" 141719 (index < 1 or:[index > tally]) ifTrue:[^self errorSubscriptBounds: index]. 141720 ^array at: index! ! 141721 141722!Heap methodsFor: 'accessing' stamp: 'ar 7/1/1999 04:14'! 141723at: index put: newObject 141724 "Heaps are accessed with #add: not #at:put:" 141725 ^self shouldNotImplement! ! 141726 141727!Heap methodsFor: 'accessing' stamp: 'md 1/19/2006 09:56'! 141728first 141729 "Return the first element in the receiver" 141730 ^array at: 1! ! 141731 141732!Heap methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 21:05'! 141733indexUpdateBlock: aBlockOrNil 141734 141735 indexUpdateBlock := aBlockOrNil. 141736 141737! ! 141738 141739!Heap methodsFor: 'accessing' stamp: 'ar 9/10/1999 14:08'! 141740reSort 141741 "Resort the entire heap" 141742 self isEmpty ifTrue:[^self]. 141743 tally // 2 to: 1 by: -1 do:[:i| self downHeap: i].! ! 141744 141745!Heap methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:37'! 141746size 141747 "Answer how many elements the receiver contains." 141748 141749 ^ tally! ! 141750 141751!Heap methodsFor: 'accessing' stamp: 'ar 7/1/1999 04:21'! 141752sortBlock 141753 ^sortBlock! ! 141754 141755!Heap methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 21:05'! 141756sortBlock: aBlock 141757 sortBlock := aBlock. 141758 self reSort.! ! 141759 141760 141761!Heap methodsFor: 'adding' stamp: 'jcg 3/8/2003 02:07'! 141762add: anObject 141763 "Include newObject as one of the receiver's elements. Answer newObject." 141764 tally = array size ifTrue:[self grow]. 141765 array at: (tally := tally + 1) put: anObject. 141766 self updateObjectIndex: tally. 141767 self upHeap: tally. 141768 ^anObject! ! 141769 141770 141771!Heap methodsFor: 'comparing' stamp: 'rhi 8/14/2003 10:05'! 141772= anObject 141773 141774 ^ self == anObject 141775 ifTrue: [true] 141776 ifFalse: [anObject isHeap 141777 ifTrue: [sortBlock = anObject sortBlock and: [super = anObject]] 141778 ifFalse: [super = anObject]]! ! 141779 141780 141781!Heap methodsFor: 'enumerating' stamp: 'ar 9/10/1999 13:05'! 141782do: aBlock 141783 "Evaluate aBlock with each of the receiver's elements as the argument." 141784 1 to: tally do:[:i| aBlock value: (array at: i)]! ! 141785 141786 141787!Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:17'! 141788grow 141789 "Become larger." 141790 self growTo: self size + self growSize.! ! 141791 141792!Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'! 141793growSize 141794 "Return the size by which the receiver should grow if there are no empty slots left." 141795 ^array size max: 5! ! 141796 141797!Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'! 141798growTo: newSize 141799 "Grow to the requested size." 141800 | newArray | 141801 newArray := Array new: (newSize max: tally). 141802 newArray replaceFrom: 1 to: array size with: array startingAt: 1. 141803 array := newArray! ! 141804 141805!Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'! 141806trim 141807 "Remove any empty slots in the receiver." 141808 self growTo: self size.! ! 141809 141810 141811!Heap methodsFor: 'removing' stamp: 'ar 9/10/1999 13:04'! 141812remove: oldObject ifAbsent: aBlock 141813 "Remove oldObject as one of the receiver's elements. If several of the 141814 elements are equal to oldObject, only one is removed. If no element is 141815 equal to oldObject, answer the result of evaluating anExceptionBlock. 141816 Otherwise, answer the argument, oldObject." 141817 1 to: tally do:[:i| 141818 (array at: i) = oldObject ifTrue:[^self privateRemoveAt: i]]. 141819 ^aBlock value! ! 141820 141821!Heap methodsFor: 'removing' stamp: 'ar 9/10/1999 13:05'! 141822removeAt: index 141823 "Remove the element at given position" 141824 (index < 1 or:[index > tally]) ifTrue:[^self errorSubscriptBounds: index]. 141825 ^self privateRemoveAt: index! ! 141826 141827!Heap methodsFor: 'removing' stamp: 'ar 9/10/1999 13:05'! 141828removeFirst 141829 "Remove the first element from the receiver" 141830 ^self removeAt: 1! ! 141831 141832 141833!Heap methodsFor: 'testing' stamp: 'ar 9/10/1999 13:03'! 141834isEmpty 141835 "Answer whether the receiver contains any elements." 141836 ^tally = 0! ! 141837 141838!Heap methodsFor: 'testing' stamp: 'rhi 8/14/2003 08:51'! 141839isHeap 141840 141841 ^ true! ! 141842 141843!Heap methodsFor: 'testing' stamp: 'ar 9/10/1999 13:03'! 141844sorts: element1 before: element2 141845 "Return true if element1 should be sorted before element2. 141846 This method defines the sort order in the receiver" 141847 ^sortBlock == nil 141848 ifTrue:[element1 <= element2] 141849 ifFalse:[sortBlock value: element1 value: element2].! ! 141850 141851 141852!Heap methodsFor: 'private' stamp: 'ar 7/1/1999 04:19'! 141853array 141854 ^array! ! 141855 141856!Heap methodsFor: 'private' stamp: 'ar 9/15/2000 17:12'! 141857privateRemoveAt: index 141858 "Remove the element at the given index and make sure the sorting order is okay" 141859 | removed | 141860 removed := array at: index. 141861 array at: index put: (array at: tally). 141862 array at: tally put: nil. 141863 tally := tally - 1. 141864 index > tally ifFalse:[ 141865 "Use #downHeapSingle: since only one element has been removed" 141866 self downHeapSingle: index]. 141867 ^removed! ! 141868 141869!Heap methodsFor: 'private' stamp: 'ar 7/1/1999 04:35'! 141870setCollection: aCollection 141871 array := aCollection. 141872 tally := 0.! ! 141873 141874!Heap methodsFor: 'private' stamp: 'ar 9/10/1999 13:18'! 141875setCollection: aCollection tally: newTally 141876 array := aCollection. 141877 tally := newTally.! ! 141878 141879!Heap methodsFor: 'private' stamp: 'sma 4/22/2000 19:30'! 141880species 141881 ^ Array! ! 141882 141883!Heap methodsFor: 'private' stamp: 'jcg 3/8/2003 02:08'! 141884updateObjectIndex: index 141885 "If indexUpdateBlock is not nil, notify the object at index of its new position in the heap array." 141886 indexUpdateBlock ifNotNil: [ 141887 indexUpdateBlock value: (array at: index) value: index]! ! 141888 141889 141890!Heap methodsFor: 'private-heap' stamp: 'jcg 3/8/2003 02:11'! 141891downHeap: anIndex 141892 "Check the heap downwards for correctness starting at anIndex. 141893 Everything above (i.e. left of) anIndex is ok." 141894 | value k n j | 141895 anIndex = 0 ifTrue:[^self]. 141896 n := tally bitShift: -1. 141897 k := anIndex. 141898 value := array at: anIndex. 141899 [k <= n] whileTrue:[ 141900 j := k + k. 141901 "use max(j,j+1)" 141902 (j < tally and:[self sorts: (array at: j+1) before: (array at: j)]) 141903 ifTrue:[ j := j + 1]. 141904 "check if position k is ok" 141905 (self sorts: value before: (array at: j)) 141906 ifTrue:[ "yes -> break loop" 141907 n := k - 1] 141908 ifFalse:[ "no -> make room at j by moving j-th element to k-th position" 141909 array at: k put: (array at: j). 141910 self updateObjectIndex: k. 141911 "and try again with j" 141912 k := j]]. 141913 array at: k put: value. 141914 self updateObjectIndex: k.! ! 141915 141916!Heap methodsFor: 'private-heap' stamp: 'jcg 3/8/2003 02:11'! 141917downHeapSingle: anIndex 141918 "This version is optimized for the case when only one element in the receiver can be at a wrong position. It avoids one comparison at each node when travelling down the heap and checks the heap upwards after the element is at a bottom position. Since the probability for being at the bottom of the heap is much larger than for being somewhere in the middle this version should be faster." 141919 | value k n j | 141920 anIndex = 0 ifTrue:[^self]. 141921 n := tally bitShift: -1. 141922 k := anIndex. 141923 value := array at: anIndex. 141924 [k <= n] whileTrue:[ 141925 j := k + k. 141926 "use max(j,j+1)" 141927 (j < tally and:[self sorts: (array at: j+1) before: (array at: j)]) 141928 ifTrue:[ j := j + 1]. 141929 array at: k put: (array at: j). 141930 self updateObjectIndex: k. 141931 "and try again with j" 141932 k := j]. 141933 array at: k put: value. 141934 self updateObjectIndex: k. 141935 self upHeap: k! ! 141936 141937!Heap methodsFor: 'private-heap' stamp: 'jcg 3/8/2003 02:12'! 141938upHeap: anIndex 141939 "Check the heap upwards for correctness starting at anIndex. 141940 Everything below anIndex is ok." 141941 | value k kDiv2 tmp | 141942 anIndex = 0 ifTrue:[^self]. 141943 k := anIndex. 141944 value := array at: anIndex. 141945 [ (k > 1) and:[self sorts: value before: (tmp := array at: (kDiv2 := k bitShift: -1))] ] 141946 whileTrue:[ 141947 array at: k put: tmp. 141948 self updateObjectIndex: k. 141949 k := kDiv2]. 141950 array at: k put: value. 141951 self updateObjectIndex: k.! ! 141952 141953"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 141954 141955Heap class 141956 instanceVariableNames: ''! 141957 141958!Heap class methodsFor: 'instance creation' stamp: 'ar 7/1/1999 04:20'! 141959new 141960 ^self new: 10! ! 141961 141962!Heap class methodsFor: 'instance creation' stamp: 'ar 7/1/1999 04:20'! 141963new: n 141964 ^super new setCollection: (Array new: n)! ! 141965 141966!Heap class methodsFor: 'instance creation' stamp: 'ar 9/10/1999 14:13'! 141967sortBlock: aBlock 141968 "Create a new heap sorted by the given block" 141969 ^self new sortBlock: aBlock! ! 141970 141971!Heap class methodsFor: 'instance creation' stamp: 'ar 9/10/1999 13:23'! 141972withAll: aCollection 141973 "Create a new heap with all the elements from aCollection" 141974 ^(self basicNew) 141975 setCollection: aCollection asArray copy tally: aCollection size; 141976 reSort; 141977 yourself! ! 141978 141979!Heap class methodsFor: 'instance creation' stamp: 'ar 5/23/2001 17:22'! 141980withAll: aCollection sortBlock: sortBlock 141981 "Create a new heap with all the elements from aCollection" 141982 ^(self basicNew) 141983 setCollection: aCollection asArray copy tally: aCollection size; 141984 sortBlock: sortBlock; 141985 yourself! ! 141986CollectionRootTest subclass: #HeapTest 141987 uses: TAddTest + TGrowableTest + TSequencedElementAccessTest + TIndexAccess + TIndexAccessForMultipliness + TSubCollectionAccess + TPrintOnSequencedTest + TAsStringCommaAndDelimiterSequenceableTest + TConvertTest + TConvertAsSortedTest + TConvertAsSetForMultiplinessIdentityTest + TBeginsEndsWith + TCopyTest + TCopySequenceableSameContents + TCopySequenceableWithReplacementForSorted + TCopySequenceableWithOrWithoutSpecificElements + TCopyPartOfSequenceable - {#testCopyEmptyMethod} + TCopyPartOfSequenceableForMultipliness + TSetArithmetic + TIterateSequencedReadableTest + TRemoveForMultiplenessTest + TReplacementSequencedTest + TOccurrencesForMultiplinessTest + TSequencedStructuralEqualityTest + TCreationWithTest - {#testOfSize} + TSequencedConcatenationTest + TIncludesWithIdentityCheckTest 141988 instanceVariableNames: 'collectionWithElement otherCollection nonEmpty empty collection elementNotIn result expectedElementByDetect speciesClass elementTwiceIn doWithoutNumber element expectedSizeAfterReject collectionNotIncluded nonEmpty5ElementsWithoutDuplicate sameAtEndAndBegining nonEmpty1Element floatCollection indexArray subCollection duplicateElement collectionWithDuplicateElement' 141989 classVariableNames: '' 141990 poolDictionaries: '' 141991 category: 'CollectionsTests-Sequenceable'! 141992 141993!HeapTest methodsFor: 'basic tests' stamp: 'stephane.ducasse 5/20/2009 18:11'! 141994testAdd 141995 "self run: #testAdd" 141996 141997 | heap | 141998 heap := Heap new. 141999 self assert: heap size = 0. 142000 heap add: 3. 142001 self assert: heap size = 1. 142002 self assert: heap isEmpty not. 142003 self assert: heap first = 3. 142004 self assert: (heap at: 1) = 3. 142005 heap add: 2. 142006 self assert: heap size = 2. 142007 self assert: heap first = 2. 142008 self assert: (heap at: 2) = 3. 142009 ! ! 142010 142011!HeapTest methodsFor: 'basic tests' stamp: 'stephane.ducasse 5/20/2009 18:11'! 142012testAt 142013 "self run: #testAt" 142014 142015 | heap | 142016 heap := Heap new. 142017 heap add: 3. 142018 self assert: (heap at: 1) = 3. 142019 self should: [heap at: 2] raise: Error. 142020 heap add: 4. 142021 self assert: (heap at: 1) = 3. 142022 self assert: (heap at: 2) = 4. 142023 142024 ! ! 142025 142026!HeapTest methodsFor: 'basic tests' stamp: 'stephane.ducasse 5/20/2009 18:11'! 142027testDo 142028 "self run: #testDo" 142029 142030 | heap coll | 142031 heap := Heap withAll: #(1 3 5). 142032 coll := OrderedCollection new. 142033 142034 heap do: [:each | coll add: each]. 142035 142036 self assert: coll = #(1 3 5) asOrderedCollection. 142037! ! 142038 142039!HeapTest methodsFor: 'basic tests' stamp: 'stephane.ducasse 5/20/2009 18:11'! 142040testFirst 142041 "self run: #testFirst" 142042 | heap | 142043 heap := Heap new. 142044 heap add: 5. 142045 heap add: 12. 142046 heap add: 1. 142047 self assert: heap first = 1. 142048 heap removeFirst. 142049 self assert: heap first = 5.! ! 142050 142051!HeapTest methodsFor: 'basic tests' stamp: 'stephane.ducasse 5/20/2009 18:11'! 142052testHeap 142053 "self run: #testHeap" 142054 142055 | heap | 142056 heap := Heap new. 142057 self assert: heap isHeap. 142058 142059 self assert: heap isEmpty. 142060 heap add: 1. 142061 self assert: heap isEmpty not 142062 142063! ! 142064 142065!HeapTest methodsFor: 'basic tests' stamp: 'stephane.ducasse 5/20/2009 18:11'! 142066testRemove 142067 "self run: #testRemove" 142068 142069 | heap | 142070 heap := Heap new. 142071 self should: [heap removeFirst] raise: Error. 142072 heap add: 5. 142073 self shouldnt: [heap removeFirst] raise: Error. 142074 self assert: heap size = 0. 142075 heap add: 5. 142076 self should: [heap removeAt: 2] raise: Error.! ! 142077 142078!HeapTest methodsFor: 'basic tests' stamp: 'stephane.ducasse 5/20/2009 18:11'! 142079testSortBlock 142080 "self run: #testSortBlock" 142081 142082 | heap | 142083 heap := Heap withAll: #(1 3 5). 142084 self assert: heap = #(1 3 5). 142085 142086 heap sortBlock: [ :e1 :e2 | e1 >= e2 ]. 142087 self assert: heap = #(5 3 1) 142088! ! 142089 142090 142091!HeapTest methodsFor: 'examples' stamp: 'md 2/12/2006 15:33'! 142092heapExample "HeapTest new heapExample" 142093 "Create a sorted collection of numbers, remove the elements 142094 sequentially and add new objects randomly. 142095 Note: This is the kind of benchmark a heap is designed for." 142096 | n rnd array time sorted | 142097 n := 5000. "# of elements to sort" 142098 rnd := Random new. 142099 array := (1 to: n) collect:[:i| rnd next]. 142100 "First, the heap version" 142101 time := Time millisecondsToRun:[ 142102 sorted := Heap withAll: array. 142103 1 to: n do:[:i| 142104 sorted removeFirst. 142105 sorted add: rnd next]. 142106 ]. 142107 Transcript cr; show:'Time for Heap: ', time printString,' msecs'. 142108 "The quicksort version" 142109 time := Time millisecondsToRun:[ 142110 sorted := SortedCollection withAll: array. 142111 1 to: n do:[:i| 142112 sorted removeFirst. 142113 sorted add: rnd next]. 142114 ]. 142115 Transcript cr; show:'Time for SortedCollection: ', time printString,' msecs'. 142116! ! 142117 142118!HeapTest methodsFor: 'examples' stamp: 'md 2/12/2006 15:34'! 142119heapSortExample "HeapTest new heapSortExample" 142120 "Sort a random collection of Floats and compare the results with 142121 SortedCollection (using the quick-sort algorithm) and 142122 ArrayedCollection>>mergeSortFrom:to:by: (using the merge-sort algorithm)." 142123 | n rnd array time sorted | 142124 n := 10000. "# of elements to sort" 142125 rnd := Random new. 142126 array := (1 to: n) collect:[:i| rnd next]. 142127 "First, the heap version" 142128 time := Time millisecondsToRun:[ 142129 sorted := Heap withAll: array. 142130 1 to: n do:[:i| sorted removeFirst]. 142131 ]. 142132 Transcript cr; show:'Time for heap-sort: ', time printString,' msecs'. 142133 "The quicksort version" 142134 time := Time millisecondsToRun:[ 142135 sorted := SortedCollection withAll: array. 142136 ]. 142137 Transcript cr; show:'Time for quick-sort: ', time printString,' msecs'. 142138 "The merge-sort version" 142139 time := Time millisecondsToRun:[ 142140 array mergeSortFrom: 1 to: array size by: [:v1 :v2| v1 <= v2]. 142141 ]. 142142 Transcript cr; show:'Time for merge-sort: ', time printString,' msecs'. 142143! ! 142144 142145 142146!HeapTest methodsFor: 'parameters' stamp: 'cyrille.delaunay 3/20/2009 13:22'! 142147valuePutIn 142148 "the value that we will put in the non empty collection" 142149 142150 ^ 7! ! 142151 142152 142153!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:17'! 142154aValue 142155" return a value to put into nonEmpty" 142156 ^ self nonEmpty anyOne ! ! 142157 142158!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:12'! 142159accessCollection 142160 ^ nonEmpty5ElementsWithoutDuplicate! ! 142161 142162!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 15:44'! 142163anotherElementNotIn 142164" return an element different of 'elementNotIn' not included in 'nonEmpty' " 142165 ^ 9999! ! 142166 142167!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:43'! 142168anotherElementOrAssociationIn 142169 " return an element (or an association for Dictionary ) present in 'collection' " 142170 ^ self collection anyOne! ! 142171 142172!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:43'! 142173anotherElementOrAssociationNotIn 142174 " return an element (or an association for Dictionary )not present in 'collection' " 142175 ^ elementNotIn ! ! 142176 142177!HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 10:17'! 142178collection 142179 ^ collection.! ! 142180 142181!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:42'! 142182collectionClass 142183" return the class to be used to create instances of the class tested" 142184 ^ Heap! ! 142185 142186!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 09:55'! 142187collectionMoreThan1NoDuplicates 142188 " return a collection of size > 1 without equal elements" 142189 ^ nonEmpty5ElementsWithoutDuplicate ! ! 142190 142191!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:00'! 142192collectionMoreThan5Elements 142193" return a collection including at least 5 elements" 142194 142195 ^nonEmpty5ElementsWithoutDuplicate ! ! 142196 142197!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:26'! 142198collectionNotIncluded 142199" return a collection for wich each element is not included in 'nonEmpty' " 142200 ^ collectionNotIncluded ! ! 142201 142202!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:34'! 142203collectionOfSize5 142204" return a collection of size 5" 142205^ nonEmpty5ElementsWithoutDuplicate ! ! 142206 142207!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:01'! 142208collectionWith5Elements 142209" return a collection of size 5 including 5 elements" 142210^ nonEmpty5ElementsWithoutDuplicate ! ! 142211 142212!HeapTest methodsFor: 'requirements'! 142213collectionWithCopy 142214 "return a collection of type 'self collectionWIithoutEqualsElements class' containing no elements equals ( with identity equality) 142215 but 2 elements only equals with classic equality" 142216 | result collection | 142217 collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. 142218 collection add: collection first copy. 142219 result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. 142220 ^ result! ! 142221 142222!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 15:44'! 142223collectionWithCopyNonIdentical 142224 " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" 142225 ^ floatCollection ! ! 142226 142227!HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/18/2009 15:07'! 142228collectionWithElement 142229 ^ collectionWithElement! ! 142230 142231!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:26'! 142232collectionWithElementsToRemove 142233" return a collection of elements included in 'nonEmpty' " 142234 ^ self nonEmpty ! ! 142235 142236!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:06'! 142237collectionWithEqualElements 142238" return a collecition including atLeast two elements equal" 142239 142240^ collectionWithDuplicateElement ! ! 142241 142242!HeapTest methodsFor: 'requirements'! 142243collectionWithIdentical 142244 "return a collection of type : 'self collectionWIithoutEqualsElements class containing two elements equals ( with identity equality)" 142245 | result collection element | 142246 collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. 142247 element := collection first. 142248 collection add: element. 142249 result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. 142250 ^ result! ! 142251 142252!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:01'! 142253collectionWithNonIdentitySameAtEndAndBegining 142254 " return a collection with elements at end and begining equals only with classic equality (they are not the same object). 142255(others elements of the collection are not equal to those elements)" 142256 ^ sameAtEndAndBegining ! ! 142257 142258!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:01'! 142259collectionWithSameAtEndAndBegining 142260 " return a collection with elements at end and begining equals . 142261(others elements of the collection are not equal to those elements)" 142262 ^ sameAtEndAndBegining ! ! 142263 142264!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:13'! 142265collectionWithSortableElements 142266" return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" 142267 ^ nonEmpty5ElementsWithoutDuplicate ! ! 142268 142269!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:12'! 142270collectionWithoutEqualElements 142271" return a collection without equal elements" 142272 ^ nonEmpty5ElementsWithoutDuplicate ! ! 142273 142274!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:40'! 142275collectionWithoutEqualsElements 142276 142277" return a collection not including equal elements " 142278 ^ nonEmpty5ElementsWithoutDuplicate ! ! 142279 142280!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:23'! 142281collectionWithoutNilElements 142282" return a collection that doesn't includes a nil element and that doesn't includes equal elements'" 142283 ^ nonEmpty5ElementsWithoutDuplicate ! ! 142284 142285!HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 13:37'! 142286element 142287 ^ element! ! 142288 142289!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:10'! 142290elementInForElementAccessing 142291" return an element inculded in 'moreThan4Elements'" 142292 ^ self moreThan4Elements anyOne.! ! 142293 142294!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 09:57'! 142295elementInForIndexAccessing 142296" return an element included in 'collectionMoreThan1NoDuplicates' " 142297 ^ self collectionMoreThan1NoDuplicates anyOne.! ! 142298 142299!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:18'! 142300elementInForOccurrences 142301 ^self nonEmpty anyOne! ! 142302 142303!HeapTest methodsFor: 'requirements'! 142304elementInForReplacement 142305" return an element included in 'nonEmpty' " 142306^ self nonEmpty anyOne.! ! 142307 142308!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:15'! 142309elementNotIn 142310 ^ elementNotIn ! ! 142311 142312!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:11'! 142313elementNotInForElementAccessing 142314" return an element not included in 'moreThan4Elements' " 142315 ^ elementNotIn ! ! 142316 142317!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 09:56'! 142318elementNotInForIndexAccessing 142319" return an element not included in 'collectionMoreThan1NoDuplicates' " 142320 ^ elementNotIn ! ! 142321 142322!HeapTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 11:53'! 142323elementNotInForOccurrences 142324 ^ elementNotIn! ! 142325 142326!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:28'! 142327elementToAdd 142328" return an element of type 'nonEmpy' elements'type'" 142329 ^ elementNotIn ! ! 142330 142331!HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 11:33'! 142332elementTwiceIn 142333 ^elementTwiceIn! ! 142334 142335!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:06'! 142336elementTwiceInForOccurrences 142337" return an element included exactly two time in # collectionWithEqualElements" 142338^ duplicateElement ! ! 142339 142340!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:15'! 142341elementsCopyNonIdenticalWithoutEqualElements 142342 " return a collection that does niot incllude equal elements ( classic equality ) 142343 all elements included are elements for which copy is not identical to the element " 142344 ^ floatCollection ! ! 142345 142346!HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/18/2009 15:24'! 142347empty 142348 ^empty.! ! 142349 142350!HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 11:19'! 142351expectedElementByDetect 142352 "Returns the first even element of #collection" 142353 ^ expectedElementByDetect. 142354 142355 ! ! 142356 142357!HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 13:46'! 142358expectedSizeAfterReject 142359 "Number of even elements in #collection" 142360 ^ expectedSizeAfterReject.! ! 142361 142362!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:43'! 142363firstCollection 142364" return a collection that will be the first part of the concatenation" 142365 ^nonEmpty ! ! 142366 142367!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:05'! 142368firstIndex 142369" return an index between 'nonEmpty' bounds that is < to 'second index' " 142370 ^2! ! 142371 142372!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:19'! 142373indexArray 142374" return a Collection including indexes between bounds of 'nonEmpty' " 142375 142376 ^ indexArray ! ! 142377 142378!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:39'! 142379indexInForCollectionWithoutDuplicates 142380" return an index between 'collectionWithoutEqualsElements' bounds" 142381 ^ 2! ! 142382 142383!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:35'! 142384indexInNonEmpty 142385" return an index between bounds of 'nonEmpty' " 142386 142387 ^2! ! 142388 142389!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:12'! 142390integerCollectionWithoutEqualElements 142391" return a collection of integer without equal elements" 142392 ^ nonEmpty5ElementsWithoutDuplicate ! ! 142393 142394!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:07'! 142395moreThan3Elements 142396 " return a collection including atLeast 3 elements" 142397 ^ nonEmpty5ElementsWithoutDuplicate ! ! 142398 142399!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:12'! 142400moreThan4Elements 142401 142402" return a collection including at leat 4 elements" 142403 ^ nonEmpty5ElementsWithoutDuplicate ! ! 142404 142405!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:06'! 142406newElement 142407"return an element that will be put in the collection in place of another" 142408 ^ elementNotIn ! ! 142409 142410!HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/18/2009 15:23'! 142411nonEmpty 142412 ^nonEmpty.! ! 142413 142414!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:11'! 142415nonEmpty1Element 142416" return a collection of size 1 including one element" 142417 ^ nonEmpty1Element ! ! 142418 142419!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:44'! 142420nonEmptyMoreThan1Element 142421" return a collection that don't includes equal elements'" 142422 ^nonEmpty5ElementsWithoutDuplicate .! ! 142423 142424!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:53'! 142425nonEmptyWithoutEqualElements 142426" return a collection without equal elements " 142427 ^ nonEmpty5ElementsWithoutDuplicate ! ! 142428 142429!HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/18/2009 15:08'! 142430otherCollection 142431 ^ otherCollection! ! 142432 142433!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:35'! 142434replacementCollection 142435" return a collection including elements of type 'collectionOfSize5' elements'type" 142436^ collection ! ! 142437 142438!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:09'! 142439replacementCollectionSameSize 142440" return a collection of size (secondIndex - firstIndex + 1)" 142441 ^subCollection ! ! 142442 142443!HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 10:34'! 142444result 142445 ^result.! ! 142446 142447!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:43'! 142448secondCollection 142449" return a collection that will be the second part of the concatenation" 142450 ^ nonEmpty5ElementsWithoutDuplicate ! ! 142451 142452!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:06'! 142453secondIndex 142454" return an index between 'nonEmpty' bounds that is > to 'second index' " 142455 ^3! ! 142456 142457!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:24'! 142458sizeCollection 142459 "Answers a collection whose #size is 4" 142460 ^collection ! ! 142461 142462!HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 11:26'! 142463speciesClass 142464 142465 ^ speciesClass! ! 142466 142467!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:13'! 142468subCollectionNotIn 142469" return a collection for which at least one element is not included in 'moreThan4Elements' " 142470 ^ collectionNotIncluded ! ! 142471 142472!HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:13'! 142473withEqualElements 142474 ^ sameAtEndAndBegining ! ! 142475 142476 142477!HeapTest methodsFor: 'running' stamp: 'delaunay 5/13/2009 16:05'! 142478setUp 142479 element := 33. 142480 elementNotIn := 666. 142481 elementTwiceIn := 3. 142482 expectedSizeAfterReject := 1. 142483 expectedElementByDetect := -2. 142484 nonEmpty5ElementsWithoutDuplicate := Heap 142485 new 142486 add: 2; 142487 add: 98; 142488 add: 4; 142489 add: 25; 142490 add: 1; 142491 yourself. 142492 collectionWithElement := Heap new. 142493 { 4. 5. 6. 2. 1. 1. (self element) } do: [ :nb | collectionWithElement add: nb ]. 142494 collection := Heap 142495 new 142496 add: 1; 142497 add: -2; 142498 add: 3; 142499 add: 1; 142500 yourself. 142501 otherCollection := Heap new 142502 add: 1; 142503 add: 20; 142504 add: 30; 142505 yourself. 142506 empty := Heap new. 142507 nonEmpty := Heap 142508 new 142509 add: self valuePutIn; 142510 add: self element; 142511 add: self elementTwiceIn; 142512 add: self elementTwiceIn; 142513 yourself. 142514 collectionNotIncluded := Heap new 142515 add: elementNotIn; 142516 add: elementNotIn; 142517 yourself. 142518 doWithoutNumber := 3. 142519 result := collection collect: [ :each | each + 1 ]. 142520 speciesClass := Heap. 142521 sameAtEndAndBegining := Heap new add: 1.5 ; add: 1.5 copy ; yourself. 142522 nonEmpty1Element := Heap new add: 5 ; yourself. 142523 floatCollection := Heap new add: 2.5 ; add: 5.5 ; add:4.2 ; yourself. 142524 indexArray := #( 1 3). 142525 subCollection := Heap new. 142526 duplicateElement := 1. 142527 collectionWithDuplicateElement := Heap new add: duplicateElement ; add: duplicateElement ; add:4 ; yourself. 142528 self firstIndex to: self secondIndex do: [:each | subCollection add: elementNotIn ]. 142529! ! 142530 142531 142532!HeapTest methodsFor: 'test - creation'! 142533testWith 142534 "self debug: #testWith" 142535 142536 | aCol element | 142537 element := self collectionMoreThan5Elements anyOne. 142538 aCol := self collectionClass with: element. 142539 self assert: (aCol includes: element).! ! 142540 142541!HeapTest methodsFor: 'test - creation'! 142542testWithAll 142543 "self debug: #testWithAll" 142544 142545 | aCol collection | 142546 collection := self collectionMoreThan5Elements asOrderedCollection . 142547 aCol := self collectionClass withAll: collection . 142548 142549 collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. 142550 142551 self assert: (aCol size = collection size ).! ! 142552 142553!HeapTest methodsFor: 'test - creation'! 142554testWithWith 142555 "self debug: #testWithWith" 142556 142557 | aCol collection element1 element2 | 142558 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . 142559 element1 := collection at: 1. 142560 element2 := collection at:2. 142561 142562 aCol := self collectionClass with: element1 with: element2 . 142563 self assert: (aCol occurrencesOf: element1 ) == ( collection occurrencesOf: element1). 142564 self assert: (aCol occurrencesOf: element2 ) == ( collection occurrencesOf: element2). 142565 142566 ! ! 142567 142568!HeapTest methodsFor: 'test - creation'! 142569testWithWithWith 142570 "self debug: #testWithWithWith" 142571 142572 | aCol collection | 142573 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . 142574 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 142575 142576 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 142577 142578!HeapTest methodsFor: 'test - creation'! 142579testWithWithWithWith 142580 "self debug: #testWithWithWithWith" 142581 142582 | aCol collection | 142583 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. 142584 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 142585 142586 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 142587 142588!HeapTest methodsFor: 'test - creation'! 142589testWithWithWithWithWith 142590 "self debug: #testWithWithWithWithWith" 142591 142592 | aCol collection | 142593 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . 142594 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 142595 142596 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 142597 142598 142599!HeapTest methodsFor: 'test - equality'! 142600testEqualSign 142601 "self debug: #testEqualSign" 142602 142603 self deny: (self empty = self nonEmpty).! ! 142604 142605!HeapTest methodsFor: 'test - equality'! 142606testEqualSignIsTrueForNonIdenticalButEqualCollections 142607 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 142608 142609 self assert: (self empty = self empty copy). 142610 self assert: (self empty copy = self empty). 142611 self assert: (self empty copy = self empty copy). 142612 142613 self assert: (self nonEmpty = self nonEmpty copy). 142614 self assert: (self nonEmpty copy = self nonEmpty). 142615 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 142616 142617!HeapTest methodsFor: 'test - equality'! 142618testEqualSignOfIdenticalCollectionObjects 142619 "self debug: #testEqualSignOfIdenticalCollectionObjects" 142620 142621 self assert: (self empty = self empty). 142622 self assert: (self nonEmpty = self nonEmpty). 142623 ! ! 142624 142625 142626!HeapTest methodsFor: 'test - remove'! 142627testRemoveElementThatExistsTwice 142628 "self debug: #testRemoveElementThatDoesExistsTwice" 142629 142630 | size | 142631 size := self nonEmpty size. 142632 self assert: (self nonEmpty includes: self elementTwiceIn). 142633 self nonEmpty remove: self elementTwiceIn. 142634 self assert: size - 1 = self nonEmpty size. 142635 142636 self assert: (self nonEmpty includes: self elementTwiceIn). 142637 self nonEmpty remove: self elementTwiceIn. 142638 self assert: size - 2 = self nonEmpty size! ! 142639 142640 142641!HeapTest methodsFor: 'testing' stamp: 'zz 12/7/2005 19:25'! 142642test1 142643 | data h | 142644 142645 "The first element of each array is the sort value, and the second will be updated by the heap with the index of the element within the heap." 142646 data := (1 to: 8) collect: [:i | {i*2. 0}]. 142647 142648 "Repeat with different data ordering." 142649 5 timesRepeat: [ 142650 h := Heap new sortBlock: [:e1 :e2 | e1 first < e2 first]. 142651 h indexUpdateBlock: [:array :index | array at: 2 put: index]. 142652 142653 data shuffled do: [:d | h add: d]. 142654 data do: [:d | self should: (h at: d second) == d]. 142655 ]! ! 142656 142657!HeapTest methodsFor: 'testing' stamp: 'md 2/12/2006 15:35'! 142658testExamples 142659 self shouldnt: [self heapExample] raise: Error. 142660 self shouldnt: [self heapSortExample] raise: Error.! ! 142661 142662 142663!HeapTest methodsFor: 'tests - adding'! 142664testTAdd 142665 | added collection | 142666 collection :=self otherCollection . 142667 added := collection add: self element. 142668 142669 self assert: added == self element. "test for identiy because #add: has not reason to copy its parameter." 142670 self assert: (collection includes: self element) . 142671 self assert: (self collectionWithElement includes: self element). 142672 142673 ! ! 142674 142675!HeapTest methodsFor: 'tests - adding'! 142676testTAddAll 142677 | added collection toBeAdded | 142678 collection := self collectionWithElement . 142679 toBeAdded := self otherCollection . 142680 added := collection addAll: toBeAdded . 142681 self assert: added == toBeAdded . "test for identiy because #addAll: has not reason to copy its parameter." 142682 self assert: (collection includesAllOf: toBeAdded )! ! 142683 142684!HeapTest methodsFor: 'tests - adding'! 142685testTAddIfNotPresentWithElementAlreadyIn 142686 142687 | added oldSize collection element | 142688 collection := self collectionWithElement . 142689 oldSize := collection size. 142690 element := self element . 142691 self assert: (collection includes: element ). 142692 142693 added := collection addIfNotPresent: element . 142694 142695 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 142696 self assert: collection size = oldSize! ! 142697 142698!HeapTest methodsFor: 'tests - adding'! 142699testTAddIfNotPresentWithNewElement 142700 142701 | added oldSize collection element | 142702 collection := self otherCollection . 142703 oldSize := collection size. 142704 element := self element . 142705 self deny: (collection includes: element ). 142706 142707 added := collection addIfNotPresent: element . 142708 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 142709 self assert: (collection size = (oldSize + 1)). 142710 142711 ! ! 142712 142713!HeapTest methodsFor: 'tests - adding'! 142714testTAddTwice 142715 | added oldSize collection element | 142716 collection := self collectionWithElement . 142717 element := self element . 142718 oldSize := collection size. 142719 added := collection 142720 add: element ; 142721 add: element . 142722 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 142723 self assert: (collection includes: element ). 142724 self assert: collection size = (oldSize + 2)! ! 142725 142726!HeapTest methodsFor: 'tests - adding'! 142727testTAddWithOccurences 142728 | added oldSize collection element | 142729 collection := self collectionWithElement . 142730 element := self element . 142731 oldSize := collection size. 142732 added := collection add: element withOccurrences: 5. 142733 142734 self assert: added == element. "test for identiy because #add: has not reason to copy its parameter." 142735 self assert: (collection includes: element). 142736 self assert: collection size = (oldSize + 5)! ! 142737 142738!HeapTest methodsFor: 'tests - adding'! 142739testTWrite 142740 | added collection element | 142741 collection := self otherCollection . 142742 element := self element . 142743 added := collection write: element . 142744 142745 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 142746 self assert: (collection includes: element ) . 142747 self assert: (collection includes: element ). 142748 142749 ! ! 142750 142751!HeapTest methodsFor: 'tests - adding'! 142752testTWriteTwice 142753 | added oldSize collection element | 142754 collection := self collectionWithElement . 142755 element := self element . 142756 oldSize := collection size. 142757 added := collection 142758 write: element ; 142759 write: element . 142760 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 142761 self assert: (collection includes: element ). 142762 self assert: collection size = (oldSize + 2)! ! 142763 142764 142765!HeapTest methodsFor: 'tests - as identity set'! 142766testAsIdentitySetWithIdentityEqualsElements 142767 | result | 142768 result := self collectionWithIdentical asIdentitySet. 142769 " Only one element should have been removed as two elements are equals with Identity equality" 142770 self assert: result size = (self collectionWithIdentical size - 1). 142771 self collectionWithIdentical do: 142772 [ :each | 142773 (self collectionWithIdentical occurrencesOf: each) > 1 142774 ifTrue: 142775 [ "the two elements equals only with classic equality shouldn't 'have been removed" 142776 self assert: (result asOrderedCollection occurrencesOf: each) = 1 142777 " the other elements are still here" ] 142778 ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ]. 142779 self assert: result class = IdentitySet! ! 142780 142781!HeapTest methodsFor: 'tests - as identity set'! 142782testAsIdentitySetWithoutIdentityEqualsElements 142783 | result collection | 142784 collection := self collectionWithCopy. 142785 result := collection asIdentitySet. 142786 " no elements should have been removed as no elements are equels with Identity equality" 142787 self assert: result size = collection size. 142788 collection do: 142789 [ :each | 142790 (collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ]. 142791 self assert: result class = IdentitySet! ! 142792 142793 142794!HeapTest methodsFor: 'tests - as set tests'! 142795testAsIdentitySetWithEqualsElements 142796 | result collection | 142797 collection := self withEqualElements . 142798 result := collection asIdentitySet. 142799 collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 142800 self assert: result class = IdentitySet.! ! 142801 142802!HeapTest methodsFor: 'tests - as set tests'! 142803testAsSetWithEqualsElements 142804 | result | 142805 result := self withEqualElements asSet. 142806 self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 142807 self assert: result class = Set! ! 142808 142809 142810!HeapTest methodsFor: 'tests - as sorted collection'! 142811testAsSortedArray 142812 | result collection | 142813 collection := self collectionWithSortableElements . 142814 result := collection asSortedArray. 142815 self assert: (result class includesBehavior: Array). 142816 self assert: result isSorted. 142817 self assert: result size = collection size! ! 142818 142819!HeapTest methodsFor: 'tests - as sorted collection'! 142820testAsSortedCollection 142821 142822 | aCollection result | 142823 aCollection := self collectionWithSortableElements . 142824 result := aCollection asSortedCollection. 142825 142826 self assert: (result class includesBehavior: SortedCollection). 142827 result do: 142828 [ :each | 142829 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 142830 142831 self assert: result size = aCollection size.! ! 142832 142833!HeapTest methodsFor: 'tests - as sorted collection'! 142834testAsSortedCollectionWithSortBlock 142835 | result tmp | 142836 result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. 142837 self assert: (result class includesBehavior: SortedCollection). 142838 result do: 142839 [ :each | 142840 self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 142841 self assert: result size = self collectionWithSortableElements size. 142842 tmp:=result at: 1. 142843 result do: [:each| self assert: tmp>=each. tmp:=each]. 142844 ! ! 142845 142846 142847!HeapTest methodsFor: 'tests - begins ends with'! 142848testsBeginsWith 142849 142850 self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty size)). 142851 self assert: (self nonEmpty beginsWith:(self nonEmpty )). 142852 self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 142853 142854!HeapTest methodsFor: 'tests - begins ends with'! 142855testsBeginsWithEmpty 142856 142857 self deny: (self nonEmpty beginsWith:(self empty)). 142858 self deny: (self empty beginsWith:(self nonEmpty )). 142859! ! 142860 142861!HeapTest methodsFor: 'tests - begins ends with'! 142862testsEndsWith 142863 142864 self assert: (self nonEmpty endsWith:(self nonEmpty copyWithoutFirst)). 142865 self assert: (self nonEmpty endsWith:(self nonEmpty )). 142866 self deny: (self nonEmpty endsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 142867 142868!HeapTest methodsFor: 'tests - begins ends with'! 142869testsEndsWithEmpty 142870 142871 self deny: (self nonEmpty endsWith:(self empty )). 142872 self deny: (self empty endsWith:(self nonEmpty )). 142873 ! ! 142874 142875 142876!HeapTest methodsFor: 'tests - comma and delimiter'! 142877testAsCommaStringEmpty 142878 142879 self assert: self empty asCommaString = ''. 142880 self assert: self empty asCommaStringAnd = ''. 142881 142882 142883! ! 142884 142885!HeapTest methodsFor: 'tests - comma and delimiter'! 142886testAsCommaStringMore 142887 142888 "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. 142889 self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' 142890" 142891 142892 | result resultAnd index allElementsAsString | 142893 result:= self nonEmpty asCommaString . 142894 resultAnd:= self nonEmpty asCommaStringAnd . 142895 142896 index := 1. 142897 (result findBetweenSubStrs: ',' )do: 142898 [:each | 142899 index = 1 142900 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] 142901 ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. 142902 index:=index+1 142903 ]. 142904 142905 "verifying esultAnd :" 142906 allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 142907 1 to: allElementsAsString size do: 142908 [:i | 142909 i<(allElementsAsString size ) 142910 ifTrue: [ 142911 i = 1 142912 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] 142913 ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] 142914 ]. 142915 i=(allElementsAsString size) 142916 ifTrue:[ 142917 i = 1 142918 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 142919 ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 142920 ]. 142921 142922 142923 ].! ! 142924 142925!HeapTest methodsFor: 'tests - comma and delimiter'! 142926testAsCommaStringOne 142927 142928 "self assert: self oneItemCol asCommaString = '1'. 142929 self assert: self oneItemCol asCommaStringAnd = '1'." 142930 142931 self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). 142932 self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). 142933 ! ! 142934 142935!HeapTest methodsFor: 'tests - comma and delimiter'! 142936testAsStringOnDelimiterEmpty 142937 142938 | delim emptyStream | 142939 delim := ', '. 142940 emptyStream := ReadWriteStream on: ''. 142941 self empty asStringOn: emptyStream delimiter: delim. 142942 self assert: emptyStream contents = ''. 142943! ! 142944 142945!HeapTest methodsFor: 'tests - comma and delimiter'! 142946testAsStringOnDelimiterLastEmpty 142947 142948 | delim emptyStream | 142949 delim := ', '. 142950 emptyStream := ReadWriteStream on: ''. 142951 self empty asStringOn: emptyStream delimiter: delim last:'and'. 142952 self assert: emptyStream contents = ''. 142953! ! 142954 142955!HeapTest methodsFor: 'tests - comma and delimiter'! 142956testAsStringOnDelimiterLastMore 142957 142958 | delim multiItemStream result last allElementsAsString | 142959 142960 delim := ', '. 142961 last := 'and'. 142962 result:=''. 142963 multiItemStream := ReadWriteStream on:result. 142964 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 142965 142966 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 142967 1 to: allElementsAsString size do: 142968 [:i | 142969 i<(allElementsAsString size-1 ) 142970 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 142971 i=(allElementsAsString size-1) 142972 ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. 142973 i=(allElementsAsString size) 142974 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 142975 ]. 142976 142977! ! 142978 142979!HeapTest methodsFor: 'tests - comma and delimiter'! 142980testAsStringOnDelimiterLastOne 142981 142982 | delim oneItemStream result | 142983 142984 delim := ', '. 142985 result:=''. 142986 oneItemStream := ReadWriteStream on: result. 142987 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 142988 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 142989 142990 142991 ! ! 142992 142993!HeapTest methodsFor: 'tests - comma and delimiter'! 142994testAsStringOnDelimiterMore 142995 142996 | delim multiItemStream result index | 142997 "delim := ', '. 142998 multiItemStream := '' readWrite. 142999 self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. 143000 self assert: multiItemStream contents = '1, 2, 3'." 143001 143002 delim := ', '. 143003 result:=''. 143004 multiItemStream := ReadWriteStream on:result. 143005 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 143006 143007 index:=1. 143008 (result findBetweenSubStrs: ', ' )do: 143009 [:each | 143010 self assert: each= ((self nonEmpty at:index)asString). 143011 index:=index+1 143012 ].! ! 143013 143014!HeapTest methodsFor: 'tests - comma and delimiter'! 143015testAsStringOnDelimiterOne 143016 143017 | delim oneItemStream result | 143018 "delim := ', '. 143019 oneItemStream := '' readWrite. 143020 self oneItemCol asStringOn: oneItemStream delimiter: delim. 143021 self assert: oneItemStream contents = '1'." 143022 143023 delim := ', '. 143024 result:=''. 143025 oneItemStream := ReadWriteStream on: result. 143026 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 143027 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 143028 143029 143030 ! ! 143031 143032 143033!HeapTest methodsFor: 'tests - concatenation'! 143034testConcatenation 143035 | result index | 143036 result:= self firstCollection,self secondCollection . 143037 "first part : " 143038 index := 1. 143039 self firstCollection do: 143040 [:each | 143041 self assert: (self firstCollection at: index)=each. 143042 index := index+1.]. 143043 "second part : " 143044 1 to: self secondCollection size do: 143045 [:i | 143046 self assert: (self secondCollection at:i)= (result at:index). 143047 index:=index+1]. 143048 "size : " 143049 self assert: result size = (self firstCollection size + self secondCollection size).! ! 143050 143051!HeapTest methodsFor: 'tests - concatenation'! 143052testConcatenationWithEmpty 143053 | result | 143054 result:= self empty,self secondCollection . 143055 143056 1 to: self secondCollection size do: 143057 [:i | 143058 self assert: (self secondCollection at:i)= (result at:i). 143059 ]. 143060 "size : " 143061 self assert: result size = ( self secondCollection size).! ! 143062 143063 143064!HeapTest methodsFor: 'tests - converting'! 143065assertNoDuplicates: aCollection whenConvertedTo: aClass 143066 | result | 143067 result := self collectionWithEqualElements asIdentitySet. 143068 self assert: (result class includesBehavior: IdentitySet). 143069 self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! 143070 143071!HeapTest methodsFor: 'tests - converting'! 143072assertNonDuplicatedContents: aCollection whenConvertedTo: aClass 143073 | result | 143074 result := aCollection perform: ('as' , aClass name) asSymbol. 143075 self assert: (result class includesBehavior: aClass). 143076 result do: 143077 [ :each | 143078 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 143079 ^ result! ! 143080 143081!HeapTest methodsFor: 'tests - converting'! 143082assertSameContents: aCollection whenConvertedTo: aClass 143083 | result | 143084 result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. 143085 self assert: result size = aCollection size! ! 143086 143087!HeapTest methodsFor: 'tests - converting'! 143088testAsArray 143089 "self debug: #testAsArray3" 143090 self 143091 assertSameContents: self collectionWithoutEqualElements 143092 whenConvertedTo: Array! ! 143093 143094!HeapTest methodsFor: 'tests - converting'! 143095testAsBag 143096 143097 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! 143098 143099!HeapTest methodsFor: 'tests - converting'! 143100testAsByteArray 143101| res | 143102self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 143103 self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . 143104 143105 res := true. 143106 self integerCollectionWithoutEqualElements 143107 detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] 143108 ifNone: [ res := false ]. 143109 self assert: res = false. 143110 143111 143112 self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! 143113 143114!HeapTest methodsFor: 'tests - converting'! 143115testAsIdentitySet 143116 "test with a collection without equal elements :" 143117 self 143118 assertSameContents: self collectionWithoutEqualElements 143119 whenConvertedTo: IdentitySet. 143120! ! 143121 143122!HeapTest methodsFor: 'tests - converting'! 143123testAsOrderedCollection 143124 143125 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! 143126 143127!HeapTest methodsFor: 'tests - converting'! 143128testAsSet 143129 | | 143130 "test with a collection without equal elements :" 143131 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. 143132 ! ! 143133 143134 143135!HeapTest methodsFor: 'tests - copy'! 143136testCopyEmptyWith 143137 "self debug: #testCopyWith" 143138 | res element | 143139 element := self elementToAdd. 143140 res := self empty copyWith: element. 143141 self assert: res size = (self empty size + 1). 143142 self assert: (res includes: (element value))! ! 143143 143144!HeapTest methodsFor: 'tests - copy'! 143145testCopyEmptyWithout 143146 "self debug: #testCopyEmptyWithout" 143147 | res | 143148 res := self empty copyWithout: self elementToAdd. 143149 self assert: res size = self empty size. 143150 self deny: (res includes: self elementToAdd)! ! 143151 143152!HeapTest methodsFor: 'tests - copy'! 143153testCopyEmptyWithoutAll 143154 "self debug: #testCopyEmptyWithoutAll" 143155 | res | 143156 res := self empty copyWithoutAll: self collectionWithElementsToRemove. 143157 self assert: res size = self empty size. 143158 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! 143159 143160!HeapTest methodsFor: 'tests - copy'! 143161testCopyNonEmptyWith 143162 "self debug: #testCopyNonEmptyWith" 143163 | res element | 143164 element := self elementToAdd . 143165 res := self nonEmpty copyWith: element. 143166 "here we do not test the size since for a non empty set we would get a problem. 143167 Then in addition copy is not about duplicate management. The element should 143168 be in at the end." 143169 self assert: (res includes: (element value)). 143170 self nonEmpty do: [ :each | res includes: each ]! ! 143171 143172!HeapTest methodsFor: 'tests - copy'! 143173testCopyNonEmptyWithout 143174 "self debug: #testCopyNonEmptyWithout" 143175 143176 | res anElementOfTheCollection | 143177 anElementOfTheCollection := self nonEmpty anyOne. 143178 res := (self nonEmpty copyWithout: anElementOfTheCollection). 143179 "here we do not test the size since for a non empty set we would get a problem. 143180 Then in addition copy is not about duplicate management. The element should 143181 be in at the end." 143182 self deny: (res includes: anElementOfTheCollection). 143183 self nonEmpty do: 143184 [:each | (each = anElementOfTheCollection) 143185 ifFalse: [self assert: (res includes: each)]]. 143186 143187! ! 143188 143189!HeapTest methodsFor: 'tests - copy'! 143190testCopyNonEmptyWithoutAll 143191 "self debug: #testCopyNonEmptyWithoutAll" 143192 | res | 143193 res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. 143194 "here we do not test the size since for a non empty set we would get a problem. 143195 Then in addition copy is not about duplicate management. The element should 143196 be in at the end." 143197 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. 143198 self nonEmpty do: 143199 [ :each | 143200 (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! 143201 143202!HeapTest methodsFor: 'tests - copy'! 143203testCopyNonEmptyWithoutAllNotIncluded 143204 "self debug: #testCopyNonEmptyWithoutAllNotIncluded" 143205 | res | 143206 res := self nonEmpty copyWithoutAll: self collectionNotIncluded. 143207 "here we do not test the size since for a non empty set we would get a problem. 143208 Then in addition copy is not about duplicate management. The element should 143209 be in at the end." 143210 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 143211 143212!HeapTest methodsFor: 'tests - copy'! 143213testCopyNonEmptyWithoutNotIncluded 143214 "self debug: #testCopyNonEmptyWithoutNotIncluded" 143215 | res | 143216 res := self nonEmpty copyWithout: self elementToAdd. 143217 "here we do not test the size since for a non empty set we would get a problem. 143218 Then in addition copy is not about duplicate management. The element should 143219 be in at the end." 143220 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 143221 143222 143223!HeapTest methodsFor: 'tests - copying part of sequenceable'! 143224testCopyAfter 143225 | result index collection | 143226 collection := self collectionWithoutEqualsElements . 143227 index:= self indexInForCollectionWithoutDuplicates . 143228 result := collection copyAfter: (collection at:index ). 143229 143230 "verifying content: " 143231 (1) to: result size do: 143232 [:i | 143233 self assert: (collection at:(i + index ))=(result at: (i))]. 143234 143235 "verify size: " 143236 self assert: result size = (collection size - index).! ! 143237 143238!HeapTest methodsFor: 'tests - copying part of sequenceable'! 143239testCopyAfterEmpty 143240 | result | 143241 result := self empty copyAfter: self collectionWithoutEqualsElements first. 143242 self assert: result isEmpty. 143243 ! ! 143244 143245!HeapTest methodsFor: 'tests - copying part of sequenceable'! 143246testCopyAfterLast 143247 | result index collection | 143248 collection := self collectionWithoutEqualsElements . 143249 index:= self indexInForCollectionWithoutDuplicates . 143250 result := collection copyAfterLast: (collection at:index ). 143251 143252 "verifying content: " 143253 (1) to: result size do: 143254 [:i | 143255 self assert: (collection at:(i + index ))=(result at: (i))]. 143256 143257 "verify size: " 143258 self assert: result size = (collection size - index).! ! 143259 143260!HeapTest methodsFor: 'tests - copying part of sequenceable'! 143261testCopyAfterLastEmpty 143262 | result | 143263 result := self empty copyAfterLast: self collectionWithoutEqualsElements first. 143264 self assert: result isEmpty.! ! 143265 143266!HeapTest methodsFor: 'tests - copying part of sequenceable'! 143267testCopyFromTo 143268 | result index collection | 143269 collection := self collectionWithoutEqualsElements . 143270 index :=self indexInForCollectionWithoutDuplicates . 143271 result := collection copyFrom: index to: collection size . 143272 143273 "verify content of 'result' : " 143274 1 to: result size do: 143275 [:i | 143276 self assert: (result at:i)=(collection at: (i + index - 1))]. 143277 143278 "verify size of 'result' : " 143279 self assert: result size = (collection size - index + 1).! ! 143280 143281!HeapTest methodsFor: 'tests - copying part of sequenceable'! 143282testCopyUpTo 143283 | result index collection | 143284 collection := self collectionWithoutEqualsElements . 143285 index:= self indexInForCollectionWithoutDuplicates . 143286 result := collection copyUpTo: (collection at:index). 143287 143288 "verify content of 'result' :" 143289 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 143290 143291 "verify size of 'result' :" 143292 self assert: result size = (index-1). 143293 ! ! 143294 143295!HeapTest methodsFor: 'tests - copying part of sequenceable'! 143296testCopyUpToEmpty 143297 | result | 143298 result := self empty copyUpTo: self collectionWithoutEqualsElements first. 143299 self assert: result isEmpty. 143300 ! ! 143301 143302!HeapTest methodsFor: 'tests - copying part of sequenceable'! 143303testCopyUpToLast 143304 | result index collection | 143305 collection := self collectionWithoutEqualsElements . 143306 index:= self indexInForCollectionWithoutDuplicates . 143307 result := collection copyUpToLast: (collection at:index). 143308 143309 "verify content of 'result' :" 143310 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 143311 143312 "verify size of 'result' :" 143313 self assert: result size = (index-1).! ! 143314 143315!HeapTest methodsFor: 'tests - copying part of sequenceable'! 143316testCopyUpToLastEmpty 143317 | result | 143318 result := self empty copyUpToLast: self collectionWithoutEqualsElements first. 143319 self assert: result isEmpty.! ! 143320 143321 143322!HeapTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 143323testCopyAfterLastWithDuplicate 143324 | result element collection | 143325 collection := self collectionWithSameAtEndAndBegining . 143326 element := collection first. 143327 143328 " collectionWithSameAtEndAndBegining first and last elements are equals. 143329 'copyAfter:' should copy after the last occurence of element :" 143330 result := collection copyAfterLast: (element ). 143331 143332 "verifying content: " 143333 self assert: result isEmpty. 143334 143335! ! 143336 143337!HeapTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 143338testCopyAfterWithDuplicate 143339 | result element collection | 143340 collection := self collectionWithSameAtEndAndBegining . 143341 element := collection last. 143342 143343 " collectionWithSameAtEndAndBegining first and last elements are equals. 143344 'copyAfter:' should copy after the first occurence :" 143345 result := collection copyAfter: (element ). 143346 143347 "verifying content: " 143348 1 to: result size do: 143349 [:i | 143350 self assert: (collection at:(i + 1 )) = (result at: (i)) 143351 ]. 143352 143353 "verify size: " 143354 self assert: result size = (collection size - 1).! ! 143355 143356!HeapTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 143357testCopyUpToLastWithDuplicate 143358 | result element collection | 143359 collection := self collectionWithSameAtEndAndBegining . 143360 element := collection first. 143361 143362 " collectionWithSameAtEndAndBegining first and last elements are equals. 143363 'copyUpToLast:' should copy until the last occurence :" 143364 result := collection copyUpToLast: (element ). 143365 143366 "verifying content: " 143367 1 to: result size do: 143368 [:i | 143369 self assert: (result at: i ) = ( collection at: i ) 143370 ]. 143371 143372 self assert: result size = (collection size - 1). 143373 143374! ! 143375 143376!HeapTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 143377testCopyUpToWithDuplicate 143378 | result element collection | 143379 collection := self collectionWithSameAtEndAndBegining . 143380 element := collection last. 143381 143382 " collectionWithSameAtEndAndBegining first and last elements are equals. 143383 'copyUpTo:' should copy until the first occurence :" 143384 result := collection copyUpTo: (element ). 143385 143386 "verifying content: " 143387 self assert: result isEmpty. 143388 143389! ! 143390 143391 143392!HeapTest methodsFor: 'tests - copying same contents'! 143393testReverse 143394 | result | 143395 result := self nonEmpty reverse . 143396 143397 "verify content of 'result: '" 143398 1 to: result size do: 143399 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 143400 "verify size of 'result' :" 143401 self assert: result size=self nonEmpty size.! ! 143402 143403!HeapTest methodsFor: 'tests - copying same contents'! 143404testReversed 143405 | result | 143406 result := self nonEmpty reversed . 143407 143408 "verify content of 'result: '" 143409 1 to: result size do: 143410 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 143411 "verify size of 'result' :" 143412 self assert: result size=self nonEmpty size.! ! 143413 143414!HeapTest methodsFor: 'tests - copying same contents'! 143415testShallowCopy 143416 | result | 143417 result := self nonEmpty shallowCopy . 143418 143419 "verify content of 'result: '" 143420 1 to: self nonEmpty size do: 143421 [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. 143422 "verify size of 'result' :" 143423 self assert: result size=self nonEmpty size.! ! 143424 143425!HeapTest methodsFor: 'tests - copying same contents'! 143426testShallowCopyEmpty 143427 | result | 143428 result := self empty shallowCopy . 143429 self assert: result isEmpty .! ! 143430 143431!HeapTest methodsFor: 'tests - copying same contents'! 143432testShuffled 143433 | result | 143434 result := self nonEmpty shuffled . 143435 143436 "verify content of 'result: '" 143437 result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. 143438 "verify size of 'result' :" 143439 self assert: result size=self nonEmpty size.! ! 143440 143441!HeapTest methodsFor: 'tests - copying same contents'! 143442testSortBy 143443 " can only be used if the collection tested can include sortable elements :" 143444 | result tmp | 143445 self 143446 shouldnt: [ self collectionWithSortableElements ] 143447 raise: Error. 143448 self shouldnt: [self collectionWithSortableElements anyOne < self collectionWithSortableElements anyOne] raise: Error. 143449 result := self collectionWithSortableElements sortBy: [ :a :b | a < b ]. 143450 143451 "verify content of 'result' : " 143452 result do: 143453 [ :each | 143454 (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 143455 tmp := result first. 143456 result do: 143457 [ :each | 143458 self assert: each >= tmp. 143459 tmp := each ]. 143460 143461 "verify size of 'result' :" 143462 self assert: result size = self collectionWithSortableElements size! ! 143463 143464 143465!HeapTest methodsFor: 'tests - copying with or without'! 143466testCopyWithFirst 143467 143468 | index element result | 143469 index:= self indexInNonEmpty . 143470 element:= self nonEmpty at: index. 143471 143472 result := self nonEmpty copyWithFirst: element. 143473 143474 self assert: result size = (self nonEmpty size + 1). 143475 self assert: result first = element . 143476 143477 2 to: result size do: 143478 [ :i | 143479 self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! 143480 143481!HeapTest methodsFor: 'tests - copying with or without'! 143482testCopyWithSequenceable 143483 143484 | result index element | 143485 index := self indexInNonEmpty . 143486 element := self nonEmpty at: index. 143487 result := self nonEmpty copyWith: (element ). 143488 143489 self assert: result size = (self nonEmpty size + 1). 143490 self assert: result last = element . 143491 143492 1 to: (result size - 1) do: 143493 [ :i | 143494 self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! 143495 143496!HeapTest methodsFor: 'tests - copying with or without'! 143497testCopyWithoutFirst 143498 143499 | result | 143500 result := self nonEmpty copyWithoutFirst. 143501 143502 self assert: result size = (self nonEmpty size - 1). 143503 143504 1 to: result size do: 143505 [:i | 143506 self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! 143507 143508!HeapTest methodsFor: 'tests - copying with or without'! 143509testCopyWithoutIndex 143510 | result index | 143511 index := self indexInNonEmpty . 143512 result := self nonEmpty copyWithoutIndex: index . 143513 143514 "verify content of 'result:'" 143515 1 to: result size do: 143516 [:i | 143517 i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. 143518 i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. 143519 143520 "verify size of result : " 143521 self assert: result size=(self nonEmpty size -1).! ! 143522 143523!HeapTest methodsFor: 'tests - copying with or without'! 143524testForceToPaddingStartWith 143525 143526 | result element | 143527 element := self nonEmpty at: self indexInNonEmpty . 143528 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). 143529 143530 "verify content of 'result' : " 143531 1 to: 2 do: 143532 [:i | self assert: ( element ) = ( result at:(i) ) ]. 143533 143534 3 to: result size do: 143535 [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. 143536 143537 "verify size of 'result' :" 143538 self assert: result size = (self nonEmpty size + 2).! ! 143539 143540!HeapTest methodsFor: 'tests - copying with or without'! 143541testForceToPaddingWith 143542 143543 | result element | 143544 element := self nonEmpty at: self indexInNonEmpty . 143545 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). 143546 143547 "verify content of 'result' : " 143548 1 to: self nonEmpty size do: 143549 [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. 143550 143551 (result size - 1) to: result size do: 143552 [:i | self assert: ( result at:i ) = ( element ) ]. 143553 143554 "verify size of 'result' :" 143555 self assert: result size = (self nonEmpty size + 2).! ! 143556 143557 143558!HeapTest methodsFor: 'tests - copying with replacement for sorted'! 143559testCopyFromToWithForSorted 143560| collection result | 143561collection := self collectionOfSize5 . 143562 143563" testing that elements to be replaced are removed from the copy :" 143564result := collection copyReplaceFrom: 1 to: collection size with: self empty . 143565self assert: result isEmpty. 143566 143567" testing that replacement elements are all put into the copy :" 143568result := collection copyReplaceFrom: 1 to: collection size with: self replacementCollection . 143569 self replacementCollection do: 143570 [:each | 143571 self assert: (result occurrencesOf: each) = ( self replacementCollection occurrencesOf: each )]. 143572 143573self assert: result size = self replacementCollection size. 143574 143575! ! 143576 143577!HeapTest methodsFor: 'tests - copying with replacement for sorted'! 143578testCopyReplaceAllWithForSorted 143579 143580| collection result | 143581collection := self collectionOfSize5 . 143582 143583" testing that elements to be replaced are removed from the copy :" 143584result := collection copyReplaceAll: collection with: self empty . 143585self assert: result isEmpty. 143586 143587" testing that replacement elements are all put into the copy :" 143588result := collection copyReplaceAll: collection with: self replacementCollection . 143589 self replacementCollection do: 143590 [:each | 143591 self assert: (result occurrencesOf: each) = ( self replacementCollection occurrencesOf: each )]. 143592 143593self assert: result size = self replacementCollection size. 143594 143595! ! 143596 143597 143598!HeapTest methodsFor: 'tests - element accessing'! 143599testAfter 143600 "self debug: #testAfter" 143601 self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). 143602 self 143603 should: 143604 [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] 143605 raise: Error. 143606 self 143607 should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] 143608 raise: Error! ! 143609 143610!HeapTest methodsFor: 'tests - element accessing'! 143611testAfterIfAbsent 143612 "self debug: #testAfterIfAbsent" 143613 self assert: (self moreThan4Elements 143614 after: (self moreThan4Elements at: 1) 143615 ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). 143616 self assert: (self moreThan4Elements 143617 after: (self moreThan4Elements at: self moreThan4Elements size) 143618 ifAbsent: [ 33 ]) == 33. 143619 self assert: (self moreThan4Elements 143620 after: self elementNotInForElementAccessing 143621 ifAbsent: [ 33 ]) = 33! ! 143622 143623!HeapTest methodsFor: 'tests - element accessing'! 143624testAtAll 143625 "self debug: #testAtAll" 143626 " self flag: #theCollectionshouldbe102030intheFixture. 143627 143628 self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. 143629 self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." 143630 | result | 143631 result := self moreThan4Elements atAll: #(2 1 2 ). 143632 self assert: (result at: 1) = (self moreThan4Elements at: 2). 143633 self assert: (result at: 2) = (self moreThan4Elements at: 1). 143634 self assert: (result at: 3) = (self moreThan4Elements at: 2). 143635 self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! 143636 143637!HeapTest methodsFor: 'tests - element accessing'! 143638testAtIfAbsent 143639 "self debug: #testAt" 143640 | absent | 143641 absent := false. 143642 self moreThan4Elements 143643 at: self moreThan4Elements size + 1 143644 ifAbsent: [ absent := true ]. 143645 self assert: absent = true. 143646 absent := false. 143647 self moreThan4Elements 143648 at: self moreThan4Elements size 143649 ifAbsent: [ absent := true ]. 143650 self assert: absent = false! ! 143651 143652!HeapTest methodsFor: 'tests - element accessing'! 143653testAtLast 143654 "self debug: #testAtLast" 143655 | index | 143656 self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. 143657 "tmp:=1. 143658 self do: 143659 [:each | 143660 each =self elementInForIndexAccessing 143661 ifTrue:[index:=tmp]. 143662 tmp:=tmp+1]." 143663 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 143664 self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! 143665 143666!HeapTest methodsFor: 'tests - element accessing'! 143667testAtLastError 143668 "self debug: #testAtLast" 143669 self 143670 should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] 143671 raise: Error! ! 143672 143673!HeapTest methodsFor: 'tests - element accessing'! 143674testAtLastIfAbsent 143675 "self debug: #testAtLastIfAbsent" 143676 self assert: (self moreThan4Elements 143677 atLast: 1 143678 ifAbsent: [ nil ]) = self moreThan4Elements last. 143679 self assert: (self moreThan4Elements 143680 atLast: self moreThan4Elements size + 1 143681 ifAbsent: [ 222 ]) = 222! ! 143682 143683!HeapTest methodsFor: 'tests - element accessing'! 143684testAtOutOfBounds 143685 "self debug: #testAtOutOfBounds" 143686 self 143687 should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] 143688 raise: Error. 143689 self 143690 should: [ self moreThan4Elements at: -1 ] 143691 raise: Error! ! 143692 143693!HeapTest methodsFor: 'tests - element accessing'! 143694testAtPin 143695 "self debug: #testAtPin" 143696 self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. 143697 self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. 143698 self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! 143699 143700!HeapTest methodsFor: 'tests - element accessing'! 143701testAtRandom 143702 | result | 143703 result := self nonEmpty atRandom . 143704 self assert: (self nonEmpty includes: result).! ! 143705 143706!HeapTest methodsFor: 'tests - element accessing'! 143707testAtWrap 143708 "self debug: #testAt" 143709 " 143710 self assert: (self accessCollection at: 1) = 1. 143711 self assert: (self accessCollection at: 2) = 2. 143712 " 143713 | index | 143714 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 143715 self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. 143716 self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. 143717 self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. 143718 self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! 143719 143720!HeapTest methodsFor: 'tests - element accessing'! 143721testBefore 143722 "self debug: #testBefore" 143723 self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). 143724 self 143725 should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] 143726 raise: Error. 143727 self 143728 should: [ self moreThan4Elements before: 66 ] 143729 raise: Error! ! 143730 143731!HeapTest methodsFor: 'tests - element accessing'! 143732testBeforeIfAbsent 143733 "self debug: #testBefore" 143734 self assert: (self moreThan4Elements 143735 before: (self moreThan4Elements at: 1) 143736 ifAbsent: [ 99 ]) = 99. 143737 self assert: (self moreThan4Elements 143738 before: (self moreThan4Elements at: 2) 143739 ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! 143740 143741!HeapTest methodsFor: 'tests - element accessing'! 143742testFirstSecondThird 143743 "self debug: #testFirstSecondThird" 143744 self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). 143745 self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). 143746 self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). 143747 self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! 143748 143749!HeapTest methodsFor: 'tests - element accessing'! 143750testLast 143751 "self debug: #testLast" 143752 self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! 143753 143754!HeapTest methodsFor: 'tests - element accessing'! 143755testMiddle 143756 "self debug: #testMiddle" 143757 self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! 143758 143759 143760!HeapTest methodsFor: 'tests - equality'! 143761testEqualSignForSequenceableCollections 143762 "self debug: #testEqualSign" 143763 143764 self deny: (self nonEmpty = self nonEmpty asSet). 143765 self deny: (self nonEmpty reversed = self nonEmpty). 143766 self deny: (self nonEmpty = self nonEmpty reversed).! ! 143767 143768!HeapTest methodsFor: 'tests - equality'! 143769testHasEqualElements 143770 "self debug: #testHasEqualElements" 143771 143772 self deny: (self empty hasEqualElements: self nonEmpty). 143773 self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). 143774 self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). 143775 self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! 143776 143777!HeapTest methodsFor: 'tests - equality'! 143778testHasEqualElementsIsTrueForNonIdenticalButEqualCollections 143779 "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" 143780 143781 self assert: (self empty hasEqualElements: self empty copy). 143782 self assert: (self empty copy hasEqualElements: self empty). 143783 self assert: (self empty copy hasEqualElements: self empty copy). 143784 143785 self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). 143786 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). 143787 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! 143788 143789!HeapTest methodsFor: 'tests - equality'! 143790testHasEqualElementsOfIdenticalCollectionObjects 143791 "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" 143792 143793 self assert: (self empty hasEqualElements: self empty). 143794 self assert: (self nonEmpty hasEqualElements: self nonEmpty). 143795 ! ! 143796 143797 143798!HeapTest methodsFor: 'tests - fixture'! 143799test0CopyTest 143800 self shouldnt: [ self empty ]raise: Error. 143801 self assert: self empty size = 0. 143802 self shouldnt: [ self nonEmpty ]raise: Error. 143803 self assert: (self nonEmpty size = 0) not. 143804 self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. 143805 self assert: (self collectionWithElementsToRemove size = 0) not. 143806 self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. 143807 143808 self shouldnt: [ self elementToAdd ]raise: Error. 143809 self deny: (self nonEmpty includes: self elementToAdd ). 143810 self shouldnt: [ self collectionNotIncluded ]raise: Error. 143811 self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! 143812 143813!HeapTest methodsFor: 'tests - fixture'! 143814test0FixtureAsSetForIdentityMultiplinessTest 143815 143816 "a collection (of elements for which copy is not identical ) without equal elements:" 143817 | element res | 143818 self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ]raise: Error. 143819 element := self elementsCopyNonIdenticalWithoutEqualElements anyOne. 143820 self deny: element copy == element . 143821 143822 res := true. 143823 self elementsCopyNonIdenticalWithoutEqualElements 143824 detect: 143825 [ :each | 143826 (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] 143827 ifNone: [ res := false ]. 143828 self assert: res = false 143829 143830 ! ! 143831 143832!HeapTest methodsFor: 'tests - fixture'! 143833test0FixtureAsStringCommaAndDelimiterTest 143834 143835 self shouldnt: [self nonEmpty] raise:Error . 143836 self deny: self nonEmpty isEmpty. 143837 143838 self shouldnt: [self empty] raise:Error . 143839 self assert: self empty isEmpty. 143840 143841 self shouldnt: [self nonEmpty1Element ] raise:Error . 143842 self assert: self nonEmpty1Element size=1.! ! 143843 143844!HeapTest methodsFor: 'tests - fixture'! 143845test0FixtureBeginsEndsWithTest 143846 143847 self shouldnt: [self nonEmpty ] raise: Error. 143848 self deny: self nonEmpty isEmpty. 143849 self assert: self nonEmpty size>1. 143850 143851 self shouldnt: [self empty ] raise: Error. 143852 self assert: self empty isEmpty.! ! 143853 143854!HeapTest methodsFor: 'tests - fixture'! 143855test0FixtureConverAsSortedTest 143856 143857 self shouldnt: [self collectionWithSortableElements ] raise: Error. 143858 self deny: self collectionWithSortableElements isEmpty .! ! 143859 143860!HeapTest methodsFor: 'tests - fixture'! 143861test0FixtureCopyPartOfForMultipliness 143862 143863self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. 143864 143865self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 143866 143867self assert: self collectionWithSameAtEndAndBegining size > 1. 143868 1438691 to: self collectionWithSameAtEndAndBegining size do: 143870 [:i | 143871 (i > 1 ) & (i < self collectionWithSameAtEndAndBegining size) 143872 ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at:i) = (self collectionWithSameAtEndAndBegining first)]. 143873 ]! ! 143874 143875!HeapTest methodsFor: 'tests - fixture'! 143876test0FixtureCopyPartOfSequenceableTest 143877 143878 self shouldnt: [self collectionWithoutEqualsElements ] raise: Error. 143879 self collectionWithoutEqualsElements do: 143880 [:each | self assert: (self collectionWithoutEqualsElements occurrencesOf: each)=1]. 143881 143882 self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. 143883 self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualsElements size. 143884 143885 self shouldnt: [self empty] raise: Error. 143886 self assert: self empty isEmpty .! ! 143887 143888!HeapTest methodsFor: 'tests - fixture'! 143889test0FixtureCopySameContentsTest 143890 143891 self shouldnt: [self nonEmpty ] raise: Error. 143892 self deny: self nonEmpty isEmpty. 143893 143894 self shouldnt: [self empty ] raise: Error. 143895 self assert: self empty isEmpty. 143896 143897! ! 143898 143899!HeapTest methodsFor: 'tests - fixture'! 143900test0FixtureCopyWithOrWithoutSpecificElementsTest 143901 143902 self shouldnt: [self nonEmpty ] raise: Error. 143903 self deny: self nonEmpty isEmpty . 143904 143905 self shouldnt: [self indexInNonEmpty ] raise: Error. 143906 self assert: self indexInNonEmpty > 0. 143907 self assert: self indexInNonEmpty <= self nonEmpty size.! ! 143908 143909!HeapTest methodsFor: 'tests - fixture'! 143910test0FixtureCopyWithReplacementForSorted 143911 143912self shouldnt: [self collectionOfSize5 ] raise: Error. 143913self assert: self collectionOfSize5 size = 5. 143914 143915self shouldnt: [self replacementCollection ] raise: Error. 143916self deny: self replacementCollection isEmpty. 143917 143918self shouldnt: [self empty] raise: Error. 143919self assert: self empty isEmpty.! ! 143920 143921!HeapTest methodsFor: 'tests - fixture'! 143922test0FixtureCreationWithTest 143923 143924self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. 143925self assert: self collectionMoreThan5Elements size >= 5.! ! 143926 143927!HeapTest methodsFor: 'tests - fixture'! 143928test0FixtureIncludeTest 143929 | elementIn | 143930 self shouldnt: [ self nonEmpty ]raise: Error. 143931 self deny: self nonEmpty isEmpty. 143932 143933 self shouldnt: [ self elementNotIn ]raise: Error. 143934 143935 elementIn := true. 143936 self nonEmpty detect: 143937 [ :each | each = self elementNotIn ] 143938 ifNone: [ elementIn := false ]. 143939 self assert: elementIn = false. 143940 143941 self shouldnt: [ self anotherElementNotIn ]raise: Error. 143942 143943 elementIn := true. 143944 self nonEmpty detect: 143945 [ :each | each = self anotherElementNotIn ] 143946 ifNone: [ elementIn := false ]. 143947 self assert: elementIn = false. 143948 143949 self shouldnt: [ self empty ] raise: Error. 143950 self assert: self empty isEmpty. 143951 143952! ! 143953 143954!HeapTest methodsFor: 'tests - fixture'! 143955test0FixtureIncludeWithIdentityTest 143956 | element | 143957 self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. 143958 element := self collectionWithCopyNonIdentical anyOne. 143959 self deny: element == element copy. 143960! ! 143961 143962!HeapTest methodsFor: 'tests - fixture'! 143963test0FixtureIndexAccessFotMultipliness 143964 self 143965 shouldnt: [ self collectionWithSameAtEndAndBegining ] 143966 raise: Error. 143967 self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 143968 self assert: self collectionWithSameAtEndAndBegining size > 1. 143969 1 to: self collectionWithSameAtEndAndBegining size 143970 do: 143971 [ :i | 143972 i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: 143973 [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! 143974 143975!HeapTest methodsFor: 'tests - fixture'! 143976test0FixtureIndexAccessTest 143977 | res collection element | 143978 self 143979 shouldnt: [ self collectionMoreThan1NoDuplicates ] 143980 raise: Error. 143981 self assert: self collectionMoreThan1NoDuplicates size >1. 143982 res := true. 143983 self collectionMoreThan1NoDuplicates 143984 detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] 143985 ifNone: [ res := false ]. 143986 self assert: res = false. 143987 self 143988 shouldnt: [ self elementInForIndexAccessing ] 143989 raise: Error. 143990 self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). 143991 self 143992 shouldnt: [ self elementNotInForIndexAccessing ] 143993 raise: Error. 143994 self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! 143995 143996!HeapTest methodsFor: 'tests - fixture'! 143997test0FixtureIterateSequencedReadableTest 143998 143999 | res | 144000 144001 self shouldnt: self nonEmptyMoreThan1Element raise: Error. 144002 self assert: self nonEmptyMoreThan1Element size > 1. 144003 144004 144005 self shouldnt: self empty raise: Error. 144006 self assert: self empty isEmpty . 144007 144008 res := true. 144009 self nonEmptyMoreThan1Element 144010 detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] 144011 ifNone: [ res := false ]. 144012 self assert: res = false.! ! 144013 144014!HeapTest methodsFor: 'tests - fixture'! 144015test0FixtureOccurrencesForMultiplinessTest 144016 | cpt element collection | 144017 self shouldnt: [self collectionWithEqualElements ]raise: Error. 144018self shouldnt: [self collectionWithEqualElements ]raise: Error. 144019 144020self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 144021element := self elementTwiceInForOccurrences . 144022collection := self collectionWithEqualElements . 144023 144024cpt := 0 . 144025" testing with identity check ( == ) so that identy collections can use this trait : " 144026self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. 144027self assert: cpt = 2.! ! 144028 144029!HeapTest methodsFor: 'tests - fixture'! 144030test0FixtureOccurrencesTest 144031 | tmp | 144032 self shouldnt: [self empty ]raise: Error. 144033 self assert: self empty isEmpty. 144034 144035 self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. 144036 self deny: self collectionWithoutEqualElements isEmpty. 144037 144038 tmp := OrderedCollection new. 144039 self collectionWithoutEqualElements do: [ 144040 :each | 144041 self deny: (tmp includes: each). 144042 tmp add: each. 144043 ]. 144044 144045 144046 self shouldnt: [ self elementNotInForOccurrences ] raise: Error. 144047 self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! 144048 144049!HeapTest methodsFor: 'tests - fixture'! 144050test0FixturePrintTest 144051 144052 self shouldnt: [self nonEmpty ] raise: Error.! ! 144053 144054!HeapTest methodsFor: 'tests - fixture'! 144055test0FixtureRequirementsOfTAddTest 144056 self 144057 shouldnt: [ self collectionWithElement ] 144058 raise: Exception. 144059 self 144060 shouldnt: [ self otherCollection ] 144061 raise: Exception. 144062 self 144063 shouldnt: [ self element ] 144064 raise: Exception. 144065 self assert: (self collectionWithElement includes: self element). 144066 self deny: (self otherCollection includes: self element)! ! 144067 144068!HeapTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/2/2009 11:53'! 144069test0FixtureRequirementsOfTGrowableTest 144070 self 144071 shouldnt: [ self empty ] 144072 raise: Exception. 144073 self 144074 shouldnt: [ self nonEmpty ] 144075 raise: Exception. 144076 self 144077 shouldnt: [ self element ] 144078 raise: Exception. 144079 self 144080 shouldnt: [ self elementNotInForOccurrences ] 144081 raise: Exception. 144082 self assert: self empty isEmpty. 144083 self deny: self nonEmpty isEmpty. 144084 self assert: (self nonEmpty includes: self element). 144085 self deny: (self nonEmpty includes: self elementNotInForOccurrences)! ! 144086 144087!HeapTest methodsFor: 'tests - fixture'! 144088test0FixtureSequencedConcatenationTest 144089 self 144090 shouldnt: self empty 144091 raise: Exception. 144092 self assert: self empty isEmpty. 144093 self 144094 shouldnt: self firstCollection 144095 raise: Exception. 144096 self 144097 shouldnt: self secondCollection 144098 raise: Exception! ! 144099 144100!HeapTest methodsFor: 'tests - fixture'! 144101test0FixtureSequencedElementAccessTest 144102 self 144103 shouldnt: [ self moreThan4Elements ] 144104 raise: Error. 144105 self assert: self moreThan4Elements size >= 4. 144106 self 144107 shouldnt: [ self subCollectionNotIn ] 144108 raise: Error. 144109 self subCollectionNotIn 144110 detect: [ :each | (self moreThan4Elements includes: each) not ] 144111 ifNone: [ self assert: false ]. 144112 self 144113 shouldnt: [ self elementNotInForElementAccessing ] 144114 raise: Error. 144115 self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). 144116 self 144117 shouldnt: [ self elementInForElementAccessing ] 144118 raise: Error. 144119 self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! 144120 144121!HeapTest methodsFor: 'tests - fixture'! 144122test0FixtureSetAritmeticTest 144123 self 144124 shouldnt: [ self collection ] 144125 raise: Error. 144126 self deny: self collection isEmpty. 144127 self 144128 shouldnt: [ self nonEmpty ] 144129 raise: Error. 144130 self deny: self nonEmpty isEmpty. 144131 self 144132 shouldnt: [ self anotherElementOrAssociationNotIn ] 144133 raise: Error. 144134 self collection isDictionary 144135 ifTrue: 144136 [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] 144137 ifFalse: 144138 [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. 144139 self 144140 shouldnt: [ self collectionClass ] 144141 raise: Error! ! 144142 144143!HeapTest methodsFor: 'tests - fixture'! 144144test0FixtureSubcollectionAccessTest 144145 self 144146 shouldnt: [ self moreThan3Elements ] 144147 raise: Error. 144148 self assert: self moreThan3Elements size > 2! ! 144149 144150!HeapTest methodsFor: 'tests - fixture'! 144151test0FixtureTConvertAsSetForMultiplinessTest 144152 "a collection with equal elements:" 144153 | res | 144154 self shouldnt: [ self withEqualElements] raise: Error. 144155 144156 res := true. 144157 self withEqualElements 144158 detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] 144159 ifNone: [ res := false ]. 144160 self assert: res = true. 144161 144162! ! 144163 144164!HeapTest methodsFor: 'tests - fixture'! 144165test0FixtureTConvertTest 144166 "a collection of number without equal elements:" 144167 | res | 144168 self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. 144169 144170 res := true. 144171 self collectionWithoutEqualElements 144172 detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] 144173 ifNone: [ res := false ]. 144174 self assert: res = false. 144175 144176 144177! ! 144178 144179!HeapTest methodsFor: 'tests - fixture'! 144180test0FixtureTRemoveTest 144181 | duplicate | 144182 self shouldnt: [ self empty ]raise: Error. 144183 self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. 144184 self deny: self nonEmptyWithoutEqualElements isEmpty. 144185 duplicate := true. 144186 self nonEmptyWithoutEqualElements detect: 144187 [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] 144188 ifNone: [duplicate := false]. 144189 self assert: duplicate = false. 144190 144191 144192 self shouldnt: [ self elementNotIn ] raise: Error. 144193 self assert: self empty isEmpty. 144194 self deny: self nonEmptyWithoutEqualElements isEmpty. 144195 self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! 144196 144197!HeapTest methodsFor: 'tests - fixture'! 144198test0TSequencedStructuralEqualityTest 144199 144200 self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! 144201 144202!HeapTest methodsFor: 'tests - fixture'! 144203test0TStructuralEqualityTest 144204 self shouldnt: [self empty] raise: Error. 144205 self shouldnt: [self nonEmpty] raise: Error. 144206 self assert: self empty isEmpty. 144207 self deny: self nonEmpty isEmpty.! ! 144208 144209!HeapTest methodsFor: 'tests - fixture'! 144210testOFixtureReplacementSequencedTest 144211 144212 self shouldnt: self nonEmpty raise: Error. 144213 self deny: self nonEmpty isEmpty. 144214 144215 self shouldnt: self elementInForReplacement raise: Error. 144216 self assert: (self nonEmpty includes: self elementInForReplacement ) . 144217 144218 self shouldnt: self newElement raise: Error. 144219 144220 self shouldnt: self firstIndex raise: Error. 144221 self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). 144222 144223 self shouldnt: self secondIndex raise: Error. 144224 self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). 144225 144226 self assert: self firstIndex <=self secondIndex . 144227 144228 self shouldnt: self replacementCollection raise: Error. 144229 144230 self shouldnt: self replacementCollectionSameSize raise: Error. 144231 self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size 144232 ! ! 144233 144234 144235!HeapTest methodsFor: 'tests - growable'! 144236testAddEmptyGrows 144237 "self debug: #testAddEmptyGrows" 144238 144239 | oldSize | 144240 oldSize := self empty size. 144241 self empty add: self element. 144242 self assert: (self empty size) = (oldSize + 1).! ! 144243 144244!HeapTest methodsFor: 'tests - growable' stamp: 'delaunay 4/2/2009 11:53'! 144245testAddNonEmptyGrowsWhenNewElement 144246 "self debug: #testAddNonEmptyGrowsWhenNewElement" 144247 | oldSize | 144248 oldSize := self nonEmpty size. 144249 self deny: (self nonEmpty includes: self elementNotInForOccurrences). 144250 self nonEmpty add: self elementNotInForOccurrences. 144251 self assert: self nonEmpty size > oldSize! ! 144252 144253 144254!HeapTest methodsFor: 'tests - includes'! 144255testIdentityIncludesNonSpecificComportement 144256 " test the same comportement than 'includes: ' " 144257 | collection | 144258 collection := self nonEmpty . 144259 144260 self deny: (collection identityIncludes: self elementNotIn ). 144261 self assert:(collection identityIncludes: collection anyOne) 144262! ! 144263 144264!HeapTest methodsFor: 'tests - includes'! 144265testIncludesAllOfAllThere 144266 "self debug: #testIncludesAllOfAllThere'" 144267 self assert: (self empty includesAllOf: self empty). 144268 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 144269 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 144270 144271!HeapTest methodsFor: 'tests - includes'! 144272testIncludesAllOfNoneThere 144273 "self debug: #testIncludesAllOfNoneThere'" 144274 self deny: (self empty includesAllOf: self nonEmpty ). 144275 self deny: (self nonEmpty includesAllOf: { self elementNotIn. self anotherElementNotIn })! ! 144276 144277!HeapTest methodsFor: 'tests - includes'! 144278testIncludesAnyOfAllThere 144279 "self debug: #testIncludesAnyOfAllThere'" 144280 self deny: (self nonEmpty includesAnyOf: self empty). 144281 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 144282 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 144283 144284!HeapTest methodsFor: 'tests - includes'! 144285testIncludesAnyOfNoneThere 144286 "self debug: #testIncludesAnyOfNoneThere'" 144287 self deny: (self nonEmpty includesAnyOf: self empty). 144288 self deny: (self nonEmpty includesAnyOf: { self elementNotIn. self anotherElementNotIn })! ! 144289 144290!HeapTest methodsFor: 'tests - includes'! 144291testIncludesElementIsNotThere 144292 "self debug: #testIncludesElementIsNotThere" 144293 144294 self deny: (self nonEmpty includes: self elementNotIn). 144295 self assert: (self nonEmpty includes: self nonEmpty anyOne). 144296 self deny: (self empty includes: self elementNotIn)! ! 144297 144298!HeapTest methodsFor: 'tests - includes'! 144299testIncludesElementIsThere 144300 "self debug: #testIncludesElementIsThere" 144301 144302 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 144303 144304 144305!HeapTest methodsFor: 'tests - including with identity'! 144306testIdentityIncludes 144307 " test the comportement in presence of elements 'includes' but not 'identityIncludes' " 144308 " can not be used by collections that can't include elements for wich copy doesn't return another instance " 144309 | collection element | 144310 144311 collection := self collectionWithCopyNonIdentical. 144312 element := collection anyOne copy. 144313 144314 self deny: (collection identityIncludes: element)! ! 144315 144316 144317!HeapTest methodsFor: 'tests - index access'! 144318testIdentityIndexOf 144319 "self debug: #testIdentityIndexOf" 144320 | collection element | 144321 collection := self collectionMoreThan1NoDuplicates. 144322 element := collection first. 144323 self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! 144324 144325!HeapTest methodsFor: 'tests - index access'! 144326testIdentityIndexOfIAbsent 144327 | collection element | 144328 collection := self collectionMoreThan1NoDuplicates. 144329 element := collection first. 144330 self assert: (collection 144331 identityIndexOf: element 144332 ifAbsent: [ 0 ]) = 1. 144333 self assert: (collection 144334 identityIndexOf: self elementNotInForIndexAccessing 144335 ifAbsent: [ 55 ]) = 55! ! 144336 144337!HeapTest methodsFor: 'tests - index access'! 144338testIndexOf 144339 "self debug: #testIndexOf" 144340 | tmp index collection | 144341 collection := self collectionMoreThan1NoDuplicates. 144342 tmp := collection size. 144343 collection reverseDo: 144344 [ :each | 144345 each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. 144346 tmp := tmp - 1 ]. 144347 self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! 144348 144349!HeapTest methodsFor: 'tests - index access'! 144350testIndexOfIfAbsent 144351 "self debug: #testIndexOfIfAbsent" 144352 | collection | 144353 collection := self collectionMoreThan1NoDuplicates. 144354 self assert: (collection 144355 indexOf: collection first 144356 ifAbsent: [ 33 ]) = 1. 144357 self assert: (collection 144358 indexOf: self elementNotInForIndexAccessing 144359 ifAbsent: [ 33 ]) = 33! ! 144360 144361!HeapTest methodsFor: 'tests - index access'! 144362testIndexOfStartingAt 144363 "self debug: #testLastIndexOf" 144364 | element collection | 144365 collection := self collectionMoreThan1NoDuplicates. 144366 element := collection first. 144367 self assert: (collection 144368 indexOf: element 144369 startingAt: 2 144370 ifAbsent: [ 99 ]) = 99. 144371 self assert: (collection 144372 indexOf: element 144373 startingAt: 1 144374 ifAbsent: [ 99 ]) = 1. 144375 self assert: (collection 144376 indexOf: self elementNotInForIndexAccessing 144377 startingAt: 1 144378 ifAbsent: [ 99 ]) = 99! ! 144379 144380!HeapTest methodsFor: 'tests - index access'! 144381testIndexOfStartingAtIfAbsent 144382 "self debug: #testLastIndexOf" 144383 | element collection | 144384 collection := self collectionMoreThan1NoDuplicates. 144385 element := collection first. 144386 self assert: (collection 144387 indexOf: element 144388 startingAt: 2 144389 ifAbsent: [ 99 ]) = 99. 144390 self assert: (collection 144391 indexOf: element 144392 startingAt: 1 144393 ifAbsent: [ 99 ]) = 1. 144394 self assert: (collection 144395 indexOf: self elementNotInForIndexAccessing 144396 startingAt: 1 144397 ifAbsent: [ 99 ]) = 99! ! 144398 144399!HeapTest methodsFor: 'tests - index access'! 144400testIndexOfSubCollectionStartingAt 144401 "self debug: #testIndexOfIfAbsent" 144402 | subcollection index collection | 144403 collection := self collectionMoreThan1NoDuplicates. 144404 subcollection := self collectionMoreThan1NoDuplicates. 144405 index := collection 144406 indexOfSubCollection: subcollection 144407 startingAt: 1. 144408 self assert: index = 1. 144409 index := collection 144410 indexOfSubCollection: subcollection 144411 startingAt: 2. 144412 self assert: index = 0! ! 144413 144414!HeapTest methodsFor: 'tests - index access'! 144415testIndexOfSubCollectionStartingAtIfAbsent 144416 "self debug: #testIndexOfIfAbsent" 144417 | index absent subcollection collection | 144418 collection := self collectionMoreThan1NoDuplicates. 144419 subcollection := self collectionMoreThan1NoDuplicates. 144420 absent := false. 144421 index := collection 144422 indexOfSubCollection: subcollection 144423 startingAt: 1 144424 ifAbsent: [ absent := true ]. 144425 self assert: absent = false. 144426 absent := false. 144427 index := collection 144428 indexOfSubCollection: subcollection 144429 startingAt: 2 144430 ifAbsent: [ absent := true ]. 144431 self assert: absent = true! ! 144432 144433!HeapTest methodsFor: 'tests - index access'! 144434testLastIndexOf 144435 "self debug: #testLastIndexOf" 144436 | element collection | 144437 collection := self collectionMoreThan1NoDuplicates. 144438 element := collection first. 144439 self assert: (collection lastIndexOf: element) = 1. 144440 self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! 144441 144442!HeapTest methodsFor: 'tests - index access'! 144443testLastIndexOfIfAbsent 144444 "self debug: #testIndexOfIfAbsent" 144445 | element collection | 144446 collection := self collectionMoreThan1NoDuplicates. 144447 element := collection first. 144448 self assert: (collection 144449 lastIndexOf: element 144450 ifAbsent: [ 99 ]) = 1. 144451 self assert: (collection 144452 lastIndexOf: self elementNotInForIndexAccessing 144453 ifAbsent: [ 99 ]) = 99! ! 144454 144455!HeapTest methodsFor: 'tests - index access'! 144456testLastIndexOfStartingAt 144457 "self debug: #testLastIndexOf" 144458 | element collection | 144459 collection := self collectionMoreThan1NoDuplicates. 144460 element := collection last. 144461 self assert: (collection 144462 lastIndexOf: element 144463 startingAt: collection size 144464 ifAbsent: [ 99 ]) = collection size. 144465 self assert: (collection 144466 lastIndexOf: element 144467 startingAt: collection size - 1 144468 ifAbsent: [ 99 ]) = 99. 144469 self assert: (collection 144470 lastIndexOf: self elementNotInForIndexAccessing 144471 startingAt: collection size 144472 ifAbsent: [ 99 ]) = 99! ! 144473 144474 144475!HeapTest methodsFor: 'tests - index accessing for multipliness'! 144476testIdentityIndexOfDuplicate 144477 "self debug: #testIdentityIndexOf" 144478 | collection element | 144479 144480 "testing fixture here as this method may not be used by some collections testClass" 144481 self shouldnt: [self collectionWithNonIdentitySameAtEndAndBegining ] raise: Error. 144482 collection := self collectionWithNonIdentitySameAtEndAndBegining . 144483 self assert: collection first = collection last. 144484 self deny: collection first == collection last. 144485 1 to: collection size do: 144486 [ :i | 144487 i > 1 & (i < collection size) ifTrue: 144488 [ self deny: (collection at: i) = collection first ] ]. 144489 144490 144491 element := collection last. 144492 " floatCollectionWithSameAtEndAndBegining first and last elements are equals but are not the same object" 144493 self assert: (collection identityIndexOf: element) = collection size! ! 144494 144495!HeapTest methodsFor: 'tests - index accessing for multipliness'! 144496testIdentityIndexOfIAbsentDuplicate 144497 "self debug: #testIdentityIndexOfIfAbsent" 144498 | collection element elementCopy | 144499 collection := self collectionWithNonIdentitySameAtEndAndBegining . 144500 element := collection last. 144501 elementCopy := element copy. 144502 self deny: element == elementCopy . 144503 self assert: (collection 144504 identityIndexOf: element 144505 ifAbsent: [ 0 ]) = collection size. 144506 self assert: (collection 144507 identityIndexOf: elementCopy 144508 ifAbsent: [ 55 ]) = 55! ! 144509 144510!HeapTest methodsFor: 'tests - index accessing for multipliness'! 144511testIndexOfDuplicate 144512 "self debug: #testIndexOf" 144513 | collection element | 144514 collection := self collectionWithSameAtEndAndBegining. 144515 element := collection last. 144516 144517 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 144518 'indexOf: should return the position of the first occurrence :'" 144519 self assert: (collection indexOf: element) = 1! ! 144520 144521!HeapTest methodsFor: 'tests - index accessing for multipliness'! 144522testIndexOfIfAbsentDuplicate 144523 "self debug: #testIndexOfIfAbsent" 144524 | collection element | 144525 collection := self collectionWithSameAtEndAndBegining. 144526 element := collection last. 144527 144528 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 144529 'indexOf:ifAbsent: should return the position of the first occurrence :'" 144530 self assert: (collection 144531 indexOf: element 144532 ifAbsent: [ 55 ]) = 1! ! 144533 144534!HeapTest methodsFor: 'tests - index accessing for multipliness'! 144535testIndexOfStartingAtDuplicate 144536 "self debug: #testLastIndexOf" 144537 | collection element | 144538 collection := self collectionWithSameAtEndAndBegining. 144539 element := collection last. 144540 144541 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 144542 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" 144543 self assert: (collection 144544 indexOf: element 144545 startingAt: 1 144546 ifAbsent: [ 55 ]) = 1. 144547 self assert: (collection 144548 indexOf: element 144549 startingAt: 2 144550 ifAbsent: [ 55 ]) = collection size! ! 144551 144552!HeapTest methodsFor: 'tests - index accessing for multipliness'! 144553testLastIndexOfDuplicate 144554 "self debug: #testLastIndexOf" 144555 | collection element | 144556 collection := self collectionWithSameAtEndAndBegining. 144557 element := collection first. 144558 144559 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 144560 'lastIndexOf: should return the position of the last occurrence :'" 144561 self assert: (collection lastIndexOf: element) = collection size! ! 144562 144563!HeapTest methodsFor: 'tests - index accessing for multipliness'! 144564testLastIndexOfIfAbsentDuplicate 144565 "self debug: #testIndexOfIfAbsent" 144566 "self debug: #testLastIndexOf" 144567 | collection element | 144568 collection := self collectionWithSameAtEndAndBegining. 144569 element := collection first. 144570 144571 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 144572 'lastIndexOf: should return the position of the last occurrence :'" 144573 self assert: (collection 144574 lastIndexOf: element 144575 ifAbsent: [ 55 ]) = collection size! ! 144576 144577!HeapTest methodsFor: 'tests - index accessing for multipliness'! 144578testLastIndexOfStartingAtDuplicate 144579 "self debug: #testLastIndexOf" 144580 | collection element | 144581 collection := self collectionWithSameAtEndAndBegining. 144582 element := collection last. 144583 144584 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 144585 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" 144586 self assert: (collection 144587 lastIndexOf: element 144588 startingAt: collection size 144589 ifAbsent: [ 55 ]) = collection size. 144590 self assert: (collection 144591 lastIndexOf: element 144592 startingAt: collection size - 1 144593 ifAbsent: [ 55 ]) = 1! ! 144594 144595 144596!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144597testAllButFirstDo 144598 144599 | result | 144600 result:= OrderedCollection new. 144601 144602 self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 144603 144604 1 to: (result size) do: 144605 [:i| 144606 self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. 144607 144608 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 144609 144610!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144611testAllButLastDo 144612 144613 | result | 144614 result:= OrderedCollection new. 144615 144616 self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 144617 144618 1 to: (result size) do: 144619 [:i| 144620 self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. 144621 144622 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 144623 144624!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144625testCollectFromTo 144626 144627 | result | 144628 result:=self nonEmptyMoreThan1Element 144629 collect: [ :each | each ] 144630 from: 1 144631 to: (self nonEmptyMoreThan1Element size - 1). 144632 144633 1 to: result size 144634 do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. 144635 self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! 144636 144637!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144638testDetectSequenced 144639" testing that detect keep the first element returning true for sequenceable collections " 144640 144641 | element result | 144642 element := self nonEmptyMoreThan1Element at:1. 144643 result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. 144644 self assert: result = element. ! ! 144645 144646!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144647testFindFirst 144648 144649 | element result | 144650 element := self nonEmptyMoreThan1Element at:1. 144651 result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. 144652 144653 self assert: result=1. ! ! 144654 144655!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144656testFindFirstNotIn 144657 144658 | result | 144659 144660 result:=self empty findFirst: [:each | true]. 144661 144662 self assert: result=0. ! ! 144663 144664!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144665testFindLast 144666 144667 | element result | 144668 element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. 144669 result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. 144670 144671 self assert: result=self nonEmptyMoreThan1Element size. ! ! 144672 144673!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144674testFindLastNotIn 144675 144676 | result | 144677 144678 result:=self empty findFirst: [:each | true]. 144679 144680 self assert: result=0. ! ! 144681 144682!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144683testFromToDo 144684 144685 | result | 144686 result:= OrderedCollection new. 144687 144688 self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 144689 144690 1 to: (self nonEmptyMoreThan1Element size -1) do: 144691 [:i| 144692 self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. 144693 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 144694 144695!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144696testKeysAndValuesDo 144697 "| result | 144698 result:= OrderedCollection new. 144699 144700 self nonEmptyMoreThan1Element keysAndValuesDo: 144701 [:i :value| 144702 result add: (value+i)]. 144703 144704 1 to: result size do: 144705 [:i| 144706 self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" 144707 | indexes elements | 144708 indexes:= OrderedCollection new. 144709 elements := OrderedCollection new. 144710 144711 self nonEmptyMoreThan1Element keysAndValuesDo: 144712 [:i :value| 144713 indexes add: (i). 144714 elements add: value]. 144715 144716 (1 to: self nonEmptyMoreThan1Element size )do: 144717 [ :i | 144718 self assert: (indexes at: i) = i. 144719 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 144720 ]. 144721 144722 self assert: indexes size = elements size. 144723 self assert: indexes size = self nonEmptyMoreThan1Element size . 144724 144725 ! ! 144726 144727!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144728testKeysAndValuesDoEmpty 144729 | result | 144730 result:= OrderedCollection new. 144731 144732 self empty keysAndValuesDo: 144733 [:i :value| 144734 result add: (value+i)]. 144735 144736 self assert: result isEmpty .! ! 144737 144738!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144739testPairsCollect 144740 144741 | index result | 144742 index:=0. 144743 144744 result:=self nonEmptyMoreThan1Element pairsCollect: 144745 [:each1 :each2 | 144746 self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). 144747 (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). 144748 ]. 144749 144750 result do: 144751 [:each | self assert: each = true]. 144752 144753! ! 144754 144755!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144756testPairsDo 144757 | index | 144758 index:=1. 144759 144760 self nonEmptyMoreThan1Element pairsDo: 144761 [:each1 :each2 | 144762 self assert:(self nonEmptyMoreThan1Element at:index)=each1. 144763 self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. 144764 index:=index+2]. 144765 144766 self nonEmptyMoreThan1Element size odd 144767 ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] 144768 ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! 144769 144770!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144771testReverseDo 144772 | result | 144773 result:= OrderedCollection new. 144774 self nonEmpty reverseDo: [: each | result add: each]. 144775 144776 1 to: result size do: 144777 [:i| 144778 self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! 144779 144780!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144781testReverseDoEmpty 144782 | result | 144783 result:= OrderedCollection new. 144784 self empty reverseDo: [: each | result add: each]. 144785 144786 self assert: result isEmpty .! ! 144787 144788!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144789testReverseWithDo 144790 144791 | secondCollection result index | 144792 result:= OrderedCollection new. 144793 index := self nonEmptyMoreThan1Element size + 1. 144794 secondCollection:= self nonEmptyMoreThan1Element copy. 144795 144796 self nonEmptyMoreThan1Element reverseWith: secondCollection do: 144797 [:a :b | 144798 self assert: (self nonEmptyMoreThan1Element indexOf: a ) = (index := index - 1 ). 144799 result add: (a = b)]. 144800 144801 1 to: result size do: 144802 [:i| 144803 self assert: (result at:i)=(true)]. 144804 self assert: result size = self nonEmptyMoreThan1Element size.! ! 144805 144806!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144807testWithCollect 144808 144809 | result newCollection index collection | 144810 144811 index := 0. 144812 collection := self nonEmptyMoreThan1Element . 144813 newCollection := collection copy. 144814 result:=collection with: newCollection collect: [:a :b | 144815 self assert: (collection indexOf: a ) = ( index := index + 1). 144816 self assert: (a = b). 144817 b]. 144818 144819 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 144820 self assert: result size = collection size.! ! 144821 144822!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144823testWithCollectError 144824 self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! 144825 144826!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144827testWithDo 144828 144829 | secondCollection result index | 144830 result:= OrderedCollection new. 144831 secondCollection:= self nonEmptyMoreThan1Element copy. 144832 index := 0. 144833 144834 self nonEmptyMoreThan1Element with: secondCollection do: 144835 [:a :b | 144836 self assert: (self nonEmptyMoreThan1Element indexOf: a) = ( index := index + 1). 144837 result add: (a =b)]. 144838 144839 1 to: result size do: 144840 [:i| 144841 self assert: (result at:i)=(true)]. 144842 self assert: result size = self nonEmptyMoreThan1Element size.! ! 144843 144844!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144845testWithDoError 144846 144847 self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! 144848 144849!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144850testWithIndexCollect 144851 144852 | result index collection | 144853 index := 0. 144854 collection := self nonEmptyMoreThan1Element . 144855 result := collection withIndexCollect: [:each :i | 144856 self assert: i = (index := index + 1). 144857 self assert: i = (collection indexOf: each) . 144858 each] . 144859 144860 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 144861 self assert: result size = collection size.! ! 144862 144863!HeapTest methodsFor: 'tests - iterate on sequenced reable collections'! 144864testWithIndexDo 144865 144866 "| result | 144867 result:=Array new: self nonEmptyMoreThan1Element size. 144868 self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 144869 144870 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" 144871 | indexes elements | 144872 indexes:= OrderedCollection new. 144873 elements := OrderedCollection new. 144874 144875 self nonEmptyMoreThan1Element withIndexDo: 144876 [:value :i | 144877 indexes add: (i). 144878 elements add: value]. 144879 144880 (1 to: self nonEmptyMoreThan1Element size )do: 144881 [ :i | 144882 self assert: (indexes at: i) = i. 144883 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 144884 ]. 144885 144886 self assert: indexes size = elements size. 144887 self assert: indexes size = self nonEmptyMoreThan1Element size . 144888 ! ! 144889 144890 144891!HeapTest methodsFor: 'tests - occurrencesOf'! 144892testOccurrencesOf 144893 | collection | 144894 collection := self collectionWithoutEqualElements . 144895 144896 collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! 144897 144898!HeapTest methodsFor: 'tests - occurrencesOf'! 144899testOccurrencesOfEmpty 144900 | result | 144901 result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). 144902 self assert: result = 0! ! 144903 144904!HeapTest methodsFor: 'tests - occurrencesOf'! 144905testOccurrencesOfNotIn 144906 | result | 144907 result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. 144908 self assert: result = 0! ! 144909 144910 144911!HeapTest methodsFor: 'tests - occurrencesOf for multipliness'! 144912testOccurrencesOfForMultipliness 144913 144914| collection element | 144915collection := self collectionWithEqualElements . 144916element := self elementTwiceInForOccurrences . 144917 144918self assert: (collection occurrencesOf: element ) = 2. ! ! 144919 144920 144921!HeapTest methodsFor: 'tests - printing'! 144922testPrintElementsOn 144923 144924 | aStream result allElementsAsString | 144925 result:=''. 144926 aStream:= ReadWriteStream on: result. 144927 144928 self nonEmpty printElementsOn: aStream . 144929 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 144930 1 to: allElementsAsString size do: 144931 [:i | 144932 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 144933 ].! ! 144934 144935!HeapTest methodsFor: 'tests - printing'! 144936testPrintNameOn 144937 144938 | aStream result | 144939 result:=''. 144940 aStream:= ReadWriteStream on: result. 144941 144942 self nonEmpty printNameOn: aStream . 144943 Transcript show: result asString. 144944 self nonEmpty class name first isVowel 144945 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 144946 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 144947 144948!HeapTest methodsFor: 'tests - printing'! 144949testPrintOn 144950 | aStream result allElementsAsString | 144951 result:=''. 144952 aStream:= ReadWriteStream on: result. 144953 144954 self nonEmpty printOn: aStream . 144955 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 144956 1 to: allElementsAsString size do: 144957 [:i | 144958 i=1 144959 ifTrue:[ 144960 self accessCollection class name first isVowel 144961 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 144962 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 144963 i=2 144964 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 144965 i>2 144966 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. 144967 ].! ! 144968 144969!HeapTest methodsFor: 'tests - printing'! 144970testPrintOnDelimiter 144971 | aStream result allElementsAsString | 144972 result:=''. 144973 aStream:= ReadWriteStream on: result. 144974 144975 self nonEmpty printOn: aStream delimiter: ', ' . 144976 144977 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 144978 1 to: allElementsAsString size do: 144979 [:i | 144980 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 144981 ].! ! 144982 144983!HeapTest methodsFor: 'tests - printing'! 144984testPrintOnDelimiterLast 144985 144986 | aStream result allElementsAsString | 144987 result:=''. 144988 aStream:= ReadWriteStream on: result. 144989 144990 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 144991 144992 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 144993 1 to: allElementsAsString size do: 144994 [:i | 144995 i<(allElementsAsString size-1 ) 144996 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 144997 i=(allElementsAsString size-1) 144998 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 144999 i=(allElementsAsString size) 145000 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 145001 ].! ! 145002 145003!HeapTest methodsFor: 'tests - printing'! 145004testStoreOn 145005" for the moment work only for collection that include simple elements such that Integer" 145006 145007"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 145008string := ''. 145009str := ReadWriteStream on: string. 145010elementsAsStringExpected := OrderedCollection new. 145011elementsAsStringObtained := OrderedCollection new. 145012self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 145013 145014self nonEmpty storeOn: str. 145015result := str contents . 145016cuttedResult := ( result findBetweenSubStrs: ';' ). 145017 145018index := 1. 145019 145020cuttedResult do: 145021 [ :each | 145022 index = 1 145023 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 145024 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 145025 elementsAsStringObtained add: tmp. 145026 index := index + 1. ] 145027 ifFalse: [ 145028 index < cuttedResult size 145029 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 145030 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 145031 elementsAsStringObtained add: tmp. 145032 index := index + 1.] 145033 ifFalse: [self assert: ( each = ' yourself)' ) ]. 145034 ] 145035 145036 ]. 145037 145038 145039 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 145040 145041! ! 145042 145043 145044!HeapTest methodsFor: 'tests - remove'! 145045testRemoveAll 145046 "self debug: #testRemoveElementThatExists" 145047 | el res subCollection collection | 145048 collection := self nonEmptyWithoutEqualElements. 145049 el := collection anyOne. 145050 subCollection := collection copyWithout: el. 145051 self 145052 shouldnt: [ res := collection removeAll: subCollection ] 145053 raise: Error. 145054 self assert: collection size = 1. 145055 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 145056 145057!HeapTest methodsFor: 'tests - remove'! 145058testRemoveAllError 145059 "self debug: #testRemoveElementThatExists" 145060 | el res subCollection | 145061 el := self elementNotIn. 145062 subCollection := self nonEmptyWithoutEqualElements copyWith: el. 145063 self 145064 should: [ res := self nonEmptyWithoutEqualElements removeAll: subCollection ] 145065 raise: Error! ! 145066 145067!HeapTest methodsFor: 'tests - remove'! 145068testRemoveAllFoundIn 145069 "self debug: #testRemoveElementThatExists" 145070 | el res subCollection | 145071 el := self nonEmptyWithoutEqualElements anyOne. 145072 subCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. 145073 self 145074 shouldnt: 145075 [ res := self nonEmptyWithoutEqualElements removeAllFoundIn: subCollection ] 145076 raise: Error. 145077 self assert: self nonEmptyWithoutEqualElements size = 1. 145078 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 145079 145080!HeapTest methodsFor: 'tests - remove'! 145081testRemoveAllSuchThat 145082 "self debug: #testRemoveElementThatExists" 145083 | el subCollection | 145084 el := self nonEmptyWithoutEqualElements anyOne. 145085 subCollection := self nonEmptyWithoutEqualElements copyWithout: el. 145086 self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | subCollection includes: each ]. 145087 self assert: self nonEmptyWithoutEqualElements size = 1. 145088 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 145089 145090!HeapTest methodsFor: 'tests - remove'! 145091testRemoveElementFromEmpty 145092 "self debug: #testRemoveElementFromEmpty" 145093 self 145094 should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] 145095 raise: Error! ! 145096 145097!HeapTest methodsFor: 'tests - remove'! 145098testRemoveElementReallyRemovesElement 145099 "self debug: #testRemoveElementReallyRemovesElement" 145100 | size | 145101 size := self nonEmptyWithoutEqualElements size. 145102 self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. 145103 self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! 145104 145105!HeapTest methodsFor: 'tests - remove'! 145106testRemoveElementThatExists 145107 "self debug: #testRemoveElementThatExists" 145108 | el res | 145109 el := self nonEmptyWithoutEqualElements anyOne. 145110 self 145111 shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] 145112 raise: Error. 145113 self assert: res == el! ! 145114 145115!HeapTest methodsFor: 'tests - remove'! 145116testRemoveIfAbsent 145117 "self debug: #testRemoveElementThatExists" 145118 | el res | 145119 el := self elementNotIn. 145120 self 145121 shouldnt: 145122 [ res := self nonEmptyWithoutEqualElements 145123 remove: el 145124 ifAbsent: [ 33 ] ] 145125 raise: Error. 145126 self assert: res == 33! ! 145127 145128 145129!HeapTest methodsFor: 'tests - replacing'! 145130testReplaceAllWith 145131 | result collection oldElement newElement | 145132 collection := self nonEmpty . 145133 result := collection copy. 145134 oldElement := self elementInForReplacement . 145135 newElement := self newElement . 145136 result replaceAll: oldElement with: newElement . 145137 145138 1 to: collection size do: 145139 [: 145140 each | 145141 ( collection at: each ) = oldElement 145142 ifTrue: [ self assert: ( result at: each ) = newElement ]. 145143 ].! ! 145144 145145!HeapTest methodsFor: 'tests - replacing'! 145146testReplaceFromToWith 145147 | result collection replacementCollection firstIndex secondIndex | 145148 collection := self nonEmpty . 145149 replacementCollection := self replacementCollectionSameSize . 145150 firstIndex := self firstIndex . 145151 secondIndex := self secondIndex . 145152 result := collection copy. 145153 result replaceFrom: firstIndex to: secondIndex with: replacementCollection . 145154 145155 "verify content of 'result' : " 145156 "first part of 'result'' : '" 145157 145158 1 to: ( firstIndex - 1 ) do: [ :i | self assert: (collection at:i ) = ( result at: i ) ]. 145159 145160 " middle part containing replacementCollection : " 145161 145162 ( firstIndex ) to: ( firstIndex + replacementCollection size - 1 ) do: 145163 [ :i | 145164 self assert: ( result at: i ) = ( replacementCollection at: ( i - firstIndex +1 ) ) 145165 ]. 145166 145167 " end part :" 145168 ( firstIndex + replacementCollection size) to: (result size) do: 145169 [:i| 145170 self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ]. 145171 145172 ! ! 145173 145174!HeapTest methodsFor: 'tests - replacing'! 145175testReplaceFromToWithStartingAt 145176 | result repStart collection replacementCollection firstIndex secondIndex | 145177 collection := self nonEmpty . 145178 result := collection copy. 145179 replacementCollection := self replacementCollectionSameSize . 145180 firstIndex := self firstIndex . 145181 secondIndex := self secondIndex . 145182 repStart := replacementCollection size - ( secondIndex - firstIndex + 1 ) + 1. 145183 result replaceFrom: firstIndex to: secondIndex with: replacementCollection startingAt: repStart . 145184 145185 "verify content of 'result' : " 145186 "first part of 'result'' : '" 145187 145188 1 to: ( firstIndex - 1 ) do: [ :i | self assert: ( collection at:i ) = ( result at: i ) ]. 145189 145190 " middle part containing replacementCollection : " 145191 145192 ( firstIndex ) to: ( replacementCollection size - repStart +1 ) do: 145193 [:i| 145194 self assert: (result at: i)=( replacementCollection at: ( repStart + ( i -firstIndex ) ) ) ]. 145195 145196 " end part :" 145197 ( firstIndex + replacementCollection size ) to: ( result size ) do: 145198 [ :i | 145199 self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ].! ! 145200 145201 145202!HeapTest methodsFor: 'tests - set arithmetic'! 145203containsAll: union of: one andOf: another 145204 145205 self assert: (one allSatisfy: [:each | union includes: each]). 145206 self assert: (another allSatisfy: [:each | union includes: each])! ! 145207 145208!HeapTest methodsFor: 'tests - set arithmetic'! 145209numberOfSimilarElementsInIntersection 145210 ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! 145211 145212!HeapTest methodsFor: 'tests - set arithmetic'! 145213testDifference 145214 "Answer the set theoretic difference of two collections." 145215 "self debug: #testDifference" 145216 145217 self assert: (self collection difference: self collection) isEmpty. 145218 self assert: (self empty difference: self collection) isEmpty. 145219 self assert: (self collection difference: self empty) = self collection 145220! ! 145221 145222!HeapTest methodsFor: 'tests - set arithmetic'! 145223testDifferenceWithNonNullIntersection 145224 "Answer the set theoretic difference of two collections." 145225 "self debug: #testDifferenceWithNonNullIntersection" 145226 " #(1 2 3) difference: #(2 4) 145227 -> #(1 3)" 145228 | res overlapping | 145229 overlapping := self collectionClass 145230 with: self anotherElementOrAssociationNotIn 145231 with: self anotherElementOrAssociationIn. 145232 res := self collection difference: overlapping. 145233 self deny: (res includes: self anotherElementOrAssociationIn). 145234 overlapping do: [ :each | self deny: (res includes: each) ]! ! 145235 145236!HeapTest methodsFor: 'tests - set arithmetic'! 145237testDifferenceWithSeparateCollection 145238 "Answer the set theoretic difference of two collections." 145239 "self debug: #testDifferenceWithSeparateCollection" 145240 | res separateCol | 145241 separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. 145242 res := self collection difference: separateCol. 145243 self deny: (res includes: self anotherElementOrAssociationNotIn). 145244 self assert: res = self collection. 145245 res := separateCol difference: self collection. 145246 self deny: (res includes: self collection anyOne). 145247 self assert: res = separateCol! ! 145248 145249!HeapTest methodsFor: 'tests - set arithmetic'! 145250testIntersectionBasic 145251 "self debug: #testIntersectionBasic" 145252 | inter | 145253 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 145254 self deny: inter isEmpty. 145255 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 145256 145257!HeapTest methodsFor: 'tests - set arithmetic'! 145258testIntersectionEmpty 145259 "self debug: #testIntersectionEmpty" 145260 145261 | inter | 145262 inter := self empty intersection: self empty. 145263 self assert: inter isEmpty. 145264 inter := self empty intersection: self collection . 145265 self assert: inter = self empty. 145266 ! ! 145267 145268!HeapTest methodsFor: 'tests - set arithmetic'! 145269testIntersectionItself 145270 "self debug: #testIntersectionItself" 145271 145272 self assert: (self collection intersection: self collection) = self collection. 145273 ! ! 145274 145275!HeapTest methodsFor: 'tests - set arithmetic'! 145276testIntersectionTwoSimilarElementsInIntersection 145277 "self debug: #testIntersectionBasic" 145278 | inter | 145279 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 145280 self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. 145281 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 145282 145283!HeapTest methodsFor: 'tests - set arithmetic'! 145284testUnion 145285 "self debug: #testUnionOfEmpties" 145286 145287 | union | 145288 union := self empty union: self nonEmpty. 145289 self containsAll: union of: self empty andOf: self nonEmpty. 145290 union := self nonEmpty union: self empty. 145291 self containsAll: union of: self empty andOf: self nonEmpty. 145292 union := self collection union: self nonEmpty. 145293 self containsAll: union of: self collection andOf: self nonEmpty.! ! 145294 145295!HeapTest methodsFor: 'tests - set arithmetic'! 145296testUnionOfEmpties 145297 "self debug: #testUnionOfEmpties" 145298 145299 self assert: (self empty union: self empty) isEmpty. 145300 145301 ! ! 145302 145303 145304!HeapTest methodsFor: 'tests - subcollections access'! 145305testAllButFirst 145306 "self debug: #testAllButFirst" 145307 | abf col | 145308 col := self moreThan3Elements. 145309 abf := col allButFirst. 145310 self deny: abf first = col first. 145311 self assert: abf size + 1 = col size! ! 145312 145313!HeapTest methodsFor: 'tests - subcollections access'! 145314testAllButFirstNElements 145315 "self debug: #testAllButFirst" 145316 | abf col | 145317 col := self moreThan3Elements. 145318 abf := col allButFirst: 2. 145319 1 145320 to: abf size 145321 do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. 145322 self assert: abf size + 2 = col size! ! 145323 145324!HeapTest methodsFor: 'tests - subcollections access'! 145325testAllButLast 145326 "self debug: #testAllButLast" 145327 | abf col | 145328 col := self moreThan3Elements. 145329 abf := col allButLast. 145330 self deny: abf last = col last. 145331 self assert: abf size + 1 = col size! ! 145332 145333!HeapTest methodsFor: 'tests - subcollections access'! 145334testAllButLastNElements 145335 "self debug: #testAllButFirst" 145336 | abf col | 145337 col := self moreThan3Elements. 145338 abf := col allButLast: 2. 145339 1 145340 to: abf size 145341 do: [ :i | self assert: (abf at: i) = (col at: i) ]. 145342 self assert: abf size + 2 = col size! ! 145343 145344!HeapTest methodsFor: 'tests - subcollections access'! 145345testFirstNElements 145346 "self debug: #testFirstNElements" 145347 | result | 145348 result := self moreThan3Elements first: self moreThan3Elements size - 1. 145349 1 145350 to: result size 145351 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. 145352 self assert: result size = (self moreThan3Elements size - 1). 145353 self 145354 should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] 145355 raise: Error! ! 145356 145357!HeapTest methodsFor: 'tests - subcollections access'! 145358testLastNElements 145359 "self debug: #testLastNElements" 145360 | result | 145361 result := self moreThan3Elements last: self moreThan3Elements size - 1. 145362 1 145363 to: result size 145364 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. 145365 self assert: result size = (self moreThan3Elements size - 1). 145366 self 145367 should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] 145368 raise: Error! ! 145369 145370"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 145371 145372HeapTest class 145373 uses: TAddTest classTrait + TGrowableTest classTrait + TSequencedElementAccessTest classTrait + TIndexAccess classTrait + TIndexAccessForMultipliness classTrait + TSubCollectionAccess classTrait + TPrintOnSequencedTest classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TConvertTest classTrait + TConvertAsSortedTest classTrait + TConvertAsSetForMultiplinessIdentityTest classTrait + TBeginsEndsWith classTrait + TCopyTest classTrait + TCopySequenceableSameContents classTrait + TCopySequenceableWithReplacementForSorted classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopyPartOfSequenceable classTrait + TCopyPartOfSequenceableForMultipliness classTrait + TSetArithmetic classTrait + TIterateSequencedReadableTest classTrait + TRemoveForMultiplenessTest classTrait + TReplacementSequencedTest classTrait + TCreationWithTest classTrait + TSequencedConcatenationTest classTrait + TIncludesWithIdentityCheckTest classTrait + TSequencedStructuralEqualityTest classTrait + TOccurrencesForMultiplinessTest classTrait 145374 instanceVariableNames: ''! 145375URI subclass: #HierarchicalURI 145376 instanceVariableNames: 'authority query pathComponents' 145377 classVariableNames: '' 145378 poolDictionaries: '' 145379 category: 'Network-URI'! 145380 145381!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 3/6/2002 14:46'! 145382absolutePath 145383 ^self schemeSpecificPart isEmpty 145384 ifTrue: ['/'] 145385 ifFalse: [self schemeSpecificPart]! ! 145386 145387!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/25/2002 18:37'! 145388authority 145389 ^authority! ! 145390 145391!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 3/22/2007 12:46'! 145392baseName 145393 "returns the last component stripped of its extension" 145394 145395 | baseName i | 145396 baseName := self name. 145397 i := baseName findLast: [:c | c = $.]. 145398 ^i = 0 145399 ifTrue: [baseName] 145400 ifFalse: [baseName copyFrom: 1 to: i-1]. 145401! ! 145402 145403!HierarchicalURI methodsFor: 'accessing' stamp: 'marcus.denker 2/20/2009 16:29'! 145404baseNameUnescaped 145405 "returns the last component stripped of its extension" 145406 145407 ^self baseName unescapePercents! ! 145408 145409!HierarchicalURI methodsFor: 'accessing' stamp: 'JMM 8/2/2007 11:54'! 145410baseNameWithExtension 145411 "returns the last component foo.bar" 145412 145413 ^self pathComponents last. 145414! ! 145415 145416!HierarchicalURI methodsFor: 'accessing' stamp: 'marcus.denker 2/20/2009 16:29'! 145417baseNameWithExtensionUnescaped 145418 "returns the last component foo.bar as unescaped " 145419 145420 ^self pathComponents last unescapePercents. 145421! ! 145422 145423!HierarchicalURI methodsFor: 'accessing' stamp: 'JMM 5/8/2006 16:28'! 145424extension 145425 "This method assumes a $. as extension delimiter" 145426 145427 | i leafName | 145428 self pathComponents ifEmpty: [^'']. 145429 leafName := self pathComponents last. 145430 i := leafName findLast: [:c | c = $.]. 145431 ^i = 0 145432 ifTrue: [''] 145433 ifFalse: [leafName copyFrom: i + 1 to: leafName size]. 145434! ! 145435 145436!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:26'! 145437host 145438 ^self authority host! ! 145439 145440!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 4/18/2007 21:52'! 145441name 145442 "returns the last component" 145443 145444 ^self pathComponents last unescapePercents! ! 145445 145446!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/27/2002 14:21'! 145447path 145448" ^self schemeSpecificPart isEmpty 145449 ifTrue: ['/'] 145450 ifFalse: [self schemeSpecificPart]" 145451 ^self schemeSpecificPart! ! 145452 145453!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 3/17/2007 18:28'! 145454pathAndQuery 145455 ^query 145456 ifNil: [self path] 145457 ifNotNil: [self path , self query]! ! 145458 145459!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 4/18/2007 22:12'! 145460pathComponents 145461 ^pathComponents ifNil: [pathComponents := (self path findTokens: $/) collect: [:each | each unescapePercents]]! ! 145462 145463!HierarchicalURI methodsFor: 'accessing' stamp: 'JMM 8/2/2007 11:50'! 145464pathComponentsUnescaped 145465 ^(self path findTokens: $/) collect: [:e | e unescapePercents].! ! 145466 145467!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:26'! 145468port 145469 ^self authority port! ! 145470 145471!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:27'! 145472query 145473 ^query! ! 145474 145475!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 4/18/2007 22:10'! 145476resolveRelativeURI: aURI 145477 | relativeURI newAuthority newPath pathParts newURI relComps | 145478 relativeURI := aURI asURI. 145479 145480 relativeURI isAbsolute 145481 ifTrue: [^relativeURI]. 145482 145483 relativeURI authority 145484 ifNil: [ 145485 newAuthority := self authority. 145486 (relativeURI path beginsWith: '/') 145487 ifTrue: [newPath := relativeURI path] 145488 ifFalse: [ 145489 pathParts := (self path copyUpToLast: $/) findTokens: $/. 145490 relComps := relativeURI pathComponents. 145491 relComps removeAllSuchThat: [:each | each = '.']. 145492 pathParts addAll: relComps. 145493 pathParts removeAllSuchThat: [:each | each = '.']. 145494 self removeComponentDotDotPairs: pathParts. 145495 newPath := self buildAbsolutePath: pathParts. 145496 ((relComps isEmpty 145497 or: [relativeURI path last == $/ ] 145498 or: [(relativeURI path endsWith: '/..') or: [relativeURI path = '..']] 145499 or: [relativeURI path endsWith: '/.' ]) 145500 and: [newPath size > 1]) 145501 ifTrue: [newPath := newPath , '/']]] 145502 ifNotNil: [ 145503 newAuthority := relativeURI authority. 145504 newPath := relativeURI path]. 145505 145506 newURI := String streamContents: [:stream | 145507 stream nextPutAll: self scheme. 145508 stream nextPut: $: . 145509 newAuthority notNil 145510 ifTrue: [ 145511 stream nextPutAll: '//'. 145512 newAuthority printOn: stream]. 145513 newPath notNil 145514 ifTrue: [stream nextPutAll: newPath]. 145515 relativeURI query notNil 145516 ifTrue: [stream nextPutAll: relativeURI query]. 145517 relativeURI fragment notNil 145518 ifTrue: [ 145519 stream nextPut: $# . 145520 stream nextPutAll: relativeURI fragment]]. 145521 ^newURI asURI! ! 145522 145523!HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:27'! 145524userInfo 145525 ^self authority userInfo! ! 145526 145527 145528!HierarchicalURI methodsFor: 'directory operations' stamp: 'mir 3/8/2002 10:51'! 145529assureExistance 145530 ! ! 145531 145532 145533!HierarchicalURI methodsFor: 'printing' stamp: 'mir 2/27/2002 12:51'! 145534printSchemeSpecificPartOn: stream 145535 self isAbsolute 145536 ifTrue: [stream nextPutAll: '//']. 145537 authority 145538 ifNotNil: [self authority printOn: stream]. 145539 super printSchemeSpecificPartOn: stream. 145540 query 145541 ifNotNil: [stream nextPutAll: query]! ! 145542 145543 145544!HierarchicalURI methodsFor: 'private' stamp: 'mir 6/20/2005 18:49'! 145545absoluteFromString: aString scheme: schemeName 145546 | remainder | 145547 super absoluteFromString: aString scheme: schemeName. 145548 145549 "We now have the interesting part in schemeSpecficPart and can parse it further" 145550 145551 "This check is somewhat redundant, just in case somebody calls this directly." 145552 remainder := schemeSpecificPart. 145553 (remainder isEmpty 145554 or: [remainder first ~~ $/]) 145555 ifTrue: [(IllegalURIException new uriString: remainder) signal: 'Invalid absolute URI']. 145556 145557 (aString beginsWith: '//') 145558 ifTrue: [remainder := self extractAuthority: (remainder copyFrom: 3 to: remainder size)]. 145559 145560 self extractSchemeSpecificPartAndFragment: remainder! ! 145561 145562!HierarchicalURI methodsFor: 'private' stamp: 'mir 4/18/2007 22:10'! 145563buildAbsolutePath: pathParts 145564 ^String streamContents: [:stream | 145565 stream nextPut: $/. 145566 pathParts 145567 do: [:pathPart | stream nextPutAll: pathPart] 145568 separatedBy: [stream nextPut: $/]]! ! 145569 145570!HierarchicalURI methodsFor: 'private' stamp: 'mir 2/27/2002 12:46'! 145571extractAuthority: aString 145572 | endAuthorityIndex authorityString | 145573 endAuthorityIndex := (aString indexOf: $/ ) - 1. 145574 endAuthorityIndex < 0 145575 ifTrue: [endAuthorityIndex := aString size]. 145576 authorityString := aString copyFrom: 1 to: endAuthorityIndex. 145577 authority := URIAuthority fromString: authorityString. 145578 ^aString copyFrom: endAuthorityIndex+1 to: aString size! ! 145579 145580!HierarchicalURI methodsFor: 'private' stamp: 'mir 2/26/2002 14:13'! 145581extractQuery: remainder 145582 | queryIndex | 145583 queryIndex := remainder indexOf: $?. 145584 queryIndex > 0 145585 ifFalse: [^remainder]. 145586 query := remainder copyFrom: queryIndex to: remainder size. 145587 ^remainder copyFrom: 1 to: queryIndex-1! ! 145588 145589!HierarchicalURI methodsFor: 'private' stamp: 'mir 2/26/2002 14:13'! 145590extractSchemeSpecificPartAndFragment: remainder 145591 super extractSchemeSpecificPartAndFragment: remainder. 145592 schemeSpecificPart := self extractQuery: schemeSpecificPart! ! 145593 145594!HierarchicalURI methodsFor: 'private' stamp: 'mir 2/27/2002 14:16'! 145595relativeFromString: aString 145596 | remainder authorityEnd | 145597 remainder := (aString beginsWith: '//') 145598 ifTrue: [ 145599 authorityEnd := aString indexOf: $/ startingAt: 3. 145600 authorityEnd == 0 145601 ifTrue: [authorityEnd := aString size+1]. 145602 self extractAuthority: (aString copyFrom: 3 to: authorityEnd-1)] 145603 ifFalse: [aString]. 145604 self extractSchemeSpecificPartAndFragment: remainder! ! 145605 145606!HierarchicalURI methodsFor: 'private' stamp: 'mir 4/18/2007 22:11'! 145607removeComponentDotDotPairs: pathParts 145608 | dotDotIndex | 145609 dotDotIndex := pathParts indexOf: '..'. 145610 [dotDotIndex > 1] 145611 whileTrue: [ 145612 pathParts 145613 removeAt: dotDotIndex; 145614 removeAt: dotDotIndex-1. 145615 dotDotIndex := pathParts indexOf: '..']! ! 145616Url subclass: #HierarchicalUrl 145617 instanceVariableNames: 'schemeName authority path query port username password' 145618 classVariableNames: '' 145619 poolDictionaries: '' 145620 category: 'Network-Url'! 145621!HierarchicalUrl commentStamp: '<historical>' prior: 0! 145622A URL which has a hierarchical encoding. For instance, http and ftp URLs are hierarchical.! 145623 145624 145625!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:58'! 145626authority 145627 ^authority! ! 145628 145629!HierarchicalUrl methodsFor: 'access' stamp: 'gk 10/21/2005 10:21'! 145630directoryUrl 145631 "The path always has at least one element so this works." 145632 145633 ^self copy path: (path copyFrom: 1 to: path size - 1)! ! 145634 145635!HierarchicalUrl methodsFor: 'access' stamp: 'gk 10/21/2005 11:06'! 145636fileName 145637 "Return the last part of the path, 145638 most often a filename but does not need to be." 145639 145640 ^self path last! ! 145641 145642!HierarchicalUrl methodsFor: 'access' stamp: 'tk 9/6/1998 12:45'! 145643isAbsolute 145644 145645 path size > 0 ifFalse: [^ false]. 145646 (path at: 1) size > 0 ifFalse: [^ false]. 145647 ^ ((path at: 1) at: 1) ~~ $.! ! 145648 145649!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/15/2003 13:13'! 145650password 145651 "http://user:pword@foo.com' asUrl password" 145652 ^password! ! 145653 145654!HierarchicalUrl methodsFor: 'access' stamp: 'KLC 4/3/2006 10:05'! 145655path 145656 "return a collection of the decoded path elements, as strings" 145657 ^path! ! 145658 145659!HierarchicalUrl methodsFor: 'access' stamp: 'gk 10/21/2005 11:15'! 145660path: aCollection 145661 "Set the collection of path elements." 145662 145663 path := aCollection! ! 145664 145665!HierarchicalUrl methodsFor: 'access' stamp: 'mir 7/30/1999 13:05'! 145666port 145667 ^port! ! 145668 145669!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:59'! 145670query 145671 "return the query, the part after any ?. Any %XY's have already been decoded. If there wasno query part, nil is returned (it is possible to also have an empty query" 145672 ^query ! ! 145673 145674!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:58'! 145675schemeName 145676 ^schemeName! ! 145677 145678!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/15/2003 13:13'! 145679username 145680 "http://user:pword@foo.com' asUrl username" 145681 ^username! ! 145682 145683 145684!HierarchicalUrl methodsFor: 'classification' stamp: 'FBS 11/20/2003 13:07'! 145685scheme 145686 ^ self schemeName.! ! 145687 145688 145689!HierarchicalUrl methodsFor: 'copying' stamp: 'gk 10/21/2005 11:14'! 145690copy 145691 "Be sure not to share the path with the copy" 145692 145693 ^self clone path: path copy! ! 145694 145695 145696!HierarchicalUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:44'! 145697hasContents 145698 "most of these do...." 145699 ^true! ! 145700 145701 145702!HierarchicalUrl methodsFor: 'parsing' stamp: 'jrp 8/28/2004 14:53'! 145703privateInitializeFromText: aString 145704 | remainder ind specifiedSchemeName | 145705 remainder := aString. 145706 schemeName ifNil: 145707 [specifiedSchemeName := Url schemeNameForString: remainder. 145708 specifiedSchemeName ifNotNil: 145709 [schemeName := specifiedSchemeName. 145710 remainder := remainder copyFrom: schemeName size + 2 to: remainder size]. 145711 schemeName ifNil: 145712 ["assume HTTP" 145713 145714 schemeName := 'http']]. 145715 145716 "remove leading // if it's there" 145717 (remainder beginsWith: '//') 145718 ifTrue: [remainder := remainder copyFrom: 3 to: remainder size]. 145719 145720 145721 "get the query" 145722 ind := remainder indexOf: $?. 145723 ind > 0 145724 ifTrue: 145725 [query := remainder copyFrom: ind + 1 to: remainder size. 145726 remainder := remainder copyFrom: 1 to: ind - 1]. 145727 145728 "get the authority" 145729 ind := remainder indexOf: $/. 145730 ind > 0 145731 ifTrue: 145732 [ind = 1 145733 ifTrue: [authority := ''] 145734 ifFalse: 145735 [authority := remainder copyFrom: 1 to: ind - 1. 145736 remainder := remainder copyFrom: ind + 1 to: remainder size]] 145737 ifFalse: 145738 [authority := remainder. 145739 remainder := '']. 145740 145741 "extract the username+password" 145742 (authority includes: $@) 145743 ifTrue: 145744 [username := authority copyUpTo: $@. 145745 authority := authority copyFrom: (authority indexOf: $@) + 1 145746 to: authority size. 145747 (username includes: $:) 145748 ifTrue: 145749 [password := username copyFrom: (username indexOf: $:) + 1 to: username size. 145750 username := username copyUpTo: $:]]. 145751 145752 "Extract the port" 145753 (authority includes: $:) 145754 ifTrue: 145755 [| lastColonIndex portString | 145756 lastColonIndex := authority findLast: [:c | c = $:]. 145757 portString := authority copyFrom: lastColonIndex + 1 to: authority size. 145758 portString isAllDigits 145759 ifTrue: 145760 [port := Integer readFromString: portString. 145761 (port > 65535) ifTrue: [self error: 'Invalid port number']. 145762 authority := authority copyFrom: 1 to: lastColonIndex - 1] 145763 ifFalse:[self error: 'Invalid port number']]. 145764 145765 "get the path" 145766 path := self privateParsePath: remainder relativeTo: #() .! ! 145767 145768!HierarchicalUrl methodsFor: 'parsing' stamp: 'ls 6/15/2003 13:40'! 145769privateInitializeFromText: aString relativeTo: aUrl 145770 | remainder ind basePath | 145771 remainder := aString. 145772 "set the scheme" 145773 schemeName := aUrl schemeName. 145774 145775 "a leading // means the authority is specified, meaning it is absolute" 145776 (remainder beginsWith: '//') 145777 ifTrue: [^ self privateInitializeFromText: aString]. 145778 145779 "otherwise, use the same authority" 145780 authority := aUrl authority. 145781 port := aUrl port. 145782 username := aUrl username. 145783 password := aUrl password. 145784 145785 "get the query" 145786 ind := remainder indexOf: $?. 145787 ind > 0 145788 ifTrue: [query := remainder copyFrom: ind + 1 to: remainder size. 145789 remainder := remainder copyFrom: 1 to: ind - 1]. 145790 145791 "get the path" 145792 (remainder beginsWith: '/') 145793 ifTrue: [ basePath := #() ] 145794 ifFalse: [ basePath := aUrl path ]. 145795 path := self privateParsePath: remainder relativeTo: basePath. 145796 145797! ! 145798 145799!HierarchicalUrl methodsFor: 'parsing' stamp: 'PeterHugossonMiller 9/3/2009 02:00'! 145800privateParsePath: remainder relativeTo: basePath 145801 | nextTok s parsedPath | 145802 s := remainder readStream. 145803 parsedPath := OrderedCollection new. 145804 parsedPath addAll: basePath. 145805 parsedPath isEmpty ifFalse: [ parsedPath removeLast ]. 145806 145807 [ s peek = $/ ifTrue: [ s next ]. 145808 nextTok := String new writeStream. 145809 [ s atEnd or: [ s peek = $/ ] ] whileFalse: [ nextTok nextPut: s next ]. 145810 nextTok := nextTok contents unescapePercents. 145811 nextTok = '..' 145812 ifTrue: [ parsedPath size > 0 ifTrue: [ parsedPath removeLast ] ] 145813 ifFalse: [ nextTok ~= '.' ifTrue: [ parsedPath add: nextTok ] ]. 145814 s atEnd ] whileFalse. 145815 parsedPath isEmpty ifTrue: [ parsedPath add: '' ]. 145816 ^ parsedPath! ! 145817 145818 145819!HierarchicalUrl methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 02:00'! 145820fullPath 145821 | ans | 145822 ans := String new writeStream. 145823 path do: [ :pathElem | 145824 ans nextPut: $/. 145825 ans nextPutAll: pathElem encodeForHTTP. ]. 145826 self query isNil ifFalse: [ 145827 ans nextPut: $?. 145828 ans nextPutAll: self query. ]. 145829 self fragment isNil ifFalse: [ 145830 ans nextPut: $#. 145831 ans nextPutAll: self fragment encodeForHTTP. ]. 145832 145833 ^ans contents! ! 145834 145835!HierarchicalUrl methodsFor: 'printing' stamp: 'fbs 2/2/2005 13:04'! 145836printOn: aStream 145837 145838 aStream nextPutAll: self schemeName. 145839 aStream nextPutAll: '://'. 145840 self username ifNotNil: [ 145841 aStream nextPutAll: self username. 145842 self password ifNotNil: [ 145843 aStream nextPutAll: ':'. 145844 aStream nextPutAll: self password ]. 145845 aStream nextPutAll: '@' ]. 145846 aStream nextPutAll: self authority. 145847 port ifNotNil: [aStream nextPut: $:; print: port]. 145848 path do: [ :pathElem | 145849 aStream nextPut: $/. 145850 aStream nextPutAll: pathElem encodeForHTTP. ]. 145851 self query isNil ifFalse: [ 145852 aStream nextPut: $?. 145853 aStream nextPutAll: self query. ]. 145854 self fragment isNil ifFalse: [ 145855 aStream nextPut: $#. 145856 aStream nextPutAll: self fragment encodeForHTTP. ].! ! 145857 145858 145859!HierarchicalUrl methodsFor: 'private' stamp: 'ls 6/20/1998 19:41'! 145860schemeName: schemeName0 authority: authority0 path: path0 query: query0 145861 "initialize a new instance" 145862 schemeName := schemeName0. 145863 authority := authority0. 145864 path := path0. 145865 query := query0. 145866! ! 145867 145868"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 145869 145870HierarchicalUrl class 145871 instanceVariableNames: ''! 145872 145873!HierarchicalUrl class methodsFor: 'instance creation' stamp: 'ls 6/20/1998 19:41'! 145874schemeName: schemeName authority: authority path: path query: query 145875 ^self new schemeName: schemeName authority: authority path: path query: query! ! 145876ClassTestCase subclass: #HierarchicalUrlTest 145877 instanceVariableNames: '' 145878 classVariableNames: '' 145879 poolDictionaries: '' 145880 category: 'NetworkTests-Url'! 145881 145882!HierarchicalUrlTest methodsFor: 'testing' stamp: 'fbs 2/2/2005 13:03'! 145883testAsString 145884 | url | 145885 url := HierarchicalUrl new 145886 schemeName: 'ftp' 145887 authority: 'localhost' 145888 path: #('path' 'to' 'file') 145889 query: 'aQuery'. 145890 self assert: url asString = 'ftp://localhost/path/to/file?aQuery'.! ! 145891Browser subclass: #HierarchyBrowser 145892 instanceVariableNames: 'classList centralClass' 145893 classVariableNames: '' 145894 poolDictionaries: '' 145895 category: 'Tools-Browser'! 145896 145897!HierarchyBrowser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:27'! 145898assureSelectionsShow 145899 "This is a workaround for the fact that a hierarchy browser, when launched, often does not show the selected class" 145900 145901 | saveCatIndex saveMsgIndex | 145902 saveCatIndex := messageCategoryListIndex. 145903 saveMsgIndex := messageListIndex. 145904 self classListIndex: classListIndex. 145905 self messageCategoryListIndex: saveCatIndex. 145906 self messageListIndex: saveMsgIndex! ! 145907 145908!HierarchyBrowser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:27'! 145909classList 145910 classList := classList select: [:each | Smalltalk includesKey: each withBlanksTrimmed asSymbol]. 145911 ^ classList! ! 145912 145913 145914!HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 5/8/2000 01:28'! 145915changed: sym 145916 sym == #classList ifTrue: [self updateAfterClassChange]. 145917 super changed: sym! ! 145918 145919!HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 145920classListIndex: newIndex 145921 "Cause system organization to reflect appropriate category" 145922 | newClassName ind | 145923 newIndex ~= 0 ifTrue: 145924 [newClassName := (classList at: newIndex) copyWithout: $ . 145925 systemCategoryListIndex := 145926 systemOrganizer numberOfCategoryOfElement: newClassName]. 145927 ind := super classListIndex: newIndex. 145928 self changed: #systemCategorySingleton. 145929 ^ ind! ! 145930 145931!HierarchyBrowser methodsFor: 'initialization' stamp: 'dew 9/15/2001 16:19'! 145932defaultBrowserTitle 145933 ^ 'Hierarchy Browser'! ! 145934 145935!HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 145936initAlphabeticListing 145937 | tab stab index | 145938 self systemOrganizer: SystemOrganization. 145939 metaClassIndicated := false. 145940 classList := Smalltalk classNames.! ! 145941 145942!HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 145943initHierarchyForClass: aClassOrMetaClass 145944 | tab stab index nonMetaClass | 145945 centralClass := aClassOrMetaClass. 145946 nonMetaClass := aClassOrMetaClass theNonMetaClass. 145947 self systemOrganizer: SystemOrganization. 145948 metaClassIndicated := aClassOrMetaClass isMeta. 145949 classList := OrderedCollection new. 145950 tab := ''. 145951 nonMetaClass allSuperclasses reverseDo: 145952 [:aClass | 145953 classList add: tab , aClass name. 145954 tab := tab , ' ']. 145955 index := classList size + 1. 145956 nonMetaClass allSubclassesWithLevelDo: 145957 [:aClass :level | 145958 stab := ''. 1 to: level do: [:i | stab := stab , ' ']. 145959 classList add: tab , stab , aClass name] 145960 startingLevel: 0. 145961 self classListIndex: index! ! 145962 145963!HierarchyBrowser methodsFor: 'initialization' stamp: 'tk 4/5/98 10:29'! 145964openEditString: aString 145965 "Create a pluggable version of all the views for a HierarchyBrowser, including views and controllers. The top list view is of the currently selected system class category--a single item list." 145966 145967 ^ self openSystemCatEditString: aString! ! 145968 145969!HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 11/8/1999 09:38'! 145970potentialClassNames 145971 "Answer the names of all the classes that could be viewed in this browser" 145972 ^ self classList collect: 145973 [:aName | aName copyWithout: $ ]! ! 145974 145975!HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 145976selectClass: classNotMeta 145977 | name | 145978 name := classNotMeta name. 145979 self classListIndex: (self classList findFirst: 145980 [:each | (each endsWith: name) 145981 and: [each size = name size 145982 or: [(each at: each size - name size) isSeparator]]])! ! 145983 145984!HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 145985selectedClassName 145986 "Answer the name of the class currently selected. di 145987 bug fix for the case where name cannot be found -- return nil rather than halt" 145988 145989 | aName | 145990 aName := super selectedClassName. 145991 ^ aName == nil 145992 ifTrue: 145993 [aName] 145994 ifFalse: 145995 [(aName copyWithout: $ ) asSymbol]! ! 145996 145997!HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 145998systemCategorySingleton 145999 146000 | cls | 146001 cls := self selectedClass. 146002 ^ cls ifNil: [Array new] 146003 ifNotNil: [Array with: cls category]! ! 146004 146005!HierarchyBrowser methodsFor: 'initialization' stamp: 'rhi 12/2/2001 21:32'! 146006updateAfterClassChange 146007 "It is possible that some the classes comprising the hierarchy have changed, so reinitialize the entire browser." 146008 146009 (centralClass notNil and: [centralClass isObsolete not]) 146010 ifTrue: [self initHierarchyForClass: centralClass]! ! 146011 146012 146013!HierarchyBrowser methodsFor: 'menu messages' stamp: 'tk 4/7/98 13:53'! 146014buildClassBrowserEditString: aString 146015 "Create and schedule a new class browser for the current selection, if one 146016 exists, with initial textual contents set to aString." 146017 146018 self spawnHierarchy! ! 146019 146020!HierarchyBrowser methodsFor: 'menu messages' stamp: 'tk 4/3/98 11:22'! 146021removeSystemCategory 146022 "If a class category is selected, create a Confirmer so the user can 146023 verify that the currently selected class category and all of its classes 146024 should be removed from the system. If so, remove it." 146025 146026 self inform: 'Use a normal Browser, in which you can see 146027the entire category you are trying to remove.'! ! 146028 146029!HierarchyBrowser methodsFor: 'menu messages' stamp: 'sw 11/8/1999 13:35'! 146030systemCatSingletonKey: aChar from: aView 146031 ^ self systemCatListKey: aChar from: aView! ! 146032 146033!HierarchyBrowser methodsFor: 'menu messages' stamp: 'marcus.denker 10/20/2008 20:53'! 146034systemCatSingletonMenu: aMenu 146035 146036 ^ aMenu labels: 146037'find class... (f) 146038browse 146039fileOut 146040update 146041rename... 146042remove' 146043 lines: #(1 4) 146044 selections: 146045 #(findClass buildSystemCategoryBrowser 146046 fileOutSystemCategory updateSystemCategories 146047 renameSystemCategory removeSystemCategory ) 146048! ! 146049 146050"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 146051 146052HierarchyBrowser class 146053 instanceVariableNames: ''! 146054 146055!HierarchyBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 146056newFor: aClass 146057 "Open a new HierarchyBrowser on the given class" 146058 | newBrowser | 146059 newBrowser := HierarchyBrowser new initHierarchyForClass: aClass. 146060 Browser openBrowserView: (newBrowser openSystemCatEditString: nil) 146061 label: newBrowser labelString 146062 146063"HierarchyBrowser newFor: Boolean"! ! 146064 146065!HierarchyBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 146066newFor: aClass labeled: aLabel 146067 "Open a new HierarchyBrowser on the given class, using aLabel as the window title." 146068 146069 | newBrowser | 146070 newBrowser := HierarchyBrowser new initHierarchyForClass: aClass. 146071 Browser openBrowserView: (newBrowser openSystemCatEditString: nil) 146072 label: aLabel 146073 146074"HierarchyBrowser newFor: Boolean labeled: 'Testing'"! ! 146075StrikeFont subclass: #HostFont 146076 instanceVariableNames: 'fullWidth kernPairs ranges' 146077 classVariableNames: 'IsoToSqueakMap' 146078 poolDictionaries: 'TextConstants' 146079 category: 'Graphics-Fonts'! 146080 146081!HostFont methodsFor: 'accessing' stamp: 'ar 2/2/2002 18:49'! 146082baseKern 146083 ^0! ! 146084 146085!HostFont methodsFor: 'accessing' stamp: 'yo 2/13/2004 04:06'! 146086createCharacterToGlyphMap 146087 146088 ^ IdentityGlyphMap new. 146089! ! 146090 146091!HostFont methodsFor: 'accessing' stamp: 'ar 2/2/2002 18:49'! 146092descentKern 146093 ^0! ! 146094 146095!HostFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 12:03'! 146096displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 146097 146098 ^ self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent. 146099! ! 146100 146101!HostFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 15:14'! 146102displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY 146103 146104 ^ super displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY. 146105! ! 146106 146107!HostFont methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 146108getFontData 146109 | fontHandle bufSize buffer | 146110 fontHandle := self 146111 primitiveCreateFont: name 146112 size: pointSize 146113 emphasis: emphasis. 146114 fontHandle ifNil: [ ^ nil ]. 146115 bufSize := self primitiveFontDataSize: fontHandle. 146116 buffer := ByteArray new: bufSize. 146117 self 146118 primitiveFont: fontHandle 146119 getData: buffer. 146120 ^ buffer! ! 146121 146122!HostFont methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 146123testEmbeddingFlags 146124 "HostFont basicNew testEmbeddingFlags" 146125 | list fontHandle | 146126 list := self class listFontNames. 146127 list do: 146128 [ :fName | 146129 fontHandle := self 146130 primitiveCreateFont: fName 146131 size: 12 146132 emphasis: 0. 146133 fontHandle ifNotNil: 146134 [ type := self primitiveFontEmbeddingFlags: fontHandle. 146135 Transcript 146136 cr; 146137 show: fName , ': ' , type printString. 146138 self primitiveDestroyFont: fontHandle ] ]! ! 146139 146140!HostFont methodsFor: 'accessing' stamp: 'stephane.ducasse 3/31/2009 21:19'! 146141widthOfString: aString from: firstIndex to: lastIndex 146142 146143 ^ (aString copyFrom: firstIndex to: lastIndex) inject: 0 into: [:s :t | s + (self widthOf: t)].! ! 146144 146145 146146!HostFont methodsFor: 'emphasis' stamp: 'lr 7/4/2009 10:42'! 146147emphasized: code 146148 | derivative addedEmphasis base safeCode | 146149 code = 0 ifTrue: [ ^ self ]. 146150 derivativeFonts == nil ifTrue: [ derivativeFonts := Array new: 32 ]. 146151 derivative := derivativeFonts at: (safeCode := code min: derivativeFonts size). 146152 derivative == nil ifFalse: [ ^ derivative ]. "Already have this style" 146153 146154 "Dont have it -- derive from another with one with less emphasis" 146155 addedEmphasis := 1 bitShift: safeCode highBit - 1. 146156 base := self emphasized: safeCode - addedEmphasis. "Order is Bold, Ital, Under, Narrow" 146157 addedEmphasis = 1 ifTrue: 146158 [ "Compute synthetic bold version of the font" 146159 derivative := (base copy name: base name) makeBoldGlyphs ]. 146160 addedEmphasis = 2 ifTrue: 146161 [ "Compute synthetic italic version of the font" 146162 derivative := (base copy name: base name) makeItalicGlyphs ]. 146163 addedEmphasis = 4 ifTrue: 146164 [ "Compute underlined version of the font" 146165 derivative := (base copy name: base name) makeUnderlinedGlyphs ]. 146166 addedEmphasis = 8 ifTrue: 146167 [ "Compute narrow version of the font" 146168 derivative := (base copy name: base name) makeCondensedGlyphs ]. 146169 addedEmphasis = 16 ifTrue: 146170 [ "Compute struck-out version of the font" 146171 derivative := (base copy name: base name) makeStruckOutGlyphs ]. 146172 derivative emphasis: safeCode. 146173 derivativeFonts 146174 at: safeCode 146175 put: derivative. 146176 ^ derivative! ! 146177 146178!HostFont methodsFor: 'emphasis' stamp: 'yo 2/14/2004 01:38'! 146179makeBoldGlyphs 146180 "First check if we can use some OS support for this" 146181 (self class listFontNames includes: name) ifFalse:[^super makeBoldGlyphs]. 146182 "Now attempt a direct creation through the appropriate primitives" 146183 (self fontName: name size: pointSize emphasis: (emphasis bitOr: 1) rangesArray: ranges) 146184 ifNil:[^super makeBoldGlyphs]. "nil means we failed"! ! 146185 146186!HostFont methodsFor: 'emphasis' stamp: 'yo 2/14/2004 01:39'! 146187makeItalicGlyphs 146188 "First check if we can use some OS support for this" 146189 (self class listFontNames includes: name) ifFalse:[^super makeItalicGlyphs]. 146190 "Now attempt a direct creation through the appropriate primitives" 146191 (self fontName: name size: pointSize emphasis: (emphasis bitOr: 2) rangesArray: ranges) 146192 ifNil:[^super makeItalicGlyphs]. "nil means we failed"! ! 146193 146194!HostFont methodsFor: 'emphasis' stamp: 'yo 2/14/2004 01:39'! 146195makeStruckOutGlyphs 146196 "First check if we can use some OS support for this" 146197 (self class listFontNames includes: name) ifFalse:[^super makeStruckOutGlyphs]. 146198 "Now attempt a direct creation through the appropriate primitives" 146199 (self fontName: name size: pointSize emphasis: (emphasis bitOr: 8) rangesArray: ranges) 146200 ifNil:[^super makeStruckOutGlyphs]. "nil means we failed"! ! 146201 146202!HostFont methodsFor: 'emphasis' stamp: 'yo 2/14/2004 01:40'! 146203makeUnderlinedGlyphs 146204 "First check if we can use some OS support for this" 146205 (self class listFontNames includes: name) ifFalse:[^super makeUnderlinedGlyphs]. 146206 "Now attempt a direct creation through the appropriate primitives" 146207 (self fontName: name size: pointSize emphasis: (emphasis bitOr: 4) rangesArray: ranges) 146208 ifNil:[^super makeUnderlinedGlyphs]. "nil means we failed"! ! 146209 146210 146211!HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:11'! 146212primitiveCreateFont: fontName size: fontSize emphasis: fontFlags 146213 <primitive:'primitiveCreateFont' module:'FontPlugin'> 146214 ^nil! ! 146215 146216!HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:01'! 146217primitiveDestroyFont: fontHandle 146218 <primitive:'primitiveDestroyFont' module:'FontPlugin'> 146219 ^self primitiveFailed! ! 146220 146221!HostFont methodsFor: 'primitives' stamp: 'nk 8/31/2004 09:19'! 146222primitiveFont: fontHandle fullWidthOfChar: aCharIndex 146223 <primitive:'primitiveFontFullWidthOfChar' module:'FontPlugin'> 146224 ^Array 146225 with: 0 146226 with: (self primitiveFont: fontHandle widthOfChar: aCharIndex) 146227 with: 0! ! 146228 146229!HostFont methodsFor: 'primitives' stamp: 'ar 2/18/2001 19:46'! 146230primitiveFont: fontHandle getData: buffer 146231 <primitive:'primitiveGetFontData' module:'FontPlugin'> 146232 ^self primitiveFailed! ! 146233 146234!HostFont methodsFor: 'primitives' stamp: 'ar 8/28/2000 16:05'! 146235primitiveFont: fontHandle getKernPair: kernIndex 146236 <primitive:'primitiveFontGetKernPair' module:'FontPlugin'> 146237 ^0! ! 146238 146239!HostFont methodsFor: 'primitives' stamp: 'nk 8/31/2004 09:19'! 146240primitiveFont: fontHandle glyphOfChar: aCharIndex into: glyphForm 146241 <primitive:'primitiveFontGlyphOfChar' module:'FontPlugin'> 146242 ^self primitiveFailed! ! 146243 146244!HostFont methodsFor: 'primitives' stamp: 'nk 8/31/2004 09:19'! 146245primitiveFont: fontHandle widthOfChar: aCharIndex 146246 <primitive:'primitiveFontWidthOfChar' module:'FontPlugin'> 146247 ^self primitiveFailed! ! 146248 146249!HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:01'! 146250primitiveFontAscent: fontHandle 146251 <primitive:'primitiveFontAscent' module:'FontPlugin'> 146252 ^self primitiveFailed! ! 146253 146254!HostFont methodsFor: 'primitives' stamp: 'ar 2/18/2001 19:45'! 146255primitiveFontDataSize: fontHandle 146256 <primitive:'primitiveFontDataSize' module:'FontPlugin'> 146257 ^self primitiveFailed! ! 146258 146259!HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:01'! 146260primitiveFontDescent: fontHandle 146261 <primitive:'primitiveFontDescent' module:'FontPlugin'> 146262 ^self primitiveFailed! ! 146263 146264!HostFont methodsFor: 'primitives' stamp: 'ar 2/18/2001 20:00'! 146265primitiveFontEmbeddingFlags: fontHandle 146266 <primitive:'primitiveFontEmbeddingFlags' module:'FontPlugin'> 146267 ^self primitiveFailed! ! 146268 146269!HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:02'! 146270primitiveFontEncoding: fontHandle 146271 <primitive:'primitiveFontEncoding' module:'FontPlugin'> 146272 ^self primitiveFailed! ! 146273 146274!HostFont methodsFor: 'primitives' stamp: 'ar 8/28/2000 16:04'! 146275primitiveFontNumKernPairs: fontHandle 146276 <primitive:'primitiveFontNumKernPairs' module:'FontPlugin'> 146277 ^0! ! 146278 146279 146280!HostFont methodsFor: 'private-creation' stamp: 'yo 2/14/2004 01:38'! 146281fontName: fontName size: ptSize emphasis: emphasisCode 146282 146283 ^ self fontName: fontName size: ptSize emphasis: emphasisCode rangesArray: (Array with: (Array with: 0 with: 255)). 146284! ! 146285 146286!HostFont methodsFor: 'private-creation' stamp: 'damiencassou 5/30/2008 14:51'! 146287fontName: fontName size: ptSize emphasis: emphasisCode rangesArray: rangesArray 146288 " 146289 ^HostFont fontName: ('MS UI Gothic') size: 12 emphasis: 0 rangesArray: EFontBDFFontReaderForRanges basicNew rangesForJapanese. 146290 " 146291 | fontHandle xStart w glyphForm fontHeight fw enc rangesStream currentRange | 146292 fontHandle := self 146293 primitiveCreateFont: fontName 146294 size: ptSize 146295 emphasis: emphasisCode. 146296 fontHandle ifNil: [ ^ nil ]. 146297 ranges := rangesArray. 146298 ranges ifNil: [ ranges := Array with: (Array 146299 with: 0 146300 with: 255) ]. 146301 pointSize := ptSize. 146302 name := fontName. 146303 emphasis := emphasisCode. 146304 minAscii := 0. 146305 maxAscii := ranges last last. 146306 ascent := self primitiveFontAscent: fontHandle. 146307 descent := self primitiveFontDescent: fontHandle. 146308 kernPairs := Array new: (self primitiveFontNumKernPairs: fontHandle). 146309 1 146310 to: kernPairs size 146311 do: 146312 [ :i | 146313 kernPairs 146314 at: i 146315 put: (self 146316 primitiveFont: fontHandle 146317 getKernPair: i) ]. 146318 fontHeight := ascent + descent. 146319 xTable := Array new: maxAscii + 3. 146320 fullWidth := Array new: maxAscii + 1. 146321 xStart := maxWidth := 0. 146322 rangesStream := (ranges collect: [ :e | e first to: e second ]) readStream. 146323 currentRange := rangesStream next. 146324 0 146325 to: maxAscii 146326 do: 146327 [ :i | 146328 xTable 146329 at: i + 1 146330 put: xStart. 146331 i > currentRange last ifTrue: 146332 [ 146333 [ rangesStream atEnd not and: 146334 [ currentRange := rangesStream next. 146335 currentRange last < i ] ] whileTrue. 146336 rangesStream atEnd ifTrue: [ ] ]. 146337 (currentRange includes: i) ifTrue: 146338 [ xTable 146339 at: i + 1 146340 put: xStart. 146341 fw := self 146342 primitiveFont: fontHandle 146343 fullWidthOfChar: i. 146344 (#(1 9 10 13 ) includes: i) ifTrue: 146345 [ "anchored morph" 146346 "tab" 146347 "LF" 146348 "CR" 146349 fw := { 0. 0. 0 } ]. 146350 fullWidth 146351 at: i + 1 146352 put: fw. 146353 w := fw at: 2. 146354 (fw at: 1) > 0 ifTrue: [ w := w + (fw at: 1) ]. 146355 (fw at: 3) > 0 ifTrue: [ w := w + (fw at: 3) ]. 146356 w > maxWidth ifTrue: [ maxWidth := w ]. 146357 xStart := xStart + w ] ]. 146358 xStart = 0 ifTrue: [ ^ nil ]. 146359 strikeLength := xStart. 146360 xTable 146361 at: maxAscii + 1 146362 put: xStart. 146363 xTable 146364 at: maxAscii + 2 146365 put: xStart. 146366 xTable 146367 at: maxAscii + 3 146368 put: xStart. 146369 glyphs := Form 146370 extent: xTable last @ fontHeight 146371 depth: 1. 146372 glyphForm := Form 146373 extent: maxWidth @ fontHeight 146374 depth: 1. 146375 0 146376 to: maxAscii 146377 do: 146378 [ :i | 146379 glyphForm fillWhite. 146380 self 146381 primitiveFont: fontHandle 146382 glyphOfChar: i 146383 into: glyphForm. 146384 xStart := xTable at: i + 1. 146385 glyphForm 146386 displayOn: glyphs 146387 at: xStart @ 0 146388 "glyphForm displayOn: Display at: xStart@0." ]. 146389 enc := self primitiveFontEncoding: fontHandle. 146390 enc = 1 ifTrue: [ characterToGlyphMap := self isoToSqueakMap ]. 146391 self primitiveDestroyFont: fontHandle. 146392 ^ self! ! 146393 146394!HostFont methodsFor: 'private-creation' stamp: 'yo 2/13/2004 02:53'! 146395isoToSqueakMap 146396 ^nil 146397! ! 146398 146399"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 146400 146401HostFont class 146402 instanceVariableNames: ''! 146403 146404!HostFont class methodsFor: 'accessing' stamp: 'yo 2/14/2004 01:50'! 146405defaultRanges 146406 146407 ^ Array with: (Array with: 0 with: 16r2AFF). 146408! ! 146409 146410!HostFont class methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 02:01'! 146411fontNameFromUser 146412 "HostFont fontNameFromUser" 146413 | fontNames index labels | 146414 fontNames := self listFontNames asSortedCollection. 146415 labels := (String new: 100) writeStream. 146416 fontNames 146417 do: [ :fn | labels nextPutAll: fn ] 146418 separatedBy: [ labels cr ]. 146419 index := UIManager default 146420 chooseFrom: labels contents substrings 146421 title: 'Choose your font'. 146422 index = 0 ifTrue: [ ^ nil ]. 146423 ^ fontNames at: index! ! 146424 146425!HostFont class methodsFor: 'accessing' stamp: 'ar 6/4/2000 23:18'! 146426listFontName: index 146427 <primitive:'primitiveListFont' module:'FontPlugin'> 146428 ^nil! ! 146429 146430!HostFont class methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 02:01'! 146431listFontNames 146432 "HostFont listFontNames" 146433 "List all the OS font names" 146434 | font fontNames index | 146435 fontNames := Array new writeStream. 146436 index := 0. 146437 146438 [ font := self listFontName: index. 146439 font == nil ] whileFalse: 146440 [ fontNames nextPut: font. 146441 index := index + 1 ]. 146442 ^ fontNames contents! ! 146443 146444!HostFont class methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 146445rangesForJapanese 146446 | basics etc | 146447 basics := { (Array with: 0 with: 255) }. 146448 etc := { 146449 (Array 146450 with: 880 146451 with: 1023). "greek" 146452 (Array 146453 with: 1024 146454 with: 1327). "cyrillic" 146455 (Array 146456 with: 7424 146457 with: 7551). "phonetic" 146458 (Array 146459 with: 7680 146460 with: 7935). "latin extended additional" 146461 (Array 146462 with: 8192 146463 with: 8303). "general punctuation" 146464 (Array 146465 with: 8352 146466 with: 8399). "currency symbols" 146467 (Array 146468 with: 8448 146469 with: 8527). "letterlike" 146470 (Array 146471 with: 8528 146472 with: 8591). "number form" 146473 (Array 146474 with: 8592 146475 with: 8703). "arrows" 146476 (Array 146477 with: 8704 146478 with: 8959). "math operators" 146479 (Array 146480 with: 8960 146481 with: 9215). "misc tech" 146482 (Array 146483 with: 9312 146484 with: 9471). "enclosed alnum" 146485 (Array 146486 with: 9472 146487 with: 9599). "box drawing" 146488 (Array 146489 with: 9600 146490 with: 9631). "box elem" 146491 (Array 146492 with: 9632 146493 with: 9727). "geometric shapes" 146494 (Array 146495 with: 9728 146496 with: 9983). "misc symbols" 146497 (Array 146498 with: 9984 146499 with: 10175). "dingbats" 146500 (Array 146501 with: 10176 146502 with: 10223). "misc math A" 146503 (Array 146504 with: 10224 146505 with: 10239). "supplimental arrow A" 146506 (Array 146507 with: 10496 146508 with: 10623). "supplimental arrow B" 146509 (Array 146510 with: 10624 146511 with: 10751). "misc math B" 146512 (Array 146513 with: 10752 146514 with: 11007). "supplimental math op" 146515 (Array 146516 with: 10496 146517 with: 10623). "supplimental arrow B" 146518 (Array 146519 with: 11904 146520 with: 12031). "cjk radicals suppliment" 146521 (Array 146522 with: 12032 146523 with: 12255). "kangxi radicals" 146524 (Array 146525 with: 12288 146526 with: 12351). "cjk symbols" 146527 (Array 146528 with: 12352 146529 with: 12447). "hiragana" 146530 (Array 146531 with: 12448 146532 with: 12543). "katakana" 146533 (Array 146534 with: 12688 146535 with: 12703). "kanbun" 146536 (Array 146537 with: 12784 146538 with: 12799). "katakana extension" 146539 (Array 146540 with: 12800 146541 with: 13055). "enclosed CJK" 146542 (Array 146543 with: 13056 146544 with: 13311). "CJK compatibility" 146545 (Array 146546 with: 13312 146547 with: 19903). "CJK unified extension A" 146548 (Array 146549 with: 19968 146550 with: 40879). "CJK ideograph" 146551 (Array 146552 with: 63744 146553 with: 64255). "CJK compatiblity ideograph" 146554 (Array 146555 with: 65072 146556 with: 65103). "CJK compatiblity forms" 146557 (Array 146558 with: 65280 146559 with: 65519) "half and full" 146560 }. 146561 ^ basics , etc! ! 146562 146563!HostFont class methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 146564textStyleFrom: fontName 146565 "HostFont textStyleFromUser" 146566 | styleName fonts | 146567 styleName := fontName asSymbol. 146568 "(TextConstants includesKey: styleName) 146569 ifTrue:[(self confirm: 146570styleName , ' is already defined in TextConstants. 146571Do you want to replace that definition?') 146572 ifFalse: [^ self]]." 146573 fonts := #( 146574 10 146575 11 146576 12 146577 13 146578 14 146579 16 146580 18 146581 20 146582 22 146583 24 146584 26 146585 28 146586 30 146587 36 146588 48 146589 60 146590 72 146591 90 146592 ). 146593 'Rendering ' , styleName 146594 displayProgressAt: Sensor cursorPoint 146595 from: 1 146596 to: fonts size 146597 during: 146598 [ :bar | 146599 fonts := fonts 146600 collect: 146601 [ :ptSize | 146602 bar value: (fonts indexOf: ptSize). 146603 self 146604 fontName: styleName 146605 size: ptSize 146606 emphasis: 0 ] 146607 thenSelect: [ :font | font notNil ] ]. "reject those that failed" 146608 fonts size = 0 ifTrue: [ ^ self error: 'Could not create font style' , styleName ]. 146609 TextConstants 146610 at: styleName 146611 put: (TextStyle fontArray: fonts)! ! 146612 146613!HostFont class methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 146614textStyleFrom: fontName sizes: ptSizes 146615 | styleName fonts | 146616 styleName := fontName asSymbol. 146617 (TextConstants includesKey: styleName) ifTrue: 146618 [ (self confirm: styleName , ' is already defined in TextConstants. 146619Do you want to replace that definition?') ifFalse: [ ^ self ] ]. 146620 'Rendering ' , styleName 146621 displayProgressAt: Sensor cursorPoint 146622 from: 1 146623 to: ptSizes size 146624 during: 146625 [ :bar | 146626 fonts := ptSizes 146627 collect: 146628 [ :ptSize | 146629 bar value: (ptSizes indexOf: ptSize). 146630 self 146631 fontName: styleName 146632 size: ptSize 146633 emphasis: 0 ] 146634 thenSelect: [ :font | font notNil ] ]. "reject those that failed" 146635 fonts size = 0 ifTrue: [ ^ self error: 'Could not create font style' , styleName ]. 146636 TextConstants 146637 at: styleName 146638 put: (TextStyle fontArray: fonts)! ! 146639 146640!HostFont class methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 146641textStyleFrom: fontName sizes: ptSizes ranges: ranges 146642 | styleName fonts | 146643 styleName := fontName asSymbol. 146644 (TextConstants includesKey: styleName) ifTrue: 146645 [ (self confirm: styleName , ' is already defined in TextConstants. 146646Do you want to replace that definition?') ifFalse: [ ^ self ] ]. 146647 'Rendering ' , styleName 146648 displayProgressAt: Sensor cursorPoint 146649 from: 1 146650 to: ptSizes size 146651 during: 146652 [ :bar | 146653 fonts := ptSizes 146654 collect: 146655 [ :ptSize | 146656 bar value: (ptSizes indexOf: ptSize). 146657 self 146658 fontName: styleName 146659 size: ptSize 146660 emphasis: 0 146661 rangesArray: ranges ] 146662 thenSelect: [ :font | font notNil ] ]. "reject those that failed" 146663 fonts size = 0 ifTrue: [ ^ self error: 'Could not create font style' , styleName ]. 146664 TextConstants 146665 at: styleName 146666 put: (TextStyle fontArray: fonts)! ! 146667 146668!HostFont class methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 146669textStyleFromUser 146670 "HostFont textStyleFromUser" 146671 | styleName fonts | 146672 styleName := self fontNameFromUser ifNil: [ ^ self ]. 146673 styleName := styleName asSymbol. 146674 (TextConstants includesKey: styleName) ifTrue: 146675 [ (self confirm: styleName , ' is already defined in TextConstants. 146676Do you want to replace that definition?') ifFalse: [ ^ self ] ]. 146677 fonts := #( 146678 10 146679 12 146680 14 146681 16 146682 18 146683 20 146684 22 146685 24 146686 26 146687 28 146688 30 146689 36 146690 48 146691 60 146692 72 146693 90 146694 ). 146695 'Rendering ' , styleName 146696 displayProgressAt: Sensor cursorPoint 146697 from: 1 146698 to: fonts size 146699 during: 146700 [ :bar | 146701 fonts := fonts 146702 collect: 146703 [ :ptSize | 146704 bar value: (fonts indexOf: ptSize). 146705 self 146706 fontName: styleName 146707 size: ptSize 146708 emphasis: 0 ] 146709 thenSelect: [ :font | font notNil ] ]. "reject those that failed" 146710 fonts size = 0 ifTrue: [ ^ self error: 'Could not create font style' , styleName ]. 146711 TextConstants 146712 at: styleName 146713 put: (TextStyle fontArray: fonts)! ! 146714 146715 146716!HostFont class methodsFor: 'instance creation' stamp: 'ar 6/4/2000 23:13'! 146717fontName: fontName size: ptSize emphasis: emphasisCode 146718 " 146719 ^HostFont fontName: (HostFont fontNameFromUser) size: 12 emphasis: 0. 146720 " 146721 ^self new fontName: fontName size: ptSize emphasis: emphasisCode! ! 146722 146723!HostFont class methodsFor: 'instance creation' stamp: 'yo 2/14/2004 01:17'! 146724fontName: fontName size: ptSize emphasis: emphasisCode rangesArray: ranges 146725 " 146726 ^HostFont fontName: (HostFont fontNameFromUser) size: 12 emphasis: 0. 146727 " 146728 ^self new fontName: fontName size: ptSize emphasis: emphasisCode rangesArray: ranges! ! 146729 146730 146731!HostFont class methodsFor: 'system defaults' stamp: 'yo 3/17/2004 00:39'! 146732initForSubtitles 146733" 146734 HostFont initForSubtitles 146735" 146736 146737 HostFont textStyleFrom: 'Verdana' sizes: #(18 20 22 24 26 28) ranges: HostFont defaultRanges. 146738 146739 StrikeFontSet installExternalFontFileName: 'greekFont.out' encoding: GreekEnvironment leadingChar encodingName: #Greek textStyleName: #DefaultMultiStyle. 146740 146741 146742 TTCFontReader encodingTag: SimplifiedChineseEnvironment leadingChar. 146743 TTCFontSet newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\simhei.TTF'. 146744 146745 TTCFontReader encodingTag: JapaneseEnvironment leadingChar. 146746 TTCFontSet newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\msgothic.TTC'. 146747 146748 TTCFontReader encodingTag: KoreanEnvironment leadingChar. 146749 TTCFontSet newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\gulim.TTC'. 146750! ! 146751 146752!HostFont class methodsFor: 'system defaults' stamp: 'yo 2/13/2004 23:25'! 146753initWin32 146754 "HostFont initWin32" 146755 #( 146756 "Basic fonts" 146757 ('Arial' "menu/text serifless" 146758 (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) 146759 ('Times New Roman' "menu/text serifs" 146760 (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) 146761 ('Courier New' "menu/text fixed" 146762 (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) 146763 ('Wingdings' "deco" 146764 (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) 146765 ('Symbol' "deco" 146766 (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) 146767 146768 "Nice fonts" 146769 ('Verdana' "menu/text serifless" 146770 (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) 146771 146772 ('Tahoma' "menu/text serifless" 146773 (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) 146774 146775 ('Garamond' "menu/text serifs" 146776 (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) 146777 ('Georgia' "menu/text serifs" 146778 (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) 146779 146780 ('Comic Sans MS' "eToy" 146781 (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) 146782 146783 "Optional fonts" 146784 ('Impact' "flaps" 146785 (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) 146786 146787 ('Webdings' "deco" 146788 (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) 146789 146790 ('System' "12pt only" 146791 (12)) 146792 ('Fixedsys' "12pt only" 146793 (12)) 146794 ) do:[:spec| HostFont textStyleFrom: spec first sizes: spec last]. 146795 146796 TextConstants removeKey: #Atlanta ifAbsent: []. 146797 TextConstants removeKey: #ComicPlain ifAbsent: []. 146798 TextConstants removeKey: #ComicBold ifAbsent: []. 146799 TextConstants removeKey: #Courier ifAbsent: []. 146800 TextConstants removeKey: #Palatino ifAbsent: []. 146801 146802 TextConstants at: #DefaultFixedTextStyle put: (TextConstants at: #'Courier New'). 146803 TextConstants at: #Helvetica put: (TextConstants at: #'Arial'). 146804 146805! ! 146806 146807!HostFont class methodsFor: 'system defaults' stamp: 'yo 12/2/2004 12:50'! 146808unloadAsianTT 146809" 146810 self unloadAsianTT 146811" 146812 146813 TTCFontSet removeStyleName: 'MultiSimHei'. 146814 TTCFontSet removeStyleName: 'MultiMSGothic'. 146815 TTCFontSet removeStyleName: 'MultiGulim'. 146816! ! 146817Object subclass: #HostSystemMenus 146818 instanceVariableNames: 'hostSystemProxy' 146819 classVariableNames: 'Default DeveloperMode' 146820 poolDictionaries: '' 146821 category: 'HostMenus-Mac'! 146822!HostSystemMenus commentStamp: 'JMM 10/15/2004 13:02' prior: 0! 146823This class uses a proxy and a plugin to support access to the host operating system's menu api. 146824Most of the work is done in the proxy and the proxy calls a host OS specific plugin, or uses FFI or whatever is applicable to make host menus work. 146825 146826Most menubar commands take a host window index value. This maps to the host window index value that is used by the host window plugin. This supports windows that support host menu bars. The macintosh has a single menu bar and all uses of windowIndex are later ignored in the macintosh proxy code. 146827 146828When menu events are passed up from the VM by a VM that actually generates the events, they are processed in EventSensor>>processMenuEvent: which calls HostSystemMenus>>defaultMenuBarForWindowIndex: N. This returns the proxy that handles the interface to the menu bar for the window that has windowIndex N. It then invokes HostSystemMenuProxy>>getHandlerForMenu:item: to get a block that will act on the invocation of menu N, menu Item M. See HostSystemMenusMenuItem class>>fakeKeyboardEventBlockascii:unicode: 146829for the default blocks definition which defaults to insert the command key keyboard stroke into the event queue. This then mimics command key usage which is being watched for by Morphic/Tweak widgets. 146830 146831Structure: 146832 hostSystemProxy HostSystemMenusProxy -- points to the proxy class that interfaces to the plugin 146833 Default HostSystemMenus -- points to the single instance of HostSystemMenus 146834 146835The macintosh plugin attempts to validate incoming menu handles. But care still must be taken not to pass in a bogus handle because this will crash the VM. Finalization is used to ensure 'lost' menu proxies are dealt with. 146836 146837! 146838 146839 146840!HostSystemMenus methodsFor: 'accessing' stamp: 'JMM 10/12/2004 14:26'! 146841hostSystemProxy 146842 hostSystemProxy ifNil: [self class setDefaultMenuProxyClass]. 146843 ^hostSystemProxy! ! 146844 146845!HostSystemMenus methodsFor: 'accessing' stamp: 'JMM 10/1/2004 12:52'! 146846hostSystemProxy: anObject 146847 hostSystemProxy := anObject! ! 146848 146849!HostSystemMenus methodsFor: 'accessing' stamp: 'JMM 10/1/2004 13:07'! 146850setHandlerForMenu: aMenuID item: anItem handler: aHandler 146851 self hostSystemProxy setHandlerForMenu: aMenuID item: anItem handler: aHandler 146852! ! 146853 146854!HostSystemMenus methodsFor: 'accessing' stamp: 'JMM 8/3/2006 17:26'! 146855toggleReaderMode: aBool! ! 146856 146857 146858!HostSystemMenus methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 12:36'! 146859clearMenuBar: aWindowIndex 146860 self hostSystemProxy clearMenuBar: aWindowIndex! ! 146861 146862!HostSystemMenus methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 12:36'! 146863createMenuBar: aWindowIndex 146864 self hostSystemProxy createMenuBar: aWindowIndex! ! 146865 146866!HostSystemMenus methodsFor: 'accessing-menuBar' stamp: 'JMM 10/12/2004 14:31'! 146867defaultMenuBarForWindowIndex: aWindowIndex 146868 ^self hostSystemProxy defaultMenuBarForWindowIndex: aWindowIndex! ! 146869 146870!HostSystemMenus methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 12:37'! 146871disposeMenuBar: aWindowIndex 146872 self hostSystemProxy disposeMenuBar: aWindowIndex! ! 146873 146874!HostSystemMenus methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 12:37'! 146875drawMenuBar: aWindowIndex 146876 self hostSystemProxy drawMenuBar: aWindowIndex! ! 146877 146878!HostSystemMenus methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 12:37'! 146879hideMenuBar: aWindowIndex 146880 self hostSystemProxy hideMenuBar: aWindowIndex! ! 146881 146882!HostSystemMenus methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 12:37'! 146883isMenuBarVisible: aWindowIndex 146884 ^self hostSystemProxy isMenuBarVisible: aWindowIndex! ! 146885 146886!HostSystemMenus methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 12:37'! 146887showMenuBar: aWindowIndex 146888 self hostSystemProxy showMenuBar: aWindowIndex! ! 146889 146890 146891!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:08'! 146892appendMenu: aMenuHandle menuItems: aCollection 146893 self hostSystemProxy appendMenu: aMenuHandle menuItems: aCollection 146894! ! 146895 146896!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:09'! 146897checkMenuItem: aMenuHandle item: anInteger checked: aBoolean 146898 self hostSystemProxy checkMenuItem: aMenuHandle item: anInteger checked: aBoolean! ! 146899 146900!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:09'! 146901countMenuItems: aMenuHandle 146902 ^self hostSystemProxy countMenuItems: aMenuHandle! ! 146903 146904!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:11'! 146905deleteMenu: aMenuHandle 146906 self hostSystemProxy deleteMenu: aMenuHandle 146907! ! 146908 146909!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:12'! 146910deleteMenuItem: aMenuHandle item: aNumber 146911 self hostSystemProxy deleteMenuItem: aMenuHandle item: aNumber! ! 146912 146913!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:12'! 146914disableMenuItem: aMenuHandle item: aNumber 146915 self hostSystemProxy disableMenuItem: aMenuHandle item: aNumber! ! 146916 146917!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:13'! 146918enableMenuItem: aMenuHandle item: aNumber 146919 self hostSystemProxy enableMenuItem: aMenuHandle item: aNumber! ! 146920 146921!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:13'! 146922getItemCmd: aMenuHandle item: aNumber 146923 ^self hostSystemProxy getItemCmd: aMenuHandle item: aNumber! ! 146924 146925!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:13'! 146926getItemIcon: aMenuHandle item: aNumber 146927 ^self hostSystemProxy getItemIcon: aMenuHandle item: aNumber! ! 146928 146929!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:18'! 146930getItemMark: aMenuHandle item: aNumber 146931 ^self hostSystemProxy getItemMark: aMenuHandle item: aNumber 146932! ! 146933 146934!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:14'! 146935getItemStyle: aMenuHandle item: aNumber 146936 ^self hostSystemProxy getItemStyle: aMenuHandle item: aNumber 146937! ! 146938 146939!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:19'! 146940getMenuHandle: aMenuID 146941 ^self hostSystemProxy getMenuHandle: aMenuID! ! 146942 146943!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:19'! 146944getMenuID: aMenuHandle 146945 ^self hostSystemProxy getMenuID: aMenuHandle! ! 146946 146947!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:19'! 146948getMenuItemText: aMenuHandle item: aNumber 146949 ^self hostSystemProxy getMenuItemText: aMenuHandle item: aNumber! ! 146950 146951!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:19'! 146952getMenuTitle: aMenuHandle 146953 ^self hostSystemProxy getMenuTitle: aMenuHandle! ! 146954 146955!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:19'! 146956insertMenu: aMenuHandle beforeID: anId 146957 self hostSystemProxy insertMenu: aMenuHandle beforeID: anId! ! 146958 146959!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:15'! 146960insertMenuItem: menuHandleOop item: anItem afterItem: anInteger 146961 self hostSystemProxy insertMenuItem: menuHandleOop item: anItem afterItem: anInteger 146962 146963! ! 146964 146965!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:20'! 146966isMenuItemEnabled: aMenuHandle item: aNumber 146967 ^self hostSystemProxy isMenuItemEnabled: aMenuHandle item: aNumber! ! 146968 146969!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:37'! 146970newMenu: xmenuID menuTitle: menuTitle 146971 ^self hostSystemProxy newMenu: xmenuID menuTitle: menuTitle 146972 ! ! 146973 146974!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:37'! 146975setItemCmd: menuHandleOop item: anInteger cmdChar: anIntegerCmdChar 146976 self hostSystemProxy setItemCmd: menuHandleOop item: anInteger cmdChar: anIntegerCmdChar 146977 146978! ! 146979 146980!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:37'! 146981setItemMark: menuHandleOop item: anInteger markChar: aMarkChar 146982 self hostSystemProxy setItemMark: menuHandleOop item: anInteger markChar: aMarkChar 146983 146984 146985! ! 146986 146987!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:38'! 146988setItemStyle: menuHandleOop item: anInteger style: aStyle 146989 self hostSystemProxy setItemStyle: menuHandleOop item: anInteger style: aStyle 146990 146991! ! 146992 146993!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:38'! 146994setMenuItemHierarchicalID: menuHandleOop item: anInteger hierID: aMenuID 146995 self hostSystemProxy setMenuItemHierarchicalID: menuHandleOop item: anInteger hierID: aMenuID 146996! ! 146997 146998!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:17'! 146999setMenuItemModifiers: menuHandleOop item: anInteger inModifiers: aUInt8 147000 self hostSystemProxy setMenuItemModifiers: menuHandleOop item: anInteger inModifiers: aUInt8 147001! ! 147002 147003!HostSystemMenus methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:38'! 147004setMenuTitle: menuHandleOop title: aMenuText 147005 self hostSystemProxy setMenuTitle: menuHandleOop title: aMenuText 147006 147007! ! 147008 147009 147010!HostSystemMenus methodsFor: 'finalization' stamp: 'JMM 10/1/2004 13:02'! 147011destroyEveryThing 147012 self hostSystemProxy destroyEveryThing! ! 147013 147014"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 147015 147016HostSystemMenus class 147017 instanceVariableNames: ''! 147018 147019!HostSystemMenus class methodsFor: 'accessing' stamp: 'JMM 10/1/2004 12:51'! 147020default 147021 ^Default ifNil: [Default := self new] ifNotNil: [Default]! ! 147022 147023!HostSystemMenus class methodsFor: 'accessing' stamp: 'pe 9/1/2006 17:55'! 147024developerMode 147025 ^DeveloperMode ifNil: [DeveloperMode := true] ifNotNil: [DeveloperMode].! ! 147026 147027!HostSystemMenus class methodsFor: 'accessing' stamp: 'pe 9/1/2006 17:55'! 147028developerMode: aBool 147029 DeveloperMode := aBool.! ! 147030 147031!HostSystemMenus class methodsFor: 'accessing' stamp: 'JMM 5/15/2006 21:36'! 147032invokeCmd: aCmd 147033 | app | 147034 147035 app := self default hostSystemProxy application. 147036 app ifNil: [^self]. 147037 app perform: aCmd ! ! 147038 147039!HostSystemMenus class methodsFor: 'accessing' stamp: 'JMM 5/15/2006 21:36'! 147040invokeCmd: aCmd with: anEvent 147041 | app | 147042 147043 app := self default hostSystemProxy application. 147044 app ifNil: [^self]. 147045 app perform: aCmd with: anEvent! ! 147046 147047!HostSystemMenus class methodsFor: 'accessing' stamp: 'JMM 5/15/2006 21:30'! 147048menuBarControler 147049 ^self default hostSystemProxy! ! 147050 147051!HostSystemMenus class methodsFor: 'accessing' stamp: 'pe 9/1/2006 17:56'! 147052toggleDeveloperMode 147053 147054 DeveloperMode := DeveloperMode not.! ! 147055 147056 147057!HostSystemMenus class methodsFor: 'instance creation' stamp: 'JMM 10/12/2004 14:36'! 147058activeMenuProxyClass 147059 "Return the concreteHostMenuProxy subclass for the platform on which we are 147060currently running." 147061 147062 HostSystemMenusProxy allSubclasses do: [:class | 147063 class isActiveHostMenuProxyClass ifTrue: [^ class]]. 147064 147065 "no responding subclass; use HostSystemMenusProxy" 147066 ^ HostSystemMenusProxy 147067! ! 147068 147069!HostSystemMenus class methodsFor: 'instance creation' stamp: 'GabrielOmarCotelli 6/4/2009 20:15'! 147070clearDefault 147071 Default := nil! ! 147072 147073!HostSystemMenus class methodsFor: 'instance creation' stamp: 'JMM 10/12/2004 14:27'! 147074defaultMenuBarForWindowIndex: aWindowIndex 147075 ^self default defaultMenuBarForWindowIndex: aWindowIndex 147076! ! 147077 147078!HostSystemMenus class methodsFor: 'instance creation' stamp: 'GabrielOmarCotelli 6/4/2009 20:15'! 147079initialize 147080 "Add me to the system startup list" 147081 "self initialize" 147082 self clearDefault. 147083 Smalltalk 147084 addToStartUpList: self 147085 after: SmalltalkImage! ! 147086 147087!HostSystemMenus class methodsFor: 'instance creation' stamp: 'JMM 10/1/2004 15:15'! 147088new 147089 ^self basicNew initialize! ! 147090 147091!HostSystemMenus class methodsFor: 'instance creation' stamp: 'JMM 10/12/2004 11:45'! 147092setDefaultMenuProxyClass 147093 self default hostSystemProxy: self activeMenuProxyClass new. 147094 ! ! 147095 147096!HostSystemMenus class methodsFor: 'instance creation' stamp: 'GabrielOmarCotelli 6/4/2009 20:16'! 147097startUp: resuming 147098 resuming ifFalse: [^self]. 147099 self clearDefault. 147100 [self setDefaultMenuProxyClass] ifError: [:err :rcvr | ].! ! 147101HostSystemMenusProxy subclass: #HostSystemMenusMacOS9 147102 instanceVariableNames: 'isVMMenuBar menuBar menus' 147103 classVariableNames: '' 147104 poolDictionaries: '' 147105 category: 'HostMenus-Mac'! 147106!HostSystemMenusMacOS9 commentStamp: 'JMM 10/15/2004 13:07' prior: 0! 147107Interface to the OS-9 classic menu bar macintosh plugin. 147108 147109Structure: 147110 isVMMenuBar Boolean -- true if this menu bar was built by the VM 147111 menuBar MenubarHandle -- The magic number identifying the menubar 147112 menus Dictionary -- Holds onto the definitions for each menu item in the menubar 147113 147114Any further useful comments about the general approach of this implementation. 147115isVMMenuBar menuBar menus windowIndex ! 147116 147117 147118!HostSystemMenusMacOS9 methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 12:40'! 147119clearMenuBar: aWindowIndex 147120 self primClearMenuBar! ! 147121 147122!HostSystemMenusMacOS9 methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 12:40'! 147123createMenuBar: aWindowIndex 147124 ! ! 147125 147126!HostSystemMenusMacOS9 methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 14:25'! 147127disposeMenuBar: aWindowIndex 147128 (self isVMMenuBar: aWindowIndex) ifTrue: [^self]. 147129 menuBar ifNotNil: [self primDisposeMenuBar: menuBar]. 147130 menuBar := nil! ! 147131 147132!HostSystemMenusMacOS9 methodsFor: 'accessing-menuBar' stamp: 'JMM 10/1/2004 13:04'! 147133drawMenuBar 147134 self primDrawMenuBar! ! 147135 147136!HostSystemMenusMacOS9 methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 13:08'! 147137drawMenuBar: aWindowIndex 147138 self primDrawMenuBar! ! 147139 147140!HostSystemMenusMacOS9 methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 12:41'! 147141hideMenuBar: aWindowIndex 147142 self primHideMenuBar! ! 147143 147144!HostSystemMenusMacOS9 methodsFor: 'accessing-menuBar' stamp: 'JMM 8/23/2004 14:11'! 147145invalMenuBar 147146 self primInvalMenuBar! ! 147147 147148!HostSystemMenusMacOS9 methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 12:42'! 147149isMenuBarVisible: aWindowIndex 147150 ^self primIsMenuBarVisible! ! 147151 147152!HostSystemMenusMacOS9 methodsFor: 'accessing-menuBar' stamp: 'JMM 10/1/2004 12:59'! 147153isVMMenuBar: anObject 147154 "Set the value of isVMMenuBar" 147155 147156 isVMMenuBar := anObject! ! 147157 147158!HostSystemMenusMacOS9 methodsFor: 'accessing-menuBar' stamp: 'JMM 10/12/2004 12:32'! 147159menuBar 147160 menuBar ifNil: 147161 [menuBar := self primGetMenuBar]. 147162 ^menuBar! ! 147163 147164!HostSystemMenusMacOS9 methodsFor: 'accessing-menuBar' stamp: 'JMM 10/1/2004 12:59'! 147165menus 147166 ^menus! ! 147167 147168!HostSystemMenusMacOS9 methodsFor: 'accessing-menuBar' stamp: 'JMM 10/15/2004 12:42'! 147169showMenuBar: aWindowIndex 147170 self primShowMenuBar! ! 147171 147172 147173!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'John M McIntosh 10/31/2008 19:09'! 147174appendMenu: aMenuHandle menuItems: aCollection 147175 | str255 | 147176 147177 aCollection do: [:e | |subCollection| 147178 subCollection := OrderedCollection with: e. 147179 str255 := self buildDataStringForAppendOrInsert: subCollection. 147180 self resolveAppendOfMenuItems: subCollection forMenuHandle: aMenuHandle. 147181 self primAppendMenu: aMenuHandle data: str255]. 147182 ! ! 147183 147184!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/26/2004 11:08'! 147185appendMenuItemText: menuHandleOop data: menuItemText 147186 | str255 | 147187 147188 str255 := self convertToStr255: menuItemText. 147189 ^self primAppendMenuItemText: menuHandleOop data: str255! ! 147190 147191!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 12:29'! 147192checkMenuItem: aMenuHandle item: anInteger checked: aBoolean 147193 self primCheckMenuItem: aMenuHandle item: anInteger checked: aBoolean 147194 147195! ! 147196 147197!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:09'! 147198countMenuItems: aMenuHandle 147199 ^self primCountMenuItems: aMenuHandle! ! 147200 147201!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/18/2004 14:37'! 147202deleteMenu: aMenuHandle 147203 | menuID | 147204 menuID := self getMenuID: aMenuHandle. 147205 self menus removeKey: menuID ifAbsent: [nil]. 147206 self primDeleteMenu: menuID. 147207 self primDisposeMenu: aMenuHandle. 147208! ! 147209 147210!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:11'! 147211deleteMenuItem: aMenuHandle item: aNumber 147212 self primDeleteMenuItem: aMenuHandle item: aNumber! ! 147213 147214!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:12'! 147215disableMenuItem: aMenuHandle item: aNumber 147216 self primDisableMenuItem: aMenuHandle item: aNumber! ! 147217 147218!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 19:10'! 147219enableMenuItem: aMenuHandle item: aNumber 147220 self primEnableMenuItem: aMenuHandle item: aNumber.! ! 147221 147222!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/18/2004 15:02'! 147223getHandlerForMenu: aMenuID item: anItem 147224 | menu menuItemHandler | 147225 147226 menu := self menus at: aMenuID ifAbsentPut: [Dictionary new]. 147227 menuItemHandler := menu at: anItem ifAbsentPut: [HostSystemMenusMenuItem menuString: '']. 147228 ^menuItemHandler! ! 147229 147230!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:13'! 147231getItemCmd: aMenuHandle item: aNumber 147232 ^(self primGetItemCmd: aMenuHandle item: aNumber) asCharacter! ! 147233 147234!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:13'! 147235getItemIcon: aMenuHandle item: aNumber 147236 ^self primGetItemIcon: aMenuHandle item: aNumber! ! 147237 147238!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:14'! 147239getItemMark: aMenuHandle item: aNumber 147240 ^(self primGetItemMark: aMenuHandle item: aNumber) asCharacter! ! 147241 147242!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/26/2004 11:12'! 147243getItemStyle: aMenuHandle item: aNumber 147244 ^self buildStyle: (self primGetItemStyle: aMenuHandle item: aNumber) 147245 ! ! 147246 147247!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:14'! 147248getMenuHandle: aMenuID 147249 ^self primGetMenuHandle: aMenuID! ! 147250 147251!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:14'! 147252getMenuID: aMenuHandle 147253 ^self primGetMenuID: aMenuHandle! ! 147254 147255!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/23/2004 12:32'! 147256getMenuItemCommandID: aMenuHandle item: aNumber 147257 ^self primGetMenuItemCommandID: aMenuHandle item: aNumber! ! 147258 147259!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/23/2004 12:34'! 147260getMenuItemFontID: aMenuHandle item: aNumber 147261 ^self primGetMenuItemFontID: aMenuHandle item: aNumber! ! 147262 147263!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/26/2004 15:52'! 147264getMenuItemHierarchicalID: menuHandleOop item: anInteger 147265 ^self primGetMenuItemHierarchicalID: menuHandleOop item: anInteger ! ! 147266 147267!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/23/2004 12:39'! 147268getMenuItemKeyGlyph: aMenuHandle item: aNumber 147269 ^self primGetMenuItemKeyGlyph: aMenuHandle item: aNumber! ! 147270 147271!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/25/2004 16:20'! 147272getMenuItemModifiers: aMenuHandle item: aNumber 147273 ^self buildModifers: (self primGetMenuItemModifiers: aMenuHandle item: aNumber)! ! 147274 147275!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:14'! 147276getMenuItemText: aMenuHandle item: aNumber 147277 ^self primGetMenuItemText: aMenuHandle item: aNumber! ! 147278 147279!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/23/2004 12:59'! 147280getMenuItemTextEncoding: aMenuHandle item: aNumber 147281 ^self primGetMenuItemTextEncoding: aMenuHandle item: aNumber! ! 147282 147283!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:14'! 147284getMenuTitle: aMenuHandle 147285 ^self primGetMenuTitle: aMenuHandle! ! 147286 147287!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/26/2004 12:38'! 147288insertFontResMenu: menuHandleOop afterItem: afterItemInteger scriptFilter: scriptFilterInteger 147289 self primInsertFontResMenu: menuHandleOop afterItem: afterItemInteger scriptFilter: scriptFilterInteger 147290 147291! ! 147292 147293!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:14'! 147294insertMenu: aMenuHandle beforeID: anId 147295 self primInsertMenu: aMenuHandle beforeID: anId! ! 147296 147297!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 9/2/2004 22:04'! 147298insertMenuItem: menuHandleOop item: aItem afterItem: anInteger 147299 | str255 | 147300 str255 := self buildDataStringForAppendOrInsert: (OrderedCollection with: aItem). 147301 self resolveInsertOfMenuItem: aItem afterItem: anInteger forMenuHandle: menuHandleOop. 147302 self primInsertMenuItem: menuHandleOop itemString: str255 afterItem: anInteger. 147303 147304! ! 147305 147306!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:15'! 147307isMenuItemEnabled: aMenuHandle item: aNumber 147308 ^self primIsMenuItemEnabled: aMenuHandle item: aNumber! ! 147309 147310!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/26/2004 11:09'! 147311newMenu: menuID menuTitle: menuTitle 147312 | str255 | 147313 147314 str255 := self convertToStr255: menuTitle. 147315 ^self primNewMenu: menuID menuTitle: str255! ! 147316 147317!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:06'! 147318setHandlerForMenu: aMenuID item: anItem handler: aHandler 147319 | menu | 147320 147321 menu := self menus at: aMenuID ifAbsentPut: [Dictionary new]. 147322 menu at: anItem put: aHandler 147323 147324 147325! ! 147326 147327!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:16'! 147328setItemCmd: menuHandleOop item: anInteger cmdChar: anIntegerCmdChar 147329 self primSetItemCmd: menuHandleOop item: anInteger cmdChar: anIntegerCmdChar asCharacter asInteger 147330 147331! ! 147332 147333!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:16'! 147334setItemMark: menuHandleOop item: anInteger markChar: aMarkChar 147335 self primSetItemMark: menuHandleOop item: anInteger markChar: aMarkChar asCharacter asInteger 147336 147337! ! 147338 147339!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:16'! 147340setItemStyle: menuHandleOop item: anInteger style: aStyle 147341 | styleInteger | 147342 147343 styleInteger := self resolveStyleInteger: aStyle. 147344 self primSetItemStyle: menuHandleOop item: anInteger styleParameter: styleInteger 147345 147346! ! 147347 147348!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:16'! 147349setMenuItemCommandID: menuHandleOop item: anInteger menuCommand: inCommandID 147350 self primSetMenuItemCommandID: menuHandleOop item: anInteger menuCommand: inCommandID asInteger 147351 147352! ! 147353 147354!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/26/2004 13:17'! 147355setMenuItemFontID: menuHandleOop item: anInteger fontID: aFontIDInteger 147356 self primSetMenuItemFontID: menuHandleOop item: anInteger fontID: aFontIDInteger 147357! ! 147358 147359!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 19:00'! 147360setMenuItemHierarchicalID: menuHandleOop item: anInteger hierID: aMenuID 147361 self primSetMenuItemHierarchicalID: menuHandleOop item: anInteger hierID: aMenuID! ! 147362 147363!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/26/2004 16:00'! 147364setMenuItemKeyGlyph: menuHandleOop item: anInteger glyph: inGlyphInteger 147365 self primSetMenuItemKeyGlyph: menuHandleOop item: anInteger glyph: inGlyphInteger! ! 147366 147367!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/25/2004 16:55'! 147368setMenuItemModifiers: menuHandleOop item: anInteger inModifiers: modifers 147369 | modifiersInteger | 147370 modifiersInteger := self resolveModifiersInteger: modifers. 147371 self primSetMenuItemModifiers: menuHandleOop item: anInteger inModifiers: modifiersInteger 147372 147373! ! 147374 147375!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/26/2004 11:15'! 147376setMenuItemText: menuHandleOop item: anInteger itemString: aMenuItemText 147377 | str255 | 147378 147379 str255 := self convertToStr255: aMenuItemText. 147380 self primSetMenuItemText: menuHandleOop item: anInteger itemString: str255 147381 147382! ! 147383 147384!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 8/26/2004 12:50'! 147385setMenuItemTextEncoding: menuHandleOop item: anInteger inScriptID: aTextEncodingOop 147386 self primSetMenuItemTextEncoding: menuHandleOop item: anInteger inScriptID: aTextEncodingOop 147387! ! 147388 147389!HostSystemMenusMacOS9 methodsFor: 'accessing-menus' stamp: 'JMM 10/1/2004 13:17'! 147390setMenuTitle: menuHandleOop title: aMenuText 147391 | str255 | 147392 147393 str255 := self convertToStr255: aMenuText. 147394 self primSetMenuTitle: menuHandleOop title: str255 147395 147396! ! 147397 147398 147399!HostSystemMenusMacOS9 methodsFor: 'handlers' stamp: 'JMM 10/18/2004 14:17'! 147400resolveAppendOfMenuItems: aCollection forMenuHandle: aMenuHandle 147401 | previousItems menuID | 147402 147403 previousItems := self countMenuItems: aMenuHandle. 147404 menuID := self getMenuID: aMenuHandle. 147405 1 to: aCollection size do: 147406 [:i | self setHandlerForMenu: menuID item: i + previousItems handler: (aCollection at: i)] 147407 ! ! 147408 147409!HostSystemMenusMacOS9 methodsFor: 'handlers' stamp: 'JMM 10/18/2004 14:17'! 147410resolveInsertOfMenuItem: aMenuItem afterItem: anIndex forMenuHandle: aMenuHandle 147411 | menuID count workList item | 147412 147413 menuID := self getMenuID: aMenuHandle. 147414 count := (self menus at: menuID) size. 147415 workList := OrderedCollection new. 147416 1 to: count do: [:i | 147417 item := self getHandlerForMenu: menuID item: i. 147418 i = (anIndex+1) ifTrue: [workList add: aMenuItem]. 147419 workList add: item]. 147420 count = anIndex ifTrue: [workList add: aMenuItem]. 147421 1 to: count + 1 do: [:i | 147422 self setHandlerForMenu: menuID item: i handler: (workList at: i)] 147423 ! ! 147424 147425 147426!HostSystemMenusMacOS9 methodsFor: 'initialize-release' stamp: 'JMM 10/18/2004 09:21'! 147427appendStandardWindowMenu: inOptions 147428 ^self 147429! ! 147430 147431!HostSystemMenusMacOS9 methodsFor: 'initialize-release' stamp: 'JMM 10/15/2004 12:41'! 147432destroyEveryThing 147433 self disposeMenuBar: 1. 147434 menuBar ifNotNil: 147435 [menuBar := nil]! ! 147436 147437!HostSystemMenusMacOS9 methodsFor: 'initialize-release' stamp: 'JMM 10/18/2004 09:21'! 147438initialize 147439 | menuHandle | 147440 super initialize. 147441 isVMMenuBar := true. 147442 menus := Dictionary new. 147443 self rebuildFromVMInstalledMenu. 147444 self appendStandardWindowMenu: 0. 147445 self reworkFileMenu. 147446 self menuBar. 147447 menuHandle := self getMenuHandle: 3. 147448 self enableMenuItem: menuHandle item: 1. 147449 self enableMenuItem: menuHandle item: 3. 147450 self enableMenuItem: menuHandle item: 4. 147451 self enableMenuItem: menuHandle item: 5. 147452 self drawMenuBar. 147453! ! 147454 147455!HostSystemMenusMacOS9 methodsFor: 'initialize-release' stamp: 'JMM 10/18/2004 14:17'! 147456rebuildFromVMInstalledMenu 147457 | editMenu fileMenuID editMenuID fileMenu | 147458 147459 fileMenuID := 2. 147460 editMenuID := 3. 147461 editMenu := OrderedCollection 147462 with: (HostSystemMenusMenuItem menuString: 'Undo' keyboardKey: $z) 147463 with: (HostSystemMenusMenuItem menuString: '_') 147464 with: (HostSystemMenusMenuItem menuString: 'Cut' keyboardKey: $x) 147465 with: (HostSystemMenusMenuItem menuString: 'Copy' keyboardKey: $c) 147466 with: (HostSystemMenusMenuItem menuString: 'Paste' keyboardKey: $v) 147467 with: (HostSystemMenusMenuItem menuString: 'Clear'). 147468 fileMenu := OrderedCollection 147469 with: (HostSystemMenusMenuItem menuString: 'Quit do not save'). 147470 1 to: fileMenu size do: 147471 [:i | self setHandlerForMenu: fileMenuID item: i handler: (fileMenu at: i)]. 147472 1 to: editMenu size do: 147473 [:i | self setHandlerForMenu: editMenuID item: i handler: (editMenu at: i)]. 147474 147475 147476 ! ! 147477 147478 147479!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/25/2004 11:20'! 147480primAppendMenu: menuHandleOop data: str255 147481 <primitive: 'primitiveAppendMenu' module: 'MacMenubarPlugin'> 147482 self primitiveFailed! ! 147483 147484!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/25/2004 12:12'! 147485primAppendMenuItemText: menuHandleOop data: str255 147486 <primitive: 'primitiveAppendMenuItemText' module: 'MacMenubarPlugin'> 147487 self primitiveFailed! ! 147488 147489!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/25/2004 14:21'! 147490primCheckMenuItem: aMenuHandle item: anInteger checked: aBoolean 147491 <primitive: 'primitiveCheckMenuItem' module: 'MacMenubarPlugin'> 147492 self primitiveFailed 147493 ! ! 147494 147495!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/24/2004 17:59'! 147496primClearMenuBar 147497 <primitive: 'primitiveClearMenuBar' module: 'MacMenubarPlugin'> 147498 self primitiveFailed! ! 147499 147500!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 11:45'! 147501primCountMenuItems: aMenuHandle 147502 <primitive: 'primitiveCountMenuItems' module: 'MacMenubarPlugin'> 147503 self primitiveFailed! ! 147504 147505!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/24/2004 17:24'! 147506primDeleteMenu: aMenuID 147507 <primitive: 'primitiveDeleteMenu' module: 'MacMenubarPlugin'> 147508 self primitiveFailed! ! 147509 147510!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/25/2004 14:30'! 147511primDeleteMenuItem: aMenuHandle item: anInteger 147512 <primitive: 'primitiveDeleteMenuItem' module: 'MacMenubarPlugin'> 147513 self primitiveFailed 147514 ! ! 147515 147516!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 14:31'! 147517primDisableMenuItem: aMenuHandle item: anInteger 147518 <primitive: 'primitiveDisableMenuItem' module: 'MacMenubarPlugin'> 147519 self primitiveFailed 147520 ! ! 147521 147522!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/24/2004 17:26'! 147523primDisposeMenu: aMenuHandle 147524 <primitive: 'primitiveDisposeMenu' module: 'MacMenubarPlugin'> 147525 self primitiveFailed! ! 147526 147527!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 10:24'! 147528primDisposeMenuBar: aMenuBar 147529 <primitive: 'primitiveDisposeMenuBar' module: 'MacMenubarPlugin'> 147530 self primitiveFailed! ! 147531 147532!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 13:15'! 147533primDrawMenuBar 147534 <primitive: 'primitiveDrawMenuBar' module: 'MacMenubarPlugin'> 147535 self primitiveFailed! ! 147536 147537!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 14:29'! 147538primEnableMenuItem: aMenuHandle item: anInteger 147539 <primitive: 'primitiveEnableMenuItem' module: 'MacMenubarPlugin'> 147540 self primitiveFailed 147541 ! ! 147542 147543!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 10/7/2004 12:18'! 147544primGetIndMenuWithCommandID: aMenuHandle commandID: aCommandID 147545 <primitive: 'primitiveGetIndMenuWithCommandID' module: 'MacMenubarPlugin'> 147546 self primitiveFailed 147547 ! ! 147548 147549!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 13:51'! 147550primGetItemCmd: aMenuHandle item: anInteger 147551 <primitive: 'primitiveGetItemCmd' module: 'MacMenubarPlugin'> 147552 self primitiveFailed 147553 ! ! 147554 147555!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 13:58'! 147556primGetItemIcon: aMenuHandle item: anInteger 147557 <primitive: 'primitiveGetItemIcon' module: 'MacMenubarPlugin'> 147558 self primitiveFailed 147559 ! ! 147560 147561!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 14:02'! 147562primGetItemMark: aMenuHandle item: anInteger 147563 <primitive: 'primitiveGetItemMark' module: 'MacMenubarPlugin'> 147564 self primitiveFailed 147565 ! ! 147566 147567!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 14:08'! 147568primGetItemStyle: aMenuHandle item: anInteger 147569 <primitive: 'primitiveGetItemStyle' module: 'MacMenubarPlugin'> 147570 self primitiveFailed 147571 ! ! 147572 147573!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 09:22'! 147574primGetMenuBar 147575 <primitive: 'primitiveGetMenuBar' module: 'MacMenubarPlugin'> 147576 self primitiveFailed! ! 147577 147578!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 10:31'! 147579primGetMenuHandle: aMenuHandle 147580 <primitive: 'primitiveGetMenuHandle' module: 'MacMenubarPlugin'> 147581 self primitiveFailed! ! 147582 147583!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/24/2004 17:42'! 147584primGetMenuID: aMenuHandle 147585 <primitive: 'primitiveGetMenuID' module: 'MacMenubarPlugin'> 147586 self primitiveFailed! ! 147587 147588!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/26/2004 13:17'! 147589primGetMenuItemFontID: menuHandleOop item: anInteger 147590 <primitive: 'primitiveGetMenuItemFontID' module: 'MacMenubarPlugin'> 147591 self primitiveFailed 147592 ! ! 147593 147594!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/26/2004 15:52'! 147595primGetMenuItemHierarchicalID: menuHandleOop item: anInteger 147596 <primitive: 'primitiveGetMenuItemHierarchicalID' module: 'MacMenubarPlugin'> 147597 self primitiveFailed 147598 ! ! 147599 147600!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 12:39'! 147601primGetMenuItemKeyGlyph: aMenuHandle item: anInteger 147602 <primitive: 'primitiveGetMenuItemKeyGlyph' module: 'MacMenubarPlugin'> 147603 self primitiveFailed 147604 ! ! 147605 147606!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 12:50'! 147607primGetMenuItemModifiers: aMenuHandle item: anInteger 147608 <primitive: 'primitiveGetMenuItemModifiers' module: 'MacMenubarPlugin'> 147609 self primitiveFailed 147610 ! ! 147611 147612!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 12:16'! 147613primGetMenuItemText: aMenuHandle item: anInteger 147614 <primitive: 'primitiveGetMenuItemText' module: 'MacMenubarPlugin'> 147615 self primitiveFailed 147616 ! ! 147617 147618!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 13:02'! 147619primGetMenuItemTextEncoding: aMenuHandle item: anInteger 147620 <primitive: 'primitiveGetMenuItemTextEncoding' module: 'MacMenubarPlugin'> 147621 self primitiveFailed 147622 ! ! 147623 147624!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 12:04'! 147625primGetMenuTitle: aMenuHandle 147626 <primitive: 'primitiveGetMenuTitle' module: 'MacMenubarPlugin'> 147627 self primitiveFailed! ! 147628 147629!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 13:12'! 147630primHideMenuBar 147631 <primitive: 'primitiveHideMenuBar' module: 'MacMenubarPlugin'> 147632 self primitiveFailed! ! 147633 147634!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/26/2004 16:16'! 147635primHiliteMenu: menuID 147636 <primitive: 'primitiveHiliteMenu' module: 'MacMenubarPlugin'> 147637 self primitiveFailed! ! 147638 147639!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/26/2004 12:38'! 147640primInsertFontResMenu: menuHandleOop afterItem: afterItemInteger scriptFilter: scriptFilterInteger 147641 <primitive: 'primitiveInsertFontResMenu' module: 'MacMenubarPlugin'> 147642 self primitiveFailed! ! 147643 147644!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 15:25'! 147645primInsertMenu: aMenuHandle beforeID: anId 147646 <primitive: 'primitiveInsertMenu' module: 'MacMenubarPlugin'> 147647 self primitiveFailed! ! 147648 147649!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/25/2004 14:39'! 147650primInsertMenuItem: aMenuHandle itemString: str255 afterItem: anInteger 147651 <primitive: 'primitiveInsertMenuItem' module: 'MacMenubarPlugin'> 147652 self primitiveFailed! ! 147653 147654!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 14:10'! 147655primInvalMenuBar 147656 <primitive: 'primitiveInvalMenuBar' module: 'MacMenubarPlugin'> 147657 self primitiveFailed! ! 147658 147659!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 13:24'! 147660primIsMenuBarVisible 147661 <primitive: 'primitiveIsMenuBarVisible' module: 'MacMenubarPlugin'> 147662 self primitiveFailed! ! 147663 147664!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 14:23'! 147665primIsMenuItemEnabled: aMenuHandle item: anInteger 147666 <primitive: 'primitiveIsMenuItemEnabled' module: 'MacMenubarPlugin'> 147667 self primitiveFailed 147668 ! ! 147669 147670!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 15:08'! 147671primNewMenu: aMenuID menuTitle: menuTitle 147672 <primitive: 'primitiveNewMenu' module: 'MacMenubarPlugin'> 147673 self primitiveFailed 147674 ! ! 147675 147676!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/25/2004 14:53'! 147677primSetItemCmd: menuHandleOop item: anInteger cmdChar: anIntegerCmdChar 147678 <primitive: 'primitiveSetItemCmd' module: 'MacMenubarPlugin'> 147679 self primitiveFailed! ! 147680 147681!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/25/2004 14:59'! 147682primSetItemMark: menuHandleOop item: anInteger markChar: aMarkChar 147683 <primitive: 'primitiveSetItemMark' module: 'MacMenubarPlugin'> 147684 self primitiveFailed! ! 147685 147686!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/25/2004 15:44'! 147687primSetItemStyle: menuHandleOop item: anInteger styleParameter: chStyleInteger 147688 <primitive: 'primitiveSetItemStyle' module: 'MacMenubarPlugin'> 147689 self primitiveFailed! ! 147690 147691!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/26/2004 16:17'! 147692primSetMenuBar: menuHandleOop 147693 <primitive: 'primitiveSetMenuBar' module: 'MacMenubarPlugin'> 147694 self primitiveFailed! ! 147695 147696!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/25/2004 16:05'! 147697primSetMenuItemCommandID: menuHandleOop item: anInteger menuCommand: inCommandID 147698 <primitive: 'primitiveSetMenuItemCommandID' module: 'MacMenubarPlugin'> 147699 self primitiveFailed! ! 147700 147701!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/26/2004 13:16'! 147702primSetMenuItemFontID: menuHandleOop item: anInteger fontID: aFontIDInteger 147703 <primitive: 'primitiveSetMenuItemFontID' module: 'MacMenubarPlugin'> 147704 self primitiveFailed! ! 147705 147706!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/26/2004 14:49'! 147707primSetMenuItemHierarchicalID: menuHandleOop item: anInteger hierID: aMenuID 147708 <primitive: 'primitiveSetMenuItemHierarchicalID' module: 'MacMenubarPlugin'> 147709 self primitiveFailed! ! 147710 147711!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/26/2004 16:00'! 147712primSetMenuItemKeyGlyph: menuHandleOop item: anInteger glyph: inGlyphInteger 147713 <primitive: 'primitiveSetMenuItemKeyGlyph' module: 'MacMenubarPlugin'> 147714 self primitiveFailed! ! 147715 147716!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/25/2004 16:13'! 147717primSetMenuItemModifiers: menuHandleOop item: anInteger inModifiers: aUInt8 147718 <primitive: 'primitiveSetMenuItemModifiers' module: 'MacMenubarPlugin'> 147719 self primitiveFailed! ! 147720 147721!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/26/2004 10:58'! 147722primSetMenuItemText: menuHandleOop item: anInteger itemString: str255 147723 <primitive: 'primitiveSetMenuItemText' module: 'MacMenubarPlugin'> 147724 self primitiveFailed! ! 147725 147726!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/26/2004 12:49'! 147727primSetMenuItemTextEncoding: menuHandleOop item: anInteger inScriptID: aTextEncodingOop 147728 <primitive: 'primitiveSetMenuItemTextEncoding' module: 'MacMenubarPlugin'> 147729 self primitiveFailed! ! 147730 147731!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/26/2004 12:46'! 147732primSetMenuTitle: menuHandleOop title: str255 147733 <primitive: 'primitiveSetMenuTitle' module: 'MacMenubarPlugin'> 147734 self primitiveFailed! ! 147735 147736!HostSystemMenusMacOS9 methodsFor: 'system primitives' stamp: 'JMM 8/23/2004 13:08'! 147737primShowMenuBar 147738 <primitive: 'primitiveShowMenuBar' module: 'MacMenubarPlugin'> 147739 self primitiveFailed! ! 147740 147741 147742!HostSystemMenusMacOS9 methodsFor: 'translation' stamp: 'PeterHugossonMiller 9/3/2009 10:00'! 147743buildDataStringForAppendOrInsert: aCollection 147744 | first str icon mark style cmd | 147745 147746 first := true. 147747 str := (String new: 80) writeStream. 147748 aCollection do: [:m | 147749 first ifFalse: [str nextPutAll: ';']. 147750 first ifTrue: [first := false]. 147751 str nextPutAll: m text. 147752 (icon := m icon) ifNotNil: [str nextPutAll: '^';nextPutAll: icon printString]. 147753 (mark := m mark) ifNotNil: [str nextPutAll: '!!';nextPut: mark asCharacter]. 147754 (style := m style) ifNotNil: [str nextPutAll: (self resolveStyle: style)]. 147755 (cmd := m cmd) ifNotNil: [str nextPutAll: '/';nextPut: cmd]. 147756 m disabled ifTrue: [str nextPutAll: '(']. 147757 ]. 147758 ^self convertToStr255: str contents. 147759 ! ! 147760 147761!HostSystemMenusMacOS9 methodsFor: 'translation' stamp: 'JMM 8/25/2004 16:19'! 147762buildModifers: integer 147763 | modifiers | 147764 integer isZero ifTrue: [^Set with: #command]. 147765 modifiers := Set new. 147766 (integer bitAnd: 1) > 0 ifTrue: [modifiers add: #shift]. 147767 (integer bitAnd: 2) > 0 ifTrue: [modifiers add: #option]. 147768 (integer bitAnd: 4) > 0 ifTrue: [modifiers add: #control]. 147769 (integer bitAnd: 8) > 0 ifTrue: [modifiers add: #nocommand]. 147770 ^modifiers! ! 147771 147772!HostSystemMenusMacOS9 methodsFor: 'translation' stamp: 'JMM 8/25/2004 15:45'! 147773buildStyle: integer 147774 | styles | 147775 styles := Set new. 147776 (integer bitAnd: 1) > 0 ifTrue: [styles add: #bold]. 147777 (integer bitAnd: 2) > 0 ifTrue: [styles add: #italic]. 147778 (integer bitAnd: 4) > 0 ifTrue: [styles add: #underline]. 147779 (integer bitAnd: 8) > 0 ifTrue: [styles add: #outline]. 147780 (integer bitAnd: 16) > 0 ifTrue: [styles add: #shadow]. 147781 ^styles! ! 147782 147783!HostSystemMenusMacOS9 methodsFor: 'translation' stamp: 'JMM 8/26/2004 11:10'! 147784convertToStr255: aString 147785 | str255 size | 147786 147787 str255 := ByteArray new: 256. 147788 size := aString size. 147789 size > 255 ifTrue: [self error: 'String is too long']. 147790 str255 byteAt: 1 put: size. 147791 str255 replaceFrom: 2 to: size + 1 with: aString startingAt: 1. 147792 ^str255 147793! ! 147794 147795!HostSystemMenusMacOS9 methodsFor: 'translation' stamp: 'JMM 8/25/2004 16:35'! 147796resolveModifiersInteger: modifers 147797 147798 | integer | 147799 integer := 0. 147800 #(#shift 1 #option 2 #control 4 #nocommand 8) 147801 pairsDo: [:style :bitOffset | 147802 (modifers includes: style) ifTrue: [integer := integer bitOr: bitOffset]]. 147803 ^integer 147804! ! 147805 147806!HostSystemMenusMacOS9 methodsFor: 'translation' stamp: 'JMM 8/25/2004 11:41'! 147807resolveStyle: aStyle 147808 | string | 147809 147810 string := String new. 147811 aStyle do: [:s | 147812 string := string,'<'. 147813 s = #bold ifTrue: [string := string,'B']. 147814 s = #italic ifTrue: [string := string,'I']. 147815 s = #underline ifTrue: [string := string,'U']. 147816 s = #outline ifTrue: [string := string,'O']. 147817 s = #shadow ifTrue: [string := string,'S']]. 147818 ^string. 147819! ! 147820 147821!HostSystemMenusMacOS9 methodsFor: 'translation' stamp: 'JMM 8/25/2004 16:01'! 147822resolveStyleInteger: aStyle 147823 147824 | integer | 147825 integer := 0. 147826 #(#bold 1 #italic 2 #underline 4 #outline 8 #shadow 16) 147827 pairsDo: [:style :bitOffset | 147828 (aStyle includes: style) ifTrue: [integer := integer bitOr: bitOffset]]. 147829 ^integer 147830! ! 147831 147832 147833!HostSystemMenusMacOS9 methodsFor: 'utility' stamp: 'adrian_lienhard 7/18/2009 15:57'! 147834alterFileMenu 147835 | fileMenu items | 147836 147837 fileMenu := self getMenuHandle: 2. 147838 items := OrderedCollection 147839 with: (HostSystemMenusMenuItem menuString: 'Quit do not save') 147840 with: (HostSystemMenusMenuItem menuString: '-') 147841 with: (HostSystemMenusMenuItem menuString: 'Save' 147842 handler: [:evt | Smalltalk snapshot: true andQuit: false ] ) 147843 with: (HostSystemMenusMenuItem menuString: 'Save As...' 147844 handler: [:evt | SmalltalkImage current saveAs]) 147845 with: (HostSystemMenusMenuItem menuString: '-') 147846 with: (HostSystemMenusMenuItem menuString: 'Quit VM ' 147847 handler: [:evt | SmalltalkImage current snapshot: 147848 (self confirm: 'Save changes before quitting?' 147849 orCancel: [^ self]) 147850 andQuit: true]). 147851 (self countMenuItems: fileMenu) > 1 147852 ifTrue: 147853 [1 to: items size do: 147854 [:i | self setHandlerForMenu: 2 item: i handler: (items at: i)]] 147855 ifFalse: 147856 [self deleteMenuItem: fileMenu item: 1. 147857 self appendMenu: fileMenu menuItems: items]. 147858 147859 147860 147861 ! ! 147862 147863!HostSystemMenusMacOS9 methodsFor: 'utility' stamp: 'JMM 10/18/2004 17:34'! 147864reworkFileMenu 147865 self alterFileMenu! ! 147866 147867"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 147868 147869HostSystemMenusMacOS9 class 147870 instanceVariableNames: ''! 147871 147872!HostSystemMenusMacOS9 class methodsFor: 'instance creation' stamp: 'JMM 1/15/2007 12:00'! 147873isActiveHostMenuProxyClass 147874"Am I active?" 147875 ^SmalltalkImage current platformName = 'Mac OS' and: [SmalltalkImage current osVersion asInteger < 1000]! ! 147876 147877!HostSystemMenusMacOS9 class methodsFor: 'instance creation' stamp: 'JMM 10/1/2004 15:15'! 147878new 147879 ^self basicNew initialize! ! 147880HostSystemMenusMacOS9 subclass: #HostSystemMenusMacOSX 147881 instanceVariableNames: '' 147882 classVariableNames: '' 147883 poolDictionaries: '' 147884 category: 'HostMenus-Mac'! 147885!HostSystemMenusMacOSX commentStamp: 'JMM 10/22/2004 10:14' prior: 0! 147886Implementation for os-x specific menu logic 147887 147888Their is a lot to do, first we must disable the hide command key, enable the Quit Squeak VM in the application menu, add items to the File menu, enable the edit menu, and install and alter the Window menu. This requires access to a few specific os-x menu calls to get menus by commandID. Both the application menu and the Window menu are found by commandID information, menu items on these special menus are also found by commandID since the menus hide menu items by default. ! 147889 147890 147891!HostSystemMenusMacOSX methodsFor: 'system primitives' stamp: 'JMM 10/6/2004 16:51'! 147892primCreateStandardWindowMenu: inOptions 147893 <primitive: 'primitiveCreateStandardWindowMenu' module: 'MacMenubarPlugin'> 147894 self primitiveFailed! ! 147895 147896!HostSystemMenusMacOSX methodsFor: 'system primitives' stamp: 'JMM 10/7/2004 10:37'! 147897primDisableMenuCommand: menuHandleOop command: aCommandID 147898 <primitive: 'primitiveDisableMenuCommand' module: 'MacMenubarPlugin'> 147899 self primitiveFailed! ! 147900 147901!HostSystemMenusMacOSX methodsFor: 'system primitives' stamp: 'JMM 10/7/2004 10:37'! 147902primEnableMenuCommand: menuHandleOop command: aCommandID 147903 <primitive: 'primitiveEnableMenuCommand' module: 'MacMenubarPlugin'> 147904 self primitiveFailed! ! 147905 147906!HostSystemMenusMacOSX methodsFor: 'system primitives' stamp: 'JMM 10/8/2004 12:16'! 147907primGetIndMenuItemWithCommandID: aMenuHandle commandID: aCommandID 147908 <primitive: 'primitiveGetIndMenuItemWithCommandID' module: 'MacMenubarPlugin'> 147909 self primitiveFailed 147910 ! ! 147911 147912!HostSystemMenusMacOSX methodsFor: 'system primitives' stamp: 'JMM 10/8/2004 12:17'! 147913primGetMenuItemCommandID: aMenuHandle item: anInteger 147914 <primitive: 'primitiveGetMenuItemCommandID' module: 'MacMenubarPlugin'> 147915 self primitiveFailed 147916 ! ! 147917 147918 147919!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'marcus.denker 7/31/2009 18:28'! 147920addMenus 147921 147922 | menu items | 147923 147924 menu := self newMenu: 4 menuTitle: 'Tools'. 147925 items := self buildSubMenusFor: World worldMenu openMenu. 147926 items removeLast. 147927 items add: (HostSystemMenusMenuItem subMenu: 200 menuString: 'More...'). 147928 self appendMenu: menu menuItems: items. 147929 self insertMenu: menu beforeID: 4. 147930 147931 items := self buildSubMenusFor: World worldMenu registeredToolsMenu. 147932 menu := self newMenu: 200 menuTitle: 'registeredToolsMenu'. 147933 self insertMenu: menu beforeID: -1. 147934 self appendMenu: menu menuItems: items. 147935 147936 menu := self newMenu: 5 menuTitle: 'Windows'. 147937 items := self buildSubMenusFor: World worldMenu windowsMenu. 147938 self appendMenu: menu menuItems: items. 147939 self insertMenu: menu beforeID: 0. 147940 147941 147942 menu := self newMenu: 6 menuTitle: 'Debug'. 147943 items := self buildSubMenusFor: World worldMenu debugMenu. 147944 self appendMenu: menu menuItems: items. 147945 self insertMenu: menu beforeID: 0. 147946 147947 147948 self isHarvester ifTrue: [ 147949 menu := self newMenu: 8 menuTitle: 'Harvesting'. 147950 items := OrderedCollection new. 147951 items add: (HostSystemMenusMenuItem menuString: '1- Prepare new update' 147952 handler: [:evt | ScriptLoader new prepareNewUpdate ]). 147953 items add: (HostSystemMenusMenuItem menuString: '2- Done applying changes' 147954 handler: [:evt | ScriptLoader new doneApplyingChanges ]). 147955 items add: (HostSystemMenusMenuItem menuString: '3- Verify new update' 147956 handler: [:evt | ScriptLoader new verifyNewUpdate]). 147957 items add: (HostSystemMenusMenuItem menuString: '4- Publish changes' 147958 handler: [:evt | ScriptLoader new publishChanges ]). 147959 self appendMenu: menu menuItems: items. 147960 self insertMenu: menu beforeID: 0. 147961 147962 ]. 147963 147964 ! ! 147965 147966!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'marcus.denker 7/31/2009 18:27'! 147967alterAppMenu 147968 | fileMenu items menu | 147969 fileMenu := self getMenuHandle: 1. 147970 items := self buildSubMenusFor: World worldMenu systemMenu. 147971 items at: 3 put: (HostSystemMenusMenuItem subMenu: 201 menuString: 'Preferences...'). 147972 147973 items add: (HostSystemMenusMenuItem menuString: '-'); 147974 add: (HostSystemMenusMenuItem menuString: 'Save' 147975 handler: [:evt | SmalltalkImage current snapshot: true andQuit: false ]); 147976 add: (HostSystemMenusMenuItem menuString: 'Save As...' 147977 handler: [:evt | SmalltalkImage current saveAs]); 147978 add: (HostSystemMenusMenuItem menuString: 'Save and Quit' 147979 handler: [:evt | SmalltalkImage current snapshot: true andQuit: true]). 147980 self appendMenu: fileMenu menuItems: items. 147981 147982 147983 items := self buildSubMenusFor: World worldMenu appearanceMenu. 147984 items at: 2 put: (HostSystemMenusMenuItem subMenu: 202 menuString: 'System fonts...'). 147985 menu := self newMenu: 201 menuTitle: 'appearanceDo'. 147986 self insertMenu: menu beforeID: -1. 147987 self appendMenu: menu menuItems: items. 147988 147989 items := self buildSubMenusFor: Preferences fontConfigurationMenu. 147990 menu := self newMenu: 202 menuTitle: 'SystemFonts'. 147991 self insertMenu: menu beforeID: -1. 147992 self appendMenu: menu menuItems: items.! ! 147993 147994!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'marcus.denker 7/31/2009 16:01'! 147995alterFileMenu 147996 | fileMenu | 147997 147998 fileMenu := self getMenuHandle: 2. 147999 self deleteMenu: fileMenu.! ! 148000 148001!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'JMM 1/15/2007 13:25'! 148002appendStandardWindowMenu: inOptions 148003 | commandID menuItemIndex windowMenu xID x | 148004 148005 "See http://developer.apple.com/documentation/Carbon/Reference/Carbon:=Event:=Manager:=Ref/CarbonEventsRef/enum:=group:=5.html" 148006 "Install standard window menu, 148007 Disable minimize window menu key, 148008 Disable hide application cmd key 148009 Note that after 10.2.x to alter the standard window menu you must do a getIndMenuItemWithCommandID:item: to have the menu built. Also it appears we must do a getMenuID/getMenuHandle to grab the correct handle, versus the template" 148010 148011 "Build the standard Window menu and disable minimize cmd key" 148012 windowMenu := self createStandardWindowMenu: inOptions. 148013 self insertMenu: windowMenu beforeID: 0. 148014 xID := self getMenuID: windowMenu. 148015 x := self getMenuHandle: xID. 148016 148017 commandID := MacOSType buildOSTypeFromCharString: 'mini'. 148018 menuItemIndex := self getIndMenuItemWithCommandID: x item: commandID. 148019 self setItemCmd: x item: 1 cmdChar: 0. 148020! ! 148021 148022!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'stephane.ducasse 4/13/2009 21:08'! 148023buildSubMenusFor: menu 148024 | items | 148025 148026 items := OrderedCollection new. 148027 menu items do: [:e | 148028 items add: (HostSystemMenusMenuItem menuString: (self modifySqueakMenu: e contents) 148029 handler: [:evt | 148030 e doButtonAction])]. 148031 ^items 148032! ! 148033 148034!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'JMM 10/6/2004 16:48'! 148035createStandardWindowMenu: inOptions 148036 ^self primCreateStandardWindowMenu: inOptions! ! 148037 148038!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'JMM 1/15/2007 13:25'! 148039disableApplicationHide: aMenuRef 148040 "Disable the hide cmd key" 148041 | commandID menuItemIndex | 148042 148043 commandID := MacOSType buildOSTypeFromCharString: 'hide'. 148044 menuItemIndex := self getIndMenuItemWithCommandID: aMenuRef item: commandID. 148045 self setItemCmd: aMenuRef item: menuItemIndex cmdChar: 0. 148046! ! 148047 148048!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'JMM 5/15/2006 20:02'! 148049disableHideMenuCmd 148050 | commandID menuRef menuItemIndex | 148051 148052 "Comand ID for hide" 148053 148054 commandID := MacOSType buildOSTypeFromCharString: 'hide'. 148055 menuRef := self getIndMenuWithCommandID: 0 item: commandID. 148056 menuItemIndex := self getIndMenuItemWithCommandID: 0 item: commandID. 148057 self setItemCmd: menuRef item: menuItemIndex cmdChar: 0. 148058 148059! ! 148060 148061!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'JMM 10/7/2004 10:36'! 148062disableMenuCommand: menuHandleOop command: aCommandID 148063 self primDisableMenuCommand: menuHandleOop command: aCommandID! ! 148064 148065!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'JMM 1/15/2007 13:25'! 148066enableApplicationQuit: aMenuRef 148067 | commandID | 148068 148069 commandID := MacOSType buildOSTypeFromCharString: 'quit'. 148070 self enableMenuCommand: aMenuRef command: commandID. 148071 148072 ! ! 148073 148074!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'JMM 10/7/2004 10:37'! 148075enableMenuCommand: menuHandleOop command: aCommandID 148076 self primEnableMenuCommand: menuHandleOop command: aCommandID! ! 148077 148078!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'JMM 1/15/2007 13:24'! 148079findApplicationMenuViaHideMenuItem 148080 | commandID menuRef | 148081 148082 commandID := MacOSType buildOSTypeFromCharString: 'hide'. 148083 menuRef := self getIndMenuWithCommandID: 0 item: commandID. 148084 ^menuRef 148085! ! 148086 148087!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'JMM 10/8/2004 12:16'! 148088getIndMenuItemWithCommandID: aMenuHandle item: aCommandID 148089 ^self primGetIndMenuItemWithCommandID: aMenuHandle commandID: aCommandID! ! 148090 148091!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'JMM 10/8/2004 12:16'! 148092getIndMenuWithCommandID: aMenuHandle item: aCommandID 148093 ^self primGetIndMenuWithCommandID: aMenuHandle commandID: aCommandID! ! 148094 148095!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'adrian.lienhard 8/11/2009 21:21'! 148096isHarvester 148097 ^{'marcus.denker'.'adrian.lienhard'.'stephane.ducasse'.'michael.rueger'} includes: Author fullNamePerSe.! ! 148098 148099!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'marcus.denker 11/21/2008 12:20'! 148100modifySqueakMenu: aString 148101 | results fixIndex middleCharacter | 148102 results := aString. 148103 results replaceAll: $; with: Character space. 148104 results replaceAll: $^ with: Character space. 148105 results replaceAll: $!! with: Character space. 148106 results replaceAll: $< with: Character space. 148107 results replaceAll: $/ with: Character space. 148108 fixIndex := results indexOf: $(. 148109 [fixIndex > 0] 148110 whileTrue: [ 148111 [(results at: fixIndex + 2) = $) 148112 ifTrue: [middleCharacter := results at: fixIndex + 1. 148113 (middleCharacter = Character space or: [middleCharacter = $(]) 148114 ifTrue: [results at: fixIndex put: Character space] 148115 ifFalse: [results at: fixIndex put: $/.]. 148116 results at: fixIndex + 1 put: middleCharacter asUppercase. 148117 results at: fixIndex + 2 put: Character space] 148118 ifFalse: [results at: fixIndex put: Character space]] 148119 ifError: [results at: fixIndex put: Character space]. 148120 fixIndex := results indexOf: $(]. 148121 ^ results! ! 148122 148123!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'marcus.denker 9/5/2009 19:06'! 148124rebuildApplicationMenuHandlers: aMenuRef 148125 | maximumItems applicationMenuItemsTitles applicationMenuItems m applicationQuit | 148126 148127 maximumItems := self countMenuItems: aMenuRef. 148128 applicationMenuItemsTitles := (1 to: maximumItems) collect: [:i | self getMenuItemText: aMenuRef item: i]. 148129 applicationMenuItems := applicationMenuItemsTitles collect: [:e | HostSystemMenusMenuItem menuString: e]. 148130 applicationQuit := applicationMenuItems detect: [:e | e text = 'Quit Pharo '] ifNone: [applicationQuit := applicationMenuItems detect: [:e | e text = 'Quit Squeak VM '] ifNone: [nil].]. 148131 applicationQuit ifNotNil: [applicationQuit handler: 148132 [:evt | SmalltalkImage current snapshot: 148133 (self confirm: 'Save changes before quitting?' 148134 orCancel: [^ self]) 148135 andQuit: true]]. 148136 m := Dictionary new. 148137 applicationMenuItems doWithIndex:[:e :i | m at: i put: e]. 148138 self menus at: (self getMenuID: aMenuRef) put: m. 148139 148140! ! 148141 148142!HostSystemMenusMacOSX methodsFor: 'utility' stamp: 'marcus.denker 7/31/2009 16:03'! 148143reworkFileMenu 148144 | menuRef | 148145 148146 menuRef := self findApplicationMenuViaHideMenuItem. 148147 self rebuildApplicationMenuHandlers: menuRef. 148148 self disableApplicationHide: menuRef. 148149 self enableApplicationQuit: menuRef. 148150 self alterFileMenu. 148151 self alterAppMenu. 148152 self addMenus. 148153 148154 ! ! 148155 148156"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 148157 148158HostSystemMenusMacOSX class 148159 instanceVariableNames: ''! 148160 148161!HostSystemMenusMacOSX class methodsFor: 'instance creation' stamp: 'John M McIntosh 10/31/2008 16:46'! 148162isActiveHostMenuProxyClass 148163"Am I active?" 148164 ^false. 148165 " ...........^Smalltalk platformName = 'Mac OS' and: [Smalltalk osVersion asInteger >= 1000]"! ! 148166HostSystemMenusMacOSX subclass: #HostSystemMenusMacOSXExample 148167 instanceVariableNames: 'applicationQuitMenuItem editReaderModeMenuItem' 148168 classVariableNames: '' 148169 poolDictionaries: '' 148170 category: 'HostMenus-Mac'! 148171 148172!HostSystemMenusMacOSXExample methodsFor: 'handlers' stamp: 'JMM 12/21/2006 00:11'! 148173appendStandardWindowMenu: inOptions 148174 ! ! 148175 148176!HostSystemMenusMacOSXExample methodsFor: 'handlers' stamp: 'JMM 1/15/2007 12:05'! 148177rebuildApplicationMenuHandlers: aMenuRef using: aMenuBarMgr 148178 | maximumItems applicationMenuItemsTitles applicationMenuItems m | 148179 148180 maximumItems := aMenuBarMgr countMenuItems: aMenuRef. 148181 applicationMenuItemsTitles := (1 to: maximumItems) collect: [:i | aMenuBarMgr getMenuItemText: aMenuRef item: i]. 148182 applicationMenuItems := applicationMenuItemsTitles collect: [:e | HostSystemMenusMenuItem menuString: e]. 148183 applicationQuitMenuItem := applicationMenuItems detect: [:e | e text = 'Quit Example'] ifNone: [nil]. 148184 applicationQuitMenuItem ifNotNil: [applicationQuitMenuItem handler: [self halt]]. 148185 m := Dictionary new. 148186 applicationMenuItems doWithIndex:[:e :i | m at: i put: e]. 148187 aMenuBarMgr menus at: (aMenuBarMgr getMenuID: aMenuRef) put: m. 148188 148189! ! 148190 148191!HostSystemMenusMacOSXExample methodsFor: 'handlers' stamp: 'JMM 12/21/2006 00:39'! 148192reworkApplicationMenu: aMenuBarMgr 148193 | menuRef commandID menuItemIndex | 148194 148195 commandID := MacOSType buildOSTypeFromCharString: 'hide'. 148196 menuRef := aMenuBarMgr getIndMenuWithCommandID: 0 item: commandID. 148197 menuItemIndex := aMenuBarMgr getIndMenuItemWithCommandID: 0 item: commandID. 148198 aMenuBarMgr setItemCmd: menuRef item: menuItemIndex cmdChar: $H. 148199 self rebuildApplicationMenuHandlers: menuRef using: aMenuBarMgr. 148200 commandID := MacOSType buildOSTypeFromCharString: 'quit'. 148201 aMenuBarMgr enableMenuCommand: menuRef command: commandID. 148202 commandID := MacOSType buildOSTypeFromCharString: 'abou'. 148203 aMenuBarMgr enableMenuCommand: menuRef command: commandID. 148204 148205 148206! ! 148207 148208!HostSystemMenusMacOSXExample methodsFor: 'handlers' stamp: 'JMM 12/21/2006 00:34'! 148209reworkEditMenu: aMenuBarMgr 148210 | items editMenuID editMenu n | 148211 148212 editMenuID := 3. 148213 editMenu := aMenuBarMgr getMenuHandle: editMenuID. 148214 items := OrderedCollection new. 148215 items add: (HostSystemMenusMenuItem menuString: 'Undo' keyboardKey: $z virtualKeyValue: 6); 148216 add: (HostSystemMenusMenuItem menuString: '-'); 148217 add: (HostSystemMenusMenuItem menuString: 'Cut' keyboardKey: $x virtualKeyValue: 7); 148218 add: (HostSystemMenusMenuItem menuString: 'Copy' keyboardKey: $c virtualKeyValue: 8); 148219 add: (HostSystemMenusMenuItem menuString: 'Paste' keyboardKey: $v virtualKeyValue: 9); 148220 add: (HostSystemMenusMenuItem menuString: 'Clear'). 148221 n := aMenuBarMgr countMenuItems: editMenu. 148222 n to: 1 by: -1 do: [:i | aMenuBarMgr deleteMenuItem: editMenu item: i]. 148223 aMenuBarMgr appendMenu: editMenu menuItems: items. 148224 editMenu := aMenuBarMgr getMenuHandle: editMenuID. 148225 n := aMenuBarMgr countMenuItems: editMenu. 148226 1 to: n by: 1 do: [:j | aMenuBarMgr enableMenuItem: editMenu item: j]. 148227! ! 148228 148229!HostSystemMenusMacOSXExample methodsFor: 'handlers' stamp: 'JMM 12/21/2006 00:21'! 148230reworkFileMenu: aMenuBarMgr 148231| items fileMenuID fileMenu n | 148232 148233 fileMenuID := 2. 148234 fileMenu := aMenuBarMgr getMenuHandle: fileMenuID. 148235 items := OrderedCollection new. 148236 items add: (HostSystemMenusMenuItem menuString: 'Quit do not save'). 148237 n := aMenuBarMgr countMenuItems: fileMenu. 148238 n to: 1 by: -1 do: [:i | aMenuBarMgr deleteMenuItem: fileMenu item: i]. 148239 aMenuBarMgr appendMenu: fileMenu menuItems: items. ! ! 148240 148241 148242!HostSystemMenusMacOSXExample methodsFor: 'initialize-release' stamp: 'JMM 12/21/2006 00:48'! 148243resetMenuBar! ! 148244 148245!HostSystemMenusMacOSXExample methodsFor: 'initialize-release' stamp: 'JMM 12/21/2006 00:14'! 148246reviseHostMenus 148247 148248 self reworkApplicationMenu: self. 148249 self reworkFileMenu: self. 148250 self reworkEditMenu: self. 148251! ! 148252 148253 148254!HostSystemMenusMacOSXExample methodsFor: 'utility' stamp: 'JMM 9/18/2006 15:42'! 148255setShiftKeyForItems: items startAtOffset: aStartNumber inMenu: aMenu useMgr: aMenuBarMgr 148256 | item | 148257 1 to: items size do: [:i | 148258 item := items at: i. 148259 item shift ifTrue: 148260 [ 148261aMenuBarMgr setMenuItemModifiers: aMenu item: aStartNumber+i-1 inModifiers: #(#shift).]].! ! 148262 148263"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 148264 148265HostSystemMenusMacOSXExample class 148266 instanceVariableNames: ''! 148267 148268!HostSystemMenusMacOSXExample class methodsFor: 'instance creation' stamp: 'John M McIntosh 10/31/2008 16:46'! 148269isActiveHostMenuProxyClass 148270"Am I active?" 148271 ^(SmalltalkImage current platformName = 'Mac OS' and: [SmalltalkImage current osVersion asInteger >= 1000])! ! 148272Object subclass: #HostSystemMenusMenuItem 148273 instanceVariableNames: 'icon mark style cmd disabled text handler shift' 148274 classVariableNames: '' 148275 poolDictionaries: '' 148276 category: 'HostMenus-Mac'! 148277!HostSystemMenusMenuItem commentStamp: 'JMM 10/22/2004 11:04' prior: 0! 148278Holds on to information about a menu item, this allows you to create and populate a menu item which is then handed to the HostSystemMenus classes to actually build the menu item. It does not refect the real-time state of the menu item since changes to the menu items via HostSystemMenus are not recorded. For example to understand the actual enabled/disabled state you must make an api call to host os to get the actual state, the same applies to all other attributes. After creation the only attribute used is the handler which points to the block to execute when a menu item is activated. 148279 148280icon pointer to icon information 148281mark mark character (ascii value) 148282style pointer to style information 148283cmd command magic number 148284disabled true if disabled 148285text text of the menu item 148286handler pointer to the block that gets executed when you invoke the menu item. 148287! 148288 148289 148290!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 10:21'! 148291cmd 148292 "Answer the value of cmd" 148293 148294 ^ cmd! ! 148295 148296!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 10:21'! 148297cmd: anObject 148298 "Set the value of cmd" 148299 148300 cmd := anObject! ! 148301 148302!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 10:21'! 148303disabled 148304 "Answer the value of disabled" 148305 148306 ^ disabled! ! 148307 148308!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 10:21'! 148309disabled: anObject 148310 "Set the value of disabled" 148311 148312 disabled := anObject! ! 148313 148314!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/30/2004 16:53'! 148315handler 148316 ^handler! ! 148317 148318!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/30/2004 16:54'! 148319handler: aHandlerBlock 148320 handler := aHandlerBlock! ! 148321 148322!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 10:21'! 148323icon 148324 "Answer the value of icon" 148325 148326 ^ icon! ! 148327 148328!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 10:21'! 148329icon: anObject 148330 "Set the value of icon" 148331 148332 icon := anObject! ! 148333 148334!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 10:21'! 148335mark 148336 "Answer the value of mark" 148337 148338 ^ mark! ! 148339 148340!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 10:21'! 148341mark: anObject 148342 "Set the value of mark" 148343 148344 mark := anObject! ! 148345 148346!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 9/18/2006 14:49'! 148347shift 148348 ^shift == true! ! 148349 148350!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 9/18/2006 14:49'! 148351shift: aBoolean 148352 shift := aBoolean! ! 148353 148354!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 10:21'! 148355style 148356 "Answer the value of style" 148357 148358 ^ style! ! 148359 148360!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 10:21'! 148361style: anObject 148362 "Set the value of style" 148363 148364 style := anObject! ! 148365 148366!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 13:08'! 148367styleAdd: aStyle 148368 148369 style add: aStyle! ! 148370 148371!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 13:08'! 148372styleRemove: aStyle 148373 148374 style remove: aStyle ifAbsent: []! ! 148375 148376!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 10:23'! 148377text 148378 "Answer the value of text" 148379 148380 ^ text! ! 148381 148382!HostSystemMenusMenuItem methodsFor: 'accessing' stamp: 'JMM 8/25/2004 10:23'! 148383text: anObject 148384 "Set the value of text" 148385 148386 text := anObject! ! 148387 148388 148389!HostSystemMenusMenuItem methodsFor: 'attributes' stamp: 'JMM 8/25/2004 10:30'! 148390disable 148391 disabled := true.! ! 148392 148393!HostSystemMenusMenuItem methodsFor: 'attributes' stamp: 'JMM 8/25/2004 10:30'! 148394enable 148395 disabled := false.! ! 148396 148397 148398!HostSystemMenusMenuItem methodsFor: 'constants' stamp: 'JMM 8/25/2004 10:39'! 148399appleMark 148400 ^nil! ! 148401 148402!HostSystemMenusMenuItem methodsFor: 'constants' stamp: 'JMM 8/25/2004 10:39'! 148403checkMark 148404^nil! ! 148405 148406!HostSystemMenusMenuItem methodsFor: 'constants' stamp: 'JMM 8/25/2004 10:40'! 148407commandMark 148408^nil! ! 148409 148410!HostSystemMenusMenuItem methodsFor: 'constants' stamp: 'JMM 8/25/2004 10:40'! 148411diamondMark 148412^nil! ! 148413 148414!HostSystemMenusMenuItem methodsFor: 'constants' stamp: 'JMM 8/25/2004 10:37'! 148415noMark 148416 ^nil! ! 148417 148418 148419!HostSystemMenusMenuItem methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:57'! 148420initialize 148421 super initialize. 148422 self enable. 148423 self mark: self noMark. 148424 self style: Set new. 148425 ! ! 148426 148427"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 148428 148429HostSystemMenusMenuItem class 148430 instanceVariableNames: ''! 148431 148432!HostSystemMenusMenuItem class methodsFor: 'handlers' stamp: 'JMM 10/4/2004 17:37'! 148433fakeKeyboardEventBlockascii: anAsciiValue unicode: aUnicodeValue 148434 ^[:evt | HostSystemMenusMenuItem fakeKeyboardEventBlockasciiActual: anAsciiValue unicode: aUnicodeValue event: evt]! ! 148435 148436!HostSystemMenusMenuItem class methodsFor: 'handlers' stamp: 'JMM 3/2/2006 16:30'! 148437fakeKeyboardEventBlockascii: anAsciiValue unicode: aUnicodeValue virtualKey: aVirtualKeyValue 148438 ^[:evt | HostSystemMenusMenuItem fakeKeyboardEventBlockasciiActual: anAsciiValue unicode: aUnicodeValue event: evt virtualKey: aVirtualKeyValue]! ! 148439 148440!HostSystemMenusMenuItem class methodsFor: 'handlers' stamp: 'michael.rueger 5/11/2009 19:57'! 148441fakeKeyboardEventBlockasciiActual: anAsciiValue unicode: aUnicodeValue event: evt 148442 |event | 148443 event := Array new: 8. 148444 event at: 1 put: 2 "EventTypeKeyboard"; 148445 at: 2 put: Time millisecondClockValue; 148446 at: 3 put: aUnicodeValue asInteger; 148447 at: 4 put: 1; "key down" 148448 at: 5 put: 8; "modifier keys (CmmandKeyBit)" 148449 at: 8 put: (evt at: 8). 148450 Sensor handleEvent: event. 148451 148452 event := Array new: 8. 148453 event at: 1 put: 2 "EventTypeKeyboard"; 148454 at: 2 put: Time millisecondClockValue; 148455 at: 3 put: anAsciiValue asInteger; 148456 at: 4 put: 0; "key char" 148457 at: 5 put: 8; "modifier keys (CmmandKeyBit)" 148458 at: 8 put: (evt at: 8). 148459 Sensor handleEvent: event. 148460 148461 event := Array new: 8. 148462 event at: 1 put: 2 "EventTypeKeyboard"; 148463 at: 2 put: Time millisecondClockValue; 148464 at: 3 put: aUnicodeValue asInteger; 148465 at: 4 put: 2; "key press/release" 148466 at: 5 put: 64; "modifier keys (CmmandKeyBit)" 148467 at: 8 put: (evt at: 8). 148468 Sensor handleEvent: event! ! 148469 148470!HostSystemMenusMenuItem class methodsFor: 'handlers' stamp: 'michael.rueger 5/11/2009 19:57'! 148471fakeKeyboardEventBlockasciiActual: anAsciiValue unicode: aUnicodeValue event: evt virtualKey: aVirtualKeyValue 148472 |event | 148473 148474 event := Array new: 8. 148475 event at: 1 put: 2 "EventTypeKeyboard"; 148476 at: 2 put: Time millisecondClockValue; 148477 at: 3 put: aVirtualKeyValue asInteger; 148478 at: 4 put: 1; "key down" 148479 at: 5 put: 8; "modifier keys (CmmandKeyBit)" 148480 at: 8 put: (evt at: 8). 148481 Sensor handleEvent: event. 148482 148483 event := Array new: 8. 148484 event at: 1 put: 2 "EventTypeKeyboard"; 148485 at: 2 put: Time millisecondClockValue; 148486 at: 3 put: anAsciiValue asInteger; 148487 at: 4 put: 0; "key char" 148488 at: 5 put: 8; "modifier keys (CmmandKeyBit)" 148489 at: 6 put: aUnicodeValue asInteger; "virtual key code" 148490 at: 8 put: (evt at: 8). 148491 Sensor handleEvent: event. 148492 148493 event := Array new: 8. 148494 event at: 1 put: 2 "EventTypeKeyboard"; 148495 at: 2 put: Time millisecondClockValue; 148496 at: 3 put: aVirtualKeyValue asInteger; 148497 at: 4 put: 2; "key press/release" 148498 at: 5 put: 64; "modifier keys (CmmandKeyBit)" 148499 at: 8 put: (evt at: 8). 148500 Sensor handleEvent: event! ! 148501 148502!HostSystemMenusMenuItem class methodsFor: 'handlers' stamp: 'JMM 8/30/2004 16:52'! 148503nullBlock 148504 ^[:evt | ]! ! 148505 148506 148507!HostSystemMenusMenuItem class methodsFor: 'instance creation' stamp: 'JMM 10/18/2004 08:58'! 148508activeMenuItemClass 148509 "Return the HostSystemMenusMenuItem subclass for the platform on which we are 148510currently running." 148511 148512 HostSystemMenusMenuItem allSubclasses do: [:class | 148513 class isActiveHostMenuItemClass ifTrue: [^ class]]. 148514 148515 "no responding subclass; use HostSystemMenusMenuItem" 148516 ^ HostSystemMenusMenuItem 148517 148518! ! 148519 148520!HostSystemMenusMenuItem class methodsFor: 'instance creation' stamp: 'JMM 10/18/2004 08:58'! 148521defaultMenuItem 148522 ^ self activeMenuItemClass basicNew initialize. 148523! ! 148524 148525!HostSystemMenusMenuItem class methodsFor: 'instance creation' stamp: 'JMM 9/22/2004 15:21'! 148526menuString: aString 148527 ^self text: aString handler: self nullBlock! ! 148528 148529!HostSystemMenusMenuItem class methodsFor: 'instance creation' stamp: 'JMM 10/18/2004 14:52'! 148530menuString: aString handler: aHandler 148531 ^self text: aString handler: aHandler! ! 148532 148533!HostSystemMenusMenuItem class methodsFor: 'instance creation' stamp: 'JMM 5/14/2006 02:19'! 148534menuString: aString keyboardKey: aKey 148535 ^self text: aString cmd: aKey asUppercase handler: 148536 (self fakeKeyboardEventBlockascii: aKey unicode: aKey )! ! 148537 148538!HostSystemMenusMenuItem class methodsFor: 'instance creation' stamp: 'JMM 5/14/2006 02:20'! 148539menuString: aString keyboardKey: aKey handler: aHandler 148540 ^self text: aString cmd: aKey asUppercase handler: aHandler! ! 148541 148542!HostSystemMenusMenuItem class methodsFor: 'instance creation' stamp: 'JMM 9/18/2006 14:51'! 148543menuString: aString keyboardKey: aKey shift: state handler: aHandler 148544 ^self text: aString cmd: aKey asUppercase shift: state handler: aHandler! ! 148545 148546!HostSystemMenusMenuItem class methodsFor: 'instance creation' stamp: 'JMM 5/14/2006 02:19'! 148547menuString: aString keyboardKey: aKey virtualKeyValue: aVirtualKeyValue 148548 ^self text: aString cmd: aKey asUppercase handler: 148549 (self fakeKeyboardEventBlockascii: aKey unicode: aKey virtualKey: aVirtualKeyValue)! ! 148550 148551!HostSystemMenusMenuItem class methodsFor: 'instance creation' stamp: 'John M McIntosh 10/31/2008 19:28'! 148552subMenu: aMenuId menuString: aString 148553 | item | 148554 148555 item := self text: aString handler: self nullBlock. 148556 item mark: aMenuId. 148557 item cmd: 16r1B asCharacter. 148558 ^item.! ! 148559 148560!HostSystemMenusMenuItem class methodsFor: 'instance creation' stamp: 'JMM 8/30/2004 16:56'! 148561text: aTextItem cmd: aCmd handler: aHandlerBlock 148562 | resolvedClassInstance | 148563 148564 resolvedClassInstance := self defaultMenuItem. 148565 resolvedClassInstance text: aTextItem. 148566 resolvedClassInstance cmd: aCmd. 148567 resolvedClassInstance handler: aHandlerBlock. 148568 ^resolvedClassInstance! ! 148569 148570!HostSystemMenusMenuItem class methodsFor: 'instance creation' stamp: 'JMM 9/18/2006 14:51'! 148571text: aTextItem cmd: aCmd shift: state handler: aHandlerBlock 148572 | resolvedClassInstance | 148573 148574 resolvedClassInstance := self defaultMenuItem. 148575 resolvedClassInstance text: aTextItem. 148576 resolvedClassInstance cmd: aCmd. 148577 resolvedClassInstance shift: state. 148578 resolvedClassInstance handler: aHandlerBlock. 148579 ^resolvedClassInstance! ! 148580 148581!HostSystemMenusMenuItem class methodsFor: 'instance creation' stamp: 'JMM 8/30/2004 16:56'! 148582text: aTextItem handler: aHandlerBlock 148583 | resolvedClassInstance | 148584 148585 resolvedClassInstance := self defaultMenuItem. 148586 resolvedClassInstance text: aTextItem. 148587 resolvedClassInstance handler: aHandlerBlock. 148588 ^resolvedClassInstance! ! 148589HostSystemMenusMenuItem subclass: #HostSystemMenusMenuItemMac 148590 instanceVariableNames: '' 148591 classVariableNames: '' 148592 poolDictionaries: '' 148593 category: 'HostMenus-Mac'! 148594!HostSystemMenusMenuItemMac commentStamp: 'JMM 10/22/2004 10:20' prior: 0! 148595mac specific information, contains the magic constants for the mark characters. ! 148596 148597 148598!HostSystemMenusMenuItemMac methodsFor: 'constants' stamp: 'JMM 8/25/2004 10:38'! 148599appleMark 148600 ^20! ! 148601 148602!HostSystemMenusMenuItemMac methodsFor: 'constants' stamp: 'JMM 8/25/2004 10:38'! 148603checkMark 148604 ^18! ! 148605 148606!HostSystemMenusMenuItemMac methodsFor: 'constants' stamp: 'JMM 8/25/2004 10:38'! 148607commandMark 148608 ^17! ! 148609 148610!HostSystemMenusMenuItemMac methodsFor: 'constants' stamp: 'JMM 8/25/2004 10:38'! 148611diamondMark 148612 ^19! ! 148613 148614!HostSystemMenusMenuItemMac methodsFor: 'constants' stamp: 'JMM 8/25/2004 10:41'! 148615hierMenu 148616 ^-1! ! 148617 148618!HostSystemMenusMenuItemMac methodsFor: 'constants' stamp: 'JMM 8/25/2004 10:36'! 148619noMark 148620 ^0! ! 148621 148622"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 148623 148624HostSystemMenusMenuItemMac class 148625 instanceVariableNames: ''! 148626 148627!HostSystemMenusMenuItemMac class methodsFor: 'instance creation' stamp: 'JMM 1/15/2007 13:02'! 148628isActiveHostMenuItemClass 148629 ^SmalltalkImage current platformName = 'Mac OS'! ! 148630Object subclass: #HostSystemMenusProxy 148631 instanceVariableNames: 'application' 148632 classVariableNames: 'Registry' 148633 poolDictionaries: '' 148634 category: 'HostMenus-Mac'! 148635!HostSystemMenusProxy commentStamp: 'JMM 10/22/2004 10:24' prior: 0! 148636Proxy for the host api menu structure. 148637All calls are managed by subclasses which support the menu API. 148638What is implemented is the finalization logic to ensure GCed menus are disposed of if the user forgets to dispose of the menu before he 148639forgets about the instance of this class. 148640 148641! 148642 148643 148644!HostSystemMenusProxy methodsFor: 'accessing' stamp: 'JMM 5/15/2006 21:42'! 148645application 148646 ^application! ! 148647 148648!HostSystemMenusProxy methodsFor: 'accessing' stamp: 'JMM 5/15/2006 21:42'! 148649application: aValue 148650 application := aValue! ! 148651 148652!HostSystemMenusProxy methodsFor: 'accessing' stamp: 'JMM 10/12/2004 12:45'! 148653getHandlerForMenu: aMenuID item: anItem 148654 ^[:nothing | ]! ! 148655 148656!HostSystemMenusProxy methodsFor: 'accessing' stamp: 'JMM 10/12/2004 12:14'! 148657setHandlerForMenu: aMenuID item: anItem handler: aHandler 148658! ! 148659 148660 148661!HostSystemMenusProxy methodsFor: 'accessing-menuBar' stamp: 'JMM 10/12/2004 12:09'! 148662clearMenuBar! ! 148663 148664!HostSystemMenusProxy methodsFor: 'accessing-menuBar' stamp: 'JMM 10/12/2004 12:09'! 148665createMenuBar! ! 148666 148667!HostSystemMenusProxy methodsFor: 'accessing-menuBar' stamp: 'JMM 10/12/2004 14:32'! 148668defaultMenuBarForWindowIndex: aWindowIndex 148669 ^self! ! 148670 148671!HostSystemMenusProxy methodsFor: 'accessing-menuBar' stamp: 'JMM 10/12/2004 12:11'! 148672drawMenuBar! ! 148673 148674!HostSystemMenusProxy methodsFor: 'accessing-menuBar' stamp: 'JMM 10/12/2004 12:11'! 148675hideMenuBar! ! 148676 148677!HostSystemMenusProxy methodsFor: 'accessing-menuBar' stamp: 'JMM 10/12/2004 12:12'! 148678isMenuBarVisible 148679 ^true! ! 148680 148681!HostSystemMenusProxy methodsFor: 'accessing-menuBar' stamp: 'JMM 10/12/2004 12:12'! 148682showMenuBar! ! 148683 148684 148685!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:16'! 148686appendMenu: aMenuHandle menuItems: aCollection! ! 148687 148688!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:16'! 148689checkMenuItem: aMenuHandle item: anInteger checked: aBoolean! ! 148690 148691!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:16'! 148692countMenuItems: aMenuHandle! ! 148693 148694!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:16'! 148695deleteMenu: aMenuHandle! ! 148696 148697!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:16'! 148698deleteMenuItem: aMenuHandle item: aNumber! ! 148699 148700!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:16'! 148701disableMenuItem: aMenuHandle item: aNumb! ! 148702 148703!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:16'! 148704enableMenuItem: aMenuHandle item: aNumber! ! 148705 148706!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:16'! 148707getItemCmd: aMenuHandle item: aNumber! ! 148708 148709!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:17'! 148710getItemIcon: aMenuHandle item: aNumber! ! 148711 148712!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:17'! 148713getItemMark: aMenuHandle item: aNumber! ! 148714 148715!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:17'! 148716getItemStyle: aMenuHandle item: aNumber! ! 148717 148718!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:17'! 148719getMenuHandle: aMenuID! ! 148720 148721!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:17'! 148722getMenuID: aMenuHandle! ! 148723 148724!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:17'! 148725getMenuItemText: aMenuHandle item: aNumber! ! 148726 148727!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:17'! 148728getMenuTitle: aMenuHandle! ! 148729 148730!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:17'! 148731insertMenu: aMenuHandle beforeID: anId! ! 148732 148733!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:18'! 148734insertMenuItem: menuHandleOop item: anItem afterItem: anInteger 148735! ! 148736 148737!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:18'! 148738isMenuItemEnabled: aMenuHandle item: aNumber 148739! ! 148740 148741!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:18'! 148742newMenu: xmenuID menuTitle: menuTitle! ! 148743 148744!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:18'! 148745setItemCmd: menuHandleOop item: anInteger cmdChar: anIntegerCmdChar! ! 148746 148747!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:18'! 148748setItemMark: menuHandleOop item: anInteger markChar: aMarkChar! ! 148749 148750!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:18'! 148751setItemStyle: menuHandleOop item: anInteger style: aStyle! ! 148752 148753!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:18'! 148754setMenuItemHierarchicalID: menuHandleOop item: anInteger hierID: aMenuID! ! 148755 148756!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:19'! 148757setMenuItemModifiers: menuHandleOop item: anInteger inModifiers: aUInt8! ! 148758 148759!HostSystemMenusProxy methodsFor: 'accessing-menus' stamp: 'JMM 10/12/2004 12:19'! 148760setMenuTitle: menuHandleOop title: aMenuText! ! 148761 148762 148763!HostSystemMenusProxy methodsFor: 'finalization' stamp: 'JMM 10/12/2004 11:20'! 148764finalize 148765 [self destroyEveryThing] ifError: [:err :rcvr |]. 148766 ! ! 148767 148768!HostSystemMenusProxy methodsFor: 'finalization' stamp: 'JMM 10/12/2004 11:19'! 148769register 148770 ^self class register: self! ! 148771 148772!HostSystemMenusProxy methodsFor: 'finalization' stamp: 'JMM 10/12/2004 11:20'! 148773unregister 148774 ^self class unregister: self! ! 148775 148776 148777!HostSystemMenusProxy methodsFor: 'initialize-release' stamp: 'JMM 10/12/2004 14:13'! 148778destroyEveryThing 148779 self unregister! ! 148780 148781!HostSystemMenusProxy methodsFor: 'initialize-release' stamp: 'JMM 10/12/2004 12:21'! 148782disposeMenuBar! ! 148783 148784!HostSystemMenusProxy methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:57'! 148785initialize 148786 super initialize. 148787 self register! ! 148788 148789!HostSystemMenusProxy methodsFor: 'initialize-release' stamp: 'JMM 5/15/2006 23:24'! 148790reviseHostMenus! ! 148791 148792"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 148793 148794HostSystemMenusProxy class 148795 instanceVariableNames: ''! 148796 148797!HostSystemMenusProxy class methodsFor: 'instance creation' stamp: 'JMM 10/12/2004 11:13'! 148798isActiveHostMenuProxyClass 148799 ^false.! ! 148800 148801!HostSystemMenusProxy class methodsFor: 'instance creation' stamp: 'JMM 10/12/2004 12:35'! 148802new 148803 ^self basicNew initialize! ! 148804 148805 148806!HostSystemMenusProxy class methodsFor: 'registery' stamp: 'JMM 10/12/2004 11:17'! 148807register: anObject 148808 WeakArray isFinalizationSupported ifFalse:[^anObject]. 148809 self registry add: anObject! ! 148810 148811!HostSystemMenusProxy class methodsFor: 'registery' stamp: 'JMM 10/12/2004 11:18'! 148812registry 148813 WeakArray isFinalizationSupported ifFalse:[^nil]. 148814 ^Registry isNil 148815 ifTrue:[Registry := WeakRegistry new] 148816 ifFalse:[Registry].! ! 148817 148818!HostSystemMenusProxy class methodsFor: 'registery' stamp: 'JMM 10/12/2004 11:18'! 148819unregister: anObject 148820 WeakArray isFinalizationSupported ifFalse:[^anObject]. 148821 self registry remove: anObject ifAbsent:[]! ! 148822TestCase subclass: #HostSystemMenusTest 148823 instanceVariableNames: 'menuBar interface secondaryMenu subMenu' 148824 classVariableNames: '' 148825 poolDictionaries: '' 148826 category: 'Tests-Mac'! 148827 148828!HostSystemMenusTest methodsFor: 'as yet unclassified' stamp: 'John M McIntosh 11/19/2008 13:55'! 148829calculateShouldBeFrom2ndLevel: item using: c 148830 | shouldBe indexOf temp | 148831 148832 shouldBe := item size < 3 148833 ifTrue: [item copyReplaceAll: c with: ' '. 148834 item copyReplaceAll: '(' with: ' '.] 148835 ifFalse: [(c = '(') 148836 ifTrue: [ 148837 indexOf := item indexOf: $(. 148838 [((item at: indexOf) = $( and: [(item at: indexOf + 2) = $)]) 148839 ifTrue: 148840 [temp := item copy. 148841 ((item at: indexOf + 1) = Character space or: [(item at: indexOf + 1) = $(]) 148842 ifTrue: [temp at: indexOf put: Character space] 148843 ifFalse: [temp at: indexOf put: $/]. 148844 temp at: indexOf + 2 put: Character space. 148845 temp] 148846 ifFalse: [temp := item copy. 148847 temp at: indexOf put: Character space]. 148848 temp] 148849 ifError: [temp := item copy. 148850 temp at: indexOf put: Character space. 148851 temp]] 148852 ifFalse: [item copyReplaceAll: c with: ' ']]. 148853 (shouldBe indexOf: $() > 0 148854 ifTrue: [shouldBe = '(' ifTrue: [self halt]. 148855 ^self calculateShouldBeFrom2ndLevel: shouldBe using: '(']. 148856 ^shouldBe! ! 148857 148858!HostSystemMenusTest methodsFor: 'as yet unclassified' stamp: 'John M McIntosh 11/19/2008 13:50'! 148859calculateShouldBeFrom: item using: c 148860 | | 148861 148862 item replaceAll: $; with: Character space. 148863 item replaceAll: $^ with: Character space. 148864 item replaceAll: $!! with: Character space. 148865 item replaceAll: $< with: Character space. 148866 item replaceAll: $/ with: Character space. 148867 ^self calculateShouldBeFrom2ndLevel: item using: c! ! 148868 148869!HostSystemMenusTest methodsFor: 'as yet unclassified' stamp: 'mrcus.denker 9/4/2009 14:05'! 148870modifySqueakMenu: aString 148871 | results fixIndex middleCharacter | 148872 results := aString. 148873 results replaceAll: $; with: Character space. 148874 results replaceAll: $^ with: Character space. 148875 results replaceAll: $!! with: Character space. 148876 results replaceAll: $< with: Character space. 148877 results replaceAll: $/ with: Character space. 148878 fixIndex := results indexOf: $(. 148879 [fixIndex > 0] 148880 whileTrue: [ 148881 [(results at: fixIndex + 2) = $) 148882 ifTrue: [middleCharacter := results at: fixIndex + 1. 148883 (middleCharacter = Character space or: [middleCharacter = $(]) 148884 ifTrue: [results at: fixIndex put: Character space] 148885 ifFalse: [results at: fixIndex put: $/.]. 148886 results at: fixIndex + 1 put: middleCharacter asUppercase. 148887 results at: fixIndex + 2 put: Character space] 148888 ifFalse: [results at: fixIndex put: Character space]] 148889 ifError: [results at: fixIndex put: Character space]. 148890 fixIndex := results indexOf: $(]. 148891 ^ results! ! 148892 148893 148894!HostSystemMenusTest methodsFor: 'initialize-release' stamp: 'JMM 10/21/2004 18:47'! 148895setUp 148896 interface := HostSystemMenus defaultMenuBarForWindowIndex: self mainWindowIndexNumber. 148897 menuBar := interface menuBar. 148898 secondaryMenu := nil. 148899 148900! ! 148901 148902!HostSystemMenusTest methodsFor: 'initialize-release' stamp: 'JMM 8/26/2004 14:53'! 148903tearDown 148904 secondaryMenu ifNotNil: [interface deleteMenu: secondaryMenu]. 148905 subMenu ifNotNil: [interface deleteMenu: subMenu]! ! 148906 148907 148908!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/21/2004 18:55'! 148909testAppendWindowMenuMacOnly 148910 self isMacintosh ifFalse: [^self]. 148911 interface appendStandardWindowMenu: 0. 148912 148913 148914 148915 148916! ! 148917 148918!HostSystemMenusTest methodsFor: 'testing' stamp: 'John M McIntosh 11/19/2008 14:57'! 148919testCharacterChanging 148920 | testString item shouldBe resultingString where | 148921 #(';' '^' '!!' '<' '/' '(' ) 148922 do: [:c | #('*' '* ' '* ' '**' '** ' '** ' 148923 ')' '*)' '* )' '* )' '**)' '** )' '** )' 148924 ')' '*)' '*X)' '*XX)' '**)' '**X)' '**XX)' 148925 '))' '*))' '*X))' '*XX))' '**))' '**X))' '**XX))' 148926 '(' '*(' '*X(' '*XX(' '**)' '**X(' '**XX(' 148927 '((' '*((' '*X((' '*XX((' '**((' '**X((' '**XX((' 148928 ) 148929 do: [:template | 148930 testString := template copyReplaceAll: '*' with: c. 148931 testString 148932 permutationsDo: [:mixedUp | 148933 item := mixedUp copy. 148934 shouldBe := self calculateShouldBeFrom: item using: c. 148935 resultingString := self modifySqueakMenu: item copy. 148936 self should: [shouldBe = resultingString]. 148937 (where := resultingString indexOf: $/) > 0 148938 ifTrue: [self should: [(mixedUp at: where) = $(]. 148939 self should: [(mixedUp at: where+2) = $)]. 148940 self should: [(mixedUp at: where+1) asUppercase = (resultingString at: where+1)]]]]]! ! 148941 148942!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 1/15/2007 13:04'! 148943testCommandIDMacOnly 148944 "menuItemCommandID value is set by VM" 148945 | menuHandle menuItemCommandID | 148946 148947 self isMacintosh ifFalse: [^self]. 148948 (SmalltalkImage current osVersion asNumber < 1000) 148949 ifTrue: [^self]. 148950 menuHandle := interface getMenuHandle: self applicationFirstMenu. 148951 menuItemCommandID := interface getMenuItemCommandID: menuHandle item: self quitItem. 148952 (SmalltalkImage current osVersion asNumber >= 1000 and: [SmalltalkImage current osVersion asNumber < 1030]) 148953 ifTrue: [self should: [menuItemCommandID = 0]. ^self]. 148954 (SmalltalkImage current osVersion asNumber >= 1030) 148955 ifTrue: [self should: [menuItemCommandID = 1886545254]. ^self]. 148956 self should: [menuItemCommandID = 0]. 148957 148958! ! 148959 148960!HostSystemMenusTest methodsFor: 'testing' stamp: 'John M McIntosh 9/23/2009 14:53'! 148961testCountsMacOnly 148962 "Mac test, check state of Menus installed by VM and by menu initialization counts are platform dependent" 148963 148964 self isMacintosh ifFalse: [^self]. 148965 (SmalltalkImage current osVersion asNumber >= 1000) 148966 ifTrue: 148967 [self should: [(interface countMenuItems: (interface getMenuHandle: self applicationFirstMenu)) = 7]] 148968 ifFalse: 148969 [self should: [(interface countMenuItems: (interface getMenuHandle: self applicationFirstMenu)) > 0]. 148970 self should: [(interface countMenuItems: (interface getMenuHandle: self fileMenu)) = 6]]. 148971 self should: [(interface countMenuItems: (interface getMenuHandle: self editMenu)) = 6]. 148972 148973! ! 148974 148975!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/21/2004 18:31'! 148976testEditMenuEncodingMacOnly 148977 | menuHandle menuItemTextEncoding | 148978 148979 self isMacintosh ifFalse: [^self]. 148980 menuHandle := interface getMenuHandle: self editMenu. 148981 menuItemTextEncoding := interface getMenuItemTextEncoding: menuHandle item: self arbitraryMenuItem. 148982 self should: [menuItemTextEncoding = 4294967294 ]. 148983 148984! ! 148985 148986!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/21/2004 18:38'! 148987testEditMenuIsMenuItemEnabledMacOnly 148988 | menuHandle menuItemEnabled | 148989 148990 self isMacintosh ifFalse: [^self]. 148991 menuHandle := interface getMenuHandle: self editMenu. 148992 menuItemEnabled := interface isMenuItemEnabled: menuHandle item: self undoMenuItem. 148993 self should: [menuItemEnabled]. 148994 interface enableMenuItem: menuHandle item: self undoMenuItem. 148995 menuItemEnabled := interface isMenuItemEnabled: menuHandle item: self undoMenuItem. 148996 self should: [menuItemEnabled]. 148997 interface disableMenuItem: menuHandle item: self undoMenuItem. 148998 menuItemEnabled := interface isMenuItemEnabled: menuHandle item: self undoMenuItem. 148999 self should: [menuItemEnabled not]. 149000 interface enableMenuItem: menuHandle item: self undoMenuItem. 149001! ! 149002 149003!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/21/2004 18:39'! 149004testEditMenuItemCmdMacOnly 149005 | menuHandle menuItemCmd | 149006 149007 self isMacintosh ifFalse: [^self]. 149008 menuHandle := interface getMenuHandle: self editMenu. 149009 menuItemCmd := interface getItemCmd: menuHandle item: self undoMenuItem. 149010 self should: [menuItemCmd = $Z]. 149011 menuItemCmd := interface getItemCmd: menuHandle item: 3. 149012 self should: [menuItemCmd = $X]. 149013 menuItemCmd := interface getItemCmd: menuHandle item: 4. 149014 self should: [menuItemCmd = $C]. 149015 menuItemCmd := interface getItemCmd: menuHandle item: 5. 149016 self should: [menuItemCmd = $V]. 149017 menuItemCmd := interface getItemCmd: menuHandle item: 6. 149018 self should: [menuItemCmd = 0 asCharacter]. 149019 149020! ! 149021 149022!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/21/2004 18:39'! 149023testEditMenuItemIconMacOnly 149024 | menuHandle menuItemIcon | 149025 149026 self isMacintosh ifFalse: [^self]. 149027 menuHandle := interface getMenuHandle: self editMenu. 149028 menuItemIcon := interface getItemIcon: menuHandle item: self undoMenuItem. 149029 self should: [menuItemIcon = 0]. 149030 menuItemIcon := interface getItemIcon: menuHandle item: 3. 149031 self should: [menuItemIcon = 0]. 149032 menuItemIcon := interface getItemIcon: menuHandle item: 4. 149033 self should: [menuItemIcon = 0]. 149034 menuItemIcon := interface getItemIcon: menuHandle item: 5. 149035 self should: [menuItemIcon = 0]. 149036 menuItemIcon := interface getItemIcon: menuHandle item: 6. 149037 self should: [menuItemIcon = 0]. 149038 149039! ! 149040 149041!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/21/2004 18:40'! 149042testEditMenuItemMarkMacOnly 149043 | menuHandle menuItemMark | 149044 149045 self isMacintosh ifFalse: [^self]. 149046 menuHandle := interface getMenuHandle: self editMenu. 149047 menuItemMark := interface getItemMark: menuHandle item: self undoMenuItem. 149048 self should: [menuItemMark = 0 asCharacter]. 149049 menuItemMark := interface getItemMark: menuHandle item: 3. 149050 self should: [menuItemMark = 0 asCharacter]. 149051 menuItemMark := interface getItemMark: menuHandle item: 4. 149052 self should: [menuItemMark = 0 asCharacter]. 149053 menuItemMark := interface getItemMark: menuHandle item: 5. 149054 self should: [menuItemMark = 0 asCharacter]. 149055 menuItemMark := interface getItemMark: menuHandle item: 6. 149056 self should: [menuItemMark = 0 asCharacter]. 149057 149058! ! 149059 149060!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/21/2004 18:41'! 149061testEditMenuItemStyle 149062 | menuHandle menuItemStyle | 149063 149064 self isMacintosh ifFalse: [^self]. 149065 menuHandle := interface getMenuHandle: self editMenu. 149066 menuItemStyle := interface getItemStyle: menuHandle item: self undoMenuItem. 149067 self should: [menuItemStyle size = 0]. 149068 menuItemStyle := interface getItemStyle: menuHandle item: 3. 149069 self should: [menuItemStyle size = 0]. 149070 menuItemStyle := interface getItemStyle: menuHandle item: 4. 149071 self should: [menuItemStyle size = 0]. 149072 menuItemStyle := interface getItemStyle: menuHandle item: 5. 149073 self should: [menuItemStyle size = 0]. 149074 menuItemStyle := interface getItemStyle: menuHandle item: 6. 149075 self should: [menuItemStyle size = 0]. 149076 149077! ! 149078 149079!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/21/2004 18:42'! 149080testEditMenuItemsTextMacOnly 149081 | menuHandle menuItemText | 149082 149083 self isMacintosh ifFalse: [^self]. 149084 menuHandle := interface getMenuHandle: self editMenu. 149085 menuItemText := interface getMenuItemText: menuHandle item: 1. 149086 self should: [menuItemText = 'Undo']. 149087 menuItemText := interface getMenuItemText: menuHandle item: 2. 149088 self should: [menuItemText = '-']. 149089 menuItemText := interface getMenuItemText: menuHandle item: 3. 149090 self should: [menuItemText = 'Cut']. 149091 menuItemText := interface getMenuItemText: menuHandle item: 4. 149092 self should: [menuItemText = 'Copy']. 149093 menuItemText := interface getMenuItemText: menuHandle item: 5. 149094 self should: [menuItemText = 'Paste']. 149095 menuItemText := interface getMenuItemText: menuHandle item: 6. 149096 self should: [menuItemText = 'Clear']. 149097 149098! ! 149099 149100!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/21/2004 18:42'! 149101testEditMenuKeyGlyphMacOnly 149102 | menuHandle menuItemKeyGlyph | 149103 149104 self isMacintosh ifFalse: [^self]. 149105 menuHandle := interface getMenuHandle: self fileMenu. 149106 menuItemKeyGlyph := interface getMenuItemKeyGlyph: menuHandle item: self undoMenuItem. 149107 self should: [menuItemKeyGlyph = 0]. 149108 149109! ! 149110 149111!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/21/2004 18:43'! 149112testEditMenuModifiersMacOnly 149113 | menuHandle menuItemModifiers | 149114 149115 self isMacintosh ifFalse: [^self]. 149116 menuHandle := interface getMenuHandle: self editMenu. 149117 menuItemModifiers := interface getMenuItemModifiers: menuHandle item: self undoMenuItem. 149118 self should: [menuItemModifiers size = 1]. 149119 self should: [menuItemModifiers includes: #command]. 149120 149121 149122! ! 149123 149124!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 11/19/2004 13:21'! 149125testEncodingMacOnly 149126 "menuItemTextEncoding value is set by VM" 149127 | menuHandle menuItemTextEncoding | 149128 149129 self isMacintosh ifFalse: [^self]. 149130 menuHandle := interface getMenuHandle: self applicationFirstMenu. 149131 menuItemTextEncoding := interface getMenuItemTextEncoding: menuHandle item: self arbitraryMenuItem. 149132 self should: [menuItemTextEncoding isZero not ]. 149133 149134! ! 149135 149136!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/21/2004 18:26'! 149137testFontIDMacOnly 149138 "menuItemFontID value is set by VM" 149139 | menuHandle menuItemFontID | 149140 149141 self isMacintosh ifFalse: [^self]. 149142 menuHandle := interface getMenuHandle: self applicationFirstMenu. 149143 menuItemFontID := interface getMenuItemFontID: menuHandle item: self arbitraryMenuItem. 149144 self should: [menuItemFontID = 0]. 149145 149146! ! 149147 149148!HostSystemMenusTest methodsFor: 'testing' stamp: 'John M McIntosh 9/23/2009 14:53'! 149149testGetMenuTitleMacOnly 149150 149151 self isMacintosh ifFalse: [^self]. 149152 self should: [(interface getMenuTitle: (interface getMenuHandle: 1)) = '']. 149153 self should: [(interface getMenuTitle: (interface getMenuHandle: 3)) = 'Edit']. 149154 149155! ! 149156 149157!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/21/2004 18:26'! 149158testKeyGlyphMacOnly 149159 "menuItemKeyGlyph value is set by VM" 149160 | menuHandle menuItemKeyGlyph | 149161 149162 self isMacintosh ifFalse: [^self]. 149163 menuHandle := interface getMenuHandle: self applicationFirstMenu. 149164 menuItemKeyGlyph := interface getMenuItemKeyGlyph: menuHandle item: self arbitraryMenuItem. 149165 self should: [menuItemKeyGlyph = 0]. 149166 149167! ! 149168 149169!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/23/2004 11:27'! 149170testMenuHandles 149171 | menuHandle | 149172 1 to: 99 do: [:i | menuHandle := interface getMenuHandle: i. 149173 menuHandle isZero ifTrue: [^self]] 149174! ! 149175 149176!HostSystemMenusTest methodsFor: 'testing' stamp: 'John M McIntosh 9/23/2009 14:54'! 149177testMenuHandlesCount 149178 (SmalltalkImage current osVersion asNumber >= 1000) ifTrue: 149179 [self should: [(interface countMenuItems: (interface getMenuHandle: 1)) = 7]] 149180 ifFalse: 149181 [self should: [(interface countMenuItems: (interface getMenuHandle: 1)) > 0]]. 149182 self should: [(interface countMenuItems: (interface getMenuHandle: 3)) = 6]. 149183 149184! ! 149185 149186!HostSystemMenusTest methodsFor: 'testing' stamp: 'John M McIntosh 9/23/2009 14:54'! 149187testMenuHandlesGetMenu1CommandID 149188 | menuHandle menuItemCommandID | 149189 menuHandle := interface getMenuHandle: 1. 149190 menuItemCommandID := interface getMenuItemCommandID: menuHandle item: 8. 149191 (SmalltalkImage current osVersion asNumber >= 1000) 149192 ifTrue: [self should: [menuItemCommandID = 1886545254]] 149193 ifFalse: [self should: [menuItemCommandID = 0]] 149194 149195! ! 149196 149197!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/23/2004 13:04'! 149198testMenuHandlesGetMenu1Encoding 149199 | menuHandle menuItemTextEncoding | 149200 menuHandle := interface getMenuHandle: 1. 149201 menuItemTextEncoding := interface getMenuItemTextEncoding: menuHandle item: 1. 149202 self should: [menuItemTextEncoding = 4294967294 ]. 149203 149204! ! 149205 149206!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/23/2004 12:36'! 149207testMenuHandlesGetMenu1FontID 149208 | menuHandle menuItemFontID | 149209 menuHandle := interface getMenuHandle: 1. 149210 menuItemFontID := interface getMenuItemFontID: menuHandle item: 1. 149211 self should: [menuItemFontID = 0]. 149212 149213! ! 149214 149215!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/23/2004 12:40'! 149216testMenuHandlesGetMenu1KeyGlyph 149217 | menuHandle menuItemKeyGlyph | 149218 menuHandle := interface getMenuHandle: 1. 149219 menuItemKeyGlyph := interface getMenuItemKeyGlyph: menuHandle item: 1. 149220 self should: [menuItemKeyGlyph = 0]. 149221 149222! ! 149223 149224!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/23/2004 13:04'! 149225testMenuHandlesGetMenu3Encoding 149226 | menuHandle menuItemTextEncoding | 149227 menuHandle := interface getMenuHandle: 3. 149228 menuItemTextEncoding := interface getMenuItemTextEncoding: menuHandle item: 1. 149229 self should: [menuItemTextEncoding = 4294967294 ]. 149230 149231! ! 149232 149233!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/1/2004 16:07'! 149234testMenuHandlesGetMenu3IsMenuItemEnabled 149235 | menuHandle menuItemEnabled | 149236 menuHandle := interface getMenuHandle: 3. 149237 menuItemEnabled := interface isMenuItemEnabled: menuHandle item: 1. 149238 self should: [menuItemEnabled]. 149239 interface enableMenuItem: menuHandle item: 1. 149240 menuItemEnabled := interface isMenuItemEnabled: menuHandle item: 1. 149241 self should: [menuItemEnabled]. 149242 interface disableMenuItem: menuHandle item: 1. 149243 menuItemEnabled := interface isMenuItemEnabled: menuHandle item: 1. 149244 self should: [menuItemEnabled not]. 149245 interface enableMenuItem: menuHandle item: 1. 149246! ! 149247 149248!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/25/2004 12:42'! 149249testMenuHandlesGetMenu3ItemCmd 149250 | menuHandle menuItemCmd | 149251 menuHandle := interface getMenuHandle: 3. 149252 menuItemCmd := interface getItemCmd: menuHandle item: 1. 149253 self should: [menuItemCmd = $Z]. 149254 menuItemCmd := interface getItemCmd: menuHandle item: 3. 149255 self should: [menuItemCmd = $X]. 149256 menuItemCmd := interface getItemCmd: menuHandle item: 4. 149257 self should: [menuItemCmd = $C]. 149258 menuItemCmd := interface getItemCmd: menuHandle item: 5. 149259 self should: [menuItemCmd = $V]. 149260 menuItemCmd := interface getItemCmd: menuHandle item: 6. 149261 self should: [menuItemCmd = 0 asCharacter]. 149262 149263! ! 149264 149265!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/23/2004 14:01'! 149266testMenuHandlesGetMenu3ItemIcon 149267 | menuHandle menuItemIcon | 149268 menuHandle := interface getMenuHandle: 3. 149269 menuItemIcon := interface getItemIcon: menuHandle item: 1. 149270 self should: [menuItemIcon = 0]. 149271 menuItemIcon := interface getItemIcon: menuHandle item: 3. 149272 self should: [menuItemIcon = 0]. 149273 menuItemIcon := interface getItemIcon: menuHandle item: 4. 149274 self should: [menuItemIcon = 0]. 149275 menuItemIcon := interface getItemIcon: menuHandle item: 5. 149276 self should: [menuItemIcon = 0]. 149277 menuItemIcon := interface getItemIcon: menuHandle item: 6. 149278 self should: [menuItemIcon = 0]. 149279 149280! ! 149281 149282!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/25/2004 15:02'! 149283testMenuHandlesGetMenu3ItemMark 149284 | menuHandle menuItemMark | 149285 menuHandle := interface getMenuHandle: 3. 149286 menuItemMark := interface getItemMark: menuHandle item: 1. 149287 self should: [menuItemMark = 0 asCharacter]. 149288 menuItemMark := interface getItemMark: menuHandle item: 3. 149289 self should: [menuItemMark = 0 asCharacter]. 149290 menuItemMark := interface getItemMark: menuHandle item: 4. 149291 self should: [menuItemMark = 0 asCharacter]. 149292 menuItemMark := interface getItemMark: menuHandle item: 5. 149293 self should: [menuItemMark = 0 asCharacter]. 149294 menuItemMark := interface getItemMark: menuHandle item: 6. 149295 self should: [menuItemMark = 0 asCharacter]. 149296 149297! ! 149298 149299!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/25/2004 14:17'! 149300testMenuHandlesGetMenu3ItemStyle 149301 | menuHandle menuItemStyle | 149302 menuHandle := interface getMenuHandle: 3. 149303 menuItemStyle := interface getItemStyle: menuHandle item: 1. 149304 self should: [menuItemStyle size = 0]. 149305 menuItemStyle := interface getItemStyle: menuHandle item: 3. 149306 self should: [menuItemStyle size = 0]. 149307 menuItemStyle := interface getItemStyle: menuHandle item: 4. 149308 self should: [menuItemStyle size = 0]. 149309 menuItemStyle := interface getItemStyle: menuHandle item: 5. 149310 self should: [menuItemStyle size = 0]. 149311 menuItemStyle := interface getItemStyle: menuHandle item: 6. 149312 self should: [menuItemStyle size = 0]. 149313 149314! ! 149315 149316!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/23/2004 12:25'! 149317testMenuHandlesGetMenu3Items 149318 | menuHandle menuItemText | 149319 menuHandle := interface getMenuHandle: 3. 149320 menuItemText := interface getMenuItemText: menuHandle item: 1. 149321 self should: [menuItemText = 'Undo']. 149322 menuItemText := interface getMenuItemText: menuHandle item: 2. 149323 self should: [menuItemText = '-']. 149324 menuItemText := interface getMenuItemText: menuHandle item: 3. 149325 self should: [menuItemText = 'Cut']. 149326 menuItemText := interface getMenuItemText: menuHandle item: 4. 149327 self should: [menuItemText = 'Copy']. 149328 menuItemText := interface getMenuItemText: menuHandle item: 5. 149329 self should: [menuItemText = 'Paste']. 149330 menuItemText := interface getMenuItemText: menuHandle item: 6. 149331 self should: [menuItemText = 'Clear']. 149332 149333! ! 149334 149335!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/23/2004 12:40'! 149336testMenuHandlesGetMenu3KeyGlyph 149337 | menuHandle menuItemKeyGlyph | 149338 menuHandle := interface getMenuHandle: 3. 149339 menuItemKeyGlyph := interface getMenuItemKeyGlyph: menuHandle item: 1. 149340 self should: [menuItemKeyGlyph = 0]. 149341 149342! ! 149343 149344!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/25/2004 16:21'! 149345testMenuHandlesGetMenu3Modifiers 149346 | menuHandle menuItemModifiers | 149347 menuHandle := interface getMenuHandle: 3. 149348 menuItemModifiers := interface getMenuItemModifiers: menuHandle item: 1. 149349 self should: [menuItemModifiers size = 1]. 149350 self should: [menuItemModifiers includes: #command]. 149351 149352 149353! ! 149354 149355!HostSystemMenusTest methodsFor: 'testing' stamp: 'John M McIntosh 9/23/2009 14:57'! 149356testMenuHandlesGetMenuTitle 149357 self should: [(interface getMenuTitle: (interface getMenuHandle: 1)) = '']. 149358 self should: [(interface getMenuTitle: (interface getMenuHandle: 3)) = 'Edit']. 149359 149360! ! 149361 149362!HostSystemMenusTest methodsFor: 'testing' stamp: 'John M McIntosh 9/23/2009 18:03'! 149363testMenuHandlesNewMenu 149364 | menuString | 149365 149366 menuString := 'Foobar'. 149367 secondaryMenu := interface newMenu: 6 menuTitle: menuString. 149368 interface insertMenu: secondaryMenu beforeID: 0. 149369 interface drawMenuBar: 1. 149370 self should: [(interface getMenuTitle: secondaryMenu) = menuString]. 149371 interface deleteMenu: secondaryMenu. 149372 self should: [(interface getMenuHandle: 6) = 0]. 149373 secondaryMenu := nil 149374 149375 149376 149377! ! 149378 149379!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 1/15/2007 13:07'! 149380testMenuHandlesNewMenuAppend 149381 | menuString items | 149382 menuString := 'Foobar'. 149383 secondaryMenu := interface newMenu: self notUsedMenuNumber2 menuTitle: menuString. 149384 interface insertMenu: secondaryMenu beforeID: 0. 149385 items := OrderedCollection with: (HostSystemMenusMenuItem menuString: 'one') 149386 with: (HostSystemMenusMenuItem menuString: 'two' keyboardKey: $a). 149387 interface appendMenu: secondaryMenu menuItems: items. 149388 self should: [(interface getMenuItemText: secondaryMenu item: 1) = 'one']. 149389 self should: [(interface getMenuItemText: secondaryMenu item: 2) = 'two']. 149390 self should: [(interface getItemCmd: secondaryMenu item: 2) = $A]. 149391 self should: [(interface getItemIcon: secondaryMenu item: 1) = 0]. 149392 self should: [(interface getItemMark: secondaryMenu item: 1) = 0 asCharacter]. 149393 self should: [(interface getItemStyle: secondaryMenu item: 1) size = 0]. 149394 149395 149396 149397 149398 149399! ! 149400 149401!HostSystemMenusTest methodsFor: 'testing' stamp: 'stephane.ducasse 4/13/2009 20:30'! 149402testMenuHandlesNewMenuAppend2 149403 | menuString items testArray | 149404 menuString := 'Foobar'. 149405 secondaryMenu := interface newMenu: self notUsedMenuNumber2 menuTitle: menuString. 149406 interface insertMenu: secondaryMenu beforeID: 0. 149407 items := OrderedCollection new. 149408 items add: (HostSystemMenusMenuItem menuString: 'one'). 149409 items add: (HostSystemMenusMenuItem menuString: 'two'). 149410 items add: (HostSystemMenusMenuItem menuString: 'three'). 149411 items add: (HostSystemMenusMenuItem menuString: 'four'). 149412 items add: (HostSystemMenusMenuItem menuString: 'five'). 149413 items add: (HostSystemMenusMenuItem menuString: 'six'). 149414 (items at: 1) styleAdd: #bold. 149415 (items at: 2) styleAdd: #italic. 149416 (items at: 3) styleAdd: #underline. 149417 (items at: 4) styleAdd: #outline. 149418 (items at: 5) styleAdd: #shadow. 149419 (items at: 6) styleAdd: #bold. 149420 (items at: 6) styleAdd: #italic. 149421 (items at: 6) styleAdd: #underline. 149422 (items at: 6) styleAdd: #outline. 149423 (items at: 6) styleAdd: #shadow. 149424 interface appendMenu: secondaryMenu menuItems: items. 149425 testArray := #(1 #bold 2 #italic 3 #underline 4 #outline 5 #shadow). 149426 testArray pairsDo: [:item :style | 149427 self should: [(interface getItemStyle: secondaryMenu item: item) size = 1]. 149428 self should: [(interface getItemStyle: secondaryMenu item: item) includes: style]]. 149429 testArray := #(6 #bold 6 #italic 6 #underline 6 #outline 6 #shadow). 149430 self should: [(interface getItemStyle: secondaryMenu item: 6) size = 5]. 149431 testArray pairsDo: [:item :style | 149432 self should: [(interface getItemStyle: secondaryMenu item: item) includes: style]]. 149433 149434 149435 149436 149437 149438 149439 149440 149441! ! 149442 149443!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/25/2004 15:04'! 149444testMenuHandlesNewMenuAppendCheck 149445 149446 self testMenuHandlesNewMenuAppend. 149447 self should: [(interface getItemMark: secondaryMenu item: 1) = 0 asCharacter]. 149448 interface checkMenuItem: secondaryMenu item: 1 checked: true. 149449 self should: [(interface getItemMark: secondaryMenu item: 1) = 18 asCharacter]. 149450 interface checkMenuItem: secondaryMenu item: 1 checked: false. 149451 self should: [(interface getItemMark: secondaryMenu item: 1) = 0 asCharacter]. 149452 149453 149454 149455 149456 149457! ! 149458 149459!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/25/2004 14:57'! 149460testMenuHandlesNewMenuAppendCheckSetCmd 149461 149462 self testMenuHandlesNewMenuAppend. 149463 interface setItemCmd: secondaryMenu item: 1 cmdChar: $x. 149464 self should: [(interface getItemCmd: secondaryMenu item: 1) = $x]. 149465 149466 149467 149468 149469 149470! ! 149471 149472!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 1/15/2007 13:04'! 149473testMenuHandlesNewMenuAppendCheckSetCmd2 149474 149475 (SmalltalkImage current osVersion asNumber < 1000) 149476 ifTrue: [^self]. 149477 self testMenuHandlesNewMenuAppend. 149478 interface setMenuItemCommandID: secondaryMenu item: 1 menuCommand: 120. 149479 self should: [(interface getMenuItemCommandID: secondaryMenu item: 1) = 120]. 149480 149481 149482 149483 149484 149485! ! 149486 149487!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 1/15/2007 13:07'! 149488testMenuHandlesNewMenuAppendCheckSetItemHierarchicalID 149489 149490 | menuString items | 149491 self testMenuHandlesNewMenuAppend. 149492 menuString := ''. 149493 subMenu := interface newMenu: self notUsedMenuNumber menuTitle: menuString. 149494 items := OrderedCollection with: (HostSystemMenusMenuItem menuString: 'three') 149495 with: (HostSystemMenusMenuItem menuString: 'four' keyboardKey: $b).. 149496 interface appendMenu: subMenu menuItems: items. 149497 self should: [(interface getMenuItemText: subMenu item: 1) = 'three']. 149498 self should: [(interface getMenuItemText: subMenu item: 2) = 'four']. 149499 self should: [(interface getItemCmd: subMenu item: 2) = $B]. 149500 interface insertMenu: subMenu beforeID: -1. 149501 interface setMenuItemHierarchicalID: secondaryMenu item: 1 hierID: self notUsedMenuNumber. 149502 self should: [(interface getMenuItemHierarchicalID: secondaryMenu item: 1) = 5] 149503 149504 149505 149506! ! 149507 149508!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/26/2004 10:52'! 149509testMenuHandlesNewMenuAppendCheckSetItemModifiers 149510 | modifiers | 149511 149512 self testMenuHandlesNewMenuAppend. 149513 modifiers := #( (#command) (#shift) (#option) (#control) (#nocommand) 149514 ( #shift #option #control #nocommand)). 149515 modifiers do: [:m | 149516 interface setMenuItemModifiers: secondaryMenu item: 2 inModifiers: m. 149517 self should: [(interface getMenuItemModifiers: secondaryMenu item: 2) = m asSet]] 149518 149519 149520 149521 149522 149523! ! 149524 149525!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/26/2004 11:17'! 149526testMenuHandlesNewMenuAppendCheckSetItemText 149527 | string | 149528 149529 string := 'foobartoobar'. 149530 self testMenuHandlesNewMenuAppend. 149531 interface setMenuItemText: secondaryMenu item: 2 itemString: string. 149532 self should: [(interface getMenuItemText: secondaryMenu item: 2) = string]. 149533 149534 149535 149536 149537 149538! ! 149539 149540!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/26/2004 13:03'! 149541testMenuHandlesNewMenuAppendCheckSetItemTextEncoding 149542 | encoding | 149543 self testMenuHandlesNewMenuAppend. 149544 encoding := 37. 149545 interface setMenuItemTextEncoding: secondaryMenu item: 1 inScriptID: encoding. 149546 self should: [(interface getMenuItemTextEncoding: secondaryMenu item: 1) = encoding]. 149547 149548 149549 149550 149551 149552! ! 149553 149554!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/26/2004 16:57'! 149555testMenuHandlesNewMenuAppendCheckSetItemTextFondID 149556 | glyph | 149557 self testMenuHandlesNewMenuAppend. 149558 glyph := 16r6C. 149559 interface setMenuItemKeyGlyph: secondaryMenu item: 2 glyph: glyph. 149560 self should: [(interface getMenuItemKeyGlyph: secondaryMenu item: 2) = glyph]. 149561 149562 149563 149564 149565! ! 149566 149567!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/25/2004 15:00'! 149568testMenuHandlesNewMenuAppendCheckSetMark 149569 149570 self testMenuHandlesNewMenuAppend. 149571 interface setItemMark: secondaryMenu item: 1 markChar: $x. 149572 self should: [(interface getItemMark: secondaryMenu item: 1) = $x]. 149573 149574 149575 149576 149577 149578! ! 149579 149580!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/26/2004 12:50'! 149581testMenuHandlesNewMenuAppendCheckSetMenuTitle 149582 | string | 149583 149584 string := 'foobartoobar'. 149585 self testMenuHandlesNewMenuAppend. 149586 interface setMenuTitle: secondaryMenu title: string. 149587 self should: [(interface getMenuTitle: secondaryMenu) = string]. 149588 149589 149590 149591 149592 149593! ! 149594 149595!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/25/2004 16:03'! 149596testMenuHandlesNewMenuAppendCheckSetStyle 149597 | styles | 149598 149599 self testMenuHandlesNewMenuAppend. 149600 styles := Set withAll: #( #bold #italic #underline #outline #shadow). 149601 interface setItemStyle: secondaryMenu item: 1 style: styles. 149602 self should: [(interface getItemStyle: secondaryMenu item: 1) size = 5]. 149603 styles do: [:style | 149604 self should: [(interface getItemStyle: secondaryMenu item: 1) includes: style]]. 149605 149606 149607 149608 149609 149610! ! 149611 149612!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/25/2004 14:35'! 149613testMenuHandlesNewMenuAppendDeleteItem 149614 149615 self testMenuHandlesNewMenuAppend. 149616 interface deleteMenuItem: secondaryMenu item: 1. 149617 self should: [(interface countMenuItems: secondaryMenu) = 1]. 149618 self should: [(interface getMenuItemText: secondaryMenu item: 1) = 'two'] 149619 149620 149621 149622 149623 149624! ! 149625 149626!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/25/2004 14:35'! 149627testMenuHandlesNewMenuAppendDeleteItem2 149628 149629 self testMenuHandlesNewMenuAppend. 149630 interface deleteMenuItem: secondaryMenu item: 2. 149631 self should: [(interface countMenuItems: secondaryMenu) = 1]. 149632 self should: [(interface getMenuItemText: secondaryMenu item: 1) = 'one'] 149633 149634 149635 149636 149637 149638! ! 149639 149640!HostSystemMenusTest methodsFor: 'testing' stamp: 'torsten.bergmann 12/16/2008 12:47'! 149641testMenuHandlesNewMenuAppendInsertItem 149642 | aItem checkBlock1 checkBlock2 block1 block2 | 149643 149644 self testMenuHandlesNewMenuAppend. 149645 block1 := [:evt | Beeper beep]. 149646 block2 := [:evt | Beeper beep. Beeper beep]. 149647 aItem := HostSystemMenusMenuItem text: 'three' handler: block1. 149648 interface insertMenuItem: secondaryMenu item: aItem afterItem: 1. 149649 aItem := HostSystemMenusMenuItem text: 'four' handler: block2. 149650 interface insertMenuItem: secondaryMenu item: aItem afterItem: 3. 149651 checkBlock1 := (HostSystemMenus 149652 defaultMenuBarForWindowIndex: 1) getHandlerForMenu: 4 item: 2. 149653 checkBlock2 := (HostSystemMenus 149654 defaultMenuBarForWindowIndex: 1) getHandlerForMenu: 4 item: 4. 149655 self should: [checkBlock1 handler == block1 ]. 149656 self should: [checkBlock2 handler == block2 ]. 149657 self should: [(interface countMenuItems: secondaryMenu) = 4]. 149658 self should: [(interface getMenuItemText: secondaryMenu item: 2) = 'three']. 149659 self should: [(interface getMenuItemText: secondaryMenu item: 4) = 'four'] 149660 149661 149662 149663 149664 149665! ! 149666 149667!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 8/25/2004 12:39'! 149668testMenuHandlesNewMenuAppendText 149669 | testString | 149670 testString := 'testxyz'. 149671 self testMenuHandlesNewMenuAppend. 149672 interface appendMenuItemText: secondaryMenu data: testString. 149673 149674 149675 149676 149677! ! 149678 149679!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/6/2004 17:05'! 149680testMenuHandlesNewMenuAppendWindowMenu 149681 interface appendStandardWindowMenu: 0. 149682 149683 149684 149685 149686! ! 149687 149688!HostSystemMenusTest methodsFor: 'testing' stamp: 'JMM 10/15/2004 12:42'! 149689testMenuHideShowMenu 149690 self should: [interface isMenuBarVisible: 1]. 149691 interface hideMenuBar: 1. 149692 self should: [(interface isMenuBarVisible: 1) not]. 149693 interface showMenuBar: 1. 149694 self should: [interface isMenuBarVisible: 1]. 149695 interface drawMenuBar: 1. 149696 ! ! 149697 149698 149699!HostSystemMenusTest methodsFor: 'utility' stamp: 'JMM 10/21/2004 18:23'! 149700applicationFirstMenu 149701 ^1! ! 149702 149703!HostSystemMenusTest methodsFor: 'utility' stamp: 'JMM 10/21/2004 18:25'! 149704arbitraryMenuItem 149705 ^1! ! 149706 149707!HostSystemMenusTest methodsFor: 'utility' stamp: 'JMM 10/21/2004 18:24'! 149708editMenu 149709 ^3! ! 149710 149711!HostSystemMenusTest methodsFor: 'utility' stamp: 'JMM 10/21/2004 18:23'! 149712fileMenu 149713 ^2! ! 149714 149715!HostSystemMenusTest methodsFor: 'utility' stamp: 'MMP 7/28/2009 10:39'! 149716isMacintosh 149717 ^self class isMacintosh! ! 149718 149719!HostSystemMenusTest methodsFor: 'utility' stamp: 'JMM 10/21/2004 18:45'! 149720mainWindowIndexNumber 149721 ^1! ! 149722 149723!HostSystemMenusTest methodsFor: 'utility' stamp: 'JMM 10/21/2004 18:45'! 149724notUsedMenuNumber 149725 ^5! ! 149726 149727!HostSystemMenusTest methodsFor: 'utility' stamp: 'JMM 10/21/2004 18:50'! 149728notUsedMenuNumber2 149729 ^4! ! 149730 149731!HostSystemMenusTest methodsFor: 'utility' stamp: 'John M McIntosh 9/23/2009 14:53'! 149732quitItem 149733 ^8! ! 149734 149735!HostSystemMenusTest methodsFor: 'utility' stamp: 'JMM 10/21/2004 18:37'! 149736undoMenuItem 149737 ^1! ! 149738 149739"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 149740 149741HostSystemMenusTest class 149742 instanceVariableNames: ''! 149743 149744!HostSystemMenusTest class methodsFor: 'testing' stamp: 'MMP 7/28/2009 10:39'! 149745isAbstract 149746 ^self isMacintosh not! ! 149747 149748 149749!HostSystemMenusTest class methodsFor: 'utility' stamp: 'MMP 7/28/2009 10:38'! 149750isMacintosh 149751 ^SmalltalkImage current platformName = 'Mac OS'! ! 149752HostSystemMenusProxy subclass: #HostSystemMenusWindows 149753 instanceVariableNames: '' 149754 classVariableNames: '' 149755 poolDictionaries: '' 149756 category: 'HostMenus-Mac'! 149757 149758!HostSystemMenusWindows methodsFor: 'as yet unclassified' stamp: 'be 8/13/2006 15:54'! 149759toggleReaderMode: aValue! ! 149760 149761"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 149762 149763HostSystemMenusWindows class 149764 instanceVariableNames: ''! 149765 149766!HostSystemMenusWindows class methodsFor: 'instance creation' stamp: 'JMM 1/15/2007 12:00'! 149767isActiveHostMenuProxyClass 149768"Am I active?" 149769 ^SmalltalkImage current platformName = 'Win32'! ! 149770Object subclass: #HostWindowProxy 149771 instanceVariableNames: 'windowHandle sourceForm' 149772 classVariableNames: 'ActiveProxyClass Registry' 149773 poolDictionaries: '' 149774 category: 'Graphics-External-Ffenestri'! 149775!HostWindowProxy commentStamp: 'tpr 10/14/2004 16:00' prior: 0! 149776This is a proxy for a Host OS window and as such is considered a disposable item. When an image is restarted the client must recreate suitable instances from the information they hold. Platform specific subclasses are available to translate abstract requirements into possible platform concrete data. 149777There is a registry of instances so that when users let go they can be guaranteed to close down properly. Because the instances point to the source Form in use this can on occasion result in a cycle that defeats the Weak mechanism - hence the implementation of #executor & #asExecutor. 149778The only requirements placed on the sourceForm instvar are those of being like a DisplayScreen - can return a bits array, the width, depth etc AND able to respond to #resetProxy to remove and rebuild the window proxy! 149779 149780 149781!HostWindowProxy methodsFor: 'accessing' stamp: 'tpr 10/6/2004 14:29'! 149782isOpen 149783"am I already opened?" 149784 ^windowHandle notNil! ! 149785 149786!HostWindowProxy methodsFor: 'accessing' stamp: 'tpr 10/7/2004 10:30'! 149787windowProxyError: problemString 149788 "Could be useful to raise an exception but not yet"! ! 149789 149790 149791!HostWindowProxy methodsFor: 'finalization' stamp: 'lr 7/4/2009 10:42'! 149792asExecutor 149793 sourceForm := nil! ! 149794 149795!HostWindowProxy methodsFor: 'finalization' stamp: 'tpr 9/30/2004 13:10'! 149796executor 149797 ^self shallowCopy asExecutor! ! 149798 149799!HostWindowProxy methodsFor: 'finalization' stamp: 'tpr 10/6/2004 21:20'! 149800finalize 149801 "close this window" 149802 self close! ! 149803 149804!HostWindowProxy methodsFor: 'finalization' stamp: 'tpr 9/30/2004 12:56'! 149805register 149806 ^self class register: self! ! 149807 149808!HostWindowProxy methodsFor: 'finalization' stamp: 'tpr 10/12/2004 19:43'! 149809resetProxy 149810"tell my sourceForm to kill me (gulp) and resurrect me in the correct clothing" 149811 sourceForm ifNotNil:[ sourceForm resetProxy]! ! 149812 149813!HostWindowProxy methodsFor: 'finalization' stamp: 'tpr 9/30/2004 12:56'! 149814unregister 149815 ^self class unregister: self! ! 149816 149817 149818!HostWindowProxy methodsFor: 'initialize-release' stamp: 'tpr 10/6/2004 21:20'! 149819close 149820 "close this window" 149821 windowHandle ifNil: [^self]. 149822 self unregister. 149823 self primitiveWindowClose: windowHandle! ! 149824 149825!HostWindowProxy methodsFor: 'initialize-release' stamp: 'lr 7/4/2009 10:42'! 149826on: aSourceForm 149827 "set my sourceForm; usually an actual Form but so long as methods like bits, height etc work, it can be anything" 149828 sourceForm := aSourceForm! ! 149829 149830!HostWindowProxy methodsFor: 'initialize-release' stamp: 'tpr 10/7/2004 11:17'! 149831open 149832 "open a host window built around my position, size and bitmap" 149833 windowHandle 149834 ifNil: [sourceForm 149835 ifNotNil:[windowHandle := self 149836 primitiveCreateHostWindowWidth: self width 149837 height: self height 149838 originX: self offset x 149839 y: self offset y 149840 attributes: self attributes. 149841 windowHandle ifNotNil:[self register]. 149842 ^windowHandle]]! ! 149843 149844 149845!HostWindowProxy methodsFor: 'metrics' stamp: 'tpr 9/28/2004 15:47'! 149846bits 149847"return the bits - normally of the sourceForm" 149848 ^sourceForm bits! ! 149849 149850!HostWindowProxy methodsFor: 'metrics' stamp: 'tpr 9/28/2004 16:08'! 149851depth 149852"return the depth - normally of the sourceForm" 149853 ^sourceForm depth! ! 149854 149855!HostWindowProxy methodsFor: 'metrics' stamp: 'tpr 9/28/2004 15:47'! 149856height 149857"return the height - normally of the sourceForm" 149858 ^sourceForm height! ! 149859 149860!HostWindowProxy methodsFor: 'metrics' stamp: 'tpr 9/28/2004 15:47'! 149861offset 149862"return the offset - normally of the sourceForm" 149863 ^sourceForm offset! ! 149864 149865!HostWindowProxy methodsFor: 'metrics' stamp: 'tpr 9/28/2004 15:47'! 149866width 149867"return the width - normally of the sourceForm" 149868 ^sourceForm width! ! 149869 149870 149871!HostWindowProxy methodsFor: 'printing' stamp: 'tpr 9/29/2004 11:59'! 149872printOn: aStream 149873 super printOn:aStream. 149874 aStream nextPutAll: ' (windowIndex '. 149875 windowHandle printOn: aStream. 149876 aStream nextPut: $)! ! 149877 149878 149879!HostWindowProxy methodsFor: 'system primitives' stamp: 'tpr 9/28/2004 13:22'! 149880primitiveCreateHostWindowWidth: w height: h originX: x y: y attributes: list 149881"create and open a host window. list is a ByteArray list of window attributes in some platform manner. See subclasses for information" 149882 <primitive: 'primitiveCreateHostWindow' module: 'HostWindowPlugin'> 149883 ^self error: 'Unable to create Host Window'! ! 149884 149885!HostWindowProxy methodsFor: 'system primitives' stamp: 'tpr 10/7/2004 10:31'! 149886primitiveUpdateHostWindow: id bitmap: bitmap width: w height: h depth: d left: l 149887right: r top: t bottom: b 149888 "Force the pixels to the screen. The bitmap details and affected area are given 149889explicitly to avoid dependence upon any object structure" 149890 <primitive: 'primitiveShowHostWindowRect' module:'HostWindowPlugin'> 149891 ^self windowProxyError: 'update'! ! 149892 149893!HostWindowProxy methodsFor: 'system primitives' stamp: 'tpr 10/7/2004 10:31'! 149894primitiveWindowClose: id 149895"Close the window" 149896 <primitive: 'primitiveCloseHostWindow' module: 'HostWindowPlugin'> 149897 ^self windowProxyError: 'close'! ! 149898 149899!HostWindowProxy methodsFor: 'system primitives' stamp: 'tpr 10/7/2004 10:32'! 149900primitiveWindowPosition: id 149901"Find the topleft corner of the window" 149902 <primitive: 'primitiveHostWindowPosition' module: 'HostWindowPlugin'> 149903 ^self windowProxyError: 'get position'! ! 149904 149905!HostWindowProxy methodsFor: 'system primitives' stamp: 'tpr 10/7/2004 10:32'! 149906primitiveWindowPosition: id x: x y: y 149907"Set the topleft corner of the window - return what is actually set" 149908 <primitive: 'primitiveHostWindowPositionSet' module: 'HostWindowPlugin'> 149909 ^self windowProxyError: 'set position'! ! 149910 149911!HostWindowProxy methodsFor: 'system primitives' stamp: 'tpr 10/7/2004 10:32'! 149912primitiveWindowSize: id 149913"Find the size of the window, just like primitiveScreenSize" 149914 <primitive: 'primitiveHostWindowSize' module: 'HostWindowPlugin'> 149915 ^self windowProxyError: 'get size'! ! 149916 149917!HostWindowProxy methodsFor: 'system primitives' stamp: 'tpr 10/7/2004 10:33'! 149918primitiveWindowSize: id x: x y: y 149919"Set the size of the window, just like primitiveScreenSize. Return the actually 149920achieved size" 149921 <primitive: 'primitiveHostWindowSizeSet' module: 'HostWindowPlugin'> 149922 ^self windowProxyError: 'set size'! ! 149923 149924!HostWindowProxy methodsFor: 'system primitives' stamp: 'tpr 9/28/2004 13:26'! 149925primitiveWindowTitle: id string: titleString 149926"Set the label of the title bar of the window" 149927 <primitive: 'primitiveHostWindowTitle' module: 'HostWindowPlugin'> 149928 ^self error: 'Unable to set title of Host Window'! ! 149929 149930 149931!HostWindowProxy methodsFor: 'window decorations' stamp: 'tpr 9/28/2004 15:52'! 149932attributes 149933"return the ByteArray representing the desired window attributes. This is utterly platform dependent and my default is an empty ByteArray to signify a default window" 149934 ^ByteArray new! ! 149935 149936!HostWindowProxy methodsFor: 'window decorations' stamp: 'tpr 10/7/2004 11:33'! 149937defaultWindowType 149938"set up my attributes to be a default window - a titlebar, usual decorations etc" 149939 ^self subclassResponsibility! ! 149940 149941 149942!HostWindowProxy methodsFor: 'window manipulation' stamp: 'tpr 9/28/2004 15:47'! 149943forceToScreen: damageRectangle 149944 "update the area of the sourceForm defined by damageRectangle" 149945 self 149946 primitiveUpdateHostWindow: windowHandle 149947 bitmap: self bits 149948 width: self width 149949 height: self height 149950 depth: self depth 149951 left: damageRectangle left 149952 right: damageRectangle right 149953 top: damageRectangle top 149954 bottom: damageRectangle bottom! ! 149955 149956!HostWindowProxy methodsFor: 'window manipulation' stamp: 'tpr 10/6/2004 14:31'! 149957recreate 149958"something has changed that require deleting the host window before opening it 149959with new attributes" 149960 self close; open! ! 149961 149962!HostWindowProxy methodsFor: 'window manipulation' stamp: 'tpr 9/28/2004 13:34'! 149963windowPosition 149964 "return the current position of the window" 149965 ^self primitiveWindowPosition: windowHandle! ! 149966 149967!HostWindowProxy methodsFor: 'window manipulation' stamp: 'tpr 9/28/2004 13:34'! 149968windowPosition: aPoint 149969 "set the position of the window and then return the new position" 149970 ^self primitiveWindowPosition: windowHandle x: aPoint x y: aPoint y! ! 149971 149972!HostWindowProxy methodsFor: 'window manipulation' stamp: 'tpr 9/28/2004 13:35'! 149973windowSize 149974 "return the current size of the window " 149975 ^self primitiveWindowSize: windowHandle! ! 149976 149977!HostWindowProxy methodsFor: 'window manipulation' stamp: 'tpr 9/28/2004 13:35'! 149978windowSize: aPoint 149979 "Set the size of the window and then return the actually set size of the window - not neccessarily the same " 149980 ^self primitiveWindowSize: windowHandle x: aPoint x y: aPoint y! ! 149981 149982!HostWindowProxy methodsFor: 'window manipulation' stamp: 'tpr 9/28/2004 13:35'! 149983windowTitle: titleString 149984"set the label in the window titlebar to titleString" 149985 ^self primitiveWindowTitle: windowHandle string: titleString! ! 149986 149987"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 149988 149989HostWindowProxy class 149990 instanceVariableNames: ''! 149991 149992!HostWindowProxy class methodsFor: 'class initialization' stamp: 'tpr 10/14/2004 16:01'! 149993initialize 149994"Add me to the system startup list and make sure to do a file-in init for first time loading" 149995"HostWindowProxy initialize" 149996 self startUp. "make sure we init on code load" 149997 Smalltalk addToStartUpList: self after: nil! ! 149998 149999 150000!HostWindowProxy class methodsFor: 'initialize-release' stamp: 'tpr 10/1/2004 15000116:35'! 150002on: aSourceForm 150003"Build a new window proxy by finding the appropriate platform specific subclass 150004and setting it up for this Form-like argument" 150005 ^ActiveProxyClass new on: aSourceForm! ! 150006 150007 150008!HostWindowProxy class methodsFor: 'registry' stamp: 'tpr 10/14/2004 16:00'! 150009register: anObject 150010"boilerplate WeakRegistry usage" 150011 WeakArray isFinalizationSupported ifFalse:[^anObject]. 150012 self registry add: anObject! ! 150013 150014!HostWindowProxy class methodsFor: 'registry' stamp: 'tpr 10/14/2004 16:00'! 150015registry 150016"boilerplate WeakRegistry usage" 150017 WeakArray isFinalizationSupported ifFalse:[^nil]. 150018 ^Registry isNil 150019 ifTrue:[Registry := WeakRegistry new] 150020 ifFalse:[Registry].! ! 150021 150022!HostWindowProxy class methodsFor: 'registry' stamp: 'tpr 10/14/2004 16:01'! 150023unregister: anObject 150024"boilerplate WeakRegistry usage" 150025 WeakArray isFinalizationSupported ifFalse:[^anObject]. 150026 self registry remove: anObject ifAbsent:[]! ! 150027 150028 150029!HostWindowProxy class methodsFor: 'system startup' stamp: 'tpr 10/14/2004 16:02'! 150030activeWindowProxyClass 150031 "Return the concrete HostWindowProxy subclass for the platform on which we are 150032currently running." 150033 150034 HostWindowProxy allSubclasses do: [:class | 150035 class isActiveHostWindowProxyClass ifTrue: [^ class]]. 150036 150037 "no responding subclass; use HostWindowProxy" 150038 ^ HostWindowProxy 150039! ! 150040 150041!HostWindowProxy class methodsFor: 'system startup' stamp: 'tpr 10/1/2004 15004216:07'! 150043isActiveHostWindowProxyClass 150044"subclasses must override this" 150045 self subclassResponsibility! ! 150046 150047!HostWindowProxy class methodsFor: 'system startup' stamp: 'lr 7/4/2009 10:42'! 150048setDefaultWindowProxyClass 150049 "connect to the proper platform subclass of proxy" 150050 ActiveProxyClass := self activeWindowProxyClass! ! 150051 150052!HostWindowProxy class methodsFor: 'system startup' stamp: 'tpr 10/12/2004 19:39'! 150053startUp 150054"system startup - find the appropriate proxy class for this platform" 150055 self setDefaultWindowProxyClass. 150056 "any currently extant instances must tell their sourceForm to resetProxy in order to kill potentially wrong-platform versions and reset to correct-platform" 150057 self registry do:[:i| i resetProxy]! ! 150058TestCase subclass: #HostWindowTests 150059 instanceVariableNames: '' 150060 classVariableNames: '' 150061 poolDictionaries: '' 150062 category: 'Tests-Ffenestri'! 150063 150064!HostWindowTests methodsFor: 'testing' stamp: 'lr 7/4/2009 10:42'! 150065testOne 150066 "Make a host window, display some of Display on it and update." 150067 "self run: #testOne" 150068 | hwindow | 150069 hwindow := DisplayHostWindow 150070 extent: 400 @ 300 150071 depth: Display depth. 150072 hwindow translateBy: 100 @ 100. "Avoid window off topleft error" 150073 self 150074 shouldnt: [ hwindow open ] 150075 raise: Error. 150076 self 150077 assert: hwindow windowSize = (400 @ 300) 150078 description: 'intial size incorrect'. 150079 self 150080 shouldnt: 150081 [ Display displayOn: hwindow. 150082 hwindow forceToScreen: hwindow boundingBox. 150083 Display 150084 displayOn: hwindow 150085 at: -100 @ -200. 150086 hwindow forceToScreen: (100 @ 100 extent: 200 @ 200). 150087 hwindow forceToScreen: (-100 @ 0 extent: 200 @ 2200) ] 150088 raise: Error. 150089 self 150090 assert: hwindow windowPosition = (100 @ 100) 150091 description: 'initial position incorrect'. 150092 self 150093 assert: (hwindow windowPosition: 300 @ 300) = (300 @ 300) 150094 description: 'altered position incorrect'. 150095 self 150096 assert: hwindow windowSize = (400 @ 300) 150097 description: 'initial size incorrect'. 150098 self 150099 assert: (hwindow windowSize: 600 @ 400) = (600 @ 400) 150100 description: 'altered size incorrect'. 150101 self 150102 shouldnt: [ hwindow windowTitle: 'Yoo hoo!! See the new title' ] 150103 raise: Error. 150104 self 150105 should: [ hwindow windowTitle: 'A Very long String.' , (String new: 300) ] 150106 raise: Error. 150107 (Delay forSeconds: 4) wait. 150108 self 150109 shouldnt: [ hwindow close ] 150110 raise: Error! ! 150111HierarchicalUrl subclass: #HttpUrl 150112 instanceVariableNames: 'realm' 150113 classVariableNames: 'Passwords' 150114 poolDictionaries: '' 150115 category: 'Network-Url'! 150116!HttpUrl commentStamp: 'ls 6/15/2003 13:44' prior: 0! 150117A URL that can be accessed via the Hypertext Transfer Protocol (HTTP), ie, a standard Web URL 150118 150119realm = the name of the security realm that has been discovered for this URL. Look it up in Passwords. 150120 150121Passwords = a Dictionary of (realm -> encoded user&password) 150122 150123 150124TODO: use the username and password, if specified 150125! 150126 150127 150128!HttpUrl methodsFor: 'downloading' stamp: 'rbb 3/1/2005 10:57'! 150129askNamePassword 150130 "Authorization is required by the host site. Ask the user for a userName and password. Encode them and store under this realm. Return false if the user wants to give up." 150131 150132 | user pass | 150133 (self confirm: 'Host ', self toText, ' 150134wants a different user and password. Type them now?' orCancel: [false]) 150135 ifFalse: [^ false]. 150136 user := UIManager default request: 'User account name?' initialAnswer: '' 150137 centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint - (50@0). 150138 pass := UIManager default requestPassword: 'Password?'. 150139 Passwords at: realm put: (Authorizer new encode: user password: pass). 150140 ^ true! ! 150141 150142!HttpUrl methodsFor: 'downloading' stamp: 'nk 8/30/2004 07:50'! 150143checkAuthorization: webDocument retry: retryBlock 150144 "authorization failed if webDocument is a String" 150145 | oldRealm i end encoded | 150146 ((webDocument isString) 150147 and: [(webDocument beginsWith: 'HTTP/1.0 401') 150148 or: [webDocument beginsWith: 'HTTP/1.1 401']]) 150149 ifFalse: [^self]. 150150 150151 oldRealm := realm. 150152 i := webDocument findString: 'realm="'. 150153 i = 0 ifTrue: [^self]. 150154 end := webDocument indexOf: $" startingAt: i. 150155 realm := webDocument copyFrom: i+7 to: end. 150156 "realm := (webDocument findTokens: '""') at: 2." 150157 Passwords ifNil: [Passwords := Dictionary new]. 150158 encoded := Passwords at: realm ifAbsent: [nil]. 150159 (oldRealm ~= realm) & (encoded ~~ nil) 150160 ifTrue: [^ retryBlock value] 150161 ifFalse: ["ask the user" 150162 self askNamePassword ifTrue: [^ retryBlock value]]! ! 150163 150164!HttpUrl methodsFor: 'downloading' stamp: 'mir 10/13/1999 19:41'! 150165loadRemoteObjects 150166 "Load a remote image segment and extract the root objects. 150167 Check if the remote file is a zip archive." 150168 "'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.extSeg' 150169 asUrl loadRemoteObjects" 150170 "'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.zip' 150171 asUrl loadRemoteObjects" 150172 150173 | stream info data extension | 150174 data := self retrieveContents content. 150175 extension := (FileDirectory extensionFor: self path last) asLowercase. 150176 (#('zip' 'gzip') includes: extension) 150177 ifTrue: [data := (GZipReadStream on: data) upToEnd]. 150178" stream := StreamWrapper streamOver: (ReadStream on: data)." 150179 stream := RWBinaryOrTextStream on: data. 150180 stream reset. 150181 info := stream fileInObjectAndCode. 150182 stream close. 150183 ^info arrayOfRoots! ! 150184 150185!HttpUrl methodsFor: 'downloading' stamp: 'noha 5/28/2009 22:14'! 150186normalizeContents: webDocument 150187 (webDocument isString) ifTrue: [ 150188 ^MIMEDocument 150189 contentType: 'text/plain' 150190 content: 'error occured retrieving ', self asString, ': ', webDocument 150191 url: (Url absoluteFromText: '')]. 150192 webDocument contentType = MIMEDocument defaultContentType ifTrue: [ 150193 ^MIMEDocument 150194 contents: webDocument content 150195 mimeType: (MIMEDocument guessTypeFromName: self path last) 150196 uri: webDocument url ]. 150197 150198 ^webDocument! ! 150199 150200!HttpUrl methodsFor: 'downloading' stamp: 'fbs 2/2/2005 13:24'! 150201postFormArgs: args 150202 | contents request | 150203 request := realm ifNotNil: [Passwords at: realm ifAbsent: ['']] 150204 ifNil: ['']. 150205 request = '' ifFalse: [request := 'Authorization: Basic ', request, String crlf]. 150206 "Why doesn't Netscape send the name of the realm instead of Basic?" 150207 contents := (HTTPSocket httpPostDocument: self asString args: args 150208 accept: 'application/octet-stream' request: request). 150209 150210 self checkAuthorization: contents retry: [^ self postFormArgs: args]. 150211 150212 ^self normalizeContents: contents! ! 150213 150214!HttpUrl methodsFor: 'downloading' stamp: 'fbs 2/2/2005 13:24'! 150215postMultipartFormArgs: args 150216 | contents request | 150217 request := realm ifNotNil: [Passwords at: realm ifAbsent: ['']] 150218 ifNil: ['']. 150219 request = '' ifFalse: [request := 'Authorization: Basic ', request, String crlf]. 150220 "Why doesn't Netscape send the name of the realm instead of Basic?" 150221 contents := (HTTPSocket httpPostMultipart: self asString args: args 150222 accept: 'application/octet-stream' request: request). 150223 150224 self checkAuthorization: contents retry: [^ self postMultipartFormArgs: args]. 150225 150226 ^self normalizeContents: contents! ! 150227 150228!HttpUrl methodsFor: 'downloading' stamp: 'tk 9/22/1998 19:49'! 150229privateInitializeFromText: aString relativeTo: aUrl 150230 150231 super privateInitializeFromText: aString relativeTo: aUrl. 150232 realm := aUrl realm.! ! 150233 150234!HttpUrl methodsFor: 'downloading' stamp: 'tk 9/22/1998 19:47'! 150235realm 150236 ^ realm! ! 150237 150238!HttpUrl methodsFor: 'downloading' stamp: 'tk 9/22/1998 20:21'! 150239retrieveContents 150240 ^ self retrieveContentsArgs: nil! ! 150241 150242!HttpUrl methodsFor: 'downloading'! 150243retrieveContentsAccept: mimeType 150244 ^ self retrieveContentsArgs: nil accept: mimeType! ! 150245 150246!HttpUrl methodsFor: 'downloading' stamp: 'GabrielOmarCotelli 6/12/2009 21:25'! 150247retrieveContentsArgs: args 150248 150249 "From http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html 150250 The Accept request-header field can be used to specify certain media types which are acceptable for the response. 150251 Accept = 'Accept' ':' 150252 #( media-range [ accept-params ] ) 150253 media-range = ( '*/*' 150254 | ( type '/' '*' ) 150255 | ( type '/' subtype ) 150256 ) *( ';' parameter ) 150257 accept-params = ';' 'q' '=' qvalue *( accept-extension ) 150258 accept-extension = ';' token [ '=' ( token | quoted-string ) ] 150259 The asterisk *' character is used to group media types into ranges, with '*/*' indicating all media types and 'type/*' indicating 150260 all subtypes of that type. Each media-range MAY be followed by one or more accept-params, beginning with the 'q' parameter for 150261 indicating a relative quality factor. Quality factors allow the user or user agent to indicate the relative degree of preference for 150262 that media-range, using the qvalue scale from 0 to 1" 150263 150264 | allMimeTypes | 150265 allMimeTypes := '*/*; q=1'. 150266 ^ self 150267 retrieveContentsArgs: args 150268 accept: allMimeTypes! ! 150269 150270!HttpUrl methodsFor: 'downloading' stamp: 'fbs 2/2/2005 13:24'! 150271retrieveContentsArgs: args accept: mimeType 150272 | contents request | 150273 request := realm ifNotNil: [Passwords at: realm ifAbsent: ['']] ifNil: ['']. 150274 request = '' ifFalse: [request := 'Authorization: Basic ' , request , String crlf]. 150275 "Why doesn't Netscape send the name of the realm instead of Basic?" 150276 150277 contents := (HTTPSocket 150278 httpGetDocument: self withoutFragment asString 150279 args: args 150280 accept: mimeType 150281 request: request). 150282 150283 self checkAuthorization: contents retry: [^ self retrieveContentsArgs: args]. 150284 150285 ^ self normalizeContents: contents! ! 150286 150287 150288!HttpUrl methodsFor: 'testing' stamp: 'ar 2/27/2001 22:08'! 150289hasRemoteContents 150290 "Return true if the receiver describes some remotely accessible content. 150291 Typically, this should only return if we could retrieve the contents 150292 on an arbitrary place in the outside world using a standard browser. 150293 In other words: If you can get to it from the next Internet Cafe, 150294 return true, else return false." 150295 ^true! ! 150296 150297"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 150298 150299HttpUrl class 150300 instanceVariableNames: ''! 150301 150302!HttpUrl class methodsFor: 'as yet unclassified' stamp: 'tk 9/22/1998 23:13'! 150303shutDown 150304 "Forget all cached passwords, so they won't stay in the image" 150305 150306 Passwords := nil.! ! 150307ByteTextConverter subclass: #ISO88592TextConverter 150308 instanceVariableNames: '' 150309 classVariableNames: 'FromTable' 150310 poolDictionaries: '' 150311 category: 'Multilingual-TextConversion'! 150312!ISO88592TextConverter commentStamp: '<historical>' prior: 0! 150313Text converter for ISO 8859-2. An international encoding used in Eastern Europe.! 150314 150315 150316"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 150317 150318ISO88592TextConverter class 150319 instanceVariableNames: ''! 150320 150321!ISO88592TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/5/2009 14:07'! 150322byteToUnicodeSpec 150323 "Sepcify a table mapping the entries 0x80 to 0xFF to their unicode counterparts by returning a 128 element array.. 150324 The entries 0x00 to 0x7F map to identical values so we don't need to specify them." 150325 150326 "http://de.wikipedia.org/wiki/ISO:=8859-2" 150327 "http://www.gymel.com/charsets/ISO8859-2.html" 150328 ^#( 150329 16r20AC 16r0081 16r0082 16r0083 16r0084 16r0085 16r0086 16r0087 150330 16r0088 16r0089 16r008A 16r008B 16r008C 16r008D 16r008E 16r008F 150331 150332 16r0090 16r0091 16r0092 16r0093 16r0094 16r0095 16r0096 16r0097 150333 16r0098 16r0099 16r009A 16r009B 16r009C 16r009D 16r009E 16r009F 150334 150335 16r00A0 16r0104 16r02D8 16r0141 16r00A4 16r013D 16r015A 16r00A7 150336 16r00A8 16r0160 16r015E 16r0164 16r0179 16r00AD 16r017D 16r017B 150337 150338 16r00B0 16r0105 16r02DB 16r0142 16r00B4 16r013E 16r015B 16r02C7 150339 16r00B8 16r0161 16r015F 16r0165 16r017A 16r02DD 16r017E 16r017C 150340 150341 16r0154 16r00C1 16r00C2 16r0102 16r00C4 16r0139 16r0106 16r00C7 150342 16r010C 16r00C9 16r0118 16r00CB 16r011A 16r00CD 16r00CE 16r010E 150343 150344 16r0110 16r0143 16r0147 16r00D3 16r00D4 16r0150 16r00D6 16r00D7 150345 16r0158 16r016E 16r00DA 16r0170 16r00DC 16r00DD 16r0162 16r00DF 150346 150347 16r0155 16r00E1 16r00E2 16r0103 16r00E4 16r013A 16r0107 16r00E7 150348 16r010D 16r00E9 16r0119 16r00EB 16r011B 16r00ED 16r00EE 16r010F 150349 150350 16r0111 16r0144 16r0148 16r00F3 16r00F4 16r0151 16r00F6 16r00F7 150351 16r0159 16r016F 16r00FA 16r0171 16r00FC 16r00FD 16r0163 16r02D9 150352)! ! 150353 150354!ISO88592TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 18:48'! 150355languageEnvironment 150356 ^Latin2Environment! ! 150357 150358 150359!ISO88592TextConverter class methodsFor: 'initialization' stamp: 'yo 1/18/2005 09:17'! 150360initialize 150361" 150362 self initialize 150363" 150364 FromTable := Dictionary new. 150365 150366 FromTable at: 16r00A0 put: 16rA0. 150367 FromTable at: 16r0104 put: 16rA1. 150368 FromTable at: 16r02D8 put: 16rA2. 150369 FromTable at: 16r0141 put: 16rA3. 150370 FromTable at: 16r00A4 put: 16rA4. 150371 FromTable at: 16r013D put: 16rA5. 150372 FromTable at: 16r015A put: 16rA6. 150373 FromTable at: 16r00A7 put: 16rA7. 150374 FromTable at: 16r00A8 put: 16rA8. 150375 FromTable at: 16r0160 put: 16rA9. 150376 FromTable at: 16r015E put: 16rAA. 150377 FromTable at: 16r0164 put: 16rAB. 150378 FromTable at: 16r0179 put: 16rAC. 150379 FromTable at: 16r00AD put: 16rAD. 150380 FromTable at: 16r017D put: 16rAE. 150381 FromTable at: 16r017B put: 16rAF. 150382 FromTable at: 16r00B0 put: 16rB0. 150383 FromTable at: 16r0105 put: 16rB1. 150384 FromTable at: 16r02DB put: 16rB2. 150385 FromTable at: 16r0142 put: 16rB3. 150386 FromTable at: 16r00B4 put: 16rB4. 150387 FromTable at: 16r013E put: 16rB5. 150388 FromTable at: 16r015B put: 16rB6. 150389 FromTable at: 16r02C7 put: 16rB7. 150390 FromTable at: 16r00B8 put: 16rB8. 150391 FromTable at: 16r0161 put: 16rB9. 150392 FromTable at: 16r015F put: 16rBA. 150393 FromTable at: 16r0165 put: 16rBB. 150394 FromTable at: 16r017A put: 16rBC. 150395 FromTable at: 16r02DD put: 16rBD. 150396 FromTable at: 16r017E put: 16rBE. 150397 FromTable at: 16r017C put: 16rBF. 150398 FromTable at: 16r0154 put: 16rC0. 150399 FromTable at: 16r00C1 put: 16rC1. 150400 FromTable at: 16r00C2 put: 16rC2. 150401 FromTable at: 16r0102 put: 16rC3. 150402 FromTable at: 16r00C4 put: 16rC4. 150403 FromTable at: 16r0139 put: 16rC5. 150404 FromTable at: 16r0106 put: 16rC6. 150405 FromTable at: 16r00C7 put: 16rC7. 150406 FromTable at: 16r010C put: 16rC8. 150407 FromTable at: 16r00C9 put: 16rC9. 150408 FromTable at: 16r0118 put: 16rCA. 150409 FromTable at: 16r00CB put: 16rCB. 150410 FromTable at: 16r011A put: 16rCC. 150411 FromTable at: 16r00CD put: 16rCD. 150412 FromTable at: 16r00CE put: 16rCE. 150413 FromTable at: 16r010E put: 16rCF. 150414 FromTable at: 16r0110 put: 16rD0. 150415 FromTable at: 16r0143 put: 16rD1. 150416 FromTable at: 16r0147 put: 16rD2. 150417 FromTable at: 16r00D3 put: 16rD3. 150418 FromTable at: 16r00D4 put: 16rD4. 150419 FromTable at: 16r0150 put: 16rD5. 150420 FromTable at: 16r00D6 put: 16rD6. 150421 FromTable at: 16r00D7 put: 16rD7. 150422 FromTable at: 16r0158 put: 16rD8. 150423 FromTable at: 16r016E put: 16rD9. 150424 FromTable at: 16r00DA put: 16rDA. 150425 FromTable at: 16r0170 put: 16rDB. 150426 FromTable at: 16r00DC put: 16rDC. 150427 FromTable at: 16r00DD put: 16rDD. 150428 FromTable at: 16r0162 put: 16rDE. 150429 FromTable at: 16r00DF put: 16rDF. 150430 FromTable at: 16r0155 put: 16rE0. 150431 FromTable at: 16r00E1 put: 16rE1. 150432 FromTable at: 16r00E2 put: 16rE2. 150433 FromTable at: 16r0103 put: 16rE3. 150434 FromTable at: 16r00E4 put: 16rE4. 150435 FromTable at: 16r013A put: 16rE5. 150436 FromTable at: 16r0107 put: 16rE6. 150437 FromTable at: 16r00E7 put: 16rE7. 150438 FromTable at: 16r010D put: 16rE8. 150439 FromTable at: 16r00E9 put: 16rE9. 150440 FromTable at: 16r0119 put: 16rEA. 150441 FromTable at: 16r00EB put: 16rEB. 150442 FromTable at: 16r011B put: 16rEC. 150443 FromTable at: 16r00ED put: 16rED. 150444 FromTable at: 16r00EE put: 16rEE. 150445 FromTable at: 16r010F put: 16rEF. 150446 FromTable at: 16r0111 put: 16rF0. 150447 FromTable at: 16r0144 put: 16rF1. 150448 FromTable at: 16r0148 put: 16rF2. 150449 FromTable at: 16r00F3 put: 16rF3. 150450 FromTable at: 16r00F4 put: 16rF4. 150451 FromTable at: 16r0151 put: 16rF5. 150452 FromTable at: 16r00F6 put: 16rF6. 150453 FromTable at: 16r00F7 put: 16rF7. 150454 FromTable at: 16r0159 put: 16rF8. 150455 FromTable at: 16r016F put: 16rF9. 150456 FromTable at: 16r00FA put: 16rFA. 150457 FromTable at: 16r0171 put: 16rFB. 150458 FromTable at: 16r00FC put: 16rFC. 150459 FromTable at: 16r00FD put: 16rFD. 150460 FromTable at: 16r0163 put: 16rFE. 150461 FromTable at: 16r02D9 put: 16rFF. 150462! ! 150463 150464 150465!ISO88592TextConverter class methodsFor: 'utilities' stamp: 'yo 1/18/2005 09:17'! 150466encodingNames 150467 150468 ^ #('iso-8859-2') copy 150469! ! 150470ByteTextConverter subclass: #ISO88597TextConverter 150471 instanceVariableNames: '' 150472 classVariableNames: 'FromTable' 150473 poolDictionaries: '' 150474 category: 'Multilingual-TextConversion'! 150475!ISO88597TextConverter commentStamp: '<historical>' prior: 0! 150476Text converter for ISO 8859-7. An international encoding used for Greek.! 150477 150478 150479"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 150480 150481ISO88597TextConverter class 150482 instanceVariableNames: ''! 150483 150484!ISO88597TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/5/2009 14:07'! 150485byteToUnicodeSpec 150486 "Sepcify a table mapping the entries 0x80 to 0xFF to their unicode counterparts by returning a 128 element array.. 150487 The entries 0x00 to 0x7F map to identical values so we don't need to specify them." 150488 150489 "http://en.wikipedia.org/wiki/ISO:=8859-7" 150490 "http://unicode.org/Public/MAPPINGS/ISO8859/8859-7.TXT" 150491 ^#( 150492 16r0080 16r0081 16r0082 16r0083 16r0084 16r0085 16r0086 16r0087 150493 16r0088 16r0089 16r008A 16r008B 16r008C 16r008D 16r008E 16r008F 150494 150495 16r0090 16r0091 16r0092 16r0093 16r0094 16r0095 16r0096 16r0097 150496 16r0098 16r0099 16r009A 16r009B 16r009C 16r009D 16r009E 16r009F 150497 150498 16r00A0 16r2018 16r2019 16r00A3 16r20AC 16r20AF 16r00A6 16r00A7 150499 16r00A8 16r00A9 16r037A 16r00AB 16r00AC 16r00AD 16r00AE 16r2015 150500 150501 16r00B0 16r00B1 16r00B2 16r00B3 16r0384 16r0385 16r0386 16r00B7 150502 16r0388 16r0389 16r038A 16r00BB 16r038C 16r00BD 16r038E 16r038F 150503 150504 16r0390 16r0391 16r0392 16r0393 16r0394 16r0395 16r0396 16r0397 150505 16r0398 16r0399 16r039A 16r039B 16r039C 16r039D 16r039E 16r039F 150506 150507 16r03A0 16r03A1 16rFFFD 16r03A3 16r03A4 16r03A5 16r03A6 16r03A7 150508 16r03A8 16r03A9 16r03AA 16r03AB 16r03AC 16r03AD 16r03AE 16r03AF 150509 150510 16r03B0 16r03B1 16r03B2 16r03B3 16r03B4 16r03B5 16r03B6 16r03B7 150511 16r03B8 16r03B9 16r03BA 16r03BB 16r03BC 16r03BD 16r03BE 16r03BF 150512 150513 16r03C0 16r03C1 16r03C2 16r03C3 16r03C4 16r03C5 16r03C6 16r03C7 150514 16r03C8 16r03C9 16r03CA 16r03CB 16r03CC 16r03CD 16r03CE 16r00FF 150515)! ! 150516 150517!ISO88597TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 18:49'! 150518languageEnvironment 150519 ^GreekEnvironment! ! 150520 150521 150522!ISO88597TextConverter class methodsFor: 'initialization' stamp: 'yo 2/9/2004 17:36'! 150523initialize 150524" 150525 self initialize 150526" 150527 FromTable := Dictionary new. 150528 150529 FromTable at: 16r00A0 put: 16rA0. 150530 FromTable at: 16r2018 put: 16rA1. 150531 FromTable at: 16r2019 put: 16rA2. 150532 FromTable at: 16r00A3 put: 16rA3. 150533 FromTable at: 16r20AC put: 16rA4. 150534 FromTable at: 16r20AF put: 16rA5. 150535 FromTable at: 16r00A6 put: 16rA6. 150536 FromTable at: 16r00A7 put: 16rA7. 150537 FromTable at: 16r00A8 put: 16rA8. 150538 FromTable at: 16r00A9 put: 16rA9. 150539 FromTable at: 16r037A put: 16rAA. 150540 FromTable at: 16r00AB put: 16rAB. 150541 FromTable at: 16r00AC put: 16rAC. 150542 FromTable at: 16r00AD put: 16rAD. 150543 FromTable at: 16r2015 put: 16rAF. 150544 FromTable at: 16r00B0 put: 16rB0. 150545 FromTable at: 16r00B1 put: 16rB1. 150546 FromTable at: 16r00B2 put: 16rB2. 150547 FromTable at: 16r00B3 put: 16rB3. 150548 FromTable at: 16r0384 put: 16rB4. 150549 FromTable at: 16r0385 put: 16rB5. 150550 FromTable at: 16r0386 put: 16rB6. 150551 FromTable at: 16r00B7 put: 16rB7. 150552 FromTable at: 16r0388 put: 16rB8. 150553 FromTable at: 16r0389 put: 16rB9. 150554 FromTable at: 16r038A put: 16rBA. 150555 FromTable at: 16r00BB put: 16rBB. 150556 FromTable at: 16r038C put: 16rBC. 150557 FromTable at: 16r00BD put: 16rBD. 150558 FromTable at: 16r038E put: 16rBE. 150559 FromTable at: 16r038F put: 16rBF. 150560 FromTable at: 16r0390 put: 16rC0. 150561 FromTable at: 16r0391 put: 16rC1. 150562 FromTable at: 16r0392 put: 16rC2. 150563 FromTable at: 16r0393 put: 16rC3. 150564 FromTable at: 16r0394 put: 16rC4. 150565 FromTable at: 16r0395 put: 16rC5. 150566 FromTable at: 16r0396 put: 16rC6. 150567 FromTable at: 16r0397 put: 16rC7. 150568 FromTable at: 16r0398 put: 16rC8. 150569 FromTable at: 16r0399 put: 16rC9. 150570 FromTable at: 16r039A put: 16rCA. 150571 FromTable at: 16r039B put: 16rCB. 150572 FromTable at: 16r039C put: 16rCC. 150573 FromTable at: 16r039D put: 16rCD. 150574 FromTable at: 16r039E put: 16rCE. 150575 FromTable at: 16r039F put: 16rCF. 150576 FromTable at: 16r03A0 put: 16rD0. 150577 FromTable at: 16r03A1 put: 16rD1. 150578 FromTable at: 16r03A3 put: 16rD3. 150579 FromTable at: 16r03A4 put: 16rD4. 150580 FromTable at: 16r03A5 put: 16rD5. 150581 FromTable at: 16r03A6 put: 16rD6. 150582 FromTable at: 16r03A7 put: 16rD7. 150583 FromTable at: 16r03A8 put: 16rD8. 150584 FromTable at: 16r03A9 put: 16rD9. 150585 FromTable at: 16r03AA put: 16rDA. 150586 FromTable at: 16r03AB put: 16rDB. 150587 FromTable at: 16r03AC put: 16rDC. 150588 FromTable at: 16r03AD put: 16rDD. 150589 FromTable at: 16r03AE put: 16rDE. 150590 FromTable at: 16r03AF put: 16rDF. 150591 FromTable at: 16r03B0 put: 16rE0. 150592 FromTable at: 16r03B1 put: 16rE1. 150593 FromTable at: 16r03B2 put: 16rE2. 150594 FromTable at: 16r03B3 put: 16rE3. 150595 FromTable at: 16r03B4 put: 16rE4. 150596 FromTable at: 16r03B5 put: 16rE5. 150597 FromTable at: 16r03B6 put: 16rE6. 150598 FromTable at: 16r03B7 put: 16rE7. 150599 FromTable at: 16r03B8 put: 16rE8. 150600 FromTable at: 16r03B9 put: 16rE9. 150601 FromTable at: 16r03BA put: 16rEA. 150602 FromTable at: 16r03BB put: 16rEB. 150603 FromTable at: 16r03BC put: 16rEC. 150604 FromTable at: 16r03BD put: 16rED. 150605 FromTable at: 16r03BE put: 16rEE. 150606 FromTable at: 16r03BF put: 16rEF. 150607 FromTable at: 16r03C0 put: 16rF0. 150608 FromTable at: 16r03C1 put: 16rF1. 150609 FromTable at: 16r03C2 put: 16rF2. 150610 FromTable at: 16r03C3 put: 16rF3. 150611 FromTable at: 16r03C4 put: 16rF4. 150612 FromTable at: 16r03C5 put: 16rF5. 150613 FromTable at: 16r03C6 put: 16rF6. 150614 FromTable at: 16r03C7 put: 16rF7. 150615 FromTable at: 16r03C8 put: 16rF8. 150616 FromTable at: 16r03C9 put: 16rF9. 150617 FromTable at: 16r03CA put: 16rFA. 150618 FromTable at: 16r03CB put: 16rFB. 150619 FromTable at: 16r03CC put: 16rFC. 150620 FromTable at: 16r03CD put: 16rFD. 150621 FromTable at: 16r03CE put: 16rFE. 150622! ! 150623 150624 150625!ISO88597TextConverter class methodsFor: 'utilities' stamp: 'yo 2/10/2004 06:32'! 150626encodingNames 150627 150628 ^ #('iso-8859-7' 'greek-iso-8859-8bit') copy 150629! ! 150630Object subclass: #ISOLanguageDefinition 150631 instanceVariableNames: 'iso3 iso2 iso3Alternate language' 150632 classVariableNames: 'ISO2Countries ISO2Table ISO3Countries ISO3Table' 150633 poolDictionaries: '' 150634 category: 'System-Localization'! 150635 150636!ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:20'! 150637iso2 150638 ^iso2 ifNil: [self iso3]! ! 150639 150640!ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:21'! 150641iso3 150642 ^iso3 ifNil: ['']! ! 150643 150644!ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 6/30/2004 15:47'! 150645iso3Alternate 150646 ^iso3Alternate ifNil: ['']! ! 150647 150648!ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 8/15/2003 13:13'! 150649language 150650 ^language! ! 150651 150652 150653!ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 6/30/2004 15:54'! 150654iso2: aString 150655 iso2 := aString ifEmpty: [nil] ifNotEmpty: [aString]! ! 150656 150657!ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 6/30/2004 15:54'! 150658iso3: aString 150659 iso3 := aString ifEmpty: [nil] ifNotEmpty: [aString]! ! 150660 150661!ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 6/30/2004 15:54'! 150662iso3Alternate: aString 150663 iso3Alternate := aString ifEmpty: [nil] ifNotEmpty: [aString]! ! 150664 150665!ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 8/15/2003 13:40'! 150666language: aString 150667 language := aString! ! 150668 150669"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 150670 150671ISOLanguageDefinition class 150672 instanceVariableNames: ''! 150673 150674!ISOLanguageDefinition class methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:06'! 150675iso2LanguageDefinition: aString 150676 ^self iso2LanguageTable at: aString! ! 150677 150678!ISOLanguageDefinition class methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:06'! 150679iso3LanguageDefinition: aString 150680 ^self iso3LanguageTable at: aString! ! 150681 150682 150683!ISOLanguageDefinition class methodsFor: 'initialization' stamp: 'mir 7/1/2004 18:19'! 150684initialize 150685 "ISOLanguageDefinition initialize" 150686 150687 ISO3Table := nil. 150688 ISO2Table := nil! ! 150689 150690 150691!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:06'! 150692buildIso3166CodesTables 150693 "ISOLanguageDefinition buildIso3166CodesTables" 150694 | rawdata stream country isoa2 isoa3 unNumeric macName macCode windowsName windowsCode empty table | 150695 rawdata := self iso3166Codes. 150696 table := OrderedCollection new: 200. 150697 stream := rawdata readStream. 150698 empty := 160 asCharacter asString. 150699 [stream atEnd] whileFalse: 150700 [country := stream nextLine. 150701 isoa2 := stream nextLine. 150702 isoa3 := stream nextLine. 150703 unNumeric := stream nextLine. 150704 windowsName := stream nextLine. 150705 windowsName = empty ifTrue: [windowsName := nil]. 150706 windowsCode := stream nextLine. 150707 windowsCode = empty ifTrue: [windowsCode := nil]. 150708 macName := stream nextLine. 150709 macName = empty ifTrue: [macName := nil]. 150710 macCode := stream nextLine. 150711 macCode = empty ifTrue: [macCode := nil]. 150712 table add: { country. isoa2. isoa3. unNumeric. windowsName. windowsCode. macName. macCode. }]. 150713 ^table! ! 150714 150715!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:14'! 150716extraCountryDefinitions 150717 ^{ 150718 {'Kids'. 'KIDS'. 'KIDS'.}. 150719 }! ! 150720 150721!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:14'! 150722extraISO3Definitions 150723 150724 ^self readISOLanguagesFrom: 'jpk Japanese (Kids) 150725' readStream! ! 150726 150727!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:13'! 150728initISO3LanguageTable 150729 "ISOLanguageDefinition initIso3LanguageTable" 150730 150731 | table | 150732 table := ISOLanguageDefinition readISOLanguagesFrom: ISOLanguageDefinition isoLanguages readStream. 150733 table addAll: self extraISO3Definitions. 150734 ^table! ! 150735 150736!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:12'! 150737initISOCountries 150738 "ISOLanguageDefinition initISOCountries" 150739 | iso3166Table | 150740 iso3166Table := ISOLanguageDefinition buildIso3166CodesTables. 150741 ISO2Countries := Dictionary new. 150742 ISO3Countries := Dictionary new. 150743 iso3166Table do: [:entry | 150744 ISO2Countries at: (entry at: 2) put: (entry at: 1). 150745 ISO3Countries at: (entry at: 3) put: (entry at: 1)]. 150746 self extraCountryDefinitions do: [:entry | 150747 ISO2Countries at: (entry at: 2) put: (entry at: 1). 150748 ISO3Countries at: (entry at: 3) put: (entry at: 1)]! ! 150749 150750!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:18'! 150751iso2Countries 150752 "ISOLanguageDefinition iso2Countries" 150753 "ISO2Countries := nil. ISO3Countries := nil" 150754 150755 ISO2Countries ifNil: [self initISOCountries]. 150756 ^ISO2Countries! ! 150757 150758!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/1/2004 18:14'! 150759iso2LanguageTable 150760 "ISOLanguageDefinition iso2LanguageTable" 150761 150762 ISO2Table ifNotNil: [^ISO2Table]. 150763 ISO2Table := Dictionary new: self iso3LanguageTable basicSize. 150764 self iso3LanguageTable do: [:entry | 150765 ISO2Table at: entry iso2 put: entry]. 150766 ^ISO2Table! ! 150767 150768!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 13:57'! 150769iso3166Codes 150770"http://www.unicode.org/onlinedat/countries.html" 150771 150772^'ÅLAND ISLANDS 150773AX 150774 150775 150776 150777 150778 150779 150780AFGHANISTAN 150781AF 150782AFG 150783004 150784 150785 150786 150787 150788ALBANIA 150789AL 150790ALB 150791008 150792CTRY_ALBANIA 150793355 150794 150795 150796ALGERIA 150797DZ 150798DZA 150799012 150800CTRY_ALGERIA 150801213 150802verArabic 15080316 150804AMERICAN SAMOA 150805AS 150806ASM 150807016 150808 150809 150810 150811 150812ANDORRA 150813AD 150814AND 150815020 150816 150817 150818 150819 150820ANGOLA 150821AO 150822AGO 150823024 150824 150825 150826 150827 150828ANGUILLA 150829AI 150830AIA 150831660 150832 150833 150834 150835 150836ANTARCTICA 150837AQ 150838ATA 150839010 150840 150841 150842 150843 150844ANTIGUA AND BARBUDA 150845AG 150846ATG 150847028 150848 150849 150850 150851 150852ARGENTINA 150853AR 150854ARG 150855032 150856CTRY_ARGENTINA 15085754 150858 150859 150860ARMENIA 150861AM 150862ARM 150863051 150864CTRY_ARMENIA 150865374 150866verArmenian 15086784 150868ARUBA 150869AW 150870ABW 150871533 150872 150873 150874 150875 150876AUSTRALIA 150877AU 150878AUS 150879036 150880CTRY_AUSTRALIA 15088161 150882verAustralia 15088315 150884AUSTRIA 150885AT 150886AUT 150887040 150888CTRY_AUSTRIA 15088943 150890verAustria 15089192 150892AZERBAIJAN 150893AZ 150894AZE 150895031 150896CTRY_AZERBAIJAN 150897994 150898 150899 150900BAHAMAS 150901BS 150902BHS 150903044 150904 150905 150906 150907 150908BAHRAIN 150909BH 150910BHR 150911048 150912CTRY_BAHRAIN 150913973 150914 150915 150916BANGLADESH 150917BD 150918BGD 150919050 150920 150921 150922verBengali 15092360 150924BARBADOS 150925BB 150926BRB 150927052 150928 150929 150930 150931 150932BELARUS 150933BY 150934BLR 150935112 150936CTRY_BELARUS 150937375 150938 150939 150940BELGIUM 150941BE 150942BEL 150943056 150944CTRY_BELGIUM 15094532 150946verFrBelgium, verFlemish 15094798 150948BELIZE 150949BZ 150950BLZ 150951084 150952CTRY_BELIZE 150953501 150954 150955 150956BENIN 150957BJ 150958BEN 150959204 150960 150961 150962 150963 150964BERMUDA 150965BM 150966BMU 150967060 150968 150969 150970 150971 150972BHUTAN 150973BT 150974BTN 150975064 150976 150977 150978verBhutan 15097983 150980BOLIVIA 150981BO 150982BOL 150983068 150984CTRY_BOLIVIA 150985591 150986 150987 150988BOSNIA AND HERZEGOVINA 150989BA 150990BIH 150991070 150992 150993 150994 150995 150996BOTSWANA 150997BW 150998BWA 150999072 151000 151001 151002 151003 151004BOUVET ISLAND 151005BV 151006BVT 151007074 151008 151009 151010 151011 151012BRAZIL 151013BR 151014BRA 151015076 151016CTRY_BRAZIL 15101755 151018verBrazil 15101971 151020BRITISH INDIAN OCEAN TERRITORY 151021IO 151022IOT 151023086 151024 151025 151026 151027 151028BRUNEI DARUSSALAM 151029BN 151030BRN 151031096 151032CTRY_BRUNEI_DARUSSALAM 151033673 151034 151035 151036BULGARIA 151037BG 151038BGR 151039100 151040CTRY_BULGARIA 151041359 151042verBulgaria 15104372 151044BURKINA FASO 151045BF 151046BFA 151047854 151048 151049 151050 151051 151052BURUNDI 151053BI 151054BDI 151055108 151056 151057 151058 151059 151060CAMBODIA 151061KH 151062KHM 151063116 151064 151065 151066 151067 151068CAMEROON 151069CM 151070CMR 151071120 151072 151073 151074 151075 151076CANADA 151077CA 151078CAN 151079124 151080CTRY_CANADA 1510812 151082verFrCanada, verEndCanada 15108382 151084CAPE VERDE 151085CV 151086CPV 151087132 151088 151089 151090 151091 151092CAYMAN ISLANDS 151093KY 151094CYM 151095136 151096 151097 151098 151099 151100CENTRAL AFRICAN REPUBLIC 151101CF 151102CAF 151103140 151104 151105 151106 151107 151108CHAD 151109TD 151110TCD 151111148 151112 151113 151114 151115 151116CHILE 151117CL 151118CHL 151119152 151120CTRY_CHILE 15112156 151122 151123 151124CHINA 151125CN 151126CHN 151127156 151128CTRY_PRCHINA 15112986 151130verChina 15113152 151132CHRISTMAS ISLAND 151133CX 151134CXR 151135162 151136 151137 151138 151139 151140COCOS (KEELING) ISLANDS 151141CC 151142CCK 151143166 151144 151145 151146 151147 151148COLOMBIA 151149CO 151150COL 151151170 151152CTRY_COLOMBIA 15115357 151154 151155 151156COMOROS 151157KM 151158COM 151159174 151160 151161 151162 151163 151164CONGO 151165CG 151166COG 151167178 151168 151169 151170 151171 151172CONGO, THE DEMOCRATIC REPUBLIC OF THE 151173CD 151174 151175 151176 151177 151178 151179 151180COOK ISLANDS 151181CK 151182COK 151183184 151184 151185 151186 151187 151188COSTA RICA 151189CR 151190CRI 151191188 151192CTRY_COSTA_RICA 151193506 151194 151195 151196COTE D''IVOIRE 151197CI 151198CIV 151199384 151200 151201 151202 151203 151204CROATIA (local name: Hrvatska) 151205HR 151206HRV 151207191 151208CTRY_CROATIA 151209385 151210verCroatia, verYugoCroatian 15121168 (c), 25 (y) 151212CUBA 151213CU 151214CUB 151215192 151216 151217 151218 151219 151220CYPRUS 151221CY 151222CYP 151223196 151224 151225 151226verCyprus 15122723 151228CZECH REPUBLIC 151229CZ 151230CZE 151231203 151232CTRY_CZECH 151233420 151234verCzech 15123556 151236DENMARK 151237DK 151238DNK 151239208 151240CTRY_DENMARK 15124145 151242verDenmark(da), verFaeroeIsl(fo) 1512439(da), 47(fo) 151244DJIBOUTI 151245DJ 151246DJI 151247262 151248 151249 151250 151251 151252DOMINICA 151253DM 151254DMA 151255212 151256 151257 151258 151259 151260DOMINICAN REPUBLIC 151261DO 151262DOM 151263214 151264CTRY_DOMINICAN_REPUBLIC 1512651 151266 151267 151268EAST TIMOR 151269TL 151270TLS 151271626 151272 151273 151274 151275 151276ECUADOR 151277EC 151278ECU 151279218 151280CTRY_ECUADOR 151281593 151282 151283 151284EGYPT 151285EG 151286EGY 151287818 151288CTRY_EGYPT 15128920 151290verArabic 15129116 151292EL SALVADOR 151293SV 151294SLV 151295222 151296CTRY_EL_SALVADOR 151297503 151298 151299 151300EQUATORIAL GUINEA 151301GQ 151302GNQ 151303226 151304 151305 151306 151307 151308ERITREA 151309ER 151310ERI 151311232 151312 151313 151314 151315 151316ESTONIA 151317EE 151318EST 151319233 151320CTRY_ESTONIA 151321372 151322verEstonia 15132344 151324ETHIOPIA 151325ET 151326ETH 151327210 151328 151329 151330 151331 151332FALKLAND ISLANDS (MALVINAS) 151333FK 151334FLK 151335238 151336 151337 151338 151339 151340FAROE ISLANDS 151341FO 151342FRO 151343234 151344CTRY_FAEROE_ISLANDS 151345298 151346 151347 151348FIJI 151349FJ 151350FJI 151351242 151352 151353 151354 151355 151356FINLAND 151357FI 151358FIN 151359246 151360CTRY_FINLAND 151361358 151362verFinland 15136317 151364FRANCE 151365FR 151366FRA 151367250 151368CTRY_FRANCE 15136933 151370verFrance 1513711 151372FRANCE, METROPOLITAN 151373FX 151374FXX 151375249 151376 151377 151378 151379 151380FRENCH GUIANA 151381GF 151382GUF 151383254 151384 151385 151386 151387 151388FRENCH POLYNESIA 151389PF 151390PYF 151391258 151392 151393 151394 151395 151396FRENCH SOUTHERN TERRITORIES 151397TF 151398ATF 151399260 151400 151401 151402 151403 151404GABON 151405GA 151406GAB 151407266 151408 151409 151410 151411 151412GAMBIA 151413GM 151414GMB 151415270 151416 151417 151418 151419 151420GEORGIA 151421GE 151422GEO 151423268 151424CTRY_GEORGIA 151425995 151426verGeorgian 15142785 151428GERMANY 151429DE 151430DEU 151431276 151432CTRY_GERMANY 15143349 151434verGermany 1514353 151436GHANA 151437GH 151438GHA 151439288 151440 151441 151442 151443 151444GIBRALTAR 151445GI 151446GIB 151447292 151448 151449 151450 151451 151452GREECE 151453GR 151454GRC 151455300 151456CTRY_GREECE 15145730 151458verGreece, verGreecePoly 15145920, 40 151460GREENLAND 151461GL 151462GRL 151463304 151464 151465 151466verGreenland 151467107 151468GRENADA 151469GD 151470GRD 151471308 151472 151473 151474 151475 151476GUADELOUPE 151477GP 151478GLP 151479312 151480 151481 151482 151483 151484GUAM 151485GU 151486GUM 151487316 151488 151489 151490 151491 151492GUATEMALA 151493GT 151494GTM 151495320 151496CTRY_GUATEMALA 151497502 151498 151499 151500GUINEA 151501GN 151502GIN 151503324 151504 151505 151506 151507 151508GUINEA-BISSAU 151509GW 151510GNB 151511624 151512 151513 151514 151515 151516GUYANA 151517GY 151518GUY 151519328 151520 151521 151522 151523 151524HAITI 151525HT 151526HTI 151527332 151528 151529 151530 151531 151532HEARD ISLAND & MCDONALD ISLANDS 151533HM 151534HMD 151535334 151536 151537 151538 151539 151540HONDURAS 151541HN 151542HND 151543340 151544CTRY_HONDURAS 151545504 151546 151547 151548HONG KONG 151549HK 151550HKG 151551344 151552CTRY_HONG_KONG 151553852 151554 151555 151556HUNGARY 151557HU 151558HUN 151559348 151560CTRY_HUNGARY 15156136 151562verHungary 15156343 151564ICELAND 151565IS 151566ISL 151567352 151568CTRY_ICELAND 151569354 151570verIceland 15157121 151572INDIA 151573IN 151574IND 151575356 151576CTRY_INDIA 15157791 151578verIndiaHindi(hi) 15157933 151580INDONESIA 151581ID 151582IDN 151583360 151584CTRY_INDONESIA 15158562 151586 151587 151588IRAN, ISLAMIC REPUBLIC OF 151589IR 151590IRN 151591364 151592CTRY_IRAN 151593981 151594verIran 15159548 151596IRAQ 151597IQ 151598IRQ 151599368 151600CTRY_IRAQ 151601964 151602verArabic 15160316 151604IRELAND 151605IE 151606IRL 151607372 151608CTRY_IRELAND 151609353 151610verIreland 15161150 151612ISRAEL 151613IL 151614ISR 151615376 151616CTRY_ISRAEL 151617972 151618verIsrael 15161913 151620ITALY 151621IT 151622ITA 151623380 151624CTRY_ITALY 15162539 151626verItaly 1516274 151628JAMAICA 151629JM 151630JAM 151631388 151632CTRY_JAMAICA 1516331 151634 151635 151636JAPAN 151637JP 151638JPN 151639392 151640CTRY_JAPAN 15164181 151642verJapan 15164314 151644JORDAN 151645JO 151646JOR 151647400 151648CTRY_JORDAN 151649962 151650 151651 151652KAZAKHSTAN 151653KZ 151654KAZ 151655398 151656CTRY_KAZAKSTAN 1516577 151658 151659 151660KENYA 151661KE 151662KEN 151663404 151664CTRY_KENYA 151665254 151666 151667 151668KIRIBATI 151669KI 151670KIR 151671296 151672 151673 151674 151675 151676KOREA, DEMOCRATIC PEOPLE''S REPUBLIC OF 151677KP 151678PRK 151679408 151680 151681 151682verKorea 15168351 151684KOREA, REPUBLIC OF 151685KR 151686KOR 151687410 151688CTRY_SOUTH_KOREA 15168982 151690verKorea 151691 151692KUWAIT 151693KW 151694KWT 151695414 151696CTRY_KUWAIT 151697965 151698 151699 151700KYRGYZSTAN 151701KG 151702KGZ 151703417 151704CTRY_KYRGYZSTAN 151705996 151706 151707 151708LAO PEOPLE''S DEMOCRATIC REPUBLIC 151709LA 151710LAO 151711418 151712 151713 151714 151715 151716LATVIA 151717LV 151718LVA 151719428 151720CTRY_LATVIA 151721371 151722verLatvia 15172345 151724LEBANON 151725LB 151726LBN 151727422 151728CTRY_LEBANON 151729961 151730 151731 151732LESOTHO 151733LS 151734LSO 151735426 151736 151737 151738 151739 151740LIBERIA 151741LR 151742LBR 151743430 151744 151745 151746 151747 151748LIBYAN ARAB JAMAHIRIYA 151749LY 151750LBY 151751434 151752CTRY_LIBYA 151753218 151754verArabic 15175516 151756LIECHTENSTEIN 151757LI 151758LIE 151759438 151760CTRY_LIECHTENSTEIN 15176141 151762 151763 151764LITHUANIA 151765LT 151766LTU 151767440 151768CTRY_LITHUANIA 151769370 151770verLithuania 15177141 151772LUXEMBOURG 151773LU 151774LUX 151775442 151776CTRY_LUXEMBOURG 151777352 151778verFrBelgiumLux 1517796 151780MACAU 151781MO 151782MAC 151783446 151784CTRY_MACAU 151785853 151786 151787 151788MACEDONIA, THE FORMER YUGOSLAV REPUBLIC OF 151789MK 151790MKD 151791807 151792CTRY_MACEDONIA 151793389 151794verMacedonian 151795 151796MADAGASCAR 151797MG 151798MDG 151799450 151800 151801 151802 151803 151804MALAWI 151805MW 151806MWI 151807454 151808 151809 151810 151811 151812MALAYSIA 151813MY 151814MYS 151815458 151816CTRY_MALAYSIA 15181760 151818 151819 151820MALDIVES 151821MV 151822MDV 151823462 151824CTRY_MALDIVES 151825960 151826 151827 151828MALI 151829ML 151830MLI 151831466 151832 151833 151834 151835 151836MALTA 151837MT 151838MLT 151839470 151840 151841 151842verMalta 15184322 151844MARSHALL ISLANDS 151845MH 151846MHL 151847584 151848 151849 151850 151851 151852MARTINIQUE 151853MQ 151854MTQ 151855474 151856 151857 151858 151859 151860MAURITANIA 151861MR 151862MRT 151863478 151864 151865 151866 151867 151868MAURITIUS 151869MU 151870MUS 151871480 151872 151873 151874 151875 151876MAYOTTE 151877YT 151878MYT 151879175 151880 151881 151882 151883 151884MEXICO 151885MX 151886MEX 151887484 151888CTRY_MEXICO 15188952 151890 151891 151892MICRONESIA, FEDERATED STATES OF 151893FM 151894FSM 151895583 151896 151897 151898 151899 151900MOLDOVA, REPUBLIC OF 151901MD 151902MDA 151903498 151904 151905 151906 151907 151908MONACO 151909MC 151910MCO 151911492 151912CTRY_MONACO 15191333 151914 151915 151916MONGOLIA 151917MN 151918MNG 151919496 151920CTRY_MONGOLIA 151921976 151922 151923 151924MONTSERRAT 151925MS 151926MSR 151927500 151928 151929 151930 151931 151932MOROCCO 151933MA 151934MAR 151935504 151936CTRY_MOROCCO 151937212 151938verArabic 15193916 151940MOZAMBIQUE 151941MZ 151942MOZ 151943508 151944 151945 151946 151947 151948MYANMAR 151949MM 151950MMR 151951104 151952 151953 151954 151955 151956NAMIBIA 151957NA 151958NAM 151959516 151960 151961 151962 151963 151964NAURU 151965NR 151966NRU 151967520 151968 151969 151970 151971 151972NEPAL 151973NP 151974NPL 151975524 151976 151977 151978verNepal 151979106 151980NETHERLANDS 151981NL 151982NLD 151983528 151984CTRY_NETHERLANDS 15198531 151986verNetherlands 1519875 151988NETHERLANDS ANTILLES 151989AN 151990ANT 151991530 151992 151993 151994 151995 151996NEW CALEDONIA 151997NC 151998NCL 151999540 152000 152001 152002 152003 152004NEW ZEALAND 152005NZ 152006NZL 152007554 152008CTRY_NEW_ZEALAND 15200964 152010 152011 152012NICARAGUA 152013NI 152014NIC 152015558 152016CTRY_NICARAGUA 152017505 152018 152019 152020NIGER 152021NE 152022NER 152023562 152024 152025 152026 152027 152028NIGERIA 152029NG 152030NGA 152031566 152032 152033 152034 152035 152036NIUE 152037NU 152038NIU 152039570 152040 152041 152042 152043 152044NORFOLK ISLAND 152045NF 152046NFK 152047574 152048 152049 152050 152051 152052NORTHERN MARIANA ISLANDS 152053MP 152054MNP 152055580 152056 152057 152058 152059 152060NORWAY 152061NO 152062NOR 152063578 152064CTRY_NORWAY 15206547 152066verNorway 15206712 152068OMAN 152069OM 152070OMN 152071512 152072CTRY_OMAN 152073968 152074 152075 152076PAKISTAN 152077PK 152078PAK 152079586 152080CTRY_PAKISTAN 15208192 152082verPakistanUrdu, verPunjabi 15208334 (U), 95 (P) 152084PALAU 152085PW 152086PLW 152087585 152088 152089 152090 152091 152092PANAMA 152093PA 152094PAN 152095591 152096CTRY_PANAMA 152097507 152098 152099 152100PALESTINIAN TERRITORY, OCCUPIED 152101PS 152102 152103 152104 152105 152106 152107 152108PAPUA NEW GUINEA 152109PG 152110PNG 152111598 152112 152113 152114 152115 152116PARAGUAY 152117PY 152118PRY 152119600 152120CTRY_PARAGUAY 152121595 152122 152123 152124PERU 152125PE 152126PER 152127604 152128CTRY_PERU 15212951 152130 152131 152132PHILIPPINES 152133PH 152134PHL 152135608 152136CTRY_PHILIPPINES 15213763 152138 152139 152140PITCAIRN 152141PN 152142PCN 152143612 152144 152145 152146 152147 152148POLAND 152149PL 152150POL 152151616 152152CTRY_POLAND 15215348 152154verPoland 15215542 152156PORTUGAL 152157PT 152158PRT 152159620 152160CTRY_PORTUGAL 152161351 152162verPortugal 15216310 152164PUERTO RICO 152165PR 152166PRI 152167630 152168CTRY_PUERTO_RICO 1521691 152170 152171 152172QATAR 152173QA 152174QAT 152175634 152176CTRY_QATAR 152177974 152178 152179 152180REUNION 152181RE 152182REU 152183638 152184 152185 152186 152187 152188ROMANIA 152189RO 152190ROU* 152191642 152192CTRY_ROMANIA 15219340 152194verRomania 15219539 152196RUSSIAN FEDERATION 152197RU 152198RUS 152199643 152200CTRY_RUSSIA 1522017 152202verRussia 15220349 152204RWANDA 152205RW 152206RWA 152207646 152208 152209 152210 152211 152212SAINT KITTS AND NEVIS 152213KN 152214KNA 152215659 152216 152217 152218 152219 152220SAINT LUCIA 152221LC 152222LCA 152223662 152224 152225 152226 152227 152228SAINT VINCENT AND THE GRENADINES 152229VC 152230VCT 152231670 152232 152233 152234 152235 152236SAMOA 152237WS 152238WSM 152239882 152240 152241 152242 152243 152244SAN MARINO 152245SM 152246SMR 152247674 152248 152249 152250 152251 152252SAO TOME AND PRINCIPE 152253ST 152254STP 152255678 152256 152257 152258 152259 152260SAUDI ARABIA 152261SA 152262SAU 152263682 152264CTRY_SAUDI_ARABIA 152265966 152266verArabic 15226716 152268SENEGAL 152269SN 152270SEN 152271686 152272 152273 152274 152275 152276SERBIA AND MONTENEGRO 152277CS 152278 152279 152280CTRY_SERBIA 152281381 152282 152283 152284SEYCHELLES 152285SC 152286SYC 152287690 152288 152289 152290 152291 152292SIERRA LEONE 152293SL 152294SLE 152295694 152296 152297 152298 152299 152300SINGAPORE 152301SG 152302SGP 152303702 152304CTRY_SINGAPORE 15230565 152306verSingapore 152307100 152308SLOVAKIA (Slovak Republic) 152309SK 152310SVK 152311703 152312CTRY_SLOVAK 152313421 152314verSlovak 15231557 152316SLOVENIA 152317SI 152318SVN 152319705 152320CTRY_SLOVENIA 152321386 152322verSlovenian 15232366 152324SOLOMON ISLANDS 152325SB 152326SLB 15232790 152328 152329 152330 152331 152332SOMALIA 152333SO 152334SOM 152335706 152336 152337 152338 152339 152340SOUTH AFRICA 152341ZA 152342ZAF 152343710 152344CTRY_SOUTH_AFRICA 15234527 152346 152347 152348SOUTH GEORGIA AND THE SOUTH SANDWICH ISLANDS 152349GS 152350 152351 152352 152353 152354 152355 152356SPAIN 152357ES 152358ESP 152359724 152360CTRY_SPAIN 15236134 152362verSpain 1523638 152364SRI LANKA 152365LK 152366LKA 152367144 152368 152369 152370 152371 152372SAINT HELENA 152373SH 152374SHN 152375654 152376 152377 152378 152379 152380SAINT PIERRE AND MIQUELON 152381PM 152382SPM 152383666 152384 152385 152386 152387 152388SUDAN 152389SD 152390SDN 152391736 152392 152393 152394 152395 152396SURINAME 152397SR 152398SUR 152399740 152400 152401 152402 152403 152404SVALBARD AND JAN MAYEN ISLANDS 152405SJ 152406SJM 152407744 152408 152409 152410 152411 152412SWAZILAND 152413SZ 152414SWZ 152415748 152416 152417 152418 152419 152420SWEDEN 152421SE 152422SWE 152423752 152424CTRY_SWEDEN 15242546 152426verSweden 1524277 152428SWITZERLAND 152429CH 152430CHE 152431756 152432CTRY_SWITZERLAND 15243341 152434verFrSwiss(fr), verGrSwiss(de) 15243518(fr), 19(de) 152436SYRIAN ARAB REPUBLIC 152437SY 152438SYR 152439760 152440CTRY_SYRIA 152441963 152442 152443 152444TAIWAN, PROVINCE OF CHINA 152445TW 152446TWN 152447158 152448CTRY_TAIWAN 152449886 152450verTaiwan 15245153 152452TAJIKISTAN 152453TJ 152454TJK 152455762 152456 152457 152458 152459 152460TANZANIA, UNITED REPUBLIC OF 152461TZ 152462TZA 152463834 152464 152465 152466 152467 152468TATARSTAN 152469 152470 152471 152472CTRY_TATARSTAN 1524737 152474 152475 152476THAILAND 152477TH 152478THA 152479764 152480CTRY_THAILAND 15248166 152482verThailand 15248354 152484TIMOR-LESTE 152485TL 152486 152487 152488 152489 152490 152491 152492TOGO 152493TG 152494TGO 152495768 152496 152497 152498 152499 152500TOKELAU 152501TK 152502TKL 152503772 152504 152505 152506 152507 152508TONGA 152509TO 152510TON 152511776 152512 152513 152514verTonga 15251588 152516TRINIDAD AND TOBAGO 152517TT 152518TTO 152519780 152520CTRY_TRINIDAD_Y_TOBAGO 1525211 152522 152523 152524TUNISIA 152525TN 152526TUN 152527788 152528CTRY_TUNISIA 152529216 152530verArabic 15253116 152532TURKEY 152533TR 152534TUR 152535792 152536CTRY_TURKEY 15253790 152538verTurkey 15253924 152540TURKMENISTAN 152541TM 152542TKM 152543795 152544 152545 152546 152547 152548TURKS AND CAICOS ISLANDS 152549TC 152550TCA 152551796 152552 152553 152554 152555 152556TUVALU 152557TV 152558TUV 152559798 152560 152561 152562 152563 152564UGANDA 152565UG 152566UGA 152567800 152568 152569 152570 152571 152572UKRAINE 152573UA 152574UKR 152575804 152576CTRY_UKRAINE 152577380 152578verUkraine 15257962 152580UNITED ARAB EMIRATES 152581AE 152582ARE 152583784 152584CTRY_UAE 152585971 152586 152587 152588UNITED KINGDOM 152589GB 152590GBR 152591826 152592CTRY_UNITED_KINGDOM 15259344 152594verBritain 1525952 152596UNITED STATES 152597US 152598USA 152599840 152600CTRY_UNITED_STATES 1526011 152602verUS 1526030 152604UNITED STATES MINOR OUTLYING ISLANDS 152605UM 152606UMI 152607581 152608 152609 152610 152611 152612URUGUAY 152613UY 152614URY 152615858 152616CTRY_URUGUAY 152617598 152618 152619 152620UZBEKISTAN 152621UZ 152622UZB 152623860 152624CTRY_UZBEKISTAN 1526257 152626 152627 152628VANUATU 152629VU 152630VUT 152631548 152632 152633 152634 152635 152636VATICAN CITY STATE (HOLY SEE) 152637VA 152638VAT 152639336 152640 152641 152642 152643 152644VENEZUELA 152645VE 152646VEN 152647862 152648CTRY_VENEZUELA 15264958 152650 152651 152652VIET NAM 152653VN 152654VNM 152655704 152656CTRY_VIET_NAM 15265784 152658verVietnam 152659 152660VIRGIN ISLANDS (BRITISH) 152661VG 152662VGB 15266392 152664 152665 152666 152667 152668VIRGIN ISLANDS (U.S.) 152669VI 152670VIR 152671850 152672 152673 152674 152675 152676WALLIS AND FUTUNA ISLANDS 152677WF 152678WLF 152679876 152680 152681 152682 152683 152684WESTERN SAHARA 152685EH 152686ESH 152687732 152688 152689 152690 152691 152692YEMEN 152693YE 152694YEM 152695887 152696CTRY_YEMEN 152697967 152698 152699 152700YUGOSLAVIA 152701YU 152702YUG 152703891 152704 152705 152706 152707 152708ZAIRE 152709ZR 152710ZAR 152711180 152712 152713 152714 152715 152716ZAMBIA 152717ZM 152718ZMB 152719894 152720 152721 152722 152723 152724ZIMBABWE 152725ZW 152726ZWE 152727716 152728CTRY_ZIMBABWE 152729263 152730 152731 152732'! ! 152733 152734!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:18'! 152735iso3Countries 152736 "ISOLanguageDefinition iso3Countries" 152737 "ISO2Countries := nil. ISO3Countries := nil" 152738 152739 ISO3Countries ifNil: [self initISOCountries]. 152740 ^ISO3Countries! ! 152741 152742!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/21/2004 13:10'! 152743iso3LanguageTable 152744 "ISOLanguageDefinition iso3LanguageTable" 152745 152746 ^ISO3Table ifNil: [ISO3Table := self initISO3LanguageTable]! ! 152747 152748!ISOLanguageDefinition class methodsFor: 'private' stamp: 'yo 12/3/2004 17:46'! 152749isoLanguages 152750 "ISO 639: 3-letter codes" 152751 ^'abk ab Abkhazian 152752ace Achinese 152753ach Acoli 152754ada Adangme 152755aar aa Afar 152756afh Afrihili 152757afr af Afrikaans 152758afa Afro-Asiatic (Other) 152759aka Akan 152760akk Akkadian 152761alb/sqi sq Albanian 152762ale Aleut 152763alg Algonquian languages 152764tut Altaic (Other) 152765amh am Amharic 152766apa Apache languages 152767ara ar Arabic 152768arc Aramaic 152769arp Arapaho 152770arn Araucanian 152771arw Arawak 152772arm/hye hy Armenian 152773art Artificial (Other) 152774asm as Assamese 152775ath Athapascan languages 152776map Austronesian (Other) 152777ava Avaric 152778ave Avestan 152779awa Awadhi 152780aym ay Aymara 152781aze az Azerbaijani 152782nah Aztec 152783ban Balinese 152784bat Baltic (Other) 152785bal Baluchi 152786bam Bambara 152787bai Bamileke languages 152788bad Banda 152789bnt Bantu (Other) 152790bas Basa 152791bak ba Bashkir 152792baq/eus eu Basque 152793bej Beja 152794bem Bemba 152795ben bn Bengali 152796ber Berber (Other) 152797bho Bhojpuri 152798bih bh Bihari 152799bik Bikol 152800bin Bini 152801bis bi Bislama 152802bra Braj 152803bre be Breton 152804bug Buginese 152805bul bg Bulgarian 152806bua Buriat 152807bur/mya my Burmese 152808bel be Byelorussian 152809cad Caddo 152810car Carib 152811cat ca Catalan 152812cau Caucasian (Other) 152813ceb Cebuano 152814cel Celtic (Other) 152815cai Central American Indian (Other) 152816chg Chagatai 152817cha Chamorro 152818che Chechen 152819chr Cherokee 152820chy Cheyenne 152821chb Chibcha 152822chi/zho zh Chinese 152823chn Chinook jargon 152824cho Choctaw 152825chu Church Slavic 152826chv Chuvash 152827cop Coptic 152828cor Cornish 152829cos co Corsican 152830cre Cree 152831mus Creek 152832crp Creoles and Pidgins (Other) 152833cpe Creoles and Pidgins, English-based (Other) 152834cpf Creoles and Pidgins, French-based (Other) 152835cpp Creoles and Pidgins, Portuguese-based (Other) 152836cus Cushitic (Other) 152837 hr Croatian 152838ces/cze cs Czech 152839dak Dakota 152840dan da Danish 152841del Delaware 152842din Dinka 152843div Divehi 152844doi Dogri 152845dra Dravidian (Other) 152846dua Duala 152847dut/nla nl Dutch 152848dum Dutch, Middle (ca. 1050-1350) 152849dyu Dyula 152850dzo dz Dzongkha 152851efi Efik 152852egy Egyptian (Ancient) 152853eka Ekajuk 152854elx Elamite 152855eng en English 152856enm English, Middle (ca. 1100-1500) 152857ang English, Old (ca. 450-1100) 152858esk Eskimo (Other) 152859epo eo Esperanto 152860est et Estonian 152861ewe Ewe 152862ewo Ewondo 152863fan Fang 152864fat Fanti 152865fao fo Faroese 152866fij fj Fijian 152867fin fi Finnish 152868fiu Finno-Ugrian (Other) 152869fon Fon 152870fra/fre fr French 152871frm French, Middle (ca. 1400-1600) 152872fro French, Old (842- ca. 1400) 152873fry fy Frisian 152874ful Fulah 152875gaa Ga 152876gae/gdh Gaelic (Scots) 152877glg gl Gallegan 152878lug Ganda 152879gay Gayo 152880gez Geez 152881geo/kat ka Georgian 152882deu/ger de German 152883gmh German, Middle High (ca. 1050-1500) 152884goh German, Old High (ca. 750-1050) 152885gem Germanic (Other) 152886gil Gilbertese 152887gon Gondi 152888got Gothic 152889grb Grebo 152890grc Greek, Ancient (to 1453) 152891ell/gre el Greek, Modern (1453-) 152892kal kl Greenlandic 152893grn gn Guarani 152894guj gu Gujarati 152895hai Haida 152896hau ha Hausa 152897haw Hawaiian 152898heb he Hebrew 152899her Herero 152900hil Hiligaynon 152901him Himachali 152902hin hi Hindi 152903hmo Hiri Motu 152904hun hu Hungarian 152905hup Hupa 152906iba Iban 152907ice/isl is Icelandic 152908ibo Igbo 152909ijo Ijo 152910ilo Iloko 152911inc Indic (Other) 152912ine Indo-European (Other) 152913ind id Indonesian 152914ina ia Interlingua (International Auxiliary language Association) 152915ine Interlingue 152916iku iu Inuktitut 152917ipk ik Inupiak 152918ira Iranian (Other) 152919gai/iri ga Irish 152920sga Irish, Old (to 900) 152921mga Irish, Middle (900 - 1200) 152922iro Iroquoian languages 152923ita it Italian 152924jpn ja Japanese 152925jav/jaw jv/jw Javanese 152926jrb Judeo-Arabic 152927jpr Judeo-Persian 152928kab Kabyle 152929kac Kachin 152930kam Kamba 152931kan kn Kannada 152932kau Kanuri 152933kaa Kara-Kalpak 152934kar Karen 152935kas ks Kashmiri 152936kaw Kawi 152937kaz kk Kazakh 152938kha Khasi 152939khm km Khmer 152940khi Khoisan (Other) 152941kho Khotanese 152942kik Kikuyu 152943kin rw Kinyarwanda 152944kir ky Kirghiz 152945kom Komi 152946kon Kongo 152947kok Konkani 152948kor ko Korean 152949kpe Kpelle 152950kro Kru 152951kua Kuanyama 152952kum Kumyk 152953kur ku Kurdish 152954kru Kurukh 152955kus Kusaie 152956kut Kutenai 152957lad Ladino 152958lah Lahnda 152959lam Lamba 152960oci oc Langue d''Oc (post 1500) 152961lao lo Lao 152962lat la Latin 152963lav lv Latvian 152964ltz Letzeburgesch 152965lez Lezghian 152966lin ln Lingala 152967lit lt Lithuanian 152968loz Lozi 152969lub Luba-Katanga 152970lui Luiseno 152971lun Lunda 152972luo Luo (Kenya and Tanzania) 152973mac/mak mk Macedonian 152974mad Madurese 152975mag Magahi 152976mai Maithili 152977mak Makasar 152978mlg mg Malagasy 152979may/msa ms Malay 152980mal Malayalam 152981mlt ml Maltese 152982man Mandingo 152983mni Manipuri 152984mno Manobo languages 152985max Manx 152986mao/mri mi Maori 152987mar mr Marathi 152988chm Mari 152989mah Marshall 152990mwr Marwari 152991mas Masai 152992myn Mayan languages 152993men Mende 152994mic Micmac 152995min Minangkabau 152996mis Miscellaneous (Other) 152997moh Mohawk 152998mol mo Moldavian 152999mkh Mon-Kmer (Other) 153000lol Mongo 153001mon mn Mongolian 153002mos Mossi 153003mul Multiple languages 153004mun Munda languages 153005nau na Nauru 153006nav Navajo 153007nde Ndebele, North 153008nbl Ndebele, South 153009ndo Ndongo 153010nep ne Nepali 153011new Newari 153012nic Niger-Kordofanian (Other) 153013ssa Nilo-Saharan (Other) 153014niu Niuean 153015non Norse, Old 153016nai North American Indian (Other) 153017nor no Norwegian 153018nno Norwegian (Nynorsk) 153019nub Nubian languages 153020nym Nyamwezi 153021nya Nyanja 153022nyn Nyankole 153023nyo Nyoro 153024nzi Nzima 153025oji Ojibwa 153026ori or Oriya 153027orm om Oromo 153028osa Osage 153029oss Ossetic 153030oto Otomian languages 153031pal Pahlavi 153032pau Palauan 153033pli Pali 153034pam Pampanga 153035pag Pangasinan 153036pan pa Panjabi 153037pap Papiamento 153038paa Papuan-Australian (Other) 153039fas/per fa Persian 153040peo Persian, Old (ca 600 - 400 B.C.) 153041phn Phoenician 153042pol pl Polish 153043pon Ponape 153044por pt Portuguese 153045pra Prakrit languages 153046pro Provencal, Old (to 1500) 153047pus ps Pushto 153048que qu Quechua 153049roh rm Rhaeto-Romance 153050raj Rajasthani 153051rar Rarotongan 153052roa Romance (Other) 153053ron/rum ro Romanian 153054rom Romany 153055run rn Rundi 153056rus ru Russian 153057sal Salishan languages 153058sam Samaritan Aramaic 153059smi Sami languages 153060smo sm Samoan 153061sad Sandawe 153062sag sg Sango 153063san sa Sanskrit 153064srd Sardinian 153065sco Scots 153066sel Selkup 153067sem Semitic (Other) 153068 sr Serbian 153069scr sh Serbo-Croatian 153070srr Serer 153071shn Shan 153072sna sn Shona 153073sid Sidamo 153074bla Siksika 153075snd sd Sindhi 153076sin si Singhalese 153077sit Sino-Tibetan (Other) 153078sio Siouan languages 153079sla Slavic (Other) 153080ssw ss Siswant 153081slk/slo sk Slovak 153082slv sl Slovenian 153083sog Sogdian 153084som so Somali 153085son Songhai 153086wen Sorbian languages 153087nso Sotho, Northern 153088sot st Sotho, Southern 153089sai South American Indian (Other) 153090esl/spa es Spanish 153091suk Sukuma 153092sux Sumerian 153093sun su Sudanese 153094sus Susu 153095swa sw Swahili 153096ssw Swazi 153097sve/swe sv Swedish 153098syr Syriac 153099tgl tl Tagalog 153100tah Tahitian 153101tgk tg Tajik 153102tmh Tamashek 153103tam ta Tamil 153104tat tt Tatar 153105tel te Telugu 153106ter Tereno 153107tha th Thai 153108bod/tib bo Tibetan 153109tig Tigre 153110tir ti Tigrinya 153111tem Timne 153112tiv Tivi 153113tli Tlingit 153114tog to Tonga (Nyasa) 153115ton Tonga (Tonga Islands) 153116tru Truk 153117tsi Tsimshian 153118tso ts Tsonga 153119tsn tn Tswana 153120tum Tumbuka 153121tur tr Turkish 153122ota Turkish, Ottoman (1500 - 1928) 153123tuk tk Turkmen 153124tyv Tuvinian 153125twi tw Twi 153126uga Ugaritic 153127uig ug Uighur 153128ukr uk Ukrainian 153129umb Umbundu 153130und Undetermined 153131urd ur Urdu 153132uzb uz Uzbek 153133vai Vai 153134ven Venda 153135vie vi Vietnamese 153136vol vo Volapük 153137vot Votic 153138wak Wakashan languages 153139wal Walamo 153140war Waray 153141was Washo 153142cym/wel cy Welsh 153143wol wo Wolof 153144xho xh Xhosa 153145sah Yakut 153146yao Yao 153147yap Yap 153148yid yi Yiddish 153149yor yo Yoruba 153150zap Zapotec 153151zen Zenaga 153152zha za Zhuang 153153zul zu Zulu 153154zun Zuni'! ! 153155 153156!ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/1/2004 18:07'! 153157readISOLanguagesFrom: stream 153158 "ISOLanguageDefinition readISOLanguagesFrom: ISOLanguageDefinition isoLanguages readStream " 153159 | languages language code3 index line | 153160 languages := Dictionary new. 153161 [stream atEnd 153162 or: [(line := stream nextLine readStream) atEnd]] 153163 whileFalse: [ 153164 language := ISOLanguageDefinition new. 153165 code3 := line upTo: Character tab. 153166 (index := code3 indexOf: $/) > 0 153167 ifTrue: [ 153168 language iso3: (code3 copyFrom: 1 to: index-1). 153169 language iso3Alternate: (code3 copyFrom: index+1 to: code3 size)] 153170 ifFalse: [language iso3: code3]. 153171 language 153172 iso2: (line upTo: Character tab); 153173 language: line upToEnd. 153174 languages at: language iso3 put: language]. 153175 ^languages! ! 153176TestCase subclass: #IVsAndClassVarNamesConflictTest 153177 instanceVariableNames: 'class className' 153178 classVariableNames: '' 153179 poolDictionaries: '' 153180 category: 'KernelTests-Classes'! 153181 153182!IVsAndClassVarNamesConflictTest methodsFor: 'setup' stamp: 'oscar.nierstrasz 10/18/2009 17:11'! 153183setUp 153184 super setUp. 153185 className := #ClassForTestToBeDeleted.! ! 153186 153187!IVsAndClassVarNamesConflictTest methodsFor: 'setup' stamp: 'oscar.nierstrasz 10/18/2009 17:11'! 153188tearDown 153189 | cl | 153190 super tearDown. 153191 cl := Smalltalk at: className ifAbsent: [^self]. 153192 cl removeFromChanges; removeFromSystemUnlogged 153193 ! ! 153194 153195 153196!IVsAndClassVarNamesConflictTest methodsFor: 'tests' stamp: 'Noury 10/26/2008 18:40'! 153197testOneCanProceedWhenIntroducingCapitalizedInstanceVariables 153198 self shouldnt: [ 153199 [Object subclass: className 153200 instanceVariableNames: 'X Y' 153201 classVariableNames: '' 153202 poolDictionaries: '' 153203 category: self class category] on: Exception do: [:ex| ex resume] 153204 ] raise: Exception. 153205 self assert: (Smalltalk keys includes: className) 153206! ! 153207 153208!IVsAndClassVarNamesConflictTest methodsFor: 'tests' stamp: 'adrian_lienhard 3/7/2009 17:54'! 153209testOneCanProceedWhenIntroducingClasseVariablesBeginingWithLowerCaseCharacters 153210 self shouldnt: [ 153211 [Object subclass: className 153212 instanceVariableNames: '' 153213 classVariableNames: 'a BVariableName' 153214 poolDictionaries: '' 153215 category: self class category] on: Exception do: [:ex| ex resume] 153216 ] raise: Exception. 153217 self assert: (Smalltalk keys includes: className) 153218! ! 153219SimpleButtonMorph subclass: #IconicButton 153220 instanceVariableNames: '' 153221 classVariableNames: '' 153222 poolDictionaries: '' 153223 category: 'Morphic-Widgets'! 153224!IconicButton commentStamp: '<historical>' prior: 0! 153225A "Simple Button" in which the appearance is provided by a Form.! 153226 153227 153228!IconicButton methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/29/2007 10:55'! 153229handlesMouseOver: anEvent 153230 "Answer true, otherwise what is all that 153231 #mouseEnter:/#mouseLeave: stuff about?" 153232 153233 ^true! ! 153234 153235!IconicButton methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/21/2008 13:03'! 153236mouseDown: evt 153237 "Partial workaraound for broken MouseOverHandler. 153238 Remove the border on mouse down if mouse focus has changed." 153239 153240 super mouseDown: evt. 153241 (actWhen == #buttonDown and: [(evt hand mouseFocus = self) not]) 153242 ifTrue: [self mouseLeave: evt]! ! 153243 153244!IconicButton methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/23/2008 17:19'! 153245mouseOverBorderStyle 153246 "Answer the border style to use whilst the mouse 153247 is over the receiver." 153248 153249 ^self valueOfProperty: #mouseOverBorderStyle ifAbsent: [BorderStyle thinGray]! ! 153250 153251!IconicButton methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/23/2008 17:19'! 153252mouseOverBorderStyle: aBorderStyle 153253 "Set the border style to use whilst the mouse 153254 is over the receiver." 153255 153256 self setProperty: #mouseOverBorderStyle toValue: aBorderStyle! ! 153257 153258 153259!IconicButton methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2007 15:34'! 153260labelGraphic: aForm 153261 "Changed to look for any image morph rather than just a sketch." 153262 153263 | oldLabel graphicalMorph | 153264 (oldLabel := self findA: ImageMorph) 153265 ifNotNil: [oldLabel delete]. 153266 graphicalMorph := ImageMorph new image: aForm. 153267 self extent: graphicalMorph extent + (self borderWidth + 6). 153268 graphicalMorph position: self center - (graphicalMorph extent // 2). 153269 self addMorph: graphicalMorph. 153270 graphicalMorph lock 153271! ! 153272 153273!IconicButton methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/23/2008 17:20'! 153274mouseEnter: evt 153275 "Remember the old border style." 153276 153277 (self hasProperty: #oldBorder) ifFalse: [ 153278 self setProperty: #oldBorder toValue: self borderStyle]. 153279 self borderStyle: self mouseOverBorderStyle! ! 153280 153281!IconicButton methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/6/2007 13:19'! 153282mouseLeave: evt 153283 "Reinstate the old border style." 153284 153285 (self valueOfProperty: #oldBorder) 153286 ifNotNilDo: [:b | 153287 self borderStyle: b. 153288 self removeProperty: #oldBorder] 153289 ifNil: [self borderNormal]! ! 153290 153291 153292!IconicButton methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:38'! 153293borderInset 153294 self borderStyle: (BorderStyle inset width: 2).! ! 153295 153296!IconicButton methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:41'! 153297borderRaised 153298 self borderStyle: (BorderStyle raised width: 2).! ! 153299 153300 153301!IconicButton methodsFor: 'as yet unclassified' stamp: 'sw 9/28/1999 14:11'! 153302labelFromString: aString 153303 "Make an iconic label from aString" 153304 153305 self labelGraphic: (StringMorph contents: aString) imageForm 153306! ! 153307 153308!IconicButton methodsFor: 'as yet unclassified' stamp: 'sw 11/29/1999 20:56'! 153309shedSelvedge 153310 self extent: (self extent - (6@6))! ! 153311 153312 153313!IconicButton methodsFor: 'initialization' stamp: 'ar 12/12/2001 01:38'! 153314borderNormal 153315 self borderStyle: (BorderStyle width: 2 color: Color transparent).! ! 153316 153317!IconicButton methodsFor: 'initialization' stamp: 'ar 12/17/2001 21:17'! 153318borderThick 153319 self borderStyle: (BorderStyle width: 2 color: self raisedColor twiceDarker).! ! 153320 153321!IconicButton methodsFor: 'initialization' stamp: 'ar 12/15/2001 14:43'! 153322buttonSetup 153323 self actWhen: #buttonUp. 153324 self cornerStyle: #rounded. 153325 self borderNormal. 153326 self on: #mouseEnter send: #borderRaised to: self. 153327 self on: #mouseLeave send: #borderNormal to: self. 153328 self on: #mouseLeaveDragging send: #borderNormal to: self. 153329 self on: #mouseDown send: #borderInset to: self. 153330 self on: #mouseUp send: #borderRaised to: self.! ! 153331 153332!IconicButton methodsFor: 'initialization' stamp: 'sw 11/29/1999 20:52'! 153333initialize 153334 super initialize. 153335 self useSquareCorners! ! 153336 153337!IconicButton methodsFor: 'initialization' stamp: 'nk 9/7/2004 11:43'! 153338initializeWithThumbnail: aThumbnail withLabel: aLabel andColor: aColor andSend: aSelector to: aReceiver 153339 "Initialize the receiver to show aThumbnail on its face, giving it the label supplied and arranging for it, when the button goes down on it, to obtain a new morph by sending the supplied selector to the supplied receiver" 153340 153341 | labeledItem nonTranslucent | 153342 nonTranslucent := aColor asNontranslucentColor. 153343 labeledItem := AlignmentMorph newColumn. 153344 labeledItem color: nonTranslucent. 153345 labeledItem borderWidth: 0. 153346 labeledItem 153347 layoutInset: 4@0; 153348 cellPositioning: #center. 153349 labeledItem addMorph: aThumbnail. 153350 labeledItem addMorphBack: (Morph new extent: (4@4)) beTransparent. 153351 labeledItem addMorphBack: (TextMorph new 153352 backgroundColor: nonTranslucent; 153353 contentsAsIs: aLabel; 153354 beAllFont: Preferences standardEToysFont; 153355 centered). 153356 153357 self 153358 beTransparent; 153359 labelGraphic: ((labeledItem imageForm: 32 backgroundColor: nonTranslucent forRectangle: labeledItem fullBounds) replaceColor: nonTranslucent withColor: Color transparent); 153360 borderWidth: 0; 153361 target: aReceiver; 153362 actionSelector: #launchPartVia:label:; 153363 arguments: {aSelector. aLabel}; 153364 actWhen: #buttonDown. 153365 153366 self stationarySetup.! ! 153367 153368!IconicButton methodsFor: 'initialization' stamp: 'nk 8/6/2004 11:34'! 153369initializeWithThumbnail: aThumbnail withLabel: aLabel andSend: aSelector to: aReceiver 153370 "Initialize the receiver to show aThumbnail on its face, giving it the label supplied and arranging for it, when the button goes down on it, to obtain a new morph by sending the supplied selector to the supplied receiver" 153371 153372 ^self initializeWithThumbnail: aThumbnail withLabel: aLabel andColor: Color transparent andSend: aSelector to: aReceiver ! ! 153373 153374!IconicButton methodsFor: 'initialization' stamp: 'sw 9/28/1999 18:38'! 153375setDefaultLabel 153376 self labelGraphic: (ScriptingSystem formAtKey: 'squeakyMouse')! ! 153377 153378!IconicButton methodsFor: 'initialization' stamp: 'ar 12/18/2001 21:22'! 153379stationarySetup 153380 153381 self actWhen: #startDrag. 153382 self cornerStyle: #rounded. 153383 self borderNormal. 153384 self on: #mouseEnter send: #borderThick to: self. 153385 self on: #mouseDown send: nil to: nil. 153386 self on: #mouseLeave send: #borderNormal to: self. 153387 self on: #mouseLeaveDragging send: #borderNormal to: self. 153388 self on: #mouseUp send: #borderThick to: self.! ! 153389 153390 153391!IconicButton methodsFor: 'menu' stamp: 'sw 9/28/1999 20:42'! 153392addLabelItemsTo: aCustomMenu hand: aHandMorph 153393 "don't do the inherited behavior, since there is no textual label in this case"! ! 153394Bag subclass: #IdentityBag 153395 instanceVariableNames: '' 153396 classVariableNames: '' 153397 poolDictionaries: '' 153398 category: 'Collections-Unordered'! 153399!IdentityBag commentStamp: '<historical>' prior: 0! 153400Like a Bag, except that items are compared with #== instead of #= . 153401 153402See the comment of IdentitySet for more information. 153403! 153404]style[(88 11 23)f3,f3LIdentitySet Comment;,f3! 153405 153406 153407"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 153408 153409IdentityBag class 153410 instanceVariableNames: ''! 153411 153412!IdentityBag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:53'! 153413contentsClass 153414 ^IdentityDictionary! ! 153415BagTest subclass: #IdentityBagTest 153416 instanceVariableNames: 'equalNotIdenticalElement elementToCopy identityBagNonEmptyNoDuplicate5Elements elementAlreadyIncluded identityBagWithoutElement' 153417 classVariableNames: '' 153418 poolDictionaries: '' 153419 category: 'CollectionsTests-Unordered'! 153420 153421!IdentityBagTest methodsFor: 'requirements' stamp: 'delaunay 4/30/2009 11:20'! 153422elementToCopy 153423 ^ elementToCopy ifNil: [ elementToCopy := 'element to copy' ]! ! 153424 153425!IdentityBagTest methodsFor: 'requirements' stamp: 'delaunay 4/30/2009 11:20'! 153426equalNotIdenticalElement 153427 ^ equalNotIdenticalElement ifNil: [ equalNotIdenticalElement := self elementToCopy copy ]! ! 153428 153429!IdentityBagTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:02'! 153430identityCollectionWithElementsCopyNotIdentical 153431"Returns a collection including elements for which #copy doesn't return the same object." 153432 ^ identityBagNonEmptyNoDuplicate5Elements ifNil: [ 153433 identityBagNonEmptyNoDuplicate5Elements := IdentityBag new add: 2.5 ; add: 1.5 ;add: 5.5 ; yourself ]! ! 153434 153435!IdentityBagTest methodsFor: 'requirements' stamp: 'damienpollet 1/9/2009 18:28'! 153436speciesClass 153437 ^ IdentityBag! ! 153438 153439 153440!IdentityBagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! 153441testIdentity 153442 "self run:#testIdentity" 153443 "self debug:#testIdentity" 153444 | bag identityBag aString anOtherString | 153445 153446 aString := 'hello'. 153447 anOtherString := aString copy. 153448 153449 self assert: (aString = anOtherString). 153450 self assert: (aString == anOtherString) not. 153451 153452 bag := Bag new. 153453 bag add: aString. 153454 bag add: aString. 153455 bag add: anOtherString. 153456 self assert: (bag occurrencesOf: aString) = 3. 153457 self assert: (bag occurrencesOf: anOtherString) = 3. 153458 153459 identityBag := IdentityBag new. 153460 identityBag add: aString. 153461 identityBag add: aString. 153462 identityBag add: anOtherString. 153463 153464 self assert: (identityBag occurrencesOf: aString) = 2. 153465 self assert: (identityBag occurrencesOf: anOtherString) = 1. 153466 153467 153468 153469! ! 153470 153471 153472!IdentityBagTest methodsFor: 'tests - converting' stamp: 'delaunay 4/30/2009 12:02'! 153473testAsSetWithEqualsElements 153474 | t1 | 153475 t1 := self withEqualElements asSet. 153476 self withEqualElements 153477 do: [:t2 | self assert: (t1 occurrencesOf: t2) 153478 = 1]. 153479 self assert: t1 class = IdentitySet! ! 153480 153481 153482!IdentityBagTest methodsFor: 'tests - identity adding' stamp: 'delaunay 4/30/2009 11:19'! 153483testIdentityAdd 153484 | added oldSize | 153485 oldSize := self collection size. 153486 self collection add: self elementToCopy . 153487 self deny: (self collection includes: self equalNotIdenticalElement). 153488 153489 added := self collection add: self equalNotIdenticalElement. 153490 self assert: added == self equalNotIdenticalElement. 153491 self assert: (self collection includes: self equalNotIdenticalElement)! ! 153492Dictionary subclass: #IdentityDictionary 153493 instanceVariableNames: '' 153494 classVariableNames: '' 153495 poolDictionaries: '' 153496 category: 'Collections-Unordered'! 153497!IdentityDictionary commentStamp: 'ls 06/15/02 22:35' prior: 0! 153498Like a Dictionary, except that keys are compared with #== instead of #= . 153499 153500See the comment of IdentitySet for more information.! 153501]style[(94 11 22)f1,f1LIdentitySet Comment;,f1! 153502 153503 153504!IdentityDictionary methodsFor: 'private' stamp: 'RAA 1/10/2001 14:57'! 153505fasterKeys 153506 "This was taking some time in publishing and we didn't really need a Set" 153507 | answer index | 153508 answer := Array new: self size. 153509 index := 0. 153510 self keysDo: [:key | answer at: (index := index + 1) put: key]. 153511 ^ answer! ! 153512 153513!IdentityDictionary methodsFor: 'private' stamp: 'di 12/1/1999 20:54'! 153514keyAtValue: value ifAbsent: exceptionBlock 153515 "Answer the key that is the external name for the argument, value. If 153516 there is none, answer the result of evaluating exceptionBlock." 153517 153518 self associationsDo: 153519 [:association | value == association value ifTrue: [^ association key]]. 153520 ^ exceptionBlock value! ! 153521 153522!IdentityDictionary methodsFor: 'private' stamp: 'md 1/21/2006 20:04'! 153523keys 153524 "Answer a Set containing the receiver's keys." 153525 | aSet | 153526 aSet := IdentitySet new: self size. 153527 self keysDo: [:key | aSet add: key]. 153528 ^ aSet! ! 153529 153530!IdentityDictionary methodsFor: 'private' stamp: 'md 10/5/2005 15:41'! 153531scanFor: anObject 153532 "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 153533 | finish hash start element | 153534 finish := array size. 153535 finish > 4096 153536 ifTrue: [hash := anObject identityHash * (finish // 4096)] 153537 ifFalse: [hash := anObject identityHash]. 153538 start := (hash \\ finish) + 1. 153539 153540 "Search from (hash mod size) to the end." 153541 start to: finish do: 153542 [:index | ((element := array at: index) == nil or: [element key == anObject]) 153543 ifTrue: [^ index ]]. 153544 153545 "Search from 1 to where we started." 153546 1 to: start-1 do: 153547 [:index | ((element := array at: index) == nil or: [element key == anObject]) 153548 ifTrue: [^ index ]]. 153549 153550 ^ 0 "No match AND no empty slot"! ! 153551DictionaryTest subclass: #IdentityDictionaryTest 153552 instanceVariableNames: '' 153553 classVariableNames: '' 153554 poolDictionaries: '' 153555 category: 'CollectionsTests-Unordered'! 153556 153557!IdentityDictionaryTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 11:41'! 153558classToBeTested 153559 153560 ^ IdentityDictionary! ! 153561 153562 153563!IdentityDictionaryTest methodsFor: 'tests - identity' stamp: 'cyrille.delaunay 6/29/2009 13:21'! 153564testIdentity 153565 | dict key | 153566 dict := self classToBeTested new. 153567 key := 'key'. 153568 dict at: key put: 2.5. 153569 153570 153571 self assert: (dict includesKey: key). 153572 self deny: (dict includesKey: key copy). 153573 153574" dict at: 1 put: 'djdh'. 153575 dict at: 'sksl' put: 1.0. 153576 self deny: (dict includesKey: 1.0) . 153577 self assert: (dict includes: 1)" 153578! ! 153579 153580"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 153581 153582IdentityDictionaryTest class 153583 instanceVariableNames: ''! 153584 153585!IdentityDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 11:41'! 153586shouldInheritSelectors 153587 153588^true! ! 153589Object subclass: #IdentityGlyphMap 153590 instanceVariableNames: '' 153591 classVariableNames: '' 153592 poolDictionaries: '' 153593 category: 'Graphics-Fonts'! 153594 153595!IdentityGlyphMap methodsFor: 'as yet unclassified' stamp: 'yo 2/13/2004 04:07'! 153596at: index 153597 153598 ^ index - 1. 153599! ! 153600Set subclass: #IdentitySet 153601 instanceVariableNames: '' 153602 classVariableNames: '' 153603 poolDictionaries: '' 153604 category: 'Collections-Unordered'! 153605!IdentitySet commentStamp: 'sw 1/14/2003 22:35' prior: 0! 153606The same as a Set, except that items are compared using #== instead of #=. 153607 153608Almost any class named IdentityFoo is the same as Foo except for the way items are compared. In Foo, #= is used, while in IdentityFoo, #== is used. That is, identity collections will treat items as the same only if they have the same identity. 153609 153610For example, note that copies of a string are equal: 153611 153612 ('abc' copy) = ('abc' copy) 153613 153614but they are not identitcal: 153615 153616 ('abc' copy) == ('abc' copy) 153617 153618A regular Set will only include equal objects once: 153619 153620 | aSet | 153621 aSet := Set new. 153622 aSet add: 'abc' copy. 153623 aSet add: 'abc' copy. 153624 aSet 153625 153626 153627An IdentitySet will include multiple equal objects if they are not identical: 153628 153629 | aSet | 153630 aSet := IdentitySet new. 153631 aSet add: 'abc' copy. 153632 aSet add: 'abc' copy. 153633 aSet 153634! 153635 153636 153637!IdentitySet methodsFor: 'converting' stamp: 'ar 9/22/2000 10:13'! 153638asIdentitySet 153639 ^self! ! 153640 153641 153642!IdentitySet methodsFor: 'private' stamp: 'md 10/5/2005 15:42'! 153643scanFor: anObject 153644 "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 153645 | finish hash start element | 153646 finish := array size. 153647 finish > 4096 153648 ifTrue: [hash := anObject identityHash * (finish // 4096)] 153649 ifFalse: [hash := anObject identityHash]. 153650 start := (hash \\ finish) + 1. 153651 153652 "Search from (hash mod size) to the end." 153653 start to: finish do: 153654 [:index | ((element := array at: index) == nil or: [element == anObject]) 153655 ifTrue: [^ index ]]. 153656 153657 "Search from 1 to where we started." 153658 1 to: start-1 do: 153659 [:index | ((element := array at: index) == nil or: [element == anObject]) 153660 ifTrue: [^ index ]]. 153661 153662 ^ 0 "No match AND no empty slot"! ! 153663SetTest subclass: #IdentitySetTest 153664 instanceVariableNames: 'floatCollection' 153665 classVariableNames: '' 153666 poolDictionaries: '' 153667 category: 'CollectionsTests-Unordered'! 153668 153669!IdentitySetTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 10:58'! 153670classToBeTested 153671 153672^ IdentitySet! ! 153673 153674!IdentitySetTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:05'! 153675identityCollectionWithElementsCopyNotIdentical 153676" return a collection including elements for which #copy return a new object " 153677 ^ floatCollection ifNil: [ floatCollection := IdentitySet new add: 2.5 ; add: 4.5 ; add:5.5 ; yourself ].! ! 153678 153679 153680!IdentitySetTest methodsFor: 'tests - identity' stamp: 'cyrille.delaunay 6/29/2009 11:18'! 153681testIdentity 153682 "self run:#testIdentity" 153683 "self debug:#testIdentity" 153684 | identitySet aString anOtherString | 153685 153686 aString := 'hello'. 153687 anOtherString := aString copy. 153688 153689 self assert: (aString = anOtherString). 153690 self assert: (aString == anOtherString) not. 153691 153692 153693 identitySet := self classToBeTested new. 153694 identitySet add: aString. 153695 153696 153697 self assert: (identitySet occurrencesOf: aString) = 1. 153698 self assert: (identitySet occurrencesOf: anOtherString) = 0. 153699 153700 153701 self assert: (identitySet includes: aString). 153702 self deny: (identitySet includes: anOtherString) = 0.! ! 153703 153704"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 153705 153706IdentitySetTest class 153707 instanceVariableNames: ''! 153708 153709!IdentitySetTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 10:51'! 153710shouldInheritSelectors 153711 153712^true! ! 153713DisplayTransform subclass: #IdentityTransform 153714 instanceVariableNames: '' 153715 classVariableNames: 'Default' 153716 poolDictionaries: '' 153717 category: 'Graphics-Transformations'! 153718 153719!IdentityTransform methodsFor: 'accessing' stamp: 'di 9/29/2000 09:04'! 153720angle 153721 ^ 0.0! ! 153722 153723!IdentityTransform methodsFor: 'accessing' stamp: 'ar 9/11/2000 21:18'! 153724inverseTransformation 153725 "Return the inverse transformation of the receiver" 153726 ^self! ! 153727 153728!IdentityTransform methodsFor: 'accessing' stamp: 'ar 4/19/2001 06:01'! 153729offset 153730 ^0@0! ! 153731 153732 153733!IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:27'! 153734composedWith: aTransform 153735 ^aTransform! ! 153736 153737!IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:19'! 153738composedWithGlobal: aTransformation 153739 ^aTransformation! ! 153740 153741!IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:19'! 153742composedWithLocal: aTransformation 153743 ^aTransformation! ! 153744 153745 153746!IdentityTransform methodsFor: 'converting' stamp: 'ar 9/11/2000 21:21'! 153747asMatrixTransform2x3 153748 "Represent the receiver as a 2x3 matrix transformation" 153749 ^MatrixTransform2x3 identity! ! 153750 153751 153752!IdentityTransform methodsFor: 'initialize' stamp: 'ar 9/11/2000 21:18'! 153753setIdentity 153754 "I *am* the identity transform" 153755 ^self! ! 153756 153757 153758!IdentityTransform methodsFor: 'testing' stamp: 'ar 9/11/2000 21:18'! 153759isIdentity 153760 "Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself." 153761 ^true! ! 153762 153763!IdentityTransform methodsFor: 'testing' stamp: 'ar 9/11/2000 21:19'! 153764isPureTranslation 153765 "Return true if the receiver specifies no rotation or scaling." 153766 ^true! ! 153767 153768 153769!IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:19'! 153770globalPointToLocal: aPoint 153771 "Transform aPoint from global coordinates into local coordinates" 153772 ^aPoint! ! 153773 153774!IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:20'! 153775globalPointsToLocal: inArray 153776 "Transform all the points of inArray from global into local coordinates" 153777 ^inArray! ! 153778 153779!IdentityTransform methodsFor: 'transforming points' stamp: 'gh 10/22/2001 13:24'! 153780invertBoundsRect: aRectangle 153781 "Return a rectangle whose coordinates have been transformed 153782 from local back to global coordinates. Since I am the identity matrix 153783 no transformation is made." 153784 153785 ^aRectangle 153786! ! 153787 153788!IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:20'! 153789localPointToGlobal: aPoint 153790 "Transform aPoint from local coordinates into global coordinates" 153791 ^aPoint! ! 153792 153793!IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:20'! 153794localPointsToGlobal: inArray 153795 "Transform all the points of inArray from local into global coordinates" 153796 ^inArray! ! 153797 153798 153799!IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:20'! 153800globalBoundsToLocal: aRectangle 153801 "Transform aRectangle from global coordinates into local coordinates" 153802 ^aRectangle! ! 153803 153804!IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:20'! 153805localBoundsToGlobal: aRectangle 153806 "Transform aRectangle from local coordinates into global coordinates" 153807 ^aRectangle! ! 153808 153809!IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:21'! 153810sourceQuadFor: aRectangle 153811 ^ aRectangle innerCorners! ! 153812 153813"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 153814 153815IdentityTransform class 153816 instanceVariableNames: ''! 153817 153818!IdentityTransform class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 153819initialize 153820 "IdentityTransform initialize" 153821 Default := self basicNew! ! 153822 153823 153824!IdentityTransform class methodsFor: 'instance creation' stamp: 'ar 9/11/2000 21:24'! 153825new 153826 "There can be only one" 153827 ^Default! ! 153828TestCase subclass: #IfNotNilTests 153829 instanceVariableNames: '' 153830 classVariableNames: '' 153831 poolDictionaries: '' 153832 category: 'Tests-Compiler'! 153833 153834!IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:43'! 153835testIfNilIfNotNil0Arg 153836 153837 self assert: (5 ifNil: [#foo] ifNotNil: [#bar]) = #bar. 153838 self assert: (nil ifNil: [#foo] ifNotNil: [#bar]) = #foo! ! 153839 153840!IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:43'! 153841testIfNilIfNotNil0ArgAsVar 153842 153843 | block1 block2 | 153844 block1 := [#foo]. 153845 block2 := [#bar]. 153846 self assert: (5 ifNil: block1 ifNotNil: block2) = #bar. 153847 self assert: (nil ifNil: block1 ifNotNil: block2) = #foo! ! 153848 153849!IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/15/2007 12:25'! 153850testIfNilIfNotNil1Arg 153851 153852 self assert: (5 ifNil: [#foo] ifNotNil: [:a | a printString]) = '5'. 153853 self assert: (nil ifNil: [#foo] ifNotNil: [:a | a printString]) = #foo! ! 153854 153855!IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:33'! 153856testIfNilIfNotNil1ArgAsVar 153857 153858 | block1 block2 | 153859 block1 := [#foo]. 153860 block2 := [:a | a printString]. 153861 self assert: (5 ifNil: block1 ifNotNil: block2) = '5'. 153862 self assert: (nil ifNil: block1 ifNotNil: block2) = #foo! ! 153863 153864!IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/15/2007 12:14'! 153865testIfNotNil0Arg 153866 153867 self assert: (5 ifNotNil: [#foo]) = #foo. 153868 self assert: (nil ifNotNil: [#foo]) = nil! ! 153869 153870!IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:30'! 153871testIfNotNil0ArgAsVar 153872 153873 | block | 153874 block := [#foo]. 153875 self assert: (5 ifNotNil: block) = #foo. 153876 self assert: (nil ifNotNil: block) = nil! ! 153877 153878!IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/15/2007 12:15'! 153879testIfNotNil1Arg 153880 153881 self assert: (5 ifNotNil: [:a | a printString]) = '5'. 153882 self assert: (nil ifNotNil: [:a | a printString]) = nil! ! 153883 153884!IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:31'! 153885testIfNotNil1ArgAsVar 153886 153887 | block | 153888 block := [:a | a printString]. 153889 self assert: (5 ifNotNil: block) = '5'. 153890 self assert: (nil ifNotNil: block) = nil! ! 153891 153892!IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:35'! 153893testIfNotNilIfNil0Arg 153894 153895 self assert: (5 ifNotNil: [#foo] ifNil: [#bar]) = #foo. 153896 self assert: (nil ifNotNil: [#foo] ifNil: [#bar]) = #bar! ! 153897 153898!IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:36'! 153899testIfNotNilIfNil0ArgAsVar 153900 153901 | block1 block2 | 153902 block1 := [#foo]. 153903 block2 := [#bar]. 153904 self assert: (5 ifNotNil: block2 ifNil: block1) = #bar. 153905 self assert: (nil ifNotNil: block2 ifNil: block1) = #foo! ! 153906 153907!IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:35'! 153908testIfNotNilIfNil1Arg 153909 153910 self assert: (5 ifNotNil: [:a | a printString] ifNil: [#foo]) = '5'. 153911 self assert: (nil ifNotNil: [:a | a printString] ifNil: [#foo]) = #foo! ! 153912 153913!IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:36'! 153914testIfNotNilIfNil1ArgAsVar 153915 153916 | block1 block2 | 153917 block1 := [#foo]. 153918 block2 := [:a | a printString]. 153919 self assert: (5 ifNotNil: block2 ifNil: block1) = '5'. 153920 self assert: (nil ifNotNil: block2 ifNil: block1) = #foo! ! 153921Exception subclass: #IllegalResumeAttempt 153922 instanceVariableNames: '' 153923 classVariableNames: '' 153924 poolDictionaries: '' 153925 category: 'Exceptions-Kernel'! 153926!IllegalResumeAttempt commentStamp: '<historical>' prior: 0! 153927This class is private to the EHS implementation. An instance of it is signaled whenever an attempt is made to resume from an exception which answers false to #isResumable.! 153928 153929 153930!IllegalResumeAttempt methodsFor: 'comment' stamp: 'ajh 9/4/2002 19:24'! 153931defaultAction 153932 "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" 153933 153934 UnhandledError signalForException: self! ! 153935 153936!IllegalResumeAttempt methodsFor: 'comment' stamp: 'ajh 2/1/2003 00:57'! 153937isResumable 153938 153939 ^ false! ! 153940 153941!IllegalResumeAttempt methodsFor: 'comment' stamp: 'tfei 6/2/1999 14:59'! 153942readMe 153943 153944 "Never handle this exception!!"! ! 153945Error subclass: #IllegalURIException 153946 instanceVariableNames: 'uriString' 153947 classVariableNames: '' 153948 poolDictionaries: '' 153949 category: 'Network-URI'! 153950 153951!IllegalURIException methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:21'! 153952uriString 153953 ^uriString! ! 153954 153955!IllegalURIException methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:20'! 153956uriString: aString 153957 uriString := aString! ! 153958OrientedFillStyle subclass: #ImageFillStyle 153959 instanceVariableNames: 'form extent offset' 153960 classVariableNames: '' 153961 poolDictionaries: '' 153962 category: 'Polymorph-Widgets-FillStyles'! 153963!ImageFillStyle commentStamp: 'gvc 9/23/2008 11:55' prior: 0! 153964Simple fillstyle that draws a (potentially translucent) form at the specified origin. Direction and normal are unused.! 153965 153966 153967!ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 10/3/2008 11:57'! 153968extent 153969 "Answer the value of extent" 153970 153971 ^ extent! ! 153972 153973!ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 10/3/2008 11:57'! 153974extent: anObject 153975 "Set the value of extent" 153976 153977 extent := anObject! ! 153978 153979!ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 3/26/2008 19:18'! 153980form 153981 "Answer the value of form" 153982 153983 ^ form! ! 153984 153985!ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:51'! 153986form: aForm 153987 "Set the value of form" 153988 153989 form := aForm. 153990 self direction: aForm extent! ! 153991 153992!ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 1/28/2009 17:40'! 153993offset 153994 "Answer the value of offset" 153995 153996 ^ offset! ! 153997 153998!ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 1/28/2009 17:40'! 153999offset: anObject 154000 "Set the value of offset" 154001 154002 offset := anObject! ! 154003 154004 154005!ImageFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 18:54'! 154006= anOrientedFillStyle 154007 "Answer whether equal." 154008 154009 ^super = anOrientedFillStyle 154010 and: [self form = anOrientedFillStyle form]! ! 154011 154012!ImageFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/26/2008 19:19'! 154013asColor 154014 "Answer the colour of the first pixel." 154015 154016 ^form colorAt: 0@0! ! 154017 154018!ImageFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 1/28/2009 17:40'! 154019fillRectangle: aRectangle on: aCanvas 154020 "Fill the given rectangle on the given canvas with the receiver." 154021 154022 self extent 154023 ifNil: [aCanvas 154024 translucentImage: self form 154025 at: self origin] 154026 ifNotNil: [aCanvas clipBy: (self origin + self offset extent: self extent) during: [:c | 154027 c 154028 translucentImage: self form 154029 at: self origin]]! ! 154030 154031!ImageFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 18:53'! 154032hash 154033 "Hash is implemented because #= is implemented." 154034 154035 ^super hash bitXor: self form hash! ! 154036 154037 154038!ImageFillStyle methodsFor: 'initialize-release' stamp: 'gvc 1/28/2009 17:40'! 154039initialize 154040 "Initialize the receiver." 154041 154042 super initialize. 154043 self 154044 origin: 0@0; 154045 offset: 0@0! ! 154046 154047"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 154048 154049ImageFillStyle class 154050 instanceVariableNames: ''! 154051 154052!ImageFillStyle class methodsFor: 'as yet unclassified' stamp: 'gvc 3/26/2008 19:17'! 154053form: aForm 154054 "Answer a new instance of the receiver with the given form." 154055 154056 ^self new form: aForm! ! 154057Morph subclass: #ImageMorph 154058 instanceVariableNames: 'image' 154059 classVariableNames: 'DefaultForm' 154060 poolDictionaries: '' 154061 category: 'Morphic-Basic'! 154062!ImageMorph commentStamp: 'efc 3/7/2003 17:48' prior: 0! 154063ImageMorph is a morph that displays a picture (Form). My extent is determined by the extent of my form. 154064 154065Use #image: to set my picture. 154066 154067Structure: 154068 instance var Type Description 154069 image Form The Form to use when drawing 154070 154071Code examples: 154072 ImageMorph new openInWorld; grabFromScreen 154073 154074 (Form fromFileNamed: 'myGraphicsFileName') asMorph openInWorld 154075 154076Relationship to SketchMorph: ImageMorph should be favored over SketchMorph, a parallel, legacy class -- see the Swiki FAQ for details ( http://minnow.cc.gatech.edu/squeak/1372 ). 154077! 154078]style[(10 37 4 97 33 11 5 47 42 3 62 18 11 109 39 5)f1LImageMorph Hierarchy;,f1,f1LForm Comment;,f1,f1i,f1,f1LForm Comment;,f1,f1dImageMorph new openInWorld; grabFromScreen;;,f1,f1d(Form fromFileNamed: 'myGraphicsFileName') asMorph openInWorld;;,f1,f1LSketchMorph Comment;,f1,f1Rhttp://minnow.cc.gatech.edu/squeak/1372;,f1! 154079 154080 154081!ImageMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/25/2006 15:45'! 154082adoptPaneColor: paneColor 154083 "Change our border color too." 154084 154085 super adoptPaneColor: paneColor. 154086 paneColor ifNil: [^self]. 154087 self borderStyle baseColor: paneColor twiceDarker! ! 154088 154089 154090!ImageMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/27/2009 11:56'! 154091borderStyle: newStyle 154092 "Set the extent to include border width." 154093 154094 | newExtent | 154095 self borderStyle = newStyle ifTrue: [^self]. 154096 newExtent := 2 * newStyle width + image extent. 154097 bounds extent = newExtent ifFalse: [super extent: newExtent]. 154098 super borderStyle: newStyle! ! 154099 154100!ImageMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/27/2009 16:10'! 154101color: aColor 154102 "Set the color. 154103 Change to a ColorForm here if depth 1." 154104 154105 super color: aColor. 154106 (image depth == 1 and: [aColor isColor]) ifTrue: [ 154107 image isColorForm ifFalse: [ 154108 image := ColorForm mappingWhiteToTransparentFrom: image]. 154109 image colors: {Color transparent. aColor}. 154110 self changed]! ! 154111 154112!ImageMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/18/2007 11:52'! 154113drawOn: aCanvas 154114 "Draw the border after the image." 154115 154116 | style | 154117 self isOpaque 154118 ifTrue:[aCanvas drawImage: image at: self innerBounds origin] 154119 ifFalse:[aCanvas translucentImage: image at: self innerBounds origin]. 154120 (style := self borderStyle) ifNotNil:[ 154121 style frameRectangle: bounds on: aCanvas]! ! 154122 154123!ImageMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/27/2009 16:11'! 154124image: anImage 154125 "Fixed to take account of border width. 154126 Use raw image, only change depth 1 forms to 154127 ColorForm with transparency if #color: is sent." 154128 154129 image := anImage. 154130 super extent: 2 * self borderWidth + image extent. 154131 self changed! ! 154132 154133 154134!ImageMorph methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:11'! 154135borderWidth: bw 154136 | newExtent | 154137 newExtent := 2 * bw + image extent. 154138 bounds extent = newExtent ifFalse:[super extent: newExtent]. 154139 super borderWidth: bw! ! 154140 154141!ImageMorph methodsFor: 'accessing'! 154142form 154143 "For compatability with SketchMorph." 154144 154145 ^ image 154146! ! 154147 154148!ImageMorph methodsFor: 'accessing' stamp: 'jm 9/27/97 20:16'! 154149image 154150 154151 ^ image 154152! ! 154153 154154!ImageMorph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 20:01'! 154155isOpaque 154156 "Return true if the receiver is marked as being completely opaque" 154157 ^ self 154158 valueOfProperty: #isOpaque 154159 ifAbsent: [false]! ! 154160 154161!ImageMorph methodsFor: 'accessing' stamp: 'ar 11/7/2000 14:57'! 154162isOpaque: aBool 154163 "Mark the receiver as being completely opaque or not" 154164 aBool == false 154165 ifTrue:[self removeProperty: #isOpaque] 154166 ifFalse:[self setProperty: #isOpaque toValue: aBool]. 154167 self changed! ! 154168 154169!ImageMorph methodsFor: 'accessing' stamp: 'marcus.denker 2/23/2009 10:12'! 154170setNewImageFrom: formOrNil 154171 "Change the receiver's image to be one derived from the supplied form. If nil is supplied, clobber any existing image in the receiver, and in its place put a default graphic, either the one known to the receiver as its default value, else a squeaky mouse" 154172 154173 | defaultImage | 154174 formOrNil ifNotNil: [^ self image: formOrNil]. 154175 defaultImage := ScriptingSystem squeakyMouseForm. 154176 self image: defaultImage 154177! ! 154178 154179!ImageMorph methodsFor: 'accessing' stamp: 'wiz 4/7/2004 15:10'! 154180withSnapshotBorder 154181 self borderStyle: ((ComplexBorder style: #complexFramed) 154182 color: (Color 154183 r: 0.613 154184 g: 1.0 154185 b: 0.516); 154186 width: 1; 154187 154188 yourself)! ! 154189 154190 154191!ImageMorph methodsFor: 'as yet unclassified' stamp: 'marcus.denker 9/14/2008 21:10'! 154192wantsRecolorHandle 154193 ^ image notNil 154194 and: [image depth == 1]! ! 154195 154196 154197!ImageMorph methodsFor: 'caching'! 154198releaseCachedState 154199 154200 super releaseCachedState. 154201 image hibernate. 154202! ! 154203 154204 154205!ImageMorph methodsFor: 'geometry'! 154206extent: aPoint 154207 "Do nothing; my extent is determined by my image Form." 154208! ! 154209 154210 154211!ImageMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:36'! 154212defaultImage 154213 "Answer the default image for the receiver." 154214 154215 ^ DefaultForm! ! 154216 154217!ImageMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:36'! 154218initialize 154219 154220 super initialize. 154221 self image: self defaultImage. 154222! ! 154223 154224 154225!ImageMorph methodsFor: 'menu' stamp: 'ar 11/7/2000 14:57'! 154226changeOpacity 154227 self isOpaque: self isOpaque not! ! 154228 154229!ImageMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:46'! 154230opacityString 154231 ^ (self isOpaque 154232 ifTrue: ['<on>'] 154233 ifFalse: ['<off>']), 'opaque' translated! ! 154234 154235 154236!ImageMorph methodsFor: 'menu commands'! 154237grabFromScreen 154238 154239 self image: Form fromUser. 154240! ! 154241 154242!ImageMorph methodsFor: 'menu commands' stamp: 'DamienCassou 9/29/2009 12:58'! 154243readFromFile 154244 | fileName | 154245 fileName := UIManager default 154246 request: 'Please enter the image file name' translated 154247 initialAnswer: 'fileName'. 154248 fileName isEmptyOrNil ifTrue: [^ self]. 154249 self image: (Form fromFileNamed: fileName). 154250! ! 154251 154252 154253!ImageMorph methodsFor: 'menus' stamp: 'ar 11/7/2000 14:55'! 154254addCustomMenuItems: aMenu hand: aHand 154255 super addCustomMenuItems: aMenu hand: aHand. 154256 aMenu addUpdating: #opacityString action: #changeOpacity! ! 154257 154258 154259!ImageMorph methodsFor: 'other' stamp: 'sw 12/17/1998 12:11'! 154260newForm: aForm 154261 self image: aForm! ! 154262 154263 154264!ImageMorph methodsFor: 'parts bin' stamp: 'sw 6/28/2001 11:32'! 154265initializeToStandAlone 154266 154267 super initializeToStandAlone. 154268 self image: DefaultForm. 154269! ! 154270 154271 154272!ImageMorph methodsFor: 'testing' stamp: 'tk 11/1/2001 12:43'! 154273basicType 154274 "Answer a symbol representing the inherent type I hold" 154275 154276 "Number String Boolean player collection sound color etc" 154277 ^ #Image! ! 154278 154279"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 154280 154281ImageMorph class 154282 instanceVariableNames: ''! 154283 154284!ImageMorph class methodsFor: 'accessing' stamp: 'ar 6/25/1999 11:59'! 154285defaultForm 154286 ^DefaultForm! ! 154287 154288 154289!ImageMorph class methodsFor: 'initialization' stamp: 'asm 4/10/2003 13:09'! 154290initialize 154291 "ImageMorph initialize" 154292 154293 | h p d | 154294 DefaultForm := (Form extent: 80@40 depth: 16). 154295 h := DefaultForm height // 2. 154296 0 to: h - 1 do: [:i | 154297 p := (i * 2)@i. 154298 d := i asFloat / h asFloat. 154299 DefaultForm fill: 154300 (p corner: DefaultForm extent - p) 154301 fillColor: (Color r: d g: 0.5 b: 1.0 - d)]. 154302 154303 self registerInFlapsRegistry.! ! 154304 154305!ImageMorph class methodsFor: 'initialization' stamp: 'asm 4/10/2003 13:10'! 154306registerInFlapsRegistry 154307 "Register the receiver in the system's flaps registry" 154308 self environment 154309 at: #Flaps 154310 ifPresent: [:cl | cl registerQuad: #(ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something') 154311 forFlapNamed: 'Supplies']! ! 154312 154313!ImageMorph class methodsFor: 'initialization' stamp: 'asm 4/11/2003 12:36'! 154314unload 154315 "Unload the receiver from global registries" 154316 154317 self environment at: #Flaps ifPresent: [:cl | 154318 cl unregisterQuadsWithReceiver: self] ! ! 154319 154320 154321!ImageMorph class methodsFor: 'instance creation' stamp: 'sw 10/23/2000 18:21'! 154322fromString: aString 154323 "Create a new ImageMorph which displays the input string in the standard button font" 154324 154325 ^ self fromString: aString font: Preferences standardButtonFont! ! 154326 154327!ImageMorph class methodsFor: 'instance creation' stamp: 'sw 10/23/2000 18:21'! 154328fromString: aString font: aFont 154329 "Create a new ImageMorph showing the given string in the given font" 154330 154331 ^ self new image: (StringMorph contents: aString font: aFont) imageForm! ! 154332 154333 154334!ImageMorph class methodsFor: 'scripting' stamp: 'sw 5/19/1998 18:30'! 154335authoringPrototype 154336 | aMorph aForm | 154337 aMorph := super authoringPrototype. 154338 aForm := ScriptingSystem formAtKey: 'Image'. 154339 aForm ifNil: [aForm := aMorph image rotateBy: 90]. 154340 aMorph image: aForm. 154341 ^ aMorph! ! 154342Morph subclass: #ImagePreviewMorph 154343 instanceVariableNames: 'imageMorph textMorph defaultImageForm' 154344 classVariableNames: '' 154345 poolDictionaries: '' 154346 category: 'Polymorph-Widgets'! 154347!ImagePreviewMorph commentStamp: 'gvc 5/18/2007 12:51' prior: 0! 154348Displays an image scaled to a fixed size along with a label describing the original dimensions.! 154349 154350 154351!ImagePreviewMorph methodsFor: 'accessing' stamp: 'gvc 10/9/2006 14:25'! 154352imageMorph 154353 "Answer the value of imageMorph" 154354 154355 ^ imageMorph! ! 154356 154357!ImagePreviewMorph methodsFor: 'accessing' stamp: 'gvc 10/9/2006 14:25'! 154358imageMorph: anObject 154359 "Set the value of imageMorph" 154360 154361 imageMorph := anObject! ! 154362 154363!ImagePreviewMorph methodsFor: 'accessing' stamp: 'gvc 10/9/2006 14:25'! 154364textMorph 154365 "Answer the value of textMorph" 154366 154367 ^ textMorph! ! 154368 154369!ImagePreviewMorph methodsFor: 'accessing' stamp: 'gvc 10/9/2006 14:25'! 154370textMorph: anObject 154371 "Set the value of textMorph" 154372 154373 textMorph := anObject! ! 154374 154375 154376!ImagePreviewMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2006 14:33'! 154377cornerStyle: aSymbol 154378 "Pass on to selector and content too." 154379 154380 super cornerStyle: aSymbol. 154381 self imageMorph cornerStyle: aSymbol! ! 154382 154383!ImagePreviewMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:59'! 154384defaultImageFormOfSize: aPoint 154385 "Answer a default preview image form." 154386 154387 ^(defaultImageForm isNil or: [defaultImageForm extent ~= aPoint]) 154388 ifTrue: [defaultImageForm := Form extent: aPoint] 154389 ifFalse: [defaultImageForm]! ! 154390 154391!ImagePreviewMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 12:38'! 154392image: form size: imageSize 154393 "Set the image and update the description." 154394 154395 form 154396 ifNil: [self imageMorph 154397 image: (self defaultImageFormOfSize: imageSize). 154398 self textMorph 154399 contents: ''] 154400 ifNotNil: [self imageMorph 154401 image: form 154402 size: imageSize. 154403 self textMorph 154404 contents: ('{1} x {2} pixels' translated 154405 format: {form width asString. form height asString})] 154406 ! ! 154407 154408!ImagePreviewMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2006 14:42'! 154409initialize 154410 "Initialize the receiver." 154411 154412 super initialize. 154413 self 154414 changeTableLayout; 154415 color: Color transparent; 154416 hResizing: #shrinkWrap; 154417 vResizing: #shrinkWrap; 154418 cellInset: 16; 154419 imageMorph: self newImageMorph; 154420 textMorph: self newTextMorph; 154421 addMorphBack: self imageMorph; 154422 addMorphBack: self textMorph! ! 154423 154424!ImagePreviewMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2006 14:42'! 154425newImageMorph 154426 "Answer a new image morph." 154427 154428 ^AlphaImageMorph new 154429 borderStyle: (BorderStyle inset width: 1); 154430 color: Color white; 154431 alpha: 1.0! ! 154432 154433!ImagePreviewMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2006 14:34'! 154434newTextMorph 154435 "Answer a new text morph." 154436 154437 ^StringMorph contents: ''! ! 154438Object subclass: #ImageReadWriter 154439 instanceVariableNames: 'stream' 154440 classVariableNames: 'ImageNotStoredSignal MagicNumberErrorSignal' 154441 poolDictionaries: '' 154442 category: 'Graphics-Files'! 154443!ImageReadWriter commentStamp: '<historical>' prior: 0! 154444Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved. 154445 154446I am an abstract class to provide for encoding and/or decoding an image on a stream. 154447 154448Instance Variables: 154449 stream <ReadStream | WriteStream> stream for image storages 154450 154451Class Variables: 154452 ImageNotStoredSignal <Signal> image not stored error signal 154453 MagicNumberErrorSignal <Signal> magic number error signal 154454 154455Subclasses must implement the following messages: 154456 accessing 154457 nextImage 154458 nextPutImage: 154459 testing 154460 canUnderstand (added tao 10/26/97)! 154461 154462 154463!ImageReadWriter methodsFor: 'accessing'! 154464nextImage 154465 "Dencoding an image on stream and answer the image." 154466 154467 ^self subclassResponsibility! ! 154468 154469!ImageReadWriter methodsFor: 'accessing'! 154470nextPutImage: anImage 154471 "Encoding anImage on stream." 154472 154473 ^self subclassResponsibility! ! 154474 154475 154476!ImageReadWriter methodsFor: 'stream access'! 154477atEnd 154478 154479 ^stream atEnd! ! 154480 154481!ImageReadWriter methodsFor: 'stream access' stamp: 'sd 1/30/2004 15:18'! 154482close 154483 154484 stream close! ! 154485 154486!ImageReadWriter methodsFor: 'stream access'! 154487contents 154488 154489 ^stream contents! ! 154490 154491!ImageReadWriter methodsFor: 'stream access'! 154492cr 154493 154494 ^stream nextPut: Character cr asInteger! ! 154495 154496!ImageReadWriter methodsFor: 'stream access'! 154497lf 154498 "PPM and PBM are used LF as CR." 154499 154500 ^stream nextPut: Character lf asInteger! ! 154501 154502!ImageReadWriter methodsFor: 'stream access'! 154503next 154504 154505 ^stream next! ! 154506 154507!ImageReadWriter methodsFor: 'stream access'! 154508next: size 154509 154510 ^stream next: size! ! 154511 154512!ImageReadWriter methodsFor: 'stream access'! 154513nextLong 154514 "Read a 32-bit quantity from the input stream." 154515 154516 ^(stream next bitShift: 24) + (stream next bitShift: 16) + 154517 (stream next bitShift: 8) + stream next! ! 154518 154519!ImageReadWriter methodsFor: 'stream access'! 154520nextLongPut: a32BitW 154521 "Write out a 32-bit integer as 32 bits." 154522 154523 stream nextPut: ((a32BitW bitShift: -24) bitAnd: 16rFF). 154524 stream nextPut: ((a32BitW bitShift: -16) bitAnd: 16rFF). 154525 stream nextPut: ((a32BitW bitShift: -8) bitAnd: 16rFF). 154526 stream nextPut: (a32BitW bitAnd: 16rFF). 154527 ^a32BitW! ! 154528 154529!ImageReadWriter methodsFor: 'stream access'! 154530nextPut: aByte 154531 154532 ^stream nextPut: aByte! ! 154533 154534!ImageReadWriter methodsFor: 'stream access'! 154535nextPutAll: aByteArray 154536 154537 ^stream nextPutAll: aByteArray! ! 154538 154539!ImageReadWriter methodsFor: 'stream access'! 154540nextWord 154541 "Read a 16-bit quantity from the input stream." 154542 154543 ^(stream next bitShift: 8) + stream next! ! 154544 154545!ImageReadWriter methodsFor: 'stream access'! 154546nextWordPut: a16BitW 154547 "Write out a 16-bit integer as 16 bits." 154548 154549 stream nextPut: ((a16BitW bitShift: -8) bitAnd: 16rFF). 154550 stream nextPut: (a16BitW bitAnd: 16rFF). 154551 ^a16BitW! ! 154552 154553!ImageReadWriter methodsFor: 'stream access' stamp: 'tao 10/23/97 18:00'! 154554peekFor: aValue 154555 154556 ^stream peekFor: aValue! ! 154557 154558!ImageReadWriter methodsFor: 'stream access'! 154559position 154560 154561 ^stream position! ! 154562 154563!ImageReadWriter methodsFor: 'stream access'! 154564position: anInteger 154565 154566 ^stream position: anInteger! ! 154567 154568!ImageReadWriter methodsFor: 'stream access'! 154569size 154570 154571 ^stream size! ! 154572 154573!ImageReadWriter methodsFor: 'stream access'! 154574skip: anInteger 154575 154576 ^stream skip: anInteger! ! 154577 154578!ImageReadWriter methodsFor: 'stream access'! 154579space 154580 154581 ^stream nextPut: Character space asInteger! ! 154582 154583!ImageReadWriter methodsFor: 'stream access'! 154584tab 154585 154586 ^stream nextPut: Character tab asInteger! ! 154587 154588 154589!ImageReadWriter methodsFor: 'testing' stamp: 'tao 10/27/97 09:26'! 154590understandsImageFormat 154591 "Test to see if the image stream format is understood by this decoder. 154592 This should be implemented in each subclass of ImageReadWriter so that 154593 a proper decoder can be selected without ImageReadWriter having to know 154594 about all possible image file types." 154595 154596 ^ false! ! 154597 154598 154599!ImageReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 154600changePadOfBits: bits width: width height: height depth: depth from: oldPad to: newPad 154601 "Change padding size of bits." 154602 | srcRowByteSize dstRowByteSize newBits srcRowBase rowEndOffset | 154603 (#(8 16 32 ) includes: oldPad) ifFalse: [ ^ self error: 'Invalid pad: ' , oldPad printString ]. 154604 (#(8 16 32 ) includes: newPad) ifFalse: [ ^ self error: 'Invalid pad: ' , newPad printString ]. 154605 srcRowByteSize := (width * depth + oldPad - 1) // oldPad * (oldPad / 8). 154606 srcRowByteSize * height = bits size ifFalse: [ ^ self error: 'Incorrect bitmap array size.' ]. 154607 dstRowByteSize := (width * depth + newPad - 1) // newPad * (newPad / 8). 154608 newBits := ByteArray new: dstRowByteSize * height. 154609 srcRowBase := 1. 154610 rowEndOffset := dstRowByteSize - 1. 154611 1 154612 to: newBits size 154613 by: dstRowByteSize 154614 do: 154615 [ :dstRowBase | 154616 newBits 154617 replaceFrom: dstRowBase 154618 to: dstRowBase + rowEndOffset 154619 with: bits 154620 startingAt: srcRowBase. 154621 srcRowBase := srcRowBase + srcRowByteSize ]. 154622 ^ newBits! ! 154623 154624!ImageReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 154625hasMagicNumber: aByteArray 154626 | position | 154627 position := stream position. 154628 (stream size - position >= aByteArray size and: [ (stream next: aByteArray size) = aByteArray ]) ifTrue: [ ^ true ]. 154629 stream position: position. 154630 ^ false! ! 154631 154632!ImageReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 154633on: aStream 154634 (stream := aStream) reset. 154635 stream binary 154636 "Note that 'reset' makes a file be text. Must do this after."! ! 154637 154638!ImageReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 154639unpackBits: bits depthTo8From: depth with: width height: height pad: pad 154640 "Unpack bits of depth 1, 2, or 4 image to it of depth 8 image." 154641 | bitMask pixelInByte bitsWidth upBitsWidth stopWidth trailingSize upBits bitIndex upBitIndex val | 154642 (#(1 2 4 ) includes: depth) ifFalse: [ ^ self error: 'depth must be 1, 2, or 4' ]. 154643 (#(8 16 32 ) includes: pad) ifFalse: [ ^ self error: 'pad must be 8, 16, or 32' ]. 154644 bitMask := (1 bitShift: depth) - 1. 154645 pixelInByte := 8 / depth. 154646 bitsWidth := (width * depth + pad - 1) // pad * (pad / 8). 154647 upBitsWidth := (width * 8 + pad - 1) // pad * (pad / 8). 154648 stopWidth := (width * depth + 7) // 8. 154649 trailingSize := width - ((stopWidth - 1) * pixelInByte). 154650 upBits := ByteArray new: upBitsWidth * height. 154651 1 154652 to: height 154653 do: 154654 [ :i | 154655 bitIndex := (i - 1) * bitsWidth. 154656 upBitIndex := (i - 1) * upBitsWidth. 154657 1 154658 to: stopWidth - 1 154659 do: 154660 [ :j | 154661 val := bits at: (bitIndex := bitIndex + 1). 154662 upBitIndex := upBitIndex + pixelInByte. 154663 1 154664 to: pixelInByte 154665 do: 154666 [ :k | 154667 upBits 154668 at: upBitIndex - k + 1 154669 put: (val bitAnd: bitMask). 154670 val := val bitShift: depth negated ] ]. 154671 val := (bits at: (bitIndex := bitIndex + 1)) bitShift: depth negated * (pixelInByte - trailingSize). 154672 upBitIndex := upBitIndex + trailingSize. 154673 1 154674 to: trailingSize 154675 do: 154676 [ :k | 154677 upBits 154678 at: upBitIndex - k + 1 154679 put: (val bitAnd: bitMask). 154680 val := val bitShift: depth negated ] ]. 154681 ^ upBits! ! 154682 154683"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 154684 154685ImageReadWriter class 154686 instanceVariableNames: ''! 154687 154688!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! 154689allTypicalFileExtensions 154690 "Answer a collection of file extensions (lowercase) which files that my subclasses can read might commonly have" 154691 "ImageReadWriter allTypicalFileExtensions" 154692 | extensions | 154693 extensions := Set new. 154694 self allSubclassesDo: [ :cls | extensions addAll: cls typicalFileExtensions ]. 154695 ^ extensions! ! 154696 154697!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! 154698formFromFileNamed: fileName 154699 "Answer a ColorForm stored on the file with the given name." 154700 | stream | 154701 stream := FileStream readOnlyFileNamed: fileName. 154702 ^ self formFromStream: stream! ! 154703 154704!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! 154705formFromServerFile: fileName 154706 "Answer a ColorForm stored on the file with the given name. Meant to be called from during the getting of updates from the server. That assures that (Utilities serverUrls) returns the right group of servers." 154707 | form urls doc | 154708 urls := Utilities serverUrls collect: [ :url | url , fileName ]. " fileName starts with: 'updates/' " 154709 urls do: 154710 [ :aURL | 154711 (fileName findTokens: '.') last asLowercase = 'gif' ifTrue: 154712 [ form := HTTPSocket httpGif: aURL. 154713 form = (ColorForm 154714 extent: 20 @ 20 154715 depth: 8) ifTrue: [ self inform: 'The file ' , aURL , ' is ill formed.' ]. 154716 ^ form ]. 154717 (fileName findTokens: '.') last asLowercase = 'bmp' ifTrue: 154718 [ doc := HTTPSocket 154719 httpGet: aURL 154720 accept: 'image/bmp'. 154721 form := Form fromBMPFile: doc. 154722 doc close. 154723 form 154724 ifNil: 154725 [ self inform: 'The file ' , aURL , ' is ill formed.'. 154726 ^ Form new ] 154727 ifNotNil: [ ^ form ] ]. 154728 self inform: 'File ' , fileName , 'does not end with .gif or .bmp' ]. 154729 self inform: 'That file not found on any server we know'! ! 154730 154731!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! 154732formFromStream: aBinaryStream 154733 "Answer a ColorForm stored on the given stream. closes the stream" 154734 | reader readerClass form | 154735 readerClass := self withAllSubclasses 154736 detect: [ :subclass | subclass understandsImageFormat: aBinaryStream ] 154737 ifNone: 154738 [ aBinaryStream close. 154739 ^ self error: 'image format not recognized' ]. 154740 reader := readerClass new on: aBinaryStream reset. 154741 Cursor read showWhile: 154742 [ form := reader nextImage. 154743 reader close ]. 154744 ^ form! ! 154745 154746!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! 154747putForm: aForm onFileNamed: fileName 154748 "Store the given form on a file of the given name." 154749 | writer | 154750 writer := self on: (FileStream newFileNamed: fileName) binary. 154751 Cursor write showWhile: [ writer nextPutImage: aForm ]. 154752 writer close! ! 154753 154754!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! 154755putForm: aForm onStream: aWriteStream 154756 "Store the given form on a file of the given name." 154757 | writer | 154758 writer := self on: aWriteStream. 154759 Cursor write showWhile: [ writer nextPutImage: aForm ]. 154760 writer close! ! 154761 154762!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:55'! 154763typicalFileExtensions 154764 "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" 154765 ^#()! ! 154766 154767!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'ar 3/1/2006 22:59'! 154768understandsImageFormat: aStream 154769 ^[(self new on: aStream) understandsImageFormat] on: Error do:[:ex| ex return: false]! ! 154770 154771 154772!ImageReadWriter class methodsFor: 'instance creation'! 154773on: aStream 154774 "Answer an instance of the receiver for encoding and/or decoding images on the given." 154775 154776 ^ self new on: aStream 154777! ! 154778Object subclass: #ImageSegment 154779 instanceVariableNames: 'arrayOfRoots segment outPointers state segmentName fileName endMarker userRootCnt renamedClasses' 154780 classVariableNames: 'BiggestFileNumber RecentlyRenamedClasses' 154781 poolDictionaries: '' 154782 category: 'System-Object Storage'! 154783!ImageSegment commentStamp: 'tk 12/2/2004 12:33' prior: 0! 154784I represent a segment of Squeak address space. I am created from an 154785array of root objects. After storing, my segment contains a binary 154786encoding of every object accessible from my roots but not otherwise 154787accessible from anywhere else in the system. My segment contains 154788outward pointers that are indices into my table of outPointers. 154789 The main use of ImageSegments is to store Projects. A dummy 154790version of SmartRefStream traverses the Project. Everything it finds 154791is classified as either an object that is owned by the project (only 154792pointed to inside the project), or an object outside the project that 154793is pointed to from inside the project. The objects that are 154794completely owned by the project are compressed into pure binary form 154795in an ImageSegment. The outside objects are put in the 'outPointers' 154796array. The entire ImageSegment (binary part plus outPointers) is 154797encoded in a SmartRefStream, and saved on the disk. (aProject 154798exportSegmentWithChangeSet:fileName:directory:) calls (anImageSegment 154799writeForExportWithSources:inDirectory:changeSet:). 154800 Note that every object inside the project is put into the 154801segment's arrayOfRoots. This is because a dummy SmartRefStream to 154802scan the project, in order to make intelligent decisions about what 154803belongs in the project. 154804 See Project's class comment for what messages are sent to 154805objects as they are unpacked in a new image. 154806 154807---- Older Details ------ 154808 154809 The primary kind of image segment is an Export Segment. It 154810can be saved on a server and read into a completely different Squeak 154811image. 154812Old way to create one: 154813(ImageSegment new copyFromRootsForExport: (Array with: Baz with: Baz class)) 154814 writeForExport: 'myFile.extSeg'. 154815Old way to create one for a project: 154816 (Project named: 'Play With Me - 3') exportSegment. 154817To read it into another image: Select 'myFile.extSeg' in a FileList, 154818Menu 'load as project'. It will install its classes automatically. 154819If you need to see the roots array, it is temporarily stored in 154820(SmartRefStream scannedObject). 154821 154822Most of 'states' of an ImageSegment are not used to export a project, 154823and have been abandoned. 154824 154825 When a segment is written out onto a file, it goes in a 154826folder called <image name>_segs. If your image is called 154827"Squeak2.6.image", the folder "Squeak2.6_segs" must accompany the 154828image whenever your move, copy, or rename it. 154829 Whenever a Class is in arrayOfRoots, its class (aClass class) 154830must also be in the arrayOfRoots. 154831 There are two kinds of image segments. Normal image segments 154832are a piece of a specific Squeak image, and can only be read back 154833into that image. The image holds the array of outPointers that are 154834necessary to turn the bits in the file into objects. 154835 To put out a normal segment that holds a Project (not the 154836current project), execute (Project named: 'xxx') storeSegment. 154837 154838 154839arrayOfRoots The objects that head the tree we will trace. 154840segment The WordArray of raw bits of all objects in the tree. 154841outPointers Oops of all objects outside the segment 154842pointed to from inside. 154843state (see below) 154844segmentName Its basic name. Often the name of a Project. 154845fileName The local name of the file. 'Foo-23.seg' 154846endMarker An object located in memory somewhere after a 154847segment that has 154848 just been brought in. To enumerate the objects in 154849the segment, start at 154850 the segment and go to this object. 154851userRootCnt number of roots submitted by caller. Extras 154852are added in preparation for saving. 154853 154854state that an ImageSegment may exist in... 154855 154856#activeCopy (has been copied, with the intent to 154857become active) 154858arrayOfRoots, segment, and outPointers have been created by 154859copyFromRoots:. The tree of objects has been encoded in the segment, 154860but those objects are still present in the Squeak system. 154861 154862#active (segment is actively holding objects) 154863The segment is now the only holder of tree of objects. Each of the 154864original roots has been transmuted into an ImageSegmentRootStub that 154865refers back to this image segment. The original objects in the 154866segment will all be garbageCollected. 154867 154868#onFile 154869The segment has been written out to a file and replaced by a file 154870pointer. Only ImageSegmentRootStubs and the array of outPointers 154871remains in the image. To get this far: 154872(ImageSegment new copyFromRoots: (Array with: Baz with: Baz class)) 154873 writeToFile: 'myFile.seg'. 154874 154875#inactive 154876The segment has been brought back into memory and turned back into 154877objects. rootsArray is set, but the segment is invalid. 154878 154879#onFileWithSymbols 154880The segment has been written out to a file, along with the text of 154881all the symbols in the outPointers array, and replaced by a file 154882pointer. This reduces the size of the outPointers array, and also 154883allows the system to reclaim any symbols that are not referred to 154884from elsewhere in the image. The specific format used is that of a 154885literal array as follows: 154886 #(symbol1 symbol2 # symbol3 symbol4 'symbolWithSpaces' # symbol5). 154887In this case, the original outPointers array was 8 long, but the 154888compacted table of outPointers retains only two entries. These get 154889inserted in place of the #'s in the array of symbols after it is read 154890back in. Symbols with embedded spaces or other strange characters 154891are written as strings, and converted back to symbols when read back 154892in. The symbol # is never written out. 154893 NOTE: All IdentitySets or dictionaries must be rehashed when 154894being read back from this format. The symbols are effectively 154895internal. (No, not if read back into same image. If a different 154896image, then use #imported. -tk) 154897 154898#imported 154899The segment is on an external file or just read in from one. The 154900segment and outPointers are meant to be read into a foreign image. 154901In this form, the image segment can be read from a URL, and 154902installed. A copy of the original array of root objects is 154903constructed, with former outPointers bound to existing objects in the 154904host system. 154905 (Any Class inside the segment MUST be in the arrayOfRoots. 154906This is so its association can be inserted into Smalltalk. The 154907class's metaclass must be in roots also. Methods that are in 154908outPointers because blocks point at them, were found and added to the 154909roots. 154910 All IdentitySets and dictionaries are rehashed when being 154911read back from exported segments.) 154912 154913 154914To discover why only some of the objects in a project are being 154915written out, try this (***Destructive Test***). This breaks lots of 154916backpointers in the target project, and puts up an array of 154917suspicious objects, a list of the classes of the outPointers, and a 154918debugger. 154919"Close any transcripts in the target project" 154920World currentHand objectToPaste ifNotNil: [ 154921 self inform: 'Hand is holding a Morph in its paste buffer:\' withCRs, 154922 World currentHand objectToPaste printString]. 154923PV _ Project named: 'xxxx'. 154924(IS _ ImageSegment new) findRogueRootsImSeg: 154925 (Array with: PV world presenter with: PV world). 154926IS findOwnersOutPtrs. "Optionally: write a file with owner chains" 154927"Quit and DO NOT save" 154928 154929When an export image segment is brought into an image, it is like an 154930image starting up. Certain startUp messages need to be run. These 154931are byte and word reversals for nonPointer data that comes from a 154932machine of the opposite endianness. #startUpProc passes over all 154933objects in the segment, and: 154934 The first time an instance of class X is encountered, (msg _ 154935X startUpFrom: anImageSegment) is sent. If msg is nil, the usual 154936case, it means that instances of X do not need special work. X is 154937included in the IdentitySet, noStartUpNeeded. If msg is not nil, 154938store it in the dictionary, startUps (aClass -> aMessage). 154939 When a later instance of X is encountered, if X is in 154940noStartUpNeeded, do nothing. If X is in startUps, send the message 154941to the instance. Typically this is a message like #swapShortObjects. 154942 Every class that implements #startUp, should see if it needs 154943a parallel implementation of #startUpFrom:. ! 154944 154945 154946!ImageSegment methodsFor: 'access' stamp: 'marcus.denker 9/14/2008 18:57'! 154947allObjectsDo: aBlock 154948 "Enumerate all objects that came from this segment. NOTE this assumes that the segment was created (and extracted). After the segment has been installed (install), this method allows you to enumerate its objects." 154949 | obj | 154950 154951 endMarker ifNil: [^ self error: 'Just extract and install, don''t writeToFile:']. 154952 segment size ~= 1 ifTrue: [ 154953 ^ self error: 'Vestigial segment size must be 1 (version word)']. 154954 154955 obj := segment nextObject. "Start with the next object after the vestigial header" 154956 [obj == endMarker] whileFalse: "Stop at the next object after the full segment" 154957 [aBlock value: obj. 154958 obj := obj nextObject]. "Step through the objects installed from the segment."! ! 154959 154960!ImageSegment methodsFor: 'access' stamp: 'tk 4/6/1999 13:15'! 154961arrayOfRoots 154962 ^ arrayOfRoots! ! 154963 154964!ImageSegment methodsFor: 'access' stamp: 'tk 12/8/1999 21:12'! 154965arrayOfRoots: array 154966 arrayOfRoots := array! ! 154967 154968!ImageSegment methodsFor: 'access' stamp: 'tk 1/20/2000 20:16'! 154969originalRoots 154970 "Return only the roots that the user submitted, not the ones we had to add." 154971 154972 userRootCnt ifNil: [^ arrayOfRoots]. 154973 ^ arrayOfRoots copyFrom: 1 to: userRootCnt! ! 154974 154975!ImageSegment methodsFor: 'access' stamp: 'tk 3/31/1999 21:47'! 154976outPointers 154977 ^ outPointers! ! 154978 154979!ImageSegment methodsFor: 'access' stamp: 'tk 8/18/1999 22:19'! 154980segment 154981 ^ segment! ! 154982 154983!ImageSegment methodsFor: 'access' stamp: 'tk 9/26/1999 22:54'! 154984state 154985 ^ state! ! 154986 154987 154988!ImageSegment methodsFor: 'compact classes' stamp: 'tk 1/8/2000 17:39'! 154989aComment 154990 "Compact classes are a potential problem because a pointer to the class would not ordinarily show up in the outPointers. We add the classes of all compact classes to outPointers, both for local and export segments. 154991 Compact classes are never allowed as roots. No compact class may be in an Environment that is written out to disk. (In local segments, the compact classes array should never have an ImageSegmentRootStub in it. For export, fileIn the class first, then load a segment with instances of it. The fileIn code can be pasted onto the front of the .extSeg file) 154992 For local segments, a class may become compact while its instances are out on the disk. Or it may become un-compact. A compact class may change shape while some of its instances are on disk. All three cases go through (ClassDescription updateInstancesFrom:). If it can't rule out an instance being in the segment, it reads it in to fix the instances. 154993 See Behavior.becomeCompact for the rules on Compact classes. Indexes may not be reused. This is so that an incoming export segment has its index available. (Changes may be needed in the way indexes are assigned.) 154994 For export segments, a compact class may have a different shape. The normal class reshape mechanism will catch this. During the installation of the segment, objects will have the wrong version of their class momentarily. We will change them back before we get caught. 154995 For export segments, the last two items in outPointers are the number 1717 and an array of the compact classes used in this segment. (The classes in the array are converted from DiskProxies by SmartRefStream.) If that class is not compact in the new image, the instances are recopied. 154996 "! 154997]style[(8 275 5 1435)f1b,f1,f3,f1! ! 154998 154999!ImageSegment methodsFor: 'compact classes' stamp: 'ar 4/10/2005 19:55'! 155000cc: ind new: inTheSeg current: inTheImage fake: fakeCls refStrm: smartRefStream 155001 "Sort out all the cases and decide what to do. Every Fake class is uncompacted before having insts converted. As the segment is installed, instances of reshaped compact classes will have the wrong class. Trouble cases: 155002 1) Existing class is compact in the segment and not compact here. Make that compact, (error if that slot is used), load the segment. If an class was just filed in, it is an existing class as far as we are concerned. 155003 2) A compact class has a different shape. We created a Fake class. Load the segment, with instances in the seg having the Wrong Class!!!! Find the bad instancees, and copy them over to being the real class. 155004 3) An existing class is not compact in the segment, but is in the image. Just let the new instance be uncompact. That is OK, and never reaches this code. 155005 A class that is a root in this segment cannot be compact. That is not allowed." 155006 155007 (inTheImage == nil) & (fakeCls == nil) ifTrue: ["case 1 and empty slot" 155008 inTheSeg becomeCompactSimplyAt: ind. ^ true]. 155009 155010 (inTheImage == inTheSeg) & (fakeCls == nil) ifTrue: ["everything matches" 155011 ^ true]. 155012 155013 inTheImage ifNil: ["reshaped and is an empty slot" 155014 fakeCls becomeCompactSimplyAt: ind. ^ true]. 155015 "comeFullyUpOnReload: will clean up" 155016 155017 (inTheSeg == String and:[inTheImage == ByteString]) ifTrue:[ 155018 "ar 4/10/2005: Workaround after renaming String to ByteString" 155019 ^true 155020 ]. 155021 155022 "Is the image class really the class we are expecting? inTheSeg came in as a DiskProxy, and was mapped if it was renamed!!" 155023 inTheImage == inTheSeg ifFalse: [ 155024 self inform: 'The incoming class ', inTheSeg name, ' wants compact class \location ', ind printString, ', but that is occupied by ', inTheImage name, '. \This file cannot be read into this system. The author of the file \should make the class uncompact and create the file again.' withCRs. 155025 ^ false]. 155026 155027 "Instances of fakeCls think they are compact, and thus will say they are instances of the class inTheImage, which is a different shape. Just allow this to happen. Collect them and remap them as soon as the segment is installed." 155028 ^ true! ! 155029 155030!ImageSegment methodsFor: 'compact classes' stamp: 'ar 2/21/2001 19:26'! 155031compactClassesArray 155032 | ccIndexes ind ccArray hdrBits | 155033 "A copy of the real compactClassesArray, but with only the classes actually used in the segment. Slow, but OK for export." 155034 155035 ccIndexes := Set new. 155036 ind := 2. "skip version word, first object" 155037 "go past extra header words" 155038 (hdrBits := (segment atPin: ind) bitAnd: 3) = 1 ifTrue: [ind := ind+1]. 155039 hdrBits = 0 ifTrue: [ind := ind+2]. 155040 155041 [ccIndexes add: (self compactIndexAt: ind). "0 if has class field" 155042 ind := self objectAfter: ind. 155043 ind > segment size] whileFalse. 155044 ccArray := Smalltalk compactClassesArray clone. 155045 1 to: ccArray size do: [:ii | "only the ones we use" 155046 (ccIndexes includes: ii) ifFalse: [ccArray at: ii put: nil]]. 155047 ^ ccArray! ! 155048 155049!ImageSegment methodsFor: 'compact classes' stamp: 'tk 12/21/1999 21:53'! 155050compactIndexAt: ind 155051 | word | 155052 "Look in this header word in the segment and find it's compact class index. *** Warning: When class ObjectMemory change, be sure to change it here. *** " 155053 155054 ((word := segment at: ind) bitAnd: 3) = 2 ifTrue: [^ 0]. "free block" 155055 ^ (word >> 12) bitAnd: 16r1F "Compact Class field of header word" 155056 155057! ! 155058 155059!ImageSegment methodsFor: 'compact classes' stamp: 'tk 3/15/2000 09:51'! 155060objectAfter: ind 155061 "Return the object or free chunk immediately following the given object or free chunk in the segment. *** Warning: When class ObjectMemory change, be sure to change it here. ***" 155062 155063 | sz word newInd hdrBits | 155064 sz := ((word := segment at: ind "header") bitAnd: 3) = 2 "free block?" 155065 ifTrue: [word bitAnd: 16rFFFFFFFC] 155066 ifFalse: [(word bitAnd: 3) = 0 "HeaderTypeSizeAndClass" 155067 ifTrue: [(segment at: ind-2) bitAnd: 16rFFFFFFFC] 155068 ifFalse: [word bitAnd: "SizeMask" 252]]. 155069 155070 newInd := ind + (sz>>2). 155071 "adjust past extra header words" 155072 (hdrBits := (segment atPin: newInd) bitAnd: 3) = 3 ifTrue: [^ newInd]. 155073 "If at end, header word will be garbage. This is OK" 155074 hdrBits = 1 ifTrue: [^ newInd+1]. 155075 hdrBits = 0 ifTrue: [^ newInd+2]. 155076 ^ newInd "free"! ! 155077 155078!ImageSegment methodsFor: 'compact classes' stamp: 'tk 1/11/2000 15:27'! 155079remapCompactClasses: mapFakeClassesToReal refStrm: smartRefStream 155080 | ccArray current fake info | 155081 "See if our compact classes are compatible with this system. Convert to what the system already has. If we are adding a new class, it has already been filed in. A compact class may not be a root." 155082 155083 (outPointers at: (outPointers size - 1)) = 1717 ifFalse: [^ true]. 155084 ccArray := outPointers last. 155085 current := Smalltalk compactClassesArray. 155086 1 to: ccArray size do: [:ind | 155087 (ccArray at: ind) ifNotNil: ["is compact in the segment" 155088 fake := mapFakeClassesToReal keyAtValue: (current at: ind) ifAbsent: [nil]. 155089 info := self cc: ind new: (ccArray at: ind) current: (current at: ind) 155090 fake: fake refStrm: smartRefStream. 155091 info ifFalse: [^ false]]]. 155092 ^ true! ! 155093 155094 155095!ImageSegment methodsFor: 'fileIn/Out' stamp: 'eem 7/21/2008 12:10'! 155096rehashSets 155097 "I have just been brought in and converted to live objects. Find all Sets and Dictionaries in the newly created objects and rehash them. Segment is near then end of memory, since is was newly brought in (and a new object created for it). 155098 Also, collect all classes of receivers of blocks. Return them. Caller will check if they have been reshaped." 155099 155100 | object sets receiverClasses inSeg | 155101 object := segment. 155102 sets := OrderedCollection new. 155103 "have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one." 155104 receiverClasses := IdentitySet new. 155105 inSeg := true. 155106 [object := object nextObject. 155107 object == endMarker ifTrue: [inSeg := false]. "off end" 155108 object isInMemory ifTrue: [ 155109 (object isKindOf: Set) ifTrue: [sets add: object]. 155110 object isBlock ifTrue: [inSeg ifTrue: [ 155111 receiverClasses add: object receiver class]]. 155112 object class == MethodContext ifTrue: [inSeg ifTrue: [ 155113 receiverClasses add: object receiver class]]. 155114 ]. 155115 object == 0] whileFalse. 155116 sets do: [:each | each rehash]. "our purpose" 155117 ^ receiverClasses "our secondary job" 155118! ! 155119 155120!ImageSegment methodsFor: 'fileIn/Out' stamp: 'eem 7/21/2008 12:09'! 155121storeDataOn: aDataStream 155122 "Don't wrote the array of Roots. Also remember the structures of the classes of objects inside the segment." 155123 155124 | tempRoots tempOutP list | 155125 state = #activeCopy ifFalse: [self error: 'wrong state']. 155126 "real state is activeCopy, but we changed it will be right when coming in" 155127 tempRoots := arrayOfRoots. 155128 tempOutP := outPointers. 155129 outPointers := outPointers clone. 155130 self prepareToBeSaved. 155131 arrayOfRoots := nil. 155132 state := #imported. 155133 super storeDataOn: aDataStream. "record my inst vars" 155134 arrayOfRoots := tempRoots. 155135 outPointers := tempOutP. 155136 state := #activeCopy. 155137 aDataStream references at: #AnImageSegment put: false. "the false is meaningless" 155138 "This key in refs is the flag that there is an ImageSegment in this file." 155139 155140 "Find the receivers of blocks in the segment. Need to get the structure of their classes into structures. Put the receivers into references." 155141 (aDataStream byteStream isKindOf: DummyStream) ifTrue: [ 155142 list := Set new. 155143 arrayOfRoots do: [:ea | 155144 ea isBlock | (ea class == MethodContext) ifTrue: [ 155145 list add: ea receiver class ]]. 155146 aDataStream references at: #BlockReceiverClasses put: list]. 155147! ! 155148 155149 155150!ImageSegment methodsFor: 'filein/out' stamp: 'RAA 1/17/2001 12:15'! 155151acceptSingleMethodSource: aDictionary 155152 155153 | oldClassInfo oldClassName ismeta newName actualClass selector | 155154 oldClassInfo := (aDictionary at: #oldClassName) findTokens: ' '. "'Class' or 'Class class'" 155155 oldClassName := oldClassInfo first asSymbol. 155156 ismeta := oldClassInfo size > 1. 155157 155158 "must use class var since we may not be the same guy who did the initial work" 155159 155160 newName := RecentlyRenamedClasses ifNil: [ 155161 oldClassName 155162 ] ifNotNil: [ 155163 RecentlyRenamedClasses at: oldClassName ifAbsent: [oldClassName] 155164 ]. 155165 actualClass := Smalltalk at: newName. 155166 ismeta ifTrue: [actualClass := actualClass class]. 155167 selector := actualClass parserClass new parseSelector: (aDictionary at: #methodText). 155168 (actualClass compiledMethodAt: selector ifAbsent: [^self "hosed input"]) 155169 putSource: (aDictionary at: #methodText) 155170 fromParseNode: nil 155171 class: actualClass 155172 category: (aDictionary at: #category) 155173 withStamp: (aDictionary at: #changeStamp) 155174 inFile: 2 155175 priorMethod: nil. 155176 155177! ! 155178 155179!ImageSegment methodsFor: 'filein/out' stamp: 'marcus.denker 2/8/2009 17:53'! 155180comeFullyUpOnReload: smartRefStream 155181 "fix up the objects in the segment that changed size. An 155182object in the segment is the wrong size for the modern version of the 155183class. Construct a fake class that is the old size. Replace the 155184modern class with the old one in outPointers. Load the segment. 155185Traverse the instances, making new instances by copying fields, and 155186running conversion messages. Keep the new instances. Bulk forward 155187become the old to the new. Let go of the fake objects and classes. 155188 After the install (below), arrayOfRoots is filled in. 155189Globalize new classes. Caller may want to do some special install on 155190certain objects in arrayOfRoots. 155191 May want to write the segment out to disk in its new form." 155192 155193 | mapFakeClassesToReal ccFixups receiverClasses 155194rootsToUnhiberhate myProject existing | 155195 155196 RecentlyRenamedClasses := nil. "in case old data 155197hanging around" 155198 mapFakeClassesToReal := smartRefStream reshapedClassesIn: outPointers. 155199 "Dictionary of just the ones that change shape. 155200Substitute them in outPointers." 155201 ccFixups := self remapCompactClasses: mapFakeClassesToReal 155202 refStrm: smartRefStream. 155203 ccFixups ifFalse: [^ self error: 'A class in the file is not 155204compatible']. 155205 endMarker := segment nextObject. "for enumeration of objects" 155206 endMarker == 0 ifTrue: [endMarker := 'End' clone]. 155207 self fixCapitalizationOfSymbols. 155208 arrayOfRoots := self loadSegmentFrom: segment outPointers: outPointers. 155209 "Can't use install. Not ready for rehashSets" 155210 mapFakeClassesToReal isEmpty ifFalse: [ 155211 self reshapeClasses: mapFakeClassesToReal refStream: 155212smartRefStream 155213 ]. 155214 "When a Project is stored, arrayOfRoots has all objects in 155215the project, except those in outPointers" 155216 arrayOfRoots do: [:importedObject | 155217 ((importedObject isMemberOf: WideString) or: [importedObject isMemberOf: WideSymbol]) ifTrue: [ 155218 importedObject mutateJISX0208StringToUnicode. 155219 importedObject class = WideSymbol ifTrue: [ 155220 "self halt." 155221 Symbol hasInterned: 155222importedObject asString ifTrue: [:multiSymbol | 155223 multiSymbol == importedObject 155224ifFalse: [ 155225 importedObject 155226becomeForward: multiSymbol. 155227 ]. 155228 ]. 155229 ]. 155230 ]. 155231 (importedObject isKindOf: TTCFontSet) ifTrue: [ 155232 existing := TTCFontSet familyName: 155233importedObject familyName 155234 pointSize: 155235importedObject pointSize. "supplies default" 155236 existing == importedObject ifFalse: 155237[importedObject becomeForward: existing]. 155238 ]. 155239 ]. 155240 "Smalltalk garbageCollect. MultiSymbol rehash. These take 155241time and are not urgent, so don't to them. In the normal case, no 155242bad MultiSymbols will be found." 155243 155244 receiverClasses := self restoreEndianness. "rehash sets" 155245 smartRefStream checkFatalReshape: receiverClasses. 155246 155247 "Classes in this segment." 155248 arrayOfRoots do: [:importedObject | 155249 importedObject class class == Metaclass ifTrue: [self 155250declare: importedObject]]. 155251 arrayOfRoots do: [:importedObject | 155252 (importedObject isKindOf: CompiledMethod) ifTrue: [ 155253 importedObject sourcePointer > 0 ifTrue: 155254[importedObject zapSourcePointer]]. 155255 (importedObject isKindOf: Project) ifTrue: [ 155256 myProject := importedObject. 155257 importedObject ensureChangeSetNameUnique. 155258 Project addingProject: importedObject. 155259 self dependentsRestore: importedObject. 155260 ]]. 155261 155262 rootsToUnhiberhate := arrayOfRoots select: [:importedObject | 155263 importedObject respondsTo: #unhibernate 155264 "ScriptEditors and ViewerFlapTabs" 155265 ]. 155266 myProject ifNotNil: [ 155267 myProject world setProperty: #thingsToUnhibernate 155268toValue: rootsToUnhiberhate 155269 ]. 155270 155271 mapFakeClassesToReal isEmpty ifFalse: [ 155272 mapFakeClassesToReal keys do: [:aFake | 155273 aFake indexIfCompact > 0 ifTrue: [aFake 155274becomeUncompact]. 155275 aFake removeFromSystemUnlogged]. 155276 SystemOrganization removeEmptyCategories]. 155277 "^ self" 155278! ! 155279 155280!ImageSegment methodsFor: 'filein/out' stamp: 'RAA 1/17/2001 12:06'! 155281declare: classThatIsARoot 155282 155283 | nameOnArrival | 155284 "The class just arrived in this segment. How fit it into the Smalltalk dictionary? If it had an association, that was installed with associationDeclareAt:." 155285 155286 nameOnArrival := classThatIsARoot name. 155287 self declareAndPossiblyRename: classThatIsARoot. 155288 nameOnArrival == classThatIsARoot name ifTrue: [^self]. 155289 renamedClasses ifNil: [RecentlyRenamedClasses := renamedClasses := Dictionary new]. 155290 renamedClasses at: nameOnArrival put: classThatIsARoot name. 155291 155292! ! 155293 155294!ImageSegment methodsFor: 'filein/out' stamp: 'stephane.ducasse 1/30/2009 21:51'! 155295declareAndPossiblyRename: classThatIsARoot 155296 | existing | 155297 "The class just arrived in this segment. How fit it into the Smalltalk dictionary? If it had an association, that was installed with associationDeclareAt:." 155298 155299 classThatIsARoot category: 'Morphic-Imported'. 155300 classThatIsARoot superclass addSubclass: classThatIsARoot. 155301 (Smalltalk includesKey: classThatIsARoot name) ifFalse: [ 155302 "Class entry in Smalltalk not referred to in Segment, install anyway." 155303 ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. 155304 existing := Smalltalk at: classThatIsARoot name. 155305 existing xxxClass == ImageSegmentRootStub ifTrue: [ 155306 "We are that segment!! Must ask it carefully!!" 155307 ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. 155308 existing == false | (existing == nil) ifTrue: [ 155309 "association is in outPointers, just installed" 155310 ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. 155311 "Conflict with existing global or copy of the class" 155312 (existing isKindOf: Class) ifTrue: [ 155313 "Take the incoming one" 155314 self inform: 'Using newly arrived version of ', classThatIsARoot name. 155315 classThatIsARoot superclass removeSubclass: classThatIsARoot. "just in case" 155316 (Smalltalk at: classThatIsARoot name) becomeForward: classThatIsARoot. 155317 ^ classThatIsARoot superclass addSubclass: classThatIsARoot]. 155318 self error: 'Name already in use by a non-class: ', classThatIsARoot name. 155319! ! 155320 155321!ImageSegment methodsFor: 'filein/out' stamp: 'tk 10/24/2001 18:31'! 155322endianness 155323 "Return which endian kind the incoming segment came from" 155324 155325 ^ (segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little]! ! 155326 155327!ImageSegment methodsFor: 'filein/out' stamp: 'ar 4/12/2005 17:37'! 155328fixCapitalizationOfSymbols 155329 "MultiString>>capitalized was not implemented correctly. 155330 Fix eventual accessors and mutators here." 155331 | sym ms | 155332 1 to: outPointers size do:[:i| 155333 sym := outPointers at: i. 155334 (sym class == WideSymbol and:[sym size > 3]) ifTrue:[ 155335 ((sym beginsWith: 'get') 155336 and:[(sym at: 4) asInteger < 256 155337 and:[(sym at: 4) isLowercase]]) ifTrue:[ 155338 ms := sym asString. 155339 ms at: 4 put: (ms at: 4) asUppercase. 155340 ms := ms asSymbol. 155341 sym becomeForward: ms. 155342 ]. 155343 ((sym beginsWith: 'set') 155344 and:[(sym at: 4) asInteger < 256 155345 and:[(sym at: 4) isLowercase 155346 and:[sym last = $: 155347 and:[(sym occurrencesOf: $:) = 1]]]]) ifTrue:[ 155348 ms := sym asString. 155349 ms at: 4 put: (ms at: 4) asUppercase. 155350 ms := ms asSymbol. 155351 sym becomeForward: ms. 155352 ]. 155353 outPointers at: i put: sym. 155354 ]. 155355 ].! ! 155356 155357!ImageSegment methodsFor: 'filein/out' stamp: 'ar 8/16/2001 13:26'! 155358prepareToBeSaved 155359 "Prepare objects in outPointers to be written on the disk. They must be able to match up with existing objects in their new system. outPointers is already a copy. 155360 Classes are already converted to a DiskProxy. 155361 Associations in outPointers: 1553621) in Smalltalk. 1553632) in a classPool. 1553643) in a shared pool. 1553654) A pool dict pointed at directly" 155366 155367| left pool myClasses outIndexes key | 155368myClasses := Set new. 155369arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [myClasses add: aRoot]]. 155370outIndexes := IdentityDictionary new. 155371outPointers withIndexDo: [:anOut :ind | 155372 anOut isVariableBinding ifTrue: [ 155373 (myClasses includes: anOut value) 155374 ifFalse: [outIndexes at: anOut put: ind] 155375 ifTrue: [(Smalltalk associationAt: anOut key ifAbsent: [3]) == anOut 155376 ifTrue: [outPointers at: ind put: 155377 (DiskProxy global: #Smalltalk selector: #associationDeclareAt: 155378 args: (Array with: anOut key))] 155379 ifFalse: [outIndexes at: anOut put: ind] 155380 ]]. 155381 (anOut isKindOf: Dictionary) ifTrue: ["Pools pointed at directly" 155382 (key := Smalltalk keyAtIdentityValue: anOut ifAbsent: [nil]) ifNotNil: [ 155383 outPointers at: ind put: 155384 (DiskProxy global: key selector: #yourself args: #())]]. 155385 anOut isMorph ifTrue: [outPointers at: ind put: 155386 (StringMorph contents: anOut printString, ' that was not counted')] 155387 ]. 155388left := outIndexes keys asSet. 155389left size > 0 ifTrue: ["Globals" 155390 (left copy) do: [:assoc | "stay stable while delete items" 155391 (Smalltalk associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [ 155392 outPointers at: (outIndexes at: assoc) put: 155393 (DiskProxy global: #Smalltalk selector: #associationAt: 155394 args: (Array with: assoc key)). 155395 left remove: assoc]]]. 155396left size > 0 ifTrue: ["Class variables" 155397 Smalltalk allClassesDo: [:cls | cls classPool size > 0 ifTrue: [ 155398 (left copy) do: [:assoc | "stay stable while delete items" 155399 (cls classPool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [ 155400 outPointers at: (outIndexes at: assoc) put: 155401 (DiskProxy new global: cls name 155402 preSelector: #classPool 155403 selector: #associationAt: 155404 args: (Array with: assoc key)). 155405 left remove: assoc]]]]]. 155406left size > 0 ifTrue: ["Pool variables" 155407 Smalltalk associationsDo: [:poolAssoc | 155408 poolAssoc value class == Dictionary ifTrue: ["a pool" 155409 pool := poolAssoc value. 155410 (left copy) do: [:assoc | "stay stable while delete items" 155411 (pool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [ 155412 outPointers at: (outIndexes at: assoc) put: 155413 (DiskProxy global: poolAssoc key selector: #associationAt: 155414 args: (Array with: assoc key)). 155415 left remove: assoc]]]]]. 155416left size > 0 ifTrue: [ 155417 "If points to class in arrayOfRoots, must deal with it separately" 155418 "OK to have obsolete associations that just get moved to the new system" 155419 self inform: 'extra associations'. 155420 left inspect]. 155421! ! 155422 155423!ImageSegment methodsFor: 'filein/out' stamp: 'RAA 12/20/2000 11:07'! 155424reshapeClasses: mapFakeClassesToReal refStream: smartRefStream 155425 155426 | bads allVarMaps perfect insts partials in out | 155427 155428 self flag: #bobconv. 155429 155430 partials := OrderedCollection new. 155431 bads := OrderedCollection new. 155432 allVarMaps := IdentityDictionary new. 155433 mapFakeClassesToReal keysAndValuesDo: [ :aFakeClass :theRealClass | 155434 (theRealClass indexIfCompact > 0) "and there is a fake class" 155435 ifFalse: [insts := aFakeClass allInstances] 155436 ifTrue: ["instances have the wrong class. Fix them before anyone notices." 155437 insts := OrderedCollection new. 155438 self allObjectsDo: [:obj | obj class == theRealClass ifTrue: [insts add: obj]]. 155439 ]. 155440 insts do: [ :misShapen | 155441 perfect := smartRefStream convert1: misShapen to: theRealClass allVarMaps: allVarMaps. 155442 bads 155443 detect: [ :x | x == misShapen] 155444 ifNone: [ 155445 bads add: misShapen. 155446 partials add: perfect 155447 ]. 155448 ]. 155449 ]. 155450 bads isEmpty ifFalse: [ 155451 bads asArray elementsForwardIdentityTo: partials asArray 155452 ]. 155453 155454 in := OrderedCollection new. 155455 out := OrderedCollection new. 155456 partials do: [ :each | 155457 perfect := smartRefStream convert2: each allVarMaps: allVarMaps. 155458 in 155459 detect: [ :x | x == each] 155460 ifNone: [ 155461 in add: each. 155462 out add: perfect 155463 ] 155464 ]. 155465 in isEmpty ifFalse: [ 155466 in asArray elementsForwardIdentityTo: out asArray 155467 ]. 155468! ! 155469 155470!ImageSegment methodsFor: 'filein/out' stamp: 'tk 10/24/2001 18:21'! 155471restoreEndianness 155472 "Fix endianness (byte order) of any objects not already fixed. Do this by discovering classes that need a startUp message sent to each instance, and sending it. 155473 I have just been brought in and converted to live objects. Find all Sets and Dictionaries in the newly created objects and rehash them. Segment is near then end of memory, since is was newly brought in (and a new object created for it). 155474 Also, collect all classes of receivers of blocks which refer to instance variables. Return them. Caller will check if they have been reshaped." 155475 155476 | object sets receiverClasses inSeg noStartUpNeeded startUps cls msg | 155477 155478 object := segment. 155479 sets := OrderedCollection new. 155480 "have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one." 155481 receiverClasses := IdentitySet new. 155482 noStartUpNeeded := IdentitySet new. "classes that don't have a per-instance startUp message" 155483 startUps := IdentityDictionary new. "class -> MessageSend of a startUp message" 155484 inSeg := true. 155485 [object := object nextObject. "all the way to the end of memory to catch remade objects" 155486 object == endMarker ifTrue: [inSeg := false]. "off end" 155487 object isInMemory ifTrue: [ 155488 (object isKindOf: Set) ifTrue: [sets add: object]. 155489 (object isKindOf: ContextPart) ifTrue: [ 155490 (inSeg and: [object hasInstVarRef]) ifTrue: [ 155491 receiverClasses add: object receiver class]]. 155492 inSeg ifTrue: [ 155493 (noStartUpNeeded includes: object class) ifFalse: [ 155494 cls := object class. 155495 (msg := startUps at: cls ifAbsent: [nil]) ifNil: [ 155496 msg := cls startUpFrom: self. "a Message, if we need to swap bytes this time" 155497 msg ifNil: [noStartUpNeeded add: cls] 155498 ifNotNil: [startUps at: cls put: msg]]. 155499 msg ifNotNil: [msg sentTo: object]]]]. 155500 object == 0] whileFalse. 155501 sets do: [:each | each rehash]. "our purpose" 155502 ^ receiverClasses "our secondary job" 155503! ! 155504 155505!ImageSegment methodsFor: 'filein/out' stamp: 'RAA 6/22/2000 17:49'! 155506scanFrom: aStream 155507 "Move source code from a fileIn to the changes file for classes in an ImageSegment. Do not compile the methods. They already came in via the image segment. After the ImageSegment in the file, !!ImageSegment new!! captures control, and scanFrom: is called." 155508 | val chunk | 155509 155510 [aStream atEnd] whileFalse: 155511 [aStream skipSeparators. 155512 val := (aStream peekFor: $!!) 155513 ifTrue: ["Move (aStream nextChunk), find the method or class 155514 comment, and install the file location bytes" 155515 (Compiler evaluate: aStream nextChunk logged: false) 155516 scanFromNoCompile: aStream forSegment: self] 155517 ifFalse: [chunk := aStream nextChunk. 155518 aStream checkForPreamble: chunk. 155519 Compiler evaluate: chunk logged: true]. 155520 aStream skipStyleChunk]. 155521 "regular fileIn will close the file" 155522 ^ val! ! 155523 155524 155525!ImageSegment methodsFor: 'instance change shape' stamp: 'tk 1/25/2000 21:54'! 155526allInstancesOf: aClass do: aBlock 155527 | withSymbols oldInstances segSize | 155528 "Bring me in, locate instances of aClass and submit them to the block. Write me out again." 155529 155530 (state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self]. 155531 withSymbols := state = #onFileWithSymbols. 155532 (outPointers includes: aClass) ifFalse: [^ self]. 155533 "If has instances, they point out at the class" 155534 state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]]. 155535 segSize := segment size. 155536 self install. 155537 oldInstances := OrderedCollection new. 155538 self allObjectsDo: [:obj | obj class == aClass ifTrue: [ 155539 oldInstances add: obj]]. 155540 oldInstances do: [:inst | aBlock value: inst]. "do the work" 155541 self copyFromRoots: arrayOfRoots sizeHint: segSize. 155542 self extract. 155543 withSymbols 155544 ifTrue: [self writeToFileWithSymbols] 155545 ifFalse: [self writeToFile]. 155546 155547! ! 155548 155549!ImageSegment methodsFor: 'instance change shape' stamp: 'tk 1/25/2000 21:54'! 155550ifOutPointer: anObject thenAllObjectsDo: aBlock 155551 | withSymbols segSize | 155552 "If I point out to anObject, bring me in, Submit all my objects to the block. Write me out again." 155553 155554 (state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self]. 155555 withSymbols := state = #onFileWithSymbols. 155556 (outPointers includes: anObject) ifFalse: [^ self]. 155557 state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]]. 155558 segSize := segment size. 155559 self install. 155560 self allObjectsDo: [:obj | aBlock value: obj]. "do the work" 155561 self copyFromRoots: arrayOfRoots sizeHint: segSize. 155562 self extract. 155563 withSymbols 155564 ifTrue: [self writeToFileWithSymbols] 155565 ifFalse: [self writeToFile]. 155566 155567! ! 155568 155569!ImageSegment methodsFor: 'instance change shape' stamp: 'ar 4/10/2005 22:19'! 155570segUpdateInstancesOf: oldClass toBe: newClass isMeta: isMeta 155571 | withSymbols oldInstances segSize | 155572 "Bring me in, locate instances of oldClass and get them converted. Write me out again." 155573 155574 (state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self]. 155575 withSymbols := state = #onFileWithSymbols. 155576 "If has instances, they point out at the class" 155577 (outPointers includes: oldClass) ifFalse: [ 155578 oldClass == SmallInteger ifTrue: [^ self]. "instance not changable" 155579 oldClass == Symbol ifTrue: [^ self]. "instance is never in a segment" 155580 oldClass == ByteSymbol ifTrue: [^ self]. "instance is never in a segment" 155581 (Smalltalk compactClassesArray includes: oldClass) ifFalse: [^ self]]. 155582 "For a compact class, must search the segment. Instance does not 155583 point outward to class" 155584 state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]]. 155585 segSize := segment size. 155586 self install. 155587 oldInstances := OrderedCollection new. 155588 self allObjectsDo: [:obj | obj class == oldClass ifTrue: [ 155589 oldInstances add: obj]]. 155590 newClass updateInstances: oldInstances asArray from: oldClass isMeta: isMeta. 155591 self copyFromRoots: arrayOfRoots sizeHint: segSize. 155592 self extract. 155593 withSymbols 155594 ifTrue: [self writeToFileWithSymbols] 155595 ifFalse: [self writeToFile]. 155596! ! 155597 155598 155599!ImageSegment methodsFor: 'nil' stamp: 'nice 4/16/2009 18:55'! 155600copyFromRoots: aRootArray sizeHint: segSizeHint areUnique: areUnique 155601 "Copy a tree of objects into a WordArray segment. The copied objects in the segment are not in the normal Squeak space. 155602 [1] For exporting a project. Objects were enumerated by ReferenceStream and aRootArray has them all. 155603 [2] For exporting some classes. See copyFromRootsForExport:. (Caller must hold Symbols, or they will not get registered in the target system.) 155604 [3] For 'local segments'. outPointers are kept in the image. 155605 If this method yields a very small segment, it is because objects just below the roots are pointed at from the outside. (See findRogueRootsImSeg: for a *destructive* diagnostic of who is pointing in.)" 155606 | segmentWordArray outPointerArray segSize rootSet uniqueRoots | 155607 aRootArray ifNil: [self errorWrongState]. 155608 uniqueRoots := areUnique 155609 ifTrue: [aRootArray] 155610 ifFalse: [rootSet := IdentitySet new: aRootArray size * 3. 155611 uniqueRoots := OrderedCollection new. 155612 1 to: aRootArray size do: [:ii | "Don't include any roots twice" 155613 (rootSet includes: (aRootArray at: ii)) 155614 ifFalse: [ 155615 uniqueRoots addLast: (aRootArray at: ii). 155616 rootSet add: (aRootArray at: ii)] 155617 ifTrue: [userRootCnt ifNotNil: ["adjust the count" 155618 ii <= userRootCnt ifTrue: [userRootCnt := userRootCnt - 1]]]]. 155619 uniqueRoots]. 155620 arrayOfRoots := uniqueRoots asArray. 155621 rootSet := uniqueRoots := nil. "be clean" 155622 userRootCnt ifNil: [userRootCnt := arrayOfRoots size]. 155623 arrayOfRoots do: [:aRoot | 155624 aRoot indexIfCompact > 0 ifTrue: [ 155625 self error: 'Compact class ', aRoot name, ' cannot be a root']. 155626 "aRoot := nil"]. "clean up" 155627 outPointers := nil. "may have used this instance before" 155628 segSize := segSizeHint > 0 ifTrue: [segSizeHint *3 //2] ifFalse: [50000]. 155629 155630 ["Guess a reasonable segment size" 155631 segmentWordArray := WordArrayForSegment new: segSize. 155632 [outPointerArray := Array new: segSize // 20] ifError: [ 155633 state := #tooBig. ^ self]. 155634 "Smalltalk garbageCollect." 155635 (self storeSegmentFor: arrayOfRoots 155636 into: segmentWordArray 155637 outPointers: outPointerArray) == nil] 155638 whileTrue: 155639 ["Double the segment size and try again" 155640 segmentWordArray := outPointerArray := nil. 155641 segSize := segSize * 2]. 155642 segment := segmentWordArray. 155643 outPointers := outPointerArray. 155644 state := #activeCopy. 155645 endMarker := segment nextObject. "for enumeration of objects" 155646 endMarker == 0 ifTrue: [endMarker := 'End' clone]. 155647! ! 155648 155649 155650!ImageSegment methodsFor: 'primitives' stamp: 'di 3/28/1999 13:47'! 155651loadSegmentFrom: segmentWordArray outPointers: outPointerArray 155652 "This primitive will install a binary image segment and return as its value the array of roots of the tree of objects represented. Upon successful completion, the wordArray will have been transmuted into an object of zero length. If this primitive should fail, it will have destroyed the contents of the segment wordArray." 155653 155654 <primitive: 99> "successful completion returns the array of roots" 155655 ^ nil "failure returns nil"! ! 155656 155657!ImageSegment methodsFor: 'primitives' stamp: 'di 3/28/1999 13:49'! 155658storeSegmentFor: rootsArray into: segmentWordArray outPointers: outPointerArray 155659 "This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree). Note: all elements of the reciever are treated as roots indetermining the extent of the tree. All pointers from within the tree to objects outside the tree will be copied into the array of outpointers. In their place in the image segment will be an oop equal to the offset in the outpointer array (the first would be 4). but with the high bit set." 155660 155661 "The primitive expects the array and wordArray to be more than adequately long. In this case it returns normally, and truncates the two arrays to exactly the right size. If either array is too small, the primitive will fail, but in no other case." 155662 155663 <primitive: 98> "successful completion returns self" 155664 ^ nil "failure returns nil"! ! 155665 155666 155667!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/5/2000 11:09'! 155668copyFromRoots: aRootArray sizeHint: segSizeHint 155669 "Copy a tree of objects into a WordArray segment. The copied objects in the segment are not in the normal Squeak space. If this method yields a very small segment, it is because objects just below the roots are pointed at from the outside. (See findRogueRootsImSeg: for a *destructive* diagnostic of who is pointing in.) 155670 Caller must hold onto Symbols. 155671 To go faster, make sure objects are not repeated in aRootArray and other method directly, with true." 155672 155673 self copyFromRoots: aRootArray sizeHint: segSizeHint areUnique: false 155674! ! 155675 155676!ImageSegment methodsFor: 'read/write segment' stamp: 'eem 7/21/2008 12:10'! 155677copyFromRootsForExport: rootArray 155678 "When possible, use copySmartRootsExport:. This way may not copy a complete tree of objects. Add to roots: all of the methods pointed to from the outside by blocks." 155679 | newRoots list segSize symbolHolder | 155680 arrayOfRoots := rootArray. 155681 Smalltalk forgetDoIts. 155682 "self halt." 155683 symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers, 155684 so they will be in outPointers" 155685 (newRoots := self rootsIncludingPlayers) ifNotNil: [ 155686 arrayOfRoots := newRoots]. "world, presenter, and all Player classes" 155687 "Creation of the segment happens here" 155688 self copyFromRoots: arrayOfRoots sizeHint: 0. 155689 segSize := segment size. 155690 [(newRoots := self rootsIncludingBlockMethods) == nil] whileFalse: [ 155691 arrayOfRoots := newRoots. 155692 self copyFromRoots: arrayOfRoots sizeHint: segSize]. 155693 "with methods pointed at from outside" 155694 [(newRoots := self rootsIncludingBlocks) == nil] whileFalse: [ 155695 arrayOfRoots := newRoots. 155696 self copyFromRoots: arrayOfRoots sizeHint: segSize]. 155697 "with methods, blocks from outPointers" 155698 "classes of receivers of blocks" 155699 list := self compactClassesArray. 155700 outPointers := outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)). 155701 "Zap sender of a homeContext. Can't send live stacks out." 155702 1 to: outPointers size do: [:ii | 155703 (outPointers at: ii) isBlock ifTrue: [outPointers at: ii put: nil]. 155704 (outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]]. 155705 symbolHolder.! ! 155706 155707!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 2/8/2000 13:34'! 155708copyFromRootsLocalFileFor: rootArray sizeHint: segSize 155709 "If the roots include a World, add its Player classes to the roots." 155710 | newRoots | 155711 155712 arrayOfRoots := rootArray. 155713 [(newRoots := self rootsIncludingPlayers) == nil] whileFalse: [ 155714 arrayOfRoots := newRoots]. "world, presenter, and all Player classes" 155715 Smalltalk forgetDoIts. 155716 self copyFromRoots: arrayOfRoots sizeHint: segSize. 155717! ! 155718 155719!ImageSegment methodsFor: 'read/write segment' stamp: 'eem 7/21/2008 14:18'! 155720copySmartRootsExport: rootArray 155721 "Use SmartRefStream to find the object. Make them all roots. Create the segment in memory. Project should be in first five objects in rootArray." 155722 | newRoots list segSize symbolHolder dummy replacements naughtyBlocks goodToGo allClasses sizeHint proj | 155723 Smalltalk forgetDoIts. 155724 155725 "self halt." 155726 symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers, 155727 so they will be in outPointers" 155728 155729 dummy := ReferenceStream on: (DummyStream on: nil). 155730 "Write to a fake Stream, not a file" 155731 "Collect all objects" 155732 dummy insideASegment: true. "So Uniclasses will be traced" 155733 dummy rootObject: rootArray. "inform him about the root" 155734 dummy nextPut: rootArray. 155735 (proj :=dummy project) ifNotNil: [self dependentsSave: dummy]. 155736 allClasses := SmartRefStream new uniClassInstVarsRefs: dummy. 155737 "catalog the extra objects in UniClass inst vars. Put into dummy" 155738 allClasses do: [:cls | 155739 dummy references at: cls class put: false. "put Player5 class in roots" 155740 dummy blockers removeKey: cls class ifAbsent: []]. 155741 "refs := dummy references." 155742 arrayOfRoots := self smartFillRoots: dummy. "guaranteed none repeat" 155743 self savePlayerReferences: dummy references. "for shared References table" 155744 replacements := dummy blockers. 155745 dummy project "recompute it" ifNil: [self error: 'lost the project!!']. 155746 dummy project class == DiskProxy ifTrue: [self error: 'saving the wrong project']. 155747 dummy := nil. "force GC?" 155748 naughtyBlocks := arrayOfRoots select: [ :each | 155749 (each isKindOf: ContextPart) and: [each hasInstVarRef] 155750 ]. 155751 155752 "since the caller switched ActiveWorld, put the real one back temporarily" 155753 naughtyBlocks isEmpty ifFalse: [ 155754 World becomeActiveDuring: [ 155755 goodToGo := (UIManager default 155756 chooseFrom: #('keep going' 'stop and take a look') 155757 title: 155758'Some block(s) which reference instance variables 155759are included in this segment. These may fail when 155760the segment is loaded if the class has been reshaped. 155761What would you like to do?') == 1. 155762 goodToGo ifFalse: [ 155763 naughtyBlocks inspect. 155764 self error: 'Here are the bad blocks']. 155765 ]. 155766 ]. 155767 "Creation of the segment happens here" 155768 155769 "try using one-quarter of memory min: four megs to publish (will get bumped later)" 155770 sizeHint := (Smalltalk garbageCollect // 4 // 4) min: 1024*1024. 155771 self copyFromRoots: arrayOfRoots sizeHint: sizeHint areUnique: true. 155772 segSize := segment size. 155773 [(newRoots := self rootsIncludingBlockMethods) == nil] whileFalse: [ 155774 arrayOfRoots := newRoots. 155775 self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true]. 155776 "with methods pointed at from outside" 155777 [(newRoots := self rootsIncludingBlocks) == nil] whileFalse: [ 155778 arrayOfRoots := newRoots. 155779 self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true]. 155780 "with methods, blocks from outPointers" 155781 list := self compactClassesArray. 155782 outPointers := outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)). 155783 1 to: outPointers size do: [:ii | 155784 (outPointers at: ii) isBlock ifTrue: [outPointers at: ii put: nil]. 155785 (outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]. 155786 "substitute new object in outPointers" 155787 (replacements includesKey: (outPointers at: ii)) ifTrue: [ 155788 outPointers at: ii put: (replacements at: (outPointers at: ii))]]. 155789 proj ifNotNil: [self dependentsCancel: proj]. 155790 symbolHolder.! ! 155791 155792!ImageSegment methodsFor: 'read/write segment' stamp: 'sw 11/19/2002 14:40'! 155793dependentsCancel: aProject 155794 "Erase the place we temporarily held the dependents of things in this project. So we don't carry them around forever." 155795 155796 aProject projectParameters removeKey: #GlobalDependentsInProject ifAbsent: []! ! 155797 155798!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/21/2002 16:17'! 155799dependentsRestore: aProject 155800 "Retrieve the list of dependents from the exporting system, hook them up, and erase the place we stored them." 155801 155802 | dict | 155803 dict := aProject projectParameterAt: #GlobalDependentsInProject. 155804 dict ifNil: [^ self]. 155805 dict associationsDo: [:assoc | 155806 assoc value do: [:dd | assoc key addDependent: dd]]. 155807 155808 self dependentsCancel: aProject.! ! 155809 155810!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/21/2002 16:25'! 155811dependentsSave: dummy 155812 "Object that have dependents are supposed to be instances of subclasses of Model. But, class Objects still provides 'Global Dependents', and some people still use them. When both the model and the dependent are in a project that is being saved, remember them, so we can hook them up when this project is loaded in." 155813 155814 | dict proj list | 155815 proj := dummy project. 155816 dict := Dictionary new. 155817 DependentsFields associationsDo: [:assoc | 155818 (dummy references includesKey: assoc key) ifTrue: [ 155819 list := assoc value select: [:dd | dummy references includesKey: dd]. 155820 list size > 0 ifTrue: [dict at: assoc key put: list]]]. 155821 155822 dict size > 0 ifTrue: [ 155823 proj projectParameterAt: #GlobalDependentsInProject put: dict]. 155824! ! 155825 155826!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 11/30/1999 22:30'! 155827extract 155828 "This operation replaces (using become:) all the original roots of a segment with segmentRootStubs. Thus the original objects will be reclaimed, and the root stubs will remain to bring the segment back in if it is needed." 155829 155830 Cursor write showWhile: [ 155831 state = #inactive ifTrue: [self copyFromRoots: arrayOfRoots sizeHint: 0]. 155832 state = #activeCopy ifFalse: [self errorWrongState]. 155833 arrayOfRoots elementsForwardIdentityTo: 155834 (arrayOfRoots collect: [:r | r rootStubInImageSegment: self]). 155835 state := #active]. 155836! ! 155837 155838!ImageSegment methodsFor: 'read/write segment' stamp: 'di 3/28/1999 13:47'! 155839extractThenInstall 155840 "For testing only" 155841 155842 | newRoots | 155843 state = #activeCopy ifFalse: [self errorWrongState]. 155844 arrayOfRoots elementsForwardIdentityTo: 155845 (arrayOfRoots collect: [:r | r rootStubInImageSegment: self]). 155846 state := #active. 155847 newRoots := self loadSegmentFrom: segment outPointers: outPointers. 155848 state := #inactive. 155849 arrayOfRoots elementsForwardIdentityTo: newRoots. 155850! ! 155851 155852!ImageSegment methodsFor: 'read/write segment' stamp: 'gk 2/24/2004 23:53'! 155853install 155854 "This operation retrieves the segment if necessary from file storage, installs it in memory, and replaces (using become:) all the root stubs with the reconstructed roots of the segment." 155855 155856 | newRoots | 155857 state = #onFile ifTrue: [self readFromFile]. 155858 state = #onFileWithSymbols ifTrue: [self readFromFileWithSymbols. 155859 endMarker := segment nextObject. "for enumeration of objects" 155860 endMarker == 0 ifTrue: [endMarker := 'End' clone]]. 155861 (state = #active) | (state = #imported) ifFalse: [self errorWrongState]. 155862 newRoots := self loadSegmentFrom: segment outPointers: outPointers. 155863 state = #imported 155864 ifTrue: ["just came in from exported file" 155865 arrayOfRoots := newRoots] 155866 ifFalse: [ 155867 arrayOfRoots elementsForwardIdentityTo: newRoots]. 155868 state := #inactive. 155869 Beeper beepPrimitive! ! 155870 155871!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/17/1999 00:03'! 155872localName 155873 | segs ind sep | 155874 "Return the current file name for this segment, a local name in the segments directory." 155875 155876 fileName ifNil: [^ nil]. 155877 "^ fileName" 155878 155879 "The following is for backward compatibility. Remove this part after June 2000. 155880 Check if the fileName is a full path, and make it local. Regardless of current or previous file system delimiter." 155881 155882 segs := self class folder copyLast: 4. ":=segs" 155883 ind := 1. 155884 [ind := fileName findString: segs startingAt: ind+1 caseSensitive: false. 155885 ind = 0 ifTrue: [^ fileName]. 155886 sep := fileName at: ind + (segs size). 155887 sep isAlphaNumeric ] whileTrue. "sep is letter or digit, not a separator" 155888 155889 ^ fileName := fileName copyFrom: ind+(segs size)+1 "delimiter" to: fileName size! ! 155890 155891!ImageSegment methodsFor: 'read/write segment' stamp: 'mdr 8/31/2000 19:01'! 155892readFromFile 155893 "Read in a simple segment. Use folder of this image, even if remembered as previous location of this image" 155894 155895 | ff realName | 155896 realName := self class folder, FileDirectory slash, self localName. 155897 ff := FileStream readOnlyFileNamed: realName. 155898 segment := ff nextWordsInto: (WordArrayForSegment new: ff size//4). 155899 endMarker := segment nextObject. "for enumeration of objects" 155900 endMarker == 0 ifTrue: [endMarker := 'End' clone]. 155901 ff close. 155902 state := #active! ! 155903 155904!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/26/1999 13:07'! 155905revert 155906 "Pretend this segment was never brought in. Check that it has a fileName. Replace (using become:) all the original roots of a segment with segmentRootStubs. Thus the original objects will be reclaimed, and the root stubs will remain to bring the segment back in if it is needed. 155907 How to use revert: In the project, choose 'save for reverting'. 155908 155909 ReEnter the project. Make changes. 155910 Either exit normally, and change will be kept, or 155911 Choose 'Revert to saved version'." 155912 155913 fileName ifNil: [^ self]. 155914 (state = #inactive) | (state = #onFile) ifFalse: [^ self]. 155915 Cursor write showWhile: [ 155916 arrayOfRoots elementsForwardIdentityTo: 155917 (arrayOfRoots collect: [:r | r rootStubInImageSegment: self]). 155918 state := #onFile. 155919 segment := nil. 155920 endMarker := nil]. 155921 155922"Old version: 155923 How to use revert: In the project, execute 155924(Project current projectParameters at: #frozen put: true) 155925 Leave the project. Check that the project went out to disk (it is gray in the Jump to Project list). 155926 ReEnter the project. Hear a plink as it comes in from disk. Make a change. 155927 Exit the project. Choose 'Revert to previous version' in the dialog box. 155928 Check that the project went out to disk (it is gray in the Jump to Project list). 155929 ReEnter the project and see that it is in the original state." 155930 155931! ! 155932 155933!ImageSegment methodsFor: 'read/write segment' stamp: 'stephane.ducasse 3/31/2009 21:02'! 155934rootsIncludingBlockMethods 155935 "Return a new roots array with more objects. (Caller should store into rootArray.) Any CompiledMethods that create blocks will be in outPointers if the block is held outside of this segment. Put such methods into the roots list. Then ask for the segment again." 155936 155937 | extras myClasses gotIt | 155938 userRootCnt ifNil: [userRootCnt := arrayOfRoots size]. 155939 extras := OrderedCollection new. 155940 myClasses := OrderedCollection new. 155941 arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [myClasses add: aRoot]]. 155942 myClasses isEmpty ifTrue: [^ nil]. "no change" 155943 outPointers do: [:anOut | 155944 anOut class == CompiledMethod ifTrue: [ 155945 "specialized version of who" 155946 gotIt := false. 155947 myClasses detect: [:class | 155948 class selectorsDo: [:sel | 155949 (class compiledMethodAt: sel) == anOut 155950 ifTrue: [extras add: anOut. gotIt := true]]. 155951 gotIt] 155952 ifNone: [] 155953 ]]. 155954 extras := extras select: [:ea | (arrayOfRoots includes: ea) not]. 155955 extras isEmpty ifTrue: [^ nil]. "no change" 155956 ^ arrayOfRoots, extras! ! 155957 155958!ImageSegment methodsFor: 'read/write segment' stamp: 'stephane.ducasse 3/31/2009 21:01'! 155959rootsIncludingBlocks 155960 "For export segments only. Return a new roots array with more objects. (Caller should store into rootArray.) Collect Blocks and external methods pointed to by them. Put them into the roots list. Then ask for the segment again." 155961 155962 | extras have | 155963 userRootCnt ifNil: [userRootCnt := arrayOfRoots size]. 155964 extras := OrderedCollection new. 155965 outPointers do: [:anOut | 155966 anOut class == CompiledMethod ifTrue: [extras add: anOut]. 155967 (anOut isBlock) ifTrue: [extras add: anOut]. 155968 (anOut class == MethodContext) ifTrue: [extras add: anOut]]. 155969 155970 [have := extras size. 155971 extras copy do: [:anOut | 155972 anOut isBlock ifTrue: [ 155973 anOut home ifNotNil: [ 155974 (extras includes: anOut home) ifFalse: [extras add: anOut home]]]. 155975 (anOut class == MethodContext) ifTrue: [ 155976 anOut method ifNotNil: [ 155977 (extras includes: anOut method) ifFalse: [extras add: anOut method]]]]. 155978 have = extras size] whileFalse. 155979 extras := extras select: [:ea | (arrayOfRoots includes: ea) not]. 155980 extras isEmpty ifTrue: [^ nil]. "no change" 155981 155982 ^ arrayOfRoots, extras! ! 155983 155984!ImageSegment methodsFor: 'read/write segment' stamp: 'HenrikSperreJohansen 9/10/2009 15:44'! 155985rootsIncludingPlayers 155986 "Players have been removed from Morphs, this method could now more accurately be renamed rootsIncludingMorphs" 155987 "Return a new roots array with more objects. (Caller should store into rootArray.) The world morph gets all its submorphs put into the Roots array. Then ask for the segment again." 155988 155989 "I'm not sure if the usage of this method, just doing refactoring.... 155990 Is it a bug that if you have more than one WorldMorph/Project/Presenter in roots, only the submorphs of the (originally final, now first due to use of detect: instead of do:) ones world will be added? " 155991| morphs existing worldAccessRoot | 155992 userRootCnt ifNil: [userRootCnt := arrayOfRoots size]. 155993 155994 worldAccessRoot := arrayOfRoots detect: [:one | 155995 (one isMorph and: [one isWorldMorph]) or: [ 155996 {Presenter. Project} contains: [:class | one isKindOf: class]]] 155997 ifNone: [^nil]. 155998 155999 worldAccessRoot world ifNotNil: [:world | 156000 morphs := IdentitySet new: 400. 156001 world allMorphsInto: morphs.]. 156002 156003 existing := arrayOfRoots asIdentitySet. 156004 morphs := morphs asOrderedCollection reject: [ :each | existing includes: each]. 156005 morphs isEmpty ifTrue: [^ nil]. "no change" 156006 worldAccessRoot := morphs := nil. 156007^ arrayOfRoots, morphs "will contain multiples of some, but reduced later" 156008! ! 156009 156010!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/8/2000 10:00'! 156011savePlayerReferences: dictOfAllObjects 156012 | save world | 156013 "Save our associations we own in the shared References table. They will be installed when the segment is imported." 156014 156015 save := OrderedCollection new. 156016 References associationsDo: [:assoc | 156017 (dictOfAllObjects includesKey: assoc) ifTrue: [save add: assoc]]. 156018 1 to: 5 do: [:ii | ((arrayOfRoots at: ii) respondsTo: #isCurrentProject) ifTrue: [ 156019 world := (arrayOfRoots at: ii) world]]. 156020 world setProperty: #References toValue: save. 156021 "assume it is not refed from outside and will be traced"! ! 156022 156023!ImageSegment methodsFor: 'read/write segment' stamp: 'di 3/28/1999 13:48'! 156024segmentCopy 156025 "This operation will install a copy of the segment in memory, and return a copy of the array of roots. The effect is to perform a deep copy of the original structure. Note that installation destroys the segment, so it must be copied before doing the operation." 156026 156027 state = #activeCopy ifFalse: [self errorWrongState]. 156028 ^ self loadSegmentFrom: segment copy outPointers: outPointers! ! 156029 156030!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/8/1999 12:39'! 156031segmentName 156032 "Return the local file name for this segment." 156033 156034 ^ segmentName! ! 156035 156036!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/13/1999 09:19'! 156037segmentName: aString 156038 "Local file name for this segment." 156039 156040 segmentName := aString! ! 156041 156042!ImageSegment methodsFor: 'read/write segment' stamp: 'ar 4/10/2005 22:19'! 156043smartFillRoots: dummy 156044 | refs known ours ww blockers | 156045 "Put all traced objects into my arrayOfRoots. Remove some 156046 that want to be in outPointers. Return blockers, an 156047 IdentityDictionary of objects to replace in outPointers." 156048 156049 blockers := dummy blockers. 156050 known := (refs := dummy references) size. 156051 refs fasterKeys do: [:obj | "copy keys to be OK with removing items" 156052 (obj isSymbol) ifTrue: [refs removeKey: obj. 156053 known := known-1]. 156054 (obj class == PasteUpMorph) ifTrue: [ 156055 obj isWorldMorph & (obj owner == nil) ifTrue: [ 156056 obj == dummy project world ifFalse: [ 156057 refs removeKey: obj. known := known-1. 156058 blockers at: obj put: 156059 (StringMorph 156060 contents: 'The worldMorph of a different world')]]]. 156061 "Make a ProjectViewMorph here" 156062 "obj class == Project ifTrue: [Transcript show: obj; cr]." 156063 (blockers includesKey: obj) ifTrue: [ 156064 refs removeKey: obj ifAbsent: [known := 156065 known+1]. known := known-1]. 156066 ]. 156067 ours := dummy project world. 156068 refs keysDo: [:obj | 156069 obj isMorph ifTrue: [ 156070 ww := obj world. 156071 (ww == ours) | (ww == nil) ifFalse: [ 156072 refs removeKey: obj. known := known-1. 156073 blockers at: obj put: 156074 (StringMorph contents: 156075 obj 156076 printString, ' from another world')]]]. 156077 "keep original roots on the front of the list" 156078 (dummy rootObject) do: [:rr | refs removeKey: rr ifAbsent: []]. 156079 ^ dummy rootObject, refs fasterKeys asArray. 156080 156081 ! ! 156082 156083!ImageSegment methodsFor: 'read/write segment' stamp: 'mir 10/11/2000 19:08'! 156084writeForExport: shortName 156085 "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk." 156086 156087 | fileStream temp | 156088 state = #activeCopy ifFalse: [self error: 'wrong state']. 156089 temp := endMarker. 156090 endMarker := nil. 156091 fileStream := FileStream newFileNamed: (FileDirectory fileName: shortName extension: self class fileExtension). 156092 fileStream fileOutClass: nil andObject: self. 156093 "remember extra structures. Note class names." 156094 endMarker := temp. 156095! ! 156096 156097!ImageSegment methodsFor: 'read/write segment' stamp: 'stephaneducasse 2/4/2006 20:38'! 156098writeForExportOn: fileStream 156099 "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk." 156100 156101 | temp | 156102 state = #activeCopy ifFalse: [self error: 'wrong state']. 156103 temp := endMarker. 156104 endMarker := nil. 156105 fileStream fileOutClass: nil andObject: self. 156106 "remember extra structures. Note class names." 156107 endMarker := temp. 156108! ! 156109 156110!ImageSegment methodsFor: 'read/write segment' stamp: 'RAA 9/30/2000 20:53'! 156111writeForExportWithSources: fName inDirectory: aDirectory 156112 "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk. Append the source code of any classes in roots. Target system will quickly transfer the sources to its changes file." 156113 156114 "this is the old version which I restored until I solve the gzip problem" 156115 156116 | fileStream temp tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource | 156117 state = #activeCopy ifFalse: [self error: 'wrong state']. 156118 (fName includes: $.) ifFalse: [ 156119 ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.]. 156120 temp := endMarker. 156121 endMarker := nil. 156122 tempFileName := aDirectory nextNameFor: 'SqProject' extension: 'temp'. 156123 zipper := [ 156124 ProgressNotification signal: '3:uncompressedSaveComplete'. 156125 (aDirectory oldFileNamed: tempFileName) compressFile. "makes xxx.gz" 156126 aDirectory 156127 rename: (tempFileName, FileDirectory dot, 'gz') 156128 toBe: fName. 156129 aDirectory 156130 deleteFileNamed: tempFileName 156131 ifAbsent: [] 156132 ]. 156133 fileStream := aDirectory newFileNamed: tempFileName. 156134 fileStream fileOutClass: nil andObject: self. 156135 "remember extra structures. Note class names." 156136 endMarker := temp. 156137 156138 "append sources" 156139 allClassesInRoots := arrayOfRoots select: [:cls | cls isKindOf: Behavior]. 156140 classesToWriteEntirely := allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined]. 156141 methodsWithSource := OrderedCollection new. 156142 allClassesInRoots do: [ :cls | 156143 (classesToWriteEntirely includes: cls) ifFalse: [ 156144 cls selectorsAndMethodsDo: [ :sel :meth | 156145 meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}]. 156146 ]. 156147 ]. 156148 ]. 156149 (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [zipper value. ^ self]. 156150 156151 fileStream reopen; setToEnd. 156152 fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. 156153 methodsWithSource do: [ :each | 156154 fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:" 156155 fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ', 156156 each first name printString,' methodsFor: ', 156157 (each first organization categoryOfElement: each second) asString printString, 156158 ' stamp: ',(Utilities timeStampForMethod: each third) printString; cr. 156159 fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString. 156160 fileStream nextChunkPut: ' '; cr. 156161 ]. 156162 classesToWriteEntirely do: [:cls | 156163 cls isMeta ifFalse: [fileStream nextPutAll: 156164 (cls name, ' category: ''', cls category, '''.!!'); cr; cr]. 156165 cls organization 156166 putCommentOnFile: fileStream 156167 numbered: 0 156168 moveSource: false 156169 forClass: cls. "does nothing if metaclass" 156170 cls organization categories do: 156171 [:heading | 156172 cls fileOutCategory: heading 156173 on: fileStream 156174 moveSource: false 156175 toFile: 0]]. 156176 "no class initialization -- it came in as a real object" 156177 fileStream close. 156178 zipper value.! ! 156179 156180!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/2/2004 12:41'! 156181writeForExportWithSources: fName inDirectory: aDirectory changeSet: 156182 aChangeSetOrNil 156183 "Write the segment on the disk with all info needed to 156184 reconstruct it in a new image. For export. Out pointers are encoded 156185 as normal objects on the disk. Append the source code of any classes 156186 in roots. Target system will quickly transfer the sources to its 156187 changes file." 156188 "Files out a changeSet first, so that a project can contain 156189 classes that are unique to the project." 156190 156191 | fileStream temp tempFileName zipper allClassesInRoots 156192 classesToWriteEntirely methodsWithSource | 156193 state = #activeCopy ifFalse: [self error: 'wrong state']. 156194 (fName includes: $.) ifFalse: [ 156195 ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at 156196 the end of the file name'.]. 156197 temp := endMarker. 156198 endMarker := nil. 156199 tempFileName := aDirectory nextNameFor: 'SqProject' extension: 'temp'. 156200 zipper := [ 156201 Preferences debugPrintSpaceLog ifTrue:[ 156202 fileStream := aDirectory newFileNamed: 156203 (fName copyFrom: 1 to: (fName 156204 lastIndexOf: $.)), 'space'. 156205 self printSpaceAnalysisOn: fileStream. 156206 fileStream close]. 156207 ProgressNotification signal: '3:uncompressedSaveComplete'. 156208 (aDirectory oldFileNamed: tempFileName) compressFile. 156209 "makes xxx.gz" 156210 aDirectory 156211 rename: (tempFileName, FileDirectory dot, 'gz') 156212 toBe: fName. 156213 aDirectory 156214 deleteFileNamed: tempFileName 156215 ifAbsent: [] 156216 ]. 156217 fileStream := aDirectory newFileNamed: tempFileName. 156218 fileStream fileOutChangeSet: aChangeSetOrNil andObject: self. 156219 "remember extra structures. Note class names." 156220 endMarker := temp. 156221 156222 "append sources" 156223 allClassesInRoots := arrayOfRoots select: [:cls | cls 156224 isKindOf: Behavior]. 156225 classesToWriteEntirely := allClassesInRoots select: [ :cls | 156226 cls theNonMetaClass isSystemDefined]. 156227 methodsWithSource := OrderedCollection new. 156228 allClassesInRoots do: [ :cls | 156229 (classesToWriteEntirely includes: cls) ifFalse: [ 156230 cls selectorsAndMethodsDo: [ :sel :meth | 156231 meth sourcePointer = 0 ifFalse: 156232 [methodsWithSource add: {cls. sel. meth}]. 156233 ]. 156234 ]. 156235 ]. 156236 (classesToWriteEntirely isEmpty and: [methodsWithSource 156237 isEmpty]) ifTrue: [zipper value. ^ self]. 156238 156239 fileStream reopen; setToEnd. 156240 fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. 156241 methodsWithSource do: [ :each | 156242 fileStream nextPut: $!!. "try to pacify 156243 ImageSegment>>scanFrom:" 156244 fileStream nextChunkPut: 'RenamedClassSourceReader 156245 formerClassName: ', 156246 each first name printString,' methodsFor: ', 156247 (each first organization 156248 categoryOfElement: each second) asString printString, 156249 ' stamp: ',(Utilities 156250 timeStampForMethod: each third) printString; cr. 156251 fileStream nextChunkPut: (each third getSourceFor: 156252 each second in: each first) asString. 156253 fileStream nextChunkPut: ' '; cr. 156254 ]. 156255 classesToWriteEntirely do: [:cls | 156256 cls isMeta ifFalse: [fileStream nextPutAll: 156257 (cls name, ' 156258 category: ''', cls category, '''.!!'); cr; cr]. 156259 cls organization 156260 putCommentOnFile: fileStream 156261 numbered: 0 156262 moveSource: false 156263 forClass: cls. "does nothing if metaclass" 156264 cls organization categories do: 156265 [:heading | 156266 cls fileOutCategory: heading 156267 on: fileStream 156268 moveSource: false 156269 toFile: 0]]. 156270 "no class initialization -- it came in as a real object" 156271 fileStream close. 156272 zipper value. 156273 ! ! 156274 156275!ImageSegment methodsFor: 'read/write segment' stamp: 'RAA 7/11/2000 18:33'! 156276writeForExportWithSourcesGZ: fName inDirectory: aDirectory 156277 "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk. Append the source code of any classes in roots. Target system will quickly transfer the sources to its changes file." 156278 156279 "this is the gzipped version which I have temporarily suspended until I can get resolve the problem with forward references tring to reposition the stream - RAA 11 june 2000" 156280 156281 156282 156283 156284 | fileStream temp allClassesInRoots classesToWriteEntirely methodsWithSource | 156285 state = #activeCopy ifFalse: [self error: 'wrong state']. 156286 (fName includes: $.) ifFalse: [ 156287 ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.]. 156288 temp := endMarker. 156289 endMarker := nil. 156290 fileStream := GZipSurrogateStream newFileNamed: fName inDirectory: aDirectory. 156291 fileStream fileOutClass: nil andObject: self. 156292 "remember extra structures. Note class names." 156293 endMarker := temp. 156294 156295 "append sources" 156296 allClassesInRoots := arrayOfRoots select: [:cls | cls isKindOf: Behavior]. 156297 classesToWriteEntirely := allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined]. 156298 methodsWithSource := OrderedCollection new. 156299 allClassesInRoots do: [ :cls | 156300 (classesToWriteEntirely includes: cls) ifFalse: [ 156301 cls selectorsAndMethodsDo: [ :sel :meth | 156302 meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}]. 156303 ]. 156304 ]. 156305 ]. 156306 (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [ 156307 fileStream reallyClose. "since #close is ignored" 156308 ^ self 156309 ]. 156310 "fileStream reopen; setToEnd." "<--not required with gzipped surrogate stream" 156311 fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. 156312 methodsWithSource do: [ :each | 156313 fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:" 156314 fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ', 156315 each first name printString,' methodsFor: ', 156316 (each first organization categoryOfElement: each second) asString printString, 156317 ' stamp: ',(Utilities timeStampForMethod: each third) printString; cr. 156318 fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString. 156319 fileStream nextChunkPut: ' '; cr. 156320 ]. 156321 classesToWriteEntirely do: [:cls | 156322 cls isMeta ifFalse: [fileStream nextPutAll: 156323 (cls name, ' category: ''', cls category, '''.!!'); cr; cr]. 156324 cls organization 156325 putCommentOnFile: fileStream 156326 numbered: 0 156327 moveSource: false 156328 forClass: cls. "does nothing if metaclass" 156329 cls organization categories do: 156330 [:heading | 156331 cls fileOutCategory: heading 156332 on: fileStream 156333 moveSource: false 156334 toFile: 0]]. 156335 "no class initialization -- it came in as a real object" 156336 fileStream reallyClose. "since #close is ignored" 156337! ! 156338 156339!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/17/1999 00:13'! 156340writeToFile 156341 156342 state = #active ifFalse: [self error: 'wrong state'. ^ self]. 156343 Cursor write showWhile: [ 156344 segmentName ifNil: [ 156345 segmentName := (FileDirectory localNameFor: fileName) sansPeriodSuffix]. 156346 "OK that still has number on end. This is an unusual case" 156347 fileName := self class uniqueFileNameFor: segmentName. "local name" 156348 (self class segmentDirectory newFileNamed: fileName) nextPutAll: segment; close. 156349 segment := nil. 156350 endMarker := nil. 156351 state := #onFile].! ! 156352 156353!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/8/1999 12:23'! 156354writeToFile: shortName 156355 "The short name can't have any fileDelimiter characters in it. It is remembered in case the segment must be brought in and then sent out again (see ClassDescription updateInstancesFrom:)." 156356 156357 segmentName := (shortName endsWith: '.seg') 156358 ifTrue: [shortName copyFrom: 1 to: shortName size - 4] 156359 ifFalse: [shortName]. 156360 segmentName last isDigit ifTrue: [segmentName := segmentName, '-']. 156361 self writeToFile.! ! 156362 156363!ImageSegment methodsFor: 'read/write segment' stamp: 'ar 4/10/2005 22:19'! 156364writeToFileWithSymbols 156365 | symbols nonSymbols pound | 156366 156367 state = #extracted ifFalse: [self error: 'wrong state']. 156368 segmentName ifNil: [ 156369 segmentName := (FileDirectory localNameFor: fileName) sansPeriodSuffix]. 156370 "OK that still has number on end. This is an unusual case" 156371 fileName := self class uniqueFileNameFor: segmentName. 156372 symbols := OrderedCollection new. 156373 nonSymbols := OrderedCollection new. 156374 pound := '#' asSymbol. 156375 outPointers do: 156376 [:s | 156377 ((s isSymbol) and: [s isLiteral and: [s ~~ pound]]) 156378 ifTrue: [symbols addLast: s] 156379 ifFalse: [symbols addLast: pound. nonSymbols addLast: s]]. 156380 (self class segmentDirectory newFileNamed: fileName) 156381 store: symbols asArray; cr; 156382 nextPutAll: segment; close. 156383 outPointers := nonSymbols asArray. 156384 state := #onFileWithSymbols! ! 156385 156386!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/8/1999 12:23'! 156387writeToFileWithSymbols: shortName 156388 156389 segmentName := (shortName endsWith: '.seg') 156390 ifTrue: [shortName copyFrom: 1 to: shortName size - 4] 156391 ifFalse: [shortName]. 156392 segmentName last isDigit ifTrue: [segmentName := segmentName, '-']. 156393 self writeToFileWithSymbols.! ! 156394 156395 156396!ImageSegment methodsFor: 'statistics' stamp: 'ar 2/21/2001 18:44'! 156397classNameAt: index 156398 | ccIndex | 156399 ccIndex := self compactIndexAt: index. 156400 ccIndex = 0 ifFalse:[^(Smalltalk compactClassesArray at: ccIndex) name]. 156401 ccIndex := segment at: index-1. 156402 (ccIndex bitAnd: 16r80000000) = 0 ifTrue:[ 156403 "within segment; likely a user object" 156404 ^#UserObject]. 156405 ccIndex := (ccIndex bitAnd: 16r7FFFFFFF) bitShift: -2. 156406 ^(outPointers at: ccIndex) name! ! 156407 156408!ImageSegment methodsFor: 'statistics' stamp: 'ar 2/21/2001 19:19'! 156409doSpaceAnalysis 156410 "Capture statistics about the IS and print the number of instances per class and space usage" 156411 | index sz word hdrBits cc instCount instSpace | 156412 state == #activeCopy ifFalse:[self errorWrongState]. 156413 instCount := IdentityDictionary new. 156414 instSpace := IdentityDictionary new. 156415 index := 2. "skip version word, first object" 156416 "go past extra header words" 156417 hdrBits := (segment at: index) bitAnd: 3. 156418 hdrBits = 1 ifTrue: [index := index+1]. 156419 hdrBits = 0 ifTrue: [index := index+2]. 156420 [index > segment size] whileFalse:[ 156421 hdrBits := (word := segment at: index) bitAnd: 3. 156422 hdrBits = 2 ifTrue:[sz := word bitAnd: 16rFFFFFFFC]. 156423 hdrBits = 0 ifTrue:[sz := ((segment at: index-2) bitAnd: 16rFFFFFFFC) + 8]. 156424 hdrBits = 1 ifTrue:[sz := (word bitAnd: "SizeMask" 252) + 4]. 156425 hdrBits = 3 ifTrue:[sz := word bitAnd: "SizeMask" 252]. 156426 hdrBits = 2 156427 ifTrue:[cc := #freeChunk] 156428 ifFalse:[cc := self classNameAt: index]. 156429 instCount at: cc put: (instCount at: cc ifAbsent:[0]) + 1. 156430 instSpace at: cc put: (instSpace at: cc ifAbsent:[0]) + sz. 156431 index := self objectAfter: index]. 156432 ^{instCount. instSpace}! ! 156433 156434!ImageSegment methodsFor: 'statistics' stamp: 'ar 2/21/2001 19:22'! 156435printSpaceAnalysisOn: aStream 156436 "Capture statistics about the IS and print the number of instances per class and space usage" 156437 | instCount instSpace sorted sum1 sum2 | 156438 instCount := self doSpaceAnalysis. 156439 instSpace := instCount last. 156440 instCount := instCount first. 156441 sorted := SortedCollection sortBlock:[:a1 :a2| a1 value >= a2 value]. 156442 instSpace associationsDo:[:a| sorted add: a]. 156443 sorted do:[:assoc| 156444 aStream cr; nextPutAll: assoc key; tab. 156445 aStream print: (instCount at: assoc key); nextPutAll:' instances '. 156446 aStream print: assoc value; nextPutAll: ' bytes '. 156447 ]. 156448 sum1 := instCount inject: 0 into:[:sum :n| sum + n]. 156449 sum2 := instSpace inject: 0 into:[:sum :n| sum + n]. 156450 aStream cr; cr. 156451 aStream print: sum1; nextPutAll:' instances '. 156452 aStream print: sum2; nextPutAll: ' bytes '. 156453! ! 156454 156455 156456!ImageSegment methodsFor: 'testing' stamp: 'tk 11/30/1999 22:29'! 156457deepCopyTest: aRootArray 156458 "ImageSegment new deepCopyTest: Morph withAllSubclasses asArray" 156459 "Project allInstances do: 156460 [:p | p == Project current ifFalse: 156461 [Transcript cr; cr; nextPutAll: p name. 156462 ImageSegment new deepCopyTest: (Array with: p)]]." 156463 | t1 t2 copy | 156464 t1 := Time millisecondsToRun: [self copyFromRoots: aRootArray sizeHint: 0]. 156465 t2 := Time millisecondsToRun: [copy := self segmentCopy]. 156466 Transcript cr; print: segment size * 4; nextPutAll: ' bytes stored with '; 156467 print: outPointers size; show: ' outpointers in '; print: t1; show: 'ms.'. 156468 Transcript cr; nextPutAll: 'Reconstructed in '; print: t2; show: 'ms.'. 156469 ^ copy 156470" 156471Smalltalk allClasses do: 156472 [:m | ImageSegment new deepCopyTest: (Array with: m with: m class)] 156473"! ! 156474 156475!ImageSegment methodsFor: 'testing' stamp: 'di 3/26/1999 22:51'! 156476errorWrongState 156477 156478 ^ self error: 'wrong state'! ! 156479 156480!ImageSegment methodsFor: 'testing' stamp: 'tk 9/3/1999 14:11'! 156481findInOut: anArray 156482 "Take an array of references to a morph, and try to classify them: in the segment, in outPointers, or other." 156483 156484String streamContents: [:strm | 156485 anArray withIndexDo: [:obj :ind | 156486 strm cr; nextPutAll: obj printString; space. 156487 156488 ]].! ! 156489 156490!ImageSegment methodsFor: 'testing' stamp: 'ar 9/14/2000 16:47'! 156491findOwnerMap: morphs 156492 | st | 156493 "Construct a string that has a printout of the owner chain for every morph in the list. Need it as a string so not hold onto them." 156494 156495st := ''. 156496morphs do: [:mm | 156497 (st includesSubString: mm printString) ifFalse: [ 156498 st := st, ' 156499', mm allOwners printString]]. 156500Smalltalk at: #Owners put: st. 156501! ! 156502 156503!ImageSegment methodsFor: 'testing' stamp: 'adrian_lienhard 7/19/2009 18:38'! 156504findOwnersOutPtrs 156505 | ow ff | 156506 ow := Smalltalk at: #Owners ifAbsent: [^ self]. 156507 ow ifNil: [^ self]. 156508 outPointers do: [:oo | 156509 oo isMorph ifTrue: [ 156510 ow := ow copyReplaceAll: oo printString with: oo printString, '[<<<- Pointed at]']]. 156511 ff := FileStream fileNamed: 'Owners log'. 156512 ff nextPutAll: ow; close. 156513 Smalltalk at: #Owners put: ow. 156514 ff edit.! ! 156515 156516!ImageSegment methodsFor: 'testing' stamp: 'HenrikSperreJohansen 9/10/2009 15:51'! 156517findRogueRootsAllMorphs: rootArray 156518 "This is a tool to track down unwanted pointers into the segment. If we don't deal with these pointers, the segment turns out much smaller than it should. These pointers keep a subtree of objects out of the segment. 1565191) assemble all objects should be in seg: morph tree, presenter, scripts, metaclasses. Put in a Set. 1565202) Remove the roots from this list. Ask for senders of each. Of the senders, forget the ones that are in the segment already. Keep others. The list is now all the 'incorrect' pointers into the segment." 156521 156522 | inSeg testRoots pointIn wld xRoots | 156523 Smalltalk garbageCollect. 156524 inSeg := IdentitySet new: 200. 156525 arrayOfRoots := rootArray. 156526 (testRoots := self rootsIncludingPlayers) ifNil: [testRoots := rootArray]. 156527 testRoots do: 156528 [:obj | 156529 (obj isKindOf: Project) 156530 ifTrue: 156531 [inSeg add: obj. 156532 wld := obj world. 156533 inSeg add: wld presenter]. 156534 (obj isKindOf: Presenter) ifTrue: [inSeg add: obj]]. 156535 xRoots := wld ifNil: [testRoots] ifNotNil: [testRoots , (Array with: wld)]. 156536 xRoots do: 156537 [:obj | 156538 "root is a project" 156539 156540 obj isMorph 156541 ifTrue: 156542 [obj allMorphs do: 156543 [:mm | 156544 inSeg add: mm.]. 156545 obj isWorldMorph ifTrue: [inSeg add: obj presenter]]]. 156546 testRoots do: [:each | inSeg remove: each ifAbsent: []]. 156547 "want them to be pointed at from outside" 156548 pointIn := IdentitySet new: 400. 156549 inSeg do: [:ob | pointIn addAll: (PointerFinder pointersTo: ob except: inSeg)]. 156550 testRoots do: [:each | pointIn remove: each ifAbsent: []]. 156551 pointIn remove: inSeg array ifAbsent: []. 156552 pointIn remove: pointIn array ifAbsent: []. 156553 inSeg do: 156554 [:obj | 156555 obj isMorph 156556 ifTrue: 156557 [pointIn remove: (obj instVarAt: 3) 156558 ifAbsent: 156559 ["submorphs" 156560 156561 ]. 156562 "associations in extension" 156563 pointIn remove: obj extension ifAbsent: []. 156564 obj extension ifNotNil: 156565 [obj extension otherProperties ifNotNil: 156566 [obj extension otherProperties associationsDo: 156567 [:ass | 156568 pointIn remove: ass ifAbsent: [] 156569 "*** and extension actorState" 156570 "*** and ActorState instantiatedUserScriptsDictionary ScriptInstantiations"]]]]. 156571 ]. 156572 self halt: 'Examine local variables pointIn and inSeg'. 156573 ^pointIn! ! 156574 156575!ImageSegment methodsFor: 'testing' stamp: 'tk 11/30/1999 22:30'! 156576findRogueRootsImSeg: rootArray 156577 "This is a tool to track down unwanted pointers into the segment. If we don't deal with these pointers, the segment turns out much smaller than it should. These pointers keep a subtree of objects out of the segment. 1565781) Break all owner pointers in submorphs and all scripts. 1565792) Create the segment and look at outPointers. 1565803) Remove those we expect. 1565814) Remember to quit without saving -- the owner pointers are smashed." 156582 156583| newRoots suspects bag1 bag2 | 156584arrayOfRoots := rootArray. 156585[(newRoots := self rootsIncludingPlayers) == nil] whileFalse: [ 156586 arrayOfRoots := newRoots]. "world, presenter, and all Player classes" 156587self findRogueRootsPrep. "and free that context!!" 156588Smalltalk forgetDoIts. 156589Smalltalk garbageCollect. 156590self copyFromRoots: arrayOfRoots sizeHint: 0. 156591 156592suspects := outPointers select: [:oo | oo isMorph]. 156593suspects size > 0 ifTrue: [suspects inspect]. 156594bag1 := Bag new. bag2 := Bag new. 156595outPointers do: [:key | 156596 (key isKindOf: Class) 156597 ifTrue: [bag2 add: key class name] 156598 ifFalse: [(#(Symbol Point Rectangle True False String Float Color Form ColorForm StrikeFont Metaclass UndefinedObject TranslucentColor) includes: key class name) 156599 ifTrue: [bag2 add: key class name] 156600 ifFalse: [bag1 add: key class name]]]. 156601"(bag sortedCounts) is the SortedCollection" 156602(StringHolder new contents: bag1 sortedCounts printString, ' 156603 156604', bag2 sortedCounts printString) 156605 openLabel: 'Objects pointed at by the outside'. 156606self halt: 'Examine local variables pointIn and inSeg'. 156607 156608"Use this in inspectors: 156609 outPointers select: [:oo | oo class == <a Class>]. " 156610 156611! ! 156612 156613!ImageSegment methodsFor: 'testing' stamp: 'alain.plantec 6/8/2009 23:41'! 156614findRogueRootsPrep 156615 "Part of the tool to track down unwanted pointers into the segment. Break all owner pointers in submorphs, scripts, and viewers in flaps." 156616 156617| wld morphs | 156618wld := arrayOfRoots detect: [:obj | 156619 obj isMorph ifTrue: [obj isWorldMorph] ifFalse: [false]] ifNone: [nil]. 156620wld ifNil: [wld := arrayOfRoots detect: [:obj | obj isMorph] 156621 ifNone: [^ self error: 'can''t find a root morph']]. 156622morphs := IdentitySet new: 400. 156623wld submorphs do: [:mm | "non showing flaps" 156624 (mm isKindOf: FlapTab) ifTrue: [ 156625 mm referent allMorphsInto: morphs]]. 156626morphs do: [:mm | "break the back pointers" 156627 mm isInMemory ifTrue: [ 156628 (mm respondsTo: #target) ifTrue: [ 156629 mm nearestOwnerThat: [:ow | ow == mm target 156630 ifTrue: [mm target: nil. true] 156631 ifFalse: [false]]]. 156632 (mm respondsTo: #arguments) ifTrue: [ 156633 mm arguments do: [:arg | arg ifNotNil: [ 156634 mm nearestOwnerThat: [:ow | ow == arg 156635 ifTrue: [mm arguments at: (mm arguments indexOf: arg) put: nil. true] 156636 ifFalse: [false]]]]]. 156637 mm eventHandler ifNotNil: ["recipients point back up" 156638 (morphs includesAllOf: (mm eventHandler allRecipients)) ifTrue: [ 156639 mm eventHandler: nil]]. 156640 "temporary, until using Model for PartsBin" 156641 (mm isMorphicModel) ifTrue: [ 156642 (mm model isMorphicModel) ifTrue: [ 156643 mm model breakDependents]]. 156644 (mm isTextMorph) ifTrue: [mm setContainer: nil]]]. 156645(Smalltalk includesKey: #Owners) ifTrue: [Smalltalk at: #Owners put: nil]. 156646 "in case findOwnerMap: is commented out" 156647"self findOwnerMap: morphs." 156648morphs do: [:mm | "break the back pointers" 156649 mm isInMemory ifTrue: [mm privateOwner: nil]]. 156650"more in extensions?" 156651 156652! ! 156653 156654!ImageSegment methodsFor: 'testing' stamp: 'Alexandre.Bergel 7/4/2009 11:10'! 156655findRogueRootsRefStrm: rootArray 156656 "This is a tool to track down unwanted pointers into the segment. If we don't deal with these pointers, the segment turns out much smaller than it should. These pointers keep a subtree of objects out of the segment. 1566571) assemble all objects that should be in the segment by using SmartReference Stream and a dummyReference Stream. Put in a Set. 1566582) Remove the roots from this list. Ask for senders of each. Of the senders, forget the ones that are in the segment already. Keep others. The list is now all the 'incorrect' pointers into the segment." 156659 156660 | dummy goodInSeg inSeg ok pointIn | 156661 dummy := ReferenceStream on: (DummyStream on: nil). 156662 "Write to a fake Stream, not a file" 156663 rootArray do: 156664 [:root | 156665 dummy rootObject: root. "inform him about the root" 156666 dummy nextPut: root]. 156667 inSeg := dummy references keys. 156668 dummy := nil. 156669 Smalltalk garbageCollect. "dump refs dictionary" 156670 rootArray do: [:each | inSeg remove: each ifAbsent: []]. 156671 "want them to be pointed at from outside" 156672 pointIn := IdentitySet new: 500. 156673 goodInSeg := IdentitySet new: 2000. 156674 inSeg do: 156675 [:obj | 156676 ok := obj class isPointers. 156677 obj class == Color ifTrue: [ok := false]. 156678 obj class == TranslucentColor ifTrue: [ok := false]. 156679 obj class == Array ifTrue: [obj size = 0 ifTrue: [ok := false]]. 156680 "shared #() in submorphs of all Morphs" 156681 ok ifTrue: [goodInSeg add: obj]]. 156682 goodInSeg 156683 do: [:ob | pointIn addAll: (PointerFinder pointersTo: ob except: #())]. 156684 inSeg do: [:each | pointIn remove: each ifAbsent: []]. 156685 rootArray do: [:each | pointIn remove: each ifAbsent: []]. 156686 pointIn remove: inSeg array ifAbsent: []. 156687 pointIn remove: goodInSeg array ifAbsent: []. 156688 pointIn remove: pointIn array ifAbsent: []. 156689 self halt: 'Examine local variables pointIn and inSeg'. 156690 ^pointIn! ! 156691 156692!ImageSegment methodsFor: 'testing' stamp: 'di 9/29/1999 16:50'! 156693isOnFile 156694 ^ state == #onFile! ! 156695 156696!ImageSegment methodsFor: 'testing' stamp: 'di 3/27/1999 22:04'! 156697verify: ob1 matches: ob2 knowing: matchDict 156698 156699 | priorMatch first | 156700 ob1 == ob2 ifTrue: 156701 ["If two pointers are same, they must be ints or in outPointers" 156702 ((ob1 isMemberOf: SmallInteger) and: [ob1 = ob2]) ifTrue: [^ self]. 156703 ((ob1 isKindOf: Behavior) and: [ob1 indexIfCompact = ob2 indexIfCompact]) ifTrue: [^ self]. 156704 (outPointers includes: ob1) ifTrue: [^ self]. 156705 self halt]. 156706 priorMatch := matchDict at: ob1 ifAbsent: [nil]. 156707 priorMatch == nil 156708 ifTrue: [matchDict at: ob1 put: ob2] 156709 ifFalse: [priorMatch == ob2 156710 ifTrue: [^ self] 156711 ifFalse: [self halt]]. 156712 self verify: ob1 class matches: ob2 class knowing: matchDict. 156713 ob1 class isVariable ifTrue: 156714 [ob1 basicSize = ob2 basicSize ifFalse: [self halt]. 156715 first := 1. 156716 (ob1 isMemberOf: CompiledMethod) ifTrue: [first := ob1 initialPC]. 156717 first to: ob1 basicSize do: 156718 [:i | self verify: (ob1 basicAt: i) matches: (ob2 basicAt: i) knowing: matchDict]]. 156719 ob1 class instSize = ob2 class instSize ifFalse: [self halt]. 156720 1 to: ob1 class instSize do: 156721 [:i | self verify: (ob1 instVarAt: i) matches: (ob2 instVarAt: i) knowing: matchDict]. 156722 (ob1 isMemberOf: CompiledMethod) ifTrue: 156723 [ob1 header = ob2 header ifFalse: [self halt]. 156724 ob1 numLiterals = ob2 numLiterals ifFalse: [self halt]. 156725 1 to: ob1 numLiterals do: 156726 [:i | self verify: (ob1 literalAt: i) matches: (ob2 literalAt: i) knowing: matchDict]]! ! 156727 156728!ImageSegment methodsFor: 'testing' stamp: 'di 3/27/1999 21:36'! 156729verifyCopy 156730 156731 | copyOfRoots matchDict | 156732 copyOfRoots := self segmentCopy. 156733 matchDict := IdentityDictionary new. 156734 arrayOfRoots with: copyOfRoots do: 156735 [:r :c | self verify: r matches: c knowing: matchDict]! ! 156736 156737 156738!ImageSegment methodsFor: '*tests-system' stamp: 'al 11/30/2008 17:18'! 156739isIntegerObject: oop 156740 ^ (oop bitAnd: 1) > 0! ! 156741 156742!ImageSegment methodsFor: '*tests-system' stamp: 'al 11/29/2008 23:43'! 156743numberOfFieldsOf: index 156744 | header format size | 156745 header := segment at: index. 156746 format := (header >> 8) bitAnd: 16rF. 156747 format <= 4 ifFalse: [ ^ 0 ]. "no pointer" 156748 156749 (header bitAnd: 3) = 2 156750 ifTrue: [ ^ 0 ] 156751 ifFalse: [ size := (header bitAnd: 3) = 0 "HeaderTypeSizeAndClass" 156752 ifTrue: [ (segment at: index - 2) bitAnd: 16rFFFFFFFC ] 156753 ifFalse: [ header bitAnd: "SizeMask" 252 ] ]. 156754 ^ size - 4 "header" >> 2 "ShiftForWord"! ! 156755 156756!ImageSegment methodsFor: '*tests-system' stamp: 'al 2/27/2009 12:21'! 156757objectJunksDo: aBlock 156758 | index header type fieldStartIndex fieldCount fields | 156759 state == #activeCopy ifFalse:[self errorWrongState]. 156760 index := 2. "skip version word, first object" 156761 "go past extra header words" 156762 type := (segment at: index) bitAnd: 3. 156763 type = 1 ifTrue: [ index := index + 1 ]. 156764 type = 0 ifTrue: [ index := index + 2 ]. 156765 [ index > segment size ] whileFalse: [ 156766 header := segment at: index. 156767 fieldStartIndex := index + 1. 156768 fieldCount := self numberOfFieldsOf: index. 156769 fields := segment copyFrom: fieldStartIndex to: fieldStartIndex + fieldCount - 1. 156770 aBlock value: (self classNameAt: index) value: header value: fields. 156771 index := self objectAfter: index. 156772 (fieldStartIndex + fieldCount - 1 < index) ifFalse: [ self error: 'should not happen' ]. 156773 ]! ! 156774 156775!ImageSegment methodsFor: '*tests-system' stamp: 'al 11/30/2008 17:18'! 156776printTypeOf: oop 156777 "oop is a field pointer, which either is an int or a pointer into the seg or into outPointers" 156778 156779 | index | 156780 (self isIntegerObject: oop) ifTrue: [ ^'<int>' , (oop >> 1) asString ]. 156781 ^((oop bitAnd: 16r80000000) = 0) 156782 ifTrue: [ 156783 index := oop bitShift: -2. 156784 ((segment at: index) bitAnd: 3) = 2 ifTrue: [ '<free block!!>' ]. 156785 self classNameAt: index ] 156786 ifFalse: [ (outPointers at: ((oop bitAnd: 16r7FFFFFFF) bitShift: -2)) class name ]! ! 156787 156788"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 156789 156790ImageSegment class 156791 instanceVariableNames: ''! 156792 156793!ImageSegment class methodsFor: 'accessing' stamp: 'mir 10/11/2000 17:33'! 156794compressedFileExtension 156795 ^'sqz'! ! 156796 156797!ImageSegment class methodsFor: 'accessing' stamp: 'mir 10/11/2000 17:32'! 156798fileExtension 156799 ^'extSeg'! ! 156800 156801 156802!ImageSegment class methodsFor: 'filein/out' stamp: 'sd 3/20/2008 22:26'! 156803folder 156804 | im | 156805 "Full path name of segments folder. Be sure to duplicate and rename the folder when you duplicate and rename an image. Is $_ legal in all file systems?" 156806 156807 im := SmalltalkImage current imageName. 156808 ^ (im copyFrom: 1 to: im size - 6 "'.image' size"), '_segs'! ! 156809 156810!ImageSegment class methodsFor: 'filein/out' stamp: 'tk 12/16/1999 23:44'! 156811reclaimObsoleteSegmentFiles "ImageSegment reclaimObsoleteSegmentFiles" 156812 "Delete segment files that can't be used after this image is saved. 156813 Note that this is never necessary -- it just saves file space." 156814 156815 | aFileName segDir segFiles folderName byName exists | 156816 folderName := FileDirectory default class localNameFor: self folder. 156817 (FileDirectory default includesKey: folderName) ifFalse: [ 156818 ^ self "don't create if absent"]. 156819 segDir := self segmentDirectory. 156820 segFiles := (segDir fileNames select: [:fn | fn endsWith: '.seg']) asSet. 156821 exists := segFiles copy. 156822 segFiles isEmpty ifTrue: [^ self]. 156823 byName := Set new. 156824 "Remove (save) every file owned by a segment in memory" 156825 ImageSegment allInstancesDo: [:is | 156826 (aFileName := is localName) ifNotNil: [ 156827 segFiles remove: aFileName ifAbsent: []. 156828 (exists includes: aFileName) ifFalse: [ 156829 Transcript cr; show: 'Segment file not found: ', aFileName]. 156830 byName add: is segmentName]]. 156831 "Of the segments we have seen, delete unclaimed the files." 156832 segFiles do: [:fName | 156833 "Delete other file versions with same project name as one known to us" 156834 (byName includes: (fName sansPeriodSuffix stemAndNumericSuffix first)) 156835 ifTrue: [segDir deleteFileNamed: fName]].! ! 156836 156837!ImageSegment class methodsFor: 'filein/out' stamp: 'di 9/29/1999 15:45'! 156838segmentDirectory 156839 "Return a directory object for the folder of segments. 156840 Create such a folder if none exists." 156841 | dir folderName | 156842 dir := FileDirectory default. 156843 folderName := dir class localNameFor: self folder. "imageName:=segs" 156844 (dir includesKey: folderName) ifFalse: 156845 [dir createDirectory: folderName]. "create the folder if necess" 156846 ^ dir directoryNamed: folderName! ! 156847 156848!ImageSegment class methodsFor: 'filein/out' stamp: 'rbb 2/18/2005 13:25'! 156849startUp 156850 | choice | 156851 "Minimal thing to assure that a .segs folder is present" 156852 156853(Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [ 156854 (FileDirectory default includesKey: (FileDirectory localNameFor: self folder)) 156855 ifFalse: [ 156856 choice := UIManager default 156857 chooseFrom: #('Create folder' 'Quit without saving') 156858 title: 156859 'The folder with segments for this image is missing.\' withCRs, 156860 self folder, '\If you have moved or renamed the image file,\' withCRs, 156861 'please Quit and rename the segments folder in the same way'. 156862 choice = 1 ifTrue: [FileDirectory default createDirectory: self folder]. 156863 choice = 2 ifTrue: [SmalltalkImage current snapshot: false andQuit: true]]] 156864 156865 ! ! 156866 156867!ImageSegment class methodsFor: 'filein/out' stamp: 'tk 12/16/1999 22:33'! 156868uniqueFileNameFor: segName 156869 "Choose a unique file name for the segment with this name." 156870 | segDir fileName listOfFiles | 156871 segDir := self segmentDirectory. 156872 listOfFiles := segDir fileNames. 156873 BiggestFileNumber ifNil: [BiggestFileNumber := 1]. 156874 BiggestFileNumber > 99 ifTrue: [BiggestFileNumber := 1]. "wrap" 156875 [fileName := segName, BiggestFileNumber printString, '.seg'. 156876 (listOfFiles includes: fileName)] whileTrue: [ 156877 BiggestFileNumber := BiggestFileNumber + 1]. "force a unique file name" 156878 ^ fileName! ! 156879 156880 156881!ImageSegment class methodsFor: 'testing' stamp: 'di 2/17/2000 21:58'! 156882activeClasses "ImageSegment activeClasses" 156883 "Restore all remaining MD faults and return the active classes" 156884 156885 | unused active | 156886 unused := OrderedCollection new. 156887 active := OrderedCollection new. 156888 Smalltalk allClasses do: 156889 [:c | (c instVarNamed: 'methodDict') 156890 ifNil: [unused addLast: c] 156891 ifNotNil: [active addLast: c]]. 156892 unused do: [:c | c recoverFromMDFault]. 156893 ^ active 156894! ! 156895 156896!ImageSegment class methodsFor: 'testing' stamp: 'di 2/17/2000 22:08'! 156897activeClassesByCategory "ImageSegment activeClassesByCategory" 156898 "Return a dictionary of active classes by system category. 156899 Useful for finding kernel categories to minimize swapping." 156900 156901 | active dict cat list | 156902 active := self activeClasses. 156903 dict := Dictionary new. 156904 active do: 156905 [:c | cat := c category. 156906 list := dict at: cat ifAbsent: [Array new]. 156907 dict at: cat put: (list copyWith: c)]. 156908 ^ dict 156909" 156910 ImageSegment discoverActiveClasses <-- do it 156911 -- do something typical -- 156912 ImageSegment activeClassesByCategory <-- inspect it 156913"! ! 156914 156915!ImageSegment class methodsFor: 'testing' stamp: 'di 3/7/2001 17:07'! 156916discoverActiveClasses "ImageSegment discoverActiveClasses" 156917 "Run this method, do a few things, maybe save and resume the image. 156918 This will leave unused classes with MDFaults. 156919 You MUST follow this soon by activeClasses, or by swapOutInactiveClasses." 156920 156921 "NOTE: discoverActiveClasses uses Squeak's ability to detect and recover from faults due to a nil method dictionary. It staches the method dict in with the organization during the time when discovery is in progress (Gag me with a spoon). This is why the faults need to be cleared promptly before resuming normal work with the system. It is also important that classes *do not* refer directly to their method dictionary, but only via the accessor message." 156922 | ok | 156923 Smalltalk allClasses do: 156924 [:c | ok := true. 156925 #(Array Object Class Message MethodDictionary) do: 156926 [:n | ((Smalltalk at: n) == c or: 156927 [(Smalltalk at: n) inheritsFrom: c]) ifTrue: [ok := false]]. 156928 ok ifTrue: [c induceMDFault]]. 156929" 156930 ImageSegment discoverActiveClasses. 156931 -- do something typical -- 156932 PopUpMenu notify: ImageSegment activeClasses size printString , ' classes were active out of ' , 156933 Smalltalk allClasses size printString. 156934"! ! 156935 156936!ImageSegment class methodsFor: 'testing' stamp: 'tk 11/30/1999 22:27'! 156937swapOutInactiveClasses "ImageSegment swapOutInactiveClasses" 156938 "Make up segments by grouping unused classes by system category. 156939 Read about, and execute discoverActiveClasses, and THEN execute this one." 156940 156941 | unused groups i roots | 156942 ImageSegment recoverFromMDFault. 156943 ImageSegmentRootStub recoverFromMDFault. 156944 unused := Smalltalk allClasses select: [:c | (c instVarNamed: 'methodDict') == nil]. 156945 unused do: [:c | c recoverFromMDFault]. 156946 groups := Dictionary new. 156947 SystemOrganization categories do: 156948 [:cat | 156949 i := (cat findLast: [:c | c = $-]) - 1. 156950 i <= 0 ifTrue: [i := cat size]. 156951 groups at: (cat copyFrom: 1 to: i) 156952 put: (groups at: (cat copyFrom: 1 to: i) ifAbsent: [Array new]) , 156953 ((SystemOrganization superclassOrder: cat) select: [:c | 156954 unused includes: c]) asArray]. 156955 groups keys do: 156956 [:cat | roots := groups at: cat. 156957 Transcript cr; cr; show: cat; cr; print: roots; endEntry. 156958 roots := roots , (roots collect: [:c | c class]). 156959 (cat beginsWith: 'Sys' "something here breaks") ifFalse: 156960 [(ImageSegment new copyFromRoots: roots sizeHint: 0) extract; 156961 writeToFile: cat]. 156962 Transcript cr; print: Smalltalk garbageCollect; endEntry]! ! 156963 156964!ImageSegment class methodsFor: 'testing' stamp: 'RAA 9/27/2000 18:50'! 156965swapOutProjects "ImageSegment swapOutProjects" 156966 "Swap out segments for all projects other than the current one." 156967 156968 | spaceLeft newSpaceLeft | 156969 spaceLeft := Smalltalk garbageCollect. 156970 Project allProjects doWithIndex: 156971 [:p :i | p couldBeSwappedOut ifTrue: 156972 [Transcript cr; cr; nextPutAll: p name. 156973 (ImageSegment new copyFromRoots: (Array with: p) sizeHint: 0) 156974 extract; writeToFile: 'project' , i printString. 156975 newSpaceLeft := Smalltalk garbageCollect. 156976 Transcript cr; print: newSpaceLeft - spaceLeft; endEntry. 156977 spaceLeft := newSpaceLeft]].! ! 156978 156979!ImageSegment class methodsFor: 'testing' stamp: 'tk 11/30/1999 22:27'! 156980testClassFaultOn: someClass "ImageSegment testClassFaultOn: FileList" 156981 "Swap out a class with an existing instance. Then send a message to the inst. 156982 This will cause the VM to choke down deep and resend #cannotInterpret:. 156983 This in turn will send a message to the stubbed class which will choke 156984 and resend: #doesNotUnderstand:. Then, if we're lucky, things will start working." 156985 156986 (ImageSegment new copyFromRoots: (Array with: someClass with: someClass class) 156987 sizeHint: 0) extract; writeToFile: 'test'. 156988! ! 156989ProtoObject subclass: #ImageSegmentRootStub 156990 instanceVariableNames: 'shadowSuper shadowMethodDict shadowFormat imageSegment' 156991 classVariableNames: 'FaultLogs LoggingFaults' 156992 poolDictionaries: '' 156993 category: 'System-Object Storage'! 156994!ImageSegmentRootStub commentStamp: '<historical>' prior: 0! 156995An ImageSegmentRootStub is a stub that replaces one of the root of an ImageSegment that has been extracted from the Squeak ObjectMemory. It has two very simple roles: 156996 1569971. If any message is sent to one of these objects, it will be caught by doesNotUnderstand:, and bring about a reinstallation of the missing segment. This exception is caused by the fact that no other messages are defined in this class, and neither does it inherit any from above, since its superclass is nil. When the reinstallation has been accomplished, the message will be resent as though nothing was amiss. 156998 1569992. If one of these objects is a class, and a message is sent to one of its instances, it will cause a similar fault which will be caught by cannotInterpret:. This exception is caused by a somewhat more subtle condition: the primitive operations of the virtual machine do not have time to check whether classes are resident or not -- they assume that all classes are resident. However every non-cached message lookup does test for a nil in the methodDictionary slot. If a rootStub replaces a class (or any behavior), it masquerades as the class, but it will have a nil in the slot where the method Dictionary is expected. This will cause the VM to send cannotInterpret:, eventually leading to the same process for reinstalling the missing segment and resending the message as above. 157000 157001Just to be on the safe side, a rootStub that replaces a Behavior also carries a copy of both the superclass and format fields from the original class. This insures that, even if some operations of the VM require these values, things will continue to operate properly when the segment is absent.! 157002 157003 157004!ImageSegmentRootStub methodsFor: 'basics' stamp: 'tk 8/13/1999 15:59'! 157005isInMemory 157006 "We are a place holder for an object that is out." 157007 ^ false! ! 157008 157009 157010!ImageSegmentRootStub methodsFor: 'fetch from disk' stamp: 'di 3/4/2001 22:45'! 157011doesNotUnderstand: aMessage 157012 | segmentName | 157013"Any normal message sent to this object is really intended for another object that is in a non-resident imageSegment. Reinstall the segment and resend the message." 157014 157015 segmentName := imageSegment segmentName. 157016 imageSegment install. 157017 LoggingFaults ifTrue: "Save the stack printout to show who caused the fault" 157018 [FaultLogs at: Time millisecondClockValue printString 157019 put: (String streamContents: 157020 [:strm | 157021 strm nextPutAll: segmentName; cr. 157022 strm print: self class; space; print: aMessage selector; cr. 157023 (thisContext sender stackOfSize: 30) 157024 do: [:item | strm print: item; cr]])]. 157025 157026 "NOTE: The following should really be (aMessage sentTo: self) 157027 in order to recover properly from a fault in a super-send, 157028 however, the lookupClass might be bogus in this case, and it's 157029 almost unthinkable that the first fault would be a super send." 157030 ^ self perform: aMessage selector withArguments: aMessage arguments! ! 157031 157032!ImageSegmentRootStub methodsFor: 'fetch from disk' stamp: 'di 3/27/1999 12:19'! 157033xxSuperclass: superclass format: format segment: segment 157034 157035 "Set up fields like a class but with null methodDict" 157036 shadowSuper := superclass. 157037 shadowMethodDict := nil. 157038 shadowFormat := format. 157039 imageSegment := segment. 157040! ! 157041 157042!ImageSegmentRootStub methodsFor: 'fetch from disk' stamp: 'tk 4/9/1999 10:32'! 157043xxxClass 157044 "Primitive. Answer the object which is the receiver's class. Essential. See 157045 Object documentation whatIsAPrimitive." 157046 157047 <primitive: 111> 157048 self primitiveFailed! ! 157049 157050!ImageSegmentRootStub methodsFor: 'fetch from disk' stamp: 'tk 10/24/1999 10:57'! 157051xxxSegment 157052 ^ imageSegment! ! 157053 157054"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 157055 157056ImageSegmentRootStub class 157057 instanceVariableNames: ''! 157058 157059!ImageSegmentRootStub class methodsFor: 'accessing' stamp: 'di 2/11/2000 12:33'! 157060faultLogs "ImageSegmentRootStub faultLogs" "<-- inspect it" 157061 157062 ^ FaultLogs! ! 157063 157064 157065!ImageSegmentRootStub class methodsFor: 'settings' stamp: 'di 2/7/2000 23:43'! 157066doLogFaults "ImageSegmentRootStub doLogFaults" 157067 157068 FaultLogs := Dictionary new. 157069 LoggingFaults := true.! ! 157070 157071!ImageSegmentRootStub class methodsFor: 'settings' stamp: 'di 2/7/2000 23:17'! 157072dontLogFaults "ImageSegmentRootStub dontLogFaults" 157073 157074 FaultLogs := Dictionary new. 157075 LoggingFaults := false.! ! 157076 157077!ImageSegmentRootStub class methodsFor: 'settings' stamp: 'di 2/11/2000 12:31'! 157078startLoggingFaults "ImageSegmentRootStub startLoggingFaults" 157079 157080 FaultLogs := Dictionary new. 157081 LoggingFaults := true.! ! 157082 157083!ImageSegmentRootStub class methodsFor: 'settings' stamp: 'di 2/11/2000 12:33'! 157084stopLoggingFaults "ImageSegmentRootStub stopLoggingFaults" 157085 157086 FaultLogs := Dictionary new. 157087 LoggingFaults := false.! ! 157088TestCase subclass: #ImageSegmentTest 157089 instanceVariableNames: '' 157090 classVariableNames: '' 157091 poolDictionaries: '' 157092 category: 'Tests-System'! 157093 157094!ImageSegmentTest methodsFor: 'private' stamp: 'AdrianLienhard 9/6/2009 15:33'! 157095analyzeSegment: aSegment 157096 "I return a collection of arrays. Each array represents an object in the segment. The first element is the name of its class and the second element is an array of the class of its instance variables." 157097 157098 | contents | 157099 contents := OrderedCollection new. 157100 aSegment objectJunksDo: [ :classname :header :fields | 157101 contents add: (Array 157102 with: classname 157103 with: (fields asOrderedCollection collect: [ :p | 157104 aSegment printTypeOf: p ]) asArray) ]. 157105 ^ contents! ! 157106 157107!ImageSegmentTest methodsFor: 'private' stamp: 'AdrianLienhard 10/18/2009 16:36'! 157108createSegmentFrom: anObject 157109 | symbolHolder | 157110 symbolHolder := Symbol allSymbols. 157111 ^ ImageSegment new 157112 copyFromRoots: (Array with: anObject) 157113 sizeHint: 1000 157114 areUnique: true.! ! 157115 157116!ImageSegmentTest methodsFor: 'private' stamp: 'AdrianLienhard 9/6/2009 19:22'! 157117fileName 157118 ^ 'imagesegment-test.bin'! ! 157119 157120!ImageSegmentTest methodsFor: 'private' stamp: 'AdrianLienhard 9/6/2009 18:35'! 157121loadSegmentFromFile 157122 | stream | 157123 stream := FileStream oldFileNamed: self fileName. 157124 ^ stream fileInObjectAndCode install arrayOfRoots first! ! 157125 157126!ImageSegmentTest methodsFor: 'private' stamp: 'AdrianLienhard 9/6/2009 19:27'! 157127writeToFile: aSegment 157128 | stream | 157129 stream := FileStream forceNewFileNamed: self fileName. 157130 [ aSegment writeForExportOn: stream ] 157131 ensure: [ stream close ].! ! 157132 157133 157134!ImageSegmentTest methodsFor: 'running' stamp: 'AdrianLienhard 9/6/2009 19:22'! 157135tearDown 157136 FileDirectory default deleteFileNamed: self fileName! ! 157137 157138 157139!ImageSegmentTest methodsFor: 'testing' stamp: 'AdrianLienhard 9/6/2009 15:37'! 157140testOutPointers 157141 "self debug: #testOutPointers" 157142 157143 | segment external internal root | 157144 external := Object new. 157145 internal := true -> external. 157146 root := false -> internal. 157147 internal := nil. 157148 157149 segment := self createSegmentFrom: root. 157150 157151 self assert: segment outPointers size = 3. 157152 self assert: [ segment outPointers includesAllOf: {external. true. false} ].! ! 157153 157154!ImageSegmentTest methodsFor: 'testing' stamp: 'AdrianLienhard 9/6/2009 15:39'! 157155testSegmentContents 157156 "self debug: #testSegmentContents" 157157 157158 | segment contents external internal root | 157159 external := Object new. 157160 internal := true -> external. 157161 root := false -> internal. 157162 internal := nil. 157163 157164 segment := self createSegmentFrom: root. 157165 contents := self analyzeSegment: segment. 157166 157167 "segment should contain the root array, root, and internal -- but not external" 157168 self assert: contents size = 3. 157169 self assert: [ (contents collect: #first) includesAllOf: #(Array Association Association) ].! ! 157170 157171!ImageSegmentTest methodsFor: 'testing' stamp: 'AdrianLienhard 9/6/2009 18:29'! 157172testSymbols 157173 "self debug: #testSymbols" 157174 157175 "This test assures that when a symbol is stored in a segment and is loaded back into an image that already contains an instance of this symbol, no duplicate is created. At the time of this writing, this is not the case *if* the symbol is stored part of the segment rather than of the outpointers collecton. The former is the case only if no other obect than the root or an object of the subtree reachable from the root references the symbol. To reproduce this situation we set symbol := nil and trigger a GC to make the symbol table release the weak reference to the symbol." 157176 157177 | segment root string symbol | 157178 string := 'randomStringForSymbolThatDoesNotExist'. 157179 Smalltalk garbageCollect. 157180 self assert: [ Symbol allSymbols noneSatisfy: [ :each | each asString = string ] ]. 157181 157182 symbol := string asSymbol. 157183 root := Array with: symbol with: #testSymbols. 157184 157185 symbol := nil. 157186 Smalltalk garbageCollect. 157187 157188 segment := self createSegmentFrom: root. 157189 self writeToFile: segment. 157190 157191 root := segment := nil. 157192 Smalltalk garbageCollect. 157193 157194 "make sure the symbol is really gone" 157195 self assert: [ Symbol allSymbols noneSatisfy: [ :each | each asString = string ] ]. 157196 157197 "create a new instance of the symbol and load the segment" 157198 symbol := string asSymbol. 157199 root := self loadSegmentFromFile. 157200 157201 self assert: root first == symbol. 157202 self assert: root second == #testSymbols.! ! 157203Object subclass: #ImmAbstractPlatform 157204 instanceVariableNames: '' 157205 classVariableNames: '' 157206 poolDictionaries: '' 157207 category: 'Multilingual-ImmPlugin'! 157208 157209!ImmAbstractPlatform methodsFor: 'all' stamp: 'yo 11/7/2002 17:43'! 157210keyboardFocusForAMorph: aMorph 157211 157212 "do nothing" 157213! ! 157214ImmAbstractPlatform subclass: #ImmWin32 157215 instanceVariableNames: '' 157216 classVariableNames: '' 157217 poolDictionaries: '' 157218 category: 'Multilingual-ImmPlugin'! 157219 157220!ImmWin32 methodsFor: 'all' stamp: 'sd 2/4/2008 21:21'! 157221keyboardFocusForAMorph: aMorph 157222 157223 | left top pos | 157224 aMorph ifNil: [^ self]. 157225 [ 157226 pos := aMorph preferredKeyboardPosition. 157227 left := (pos x min: Display width max: 0) asInteger. 157228 top := (pos y min: Display height max: 0) asInteger. 157229 self setCompositionWindowPositionX: left y: top 157230 ] on: Error 157231 do: [:ex |]. 157232! ! 157233 157234 157235!ImmWin32 methodsFor: 'as yet unclassified' stamp: 'yo 11/7/2002 16:47'! 157236setCompositionWindowPositionX: x y: y 157237 157238 <primitive: 'primSetCompositionWindowPosition' module: 'ImmWin32Plugin'> 157239 157240 ^ nil 157241! ! 157242ImmAbstractPlatform subclass: #ImmX11 157243 instanceVariableNames: '' 157244 classVariableNames: '' 157245 poolDictionaries: '' 157246 category: 'Multilingual-ImmPlugin'! 157247 157248!ImmX11 methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:21'! 157249keyboardFocusForAMorph: aMorph 157250 157251 | left bottom pos | 157252 aMorph ifNil: [^ self]. 157253 [ 157254 pos := aMorph preferredKeyboardPosition. 157255 left := (pos x min: Display width max: 0) asInteger. 157256 bottom := (pos y min: Display height max: 0) asInteger 157257 + (aMorph paragraph 157258 characterBlockForIndex: aMorph editor selectionInterval first) height. 157259 self setCompositionWindowPositionX: left y: bottom 157260 ] on: Error 157261 do: [:ex |]. 157262! ! 157263 157264!ImmX11 methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 11/8/2003 08:46'! 157265setCompositionWindowPositionX: x y: y 157266 157267 <primitive: 'primSetCompositionWindowPosition' module: 'ImmX11Plugin'> 157268 157269 ^ nil 157270! ! 157271Object subclass: #Imports 157272 instanceVariableNames: 'imports' 157273 classVariableNames: '' 157274 poolDictionaries: '' 157275 category: 'System-Support'! 157276!Imports commentStamp: 'sd 5/11/2003 20:34' prior: 0! 157277I represent imported resources such as images, sounds, and other kind of files. 157278For now I only store images in a simple way. 157279 157280To access my default instance use: Imports default. However I'm not a strict singleton 157281and clients may create several of me using new. ! 157282 157283 157284!Imports methodsFor: 'icons' stamp: 'marcus.denker 11/10/2008 10:04'! 157285importImageDirectory: directoryOrName 157286 | dir extensions forms | 157287 dir := directoryOrName isString 157288 ifFalse: [ directoryOrName ] 157289 ifTrue: [ FileDirectory default directoryNamed: directoryOrName ]. 157290 dir exists 157291 ifFalse: [self error: dir fullName , ' does not exist'. ^ #()]. 157292 extensions := (ImageReadWriter allTypicalFileExtensions add: 'form'; 157293 yourself) 157294 collect: [:ex | '.' , ex]. 157295 forms := OrderedCollection new. 157296 dir fileNames 157297 do: [:fileName | | fullName | (fileName endsWithAnyOf: extensions) 157298 ifTrue: [fullName := dir fullNameFor: fileName. 157299 (self importImageFromFileNamed: fullName) 157300 ifNotNil: [:form | forms add: form]]]. 157301 ^ forms! ! 157302 157303!Imports methodsFor: 'icons' stamp: 'nk 6/12/2004 12:44'! 157304importImageDirectoryWithSubdirectories: directoryOrName 157305 | dir forms | 157306 dir := directoryOrName isString 157307 ifFalse: [ directoryOrName ] 157308 ifTrue: [ FileDirectory default directoryNamed: directoryOrName ]. 157309 dir exists 157310 ifFalse: [self error: dir fullName , ' does not exist'. ^ #()]. 157311 forms := OrderedCollection new. 157312 dir withAllSubdirectoriesCollect: [ :subdir | forms addAll: (self importImageDirectory: dir) ]. 157313 ^ forms! ! 157314 157315!Imports methodsFor: 'icons' stamp: 'nk 6/12/2004 12:25'! 157316importImageFromFileNamed: fullName 157317 | localName pathParts form imageName | 157318 FileDirectory 157319 splitName: fullName 157320 to: [:dirPath :lname | 157321 localName := lname. 157322 pathParts := dirPath findTokens: FileDirectory slash]. 157323 form := [Form fromFileNamed: fullName] 157324 on: Error 157325 do: [:ex | ex return: nil]. 157326 form 157327 ifNil: [^ nil]. 157328 imageName := FileDirectory baseNameFor: localName. 157329 [imports includesKey: imageName] 157330 whileTrue: [imageName := pathParts isEmpty 157331 ifTrue: [Utilities 157332 keyLike: imageName 157333 satisfying: [:ea | (imports includesKey: ea) not]] 157334 ifFalse: [pathParts removeLast , '-' , imageName]]. 157335 imports at: imageName put: form. 157336 ^ form! ! 157337 157338 157339!Imports methodsFor: 'images' stamp: 'sd 5/11/2003 20:36'! 157340images 157341 "returns all the imported images" 157342 157343 ^ imports values 157344 157345 ! ! 157346 157347!Imports methodsFor: 'images' stamp: 'nk 6/12/2004 12:49'! 157348importImage: anImage named: aName 157349 imports 157350 at: (Utilities 157351 keyLike: aName 157352 satisfying: [:ea | (imports includesKey: ea) not]) 157353 put: anImage! ! 157354 157355!Imports methodsFor: 'images' stamp: 'yo 7/17/2003 00:17'! 157356imports 157357 157358 ^ imports 157359! ! 157360 157361!Imports methodsFor: 'images' stamp: 'sd 5/11/2003 22:26'! 157362namesAndImagesDo: aBlock 157363 "iterate over all the names and image" 157364 157365 ^ imports keysAndValuesDo: aBlock 157366 157367 ! ! 157368 157369 157370!Imports methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:58'! 157371initialize 157372 super initialize. 157373 imports := Dictionary new.! ! 157374 157375"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 157376 157377Imports class 157378 instanceVariableNames: 'default'! 157379 157380!Imports class methodsFor: 'instance creation' stamp: 'nk 7/12/2003 10:38'! 157381default 157382 "Answer my default instance, creating one if necessary." 157383 "Imports default" 157384 ^default ifNil: [ default := self new ]! ! 157385 157386!Imports class methodsFor: 'instance creation' stamp: 'nk 7/12/2003 10:36'! 157387default: anImports 157388 "Set my default instance. Returns the old value if any." 157389 | old | 157390 old := default. 157391 default := anImports. 157392 ^old! ! 157393Notification subclass: #InMidstOfFileinNotification 157394 instanceVariableNames: '' 157395 classVariableNames: '' 157396 poolDictionaries: '' 157397 category: 'Exceptions-Kernel'! 157398 157399!InMidstOfFileinNotification methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 17:07'! 157400defaultAction 157401 157402 self resume: false! ! 157403MorphicModel subclass: #IncrementalSliderMorph 157404 instanceVariableNames: 'sliderMorph getValueSelector setValueSelector getEnabledSelector' 157405 classVariableNames: '' 157406 poolDictionaries: '' 157407 category: 'Polymorph-Widgets'! 157408 157409!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:45'! 157410buttons 157411 "Answer the buttons." 157412 157413 ^{self firstSubmorph. self lastSubmorph}! ! 157414 157415!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:56'! 157416decrement 157417 "Decrement the value." 157418 157419 self value: self value - self quantum! ! 157420 157421!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 15:17'! 157422extent: aPoint 157423 "Set the button width to match the height." 157424 157425 self extent = aPoint ifTrue: [^self]. 157426 super extent: aPoint. 157427 self updateOrientation: aPoint! ! 157428 157429!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:56'! 157430increment 157431 "Increment the value." 157432 157433 self value: self value + self quantum! ! 157434 157435!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:13'! 157436maxEnabled 157437 "Answer whether the maximum button should be enabled." 157438 157439 ^self enabled and: [self notAtMax]! ! 157440 157441!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:13'! 157442minEnabled 157443 "Answer whether the minimum button should be enabled." 157444 157445 ^self enabled and: [self notAtMin]! ! 157446 157447!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 15:16'! 157448minExtent 157449 "Must answer a fixed small size here to 157450 allow auto orientation to work." 157451 157452 ^24@24! ! 157453 157454!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:50'! 157455newButtonLabel: direction ofSize: size 157456 "Answer a new label for an inc/dec button." 157457 157458 ^AlphaImageMorph new 157459 image: (ScrollBar 157460 arrowOfDirection: direction 157461 size: size 157462 color: self paneColor darker)! ! 157463 157464!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:35'! 157465notAtMax 157466 "Answer whether the value is not at the maximum," 157467 157468 ^self value < self max! ! 157469 157470!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:35'! 157471notAtMin 157472 "Answer whether the value is not at the minimum," 157473 157474 ^self value > self min! ! 157475 157476!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:02'! 157477on: anObject getValue: getSel setValue: setSel 157478 "Use the given selectors as the interface." 157479 157480 self 157481 model: anObject; 157482 getValueSelector: getSel; 157483 setValueSelector: setSel; 157484 updateValue! ! 157485 157486!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:24'! 157487update: aSymbol 157488 "Update the value." 157489 157490 super update: aSymbol. 157491 aSymbol = self getValueSelector 157492 ifTrue: [^self updateValue]. 157493 aSymbol = self getEnabledSelector 157494 ifTrue: [^self updateEnabled]! ! 157495 157496!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:26'! 157497updateEnabled 157498 "Update the enablement state." 157499 157500 self model ifNotNil: [ 157501 self getEnabledSelector ifNotNil: [ 157502 self enabled: (self model perform: self getEnabledSelector)]]! ! 157503 157504!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 15:19'! 157505updateOrientation: aPoint 157506 "Set the layout for the new extent." 157507 157508 |butts| 157509 butts := self buttons. 157510 aPoint x >= aPoint y 157511 ifTrue: [self listDirection: #leftToRight. 157512 butts first 157513 roundedCorners: #(1 2); 157514 hResizing: #rigid; 157515 vResizing: #spaceFill; 157516 width: aPoint y; 157517 label: (self newButtonLabel: #left ofSize: aPoint y // 2). 157518 butts last 157519 roundedCorners: #(3 4); 157520 hResizing: #rigid; 157521 vResizing: #spaceFill; 157522 width: aPoint y; 157523 label: (self newButtonLabel: #right ofSize: aPoint y // 2)] 157524 ifFalse: [self listDirection: #topToBottom. 157525 butts first 157526 roundedCorners: #(1 4); 157527 hResizing: #spaceFill; 157528 vResizing: #rigid; 157529 height: aPoint x; 157530 label: (self newButtonLabel: #top ofSize: aPoint x // 2). 157531 butts last 157532 roundedCorners: #(2 3); 157533 hResizing: #spaceFill; 157534 vResizing: #rigid; 157535 height: aPoint x; 157536 label: (self newButtonLabel: #bottom ofSize: aPoint x // 2)]! ! 157537 157538!IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:14'! 157539updateValue 157540 "Update the value." 157541 157542 self model ifNotNil: [ 157543 self getValueSelector ifNotNil: [ 157544 self sliderMorph ifNotNilDo: [:sm | 157545 sm scaledValue: self value. 157546 self changed: #minEnabled; changed: #maxEnabled]]]! ! 157547 157548 157549!IncrementalSliderMorph methodsFor: 'initialize-release' stamp: 'gvc 9/3/2009 13:54'! 157550defaultSliderFillStyle 157551 "Answer the hue gradient." 157552 157553 ^(GradientFillStyle colors: {Color white. Color black}) 157554 origin: self topLeft; 157555 direction: (self bounds isWide 157556 ifTrue: [self width@0] 157557 ifFalse: [0@self height])! ! 157558 157559!IncrementalSliderMorph methodsFor: 'initialize-release' stamp: 'gvc 9/2/2009 14:22'! 157560initialize 157561 "Initialize the receiver." 157562 157563 super initialize. 157564 self sliderMorph: self newSliderMorph. 157565 self 157566 changeTableLayout; 157567 listDirection: #leftToRight; 157568 cellInset: 0; 157569 borderWidth: 0; 157570 hResizing: #spaceFill; 157571 vResizing: #spaceFill; 157572 borderColor: Color transparent; 157573 addMorphBack: self newDecrementButton; 157574 addMorphBack: self sliderMorph; 157575 addMorphBack: self newIncrementButton! ! 157576 157577!IncrementalSliderMorph methodsFor: 'initialize-release' stamp: 'gvc 9/8/2009 13:12'! 157578newDecrementButton 157579 "Answer a new decrement button." 157580 157581 ^(UITheme builder 157582 newButtonFor: self 157583 action: #decrement 157584 getEnabled: #minEnabled 157585 label: (self newButtonLabel: #left ofSize: 24) 157586 help: nil) 157587 vResizing: #spaceFill; 157588 width: 64; 157589 roundedCorners: #(1 2); 157590 setProperty: #wantsKeyboardFocusNavigation toValue: false; 157591 on: #mouseStillDown send: #decrement to: self! ! 157592 157593!IncrementalSliderMorph methodsFor: 'initialize-release' stamp: 'gvc 9/8/2009 13:13'! 157594newIncrementButton 157595 "Answer a new increment button." 157596 157597 ^(UITheme builder 157598 newButtonFor: self 157599 action: #increment 157600 getEnabled: #maxEnabled 157601 label: (self newButtonLabel: #right ofSize: 24) 157602 help: nil) 157603 vResizing: #spaceFill; 157604 width: 64; 157605 roundedCorners: #(3 4); 157606 setProperty: #wantsKeyboardFocusNavigation toValue: false; 157607 on: #mouseStillDown send: #increment to: self! ! 157608 157609!IncrementalSliderMorph methodsFor: 'initialize-release' stamp: 'gvc 9/10/2009 13:36'! 157610newSliderMorph 157611 "Answer a new morph for the slider." 157612 157613 |slider| 157614 slider := UITheme builder 157615 newBracketSliderFor: self 157616 getValue: #value 157617 setValue: #value: 157618 min: 0 157619 max: 100 157620 quantum: 1 157621 getEnabled: #enabled 157622 help: nil. 157623 slider fillStyle: self defaultSliderFillStyle. 157624 ^slider! ! 157625 157626 157627!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2009 13:16'! 157628enabled 157629 "Answer whether the receiver is enabled for user input." 157630 157631 ^self sliderMorph 157632 ifNil: [super enabled] 157633 ifNotNilDo: [:sm | sm enabled]! ! 157634 157635!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2009 13:27'! 157636enabled: aBoolean 157637 "Set whether the receiver is enabled for user input." 157638 157639 self sliderMorph ifNotNilDo: [:sm | sm enabled: aBoolean]. 157640 self 157641 changed: #enabled; 157642 changed: #minEnabled; 157643 changed: #maxEnabled! ! 157644 157645!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/10/2009 13:37'! 157646getEnabledSelector 157647 "Answer the value of getEnabledSelector" 157648 157649 ^ getEnabledSelector! ! 157650 157651!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/10/2009 13:37'! 157652getEnabledSelector: aSymbol 157653 "Set the value of getEnabledSelector" 157654 157655 getEnabledSelector := aSymbol. 157656 self updateEnabled! ! 157657 157658!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 13:57'! 157659getValueSelector 157660 "Answer the value of getValueSelector" 157661 157662 ^ getValueSelector! ! 157663 157664!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 13:57'! 157665getValueSelector: anObject 157666 "Set the value of getValueSelector" 157667 157668 getValueSelector := anObject! ! 157669 157670!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:31'! 157671max 157672 "Answer the max value." 157673 157674 ^(self sliderMorph ifNil: [^0]) max! ! 157675 157676!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:55'! 157677max: aNumber 157678 "Set the max value." 157679 157680 (self sliderMorph ifNil: [^self]) max: aNumber! ! 157681 157682!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:31'! 157683min 157684 "Answer the min value." 157685 157686 ^(self sliderMorph ifNil: [^0]) min! ! 157687 157688!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:55'! 157689min: aNumber 157690 "Set the min value." 157691 157692 (self sliderMorph ifNil: [^self]) min: aNumber! ! 157693 157694!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:31'! 157695quantum 157696 "Answer the quantum value." 157697 157698 ^(self sliderMorph ifNil: [^0]) quantum! ! 157699 157700!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:55'! 157701quantum: aNumber 157702 "Set the quantum value." 157703 157704 (self sliderMorph ifNil: [^self]) quantum: aNumber! ! 157705 157706!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 13:57'! 157707setValueSelector 157708 "Answer the value of setValueSelector" 157709 157710 ^ setValueSelector! ! 157711 157712!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 13:57'! 157713setValueSelector: anObject 157714 "Set the value of setValueSelector" 157715 157716 setValueSelector := anObject! ! 157717 157718!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:18'! 157719sliderMorph 157720 "Answer the value of sliderMorph" 157721 157722 ^ sliderMorph! ! 157723 157724!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:18'! 157725sliderMorph: anObject 157726 "Set the value of sliderMorph" 157727 157728 sliderMorph := anObject! ! 157729 157730!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/4/2009 16:15'! 157731value 157732 "Answer the slider value." 157733 157734 ^self getValueSelector 157735 ifNil: [(self sliderMorph ifNil: [^0]) scaledValue] 157736 ifNotNil: [self model 157737 ifNil: [(self sliderMorph ifNil: [^0]) scaledValue] 157738 ifNotNil: [self model perform: self getValueSelector]]! ! 157739 157740!IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2009 13:17'! 157741value: aNumber 157742 "Set the slider value." 157743 157744 (self sliderMorph ifNil: [^self]) scaledValue: aNumber. 157745 self model ifNotNil: [ 157746 self setValueSelector ifNotNil: [ 157747 self model perform: self setValueSelector with: self sliderMorph scaledValue]]. 157748 self changed: #minEnabled; changed: #maxEnabled! ! 157749 157750"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 157751 157752IncrementalSliderMorph class 157753 instanceVariableNames: ''! 157754 157755!IncrementalSliderMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:02'! 157756on: anObject getValue: getSel setValue: setSel 157757 "Answer a new instance of the receiver with 157758 the given selectors as the interface." 157759 157760 ^self new 157761 on: anObject 157762 getValue: getSel 157763 setValue: setSel! ! 157764 157765!IncrementalSliderMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:01'! 157766on: anObject getValue: getSel setValue: setSel min: min max: max quantum: quantum 157767 "Answer a new instance of the receiver with 157768 the given selectors as the interface." 157769 157770 ^self new 157771 min: min; 157772 max: max; 157773 quantum: quantum; 157774 on: anObject 157775 getValue: getSel 157776 setValue: setSel! ! 157777StringMorph subclass: #IndentingListItemMorph 157778 instanceVariableNames: 'indentLevel isExpanded complexContents firstChild container nextSibling icon' 157779 classVariableNames: '' 157780 poolDictionaries: '' 157781 category: 'Tools-Explorer'! 157782!IndentingListItemMorph commentStamp: '<historical>' prior: 0! 157783An IndentingListItemMorph is a StringMorph that draws itself with an optional toggle at its left, as part of the display of the SimpleHierarchicalListMorph. 157784 157785It will also display lines around the toggle if the #showLinesInHierarchyViews Preference is set. 157786 157787Instance variables: 157788 157789indentLevel <SmallInteger> the indent level, from 0 at the root and increasing by 1 at each level of the hierarchy. 157790 157791isExpanded <Boolean> true if this item is expanded (showing its children) 157792 157793complexContents <ListItemWrapper> an adapter wrapping my represented item that can answer its children, etc. 157794 157795firstChild <IndentingListItemMorph|nil> my first child, or nil if none 157796 157797container <SimpleHierarchicalListMorph> my container 157798 157799nextSibling <IndentingListItemMorph|nil> the next item in the linked list of siblings, or nil if none. 157800 157801Contributed by Bob Arning as part of the ObjectExplorer package. 157802Don't blame him if it's not perfect. We wanted to get it out for people to play with.! 157803 157804 157805!IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 10:47'! 157806changed 157807 "Need to invalidate the selection frame." 157808 157809 container ifNil: [^super changed]. 157810 self invalidRect: self selectionFrame. 157811 super changed! ! 157812 157813!IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/12/2006 15:34'! 157814drawMouseDownHighlightOn: aCanvas 157815 "Draw with a dotted border." 157816 157817 |frame| 157818 self highlightedForMouseDown ifTrue: [ 157819 container ifNil: [^super drawMouseDownHighlightOn: aCanvas]. 157820 frame := self selectionFrame. 157821 aCanvas 157822 frameRectangle: frame 157823 width: 1 157824 colors: {container mouseDownHighlightColor. Color transparent} 157825 dashes: #(1 1)]! ! 157826 157827!IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 13:56'! 157828lastChild 157829 "Answer the last child." 157830 157831 |c| 157832 c := self firstChild ifNil: [^nil]. 157833 [c nextSibling isNil] whileFalse: [c := c nextSibling]. 157834 ^c! ! 157835 157836!IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 11/15/2007 14:26'! 157837openItemPath: anArray 157838 "Open a path based on wrapper item equivalence. Generally more specific 157839 than #openPath: (string based)." 157840 157841 | found | 157842 anArray isEmpty 157843 ifTrue: [^ container setSelectedMorph: nil]. 157844 found := nil. 157845 self 157846 withSiblingsDo: [:each | found 157847 ifNil: [(each complexContents withoutListWrapper == anArray first 157848 or: [anArray first isNil]) 157849 ifTrue: [found := each]]]. 157850 found 157851 ifNotNil: [found isExpanded 157852 ifFalse: [found toggleExpandedState. 157853 container adjustSubmorphPositions]. 157854 found changed. 157855 anArray size = 1 157856 ifTrue: [^ container setSelectedMorph: found]. 157857 ^ found firstChild 157858 ifNil: [container setSelectedMorph: nil] 157859 ifNotNil: [found firstChild openItemPath: anArray allButFirst]]. 157860 ^container setSelectedMorph: nil! ! 157861 157862!IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 13:56'! 157863outerBounds 157864 "Return the 'outer' bounds of the receiver, e.g., the bounds that need to be invalidated when the receiver changes." 157865 157866 |box| 157867 box := super outerBounds. 157868 container ifNil: [^box]. 157869 ^box left: (box left min: self selectionFrame left)! ! 157870 157871!IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/12/2006 15:34'! 157872selectionFrame 157873 "Answer the selection frame rectangle." 157874 157875 |frame| 157876 frame := self bounds: self bounds in: container. 157877 frame := self 157878 bounds: ((frame left: container innerBounds left) right: container innerBounds right) 157879 from: container. 157880 ^frame! ! 157881 157882!IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/5/2007 15:07'! 157883theme 157884 "Answer the ui theme that provides controls. 157885 Done directly here to avoid performance hit of 157886 looking up in window." 157887 157888 ^UITheme current! ! 157889 157890 157891!IndentingListItemMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2009 13:55'! 157892drawLineToggleToTextOn: aCanvas lineColor: lineColor hasToggle: hasToggle 157893 "If I am not the only item in my container, draw the line between: 157894 - my toggle (if any) or my left edge (if no toggle) 157895 - and my text left edge. 157896 Only draw now if no toggle." 157897 157898 | myBounds myCenter hLineY hLineLeft myTheme| 157899 self isSoleItem ifTrue: [ ^self ]. 157900 self hasToggle ifTrue: [^self]. 157901 myBounds := self toggleBounds. 157902 myCenter := myBounds center. 157903 hLineY := myCenter y - 1. 157904 hLineLeft := myCenter x. 157905 "Draw line from toggle to text. Use optimised form since vertical." 157906 myTheme := self theme. 157907 aCanvas 157908 frameRectangle: (hLineLeft @ hLineY corner: myBounds right + 3 @ (hLineY + 1)) 157909 width: myTheme treeLineWidth 157910 colors: (myTheme treeLineColorsFrom: lineColor) 157911 dashes: myTheme treeLineDashes! ! 157912 157913!IndentingListItemMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2009 13:55'! 157914drawLinesToFirstChildOn: aCanvas lineColor: lineColor 157915 "Draw line from me to first child. 157916 Don't bother if the first child has a toggle.." 157917 157918 | vLineX vLineTop vLineBottom childBounds childCenter myTheme| 157919 self firstChild hasToggle ifTrue: [^self]. 157920 childBounds := self firstChild toggleBounds. 157921 childCenter := childBounds center. 157922 vLineX := childCenter x. 157923 vLineTop := bounds bottom. 157924 self firstChild hasToggle 157925 ifTrue: [vLineBottom := childCenter y - (childBounds height // 2) + 1] 157926 ifFalse: [vLineBottom := childCenter y - 2]. 157927 myTheme := self theme. 157928 aCanvas 157929 frameRectangle: (vLineX @ vLineTop corner: vLineX + 1 @ vLineBottom) 157930 width: myTheme treeLineWidth 157931 colors: (myTheme treeLineColorsFrom: lineColor) 157932 dashes: myTheme treeLineDashes! ! 157933 157934!IndentingListItemMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2009 13:55'! 157935drawLinesToNextSiblingOn: aCanvas lineColor: lineColor hasToggle: hasToggle 157936 "Draw line from me to next sibling" 157937 157938 | myBounds nextSibBounds vLineX myCenter vLineTop vLineBottom myTheme| 157939 myBounds := self toggleBounds. 157940 nextSibBounds := self nextSibling toggleBounds. 157941 myCenter := myBounds center. 157942 vLineX := myCenter x. 157943 vLineTop := myCenter y + 1. 157944 vLineBottom := nextSibBounds center y - 1. 157945 "Draw line from me to next sibling" 157946 myTheme := self theme. 157947 aCanvas 157948 frameRectangle: (vLineX @ vLineTop corner: vLineX + 1 @ vLineBottom) 157949 width: myTheme treeLineWidth 157950 colors: (myTheme treeLineColorsFrom: lineColor) 157951 dashes: myTheme treeLineDashes! ! 157952 157953!IndentingListItemMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/5/2007 14:55'! 157954drawToggleOn: aCanvas in: aRectangle 157955 157956 | aForm centeringOffset | 157957 complexContents hasContents ifFalse: [^self]. 157958 aForm := isExpanded 157959 ifTrue: [container expandedForm] 157960 ifFalse: [container notExpandedForm]. 157961 centeringOffset := ((aRectangle height - aForm extent y) / 2.0) truncated. 157962 ^aCanvas 157963 translucentImage: aForm 157964 at: (aRectangle topLeft translateBy: 0 @ centeringOffset). 157965! ! 157966 157967!IndentingListItemMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/15/2007 13:17'! 157968minHeight 157969 "Answer the minimum height of the receiver." 157970 157971 | iconHeight | 157972 iconHeight := self hasIcon 157973 ifTrue: [self icon height + 2] 157974 ifFalse: [0]. 157975 ^(self fontToUse height max: iconHeight) max: super minHeight! ! 157976 157977!IndentingListItemMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/15/2007 13:15'! 157978minWidth 157979 "Fixed to work such that guessed width is unnecessary in 157980 #adjustSubmorphPositions." 157981 157982 | iconWidth | 157983 iconWidth := self hasIcon 157984 ifTrue: [self icon width + 2] 157985 ifFalse: [0]. 157986 ^(13 * indentLevel + 15 + (self fontToUse widthOfString: contents) 157987 + iconWidth) max: super minWidth! ! 157988 157989!IndentingListItemMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/25/2007 19:42'! 157990toggleRectangle 157991 157992 | h | 157993 h := bounds height. 157994 ^(bounds left + (13 * indentLevel)) @ bounds top extent: 9@h! ! 157995 157996 157997!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/21/2000 11:00'! 157998balloonText 157999 158000 ^complexContents balloonText ifNil: [super balloonText]! ! 158001 158002!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 3/31/1999 17:44'! 158003canExpand 158004 158005 ^complexContents hasContents! ! 158006 158007!IndentingListItemMorph methodsFor: 'accessing' stamp: 'panda 4/28/2000 15:30'! 158008children 158009 | children | 158010 children := OrderedCollection new. 158011 self childrenDo: [:each | children add: each]. 158012 ^children! ! 158013 158014!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 8/2/1999 16:48'! 158015firstChild 158016 158017 ^firstChild! ! 158018 158019!IndentingListItemMorph methodsFor: 'accessing' stamp: 'dgd 9/25/2004 22:25'! 158020hasIcon 158021 "Answer whether the receiver has an icon." 158022 ^ icon notNil! ! 158023 158024!IndentingListItemMorph methodsFor: 'accessing' stamp: 'dgd 9/25/2004 22:27'! 158025icon 158026 "answer the receiver's icon" 158027 ^ icon! ! 158028 158029!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/30/2000 19:15'! 158030indentLevel 158031 158032 ^indentLevel! ! 158033 158034!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/31/1998 00:30'! 158035isExpanded 158036 158037 ^isExpanded! ! 158038 158039!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/31/1998 00:48'! 158040isExpanded: aBoolean 158041 158042 isExpanded := aBoolean! ! 158043 158044!IndentingListItemMorph methodsFor: 'accessing' stamp: 'nk 3/8/2004 09:14'! 158045isFirstItem 158046 ^owner submorphs first == self! ! 158047 158048!IndentingListItemMorph methodsFor: 'accessing' stamp: 'nk 3/8/2004 09:15'! 158049isSoleItem 158050 ^self isFirstItem and: [ owner submorphs size = 1 ]! ! 158051 158052!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/11/1998 12:15'! 158053nextSibling 158054 158055 ^nextSibling! ! 158056 158057!IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 8/1/1998 01:05'! 158058nextSibling: anotherMorph 158059 158060 nextSibling := anotherMorph! ! 158061 158062!IndentingListItemMorph methodsFor: 'accessing' stamp: 'bf 2/9/2004 10:55'! 158063userString 158064 "Add leading tabs to my userString" 158065 ^ (String new: indentLevel withAll: Character tab), super userString 158066! ! 158067 158068 158069!IndentingListItemMorph methodsFor: 'converting' stamp: 'RAA 3/31/1999 12:13'! 158070withoutListWrapper 158071 158072 ^complexContents withoutListWrapper! ! 158073 158074 158075!IndentingListItemMorph methodsFor: 'drag and drop' stamp: 'nk 6/12/2004 16:49'! 158076acceptDroppingMorph: toDrop event: evt 158077 complexContents acceptDroppingObject: toDrop complexContents. 158078 toDrop delete. 158079 self highlightForDrop: false.! ! 158080 158081 158082!IndentingListItemMorph methodsFor: 'drawing' stamp: 'nk 3/8/2004 11:43'! 158083drawLinesOn: aCanvas lineColor: lineColor 158084 | hasToggle | 158085 hasToggle := self hasToggle. 158086 "Draw line from toggle to text" 158087 self drawLineToggleToTextOn: aCanvas lineColor: lineColor hasToggle: hasToggle. 158088 158089 "Draw the line from my toggle to the nextSibling's toggle" 158090 self nextSibling ifNotNil: [ self drawLinesToNextSiblingOn: aCanvas lineColor: lineColor hasToggle: hasToggle ]. 158091 158092 "If I have children and am expanded, draw a line to my first child" 158093 (self firstChild notNil and: [ self isExpanded ]) 158094 ifTrue: [ self drawLinesToFirstChildOn: aCanvas lineColor: lineColor]! ! 158095 158096!IndentingListItemMorph methodsFor: 'drawing' stamp: 'damiencassou 5/30/2008 16:29'! 158097drawOn: aCanvas 158098 | tRect sRect columnRect columnScanner columnData columnLeft colorToUse | 158099 tRect := self toggleRectangle. 158100 sRect := bounds withLeft: tRect right + 4. 158101 self 158102 drawToggleOn: aCanvas 158103 in: tRect. 158104 colorToUse := complexContents preferredColor ifNil: [ color ]. 158105 icon isNil ifFalse: 158106 [ aCanvas 158107 translucentImage: icon 158108 at: sRect left @ (self top + ((self height - icon height) // 2)). 158109 sRect := sRect left: sRect left + icon width + 2 ]. 158110 (container columns isNil or: [ (contents asString indexOf: Character tab) = 0 ]) 158111 ifTrue: 158112 [ sRect := sRect top: (sRect top + sRect bottom - self fontToUse height) // 2. 158113 aCanvas 158114 drawString: contents asString 158115 in: sRect 158116 font: self fontToUse 158117 color: colorToUse ] 158118 ifFalse: 158119 [ columnLeft := sRect left. 158120 columnScanner := contents asString readStream. 158121 container columns do: 158122 [ :width | 158123 columnRect := columnLeft @ sRect top extent: width @ sRect height. 158124 columnData := columnScanner upTo: Character tab. 158125 columnData isEmpty ifFalse: 158126 [ aCanvas 158127 drawString: columnData 158128 in: columnRect 158129 font: self fontToUse 158130 color: colorToUse ]. 158131 columnLeft := columnRect right + 5 ] ]! ! 158132 158133!IndentingListItemMorph methodsFor: 'drawing' stamp: 'RAA 8/3/1999 09:46'! 158134unhighlight 158135 158136 complexContents highlightingColor ifNotNil: [self color: Color black]. 158137 self changed. 158138 158139 158140! ! 158141 158142 158143!IndentingListItemMorph methodsFor: 'enumeration' stamp: 'panda 4/28/2000 15:29'! 158144childrenDo: aBlock 158145 158146 firstChild ifNotNil: [ 158147 firstChild withSiblingsDo: [ :aNode | aBlock value: aNode]. 158148 ]! ! 158149 158150 158151!IndentingListItemMorph methodsFor: 'halos and balloon help' stamp: 'RAA 7/21/2000 11:13'! 158152boundsForBalloon 158153 158154 "some morphs have bounds that are way too big" 158155 container ifNil: [^super boundsForBalloon]. 158156 ^self boundsInWorld intersect: container boundsInWorld! ! 158157 158158 158159!IndentingListItemMorph methodsFor: 'initialization' stamp: 'dgd 9/25/2004 22:33'! 158160initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel 158161 158162 container := hostList. 158163 complexContents := anObject. 158164 self initWithContents: anObject asString font: Preferences standardListFont emphasis: nil. 158165 indentLevel := 0. 158166 isExpanded := false. 158167 nextSibling := firstChild := nil. 158168 priorMorph ifNotNil: [ 158169 priorMorph nextSibling: self. 158170 ]. 158171 indentLevel := newLevel. 158172 icon := anObject icon. 158173 self extent: self minWidth @ self minHeight! ! 158174 158175!IndentingListItemMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42'! 158176initialize 158177"initialize the state of the receiver" 158178 super initialize. 158179"" 158180 indentLevel := 0. 158181 isExpanded := false! ! 158182 158183 158184!IndentingListItemMorph methodsFor: 'mouse events' stamp: 'ar 3/17/2001 17:32'! 158185inToggleArea: aPoint 158186 158187 ^self toggleRectangle containsPoint: aPoint! ! 158188 158189 158190!IndentingListItemMorph methodsFor: 'private' stamp: 'nk 2/19/2004 18:29'! 158191hasToggle 158192 ^ complexContents hasContents! ! 158193 158194!IndentingListItemMorph methodsFor: 'private' stamp: 'nk 12/5/2002 15:16'! 158195toggleBounds 158196 ^self toggleRectangle! ! 158197 158198!IndentingListItemMorph methodsFor: 'private' stamp: 'RAA 7/11/1998 14:25'! 158199withSiblingsDo: aBlock 158200 158201 | node | 158202 node := self. 158203 [node isNil] whileFalse: [ 158204 aBlock value: node. 158205 node := node nextSibling 158206 ].! ! 158207 158208 158209!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 7/30/2000 19:49'! 158210addChildrenForList: hostList addingTo: morphList withExpandedItems: expandedItems 158211 158212 firstChild ifNotNil: [ 158213 firstChild withSiblingsDo: [ :aNode | aNode delete]. 158214 ]. 158215 firstChild := nil. 158216 complexContents hasContents ifFalse: [^self]. 158217 firstChild := hostList 158218 addMorphsTo: morphList 158219 from: complexContents contents 158220 allowSorting: true 158221 withExpandedItems: expandedItems 158222 atLevel: indentLevel + 1. 158223 ! ! 158224 158225!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 7/11/1998 14:34'! 158226complexContents 158227 158228 ^complexContents! ! 158229 158230!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 8/3/1999 09:47'! 158231highlight 158232 158233 complexContents highlightingColor ifNotNil: [self color: complexContents highlightingColor]. 158234 self changed. 158235 158236! ! 158237 158238!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'nk 10/14/2003 10:36'! 158239openPath: anArray 158240 | found | 158241 anArray isEmpty 158242 ifTrue: [^ container setSelectedMorph: nil]. 158243 found := nil. 158244 self 158245 withSiblingsDo: [:each | found 158246 ifNil: [(each complexContents asString = anArray first 158247 or: [anArray first isNil]) 158248 ifTrue: [found := each]]]. 158249 found 158250 ifNil: ["try again with no case sensitivity" 158251 self 158252 withSiblingsDo: [:each | found 158253 ifNil: [(each complexContents asString sameAs: anArray first) 158254 ifTrue: [found := each]]]]. 158255 found 158256 ifNotNil: [found isExpanded 158257 ifFalse: [found toggleExpandedState. 158258 container adjustSubmorphPositions]. 158259 found changed. 158260 anArray size = 1 158261 ifTrue: [^ container setSelectedMorph: found]. 158262 ^ found firstChild 158263 ifNil: [container setSelectedMorph: nil] 158264 ifNotNil: [found firstChild openPath: anArray allButFirst]]. 158265 ^ container setSelectedMorph: nil! ! 158266 158267!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 6/21/1999 14:54'! 158268recursiveAddTo: aCollection 158269 158270 firstChild ifNotNil: [ 158271 firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: aCollection]. 158272 ]. 158273 aCollection add: self 158274 ! ! 158275 158276!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 4/2/1999 18:02'! 158277recursiveDelete 158278 158279 firstChild ifNotNil: [ 158280 firstChild withSiblingsDo: [ :aNode | aNode recursiveDelete]. 158281 ]. 158282 self delete 158283 ! ! 158284 158285!IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 7/30/2000 19:17'! 158286toggleExpandedState 158287 158288 | newChildren toDelete c | 158289 158290 isExpanded := isExpanded not. 158291 toDelete := OrderedCollection new. 158292 firstChild ifNotNil: [ 158293 firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: toDelete]. 158294 ]. 158295 container noteRemovalOfAll: toDelete. 158296 (isExpanded and: [complexContents hasContents]) ifFalse: [ 158297 ^self changed 158298 ]. 158299 (c := complexContents contents) isEmpty ifTrue: [^self changed]. 158300 newChildren := container 158301 addSubmorphsAfter: self 158302 fromCollection: c 158303 allowSorting: true. 158304 firstChild := newChildren first. 158305! ! 158306DisplayObject subclass: #InfiniteForm 158307 instanceVariableNames: 'patternForm' 158308 classVariableNames: '' 158309 poolDictionaries: '' 158310 category: 'Graphics-Display Objects'! 158311!InfiniteForm commentStamp: '<historical>' prior: 0! 158312I represent a Form obtained by replicating a pattern form indefinitely in all directions.! 158313 158314 158315!InfiniteForm methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/21/2008 16:37'! 158316fillRectangle: aRectangle on: aCanvas 158317 "Fill the given rectangle on the given canvas with the receiver." 158318 158319 aCanvas fillRectangle: aRectangle basicFillStyle: self! ! 158320 158321 158322!InfiniteForm methodsFor: 'accessing' stamp: 'mjg 7/9/2001 14:12'! 158323asColor 158324 ^ patternForm dominantColor! ! 158325 158326!InfiniteForm methodsFor: 'accessing'! 158327asForm 158328 ^ patternForm! ! 158329 158330!InfiniteForm methodsFor: 'accessing' stamp: 'di 9/2/97 20:21'! 158331dominantColor 158332 ^ patternForm dominantColor! ! 158333 158334!InfiniteForm methodsFor: 'accessing'! 158335offset 158336 "Refer to the comment in DisplayObject|offset." 158337 158338 ^0 @ 0! ! 158339 158340 158341!InfiniteForm methodsFor: 'as yet unclassified' stamp: 'RAA 6/1/2000 10:50'! 158342addFillStyleMenuItems: aMenu hand: aHand from: aMorph 158343 "Add the items for changing the current fill style of the receiver" 158344 158345 "prevents a walkback when control menu is built for morph with me as color"! ! 158346 158347 158348!InfiniteForm methodsFor: 'display box access'! 158349computeBoundingBox 158350 "Refer to the comment in DisplayObject|computeBoundingBox." 158351 158352 ^0 @ 0 corner: SmallInteger maxVal @ SmallInteger maxVal! ! 158353 158354 158355!InfiniteForm methodsFor: 'displaying' stamp: 'sw 2/16/98 03:42'! 158356colorForInsets 158357 ^ Color transparent! ! 158358 158359!InfiniteForm methodsFor: 'displaying' stamp: 'nk 4/17/2004 19:48'! 158360displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 158361 "This is the real display message, but it doesn't get used until the new 158362 display protocol is installed." 158363 | targetBox patternBox bb | 158364 (patternForm isForm) ifFalse: 158365 [^ aDisplayMedium fill: clipRectangle rule: ruleInteger fillColor: patternForm]. 158366 158367 "Do it iteratively" 158368 targetBox := aDisplayMedium boundingBox intersect: clipRectangle. 158369 patternBox := patternForm boundingBox. 158370 bb := BitBlt current destForm: aDisplayMedium sourceForm: patternForm fillColor: aForm 158371 combinationRule: ruleInteger destOrigin: 0@0 sourceOrigin: 0@0 158372 extent: patternBox extent clipRect: clipRectangle. 158373 bb colorMap: 158374 (patternForm colormapIfNeededFor: aDisplayMedium). 158375 (targetBox left truncateTo: patternBox width) 158376 to: targetBox right - 1 by: patternBox width do: 158377 [:x | 158378 (targetBox top truncateTo: patternBox height) 158379 to: targetBox bottom - 1 by: patternBox height do: 158380 [:y | 158381 bb destOrigin: x@y; copyBits]]! ! 158382 158383!InfiniteForm methodsFor: 'displaying' stamp: 'nk 4/17/2004 19:48'! 158384displayOnPort: aPort at: offset 158385 158386 | targetBox patternBox savedMap top left | 158387 158388 self flag: #bob. 158389 158390 "this *may* not get called at the moment. I have been trying to figure out the right way for this to work and am using #displayOnPort:offsetBy: as my current offering - Bob" 158391 158392 (patternForm isForm) ifFalse: [ 158393 "patternForm is a Pattern or Color; just use it as a mask for BitBlt" 158394 ^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over]. 158395 158396 "do it iteratively" 158397 targetBox := aPort clipRect. 158398 patternBox := patternForm boundingBox. 158399 savedMap := aPort colorMap. 158400 aPort sourceForm: patternForm; 158401 fillColor: nil; 158402 combinationRule: Form paint; 158403 sourceRect: (0@0 extent: patternBox extent); 158404 colorMap: (patternForm colormapIfNeededFor: aPort destForm). 158405 top := (targetBox top truncateTo: patternBox height) "- (offset y \\ patternBox height)". 158406 left := (targetBox left truncateTo: patternBox width) "- (offset x \\ patternBox width)". 158407 left to: (targetBox right - 1) by: patternBox width do: 158408 [:x | top to: (targetBox bottom - 1) by: patternBox height do: 158409 [:y | aPort destOrigin: x@y; copyBits]]. 158410 aPort colorMap: savedMap. 158411! ! 158412 158413!InfiniteForm methodsFor: 'displaying' stamp: 'nk 4/17/2004 19:48'! 158414displayOnPort: aPort offsetBy: offset 158415 158416 | targetBox patternBox savedMap top left | 158417 158418 "this version tries to get the form aligned where the user wants it and not just aligned with the cliprect" 158419 158420 (patternForm isForm) ifFalse: [ 158421 "patternForm is a Pattern or Color; just use it as a mask for BitBlt" 158422 ^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over]. 158423 158424 "do it iteratively" 158425 targetBox := aPort clipRect. 158426 patternBox := patternForm boundingBox. 158427 savedMap := aPort colorMap. 158428 aPort sourceForm: patternForm; 158429 fillColor: nil; 158430 combinationRule: Form paint; 158431 sourceRect: (0@0 extent: patternBox extent); 158432 colorMap: (patternForm colormapIfNeededFor: aPort destForm). 158433 top := (targetBox top truncateTo: patternBox height) + offset y. 158434 left := (targetBox left truncateTo: patternBox width) + offset x. 158435 158436 left to: (targetBox right - 1) by: patternBox width do: 158437 [:x | top to: (targetBox bottom - 1) by: patternBox height do: 158438 [:y | aPort destOrigin: x@y; copyBits]]. 158439 aPort colorMap: savedMap. 158440! ! 158441 158442!InfiniteForm methodsFor: 'displaying' stamp: 'ar 8/16/2001 12:47'! 158443raisedColor 158444 ^ Color transparent! ! 158445 158446 158447!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'bolot 9/15/1999 10:13'! 158448bitPatternForDepth: suspectedDepth 158449 ^ patternForm! ! 158450 158451!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'! 158452direction 158453 ^patternForm width @ 0! ! 158454 158455!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'! 158456form 158457 "Bitmap fills respond to #form" 158458 ^patternForm! ! 158459 158460!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'! 158461isBitmapFill 158462 ^true! ! 158463 158464!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'! 158465isGradientFill 158466 ^false! ! 158467 158468!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:59'! 158469isOrientedFill 158470 ^true! ! 158471 158472!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'! 158473isSolidFill 158474 ^false! ! 158475 158476!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:55'! 158477isTiled 158478 "Return true if the receiver should be drawn as a tiled pattern" 158479 ^true! ! 158480 158481!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 9/2/1999 14:32'! 158482isTranslucent 158483 "Return true since the bitmap may be translucent and we don't really want to check" 158484 ^true! ! 158485 158486!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:57'! 158487normal 158488 ^0 @ patternForm height! ! 158489 158490!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'! 158491origin 158492 ^0@0! ! 158493 158494!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'! 158495origin: aPoint 158496 "Ignored" 158497! ! 158498 158499 158500!InfiniteForm methodsFor: 'private'! 158501form: aForm 158502 158503 patternForm := aForm! ! 158504 158505"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 158506 158507InfiniteForm class 158508 instanceVariableNames: ''! 158509 158510!InfiniteForm class methodsFor: 'instance creation'! 158511with: aForm 158512 "Answer an instance of me whose pattern form is the argument, aForm." 158513 158514 ^self new form: aForm! ! 158515ReadStream subclass: #InflateStream 158516 instanceVariableNames: 'state bitBuf bitPos source sourcePos sourceLimit litTable distTable sourceStream crc' 158517 classVariableNames: 'BlockProceedBit BlockTypes FixedDistCodes FixedLitCodes MaxBits StateNewBlock StateNoMoreData' 158518 poolDictionaries: '' 158519 category: 'Compression-Streams'! 158520!InflateStream commentStamp: '<historical>' prior: 0! 158521This class implements the Inflate decompression algorithm as defined by RFC1951 and used in PKZip, GZip and ZLib (and many, many more). It is a variant of the LZ77 compression algorithm described in 158522 158523[LZ77] Ziv J., Lempel A., "A Universal Algorithm for Sequential Data Compression", IEEE Transactions on Information Theory", Vol. 23, No. 3, pp. 337-343. 158524 158525[RFC1951] Deutsch. P, "DEFLATE Compressed Data Format Specification version 1.3" 158526 158527For more information see the above mentioned RFC 1951 which can for instance be found at 158528 158529 http://www.leo.org/pub/comp/doc/standards/rfc/index.html 158530 158531Huffman Tree Implementation Notes: 158532=========================================== 158533The huffman tree used for decoding literal, distance and length codes in the inflate algorithm has been encoded in a single Array. The tree is made up of subsequent tables storing all entries at the current bit depth. Each entry in the table (e.g., a 32bit Integer value) is either a leaf or a non-leaf node. Leaf nodes store the immediate value in its low 16 bits whereas non-leaf nodes store the offset of the subtable in its low 16bits. The high 8 bits of non-leaf nodes contain the number of additional bits needed for the sub table (the high 8 bits of leaf-nodes are always zero). The first entry in each table is always a non-leaf node indicating how many bits we need to fetch initially. We can thus travel down the tree as follows (written in sort-of-pseudocode the actual implementation can be seen in InflateStream>>decodeValueFrom:): 158534 158535 table _ initialTable. 158536 bitsNeeded _ high 8 bits of (table at: 1). "Determine initial bits" 158537 table _ initialTable + (low 16 bits of (table at: 1)). "Determine start of first real table" 158538 [bits _ fetch next bitsNeeded bits. "Grab the bits" 158539 value _ table at: bits. "Lookup the value" 158540 value has high 8 bit set] whileTrue:[ "Check if it's leaf" 158541 table _ initialTable + (low 16 bits of value). "No - compute new sub table start" 158542 bitsNeeded _ high 8 bit of value]. "Compute additional number of bits needed" 158543 ^value 158544! 158545 158546 158547!InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:31'! 158548close 158549 sourceStream ifNotNil:[sourceStream close].! ! 158550 158551!InflateStream methodsFor: 'accessing' stamp: 'tk 2/4/2000 10:26'! 158552contents 158553 158554 ^ self upToEnd! ! 158555 158556!InflateStream methodsFor: 'accessing' stamp: 'ar 12/22/1999 01:29'! 158557next 158558 "Answer the next decompressed object in the Stream represented by the 158559 receiver." 158560 158561 <primitive: 65> 158562 position >= readLimit 158563 ifTrue: [^self pastEndRead] 158564 ifFalse: [^collection at: (position := position + 1)]! ! 158565 158566!InflateStream methodsFor: 'accessing' stamp: 'nk 3/7/2004 18:45'! 158567next: anInteger 158568 "Answer the next anInteger elements of my collection. overriden for simplicity" 158569 | newArray | 158570 158571 "try to do it the fast way" 158572 position + anInteger < readLimit ifTrue: [ 158573 newArray := collection copyFrom: position + 1 to: position + anInteger. 158574 position := position + anInteger. 158575 ^newArray 158576 ]. 158577 158578 "oh, well..." 158579 newArray := collection species new: anInteger. 158580 1 to: anInteger do: [:index | newArray at: index put: (self next ifNil: [ ^newArray copyFrom: 1 to: index - 1]) ]. 158581 ^newArray! ! 158582 158583!InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 16:06'! 158584next: n into: buffer startingAt: startIndex 158585 "Read n objects into the given collection. 158586 Return aCollection or a partial copy if less than 158587 n elements have been read." 158588 | c numRead count | 158589 numRead := 0. 158590 ["Force decompression if necessary" 158591 (c := self next) == nil 158592 ifTrue:[^buffer copyFrom: 1 to: startIndex+numRead-1]. 158593 "Store the first value which provoked decompression" 158594 buffer at: startIndex + numRead put: c. 158595 numRead := numRead + 1. 158596 "After collection has been filled copy as many objects as possible" 158597 count := (readLimit - position) min: (n - numRead). 158598 buffer 158599 replaceFrom: startIndex + numRead 158600 to: startIndex + numRead + count - 1 158601 with: collection 158602 startingAt: position+1. 158603 position := position + count. 158604 numRead := numRead + count. 158605 numRead = n] whileFalse. 158606 ^buffer! ! 158607 158608!InflateStream methodsFor: 'accessing' stamp: 'ar 12/3/1998 16:19'! 158609size 158610 "This is a compressed stream - we don't know the size beforehand" 158611 ^self shouldNotImplement! ! 158612 158613!InflateStream methodsFor: 'accessing' stamp: 'ar 12/21/1999 23:54'! 158614sourceLimit 158615 ^sourceLimit! ! 158616 158617!InflateStream methodsFor: 'accessing' stamp: 'ar 12/21/1999 23:52'! 158618sourcePosition 158619 ^sourcePos! ! 158620 158621!InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:31'! 158622sourceStream 158623 ^sourceStream! ! 158624 158625!InflateStream methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:00'! 158626upTo: anObject 158627 "Answer a subcollection from the current access position to the 158628 occurrence (if any, but not inclusive) of anObject in the receiver. If 158629 anObject is not in the collection, answer the entire rest of the receiver." 158630 | newStream element | 158631 newStream := (collection species new: 100) writeStream. 158632 [self atEnd or: [(element := self next) = anObject]] 158633 whileFalse: [newStream nextPut: element]. 158634 ^newStream contents! ! 158635 158636!InflateStream methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:00'! 158637upToEnd 158638 "Answer a subcollection from the current access position through the last element of the receiver." 158639 158640 | newStream buffer | 158641 buffer := collection species new: 1000. 158642 newStream := (collection species new: 100) writeStream. 158643 [self atEnd] whileFalse: [newStream nextPutAll: (self nextInto: buffer)]. 158644 ^ newStream contents! ! 158645 158646 158647!InflateStream methodsFor: 'bit access' stamp: 'ar 12/27/1999 13:47'! 158648bitPosition 158649 "Return the current bit position of the source" 158650 sourceStream == nil 158651 ifTrue:[^sourcePos * 8 + bitPos] 158652 ifFalse:[^sourceStream position + sourcePos * 8 + bitPos]! ! 158653 158654!InflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:00'! 158655nextBits: n 158656 | bits | 158657 [bitPos < n] whileTrue:[ 158658 bitBuf := bitBuf + (self nextByte bitShift: bitPos). 158659 bitPos := bitPos + 8]. 158660 bits := bitBuf bitAnd: (1 bitShift: n)-1. 158661 bitBuf := bitBuf bitShift: 0 - n. 158662 bitPos := bitPos - n. 158663 ^bits! ! 158664 158665!InflateStream methodsFor: 'bit access' stamp: 'ar 12/5/1998 14:54'! 158666nextByte 158667 ^source byteAt: (sourcePos := sourcePos + 1)! ! 158668 158669!InflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:01'! 158670nextSingleBits: n 158671 | out | 158672 out := 0. 158673 1 to: n do:[:i| out := (out bitShift: 1) + (self nextBits: 1)]. 158674 ^out! ! 158675 158676 158677!InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:04'! 158678crcError: aString 158679 ^CRCError signal: aString! ! 158680 158681!InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 03:49'! 158682updateCrc: oldCrc from: start to: stop in: aCollection 158683 "Answer an updated CRC for the range of bytes in aCollection. 158684 Subclasses can implement the appropriate means for the check sum they wish to use." 158685 ^oldCrc! ! 158686 158687!InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:22'! 158688verifyCrc 158689 "Verify the crc checksum in the input"! ! 158690 158691 158692!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/21/1999 22:59'! 158693computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits 158694 "Assign numerical values to all codes. 158695 Note: The values are stored according to the bit length" 158696 | offsets values baseOffset codeLength | 158697 offsets := Array new: maxBits. 158698 offsets atAllPut: 0. 158699 baseOffset := 1. 158700 minBits to: maxBits do:[:bits| 158701 offsets at: bits put: baseOffset. 158702 baseOffset := baseOffset + (counts at: bits+1)]. 158703 values := WordArray new: aCollection size. 158704 1 to: aCollection size do:[:i| 158705 codeLength := aCollection at: i. 158706 codeLength > 0 ifTrue:[ 158707 baseOffset := offsets at: codeLength. 158708 values at: baseOffset put: i-1. 158709 offsets at: codeLength put: baseOffset + 1]]. 158710 ^values! ! 158711 158712!InflateStream methodsFor: 'huffman trees' stamp: 'sma 5/12/2000 10:49'! 158713createHuffmanTables: values counts: counts from: minBits to: maxBits 158714 "Create the actual tables" 158715 | table tableStart tableSize tableEnd 158716 valueIndex tableStack numValues deltaBits maxEntries 158717 lastTable lastTableStart tableIndex lastTableIndex | 158718 158719 table := WordArray new: ((4 bitShift: minBits) max: 16). 158720 158721 "Create the first entry - this is a dummy. 158722 It gives us information about how many bits to fetch initially." 158723 table at: 1 put: (minBits bitShift: 24) + 2. "First actual table starts at index 2" 158724 158725 "Create the first table from scratch." 158726 tableStart := 2. "See above" 158727 tableSize := 1 bitShift: minBits. 158728 tableEnd := tableStart + tableSize. 158729 "Store the terminal symbols" 158730 valueIndex := (counts at: minBits+1). 158731 tableIndex := 0. 158732 1 to: valueIndex do:[:i| 158733 table at: tableStart + tableIndex put: (values at: i). 158734 tableIndex := self increment: tableIndex bits: minBits]. 158735 "Fill up remaining entries with invalid entries" 158736 tableStack := OrderedCollection new: 10. "Should be more than enough" 158737 tableStack addLast: 158738 (Array 158739 with: minBits "Number of bits (e.g., depth) for this table" 158740 with: tableStart "Start of table" 158741 with: tableIndex "Next index in table" 158742 with: minBits "Number of delta bits encoded in table" 158743 with: tableSize - valueIndex "Entries remaining in table"). 158744 "Go to next value index" 158745 valueIndex := valueIndex + 1. 158746 "Walk over remaining bit lengths and create new subtables" 158747 minBits+1 to: maxBits do:[:bits| 158748 numValues := counts at: bits+1. 158749 [numValues > 0] whileTrue:["Create a new subtable" 158750 lastTable := tableStack last. 158751 lastTableStart := lastTable at: 2. 158752 lastTableIndex := lastTable at: 3. 158753 deltaBits := bits - (lastTable at: 1). 158754 "Make up a table of deltaBits size" 158755 tableSize := 1 bitShift: deltaBits. 158756 tableStart := tableEnd. 158757 tableEnd := tableEnd + tableSize. 158758 [tableEnd > table size ] 158759 whileTrue:[table := self growHuffmanTable: table]. 158760 "Connect to last table" 158761 self assert:[(table at: lastTableStart + lastTableIndex) = 0]."Entry must be unused" 158762 table at: lastTableStart + lastTableIndex put: (deltaBits bitShift: 24) + tableStart. 158763 lastTable at: 3 put: (self increment: lastTableIndex bits: (lastTable at: 4)). 158764 lastTable at: 5 put: (lastTable at: 5) - 1. 158765 self assert:[(lastTable at: 5) >= 0]. "Don't exceed tableSize" 158766 "Store terminal values" 158767 maxEntries := numValues min: tableSize. 158768 tableIndex := 0. 158769 1 to: maxEntries do:[:i| 158770 table at: tableStart + tableIndex put: (values at: valueIndex). 158771 valueIndex := valueIndex + 1. 158772 numValues := numValues - 1. 158773 tableIndex := self increment: tableIndex bits: deltaBits]. 158774 "Check if we have filled up the current table completely" 158775 maxEntries = tableSize ifTrue:[ 158776 "Table has been filled. Back up to the last table with space left." 158777 [tableStack isEmpty not and:[(tableStack last at: 5) = 0]] 158778 whileTrue:[tableStack removeLast]. 158779 ] ifFalse:[ 158780 "Table not yet filled. Put it back on the stack." 158781 tableStack addLast: 158782 (Array 158783 with: bits "Nr. of bits in this table" 158784 with: tableStart "Start of table" 158785 with: tableIndex "Index in table" 158786 with: deltaBits "delta bits of table" 158787 with: tableSize - maxEntries "Unused entries in table"). 158788 ]. 158789 ]. 158790 ]. 158791 ^table copyFrom: 1 to: tableEnd-1! ! 158792 158793!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:25'! 158794decodeDynamicTable: nItems from: aHuffmanTable 158795 "Decode the code length of the literal/length and distance table 158796 in a block compressed with dynamic huffman trees" 158797 | values index value repCount theValue | 158798 values := Array new: nItems. 158799 index := 1. 158800 theValue := 0. 158801 [index <= nItems] whileTrue:[ 158802 value := self decodeValueFrom: aHuffmanTable. 158803 value < 16 ifTrue:[ 158804 "Immediate values" 158805 theValue := value. 158806 values at: index put: value. 158807 index := index+1. 158808 ] ifFalse:[ 158809 "Repeated values" 158810 value = 16 ifTrue:[ 158811 "Repeat last value" 158812 repCount := (self nextBits: 2) + 3. 158813 ] ifFalse:[ 158814 "Repeat zero value" 158815 theValue := 0. 158816 value = 17 158817 ifTrue:[repCount := (self nextBits: 3) + 3] 158818 ifFalse:[value = 18 158819 ifTrue:[repCount := (self nextBits: 7) + 11] 158820 ifFalse:[^self error:'Invalid bits tree value']]]. 158821 0 to: repCount-1 do:[:i| values at: index+i put: theValue]. 158822 index := index + repCount]. 158823 ]. 158824 ^values! ! 158825 158826!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:51'! 158827distanceMap 158828 "This is used by the fast decompressor" 158829 ^nil! ! 158830 158831!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/3/1998 13:16'! 158832growHuffmanTable: table 158833 | newTable | 158834 newTable := table species new: table size * 2. 158835 newTable replaceFrom: 1 to: table size with: table startingAt: 1. 158836 ^newTable! ! 158837 158838!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:27'! 158839huffmanTableFrom: aCollection mappedBy: valueMap 158840 "Create a new huffman table from the given code lengths. 158841 Map the actual values by valueMap if it is given. 158842 See the class comment for a documentation of the huffman 158843 tables used in this decompressor." 158844 | counts values table minBits maxBits | 158845 minBits := MaxBits + 1. 158846 maxBits := 0. 158847 "Count the occurences of each code length and compute minBits and maxBits" 158848 counts := Array new: MaxBits+1. 158849 counts atAllPut: 0. 158850 aCollection do:[:length| 158851 length > 0 ifTrue:[ 158852 length < minBits ifTrue:[minBits := length]. 158853 length > maxBits ifTrue:[maxBits := length]. 158854 counts at: length+1 put: (counts at: length+1)+1]]. 158855 maxBits = 0 ifTrue:[^nil]. "Empty huffman table" 158856 158857 "Assign numerical values to all codes." 158858 values := self computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits. 158859 158860 "Map the values if requested" 158861 self mapValues: values by: valueMap. 158862 158863 "Create the actual tables" 158864 table := self createHuffmanTables: values counts: counts from: minBits to: maxBits. 158865 158866 ^table! ! 158867 158868!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:48'! 158869increment: value bits: nBits 158870 "Increment a value of nBits length. 158871 The fast decompressor will do this differently" 158872 ^value+1! ! 158873 158874!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:50'! 158875literalLengthMap 158876 "This is used by the fast decompressor" 158877 ^nil! ! 158878 158879!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:28'! 158880mapValues: values by: valueMap 158881 | oldValue | 158882 valueMap ifNil:[^values]. 158883 1 to: values size do:[:i| 158884 oldValue := values at: i. 158885 "Note: there may be nil values if not all values are used" 158886 oldValue isNil 158887 ifTrue:[^values] 158888 ifFalse:[values at: i put: (valueMap at: oldValue+1)]]. 158889! ! 158890 158891 158892!InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 02:24'! 158893decodeValueFrom: table 158894 "Decode the next value in the receiver using the given huffman table." 158895 | bits bitsNeeded tableIndex value | 158896 bitsNeeded := (table at: 1) bitShift: -24. "Initial bits needed" 158897 tableIndex := 2. "First real table" 158898 [bits := self nextSingleBits: bitsNeeded. "Get bits" 158899 value := table at: (tableIndex + bits). "Lookup entry in table" 158900 (value bitAnd: 16r3F000000) = 0] "Check if it is a non-leaf node" 158901 whileFalse:["Fetch sub table" 158902 tableIndex := value bitAnd: 16rFFFF. "Table offset in low 16 bit" 158903 bitsNeeded := (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit" 158904 bitsNeeded > MaxBits ifTrue:[^self error:'Invalid huffman table entry']]. 158905 ^value! ! 158906 158907!InflateStream methodsFor: 'inflating' stamp: 'ar 3/15/1999 15:38'! 158908decompressBlock: llTable with: dTable 158909 "Process the compressed data in the block. 158910 llTable is the huffman table for literal/length codes 158911 and dTable is the huffman table for distance codes." 158912 | value extra length distance oldPos oldBits oldBitPos | 158913 [readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[ 158914 "Back up stuff if we're running out of space" 158915 oldBits := bitBuf. 158916 oldBitPos := bitPos. 158917 oldPos := sourcePos. 158918 value := self decodeValueFrom: llTable. 158919 value < 256 ifTrue:[ "A literal" 158920 collection byteAt: (readLimit := readLimit + 1) put: value. 158921 ] ifFalse:["length/distance or end of block" 158922 value = 256 ifTrue:["End of block" 158923 state := state bitAnd: StateNoMoreData. 158924 ^self]. 158925 "Compute the actual length value (including possible extra bits)" 158926 extra := #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0) at: value - 256. 158927 length := #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258) at: value - 256. 158928 extra > 0 ifTrue:[length := length + (self nextBits: extra)]. 158929 "Compute the distance value" 158930 value := self decodeValueFrom: dTable. 158931 extra := #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13) at: value+1. 158932 distance := #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769 158933 1025 1537 2049 3073 4097 6145 8193 12289 16385 24577) at: value+1. 158934 extra > 0 ifTrue:[distance := distance + (self nextBits: extra)]. 158935 (readLimit + length >= collection size) ifTrue:[ 158936 bitBuf := oldBits. 158937 bitPos := oldBitPos. 158938 sourcePos := oldPos. 158939 ^self]. 158940 collection 158941 replaceFrom: readLimit+1 158942 to: readLimit + length + 1 158943 with: collection 158944 startingAt: readLimit - distance + 1. 158945 readLimit := readLimit + length. 158946 ]. 158947 ].! ! 158948 158949!InflateStream methodsFor: 'inflating' stamp: 'ar 12/3/1998 20:49'! 158950proceedDynamicBlock 158951 self decompressBlock: litTable with: distTable! ! 158952 158953!InflateStream methodsFor: 'inflating' stamp: 'ar 12/3/1998 20:49'! 158954proceedFixedBlock 158955 self decompressBlock: litTable with: distTable! ! 158956 158957!InflateStream methodsFor: 'inflating' stamp: 'ar 12/27/1999 13:49'! 158958proceedStoredBlock 158959 "Proceed decompressing a stored (e.g., uncompressed) block" 158960 | length decoded | 158961 "Literal table must be nil for a stored block" 158962 litTable == nil ifFalse:[^self error:'Bad state']. 158963 length := distTable. 158964 [length > 0 and:[readLimit < collection size and:[sourcePos < sourceLimit]]] 158965 whileTrue:[ 158966 collection at: (readLimit := readLimit + 1) put: 158967 (source at: (sourcePos := sourcePos + 1)). 158968 length := length - 1]. 158969 length = 0 ifTrue:[state := state bitAnd: StateNoMoreData]. 158970 decoded := length - distTable. 158971 distTable := length. 158972 ^decoded! ! 158973 158974!InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 01:46'! 158975processDynamicBlock 158976 | nLit nDist nLen codeLength lengthTable bits | 158977 nLit := (self nextBits: 5) + 257. 158978 nDist := (self nextBits: 5) + 1. 158979 nLen := (self nextBits: 4) + 4. 158980 codeLength := Array new: 19. 158981 codeLength atAllPut: 0. 158982 1 to: nLen do:[:i| 158983 bits := #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15) at: i. 158984 codeLength at: bits+1 put: (self nextBits: 3). 158985 ]. 158986 lengthTable := self huffmanTableFrom: codeLength mappedBy: nil. 158987 "RFC 1951: In other words, all code lengths form a single sequence..." 158988 codeLength := self decodeDynamicTable: nLit+nDist from: lengthTable. 158989 litTable := self 158990 huffmanTableFrom: (codeLength copyFrom: 1 to: nLit) 158991 mappedBy: self literalLengthMap. 158992 distTable := self 158993 huffmanTableFrom: (codeLength copyFrom: nLit+1 to: codeLength size) 158994 mappedBy: self distanceMap. 158995 state := state bitOr: BlockProceedBit. 158996 self proceedDynamicBlock.! ! 158997 158998!InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 19:13'! 158999processFixedBlock 159000 litTable := self 159001 huffmanTableFrom: FixedLitCodes 159002 mappedBy: self literalLengthMap. 159003 distTable := self 159004 huffmanTableFrom: FixedDistCodes 159005 mappedBy: self distanceMap. 159006 state := state bitOr: BlockProceedBit. 159007 self proceedFixedBlock.! ! 159008 159009!InflateStream methodsFor: 'inflating' stamp: 'ar 12/27/1999 13:49'! 159010processStoredBlock 159011 | chkSum length | 159012 "Skip to byte boundary" 159013 self nextBits: (bitPos bitAnd: 7). 159014 length := self nextBits: 16. 159015 chkSum := self nextBits: 16. 159016 (chkSum bitXor: 16rFFFF) = length 159017 ifFalse:[^self error:'Bad block length']. 159018 litTable := nil. 159019 distTable := length. 159020 state := state bitOr: BlockProceedBit. 159021 ^self proceedStoredBlock! ! 159022 159023 159024!InflateStream methodsFor: 'initialize' stamp: 'ls 1/2/2001 11:44'! 159025on: aCollectionOrStream 159026 aCollectionOrStream isStream 159027 ifTrue:[ aCollectionOrStream binary. 159028 sourceStream := aCollectionOrStream. 159029 self getFirstBuffer] 159030 ifFalse:[source := aCollectionOrStream]. 159031 ^self on: source from: 1 to: source size.! ! 159032 159033!InflateStream methodsFor: 'initialize' stamp: 'ar 12/23/1999 15:35'! 159034on: aCollection from: firstIndex to: lastIndex 159035 bitBuf := bitPos := 0. 159036 "The decompression buffer has a size of at 64k, 159037 since we may have distances up to 32k back and 159038 repetitions of at most 32k length forward" 159039 collection := aCollection species new: 1 << 16. 159040 readLimit := 0. "Not yet initialized" 159041 position := 0. 159042 source := aCollection. 159043 sourceLimit := lastIndex. 159044 sourcePos := firstIndex-1. 159045 state := StateNewBlock.! ! 159046 159047!InflateStream methodsFor: 'initialize' stamp: 'ar 12/3/1998 16:32'! 159048reset 159049 "Position zero - nothing decoded yet" 159050 position := readLimit := 0. 159051 sourcePos := 0. 159052 bitBuf := bitPos := 0. 159053 state := 0.! ! 159054 159055 159056!InflateStream methodsFor: 'testing' stamp: 'marcus.denker 9/14/2008 18:57'! 159057atEnd 159058 "Note: It is possible that we have a few bits left, 159059 representing just the EOB marker. To check for 159060 this we must force decompression of the next 159061 block if at end of data." 159062 super atEnd ifFalse:[^false]. "Primitive test" 159063 (position >= readLimit and:[state = StateNoMoreData]) ifTrue:[^true]. 159064 "Force decompression, by calling #next. Since #moveContentsToFront 159065 will never move data to the beginning of the buffer it is safe to 159066 skip back the read position afterwards" 159067 self next ifNil: [^true]. 159068 position := position - 1. 159069 ^false! ! 159070 159071 159072!InflateStream methodsFor: 'private' stamp: 'ar 12/4/1998 02:03'! 159073decompressAll 159074 "Profile the decompression speed" 159075 [self atEnd] whileFalse:[ 159076 position := readLimit. 159077 self next "Provokes decompression" 159078 ].! ! 159079 159080!InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:15'! 159081getFirstBuffer 159082 "Get the first source buffer after initialization has been done" 159083 sourceStream == nil ifTrue:[^self]. 159084 source := sourceStream next: 1 << 16. "This is more than enough..." 159085 sourceLimit := source size.! ! 159086 159087!InflateStream methodsFor: 'private' stamp: 'ar 12/3/1998 17:32'! 159088getNextBlock 159089 ^self nextBits: 3! ! 159090 159091!InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:17'! 159092moveContentsToFront 159093 "Move the decoded contents of the receiver to the front so that we have enough space for decoding more data." 159094 | delta | 159095 readLimit > 32768 ifTrue:[ 159096 delta := readLimit - 32767. 159097 collection 159098 replaceFrom: 1 159099 to: collection size - delta + 1 159100 with: collection 159101 startingAt: delta. 159102 position := position - delta + 1. 159103 readLimit := readLimit - delta + 1].! ! 159104 159105!InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:27'! 159106moveSourceToFront 159107 "Move the encoded contents of the receiver to the front so that we have enough space for decoding more data." 159108 (sourceStream == nil or:[sourceStream atEnd]) ifTrue:[^self]. 159109 sourcePos > 10000 ifTrue:[ 159110 source 159111 replaceFrom: 1 159112 to: source size - sourcePos 159113 with: source 159114 startingAt: sourcePos + 1. 159115 source := sourceStream 159116 next: sourcePos 159117 into: source 159118 startingAt: source size - sourcePos + 1. 159119 sourcePos := 0. 159120 sourceLimit := source size].! ! 159121 159122!InflateStream methodsFor: 'private' stamp: 'ar 2/29/2004 04:18'! 159123pastEndRead 159124 "A client has attempted to read beyond the read limit. 159125 Check in what state we currently are and perform 159126 the appropriate action" 159127 | blockType bp oldLimit | 159128 state = StateNoMoreData ifTrue:[^nil]. "Get out early if possible" 159129 "Check if we can move decoded data to front" 159130 self moveContentsToFront. 159131 "Check if we can fetch more source data" 159132 self moveSourceToFront. 159133 state = StateNewBlock ifTrue:[state := self getNextBlock]. 159134 blockType := state bitShift: -1. 159135 bp := self bitPosition. 159136 oldLimit := readLimit. 159137 self perform: (BlockTypes at: blockType+1). 159138 "Note: if bit position hasn't advanced then nothing has been decoded." 159139 bp = self bitPosition 159140 ifTrue:[^self primitiveFailed]. 159141 "Update crc for the decoded contents" 159142 readLimit > oldLimit 159143 ifTrue:[crc := self updateCrc: crc from: oldLimit+1 to: readLimit in: collection]. 159144 state = StateNoMoreData ifTrue:[self verifyCrc]. 159145 ^self next! ! 159146 159147!InflateStream methodsFor: 'private' stamp: 'ar 12/4/1998 02:03'! 159148profile 159149 "Profile the decompression speed" 159150 MessageTally spyOn:[self decompressAll].! ! 159151 159152"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 159153 159154InflateStream class 159155 instanceVariableNames: ''! 159156 159157!InflateStream class methodsFor: 'initialization' stamp: 'stephane.ducasse 6/14/2009 22:47'! 159158initialize 159159 "InflateStream initialize" 159160 MaxBits := 16. 159161 StateNewBlock := 0. 159162 StateNoMoreData := 1. 159163 BlockProceedBit := 8. 159164 BlockTypes := #( processStoredBlock "New block in stored format" 159165 processFixedBlock "New block with fixed huffman tables" 159166 processDynamicBlock "New block with dynamic huffman tables" 159167 errorBadBlock "Bad block format" 159168 proceedStoredBlock "Continue block in stored format" 159169 proceedFixedBlock "Continue block in fixed format" 159170 proceedDynamicBlock "Continue block in dynamic format" 159171 errorBadBlock "Bad block format"). 159172 "Initialize fixed block values" 159173 FixedLitCodes := ((1 to: 144) collect:[:i| 8]), 159174 ((145 to: 256) collect:[:i| 9]), 159175 ((257 to: 280) collect:[:i| 7]), 159176 ((281 to: 288) collect:[:i| 8]). 159177 FixedDistCodes := ((1 to: 32) collect:[:i| 5]).! ! 159178TextDiffBuilder subclass: #InlineTextDiffBuilder 159179 instanceVariableNames: '' 159180 classVariableNames: '' 159181 poolDictionaries: '' 159182 category: 'Polymorph-Tools-Diff'! 159183 159184!InlineTextDiffBuilder methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2008 16:10'! 159185split: aString 159186 "Answer the split 'lines' by splitting on whitespace." 159187 159188 |str lines sep| 159189 lines := OrderedCollection new. 159190 sep := Character separators, '^()[]{}''"`;.'. 159191 str := aString readStream. 159192 [str atEnd] whileFalse: [ 159193 lines add: (str upToAny: sep). 159194 str atEnd ifFalse: [ 159195 str skip: -1. 159196 lines add: str next asString]]. 159197 ^lines! ! 159198Object subclass: #InputEventFetcher 159199 instanceVariableNames: 'eventHandlers fetcherProcess inputSemaphore' 159200 classVariableNames: 'Default' 159201 poolDictionaries: 'EventSensorConstants' 159202 category: 'Kernel-Processes'! 159203!InputEventFetcher commentStamp: 'michael.rueger 4/22/2009 11:59' prior: 0! 159204EventFetcher is responsible for fetching the raw VM events and forward them to the registered event handlers. Event fetching is done in a high priority process, so even with other processes (e.g. the Morphic UI process) being busy events will still be fetched. 159205 159206Instance Variables 159207 inputSemaphore: <Semaphore> 159208 eventHandlers <OrderedCollection> 159209 fetcherProcess <Process> 159210 159211inputSemaphore 159212 - a semaphore registered with the VM to signal availability of an event. Currently not supported on all platforms. 159213 159214eventHandlers 159215 - registered event handlers. Event buffers are cloned before sent to each handler. 159216 159217fetcherProcess 159218 - a process that fetches the events from the VM. Either polling (InputEventPollingFetcher) or waiting on the inputSemaphore. 159219 159220 159221 159222Event format: 159223The current event format is very simple. Each event is recorded into an 8 element array. All events must provide some SmallInteger ID (the first field in the event buffer) and a time stamp (the second field in the event buffer), so that the difference between the time stamp of an event and the current time can be reported. 159224 159225Currently, the following events are defined: 159226 159227Null event 159228============= 159229The Null event is returned when the ST side asks for more events but no more events are available. 159230Structure: 159231[1] - event type 0 159232[2-8] - unused 159233 159234Mouse event structure 159235========================== 159236Mouse events are generated when mouse input is detected. 159237Structure: 159238[1] - event type 1 159239[2] - time stamp 159240[3] - mouse x position 159241[4] - mouse y position 159242[5] - button state; bitfield with the following entries: 159243 1 - yellow (e.g., right) button 159244 2 - blue (e.g., middle) button 159245 4 - red (e.g., left) button 159246 [all other bits are currently undefined] 159247[6] - modifier keys; bitfield with the following entries: 159248 1 - shift key 159249 2 - ctrl key 159250 4 - (Mac specific) option key 159251 8 - Cmd/Alt key 159252 [all other bits are currently undefined] 159253[7] - reserved. 159254[8] - reserved. 159255 159256Keyboard events 159257==================== 159258Keyboard events are generated when keyboard input is detected. 159259[1] - event type 2 159260[2] - time stamp 159261[3] - character code 159262 For now the character code is in Mac Roman encoding. 159263[4] - press state; integer with the following meaning 159264 0 - character 159265 1 - key press (down) 159266 2 - key release (up) 159267[5] - modifier keys (same as in mouse events) 159268[6] - reserved. 159269[7] - reserved. 159270[8] - reserved. 159271! 159272 159273 159274!InputEventFetcher methodsFor: 'events' stamp: 'IgorStasenko 11/22/2008 20:23'! 159275eventLoop 159276 "Fetch pending raw events from the VM. 159277 This method is run at high priority." 159278 | eventBuffer | 159279 159280 eventBuffer := Array new: 8. 159281 159282 [true] whileTrue: [ 159283 | type window | 159284 self waitForInput. 159285 159286 [self primGetNextEvent: eventBuffer. 159287 type := eventBuffer at: 1. 159288 type = EventTypeNone] 159289 whileFalse: [ 159290 "Patch up the window index in case we don't get one" 159291 window := eventBuffer at: 8. 159292 (window isNil 159293 or: [window isZero]) 159294 ifTrue: [eventBuffer at: 8 put: 1]. 159295 159296 self signalEvent: eventBuffer]]! ! 159297 159298!InputEventFetcher methodsFor: 'events' stamp: 'mir 11/19/2008 19:40'! 159299signalEvent: eventBuffer 159300 "Signal the event buffer to all registered event handlers. 159301 Handlers need make sure to copy the buffer or extract the data otherwise, as the buffer will be reused." 159302 159303 self eventHandlers do: [:handler | 159304 handler handleEvent: eventBuffer]! ! 159305 159306!InputEventFetcher methodsFor: 'events' stamp: 'IgorStasenko 11/22/2008 20:20'! 159307waitForInput 159308 inputSemaphore wait.! ! 159309 159310 159311!InputEventFetcher methodsFor: 'handlers' stamp: 'mir 8/13/2008 16:29'! 159312registerHandler: handler 159313 self eventHandlers add: handler! ! 159314 159315!InputEventFetcher methodsFor: 'handlers' stamp: 'mir 8/13/2008 16:29'! 159316unregisterHandler: handler 159317 self eventHandlers remove: handler ifAbsent: []! ! 159318 159319 159320!InputEventFetcher methodsFor: 'initialize-release' stamp: 'Igor.Stasenko 4/23/2009 13:51'! 159321installEventLoop 159322 "Initialize the event loop process. Terminate the old process if any." 159323 "InputEventFetcher default installEventLoop" 159324 159325 self terminateEventLoop.. 159326 fetcherProcess := [self eventLoop] forkAt: Processor lowIOPriority. 159327 fetcherProcess name: 'Input events fetching process'! ! 159328 159329!InputEventFetcher methodsFor: 'initialize-release' stamp: 'michael.rueger 4/22/2009 11:34'! 159330shutDown 159331 self terminateEventLoop. 159332 inputSemaphore ifNotNil: [Smalltalk unregisterExternalObject: inputSemaphore]! ! 159333 159334!InputEventFetcher methodsFor: 'initialize-release' stamp: 'michael.rueger 4/22/2009 11:33'! 159335startUp 159336 inputSemaphore := Semaphore new. 159337 self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore). 159338 inputSemaphore initSignals. 159339 self installEventLoop! ! 159340 159341!InputEventFetcher methodsFor: 'initialize-release' stamp: 'michael.rueger 4/22/2009 11:33'! 159342terminateEventLoop 159343 "Terminate the event loop process. Terminate the old process if any." 159344 "InputEventFetcher default terminateEventLoop" 159345 159346 fetcherProcess ifNotNil: [fetcherProcess terminate]! ! 159347 159348 159349!InputEventFetcher methodsFor: 'private' stamp: 'mir 8/14/2008 16:00'! 159350eventHandlers 159351 ^eventHandlers ifNil: [eventHandlers := OrderedCollection new]! ! 159352 159353!InputEventFetcher methodsFor: 'private' stamp: 'mir 8/14/2008 14:37'! 159354primGetNextEvent: array 159355 "Store the next OS event available into the provided array. 159356 Essential." 159357 <primitive: 94> 159358 ^nil! ! 159359 159360 159361!InputEventFetcher methodsFor: 'private events' stamp: 'mir 8/14/2008 15:43'! 159362primInterruptSemaphore: aSemaphore 159363 "Primitive. Install the argument as the semaphore to be signalled whenever the user presses the interrupt key. The semaphore will be signaled once each time the interrupt key is pressed." 159364 159365 <primitive: 134> 159366 ^self primitiveFailed 159367"Note: This primitive was marked obsolete but is still used and actually quite useful. It could bre replace with a check in the event loop though, without a need for the now obsolete event tickler as event fetching isn't bound to the Morphic loop."! ! 159368 159369!InputEventFetcher methodsFor: 'private events' stamp: 'mir 8/14/2008 15:57'! 159370primSetInputSemaphore: semaIndex 159371 "Set the input semaphore the VM should use for asynchronously signaling the availability of events. Primitive. Optional." 159372 <primitive: 93> 159373 ^nil! ! 159374 159375"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 159376 159377InputEventFetcher class 159378 instanceVariableNames: ''! 159379 159380!InputEventFetcher class methodsFor: 'accessing' stamp: 'michael.rueger 4/20/2009 13:40'! 159381default 159382 "InputEventFetcher default" 159383 159384 ^Default ifNil: [Default := InputEventPollingFetcher new]! ! 159385 159386 159387!InputEventFetcher class methodsFor: 'class initialization' stamp: 'michael.rueger 4/24/2009 13:23'! 159388deinstall 159389 "InputEventFetcher deinstall" 159390 159391 Default 159392 ifNotNil: [ 159393 Default shutDown. 159394 Smalltalk removeFromStartUpList: Default class. 159395 Smalltalk removeFromShutDownList: Default class. 159396 Default := nil]. 159397 Smalltalk removeFromStartUpList: self. 159398 Smalltalk removeFromShutDownList: self! ! 159399 159400!InputEventFetcher class methodsFor: 'class initialization' stamp: 'michael.rueger 4/24/2009 13:20'! 159401install 159402 "InputEventFetcher install" 159403 159404 Smalltalk addToStartUpList: self after: Cursor. 159405 Smalltalk addToShutDownList: self after: Form. 159406 159407 Default := self new. 159408 Default startUp 159409! ! 159410 159411 159412!InputEventFetcher class methodsFor: 'system startup' stamp: 'mir 8/14/2008 15:21'! 159413shutDown 159414 "InputEventFetcher shutDown" 159415 159416 self default shutDown! ! 159417 159418!InputEventFetcher class methodsFor: 'system startup' stamp: 'mir 8/13/2008 14:25'! 159419startUp 159420 "InputEventFetcher startUp" 159421 159422 self default startUp! ! 159423Object subclass: #InputEventHandler 159424 instanceVariableNames: 'eventFetcher' 159425 classVariableNames: '' 159426 poolDictionaries: 'EventSensorConstants' 159427 category: 'Kernel-Processes'! 159428!InputEventHandler commentStamp: 'michael.rueger 4/22/2009 11:56' prior: 0! 159429An InputEventHandler is the abstract superclass for all input event handlers. 159430Subclasses need to implement handleEvent:. 159431 159432Instance Variables 159433 eventFetcher: <InputEventFetcher> 159434 159435eventFetcher 159436 - the event fetcher I'm registered with and receiving my events from. 159437! 159438 159439 159440!InputEventHandler methodsFor: 'events' stamp: 'mir 8/13/2008 19:35'! 159441handleEvent: eventBuffer 159442 self subclassResponsibility! ! 159443 159444 159445!InputEventHandler methodsFor: 'initialize-release' stamp: 'mir 8/13/2008 16:27'! 159446registerIn: anEventFetcher 159447 eventFetcher := anEventFetcher. 159448 eventFetcher registerHandler: self! ! 159449 159450!InputEventHandler methodsFor: 'initialize-release' stamp: 'mir 8/13/2008 16:27'! 159451unregister 159452 eventFetcher 159453 ifNotNil: [eventFetcher unregisterHandler: self]! ! 159454 159455"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 159456 159457InputEventHandler class 159458 instanceVariableNames: ''! 159459InputEventFetcher subclass: #InputEventPollingFetcher 159460 instanceVariableNames: '' 159461 classVariableNames: 'EventPollDelay' 159462 poolDictionaries: '' 159463 category: 'Kernel-Processes'! 159464!InputEventPollingFetcher commentStamp: 'michael.rueger 4/22/2009 11:55' prior: 0! 159465An InputEventPollingFetcher is a subclass of the event fetcher using polling instead of the input semaphore. 159466 159467EventPollDelay 159468 - Delay used to wait on within the polling loop! 159469 159470 159471!InputEventPollingFetcher methodsFor: 'events' stamp: 'IgorStasenko 11/22/2008 20:26'! 159472waitForInput 159473 self class eventPollDelay wait.! ! 159474 159475 159476!InputEventPollingFetcher methodsFor: 'initialize-release' stamp: 'michael.rueger 4/22/2009 11:33'! 159477terminateEventLoop 159478 "Terminate the event loop process. Terminate the old process if any." 159479 "InputEventFetcher default terminateEventLoop" 159480 159481 super terminateEventLoop. 159482 self class resetEventPollDelay! ! 159483 159484"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 159485 159486InputEventPollingFetcher class 159487 instanceVariableNames: ''! 159488 159489!InputEventPollingFetcher class methodsFor: 'accesing' stamp: 'IgorStasenko 11/22/2008 20:25'! 159490eventPollDelay 159491 ^ EventPollDelay ifNil: [ EventPollDelay := Delay forMilliseconds: 10 ].! ! 159492 159493!InputEventPollingFetcher class methodsFor: 'accesing' stamp: 'IgorStasenko 11/22/2008 20:25'! 159494eventPollPeriod: msecs 159495 EventPollDelay := Delay forMilliseconds: msecs.! ! 159496 159497!InputEventPollingFetcher class methodsFor: 'accesing' stamp: 'michael.rueger 4/20/2009 14:11'! 159498resetEventPollDelay 159499 EventPollDelay := nil! ! 159500InputEventHandler subclass: #InputEventSensor 159501 instanceVariableNames: 'eventQueue modifiers mouseButtons mousePosition' 159502 classVariableNames: 'ButtonDecodeTable KeyDecodeTable' 159503 poolDictionaries: 'EventSensorConstants' 159504 category: 'Kernel-Processes'! 159505!InputEventSensor commentStamp: 'michael.rueger 4/22/2009 11:59' prior: 0! 159506An InputEventSensor is a replacement for the old Morphic EventSensor framework. 159507It updates its state when events are received so that all state based users of Sensor (e.g., Sensor keyboard, Sensor leftShiftDown, Sensor mouseButtons) will work exactly as before. The usage of these funtions is discouraged. 159508 159509Instance variables: 159510 mouseButtons <Integer> - mouse button state as replacement for primMouseButtons 159511 mousePosition <Point> - mouse position as replacement for primMousePt 159512 eventQueue <SharedQueue> - an optional event queue for event driven applications 159513 modifiers <Integer> - modifier states 159514 159515Class variables: 159516 159517 ButtonDecodeTable 159518 159519 KeyDecodeTable 159520! 159521 159522 159523!InputEventSensor methodsFor: 'cursor' stamp: 'di 4/13/2000 12:15'! 159524currentCursor 159525 "The current cursor is maintained in class Cursor." 159526 159527 ^ Cursor currentCursor! ! 159528 159529!InputEventSensor methodsFor: 'cursor' stamp: 'di 4/13/2000 12:16'! 159530currentCursor: newCursor 159531 "The current cursor is maintained in class Cursor." 159532 159533 Cursor currentCursor: newCursor.! ! 159534 159535!InputEventSensor methodsFor: 'cursor' stamp: 'michael.rueger 5/25/2009 13:45'! 159536cursorPoint 159537 "Answer a Point indicating the cursor location." 159538 159539 "Fetch the next event if any to update state. 159540 Makes sure that the old polling methods consume events 159541 self nextEvent." 159542 159543 ^ mousePosition! ! 159544 159545!InputEventSensor methodsFor: 'cursor'! 159546cursorPoint: aPoint 159547 "Set aPoint to be the current cursor location." 159548 159549 ^self primCursorLocPut: aPoint! ! 159550 159551!InputEventSensor methodsFor: 'cursor' stamp: 'ar 2/14/2001 00:00'! 159552peekPosition 159553 ^self cursorPoint! ! 159554 159555 159556!InputEventSensor methodsFor: 'events' stamp: 'mir 11/19/2008 12:44'! 159557flushAllButDandDEvents! ! 159558 159559!InputEventSensor methodsFor: 'events' stamp: 'mir 11/19/2008 19:41'! 159560handleEvent: evt 159561 159562 self queueEvent: evt clone! ! 159563 159564!InputEventSensor methodsFor: 'events' stamp: 'michael.rueger 4/27/2009 18:32'! 159565nextEvent 159566 "Return the next event from the receiver." 159567 ^eventQueue isEmpty 159568 ifTrue:[nil] 159569 ifFalse: [self processEvent: eventQueue next]! ! 159570 159571!InputEventSensor methodsFor: 'events' stamp: 'michael.rueger 4/27/2009 18:32'! 159572peekEvent 159573 "Look ahead at the next event." 159574 | nextEvent | 159575 nextEvent := eventQueue peek. 159576 ^nextEvent 159577 ifNotNil: [self processEvent: nextEvent]! ! 159578 159579 159580!InputEventSensor methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:58'! 159581initialize 159582 "Initialize the receiver" 159583 super initialize. 159584 eventQueue := SharedQueue new. 159585 mouseButtons := 0. 159586 mousePosition := 0 @ 0! ! 159587 159588!InputEventSensor methodsFor: 'initialize-release' stamp: 'mir 8/14/2008 15:18'! 159589shutDown! ! 159590 159591!InputEventSensor methodsFor: 'initialize-release' stamp: 'mir 8/14/2008 15:18'! 159592startUp! ! 159593 159594 159595!InputEventSensor methodsFor: 'joystick'! 159596joystickButtons: index 159597 159598 ^ ((self primReadJoystick: index) bitShift: -22) bitAnd: 16r71F 159599 ! ! 159600 159601!InputEventSensor methodsFor: 'joystick'! 159602joystickOn: index 159603 159604 ^ (((self primReadJoystick: index) bitShift: -27) bitAnd: 1) ~= 0 159605 ! ! 159606 159607!InputEventSensor methodsFor: 'joystick'! 159608joystickXY: index 159609 159610 | inputWord x y | 159611 inputWord := self primReadJoystick: index. 159612 x := (inputWord bitAnd: 16r7FF) - 16r400. 159613 y := ((inputWord bitShift: -11) bitAnd: 16r7FF) - 16r400. 159614 ^ x@y 159615 ! ! 159616 159617!InputEventSensor methodsFor: 'joystick' stamp: 'BG 3/16/2005 08:23'! 159618testJoystick: index 159619 "Sensor testJoystick: 3" 159620 159621 | f pt buttons status | 159622 f := Form extent: 110@50. 159623 [Sensor anyButtonPressed] whileFalse: [ 159624 pt := Sensor joystickXY: index. 159625 buttons := Sensor joystickButtons: index. 159626 status := 159627'xy: ', pt printString, ' 159628buttons: ', buttons printStringHex. 159629 f fillWhite. 159630 status displayOn: f at: 10@10. 159631 f displayOn: Display at: 10@10. 159632 ]. 159633! ! 159634 159635 159636!InputEventSensor methodsFor: 'keyboard' stamp: 'mir 8/13/2008 20:06'! 159637flushKeyboard 159638 "Remove all characters from the keyboard buffer." 159639 159640 [self keyboardPressed] 159641 whileTrue: [self keyboard]! ! 159642 159643!InputEventSensor methodsFor: 'keyboard' stamp: 'mir 8/14/2008 14:02'! 159644keyboard 159645 "Answer the next character from the keyboard." 159646 159647 ^self characterForEvent: self nextKeyboardEvent! ! 159648 159649!InputEventSensor methodsFor: 'keyboard' stamp: 'mir 8/14/2008 14:03'! 159650keyboardPeek 159651 "Answer the next character in the keyboard buffer without removing it, or nil if it is empty." 159652 159653 ^ self characterForEvent: self peekKeyboardEvent! ! 159654 159655!InputEventSensor methodsFor: 'keyboard' stamp: 'mir 8/14/2008 14:06'! 159656keyboardPressed 159657 "Answer true if keystrokes are available." 159658 159659 ^self peekKeyboardEvent notNil! ! 159660 159661 159662!InputEventSensor methodsFor: 'modifier keys' stamp: 'mir 11/19/2008 21:07'! 159663anyModifierKeyPressed 159664 "ignore, however, the shift keys 'cause that's not REALLY a command key" 159665 159666 ^self modifiers anyMask: 16r0E "cmd | opt | ctrl"! ! 159667 159668!InputEventSensor methodsFor: 'modifier keys' stamp: 'michael.rueger 6/10/2009 13:36'! 159669commandKeyPressed 159670 "Answer whether the command key on the keyboard is being held down." 159671 159672 ^self modifiers anyMask: 16r08! ! 159673 159674!InputEventSensor methodsFor: 'modifier keys' stamp: 'mir 11/19/2008 21:09'! 159675controlKeyPressed 159676 "Answer whether the control key on the keyboard is being held down." 159677 159678 ^self modifiers anyMask: 16r02! ! 159679 159680!InputEventSensor methodsFor: 'modifier keys' stamp: 'mir 11/19/2008 21:09'! 159681leftShiftDown 159682 "Answer whether the shift key on the keyboard is being held down. The name of this message is a throwback to the Alto, which had independent left and right shift keys." 159683 159684 ^self modifiers anyMask: 16r01! ! 159685 159686!InputEventSensor methodsFor: 'modifier keys' stamp: 'mir 11/19/2008 21:16'! 159687shiftPressed 159688 "Answer whether the shift key on the keyboard is being held down." 159689 159690 ^self modifiers anyMask: 16r01 159691! ! 159692 159693 159694!InputEventSensor methodsFor: 'mouse' stamp: 'mir 11/19/2008 22:28'! 159695anyButtonPressed 159696 "Answer whether at least one mouse button is currently being pressed." 159697 159698 ^self mouseButtons anyMask: 7! ! 159699 159700!InputEventSensor methodsFor: 'mouse' stamp: 'mir 11/19/2008 21:07'! 159701blueButtonPressed 159702 "Answer whether only the blue mouse button is being pressed. 159703 This is the third mouse button or cmd+click on the Mac." 159704 159705 ^(self mouseButtons bitAnd: 7) = 1 159706! ! 159707 159708!InputEventSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:02'! 159709noButtonPressed 159710 "Answer whether any mouse button is not being pressed." 159711 159712 ^self anyButtonPressed not 159713! ! 159714 159715!InputEventSensor methodsFor: 'mouse' stamp: 'mir 8/14/2008 14:56'! 159716peekMousePt 159717 ^ mousePosition! ! 159718 159719!InputEventSensor methodsFor: 'mouse' stamp: 'mir 11/19/2008 21:15'! 159720redButtonPressed 159721 "Answer true if only the red mouse button is being pressed. 159722 This is the first mouse button, usually the left one." 159723 159724 ^(self mouseButtons bitAnd: 7) = 4 159725! ! 159726 159727!InputEventSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:22'! 159728waitButton 159729 "Wait for the user to press any mouse button and then answer with the 159730 current location of the cursor." 159731 159732 | delay | 159733 delay := Delay forMilliseconds: 50. 159734 [self anyButtonPressed] whileFalse: [ delay wait ]. 159735 ^self cursorPoint 159736! ! 159737 159738!InputEventSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:22'! 159739waitButtonOrKeyboard 159740 "Wait for the user to press either any mouse button or any key. 159741 Answer the current cursor location or nil if a keypress occured." 159742 159743 | delay | 159744 delay := Delay forMilliseconds: 50. 159745 [self anyButtonPressed] 159746 whileFalse: [delay wait. 159747 self keyboardPressed 159748 ifTrue: [^ nil]]. 159749 ^ self cursorPoint 159750! ! 159751 159752!InputEventSensor methodsFor: 'mouse'! 159753waitClickButton 159754 "Wait for the user to click (press and then release) any mouse button and 159755 then answer with the current location of the cursor." 159756 159757 self waitButton. 159758 ^self waitNoButton! ! 159759 159760!InputEventSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:25'! 159761waitNoButton 159762 "Wait for the user to release any mouse button and then answer the current location of the cursor." 159763 159764 | delay | 159765 delay := Delay forMilliseconds: 50. 159766 [self anyButtonPressed] whileTrue: [ delay wait]. 159767 ^self cursorPoint 159768! ! 159769 159770!InputEventSensor methodsFor: 'mouse' stamp: 'mir 11/19/2008 21:15'! 159771yellowButtonPressed 159772 "Answer whether only the yellow mouse button is being pressed. 159773 This is the second mouse button or option+click on the Mac." 159774 159775 ^(self mouseButtons bitAnd: 7) = 2 159776! ! 159777 159778 159779!InputEventSensor methodsFor: 'tablet' stamp: 'jm 4/10/1999 22:14'! 159780hasTablet 159781 "Answer true if there is a pen tablet available on this computer." 159782 159783 ^ (self primTabletGetParameters: 1) notNil 159784! ! 159785 159786!InputEventSensor methodsFor: 'tablet' stamp: 'jm 4/13/1999 11:02'! 159787tabletExtent 159788 "Answer the full tablet extent in tablet coordinates." 159789 159790 | params | 159791 params := self primTabletGetParameters: 1. 159792 params ifNil: [^ self error: 'no tablet available']. 159793 ^ (params at: 1)@(params at: 2) 159794! ! 159795 159796!InputEventSensor methodsFor: 'tablet' stamp: 'jm 4/13/1999 11:12'! 159797tabletPoint 159798 "Answer the current position of the first tablet pointing device (pen, puck, or eraser) in tablet coordinates." 159799 159800 | data | 159801 data := self primTabletRead: 1. "state of first/primary pen" 159802 ^ (data at: 3) @ (data at: 4) 159803! ! 159804 159805!InputEventSensor methodsFor: 'tablet' stamp: 'jm 4/12/1999 13:05'! 159806tabletPressure 159807 "Answer the current pressure of the first tablet pointing device (pen, puck, or eraser), a number between 0.0 (no pressure) and 1.0 (max pressure)" 159808 159809 | params data | 159810 params := self primTabletGetParameters: 1. 159811 params ifNil: [^ self]. 159812 data := self primTabletRead: 1. "state of first/primary pen" 159813 ^ (data at: 10) asFloat / ((params at: 10) - 1) 159814! ! 159815 159816!InputEventSensor methodsFor: 'tablet' stamp: 'jm 4/10/1999 23:03'! 159817tabletTimestamp 159818 "Answer the time (in tablet clock ticks) at which the tablet's primary pen last changed state. This can be used in polling loops; if this timestamp hasn't changed, then the pen state hasn't changed either." 159819 159820 | data | 159821 data := self primTabletRead: 1. "state of first/primary pen" 159822 ^ data at: 2 159823! ! 159824 159825 159826!InputEventSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 159827primReadJoystick: index 159828 "Return the joystick input word for the joystick with the given index in the range [1..16]. Returns zero if the index does not correspond to a currently installed joystick." 159829 159830 <primitive: 'primitiveReadJoystick' module: 'JoystickTabletPlugin'> 159831 ^ 0 159832 159833 ! ! 159834 159835!InputEventSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 159836primTabletGetParameters: cursorIndex 159837 "Answer the pen tablet parameters. For parameters that differ from cursor to cursor, answer those associated with the cursor having the given index. Answer nil if there is no pen tablet. The parameters are: 159838 1. tablet width, in tablet units 159839 2. tablet height, in tablet units 159840 3. number of tablet units per inch 159841 4. number of cursors (pens, pucks, etc; some tablets have more than one) 159842 5. this cursor index 159843 6. and 7. x scale and x offset for scaling tablet coordintes (e.g., to fit the screen) 159844 8. and 9. y scale and y offset for scaling tablet coordintes (e.g., to fit the screen) 159845 10. number of pressure levels 159846 11. presure threshold needed close pen tip switch 159847 12. number of pen tilt angles" 159848 159849 <primitive: 'primitiveGetTabletParameters' module: 'JoystickTabletPlugin'> 159850 ^ nil 159851! ! 159852 159853!InputEventSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 159854primTabletRead: cursorIndex 159855 "Answer the pen tablet data for the cursor having the given index. Answer nil if there is no pen tablet. The data is: 159856 1. index of the cursor to which this data applies 159857 2. timestamp of the last state chance for this cursor 159858 3., 4., and 5. x, y, and z coordinates of the cursor (z is typically 0) 159859 6. and 7. xTilt and yTilt of the cursor; (signed) 159860 8. type of cursor (0 = unknown, 1 = pen, 2 = puck, 3 = eraser) 159861 9. cursor buttons 159862 10. cursor pressure, downward 159863 11. cursor pressure, tangential 159864 12. flags" 159865 159866 <primitive: 'primitiveReadTablet' module: 'JoystickTabletPlugin'> 159867 self primitiveFailed 159868! ! 159869 159870 159871!InputEventSensor methodsFor: 'private events' stamp: 'michael.rueger 4/9/2009 15:02'! 159872characterForEvent: evtBuf 159873 159874 | keycode | 159875 evtBuf ifNil: [^nil]. 159876 keycode := evtBuf sixth. 159877 ^keycode 159878 ifNotNil: [Unicode value: keycode]! ! 159879 159880!InputEventSensor methodsFor: 'private events' stamp: 'nice 4/20/2009 22:48'! 159881flushNonKbdEvents 159882 eventQueue ifNil: [^ self]. 159883 eventQueue flushAllSuchThat: 159884 [:buf | (self isKbdEvent: buf) not]! ! 159885 159886!InputEventSensor methodsFor: 'private events' stamp: 'mir 8/13/2008 19:57'! 159887isKbdEvent: buf 159888 ^ (buf at: 1) = EventTypeKeyboard and: [(buf at: 4) = EventKeyChar]! ! 159889 159890!InputEventSensor methodsFor: 'private events' stamp: 'mir 6/23/2008 09:19'! 159891mapButtons: buttons modifiers: modifiers 159892 "Map the buttons to yellow or blue based on the given modifiers. 159893 If only the red button is pressed, then map 159894 Ctrl-RedButton -> BlueButton. 159895 Cmd-RedButton -> YellowButton. 159896 " 159897 (buttons = RedButtonBit) 159898 ifFalse:[^buttons]. 159899 (modifiers allMask: CtrlKeyBit) 159900 ifTrue:[^BlueButtonBit]. 159901 (modifiers allMask: CommandKeyBit) 159902 ifTrue:[^YellowButtonBit]. 159903 ^buttons! ! 159904 159905!InputEventSensor methodsFor: 'private events' stamp: 'michael.rueger 4/22/2009 12:59'! 159906modifiers 159907 "modifier keys; bitfield with the following entries: 159908 1 - shift key 159909 2 - ctrl key 159910 4 - (Mac specific) option key 159911 8 - Cmd/Alt key" 159912 159913 "Fetch the next event if any to update state. 159914 Makes sure that the old polling methods consume events" 159915 159916" self nextEvent." 159917 159918 159919 ^modifiers! ! 159920 159921!InputEventSensor methodsFor: 'private events' stamp: 'michael.rueger 5/25/2009 13:45'! 159922mouseButtons 159923 "button state; bitfield with the following entries: 159924 1 - yellow (e.g., right) button 159925 2 - blue (e.g., middle) button 159926 4 - red (e.g., left) button 159927 [all other bits are currently undefined]" 159928 159929 "Fetch the next event if any to update state. 159930 Makes sure that the old polling methods consume events" 159931 self nextEvent. 159932 159933 ^mouseButtons! ! 159934 159935!InputEventSensor methodsFor: 'private events' stamp: 'mir 8/14/2008 13:37'! 159936nextKeyboardEvent 159937 "Allows for use of old Sensor protocol to get at the keyboard, 159938 as when running kbdTest or the InterpreterSimulator in Morphic" 159939 159940 | evtBuf | 159941 evtBuf := eventQueue nextOrNilSuchThat: [:buf | self isKbdEvent: buf]. 159942 self flushNonKbdEvents. 159943 ^evtBuf! ! 159944 159945!InputEventSensor methodsFor: 'private events' stamp: 'mir 8/14/2008 13:37'! 159946peekKeyboardEvent 159947 "Allows for use of old Sensor protocol to get at the keyboard, 159948 as when running kbdTest or the InterpreterSimulator in Morphic" 159949 159950 ^eventQueue findFirst: [:buf | self isKbdEvent: buf]! ! 159951 159952!InputEventSensor methodsFor: 'private events' stamp: 'michael.rueger 4/27/2009 18:31'! 159953processEvent: evt 159954 "Process a single event. This method is run at high priority." 159955 | type | 159956 159957 type := evt at: 1. 159958 159959 "Treat menu events first" 159960 type = EventTypeMenu 159961 ifTrue: [ 159962 self processMenuEvent: evt. 159963 ^nil]. 159964 159965 "Tackle mouse events first" 159966 type = EventTypeMouse 159967 ifTrue: [ 159968 "Transmogrify the button state according to the platform's button map definition" 159969 evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1). 159970 "Map the mouse buttons depending on modifiers" 159971 evt at: 5 put: (self mapButtons: (evt at: 5) modifiers: (evt at: 6)). 159972 159973 "Update state for polling calls" 159974 mousePosition := (evt at: 3) @ (evt at: 4). 159975 modifiers := evt at: 6. 159976 mouseButtons := evt at: 5. 159977 159978 ^evt]. 159979 159980 159981 "Finally keyboard" 159982 type = EventTypeKeyboard 159983 ifTrue: [ 159984 "Sswap ctrl/alt keys if neeeded" 159985 KeyDecodeTable 159986 at: {evt at: 3. evt at: 5} 159987 ifPresent: [:a | 159988 evt 159989 at: 3 put: a first; 159990 at: 5 put: a second]. 159991 159992 "Update state for polling calls" 159993 modifiers := evt at: 5. 159994 ^evt]. 159995 159996 "Handle all events other than Keyborad or Mouse." 159997 ^evt. 159998 ! ! 159999 160000!InputEventSensor methodsFor: 'private events' stamp: 'michael.rueger 4/22/2009 11:25'! 160001processMenuEvent: evt 160002 | handler localCopyOfEvt | 160003 160004 localCopyOfEvt := evt clone. 160005 handler := (HostSystemMenus 160006 defaultMenuBarForWindowIndex: (localCopyOfEvt at: 8)) 160007 getHandlerForMenu: (localCopyOfEvt at: 3) item: (localCopyOfEvt at: 4). 160008 160009 [[handler handler value: localCopyOfEvt] ifError: [:err :rcvr | ]] 160010 forkAt: Processor activePriority! ! 160011 160012!InputEventSensor methodsFor: 'private events' stamp: 'mir 11/19/2008 19:42'! 160013queueEvent: evt 160014 "Queue the given event in the event queue" 160015 eventQueue nextPut: evt! ! 160016 160017"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 160018 160019InputEventSensor class 160020 instanceVariableNames: ''! 160021 160022!InputEventSensor class methodsFor: 'class initialization' stamp: 'nk 7/11/2002 07:41'! 160023defaultCrossPlatformKeys 160024 "Answer a list of key letters that are used for common editing operations 160025 on different platforms." 160026 ^{ $c . $x . $v . $a . $s . $f . $g . $z } 160027! ! 160028 160029!InputEventSensor class methodsFor: 'class initialization' stamp: 'michael.rueger 4/22/2009 11:48'! 160030installEventSensorFramework 160031 "Installs the new sensor framework." 160032 "InputEventSensor installEventSensorFramework" 160033 160034 self installEventSensorFramework: InputEventFetcher! ! 160035 160036!InputEventSensor class methodsFor: 'class initialization' stamp: 'michael.rueger 4/27/2009 18:03'! 160037installEventSensorFramework: fetcherClass 160038 "Installs the new sensor framework." 160039 "InputEventSensor installEventSensorFramework: InputEventPollingFetcher" 160040 160041 | newSensor | 160042 "Do some extra cleanup" 160043 {InputEventFetcher. InputEventPollingFetcher. InputSensor. } 160044 do: [:oldSensorClass | 160045 Smalltalk removeFromShutDownList: oldSensorClass. 160046 Smalltalk removeFromStartUpList: oldSensorClass]. 160047 160048 InputEventFetcher deinstall. 160049 160050 newSensor := self new. 160051 fetcherClass install. 160052 newSensor registerIn: InputEventPollingFetcher default. 160053 160054 "Shut down old sensor" 160055 Sensor shutDown. 160056 Smalltalk removeFromShutDownList: Sensor class. 160057 Smalltalk removeFromStartUpList: Sensor class. 160058 160059 (Preferences allPreferenceObjects select: [:pref | pref changeInformee = InputSensor]) 160060 do: [:pref | pref changeInformee: newSensor class]. 160061 (Preferences allPreferenceObjects select: [:pref | pref changeInformee = Sensor class]) 160062 do: [:pref | pref changeInformee: newSensor class]. 160063 160064 160065 "Note: We must use #become: here to replace all references to the old sensor with the new one, since Sensor is referenced from all the existing controllers." 160066 Sensor becomeForward: newSensor. "done" 160067 160068 "Register the interrupt handler" 160069 UserInterruptHandler new registerIn: InputEventFetcher default. 160070 160071 Smalltalk addToStartUpList: Sensor class after: fetcherClass. 160072 Smalltalk addToShutDownList: Sensor class after: Form. 160073 160074 "Project spawnNewProcessAndTerminateOld: true"! ! 160075 160076!InputEventSensor class methodsFor: 'class initialization' stamp: 'mir 8/14/2008 15:13'! 160077installKeyDecodeTable 160078 "Create a decode table that swaps some keys if 160079 Preferences swapControlAndAltKeys is set" 160080 KeyDecodeTable := Dictionary new. 160081 Preferences duplicateControlAndAltKeys 160082 ifTrue: [ self defaultCrossPlatformKeys do: 160083 [ :c | self installDuplicateKeyEntryFor: c ] ]. 160084 Preferences swapControlAndAltKeys 160085 ifTrue: [ self defaultCrossPlatformKeys do: 160086 [ :c | self installSwappedKeyEntryFor: c ] ]. 160087 Preferences duplicateAllControlAndAltKeys 160088 ifTrue: [ (Character allCharacters select: [:ea | ea isAlphaNumeric]) do: 160089 [ :c | self installDuplicateKeyEntryFor: c ] ]. 160090! ! 160091 160092!InputEventSensor class methodsFor: 'class initialization' stamp: 'mir 8/14/2008 15:13'! 160093installMouseDecodeTable 160094 "Create a decode table that swaps the lowest-order 2 bits if 160095 Preferences swapMouseButtons is set" 160096 ButtonDecodeTable := Preferences swapMouseButtons 160097 ifTrue: [ByteArray withAll: 160098 ((0 to: 255) collect: [:ea | 160099 ((ea bitAnd: 1) << 1 160100 bitOr: (ea bitAnd: 2) >> 1) 160101 bitOr: (ea bitAnd: 16rFC) ])] 160102 ifFalse: [ByteArray 160103 withAll: (0 to: 255)]! ! 160104 160105!InputEventSensor class methodsFor: 'class initialization' stamp: 'michael.rueger 4/22/2009 11:48'! 160106installPollingEventSensorFramework 160107 "Installs the new sensor framework." 160108 "InputEventSensor installPollingEventSensorFramework" 160109 160110 self installEventSensorFramework: InputEventPollingFetcher! ! 160111 160112 160113!InputEventSensor class methodsFor: 'preference change notification' stamp: 'dew 12/14/2004 23:54'! 160114duplicateAllControlAndAltKeysChanged 160115 "The Preference for duplicateAllControlAndAltKeys has changed; reset the other two." 160116 "At some point the various exclusive CtrlAlt-key prefs should become a radio button set, then these methods wouldn't be needed." 160117 (Preferences 160118 valueOfFlag: #swapControlAndAltKeys 160119 ifAbsent: [false]) ifTrue: [ 160120 self inform: 'Resetting swapControlAndAltKeys preference'. 160121 (Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false. 160122 ]. 160123 (Preferences 160124 valueOfFlag: #duplicateControlAndAltKeys 160125 ifAbsent: [false]) ifTrue: [ 160126 self inform: 'Resetting duplicateControlAndAltKeys preference'. 160127 (Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false. 160128 ]. 160129 self installKeyDecodeTable. 160130! ! 160131 160132!InputEventSensor class methodsFor: 'preference change notification' stamp: 'dew 12/13/2004 18:58'! 160133duplicateControlAndAltKeysChanged 160134 "The Preference for duplicateControlAndAltKeys has changed; reset the other two." 160135 (Preferences 160136 valueOfFlag: #swapControlAndAltKeys 160137 ifAbsent: [false]) ifTrue: [ 160138 self inform: 'Resetting swapControlAndAltKeys preference'. 160139 (Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false. 160140 ]. 160141 (Preferences 160142 valueOfFlag: #duplicateAllControlAndAltKeys 160143 ifAbsent: [false]) ifTrue: [ 160144 self inform: 'Resetting duplicateAllControlAndAltKeys preference'. 160145 (Preferences preferenceAt: #duplicateAllControlAndAltKeys) rawValue: false. 160146 ]. 160147 self installKeyDecodeTable. 160148! ! 160149 160150!InputEventSensor class methodsFor: 'preference change notification' stamp: 'dew 12/13/2004 18:58'! 160151swapControlAndAltKeysChanged 160152 "The Preference for swapControlAndAltKeys has changed; reset the other two." 160153 (Preferences 160154 valueOfFlag: #duplicateControlAndAltKeys 160155 ifAbsent: [false]) ifTrue: [ 160156 self inform: 'Resetting duplicateControlAndAltKeys preference'. 160157 (Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false. 160158 ]. 160159 (Preferences 160160 valueOfFlag: #duplicateAllControlAndAltKeys 160161 ifAbsent: [false]) ifTrue: [ 160162 self inform: 'Resetting duplicateAllControlAndAltKeys preference'. 160163 (Preferences preferenceAt: #duplicateAllControlAndAltKeys) rawValue: false. 160164 ]. 160165 self installKeyDecodeTable. 160166! ! 160167 160168 160169!InputEventSensor class methodsFor: 'public'! 160170default 160171 "Answer the default system InputEventSensor, Sensor." 160172 160173 ^ Sensor! ! 160174 160175!InputEventSensor class methodsFor: 'public' stamp: 'nk 7/11/2002 07:14'! 160176duplicateControlAndAltKeys: aBoolean 160177 "InputEventSensor duplicateControlAndAltKeys: true" 160178 160179 Preferences setPreference: #duplicateControlAndAltKeys toValue: aBoolean. 160180 self installKeyDecodeTable 160181! ! 160182 160183!InputEventSensor class methodsFor: 'public' stamp: 'mir 8/14/2008 15:13'! 160184installDuplicateKeyEntryFor: c 160185 | key | 160186 key := c asInteger. 160187 "first do control->alt key" 160188 KeyDecodeTable at: { key bitAnd: 16r9F . 2 } put: { key . 8 }. 160189 "then alt->alt key" 160190 KeyDecodeTable at: { key . 8 } put: { key . 8 } 160191! ! 160192 160193!InputEventSensor class methodsFor: 'public' stamp: 'mir 8/14/2008 15:13'! 160194installSwappedKeyEntryFor: c 160195 | key | 160196 key := c asInteger. 160197 "first do control->alt key" 160198 KeyDecodeTable at: { key bitAnd: 16r9F . 2 } put: { key . 8 }. 160199 "then alt->control key" 160200 KeyDecodeTable at: { key . 8 } put: { key bitAnd: 16r9F . 2 }! ! 160201 160202!InputEventSensor class methodsFor: 'public' stamp: 'nk 2/10/2002 11:57'! 160203swapControlAndAltKeys: aBoolean 160204 "InputEventSensor swapControlAndAltKeys: true" 160205 160206 Preferences setPreference: #swapControlAndAltKeys toValue: aBoolean. 160207 self installKeyDecodeTable! ! 160208 160209!InputEventSensor class methodsFor: 'public' stamp: 'nk 2/10/2002 11:57'! 160210swapMouseButtons: aBoolean 160211 "InputEventSensor swapMouseButtons: true" 160212 160213 Preferences setPreference: #swapMouseButtons toValue: aBoolean. 160214 self installMouseDecodeTable.! ! 160215 160216 160217!InputEventSensor class methodsFor: 'system startup' stamp: 'nk 6/21/2004 10:36'! 160218shutDown 160219 self default shutDown.! ! 160220 160221!InputEventSensor class methodsFor: 'system startup' stamp: 'nk 2/10/2002 11:57'! 160222startUp 160223 160224 self installMouseDecodeTable. 160225 self installKeyDecodeTable. 160226 self default startUp! ! 160227Object subclass: #InputSensor 160228 instanceVariableNames: '' 160229 classVariableNames: 'ButtonDecodeTable InterruptSemaphore InterruptWatcherProcess KeyDecodeTable' 160230 poolDictionaries: '' 160231 category: 'Kernel-Processes'! 160232!InputSensor commentStamp: '<historical>' prior: 0! 160233An InputSensor is an interface to the user input devices. 160234There is at least one (sub)instance of InputSensor named Sensor in the system. 160235 160236Class variables: 160237 160238ButtonDecodeTable <ByteArray> - maps mouse buttons as reported by the VM to ones reported in the events. 160239 160240KeyDecodeTable <Dictionary<SmallInteger->SmallInteger>> - maps some keys and their modifiers to other keys (used for instance to map Ctrl-X to Alt-X) 160241 160242InterruptSemaphore <Semaphore> - signalled by the the VM and/or the event loop upon receiving an interrupt keystroke. 160243 160244InterruptWatcherProcess <Process> - waits on the InterruptSemaphore and then responds as appropriate.! 160245 160246 160247!InputSensor methodsFor: 'accessing' stamp: 'ar 10/11/2000 17:34'! 160248eventQueue 160249 ^nil! ! 160250 160251!InputSensor methodsFor: 'accessing' stamp: 'ar 10/11/2000 17:35'! 160252eventQueue: aSharedQueue 160253! ! 160254 160255!InputSensor methodsFor: 'accessing' stamp: 'JMM 10/5/2001 12:54'! 160256flushAllButDandDEvents! ! 160257 160258 160259!InputSensor methodsFor: 'buttons' stamp: 'nk 7/12/2000 09:33'! 160260buttons 160261 "Answer the result of primMouseButtons, but swap the mouse 160262 buttons if Preferences swapMouseButtons is set." 160263 ^ ButtonDecodeTable at: self primMouseButtons + 1! ! 160264 160265 160266!InputSensor methodsFor: 'cursor' stamp: 'di 4/13/2000 12:15'! 160267currentCursor 160268 "The current cursor is maintained in class Cursor." 160269 160270 ^ Cursor currentCursor! ! 160271 160272!InputSensor methodsFor: 'cursor' stamp: 'di 4/13/2000 12:16'! 160273currentCursor: newCursor 160274 "The current cursor is maintained in class Cursor." 160275 160276 Cursor currentCursor: newCursor.! ! 160277 160278!InputSensor methodsFor: 'cursor'! 160279cursorPoint 160280 "Answer a Point indicating the cursor location." 160281 160282 ^self mousePoint! ! 160283 160284!InputSensor methodsFor: 'cursor'! 160285cursorPoint: aPoint 160286 "Set aPoint to be the current cursor location." 160287 160288 ^self primCursorLocPut: aPoint! ! 160289 160290!InputSensor methodsFor: 'cursor' stamp: 'ar 2/14/2001 00:00'! 160291peekPosition 160292 ^self cursorPoint! ! 160293 160294 160295!InputSensor methodsFor: 'initialize' stamp: 'ar 9/26/2000 21:35'! 160296flushEvents 160297 "Do nothing"! ! 160298 160299!InputSensor methodsFor: 'initialize' stamp: 'nk 4/12/2004 19:45'! 160300shutDown 160301 InterruptWatcherProcess ifNotNil: [ 160302 InterruptWatcherProcess terminate. 160303 InterruptWatcherProcess := nil ].! ! 160304 160305!InputSensor methodsFor: 'initialize' stamp: 'ar 7/23/2000 00:00'! 160306startUp 160307 self installInterruptWatcher.! ! 160308 160309 160310!InputSensor methodsFor: 'joystick'! 160311joystickButtons: index 160312 160313 ^ ((self primReadJoystick: index) bitShift: -22) bitAnd: 16r71F 160314 ! ! 160315 160316!InputSensor methodsFor: 'joystick'! 160317joystickOn: index 160318 160319 ^ (((self primReadJoystick: index) bitShift: -27) bitAnd: 1) ~= 0 160320 ! ! 160321 160322!InputSensor methodsFor: 'joystick'! 160323joystickXY: index 160324 160325 | inputWord x y | 160326 inputWord := self primReadJoystick: index. 160327 x := (inputWord bitAnd: 16r7FF) - 16r400. 160328 y := ((inputWord bitShift: -11) bitAnd: 16r7FF) - 16r400. 160329 ^ x@y 160330 ! ! 160331 160332!InputSensor methodsFor: 'joystick' stamp: 'BG 3/16/2005 08:23'! 160333testJoystick: index 160334 "Sensor testJoystick: 3" 160335 160336 | f pt buttons status | 160337 f := Form extent: 110@50. 160338 [Sensor anyButtonPressed] whileFalse: [ 160339 pt := Sensor joystickXY: index. 160340 buttons := Sensor joystickButtons: index. 160341 status := 160342'xy: ', pt printString, ' 160343buttons: ', buttons printStringHex. 160344 f fillWhite. 160345 status displayOn: f at: 10@10. 160346 f displayOn: Display at: 10@10. 160347 ]. 160348! ! 160349 160350 160351!InputSensor methodsFor: 'keyboard'! 160352flushKeyboard 160353 "Remove all characters from the keyboard buffer." 160354 160355 [self keyboardPressed] 160356 whileTrue: [self keyboard]! ! 160357 160358!InputSensor methodsFor: 'keyboard' stamp: 'michael.rueger 4/9/2009 14:50'! 160359keyboard 160360 "Answer the next character from the keyboard." 160361 | keycode | 160362 keycode := self primKbdNext. 160363 ^keycode 160364 ifNotNil: [Unicode value: keycode]! ! 160365 160366!InputSensor methodsFor: 'keyboard'! 160367keyboardPressed 160368 "Answer true if keystrokes are available." 160369 160370 ^self primKbdPeek notNil! ! 160371 160372 160373!InputSensor methodsFor: 'modifier keys' stamp: 'di 9/28/1999 08:29'! 160374anyModifierKeyPressed 160375 "ignore, however, the shift keys 'cause that's not REALLY a command key" 160376 160377 ^ self primMouseButtons anyMask: 16r70 "cmd | opt | ctrl"! ! 160378 160379!InputSensor methodsFor: 'modifier keys'! 160380commandKeyPressed 160381 "Answer whether the command key on the keyboard is being held down." 160382 160383 ^ self primMouseButtons anyMask: 64! ! 160384 160385!InputSensor methodsFor: 'modifier keys'! 160386controlKeyPressed 160387 "Answer whether the control key on the keyboard is being held down." 160388 160389 ^ self primMouseButtons anyMask: 16! ! 160390 160391!InputSensor methodsFor: 'modifier keys'! 160392leftShiftDown 160393 "Answer whether the shift key on the keyboard is being held down. The name of this message is a throwback to the Alto, which had independent left and right shift keys." 160394 160395 ^ self primMouseButtons anyMask: 8! ! 160396 160397!InputSensor methodsFor: 'modifier keys' stamp: 'sw 9/21/2000 12:41'! 160398rawMacOptionKeyPressed 160399 "Answer whether the option key on the Macintosh keyboard is being held down. Macintosh specific. Clients are discouraged from calling this directly, since it circumvents bert's attempt to eradicate option-key checks" 160400 160401 ^ self primMouseButtons anyMask: 32! ! 160402 160403!InputSensor methodsFor: 'modifier keys' stamp: 'jm 5/21/1998 16:13'! 160404shiftPressed 160405 "Answer whether the shift key on the keyboard is being held down." 160406 160407 ^ self primMouseButtons anyMask: 8 160408! ! 160409 160410 160411!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24'! 160412anyButtonPressed 160413 "Answer whether at least one mouse button is currently being pressed." 160414 160415 ^ self primMouseButtons anyMask: 7 160416! ! 160417 160418!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24'! 160419blueButtonPressed 160420 "Answer whether only the blue mouse button is being pressed. 160421 This is the third mouse button or cmd+click on the Mac." 160422 160423 ^ (self primMouseButtons bitAnd: 7) = 1 160424! ! 160425 160426!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24'! 160427mouseButtons 160428 "Answer a number from 0 to 7 that encodes the state of the three mouse buttons in its lowest 3 bits." 160429 160430 ^ self primMouseButtons bitAnd: 7 160431! ! 160432 160433!InputSensor methodsFor: 'mouse'! 160434mousePoint 160435 "Answer a Point indicating the coordinates of the current mouse location." 160436 160437 ^self primMousePt! ! 160438 160439!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:02'! 160440noButtonPressed 160441 "Answer whether any mouse button is not being pressed." 160442 160443 ^self anyButtonPressed not 160444! ! 160445 160446!InputSensor methodsFor: 'mouse' stamp: 'ar 2/14/2001 00:02'! 160447peekButtons 160448 ^self primMouseButtons! ! 160449 160450!InputSensor methodsFor: 'mouse' stamp: 'ar 2/8/2001 21:45'! 160451peekMousePt 160452 ^self primMousePt! ! 160453 160454!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:16'! 160455redButtonPressed 160456 "Answer true if only the red mouse button is being pressed. 160457 This is the first mouse button, usually the left one." 160458 160459 ^ (self primMouseButtons bitAnd: 7) = 4 160460! ! 160461 160462!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:22'! 160463waitButton 160464 "Wait for the user to press any mouse button and then answer with the 160465 current location of the cursor." 160466 160467 | delay | 160468 delay := Delay forMilliseconds: 50. 160469 [self anyButtonPressed] whileFalse: [ delay wait ]. 160470 ^self cursorPoint 160471! ! 160472 160473!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:22'! 160474waitButtonOrKeyboard 160475 "Wait for the user to press either any mouse button or any key. 160476 Answer the current cursor location or nil if a keypress occured." 160477 160478 | delay | 160479 delay := Delay forMilliseconds: 50. 160480 [self anyButtonPressed] 160481 whileFalse: [delay wait. 160482 self keyboardPressed 160483 ifTrue: [^ nil]]. 160484 ^ self cursorPoint 160485! ! 160486 160487!InputSensor methodsFor: 'mouse'! 160488waitClickButton 160489 "Wait for the user to click (press and then release) any mouse button and 160490 then answer with the current location of the cursor." 160491 160492 self waitButton. 160493 ^self waitNoButton! ! 160494 160495!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:25'! 160496waitNoButton 160497 "Wait for the user to release any mouse button and then answer the current location of the cursor." 160498 160499 | delay | 160500 delay := Delay forMilliseconds: 50. 160501 [self anyButtonPressed] whileTrue: [ delay wait]. 160502 ^self cursorPoint 160503! ! 160504 160505!InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:05'! 160506yellowButtonPressed 160507 "Answer whether only the yellow mouse button is being pressed. 160508 This is the second mouse button or option+click on the Mac." 160509 160510 ^ (self primMouseButtons bitAnd: 7) = 2 160511! ! 160512 160513 160514!InputSensor methodsFor: 'tablet' stamp: 'jm 4/10/1999 22:14'! 160515hasTablet 160516 "Answer true if there is a pen tablet available on this computer." 160517 160518 ^ (self primTabletGetParameters: 1) notNil 160519! ! 160520 160521!InputSensor methodsFor: 'tablet' stamp: 'jm 4/13/1999 11:02'! 160522tabletExtent 160523 "Answer the full tablet extent in tablet coordinates." 160524 160525 | params | 160526 params := self primTabletGetParameters: 1. 160527 params ifNil: [^ self error: 'no tablet available']. 160528 ^ (params at: 1)@(params at: 2) 160529! ! 160530 160531!InputSensor methodsFor: 'tablet' stamp: 'jm 4/13/1999 11:12'! 160532tabletPoint 160533 "Answer the current position of the first tablet pointing device (pen, puck, or eraser) in tablet coordinates." 160534 160535 | data | 160536 data := self primTabletRead: 1. "state of first/primary pen" 160537 ^ (data at: 3) @ (data at: 4) 160538! ! 160539 160540!InputSensor methodsFor: 'tablet' stamp: 'jm 4/12/1999 13:05'! 160541tabletPressure 160542 "Answer the current pressure of the first tablet pointing device (pen, puck, or eraser), a number between 0.0 (no pressure) and 1.0 (max pressure)" 160543 160544 | params data | 160545 params := self primTabletGetParameters: 1. 160546 params ifNil: [^ self]. 160547 data := self primTabletRead: 1. "state of first/primary pen" 160548 ^ (data at: 10) asFloat / ((params at: 10) - 1) 160549! ! 160550 160551!InputSensor methodsFor: 'tablet' stamp: 'jm 4/10/1999 23:03'! 160552tabletTimestamp 160553 "Answer the time (in tablet clock ticks) at which the tablet's primary pen last changed state. This can be used in polling loops; if this timestamp hasn't changed, then the pen state hasn't changed either." 160554 160555 | data | 160556 data := self primTabletRead: 1. "state of first/primary pen" 160557 ^ data at: 2 160558! ! 160559 160560 160561!InputSensor methodsFor: 'user interrupts' stamp: 'nk 4/12/2004 19:36'! 160562eventTicklerProcess 160563 "Answer my event tickler process, if any" 160564 ^nil! ! 160565 160566!InputSensor methodsFor: 'user interrupts' stamp: 'nk 10/29/2000 11:23'! 160567inputProcess 160568 "For non-event image compatibility" 160569 ^ nil! ! 160570 160571!InputSensor methodsFor: 'user interrupts' stamp: 'nk 6/21/2004 10:41'! 160572installInterruptWatcher 160573 "Initialize the interrupt watcher process. Terminate the old process if any." 160574 "Sensor installInterruptWatcher" 160575 160576 InterruptWatcherProcess ifNotNil: [InterruptWatcherProcess terminate]. 160577 InterruptSemaphore := Semaphore new. 160578 InterruptWatcherProcess := [self userInterruptWatcher] forkAt: Processor lowIOPriority. 160579 self primInterruptSemaphore: InterruptSemaphore.! ! 160580 160581!InputSensor methodsFor: 'user interrupts' stamp: 'nk 10/28/2000 20:33'! 160582interruptWatcherProcess 160583 "Answer my interrupt watcher process, if any" 160584 ^InterruptWatcherProcess! ! 160585 160586!InputSensor methodsFor: 'user interrupts'! 160587setInterruptKey: anInteger 160588 "Register the given keycode as the user interrupt key." 160589 160590 self primSetInterruptKey: anInteger. 160591! ! 160592 160593!InputSensor methodsFor: 'user interrupts' stamp: 'gk 2/23/2004 20:51'! 160594userInterruptWatcher 160595 "Wait for user interrupts and open a notifier on the active process when one occurs." 160596 160597 [true] whileTrue: [ 160598 InterruptSemaphore wait. 160599 Display deferUpdates: false. 160600 SoundService default shutDown. 160601 Smalltalk handleUserInterrupt] 160602! ! 160603 160604 160605!InputSensor methodsFor: 'private'! 160606primCursorLocPut: aPoint 160607 "If the primitive fails, try again with a rounded point." 160608 160609 <primitive: 91> 160610 ^ self primCursorLocPutAgain: aPoint rounded! ! 160611 160612!InputSensor methodsFor: 'private'! 160613primCursorLocPutAgain: aPoint 160614 "Do nothing if primitive is not implemented." 160615 160616 <primitive: 91> 160617 ^ self! ! 160618 160619!InputSensor methodsFor: 'private' stamp: 'ar 7/23/2000 15:38'! 160620primInterruptSemaphore: aSemaphore 160621 "Primitive. Install the argument as the semaphore to be signalled whenever the user presses the interrupt key. The semaphore will be signaled once each time the interrupt key is pressed." 160622 160623 <primitive: 134> 160624 ^self primitiveFailed 160625"Note: This primitive is obsolete with the new event driven architecture in which EventSensor can handle the interrupts itself. However, for supporting older images running on newer VMs the primitive must still be implemented."! ! 160626 160627!InputSensor methodsFor: 'private'! 160628primKbdNext 160629 <primitive: 108> 160630 ^ nil! ! 160631 160632!InputSensor methodsFor: 'private'! 160633primKbdPeek 160634 <primitive: 109> 160635 ^ nil! ! 160636 160637!InputSensor methodsFor: 'private'! 160638primMouseButtons 160639 <primitive: 107> 160640 ^ 0! ! 160641 160642!InputSensor methodsFor: 'private'! 160643primMousePt 160644 "Primitive. Poll the mouse to find out its position. Return a Point. Fail if 160645 event-driven tracking is used instead of polling. Optional. See Object 160646 documentation whatIsAPrimitive." 160647 160648 <primitive: 90> 160649 ^ 0@0! ! 160650 160651!InputSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 160652primReadJoystick: index 160653 "Return the joystick input word for the joystick with the given index in the range [1..16]. Returns zero if the index does not correspond to a currently installed joystick." 160654 160655 <primitive: 'primitiveReadJoystick' module: 'JoystickTabletPlugin'> 160656 ^ 0 160657 160658 ! ! 160659 160660!InputSensor methodsFor: 'private' stamp: 'ar 7/23/2000 15:38'! 160661primSetInterruptKey: anInteger 160662 "Primitive. Register the given keycode as the user interrupt key. The low byte of the keycode is the ISO character and its next four bits are the Smalltalk modifer bits <cmd><opt><ctrl><shift>." 160663 160664 <primitive: 133> 160665 ^self primitiveFailed 160666"Note: This primitive is obsolete with the new event driven architecture in which EventSensor can handle the interrupts itself. However, for supporting older images running on newer VMs the primitive must still be implemented."! ! 160667 160668!InputSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 160669primTabletGetParameters: cursorIndex 160670 "Answer the pen tablet parameters. For parameters that differ from cursor to cursor, answer those associated with the cursor having the given index. Answer nil if there is no pen tablet. The parameters are: 160671 1. tablet width, in tablet units 160672 2. tablet height, in tablet units 160673 3. number of tablet units per inch 160674 4. number of cursors (pens, pucks, etc; some tablets have more than one) 160675 5. this cursor index 160676 6. and 7. x scale and x offset for scaling tablet coordintes (e.g., to fit the screen) 160677 8. and 9. y scale and y offset for scaling tablet coordintes (e.g., to fit the screen) 160678 10. number of pressure levels 160679 11. presure threshold needed close pen tip switch 160680 12. number of pen tilt angles" 160681 160682 <primitive: 'primitiveGetTabletParameters' module: 'JoystickTabletPlugin'> 160683 ^ nil 160684! ! 160685 160686!InputSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! 160687primTabletRead: cursorIndex 160688 "Answer the pen tablet data for the cursor having the given index. Answer nil if there is no pen tablet. The data is: 160689 1. index of the cursor to which this data applies 160690 2. timestamp of the last state chance for this cursor 160691 3., 4., and 5. x, y, and z coordinates of the cursor (z is typically 0) 160692 6. and 7. xTilt and yTilt of the cursor; (signed) 160693 8. type of cursor (0 = unknown, 1 = pen, 2 = puck, 3 = eraser) 160694 9. cursor buttons 160695 10. cursor pressure, downward 160696 11. cursor pressure, tangential 160697 12. flags" 160698 160699 <primitive: 'primitiveReadTablet' module: 'JoystickTabletPlugin'> 160700 self primitiveFailed 160701! ! 160702 160703"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 160704 160705InputSensor class 160706 instanceVariableNames: ''! 160707 160708!InputSensor class methodsFor: 'class initialization' stamp: 'nk 7/11/2002 07:41'! 160709defaultCrossPlatformKeys 160710 "Answer a list of key letters that are used for common editing operations 160711 on different platforms." 160712 ^{ $c . $x . $v . $a . $s . $f . $g . $z } 160713! ! 160714 160715!InputSensor class methodsFor: 'class initialization' stamp: 'dew 12/13/2004 23:21'! 160716installKeyDecodeTable 160717 "Create a decode table that swaps some keys if 160718 Preferences swapControlAndAltKeys is set" 160719 KeyDecodeTable := Dictionary new. 160720 Preferences duplicateControlAndAltKeys 160721 ifTrue: [ self defaultCrossPlatformKeys do: 160722 [ :c | self installDuplicateKeyEntryFor: c ] ]. 160723 Preferences swapControlAndAltKeys 160724 ifTrue: [ self defaultCrossPlatformKeys do: 160725 [ :c | self installSwappedKeyEntryFor: c ] ]. 160726 Preferences duplicateAllControlAndAltKeys 160727 ifTrue: [ (Character allCharacters select: [:ea | ea isAlphaNumeric]) do: 160728 [ :c | self installDuplicateKeyEntryFor: c ] ]. 160729! ! 160730 160731!InputSensor class methodsFor: 'class initialization' stamp: 'nk 2/10/2002 11:55'! 160732installMouseDecodeTable 160733 "Create a decode table that swaps the lowest-order 2 bits if 160734 Preferences swapMouseButtons is set" 160735 ButtonDecodeTable := Preferences swapMouseButtons 160736 ifTrue: [ByteArray withAll: 160737 ((0 to: 255) collect: [:ea | 160738 ((ea bitAnd: 1) << 1 160739 bitOr: (ea bitAnd: 2) >> 1) 160740 bitOr: (ea bitAnd: 16rFC) ])] 160741 ifFalse: [ByteArray 160742 withAll: (0 to: 255)]! ! 160743 160744 160745!InputSensor class methodsFor: 'preference change notification' stamp: 'dew 12/14/2004 23:54'! 160746duplicateAllControlAndAltKeysChanged 160747 "The Preference for duplicateAllControlAndAltKeys has changed; reset the other two." 160748 "At some point the various exclusive CtrlAlt-key prefs should become a radio button set, then these methods wouldn't be needed." 160749 (Preferences 160750 valueOfFlag: #swapControlAndAltKeys 160751 ifAbsent: [false]) ifTrue: [ 160752 self inform: 'Resetting swapControlAndAltKeys preference'. 160753 (Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false. 160754 ]. 160755 (Preferences 160756 valueOfFlag: #duplicateControlAndAltKeys 160757 ifAbsent: [false]) ifTrue: [ 160758 self inform: 'Resetting duplicateControlAndAltKeys preference'. 160759 (Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false. 160760 ]. 160761 self installKeyDecodeTable. 160762! ! 160763 160764!InputSensor class methodsFor: 'preference change notification' stamp: 'dew 12/13/2004 18:58'! 160765duplicateControlAndAltKeysChanged 160766 "The Preference for duplicateControlAndAltKeys has changed; reset the other two." 160767 (Preferences 160768 valueOfFlag: #swapControlAndAltKeys 160769 ifAbsent: [false]) ifTrue: [ 160770 self inform: 'Resetting swapControlAndAltKeys preference'. 160771 (Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false. 160772 ]. 160773 (Preferences 160774 valueOfFlag: #duplicateAllControlAndAltKeys 160775 ifAbsent: [false]) ifTrue: [ 160776 self inform: 'Resetting duplicateAllControlAndAltKeys preference'. 160777 (Preferences preferenceAt: #duplicateAllControlAndAltKeys) rawValue: false. 160778 ]. 160779 self installKeyDecodeTable. 160780! ! 160781 160782!InputSensor class methodsFor: 'preference change notification' stamp: 'dew 12/13/2004 18:58'! 160783swapControlAndAltKeysChanged 160784 "The Preference for swapControlAndAltKeys has changed; reset the other two." 160785 (Preferences 160786 valueOfFlag: #duplicateControlAndAltKeys 160787 ifAbsent: [false]) ifTrue: [ 160788 self inform: 'Resetting duplicateControlAndAltKeys preference'. 160789 (Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false. 160790 ]. 160791 (Preferences 160792 valueOfFlag: #duplicateAllControlAndAltKeys 160793 ifAbsent: [false]) ifTrue: [ 160794 self inform: 'Resetting duplicateAllControlAndAltKeys preference'. 160795 (Preferences preferenceAt: #duplicateAllControlAndAltKeys) rawValue: false. 160796 ]. 160797 self installKeyDecodeTable. 160798! ! 160799 160800 160801!InputSensor class methodsFor: 'public'! 160802default 160803 "Answer the default system InputSensor, Sensor." 160804 160805 ^ Sensor! ! 160806 160807!InputSensor class methodsFor: 'public' stamp: 'nk 7/11/2002 07:14'! 160808duplicateControlAndAltKeys: aBoolean 160809 "InputSensor duplicateControlAndAltKeys: true" 160810 160811 Preferences setPreference: #duplicateControlAndAltKeys toValue: aBoolean. 160812 self installKeyDecodeTable 160813! ! 160814 160815!InputSensor class methodsFor: 'public' stamp: 'nk 7/11/2002 07:09'! 160816installDuplicateKeyEntryFor: c 160817 | key | 160818 key := c asInteger. 160819 "first do control->alt key" 160820 KeyDecodeTable at: { key bitAnd: 16r9F . 2 } put: { key . 8 }. 160821 "then alt->alt key" 160822 KeyDecodeTable at: { key . 8 } put: { key . 8 } 160823! ! 160824 160825!InputSensor class methodsFor: 'public' stamp: 'nk 2/11/2002 12:39'! 160826installSwappedKeyEntryFor: c 160827 | key | 160828 key := c asInteger. 160829 "first do control->alt key" 160830 KeyDecodeTable at: { key bitAnd: 16r9F . 2 } put: { key . 8 }. 160831 "then alt->control key" 160832 KeyDecodeTable at: { key . 8 } put: { key bitAnd: 16r9F . 2 }! ! 160833 160834!InputSensor class methodsFor: 'public' stamp: 'nk 2/10/2002 11:57'! 160835keyDecodeTable 160836 ^KeyDecodeTable ifNil: [ self installKeyDecodeTable ]! ! 160837 160838!InputSensor class methodsFor: 'public' stamp: 'nk 2/10/2002 11:57'! 160839swapControlAndAltKeys: aBoolean 160840 "InputSensor swapControlAndAltKeys: true" 160841 160842 Preferences setPreference: #swapControlAndAltKeys toValue: aBoolean. 160843 self installKeyDecodeTable! ! 160844 160845!InputSensor class methodsFor: 'public' stamp: 'nk 2/10/2002 11:57'! 160846swapMouseButtons: aBoolean 160847 "InputSensor swapMouseButtons: true" 160848 160849 Preferences setPreference: #swapMouseButtons toValue: aBoolean. 160850 self installMouseDecodeTable.! ! 160851 160852 160853!InputSensor class methodsFor: 'system startup' stamp: 'nk 6/21/2004 10:36'! 160854shutDown 160855 self default shutDown.! ! 160856 160857!InputSensor class methodsFor: 'system startup' stamp: 'nk 2/10/2002 11:57'! 160858startUp 160859 160860 self installMouseDecodeTable. 160861 self installKeyDecodeTable. 160862 self default startUp! ! 160863SimpleBorder subclass: #InsetBorder 160864 instanceVariableNames: '' 160865 classVariableNames: '' 160866 poolDictionaries: '' 160867 category: 'Morphic-Borders'! 160868!InsetBorder commentStamp: 'kfr 10/27/2003 09:32' prior: 0! 160869see BorderedMorph! 160870 160871 160872!InsetBorder methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/31/2007 13:41'! 160873bottomRightColor 160874 "Changed from direct access to color since, if nil, 160875 self color is transparent." 160876 160877 ^width = 1 160878 ifTrue: [self color twiceLighter] 160879 ifFalse: [self color lighter]! ! 160880 160881!InsetBorder methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/31/2007 13:41'! 160882topLeftColor 160883 "Changed from direct access to color since, if nil, 160884 self color is transparent." 160885 160886 ^width = 1 160887 ifTrue: [self color twiceDarker] 160888 ifFalse: [self color darker]! ! 160889 160890 160891!InsetBorder methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:23'! 160892colorsAtCorners 160893 | c c14 c23 | 160894 c := self color. 160895 c14 := c lighter. c23 := c darker. 160896 ^Array with: c23 with: c14 with: c14 with: c23.! ! 160897 160898!InsetBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'! 160899style 160900 ^#inset! ! 160901 160902 160903!InsetBorder methodsFor: 'color tracking' stamp: 'ar 8/25/2001 18:17'! 160904trackColorFrom: aMorph 160905 baseColor ifNil:[self color: aMorph insetColor].! ! 160906StringHolder subclass: #Inspector 160907 instanceVariableNames: 'object selectionIndex timeOfLastListUpdate selectionUpdateTime context' 160908 classVariableNames: '' 160909 poolDictionaries: '' 160910 category: 'Tools-Inspector'! 160911!Inspector commentStamp: '<historical>' prior: 0! 160912I represent a query path into the internal representation of an object. As a StringHolder, the string I represent is the value of the currently selected variable of the observed object.! 160913 160914 160915!Inspector methodsFor: 'accessing'! 160916baseFieldList 160917 "Answer an Array consisting of 'self' 160918 and the instance variable names of the inspected object." 160919 160920 ^ (Array with: 'self' with: 'all inst vars') 160921 , object class allInstVarNames! ! 160922 160923!Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 160924context: ctxt 160925 "Set the context of inspection. Currently only used by my subclass ClosureEnvInspector. The inst var is here because we do primitiveChangeClassTo: between subclasses (see inspect:) between different subclasses, but also context could be used as a general concept in all inspectors" 160926 160927 context := ctxt! ! 160928 160929!Inspector methodsFor: 'accessing'! 160930fieldList 160931 "Answer the base field list plus an abbreviated list of indices." 160932 160933 object class isVariable ifFalse: [^ self baseFieldList]. 160934 ^ self baseFieldList , 160935 (object basicSize <= (self i1 + self i2) 160936 ifTrue: [(1 to: object basicSize) 160937 collect: [:i | i printString]] 160938 ifFalse: [(1 to: self i1) , (object basicSize-(self i2-1) to: object basicSize) 160939 collect: [:i | i printString]])! ! 160940 160941!Inspector methodsFor: 'accessing'! 160942i1 160943 "This is the max index shown before skipping to the 160944 last i2 elements of very long arrays" 160945 ^ 100! ! 160946 160947!Inspector methodsFor: 'accessing'! 160948i2 160949 "This is the number of elements to show at the end 160950 of very long arrays" 160951 ^ 10! ! 160952 160953!Inspector methodsFor: 'accessing' stamp: 'al 9/21/2008 19:40'! 160954initialExtent 160955 "Answer the desired extent for the receiver when it is first opened on the screen. " 160956 160957 ^ 350 @ 300! ! 160958 160959!Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 160960modelWakeUpIn: aWindow 160961 | newText | 160962 self updateListsAndCodeIn: aWindow. 160963 newText := self contentsIsString 160964 ifTrue: [newText := self selection] 160965 ifFalse: ["keep it short to reduce time to compute it" 160966 self selectionPrintString ]. 160967 newText = contents ifFalse: 160968 [contents := newText. 160969 self changed: #contents]! ! 160970 160971!Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 160972noteSelectionIndex: anInteger for: aSymbol 160973 aSymbol == #fieldList 160974 ifTrue: 160975 [selectionIndex := anInteger]! ! 160976 160977!Inspector methodsFor: 'accessing'! 160978object 160979 "Answer the object being inspected by the receiver." 160980 160981 ^object! ! 160982 160983!Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 160984object: anObject 160985 "Set anObject to be the object being inspected by the receiver." 160986 160987 | oldIndex | 160988 anObject == object 160989 ifTrue: [self update] 160990 ifFalse: 160991 [oldIndex := selectionIndex <= 2 ifTrue: [selectionIndex] ifFalse: [0]. 160992 self inspect: anObject. 160993 oldIndex := oldIndex min: self fieldList size. 160994 self changed: #inspectObject. 160995 oldIndex > 0 160996 ifTrue: [self toggleIndex: oldIndex]. 160997 self changed: #fieldList. 160998 self changed: #contents]! ! 160999 161000!Inspector methodsFor: 'accessing' stamp: 'tk 4/18/1998 15:37'! 161001selectedClass 161002 "Answer the class of the receiver's current selection" 161003 161004 self selectionUnmodifiable ifTrue: [^ object class]. 161005 ^ self selection class! ! 161006 161007!Inspector methodsFor: 'accessing' stamp: 'sma 6/15/2000 16:48'! 161008stepTimeIn: aSystemWindow 161009 ^ (selectionUpdateTime ifNil: [0]) * 10 max: 1000! ! 161010 161011!Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 161012timeOfLastListUpdate 161013 ^ timeOfLastListUpdate ifNil: [timeOfLastListUpdate := 0]! ! 161014 161015!Inspector methodsFor: 'accessing' stamp: 'tk 6/11/1998 22:23'! 161016trash: newText 161017 "Don't save it" 161018 ^ true! ! 161019 161020!Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 161021update 161022 "Reshow contents, assuming selected value may have changed." 161023 161024 selectionIndex = 0 161025 ifFalse: 161026 [self contentsIsString 161027 ifTrue: [contents := self selection] 161028 ifFalse: [contents := self selectionPrintString]. 161029 self changed: #contents. 161030 self changed: #selection. 161031 self changed: #selectionIndex]! ! 161032 161033!Inspector methodsFor: 'accessing' stamp: 'di 1/13/1999 14:36'! 161034wantsSteps 161035 ^ true! ! 161036 161037 161038!Inspector methodsFor: 'code'! 161039doItReceiver 161040 "Answer the object that should be informed of the result of evaluating a 161041 text selection." 161042 161043 ^object! ! 161044 161045 161046!Inspector methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 161047initialize 161048 161049 selectionIndex := 0. 161050 super initialize! ! 161051 161052!Inspector methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 161053inspect: anObject 161054 "Initialize the receiver so that it is inspecting anObject. There is no current selection. 161055 161056 Normally the receiver will be of the correct class (as defined by anObject inspectorClass), 161057 because it will have just been created by sedning inspect to anObject. However, the 161058 debugger uses two embedded inspectors, which are re-targetted on the current receiver 161059 each time the stack frame changes. The left-hand inspector in the debugger has its 161060 class changed by the code here. Care should be taken if this method is overridden to 161061 ensure that the overriding code calls 'super inspect: anObject', or otherwise ensures that 161062 the class of these embedded inspectors are changed back." 161063 161064 | c | 161065 c := anObject inspectorClass. 161066 (self class ~= c and: [self class format = c format]) ifTrue: [ 161067 self primitiveChangeClassTo: c basicNew]. 161068 161069 "Set 'object' before sending the initialize message, because some implementations 161070 of initialize (e.g., in DictionaryInspector) require 'object' to be non-nil." 161071 161072 object := anObject. 161073 self initialize! ! 161074 161075 161076!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'! 161077addCollectionItemsTo: aMenu 161078 "If the current selection is an appropriate collection, add items to aMenu that cater to that kind of selection" 161079 161080 | sel | 161081 ((((sel := self selection) isMemberOf: Array) or: [sel isMemberOf: OrderedCollection]) and: 161082 [sel size > 0]) ifTrue: [ 161083 aMenu addList: #( 161084 ('inspect element...' inspectElement))]. 161085 161086 (sel isKindOf: MorphExtension) ifTrue: [ 161087 aMenu addList: #( 161088 ('inspect property...' inspectElement))].! ! 161089 161090!Inspector methodsFor: 'menu commands' stamp: 'sd 5/10/2008 17:33'! 161091browseFullProtocol 161092 "Open up a protocol-category browser on the value of the receiver's current selection." 161093 161094 ^ self spawnProtocol 161095 161096 ! ! 161097 161098!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'! 161099chasePointers 161100 | selected saved | 161101 self selectionIndex == 0 ifTrue: [^ self changed: #flash]. 161102 selected := self selection. 161103 saved := self object. 161104 [self object: nil. 161105 (Smalltalk includesKey: #PointerFinder) 161106 ifTrue: [PointerFinder on: selected] 161107 ifFalse: [self inspectPointers]] 161108 ensure: [self object: saved]! ! 161109 161110!Inspector methodsFor: 'menu commands' stamp: 'tk 4/10/1998 17:53'! 161111classOfSelection 161112 "Answer the class of the receiver's current selection" 161113 161114 self selectionUnmodifiable ifTrue: [^ object class]. 161115 ^ self selection class! ! 161116 161117!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'! 161118classVarRefs 161119 "Request a browser of methods that store into a chosen instance variable" 161120 161121 | aClass | 161122 (aClass := self classOfSelection) ifNotNil: 161123 [self systemNavigation browseClassVarRefs: aClass]. 161124! ! 161125 161126!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'! 161127copyName 161128 "Copy the name of the current variable, so the user can paste it into the 161129 window below and work with is. If collection, do (xxx at: 1)." 161130 | sel aClass variableNames | 161131 self selectionUnmodifiable 161132 ifTrue: [^ self changed: #flash]. 161133 aClass := self object class. 161134 variableNames := aClass allInstVarNames. 161135 (aClass isVariable and: [selectionIndex > (variableNames size + 2)]) 161136 ifTrue: [sel := '(self basicAt: ' , (selectionIndex - (variableNames size + 2)) asString , ')'] 161137 ifFalse: [sel := variableNames at: selectionIndex - 2]. 161138 (self selection isKindOf: Collection) 161139 ifTrue: [sel := '(' , sel , ' at: 1)']. 161140 Clipboard clipboardText: sel asText! ! 161141 161142!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'! 161143defsOfSelection 161144 "Open a browser on all defining references to the selected instance variable, if that's what currently selected. " 161145 | aClass sel | 161146 161147 self selectionUnmodifiable ifTrue: [^ self changed: #flash]. 161148 (aClass := self object class) isVariable ifTrue: [^ self changed: #flash]. 161149 161150 sel := aClass allInstVarNames at: self selectionIndex - 2. 161151 self systemNavigation browseAllStoresInto: sel from: aClass! ! 161152 161153!Inspector methodsFor: 'menu commands' stamp: 'mtf 4/25/2008 14:17'! 161154explorePointers 161155 self selectionIndex = 0 ifTrue: [^ self changed: #flash]. 161156 PointerExplorer new openExplorerFor: self selection! ! 161157 161158!Inspector methodsFor: 'menu commands' stamp: 'sw 9/21/1999 12:16'! 161159exploreSelection 161160 161161 self selectionIndex = 0 ifTrue: [^ self changed: #flash]. 161162 ^ self selection explore! ! 161163 161164!Inspector methodsFor: 'menu commands' stamp: 'stephane.ducasse 11/8/2008 21:44'! 161165fieldListMenu: aMenu 161166 "Arm the supplied menu with items for the field-list of the receiver" 161167 161168 aMenu addStayUpItemSpecial. 161169 161170 aMenu addList: #( 161171 ('inspect (i)' inspectSelection) 161172 ('explore (I)' exploreSelection)). 161173 161174 self addCollectionItemsTo: aMenu. 161175 161176 aMenu addList: #( 161177 - 161178 ('method refs to this inst var' referencesToSelection) 161179 ('methods storing into this inst var' defsOfSelection) 161180 ('objects pointing to this value' objectReferencesToSelection) 161181 ('chase pointers' chasePointers) 161182 ('explore pointers' explorePointers) 161183 - 161184 ('browse full (b)' browseMethodFull) 161185 ('browse class' browseClass) 161186 ('browse hierarchy (h)' classHierarchy) 161187 ('browse protocol (p)' browseFullProtocol) 161188 - 161189 ('inst var refs...' browseInstVarRefs) 161190 ('inst var defs...' browseInstVarDefs) 161191 ('class var refs...' classVarRefs) 161192 ('class variables' browseClassVariables) 161193 ('class refs (N)' browseClassRefs) 161194 - 161195 ('copy name (c)' copyName) 161196 ('basic inspect' inspectBasic) 161197 ). 161198 ^ aMenu 161199 161200 161201! ! 161202 161203!Inspector methodsFor: 'menu commands' stamp: 'tk 4/12/1998 08:49'! 161204inspectBasic 161205 "Bring up a non-special inspector" 161206 161207 selectionIndex = 0 ifTrue: [^ object basicInspect]. 161208 self selection basicInspect! ! 161209 161210!Inspector methodsFor: 'menu commands' stamp: 'damiencassou 5/30/2008 16:29'! 161211inspectElement 161212 "Create and schedule an Inspector on an element of the receiver's model's currently selected collection." 161213 | sel selSize countString count nameStrs | 161214 self selectionIndex = 0 ifTrue: [ ^ self changed: #flash ]. 161215 ((sel := self selection) isKindOf: SequenceableCollection) ifFalse: 161216 [ (sel isKindOf: MorphExtension) ifTrue: [ ^ sel inspectElement ]. 161217 ^ sel inspect ]. 161218 (selSize := sel size) == 1 ifTrue: [ ^ sel first inspect ]. 161219 selSize <= 20 ifTrue: 161220 [ nameStrs := (1 to: selSize) asArray collect: 161221 [ :ii | 161222 ii printString , ' ' , (((sel at: ii) printStringLimitedTo: 25) 161223 replaceAll: Character cr 161224 with: Character space) ]. 161225 count := UIManager default 161226 chooseFrom: nameStrs substrings 161227 title: 'which element?'. 161228 count = 0 ifTrue: [ ^ self ]. 161229 ^ (sel at: count) inspect ]. 161230 countString := UIManager default 161231 request: 'Which element? (1 to ' , selSize printString , ')' 161232 initialAnswer: '1'. 161233 countString isEmptyOrNil ifTrue: [ ^ self ]. 161234 count := Integer readFrom: countString readStream. 161235 (count > 0 and: [ count <= selSize ]) 161236 ifTrue: [ (sel at: count) inspect ] 161237 ifFalse: [ Beeper beep ]! ! 161238 161239!Inspector methodsFor: 'menu commands' stamp: 'apb 7/14/2004 13:16'! 161240inspectSelection 161241 "Create and schedule an Inspector on the receiver's model's currently selected object." 161242 161243 self selectionIndex = 0 ifTrue: [^ self changed: #flash]. 161244 self selection inspect. 161245 ^ self selection! ! 161246 161247!Inspector methodsFor: 'menu commands' stamp: 'stephane.ducasse 9/20/2008 22:23'! 161248inspectorKey: aChar from: view 161249 "Respond to a Command key issued while the cursor is over my field list" 161250 161251 aChar == $i ifTrue: [^ self selection inspect]. 161252 aChar == $I ifTrue: [^ self selection explore]. 161253 aChar == $b ifTrue: [^ self browseMethodFull]. 161254 aChar == $h ifTrue: [^ self classHierarchy]. 161255 aChar == $c ifTrue: [^ self copyName]. 161256 aChar == $p ifTrue: [^ self browseFullProtocol]. 161257 aChar == $N ifTrue: [^ self browseClassRefs]. 161258 161259 ^ self arrowKey: aChar from: view! ! 161260 161261!Inspector methodsFor: 'menu commands' stamp: 'sd 4/16/2003 11:41'! 161262objectReferencesToSelection 161263 "Open a list inspector on all the objects that point to the value of the selected instance variable, if any. " 161264 161265 self selectionIndex == 0 ifTrue: [^ self changed: #flash]. 161266 self systemNavigation 161267 browseAllObjectReferencesTo: self selection 161268 except: (Array with: self object) 161269 ifNone: [:obj | self changed: #flash]. 161270! ! 161271 161272!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'! 161273referencesToSelection 161274 "Open a browser on all references to the selected instance variable, if that's what currently selected. 1/25/96 sw" 161275 | aClass sel | 161276 161277 self selectionUnmodifiable ifTrue: [^ self changed: #flash]. 161278 (aClass := self object class) isVariable ifTrue: [^ self changed: #flash]. 161279 161280 sel := aClass allInstVarNames at: self selectionIndex - 2. 161281 self systemNavigation browseAllAccessesTo: sel from: aClass! ! 161282 161283!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'! 161284spawnFullProtocol 161285 "Spawn a window showing full protocol for the receiver's selection" 161286 161287 | objectToRepresent | 161288 objectToRepresent := self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection]. 161289 ProtocolBrowser openFullProtocolForClass: objectToRepresent class! ! 161290 161291!Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'! 161292spawnProtocol 161293 "Spawn a protocol on browser on the receiver's selection" 161294 161295 | objectToRepresent | 161296 objectToRepresent := self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection]. 161297 ProtocolBrowser openSubProtocolForClass: objectToRepresent class! ! 161298 161299 161300!Inspector methodsFor: 'selecting' stamp: 'damiencassou 5/30/2008 16:29'! 161301accept: aString 161302 | result | 161303 result := self doItReceiver class evaluatorClass new 161304 evaluate: aString readStream 161305 in: self doItContext 161306 to: self doItReceiver 161307 notifying: nil 161308 ifFail: 161309 [ "fix this" 161310 self changed: #flash. 161311 ^ false ]. 161312 result == #failedDoit ifTrue: [ ^ false ]. 161313 self replaceSelectionValue: result. 161314 self changed: #contents. 161315 ^ true! ! 161316 161317!Inspector methodsFor: 'selecting' stamp: 'di 9/22/1998 21:24'! 161318contentsIsString 161319 "Hacked so contents empty when deselected and = long printString when item 2" 161320 161321 ^ (selectionIndex = 2) | (selectionIndex = 0)! ! 161322 161323!Inspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'! 161324replaceSelectionValue: anObject 161325 "The receiver has a list of variables of its inspected object. One of these 161326 is selected. The value of the selected variable is set to the value, 161327 anObject." 161328 | basicIndex si | 161329 selectionIndex <= 2 ifTrue: [ 161330 self toggleIndex: (si := selectionIndex). 161331 self toggleIndex: si. 161332 ^ object]. 161333 object class isVariable 161334 ifFalse: [^ object instVarAt: selectionIndex - 2 put: anObject]. 161335 basicIndex := selectionIndex - 2 - object class instSize. 161336 (object basicSize <= (self i1 + self i2) or: [basicIndex <= self i1]) 161337 ifTrue: [^object basicAt: basicIndex put: anObject] 161338 ifFalse: [^object basicAt: object basicSize - (self i1 + self i2) + basicIndex 161339 put: anObject]! ! 161340 161341!Inspector methodsFor: 'selecting' stamp: 'eem 5/21/2008 11:46'! 161342selectedSlotName 161343 161344 ^ self fieldList at: self selectionIndex ifAbsent: []! ! 161345 161346!Inspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'! 161347selection 161348 "The receiver has a list of variables of its inspected object. 161349 One of these is selected. Answer the value of the selected variable." 161350 | basicIndex | 161351 selectionIndex = 0 ifTrue: [^ '']. 161352 selectionIndex = 1 ifTrue: [^ object]. 161353 selectionIndex = 2 ifTrue: [^ object longPrintStringLimitedTo: 20000]. 161354 (selectionIndex - 2) <= object class instSize 161355 ifTrue: [^ object instVarAt: selectionIndex - 2]. 161356 basicIndex := selectionIndex - 2 - object class instSize. 161357 (object basicSize <= (self i1 + self i2) or: [basicIndex <= self i1]) 161358 ifTrue: [^ object basicAt: basicIndex] 161359 ifFalse: [^ object basicAt: object basicSize - (self i1 + self i2) + basicIndex]! ! 161360 161361!Inspector methodsFor: 'selecting'! 161362selectionIndex 161363 "The receiver has a list of variables of its inspected object. One of these 161364 is selected. Answer the index into the list of the selected variable." 161365 161366 ^selectionIndex! ! 161367 161368!Inspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 22:03'! 161369selectionPrintString 161370 | text | 161371 selectionUpdateTime := [text := [self selection printStringLimitedTo: 5000] 161372 on: Error 161373 do: [text := self printStringErrorText. 161374 text 161375 addAttribute: TextColor red 161376 from: 1 161377 to: text size. 161378 text]] timeToRun. 161379 ^ text! ! 161380 161381!Inspector methodsFor: 'selecting' stamp: 'PHK 6/30/2004 11:50'! 161382selectionUnmodifiable 161383 "Answer if the current selected variable is modifiable via acceptance in the code pane. For most inspectors, no selection and a selection of 'self' (selectionIndex = 1) and 'all inst vars' (selectionIndex = 2) are unmodifiable" 161384 161385 ^ selectionIndex <= 2! ! 161386 161387!Inspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'! 161388toggleIndex: anInteger 161389 "The receiver has a list of variables of its inspected object. One of these 161390 is selected. If anInteger is the index of this variable, then deselect it. 161391 Otherwise, make the variable whose index is anInteger be the selected 161392 item." 161393 161394 selectionUpdateTime := 0. 161395 selectionIndex = anInteger 161396 ifTrue: 161397 ["same index, turn off selection" 161398 selectionIndex := 0. 161399 contents := ''] 161400 ifFalse: 161401 ["different index, new selection" 161402 selectionIndex := anInteger. 161403 self contentsIsString 161404 ifTrue: [contents := self selection] 161405 ifFalse: [contents := self selectionPrintString]]. 161406 self changed: #selection. 161407 self changed: #contents. 161408 self changed: #selectionIndex.! ! 161409 161410 161411!Inspector methodsFor: 'stepping' stamp: 'sd 11/20/2005 21:27'! 161412stepAt: millisecondClockValue in: aWindow 161413 | newText | 161414 161415 (Preferences smartUpdating and: [(millisecondClockValue - self timeOfLastListUpdate) > 8000]) "Not more often than once every 8 seconds" 161416 ifTrue: 161417 [self updateListsAndCodeIn: aWindow. 161418 timeOfLastListUpdate := millisecondClockValue]. 161419 161420 newText := self contentsIsString 161421 ifTrue: [self selection] 161422 ifFalse: ["keep it short to reduce time to compute it" 161423 self selectionPrintString ]. 161424 newText = contents ifFalse: 161425 [contents := newText. 161426 self changed: #contents]! ! 161427 161428 161429!Inspector methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! 161430printStringErrorText 161431 | nm | 161432 nm := self selectionIndex < 3 161433 ifTrue: ['self'] 161434 ifFalse: [self selectedSlotName]. 161435 ^ ('<error in printString: evaluate "' , nm , ' printString" to debug>') asText.! ! 161436 161437"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 161438 161439Inspector class 161440 instanceVariableNames: ''! 161441 161442!Inspector class methodsFor: 'instance creation' stamp: 'al 9/21/2008 19:41'! 161443horizontalDividerProportion 161444 ^ 0.4! ! 161445 161446!Inspector class methodsFor: 'instance creation' stamp: 'PHK 7/22/2004 17:04'! 161447inspect: anObject 161448 "Answer an instance of me to provide an inspector for anObject." 161449 161450 "We call basicNew to avoid a premature initialization; the instance method 161451 inspect: anObject will do a self initialize." 161452 161453 ^self basicNew inspect: anObject! ! 161454 161455!Inspector class methodsFor: 'instance creation' stamp: 'sw 9/23/1998 08:16'! 161456openAsMorphOn: anObject 161457 ^ self openAsMorphOn: anObject withLabel: anObject defaultLabelForInspector! ! 161458 161459!Inspector class methodsFor: 'instance creation' stamp: 'apb 7/14/2004 12:54'! 161460openAsMorphOn: anObject withEvalPane: withEval withLabel: label valueViewClass: valueViewClass 161461 "Note: for now, this always adds an eval pane, and ignores the valueViewClass" 161462 161463 ^ (self openAsMorphOn: anObject withLabel: label) openInWorld! ! 161464 161465!Inspector class methodsFor: 'instance creation' stamp: 'alain.plantec 6/19/2008 09:39'! 161466openAsMorphOn: anObject withLabel: aLabel 161467 "(Inspector openAsMorphOn: SystemOrganization withLabel: 'Test') openInWorld" 161468 | window inspector | 161469 inspector := self inspect: anObject. 161470 window := (SystemWindow labelled: aLabel) 161471 model: inspector. 161472 window 161473 addMorph: ((PluggableListMorph new doubleClickSelector: #inspectSelection; 161474 161475 on: inspector 161476 list: #fieldList 161477 selected: #selectionIndex 161478 changeSelected: #toggleIndex: 161479 menu: #fieldListMenu: 161480 keystroke: #inspectorKey:from:) 161481 autoDeselect: false ) 161482 "For doubleClick to work best disable autoDeselect" 161483 frame: (0 @ 0 corner: self horizontalDividerProportion @ self verticalDividerProportion). 161484 window 161485 addMorph: (PluggableTextMorph 161486 on: inspector 161487 text: #contents 161488 accept: #accept: 161489 readSelection: #contentsSelection 161490 menu: #codePaneMenu:shifted:) 161491 frame: (self horizontalDividerProportion @ 0 corner: 1 @ self verticalDividerProportion). 161492 window 161493 addMorph: ((PluggableTextMorph 161494 on: inspector 161495 text: #trash 161496 accept: #trash: 161497 readSelection: #contentsSelection 161498 menu: #codePaneMenu:shifted:) 161499 askBeforeDiscardingEdits: false) 161500 frame: (0 @ self verticalDividerProportion corner: 1 @ 1). 161501 window setUpdatablePanesFrom: #(#fieldList ). 161502 window position: 16 @ 0. 161503 "Room for scroll bar." 161504 ^ window! ! 161505 161506!Inspector class methodsFor: 'instance creation' stamp: 'ar 9/27/2005 18:30'! 161507openOn: anObject 161508 "Create and schedule an instance of me on the model, anInspector. " 161509 161510 ^ self openOn: anObject withEvalPane: true! ! 161511 161512!Inspector class methodsFor: 'instance creation'! 161513openOn: anObject withEvalPane: withEval 161514 "Create and schedule an instance of me on the model, anInspector. " 161515 161516 ^ self openOn: anObject withEvalPane: withEval withLabel: anObject defaultLabelForInspector! ! 161517 161518!Inspector class methodsFor: 'instance creation' stamp: 'alain.plantec 6/10/2008 18:35'! 161519openOn: anObject withEvalPane: withEval withLabel: label 161520 ^ self 161521 openAsMorphOn: anObject 161522 withEvalPane: withEval 161523 withLabel: label 161524 valueViewClass: nil! ! 161525 161526!Inspector class methodsFor: 'instance creation' stamp: 'sw 1/19/1999 14:38'! 161527verticalDividerProportion 161528 ^ 0.7! ! 161529Inspector subclass: #InspectorBrowser 161530 instanceVariableNames: 'fieldList msgList msgListIndex' 161531 classVariableNames: '' 161532 poolDictionaries: '' 161533 category: 'Tools-Inspector'! 161534 161535!InspectorBrowser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 161536fieldList 161537 fieldList ifNotNil: [^ fieldList]. 161538 ^ (fieldList := super fieldList)! ! 161539 161540 161541!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'! 161542msgAccept: newText from: editor 161543 | category | 161544 category := msgListIndex = 0 161545 ifTrue: [ClassOrganizer default] 161546 ifFalse: [object class organization categoryOfElement: (msgList at: msgListIndex)]. 161547 ^ (object class compile: newText classified: category notifying: editor) ~~ nil! ! 161548 161549!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/16/1998 14:18'! 161550msgListIndex 161551 ^msgListIndex! ! 161552 161553!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'! 161554msgListIndex: anInteger 161555 "A selection has been made in the message pane" 161556 161557 msgListIndex := anInteger. 161558 self changed: #msgText.! ! 161559 161560!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/20/1998 07:44'! 161561msgPaneMenu: aMenu shifted: shifted 161562 ^ aMenu labels: 161563'find...(f) 161564find again (g) 161565set search string (h) 161566do again (j) 161567undo (z) 161568copy (c) 161569cut (x) 161570paste (v) 161571do it (d) 161572print it (p) 161573inspect it (i) 161574accept (s) 161575cancel (l)' 161576 lines: #(0 3 5 8 11) 161577 selections: #(find findAgain setSearchString again undo copySelection cut paste doIt printIt inspectIt accept cancel)! ! 161578 161579!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/16/1998 14:38'! 161580msgText 161581 msgListIndex = 0 ifTrue: [^ nil]. 161582 ^ object class sourceCodeAt: (msgList at: msgListIndex)! ! 161583 161584 161585!InspectorBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 161586initialize 161587 161588 super initialize. 161589 fieldList := nil. 161590 msgListIndex := 0. 161591 self changed: #msgText 161592! ! 161593 161594!InspectorBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 161595inspect: anObject 161596 "Initialize the receiver so that it is inspecting anObject. There is no current selection. 161597 Overriden so that my class is not changed to 'anObject inspectorClass'." 161598 161599 object := anObject. 161600 self initialize 161601! ! 161602 161603 161604!InspectorBrowser methodsFor: 'menus' stamp: 'sd 11/20/2005 21:27'! 161605step 161606 | list fieldString msg | 161607 (list := super fieldList) = fieldList ifFalse: 161608 [fieldString := selectionIndex > 0 ifTrue: [fieldList at: selectionIndex] ifFalse: [nil]. 161609 fieldList := list. 161610 selectionIndex := fieldList indexOf: fieldString ifAbsent: [0]. 161611 self changed: #fieldList. 161612 self changed: #selectionIndex]. 161613 list := msgList. msgList := nil. "force recomputation" 161614 list = self msgList ifFalse: 161615 [msg := msgListIndex > 0 ifTrue: [list at: msgListIndex] ifFalse: [nil]. 161616 msgListIndex := msgList indexOf: msg ifAbsent: [0]. 161617 self changed: #msgList. 161618 self changed: #msgListIndex]. 161619 super step! ! 161620 161621 161622!InspectorBrowser methodsFor: 'messages' stamp: 'sd 11/20/2005 21:27'! 161623msgList 161624 msgList ifNotNil: [^ msgList]. 161625 ^ (msgList := object class selectors asSortedArray)! ! 161626 161627!InspectorBrowser methodsFor: 'messages' stamp: 'apb 7/14/2004 13:57'! 161628msgListMenu: aMenu 161629 ^ aMenu labels: 'Not yet implemented' lines: #(0) selections: #(flash)! ! 161630 161631"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 161632 161633InspectorBrowser class 161634 instanceVariableNames: ''! 161635 161636!InspectorBrowser class methodsFor: 'as yet unclassified' stamp: 'alain.plantec 6/19/2008 09:39'! 161637openAsMorphOn: anObject 161638 "(InspectorBrowser openAsMorphOn: SystemOrganization) openInWorld" 161639 | window inspector | 161640 inspector := self inspect: anObject. 161641 window := (SystemWindow labelled: anObject defaultLabelForInspector) 161642 model: inspector. 161643 161644 window addMorph: (PluggableListMorph on: inspector list: #fieldList 161645 selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu:) 161646 frame: (0@0 corner: 0.3@0.5). 161647 window addMorph: (PluggableTextMorph on: inspector text: #contents accept: #accept: 161648 readSelection: nil menu: #codePaneMenu:shifted:) 161649 frame: (0.3@0 corner: 1.0@0.5). 161650 window addMorph: (PluggableListMorph on: inspector list: #msgList 161651 selected: #msgListIndex changeSelected: #msgListIndex: menu: #msgListMenu:) 161652 frame: (0@0.5 corner: 0.3@1.0). 161653 window addMorph: (PluggableTextMorph on: inspector text: #msgText accept: #msgAccept:from: 161654 readSelection: nil menu: #msgPaneMenu:shifted:) 161655 frame: (0.3@0.5 corner: 1.0@1.0). 161656 161657 window setUpdatablePanesFrom: #(fieldList msgList). 161658 window position: 16@0. "Room for scroll bar." 161659 ^ window! ! 161660InstructionClient subclass: #InstVarRefLocator 161661 instanceVariableNames: 'bingo' 161662 classVariableNames: '' 161663 poolDictionaries: '' 161664 category: 'Kernel-Methods'! 161665!InstVarRefLocator commentStamp: 'md 4/8/2003 12:50' prior: 0! 161666My job is to scan bytecodes for instance variable references. 161667 161668BlockContext allInstances collect: [ :x | 161669 {x. x hasInstVarRef} 161670].! 161671 161672 161673!InstVarRefLocator methodsFor: 'initialize-release' stamp: 'md 4/8/2003 11:35'! 161674interpretNextInstructionUsing: aScanner 161675 161676 bingo := false. 161677 aScanner interpretNextInstructionFor: self. 161678 ^bingo! ! 161679 161680 161681!InstVarRefLocator methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:46'! 161682popIntoReceiverVariable: offset 161683 161684 bingo := true! ! 161685 161686!InstVarRefLocator methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:46'! 161687pushReceiverVariable: offset 161688 161689 bingo := true! ! 161690 161691!InstVarRefLocator methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:46'! 161692storeIntoReceiverVariable: offset 161693 161694 bingo := true! ! 161695 161696"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 161697 161698InstVarRefLocator class 161699 instanceVariableNames: ''! 161700TestCase subclass: #InstVarRefLocatorTest 161701 instanceVariableNames: 'tt' 161702 classVariableNames: '' 161703 poolDictionaries: '' 161704 category: 'KernelTests-Methods'! 161705!InstVarRefLocatorTest commentStamp: '<historical>' prior: 0! 161706This is the unit test for the class InstVarRefLocator. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 161707 - http://www.c2.com/cgi/wiki?UnitTest 161708 - http://minnow.cc.gatech.edu/squeak/1547 161709 - the sunit class category! 161710 161711 161712!InstVarRefLocatorTest methodsFor: 'examples' stamp: 'sd 6/5/2005 08:27'! 161713example1 161714 | ff | 161715 (1 < 2) ifTrue: [tt ifNotNil: [ff := 'hallo']]. 161716 ^ ff.! ! 161717 161718!InstVarRefLocatorTest methodsFor: 'examples' stamp: 'md 4/8/2003 12:31'! 161719example2 161720 | ff| 161721 ff := 1. 161722 (1 < 2) ifTrue: [ff ifNotNil: [ff := 'hallo']]. 161723 ^ ff.! ! 161724 161725 161726!InstVarRefLocatorTest methodsFor: 'tests' stamp: 'md 4/8/2003 12:42'! 161727testExample1 161728 | method | 161729 161730 method := self class compiledMethodAt: #example1. 161731 self assert: (self hasInstVarRef: method).! ! 161732 161733!InstVarRefLocatorTest methodsFor: 'tests' stamp: 'md 4/8/2003 12:42'! 161734testExample2 161735 | method | 161736 161737 method := self class compiledMethodAt: #example2. 161738 self deny: (self hasInstVarRef: method).! ! 161739 161740!InstVarRefLocatorTest methodsFor: 'tests' stamp: 'marcus.denker 8/24/2008 13:18'! 161741testInstructions 161742 161743 | scanner end printer | 161744 161745 Object methods do: [:method | 161746 scanner := InstructionStream on: method. 161747 printer := InstVarRefLocator new. 161748 end := scanner method endPC. 161749 161750 [scanner pc <= end] whileTrue: [ 161751 self shouldnt: [printer interpretNextInstructionUsing: scanner] raise: Error. 161752 ]. 161753 ].! ! 161754 161755 161756!InstVarRefLocatorTest methodsFor: 'private' stamp: 'md 4/8/2003 12:39'! 161757hasInstVarRef: aMethod 161758 "Answer whether the receiver references an instance variable." 161759 161760 | scanner end printer | 161761 161762 scanner := InstructionStream on: aMethod. 161763 printer := InstVarRefLocator new. 161764 end := scanner method endPC. 161765 161766 [scanner pc <= end] whileTrue: [ 161767 (printer interpretNextInstructionUsing: scanner) ifTrue: [^true]. 161768 ]. 161769 ^false! ! 161770VariableNode subclass: #InstanceVariableNode 161771 instanceVariableNames: '' 161772 classVariableNames: '' 161773 poolDictionaries: '' 161774 category: 'Compiler-ParseNodes'! 161775 161776!InstanceVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:08'! 161777emitCodeForStore: stack encoder: encoder 161778 encoder genStoreInstVar: index! ! 161779 161780!InstanceVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/15/2008 10:05'! 161781emitCodeForStorePop: stack encoder: encoder 161782 encoder genStorePopInstVar: index. 161783 stack pop: 1! ! 161784 161785!InstanceVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:08'! 161786emitCodeForValue: stack encoder: encoder 161787 stack push: 1. 161788 ^encoder genPushInstVar: index! ! 161789 161790!InstanceVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:57'! 161791sizeCodeForStore: encoder 161792 ^encoder sizeStoreInstVar: index! ! 161793 161794!InstanceVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:07'! 161795sizeCodeForStorePop: encoder 161796 ^encoder sizeStorePopInstVar: index! ! 161797 161798!InstanceVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:53'! 161799sizeCodeForValue: encoder 161800 ^encoder sizePushInstVar: index! ! 161801 161802 161803!InstanceVariableNode methodsFor: 'initialize-release' stamp: 'eem 5/13/2008 10:17'! 161804name: varName index: varIndex 161805 ^self name: varName index: varIndex-1 type: LdInstType! ! 161806 161807 161808!InstanceVariableNode methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:50'! 161809accept: aVisitor 161810 aVisitor visitInstanceVariableNode: self! ! 161811Object subclass: #InstructionClient 161812 instanceVariableNames: '' 161813 classVariableNames: '' 161814 poolDictionaries: '' 161815 category: 'Kernel-Methods'! 161816!InstructionClient commentStamp: 'md 4/8/2003 12:50' prior: 0! 161817My job is to make it easier to implement clients for InstructionStream. See InstVarRefLocator 161818as an example. ! 161819 161820 161821!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! 161822blockReturnTop 161823 "Return Top Of Stack bytecode." 161824 161825! ! 161826 161827!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! 161828doDup 161829 "Duplicate Top Of Stack bytecode." 161830 161831! ! 161832 161833!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! 161834doPop 161835 "Remove Top Of Stack bytecode." 161836! ! 161837 161838!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! 161839jump: offset 161840 "Unconditional Jump bytecode." 161841 161842! ! 161843 161844!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! 161845jump: offset if: condition 161846 "Conditional Jump bytecode." 161847 161848! ! 161849 161850!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! 161851methodReturnConstant: value 161852 "Return Constant bytecode." 161853! ! 161854 161855!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! 161856methodReturnReceiver 161857 "Return Self bytecode." 161858! ! 161859 161860!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! 161861methodReturnTop 161862 "Return Top Of Stack bytecode." 161863! ! 161864 161865!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! 161866popIntoLiteralVariable: anAssociation 161867 "Remove Top Of Stack And Store Into Literal Variable bytecode." 161868! ! 161869 161870!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! 161871popIntoReceiverVariable: offset 161872 "Remove Top Of Stack And Store Into Instance Variable bytecode." 161873! ! 161874 161875!InstructionClient methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:51'! 161876popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 161877 "Remove Top Of Stack And Store Into Offset of Temp Vector bytecode."! ! 161878 161879!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! 161880popIntoTemporaryVariable: offset 161881 "Remove Top Of Stack And Store Into Temporary Variable bytecode." 161882! ! 161883 161884!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! 161885pushActiveContext 161886 "Push Active Context On Top Of Its Own Stack bytecode." 161887! ! 161888 161889!InstructionClient methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:49'! 161890pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize 161891 "Push Closure bytecode." 161892! ! 161893 161894!InstructionClient methodsFor: 'instruction decoding' stamp: 'eem 6/16/2008 14:26'! 161895pushConsArrayWithElements: numElements 161896 "Push Cons Array of size numElements popping numElements items from the stack into the array bytecode." 161897! ! 161898 161899!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! 161900pushConstant: value 161901 "Push Constant, value, on Top Of Stack bytecode." 161902! ! 161903 161904!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! 161905pushLiteralVariable: anAssociation 161906 "Push Contents Of anAssociation On Top Of Stack bytecode." 161907! ! 161908 161909!InstructionClient methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:50'! 161910pushNewArrayOfSize: numElements 161911 "Push New Array of size numElements bytecode." 161912! ! 161913 161914!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! 161915pushReceiver 161916 "Push Active Context's Receiver on Top Of Stack bytecode." 161917! ! 161918 161919!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! 161920pushReceiverVariable: offset 161921 "Push Contents Of the Receiver's Instance Variable Whose Index 161922 is the argument, offset, On Top Of Stack bytecode." 161923! ! 161924 161925!InstructionClient methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:54'! 161926pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 161927 "Push Contents at Offset in Temp Vector bytecode."! ! 161928 161929!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! 161930pushTemporaryVariable: offset 161931 "Push Contents Of Temporary Variable Whose Index Is the 161932 argument, offset, On Top Of Stack bytecode." 161933! ! 161934 161935!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! 161936send: selector super: supered numArgs: numberArguments 161937 "Send Message With Selector, selector, bytecode. The argument, 161938 supered, indicates whether the receiver of the message is specified with 161939 'super' in the source method. The arguments of the message are found in 161940 the top numArguments locations on the stack and the receiver just 161941 below them." 161942! ! 161943 161944!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! 161945storeIntoLiteralVariable: anAssociation 161946 "Store Top Of Stack Into Literal Variable Of Method bytecode." 161947! ! 161948 161949!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! 161950storeIntoReceiverVariable: offset 161951 "Store Top Of Stack Into Instance Variable Of Method bytecode." 161952! ! 161953 161954!InstructionClient methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:52'! 161955storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 161956 "Store Top Of Stack And Store Into Offset of Temp Vector bytecode."! ! 161957 161958!InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! 161959storeIntoTemporaryVariable: offset 161960 "Store Top Of Stack Into Temporary Variable Of Method bytecode." 161961! ! 161962 161963"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 161964 161965InstructionClient class 161966 instanceVariableNames: ''! 161967TestCase subclass: #InstructionClientTest 161968 instanceVariableNames: '' 161969 classVariableNames: '' 161970 poolDictionaries: '' 161971 category: 'KernelTests-Methods'! 161972!InstructionClientTest commentStamp: '<historical>' prior: 0! 161973This is the unit test for the class InstructionClient. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 161974 - http://www.c2.com/cgi/wiki?UnitTest 161975 - http://minnow.cc.gatech.edu/squeak/1547 161976 - the sunit class category! 161977 161978 161979!InstructionClientTest methodsFor: 'tests' stamp: 'marcus.denker 8/24/2008 13:18'! 161980testInstructions 161981 "just interpret all of methods of Object" 161982 161983 | client scanner| 161984 161985 client := InstructionClient new. 161986 161987 Object methods do: [:method | 161988 scanner := (InstructionStream on: method). 161989 [scanner pc <= method endPC] whileTrue: [ 161990 self shouldnt: [scanner interpretNextInstructionFor: client] raise: Error. 161991 ]. 161992 ]. 161993! ! 161994InstructionClient subclass: #InstructionPrinter 161995 instanceVariableNames: 'method scanner stream oldPC innerIndents indent printPC indentSpanOfFollowingJump' 161996 classVariableNames: '' 161997 poolDictionaries: '' 161998 category: 'Kernel-Methods'! 161999!InstructionPrinter commentStamp: 'md 4/8/2003 12:47' prior: 0! 162000My instances can print the object code of a CompiledMethod in symbolic format. They print into an instance variable, stream, and uses oldPC to determine how many bytes to print in the listing. The variable method is used to hold the method being printed.! 162001 162002 162003!InstructionPrinter methodsFor: 'accessing' stamp: 'ajh 6/27/2003 22:25'! 162004indent 162005 162006 ^ indent ifNil: [0]! ! 162007 162008!InstructionPrinter methodsFor: 'accessing' stamp: 'md 4/8/2003 11:20'! 162009method 162010 ^method.! ! 162011 162012!InstructionPrinter methodsFor: 'accessing' stamp: 'eem 5/29/2008 14:00'! 162013method: aMethod 162014 method := aMethod. 162015 printPC := true. 162016 indentSpanOfFollowingJump := false! ! 162017 162018!InstructionPrinter methodsFor: 'accessing' stamp: 'eem 5/29/2008 13:50'! 162019printPC 162020 ^printPC! ! 162021 162022!InstructionPrinter methodsFor: 'accessing' stamp: 'eem 5/29/2008 13:50'! 162023printPC: aBoolean 162024 printPC := aBoolean! ! 162025 162026 162027!InstructionPrinter methodsFor: 'initialize-release' stamp: 'ajh 2/9/2003 14:16'! 162028indent: numTabs 162029 162030 indent := numTabs! ! 162031 162032!InstructionPrinter methodsFor: 'initialize-release' stamp: 'eem 5/29/2008 13:26'! 162033printInstructionsOn: aStream 162034 "Append to the stream, aStream, a description of each bytecode in the 162035 instruction stream." 162036 162037 | end | 162038 stream := aStream. 162039 scanner := InstructionStream on: method. 162040 end := method endPC. 162041 oldPC := scanner pc. 162042 innerIndents := Array new: end withAll: 0. 162043 [scanner pc <= end] whileTrue: 162044 [scanner interpretNextInstructionFor: self]! ! 162045 162046!InstructionPrinter methodsFor: 'initialize-release' stamp: 'eem 8/4/2008 16:26'! 162047printInstructionsOn: aStream do: aBlock 162048 "Append to the stream, aStream, a description of each bytecode in the 162049 instruction stream. Evaluate aBlock with the receiver, the scanner and 162050 the stream after each instruction." 162051 162052 | end | 162053 stream := aStream. 162054 scanner := InstructionStream on: method. 162055 end := method endPC. 162056 oldPC := scanner pc. 162057 innerIndents := Array new: end withAll: 0. 162058 [scanner pc <= end] whileTrue: 162059 [scanner interpretNextInstructionFor: self. 162060 aBlock value: self value: scanner value: stream]! ! 162061 162062 162063!InstructionPrinter methodsFor: 'instruction decoding'! 162064blockReturnTop 162065 "Print the Return Top Of Stack bytecode." 162066 162067 self print: 'blockReturn'! ! 162068 162069!InstructionPrinter methodsFor: 'instruction decoding'! 162070doDup 162071 "Print the Duplicate Top Of Stack bytecode." 162072 162073 self print: 'dup'! ! 162074 162075!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 12:14'! 162076doPop 162077 "Print the Remove Top Of Stack bytecode." 162078 162079 self print: 'pop'! ! 162080 162081!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/29/2008 14:02'! 162082jump: offset 162083 "Print the Unconditional Jump bytecode." 162084 162085 self print: 'jumpTo: ' , (scanner pc + offset) printString. 162086 indentSpanOfFollowingJump ifTrue: 162087 [indentSpanOfFollowingJump := false. 162088 innerIndents atAll: (scanner pc to: scanner pc + offset - 1) put: (innerIndents at: scanner pc - 1) + 1]! ! 162089 162090!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 11:13'! 162091jump: offset if: condition 162092 "Print the Conditional Jump bytecode." 162093 162094 self print: 162095 (condition 162096 ifTrue: ['jumpTrue: '] 162097 ifFalse: ['jumpFalse: ']) 162098 , (scanner pc + offset) printString! ! 162099 162100!InstructionPrinter methodsFor: 'instruction decoding'! 162101methodReturnConstant: value 162102 "Print the Return Constant bytecode." 162103 162104 self print: 'return: ' , value printString! ! 162105 162106!InstructionPrinter methodsFor: 'instruction decoding'! 162107methodReturnReceiver 162108 "Print the Return Self bytecode." 162109 162110 self print: 'returnSelf'! ! 162111 162112!InstructionPrinter methodsFor: 'instruction decoding'! 162113methodReturnTop 162114 "Print the Return Top Of Stack bytecode." 162115 162116 self print: 'returnTop'! ! 162117 162118!InstructionPrinter methodsFor: 'instruction decoding'! 162119popIntoLiteralVariable: anAssociation 162120 "Print the Remove Top Of Stack And Store Into Literal Variable bytecode." 162121 162122 self print: 'popIntoLit: ' , anAssociation key! ! 162123 162124!InstructionPrinter methodsFor: 'instruction decoding'! 162125popIntoReceiverVariable: offset 162126 "Print the Remove Top Of Stack And Store Into Instance Variable 162127 bytecode." 162128 162129 self print: 'popIntoRcvr: ' , offset printString! ! 162130 162131!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/25/2008 14:06'! 162132popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 162133 self print: 'popIntoTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! ! 162134 162135!InstructionPrinter methodsFor: 'instruction decoding'! 162136popIntoTemporaryVariable: offset 162137 "Print the Remove Top Of Stack And Store Into Temporary Variable 162138 bytecode." 162139 162140 self print: 'popIntoTemp: ' , offset printString! ! 162141 162142!InstructionPrinter methodsFor: 'instruction decoding'! 162143pushActiveContext 162144 "Print the Push Active Context On Top Of Its Own Stack bytecode." 162145 162146 self print: 'pushThisContext: '! ! 162147 162148!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 6/16/2008 14:04'! 162149pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize 162150 self print: 'closureNumCopied: ', numCopied printString 162151 , ' numArgs: ', numArgs printString 162152 , ' bytes ', scanner pc printString 162153 , ' to ', (scanner pc + blockSize - 1) printString. 162154 innerIndents 162155 atAll: (scanner pc to: scanner pc + blockSize - 1) 162156 put: (innerIndents at: scanner pc - 1) + 1! ! 162157 162158!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/30/2008 17:42'! 162159pushConsArrayWithElements: numElements 162160 self print: 'pop ', numElements printString, ' into (Array new: ', numElements printString, ')'! ! 162161 162162!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/23/2008 13:58'! 162163pushConstant: obj 162164 "Print the Push Constant, obj, on Top Of Stack bytecode." 162165 162166 self print: (String streamContents: 162167 [:s | 162168 s nextPutAll: 'pushConstant: '. 162169 (obj isKindOf: LookupKey) 162170 ifFalse: [obj printOn: s] 162171 ifTrue: [obj key 162172 ifNotNil: [s nextPutAll: '##'; nextPutAll: obj key] 162173 ifNil: [s nextPutAll: '###'; nextPutAll: obj value soleInstance name]]]). 162174 162175 (obj isKindOf: CompiledMethod) ifTrue: 162176 [obj longPrintOn: stream indent: self indent + 2. 162177 ^self].! ! 162178 162179!InstructionPrinter methodsFor: 'instruction decoding'! 162180pushLiteralVariable: anAssociation 162181 "Print the Push Contents Of anAssociation On Top Of Stack bytecode." 162182 162183 self print: 'pushLit: ' , anAssociation key! ! 162184 162185!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/25/2008 15:02'! 162186pushNewArrayOfSize: numElements 162187 self print: 'push: (Array new: ', numElements printString, ')'! ! 162188 162189!InstructionPrinter methodsFor: 'instruction decoding'! 162190pushReceiver 162191 "Print the Push Active Context's Receiver on Top Of Stack bytecode." 162192 162193 self print: 'self'! ! 162194 162195!InstructionPrinter methodsFor: 'instruction decoding'! 162196pushReceiverVariable: offset 162197 "Print the Push Contents Of the Receiver's Instance Variable Whose Index 162198 is the argument, offset, On Top Of Stack bytecode." 162199 162200 self print: 'pushRcvr: ' , offset printString! ! 162201 162202!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/25/2008 00:00'! 162203pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 162204 self print: 'pushTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! ! 162205 162206!InstructionPrinter methodsFor: 'instruction decoding'! 162207pushTemporaryVariable: offset 162208 "Print the Push Contents Of Temporary Variable Whose Index Is the 162209 argument, offset, On Top Of Stack bytecode." 162210 162211 self print: 'pushTemp: ' , offset printString! ! 162212 162213!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/29/2008 14:02'! 162214send: selector super: supered numArgs: numberArguments 162215 "Print the Send Message With Selector, selector, bytecode. The argument, 162216 supered, indicates whether the receiver of the message is specified with 162217 'super' in the source method. The arguments of the message are found in 162218 the top numArguments locations on the stack and the receiver just 162219 below them." 162220 162221 self print: (supered ifTrue: ['superSend: '] ifFalse: ['send: ']) , selector. 162222 indentSpanOfFollowingJump := #(blockCopy: #closureCopy:copiedValues:) includes: selector! ! 162223 162224!InstructionPrinter methodsFor: 'instruction decoding'! 162225storeIntoLiteralVariable: anAssociation 162226 "Print the Store Top Of Stack Into Literal Variable Of Method bytecode." 162227 162228 self print: 'storeIntoLit: ' , anAssociation key! ! 162229 162230!InstructionPrinter methodsFor: 'instruction decoding'! 162231storeIntoReceiverVariable: offset 162232 "Print the Store Top Of Stack Into Instance Variable Of Method bytecode." 162233 162234 self print: 'storeIntoRcvr: ' , offset printString! ! 162235 162236!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/25/2008 14:06'! 162237storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 162238 self print: 'storeIntoTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! ! 162239 162240!InstructionPrinter methodsFor: 'instruction decoding'! 162241storeIntoTemporaryVariable: offset 162242 "Print the Store Top Of Stack Into Temporary Variable Of Method 162243 bytecode." 162244 162245 self print: 'storeIntoTemp: ' , offset printString! ! 162246 162247 162248!InstructionPrinter methodsFor: 'printing' stamp: 'eem 5/29/2008 13:53'! 162249print: instruction 162250 "Append to the receiver a description of the bytecode, instruction." 162251 162252 | code | 162253 stream tab: self indent. 162254 printPC ifTrue: [stream print: oldPC; space]. 162255 stream tab: (innerIndents at: oldPC). 162256 stream nextPut: $<. 162257 oldPC to: scanner pc - 1 do: 162258 [:i | 162259 code := (method at: i) radix: 16. 162260 stream nextPut: 162261 (code size < 2 162262 ifTrue: [$0] 162263 ifFalse: [code at: 1]). 162264 stream nextPut: code last; space]. 162265 stream skip: -1. 162266 stream nextPut: $>. 162267 stream space. 162268 stream nextPutAll: instruction. 162269 stream cr. 162270 oldPC := scanner pc. 162271 "(InstructionPrinter compiledMethodAt: #print:) symbolic." 162272! ! 162273 162274"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 162275 162276InstructionPrinter class 162277 instanceVariableNames: ''! 162278 162279!InstructionPrinter class methodsFor: 'printing' stamp: 'md 4/8/2003 11:19'! 162280on: aMethod 162281 ^self new method: aMethod. 162282 ! ! 162283 162284!InstructionPrinter class methodsFor: 'printing'! 162285printClass: class 162286 "Create a file whose name is the argument followed by '.bytes'. Store on 162287 the file the symbolic form of the compiled methods of the class." 162288 | file | 162289 file := FileStream newFileNamed: class name , '.bytes'. 162290 class selectors do: 162291 [:sel | 162292 file cr; nextPutAll: sel; cr. 162293 (self on: (class compiledMethodAt: sel)) printInstructionsOn: file]. 162294 file close 162295 "InstructionPrinter printClass: Parser." 162296! ! 162297ClassTestCase subclass: #InstructionPrinterTest 162298 instanceVariableNames: 'tt' 162299 classVariableNames: '' 162300 poolDictionaries: '' 162301 category: 'KernelTests-Methods'! 162302!InstructionPrinterTest commentStamp: '<historical>' prior: 0! 162303This is the unit test for the class InstructionPrinter. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 162304 - http://www.c2.com/cgi/wiki?UnitTest 162305 - http://minnow.cc.gatech.edu/squeak/1547 162306 - the sunit class category! 162307 162308 162309!InstructionPrinterTest methodsFor: 'examples' stamp: 'md 4/8/2003 12:28'! 162310example1 162311 | ff| 162312 (1 < 2) ifTrue: [tt ifNotNil: [ff := 'hallo']]. 162313 ^ ff.! ! 162314 162315 162316!InstructionPrinterTest methodsFor: 'tests' stamp: 'marcus.denker 8/24/2008 13:19'! 162317testInstructions 162318 "just print all of methods of Object and see if no error accours" 162319 162320 | printer | 162321 162322 printer := InstructionPrinter. 162323 162324 Object methods do: [:method | 162325 self shouldnt: [ 162326 String streamContents: [:stream | 162327 (printer on: method) printInstructionsOn: stream]] raise: Error. 162328 ]. 162329! ! 162330Object subclass: #InstructionStream 162331 instanceVariableNames: 'sender pc' 162332 classVariableNames: 'SpecialConstants' 162333 poolDictionaries: '' 162334 category: 'Kernel-Methods'! 162335!InstructionStream commentStamp: '<historical>' prior: 0! 162336My instances can interpret the byte-encoded Smalltalk instruction set. They maintain a program counter (pc) for streaming through CompiledMethods. My subclasses are Contexts, which inherit this capability. They store the return pointer in the instance variable sender, and the current position in their method in the instance variable pc. For other users, sender can hold a method to be similarly interpreted. The unclean re-use of sender to hold the method was to avoid a trivial subclass for the stand-alone scanning function.! 162337 162338 162339!InstructionStream methodsFor: 'debugger access' stamp: 'eem 6/5/2008 10:28'! 162340abstractPC 162341 ^self method abstractPCForConcretePC: pc! ! 162342 162343!InstructionStream methodsFor: 'debugger access' stamp: 'eem 6/5/2008 10:45'! 162344debuggerMap 162345 ^self method debuggerMap! ! 162346 162347 162348!InstructionStream methodsFor: 'decoding' stamp: 'ajh 7/29/2001 20:45'! 162349atEnd 162350 162351 ^ pc > self method endPC! ! 162352 162353!InstructionStream methodsFor: 'decoding' stamp: 'ajh 3/2/2003 14:06'! 162354interpret 162355 162356 [self atEnd] whileFalse: [self interpretNextInstructionFor: self]! ! 162357 162358!InstructionStream methodsFor: 'decoding'! 162359interpretJump 162360 162361 | byte | 162362 byte := self method at: pc. 162363 (byte between: 144 and: 151) ifTrue: 162364 [pc := pc + 1. ^byte - 143]. 162365 (byte between: 160 and: 167) ifTrue: 162366 [pc := pc + 2. ^(byte - 164) * 256 + (self method at: pc - 1)]. 162367 ^nil! ! 162368 162369!InstructionStream methodsFor: 'decoding' stamp: 'eem 9/29/2008 11:59'! 162370interpretJumpIfCond 162371 162372 | byte | 162373 byte := self method at: pc. 162374 (byte between: 152 and: 159) ifTrue: 162375 [pc := pc + 1. ^byte - 151]. 162376 (byte between: 168 and: 175) ifTrue: 162377 [pc := pc + 2. ^(byte bitAnd: 3) * 256 + (self method at: pc - 1)]. 162378 ^nil! ! 162379 162380!InstructionStream methodsFor: 'decoding' stamp: 'md 1/20/2006 17:19'! 162381interpretNextInstructionFor: client 162382 "Send to the argument, client, a message that specifies the type of the 162383 next instruction." 162384 162385 | byte type offset method | 162386 method := self method. 162387 byte := method at: pc. 162388 type := byte // 16. 162389 offset := byte \\ 16. 162390 pc := pc+1. 162391 "We do an inline binary search on each of the possible 16 values of type: 162392 The old, cleaner but slowe code is retained as a comment below" 162393 type < 8 162394 ifTrue: [type < 4 162395 ifTrue: [type < 2 162396 ifTrue: [type < 1 162397 ifTrue: ["type = 0" 162398 ^ client pushReceiverVariable: offset] 162399 ifFalse: ["type = 1" 162400 ^ client pushTemporaryVariable: offset]] 162401 ifFalse: [type < 3 162402 ifTrue: ["type = 2" 162403 ^ client 162404 pushConstant: (method literalAt: offset + 1)] 162405 ifFalse: ["type = 3" 162406 ^ client 162407 pushConstant: (method literalAt: offset + 17)]]] 162408 ifFalse: [type < 6 162409 ifTrue: [type < 5 162410 ifTrue: ["type = 4" 162411 ^ client 162412 pushLiteralVariable: (method literalAt: offset + 1)] 162413 ifFalse: ["type = 5" 162414 ^ client 162415 pushLiteralVariable: (method literalAt: offset + 17)]] 162416 ifFalse: [type < 7 162417 ifTrue: ["type = 6" 162418 offset < 8 162419 ifTrue: [^ client popIntoReceiverVariable: offset] 162420 ifFalse: [^ client popIntoTemporaryVariable: offset - 8]] 162421 ifFalse: ["type = 7" 162422 offset = 0 162423 ifTrue: [^ client pushReceiver]. 162424 offset < 8 162425 ifTrue: [^ client 162426 pushConstant: (SpecialConstants at: offset)]. 162427 offset = 8 162428 ifTrue: [^ client methodReturnReceiver]. 162429 offset < 12 162430 ifTrue: [^ client 162431 methodReturnConstant: (SpecialConstants at: offset - 8)]. 162432 offset = 12 162433 ifTrue: [^ client methodReturnTop]. 162434 offset = 13 162435 ifTrue: [^ client blockReturnTop]. 162436 offset > 13 162437 ifTrue: [^ self error: 'unusedBytecode']]]]] 162438 ifFalse: [type < 12 162439 ifTrue: [type < 10 162440 ifTrue: [type < 9 162441 ifTrue: ["type = 8" 162442 ^ self 162443 interpretExtension: offset 162444 in: method 162445 for: client] 162446 ifFalse: ["type = 9 (short jumps)" 162447 offset < 8 162448 ifTrue: [^ client jump: offset + 1]. 162449 ^ client jump: offset - 8 + 1 if: false]] 162450 ifFalse: [type < 11 162451 ifTrue: ["type = 10 (long jumps)" 162452 byte := method at: pc. 162453 pc := pc + 1. 162454 offset < 8 162455 ifTrue: [^ client jump: offset - 4 * 256 + byte]. 162456 ^ client jump: (offset bitAnd: 3) 162457 * 256 + byte if: offset < 12] 162458 ifFalse: ["type = 11" 162459 ^ client 162460 send: (Smalltalk specialSelectorAt: offset + 1) 162461 super: false 162462 numArgs: (Smalltalk specialNargsAt: offset + 1)]]] 162463 ifFalse: [type = 12 162464 ifTrue: [^ client 162465 send: (Smalltalk specialSelectorAt: offset + 17) 162466 super: false 162467 numArgs: (Smalltalk specialNargsAt: offset + 17)] 162468 ifFalse: ["type = 13, 14 or 15" 162469 ^ client 162470 send: (method literalAt: offset + 1) 162471 super: false 162472 numArgs: type - 13]]]. 162473 162474 162475" old code 162476 type=0 ifTrue: [^client pushReceiverVariable: offset]. 162477 type=1 ifTrue: [^client pushTemporaryVariable: offset]. 162478 type=2 ifTrue: [^client pushConstant: (method literalAt: offset+1)]. 162479 type=3 ifTrue: [^client pushConstant: (method literalAt: offset+17)]. 162480 type=4 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+1)]. 162481 type=5 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+17)]. 162482 type=6 162483 ifTrue: [offset<8 162484 ifTrue: [^client popIntoReceiverVariable: offset] 162485 ifFalse: [^client popIntoTemporaryVariable: offset-8]]. 162486 type=7 162487 ifTrue: [offset=0 ifTrue: [^client pushReceiver]. 162488 offset<8 ifTrue: [^client pushConstant: (SpecialConstants at: offset)]. 162489 offset=8 ifTrue: [^client methodReturnReceiver]. 162490 offset<12 ifTrue: [^client methodReturnConstant: 162491 (SpecialConstants at: offset-8)]. 162492 offset=12 ifTrue: [^client methodReturnTop]. 162493 offset=13 ifTrue: [^client blockReturnTop]. 162494 offset>13 ifTrue: [^self error: 'unusedBytecode']]. 162495 type=8 ifTrue: [^self interpretExtension: offset in: method for: client]. 162496 type=9 162497 ifTrue: short jumps 162498 [offset<8 ifTrue: [^client jump: offset+1]. 162499 ^client jump: offset-8+1 if: false]. 162500 type=10 162501 ifTrue: long jumps 162502 [byte:= method at: pc. pc:= pc+1. 162503 offset<8 ifTrue: [^client jump: offset-4*256 + byte]. 162504 ^client jump: (offset bitAnd: 3)*256 + byte if: offset<12]. 162505 type=11 162506 ifTrue: 162507 [^client 162508 send: (Smalltalk specialSelectorAt: offset+1) 162509 super: false 162510 numArgs: (Smalltalk specialNargsAt: offset+1)]. 162511 type=12 162512 ifTrue: 162513 [^client 162514 send: (Smalltalk specialSelectorAt: offset+17) 162515 super: false 162516 numArgs: (Smalltalk specialNargsAt: offset+17)]. 162517 type>12 162518 ifTrue: 162519 [^client send: (method literalAt: offset+1) 162520 super: false 162521 numArgs: type-13]"! ! 162522 162523 162524!InstructionStream methodsFor: 'scanning' stamp: 'eem 6/4/2008 10:58'! 162525addSelectorTo: set 162526 "If this instruction is a send, add its selector to set." 162527 162528 | selectorOrSelf | 162529 (selectorOrSelf := self selectorToSendOrSelf) == self ifFalse: 162530 [set add: selectorOrSelf]! ! 162531 162532!InstructionStream methodsFor: 'scanning' stamp: 'eem 6/16/2008 09:52'! 162533firstByte 162534 "Answer the first byte of the current bytecode." 162535 162536 ^self method at: pc! ! 162537 162538!InstructionStream methodsFor: 'scanning'! 162539followingByte 162540 "Answer the next bytecode." 162541 162542 ^self method at: pc + 1! ! 162543 162544!InstructionStream methodsFor: 'scanning' stamp: 'eem 6/16/2008 09:53'! 162545fourthByte 162546 "Answer the fourth byte of the current bytecode." 162547 162548 ^self method at: pc + 3! ! 162549 162550!InstructionStream methodsFor: 'scanning'! 162551method 162552 "Answer the compiled method that supplies the receiver's bytecodes." 162553 162554 ^sender "method access when used alone (not as part of a context)"! ! 162555 162556!InstructionStream methodsFor: 'scanning'! 162557nextByte 162558 "Answer the next bytecode." 162559 162560 ^self method at: pc! ! 162561 162562!InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:32'! 162563nextInstruction 162564 "Return the next bytecode instruction as a message that an InstructionClient would understand. This advances the pc by one instruction." 162565 162566 ^ self interpretNextInstructionFor: MessageCatcher new! ! 162567 162568!InstructionStream methodsFor: 'scanning'! 162569pc 162570 "Answer the index of the next bytecode." 162571 162572 ^pc! ! 162573 162574!InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:36'! 162575peekInstruction 162576 "Return the next bytecode instruction as a message that an InstructionClient would understand. The pc remains unchanged." 162577 162578 | currentPc instr | 162579 currentPc := self pc. 162580 instr := self nextInstruction. 162581 self pc: currentPc. 162582 ^ instr! ! 162583 162584!InstructionStream methodsFor: 'scanning' stamp: 'eem 6/5/2008 10:07'! 162585previousPc 162586 162587 ^self method pcPreviousTo: pc! ! 162588 162589!InstructionStream methodsFor: 'scanning' stamp: 'eem 6/16/2008 09:51'! 162590scanFor: scanBlock 162591 "Answer the index of the first bytecode for which scanBlock answer true 162592 when supplied with that bytecode." 162593 162594 | method end byte type | 162595 method := self method. 162596 end := method endPC. 162597 [pc <= end] whileTrue: 162598 [(scanBlock value: (byte := method at: pc)) ifTrue: 162599 [^true]. 162600 type := byte // 16. 162601 pc := type = 8 "extensions" 162602 ifTrue: [pc + (#(2 2 2 2 3 2 2 1 1 1 2 1 3 3 3 4) at: byte \\ 16 + 1)] 162603 ifFalse: [type = 10 "long jumps" 162604 ifTrue: [pc + 2] 162605 ifFalse: [pc + 1]]]. 162606 ^false! ! 162607 162608!InstructionStream methodsFor: 'scanning' stamp: 'eem 6/16/2008 09:52'! 162609secondByte 162610 "Answer the second byte of the current bytecode." 162611 162612 ^self method at: pc + 1! ! 162613 162614!InstructionStream methodsFor: 'scanning' stamp: 'eem 6/4/2008 10:57'! 162615selectorToSendOrSelf 162616 "If this instruction is a send, answer the selector, otherwise answer self." 162617 162618 | byte byte2 | 162619 byte := self method at: pc. 162620 byte < 131 ifTrue: [^self]. 162621 byte >= 176 162622 ifTrue: 162623 ["special byte or short send" 162624 byte >= 208 162625 ifTrue: [^self method literalAt: (byte bitAnd: 15) + 1] 162626 ifFalse: [^Smalltalk specialSelectorAt: byte - 176 + 1]] 162627 ifFalse: 162628 [byte <= 134 ifTrue: 162629 [byte2 := self method at: pc + 1. 162630 byte = 131 ifTrue: [^self method literalAt: byte2 \\ 32 + 1]. 162631 byte = 132 ifTrue: [byte2 < 64 ifTrue: [^self method literalAt: (self method at: pc + 2) + 1]]. 162632 byte = 133 ifTrue: [^self method literalAt: byte2 \\ 32 + 1]. 162633 byte = 134 ifTrue: [^self method literalAt: byte2 \\ 64 + 1]]]! ! 162634 162635!InstructionStream methodsFor: 'scanning' stamp: 'hmm 7/29/2001 21:25'! 162636skipBackBeforeJump 162637 "Assuming that the receiver is positioned jast after a jump, skip back one or two bytes, depending on the size of the previous jump instruction." 162638 | strm short | 162639 strm := InstructionStream on: self method. 162640 (strm scanFor: [:byte | 162641 ((short := byte between: 152 and: 159) or: [byte between: 168 and: 175]) 162642 and: [strm pc = (short ifTrue: [pc-1] ifFalse: [pc-2])]]) ifFalse: [self error: 'Where''s the jump??']. 162643 self jump: (short ifTrue: [-1] ifFalse: [-2]). 162644! ! 162645 162646!InstructionStream methodsFor: 'scanning' stamp: 'eem 6/16/2008 09:52'! 162647thirdByte 162648 "Answer the third byte of the current bytecode." 162649 162650 ^self method at: pc + 2! ! 162651 162652 162653!InstructionStream methodsFor: 'testing' stamp: 'ajh 8/13/2002 11:34'! 162654willBlockReturn 162655 162656 ^ (self method at: pc) = Encoder blockReturnCode! ! 162657 162658!InstructionStream methodsFor: 'testing' stamp: 'ajh 8/13/2002 11:10'! 162659willJump 162660 "unconditionally" 162661 162662 | byte | 162663 byte := self method at: pc. 162664 ^ (byte between: 144 and: 151) or: [byte between: 160 and: 167]! ! 162665 162666!InstructionStream methodsFor: 'testing'! 162667willJumpIfFalse 162668 "Answer whether the next bytecode is a jump-if-false." 162669 162670 | byte | 162671 byte := self method at: pc. 162672 ^(byte between: 152 and: 159) or: [byte between: 172 and: 175]! ! 162673 162674!InstructionStream methodsFor: 'testing' stamp: 'di 1/29/2000 14:42'! 162675willJumpIfTrue 162676 "Answer whether the next bytecode is a jump-if-true." 162677 162678 | byte | 162679 byte := self method at: pc. 162680 ^ byte between: 168 and: 171! ! 162681 162682!InstructionStream methodsFor: 'testing' stamp: 'ajh 8/13/2002 17:32'! 162683willJustPop 162684 162685 ^ (self method at: pc) = Encoder popCode! ! 162686 162687!InstructionStream methodsFor: 'testing' stamp: 'eem 6/19/2008 23:32'! 162688willReallySend 162689 "Answer whether the next bytecode is a real message-send, 162690 not blockCopy:." 162691 162692 | byte | 162693 byte := self method at: pc. 162694 ^byte >= 131 162695 and: [byte ~~ 200 162696 and: [byte >= 176 "special send or short send" 162697 or: [byte <= 134 "long sends" 162698 and: [| litIndex | 162699 "long form support demands we check the selector" 162700 litIndex := byte = 132 162701 ifTrue: [(self method at: pc + 1) // 32 > 1 ifTrue: [^false]. 162702 self method at: pc + 2] 162703 ifFalse: [byte = 134 162704 ifTrue: [(self method at: pc + 1) bitAnd: 2r111111] 162705 ifFalse: [(self method at: pc + 1) bitAnd: 2r11111]]. 162706 (self method literalAt: litIndex + 1) ~~ #blockCopy:]]]]! ! 162707 162708!InstructionStream methodsFor: 'testing'! 162709willReturn 162710 "Answer whether the next bytecode is a return." 162711 162712 ^(self method at: pc) between: 120 and: 125! ! 162713 162714!InstructionStream methodsFor: 'testing' stamp: 'eem 5/16/2008 16:22'! 162715willSend 162716 "Answer whether the next bytecode is a message-send." 162717 162718 | byte | 162719 byte := self method at: pc. 162720 ^byte >= 131 162721 and: [byte >= 176 "special send or short send" 162722 or: [byte <= 134]] "long sends"! ! 162723 162724!InstructionStream methodsFor: 'testing' stamp: 'eem 6/4/2008 15:58'! 162725willStore 162726 "Answer whether the next bytecode is a store or store-pop" 162727 162728 | byte | 162729 byte := self method at: pc. 162730 ^(byte between: 96 and: 142) 162731 and: [byte <= 111 "96 103 storeAndPopReceiverVariableBytecode" 162732 "104 111 storeAndPopTemporaryVariableBytecode" 162733 or: [byte >= 129 "129 extendedStoreBytecode" 162734 and: [byte <= 130 "130 extendedStoreAndPopBytecode" 162735 or: [(byte = 132 "132 doubleExtendedDoAnythingBytecode" 162736 and: [(self method at: pc+1) >= 160]) 162737 or: [byte = 141 "141 storeRemoteTempLongBytecode" 162738 or: [byte = 142 "142 storeAndPopRemoteTempLongBytecode"]]]]]]! ! 162739 162740!InstructionStream methodsFor: 'testing' stamp: 'eem 6/4/2008 15:56'! 162741willStorePop 162742 "Answer whether the next bytecode is a store-pop." 162743 162744 | byte | 162745 byte := self method at: pc. 162746 ^byte = 130 "130 extendedStoreAndPopBytecode" 162747 or: [byte = 142 "142 storeAndPopRemoteTempLongBytecode" 162748 or: [byte between: 96 and: 111 "96 103 storeAndPopReceiverVariableBytecode" 162749 "104 111 storeAndPopTemporaryVariableBytecode"]]! ! 162750 162751 162752!InstructionStream methodsFor: 'private' stamp: 'eem 6/16/2008 09:49'! 162753interpretExtension: offset in: method for: client 162754 | type offset2 byte2 byte3 byte4 | 162755 offset <= 6 ifTrue: 162756 ["Extended op codes 128-134" 162757 byte2 := method at: pc. pc := pc + 1. 162758 offset <= 2 ifTrue: 162759 ["128-130: extended pushes and pops" 162760 type := byte2 // 64. 162761 offset2 := byte2 \\ 64. 162762 offset = 0 ifTrue: 162763 [type = 0 ifTrue: [^client pushReceiverVariable: offset2]. 162764 type = 1 ifTrue: [^client pushTemporaryVariable: offset2]. 162765 type = 2 ifTrue: [^client pushConstant: (method literalAt: offset2 + 1)]. 162766 type = 3 ifTrue: [^client pushLiteralVariable: (method literalAt: offset2 + 1)]]. 162767 offset = 1 ifTrue: 162768 [type = 0 ifTrue: [^client storeIntoReceiverVariable: offset2]. 162769 type = 1 ifTrue: [^client storeIntoTemporaryVariable: offset2]. 162770 type = 2 ifTrue: [self error: 'illegalStore']. 162771 type = 3 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]]. 162772 offset = 2 ifTrue: 162773 [type = 0 ifTrue: [^client popIntoReceiverVariable: offset2]. 162774 type = 1 ifTrue: [^client popIntoTemporaryVariable: offset2]. 162775 type = 2 ifTrue: [self error: 'illegalStore']. 162776 type = 3 ifTrue: [^client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]]. 162777 "131-134: extended sends" 162778 offset = 3 ifTrue: "Single extended send" 162779 [^client send: (method literalAt: byte2 \\ 32 + 1) 162780 super: false numArgs: byte2 // 32]. 162781 offset = 4 ifTrue: "Double extended do-anything" 162782 [byte3 := method at: pc. pc := pc + 1. 162783 type := byte2 // 32. 162784 type = 0 ifTrue: [^client send: (method literalAt: byte3 + 1) 162785 super: false numArgs: byte2 \\ 32]. 162786 type = 1 ifTrue: [^client send: (method literalAt: byte3 + 1) 162787 super: true numArgs: byte2 \\ 32]. 162788 type = 2 ifTrue: [^client pushReceiverVariable: byte3]. 162789 type = 3 ifTrue: [^client pushConstant: (method literalAt: byte3 + 1)]. 162790 type = 4 ifTrue: [^client pushLiteralVariable: (method literalAt: byte3 + 1)]. 162791 type = 5 ifTrue: [^client storeIntoReceiverVariable: byte3]. 162792 type = 6 ifTrue: [^client popIntoReceiverVariable: byte3]. 162793 type = 7 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: byte3 + 1)]]. 162794 offset = 5 ifTrue: "Single extended send to super" 162795 [^client send: (method literalAt: byte2 \\ 32 + 1) 162796 super: true numArgs: byte2 // 32]. 162797 offset = 6 ifTrue: "Second extended send" 162798 [^client send: (method literalAt: byte2 \\ 64 + 1) 162799 super: false numArgs: byte2 // 64]]. 162800 offset = 7 ifTrue: [^client doPop]. 162801 offset = 8 ifTrue: [^client doDup]. 162802 offset = 9 ifTrue: [^client pushActiveContext]. 162803 byte2 := method at: pc. pc := pc + 1. 162804 offset = 10 ifTrue: 162805 [^byte2 < 128 162806 ifTrue: [client pushNewArrayOfSize: byte2] 162807 ifFalse: [client pushConsArrayWithElements: byte2 - 128]]. 162808 offset = 11 ifTrue: [^self error: 'unusedBytecode']. 162809 byte3 := method at: pc. pc := pc + 1. 162810 offset = 12 ifTrue: [^client pushRemoteTemp: byte2 inVectorAt: byte3]. 162811 offset = 13 ifTrue: [^client storeIntoRemoteTemp: byte2 inVectorAt: byte3]. 162812 offset = 14 ifTrue: [^client popIntoRemoteTemp: byte2 inVectorAt: byte3]. 162813 "offset = 15" 162814 byte4 := method at: pc. pc := pc + 1. 162815 ^client 162816 pushClosureCopyNumCopiedValues: (byte2 bitShift: -4) 162817 numArgs: (byte2 bitAnd: 16rF) 162818 blockSize: (byte3 * 256) + byte4! ! 162819 162820!InstructionStream methodsFor: 'private'! 162821method: method pc: startpc 162822 162823 sender := method. 162824 "allows this class to stand alone as a method scanner" 162825 pc := startpc! ! 162826 162827!InstructionStream methodsFor: 'private' stamp: 'ajh 8/1/2001 02:57'! 162828pc: n 162829 162830 pc := n! ! 162831 162832"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 162833 162834InstructionStream class 162835 instanceVariableNames: ''! 162836 162837!InstructionStream class methodsFor: 'class initialization'! 162838initialize 162839 "Initialize an array of special constants returned by single-bytecode returns." 162840 162841 SpecialConstants := 162842 (Array with: true with: false with: nil) 162843 , (Array with: -1 with: 0 with: 1 with: 2) 162844 "InstructionStream initialize." 162845! ! 162846 162847 162848!InstructionStream class methodsFor: 'compiling' stamp: 'eem 7/17/2008 13:16'! 162849instVarNamesAndOffsetsDo: aBinaryBlock 162850 "This is part of the interface between the compiler and a class's instance or field names. 162851 We override here to arrange that the compiler will use MaybeContextInstanceVariableNodes 162852 for instances variables of ContextPart or any of its superclasses and subclasses. The 162853 convention to make the compiler use the special nodes is to use negative indices" 162854 162855 | superInstSize | 162856 (self withAllSubclasses noneSatisfy: [:class|class isContextClass]) ifTrue: 162857 [^super instVarNamesAndOffsetsDo: aBinaryBlock]. 162858 (superInstSize := superclass notNil ifTrue: [superclass instSize] ifFalse: [0]) > 0 ifTrue: 162859 [superclass instVarNamesAndOffsetsDo: aBinaryBlock]. 162860 1 to: self instSize - superInstSize do: 162861 [:i| aBinaryBlock value: (instanceVariables at: i) value: (i + superInstSize) negated]! ! 162862 162863!InstructionStream class methodsFor: 'compiling' stamp: 'eem 6/19/2008 10:00'! 162864isContextClass 162865 ^false! ! 162866 162867 162868!InstructionStream class methodsFor: 'instance creation'! 162869on: method 162870 "Answer an instance of me on the argument, method." 162871 162872 ^self new method: method pc: method initialPC! ! 162873Number subclass: #Integer 162874 instanceVariableNames: '' 162875 classVariableNames: '' 162876 poolDictionaries: '' 162877 category: 'Kernel-Numbers'! 162878!Integer commentStamp: '<historical>' prior: 0! 162879I am a common abstract superclass for all Integer implementations. My implementation subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger. 162880 162881Integer division consists of: 162882 / exact division, answers a fraction if result is not a whole integer 162883 // answers an Integer, rounded towards negative infinity 162884 \\ is modulo rounded towards negative infinity 162885 quo: truncated division, rounded towards zero! 162886 162887 162888!Integer methodsFor: '*system-hashing-core' stamp: 'PeterHugossonMiller 9/3/2009 10:00'! 162889asArray 162890 162891 | stream | 162892 stream := Array new writeStream. 162893 self digitLength to: 1 by: -1 do: [:digitIndex | 162894 stream nextPut: (self digitAt: digitIndex)]. 162895 ^ stream contents 162896! ! 162897 162898!Integer methodsFor: '*system-hashing-core' stamp: 'PeterHugossonMiller 9/3/2009 10:01'! 162899asByteArray 162900 162901 | stream | 162902 stream := ByteArray new writeStream. 162903 self digitLength to: 1 by: -1 do: [:digitIndex | 162904 stream nextPut: (self digitAt: digitIndex)]. 162905 ^ stream contents 162906! ! 162907 162908!Integer methodsFor: '*system-hashing-core' stamp: 'StephaneDucasse 10/17/2009 17:15'! 162909asByteArrayOfSize: aSize 162910 "Answer a ByteArray of aSize with my value, most-significant byte first." 162911 | answer digitPos | 162912 aSize < self digitLength ifTrue: [ self error: 'number to large for byte array' ]. 162913 answer := ByteArray new: aSize. 162914 digitPos := 1. 162915 aSize 162916 to: aSize - self digitLength + 1 162917 by: -1 162918 do: 162919 [ :pos | 162920 answer 162921 at: pos 162922 put: (self digitAt: digitPos). 162923 digitPos := digitPos + 1 ]. 162924 ^ answer! ! 162925 162926 162927!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'! 162928* aNumber 162929 "Refer to the comment in Number * " 162930 aNumber isInteger ifTrue: 162931 [^ self digitMultiply: aNumber 162932 neg: self negative ~~ aNumber negative]. 162933 ^ aNumber adaptToInteger: self andSend: #*! ! 162934 162935!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'! 162936+ aNumber 162937 "Refer to the comment in Number + " 162938 aNumber isInteger ifTrue: 162939 [self negative == aNumber negative 162940 ifTrue: [^ (self digitAdd: aNumber) normalize] 162941 ifFalse: [^ self digitSubtract: aNumber]]. 162942 ^ aNumber adaptToInteger: self andSend: #+! ! 162943 162944!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'! 162945- aNumber 162946 "Refer to the comment in Number - " 162947 aNumber isInteger ifTrue: 162948 [self negative == aNumber negative 162949 ifTrue: [^ self digitSubtract: aNumber] 162950 ifFalse: [^ (self digitAdd: aNumber) normalize]]. 162951 ^ aNumber adaptToInteger: self andSend: #-! ! 162952 162953!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:00'! 162954/ aNumber 162955 "Refer to the comment in Number / " 162956 | quoRem | 162957 aNumber isInteger ifTrue: 162958 [quoRem := self digitDiv: aNumber abs "*****I've added abs here*****" 162959 neg: self negative ~~ aNumber negative. 162960 (quoRem at: 2) = 0 162961 ifTrue: [^ (quoRem at: 1) normalize] 162962 ifFalse: [^ (Fraction numerator: self denominator: aNumber) reduced]]. 162963 ^ aNumber adaptToInteger: self andSend: #/! ! 162964 162965!Integer methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49'! 162966// aNumber 162967 | q | 162968 #Numeric. 162969 "Changed 200/01/19 For ANSI support." 162970 aNumber = 0 ifTrue: [^ (ZeroDivide dividend: self) signal"<- Chg"]. 162971 self = 0 ifTrue: [^ 0]. 162972 q := self quo: aNumber. 162973 "Refer to the comment in Number|//." 162974 (q negative 162975 ifTrue: [q * aNumber ~= self] 162976 ifFalse: [q = 0 and: [self negative ~= aNumber negative]]) 162977 ifTrue: [^ q - 1"Truncate towards minus infinity."] 162978 ifFalse: [^ q]! ! 162979 162980!Integer methodsFor: 'arithmetic' stamp: 'bf 9/25/2008 15:13'! 162981\\\ anInteger 162982 "a modulo method for use in DSA. Be careful if you try to use this elsewhere." 162983 162984 ^self \\ anInteger! ! 162985 162986!Integer methodsFor: 'arithmetic'! 162987alignedTo: anInteger 162988 "Answer the smallest number not less than receiver that is a multiple of anInteger." 162989 162990 ^(self+anInteger-1//anInteger)*anInteger 162991 162992"5 alignedTo: 2" 162993"12 alignedTo: 3"! ! 162994 162995!Integer methodsFor: 'arithmetic' stamp: 'mga 5/11/2006 15:42'! 162996crossSumBase: aBase 162997 |aResult| 162998 "Precondition" 162999 self assert:[aBase isInteger and: [aBase >=2]]. 163000 163001 self < 0 ifTrue: [^self negated crossSumBase: aBase]. 163002 self < aBase ifTrue: [^ self]. 163003 aResult := self \\ aBase + (self // aBase crossSumBase: aBase). 163004 163005 "Postcondition 163006 E.g. 18 crossSumBase: 10 -> 9 => 18\\(10-1) = 0" 163007 self assert: [((aResult \\ (aBase - 1) = 0)) = ((self \\ (aBase - 1)) =0)]. 163008 ^aResult! ! 163009 163010!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:00'! 163011quo: aNumber 163012 "Refer to the comment in Number quo: " 163013 | ng quo | 163014 aNumber isInteger ifTrue: 163015 [ng := self negative == aNumber negative == false. 163016 quo := (self digitDiv: 163017 (aNumber class == SmallInteger 163018 ifTrue: [aNumber abs] 163019 ifFalse: [aNumber]) 163020 neg: ng) at: 1. 163021 ^ quo normalize]. 163022 ^ aNumber adaptToInteger: self andSend: #quo:! ! 163023 163024 163025!Integer methodsFor: 'benchmarks' stamp: 'jm 11/20/1998 07:06'! 163026benchFib "Handy send-heavy benchmark" 163027 "(result // seconds to run) = approx calls per second" 163028 " | r t | 163029 t := Time millisecondsToRun: [r := 26 benchFib]. 163030 (r * 1000) // t" 163031 "138000 on a Mac 8100/100" 163032 ^ self < 2 163033 ifTrue: [1] 163034 ifFalse: [(self-1) benchFib + (self-2) benchFib + 1] 163035! ! 163036 163037!Integer methodsFor: 'benchmarks' stamp: 'di 4/11/1999 11:20'! 163038benchmark "Handy bytecode-heavy benchmark" 163039 "(500000 // time to run) = approx bytecodes per second" 163040 "5000000 // (Time millisecondsToRun: [10 benchmark]) * 1000" 163041 "3059000 on a Mac 8100/100" 163042 | size flags prime k count | 163043 size := 8190. 163044 1 to: self do: 163045 [:iter | 163046 count := 0. 163047 flags := (Array new: size) atAllPut: true. 163048 1 to: size do: 163049 [:i | (flags at: i) ifTrue: 163050 [prime := i+1. 163051 k := i + prime. 163052 [k <= size] whileTrue: 163053 [flags at: k put: false. 163054 k := k + prime]. 163055 count := count + 1]]]. 163056 ^ count! ! 163057 163058!Integer methodsFor: 'benchmarks' stamp: 'adrian-lienhard 5/18/2009 20:33'! 163059tinyBenchmarks 163060 "Report the results of running the two tiny Squeak benchmarks. 163061 ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results" 163062 "0 tinyBenchmarks" 163063 "On a 292 MHz G3 Mac: 22727272 bytecodes/sec; 984169 sends/sec" 163064 "On a 400 MHz PII/Win98: 18028169 bytecodes/sec; 1081272 sends/sec" 163065 | t1 t2 r n1 n2 | 163066 n1 := 1. 163067 [t1 := Time millisecondsToRun: [n1 benchmark]. 163068 t1 < 1000] whileTrue:[n1 := n1 * 2]. "Note: #benchmark's runtime is about O(n)" 163069 163070 n2 := 28. 163071 [t2 := Time millisecondsToRun: [r := n2 benchFib]. 163072 t2 < 1000] whileTrue:[n2 := n2 + 1]. "Note: #benchFib's runtime is about O(n^2)." 163073 163074 ^ ((n1 * 500000 * 1000) // t1) printString, ' bytecodes/sec; ', 163075 ((r * 1000) // t2) printString, ' sends/sec'! ! 163076 163077 163078!Integer methodsFor: 'bit manipulation' stamp: 'adrian-lienhard 5/18/2009 20:35'! 163079<< shiftAmount 163080 "left shift" 163081 163082 shiftAmount < 0 ifTrue: [self error: 'negative arg']. 163083 ^ self bitShift: shiftAmount! ! 163084 163085!Integer methodsFor: 'bit manipulation' stamp: 'adrian-lienhard 5/18/2009 20:34'! 163086>> shiftAmount 163087 "right shift" 163088 163089 shiftAmount < 0 ifTrue: [self error: 'negative arg']. 163090 ^ self bitShift: 0 - shiftAmount! ! 163091 163092!Integer methodsFor: 'bit manipulation'! 163093allMask: mask 163094 "Treat the argument as a bit mask. Answer whether all of the bits that 163095 are 1 in the argument are 1 in the receiver." 163096 163097 ^mask = (self bitAnd: mask)! ! 163098 163099!Integer methodsFor: 'bit manipulation' stamp: 'sr 11/29/2000 14:32'! 163100anyBitOfMagnitudeFrom: start to: stopArg 163101 "Tests for any magnitude bits in the interval from start to stopArg." 163102 "Primitive fixed in LargeIntegers v1.2. If you have an earlier version 163103 comment out the primitive call (using this ST method then)." 163104 | magnitude firstDigitIx lastDigitIx rightShift leftShift stop | 163105 <primitive: 'primAnyBitFromTo' module:'LargeIntegers'> 163106 start < 1 | (stopArg < 1) 163107 ifTrue: [^ self error: 'out of range']. 163108 magnitude := self abs. 163109 stop := stopArg min: magnitude highBit. 163110 start > stop 163111 ifTrue: [^ false]. 163112 firstDigitIx := start - 1 // 8 + 1. 163113 lastDigitIx := stop - 1 // 8 + 1. 163114 rightShift := (start - 1 \\ 8) negated. 163115 leftShift := 7 - (stop - 1 \\ 8). 163116 firstDigitIx = lastDigitIx 163117 ifTrue: [| digit mask | 163118 mask := (255 bitShift: rightShift negated) 163119 bitAnd: (255 bitShift: leftShift negated). 163120 digit := magnitude digitAt: firstDigitIx. 163121 ^ (digit bitAnd: mask) 163122 ~= 0]. 163123 ((magnitude digitAt: firstDigitIx) 163124 bitShift: rightShift) 163125 ~= 0 163126 ifTrue: [^ true]. 163127 firstDigitIx + 1 163128 to: lastDigitIx - 1 163129 do: [:ix | (magnitude digitAt: ix) 163130 ~= 0 163131 ifTrue: [^ true]]. 163132 (((magnitude digitAt: lastDigitIx) 163133 bitShift: leftShift) 163134 bitAnd: 255) 163135 ~= 0 163136 ifTrue: [^ true]. 163137 ^ false! ! 163138 163139!Integer methodsFor: 'bit manipulation'! 163140anyMask: mask 163141 "Treat the argument as a bit mask. Answer whether any of the bits that 163142 are 1 in the argument are 1 in the receiver." 163143 163144 ^0 ~= (self bitAnd: mask)! ! 163145 163146!Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'! 163147bitAnd: n 163148 "Answer an Integer whose bits are the logical AND of the receiver's bits 163149 and those of the argument, n." 163150 | norm | 163151 <primitive: 'primDigitBitAnd' module:'LargeIntegers'> 163152 norm := n normalize. 163153 ^ self 163154 digitLogic: norm 163155 op: #bitAnd: 163156 length: (self digitLength max: norm digitLength)! ! 163157 163158!Integer methodsFor: 'bit manipulation' stamp: 'nice 3/21/2008 21:47'! 163159bitAt: anInteger 163160 "Answer 1 if the bit at position anInteger is set to 1, 0 otherwise. 163161 self is considered an infinite sequence of bits, so anInteger can be any strictly positive integer. 163162 Bit at position 1 is the least significant bit. 163163 Negative numbers are in two-complements. 163164 163165 This is a naive implementation that can be refined in subclass for speed" 163166 163167 ^(self bitShift: 1 - anInteger) bitAnd: 1! ! 163168 163169!Integer methodsFor: 'bit manipulation' stamp: 'di 4/30/1998 10:32'! 163170bitClear: aMask 163171 "Answer an Integer equal to the receiver, except with all bits cleared that are set in aMask." 163172 163173 ^ (self bitOr: aMask) - aMask! ! 163174 163175!Integer methodsFor: 'bit manipulation' stamp: 'tak 9/25/2008 15:17'! 163176bitInvert 163177 "Answer an Integer whose bits are the logical negation of the receiver's bits. 163178 Numbers are interpreted as having 2's-complement representation." 163179 163180 ^ -1 - self.! ! 163181 163182!Integer methodsFor: 'bit manipulation'! 163183bitInvert32 163184 "Answer the 32-bit complement of the receiver." 163185 163186 ^ self bitXor: 16rFFFFFFFF! ! 163187 163188!Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'! 163189bitOr: n 163190 "Answer an Integer whose bits are the logical OR of the receiver's bits 163191 and those of the argument, n." 163192 | norm | 163193 <primitive: 'primDigitBitOr' module:'LargeIntegers'> 163194 norm := n normalize. 163195 ^ self 163196 digitLogic: norm 163197 op: #bitOr: 163198 length: (self digitLength max: norm digitLength)! ! 163199 163200!Integer methodsFor: 'bit manipulation' stamp: 'sr 6/9/2000 10:09'! 163201bitShift: shiftCount 163202 "Answer an Integer whose value (in twos-complement representation) is 163203 the receiver's value (in twos-complement representation) shifted left by 163204 the number of bits indicated by the argument. Negative arguments 163205 shift right. Zeros are shifted in from the right in left shifts." 163206 | magnitudeShift | 163207 magnitudeShift := self bitShiftMagnitude: shiftCount. 163208 ^ ((self negative and: [shiftCount negative]) 163209 and: [self anyBitOfMagnitudeFrom: 1 to: shiftCount negated]) 163210 ifTrue: [magnitudeShift - 1] 163211 ifFalse: [magnitudeShift]! ! 163212 163213!Integer methodsFor: 'bit manipulation' stamp: 'sr 6/9/2000 14:02'! 163214bitShiftMagnitude: shiftCount 163215 "Answer an Integer whose value (in magnitude representation) is 163216 the receiver's value (in magnitude representation) shifted left by 163217 the number of bits indicated by the argument. Negative arguments 163218 shift right. Zeros are shifted in from the right in left shifts." 163219 | rShift | 163220 <primitive: 'primDigitBitShiftMagnitude' module:'LargeIntegers'> 163221 shiftCount >= 0 ifTrue: [^ self digitLshift: shiftCount]. 163222 rShift := 0 - shiftCount. 163223 ^ (self 163224 digitRshift: (rShift bitAnd: 7) 163225 bytes: (rShift bitShift: -3) 163226 lookfirst: self digitLength) normalize! ! 163227 163228!Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'! 163229bitXor: n 163230 "Answer an Integer whose bits are the logical XOR of the receiver's bits 163231 and those of the argument, n." 163232 | norm | 163233 <primitive: 'primDigitBitXor' module:'LargeIntegers'> 163234 norm := n normalize. 163235 ^ self 163236 digitLogic: norm 163237 op: #bitXor: 163238 length: (self digitLength max: norm digitLength)! ! 163239 163240!Integer methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:13'! 163241highBit 163242 "Answer the index of the high order bit of the receiver, or zero if the 163243 receiver is zero. Raise an error if the receiver is negative, since 163244 negative integers are defined to have an infinite number of leading 1's 163245 in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to 163246 get the highest bit of the magnitude." 163247 163248 ^ self subclassResponsibility! ! 163249 163250!Integer methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 01:55'! 163251highBitOfMagnitude 163252 "Answer the index of the high order bit of the magnitude of the 163253 receiver, or zero if the receiver is zero." 163254 ^ self subclassResponsibility! ! 163255 163256!Integer methodsFor: 'bit manipulation' stamp: 'jm 2/19/98 12:11'! 163257lowBit 163258 "Answer the index of the low order bit of this number." 163259 | index | 163260 self = 0 ifTrue: [ ^ 0 ]. 163261 index := 1. 163262 [ (self digitAt: index) = 0 ] 163263 whileTrue: 163264 [ index := index + 1 ]. 163265 ^ (self digitAt: index) lowBit + (8 * (index - 1))! ! 163266 163267!Integer methodsFor: 'bit manipulation'! 163268noMask: mask 163269 "Treat the argument as a bit mask. Answer whether none of the bits that 163270 are 1 in the argument are 1 in the receiver." 163271 163272 ^0 = (self bitAnd: mask)! ! 163273 163274 163275!Integer methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:38'! 163276< aNumber 163277 aNumber isInteger ifTrue: 163278 [self negative == aNumber negative 163279 ifTrue: [self negative 163280 ifTrue: [^ (self digitCompare: aNumber) > 0] 163281 ifFalse: [^ (self digitCompare: aNumber) < 0]] 163282 ifFalse: [^ self negative]]. 163283 ^ aNumber adaptToInteger: self andCompare: #<! ! 163284 163285!Integer methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:41'! 163286= aNumber 163287 aNumber isNumber ifFalse: [^ false]. 163288 aNumber isInteger ifTrue: 163289 [aNumber negative == self negative 163290 ifTrue: [^ (self digitCompare: aNumber) = 0] 163291 ifFalse: [^ false]]. 163292 ^ aNumber adaptToInteger: self andCompare: #=! ! 163293 163294!Integer methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:38'! 163295> aNumber 163296 aNumber isInteger ifTrue: 163297 [self negative == aNumber negative 163298 ifTrue: [self negative 163299 ifTrue: [^(self digitCompare: aNumber) < 0] 163300 ifFalse: [^(self digitCompare: aNumber) > 0]] 163301 ifFalse: [^ aNumber negative]]. 163302 ^ aNumber adaptToInteger: self andCompare: #>! ! 163303 163304!Integer methodsFor: 'comparing'! 163305hash 163306 "Hash is reimplemented because = is implemented." 163307 163308 ^(self lastDigit bitShift: 8) + (self digitAt: 1)! ! 163309 163310 163311!Integer methodsFor: 'converting' stamp: 'mk 10/27/2003 17:45'! 163312adaptToComplex: rcvr andSend: selector 163313 "If I am involved in arithmetic with a Complex number, convert me to a Complex number." 163314 ^ rcvr perform: selector with: self asComplex! ! 163315 163316!Integer methodsFor: 'converting' stamp: 'di 11/6/1998 13:43'! 163317adaptToFraction: rcvr andSend: selector 163318 "If I am involved in arithmetic with a Fraction, convert me to a Fraction." 163319 ^ rcvr perform: selector with: self asFraction! ! 163320 163321!Integer methodsFor: 'converting' stamp: 'ar 4/9/2005 22:31'! 163322asCharacter 163323 "Answer the Character whose value is the receiver." 163324 ^Character value: self! ! 163325 163326!Integer methodsFor: 'converting' stamp: 'ar 10/31/1998 23:04'! 163327asColorOfDepth: d 163328 "Return a color value representing the receiver as color of the given depth" 163329 ^Color colorFromPixelValue: self depth: d! ! 163330 163331!Integer methodsFor: 'converting' stamp: 'mk 10/27/2003 17:44'! 163332asComplex 163333 "Answer a Complex number that represents value of the the receiver." 163334 163335 ^ Complex real: self imaginary: 0! ! 163336 163337!Integer methodsFor: 'converting' stamp: 'nice 6/11/2009 02:01'! 163338asFloat 163339 "Answer a Float that represents the value of the receiver. 163340 This is the nearest possible Float according to IEEE 754 round to nearest even mode. 163341 If the receiver is too large, then answer with Float infinity." 163342 163343 | mantissa shift sum numberOfTruncatedBits mask truncatedBits | 163344 self isZero 163345 ifTrue: [^ 0.0]. 163346 mantissa := self abs. 163347 163348 "Assume Float is a double precision IEEE 754 number with 53bits mantissa. 163349 We should better use some Float class message for that (Float precision)..." 163350 numberOfTruncatedBits := mantissa highBit - 53. 163351 numberOfTruncatedBits > 0 163352 ifTrue: [mask := (1 bitShift: numberOfTruncatedBits) - 1. 163353 truncatedBits := mantissa bitAnd: mask. 163354 mantissa := mantissa bitShift: numberOfTruncatedBits negated. 163355 "inexact := truncatedBits isZero not." 163356 truncatedBits highBit = numberOfTruncatedBits 163357 ifTrue: ["There is a carry, whe must eventually round upper" 163358 (mantissa even and: [truncatedBits isPowerOfTwo]) 163359 ifFalse: ["Either the mantissa is odd, and we must round upper to the nearest even 163360 Or the truncated part is not a power of two, so has more than 1 bit, so is > 0.5ulp: we must round upper" 163361 mantissa := mantissa + 1]]] 163362 ifFalse: [numberOfTruncatedBits := 0]. 163363 163364 "now, mantissa has no more than 53 bits, we can do exact floating point arithmetic" 163365 sum := 0.0. 163366 shift := numberOfTruncatedBits. 163367 1 to: mantissa digitLength do: 163368 [:byteIndex | 163369 sum := ((mantissa digitAt: byteIndex) asFloat timesTwoPower: shift) + sum. 163370 shift := shift + 8]. 163371 ^ self positive 163372 ifTrue: [sum] 163373 ifFalse: [sum negated] 163374 163375 163376 "Implementation notes: 163377 The receiver is split in three parts: 163378 - a sign 163379 - a truncated mantissa made of first 53 bits which is the maximum precision of Float 163380 - trailing truncatedBits 163381 This is like placing a floating point after numberOfTruncatedBits from the right: 163382 self = (self sign*(mantissa + fractionPart)*(1 bitShift: numberOfTruncatedBits)). 163383 where 0 <= fractionPart < 1, 163384 fractionPart = (truncatedBits/(1 bitShift: numberOfTruncatedBits)). 163385 Note that the converson is inexact if fractionPart > 0. 163386 163387 If fractionPart > 0.5 (2r0.1), then the mantissa must be rounded upward. 163388 If fractionPart = 0.5, then it is case of exact difference between two consecutive integers. 163389 In this later case, we always round to nearest even. That is round upward if mantissa is odd. 163390 163391 The two cases imply first bit after floating point is 1: truncatedBits highBit = numberOfTruncatedBits 163392 Possible variants: (self abs bitAt: numberOfTruncatedBits) = 1 163393 In the former case, there must be another truncated bit set to 1: truncatedBits isPowerOfTwo not. 163394 Possible variants: (self abs lowBit < numberOfTruncatedBits) 163395 The later case is recognized as: mantissa odd. 163396 163397 examples (I omit first 52 bits of mantissa for clarity) 163398 2r0.00001 is rounded to 2r0 163399 2r1.00001 is rounded to 2r1 163400 2r0.1 is rounded to 2r0 (nearest even) 163401 2r1.1 is rounded to 2r10 (nearest even) 163402 2r0.10001 is rounded to 2r1 163403 2r1.10001 is rounded to 2r10"! ! 163404 163405!Integer methodsFor: 'converting'! 163406asFraction 163407 "Answer a Fraction that represents value of the the receiver." 163408 163409 ^Fraction numerator: self denominator: 1! ! 163410 163411!Integer methodsFor: 'converting' stamp: 'ls 5/26/1998 20:53'! 163412asHexDigit 163413 ^'0123456789ABCDEF' at: self+1! ! 163414 163415!Integer methodsFor: 'converting'! 163416asInteger 163417 "Answer with the receiver itself." 163418 163419 ^self 163420 163421! ! 163422 163423!Integer methodsFor: 'converting' stamp: 'brp 5/13/2003 10:12'! 163424asYear 163425 163426 ^ Year year: self ! ! 163427 163428!Integer methodsFor: 'converting' stamp: 'stephane.ducasse 5/25/2008 15:44'! 163429hex 163430 ^ self printStringBase: 16! ! 163431 163432 163433!Integer methodsFor: 'enumerating'! 163434timesRepeat: aBlock 163435 "Evaluate the argument, aBlock, the number of times represented by the 163436 receiver." 163437 163438 | count | 163439 count := 1. 163440 [count <= self] 163441 whileTrue: 163442 [aBlock value. 163443 count := count + 1]! ! 163444 163445 163446!Integer methodsFor: 'explorer' stamp: 'laza 3/17/2005 13:37'! 163447explorerContents 163448 ^{ 163449 'hexadecimal' -> 16. 163450 'octal' -> 8. 163451 'binary' -> 2 163452 } collect: [:each | 163453 ObjectExplorerWrapper with: each key translated name: (self printStringBase: each value) model: self]! ! 163454 163455!Integer methodsFor: 'explorer' stamp: 'laza 3/17/2005 13:38'! 163456hasContentsInExplorer 163457 ^true! ! 163458 163459 163460!Integer methodsFor: 'mathematical functions' stamp: 'di 4/22/1998 14:45'! 163461factorial 163462 "Answer the factorial of the receiver." 163463 163464 self = 0 ifTrue: [^ 1]. 163465 self > 0 ifTrue: [^ self * (self - 1) factorial]. 163466 self error: 'Not valid for negative integers'! ! 163467 163468!Integer methodsFor: 'mathematical functions' stamp: 'LC 6/17/1998 19:22'! 163469gcd: anInteger 163470 "See Knuth, Vol 2, 4.5.2, Algorithm L" 163471 "Initialize" 163472 | higher u v k uHat vHat a b c d vPrime vPrimePrime q t | 163473 higher := SmallInteger maxVal highBit. 163474 u := self abs max: (v := anInteger abs). 163475 v := self abs min: v. 163476 [v class == SmallInteger] 163477 whileFalse: 163478 [(uHat := u bitShift: (k := higher - u highBit)) class == SmallInteger 163479 ifFalse: 163480 [k := k - 1. 163481 uHat := uHat bitShift: -1]. 163482 vHat := v bitShift: k. 163483 a := 1. 163484 b := 0. 163485 c := 0. 163486 d := 1. 163487 "Test quotient" 163488 [(vPrime := vHat + d) ~= 0 163489 and: [(vPrimePrime := vHat + c) ~= 0 and: [(q := uHat + a // vPrimePrime) = (uHat + b // vPrime)]]] 163490 whileTrue: 163491 ["Emulate Euclid" 163492 c := a - (q * (a := c)). 163493 d := b - (q * (b := d)). 163494 vHat := uHat - (q * (uHat := vHat))]. 163495 "Multiprecision step" 163496 b = 0 163497 ifTrue: 163498 [v := u rem: (u := v)] 163499 ifFalse: 163500 [t := u * a + (v * b). 163501 v := u * c + (v * d). 163502 u := t]]. 163503 ^ v gcd: u! ! 163504 163505!Integer methodsFor: 'mathematical functions'! 163506lcm: n 163507 "Answer the least common multiple of the receiver and n." 163508 163509 ^self // (self gcd: n) * n! ! 163510 163511!Integer methodsFor: 'mathematical functions' stamp: 'es 5/25/2005 11:04'! 163512raisedToInteger: exp modulo: m 163513 (exp = 0) ifTrue: [^ 1]. 163514 exp even 163515 ifTrue: [^ (self raisedToInteger: (exp // 2) modulo: m) squared \\ m] 163516 ifFalse: [^ (self * (self raisedToInteger: (exp - 1) modulo: m)) \\ m].! ! 163517 163518!Integer methodsFor: 'mathematical functions' stamp: 'adrian-lienhard 5/18/2009 21:03'! 163519raisedTo: y modulo: n 163520 "Answer the modular exponential. Code by Jesse Welton." 163521 | s t u | 163522 s := 1. 163523 t := self. 163524 u := y. 163525 [u = 0] whileFalse: [ 163526 u odd ifTrue: [ 163527 s := s * t. 163528 s >= n ifTrue: [s := s \\\ n]]. 163529 t := t * t. 163530 t >= n ifTrue: [t := t \\\ n]. 163531 u := u bitShift: -1]. 163532 ^ s. 163533! ! 163534 163535!Integer methodsFor: 'mathematical functions' stamp: 'tk 7/30/97 13:08'! 163536take: kk 163537 "Return the number of combinations of (self) elements taken kk at a time. For 6 take 3, this is 6*5*4 / (1*2*3). Zero outside of Pascal's triangle. Use a trick to go faster." 163538 " 6 take: 3 " 163539 163540 | num denom | 163541 kk < 0 ifTrue: [^ 0]. 163542 kk > self ifTrue: [^ 0]. 163543 num := 1. 163544 self to: (kk max: self-kk) + 1 by: -1 do: [:factor | num := num * factor]. 163545 denom := 1. 163546 1 to: (kk min: self-kk) do: [:factor | denom := denom * factor]. 163547 ^ num // denom! ! 163548 163549 163550!Integer methodsFor: 'printing' stamp: 'sw 11/24/1998 14:53'! 163551asStringWithCommas 163552 "123456789 asStringWithCommas" 163553 "-123456789 asStringWithCommas" 163554 | digits | 163555 digits := self abs printString. 163556 ^ String streamContents: 163557 [:strm | 163558 self sign = -1 ifTrue: [strm nextPut: $-]. 163559 1 to: digits size do: 163560 [:i | strm nextPut: (digits at: i). 163561 (i < digits size and: [(i - digits size) \\ 3 = 0]) 163562 ifTrue: [strm nextPut: $,]]]! ! 163563 163564!Integer methodsFor: 'printing' stamp: 'ar 7/18/2001 22:09'! 163565asStringWithCommasSigned 163566 "123456789 asStringWithCommasSigned" 163567 "-123456789 asStringWithCommasSigned" 163568 | digits | 163569 digits := self abs printString. 163570 ^ String streamContents: 163571 [:strm | 163572 self sign = -1 ifTrue: [strm nextPut: $-] ifFalse:[strm nextPut: $+]. 163573 1 to: digits size do: 163574 [:i | strm nextPut: (digits at: i). 163575 (i < digits size and: [(i - digits size) \\ 3 = 0]) 163576 ifTrue: [strm nextPut: $,]]]! ! 163577 163578!Integer methodsFor: 'printing' stamp: 'sw 11/13/1999 23:00'! 163579asTwoCharacterString 163580 "Answer a two-character string representing the receiver, with leading zero if required. Intended for use with integers in the range 0 to 99, but plausible replies given for other values too" 163581 163582 ^ (self >= 0 and: [self < 10]) 163583 ifTrue: ['0', self printString] 163584 ifFalse: [self printString copyFrom: 1 to: 2] 163585 163586 163587" 1635882 asTwoCharacterString 16358911 asTwoCharacterString 1635901943 asTwoCharacterString 1635910 asTwoCharacterString 163592-2 asTwoCharacterString 163593-234 asTwoCharacterString 163594"! ! 163595 163596!Integer methodsFor: 'printing' stamp: 'tk 4/1/2002 11:30'! 163597asWords 163598 "SmallInteger maxVal asWords" 163599 | mils minus three num answer milCount | 163600 self = 0 ifTrue: [^'zero']. 163601 mils := #('' ' thousand' ' million' ' billion' ' trillion' ' quadrillion' ' quintillion' ' sextillion' ' septillion' ' octillion' ' nonillion' ' decillion' ' undecillion' ' duodecillion' ' tredecillion' ' quattuordecillion' ' quindecillion' ' sexdecillion' ' septendecillion' ' octodecillion' ' novemdecillion' ' vigintillion'). 163602 num := self. 163603 minus := ''. 163604 self < 0 ifTrue: [ 163605 minus := 'negative '. 163606 num := num negated. 163607 ]. 163608 answer := String new. 163609 milCount := 1. 163610 [num > 0] whileTrue: [ 163611 three := (num \\ 1000) threeDigitName. 163612 num := num // 1000. 163613 three isEmpty ifFalse: [ 163614 answer isEmpty ifFalse: [ 163615 answer := ', ',answer 163616 ]. 163617 answer := three,(mils at: milCount),answer. 163618 ]. 163619 milCount := milCount + 1. 163620 ]. 163621 ^minus,answer! ! 163622 163623!Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:14'! 163624destinationBuffer:digitLength 163625 digitLength <= 1 163626 ifTrue: [self] 163627 ifFalse: [LargePositiveInteger new: digitLength].! ! 163628 163629!Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:16'! 163630digitBuffer:digitLength 163631 ^Array new:digitLength*8.! ! 163632 163633!Integer methodsFor: 'printing'! 163634isLiteral 163635 163636 ^true! ! 163637 163638!Integer methodsFor: 'printing' stamp: 'stephane.ducasse 4/13/2009 14:15'! 163639numberOfDigits 163640 "Return how many digits are necessary to print this number in base 10. 163641 This does not count any place for minus sign, radix prefix or whatever." 163642 163643 ^ self numberOfDigitsInBase: 10 163644! ! 163645 163646!Integer methodsFor: 'printing' stamp: 'nice 2/15/2008 22:14'! 163647numberOfDigitsInBase: b 163648 "Return how many digits are necessary to print this number in base b. 163649 This does not count any place for minus sign, radix prefix or whatever. 163650 Note that this algorithm may cost a few operations on LargeInteger." 163651 163652 | nDigits q | 163653 self negative ifTrue: [^self negated numberOfDigitsInBase: b]. 163654 self < b ifTrue: [^1]. 163655 b isPowerOfTwo ifTrue: [^self highBit + b highBit - 2 quo: b highBit - 1]. 163656 163657 "A conversion from base 2 to base b has to be performed. 163658 This algorithm avoids Float computations like (self log: b) floor + 1, 163659 1) because they are inexact 163660 2) because LargeInteger might overflow 163661 3) because this algorithm might be cheaper than conversion" 163662 163663 "Make an initial nDigits guess that is lower than or equal to required number of digits" 163664 b = 10 163665 ifTrue: [nDigits := ((self highBit - 1) * 3 quo: 10) + 1. "This is because 1024 is a little more than a kilo"] 163666 ifFalse: [nDigits := self highBit quo: b highBit]. 163667 163668 "See how many digits remains above these first nDigits guess" 163669 q := self quo: (b raisedTo: nDigits). 163670 ^q = 0 163671 ifTrue: [nDigits] 163672 ifFalse: [nDigits + (q numberOfDigitsInBase: b)]! ! 163673 163674!Integer methodsFor: 'printing' stamp: 'nice 2/15/2008 21:49'! 163675printOn: aStream 163676 ^self printOn: aStream base: 10! ! 163677 163678!Integer methodsFor: 'printing' stamp: 'fbs 2/9/2006 08:57'! 163679printOn: outputStream base: baseInteger showRadix: flagBoolean 163680 "Write a sequence of characters that describes the receiver in radix 163681 baseInteger with optional radix specifier. 163682 The result is undefined if baseInteger less than 2 or greater than 36." 163683 | tempString startPos | 163684 #Numeric. 163685 "2000/03/04 Harmon R. Added ANSI <integer> protocol" 163686 163687 tempString := self printStringRadix: baseInteger. 163688 flagBoolean ifTrue: [^ outputStream nextPutAll: tempString]. 163689 startPos := (tempString indexOf: $r ifAbsent: [self error: 'radix indicator not found.']) 163690 + 1. 163691 self negative ifTrue: [outputStream nextPut: $-]. 163692 outputStream nextPutAll: (tempString copyFrom: startPos to: tempString size)! ! 163693 163694!Integer methodsFor: 'printing' stamp: 'RAH 4/25/2000 19:49'! 163695printPaddedWith: aCharacter to: anInteger 163696 "Answer the string containing the ASCII representation of the receiver 163697 padded on the left with aCharacter to be at least anInteger characters." 163698 #Numeric. 163699 "2000/03/04 Harmon R. Added Date and Time support" 163700 ^ self 163701 printPaddedWith: aCharacter 163702 to: anInteger 163703 base: 10! ! 163704 163705!Integer methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 10:01'! 163706printPaddedWith: aCharacter to: anInteger base: aRadix 163707 "Answer the string containing the ASCII representation of the receiver 163708 padded on the left with aCharacter to be at least anInteger characters." 163709 | aStream padding digits | 163710 #Numeric. 163711 "2000/03/04 Harmon R. Added Date and Time support" 163712 aStream := (String new: 10) writeStream. 163713 self 163714 printOn: aStream 163715 base: aRadix 163716 showRadix: false. 163717 digits := aStream contents. 163718 padding := anInteger - digits size. 163719 padding > 0 ifFalse: [^ digits]. 163720 ^ ((String new: padding) atAllPut: aCharacter; 163721 yourself) , digits! ! 163722 163723!Integer methodsFor: 'printing' stamp: 'nice 2/15/2008 21:49'! 163724printString 163725 "For Integer, prefer the stream version to the string version for efficiency" 163726 163727 ^String streamContents: [:str | self printOn: str base: 10]! ! 163728 163729!Integer methodsFor: 'printing' stamp: 'md 7/30/2005 21:00'! 163730printStringRadix: baseInteger 163731 "Return a string containing a sequence of characters that represents the 163732 numeric value of the receiver in the radix specified by the argument. 163733 If the receiver is negative, a minus sign ('-') is prepended to the 163734 sequence of characters. 163735 The result is undefined if baseInteger less than 2 or greater than 36." 163736 | tempString | 163737 #Numeric. 163738 "2000/03/04 Harmon R. Added ANSI <integer> protocol" 163739 baseInteger = 10 163740 ifTrue: 163741 [tempString := self storeStringBase: baseInteger. 163742 self negative 163743 ifTrue: [^ '-10r' , (tempString copyFrom: 2 to: tempString size)] 163744 ifFalse: [^ '10r' , tempString]]. 163745 ^ self storeStringBase: baseInteger! ! 163746 163747 163748!Integer methodsFor: 'printing-numerative' stamp: 'laza 1/30/2005 13:53'! 163749byteEncode: aStream base: base 163750 ^self printOn: aStream base: base ! ! 163751 163752!Integer methodsFor: 'printing-numerative' stamp: 'nice 2/15/2008 21:52'! 163753printOn: aStream base: base 163754 ^self subclassResponsibility! ! 163755 163756!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:13'! 163757printOn: aStream base: base length: minimum padded: zeroFlag 163758 | prefix | 163759 prefix := self negative ifTrue: ['-'] ifFalse: [String new]. 163760 self print: (self abs printStringBase: base) on: aStream prefix: prefix length: minimum padded: zeroFlag 163761! ! 163762 163763!Integer methodsFor: 'printing-numerative' stamp: 'nice 2/15/2008 21:44'! 163764printOn: aStream base: b nDigits: n 163765 "Append a representation of this number in base b on aStream using nDigits. 163766 self must be positive." 163767 163768 self subclassResponsibility! ! 163769 163770!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:14'! 163771printStringBase: base length: minimum padded: zeroFlag 163772 ^String streamContents: [:s| self printOn: s base: base length: minimum padded: zeroFlag]! ! 163773 163774!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 10:58'! 163775printStringHex 163776 ^self printStringBase: 16! ! 163777 163778!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:21'! 163779printStringLength: minimal 163780 ^self printStringLength: minimal padded: false 163781! ! 163782 163783!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:20'! 163784printStringLength: minimal padded: zeroFlag 163785 ^self printStringBase: 10 length: minimal padded: zeroFlag! ! 163786 163787!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:20'! 163788printStringPadded: minimal 163789 ^self printStringLength: minimal padded: true 163790! ! 163791 163792!Integer methodsFor: 'printing-numerative' stamp: 'PeterHugossonMiller 9/3/2009 10:01'! 163793printStringRoman 163794 | stream integer | 163795 stream := String new writeStream. 163796 integer := self negative ifTrue: [stream nextPut: $-. self negated] ifFalse: [self]. 163797 integer // 1000 timesRepeat: [stream nextPut: $M]. 163798 integer 163799 romanDigits: 'MDC' for: 100 on: stream; 163800 romanDigits: 'CLX' for: 10 on: stream; 163801 romanDigits: 'XVI' for: 1 on: stream. 163802 ^stream contents! ! 163803 163804!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 13:35'! 163805radix: base 163806 ^ self printStringBase: base! ! 163807 163808!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 13:36'! 163809storeOn: aStream base: base 163810 "Print a representation of the receiver on the stream 163811 <aStream> in base <base> where 163812 2 <= <baseInteger> <= 16. If <base> is other than 10 163813 it is written first separated by $r followed by the number 163814 like for example: 16rFCE2" 163815 163816 | integer | 163817 integer := self negative 163818 ifTrue: [aStream nextPut: $-. self negated] 163819 ifFalse: [self]. 163820 base = 10 ifFalse: [aStream nextPutAll: base printString; nextPut: $r]. 163821 aStream nextPutAll: (integer printStringBase: base). 163822! ! 163823 163824!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:16'! 163825storeOn: aStream base: base length: minimum padded: zeroFlag 163826 | prefix | 163827 prefix := self negative ifTrue: ['-'] ifFalse: [String new]. 163828 base = 10 ifFalse: [prefix := prefix, base printString, 'r']. 163829 self print: (self abs printStringBase: base) on: aStream prefix: prefix length: minimum padded: zeroFlag 163830! ! 163831 163832!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:16'! 163833storeStringBase: base length: minimum padded: zeroFlag 163834 ^String streamContents: [:s| self storeOn: s base: base length: minimum padded: zeroFlag]! ! 163835 163836!Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 10:58'! 163837storeStringHex 163838 ^self storeStringBase: 16! ! 163839 163840 163841!Integer methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:26'! 163842lastDigit 163843 "Answer the last digit of the integer base 256. LargePositiveInteger uses bytes of base two number, and each is a 'digit'." 163844 163845 ^self digitAt: self digitLength! ! 163846 163847!Integer methodsFor: 'system primitives'! 163848replaceFrom: start to: stop with: replacement startingAt: repStart 163849 | j | "Catches failure if LgInt replace primitive fails" 163850 j := repStart. 163851 start to: stop do: 163852 [:i | 163853 self digitAt: i put: (replacement digitAt: j). 163854 j := j+1]! ! 163855 163856 163857!Integer methodsFor: 'testing'! 163858even 163859 "Refer to the comment in Number|even." 163860 163861 ^((self digitAt: 1) bitAnd: 1) = 0! ! 163862 163863!Integer methodsFor: 'testing'! 163864isInteger 163865 "True for all subclasses of Integer." 163866 163867 ^ true! ! 163868 163869!Integer methodsFor: 'testing' stamp: 'ar 6/9/2000 18:56'! 163870isPowerOfTwo 163871 "Return true if the receiver is an integral power of two." 163872 ^ (self bitAnd: self-1) = 0! ! 163873 163874!Integer methodsFor: 'testing' stamp: 'md 2/12/2006 14:37'! 163875isPrime 163876 "See isProbablyPrimeWithK:andQ: for the algoritm description." 163877 | k q | 163878 self <= 1 ifTrue: [^self error: 'operation undefined']. 163879 self even ifTrue: [^self = 2]. 163880 k := 1. 163881 163882 q := self - 1 bitShift: -1. 163883 [q odd] whileFalse: 163884 [q := q bitShift: -1. 163885 k := k + 1]. 163886 163887 25 timesRepeat: [(self isProbablyPrimeWithK: k andQ: q) ifFalse: [^false]]. 163888 ^true! ! 163889 163890 163891!Integer methodsFor: 'tiles' stamp: 'RAA 8/24/1999 15:32'! 163892asPrecedenceName 163893 163894 ^#('unary' 'binary' 'keyword') at: self 163895! ! 163896 163897 163898!Integer methodsFor: 'truncation and round off' stamp: 'ar 6/9/2000 19:16'! 163899asLargerPowerOfTwo 163900 "Convert the receiver into a power of two which is not less than the receiver" 163901 self isPowerOfTwo 163902 ifTrue:[^self] 163903 ifFalse:[^1 bitShift: (self highBit)]! ! 163904 163905!Integer methodsFor: 'truncation and round off' stamp: 'ar 6/9/2000 18:56'! 163906asPowerOfTwo 163907 "Convert the receiver into a power of two" 163908 ^self asSmallerPowerOfTwo! ! 163909 163910!Integer methodsFor: 'truncation and round off' stamp: 'ar 6/9/2000 19:16'! 163911asSmallerPowerOfTwo 163912 "Convert the receiver into a power of two which is not larger than the receiver" 163913 self isPowerOfTwo 163914 ifTrue:[^self] 163915 ifFalse:[^1 bitShift: (self highBit - 1)]! ! 163916 163917!Integer methodsFor: 'truncation and round off' stamp: 'lr 11/4/2003 12:14'! 163918atRandom 163919 "Answer a random integer from 1 to self. This implementation uses a 163920 shared generator. Heavy users should their own implementation or use 163921 Interval>atRandom: directly." 163922 163923 self = 0 ifTrue: [ ^0 ]. 163924 self < 0 ifTrue: [ ^self negated atRandom negated ]. 163925 ^Collection mutexForPicking critical: [ 163926 self atRandom: Collection randomForPicking ]! ! 163927 163928!Integer methodsFor: 'truncation and round off' stamp: 'sma 5/12/2000 12:35'! 163929atRandom: aGenerator 163930 "Answer a random integer from 1 to self picked from aGenerator." 163931 163932 ^ aGenerator nextInt: self! ! 163933 163934!Integer methodsFor: 'truncation and round off'! 163935ceiling 163936 "Refer to the comment in Number|ceiling."! ! 163937 163938!Integer methodsFor: 'truncation and round off'! 163939floor 163940 "Refer to the comment in Number|floor."! ! 163941 163942!Integer methodsFor: 'truncation and round off'! 163943normalize 163944 "SmallInts OK; LgInts override" 163945 ^ self! ! 163946 163947!Integer methodsFor: 'truncation and round off'! 163948rounded 163949 "Refer to the comment in Number|rounded."! ! 163950 163951!Integer methodsFor: 'truncation and round off'! 163952truncated 163953 "Refer to the comment in Number|truncated."! ! 163954 163955 163956!Integer methodsFor: 'private'! 163957copyto: x 163958 | stop | 163959 stop := self digitLength min: x digitLength. 163960 ^ x replaceFrom: 1 to: stop with: self startingAt: 1! ! 163961 163962!Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:41'! 163963digitAdd: arg 163964 | len arglen accum sum | 163965 <primitive: 'primDigitAdd' module:'LargeIntegers'> 163966 accum := 0. 163967 (len := self digitLength) < (arglen := arg digitLength) ifTrue: [len := arglen]. 163968 "Open code max: for speed" 163969 sum := Integer new: len neg: self negative. 163970 1 to: len do: 163971 [:i | 163972 accum := (accum bitShift: -8) 163973 + (self digitAt: i) + (arg digitAt: i). 163974 sum digitAt: i put: (accum bitAnd: 255)]. 163975 accum > 255 163976 ifTrue: 163977 [sum := sum growby: 1. 163978 sum at: sum digitLength put: (accum bitShift: -8)]. 163979 ^ sum! ! 163980 163981!Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:43'! 163982digitCompare: arg 163983 "Compare the magnitude of self with that of arg. 163984 Return a code of 1, 0, -1 for self >, = , < arg" 163985 | len arglen argDigit selfDigit | 163986 <primitive: 'primDigitCompare' module:'LargeIntegers'> 163987 len := self digitLength. 163988 (arglen := arg digitLength) ~= len 163989 ifTrue: [arglen > len 163990 ifTrue: [^ -1] 163991 ifFalse: [^ 1]]. 163992 [len > 0] 163993 whileTrue: 163994 [(argDigit := arg digitAt: len) ~= (selfDigit := self digitAt: len) 163995 ifTrue: [argDigit < selfDigit 163996 ifTrue: [^ 1] 163997 ifFalse: [^ -1]]. 163998 len := len - 1]. 163999 ^ 0! ! 164000 164001!Integer methodsFor: 'private' stamp: 'sr 6/8/2000 01:28'! 164002digitDiv: arg neg: ng 164003 "Answer with an array of (quotient, remainder)." 164004 | quo rem ql d div dh dnh dl qhi qlo j l hi lo r3 a t | 164005 <primitive: 'primDigitDivNegative' module:'LargeIntegers'> 164006 arg = 0 ifTrue: [^ (ZeroDivide dividend: self) signal]. 164007 "TFEI added this line" 164008 l := self digitLength - arg digitLength + 1. 164009 l <= 0 ifTrue: [^ Array with: 0 with: self]. 164010 "shortcut against #highBit" 164011 d := 8 - arg lastDigit highBitOfPositiveReceiver. 164012 div := arg digitLshift: d. 164013 div := div growto: div digitLength + 1. 164014 "shifts so high order word is >=128" 164015 rem := self digitLshift: d. 164016 rem digitLength = self digitLength ifTrue: [rem := rem growto: self digitLength + 1]. 164017 "makes a copy and shifts" 164018 quo := Integer new: l neg: ng. 164019 dl := div digitLength - 1. 164020 "Last actual byte of data" 164021 ql := l. 164022 dh := div digitAt: dl. 164023 dnh := dl = 1 164024 ifTrue: [0] 164025 ifFalse: [div digitAt: dl - 1]. 164026 1 to: ql do: 164027 [:k | 164028 "maintain quo*arg+rem=self" 164029 "Estimate rem/div by dividing the leading to bytes of rem by dh." 164030 "The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles." 164031 j := rem digitLength + 1 - k. 164032 "r1 := rem digitAt: j." 164033 (rem digitAt: j) 164034 = dh 164035 ifTrue: [qhi := qlo := 15 164036 "i.e. q=255"] 164037 ifFalse: 164038 ["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh. 164039 Note that r1,r2 are bytes, not nibbles. 164040 Be careful not to generate intermediate results exceeding 13 164041 bits." 164042 "r2 := (rem digitAt: j - 1)." 164043 t := ((rem digitAt: j) 164044 bitShift: 4) 164045 + ((rem digitAt: j - 1) 164046 bitShift: -4). 164047 qhi := t // dh. 164048 t := (t \\ dh bitShift: 4) 164049 + ((rem digitAt: j - 1) 164050 bitAnd: 15). 164051 qlo := t // dh. 164052 t := t \\ dh. 164053 "Next compute (hi,lo) := q*dnh" 164054 hi := qhi * dnh. 164055 lo := qlo * dnh + ((hi bitAnd: 15) 164056 bitShift: 4). 164057 hi := (hi bitShift: -4) 164058 + (lo bitShift: -8). 164059 lo := lo bitAnd: 255. 164060 "Correct overestimate of q. 164061 Max of 2 iterations through loop -- see Knuth vol. 2" 164062 r3 := j < 3 164063 ifTrue: [0] 164064 ifFalse: [rem digitAt: j - 2]. 164065 [(t < hi 164066 or: [t = hi and: [r3 < lo]]) 164067 and: 164068 ["i.e. (t,r3) < (hi,lo)" 164069 qlo := qlo - 1. 164070 lo := lo - dnh. 164071 lo < 0 164072 ifTrue: 164073 [hi := hi - 1. 164074 lo := lo + 256]. 164075 hi >= dh]] 164076 whileTrue: [hi := hi - dh]. 164077 qlo < 0 164078 ifTrue: 164079 [qhi := qhi - 1. 164080 qlo := qlo + 16]]. 164081 "Subtract q*div from rem" 164082 l := j - dl. 164083 a := 0. 164084 1 to: div digitLength do: 164085 [:i | 164086 hi := (div digitAt: i) 164087 * qhi. 164088 lo := a + (rem digitAt: l) - ((hi bitAnd: 15) 164089 bitShift: 4) - ((div digitAt: i) 164090 * qlo). 164091 rem digitAt: l put: lo - (lo // 256 * 256). 164092 "sign-tolerant form of (lo bitAnd: 255)" 164093 a := lo // 256 - (hi bitShift: -4). 164094 l := l + 1]. 164095 a < 0 164096 ifTrue: 164097 ["Add div back into rem, decrease q by 1" 164098 qlo := qlo - 1. 164099 l := j - dl. 164100 a := 0. 164101 1 to: div digitLength do: 164102 [:i | 164103 a := (a bitShift: -8) 164104 + (rem digitAt: l) + (div digitAt: i). 164105 rem digitAt: l put: (a bitAnd: 255). 164106 l := l + 1]]. 164107 quo digitAt: quo digitLength + 1 - k put: (qhi bitShift: 4) 164108 + qlo]. 164109 rem := rem 164110 digitRshift: d 164111 bytes: 0 164112 lookfirst: dl. 164113 ^ Array with: quo with: rem! ! 164114 164115!Integer methodsFor: 'private' stamp: 'nice 1/26/2008 02:12'! 164116digitLogic: arg op: op length: len 164117 | i result neg1 neg2 rneg z1 z2 rz b1 b2 b | 164118 neg1 := self negative. 164119 neg2 := arg negative. 164120 rneg := ((neg1 164121 ifTrue: [-1] 164122 ifFalse: [0]) 164123 perform: op 164124 with: (neg2 164125 ifTrue: [-1] 164126 ifFalse: [0])) 164127 < 0. 164128 result := Integer new: len neg: rneg. 164129 rz := z1 := z2 := true. 164130 i := 0. 164131 [(i := i + 1) <= len 164132 or: ["mind a carry on result that might go past len digits" 164133 rneg and: [rz 164134 and: [result := result growby: 1. 164135 true]]]] 164136 whileTrue: [b1 := self digitAt: i. 164137 neg1 164138 ifTrue: [b1 := z1 164139 ifTrue: [b1 = 0 164140 ifTrue: [0] 164141 ifFalse: [z1 := false. 164142 256 - b1]] 164143 ifFalse: [255 - b1]]. 164144 b2 := arg digitAt: i. 164145 neg2 164146 ifTrue: [b2 := z2 164147 ifTrue: [b2 = 0 164148 ifTrue: [0] 164149 ifFalse: [z2 := false. 164150 256 - b2]] 164151 ifFalse: [255 - b2]]. 164152 b := b1 perform: op with: b2. 164153 result 164154 digitAt: i 164155 put: (rneg 164156 ifTrue: [rz 164157 ifTrue: [b = 0 164158 ifTrue: [0] 164159 ifFalse: [rz := false. 164160 256 - b]] 164161 ifFalse: [255 - b]] 164162 ifFalse: [b])]. 164163 ^ result normalize! ! 164164 164165!Integer methodsFor: 'private' stamp: 'sr 6/8/2000 01:30'! 164166digitLshift: shiftCount 164167 | carry rShift mask len result digit byteShift bitShift highBit | 164168 (highBit := self highBitOfMagnitude) = 0 ifTrue: [^ 0]. 164169 len := highBit + shiftCount + 7 // 8. 164170 result := Integer new: len neg: self negative. 164171 byteShift := shiftCount // 8. 164172 bitShift := shiftCount \\ 8. 164173 bitShift = 0 ifTrue: ["Fast version for byte-aligned shifts" 164174 ^ result 164175 replaceFrom: byteShift + 1 164176 to: len 164177 with: self 164178 startingAt: 1]. 164179 carry := 0. 164180 rShift := bitShift - 8. 164181 mask := 255 bitShift: 0 - bitShift. 164182 1 to: byteShift do: [:i | result digitAt: i put: 0]. 164183 1 to: len - byteShift do: 164184 [:i | 164185 digit := self digitAt: i. 164186 result digitAt: i + byteShift put: (((digit bitAnd: mask) 164187 bitShift: bitShift) 164188 bitOr: carry). 164189 carry := digit bitShift: rShift]. 164190 ^ result! ! 164191 164192!Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:46'! 164193digitMultiply: arg neg: ng 164194 | prod prodLen carry digit k ab | 164195 <primitive: 'primDigitMultiplyNegative' module:'LargeIntegers'> 164196 (arg digitLength = 1 and: [(arg digitAt: 1) 164197 = 0]) 164198 ifTrue: [^ 0]. 164199 (self digitLength = 1 and: [(self digitAt: 1) 164200 = 0]) 164201 ifTrue: [^ 0]. 164202 prodLen := self digitLength + arg digitLength. 164203 prod := Integer new: prodLen neg: ng. 164204 "prod starts out all zero" 164205 1 to: self digitLength do: [:i | (digit := self digitAt: i) ~= 0 164206 ifTrue: 164207 [k := i. 164208 carry := 0. 164209 "Loop invariant: 0<=carry<=0377, k=i+j-1" 164210 1 to: arg digitLength do: 164211 [:j | 164212 ab := (arg digitAt: j) 164213 * digit + carry + (prod digitAt: k). 164214 carry := ab bitShift: -8. 164215 prod digitAt: k put: (ab bitAnd: 255). 164216 k := k + 1]. 164217 prod digitAt: k put: carry]]. 164218 ^ prod normalize! ! 164219 164220!Integer methodsFor: 'private'! 164221digitRshift: anInteger bytes: b lookfirst: a 164222 "Shift right 8*b+anInteger bits, 0<=n<8. 164223 Discard all digits beyond a, and all zeroes at or below a." 164224 | n x r f m digit count i | 164225 n := 0 - anInteger. 164226 x := 0. 164227 f := n + 8. 164228 i := a. 164229 m := 255 bitShift: 0 - f. 164230 digit := self digitAt: i. 164231 [((digit bitShift: n) bitOr: x) = 0 and: [i ~= 1]] whileTrue: 164232 [x := digit bitShift: f "Can't exceed 8 bits". 164233 i := i - 1. 164234 digit := self digitAt: i]. 164235 i <= b ifTrue: [^Integer new: 0 neg: self negative]. "All bits lost" 164236 r := Integer new: i - b neg: self negative. 164237 count := i. 164238 x := (self digitAt: b + 1) bitShift: n. 164239 b + 1 to: count do: 164240 [:j | digit := self digitAt: j + 1. 164241 r digitAt: j - b put: (((digit bitAnd: m) bitShift: f) bitOr: x) 164242 "Avoid values > 8 bits". 164243 x := digit bitShift: n]. 164244 ^r! ! 164245 164246!Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:46'! 164247digitSubtract: arg 164248 | smaller larger z sum sl al ng | 164249 <primitive: 'primDigitSubtract' module:'LargeIntegers'> 164250 sl := self digitLength. 164251 al := arg digitLength. 164252 (sl = al 164253 ifTrue: 164254 [[(self digitAt: sl) 164255 = (arg digitAt: sl) and: [sl > 1]] 164256 whileTrue: [sl := sl - 1]. 164257 al := sl. 164258 (self digitAt: sl) 164259 < (arg digitAt: sl)] 164260 ifFalse: [sl < al]) 164261 ifTrue: 164262 [larger := arg. 164263 smaller := self. 164264 ng := self negative == false. 164265 sl := al] 164266 ifFalse: 164267 [larger := self. 164268 smaller := arg. 164269 ng := self negative]. 164270 sum := Integer new: sl neg: ng. 164271 z := 0. 164272 "Loop invariant is -1<=z<=1" 164273 1 to: sl do: 164274 [:i | 164275 z := z + (larger digitAt: i) - (smaller digitAt: i). 164276 sum digitAt: i put: z - (z // 256 * 256). 164277 "sign-tolerant form of (z bitAnd: 255)" 164278 z := z // 256]. 164279 ^ sum normalize! ! 164280 164281!Integer methodsFor: 'private'! 164282growby: n 164283 164284 ^self growto: self digitLength + n! ! 164285 164286!Integer methodsFor: 'private'! 164287growto: n 164288 164289 ^self copyto: (self species new: n)! ! 164290 164291!Integer methodsFor: 'private' stamp: 'es 5/31/2005 09:30'! 164292isProbablyPrimeWithK: k andQ: q 164293 "Algorithm P, probabilistic primality test, from 164294 Knuth, Donald E. 'The Art of Computer Programming', Vol 2, 164295 Third Edition, section 4.5.4, page 395, P1-P5 refer to Knuth description." 164296 164297 "P1" 164298 164299 | x j y | 164300 x := (self - 2) atRandom + 1. 164301 "P2" 164302 j := 0. 164303 y := x raisedToInteger: q modulo: self. 164304 "P3" 164305 164306 [(((j = 0) & (y = 1)) | (y = (self - 1))) ifTrue: [^true]. 164307 ((j > 0) & (y = 1)) ifTrue: [^false]. "P5" 164308 true] 164309 whileTrue: 164310 [j := j + 1. 164311 (j < k) ifTrue: [y := y squared \\ self] 164312 ifFalse:[^ false]]! ! 164313 164314!Integer methodsFor: 'private' stamp: 'laza 3/29/2004 18:16'! 164315print: positiveNumberString on: aStream prefix: prefix length: minimum padded: zeroFlag 164316 | padLength | 164317 padLength := minimum - positiveNumberString size - prefix size. 164318 padLength > 0 164319 ifTrue: [zeroFlag 164320 ifTrue: [aStream nextPutAll: prefix; nextPutAll: (String new: padLength withAll: $0)] 164321 ifFalse: [aStream nextPutAll: (String new: padLength withAll: Character space); nextPutAll: prefix]] 164322 ifFalse: [aStream nextPutAll: prefix]. 164323 aStream nextPutAll: positiveNumberString 164324 ! ! 164325 164326!Integer methodsFor: 'private' stamp: 'sma 5/20/2000 17:00'! 164327romanDigits: digits for: base on: aStream 164328 | n | 164329 n := self \\ (base * 10) // base. 164330 n = 9 ifTrue: [^ aStream nextPut: digits last; nextPut: digits first]. 164331 n = 4 ifTrue: [^ aStream nextPut: digits last; nextPut: digits second]. 164332 n > 4 ifTrue: [aStream nextPut: digits second]. 164333 n \\ 5 timesRepeat: [aStream nextPut: digits last]! ! 164334 164335"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 164336 164337Integer class 164338 instanceVariableNames: ''! 164339 164340!Integer class methodsFor: 'compatibility' stamp: 'laza 10/16/2004 14:34'! 164341readFrom: aStream radix: radix 164342 ^self readFrom: aStream base: radix! ! 164343 164344 164345!Integer class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 14:18'! 164346basicNew 164347 164348 self == Integer ifTrue: [ 164349 ^ self error: 'Integer is an abstract class. Make a concrete subclass.']. 164350 ^ super basicNew! ! 164351 164352!Integer class methodsFor: 'instance creation' stamp: 'bf 2/2/2004 00:23'! 164353byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4 164354 "Depending on high-order byte copy directly into a LargeInteger, 164355 or build up a SmallInteger by shifting" 164356 | value | 164357 byte4 < 16r40 ifTrue: 164358 [^ (byte4 bitShift: 24) 164359 + (byte3 bitShift: 16) 164360 + (byte2 bitShift: 8) 164361 + byte1]. 164362 value := LargePositiveInteger new: 4. 164363 value digitAt: 4 put: byte4. 164364 value digitAt: 3 put: byte3. 164365 value digitAt: 2 put: byte2. 164366 value digitAt: 1 put: byte1. 164367 ^ value! ! 164368 164369!Integer class methodsFor: 'instance creation' stamp: 'sw 5/8/2000 11:05'! 164370initializedInstance 164371 ^ 2468! ! 164372 164373!Integer class methodsFor: 'instance creation' stamp: 'tk 4/18/1999 22:01'! 164374new 164375 164376 self == Integer ifTrue: [ 164377 ^ self error: 'Integer is an abstract class. Make a concrete subclass.']. 164378 ^ super new! ! 164379 164380!Integer class methodsFor: 'instance creation'! 164381new: length neg: neg 164382 "Answer an instance of a large integer whose size is length. neg is a flag 164383 determining whether the integer is negative or not." 164384 164385 neg 164386 ifTrue: [^LargeNegativeInteger new: length] 164387 ifFalse: [^LargePositiveInteger new: length]! ! 164388 164389!Integer class methodsFor: 'instance creation' stamp: 'nice 3/15/2008 00:36'! 164390readFrom: aStringOrStream 164391 "Answer a new Integer as described on the stream, aStream. 164392 Embedded radix specifiers not allowed - use Number readFrom: for that." 164393 ^self readFrom: aStringOrStream base: 10! ! 164394 164395!Integer class methodsFor: 'instance creation' stamp: 'nice 6/11/2009 03:34'! 164396readFrom: aStringOrStream base: base 164397 "Answer an instance of one of the concrete subclasses if Integer. 164398 Initial minus sign accepted, and bases > 10 use letters A-Z. 164399 Imbedded radix specifiers not allowed; use Number 164400 class readFrom: for that. 164401 Raise an Error if there are no digits. 164402 If stringOrStream dos not start with a valid number description, answer 0 for backward compatibility. This is not clever and should better be changed." 164403 164404 ^(SqNumberParser on: aStringOrStream) failBlock: [^0]; nextIntegerBase: base! ! 164405 164406!Integer class methodsFor: 'instance creation' stamp: 'nice 3/15/2008 01:09'! 164407readFrom: aStringOrStream ifFail: aBlock 164408 "Answer an instance of one of the concrete subclasses if Integer. 164409 Initial minus sign accepted. 164410 Imbedded radix specifiers not allowed; use Number 164411 class readFrom: for that. 164412 Execute aBlock if there are no digits." 164413 164414 ^(SqNumberParser on: aStringOrStream) nextIntegerBase: 10 ifFail: aBlock! ! 164415 164416 164417!Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:34'! 164418largePrimesUpTo: maxValue 164419 "Compute and return all the prime numbers up to maxValue" 164420 ^Array streamContents:[:s| self largePrimesUpTo: maxValue do:[:prime| s nextPut: prime]]! ! 164421 164422!Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 02:38'! 164423largePrimesUpTo: max do: aBlock 164424 "Evaluate aBlock with all primes up to maxValue. 164425 The Algorithm is adapted from http://www.rsok.com/~jrm/printprimes.html 164426 It encodes prime numbers much more compactly than #primesUpTo: 164427 38.5 integer per byte (2310 numbers per 60 byte) allow for some fun large primes. 164428 (all primes up to SmallInteger maxVal can be computed within ~27MB of memory; 164429 the regular #primesUpTo: would require 4 *GIGA*bytes). 164430 Note: The algorithm could be re-written to produce the first primes (which require 164431 the longest time to sieve) faster but only at the cost of clarity." 164432 164433 | limit flags maskBitIndex bitIndex maskBit byteIndex index primesUpTo2310 indexLimit | 164434 limit := max asInteger - 1. 164435 indexLimit := max sqrt truncated + 1. 164436 "Create the array of flags." 164437 flags := ByteArray new: (limit + 2309) // 2310 * 60 + 60. 164438 flags atAllPut: 16rFF. "set all to true" 164439 164440 "Compute the primes up to 2310" 164441 primesUpTo2310 := self primesUpTo: 2310. 164442 164443 "Create a mapping from 2310 integers to 480 bits (60 byte)" 164444 maskBitIndex := Array new: 2310. 164445 bitIndex := -1. "for pre-increment" 164446 maskBitIndex at: 1 put: (bitIndex := bitIndex + 1). 164447 maskBitIndex at: 2 put: (bitIndex := bitIndex + 1). 164448 164449 1 to: 5 do:[:i| aBlock value: (primesUpTo2310 at: i)]. 164450 164451 index := 6. 164452 2 to: 2309 do:[:n| 164453 [(primesUpTo2310 at: index) < n] 164454 whileTrue:[index := index + 1]. 164455 n = (primesUpTo2310 at: index) ifTrue:[ 164456 maskBitIndex at: n+1 put: (bitIndex := bitIndex + 1). 164457 ] ifFalse:[ 164458 "if modulo any of the prime factors of 2310, then could not be prime" 164459 (n \\ 2 = 0 or:[n \\ 3 = 0 or:[n \\ 5 = 0 or:[n \\ 7 = 0 or:[n \\ 11 = 0]]]]) 164460 ifTrue:[maskBitIndex at: n+1 put: 0] 164461 ifFalse:[maskBitIndex at: n+1 put: (bitIndex := bitIndex + 1)]. 164462 ]. 164463 ]. 164464 164465 "Now the real work begins... 164466 Start with 13 since multiples of 2,3,5,7,11 are handled by the storage method; 164467 increment by 2 for odd numbers only." 164468 13 to: limit by: 2 do:[:n| 164469 (maskBit := maskBitIndex at: (n \\ 2310 + 1)) = 0 ifFalse:["not a multiple of 2,3,5,7,11" 164470 byteIndex := n // 2310 * 60 + (maskBit-1 bitShift: -3) + 1. 164471 bitIndex := 1 bitShift: (maskBit bitAnd: 7). 164472 ((flags at: byteIndex) bitAnd: bitIndex) = 0 ifFalse:["not marked -- n is prime" 164473 aBlock value: n. 164474 "Start with n*n since any integer < n has already been sieved 164475 (e.g., any multiple of n with a number k < n has been cleared 164476 when k was sieved); add 2 * i to avoid even numbers and 164477 mark all multiples of this prime. Note: n < indexLimit below 164478 limits running into LargeInts -- nothing more." 164479 n < indexLimit ifTrue:[ 164480 index := n * n. 164481 (index bitAnd: 1) = 0 ifTrue:[index := index + n]. 164482 [index <= limit] whileTrue:[ 164483 (maskBit := maskBitIndex at: (index \\ 2310 + 1)) = 0 ifFalse:[ 164484 byteIndex := (index // 2310 * 60) + (maskBit-1 bitShift: -3) + 1. 164485 maskBit := 255 - (1 bitShift: (maskBit bitAnd: 7)). 164486 flags at: byteIndex put: ((flags at: byteIndex) bitAnd: maskBit). 164487 ]. 164488 index := index + (2 * n)]. 164489 ]. 164490 ]. 164491 ]. 164492 ]. 164493! ! 164494 164495!Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:33'! 164496primesUpTo: max 164497 "Return a list of prime integers up to the given integer." 164498 "Integer primesUpTo: 100" 164499 ^Array streamContents:[:s| self primesUpTo: max do:[:prime| s nextPut: prime]]! ! 164500 164501!Integer class methodsFor: 'prime numbers' stamp: 'md 2/13/2006 14:38'! 164502primesUpTo: max do: aBlock 164503 "Compute aBlock with all prime integers up to the given integer." 164504 "Integer primesUpTo: 100" 164505 164506 | limit flags prime k | 164507 limit := max asInteger - 1. 164508 "Fall back into #largePrimesUpTo:do: if we'd require more than 100k of memory; 164509 the alternative will only requre 1/154th of the amount we need here and is almost as fast." 164510 limit > 25000 ifTrue:[^self largePrimesUpTo: max do: aBlock]. 164511 flags := (Array new: limit) atAllPut: true. 164512 1 to: limit - 1 do: [:i | 164513 (flags at: i) ifTrue: [ 164514 prime := i + 1. 164515 k := i + prime. 164516 [k <= limit] whileTrue: [ 164517 flags at: k put: false. 164518 k := k + prime]. 164519 aBlock value: prime]]. 164520! ! 164521 164522!Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:33'! 164523verbosePrimesUpTo: max 164524 "Integer verbosePrimesUpTo: SmallInteger maxVal" "<- heh, heh" 164525 "Compute primes up to max, but be verbose about it" 164526 ^Array streamContents:[:s| self verbosePrimesUpTo: max do:[:prime| s nextPut: prime]].! ! 164527 164528!Integer class methodsFor: 'prime numbers' stamp: 'sd 3/28/2008 11:03'! 164529verbosePrimesUpTo: max do: aBlock 164530 "Integer verbosePrimesUpTo: SmallInteger maxVal" 164531 "<- heh, heh" 164532 "Compute primes up to max, but be verbose about it" 164533 | lastTime nowTime | 164534 lastTime := Time millisecondClockValue. 164535 UIManager default informUserDuring: 164536 [ :bar | 164537 bar value: 'Computing primes...'. 164538 self 164539 primesUpTo: max 164540 do: 164541 [ :prime | 164542 aBlock value: prime. 164543 nowTime := Time millisecondClockValue. 164544 nowTime - lastTime > 1000 ifTrue: 164545 [ lastTime := nowTime. 164546 bar value: 'Last prime found: ' , prime printString ] ] ]! ! 164547ArrayedCollection variableWordSubclass: #IntegerArray 164548 instanceVariableNames: '' 164549 classVariableNames: '' 164550 poolDictionaries: '' 164551 category: 'Collections-Arrayed'! 164552!IntegerArray commentStamp: '<historical>' prior: 0! 164553IntegerArrays store 32bit signed Integer values. 164554Negative values are stored as 2's complement.! 164555 164556 164557!IntegerArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:40'! 164558at: index 164559 | word | 164560 <primitive: 165> 164561 word := self basicAt: index. 164562 word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" 164563 ^word >= 16r80000000 "Negative?!!" 164564 ifTrue:["word - 16r100000000" 164565 (word bitInvert32 + 1) negated] 164566 ifFalse:[word]! ! 164567 164568!IntegerArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:40'! 164569at: index put: anInteger 164570 | word | 164571 <primitive: 166> 164572 anInteger < 0 164573 ifTrue:["word := 16r100000000 + anInteger" 164574 word := (anInteger + 1) negated bitInvert32] 164575 ifFalse:[word := anInteger]. 164576 self basicAt: index put: word. 164577 ^anInteger! ! 164578 164579!IntegerArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 23:34'! 164580atAllPut: anInteger 164581 | word | 164582 anInteger < 0 164583 ifTrue:["word := 16r100000000 + anInteger" 164584 word := (anInteger + 1) negated bitInvert32] 164585 ifFalse:[word := anInteger]. 164586 self primFill: word.! ! 164587 164588!IntegerArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! 164589defaultElement 164590 "Return the default element of the receiver" 164591 ^0! ! 164592 164593 164594!IntegerArray methodsFor: 'converting' stamp: 'ar 10/10/1998 16:18'! 164595asIntegerArray 164596 ^self! ! 164597 164598 164599!IntegerArray methodsFor: 'private' stamp: 'ar 3/3/2001 23:34'! 164600primFill: aPositiveInteger 164601 "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays." 164602 164603 <primitive: 145> 164604 self errorImproperStore.! ! 164605TestCase subclass: #IntegerDigitLogicTest 164606 instanceVariableNames: '' 164607 classVariableNames: '' 164608 poolDictionaries: '' 164609 category: 'KernelTests-Numbers'! 164610 164611!IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:12'! 164612testAndSingleBitWithMinusOne 164613 "And a single bit with -1 and test for same value" 164614 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitAnd: -1) = (1 bitShift: i)].! ! 164615 164616!IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:13'! 164617testMixedSignDigitLogic 164618 "Verify that mixed sign logic with large integers works." 164619 self assert: (-2 bitAnd: 16rFFFFFFFF) = 16rFFFFFFFE! ! 164620 164621!IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:12'! 164622testNBitAndNNegatedEqualsN 164623 "Verify that (n bitAnd: n negated) = n for single bits" 164624 | n | 164625 1 to: 100 do: [:i | n := 1 bitShift: i. 164626 self assert: (n bitAnd: n negated) = n]! ! 164627 164628!IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:12'! 164629testNNegatedEqualsNComplementedPlusOne 164630 "Verify that n negated = (n complemented + 1) for single bits" 164631 | n | 164632 1 to: 100 do: [:i | n := 1 bitShift: i. 164633 self assert: n negated = ((n bitXor: -1) + 1)]! ! 164634 164635!IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:13'! 164636testShiftMinusOne1LeftThenRight 164637 "Shift -1 left then right and test for 1" 164638 1 to: 100 do: [:i | self assert: ((-1 bitShift: i) bitShift: i negated) = -1]. 164639! ! 164640 164641!IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:12'! 164642testShiftOneLeftThenRight 164643 "Shift 1 bit left then right and test for 1" 164644 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitShift: i negated) = 1]. 164645! ! 164646TestCase subclass: #IntegerTest 164647 instanceVariableNames: '' 164648 classVariableNames: '' 164649 poolDictionaries: '' 164650 category: 'KernelTests-Numbers'! 164651 164652!IntegerTest methodsFor: 'testing - arithmetic' stamp: 'mga 5/11/2006 15:41'! 164653testCrossSumBase 164654 "self run: #testCrossSumBase" 164655 164656 self assert: ( 164657 ((-20 to: 20) collect: [:each | each crossSumBase: 10]) asArray = 164658 #(2 10 9 8 7 6 5 4 3 2 1 9 8 7 6 5 4 3 2 1 0 1 2 3 4 5 6 7 8 9 1 2 3 4 5 6 7 8 9 10 2)). 164659 self assert: ( 164660 ((-20 to: 20) collect: [:each | each crossSumBase: 2]) asArray = 164661 #(2 3 2 2 1 4 3 3 2 3 2 2 1 3 2 2 1 2 1 1 0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4 1 2 2 3 2)). 164662 self should: [10 crossSumBase: 1] raise: AssertionFailure! ! 164663 164664 164665!IntegerTest methodsFor: 'tests - basic' stamp: 'sd 3/5/2004 14:50'! 164666testDegreeCos 164667 "self run: #testDegreeCos" 164668 164669 self shouldnt: [ 45 degreeCos] raise: Error. 164670 self assert: 45 degreeCos printString = (2 sqrt / 2) asFloat printString ! ! 164671 164672!IntegerTest methodsFor: 'tests - basic' stamp: 'md 4/21/2003 16:17'! 164673testEven 164674 164675 self deny: (1073741825 even). 164676 self assert: (1073741824 even). 164677 ! ! 164678 164679!IntegerTest methodsFor: 'tests - basic' stamp: 'sd 6/5/2005 08:45'! 164680testIsInteger 164681 164682 self assert: (0 isInteger). 164683 ! ! 164684 164685!IntegerTest methodsFor: 'tests - basic' stamp: 'md 4/15/2003 20:40'! 164686testIsPowerOfTwo 164687 164688 self assert: (0 isPowerOfTwo). 164689 self assert: (1 isPowerOfTwo). 164690 self assert: (2 isPowerOfTwo). 164691 self deny: (3 isPowerOfTwo). 164692 self assert: (4 isPowerOfTwo). 164693 ! ! 164694 164695!IntegerTest methodsFor: 'tests - basic' stamp: 'nice 1/25/2008 22:51'! 164696testIsPowerOfTwoM6873 164697 "This is a non regression test for http://bugs.squeak.org/view.php?id=6873" 164698 164699 self deny: ((1 to: 80) anySatisfy: [:n | (2 raisedTo: n) negated isPowerOfTwo]) 164700 description: 'A negative integer cannot be a power of two'.! ! 164701 164702!IntegerTest methodsFor: 'tests - basic' stamp: 'md 2/12/2006 14:40'! 164703testIsPrime 164704 164705 "The following tests should return 'true'" 164706 self assert: 17 isPrime. 164707 self assert: 78901 isPrime. 164708 self assert: 104729 isPrime. 164709 self assert: 15485863 isPrime. 164710 self assert: 2038074743 isPrime. 164711 self assert: 29996224275833 isPrime. 164712 164713 "The following tests should return 'false' (first 5 are Carmichael integers)" 164714 self deny: 561 isPrime. 164715 self deny: 2821 isPrime. 164716 self deny: 6601 isPrime. 164717 self deny: 10585 isPrime. 164718 self deny: 15841 isPrime. 164719 self deny: 256 isPrime. 164720 self deny: 29996224275831 isPrime.! ! 164721 164722!IntegerTest methodsFor: 'tests - basic' stamp: 'md 2/12/2006 14:36'! 164723testLargePrimesUpTo 164724 164725 | nn | 164726 nn := (2 raisedTo: 17) - 1. 164727 self deny: (Integer primesUpTo: nn) last = nn. 164728 self assert: (Integer primesUpTo: nn + 1) last = nn. 164729 164730 164731! ! 164732 164733!IntegerTest methodsFor: 'tests - basic' stamp: 'md 2/12/2006 14:36'! 164734testPrimesUpTo 164735 164736 | primes nn| 164737 primes := Integer primesUpTo: 100. 164738 self assert: primes = #(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97). 164739 164740 "upTo: semantics means 'non-inclusive'" 164741 primes := Integer primesUpTo: 5. 164742 self assert: primes = #(2 3). 164743 164744 "this test is green for nn>25000, see #testLargePrimesUpTo" 164745 nn := 5. 164746 self deny: (Integer primesUpTo: nn) last = nn. 164747 self assert: (Integer primesUpTo: nn + 1) last = nn.! ! 164748 164749 164750!IntegerTest methodsFor: 'tests - benchmarks' stamp: 'sd 6/5/2005 08:37'! 164751testBenchFib 164752 164753 self assert: (0 benchFib = 1). 164754 self assert: (1 benchFib = 1). 164755 self assert: (2 benchFib = 3). 164756 ! ! 164757 164758 164759!IntegerTest methodsFor: 'tests - bitLogic' stamp: 'nice 3/21/2008 00:49'! 164760testBitAt 164761 | trials aNumber bitSequence2 bitInvert | 164762 164763 self 164764 assert: ((1 to: 100) allSatisfy: [:i | (0 bitAt: i) = 0]) 164765 description: 'all bits of zero are set to zero'. 164766 164767 self 164768 assert: ((1 to: 100) allSatisfy: [:i | (-1 bitAt: i) = 1]) 164769 description: 'In two complements, all bits of -1 are set to 1'. 164770 164771 164772 trials := #( 164773 '2r10010011' 164774 '2r11100100' 164775 '2r10000000' 164776 '2r0000101011011001' 164777 '2r1000101011011001' 164778 '2r0101010101011000' 164779 '2r0010011110110010' 164780 '2r0010011000000000' 164781 '2r00100111101100101000101011011001' 164782 '2r01110010011110110010100110101101' 164783 '2r10101011101011001010000010110110' 164784 '2r10101000000000000000000000000000' 164785 '2r0010101110101001110010100000101101100010011110110010100010101100' 164786 '2r1010101110101100101000001011011000100111101100101000101011011001' 164787 '2r1010101110101000000000000000000000000000000000000000000000000000'). 164788 trials do: [:bitSequence | 164789 aNumber := Number readFrom: bitSequence. 164790 bitSequence2 := (bitSequence size - 2 to: 1 by: -1) inject: '2r' into: [:string :i | string copyWith: (Character digitValue: (aNumber bitAt: i))]. 164791 self assert: bitSequence2 = bitSequence]. 164792 164793 trials do: [:bitSequence | 164794 bitInvert := -1 - (Number readFrom: bitSequence). 164795 bitSequence2 := (bitSequence size - 2 to: 1 by: -1) inject: '2r' into: [:string :i | string copyWith: (Character digitValue: 1 - (bitInvert bitAt: i))]. 164796 self assert: bitSequence2 = bitSequence description: '-1-x is similar to a bitInvert operation in two complement']! ! 164797 164798!IntegerTest methodsFor: 'tests - bitLogic' stamp: 'sd 6/5/2005 08:43'! 164799testBitLogic 164800 "This little suite of tests is designed to verify correct operation of most 164801 of Squeak's bit manipulation code, including two's complement 164802 representation of negative values. It was written in a hurry and 164803 is probably lacking several important checks." 164804 164805 "Shift 1 bit left then right and test for 1" 164806 "self run: #testBitLogic" 164807 | n | 164808 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitShift: i negated) = 1]. 164809 164810 "Shift -1 left then right and test for 1" 164811 1 to: 100 do: [:i | self assert: ((-1 bitShift: i) bitShift: i negated) = -1]. 164812 164813 "And a single bit with -1 and test for same value" 164814 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitAnd: -1) = (1 bitShift: i)]. 164815 164816 "Verify that (n bitAnd: n negated) = n for single bits" 164817 1 to: 100 do: [:i | n := 1 bitShift: i. self assert: (n bitAnd: n negated) = n]. 164818 164819 "Verify that n negated = (n complemented + 1) for single bits" 164820 1 to: 100 do: [:i | 164821 n := 1 bitShift: i. 164822 self assert: n negated = ((n bitXor: -1) + 1)]. 164823 164824 "Verify that (n + n complemented) = -1 for single bits" 164825 1 to: 100 do: [:i | 164826 n := 1 bitShift: i. 164827 self assert: (n + (n bitXor: -1)) = -1]. 164828 164829 "Verify that n negated = (n complemented +1) for single bits" 164830 1 to: 100 do: [:i | 164831 n := 1 bitShift: i. 164832 self assert: n negated = ((n bitXor: -1) + 1)]. 164833 164834 self assert: (-2 bitAnd: 16rFFFFFFFF) = 16rFFFFFFFE.! ! 164835 164836!IntegerTest methodsFor: 'tests - bitLogic' stamp: 'nice 7/8/2008 02:47'! 164837testHighBit 164838 | suite | 164839 164840 suite := (0 to: 1024) asArray , #(16rFDFD 16rFFFF 16r1000 16r1000000 16r1000001 16r70000000 16r7AFAFAFA ) , {SmallInteger maxVal . SmallInteger maxVal+1}. 164841 suite := suite , (suite collect: [:e | e raisedTo: 20]). 164842 164843 suite do: [:anInteger | 164844 | highBit shifted | 164845 highBit := 0. 164846 shifted := 1. 164847 [shifted > anInteger] whileFalse: [highBit := highBit+1. shifted := shifted bitShift: 1]. 164848 self assert: anInteger highBit = highBit].! ! 164849 164850!IntegerTest methodsFor: 'tests - bitLogic' stamp: 'nice 7/8/2008 02:44'! 164851testHighBitOfMagnitude 164852 | suite | 164853 164854 suite := (0 to: 1024) asArray , #(16rFDFD 16rFFFF 16r1000 16r1000000 16r1000001 16r70000000 16r7AFAFAFA ) , {SmallInteger maxVal . SmallInteger maxVal+1}. 164855 suite := suite , (suite collect: [:e | e raisedTo: 20]). 164856 164857 suite do: [:anInteger | 164858 | highBit shifted | 164859 highBit := 0. 164860 shifted := 1. 164861 [shifted > anInteger] whileFalse: [highBit := highBit+1. shifted := shifted bitShift: 1]. 164862 self assert: anInteger highBitOfMagnitude = highBit. 164863 self assert: anInteger negated highBitOfMagnitude = highBit].! ! 164864 164865!IntegerTest methodsFor: 'tests - bitLogic' stamp: 'nice 7/8/2008 02:21'! 164866testLowBit 164867 | suite | 164868 164869 suite := (0 to: 1024) asArray , #(16rFDFD 16rFFFF 16r1000 16r1000000 16r1000001 16r70000000 16r7AFAFAFA ) , {SmallInteger maxVal . SmallInteger maxVal+1}. 164870 suite := suite , (suite collect: [:e | e raisedTo: 20]). 164871 164872 suite do: [:anInteger | 164873 | lowBit | 164874 lowBit := (anInteger respondsTo: #bitAt:) 164875 ifTrue: [(1 to: anInteger highBit) detect: [:bitIndex | (anInteger bitAt: bitIndex) ~= 0] ifNone: [0]] 164876 ifFalse: [(1 to: anInteger highBit) detect: [:bitIndex | (anInteger bitAnd: (1 bitShift: bitIndex-1)) ~= 0] ifNone: [0]]. 164877 self assert: anInteger lowBit = lowBit. 164878 self assert: anInteger negated lowBit = lowBit].! ! 164879 164880!IntegerTest methodsFor: 'tests - bitLogic' stamp: 'nice 1/26/2008 02:22'! 164881testTwoComplementBitLogicWithCarry 164882 "This is non regression test for http://bugs.squeak.org/view.php?id=6874" 164883 164884 "By property of two complement, following operation is: 164885 ...111110000 this is -16 164886 ...111101111 this is -16-1 164887 ...111100000 this is -32, the result of bitAnd: on two complement 164888 164889 This test used to fail with n=31 39 47.... because of bug 6874" 164890 164891 self assert: ((2 to: 80) allSatisfy: [:n | ((2 raisedTo: n) negated bitAnd: (2 raisedTo: n) negated - 1) = (2 raisedTo: n + 1) negated]).! ! 164892 164893!IntegerTest methodsFor: 'tests - bitLogic' stamp: 'sd 6/5/2005 08:44'! 164894testTwoComplementRightShift 164895 "self run: #testTwoComplementRightShift" 164896 164897 | large small | 164898 small := 2 << 16. 164899 large := 2 << 32. 164900 self assert: ((small negated bitShift: -1) ~= ((small + 1) negated bitShift: -1) 164901 == ((large negated bitShift: -1) ~= ((large + 1) negated bitShift: -1))). 164902 164903 self assert: ((small bitShift: -1) ~= (small + 1 bitShift: -1) 164904 == ((large bitShift: -1) ~= (large + 1 bitShift: -1))).! ! 164905 164906 164907!IntegerTest methodsFor: 'tests - instance creation' stamp: 'sd 6/5/2005 08:48'! 164908testCreationFromBytes1 164909 "self run: #testCreationFromBytes1" 164910 "it is illegal for a LargeInteger to be less than SmallInteger maxVal." 164911 "here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs SmallInteger maxVal as an instance of SmallInteger. " 164912 164913 | maxSmallInt hexString byte1 byte2 byte3 byte4 164914 builtInteger | 164915 maxSmallInt := SmallInteger maxVal. 164916 hexString := maxSmallInt printStringHex. 164917 self assert: hexString size = 8. 164918 byte4 := Number readFrom: (hexString copyFrom: 1 to: 2) base: 16. 164919 byte3 := Number readFrom: (hexString copyFrom: 3 to: 4) base: 16. 164920 byte2 := Number readFrom: (hexString copyFrom: 5 to: 6) base: 16. 164921 byte1 := Number readFrom: (hexString copyFrom: 7 to: 8) base: 16. 164922 builtInteger := Integer byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4. 164923 self assert: builtInteger = maxSmallInt. 164924 self assert: builtInteger class = SmallInteger 164925! ! 164926 164927!IntegerTest methodsFor: 'tests - instance creation' stamp: 'sd 6/5/2005 08:48'! 164928testCreationFromBytes2 164929 "self run: #testCreationFromBytes2" 164930 164931 "it is illegal for a LargeInteger to be less than SmallInteger maxVal." 164932 "here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs (SmallInteger maxVal + 1) as an instance of LargePositiveInteger. " 164933 | maxSmallInt hexString byte1 byte2 byte3 byte4 builtInteger | 164934 maxSmallInt := SmallInteger maxVal. 164935 hexString := (maxSmallInt + 1) printStringHex. 164936 self assert: hexString size = 8. 164937 byte4 := Number readFrom: (hexString copyFrom: 1 to: 2) base: 16. 164938 byte3 := Number readFrom: (hexString copyFrom: 3 to: 4) base: 16. 164939 byte2 := Number readFrom: (hexString copyFrom: 5 to: 6) base: 16. 164940 byte1 := Number readFrom: (hexString copyFrom: 7 to: 8) base: 16. 164941 builtInteger := Integer byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4. 164942 self assert: builtInteger = (maxSmallInt + 1). 164943 self deny: builtInteger class = SmallInteger 164944! ! 164945 164946!IntegerTest methodsFor: 'tests - instance creation' stamp: 'sd 6/5/2005 08:49'! 164947testCreationFromBytes3 164948 "self run: #testCreationFromBytes3" 164949 164950 "it is illegal for a LargeInteger to be less than SmallInteger maxVal." 164951 "here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs (SmallInteger maxVal - 1) as an instance of SmallInteger. " 164952 | maxSmallInt hexString byte1 byte2 byte3 byte4 164953 builtInteger | 164954 maxSmallInt := SmallInteger maxVal. 164955 hexString := (maxSmallInt - 1) printStringHex. 164956 self assert: hexString size = 8. 164957 byte4 := Number readFrom: (hexString copyFrom: 1 to: 2) base: 16. 164958 byte3 := Number readFrom: (hexString copyFrom: 3 to: 4) base: 16. 164959 byte2 := Number readFrom: (hexString copyFrom: 5 to: 6) base: 16. 164960 byte1 := Number readFrom: (hexString copyFrom: 7 to: 8) base: 16. 164961 builtInteger := Integer byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4. 164962 self assert: builtInteger = (maxSmallInt - 1). 164963 self assert: builtInteger class = SmallInteger 164964! ! 164965 164966!IntegerTest methodsFor: 'tests - instance creation' stamp: 'sd 6/5/2005 08:46'! 164967testDifferentBases 164968 "self run: #testDifferentBases" 164969 "| value | 164970 2 to: 36 do: [:each| 164971 value := 0. 164972 1 to: each-1 do: [:n| value := value + (n * (each raisedToInteger: n))]. 164973 value := value negated. 164974 Transcript tab; show: 'self assert: (', value printString, ' printStringBase: ', each printString, ') = ''', (value printStringBase: each), '''.'; cr. 164975 Transcript tab; show: 'self assert: (', value printString, ' radix: ', each printString, ') = ''', (value radix: each), '''.'; cr. 164976 Transcript tab; show: 'self assert: ', value printString, ' printStringHex = ''', (value printStringBase: 16), '''.'; cr. 164977 Transcript tab; show: 'self assert: (', value printString, ' storeStringBase: ', each printString, ') = ''', (value storeStringBase: each), '''.'; cr. 164978 Transcript tab; show: 'self assert: ', value printString, ' storeStringHex = ''', (value storeStringBase: 16), '''.'; cr. 164979 164980 164981]. 164982 " 164983 164984 self assert: 2r10 = 2. 164985 self assert: 3r210 = 21. 164986 self assert: 4r3210 = 228. 164987 self assert: 5r43210 = 2930. 164988 self assert: 6r543210 = 44790. 164989 self assert: 7r6543210 = 800667. 164990 self assert: 8r76543210 = 16434824. 164991 self assert: 9r876543210 = 381367044. 164992 self assert: 10r9876543210 = 9876543210. 164993 self assert: 11rA9876543210 = 282458553905. 164994 self assert: 12rBA9876543210 = 8842413667692. 164995 self assert: 13rCBA9876543210 = 300771807240918. 164996 self assert: 14rDCBA9876543210 = 11046255305880158. 164997 self assert: 15rEDCBA9876543210 = 435659737878916215. 164998 self assert: 16rFEDCBA9876543210 = 18364758544493064720. 164999 self assert: 17rGFEDCBA9876543210 = 824008854613343261192. 165000 self assert: 18rHGFEDCBA9876543210 = 39210261334551566857170. 165001 self assert: 19rIHGFEDCBA9876543210 = 1972313422155189164466189. 165002 self assert: 20rJIHGFEDCBA9876543210 = 104567135734072022160664820. 165003 self assert: 21rKJIHGFEDCBA9876543210 = 5827980550840017565077671610. 165004 self assert: 22rLKJIHGFEDCBA9876543210 = 340653664490377789692799452102. 165005 self assert: 23rMLKJIHGFEDCBA9876543210 = 20837326537038308910317109288851. 165006 self assert: 24rNMLKJIHGFEDCBA9876543210 = 1331214537196502869015340298036888. 165007 self assert: 25rONMLKJIHGFEDCBA9876543210 = 88663644327703473714387251271141900. 165008 self assert: 26rPONMLKJIHGFEDCBA9876543210 = 6146269788878825859099399609538763450. 165009 self assert: 27rQPONMLKJIHGFEDCBA9876543210 = 442770531899482980347734468443677777577. 165010 self assert: 28rRQPONMLKJIHGFEDCBA9876543210 = 33100056003358651440264672384704297711484. 165011 self assert: 29rSRQPONMLKJIHGFEDCBA9876543210 = 2564411043271974895869785066497940850811934. 165012 self assert: 30rTSRQPONMLKJIHGFEDCBA9876543210 = 205646315052919334126040428061831153388822830. 165013 self assert: 31rUTSRQPONMLKJIHGFEDCBA9876543210 = 17050208381689099029767742314582582184093573615. 165014 self assert: 32rVUTSRQPONMLKJIHGFEDCBA9876543210 = 1459980823972598128486511383358617792788444579872. 165015 self assert: 33rWVUTSRQPONMLKJIHGFEDCBA9876543210 = 128983956064237823710866404905431464703849549412368. 165016 self assert: 34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 11745843093701610854378775891116314824081102660800418. 165017 self assert: 35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 1101553773143634726491620528194292510495517905608180485. 165018 self assert: 36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 106300512100105327644605138221229898724869759421181854980. 165019 165020 self assert: -2r10 = -2. 165021 self assert: -3r210 = -21. 165022 self assert: -4r3210 = -228. 165023 self assert: -5r43210 = -2930. 165024 self assert: -6r543210 = -44790. 165025 self assert: -7r6543210 = -800667. 165026 self assert: -8r76543210 = -16434824. 165027 self assert: -9r876543210 = -381367044. 165028 self assert: -10r9876543210 = -9876543210. 165029 self assert: -11rA9876543210 = -282458553905. 165030 self assert: -12rBA9876543210 = -8842413667692. 165031 self assert: -13rCBA9876543210 = -300771807240918. 165032 self assert: -14rDCBA9876543210 = -11046255305880158. 165033 self assert: -15rEDCBA9876543210 = -435659737878916215. 165034 self assert: -16rFEDCBA9876543210 = -18364758544493064720. 165035 self assert: -17rGFEDCBA9876543210 = -824008854613343261192. 165036 self assert: -18rHGFEDCBA9876543210 = -39210261334551566857170. 165037 self assert: -19rIHGFEDCBA9876543210 = -1972313422155189164466189. 165038 self assert: -20rJIHGFEDCBA9876543210 = -104567135734072022160664820. 165039 self assert: -21rKJIHGFEDCBA9876543210 = -5827980550840017565077671610. 165040 self assert: -22rLKJIHGFEDCBA9876543210 = -340653664490377789692799452102. 165041 self assert: -23rMLKJIHGFEDCBA9876543210 = -20837326537038308910317109288851. 165042 self assert: -24rNMLKJIHGFEDCBA9876543210 = -1331214537196502869015340298036888. 165043 self assert: -25rONMLKJIHGFEDCBA9876543210 = -88663644327703473714387251271141900. 165044 self assert: -26rPONMLKJIHGFEDCBA9876543210 = -6146269788878825859099399609538763450. 165045 self assert: -27rQPONMLKJIHGFEDCBA9876543210 = -442770531899482980347734468443677777577. 165046 self assert: -28rRQPONMLKJIHGFEDCBA9876543210 = -33100056003358651440264672384704297711484. 165047 self assert: -29rSRQPONMLKJIHGFEDCBA9876543210 = -2564411043271974895869785066497940850811934. 165048 self assert: -30rTSRQPONMLKJIHGFEDCBA9876543210 = -205646315052919334126040428061831153388822830. 165049 self assert: -31rUTSRQPONMLKJIHGFEDCBA9876543210 = -17050208381689099029767742314582582184093573615. 165050 self assert: -32rVUTSRQPONMLKJIHGFEDCBA9876543210 = -1459980823972598128486511383358617792788444579872. 165051 self assert: -33rWVUTSRQPONMLKJIHGFEDCBA9876543210 = -128983956064237823710866404905431464703849549412368. 165052 self assert: -34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -11745843093701610854378775891116314824081102660800418. 165053 self assert: -35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -1101553773143634726491620528194292510495517905608180485. 165054 self assert: -36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -106300512100105327644605138221229898724869759421181854980.! ! 165055 165056!IntegerTest methodsFor: 'tests - instance creation' stamp: 'laza 11/14/2004 00:14'! 165057testIntegerReadFrom 165058 self assert: (Integer readFrom: '123' readStream base: 10) = 123. 165059 self assert: (Integer readFrom: '-123' readStream base: 10) = -123. 165060 self assert: (Integer readFrom: 'abc' readStream base: 10) = 0. 165061 self assert: (Integer readFrom: 'D12' readStream base: 10) = 0. 165062 self assert: (Integer readFrom: '1two3' readStream base: 10) = 1. 165063! ! 165064 165065!IntegerTest methodsFor: 'tests - instance creation' stamp: 'md 3/25/2003 23:14'! 165066testNew 165067 self should: [Integer new] raise: TestResult error. ! ! 165068 165069!IntegerTest methodsFor: 'tests - instance creation' stamp: 'damiencassou 5/30/2008 11:09'! 165070testReadFrom 165071 "Ensure remaining characters in a stream are not lost when parsing an integer." 165072 | rs i s | 165073 rs := '123s could be confused with a ScaledDecimal' readStream. 165074 i := Number readFrom: rs. 165075 self assert: i == 123. 165076 s := rs upToEnd. 165077 self assert: 's could be confused with a ScaledDecimal' = s. 165078 rs := '123.s could be confused with a ScaledDecimal' readStream. 165079 i := Number readFrom: rs. 165080 self assert: i == 123. 165081 s := rs upToEnd. 165082 self assert: '.s could be confused with a ScaledDecimal' = s! ! 165083 165084!IntegerTest methodsFor: 'tests - instance creation' stamp: 'dtl 9/18/2004 17:07'! 165085testStringAsNumber 165086 "This covers parsing in Number>>readFrom: 165087 Trailing decimal points should be ignored." 165088 165089 self assert: ('123' asNumber == 123). 165090 self assert: ('-123' asNumber == -123). 165091 self assert: ('123.' asNumber == 123). 165092 self assert: ('-123.' asNumber == -123). 165093 self assert: ('123This is not to be read' asNumber == 123). 165094 self assert: ('123s could be confused with a ScaledDecimal' asNumber == 123). 165095 self assert: ('123e could be confused with a Float' asNumber == 123). 165096! ! 165097 165098 165099!IntegerTest methodsFor: 'tests - printing' stamp: 'al 7/21/2008 22:36'! 165100testBadBase 165101 "This used to get into an endless loop. 165102 See Pharo #114" 165103 165104 self should: [2 printStringBase: 1] raise: Error.! ! 165105 165106!IntegerTest methodsFor: 'tests - printing' stamp: 'stephane.ducasse 5/25/2008 15:46'! 165107testHex 165108 self assert: 0 hex = '0'. 165109 self assert: 12 hex = 'C'. 165110 self assert: 1234 hex = '4D2'.! ! 165111 165112!IntegerTest methodsFor: 'tests - printing' stamp: 'laza 3/29/2004 18:16'! 165113testIntegerPadding 165114 "self run: #testIntegerPadding" 165115 165116 self assert: (1 printStringBase: 10 length: 0 padded: false) = '1'. 165117 self assert: (1 printStringBase: 10 length: 1 padded: false) = '1'. 165118 self assert: (1 printStringBase: 10 length: 2 padded: false) = ' 1'. 165119 self assert: (1024 printStringBase: 10 length: 19 padded: false) = ' 1024'. 165120 self assert: (1024 printStringBase: 10 length: -1 padded: false) = '1024'. 165121 self assert: (1024 printStringBase: 10 length: 5 padded: false) = ' 1024'. 165122 self assert: (-1024 printStringBase: 10 length: 5 padded: false) = '-1024'. 165123 self assert: (-1024 printStringBase: 10 length: 19 padded: false) = ' -1024'. 165124 165125 self assert: (1 printStringBase: 10 length: 0 padded: true) = '1'. 165126 self assert: (1 printStringBase: 10 length: 1 padded: true) = '1'. 165127 self assert: (1 printStringBase: 10 length: 2 padded: true) = '01'. 165128 self assert: (1024 printStringBase: 10 length: 19 padded: true) = '0000000000000001024'. 165129 self assert: (1024 printStringBase: 10 length: -1 padded: true) = '1024'. 165130 self assert: (1024 printStringBase: 10 length: 5 padded: true) = '01024'. 165131 self assert: (-1024 printStringBase: 10 length: 5 padded: true) = '-1024'. 165132 self assert: (-1024 printStringBase: 10 length: 19 padded: true) = '-000000000000001024'. 165133 165134 self assert: (1 printStringBase: 16 length: 0 padded: false) = '1'. 165135 self assert: (1 printStringBase: 16 length: 1 padded: false) = '1'. 165136 self assert: (1 printStringBase: 16 length: 2 padded: false) = ' 1'. 165137 self assert: (2047 printStringBase: 16 length: 19 padded: false) = ' 7FF'. 165138 self assert: (2047 printStringBase: 16 length: -1 padded: false) = '7FF'. 165139 self assert: (2047 printStringBase: 16 length: 4 padded: false) = ' 7FF'. 165140 self assert: (-2047 printStringBase: 16 length: 4 padded: false) = '-7FF'. 165141 self assert: (-2047 printStringBase: 16 length: 19 padded: false) = ' -7FF'. 165142 165143 self assert: (1 printStringBase: 16 length: 0 padded: true) = '1'. 165144 self assert: (1 printStringBase: 16 length: 1 padded: true) = '1'. 165145 self assert: (1 printStringBase: 16 length: 2 padded: true) = '01'. 165146 self assert: (2047 printStringBase: 16 length: 19 padded: true) = '00000000000000007FF'. 165147 self assert: (2047 printStringBase: 16 length: -1 padded: true) = '7FF'. 165148 self assert: (2047 printStringBase: 16 length: 4 padded: true) = '07FF'. 165149 self assert: (-2047 printStringBase: 16 length: 4 padded: true) = '-7FF'. 165150 self assert: (-2047 printStringBase: 16 length: 19 padded: true) = '-0000000000000007FF'. 165151 165152 self assert: (1 storeStringBase: 10 length: 0 padded: false) = '1'. 165153 self assert: (1 storeStringBase: 10 length: 1 padded: false) = '1'. 165154 self assert: (1 storeStringBase: 10 length: 2 padded: false) = ' 1'. 165155 self assert: (1024 storeStringBase: 10 length: 19 padded: false) = ' 1024'. 165156 self assert: (1024 storeStringBase: 10 length: -1 padded: false) = '1024'. 165157 self assert: (1024 storeStringBase: 10 length: 5 padded: false) = ' 1024'. 165158 self assert: (-1024 storeStringBase: 10 length: 5 padded: false) = '-1024'. 165159 self assert: (-1024 storeStringBase: 10 length: 19 padded: false) = ' -1024'. 165160 165161 self assert: (1 storeStringBase: 10 length: 0 padded: true) = '1'. 165162 self assert: (1 storeStringBase: 10 length: 1 padded: true) = '1'. 165163 self assert: (1 storeStringBase: 10 length: 2 padded: true) = '01'. 165164 self assert: (1024 storeStringBase: 10 length: 19 padded: true) = '0000000000000001024'. 165165 self assert: (1024 storeStringBase: 10 length: -1 padded: true) = '1024'. 165166 self assert: (1024 storeStringBase: 10 length: 5 padded: true) = '01024'. 165167 self assert: (-1024 storeStringBase: 10 length: 5 padded: true) = '-1024'. 165168 self assert: (-1024 storeStringBase: 10 length: 19 padded: true) = '-000000000000001024'. 165169 165170 self assert: (1 storeStringBase: 16 length: 0 padded: false) = '16r1'. 165171 self assert: (1 storeStringBase: 16 length: 4 padded: false) = '16r1'. 165172 self assert: (1 storeStringBase: 16 length: 5 padded: false) = ' 16r1'. 165173 self assert: (2047 storeStringBase: 16 length: 19 padded: false) = ' 16r7FF'. 165174 self assert: (2047 storeStringBase: 16 length: -1 padded: false) = '16r7FF'. 165175 self assert: (2047 storeStringBase: 16 length: 7 padded: false) = ' 16r7FF'. 165176 self assert: (-2047 storeStringBase: 16 length: 7 padded: false) = '-16r7FF'. 165177 self assert: (-2047 storeStringBase: 16 length: 19 padded: false) = ' -16r7FF'. 165178 165179 self assert: (1 storeStringBase: 16 length: 0 padded: true) = '16r1'. 165180 self assert: (1 storeStringBase: 16 length: 4 padded: true) = '16r1'. 165181 self assert: (1 storeStringBase: 16 length: 5 padded: true) = '16r01'. 165182 self assert: (2047 storeStringBase: 16 length: 19 padded: true) = '16r00000000000007FF'. 165183 self assert: (2047 storeStringBase: 16 length: -1 padded: true) = '16r7FF'. 165184 self assert: (2047 storeStringBase: 16 length: 7 padded: true) = '16r07FF'. 165185 self assert: (-2047 storeStringBase: 16 length: 7 padded: true) = '-16r7FF'. 165186 self assert: (-2047 storeStringBase: 16 length: 19 padded: true) = '-16r0000000000007FF'. 165187! ! 165188 165189!IntegerTest methodsFor: 'tests - printing' stamp: 'laza 3/30/2004 14:20'! 165190testNegativeIntegerPrinting 165191 "self run: #testnegativeIntegerPrinting" 165192 165193 self assert: (-2 printStringBase: 2) = '-10'. 165194 self assert: (-2 radix: 2) = '-10'. 165195 self assert: -2 printStringHex = '-2'. 165196 self assert: (-2 storeStringBase: 2) = '-2r10'. 165197 self assert: -2 storeStringHex = '-16r2'. 165198 self assert: (-21 printStringBase: 3) = '-210'. 165199 self assert: (-21 radix: 3) = '-210'. 165200 self assert: -21 printStringHex = '-15'. 165201 self assert: (-21 storeStringBase: 3) = '-3r210'. 165202 self assert: -21 storeStringHex = '-16r15'. 165203 self assert: (-228 printStringBase: 4) = '-3210'. 165204 self assert: (-228 radix: 4) = '-3210'. 165205 self assert: -228 printStringHex = '-E4'. 165206 self assert: (-228 storeStringBase: 4) = '-4r3210'. 165207 self assert: -228 storeStringHex = '-16rE4'. 165208 self assert: (-2930 printStringBase: 5) = '-43210'. 165209 self assert: (-2930 radix: 5) = '-43210'. 165210 self assert: -2930 printStringHex = '-B72'. 165211 self assert: (-2930 storeStringBase: 5) = '-5r43210'. 165212 self assert: -2930 storeStringHex = '-16rB72'. 165213 self assert: (-44790 printStringBase: 6) = '-543210'. 165214 self assert: (-44790 radix: 6) = '-543210'. 165215 self assert: -44790 printStringHex = '-AEF6'. 165216 self assert: (-44790 storeStringBase: 6) = '-6r543210'. 165217 self assert: -44790 storeStringHex = '-16rAEF6'. 165218 self assert: (-800667 printStringBase: 7) = '-6543210'. 165219 self assert: (-800667 radix: 7) = '-6543210'. 165220 self assert: -800667 printStringHex = '-C379B'. 165221 self assert: (-800667 storeStringBase: 7) = '-7r6543210'. 165222 self assert: -800667 storeStringHex = '-16rC379B'. 165223 self assert: (-16434824 printStringBase: 8) = '-76543210'. 165224 self assert: (-16434824 radix: 8) = '-76543210'. 165225 self assert: -16434824 printStringHex = '-FAC688'. 165226 self assert: (-16434824 storeStringBase: 8) = '-8r76543210'. 165227 self assert: -16434824 storeStringHex = '-16rFAC688'. 165228 self assert: (-381367044 printStringBase: 9) = '-876543210'. 165229 self assert: (-381367044 radix: 9) = '-876543210'. 165230 self assert: -381367044 printStringHex = '-16BB3304'. 165231 self assert: (-381367044 storeStringBase: 9) = '-9r876543210'. 165232 self assert: -381367044 storeStringHex = '-16r16BB3304'. 165233 self assert: (-9876543210 printStringBase: 10) = '-9876543210'. 165234 self assert: (-9876543210 radix: 10) = '-9876543210'. 165235 self assert: -9876543210 printStringHex = '-24CB016EA'. 165236 self assert: (-9876543210 storeStringBase: 10) = '-9876543210'. 165237 self assert: -9876543210 storeStringHex = '-16r24CB016EA'. 165238 self assert: (-282458553905 printStringBase: 11) = '-A9876543210'. 165239 self assert: (-282458553905 radix: 11) = '-A9876543210'. 165240 self assert: -282458553905 printStringHex = '-41C3D77E31'. 165241 self assert: (-282458553905 storeStringBase: 11) = '-11rA9876543210'. 165242 self assert: -282458553905 storeStringHex = '-16r41C3D77E31'. 165243 self assert: (-8842413667692 printStringBase: 12) = '-BA9876543210'. 165244 self assert: (-8842413667692 radix: 12) = '-BA9876543210'. 165245 self assert: -8842413667692 printStringHex = '-80AC8ECF56C'. 165246 self assert: (-8842413667692 storeStringBase: 12) = '-12rBA9876543210'. 165247 self assert: -8842413667692 storeStringHex = '-16r80AC8ECF56C'. 165248 self assert: (-300771807240918 printStringBase: 13) = '-CBA9876543210'. 165249 self assert: (-300771807240918 radix: 13) = '-CBA9876543210'. 165250 self assert: -300771807240918 printStringHex = '-1118CE4BAA2D6'. 165251 self assert: (-300771807240918 storeStringBase: 13) = '-13rCBA9876543210'. 165252 self assert: -300771807240918 storeStringHex = '-16r1118CE4BAA2D6'. 165253 self assert: (-11046255305880158 printStringBase: 14) = '-DCBA9876543210'. 165254 self assert: (-11046255305880158 radix: 14) = '-DCBA9876543210'. 165255 self assert: -11046255305880158 printStringHex = '-273E82BB9AF25E'. 165256 self assert: (-11046255305880158 storeStringBase: 14) = '-14rDCBA9876543210'. 165257 self assert: -11046255305880158 storeStringHex = '-16r273E82BB9AF25E'. 165258 self assert: (-435659737878916215 printStringBase: 15) = '-EDCBA9876543210'. 165259 self assert: (-435659737878916215 radix: 15) = '-EDCBA9876543210'. 165260 self assert: -435659737878916215 printStringHex = '-60BC6392F366C77'. 165261 self assert: (-435659737878916215 storeStringBase: 15) = '-15rEDCBA9876543210'. 165262 self assert: -435659737878916215 storeStringHex = '-16r60BC6392F366C77'. 165263 self assert: (-18364758544493064720 printStringBase: 16) = '-FEDCBA9876543210'. 165264 self assert: (-18364758544493064720 radix: 16) = '-FEDCBA9876543210'. 165265 self assert: -18364758544493064720 printStringHex = '-FEDCBA9876543210'. 165266 self assert: (-18364758544493064720 storeStringBase: 16) = '-16rFEDCBA9876543210'. 165267 self assert: -18364758544493064720 storeStringHex = '-16rFEDCBA9876543210'. 165268 self assert: (-824008854613343261192 printStringBase: 17) = '-GFEDCBA9876543210'. 165269 self assert: (-824008854613343261192 radix: 17) = '-GFEDCBA9876543210'. 165270 self assert: -824008854613343261192 printStringHex = '-2CAB6B877C1CD2D208'. 165271 self assert: (-824008854613343261192 storeStringBase: 17) = '-17rGFEDCBA9876543210'. 165272 self assert: -824008854613343261192 storeStringHex = '-16r2CAB6B877C1CD2D208'. 165273 self assert: (-39210261334551566857170 printStringBase: 18) = '-HGFEDCBA9876543210'. 165274 self assert: (-39210261334551566857170 radix: 18) = '-HGFEDCBA9876543210'. 165275 self assert: -39210261334551566857170 printStringHex = '-84D97AFCAE81415B3D2'. 165276 self assert: (-39210261334551566857170 storeStringBase: 18) = '-18rHGFEDCBA9876543210'. 165277 self assert: -39210261334551566857170 storeStringHex = '-16r84D97AFCAE81415B3D2'. 165278 self assert: (-1972313422155189164466189 printStringBase: 19) = '-IHGFEDCBA9876543210'. 165279 self assert: (-1972313422155189164466189 radix: 19) = '-IHGFEDCBA9876543210'. 165280 self assert: -1972313422155189164466189 printStringHex = '-1A1A75329C5C6FC00600D'. 165281 self assert: (-1972313422155189164466189 storeStringBase: 19) = '-19rIHGFEDCBA9876543210'. 165282 self assert: -1972313422155189164466189 storeStringHex = '-16r1A1A75329C5C6FC00600D'. 165283 self assert: (-104567135734072022160664820 printStringBase: 20) = '-JIHGFEDCBA9876543210'. 165284 self assert: (-104567135734072022160664820 radix: 20) = '-JIHGFEDCBA9876543210'. 165285 self assert: -104567135734072022160664820 printStringHex = '-567EF3C9636D242A8C68F4'. 165286 self assert: (-104567135734072022160664820 storeStringBase: 20) = '-20rJIHGFEDCBA9876543210'. 165287 self assert: -104567135734072022160664820 storeStringHex = '-16r567EF3C9636D242A8C68F4'. 165288 self assert: (-5827980550840017565077671610 printStringBase: 21) = '-KJIHGFEDCBA9876543210'. 165289 self assert: (-5827980550840017565077671610 radix: 21) = '-KJIHGFEDCBA9876543210'. 165290 self assert: -5827980550840017565077671610 printStringHex = '-12D4CAE2B8A09BCFDBE30EBA'. 165291 self assert: (-5827980550840017565077671610 storeStringBase: 21) = '-21rKJIHGFEDCBA9876543210'. 165292 self assert: -5827980550840017565077671610 storeStringHex = '-16r12D4CAE2B8A09BCFDBE30EBA'. 165293 self assert: (-340653664490377789692799452102 printStringBase: 22) = '-LKJIHGFEDCBA9876543210'. 165294 self assert: (-340653664490377789692799452102 radix: 22) = '-LKJIHGFEDCBA9876543210'. 165295 self assert: -340653664490377789692799452102 printStringHex = '-44CB61B5B47E1A5D8F88583C6'. 165296 self assert: (-340653664490377789692799452102 storeStringBase: 22) = '-22rLKJIHGFEDCBA9876543210'. 165297 self assert: -340653664490377789692799452102 storeStringHex = '-16r44CB61B5B47E1A5D8F88583C6'. 165298 self assert: (-20837326537038308910317109288851 printStringBase: 23) = '-MLKJIHGFEDCBA9876543210'. 165299 self assert: (-20837326537038308910317109288851 radix: 23) = '-MLKJIHGFEDCBA9876543210'. 165300 self assert: -20837326537038308910317109288851 printStringHex = '-1070108876456E0EF115B389F93'. 165301 self assert: (-20837326537038308910317109288851 storeStringBase: 23) = '-23rMLKJIHGFEDCBA9876543210'. 165302 self assert: -20837326537038308910317109288851 storeStringHex = '-16r1070108876456E0EF115B389F93'. 165303 self assert: (-1331214537196502869015340298036888 printStringBase: 24) = '-NMLKJIHGFEDCBA9876543210'. 165304 self assert: (-1331214537196502869015340298036888 radix: 24) = '-NMLKJIHGFEDCBA9876543210'. 165305 self assert: -1331214537196502869015340298036888 printStringHex = '-41A24A285154B026B6ED206C6698'. 165306 self assert: (-1331214537196502869015340298036888 storeStringBase: 24) = '-24rNMLKJIHGFEDCBA9876543210'. 165307 self assert: -1331214537196502869015340298036888 storeStringHex = '-16r41A24A285154B026B6ED206C6698'. 165308 self assert: (-88663644327703473714387251271141900 printStringBase: 25) = '-ONMLKJIHGFEDCBA9876543210'. 165309 self assert: (-88663644327703473714387251271141900 radix: 25) = '-ONMLKJIHGFEDCBA9876543210'. 165310 self assert: -88663644327703473714387251271141900 printStringHex = '-111374860A2C6CEBE5999630398A0C'. 165311 self assert: (-88663644327703473714387251271141900 storeStringBase: 25) = '-25rONMLKJIHGFEDCBA9876543210'. 165312 self assert: -88663644327703473714387251271141900 storeStringHex = '-16r111374860A2C6CEBE5999630398A0C'. 165313 self assert: (-6146269788878825859099399609538763450 printStringBase: 26) = '-PONMLKJIHGFEDCBA9876543210'. 165314 self assert: (-6146269788878825859099399609538763450 radix: 26) = '-PONMLKJIHGFEDCBA9876543210'. 165315 self assert: -6146269788878825859099399609538763450 printStringHex = '-49FBA7F30B0F48BD14E6A99BD8ADABA'. 165316 self assert: (-6146269788878825859099399609538763450 storeStringBase: 26) = '-26rPONMLKJIHGFEDCBA9876543210'. 165317 self assert: -6146269788878825859099399609538763450 storeStringHex = '-16r49FBA7F30B0F48BD14E6A99BD8ADABA'. 165318 self assert: (-442770531899482980347734468443677777577 printStringBase: 27) = '-QPONMLKJIHGFEDCBA9876543210'. 165319 self assert: (-442770531899482980347734468443677777577 radix: 27) = '-QPONMLKJIHGFEDCBA9876543210'. 165320 self assert: -442770531899482980347734468443677777577 printStringHex = '-14D1A80A997343640C1145A073731DEA9'. 165321 self assert: (-442770531899482980347734468443677777577 storeStringBase: 27) = '-27rQPONMLKJIHGFEDCBA9876543210'. 165322 self assert: -442770531899482980347734468443677777577 storeStringHex = '-16r14D1A80A997343640C1145A073731DEA9'. 165323 self assert: (-33100056003358651440264672384704297711484 printStringBase: 28) = '-RQPONMLKJIHGFEDCBA9876543210'. 165324 self assert: (-33100056003358651440264672384704297711484 radix: 28) = '-RQPONMLKJIHGFEDCBA9876543210'. 165325 self assert: -33100056003358651440264672384704297711484 printStringHex = '-6145B6E6DACFA25D0E936F51D25932377C'. 165326 self assert: (-33100056003358651440264672384704297711484 storeStringBase: 28) = '-28rRQPONMLKJIHGFEDCBA9876543210'. 165327 self assert: -33100056003358651440264672384704297711484 storeStringHex = '-16r6145B6E6DACFA25D0E936F51D25932377C'. 165328 self assert: (-2564411043271974895869785066497940850811934 printStringBase: 29) = '-SRQPONMLKJIHGFEDCBA9876543210'. 165329 self assert: (-2564411043271974895869785066497940850811934 radix: 29) = '-SRQPONMLKJIHGFEDCBA9876543210'. 165330 self assert: -2564411043271974895869785066497940850811934 printStringHex = '-1D702071CBA4A1597D4DD37E95EFAC79241E'. 165331 self assert: (-2564411043271974895869785066497940850811934 storeStringBase: 29) = '-29rSRQPONMLKJIHGFEDCBA9876543210'. 165332 self assert: -2564411043271974895869785066497940850811934 storeStringHex = '-16r1D702071CBA4A1597D4DD37E95EFAC79241E'. 165333 self assert: (-205646315052919334126040428061831153388822830 printStringBase: 30) = '-TSRQPONMLKJIHGFEDCBA9876543210'. 165334 self assert: (-205646315052919334126040428061831153388822830 radix: 30) = '-TSRQPONMLKJIHGFEDCBA9876543210'. 165335 self assert: -205646315052919334126040428061831153388822830 printStringHex = '-938B4343B54B550989989D02998718FFB212E'. 165336 self assert: (-205646315052919334126040428061831153388822830 storeStringBase: 30) = '-30rTSRQPONMLKJIHGFEDCBA9876543210'. 165337 self assert: -205646315052919334126040428061831153388822830 storeStringHex = '-16r938B4343B54B550989989D02998718FFB212E'. 165338 self assert: (-17050208381689099029767742314582582184093573615 printStringBase: 31) = '-UTSRQPONMLKJIHGFEDCBA9876543210'. 165339 self assert: (-17050208381689099029767742314582582184093573615 radix: 31) = '-UTSRQPONMLKJIHGFEDCBA9876543210'. 165340 self assert: -17050208381689099029767742314582582184093573615 printStringHex = '-2FC8ECB1521BA16D24A69E976D53873E2C661EF'. 165341 self assert: (-17050208381689099029767742314582582184093573615 storeStringBase: 31) = '-31rUTSRQPONMLKJIHGFEDCBA9876543210'. 165342 self assert: -17050208381689099029767742314582582184093573615 storeStringHex = '-16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'. 165343 self assert: (-1459980823972598128486511383358617792788444579872 printStringBase: 32) = '-VUTSRQPONMLKJIHGFEDCBA9876543210'. 165344 self assert: (-1459980823972598128486511383358617792788444579872 radix: 32) = '-VUTSRQPONMLKJIHGFEDCBA9876543210'. 165345 self assert: -1459980823972598128486511383358617792788444579872 printStringHex = '-FFBBCDEB38BDAB49CA307B9AC5A928398A418820'. 165346 self assert: (-1459980823972598128486511383358617792788444579872 storeStringBase: 32) = '-32rVUTSRQPONMLKJIHGFEDCBA9876543210'. 165347 self assert: -1459980823972598128486511383358617792788444579872 storeStringHex = '-16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'. 165348 self assert: (-128983956064237823710866404905431464703849549412368 printStringBase: 33) = '-WVUTSRQPONMLKJIHGFEDCBA9876543210'. 165349 self assert: (-128983956064237823710866404905431464703849549412368 radix: 33) = '-WVUTSRQPONMLKJIHGFEDCBA9876543210'. 165350 self assert: -128983956064237823710866404905431464703849549412368 printStringHex = '-584120A0328DE272AB055A8AA003CE4A559F223810'. 165351 self assert: (-128983956064237823710866404905431464703849549412368 storeStringBase: 33) = '-33rWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165352 self assert: -128983956064237823710866404905431464703849549412368 storeStringHex = '-16r584120A0328DE272AB055A8AA003CE4A559F223810'. 165353 self assert: (-11745843093701610854378775891116314824081102660800418 printStringBase: 34) = '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165354 self assert: (-11745843093701610854378775891116314824081102660800418 radix: 34) = '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165355 self assert: -11745843093701610854378775891116314824081102660800418 printStringHex = '-1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'. 165356 self assert: (-11745843093701610854378775891116314824081102660800418 storeStringBase: 34) = '-34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165357 self assert: -11745843093701610854378775891116314824081102660800418 storeStringHex = '-16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'. 165358 self assert: (-1101553773143634726491620528194292510495517905608180485 printStringBase: 35) = '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165359 self assert: (-1101553773143634726491620528194292510495517905608180485 radix: 35) = '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165360 self assert: -1101553773143634726491620528194292510495517905608180485 printStringHex = '-B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'. 165361 self assert: (-1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) = '-35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165362 self assert: -1101553773143634726491620528194292510495517905608180485 storeStringHex = '-16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'. 165363 self assert: (-106300512100105327644605138221229898724869759421181854980 printStringBase: 36) = '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165364 self assert: (-106300512100105327644605138221229898724869759421181854980 radix: 36) = '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165365 self assert: -106300512100105327644605138221229898724869759421181854980 printStringHex = '-455D441E55A37239AB4C303189576071AF5578FFCA80504'. 165366 self assert: (-106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) = '-36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165367 self assert: -106300512100105327644605138221229898724869759421181854980 storeStringHex = '-16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.! ! 165368 165369!IntegerTest methodsFor: 'tests - printing' stamp: 'nice 2/15/2008 22:23'! 165370testNumberOfDigits 165371 165372 2 to: 32 do: [:b | 165373 1 to: 1000//b do: [:n | 165374 | bRaisedToN | 165375 bRaisedToN := b raisedTo: n. 165376 self assert: (bRaisedToN - 1 numberOfDigitsInBase: b) = n. 165377 self assert: (bRaisedToN numberOfDigitsInBase: b) = (n+1). 165378 self assert: (bRaisedToN + 1 numberOfDigitsInBase: b) = (n+1). 165379 165380 self assert: (bRaisedToN negated + 1 numberOfDigitsInBase: b) = n. 165381 self assert: (bRaisedToN negated numberOfDigitsInBase: b) = (n+1). 165382 self assert: (bRaisedToN negated - 1 numberOfDigitsInBase: b) = (n+1).]]. 165383! ! 165384 165385!IntegerTest methodsFor: 'tests - printing' stamp: 'laza 3/30/2004 11:52'! 165386testPositiveIntegerPrinting 165387 "self run: #testPositiveIntegerPrinting" 165388 165389 self assert: 0 printString = '0'. 165390 self assert: 0 printStringHex = '0'. 165391 self assert: 0 storeStringHex = '16r0'. 165392 165393 self assert: (2 printStringBase: 2) = '10'. 165394 self assert: (2 radix: 2) = '10'. 165395 self assert: 2 printStringHex = '2'. 165396 self assert: (2 storeStringBase: 2) = '2r10'. 165397 self assert: 2 storeStringHex = '16r2'. 165398 self assert: (21 printStringBase: 3) = '210'. 165399 self assert: (21 radix: 3) = '210'. 165400 self assert: 21 printStringHex = '15'. 165401 self assert: (21 storeStringBase: 3) = '3r210'. 165402 self assert: 21 storeStringHex = '16r15'. 165403 self assert: (228 printStringBase: 4) = '3210'. 165404 self assert: (228 radix: 4) = '3210'. 165405 self assert: 228 printStringHex = 'E4'. 165406 self assert: (228 storeStringBase: 4) = '4r3210'. 165407 self assert: 228 storeStringHex = '16rE4'. 165408 self assert: (2930 printStringBase: 5) = '43210'. 165409 self assert: (2930 radix: 5) = '43210'. 165410 self assert: 2930 printStringHex = 'B72'. 165411 self assert: (2930 storeStringBase: 5) = '5r43210'. 165412 self assert: 2930 storeStringHex = '16rB72'. 165413 self assert: (44790 printStringBase: 6) = '543210'. 165414 self assert: (44790 radix: 6) = '543210'. 165415 self assert: 44790 printStringHex = 'AEF6'. 165416 self assert: (44790 storeStringBase: 6) = '6r543210'. 165417 self assert: 44790 storeStringHex = '16rAEF6'. 165418 self assert: (800667 printStringBase: 7) = '6543210'. 165419 self assert: (800667 radix: 7) = '6543210'. 165420 self assert: 800667 printStringHex = 'C379B'. 165421 self assert: (800667 storeStringBase: 7) = '7r6543210'. 165422 self assert: 800667 storeStringHex = '16rC379B'. 165423 self assert: (16434824 printStringBase: 8) = '76543210'. 165424 self assert: (16434824 radix: 8) = '76543210'. 165425 self assert: 16434824 printStringHex = 'FAC688'. 165426 self assert: (16434824 storeStringBase: 8) = '8r76543210'. 165427 self assert: 16434824 storeStringHex = '16rFAC688'. 165428 self assert: (381367044 printStringBase: 9) = '876543210'. 165429 self assert: (381367044 radix: 9) = '876543210'. 165430 self assert: 381367044 printStringHex = '16BB3304'. 165431 self assert: (381367044 storeStringBase: 9) = '9r876543210'. 165432 self assert: 381367044 storeStringHex = '16r16BB3304'. 165433 self assert: (9876543210 printStringBase: 10) = '9876543210'. 165434 self assert: (9876543210 radix: 10) = '9876543210'. 165435 self assert: 9876543210 printStringHex = '24CB016EA'. 165436 self assert: (9876543210 storeStringBase: 10) = '9876543210'. 165437 self assert: 9876543210 storeStringHex = '16r24CB016EA'. 165438 self assert: (282458553905 printStringBase: 11) = 'A9876543210'. 165439 self assert: (282458553905 radix: 11) = 'A9876543210'. 165440 self assert: 282458553905 printStringHex = '41C3D77E31'. 165441 self assert: (282458553905 storeStringBase: 11) = '11rA9876543210'. 165442 self assert: 282458553905 storeStringHex = '16r41C3D77E31'. 165443 self assert: (8842413667692 printStringBase: 12) = 'BA9876543210'. 165444 self assert: (8842413667692 radix: 12) = 'BA9876543210'. 165445 self assert: 8842413667692 printStringHex = '80AC8ECF56C'. 165446 self assert: (8842413667692 storeStringBase: 12) = '12rBA9876543210'. 165447 self assert: 8842413667692 storeStringHex = '16r80AC8ECF56C'. 165448 self assert: (300771807240918 printStringBase: 13) = 'CBA9876543210'. 165449 self assert: (300771807240918 radix: 13) = 'CBA9876543210'. 165450 self assert: 300771807240918 printStringHex = '1118CE4BAA2D6'. 165451 self assert: (300771807240918 storeStringBase: 13) = '13rCBA9876543210'. 165452 self assert: 300771807240918 storeStringHex = '16r1118CE4BAA2D6'. 165453 self assert: (11046255305880158 printStringBase: 14) = 'DCBA9876543210'. 165454 self assert: (11046255305880158 radix: 14) = 'DCBA9876543210'. 165455 self assert: 11046255305880158 printStringHex = '273E82BB9AF25E'. 165456 self assert: (11046255305880158 storeStringBase: 14) = '14rDCBA9876543210'. 165457 self assert: 11046255305880158 storeStringHex = '16r273E82BB9AF25E'. 165458 self assert: (435659737878916215 printStringBase: 15) = 'EDCBA9876543210'. 165459 self assert: (435659737878916215 radix: 15) = 'EDCBA9876543210'. 165460 self assert: 435659737878916215 printStringHex = '60BC6392F366C77'. 165461 self assert: (435659737878916215 storeStringBase: 15) = '15rEDCBA9876543210'. 165462 self assert: 435659737878916215 storeStringHex = '16r60BC6392F366C77'. 165463 self assert: (18364758544493064720 printStringBase: 16) = 'FEDCBA9876543210'. 165464 self assert: (18364758544493064720 radix: 16) = 'FEDCBA9876543210'. 165465 self assert: 18364758544493064720 printStringHex = 'FEDCBA9876543210'. 165466 self assert: (18364758544493064720 storeStringBase: 16) = '16rFEDCBA9876543210'. 165467 self assert: 18364758544493064720 storeStringHex = '16rFEDCBA9876543210'. 165468 self assert: (824008854613343261192 printStringBase: 17) = 'GFEDCBA9876543210'. 165469 self assert: (824008854613343261192 radix: 17) = 'GFEDCBA9876543210'. 165470 self assert: 824008854613343261192 printStringHex = '2CAB6B877C1CD2D208'. 165471 self assert: (824008854613343261192 storeStringBase: 17) = '17rGFEDCBA9876543210'. 165472 self assert: 824008854613343261192 storeStringHex = '16r2CAB6B877C1CD2D208'. 165473 self assert: (39210261334551566857170 printStringBase: 18) = 'HGFEDCBA9876543210'. 165474 self assert: (39210261334551566857170 radix: 18) = 'HGFEDCBA9876543210'. 165475 self assert: 39210261334551566857170 printStringHex = '84D97AFCAE81415B3D2'. 165476 self assert: (39210261334551566857170 storeStringBase: 18) = '18rHGFEDCBA9876543210'. 165477 self assert: 39210261334551566857170 storeStringHex = '16r84D97AFCAE81415B3D2'. 165478 self assert: (1972313422155189164466189 printStringBase: 19) = 'IHGFEDCBA9876543210'. 165479 self assert: (1972313422155189164466189 radix: 19) = 'IHGFEDCBA9876543210'. 165480 self assert: 1972313422155189164466189 printStringHex = '1A1A75329C5C6FC00600D'. 165481 self assert: (1972313422155189164466189 storeStringBase: 19) = '19rIHGFEDCBA9876543210'. 165482 self assert: 1972313422155189164466189 storeStringHex = '16r1A1A75329C5C6FC00600D'. 165483 self assert: (104567135734072022160664820 printStringBase: 20) = 'JIHGFEDCBA9876543210'. 165484 self assert: (104567135734072022160664820 radix: 20) = 'JIHGFEDCBA9876543210'. 165485 self assert: 104567135734072022160664820 printStringHex = '567EF3C9636D242A8C68F4'. 165486 self assert: (104567135734072022160664820 storeStringBase: 20) = '20rJIHGFEDCBA9876543210'. 165487 self assert: 104567135734072022160664820 storeStringHex = '16r567EF3C9636D242A8C68F4'. 165488 self assert: (5827980550840017565077671610 printStringBase: 21) = 'KJIHGFEDCBA9876543210'. 165489 self assert: (5827980550840017565077671610 radix: 21) = 'KJIHGFEDCBA9876543210'. 165490 self assert: 5827980550840017565077671610 printStringHex = '12D4CAE2B8A09BCFDBE30EBA'. 165491 self assert: (5827980550840017565077671610 storeStringBase: 21) = '21rKJIHGFEDCBA9876543210'. 165492 self assert: 5827980550840017565077671610 storeStringHex = '16r12D4CAE2B8A09BCFDBE30EBA'. 165493 self assert: (340653664490377789692799452102 printStringBase: 22) = 'LKJIHGFEDCBA9876543210'. 165494 self assert: (340653664490377789692799452102 radix: 22) = 'LKJIHGFEDCBA9876543210'. 165495 self assert: 340653664490377789692799452102 printStringHex = '44CB61B5B47E1A5D8F88583C6'. 165496 self assert: (340653664490377789692799452102 storeStringBase: 22) = '22rLKJIHGFEDCBA9876543210'. 165497 self assert: 340653664490377789692799452102 storeStringHex = '16r44CB61B5B47E1A5D8F88583C6'. 165498 self assert: (20837326537038308910317109288851 printStringBase: 23) = 'MLKJIHGFEDCBA9876543210'. 165499 self assert: (20837326537038308910317109288851 radix: 23) = 'MLKJIHGFEDCBA9876543210'. 165500 self assert: 20837326537038308910317109288851 printStringHex = '1070108876456E0EF115B389F93'. 165501 self assert: (20837326537038308910317109288851 storeStringBase: 23) = '23rMLKJIHGFEDCBA9876543210'. 165502 self assert: 20837326537038308910317109288851 storeStringHex = '16r1070108876456E0EF115B389F93'. 165503 self assert: (1331214537196502869015340298036888 printStringBase: 24) = 'NMLKJIHGFEDCBA9876543210'. 165504 self assert: (1331214537196502869015340298036888 radix: 24) = 'NMLKJIHGFEDCBA9876543210'. 165505 self assert: 1331214537196502869015340298036888 printStringHex = '41A24A285154B026B6ED206C6698'. 165506 self assert: (1331214537196502869015340298036888 storeStringBase: 24) = '24rNMLKJIHGFEDCBA9876543210'. 165507 self assert: 1331214537196502869015340298036888 storeStringHex = '16r41A24A285154B026B6ED206C6698'. 165508 self assert: (88663644327703473714387251271141900 printStringBase: 25) = 'ONMLKJIHGFEDCBA9876543210'. 165509 self assert: (88663644327703473714387251271141900 radix: 25) = 'ONMLKJIHGFEDCBA9876543210'. 165510 self assert: 88663644327703473714387251271141900 printStringHex = '111374860A2C6CEBE5999630398A0C'. 165511 self assert: (88663644327703473714387251271141900 storeStringBase: 25) = '25rONMLKJIHGFEDCBA9876543210'. 165512 self assert: 88663644327703473714387251271141900 storeStringHex = '16r111374860A2C6CEBE5999630398A0C'. 165513 self assert: (6146269788878825859099399609538763450 printStringBase: 26) = 'PONMLKJIHGFEDCBA9876543210'. 165514 self assert: (6146269788878825859099399609538763450 radix: 26) = 'PONMLKJIHGFEDCBA9876543210'. 165515 self assert: 6146269788878825859099399609538763450 printStringHex = '49FBA7F30B0F48BD14E6A99BD8ADABA'. 165516 self assert: (6146269788878825859099399609538763450 storeStringBase: 26) = '26rPONMLKJIHGFEDCBA9876543210'. 165517 self assert: 6146269788878825859099399609538763450 storeStringHex = '16r49FBA7F30B0F48BD14E6A99BD8ADABA'. 165518 self assert: (442770531899482980347734468443677777577 printStringBase: 27) = 'QPONMLKJIHGFEDCBA9876543210'. 165519 self assert: (442770531899482980347734468443677777577 radix: 27) = 'QPONMLKJIHGFEDCBA9876543210'. 165520 self assert: 442770531899482980347734468443677777577 printStringHex = '14D1A80A997343640C1145A073731DEA9'. 165521 self assert: (442770531899482980347734468443677777577 storeStringBase: 27) = '27rQPONMLKJIHGFEDCBA9876543210'. 165522 self assert: 442770531899482980347734468443677777577 storeStringHex = '16r14D1A80A997343640C1145A073731DEA9'. 165523 self assert: (33100056003358651440264672384704297711484 printStringBase: 28) = 'RQPONMLKJIHGFEDCBA9876543210'. 165524 self assert: (33100056003358651440264672384704297711484 radix: 28) = 'RQPONMLKJIHGFEDCBA9876543210'. 165525 self assert: 33100056003358651440264672384704297711484 printStringHex = '6145B6E6DACFA25D0E936F51D25932377C'. 165526 self assert: (33100056003358651440264672384704297711484 storeStringBase: 28) = '28rRQPONMLKJIHGFEDCBA9876543210'. 165527 self assert: 33100056003358651440264672384704297711484 storeStringHex = '16r6145B6E6DACFA25D0E936F51D25932377C'. 165528 self assert: (2564411043271974895869785066497940850811934 printStringBase: 29) = 'SRQPONMLKJIHGFEDCBA9876543210'. 165529 self assert: (2564411043271974895869785066497940850811934 radix: 29) = 'SRQPONMLKJIHGFEDCBA9876543210'. 165530 self assert: 2564411043271974895869785066497940850811934 printStringHex = '1D702071CBA4A1597D4DD37E95EFAC79241E'. 165531 self assert: (2564411043271974895869785066497940850811934 storeStringBase: 29) = '29rSRQPONMLKJIHGFEDCBA9876543210'. 165532 self assert: 2564411043271974895869785066497940850811934 storeStringHex = '16r1D702071CBA4A1597D4DD37E95EFAC79241E'. 165533 self assert: (205646315052919334126040428061831153388822830 printStringBase: 30) = 'TSRQPONMLKJIHGFEDCBA9876543210'. 165534 self assert: (205646315052919334126040428061831153388822830 radix: 30) = 'TSRQPONMLKJIHGFEDCBA9876543210'. 165535 self assert: 205646315052919334126040428061831153388822830 printStringHex = '938B4343B54B550989989D02998718FFB212E'. 165536 self assert: (205646315052919334126040428061831153388822830 storeStringBase: 30) = '30rTSRQPONMLKJIHGFEDCBA9876543210'. 165537 self assert: 205646315052919334126040428061831153388822830 storeStringHex = '16r938B4343B54B550989989D02998718FFB212E'. 165538 self assert: (17050208381689099029767742314582582184093573615 printStringBase: 31) = 'UTSRQPONMLKJIHGFEDCBA9876543210'. 165539 self assert: (17050208381689099029767742314582582184093573615 radix: 31) = 'UTSRQPONMLKJIHGFEDCBA9876543210'. 165540 self assert: 17050208381689099029767742314582582184093573615 printStringHex = '2FC8ECB1521BA16D24A69E976D53873E2C661EF'. 165541 self assert: (17050208381689099029767742314582582184093573615 storeStringBase: 31) = '31rUTSRQPONMLKJIHGFEDCBA9876543210'. 165542 self assert: 17050208381689099029767742314582582184093573615 storeStringHex = '16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'. 165543 self assert: (1459980823972598128486511383358617792788444579872 printStringBase: 32) = 'VUTSRQPONMLKJIHGFEDCBA9876543210'. 165544 self assert: (1459980823972598128486511383358617792788444579872 radix: 32) = 'VUTSRQPONMLKJIHGFEDCBA9876543210'. 165545 self assert: 1459980823972598128486511383358617792788444579872 printStringHex = 'FFBBCDEB38BDAB49CA307B9AC5A928398A418820'. 165546 self assert: (1459980823972598128486511383358617792788444579872 storeStringBase: 32) = '32rVUTSRQPONMLKJIHGFEDCBA9876543210'. 165547 self assert: 1459980823972598128486511383358617792788444579872 storeStringHex = '16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'. 165548 self assert: (128983956064237823710866404905431464703849549412368 printStringBase: 33) = 'WVUTSRQPONMLKJIHGFEDCBA9876543210'. 165549 self assert: (128983956064237823710866404905431464703849549412368 radix: 33) = 'WVUTSRQPONMLKJIHGFEDCBA9876543210'. 165550 self assert: 128983956064237823710866404905431464703849549412368 printStringHex = '584120A0328DE272AB055A8AA003CE4A559F223810'. 165551 self assert: (128983956064237823710866404905431464703849549412368 storeStringBase: 33) = '33rWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165552 self assert: 128983956064237823710866404905431464703849549412368 storeStringHex = '16r584120A0328DE272AB055A8AA003CE4A559F223810'. 165553 self assert: (11745843093701610854378775891116314824081102660800418 printStringBase: 34) = 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165554 self assert: (11745843093701610854378775891116314824081102660800418 radix: 34) = 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165555 self assert: 11745843093701610854378775891116314824081102660800418 printStringHex = '1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'. 165556 self assert: (11745843093701610854378775891116314824081102660800418 storeStringBase: 34) = '34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165557 self assert: 11745843093701610854378775891116314824081102660800418 storeStringHex = '16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'. 165558 self assert: (1101553773143634726491620528194292510495517905608180485 printStringBase: 35) = 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165559 self assert: (1101553773143634726491620528194292510495517905608180485 radix: 35) = 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165560 self assert: 1101553773143634726491620528194292510495517905608180485 printStringHex = 'B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'. 165561 self assert: (1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) = '35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165562 self assert: 1101553773143634726491620528194292510495517905608180485 storeStringHex = '16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'. 165563 self assert: (106300512100105327644605138221229898724869759421181854980 printStringBase: 36) = 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165564 self assert: (106300512100105327644605138221229898724869759421181854980 radix: 36) = 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165565 self assert: 106300512100105327644605138221229898724869759421181854980 printStringHex = '455D441E55A37239AB4C303189576071AF5578FFCA80504'. 165566 self assert: (106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) = '36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. 165567 self assert: 106300512100105327644605138221229898724869759421181854980 storeStringHex = '16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.! ! 165568 165569!IntegerTest methodsFor: 'tests - printing' stamp: 'fbs 2/9/2006 08:48'! 165570testPrintOnBaseShowRadix 165571 | s | 165572 s := ReadWriteStream on: ''. 165573 123 printOn: s base: 10 showRadix: false. 165574 self assert: (s contents = '123'). 165575 165576 s := ReadWriteStream on: ''. 165577 123 printOn: s base: 10 showRadix: true. 165578 self assert: (s contents = '10r123'). 165579 165580 s := ReadWriteStream on: ''. 165581 123 printOn: s base: 8 showRadix: false. 165582 self assert: (s contents = '173'). 165583 165584 s := ReadWriteStream on: ''. 165585 123 printOn: s base: 8 showRadix: true. 165586 self assert: (s contents = '8r173').! ! 165587 165588!IntegerTest methodsFor: 'tests - printing' stamp: 'nice 2/15/2008 22:31'! 165589testPrintStringBase 165590 165591 2 to: 32 do: [:b | 165592 1 to: 1000//b do: [:n | 165593 | bRaisedToN | 165594 bRaisedToN := b raisedTo: n. 165595 self assert: (bRaisedToN - 1 printStringBase: b) = (String new: n withAll: (Character digitValue: b-1)). 165596 self assert: (bRaisedToN printStringBase: b) = ('1' , (String new: n withAll: $0)). 165597 165598 self assert: (bRaisedToN negated + 1 printStringBase: b) = ('-' , (String new: n withAll: (Character digitValue: b-1))). 165599 self assert: (bRaisedToN negated printStringBase: b) = ('-1' , (String new: n withAll: $0))]]. 165600! ! 165601 165602!IntegerTest methodsFor: 'tests - printing' stamp: 'laza 3/30/2004 09:23'! 165603testRomanPrinting 165604 self assert: 0 printStringRoman = ''. "No symbol for zero" 165605 self assert: 1 printStringRoman = 'I'. 165606 self assert: 2 printStringRoman = 'II'. 165607 self assert: 3 printStringRoman = 'III'. 165608 self assert: 4 printStringRoman = 'IV'. 165609 self assert: 5 printStringRoman = 'V'. 165610 self assert: 6 printStringRoman = 'VI'. 165611 self assert: 7 printStringRoman = 'VII'. 165612 self assert: 8 printStringRoman = 'VIII'. 165613 self assert: 9 printStringRoman = 'IX'. 165614 self assert: 10 printStringRoman = 'X'. 165615 self assert: 23 printStringRoman = 'XXIII'. 165616 self assert: 36 printStringRoman = 'XXXVI'. 165617 self assert: 49 printStringRoman = 'XLIX'. 165618 self assert: 62 printStringRoman = 'LXII'. 165619 self assert: 75 printStringRoman = 'LXXV'. 165620 self assert: 88 printStringRoman = 'LXXXVIII'. 165621 self assert: 99 printStringRoman = 'XCIX'. 165622 self assert: 100 printStringRoman = 'C'. 165623 self assert: 101 printStringRoman = 'CI'. 165624 self assert: 196 printStringRoman = 'CXCVI'. 165625 self assert: 197 printStringRoman = 'CXCVII'. 165626 self assert: 198 printStringRoman = 'CXCVIII'. 165627 self assert: 293 printStringRoman = 'CCXCIII'. 165628 self assert: 294 printStringRoman = 'CCXCIV'. 165629 self assert: 295 printStringRoman = 'CCXCV'. 165630 self assert: 390 printStringRoman = 'CCCXC'. 165631 self assert: 391 printStringRoman = 'CCCXCI'. 165632 self assert: 392 printStringRoman = 'CCCXCII'. 165633 self assert: 487 printStringRoman = 'CDLXXXVII'. 165634 self assert: 488 printStringRoman = 'CDLXXXVIII'. 165635 self assert: 489 printStringRoman = 'CDLXXXIX'. 165636 self assert: 584 printStringRoman = 'DLXXXIV'. 165637 self assert: 585 printStringRoman = 'DLXXXV'. 165638 self assert: 586 printStringRoman = 'DLXXXVI'. 165639 self assert: 681 printStringRoman = 'DCLXXXI'. 165640 self assert: 682 printStringRoman = 'DCLXXXII'. 165641 self assert: 683 printStringRoman = 'DCLXXXIII'. 165642 self assert: 778 printStringRoman = 'DCCLXXVIII'. 165643 self assert: 779 printStringRoman = 'DCCLXXIX'. 165644 self assert: 780 printStringRoman = 'DCCLXXX'. 165645 self assert: 875 printStringRoman = 'DCCCLXXV'. 165646 self assert: 876 printStringRoman = 'DCCCLXXVI'. 165647 self assert: 877 printStringRoman = 'DCCCLXXVII'. 165648 self assert: 972 printStringRoman = 'CMLXXII'. 165649 self assert: 973 printStringRoman = 'CMLXXIII'. 165650 self assert: 974 printStringRoman = 'CMLXXIV'. 165651 self assert: 1069 printStringRoman = 'MLXIX'. 165652 self assert: 1070 printStringRoman = 'MLXX'. 165653 self assert: 1071 printStringRoman = 'MLXXI'. 165654 self assert: 1166 printStringRoman = 'MCLXVI'. 165655 self assert: 1167 printStringRoman = 'MCLXVII'. 165656 self assert: 1168 printStringRoman = 'MCLXVIII'. 165657 self assert: 1263 printStringRoman = 'MCCLXIII'. 165658 self assert: 1264 printStringRoman = 'MCCLXIV'. 165659 self assert: 1265 printStringRoman = 'MCCLXV'. 165660 self assert: 1360 printStringRoman = 'MCCCLX'. 165661 self assert: 1361 printStringRoman = 'MCCCLXI'. 165662 self assert: 1362 printStringRoman = 'MCCCLXII'. 165663 self assert: 1457 printStringRoman = 'MCDLVII'. 165664 self assert: 1458 printStringRoman = 'MCDLVIII'. 165665 self assert: 1459 printStringRoman = 'MCDLIX'. 165666 self assert: 1554 printStringRoman = 'MDLIV'. 165667 self assert: 1555 printStringRoman = 'MDLV'. 165668 self assert: 1556 printStringRoman = 'MDLVI'. 165669 self assert: 1651 printStringRoman = 'MDCLI'. 165670 self assert: 1652 printStringRoman = 'MDCLII'. 165671 self assert: 1653 printStringRoman = 'MDCLIII'. 165672 self assert: 1748 printStringRoman = 'MDCCXLVIII'. 165673 self assert: 1749 printStringRoman = 'MDCCXLIX'. 165674 self assert: 1750 printStringRoman = 'MDCCL'. 165675 self assert: 1845 printStringRoman = 'MDCCCXLV'. 165676 self assert: 1846 printStringRoman = 'MDCCCXLVI'. 165677 self assert: 1847 printStringRoman = 'MDCCCXLVII'. 165678 self assert: 1942 printStringRoman = 'MCMXLII'. 165679 self assert: 1943 printStringRoman = 'MCMXLIII'. 165680 self assert: 1944 printStringRoman = 'MCMXLIV'. 165681 self assert: 2004 printStringRoman = 'MMIV'. 165682 165683 self assert: -1 printStringRoman = '-I'. 165684 self assert: -2 printStringRoman = '-II'. 165685 self assert: -3 printStringRoman = '-III'. 165686 self assert: -4 printStringRoman = '-IV'. 165687 self assert: -5 printStringRoman = '-V'. 165688 self assert: -6 printStringRoman = '-VI'. 165689 self assert: -7 printStringRoman = '-VII'. 165690 self assert: -8 printStringRoman = '-VIII'. 165691 self assert: -9 printStringRoman = '-IX'. 165692 self assert: -10 printStringRoman = '-X'. 165693! ! 165694Object subclass: #InternetConfiguration 165695 instanceVariableNames: '' 165696 classVariableNames: '' 165697 poolDictionaries: '' 165698 category: 'Network-Kernel'! 165699 165700"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 165701 165702InternetConfiguration class 165703 instanceVariableNames: ''! 165704 165705!InternetConfiguration class methodsFor: 'initialization' stamp: 'md 2/24/2006 15:22'! 165706initialize 165707 "self initialize" 165708 Smalltalk addToStartUpList: self. 165709 Smalltalk addToShutDownList: self.! ! 165710 165711 165712!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:05'! 165713getArchiePreferred 165714 "Return the preferred Archie server" 165715 "InternetConfiguration getArchiePreferred" 165716 165717 ^self primitiveGetStringKeyedBy: 'ArchiePreferred' 165718! ! 165719 165720!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:31'! 165721getDownloadPath 165722 "Return the download path" 165723 "InternetConfiguration getDownloadPath" 165724 165725 ^self primitiveGetStringKeyedBy: 'DownLoadPath' 165726! ! 165727 165728!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:07'! 165729getEmail 165730 "Return the email address of user" 165731 "InternetConfiguration getEmail" 165732 165733 ^self primitiveGetStringKeyedBy: 'Email' 165734! ! 165735 165736!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:08'! 165737getFTPHost 165738 "Return the FTPHost" 165739 "InternetConfiguration getFTPHost" 165740 165741 ^self primitiveGetStringKeyedBy: 'FTPHost' 165742! ! 165743 165744!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:09'! 165745getFTPProxyAccount 165746 "Return the second level FTP proxy authorisation" 165747 "InternetConfiguration getFTPProxyAccount" 165748 165749 ^self primitiveGetStringKeyedBy: 'FTPProxyAccount' 165750! ! 165751 165752!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 20:00'! 165753getFTPProxyHost 165754 "Return the FTP proxy host" 165755 "InternetConfiguration getFTPProxyHost" 165756 165757 ^self primitiveGetStringKeyedBy: 'FTPProxyHost' 165758! ! 165759 165760!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/3/2001 14:02'! 165761getFTPProxyPassword 165762 "Return the FTP proxy password" 165763 "InternetConfiguration getFTPProxyPassword" 165764 165765 ^self primitiveGetStringKeyedBy: 'FTPProxyPassword' 165766! ! 165767 165768!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:10'! 165769getFTPProxyUser 165770 "Return the first level FTP proxy authorisation" 165771 "InternetConfiguration getFTPProxyUser" 165772 165773 ^self primitiveGetStringKeyedBy: 'FTPProxyUser' 165774! ! 165775 165776!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:10'! 165777getFingerHost 165778 "Return the default finger server" 165779 "InternetConfiguration getFingerHost" 165780 165781 ^self primitiveGetStringKeyedBy: 'FingerHost' 165782! ! 165783 165784!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:11'! 165785getGopherHost 165786 "Return the default Gopher server" 165787 "InternetConfiguration getGopherHost" 165788 165789 ^self primitiveGetStringKeyedBy: 'GopherHost' 165790! ! 165791 165792!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:11'! 165793getGopherProxy 165794 "Return the Gopher proxy" 165795 "InternetConfiguration getGopherProxy" 165796 165797 ^self primitiveGetStringKeyedBy: 'GopherProxy' 165798! ! 165799 165800!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:14'! 165801getHTTPProxyHost 165802 "Return the http proxy for this client." 165803 "InternetConfiguration getHTTPProxyHost" 165804 165805 ^self primitiveGetStringKeyedBy: 'HTTPProxyHost' 165806! ! 165807 165808!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:14'! 165809getIRCHost 165810 "Return the Internet Relay Chat server" 165811 "InternetConfiguration getIRCHost" 165812 165813 ^self primitiveGetStringKeyedBy: 'IRCHost' 165814! ! 165815 165816!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:14'! 165817getLDAPSearchbase 165818 "Return the LDAP thing" 165819 "InternetConfiguration getLDAPSearchbase" 165820 165821 ^self primitiveGetStringKeyedBy: 'LDAPSearchbase' 165822! ! 165823 165824!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:15'! 165825getLDAPServer 165826 "Return the LDAP server" 165827 "InternetConfiguration getLDAPServer" 165828 165829 ^self primitiveGetStringKeyedBy: 'LDAPServer' 165830! ! 165831 165832!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/5/2001 23:45'! 165833getMacintoshFileTypeAndCreatorFrom: aFileName 165834 "Return the application type and application signature for the file 165835 for the macintosh file system based on the file ending, the file does not need to exist 165836 failure to find a signature based on the file ending, or because of primitive failure turns nil" 165837 "InternetConfiguration getMacintoshFileTypeAndCreatorFrom: 'test.jpg'" 165838 | string | 165839 165840 string := self primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName. 165841 string = '********' ifTrue: [^nil]. 165842 ^Array with: (string first: 4) with: (string last: 4) 165843! ! 165844 165845!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 20:07'! 165846getMailAccount 165847 "Return the mail account user@host.domain" 165848 "InternetConfiguration getMailAccount" 165849 165850 ^self primitiveGetStringKeyedBy: 'MailAccount' 165851! ! 165852 165853!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/3/2001 14:31'! 165854getMailPassword 165855 "Return the mail account Password " 165856 "InternetConfiguration getMailPassword " 165857 165858 ^self primitiveGetStringKeyedBy: 'MailPassword' 165859! ! 165860 165861!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:16'! 165862getNNTPHost 165863 "Return the NNTP server" 165864 "InternetConfiguration getNNTPHost" 165865 165866 ^self primitiveGetStringKeyedBy: 'NNTPHost' 165867! ! 165868 165869!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:17'! 165870getNTPHost 165871 "Return the Network Time Protocol (NTP)" 165872 "InternetConfiguration getNTPHost" 165873 165874 ^self primitiveGetStringKeyedBy: 'NTPHost' 165875! ! 165876 165877!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/3/2001 14:04'! 165878getNewsAuthPassword 165879 "Return the Password for the authorised news servers" 165880 "InternetConfiguration getNewsAuthPassword" 165881 165882 ^self primitiveGetStringKeyedBy: 'NewsAuthPassword' 165883! ! 165884 165885!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:17'! 165886getNewsAuthUsername 165887 "Return the user name for authorised news servers" 165888 "InternetConfiguration getNewsAuthUsername" 165889 165890 ^self primitiveGetStringKeyedBy: 'NewsAuthUsername' 165891! ! 165892 165893!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/5/2001 10:54'! 165894getNoProxyDomains 165895 "Return a comma seperated string of domains not to proxy" 165896 "InternetConfiguration getNoProxyDomains" 165897 165898 ^self primitiveGetStringKeyedBy: 'NoProxyDomains' 165899! ! 165900 165901!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:36'! 165902getOrganization 165903 "Return the Organization" 165904 "InternetConfiguration getOrganization" 165905 165906 ^self primitiveGetStringKeyedBy: 'Organization' 165907! ! 165908 165909!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:37'! 165910getPhHost 165911 "Return the PhHost server" 165912 "InternetConfiguration getPhHost" 165913 165914 ^self primitiveGetStringKeyedBy: 'PhHost' 165915! ! 165916 165917!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 20:04'! 165918getRealName 165919 "Return the RealName" 165920 "InternetConfiguration getRealName" 165921 165922 ^self primitiveGetStringKeyedBy: 'RealName' 165923! ! 165924 165925!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:19'! 165926getSMTPHost 165927 "Return the SMTP server" 165928 "InternetConfiguration getSMTPHost" 165929 165930 ^self primitiveGetStringKeyedBy: 'SMTPHost' 165931! ! 165932 165933!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:19'! 165934getSocksHost 165935 "Return the Socks server" 165936 "InternetConfiguration getSocksHost" 165937 165938 ^self primitiveGetStringKeyedBy: 'SocksHost' 165939! ! 165940 165941!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:20'! 165942getTelnetHost 165943 "Return the TelnetHost server" 165944 "InternetConfiguration getTelnetHost" 165945 165946 ^self primitiveGetStringKeyedBy: 'TelnetHost' 165947! ! 165948 165949!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:44'! 165950getWAISGateway 165951 "Return the wais gateway" 165952 "InternetConfiguration getWAISGateway" 165953 165954 ^self primitiveGetStringKeyedBy: 'WAISGateway' 165955! ! 165956 165957!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:44'! 165958getWWWHomePage 165959 "Return the WWW home page url" 165960 "InternetConfiguration getWWWHomePage" 165961 165962 ^self primitiveGetStringKeyedBy: 'WWWHomePage' 165963! ! 165964 165965!InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:23'! 165966getWhoisHost 165967 "Return the WhoisHost server" 165968 "InternetConfiguration getWhoisHost" 165969 165970 ^self primitiveGetStringKeyedBy: 'WhoisHost' 165971! ! 165972 165973 165974!InternetConfiguration class methodsFor: 'system primitives' stamp: 'JMM 10/5/2001 23:44'! 165975primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName 165976 <primitive: 'primitiveGetMacintoshFileTypeAndCreatorFrom' module: 'InternetConfigPlugin'> 165977 ^'********' copy ! ! 165978 165979!InternetConfiguration class methodsFor: 'system primitives' stamp: 'JMM 9/26/2001 16:31'! 165980primitiveGetStringKeyedBy: aKey 165981 <primitive: 'primitiveGetStringKeyedBy' module: 'InternetConfigPlugin'> 165982 ^String new. 165983! ! 165984 165985 165986!InternetConfiguration class methodsFor: 'system startup' stamp: 'md 2/24/2006 15:22'! 165987shutDown 165988 (SmalltalkImage current platformName = 'Mac OS') ifTrue: [ 165989 HTTPSocket stopUsingProxyServer] 165990 165991! ! 165992 165993!InternetConfiguration class methodsFor: 'system startup' stamp: 'md 3/5/2006 16:25'! 165994startUp 165995 (SmalltalkImage current platformName = 'Mac OS') ifTrue: [ 165996 self useHTTPProxy ifTrue: [ 165997 (self getHTTPProxyHost findTokens: ':') ifNotEmpty: [:p | 165998 HTTPSocket useProxyServerNamed: p first port: p second asInteger]]]! ! 165999 166000 166001!InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 10/5/2001 11:23'! 166002useFTPProxy 166003 "Return true if UseFTPProxy" 166004 "InternetConfiguration useFTPProxy" 166005 166006 ^(self primitiveGetStringKeyedBy: 'UseFTPProxy') = '1' 166007! ! 166008 166009!InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 10/5/2001 11:23'! 166010useGopherProxy 166011 "Return true if UseGopherProxy" 166012 "InternetConfiguration useGopherProxy" 166013 166014 ^(self primitiveGetStringKeyedBy: 'UseGopherProxy') = '1' 166015! ! 166016 166017!InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 9/26/2001 19:41'! 166018useHTTPProxy 166019 "Return true if UseHTTPProxy" 166020 "InternetConfiguration useHTTPProxy" 166021 166022 ^(self primitiveGetStringKeyedBy: 'UseHTTPProxy') = '1' 166023! ! 166024 166025!InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 9/26/2001 19:42'! 166026usePassiveFTP 166027 "Return true if UsePassiveFTP" 166028 "InternetConfiguration usePassiveFTP" 166029 166030 ^(self primitiveGetStringKeyedBy: 'UsePassiveFTP') = '1' 166031! ! 166032 166033!InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 10/5/2001 11:23'! 166034useSocks 166035 "Return true if UseSocks" 166036 "InternetConfiguration useSocks" 166037 166038 ^(self primitiveGetStringKeyedBy: 'UseSocks') = '1' 166039! ! 166040GradientFillStyle subclass: #InterpolatedGradientFillStyle 166041 instanceVariableNames: '' 166042 classVariableNames: '' 166043 poolDictionaries: '' 166044 category: 'Polymorph-Widgets-FillStyles'! 166045!InterpolatedGradientFillStyle commentStamp: 'gvc 5/18/2007 12:49' prior: 0! 166046Gradient fill style that uses proper alpha-aware interpolation.! 166047 166048 166049!InterpolatedGradientFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 12:49'! 166050computePixelRampOfSize: length 166051 "Compute the pixel ramp in the receiver." 166052 166053 | bits lastColor lastIndex nextIndex nextColor distance theta ramp step lastWord nextWord | 166054 ramp := colorRamp asSortedCollection:[:a1 :a2| a1 key < a2 key]. 166055 bits := Bitmap new: length. 166056 lastColor := ramp first value. 166057 lastWord := lastColor pixelWord32. 166058 lastIndex := 0. 166059 ramp do:[:assoc| 166060 nextIndex := (assoc key * length) rounded. 166061 nextColor := assoc value. 166062 nextWord := nextColor pixelWord32. 166063 distance := nextIndex - lastIndex. 166064 distance = 0 ifTrue: [distance := 1]. 166065 step := 1.0 / distance. 166066 theta := 0.0. 166067 lastIndex+1 to: nextIndex do: [:i| 166068 theta := theta + step. 166069 bits at: i put: (self interpolatedAlphaMix: theta of: lastWord and: nextWord)]. 166070 lastIndex := nextIndex. 166071 lastColor := nextColor. 166072 lastWord := nextWord]. 166073 lastIndex+1 to: length do: [:i| bits at: i put: lastWord]. 166074 ^bits! ! 166075 166076!InterpolatedGradientFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 12:48'! 166077interpolatedAlphaMix: ratio of: rgba1 and: rgba2 166078 "Answer a proper interpolated value between two RGBA color words. 166079 Theta is 0..1.." 166080 166081 | a1 a2 ra ira rgb1 rgb2 alpha br1 br2 bg1 bg2 bb1 bb2 result | 166082 a1 := rgba1 bitShift: -24. a2 := rgba2 bitShift: -24. 166083 alpha := ratio * (a2 - a1) + a1. 166084 ra := ratio * alpha. 166085 ira := (1.0 - ratio) * alpha. 166086 rgb1 := rgba1 bitAnd: 16rFFFFFF. rgb2 := rgba2 bitAnd: 16rFFFFFF. 166087 br1 := (rgb1 bitAnd: 255). br2 := (rgb2 bitAnd: 255). 166088 bg1 := ((rgb1 bitShift: -8) bitAnd: 255). bg2 := ((rgb2 bitShift: -8) bitAnd: 255). 166089 bb1 := ((rgb1 bitShift: -16) bitAnd: 255). bb2 := ((rgb2 bitShift: -16) bitAnd: 255). 166090 result := (ra * br2 + (ira * br1)) rounded // 255. 166091 result := result bitOr: ((ra * bg2 + (ira * bg1)) rounded // 255 bitShift: 8). 166092 result := result bitOr: ((ra * bb2 + (ira * bb1)) rounded // 255 bitShift: 16). 166093 ^result bitOr: (alpha rounded bitShift: 24)! ! 166094SequenceableCollection subclass: #Interval 166095 instanceVariableNames: 'start stop step' 166096 classVariableNames: '' 166097 poolDictionaries: '' 166098 category: 'Collections-Sequenceable'! 166099!Interval commentStamp: '<historical>' prior: 0! 166100I represent a finite arithmetic progression.! 166101 166102 166103!Interval methodsFor: 'accessing'! 166104at: anInteger 166105 "Answer the anInteger'th element." 166106 166107 (anInteger >= 1 and: [anInteger <= self size]) 166108 ifTrue: [^start + (step * (anInteger - 1))] 166109 ifFalse: [self errorSubscriptBounds: anInteger]! ! 166110 166111!Interval methodsFor: 'accessing'! 166112at: anInteger put: anObject 166113 "Storing into an Interval is not allowed." 166114 166115 self error: 'you can not store into an interval'! ! 166116 166117!Interval methodsFor: 'accessing' stamp: 'stp 8/19/2000 23:52'! 166118extent 166119 "Answer the max - min of the receiver interval." 166120 "(10 to: 50) extent" 166121 166122 ^stop - start! ! 166123 166124!Interval methodsFor: 'accessing'! 166125first 166126 "Refer to the comment in SequenceableCollection|first." 166127 166128 ^start! ! 166129 166130!Interval methodsFor: 'accessing'! 166131increment 166132 "Answer the receiver's interval increment." 166133 166134 ^step! ! 166135 166136!Interval methodsFor: 'accessing' stamp: 'nice 2/3/2008 21:18'! 166137indexOf: anElement startingAt: startIndex ifAbsent: exceptionBlock 166138 "startIndex is an positive integer, the collection index where the search is started." 166139 "during the computation of val , floats are only used when the receiver contains floats" 166140 166141 | index val | 166142 (self rangeIncludes: anElement) 166143 ifFalse: [^ exceptionBlock value]. 166144 val := anElement - self first / self increment. 166145 val isFloat 166146 ifTrue: [(val - val rounded) abs * 100000000 < 1 166147 ifTrue: [index := val rounded + 1] 166148 ifFalse: [^ exceptionBlock value]] 166149 ifFalse: [val isInteger 166150 ifTrue: [index := val + 1] 166151 ifFalse: [^ exceptionBlock value]]. 166152 "finally, the value of startIndex comes into play:" 166153 ^ index < startIndex 166154 ifTrue: [exceptionBlock value] 166155 ifFalse: [index]! ! 166156 166157!Interval methodsFor: 'accessing'! 166158last 166159 "Refer to the comment in SequenceableCollection|last." 166160 166161 ^stop - (stop - start \\ step)! ! 166162 166163!Interval methodsFor: 'accessing' stamp: 'di 12/6/1999 11:00'! 166164rangeIncludes: aNumber 166165 "Return true if the number lies in the interval between start and stop." 166166 166167 step >= 0 166168 ifTrue: [^ aNumber between: start and: stop] 166169 ifFalse: [^ aNumber between: stop and: start] 166170! ! 166171 166172!Interval methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:38'! 166173size 166174 "Answer how many elements the receiver contains." 166175 166176 step < 0 166177 ifTrue: [start < stop 166178 ifTrue: [^ 0] 166179 ifFalse: [^ stop - start // step + 1]] 166180 ifFalse: [stop < start 166181 ifTrue: [^ 0] 166182 ifFalse: [^ stop - start // step + 1]]! ! 166183 166184 166185!Interval methodsFor: 'adding'! 166186add: newObject 166187 "Adding to an Interval is not allowed." 166188 166189 self shouldNotImplement! ! 166190 166191 166192!Interval methodsFor: 'arithmetic' stamp: 'ajh 3/13/2003 15:45'! 166193+ number 166194 166195 ^ start + number to: stop + number by: step! ! 166196 166197!Interval methodsFor: 'arithmetic' stamp: 'ajh 3/13/2003 15:46'! 166198- number 166199 166200 ^ start - number to: stop - number by: step! ! 166201 166202 166203!Interval methodsFor: 'comparing' stamp: 'rhi 8/14/2003 10:08'! 166204= anObject 166205 166206 ^ self == anObject 166207 ifTrue: [true] 166208 ifFalse: [anObject isInterval 166209 ifTrue: [start = anObject first 166210 and: [step = anObject increment 166211 and: [self last = anObject last]]] 166212 ifFalse: [super = anObject]]! ! 166213 166214!Interval methodsFor: 'comparing'! 166215hash 166216 "Hash is reimplemented because = is implemented." 166217 166218 ^(((start hash bitShift: 2) 166219 bitOr: stop hash) 166220 bitShift: 1) 166221 bitOr: self size! ! 166222 166223 166224!Interval methodsFor: 'copying'! 166225copy 166226 "Return a copy of me. Override the superclass because my species is 166227 Array and copy, as inherited from SequenceableCollection, uses 166228 copyFrom:to:, which creates a new object of my species." 166229 166230 ^self shallowCopy! ! 166231 166232!Interval methodsFor: 'copying' stamp: 'sma 3/3/2000 13:18'! 166233shallowCopy 166234 "Without this method, #copy would return an array instead of a new interval. 166235 The whole problem is burried in the class hierarchy and every fix will worsen 166236 the problem, so once the whole issue is resolved one should come back to this 166237 method fix it." 166238 166239 ^ self class from: start to: stop by: step! ! 166240 166241 166242!Interval methodsFor: 'enumerating'! 166243collect: aBlock 166244 | nextValue result | 166245 result := self species new: self size. 166246 nextValue := start. 166247 1 to: result size do: 166248 [:i | 166249 result at: i put: (aBlock value: nextValue). 166250 nextValue := nextValue + step]. 166251 ^ result! ! 166252 166253!Interval methodsFor: 'enumerating' stamp: 'nice 4/30/2007 19:00'! 166254do: aBlock 166255 "Evaluate aBlock for each value of the interval. 166256 Implementation note: instead of repeatedly incrementing the value 166257 aValue := aValue + step. 166258 until stop is reached, 166259 We prefer to recompute value from start 166260 aValue := aValue + (index * step). 166261 This is better for floating points, while not degrading Integer and 166262 Fraction case too much. 166263 Moreover, this is consistent with methods #at: and #size" 166264 166265 | aValue index size | 166266 index := 0. 166267 size := self size. 166268 [index < size] 166269 whileTrue: [aValue := start + (index * step). 166270 index := index + 1. 166271 aBlock value: aValue]! ! 166272 166273!Interval methodsFor: 'enumerating' stamp: 'dtl 5/31/2003 16:45'! 166274permutationsDo: aBlock 166275 "Repeatly value aBlock with a single copy of the receiver. Reorder the copy 166276 so that aBlock is presented all (self size factorial) possible permutations." 166277 "(1 to: 4) permutationsDo: [:each | Transcript cr; show: each printString]" 166278 166279 self asArray permutationsDo: aBlock 166280! ! 166281 166282!Interval methodsFor: 'enumerating' stamp: 'nice 4/30/2007 18:28'! 166283reverseDo: aBlock 166284 "Evaluate aBlock for each element of my interval, in reverse order. 166285 Implementation notes: see do: for an explanation on loop detail" 166286 166287 | aValue index | 166288 index := self size. 166289 [index > 0] 166290 whileTrue: [ 166291 index := index - 1. 166292 aValue := start + (index * step). 166293 aBlock value: aValue]! ! 166294 166295 166296!Interval methodsFor: 'printing' stamp: 'sma 6/1/2000 09:50'! 166297printOn: aStream 166298 aStream nextPut: $(; 166299 print: start; 166300 nextPutAll: ' to: '; 166301 print: stop. 166302 step ~= 1 ifTrue: [aStream nextPutAll: ' by: '; print: step]. 166303 aStream nextPut: $)! ! 166304 166305!Interval methodsFor: 'printing'! 166306storeOn: aStream 166307 "This is possible because we know numbers store and print the same." 166308 166309 self printOn: aStream! ! 166310 166311 166312!Interval methodsFor: 'removing'! 166313remove: newObject 166314 "Removing from an Interval is not allowed." 166315 166316 self error: 'elements cannot be removed from an Interval'! ! 166317 166318 166319!Interval methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 22:03'! 166320isSelfEvaluating 166321 ^ self class == Interval! ! 166322 166323 166324!Interval methodsFor: 'testing' stamp: 'rhi 8/12/2003 09:52'! 166325isInterval 166326 166327 ^ true! ! 166328 166329 166330!Interval methodsFor: 'private'! 166331setFrom: startInteger to: stopInteger by: stepInteger 166332 166333 start := startInteger. 166334 stop := stopInteger. 166335 step := stepInteger! ! 166336 166337!Interval methodsFor: 'private'! 166338species 166339 166340 ^Array! ! 166341 166342"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 166343 166344Interval class 166345 instanceVariableNames: ''! 166346 166347!Interval class methodsFor: 'instance creation'! 166348from: startInteger to: stopInteger 166349 "Answer an instance of me, starting at startNumber, ending at 166350 stopNumber, and with an interval increment of 1." 166351 166352 ^self new 166353 setFrom: startInteger 166354 to: stopInteger 166355 by: 1! ! 166356 166357!Interval class methodsFor: 'instance creation'! 166358from: startInteger to: stopInteger by: stepInteger 166359 "Answer an instance of me, starting at startNumber, ending at 166360 stopNumber, and with an interval increment of stepNumber." 166361 166362 ^self new 166363 setFrom: startInteger 166364 to: stopInteger 166365 by: stepInteger! ! 166366 166367!Interval class methodsFor: 'instance creation'! 166368new 166369 "Primitive. Create and answer with a new instance of the receiver 166370 (a class) with no indexable fields. Fail if the class is indexable. Override 166371 SequenceableCollection new. Essential. See Object documentation 166372 whatIsAPrimitive." 166373 166374 <primitive: 70> 166375 self isVariable ifTrue: [ ^ self new: 0 ]. 166376 "space must be low" 166377 Smalltalk signalLowSpace. 166378 ^ self new "retry if user proceeds" 166379! ! 166380 166381!Interval class methodsFor: 'instance creation' stamp: 'nice 3/27/2008 00:17'! 166382newFrom: aCollection 166383 "Answer an instance of me containing the same elements as aCollection." 166384 166385 | newInterval n | 166386 166387 (n := aCollection size) <= 1 ifTrue: [ 166388 n = 0 ifTrue: [^self from: 1 to: 0]. 166389 ^self from: aCollection first to: aCollection last]. 166390 newInterval := self from: aCollection first to: aCollection last 166391 by: (aCollection last - aCollection first) // (n - 1). 166392 aCollection ~= newInterval 166393 ifTrue: [ 166394 "Give a second chance, because progression might be arithmetic, but = answer false" 166395 (newInterval hasEqualElements: aCollection) ifFalse: [ 166396 self error: 'The argument is not an arithmetic progression']]. 166397 ^newInterval 166398 166399" Interval newFrom: {1. 2. 3} 166400 {33. 5. -23} as: Interval 166401 {33. 5. -22} as: Interval (an error) 166402 (-4 to: -12 by: -1) as: Interval 166403 #(2 4 6) asByteArray as: Interval. 166404"! ! 166405CollectionRootTest subclass: #IntervalTest 166406 uses: TCloneTest + TIncludesWithIdentityCheckTest + TSequencedElementAccessTest + TIterateSequencedReadableTest + TSequencedConcatenationTest + TSubCollectionAccess + TAsStringCommaAndDelimiterSequenceableTest + TIndexAccess + TPrintOnSequencedTest + TConvertTest + TCopySequenceableWithReplacement - {#testCopyReplaceAllWithManyOccurence. #collectionWith2TimeSubcollection} + TCopySequenceableWithOrWithoutSpecificElements + TCopySequenceableSameContents - {#testShuffled} + TCopyPartOfSequenceable - {#testCopyEmptyMethod} + TCopyTest + TBeginsEndsWith + TConvertAsSortedTest + TSequencedStructuralEqualityTest + TOccurrencesTest 166407 instanceVariableNames: 'empty nonEmpty one elementIn elementNotIn subCollectionNotIn collectionOfFloat anotherCollection nonEmpty1Element subCollection collectionWithSubCollection subCollectionInNonEmpty collectionWithoutNil result' 166408 classVariableNames: '' 166409 poolDictionaries: '' 166410 category: 'CollectionsTests-Sequenceable'! 166411 166412!IntervalTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 17:21'! 166413accessCollection 166414 ^ -2 to: 14 by: 4! ! 166415 166416!IntervalTest methodsFor: 'requirements' stamp: 'stephane.ducasse 11/21/2008 15:39'! 166417anotherElementNotIn 166418 ^ 42! ! 166419 166420!IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:55'! 166421collection 166422 ^ nonEmpty! ! 166423 166424!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 16:36'! 166425collectionClass 166426 166427 ^ Interval! ! 166428 166429!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:51'! 166430collectionInForIncluding 166431 ^ nonEmpty copyWithout: (self nonEmpty last).! ! 166432 166433!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:15'! 166434collectionMoreThan1NoDuplicates 166435 " return a collection of size 5 without equal elements" 166436 ^ nonEmpty ! ! 166437 166438!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:35'! 166439collectionNotIncluded 166440 ^ (nonEmpty last + 1) to: (nonEmpty last +5)! ! 166441 166442!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:10'! 166443collectionOfFloat 166444 ^collectionOfFloat ! ! 166445 166446!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 14:44'! 166447collectionWith1TimeSubcollection 166448 ^ collectionWithSubCollection ! ! 166449 166450!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! 166451collectionWithCopyNonIdentical 166452 " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" 166453 ^ collectionOfFloat! ! 166454 166455!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:32'! 166456collectionWithElementsToRemove 166457 166458 ^ subCollectionInNonEmpty .! ! 166459 166460!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:25'! 166461collectionWithSortableElements 166462" return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" 166463 ^ self nonEmpty ! ! 166464 166465!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 15:39'! 166466collectionWithoutEqualElements 166467 ^ nonEmpty ! ! 166468 166469!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:13'! 166470collectionWithoutEqualsElements 166471 ^ nonEmpty ! ! 166472 166473!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:28'! 166474collectionWithoutNilElements 166475" return a collection that doesn't includes a nil element and that doesn't includes equal elements'" 166476 ^ collectionWithoutNil ! ! 166477 166478!IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:59'! 166479doWithoutNumber 166480 166481 ^ 6! ! 166482 166483!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:22'! 166484elementInCollectionOfFloat 166485 ^ collectionOfFloat anyOne! ! 166486 166487!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:40'! 166488elementInForElementAccessing 166489" return an element inculded in 'accessCollection '" 166490 ^ self accessCollection anyOne! ! 166491 166492!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:47'! 166493elementInForIncludesTest 166494 166495 ^ elementIn ! ! 166496 166497!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 15:03'! 166498elementInForIndexAccess 166499 ^ self accessCollection anyOne! ! 166500 166501!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:48'! 166502elementInForIndexAccessing 166503 166504 ^ elementIn ! ! 166505 166506!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:48'! 166507elementNotIn 166508 ^elementNotIn! ! 166509 166510!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:43'! 166511elementNotInForElementAccessing 166512" return an element not included in 'accessCollection' " 166513 ^ elementNotIn ! ! 166514 166515!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:48'! 166516elementNotInForIndexAccessing 166517 166518 ^elementNotIn ! ! 166519 166520!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 11:53'! 166521elementNotInForOccurrences 166522 ^ 9! ! 166523 166524!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:27'! 166525elementToAdd 166526 ^ elementNotIn ! ! 166527 166528!IntervalTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/5/2008 13:08'! 166529empty 166530 166531 ^ empty 166532! ! 166533 166534!IntervalTest methodsFor: 'requirements' stamp: 'marcus.denker 2/20/2009 16:30'! 166535expectedElementByDetect 166536 "Returns the first even element of #collection" 166537 ^ -2 166538 166539 ! ! 166540 166541!IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 19:01'! 166542expectedSizeAfterReject 166543 "Number of even elements in #collection" 166544 ^ 3! ! 166545 166546!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:55'! 166547firstCollection 166548 ^ nonEmpty.! ! 166549 166550!IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:57'! 166551firstEven 166552 "Returns the first even number of #collection" 166553 ^ -2! ! 166554 166555!IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:58'! 166556firstOdd 166557 "Returns the first odd number of #collection" 166558 ^ -5! ! 166559 166560!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:14'! 166561indexInForCollectionWithoutDuplicates 166562 ^ 2.! ! 166563 166564!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:02'! 166565indexInNonEmpty 166566 ^2.! ! 166567 166568!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:04'! 166569integerCollection 166570 ^ nonEmpty ! ! 166571 166572!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:31'! 166573integerCollectionWithoutEqualElements 166574 ^ 1 to: 23.! ! 166575 166576!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:51'! 166577moreThan3Elements 166578 " return a collection including atLeast 3 elements" 166579 ^ nonEmpty ! ! 166580 166581!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:51'! 166582moreThan4Elements 166583 166584" return a collection including at leat 4 elements" 166585 ^ nonEmpty ! ! 166586 166587!IntervalTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/5/2008 13:08'! 166588nonEmpty 166589 166590 ^ nonEmpty! ! 166591 166592!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 15:00'! 166593nonEmpty1Element 166594 166595 ^ nonEmpty1Element ! ! 166596 166597!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:46'! 166598nonEmptyMoreThan1Element 166599 ^nonEmpty .! ! 166600 166601!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 14:44'! 166602oldSubCollection 166603 ^ subCollection ! ! 166604 166605!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 14:45'! 166606replacementCollection 166607 ^ 5 to: 7.! ! 166608 166609!IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:57'! 166610result 166611 ^ {SmallInteger . SmallInteger . SmallInteger . SmallInteger . SmallInteger . SmallInteger}! ! 166612 166613!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:27'! 166614resultForCollectElementsClass 166615" return the retsult expected by collecting the class of each element of collectionWithoutNilElements" 166616 ^ result ! ! 166617 166618!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:56'! 166619secondCollection 166620 ^anotherCollection ! ! 166621 166622!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:07'! 166623sizeCollection 166624 "Answers a collection whose #size is 4" 166625 ^ 1 to: 4.! ! 166626 166627!IntervalTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 17:25'! 166628speciesClass 166629 166630 ^ Array! ! 166631 166632!IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:52'! 166633subCollectionNotIn 166634 166635 ^subCollectionNotIn ! ! 166636 166637 166638!IntervalTest methodsFor: 'setup' stamp: 'delaunay 4/23/2009 11:27'! 166639setUp 166640 166641 empty := (1 to: 0). 166642 one := (1 to:1). 166643 nonEmpty := -5 to: 10 by: 3. 166644 subCollectionInNonEmpty := -2 to: 4 by: 3. 166645 nonEmpty1Element:= 1to:1. 166646 anotherCollection:= 2 to: 15. 166647 collectionWithoutNil := 1 to: 3. 166648 result := { SmallInteger. SmallInteger. SmallInteger.}. 166649 elementIn :=-2. 166650 elementNotIn:= 12. 166651 subCollectionNotIn:= -2 to: 1. 166652 collectionOfFloat := 1.5 to: 7.5 by: 1. 166653 subCollection := 2 to: 8. 166654 collectionWithSubCollection := 1 to: 10.! ! 166655 166656 166657!IntervalTest methodsFor: 'test - equality'! 166658testEqualSign 166659 "self debug: #testEqualSign" 166660 166661 self deny: (self empty = self nonEmpty).! ! 166662 166663!IntervalTest methodsFor: 'test - equality'! 166664testEqualSignIsTrueForNonIdenticalButEqualCollections 166665 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 166666 166667 self assert: (self empty = self empty copy). 166668 self assert: (self empty copy = self empty). 166669 self assert: (self empty copy = self empty copy). 166670 166671 self assert: (self nonEmpty = self nonEmpty copy). 166672 self assert: (self nonEmpty copy = self nonEmpty). 166673 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 166674 166675!IntervalTest methodsFor: 'test - equality'! 166676testEqualSignOfIdenticalCollectionObjects 166677 "self debug: #testEqualSignOfIdenticalCollectionObjects" 166678 166679 self assert: (self empty = self empty). 166680 self assert: (self nonEmpty = self nonEmpty). 166681 ! ! 166682 166683 166684!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:23'! 166685testAdd 166686 self assert: (1 to: 10) 166687 + 5 166688 = (6 to: 15)! ! 166689 166690!IntervalTest methodsFor: 'tests' stamp: 'nice 3/27/2008 00:24'! 166691testAsInterval 166692 "This is the same as newFrom:" 166693 166694 self shouldnt: [ 166695 self assert: (#(1 2 3) as: Interval) = (1 to: 3). 166696 self assert: (#(33 5 -23) as: Interval) = (33 to: -23 by: -28). 166697 self assert: (#(2 4 6) asByteArray as: Interval) = (2 to: 6 by: 2). 166698 ] raise: Error. 166699 166700 self should: [#(33 5 -22) as: Interval] 166701 raise: Error 166702 description: 'This is not an arithmetic progression' 166703! ! 166704 166705!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:15'! 166706testAt 166707 self assert: ((1 to: 10) 166708 at: 1) 166709 = 1. 166710 self assert: ((1 to: 10) 166711 at: 3) 166712 = 3. 166713 self assert: ((1 to: 10 by: 2) 166714 at: 1) 166715 = 1. 166716 self assert: ((1 to: 10 by: 2) 166717 at: 3) 166718 = 5! ! 166719 166720!IntervalTest methodsFor: 'tests' stamp: 'stephane.ducasse 1/16/2009 21:06'! 166721testCollectThenSelectLocal 166722 | letters vowels | 166723 letters := 'abcdefghijklmnopqrstuvwxyz'. 166724 vowels := (1 to: 26) collect: [:index | letters at: index] thenSelect: [:char | char isVowel]. 166725 self assert: (vowels hasEqualElements: 'aeiou').! ! 166726 166727!IntervalTest methodsFor: 'tests' stamp: 'apb 4/22/2007 12:34'! 166728testDo 166729 | s i | 166730 s := OrderedCollection new. 166731 i := (10 to: 20). 166732 i do: [ :each | s addLast: each]. 166733 self assert: (s hasEqualElements: i)! ! 166734 166735!IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:13'! 166736testEquals 166737 166738 self shouldnt: [ 166739 self assert: (3 to: 5) = #(3 4 5). 166740 self deny: (3 to: 5) = #(3 5). 166741 self deny: (3 to: 5) = #(). 166742 166743 self assert: #(3 4 5) = (3 to: 5). 166744 self deny: #(3 5) = (3 to: 5). 166745 self deny: #() = (3 to: 5). 166746 ] raise: MessageNotUnderstood.! ! 166747 166748!IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:13'! 166749testEquals2 166750 166751 self assert: (3 to: 5) = #(3 4 5). 166752 self deny: (3 to: 5) = #(3 5). 166753 self deny: (3 to: 5) = #(). 166754 166755 self assert: #(3 4 5) = (3 to: 5). 166756 self deny: #(3 5) = (3 to: 5). 166757 self deny: #() = (3 to: 5).! ! 166758 166759!IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:13'! 166760testEquals3 166761 166762 self assert: (3 to: 5 by: 2) first = (3 to: 6 by: 2) first. 166763 self assert: (3 to: 5 by: 2) last = (3 to: 6 by: 2) last. 166764 self assert: (3 to: 5 by: 2) = (3 to: 6 by: 2).! ! 166765 166766!IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:13'! 166767testEquals4 166768 166769 self assert: (3 to: 5 by: 2) = #(3 5). 166770 self deny: (3 to: 5 by: 2) = #(3 4 5). 166771 self deny: (3 to: 5 by: 2) = #(). 166772 166773 self assert: #(3 5) = (3 to: 5 by: 2). 166774 self deny: #(3 4 5) = (3 to: 5 by: 2). 166775 self deny: #() = (3 to: 5 by: 2).! ! 166776 166777!IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:14'! 166778testEquals5 166779 166780 self assert: (3 to: 5 by: 2) = (Heap withAll: #(3 5)). 166781 self deny: (3 to: 5 by: 2) = (Heap withAll: #(3 4 5)). 166782 self deny: (3 to: 5 by: 2) = Heap new. 166783 166784 self assert: (Heap withAll: #(3 5)) = (3 to: 5 by: 2). 166785 self deny: (Heap withAll: #(3 4 5)) = (3 to: 5 by: 2). 166786 self deny: Heap new = (3 to: 5 by: 2).! ! 166787 166788!IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:14'! 166789testEquals6 166790 166791 self assert: #() = Heap new. 166792 self assert: #(3 5) = (Heap withAll: #(3 5)). 166793 self deny: (3 to: 5 by: 2) = (Heap withAll: #(3 4 5)). 166794 self deny: (3 to: 5 by: 2) = Heap new. 166795 166796 self assert: Heap new = #(). 166797 self assert: (Heap withAll: #(3 5)) = #(3 5). 166798 self deny: (Heap withAll: #(3 4 5)) = #(3 5). 166799 self deny: Heap new = #(3 5).! ! 166800 166801!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:08'! 166802testExtent 166803 self assert: (1 to: 10) extent = 9. 166804 self assert: (1 to: 10 by: 2) extent = 9. 166805 self assert: (1 to:-1) extent = -2! ! 166806 166807!IntervalTest methodsFor: 'tests' stamp: 'nice 4/29/2007 21:34'! 166808testInclusionBug1603 166809 "This test is by german morales. 166810 It is about mantis bug 1603" 166811 166812 self shouldnt: ((1 to: 5 by: 1) includes: 2.5). "obvious" 166813 self shouldnt: ((100000000000000 to: 500000000000000 by: 100000000000000) 166814 includes: 250000000000000). "same as above with 14 zeros appended"! ! 166815 166816!IntervalTest methodsFor: 'tests' stamp: 'nice 2/3/2008 21:43'! 166817testInclusionBug6455 166818 "This test is about mantis bug http://bugs.squeak.org/view.php?id=6455 166819 It should work as long as Fuzzy inclusion test feature for Interval of Float is maintained. 166820 This is a case when tested element is near ones of actual value, but by default. 166821 Code used to work only in the case of close numbers by excess..." 166822 166823 self assert: ((0 to: Float pi by: Float pi / 100) includes: Float pi * (3/100))! ! 166824 166825!IntervalTest methodsFor: 'tests' stamp: 'nice 4/29/2007 21:35'! 166826testIndexOfBug1602 166827 "This test is by german morales. 166828 It is about mantis bug 1602" 166829 166830 self should: ((1 to: 5 by: 1) indexOf: 2.5) = 0. "obvious" 166831 self should: ((100000000000000 to: 500000000000000 by: 100000000000000) 166832 indexOf: 250000000000000) = 0. "same as above with 14 zeros appended"! ! 166833 166834!IntervalTest methodsFor: 'tests' stamp: 'nice 2/3/2008 21:35'! 166835testIndexOfBug6455 166836 "This test is about mantis bug http://bugs.squeak.org/view.php?id=6455 166837 It should work as long as Fuzzy inclusion test feature for Interval of Float is maintained. 166838 This is a case when tested element is near ones of actual value, but by default. 166839 Code used to work only in the case of close numbers by excess..." 166840 166841 self assert: ((0 to: Float pi by: Float pi / 100) indexOf: Float pi * (3/100)) = 4! ! 166842 166843!IntervalTest methodsFor: 'tests' stamp: 'nice 4/30/2007 18:40'! 166844testInfiniteLoopBug6456 166845 "This is a non regression test against mantis bug #6456. 166846 Some Float interval size was not consistent with do: loop. 166847 Some Float Interval used to do: infinite loops" 166848 166849 | x interval counter size | 166850 x := (1.0 timesTwoPower: 53). "Note: x+1 = x due to inexact arithmetic" 166851 interval := x to: x+4. 166852 size := interval size. 166853 counter := 0. 166854 interval do: [:each | self should: (counter := counter + 1) <= size].! ! 166855 166856!IntervalTest methodsFor: 'tests'! 166857testInvalid 166858 "empty, impossible ranges" 166859 self assert: (1 to: 0) = #(). 166860 self assert: (1 to: -1) = #(). 166861 self assert: (-1 to: -2) = #(). 166862 self assert: (1 to: 5 by: -1) = #(). 166863 166864 "always contains only start value." 166865 self assert: (1 to: 1) = #(1). 166866 self assert: (1 to: 5 by: 10) = #(1). 166867 self assert: (1 to: 0 by: -2) = #(1). 166868! ! 166869 166870!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:11'! 166871testIsEvaluating 166872 self assert: (1 to: 10) isSelfEvaluating. 166873 self assert: (1 to: 10 by: 2) isSelfEvaluating! ! 166874 166875!IntervalTest methodsFor: 'tests' stamp: 'zz 12/7/2005 13:29'! 166876testIsInterval 166877 self assert: (1 to: 10) isInterval. 166878 self assert: (1 to: 10 by: 2) isInterval! ! 166879 166880!IntervalTest methodsFor: 'tests' stamp: 'zz 12/7/2005 13:29'! 166881testLast 166882 166883self assert: (1 to:10) last = 10. 166884self assert: (1 to:10 by:2) last = 9 ! ! 166885 166886!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:28'! 166887testMinus 166888 self assert: (1 to: 10) 166889 - 5 166890 = (-4 to: 5)! ! 166891 166892!IntervalTest methodsFor: 'tests' stamp: 'md 1/14/2004 11:43'! 166893testNewFrom 166894 166895 self shouldnt: [ 166896 self assert: ( (Interval newFrom: (1 to: 1)) = (1 to: 1)). 166897 self assert: ( (Interval newFrom: #(1)) = (1 to: 1)). 166898 self assert: ( (Interval newFrom: #()) = ( 1 to: 0)) . 166899 ] raise: Error.! ! 166900 166901!IntervalTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:17'! 166902testNumericTypes 166903 166904 (3 asNumber) to: 5 = #(3 4 5). 166905 166906 3.0 to: 5.0 = #(3.0 4.0 5.0). 166907 3.0 to: 5.0 by: 0.5 = #(3.0 3.5 4.0 4.5 5.0). 166908 166909 3/1 to: 5/1 = #(3 4 5). 166910 1/2 to: 5/2 by: 1/2 = #(1/2 1 3/2 2 5/2).! ! 166911 166912!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:03'! 166913testOtherNewFrom 166914 166915 self assert: (Interval newFrom: #(1 2 3 )) = (1 to: 3). 166916 self assert: (Interval newFrom: #(33 5 -23 )) = (33 to: -23 by: -28). 166917 self should: [(Interval newFrom: #(33 5 -22 ))] raise: Error. 166918 self assert: (#(33 5 -23) as: Interval) = (33 to: -23 by: -28). 166919 self should: [( #(33 5 -22 ) as: Interval)] raise: Error. 166920 166921 self assert: ( (-4 to: -12 by: -1) as: Interval) = (-4 to: -12 by: -1). 166922 self assert: ( Interval newFrom: (1 to: 1)) = (1 to: 1). 166923 self assert: ( Interval newFrom: (1 to: 0)) = (1 to: 0). 166924 self assert: (#(1) as: Interval) = (1 to: 1). 166925 self assert: (#() as: Interval) = (1 to: 0).! ! 166926 166927!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:03'! 166928testPermutationsDo 166929 166930 | i oc | 166931 i := (1.234 to: 4.234). 166932 oc := OrderedCollection new. 166933 i permutationsDo: [:e | oc add: e]. 166934 self assert: (oc size == i size factorial). 166935 ^ oc! ! 166936 166937!IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:20'! 166938testRangeIncludes 166939 self 166940 assert: ((1 to: 10) 166941 rangeIncludes: 3). 166942 self 166943 assert: ((1 to: 10 by: 2) 166944 rangeIncludes: 3). 166945 self 166946 deny: ((1 to: 10) 166947 rangeIncludes: 0). 166948 self 166949 deny: ((1 to: 10) 166950 rangeIncludes: 11). 166951 self 166952 deny: ((1 to: 10 by: 2) 166953 rangeIncludes: 0). 166954 self 166955 deny: ((1 to: 10 by: 2) 166956 rangeIncludes: 11)! ! 166957 166958!IntervalTest methodsFor: 'tests' stamp: 'apb 4/22/2007 12:35'! 166959testReverseDo 166960 | s i | 166961 s := OrderedCollection new. 166962 i := 10 to: 20. 166963 i 166964 reverseDo: [:each | s addFirst: each]. 166965 self 166966 assert: (s hasEqualElements: i)! ! 166967 166968!IntervalTest methodsFor: 'tests' stamp: 'apb 4/22/2007 12:36'! 166969testReverseUnevenDo 166970 | s i | 166971 s := OrderedCollection new. 166972 i := 10 to: 20 by: 3. 166973 i 166974 reverseDo: [:each | s addFirst: each]. 166975 self 166976 assert: (s hasEqualElements: i)! ! 166977 166978!IntervalTest methodsFor: 'tests' stamp: 'apb 4/22/2007 12:39'! 166979testUnevenDo 166980 | s i | 166981 s := OrderedCollection new. 166982 i := 10 to: 20 by: 3. 166983 i 166984 do: [:each | s addLast: each]. 166985 self 166986 assert: (s hasEqualElements: i)! ! 166987 166988 166989!IntervalTest methodsFor: 'tests - as sorted collection'! 166990testAsSortedArray 166991 | result collection | 166992 collection := self collectionWithSortableElements . 166993 result := collection asSortedArray. 166994 self assert: (result class includesBehavior: Array). 166995 self assert: result isSorted. 166996 self assert: result size = collection size! ! 166997 166998!IntervalTest methodsFor: 'tests - as sorted collection'! 166999testAsSortedCollection 167000 167001 | aCollection result | 167002 aCollection := self collectionWithSortableElements . 167003 result := aCollection asSortedCollection. 167004 167005 self assert: (result class includesBehavior: SortedCollection). 167006 result do: 167007 [ :each | 167008 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 167009 167010 self assert: result size = aCollection size.! ! 167011 167012!IntervalTest methodsFor: 'tests - as sorted collection'! 167013testAsSortedCollectionWithSortBlock 167014 | result tmp | 167015 result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. 167016 self assert: (result class includesBehavior: SortedCollection). 167017 result do: 167018 [ :each | 167019 self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 167020 self assert: result size = self collectionWithSortableElements size. 167021 tmp:=result at: 1. 167022 result do: [:each| self assert: tmp>=each. tmp:=each]. 167023 ! ! 167024 167025 167026!IntervalTest methodsFor: 'tests - begins ends with'! 167027testsBeginsWith 167028 167029 self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty size)). 167030 self assert: (self nonEmpty beginsWith:(self nonEmpty )). 167031 self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 167032 167033!IntervalTest methodsFor: 'tests - begins ends with'! 167034testsBeginsWithEmpty 167035 167036 self deny: (self nonEmpty beginsWith:(self empty)). 167037 self deny: (self empty beginsWith:(self nonEmpty )). 167038! ! 167039 167040!IntervalTest methodsFor: 'tests - begins ends with'! 167041testsEndsWith 167042 167043 self assert: (self nonEmpty endsWith:(self nonEmpty copyWithoutFirst)). 167044 self assert: (self nonEmpty endsWith:(self nonEmpty )). 167045 self deny: (self nonEmpty endsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 167046 167047!IntervalTest methodsFor: 'tests - begins ends with'! 167048testsEndsWithEmpty 167049 167050 self deny: (self nonEmpty endsWith:(self empty )). 167051 self deny: (self empty endsWith:(self nonEmpty )). 167052 ! ! 167053 167054 167055!IntervalTest methodsFor: 'tests - comma and delimiter'! 167056testAsCommaStringEmpty 167057 167058 self assert: self empty asCommaString = ''. 167059 self assert: self empty asCommaStringAnd = ''. 167060 167061 167062! ! 167063 167064!IntervalTest methodsFor: 'tests - comma and delimiter'! 167065testAsCommaStringMore 167066 167067 "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. 167068 self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' 167069" 167070 167071 | result resultAnd index allElementsAsString | 167072 result:= self nonEmpty asCommaString . 167073 resultAnd:= self nonEmpty asCommaStringAnd . 167074 167075 index := 1. 167076 (result findBetweenSubStrs: ',' )do: 167077 [:each | 167078 index = 1 167079 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] 167080 ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. 167081 index:=index+1 167082 ]. 167083 167084 "verifying esultAnd :" 167085 allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 167086 1 to: allElementsAsString size do: 167087 [:i | 167088 i<(allElementsAsString size ) 167089 ifTrue: [ 167090 i = 1 167091 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] 167092 ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] 167093 ]. 167094 i=(allElementsAsString size) 167095 ifTrue:[ 167096 i = 1 167097 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 167098 ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 167099 ]. 167100 167101 167102 ].! ! 167103 167104!IntervalTest methodsFor: 'tests - comma and delimiter'! 167105testAsCommaStringOne 167106 167107 "self assert: self oneItemCol asCommaString = '1'. 167108 self assert: self oneItemCol asCommaStringAnd = '1'." 167109 167110 self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). 167111 self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). 167112 ! ! 167113 167114!IntervalTest methodsFor: 'tests - comma and delimiter'! 167115testAsStringOnDelimiterEmpty 167116 167117 | delim emptyStream | 167118 delim := ', '. 167119 emptyStream := ReadWriteStream on: ''. 167120 self empty asStringOn: emptyStream delimiter: delim. 167121 self assert: emptyStream contents = ''. 167122! ! 167123 167124!IntervalTest methodsFor: 'tests - comma and delimiter'! 167125testAsStringOnDelimiterLastEmpty 167126 167127 | delim emptyStream | 167128 delim := ', '. 167129 emptyStream := ReadWriteStream on: ''. 167130 self empty asStringOn: emptyStream delimiter: delim last:'and'. 167131 self assert: emptyStream contents = ''. 167132! ! 167133 167134!IntervalTest methodsFor: 'tests - comma and delimiter'! 167135testAsStringOnDelimiterLastMore 167136 167137 | delim multiItemStream result last allElementsAsString | 167138 167139 delim := ', '. 167140 last := 'and'. 167141 result:=''. 167142 multiItemStream := ReadWriteStream on:result. 167143 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 167144 167145 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 167146 1 to: allElementsAsString size do: 167147 [:i | 167148 i<(allElementsAsString size-1 ) 167149 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 167150 i=(allElementsAsString size-1) 167151 ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. 167152 i=(allElementsAsString size) 167153 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 167154 ]. 167155 167156! ! 167157 167158!IntervalTest methodsFor: 'tests - comma and delimiter'! 167159testAsStringOnDelimiterLastOne 167160 167161 | delim oneItemStream result | 167162 167163 delim := ', '. 167164 result:=''. 167165 oneItemStream := ReadWriteStream on: result. 167166 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 167167 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 167168 167169 167170 ! ! 167171 167172!IntervalTest methodsFor: 'tests - comma and delimiter'! 167173testAsStringOnDelimiterMore 167174 167175 | delim multiItemStream result index | 167176 "delim := ', '. 167177 multiItemStream := '' readWrite. 167178 self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. 167179 self assert: multiItemStream contents = '1, 2, 3'." 167180 167181 delim := ', '. 167182 result:=''. 167183 multiItemStream := ReadWriteStream on:result. 167184 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 167185 167186 index:=1. 167187 (result findBetweenSubStrs: ', ' )do: 167188 [:each | 167189 self assert: each= ((self nonEmpty at:index)asString). 167190 index:=index+1 167191 ].! ! 167192 167193!IntervalTest methodsFor: 'tests - comma and delimiter'! 167194testAsStringOnDelimiterOne 167195 167196 | delim oneItemStream result | 167197 "delim := ', '. 167198 oneItemStream := '' readWrite. 167199 self oneItemCol asStringOn: oneItemStream delimiter: delim. 167200 self assert: oneItemStream contents = '1'." 167201 167202 delim := ', '. 167203 result:=''. 167204 oneItemStream := ReadWriteStream on: result. 167205 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 167206 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 167207 167208 167209 ! ! 167210 167211 167212!IntervalTest methodsFor: 'tests - concatenation'! 167213testConcatenation 167214 | result index | 167215 result:= self firstCollection,self secondCollection . 167216 "first part : " 167217 index := 1. 167218 self firstCollection do: 167219 [:each | 167220 self assert: (self firstCollection at: index)=each. 167221 index := index+1.]. 167222 "second part : " 167223 1 to: self secondCollection size do: 167224 [:i | 167225 self assert: (self secondCollection at:i)= (result at:index). 167226 index:=index+1]. 167227 "size : " 167228 self assert: result size = (self firstCollection size + self secondCollection size).! ! 167229 167230!IntervalTest methodsFor: 'tests - concatenation'! 167231testConcatenationWithEmpty 167232 | result | 167233 result:= self empty,self secondCollection . 167234 167235 1 to: self secondCollection size do: 167236 [:i | 167237 self assert: (self secondCollection at:i)= (result at:i). 167238 ]. 167239 "size : " 167240 self assert: result size = ( self secondCollection size).! ! 167241 167242 167243!IntervalTest methodsFor: 'tests - converting'! 167244assertNoDuplicates: aCollection whenConvertedTo: aClass 167245 | result | 167246 result := self collectionWithEqualElements asIdentitySet. 167247 self assert: (result class includesBehavior: IdentitySet). 167248 self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! 167249 167250!IntervalTest methodsFor: 'tests - converting'! 167251assertNonDuplicatedContents: aCollection whenConvertedTo: aClass 167252 | result | 167253 result := aCollection perform: ('as' , aClass name) asSymbol. 167254 self assert: (result class includesBehavior: aClass). 167255 result do: 167256 [ :each | 167257 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 167258 ^ result! ! 167259 167260!IntervalTest methodsFor: 'tests - converting'! 167261assertSameContents: aCollection whenConvertedTo: aClass 167262 | result | 167263 result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. 167264 self assert: result size = aCollection size! ! 167265 167266!IntervalTest methodsFor: 'tests - converting'! 167267testAsArray 167268 "self debug: #testAsArray3" 167269 self 167270 assertSameContents: self collectionWithoutEqualElements 167271 whenConvertedTo: Array! ! 167272 167273!IntervalTest methodsFor: 'tests - converting'! 167274testAsBag 167275 167276 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! 167277 167278!IntervalTest methodsFor: 'tests - converting'! 167279testAsByteArray 167280| res | 167281self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 167282 self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . 167283 167284 res := true. 167285 self integerCollectionWithoutEqualElements 167286 detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] 167287 ifNone: [ res := false ]. 167288 self assert: res = false. 167289 167290 167291 self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! 167292 167293!IntervalTest methodsFor: 'tests - converting'! 167294testAsIdentitySet 167295 "test with a collection without equal elements :" 167296 self 167297 assertSameContents: self collectionWithoutEqualElements 167298 whenConvertedTo: IdentitySet. 167299! ! 167300 167301!IntervalTest methodsFor: 'tests - converting'! 167302testAsOrderedCollection 167303 167304 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! 167305 167306!IntervalTest methodsFor: 'tests - converting'! 167307testAsSet 167308 | | 167309 "test with a collection without equal elements :" 167310 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. 167311 ! ! 167312 167313 167314!IntervalTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 167315testCopyEmptyWith 167316 "self debug: #testCopyWith" 167317 | res | 167318 res := self empty copyWith: self elementToAdd. 167319 self assert: res size = (self empty size + 1). 167320 self assert: (res includes: self elementToAdd)! ! 167321 167322!IntervalTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 167323testCopyEmptyWithout 167324 "self debug: #testCopyEmptyWithout" 167325 | res | 167326 res := self empty copyWithout: self elementToAdd. 167327 self assert: res size = self empty size. 167328 self deny: (res includes: self elementToAdd)! ! 167329 167330!IntervalTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 167331testCopyEmptyWithoutAll 167332 "self debug: #testCopyEmptyWithoutAll" 167333 | res | 167334 res := self empty copyWithoutAll: self collectionWithElementsToRemove. 167335 self assert: res size = self empty size. 167336 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! 167337 167338!IntervalTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 167339testCopyNonEmptyWith 167340 "self debug: #testCopyNonEmptyWith" 167341 | res | 167342 res := self nonEmpty copyWith: self elementToAdd. 167343 "here we do not test the size since for a non empty set we would get a problem. 167344 Then in addition copy is not about duplicate management. The element should 167345 be in at the end." 167346 self assert: (res includes: self elementToAdd). 167347 self nonEmpty do: [ :each | res includes: each ]! ! 167348 167349!IntervalTest methodsFor: 'tests - copy'! 167350testCopyNonEmptyWithout 167351 "self debug: #testCopyNonEmptyWithout" 167352 167353 | res anElementOfTheCollection | 167354 anElementOfTheCollection := self nonEmpty anyOne. 167355 res := (self nonEmpty copyWithout: anElementOfTheCollection). 167356 "here we do not test the size since for a non empty set we would get a problem. 167357 Then in addition copy is not about duplicate management. The element should 167358 be in at the end." 167359 self deny: (res includes: anElementOfTheCollection). 167360 self nonEmpty do: 167361 [:each | (each = anElementOfTheCollection) 167362 ifFalse: [self assert: (res includes: each)]]. 167363 167364! ! 167365 167366!IntervalTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 167367testCopyNonEmptyWithoutAll 167368 "self debug: #testCopyNonEmptyWithoutAll" 167369 | res | 167370 res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. 167371 "here we do not test the size since for a non empty set we would get a problem. 167372 Then in addition copy is not about duplicate management. The element should 167373 be in at the end." 167374 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]. 167375 self nonEmpty do: 167376 [ :each | 167377 (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! 167378 167379!IntervalTest methodsFor: 'tests - copy'! 167380testCopyNonEmptyWithoutAllNotIncluded 167381 "self debug: #testCopyNonEmptyWithoutAllNotIncluded" 167382 | res | 167383 res := self nonEmpty copyWithoutAll: self collectionNotIncluded. 167384 "here we do not test the size since for a non empty set we would get a problem. 167385 Then in addition copy is not about duplicate management. The element should 167386 be in at the end." 167387 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 167388 167389!IntervalTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 167390testCopyNonEmptyWithoutNotIncluded 167391 "self debug: #testCopyNonEmptyWithoutNotIncluded" 167392 | res | 167393 res := self nonEmpty copyWithout: self elementToAdd. 167394 "here we do not test the size since for a non empty set we would get a problem. 167395 Then in addition copy is not about duplicate management. The element should 167396 be in at the end." 167397 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 167398 167399 167400!IntervalTest methodsFor: 'tests - copy - clone'! 167401testCopyCreatesNewObject 167402 "self debug: #testCopyCreatesNewObject" 167403 167404 | copy | 167405 copy := self nonEmpty copy. 167406 self deny: self nonEmpty == copy. 167407 ! ! 167408 167409!IntervalTest methodsFor: 'tests - copy - clone'! 167410testCopyEmpty 167411 "self debug: #testCopyEmpty" 167412 167413 | copy | 167414 copy := self empty copy. 167415 self assert: copy isEmpty.! ! 167416 167417!IntervalTest methodsFor: 'tests - copy - clone'! 167418testCopyNonEmpty 167419 "self debug: #testCopyNonEmpty" 167420 167421 | copy | 167422 copy := self nonEmpty copy. 167423 self deny: copy isEmpty. 167424 self assert: copy size = self nonEmpty size. 167425 self nonEmpty do: 167426 [:each | copy includes: each]! ! 167427 167428 167429!IntervalTest methodsFor: 'tests - copying part of sequenceable'! 167430testCopyAfter 167431 | result index collection | 167432 collection := self collectionWithoutEqualsElements . 167433 index:= self indexInForCollectionWithoutDuplicates . 167434 result := collection copyAfter: (collection at:index ). 167435 167436 "verifying content: " 167437 (1) to: result size do: 167438 [:i | 167439 self assert: (collection at:(i + index ))=(result at: (i))]. 167440 167441 "verify size: " 167442 self assert: result size = (collection size - index).! ! 167443 167444!IntervalTest methodsFor: 'tests - copying part of sequenceable'! 167445testCopyAfterEmpty 167446 | result | 167447 result := self empty copyAfter: self collectionWithoutEqualsElements first. 167448 self assert: result isEmpty. 167449 ! ! 167450 167451!IntervalTest methodsFor: 'tests - copying part of sequenceable'! 167452testCopyAfterLast 167453 | result index collection | 167454 collection := self collectionWithoutEqualsElements . 167455 index:= self indexInForCollectionWithoutDuplicates . 167456 result := collection copyAfterLast: (collection at:index ). 167457 167458 "verifying content: " 167459 (1) to: result size do: 167460 [:i | 167461 self assert: (collection at:(i + index ))=(result at: (i))]. 167462 167463 "verify size: " 167464 self assert: result size = (collection size - index).! ! 167465 167466!IntervalTest methodsFor: 'tests - copying part of sequenceable'! 167467testCopyAfterLastEmpty 167468 | result | 167469 result := self empty copyAfterLast: self collectionWithoutEqualsElements first. 167470 self assert: result isEmpty.! ! 167471 167472!IntervalTest methodsFor: 'tests - copying part of sequenceable'! 167473testCopyFromTo 167474 | result index collection | 167475 collection := self collectionWithoutEqualsElements . 167476 index :=self indexInForCollectionWithoutDuplicates . 167477 result := collection copyFrom: index to: collection size . 167478 167479 "verify content of 'result' : " 167480 1 to: result size do: 167481 [:i | 167482 self assert: (result at:i)=(collection at: (i + index - 1))]. 167483 167484 "verify size of 'result' : " 167485 self assert: result size = (collection size - index + 1).! ! 167486 167487!IntervalTest methodsFor: 'tests - copying part of sequenceable'! 167488testCopyUpTo 167489 | result index collection | 167490 collection := self collectionWithoutEqualsElements . 167491 index:= self indexInForCollectionWithoutDuplicates . 167492 result := collection copyUpTo: (collection at:index). 167493 167494 "verify content of 'result' :" 167495 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 167496 167497 "verify size of 'result' :" 167498 self assert: result size = (index-1). 167499 ! ! 167500 167501!IntervalTest methodsFor: 'tests - copying part of sequenceable'! 167502testCopyUpToEmpty 167503 | result | 167504 result := self empty copyUpTo: self collectionWithoutEqualsElements first. 167505 self assert: result isEmpty. 167506 ! ! 167507 167508!IntervalTest methodsFor: 'tests - copying part of sequenceable'! 167509testCopyUpToLast 167510 | result index collection | 167511 collection := self collectionWithoutEqualsElements . 167512 index:= self indexInForCollectionWithoutDuplicates . 167513 result := collection copyUpToLast: (collection at:index). 167514 167515 "verify content of 'result' :" 167516 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 167517 167518 "verify size of 'result' :" 167519 self assert: result size = (index-1).! ! 167520 167521!IntervalTest methodsFor: 'tests - copying part of sequenceable'! 167522testCopyUpToLastEmpty 167523 | result | 167524 result := self empty copyUpToLast: self collectionWithoutEqualsElements first. 167525 self assert: result isEmpty.! ! 167526 167527 167528!IntervalTest methodsFor: 'tests - copying same contents'! 167529testReverse 167530 | result | 167531 result := self nonEmpty reverse . 167532 167533 "verify content of 'result: '" 167534 1 to: result size do: 167535 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 167536 "verify size of 'result' :" 167537 self assert: result size=self nonEmpty size.! ! 167538 167539!IntervalTest methodsFor: 'tests - copying same contents'! 167540testReversed 167541 | result | 167542 result := self nonEmpty reversed . 167543 167544 "verify content of 'result: '" 167545 1 to: result size do: 167546 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 167547 "verify size of 'result' :" 167548 self assert: result size=self nonEmpty size.! ! 167549 167550!IntervalTest methodsFor: 'tests - copying same contents'! 167551testShallowCopy 167552 | result | 167553 result := self nonEmpty shallowCopy . 167554 167555 "verify content of 'result: '" 167556 1 to: self nonEmpty size do: 167557 [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. 167558 "verify size of 'result' :" 167559 self assert: result size=self nonEmpty size.! ! 167560 167561!IntervalTest methodsFor: 'tests - copying same contents'! 167562testShallowCopyEmpty 167563 | result | 167564 result := self empty shallowCopy . 167565 self assert: result isEmpty .! ! 167566 167567!IntervalTest methodsFor: 'tests - copying same contents'! 167568testSortBy 167569 " can only be used if the collection tested can include sortable elements :" 167570 | result tmp | 167571 self 167572 shouldnt: [ self collectionWithSortableElements ] 167573 raise: Error. 167574 self shouldnt: [self collectionWithSortableElements anyOne < self collectionWithSortableElements anyOne] raise: Error. 167575 result := self collectionWithSortableElements sortBy: [ :a :b | a < b ]. 167576 167577 "verify content of 'result' : " 167578 result do: 167579 [ :each | 167580 (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 167581 tmp := result first. 167582 result do: 167583 [ :each | 167584 self assert: each >= tmp. 167585 tmp := each ]. 167586 167587 "verify size of 'result' :" 167588 self assert: result size = self collectionWithSortableElements size! ! 167589 167590 167591!IntervalTest methodsFor: 'tests - copying with or without'! 167592testCopyWithFirst 167593 167594 | index element result | 167595 index:= self indexInNonEmpty . 167596 element:= self nonEmpty at: index. 167597 167598 result := self nonEmpty copyWithFirst: element. 167599 167600 self assert: result size = (self nonEmpty size + 1). 167601 self assert: result first = element . 167602 167603 2 to: result size do: 167604 [ :i | 167605 self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! 167606 167607!IntervalTest methodsFor: 'tests - copying with or without'! 167608testCopyWithSequenceable 167609 167610 | result index element | 167611 index := self indexInNonEmpty . 167612 element := self nonEmpty at: index. 167613 result := self nonEmpty copyWith: (element ). 167614 167615 self assert: result size = (self nonEmpty size + 1). 167616 self assert: result last = element . 167617 167618 1 to: (result size - 1) do: 167619 [ :i | 167620 self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! 167621 167622!IntervalTest methodsFor: 'tests - copying with or without'! 167623testCopyWithoutFirst 167624 167625 | result | 167626 result := self nonEmpty copyWithoutFirst. 167627 167628 self assert: result size = (self nonEmpty size - 1). 167629 167630 1 to: result size do: 167631 [:i | 167632 self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! 167633 167634!IntervalTest methodsFor: 'tests - copying with or without'! 167635testCopyWithoutIndex 167636 | result index | 167637 index := self indexInNonEmpty . 167638 result := self nonEmpty copyWithoutIndex: index . 167639 167640 "verify content of 'result:'" 167641 1 to: result size do: 167642 [:i | 167643 i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. 167644 i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. 167645 167646 "verify size of result : " 167647 self assert: result size=(self nonEmpty size -1).! ! 167648 167649!IntervalTest methodsFor: 'tests - copying with or without'! 167650testForceToPaddingStartWith 167651 167652 | result element | 167653 element := self nonEmpty at: self indexInNonEmpty . 167654 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). 167655 167656 "verify content of 'result' : " 167657 1 to: 2 do: 167658 [:i | self assert: ( element ) = ( result at:(i) ) ]. 167659 167660 3 to: result size do: 167661 [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. 167662 167663 "verify size of 'result' :" 167664 self assert: result size = (self nonEmpty size + 2).! ! 167665 167666!IntervalTest methodsFor: 'tests - copying with or without'! 167667testForceToPaddingWith 167668 167669 | result element | 167670 element := self nonEmpty at: self indexInNonEmpty . 167671 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). 167672 167673 "verify content of 'result' : " 167674 1 to: self nonEmpty size do: 167675 [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. 167676 167677 (result size - 1) to: result size do: 167678 [:i | self assert: ( result at:i ) = ( element ) ]. 167679 167680 "verify size of 'result' :" 167681 self assert: result size = (self nonEmpty size + 2).! ! 167682 167683 167684!IntervalTest methodsFor: 'tests - copying with replacement'! 167685firstIndexesOf: subCollection in: collection 167686" return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " 167687 | tmp result currentIndex | 167688 tmp:= collection. 167689 result:= OrderedCollection new. 167690 currentIndex := 1. 167691 167692 [tmp isEmpty ]whileFalse: 167693 [ 167694 (tmp beginsWith: subCollection) 167695 ifTrue: [ 167696 result add: currentIndex. 167697 1 to: subCollection size do: 167698 [:i | 167699 tmp := tmp copyWithoutFirst. 167700 currentIndex := currentIndex + 1] 167701 ] 167702 ifFalse: [ 167703 tmp := tmp copyWithoutFirst. 167704 currentIndex := currentIndex +1. 167705 ] 167706 ]. 167707 167708 ^ result. 167709 ! ! 167710 167711!IntervalTest methodsFor: 'tests - copying with replacement'! 167712testCopyReplaceAllWith1Occurence 167713 | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | 167714 167715 result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 167716 167717 "detecting indexes of olSubCollection" 167718 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . 167719 index:= firstIndexesOfOccurrence at: 1. 167720 167721 "verify content of 'result' : " 167722 "first part of 'result'' : '" 167723 167724 1 to: (index -1) do: 167725 [ 167726 :i | 167727 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 167728 ]. 167729 167730 " middle part containing replacementCollection : " 167731 167732 index to: (index + self replacementCollection size-1) do: 167733 [ 167734 :i | 167735 self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) 167736 ]. 167737 167738 " end part :" 167739 167740 endPartIndexResult := index + self replacementCollection size . 167741 endPartIndexCollection := index + self oldSubCollection size . 167742 167743 1 to: (result size - endPartIndexResult - 1 ) do: 167744 [ 167745 :i | 167746 self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). 167747 ]. 167748 167749 167750 ! ! 167751 167752!IntervalTest methodsFor: 'tests - copying with replacement'! 167753testCopyReplaceFromToWith 167754 | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | 167755 167756 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 167757 lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. 167758 lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. 167759 167760 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . 167761 167762 "verify content of 'result' : " 167763 "first part of 'result' " 167764 167765 1 to: (indexOfSubcollection - 1) do: 167766 [ 167767 :i | 167768 self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) 167769 ]. 167770 167771 " middle part containing replacementCollection : " 167772 167773 (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: 167774 [ 167775 :i | 167776 self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) 167777 ]. 167778 167779 " end part :" 167780 1 to: (result size - lastIndexOfReplacementCollection ) do: 167781 [ 167782 :i | 167783 self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). 167784 ]. 167785 167786 167787 167788 167789 167790 ! ! 167791 167792!IntervalTest methodsFor: 'tests - copying with replacement'! 167793testCopyReplaceFromToWithInsertion 167794 | result indexOfSubcollection | 167795 167796 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 167797 167798 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . 167799 167800 "verify content of 'result' : " 167801 "first part of 'result'' : '" 167802 167803 1 to: (indexOfSubcollection -1) do: 167804 [ 167805 :i | 167806 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 167807 ]. 167808 167809 " middle part containing replacementCollection : " 167810 indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: 167811 [ 167812 :i | 167813 self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) 167814 ]. 167815 167816 " end part :" 167817 (indexOfSubcollection + self replacementCollection size) to: (result size) do: 167818 [:i| 167819 self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. 167820 167821 " verify size: " 167822 self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). 167823 167824 167825 167826 167827 167828 ! ! 167829 167830 167831!IntervalTest methodsFor: 'tests - element accessing'! 167832testAfter 167833 "self debug: #testAfter" 167834 self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). 167835 self 167836 should: 167837 [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] 167838 raise: Error. 167839 self 167840 should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] 167841 raise: Error! ! 167842 167843!IntervalTest methodsFor: 'tests - element accessing'! 167844testAfterIfAbsent 167845 "self debug: #testAfterIfAbsent" 167846 self assert: (self moreThan4Elements 167847 after: (self moreThan4Elements at: 1) 167848 ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). 167849 self assert: (self moreThan4Elements 167850 after: (self moreThan4Elements at: self moreThan4Elements size) 167851 ifAbsent: [ 33 ]) == 33. 167852 self assert: (self moreThan4Elements 167853 after: self elementNotInForElementAccessing 167854 ifAbsent: [ 33 ]) = 33! ! 167855 167856!IntervalTest methodsFor: 'tests - element accessing'! 167857testAtAll 167858 "self debug: #testAtAll" 167859 " self flag: #theCollectionshouldbe102030intheFixture. 167860 167861 self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. 167862 self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." 167863 | result | 167864 result := self moreThan4Elements atAll: #(2 1 2 ). 167865 self assert: (result at: 1) = (self moreThan4Elements at: 2). 167866 self assert: (result at: 2) = (self moreThan4Elements at: 1). 167867 self assert: (result at: 3) = (self moreThan4Elements at: 2). 167868 self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! 167869 167870!IntervalTest methodsFor: 'tests - element accessing'! 167871testAtIfAbsent 167872 "self debug: #testAt" 167873 | absent | 167874 absent := false. 167875 self moreThan4Elements 167876 at: self moreThan4Elements size + 1 167877 ifAbsent: [ absent := true ]. 167878 self assert: absent = true. 167879 absent := false. 167880 self moreThan4Elements 167881 at: self moreThan4Elements size 167882 ifAbsent: [ absent := true ]. 167883 self assert: absent = false! ! 167884 167885!IntervalTest methodsFor: 'tests - element accessing'! 167886testAtLast 167887 "self debug: #testAtLast" 167888 | index | 167889 self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. 167890 "tmp:=1. 167891 self do: 167892 [:each | 167893 each =self elementInForIndexAccessing 167894 ifTrue:[index:=tmp]. 167895 tmp:=tmp+1]." 167896 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 167897 self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! 167898 167899!IntervalTest methodsFor: 'tests - element accessing'! 167900testAtLastError 167901 "self debug: #testAtLast" 167902 self 167903 should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] 167904 raise: Error! ! 167905 167906!IntervalTest methodsFor: 'tests - element accessing'! 167907testAtLastIfAbsent 167908 "self debug: #testAtLastIfAbsent" 167909 self assert: (self moreThan4Elements 167910 atLast: 1 167911 ifAbsent: [ nil ]) = self moreThan4Elements last. 167912 self assert: (self moreThan4Elements 167913 atLast: self moreThan4Elements size + 1 167914 ifAbsent: [ 222 ]) = 222! ! 167915 167916!IntervalTest methodsFor: 'tests - element accessing'! 167917testAtOutOfBounds 167918 "self debug: #testAtOutOfBounds" 167919 self 167920 should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] 167921 raise: Error. 167922 self 167923 should: [ self moreThan4Elements at: -1 ] 167924 raise: Error! ! 167925 167926!IntervalTest methodsFor: 'tests - element accessing'! 167927testAtPin 167928 "self debug: #testAtPin" 167929 self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. 167930 self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. 167931 self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! 167932 167933!IntervalTest methodsFor: 'tests - element accessing'! 167934testAtRandom 167935 | result | 167936 result := self nonEmpty atRandom . 167937 self assert: (self nonEmpty includes: result).! ! 167938 167939!IntervalTest methodsFor: 'tests - element accessing'! 167940testBefore 167941 "self debug: #testBefore" 167942 self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). 167943 self 167944 should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] 167945 raise: Error. 167946 self 167947 should: [ self moreThan4Elements before: 66 ] 167948 raise: Error! ! 167949 167950!IntervalTest methodsFor: 'tests - element accessing'! 167951testBeforeIfAbsent 167952 "self debug: #testBefore" 167953 self assert: (self moreThan4Elements 167954 before: (self moreThan4Elements at: 1) 167955 ifAbsent: [ 99 ]) = 99. 167956 self assert: (self moreThan4Elements 167957 before: (self moreThan4Elements at: 2) 167958 ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! 167959 167960!IntervalTest methodsFor: 'tests - element accessing'! 167961testFirstSecondThird 167962 "self debug: #testFirstSecondThird" 167963 self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). 167964 self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). 167965 self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). 167966 self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! 167967 167968!IntervalTest methodsFor: 'tests - element accessing'! 167969testMiddle 167970 "self debug: #testMiddle" 167971 self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! 167972 167973 167974!IntervalTest methodsFor: 'tests - equality'! 167975testEqualSignForSequenceableCollections 167976 "self debug: #testEqualSign" 167977 167978 self deny: (self nonEmpty = self nonEmpty asSet). 167979 self deny: (self nonEmpty reversed = self nonEmpty). 167980 self deny: (self nonEmpty = self nonEmpty reversed).! ! 167981 167982!IntervalTest methodsFor: 'tests - equality'! 167983testHasEqualElements 167984 "self debug: #testHasEqualElements" 167985 167986 self deny: (self empty hasEqualElements: self nonEmpty). 167987 self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). 167988 self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). 167989 self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! 167990 167991!IntervalTest methodsFor: 'tests - equality'! 167992testHasEqualElementsIsTrueForNonIdenticalButEqualCollections 167993 "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" 167994 167995 self assert: (self empty hasEqualElements: self empty copy). 167996 self assert: (self empty copy hasEqualElements: self empty). 167997 self assert: (self empty copy hasEqualElements: self empty copy). 167998 167999 self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). 168000 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). 168001 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! 168002 168003!IntervalTest methodsFor: 'tests - equality'! 168004testHasEqualElementsOfIdenticalCollectionObjects 168005 "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" 168006 168007 self assert: (self empty hasEqualElements: self empty). 168008 self assert: (self nonEmpty hasEqualElements: self nonEmpty). 168009 ! ! 168010 168011 168012!IntervalTest methodsFor: 'tests - fixture'! 168013howMany: subCollection in: collection 168014" return an integer representing how many time 'subCollection' appears in 'collection' " 168015 | tmp nTime | 168016 tmp:= collection. 168017 nTime:= 0. 168018 168019 [tmp isEmpty ]whileFalse: 168020 [ 168021 (tmp beginsWith: subCollection) 168022 ifTrue: [ 168023 nTime := nTime + 1. 168024 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] 168025 ] 168026 ifFalse: [tmp := tmp copyWithoutFirst.] 168027 ]. 168028 168029 ^ nTime. 168030 ! ! 168031 168032!IntervalTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/17/2009 15:26'! 168033test0CopyTest 168034 self 168035 shouldnt: [ self empty ] 168036 raise: Error. 168037 self assert: self empty size = 0. 168038 self 168039 shouldnt: [ self nonEmpty ] 168040 raise: Error. 168041 self assert: (self nonEmpty size = 0) not. 168042 self 168043 shouldnt: [ self collectionWithElementsToRemove ] 168044 raise: Error. 168045 self assert: (self collectionWithElementsToRemove size = 0) not. 168046 self 168047 shouldnt: [ self elementToAdd ] 168048 raise: Error. 168049 self 168050 shouldnt: [ self collectionNotIncluded ] 168051 raise: Error. 168052 self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! 168053 168054!IntervalTest methodsFor: 'tests - fixture'! 168055test0FixtureAsStringCommaAndDelimiterTest 168056 168057 self shouldnt: [self nonEmpty] raise:Error . 168058 self deny: self nonEmpty isEmpty. 168059 168060 self shouldnt: [self empty] raise:Error . 168061 self assert: self empty isEmpty. 168062 168063 self shouldnt: [self nonEmpty1Element ] raise:Error . 168064 self assert: self nonEmpty1Element size=1.! ! 168065 168066!IntervalTest methodsFor: 'tests - fixture'! 168067test0FixtureBeginsEndsWithTest 168068 168069 self shouldnt: [self nonEmpty ] raise: Error. 168070 self deny: self nonEmpty isEmpty. 168071 self assert: self nonEmpty size>1. 168072 168073 self shouldnt: [self empty ] raise: Error. 168074 self assert: self empty isEmpty.! ! 168075 168076!IntervalTest methodsFor: 'tests - fixture'! 168077test0FixtureCloneTest 168078 168079self shouldnt: [ self nonEmpty ] raise: Error. 168080self deny: self nonEmpty isEmpty. 168081 168082self shouldnt: [ self empty ] raise: Error. 168083self assert: self empty isEmpty. 168084 168085! ! 168086 168087!IntervalTest methodsFor: 'tests - fixture'! 168088test0FixtureConverAsSortedTest 168089 168090 self shouldnt: [self collectionWithSortableElements ] raise: Error. 168091 self deny: self collectionWithSortableElements isEmpty .! ! 168092 168093!IntervalTest methodsFor: 'tests - fixture'! 168094test0FixtureCopyPartOfSequenceableTest 168095 168096 self shouldnt: [self collectionWithoutEqualsElements ] raise: Error. 168097 self collectionWithoutEqualsElements do: 168098 [:each | self assert: (self collectionWithoutEqualsElements occurrencesOf: each)=1]. 168099 168100 self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. 168101 self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualsElements size. 168102 168103 self shouldnt: [self empty] raise: Error. 168104 self assert: self empty isEmpty .! ! 168105 168106!IntervalTest methodsFor: 'tests - fixture'! 168107test0FixtureCopySameContentsTest 168108 168109 self shouldnt: [self nonEmpty ] raise: Error. 168110 self deny: self nonEmpty isEmpty. 168111 168112 self shouldnt: [self empty ] raise: Error. 168113 self assert: self empty isEmpty. 168114 168115! ! 168116 168117!IntervalTest methodsFor: 'tests - fixture'! 168118test0FixtureCopyWithOrWithoutSpecificElementsTest 168119 168120 self shouldnt: [self nonEmpty ] raise: Error. 168121 self deny: self nonEmpty isEmpty . 168122 168123 self shouldnt: [self indexInNonEmpty ] raise: Error. 168124 self assert: self indexInNonEmpty > 0. 168125 self assert: self indexInNonEmpty <= self nonEmpty size.! ! 168126 168127!IntervalTest methodsFor: 'tests - fixture'! 168128test0FixtureCopyWithReplacementTest 168129 168130 self shouldnt: [self replacementCollection ]raise: Error. 168131 self shouldnt: [self oldSubCollection] raise: Error. 168132 168133 self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. 168134 self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. 168135 168136 ! ! 168137 168138!IntervalTest methodsFor: 'tests - fixture'! 168139test0FixtureIncludeTest 168140 | elementIn | 168141 self shouldnt: [ self nonEmpty ]raise: Error. 168142 self deny: self nonEmpty isEmpty. 168143 168144 self shouldnt: [ self elementNotIn ]raise: Error. 168145 168146 elementIn := true. 168147 self nonEmpty detect: 168148 [ :each | each = self elementNotIn ] 168149 ifNone: [ elementIn := false ]. 168150 self assert: elementIn = false. 168151 168152 self shouldnt: [ self anotherElementNotIn ]raise: Error. 168153 168154 elementIn := true. 168155 self nonEmpty detect: 168156 [ :each | each = self anotherElementNotIn ] 168157 ifNone: [ elementIn := false ]. 168158 self assert: elementIn = false. 168159 168160 self shouldnt: [ self empty ] raise: Error. 168161 self assert: self empty isEmpty. 168162 168163! ! 168164 168165!IntervalTest methodsFor: 'tests - fixture'! 168166test0FixtureIncludeWithIdentityTest 168167 | element | 168168 self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. 168169 element := self collectionWithCopyNonIdentical anyOne. 168170 self deny: element == element copy. 168171! ! 168172 168173!IntervalTest methodsFor: 'tests - fixture'! 168174test0FixtureIndexAccessTest 168175 | res collection element | 168176 self 168177 shouldnt: [ self collectionMoreThan1NoDuplicates ] 168178 raise: Error. 168179 self assert: self collectionMoreThan1NoDuplicates size >1. 168180 res := true. 168181 self collectionMoreThan1NoDuplicates 168182 detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] 168183 ifNone: [ res := false ]. 168184 self assert: res = false. 168185 self 168186 shouldnt: [ self elementInForIndexAccessing ] 168187 raise: Error. 168188 self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). 168189 self 168190 shouldnt: [ self elementNotInForIndexAccessing ] 168191 raise: Error. 168192 self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! 168193 168194!IntervalTest methodsFor: 'tests - fixture'! 168195test0FixtureIterateSequencedReadableTest 168196 168197 | res | 168198 168199 self shouldnt: self nonEmptyMoreThan1Element raise: Error. 168200 self assert: self nonEmptyMoreThan1Element size > 1. 168201 168202 168203 self shouldnt: self empty raise: Error. 168204 self assert: self empty isEmpty . 168205 168206 res := true. 168207 self nonEmptyMoreThan1Element 168208 detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] 168209 ifNone: [ res := false ]. 168210 self assert: res = false.! ! 168211 168212!IntervalTest methodsFor: 'tests - fixture'! 168213test0FixtureOccurrencesTest 168214 | tmp | 168215 self shouldnt: [self empty ]raise: Error. 168216 self assert: self empty isEmpty. 168217 168218 self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. 168219 self deny: self collectionWithoutEqualElements isEmpty. 168220 168221 tmp := OrderedCollection new. 168222 self collectionWithoutEqualElements do: [ 168223 :each | 168224 self deny: (tmp includes: each). 168225 tmp add: each. 168226 ]. 168227 168228 168229 self shouldnt: [ self elementNotInForOccurrences ] raise: Error. 168230 self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! 168231 168232!IntervalTest methodsFor: 'tests - fixture'! 168233test0FixturePrintTest 168234 168235 self shouldnt: [self nonEmpty ] raise: Error.! ! 168236 168237!IntervalTest methodsFor: 'tests - fixture'! 168238test0FixtureSequencedConcatenationTest 168239 self 168240 shouldnt: self empty 168241 raise: Exception. 168242 self assert: self empty isEmpty. 168243 self 168244 shouldnt: self firstCollection 168245 raise: Exception. 168246 self 168247 shouldnt: self secondCollection 168248 raise: Exception! ! 168249 168250!IntervalTest methodsFor: 'tests - fixture'! 168251test0FixtureSequencedElementAccessTest 168252 self 168253 shouldnt: [ self moreThan4Elements ] 168254 raise: Error. 168255 self assert: self moreThan4Elements size >= 4. 168256 self 168257 shouldnt: [ self subCollectionNotIn ] 168258 raise: Error. 168259 self subCollectionNotIn 168260 detect: [ :each | (self moreThan4Elements includes: each) not ] 168261 ifNone: [ self assert: false ]. 168262 self 168263 shouldnt: [ self elementNotInForElementAccessing ] 168264 raise: Error. 168265 self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). 168266 self 168267 shouldnt: [ self elementInForElementAccessing ] 168268 raise: Error. 168269 self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! 168270 168271!IntervalTest methodsFor: 'tests - fixture'! 168272test0FixtureSubcollectionAccessTest 168273 self 168274 shouldnt: [ self moreThan3Elements ] 168275 raise: Error. 168276 self assert: self moreThan3Elements size > 2! ! 168277 168278!IntervalTest methodsFor: 'tests - fixture'! 168279test0FixtureTConvertTest 168280 "a collection of number without equal elements:" 168281 | res | 168282 self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. 168283 168284 res := true. 168285 self collectionWithoutEqualElements 168286 detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] 168287 ifNone: [ res := false ]. 168288 self assert: res = false. 168289 168290 168291! ! 168292 168293!IntervalTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/15/2009 14:07'! 168294test0IndexAccessingTest 168295 self 168296 shouldnt: [ self accessCollection ] 168297 raise: Error. 168298 self assert: self accessCollection size = 5. 168299 self 168300 shouldnt: [ self subCollectionNotIn ] 168301 raise: Error. 168302 self subCollectionNotIn 168303 detect: [ :each | (self accessCollection includes: each) not ] 168304 ifNone: [ self assert: false ]. 168305 self 168306 shouldnt: [ self elementNotInForIndexAccessing ] 168307 raise: Error. 168308 self deny: (self accessCollection includes: self elementNotInForIndexAccessing). 168309 self 168310 shouldnt: [ self elementInForIndexAccessing ] 168311 raise: Error. 168312 self assert: (self accessCollection includes: self elementInForIndexAccessing). 168313 self 168314 shouldnt: [ self collectionOfFloat ] 168315 raise: Error. 168316 self collectionOfFloat do: [ :each | self deny: each class = SmallInteger ]! ! 168317 168318!IntervalTest methodsFor: 'tests - fixture'! 168319test0TSequencedStructuralEqualityTest 168320 168321 self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! 168322 168323!IntervalTest methodsFor: 'tests - fixture'! 168324test0TStructuralEqualityTest 168325 self shouldnt: [self empty] raise: Error. 168326 self shouldnt: [self nonEmpty] raise: Error. 168327 self assert: self empty isEmpty. 168328 self deny: self nonEmpty isEmpty.! ! 168329 168330 168331!IntervalTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! 168332testIdentityIncludes 168333 " test the comportement in presence of elements 'includes' but not 'identityIncludes' " 168334 " can not be used by collections that can't include elements for wich copy doesn't return another instance " 168335 | collection element | 168336 self 168337 shouldnt: [ self collectionWithCopyNonIdentical ] 168338 raise: Error. 168339 collection := self collectionWithCopyNonIdentical. 168340 element := collection anyOne copy. 168341 "self assert: (collection includes: element)." 168342 self deny: (collection identityIncludes: element)! ! 168343 168344!IntervalTest methodsFor: 'tests - includes'! 168345testIdentityIncludesNonSpecificComportement 168346 " test the same comportement than 'includes: ' " 168347 | collection | 168348 collection := self nonEmpty . 168349 168350 self deny: (collection identityIncludes: self elementNotIn ). 168351 self assert:(collection identityIncludes: collection anyOne) 168352! ! 168353 168354!IntervalTest methodsFor: 'tests - includes'! 168355testIncludesAllOfAllThere 168356 "self debug: #testIncludesAllOfAllThere'" 168357 self assert: (self empty includesAllOf: self empty). 168358 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 168359 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 168360 168361!IntervalTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 168362testIncludesAllOfNoneThere 168363 "self debug: #testIncludesAllOfNoneThere'" 168364 self deny: (self empty includesAllOf: self collection). 168365 self deny: (self nonEmpty includesAllOf: { 168366 (self elementNotIn). 168367 (self anotherElementNotIn) 168368 })! ! 168369 168370!IntervalTest methodsFor: 'tests - includes'! 168371testIncludesAnyOfAllThere 168372 "self debug: #testIncludesAnyOfAllThere'" 168373 self deny: (self nonEmpty includesAnyOf: self empty). 168374 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 168375 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 168376 168377!IntervalTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 168378testIncludesAnyOfNoneThere 168379 "self debug: #testIncludesAnyOfNoneThere'" 168380 self deny: (self nonEmpty includesAnyOf: self empty). 168381 self deny: (self nonEmpty includesAnyOf: { 168382 (self elementNotIn). 168383 (self anotherElementNotIn) 168384 })! ! 168385 168386!IntervalTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 168387testIncludesElementIsNotThere 168388 "self debug: #testIncludesElementIsNotThere" 168389 self deny: (self nonEmpty includes: self elementNotInForOccurrences). 168390 self assert: (self nonEmpty includes: self nonEmpty anyOne). 168391 self deny: (self empty includes: self elementNotInForOccurrences)! ! 168392 168393!IntervalTest methodsFor: 'tests - includes'! 168394testIncludesElementIsThere 168395 "self debug: #testIncludesElementIsThere" 168396 168397 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 168398 168399!IntervalTest methodsFor: 'tests - includes' stamp: 'delaunay 4/9/2009 10:44'! 168400testIncludesSubstringAnywhere 168401 "self debug: #testIncludesSubstringAnywher'" 168402 self assert: (self empty includesAllOf: self empty). 168403 self assert: (self nonEmpty includesAllOf: { (self nonEmpty anyOne) }). 168404 self assert: (self nonEmpty includesAllOf: self nonEmpty)! ! 168405 168406 168407!IntervalTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 168408testIdentityIndexOf 168409 "self debug: #testIdentityIndexOf" 168410 | collection element | 168411 collection := self collectionMoreThan1NoDuplicates. 168412 element := collection first. 168413 self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! 168414 168415!IntervalTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 168416testIdentityIndexOfIAbsent 168417 | collection element | 168418 collection := self collectionMoreThan1NoDuplicates. 168419 element := collection first. 168420 self assert: (collection 168421 identityIndexOf: element 168422 ifAbsent: [ 0 ]) = 1. 168423 self assert: (collection 168424 identityIndexOf: self elementNotInForIndexAccessing 168425 ifAbsent: [ 55 ]) = 55! ! 168426 168427!IntervalTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 168428testIndexOf 168429 "self debug: #testIndexOf" 168430 | tmp index collection | 168431 collection := self collectionMoreThan1NoDuplicates. 168432 tmp := collection size. 168433 collection reverseDo: 168434 [ :each | 168435 each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. 168436 tmp := tmp - 1 ]. 168437 self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! 168438 168439!IntervalTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 168440testIndexOfIfAbsent 168441 "self debug: #testIndexOfIfAbsent" 168442 | collection | 168443 collection := self collectionMoreThan1NoDuplicates. 168444 self assert: (collection 168445 indexOf: collection first 168446 ifAbsent: [ 33 ]) = 1. 168447 self assert: (collection 168448 indexOf: self elementNotInForIndexAccessing 168449 ifAbsent: [ 33 ]) = 33! ! 168450 168451!IntervalTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 168452testIndexOfStartingAt 168453 "self debug: #testLastIndexOf" 168454 | element collection | 168455 collection := self collectionMoreThan1NoDuplicates. 168456 element := collection first. 168457 self assert: (collection 168458 indexOf: element 168459 startingAt: 2 168460 ifAbsent: [ 99 ]) = 99. 168461 self assert: (collection 168462 indexOf: element 168463 startingAt: 1 168464 ifAbsent: [ 99 ]) = 1. 168465 self assert: (collection 168466 indexOf: self elementNotInForIndexAccessing 168467 startingAt: 1 168468 ifAbsent: [ 99 ]) = 99! ! 168469 168470!IntervalTest methodsFor: 'tests - index access'! 168471testIndexOfStartingAtIfAbsent 168472 "self debug: #testLastIndexOf" 168473 | element collection | 168474 collection := self collectionMoreThan1NoDuplicates. 168475 element := collection first. 168476 self assert: (collection 168477 indexOf: element 168478 startingAt: 2 168479 ifAbsent: [ 99 ]) = 99. 168480 self assert: (collection 168481 indexOf: element 168482 startingAt: 1 168483 ifAbsent: [ 99 ]) = 1. 168484 self assert: (collection 168485 indexOf: self elementNotInForIndexAccessing 168486 startingAt: 1 168487 ifAbsent: [ 99 ]) = 99! ! 168488 168489!IntervalTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 168490testIndexOfSubCollectionStartingAt 168491 "self debug: #testIndexOfIfAbsent" 168492 | subcollection index collection | 168493 collection := self collectionMoreThan1NoDuplicates. 168494 subcollection := self collectionMoreThan1NoDuplicates. 168495 index := collection 168496 indexOfSubCollection: subcollection 168497 startingAt: 1. 168498 self assert: index = 1. 168499 index := collection 168500 indexOfSubCollection: subcollection 168501 startingAt: 2. 168502 self assert: index = 0! ! 168503 168504!IntervalTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 168505testIndexOfSubCollectionStartingAtIfAbsent 168506 "self debug: #testIndexOfIfAbsent" 168507 | index absent subcollection collection | 168508 collection := self collectionMoreThan1NoDuplicates. 168509 subcollection := self collectionMoreThan1NoDuplicates. 168510 absent := false. 168511 index := collection 168512 indexOfSubCollection: subcollection 168513 startingAt: 1 168514 ifAbsent: [ absent := true ]. 168515 self assert: absent = false. 168516 absent := false. 168517 index := collection 168518 indexOfSubCollection: subcollection 168519 startingAt: 2 168520 ifAbsent: [ absent := true ]. 168521 self assert: absent = true! ! 168522 168523!IntervalTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 168524testLastIndexOf 168525 "self debug: #testLastIndexOf" 168526 | element collection | 168527 collection := self collectionMoreThan1NoDuplicates. 168528 element := collection first. 168529 self assert: (collection lastIndexOf: element) = 1. 168530 self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! 168531 168532!IntervalTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 168533testLastIndexOfIfAbsent 168534 "self debug: #testIndexOfIfAbsent" 168535 | element collection | 168536 collection := self collectionMoreThan1NoDuplicates. 168537 element := collection first. 168538 self assert: (collection 168539 lastIndexOf: element 168540 ifAbsent: [ 99 ]) = 1. 168541 self assert: (collection 168542 lastIndexOf: self elementNotInForIndexAccessing 168543 ifAbsent: [ 99 ]) = 99! ! 168544 168545!IntervalTest methodsFor: 'tests - index access'! 168546testLastIndexOfStartingAt 168547 "self debug: #testLastIndexOf" 168548 | element collection | 168549 collection := self collectionMoreThan1NoDuplicates. 168550 element := collection last. 168551 self assert: (collection 168552 lastIndexOf: element 168553 startingAt: collection size 168554 ifAbsent: [ 99 ]) = collection size. 168555 self assert: (collection 168556 lastIndexOf: element 168557 startingAt: collection size - 1 168558 ifAbsent: [ 99 ]) = 99. 168559 self assert: (collection 168560 lastIndexOf: self elementNotInForIndexAccessing 168561 startingAt: collection size 168562 ifAbsent: [ 99 ]) = 99! ! 168563 168564 168565!IntervalTest methodsFor: 'tests - indexable access' stamp: 'delaunay 4/6/2009 15:24'! 168566testAllButFirstElements 168567 "self debug: #testAllButFirst" 168568 | abf col | 168569 col := self accessCollection. 168570 abf := col allButFirst: 2. 168571 1 168572 to: abf size 168573 do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. 168574 self assert: abf size + 2 = col size! ! 168575 168576!IntervalTest methodsFor: 'tests - indexable access' stamp: 'delaunay 4/6/2009 15:25'! 168577testAllButLastElements 168578 "self debug: #testAllButFirst" 168579 | abf col | 168580 col := self accessCollection. 168581 abf := col allButLast: 2. 168582 1 168583 to: abf size 168584 do: [ :i | self assert: (abf at: i) = (col at: i) ]. 168585 self assert: abf size + 2 = col size! ! 168586 168587!IntervalTest methodsFor: 'tests - indexable access' stamp: 'delaunay 4/10/2009 16:20'! 168588testAtWrap 168589 "self debug: #testAt" 168590 " 168591 self assert: (self accessCollection at: 1) = 1. 168592 self assert: (self accessCollection at: 2) = 2. 168593 " 168594 | index | 168595 index := self accessCollection indexOf: self elementInForIndexAccessing. 168596 self assert: (self accessCollection atWrap: index) = self elementInForIndexAccessing. 168597 self assert: (self accessCollection atWrap: index + self accessCollection size) = self elementInForIndexAccessing. 168598 self assert: (self accessCollection atWrap: index - self accessCollection size) = self elementInForIndexAccessing. 168599 self assert: (self accessCollection atWrap: 1 + self accessCollection size) = (self accessCollection at: 1)! ! 168600 168601 168602!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168603testAllButFirstDo 168604 168605 | result | 168606 result:= OrderedCollection new. 168607 168608 self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 168609 168610 1 to: (result size) do: 168611 [:i| 168612 self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. 168613 168614 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 168615 168616!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168617testAllButLastDo 168618 168619 | result | 168620 result:= OrderedCollection new. 168621 168622 self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 168623 168624 1 to: (result size) do: 168625 [:i| 168626 self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. 168627 168628 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 168629 168630!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168631testCollectFromTo 168632 168633 | result | 168634 result:=self nonEmptyMoreThan1Element 168635 collect: [ :each | each ] 168636 from: 1 168637 to: (self nonEmptyMoreThan1Element size - 1). 168638 168639 1 to: result size 168640 do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. 168641 self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! 168642 168643!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168644testDetectSequenced 168645" testing that detect keep the first element returning true for sequenceable collections " 168646 168647 | element result | 168648 element := self nonEmptyMoreThan1Element at:1. 168649 result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. 168650 self assert: result = element. ! ! 168651 168652!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168653testFindFirst 168654 168655 | element result | 168656 element := self nonEmptyMoreThan1Element at:1. 168657 result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. 168658 168659 self assert: result=1. ! ! 168660 168661!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168662testFindFirstNotIn 168663 168664 | result | 168665 168666 result:=self empty findFirst: [:each | true]. 168667 168668 self assert: result=0. ! ! 168669 168670!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168671testFindLast 168672 168673 | element result | 168674 element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. 168675 result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. 168676 168677 self assert: result=self nonEmptyMoreThan1Element size. ! ! 168678 168679!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168680testFindLastNotIn 168681 168682 | result | 168683 168684 result:=self empty findFirst: [:each | true]. 168685 168686 self assert: result=0. ! ! 168687 168688!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168689testFromToDo 168690 168691 | result | 168692 result:= OrderedCollection new. 168693 168694 self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 168695 168696 1 to: (self nonEmptyMoreThan1Element size -1) do: 168697 [:i| 168698 self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. 168699 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 168700 168701!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168702testKeysAndValuesDo 168703 "| result | 168704 result:= OrderedCollection new. 168705 168706 self nonEmptyMoreThan1Element keysAndValuesDo: 168707 [:i :value| 168708 result add: (value+i)]. 168709 168710 1 to: result size do: 168711 [:i| 168712 self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" 168713 | indexes elements | 168714 indexes:= OrderedCollection new. 168715 elements := OrderedCollection new. 168716 168717 self nonEmptyMoreThan1Element keysAndValuesDo: 168718 [:i :value| 168719 indexes add: (i). 168720 elements add: value]. 168721 168722 (1 to: self nonEmptyMoreThan1Element size )do: 168723 [ :i | 168724 self assert: (indexes at: i) = i. 168725 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 168726 ]. 168727 168728 self assert: indexes size = elements size. 168729 self assert: indexes size = self nonEmptyMoreThan1Element size . 168730 168731 ! ! 168732 168733!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168734testKeysAndValuesDoEmpty 168735 | result | 168736 result:= OrderedCollection new. 168737 168738 self empty keysAndValuesDo: 168739 [:i :value| 168740 result add: (value+i)]. 168741 168742 self assert: result isEmpty .! ! 168743 168744!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168745testPairsCollect 168746 168747 | index result | 168748 index:=0. 168749 168750 result:=self nonEmptyMoreThan1Element pairsCollect: 168751 [:each1 :each2 | 168752 self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). 168753 (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). 168754 ]. 168755 168756 result do: 168757 [:each | self assert: each = true]. 168758 168759! ! 168760 168761!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168762testPairsDo 168763 | index | 168764 index:=1. 168765 168766 self nonEmptyMoreThan1Element pairsDo: 168767 [:each1 :each2 | 168768 self assert:(self nonEmptyMoreThan1Element at:index)=each1. 168769 self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. 168770 index:=index+2]. 168771 168772 self nonEmptyMoreThan1Element size odd 168773 ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] 168774 ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! 168775 168776!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168777testReverseDoEmpty 168778 | result | 168779 result:= OrderedCollection new. 168780 self empty reverseDo: [: each | result add: each]. 168781 168782 self assert: result isEmpty .! ! 168783 168784!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168785testReverseWithDo 168786 168787 | secondCollection result index | 168788 result:= OrderedCollection new. 168789 index := self nonEmptyMoreThan1Element size + 1. 168790 secondCollection:= self nonEmptyMoreThan1Element copy. 168791 168792 self nonEmptyMoreThan1Element reverseWith: secondCollection do: 168793 [:a :b | 168794 self assert: (self nonEmptyMoreThan1Element indexOf: a ) = (index := index - 1 ). 168795 result add: (a = b)]. 168796 168797 1 to: result size do: 168798 [:i| 168799 self assert: (result at:i)=(true)]. 168800 self assert: result size = self nonEmptyMoreThan1Element size.! ! 168801 168802!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168803testWithCollect 168804 168805 | result newCollection index collection | 168806 168807 index := 0. 168808 collection := self nonEmptyMoreThan1Element . 168809 newCollection := collection copy. 168810 result:=collection with: newCollection collect: [:a :b | 168811 self assert: (collection indexOf: a ) = ( index := index + 1). 168812 self assert: (a = b). 168813 b]. 168814 168815 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 168816 self assert: result size = collection size.! ! 168817 168818!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168819testWithCollectError 168820 self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! 168821 168822!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168823testWithDo 168824 168825 | secondCollection result index | 168826 result:= OrderedCollection new. 168827 secondCollection:= self nonEmptyMoreThan1Element copy. 168828 index := 0. 168829 168830 self nonEmptyMoreThan1Element with: secondCollection do: 168831 [:a :b | 168832 self assert: (self nonEmptyMoreThan1Element indexOf: a) = ( index := index + 1). 168833 result add: (a =b)]. 168834 168835 1 to: result size do: 168836 [:i| 168837 self assert: (result at:i)=(true)]. 168838 self assert: result size = self nonEmptyMoreThan1Element size.! ! 168839 168840!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168841testWithDoError 168842 168843 self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! 168844 168845!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168846testWithIndexCollect 168847 168848 | result index collection | 168849 index := 0. 168850 collection := self nonEmptyMoreThan1Element . 168851 result := collection withIndexCollect: [:each :i | 168852 self assert: i = (index := index + 1). 168853 self assert: i = (collection indexOf: each) . 168854 each] . 168855 168856 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 168857 self assert: result size = collection size.! ! 168858 168859!IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 168860testWithIndexDo 168861 168862 "| result | 168863 result:=Array new: self nonEmptyMoreThan1Element size. 168864 self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 168865 168866 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" 168867 | indexes elements | 168868 indexes:= OrderedCollection new. 168869 elements := OrderedCollection new. 168870 168871 self nonEmptyMoreThan1Element withIndexDo: 168872 [:value :i | 168873 indexes add: (i). 168874 elements add: value]. 168875 168876 (1 to: self nonEmptyMoreThan1Element size )do: 168877 [ :i | 168878 self assert: (indexes at: i) = i. 168879 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 168880 ]. 168881 168882 self assert: indexes size = elements size. 168883 self assert: indexes size = self nonEmptyMoreThan1Element size . 168884 ! ! 168885 168886 168887!IntervalTest methodsFor: 'tests - occurrencesOf'! 168888testOccurrencesOf 168889 | collection | 168890 collection := self collectionWithoutEqualElements . 168891 168892 collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! 168893 168894!IntervalTest methodsFor: 'tests - occurrencesOf'! 168895testOccurrencesOfEmpty 168896 | result | 168897 result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). 168898 self assert: result = 0! ! 168899 168900!IntervalTest methodsFor: 'tests - occurrencesOf'! 168901testOccurrencesOfNotIn 168902 | result | 168903 result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. 168904 self assert: result = 0! ! 168905 168906 168907!IntervalTest methodsFor: 'tests - printing'! 168908testPrintElementsOn 168909 168910 | aStream result allElementsAsString | 168911 result:=''. 168912 aStream:= ReadWriteStream on: result. 168913 168914 self nonEmpty printElementsOn: aStream . 168915 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 168916 1 to: allElementsAsString size do: 168917 [:i | 168918 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 168919 ].! ! 168920 168921!IntervalTest methodsFor: 'tests - printing'! 168922testPrintNameOn 168923 168924 | aStream result | 168925 result:=''. 168926 aStream:= ReadWriteStream on: result. 168927 168928 self nonEmpty printNameOn: aStream . 168929 Transcript show: result asString. 168930 self nonEmpty class name first isVowel 168931 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 168932 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 168933 168934!IntervalTest methodsFor: 'tests - printing'! 168935testPrintOn 168936 | aStream result allElementsAsString | 168937 result:=''. 168938 aStream:= ReadWriteStream on: result. 168939 168940 self nonEmpty printOn: aStream . 168941 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 168942 1 to: allElementsAsString size do: 168943 [:i | 168944 i=1 168945 ifTrue:[ 168946 self accessCollection class name first isVowel 168947 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 168948 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 168949 i=2 168950 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 168951 i>2 168952 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. 168953 ].! ! 168954 168955!IntervalTest methodsFor: 'tests - printing'! 168956testPrintOnDelimiter 168957 | aStream result allElementsAsString | 168958 result:=''. 168959 aStream:= ReadWriteStream on: result. 168960 168961 self nonEmpty printOn: aStream delimiter: ', ' . 168962 168963 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 168964 1 to: allElementsAsString size do: 168965 [:i | 168966 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 168967 ].! ! 168968 168969!IntervalTest methodsFor: 'tests - printing'! 168970testPrintOnDelimiterLast 168971 168972 | aStream result allElementsAsString | 168973 result:=''. 168974 aStream:= ReadWriteStream on: result. 168975 168976 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 168977 168978 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 168979 1 to: allElementsAsString size do: 168980 [:i | 168981 i<(allElementsAsString size-1 ) 168982 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 168983 i=(allElementsAsString size-1) 168984 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 168985 i=(allElementsAsString size) 168986 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 168987 ].! ! 168988 168989!IntervalTest methodsFor: 'tests - printing'! 168990testStoreOn 168991" for the moment work only for collection that include simple elements such that Integer" 168992 168993"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 168994string := ''. 168995str := ReadWriteStream on: string. 168996elementsAsStringExpected := OrderedCollection new. 168997elementsAsStringObtained := OrderedCollection new. 168998self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 168999 169000self nonEmpty storeOn: str. 169001result := str contents . 169002cuttedResult := ( result findBetweenSubStrs: ';' ). 169003 169004index := 1. 169005 169006cuttedResult do: 169007 [ :each | 169008 index = 1 169009 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 169010 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 169011 elementsAsStringObtained add: tmp. 169012 index := index + 1. ] 169013 ifFalse: [ 169014 index < cuttedResult size 169015 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 169016 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 169017 elementsAsStringObtained add: tmp. 169018 index := index + 1.] 169019 ifFalse: [self assert: ( each = ' yourself)' ) ]. 169020 ] 169021 169022 ]. 169023 169024 169025 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 169026 169027! ! 169028 169029 169030!IntervalTest methodsFor: 'tests - subcollections access'! 169031testAllButFirst 169032 "self debug: #testAllButFirst" 169033 | abf col | 169034 col := self moreThan3Elements. 169035 abf := col allButFirst. 169036 self deny: abf first = col first. 169037 self assert: abf size + 1 = col size! ! 169038 169039!IntervalTest methodsFor: 'tests - subcollections access'! 169040testAllButFirstNElements 169041 "self debug: #testAllButFirst" 169042 | abf col | 169043 col := self moreThan3Elements. 169044 abf := col allButFirst: 2. 169045 1 169046 to: abf size 169047 do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. 169048 self assert: abf size + 2 = col size! ! 169049 169050!IntervalTest methodsFor: 'tests - subcollections access'! 169051testAllButLast 169052 "self debug: #testAllButLast" 169053 | abf col | 169054 col := self moreThan3Elements. 169055 abf := col allButLast. 169056 self deny: abf last = col last. 169057 self assert: abf size + 1 = col size! ! 169058 169059!IntervalTest methodsFor: 'tests - subcollections access'! 169060testAllButLastNElements 169061 "self debug: #testAllButFirst" 169062 | abf col | 169063 col := self moreThan3Elements. 169064 abf := col allButLast: 2. 169065 1 169066 to: abf size 169067 do: [ :i | self assert: (abf at: i) = (col at: i) ]. 169068 self assert: abf size + 2 = col size! ! 169069 169070!IntervalTest methodsFor: 'tests - subcollections access'! 169071testFirstNElements 169072 "self debug: #testFirstNElements" 169073 | result | 169074 result := self moreThan3Elements first: self moreThan3Elements size - 1. 169075 1 169076 to: result size 169077 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. 169078 self assert: result size = (self moreThan3Elements size - 1). 169079 self 169080 should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] 169081 raise: Error! ! 169082 169083!IntervalTest methodsFor: 'tests - subcollections access'! 169084testLastNElements 169085 "self debug: #testLastNElements" 169086 | result | 169087 result := self moreThan3Elements last: self moreThan3Elements size - 1. 169088 1 169089 to: result size 169090 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. 169091 self assert: result size = (self moreThan3Elements size - 1). 169092 self 169093 should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] 169094 raise: Error! ! 169095 169096"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 169097 169098IntervalTest class 169099 uses: TCloneTest classTrait + TSequencedElementAccessTest classTrait + TIterateSequencedReadableTest classTrait + TSequencedConcatenationTest classTrait + TSubCollectionAccess classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TIndexAccess classTrait + TPrintOnSequencedTest classTrait + TConvertTest classTrait + TCopySequenceableWithReplacement classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopySequenceableSameContents classTrait + TCopyPartOfSequenceable classTrait + TCopyTest classTrait + TBeginsEndsWith classTrait + TConvertAsSortedTest classTrait + TIncludesWithIdentityCheckTest classTrait + TSequencedStructuralEqualityTest classTrait + TOccurrencesTest classTrait 169100 instanceVariableNames: ''! 169101Error subclass: #InvalidDirectoryError 169102 instanceVariableNames: 'pathName' 169103 classVariableNames: '' 169104 poolDictionaries: '' 169105 category: 'Exceptions-Kernel'! 169106 169107!InvalidDirectoryError methodsFor: 'accessing' stamp: 'ar 5/30/2001 20:44'! 169108pathName 169109 ^pathName! ! 169110 169111!InvalidDirectoryError methodsFor: 'accessing' stamp: 'ar 5/30/2001 20:45'! 169112pathName: badPathName 169113 pathName := badPathName! ! 169114 169115 169116!InvalidDirectoryError methodsFor: 'exceptiondescription' stamp: 'StephaneDucasse 8/30/2009 16:54'! 169117defaultAction 169118 169119 ^#()! ! 169120 169121"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 169122 169123InvalidDirectoryError class 169124 instanceVariableNames: ''! 169125 169126!InvalidDirectoryError class methodsFor: 'exceptioninstantiator' stamp: 'ar 5/30/2001 20:49'! 169127pathName: badPathName 169128 ^self new pathName: badPathName! ! 169129Error subclass: #InvalidSocketStatusException 169130 instanceVariableNames: '' 169131 classVariableNames: '' 169132 poolDictionaries: '' 169133 category: 'Network-Kernel'! 169134!InvalidSocketStatusException commentStamp: 'mir 5/12/2003 18:15' prior: 0! 169135Signals if an operation on a Socket found it in a state invalid for that operation. 169136! 169137 169138TestCase subclass: #IslandVMTweaksTestCase 169139 instanceVariableNames: '' 169140 classVariableNames: '' 169141 poolDictionaries: '' 169142 category: 'Tests-VM'! 169143!IslandVMTweaksTestCase commentStamp: 'ls 7/10/2003 18:59' prior: 0! 169144Test case for some tweaks to the VM that Islands requires. These tests are largely for documentation; with an un-tweaked VM, the tests mostly still succeed, albeit with possible memory corruption.! 169145 169146 169147!IslandVMTweaksTestCase methodsFor: 'miscellaneous' stamp: 'ls 7/10/2003 17:42'! 169148returnTwelve 169149 "this method is tweaked by testFlagInCompiledMethod" 169150 ^12! ! 169151 169152 169153!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:16'! 169154aaaREADMEaboutPrimitives 169155 "most of the Islands tweaks allow primitive methods to be located in places other than class Object. Thus they are copied here for testing." 169156! ! 169157 169158!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:17'! 169159classOf: anObject 169160 <primitive: 111> 169161! ! 169162 169163!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:16'! 169164instVarOf: anObject at: index 169165 <primitive: 73> 169166 self primitiveFailed 169167! ! 169168 169169!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:17'! 169170instVarOf: anObject at: index put: anotherObject 169171 <primitive: 74> 169172 self primitiveFailed 169173! ! 169174 169175!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:18'! 169176nextInstanceAfter: anObject 169177 <primitive: 78> 169178! ! 169179 169180!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:18'! 169181nextObjectAfter: anObject 169182 <primitive: 139> 169183! ! 169184 169185!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:21'! 169186replaceIn: replacee from: start to: stop with: replacer startingAt: replStart 169187 <primitive: 105> 169188 self primitiveFailed! ! 169189 169190!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:19'! 169191someInstanceOf: aClass 169192 <primitive: 77> 169193 self primitiveFailed! ! 169194 169195!IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:20'! 169196someObject 169197 <primitive: 138> 169198 self primitiveFailed! ! 169199 169200 169201!IslandVMTweaksTestCase methodsFor: 'testing' stamp: 'ls 7/10/2003 11:03'! 169202testEmptyReplace 169203 | array1 array2 | 169204 array1 := Array with: 1 with: 2 with: 3 with: 4. 169205 array2 := Array with: 5 with: 6 with: 7. 169206 169207 self replaceIn: array1 from: 1 to: 0 with: array2 startingAt: 1. 169208 self should: [ array1 = #(1 2 3 4) ]. 169209! ! 169210 169211!IslandVMTweaksTestCase methodsFor: 'testing' stamp: 'ls 7/10/2003 18:53'! 169212testFlagInCompiledMethod 169213 "this tests that the flag in compiled methods is treated correctly" 169214 | method | 169215 method := self class compiledMethodAt: #returnTwelve. 169216 169217 "turn off the flag" 169218 method objectAt: 1 put: (method header bitAnd: (1 << 29) bitInvert). 169219 self should: [ method flag not ]. 169220 169221 "turn on the flag" 169222 method objectAt: 1 put: (method header bitOr: (1 << 29)). 169223 self should: [ method flag ]. 169224 169225 "try running the method with the flag turned on" 169226 self should: [ self returnTwelve = 12 ]. 169227 169228 169229 "make sure the flag bit isn't interpreted as a primitive" 169230 self should: [ method primitive = 0 ].! ! 169231 169232!IslandVMTweaksTestCase methodsFor: 'testing' stamp: 'ls 7/10/2003 10:38'! 169233testForgivingPrims 169234 | aPoint anotherPoint array1 array2 | 169235 aPoint := Point x: 5 y: 6. 169236 anotherPoint := Point x: 7 y: 8. "make sure there are multiple points floating around" 169237 anotherPoint. "stop the compiler complaining about no uses" 169238 169239 self should: [ (self classOf: aPoint) = Point ]. 169240 self should: [ (self instVarOf: aPoint at: 1) = 5 ]. 169241 self instVarOf: aPoint at: 2 put: 10. 169242 self should: [ (self instVarOf: aPoint at: 2) = 10 ]. 169243 169244 self someObject. 169245 self nextObjectAfter: aPoint. 169246 169247 self should: [ (self someInstanceOf: Point) class = Point ]. 169248 self should: [ (self nextInstanceAfter: aPoint) class = Point ]. 169249 169250 169251 array1 := Array with: 1 with: 2 with: 3. 169252 array2 := Array with: 4 with: 5 with: 6. 169253 169254 self replaceIn: array1 from: 2 to: 3 with: array2 startingAt: 1. 169255 self should: [ array1 = #(1 4 5) ]. 169256 169257! ! 169258EncodedCharSet subclass: #JISX0208 169259 instanceVariableNames: '' 169260 classVariableNames: '' 169261 poolDictionaries: '' 169262 category: 'Multilingual-Encodings'! 169263!JISX0208 commentStamp: 'yo 10/19/2004 19:52' prior: 0! 169264This class represents the domestic character encoding called JIS X 0208 used for Japanese.! 169265 169266 169267"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 169268 169269JISX0208 class 169270 instanceVariableNames: ''! 169271 169272!JISX0208 class methodsFor: 'accessing - displaying' stamp: 'yo 3/18/2003 11:11'! 169273isBreakableAt: index in: text 169274 169275 | prev | 169276 index = 1 ifTrue: [^ false]. 169277 prev := text at: index - 1. 169278 prev leadingChar ~= 1 ifTrue: [^ true]. 169279 ^ false 169280! ! 169281 169282 169283!JISX0208 class methodsFor: 'character classification' stamp: 'yo 8/6/2003 05:30'! 169284isLetter: char 169285 169286 | value leading | 169287 169288 leading := char leadingChar. 169289 value := char charCode. 169290 169291 leading = 0 ifTrue: [^ super isLetter: char]. 169292 169293 value := value // 94 + 1. 169294 ^ 1 <= value and: [value < 84]. 169295! ! 169296 169297 169298!JISX0208 class methodsFor: 'class methods' stamp: 'ar 4/9/2005 22:31'! 169299charAtKuten: anInteger 169300 169301 | a b | 169302 a := anInteger \\ 100. 169303 b := anInteger // 100. 169304 (a > 94) | (b > 94) ifTrue: [ 169305 self error: 'character code is not valid'. 169306 ]. 169307 ^ Character leadingChar: self leadingChar code: ((b - 1) * 94) + a - 1. 169308! ! 169309 169310!JISX0208 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! 169311compoundTextSequence 169312 ^ compoundTextSequence! ! 169313 169314!JISX0208 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! 169315initialize 169316 " 169317 self initialize 169318" 169319 compoundTextSequence := String streamContents: 169320 [ :s | 169321 s nextPut: (Character value: 27). 169322 s nextPut: $$. 169323 s nextPut: $B ]! ! 169324 169325!JISX0208 class methodsFor: 'class methods' stamp: 'yo 9/2/2002 17:38'! 169326leadingChar 169327 169328 ^ 1. 169329! ! 169330 169331!JISX0208 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! 169332nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state 169333 | c1 c2 | 169334 state charSize: 2. 169335 state g0Leading ~= self leadingChar ifTrue: 169336 [ state g0Leading: self leadingChar. 169337 state g0Size: 2. 169338 aStream basicNextPutAll: compoundTextSequence ]. 169339 c1 := ascii // 94 + 33. 169340 c2 := ascii \\ 94 + 33. 169341 ^ aStream 169342 basicNextPut: (Character value: c1); 169343 basicNextPut: (Character value: c2)! ! 169344 169345!JISX0208 class methodsFor: 'class methods' stamp: 'yo 9/4/2002 22:52'! 169346printingDirection 169347 169348 ^ #right. 169349! ! 169350 169351!JISX0208 class methodsFor: 'class methods' stamp: 'ar 4/12/2005 17:34'! 169352stringFromKutenArray: anArray 169353 169354 | s | 169355 s := WideString new: anArray size. 169356 1 to: anArray size do: [:i | 169357 s at: i put: (self charAtKuten: (anArray at: i)). 169358 ]. 169359 ^s. 169360! ! 169361 169362!JISX0208 class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'! 169363ucsTable 169364 169365 ^ UCSTable jisx0208Table. 169366! ! 169367 169368!JISX0208 class methodsFor: 'class methods' stamp: 'yo 7/21/2004 18:36'! 169369unicodeLeadingChar 169370 169371 ^ JapaneseEnvironment leadingChar. 169372! ! 169373Object subclass: #JPEGColorComponent 169374 instanceVariableNames: 'currentX currentY hSampleFactor vSampleFactor mcuBlocks widthInBlocks heightInBlocks dctSize mcuWidth mcuHeight priorDCValue id qTableIndex dcTableIndex acTableIndex' 169375 classVariableNames: '' 169376 poolDictionaries: '' 169377 category: 'Graphics-Files'! 169378!JPEGColorComponent commentStamp: '<historical>' prior: 0! 169379I represent a single component of color in JPEG YCbCr color space. I can accept a list of blocks in my component from the current MCU, then stream the samples from this block for use in color conversion. I also store the running DC sample value for my component, used by the Huffman decoder. 169380 169381The following layout is fixed for the JPEG primitives to work: 169382 currentX <SmallInteger> 169383 currentY <SmallInteger> 169384 hSampleFactor <SmallInteger> 169385 vSampleFactor <SmallInteger> 169386 mcuBlocks <Array of: <IntegerArray of: DCTSize2 * Integer>> 169387 widthInBlocks <SmallInteger> 169388 heightInBlocks <SmallInteger> 169389 dctSize <SmallInteger> 169390 mcuWidth <SmallInteger> 169391 mcuHeight <SmallInteger> 169392 priorDCValue <SmallInteger> 169393! 169394 169395 169396!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:21'! 169397acTableIndex 169398 169399 ^acTableIndex! ! 169400 169401!JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169402acTableIndex: anInteger 169403 acTableIndex := anInteger! ! 169404 169405!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:21'! 169406dcTableIndex 169407 169408 ^dcTableIndex! ! 169409 169410!JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169411dcTableIndex: anInteger 169412 dcTableIndex := anInteger! ! 169413 169414!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:11'! 169415heightInBlocks 169416 169417 ^heightInBlocks! ! 169418 169419!JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169420heightInBlocks: anInteger 169421 heightInBlocks := anInteger! ! 169422 169423!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:09'! 169424id 169425 169426 ^id! ! 169427 169428!JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169429id: anObject 169430 id := anObject! ! 169431 169432!JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169433mcuWidth: mw mcuHeight: mh dctSize: ds 169434 mcuWidth := mw. 169435 mcuHeight := mh. 169436 dctSize := ds. 169437 hSampleFactor := mcuWidth // widthInBlocks. 169438 vSampleFactor := mcuHeight // heightInBlocks! ! 169439 169440!JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169441priorDCValue: aNumber 169442 priorDCValue := aNumber! ! 169443 169444!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:43'! 169445qTableIndex 169446 ^qTableIndex! ! 169447 169448!JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169449qTableIndex: anInteger 169450 qTableIndex := anInteger! ! 169451 169452!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:18'! 169453totalMcuBlocks 169454 169455 ^ heightInBlocks * widthInBlocks! ! 169456 169457!JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169458updateDCValue: aNumber 169459 priorDCValue := priorDCValue + aNumber. 169460 ^ priorDCValue! ! 169461 169462!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:11'! 169463widthInBlocks 169464 169465 ^widthInBlocks! ! 169466 169467!JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169468widthInBlocks: anInteger 169469 widthInBlocks := anInteger! ! 169470 169471 169472!JPEGColorComponent methodsFor: 'sample streaming' stamp: 'lr 7/4/2009 10:42'! 169473initializeSampleStreamBlocks: aCollection 169474 mcuBlocks := aCollection. 169475 self resetSampleStream! ! 169476 169477!JPEGColorComponent methodsFor: 'sample streaming' stamp: 'lr 7/4/2009 10:42'! 169478nextSample 169479 | dx dy blockIndex sampleIndex sample | 169480 dx := currentX // hSampleFactor. 169481 dy := currentY // vSampleFactor. 169482 blockIndex := dy // dctSize * widthInBlocks + (dx // dctSize) + 1. 169483 sampleIndex := dy \\ dctSize * dctSize + (dx \\ dctSize) + 1. 169484 sample := (mcuBlocks at: blockIndex) at: sampleIndex. 169485 currentX := currentX + 1. 169486 currentX < (mcuWidth * dctSize) ifFalse: 169487 [ currentX := 0. 169488 currentY := currentY + 1 ]. 169489 ^ sample! ! 169490 169491!JPEGColorComponent methodsFor: 'sample streaming' stamp: 'lr 7/4/2009 10:42'! 169492resetSampleStream 169493 currentX := 0. 169494 currentY := 0! ! 169495Object subclass: #JPEGHuffmanTable 169496 instanceVariableNames: 'bits values mincode maxcode valptr lookaheadBits lookaheadSymbol' 169497 classVariableNames: 'BitBufferSize Lookahead' 169498 poolDictionaries: '' 169499 category: 'Graphics-Files'! 169500!JPEGHuffmanTable commentStamp: '<historical>' prior: 0! 169501I represent the table of values used to decode Huffman entropy-encoded bitstreams. From the JFIF file header entropy values, I build a derived table of codes and values for faster decoding.! 169502 169503 169504!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169505bits: anObject 169506 bits := anObject! ! 169507 169508!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/21/97 23:31'! 169509lookaheadBits 169510 ^lookaheadBits! ! 169511 169512!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/21/97 23:38'! 169513lookaheadSymbol 169514 ^lookaheadSymbol! ! 169515 169516!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/21/97 23:59'! 169517maxcode 169518 ^maxcode! ! 169519 169520!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169521values: anObject 169522 values := anObject! ! 169523 169524 169525!JPEGHuffmanTable methodsFor: 'computation' stamp: 'lr 7/4/2009 10:42'! 169526makeDerivedTables 169527 | huffSize huffCode code si index lookbits | 169528 mincode := Array new: 16. 169529 maxcode := Array new: 17. 169530 valptr := Array new: 17. 169531 huffSize := OrderedCollection new. 169532 1 169533 to: 16 169534 do: 169535 [ :l | 169536 1 169537 to: (bits at: l) 169538 do: [ :i | huffSize add: l ] ]. 169539 huffSize add: 0. 169540 code := 0. 169541 huffCode := Array new: huffSize size. 169542 si := huffSize at: 1. 169543 index := 1. 169544 [ (huffSize at: index) ~= 0 ] whileTrue: 169545 [ [ (huffSize at: index) = si ] whileTrue: 169546 [ huffCode 169547 at: index 169548 put: code. 169549 index := index + 1. 169550 code := code + 1 ]. 169551 code := code << 1. 169552 si := si + 1 ]. 169553 index := 1. 169554 1 169555 to: 16 169556 do: 169557 [ :l | 169558 (bits at: l) ~= 0 169559 ifTrue: 169560 [ valptr 169561 at: l 169562 put: index. 169563 mincode 169564 at: l 169565 put: (huffCode at: index). 169566 index := index + (bits at: l). 169567 maxcode 169568 at: l 169569 put: (huffCode at: index - 1) ] 169570 ifFalse: 169571 [ maxcode 169572 at: l 169573 put: -1 ] ]. 169574 maxcode 169575 at: 17 169576 put: 1048575. 169577 lookaheadBits := (Array new: 1 << Lookahead) atAllPut: 0. 169578 lookaheadSymbol := Array new: 1 << Lookahead. 169579 index := 1. 169580 1 169581 to: Lookahead 169582 do: 169583 [ :l | 169584 1 169585 to: (bits at: l) 169586 do: 169587 [ :i | 169588 lookbits := ((huffCode at: index) << (Lookahead - l)) + 1. 169589 (1 << (Lookahead - l) 169590 to: 1 169591 by: -1) do: 169592 [ :ctr | 169593 lookaheadBits 169594 at: lookbits 169595 put: l. 169596 lookaheadSymbol 169597 at: lookbits 169598 put: (values at: index). 169599 lookbits := lookbits + 1 ]. 169600 index := index + 1 ] ]! ! 169601 169602!JPEGHuffmanTable methodsFor: 'computation' stamp: 'tao 10/21/97 22:44'! 169603valueForCode: code length: length 169604 169605 ^ values at: ((valptr at: length) + code - (mincode at: length))! ! 169606 169607"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 169608 169609JPEGHuffmanTable class 169610 instanceVariableNames: ''! 169611 169612!JPEGHuffmanTable class methodsFor: 'constants' stamp: 'tao 10/21/97 22:15'! 169613lookahead 169614 169615 ^ Lookahead! ! 169616 169617 169618!JPEGHuffmanTable class methodsFor: 'initialization' stamp: 'stephane.ducasse 6/14/2009 22:52'! 169619initialize 169620 169621 Lookahead := 8. 169622 BitBufferSize := 16! ! 169623ReadStream subclass: #JPEGReadStream 169624 instanceVariableNames: 'bitBuffer bitsInBuffer' 169625 classVariableNames: 'MaxBits' 169626 poolDictionaries: '' 169627 category: 'Graphics-Files'! 169628!JPEGReadStream commentStamp: '<historical>' prior: 0! 169629Encapsulates huffman encoded access to JPEG data. 169630 169631The following layout is fixed for the JPEG primitives to work: 169632 169633 collection <ByteArray | String> 169634 position <SmallInteger> 169635 readLimit <SmallInteger> 169636 bitBuffer <SmallInteger> 169637 bitsInBuffer <SmallInteger>! 169638 169639 169640!JPEGReadStream methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169641fillBuffer 169642 | byte | 169643 [ bitsInBuffer <= 16 ] whileTrue: 169644 [ byte := self next. 169645 (byte = 255 and: [ (self peekFor: 0) not ]) ifTrue: 169646 [ self position: self position - 1. 169647 ^ 0 ]. 169648 bitBuffer := (bitBuffer bitShift: 8) bitOr: byte. 169649 bitsInBuffer := bitsInBuffer + 8 ]. 169650 ^ bitsInBuffer! ! 169651 169652!JPEGReadStream methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169653getBits: requestedBits 169654 | value | 169655 requestedBits > bitsInBuffer ifTrue: 169656 [ self fillBuffer. 169657 requestedBits > bitsInBuffer ifTrue: [ self error: 'not enough bits available to decode' ] ]. 169658 value := bitBuffer bitShift: requestedBits - bitsInBuffer. 169659 bitBuffer := bitBuffer bitAnd: (1 bitShift: bitsInBuffer - requestedBits) - 1. 169660 bitsInBuffer := bitsInBuffer - requestedBits. 169661 ^ value! ! 169662 169663!JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/6/2001 12:34'! 169664nextByte 169665 ^self next asInteger! ! 169666 169667!JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/6/2001 12:35'! 169668nextBytes: n 169669 ^(self next: n) asByteArray! ! 169670 169671!JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/4/2001 17:40'! 169672reset 169673 super reset. 169674 self resetBitBuffer! ! 169675 169676!JPEGReadStream methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169677resetBitBuffer 169678 bitBuffer := 0. 169679 bitsInBuffer := 0! ! 169680 169681 169682!JPEGReadStream methodsFor: 'huffman trees' stamp: 'lr 7/4/2009 10:42'! 169683buildLookupTable: values counts: counts 169684 | min max | 169685 min := max := nil. 169686 1 169687 to: counts size 169688 do: 169689 [ :i | 169690 (counts at: i) = 0 ifFalse: 169691 [ min ifNil: [ min := i - 1 ]. 169692 max := i ] ]. 169693 ^ self 169694 createHuffmanTables: values 169695 counts: { 0 } , counts 169696 from: min + 1 169697 to: max! ! 169698 169699!JPEGReadStream methodsFor: 'huffman trees' stamp: 'lr 7/4/2009 10:42'! 169700createHuffmanTables: values counts: counts from: minBits to: maxBits 169701 "Create the actual tables" 169702 | table tableStart tableSize tableEnd valueIndex tableStack numValues deltaBits maxEntries lastTable lastTableStart tableIndex lastTableIndex | 169703 table := WordArray new: ((4 bitShift: minBits) max: 16). 169704 169705 "Create the first entry - this is a dummy. 169706 It gives us information about how many bits to fetch initially." 169707 table 169708 at: 1 169709 put: (minBits bitShift: 24) + 2. "First actual table starts at index 2" 169710 169711 "Create the first table from scratch." 169712 tableStart := 2. "See above" 169713 tableSize := 1 bitShift: minBits. 169714 tableEnd := tableStart + tableSize. 169715 "Store the terminal symbols" 169716 valueIndex := counts at: minBits + 1. 169717 tableIndex := 0. 169718 1 169719 to: valueIndex 169720 do: 169721 [ :i | 169722 table 169723 at: tableStart + tableIndex 169724 put: (values at: i). 169725 tableIndex := tableIndex + 1 ]. 169726 "Fill up remaining entries with invalid entries" 169727 tableStack := OrderedCollection new: 10. "Should be more than enough" 169728 tableStack addLast: (Array 169729 with: minBits 169730 with: tableStart 169731 with: tableIndex 169732 with: minBits 169733 with: tableSize - valueIndex). "Number of bits (e.g., depth) for this table" "Start of table" "Next index in table" "Number of delta bits encoded in table" "Entries remaining in table" 169734 "Go to next value index" 169735 valueIndex := valueIndex + 1. 169736 "Walk over remaining bit lengths and create new subtables" 169737 minBits + 1 169738 to: maxBits 169739 do: 169740 [ :bits | 169741 numValues := counts at: bits + 1. 169742 [ numValues > 0 ] whileTrue: 169743 [ "Create a new subtable" 169744 lastTable := tableStack last. 169745 lastTableStart := lastTable at: 2. 169746 lastTableIndex := lastTable at: 3. 169747 deltaBits := bits - (lastTable at: 1). 169748 "Make up a table of deltaBits size" 169749 tableSize := 1 bitShift: deltaBits. 169750 tableStart := tableEnd. 169751 tableEnd := tableEnd + tableSize. 169752 [ tableEnd > table size ] whileTrue: [ table := self growHuffmanTable: table ]. 169753 "Connect to last table" 169754 self assert: [ (table at: lastTableStart + lastTableIndex) = 0 ]. "Entry must be unused" 169755 table 169756 at: lastTableStart + lastTableIndex 169757 put: (deltaBits bitShift: 24) + tableStart. 169758 lastTable 169759 at: 3 169760 put: lastTableIndex + 1. 169761 lastTable 169762 at: 5 169763 put: (lastTable at: 5) - 1. 169764 self assert: [ (lastTable at: 5) >= 0 ]. "Don't exceed tableSize" 169765 "Store terminal values" 169766 maxEntries := numValues min: tableSize. 169767 tableIndex := 0. 169768 1 169769 to: maxEntries 169770 do: 169771 [ :i | 169772 table 169773 at: tableStart + tableIndex 169774 put: (values at: valueIndex). 169775 valueIndex := valueIndex + 1. 169776 numValues := numValues - 1. 169777 tableIndex := tableIndex + 1 ]. 169778 "Check if we have filled up the current table completely" 169779 maxEntries = tableSize 169780 ifTrue: 169781 [ "Table has been filled. Back up to the last table with space left." 169782 [ tableStack isEmpty not and: [ (tableStack last at: 5) = 0 ] ] whileTrue: [ tableStack removeLast ] ] 169783 ifFalse: 169784 [ "Table not yet filled. Put it back on the stack." 169785 tableStack addLast: (Array 169786 with: bits 169787 with: tableStart 169788 with: tableIndex 169789 with: deltaBits 169790 with: tableSize - maxEntries) "Nr. of bits in this table" "Start of table" "Index in table" "delta bits of table" "Unused entries in table" ] ] ]. 169791 ^ table 169792 copyFrom: 1 169793 to: tableEnd - 1! ! 169794 169795!JPEGReadStream methodsFor: 'huffman trees' stamp: 'lr 7/4/2009 10:42'! 169796decodeValueFrom: table 169797 "Decode the next value in the receiver using the given huffman table." 169798 | bits bitsNeeded tableIndex value | 169799 bitsNeeded := (table at: 1) bitShift: -24. "Initial bits needed" 169800 tableIndex := 2. "First real table" 169801 169802 [ bits := self getBits: bitsNeeded. "Get bits" 169803 value := table at: tableIndex + bits. "Lookup entry in table" 169804 (value bitAnd: 1056964608) = 0 "Check if it is a non-leaf node" ] whileFalse: 169805 [ "Fetch sub table" 169806 tableIndex := value bitAnd: 65535. "Table offset in low 16 bit" 169807 bitsNeeded := (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit" 169808 bitsNeeded > MaxBits ifTrue: [ ^ self error: 'Invalid huffman table entry' ] ]. 169809 ^ value! ! 169810 169811!JPEGReadStream methodsFor: 'huffman trees' stamp: 'lr 7/4/2009 10:42'! 169812growHuffmanTable: table 169813 | newTable | 169814 newTable := table species new: table size * 2. 169815 newTable 169816 replaceFrom: 1 169817 to: table size 169818 with: table 169819 startingAt: 1. 169820 ^ newTable! ! 169821 169822"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 169823 169824JPEGReadStream class 169825 instanceVariableNames: ''! 169826 169827!JPEGReadStream class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 169828initialize 169829 "JPEGReadStream initialize" 169830 MaxBits := 16! ! 169831ImageReadWriter subclass: #JPEGReadWriter 169832 instanceVariableNames: 'width height components currentComponents qTable hACTable hDCTable restartInterval restartsToGo mcuWidth mcuHeight mcusPerRow mcuRowsInScan mcuMembership mcuSampleBuffer mcuImageBuffer majorVersion minorVersion dataPrecision densityUnit xDensity yDensity ss se ah al sosSeen residuals ditherMask' 169833 classVariableNames: 'ConstBits DCTK1 DCTK2 DCTK3 DCTK4 DCTSize DCTSize2 DitherMasks FIXn0n298631336 FIXn0n34414 FIXn0n390180644 FIXn0n541196100 FIXn0n71414 FIXn0n765366865 FIXn0n899976223 FIXn1n175875602 FIXn1n40200 FIXn1n501321110 FIXn1n77200 FIXn1n847759065 FIXn1n961570560 FIXn2n053119869 FIXn2n562915447 FIXn3n072711026 FloatSampleOffset HuffmanTableSize JFIFMarkerParser JPEGNaturalOrder MaxSample Pass1Bits Pass1Div Pass2Div QTableScaleFactor QuantizationTableSize SampleOffset' 169834 poolDictionaries: '' 169835 category: 'Graphics-Files'! 169836!JPEGReadWriter commentStamp: '<historical>' prior: 0! 169837I am a subclass of ImageReadWriter that understands JFIF file streams, and can decode JPEG images. 169838This code is based upon the Independent Joint Photographic Experts Group (IJPEG) software, originally written in C by Tom Lane, Philip Gladstone, Luis Ortiz, Jim Boucher, Lee Crocker, Julian Minguillon, George Phillips, Davide Rossi, Ge' Weijers, and other members of the Independent JPEG Group. 169839 169840! 169841 169842 169843!JPEGReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169844hACTable 169845 hACTable ifNil: [ hACTable := Array new: HuffmanTableSize ]. 169846 ^ hACTable! ! 169847 169848!JPEGReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169849hDCTable 169850 hDCTable ifNil: [ hDCTable := Array new: HuffmanTableSize ]. 169851 ^ hDCTable! ! 169852 169853!JPEGReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 169854qTable 169855 qTable ifNil: [ qTable := Array new: QuantizationTableSize ]. 169856 ^ qTable! ! 169857 169858 169859!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'lr 7/4/2009 10:42'! 169860colorConvertFloatYCbCrMCU 169861 | ySampleStream crSampleStream cbSampleStream y cb cr red green blue bits | 169862 ySampleStream := currentComponents at: 1. 169863 cbSampleStream := currentComponents at: 2. 169864 crSampleStream := currentComponents at: 3. 169865 ySampleStream resetSampleStream. 169866 cbSampleStream resetSampleStream. 169867 crSampleStream resetSampleStream. 169868 bits := mcuImageBuffer bits. 169869 1 169870 to: bits size 169871 do: 169872 [ :i | 169873 y := ySampleStream nextSample. 169874 cb := cbSampleStream nextSample - FloatSampleOffset. 169875 cr := crSampleStream nextSample - FloatSampleOffset. 169876 red := self sampleFloatRangeLimit: y + (1.402 * cr). 169877 green := self sampleFloatRangeLimit: y - (0.34414 * cb) - (0.71414 * cr). 169878 blue := self sampleFloatRangeLimit: y + (1.772 * cb). 169879 bits 169880 at: i 169881 put: 4278190080 + (red << 16) + (green << 8) + blue ]! ! 169882 169883!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'lr 7/4/2009 10:42'! 169884colorConvertGrayscaleMCU 169885 | ySampleStream y bits | 169886 ySampleStream := currentComponents at: 1. 169887 ySampleStream resetSampleStream. 169888 bits := mcuImageBuffer bits. 169889 1 169890 to: bits size 169891 do: 169892 [ :i | 169893 y := ySampleStream nextSample + (residuals at: 2). 169894 y > MaxSample ifTrue: [ y := MaxSample ]. 169895 residuals 169896 at: 2 169897 put: (y bitAnd: ditherMask). 169898 y := y bitAnd: MaxSample - ditherMask. 169899 y < 1 ifTrue: [ y := 1 ]. 169900 bits 169901 at: i 169902 put: 4278190080 + (y << 16) + (y << 8) + y ]! ! 169903 169904!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'lr 7/4/2009 10:42'! 169905colorConvertIntYCbCrMCU 169906 | ySampleStream crSampleStream cbSampleStream y cb cr red green blue bits | 169907 ySampleStream := currentComponents at: 1. 169908 cbSampleStream := currentComponents at: 2. 169909 crSampleStream := currentComponents at: 3. 169910 ySampleStream resetSampleStream. 169911 cbSampleStream resetSampleStream. 169912 crSampleStream resetSampleStream. 169913 bits := mcuImageBuffer bits. 169914 1 169915 to: bits size 169916 do: 169917 [ :i | 169918 y := ySampleStream nextSample. 169919 cb := cbSampleStream nextSample - SampleOffset. 169920 cr := crSampleStream nextSample - SampleOffset. 169921 red := y + (FIXn1n40200 * cr // 65536) + (residuals at: 1). 169922 red > MaxSample 169923 ifTrue: [ red := MaxSample ] 169924 ifFalse: [ red < 0 ifTrue: [ red := 0 ] ]. 169925 residuals 169926 at: 1 169927 put: (red bitAnd: ditherMask). 169928 red := red bitAnd: MaxSample - ditherMask. 169929 red < 1 ifTrue: [ red := 1 ]. 169930 green := y - (FIXn0n34414 * cb // 65536) - (FIXn0n71414 * cr // 65536) + (residuals at: 2). 169931 green > MaxSample 169932 ifTrue: [ green := MaxSample ] 169933 ifFalse: [ green < 0 ifTrue: [ green := 0 ] ]. 169934 residuals 169935 at: 2 169936 put: (green bitAnd: ditherMask). 169937 green := green bitAnd: MaxSample - ditherMask. 169938 green < 1 ifTrue: [ green := 1 ]. 169939 blue := y + (FIXn1n77200 * cb // 65536) + (residuals at: 3). 169940 blue > MaxSample 169941 ifTrue: [ blue := MaxSample ] 169942 ifFalse: [ blue < 0 ifTrue: [ blue := 0 ] ]. 169943 residuals 169944 at: 3 169945 put: (blue bitAnd: ditherMask). 169946 blue := blue bitAnd: MaxSample - ditherMask. 169947 blue < 1 ifTrue: [ blue := 1 ]. 169948 bits 169949 at: i 169950 put: 4278190080 + (red bitShift: 16) + (green bitShift: 8) + blue ]! ! 169951 169952!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/7/2001 01:02'! 169953colorConvertMCU 169954 169955 ^ currentComponents size = 3 169956 ifTrue: 169957 [self useFloatingPoint 169958 ifTrue: [self colorConvertFloatYCbCrMCU] 169959 ifFalse: [self primColorConvertYCbCrMCU: currentComponents 169960 bits: mcuImageBuffer bits 169961 residuals: residuals 169962 ditherMask: ditherMask.]] 169963 ifFalse: [self primColorConvertGrayscaleMCU]! ! 169964 169965!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 22:19'! 169966primColorConvertGrayscaleMCU 169967 self primColorConvertGrayscaleMCU: (currentComponents at: 1) 169968 bits: mcuImageBuffer bits 169969 residuals: residuals 169970 ditherMask: ditherMask.! ! 169971 169972!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/15/2001 18:11'! 169973primColorConvertGrayscaleMCU: componentArray bits: bits residuals: residualArray ditherMask: mask 169974 <primitive: 'primitiveColorConvertGrayscaleMCU' module: 'JPEGReaderPlugin'> 169975 "JPEGReaderPlugin doPrimitive: #primitiveColorConvertGrayscaleMCU." 169976 ^self colorConvertGrayscaleMCU! ! 169977 169978!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 21:36'! 169979primColorConvertIntYCbCrMCU 169980 self primColorConvertYCbCrMCU: currentComponents 169981 bits: mcuImageBuffer bits 169982 residuals: residuals 169983 ditherMask: ditherMask.! ! 169984 169985!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 21:36'! 169986primColorConvertYCbCrMCU: componentArray bits: bits residuals: residualArray ditherMask: mask 169987 <primitive: 'primitiveColorConvertMCU' module: 'JPEGReaderPlugin'> 169988 ^self colorConvertIntYCbCrMCU! ! 169989 169990!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'tao 10/26/97 15:43'! 169991sampleFloatRangeLimit: aNumber 169992 169993 ^ (aNumber rounded max: 0) min: MaxSample! ! 169994 169995!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'di 9/15/1998 14:30'! 169996sampleRangeLimit: aNumber 169997 169998 aNumber < 0 ifTrue: [^ 0]. 169999 aNumber > MaxSample ifTrue: [^ MaxSample]. 170000 ^ aNumber! ! 170001 170002 170003!JPEGReadWriter methodsFor: 'dct' stamp: 'tao 10/26/97 15:16'! 170004dctFloatRangeLimit: value 170005 170006 ^ (value / 8.0) + FloatSampleOffset.! ! 170007 170008!JPEGReadWriter methodsFor: 'dct' stamp: 'lr 7/4/2009 10:42'! 170009idctBlockFloat: anArray component: aColorComponent 170010 | t0 t1 t2 t3 t4 t5 t6 t7 t10 t11 t12 t13 z5 z10 z11 z12 z13 qt ws | 170011 qt := self qTable at: aColorComponent qTableIndex. 170012 ws := Array new: DCTSize2. 170013 170014 "Pass 1: process columns from input, store into work array" 170015 1 170016 to: DCTSize 170017 do: 170018 [ :i | 170019 t0 := (anArray at: i) * (qt at: i). 170020 t1 := (anArray at: DCTSize * 2 + i) * (qt at: DCTSize * 2 + i). 170021 t2 := (anArray at: DCTSize * 4 + i) * (qt at: DCTSize * 4 + i). 170022 t3 := (anArray at: DCTSize * 6 + i) * (qt at: DCTSize * 6 + i). 170023 t10 := t0 + t2. 170024 t11 := t0 - t2. 170025 t13 := t1 + t3. 170026 t12 := (t1 - t3) * DCTK1 - t13. 170027 t0 := t10 + t13. 170028 t3 := t10 - t13. 170029 t1 := t11 + t12. 170030 t2 := t11 - t12. 170031 t4 := (anArray at: DCTSize + i) * (qt at: DCTSize + i). 170032 t5 := (anArray at: DCTSize * 3 + i) * (qt at: DCTSize * 3 + i). 170033 t6 := (anArray at: DCTSize * 5 + i) * (qt at: DCTSize * 5 + i). 170034 t7 := (anArray at: DCTSize * 7 + i) * (qt at: DCTSize * 7 + i). 170035 z13 := t6 + t5. 170036 z10 := t6 - t5. 170037 z11 := t4 + t7. 170038 z12 := t4 - t7. 170039 t7 := z11 + z13. 170040 t11 := (z11 - z13) * DCTK1. 170041 z5 := (z10 + z12) * DCTK2. 170042 t10 := DCTK3 * z12 - z5. 170043 t12 := DCTK4 * z10 + z5. 170044 t6 := t12 - t7. 170045 t5 := t11 - t6. 170046 t4 := t10 + t5. 170047 ws 170048 at: i 170049 put: t0 + t7. 170050 ws 170051 at: DCTSize * 7 + i 170052 put: t0 - t7. 170053 ws 170054 at: DCTSize + i 170055 put: t1 + t6. 170056 ws 170057 at: DCTSize * 6 + i 170058 put: t1 - t6. 170059 ws 170060 at: DCTSize * 2 + i 170061 put: t2 + t5. 170062 ws 170063 at: DCTSize * 5 + i 170064 put: t2 - t5. 170065 ws 170066 at: DCTSize * 4 + i 170067 put: t3 + t4. 170068 ws 170069 at: DCTSize * 3 + i 170070 put: t3 - t4 ]. 170071 170072 "Pass 2: process rows from the workspace" 170073 (0 170074 to: DCTSize2 - DCTSize 170075 by: DCTSize) do: 170076 [ :i | 170077 t10 := (ws at: i + 1) + (ws at: i + 5). 170078 t11 := (ws at: i + 1) - (ws at: i + 5). 170079 t13 := (ws at: i + 3) + (ws at: i + 7). 170080 t12 := ((ws at: i + 3) - (ws at: i + 7)) * DCTK1 - t13. 170081 t0 := t10 + t13. 170082 t3 := t10 - t13. 170083 t1 := t11 + t12. 170084 t2 := t11 - t12. 170085 z13 := (ws at: i + 6) + (ws at: i + 4). 170086 z10 := (ws at: i + 6) - (ws at: i + 4). 170087 z11 := (ws at: i + 2) + (ws at: i + 8). 170088 z12 := (ws at: i + 2) - (ws at: i + 8). 170089 t7 := z11 + z13. 170090 t11 := (z11 - z13) * DCTK1. 170091 z5 := (z10 + z12) * DCTK2. 170092 t10 := DCTK3 * z12 - z5. 170093 t12 := DCTK4 * z10 + z5. 170094 t6 := t12 - t7. 170095 t5 := t11 - t6. 170096 t4 := t10 + t5. 170097 170098 "final output stage: scale down by a factor of 8 and range-limit" 170099 anArray 170100 at: i + 1 170101 put: (self dctFloatRangeLimit: t0 + t7). 170102 anArray 170103 at: i + 8 170104 put: (self dctFloatRangeLimit: t0 - t7). 170105 anArray 170106 at: i + 2 170107 put: (self dctFloatRangeLimit: t1 + t6). 170108 anArray 170109 at: i + 7 170110 put: (self dctFloatRangeLimit: t1 - t6). 170111 anArray 170112 at: i + 3 170113 put: (self dctFloatRangeLimit: t2 + t5). 170114 anArray 170115 at: i + 6 170116 put: (self dctFloatRangeLimit: t2 - t5). 170117 anArray 170118 at: i + 5 170119 put: (self dctFloatRangeLimit: t3 + t4). 170120 anArray 170121 at: i + 4 170122 put: (self dctFloatRangeLimit: t3 - t4) ]! ! 170123 170124!JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:35'! 170125idctBlockInt: anArray component: aColorComponent 170126 ^self idctBlockInt: anArray qt: (self qTable at: aColorComponent qTableIndex)! ! 170127 170128!JPEGReadWriter methodsFor: 'dct' stamp: 'lr 7/4/2009 10:42'! 170129idctBlockInt: anArray qt: qt 170130 | ws anACTerm dcval z1 z2 z3 z4 z5 t0 t1 t2 t3 t10 t11 t12 t13 shift | 170131 ws := Array new: DCTSize2. 170132 170133 "Pass 1: process columns from anArray, store into work array" 170134 shift := 1 bitShift: ConstBits - Pass1Bits. 170135 1 170136 to: DCTSize 170137 do: 170138 [ :i | 170139 anACTerm := nil. 170140 1 170141 to: DCTSize - 1 170142 do: 170143 [ :row | 170144 anACTerm ifNil: [ (anArray at: row * DCTSize + i) = 0 ifFalse: [ anACTerm := row ] ] ]. 170145 anACTerm == nil 170146 ifTrue: 170147 [ dcval := (anArray at: i) * (qt at: 1) bitShift: Pass1Bits. 170148 0 170149 to: DCTSize - 1 170150 do: 170151 [ :j | 170152 ws 170153 at: j * DCTSize + i 170154 put: dcval ] ] 170155 ifFalse: 170156 [ z2 := (anArray at: DCTSize * 2 + i) * (qt at: DCTSize * 2 + i). 170157 z3 := (anArray at: DCTSize * 6 + i) * (qt at: DCTSize * 6 + i). 170158 z1 := (z2 + z3) * FIXn0n541196100. 170159 t2 := z1 + (z3 * FIXn1n847759065 negated). 170160 t3 := z1 + (z2 * FIXn0n765366865). 170161 z2 := (anArray at: i) * (qt at: i). 170162 z3 := (anArray at: DCTSize * 4 + i) * (qt at: DCTSize * 4 + i). 170163 t0 := z2 + z3 bitShift: ConstBits. 170164 t1 := z2 - z3 bitShift: ConstBits. 170165 t10 := t0 + t3. 170166 t13 := t0 - t3. 170167 t11 := t1 + t2. 170168 t12 := t1 - t2. 170169 t0 := (anArray at: DCTSize * 7 + i) * (qt at: DCTSize * 7 + i). 170170 t1 := (anArray at: DCTSize * 5 + i) * (qt at: DCTSize * 5 + i). 170171 t2 := (anArray at: DCTSize * 3 + i) * (qt at: DCTSize * 3 + i). 170172 t3 := (anArray at: DCTSize + i) * (qt at: DCTSize + i). 170173 z1 := t0 + t3. 170174 z2 := t1 + t2. 170175 z3 := t0 + t2. 170176 z4 := t1 + t3. 170177 z5 := (z3 + z4) * FIXn1n175875602. 170178 t0 := t0 * FIXn0n298631336. 170179 t1 := t1 * FIXn2n053119869. 170180 t2 := t2 * FIXn3n072711026. 170181 t3 := t3 * FIXn1n501321110. 170182 z1 := z1 * FIXn0n899976223 negated. 170183 z2 := z2 * FIXn2n562915447 negated. 170184 z3 := z3 * FIXn1n961570560 negated. 170185 z4 := z4 * FIXn0n390180644 negated. 170186 z3 := z3 + z5. 170187 z4 := z4 + z5. 170188 t0 := t0 + z1 + z3. 170189 t1 := t1 + z2 + z4. 170190 t2 := t2 + z2 + z3. 170191 t3 := t3 + z1 + z4. 170192 ws 170193 at: i 170194 put: t10 + t3 >> (ConstBits - Pass1Bits). 170195 ws 170196 at: DCTSize * 7 + i 170197 put: (t10 - t3) // shift. 170198 ws 170199 at: DCTSize * 1 + i 170200 put: (t11 + t2) // shift. 170201 ws 170202 at: DCTSize * 6 + i 170203 put: (t11 - t2) // shift. 170204 ws 170205 at: DCTSize * 2 + i 170206 put: (t12 + t1) // shift. 170207 ws 170208 at: DCTSize * 5 + i 170209 put: (t12 - t1) // shift. 170210 ws 170211 at: DCTSize * 3 + i 170212 put: (t13 + t0) // shift. 170213 ws 170214 at: DCTSize * 4 + i 170215 put: (t13 - t0) // shift ] ]. 170216 170217 "Pass 2: process rows from work array, store back into anArray" 170218 shift := 1 bitShift: ConstBits + Pass1Bits + 3. 170219 0 170220 to: DCTSize2 - DCTSize 170221 by: DCTSize 170222 do: 170223 [ :i | 170224 z2 := ws at: i + 3. 170225 z3 := ws at: i + 7. 170226 z1 := (z2 + z3) * FIXn0n541196100. 170227 t2 := z1 + (z3 * FIXn1n847759065 negated). 170228 t3 := z1 + (z2 * FIXn0n765366865). 170229 t0 := (ws at: i + 1) + (ws at: i + 5) bitShift: ConstBits. 170230 t1 := (ws at: i + 1) - (ws at: i + 5) bitShift: ConstBits. 170231 t10 := t0 + t3. 170232 t13 := t0 - t3. 170233 t11 := t1 + t2. 170234 t12 := t1 - t2. 170235 t0 := ws at: i + 8. 170236 t1 := ws at: i + 6. 170237 t2 := ws at: i + 4. 170238 t3 := ws at: i + 2. 170239 z1 := t0 + t3. 170240 z2 := t1 + t2. 170241 z3 := t0 + t2. 170242 z4 := t1 + t3. 170243 z5 := (z3 + z4) * FIXn1n175875602. 170244 t0 := t0 * FIXn0n298631336. 170245 t1 := t1 * FIXn2n053119869. 170246 t2 := t2 * FIXn3n072711026. 170247 t3 := t3 * FIXn1n501321110. 170248 z1 := z1 * FIXn0n899976223 negated. 170249 z2 := z2 * FIXn2n562915447 negated. 170250 z3 := z3 * FIXn1n961570560 negated. 170251 z4 := z4 * FIXn0n390180644 negated. 170252 z3 := z3 + z5. 170253 z4 := z4 + z5. 170254 t0 := t0 + z1 + z3. 170255 t1 := t1 + z2 + z4. 170256 t2 := t2 + z2 + z3. 170257 t3 := t3 + z1 + z4. 170258 anArray 170259 at: i + 1 170260 put: (self sampleRangeLimit: (t10 + t3) // shift + SampleOffset). 170261 anArray 170262 at: i + 8 170263 put: (self sampleRangeLimit: (t10 - t3) // shift + SampleOffset). 170264 anArray 170265 at: i + 2 170266 put: (self sampleRangeLimit: (t11 + t2) // shift + SampleOffset). 170267 anArray 170268 at: i + 7 170269 put: (self sampleRangeLimit: (t11 - t2) // shift + SampleOffset). 170270 anArray 170271 at: i + 3 170272 put: (self sampleRangeLimit: (t12 + t1) // shift + SampleOffset). 170273 anArray 170274 at: i + 6 170275 put: (self sampleRangeLimit: (t12 - t1) // shift + SampleOffset). 170276 anArray 170277 at: i + 4 170278 put: (self sampleRangeLimit: (t13 + t0) // shift + SampleOffset). 170279 anArray 170280 at: i + 5 170281 put: (self sampleRangeLimit: (t13 - t0) // shift + SampleOffset) ]! ! 170282 170283!JPEGReadWriter methodsFor: 'dct' stamp: 'lr 7/4/2009 10:42'! 170284idctMCU 170285 | comp fp ci | 170286 fp := self useFloatingPoint. 170287 1 170288 to: mcuMembership size 170289 do: 170290 [ :i | 170291 ci := mcuMembership at: i. 170292 comp := currentComponents at: ci. 170293 fp 170294 ifTrue: 170295 [ self 170296 idctBlockFloat: (mcuSampleBuffer at: i) 170297 component: comp ] 170298 ifFalse: 170299 [ self 170300 primIdctInt: (mcuSampleBuffer at: i) 170301 qt: (qTable at: comp qTableIndex) ] ]! ! 170302 170303!JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:37'! 170304primIdctBlockInt: anArray component: aColorComponent 170305 ^self primIdctInt: anArray qt: (self qTable at: aColorComponent qTableIndex)! ! 170306 170307!JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:35'! 170308primIdctInt: anArray qt: qt 170309 <primitive: 'primitiveIdctInt' module: 'JPEGReaderPlugin'> 170310 ^self idctBlockInt: anArray qt: qt! ! 170311 170312!JPEGReadWriter methodsFor: 'dct' stamp: 'lr 7/4/2009 10:42'! 170313scaleQuantizationTable: table 170314 | index | 170315 index := 1. 170316 1 170317 to: DCTSize 170318 do: 170319 [ :row | 170320 1 170321 to: DCTSize 170322 do: 170323 [ :col | 170324 table 170325 at: index 170326 put: ((table at: index) * (QTableScaleFactor at: row) * (QTableScaleFactor at: col)) rounded. 170327 index := index + 1 ] ]. 170328 ^ table! ! 170329 170330 170331!JPEGReadWriter methodsFor: 'error handling' stamp: 'tao 10/19/97 12:25'! 170332notSupported: aString 170333 170334 self error: aString , ' is not currently supported'! ! 170335 170336 170337!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'lr 7/4/2009 10:42'! 170338decodeBlockInto: anArray component: aColorComponent dcTable: huffmanDC acTable: huffmanAC 170339 | byte i zeroCount | 170340 byte := stream decodeValueFrom: huffmanDC. 170341 byte ~= 0 ifTrue: 170342 [ byte := self 170343 scaleAndSignExtend: (self getBits: byte) 170344 inFieldWidth: byte ]. 170345 byte := aColorComponent updateDCValue: byte. 170346 anArray atAllPut: 0. 170347 anArray 170348 at: 1 170349 put: byte. 170350 i := 2. 170351 [ i <= DCTSize2 ] whileTrue: 170352 [ byte := stream decodeValueFrom: huffmanAC. 170353 zeroCount := byte >> 4. 170354 byte := byte bitAnd: 15. 170355 byte ~= 0 170356 ifTrue: 170357 [ i := i + zeroCount. 170358 byte := self 170359 scaleAndSignExtend: (self getBits: byte) 170360 inFieldWidth: byte. 170361 anArray 170362 at: (JPEGNaturalOrder at: i) 170363 put: byte ] 170364 ifFalse: 170365 [ zeroCount = 15 170366 ifTrue: [ i := i + zeroCount ] 170367 ifFalse: [ ^ self ] ]. 170368 i := i + 1 ]! ! 170369 170370!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'lr 7/4/2009 10:42'! 170371decodeMCU 170372 | comp ci | 170373 (restartInterval ~= 0 and: [ restartsToGo = 0 ]) ifTrue: [ self processRestart ]. 170374 1 170375 to: mcuMembership size 170376 do: 170377 [ :i | 170378 ci := mcuMembership at: i. 170379 comp := currentComponents at: ci. 170380 self 170381 primDecodeBlockInto: (mcuSampleBuffer at: i) 170382 component: comp 170383 dcTable: (hDCTable at: comp dcTableIndex) 170384 acTable: (hACTable at: comp acTableIndex) 170385 stream: stream ]. 170386 restartsToGo := restartsToGo - 1! ! 170387 170388!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 17:27'! 170389getBits: requestedBits 170390 ^stream getBits: requestedBits! ! 170391 170392!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 21:32'! 170393primDecodeBlockInto: sampleBuffer component: comp dcTable: dcTable acTable: acTable stream: jpegStream 170394 <primitive: 'primitiveDecodeMCU' module: 'JPEGReaderPlugin'> 170395 ^self decodeBlockInto: sampleBuffer component: comp dcTable: dcTable acTable: acTable! ! 170396 170397!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'lr 7/4/2009 10:42'! 170398processRestart 170399 stream resetBitBuffer. 170400 self parseNextMarker. 170401 currentComponents do: [ :c | c priorDCValue: 0 ]. 170402 restartsToGo := restartInterval! ! 170403 170404!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 01:17'! 170405scaleAndSignExtend: aNumber inFieldWidth: w 170406 170407 aNumber < (1 bitShift: (w - 1)) 170408 ifTrue: [^aNumber - (1 bitShift: w) + 1] 170409 ifFalse: [^aNumber]! ! 170410 170411 170412!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! 170413initialSOSSetup 170414 mcuWidth := (components detectMax: [ :c | c widthInBlocks ]) widthInBlocks. 170415 mcuHeight := (components detectMax: [ :c | c heightInBlocks ]) heightInBlocks. 170416 components do: 170417 [ :c | 170418 c 170419 mcuWidth: mcuWidth 170420 mcuHeight: mcuHeight 170421 dctSize: DCTSize ]. 170422 stream resetBitBuffer! ! 170423 170424!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'mir 6/13/2001 13:06'! 170425okToIgnoreMarker: aMarker 170426 170427 ^ (((16rE0 to: 16rEF) includes: aMarker) "unhandled APPn markers" 170428 or: [aMarker = 16rDC or: [aMarker = 16rFE]]) "DNL or COM markers" 170429 or: [aMarker = 16r99] "Whatever that is"! ! 170430 170431!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! 170432parseAPPn 170433 | length buffer thumbnailLength markerStart | 170434 markerStart := self position. 170435 length := self nextWord. 170436 buffer := self next: 4. 170437 buffer asString = 'JFIF' ifFalse: 170438 [ "Skip APPs that we're not interested in" 170439 stream next: length - 6. 170440 ^ self ]. 170441 self next. 170442 majorVersion := self next. 170443 minorVersion := self next. 170444 densityUnit := self next. 170445 xDensity := self nextWord. 170446 yDensity := self nextWord. 170447 thumbnailLength := self next * self next * 3. 170448 length := length - (self position - markerStart). 170449 length = thumbnailLength ifFalse: [ self error: 'APP0 thumbnail length is incorrect.' ]. 170450 self next: length! ! 170451 170452!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! 170453parseDecoderRestartInterval 170454 | length | 170455 length := self nextWord. 170456 length = 4 ifFalse: [ self error: 'DRI length incorrect' ]. 170457 restartInterval := self nextWord! ! 170458 170459!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! 170460parseFirstMarker 170461 | marker | 170462 self next = 255 ifFalse: [ self error: 'JFIF marker expected' ]. 170463 marker := self next. 170464 marker = 217 ifTrue: [ ^ self "halt: 'EOI encountered.'" ]. 170465 marker = 216 ifFalse: [ self error: 'SOI marker expected' ]. 170466 self parseStartOfInput! ! 170467 170468!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! 170469parseHuffmanTable 170470 | length markerStart index bits count huffVal isACTable hTable | 170471 markerStart := self position. 170472 length := self nextWord. 170473 [ self position - markerStart >= length ] whileFalse: 170474 [ index := self next. 170475 isACTable := (index bitAnd: 16) ~= 0. 170476 index := (index bitAnd: 15) + 1. 170477 index > HuffmanTableSize ifTrue: 170478 [ self error: 'image has more than ' , HuffmanTableSize printString , ' quantization tables' ]. 170479 bits := self next: 16. 170480 count := bits sum. 170481 (count > 256 or: [ count > (length - (self position - markerStart)) ]) ifTrue: [ self error: 'Huffman Table count is incorrect' ]. 170482 huffVal := self next: count. 170483 hTable := stream 170484 buildLookupTable: huffVal 170485 counts: bits. 170486 isACTable 170487 ifTrue: 170488 [ self hACTable 170489 at: index 170490 put: hTable ] 170491 ifFalse: 170492 [ self hDCTable 170493 at: index 170494 put: hTable ] ]! ! 170495 170496!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/24/97 17:32'! 170497parseNOP 170498 170499 "don't need to do anything, here"! ! 170500 170501!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! 170502parseNextMarker 170503 "Parse the next marker of the stream" 170504 | byte discardedBytes | 170505 discardedBytes := 0. 170506 [ (byte := self next) = 255 ] whileFalse: [ discardedBytes := discardedBytes + 1 ]. 170507 170508 [ [ (byte := self next) = 255 ] whileTrue. 170509 byte = 0 ] whileTrue: [ discardedBytes := discardedBytes + 2 ]. 170510 discardedBytes > 0 ifTrue: 170511 [ "notifyWithLabel: 'warning: extraneous data discarded'" 170512 self ]. 170513 self perform: (JFIFMarkerParser 170514 at: byte 170515 ifAbsent: 170516 [ (self okToIgnoreMarker: byte) 170517 ifTrue: [ #skipMarker ] 170518 ifFalse: [ self error: 'marker ' , byte printStringHex , ' cannot be handled' ] ])! ! 170519 170520!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! 170521parseQuantizationTable 170522 | length markerStart n prec value table | 170523 markerStart := self position. 170524 length := self nextWord. 170525 [ self position - markerStart >= length ] whileFalse: 170526 [ value := self next. 170527 n := (value bitAnd: 15) + 1. 170528 prec := value >> 4 > 0. 170529 n > QuantizationTableSize ifTrue: 170530 [ self error: 'image has more than ' , QuantizationTableSize printString , ' quantization tables' ]. 170531 table := IntegerArray new: DCTSize2. 170532 1 170533 to: DCTSize2 170534 do: 170535 [ :i | 170536 value := prec 170537 ifTrue: [ self nextWord ] 170538 ifFalse: [ self next ]. 170539 table 170540 at: (JPEGNaturalOrder at: i) 170541 put: value ]. 170542 self useFloatingPoint ifTrue: [ self scaleQuantizationTable: table ]. 170543 self qTable 170544 at: n 170545 put: table ]! ! 170546 170547!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! 170548parseStartOfFile 170549 | length markerStart value n | 170550 markerStart := self position. 170551 length := self nextWord. 170552 dataPrecision := self next. 170553 dataPrecision = 8 ifFalse: 170554 [ self error: 'cannot handle ' , dataPrecision printString , '-bit components' ]. 170555 height := self nextWord. 170556 width := self nextWord. 170557 n := self next. 170558 height = 0 | (width = 0) | (n = 0) ifTrue: [ self error: 'empty image' ]. 170559 length - (self position - markerStart) ~= (n * 3) ifTrue: [ self error: 'component length is incorrect' ]. 170560 components := Array new: n. 170561 1 170562 to: components size 170563 do: 170564 [ :i | 170565 components 170566 at: i 170567 put: (JPEGColorComponent new 170568 id: self next; 170569 widthInBlocks: ((value := self next) >> 4 bitAnd: 15); 170570 heightInBlocks: (value bitAnd: 15); 170571 qTableIndex: self next + 1) 170572 "heightInBlocks: (((value _ self next) >> 4) bitAnd: 16r0F); 170573 widthInBlocks: (value bitAnd: 16r0F);" ]! ! 170574 170575!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! 170576parseStartOfInput 170577 restartInterval := 0. 170578 densityUnit := 0. 170579 xDensity := 1. 170580 yDensity := 1! ! 170581 170582!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! 170583parseStartOfScan 170584 | length n id value dcNum acNum comp | 170585 length := self nextWord. 170586 n := self next. 170587 length ~= (n * 2 + 6) | (n < 1) ifTrue: [ self error: 'SOS length is incorrect' ]. 170588 currentComponents := Array new: n. 170589 1 170590 to: n 170591 do: 170592 [ :i | 170593 id := self next. 170594 value := self next. 170595 dcNum := value >> 4 bitAnd: 15. 170596 acNum := value bitAnd: 15. 170597 comp := components detect: [ :c | c id = id ]. 170598 comp 170599 dcTableIndex: dcNum + 1; 170600 acTableIndex: acNum + 1. 170601 currentComponents 170602 at: i 170603 put: comp ]. 170604 ss := self next. 170605 se := self next. 170606 value := self next. 170607 ah := value >> 4 bitAnd: 15. 170608 al := value bitAnd: 15. 170609 self initialSOSSetup. 170610 self perScanSetup. 170611 sosSeen := true! ! 170612 170613!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! 170614perScanSetup 170615 mcusPerRow := (width / (mcuWidth * DCTSize)) ceiling. 170616 mcuRowsInScan := (height / (mcuHeight * DCTSize)) ceiling. 170617 (currentComponents size = 3 or: [ currentComponents size = 1 ]) ifFalse: [ self error: 'JPEG color space not recognized' ]. 170618 mcuMembership := OrderedCollection new. 170619 currentComponents withIndexDo: 170620 [ :c :i | 170621 c priorDCValue: 0. 170622 mcuMembership addAll: ((1 to: c totalMcuBlocks) collect: [ :b | i ]) ]. 170623 mcuMembership := mcuMembership asArray. 170624 mcuSampleBuffer := (1 to: mcuMembership size) collect: [ :i | IntegerArray new: DCTSize2 ]. 170625 currentComponents withIndexDo: 170626 [ :c :i | 170627 c initializeSampleStreamBlocks: ((1 to: mcuMembership size) 170628 select: [ :j | i = (mcuMembership at: j) ] 170629 thenCollect: [ :j | mcuSampleBuffer at: j ]) ]. 170630 mcuImageBuffer := Form 170631 extent: mcuWidth @ mcuHeight * DCTSize 170632 depth: 32. 170633 restartsToGo := restartInterval! ! 170634 170635!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! 170636skipMarker 170637 | length markerStart | 170638 markerStart := self position. 170639 length := self nextWord. 170640 self next: length - (self position - markerStart)! ! 170641 170642 170643!JPEGReadWriter methodsFor: 'preferences' stamp: 'tao 10/26/97 22:09'! 170644useFloatingPoint 170645 170646 ^ false! ! 170647 170648 170649!JPEGReadWriter methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! 170650decompressionTest 170651 "Test decompression; don't generate actual image" 170652 | xStep yStep x y | 170653 MessageTally spyOn: 170654 [ ditherMask := DitherMasks at: 32. 170655 residuals := WordArray new: 3. 170656 sosSeen := false. 170657 self parseFirstMarker. 170658 [ sosSeen ] whileFalse: [ self parseNextMarker ]. 170659 xStep := mcuWidth * DCTSize. 170660 yStep := mcuHeight * DCTSize. 170661 y := 0. 170662 1 170663 to: mcuRowsInScan 170664 do: 170665 [ :row | 170666 x := 0. 170667 1 170668 to: mcusPerRow 170669 do: 170670 [ :col | 170671 self decodeMCU. 170672 self idctMCU. 170673 self colorConvertMCU. 170674 x := x + xStep ]. 170675 y := y + yStep ] ]! ! 170676 170677!JPEGReadWriter methodsFor: 'public access' stamp: 'tao 9/18/1998 08:53'! 170678nextImage 170679 170680 ^ self nextImageDitheredToDepth: Display depth 170681! ! 170682 170683!JPEGReadWriter methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! 170684nextImageDitheredToDepth: depth 170685 | form xStep yStep x y bb | 170686 ditherMask := DitherMasks 170687 at: depth 170688 ifAbsent: [ self error: 'can only dither to display depths' ]. 170689 residuals := WordArray new: 3. 170690 sosSeen := false. 170691 self parseFirstMarker. 170692 [ sosSeen ] whileFalse: [ self parseNextMarker ]. 170693 form := Form 170694 extent: width @ height 170695 depth: depth. 170696 bb := BitBlt current toForm: form. 170697 bb sourceForm: mcuImageBuffer. 170698 bb colorMap: (mcuImageBuffer colormapIfNeededFor: form). 170699 bb sourceRect: mcuImageBuffer boundingBox. 170700 bb combinationRule: Form over. 170701 xStep := mcuWidth * DCTSize. 170702 yStep := mcuHeight * DCTSize. 170703 y := 0. 170704 1 170705 to: mcuRowsInScan 170706 do: 170707 [ :row | 170708 x := 0. 170709 1 170710 to: mcusPerRow 170711 do: 170712 [ :col | 170713 self decodeMCU. 170714 self idctMCU. 170715 self colorConvertMCU. 170716 bb 170717 destX: x; 170718 destY: y; 170719 copyBits. 170720 x := x + xStep ]. 170721 y := y + yStep ]. 170722 ^ form! ! 170723 170724!JPEGReadWriter methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! 170725setStream: aStream 170726 "Feed it in from an existing source" 170727 stream := JPEGReadStream on: aStream upToEnd! ! 170728 170729 170730!JPEGReadWriter methodsFor: 'testing' stamp: 'ar 3/4/2001 00:50'! 170731understandsImageFormat 170732 "Answer true if the image stream format is understood by this decoder." 170733 self next = 16rFF ifFalse: [^ false]. 170734 self next = 16rD8 ifFalse: [^ false]. 170735 ^ true 170736! ! 170737 170738 170739!JPEGReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 170740on: aStream 170741 super on: aStream. 170742 stream := JPEGReadStream on: stream upToEnd! ! 170743 170744"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 170745 170746JPEGReadWriter class 170747 instanceVariableNames: ''! 170748 170749!JPEGReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'! 170750typicalFileExtensions 170751 "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" 170752 ^#('jpg' 'jpeg')! ! 170753 170754!JPEGReadWriter class methodsFor: 'image reading/writing' stamp: 'ar 6/16/2002 18:54'! 170755understandsImageFormat: aStream 170756 (JPEGReadWriter2 understandsImageFormat: aStream) ifTrue:[^false]. 170757 aStream reset. 170758 aStream next = 16rFF ifFalse: [^ false]. 170759 aStream next = 16rD8 ifFalse: [^ false]. 170760 ^true! ! 170761 170762 170763!JPEGReadWriter class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 170764initialize 170765 "JPEGReadWriter initialize" 170766 "general constants" 170767 DCTSize := 8. 170768 MaxSample := (2 raisedToInteger: DCTSize) - 1. 170769 SampleOffset := MaxSample // 2. 170770 FloatSampleOffset := SampleOffset asFloat. 170771 DCTSize2 := DCTSize squared. 170772 QuantizationTableSize := 4. 170773 HuffmanTableSize := 4. 170774 170775 "floating-point Inverse Discrete Cosine Transform (IDCT) constants" 170776 ConstBits := 13. 170777 Pass1Bits := 2. 170778 DCTK1 := 2 sqrt. 170779 DCTK2 := 1.847759065. 170780 DCTK3 := 1.0823922. 170781 DCTK4 := -2.61312593. 170782 Pass1Div := 1 bitShift: ConstBits - Pass1Bits. 170783 Pass2Div := 1 bitShift: ConstBits + Pass1Bits + 3. 170784 170785 "fixed-point Inverse Discrete Cosine Transform (IDCT) constants" 170786 FIXn0n298631336 := 2446. 170787 FIXn0n390180644 := 3196. 170788 FIXn0n541196100 := 4433. 170789 FIXn0n765366865 := 6270. 170790 FIXn0n899976223 := 7373. 170791 FIXn1n175875602 := 9633. 170792 FIXn1n501321110 := 12299. 170793 FIXn1n847759065 := 15137. 170794 FIXn1n961570560 := 16069. 170795 FIXn2n053119869 := 16819. 170796 FIXn2n562915447 := 20995. 170797 FIXn3n072711026 := 25172. 170798 170799 "fixed-point color conversion constants" 170800 FIXn0n34414 := 22554. 170801 FIXn0n71414 := 46802. 170802 FIXn1n40200 := 91881. 170803 FIXn1n77200 := 116130. 170804 170805 "reordering table from JPEG zig-zag order" 170806 JPEGNaturalOrder := #( 170807 1 170808 2 170809 9 170810 17 170811 10 170812 3 170813 4 170814 11 170815 18 170816 25 170817 33 170818 26 170819 19 170820 12 170821 5 170822 6 170823 13 170824 20 170825 27 170826 34 170827 41 170828 49 170829 42 170830 35 170831 28 170832 21 170833 14 170834 7 170835 8 170836 15 170837 22 170838 29 170839 36 170840 43 170841 50 170842 57 170843 58 170844 51 170845 44 170846 37 170847 30 170848 23 170849 16 170850 24 170851 31 170852 38 170853 45 170854 52 170855 59 170856 60 170857 53 170858 46 170859 39 170860 32 170861 40 170862 47 170863 54 170864 61 170865 62 170866 55 170867 48 170868 56 170869 63 170870 64 170871 ). 170872 170873 "scale factors for the values in the Quantization Tables" 170874 QTableScaleFactor := (0 to: DCTSize - 1) collect: 170875 [ :k | 170876 k = 0 170877 ifTrue: [ 1.0 ] 170878 ifFalse: [ (k * Float pi / 16) cos * 2 sqrt ] ]. 170879 170880 "dithering masks" 170881 (DitherMasks := Dictionary new) 170882 add: 0 -> 0; 170883 add: 1 -> 127; 170884 add: 2 -> 63; 170885 add: 4 -> 63; 170886 add: 8 -> 31; 170887 add: 16 -> 7; 170888 add: 32 -> 0. 170889 170890 "dictionary of marker parsers" 170891 (JFIFMarkerParser := Dictionary new) 170892 add: 1 -> #parseNOP; 170893 add: 192 -> #parseStartOfFile; 170894 add: 196 -> #parseHuffmanTable; 170895 addAll: ((208 to: 215) collect: 170896 [ :m | 170897 Association 170898 key: m 170899 value: #parseNOP ]); 170900 add: 216 -> #parseStartOfInput; 170901 add: 217 -> #parseEndOfInput; 170902 add: 218 -> #parseStartOfScan; 170903 add: 219 -> #parseQuantizationTable; 170904 add: 221 -> #parseDecoderRestartInterval; 170905 add: 224 -> #parseAPPn; 170906 add: 225 -> #parseAPPn! ! 170907ImageReadWriter subclass: #JPEGReadWriter2 170908 instanceVariableNames: '' 170909 classVariableNames: '' 170910 poolDictionaries: '' 170911 category: 'Graphics-Files'! 170912!JPEGReadWriter2 commentStamp: '<historical>' prior: 0! 170913I provide fast JPEG compression and decompression. I require the VM pluginJPEGReadWriter2Plugin, which is typically stored in same directory as the Squeak virtual machine. 170914 170915JPEGReadWriter2Plugin is based on LIBJPEG library. This sentence applies to the plugin: 170916 "This software is based in part on the work of the Independent JPEG Group". 170917 170918The LIBJPEG license allows it to be used free for any purpose so long as its origin and copyright are acknowledged. You can read more about LIBJPEG and get the complete source code at www.ijg.org. 170919! 170920 170921 170922!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:34'! 170923primImageHeight: aJPEGCompressStruct 170924 170925 <primitive: 'primImageHeight' module: 'JPEGReadWriter2Plugin'> 170926 self primitiveFailed 170927! ! 170928 170929!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! 170930primImageWidth: aJPEGCompressStruct 170931 170932 <primitive: 'primImageWidth' module: 'JPEGReadWriter2Plugin'> 170933 self primitiveFailed 170934! ! 170935 170936!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! 170937primJPEGCompressStructSize 170938 170939 <primitive: 'primJPEGCompressStructSize' module: 'JPEGReadWriter2Plugin'> 170940 self primitiveFailed 170941! ! 170942 170943!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! 170944primJPEGDecompressStructSize 170945 170946 <primitive: 'primJPEGDecompressStructSize' module: 'JPEGReadWriter2Plugin'> 170947 self primitiveFailed 170948! ! 170949 170950!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! 170951primJPEGErrorMgr2StructSize 170952 170953 <primitive: 'primJPEGErrorMgr2StructSize' module: 'JPEGReadWriter2Plugin'> 170954 self primitiveFailed 170955! ! 170956 170957!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'ar 11/27/2001 00:39'! 170958primJPEGPluginIsPresent 170959 <primitive: 'primJPEGPluginIsPresent' module: 'JPEGReadWriter2Plugin'> 170960 ^false! ! 170961 170962!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! 170963primJPEGReadHeader: aJPEGDecompressStruct fromByteArray: source errorMgr: aJPEGErrorMgr2Struct 170964 170965 <primitive: 'primJPEGReadHeaderfromByteArrayerrorMgr' module: 'JPEGReadWriter2Plugin'> 170966 self primitiveFailed 170967! ! 170968 170969!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jmv 12/7/2001 13:45'! 170970primJPEGReadImage: aJPEGDecompressStruct fromByteArray: source onForm: form doDithering: ditherFlag errorMgr: aJPEGErrorMgr2Struct 170971 170972 <primitive: 'primJPEGReadImagefromByteArrayonFormdoDitheringerrorMgr' module: 'JPEGReadWriter2Plugin'> 170973 self primitiveFailed 170974! ! 170975 170976!JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! 170977primJPEGWriteImage: aJPEGCompressStruct onByteArray: destination form: form quality: quality progressiveJPEG: progressiveFlag errorMgr: aJPEGErrorMgr2Struct 170978 170979 <primitive: 'primJPEGWriteImageonByteArrayformqualityprogressiveJPEGerrorMgr' module: 'JPEGReadWriter2Plugin'> 170980 self primitiveFailed 170981! ! 170982 170983 170984!JPEGReadWriter2 methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! 170985compress: aForm quality: quality 170986 "Encode the given Form and answer the compressed ByteArray. Quality goes from 0 (low) to 100 (high), where -1 means default." 170987 | sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount | 170988 aForm unhibernate. 170989 "odd width images of depth 16 give problems; avoid them." 170990 sourceForm := aForm depth = 32 | (aForm width even & (aForm depth = 16)) 170991 ifTrue: [ aForm ] 170992 ifFalse: [ aForm asFormOfDepth: 32 ]. 170993 jpegCompressStruct := ByteArray new: self primJPEGCompressStructSize. 170994 jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. 170995 buffer := ByteArray new: sourceForm width * sourceForm height + 1024. 170996 byteCount := self 170997 primJPEGWriteImage: jpegCompressStruct 170998 onByteArray: buffer 170999 form: sourceForm 171000 quality: quality 171001 progressiveJPEG: false 171002 errorMgr: jpegErrorMgr2Struct. 171003 byteCount = 0 ifTrue: [ self error: 'buffer too small for compressed data' ]. 171004 ^ buffer 171005 copyFrom: 1 171006 to: byteCount! ! 171007 171008!JPEGReadWriter2 methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! 171009imageExtent: aByteArray 171010 "Answer the extent of the compressed image encoded in the given ByteArray." 171011 | jpegDecompressStruct jpegErrorMgr2Struct w h | 171012 jpegDecompressStruct := ByteArray new: self primJPEGDecompressStructSize. 171013 jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. 171014 self 171015 primJPEGReadHeader: jpegDecompressStruct 171016 fromByteArray: aByteArray 171017 errorMgr: jpegErrorMgr2Struct. 171018 w := self primImageWidth: jpegDecompressStruct. 171019 h := self primImageHeight: jpegDecompressStruct. 171020 ^ w @ h! ! 171021 171022!JPEGReadWriter2 methodsFor: 'public access' stamp: 'jm 11/20/2001 10:23'! 171023nextImage 171024 "Decode and answer a Form from my stream." 171025 171026 ^ self nextImageSuggestedDepth: Display depth 171027! ! 171028 171029!JPEGReadWriter2 methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! 171030nextImageSuggestedDepth: depth 171031 "Decode and answer a Form of the given depth from my stream. Close the stream if it is a file stream. Possible depths are 16-bit and 32-bit." 171032 | bytes width height form jpegDecompressStruct jpegErrorMgr2Struct depthToUse | 171033 bytes := stream upToEnd. 171034 stream close. 171035 jpegDecompressStruct := ByteArray new: self primJPEGDecompressStructSize. 171036 jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. 171037 self 171038 primJPEGReadHeader: jpegDecompressStruct 171039 fromByteArray: bytes 171040 errorMgr: jpegErrorMgr2Struct. 171041 width := self primImageWidth: jpegDecompressStruct. 171042 height := self primImageHeight: jpegDecompressStruct. 171043 "Odd width images of depth 16 gave problems. Avoid them (or check carefully!!)" 171044 depthToUse := depth = 32 | width odd 171045 ifTrue: [ 32 ] 171046 ifFalse: [ 16 ]. 171047 form := Form 171048 extent: width @ height 171049 depth: depthToUse. 171050 (width = 0 or: [ height = 0 ]) ifTrue: [ ^ form ]. 171051 self 171052 primJPEGReadImage: jpegDecompressStruct 171053 fromByteArray: bytes 171054 onForm: form 171055 doDithering: true 171056 errorMgr: jpegErrorMgr2Struct. 171057 ^ form! ! 171058 171059!JPEGReadWriter2 methodsFor: 'public access' stamp: 'jm 11/20/2001 10:21'! 171060nextPutImage: aForm 171061 "Encode the given Form on my stream with default quality." 171062 171063 ^ self nextPutImage: aForm quality: -1 progressiveJPEG: false 171064! ! 171065 171066!JPEGReadWriter2 methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! 171067nextPutImage: aForm quality: quality progressiveJPEG: progressiveFlag 171068 "Encode the given Form on my stream with the given settings. Quality goes from 0 (low) to 100 (high), where -1 means default. If progressiveFlag is true, encode as a progressive JPEG." 171069 | sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount | 171070 aForm unhibernate. 171071 "odd width images of depth 16 give problems; avoid them." 171072 sourceForm := aForm depth = 32 | (aForm width even & (aForm depth = 16)) 171073 ifTrue: [ aForm ] 171074 ifFalse: [ aForm asFormOfDepth: 32 ]. 171075 jpegCompressStruct := ByteArray new: self primJPEGCompressStructSize. 171076 jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. 171077 buffer := ByteArray new: sourceForm width * sourceForm height + 1024. 171078 byteCount := self 171079 primJPEGWriteImage: jpegCompressStruct 171080 onByteArray: buffer 171081 form: sourceForm 171082 quality: quality 171083 progressiveJPEG: progressiveFlag 171084 errorMgr: jpegErrorMgr2Struct. 171085 byteCount = 0 ifTrue: [ self error: 'buffer too small for compressed data' ]. 171086 stream 171087 next: byteCount 171088 putAll: buffer 171089 startingAt: 1. 171090 self close! ! 171091 171092!JPEGReadWriter2 methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! 171093uncompress: aByteArray into: aForm 171094 "Uncompress an image from the given ByteArray into the given Form. 171095 Fails if the given Form has the wrong dimensions or depth. 171096 If aForm has depth 16, do ordered dithering." 171097 | jpegDecompressStruct jpegErrorMgr2Struct w h | 171098 aForm unhibernate. 171099 jpegDecompressStruct := ByteArray new: self primJPEGDecompressStructSize. 171100 jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. 171101 self 171102 primJPEGReadHeader: jpegDecompressStruct 171103 fromByteArray: aByteArray 171104 errorMgr: jpegErrorMgr2Struct. 171105 w := self primImageWidth: jpegDecompressStruct. 171106 h := self primImageHeight: jpegDecompressStruct. 171107 aForm width = w & (aForm height = h) ifFalse: [ ^ self error: 'form dimensions do not match' ]. 171108 171109 "odd width images of depth 16 give problems; avoid them" 171110 w odd 171111 ifTrue: 171112 [ aForm depth = 32 ifFalse: [ ^ self error: 'must use depth 32 with odd width' ] ] 171113 ifFalse: 171114 [ aForm depth = 16 | (aForm depth = 32) ifFalse: [ ^ self error: 'must use depth 16 or 32' ] ]. 171115 self 171116 primJPEGReadImage: jpegDecompressStruct 171117 fromByteArray: aByteArray 171118 onForm: aForm 171119 doDithering: true 171120 errorMgr: jpegErrorMgr2Struct! ! 171121 171122!JPEGReadWriter2 methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! 171123uncompress: aByteArray into: aForm doDithering: ditherFlag 171124 "Uncompress an image from the given ByteArray into the given Form. 171125 Fails if the given Form has the wrong dimensions or depth. 171126 If aForm has depth 16 and ditherFlag = true, do ordered dithering." 171127 | jpegDecompressStruct jpegErrorMgr2Struct w h | 171128 aForm unhibernate. 171129 jpegDecompressStruct := ByteArray new: self primJPEGDecompressStructSize. 171130 jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. 171131 self 171132 primJPEGReadHeader: jpegDecompressStruct 171133 fromByteArray: aByteArray 171134 errorMgr: jpegErrorMgr2Struct. 171135 w := self primImageWidth: jpegDecompressStruct. 171136 h := self primImageHeight: jpegDecompressStruct. 171137 aForm width = w & (aForm height = h) ifFalse: [ ^ self error: 'form dimensions do not match' ]. 171138 171139 "odd width images of depth 16 give problems; avoid them" 171140 w odd 171141 ifTrue: 171142 [ aForm depth = 32 ifFalse: [ ^ self error: 'must use depth 32 with odd width' ] ] 171143 ifFalse: 171144 [ aForm depth = 16 | (aForm depth = 32) ifFalse: [ ^ self error: 'must use depth 16 or 32' ] ]. 171145 self 171146 primJPEGReadImage: jpegDecompressStruct 171147 fromByteArray: aByteArray 171148 onForm: aForm 171149 doDithering: ditherFlag 171150 errorMgr: jpegErrorMgr2Struct! ! 171151 171152 171153!JPEGReadWriter2 methodsFor: 'testing' stamp: 'ar 11/27/2001 00:40'! 171154isPluginPresent 171155 ^self primJPEGPluginIsPresent! ! 171156 171157!JPEGReadWriter2 methodsFor: 'testing' stamp: 'ar 11/27/2001 00:39'! 171158understandsImageFormat 171159 "Answer true if the image stream format is understood by this decoder." 171160 self isPluginPresent ifFalse:[^false]. "cannot read it otherwise" 171161 self next = 16rFF ifFalse: [^ false]. 171162 self next = 16rD8 ifFalse: [^ false]. 171163 ^ true 171164! ! 171165 171166"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 171167 171168JPEGReadWriter2 class 171169 instanceVariableNames: ''! 171170 171171!JPEGReadWriter2 class methodsFor: 'image reading/writing' stamp: 'ar 6/16/2002 18:54'! 171172primJPEGPluginIsPresent 171173 <primitive: 'primJPEGPluginIsPresent' module: 'JPEGReadWriter2Plugin'> 171174 ^false! ! 171175 171176!JPEGReadWriter2 class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! 171177putForm: aForm quality: quality progressiveJPEG: progressiveFlag onFileNamed: fileName 171178 "Store the given Form as a JPEG file of the given name, overwriting any existing file of that name. Quality goes from 0 (low) to 100 (high), where -1 means default. If progressiveFlag is true, encode as a progressive JPEG." 171179 | writer | 171180 FileDirectory deleteFilePath: fileName. 171181 writer := self on: (FileStream newFileNamed: fileName) binary. 171182 Cursor write showWhile: 171183 [ writer 171184 nextPutImage: aForm 171185 quality: quality 171186 progressiveJPEG: progressiveFlag ]. 171187 writer close! ! 171188 171189!JPEGReadWriter2 class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'! 171190typicalFileExtensions 171191 "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" 171192 ^#('jpg' 'jpeg')! ! 171193LanguageEnvironment subclass: #JapaneseEnvironment 171194 instanceVariableNames: '' 171195 classVariableNames: '' 171196 poolDictionaries: '' 171197 category: 'Multilingual-Languages'! 171198!JapaneseEnvironment commentStamp: '<historical>' prior: 0! 171199This class provides the Japanese support. Since it has been used most other than default 'latin-1' languages, this tends to be a good place to look at when you want to know what a typical subclass of LanguageEnvironment should do. 171200! 171201 171202 171203"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 171204 171205JapaneseEnvironment class 171206 instanceVariableNames: ''! 171207 171208!JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 8/3/2004 21:25'! 171209flapTabTextFor: aString in: aFlapTab 171210 171211 | string | 171212 string := super flapTabTextFor: aString. 171213 string isEmptyOrNil ifTrue: [^ self]. 171214 string := aFlapTab orientation == #vertical 171215 ifTrue: [string copyReplaceAll: 'ー' with: '｜'] 171216 ifFalse: [string copyReplaceAll: '｜' with: 'ー']. 171217 171218 ^ string. 171219!]lang[(213 1 9 1 41 1 9 1 16)0,5,0,5,0,5,0,5,0! ! 171220 171221!JapaneseEnvironment class methodsFor: 'language methods' stamp: 'ar 4/9/2005 22:31'! 171222fromJISX0208String: aString 171223 171224 ^ aString collect: [:each | Character leadingChar: JapaneseEnvironment leadingChar code: (each asUnicode)]. 171225! ! 171226 171227!JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 3/17/2004 21:54'! 171228scanSelector 171229 171230 ^ #scanJapaneseCharactersFrom:to:in:rightX:stopConditions:kern: 171231! ! 171232 171233!JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 3/16/2004 14:49'! 171234traditionalCharsetClass 171235 171236 ^ JISX0208. 171237! ! 171238 171239 171240!JapaneseEnvironment class methodsFor: 'public query' stamp: 'nk 7/30/2004 21:43'! 171241defaultEncodingName 171242 | platformName osVersion | 171243 platformName := SmalltalkImage current platformName. 171244 osVersion := SmalltalkImage current getSystemAttribute: 1002. 171245 (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8']. 171246 (#('Win32' 'ZaurusOS') includes: platformName) ifTrue: [^'shift-jis']. 171247 platformName = 'Mac OS' 171248 ifTrue: 171249 [^('10*' match: SmalltalkImage current osVersion) 171250 ifTrue: ['utf-8'] 171251 ifFalse: ['shift-jis']]. 171252 ^'unix' = platformName ifTrue: ['euc-jp'] ifFalse: ['mac-roman']! ! 171253 171254 171255!JapaneseEnvironment class methodsFor: 'rendering support' stamp: 'yo 3/18/2005 08:00'! 171256isBreakableAt: index in: text 171257 171258 | prev | 171259 index = 1 ifTrue: [^ false]. 171260 prev := text at: index - 1. 171261 prev leadingChar ~= JapaneseEnvironment leadingChar ifTrue: [^ true]. 171262 ^ (('、。，．・：；？！゛゜´｀¨＾―‐／\〜‖｜…‥’”）〕］｝〉》」』】°′″℃' includes: (text at: index)) or: ['‘“（〔［｛〈《「『【°′″℃＠§' includes: prev]) not. 171263!]lang[(177 11 1 1 1 4 1 16 1 3 36 11 1 4 25)0,5,0,5,0,5,0,5,0,5,0,5,0,5,0! ! 171264 171265 171266!JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 21:55'! 171267leadingChar 171268 171269 ^ 5. 171270! ! 171271 171272!JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/21/2004 19:09'! 171273supportedLanguages 171274 "Return the languages that this class supports. 171275 Any translations for those languages will use this class as their environment." 171276 171277 ^#('ja' 'ja-etoys' )! ! 171278 171279!JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'T2 2/3/2005 13:07'! 171280systemConverterClass 171281 | platformName osVersion encoding | 171282 platformName := SmalltalkImage current platformName. 171283 osVersion := SmalltalkImage current getSystemAttribute: 1002. 171284 (platformName = 'Win32' and: [osVersion = 'CE']) 171285 ifTrue: [^UTF8TextConverter]. 171286 (#('Win32' 'ZaurusOS') includes: platformName) 171287 ifTrue: [^ShiftJISTextConverter]. 171288 platformName = 'Mac OS' 171289 ifTrue: 171290 [^('10*' match: SmalltalkImage current osVersion) 171291 ifTrue: [UTF8TextConverter] 171292 ifFalse: [ShiftJISTextConverter]]. 171293 platformName = 'unix' 171294 ifTrue: 171295 [encoding := X11Encoding encoding. 171296 encoding ifNil: [^EUCJPTextConverter]. 171297 (encoding = 'utf-8') 171298 ifTrue: [^UTF8TextConverter]. 171299 (encoding = 'shiftjis' | encoding = 'sjis') 171300 ifTrue: [^ShiftJISTextConverter]. 171301 ^EUCJPTextConverter]. 171302 ^MacRomanTextConverter! ! 171303Object subclass: #JoinSection 171304 instanceVariableNames: 'src dst borderWidth borderColor type width shape' 171305 classVariableNames: '' 171306 poolDictionaries: '' 171307 category: 'Polymorph-Tools-Diff'! 171308 171309!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:16'! 171310borderColor 171311 "Answer the value of borderColor" 171312 171313 ^ borderColor! ! 171314 171315!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:16'! 171316borderColor: aColor 171317 "Set the value of borderColor" 171318 171319 borderColor := aColor. 171320 self updateHighlights! ! 171321 171322!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:16'! 171323borderWidth 171324 "Answer the value of borderWidth" 171325 171326 ^ borderWidth! ! 171327 171328!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:16'! 171329borderWidth: anInteger 171330 "Set the value of borderWidth" 171331 171332 borderWidth := anInteger. 171333 self src highlight notNil ifTrue: [ 171334 self src highlight borderWidth: anInteger]. 171335 self dst highlight notNil ifTrue: [ 171336 self dst highlight borderWidth: anInteger]! ! 171337 171338!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171339dst 171340 "Answer the value of dst" 171341 171342 ^ dst! ! 171343 171344!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171345dst: anObject 171346 "Set the value of dst" 171347 171348 dst := anObject! ! 171349 171350!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171351dstColor: aColor 171352 "Set the dst color" 171353 171354 self dst color: aColor! ! 171355 171356!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171357dstLineRange: anInterval 171358 "Set the dst lineRange." 171359 171360 self dst lineRange: anInterval! ! 171361 171362!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171363dstOffset: aPoint 171364 "Set the dst offset." 171365 171366 self dst offset: aPoint. 171367 self updateShape! ! 171368 171369!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171370dstRange: anInterval 171371 "Set the dst range." 171372 171373 self dst range: anInterval. 171374 self updateShape! ! 171375 171376!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171377shape 171378 "Answer the value of shape" 171379 171380 ^ shape! ! 171381 171382!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171383shape: anObject 171384 "Set the value of shape" 171385 171386 shape := anObject! ! 171387 171388!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171389src 171390 "Answer the value of src" 171391 171392 ^ src! ! 171393 171394!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171395src: anObject 171396 "Set the value of src" 171397 171398 src := anObject! ! 171399 171400!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171401srcColor: aColor 171402 "Set the src color." 171403 171404 self src color: aColor! ! 171405 171406!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171407srcLineRange: anInterval 171408 "Set the src lneRange." 171409 171410 self src lineRange: anInterval! ! 171411 171412!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171413srcOffset: aPoint 171414 "Set the src offset" 171415 171416 self src offset: aPoint. 171417 self updateShape! ! 171418 171419!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171420srcRange: anInterval 171421 "Set the src range" 171422 171423 self src range: anInterval. 171424 self updateShape! ! 171425 171426!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171427type 171428 "Answer the value of type" 171429 171430 ^ type! ! 171431 171432!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! 171433type: anObject 171434 "Set the value of type" 171435 171436 type := anObject! ! 171437 171438!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:28'! 171439updateHighlights 171440 "Update the highlight border colors." 171441 171442 |bc| 171443 (self src isNil or: [self dst isNil]) ifTrue: [^self]. 171444 bc := self borderColorToUse. 171445 self src highlight notNil ifTrue: [ 171446 self src highlight borderColor: bc]. 171447 self dst highlight notNil ifTrue: [ 171448 self dst highlight borderColor: bc]! ! 171449 171450!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:21'! 171451width 171452 "Answer the value of width" 171453 171454 ^ width! ! 171455 171456!JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:21'! 171457width: anObject 171458 "Set the value of width" 171459 171460 width := anObject. 171461 self updateShape! ! 171462 171463 171464!JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:16'! 171465addHighlightsFrom: srcBlock to: dstBlock to: aCollection color: aColor 171466 "Add the highlights required for the given character blocks 171467 of a paragraph. May be up to three highlights depending 171468 on the line spans." 171469 171470 srcBlock textLine = dstBlock textLine 171471 ifTrue: [aCollection add: (TextHighlight new 171472 color: aColor; 171473 bounds: (srcBlock topLeft corner: dstBlock bottomRight))] 171474 ifFalse: [aCollection 171475 add: (TextHighlight new 171476 color: aColor; 171477 bounds: (srcBlock topLeft corner: srcBlock textLine bottomRight)); 171478 add: (TextHighlight new 171479 fillWidth: true; 171480 color: aColor; 171481 bounds: (srcBlock bottomLeft corner: dstBlock topRight)); 171482 add: (TextHighlight new 171483 color: aColor; 171484 bounds: (dstBlock textLine topLeft corner: dstBlock bottomRight))]! ! 171485 171486!JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:22'! 171487borderColorToUse 171488 "Answer the border color to use." 171489 171490 ^self borderColor! ! 171491 171492!JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:17'! 171493clicked 171494 "The receiver or a highlight was clicked." 171495 171496 self wantsClick ifFalse: [^false]. 171497 ^true! ! 171498 171499!JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:18'! 171500containsPoint: aPoint 171501 "Answer whether the receiver contains the given point." 171502 171503 ^self shape containsPoint: aPoint! ! 171504 171505!JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:18'! 171506createHighlights 171507 "Create and store the src and dst highlights." 171508 171509 |s d| 171510 s := OrderedCollection new. 171511 d := OrderedCollection new. 171512 s add: (self newHighlight 171513 color: self src color; 171514 borderWidth: self borderWidth; 171515 bounds: (0@self src range first corner: 0@(self src range last + 1)); 171516 borderSides: #(top left bottom)). 171517 d add: (self newHighlight 171518 color: self dst color; 171519 borderWidth: self borderWidth; 171520 bounds: (0@self dst range first corner: 0@(self dst range last + 1)); 171521 borderSides: #(top right bottom)). 171522 self src highlights: s. 171523 self dst highlights: d! ! 171524 171525!JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:18'! 171526createHighlightsFrom: srcPara to: dstPara 171527 "Create and store the src and dst highlights. 171528 Use the given paragraphs to determine inline 171529 diffs." 171530 171531 |s d si di srcText dstText diffs i sb eb line| 171532 self createHighlights. 171533 self src lineRange notEmpty 171534 ifTrue: [ line := srcPara lines at: self src lineRange first. 171535 si := line first. 171536 line := srcPara lines at: self src lineRange last. 171537 srcText := srcPara string copyFrom: si to: line last] 171538 ifFalse: [srcText := '']. 171539 self dst lineRange notEmpty 171540 ifTrue: [line := dstPara lines at: self dst lineRange first. 171541 di := line first. 171542 line := dstPara lines at: self dst lineRange last. 171543 dstText := dstPara string copyFrom: di to: line last] 171544 ifFalse: [dstText := '']. 171545 self src text: srcText. 171546 self dst text: dstText. 171547 self type = #modification ifFalse: [^self]. 171548 s := self src highlights. 171549 d := self dst highlights. 171550 diffs := (InlineTextDiffBuilder from: srcText to: dstText) 171551 buildPatchSequence 171552 aggregateRuns: [:e | e key]. 171553 diffs do: [:c | 171554 c first key = #match 171555 ifTrue: [c do: [:a | 171556 si := si + a value size. 171557 di := di + a value size]]. 171558 c first key = #insert 171559 ifTrue: [i := di. 171560 c do: [:a | di := di + a value size]. 171561 sb := dstPara characterBlockForIndex: i. 171562 eb := dstPara characterBlockForIndex: di - 1. 171563 self addHighlightsFrom: sb to: eb to: d color: (Color green alpha: 0.3)]. 171564 c first key = #remove 171565 ifTrue: [i := si. 171566 c do: [:a | si := si + a value size]. 171567 sb := srcPara characterBlockForIndex: i. 171568 eb := srcPara characterBlockForIndex: si - 1. 171569 self addHighlightsFrom: sb to: eb to: s color: (Color red alpha: 0.3)]]! ! 171570 171571!JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:24'! 171572drawMapOn: aCanvas in: rect scale: scale 171573 "Draw the join on the given canvas scaled into the given rectangle." 171574 171575 self type = #match ifTrue: [^self]. 171576 aCanvas 171577 frameAndFillRectangle: (rect left @ (((self dst range first max: 0) * scale) truncated + rect top) 171578 corner: (rect right @ ((self dst range last * scale) truncated + rect top))) 171579 fillColor: (self fillStyleFor: rect) 171580 borderWidth: 1 171581 borderColor: self borderColorToUse! ! 171582 171583!JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:23'! 171584drawOn: aCanvas 171585 "Draw the join on the given canvas." 171586 171587 |v bc| 171588 (self src color isTransparent and: [self dst color isTransparent]) 171589 ifTrue: [^self]. 171590 v := self shape vertices. 171591 aCanvas 171592 drawPolygon: v 171593 fillStyle: (self fillStyleFor: self shape bounds). 171594 (self borderWidth > 0 and: [self borderColor isTransparent not]) ifTrue: [ 171595 bc := self borderColorToUse. 171596 aCanvas 171597 line: v first + (0@self borderWidth // 2) 171598 to: v second + (-1@self borderWidth // 2) 171599 width: self borderWidth 171600 color: bc; 171601 line: v third - (1@(self borderWidth // 2)) 171602 to: v fourth - (0@(self borderWidth // 2)) 171603 width: self borderWidth 171604 color: bc]! ! 171605 171606!JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:19'! 171607fillStyleFor: rect 171608 "Answer the fillStyle to use for the given rectangle." 171609 171610 ^self src color = self dst color 171611 ifTrue: [self src color] 171612 ifFalse: [(GradientFillStyle ramp: {0.0 -> self src color. 1.0 -> self dst color}) 171613 direction: rect width@0; 171614 origin: rect topLeft]! ! 171615 171616!JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:20'! 171617initialize 171618 "Initialize the receiver." 171619 171620 super initialize. 171621 self 171622 src: JoinSide new; 171623 dst: JoinSide new; 171624 shape: Polygon new; 171625 width: 0; 171626 borderWidth: 0; 171627 borderColor: Color transparent; 171628 type: #modification! ! 171629 171630!JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:18'! 171631newHighlight 171632 "Anwser a new highlight." 171633 171634 ^TextHighlight new 171635 borderWidth: 1; 171636 borderColor: self borderColor; 171637 fillWidth: true! ! 171638 171639!JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:19'! 171640updateShape 171641 "Update the receiver's shape." 171642 171643 (self src range isNil or: [self dst range isNil]) ifTrue: [^self]. 171644 self shape: (Polygon vertices: 171645 {(0@ self src range first) + self src offset. (self width @ self dst range first) + self dst offset. 171646 (self width @ self dst range last) + self dst offset. (0@self src range last) + self src offset})! ! 171647 171648!JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:19'! 171649wantsClick 171650 "Don't if we are transparent for now." 171651 171652 ^(self src color isTransparent and: [self dst color isTransparent]) not! ! 171653Object subclass: #JoinSide 171654 instanceVariableNames: 'range offset lineRange highlights color text' 171655 classVariableNames: '' 171656 poolDictionaries: '' 171657 category: 'Polymorph-Tools-Diff'! 171658 171659!JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! 171660color 171661 "Answer the value of color" 171662 171663 ^ color! ! 171664 171665!JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! 171666color: anObject 171667 "Set the value of color" 171668 171669 color := anObject! ! 171670 171671!JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! 171672highlights 171673 "Answer the value of highlights" 171674 171675 ^ highlights! ! 171676 171677!JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! 171678highlights: anObject 171679 "Set the value of highlights" 171680 171681 highlights := anObject! ! 171682 171683!JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! 171684lineRange 171685 "Answer the value of lineRange" 171686 171687 ^ lineRange! ! 171688 171689!JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! 171690lineRange: anObject 171691 "Set the value of lineRange" 171692 171693 lineRange := anObject! ! 171694 171695!JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! 171696offset 171697 "Answer the value of offset" 171698 171699 ^ offset! ! 171700 171701!JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! 171702offset: anObject 171703 "Set the value of offset" 171704 171705 offset := anObject! ! 171706 171707!JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! 171708range 171709 "Answer the value of range" 171710 171711 ^ range! ! 171712 171713!JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! 171714range: anObject 171715 "Set the value of range" 171716 171717 range := anObject! ! 171718 171719!JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 11:09'! 171720text 171721 "Answer the value of text" 171722 171723 ^ text! ! 171724 171725!JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 11:09'! 171726text: anObject 171727 "Set the value of text" 171728 171729 text := anObject! ! 171730 171731 171732!JoinSide methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 10:58'! 171733highlight 171734 "Answer the primary highlight." 171735 171736 ^(self highlights ifEmpty: [^nil]) first! ! 171737 171738!JoinSide methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 11:09'! 171739initialize 171740 "Initialize the receiver." 171741 171742 super initialize. 171743 self 171744 highlights: #(); 171745 offset: 0@0; 171746 range: (1 to: 1); 171747 lineRange: (1 to: 0); 171748 color: Color yellow; 171749 text: ''! ! 171750ByteTextConverter subclass: #KOI8RTextConverter 171751 instanceVariableNames: '' 171752 classVariableNames: 'FromTable' 171753 poolDictionaries: '' 171754 category: 'Multilingual-TextConversion'! 171755 171756"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 171757 171758KOI8RTextConverter class 171759 instanceVariableNames: ''! 171760 171761!KOI8RTextConverter class methodsFor: 'accessing' stamp: 'yo 12/11/2007 10:59'! 171762encodingNames 171763 171764 ^ #('koi8-r') copy 171765! ! 171766 171767!KOI8RTextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 18:53'! 171768languageEnvironment 171769 ^RussianEnvironment! ! 171770 171771 171772!KOI8RTextConverter class methodsFor: 'initialization' stamp: 'michael.rueger 2/5/2009 14:07'! 171773byteToUnicodeSpec 171774 "Sepcify a table mapping the entries 0x80 to 0xFF to their unicode counterparts by returning a 128 element array.. 171775 The entries 0x00 to 0x7F map to identical values so we don't need to specify them." 171776 171777 "http://en.wikipedia.org/wiki/KOI8-R" 171778 "http://unicode.org/Public/MAPPINGS/VENDORS/MISC/KOI8-R.TXT" 171779 ^#( 171780 16r2500 16r2502 16r250C 16r2510 16r2514 16r2518 16r251C 16r2524 171781 16r252C 16r2534 16r253C 16r2580 16r2584 16r2588 16r258C 16r2590 171782 171783 16r2591 16r2592 16r2593 16r2320 16r25A0 16r2219 16r221A 16r2248 171784 16r2264 16r2265 16r00A0 16r2321 16r00B0 16r00B2 16r00B7 16r00F7 171785 171786 16r2550 16r2551 16r2552 16r0451 16r2553 16r2554 16r2555 16r2556 171787 16r2557 16r2558 16r2559 16r255A 16r255B 16r255C 16r255D 16r255E 171788 171789 16r255F 16r2560 16r2561 16r0401 16r2562 16r2563 16r2564 16r2565 171790 16r2566 16r2567 16r2568 16r2569 16r256A 16r256B 16r256C 16r00A9 171791 171792 16r044E 16r0430 16r0431 16r0446 16r0434 16r0435 16r0444 16r0433 171793 16r0445 16r0438 16r0439 16r043A 16r043B 16r043C 16r043D 16r043E 171794 171795 16r043F 16r044F 16r0440 16r0441 16r0442 16r0443 16r0436 16r0432 171796 16r044C 16r044B 16r0437 16r0448 16r044D 16r0449 16r0447 16r044A 171797 171798 16r042E 16r0410 16r0411 16r0426 16r0414 16r0415 16r0424 16r0413 171799 16r0425 16r0418 16r0419 16r041A 16r041B 16r041C 16r041D 16r041E 171800 171801 16r041F 16r042F 16r0420 16r0421 16r0422 16r0423 16r0416 16r0412 171802 16r042C 16r042B 16r0417 16r0428 16r042D 16r0429 16r0427 16r042A 171803)! ! 171804EncodedCharSet subclass: #KSX1001 171805 instanceVariableNames: '' 171806 classVariableNames: '' 171807 poolDictionaries: '' 171808 category: 'Multilingual-Encodings'! 171809!KSX1001 commentStamp: 'yo 10/19/2004 19:53' prior: 0! 171810This class represents the domestic character encoding called KS X 1001 used for Korean.! 171811 171812 171813"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 171814 171815KSX1001 class 171816 instanceVariableNames: ''! 171817 171818!KSX1001 class methodsFor: 'character classification' stamp: 'yo 8/6/2003 05:30'! 171819isLetter: char 171820 171821 | value leading | 171822 171823 leading := char leadingChar. 171824 value := char charCode. 171825 171826 leading = 0 ifTrue: [^ super isLetter: char]. 171827 171828 value := value // 94 + 1. 171829 ^ 1 <= value and: [value < 84]. 171830! ! 171831 171832 171833!KSX1001 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! 171834compoundTextSequence 171835 ^ compoundTextSequence! ! 171836 171837!KSX1001 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! 171838initialize 171839 " 171840 KSX1001 initialize 171841" 171842 compoundTextSequence := String streamContents: 171843 [ :stream | 171844 stream nextPut: Character escape. 171845 stream nextPut: $$. 171846 stream nextPut: $(. 171847 stream nextPut: $C ]! ! 171848 171849!KSX1001 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:49'! 171850leadingChar 171851 171852 ^ 3. 171853! ! 171854 171855!KSX1001 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! 171856nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state 171857 | c1 c2 | 171858 state charSize: 2. 171859 state g0Leading ~= self leadingChar ifTrue: 171860 [ state g0Leading: self leadingChar. 171861 state g0Size: 2. 171862 aStream basicNextPutAll: compoundTextSequence ]. 171863 c1 := ascii // 94 + 33. 171864 c2 := ascii \\ 94 + 33. 171865 ^ aStream 171866 basicNextPut: (Character value: c1); 171867 basicNextPut: (Character value: c2)! ! 171868 171869!KSX1001 class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'! 171870ucsTable 171871 171872 ^ UCSTable ksx1001Table. 171873! ! 171874FloatArray variableWordSubclass: #KedamaFloatArray 171875 instanceVariableNames: '' 171876 classVariableNames: '' 171877 poolDictionaries: '' 171878 category: 'Collections-Arrayed'! 171879 171880!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:40'! 171881* other 171882 171883 | result | 171884 other isNumber ifTrue: [ 171885 result := KedamaFloatArray new: self size. 171886 ^ self primMulScalar: self and: other into: result. 171887 ]. 171888 ((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [ 171889 result := KedamaFloatArray new: self size. 171890 ^ self primMulArray: self and: other into: result. 171891 ]. 171892 ^ super * other. 171893! ! 171894 171895!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:43'! 171896*= other 171897 171898 other isNumber ifTrue: [ 171899 ^ self primMulScalar: self and: other asFloat into: self. 171900 ]. 171901 ((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [ 171902 ^ self primMulArray: self and: other into: self. 171903 ]. 171904 ^ super *= other. 171905! ! 171906 171907!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:30'! 171908+ other 171909 171910 | result | 171911 other isNumber ifTrue: [ 171912 result := KedamaFloatArray new: self size. 171913 ^ self primAddScalar: self and: other into: result. 171914 ]. 171915 ((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [ 171916 result := KedamaFloatArray new: self size. 171917 ^ self primAddArray: self and: other into: result. 171918 ]. 171919 ^ super + other. 171920! ! 171921 171922!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:44'! 171923+= other 171924 171925 other isNumber ifTrue: [ 171926 ^ self primAddScalar: self and: other into: self. 171927 ]. 171928 ((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [ 171929 ^ self primAddArray: self and: other into: self. 171930 ]. 171931 ^ super += other. 171932! ! 171933 171934!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:40'! 171935- other 171936 171937 | result | 171938 other isNumber ifTrue: [ 171939 result := KedamaFloatArray new: self size. 171940 ^ self primSubScalar: self and: other into: result. 171941 ]. 171942 ((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [ 171943 result := KedamaFloatArray new: self size. 171944 ^ self primSubArray: self and: other into: result. 171945 ]. 171946 ^ super - other. 171947! ! 171948 171949!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:44'! 171950-= other 171951 171952 other isNumber ifTrue: [ 171953 ^ self primSubScalar: self and: other into: self. 171954 ]. 171955 ((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [ 171956 ^ self primSubArray: self and: other into: self. 171957 ]. 171958 ^ super -= other. 171959! ! 171960 171961!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:41'! 171962/ other 171963 171964 | result | 171965 other isNumber ifTrue: [ 171966 result := KedamaFloatArray new: self size. 171967 ^ self primDivScalar: self and: other into: result. 171968 ]. 171969 ((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [ 171970 result := KedamaFloatArray new: self size. 171971 ^ self primDivArray: self and: other into: result. 171972 ]. 171973 ^ super / other. 171974! ! 171975 171976!KedamaFloatArray methodsFor: 'arithmetic' stamp: 'yo 10/25/2004 15:45'! 171977/= other 171978 171979 other isNumber ifTrue: [ 171980 ^ self primDivScalar: self and: other into: self. 171981 ]. 171982 ((other isMemberOf: WordArray) or: [other isMemberOf: KedamaFloatArray]) ifTrue: [ 171983 ^ self primDivArray: self and: other into: self. 171984 ]. 171985 ^ super /= other. 171986! ! 171987 171988 171989!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:39'! 171990primAddArray: rcvr and: other into: result 171991 171992 <primitive: 'primitiveAddArrays' module:'KedamaPlugin'> 171993 "^ KedamaPlugin doPrimitive: #primitiveAddArrays." 171994 171995 1 to: rcvr size do: [:i | 171996 result at: i put: (rcvr at: i) + (other at: i) 171997 ]. 171998 ^ result. 171999! ! 172000 172001!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:15'! 172002primAddScalar: rcvr and: other into: result 172003 172004 <primitive: 'primitiveAddScalar' module:'KedamaPlugin'> 172005 "^ KedamaPlugin doPrimitive: #primitiveAddScalar." 172006 172007 1 to: rcvr size do: [:i | 172008 result at: i put: (rcvr at: i) + other. 172009 ]. 172010 ^ result. 172011! ! 172012 172013!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:39'! 172014primDivArray: rcvr and: other into: result 172015 172016 <primitive: 'primitiveDivArrays' module:'KedamaPlugin'> 172017 "^ KedamaPlugin doPrimitive: #primitiveDivArrays." 172018 172019 1 to: rcvr size do: [:i | 172020 result at: i put: (rcvr at: i) / (other at: i) 172021 ]. 172022 ^ result. 172023! ! 172024 172025!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:39'! 172026primDivScalar: rcvr and: other into: result 172027 172028 <primitive: 'primitiveDivScalar' module:'KedamaPlugin'> 172029 "^ KedamaPlugin doPrimitive: #primitiveDivScalar." 172030 172031 1 to: rcvr size do: [:i | 172032 result at: i put: (rcvr at: i) / other. 172033 ]. 172034 ^ result. 172035! ! 172036 172037!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:39'! 172038primMulArray: rcvr and: other into: result 172039 172040 <primitive: 'primitiveMulArrays' module:'KedamaPlugin'> 172041 "^ KedamaPlugin doPrimitive: #primitiveMulArrays." 172042 172043 1 to: rcvr size do: [:i | 172044 result at: i put: (rcvr at: i) * (other at: i) 172045 ]. 172046 ^ result. 172047! ! 172048 172049!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:38'! 172050primMulScalar: rcvr and: other into: result 172051 172052 <primitive: 'primitiveMulScalar' module:'KedamaPlugin'> 172053 "^ KedamaPlugin doPrimitive: #primitiveMulScalar." 172054 172055 1 to: rcvr size do: [:i | 172056 result at: i put: (rcvr at: i) * other. 172057 ]. 172058 ^ result. 172059! ! 172060 172061!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:39'! 172062primSubArray: rcvr and: other into: result 172063 172064 <primitive: 'primitiveSubArrays' module:'KedamaPlugin'> 172065 "^ KedamaPlugin doPrimitive: #primitiveSubArrays." 172066 172067 1 to: rcvr size do: [:i | 172068 result at: i put: (rcvr at: i) - (other at: i) 172069 ]. 172070 ^ result. 172071! ! 172072 172073!KedamaFloatArray methodsFor: 'primitives' stamp: 'yo 10/25/2004 15:38'! 172074primSubScalar: rcvr and: other into: result 172075 172076 <primitive: 'primitiveSubScalar' module:'KedamaPlugin'> 172077 "^ KedamaPlugin doPrimitive: #primitiveSubScalar." 172078 172079 1 to: rcvr size do: [:i | 172080 result at: i put: (rcvr at: i) - other. 172081 ]. 172082 ^ result. 172083! ! 172084UserInputEvent subclass: #KeyboardEvent 172085 instanceVariableNames: 'keyValue charCode scanCode' 172086 classVariableNames: '' 172087 poolDictionaries: '' 172088 category: 'Morphic-Events'! 172089 172090!KeyboardEvent methodsFor: 'comparing' stamp: 'ar 10/24/2000 17:44'! 172091= aMorphicEvent 172092 super = aMorphicEvent ifFalse:[^false]. 172093 buttons = aMorphicEvent buttons ifFalse: [^ false]. 172094 keyValue = aMorphicEvent keyValue ifFalse: [^ false]. 172095 ^ true 172096! ! 172097 172098!KeyboardEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:50'! 172099hash 172100 ^buttons hash + keyValue hash 172101! ! 172102 172103 172104!KeyboardEvent methodsFor: 'dispatching' stamp: 'ar 9/15/2000 21:13'! 172105sentTo: anObject 172106 "Dispatch the receiver into anObject" 172107 type == #keystroke ifTrue:[^anObject handleKeystroke: self]. 172108 type == #keyDown ifTrue:[^anObject handleKeyDown: self]. 172109 type == #keyUp ifTrue:[^anObject handleKeyUp: self]. 172110 ^super sentTo: anObject.! ! 172111 172112 172113!KeyboardEvent methodsFor: 'initialize' stamp: 'michael.rueger 2/24/2009 14:08'! 172114scanCode: anInt 172115 scanCode := anInt! ! 172116 172117!KeyboardEvent methodsFor: 'initialize' stamp: 'ar 10/25/2000 22:08'! 172118type: eventType readFrom: aStream 172119 type := eventType. 172120 timeStamp := Integer readFrom: aStream. 172121 aStream skip: 1. 172122 buttons := Integer readFrom: aStream. 172123 aStream skip: 1. 172124 keyValue := Integer readFrom: aStream.! ! 172125 172126 172127!KeyboardEvent methodsFor: 'keyboard' stamp: 'michael.rueger 3/11/2009 11:21'! 172128keyCharacter 172129 "Answer the character corresponding this keystroke. This is defined only for keystroke events." 172130 172131 ^Unicode value: charCode! ! 172132 172133!KeyboardEvent methodsFor: 'keyboard' stamp: 'nk 10/13/2004 10:43'! 172134keyString 172135 "Answer the string value for this keystroke. This is defined only for keystroke events." 172136 172137 ^ String streamContents: [ :s | self printKeyStringOn: s ]! ! 172138 172139!KeyboardEvent methodsFor: 'keyboard' stamp: 'ar 9/13/2000 15:51'! 172140keyValue 172141 "Answer the ascii value for this keystroke. This is defined only for keystroke events." 172142 172143 ^ keyValue! ! 172144 172145!KeyboardEvent methodsFor: 'keyboard' stamp: 'michael.rueger 2/25/2009 22:19'! 172146scanCode 172147 ^scanCode! ! 172148 172149 172150!KeyboardEvent methodsFor: 'printing' stamp: 'tk 10/13/2004 15:19'! 172151printKeyStringOn: aStream 172152 "Print a readable string representing the receiver on a given stream" 172153 172154 | kc inBrackets firstBracket keyString | 172155 kc := self keyCharacter. 172156 inBrackets := false. 172157 firstBracket := [ inBrackets ifFalse: [ aStream nextPut: $<. inBrackets := true ]]. 172158 self controlKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Ctrl-' ]. 172159 self commandKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Cmd-' ]. 172160 (buttons anyMask: 32) ifTrue: [ firstBracket value. aStream nextPutAll: 'Opt-' ]. 172161 (self shiftPressed and: [ keyValue between: 1 and: 31 ]) 172162 ifTrue: [ firstBracket value. aStream nextPutAll: 'Shift-' ]. 172163 172164 (self controlKeyPressed and: [ keyValue <= 26 ]) 172165 ifTrue: 172166 [aStream nextPut: (keyValue + $a asciiValue - 1) asCharacter] 172167 ifFalse: 172168 [keyString := (kc caseOf: { 172169 [ Character space ] -> [ ' ' ]. 172170 [ Character tab ] -> [ 'tab' ]. 172171 [ Character cr ] -> [ 'cr' ]. 172172 [ Character lf ] -> [ 'lf' ]. 172173 [ Character enter ] -> [ 'enter' ]. 172174 172175 [ Character backspace ] -> [ 'backspace' ]. 172176 [ Character delete ] -> [ 'delete' ]. 172177 172178 [ Character escape ] -> [ 'escape' ]. 172179 172180 [ Character arrowDown ] -> [ 'down' ]. 172181 [ Character arrowUp ] -> [ 'up' ]. 172182 [ Character arrowLeft ] -> [ 'left' ]. 172183 [ Character arrowRight ] -> [ 'right' ]. 172184 172185 [ Character end ] -> [ 'end' ]. 172186 [ Character home ] -> [ 'home' ]. 172187 [ Character pageDown ] -> [ 'pageDown' ]. 172188 [ Character pageUp ] -> [ 'pageUp' ]. 172189 172190 [ Character euro ] -> [ 'euro' ]. 172191 [ Character insert ] -> [ 'insert' ]. 172192 172193 } otherwise: [ String with: kc ]). 172194 keyString size > 1 ifTrue: [ firstBracket value ]. 172195 aStream nextPutAll: keyString]. 172196 172197 inBrackets ifTrue: [aStream nextPut: $> ]! ! 172198 172199!KeyboardEvent methodsFor: 'printing' stamp: 'nk 10/13/2004 10:42'! 172200printOn: aStream 172201 "Print the receiver on a stream" 172202 172203 aStream nextPut: $[. 172204 aStream nextPutAll: type; nextPutAll: ' '''. 172205 self printKeyStringOn: aStream. 172206 aStream nextPut: $'. 172207 aStream nextPut: $]! ! 172208 172209!KeyboardEvent methodsFor: 'printing' stamp: 'ar 10/25/2000 22:07'! 172210storeOn: aStream 172211 172212 aStream nextPutAll: type. 172213 aStream space. 172214 self timeStamp storeOn: aStream. 172215 aStream space. 172216 buttons storeOn: aStream. 172217 aStream space. 172218 keyValue storeOn: aStream. 172219! ! 172220 172221 172222!KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'! 172223isKeyDown 172224 ^self type == #keyDown! ! 172225 172226!KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'! 172227isKeyUp 172228 ^self type == #keyUp! ! 172229 172230!KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'! 172231isKeyboard 172232 ^true! ! 172233 172234!KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'! 172235isKeystroke 172236 ^self type == #keystroke! ! 172237 172238!KeyboardEvent methodsFor: 'testing' stamp: 'ar 10/9/2000 00:43'! 172239isMouseMove 172240 ^false! ! 172241 172242 172243!KeyboardEvent methodsFor: 'private' stamp: 'michael.rueger 2/23/2009 11:49'! 172244setType: aSymbol buttons: anInteger position: pos keyValue: aValue charCode: anInt hand: aHand stamp: stamp 172245 type := aSymbol. 172246 buttons := anInteger. 172247 position := pos. 172248 keyValue := aValue. 172249 charCode := anInt. 172250 source := aHand. 172251 wasHandled := false. 172252 timeStamp := stamp.! ! 172253 172254!KeyboardEvent methodsFor: 'private' stamp: 'ar 10/5/2000 23:54'! 172255setType: aSymbol buttons: anInteger position: pos keyValue: aValue hand: aHand stamp: stamp 172256 type := aSymbol. 172257 buttons := anInteger. 172258 position := pos. 172259 keyValue := aValue. 172260 source := aHand. 172261 wasHandled := false. 172262 timeStamp := stamp.! ! 172263KeyedSet subclass: #KeyedIdentitySet 172264 instanceVariableNames: '' 172265 classVariableNames: '' 172266 poolDictionaries: '' 172267 category: 'Collections-Unordered'! 172268 172269!KeyedIdentitySet methodsFor: 'private' stamp: 'md 10/5/2005 15:43'! 172270scanFor: anObject 172271 "Same as super except change = to ==, and hash to identityHash" 172272 172273 | element start finish | 172274 finish := array size. 172275 start := (anObject identityHash \\ finish) + 1. 172276 172277 172278 "Search from (hash mod size) to the end." 172279 start to: finish do: 172280 [:index | ((element := array at: index) == nil or: [(keyBlock value: element) == anObject]) 172281 ifTrue: [^ index ]]. 172282 172283 "Search from 1 to where we started." 172284 1 to: start-1 do: 172285 [:index | ((element := array at: index) == nil or: [(keyBlock value: element) == anObject]) 172286 ifTrue: [^ index ]]. 172287 172288 ^ 0 "No match AND no empty slot"! ! 172289Set subclass: #KeyedSet 172290 instanceVariableNames: 'keyBlock' 172291 classVariableNames: '' 172292 poolDictionaries: '' 172293 category: 'Collections-Unordered'! 172294!KeyedSet commentStamp: '<historical>' prior: 0! 172295Like Set except a key of every element is used for hashing and searching instead of the element itself. keyBlock gets the key of an element.! 172296 172297 172298!KeyedSet methodsFor: 'accessing' stamp: 'ajh 9/5/2000 03:57'! 172299at: key 172300 "Answer the value associated with the key." 172301 172302 ^ self at: key ifAbsent: [self errorKeyNotFound]! ! 172303 172304!KeyedSet methodsFor: 'accessing' stamp: 'ajh 10/6/2000 20:28'! 172305at: key ifAbsent: aBlock 172306 "Answer the value associated with the key or, if key isn't found, 172307 answer the result of evaluating aBlock." 172308 172309 | obj | 172310 obj := array at: (self findElementOrNil: key). 172311 obj ifNil: [^ aBlock value]. 172312 ^ obj! ! 172313 172314!KeyedSet methodsFor: 'accessing' stamp: 'ajh 12/10/2000 15:42'! 172315at: key ifAbsentPut: aBlock 172316 "Answer the value associated with the key or, if key isn't found, 172317 add the result of evaluating aBlock to self" 172318 172319 ^ self at: key ifAbsent: [self add: aBlock value]! ! 172320 172321!KeyedSet methodsFor: 'accessing' stamp: 'ajh 9/5/2000 03:58'! 172322at: key ifPresent: aBlock 172323 "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil." 172324 172325 | v | 172326 v := self at: key ifAbsent: [^ nil]. 172327 ^ aBlock value: v 172328 ! ! 172329 172330!KeyedSet methodsFor: 'accessing' stamp: 'ajh 7/3/2004 17:55'! 172331keys 172332 172333 | keys | 172334 keys := Set new. 172335 self keysDo: [:key | keys add: key]. 172336 ^ keys! ! 172337 172338!KeyedSet methodsFor: 'accessing' stamp: 'ajh 7/3/2004 17:54'! 172339keysDo: block 172340 172341 self do: [:item | block value: (keyBlock value: item)]! ! 172342 172343!KeyedSet methodsFor: 'accessing' stamp: 'ajh 5/11/2002 13:28'! 172344keysSorted 172345 172346 | keys | 172347 keys := SortedCollection new. 172348 self do: [:item | keys add: (keyBlock value: item)]. 172349 ^ keys! ! 172350 172351 172352!KeyedSet methodsFor: 'adding' stamp: 'md 3/14/2006 12:37'! 172353add: newObject 172354 "Include newObject as one of the receiver's elements, but only if 172355 not already present. Answer newObject." 172356 172357 | index | 172358 newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element']. 172359 index := self findElementOrNil: (keyBlock value: newObject). 172360 (array at: index) ifNil: [self atNewIndex: index put: newObject]. 172361 ^ newObject! ! 172362 172363!KeyedSet methodsFor: 'adding' stamp: 'ajh 12/4/2001 05:27'! 172364addAll: aCollection 172365 "Include all the elements of aCollection as the receiver's elements" 172366 172367 (aCollection respondsTo: #associationsDo:) 172368 ifTrue: [aCollection associationsDo: [:ass | self add: ass]] 172369 ifFalse: [aCollection do: [:each | self add: each]]. 172370 ^ aCollection! ! 172371 172372!KeyedSet methodsFor: 'adding' stamp: 'ajh 6/3/2002 10:11'! 172373member: newObject 172374 "Include newObject as one of the receiver's elements, if already exists just return it" 172375 172376 | index | 172377 newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element']. 172378 index := self findElementOrNil: (keyBlock value: newObject). 172379 (array at: index) ifNotNil: [^ array at: index]. 172380 self atNewIndex: index put: newObject. 172381 ^ newObject! ! 172382 172383 172384!KeyedSet methodsFor: 'copying' stamp: 'nice 6/16/2009 20:56'! 172385copyEmpty 172386 ^super copyEmpty 172387 keyBlock: keyBlock copy! ! 172388 172389 172390!KeyedSet methodsFor: 'initialize' stamp: 'ajh 9/5/2000 03:36'! 172391keyBlock: oneArgBlock 172392 "When evaluated return the key of the argument which will be an element of the set" 172393 172394 keyBlock := oneArgBlock! ! 172395 172396 172397!KeyedSet methodsFor: 'removing' stamp: 'ajh 9/5/2000 03:47'! 172398remove: oldObject ifAbsent: aBlock 172399 172400 | index | 172401 index := self findElementOrNil: (keyBlock value: oldObject). 172402 (array at: index) == nil ifTrue: [ ^ aBlock value ]. 172403 array at: index put: nil. 172404 tally := tally - 1. 172405 self fixCollisionsFrom: index. 172406 ^ oldObject! ! 172407 172408!KeyedSet methodsFor: 'removing' stamp: 'nice 12/30/2008 19:01'! 172409removeAll 172410 "See super." 172411 172412 | tmp | 172413 tmp := keyBlock. 172414 super removeAll. 172415 keyBlock := tmp! ! 172416 172417!KeyedSet methodsFor: 'removing' stamp: 'ajh 3/29/2001 19:03'! 172418removeKey: key 172419 172420 ^ self removeKey: key ifAbsent: [self errorKeyNotFound]! ! 172421 172422!KeyedSet methodsFor: 'removing' stamp: 'ajh 3/29/2001 19:03'! 172423removeKey: key ifAbsent: aBlock 172424 172425 | index obj | 172426 index := self findElementOrNil: key. 172427 (obj := array at: index) == nil ifTrue: [ ^ aBlock value ]. 172428 array at: index put: nil. 172429 tally := tally - 1. 172430 self fixCollisionsFrom: index. 172431 ^ obj! ! 172432 172433 172434!KeyedSet methodsFor: 'testing' stamp: 'ajh 9/5/2000 03:45'! 172435includes: anObject 172436 ^ (array at: (self findElementOrNil: (keyBlock value: anObject))) ~~ nil! ! 172437 172438!KeyedSet methodsFor: 'testing' stamp: 'ajh 3/29/2001 23:56'! 172439includesKey: key 172440 172441 ^ (array at: (self findElementOrNil: key)) ~~ nil! ! 172442 172443 172444!KeyedSet methodsFor: 'private' stamp: 'ajh 3/29/2001 19:04'! 172445errorKeyNotFound 172446 172447 self error: 'key not found'! ! 172448 172449!KeyedSet methodsFor: 'private' stamp: 'ajh 9/5/2000 03:44'! 172450fixCollisionsFrom: index 172451 "The element at index has been removed and replaced by nil. 172452 This method moves forward from there, relocating any entries 172453 that had been placed below due to collisions with this one" 172454 | length oldIndex newIndex element | 172455 oldIndex := index. 172456 length := array size. 172457 [oldIndex = length 172458 ifTrue: [oldIndex := 1] 172459 ifFalse: [oldIndex := oldIndex + 1]. 172460 (element := self keyAt: oldIndex) == nil] 172461 whileFalse: 172462 [newIndex := self findElementOrNil: (keyBlock value: element). 172463 oldIndex = newIndex ifFalse: [self swap: oldIndex with: newIndex]]! ! 172464 172465!KeyedSet methodsFor: 'private' stamp: 'nice 4/4/2006 22:09'! 172466initialize: n 172467 super initialize: n. 172468 keyBlock := [:element | element key]. 172469 ! ! 172470 172471!KeyedSet methodsFor: 'private' stamp: 'ajh 9/5/2000 03:46'! 172472noCheckAdd: anObject 172473 array at: (self findElementOrNil: (keyBlock value: anObject)) put: anObject. 172474 tally := tally + 1! ! 172475 172476!KeyedSet methodsFor: 'private' stamp: 'ajh 12/13/2001 00:17'! 172477rehash 172478 | newSelf | 172479 newSelf := self species new: self size. 172480 newSelf keyBlock: keyBlock. 172481 self do: [:each | newSelf noCheckAdd: each]. 172482 array := newSelf array! ! 172483 172484!KeyedSet methodsFor: 'private' stamp: 'md 10/5/2005 15:43'! 172485scanFor: anObject 172486 "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 172487 | element start finish | 172488 finish := array size. 172489 start := (anObject hash \\ finish) + 1. 172490 172491 "Search from (hash mod size) to the end." 172492 start to: finish do: 172493 [:index | ((element := array at: index) == nil or: [(keyBlock value: element) = anObject]) 172494 ifTrue: [^ index ]]. 172495 172496 "Search from 1 to where we started." 172497 1 to: start-1 do: 172498 [:index | ((element := array at: index) == nil or: [(keyBlock value: element) = anObject]) 172499 ifTrue: [^ index ]]. 172500 172501 ^ 0 "No match AND no empty slot"! ! 172502 172503"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 172504 172505KeyedSet class 172506 instanceVariableNames: ''! 172507 172508!KeyedSet class methodsFor: 'instance creation' stamp: 'ajh 10/23/2000 23:16'! 172509keyBlock: oneArgBlock 172510 "Create a new KeySet whose way to access an element's key is by executing oneArgBlock on the element" 172511 172512 ^ self new keyBlock: oneArgBlock! ! 172513ClassTestCase subclass: #KeyedSetTest 172514 instanceVariableNames: '' 172515 classVariableNames: '' 172516 poolDictionaries: '' 172517 category: 'CollectionsTests-Unordered'! 172518!KeyedSetTest commentStamp: 'nice 5/22/2008 14:12' prior: 0! 172519KeyedSetTest hold sunit tests for class KeyedSet! 172520 172521 172522!KeyedSetTest methodsFor: 'tests' stamp: 'nice 5/22/2008 14:18'! 172523testSelect 172524 "this is a non regression test for http://bugs.squeak.org/view.php?id=6535" 172525 172526 | ks ks2 | 172527 172528 "Creare a KeyedSet" 172529 ks := KeyedSet keyBlock: [:e | e asInteger \\ 4]. 172530 ks addAll: #(1.2 1.5 3.8 7.7 9.1 12.4 13.25 14.0 19.2 11.4). 172531 172532 "There is non more than 4 possible keys (0 1 2 3)" 172533 self assert: ks size <= 4. 172534 172535 "Select some elements" 172536 ks2 := ks select: [:e | e fractionPart > 0.5]. 172537 172538 "If keyBlock was preserved, then still no more than 4 keys..." 172539 ks2 addAll: #(1.2 1.5 3.8 7.7 9.1 12.4 13.25 14.0 19.2 11.4). 172540 self assert: ks size <= 4.! ! 172541Dictionary subclass: #KeyedTree 172542 instanceVariableNames: '' 172543 classVariableNames: '' 172544 poolDictionaries: '' 172545 category: 'Polymorph-Widgets'! 172546!KeyedTree commentStamp: '<historical>' prior: 0! 172547Provides path based access to elements contained in the receiver and any subtrees. 172548 172549Example: 172550 172551(KeyedTree new 172552 at: 1 put: 'One'; 172553 at: 2 put: 'Two'; 172554 at: 'Tree' put: (KeyedTree new 172555 at: $a put: 'Tree-A'; 172556 at: $b put: 'Tree-B'; 172557 yourself); 172558 yourself) atPath: #('Tree' $b)! 172559 172560 172561!KeyedTree methodsFor: 'accessing' stamp: 'gvc 12/15/2005 13:57'! 172562allKeys 172563 "Answer an ordered collection of the keys of the receiver and any subtrees. 172564 Please no circular references!!" 172565 172566 |answer| 172567 answer := OrderedCollection new. 172568 answer addAll: self keys. 172569 self subtrees do: [:t | 172570 answer addAll: t allKeys]. 172571 ^answer! ! 172572 172573!KeyedTree methodsFor: 'accessing' stamp: 'gvc 10/20/2005 18:42'! 172574atPath: anArray 172575 "Answer the element referenced by the give key path. 172576 Signal an error if not found." 172577 172578 ^self atPath: anArray ifAbsent: [self errorKeyNotFound]! ! 172579 172580!KeyedTree methodsFor: 'accessing' stamp: 'gvc 2/1/2006 11:01'! 172581atPath: anArray ifAbsent: aBlock 172582 "Answer the element referenced by the given key path. 172583 Answer the value of aBlock if not found." 172584 172585 |element| 172586 element := self. 172587 anArray do: [:key | 172588 element := element at: key ifAbsent: [^aBlock value]]. 172589 ^element! ! 172590 172591!KeyedTree methodsFor: 'accessing' stamp: 'gvc 2/1/2006 11:01'! 172592atPath: anArray ifAbsentPut: aBlock 172593 "Answer the element referenced by the given key path. 172594 Answer the value of aBlock if not found after creating its path." 172595 172596 |element| 172597 anArray isEmpty 172598 ifTrue: [^self]. 172599 element := self. 172600 anArray allButLastDo: [:key | 172601 element := element at: key ifAbsentPut: [self species new]]. 172602 ^element at: anArray last ifAbsentPut: aBlock! ! 172603 172604!KeyedTree methodsFor: 'accessing' stamp: 'gvc 2/1/2006 11:00'! 172605atPath: anArray put: aBlock 172606 "Answer the value of aBlock after creating its path." 172607 172608 |element| 172609 anArray isEmpty 172610 ifTrue: [^self]. 172611 element := self. 172612 anArray allButLastDo: [:key | 172613 element := element at: key ifAbsentPut: [self species new]]. 172614 ^element at: anArray last put: aBlock! ! 172615 172616!KeyedTree methodsFor: 'accessing' stamp: 'gvc 1/17/2008 15:37'! 172617sortBlock 172618 "Answer the block to sort tree keys with." 172619 172620 ^[:a :b | [a <= b] on: Error do: [a class name <= b class name]]! ! 172621 172622!KeyedTree methodsFor: 'accessing' stamp: 'gvc 12/15/2005 13:54'! 172623subtrees 172624 "Answer the subtrees of the receiver." 172625 172626 ^(self select: [:v | v isKindOf: KeyedTree]) values! ! 172627 172628 172629!KeyedTree methodsFor: 'adding' stamp: 'gvc 10/20/2005 19:11'! 172630merge: aKeyedTree 172631 "Merge the given tree into the receiver, overwriting or extending elements as needed." 172632 172633 |subtree| 172634 aKeyedTree keysAndValuesDo: [:k :v | 172635 (v isKindOf: KeyedTree) 172636 ifTrue: [subtree := self at: k ifAbsentPut: [v species new]. 172637 (subtree isKindOf: KeyedTree) not 172638 ifTrue: [subtree := self at: k put: v species new]. 172639 subtree merge: v] 172640 ifFalse: [self at: k put: v]]! ! 172641 172642 172643!KeyedTree methodsFor: 'copying' stamp: 'gvc 10/20/2005 18:38'! 172644copy 172645 "Must copy the associations, or later store will affect both the 172646 original and the copy. 172647 Copy any subtrees too!!" 172648 172649 ^ self shallowCopy withArray: 172650 (array collect: [:assoc | 172651 assoc ifNil: [nil] 172652 ifNotNil: [Association 172653 key: assoc key 172654 value: ((assoc value isKindOf: KeyedTree) 172655 ifTrue: [assoc value copy] 172656 ifFalse: [assoc value])]])! ! 172657 172658 172659!KeyedTree methodsFor: 'printing' stamp: 'gvc 1/17/2008 16:06'! 172660formattedText 172661 "Answer a string or text representing the receiver with indentation and, possibly, markup." 172662 172663 |str| 172664 str := String new writeStream. 172665 self putFormattedTextOn: str level: 0 indentString: ' '. 172666 ^str contents! ! 172667 172668!KeyedTree methodsFor: 'printing' stamp: 'gvc 1/17/2008 16:23'! 172669formattedTextWithDescriptions: aKeyedTree 172670 "Answer a string or text representing the receiver with indentation and, possibly, markup. 172671 Descriptions of each item are taken from the given tree with 172672 the same key structure as the receiver." 172673 172674 |str| 172675 str := String new writeStream. 172676 self putFormattedTextOn: str withDescriptions: aKeyedTree level: 0 indentString: ' '. 172677 ^str contents! ! 172678 172679!KeyedTree methodsFor: 'printing' stamp: 'gvc 1/17/2008 16:06'! 172680putFormattedTextOn: aStream level: indentLevel indentString: aString 172681 "Place a description of the receiver on the given stream with the given indentation level." 172682 172683 |v| 172684 (self keys asSortedCollection: self sortBlock) do: [:k | 172685 indentLevel timesRepeat: [aStream nextPutAll: aString]. 172686 aStream nextPutAll: k printString. 172687 v := self at: k. 172688 (v isKindOf: self class) 172689 ifTrue: [aStream cr. 172690 v putFormattedTextOn: aStream level: indentLevel + 1 indentString: aString] 172691 ifFalse: [aStream 172692 nextPutAll: ' : '; 172693 nextPutAll: v printString. 172694 aStream cr]]! ! 172695 172696!KeyedTree methodsFor: 'printing' stamp: 'gvc 1/18/2008 16:44'! 172697putFormattedTextOn: aStream withDescriptions: aKeyedTree level: indentLevel indentString: aString 172698 "Place a print of the receiver and associated description on the given stream with the given indentation level." 172699 172700 |v| 172701 (self keys asSortedCollection: self sortBlock) do: [:k | 172702 indentLevel timesRepeat: [aStream nextPutAll: aString]. 172703 aStream nextPutAll: k printString. 172704 v := self at: k. 172705 (v isKindOf: self class) 172706 ifTrue: [aStream cr. 172707 v 172708 putFormattedTextOn: aStream 172709 withDescriptions: (aKeyedTree at: k ifAbsent: [self class new]) 172710 level: indentLevel + 1 172711 indentString: aString] 172712 ifFalse: [aStream 172713 nextPutAll: ' : '; 172714 nextPutAll: v printString; 172715 tab; tab; 172716 nextPutAll: (aKeyedTree at: k ifAbsent: ['nondescript']) printString. 172717 aStream cr]]! ! 172718 172719 172720!KeyedTree methodsFor: 'removing' stamp: 'gvc 10/20/2005 18:54'! 172721removePath: anArray 172722 "Remove and answer the element referenced by the given path. 172723 Signal an error if not found." 172724 172725 ^self removePath: anArray ifAbsent: [self errorKeyNotFound]! ! 172726 172727!KeyedTree methodsFor: 'removing' stamp: 'gvc 10/20/2005 18:53'! 172728removePath: anArray ifAbsent: aBlock 172729 "Remove and answer the element referenced by the given path. 172730 Answer the value of aBlock if not found." 172731 172732 |element| 172733 anArray isEmpty 172734 ifTrue: [^self]. 172735 element := self. 172736 anArray allButLastDo: [:key | 172737 element := element at: key ifAbsent: [^aBlock value]]. 172738 ^element removeKey: anArray last ifAbsent: aBlock ! ! 172739LanguageEnvironment subclass: #KoreanEnvironment 172740 instanceVariableNames: '' 172741 classVariableNames: '' 172742 poolDictionaries: '' 172743 category: 'Multilingual-Languages'! 172744!KoreanEnvironment commentStamp: '<historical>' prior: 0! 172745This class provides the Korean support. Unfortunately, we haven't tested this yet. We did have a working version in previous implementations, but not this new implementation. But as soon as we find somebody who understand the language, probably we can make it work in two days or so, as we have done for Czech support.! 172746 172747 172748!KoreanEnvironment methodsFor: 'as yet unclassified' stamp: 'janggoon 11/6/2008 23:57'! 172749fontDownloadUrls 172750 ^ #('http://squeak.kr/data/' )! ! 172751 172752"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 172753 172754KoreanEnvironment class 172755 instanceVariableNames: ''! 172756 172757!KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'janggoon 11/4/2008 22:09'! 172758defaultEncodingName 172759 | platformName osVersion | 172760 platformName := SmalltalkImage current platformName. 172761 osVersion := SmalltalkImage current getSystemAttribute: 1002. 172762 (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8' copy]. 172763 (#('Win32' 'ZaurusOS') includes: platformName) 172764 ifTrue: [^'euc-kr' copy]. 172765 platformName = 'Mac OS' 172766 ifTrue: [^ ('10*' match: SmalltalkImage current osVersion) 172767 ifTrue: ['utf-8'] 172768 ifFalse: ['euc-kr']]. 172769 (#('unix') includes: platformName) ifTrue: [^'euc-kr' copy]. 172770 ^'mac-roman'! ! 172771 172772!KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'janggoon 11/4/2008 22:11'! 172773leadingChar 172774 172775 ^ 7! ! 172776 172777!KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'janggoon 11/4/2008 22:12'! 172778systemConverterClass 172779 | platformName osVersion encoding | 172780 platformName := SmalltalkImage current platformName. 172781 osVersion := SmalltalkImage current getSystemAttribute: 1002. 172782 (platformName = 'Win32' and: [osVersion = 'CE']) 172783 ifTrue: [^UTF8TextConverter]. 172784 (#('Win32' 'ZaurusOS') includes: platformName) 172785 ifTrue: [^EUCKRTextConverter]. 172786 platformName = 'Mac OS' 172787 ifTrue: 172788 [^('10*' match: SmalltalkImage current osVersion) 172789 ifTrue: [UTF8TextConverter] 172790 ifFalse: [EUCKRTextConverter]]. 172791 platformName = 'unix' 172792 ifTrue: 172793 [encoding := X11Encoding encoding. 172794 encoding ifNil: [^EUCKRTextConverter]. 172795 (encoding = 'utf-8') 172796 ifTrue: [^UTF8TextConverter]. 172797 ^EUCKRTextConverter]. 172798 ^MacRomanTextConverter! ! 172799 172800!KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 3/16/2004 14:50'! 172801traditionalCharsetClass 172802 172803 ^ KSX1001. 172804! ! 172805 172806 172807!KoreanEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 18:42'! 172808supportedLanguages 172809 "Return the languages that this class supports. 172810 Any translations for those languages will use this class as their environment." 172811 ^#('ko' )! ! 172812Object subclass: #LRUCache 172813 instanceVariableNames: 'size factory calls hits values' 172814 classVariableNames: '' 172815 poolDictionaries: '' 172816 category: 'System-Support'! 172817!LRUCache commentStamp: '<historical>' prior: 0! 172818I'm a cache of values, given a key I return a Value from the cache or from the factory! 172819 172820 172821!LRUCache methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/29/2007 12:58'! 172822at: aKey 172823 "answer the object for aKey, if not present in the cache creates it. 172824 Clone the factory block before calling in case of multiple processes!!" 172825 172826 | element keyHash | 172827 calls := calls + 1. 172828 keyHash := aKey hash. 172829 1 172830 to: size 172831 do: [:index | 172832 element := values at: index. 172833 (keyHash 172834 = (element at: 2) 172835 and: [aKey 172836 = (element at: 1)]) 172837 ifTrue: ["Found!!" 172838 hits := hits + 1. 172839 values 172840 replaceFrom: 2 172841 to: index 172842 with: (values first: index - 1). 172843 values at: 1 put: element. 172844 ^ element at: 3]]. 172845 "Not found!!" 172846 element := {aKey. keyHash. factory clone value: aKey}. 172847 values 172848 replaceFrom: 2 172849 to: size 172850 with: values allButLast. 172851 values at: 1 put: element. 172852 ^ element at: 3! ! 172853 172854 172855!LRUCache methodsFor: 'initialization' stamp: 'dgd 3/28/2003 19:42'! 172856initializeSize: aNumber factory: aBlock 172857 "initialize the receiver's size and factory" 172858 size := aNumber. 172859 values := Array new: aNumber withAll: {nil. nil. nil}. 172860 factory := aBlock. 172861 calls := 0. 172862 hits := 0! ! 172863 172864 172865!LRUCache methodsFor: 'printing' stamp: 'dgd 3/28/2003 19:41'! 172866printOn: aStream 172867 "Append to the argument, aStream, a sequence of characters 172868 that identifies the receiver." 172869 aStream nextPutAll: self class name; 172870 nextPutAll: ' size:'; 172871 nextPutAll: size asString; 172872 nextPutAll: ', calls:'; 172873 nextPutAll: calls asString; 172874 nextPutAll: ', hits:'; 172875 nextPutAll: hits asString; 172876 nextPutAll: ', ratio:'; 172877nextPutAll: 172878 (hits / calls) asFloat asString! ! 172879 172880"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 172881 172882LRUCache class 172883 instanceVariableNames: ''! 172884 172885!LRUCache class methodsFor: 'instance creation' stamp: 'dgd 3/26/2003 22:29'! 172886size: aNumber factory: aBlock 172887 "answer an instance of the receiver" 172888 ^ self new initializeSize: aNumber factory: aBlock! ! 172889 172890 172891!LRUCache class methodsFor: 'testing' stamp: 'dgd 3/26/2003 22:22'! 172892test 172893 " 172894 LRUCache test 172895 " 172896 | c | 172897 c := LRUCache 172898 size: 5 172899 factory: [:key | key * 2]. 172900 c at: 1. 172901 c at: 2. 172902 c at: 3. 172903 c at: 4. 172904 c at: 1. 172905 c at: 5. 172906 c at: 6. 172907 c at: 7. 172908 c at: 8. 172909 c at: 1. 172910 ^ c! ! 172911 172912!LRUCache class methodsFor: 'testing' stamp: 'dgd 3/26/2003 22:22'! 172913test2 172914 " 172915 LRUCache test2. 172916 Time millisecondsToRun:[LRUCache test2]. 172917 MessageTally spyOn:[LRUCache test2]. 172918 " 172919 | c | 172920 c := LRUCache 172921 size: 600 172922 factory: [:key | key * 2]. 172923 1 172924 to: 6000 172925 do: [:each | c at: each]. 172926 ^ c! ! 172927StringMorph subclass: #LabelMorph 172928 instanceVariableNames: 'getEnabledSelector enabled model disabledStyle' 172929 classVariableNames: '' 172930 poolDictionaries: '' 172931 category: 'Polymorph-Widgets'! 172932!LabelMorph commentStamp: 'gvc 5/18/2007 12:48' prior: 0! 172933String morph with enablement support. When disabled the text will appear inset.! 172934 172935 172936!LabelMorph methodsFor: 'accessing' stamp: 'gvc 8/2/2007 16:43'! 172937disabledStyle 172938 "Answer the value of disabledStyle" 172939 172940 ^ disabledStyle! ! 172941 172942!LabelMorph methodsFor: 'accessing' stamp: 'gvc 8/2/2007 16:53'! 172943disabledStyle: anObject 172944 "Set the value of disabledStyle" 172945 172946 disabledStyle := anObject. 172947 self 172948 changed: #disabledStyle; 172949 changed! ! 172950 172951!LabelMorph methodsFor: 'accessing' stamp: 'gvc 1/16/2007 15:28'! 172952enabled 172953 "Answer the value of enabled" 172954 172955 ^enabled! ! 172956 172957!LabelMorph methodsFor: 'accessing' stamp: 'gvc 1/16/2007 15:55'! 172958enabled: aBoolean 172959 "Set the value of enabled" 172960 172961 enabled := aBoolean. 172962 self 172963 changed: #enabled; 172964 changed! ! 172965 172966!LabelMorph methodsFor: 'accessing' stamp: 'gvc 1/16/2007 15:52'! 172967model 172968 "Answer the value of model" 172969 172970 ^model! ! 172971 172972!LabelMorph methodsFor: 'accessing' stamp: 'gvc 1/16/2007 15:54'! 172973model: anObject 172974 "Set my model and make me me a dependent of the given object." 172975 172976 model ifNotNil: [model removeDependent: self]. 172977 anObject ifNotNil: [anObject addDependent: self]. 172978 model := anObject! ! 172979 172980 172981!LabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 16:35'! 172982disable 172983 "Disable the receiver." 172984 172985 self enabled: false! ! 172986 172987!LabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/2/2009 13:59'! 172988drawOn: aCanvas 172989 "Draw based on enablement." 172990 172991 |pc| 172992 pc := self owner 172993 ifNil: [self paneColor] 172994 ifNotNil: [self owner color isTransparent 172995 ifTrue: [self owner paneColor] 172996 ifFalse: [self owner color]]. 172997 self enabled 172998 ifTrue: [aCanvas 172999 drawString: self contents 173000 in: self bounds 173001 font: self fontToUse 173002 color: self color] 173003 ifFalse: [self disabledStyle == #inset ifTrue: [ 173004 aCanvas 173005 drawString: self contents 173006 in: (self bounds translateBy: 1) 173007 font: self fontToUse 173008 color: pc lighter; 173009 drawString: self contents 173010 in: self bounds 173011 font: self fontToUse 173012 color: pc muchDarker]. 173013 self disabledStyle == #plain ifTrue: [ 173014 aCanvas 173015 drawString: self contents 173016 in: self bounds 173017 font: self fontToUse 173018 color: pc muchDarker]]! ! 173019 173020!LabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 16:35'! 173021enable 173022 "Enable the receiver." 173023 173024 self enabled: true! ! 173025 173026!LabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 15:28'! 173027getEnabledSelector 173028 "Answer the value of getEnabledSelector" 173029 173030 ^ getEnabledSelector! ! 173031 173032!LabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 15:27'! 173033getEnabledSelector: anObject 173034 "Set the value of getEnabledSelector" 173035 173036 getEnabledSelector := anObject. 173037 self updateEnabled! ! 173038 173039!LabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 16:51'! 173040initWithContents: aString font: aFont emphasis: emphasisCode 173041 "Grrr, why do they do basicNew?" 173042 173043 super initWithContents: aString font: aFont emphasis: emphasisCode. 173044 self 173045 disabledStyle: #plain; 173046 enabled: true! ! 173047 173048!LabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 16:44'! 173049initialize 173050 "Initialize the receiver." 173051 173052 super initialize. 173053 self 173054 disabledStyle: #plain; 173055 enabled: true! ! 173056 173057!LabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 15:27'! 173058update: aSymbol 173059 "Refer to the comment in View|update:." 173060 173061 aSymbol == self getEnabledSelector ifTrue: 173062 [self updateEnabled. 173063 ^ self]! ! 173064 173065!LabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:25'! 173066updateEnabled 173067 "Update the enablement state." 173068 173069 self model ifNotNil: [ 173070 self getEnabledSelector ifNotNil: [ 173071 self enabled: (self model perform: self getEnabledSelector)]]! ! 173072 173073 173074!LabelMorph methodsFor: 'layout' stamp: 'gvc 6/15/2007 13:17'! 173075minHeight 173076 "Answer the receiver's minimum height. 173077 based on font height." 173078 173079 ^self fontToUse height rounded max: super minHeight! ! 173080 173081!LabelMorph methodsFor: 'layout' stamp: 'gvc 10/26/2007 21:15'! 173082minWidth 173083 "Answer the minmum width of the receiver. 173084 Based on font and contents." 173085 173086 ^self valueOfProperty: #minWidth ifAbsent: [self measureContents x] "allow override"! ! 173087StringMorph subclass: #LabelStringMorph 173088 instanceVariableNames: 'mySystemWindow' 173089 classVariableNames: '' 173090 poolDictionaries: '' 173091 category: 'Morphic-Windows'! 173092!LabelStringMorph commentStamp: '<historical>' prior: 0! 173093I am the stringMorph label for a system window. When a user tries to edit me (shift-click's me) I call >>relabel in my SystemWindow. In this way the SystemWindow is informed of the change.! 173094 173095 173096!LabelStringMorph methodsFor: 'accessing' stamp: 'fc 12/15/2004 15:27'! 173097mySystemWindow 173098 mySystemWindow! ! 173099 173100!LabelStringMorph methodsFor: 'accessing' stamp: 'fc 12/15/2004 15:27'! 173101mySystemWindow: aSystemWindow 173102 mySystemWindow := aSystemWindow.! ! 173103 173104 173105!LabelStringMorph methodsFor: 'event handling' stamp: 'fc 12/15/2004 15:28'! 173106mouseDown: evt 173107 173108 (evt shiftPressed) ifTrue: 173109 [mySystemWindow relabel]! ! 173110SystemWindow subclass: #LanguageEditor 173111 instanceVariableNames: 'translator selectedTranslation selectedTranslations selectedUntranslated translationsList untranslatedList translationText translationsFilter untranslatedFilter newerKeys' 173112 classVariableNames: 'CheckMethods' 173113 poolDictionaries: '' 173114 category: 'Multilingual-Editor'! 173115!LanguageEditor commentStamp: 'dgd 11/16/2003 15:02' prior: 0! 173116Editor for Babel's languages. 173117 173118Open it from 173119 173120 World Menu >> open... >> Language Editor (to open on default language) 173121 World Menu >> open... >> Language Editor for... (to choose the language) 173122 173123Or click: 173124 173125 LanguageEditor openOnDefault. 173126 LanguageEditor open. 173127 173128See http://swiki.agro.uba.ar/small_land/191 for documentation 173129! 173130 173131 173132!LanguageEditor methodsFor: 'accessing' stamp: 'dgd 8/24/2003 19:13'! 173133selectedTranslation 173134 "answer the selectedTranslation" 173135 ^ selectedTranslation! ! 173136 173137!LanguageEditor methodsFor: 'accessing' stamp: 'dgd 8/24/2003 21:56'! 173138selectedTranslation: anInteger 173139 "change the receiver's selectedTranslation" 173140 selectedTranslation := anInteger. 173141 "" 173142 self changed: #selectedTranslation. 173143 self changed: #translation! ! 173144 173145!LanguageEditor methodsFor: 'accessing' stamp: 'tak 11/28/2004 14:12'! 173146selectedTranslationsAt: index 173147 ^ selectedTranslations includes: index! ! 173148 173149!LanguageEditor methodsFor: 'accessing' stamp: 'tak 11/28/2004 14:15'! 173150selectedTranslationsAt: index put: value 173151 value = true 173152 ifTrue: [selectedTranslations add: index] 173153 ifFalse: [selectedTranslations 173154 remove: index 173155 ifAbsent: []]! ! 173156 173157!LanguageEditor methodsFor: 'accessing' stamp: 'dgd 8/24/2003 21:57'! 173158selectedUntranslated 173159 "answer the selectedUntranslated" 173160 ^ selectedUntranslated! ! 173161 173162!LanguageEditor methodsFor: 'accessing' stamp: 'dgd 8/24/2003 21:57'! 173163selectedUntranslated: anInteger 173164 "change the selectedUntranslated" 173165 selectedUntranslated := anInteger. 173166 "" 173167 self changed: #selectedUntranslated! ! 173168 173169!LanguageEditor methodsFor: 'accessing' stamp: 'mir 8/11/2004 10:00'! 173170translation 173171 "answer the translation for the selected phrase" 173172 self selectedTranslation isZero 173173 ifTrue: [^ '<select a phrase from the upper list>' translated]. 173174 "" 173175 ^ self translator 173176 translationFor: (self translations at: self selectedTranslation)! ! 173177 173178!LanguageEditor methodsFor: 'accessing' stamp: 'sd 2/4/2008 21:21'! 173179translation: aStringOrText 173180 "change the translation for the selected phrase" 173181 | phrase | 173182 self selectedTranslation isZero 173183 ifTrue: [^ self]. 173184 phrase := self translations at: self selectedTranslation. 173185 translator 173186 phrase: phrase 173187 translation: aStringOrText asString. 173188 newerKeys add: phrase. 173189 ^ true! ! 173190 173191!LanguageEditor methodsFor: 'accessing' stamp: 'mir 8/11/2004 10:00'! 173192translations 173193 "answet the translator's translations" 173194 | allTranslations filterString | 173195 allTranslations := self translator translations keys. 173196 "" 173197 filterString := self translationsFilter. 173198 "" 173199 filterString isEmpty 173200 ifFalse: [allTranslations := allTranslations 173201 select: [:each | "" 173202 ('*' , filterString , '*' match: each) 173203 or: ['*' , filterString , '*' 173204 match: (self translator translationFor: each)]]]. 173205"" 173206 ^ allTranslations asSortedCollection! ! 173207 173208!LanguageEditor methodsFor: 'accessing' stamp: 'dgd 9/21/2003 12:00'! 173209translationsFilter 173210^translationsFilter ifNil:['']! ! 173211 173212!LanguageEditor methodsFor: 'accessing' stamp: 'mir 8/11/2004 10:00'! 173213untranslated 173214 "answer the translator's untranslated phrases" 173215 173216 173217| all filterString | 173218 all := self translator untranslated. 173219 "" 173220 filterString := self untranslatedFilter. 173221 "" 173222 filterString isEmpty 173223 ifFalse: [all := all 173224 select: [:each | "" 173225 ('*' , filterString , '*' match: each) 173226 or: ['*' , filterString , '*' 173227 match: (self translator translationFor: each)]]]. 173228 "" 173229 ^ all asSortedCollection! ! 173230 173231!LanguageEditor methodsFor: 'accessing' stamp: 'dgd 9/21/2003 12:19'! 173232untranslatedFilter 173233 ^ untranslatedFilter 173234 ifNil: ['']! ! 173235 173236 173237!LanguageEditor methodsFor: 'gui methods' stamp: 'DamienCassou 9/29/2009 12:59'! 173238addTranslation 173239 "translate a phrase" 173240 | phrase | 173241 phrase := UIManager default 173242 request: 'enter the original:' 173243 initialAnswer: ''. 173244 173245 phrase isEmptyOrNil 173246 ifTrue: ["" 173247 self beep. 173248 ^ self]. 173249 "" 173250 self translatePhrase: phrase! ! 173251 173252!LanguageEditor methodsFor: 'gui methods' stamp: 'mir 7/21/2004 16:55'! 173253applyTranslations 173254 "private - try to apply the translations as much as possible all 173255 over the image" 173256 Project current updateLocaleDependents! ! 173257 173258!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 7/30/2004 22:25'! 173259browseMethodsWithTranslation 173260 | translation | 173261 self selectedTranslation isZero 173262 ifTrue: ["" 173263 self beep. 173264 self inform: 'select the translation to look for' translated. 173265 ^ self]. 173266 "" 173267 translation := self translations at: self selectedTranslation. 173268 self systemNavigation browseMethodsWithLiteral: translation! ! 173269 173270!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 7/13/2004 10:19'! 173271browseMethodsWithUntranslated 173272 | untranslated | 173273 self selectedUntranslated isZero 173274 ifTrue: ["" 173275 self beep. 173276 self inform: 'select the untranslated phrase to look for' translated. 173277 ^ self]. 173278 "" 173279 untranslated := self untranslated at: self selectedUntranslated. 173280 SystemNavigation default browseMethodsWithLiteral: untranslated. 173281! ! 173282 173283!LanguageEditor methodsFor: 'gui methods' stamp: 'tak 11/28/2004 15:01'! 173284codeSelectedTranslation 173285 | keys code | 173286 keys := selectedTranslations 173287 collect: [:key | self translations at: key]. 173288 code := String 173289 streamContents: [:aStream | self translator fileOutOn: aStream keys: keys]. 173290 (StringHolder new contents: code) 173291 openLabel: 'exported codes'! ! 173292 173293!LanguageEditor methodsFor: 'gui methods' stamp: 'sd 2/4/2008 21:21'! 173294codeSelectedTranslationAsMimeString 173295 | keys code tmpStream s2 gzs cont | 173296 keys := selectedTranslations 173297 collect: [:key | self translations at: key]. 173298 code := String 173299 streamContents: [:aStream | self translator fileOutOn: aStream keys: keys]. 173300 173301 tmpStream := MultiByteBinaryOrTextStream on: ''. 173302 tmpStream converter: UTF8TextConverter new. 173303 translator fileOutHeaderOn: tmpStream. 173304 tmpStream nextPutAll: code. 173305 s2 := RWBinaryOrTextStream on: ''. 173306 gzs := GZipWriteStream on: s2. 173307 tmpStream reset. 173308 gzs nextPutAll: (tmpStream binary contentsOfEntireFile asString) contents. 173309 gzs close. 173310 s2 reset. 173311 173312 cont := String streamContents: [:strm | 173313 strm nextPutAll: '"Gzip+Base64 encoded translation for;'; cr. 173314 strm nextPutAll: '#('. 173315 keys do: [:each | strm nextPutAll: '''', each, ''' '.]. 173316 strm nextPutAll: ')"'; cr; cr. 173317 strm nextPutAll: 'NaturalLanguageTranslator loadForLocaleIsoString: '. 173318 strm nextPut: $'. 173319 strm nextPutAll: translator localeID isoString. 173320 strm nextPut: $'. 173321 strm nextPutAll: ' fromGzippedMimeLiteral: '. 173322 strm nextPut: $'. 173323 strm nextPutAll: (Base64MimeConverter mimeEncode: s2) contents. 173324 strm nextPutAll: '''.'. 173325 strm cr. 173326 ]. 173327 173328 (StringHolder new contents: cont) 173329 openLabel: 'exported codes in Gzip+Base64 encoding'! ! 173330 173331!LanguageEditor methodsFor: 'gui methods' stamp: 'tak 11/28/2004 14:27'! 173332deselectAllTranslation 173333 selectedTranslations := IdentitySet new. 173334 self changed: #allSelections! ! 173335 173336!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 10:57'! 173337filterTranslations 173338 | filter | 173339 filter := UIManager default request: 'filter with 173340(empty string means no-filtering)' translated initialAnswer: self translationsFilter. 173341 "" 173342 self filterTranslations: filter! ! 173343 173344!LanguageEditor methodsFor: 'gui methods' stamp: 'sd 2/4/2008 21:21'! 173345filterTranslations: aString 173346| filter | 173347filter := aString ifNil:['']. 173348"" 173349 translationsFilter := filter. 173350self update: #translations. 173351! ! 173352 173353!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 10:58'! 173354filterUntranslated 173355 | filter | 173356 filter := UIManager default request: 'filter with 173357(empty string means no-filtering)' translated initialAnswer: self untranslatedFilter. 173358 "" 173359 self filterUntranslated: filter! ! 173360 173361!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/21/2003 12:20'! 173362filterUntranslated: aString 173363 | filter | 173364 filter := aString 173365 ifNil: ['']. 173366 "" 173367 untranslatedFilter := filter. 173368 self update: #untranslated! ! 173369 173370!LanguageEditor methodsFor: 'gui methods' stamp: 'tak 1/4/2005 09:24'! 173371getTextExport 173372 (Smalltalk at: #GetTextExporter) new export: self model! ! 173373 173374!LanguageEditor methodsFor: 'gui methods' stamp: 'mir 8/11/2004 09:56'! 173375loadFromFile 173376 | fileName | 173377 fileName := self selectTranslationFileName. 173378 fileName isNil 173379 ifTrue: ["" 173380 self beep. 173381 ^ self]. 173382 "" 173383 Cursor wait 173384 showWhile: [ 173385 self translator loadFromFileNamed: fileName. 173386 self changed: #translations. 173387 self changed: #untranslated]! ! 173388 173389!LanguageEditor methodsFor: 'gui methods' stamp: 'mir 8/11/2004 09:56'! 173390mergeFromFile 173391 | fileName | 173392 fileName := self selectTranslationFileName. 173393 fileName isNil 173394 ifTrue: ["" 173395 self beep. 173396 ^ self]. 173397 "" 173398 Cursor wait 173399 showWhile: [ 173400 self translator loadFromFileNamed: fileName. 173401 self changed: #translations. 173402 self changed: #untranslated]! ! 173403 173404!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 3/1/2005 12:32'! 173405phrase: phraseString translation: translationString 173406 "set the models's translation for phraseString" 173407 self translator phrase: phraseString translation: translationString. 173408 self changed: #translations. 173409 self changed: #untranslated. 173410 173411 newerKeys add: phraseString. 173412! ! 173413 173414!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 10:58'! 173415phraseToTranslate 173416 "answer a phrase to translate. use the selected untranslated phrase or ask for a new one" 173417 ^ self selectedUntranslated isZero 173418 ifTrue: [UIManager default 173419 multiLineRequest: 'new phrase to translate' translated 173420 centerAt: Sensor cursorPoint 173421 initialAnswer: '' 173422 answerHeight: 200] 173423 ifFalse: [self untranslated at: self selectedUntranslated]! ! 173424 173425!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 1/14/2005 18:00'! 173426removeTranslation 173427 "remove the selected translation" 173428 | translation | 173429 self selectedTranslation isZero 173430 ifTrue: ["" 173431 self beep. 173432 self inform: 'select the translation to remove' translated. 173433 ^ self]. 173434 "" 173435 translation := self translations at: self selectedTranslation. 173436"" 173437 (self 173438 confirm: ('Removing "{1}". 173439Are you sure you want to do this?' translated format: {translation})) 173440 ifFalse: [^ self]. 173441"" 173442 self translator removeTranslationFor: translation. 173443 self changed: #translations. 173444 self changed: #untranslated.! ! 173445 173446!LanguageEditor methodsFor: 'gui methods' stamp: 'mir 8/11/2004 09:59'! 173447removeUntranslated 173448 "remove the selected untranslated phrase" 173449 | untranslated | 173450 self selectedUntranslated isZero 173451 ifTrue: ["" 173452 self beep. 173453 self inform: 'select the untranslated phrase to remove' translated. 173454 ^ self]. 173455 "" 173456 untranslated := self untranslated at: self selectedUntranslated. 173457 "" 173458 (self 173459 confirm: ('Removing "{1}". 173460Are you sure you want to do this?' translated format: {untranslated})) 173461 ifFalse: [^ self]. 173462 "" 173463 self translator removeUntranslated: untranslated! ! 173464 173465!LanguageEditor methodsFor: 'gui methods' stamp: 'mir 7/21/2004 19:27'! 173466report 173467 self reportString openInWorkspaceWithTitle: 'report' translated! ! 173468 173469!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 3/1/2005 12:36'! 173470resetNewerKeys 173471 173472 self initializeNewerKeys. 173473! ! 173474 173475!LanguageEditor methodsFor: 'gui methods' stamp: 'DamienCassou 9/29/2009 12:59'! 173476saveToFile 173477 "save the translator to a file" 173478 | fileName | 173479 fileName := UIManager default request: 'file name' translated initialAnswer: translator localeID isoString , '.translation'. 173480 fileName isEmptyOrNil 173481 ifTrue: ["" 173482 self beep. 173483 ^ self]. 173484 "" 173485Cursor wait 173486 showWhile: [ 173487 self translator saveToFileNamed: fileName]! ! 173488 173489!LanguageEditor methodsFor: 'gui methods' stamp: 'DamienCassou 9/29/2009 12:59'! 173490searchTranslation 173491 | search | 173492 search := UIManager default request: 'search for' translated initialAnswer: ''. 173493 search isEmptyOrNil 173494 ifTrue: ["" 173495 self beep. 173496 ^ self]. 173497"" 173498self searchTranslation: search! ! 173499 173500!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 09:24'! 173501searchTranslation: aString 173502 | translations results index | 173503 translations := self translations. 173504 results := translations 173505 select: [:each | "" 173506 ('*' , aString , '*' match: each) 173507 or: ['*' , aString , '*' match: (self translator translationFor: each)]]. 173508 "" 173509 results isEmpty 173510 ifTrue: ["" 173511 self inform: 'no matches for' translated , ' ''' , aString , ''''. 173512 ^ self]. 173513 "" 173514 results size = 1 173515 ifTrue: ["" 173516 self selectTranslationPhrase: results first. 173517 ^ self]. 173518 "" 173519 index := (UIManager default 173520 chooseFrom: (results 173521 collect: [:each | "" 173522 (each copy replaceAll: Character cr with: $\) 173523 , ' -> ' 173524 , ((self translator translationFor: each) copy replaceAll: Character cr with: $\)]) 173525 title: 'select the translation...' translated). 173526 "" 173527 index isZero 173528 ifTrue: ["" 173529 self beep. 173530 ^ self]. 173531 "" 173532 self 173533 selectTranslationPhrase: (results at: index)! ! 173534 173535!LanguageEditor methodsFor: 'gui methods' stamp: 'DamienCassou 9/29/2009 13:00'! 173536searchUntranslated 173537 | search | 173538 search := UIManager default request: 'search for' translated initialAnswer: ''. 173539 search isEmptyOrNil 173540 ifTrue: ["" 173541 self beep. 173542 ^ self]. 173543 "" 173544 self searchUntranslated: search! ! 173545 173546!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 09:25'! 173547searchUntranslated: aString 173548 | untranslateds results index | 173549 untranslateds := self untranslated. 173550 results := untranslateds 173551 select: [:each | '*' , aString , '*' match: each]. 173552 "" 173553 results isEmpty 173554 ifTrue: ["" 173555 self inform: 'no matches for' translated , ' ''' , aString , ''''. 173556 ^ self]. 173557 "" 173558 results size = 1 173559 ifTrue: ["" 173560 self selectUntranslatedPhrase: results first. 173561 ^ self]. 173562 "" 173563 index := (UIManager default 173564 chooseFrom: (results 173565 collect: [:each | each copy replaceAll: Character cr with: $\]) 173566 title: 'select the untranslated phrase...' translated). 173567 "" 173568 index isZero 173569 ifTrue: ["" 173570 self beep. 173571 ^ self]. 173572 "" 173573 self 173574 selectUntranslatedPhrase: (results at: index)! ! 173575 173576!LanguageEditor methodsFor: 'gui methods' stamp: 'tak 11/28/2004 14:26'! 173577selectAllTranslation 173578 selectedTranslations := (1 to: self translations size) asIdentitySet. 173579 self changed: #allSelections! ! 173580 173581!LanguageEditor methodsFor: 'gui methods' stamp: 'sd 2/4/2008 21:21'! 173582selectNewerKeys 173583 173584 | translations index | 173585 self deselectAllTranslation. 173586 translations := self translations. 173587 newerKeys do: [:k | 173588 index := translations indexOf: k ifAbsent: [0]. 173589 index > 0 ifTrue: [ 173590 self selectedTranslationsAt: index put: true 173591 ]. 173592 ]. 173593! ! 173594 173595!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/24/2003 22:15'! 173596selectTranslationFileName 173597 "answer a file with a translation" 173598 | file | 173599 file := (StandardFileMenu oldFileMenu: FileDirectory default withPattern: '*.translation') 173600 startUpWithCaption: 'Select the file...' translated. 173601 ^ file isNil 173602 ifFalse: [file directory fullNameFor: file name]! ! 173603 173604!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/24/2003 22:49'! 173605selectTranslationPhrase: phraseString 173606 self selectedTranslation: (self translations indexOf: phraseString)! ! 173607 173608!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/27/2003 20:43'! 173609selectUntranslatedPhrase: phraseString 173610 self 173611 selectedUntranslated: (self untranslated indexOf: phraseString)! ! 173612 173613!LanguageEditor methodsFor: 'gui methods' stamp: 'mir 8/11/2004 10:00'! 173614status 173615 "answer a status string" 173616 | translationsSize untranslatedSize | 173617 translationsSize := self translator translations size. 173618 untranslatedSize := self translator untranslated size. 173619 ^ 'ÆÀ {1} phrases ÆÀ {2} translated ÆÀ {3} untranslated ÆÀ' translated format: {translationsSize + untranslatedSize. translationsSize. untranslatedSize}! ! 173620 173621!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/24/2003 21:53'! 173622translate 173623 "translate a phrase" 173624 | phrase | 173625 phrase := self phraseToTranslate. 173626 "" 173627 (phrase isNil 173628 or: [phrase = '']) 173629 ifTrue: ["" 173630 self beep. 173631 ^ self]. 173632 "" 173633 self translatePhrase: phrase! ! 173634 173635!LanguageEditor methodsFor: 'gui methods' stamp: 'rbb 3/1/2005 10:58'! 173636translatePhrase: aString 173637 "translate aString" 173638 | translation | 173639 translation := UIManager default 173640 multiLineRequest: 'translation for: ' translated , '''' , aString , '''' 173641 centerAt: Sensor cursorPoint 173642 initialAnswer: aString 173643 answerHeight: 200. 173644 "" 173645 (translation isNil 173646 or: [translation = '']) 173647 ifTrue: ["" 173648 self beep. 173649 ^ self]. 173650 "" 173651 self phrase: aString translation: translation! ! 173652 173653!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/21/2003 12:09'! 173654translationsFilterWording 173655 ^ (self translationsFilter isEmpty 173656 ifTrue: ['filter' translated] 173657 ifFalse: ['filtering: {1}' translated format:{self translationsFilter}]) ! ! 173658 173659!LanguageEditor methodsFor: 'gui methods' stamp: 'gm 8/30/2003 02:00'! 173660translationsKeystroke: aChar 173661 "Respond to a Command key in the translations list." 173662 aChar == $x 173663 ifTrue: [^ self removeTranslation]. 173664 aChar == $E 173665 ifTrue: [^ self browseMethodsWithTranslation]! ! 173666 173667!LanguageEditor methodsFor: 'gui methods' stamp: 'yo 3/1/2005 12:49'! 173668translationsMenu: aMenu 173669 ^ aMenu add: 'remove (x)' translated action: #removeTranslation; 173670 add: 'where (E)' translated action: #browseMethodsWithTranslation; 173671 add: 'select all' translated action: #selectAllTranslation; 173672 add: 'deselect all' translated action: #deselectAllTranslation; 173673 add: 'select changed keys' translated action: #selectNewerKeys; 173674 add: 'export selection' translated action: #codeSelectedTranslation; 173675 add: 'export selection in do-it form' translated action: #codeSelectedTranslationAsMimeString; 173676 add: 'reset changed keys' translated action: #resetNewerKeys; 173677 yourself! ! 173678 173679!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/21/2003 12:19'! 173680untranslatedFilterWording 173681 ^ self untranslatedFilter isEmpty 173682 ifTrue: ['filter' translated] 173683 ifFalse: ['filtering: {1}' translated format: {self untranslatedFilter}]! ! 173684 173685!LanguageEditor methodsFor: 'gui methods' stamp: 'gm 8/30/2003 02:01'! 173686untranslatedKeystroke: aChar 173687 "Respond to a Command key in the translations list." 173688 aChar == $t 173689 ifTrue: [^ self translate]. 173690 aChar == $E 173691 ifTrue: [^ self browseMethodsWithUntranslated]! ! 173692 173693!LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 10/13/2003 18:30'! 173694untranslatedMenu: aMenu 173695 ^ aMenu add: 'remove' translated action: #removeUntranslated; 173696 add: 'translate (t)' translated action: #translate; 173697 add: 'where (E)' translated action: #browseMethodsWithUntranslated; 173698 yourself! ! 173699 173700 173701!LanguageEditor methodsFor: 'initialization' stamp: 'sd 2/4/2008 21:21'! 173702initializeNewerKeys 173703 173704 newerKeys := Set new. 173705! ! 173706 173707!LanguageEditor methodsFor: 'initialization' stamp: 'yo 3/1/2005 12:33'! 173708initializeOn: aLanguage 173709 "initialize the receiver on aLanguage" 173710 "" 173711 selectedTranslation := 0. 173712 selectedUntranslated := 0. 173713 selectedTranslations := IdentitySet new. 173714 "" 173715 translator := aLanguage. 173716 "" 173717 self setLabel: 'Language editor for: ' translated , self translator name. 173718 "" 173719 self initializeToolbars. 173720 self initializePanels. 173721 self initializeStatusbar. 173722 self initializeNewerKeys. 173723! ! 173724 173725!LanguageEditor methodsFor: 'initialization' stamp: 'tak 11/28/2004 14:12'! 173726initializePanels 173727 "initialize the receiver's panels" 173728 translationsList := PluggableListMorphOfMany 173729 on: self 173730 list: #translations 173731 primarySelection: #selectedTranslation 173732 changePrimarySelection: #selectedTranslation: 173733 listSelection: #selectedTranslationsAt: 173734 changeListSelection: #selectedTranslationsAt:put: 173735 menu: #translationsMenu: 173736 keystroke: #translationsKeystroke:. 173737 translationsList setBalloonText: 'List of all the translated phrases.' translated. 173738 "" 173739 untranslatedList := PluggableListMorph 173740 on: self 173741 list: #untranslated 173742 selected: #selectedUntranslated 173743 changeSelected: #selectedUntranslated: 173744 menu: #untranslatedMenu: 173745 keystroke: #untranslatedKeystroke:. 173746 untranslatedList setBalloonText: 'List of all the untranslated phrases.' translated. 173747 "" 173748 translationText := PluggableTextMorph 173749 on: self 173750 text: #translation 173751 accept: #translation: 173752 readSelection: nil 173753 menu: nil. 173754 translationText setBalloonText: 'Translation for the selected phrase in the upper list.' translated. 173755 "" 173756 self 173757 addMorph: translationsList 173758 frame: (0 @ 0.18 corner: 0.5 @ 0.66). 173759 self 173760 addMorph: untranslatedList 173761 frame: (0.5 @ 0.18 corner: 1 @ 0.93). 173762 self 173763 addMorph: translationText 173764 frame: (0 @ 0.66 corner: 0.5 @ 0.93)! ! 173765 173766 173767!LanguageEditor methodsFor: 'initialization - statusbar' stamp: 'tak 11/15/2004 12:15'! 173768createStatusbar 173769 "create the statusbar for the receiver" 173770 | statusbar | 173771 statusbar := self createRow. 173772 statusbar addMorph: ((UpdatingStringMorph on: self selector: #status) growable: true; 173773 useStringFormat; 173774 hResizing: #spaceFill; 173775 stepTime: 2000). 173776 ^ statusbar! ! 173777 173778!LanguageEditor methodsFor: 'initialization - statusbar' stamp: 'dgd 9/21/2003 11:39'! 173779initializeStatusbar 173780 "initialize the receiver's statusbar" 173781 self 173782 addMorph: self createStatusbar 173783 frame: (0 @ 0.93 corner: 1 @ 1)! ! 173784 173785 173786!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'tak 11/16/2004 15:07'! 173787createButtonLabel: aString action: actionSelector help: helpString 173788 "create a toolbar for the receiver" 173789 | button | 173790 button := SimpleButtonMorph new target: self; 173791 label: aString translated "font: Preferences standardButtonFont"; 173792 actionSelector: actionSelector; 173793 setBalloonText: helpString translated; 173794 color: translator defaultBackgroundColor twiceDarker; 173795 borderWidth: 2; 173796 borderColor: #raised. 173797 "" 173798 ^ button! ! 173799 173800!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'mir 7/21/2004 18:01'! 173801createMainToolbar 173802 "create a toolbar for the receiver" 173803 | toolbar | 173804 toolbar := self createRow. 173805 "" 173806" toolbar 173807 addMorphBack: (self 173808 createUpdatingButtonWording: #debugWording 173809 action: #switchDebug 173810 help: 'Switch the debug flag')." 173811 toolbar addTransparentSpacerOfSize: 5 @ 0. 173812 "" 173813 toolbar 173814 addMorphBack: (self 173815 createButtonLabel: 'save' 173816 action: #saveToFile 173817 help: 'Save the translations to a file'). 173818 toolbar 173819 addMorphBack: (self 173820 createButtonLabel: 'load' 173821 action: #loadFromFile 173822 help: 'Load the translations from a file'). 173823 toolbar 173824 addMorphBack: (self 173825 createButtonLabel: 'merge' 173826 action: #mergeFromFile 173827 help: 'Merge the current translations with the translations in a file'). 173828 "" 173829 toolbar addTransparentSpacerOfSize: 5 @ 0. 173830 toolbar 173831 addMorphBack: (self 173832 createButtonLabel: 'apply' 173833 action: #applyTranslations 173834 help: 'Apply the translations as much as possible.'). 173835 "" 173836 toolbar addTransparentSpacerOfSize: 5 @ 0. 173837 toolbar 173838 addMorphBack: (self 173839 createButtonLabel: 'check translations' 173840 action: #check 173841 help: 'Check the translations and report the results.'). 173842 toolbar 173843 addMorphBack: (self 173844 createButtonLabel: 'report' 173845 action: #report 173846 help: 'Create a report.'). 173847 toolbar 173848 addMorphBack: (self 173849 createButtonLabel: 'gettext export' 173850 action: #getTextExport 173851 help: 'Exports the translations in GetText format.'). 173852 "" 173853 ^ toolbar! ! 173854 173855!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'dgd 9/21/2003 11:46'! 173856createRow 173857 "create a row" 173858 | row | 173859 row := AlignmentMorph newRow. 173860 row layoutInset: 3; 173861 wrapCentering: #center; 173862 cellPositioning: #leftCenter. 173863 "" 173864 ^ row! ! 173865 173866!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'yo 2/17/2005 18:24'! 173867createTranslationsToolbar 173868 "create a toolbar for the receiver" 173869 | toolbar | 173870 toolbar := self createRow. 173871 "" 173872 toolbar 173873 addMorphBack: (self 173874 createUpdatingButtonWording: #translationsFilterWording 173875 action: #filterTranslations 173876 help: 'Filter the translations list.'). 173877 toolbar addTransparentSpacerOfSize: 5 @ 0. 173878 "" 173879 toolbar 173880 addMorphBack: (self 173881 createButtonLabel: 'search' 173882 action: #searchTranslation 173883 help: 'Search for a translation containing...'). 173884 toolbar addTransparentSpacerOfSize: 5 @ 0. 173885 toolbar 173886 addMorphBack: (self 173887 createButtonLabel: 'remove' 173888 action: #removeTranslation 173889 help: 'Remove the selected translation. If none is selected, ask for the one to remove.'). 173890 "" 173891 toolbar addTransparentSpacerOfSize: 5 @ 0. 173892 toolbar 173893 addMorphBack: (self 173894 createButtonLabel: 'where' 173895 action: #browseMethodsWithTranslation 173896 help: 'Launch a browser on all methods that contain the phrase as a substring of any literal String.'). 173897 toolbar addTransparentSpacerOfSize: 5 @ 0. 173898 toolbar 173899 addMorphBack: (self 173900 createButtonLabel: 'r-unused' 173901 action: #removeTranslatedButUnusedStrings 173902 help: 'Remove all the strings that are not used by the system'). 173903 toolbar addTransparentSpacerOfSize: 5 @ 0. 173904 toolbar 173905 addMorphBack: (self 173906 createButtonLabel: 'add ' 173907 action: #addTranslation 173908 help: 'Add a new phrase'). 173909 173910 ^ toolbar! ! 173911 173912!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'sd 12/18/2004 18:10'! 173913createUntranslatedToolbar 173914 "create a toolbar for the receiver" 173915 | toolbar | 173916 toolbar := self createRow. 173917 "" 173918 toolbar 173919 addMorphBack: (self 173920 createUpdatingButtonWording: #untranslatedFilterWording 173921 action: #filterUntranslated 173922 help: 'Filter the untranslated list.'). 173923 toolbar addTransparentSpacerOfSize: 5 @ 0. 173924 "" 173925 toolbar 173926 addMorphBack: (self 173927 createButtonLabel: 'search' 173928 action: #searchUntranslated 173929 help: 'Search for a untranslated phrase containing...'). 173930 toolbar addTransparentSpacerOfSize: 5 @ 0. 173931 toolbar 173932 addMorphBack: (self 173933 createButtonLabel: 'remove' 173934 action: #removeUntranslated 173935 help: 'Remove the selected untranslated phrease. If none is selected, ask for the one to remove.'). 173936 "" 173937 toolbar addTransparentSpacerOfSize: 5 @ 0. 173938 toolbar 173939 addMorphBack: (self 173940 createButtonLabel: 'translate' 173941 action: #translate 173942 help: 'Translate the selected untranslated phrase or a new phrase'). 173943 "" 173944 toolbar addTransparentSpacerOfSize: 5 @ 0. 173945 toolbar 173946 addMorphBack: (self 173947 createButtonLabel: 'where' 173948 action: #browseMethodsWithUntranslated 173949 help: 'Launch a browser on all methods that contain the phrase as a substring of any literal String.'). 173950 toolbar addTransparentSpacerOfSize: 5 @ 0. 173951 toolbar 173952 addMorphBack: (self 173953 createButtonLabel: 'r-unused' 173954 action: #removeUntranslatedButUnusedStrings 173955 help: 'Remove all the strings that are not used by the system'). 173956 ^ toolbar! ! 173957 173958!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'tak 11/16/2004 15:06'! 173959createUpdatingButtonWording: wordingSelector action: actionSelector help: helpString 173960 "create a toolbar for the receiver" 173961 | button | 173962 button := (UpdatingSimpleButtonMorph newWithLabel: '-') target: self; 173963 wordingSelector: wordingSelector; 173964 actionSelector: actionSelector; 173965 setBalloonText: helpString translated; 173966 color: translator defaultBackgroundColor twiceDarker; 173967 borderWidth: 1; 173968 borderColor: #raised; cornerStyle: #square. 173969 "" 173970 ^ button! ! 173971 173972!LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'dgd 9/21/2003 11:27'! 173973initializeToolbars 173974 "initialize the receiver's toolbar" 173975 self 173976 addMorph: self createMainToolbar 173977 frame: (0 @ 0 corner: 1 @ 0.09). 173978 "" 173979 self 173980 addMorph: self createTranslationsToolbar 173981 frame: (0 @ 0.09 corner: 0.5 @ 0.18). 173982 self 173983 addMorph: self createUntranslatedToolbar 173984 frame: (0.5 @ 0.09 corner: 1 @ 0.18)! ! 173985 173986 173987!LanguageEditor methodsFor: 'message handling' stamp: 'gm 8/30/2003 01:54'! 173988perform: selector orSendTo: otherTarget 173989 "I wish to intercept and handle selector myself" 173990 ^ self perform: selector! ! 173991 173992 173993!LanguageEditor methodsFor: 'open/close' stamp: 'dgd 8/26/2003 14:20'! 173994delete 173995 "Remove the receiver as a submorph of its owner" 173996 self model: nil. 173997 super delete ! ! 173998 173999 174000!LanguageEditor methodsFor: 'reporting' stamp: 'mir 7/21/2004 19:24'! 174001asHtml: aString 174002 | stream | 174003 stream := String new writeStream. 174004 174005 aString 174006 do: [:each | 174007 each caseOf: { 174008 [Character cr] -> [stream nextPutAll: '<br>']. 174009 [$&] -> [stream nextPutAll: '&']. 174010 [$<] -> [stream nextPutAll: '<']. 174011 [$>] -> [stream nextPutAll: '>']. 174012 [$*] -> [stream nextPutAll: '☆']. 174013 [$@] -> [stream nextPutAll: '&at;']} 174014 otherwise: [stream nextPut: each]]. 174015 174016 ^ stream contents! ! 174017 174018!LanguageEditor methodsFor: 'reporting' stamp: 'mir 8/11/2004 09:59'! 174019printHeaderReportOn: aStream 174020 "append to aStream a header report of the receiver with swiki 174021 format" 174022 aStream nextPutAll: '!!!!'; 174023 174024 nextPutAll: ('Language: {1}' translated format: {self translator localeID isoString}); 174025 cr. 174026 174027 aStream nextPutAll: '- '; 174028 174029 nextPutAll: ('{1} translated phrases' translated format: {self translator translations size}); 174030 cr. 174031 174032 aStream nextPutAll: '- '; 174033 174034 nextPutAll: ('{1} untranslated phrases' translated format: {self translator untranslated size}); 174035 cr. 174036 174037 aStream cr; cr! ! 174038 174039!LanguageEditor methodsFor: 'reporting' stamp: 'mir 7/21/2004 19:25'! 174040printReportOn: aStream 174041 "append to aStream a report of the receiver with swiki format" 174042 self printHeaderReportOn: aStream. 174043 self printUntranslatedReportOn: aStream. 174044 self printTranslationsReportOn: aStream! ! 174045 174046!LanguageEditor methodsFor: 'reporting' stamp: 'mir 8/11/2004 10:01'! 174047printTranslationsReportOn: aStream 174048 "append to aStream a report of the receiver's translations" 174049 | originalPhrases | 174050 aStream nextPutAll: '!!'; 174051 nextPutAll: 'translations' translated; 174052 cr. 174053 174054 originalPhrases := self translator translations keys asSortedCollection. 174055 174056 originalPhrases 174057 do: [:each | 174058 aStream 174059 nextPutAll: ('|{1}|{2}|' format: {self asHtml: each. self 174060 asHtml: (self translator translationFor: each)}); 174061 cr]. 174062 174063 aStream cr; cr! ! 174064 174065!LanguageEditor methodsFor: 'reporting' stamp: 'mir 7/21/2004 19:26'! 174066printUntranslatedReportOn: aStream 174067 "append to aStream a report of the receiver's translations" 174068 aStream nextPutAll: '!!'; 174069 nextPutAll: 'not translated' translated; 174070 cr. 174071 174072 self untranslated asSortedCollection 174073 do: [:each | 174074 aStream 174075 nextPutAll: ('|{1}|' format: {self asHtml: each}); 174076 cr]. 174077 174078 aStream cr; cr! ! 174079 174080!LanguageEditor methodsFor: 'reporting' stamp: 'mir 7/21/2004 19:26'! 174081reportString 174082 "answer a string with a report of the receiver" 174083 | stream | 174084 stream := String new writeStream. 174085 self printReportOn: stream. 174086 ^ stream contents! ! 174087 174088 174089!LanguageEditor methodsFor: 'stef' stamp: 'ar 4/10/2005 18:48'! 174090identifyUnusedStrings 174091 "self new identifyUnusedStrings" 174092 translationsList getList 174093 do: [:each | 174094 Transcript show: each. 174095 Transcript show: (Smalltalk 174096 allSelect: [:method | method 174097 hasLiteralSuchThat: [:lit | lit isString 174098 and: [lit includesSubstring: each caseSensitive: true]]]) size printString; cr]! ! 174099 174100!LanguageEditor methodsFor: 'stef' stamp: 'ar 4/10/2005 18:48'! 174101numberOfTimesStringIsUsed: aString 174102 174103 ^ (self systemNavigation allSelect: [:method | method 174104 hasLiteralSuchThat: [:lit | lit isString 174105 and: [lit includesSubstring: aString caseSensitive: true]]]) size! ! 174106 174107!LanguageEditor methodsFor: 'stef' stamp: 'tak 1/4/2005 09:26'! 174108removeTranslatedButUnusedStrings 174109 (self confirm: 'Are you sure that you want to remove unused strings?' translated) 174110 ifFalse: [^ self]. 174111 translationsList getList 174112 do: [:each | 174113 | timesUsed | 174114 timesUsed := self numberOfTimesStringIsUsed: each. 174115 Transcript show: each. 174116 Transcript show: timesUsed printString; 174117 cr. 174118 timesUsed isZero 174119 ifTrue: [self translator removeTranslationFor: each]]! ! 174120 174121!LanguageEditor methodsFor: 'stef' stamp: 'yo 1/14/2005 16:55'! 174122removeUntranslatedButUnusedStrings 174123 (self confirm: 'Are you sure that you want to remove unused strings?' translated) 174124 ifFalse: [^ self]. 174125 untranslatedList getList 174126 do: [:each | 174127 | timesUsed | 174128 timesUsed := self numberOfTimesStringIsUsed: each. 174129 Transcript show: each. 174130 Transcript show: timesUsed printString; 174131 cr. 174132 timesUsed isZero 174133 ifTrue: [self translator removeUntranslated: each]]. 174134 174135 self update: #untranslated. 174136! ! 174137 174138 174139!LanguageEditor methodsFor: 'updating' stamp: 'alain.plantec 2/8/2009 22:15'! 174140okToChange 174141 "Allows a controller to ask this of any model" 174142 self selectedTranslation isZero 174143 ifTrue: [^ true]. 174144 "" 174145 translationText hasUnacceptedEdits 174146 ifFalse: [^ true]. 174147 ^ (self confirm: 'Discard the changes to currently selected translated phrase?' translated) 174148 and: [translationText hasUnacceptedEdits: false. 174149 true] ! ! 174150 174151!LanguageEditor methodsFor: 'updating' stamp: 'dgd 8/27/2003 19:59'! 174152refreshTranslations 174153 "refresh the translations panel" 174154 self changed: #translations. 174155 self selectedTranslation: 0! ! 174156 174157!LanguageEditor methodsFor: 'updating' stamp: 'dgd 8/27/2003 19:59'! 174158refreshUntranslated 174159"refresh the untranslated panel" 174160 self changed: #untranslated. 174161 self selectedUntranslated: 0! ! 174162 174163!LanguageEditor methodsFor: 'updating' stamp: 'dgd 8/25/2003 20:11'! 174164update: aSymbol 174165 "Receive a change notice from an object of whom the receiver 174166 is a dependent." 174167 super update: aSymbol. 174168 "" 174169 aSymbol == #untranslated 174170 ifTrue: [self refreshUntranslated]. 174171 aSymbol == #translations 174172 ifTrue: [self refreshTranslations]! ! 174173 174174 174175!LanguageEditor methodsFor: 'private' stamp: 'torsten.bergmann 12/16/2008 12:49'! 174176beep 174177 ^Beeper beep! ! 174178 174179!LanguageEditor methodsFor: 'private' stamp: 'mir 8/11/2004 09:58'! 174180check 174181 "check the translations and answer a collection with the results" 174182 | results counter phrasesCount untranslated translations checkMethod | 174183 results := OrderedCollection new. 174184 untranslated := self translator untranslated. 174185 translations := self translator translations. 174186 phrasesCount := translations size + untranslated size. 174187 counter := 0. 174188 checkMethod := self class checkMethods at: self translator localeID printString ifAbsent: [^results]. 174189 174190 translations 174191 keysAndValuesDo: [:phrase :translation | 174192 | result | 174193 result := self perform: checkMethod with: phrase with: translation. 174194 (result notNil 174195 and: [result notEmpty]) 174196 ifTrue: [results add: {phrase. translation. result}]. 174197 174198 counter := counter + 1. 174199 (counter isDivisibleBy: 50) 174200 ifTrue: [| percent | 174201 percent := counter / phrasesCount * 100 roundTo: 0.01. 174202 Transcript 174203 show: ('- checked {1} phrases of {2} ({3}%)...' translated format: {counter. phrasesCount. percent}); 174204 cr]]. 174205 174206 untranslated 174207 do: [:phrase | 174208 | result | 174209 result := self checkUntranslatedPhrase: phrase. 174210 (result notNil 174211 and: [result notEmpty]) 174212 ifTrue: [results add: {phrase. nil. result}]. 174213 174214 counter := counter + 1. 174215 (counter isDivisibleBy: 50) 174216 ifTrue: [| percent | 174217 percent := counter / phrasesCount * 100 roundTo: 0.01. 174218 Transcript 174219 show: ('- checked {1} phrases of {2} ({3}%)...' translated format: {counter. phrasesCount. percent}); 174220 cr]]. 174221 174222 ^ results! ! 174223 174224!LanguageEditor methodsFor: 'private' stamp: 'mir 7/21/2004 18:58'! 174225checkPhrase: phraseString translation: translationString 174226 ^nil! ! 174227 174228!LanguageEditor methodsFor: 'private' stamp: 'tak 12/26/2004 12:10'! 174229checkSpanishPhrase: phraseString translation: translationString 174230 "check the translation an aswer a string with a comment or a 174231 nil meaning no-comments" 174232 | superResult | 174233 superResult := self checkPhrase: phraseString translation: translationString. 174234 174235 superResult isNil 174236 ifFalse: [^ superResult]. 174237"For some reason, MCInstaller couldn't read Spanish character." 174238" ((translationString withBlanksTrimmed includes: $?) 174239 and: [(translationString withBlanksTrimmed includes: $é…) not]) 174240 ifTrue: [^ 'é…OlvidƧ el signo de pregunta?']. 174241 ((translationString withBlanksTrimmed includes: $!!) 174242 and: [(translationString withBlanksTrimmed includes: $éÄ) not]) 174243 ifTrue: [^ 'é…OlvidƧ el signo de admiraciƧn?']. 174244" 174245 ^ nil! ! 174246 174247!LanguageEditor methodsFor: 'private' stamp: 'mir 7/21/2004 18:57'! 174248checkUntranslatedPhrase: phraseString 174249 "check the phrase an aswer a string with a comment or a nil 174250 meaning no-comments" 174251 174252 (self translations includes: phraseString) 174253 ifTrue: [^ 'possible double-translation' translated]. 174254 174255 ^ nil! ! 174256 174257!LanguageEditor methodsFor: 'private' stamp: 'mir 8/11/2004 09:57'! 174258translator 174259 ^translator! ! 174260 174261"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 174262 174263LanguageEditor class 174264 instanceVariableNames: ''! 174265 174266!LanguageEditor class methodsFor: 'initialization' stamp: 'mir 7/21/2004 18:47'! 174267initCheckMethods 174268 "LanguageEditor initCheckMethods" 174269 174270 | registry | 174271 registry := Dictionary new. 174272 registry 174273 at: 'es' put: #checkSpanishPhrase:translation:; 174274 yourself. 174275 ^registry! ! 174276 174277!LanguageEditor class methodsFor: 'initialization' stamp: 'dgd 11/9/2003 14:27'! 174278initialize 174279 "initialize the receiver" 174280 (TheWorldMenu respondsTo: #registerOpenCommand:) 174281 ifTrue: ["" 174282 TheWorldMenu registerOpenCommand: {'Language Editor'. {self. #openOnDefault}}. 174283 TheWorldMenu registerOpenCommand: {'Language Editor for...'. {self. #open}}]! ! 174284 174285!LanguageEditor class methodsFor: 'initialization' stamp: 'dgd 11/9/2003 14:27'! 174286unload 174287 "the receiver is being unloaded" 174288 (TheWorldMenu respondsTo: #registerOpenCommand:) 174289 ifTrue: ["" 174290 TheWorldMenu unregisterOpenCommand: 'Language Editor'. 174291 TheWorldMenu unregisterOpenCommand: 'Language Editor for...'] ! ! 174292 174293 174294!LanguageEditor class methodsFor: 'instance creation' stamp: 'mir 7/21/2004 17:00'! 174295on: aLanguage 174296 "answer an instance of the receiver on aLanguage" 174297 ^ self new initializeOn: (NaturalLanguageTranslator localeID: aLanguage)! ! 174298 174299!LanguageEditor class methodsFor: 'instance creation' stamp: 'mir 8/11/2004 10:00'! 174300openOn: aLanguage 174301 "open an instance on aLanguage" 174302 World submorphs 174303 do: [:each | "" 174304 ((each isKindOf: LanguageEditor) 174305 and: [each translator == aLanguage]) 174306 ifTrue: ["" 174307 self ensureVisibilityOfWindow: each. 174308 ^ self]]. 174309 "" 174310 ^ (self on: aLanguage) openInWorld! ! 174311 174312 174313!LanguageEditor class methodsFor: 'opening' stamp: 'mir 7/21/2004 16:57'! 174314open 174315 "open the receiver on any language" 174316 " 174317 LanguageEditor open. 174318 " 174319 | menu | 174320 menu := MenuMorph new defaultTarget: self. 174321 menu addTitle: 'Language Editor for...' translated. 174322 "" 174323 (NaturalLanguageTranslator availableLanguageLocaleIDs 174324 asSortedCollection: [:x :y | x asString <= y asString]) 174325 do: [:eachLanguage | "" 174326 menu 174327 add: eachLanguage name 174328 target: self 174329 selector: #openOn: 174330 argument: eachLanguage]. 174331 "" 174332 menu popUpInWorld! ! 174333 174334!LanguageEditor class methodsFor: 'opening' stamp: 'TN 4/8/2005 01:13'! 174335openOnDefault 174336 "open the receiver on the default language" 174337 self openOn: LocaleID current! ! 174338 174339 174340!LanguageEditor class methodsFor: 'private' stamp: 'mir 7/21/2004 18:47'! 174341checkMethods 174342 ^CheckMethods ifNil: [CheckMethods := self initCheckMethods]! ! 174343 174344!LanguageEditor class methodsFor: 'private' stamp: 'dgd 11/9/2003 15:39'! 174345ensureVisibilityOfWindow: aWindow 174346 "private - activate the window" 174347 | | 174348 aWindow expand. 174349 aWindow comeToFront. 174350 "" 174351 aWindow 174352 right: (aWindow right min: World right). 174353 aWindow 174354 bottom: (aWindow bottom min: World bottom). 174355 aWindow 174356 left: (aWindow left max: World left). 174357 aWindow 174358 top: (aWindow top max: World top). 174359 "" 174360 aWindow flash; flash! ! 174361Object subclass: #LanguageEnvironment 174362 instanceVariableNames: 'id' 174363 classVariableNames: 'ClipboardInterpreterClass Current FileNameConverterClass InputInterpreterClass KnownEnvironments SystemConverterClass' 174364 poolDictionaries: '' 174365 category: 'Multilingual-Languages'! 174366!LanguageEnvironment commentStamp: '<historical>' prior: 0! 174367The name multilingualized Squeak suggests that you can use multiple language at one time. This is true, of course, but the system still how to manage the primary language; that provides the interpretation of data going out or coming in from outside world. It also provides how to render strings, as there rendering rule could be different in one language to another, even if the code points in a string is the same. 174368 174369 Originally, LanguageEnvironment and its subclasses only has class side methods. After merged with Diego's Babel work, it now has instance side methods. Since this historical reason, the class side and instance side are not related well. 174370 174371 When we talk about the interface with the outside of the Squeak world, there are three different "channels"; the keyboard input, clipboard output and input, and filename. On a not-to-uncommon system such as a Unix system localized to Japan, all of these three can have (and does have) different encodings. So we need to manage them separately. Note that the encoding in a file can be anything. While it is nice to provide a suggested guess for this 'default system file content encoding', it is not critical. 174372 174373 Rendering support is limited basic L-to-R rendering so far. But you can provide different line-wrap rule, at least. 174374! 174375 174376 174377!LanguageEnvironment methodsFor: 'accessing' stamp: 'tak 8/4/2005 11:02'! 174378fontEncodingName 174379 ^ #Font , self class name! ! 174380 174381!LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:32'! 174382isoCountry 174383 ^self localeID isoCountry! ! 174384 174385!LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:32'! 174386isoLanguage 174387 ^self localeID isoLanguage! ! 174388 174389!LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 18:55'! 174390leadingChar 174391 ^self class leadingChar! ! 174392 174393!LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:31'! 174394localeID 174395 ^id! ! 174396 174397 174398!LanguageEnvironment methodsFor: 'fonts support' stamp: 'tak 8/5/2005 21:04'! 174399fontDownload 174400 "(Locale isoLanguage: 'ja') languageEnvironment fontDownload" 174401 | contents f | 174402 (FileDirectory default fileExists: self fontFullName) 174403 ifTrue: [^ self]. 174404 Cursor read 174405 showWhile: [self fontDownloadUrls 174406 do: [:each | [contents := (each , '/' , self fontFileName) asUrl retrieveContents contents. 174407 (contents first: 2) 174408 = 'PK' 174409 ifTrue: [f := FileStream newFileNamed: self fontFullName. 174410 f binary. 174411 [f nextPutAll: contents] 174412 ensure: [f close]. 174413 ^ self]] 174414 on: NameLookupFailure 174415 do: [:e | e]]]. 174416 self error: 'Fonts does not found (' , self fontFullName , ')'! ! 174417 174418!LanguageEnvironment methodsFor: 'fonts support' stamp: 'tak 8/5/2005 21:05'! 174419fontDownloadUrls 174420 ^ #('http://metatoys.org/pub/' )! ! 174421 174422!LanguageEnvironment methodsFor: 'fonts support' stamp: 'tak 8/5/2005 20:46'! 174423fontFileName 174424 "(Locale isoLanguage: 'ja') languageEnvironment fontFileName" 174425 ^ self fontEncodingName , '.sar'! ! 174426 174427!LanguageEnvironment methodsFor: 'fonts support' stamp: 'tak 8/7/2005 12:27'! 174428fontFullName 174429 "(Locale isoLanguage: 'ja') languageEnvironment fontFullName" 174430 | dir | 174431 dir := FileDirectory on: SecurityManager default untrustedUserDirectory. 174432 "dir exists is needed if it is in restricted mode" 174433 dir exists 174434 ifFalse: [dir assureExistence]. 174435 ^ dir fullNameFor: self fontFileName! ! 174436 174437!LanguageEnvironment methodsFor: 'fonts support' stamp: 'tak 8/5/2005 21:00'! 174438installFont 174439 "(Locale isoLanguage: 'ja') languageEnvironment installFont" 174440 self fontDownload. 174441 SARInstaller installSAR: self fontFullName! ! 174442 174443!LanguageEnvironment methodsFor: 'fonts support' stamp: 'adrian_lienhard 7/18/2009 15:28'! 174444isFontAvailable 174445 | encoding f | 174446 encoding := self leadingChar + 1. 174447 f := TextStyle defaultFont. 174448 f isFontSet ifTrue: [ 174449 f fontArray 174450 at: encoding 174451 ifAbsent: [^ false]. 174452 ^ true 174453 ]. 174454 ^ encoding = 1! ! 174455 174456!LanguageEnvironment methodsFor: 'fonts support' stamp: 'tak 8/4/2005 11:08'! 174457removeFonts 174458 "(Locale isoLanguage: 'ja') languageEnvironment removeFonts" 174459 StrikeFontSet removeFontsForEncoding: self leadingChar encodingName: self fontEncodingName! ! 174460 174461 174462!LanguageEnvironment methodsFor: 'initialization' stamp: 'mir 7/15/2004 15:31'! 174463localeID: anID 174464 id := anID! ! 174465 174466 174467!LanguageEnvironment methodsFor: 'utilities' stamp: 'mir 7/21/2004 18:05'! 174468checkPhrase: phrase translation: translation 174469 "check the translation. 174470 Answer a string with a comment or meaning no-comments" 174471 ^nil! ! 174472 174473!LanguageEnvironment methodsFor: 'utilities' stamp: 'tak 11/28/2005 17:28'! 174474setupSqueaklandSpecifics 174475 "Write language specific settings here"! ! 174476 174477"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 174478 174479LanguageEnvironment class 174480 instanceVariableNames: ''! 174481 174482!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! 174483canBeGlobalVarInitial: char 174484 174485 ^ Unicode canBeGlobalVarInitial: char. 174486! ! 174487 174488!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! 174489canBeNonGlobalVarInitial: char 174490 174491 ^ Unicode canBeNonGlobalVarInitial: char. 174492! ! 174493 174494!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 7/28/2004 21:34'! 174495currentPlatform 174496 174497 ^ Locale currentPlatform languageEnvironment. 174498! ! 174499 174500!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! 174501digitValue: char 174502 174503 ^ Unicode digitValue: char. 174504! ! 174505 174506!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 12/2/2004 16:13'! 174507isCharset 174508 174509 ^ false. 174510! ! 174511 174512!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! 174513isDigit: char 174514 174515 ^ Unicode isDigit: char. 174516! ! 174517 174518!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:25'! 174519isLetter: char 174520 174521 ^ Unicode isLetter: char. 174522! ! 174523 174524!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:25'! 174525isLowercase: char 174526 174527 ^ Unicode isLowercase: char. 174528! ! 174529 174530!LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:25'! 174531isUppercase: char 174532 174533 ^ Unicode isUppercase: char. 174534! ! 174535 174536!LanguageEnvironment class methodsFor: 'accessing' stamp: 'michael.rueger 3/15/2009 11:45'! 174537localeID: localeID 174538 self knownEnvironments at: localeID ifPresent: [:value | ^value]. 174539 ^self knownEnvironments 174540 at: (LocaleID isoLanguage: localeID isoLanguage) 174541 ifAbsent: [self localeID: (LocaleID isoLanguage: 'en')]! ! 174542 174543 174544!LanguageEnvironment class methodsFor: 'class initialization' stamp: 'mir 7/15/2004 16:13'! 174545localeChanged 174546 self startUp! ! 174547 174548!LanguageEnvironment class methodsFor: 'class initialization' stamp: 'yo 6/12/2008 15:08'! 174549localeChangedGently 174550 174551 self clearDefault. 174552 ActiveHand clearKeyboardInterpreter. 174553 self setUsePangoFlag. 174554! ! 174555 174556!LanguageEnvironment class methodsFor: 'class initialization' stamp: 'michael.rueger 3/2/2009 11:06'! 174557startUp 174558 174559 self clearDefault. 174560 self setUsePangoFlag. 174561! ! 174562 174563 174564!LanguageEnvironment class methodsFor: 'initialization' stamp: 'yo 3/15/2004 21:15'! 174565clearDefault 174566 174567 ClipboardInterpreterClass := nil. 174568 InputInterpreterClass := nil. 174569 SystemConverterClass := nil. 174570 FileNameConverterClass := nil. 174571! ! 174572 174573!LanguageEnvironment class methodsFor: 'initialization' stamp: 'mir 7/15/2004 15:54'! 174574initialize 174575 "LanguageEnvironment initialize" 174576 174577 Smalltalk addToStartUpList: LanguageEnvironment after: FileDirectory. 174578 Smalltalk addToStartUpList: FileDirectory after: LanguageEnvironment. 174579! ! 174580 174581!LanguageEnvironment class methodsFor: 'initialization' stamp: 'mir 7/21/2004 19:10'! 174582resetKnownEnvironments 174583 "LanguageEnvironment resetKnownEnvironments" 174584 174585 KnownEnvironments := nil! ! 174586 174587 174588!LanguageEnvironment class methodsFor: 'language methods' stamp: 'yo 1/18/2005 15:56'! 174589scanSelector 174590 174591 ^ #scanMultiCharactersFrom:to:in:rightX:stopConditions:kern: 174592! ! 174593 174594 174595!LanguageEnvironment class methodsFor: 'public query' stamp: 'yo 3/15/2004 15:50'! 174596defaultEncodingName 174597 174598 ^ 'mac-roman'. 174599! ! 174600 174601!LanguageEnvironment class methodsFor: 'public query' stamp: 'yo 7/28/2004 21:56'! 174602defaultFileNameConverter 174603 FileNameConverterClass 174604 ifNil: [FileNameConverterClass := self currentPlatform class fileNameConverterClass]. 174605 ^ FileNameConverterClass new! ! 174606 174607!LanguageEnvironment class methodsFor: 'public query' stamp: 'yo 7/28/2004 21:56'! 174608defaultSystemConverter 174609 174610 SystemConverterClass ifNil: [SystemConverterClass := self currentPlatform class systemConverterClass]. 174611 ^ SystemConverterClass new. 174612! ! 174613 174614 174615!LanguageEnvironment class methodsFor: 'rendering support' stamp: 'marcus.denker 8/15/2008 17:25'! 174616flapTabTextFor: aString 174617 174618 ^ aString. 174619 174620! ! 174621 174622!LanguageEnvironment class methodsFor: 'rendering support' stamp: 'marcus.denker 8/15/2008 17:26'! 174623flapTabTextFor: aString in: aFlapTab 174624 174625 ^ aString. 174626! ! 174627 174628!LanguageEnvironment class methodsFor: 'rendering support' stamp: 'yo 3/17/2004 21:54'! 174629isBreakableAt: index in: text 174630 174631 | char | 174632 char := text at: index. 174633 char = Character space ifTrue: [^ true]. 174634 char = Character cr ifTrue: [^ true]. 174635 ^ false. 174636! ! 174637 174638 174639!LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'michael.rueger 2/5/2009 17:23'! 174640fileNameConverterClass 174641 174642 ^UTF8TextConverter! ! 174643 174644!LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:11'! 174645leadingChar 174646 174647 self subclassResponsibility. 174648 ^ 0. 174649! ! 174650 174651!LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 17:59'! 174652supportedLanguages 174653 "Return the languages that this class supports. 174654 Any translations for those languages will use this class as their environment." 174655 self subclassResponsibility! ! 174656 174657!LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:10'! 174658systemConverterClass 174659 174660 self subclassResponsibility. 174661 ^ Latin1TextConverter. 174662! ! 174663 174664 174665!LanguageEnvironment class methodsFor: 'private' stamp: 'mir 7/28/2005 13:53'! 174666initKnownEnvironments 174667 "LanguageEnvironment initKnownEnvironments" 174668 174669 | env known id | 174670 known := Dictionary new. 174671 self allSubclassesDo: [:subClass | 174672 subClass supportedLanguages do: [:language | 174673 env := subClass new. 174674 id := LocaleID isoString: language. 174675 env localeID: id. 174676 known at: id put: env]]. 174677 ^known! ! 174678 174679!LanguageEnvironment class methodsFor: 'private' stamp: 'mir 7/15/2004 15:45'! 174680knownEnvironments 174681 "LanguageEnvironment knownEnvironments" 174682 "KnownEnvironments := nil" 174683 174684 ^KnownEnvironments ifNil: [KnownEnvironments := self initKnownEnvironments]! ! 174685 174686!LanguageEnvironment class methodsFor: 'private'! 174687setUsePangoFlag 174688 ^ self! ! 174689 174690!LanguageEnvironment class methodsFor: 'private' stamp: 'yo 8/27/2008 15:56'! 174691usePangoRenderer 174692 174693 | tr font phraseTest fontName | 174694 Preferences usePangoRenderer ifTrue: [^ true]. 174695 174696 "first, see if people specified font." 174697 tr := NaturalLanguageTranslator current. 174698 fontName := tr translate: 'Linux-Font'. 174699 (fontName ~= 'Linux-Font' 174700 and: [(StrikeFont familyNames includes: fontName asSymbol) not]) ifTrue: [^ true]. 174701 174702 font := TextStyle defaultFont. 174703 phraseTest := [:phrase | 174704 phrase do: [:c | 174705 (font hasGlyphWithFallbackOf: c) ifFalse: [^ true]]]. 174706 174707 "Hopefully people start translating phrases that are really used, but also people translate on the Pootle server which has a ideosyncratic ordering..." 174708 #('Rectangle' 'Text' 'forward by' 'turn by' 'color' 'choose new graphic' 'linear gradient' 'open as Flash' 'set custom action' 'show compressed size' 'more smoothing') do: [:ph | phraseTest value: (tr translate: ph)]. 174709 174710 "But it is not often the case; so a bit more testing..." 174711 10 timesRepeat: [ 174712 phraseTest value: tr atRandom]. 174713 174714 ^ false. 174715! ! 174716LargePositiveInteger variableByteSubclass: #LargeNegativeInteger 174717 instanceVariableNames: '' 174718 classVariableNames: '' 174719 poolDictionaries: '' 174720 category: 'Kernel-Numbers'! 174721!LargeNegativeInteger commentStamp: '<historical>' prior: 0! 174722Just like LargePositiveInteger, but represents a negative number.! 174723 174724 174725!LargeNegativeInteger methodsFor: 'arithmetic'! 174726abs 174727 ^ self negated! ! 174728 174729!LargeNegativeInteger methodsFor: 'arithmetic'! 174730negated 174731 ^ self copyto: (LargePositiveInteger new: self digitLength)! ! 174732 174733 174734!LargeNegativeInteger methodsFor: 'bit manipulation' stamp: 'nice 3/21/2008 01:02'! 174735bitAt: anInteger 174736 "super would not work because we have to pretend we are in two-complement. 174737 this has to be tricky..." 174738 174739 | digitIndex bitIndex i | 174740 digitIndex := anInteger - 1 // 8 + 1. 174741 digitIndex > self digitLength ifTrue: [^1]. 174742 bitIndex := anInteger - 1 \\ 8 + 1. 174743 174744 i := 1. 174745 [i = digitIndex 174746 ifTrue: 174747 ["evaluate two complement (bitInvert + 1) on the digit : 174748 (if digitIndex > 1, we must still add 1 due to the carry). 174749 but x bitInvert is -1-x, bitInvert+1 is just x negated..." 174750 ^(self digitAt: digitIndex) negated bitAt: bitIndex]. 174751 (self digitAt: i) = 0] 174752 whileTrue: [ 174753 "two complement (bitInvert + 1) raises a carry: 174754 0 bitInvert -> 2r11111111. 2r11111111 + 1 -> 0 with carry... 174755 Thus we must inquire one digit forward" 174756 i := i + 1]. 174757 174758 "We escaped the while loop, because there is no more carry. 174759 Do a simple bitInvert without a carry" 174760 ^1 - ((self digitAt: digitIndex) bitAt: bitIndex)! ! 174761 174762!LargeNegativeInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:10'! 174763highBit 174764 "Answer the index of the high order bit of the receiver, or zero if the 174765 receiver is zero. Raise an error if the receiver is negative, since 174766 negative integers are defined to have an infinite number of leading 1's 174767 in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to 174768 get the highest bit of the magnitude." 174769 174770 ^ self shouldNotImplement! ! 174771 174772 174773!LargeNegativeInteger methodsFor: 'converting' stamp: 'ar 5/17/2000 16:10'! 174774normalize 174775 "Check for leading zeroes and return shortened copy if so" 174776 | sLen val len oldLen minVal | 174777 <primitive: 'primNormalizeNegative' module:'LargeIntegers'> 174778 "First establish len = significant length" 174779 len := oldLen := self digitLength. 174780 [len = 0 ifTrue: [^0]. 174781 (self digitAt: len) = 0] 174782 whileTrue: [len := len - 1]. 174783 174784 "Now check if in SmallInteger range" 174785 sLen := 4 "SmallInteger minVal digitLength". 174786 len <= sLen ifTrue: 174787 [minVal := SmallInteger minVal. 174788 (len < sLen 174789 or: [(self digitAt: sLen) < minVal lastDigit]) 174790 ifTrue: ["If high digit less, then can be small" 174791 val := 0. 174792 len to: 1 by: -1 do: 174793 [:i | val := (val *256) - (self digitAt: i)]. 174794 ^ val]. 174795 1 to: sLen do: "If all digits same, then = minVal" 174796 [:i | (self digitAt: i) = (minVal digitAt: i) 174797 ifFalse: ["Not so; return self shortened" 174798 len < oldLen 174799 ifTrue: [^ self growto: len] 174800 ifFalse: [^ self]]]. 174801 ^ minVal]. 174802 174803 "Return self, or a shortened copy" 174804 len < oldLen 174805 ifTrue: [^ self growto: len] 174806 ifFalse: [^ self]! ! 174807 174808 174809!LargeNegativeInteger methodsFor: 'printing' stamp: 'nice 2/15/2008 21:47'! 174810printOn: aStream base: b 174811 "Append a representation of this number in base b on aStream." 174812 174813 aStream nextPut: $-. 174814 self abs printOn: aStream base: b! ! 174815 174816 174817!LargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'! 174818negative 174819 "Answer whether the receiver is mathematically negative." 174820 174821 ^ true! ! 174822 174823!LargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:00'! 174824positive 174825 "Answer whether the receiver is positive or equal to 0. (ST-80 protocol). 174826 See also strictlyPositive" 174827 174828 ^ false! ! 174829 174830!LargeNegativeInteger methodsFor: 'testing' stamp: 'jm 3/27/98 06:19'! 174831sign 174832 "Optimization. Answer -1 since receiver is less than 0." 174833 174834 ^ -1 174835! ! 174836 174837!LargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:03'! 174838strictlyPositive 174839 "Answer whether the receiver is mathematically positive." 174840 174841 ^ false! ! 174842 174843"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 174844 174845LargeNegativeInteger class 174846 instanceVariableNames: ''! 174847 174848!LargeNegativeInteger class methodsFor: 'as yet unclassified' stamp: 'sw 5/8/2000 12:05'! 174849initializedInstance 174850 ^ -9876543210987654321 copy! ! 174851ClassTestCase subclass: #LargeNegativeIntegerTest 174852 instanceVariableNames: '' 174853 classVariableNames: '' 174854 poolDictionaries: '' 174855 category: 'KernelTests-Numbers'! 174856 174857!LargeNegativeIntegerTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:36'! 174858testEmptyTemplate 174859 "Check that an uninitialized instance behaves reasonably." 174860 174861 | i | 174862 i := LargeNegativeInteger new: 4. 174863 self assert: i size == 4. 174864 self assert: i printString = '-0'. 174865 self assert: i normalize == 0! ! 174866Integer variableByteSubclass: #LargePositiveInteger 174867 instanceVariableNames: '' 174868 classVariableNames: '' 174869 poolDictionaries: '' 174870 category: 'Kernel-Numbers'! 174871!LargePositiveInteger commentStamp: '<historical>' prior: 0! 174872I represent positive integers of more than 30 bits (ie, >= 1073741824). These values are beyond the range of SmallInteger, and are encoded here as an array of 8-bit digits. Care must be taken, when new values are computed, that any result that COULD BE a SmallInteger IS a SmallInteger (see normalize). 174873 174874Note that the bit manipulation primitives, bitAnd:, bitShift:, etc., = and ~= run without failure (and therefore fast) if the value fits in 32 bits. This is a great help to the simulator.! 174875 174876 174877!LargePositiveInteger methodsFor: 'arithmetic'! 174878* anInteger 174879 "Primitive. Multiply the receiver by the argument and answer with an 174880 Integer result. Fail if either the argument or the result is not a 174881 SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See 174882 Object documentation whatIsAPrimitive. " 174883 174884 <primitive: 29> 174885 ^super * anInteger! ! 174886 174887!LargePositiveInteger methodsFor: 'arithmetic'! 174888+ anInteger 174889 "Primitive. Add the receiver to the argument and answer with an 174890 Integer result. Fail if either the argument or the result is not a 174891 SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See 174892 Object documentation whatIsAPrimitive." 174893 174894 <primitive: 21> 174895 ^super + anInteger! ! 174896 174897!LargePositiveInteger methodsFor: 'arithmetic'! 174898- anInteger 174899 "Primitive. Subtract the argument from the receiver and answer with an 174900 Integer result. Fail if either the argument or the result is not a 174901 SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See 174902 Object documentation whatIsAPrimitive." 174903 174904 <primitive: 22> 174905 ^super - anInteger! ! 174906 174907!LargePositiveInteger methodsFor: 'arithmetic'! 174908/ anInteger 174909 "Primitive. Divide the receiver by the argument and answer with the 174910 result if the division is exact. Fail if the result is not a whole integer. 174911 Fail if the argument is 0. Fail if either the argument or the result is not 174912 a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See 174913 Object documentation whatIsAPrimitive. " 174914 174915 <primitive: 30> 174916 ^super / anInteger! ! 174917 174918!LargePositiveInteger methodsFor: 'arithmetic'! 174919// anInteger 174920 "Primitive. Divide the receiver by the argument and return the result. 174921 Round the result down towards negative infinity to make it a whole 174922 integer. Fail if the argument is 0. Fail if either the argument or the 174923 result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). 174924 Optional. See Object documentation whatIsAPrimitive. " 174925 174926 <primitive: 32> 174927 ^super // anInteger! ! 174928 174929!LargePositiveInteger methodsFor: 'arithmetic'! 174930\\ anInteger 174931 "Primitive. Take the receiver modulo the argument. The result is the 174932 remainder rounded towards negative infinity, of the receiver divided 174933 by the argument. Fail if the argument is 0. Fail if either the argument 174934 or the result is not a SmallInteger or a LargePositiveInteger less than 174935 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." 174936 174937 <primitive: 31> 174938 ^super \\ anInteger! ! 174939 174940!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'RAA 5/31/2000 13:21'! 174941\\\ anInteger 174942 "a faster modulo method for use in DSA. Be careful if you try to use this elsewhere" 174943 174944 ^(self digitDiv: anInteger neg: false) second! ! 174945 174946!LargePositiveInteger methodsFor: 'arithmetic'! 174947abs! ! 174948 174949!LargePositiveInteger methodsFor: 'arithmetic'! 174950negated 174951 ^ (self copyto: (LargeNegativeInteger new: self digitLength)) 174952 normalize "Need to normalize to catch SmallInteger minVal"! ! 174953 174954!LargePositiveInteger methodsFor: 'arithmetic'! 174955quo: anInteger 174956 "Primitive. Divide the receiver by the argument and return the result. 174957 Round the result down towards zero to make it a whole integer. Fail if 174958 the argument is 0. Fail if either the argument or the result is not a 174959 SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See 174960 Object documentation whatIsAPrimitive." 174961 174962 <primitive: 33> 174963 ^super quo: anInteger! ! 174964 174965 174966!LargePositiveInteger methodsFor: 'bit manipulation'! 174967bitAnd: anInteger 174968 "Primitive. Answer an Integer whose bits are the logical AND of the 174969 receiver's bits and those of the argument. Fail if the receiver or argument 174970 is greater than 32 bits. See Object documentation whatIsAPrimitive." 174971 <primitive: 14> 174972 ^ super bitAnd: anInteger! ! 174973 174974!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'nice 3/21/2008 00:09'! 174975bitAt: anInteger 174976 "Optimize super algorithm to avoid long bit operations. 174977 Instead work on digits which are known to be SmallInteger and fast. 174978 Note that this algorithm does not work for negative integers." 174979 174980 | digitIndex bitIndex | 174981 digitIndex := anInteger - 1 // 8 + 1. 174982 digitIndex > self digitLength ifTrue: [^0]. 174983 bitIndex := anInteger - 1 \\ 8 + 1. 174984 ^(self digitAt: digitIndex) bitAt: bitIndex! ! 174985 174986!LargePositiveInteger methodsFor: 'bit manipulation'! 174987bitOr: anInteger 174988 "Primitive. Answer an Integer whose bits are the logical OR of the 174989 receiver's bits and those of the argument. Fail if the receiver or argument 174990 is greater than 32 bits. See Object documentation whatIsAPrimitive." 174991 <primitive: 15> 174992 ^ super bitOr: anInteger! ! 174993 174994!LargePositiveInteger methodsFor: 'bit manipulation'! 174995bitShift: anInteger 174996 "Primitive. Answer an Integer whose value (in twos-complement 174997 representation) is the receiver's value (in twos-complement 174998 representation) shifted left by the number of bits indicated by the 174999 argument. Negative arguments shift right. Zeros are shifted in from the 175000 right in left shifts. The sign bit is extended in right shifts. 175001 Fail if the receiver or result is greater than 32 bits. 175002 See Object documentation whatIsAPrimitive." 175003 <primitive: 17> 175004 ^super bitShift: anInteger! ! 175005 175006!LargePositiveInteger methodsFor: 'bit manipulation'! 175007bitXor: anInteger 175008 "Primitive. Answer an Integer whose bits are the logical XOR of the 175009 receiver's bits and those of the argument. Fail if the receiver or argument 175010 is greater than 32 bits. See Object documentation whatIsAPrimitive." 175011 <primitive: 16> 175012 ^ super bitXor: anInteger! ! 175013 175014!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'SqR 9/18/2000 15:17'! 175015hashMultiply 175016 "Truncate to 28 bits and try again" 175017 175018 ^(self bitAnd: 16rFFFFFFF) hashMultiply! ! 175019 175020!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:11'! 175021highBit 175022 "Answer the index of the high order bit of the receiver, or zero if the 175023 receiver is zero. Raise an error if the receiver is negative, since 175024 negative integers are defined to have an infinite number of leading 1's 175025 in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to 175026 get the highest bit of the magnitude." 175027 ^ self highBitOfMagnitude! ! 175028 175029!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:15'! 175030highBitOfMagnitude 175031 "Answer the index of the high order bit of the magnitude of the 175032 receiver, or zero if the receiver is zero. 175033 This method is used for LargeNegativeIntegers as well, 175034 since Squeak's LargeIntegers are sign/magnitude." 175035 | realLength lastDigit | 175036 realLength := self digitLength. 175037 [(lastDigit := self digitAt: realLength) = 0] 175038 whileTrue: [(realLength := realLength - 1) = 0 ifTrue: [^ 0]]. 175039 ^ lastDigit highBitOfPositiveReceiver + (8 * (realLength - 1))! ! 175040 175041 175042!LargePositiveInteger methodsFor: 'comparing'! 175043< anInteger 175044 "Primitive. Compare the receiver with the argument and answer true if 175045 the receiver is less than the argument. Otherwise answer false. Fail if the 175046 argument is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). 175047 Optional. See Object documentation whatIsAPrimitive." 175048 175049 <primitive: 23> 175050 ^super < anInteger! ! 175051 175052!LargePositiveInteger methodsFor: 'comparing'! 175053<= anInteger 175054 "Primitive. Compare the receiver with the argument and answer true if 175055 the receiver is less than or equal to the argument. Otherwise answer false. 175056 Fail if the argument is not a SmallInteger or a LargePositiveInteger less 175057 than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." 175058 175059 <primitive: 25> 175060 ^super <= anInteger! ! 175061 175062!LargePositiveInteger methodsFor: 'comparing'! 175063= anInteger 175064 "Primitive. Compare the receiver with the argument and answer true if 175065 the receiver is equal to the argument. Otherwise answer false. Fail if the 175066 receiver or argument is negative or greater than 32 bits. 175067 Optional. See Object documentation whatIsAPrimitive." 175068 175069 <primitive: 7> 175070 ^ super = anInteger! ! 175071 175072!LargePositiveInteger methodsFor: 'comparing'! 175073> anInteger 175074 "Primitive. Compare the receiver with the argument and answer true if 175075 the receiver is greater than the argument. Otherwise answer false. Fail if 175076 the argument is not a SmallInteger or a LargePositiveInteger less than 175077 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." 175078 175079 <primitive: 24> 175080 ^super > anInteger! ! 175081 175082!LargePositiveInteger methodsFor: 'comparing'! 175083>= anInteger 175084 "Primitive. Compare the receiver with the argument and answer true if 175085 the receiver is greater than or equal to the argument. Otherwise answer 175086 false. Fail if the argument is not a SmallInteger or a LargePositiveInteger 175087 less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." 175088 175089 <primitive: 26> 175090 ^super >= anInteger! ! 175091 175092!LargePositiveInteger methodsFor: 'comparing' stamp: 'SqR 8/13/2002 10:52'! 175093hash 175094 175095 ^ByteArray 175096 hashBytes: self 175097 startingWith: self species hash! ! 175098 175099!LargePositiveInteger methodsFor: 'comparing'! 175100~= anInteger 175101 "Primitive. Compare the receiver with the argument and answer true if 175102 the receiver is equal to the argument. Otherwise answer false. Fail if the 175103 receiver or argument is negative or greater than 32 bits. 175104 Optional. See Object documentation whatIsAPrimitive." 175105 175106 <primitive: 8> 175107 ^ super ~= anInteger! ! 175108 175109 175110!LargePositiveInteger methodsFor: 'converting' stamp: 'ajh 7/25/2001 22:28'! 175111as31BitSmallInt 175112 "This is only for 31 bit numbers. Keep my 31 bits the same, but put them in a small int. The small int will be negative since my 31st bit is 1. We know my 31st bit is 1 because otherwise I would already be a positive small int." 175113 175114 self highBit = 31 ifFalse: [self error: 'more than 31 bits can not fit in a SmallInteger']. 175115 175116 ^ self - 16r80000000! ! 175117 175118!LargePositiveInteger methodsFor: 'converting' stamp: 'ar 5/17/2000 16:09'! 175119normalize 175120 "Check for leading zeroes and return shortened copy if so" 175121 | sLen val len oldLen | 175122 <primitive: 'primNormalizePositive' module:'LargeIntegers'> 175123 "First establish len = significant length" 175124 len := oldLen := self digitLength. 175125 [len = 0 ifTrue: [^0]. 175126 (self digitAt: len) = 0] 175127 whileTrue: [len := len - 1]. 175128 175129 "Now check if in SmallInteger range" 175130 sLen := SmallInteger maxVal digitLength. 175131 (len <= sLen 175132 and: [(self digitAt: sLen) <= (SmallInteger maxVal digitAt: sLen)]) 175133 ifTrue: ["If so, return its SmallInt value" 175134 val := 0. 175135 len to: 1 by: -1 do: 175136 [:i | val := (val *256) + (self digitAt: i)]. 175137 ^ val]. 175138 175139 "Return self, or a shortened copy" 175140 len < oldLen 175141 ifTrue: [^ self growto: len] 175142 ifFalse: [^ self]! ! 175143 175144!LargePositiveInteger methodsFor: 'converting' stamp: 'RAA 3/2/2002 14:32'! 175145withAtLeastNDigits: desiredLength 175146 175147 | new | 175148 175149 self size >= desiredLength ifTrue: [^self]. 175150 new := self class new: desiredLength. 175151 new 175152 replaceFrom: 1 175153 to: self size 175154 with: self 175155 startingAt: 1. 175156 ^new! ! 175157 175158 175159!LargePositiveInteger methodsFor: 'printing' stamp: 'nice 7/22/2008 00:13'! 175160printOn: aStream base: b 175161 "Append a representation of this number in base b on aStream. 175162 In order to reduce cost of LargePositiveInteger ops, split the number in approximately two equal parts in number of digits." 175163 175164 | halfDigits halfPower head tail nDigitsUnderestimate | 175165 "Don't engage any arithmetic if not normalized" 175166 (self digitLength = 0 or: [(self digitAt: self digitLength) = 0]) ifTrue: [^self normalize printOn: aStream base: b]. 175167 175168 nDigitsUnderestimate := b = 10 175169 ifTrue: [((self highBit - 1) * 3 quo: 10) + 1 "because 1024 is almost a kilo"] 175170 ifFalse: [self highBit quo: b highBit]. 175171 175172 "splitting digits with a whole power of two is more efficient" 175173 halfDigits := 1 bitShift: nDigitsUnderestimate highBit - 2. 175174 175175 halfDigits <= 1 175176 ifTrue: ["Hmmm, this could happen only in case of a huge base b... Let lower level fail" 175177 ^self printOn: aStream base: b nDigits: (self numberOfDigitsInBase: b)]. 175178 175179 "Separate in two halves, head and tail" 175180 halfPower := b raisedToInteger: halfDigits. 175181 head := self quo: halfPower. 175182 tail := self - (head * halfPower). 175183 175184 "print head" 175185 head printOn: aStream base: b. 175186 175187 "print tail without the overhead to count the digits" 175188 tail printOn: aStream base: b nDigits: halfDigits! ! 175189 175190!LargePositiveInteger methodsFor: 'printing' stamp: 'nice 7/5/2008 23:23'! 175191printOn: aStream base: b nDigits: n 175192 "Append a representation of this number in base b on aStream using n digits. 175193 In order to reduce cost of LargePositiveInteger ops, split the number of digts approximatily in two 175194 Should be invoked with: 0 <= self < (b raisedToInteger: n)" 175195 175196 | halfPower half head tail | 175197 n <= 1 ifTrue: [ 175198 n <= 0 ifTrue: [self error: 'Number of digits n should be > 0']. 175199 175200 "Note: this is to stop an infinite loop if one ever attempts to print with a huge base 175201 This can happen because choice was to not hardcode any limit for base b 175202 We let Character>>#digitValue: fail" 175203 ^Character digitValue: self]. 175204 halfPower := n bitShift: -1. 175205 half := b raisedToInteger: halfPower. 175206 head := self quo: half. 175207 tail := self - (head * half). 175208 head printOn: aStream base: b nDigits: n - halfPower. 175209 tail printOn: aStream base: b nDigits: halfPower! ! 175210 175211!LargePositiveInteger methodsFor: 'printing' stamp: 'nice 7/6/2008 00:34'! 175212printStringBase: base 175213 "For LargeIntegers, it's faster to use the stream version. 175214 This reproduces Number implementation to avoid speed down if one defines Integer>>#printStringBase: 175215 This method should be removed if Integer>>#printStringBase: is removed. 175216 Note: tests preallocating stream space with exact numberOfDigitsInBase: did not gain speed" 175217 175218 ^String streamContents: [:str | self printOn: str base: base]! ! 175219 175220 175221!LargePositiveInteger methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:28'! 175222digitAt: index 175223 "Primitive. Answer the value of an indexable field in the receiver. LargePositiveInteger uses bytes of base two number, and each is a 'digit' base 256. Fail if the argument (the index) is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." 175224 175225 <primitive: 60> 175226 self digitLength < index 175227 ifTrue: [^0] 175228 ifFalse: [^super at: index]! ! 175229 175230!LargePositiveInteger methodsFor: 'system primitives'! 175231digitAt: index put: value 175232 "Primitive. Store the second argument (value) in the indexable field of 175233 the receiver indicated by index. Fail if the value is negative or is larger 175234 than 255. Fail if the index is not an Integer or is out of bounds. Answer 175235 the value that was stored. Essential. See Object documentation 175236 whatIsAPrimitive." 175237 175238 <primitive: 61> 175239 ^super at: index put: value! ! 175240 175241!LargePositiveInteger methodsFor: 'system primitives'! 175242digitLength 175243 "Primitive. Answer the number of indexable fields in the receiver. This 175244 value is the same as the largest legal subscript. Essential. See Object 175245 documentation whatIsAPrimitive." 175246 175247 <primitive: 62> 175248 self primitiveFailed! ! 175249 175250!LargePositiveInteger methodsFor: 'system primitives'! 175251replaceFrom: start to: stop with: replacement startingAt: repStart 175252 "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." 175253 <primitive: 105> 175254 ^ super replaceFrom: start to: stop with: replacement startingAt: repStart! ! 175255 175256 175257!LargePositiveInteger methodsFor: 'testing' stamp: 'nice 8/31/2008 00:07'! 175258isLarge 175259 ^true! ! 175260 175261!LargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'! 175262negative 175263 "Answer whether the receiver is mathematically negative." 175264 175265 ^ false! ! 175266 175267!LargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:00'! 175268positive 175269 "Answer whether the receiver is positive or equal to 0. (ST-80 protocol). 175270 See also strictlyPositive" 175271 175272 ^ true! ! 175273 175274!LargePositiveInteger methodsFor: 'testing' stamp: 'jm 3/27/98 06:19'! 175275sign 175276 "Optimization. Answer 1 since receiver is greater than 0." 175277 175278 ^ 1 175279! ! 175280 175281!LargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:02'! 175282strictlyPositive 175283 "Answer whether the receiver is mathematically positive." 175284 175285 ^ true! ! 175286 175287"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 175288 175289LargePositiveInteger class 175290 instanceVariableNames: ''! 175291 175292!LargePositiveInteger class methodsFor: 'testing' stamp: 'sw 5/8/2000 12:05'! 175293initializedInstance 175294 ^ 12345678901234567 copy! ! 175295ClassTestCase subclass: #LargePositiveIntegerTest 175296 instanceVariableNames: '' 175297 classVariableNames: '' 175298 poolDictionaries: '' 175299 category: 'KernelTests-Numbers'! 175300 175301!LargePositiveIntegerTest methodsFor: 'tests' stamp: 'md 3/17/2003 15:20'! 175302testBitShift 175303 175304 "Check bitShift from and back to SmallInts" 175305 175306 1 to: 257 do: [:i | self should: [((i bitShift: i) bitShift: 0-i) == i]].! ! 175307 175308!LargePositiveIntegerTest methodsFor: 'tests' stamp: 'dtl 5/26/2004 18:33'! 175309testEmptyTemplate 175310 175311 "Check that an uninitialized instance behaves reasonably." 175312 175313 | i | 175314 i := LargePositiveInteger new: 4. 175315 self assert: i size == 4. 175316 self assert: i printString = '0'. 175317 self assert: i normalize == 0! ! 175318 175319!LargePositiveIntegerTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:52'! 175320testMultDicAddSub 175321 "self run: #testMultDicAddSub" 175322 175323 | n f f1 | 175324 n := 100. 175325 f := 100 factorial. 175326 f1 := f*(n+1). 175327 n timesRepeat: [f1 := f1 - f]. 175328 self assert: (f1 = f). 175329 175330 n timesRepeat: [f1 := f1 + f]. 175331 self assert: (f1 // f = (n+1)). 175332 self assert: (f1 negated = (Number readFrom: '-' , f1 printString)).! ! 175333 175334!LargePositiveIntegerTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:53'! 175335testNormalize 175336 "self run: #testNormalize" 175337 "Check normalization and conversion to/from SmallInts" 175338 175339 self assert: ((SmallInteger maxVal + 1 - 1) == SmallInteger maxVal). 175340 self assert: (SmallInteger maxVal + 3 - 6) == (SmallInteger maxVal-3). 175341 self should: ((SmallInteger minVal - 1 + 1) == SmallInteger minVal). 175342 self assert: (SmallInteger minVal - 3 + 6) == (SmallInteger minVal+3).! ! 175343EncodedCharSet subclass: #Latin1 175344 instanceVariableNames: '' 175345 classVariableNames: '' 175346 poolDictionaries: '' 175347 category: 'Multilingual-Encodings'! 175348!Latin1 commentStamp: 'yo 10/19/2004 19:53' prior: 0! 175349This class represents the domestic character encoding called ISO-8859-1, also known as Latin-1 used for Most of the Western European Languages.! 175350 175351 175352"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 175353 175354Latin1 class 175355 instanceVariableNames: 'rightHalfSequence'! 175356 175357!Latin1 class methodsFor: 'accessing - displaying' stamp: 'yo 8/18/2003 17:32'! 175358isBreakableAt: index in: text 175359 175360 | char | 175361 char := text at: index. 175362 char = Character space ifTrue: [^ true]. 175363 char = Character cr ifTrue: [^ true]. 175364 ^ false. 175365! ! 175366 175367!Latin1 class methodsFor: 'accessing - displaying' stamp: 'yo 8/18/2003 17:32'! 175368printingDirection 175369 175370 ^ #right. 175371! ! 175372 175373 175374!Latin1 class methodsFor: 'character classification' stamp: 'yo 8/28/2004 10:41'! 175375isLetter: char 175376 "Answer whether the receiver is a letter." 175377 175378 ^ Unicode isLetter: char. 175379 175380! ! 175381 175382 175383!Latin1 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! 175384emitSequenceToResetStateIfNeededOn: aStream forState: state 175385 state g0Leading ~= 0 ifTrue: 175386 [ state charSize: 1. 175387 state g0Leading: 0. 175388 state g0Size: 1. 175389 aStream basicNextPutAll: compoundTextSequence ] 175390 175391 "Actually, G1 state should go back to ISO-8859-1, too."! ! 175392 175393!Latin1 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! 175394initialize 175395 " 175396 self initialize 175397" 175398 compoundTextSequence := String streamContents: 175399 [ :s | 175400 s nextPut: (Character value: 27). 175401 s nextPut: $(. 175402 s nextPut: $B ]. 175403 rightHalfSequence := String streamContents: 175404 [ :s | 175405 s nextPut: (Character value: 27). 175406 s nextPut: $-. 175407 s nextPut: $A ]! ! 175408 175409!Latin1 class methodsFor: 'class methods' stamp: 'yo 8/18/2003 17:32'! 175410leadingChar 175411 175412 ^ 0. 175413! ! 175414 175415!Latin1 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! 175416nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state 175417 (ascii <= 127 and: [ state g0Leading ~= 0 ]) ifTrue: 175418 [ state charSize: 1. 175419 state g0Leading: 0. 175420 state g0Size: 1. 175421 aStream basicNextPutAll: compoundTextSequence. 175422 aStream basicNextPut: (Character value: ascii). 175423 ^ self ]. 175424 ((128 <= ascii and: [ ascii <= 255 ]) and: [ state g1Leading ~= 0 ]) ifTrue: 175425 [ ^ self 175426 nextPutRightHalfValue: ascii 175427 toStream: aStream 175428 withShiftSequenceIfNeededForTextConverterState: state ]. 175429 aStream basicNextPut: (Character value: ascii). 175430 ^ self! ! 175431 175432 175433!Latin1 class methodsFor: 'private' stamp: 'Alexandre.Bergel 11/20/2008 11:10'! 175434nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state 175435 state charSize: 1. 175436 state g1Leading: 0. 175437 state g1Size: 1. 175438 aStream basicNextPutAll: rightHalfSequence. 175439 aStream basicNextPut: (Character value: ascii)! ! 175440LanguageEnvironment subclass: #Latin1Environment 175441 instanceVariableNames: '' 175442 classVariableNames: '' 175443 poolDictionaries: '' 175444 category: 'Multilingual-Languages'! 175445!Latin1Environment commentStamp: '<historical>' prior: 0! 175446This class provides the support for the languages in 'Latin-1' category. Although we could have different language environments for different languages in the category, so far nobody seriously needed it. 175447! 175448 175449 175450"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 175451 175452Latin1Environment class 175453 instanceVariableNames: ''! 175454 175455!Latin1Environment class methodsFor: 'language methods' stamp: 'yo 1/24/2005 10:00'! 175456nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state 175457 175458 ^ self traditionalCharsetClass nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state. 175459! ! 175460 175461!Latin1Environment class methodsFor: 'language methods' stamp: 'yo 1/24/2005 10:00'! 175462nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state 175463 175464 ^ self traditionalCharsetClass nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state.! ! 175465 175466!Latin1Environment class methodsFor: 'language methods' stamp: 'yo 1/24/2005 09:59'! 175467traditionalCharsetClass 175468 175469 ^ Latin1. 175470! ! 175471 175472 175473!Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'nk 7/30/2004 21:39'! 175474defaultEncodingName 175475 | platformName osVersion | 175476 platformName := SmalltalkImage current platformName. 175477 osVersion := SmalltalkImage current getSystemAttribute: 1002. 175478 (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8' copy]. 175479 (#('Win32' 'Mac OS' 'ZaurusOS') includes: platformName) 175480 ifTrue: [^'iso8859-1' copy]. 175481 (#('unix') includes: platformName) ifTrue: [^'iso8859-1' copy]. 175482 ^'mac-roman'! ! 175483 175484!Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:07'! 175485leadingChar 175486 175487 ^ 0. 175488! ! 175489 175490!Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 2/24/2005 20:41'! 175491supportedLanguages 175492 "Return the languages that this class supports. 175493 Any translations for those languages will use this class as their environment." 175494 175495 ^#('fr' 'es' 'ca' 'eu' 'pt' 'it' 'sq' 'rm' 'nl' 'de' 'da' 'sv' 'no' 'fi' 'fo' 'is' 'ga' 'gd' 'en' 'af' 'sw')! ! 175496 175497!Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:07'! 175498systemConverterClass 175499 175500 ^ Latin1TextConverter. 175501! ! 175502ByteTextConverter subclass: #Latin1TextConverter 175503 instanceVariableNames: '' 175504 classVariableNames: '' 175505 poolDictionaries: '' 175506 category: 'Multilingual-TextConversion'! 175507!Latin1TextConverter commentStamp: '<historical>' prior: 0! 175508Text converter for ISO 8859-1. An international encoding used in Western Europe.! 175509 175510 175511!Latin1TextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:20'! 175512byteToUnicode: char 175513 175514 ^char! ! 175515 175516!Latin1TextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:20'! 175517unicodeToByte: unicodeChar 175518 175519 ^unicodeChar charCode < 256 175520 ifTrue: [unicodeChar] 175521 ifFalse: [0 asCharacter]! ! 175522 175523"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 175524 175525Latin1TextConverter class 175526 instanceVariableNames: ''! 175527 175528!Latin1TextConverter class methodsFor: 'accessing' stamp: 'yo 12/28/2003 01:15'! 175529encodingNames 175530 175531 ^ #('latin-1' 'latin1') copy. 175532! ! 175533 175534!Latin1TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 19:31'! 175535languageEnvironment 175536 ^Latin1Environment! ! 175537 175538 175539!Latin1TextConverter class methodsFor: 'class initialization' stamp: 'michael.rueger 2/2/2009 19:31'! 175540initializeTables 175541 "noop for Latin1"! ! 175542LanguageEnvironment subclass: #Latin2Environment 175543 instanceVariableNames: '' 175544 classVariableNames: '' 175545 poolDictionaries: '' 175546 category: 'Multilingual-Languages'! 175547!Latin2Environment commentStamp: '<historical>' prior: 0! 175548This class provides the support for the languages in 'Latin-2' category. Although we could have different language environments for different languages in the category, so far nobody seriously needed it. 175549 175550 I (Yoshiki) don't have good knowledge in these language, so when Pavel Krivanek volunteered to implement the detail, it was a good test to see how flexible my m17n framework was. There are a few glitches, but with several email conversations over a few days, we managed to make it work relatively painlessly. I thought this went well. 175551 175552 There seem that some source of headache, as Windows doesn't exactly use Latin-2 encoded characters, but a little modified version called 'code page 1250'. Similar to Japanese support, the encode interpreters are swapped based on the type of platform it is running on. 175553 175554! 175555 175556 175557"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 175558 175559Latin2Environment class 175560 instanceVariableNames: ''! 175561 175562!Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'pk 1/19/2005 15:05'! 175563defaultEncodingName 175564 | platformName osVersion | 175565 platformName := SmalltalkImage current platformName. 175566 osVersion := SmalltalkImage current getSystemAttribute: 1002. 175567 (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8' copy]. 175568 (#('Win32') includes: platformName) 175569 ifTrue: [^'cp-1250' copy]. 175570 (#('unix') includes: platformName) ifTrue: [^'iso8859-2' copy]. 175571 ^'mac-roman'! ! 175572 175573!Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 1/18/2005 15:53'! 175574leadingChar 175575 175576 ^ 14. 175577! ! 175578 175579!Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 1/19/2005 09:16'! 175580supportedLanguages 175581 "Return the languages that this class supports. 175582 Any translations for those languages will use this class as their environment." 175583 175584 ^#('cs' 'hu' 'ro' 'hr' 'sk' 'sl') "Sorbian languages don't have two char code?" 175585! ! 175586 175587!Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'pk 1/19/2005 15:04'! 175588systemConverterClass 175589 175590 (#('Win32') includes: SmalltalkImage current platformName) 175591 ifTrue: [^CP1250TextConverter ]. 175592 175593 ^ ISO88592TextConverter. 175594! ! 175595Object subclass: #LayoutCell 175596 instanceVariableNames: 'target cellSize extraSpace flags nextCell' 175597 classVariableNames: '' 175598 poolDictionaries: '' 175599 category: 'Morphic-Layouts'! 175600!LayoutCell commentStamp: '<historical>' prior: 0! 175601I am used in table layouts to hold temporary values while the layout is being computed. 175602 175603Instance variables: 175604 target <Morph> The morph contained in this cell 175605 cellSize <Point> The size of the cell 175606 extraSpace <nil | Point> Additional space to add after this cell 175607 nextCell <nil | LayoutCell> The next cell in the arrangement. 175608 175609Implementation note: 175610Both, cellSize and extraSpace contains points where 175611 x - represents the primary table direction 175612 y - represents the secondary table direction 175613! 175614 175615 175616!LayoutCell methodsFor: 'accessing' stamp: 'ar 11/2/2000 17:15'! 175617addExtraSpace: aPoint 175618 extraSpace 175619 ifNil:[extraSpace := aPoint] 175620 ifNotNil:[extraSpace := extraSpace + aPoint]! ! 175621 175622!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'! 175623cellSize 175624 ^cellSize! ! 175625 175626!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'! 175627cellSize: aPoint 175628 cellSize := aPoint! ! 175629 175630!LayoutCell methodsFor: 'accessing' stamp: 'ar 11/10/2000 17:09'! 175631extraSpace 175632 ^extraSpace ifNil:[0@0]! ! 175633 175634!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 21:30'! 175635extraSpace: aPoint 175636 extraSpace := aPoint! ! 175637 175638!LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:47'! 175639flags 175640 ^flags ifNil: [ 0 ]! ! 175641 175642!LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:48'! 175643hSpaceFill 175644 ^self flags anyMask: 1! ! 175645 175646!LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:48'! 175647hSpaceFill: aBool 175648 flags := aBool ifTrue:[self flags bitOr: 1] ifFalse:[self flags bitClear: 1]. 175649! ! 175650 175651!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'! 175652nextCell 175653 ^nextCell! ! 175654 175655!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'! 175656nextCell: aCell 175657 nextCell := aCell! ! 175658 175659!LayoutCell methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:09'! 175660size 175661 | n cell | 175662 n := 0. 175663 cell := self. 175664 [cell isNil] whileFalse: 175665 [n := n + 1. 175666 cell := cell nextCell]. 175667 ^n! ! 175668 175669!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:11'! 175670target 175671 ^target! ! 175672 175673!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'! 175674target: newTarget 175675 target := newTarget! ! 175676 175677!LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:47'! 175678vSpaceFill 175679 ^self flags anyMask: 2! ! 175680 175681!LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:48'! 175682vSpaceFill: aBool 175683 flags := aBool ifTrue:[self flags bitOr: 2] ifFalse:[self flags bitClear: 2]. 175684! ! 175685 175686 175687!LayoutCell methodsFor: 'collection' stamp: 'ar 10/28/2000 18:58'! 175688do: aBlock 175689 aBlock value: self. 175690 nextCell ifNotNil:[nextCell do: aBlock].! ! 175691 175692!LayoutCell methodsFor: 'collection' stamp: 'ar 10/28/2000 21:27'! 175693inject: thisValue into: binaryBlock 175694 "Accumulate a running value associated with evaluating the argument, 175695 binaryBlock, with the current value of the argument, thisValue, and the 175696 receiver as block arguments. For instance, to sum the numeric elements 175697 of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal + 175698 next]." 175699 175700 | nextValue | 175701 nextValue := thisValue. 175702 self do: [:each | nextValue := binaryBlock value: nextValue value: each]. 175703 ^nextValue! ! 175704Object subclass: #LayoutFrame 175705 instanceVariableNames: 'leftFraction leftOffset topFraction topOffset rightFraction rightOffset bottomFraction bottomOffset' 175706 classVariableNames: '' 175707 poolDictionaries: '' 175708 category: 'Morphic-Layouts'! 175709!LayoutFrame commentStamp: '<historical>' prior: 0! 175710I define a frame for positioning some morph in a proportional layout. 175711 175712Instance variables: 175713 leftFraction 175714 topFraction 175715 rightFraction 175716 bottomFraction <Float> The fractional distance (between 0 and 1) to place the morph in its owner's bounds 175717 leftOffset 175718 topOffset 175719 rightOffset 175720 bottomOffset <Integer> Fixed pixel offset to apply after fractional positioning (e.g., "10 pixel right of the center of the owner")! 175721 175722 175723!LayoutFrame methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/24/2007 15:51'! 175724minExtentFrom: minExtent 175725 "Return the minimal extent the given bounds can be represented in." 175726 175727 |width height widthProp heightProp leftO rightO topO bottomO| 175728 leftO := leftOffset ifNil: [0]. 175729 rightO := rightOffset ifNil: [0]. 175730 topO := topOffset ifNil: [0]. 175731 bottomO := bottomOffset ifNil: [0]. 175732 "calculate proportional area. bottom/right offsets extend in +ve direction." 175733 width := minExtent x + leftO - rightO. 175734 height := minExtent y + topO - bottomO. 175735 "calculate the effective proportion" 175736 widthProp := (rightFraction ifNil: [1.0]) - (leftFraction ifNil: [0]). 175737 heightProp := (bottomFraction ifNil: [1.0]) - (topFraction ifNil: [0]). 175738 "if the proportions are 0 then the minima cannot be determined and 175739 minExtent cannot be respected." 175740 width := widthProp = 0 175741 ifTrue: [0] 175742 ifFalse: [width / widthProp]. 175743 height := heightProp = 0 175744 ifTrue: [0] 175745 ifFalse: [height / heightProp]. 175746 ^width truncated @ height truncated! ! 175747 175748 175749!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! 175750bottomFraction 175751 ^bottomFraction! ! 175752 175753!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! 175754bottomFraction: aNumber 175755 bottomFraction := aNumber! ! 175756 175757!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! 175758bottomFraction: aNumber offset: anInteger 175759 175760 bottomFraction := aNumber. 175761 bottomOffset := anInteger! ! 175762 175763!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! 175764bottomOffset 175765 ^bottomOffset! ! 175766 175767!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! 175768bottomOffset: anInteger 175769 bottomOffset := anInteger! ! 175770 175771!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! 175772leftFraction 175773 ^leftFraction! ! 175774 175775!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! 175776leftFraction: aNumber 175777 leftFraction := aNumber! ! 175778 175779!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! 175780leftFraction: aNumber offset: anInteger 175781 175782 leftFraction := aNumber. 175783 leftOffset := anInteger! ! 175784 175785!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! 175786leftOffset 175787 ^leftOffset! ! 175788 175789!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! 175790leftOffset: anInteger 175791 leftOffset := anInteger! ! 175792 175793!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! 175794rightFraction 175795 ^rightFraction! ! 175796 175797!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! 175798rightFraction: aNumber 175799 rightFraction := aNumber! ! 175800 175801!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! 175802rightFraction: aNumber offset: anInteger 175803 175804 rightFraction := aNumber. 175805 rightOffset := anInteger! ! 175806 175807!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! 175808rightOffset 175809 ^rightOffset! ! 175810 175811!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! 175812rightOffset: anInteger 175813 rightOffset := anInteger! ! 175814 175815!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! 175816topFraction 175817 ^topFraction! ! 175818 175819!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! 175820topFraction: aNumber 175821 topFraction := aNumber! ! 175822 175823!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'! 175824topFraction: aNumber offset: anInteger 175825 175826 topFraction := aNumber. 175827 topOffset := anInteger! ! 175828 175829!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'! 175830topOffset 175831 ^topOffset! ! 175832 175833!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'! 175834topOffset: anInteger 175835 topOffset := anInteger! ! 175836 175837 175838!LayoutFrame methodsFor: 'layout' stamp: 'JW 2/1/2001 13:04'! 175839layout: oldBounds in: newBounds 175840 "Return the proportional rectangle insetting the given bounds" 175841 | left right top bottom | 175842 leftFraction ifNotNil:[ 175843 left := newBounds left + (newBounds width * leftFraction). 175844 leftOffset ifNotNil:[left := left + leftOffset]]. 175845 rightFraction ifNotNil:[ 175846 right := newBounds right - (newBounds width * (1.0 - rightFraction)). 175847 rightOffset ifNotNil:[right := right + rightOffset]]. 175848 topFraction ifNotNil:[ 175849 top := newBounds top + (newBounds height * topFraction). 175850 topOffset ifNotNil:[top := top + topOffset]]. 175851 bottomFraction ifNotNil:[ 175852 bottom := newBounds bottom - (newBounds height * (1.0 - bottomFraction)). 175853 bottomOffset ifNotNil:[bottom := bottom + bottomOffset]]. 175854 left ifNil:[ right 175855 ifNil:[left := oldBounds left. right := oldBounds right] 175856 ifNotNil:[left := right - oldBounds width]]. 175857 right ifNil:[right := left + oldBounds width]. 175858 top ifNil:[ bottom 175859 ifNil:[top := oldBounds top. bottom := oldBounds bottom] 175860 ifNotNil:[top := bottom - oldBounds height]]. 175861 bottom ifNil:[bottom := top + oldBounds height]. 175862 ^(left rounded @ top rounded) corner: (right rounded @ bottom rounded)! ! 175863 175864 175865!LayoutFrame methodsFor: 'objects from disk' stamp: 'JW 2/1/2001 14:37'! 175866negateBottomRightOffsets 175867 175868 bottomOffset ifNotNil: [ bottomOffset := bottomOffset negated ]. 175869 rightOffset ifNotNil: [ rightOffset := rightOffset negated ]. 175870 175871! ! 175872 175873"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 175874 175875LayoutFrame class 175876 instanceVariableNames: ''! 175877 175878!LayoutFrame class methodsFor: 'accessing' stamp: 'JW 2/1/2001 12:48'! 175879classVersion 175880 ^1 "changed treatment of bottomOffset and rightOffset" 175881! ! 175882 175883 175884!LayoutFrame class methodsFor: 'instance creation' stamp: 'ar 2/5/2002 00:07'! 175885fractions: fractionsOrNil 175886 ^self fractions: fractionsOrNil offsets: nil! ! 175887 175888!LayoutFrame class methodsFor: 'instance creation' stamp: 'RAA 1/8/2001 21:22'! 175889fractions: fractionsOrNil offsets: offsetsOrNil 175890 175891 | fractions offsets | 175892 175893 fractions := fractionsOrNil ifNil: [0@0 extent: 0@0]. 175894 offsets := offsetsOrNil ifNil: [0@0 extent: 0@0]. 175895 ^self new 175896 topFraction: fractions top offset: offsets top; 175897 leftFraction: fractions left offset: offsets left; 175898 bottomFraction: fractions bottom offset: offsets bottom; 175899 rightFraction: fractions right offset: offsets right 175900! ! 175901 175902!LayoutFrame class methodsFor: 'instance creation' stamp: 'ar 2/5/2002 20:06'! 175903offsets: offsetsOrNil 175904 ^self fractions: nil offsets: offsetsOrNil! ! 175905Object subclass: #LayoutPolicy 175906 instanceVariableNames: '' 175907 classVariableNames: '' 175908 poolDictionaries: '' 175909 category: 'Morphic-Layouts'! 175910!LayoutPolicy commentStamp: '<historical>' prior: 0! 175911A LayoutPolicy defines how submorphs of some morph should be arranged. Subclasses of the receiver define concrete layout policies.! 175912 175913 175914!LayoutPolicy methodsFor: 'layout' stamp: 'ar 1/27/2001 14:39'! 175915flushLayoutCache 175916 "Flush any cached information associated with the receiver"! ! 175917 175918!LayoutPolicy methodsFor: 'layout' stamp: 'ar 10/28/2000 19:12'! 175919layout: aMorph in: newBounds 175920 "Compute the layout for the given morph based on the new bounds" 175921! ! 175922 175923!LayoutPolicy methodsFor: 'layout' stamp: 'ar 10/31/2000 19:59'! 175924minExtentOf: aMorph in: newBounds 175925 "Return the minimal size aMorph's children would require given the new bounds" 175926 ^0@0! ! 175927 175928 175929!LayoutPolicy methodsFor: 'testing' stamp: 'ar 10/29/2000 01:28'! 175930isProportionalLayout 175931 ^false! ! 175932 175933!LayoutPolicy methodsFor: 'testing' stamp: 'ar 10/29/2000 01:28'! 175934isTableLayout 175935 ^false! ! 175936 175937 175938!LayoutPolicy methodsFor: 'utilities' stamp: 'ar 10/29/2000 17:31'! 175939indexForInserting: aMorph at: aPoint in: someMorph 175940 "Return the insertion index based on the layout strategy defined for some morph. Used for drop insertion." 175941 ^1 "front-most"! ! 175942Object subclass: #LayoutProperties 175943 instanceVariableNames: 'hResizing vResizing disableLayout' 175944 classVariableNames: '' 175945 poolDictionaries: '' 175946 category: 'Morphic-Layouts'! 175947!LayoutProperties commentStamp: '<historical>' prior: 0! 175948This class provides a compact bit encoding for the most commonly used layout properties.! 175949 175950 175951!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! 175952disableTableLayout 175953 ^disableLayout! ! 175954 175955!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! 175956disableTableLayout: aBool 175957 disableLayout := aBool! ! 175958 175959!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! 175960hResizing 175961 ^hResizing! ! 175962 175963!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! 175964hResizing: aSymbol 175965 hResizing := aSymbol! ! 175966 175967!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! 175968vResizing 175969 ^vResizing! ! 175970 175971!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:52'! 175972vResizing: aSymbol 175973 vResizing := aSymbol! ! 175974 175975 175976!LayoutProperties methodsFor: 'converting' stamp: 'ar 11/14/2000 17:52'! 175977asTableLayoutProperties 175978 ^(TableLayoutProperties new) 175979 hResizing: self hResizing; 175980 vResizing: self vResizing; 175981 disableTableLayout: self disableTableLayout; 175982 yourself! ! 175983 175984 175985!LayoutProperties methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 10:00'! 175986initialize 175987 super initialize. 175988 hResizing := vResizing := #rigid. 175989 disableLayout := false.! ! 175990 175991!LayoutProperties methodsFor: 'initialize' stamp: 'ar 11/14/2000 17:56'! 175992initializeFrom: defaultProvider 175993 "Initialize the receiver from a default provider" 175994 self hResizing: defaultProvider hResizing. 175995 self vResizing: defaultProvider vResizing. 175996 self disableTableLayout: defaultProvider disableTableLayout.! ! 175997 175998 175999!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:53'! 176000cellInset 176001 "Default" 176002 ^0! ! 176003 176004!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:50'! 176005cellPositioning 176006 ^#center! ! 176007 176008!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:55'! 176009cellSpacing 176010 "Default" 176011 ^#none! ! 176012 176013!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 16:38'! 176014layoutInset 176015 ^0! ! 176016 176017!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:58'! 176018listCentering 176019 "Default" 176020 ^#topLeft! ! 176021 176022!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:59'! 176023listDirection 176024 "Default" 176025 ^#topToBottom! ! 176026 176027!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:59'! 176028listSpacing 176029 "Default" 176030 ^#none! ! 176031 176032!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:00'! 176033maxCellSize 176034 ^SmallInteger maxVal! ! 176035 176036!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:00'! 176037minCellSize 176038 ^0! ! 176039 176040!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:00'! 176041reverseTableCells 176042 ^false! ! 176043 176044!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:01'! 176045rubberBandCells 176046 ^false! ! 176047 176048!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:02'! 176049wrapCentering 176050 ^#topLeft! ! 176051 176052!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:02'! 176053wrapDirection 176054 ^#none! ! 176055 176056 176057!LayoutProperties methodsFor: 'testing' stamp: 'ar 11/13/2000 18:34'! 176058includesTableProperties 176059 ^false! ! 176060Morph subclass: #LazyListMorph 176061 instanceVariableNames: 'listItems font selectedRow selectedRows listSource maxWidth' 176062 classVariableNames: '' 176063 poolDictionaries: '' 176064 category: 'Morphic-Widgets'! 176065!LazyListMorph commentStamp: 'efc 8/6/2005 11:34' prior: 0! 176066The morph that displays the list in a PluggableListMorph. It is "lazy" because it will only request the list items that it actually needs to display. 176067 176068I will cache the maximum width of my items in maxWidth to avoid this potentially expensive and frequent computation.! 176069 176070 176071!LazyListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/12/2006 11:21'! 176072mouseDownRow 176073 "Answer the row that should have mouse down highlighting if any." 176074 176075 ^self valueOfProperty: #mouseDownRow! ! 176076 176077!LazyListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 13:06'! 176078mouseDownRow: anInteger 176079 "Set the row that should have mouse down highlighting or nil if none." 176080 176081 anInteger = self mouseDownRow ifTrue: [^self]. 176082 self mouseDownRowFrameChanged. 176083 self setProperty: #mouseDownRow toValue: anInteger. 176084 self mouseDownRowFrameChanged! ! 176085 176086!LazyListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 14:04'! 176087mouseDownRowFrameChanged 176088 "Invalidate frame of the current mouse down row if any." 176089 176090 |frame row| 176091 row := self mouseDownRow ifNil: [ ^self ]. 176092 frame := self selectionFrameForRow: row. 176093 self invalidRect: frame! ! 176094 176095!LazyListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 11:44'! 176096selectionFrameChanged 176097 "Invalidate frame of the current selection if any." 176098 176099 | frame | 176100 selectedRow ifNil: [ ^self ]. 176101 selectedRow = 0 ifTrue: [ ^self ]. 176102 frame := self selectionFrameForRow: selectedRow. 176103 self invalidRect: frame! ! 176104 176105!LazyListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/12/2006 15:33'! 176106selectionFrameForRow: row 176107 "Answer the selection frame rectangle." 176108 176109 |frame| 176110 frame := self drawBoundsForRow: row. 176111 frame := frame intersect: self bounds. 176112 frame := self bounds: frame in: listSource. 176113 frame := self 176114 bounds: ((frame left: listSource innerBounds left) right: listSource innerBounds right) 176115 from: listSource. 176116 ^frame! ! 176117 176118 176119!LazyListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/11/2006 13:45'! 176120colorForRow: row 176121 "Answer the color for the row text." 176122 176123 ^self color! ! 176124 176125!LazyListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'tween 3/10/2009 08:13'! 176126display: item atRow: row on: aCanvas 176127 "Display the given item at the given row on the given canvas." 176128 176129 | c drawBounds frame attrs useDefaultFont| 176130 drawBounds := self drawBoundsForRow: row. 176131 c := self colorForRow: row. 176132 item isText 176133 ifTrue: [|f col itemBounds| 176134 attrs := item attributesAt: 1 forStyle: TextStyle default. 176135 useDefaultFont := true. 176136 attrs do: [:att | att forFontInStyle: TextStyle default do: [:fon | useDefaultFont := false]]. 176137 f := useDefaultFont 176138 ifTrue: [self font] 176139 ifFalse: [item fontAt: 1 withStyle: TextStyle default]. 176140 col := (item attributesAt: 1) detect: [:a | a isKindOf: TextColor] ifNone: []. 176141 col ifNotNil: [c := col color]. 176142 itemBounds := drawBounds withHeight: f height. 176143 itemBounds := itemBounds align: itemBounds leftCenter with: drawBounds leftCenter. 176144 "centre the item if the font height is different to that of our font" 176145 aCanvas drawString: item in: itemBounds font: (f emphasized: (item emphasisAt: 1)) color: c underline: ((item emphasisAt: 1) bitAnd: 4) > 0 underlineColor: c strikethrough: ((item emphasisAt: 1) bitAnd: 16) > 0 strikethroughColor: c] 176146 ifFalse: [aCanvas drawString: item in: drawBounds font: self font color: c]. 176147 row = ((self respondsTo: #mouseDownRow) "check since MC doesn't manage an atomic load!!" 176148 ifTrue: [self mouseDownRow]) 176149 ifTrue: [frame := self selectionFrameForRow: row. 176150 aCanvas 176151 frameRectangle: frame 176152 width: 1 176153 colors: {c. Color transparent} 176154 dashes: #(1 1)]! ! 176155 176156!LazyListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/12/2006 14:36'! 176157drawSelectionOn: aCanvas 176158 "Draw the selection background." 176159 176160 | frame | 176161 selectedRow ifNil: [ ^self ]. 176162 selectedRow = 0 ifTrue: [ ^self ]. 176163 frame := self selectionFrameForRow: selectedRow. 176164 aCanvas 176165 fillRectangle: frame 176166 color: (listSource selectionColorToUse ifNil: [Preferences textHighlightColor])! ! 176167 176168!LazyListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/19/2009 12:15'! 176169hUnadjustedScrollRange 176170"Ok, this is a bit messed up. We need to return the width of the widest item in the list. If we grab every item in the list, it defeats the purpose of LazyListMorph. If we don't, then we don't know the size. 176171 176172This is a compromise -- find the widest of the first 30 items, then double it, This width will be updated as new items are installed, so it will always be correct for the visible items. If you know a better way, please chime in." 176173 176174 | itemsToCheck item index | 176175 "Check for a cached value" 176176 maxWidth ifNotNil:[^maxWidth]. 176177 176178 listItems isEmpty ifTrue: [^0]. "don't set maxWidth if empty do will be recomputed when there are some items" 176179 "Compute from scratch" 176180 itemsToCheck := 30 min: (listItems size). 176181 maxWidth := 0. 176182 176183 "Check the first few items to get a representative sample of the rest of the list." 176184 index := 1. 176185 [index < itemsToCheck] whileTrue: 176186 [ item := self getListItem: index. "Be careful not to actually install this item" 176187 maxWidth := maxWidth max: (self widthToDisplayItem: item contents). 176188 index:= index + 1. 176189 ]. 176190 176191 "Add some initial fudge if we didn't check all the items." 176192 (itemsToCheck < listItems size) ifTrue:[maxWidth := maxWidth*2]. 176193 176194 ^maxWidth 176195! ! 176196 176197!LazyListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/19/2009 12:39'! 176198listChanged 176199 "set newList to be the list of strings to display" 176200 listItems := Array new: self getListSize withAll: nil. 176201 selectedRow := nil. 176202 selectedRows := PluggableSet integerSet. 176203 maxWidth := nil. "recompute" 176204 self adjustHeight. 176205 self adjustWidth. 176206 self changed. 176207! ! 176208 176209!LazyListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/24/2007 11:45'! 176210selectRow: index 176211 "Select the index-th row." 176212 176213 selectedRows add: index. 176214 self invalidRect: (self selectionFrameForRow: index)! ! 176215 176216!LazyListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/24/2007 11:46'! 176217selectedRow: index 176218 "Select the index-th row. if nil, remove the current selection." 176219 176220 selectedRow ifNotNil: [self selectionFrameChanged]. 176221 selectedRow := index. 176222 selectedRow ifNotNil: [self selectionFrameChanged]! ! 176223 176224!LazyListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/24/2007 11:46'! 176225unselectRow: index 176226 "Unselect the index-th row." 176227 176228 selectedRows remove: index ifAbsent: [^self]. 176229 self invalidRect: (self selectionFrameForRow: index)! ! 176230 176231 176232!LazyListMorph methodsFor: 'accessing' stamp: 'bf 4/21/2005 15:58'! 176233userString 176234 "Do I have a text string to be searched on?" 176235 176236 ^ String streamContents: [:strm | 176237 1 to: self getListSize do: [:i | 176238 strm nextPutAll: (self getListItem: i); cr]]! ! 176239 176240 176241!LazyListMorph methodsFor: 'drawing' stamp: 'ls 5/15/2001 22:13'! 176242adjustHeight 176243 "private. Adjust our height to match the length of the underlying list" 176244 self height: (listItems size max: 1) * font height 176245! ! 176246 176247!LazyListMorph methodsFor: 'drawing' stamp: 'sps 3/9/2004 17:06'! 176248adjustWidth 176249 "private. Adjust our height to match the length of the underlying list" 176250 self width: ((listSource width max: self hUnadjustedScrollRange) + 20). 176251! ! 176252 176253!LazyListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 21:57'! 176254bottomVisibleRowForCanvas: aCanvas 176255 "return the bottom visible row in aCanvas's clip rectangle" 176256 ^self rowAtLocation: aCanvas clipRect bottomLeft. 176257! ! 176258 176259!LazyListMorph methodsFor: 'drawing' stamp: 'ls 6/10/2001 12:31'! 176260drawBackgroundForMulti: row on: aCanvas 176261 | selectionDrawBounds | 176262 "shade the background darker, if this row is selected" 176263 176264 selectionDrawBounds := self drawBoundsForRow: row. 176265 selectionDrawBounds := selectionDrawBounds intersect: self bounds. 176266 aCanvas fillRectangle: selectionDrawBounds color: self color muchLighter! ! 176267 176268!LazyListMorph methodsFor: 'drawing' stamp: 'ls 6/22/2001 23:59'! 176269drawBackgroundForPotentialDrop: row on: aCanvas 176270 | selectionDrawBounds | 176271 "shade the background darker, if this row is a potential drop target" 176272 176273 selectionDrawBounds := self drawBoundsForRow: row. 176274 selectionDrawBounds := selectionDrawBounds intersect: self bounds. 176275 aCanvas fillRectangle: selectionDrawBounds color: self color muchLighter darker! ! 176276 176277!LazyListMorph methodsFor: 'drawing' stamp: 'ls 12/6/2001 21:43'! 176278drawOn: aCanvas 176279 | | 176280 listItems size = 0 ifTrue: [ ^self ]. 176281 176282 self drawSelectionOn: aCanvas. 176283 176284 (self topVisibleRowForCanvas: aCanvas) to: (self bottomVisibleRowForCanvas: aCanvas) do: [ :row | 176285 (listSource itemSelectedAmongMultiple: row) ifTrue: [ 176286 self drawBackgroundForMulti: row on: aCanvas. ]. 176287 self display: (self item: row) atRow: row on: aCanvas. 176288 ]. 176289 176290 listSource potentialDropRow > 0 ifTrue: [ 176291 self highlightPotentialDropRow: listSource potentialDropRow on: aCanvas ].! ! 176292 176293!LazyListMorph methodsFor: 'drawing' stamp: 'ls 7/5/2000 18:37'! 176294font 176295 "return the font used for drawing. The response is never nil" 176296 ^font! ! 176297 176298!LazyListMorph methodsFor: 'drawing' stamp: 'ls 7/5/2000 18:04'! 176299font: newFont 176300 font := (newFont ifNil: [ TextStyle default defaultFont ]). 176301 self adjustHeight. 176302 self changed.! ! 176303 176304!LazyListMorph methodsFor: 'drawing' stamp: 'ls 6/23/2001 00:13'! 176305highlightPotentialDropRow: row on: aCanvas 176306 | drawBounds | 176307 drawBounds := self drawBoundsForRow: row. 176308 drawBounds := drawBounds intersect: self bounds. 176309 aCanvas frameRectangle: drawBounds color: Color blue! ! 176310 176311!LazyListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 21:57'! 176312topVisibleRowForCanvas: aCanvas 176313 "return the top visible row in aCanvas's clip rectangle" 176314 ^self rowAtLocation: aCanvas clipRect topLeft. 176315! ! 176316 176317 176318!LazyListMorph methodsFor: 'initialization' stamp: 'nk 10/14/2003 15:24'! 176319initialize 176320 super initialize. 176321 self color: Color black. 176322 font := Preferences standardListFont. 176323 listItems := #(). 176324 selectedRow := nil. 176325 selectedRows := PluggableSet integerSet. 176326 self adjustHeight.! ! 176327 176328!LazyListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:12'! 176329listSource: aListSource 176330 "set the source of list items -- typically a PluggableListMorph" 176331 listSource := aListSource. 176332 self listChanged! ! 176333 176334 176335!LazyListMorph methodsFor: 'list access' stamp: 'ls 8/19/2001 14:07'! 176336getListItem: index 176337 "grab a list item directly from the model" 176338 ^listSource getListItem: index! ! 176339 176340!LazyListMorph methodsFor: 'list access' stamp: 'ls 5/15/2001 22:11'! 176341getListSize 176342 "return the number of items in the list" 176343 listSource ifNil: [ ^0 ]. 176344 ^listSource getListSize! ! 176345 176346!LazyListMorph methodsFor: 'list access' stamp: 'efc 8/6/2005 11:23'! 176347item: index 176348 "return the index-th item, using the 'listItems' cache" 176349 | newItem itemWidth | 176350 (index between: 1 and: listItems size) 176351 ifFalse: [ "there should have been an update, but there wasn't!!" ^self getListItem: index]. 176352 (listItems at: index) ifNil: [ 176353 newItem := self getListItem: index. 176354 "Update the width cache." 176355 maxWidth ifNotNil:[ 176356 itemWidth := self widthToDisplayItem: newItem contents. 176357 itemWidth > maxWidth ifTrue:[ 176358 maxWidth := itemWidth. 176359 self adjustWidth. 176360 ]]. 176361 listItems at: index put: newItem ]. 176362 ^listItems at: index! ! 176363 176364 176365!LazyListMorph methodsFor: 'list management' stamp: 'ls 7/5/2000 18:21'! 176366drawBoundsForRow: row 176367 "calculate the bounds that row should be drawn at. This might be outside our bounds!!" 176368 | topLeft drawBounds | 176369 topLeft := self topLeft x @ (self topLeft y + ((row - 1) * (font height))). 176370 drawBounds := topLeft extent: self width @ font height. 176371 ^drawBounds! ! 176372 176373!LazyListMorph methodsFor: 'list management' stamp: 'ls 10/20/2001 00:09'! 176374rowAtLocation: aPoint 176375 "return the number of the row at aPoint" 176376 | y | 176377 y := aPoint y. 176378 y < self top ifTrue: [ ^ 1 ]. 176379 ^((y - self top // (font height)) + 1) min: listItems size max: 0! ! 176380 176381!LazyListMorph methodsFor: 'list management' stamp: 'ls 7/7/2000 10:38'! 176382selectedRow 176383 "return the currently selected row, or nil if none is selected" 176384 ^selectedRow! ! 176385 176386 176387!LazyListMorph methodsFor: 'scroll range' stamp: 'ls 4/17/2004 12:17'! 176388widthToDisplayItem: item 176389 ^self font widthOfStringOrText: item 176390 ! ! 176391LazyListMorph subclass: #LazyMorphListMorph 176392 instanceVariableNames: '' 176393 classVariableNames: '' 176394 poolDictionaries: '' 176395 category: 'Polymorph-Widgets'! 176396!LazyMorphListMorph commentStamp: 'gvc 5/18/2007 12:47' prior: 0! 176397Support for morph lists in PluggableMorphListMorph.! 176398 176399 176400!LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 13:38'! 176401adjustHeight 176402 "private. Adjust our height to match the length of the underlying list. 176403 Automatic with table layout." 176404! ! 176405 176406!LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/13/2006 11:12'! 176407adjustWidth 176408 "private. Adjust our height to match the length of the underlying list" 176409 176410 self width: (listSource innerBounds width max: self hUnadjustedScrollRange). ! ! 176411 176412!LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/12/2006 15:14'! 176413display: item atRow: row on: aCanvas 176414 "Display the given item at the given row on the given canvas." 176415 176416 |c frame| 176417 row = self mouseDownRow ifFalse: [^self]. 176418 frame := self selectionFrameForRow: row. 176419 c := self colorForRow: row. 176420 aCanvas 176421 frameRectangle: frame 176422 width: 1 176423 colors: {c. Color transparent} 176424 dashes: #(1 1)! ! 176425 176426!LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 16:08'! 176427drawBoundsForRow: row 176428 "Calculate the bounds that row should be drawn at. This might be outside our bounds!!" 176429 176430 (row between: 1 and: listItems size) 176431 ifFalse: [^0@0 corner: 0@0]. 176432 ^(listItems at: row) bounds! ! 176433 176434!LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'Henrik Sperre Johansen 5/19/2009 21:59'! 176435drawSubmorphsOn: aCanvas 176436 "Display submorphs back to front" 176437 176438 |drawBlock i| 176439 submorphs isEmpty ifTrue: [^self]. 176440 drawBlock := [:canvas | 176441 (self topVisibleRowForCanvas: aCanvas) to: (self bottomVisibleRowForCanvas: aCanvas) do: [ :row | 176442 i := self item: row. 176443 canvas fullDrawMorph: i]]. 176444 self clipSubmorphs 176445 ifTrue: [aCanvas clipBy: (aCanvas clipRect intersect: self clippingBounds) during: drawBlock] 176446 ifFalse: [drawBlock value: aCanvas]! ! 176447 176448!LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/19/2009 12:25'! 176449hUnadjustedScrollRange 176450 "Answer the width of the widest item." 176451 176452 maxWidth ifNotNil:[^maxWidth]. 176453 listItems isEmpty ifTrue: [^0]. 176454 maxWidth := 0. 176455 listItems do: [:each | 176456 each ifNotNil: [maxWidth := maxWidth max: (self widthToDisplayItem: each)]]. 176457 ^maxWidth 176458! ! 176459 176460!LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/13/2006 10:44'! 176461initialize 176462 "Initialize the receiver." 176463 176464 super initialize. 176465 self 176466 changeTableLayout; 176467 cellPositioning: #topLeft; 176468 cellInset: 2; 176469 vResizing: #shrinkWrap; 176470 hResizing: #rigid! ! 176471 176472!LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/19/2009 17:15'! 176473listChanged 176474 "set newList to be the list of strings to display" 176475 listItems := (1 to: self getListSize) collect: [:i | 176476 self getListItem: i]. 176477 self removeAllMorphs. 176478 listItems do: [:i | self addMorphBack: i]. 176479 selectedRow := nil. 176480 selectedRows := PluggableSet integerSet. 176481 maxWidth := nil. "recompute" 176482 self 176483 adjustHeight; 176484 adjustWidth. 176485 listItems do: [:i | i layoutChanged]. 176486 self changed. 176487! ! 176488 176489!LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 13:36'! 176490rowAtLocation: aPoint 176491 "return the number of the row at aPoint" 176492 176493 | y | 176494 y := aPoint y. 176495 y < self top ifTrue: [ ^ 1 ]. 176496 listItems with: (1 to: listItems size) do: [:i :row | 176497 (y < i bottom) ifTrue: [^row]]. 176498 ^listItems size! ! 176499 176500!LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 12:24'! 176501selectRow: index 176502 "select the index-th row" 176503 selectedRows add: index. 176504 self invalidRect: (self drawBoundsForRow: index)! ! 176505 176506!LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/12/2006 15:33'! 176507selectionFrameForRow: row 176508 "Answer the selection frame rectangle." 176509 176510 |frame| 176511 frame := self drawBoundsForRow: row. 176512 frame := frame expandBy: (self cellInset // 2). 176513 self cellInset odd ifTrue: [frame := frame bottom: frame bottom + 1]. 176514 frame := frame intersect: self bounds. 176515 frame := self bounds: frame in: listSource. 176516 frame := self 176517 bounds: ((frame left: listSource innerBounds left) right: listSource innerBounds right) 176518 from: listSource. 176519 ^frame! ! 176520 176521!LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/10/2006 09:42'! 176522userString 176523 "Do I have a text string to be searched on?" 176524 176525 |usm| 176526 ^ String streamContents: [:strm | 176527 1 to: self getListSize do: [:i | 176528 usm := (self getListItem: i) submorphs detect: [:m | m userString notNil] ifNone: []. 176529 strm nextPutAll: (usm ifNil: [''] ifNotNil: [usm userString]); cr]]! ! 176530 176531!LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 11:09'! 176532widthToDisplayItem: item 176533 176534 ^item minExtent x 176535 ! ! 176536ParseNode subclass: #LeafNode 176537 instanceVariableNames: 'key code index' 176538 classVariableNames: '' 176539 poolDictionaries: '' 176540 category: 'Compiler-ParseNodes'! 176541!LeafNode commentStamp: '<historical>' prior: 0! 176542I represent a leaf node of the compiler parse tree. I am abstract. 176543 176544Types (defined in class ParseNode): 176545 1 LdInstType (which uses class VariableNode) 176546 2 LdTempType (which uses class VariableNode) 176547 3 LdLitType (which uses class LiteralNode) 176548 4 LdLitIndType (which uses class VariableNode) 176549 5 SendType (which uses class SelectorNode). 176550 176551Note that Squeak departs slightly from the Blue Book bytecode spec. 176552 176553In order to allow access to more than 63 literals and instance variables, 176554bytecode 132 has been redefined as DoubleExtendedDoAnything: 176555 byte2 byte3 Operation 176556(hi 3 bits) (lo 5 bits) 176557 0 nargs lit index Send Literal Message 0-255 176558 1 nargs lit index Super-Send Lit Msg 0-255 176559 2 ignored rcvr index Push Receiver Variable 0-255 176560 3 ignored lit index Push Literal Constant 0-255 176561 4 ignored lit index Push Literal Variable 0-255 176562 5 ignored rcvr index Store Receiver Variable 0-255 176563 6 ignored rcvr index Store-pop Receiver Variable 0-255 176564 7 ignored lit index Store Literal Variable 0-255 176565 176566 This has allowed bytecode 134 also to be redefined as a second extended send 176567 that can access literals up to 64 for nargs up to 3 without needing three bytes. 176568 It is just like 131, except that the extension byte is aallllll instead of aaalllll, 176569 where aaa are bits of argument count, and lll are bits of literal index.! 176570 176571 176572!LeafNode methodsFor: 'accessing'! 176573key 176574 176575 ^key! ! 176576 176577 176578!LeafNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:39'! 176579code 176580 176581 ^ code! ! 176582 176583!LeafNode methodsFor: 'code generation'! 176584emitForEffect: stack on: strm 176585 176586 ^self! ! 176587 176588!LeafNode methodsFor: 'code generation' stamp: 'ar 3/26/2004 15:44'! 176589emitLong: mode on: aStream 176590 "Emit extended variable access." 176591 | type index | 176592 code < 256 176593 ifTrue: 176594 [code < 16 176595 ifTrue: [type := 0. 176596 index := code] 176597 ifFalse: [code < 32 176598 ifTrue: [type := 1. 176599 index := code - 16] 176600 ifFalse: [code < 96 176601 ifTrue: [type := code // 32 + 1. 176602 index := code \\ 32] 176603 ifFalse: [self error: 176604 'Sends should be handled in SelectorNode']]]] 176605 ifFalse: 176606 [index := code \\ 256. 176607 type := code // 256 - 1]. 176608 index <= 63 ifTrue: 176609 [aStream nextPut: mode. 176610 ^ aStream nextPut: type * 64 + index]. 176611 "Compile for Double-exetended Do-anything instruction..." 176612 mode = LoadLong ifTrue: 176613 [aStream nextPut: DblExtDoAll. 176614 aStream nextPut: (#(64 0 96 128) at: type+1). "Cant be temp (type=1)" 176615 ^ aStream nextPut: index]. 176616 mode = Store ifTrue: 176617 [aStream nextPut: DblExtDoAll. 176618 aStream nextPut: (#(160 0 0 224) at: type+1). "Cant be temp or const (type=1 or 2)" 176619 ^ aStream nextPut: index]. 176620 mode = StorePop ifTrue: 176621 [aStream nextPut: DblExtDoAll. 176622 aStream nextPut: (#(192 0 0 0) at: type+1). "Can only be inst" 176623 ^ aStream nextPut: index]. 176624! ! 176625 176626!LeafNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 15:57'! 176627reserve: encoder 176628 "If this is a yet unused literal of type -code, reserve it." 176629 176630 code < 0 ifTrue: [code := self code: (index := encoder litIndex: key) type: 0 - code]! ! 176631 176632!LeafNode methodsFor: 'code generation'! 176633sizeForEffect: encoder 176634 176635 ^0! ! 176636 176637!LeafNode methodsFor: 'code generation' stamp: 'ar 3/26/2004 15:44'! 176638sizeForValue: encoder 176639 self reserve: encoder. 176640 code < 256 ifTrue: [^ 1]. 176641 (code \\ 256) <= 63 ifTrue: [^ 2]. 176642 ^ 3! ! 176643 176644 176645!LeafNode methodsFor: 'code generation (closures)' stamp: 'eem 6/16/2008 09:32'! 176646analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>" 176647 "This is a no-op except in TempVariableNode" 176648 ^self! ! 176649 176650 176651!LeafNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 176652emitCodeForEffect: stack encoder: encoder 176653 176654 ^self! ! 176655 176656!LeafNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 15:25'! 176657emitCodeForLoad: stack encoder: encoder 176658 "Default is to do nothing. 176659 Subclasses may need to override."! ! 176660 176661!LeafNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 176662sizeCodeForEffect: encoder 176663 176664 ^0! ! 176665 176666!LeafNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 15:24'! 176667sizeCodeForLoad: encoder 176668 "Default is to do nothing. 176669 Subclasses may need to override." 176670 ^0! ! 176671 176672!LeafNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/19/2008 15:10'! 176673sizeCodeForValue: encoder 176674 self subclassResponsibility! ! 176675 176676 176677!LeafNode methodsFor: 'copying' stamp: 'eem 5/14/2008 11:25'! 176678veryDeepFixupWith: deepCopier 176679 "If fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 176680 176681super veryDeepFixupWith: deepCopier. 176682key := (deepCopier references at: key ifAbsent: [key]). 176683! ! 176684 176685!LeafNode methodsFor: 'copying' stamp: 'eem 7/12/2008 17:24'! 176686veryDeepInner: deepCopier 176687 "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." 176688 176689super veryDeepInner: deepCopier. 176690"key := key. Weakly copied" 176691code := code veryDeepCopyWith: deepCopier. 176692index := index veryDeepCopyWith: deepCopier. 176693! ! 176694 176695 176696!LeafNode methodsFor: 'initialize-release' stamp: 'ar 3/26/2004 15:44'! 176697key: object code: byte 176698 176699 key := object. 176700 code := byte! ! 176701 176702!LeafNode methodsFor: 'initialize-release' stamp: 'eem 5/14/2008 15:56'! 176703key: object index: i type: type 176704 176705 key := object. 176706 code := (self code: i type: type). 176707 index := i! ! 176708 176709!LeafNode methodsFor: 'initialize-release' stamp: 'ar 3/26/2004 15:44'! 176710name: ignored key: object code: byte 176711 176712 key := object. 176713 code := byte! ! 176714 176715 176716!LeafNode methodsFor: 'private'! 176717code: index type: type 176718 176719 index isNil 176720 ifTrue: [^type negated]. 176721 (CodeLimits at: type) > index 176722 ifTrue: [^(CodeBases at: type) + index]. 176723 ^type * 256 + index! ! 176724 176725"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 176726 176727LeafNode class 176728 instanceVariableNames: ''! 176729WriteStream subclass: #LimitedWriteStream 176730 instanceVariableNames: 'limit limitBlock' 176731 classVariableNames: '' 176732 poolDictionaries: '' 176733 category: 'Collections-Streams'! 176734!LimitedWriteStream commentStamp: '<historical>' prior: 0! 176735A LimitedWriteStream is a specialized WriteStream that has a maximum size of the collection it streams over. When this limit is reached a special limitBlock is executed. This can for example be used to "bail out" of lengthy streaming operations before they have finished. For a simple example take a look at the universal Object printString. 176736 176737The message SequenceableCollection class streamContents:limitedTo: creates a LimitedWriteStream. In this case it prevents very large (or possibly recursive) object structures to "overdo" their textual representation. ! 176738]style[(323 18 15 54 151)f1,f1LObject printString;,f1,f1LSequenceableCollection class streamContents:limitedTo:;,f1! 176739 176740 176741!LimitedWriteStream methodsFor: 'accessing' stamp: 'BG 3/13/2004 16:03'! 176742nextPut: anObject 176743 "Ensure that the limit is not exceeded" 176744 176745 position >= limit ifTrue: [limitBlock value] 176746 ifFalse: [super nextPut: anObject]. 176747! ! 176748 176749 176750!LimitedWriteStream methodsFor: 'as yet unclassified' stamp: 'BG 3/13/2004 13:18'! 176751nextPutAll: aCollection 176752 176753 | newEnd | 176754 collection class == aCollection class ifFalse: 176755 [^ super nextPutAll: aCollection ]. 176756 176757 newEnd := position + aCollection size. 176758 newEnd > limit ifTrue: [ 176759 super nextPutAll: (aCollection copyFrom: 1 to: (limit - position max: 0)). 176760 ^ limitBlock value. 176761 ]. 176762 newEnd > writeLimit ifTrue: [ 176763 self growTo: newEnd + 10 176764 ]. 176765 176766 collection replaceFrom: position+1 to: newEnd with: aCollection startingAt: 1. 176767 position := newEnd.! ! 176768 176769!LimitedWriteStream methodsFor: 'as yet unclassified' stamp: 'di 10/28/2001 12:49'! 176770pastEndPut: anObject 176771 collection size >= limit ifTrue: [limitBlock value]. "Exceptional return" 176772 ^ super pastEndPut: anObject! ! 176773 176774!LimitedWriteStream methodsFor: 'as yet unclassified' stamp: 'di 6/20/97 09:07'! 176775setLimit: sizeLimit limitBlock: aBlock 176776 "Limit the numer of elements this stream will write..." 176777 limit := sizeLimit. 176778 "Execute this (typically ^ contents) when that limit is exceded" 176779 limitBlock := aBlock! ! 176780Object subclass: #LimitingLineStreamWrapper 176781 instanceVariableNames: 'stream line limitingBlock position' 176782 classVariableNames: '' 176783 poolDictionaries: 'TextConstants' 176784 category: 'Collections-Streams'! 176785!LimitingLineStreamWrapper commentStamp: '<historical>' prior: 0! 176786I'm a wrapper for a stream optimized for line-by-line access using #nextLine. My instances can be nested. 176787 176788I read one line ahead. Reading terminates when the stream ends, or if the limitingBlock evaluated with the line answers true. To skip the delimiting line for further reading use #skipThisLine. 176789 176790Character-based reading (#next) is permitted, too. Send #updatePosition when switching from line-based reading. 176791 176792See examples at the class side. 176793 176794--bf 2/19/1999 12:52! 176795 176796 176797!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:25'! 176798delimiter: aString 176799 "Set limitBlock to check for a delimiting string. Be unlimiting if nil" 176800 176801 self limitingBlock: (aString caseOf: { 176802 [nil] -> [[:aLine | false]]. 176803 [''] -> [[:aLine | aLine size = 0]] 176804 } otherwise: [[:aLine | aLine beginsWith: aString]]) 176805! ! 176806 176807!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/13/1998 13:08'! 176808lastLineRead 176809 "Return line last read. At stream end, this is the boundary line or nil" 176810 176811 ^ line! ! 176812 176813!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 21:08'! 176814limitingBlock: aBlock 176815 "The limitingBlock is evaluated with a line to check if this line terminates the stream" 176816 176817 limitingBlock := aBlock. 176818 self updatePosition! ! 176819 176820!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 2/19/1999 11:45'! 176821linesUpToEnd 176822 176823 | elements ln | 176824 elements := OrderedCollection new. 176825 [(ln := self nextLine) isNil] whileFalse: [ 176826 elements add: ln]. 176827 ^elements! ! 176828 176829!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:37'! 176830next 176831 "Provide character-based access" 176832 176833 position isNil ifTrue: [^nil]. 176834 position < line size ifTrue: [^line at: (position := position + 1)]. 176835 line := stream nextLine. 176836 self updatePosition. 176837 ^ Character cr! ! 176838 176839!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:09'! 176840nextLine 176841 176842 | thisLine | 176843 self atEnd ifTrue: [^nil]. 176844 thisLine := line. 176845 line := stream nextLine. 176846 ^thisLine 176847! ! 176848 176849!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/13/1998 13:04'! 176850peekLine 176851 176852 self atEnd ifTrue: [^nil]. 176853 ^ line! ! 176854 176855!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 16:53'! 176856skipThisLine 176857 176858 line := stream nextLine. 176859 self updatePosition. 176860! ! 176861 176862!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 2/19/1999 11:47'! 176863upToEnd 176864 176865 | ln | 176866 ^String streamContents: [:strm | 176867 [(ln := self nextLine) isNil] whileFalse: [ 176868 strm nextPutAll: ln; cr]]! ! 176869 176870!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:37'! 176871updatePosition 176872 "Call this before doing character-based access" 176873 176874 position := self atEnd ifFalse: [0]! ! 176875 176876 176877!LimitingLineStreamWrapper methodsFor: 'printing' stamp: 'bf 11/24/1998 13:39'! 176878printOn: aStream 176879 176880 super printOn: aStream. 176881 aStream nextPutAll: ' on '. 176882 stream printOn: aStream! ! 176883 176884 176885!LimitingLineStreamWrapper methodsFor: 'stream protocol' stamp: 'bf 11/13/1998 17:00'! 176886close 176887 ^stream close! ! 176888 176889 176890!LimitingLineStreamWrapper methodsFor: 'testing' stamp: 'bf 11/13/1998 16:55'! 176891atEnd 176892 176893 ^line isNil or: [limitingBlock value: line]! ! 176894 176895 176896!LimitingLineStreamWrapper methodsFor: 'private' stamp: 'bf 11/24/1998 14:30'! 176897setStream: aStream delimiter: aString 176898 176899 stream := aStream. 176900 line := stream nextLine. 176901 self delimiter: aString. "sets position" 176902! ! 176903 176904"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 176905 176906LimitingLineStreamWrapper class 176907 instanceVariableNames: ''! 176908 176909!LimitingLineStreamWrapper class methodsFor: 'examples' stamp: 'bf 2/19/1999 11:48'! 176910example1 176911 "LimitingLineStreamWrapper example1" 176912 "Separate chunks of text delimited by a special string" 176913 | inStream msgStream messages | 176914 inStream := self exampleStream. 176915 msgStream := LimitingLineStreamWrapper on: inStream delimiter: 'From '. 176916 messages := OrderedCollection new. 176917 [inStream atEnd] whileFalse: [ 176918 msgStream skipThisLine. 176919 messages add: msgStream upToEnd]. 176920 ^messages 176921 ! ! 176922 176923!LimitingLineStreamWrapper class methodsFor: 'examples' stamp: 'bf 2/19/1999 12:46'! 176924example2 176925 "LimitingLineStreamWrapper example2" 176926 "Demo nesting wrappers - get header lines from some messages" 176927 | inStream msgStream headers headerStream | 176928 inStream := self exampleStream. 176929 msgStream := LimitingLineStreamWrapper on: inStream delimiter: 'From '. 176930 headers := OrderedCollection new. 176931 [inStream atEnd] whileFalse: [ 176932 msgStream skipThisLine. "Skip From" 176933 headerStream := LimitingLineStreamWrapper on: msgStream delimiter: ''. 176934 headers add: headerStream linesUpToEnd. 176935 [msgStream nextLine isNil] whileFalse. "Skip Body" 176936 ]. 176937 ^headers 176938 ! ! 176939 176940!LimitingLineStreamWrapper class methodsFor: 'examples' stamp: 'damiencassou 5/30/2008 11:45'! 176941exampleStream 176942 ^ 'From me@somewhere 176943From: me 176944To: you 176945Subject: Test 176946 176947Test 176948 176949From you@elsewhere 176950From: you 176951To: me 176952Subject: Re: test 176953 176954okay 176955' readStream! ! 176956 176957 176958!LimitingLineStreamWrapper class methodsFor: 'instance creation' stamp: 'bf 11/24/1998 14:31'! 176959on: aStream delimiter: aString 176960 176961 ^self new setStream: aStream delimiter: aString 176962! ! 176963Path subclass: #Line 176964 instanceVariableNames: '' 176965 classVariableNames: '' 176966 poolDictionaries: '' 176967 category: 'ST80-Paths'! 176968!Line commentStamp: '<historical>' prior: 0! 176969I represent the line segment specified by two points.! 176970 176971 176972!Line methodsFor: 'accessing'! 176973beginPoint 176974 "Answer the first end point of the receiver." 176975 176976 ^self first! ! 176977 176978!Line methodsFor: 'accessing'! 176979beginPoint: aPoint 176980 "Set the first end point of the receiver to be the argument, aPoint. 176981 Answer aPoint." 176982 176983 self at: 1 put: aPoint. 176984 ^aPoint! ! 176985 176986!Line methodsFor: 'accessing'! 176987endPoint 176988 "Answer the last end point of the receiver." 176989 176990 ^self last! ! 176991 176992!Line methodsFor: 'accessing'! 176993endPoint: aPoint 176994 "Set the first end point of the receiver to be the argument, aPoint. 176995 Answer aPoint." 176996 176997 self at: 2 put: aPoint. 176998 ^aPoint! ! 176999 177000 177001!Line methodsFor: 'displaying'! 177002displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm 177003 "The form associated with this Path will be displayed, according 177004 to one of the sixteen functions of two logical variables (rule), at 177005 each point on the Line. Also the source form will be first anded 177006 with aForm as a mask. Does not effect the state of the Path." 177007 177008 collectionOfPoints size < 2 ifTrue: [self error: 'a line must have two points']. 177009 aDisplayMedium 177010 drawLine: self form 177011 from: self beginPoint + aPoint 177012 to: self endPoint + aPoint 177013 clippingBox: clipRect 177014 rule: anInteger 177015 fillColor: aForm! ! 177016 177017!Line methodsFor: 'displaying'! 177018displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm 177019 177020 | newPath newLine | 177021 newPath := aTransformation applyTo: self. 177022 newLine := Line new. 177023 newLine beginPoint: newPath firstPoint. 177024 newLine endPoint: newPath secondPoint. 177025 newLine form: self form. 177026 newLine 177027 displayOn: aDisplayMedium 177028 at: 0 @ 0 177029 clippingBox: clipRect 177030 rule: anInteger 177031 fillColor: aForm! ! 177032 177033!Line methodsFor: 'displaying'! 177034displayOnPort: aPort at: aPoint 177035 aPort sourceForm: self form; combinationRule: Form under; fillColor: nil. 177036 aPort drawFrom: collectionOfPoints first + aPoint 177037 to: collectionOfPoints last + aPoint! ! 177038 177039"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 177040 177041Line class 177042 instanceVariableNames: ''! 177043 177044!Line class methodsFor: 'examples'! 177045example 177046 "Designate two places on the screen by clicking any mouse button. A 177047 straight path with a square black form will be displayed connecting the 177048 two selected points." 177049 177050 | aLine aForm | 177051 aForm := Form extent: 20@20. "make a form one quarter of inch square" 177052 aForm fillBlack. "turn it black" 177053 aLine := Line new. 177054 aLine form: aForm. "use the black form for display" 177055 aLine beginPoint: Sensor waitButton. Sensor waitNoButton. 177056 aForm displayOn: Display at: aLine beginPoint. 177057 aLine endPoint: Sensor waitButton. 177058 aLine displayOn: Display. "display the line" 177059 177060 "Line example"! ! 177061 177062 177063!Line class methodsFor: 'instance creation'! 177064from: beginPoint to: endPoint withForm: aForm 177065 "Answer an instance of me with end points begingPoint and endPoint; 177066 the source form for displaying the line is aForm." 177067 177068 | newSelf | 177069 newSelf := super new: 2. 177070 newSelf add: beginPoint. 177071 newSelf add: endPoint. 177072 newSelf form: aForm. 177073 ^newSelf! ! 177074 177075!Line class methodsFor: 'instance creation'! 177076new 177077 177078 | newSelf | 177079 newSelf := super new: 2. 177080 newSelf add: 0@0. 177081 newSelf add: 0@0. 177082 ^newSelf! ! 177083PolygonMorph subclass: #LineMorph 177084 instanceVariableNames: '' 177085 classVariableNames: '' 177086 poolDictionaries: '' 177087 category: 'Morphic-Basic'! 177088!LineMorph commentStamp: '<historical>' prior: 0! 177089This is really only a shell for creating single-segment straight-line Shapes.! 177090 177091 177092"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 177093 177094LineMorph class 177095 instanceVariableNames: ''! 177096 177097!LineMorph class methodsFor: 'instance creation' stamp: 'di 8/20/2000 12:18'! 177098from: startPoint to: endPoint color: lineColor width: lineWidth 177099 177100 ^ PolygonMorph vertices: {startPoint. endPoint} 177101 color: Color black borderWidth: lineWidth borderColor: lineColor! ! 177102 177103!LineMorph class methodsFor: 'instance creation' stamp: 'di 8/20/2000 12:16'! 177104new 177105 ^ self from: 0@0 to: 50@50 color: Color black width: 2! ! 177106 177107 177108!LineMorph class methodsFor: 'new-morph participation' stamp: 'sw 11/13/2001 14:37'! 177109newStandAlone 177110 "Answer a suitable instance for use in a parts bin, for example" 177111 177112 ^ self new setNameTo: 'Line'! ! 177113Object subclass: #LineSegment 177114 instanceVariableNames: 'start end' 177115 classVariableNames: '' 177116 poolDictionaries: '' 177117 category: 'Balloon-Geometry'! 177118!LineSegment commentStamp: '<historical>' prior: 0! 177119This class represents a straight line segment between two points 177120 177121Instance variables: 177122 start <Point> start point of the line 177123 end <Point> end point of the line 177124! 177125 177126 177127!LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'! 177128bounds 177129 "Return the bounds containing the receiver" 177130 ^(start min: end) corner: (start max: end)! ! 177131 177132!LineSegment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'! 177133degree 177134 ^1! ! 177135 177136!LineSegment methodsFor: 'accessing' stamp: 'ar 5/23/2001 19:11'! 177137direction 177138 ^end - start! ! 177139 177140!LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'! 177141end 177142 "Return the end point" 177143 ^end! ! 177144 177145!LineSegment methodsFor: 'accessing' stamp: 'ar 6/7/2003 00:10'! 177146end: aPoint 177147 end := aPoint! ! 177148 177149!LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'! 177150start 177151 "Return the start point" 177152 ^start! ! 177153 177154!LineSegment methodsFor: 'accessing' stamp: 'ar 6/7/2003 00:10'! 177155start: aPoint 177156 start := aPoint! ! 177157 177158 177159!LineSegment methodsFor: 'bezier clipping' stamp: 'ar 6/8/2003 00:06'! 177160bezierClipCurve: aCurve 177161 ^self bezierClipCurve: aCurve epsilon: 1! ! 177162 177163!LineSegment methodsFor: 'bezier clipping' stamp: 'ar 6/8/2003 00:19'! 177164bezierClipCurve: aCurve epsilon: eps 177165 "Compute the intersection of the receiver (a line) with the given curve using bezier clipping." 177166 | tMin tMax clip newCurve | 177167 clip := self bezierClipInterval: aCurve. 177168 clip ifNil:[^#()]. "no overlap" 177169 tMin := clip at: 1. 177170 tMax := clip at: 2. 177171 newCurve := aCurve curveFrom: tMin to: tMax. 177172 newCurve length < eps ifTrue:[^Array with: (aCurve valueAt: tMin + tMax * 0.5)]. 177173 (tMin < 0.001 and:[tMax > 0.999]) ifTrue:[ 177174 "Need to split aCurve before proceeding" 177175 | curve1 curve2 | 177176 curve1 := aCurve curveFrom: 0.0 to: 0.5. 177177 curve2 := aCurve curveFrom: 0.5 to: 1.0. 177178 ^(curve1 bezierClipCurve: self epsilon: eps), 177179 (curve2 bezierClipCurve: self epsilon: eps). 177180 ]. 177181 ^newCurve bezierClipCurve: self epsilon: eps.! ! 177182 177183!LineSegment methodsFor: 'bezier clipping' stamp: 'ar 6/7/2003 23:58'! 177184bezierClipInterval: aCurve 177185 "Compute the new bezier clip interval for the argument, 177186 based on the fat line (the direction aligned bounding box) of the receiver. 177187 Note: This could be modified so that multiple clip intervals are returned. 177188 The idea is that for a distance curve like 177189 177190 x x 177191 tMax---- --\-----/---\------- 177192 x x 177193 tMin------------------------- 177194 177195 all the intersections intervals with tMin/tMax are reported, therefore 177196 minimizing the iteration count. As it is, the process will slowly iterate 177197 against tMax and then the curve will be split. 177198 " 177199 | nrm tStep pts eps inside vValue vMin vMax tValue tMin tMax 177200 last lastV lastT lastInside next nextV nextT nextInside | 177201 eps := 0.00001. "distance epsilon" 177202 nrm := (start y - end y) @ (end x - start x). "normal direction for (end-start)" 177203 177204 "Map receiver's control point into fat line; compute vMin and vMax" 177205 vMin := vMax := nil. 177206 self controlPointsDo:[:pt| 177207 vValue := (nrm x * pt x) + (nrm y * pt y). "nrm dotProduct: pt." 177208 vMin == nil ifTrue:[ vMin := vMax := vValue] 177209 ifFalse:[vValue < vMin ifTrue:[vMin := vValue]. 177210 vValue > vMax ifTrue:[vMax := vValue]]]. 177211 "Map the argument into fat line; compute tMin, tMax for clip" 177212 tStep := 1.0 / aCurve degree. 177213 pts := aCurve controlPoints. 177214 last := pts at: pts size. 177215 lastV := (nrm x * last x) + (nrm y * last y). "nrm dotProduct: last." 177216 lastT := 1.0. 177217 lastInside := lastV+eps < vMin ifTrue:[-1] ifFalse:[lastV-eps > vMax ifTrue:[1] ifFalse:[0]]. 177218 177219 "Now compute new minimal and maximal clip boundaries" 177220 inside := false. "assume we're completely outside" 177221 tMin := 2.0. tMax := -1.0. "clip interval" 177222 1 to: pts size do:[:i| 177223 next := pts at: i. 177224 nextV := (nrm x * next x) + (nrm y * next y). "nrm dotProduct: next." 177225 false ifTrue:[ 177226 (nextV - vMin / (vMax - vMin)) printString displayAt: 0@ (i-1*20)]. 177227 nextT := i-1 * tStep. 177228 nextInside := nextV+eps < vMin ifTrue:[-1] ifFalse:[nextV-eps > vMax ifTrue:[1] ifFalse:[0]]. 177229 nextInside = 0 ifTrue:[ 177230 inside := true. 177231 tValue := nextT. 177232 tValue < tMin ifTrue:[tMin := tValue]. 177233 tValue > tMax ifTrue:[tMax := tValue]. 177234 ]. 177235 lastInside = nextInside ifFalse:["At least one clip boundary" 177236 inside := true. 177237 "See if one is below vMin" 177238 (lastInside + nextInside <= 0) ifTrue:[ 177239 tValue := lastT + ((nextT - lastT) * (vMin - lastV) / (nextV - lastV)). 177240 tValue < tMin ifTrue:[tMin := tValue]. 177241 tValue > tMax ifTrue:[tMax := tValue]. 177242 ]. 177243 "See if one is above vMax" 177244 (lastInside + nextInside >= 0) ifTrue:[ 177245 tValue := lastT + ((nextT - lastT) * (vMax - lastV) / (nextV - lastV)). 177246 tValue < tMin ifTrue:[tMin := tValue]. 177247 tValue > tMax ifTrue:[tMax := tValue]. 177248 ]. 177249 ]. 177250 last := next. 177251 lastT := nextT. 177252 lastV := nextV. 177253 lastInside := nextInside. 177254 ]. 177255 inside 177256 ifTrue:[^Array with: tMin with: tMax] 177257 ifFalse:[^nil]! ! 177258 177259 177260!LineSegment methodsFor: 'converting' stamp: 'ar 6/8/2003 04:19'! 177261asBezier2Points: error 177262 ^Array with: start with: start with: end! ! 177263 177264!LineSegment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:11'! 177265asBezier2Segment 177266 "Represent the receiver as quadratic bezier segment" 177267 ^Bezier2Segment from: start to: end! ! 177268 177269!LineSegment methodsFor: 'converting' stamp: 'ar 6/8/2003 15:38'! 177270asBezier2Segments: error 177271 "Demote a cubic bezier to a set of approximating quadratic beziers." 177272 | pts | 177273 pts := self asBezier2Points: error. 177274 ^(1 to: pts size by: 3) collect:[:i| 177275 Bezier2Segment from: (pts at: i) via: (pts at: i+1) to: (pts at: i+2)]. 177276! ! 177277 177278!LineSegment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:11'! 177279asIntegerSegment 177280 "Convert the receiver into integer representation" 177281 ^self species from: start asIntegerPoint to: end asIntegerPoint! ! 177282 177283!LineSegment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:11'! 177284asLineSegment 177285 "Represent the receiver as a straight line segment" 177286 ^self! ! 177287 177288!LineSegment methodsFor: 'converting' stamp: 'ar 6/7/2003 20:57'! 177289asTangentSegment 177290 ^LineSegment from: end-start to: end-start! ! 177291 177292!LineSegment methodsFor: 'converting' stamp: 'ar 6/7/2003 00:08'! 177293reversed 177294 ^self class controlPoints: self controlPoints reversed! ! 177295 177296 177297!LineSegment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:12'! 177298from: startPoint to: endPoint 177299 "Initialize the receiver" 177300 start := startPoint. 177301 end := endPoint.! ! 177302 177303!LineSegment methodsFor: 'initialize' stamp: 'ar 6/7/2003 00:09'! 177304initializeFrom: controlPoints 177305 controlPoints size = 2 ifFalse:[self error:'Wrong number of control points']. 177306 start := controlPoints at: 1. 177307 end := controlPoints at: 2.! ! 177308 177309 177310!LineSegment methodsFor: 'intersection' stamp: 'nk 3/29/2002 22:30'! 177311intersectionWith: anotherSegment 177312 "Copied from LineIntersections>>intersectFrom:to:with:to:" 177313 | det deltaPt alpha beta pt1Dir pt2Dir | 177314 pt1Dir := end - start. 177315 pt2Dir := anotherSegment end - anotherSegment start. 177316 det := (pt1Dir x * pt2Dir y) - (pt1Dir y * pt2Dir x). 177317 deltaPt := anotherSegment start - start. 177318 alpha := (deltaPt x * pt2Dir y) - (deltaPt y * pt2Dir x). 177319 beta := (deltaPt x * pt1Dir y) - (deltaPt y * pt1Dir x). 177320 det = 0 ifTrue:[^nil]. "no intersection" 177321 alpha * det < 0 ifTrue:[^nil]. 177322 beta * det < 0 ifTrue:[^nil]. 177323 det > 0 177324 ifTrue:[(alpha > det or:[beta > det]) ifTrue:[^nil]] 177325 ifFalse:[(alpha < det or:[beta < det]) ifTrue:[^nil]]. 177326 "And compute intersection" 177327 ^start + (alpha * pt1Dir / (det@det))! ! 177328 177329!LineSegment methodsFor: 'intersection' stamp: 'nk 12/27/2003 13:00'! 177330roundTo: quantum 177331 start := start roundTo: quantum. 177332 end := end roundTo: quantum.! ! 177333 177334 177335!LineSegment methodsFor: 'printing' stamp: 'ar 11/2/1998 12:13'! 177336printOn: aStream 177337 "Print the receiver on aStream" 177338 aStream 177339 nextPutAll: self class name; 177340 nextPutAll:' from: '; 177341 print: start; 177342 nextPutAll: ' to: '; 177343 print: end; 177344 space.! ! 177345 177346 177347!LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:12'! 177348hasZeroLength 177349 "Return true if the receiver has zero length" 177350 ^start = end! ! 177351 177352!LineSegment methodsFor: 'testing' stamp: 'ar 6/8/2003 01:03'! 177353isArcSegment 177354 "Answer whether I approximate an arc segment reasonably well" 177355 | mid v1 v2 d1 d2 center | 177356 start = end ifTrue:[^false]. 177357 mid := self valueAt: 0.5. 177358 v1 := (start + mid) * 0.5. 177359 v2 := (mid + end) * 0.5. 177360 d1 := mid - start. d1 := d1 y @ d1 x negated. 177361 d2 := end - mid. d2 := d2 y @ d2 x negated. 177362 177363 center := LineSegment 177364 intersectFrom: v1 with: d1 to: v2 with: d2. 177365 177366 "Now see if the tangents are 'reasonably close' to the circle" 177367 d1 := (start - center) normalized dotProduct: self tangentAtStart normalized. 177368 d1 abs > 0.02 ifTrue:[^false]. 177369 d1 := (end - center) normalized dotProduct: self tangentAtEnd normalized. 177370 d1 abs > 0.02 ifTrue:[^false]. 177371 d1 := (mid - center) normalized dotProduct: self tangentAtMid normalized. 177372 d1 abs > 0.02 ifTrue:[^false]. 177373 177374 ^true! ! 177375 177376!LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:07'! 177377isBezier2Segment 177378 "Return true if the receiver is a quadratic bezier segment" 177379 ^false! ! 177380 177381!LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:07'! 177382isLineSegment 177383 "Return true if the receiver is a line segment" 177384 ^true! ! 177385 177386!LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:08'! 177387isStraight 177388 "Return true if the receiver represents a straight line" 177389 ^true! ! 177390 177391 177392!LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:15'! 177393asBezier2Curves: err 177394 ^Array with: self! ! 177395 177396!LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:08'! 177397controlPoints 177398 ^{start. end}! ! 177399 177400!LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:39'! 177401controlPointsDo: aBlock 177402 aBlock value: start; value: end! ! 177403 177404!LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:48'! 177405curveFrom: parameter1 to: parameter2 177406 "Create a new segment like the receiver but starting/ending at the given parametric values" 177407 | delta | 177408 delta := end - start. 177409 ^self clone from: delta * parameter1 + start to: delta * parameter2 + start! ! 177410 177411!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:08'! 177412length 177413 "Return the length of the receiver" 177414 ^start dist: end! ! 177415 177416!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:08'! 177417lineSegmentsDo: aBlock 177418 "Evaluate aBlock with the receiver's line segments" 177419 aBlock value: start value: end! ! 177420 177421!LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 17:21'! 177422lineSegments: steps do: aBlock 177423 "Evaluate aBlock with the receiver's line segments" 177424 aBlock value: start value: end! ! 177425 177426!LineSegment methodsFor: 'vector functions' stamp: 'ar 5/23/2001 18:27'! 177427sideOfPoint: aPoint 177428 "Return the side of the receiver this point is on. The method returns 177429 -1: if aPoint is left 177430 0: if aPoint is on 177431 +1: if a point is right 177432 of the receiver." 177433 | dx dy px py | 177434 dx := end x - start x. 177435 dy := end y - start y. 177436 px := aPoint x - start x. 177437 py := aPoint y - start y. 177438 ^((dx * py) - (px * dy)) sign 177439" 177440 (LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@-50. 177441 (LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@50. 177442 (LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@0. 177443" 177444! ! 177445 177446!LineSegment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:54'! 177447tangentAtMid 177448 "Return the tangent for the last point" 177449 ^(end - start)! ! 177450 177451!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'! 177452tangentAt: parameter 177453 "Return the tangent at the given parametric value along the receiver" 177454 ^end - start! ! 177455 177456!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'! 177457tangentAtEnd 177458 "Return the tangent for the last point" 177459 ^(end - start)! ! 177460 177461!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'! 177462tangentAtStart 177463 "Return the tangent for the last point" 177464 ^(end - start)! ! 177465 177466!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'! 177467valueAt: parameter 177468 "Evaluate the receiver at the given parametric value" 177469 ^start + (end - start * parameter)! ! 177470 177471!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:10'! 177472valueAtEnd 177473 "Evaluate the receiver at it's end point (e.g., self valueAtEnd = (self valueAt: 1.0))" 177474 ^end! ! 177475 177476!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:10'! 177477valueAtStart 177478 "Evaluate the receiver at it's start point (e.g., self valueAtEnd = (self valueAt: 0.0))" 177479 ^start! ! 177480 177481 177482!LineSegment methodsFor: 'private' stamp: 'ar 6/7/2003 21:00'! 177483debugDraw 177484 ^self debugDrawAt: 0@0.! ! 177485 177486!LineSegment methodsFor: 'private' stamp: 'ar 6/7/2003 21:00'! 177487debugDrawAt: offset 177488 | canvas | 177489 canvas := Display getCanvas. 177490 canvas translateBy: offset during:[:aCanvas| 177491 self lineSegmentsDo:[:p1 :p2| 177492 aCanvas line: p1 rounded to: p2 rounded width: 1 color: Color black. 177493 ]. 177494 ].! ! 177495 177496"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 177497 177498LineSegment class 177499 instanceVariableNames: ''! 177500 177501!LineSegment class methodsFor: 'geometry' stamp: 'nk 8/19/2003 17:17'! 177502fromPoints: pts 177503 ^self from: pts first to: pts third via: pts second! ! 177504 177505!LineSegment class methodsFor: 'geometry' stamp: 'nk 8/19/2003 17:15'! 177506from: startPoint to: endPoint via: via 177507 (startPoint = via or: [ endPoint = via ]) ifTrue: [ ^self new from: startPoint to: endPoint ]. 177508 ^Bezier2Segment from: startPoint to: endPoint via: via! ! 177509 177510 177511!LineSegment class methodsFor: 'instance creation' stamp: 'ar 6/7/2003 00:09'! 177512controlPoints: anArray 177513 "Create a new instance of the receiver from the given control points" 177514 anArray size = 2 ifTrue:[^LineSegment new initializeFrom: anArray]. 177515 anArray size = 3 ifTrue:[^Bezier2Segment new initializeFrom: anArray]. 177516 anArray size = 4 ifTrue:[^Bezier3Segment new initializeFrom: anArray]. 177517 self error:'Unsupported'.! ! 177518 177519!LineSegment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:10'! 177520from: startPoint to: endPoint 177521 ^self new from: startPoint to: endPoint! ! 177522 177523 177524!LineSegment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 00:49'! 177525intersectFrom: startPt with: startDir to: endPt with: endDir 177526 "Compute the intersection of two lines, e.g., compute alpha and beta for 177527 startPt + (alpha * startDir) = endPt + (beta * endDir). 177528 Reformulating this yields 177529 (alpha * startDir) - (beta * endDir) = endPt - startPt. 177530 or 177531 (alpha * startDir) + (-beta * endDir) = endPt - startPt. 177532 or 177533 (alpha * startDir x) + (-beta * endDir x) = endPt x - startPt x. 177534 (alpha * startDir y) + (-beta * endDir y) = endPt y - startPt y. 177535 which is trivial to solve using Cramer's rule. Note that since 177536 we're really only interested in the intersection point we need only 177537 one of alpha or beta since the resulting intersection point can be 177538 computed based on either one." 177539 | det deltaPt alpha | 177540 det := (startDir x * endDir y) - (startDir y * endDir x). 177541 det = 0.0 ifTrue:[^nil]. "There's no solution for it" 177542 deltaPt := endPt - startPt. 177543 alpha := (deltaPt x * endDir y) - (deltaPt y * endDir x). 177544 alpha := alpha / det. 177545 "And compute intersection" 177546 ^startPt + (alpha * startDir)! ! 177547Path subclass: #LinearFit 177548 instanceVariableNames: '' 177549 classVariableNames: '' 177550 poolDictionaries: '' 177551 category: 'ST80-Paths'! 177552!LinearFit commentStamp: '<historical>' prior: 0! 177553I represent a piece-wise linear approximation to a set of points in the plane.! 177554 177555 177556!LinearFit methodsFor: 'displaying' stamp: 'jrm 9/7/1999 22:16'! 177557displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger 177558fillColor: aForm 177559 177560 | line | 177561 line := Line new. 177562 line form: self form. 177563 1 to: self size - 1 do: 177564 [:i | 177565 line beginPoint: (self at: i). 177566 line endPoint: (self at: i + 1). 177567 line displayOn: aDisplayMedium 177568 at: aPoint 177569 clippingBox: clipRect 177570 rule: anInteger 177571 fillColor: aForm]! ! 177572 177573!LinearFit methodsFor: 'displaying' stamp: 'jrm 9/7/1999 23:00'! 177574displayOn: aDisplayMedium transformation: aTransformation clippingBox: 177575clipRect rule: anInteger fillColor: aForm 177576 177577 | transformedPath | 177578 "get the scaled and translated Path." 177579 transformedPath := aTransformation applyTo: self. 177580 transformedPath 177581 displayOn: aDisplayMedium 177582 at: 0 @ 0 177583 clippingBox: clipRect 177584 rule: anInteger 177585 fillColor: aForm! ! 177586 177587"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 177588 177589LinearFit class 177590 instanceVariableNames: ''! 177591 177592!LinearFit class methodsFor: 'examples'! 177593example 177594 "Select points on a Path using the red button. Terminate by selecting 177595 any other button. Creates a Path from the points and displays it as a 177596 piece-wise linear approximation." 177597 177598 | aLinearFit aForm flag | 177599 aLinearFit := LinearFit new. 177600 aForm := Form extent: 1 @ 40. 177601 aForm fillBlack. 177602 aLinearFit form: aForm. 177603 flag := true. 177604 [flag] whileTrue: 177605 [Sensor waitButton. 177606 Sensor redButtonPressed 177607 ifTrue: [aLinearFit add: Sensor waitButton. Sensor waitNoButton. 177608 aForm displayOn: Display at: aLinearFit last] 177609 ifFalse: [flag:=false]]. 177610 aLinearFit displayOn: Display 177611 177612 "LinearFit example"! ! 177613TTCFont subclass: #LinedTTCFont 177614 instanceVariableNames: 'emphasis lineGlyph contourWidth' 177615 classVariableNames: '' 177616 poolDictionaries: '' 177617 category: 'Multilingual-Display'! 177618 177619!LinedTTCFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:11'! 177620computeForm: char 177621 177622 | ttGlyph scale | 177623 177624 char = Character tab ifTrue: [^ super computeForm: char]. 177625 177626 "char = $U ifTrue: [self doOnlyOnce: [self halt]]." 177627 scale := self pixelSize asFloat / (ttcDescription ascender - ttcDescription descender). 177628 ttGlyph := ttcDescription at: char. 177629 ^ ttGlyph asFormWithScale: scale ascender: ttcDescription ascender descender: ttcDescription descender fgColor: foregroundColor bgColor: Color transparent depth: self depth replaceColor: false lineGlyph: lineGlyph lingGlyphWidth: contourWidth emphasis: emphasis! ! 177630 177631!LinedTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 5/6/2004 19:56'! 177632emphasis 177633 177634 ^ emphasis. 177635! ! 177636 177637!LinedTTCFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:11'! 177638emphasis: code 177639 177640 emphasis := code. 177641! ! 177642 177643!LinedTTCFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:11'! 177644lineGlyph: aGlyph 177645 177646 lineGlyph := aGlyph. 177647 contourWidth := aGlyph calculateWidth. 177648! ! 177649 177650"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 177651 177652LinedTTCFont class 177653 instanceVariableNames: ''! 177654 177655!LinedTTCFont class methodsFor: 'as yet unclassified' stamp: 'ar 11/14/2006 15:18'! 177656fromTTCFont: aTTCFont emphasis: code 177657 177658 | inst | 177659 inst := self new. 177660 inst ttcDescription: aTTCFont ttcDescription. 177661 inst pointSize: aTTCFont pointSize. 177662 inst emphasis: (aTTCFont emphasis bitOr: code). 177663 inst lineGlyph: (aTTCFont ttcDescription at: $_). 177664 177665 ^ inst. 177666! ! 177667Object subclass: #Link 177668 instanceVariableNames: 'nextLink' 177669 classVariableNames: '' 177670 poolDictionaries: '' 177671 category: 'Collections-Support'! 177672!Link commentStamp: '<historical>' prior: 0! 177673An instance of me is a simple record of a pointer to another Link. I am an abstract class; my concrete subclasses, for example, Process, can be stored in a LinkedList structure.! 177674 177675 177676!Link methodsFor: 'accessing'! 177677nextLink 177678 "Answer the link to which the receiver points." 177679 177680 ^nextLink! ! 177681 177682!Link methodsFor: 'accessing'! 177683nextLink: aLink 177684 "Store the argument, aLink, as the link to which the receiver refers. 177685 Answer aLink." 177686 177687 ^nextLink := aLink! ! 177688 177689"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 177690 177691Link class 177692 instanceVariableNames: ''! 177693 177694!Link class methodsFor: 'instance creation' stamp: 'apb 10/3/2000 15:55'! 177695nextLink: aLink 177696 "Answer an instance of me referring to the argument, aLink." 177697 177698 ^self new nextLink: aLink; yourself! ! 177699SequenceableCollection subclass: #LinkedList 177700 instanceVariableNames: 'firstLink lastLink' 177701 classVariableNames: '' 177702 poolDictionaries: '' 177703 category: 'Collections-Sequenceable'! 177704!LinkedList commentStamp: '<historical>' prior: 0! 177705I represent a collection of links, which are containers for other objects. Using the message sequence addFirst:/removeLast causes the receiver to behave as a stack; using addLast:/removeFirst causes the receiver to behave as a queue.! 177706 177707 177708!LinkedList methodsFor: 'accessing' stamp: 'ajh 8/6/2002 15:46'! 177709at: index 177710 177711 | i | 177712 i := 0. 177713 self do: [:link | 177714 (i := i + 1) = index ifTrue: [^ link]]. 177715 ^ self errorSubscriptBounds: index! ! 177716 177717!LinkedList methodsFor: 'accessing'! 177718first 177719 "Answer the first link. Create an error notification if the receiver is 177720 empty." 177721 177722 self emptyCheck. 177723 ^firstLink! ! 177724 177725!LinkedList methodsFor: 'accessing'! 177726last 177727 "Answer the last link. Create an error notification if the receiver is 177728 empty." 177729 177730 self emptyCheck. 177731 ^lastLink! ! 177732 177733 177734!LinkedList methodsFor: 'adding'! 177735add: aLink 177736 "Add aLink to the end of the receiver's list. Answer aLink." 177737 177738 ^self addLast: aLink! ! 177739 177740!LinkedList methodsFor: 'adding' stamp: 'nice 7/28/2008 22:37'! 177741add: link after: otherLink 177742 177743 "Add otherLink after link in the list. Answer aLink." 177744 177745 | savedLink | 177746 lastLink == otherLink ifTrue: [^ self addLast: link]. 177747 savedLink := otherLink nextLink. 177748 otherLink nextLink: link. 177749 link nextLink: savedLink. 177750 ^link.! ! 177751 177752!LinkedList methodsFor: 'adding' stamp: 'ajh 8/22/2002 14:17'! 177753add: link before: otherLink 177754 177755 | aLink | 177756 firstLink == otherLink ifTrue: [^ self addFirst: link]. 177757 aLink := firstLink. 177758 [aLink == nil] whileFalse: [ 177759 aLink nextLink == otherLink ifTrue: [ 177760 link nextLink: aLink nextLink. 177761 aLink nextLink: link. 177762 ^ link 177763 ]. 177764 aLink := aLink nextLink. 177765 ]. 177766 ^ self errorNotFound: otherLink! ! 177767 177768!LinkedList methodsFor: 'adding'! 177769addFirst: aLink 177770 "Add aLink to the beginning of the receiver's list. Answer aLink." 177771 177772 self isEmpty ifTrue: [lastLink := aLink]. 177773 aLink nextLink: firstLink. 177774 firstLink := aLink. 177775 ^aLink! ! 177776 177777!LinkedList methodsFor: 'adding'! 177778addLast: aLink 177779 "Add aLink to the end of the receiver's list. Answer aLink." 177780 177781 self isEmpty 177782 ifTrue: [firstLink := aLink] 177783 ifFalse: [lastLink nextLink: aLink]. 177784 lastLink := aLink. 177785 ^aLink! ! 177786 177787 177788!LinkedList methodsFor: 'enumerating'! 177789do: aBlock 177790 177791 | aLink | 177792 aLink := firstLink. 177793 [aLink == nil] whileFalse: 177794 [aBlock value: aLink. 177795 aLink := aLink nextLink]! ! 177796 177797!LinkedList methodsFor: 'enumerating' stamp: 'ajh 8/6/2002 16:39'! 177798species 177799 177800 ^ Array! ! 177801 177802 177803!LinkedList methodsFor: 'removing'! 177804remove: aLink ifAbsent: aBlock 177805 "Remove aLink from the receiver. If it is not there, answer the result of 177806 evaluating aBlock." 177807 177808 | tempLink | 177809 aLink == firstLink 177810 ifTrue: [firstLink := aLink nextLink. 177811 aLink == lastLink 177812 ifTrue: [lastLink := nil]] 177813 ifFalse: [tempLink := firstLink. 177814 [tempLink == nil ifTrue: [^aBlock value]. 177815 tempLink nextLink == aLink] 177816 whileFalse: [tempLink := tempLink nextLink]. 177817 tempLink nextLink: aLink nextLink. 177818 aLink == lastLink 177819 ifTrue: [lastLink := tempLink]]. 177820 aLink nextLink: nil. 177821 ^aLink! ! 177822 177823!LinkedList methodsFor: 'removing' stamp: 'nice 1/10/2009 00:23'! 177824removeAll 177825 "Implementation note: this has to be fast" 177826 177827 firstLink := lastLink := nil! ! 177828 177829!LinkedList methodsFor: 'removing'! 177830removeFirst 177831 "Remove the first element and answer it. If the receiver is empty, create 177832 an error notification." 177833 177834 | oldLink | 177835 self emptyCheck. 177836 oldLink := firstLink. 177837 firstLink == lastLink 177838 ifTrue: [firstLink := nil. lastLink := nil] 177839 ifFalse: [firstLink := oldLink nextLink]. 177840 oldLink nextLink: nil. 177841 ^oldLink! ! 177842 177843!LinkedList methodsFor: 'removing'! 177844removeLast 177845 "Remove the receiver's last element and answer it. If the receiver is 177846 empty, create an error notification." 177847 177848 | oldLink aLink | 177849 self emptyCheck. 177850 oldLink := lastLink. 177851 firstLink == lastLink 177852 ifTrue: [firstLink := nil. lastLink := nil] 177853 ifFalse: [aLink := firstLink. 177854 [aLink nextLink == oldLink] whileFalse: 177855 [aLink := aLink nextLink]. 177856 aLink nextLink: nil. 177857 lastLink := aLink]. 177858 oldLink nextLink: nil. 177859 ^oldLink! ! 177860 177861 177862!LinkedList methodsFor: 'testing' stamp: 'marcus.denker 9/14/2008 18:58'! 177863isEmpty 177864 177865 ^firstLink isNil! ! 177866TestCase subclass: #LinkedListTest 177867 uses: TAddTest - {#testTAddWithOccurences. #testTAddTwice. #testTWriteTwice} + TEmptyTest + TIterateTest + TIterateSequencedReadableTest + TPrintTest + TAsStringCommaAndDelimiterSequenceableTest + TIndexAccess + TSequencedElementAccessTest + TSubCollectionAccess + TConvertTest - {#testAsByteArray. #integerCollectionWithoutEqualElements} + TCopyPartOfSequenceable - {#testCopyEmptyMethod} + TCopySequenceableSameContents - {#testSortBy. #integerCollection} + TCopySequenceableWithOrWithoutSpecificElements + TCopyTest + TCopySequenceableWithReplacement - {#testCopyReplaceAllWithManyOccurence. #collectionWith2TimeSubcollection} + TBeginsEndsWith + TRemoveTest + TSetArithmetic + TIncludesWithIdentityCheckTest + TStructuralEqualityTest + TOccurrencesTest 177868 instanceVariableNames: 'nextLink n list link1 link2 link3 link4 nonEmpty otherList link result collectionWithNil collectionWithoutNil nonEmpty1Element collectionWithoutEqualElements elementNotIn elementIn sameAtendAndBegining collection5Elements' 177869 classVariableNames: '' 177870 poolDictionaries: '' 177871 category: 'CollectionsTests-Sequenceable'! 177872!LinkedListTest commentStamp: 'mk 8/3/2005 11:55' prior: 0! 177873A set of test cases which thoroughly test functionality of the LinkedList class.! 177874 177875 177876!LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:47'! 177877n 177878 ^n! ! 177879 177880!LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:46'! 177881nextLink 177882 ^nextLink! ! 177883 177884!LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:46'! 177885nextLink: aLink 177886 nextLink := aLink! ! 177887 177888!LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:47'! 177889n: number 177890 n := number. 177891 ! ! 177892 177893 177894!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 16:46'! 177895accessCollection 177896 ^collectionWithoutEqualElements ! ! 177897 177898!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:52'! 177899anotherElementNotIn 177900" return an element included in 'collection' " 177901 ^ elementNotIn ! ! 177902 177903!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:03'! 177904anotherElementOrAssociationIn 177905 " return an element (or an association for Dictionary ) present in 'collection' " 177906 ^ self collection anyOne! ! 177907 177908!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:04'! 177909anotherElementOrAssociationNotIn 177910 " return an element (or an association for Dictionary )not present in 'collection' " 177911 ^ elementNotIn ! ! 177912 177913!LinkedListTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 19:10'! 177914collection 177915 ^ self nonEmpty! ! 177916 177917!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:49'! 177918collectionClass 177919" return the class to be used to create instances of the class tested" 177920 ^ LinkedList! ! 177921 177922!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:14'! 177923collectionMoreThan1NoDuplicates 177924 " return a collection of size 5 without equal elements" 177925 ^ collectionWithoutEqualElements! ! 177926 177927!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:17'! 177928collectionNotIncluded 177929" return a collection for wich each element is not included in 'nonEmpty' " 177930 ^ collectionWithoutNil ! ! 177931 177932!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:37'! 177933collectionWith1TimeSubcollection 177934" return a collection including 'oldSubCollection' only one time " 177935 ^ self oldSubCollection ! ! 177936 177937!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! 177938collectionWithCopyNonIdentical 177939 " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" 177940 ^ collectionWithoutEqualElements! ! 177941 177942!LinkedListTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 16:14'! 177943collectionWithElement 177944 "Returns a collection that already includes what is returned by #element." 177945 ^ self collection! ! 177946 177947!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:17'! 177948collectionWithElementsToRemove 177949" return a collection of elements included in 'nonEmpty' " 177950 ^ self nonEmpty ! ! 177951 177952!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:14'! 177953collectionWithSortableElements 177954 " return a collection only including elements that can be sorted (understanding '<' )" 177955 ^ collection5Elements ! ! 177956 177957!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:03'! 177958collectionWithoutEqualElements 177959" return a collection without equal elements" 177960 ^collectionWithoutEqualElements ! ! 177961 177962!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:55'! 177963collectionWithoutEqualsElements 177964 177965" return a collection not including equal elements " 177966 ^collectionWithoutEqualElements ! ! 177967 177968!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 17:07'! 177969collectionWithoutNilElements 177970" return a collection that doesn't includes a nil element " 177971 ^collectionWithoutNil ! ! 177972 177973!LinkedListTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 16:21'! 177974element 177975 ^ link ifNil: [link := StackLink with: 42. "so that we can recognize this link"]! ! 177976 177977!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 16:46'! 177978elementInForElementAccessing 177979" return an element inculded in 'accessCollection '" 177980 ^ elementIn ! ! 177981 177982!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 16:27'! 177983elementInForIndexAccessing 177984" return an element included in 'accessCollection' " 177985 ^ elementIn ! ! 177986 177987!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 15:31'! 177988elementNotIn 177989 ^ Link new! ! 177990 177991!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 16:46'! 177992elementNotInForElementAccessing 177993" return an element not included in 'accessCollection' " 177994 ^ elementNotIn ! ! 177995 177996!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:10'! 177997elementNotInForIndexAccessing 177998" return an element not included in 'accessCollection' " 177999 ^ elementNotIn ! ! 178000 178001!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:07'! 178002elementNotInForOccurrences 178003" return an element notIncluded in #collectionWithoutEqualElements" 178004 ^ elementNotIn ! ! 178005 178006!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:17'! 178007elementToAdd 178008" return an element of type 'nonEmpy' elements'type'" 178009 ^ Link new! ! 178010 178011!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:55'! 178012indexInForCollectionWithoutDuplicates 178013" return an index between 'collectionWithoutEqualsElements' bounds" 178014 ^ 2! ! 178015 178016!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:09'! 178017indexInNonEmpty 178018" return an index between bounds of 'nonEmpty' " 178019 178020 ^ self nonEmpty size! ! 178021 178022!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:52'! 178023moreThan3Elements 178024 " return a collection including atLeast 3 elements" 178025 ^ collectionWithoutEqualElements ! ! 178026 178027!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:52'! 178028moreThan4Elements 178029 178030" return a collection including at leat 4 elements" 178031 ^ collectionWithoutEqualElements ! ! 178032 178033!LinkedListTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 19:11'! 178034nonEmpty 178035 ^ nonEmpty ifNil: [nonEmpty := LinkedList with: self element with: Link new]! ! 178036 178037!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 14:14'! 178038nonEmpty1Element 178039" return a collection of size 1 including one element" 178040 ^ nonEmpty1Element ! ! 178041 178042!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 14:09'! 178043nonEmptyMoreThan1Element 178044" return a collection that don't includes equl elements'" 178045 ^collectionWithoutNil ! ! 178046 178047!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:30'! 178048nonEmptyWithoutEqualElements 178049" return a collection without equal elements " 178050 ^ collectionWithoutEqualElements ! ! 178051 178052!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:36'! 178053oldSubCollection 178054" return a subCollection included in collectionWith1TimeSubcollection . 178055ex : subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)" 178056 ^ self nonEmpty ! ! 178057 178058!LinkedListTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 16:22'! 178059otherCollection 178060 ^ otherList ifNil: [otherList := LinkedList with: Link new with: Link new]! ! 178061 178062!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:36'! 178063replacementCollection 178064" return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection' " 178065 ^ collectionWithoutNil ! ! 178066 178067!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 15:43'! 178068result 178069 "Returns a collection of the classes of elements in #collection" 178070 ^ result! ! 178071 178072!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 10:23'! 178073resultForCollectElementsClass 178074" return the retsult expected by collecting the class of each element of collectionWithoutNilElements" 178075 ^ result .! ! 178076 178077!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 15:32'! 178078speciesClass 178079 178080 ^LinkedList! ! 178081 178082!LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 16:47'! 178083subCollectionNotIn 178084" return a collection for which at least one element is not included in 'accessCollection' " 178085 ^ collectionWithoutNil ! ! 178086 178087 178088!LinkedListTest methodsFor: 'running' stamp: 'delaunay 5/14/2009 14:13'! 178089setUp 178090 178091 super setUp. 178092 list := LinkedList new. 178093 link1 := Link new. 178094 link2 := Link new. 178095 link3 := Link new. 178096 link4 := Link new. 178097 elementNotIn := Link new. 178098 collectionWithoutNil := LinkedList new add: Link new; add: Link new ; add: Link new; yourself. 178099 elementIn := Link new. 178100 collectionWithoutEqualElements := LinkedList new add: elementIn ; add: Link new ; add: Link new; add: Link new;add: Link new;yourself. 178101 collection5Elements := collectionWithoutEqualElements . 178102 178103 "sameAtendAndBegining := LinkedList new add: Link new; add: Link new ; add: Link new; yourself." 178104 result := {Link. Link. Link.}. 178105 link := StackLink with: 42. 178106 nonEmpty1Element := LinkedList new add: Link new; yourself. 178107 "so that we can recognize this link" 178108 "nonEmpty := LinkedList with: link with: Link new." 178109 "otherList := LinkedList with: Link new with: Link new." 178110! ! 178111 178112!LinkedListTest methodsFor: 'running' stamp: 'damien.pollet 10/31/2008 14:48'! 178113tearDown 178114 list := nil. 178115 link1 := nil. 178116 link2 := nil. 178117 link3 := nil. 178118 link4 := nil. 178119 178120 link := nil. 178121 nonEmpty := nil. 178122 otherList := nil. 178123 178124 ^ super tearDown! ! 178125 178126 178127!LinkedListTest methodsFor: 'test - equality'! 178128testEqualSign 178129 "self debug: #testEqualSign" 178130 178131 self deny: (self empty = self nonEmpty).! ! 178132 178133!LinkedListTest methodsFor: 'test - equality'! 178134testEqualSignIsTrueForNonIdenticalButEqualCollections 178135 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 178136 178137 self assert: (self empty = self empty copy). 178138 self assert: (self empty copy = self empty). 178139 self assert: (self empty copy = self empty copy). 178140 178141 self assert: (self nonEmpty = self nonEmpty copy). 178142 self assert: (self nonEmpty copy = self nonEmpty). 178143 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 178144 178145!LinkedListTest methodsFor: 'test - equality'! 178146testEqualSignOfIdenticalCollectionObjects 178147 "self debug: #testEqualSignOfIdenticalCollectionObjects" 178148 178149 self assert: (self empty = self empty). 178150 self assert: (self nonEmpty = self nonEmpty). 178151 ! ! 178152 178153 178154!LinkedListTest methodsFor: 'test - fixture'! 178155test0FixtureIterateTest 178156 178157 178158| res | 178159self shouldnt: [ self collectionWithoutNilElements ] raise: Error. 178160 178161self assert: ( self collectionWithoutNilElements occurrencesOf: nil) = 0. 178162 178163res := true. 178164self collectionWithoutNilElements 178165 detect: [ :each | (self collectionWithoutNilElements occurrencesOf: each) > 1 ] 178166 ifNone: [ res := false ]. 178167self assert: res = false.! ! 178168 178169 178170!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:04'! 178171test01add 178172 self assert: list isEmpty. 178173 list add: link1. 178174 self assert: list size = 1. 178175 self assert: list first = link1. 178176 178177 list add: link2. 178178 self assert: list size = 2. 178179 self assert: list first = link1. 178180 self assert: list second = link2. 178181 178182 list add: link3. 178183 self assert: list size = 3. 178184 self assert: list first = link1. 178185 self assert: list second = link2. 178186 self assert: list third = link3. 178187 178188 list add: link4. 178189 self assert: list size = 4. 178190 self assert: list first = link1. 178191 self assert: list second = link2. 178192 self assert: list third = link3. 178193 self assert: list fourth = link4! ! 178194 178195!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:04'! 178196test02addLast 178197 self assert: list isEmpty. 178198 178199 list addLast: link1. 178200 self assert: list size = 1. 178201 self assert: list first = link1. 178202 178203 list addLast: link2. 178204 self assert: list size = 2. 178205 self assert: list first = link1. 178206 self assert: list second = link2. 178207 178208 list addLast: link3. 178209 self assert: list size = 3. 178210 self assert: list first = link1. 178211 self assert: list second = link2. 178212 self assert: list third = link3. 178213 178214 list addLast: link4. 178215 self assert: list size = 4. 178216 self assert: list first = link1. 178217 self assert: list second = link2. 178218 self assert: list third = link3. 178219 self assert: list fourth = link4! ! 178220 178221!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:04'! 178222test03addFirst 178223 self assert: list isEmpty. 178224 178225 list addFirst: link1. 178226 self assert: list size = 1. 178227 self assert: list first = link1. 178228 178229 list addFirst: link2. 178230 self assert: list size = 2. 178231 self assert: list first = link2. 178232 self assert: list second = link1. 178233 178234 list addFirst: link3. 178235 self assert: list size = 3. 178236 self assert: list first = link3. 178237 self assert: list second = link2. 178238 self assert: list third = link1. 178239 178240 list addFirst: link4. 178241 self assert: list size = 4. 178242 self assert: list first = link4. 178243 self assert: list second = link3. 178244 self assert: list third = link2. 178245 self assert: list fourth = link1! ! 178246 178247!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:05'! 178248test04addBefore 178249 self assert: list isEmpty. 178250 178251 list add: link1. 178252 self assert: list size = 1. 178253 self assert: list first == link1. 178254 178255 list add: link2 before: link1. 178256 self assert: list size = 2. 178257 self assert: list first == link2. 178258 self assert: list second == link1. 178259 178260 list add: link3 before: link1. 178261 self assert: list size = 3. 178262 self assert: list first == link2. 178263 self assert: list second == link3. 178264 self assert: list third == link1. 178265 178266 list add: link4 before: link1. 178267 self assert: list size = 4. 178268 self assert: list first == link2. 178269 self assert: list second == link3. 178270 self assert: list third == link4. 178271 self assert: list fourth == link1! ! 178272 178273!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:05'! 178274test05addBefore 178275 self assert: list isEmpty. 178276 178277 list add: link1. 178278 self assert: list size = 1. 178279 self assert: list first == link1. 178280 178281 list add: link2 before: link1. 178282 self assert: list size = 2. 178283 self assert: list first == link2. 178284 self assert: list second == link1. 178285 178286 list add: link3 before: link2. 178287 self assert: list size = 3. 178288 self assert: list first == link3. 178289 self assert: list second == link2. 178290 self assert: list third == link1. 178291 178292 list add: link4 before: link3. 178293 self assert: list size = 4. 178294 self assert: list first == link4. 178295 self assert: list second == link3. 178296 self assert: list third == link2. 178297 self assert: list fourth == link1! ! 178298 178299!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:05'! 178300test06addAfter 178301 self assert: list isEmpty. 178302 178303 list add: link1. 178304 self assert: list size = 1. 178305 self assert: list first == link1. 178306 178307 list add: link2 after: link1. 178308 self assert: list size = 2. 178309 self assert: list first == link1. 178310 self assert: list second == link2. 178311 178312 list add: link3 after: link2. 178313 self assert: list size = 3. 178314 self assert: list first == link1. 178315 self assert: list second == link2. 178316 self assert: list third == link3. 178317 178318 list add: link4 after: link3. 178319 self assert: list size = 4. 178320 self assert: list first == link1. 178321 self assert: list second == link2. 178322 self assert: list third == link3. 178323 self assert: list fourth == link4! ! 178324 178325!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:10'! 178326test07addAfter 178327 self assert: list isEmpty. 178328 178329 list add: link1. 178330 self assert: list size = 1. 178331 self assert: list first == link1. 178332 178333 list add: link2 after: link1. 178334 self assert: list size = 2. 178335 self assert: list first == link1. 178336 self assert: list second == link2. 178337 178338 list add: link3 after: link1. 178339 self assert: list size = 3. 178340 self assert: list first == link1. 178341 self assert: list second == link3. 178342 self assert: list third == link2. 178343 178344 list add: link4 after: link1. 178345 self assert: list size = 4. 178346 self assert: list first == link1. 178347 self assert: list second == link4. 178348 self assert: list third == link3. 178349 self assert: list fourth == link2! ! 178350 178351!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:09'! 178352test08addAfter 178353 | l first | 178354 l := LinkedList new. 178355 first := self class new n: 1. 178356 178357 l add: first. 178358 l add: (self class new n: 3). 178359 178360 self assert: (l collect:[:e | e n]) asArray = #(1 3). 178361 178362 l add: (self class new n: 2) after: first. 178363 178364 self assert: (l collect:[:e | e n]) asArray = #(1 2 3).! ! 178365 178366!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:09'! 178367test09addAfter 178368 | l last | 178369 l := LinkedList new. 178370 last := self class new n: 2. 178371 l add: (self class new n: 1). 178372 l add: last. 178373 178374 self assert: (l collect:[:e | e n]) asArray = #(1 2). 178375 178376 l add: (self class new n: 3) after: last. 178377 178378 self assert: (l collect:[:e | e n]) asArray = #(1 2 3).! ! 178379 178380!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:10'! 178381test10removeFirst 178382 list add: link1. 178383 list add: link2. 178384 list add: link3. 178385 list add: link4. 178386 178387 self assert: list size = 4. 178388 self assert: list first == link1. 178389 self assert: list second == link2. 178390 self assert: list third == link3. 178391 self assert: list fourth == link4. 178392 178393 list removeFirst. 178394 self assert: list size = 3. 178395 self assert: list first == link2. 178396 self assert: list second == link3. 178397 self assert: list third == link4. 178398 178399 list removeFirst. 178400 self assert: list size = 2. 178401 self assert: list first == link3. 178402 self assert: list second == link4. 178403 178404 list removeFirst. 178405 self assert: list size = 1. 178406 self assert: list first == link4. 178407 178408 list removeFirst. 178409 self assert: list isEmpty! ! 178410 178411!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:10'! 178412test11removeLast 178413 list add: link1. 178414 list add: link2. 178415 list add: link3. 178416 list add: link4. 178417 178418 self assert: list size = 4. 178419 self assert: list first == link1. 178420 self assert: list second == link2. 178421 self assert: list third == link3. 178422 self assert: list fourth == link4. 178423 178424 list removeLast. 178425 self assert: list size = 3. 178426 self assert: list first == link1. 178427 self assert: list second == link2. 178428 self assert: list third == link3. 178429 178430 list removeLast. 178431 self assert: list size = 2. 178432 self assert: list first == link1. 178433 self assert: list second == link2. 178434 178435 list removeLast. 178436 self assert: list size = 1. 178437 self assert: list first == link1. 178438 178439 list removeFirst. 178440 self assert: list isEmpty! ! 178441 178442!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:11'! 178443test12remove 178444 list add: link1. 178445 list add: link2. 178446 list add: link3. 178447 list add: link4. 178448 178449 self assert: list size = 4. 178450 self assert: list first == link1. 178451 self assert: list second == link2. 178452 self assert: list third == link3. 178453 self assert: list fourth == link4. 178454 178455 list remove: link3. 178456 self assert: list size = 3. 178457 self assert: list first == link1. 178458 self assert: list second == link2. 178459 self assert: list third == link4. 178460 178461 list remove: link2. 178462 self assert: list size = 2. 178463 self assert: list first == link1. 178464 self assert: list second == link4. 178465 178466 list remove: link1. 178467 self assert: list size = 1. 178468 self assert: list first == link4. 178469 178470 list remove: link4. 178471 self assert: list isEmpty! ! 178472 178473!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:12'! 178474test13remove 178475 list add: link1. 178476 list add: link2. 178477 list add: link3. 178478 list add: link4. 178479 178480 self assert: list size = 4. 178481 self assert: list first == link1. 178482 self assert: list second == link2. 178483 self assert: list third == link3. 178484 self assert: list fourth == link4. 178485 178486 list remove: link1. 178487 self assert: list size = 3. 178488 self assert: list first == link2. 178489 self assert: list second == link3. 178490 self assert: list third == link4. 178491 178492 list remove: link4. 178493 self assert: list size = 2. 178494 self assert: list first == link2. 178495 self assert: list second == link3. 178496 178497 list remove: link2. 178498 self assert: list size = 1. 178499 self assert: list first == link3. 178500 178501 list remove: link3. 178502 self assert: list isEmpty! ! 178503 178504!LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:13'! 178505test14removeIfAbsent 178506 list add: link1. 178507 178508 self assert: list size = 1. 178509 self assert: list first == link1. 178510 178511 list remove: link1. 178512 self assert: list isEmpty. 178513 178514 [list remove: link1] 178515 on: Error 178516 do: [^ self]. 178517 178518 "The execution should not get here. If yes, something went wrong." 178519 self assert: false! ! 178520 178521!LinkedListTest methodsFor: 'testing' stamp: 'zz 12/7/2005 19:08'! 178522test22addAll 178523 | link5 link6 link7 link8 listToBeAdded | 178524 link5 := Link new. 178525 link6 := Link new. 178526 link7 := Link new. 178527 link8 := Link new. 178528 178529 list 178530 add: link1; 178531 add: link2; 178532 add: link3; 178533 add: link4. 178534 178535 listToBeAdded := LinkedList new. 178536 listToBeAdded 178537 add: link5; 178538 add: link6; 178539 add: link7; 178540 add: link8. 178541 178542 list addAll: listToBeAdded. 178543 178544 self should: [(list at: 1) == link1]. 178545 self should: [(list at: 2) == link2]. 178546 self should: [(list at: 3) == link3]. 178547 self should: [(list at: 4) == link4]. 178548 self should: [(list at: 5) == link5]. 178549 self should: [(list at: 6) == link6]. 178550 self should: [(list at: 7) == link7]. 178551 self should: [(list at: 8) == link8].! ! 178552 178553!LinkedListTest methodsFor: 'testing' stamp: 'nice 9/14/2009 20:57'! 178554testRemoveAll 178555 | list2 | 178556 list add: link1. 178557 list add: link2. 178558 list add: link3. 178559 list add: link4. 178560 list2 := list copy. 178561 list removeAll. 178562 178563 self assert: list size = 0. 178564 self assert: list2 size = 4 description: 'the copy has not been modified'! ! 178565 178566 178567!LinkedListTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:20'! 178568testAddAfter 178569 178570 | l first | 178571 l := LinkedList new. 178572 first := self class new n: 1. 178573 178574 l add: first. 178575 l add: (self class new n: 3). 178576 self assert: (l collect:[:e | e n]) asArray = #(1 3). 178577 l add: (self class new n: 2) after: first. 178578 self assert: (l collect:[:e | e n]) asArray = #(1 2 3).! ! 178579 178580!LinkedListTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:20'! 178581testAddAfterLast 178582 178583 | l last | 178584 l := LinkedList new. 178585 last := self class new n: 2. 178586 l add: (self class new n: 1). 178587 l add: last. 178588 self assert: (l collect:[:e | e n]) asArray = #(1 2). 178589 l add: (self class new n: 3) after: last. 178590 self assert: (l collect:[:e | e n]) asArray = #(1 2 3).! ! 178591 178592!LinkedListTest methodsFor: 'tests' stamp: 'nice 7/28/2008 22:27'! 178593testAddAfterLast2 178594 "LinkedListTest new testAddAfterLast2" 178595 178596 | l first second third fourth | 178597 l := LinkedList new. 178598 first := self class new n: 1. 178599 second := self class new n: 2. 178600 third := self class new n: 3. 178601 fourth :=self class new n: 4. 178602 l addLast: first. 178603 l addLast: second. 178604 self assert: (l collect:[:e | e n]) asArray = #(1 2). 178605 l add: third after: second. 178606 self assert: (l collect:[:e | e n]) asArray = #(1 2 3). 178607 l addLast: fourth. 178608 self assert: (l collect:[:e | e n]) asArray = #(1 2 3 4).! ! 178609 178610 178611!LinkedListTest methodsFor: 'tests - adding' stamp: 'damien.pollet 10/31/2008 23:16'! 178612testTAdd 178613 178614 | added | 178615 added := self otherCollection add: self element. 178616 self assert: added = self element. "equality or identity ?" 178617 self assert: (self otherCollection includes: self element). 178618 178619 ! ! 178620 178621!LinkedListTest methodsFor: 'tests - adding'! 178622testTAddAll 178623 | added collection toBeAdded | 178624 collection := self collectionWithElement . 178625 toBeAdded := self otherCollection . 178626 added := collection addAll: toBeAdded . 178627 self assert: added == toBeAdded . "test for identiy because #addAll: has not reason to copy its parameter." 178628 self assert: (collection includesAllOf: toBeAdded )! ! 178629 178630!LinkedListTest methodsFor: 'tests - adding'! 178631testTAddIfNotPresentWithElementAlreadyIn 178632 178633 | added oldSize collection element | 178634 collection := self collectionWithElement . 178635 oldSize := collection size. 178636 element := self element . 178637 self assert: (collection includes: element ). 178638 178639 added := collection addIfNotPresent: element . 178640 178641 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 178642 self assert: collection size = oldSize! ! 178643 178644!LinkedListTest methodsFor: 'tests - adding'! 178645testTAddIfNotPresentWithNewElement 178646 178647 | added oldSize collection element | 178648 collection := self otherCollection . 178649 oldSize := collection size. 178650 element := self element . 178651 self deny: (collection includes: element ). 178652 178653 added := collection addIfNotPresent: element . 178654 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 178655 self assert: (collection size = (oldSize + 1)). 178656 178657 ! ! 178658 178659!LinkedListTest methodsFor: 'tests - adding'! 178660testTWrite 178661 | added collection element | 178662 collection := self otherCollection . 178663 element := self element . 178664 added := collection write: element . 178665 178666 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 178667 self assert: (collection includes: element ) . 178668 self assert: (collection includes: element ). 178669 178670 ! ! 178671 178672 178673!LinkedListTest methodsFor: 'tests - begins ends with'! 178674testsBeginsWith 178675 178676 self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty size)). 178677 self assert: (self nonEmpty beginsWith:(self nonEmpty )). 178678 self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 178679 178680!LinkedListTest methodsFor: 'tests - begins ends with'! 178681testsBeginsWithEmpty 178682 178683 self deny: (self nonEmpty beginsWith:(self empty)). 178684 self deny: (self empty beginsWith:(self nonEmpty )). 178685! ! 178686 178687!LinkedListTest methodsFor: 'tests - begins ends with'! 178688testsEndsWith 178689 178690 self assert: (self nonEmpty endsWith:(self nonEmpty copyWithoutFirst)). 178691 self assert: (self nonEmpty endsWith:(self nonEmpty )). 178692 self deny: (self nonEmpty endsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 178693 178694!LinkedListTest methodsFor: 'tests - begins ends with'! 178695testsEndsWithEmpty 178696 178697 self deny: (self nonEmpty endsWith:(self empty )). 178698 self deny: (self empty endsWith:(self nonEmpty )). 178699 ! ! 178700 178701 178702!LinkedListTest methodsFor: 'tests - comma and delimiter'! 178703testAsCommaStringEmpty 178704 178705 self assert: self empty asCommaString = ''. 178706 self assert: self empty asCommaStringAnd = ''. 178707 178708 178709! ! 178710 178711!LinkedListTest methodsFor: 'tests - comma and delimiter'! 178712testAsCommaStringMore 178713 178714 "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. 178715 self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' 178716" 178717 178718 | result resultAnd index allElementsAsString | 178719 result:= self nonEmpty asCommaString . 178720 resultAnd:= self nonEmpty asCommaStringAnd . 178721 178722 index := 1. 178723 (result findBetweenSubStrs: ',' )do: 178724 [:each | 178725 index = 1 178726 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] 178727 ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. 178728 index:=index+1 178729 ]. 178730 178731 "verifying esultAnd :" 178732 allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 178733 1 to: allElementsAsString size do: 178734 [:i | 178735 i<(allElementsAsString size ) 178736 ifTrue: [ 178737 i = 1 178738 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] 178739 ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] 178740 ]. 178741 i=(allElementsAsString size) 178742 ifTrue:[ 178743 i = 1 178744 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 178745 ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 178746 ]. 178747 178748 178749 ].! ! 178750 178751!LinkedListTest methodsFor: 'tests - comma and delimiter'! 178752testAsCommaStringOne 178753 178754 "self assert: self oneItemCol asCommaString = '1'. 178755 self assert: self oneItemCol asCommaStringAnd = '1'." 178756 178757 self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). 178758 self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). 178759 ! ! 178760 178761!LinkedListTest methodsFor: 'tests - comma and delimiter'! 178762testAsStringOnDelimiterEmpty 178763 178764 | delim emptyStream | 178765 delim := ', '. 178766 emptyStream := ReadWriteStream on: ''. 178767 self empty asStringOn: emptyStream delimiter: delim. 178768 self assert: emptyStream contents = ''. 178769! ! 178770 178771!LinkedListTest methodsFor: 'tests - comma and delimiter'! 178772testAsStringOnDelimiterLastEmpty 178773 178774 | delim emptyStream | 178775 delim := ', '. 178776 emptyStream := ReadWriteStream on: ''. 178777 self empty asStringOn: emptyStream delimiter: delim last:'and'. 178778 self assert: emptyStream contents = ''. 178779! ! 178780 178781!LinkedListTest methodsFor: 'tests - comma and delimiter'! 178782testAsStringOnDelimiterLastMore 178783 178784 | delim multiItemStream result last allElementsAsString | 178785 178786 delim := ', '. 178787 last := 'and'. 178788 result:=''. 178789 multiItemStream := ReadWriteStream on:result. 178790 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 178791 178792 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 178793 1 to: allElementsAsString size do: 178794 [:i | 178795 i<(allElementsAsString size-1 ) 178796 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 178797 i=(allElementsAsString size-1) 178798 ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. 178799 i=(allElementsAsString size) 178800 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 178801 ]. 178802 178803! ! 178804 178805!LinkedListTest methodsFor: 'tests - comma and delimiter'! 178806testAsStringOnDelimiterLastOne 178807 178808 | delim oneItemStream result | 178809 178810 delim := ', '. 178811 result:=''. 178812 oneItemStream := ReadWriteStream on: result. 178813 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 178814 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 178815 178816 178817 ! ! 178818 178819!LinkedListTest methodsFor: 'tests - comma and delimiter'! 178820testAsStringOnDelimiterMore 178821 178822 | delim multiItemStream result index | 178823 "delim := ', '. 178824 multiItemStream := '' readWrite. 178825 self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. 178826 self assert: multiItemStream contents = '1, 2, 3'." 178827 178828 delim := ', '. 178829 result:=''. 178830 multiItemStream := ReadWriteStream on:result. 178831 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 178832 178833 index:=1. 178834 (result findBetweenSubStrs: ', ' )do: 178835 [:each | 178836 self assert: each= ((self nonEmpty at:index)asString). 178837 index:=index+1 178838 ].! ! 178839 178840!LinkedListTest methodsFor: 'tests - comma and delimiter'! 178841testAsStringOnDelimiterOne 178842 178843 | delim oneItemStream result | 178844 "delim := ', '. 178845 oneItemStream := '' readWrite. 178846 self oneItemCol asStringOn: oneItemStream delimiter: delim. 178847 self assert: oneItemStream contents = '1'." 178848 178849 delim := ', '. 178850 result:=''. 178851 oneItemStream := ReadWriteStream on: result. 178852 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 178853 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 178854 178855 178856 ! ! 178857 178858 178859!LinkedListTest methodsFor: 'tests - converting'! 178860assertNoDuplicates: aCollection whenConvertedTo: aClass 178861 | result | 178862 result := self collectionWithEqualElements asIdentitySet. 178863 self assert: (result class includesBehavior: IdentitySet). 178864 self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! 178865 178866!LinkedListTest methodsFor: 'tests - converting'! 178867assertNonDuplicatedContents: aCollection whenConvertedTo: aClass 178868 | result | 178869 result := aCollection perform: ('as' , aClass name) asSymbol. 178870 self assert: (result class includesBehavior: aClass). 178871 result do: 178872 [ :each | 178873 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 178874 ^ result! ! 178875 178876!LinkedListTest methodsFor: 'tests - converting'! 178877assertSameContents: aCollection whenConvertedTo: aClass 178878 | result | 178879 result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. 178880 self assert: result size = aCollection size! ! 178881 178882!LinkedListTest methodsFor: 'tests - converting'! 178883testAsArray 178884 "self debug: #testAsArray3" 178885 self 178886 assertSameContents: self collectionWithoutEqualElements 178887 whenConvertedTo: Array! ! 178888 178889!LinkedListTest methodsFor: 'tests - converting'! 178890testAsBag 178891 178892 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! 178893 178894!LinkedListTest methodsFor: 'tests - converting'! 178895testAsIdentitySet 178896 "test with a collection without equal elements :" 178897 self 178898 assertSameContents: self collectionWithoutEqualElements 178899 whenConvertedTo: IdentitySet. 178900! ! 178901 178902!LinkedListTest methodsFor: 'tests - converting'! 178903testAsOrderedCollection 178904 178905 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! 178906 178907!LinkedListTest methodsFor: 'tests - converting'! 178908testAsSet 178909 | | 178910 "test with a collection without equal elements :" 178911 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. 178912 ! ! 178913 178914 178915!LinkedListTest methodsFor: 'tests - copy'! 178916testCopyEmptyWith 178917 "self debug: #testCopyWith" 178918 | res element | 178919 element := self elementToAdd. 178920 res := self empty copyWith: element. 178921 self assert: res size = (self empty size + 1). 178922 self assert: (res includes: (element value))! ! 178923 178924!LinkedListTest methodsFor: 'tests - copy'! 178925testCopyEmptyWithout 178926 "self debug: #testCopyEmptyWithout" 178927 | res | 178928 res := self empty copyWithout: self elementToAdd. 178929 self assert: res size = self empty size. 178930 self deny: (res includes: self elementToAdd)! ! 178931 178932!LinkedListTest methodsFor: 'tests - copy'! 178933testCopyEmptyWithoutAll 178934 "self debug: #testCopyEmptyWithoutAll" 178935 | res | 178936 res := self empty copyWithoutAll: self collectionWithElementsToRemove. 178937 self assert: res size = self empty size. 178938 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! 178939 178940!LinkedListTest methodsFor: 'tests - copy'! 178941testCopyNonEmptyWith 178942 "self debug: #testCopyNonEmptyWith" 178943 | res element | 178944 element := self elementToAdd . 178945 res := self nonEmpty copyWith: element. 178946 "here we do not test the size since for a non empty set we would get a problem. 178947 Then in addition copy is not about duplicate management. The element should 178948 be in at the end." 178949 self assert: (res includes: (element value)). 178950 self nonEmpty do: [ :each | res includes: each ]! ! 178951 178952!LinkedListTest methodsFor: 'tests - copy'! 178953testCopyNonEmptyWithout 178954 "self debug: #testCopyNonEmptyWithout" 178955 178956 | res anElementOfTheCollection | 178957 anElementOfTheCollection := self nonEmpty anyOne. 178958 res := (self nonEmpty copyWithout: anElementOfTheCollection). 178959 "here we do not test the size since for a non empty set we would get a problem. 178960 Then in addition copy is not about duplicate management. The element should 178961 be in at the end." 178962 self deny: (res includes: anElementOfTheCollection). 178963 self nonEmpty do: 178964 [:each | (each = anElementOfTheCollection) 178965 ifFalse: [self assert: (res includes: each)]]. 178966 178967! ! 178968 178969!LinkedListTest methodsFor: 'tests - copy'! 178970testCopyNonEmptyWithoutAll 178971 "self debug: #testCopyNonEmptyWithoutAll" 178972 | res | 178973 res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. 178974 "here we do not test the size since for a non empty set we would get a problem. 178975 Then in addition copy is not about duplicate management. The element should 178976 be in at the end." 178977 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. 178978 self nonEmpty do: 178979 [ :each | 178980 (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! 178981 178982!LinkedListTest methodsFor: 'tests - copy'! 178983testCopyNonEmptyWithoutAllNotIncluded 178984 "self debug: #testCopyNonEmptyWithoutAllNotIncluded" 178985 | res | 178986 res := self nonEmpty copyWithoutAll: self collectionNotIncluded. 178987 "here we do not test the size since for a non empty set we would get a problem. 178988 Then in addition copy is not about duplicate management. The element should 178989 be in at the end." 178990 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 178991 178992!LinkedListTest methodsFor: 'tests - copy'! 178993testCopyNonEmptyWithoutNotIncluded 178994 "self debug: #testCopyNonEmptyWithoutNotIncluded" 178995 | res | 178996 res := self nonEmpty copyWithout: self elementToAdd. 178997 "here we do not test the size since for a non empty set we would get a problem. 178998 Then in addition copy is not about duplicate management. The element should 178999 be in at the end." 179000 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 179001 179002 179003!LinkedListTest methodsFor: 'tests - copying part of sequenceable'! 179004testCopyAfter 179005 | result index collection | 179006 collection := self collectionWithoutEqualsElements . 179007 index:= self indexInForCollectionWithoutDuplicates . 179008 result := collection copyAfter: (collection at:index ). 179009 179010 "verifying content: " 179011 (1) to: result size do: 179012 [:i | 179013 self assert: (collection at:(i + index ))=(result at: (i))]. 179014 179015 "verify size: " 179016 self assert: result size = (collection size - index).! ! 179017 179018!LinkedListTest methodsFor: 'tests - copying part of sequenceable'! 179019testCopyAfterEmpty 179020 | result | 179021 result := self empty copyAfter: self collectionWithoutEqualsElements first. 179022 self assert: result isEmpty. 179023 ! ! 179024 179025!LinkedListTest methodsFor: 'tests - copying part of sequenceable'! 179026testCopyAfterLast 179027 | result index collection | 179028 collection := self collectionWithoutEqualsElements . 179029 index:= self indexInForCollectionWithoutDuplicates . 179030 result := collection copyAfterLast: (collection at:index ). 179031 179032 "verifying content: " 179033 (1) to: result size do: 179034 [:i | 179035 self assert: (collection at:(i + index ))=(result at: (i))]. 179036 179037 "verify size: " 179038 self assert: result size = (collection size - index).! ! 179039 179040!LinkedListTest methodsFor: 'tests - copying part of sequenceable'! 179041testCopyAfterLastEmpty 179042 | result | 179043 result := self empty copyAfterLast: self collectionWithoutEqualsElements first. 179044 self assert: result isEmpty.! ! 179045 179046!LinkedListTest methodsFor: 'tests - copying part of sequenceable'! 179047testCopyFromTo 179048 | result index collection | 179049 collection := self collectionWithoutEqualsElements . 179050 index :=self indexInForCollectionWithoutDuplicates . 179051 result := collection copyFrom: index to: collection size . 179052 179053 "verify content of 'result' : " 179054 1 to: result size do: 179055 [:i | 179056 self assert: (result at:i)=(collection at: (i + index - 1))]. 179057 179058 "verify size of 'result' : " 179059 self assert: result size = (collection size - index + 1).! ! 179060 179061!LinkedListTest methodsFor: 'tests - copying part of sequenceable'! 179062testCopyUpTo 179063 | result index collection | 179064 collection := self collectionWithoutEqualsElements . 179065 index:= self indexInForCollectionWithoutDuplicates . 179066 result := collection copyUpTo: (collection at:index). 179067 179068 "verify content of 'result' :" 179069 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 179070 179071 "verify size of 'result' :" 179072 self assert: result size = (index-1). 179073 ! ! 179074 179075!LinkedListTest methodsFor: 'tests - copying part of sequenceable'! 179076testCopyUpToEmpty 179077 | result | 179078 result := self empty copyUpTo: self collectionWithoutEqualsElements first. 179079 self assert: result isEmpty. 179080 ! ! 179081 179082!LinkedListTest methodsFor: 'tests - copying part of sequenceable'! 179083testCopyUpToLast 179084 | result index collection | 179085 collection := self collectionWithoutEqualsElements . 179086 index:= self indexInForCollectionWithoutDuplicates . 179087 result := collection copyUpToLast: (collection at:index). 179088 179089 "verify content of 'result' :" 179090 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 179091 179092 "verify size of 'result' :" 179093 self assert: result size = (index-1).! ! 179094 179095!LinkedListTest methodsFor: 'tests - copying part of sequenceable'! 179096testCopyUpToLastEmpty 179097 | result | 179098 result := self empty copyUpToLast: self collectionWithoutEqualsElements first. 179099 self assert: result isEmpty.! ! 179100 179101 179102!LinkedListTest methodsFor: 'tests - copying same contents'! 179103testReverse 179104 | result | 179105 result := self nonEmpty reverse . 179106 179107 "verify content of 'result: '" 179108 1 to: result size do: 179109 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 179110 "verify size of 'result' :" 179111 self assert: result size=self nonEmpty size.! ! 179112 179113!LinkedListTest methodsFor: 'tests - copying same contents'! 179114testReversed 179115 | result | 179116 result := self nonEmpty reversed . 179117 179118 "verify content of 'result: '" 179119 1 to: result size do: 179120 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 179121 "verify size of 'result' :" 179122 self assert: result size=self nonEmpty size.! ! 179123 179124!LinkedListTest methodsFor: 'tests - copying same contents'! 179125testShallowCopy 179126 | result | 179127 result := self nonEmpty shallowCopy . 179128 179129 "verify content of 'result: '" 179130 1 to: self nonEmpty size do: 179131 [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. 179132 "verify size of 'result' :" 179133 self assert: result size=self nonEmpty size.! ! 179134 179135!LinkedListTest methodsFor: 'tests - copying same contents'! 179136testShallowCopyEmpty 179137 | result | 179138 result := self empty shallowCopy . 179139 self assert: result isEmpty .! ! 179140 179141!LinkedListTest methodsFor: 'tests - copying same contents'! 179142testShuffled 179143 | result | 179144 result := self nonEmpty shuffled . 179145 179146 "verify content of 'result: '" 179147 result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. 179148 "verify size of 'result' :" 179149 self assert: result size=self nonEmpty size.! ! 179150 179151 179152!LinkedListTest methodsFor: 'tests - copying with or without'! 179153testCopyWithFirst 179154 179155 | index element result | 179156 index:= self indexInNonEmpty . 179157 element:= self nonEmpty at: index. 179158 179159 result := self nonEmpty copyWithFirst: element. 179160 179161 self assert: result size = (self nonEmpty size + 1). 179162 self assert: result first = element . 179163 179164 2 to: result size do: 179165 [ :i | 179166 self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! 179167 179168!LinkedListTest methodsFor: 'tests - copying with or without'! 179169testCopyWithSequenceable 179170 179171 | result index element | 179172 index := self indexInNonEmpty . 179173 element := self nonEmpty at: index. 179174 result := self nonEmpty copyWith: (element ). 179175 179176 self assert: result size = (self nonEmpty size + 1). 179177 self assert: result last = element . 179178 179179 1 to: (result size - 1) do: 179180 [ :i | 179181 self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! 179182 179183!LinkedListTest methodsFor: 'tests - copying with or without'! 179184testCopyWithoutFirst 179185 179186 | result | 179187 result := self nonEmpty copyWithoutFirst. 179188 179189 self assert: result size = (self nonEmpty size - 1). 179190 179191 1 to: result size do: 179192 [:i | 179193 self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! 179194 179195!LinkedListTest methodsFor: 'tests - copying with or without'! 179196testCopyWithoutIndex 179197 | result index | 179198 index := self indexInNonEmpty . 179199 result := self nonEmpty copyWithoutIndex: index . 179200 179201 "verify content of 'result:'" 179202 1 to: result size do: 179203 [:i | 179204 i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. 179205 i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. 179206 179207 "verify size of result : " 179208 self assert: result size=(self nonEmpty size -1).! ! 179209 179210!LinkedListTest methodsFor: 'tests - copying with or without'! 179211testForceToPaddingStartWith 179212 179213 | result element | 179214 element := self nonEmpty at: self indexInNonEmpty . 179215 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). 179216 179217 "verify content of 'result' : " 179218 1 to: 2 do: 179219 [:i | self assert: ( element ) = ( result at:(i) ) ]. 179220 179221 3 to: result size do: 179222 [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. 179223 179224 "verify size of 'result' :" 179225 self assert: result size = (self nonEmpty size + 2).! ! 179226 179227!LinkedListTest methodsFor: 'tests - copying with or without'! 179228testForceToPaddingWith 179229 179230 | result element | 179231 element := self nonEmpty at: self indexInNonEmpty . 179232 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). 179233 179234 "verify content of 'result' : " 179235 1 to: self nonEmpty size do: 179236 [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. 179237 179238 (result size - 1) to: result size do: 179239 [:i | self assert: ( result at:i ) = ( element ) ]. 179240 179241 "verify size of 'result' :" 179242 self assert: result size = (self nonEmpty size + 2).! ! 179243 179244 179245!LinkedListTest methodsFor: 'tests - copying with replacement'! 179246firstIndexesOf: subCollection in: collection 179247" return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " 179248 | tmp result currentIndex | 179249 tmp:= collection. 179250 result:= OrderedCollection new. 179251 currentIndex := 1. 179252 179253 [tmp isEmpty ]whileFalse: 179254 [ 179255 (tmp beginsWith: subCollection) 179256 ifTrue: [ 179257 result add: currentIndex. 179258 1 to: subCollection size do: 179259 [:i | 179260 tmp := tmp copyWithoutFirst. 179261 currentIndex := currentIndex + 1] 179262 ] 179263 ifFalse: [ 179264 tmp := tmp copyWithoutFirst. 179265 currentIndex := currentIndex +1. 179266 ] 179267 ]. 179268 179269 ^ result. 179270 ! ! 179271 179272!LinkedListTest methodsFor: 'tests - copying with replacement'! 179273testCopyReplaceAllWith1Occurence 179274 | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | 179275 179276 result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 179277 179278 "detecting indexes of olSubCollection" 179279 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . 179280 index:= firstIndexesOfOccurrence at: 1. 179281 179282 "verify content of 'result' : " 179283 "first part of 'result'' : '" 179284 179285 1 to: (index -1) do: 179286 [ 179287 :i | 179288 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 179289 ]. 179290 179291 " middle part containing replacementCollection : " 179292 179293 index to: (index + self replacementCollection size-1) do: 179294 [ 179295 :i | 179296 self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) 179297 ]. 179298 179299 " end part :" 179300 179301 endPartIndexResult := index + self replacementCollection size . 179302 endPartIndexCollection := index + self oldSubCollection size . 179303 179304 1 to: (result size - endPartIndexResult - 1 ) do: 179305 [ 179306 :i | 179307 self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). 179308 ]. 179309 179310 179311 ! ! 179312 179313!LinkedListTest methodsFor: 'tests - copying with replacement'! 179314testCopyReplaceFromToWith 179315 | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | 179316 179317 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 179318 lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. 179319 lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. 179320 179321 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . 179322 179323 "verify content of 'result' : " 179324 "first part of 'result' " 179325 179326 1 to: (indexOfSubcollection - 1) do: 179327 [ 179328 :i | 179329 self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) 179330 ]. 179331 179332 " middle part containing replacementCollection : " 179333 179334 (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: 179335 [ 179336 :i | 179337 self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) 179338 ]. 179339 179340 " end part :" 179341 1 to: (result size - lastIndexOfReplacementCollection ) do: 179342 [ 179343 :i | 179344 self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). 179345 ]. 179346 179347 179348 179349 179350 179351 ! ! 179352 179353!LinkedListTest methodsFor: 'tests - copying with replacement'! 179354testCopyReplaceFromToWithInsertion 179355 | result indexOfSubcollection | 179356 179357 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 179358 179359 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . 179360 179361 "verify content of 'result' : " 179362 "first part of 'result'' : '" 179363 179364 1 to: (indexOfSubcollection -1) do: 179365 [ 179366 :i | 179367 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 179368 ]. 179369 179370 " middle part containing replacementCollection : " 179371 indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: 179372 [ 179373 :i | 179374 self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) 179375 ]. 179376 179377 " end part :" 179378 (indexOfSubcollection + self replacementCollection size) to: (result size) do: 179379 [:i| 179380 self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. 179381 179382 " verify size: " 179383 self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). 179384 179385 179386 179387 179388 179389 ! ! 179390 179391 179392!LinkedListTest methodsFor: 'tests - element accessing'! 179393testAfter 179394 "self debug: #testAfter" 179395 self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). 179396 self 179397 should: 179398 [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] 179399 raise: Error. 179400 self 179401 should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] 179402 raise: Error! ! 179403 179404!LinkedListTest methodsFor: 'tests - element accessing'! 179405testAfterIfAbsent 179406 "self debug: #testAfterIfAbsent" 179407 self assert: (self moreThan4Elements 179408 after: (self moreThan4Elements at: 1) 179409 ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). 179410 self assert: (self moreThan4Elements 179411 after: (self moreThan4Elements at: self moreThan4Elements size) 179412 ifAbsent: [ 33 ]) == 33. 179413 self assert: (self moreThan4Elements 179414 after: self elementNotInForElementAccessing 179415 ifAbsent: [ 33 ]) = 33! ! 179416 179417!LinkedListTest methodsFor: 'tests - element accessing'! 179418testAt 179419 "self debug: #testAt" 179420 " 179421 self assert: (self accessCollection at: 1) = 1. 179422 self assert: (self accessCollection at: 2) = 2. 179423 " 179424 | index | 179425 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 179426 self assert: (self moreThan4Elements at: index) = self elementInForElementAccessing! ! 179427 179428!LinkedListTest methodsFor: 'tests - element accessing'! 179429testAtAll 179430 "self debug: #testAtAll" 179431 " self flag: #theCollectionshouldbe102030intheFixture. 179432 179433 self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. 179434 self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." 179435 | result | 179436 result := self moreThan4Elements atAll: #(2 1 2 ). 179437 self assert: (result at: 1) = (self moreThan4Elements at: 2). 179438 self assert: (result at: 2) = (self moreThan4Elements at: 1). 179439 self assert: (result at: 3) = (self moreThan4Elements at: 2). 179440 self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! 179441 179442!LinkedListTest methodsFor: 'tests - element accessing'! 179443testAtIfAbsent 179444 "self debug: #testAt" 179445 | absent | 179446 absent := false. 179447 self moreThan4Elements 179448 at: self moreThan4Elements size + 1 179449 ifAbsent: [ absent := true ]. 179450 self assert: absent = true. 179451 absent := false. 179452 self moreThan4Elements 179453 at: self moreThan4Elements size 179454 ifAbsent: [ absent := true ]. 179455 self assert: absent = false! ! 179456 179457!LinkedListTest methodsFor: 'tests - element accessing'! 179458testAtLast 179459 "self debug: #testAtLast" 179460 | index | 179461 self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. 179462 "tmp:=1. 179463 self do: 179464 [:each | 179465 each =self elementInForIndexAccessing 179466 ifTrue:[index:=tmp]. 179467 tmp:=tmp+1]." 179468 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 179469 self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! 179470 179471!LinkedListTest methodsFor: 'tests - element accessing'! 179472testAtLastError 179473 "self debug: #testAtLast" 179474 self 179475 should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] 179476 raise: Error! ! 179477 179478!LinkedListTest methodsFor: 'tests - element accessing'! 179479testAtLastIfAbsent 179480 "self debug: #testAtLastIfAbsent" 179481 self assert: (self moreThan4Elements 179482 atLast: 1 179483 ifAbsent: [ nil ]) = self moreThan4Elements last. 179484 self assert: (self moreThan4Elements 179485 atLast: self moreThan4Elements size + 1 179486 ifAbsent: [ 222 ]) = 222! ! 179487 179488!LinkedListTest methodsFor: 'tests - element accessing'! 179489testAtOutOfBounds 179490 "self debug: #testAtOutOfBounds" 179491 self 179492 should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] 179493 raise: Error. 179494 self 179495 should: [ self moreThan4Elements at: -1 ] 179496 raise: Error! ! 179497 179498!LinkedListTest methodsFor: 'tests - element accessing'! 179499testAtPin 179500 "self debug: #testAtPin" 179501 self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. 179502 self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. 179503 self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! 179504 179505!LinkedListTest methodsFor: 'tests - element accessing'! 179506testAtRandom 179507 | result | 179508 result := self nonEmpty atRandom . 179509 self assert: (self nonEmpty includes: result).! ! 179510 179511!LinkedListTest methodsFor: 'tests - element accessing'! 179512testAtWrap 179513 "self debug: #testAt" 179514 " 179515 self assert: (self accessCollection at: 1) = 1. 179516 self assert: (self accessCollection at: 2) = 2. 179517 " 179518 | index | 179519 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 179520 self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. 179521 self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. 179522 self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. 179523 self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! 179524 179525!LinkedListTest methodsFor: 'tests - element accessing'! 179526testBefore 179527 "self debug: #testBefore" 179528 self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). 179529 self 179530 should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] 179531 raise: Error. 179532 self 179533 should: [ self moreThan4Elements before: 66 ] 179534 raise: Error! ! 179535 179536!LinkedListTest methodsFor: 'tests - element accessing'! 179537testBeforeIfAbsent 179538 "self debug: #testBefore" 179539 self assert: (self moreThan4Elements 179540 before: (self moreThan4Elements at: 1) 179541 ifAbsent: [ 99 ]) = 99. 179542 self assert: (self moreThan4Elements 179543 before: (self moreThan4Elements at: 2) 179544 ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! 179545 179546!LinkedListTest methodsFor: 'tests - element accessing'! 179547testFirstSecondThird 179548 "self debug: #testFirstSecondThird" 179549 self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). 179550 self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). 179551 self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). 179552 self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! 179553 179554!LinkedListTest methodsFor: 'tests - element accessing'! 179555testLast 179556 "self debug: #testLast" 179557 self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! 179558 179559!LinkedListTest methodsFor: 'tests - element accessing'! 179560testMiddle 179561 "self debug: #testMiddle" 179562 self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! 179563 179564 179565!LinkedListTest methodsFor: 'tests - empty' stamp: 'damien.pollet 10/31/2008 14:36'! 179566empty 179567 ^ list! ! 179568 179569!LinkedListTest methodsFor: 'tests - empty'! 179570testIfEmpty 179571 179572 self nonEmpty ifEmpty: [ self assert: false] . 179573 self empty ifEmpty: [ self assert: true] . 179574 179575 179576 ! ! 179577 179578!LinkedListTest methodsFor: 'tests - empty'! 179579testIfEmptyifNotEmpty 179580 179581 self assert: (self empty ifEmpty: [true] ifNotEmpty: [false]). 179582 self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [true]). 179583 ! ! 179584 179585!LinkedListTest methodsFor: 'tests - empty'! 179586testIfEmptyifNotEmptyDo 179587 "self debug #testIfEmptyifNotEmptyDo" 179588 179589 self assert: (self empty ifEmpty: [true] ifNotEmptyDo: [:s | false]). 179590 self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | true]). 179591 self assert: (self nonEmpty 179592 ifEmpty: [false] 179593 ifNotEmptyDo: [:s | s]) == self nonEmpty.! ! 179594 179595!LinkedListTest methodsFor: 'tests - empty'! 179596testIfNotEmpty 179597 179598 self empty ifNotEmpty: [self assert: false]. 179599 self nonEmpty ifNotEmpty: [self assert: true]. 179600 self assert: (self nonEmpty ifNotEmpty: [:s | s ]) = self nonEmpty 179601 ! ! 179602 179603!LinkedListTest methodsFor: 'tests - empty'! 179604testIfNotEmptyDo 179605 179606 self empty ifNotEmptyDo: [:s | self assert: false]. 179607 self assert: (self nonEmpty ifNotEmptyDo: [:s | s]) == self nonEmpty 179608! ! 179609 179610!LinkedListTest methodsFor: 'tests - empty'! 179611testIfNotEmptyDoifNotEmpty 179612 179613 self assert: (self empty ifNotEmptyDo: [:s | false] ifEmpty: [true]). 179614 self assert: (self nonEmpty 179615 ifNotEmptyDo: [:s | s] 179616 ifEmpty: [false]) == self nonEmpty! ! 179617 179618!LinkedListTest methodsFor: 'tests - empty'! 179619testIfNotEmptyifEmpty 179620 179621 self assert: (self empty ifNotEmpty: [false] ifEmpty: [true]). 179622 self assert: (self nonEmpty ifNotEmpty: [true] ifEmpty: [false]). 179623 ! ! 179624 179625!LinkedListTest methodsFor: 'tests - empty'! 179626testIsEmpty 179627 179628 self assert: (self empty isEmpty). 179629 self deny: (self nonEmpty isEmpty).! ! 179630 179631!LinkedListTest methodsFor: 'tests - empty'! 179632testIsEmptyOrNil 179633 179634 self assert: (self empty isEmptyOrNil). 179635 self deny: (self nonEmpty isEmptyOrNil).! ! 179636 179637!LinkedListTest methodsFor: 'tests - empty'! 179638testNotEmpty 179639 179640 self assert: (self nonEmpty notEmpty). 179641 self deny: (self empty notEmpty).! ! 179642 179643 179644!LinkedListTest methodsFor: 'tests - fixture'! 179645howMany: subCollection in: collection 179646" return an integer representing how many time 'subCollection' appears in 'collection' " 179647 | tmp nTime | 179648 tmp:= collection. 179649 nTime:= 0. 179650 179651 [tmp isEmpty ]whileFalse: 179652 [ 179653 (tmp beginsWith: subCollection) 179654 ifTrue: [ 179655 nTime := nTime + 1. 179656 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] 179657 ] 179658 ifFalse: [tmp := tmp copyWithoutFirst.] 179659 ]. 179660 179661 ^ nTime. 179662 ! ! 179663 179664!LinkedListTest methodsFor: 'tests - fixture'! 179665test0CopyTest 179666 self shouldnt: [ self empty ]raise: Error. 179667 self assert: self empty size = 0. 179668 self shouldnt: [ self nonEmpty ]raise: Error. 179669 self assert: (self nonEmpty size = 0) not. 179670 self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. 179671 self assert: (self collectionWithElementsToRemove size = 0) not. 179672 self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. 179673 179674 self shouldnt: [ self elementToAdd ]raise: Error. 179675 self deny: (self nonEmpty includes: self elementToAdd ). 179676 self shouldnt: [ self collectionNotIncluded ]raise: Error. 179677 self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! 179678 179679!LinkedListTest methodsFor: 'tests - fixture'! 179680test0FixtureAsStringCommaAndDelimiterTest 179681 179682 self shouldnt: [self nonEmpty] raise:Error . 179683 self deny: self nonEmpty isEmpty. 179684 179685 self shouldnt: [self empty] raise:Error . 179686 self assert: self empty isEmpty. 179687 179688 self shouldnt: [self nonEmpty1Element ] raise:Error . 179689 self assert: self nonEmpty1Element size=1.! ! 179690 179691!LinkedListTest methodsFor: 'tests - fixture'! 179692test0FixtureBeginsEndsWithTest 179693 179694 self shouldnt: [self nonEmpty ] raise: Error. 179695 self deny: self nonEmpty isEmpty. 179696 self assert: self nonEmpty size>1. 179697 179698 self shouldnt: [self empty ] raise: Error. 179699 self assert: self empty isEmpty.! ! 179700 179701!LinkedListTest methodsFor: 'tests - fixture'! 179702test0FixtureCopyPartOfSequenceableTest 179703 179704 self shouldnt: [self collectionWithoutEqualsElements ] raise: Error. 179705 self collectionWithoutEqualsElements do: 179706 [:each | self assert: (self collectionWithoutEqualsElements occurrencesOf: each)=1]. 179707 179708 self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. 179709 self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualsElements size. 179710 179711 self shouldnt: [self empty] raise: Error. 179712 self assert: self empty isEmpty .! ! 179713 179714!LinkedListTest methodsFor: 'tests - fixture'! 179715test0FixtureCopySameContentsTest 179716 179717 self shouldnt: [self nonEmpty ] raise: Error. 179718 self deny: self nonEmpty isEmpty. 179719 179720 self shouldnt: [self empty ] raise: Error. 179721 self assert: self empty isEmpty. 179722 179723! ! 179724 179725!LinkedListTest methodsFor: 'tests - fixture'! 179726test0FixtureCopyWithOrWithoutSpecificElementsTest 179727 179728 self shouldnt: [self nonEmpty ] raise: Error. 179729 self deny: self nonEmpty isEmpty . 179730 179731 self shouldnt: [self indexInNonEmpty ] raise: Error. 179732 self assert: self indexInNonEmpty > 0. 179733 self assert: self indexInNonEmpty <= self nonEmpty size.! ! 179734 179735!LinkedListTest methodsFor: 'tests - fixture'! 179736test0FixtureCopyWithReplacementTest 179737 179738 self shouldnt: [self replacementCollection ]raise: Error. 179739 self shouldnt: [self oldSubCollection] raise: Error. 179740 179741 self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. 179742 self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. 179743 179744 ! ! 179745 179746!LinkedListTest methodsFor: 'tests - fixture'! 179747test0FixtureEmptyTest 179748 179749self shouldnt: [ self nonEmpty ] raise: Error. 179750self deny: self nonEmpty isEmpty. 179751 179752self shouldnt: [ self empty ] raise: Error. 179753self assert: self empty isEmpty.! ! 179754 179755!LinkedListTest methodsFor: 'tests - fixture'! 179756test0FixtureIncludeTest 179757 | elementIn | 179758 self shouldnt: [ self nonEmpty ]raise: Error. 179759 self deny: self nonEmpty isEmpty. 179760 179761 self shouldnt: [ self elementNotIn ]raise: Error. 179762 179763 elementIn := true. 179764 self nonEmpty detect: 179765 [ :each | each = self elementNotIn ] 179766 ifNone: [ elementIn := false ]. 179767 self assert: elementIn = false. 179768 179769 self shouldnt: [ self anotherElementNotIn ]raise: Error. 179770 179771 elementIn := true. 179772 self nonEmpty detect: 179773 [ :each | each = self anotherElementNotIn ] 179774 ifNone: [ elementIn := false ]. 179775 self assert: elementIn = false. 179776 179777 self shouldnt: [ self empty ] raise: Error. 179778 self assert: self empty isEmpty. 179779 179780! ! 179781 179782!LinkedListTest methodsFor: 'tests - fixture'! 179783test0FixtureIncludeWithIdentityTest 179784 | element | 179785 self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. 179786 element := self collectionWithCopyNonIdentical anyOne. 179787 self deny: element == element copy. 179788! ! 179789 179790!LinkedListTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/23/2009 15:14'! 179791test0FixtureIndexAccessTest 179792 | res | 179793 self 179794 shouldnt: [ self collectionMoreThan1NoDuplicates ] 179795 raise: Error. 179796 self assert: self collectionMoreThan1NoDuplicates size = 5. 179797 res := true. 179798 self collectionMoreThan1NoDuplicates 179799 detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] 179800 ifNone: [ res := false ]. 179801 self assert: res = false. 179802 self 179803 shouldnt: [ self elementInForIndexAccessing ] 179804 raise: Error. 179805 self assert: (self collectionMoreThan1NoDuplicates includes: self elementInForIndexAccessing). 179806 self 179807 shouldnt: [ self elementNotInForIndexAccessing ] 179808 raise: Error. 179809 self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! 179810 179811!LinkedListTest methodsFor: 'tests - fixture'! 179812test0FixtureIterateSequencedReadableTest 179813 179814 | res | 179815 179816 self shouldnt: self nonEmptyMoreThan1Element raise: Error. 179817 self assert: self nonEmptyMoreThan1Element size > 1. 179818 179819 179820 self shouldnt: self empty raise: Error. 179821 self assert: self empty isEmpty . 179822 179823 res := true. 179824 self nonEmptyMoreThan1Element 179825 detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] 179826 ifNone: [ res := false ]. 179827 self assert: res = false.! ! 179828 179829!LinkedListTest methodsFor: 'tests - fixture'! 179830test0FixtureOccurrencesTest 179831 | tmp | 179832 self shouldnt: [self empty ]raise: Error. 179833 self assert: self empty isEmpty. 179834 179835 self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. 179836 self deny: self collectionWithoutEqualElements isEmpty. 179837 179838 tmp := OrderedCollection new. 179839 self collectionWithoutEqualElements do: [ 179840 :each | 179841 self deny: (tmp includes: each). 179842 tmp add: each. 179843 ]. 179844 179845 179846 self shouldnt: [ self elementNotInForOccurrences ] raise: Error. 179847 self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! 179848 179849!LinkedListTest methodsFor: 'tests - fixture'! 179850test0FixturePrintTest 179851 179852 self shouldnt: [self nonEmpty ] raise: Error. 179853 self deny: self nonEmpty isEmpty.! ! 179854 179855!LinkedListTest methodsFor: 'tests - fixture'! 179856test0FixtureRequirementsOfTAddTest 179857 self 179858 shouldnt: [ self collectionWithElement ] 179859 raise: Exception. 179860 self 179861 shouldnt: [ self otherCollection ] 179862 raise: Exception. 179863 self 179864 shouldnt: [ self element ] 179865 raise: Exception. 179866 self assert: (self collectionWithElement includes: self element). 179867 self deny: (self otherCollection includes: self element)! ! 179868 179869!LinkedListTest methodsFor: 'tests - fixture'! 179870test0FixtureSequencedElementAccessTest 179871 self 179872 shouldnt: [ self moreThan4Elements ] 179873 raise: Error. 179874 self assert: self moreThan4Elements size >= 4. 179875 self 179876 shouldnt: [ self subCollectionNotIn ] 179877 raise: Error. 179878 self subCollectionNotIn 179879 detect: [ :each | (self moreThan4Elements includes: each) not ] 179880 ifNone: [ self assert: false ]. 179881 self 179882 shouldnt: [ self elementNotInForElementAccessing ] 179883 raise: Error. 179884 self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). 179885 self 179886 shouldnt: [ self elementInForElementAccessing ] 179887 raise: Error. 179888 self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! 179889 179890!LinkedListTest methodsFor: 'tests - fixture'! 179891test0FixtureSetAritmeticTest 179892 self 179893 shouldnt: [ self collection ] 179894 raise: Error. 179895 self deny: self collection isEmpty. 179896 self 179897 shouldnt: [ self nonEmpty ] 179898 raise: Error. 179899 self deny: self nonEmpty isEmpty. 179900 self 179901 shouldnt: [ self anotherElementOrAssociationNotIn ] 179902 raise: Error. 179903 self collection isDictionary 179904 ifTrue: 179905 [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] 179906 ifFalse: 179907 [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. 179908 self 179909 shouldnt: [ self collectionClass ] 179910 raise: Error! ! 179911 179912!LinkedListTest methodsFor: 'tests - fixture'! 179913test0FixtureSubcollectionAccessTest 179914 self 179915 shouldnt: [ self moreThan3Elements ] 179916 raise: Error. 179917 self assert: self moreThan3Elements size > 2! ! 179918 179919!LinkedListTest methodsFor: 'tests - fixture'! 179920test0FixtureTConvertTest 179921 "a collection of number without equal elements:" 179922 | res | 179923 self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. 179924 179925 res := true. 179926 self collectionWithoutEqualElements 179927 detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] 179928 ifNone: [ res := false ]. 179929 self assert: res = false. 179930 179931 179932! ! 179933 179934!LinkedListTest methodsFor: 'tests - fixture'! 179935test0FixtureTRemoveTest 179936 | duplicate | 179937 self shouldnt: [ self empty ]raise: Error. 179938 self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. 179939 self deny: self nonEmptyWithoutEqualElements isEmpty. 179940 duplicate := true. 179941 self nonEmptyWithoutEqualElements detect: 179942 [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] 179943 ifNone: [duplicate := false]. 179944 self assert: duplicate = false. 179945 179946 179947 self shouldnt: [ self elementNotIn ] raise: Error. 179948 self assert: self empty isEmpty. 179949 self deny: self nonEmptyWithoutEqualElements isEmpty. 179950 self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! 179951 179952!LinkedListTest methodsFor: 'tests - fixture'! 179953test0TStructuralEqualityTest 179954 self shouldnt: [self empty] raise: Error. 179955 self shouldnt: [self nonEmpty] raise: Error. 179956 self assert: self empty isEmpty. 179957 self deny: self nonEmpty isEmpty.! ! 179958 179959 179960!LinkedListTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! 179961testIdentityIncludes 179962 " test the comportement in presence of elements 'includes' but not 'identityIncludes' " 179963 " can not be used by collections that can't include elements for wich copy doesn't return another instance " 179964 | collection element | 179965 self 179966 shouldnt: [ self collectionWithCopyNonIdentical ] 179967 raise: Error. 179968 collection := self collectionWithCopyNonIdentical. 179969 element := collection anyOne copy. 179970 "self assert: (collection includes: element)." 179971 self deny: (collection identityIncludes: element)! ! 179972 179973!LinkedListTest methodsFor: 'tests - includes'! 179974testIdentityIncludesNonSpecificComportement 179975 " test the same comportement than 'includes: ' " 179976 | collection | 179977 collection := self nonEmpty . 179978 179979 self deny: (collection identityIncludes: self elementNotIn ). 179980 self assert:(collection identityIncludes: collection anyOne) 179981! ! 179982 179983!LinkedListTest methodsFor: 'tests - includes'! 179984testIncludesAllOfAllThere 179985 "self debug: #testIncludesAllOfAllThere'" 179986 self assert: (self empty includesAllOf: self empty). 179987 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 179988 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 179989 179990!LinkedListTest methodsFor: 'tests - includes'! 179991testIncludesAllOfNoneThere 179992 "self debug: #testIncludesAllOfNoneThere'" 179993 self deny: (self empty includesAllOf: self nonEmpty ). 179994 self deny: (self nonEmpty includesAllOf: { self elementNotIn. self anotherElementNotIn })! ! 179995 179996!LinkedListTest methodsFor: 'tests - includes'! 179997testIncludesAnyOfAllThere 179998 "self debug: #testIncludesAnyOfAllThere'" 179999 self deny: (self nonEmpty includesAnyOf: self empty). 180000 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 180001 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 180002 180003!LinkedListTest methodsFor: 'tests - includes'! 180004testIncludesAnyOfNoneThere 180005 "self debug: #testIncludesAnyOfNoneThere'" 180006 self deny: (self nonEmpty includesAnyOf: self empty). 180007 self deny: (self nonEmpty includesAnyOf: { self elementNotIn. self anotherElementNotIn })! ! 180008 180009!LinkedListTest methodsFor: 'tests - includes'! 180010testIncludesElementIsNotThere 180011 "self debug: #testIncludesElementIsNotThere" 180012 180013 self deny: (self nonEmpty includes: self elementNotIn). 180014 self assert: (self nonEmpty includes: self nonEmpty anyOne). 180015 self deny: (self empty includes: self elementNotIn)! ! 180016 180017!LinkedListTest methodsFor: 'tests - includes'! 180018testIncludesElementIsThere 180019 "self debug: #testIncludesElementIsThere" 180020 180021 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 180022 180023 180024!LinkedListTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 180025testIdentityIndexOf 180026 "self debug: #testIdentityIndexOf" 180027 | collection element | 180028 collection := self collectionMoreThan1NoDuplicates. 180029 element := collection first. 180030 self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! 180031 180032!LinkedListTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 180033testIdentityIndexOfIAbsent 180034 | collection element | 180035 collection := self collectionMoreThan1NoDuplicates. 180036 element := collection first. 180037 self assert: (collection 180038 identityIndexOf: element 180039 ifAbsent: [ 0 ]) = 1. 180040 self assert: (collection 180041 identityIndexOf: self elementNotInForIndexAccessing 180042 ifAbsent: [ 55 ]) = 55! ! 180043 180044!LinkedListTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 180045testIndexOf 180046 "self debug: #testIndexOf" 180047 | tmp index collection | 180048 collection := self collectionMoreThan1NoDuplicates. 180049 tmp := collection size. 180050 collection reverseDo: 180051 [ :each | 180052 each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. 180053 tmp := tmp - 1 ]. 180054 self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! 180055 180056!LinkedListTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 180057testIndexOfIfAbsent 180058 "self debug: #testIndexOfIfAbsent" 180059 | collection | 180060 collection := self collectionMoreThan1NoDuplicates. 180061 self assert: (collection 180062 indexOf: collection first 180063 ifAbsent: [ 33 ]) = 1. 180064 self assert: (collection 180065 indexOf: self elementNotInForIndexAccessing 180066 ifAbsent: [ 33 ]) = 33! ! 180067 180068!LinkedListTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 180069testIndexOfStartingAt 180070 "self debug: #testLastIndexOf" 180071 | element collection | 180072 collection := self collectionMoreThan1NoDuplicates. 180073 element := collection first. 180074 self assert: (collection 180075 indexOf: element 180076 startingAt: 2 180077 ifAbsent: [ 99 ]) = 99. 180078 self assert: (collection 180079 indexOf: element 180080 startingAt: 1 180081 ifAbsent: [ 99 ]) = 1. 180082 self assert: (collection 180083 indexOf: self elementNotInForIndexAccessing 180084 startingAt: 1 180085 ifAbsent: [ 99 ]) = 99! ! 180086 180087!LinkedListTest methodsFor: 'tests - index access'! 180088testIndexOfStartingAtIfAbsent 180089 "self debug: #testLastIndexOf" 180090 | element collection | 180091 collection := self collectionMoreThan1NoDuplicates. 180092 element := collection first. 180093 self assert: (collection 180094 indexOf: element 180095 startingAt: 2 180096 ifAbsent: [ 99 ]) = 99. 180097 self assert: (collection 180098 indexOf: element 180099 startingAt: 1 180100 ifAbsent: [ 99 ]) = 1. 180101 self assert: (collection 180102 indexOf: self elementNotInForIndexAccessing 180103 startingAt: 1 180104 ifAbsent: [ 99 ]) = 99! ! 180105 180106!LinkedListTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 180107testIndexOfSubCollectionStartingAt 180108 "self debug: #testIndexOfIfAbsent" 180109 | subcollection index collection | 180110 collection := self collectionMoreThan1NoDuplicates. 180111 subcollection := self collectionMoreThan1NoDuplicates. 180112 index := collection 180113 indexOfSubCollection: subcollection 180114 startingAt: 1. 180115 self assert: index = 1. 180116 index := collection 180117 indexOfSubCollection: subcollection 180118 startingAt: 2. 180119 self assert: index = 0! ! 180120 180121!LinkedListTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 180122testIndexOfSubCollectionStartingAtIfAbsent 180123 "self debug: #testIndexOfIfAbsent" 180124 | index absent subcollection collection | 180125 collection := self collectionMoreThan1NoDuplicates. 180126 subcollection := self collectionMoreThan1NoDuplicates. 180127 absent := false. 180128 index := collection 180129 indexOfSubCollection: subcollection 180130 startingAt: 1 180131 ifAbsent: [ absent := true ]. 180132 self assert: absent = false. 180133 absent := false. 180134 index := collection 180135 indexOfSubCollection: subcollection 180136 startingAt: 2 180137 ifAbsent: [ absent := true ]. 180138 self assert: absent = true! ! 180139 180140!LinkedListTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 180141testLastIndexOf 180142 "self debug: #testLastIndexOf" 180143 | element collection | 180144 collection := self collectionMoreThan1NoDuplicates. 180145 element := collection first. 180146 self assert: (collection lastIndexOf: element) = 1. 180147 self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! 180148 180149!LinkedListTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 180150testLastIndexOfIfAbsent 180151 "self debug: #testIndexOfIfAbsent" 180152 | element collection | 180153 collection := self collectionMoreThan1NoDuplicates. 180154 element := collection first. 180155 self assert: (collection 180156 lastIndexOf: element 180157 ifAbsent: [ 99 ]) = 1. 180158 self assert: (collection 180159 lastIndexOf: self elementNotInForIndexAccessing 180160 ifAbsent: [ 99 ]) = 99! ! 180161 180162!LinkedListTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 180163testLastIndexOfStartingAt 180164 "self debug: #testLastIndexOf" 180165 | element collection | 180166 collection := self collectionMoreThan1NoDuplicates. 180167 element := collection last. 180168 self assert: (collection 180169 lastIndexOf: element 180170 startingAt: collection size 180171 ifAbsent: [ 99 ]) = collection size. 180172 self assert: (collection 180173 lastIndexOf: element 180174 startingAt: collection size - 1 180175 ifAbsent: [ 99 ]) = 99. 180176 self assert: (collection 180177 lastIndexOf: self elementNotInForIndexAccessing 180178 startingAt: collection size 180179 ifAbsent: [ 99 ]) = 99! ! 180180 180181 180182!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180183testAllButFirstDo 180184 180185 | result | 180186 result:= OrderedCollection new. 180187 180188 self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 180189 180190 1 to: (result size) do: 180191 [:i| 180192 self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. 180193 180194 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 180195 180196!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180197testAllButLastDo 180198 180199 | result | 180200 result:= OrderedCollection new. 180201 180202 self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 180203 180204 1 to: (result size) do: 180205 [:i| 180206 self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. 180207 180208 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 180209 180210!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180211testCollectFromTo 180212 180213 | result | 180214 result:=self nonEmptyMoreThan1Element 180215 collect: [ :each | each ] 180216 from: 1 180217 to: (self nonEmptyMoreThan1Element size - 1). 180218 180219 1 to: result size 180220 do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. 180221 self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! 180222 180223!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180224testDetectSequenced 180225" testing that detect keep the first element returning true for sequenceable collections " 180226 180227 | element result | 180228 element := self nonEmptyMoreThan1Element at:1. 180229 result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. 180230 self assert: result = element. ! ! 180231 180232!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180233testDo! ! 180234 180235!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180236testFindFirst 180237 180238 | element result | 180239 element := self nonEmptyMoreThan1Element at:1. 180240 result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. 180241 180242 self assert: result=1. ! ! 180243 180244!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180245testFindFirstNotIn 180246 180247 | result | 180248 180249 result:=self empty findFirst: [:each | true]. 180250 180251 self assert: result=0. ! ! 180252 180253!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180254testFindLast 180255 180256 | element result | 180257 element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. 180258 result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. 180259 180260 self assert: result=self nonEmptyMoreThan1Element size. ! ! 180261 180262!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180263testFindLastNotIn 180264 180265 | result | 180266 180267 result:=self empty findFirst: [:each | true]. 180268 180269 self assert: result=0. ! ! 180270 180271!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180272testFromToDo 180273 180274 | result | 180275 result:= OrderedCollection new. 180276 180277 self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 180278 180279 1 to: (self nonEmptyMoreThan1Element size -1) do: 180280 [:i| 180281 self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. 180282 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 180283 180284!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180285testKeysAndValuesDo 180286 "| result | 180287 result:= OrderedCollection new. 180288 180289 self nonEmptyMoreThan1Element keysAndValuesDo: 180290 [:i :value| 180291 result add: (value+i)]. 180292 180293 1 to: result size do: 180294 [:i| 180295 self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" 180296 | indexes elements | 180297 indexes:= OrderedCollection new. 180298 elements := OrderedCollection new. 180299 180300 self nonEmptyMoreThan1Element keysAndValuesDo: 180301 [:i :value| 180302 indexes add: (i). 180303 elements add: value]. 180304 180305 (1 to: self nonEmptyMoreThan1Element size )do: 180306 [ :i | 180307 self assert: (indexes at: i) = i. 180308 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 180309 ]. 180310 180311 self assert: indexes size = elements size. 180312 self assert: indexes size = self nonEmptyMoreThan1Element size . 180313 180314 ! ! 180315 180316!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180317testKeysAndValuesDoEmpty 180318 | result | 180319 result:= OrderedCollection new. 180320 180321 self empty keysAndValuesDo: 180322 [:i :value| 180323 result add: (value+i)]. 180324 180325 self assert: result isEmpty .! ! 180326 180327!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180328testPairsCollect 180329 180330 | index result | 180331 index:=0. 180332 180333 result:=self nonEmptyMoreThan1Element pairsCollect: 180334 [:each1 :each2 | 180335 self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). 180336 (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). 180337 ]. 180338 180339 result do: 180340 [:each | self assert: each = true]. 180341 180342! ! 180343 180344!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180345testPairsDo 180346 | index | 180347 index:=1. 180348 180349 self nonEmptyMoreThan1Element pairsDo: 180350 [:each1 :each2 | 180351 self assert:(self nonEmptyMoreThan1Element at:index)=each1. 180352 self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. 180353 index:=index+2]. 180354 180355 self nonEmptyMoreThan1Element size odd 180356 ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] 180357 ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! 180358 180359!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180360testReverseDo 180361 | result | 180362 result:= OrderedCollection new. 180363 self nonEmpty reverseDo: [: each | result add: each]. 180364 180365 1 to: result size do: 180366 [:i| 180367 self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! 180368 180369!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180370testReverseDoEmpty 180371 | result | 180372 result:= OrderedCollection new. 180373 self empty reverseDo: [: each | result add: each]. 180374 180375 self assert: result isEmpty .! ! 180376 180377!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180378testReverseWithDo 180379 180380 | secondCollection result index | 180381 result:= OrderedCollection new. 180382 index := self nonEmptyMoreThan1Element size + 1. 180383 secondCollection:= self nonEmptyMoreThan1Element copy. 180384 180385 self nonEmptyMoreThan1Element reverseWith: secondCollection do: 180386 [:a :b | 180387 self assert: (self nonEmptyMoreThan1Element indexOf: a ) = (index := index - 1 ). 180388 result add: (a = b)]. 180389 180390 1 to: result size do: 180391 [:i| 180392 self assert: (result at:i)=(true)]. 180393 self assert: result size = self nonEmptyMoreThan1Element size.! ! 180394 180395!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180396testWithCollect 180397 180398 | result newCollection index collection | 180399 180400 index := 0. 180401 collection := self nonEmptyMoreThan1Element . 180402 newCollection := collection copy. 180403 result:=collection with: newCollection collect: [:a :b | 180404 self assert: (collection indexOf: a ) = ( index := index + 1). 180405 self assert: (a = b). 180406 b]. 180407 180408 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 180409 self assert: result size = collection size.! ! 180410 180411!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180412testWithCollectError 180413 self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! 180414 180415!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180416testWithDo 180417 180418 | secondCollection result index | 180419 result:= OrderedCollection new. 180420 secondCollection:= self nonEmptyMoreThan1Element copy. 180421 index := 0. 180422 180423 self nonEmptyMoreThan1Element with: secondCollection do: 180424 [:a :b | 180425 self assert: (self nonEmptyMoreThan1Element indexOf: a) = ( index := index + 1). 180426 result add: (a =b)]. 180427 180428 1 to: result size do: 180429 [:i| 180430 self assert: (result at:i)=(true)]. 180431 self assert: result size = self nonEmptyMoreThan1Element size.! ! 180432 180433!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180434testWithDoError 180435 180436 self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! 180437 180438!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180439testWithIndexCollect 180440 180441 | result index collection | 180442 index := 0. 180443 collection := self nonEmptyMoreThan1Element . 180444 result := collection withIndexCollect: [:each :i | 180445 self assert: i = (index := index + 1). 180446 self assert: i = (collection indexOf: each) . 180447 each] . 180448 180449 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 180450 self assert: result size = collection size.! ! 180451 180452!LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 180453testWithIndexDo 180454 180455 "| result | 180456 result:=Array new: self nonEmptyMoreThan1Element size. 180457 self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 180458 180459 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" 180460 | indexes elements | 180461 indexes:= OrderedCollection new. 180462 elements := OrderedCollection new. 180463 180464 self nonEmptyMoreThan1Element withIndexDo: 180465 [:value :i | 180466 indexes add: (i). 180467 elements add: value]. 180468 180469 (1 to: self nonEmptyMoreThan1Element size )do: 180470 [ :i | 180471 self assert: (indexes at: i) = i. 180472 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 180473 ]. 180474 180475 self assert: indexes size = elements size. 180476 self assert: indexes size = self nonEmptyMoreThan1Element size . 180477 ! ! 180478 180479 180480!LinkedListTest methodsFor: 'tests - iterating'! 180481testAllSatisfy 180482 180483 | element | 180484 " when all element satisfy the condition, should return true : " 180485 self assert: ( self collectionWithoutNilElements allSatisfy: [:each | (each notNil) ] ). 180486 180487 " when all element don't satisfy the condition, should return false : " 180488 self deny: ( self collectionWithoutNilElements allSatisfy: [:each | (each notNil) not ] ). 180489 180490 " when only one element doesn't satisfy the condition' should return false'" 180491 element := self collectionWithoutNilElements anyOne. 180492 self deny: ( self collectionWithoutNilElements allSatisfy: [:each | (each = element) not] ).! ! 180493 180494!LinkedListTest methodsFor: 'tests - iterating'! 180495testAllSatisfyEmpty 180496 180497 self assert: ( self empty allSatisfy: [:each | false]). 180498 ! ! 180499 180500!LinkedListTest methodsFor: 'tests - iterating'! 180501testAnySastify 180502 180503 | element | 180504 " when all elements satisty the condition, should return true :" 180505 self assert: ( self collectionWithoutNilElements anySatisfy: [:each | each notNil ]). 180506 180507 " when only one element satisfy the condition, should return true :" 180508 element := self collectionWithoutNilElements anyOne. 180509 self assert: ( self collectionWithoutNilElements anySatisfy: [:each | (each = element) ] ). 180510 180511 " when all elements don't satisty the condition, should return false :" 180512 self deny: ( self collectionWithoutNilElements anySatisfy: [:each | (each notNil) not ]). 180513! ! 180514 180515!LinkedListTest methodsFor: 'tests - iterating'! 180516testBasicCollect 180517 180518 | res index | 180519 index := 0. 180520 res := self collectionWithoutNilElements collect: [ 180521 :each | 180522 index := index + 1. 180523 each 180524 ]. 180525 180526 res do:[:each | self assert: (self collectionWithoutNilElements occurrencesOf: each) = (res occurrencesOf: each)]. 180527 self assert: index = self collectionWithoutNilElements size. 180528 ! ! 180529 180530!LinkedListTest methodsFor: 'tests - iterating'! 180531testBasicCollectEmpty 180532 180533 | res | 180534 res := self empty collect: [:each | each class]. 180535 self assert: res isEmpty 180536 ! ! 180537 180538!LinkedListTest methodsFor: 'tests - iterating'! 180539testCollectOnEmpty 180540 self assert: (self empty collect: [:e | self fail]) isEmpty! ! 180541 180542!LinkedListTest methodsFor: 'tests - iterating'! 180543testCollectThenSelectOnEmpty 180544 180545 self assert: (self empty collect: [:e | self fail] thenSelect: [:e | self fail]) isEmpty! ! 180546 180547!LinkedListTest methodsFor: 'tests - iterating'! 180548testDetect 180549 180550 | res element | 180551 element := self collectionWithoutNilElements anyOne . 180552 180553 res := self collectionWithoutNilElements detect: [:each | each = element]. 180554 self assert: (res = element). 180555 180556 180557 ! ! 180558 180559!LinkedListTest methodsFor: 'tests - iterating'! 180560testDetectIfNone 180561 180562 | res element | 180563 res := self collectionWithoutNilElements detect: [:each | each notNil not] ifNone: [100]. 180564 self assert: res = 100. 180565 180566 element := self collectionWithoutNilElements anyOne. 180567 res := self collectionWithoutNilElements detect: [:each | each = element] ifNone: [100]. 180568 self assert: res = element. 180569 180570 180571 ! ! 180572 180573!LinkedListTest methodsFor: 'tests - iterating'! 180574testDo2 180575 "dc: Bad test, it assumes that a new instance of #speciesClass allows addition with #add:. This is not the case of Interval for which species is Array." 180576 "res := self speciesClass new. 180577 self collection do: [:each | res add: each class]. 180578 self assert: res = self result. " 180579 | collection cptElementsViewed cptElementsIn | 180580 collection := self collectionWithoutNilElements. 180581 cptElementsViewed := 0. 180582 cptElementsIn := OrderedCollection new. 180583 collection do: 180584 [ :each | 180585 cptElementsViewed := cptElementsViewed + 1. 180586 " #do doesn't iterate with the same objects than those in the collection for FloatArray( I don' t know why ) . That's why I use #includes: and not #identityIncludes: '" 180587 (collection includes: each) ifTrue: [ 180588 " the collection used doesn't include equal elements. Therefore each element viewed should not have been viewed before " 180589 ( cptElementsIn includes: each ) ifFalse: [ cptElementsIn add: each ] . 180590 ]. 180591 ]. 180592 self assert: cptElementsViewed = collection size. 180593 self assert: cptElementsIn size = collection size. 180594 180595 ! ! 180596 180597!LinkedListTest methodsFor: 'tests - iterating'! 180598testDoSeparatedBy 180599 | string expectedString beforeFirst | 180600 180601 string := ''. 180602 self collectionWithoutNilElements 180603 do: [ :each | string := string , each asString ] 180604 separatedBy: [ string := string , '|' ]. 180605 180606 expectedString := ''. 180607 beforeFirst := true. 180608 self collectionWithoutNilElements do: 180609 [ :each | 180610 beforeFirst = true 180611 ifTrue: [ beforeFirst := false ] 180612 ifFalse: [ expectedString := expectedString , '|' ]. 180613 expectedString := expectedString , each asString ]. 180614 self assert: expectedString = string! ! 180615 180616!LinkedListTest methodsFor: 'tests - iterating'! 180617testDoWithout 180618 "self debug: #testDoWithout" 180619 180620 | res element collection | 180621 collection := self collectionWithoutNilElements . 180622 res := OrderedCollection new. 180623 element := self collectionWithoutNilElements anyOne . 180624 collection do: [:each | res add: each] without: element . 180625 " verifying result :" 180626 self assert: res size = (collection size - (collection occurrencesOf: element)). 180627 res do: [:each | self assert: (collection occurrencesOf: each) = ( res occurrencesOf: each ) ]. 180628 ! ! 180629 180630!LinkedListTest methodsFor: 'tests - iterating'! 180631testInjectInto 180632 |result| 180633 result:= self collectionWithoutNilElements 180634 inject: 0 180635 into: [:inj :ele | ele notNil ifTrue: [ inj + 1 ]]. 180636 180637 self assert: self collectionWithoutNilElements size = result .! ! 180638 180639!LinkedListTest methodsFor: 'tests - iterating'! 180640testNoneSatisfy 180641 180642 | element | 180643 self assert: ( self collectionWithoutNilElements noneSatisfy: [:each | each notNil not ] ). 180644 element := self collectionWithoutNilElements anyOne. 180645 self deny: ( self collectionWithoutNilElements noneSatisfy: [:each | (each = element)not ] ).! ! 180646 180647!LinkedListTest methodsFor: 'tests - iterating'! 180648testNoneSatisfyEmpty 180649 180650 self assert: ( self empty noneSatisfy: [:each | false]). 180651 ! ! 180652 180653!LinkedListTest methodsFor: 'tests - iterating'! 180654testReject 180655 180656 | res element | 180657 res := self collectionWithoutNilElements reject: [:each | each notNil not]. 180658 self assert: res size = self collectionWithoutNilElements size. 180659 180660 element := self collectionWithoutNilElements anyOne. 180661 res := self collectionWithoutNilElements reject: [:each | each = element]. 180662 self assert: res size = (self collectionWithoutNilElements size - 1). 180663 180664 180665 ! ! 180666 180667!LinkedListTest methodsFor: 'tests - iterating'! 180668testRejectEmpty 180669 180670 | res | 180671 res := self empty reject: [:each | each odd]. 180672 self assert: res size = self empty size 180673 ! ! 180674 180675!LinkedListTest methodsFor: 'tests - iterating'! 180676testRejectNoReject 180677 180678 | res | 180679 res := self collectionWithoutNilElements reject: [:each | each notNil not]. 180680 self assert: res size = self collectionWithoutNilElements size. 180681 ! ! 180682 180683!LinkedListTest methodsFor: 'tests - iterating'! 180684testSelect 180685 180686 | res element | 180687 res := self collectionWithoutNilElements select: [:each | each notNil]. 180688 self assert: res size = self collectionWithoutNilElements size. 180689 180690 element := self collectionWithoutNilElements anyOne. 180691 res := self collectionWithoutNilElements select: [:each | (each = element) not]. 180692 self assert: res size = (self collectionWithoutNilElements size - 1). 180693 ! ! 180694 180695!LinkedListTest methodsFor: 'tests - iterating'! 180696testSelectOnEmpty 180697 180698 self assert: (self empty select: [:e | self fail]) isEmpty 180699 ! ! 180700 180701 180702!LinkedListTest methodsFor: 'tests - occurrencesOf'! 180703testOccurrencesOf 180704 | collection | 180705 collection := self collectionWithoutEqualElements . 180706 180707 collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! 180708 180709!LinkedListTest methodsFor: 'tests - occurrencesOf'! 180710testOccurrencesOfEmpty 180711 | result | 180712 result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). 180713 self assert: result = 0! ! 180714 180715!LinkedListTest methodsFor: 'tests - occurrencesOf'! 180716testOccurrencesOfNotIn 180717 | result | 180718 result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. 180719 self assert: result = 0! ! 180720 180721 180722!LinkedListTest methodsFor: 'tests - printing'! 180723testPrintElementsOn 180724 180725 | aStream result allElementsAsString tmp | 180726 result:=''. 180727 aStream:= ReadWriteStream on: result. 180728 tmp:= OrderedCollection new. 180729 self nonEmpty do: [:each | tmp add: each asString]. 180730 180731 self nonEmpty printElementsOn: aStream . 180732 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 180733 1 to: allElementsAsString size do: 180734 [:i | 180735 self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)). 180736 ].! ! 180737 180738!LinkedListTest methodsFor: 'tests - printing'! 180739testPrintNameOn 180740 180741 | aStream result | 180742 result:=''. 180743 aStream:= ReadWriteStream on: result. 180744 180745 self nonEmpty printNameOn: aStream . 180746 Transcript show: result asString. 180747 self nonEmpty class name first isVowel 180748 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 180749 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 180750 180751!LinkedListTest methodsFor: 'tests - printing'! 180752testPrintOn 180753 | aStream result allElementsAsString tmp | 180754 result:=''. 180755 aStream:= ReadWriteStream on: result. 180756 tmp:= OrderedCollection new. 180757 self nonEmpty do: [:each | tmp add: each asString]. 180758 180759 self nonEmpty printOn: aStream . 180760 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 180761 1 to: allElementsAsString size do: 180762 [:i | 180763 i=1 180764 ifTrue:[ 180765 self accessCollection class name first isVowel 180766 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 180767 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 180768 i=2 180769 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 180770 i>2 180771 ifTrue:[self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)).]. 180772 ].! ! 180773 180774!LinkedListTest methodsFor: 'tests - printing'! 180775testPrintOnDelimiter 180776 | aStream result allElementsAsString tmp | 180777 result:=''. 180778 aStream:= ReadWriteStream on: result. 180779 tmp:= OrderedCollection new. 180780 self nonEmpty do: [:each | tmp add: each asString]. 180781 180782 180783 180784 self nonEmpty printOn: aStream delimiter: ', ' . 180785 180786 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 180787 1 to: allElementsAsString size do: 180788 [:i | 180789 self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)) 180790 ].! ! 180791 180792!LinkedListTest methodsFor: 'tests - printing'! 180793testPrintOnDelimiterLast 180794 180795 | aStream result allElementsAsString tmp | 180796 result:=''. 180797 aStream:= ReadWriteStream on: result. 180798 tmp:= OrderedCollection new. 180799 self nonEmpty do: [:each | tmp add: each asString]. 180800 180801 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 180802 180803 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 180804 1 to: allElementsAsString size do: 180805 [:i | 180806 i<(allElementsAsString size-1 ) 180807 ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. 180808 i=(allElementsAsString size-1) 180809 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 180810 i=(allElementsAsString size) 180811 ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. 180812 ].! ! 180813 180814!LinkedListTest methodsFor: 'tests - printing'! 180815testStoreOn 180816" for the moment work only for collection that include simple elements such that Integer" 180817 180818"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 180819string := ''. 180820str := ReadWriteStream on: string. 180821elementsAsStringExpected := OrderedCollection new. 180822elementsAsStringObtained := OrderedCollection new. 180823self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 180824 180825self nonEmpty storeOn: str. 180826result := str contents . 180827cuttedResult := ( result findBetweenSubStrs: ';' ). 180828 180829index := 1. 180830 180831cuttedResult do: 180832 [ :each | 180833 index = 1 180834 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 180835 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 180836 elementsAsStringObtained add: tmp. 180837 index := index + 1. ] 180838 ifFalse: [ 180839 index < cuttedResult size 180840 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 180841 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 180842 elementsAsStringObtained add: tmp. 180843 index := index + 1.] 180844 ifFalse: [self assert: ( each = ' yourself)' ) ]. 180845 ] 180846 180847 ]. 180848 180849 180850 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 180851 180852! ! 180853 180854 180855!LinkedListTest methodsFor: 'tests - remove'! 180856testRemoveAllError 180857 "self debug: #testRemoveElementThatExists" 180858 | el res subCollection | 180859 el := self elementNotIn. 180860 subCollection := self nonEmptyWithoutEqualElements copyWith: el. 180861 self 180862 should: [ res := self nonEmptyWithoutEqualElements removeAll: subCollection ] 180863 raise: Error! ! 180864 180865!LinkedListTest methodsFor: 'tests - remove'! 180866testRemoveAllFoundIn 180867 "self debug: #testRemoveElementThatExists" 180868 | el res subCollection | 180869 el := self nonEmptyWithoutEqualElements anyOne. 180870 subCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. 180871 self 180872 shouldnt: 180873 [ res := self nonEmptyWithoutEqualElements removeAllFoundIn: subCollection ] 180874 raise: Error. 180875 self assert: self nonEmptyWithoutEqualElements size = 1. 180876 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 180877 180878!LinkedListTest methodsFor: 'tests - remove'! 180879testRemoveAllSuchThat 180880 "self debug: #testRemoveElementThatExists" 180881 | el subCollection | 180882 el := self nonEmptyWithoutEqualElements anyOne. 180883 subCollection := self nonEmptyWithoutEqualElements copyWithout: el. 180884 self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | subCollection includes: each ]. 180885 self assert: self nonEmptyWithoutEqualElements size = 1. 180886 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 180887 180888!LinkedListTest methodsFor: 'tests - remove'! 180889testRemoveElementFromEmpty 180890 "self debug: #testRemoveElementFromEmpty" 180891 self 180892 should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] 180893 raise: Error! ! 180894 180895!LinkedListTest methodsFor: 'tests - remove'! 180896testRemoveElementReallyRemovesElement 180897 "self debug: #testRemoveElementReallyRemovesElement" 180898 | size | 180899 size := self nonEmptyWithoutEqualElements size. 180900 self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. 180901 self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! 180902 180903!LinkedListTest methodsFor: 'tests - remove'! 180904testRemoveElementThatExists 180905 "self debug: #testRemoveElementThatExists" 180906 | el res | 180907 el := self nonEmptyWithoutEqualElements anyOne. 180908 self 180909 shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] 180910 raise: Error. 180911 self assert: res == el! ! 180912 180913!LinkedListTest methodsFor: 'tests - remove'! 180914testRemoveIfAbsent 180915 "self debug: #testRemoveElementThatExists" 180916 | el res | 180917 el := self elementNotIn. 180918 self 180919 shouldnt: 180920 [ res := self nonEmptyWithoutEqualElements 180921 remove: el 180922 ifAbsent: [ 33 ] ] 180923 raise: Error. 180924 self assert: res == 33! ! 180925 180926 180927!LinkedListTest methodsFor: 'tests - set arithmetic'! 180928containsAll: union of: one andOf: another 180929 180930 self assert: (one allSatisfy: [:each | union includes: each]). 180931 self assert: (another allSatisfy: [:each | union includes: each])! ! 180932 180933!LinkedListTest methodsFor: 'tests - set arithmetic'! 180934numberOfSimilarElementsInIntersection 180935 ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! 180936 180937!LinkedListTest methodsFor: 'tests - set arithmetic'! 180938testDifference 180939 "Answer the set theoretic difference of two collections." 180940 "self debug: #testDifference" 180941 180942 self assert: (self collection difference: self collection) isEmpty. 180943 self assert: (self empty difference: self collection) isEmpty. 180944 self assert: (self collection difference: self empty) = self collection 180945! ! 180946 180947!LinkedListTest methodsFor: 'tests - set arithmetic'! 180948testDifferenceWithNonNullIntersection 180949 "Answer the set theoretic difference of two collections." 180950 "self debug: #testDifferenceWithNonNullIntersection" 180951 " #(1 2 3) difference: #(2 4) 180952 -> #(1 3)" 180953 | res overlapping | 180954 overlapping := self collectionClass 180955 with: self anotherElementOrAssociationNotIn 180956 with: self anotherElementOrAssociationIn. 180957 res := self collection difference: overlapping. 180958 self deny: (res includes: self anotherElementOrAssociationIn). 180959 overlapping do: [ :each | self deny: (res includes: each) ]! ! 180960 180961!LinkedListTest methodsFor: 'tests - set arithmetic'! 180962testDifferenceWithSeparateCollection 180963 "Answer the set theoretic difference of two collections." 180964 "self debug: #testDifferenceWithSeparateCollection" 180965 | res separateCol | 180966 separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. 180967 res := self collection difference: separateCol. 180968 self deny: (res includes: self anotherElementOrAssociationNotIn). 180969 self assert: res = self collection. 180970 res := separateCol difference: self collection. 180971 self deny: (res includes: self collection anyOne). 180972 self assert: res = separateCol! ! 180973 180974!LinkedListTest methodsFor: 'tests - set arithmetic'! 180975testIntersectionBasic 180976 "self debug: #testIntersectionBasic" 180977 | inter | 180978 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 180979 self deny: inter isEmpty. 180980 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 180981 180982!LinkedListTest methodsFor: 'tests - set arithmetic'! 180983testIntersectionEmpty 180984 "self debug: #testIntersectionEmpty" 180985 180986 | inter | 180987 inter := self empty intersection: self empty. 180988 self assert: inter isEmpty. 180989 inter := self empty intersection: self collection . 180990 self assert: inter = self empty. 180991 ! ! 180992 180993!LinkedListTest methodsFor: 'tests - set arithmetic'! 180994testIntersectionItself 180995 "self debug: #testIntersectionItself" 180996 180997 self assert: (self collection intersection: self collection) = self collection. 180998 ! ! 180999 181000!LinkedListTest methodsFor: 'tests - set arithmetic'! 181001testIntersectionTwoSimilarElementsInIntersection 181002 "self debug: #testIntersectionBasic" 181003 | inter | 181004 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 181005 self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. 181006 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 181007 181008!LinkedListTest methodsFor: 'tests - set arithmetic'! 181009testUnion 181010 "self debug: #testUnionOfEmpties" 181011 181012 | union | 181013 union := self empty union: self nonEmpty. 181014 self containsAll: union of: self empty andOf: self nonEmpty. 181015 union := self nonEmpty union: self empty. 181016 self containsAll: union of: self empty andOf: self nonEmpty. 181017 union := self collection union: self nonEmpty. 181018 self containsAll: union of: self collection andOf: self nonEmpty.! ! 181019 181020!LinkedListTest methodsFor: 'tests - set arithmetic'! 181021testUnionOfEmpties 181022 "self debug: #testUnionOfEmpties" 181023 181024 self assert: (self empty union: self empty) isEmpty. 181025 181026 ! ! 181027 181028 181029!LinkedListTest methodsFor: 'tests - subcollections access'! 181030testAllButFirst 181031 "self debug: #testAllButFirst" 181032 | abf col | 181033 col := self moreThan3Elements. 181034 abf := col allButFirst. 181035 self deny: abf first = col first. 181036 self assert: abf size + 1 = col size! ! 181037 181038!LinkedListTest methodsFor: 'tests - subcollections access'! 181039testAllButFirstNElements 181040 "self debug: #testAllButFirst" 181041 | abf col | 181042 col := self moreThan3Elements. 181043 abf := col allButFirst: 2. 181044 1 181045 to: abf size 181046 do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. 181047 self assert: abf size + 2 = col size! ! 181048 181049!LinkedListTest methodsFor: 'tests - subcollections access'! 181050testAllButLast 181051 "self debug: #testAllButLast" 181052 | abf col | 181053 col := self moreThan3Elements. 181054 abf := col allButLast. 181055 self deny: abf last = col last. 181056 self assert: abf size + 1 = col size! ! 181057 181058!LinkedListTest methodsFor: 'tests - subcollections access'! 181059testAllButLastNElements 181060 "self debug: #testAllButFirst" 181061 | abf col | 181062 col := self moreThan3Elements. 181063 abf := col allButLast: 2. 181064 1 181065 to: abf size 181066 do: [ :i | self assert: (abf at: i) = (col at: i) ]. 181067 self assert: abf size + 2 = col size! ! 181068 181069!LinkedListTest methodsFor: 'tests - subcollections access'! 181070testFirstNElements 181071 "self debug: #testFirstNElements" 181072 | result | 181073 result := self moreThan3Elements first: self moreThan3Elements size - 1. 181074 1 181075 to: result size 181076 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. 181077 self assert: result size = (self moreThan3Elements size - 1). 181078 self 181079 should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] 181080 raise: Error! ! 181081 181082!LinkedListTest methodsFor: 'tests - subcollections access'! 181083testLastNElements 181084 "self debug: #testLastNElements" 181085 | result | 181086 result := self moreThan3Elements last: self moreThan3Elements size - 1. 181087 1 181088 to: result size 181089 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. 181090 self assert: result size = (self moreThan3Elements size - 1). 181091 self 181092 should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] 181093 raise: Error! ! 181094 181095"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 181096 181097LinkedListTest class 181098 uses: TAddTest classTrait + TEmptyTest classTrait + TIterateTest classTrait + TIterateSequencedReadableTest classTrait + TPrintTest classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TIndexAccess classTrait + TSequencedElementAccessTest classTrait + TSubCollectionAccess classTrait + TConvertTest classTrait + TCopyPartOfSequenceable classTrait + TCopySequenceableSameContents classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopyTest classTrait + TCopySequenceableWithReplacement classTrait + TBeginsEndsWith classTrait + TRemoveTest classTrait + TSetArithmetic classTrait + TIncludesWithIdentityCheckTest classTrait + TStructuralEqualityTest classTrait + TOccurrencesTest classTrait 181099 instanceVariableNames: ''! 181100Object subclass: #ListItemWrapper 181101 instanceVariableNames: 'item model' 181102 classVariableNames: '' 181103 poolDictionaries: '' 181104 category: 'Morphic-Explorer'! 181105!ListItemWrapper commentStamp: '<historical>' prior: 0! 181106Contributed by Bob Arning as part of the ObjectExplorer package. 181107! 181108 181109 181110!ListItemWrapper methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/23/2006 15:53'! 181111item 181112 "Answer the item. It is useful!!" 181113 181114 ^item! ! 181115 181116!ListItemWrapper methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/26/2006 11:11'! 181117model 181118 "Answer the model. It is useful!!" 181119 181120 ^model! ! 181121 181122 181123!ListItemWrapper methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/11/2006 13:53'! 181124highlightingColor 181125 181126 ^Color black! ! 181127 181128 181129!ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 7/21/2000 10:59'! 181130balloonText 181131 181132 ^nil! ! 181133 181134!ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 3/31/1999 16:32'! 181135contents 181136 181137 ^Array new! ! 181138 181139!ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 4/1/1999 20:09'! 181140hasContents 181141 181142 ^self contents isEmpty not! ! 181143 181144!ListItemWrapper methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:22'! 181145icon 181146 "Answer a form to be used as icon" 181147 ^ nil! ! 181148 181149!ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 4/2/1999 15:14'! 181150preferredColor 181151 181152 ^nil! ! 181153 181154!ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 3/30/1999 18:27'! 181155setItem: anObject 181156 181157 item := anObject! ! 181158 181159!ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 3/31/1999 16:44'! 181160setItem: anObject model: aModel 181161 181162 item := anObject. 181163 model := aModel.! ! 181164 181165 181166!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/30/1999 18:13'! 181167acceptDroppingObject: anotherItem 181168 181169 ^item acceptDroppingObject: anotherItem! ! 181170 181171!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 12:25'! 181172canBeDragged 181173 181174 ^true! ! 181175 181176!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:24'! 181177handlesMouseOver: evt 181178 181179 ^false! ! 181180 181181!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 12:15'! 181182hasEquivalentIn: aCollection 181183 181184 aCollection detect: [ :each | 181185 each withoutListWrapper = item withoutListWrapper 181186 ] ifNone: [^false]. 181187 ^true! ! 181188 181189!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 4/4/1999 17:58'! 181190sendSettingMessageTo: aModel 181191 181192 aModel 181193 perform: (self settingSelector ifNil: [^self]) 181194 with: self withoutListWrapper 181195! ! 181196 181197!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 21:31'! 181198settingSelector 181199 181200 ^nil! ! 181201 181202!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:32'! 181203wantsDroppedObject: anotherItem 181204 181205 ^false! ! 181206 181207 181208!ListItemWrapper methodsFor: 'converting' stamp: 'RAA 3/30/1999 18:17'! 181209asString 181210 181211 ^item asString! ! 181212 181213!ListItemWrapper methodsFor: 'converting' stamp: 'RAA 3/31/1999 12:13'! 181214withoutListWrapper 181215 181216 ^item withoutListWrapper! ! 181217 181218"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 181219 181220ListItemWrapper class 181221 instanceVariableNames: ''! 181222 181223!ListItemWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 3/30/1999 18:28'! 181224with: anObject 181225 181226 ^self new setItem: anObject! ! 181227 181228!ListItemWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:44'! 181229with: anObject model: aModel 181230 181231 ^self new setItem: anObject model: aModel! ! 181232Object subclass: #ListModel 181233 instanceVariableNames: 'list selectionIndex' 181234 classVariableNames: '' 181235 poolDictionaries: '' 181236 category: 'Polymorph-Widgets'! 181237!ListModel commentStamp: 'gvc 9/23/2008 11:31' prior: 0! 181238Resusable model for a simple single selection list.! 181239 181240 181241!ListModel methodsFor: 'accessing' stamp: 'gvc 8/2/2007 12:14'! 181242list 181243 "Answer the value of list" 181244 181245 ^ list! ! 181246 181247!ListModel methodsFor: 'accessing' stamp: 'gvc 8/2/2007 12:14'! 181248list: anObject 181249 "Set the value of list" 181250 181251 list := anObject. 181252 self changed: #list! ! 181253 181254!ListModel methodsFor: 'accessing' stamp: 'gvc 9/23/2008 11:32'! 181255selectedItem 181256 "Answer the currently selected item or nil if none." 181257 181258 ^self selectionIndex = 0 181259 ifTrue: [nil] 181260 ifFalse: [self list at: self selectionIndex]! ! 181261 181262!ListModel methodsFor: 'accessing' stamp: 'gvc 8/2/2007 12:14'! 181263selectionIndex 181264 "Answer the value of selectionIndex" 181265 181266 ^ selectionIndex! ! 181267 181268!ListModel methodsFor: 'accessing' stamp: 'gvc 8/2/2007 12:14'! 181269selectionIndex: anObject 181270 "Set the value of selectionIndex" 181271 181272 selectionIndex := anObject. 181273 self changed: #selectionIndex! ! 181274 181275 181276!ListModel methodsFor: 'initialize-release' stamp: 'gvc 8/2/2007 12:14'! 181277initialize 181278 "Initialize the receiver." 181279 181280 super initialize. 181281 self 181282 list: #(); 181283 selectionIndex: 0! ! 181284Paragraph subclass: #ListParagraph 181285 instanceVariableNames: '' 181286 classVariableNames: 'ListStyle' 181287 poolDictionaries: '' 181288 category: 'ST80-Support'! 181289!ListParagraph commentStamp: '<historical>' prior: 0! 181290I represent a special type of Paragraph that is used in the list panes of a browser. I avoid all the composition done by more general Paragraphs, because I know the structure of my Text.! 181291 181292 181293!ListParagraph methodsFor: 'composition'! 181294composeAll 181295 "No composition is necessary once the ListParagraph is created." 181296 181297 lastLine isNil ifTrue: [lastLine := 0]. 181298 "Because composeAll is called once in the process of creating the ListParagraph." 181299 ^compositionRectangle width! ! 181300 181301 181302!ListParagraph methodsFor: 'private'! 181303trimLinesTo: lastLineInteger 181304 "Since ListParagraphs are not designed to be changed, we can cut back the 181305 lines field to lastLineInteger." 181306 lastLine := lastLineInteger. 181307 lines := lines copyFrom: 1 to: lastLine! ! 181308 181309!ListParagraph methodsFor: 'private' stamp: 'di 7/13/97 16:56'! 181310withArray: anArray 181311 "Modifies self to contain the list of strings in anArray" 181312 | startOfLine endOfLine lineIndex aString | 181313 lines := Array new: 20. 181314 lastLine := 0. 181315 startOfLine := 1. 181316 endOfLine := 1. 181317 lineIndex := 0. 181318 anArray do: 181319 [:item | 181320 endOfLine := startOfLine + item size. "this computation allows for a cr after each line..." 181321 "...but later we will adjust for no cr after last line" 181322 lineIndex := lineIndex + 1. 181323 self lineAt: lineIndex put: 181324 ((TextLineInterval start: startOfLine stop: endOfLine 181325 internalSpaces: 0 paddingWidth: 0) 181326 lineHeight: textStyle lineGrid baseline: textStyle baseline). 181327 startOfLine := endOfLine + 1]. 181328 endOfLine := endOfLine - 1. "endOfLine is now the total size of the text" 181329 self trimLinesTo: lineIndex. 181330 aString := String new: endOfLine. 181331 anArray with: lines do: 181332 [:item :interval | 181333 aString 181334 replaceFrom: interval first 181335 to: interval last - 1 181336 with: item asString 181337 startingAt: 1. 181338 interval last <= endOfLine ifTrue: [aString at: interval last put: Character cr]]. 181339 lineIndex > 0 ifTrue: [(lines at: lineIndex) stop: endOfLine]. "adjust for no cr after last line" 181340 self text: aString asText. 181341 anArray with: lines do: 181342 [:item :interval | item isText ifTrue: 181343 [text replaceFrom: interval first to: interval last - 1 with: item]]. 181344 self updateCompositionHeight! ! 181345 181346"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 181347 181348ListParagraph class 181349 instanceVariableNames: ''! 181350 181351!ListParagraph class methodsFor: 'initialization' stamp: 'nk 9/1/2004 10:27'! 181352initialize 181353 "ListParagraph initialize" 181354 | aFont | 181355 "Allow different line spacing for lists" 181356 aFont := Preferences standardListFont. 181357 ListStyle := TextStyle fontArray: { aFont }. 181358 ListStyle gridForFont: 1 withLead: 1! ! 181359 181360 181361!ListParagraph class methodsFor: 'instance creation' stamp: 'jm 9/20/1998 17:10'! 181362withArray: anArray style: aTextStyleOrNil 181363 "Convert an array of strings into a ListParagraph using the given TextStyle." 181364 181365 aTextStyleOrNil 181366 ifNil: [^ (super withText: Text new style: ListStyle) withArray: anArray] 181367 ifNotNil: [^ (super withText: Text new style: aTextStyleOrNil) withArray: anArray]. 181368! ! 181369 181370 181371!ListParagraph class methodsFor: 'style' stamp: 'sw 12/10/1999 10:43'! 181372standardListStyle 181373 ^ ListStyle! ! 181374WidgetStub subclass: #ListStub 181375 instanceVariableNames: 'list index' 181376 classVariableNames: '' 181377 poolDictionaries: '' 181378 category: 'ToolBuilder-SUnit'! 181379 181380!ListStub methodsFor: 'events' stamp: 'cwp 4/22/2005 22:35'! 181381eventAccessors 181382 ^ #(list getIndex setIndex getSelected setSelected menu keyPress autoDeselect)! ! 181383 181384!ListStub methodsFor: 'events' stamp: 'cwp 5/26/2005 08:39'! 181385refresh 181386 self refreshList. 181387 self refreshIndex! ! 181388 181389!ListStub methodsFor: 'events' stamp: 'stephaneducasse 2/3/2006 22:32'! 181390refreshIndex 181391 | selector | 181392 selector := spec getIndex. 181393 index := selector 181394 ifNil: [self list indexOf: (self model perform: spec getSelected)] 181395 ifNotNil: [spec model perform: selector] 181396! ! 181397 181398!ListStub methodsFor: 'events' stamp: 'cwp 5/26/2005 08:32'! 181399refreshList 181400 list := self model perform: spec list! ! 181401 181402!ListStub methodsFor: 'events' stamp: 'cwp 5/26/2005 08:57'! 181403update: aSelector 181404 aSelector = spec list ifTrue: [^ self refreshList]. 181405 aSelector = spec getSelected ifTrue: [^ self refreshIndex]. 181406 aSelector = spec getIndex ifTrue: [^ self refreshIndex]. 181407 ^ super update: aSelector! ! 181408 181409 181410!ListStub methodsFor: 'simulating' stamp: 'stephaneducasse 2/3/2006 22:32'! 181411clickItemAt: anInteger 181412 | selector | 181413 selector := spec setIndex. 181414 selector 181415 ifNil: [self model perform: spec setSelected with: (self list at: anInteger)] 181416 ifNotNil: [self model perform: selector with: anInteger] 181417! ! 181418 181419!ListStub methodsFor: 'simulating' stamp: 'cwp 5/27/2005 08:16'! 181420click: aString 181421 self clickItemAt: (self list indexOf: aString)! ! 181422 181423!ListStub methodsFor: 'simulating' stamp: 'cwp 5/26/2005 08:39'! 181424list 181425 ^ list ifNil: [Array new]! ! 181426 181427!ListStub methodsFor: 'simulating' stamp: 'cwp 6/9/2005 08:15'! 181428menu 181429 ^ MenuStub fromSpec: 181430 (self model 181431 perform: spec menu 181432 with: (PluggableMenuSpec withModel: self model))! ! 181433 181434!ListStub methodsFor: 'simulating' stamp: 'cwp 5/27/2005 08:22'! 181435selectedIndex 181436 ^ index ifNil: [0]! ! 181437 181438!ListStub methodsFor: 'simulating' stamp: 'cwp 5/27/2005 08:27'! 181439selectedItem 181440 | items idx | 181441 (items := self list) isEmpty ifTrue: [^ nil]. 181442 (idx := self selectedIndex) = 0 ifTrue: [^ nil]. 181443 ^ items at: idx 181444 ! ! 181445Dictionary subclass: #LiteralDictionary 181446 instanceVariableNames: '' 181447 classVariableNames: '' 181448 poolDictionaries: '' 181449 category: 'Compiler-Support'! 181450!LiteralDictionary commentStamp: '<historical>' prior: 0! 181451A LiteralDictionary, like an IdentityDictionary, has a special test for equality. In this case it is simple equality between objects of like class. This allows equal Float or String literals to be shared without the possibility of erroneously sharing, say, 1 and 1.0! 181452 181453 181454!LiteralDictionary methodsFor: 'internal' stamp: 'md 10/5/2005 15:43'! 181455scanFor: anObject 181456 "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 181457 | element start finish | 181458 finish := array size. 181459 start := (anObject hash \\ finish) + 1. 181460 181461 "Search from (hash mod size) to the end." 181462 start to: finish do: 181463 [:index | ((element := array at: index) == nil 181464 or: [self literalEquality: element key and: anObject]) 181465 ifTrue: [^ index ]]. 181466 181467 "Search from 1 to where we started." 181468 1 to: start-1 do: 181469 [:index | ((element := array at: index) == nil 181470 or: [self literalEquality: element key and: anObject]) 181471 ifTrue: [^ index ]]. 181472 181473 ^ 0 "No match AND no empty slot"! ! 181474 181475 181476!LiteralDictionary methodsFor: 'testing' stamp: 'nice 8/28/2008 19:26'! 181477literalEquality: x and: y 181478 "Check if two literals should be considered equal and reduced to a single literal. 181479 Delegate this task to the literal themselves, they are aware of their peculiarities and know how to behave." 181480 181481 ^ x literalEqual: y 181482! ! 181483DictionaryTest subclass: #LiteralDictionaryTest 181484 instanceVariableNames: '' 181485 classVariableNames: '' 181486 poolDictionaries: '' 181487 category: 'CollectionsTests-Unordered'! 181488 181489!LiteralDictionaryTest methodsFor: 'problems' stamp: 'cyrille.delaunay 7/17/2009 11:17'! 181490testUnCategorizedMethods 181491"this test doesn't pass :" 181492 | categories slips | 181493 categories := self categoriesForClass: self targetClass. 181494 slips := categories select: [:each | each = #'as yet unclassified']. 181495 self should: [slips isEmpty]. ! ! 181496 181497 181498!LiteralDictionaryTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 12:57'! 181499classToBeTested 181500 181501^ LiteralDictionary! ! 181502 181503 181504!LiteralDictionaryTest methodsFor: 'tests - literal specific behavior' stamp: 'cyrille.delaunay 7/17/2009 11:17'! 181505testIncludesWithEqualElementFromDifferentClasses 181506 181507| dict | 181508dict := self classToBeTested new. 181509 181510dict at: 1 put: 'element1'. 181511dict at: #key put: 1.0. 181512 181513self deny: (dict includesKey: 1.0). 181514self assert: (dict includes: 1)! ! 181515 181516"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 181517 181518LiteralDictionaryTest class 181519 instanceVariableNames: ''! 181520 181521!LiteralDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 12:58'! 181522shouldInheritSelectors 181523 181524^true! ! 181525LeafNode subclass: #LiteralNode 181526 instanceVariableNames: '' 181527 classVariableNames: '' 181528 poolDictionaries: '' 181529 category: 'Compiler-ParseNodes'! 181530!LiteralNode commentStamp: '<historical>' prior: 0! 181531I am a parse tree leaf representing a literal string or number.! 181532 181533 181534!LiteralNode methodsFor: 'code generation'! 181535emitForValue: stack on: strm 181536 181537 code < 256 181538 ifTrue: [strm nextPut: code] 181539 ifFalse: [self emitLong: LoadLong on: strm]. 181540 stack push: 1! ! 181541 181542 181543!LiteralNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:19'! 181544emitCodeForValue: stack encoder: encoder 181545 stack push: 1. 181546 (encoder 181547 if: code 181548 isSpecialLiteralForPush: 181549 [:specialLiteral| 181550 encoder genPushSpecialLiteral: specialLiteral]) 181551 ifFalse: 181552 [encoder genPushLiteral: index]! ! 181553 181554!LiteralNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:03'! 181555sizeCodeForValue: encoder 181556 self reserve: encoder. 181557 (encoder 181558 if: code 181559 isSpecialLiteralForPush: 181560 [:specialLiteral| 181561 ^encoder sizePushSpecialLiteral: specialLiteral]) 181562 ifFalse: 181563 [^encoder sizePushLiteral: index]! ! 181564 181565 181566!LiteralNode methodsFor: 'evaluation' stamp: 'tk 8/4/1999 17:35'! 181567eval 181568 "When everything in me is a constant, I can produce a value. This is only used by the Scripting system (TilePadMorph tilesFrom:in:)" 181569 181570 ^ key! ! 181571 181572 181573!LiteralNode methodsFor: 'initialize-release' stamp: 'eem 5/14/2008 09:30'! 181574name: literal key: object index: i type: type 181575 "For compatibility with Encoder>>name:key:class:type:set:" 181576 ^self key: object index: i type: type! ! 181577 181578 181579!LiteralNode methodsFor: 'printing' stamp: 'eem 5/6/2008 14:46'! 181580printOn: aStream indent: level 181581 181582 key isVariableBinding 181583 ifTrue: 181584 [key key isNil 181585 ifTrue: 181586 [aStream nextPutAll: '###'; nextPutAll: key value soleInstance name] 181587 ifFalse: 181588 [aStream nextPutAll: '##'; nextPutAll: key key]] 181589 ifFalse: 181590 [key storeOn: aStream]! ! 181591 181592!LiteralNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 181593printWithClosureAnalysisOn: aStream indent: level 181594 181595 key isVariableBinding 181596 ifTrue: 181597 [key key isNil 181598 ifTrue: 181599 [aStream nextPutAll: '###'; nextPutAll: key value soleInstance name] 181600 ifFalse: 181601 [aStream nextPutAll: '##'; nextPutAll: key key]] 181602 ifFalse: 181603 [key storeOn: aStream]! ! 181604 181605 181606!LiteralNode methodsFor: 'testing'! 181607isConstantNumber 181608 ^ key isNumber! ! 181609 181610!LiteralNode methodsFor: 'testing' stamp: 'di 4/5/2000 11:13'! 181611isLiteral 181612 181613 ^ true! ! 181614 181615!LiteralNode methodsFor: 'testing'! 181616isSpecialConstant 181617 ^ code between: LdTrue and: LdMinus1+3! ! 181618 181619!LiteralNode methodsFor: 'testing'! 181620literalValue 181621 181622 ^key! ! 181623 181624 181625!LiteralNode methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:48'! 181626accept: aVisitor 181627 aVisitor visitLiteralNode: self! ! 181628VariableNode subclass: #LiteralVariableNode 181629 instanceVariableNames: 'readNode writeNode' 181630 classVariableNames: '' 181631 poolDictionaries: '' 181632 category: 'Compiler-ParseNodes'! 181633 181634!LiteralVariableNode methodsFor: 'code generation' stamp: 'ar 8/14/2003 02:01'! 181635emitForValue: stack on: strm 181636 super emitForValue: stack on: strm. 181637 readNode ifNotNil:[readNode emit: stack args: 0 on: strm super: false].! ! 181638 181639!LiteralVariableNode methodsFor: 'code generation' stamp: 'ar 8/14/2003 01:59'! 181640emitLoad: stack on: strm 181641 writeNode ifNil:[^super emitLoad: stack on: strm]. 181642 code < 256 181643 ifTrue: [strm nextPut: code] 181644 ifFalse: [self emitLong: LoadLong on: strm]. 181645 stack push: 1.! ! 181646 181647!LiteralVariableNode methodsFor: 'code generation' stamp: 'ar 8/14/2003 02:00'! 181648emitStore: stack on: strm 181649 writeNode ifNil:[^super emitStore: stack on: strm]. 181650 writeNode 181651 emit: stack 181652 args: 1 181653 on: strm 181654 super: false.! ! 181655 181656!LiteralVariableNode methodsFor: 'code generation' stamp: 'ar 8/14/2003 02:00'! 181657emitStorePop: stack on: strm 181658 writeNode ifNil:[^super emitStorePop: stack on: strm]. 181659 self emitStore: stack on: strm. 181660 strm nextPut: Pop. 181661 stack pop: 1.! ! 181662 181663!LiteralVariableNode methodsFor: 'code generation' stamp: 'ar 8/14/2003 02:00'! 181664sizeForStore: encoder 181665 | index | 181666 (key isVariableBinding and:[key isSpecialWriteBinding]) 181667 ifFalse:[^super sizeForStore: encoder]. 181668 code < 0 ifTrue:[ 181669 index := self index. 181670 code := self code: index type: LdLitType]. 181671 writeNode := encoder encodeSelector: #value:. 181672 ^(writeNode size: encoder args: 1 super: false) + (super sizeForValue: encoder)! ! 181673 181674!LiteralVariableNode methodsFor: 'code generation' stamp: 'ar 8/14/2003 02:00'! 181675sizeForStorePop: encoder 181676 | index | 181677 (key isVariableBinding and:[key isSpecialWriteBinding]) 181678 ifFalse:[^super sizeForStorePop: encoder]. 181679 code < 0 ifTrue:[ 181680 index := self index. 181681 code := self code: index type: LdLitType]. 181682 writeNode := encoder encodeSelector: #value:. 181683 ^(writeNode size: encoder args: 1 super: false) + (super sizeForValue: encoder) + 1! ! 181684 181685!LiteralVariableNode methodsFor: 'code generation' stamp: 'ar 8/14/2003 02:02'! 181686sizeForValue: encoder 181687 | index | 181688 (key isVariableBinding and:[key isSpecialReadBinding]) 181689 ifFalse:[^super sizeForValue: encoder]. 181690 code < 0 ifTrue:[ 181691 index := self index. 181692 code := self code: index type: LdLitType]. 181693 readNode := encoder encodeSelector: #value. 181694 ^(readNode size: encoder args: 0 super: false) + (super sizeForValue: encoder)! ! 181695 181696 181697!LiteralVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/15/2008 09:44'! 181698emitCodeForLoad: stack encoder: encoder 181699 writeNode ifNotNil: 181700 [encoder genPushLiteral: index. 181701 stack push: 1]! ! 181702 181703!LiteralVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/15/2008 10:43'! 181704emitCodeForStore: stack encoder: encoder 181705 writeNode ifNil: [^encoder genStoreLiteralVar: index]. 181706 "THIS IS WRONG!!!! THE VALUE IS LOST FROM THE STACK!!!! 181707 The various value: methods on Association ReadOnlyVariableBinding 181708 etc _do not_ return the value assigned; they return the receiver." 181709 "Should generate something more like 181710 push expr 181711 push lit 181712 push temp (index of expr) 181713 send value: 181714 pop 181715 or use e.g. valueForStore:" 181716 self flag: #bogus. 181717 writeNode 181718 emitCode: stack 181719 args: 1 181720 encoder: encoder 181721 super: false! ! 181722 181723!LiteralVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/15/2008 10:09'! 181724emitCodeForStorePop: stack encoder: encoder 181725 writeNode ifNil: 181726 [stack pop: 1. 181727 ^encoder genStorePopLiteralVar: index]. 181728 self emitCodeForStore: stack encoder: encoder. 181729 encoder genPop. 181730 stack pop: 1.! ! 181731 181732!LiteralVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:11'! 181733emitCodeForValue: stack encoder: encoder 181734 stack push: 1. 181735 ^encoder genPushLiteralVar: index! ! 181736 181737!LiteralVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/15/2008 09:45'! 181738sizeCodeForLoad: encoder 181739 ^writeNode ifNil: [0] ifNotNil: [encoder sizePushLiteral: index]! ! 181740 181741!LiteralVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:06'! 181742sizeCodeForStore: encoder 181743 self reserve: encoder. 181744 (key isVariableBinding and: [key isSpecialWriteBinding]) ifFalse: 181745 [^encoder sizeStoreLiteralVar: index]. 181746 code < 0 ifTrue: 181747 [self flag: #dubious. 181748 self code: (self code: self index type: LdLitType)]. 181749 "THIS IS WRONG!!!! THE VALUE IS LOST FROM THE STACK!!!! 181750 The various value: methods on Association ReadOnlyVariableBinding 181751 etc _do not_ return the value assigned; they return the receiver." 181752 "Should generate something more like 181753 push expr 181754 push lit 181755 push temp (index of expr) 181756 send value: 181757 pop" 181758 self flag: #bogus. 181759 writeNode := encoder encodeSelector: #value:. 181760 ^(encoder sizePushLiteralVar: index) 181761 + (writeNode sizeCode: encoder args: 1 super: false)! ! 181762 181763!LiteralVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/15/2008 10:17'! 181764sizeCodeForStorePop: encoder 181765 self reserve: encoder. 181766 ^(key isVariableBinding and: [key isSpecialWriteBinding]) 181767 ifTrue: [(self sizeCodeForStorePop: encoder) + encoder sizePop] 181768 ifFalse: [encoder sizeStorePopLiteralVar: index]! ! 181769 181770!LiteralVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:03'! 181771sizeCodeForValue: encoder 181772 self reserve: encoder. 181773 ^encoder sizePushLiteralVar: index! ! 181774 181775 181776!LiteralVariableNode methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:50'! 181777accept: aVisitor 181778 aVisitor visitLiteralVariableNode: self! ! 181779CodeModelExtension subclass: #LocalSends 181780 instanceVariableNames: '' 181781 classVariableNames: '' 181782 poolDictionaries: '' 181783 category: 'Traits-LocalSends'! 181784!LocalSends commentStamp: '<historical>' prior: 0! 181785This class provide the model extension describing local sends for a given class. These are described in the comment for SendInfo, which is the class that actually computes this information.! 181786 181787 181788!LocalSends methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 18:48'! 181789newCacheFor: aClass 181790 "Creates an instance of SendCaches, assigns it to the instance variable sendCaches and fills it with all the self-sends class-sends and super-sends that occur in methods defined in this class (or by used traits)." 181791 181792 | localSendCache info | 181793 localSendCache := SendCaches new. 181794 aClass selectorsAndMethodsDo: 181795 [:sender :m | 181796 info := (SendInfo on: m) collectSends. 181797 info selfSentSelectors 181798 do: [:sentSelector | localSendCache addSelfSender: sender of: sentSelector]. 181799 info superSentSelectors 181800 do: [:sentSelector | localSendCache addSuperSender: sender of: sentSelector]. 181801 info classSentSelectors 181802 do: [:sentSelector | localSendCache addClassSender: sender of: sentSelector]]. 181803 ^localSendCache! ! 181804 181805"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 181806 181807LocalSends class 181808 instanceVariableNames: ''! 181809Object subclass: #Locale 181810 instanceVariableNames: 'id shortDate longDate time decimalSymbol digitGrouping currencySymbol currencyNotation measurement offsetLocalToUTC offsetVMToUTC dstActive' 181811 classVariableNames: 'Current CurrentPlatform KnownLocales LanguageSymbols LocaleChangeListeners PlatformEncodings' 181812 poolDictionaries: '' 181813 category: 'System-Localization'! 181814!Locale commentStamp: '<historical>' prior: 0! 181815Main comment stating the purpose of this class and relevant relationship to other classes. 181816 181817 181818 181819 http://www.w3.org/WAI/ER/IG/ert/iso639.htm 181820 http://www.oasis-open.org/cover/iso639a.html 181821 See also 181822 http://oss.software.ibm.com/cvs/icu/~checkout~/icuhtml/design/language_code_issues.html 181823 http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.10 181824 181825ISO 3166 181826http://mitglied.lycos.de/buran/knowhow/codes/locales/ 181827! 181828 181829 181830!Locale methodsFor: 'accessing' stamp: 'mir 8/31/2005 17:03'! 181831determineLocale 181832 self localeID: self determineLocaleID! ! 181833 181834!Locale methodsFor: 'accessing' stamp: 'mir 8/31/2005 16:32'! 181835determineLocaleID 181836 "Locale current determineLocaleID" 181837 | langCode isoLang countryCode isoCountry | 181838 langCode := self fetchISO2Language. 181839 isoLang := langCode 181840 ifNil: [^self localeID] 181841 ifNotNil: [langCode]. 181842 countryCode := self primCountry. 181843 isoCountry := countryCode 181844 ifNil: [^LocaleID isoLanguage: isoLang] 181845 ifNotNil: [countryCode]. 181846 ^LocaleID isoLanguage: isoLang isoCountry: isoCountry! ! 181847 181848!Locale methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:39'! 181849isoCountry 181850 ^self localeID isoCountry! ! 181851 181852!Locale methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:39'! 181853isoLanguage 181854 ^self localeID isoLanguage! ! 181855 181856!Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:41'! 181857isoLocale 181858 "<language>-<country>" 181859 ^self isoCountry 181860 ifNil: [self isoLanguage] 181861 ifNotNil: [self isoLanguage , '-' , self isoCountry]! ! 181862 181863!Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:52'! 181864languageEnvironment 181865 ^LanguageEnvironment localeID: self localeID! ! 181866 181867!Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:55'! 181868localeID 181869 ^id! ! 181870 181871!Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:55'! 181872localeID: anID 181873 id := anID! ! 181874 181875!Locale methodsFor: 'accessing' stamp: 'tak 8/4/2005 15:18'! 181876printOn: aStream 181877 super printOn: aStream. 181878 aStream nextPutAll: '(' , id printString , ')'! ! 181879 181880 181881!Locale methodsFor: 'system primitives' stamp: 'mir 8/31/2005 17:36'! 181882primCountry 181883 "Returns string with country tag according to ISO 639" 181884 <primitive: 'primitiveCountry' module: 'LocalePlugin'> 181885 ^nil! ! 181886 181887!Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:45'! 181888primCurrencyNotation 181889 "Returns boolean if symbol is pre- (true) or post-fix (false)" 181890 <primitive: 'primitiveCurrencyNotation' module: 'LocalePlugin'> 181891 ^true! ! 181892 181893!Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:47'! 181894primCurrencySymbol 181895 "Returns string with currency symbol" 181896 <primitive: 'primitiveCurrencySymbol' module:'LocalePlugin'> 181897 ^'$'! ! 181898 181899!Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:48'! 181900primDST 181901 "Returns boolean if DST (daylight saving time) is active or not" 181902 <primitive:'primitiveDaylightSavings' module: 'LocalePlugin'> 181903 ^false! ! 181904 181905!Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:42'! 181906primDecimalSymbol 181907 "Returns string with e.g. '.' or ','" 181908 <primitive:'primitiveDecimalSymbol' module: 'LocalePlugin'> 181909 ^'.'! ! 181910 181911!Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:42'! 181912primDigitGrouping 181913 "Returns string with e.g. '.' or ',' (thousands etc)" 181914 <primitive:'primitiveDigitGroupingSymbol' module: 'LocalePlugin'> 181915 ^','! ! 181916 181917!Locale methodsFor: 'system primitives' stamp: 'mir 8/17/2005 15:53'! 181918primLanguage 181919 "returns string with language tag according to ISO 639" 181920 <primitive:'primitiveLanguage' module: 'LocalePlugin'> 181921 ^nil! ! 181922 181923!Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:51'! 181924primLongDateFormat 181925 "Returns the long date format 181926 d day, m month, y year, 181927 double symbol is null padded, single not padded (m=6, mm=06) 181928 dddd weekday 181929 mmmm month name" 181930 <primitive:'primitiveLongDateFormat' module: 'LocalePlugin'> 181931! ! 181932 181933!Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:43'! 181934primMeasurement 181935 "Returns boolean denoting metric(true) or imperial(false)." 181936 <primitive:'primitiveMeasurementMetric' module: 'LocalePlugin'> 181937 ^true 181938! ! 181939 181940!Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:53'! 181941primShortDateFormat 181942 "Returns the short date format 181943 d day, m month, y year, 181944 double symbol is null padded, single not padded (m=6, mm=06) 181945 dddd weekday 181946 mmmm month name" 181947 <primitive:'primitiveShortDateFormat' module: 'LocalePlugin'> 181948! ! 181949 181950!Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:54'! 181951primTimeFormat 181952 "Returns string time format 181953 Format is made up of 181954 h hour (h 12, H 24), m minute, s seconds, x (am/pm String) 181955 double symbol is null padded, single not padded (h=6, hh=06)" 181956 <primitive:'primitiveTimeFormat' module: 'LocalePlugin'> 181957 181958! ! 181959 181960!Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:43'! 181961primTimezone 181962 "The offset from UTC in minutes, with positive offsets being towards the east. 181963 (San Francisco is in UTC -08*60 and Paris is in GMT +01*60 (daylight savings is not in effect)." 181964 <primitive:'primitiveTimezoneOffset' module: 'LocalePlugin'> 181965 ^0! ! 181966 181967!Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:44'! 181968primVMOffsetToUTC 181969 "Returns the offset in minutes between the VM and UTC. 181970 If the VM does not support UTC times, this is 0. 181971 Also gives us backward compatibility with old VMs as the primitive will fail and we then can return 0." 181972 <primitive:'primitiveVMOffsetToUTC' module: 'LocalePlugin'> 181973 ^0! ! 181974 181975 181976!Locale methodsFor: 'private' stamp: 'mir 8/31/2005 17:36'! 181977fetchISO2Language 181978 "Locale current fetchISO2Language" 181979 | lang isoLang | 181980 lang := self primLanguage. 181981 lang ifNil: [^nil]. 181982 lang := lang copyUpTo: 0 asCharacter. 181983 lang size == 2 181984 ifTrue: [^lang]. 181985 isoLang := ISOLanguageDefinition iso3LanguageDefinition: lang. 181986 ^isoLang 181987 ifNil: [nil] 181988 ifNotNil: [isoLang iso2]! ! 181989 181990"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 181991 181992Locale class 181993 instanceVariableNames: ''! 181994 181995!Locale class methodsFor: 'accessing' stamp: 'mir 8/31/2005 17:36'! 181996current 181997 "Current := nil" 181998 Current ifNil: [ 181999 Current := self determineCurrentLocale. 182000 "Transcript show: 'Current locale: ' , Current localeID asString; cr"]. 182001 ^Current! ! 182002 182003!Locale class methodsFor: 'accessing' stamp: 'yo 7/28/2004 20:32'! 182004currentPlatform 182005 "CurrentPlatform := nil" 182006 CurrentPlatform ifNil: [CurrentPlatform := self determineCurrentLocale]. 182007 ^CurrentPlatform! ! 182008 182009!Locale class methodsFor: 'accessing' stamp: 'yo 7/28/2004 20:39'! 182010currentPlatform: locale 182011 CurrentPlatform := locale. 182012 LanguageEnvironment startUp. 182013! ! 182014 182015!Locale class methodsFor: 'accessing' stamp: 'tak 10/18/2005 22:33'! 182016currentPlatform: locale during: aBlock 182017 "Alter current language platform during a block" 182018 | backupPlatform | 182019 backupPlatform := self currentPlatform. 182020 [self currentPlatform: locale. 182021 aBlock value] 182022 ensure: [self currentPlatform: backupPlatform]! ! 182023 182024!Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:20'! 182025isoLanguage: isoLanguage 182026 ^self isoLanguage: isoLanguage isoCountry: nil! ! 182027 182028!Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:31'! 182029isoLanguage: isoLanguage isoCountry: isoCountry 182030 ^self localeID: (LocaleID isoLanguage: isoLanguage isoCountry: isoCountry)! ! 182031 182032!Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:42'! 182033isoLocale: aString 182034 ! ! 182035 182036!Locale class methodsFor: 'accessing' stamp: 'mir 7/13/2004 00:24'! 182037languageSymbol: languageSymbol 182038 "Locale languageSymbol: #Deutsch" 182039 182040 ^self isoLanguage: (LanguageSymbols at: languageSymbol)! ! 182041 182042!Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:30'! 182043localeID: id 182044 ^self knownLocales at: id ifAbsentPut: [Locale new localeID: id]! ! 182045 182046!Locale class methodsFor: 'accessing' stamp: 'dgd 10/7/2004 20:50'! 182047stringForLanguageNameIs: localeID 182048 "Answer a string for a menu determining whether the given 182049 symbol is the project's natural language" 182050 ^ (self current localeID = localeID 182051 ifTrue: ['<yes>'] 182052 ifFalse: ['<no>']) 182053 , localeID displayName! ! 182054 182055!Locale class methodsFor: 'accessing' stamp: 'tak 8/5/2005 21:11'! 182056switchAndInstallFontToID: localeID 182057 "Locale switchAndInstallFontToID: (LocaleID isoLanguage: 'de')" 182058 | locale | 182059 locale := Locale localeID: localeID. 182060 locale languageEnvironment isFontAvailable 182061 ifFalse: [(self confirm: 'This language needs additional fonts. 182062Do you want to install the fonts?' translated) 182063 ifTrue: [locale languageEnvironment installFont] 182064 ifFalse: [^ self]]. 182065 self 182066 switchTo: locale! ! 182067 182068!Locale class methodsFor: 'accessing' stamp: 'tak 8/4/2005 16:30'! 182069switchTo: locale 182070 "Locale switchTo: Locale isoLanguage: 'de'" 182071 Current localeID = locale localeID 182072 ifFalse: [Current := locale. 182073 CurrentPlatform := locale. 182074 self localeChanged]! ! 182075 182076!Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 19:07'! 182077switchToID: localeID 182078 "Locale switchToID: (LocaleID isoLanguage: 'de') " 182079 182080 self switchTo: (Locale localeID: localeID)! ! 182081 182082 182083!Locale class methodsFor: 'initialization' stamp: 'mir 8/31/2005 17:00'! 182084initialize 182085 "Locale initialize" 182086 182087 Smalltalk addToStartUpList: Locale. 182088 Preferences addPreference: #useLocale 182089 categories: #('general') default: false 182090 balloonHelp: 'Use the system locale to set the system language etc at startup'.! ! 182091 182092!Locale class methodsFor: 'initialization' stamp: 'nk 8/29/2004 13:21'! 182093initializePlatformEncodings 182094 "Locale initializePlatformEncodings" 182095 182096 | platform | 182097 PlatformEncodings isNil ifTrue: [ PlatformEncodings := Dictionary new ]. 182098 182099 platform := PlatformEncodings at: 'default' ifAbsentPut: Dictionary new. 182100 platform 182101 at: 'default' put: 'iso8859-1'; 182102 at: 'Win32 CE' put: 'utf-8'; 182103 yourself. 182104 182105 platform := PlatformEncodings at: 'ja' ifAbsentPut: Dictionary new. 182106 platform 182107 at: 'default' put: 'shift-jis'; 182108 at: 'unix' put: 'euc-jp'; 182109 at: 'Win32 CE' put: 'utf-8'; 182110 yourself. 182111 182112 platform := PlatformEncodings at: 'ko' ifAbsentPut: Dictionary new. 182113 platform 182114 at: 'default' put: 'euc-kr'; 182115 at: 'Win32 CE' put: 'utf-8'; 182116 yourself. 182117 182118 platform := PlatformEncodings at: 'zh' ifAbsentPut: Dictionary new. 182119 platform 182120 at: 'default' put: 'gb2312'; 182121 at: 'unix' put: 'euc-cn'; 182122 at: 'Win32 CE' put: 'utf-8'; 182123 yourself. 182124! ! 182125 182126!Locale class methodsFor: 'initialization' stamp: 'nk 8/29/2004 13:20'! 182127platformEncodings 182128 PlatformEncodings isEmptyOrNil ifTrue: [ self initializePlatformEncodings ]. 182129 ^PlatformEncodings 182130! ! 182131 182132 182133!Locale class methodsFor: 'notification' stamp: 'mir 6/30/2004 16:15'! 182134addLocalChangedListener: anObjectOrClass 182135 self localeChangedListeners add: anObjectOrClass! ! 182136 182137!Locale class methodsFor: 'notification' stamp: 'adrian_lienhard 7/19/2009 22:25'! 182138localeChanged 182139 #(#ParagraphEditor ) 182140 do: [:key | Smalltalk 182141 at: key 182142 ifPresent: [:class | class initialize]]. 182143 StrikeFont localeChanged. 182144 Project localeChanged. 182145 ColorPickerMorph localeChanged. 182146 Preferences localeChanged! ! 182147 182148!Locale class methodsFor: 'notification' stamp: 'mir 6/30/2004 16:15'! 182149localeChangedListeners 182150 ^LocaleChangeListeners ifNil: [LocaleChangeListeners := OrderedCollection new]! ! 182151 182152 182153!Locale class methodsFor: 'platform specific' stamp: 'nk 7/30/2004 21:45'! 182154defaultEncodingName: languageSymbol 182155 | encodings platformName osVersion | 182156 platformName := SmalltalkImage current platformName. 182157 osVersion := SmalltalkImage current getSystemAttribute: 1002. 182158 encodings := self platformEncodings at: languageSymbol 182159 ifAbsent: [self platformEncodings at: #default]. 182160 encodings at: platformName ifPresent: [:encoding | ^encoding]. 182161 encodings at: platformName , ' ' , osVersion 182162 ifPresent: [:encoding | ^encoding]. 182163 ^encodings at: #default! ! 182164 182165 182166!Locale class methodsFor: 'system startup' stamp: 'mir 8/31/2005 17:03'! 182167startUp: resuming 182168 | newID | 182169 resuming ifFalse: [^self]. 182170 (Preferences valueOfFlag: #useLocale) 182171 ifTrue: [ 182172 newID := self current determineLocaleID. 182173 newID ~= LocaleID current 182174 ifTrue: [self switchToID: newID]]! ! 182175 182176 182177!Locale class methodsFor: 'private' stamp: 'mir 7/28/2005 00:24'! 182178determineCurrentLocale 182179 "For now just return the default locale. 182180 A smarter way would be to determine the current platforms default locale." 182181 "Locale determineCurrentLocale" 182182 182183 ^self new determineLocale! ! 182184 182185!Locale class methodsFor: 'private' stamp: 'mir 7/15/2004 19:44'! 182186initKnownLocales 182187 | locales | 182188 locales := Dictionary new. 182189 182190 "Init the locales for which we have translations" 182191 NaturalLanguageTranslator availableLanguageLocaleIDs do: [:id | 182192 locales at: id put: (Locale new localeID: id)]. 182193 ^locales! ! 182194 182195!Locale class methodsFor: 'private' stamp: 'mir 7/15/2004 16:44'! 182196knownLocales 182197 "KnownLocales := nil" 182198 ^KnownLocales ifNil: [KnownLocales := self initKnownLocales]! ! 182199 182200!Locale class methodsFor: 'private' stamp: 'adrian_lienhard 7/19/2009 22:25'! 182201migrateSystem 182202 "Locale migrateSystem" 182203 "Do all the necessary operations to switch to the new Locale environment." 182204 182205 LocaleChangeListeners := nil. 182206 self 182207 addLocalChangedListener: HandMorph; 182208 addLocalChangedListener: Clipboard; 182209 addLocalChangedListener: Project; 182210 yourself! ! 182211Object subclass: #LocaleID 182212 instanceVariableNames: 'isoLanguage isoCountry' 182213 classVariableNames: '' 182214 poolDictionaries: '' 182215 category: 'System-Localization'! 182216 182217!LocaleID methodsFor: 'accessing' stamp: 'mir 9/1/2005 14:17'! 182218displayCountry 182219 ^(ISOLanguageDefinition iso2Countries at: self isoCountry asUppercase ifAbsent: [ self isoCountry ]) ! ! 182220 182221!LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 18:18'! 182222displayLanguage 182223 | language | 182224 language := (ISOLanguageDefinition iso2LanguageDefinition: self isoLanguage) language. 182225 ^self isoCountry 182226 ifNil: [language] 182227 ifNotNil: [language , ' (' , self displayCountry , ')']! ! 182228 182229!LocaleID methodsFor: 'accessing' stamp: 'dgd 10/7/2004 21:16'! 182230displayName 182231 "Answer a proper name to represent the receiver in GUI. 182232 182233 The wording is provided by translations of the magic value 182234 '<language display name>'. 182235 182236 'English' -> 'English' 182237 'German' -> 'Deutsch' 182238 " 182239 | magicPhrase translatedMagicPhrase | 182240 magicPhrase := '<language display name>'. 182241 translatedMagicPhrase := magicPhrase translatedTo: self. 182242 ^ translatedMagicPhrase = magicPhrase 182243 ifTrue: [self displayLanguage] 182244 ifFalse: [translatedMagicPhrase]! ! 182245 182246!LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:43'! 182247isoCountry 182248 ^isoCountry! ! 182249 182250!LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:43'! 182251isoLanguage 182252 ^isoLanguage! ! 182253 182254!LocaleID methodsFor: 'accessing' stamp: 'mir 7/21/2004 19:17'! 182255isoString 182256 ^self asString! ! 182257 182258!LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:34'! 182259parent 182260 ^self class isoLanguage: self isoLanguage! ! 182261 182262!LocaleID methodsFor: 'accessing' stamp: 'dgd 8/24/2004 19:37'! 182263translator 182264 ^ NaturalLanguageTranslator localeID: self ! ! 182265 182266 182267!LocaleID methodsFor: 'comparing' stamp: 'mir 7/15/2004 14:23'! 182268= anotherObject 182269 self class == anotherObject class 182270 ifFalse: [^false]. 182271 ^self isoLanguage = anotherObject isoLanguage 182272 and: [self isoCountry = anotherObject isoCountry]! ! 182273 182274!LocaleID methodsFor: 'comparing' stamp: 'mir 7/15/2004 14:23'! 182275hash 182276 ^self isoLanguage hash bitXor: self isoCountry hash! ! 182277 182278 182279!LocaleID methodsFor: 'initialize' stamp: 'mir 7/15/2004 12:44'! 182280isoLanguage: langString isoCountry: countryStringOrNil 182281 isoLanguage := langString. 182282 isoCountry := countryStringOrNil! ! 182283 182284 182285!LocaleID methodsFor: 'printing' stamp: 'mir 7/15/2004 12:45'! 182286printOn: stream 182287 "<language>-<country>" 182288 stream nextPutAll: self isoLanguage. 182289 self isoCountry 182290 ifNotNil: [stream nextPut: $-; nextPutAll: self isoCountry]! ! 182291 182292!LocaleID methodsFor: 'printing' stamp: 'tak 11/15/2004 12:45'! 182293storeOn: aStream 182294 aStream nextPut: $(. 182295 aStream nextPutAll: self class name. 182296 aStream nextPutAll: ' isoString: '. 182297 aStream nextPutAll: '''' , self printString , ''''. 182298 aStream nextPut: $). 182299! ! 182300 182301 182302!LocaleID methodsFor: 'testing' stamp: 'mir 7/15/2004 14:34'! 182303hasParent 182304 ^self isoCountry notNil! ! 182305 182306"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 182307 182308LocaleID class 182309 instanceVariableNames: ''! 182310 182311!LocaleID class methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:09'! 182312current 182313 ^Locale current localeID! ! 182314 182315 182316!LocaleID class methodsFor: 'instance creation' stamp: 'mir 7/15/2004 14:35'! 182317isoLanguage: langString 182318 ^self isoLanguage: langString isoCountry: nil! ! 182319 182320!LocaleID class methodsFor: 'instance creation' stamp: 'mir 7/15/2004 12:46'! 182321isoLanguage: langString isoCountry: countryStringOrNil 182322 ^self new isoLanguage: langString isoCountry: countryStringOrNil! ! 182323 182324!LocaleID class methodsFor: 'instance creation' stamp: 'mir 7/21/2004 13:59'! 182325isoString: isoString 182326 "Parse the isoString (<language>-<country>) into its components and return the matching LocaleID" 182327 "LocaleID isoString: 'en' " 182328 "LocaleID isoString: 'en-us' " 182329 182330 | parts language country | 182331 parts := isoString findTokens: #($- ). 182332 language := parts first. 182333 parts size > 1 182334 ifTrue: [country := parts second]. 182335 ^self isoLanguage: language isoCountry: country! ! 182336TestCase subclass: #LocaleTest 182337 instanceVariableNames: '' 182338 classVariableNames: '' 182339 poolDictionaries: '' 182340 category: 'Tests-Localization'! 182341!LocaleTest commentStamp: 'tak 8/3/2005 18:24' prior: 0! 182342LocaleTest buildSuite run! 182343 182344 182345!LocaleTest methodsFor: 'testing' stamp: 'tak 8/4/2005 11:02'! 182346testEncodingName 182347 "self debug: #testEncodingName" 182348 | locale | 182349 locale := Locale isoLanguage: 'ja'. 182350 self assert: locale languageEnvironment fontEncodingName = #FontJapaneseEnvironment! ! 182351 182352!LocaleTest methodsFor: 'testing' stamp: 'tak 8/7/2005 12:25'! 182353testFontFullName 182354 "self debug: #testFontFullName" 182355 | env dir | 182356 env := (Locale isoLanguage: 'ja') languageEnvironment. 182357 dir := FileDirectory on: SecurityManager default untrustedUserDirectory. 182358 [dir recursiveDelete] 182359 on: Error 182360 do: [:e | e]. 182361 env fontFullName. 182362 self assert: dir exists! ! 182363 182364!LocaleTest methodsFor: 'testing' stamp: 'tak 8/4/2005 14:42'! 182365testIsFontAvailable 182366 "self debug: #testIsFontAvailable" 182367 (Locale isoLanguage: 'ja') languageEnvironment removeFonts. 182368 self assert: (Locale isoLanguage: 'en') languageEnvironment isFontAvailable. 182369 "Next test should fail after installing Japanese font" 182370 self assert: (Locale isoLanguage: 'ja') languageEnvironment isFontAvailable not. 182371 (Locale isoLanguage: 'ja') languageEnvironment installFont. 182372 self assert: (Locale isoLanguage: 'ja') languageEnvironment isFontAvailable! ! 182373Object subclass: #LocatedMethod 182374 instanceVariableNames: 'location selector' 182375 classVariableNames: '' 182376 poolDictionaries: '' 182377 category: 'Traits-Composition'! 182378!LocatedMethod commentStamp: '<historical>' prior: 0! 182379I identify a method in the system by its selector and location (class or trait) where it is defined.! 182380 182381 182382!LocatedMethod methodsFor: 'accessing' stamp: 'al 1/23/2004 10:18'! 182383location 182384 ^location! ! 182385 182386!LocatedMethod methodsFor: 'accessing' stamp: 'al 1/23/2004 10:07'! 182387location: aPureBehavior selector: aSymbol 182388 location := aPureBehavior. 182389 selector := aSymbol! ! 182390 182391!LocatedMethod methodsFor: 'accessing' stamp: 'al 1/23/2004 10:17'! 182392selector 182393 ^selector! ! 182394 182395 182396!LocatedMethod methodsFor: 'comparing' stamp: 'al 3/6/2004 18:53'! 182397argumentNames 182398 "Return an array with the argument names of the method's selector" 182399 182400 | keywords stream argumentNames argumentName delimiters | 182401 delimiters := {Character space. Character cr}. 182402 keywords := self selector keywords. 182403 stream := self source readStream. 182404 argumentNames := OrderedCollection new. 182405 keywords do: [ :each | 182406 stream match: each. 182407 [stream peekFor: Character space] whileTrue. 182408 argumentName := ReadWriteStream on: String new. 182409 [(delimiters includes: stream peek) or: [stream peek isNil]] 182410 whileFalse: [argumentName nextPut: stream next]. 182411 argumentName isEmpty ifFalse: [ 182412 argumentNames add: argumentName contents withBlanksTrimmed]]. 182413 ^(argumentNames copyFrom: 1 to: self method numArgs) asArray! ! 182414 182415!LocatedMethod methodsFor: 'comparing' stamp: 'NS 3/30/2004 16:12'! 182416hash 182417 ^ self method identityHash! ! 182418 182419!LocatedMethod methodsFor: 'comparing' stamp: 'G.C 10/23/2008 10:12'! 182420= aLocatedMethod 182421 ^ self method == aLocatedMethod method! ! 182422 182423 182424!LocatedMethod methodsFor: 'convenience' stamp: 'al 3/9/2004 23:30'! 182425category 182426 ^self location 182427 whichCategoryIncludesSelector: self selector! ! 182428 182429!LocatedMethod methodsFor: 'convenience' stamp: 'al 1/23/2004 10:17'! 182430method 182431 ^self location >> self selector! ! 182432 182433!LocatedMethod methodsFor: 'convenience' stamp: 'al 2/16/2004 17:08'! 182434source 182435 ^(self method 182436 getSourceFor: self selector 182437 in: self location) asString! ! 182438 182439 182440!LocatedMethod methodsFor: 'testing' stamp: 'al 2/25/2004 11:20'! 182441isBinarySelector 182442 ^self selector 182443 allSatisfy: [:each | each isSpecial]! ! 182444 182445"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 182446 182447LocatedMethod class 182448 instanceVariableNames: ''! 182449 182450!LocatedMethod class methodsFor: 'instance creation' stamp: 'al 1/23/2004 10:07'! 182451location: aPureBehavior selector: aSymbol 182452 ^self new 182453 location: aPureBehavior selector: aSymbol; 182454 yourself! ! 182455TraitsTestCase subclass: #LocatedMethodTest 182456 instanceVariableNames: '' 182457 classVariableNames: '' 182458 poolDictionaries: '' 182459 category: 'Tests-Traits'! 182460 182461!LocatedMethodTest methodsFor: 'running' stamp: 'dvf 8/26/2005 14:25'! 182462testArgumentNames 182463 182464 self assert: (LocatedMethod location: self t1 selector: #+) argumentNames = #(aNumber). 182465 self assert: (LocatedMethod location: self t1 selector: #!!) argumentNames = #(aNumber). 182466 self assert: (LocatedMethod location: self t1 selector: #&&) argumentNames = #(anObject). 182467 self assert: (LocatedMethod location: self t1 selector: #@%+) argumentNames = #(anObject). 182468 182469 self assert: (LocatedMethod location: self t1 selector: #mySelector) argumentNames = #(). 182470 self assert: (LocatedMethod location: self t1 selector: #mySelector:) argumentNames = #(something). 182471 self assert: (LocatedMethod location: self t1 selector: #mySelector:and:) argumentNames = #(something somethingElse). 182472 182473! ! 182474 182475!LocatedMethodTest methodsFor: 'running' stamp: 'dvf 8/26/2005 14:25'! 182476testBinarySelectors 182477 self assert: (LocatedMethod location: self t1 selector: #+) isBinarySelector. 182478 self assert: (LocatedMethod location: self t1 selector: #!!) isBinarySelector. 182479 self assert: (LocatedMethod location: self t1 selector: #&&) isBinarySelector. 182480 self assert: (LocatedMethod location: self t1 selector: #@%+) isBinarySelector. 182481 182482 self deny: (LocatedMethod location: self t1 selector: #mySelector) isBinarySelector. 182483 self deny: (LocatedMethod location: self t1 selector: #mySelector:) isBinarySelector. 182484 self deny: (LocatedMethod location: self t1 selector: #mySelector:and:) isBinarySelector. 182485 182486 ! ! 182487 182488!LocatedMethodTest methodsFor: 'running' stamp: 'al 1/23/2004 17:16'! 182489testEquality 182490 | locatedMethod1 locatedMethod2 | 182491 locatedMethod1 := LocatedMethod location: self class selector: #testEquality. 182492 locatedMethod2 := LocatedMethod location: self class selector: #testEquality. 182493 self assert: locatedMethod1 = locatedMethod2. 182494 self assert: locatedMethod1 hash = locatedMethod2 hash! ! 182495 182496 182497!LocatedMethodTest methodsFor: 'setup' stamp: 'dvf 8/26/2005 14:21'! 182498setUp 182499 super setUp. 182500 self t1 compile: '+ aNumber ^aNumber + 17'. 182501 self t1 compile: '!!aNumber 182502 | temp | 182503 ^aNumber + 17'. 182504 self t1 compile: '&& anObject'. 182505 self t1 compile: '@%+anObject'. 182506 self t1 compile: 'mySelector "a comment"'. 182507 self t1 compile: 'mySelector: something 182508 ^17'. 182509 self t1 compile: 'mySelector: something and:somethingElse ^true'! ! 182510AbstractFont subclass: #LogicalFont 182511 instanceVariableNames: 'realFont emphasis familyName fallbackFamilyNames pointSize stretchValue weightValue slantValue derivatives boldDerivative italicDerivative boldItalicDerivative' 182512 classVariableNames: '' 182513 poolDictionaries: '' 182514 category: 'FreeType-FontManager'! 182515 182516!LogicalFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 10:49'! 182517clearRealFont 182518 realFont := nil! ! 182519 182520!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/27/2007 11:18'! 182521fallbackFamilyNames 182522 ^fallbackFamilyNames! ! 182523 182524!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/27/2007 11:19'! 182525fallbackFamilyNames: aSequencableCollection 182526 fallbackFamilyNames := aSequencableCollection! ! 182527 182528!LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 16:25'! 182529familyName 182530 ^familyName! ! 182531 182532!LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 13:57'! 182533familyName: aString 182534 familyName := aString! ! 182535 182536!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/27/2007 11:38'! 182537familyNames 182538 "Answer an array containing the receiver's familyName 182539 followed by any fallbackFamilyNames" 182540 |answer| 182541 answer := {familyName}. 182542 fallbackFamilyNames ifNotNil:[ 182543 answer := answer, fallbackFamilyNames]. 182544 ^answer! ! 182545 182546!LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 17:39'! 182547familySizeFace 182548 "should have default in AbstractFont" 182549 ^{self familyName. self pointSize. self emphasis}! ! 182550 182551!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 16:32'! 182552forceBold 182553 weightValue := (self weightValue max: 700).! ! 182554 182555!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 16:34'! 182556forceItalicOrOblique 182557 self slantValue = 0 ifTrue:[slantValue := 1]! ! 182558 182559!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 17:04'! 182560forceNotBold 182561 "anything other than bold (700) is not changed. 182562 we only remove boldness that can be put back with 182563 a TextAttribute bold." 182564 182565 self weightValue = 700 182566 ifTrue:[weightValue := 400].! ! 182567 182568!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 21:47'! 182569forceNotItalic 182570 "leave oblique style in place" 182571 slantValue = 1 ifTrue:[slantValue := 0].! ! 182572 182573!LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 16:07'! 182574pointSize 182575 ^pointSize! ! 182576 182577!LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 13:58'! 182578pointSize: aNumber 182579 pointSize := aNumber! ! 182580 182581!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 19:49'! 182582realFont 182583 ^realFont ifNil:[realFont := self findRealFont]! ! 182584 182585!LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 15:57'! 182586setEmphasis: code 182587 182588 emphasis := code! ! 182589 182590!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 19:46'! 182591slantValue 182592 "Answer the value of slantValue" 182593 182594 ^ slantValue ifNil:[slantValue := 0]! ! 182595 182596!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/17/2007 00:27'! 182597slantValue: anObject 182598 "Set the value of slantValue" 182599 182600 slantValue := anObject! ! 182601 182602!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 19:46'! 182603stretchValue 182604 "Answer the value of stretchValue" 182605 182606 ^ stretchValue ifNil:[stretchValue := 5]! ! 182607 182608!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/17/2007 00:27'! 182609stretchValue: anObject 182610 "Set the value of stretchValue" 182611 182612 stretchValue := anObject! ! 182613 182614!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 19:46'! 182615weightValue 182616 "Answer the value of weightValue" 182617 182618 ^ weightValue ifNil:[weightValue := 400]! ! 182619 182620!LogicalFont methodsFor: 'accessing' stamp: 'tween 8/17/2007 00:27'! 182621weightValue: anObject 182622 "Set the value of weightValue" 182623 182624 weightValue := anObject! ! 182625 182626 182627!LogicalFont methodsFor: 'as yet unclassified' stamp: 'tween 3/16/2007 18:04'! 182628findRealFont 182629 "for now just get a strike" 182630 "^((TextStyle named: 'Accuny') fontOfPointSize: pointSize) 182631 emphasized: emphasis" 182632 ^LogicalFontManager current bestFontFor: self! ! 182633 182634!LogicalFont methodsFor: 'as yet unclassified' stamp: 'tween 3/16/2007 16:21'! 182635maxAscii 182636 "??? 182637 what to do if realFont happens to be a StrikeFontSet?" 182638 ^SmallInteger maxVal! ! 182639 182640 182641!LogicalFont methodsFor: 'derivatives' stamp: 'tween 3/16/2007 15:44'! 182642derivativeFont: newFont 182643 "add aFont as derivative, answer new basefont" 182644 (self isRegular and: [newFont isRegular not]) ifTrue: [ 182645 self derivativeFontsAt: newFont emphasis put: newFont. 182646 ^self]. 182647 "new font is base, copy everything over" 182648 self isRegular 182649 ifFalse: [newFont derivativeFontsAt: self emphasis put: self]. 182650 self derivativeFonts do: [:f | 182651 newFont derivativeFontsAt: f emphasis put: f]. 182652 derivatives := nil. 182653 ^newFont! ! 182654 182655!LogicalFont methodsFor: 'derivatives' stamp: 'tween 3/16/2007 17:43'! 182656derivativeFont: newFont mainFont: ignore 182657 self derivativeFont: newFont! ! 182658 182659!LogicalFont methodsFor: 'derivatives' stamp: 'tween 3/16/2007 15:46'! 182660derivativeFonts 182661 182662 derivatives ifNil: [^ #()]. 182663 ^derivatives copyWithout: nil! ! 182664 182665!LogicalFont methodsFor: 'derivatives' stamp: 'tween 3/16/2007 15:44'! 182666derivativeFontsAt: index put: aFont 182667 182668 derivatives ifNil:[derivatives := Array new: 32]. 182669 derivatives at: index put: aFont! ! 182670 182671 182672!LogicalFont methodsFor: 'emphasis' stamp: 'tween 9/29/2007 12:48'! 182673emphasis 182674 "Answer the squeak emphasis code for the receiver. 182675 1=bold, 2=italic, 3=bold-italic etc" 182676 | answer | 182677 answer := 0. 182678 self isBoldOrBolder ifTrue:[answer := answer + self class squeakWeightBold]. 182679 self isItalicOrOblique ifTrue:[answer := answer + self class squeakSlantItalic]. 182680 ^answer! ! 182681 182682!LogicalFont methodsFor: 'emphasis' stamp: 'tween 9/22/2007 12:41'! 182683emphasis: code 182684 182685 ^self emphasized: code! ! 182686 182687!LogicalFont methodsFor: 'emphasis' stamp: 'tween 3/16/2007 15:59'! 182688emphasisString 182689 ^AbstractFont emphasisStringFor: emphasis! ! 182690 182691!LogicalFont methodsFor: 'emphasis' stamp: 'tween 9/29/2007 12:45'! 182692emphasized: code 182693 | validCode newWeight newSlant answer validCodeMask | 182694 182695 "we only handle bold and italic here since underline/strikeout are drawn separately" 182696 validCodeMask := self class squeakWeightBold bitOr: self class squeakSlantItalic. 182697 validCode := code bitAnd: validCodeMask. 182698 validCode = 0 ifTrue:[^self]. 182699 (validCode anyMask: self class squeakWeightBold) 182700 ifTrue:[newWeight := self class weightBold max: weightValue] 182701 ifFalse:[newWeight := weightValue]. 182702 ((validCode anyMask: self class squeakSlantItalic) and:[self isItalicOrOblique not]) 182703 ifTrue:[newSlant := self class slantItalic] 182704 ifFalse:[newSlant := slantValue]. 182705 (weightValue = newWeight and:[slantValue = newSlant]) ifTrue:[^self]. 182706 (weightValue ~= newWeight and:[slantValue ~= newSlant]) 182707 ifTrue:[ 182708 boldItalicDerivative ifNotNil:[^boldItalicDerivative]] 182709 ifFalse:[ 182710 (weightValue ~= newWeight) 182711 ifTrue:[boldDerivative ifNotNil:[^boldDerivative]]. 182712 (slantValue ~= newSlant) 182713 ifTrue:[italicDerivative ifNotNil:[^italicDerivative]]]. 182714 answer := self class 182715 familyName: familyName 182716 fallbackFamilyNames: fallbackFamilyNames 182717 pointSize: pointSize 182718 stretchValue: stretchValue 182719 weightValue: newWeight 182720 slantValue: newSlant. 182721 (weightValue ~= newWeight and:[slantValue ~= newSlant]) 182722 ifTrue:[^boldItalicDerivative := answer]. 182723 (weightValue ~= newWeight) 182724 ifTrue:[^boldDerivative := answer]. 182725 (slantValue ~= newSlant) 182726 ifTrue:[^italicDerivative := answer]. 182727 ^answer 182728! ! 182729 182730 182731!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 13:37'! 182732ascent 182733 ^self realFont ascent! ! 182734 182735!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:02'! 182736baseKern 182737 ^self realFont baseKern! ! 182738 182739!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 4/5/2007 08:30'! 182740characterFormAt: aCharacter 182741 ^self realFont characterFormAt: aCharacter! ! 182742 182743!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 13:38'! 182744descent 182745 ^self realFont descent! ! 182746 182747!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:02'! 182748descentKern 182749 ^self realFont descentKern! ! 182750 182751!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:13'! 182752displayStrikeoutOn: aGrafPort from: aPoint to: aPoint3 182753 ^self realFont displayStrikeoutOn: aGrafPort from: aPoint to: aPoint3 ! ! 182754 182755!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 16:03'! 182756displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta 182757 ^self realFont displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta! ! 182758 182759!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:11'! 182760displayString: aWideString on: aGrafPort from: aSmallInteger to: aSmallInteger4 at: aPoint kern: aSmallInteger6 baselineY: aSmallInteger7 182761 ^self realFont displayString: aWideString on: aGrafPort from: aSmallInteger to: aSmallInteger4 at: aPoint kern: aSmallInteger6 baselineY: aSmallInteger7 ! ! 182762 182763!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:12'! 182764displayUnderlineOn: aGrafPort from: aPoint to: aPoint3 182765 ^self realFont displayUnderlineOn: aGrafPort from: aPoint to: aPoint3 ! ! 182766 182767!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 16:19'! 182768fontArray 182769 | real | 182770 real := self realFont. 182771 ((real isMemberOf: StrikeFontSet) or: [real isKindOf: TTCFontSet]) ifTrue: [ 182772 ^real fontArray 182773 ] ifFalse: [ 182774 ^{self} 182775 ].! ! 182776 182777!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/29/2007 13:43'! 182778hasDistinctGlyphsForAll: asciiString 182779 182780 ^self realFont hasDistinctGlyphsForAll: asciiString! ! 182781 182782!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/29/2007 13:29'! 182783hasGlyphsForAll: asciiString 182784 182785 ^self realFont hasGlyphsForAll: asciiString! ! 182786 182787!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 13:33'! 182788height 182789 ^self realFont height! ! 182790 182791!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:04'! 182792installOn: a foregroundColor: b backgroundColor: c 182793 ^self realFont installOn: a foregroundColor: b backgroundColor: c! ! 182794 182795!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 4/6/2007 12:58'! 182796isSubPixelPositioned 182797 "Answer true if the receiver is currently using subpixel positioned 182798 glyphs, false otherwise. This affects how padded space sizes are calculated 182799 when composing text. 182800 Currently, only FreeTypeFonts are subPixelPositioned, and only when not 182801 Hinted" 182802 182803 ^self realFont isSubPixelPositioned! ! 182804 182805!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/29/2007 14:04'! 182806isSymbolFont 182807 182808 ^self realFont isSymbolFont! ! 182809 182810!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 13:38'! 182811isTTCFont 182812 ^self realFont isTTCFont! ! 182813 182814!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/21/2007 09:16'! 182815kerningLeft: leftChar right: rightChar 182816 ^self realFont kerningLeft: leftChar right: rightChar! ! 182817 182818!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/31/2007 17:13'! 182819linearWidthOf: aCharacter 182820 ^self realFont linearWidthOf: aCharacter! ! 182821 182822!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 4/2/2007 22:12'! 182823widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray 182824 ^self realFont widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray! ! 182825 182826!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:03'! 182827widthOf: anObject 182828 ^self realFont widthOf: anObject! ! 182829 182830!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/28/2007 14:56'! 182831widthOfString: aString 182832 ^self realFont widthOfString: aString! ! 182833 182834!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/28/2007 14:52'! 182835widthOfString: aString from: startIndex to: stopIndex 182836 ^self realFont widthOfString: aString from: startIndex to: stopIndex! ! 182837 182838!LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:03'! 182839xTable 182840 ^self realFont xTable! ! 182841 182842 182843!LogicalFont methodsFor: 'initialize-release' stamp: 'tween 3/16/2007 17:42'! 182844initialize: aFont 182845 182846 familyName := aFont familyName. 182847 emphasis := aFont emphasis.! ! 182848 182849 182850!LogicalFont methodsFor: 'objects from disk' stamp: 'tween 8/27/2007 11:23'! 182851objectForDataStream: refStrm 182852 | dp | 182853 "I am about to be written on an object file. Write a reference to a known LogicalFont in the other system instead." 182854 182855 dp := DiskProxy global: #LogicalFont selector: #familyName:fallbackFamilyNames:pointSize:stretchValue:weightValue:slantValue: 182856 args: {self familyName. self fallbackFamilyNames. self pointSize. self stretchValue. self weightValue. self slantValue}. 182857 refStrm replace: self with: dp. 182858 ^ dp. 182859! ! 182860 182861 182862!LogicalFont methodsFor: 'printing' stamp: 'tween 8/18/2007 20:22'! 182863printOn: aStream 182864 super printOn: aStream. 182865 aStream cr; 182866 nextPutAll: ' familyName: ', familyName asString;cr; 182867 nextPutAll: ' emphasis: ', emphasis asString;cr; 182868 nextPutAll: ' pointSize: ', pointSize asString;cr; 182869 nextPutAll: ' realFont: ', realFont asString; 182870 nextPutAll: ' weight: ', weightValue asString; 182871 nextPutAll: ' stretch: ', stretchValue asString; 182872 nextPutAll: ' slant: ', slantValue asString.! ! 182873 182874 182875!LogicalFont methodsFor: 'testing' stamp: 'tween 9/29/2007 10:56'! 182876isBold 182877 ^self isBoldOrBolder! ! 182878 182879!LogicalFont methodsFor: 'testing' stamp: 'tween 9/29/2007 10:48'! 182880isBoldOrBolder 182881 ^(weightValue ifNil:[400]) >= 700! ! 182882 182883!LogicalFont methodsFor: 'testing' stamp: 'tween 9/29/2007 10:57'! 182884isItalic 182885 ^self isItalicOrOblique! ! 182886 182887!LogicalFont methodsFor: 'testing' stamp: 'tween 9/29/2007 10:47'! 182888isItalicOrOblique 182889 slantValue ifNil:[slantValue := 0]. 182890 ^slantValue = 1 or:[slantValue = 2]! ! 182891 182892!LogicalFont methodsFor: 'testing' stamp: 'tween 3/16/2007 15:48'! 182893isRegular 182894 ^emphasis = 0! ! 182895 182896"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 182897 182898LogicalFont class 182899 instanceVariableNames: 'all'! 182900 182901!LogicalFont class methodsFor: 'accessing' stamp: 'tween 8/11/2007 01:22'! 182902all 182903 ^all ifNil:[ 182904 all := WeakSet new 182905 addAll: self allInstances; 182906 yourself]! ! 182907 182908 182909!LogicalFont class methodsFor: 'class initialization' stamp: 'tween 3/17/2007 10:50'! 182910initialize 182911 " 182912 self initialize. 182913 " 182914 Smalltalk addToShutDownList: self. "should it be at a particular place in the list?"! ! 182915 182916 182917!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:59'! 182918slantBackslanted 182919 ^2! ! 182920 182921!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:58'! 182922slantBook 182923 ^0! ! 182924 182925!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 12:00'! 182926slantCursive 182927 ^1! ! 182928 182929!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:59'! 182930slantInclined 182931 ^2! ! 182932 182933!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 12:00'! 182934slantItalic 182935 ^1! ! 182936 182937!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 12:00'! 182938slantKursiv 182939 ^1! ! 182940 182941!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:58'! 182942slantNormal 182943 ^0! ! 182944 182945!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:59'! 182946slantOblique 182947 ^2! ! 182948 182949!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:58'! 182950slantRegular 182951 ^0! ! 182952 182953!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:58'! 182954slantRoman 182955 ^0! ! 182956 182957!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:59'! 182958slantSlanted 182959 ^2! ! 182960 182961!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:59'! 182962slantUpright 182963 ^0! ! 182964 182965!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 12:42'! 182966squeakSlantItalic 182967 ^2! ! 182968 182969!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 12:41'! 182970squeakStretchCondensed 182971 ^8! ! 182972 182973!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 12:42'! 182974squeakWeightBold 182975 ^1! ! 182976 182977!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! 182978stretchCompact 182979 ^4! ! 182980 182981!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:54'! 182982stretchCompressed 182983 ^2! ! 182984 182985!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:56'! 182986stretchCondensed 182987 ^3! ! 182988 182989!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:56'! 182990stretchExpanded 182991 ^7! ! 182992 182993!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:57'! 182994stretchExtended 182995 ^7! ! 182996 182997!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:53'! 182998stretchExtraCompressed 182999 ^1! ! 183000 183001!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:54'! 183002stretchExtraCondensed 183003 ^2! ! 183004 183005!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! 183006stretchExtraExpanded 183007 ^8! ! 183008 183009!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! 183010stretchExtraExtended 183011 ^8! ! 183012 183013!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:54'! 183014stretchNarrow 183015 ^4! ! 183016 183017!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:57'! 183018stretchRegular 183019 ^5! ! 183020 183021!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! 183022stretchSemiCondensed 183023 ^4! ! 183024 183025!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! 183026stretchSemiExpanded 183027 ^6! ! 183028 183029!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! 183030stretchSemiExtended 183031 ^6! ! 183032 183033!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:53'! 183034stretchUltraCompressed 183035 ^1! ! 183036 183037!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:53'! 183038stretchUltraCondensed 183039 ^1! ! 183040 183041!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:56'! 183042stretchUltraExpanded 183043 ^9! ! 183044 183045!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:56'! 183046stretchUltraExtended 183047 ^9! ! 183048 183049!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! 183050stretchWide 183051 ^6! ! 183052 183053!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:52'! 183054weightBlack 183055 ^900! ! 183056 183057!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:51'! 183058weightBold 183059 ^700! ! 183060 183061!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:52'! 183062weightDemi 183063 ^600! ! 183064 183065!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:50'! 183066weightDemiBold 183067 ^600! ! 183068 183069!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:51'! 183070weightExtraBlack 183071 ^950! ! 183072 183073!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:50'! 183074weightExtraBold 183075 ^800! ! 183076 183077!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:49'! 183078weightExtraLight 183079 ^200! ! 183080 183081!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:49'! 183082weightExtraThin 183083 ^100! ! 183084 183085!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:52'! 183086weightHeavy 183087 ^900! ! 183088 183089!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:52'! 183090weightLight 183091 ^300! ! 183092 183093!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:52'! 183094weightMedium 183095 ^500! ! 183096 183097!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:52'! 183098weightNord 183099 ^900! ! 183100 183101!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:57'! 183102weightRegular 183103 ^400! ! 183104 183105!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:50'! 183106weightSemiBold 183107 ^600! ! 183108 183109!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:51'! 183110weightThin 183111 ^100! ! 183112 183113!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:53'! 183114weightUltra 183115 ^800! ! 183116 183117!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:51'! 183118weightUltraBlack 183119 ^950! ! 183120 183121!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:50'! 183122weightUltraBold 183123 ^800! ! 183124 183125!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:50'! 183126weightUltraLight 183127 ^200! ! 183128 183129!LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:49'! 183130weightUltraThin 183131 ^100! ! 183132 183133 183134!LogicalFont class methodsFor: 'instance creation' stamp: 'tween 8/27/2007 11:28'! 183135familyName: familyName fallbackFamilyNames: fallbackFamilyNames pointSize: pointSize 183136 183137 ^self familyName: familyName fallbackFamilyNames: fallbackFamilyNames pointSize: pointSize stretchValue: 5 weightValue: 400 slantValue: 0! ! 183138 183139!LogicalFont class methodsFor: 'instance creation' stamp: 'tween 8/27/2007 11:24'! 183140familyName: familyName fallbackFamilyNames: fallbackFamilyNames pointSize: pointSize stretchValue: stretch weightValue: weight slantValue: slant 183141 183142 "^self all asArray" 183143 "^(self all collect:[:each | each]) asArray" 183144 ^self all 183145 detect:[:each | 183146 each familyName = familyName and:[ 183147 each fallbackFamilyNames = fallbackFamilyNames and:[ 183148 each pointSize = pointSize and:[ 183149 each weightValue = weight and:[ 183150 each stretchValue = stretch and:[ 183151 each slantValue = slant]]]]]] 183152 ifNone:[ 183153 self new 183154 familyName: familyName; 183155 fallbackFamilyNames: fallbackFamilyNames; 183156 pointSize: pointSize; 183157 weightValue:weight; 183158 stretchValue: stretch; 183159 slantValue: slant; 183160 yourself]! ! 183161 183162!LogicalFont class methodsFor: 'instance creation' stamp: 'tween 8/27/2007 11:26'! 183163familyName: familyName pointSize: pointSize 183164 183165 ^self familyName: familyName fallbackFamilyNames: nil pointSize: pointSize stretchValue: 5 weightValue: 400 slantValue: 0! ! 183166 183167!LogicalFont class methodsFor: 'instance creation' stamp: 'tween 8/27/2007 11:24'! 183168familyName: familyName pointSize: pointSize stretchValue: stretch weightValue: weight slantValue: slant 183169 183170 ^self familyName: familyName fallbackFamilyNames: nil pointSize: pointSize stretchValue: stretch weightValue: weight slantValue: slant! ! 183171 183172!LogicalFont class methodsFor: 'instance creation' stamp: 'tween 8/11/2007 01:23'! 183173new 183174 183175 ^self all add: super new! ! 183176 183177 183178!LogicalFont class methodsFor: 'shutdown' stamp: 'tween 4/3/2007 16:19'! 183179shutDown: quitting 183180 183181 self allSubInstances do: [:i | i clearRealFont].! ! 183182Object subclass: #LogicalFontManager 183183 instanceVariableNames: 'fontProviders' 183184 classVariableNames: '' 183185 poolDictionaries: '' 183186 category: 'FreeType-FontManager'! 183187 183188!LogicalFontManager methodsFor: 'accessing' stamp: 'tween 9/29/2007 09:14'! 183189addFontProvider: aFontProvider 183190 183191 fontProviders addLast: aFontProvider 183192 ! ! 183193 183194 183195!LogicalFontManager methodsFor: 'font families' stamp: 'tween 9/29/2007 09:14'! 183196allFamilies 183197 "answer an Array containing all the font families from the receiver's fontProviders, 183198 together with any TextStyle font families, sorted by family name" 183199 | answer textStyleFamilies textStyleFamilyName | 183200 answer := Set new. 183201 fontProviders do:[:each | answer addAll: each families]. 183202 textStyleFamilies := TextStyle knownTextStylesWithoutDefault collect:[:textStyleName | 183203 TextStyleAsFontFamily new 183204 textStyle: (TextStyle named: textStyleName); 183205 familyName: textStyleName; 183206 yourself]. 183207 "reject any textStyles whose defaultFont also appears as a fontFamily" 183208 textStyleFamilies := textStyleFamilies reject:[:textStyleFamily | 183209 textStyleFamilyName := textStyleFamily textStyle defaultFont familyName. 183210 (answer detect:[:fontFamily | fontFamily familyName = textStyleFamilyName] ifNone:[]) notNil]. 183211 answer addAll: textStyleFamilies. 183212 ^(answer asSortedCollection: [:a :b | a familyName <= b familyName]) asArray. 183213 183214 ! ! 183215 183216 183217!LogicalFontManager methodsFor: 'font lookup' stamp: 'tween 8/18/2007 10:42'! 183218bestFontFor: aLogicalFont 183219 "look up best font from the receivers fontProviders" 183220 183221 ^self bestFontFor: aLogicalFont whenFindingAlternativeIgnoreAll: Set new 183222! ! 183223 183224!LogicalFontManager methodsFor: 'font lookup' stamp: 'tween 9/29/2007 09:14'! 183225bestFontFor: aLogicalFont whenFindingAlternativeIgnoreAll: ignoreSet 183226 "look up best real font from the receivers fontProviders. 183227 If we can't find a font, then answer an alternative real font. 183228 183229 ignoreSet contains the LogicalFonts that we have already attempted to 183230 get an alternative real font from. We ignore those on each iteration so that we don't 183231 recurse forever" 183232 | answer textStyle font | 183233 183234 aLogicalFont familyNames do:[:familyName | 183235 fontProviders do:[:p | 183236 (answer := p fontFor: aLogicalFont familyName: familyName) 183237 ifNotNil:[^answer]]. 183238 textStyle := TextStyle named: familyName. 183239 textStyle ifNotNil:[ 183240 font := textStyle fontOfPointSize: aLogicalFont pointSize. 183241 font ifNotNil:[^font emphasized: aLogicalFont emphasis]]]. 183242 "not found, so use the default TextStyle" 183243 textStyle := TextStyle default. 183244 textStyle ifNotNil:[ 183245 font := textStyle fontOfPointSize: aLogicalFont pointSize. 183246 (font isKindOf: LogicalFont) ifFalse:[^font emphasized: aLogicalFont emphasis]. 183247 (ignoreSet includes: font) 183248 ifFalse:[ 183249 ignoreSet add: font. "remember that we have visited font so that we don't loop forever" 183250 "try again using the default TextStyle's logicalFont" 183251 ^self bestFontFor: font whenFindingAlternativeIgnoreAll: ignoreSet]]. 183252 "Neither the family, nor any of the fallback families, is available. 183253 Any non-LogicalFont will do as a fallback" 183254 (TextConstants select: [:each | each isKindOf: TextStyle]) 183255 do:[:ts | 183256 ((font := ts fontOfPointSize: aLogicalFont pointSize) isKindOf: LogicalFont) 183257 ifFalse:[^font emphasized: aLogicalFont emphasis]]. 183258 "There are no non-logical fonts in TextConstants - let it fail by answering nil" 183259 ^nil 183260 183261 183262! ! 183263 183264 183265!LogicalFontManager methodsFor: 'initialize-release' stamp: 'tween 3/14/2007 22:56'! 183266initialize 183267 super initialize. 183268 fontProviders := OrderedCollection new: 10 183269 ! ! 183270 183271"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 183272 183273LogicalFontManager class 183274 instanceVariableNames: 'current'! 183275 183276!LogicalFontManager class methodsFor: 'accessing' stamp: 'tween 3/17/2007 13:53'! 183277current 183278 " 183279 current := nil. 183280 self current 183281 " 183282 ^current ifNil:[current := self defaultCurrent]! ! 183283 183284 183285!LogicalFontManager class methodsFor: 'instance creation' stamp: 'tween 9/8/2007 14:45'! 183286defaultCurrent 183287 ^self new 183288 addFontProvider: FreeTypeFontProvider current; 183289 yourself! ! 183290ProtocolClientError subclass: #LoginFailedException 183291 instanceVariableNames: '' 183292 classVariableNames: '' 183293 poolDictionaries: '' 183294 category: 'Network-Protocols'! 183295!LoginFailedException commentStamp: 'mir 5/12/2003 17:57' prior: 0! 183296Exception for signaling login failures of protocol clients. 183297! 183298 183299 183300!LoginFailedException methodsFor: 'exceptiondescription' stamp: 'mir 2/15/2002 13:10'! 183301isResumable 183302 "Resumable so we can give the user another chance to login" 183303 183304 ^true! ! 183305MessageDialogWindow subclass: #LongMessageDialogWindow 183306 instanceVariableNames: 'entryText' 183307 classVariableNames: '' 183308 poolDictionaries: '' 183309 category: 'Polymorph-Widgets-Windows'! 183310!LongMessageDialogWindow commentStamp: 'gvc 9/23/2008 11:36' prior: 0! 183311Dialog window displaying a message with a single OK button. Escape/return will close. Icon is a themed information icon. 183312Handles long messages through use of a text editor with potential for scrolling.! 183313 183314 183315!LongMessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/15/2008 22:11'! 183316entryText 183317 "Answer the value of entryText" 183318 183319 ^ entryText! ! 183320 183321!LongMessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/15/2008 22:50'! 183322entryText: anObject 183323 "Set the value of entryText" 183324 183325 entryText := anObject. 183326 self changed: #entryText! ! 183327 183328 183329!LongMessageDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/15/2008 22:52'! 183330newContentMorph 183331 "Answer a new content morph." 183332 183333 self iconMorph: self newIconMorph. 183334 self textMorph: self newTextMorph. 183335 ^self newGroupboxFor: ( 183336 (self newRow: {self iconMorph. self textMorph}) 183337 cellPositioning: #top; 183338 vResizing: #spaceFill)! ! 183339 183340!LongMessageDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/15/2008 22:51'! 183341newTextMorph 183342 "Answer a new text editor morph." 183343 183344 |tm| 183345 tm := (self 183346 newTextEditorFor: self 183347 getText: #entryText 183348 setText: #entryText: 183349 getEnabled: nil) 183350 minWidth: Display width // 4; 183351 minHeight: Display height // 4; 183352 disable. 183353 ^tm! ! 183354 183355!LongMessageDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/15/2008 22:11'! 183356text: aStringOrText 183357 "Set the text." 183358 183359 |t| 183360 t := aStringOrText isString 183361 ifTrue: [aStringOrText asText addAttribute: (TextFontReference toFont: self textFont); yourself] 183362 ifFalse: [aStringOrText]. 183363 self entryText: t! ! 183364TestCase subclass: #LongTestCase 183365 instanceVariableNames: '' 183366 classVariableNames: 'DoNotRunLongTestCases' 183367 poolDictionaries: '' 183368 category: 'SUnit-Extensions'! 183369 183370"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 183371 183372LongTestCase class 183373 instanceVariableNames: ''! 183374 183375!LongTestCase class methodsFor: 'accessing' stamp: 'md 12/5/2004 21:36'! 183376allTestSelectors 183377 DoNotRunLongTestCases ifFalse: [ 183378 ^super testSelectors]. 183379 ^#().! ! 183380 183381!LongTestCase class methodsFor: 'accessing' stamp: 'sd 9/25/2004 12:57'! 183382doNotRunLongTestCases 183383 183384 DoNotRunLongTestCases := true.! ! 183385 183386!LongTestCase class methodsFor: 'accessing' stamp: 'md 11/14/2004 21:31'! 183387runLongTestCases 183388 183389 DoNotRunLongTestCases := false.! ! 183390 183391 183392!LongTestCase class methodsFor: 'initialization' stamp: 'sd 9/25/2004 12:57'! 183393initialize 183394 183395 self doNotRunLongTestCases! ! 183396 183397 183398!LongTestCase class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/3/2006 22:41'! 183399buildSuite 183400 | suite | 183401 suite := TestSuite new. 183402 DoNotRunLongTestCases ifFalse: [ 183403 self addToSuiteFromSelectors: suite]. 183404 ^suite! ! 183405 183406 183407!LongTestCase class methodsFor: 'testing' stamp: 'md 2/22/2006 14:21'! 183408isAbstract 183409 "Override to true if a TestCase subclass is Abstract and should not have 183410 TestCase instances built from it" 183411 183412 ^self name = #LongTestCase 183413 ! ! 183414TestCase subclass: #LongTestCaseTest 183415 instanceVariableNames: '' 183416 classVariableNames: '' 183417 poolDictionaries: '' 183418 category: 'SUnit-Extensions'! 183419 183420!LongTestCaseTest methodsFor: 'testing' stamp: 'sd 9/25/2004 14:12'! 183421testLongTestCaseDoNotRun 183422 "self debug: #testLongTestCaseDoNotRun" 183423 "self run: #testLongTestCaseDoNotRun" 183424 183425 LongTestCase doNotRunLongTestCases. 183426 LongTestCaseTestUnderTest markAsNotRun. 183427 self deny: LongTestCaseTestUnderTest hasRun. 183428 LongTestCaseTestUnderTest suite run. 183429 self deny: LongTestCaseTestUnderTest hasRun. 183430 183431 183432 ! ! 183433 183434!LongTestCaseTest methodsFor: 'testing' stamp: 'md 12/5/2004 21:28'! 183435testLongTestCaseRun 183436 "self debug: #testLongTestCaseRun" 183437 "self run: #testLongTestCaseRun" 183438 183439 LongTestCase runLongTestCases. 183440 LongTestCaseTestUnderTest markAsNotRun. 183441 self deny: LongTestCaseTestUnderTest hasRun. 183442 LongTestCaseTestUnderTest suite run. 183443 self assert: LongTestCaseTestUnderTest hasRun. 183444 LongTestCase doNotRunLongTestCases. 183445 183446 ! ! 183447LongTestCase subclass: #LongTestCaseTestUnderTest 183448 instanceVariableNames: '' 183449 classVariableNames: 'RunStatus' 183450 poolDictionaries: '' 183451 category: 'SUnit-Extensions'! 183452 183453!LongTestCaseTestUnderTest methodsFor: 'testing' stamp: 'md 11/14/2004 21:30'! 183454testWhenRunMarkTestedToTrue 183455 183456 183457 RunStatus := true.! ! 183458 183459"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 183460 183461LongTestCaseTestUnderTest class 183462 instanceVariableNames: ''! 183463 183464!LongTestCaseTestUnderTest class methodsFor: 'accessing' stamp: 'sd 9/25/2004 14:02'! 183465hasRun 183466 183467 ^ RunStatus! ! 183468 183469!LongTestCaseTestUnderTest class methodsFor: 'accessing' stamp: 'md 11/14/2004 21:37'! 183470markAsNotRun 183471 183472 ^ RunStatus := false! ! 183473Magnitude subclass: #LookupKey 183474 instanceVariableNames: 'key' 183475 classVariableNames: '' 183476 poolDictionaries: '' 183477 category: 'Collections-Support'! 183478!LookupKey commentStamp: '<historical>' prior: 0! 183479I represent a key for looking up entries in a data structure. Subclasses of me, such as Association, typically represent dictionary entries.! 183480 183481 183482!LookupKey methodsFor: 'accessing' stamp: 'ajh 9/12/2002 12:04'! 183483canAssign 183484 183485 ^ true! ! 183486 183487!LookupKey methodsFor: 'accessing'! 183488key 183489 "Answer the lookup key of the receiver." 183490 183491 ^key! ! 183492 183493!LookupKey methodsFor: 'accessing'! 183494key: anObject 183495 "Store the argument, anObject, as the lookup key of the receiver." 183496 183497 key := anObject! ! 183498 183499!LookupKey methodsFor: 'accessing' stamp: 'ajh 3/24/2003 21:14'! 183500name 183501 183502 ^ self key isString 183503 ifTrue: [self key] 183504 ifFalse: [self key printString]! ! 183505 183506 183507!LookupKey methodsFor: 'comparing'! 183508< aLookupKey 183509 "Refer to the comment in Magnitude|<." 183510 183511 ^key < aLookupKey key! ! 183512 183513!LookupKey methodsFor: 'comparing'! 183514= aLookupKey 183515 183516 self species = aLookupKey species 183517 ifTrue: [^key = aLookupKey key] 183518 ifFalse: [^false]! ! 183519 183520!LookupKey methodsFor: 'comparing'! 183521hash 183522 "Hash is reimplemented because = is implemented." 183523 183524 ^key hash! ! 183525 183526 183527!LookupKey methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 02:35'! 183528writeOnFilterStream: aStream 183529 183530 aStream write:key.! ! 183531 183532 183533!LookupKey methodsFor: 'printing'! 183534printOn: aStream 183535 183536 key printOn: aStream! ! 183537 183538 183539!LookupKey methodsFor: 'testing' stamp: 'ar 8/14/2003 01:52'! 183540isSpecialReadBinding 183541 "Return true if this variable binding is read protected, e.g., should not be accessed primitively but rather by sending #value messages" 183542 ^false! ! 183543 183544!LookupKey methodsFor: 'testing' stamp: 'ar 8/14/2001 22:39'! 183545isVariableBinding 183546 "Return true if I represent a literal variable binding" 183547 ^true! ! 183548 183549"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 183550 183551LookupKey class 183552 instanceVariableNames: ''! 183553 183554!LookupKey class methodsFor: 'instance creation' stamp: 'md 6/29/2005 16:34'! 183555key: aKey 183556 "Answer an instance of me with the argument as the lookup up." 183557 183558 ^self basicNew key: aKey! ! 183559MCPatchOperation subclass: #MCAddition 183560 instanceVariableNames: 'definition' 183561 classVariableNames: '' 183562 poolDictionaries: '' 183563 category: 'Monticello-Patching'! 183564 183565!MCAddition methodsFor: 'accessing' stamp: 'ab 5/24/2003 16:11'! 183566applyTo: anObject 183567 anObject addDefinition: definition! ! 183568 183569!MCAddition methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:09'! 183570baseDefinition 183571 ^ nil! ! 183572 183573!MCAddition methodsFor: 'accessing' stamp: 'cwp 11/27/2002 09:32'! 183574definition 183575 ^ definition! ! 183576 183577!MCAddition methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:45'! 183578fromSource 183579 ^ ''! ! 183580 183581!MCAddition methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:39'! 183582sourceString 183583 ^(self toSource asText) 183584 addAttribute: TextColor red; 183585 yourself! ! 183586 183587!MCAddition methodsFor: 'accessing' stamp: 'ab 5/13/2003 12:18'! 183588summary 183589 ^ definition summary! ! 183590 183591!MCAddition methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:17'! 183592targetClass 183593 ^definition actualClass ! ! 183594 183595!MCAddition methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:09'! 183596targetDefinition 183597 ^ definition! ! 183598 183599!MCAddition methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:45'! 183600toSource 183601 ^ definition source! ! 183602 183603 183604!MCAddition methodsFor: 'as yet unclassified' stamp: 'ab 8/22/2003 02:26'! 183605inverse 183606 ^ MCRemoval of: definition! ! 183607 183608!MCAddition methodsFor: 'as yet unclassified' stamp: 'nk 2/25/2005 17:28'! 183609isClassPatch 183610 ^definition isClassDefinition! ! 183611 183612 183613!MCAddition methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! 183614intializeWithDefinition: aDefinition 183615 definition := aDefinition! ! 183616 183617 183618!MCAddition methodsFor: 'testing' stamp: 'cwp 11/28/2002 07:22'! 183619isAddition 183620 ^ true! ! 183621 183622"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 183623 183624MCAddition class 183625 instanceVariableNames: ''! 183626 183627!MCAddition class methodsFor: 'as yet unclassified' stamp: 'cwp 11/27/2002 10:03'! 183628of: aDefinition 183629 ^ self new intializeWithDefinition: aDefinition! ! 183630Object subclass: #MCAncestry 183631 instanceVariableNames: 'ancestors stepChildren' 183632 classVariableNames: '' 183633 poolDictionaries: '' 183634 category: 'Monticello-Versioning'! 183635!MCAncestry commentStamp: '<historical>' prior: 0! 183636Abstract superclass of records of ancestry.! 183637 183638 183639!MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:57'! 183640allAncestorsDo: aBlock 183641 self ancestors do: 183642 [:ea | 183643 aBlock value: ea. 183644 ea allAncestorsDo: aBlock]! ! 183645 183646!MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:57'! 183647allAncestorsOnPathTo: aVersionInfo 183648 ^ MCFilteredVersionSorter new 183649 target: aVersionInfo; 183650 addAllVersionInfos: self ancestors; 183651 sortedVersionInfos! ! 183652 183653!MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:57'! 183654ancestorString 183655 ^ String streamContents: 183656 [:s | self ancestors do: [:ea | s nextPutAll: ea name] separatedBy: [s nextPutAll: ', ']]! ! 183657 183658!MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:57'! 183659ancestors 183660 ^ ancestors ifNil: [#()]! ! 183661 183662!MCAncestry methodsFor: 'ancestry' stamp: 'bf 12/22/2004 21:55'! 183663ancestorsDoWhileTrue: aBlock 183664 self ancestors do: 183665 [:ea | 183666 (aBlock value: ea) ifTrue: 183667 [ea ancestorsDoWhileTrue: aBlock]]! ! 183668 183669!MCAncestry methodsFor: 'ancestry' stamp: 'avi 9/17/2005 16:03'! 183670breadthFirstAncestors 183671 ^ Array streamContents: [:s | self breadthFirstAncestorsDo: [:ea | s nextPut: ea]]! ! 183672 183673!MCAncestry methodsFor: 'ancestry' stamp: 'stephaneducasse 2/4/2006 20:47'! 183674breadthFirstAncestorsDo: aBlock 183675 | seen todo next | 183676 seen := Set with: self. 183677 todo := OrderedCollection with: self. 183678 [todo isEmpty] whileFalse: 183679 [next := todo removeFirst. 183680 next ancestors do: 183681 [:ea | 183682 (seen includes: ea) ifFalse: 183683 [aBlock value: ea. 183684 seen add: ea. 183685 todo add: ea]]]! ! 183686 183687!MCAncestry methodsFor: 'ancestry' stamp: 'stephaneducasse 2/4/2006 20:47'! 183688commonAncestorsWith: aVersionInfo 183689 183690 | sharedAncestors mergedOrder sorter | 183691 sorter := MCVersionSorter new 183692 addVersionInfo: self; 183693 addVersionInfo: aVersionInfo. 183694 mergedOrder := sorter sortedVersionInfos. 183695 sharedAncestors := (sorter allAncestorsOf: self) intersection: (sorter allAncestorsOf: aVersionInfo). 183696 ^ mergedOrder select: [:ea | sharedAncestors includes: ea]! ! 183697 183698!MCAncestry methodsFor: 'ancestry' stamp: 'stephaneducasse 2/4/2006 20:47'! 183699commonAncestorWith: aNode 183700 | commonAncestors | 183701 commonAncestors := self commonAncestorsWith: aNode. 183702 ^ commonAncestors at: 1 ifAbsent: [nil]! ! 183703 183704!MCAncestry methodsFor: 'ancestry' stamp: 'jrp 7/12/2004 08:16'! 183705hasAncestor: aVersionInfo 183706 ^ self 183707 hasAncestor: aVersionInfo 183708 alreadySeen: OrderedCollection new! ! 183709 183710!MCAncestry methodsFor: 'ancestry' stamp: 'jrp 7/12/2004 08:16'! 183711hasAncestor: aVersionInfo alreadySeen: aList 183712 (aList includes: self) ifTrue: [^ false]. 183713 aList add: self. 183714 183715 ^ self = aVersionInfo or: [self ancestors anySatisfy: [:ea | ea hasAncestor: aVersionInfo alreadySeen: aList]] 183716! ! 183717 183718!MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:58'! 183719isRelatedTo: aVersionInfo 183720 ^ aVersionInfo timeStamp < self timeStamp 183721 ifTrue: [self hasAncestor: aVersionInfo] 183722 ifFalse: [aVersionInfo hasAncestor: self]! ! 183723 183724!MCAncestry methodsFor: 'ancestry' stamp: 'avi 9/11/2004 15:08'! 183725stepChildren 183726 ^ stepChildren ifNil: [#()]! ! 183727 183728!MCAncestry methodsFor: 'ancestry' stamp: 'avi 9/14/2004 15:21'! 183729stepChildrenString 183730 ^ String streamContents: 183731 [:s | self stepChildren do: [:ea | s nextPutAll: ea name] separatedBy: [s nextPutAll: ', ']]! ! 183732 183733!MCAncestry methodsFor: 'ancestry' stamp: 'stephaneducasse 2/4/2006 20:47'! 183734topologicalAncestors 183735 | frontier f | 183736 ^ Array streamContents: 183737 [:s | 183738 frontier := MCFrontier frontierOn: self. 183739 [f := frontier frontier. 183740 s nextPutAll: f. 183741 frontier removeAll: f. 183742 f isEmpty] whileFalse] ! ! 183743 183744!MCAncestry methodsFor: 'ancestry' stamp: 'avi 9/17/2005 16:03'! 183745withBreadthFirstAncestors 183746 ^ (Array with: self), self breadthFirstAncestors! ! 183747 183748 183749!MCAncestry methodsFor: 'initializing' stamp: 'alain.plantec 5/28/2009 10:02'! 183750initialize 183751 super initialize. 183752 ancestors := #(). 183753 stepChildren := #()! ! 183754 183755"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 183756 183757MCAncestry class 183758 instanceVariableNames: ''! 183759MCTestCase subclass: #MCAncestryTest 183760 instanceVariableNames: '' 183761 classVariableNames: '' 183762 poolDictionaries: '' 183763 category: 'Tests-Monticello'! 183764 183765!MCAncestryTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 183766assertCommonAncestorOf: leftName and: rightName in: options in: tree 183767 | left right ancestor | 183768 left := self versionForName: leftName in: tree. 183769 right := self versionForName: rightName in: tree. 183770 183771 ancestor := left commonAncestorWith: right. 183772 183773 self assert: (options includes: ancestor name)! ! 183774 183775!MCAncestryTest methodsFor: 'asserting' stamp: 'avi 9/17/2005 21:09'! 183776assertCommonAncestorOf: leftName and: rightName is: ancestorName in: tree 183777 self assertCommonAncestorOf: leftName and: rightName in: (Array with: ancestorName) in: tree! ! 183778 183779!MCAncestryTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 183780assertNamesOf: versionInfoCollection are: nameArray 183781 | names | 183782 names := versionInfoCollection collect: [:ea | ea name]. 183783 183784 self assert: names asArray = nameArray! ! 183785 183786!MCAncestryTest methodsFor: 'asserting' stamp: 'jf 8/16/2003 23:42'! 183787assertPathTo: aSymbol is: anArray 183788 self 183789 assertNamesOf: (self tree allAncestorsOnPathTo: (self treeFrom: {aSymbol})) 183790 are: anArray! ! 183791 183792 183793!MCAncestryTest methodsFor: 'building' stamp: 'jf 8/16/2003 21:21'! 183794tree 183795 ^ self treeFrom: 183796 #(c1 183797 ((e2 183798 ((e1 183799 ((a1 183800 (('00'))))))) 183801 (a2 183802 ((a1 183803 (('00'))))) 183804 (b3 183805 ((b2 183806 ((b1 183807 ((b0 183808 (('00'))))))) 183809 (a1 183810 (('00'))))) 183811 (d1)))! ! 183812 183813!MCAncestryTest methodsFor: 'building' stamp: 'jf 8/16/2003 22:55'! 183814twoPersonTree 183815 ^ self treeFrom: 183816 #(c1 183817 ((a4 183818 ((a1) 183819 (b3 183820 ((b2 183821 ((a1))))))) 183822 (b5 183823 ((b2 183824 ((a1)))))))! ! 183825 183826!MCAncestryTest methodsFor: 'building' stamp: 'marcus.denker 11/10/2008 10:04'! 183827versionForName: name in: tree 183828 (tree name = name) ifTrue: [^ tree]. 183829 183830 tree ancestors do: [:ea | (self versionForName: name in: ea) ifNotNil: [:v | ^ v]]. 183831 183832 ^ nil! ! 183833 183834 183835!MCAncestryTest methodsFor: 'tests' stamp: 'avi 9/17/2005 21:08'! 183836testCommonAncestors 183837 self assertCommonAncestorOf: #a2 and: #e2 is: #a1 in: self tree. 183838 self assertCommonAncestorOf: #e2 and: #b3 is: #a1 in: self tree. 183839 self assertCommonAncestorOf: #b2 and: #e2 is: #'00' in: self tree. 183840 183841 self assertCommonAncestorOf: #a4 and: #b5 in: #(b2 a1) in: self twoPersonTree. 183842 self assertCommonAncestorOf: #b5 and: #b3 is: #b2 in: self twoPersonTree. 183843 self assertCommonAncestorOf: #b2 and: #a4 is: #b2 in: self twoPersonTree. 183844 self assertCommonAncestorOf: #b2 and: #b2 is: #b2 in: self twoPersonTree. 183845 self assertCommonAncestorOf: #b2 and: #a1 is: #a1 in: self twoPersonTree. 183846 self assertCommonAncestorOf: #a1 and: #b2 is: #a1 in: self twoPersonTree.! ! 183847 183848!MCAncestryTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 183849testDescendants 183850 | c1 a1 b3 q1 q2 c2 | 183851 c1 := self tree. 183852 a1 := self treeFrom: #(a1 (('00'))). 183853 b3 := self treeFrom: #(b3 183854 ((b2 183855 ((b1 183856 ((b0 183857 (('00'))))))) 183858 (a1 183859 (('00'))))). 183860 q1 := MCWorkingAncestry new addAncestor: a1. 183861 q2 := MCWorkingAncestry new addAncestor: q1. 183862 self assert: (q2 commonAncestorWith: b3) = a1. 183863 self assert: (b3 commonAncestorWith: q2) = a1. 183864 self assert: (q2 commonAncestorWith: c1) = a1. 183865 self assert: (c1 commonAncestorWith: q2) = a1. 183866 q1 addStepChild: c1. 183867 self assert: (q2 commonAncestorWith: c1) = q1. 183868 self assert: (c1 commonAncestorWith: q2) = q1. 183869 c2 := MCWorkingAncestry new addAncestor: c1. 183870 self assert: (q2 commonAncestorWith: c2) = q1. 183871 self assert: (c2 commonAncestorWith: q2) = q1. 183872! ! 183873 183874!MCAncestryTest methodsFor: 'tests' stamp: 'jf 8/16/2003 20:45'! 183875testLinearPath 183876 self assertPathTo: #b1 is: #(b3 b2)! ! 183877 183878!MCAncestryTest methodsFor: 'tests' stamp: 'jf 8/16/2003 20:42'! 183879testPathToMissingAncestor 183880 self assert: (self tree allAncestorsOnPathTo: MCVersionInfo new) isEmpty! ! 183881MCDirectoryRepository subclass: #MCCacheRepository 183882 instanceVariableNames: 'packageCaches seenFiles' 183883 classVariableNames: '' 183884 poolDictionaries: '' 183885 category: 'Monticello-Repositories'! 183886 183887!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'bf 3/23/2005 00:52'! 183888basicStoreVersion: aVersion 183889 (aVersion isCacheable and: [self allFileNames includes: aVersion fileName]) 183890 ifFalse: [super basicStoreVersion: aVersion] 183891! ! 183892 183893!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 183894cacheForPackage: aPackage 183895 packageCaches ifNil: [packageCaches := Dictionary new]. 183896 ^ packageCaches at: aPackage ifAbsentPut: [MCPackageCache new]! ! 183897 183898!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 18:15'! 183899newFileNames 183900 ^ self allFileNames difference: self seenFileNames! ! 183901 183902!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 15:13'! 183903packageForFileNamed: aString 183904 ^ self packageCache at: aString ifAbsentPut: [self versionReaderForFileNamed: aString do: [:r | r package]]! ! 183905 183906!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 18:29'! 183907rescan 183908 self newFileNames do: 183909 [:ea | 183910 self versionReaderForFileNamed: ea do: 183911 [:reader | 183912 (self cacheForPackage: reader package) 183913 recordVersionInfo: reader info 183914 forFileNamed: ea. 183915 self seenFileNames add: ea]] 183916 displayingProgress: 'Scanning cache...'! ! 183917 183918!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 183919seenFileNames 183920 ^ seenFiles ifNil: [seenFiles := OrderedCollection new]! ! 183921 183922!MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 15:05'! 183923versionInfoForFileNamed: aString 183924 ^ self infoCache at: aString ifAbsentPut: [self versionReaderForFileNamed: aString do: [:r | r info]]! ! 183925 183926"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 183927 183928MCCacheRepository class 183929 instanceVariableNames: 'default'! 183930 183931!MCCacheRepository class methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:46'! 183932cacheDirectory 183933 ^ (FileDirectory default directoryNamed: 'package-cache') 183934 assureExistence; 183935 yourself! ! 183936 183937!MCCacheRepository class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 183938checkCacheDirectory 183939 default notNil and: [default directory exists ifFalse: [default := nil]]! ! 183940 183941!MCCacheRepository class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 183942default 183943 self checkCacheDirectory. 183944 ^ default ifNil: [default := self new directory: self cacheDirectory]! ! 183945 183946!MCCacheRepository class methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:56'! 183947description 183948 ^ nil! ! 183949 183950!MCCacheRepository class methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 16:21'! 183951initialize 183952 self checkCacheDirectory! ! 183953MCTestCase subclass: #MCChangeNotificationTest 183954 instanceVariableNames: 'workingCopy' 183955 classVariableNames: '' 183956 poolDictionaries: '' 183957 category: 'Tests-Monticello'! 183958 183959!MCChangeNotificationTest methodsFor: 'events' stamp: 'cwp 11/6/2004 22:32'! 183960modifiedEventFor: aSelector ofClass: aClass 183961 | method | 183962 method := aClass compiledMethodAt: aSelector. 183963 ^ ModifiedEvent 183964 methodChangedFrom: method 183965 to: method 183966 selector: aSelector 183967 inClass: aClass. 183968! ! 183969 183970 183971!MCChangeNotificationTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! 183972setUp 183973 workingCopy := MCWorkingCopy forPackage: self mockPackage. 183974 ! ! 183975 183976!MCChangeNotificationTest methodsFor: 'running' stamp: 'bf 5/20/2005 17:02'! 183977tearDown 183978 workingCopy unregister! ! 183979 183980 183981!MCChangeNotificationTest methodsFor: 'tests' stamp: 'bf 5/20/2005 19:54'! 183982testCoreMethodModified 183983 | event | 183984 workingCopy modified: false. 183985 event := self modifiedEventFor: #one ofClass: self mockClassA. 183986 MCWorkingCopy methodModified: event. 183987 self assert: workingCopy modified! ! 183988 183989!MCChangeNotificationTest methodsFor: 'tests' stamp: 'bf 5/20/2005 17:05'! 183990testExtMethodModified 183991 | event mref | 183992 workingCopy modified: false. 183993 mref := workingCopy packageInfo extensionMethods first. 183994 event := self modifiedEventFor: mref methodSymbol ofClass: mref actualClass. 183995 MCWorkingCopy methodModified: event. 183996 self assert: workingCopy modified! ! 183997 183998!MCChangeNotificationTest methodsFor: 'tests' stamp: 'bf 5/20/2005 17:00'! 183999testForeignMethodModified 184000 | event | 184001 workingCopy modified: false. 184002 event := self modifiedEventFor: #foreignMethod ofClass: self class. 184003 MCWorkingCopy methodModified: event. 184004 self deny: workingCopy modified! ! 184005 184006 184007!MCChangeNotificationTest methodsFor: 'private' stamp: 'bf 5/20/2005 16:19'! 184008foreignMethod 184009 "see testForeignMethodModified"! ! 184010Notification subclass: #MCChangeSelectionRequest 184011 instanceVariableNames: 'patch label' 184012 classVariableNames: '' 184013 poolDictionaries: '' 184014 category: 'Monticello-Versioning'! 184015 184016!MCChangeSelectionRequest methodsFor: '*MonticelloGUI' stamp: 'avi 9/14/2004 15:01'! 184017defaultAction 184018 ^ (MCChangeSelector new patch: patch; label: label) showModally! ! 184019 184020 184021!MCChangeSelectionRequest methodsFor: 'as yet unclassified' stamp: 'avi 9/14/2004 15:02'! 184022label 184023 ^ label! ! 184024 184025!MCChangeSelectionRequest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 184026label: aString 184027 label := aString! ! 184028 184029!MCChangeSelectionRequest methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 15:12'! 184030patch 184031 ^ patch! ! 184032 184033!MCChangeSelectionRequest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 184034patch: aPatch 184035 patch := aPatch! ! 184036 184037"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 184038 184039MCChangeSelectionRequest class 184040 instanceVariableNames: ''! 184041MCPatchBrowser subclass: #MCChangeSelector 184042 instanceVariableNames: 'kept' 184043 classVariableNames: '' 184044 poolDictionaries: '' 184045 category: 'MonticelloGUI'! 184046 184047!MCChangeSelector methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/17/2009 13:51'! 184048widgetSpecs 184049 Preferences annotationPanes ifFalse: [ ^#( 184050 ((buttonRow) (0 0 1 0) (0 0 0 30)) 184051 ((multiListMorph:selection:listSelection:menu: list selection listSelectionAt: methodListMenu:) (0 0 1 0.4) (0 30 0 0)) 184052 ((buttonRow: #(('Select All' selectAll 'select all changes') ('Select None' selectNone 'select no changes'))) (0 0.4 1 0.4) (0 0 0 30)) 184053 ((textMorph: text) (0 0.4 1 1) (0 30 0 0)) 184054 )]. 184055 184056 ^ #( 184057 ((buttonRow) (0 0 1 0) (0 0 0 30)) 184058 ((multiListMorph:selection:listSelection:menu: list selection listSelectionAt: methodListMenu:) (0 0 1 0.4) (0 30 0 0)) 184059 ((buttonRow: #(('Select All' selectAll 'select all changes') ('Select None' selectNone 'select no changes'))) (0 0.4 1 0.4) (0 0 0 30)) 184060 ((textMorph: annotations) (0 0.4 1 0.4) (0 30 0 60)) 184061 ((textMorph: text) (0 0.4 1 1) (0 60 0 0)) 184062 )! ! 184063 184064 184065!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:07'! 184066buttonSpecs 184067 ^ #((Select select 'Select these changes') 184068 (Cancel cancel 'Cancel the operation') 184069 )! ! 184070 184071!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:26'! 184072cancel 184073 self answer: nil! ! 184074 184075!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/14/2004 15:01'! 184076defaultLabel 184077 ^ 'Change Selector'! ! 184078 184079!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:13'! 184080innerButtonRow 184081 ^ self buttonRow: 184082 #(('Select All' selectAll 'select all changes') 184083 ('Select None' selectNone 'select no changes'))! ! 184084 184085!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 184086kept 184087 ^ kept ifNil: [kept := Set new]! ! 184088 184089!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:22'! 184090listSelectionAt: aNumber 184091 ^ self kept includes: (self items at: aNumber)! ! 184092 184093!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 184094listSelectionAt: aNumber put: aBoolean 184095 | item | 184096 item := self items at: aNumber. 184097 aBoolean 184098 ifTrue: [self kept add: item ] 184099 ifFalse: [self kept remove: item ifAbsent: []]! ! 184100 184101!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:26'! 184102select 184103 self answer: (MCPatch operations: kept)! ! 184104 184105!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/14/2004 15:00'! 184106selectAll 184107 kept addAll: self items. 184108 self changed: #list! ! 184109 184110!MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 184111selectNone 184112 kept := Set new. 184113 self changed: #list! ! 184114 184115"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 184116 184117MCChangeSelector class 184118 instanceVariableNames: ''! 184119MCDefinition subclass: #MCClassDefinition 184120 instanceVariableNames: 'name superclassName variables category type comment commentStamp traitComposition classTraitComposition' 184121 classVariableNames: '' 184122 poolDictionaries: '' 184123 category: 'Monticello-Modeling'! 184124 184125!MCClassDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 1/14/2009 13:41'! 184126classDefinitionString 184127 "Answer a string describing the class-side definition." 184128 184129 ^String streamContents: [:stream | self printClassDefinitionOn: stream]! ! 184130 184131!MCClassDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 1/14/2009 13:41'! 184132printClassDefinitionOn: stream 184133 "Print a class-side definition of the receiver on the given stream. 184134 Class instance variables and class traits." 184135 184136 stream 184137 nextPutAll: self className; 184138 nextPutAll: ' class'; 184139 cr; tab. 184140 self hasClassTraitComposition ifTrue: [ 184141 stream 184142 nextPutAll: 'uses: '; 184143 nextPutAll: self classTraitCompositionString; 184144 cr; tab ]. 184145 stream 184146 nextPutAll: 'instanceVariableNames: '; 184147 store: self classInstanceVariablesString! ! 184148 184149 184150!MCClassDefinition methodsFor: 'accessing' stamp: 'nk 2/25/2005 09:49'! 184151actualClass 184152 ^Smalltalk classNamed: self className! ! 184153 184154!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 11/24/2002 06:23'! 184155category 184156 ^ category! ! 184157 184158!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:32'! 184159classInstVarNames 184160 ^ self selectVariables: #isClassInstanceVariable! ! 184161 184162!MCClassDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 01:52'! 184163className 184164 ^ name! ! 184165 184166!MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:07'! 184167classTraitComposition 184168 ^classTraitComposition! ! 184169 184170!MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:55'! 184171classTraitCompositionString 184172 ^self classTraitComposition ifNil: ['{}'].! ! 184173 184174!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:33'! 184175classVarNames 184176 ^ self selectVariables: #isClassVariable! ! 184177 184178!MCClassDefinition methodsFor: 'accessing' stamp: 'ab 1/15/2003 13:42'! 184179comment 184180 ^ comment! ! 184181 184182!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 8/10/2003 16:40'! 184183commentStamp 184184 ^ commentStamp! ! 184185 184186!MCClassDefinition methodsFor: 'accessing' stamp: 'ab 12/5/2002 21:24'! 184187description 184188 ^ Array with: name 184189! ! 184190 184191!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:33'! 184192instVarNames 184193 ^ self selectVariables: #isInstanceVariable! ! 184194 184195!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:53'! 184196poolDictionaries 184197 ^ self selectVariables: #isPoolImport! ! 184198 184199!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:28'! 184200selectVariables: aSelector 184201 ^ variables select: [:v | v perform: aSelector] thenCollect: [:v | v name]! ! 184202 184203!MCClassDefinition methodsFor: 'accessing' stamp: 'ab 7/19/2003 18:00'! 184204sortKey 184205 ^ self className! ! 184206 184207!MCClassDefinition methodsFor: 'accessing' stamp: 'bf 8/29/2006 11:45'! 184208sortedVariables 184209 "sort variables for comparison purposes" 184210 184211 | sorted | 184212 sorted := variables select: [:var | var isOrderDependend]. 184213 sorted addAll: ((variables reject: [:var | var isOrderDependend]) 184214 asSortedCollection: [:a :b | a name <= b name]). 184215 ^sorted! ! 184216 184217!MCClassDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 17:41'! 184218superclassName 184219 ^ superclassName! ! 184220 184221!MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:16'! 184222traitComposition 184223 ^traitComposition! ! 184224 184225!MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:55'! 184226traitCompositionString 184227 ^self traitComposition ifNil: ['{}'].! ! 184228 184229!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 11/24/2002 22:35'! 184230type 184231 ^ type! ! 184232 184233!MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 11/25/2002 06:51'! 184234variables 184235 ^ variables! ! 184236 184237 184238!MCClassDefinition methodsFor: 'annotations' stamp: 'nk 7/24/2003 16:05'! 184239printAnnotations: requests on: aStream 184240 "Add a string for an annotation pane, trying to fulfill the annotation requests. 184241 These might include anything that 184242 Preferences defaultAnnotationRequests 184243 might return. Which includes anything in 184244 Preferences annotationInfo 184245 To edit these, use:" 184246 "Preferences editAnnotations" 184247 184248 requests do: [ :aRequest | 184249 aRequest == #requirements ifTrue: [ 184250 self requirements do: [ :req | aStream nextPutAll: req ] separatedBy: [ aStream space ]] 184251 ] separatedBy: [ aStream space ].! ! 184252 184253 184254!MCClassDefinition methodsFor: 'comparing' stamp: 'stephaneducasse 2/4/2006 20:47'! 184255hash 184256 | hash | 184257 hash := String stringHash: name initialHash: 0. 184258 hash := String stringHash: superclassName initialHash: hash. 184259 hash := String stringHash: self traitCompositionString initialHash: hash. 184260 hash := String stringHash: self classTraitComposition asString initialHash: hash. 184261 hash := String stringHash: (category ifNil: ['']) initialHash: hash. 184262 hash := String stringHash: type initialHash: hash. 184263 variables do: [ 184264 :v | 184265 hash := String stringHash: v name initialHash: hash. 184266 ]. 184267 ^ hash! ! 184268 184269!MCClassDefinition methodsFor: 'comparing' stamp: 'ab 5/24/2003 14:12'! 184270provisions 184271 ^ Array with: name! ! 184272 184273!MCClassDefinition methodsFor: 'comparing' stamp: 'avi 2/17/2004 03:13'! 184274requirements 184275 ^ (Array with: superclassName), self poolDictionaries! ! 184276 184277 184278!MCClassDefinition methodsFor: 'initializing' stamp: 'cwp 7/7/2003 23:19'! 184279addVariables: aCollection ofType: aClass 184280 variables addAll: (aCollection collect: [:var | aClass name: var asString]).! ! 184281 184282!MCClassDefinition methodsFor: 'initializing' stamp: 'cwp 8/10/2003 17:39'! 184283defaultCommentStamp 184284 ^ String new 184285 184286 "The version below avoids stomping on stamps already in the image 184287 184288 ^ (Smalltalk at: name ifPresent: [:c | c organization commentStamp]) 184289 ifNil: [''] 184290 " 184291! ! 184292 184293!MCClassDefinition methodsFor: 'initializing' stamp: 'bf 8/12/2009 10:55'! 184294initializeWithName: nameString 184295superclassName: superclassString 184296category: categoryString 184297instVarNames: ivarArray 184298classVarNames: cvarArray 184299poolDictionaryNames: poolArray 184300classInstVarNames: civarArray 184301type: typeSymbol 184302comment: commentString 184303commentStamp: stampStringOrNil 184304 name := nameString asSymbol. 184305 superclassName := superclassString ifNil: ['nil'] ifNotNil: [superclassString asSymbol]. 184306 category := categoryString. 184307 name = #CompiledMethod ifTrue: [type := #compiledMethod] ifFalse: [type := typeSymbol]. 184308 comment := commentString withSqueakLineEndings. 184309 commentStamp := stampStringOrNil ifNil: [self defaultCommentStamp]. 184310 variables := OrderedCollection new. 184311 self addVariables: ivarArray ofType: MCInstanceVariableDefinition. 184312 self addVariables: cvarArray asSortedCollection ofType: MCClassVariableDefinition. 184313 self addVariables: poolArray asSortedCollection ofType: MCPoolImportDefinition. 184314 self addVariables: civarArray ofType: MCClassInstanceVariableDefinition.! ! 184315 184316!MCClassDefinition methodsFor: 'initializing' stamp: 'bf 8/12/2009 10:55'! 184317initializeWithName: nameString 184318superclassName: superclassString 184319traitComposition: traitCompositionString 184320classTraitComposition: classTraitCompositionString 184321category: categoryString 184322instVarNames: ivarArray 184323classVarNames: cvarArray 184324poolDictionaryNames: poolArray 184325classInstVarNames: civarArray 184326type: typeSymbol 184327comment: commentString 184328commentStamp: stampStringOrNil 184329 name := nameString asSymbol. 184330 superclassName := superclassString ifNil: ['nil'] ifNotNil: [superclassString asSymbol]. 184331 traitComposition := traitCompositionString. 184332 classTraitComposition := classTraitCompositionString. 184333 category := categoryString. 184334 name = #CompiledMethod ifTrue: [type := #compiledMethod] ifFalse: [type := typeSymbol]. 184335 comment := commentString withSqueakLineEndings. 184336 commentStamp := stampStringOrNil ifNil: [self defaultCommentStamp]. 184337 variables := OrderedCollection new. 184338 self addVariables: ivarArray ofType: MCInstanceVariableDefinition. 184339 self addVariables: cvarArray asSortedCollection ofType: MCClassVariableDefinition. 184340 self addVariables: poolArray asSortedCollection ofType: MCPoolImportDefinition. 184341 self addVariables: civarArray ofType: MCClassInstanceVariableDefinition.! ! 184342 184343 184344!MCClassDefinition methodsFor: 'installing' stamp: 'stephaneducasse 2/4/2006 20:47'! 184345createClass 184346 | superClass class | 184347 superClass := Smalltalk at: superclassName. 184348 class := (ClassBuilder new) 184349 name: name 184350 inEnvironment: superClass environment 184351 subclassOf: superClass 184352 type: type 184353 instanceVariableNames: self instanceVariablesString 184354 classVariableNames: self classVariablesString 184355 poolDictionaries: self sharedPoolsString 184356 category: category. 184357 self traitComposition ifNotNil: [ 184358 class setTraitComposition: (Compiler 184359 evaluate: self traitComposition) asTraitComposition ]. 184360 self classTraitComposition ifNotNil: [ 184361 class class setTraitComposition: (Compiler 184362 evaluate: self classTraitComposition) asTraitComposition ]. 184363 ^class. 184364! ! 184365 184366!MCClassDefinition methodsFor: 'installing' stamp: 'marcus.denker 11/10/2008 10:04'! 184367load 184368 self createClass ifNotNil: 184369 [:class | 184370 class class instanceVariableNames: self classInstanceVariablesString. 184371 self hasComment ifTrue: [class classComment: comment stamp: commentStamp]]! ! 184372 184373!MCClassDefinition methodsFor: 'installing' stamp: 'eem 4/30/2009 16:47'! 184374stringForSortedVariablesOfType: aSymbol 184375 ^ String streamContents: 184376 [:stream | 184377 (self selectVariables: aSymbol) asSortedCollection 184378 do: [:ea | stream nextPutAll: ea] 184379 separatedBy: [stream space]]! ! 184380 184381!MCClassDefinition methodsFor: 'installing' stamp: 'cwp 2/3/2004 21:35'! 184382stringForVariablesOfType: aSymbol 184383 ^ String streamContents: 184384 [:stream | 184385 (self selectVariables: aSymbol) 184386 do: [:ea | stream nextPutAll: ea] 184387 separatedBy: [stream space]]! ! 184388 184389!MCClassDefinition methodsFor: 'installing' stamp: 'ab 11/13/2002 19:39'! 184390unload 184391 Smalltalk removeClassNamed: name! ! 184392 184393 184394!MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/7/2003 23:35'! 184395classInstanceVariablesString 184396 ^ self stringForVariablesOfType: #isClassInstanceVariable! ! 184397 184398!MCClassDefinition methodsFor: 'printing' stamp: 'eem 4/30/2009 16:47'! 184399classVariablesString 184400 ^ self stringForSortedVariablesOfType: #isClassVariable! ! 184401 184402!MCClassDefinition methodsFor: 'printing' stamp: 'cwp 8/2/2003 02:03'! 184403definitionString 184404 ^ String streamContents: [:stream | self printDefinitionOn: stream]! ! 184405 184406!MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/7/2003 23:35'! 184407instanceVariablesString 184408 ^ self stringForVariablesOfType: #isInstanceVariable! ! 184409 184410!MCClassDefinition methodsFor: 'printing' stamp: 'cwp 11/24/2002 22:16'! 184411kindOfSubclass 184412 type = #normal ifTrue: [^ ' subclass: ']. 184413 type = #words ifTrue: [^ ' variableWordSubclass: ']. 184414 type = #variable ifTrue: [^ ' variableSubclass: ']. 184415 type = #bytes ifTrue: [^ ' variableByteSubclass: ']. 184416 type = #weak ifTrue: [^ ' weakSubclass: ' ]. 184417 type = #compiledMethod ifTrue: [^ ' variableByteSubclass: ' ]. 184418 self error: 'Unrecognized class type'! ! 184419 184420!MCClassDefinition methodsFor: 'printing' stamp: 'al 3/28/2006 23:42'! 184421printDefinitionOn: stream 184422 stream 184423 nextPutAll: self superclassName; 184424 nextPutAll: self kindOfSubclass; 184425 nextPut: $# ; 184426 nextPutAll: self className; 184427 cr; tab. 184428 self hasTraitComposition ifTrue: [ 184429 stream 184430 nextPutAll: 'uses: '; 184431 nextPutAll: self traitCompositionString; 184432 cr; tab ]. 184433 stream 184434 nextPutAll: 'instanceVariableNames: '; 184435 store: self instanceVariablesString; 184436 cr; tab; 184437 nextPutAll: 'classVariableNames: '; 184438 store: self classVariablesString; 184439 cr; tab; 184440 nextPutAll: 'poolDictionaries: '; 184441 store: self sharedPoolsString; 184442 cr; tab; 184443 nextPutAll: 'category: '; 184444 store: self category asString! ! 184445 184446!MCClassDefinition methodsFor: 'printing' stamp: 'eem 4/30/2009 16:47'! 184447sharedPoolsString 184448 ^ self stringForSortedVariablesOfType: #isPoolImport! ! 184449 184450!MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/10/2003 01:29'! 184451source 184452 ^ self definitionString! ! 184453 184454!MCClassDefinition methodsFor: 'printing' stamp: 'ab 11/16/2002 17:33'! 184455summary 184456 ^ name! ! 184457 184458 184459!MCClassDefinition methodsFor: 'serializing' stamp: 'al 7/4/2006 10:14'! 184460storeDataOn: aDataStream 184461 | instVarSize | 184462 instVarSize := (self hasTraitComposition or: [ self hasClassTraitComposition ]) 184463 ifTrue: [ self class instSize ] 184464 ifFalse: [ self class instSize - 2 ]. 184465 aDataStream 184466 beginInstance: self class 184467 size: instVarSize. 184468 1 to: instVarSize do: [ :index | 184469 aDataStream nextPut: (self instVarAt: index) ].! ! 184470 184471 184472!MCClassDefinition methodsFor: 'testing' stamp: 'cwp 8/2/2003 02:54'! 184473hasClassInstanceVariables 184474 ^ (self selectVariables: #isClassInstanceVariable) isEmpty not! ! 184475 184476!MCClassDefinition methodsFor: 'testing' stamp: 'al 10/9/2005 21:59'! 184477hasClassTraitComposition 184478 ^self classTraitCompositionString ~= '{}'! ! 184479 184480!MCClassDefinition methodsFor: 'testing' stamp: 'al 10/9/2005 20:13'! 184481hasComment 184482 ^ comment isEmptyOrNil not! ! 184483 184484!MCClassDefinition methodsFor: 'testing' stamp: 'al 3/29/2006 00:27'! 184485hasTraitComposition 184486 ^self traitCompositionString ~= '{}'! ! 184487 184488!MCClassDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:52'! 184489isClassDefinition 184490 ^ true! ! 184491 184492!MCClassDefinition methodsFor: 'testing' stamp: 'ab 5/24/2003 13:49'! 184493isCodeDefinition 184494 ^ true! ! 184495 184496 184497!MCClassDefinition methodsFor: 'visiting' stamp: 'al 10/9/2005 19:33'! 184498accept: aVisitor 184499 aVisitor visitClassDefinition: self. 184500 (self hasClassInstanceVariables or: [self hasClassTraitComposition]) 184501 ifTrue: [aVisitor visitMetaclassDefinition: self]. 184502! ! 184503 184504!MCClassDefinition methodsFor: 'visiting' stamp: 'bf 8/12/2009 10:53'! 184505= aDefinition 184506 ^((super = aDefinition) 184507 and: [superclassName = aDefinition superclassName] 184508 and: [self traitCompositionString = aDefinition traitCompositionString] 184509 and: [self classTraitCompositionString = aDefinition classTraitCompositionString]) 184510 and: [category = aDefinition category] 184511 and: [type = aDefinition type] 184512 and: [self sortedVariables = aDefinition sortedVariables] 184513 and: [comment = aDefinition comment] 184514 ! ! 184515 184516"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 184517 184518MCClassDefinition class 184519 instanceVariableNames: ''! 184520 184521!MCClassDefinition class methodsFor: 'instance creation' stamp: 'al 10/9/2005 19:16'! 184522name: nameString 184523superclassName: superclassString 184524category: categoryString 184525instVarNames: ivarArray 184526classVarNames: cvarArray 184527poolDictionaryNames: poolArray 184528classInstVarNames: civarArray 184529type: typeSymbol 184530comment: commentString 184531commentStamp: stampString 184532 ^ self instanceLike: 184533 (self new initializeWithName: nameString 184534 superclassName: superclassString 184535 traitComposition: '{}' 184536 classTraitComposition: '{}' 184537 category: categoryString 184538 instVarNames: ivarArray 184539 classVarNames: cvarArray 184540 poolDictionaryNames: poolArray 184541 classInstVarNames: civarArray 184542 type: typeSymbol 184543 comment: commentString 184544 commentStamp: stampString)! ! 184545 184546!MCClassDefinition class methodsFor: 'instance creation' stamp: 'al 10/10/2005 13:58'! 184547name: nameString 184548superclassName: superclassString 184549traitComposition: traitCompositionString 184550classTraitComposition: classTraitCompositionString 184551category: categoryString 184552instVarNames: ivarArray 184553classVarNames: cvarArray 184554poolDictionaryNames: poolArray 184555classInstVarNames: civarArray 184556type: typeSymbol 184557comment: commentString 184558commentStamp: stampString 184559 184560 ^ self instanceLike: 184561 (self new initializeWithName: nameString 184562 superclassName: superclassString 184563 traitComposition: traitCompositionString 184564 classTraitComposition: classTraitCompositionString 184565 category: categoryString 184566 instVarNames: ivarArray 184567 classVarNames: cvarArray 184568 poolDictionaryNames: poolArray 184569 classInstVarNames: civarArray 184570 type: typeSymbol 184571 comment: commentString 184572 commentStamp: stampString)! ! 184573 184574 184575!MCClassDefinition class methodsFor: 'obsolete' stamp: 'ab 4/1/2003 01:22'! 184576name: nameString 184577superclassName: superclassString 184578category: categoryString 184579instVarNames: ivarArray 184580classVarNames: cvarArray 184581poolDictionaryNames: poolArray 184582classInstVarNames: civarArray 184583comment: commentString 184584 ^ self name: nameString 184585 superclassName: superclassString 184586 category: categoryString 184587 instVarNames: ivarArray 184588 classVarNames: cvarArray 184589 poolDictionaryNames: poolArray 184590 classInstVarNames: civarArray 184591 type: #normal 184592 comment: commentString 184593! ! 184594 184595!MCClassDefinition class methodsFor: 'obsolete' stamp: 'cwp 8/10/2003 16:33'! 184596name: nameString 184597superclassName: superclassString 184598category: categoryString 184599instVarNames: ivarArray 184600classVarNames: cvarArray 184601poolDictionaryNames: poolArray 184602classInstVarNames: civarArray 184603type: typeSymbol 184604comment: commentString 184605 ^ self 184606 name: nameString 184607 superclassName: superclassString 184608 category: categoryString 184609 instVarNames: ivarArray 184610 classVarNames: cvarArray 184611 poolDictionaryNames: poolArray 184612 classInstVarNames: civarArray 184613 type: typeSymbol 184614 comment: commentString 184615 commentStamp: nil! ! 184616 184617!MCClassDefinition class methodsFor: 'obsolete' stamp: 'ab 4/1/2003 01:22'! 184618name: nameString 184619superclassName: superclassString 184620category: categoryString 184621instVarNames: ivarArray 184622comment: commentString 184623 ^ self name: nameString 184624 superclassName: superclassString 184625 category: categoryString 184626 instVarNames: ivarArray 184627 classVarNames: #() 184628 poolDictionaryNames: #() 184629 classInstVarNames: #() 184630 comment: commentString 184631! ! 184632MCTestCase subclass: #MCClassDefinitionTest 184633 instanceVariableNames: 'previousChangeSet' 184634 classVariableNames: '' 184635 poolDictionaries: '' 184636 category: 'Tests-Monticello'! 184637 184638!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 01:20'! 184639classAComment 184640 ^ self class classAComment! ! 184641 184642!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 17:17'! 184643creationMessage 184644 ^ MessageSend 184645 receiver: MCClassDefinition 184646 selector: #name:superclassName:category:instVarNames:classVarNames:poolDictionaryNames:classInstVarNames:type:comment:commentStamp:! ! 184647 184648!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 16:57'! 184649tearDown 184650 Smalltalk at: 'MCMockClassC' ifPresent: [:c | c removeFromSystem]! ! 184651 184652!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 184653testCannotLoad 184654 | d | 184655 d := self mockClass: 'MCMockClassC' super: 'NotAnObject'. 184656 self should: [d load] raise: Error. 184657 self deny: (Smalltalk hasClassNamed: 'MCMockClassC').! ! 184658 184659!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 184660testComparison 184661 | d1 d2 d3 d4 | 184662 d1 := self mockClass: 'A' super: 'X'. 184663 d2 := self mockClass: 'A' super: 'Y'. 184664 d3 := self mockClass: 'B' super: 'X'. 184665 d4 := self mockClass: 'B' super: 'X'. 184666 184667 self assert: (d1 isRevisionOf: d2). 184668 self deny: (d1 isSameRevisionAs: d2). 184669 184670 self assert: (d3 isRevisionOf: d4). 184671 self assert: (d3 isSameRevisionAs: d4). 184672 184673 self deny: (d1 isRevisionOf: d3). 184674 self deny: (d4 isRevisionOf: d2).! ! 184675 184676!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 184677testCreation 184678 | d | 184679 d := self mockClassA asClassDefinition. 184680 self assert: d className = #MCMockClassA. 184681 self assert: d superclassName = #MCMock. 184682 self assert: d type = #normal. 184683 self assert: d category = self mockCategoryName. 184684 self assert: d instVarNames asArray = #('ivar'). 184685 self assert: d classVarNames asArray = #('CVar'). 184686 self assert: d classInstVarNames asArray = #(). 184687 self assert: d comment isString. 184688 self assert: d comment = self classAComment. 184689 self assert: d commentStamp = self mockClassA organization commentStamp! ! 184690 184691!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 184692testDefinitionString 184693 | d | 184694 d := self mockClassA asClassDefinition. 184695 self assert: d definitionString = self mockClassA definition.! ! 184696 184697!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 184698testEquals 184699 | a b | 184700 a := self mockClass: 'ClassA' super: 'SuperA'. 184701 b := self mockClass: 'ClassA' super: 'SuperA'. 184702 self assert: a = b! ! 184703 184704!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 184705testEqualsSensitivity 184706 | message a b defA args defB | 184707 message := self creationMessage. 184708 a := #(ClassA SuperA CategoryA #(iVarA) #(CVarA) #(PoolA) #(ciVarA) 184709 typeA 'A comment' 'A'). 184710 b := #(ClassB SuperB CategoryB #(iVarB) #(CVarB) #(PoolB) #(ciVarB) 184711 typeB 'B comment' 'B'). 184712 184713 defA := message valueWithArguments: a. 184714 1 to: 8 do: [:index | 184715 args := a copy. 184716 args at: index put: (b at: index). 184717 defB := message valueWithArguments: args. 184718 self deny: defA = defB.]! ! 184719 184720!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 184721testKindOfSubclass 184722 | classes d | 184723 classes := {self mockClassA. String. MethodContext. WeakArray. Float}. 184724 classes do: [:c | 184725 d := c asClassDefinition. 184726 self assert: d kindOfSubclass = c kindOfSubclass. 184727 ].! ! 184728 184729!MCClassDefinitionTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 184730testLoadAndUnload 184731 | d c | 184732 d := self mockClass: 'MCMockClassC' super: 'Object'. 184733 d load. 184734 self assert: (Smalltalk hasClassNamed: 'MCMockClassC'). 184735 c := (Smalltalk classNamed: 'MCMockClassC'). 184736 self assert: (c isKindOf: Class). 184737 self assert: c superclass = Object. 184738 self assert: c instVarNames isEmpty. 184739 self assert: c classVarNames isEmpty. 184740 self assert: c sharedPools isEmpty. 184741 self assert: c category = self mockCategoryName. 184742 self assert: c organization classComment = (self commentForClass: 'MCMockClassC'). 184743 self assert: c organization commentStamp = (self commentStampForClass: 'MCMockClassC'). 184744 d unload. 184745 self deny: (Smalltalk hasClassNamed: 'MCMockClassC').! ! 184746 184747"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 184748 184749MCClassDefinitionTest class 184750 instanceVariableNames: ''! 184751 184752!MCClassDefinitionTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 01:20'! 184753classAComment 184754 ^ 'This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.'! ! 184755 184756!MCClassDefinitionTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 17:59'! 184757classACommentStamp 184758 ^ 'cwp 8/10/2003 16:43'! ! 184759 184760!MCClassDefinitionTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 18:01'! 184761restoreClassAComment 184762 Smalltalk 184763 at: #MCMockClassA 184764 ifPresent: [:a | a classComment: self classAComment stamp: self classACommentStamp]! ! 184765MCVariableDefinition subclass: #MCClassInstanceVariableDefinition 184766 instanceVariableNames: '' 184767 classVariableNames: '' 184768 poolDictionaries: '' 184769 category: 'Monticello-Modeling'! 184770 184771!MCClassInstanceVariableDefinition methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 23:31'! 184772isClassInstanceVariable 184773 ^ true! ! 184774 184775"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 184776 184777MCClassInstanceVariableDefinition class 184778 instanceVariableNames: ''! 184779 184780!MCClassInstanceVariableDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 22:59'! 184781type 184782 ^ #classInstance! ! 184783MCDefinition subclass: #MCClassTraitDefinition 184784 instanceVariableNames: 'baseTrait classTraitComposition category' 184785 classVariableNames: '' 184786 poolDictionaries: '' 184787 category: 'Monticello-Modeling'! 184788 184789!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:23'! 184790baseTrait 184791 ^baseTrait 184792! ! 184793 184794!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'damiencassou 7/30/2009 12:23'! 184795category 184796 ^ category ifNil: [(Smalltalk classOrTraitNamed: self baseTrait) 184797 ifNotNil: [:baseTrait | baseTrait category] 184798 ifNil: [self error: 'Can''t detect the category']]! ! 184799 184800!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 12/15/2005 11:31'! 184801className 184802 ^self baseTrait! ! 184803 184804!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:23'! 184805classTraitComposition 184806 ^classTraitComposition 184807 184808! ! 184809 184810!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/10/2005 10:12'! 184811classTraitCompositionString 184812 ^self classTraitComposition ifNil: ['{}']. 184813 184814! ! 184815 184816!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:59'! 184817definitionString 184818 ^self baseTrait , ' classTrait 184819 uses: ' , self classTraitCompositionString. 184820! ! 184821 184822!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:24'! 184823description 184824 ^Array 184825 with: baseTrait 184826 with: classTraitComposition! ! 184827 184828!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 6/5/2006 14:04'! 184829hash 184830 | hash | 184831 hash := String stringHash: baseTrait initialHash: 0. 184832 hash := String stringHash: self classTraitCompositionString initialHash: hash. 184833 ^hash 184834! ! 184835 184836!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:24'! 184837requirements 184838 ^Array with: baseTrait! ! 184839 184840!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:25'! 184841sortKey 184842 ^ self baseTrait name , '.classTrait'! ! 184843 184844!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:25'! 184845source 184846 ^self definitionString! ! 184847 184848!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:25'! 184849summary 184850 ^self baseTrait , ' classTrait' 184851! ! 184852 184853!MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:59'! 184854= aDefinition 184855 ^ (super = aDefinition) 184856 and: [baseTrait = aDefinition baseTrait] 184857 and: [self classTraitCompositionString = aDefinition classTraitCompositionString] 184858 184859! ! 184860 184861 184862!MCClassTraitDefinition methodsFor: 'as yet unclassified' stamp: 'al 10/9/2005 20:23'! 184863accept: aVisitor 184864 ^ aVisitor visitClassTraitDefinition: self.! ! 184865 184866 184867!MCClassTraitDefinition methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! 184868initializeWithBaseTraitName: aTraitName classTraitComposition: aString 184869 baseTrait := aTraitName. 184870 classTraitComposition := aString.! ! 184871 184872!MCClassTraitDefinition methodsFor: 'initialization' stamp: 'damiencassou 7/30/2009 12:12'! 184873initializeWithBaseTraitName: aTraitName classTraitComposition: aString category: aCategoryString 184874 baseTrait := aTraitName. 184875 classTraitComposition := aString. 184876 category := aCategoryString! ! 184877 184878 184879!MCClassTraitDefinition methodsFor: 'installing' stamp: 'al 10/9/2005 20:24'! 184880load 184881 Compiler evaluate: self definitionString! ! 184882 184883 184884!MCClassTraitDefinition methodsFor: 'testing' stamp: 'adrian-lienhard 5/11/2009 16:47'! 184885isClassDefinition 184886 "Traits are treated the same like classes." 184887 184888 ^ true! ! 184889 184890"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 184891 184892MCClassTraitDefinition class 184893 instanceVariableNames: ''! 184894 184895!MCClassTraitDefinition class methodsFor: 'instance creation' stamp: 'damiencassou 7/30/2009 12:32'! 184896baseTraitName: aString classTraitComposition: classTraitCompositionString 184897 ^ self baseTraitName: aString classTraitComposition: classTraitCompositionString category: nil! ! 184898 184899!MCClassTraitDefinition class methodsFor: 'instance creation' stamp: 'damiencassou 7/30/2009 12:11'! 184900baseTraitName: aString classTraitComposition: classTraitCompositionString category: aCategoryString 184901 ^self instanceLike: ( 184902 self new 184903 initializeWithBaseTraitName: aString 184904 classTraitComposition: classTraitCompositionString 184905 category: aCategoryString).! ! 184906MCDoItParser subclass: #MCClassTraitParser 184907 instanceVariableNames: '' 184908 classVariableNames: '' 184909 poolDictionaries: '' 184910 category: 'Monticello-Modeling'! 184911 184912!MCClassTraitParser methodsFor: 'as yet unclassified' stamp: 'PeterHugossonMiller 9/2/2009 16:16'! 184913addDefinitionsTo: aCollection 184914 | tokens definition traitCompositionString | 184915 tokens := Scanner new scanTokens: source. 184916 traitCompositionString := (source readStream 184917 match: 'uses:'; 184918 upToEnd) withBlanksTrimmed. 184919 definition := MCClassTraitDefinition 184920 baseTraitName: (tokens at: 1) 184921 classTraitComposition: traitCompositionString. 184922 aCollection add: definition 184923! ! 184924 184925"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 184926 184927MCClassTraitParser class 184928 instanceVariableNames: ''! 184929 184930!MCClassTraitParser class methodsFor: 'as yet unclassified' stamp: 'al 10/9/2005 20:43'! 184931pattern 184932 ^ '*classTrait*uses:*'! ! 184933MCVariableDefinition subclass: #MCClassVariableDefinition 184934 instanceVariableNames: '' 184935 classVariableNames: '' 184936 poolDictionaries: '' 184937 category: 'Monticello-Modeling'! 184938 184939!MCClassVariableDefinition methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 23:32'! 184940isClassVariable 184941 ^ true! ! 184942 184943!MCClassVariableDefinition methodsFor: 'as yet unclassified' stamp: 'bf 8/29/2006 11:41'! 184944isOrderDependend 184945 ^false! ! 184946 184947"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 184948 184949MCClassVariableDefinition class 184950 instanceVariableNames: ''! 184951 184952!MCClassVariableDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 22:58'! 184953type 184954 ^ #class! ! 184955MCTool subclass: #MCCodeTool 184956 instanceVariableNames: 'items' 184957 classVariableNames: '' 184958 poolDictionaries: '' 184959 category: 'MonticelloGUI'! 184960!MCCodeTool commentStamp: 'nk 11/10/2003 22:00' prior: 0! 184961MCCodeTool is an abstract superclass for those Monticello browsers that display code. 184962It contains copies of the various CodeHolder methods that perform the various menu operations in the method list. 184963! 184964 184965 184966!MCCodeTool methodsFor: 'menus' stamp: 'marcus.denker 11/10/2008 10:04'! 184967adoptMessageInCurrentChangeset 184968 "Add the receiver's method to the current change set if not already there" 184969 184970 self selectedClassOrMetaClass ifNotNil: [ :cl | 184971 self selectedMessageName ifNotNil: [ :sel | 184972 ChangeSet current adoptSelector: sel forClass: cl. 184973 self changed: #annotations ]] 184974! ! 184975 184976!MCCodeTool methodsFor: 'menus' stamp: 'sd 5/10/2008 17:31'! 184977browseFullProtocol 184978 "Open up a protocol-category browser on the value of the 184979 receiver's current selection." 184980 184981 ^ self spawnFullProtocol! ! 184982 184983!MCCodeTool methodsFor: 'menus' stamp: 'nk 11/10/2003 21:26'! 184984browseMessages 184985 "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all implementors of the selector chosen." 184986 184987 self systemNavigation browseAllImplementorsOf: (self selectedMessageName ifNil: [ ^nil ])! ! 184988 184989!MCCodeTool methodsFor: 'menus' stamp: 'stephaneducasse 2/4/2006 20:47'! 184990browseMethodFull 184991 "Create and schedule a full Browser and then select the current class and message." 184992 184993 | myClass | 184994 (myClass := self selectedClassOrMetaClass) ifNotNil: 184995 [Browser fullOnClass: myClass selector: self selectedMessageName]! ! 184996 184997!MCCodeTool methodsFor: 'menus' stamp: 'nk 11/10/2003 20:54'! 184998browseSendersOfMessages 184999 "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all senders of the selector chosen." 185000 185001 self systemNavigation browseAllCallsOn: (self selectedMessageName ifNil: [ ^nil ])! ! 185002 185003!MCCodeTool methodsFor: 'menus' stamp: 'stephaneducasse 2/4/2006 20:47'! 185004browseVersions 185005 "Create and schedule a message set browser on all versions of the 185006 currently selected message selector." 185007 185008 | class selector compiledMethod | 185009 class := self selectedClassOrMetaClass. 185010 selector := self selectedMessageName. 185011 compiledMethod := class compiledMethodAt: selector ifAbsent: [ ^self ]. 185012 VersionsBrowser 185013 browseVersionsOf: compiledMethod 185014 class: class theNonMetaClass 185015 meta: class isMeta 185016 category: self selectedMessageCategoryName 185017 selector: selector! ! 185018 185019!MCCodeTool methodsFor: 'menus' stamp: 'nk 7/30/2004 17:56'! 185020classHierarchy 185021 "Create and schedule a class list browser on the receiver's hierarchy." 185022 185023 self systemNavigation spawnHierarchyForClass: self selectedClassOrMetaClass 185024 selector: self selectedMessageName "OK if nil"! ! 185025 185026!MCCodeTool methodsFor: 'menus' stamp: 'nk 6/12/2004 14:01'! 185027classListMenu: aMenu 185028 185029 aMenu addList: #( 185030 - 185031 ('browse full (b)' browseMethodFull) 185032 ('browse hierarchy (h)' classHierarchy) 185033 ('browse protocol (p)' browseFullProtocol) 185034" - 185035 ('printOut' printOutClass) 185036 ('fileOut' fileOutClass) 185037" - 185038 ('show hierarchy' methodHierarchy) 185039" ('show definition' editClass) 185040 ('show comment' editComment) 185041" 185042" - 185043 ('inst var refs...' browseInstVarRefs) 185044 ('inst var defs...' browseInstVarDefs) 185045 - 185046 ('class var refs...' browseClassVarRefs) 185047 ('class vars' browseClassVariables) 185048 ('class refs (N)' browseClassRefs) 185049 - 185050 ('rename class ...' renameClass) 185051 ('copy class' copyClass) 185052 ('remove class (x)' removeClass) 185053" 185054 - 185055 ('find method...' findMethodInChangeSets)). 185056 185057 ^aMenu! ! 185058 185059!MCCodeTool methodsFor: 'menus' stamp: 'stephaneducasse 2/4/2006 20:47'! 185060copySelector 185061 "Copy the selected selector to the clipboard" 185062 185063 | selector | 185064 (selector := self selectedMessageName) ifNotNil: 185065 [Clipboard clipboardText: selector asString]! ! 185066 185067!MCCodeTool methodsFor: 'menus' stamp: 'nk 11/10/2003 20:55'! 185068fileOutMessage 185069 "Put a description of the selected message on a file" 185070 185071 self selectedMessageName ifNotNil: 185072 [Cursor write showWhile: 185073 [self selectedClassOrMetaClass fileOutMethod: self selectedMessageName]]! ! 185074 185075!MCCodeTool methodsFor: 'menus' stamp: 'stephaneducasse 2/4/2006 20:47'! 185076findMethodInChangeSets 185077 "Find and open a changeSet containing the current method." 185078 185079 | aName | 185080 (aName := self selectedMessageName) ifNotNil: [ 185081 ChangeSorter browseChangeSetsWithClass: self selectedClassOrMetaClass 185082 selector: aName]! ! 185083 185084!MCCodeTool methodsFor: 'menus' stamp: 'nk 7/30/2004 17:56'! 185085methodHierarchy 185086 "Create and schedule a method browser on the hierarchy of implementors." 185087 185088 self systemNavigation methodHierarchyBrowserForClass: self selectedClassOrMetaClass 185089 selector: self selectedMessageName! ! 185090 185091!MCCodeTool methodsFor: 'menus' stamp: 'nk 2/16/2004 17:00'! 185092methodListKey: aKeystroke from: aListMorph 185093 aKeystroke caseOf: { 185094 [$b] -> [self browseMethodFull]. 185095 [$h] -> [self classHierarchy]. 185096 [$O] -> [self openSingleMessageBrowser]. 185097 [$p] -> [self browseFullProtocol]. 185098 [$o] -> [self fileOutMessage]. 185099 [$c] -> [self copySelector]. 185100 [$n] -> [self browseSendersOfMessages]. 185101 [$m] -> [self browseMessages]. 185102 [$i] -> [self methodHierarchy]. 185103 [$v] -> [self browseVersions]} 185104 otherwise: []! ! 185105 185106!MCCodeTool methodsFor: 'menus' stamp: 'md 4/30/2008 15:39'! 185107methodListMenu: aMenu 185108 "Build the menu for the selected method, if any." 185109 185110 self selectedMessageName ifNotNil: [ 185111 aMenu addList:#( 185112 ('browse full (b)' browseMethodFull) 185113 ('browse hierarchy (h)' classHierarchy) 185114 ('browse method (O)' openSingleMessageBrowser) 185115 ('browse protocol (p)' browseFullProtocol) 185116 - 185117 ('fileOut (o)' fileOutMessage) 185118 ('copy selector (c)' copySelector)). 185119 aMenu addList: #( 185120 - 185121 ('browse senders (n)' browseSendersOfMessages) 185122 ('browse implementors (m)' browseMessages) 185123 ('inheritance (i)' methodHierarchy) 185124 ('versions (v)' browseVersions) 185125 ('change sets with this method' findMethodInChangeSets) 185126" ('x revert to previous version' revertToPreviousVersion)" 185127 ('remove from current change set' removeFromCurrentChanges) 185128" ('x revert & remove from changes' revertAndForget)" 185129 ('add to current change set' adoptMessageInCurrentChangeset) 185130" ('x copy up or copy down...' copyUpOrCopyDown)" 185131" ('x remove method (x)' removeMessage)" 185132 "-" 185133 ). 185134 ]. 185135" aMenu addList: #( 185136 ('x inst var refs...' browseInstVarRefs) 185137 ('x inst var defs...' browseInstVarDefs) 185138 ('x class var refs...' browseClassVarRefs) 185139 ('x class variables' browseClassVariables) 185140 ('x class refs (N)' browseClassRefs) 185141 ). 185142" 185143 ^ aMenu 185144! ! 185145 185146!MCCodeTool methodsFor: 'menus' stamp: 'stephaneducasse 2/4/2006 20:47'! 185147openSingleMessageBrowser 185148 | msgName mr | 185149 "Create and schedule a message list browser populated only by the currently selected message" 185150 185151 (msgName := self selectedMessageName) ifNil: [^ self]. 185152 185153 mr := MethodReference new 185154 setStandardClass: self selectedClassOrMetaClass 185155 methodSymbol: msgName. 185156 185157 self systemNavigation 185158 browseMessageList: (Array with: mr) 185159 name: mr asStringOrText 185160 autoSelect: nil! ! 185161 185162!MCCodeTool methodsFor: 'menus' stamp: 'nk 11/10/2003 20:55'! 185163perform: selector orSendTo: otherTarget 185164 185165 "Selector was just chosen from a menu by a user. If can respond, then 185166 perform it on myself. If not, send it to otherTarget, presumably the 185167 editPane from which the menu was invoked." 185168 185169 (self respondsTo: selector) 185170 ifTrue: [^ self perform: selector] 185171 ifFalse: [^ super perform: selector orSendTo: otherTarget]! ! 185172 185173!MCCodeTool methodsFor: 'menus' stamp: 'nk 11/10/2003 21:00'! 185174removeFromCurrentChanges 185175 "Tell the changes mgr to forget that the current msg was changed." 185176 185177 ChangeSet current removeSelectorChanges: self selectedMessageName 185178 class: self selectedClassOrMetaClass. 185179 self changed: #annotations! ! 185180 185181 185182!MCCodeTool methodsFor: 'subclassresponsibility' stamp: 'nk 11/10/2003 22:01'! 185183annotations 185184 "Build an annotations string for the various browsers" 185185 ^''! ! 185186 185187!MCCodeTool methodsFor: 'subclassresponsibility' stamp: 'nk 11/10/2003 22:02'! 185188selectedClass 185189 "Answer the class that is selected, or nil" 185190 self subclassResponsibility! ! 185191 185192!MCCodeTool methodsFor: 'subclassresponsibility' stamp: 'nk 11/10/2003 22:02'! 185193selectedClassOrMetaClass 185194 "Answer the class that is selected, or nil" 185195 self subclassResponsibility! ! 185196 185197!MCCodeTool methodsFor: 'subclassresponsibility' stamp: 'nk 11/10/2003 22:02'! 185198selectedMessageCategoryName 185199 "Answer the method category of the method that is selected, or nil" 185200 self subclassResponsibility! ! 185201 185202!MCCodeTool methodsFor: 'subclassresponsibility' stamp: 'nk 11/10/2003 22:02'! 185203selectedMessageName 185204 "Answer the name of the selected message" 185205 self subclassResponsibility! ! 185206 185207"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 185208 185209MCCodeTool class 185210 instanceVariableNames: ''! 185211Object subclass: #MCConfiguration 185212 instanceVariableNames: 'name dependencies repositories log' 185213 classVariableNames: 'DefaultLog' 185214 poolDictionaries: '' 185215 category: 'MonticelloConfigurations'! 185216 185217!MCConfiguration methodsFor: '*MonticelloGUI' stamp: 'bf 3/22/2005 22:09'! 185218browse 185219 (MCConfigurationBrowser new configuration: self) show! ! 185220 185221 185222!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/21/2005 16:32'! 185223dependencies 185224 ^dependencies ifNil: [dependencies := OrderedCollection new]! ! 185225 185226!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/21/2005 18:40'! 185227dependencies: aCollection 185228 dependencies := aCollection! ! 185229 185230!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 18:22'! 185231fileName 185232 ^ self name, '.', self writerClass extension 185233! ! 185234 185235!MCConfiguration methodsFor: 'accessing' stamp: 'bf 6/9/2005 15:58'! 185236log 185237 ^log ifNil: [Transcript]! ! 185238 185239!MCConfiguration methodsFor: 'accessing' stamp: 'ar 4/28/2005 11:55'! 185240log: aStream 185241 log := aStream.! ! 185242 185243!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 18:23'! 185244name 185245 ^name! ! 185246 185247!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 18:23'! 185248name: aString 185249 name := aString! ! 185250 185251!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/23/2005 17:35'! 185252repositories 185253 ^repositories ifNil: [repositories := OrderedCollection new]! ! 185254 185255!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/23/2005 17:36'! 185256repositories: aCollection 185257 repositories := aCollection! ! 185258 185259!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/23/2005 00:44'! 185260summary 185261 ^String streamContents: [:stream | 185262 self dependencies 185263 do: [:ea | stream nextPutAll: ea versionInfo name; cr ]]! ! 185264 185265!MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 10:50'! 185266writerClass 185267 ^ MCMcmWriter ! ! 185268 185269 185270!MCConfiguration methodsFor: 'actions' stamp: 'bf 3/22/2005 10:51'! 185271fileOutOn: aStream 185272 self writerClass fileOut: self on: aStream! ! 185273 185274!MCConfiguration methodsFor: 'actions' stamp: 'bf 3/17/2006 15:55'! 185275load 185276 "install all the versions in this configuration, even if this means to downgrade a package" 185277 185278 | versions | 185279 versions := OrderedCollection new. 185280 185281 self depsSatisfying: [:dep | dep isCurrent not] 185282 versionDo: [:ver | versions add: ver] 185283 displayingProgress: 'finding packages'. 185284 185285 ^self loadVersions: versions! ! 185286 185287!MCConfiguration methodsFor: 'actions' stamp: 'bf 3/16/2006 17:41'! 185288merge 185289 "merge in all the versions in this configuration" 185290 185291 | versions | 185292 versions := OrderedCollection new. 185293 185294 self depsSatisfying: [:dep | dep isFulfilledByAncestors not] 185295 versionDo: [:ver | versions add: ver] 185296 displayingProgress: 'finding packages'. 185297 185298 ^self mergeVersions: versions! ! 185299 185300!MCConfiguration methodsFor: 'actions' stamp: 'bf 3/16/2006 17:22'! 185301upgrade 185302 ^Preferences upgradeIsMerge 185303 ifTrue: [self upgradeByMerging] 185304 ifFalse: [self upgradeByLoading]! ! 185305 185306!MCConfiguration methodsFor: 'actions' stamp: 'bf 3/17/2006 16:17'! 185307upgradeByLoading 185308 "this differs from #load only in that newer versions in the image are not downgraded" 185309 185310 | versions | 185311 versions := OrderedCollection new. 185312 185313 self depsSatisfying: [:dep | dep isFulfilledByAncestors not] 185314 versionDo: [:ver | versions add: ver] 185315 displayingProgress: 'finding packages'. 185316 185317 ^self loadVersions: versions 185318! ! 185319 185320!MCConfiguration methodsFor: 'actions' stamp: 'bf 3/20/2006 19:10'! 185321upgradeByMerging 185322 | versions | 185323 versions := OrderedCollection new. 185324 185325 self depsSatisfying: [:dep | dep isFulfilledByAncestors not] 185326 versionDo: [:ver | versions add: ver] 185327 displayingProgress: 'finding packages'. 185328 185329 ^(versions noneSatisfy: [:ver | self mustMerge: ver]) 185330 ifTrue: [self loadVersions: versions] 185331 ifFalse: [self mergeVersionsSilently: versions]. 185332! ! 185333 185334 185335!MCConfiguration methodsFor: 'copying' stamp: 'bf 11/26/2005 20:22'! 185336postCopy 185337 dependencies := dependencies shallowCopy. 185338 repositories := repositories shallowCopy.! ! 185339 185340 185341!MCConfiguration methodsFor: 'faking' stamp: 'bf 3/24/2005 01:19'! 185342changes 185343 ^MCPatch operations: #()! ! 185344 185345!MCConfiguration methodsFor: 'faking' stamp: 'bf 3/24/2005 01:17'! 185346info 185347 ^MCVersionInfo new! ! 185348 185349 185350!MCConfiguration methodsFor: 'initialize' stamp: 'ar 5/27/2005 17:28'! 185351initialize 185352 super initialize. 185353 log := DefaultLog.! ! 185354 185355 185356!MCConfiguration methodsFor: 'testing' stamp: 'bf 3/22/2005 22:56'! 185357isCacheable 185358 ^false! ! 185359 185360 185361!MCConfiguration methodsFor: 'updating' stamp: 'bf 5/23/2005 17:43'! 185362updateFromImage 185363 self dependencies: (self dependencies collect: [:dep | 185364 dep package hasWorkingCopy 185365 ifTrue: [ 185366 dep package workingCopy in: [:wc | 185367 MCVersionDependency package: wc package info: wc ancestors first]] 185368 ifFalse: [dep]]). 185369! ! 185370 185371!MCConfiguration methodsFor: 'updating' stamp: 'bf 5/30/2005 20:50'! 185372updateFromRepositories 185373 | oldInfos newNames sortedNames newDeps | 185374 oldInfos := self dependencies collect: [:dep | dep versionInfo]. 185375 newNames := Dictionary new. 185376 self repositories 185377 do: [:repo | 185378 ProgressNotification signal: '' extra: 'Checking ', repo description. 185379 (repo possiblyNewerVersionsOfAnyOf: oldInfos) 185380 do: [:newName | newNames at: newName put: repo]] 185381 displayingProgress: 'Searching new versions'. 185382 185383 sortedNames := newNames keys asSortedCollection: 185384 [:a :b | a numericSuffix > b numericSuffix]. 185385 185386 newDeps := OrderedCollection new. 185387 self dependencies do: [:dep | 185388 | newName | 185389 newName := sortedNames 185390 detect: [:each | (each copyUpToLast: $-) = dep package name] 185391 ifNone: [nil]. 185392 newDeps add: (newName 185393 ifNil: [dep] 185394 ifNotNil: [ 185395 | repo ver | 185396 repo := newNames at: newName. 185397 ver := self versionNamed: newName for: dep from: repo. 185398 ver ifNil: [dep] 185399 ifNotNil: [MCVersionDependency package: ver package info: ver info] 185400 ]) 185401 ] displayingProgress: 'downloading new versions'. 185402 185403 self dependencies: newDeps. 185404! ! 185405 185406 185407!MCConfiguration methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! 185408depsSatisfying: selectBlock versionDo: verBlock displayingProgress: progressString 185409 | repoMap count | 185410 repoMap := Dictionary new. 185411 self repositories do: [:repo | 185412 MCRepositoryGroup default addRepository: repo. 185413 repo allVersionNames 185414 ifEmpty: [self logWarning: 'cannot read from ', repo description] 185415 ifNotEmptyDo: [:all | all do: [:ver | repoMap at: ver put: repo]]]. 185416 185417 count := 0. 185418 self dependencies do: [:dep | 185419 | ver repo | 185420 ver := dep versionInfo name. 185421 repo := repoMap at: ver ifAbsent: [ 185422 self logError: 'Version ', ver, ' not found in any repository'. 185423 self logError: 'Aborting'. 185424 ^count]. 185425 (selectBlock value: dep) ifTrue: [ 185426 | new | 185427 new := self versionNamed: ver for: dep from: repo. 185428 new ifNil: [ 185429 self logError: 'Could not download version ', ver, ' from ', repo description. 185430 self logError: 'Aborting'. 185431 ^count] 185432 ifNotNil: [ 185433 self logUpdate: dep package with: new. 185434 ProgressNotification signal: '' extra: 'Installing ', ver. 185435 verBlock value: new. 185436 count := count + 1. 185437 ] 185438 ]. 185439 dep package workingCopy repositoryGroup addRepository: repo. 185440 ] displayingProgress: progressString. 185441 185442 ^count! ! 185443 185444!MCConfiguration methodsFor: 'private' stamp: 'bf 6/9/2005 11:26'! 185445diffBaseFor: aDependency 185446 | wc | 185447 aDependency package hasWorkingCopy ifFalse: [^nil]. 185448 wc := aDependency package workingCopy. 185449 wc ancestors ifEmpty: [^nil]. 185450 ^wc ancestors first name! ! 185451 185452!MCConfiguration methodsFor: 'private' stamp: 'bf 3/16/2006 19:07'! 185453loadVersions: aCollection 185454 185455 | loader | 185456 aCollection isEmpty ifTrue: [^0]. 185457 loader := MCVersionLoader new. 185458 aCollection do: [:each | loader addVersion: each]. 185459 loader loadWithNameLike: self nameForChangeset. 185460 ^ aCollection size! ! 185461 185462!MCConfiguration methodsFor: 'private' stamp: 'bf 6/9/2005 16:07'! 185463logError: aString 185464 self log 185465 cr; nextPutAll: 'ERROR: '; 185466 nextPutAll: aString; cr; 185467 flush. 185468! ! 185469 185470!MCConfiguration methodsFor: 'private' stamp: 'bf 6/9/2005 15:59'! 185471logUpdate: aPackage with: aVersion 185472 self log 185473 cr; nextPutAll: '========== ', aVersion info name, ' =========='; cr; 185474 cr; nextPutAll: aVersion info message asString; cr; 185475 flush. 185476 185477 aPackage hasWorkingCopy ifFalse: [^self]. 185478 185479 aPackage workingCopy ancestors do: [:each | 185480 (aVersion info hasAncestor: each) 185481 ifTrue: [(aVersion info allAncestorsOnPathTo: each) 185482 do: [:ver | self log cr; nextPutAll: '>>> ', ver name, ' <<<'; cr; 185483 nextPutAll: ver message; cr; flush]]]! ! 185484 185485!MCConfiguration methodsFor: 'private' stamp: 'bf 6/9/2005 16:08'! 185486logWarning: aString 185487 self log 185488 cr; nextPutAll: 'WARNING: '; 185489 nextPutAll: aString; cr; 185490 flush. 185491! ! 185492 185493!MCConfiguration methodsFor: 'private' stamp: 'bf 3/16/2006 19:07'! 185494mergeVersions: aCollection 185495 185496 | merger | 185497 aCollection isEmpty ifTrue: [^0]. 185498 merger := MCVersionMerger new. 185499 aCollection do: [:each | merger addVersion: each]. 185500 merger mergeWithNameLike: self nameForChangeset. 185501 ^ aCollection size! ! 185502 185503!MCConfiguration methodsFor: 'private' stamp: 'bf 3/20/2006 19:10'! 185504mergeVersionsSilently: aCollection 185505 185506 ^self suppressMergeDialogWhile: [self mergeVersions: aCollection]! ! 185507 185508!MCConfiguration methodsFor: 'private' stamp: 'bf 5/23/2005 14:47'! 185509mustMerge: aVersion 185510 "answer true if we have to do a full merge and false if we can simply load instead" 185511 185512 | pkg wc current | 185513 (pkg := aVersion package) hasWorkingCopy ifFalse: [^false "no wc -> load"]. 185514 (wc := pkg workingCopy) modified ifTrue: [^true "modified -> merge"]. 185515 wc ancestors isEmpty ifTrue: [^true "no ancestor info -> merge"]. 185516 current := wc ancestors first. 185517 (aVersion info hasAncestor: current) ifTrue: [^false "direct descendant of wc -> load"]. 185518 "new branch -> merge" 185519 ^true! ! 185520 185521!MCConfiguration methodsFor: 'private' stamp: 'bf 3/16/2006 19:07'! 185522nameForChangeset 185523 ^self name ifNil: [self class name]! ! 185524 185525!MCConfiguration methodsFor: 'private' stamp: 'bf 3/20/2006 19:09'! 185526suppressMergeDialogWhile: aBlock 185527 ^[aBlock value] 185528 on: MCMergeResolutionRequest 185529 do: [:request | 185530 request merger conflicts isEmpty 185531 ifTrue: [request resume: true] 185532 ifFalse: [request pass]]! ! 185533 185534!MCConfiguration methodsFor: 'private' stamp: 'md 9/18/2005 15:56'! 185535versionNamed: verName for: aDependency from: repo 185536 185537 | baseName fileName ver | 185538 (repo filterFileNames: repo cachedFileNames forVersionNamed: verName) ifNotEmptyDo: [:cachedNames | 185539 fileName := cachedNames anyOne. 185540 ProgressNotification signal: '' extra: 'Using cached ', fileName. 185541 ver := repo versionFromFileNamed: fileName]. 185542 ver ifNil: [ 185543 baseName := self diffBaseFor: aDependency. 185544 (baseName notNil and: [baseName ~= verName and: [repo includesVersionNamed: baseName]]) ifTrue: [ 185545 fileName := (MCDiffyVersion nameForVer: verName base: baseName), '.mcd'. 185546 ProgressNotification signal: '' extra: 'Downloading ', fileName. 185547 ver := repo versionFromFileNamed: fileName]]. 185548 ver ifNil: [ 185549 fileName := verName, '.mcz'. 185550 ProgressNotification signal: '' extra: 'Downloading ', fileName. 185551 ver := repo versionFromFileNamed: fileName]. 185552 ^ver! ! 185553 185554"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 185555 185556MCConfiguration class 185557 instanceVariableNames: ''! 185558 185559!MCConfiguration class methodsFor: 'accessing' stamp: 'ar 5/27/2005 17:27'! 185560defaultLog 185561 "Answer the default configuration log" 185562 ^DefaultLog! ! 185563 185564!MCConfiguration class methodsFor: 'accessing' stamp: 'ar 5/27/2005 17:27'! 185565defaultLog: aStream 185566 "Set the default configuration log" 185567 DefaultLog := aStream.! ! 185568 185569 185570!MCConfiguration class methodsFor: 'converting' stamp: 'bf 3/24/2005 01:43'! 185571dependencyFromArray: anArray 185572 ^MCVersionDependency 185573 package: (MCPackage named: anArray first) 185574 info: ( 185575 MCVersionInfo 185576 name: anArray second 185577 id: (UUID fromString: anArray third) 185578 message: nil 185579 date: nil 185580 time: nil 185581 author: nil 185582 ancestors: nil)! ! 185583 185584!MCConfiguration class methodsFor: 'converting' stamp: 'bf 3/24/2005 01:44'! 185585dependencyToArray: aDependency 185586 ^ { 185587 aDependency package name . 185588 aDependency versionInfo name . 185589 aDependency versionInfo id asString }! ! 185590 185591!MCConfiguration class methodsFor: 'converting' stamp: 'bf 6/9/2005 14:25'! 185592repositoryFromArray: anArray 185593 ^ MCRepositoryGroup default repositories 185594 detect: [:repo | repo description = anArray first] 185595 ifNone: [ 185596 MCHttpRepository 185597 location: anArray first 185598 user: '' 185599 password: '']! ! 185600 185601!MCConfiguration class methodsFor: 'converting' stamp: 'bf 3/24/2005 01:51'! 185602repositoryToArray: aRepository 185603 ^ {aRepository description}! ! 185604 185605 185606!MCConfiguration class methodsFor: 'initialization' stamp: 'bf 4/20/2005 17:20'! 185607initialize 185608 "MCConfiguration initialize" 185609 185610 Preferences addPreference: #upgradeIsMerge 185611 categories: #('updates') default: false 185612 balloonHelp: 'When upgrading packages, use merge instead of load'.! ! 185613 185614 185615!MCConfiguration class methodsFor: 'instance creation' stamp: 'bf 3/24/2005 01:51'! 185616fromArray: anArray 185617 | configuration | 185618 configuration := self new. 185619 anArray pairsDo: [:key :value | 185620 key = #repository 185621 ifTrue: [configuration repositories add: (self repositoryFromArray: value)]. 185622 key = #dependency 185623 ifTrue: [configuration dependencies add: (self dependencyFromArray: value)]. 185624 ]. 185625 ^configuration! ! 185626 185627 185628!MCConfiguration class methodsFor: 'utilities' stamp: 'bf 9/6/2006 19:39'! 185629changesIn: aPackage from: oldInfo to: newInfo on: aStream 185630 | printBlock newVersion | 185631 (newInfo = oldInfo) 185632 ifTrue: [^self]. 185633 aStream cr; nextPutAll: '----------------- ', aPackage name, ' ------------------'; cr. 185634 185635 newInfo 185636 ifNil: [^aStream cr; nextPutAll: 'REMOVED'; cr]. 185637 185638 oldInfo 185639 ifNil: [^aStream cr; nextPutAll: 'ADDED'; cr]. 185640 185641 "get actual version for full ancestry" 185642 newVersion := MCRepositoryGroup default versionWithInfo: newInfo. 185643 185644 printBlock := [:ver | 185645 aStream cr; 185646 nextPutAll: (ver name copyAfterLast: $-); 185647 nextPutAll: ' (', (ver date printFormat: #(1 2 0 $. 1 1 2)), ', '. 185648 ver time print24: true showSeconds: false on: aStream. 185649 aStream nextPutAll: ')'; cr; 185650 nextPutAll: ver message; cr]. 185651 185652 (newVersion info hasAncestor: oldInfo) 185653 ifTrue: [(newVersion info allAncestorsOnPathTo: oldInfo) 185654 reverseDo: printBlock]. 185655 newVersion info in: printBlock. 185656 aStream flush! ! 185657 185658!MCConfiguration class methodsFor: 'utilities' stamp: 'bf 6/13/2006 15:46'! 185659whatChangedFrom: oldConfig to: newConfig 185660 "MCConfiguration 185661 whatChangedFrom: ReleaseBuilderPloppDeveloper config20060201PloppBeta 185662 to: ReleaseBuilderPloppDeveloper config20060215premaster" 185663 185664 self whatChangedFrom: oldConfig to: newConfig on: Transcript. 185665 Transcript flush.! ! 185666 185667!MCConfiguration class methodsFor: 'utilities' stamp: 'bf 6/13/2006 15:47'! 185668whatChangedFrom: oldConfig to: newConfig on: aStream 185669 "MCConfiguration 185670 whatChangedFrom: ReleaseBuilderPloppDeveloper config20060201PloppBeta 185671 to: ReleaseBuilderPloppDeveloper config20060215premaster" 185672 185673 | oldDeps | 185674 oldDeps := Dictionary new. 185675 oldConfig dependencies do: [:old | oldDeps at: old package put: old]. 185676 185677 newConfig dependencies do: [:new | | old | 185678 old := oldDeps removeKey: new package ifAbsent: [nil]. 185679 old ifNotNil: [old := old versionInfo]. 185680 self changesIn: new package from: old to: new versionInfo on: aStream. 185681 ]. 185682 185683 oldDeps do: [:old | 185684 self changesIn: old package from: old versionInfo to: nil on: aStream. 185685 ]. 185686! ! 185687MCTool subclass: #MCConfigurationBrowser 185688 instanceVariableNames: 'configuration dependencyIndex repositoryIndex' 185689 classVariableNames: '' 185690 poolDictionaries: '' 185691 category: 'MonticelloGUI'! 185692 185693!MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/21/2005 16:03'! 185694configuration 185695 ^configuration ifNil: [configuration := MCConfiguration new]! ! 185696 185697!MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/21/2005 14:56'! 185698configuration: aConfiguration 185699 configuration := aConfiguration! ! 185700 185701!MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/21/2005 16:35'! 185702dependencies 185703 ^self configuration dependencies 185704! ! 185705 185706!MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 4/19/2005 16:02'! 185707dependencies: aCollection 185708 self configuration dependencies: aCollection. 185709 self changed: #dependencyList; changed: #description 185710! ! 185711 185712!MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/23/2005 17:41'! 185713repositories 185714 ^ self configuration repositories! ! 185715 185716!MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/23/2005 21:15'! 185717repositories: aCollection 185718 ^self configuration repositories: aCollection 185719! ! 185720 185721 185722!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 3/23/2005 22:08'! 185723add 185724 (self pickWorkingCopiesSatisfying: [:each | (self includesPackage: each package) not]) 185725 do: [:wc | 185726 wc ancestors isEmpty 185727 ifTrue: [self inform: 'You must save ', wc packageName, ' first!! 185728Skipping this package'] 185729 ifFalse: [ 185730 self dependencies add: (MCVersionDependency 185731 package: wc package 185732 info: wc ancestors first)]]. 185733 self changed: #dependencyList; changed: #description! ! 185734 185735!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 3/23/2005 21:01'! 185736down 185737 self canMoveDown ifTrue: [ 185738 self list swap: self index with: self index + 1. 185739 self index: self index + 1. 185740 self changedList. 185741 ]. 185742! ! 185743 185744!MCConfigurationBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! 185745installMenu 185746 185747 | menu | 185748 menu := MenuMorph new defaultTarget: self. 185749 menu add: 'load packages' action: #load. 185750 menu add: 'merge packages' action: #merge. 185751 menu add: 'upgrade packages' action: #upgrade. 185752 menu popUpInWorld.! ! 185753 185754!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 4/19/2005 17:42'! 185755load 185756 self configuration load. 185757 self changed: #dependencyList; changed: #description 185758! ! 185759 185760!MCConfigurationBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! 185761loadMenu 185762 185763 | menu | 185764 menu := MenuMorph new defaultTarget: self. 185765 menu add: 'update from image' action: #updateFromImage. 185766 menu add: 'update from repositories' action: #updateFromRepositories. 185767 menu popUpInWorld. 185768! ! 185769 185770!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 4/19/2005 17:42'! 185771merge 185772 self configuration merge. 185773 self changed: #dependencyList; changed: #description 185774! ! 185775 185776!MCConfigurationBrowser methodsFor: 'actions' stamp: 'jl 10/26/2006 17:50'! 185777migrate 185778 "copy all packageversions in this cofiguration to a repository" 185779 | versions | 185780 versions := OrderedCollection new. 185781 185782 configuration depsSatisfying: [:dep | dep isFulfilledByAncestors not] 185783 versionDo: [:ver | versions add: ver] 185784 displayingProgress: 'finding packages'. 185785 185786 self pickRepository ifNotNilDo: [:aRepository | 185787 versions do: [:eachVersion | 185788 Transcript cr; show: '',aRepository,' storeVersion: ', eachVersion. 185789 aRepository storeVersion: eachVersion 185790 ] 185791 ] 185792! ! 185793 185794!MCConfigurationBrowser methodsFor: 'actions' stamp: 'DamienCassou 9/29/2009 13:00'! 185795post 185796 "Take the current configuration and post an update" 185797 | name update managers names choice | 185798 (self checkRepositories and: [self checkDependencies]) ifFalse: [^self]. 185799 name := UIManager default 185800 request: 'Update name (.cs) will be appended):' translated 185801 initialAnswer: (self configuration name ifNil: ['']). 185802 name isEmptyOrNil ifTrue:[^self]. 185803 self configuration name: name. 185804 update := MCPseudoFileStream on: (String new: 100). 185805 update localName: name, '.cs'. 185806 update nextPutAll: '"Change Set: ', name. 185807 update cr; nextPutAll: 'Date: ', Date today printString. 185808 update cr; nextPutAll: 'Author: Posted by Monticello'. 185809 update cr; cr; nextPutAll: 'This is a configuration map created by Monticello."'. 185810 185811 update cr; cr; nextPutAll: '(MCConfiguration fromArray: #'. 185812 self configuration fileOutOn: update. 185813 update nextPutAll: ') upgrade.'. 185814 update position: 0. 185815 185816 managers := Smalltalk at: #UpdateManager ifPresent:[:mgr| mgr allRegisteredManagers]. 185817 managers ifNil:[managers := #()]. 185818 managers size > 0 ifTrue:[ 185819 | servers index | 185820 servers := ServerDirectory groupNames asSortedArray. 185821 names := (managers collect:[:each| each packageVersion]), servers. 185822 index := UIManager default chooseFrom: names lines: {managers size}. 185823 index = 0 ifTrue:[^self]. 185824 index <= managers size ifTrue:[ 185825 | mgr | 185826 mgr := managers at: index. 185827 ^mgr publishUpdate: update. 185828 ]. 185829 choice := names at: index. 185830 ] ifFalse:[ 185831 names := ServerDirectory groupNames asSortedArray. 185832 choice := UIManager default chooseFrom: names values: names. 185833 choice ifNil: [^ self]. 185834 ]. 185835 (ServerDirectory serverInGroupNamed: choice) putUpdate: update.! ! 185836 185837!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 3/23/2005 21:05'! 185838remove 185839 self canRemove ifTrue: [ 185840 self list removeAt: self index. 185841 self changedList. 185842 self updateIndex. 185843 ]. 185844! ! 185845 185846!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 9/6/2006 19:40'! 185847showChangeLog 185848 self pickConfig ifNotNilDo: [:oldConfig | 185849 Transcript dependents isEmpty 185850 ifTrue: [Transcript open] 185851 ifFalse: [Transcript dependents do: [:ea | 185852 ea isSystemWindow ifTrue: [ea activate]]]. 185853 Cursor wait showWhile: [ 185854 MCConfiguration whatChangedFrom: oldConfig to: configuration on: Transcript. 185855 Transcript flush]]! ! 185856 185857!MCConfigurationBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! 185858store 185859 (self checkRepositories and: [self checkDependencies]) ifFalse: [^self]. 185860 self pickName ifNotNil: [:name | 185861 self configuration name: name. 185862 self pickRepository ifNotNil: [:repo | 185863 repo storeVersion: self configuration]].! ! 185864 185865!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 3/23/2005 20:53'! 185866up 185867 self canMoveUp ifTrue: [ 185868 self list swap: self index with: self index - 1. 185869 self index: self index - 1. 185870 self changedList. 185871 ].! ! 185872 185873!MCConfigurationBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! 185874updateMenu 185875 185876 | menu | 185877 menu := MenuMorph new defaultTarget: self. 185878 menu add: 'update from image' action: #updateFromImage. 185879 menu add: 'update from repositories' action: #updateFromRepositories. 185880 menu popUpInWorld.! ! 185881 185882!MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 4/19/2005 17:43'! 185883upgrade 185884 self configuration upgrade. 185885 self changed: #dependencyList; changed: #description 185886! ! 185887 185888 185889!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 3/23/2005 22:08'! 185890addDependency 185891 (self pickWorkingCopiesSatisfying: [:each | (self includesPackage: each package) not]) 185892 do: [:wc | 185893 wc ancestors isEmpty 185894 ifTrue: [self inform: 'You must save ', wc packageName, ' first!! 185895Skipping this package'] 185896 ifFalse: [ 185897 self dependencies add: (MCVersionDependency 185898 package: wc package 185899 info: wc ancestors first)]]. 185900 self changed: #dependencyList; changed: #description! ! 185901 185902!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 4/19/2005 17:36'! 185903checkDependencies 185904 ^self checkModified and: [self checkMissing]! ! 185905 185906!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 4/19/2005 17:35'! 185907checkMissing 185908 | missing | 185909 missing := (self dependencies collect: [:ea | ea versionInfo name]) asSet. 185910 185911 self repositories 185912 do: [:repo | 185913 repo allVersionNames 185914 do: [:found | missing remove: found ifAbsent: []]] 185915 displayingProgress: 'searching versions'. 185916 185917 ^missing isEmpty or: [ 185918 self selectDependency: missing anyOne. 185919 self confirm: (String streamContents: [:strm | 185920 strm nextPutAll: 'No repository found for'; cr. 185921 missing do: [:r | strm nextPutAll: r; cr]. 185922 strm nextPutAll: 'Do you still want to store?'])] 185923 ! ! 185924 185925!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 4/19/2005 17:37'! 185926checkModified 185927 | modified | 185928 modified := self dependencies select: [:dep | 185929 dep isFulfilled and: [dep package workingCopy modified]]. 185930 185931 ^modified isEmpty or: [ 185932 self selectDependency: modified anyOne. 185933 self confirm: (String streamContents: [:strm | 185934 strm nextPutAll: 'These packages are modified:'; cr. 185935 modified do: [:dep | strm nextPutAll: dep package name; cr]. 185936 strm nextPutAll: 'Do you still want to store?'])] 185937 ! ! 185938 185939!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 1/10/2006 17:58'! 185940dependencyList 185941 ^self dependencies collect: [:dep | 185942 Text string: (dep isCurrent 185943 ifTrue: [dep versionInfo name] 185944 ifFalse: [':: ', dep versionInfo name]) 185945 attributes: (Array streamContents: [:attr | 185946 dep isFulfilledByAncestors 185947 ifFalse: [attr nextPut: TextEmphasis bold] 185948 ifTrue: [dep isCurrent ifFalse: [attr nextPut: TextEmphasis italic]]. 185949 ])] 185950! ! 185951 185952!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 3/23/2005 17:56'! 185953selectedDependency 185954 ^ self dependencies at: self dependencyIndex ifAbsent: []! ! 185955 185956!MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'marcus.denker 11/10/2008 10:04'! 185957selectedPackage 185958 ^ self selectedDependency ifNotNil: [:dep | dep package]! ! 185959 185960 185961!MCConfigurationBrowser methodsFor: 'description' stamp: 'marcus.denker 11/10/2008 10:04'! 185962description 185963 self selectedDependency ifNotNil: [:dep | ^ ('Package: ', dep package name, String cr, 185964 dep versionInfo summary) asText]. 185965 self selectedRepository ifNotNil: [:repo | ^repo creationTemplate 185966 ifNotNil: [repo creationTemplate asText] 185967 ifNil: [repo asCreationTemplate asText addAttribute: TextColor red]]. 185968 ^ '' 185969! ! 185970 185971!MCConfigurationBrowser methodsFor: 'description' stamp: 'marcus.denker 11/10/2008 10:04'! 185972description: aText 185973 185974 self selectedRepository ifNotNil: [:repo | 185975 | new | 185976 new := MCRepository readFrom: aText asString. 185977 (new class = repo class 185978 and: [new description = repo description]) 185979 ifTrue: [ 185980 repo creationTemplate: aText asString. 185981 self changed: #description] 185982 ifFalse: [ 185983 self inform: 'This does not match the previous definition!!' 185984 ] 185985 ]. 185986 185987! ! 185988 185989 185990!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'jl 10/26/2006 17:42'! 185991buttonSpecs 185992 ^ #(('Add' addDependency 'Add a dependency') 185993 ('Update' updateMenu 'Update dependencies') 185994 ('Install' installMenu 'Load/Merge/Upgrade into image') 185995 ('Up' up 'Move item up in list' canMoveUp) 185996 ('Down' down 'Move item down in list' canMoveDown) 185997 ('Remove' remove 'Remove item' canRemove) 185998 ('Migrate' migrate 'Migrate all packages to a repository') 185999 ('Store' store 'store configuration') 186000 ('Post' post 'Post this configuration to an update stream') 186001 )! ! 186002 186003!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 4/19/2005 16:51'! 186004defaultExtent 186005 ^ 350@500! ! 186006 186007!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 9/6/2006 17:59'! 186008dependencyMenu: aMenu 186009 self fillMenu: aMenu fromSpecs: #(('change log...' showChangeLog)). 186010 self fillMenu: aMenu fromSpecs: #(('add dependency...' addDependency)). 186011 self selectedDependency ifNotNil: [ 186012 self fillMenu: aMenu fromSpecs: #(('remove dependency...' remove))]. 186013 ^aMenu 186014! ! 186015 186016!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'alain.plantec 2/10/2009 18:09'! 186017pickConfig 186018 self pickRepository ifNotNilDo: [:repo | 186019 | configs index | 186020 configs := Cursor wait showWhile: [ 186021 repo allFileNames 186022 select: [:ea | MCMcmReader canReadFileNamed: ea] 186023 thenCollect: [:ea | ea copyUpToLast: $.]]. 186024 configs isEmpty ifTrue: [^self inform: 'no configs found in ', repo description]. 186025 configs := configs asSortedCollection: [:a :b | 186026 (a copyAfterLast: $.) asNumber > (b copyAfterLast: $.) asNumber]. 186027 index := UIManager default chooseFrom: configs title: 'config:' translated. 186028 index = 0 ifFalse: [^Cursor wait showWhile: [ 186029 repo versionFromFileNamed: (configs at: index), '.', MCMcmReader extension]]]. 186030 ^nil! ! 186031 186032!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'DamienCassou 9/29/2009 13:00'! 186033pickName 186034 | name | 186035 name := UIManager default 186036 request: ('Name' translated, ' (.', self configuration writerClass extension, ' will be appended' translated, '):') 186037 initialAnswer: (self configuration name ifNil: ['']). 186038 ^ name isEmptyOrNil ifFalse: [name]! ! 186039 186040!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 3/23/2005 21:11'! 186041pickRepository 186042 ^self pickRepositorySatisfying: [:ea | true] 186043! ! 186044 186045!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'alain.plantec 2/6/2009 11:06'! 186046pickRepositorySatisfying: aBlock 186047 | index list | 186048 list := MCRepositoryGroup default repositories select: aBlock. 186049 index := (UIManager default chooseFrom: (list collect: [:ea | ea description]) title: 'Repository:' translated). 186050 ^ index = 0 ifFalse: [list at: index]! ! 186051 186052!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'michael.rueger 3/9/2009 19:53'! 186053pickWorkingCopiesSatisfying: aBlock 186054 | copies item | 186055 copies := (MCWorkingCopy allManagers select: aBlock) 186056 asSortedCollection: [:a :b | a packageName <= b packageName]. 186057 item := UIManager default 186058 chooseFrom: ({'match ...' translated} , (copies 186059 collect: [:ea | ea packageName])) 186060 lines: #(1 ) 186061 title: 'Package:' translated. 186062 item = 1 186063 ifTrue: [| pattern | 186064 pattern := UIManager default request: 'Packages matching:' translated initialAnswer: '*'. 186065 ^ pattern isEmptyOrNil 186066 ifTrue: [#()] 186067 ifFalse: [(pattern includes: $*) 186068 ifFalse: [pattern := '*' , pattern , '*']. 186069 copies 186070 select: [:ea | pattern match: ea packageName]]]. 186071 ^ item = 0 186072 ifTrue: [#()] 186073 ifFalse: [{copies at: item - 1}]! ! 186074 186075!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 3/23/2005 21:27'! 186076repositoryMenu: aMenu 186077 ^self fillMenu: aMenu fromSpecs: #( 186078 ('add repository...' addRepository) 186079 )! ! 186080 186081!MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 3/23/2005 22:01'! 186082widgetSpecs 186083 ^ #( 186084 ((buttonRow) (0 0 1 0) (0 0 0 30)) 186085 ((listMorph:selection:menu: dependencyList dependencyIndex dependencyMenu:) (0 0 1 1) (0 30 0 -180)) 186086 ((listMorph:selection:menu: repositoryList repositoryIndex repositoryMenu:) (0 1 1 1) (0 -180 0 -120)) 186087 ((textMorph: description) (0 1 1 1) (0 -120 0 0)) 186088 )! ! 186089 186090 186091!MCConfigurationBrowser methodsFor: 'repositories' stamp: 'marcus.denker 11/10/2008 10:04'! 186092addRepository 186093 (self pickRepositorySatisfying: [:ea | (self repositories includes: ea) not]) 186094 ifNotNil: [:repo | 186095 (repo isKindOf: MCHttpRepository) 186096 ifFalse: [^self inform: 'Only HTTP repositories are supported']. 186097 self repositories add: repo. 186098 self changed: #repositoryList. 186099 ]! ! 186100 186101!MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/24/2005 00:45'! 186102checkRepositories 186103 | bad | 186104 bad := self repositories reject: [:repo | repo isKindOf: MCHttpRepository]. 186105 ^bad isEmpty or: [ 186106 self selectRepository: bad first. 186107 self inform: (String streamContents: [:strm | 186108 strm nextPutAll: 'Please remove these repositories:'; cr. 186109 bad do: [:r | strm nextPutAll: r description; cr]. 186110 strm nextPutAll: '(only HTTP repositories are supported)']). 186111 false]. 186112! ! 186113 186114!MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/24/2005 00:47'! 186115checkRepositoryTemplates 186116 "unused for now - we only do HTTP" 186117 | bad | 186118 bad := self repositories select: [:repo | repo creationTemplate isNil]. 186119 ^bad isEmpty or: [ 186120 self selectRepository: bad first. 186121 self inform: (String streamContents: [:strm | 186122 strm nextPutAll: 'Creation template missing for'; cr. 186123 bad do: [:r | strm nextPutAll: r description; cr]. 186124 strm nextPutAll: 'Please fill in the details first!!']). 186125 false]. 186126! ! 186127 186128!MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/23/2005 21:15'! 186129repositoryList 186130 ^self repositories collect: [:ea | ea description] 186131! ! 186132 186133!MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/23/2005 17:58'! 186134selectedRepository 186135 ^ self repositories at: self repositoryIndex ifAbsent: []! ! 186136 186137 186138!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 5/27/2005 19:54'! 186139changedButtons 186140 self changed: #canMoveDown. 186141 self changed: #canMoveUp. 186142 self changed: #canRemove.! ! 186143 186144!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 20:55'! 186145changedList 186146 self dependencyIndex > 0 ifTrue: [^self changed: #dependencyList]. 186147 self repositoryIndex > 0 ifTrue: [^self changed: #repositoryList]. 186148 self error: 'nothing selected'! ! 186149 186150!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 17:56'! 186151dependencyIndex 186152 ^dependencyIndex ifNil: [0]! ! 186153 186154!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 5/27/2005 19:55'! 186155dependencyIndex: anInteger 186156 dependencyIndex := anInteger. 186157 dependencyIndex > 0 186158 ifTrue: [self repositoryIndex: 0]. 186159 self changed: #dependencyIndex; changed: #description. 186160 self changedButtons.! ! 186161 186162!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 20:43'! 186163index 186164 ^self dependencyIndex max: self repositoryIndex! ! 186165 186166!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 21:00'! 186167index: anInteger 186168 self dependencyIndex > 0 ifTrue: [^self dependencyIndex: anInteger]. 186169 self repositoryIndex > 0 ifTrue: [^self repositoryIndex: anInteger]. 186170 anInteger > 0 ifTrue: [self error: 'cannot select']! ! 186171 186172!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 20:51'! 186173list 186174 self dependencyIndex > 0 ifTrue: [^self dependencies]. 186175 self repositoryIndex > 0 ifTrue: [^self repositories]. 186176 ^#()! ! 186177 186178!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 20:52'! 186179maxIndex 186180 ^ self list size! ! 186181 186182!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 17:57'! 186183repositoryIndex 186184 ^repositoryIndex ifNil: [0]! ! 186185 186186!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 5/27/2005 19:55'! 186187repositoryIndex: anInteger 186188 repositoryIndex := anInteger. 186189 repositoryIndex > 0 186190 ifTrue: [self dependencyIndex: 0]. 186191 self changed: #repositoryIndex; changed: #description. 186192 self changedButtons.! ! 186193 186194!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 23:16'! 186195selectDependency: aDependency 186196 self dependencyIndex: (self dependencies indexOf: aDependency)! ! 186197 186198!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 23:15'! 186199selectRepository: aRepository 186200 self repositoryIndex: (self repositories indexOf: aRepository)! ! 186201 186202!MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 21:00'! 186203updateIndex 186204 self index > 0 ifTrue: [self index: (self index min: self maxIndex)]! ! 186205 186206 186207!MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/23/2005 20:44'! 186208canMoveDown 186209 ^self index between: 1 and: self maxIndex - 1 ! ! 186210 186211!MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/23/2005 20:44'! 186212canMoveUp 186213 ^self index > 1! ! 186214 186215!MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/23/2005 20:45'! 186216canRemove 186217 ^self index > 0! ! 186218 186219!MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/21/2005 17:15'! 186220includesPackage: aPackage 186221 ^self dependencies anySatisfy: [:each | each package = aPackage]! ! 186222 186223 186224!MCConfigurationBrowser methodsFor: 'updating' stamp: 'bf 5/23/2005 17:44'! 186225updateFromImage 186226 self configuration updateFromImage. 186227 self changed: #dependencyList; changed: #description 186228! ! 186229 186230!MCConfigurationBrowser methodsFor: 'updating' stamp: 'bf 5/23/2005 17:44'! 186231updateFromRepositories 186232 self configuration updateFromRepositories. 186233 self changed: #dependencyList; changed: #description 186234! ! 186235 186236"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 186237 186238MCConfigurationBrowser class 186239 instanceVariableNames: ''! 186240 186241!MCConfigurationBrowser class methodsFor: 'initialization' stamp: 'bf 3/21/2005 19:46'! 186242initialize 186243 TheWorldMenu registerOpenCommand: { 'Monticello Configurations' . { self . #open }. 'Monticello Configuration Browser' }.! ! 186244 186245 186246!MCConfigurationBrowser class methodsFor: 'opening' stamp: 'bf 3/21/2005 19:50'! 186247open 186248 ^self new show! ! 186249Object subclass: #MCConflict 186250 instanceVariableNames: 'operation chooseRemote' 186251 classVariableNames: '' 186252 poolDictionaries: '' 186253 category: 'Monticello-Merging'! 186254 186255!MCConflict methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 4/2/2009 13:22'! 186256diff 186257 "Do a diff of the operation." 186258 186259 self operation diff! ! 186260 186261!MCConflict methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 10/30/2006 11:27'! 186262patchWrapper 186263 "Answer a wrapper for a patch tree for the receiver." 186264 186265 ^PSMCConflictWrapper with: self! ! 186266 186267!MCConflict methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 4/1/2009 13:59'! 186268shortSummary 186269 "Answer the short summary of the operation." 186270 186271 ^self operation shortSummary! ! 186272 186273!MCConflict methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 10/30/2006 11:30'! 186274targetClassName 186275 "Answer the class name of the target since the class may no longer exist." 186276 186277 ^operation targetClassName! ! 186278 186279 186280!MCConflict methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 186281annotations 186282 ^operation ifNotNil: [ :op | op annotations ]! ! 186283 186284!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 13:04'! 186285applyTo: anObject 186286 self isResolved ifFalse: [self error: 'Cannot continue until this conflict has been resolved']. 186287 self remoteChosen ifTrue: [operation applyTo: anObject].! ! 186288 186289!MCConflict methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186290chooseLocal 186291 chooseRemote := false! ! 186292 186293!MCConflict methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:16'! 186294chooseNewer 186295 self isLocalNewer ifTrue: [ self chooseLocal ] 186296 ifFalse: [ self isRemoteNewer ifTrue: [ self chooseRemote ]]! ! 186297 186298!MCConflict methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:22'! 186299chooseOlder 186300 self isRemoteNewer ifTrue: [ self chooseLocal ] 186301 ifFalse: [ self isLocalNewer ifTrue: [ self chooseRemote ]]! ! 186302 186303!MCConflict methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186304chooseRemote 186305 chooseRemote := true! ! 186306 186307!MCConflict methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186308clearChoice 186309 chooseRemote := nil! ! 186310 186311!MCConflict methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 186312definition 186313 ^operation ifNotNil: [ :op | op definition ]! ! 186314 186315!MCConflict methodsFor: 'as yet unclassified' stamp: 'dvf 8/10/2004 23:24'! 186316isConflict 186317 ^true! ! 186318 186319!MCConflict methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:11'! 186320isLocalNewer 186321 ^ self localDefinition fullTimeStamp > self remoteDefinition fullTimeStamp! ! 186322 186323!MCConflict methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:15'! 186324isRemoteNewer 186325 ^ self localDefinition fullTimeStamp < self remoteDefinition fullTimeStamp! ! 186326 186327!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 13:02'! 186328isResolved 186329 ^ chooseRemote notNil! ! 186330 186331!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:45'! 186332localChosen 186333 ^ chooseRemote notNil and: [chooseRemote not]! ! 186334 186335!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 13:10'! 186336localDefinition 186337 ^ operation baseDefinition! ! 186338 186339!MCConflict methodsFor: 'as yet unclassified' stamp: 'avi 9/19/2005 02:19'! 186340operation 186341 ^ operation! ! 186342 186343!MCConflict methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186344operation: anOperation 186345 operation := anOperation! ! 186346 186347!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:45'! 186348remoteChosen 186349 ^ chooseRemote notNil and: [chooseRemote]! ! 186350 186351!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 13:10'! 186352remoteDefinition 186353 ^ operation targetDefinition! ! 186354 186355!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 16:47'! 186356source 186357 ^ self localChosen 186358 ifTrue: [operation fromSource] 186359 ifFalse: [operation source]! ! 186360 186361!MCConflict methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 13:48'! 186362status 186363 ^ self isResolved 186364 ifFalse: [''] 186365 ifTrue: [self remoteChosen 186366 ifFalse: ['L'] 186367 ifTrue: ['R']]! ! 186368 186369!MCConflict methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186370summary 186371 | attribute | 186372 attribute := 186373 self isResolved 186374 ifTrue: [self remoteChosen ifTrue: [#underlined] ifFalse: [#struckOut]] 186375 ifFalse: [#bold]. 186376 ^ Text string: operation summary attribute: (TextEmphasis perform: attribute)! ! 186377 186378"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 186379 186380MCConflict class 186381 instanceVariableNames: ''! 186382 186383!MCConflict class methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 13:07'! 186384operation: anOperation 186385 ^ self new operation: anOperation ! ! 186386Object subclass: #MCDefinition 186387 instanceVariableNames: '' 186388 classVariableNames: 'Instances' 186389 poolDictionaries: '' 186390 category: 'Monticello-Base'! 186391 186392!MCDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 12/12/2008 16:18'! 186393actualClass 186394 "Since the targetClass call on a patch operation will fail 186395 otherwise." 186396 186397 ^nil! ! 186398 186399!MCDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 4/1/2009 12:11'! 186400className 186401 "Answer the class name here or nil if not applicable." 186402 186403 ^nil! ! 186404 186405!MCDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 4/1/2009 12:14'! 186406fullClassName 186407 "Answer the className by default." 186408 186409 ^self className! ! 186410 186411 186412!MCDefinition methodsFor: 'accessing' stamp: 'ab 5/24/2003 14:12'! 186413provisions 186414 ^ #()! ! 186415 186416!MCDefinition methodsFor: 'accessing' stamp: 'ab 5/24/2003 14:12'! 186417requirements 186418 ^ #()! ! 186419 186420 186421!MCDefinition methodsFor: 'annotations' stamp: 'nk 7/24/2003 12:27'! 186422annotations 186423 ^self annotations: Preferences defaultAnnotationRequests! ! 186424 186425!MCDefinition methodsFor: 'annotations' stamp: 'nk 7/24/2003 12:26'! 186426annotations: requests 186427 "Answer a string for an annotation pane, trying to fulfill the annotation requests. 186428 These might include anything that 186429 Preferences defaultAnnotationRequests 186430 might return. Which includes anything in 186431 Preferences annotationInfo 186432 To edit these, use:" 186433 "Preferences editAnnotations" 186434 186435 ^String streamContents: [ :s | self printAnnotations: requests on: s ].! ! 186436 186437!MCDefinition methodsFor: 'annotations' stamp: 'nk 11/10/2003 21:46'! 186438printAnnotations: requests on: aStream 186439 "Add a string for an annotation pane, trying to fulfill the annotation requests. 186440 These might include anything that 186441 Preferences defaultAnnotationRequests 186442 might return. Which includes anything in 186443 Preferences annotationInfo 186444 To edit these, use:" 186445 "Preferences editAnnotations" 186446 186447 aStream nextPutAll: 'not yet implemented'! ! 186448 186449 186450!MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:14'! 186451description 186452 self subclassResponsibility! ! 186453 186454!MCDefinition methodsFor: 'comparing' stamp: 'nk 10/21/2003 23:18'! 186455fullTimeStamp 186456 ^TimeStamp current! ! 186457 186458!MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:14'! 186459hash 186460 ^ self description hash! ! 186461 186462!MCDefinition methodsFor: 'comparing' stamp: 'damiencassou 11/27/2008 18:15'! 186463isRevisionOf: aDefinition 186464 ^ (aDefinition isKindOf: MCDefinition) and: [aDefinition description = self description]! ! 186465 186466!MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:25'! 186467isSameRevisionAs: aDefinition 186468 ^ self = aDefinition! ! 186469 186470!MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:04'! 186471sortKey 186472 self subclassResponsibility ! ! 186473 186474!MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 17:59'! 186475<= other 186476 ^ self sortKey <= other sortKey! ! 186477 186478!MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:24'! 186479= aDefinition 186480 ^ self isRevisionOf: aDefinition! ! 186481 186482 186483!MCDefinition methodsFor: 'installing' stamp: 'rej 2/26/2007 18:45'! 186484addMethodAdditionTo: aCollection 186485 Transcript show: self printString. 186486 self load! ! 186487 186488!MCDefinition methodsFor: 'installing' stamp: 'ab 7/18/2003 21:31'! 186489load 186490 ! ! 186491 186492!MCDefinition methodsFor: 'installing' stamp: 'avi 2/17/2004 13:19'! 186493loadOver: aDefinition 186494 self load 186495 ! ! 186496 186497!MCDefinition methodsFor: 'installing' stamp: 'ab 7/18/2003 19:48'! 186498postload! ! 186499 186500!MCDefinition methodsFor: 'installing' stamp: 'avi 2/17/2004 13:19'! 186501postloadOver: aDefinition 186502 self postload! ! 186503 186504!MCDefinition methodsFor: 'installing' stamp: 'ab 11/14/2002 00:08'! 186505unload! ! 186506 186507 186508!MCDefinition methodsFor: 'printing' stamp: 'ab 7/18/2003 19:43'! 186509printOn: aStream 186510 super printOn: aStream. 186511 aStream nextPutAll: '(', self summary, ')'! ! 186512 186513!MCDefinition methodsFor: 'printing' stamp: 'ab 7/19/2003 18:23'! 186514summary 186515 self subclassResponsibility ! ! 186516 186517 186518!MCDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:51'! 186519isClassDefinition 186520 ^false! ! 186521 186522!MCDefinition methodsFor: 'testing' stamp: 'bf 11/12/2004 14:46'! 186523isClassDefinitionExtension 186524 "Answer true if this definition extends the regular class definition" 186525 ^false! ! 186526 186527!MCDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:51'! 186528isMethodDefinition 186529 ^false! ! 186530 186531!MCDefinition methodsFor: 'testing' stamp: 'cwp 7/11/2003 01:32'! 186532isOrganizationDefinition 186533 ^false! ! 186534 186535!MCDefinition methodsFor: 'testing' stamp: 'bf 8/12/2009 22:55'! 186536isScriptDefinition 186537 ^false! ! 186538 186539"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 186540 186541MCDefinition class 186542 instanceVariableNames: ''! 186543 186544!MCDefinition class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186545clearInstances 186546 WeakArray removeWeakDependent: Instances. 186547 Instances := nil! ! 186548 186549!MCDefinition class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186550instanceLike: aDefinition 186551 Instances ifNil: [Instances := WeakSet new]. 186552 ^ (Instances like: aDefinition) ifNil: [Instances add: aDefinition]! ! 186553Object subclass: #MCDefinitionIndex 186554 instanceVariableNames: 'definitions' 186555 classVariableNames: '' 186556 poolDictionaries: '' 186557 category: 'Monticello-Patching'! 186558 186559!MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:38'! 186560addAll: aCollection 186561 aCollection do: [:ea | self add: ea]! ! 186562 186563!MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:38'! 186564add: aDefinition 186565 definitions at: aDefinition description put: aDefinition! ! 186566 186567!MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186568definitionLike: aDefinition ifPresent: foundBlock ifAbsent: errorBlock 186569 | definition | 186570 definition := definitions at: aDefinition description ifAbsent: []. 186571 ^ definition 186572 ifNil: errorBlock 186573 ifNotNil: [foundBlock value: definition]! ! 186574 186575!MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:42'! 186576definitions 186577 ^ definitions values! ! 186578 186579!MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:02'! 186580initialize 186581 super initialize. 186582 definitions := Dictionary new! ! 186583 186584!MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:40'! 186585remove: aDefinition 186586 definitions removeKey: aDefinition description ifAbsent: []! ! 186587 186588"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 186589 186590MCDefinitionIndex class 186591 instanceVariableNames: ''! 186592 186593!MCDefinitionIndex class methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:29'! 186594definitions: aCollection 186595 ^ self new addAll: aCollection! ! 186596Object subclass: #MCDependencySorter 186597 instanceVariableNames: 'required provided orderedItems' 186598 classVariableNames: '' 186599 poolDictionaries: '' 186600 category: 'Monticello-Loading'! 186601 186602!MCDependencySorter methodsFor: 'accessing' stamp: 'dvf 9/8/2004 00:49'! 186603externalRequirements 186604 | unloaded providedByUnloaded | 186605 unloaded := self itemsWithMissingRequirements. 186606 providedByUnloaded := (unloaded gather: [:e | e provisions]) asSet. 186607 ^ required keys reject: [:ea | providedByUnloaded includes: ea ]! ! 186608 186609!MCDependencySorter methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 186610itemsWithMissingRequirements 186611 | items | 186612 items := Set new. 186613 required do: [:ea | items addAll: ea]. 186614 ^ items 186615! ! 186616 186617 186618!MCDependencySorter methodsFor: 'building' stamp: 'bf 11/12/2004 14:50'! 186619addAll: aCollection 186620 aCollection asArray sort do: [:ea | self add: ea]! ! 186621 186622!MCDependencySorter methodsFor: 'building' stamp: 'avi 10/7/2004 22:47'! 186623addExternalProvisions: aCollection 186624 (aCollection intersection: self externalRequirements) 186625 do: [:ea | self addProvision: ea]! ! 186626 186627!MCDependencySorter methodsFor: 'building' stamp: 'stephaneducasse 2/4/2006 20:47'! 186628add: anItem 186629 | requirements | 186630 requirements := self unresolvedRequirementsFor: anItem. 186631 requirements isEmpty 186632 ifTrue: [self addToOrder: anItem] 186633 ifFalse: [self addRequirements: requirements for: anItem]! ! 186634 186635 186636!MCDependencySorter methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:02'! 186637initialize 186638 super initialize. 186639 provided := Set new. 186640 required := Dictionary new. 186641 orderedItems := OrderedCollection new.! ! 186642 186643 186644!MCDependencySorter methodsFor: 'sorting' stamp: 'ab 5/22/2003 23:25'! 186645orderedItems 186646 ^ orderedItems! ! 186647 186648 186649!MCDependencySorter methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! 186650addProvision: anObject 186651 | newlySatisfied | 186652 provided add: anObject. 186653 newlySatisfied := required removeKey: anObject ifAbsent: [#()]. 186654 self addAll: newlySatisfied.! ! 186655 186656!MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:23'! 186657addRequirements: aCollection for: anObject 186658 aCollection do: [:ea | self addRequirement: ea for: anObject]! ! 186659 186660!MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:24'! 186661addRequirement: reqObject for: itemObject 186662 (self itemsRequiring: reqObject) add: itemObject! ! 186663 186664!MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:15'! 186665addToOrder: anItem 186666 orderedItems add: anItem. 186667 anItem provisions do: [:ea | self addProvision: ea].! ! 186668 186669!MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:24'! 186670itemsRequiring: anObject 186671 ^ required at: anObject ifAbsentPut: [Set new]! ! 186672 186673!MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:22'! 186674unresolvedRequirementsFor: anItem 186675 ^ anItem requirements difference: provided! ! 186676 186677"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 186678 186679MCDependencySorter class 186680 instanceVariableNames: ''! 186681 186682!MCDependencySorter class methodsFor: 'as yet unclassified' stamp: 'ab 5/23/2003 14:17'! 186683items: aCollection 186684 ^ self new addAll: aCollection! ! 186685 186686!MCDependencySorter class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186687sortItems: aCollection 186688 | sorter | 186689 sorter := self items: aCollection. 186690 sorter externalRequirements do: [:req | sorter addProvision: req]. 186691 ^ sorter orderedItems.! ! 186692TestCase subclass: #MCDependencySorterTest 186693 instanceVariableNames: '' 186694 classVariableNames: '' 186695 poolDictionaries: '' 186696 category: 'Tests-Monticello'! 186697 186698!MCDependencySorterTest methodsFor: 'asserting' stamp: 'avi 10/7/2004 22:32'! 186699assertItems: anArray orderAs: depOrder withRequired: missingDeps toLoad: unloadableItems 186700 self assertItems: anArray orderAs: depOrder withRequired: missingDeps toLoad: unloadableItems extraProvisions: #()! ! 186701 186702!MCDependencySorterTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 186703assertItems: anArray orderAs: depOrder withRequired: missingDeps toLoad: unloadableItems extraProvisions: provisions 186704 | order sorter items missing unloadable | 186705 items := anArray collect: [:ea | self itemWithSpec: ea]. 186706 sorter := MCDependencySorter items: items. 186707 sorter addExternalProvisions: provisions. 186708 order := (sorter orderedItems collect: [:ea | ea name]) asArray. 186709 self assert: order = depOrder. 186710 missing := sorter externalRequirements. 186711 self assert: missing asSet = missingDeps asSet. 186712 unloadable := (sorter itemsWithMissingRequirements collect: [:ea | ea name]) asArray. 186713 self assert: unloadable asSet = unloadableItems asSet! ! 186714 186715 186716!MCDependencySorterTest methodsFor: 'building' stamp: 'ab 5/24/2003 14:08'! 186717itemWithSpec: anArray 186718 ^ MCMockDependentItem new 186719 name: anArray first; 186720 provides: anArray second; 186721 requires: anArray third! ! 186722 186723 186724!MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:11'! 186725testCascadingUnresolved 186726 self assertItems: #( 186727 (a (x) (z)) 186728 (b () (x)) 186729 (c () ())) 186730 orderAs: #(c) 186731 withRequired: #(z) 186732 toLoad: #(a b) ! ! 186733 186734!MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:11'! 186735testCycle 186736 self assertItems: #( 186737 (a (x) (y)) 186738 (b (y) (x))) 186739 orderAs: #() 186740 withRequired: #() 186741 toLoad: #(a b) ! ! 186742 186743!MCDependencySorterTest methodsFor: 'tests' stamp: 'avi 10/7/2004 22:35'! 186744testExtraProvisions 186745 self assertItems: 186746 #((a (x) (z)) 186747 (b () (x))) 186748 orderAs: #(a b) 186749 withRequired: #() 186750 toLoad: #() 186751 extraProvisions: #(x z)! ! 186752 186753!MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:11'! 186754testMultiRequirementOrdering 186755 self assertItems: #( 186756 (a (x) (z)) 186757 (b (y) ()) 186758 (c (z) ()) 186759 (d () (x y z))) 186760 orderAs: #(b c a d) 186761 withRequired: #() 186762 toLoad: #()! ! 186763 186764!MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:11'! 186765testSimpleOrdering 186766 self assertItems: #((a (x) ()) 186767 (c () (y)) 186768 (b (y) (x))) 186769 orderAs: #(a b c) 186770 withRequired: #() 186771 toLoad: #()! ! 186772 186773!MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:12'! 186774testSimpleUnresolved 186775 self assertItems: #( 186776 (a () (z))) 186777 orderAs: #() 186778 withRequired: #(z) 186779 toLoad: #(a) 186780 ! ! 186781 186782!MCDependencySorterTest methodsFor: 'tests' stamp: 'avi 10/7/2004 22:12'! 186783testUnusedAlternateProvider 186784 self assertItems: #( 186785 (a (x) (z)) 186786 (b () (x)) 186787 (c (x) ())) 186788 orderAs: #(c b) 186789 withRequired: #(z) 186790 toLoad: #(a) ! ! 186791ListItemWrapper subclass: #MCDependentsWrapper 186792 instanceVariableNames: '' 186793 classVariableNames: '' 186794 poolDictionaries: '' 186795 category: 'MonticelloGUI'! 186796 186797!MCDependentsWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/14/2004 02:31'! 186798asString 186799 ^item description! ! 186800 186801!MCDependentsWrapper methodsFor: 'as yet unclassified' stamp: 'avi 9/10/2004 17:54'! 186802contents 186803 | list workingCopies | 186804 workingCopies := model unsortedWorkingCopies. 186805 list := item requiredPackages collect: 186806 [:each | 186807 workingCopies detect: [:wc | wc package = each] ifNone: [nil]] 186808 thenSelect: [:x | x notNil]. 186809 ^list collect: [:each | self class with: each model: model]! ! 186810 186811!MCDependentsWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/14/2004 02:31'! 186812hasContents 186813 ^item requiredPackages isEmpty not! ! 186814 186815!MCDependentsWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/14/2004 02:41'! 186816item 186817 ^item! ! 186818 186819"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 186820 186821MCDependentsWrapper class 186822 instanceVariableNames: ''! 186823MCRepository subclass: #MCDictionaryRepository 186824 instanceVariableNames: 'description dict' 186825 classVariableNames: '' 186826 poolDictionaries: '' 186827 category: 'Monticello-Repositories'! 186828 186829!MCDictionaryRepository methodsFor: '*MonticelloGUI' stamp: 'ar 8/6/2009 18:24'! 186830morphicOpen: aWorkingCopy 186831 | names index infos | 186832 infos := self sortedVersionInfos. 186833 infos isEmpty ifTrue: [^ self inform: 'No versions']. 186834 names := infos collect: [:ea | ea name]. 186835 index := UIManager default chooseFrom: names title: 'Open version:'. 186836 index = 0 ifFalse: [(self versionWithInfo: (infos at: index)) open]! ! 186837 186838 186839!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 21:04'! 186840allVersionInfos 186841 ^ dict values collect: [:ea | ea info]! ! 186842 186843!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:20'! 186844basicStoreVersion: aVersion 186845 dict at: aVersion info put: aVersion! ! 186846 186847!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186848closestAncestorVersionFor: anAncestry ifNone: errorBlock 186849 | info | 186850 info := anAncestry breadthFirstAncestors 186851 detect: [:ea | self includesVersionWithInfo: ea] 186852 ifNone: [^ errorBlock value]. 186853 ^ self versionWithInfo: info! ! 186854 186855!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/26/2003 02:47'! 186856description 186857 186858 ^ description ifNil: ['cache']! ! 186859 186860!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186861description: aString 186862 186863 description := aString ! ! 186864 186865!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/26/2003 02:47'! 186866dictionary 186867 186868 ^ dict! ! 186869 186870!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186871dictionary: aDictionary 186872 186873 dict := aDictionary! ! 186874 186875!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/21/2003 23:39'! 186876includesVersionNamed: aString 186877 ^ dict anySatisfy: [:ea | ea info name = aString]! ! 186878 186879!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 19:49'! 186880includesVersionWithInfo: aVersionInfo 186881 ^ dict includesKey: aVersionInfo! ! 186882 186883!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:02'! 186884initialize 186885 186886 super initialize. 186887 dict := Dictionary new. 186888! ! 186889 186890!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186891sortedVersionInfos 186892 | sorter | 186893 sorter := MCVersionSorter new. 186894 self allVersionInfos do: [:ea | sorter addVersionInfo: ea]. 186895 ^ sorter sortedVersionInfos 186896! ! 186897 186898!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/16/2003 18:22'! 186899versionWithInfo: aVersionInfo ifAbsent: errorBlock 186900 ^ dict at: aVersionInfo ifAbsent: errorBlock! ! 186901 186902!MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 12:56'! 186903= other 186904 ^ self == other! ! 186905 186906"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 186907 186908MCDictionaryRepository class 186909 instanceVariableNames: ''! 186910MCRepositoryTest subclass: #MCDictionaryRepositoryTest 186911 instanceVariableNames: 'dict' 186912 classVariableNames: '' 186913 poolDictionaries: '' 186914 category: 'Tests-Monticello'! 186915 186916!MCDictionaryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'ab 8/16/2003 17:53'! 186917addVersion: aVersion 186918 dict at: aVersion info put: aVersion! ! 186919 186920!MCDictionaryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 16:06'! 186921deleteNode: aNode 186922 dict removeKey: aNode! ! 186923 186924!MCDictionaryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186925dictionary 186926 ^ dict ifNil: [dict := Dictionary new]! ! 186927 186928!MCDictionaryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186929setUp 186930 repository := MCDictionaryRepository new dictionary: self dictionary! ! 186931MCVersion subclass: #MCDiffyVersion 186932 instanceVariableNames: 'base patch' 186933 classVariableNames: '' 186934 poolDictionaries: '' 186935 category: 'Monticello-Versioning'! 186936 186937!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:17'! 186938baseInfo 186939 ^ base! ! 186940 186941!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:39'! 186942baseSnapshot 186943 ^ (self workingCopy repositoryGroup versionWithInfo: base) snapshot! ! 186944 186945!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'bf 5/23/2005 15:42'! 186946canOptimizeLoading 186947 "Answer wether I can provide a patch for the working copy without the usual diff pass" 186948 ^ package hasWorkingCopy 186949 and: [package workingCopy modified not 186950 and: [package workingCopy ancestors includes: self baseInfo]]! ! 186951 186952!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'bf 5/30/2005 17:39'! 186953fileName 186954 ^ (self class nameForVer: info name base: base name), '.', self writerClass extension! ! 186955 186956!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186957initializeWithPackage: aPackage info: aVersionInfo dependencies: aCollection baseInfo: baseVersionInfo patch: aPatch 186958 patch := aPatch. 186959 base := baseVersionInfo. 186960 super initializeWithPackage: aPackage info: aVersionInfo snapshot: nil dependencies: aCollection. 186961! ! 186962 186963!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:24'! 186964isDiffy 186965 ^ true! ! 186966 186967!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:17'! 186968patch 186969 ^ patch! ! 186970 186971!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 186972snapshot 186973 ^ snapshot ifNil: [snapshot := MCPatcher apply: patch to: self baseSnapshot]! ! 186974 186975!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/19/2004 22:03'! 186976summary 186977 ^ '(Diff against ', self baseInfo name, ')', String cr, super summary! ! 186978 186979!MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:17'! 186980writerClass 186981 ^ MCMcdWriter ! ! 186982 186983"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 186984 186985MCDiffyVersion class 186986 instanceVariableNames: ''! 186987 186988!MCDiffyVersion class methodsFor: 'instance creation' stamp: 'avi 2/13/2004 23:07'! 186989package: aPackage info: aVersionInfo dependencies: aCollection baseInfo: baseVersionInfo patch: 186990aPatch 186991 ^ self basicNew initializeWithPackage: aPackage info: aVersionInfo dependencies: aCollection baseInfo: baseVersionInfo patch: 186992aPatch! ! 186993 186994!MCDiffyVersion class methodsFor: 'instance creation' stamp: 'avi 2/13/2004 23:06'! 186995package: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection baseVersion: aVersion 186996 ^ self 186997 package: aPackage 186998 info: aVersionInfo 186999 dependencies: aCollection 187000 baseInfo: aVersion info 187001 patch: (aSnapshot patchRelativeToBase: aVersion snapshot)! ! 187002 187003 187004!MCDiffyVersion class methodsFor: 'name utilities' stamp: 'bf 5/30/2005 18:45'! 187005baseNameFrom: diffName 187006 | baseId verName | 187007 baseId := (diffName copyAfter: $() copyUpTo: $). 187008 baseId ifEmpty: [^baseId]. 187009 (baseId beginsWith: '@') 187010 ifTrue: [^baseId copyAfter: $@]. 187011 verName := self verNameFrom: diffName. 187012 ^(baseId includes: $.) 187013 ifTrue: [(verName copyUpToLast: $-), '-', baseId] 187014 ifFalse: [(verName copyUpToLast: $.), '.', baseId] 187015! ! 187016 187017!MCDiffyVersion class methodsFor: 'name utilities' stamp: 'bf 5/30/2005 18:58'! 187018canonicalNameFor: aFileName 187019 ^(self nameForVer: (self verNameFrom: aFileName) 187020 base: (self baseNameFrom: aFileName)) 187021 , '.', MCMcdReader extension 187022! ! 187023 187024!MCDiffyVersion class methodsFor: 'name utilities' stamp: 'bf 5/30/2005 17:39'! 187025nameForVer: versionName base: baseName 187026 | baseId | 187027 baseId := (versionName copyUpToLast: $.) = (baseName copyUpToLast: $.) 187028 ifTrue: [baseName copyAfterLast: $.] 187029 ifFalse: [(versionName copyUpToLast: $-) = (baseName copyUpToLast: $-) 187030 ifTrue: [baseName copyAfterLast: $-] 187031 ifFalse: ['@', baseName]]. 187032 ^ versionName, '(', baseId, ')'! ! 187033 187034!MCDiffyVersion class methodsFor: 'name utilities' stamp: 'bf 5/30/2005 18:19'! 187035verNameFrom: diffName 187036 ^diffName copyUpTo: $(! ! 187037MCFileBasedRepository subclass: #MCDirectoryRepository 187038 instanceVariableNames: 'directory' 187039 classVariableNames: '' 187040 poolDictionaries: '' 187041 category: 'Monticello-Repositories'! 187042 187043!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/31/2003 15:28'! 187044allFileNames 187045 ^ (directory entries sortBy: [:a :b | a modificationTime >= b modificationTime]) collect: [:ea | ea name]! ! 187046 187047!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:57'! 187048description 187049 ^ directory pathName! ! 187050 187051!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 17:49'! 187052directory 187053 ^ directory! ! 187054 187055!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187056directory: aDirectory 187057 directory := aDirectory! ! 187058 187059!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:02'! 187060initialize 187061 super initialize. 187062 directory := FileDirectory default! ! 187063 187064!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'nk 11/2/2003 10:55'! 187065isValid 187066 ^directory exists! ! 187067 187068!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187069readStreamForFileNamed: aString do: aBlock 187070 | file val | 187071 file := FileStream readOnlyFileNamed: (directory fullNameFor: aString). 187072 val := aBlock value: file. 187073 file close. 187074 ^ val! ! 187075 187076!MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187077writeStreamForFileNamed: aString replace: aBoolean do: aBlock 187078 | file sel | 187079 sel := aBoolean ifTrue: [#forceNewFileNamed:] ifFalse: [#newFileNamed:]. 187080 file := FileStream perform: sel with: (directory fullNameFor: aString). 187081 aBlock value: file. 187082 file close.! ! 187083 187084 187085!MCDirectoryRepository methodsFor: 'comparing' stamp: 'ab 7/19/2003 21:40'! 187086hash 187087 ^ directory pathName hash! ! 187088 187089"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 187090 187091MCDirectoryRepository class 187092 instanceVariableNames: ''! 187093 187094!MCDirectoryRepository class methodsFor: 'instance creation' stamp: 'ab 7/24/2003 21:20'! 187095description 187096 ^ 'directory'! ! 187097 187098!MCDirectoryRepository class methodsFor: 'instance creation' stamp: 'damiencassou 12/12/2008 17:18'! 187099morphicConfigure 187100 ^ UIManager default chooseDirectory ifNotNil: 187101 [:directory | 187102 self new directory: directory]! ! 187103MCRepositoryTest subclass: #MCDirectoryRepositoryTest 187104 instanceVariableNames: 'directory' 187105 classVariableNames: '' 187106 poolDictionaries: '' 187107 category: 'Tests-Monticello'! 187108 187109!MCDirectoryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187110addVersion: aVersion 187111 | file | 187112 file := FileStream newFileNamed: (directory fullNameFor: aVersion fileName). 187113 aVersion fileOutOn: file. 187114 file close.! ! 187115 187116!MCDirectoryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187117directory 187118 directory ifNil: 187119 [directory := FileDirectory default directoryNamed: 'mctest'. 187120 directory assureExistence]. 187121 ^ directory! ! 187122 187123!MCDirectoryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187124setUp 187125 repository := MCDirectoryRepository new directory: self directory! ! 187126 187127!MCDirectoryRepositoryTest methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 12:53'! 187128tearDown 187129 self directory recursiveDelete! ! 187130PackageInfo subclass: #MCDirtyPackageInfo 187131 instanceVariableNames: '' 187132 classVariableNames: '' 187133 poolDictionaries: '' 187134 category: 'Monticello-Mocks'! 187135 187136!MCDirtyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 187137classes 187138 ^ Array new: 0.! ! 187139 187140!MCDirtyPackageInfo methodsFor: 'as yet unclassified' stamp: 'al 2/16/2006 09:53'! 187141methods 187142 ^ MCMockClassA selectors 187143 select: [:ea | ea beginsWith: 'ordinal'] 187144 thenCollect: 187145 [:ea | 187146 MethodReference new 187147 setStandardClass: MCMockClassA 187148 methodSymbol: ea].! ! 187149 187150!MCDirtyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 187151packageName 187152 ^ 'MCDirtyPackage'! ! 187153 187154"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 187155 187156MCDirtyPackageInfo class 187157 instanceVariableNames: ''! 187158 187159!MCDirtyPackageInfo class methodsFor: 'as yet unclassified' stamp: 'avi 2/22/2004 14:04'! 187160initialize 187161 [self new register] on: MessageNotUnderstood do: []! ! 187162 187163!MCDirtyPackageInfo class methodsFor: 'as yet unclassified' stamp: 'cwp 7/21/2003 19:45'! 187164wantsChangeSetLogging 187165 ^ false! ! 187166Object subclass: #MCDoItParser 187167 instanceVariableNames: 'source' 187168 classVariableNames: '' 187169 poolDictionaries: '' 187170 category: 'Monticello-Chunk Format'! 187171 187172!MCDoItParser methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:40'! 187173addDefinitionsTo: aCollection 187174 self subclassResponsibility ! ! 187175 187176!MCDoItParser methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:40'! 187177source 187178 ^ source! ! 187179 187180!MCDoItParser methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187181source: aString 187182 source := aString! ! 187183 187184"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 187185 187186MCDoItParser class 187187 instanceVariableNames: ''! 187188 187189!MCDoItParser class methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:29'! 187190concreteSubclasses 187191 ^ self allSubclasses reject: [:c | c isAbstract]! ! 187192 187193!MCDoItParser class methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 187194forDoit: aString 187195 ^ (self subclassForDoit: aString) ifNotNil: [:c | c new source: aString]! ! 187196 187197!MCDoItParser class methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:51'! 187198isAbstract 187199 ^ self pattern isNil! ! 187200 187201!MCDoItParser class methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:30'! 187202pattern 187203 ^ nil! ! 187204 187205!MCDoItParser class methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:30'! 187206subclassForDoit: aString 187207 ^ self concreteSubclasses detect: [:ea | ea pattern match: aString] ifNone: []! ! 187208PackageInfo subclass: #MCEmptyPackageInfo 187209 instanceVariableNames: '' 187210 classVariableNames: '' 187211 poolDictionaries: '' 187212 category: 'Monticello-Mocks'! 187213 187214!MCEmptyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 187215classes 187216 ^ #()! ! 187217 187218!MCEmptyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 187219methods 187220 ^ #()! ! 187221 187222!MCEmptyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 187223packageName 187224 ^ 'MCEmptyPackage'! ! 187225 187226"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 187227 187228MCEmptyPackageInfo class 187229 instanceVariableNames: ''! 187230 187231!MCEmptyPackageInfo class methodsFor: 'as yet unclassified' stamp: 'avi 2/22/2004 14:04'! 187232initialize 187233 [self new register] on: MessageNotUnderstood do: []! ! 187234 187235!MCEmptyPackageInfo class methodsFor: 'as yet unclassified' stamp: 'cwp 7/21/2003 19:45'! 187236wantsChangeSetLogging 187237 ^ false! ! 187238MCRepository subclass: #MCFileBasedRepository 187239 instanceVariableNames: 'cache allFileNames' 187240 classVariableNames: '' 187241 poolDictionaries: '' 187242 category: 'Monticello-Repositories'! 187243 187244!MCFileBasedRepository methodsFor: '*MonticelloGUI' stamp: 'avi 2/28/2004 18:32'! 187245morphicOpen: aWorkingCopy 187246 (MCFileRepositoryInspector repository: self workingCopy: aWorkingCopy) 187247 show! ! 187248 187249 187250!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 00:35'! 187251allFileNames 187252 self subclassResponsibility! ! 187253 187254!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 20:01'! 187255allFileNamesForVersionNamed: aString 187256 ^ self filterFileNames: self readableFileNames forVersionNamed: aString! ! 187257 187258!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 16:40'! 187259allFileNamesOrCache 187260 ^ allFileNames ifNil: [self allFileNames]! ! 187261 187262!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 00:40'! 187263allVersionNames 187264 ^ self readableFileNames collect: [:ea | self versionNameFromFileName: ea]! ! 187265 187266!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187267basicStoreVersion: aVersion 187268 self 187269 writeStreamForFileNamed: aVersion fileName 187270 do: [:s | aVersion fileOutOn: s]. 187271 aVersion isCacheable ifTrue: [ 187272 cache ifNil: [cache := Dictionary new]. 187273 cache at: aVersion fileName put: aVersion]. 187274! ! 187275 187276!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187277cache 187278 ^ cache ifNil: [cache := Dictionary new]! ! 187279 187280!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187281cacheAllFileNamesDuring: aBlock 187282 allFileNames := self allFileNames. 187283 ^ aBlock ensure: [allFileNames := nil]! ! 187284 187285!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'bf 6/9/2005 15:47'! 187286cachedFileNames 187287 ^cache == nil 187288 ifTrue: [#()] 187289 ifFalse: [cache keys]! ! 187290 187291!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187292canReadFileNamed: aString 187293 | reader | 187294 reader := MCVersionReader readerClassForFileNamed: aString. 187295 ^ reader notNil! ! 187296 187297!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 16:40'! 187298closestAncestorVersionFor: anAncestry ifNone: errorBlock 187299 ^ self cacheAllFileNamesDuring: 187300 [super closestAncestorVersionFor: anAncestry ifNone: errorBlock]! ! 187301 187302!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 20:01'! 187303filterFileNames: aCollection forVersionNamed: aString 187304 ^ aCollection select: [:ea | (self versionNameFromFileName: ea) = aString] ! ! 187305 187306!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187307flushCache 187308 cache := nil! ! 187309 187310!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 00:36'! 187311includesVersionNamed: aString 187312 ^ self allVersionNames includes: aString! ! 187313 187314!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 13:34'! 187315loadVersionFromFileNamed: aString 187316 ^ self versionReaderForFileNamed: aString do: [:r | r version]! ! 187317 187318!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 18:37'! 187319loadVersionInfoFromFileNamed: aString 187320 ^ self versionReaderForFileNamed: aString do: [:r | r info] 187321 ! ! 187322 187323!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 16:52'! 187324maxCacheSize 187325 ^ 8! ! 187326 187327!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:34'! 187328notifyList 187329 | list | 187330 (self allFileNames includes: 'notify') ifFalse: [^ #()]. 187331 ^ self readStreamForFileNamed: 'notify' do: 187332 [:s | 187333 s upToEnd withSqueakLineEndings findTokens: (String with: Character cr)]! ! 187334 187335!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'bf 3/11/2005 18:01'! 187336possiblyNewerVersionsOfAnyOf: someVersions 187337 | pkgs | 187338 pkgs := Dictionary new. 187339 187340 someVersions do: [:aVersionInfo | 187341 pkgs at: (aVersionInfo name copyUpToLast: $-) 187342 put: (aVersionInfo name copyAfterLast: $.) asNumber]. 187343 187344 ^[self allVersionNames select: [:each | 187345 (pkgs at: (each copyUpToLast: $-) ifPresent: [:verNumber | 187346 verNumber < (each copyAfterLast: $.) asNumber 187347 or: [verNumber = (each copyAfterLast: $.) asNumber 187348 and: [someVersions noneSatisfy: [:v | v name = each]]]]) == true] 187349 ] on: Error do: [:ex | ex return: #()]! ! 187350 187351!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 16:39'! 187352readableFileNames 187353 | all cached new | 187354 all := self allFileNamesOrCache. "from repository" 187355 cached := self cachedFileNames. "in memory" 187356 new := all difference: cached. 187357 ^ (cached asArray, new) 187358 select: [:ea | self canReadFileNamed: ea]! ! 187359 187360!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/18/2005 22:43'! 187361resizeCache: aDictionary 187362 [aDictionary size <= self maxCacheSize] whileFalse: 187363 [aDictionary removeKey: aDictionary keys atRandom]! ! 187364 187365!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 23:09'! 187366versionFromFileNamed: aString 187367 | v | 187368 v := self cache at: aString ifAbsent: [self loadVersionFromFileNamed: aString]. 187369 self resizeCache: cache. 187370 (v notNil and: [v isCacheable]) ifTrue: [cache at: aString put: v]. 187371 ^ v! ! 187372 187373!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 18:37'! 187374versionInfoFromFileNamed: aString 187375 self cache at: aString ifPresent: [:v | ^ v info]. 187376 ^ self loadVersionInfoFromFileNamed: aString! ! 187377 187378!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'bf 5/30/2005 22:52'! 187379versionNameFromFileName: aString 187380 ^ (aString copyUpToLast: $.) copyUpTo: $(! ! 187381 187382!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 187383versionReaderForFileNamed: aString do: aBlock 187384 ^ self 187385 readStreamForFileNamed: aString 187386 do: [:s | 187387 (MCVersionReader readerClassForFileNamed: aString) ifNotNil: 187388 [:class | aBlock value: (class on: s fileName: aString)]] 187389! ! 187390 187391!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187392versionWithInfo: aVersionInfo ifAbsent: errorBlock 187393 | version | 187394 (self allFileNamesForVersionNamed: aVersionInfo name) do: 187395 [:fileName | 187396 version := self versionFromFileNamed: fileName. 187397 version info = aVersionInfo ifTrue: [^ version]]. 187398 ^ errorBlock value! ! 187399 187400!MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/31/2003 14:32'! 187401writeStreamForFileNamed: aString do: aBlock 187402 ^ self writeStreamForFileNamed: aString replace: false do: aBlock! ! 187403 187404"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 187405 187406MCFileBasedRepository class 187407 instanceVariableNames: ''! 187408 187409!MCFileBasedRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/3/2005 00:43'! 187410flushAllCaches 187411 self allSubInstancesDo: [:ea | ea flushCache]! ! 187412MCTestCase subclass: #MCFileInTest 187413 instanceVariableNames: 'stream expected diff' 187414 classVariableNames: '' 187415 poolDictionaries: '' 187416 category: 'Tests-Monticello'! 187417 187418!MCFileInTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 187419assertNoChange 187420 | actual | 187421 actual := MCSnapshotResource takeSnapshot. 187422 diff := actual patchRelativeToBase: expected. 187423 self assert: diff isEmpty! ! 187424 187425 187426!MCFileInTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! 187427setUp 187428 expected := self mockSnapshot. 187429 stream := RWBinaryOrTextStream on: String new.! ! 187430 187431!MCFileInTest methodsFor: 'running' stamp: 'oscar.nierstrasz 10/18/2009 12:15'! 187432tearDown 187433 (diff isNil or: [diff isEmpty not]) 187434 ifTrue: [expected updatePackage: self mockPackage]. 187435 DataStream initialize! ! 187436 187437 187438!MCFileInTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 02:08'! 187439alterInitialState 187440 self mockClassA touchCVar! ! 187441 187442!MCFileInTest methodsFor: 'testing' stamp: 'avi 2/17/2004 03:21'! 187443assertFileOutFrom: writerClass canBeFiledInWith: aBlock 187444 (writerClass on: stream) writeSnapshot: self mockSnapshot. 187445 self alterInitialState. 187446 self assertSuccessfulLoadWith: aBlock. 187447 self mockPackage unload. 187448 self assertSuccessfulLoadWith: aBlock. 187449! ! 187450 187451!MCFileInTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! 187452assertInitializersCalled 187453 | cvar | 187454 cvar := self mockClassA cVar. 187455 self assert: cvar = #initialized! ! 187456 187457!MCFileInTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 02:30'! 187458assertSuccessfulLoadWith: aBlock 187459 stream reset. 187460 aBlock value. 187461 self assertNoChange. 187462 self assertInitializersCalled.! ! 187463 187464!MCFileInTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 00:13'! 187465testStWriter 187466 self 187467 assertFileOutFrom: MCStWriter 187468 canBeFiledInWith: [stream fileIn]. 187469! ! 187470MCVersionInspector subclass: #MCFileRepositoryInspector 187471 instanceVariableNames: 'repository versions loaded newer inherited selectedPackage selectedVersion order versionInfo' 187472 classVariableNames: 'Order' 187473 poolDictionaries: '' 187474 category: 'MonticelloGUI'! 187475 187476!MCFileRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'avi 9/18/2005 10:54'! 187477load 187478 self hasVersion ifTrue: 187479 [self version isCacheable 187480 ifTrue: [version workingCopy repositoryGroup addRepository: repository]. 187481 super load. 187482 self refresh].! ! 187483 187484!MCFileRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'bf 11/16/2004 11:56'! 187485merge 187486 super merge. 187487 self refresh. 187488! ! 187489 187490!MCFileRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'md 2/28/2006 12:10'! 187491refresh 187492 | packageNames name latest av | 187493 packageNames := Set new. 187494 versions := repository readableFileNames collect: [ :each | 187495 name := (each copyUpToLast: $.) copyUpTo: $(. 187496 name last isDigit ifFalse: [Array with: name with: '' with: '' with: each] 187497 ifTrue: 187498 [Array 187499 with: (packageNames add: (name copyUpToLast: $-)) "pkg name" 187500 with: ((name copyAfterLast: $-) copyUpTo: $.) "user" 187501 with: ((name copyAfterLast: $-) copyAfter: $.) asInteger "version" 187502 with: each]]. 187503 newer := Set new. 187504 inherited := Set new. 187505 loaded := Set new. 187506 (MCWorkingCopy allManagers 187507" select: [ :each | packageNames includes: each packageName]") 187508 do: [:each | 187509 each ancestors do: [ :ancestor | 187510 loaded add: ancestor name. 187511 ancestor ancestorsDoWhileTrue: [:heir | 187512 (inherited includes: heir name) 187513 ifTrue: [false] 187514 ifFalse: [inherited add: heir name. true]]]. 187515 latest := (versions select: [:v | v first = each package name]) 187516 detectMax: [:v | v third]. 187517 (latest notNil and: [ 187518 each ancestors allSatisfy: [:ancestor | 187519 av := ((ancestor name copyAfterLast: $-) copyAfter: $.) asInteger. 187520 av < latest third or: [ 187521 av = latest third and: [((ancestor name copyAfterLast: $-) copyUpTo: $.) ~= latest second]]]]) 187522 ifTrue: [newer add: each package name ]]. 187523 187524 self changed: #packageList; changed: #versionList! ! 187525 187526!MCFileRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187527setRepository: aFileBasedRepository workingCopy: aWorkingCopy 187528 order := self class order. 187529 repository := aFileBasedRepository. 187530 self refresh. 187531 aWorkingCopy 187532 ifNil: [selectedPackage := self packageList isEmpty ifFalse: [self packageList first]] 187533 ifNotNil: [ selectedPackage := aWorkingCopy ancestry ancestorString copyUpToLast: $- ]. 187534 MCWorkingCopy addDependent: self. 187535! ! 187536 187537 187538!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 11/10/2003 22:35'! 187539buttonSpecs 187540 ^#(('Refresh' refresh 'refresh the version-list')) , super buttonSpecs! ! 187541 187542!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'hfm 12/22/2008 18:37'! 187543defaultExtent 187544 ^500@450! ! 187545 187546!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 20:06'! 187547defaultLabel 187548 ^'Repository: ' , repository description! ! 187549 187550!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 9/17/2005 17:21'! 187551hasVersion 187552 ^ selectedVersion notNil! ! 187553 187554!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 21:26'! 187555orderSpecs 187556 ^{ 187557 'unchanged' -> nil. 187558 'order by package' -> [ :x :y | x first <= y first ]. 187559 'order by author' -> [ :x :y | x second <= y second ]. 187560 'order by version-string' -> [ :x :y | x third <= y third ]. 187561 'order by version-number' -> [ :x :y | x third asNumber >= y third asNumber ]. 187562 'order by filename' -> [ :x :y | x fourth <= y fourth ]. 187563 }! ! 187564 187565!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 21:07'! 187566orderString: anIndex 187567 ^String streamContents: [ :stream | 187568 order = anIndex 187569 ifTrue: [ stream nextPutAll: '<yes>' ] 187570 ifFalse: [ stream nextPutAll: '<no>' ]. 187571 stream nextPutAll: (self orderSpecs at: anIndex) key ]! ! 187572 187573!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 187574order: anInteger 187575 self class order: (order := anInteger). 187576 self changed: #versionList.! ! 187577 187578!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'bf 2/24/2005 18:29'! 187579packageHighlight: aString 187580 187581 newer ifNil: [newer := #()]. 187582 ^(loaded anySatisfy: [:each | (each copyUpToLast: $-) = aString]) 187583 ifTrue: [ 187584 Text string: aString 187585 attribute: (TextEmphasis new emphasisCode: ( 187586 ((newer includes: aString) 187587 ifTrue: [5] ifFalse: [4])))] 187588 ifFalse: [aString]! ! 187589 187590!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 187591packageList 187592 | result | 187593 result := versions 187594 inject: Set new 187595 into: [ :set :each | set add: each first; yourself ]. 187596 187597 "sort loaded packages first, then alphabetically" 187598 result := result asSortedCollection: [:a :b | 187599 | loadedA loadedB | 187600 loadedA := loaded anySatisfy: [:each | (each copyUpToLast: $-) = a]. 187601 loadedB := loaded anySatisfy: [:each | (each copyUpToLast: $-) = b]. 187602 loadedA = loadedB 187603 ifTrue: [a < b] 187604 ifFalse: [loadedA]]. 187605 187606 ^result collect: [:each | self packageHighlight: each]! ! 187607 187608!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 17:25'! 187609packageListMenu: aMenu 187610 ^aMenu! ! 187611 187612!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 20:17'! 187613packageSelection 187614 ^self packageList indexOf: selectedPackage! ! 187615 187616!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 187617packageSelection: aNumber 187618 selectedPackage := aNumber isZero 187619 ifFalse: [ (self packageList at: aNumber) asString ]. 187620 self versionSelection: 0. 187621 self changed: #packageSelection; changed: #versionList! ! 187622 187623!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 187624version 187625 ^ version ifNil: 187626 [Cursor wait showWhile: 187627 [version := repository versionFromFileNamed: selectedVersion]. 187628 version]! ! 187629 187630!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'bf 5/30/2005 19:10'! 187631versionHighlight: aString 187632 187633 | verName | 187634 inherited ifNil: [inherited := #()]. 187635 verName := (aString copyUpToLast: $.) copyUpTo: $(. 187636 ^Text 187637 string: aString 187638 attribute: (TextEmphasis new emphasisCode: ( 187639 ((loaded includes: verName) ifTrue: [ 4 "underlined" ] 187640 ifFalse: [ (inherited includes: verName) 187641 ifTrue: [ 0 ] 187642 ifFalse: [ 1 "bold" ] ])))! ! 187643 187644!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 187645versionInfo 187646 ^ versionInfo ifNil: [versionInfo := repository versionInfoFromFileNamed: selectedVersion]! ! 187647 187648!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 187649versionList 187650 | result sortBlock | 187651 result := selectedPackage isNil 187652 ifTrue: [ versions ] 187653 ifFalse: [ versions select: [ :each | selectedPackage = each first ] ]. 187654 sortBlock := (self orderSpecs at: order) value. 187655 sortBlock isNil ifFalse: [ 187656 result := result asSortedCollection: [:a :b | [sortBlock value: a value: b] on: Error do: [true]]]. 187657 ^result := result 187658 collect: [ :each | self versionHighlight: each fourth ]! ! 187659 187660!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 21:07'! 187661versionListMenu: aMenu 187662 1 to: self orderSpecs size do: [ :index | 187663 aMenu addUpdating: #orderString: target: self selector: #order: argumentList: { index } ]. 187664 ^aMenu! ! 187665 187666!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 20:18'! 187667versionSelection 187668 ^self versionList indexOf: selectedVersion! ! 187669 187670!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 187671versionSelection: aNumber 187672 aNumber isZero 187673 ifTrue: [ selectedVersion := version := versionInfo := nil ] 187674 ifFalse: [ 187675 selectedVersion := (self versionList at: aNumber) asString. 187676 version := versionInfo := nil]. 187677 self changed: #versionSelection; changed: #summary; changed: #hasVersion! ! 187678 187679!MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 20:26'! 187680widgetSpecs 187681 ^#( ((buttonRow) (0 0 1 0) (0 0 0 30)) 187682 ((listMorph: package) (0 0 0.5 0.6) (0 30 0 0)) 187683 ((listMorph: version) (0.5 0 1 0.6) (0 30 0 0)) 187684 ((textMorph: summary) (0 0.6 1 1) (0 0 0 0)) )! ! 187685 187686"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 187687 187688MCFileRepositoryInspector class 187689 instanceVariableNames: ''! 187690 187691!MCFileRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187692order 187693 Order isNil 187694 ifTrue: [ Order := 5 ]. 187695 ^Order! ! 187696 187697!MCFileRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187698order: anInteger 187699 Order := anInteger! ! 187700 187701!MCFileRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'lr 9/26/2003 20:09'! 187702repository: aFileBasedRepository workingCopy: aWorkingCopy 187703 ^self new 187704 setRepository: aFileBasedRepository workingCopy: aWorkingCopy; 187705 yourself! ! 187706MCVersionSorter subclass: #MCFilteredVersionSorter 187707 instanceVariableNames: 'target' 187708 classVariableNames: '' 187709 poolDictionaries: '' 187710 category: 'Monticello-Versioning'! 187711 187712!MCFilteredVersionSorter methodsFor: 'as yet unclassified' stamp: 'bf 5/28/2005 01:14'! 187713addVersionInfo: aVersionInfo 187714 (aVersionInfo hasAncestor: target) 187715 ifTrue: [super addVersionInfo: aVersionInfo] 187716! ! 187717 187718!MCFilteredVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187719processVersionInfo: aVersionInfo 187720 | success | 187721 aVersionInfo = target ifTrue: [^ true]. 187722 self pushLayer. 187723 success := (self knownAncestorsOf: aVersionInfo) anySatisfy: 187724 [:ea | self processVersionInfo: ea]. 187725 self popLayer. 187726 success ifTrue: [self addToCurrentLayer: aVersionInfo]. 187727 ^ success ! ! 187728 187729!MCFilteredVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187730target: aVersionInfo 187731 target := aVersionInfo! ! 187732 187733"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 187734 187735MCFilteredVersionSorter class 187736 instanceVariableNames: ''! 187737Object subclass: #MCFrontier 187738 instanceVariableNames: 'frontier bag' 187739 classVariableNames: '' 187740 poolDictionaries: '' 187741 category: 'Monticello-Versioning'! 187742 187743!MCFrontier methodsFor: 'accessing' stamp: 'avi 9/17/2005 22:02'! 187744frontier 187745 ^frontier! ! 187746 187747 187748!MCFrontier methodsFor: 'advancing' stamp: 'avi 9/17/2005 22:02'! 187749removeAll: collection 187750 collection do: [ :n | self remove: n]! ! 187751 187752!MCFrontier methodsFor: 'advancing' stamp: 'avi 9/17/2005 22:13'! 187753remove: aVersionInfo 187754 frontier remove: aVersionInfo. 187755 aVersionInfo ancestors do: 187756 [ :ancestor | 187757 bag remove: ancestor. 187758 (bag occurrencesOf: ancestor) = 0 187759 ifTrue: [frontier add: ancestor]]. 187760 ^aVersionInfo! ! 187761 187762 187763!MCFrontier methodsFor: 'initialization' stamp: 'avi 9/17/2005 22:11'! 187764frontier: f bag: remaining 187765 frontier := f asOrderedCollection. 187766 bag := remaining! ! 187767 187768"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 187769 187770MCFrontier class 187771 instanceVariableNames: ''! 187772 187773!MCFrontier class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:47'! 187774frontierOnAll: aCollection 187775 | remaining allVersions | 187776 remaining := Bag new. 187777 allVersions := (aCollection gather: [:ea | ea withBreadthFirstAncestors]) asSet. 187778 allVersions do: [:ea | remaining addAll: ea ancestors]. 187779 ^self new frontier: aCollection bag: remaining! ! 187780 187781!MCFrontier class methodsFor: 'instance creation' stamp: 'avi 9/17/2005 22:07'! 187782frontierOn: aVersionInfo 187783 ^ self frontierOnAll: (Array with: aVersionInfo)! ! 187784 187785!MCFrontier class methodsFor: 'instance creation' stamp: 'avi 9/17/2005 22:07'! 187786frontierOn: aVersionInfo and: otherVersionInfo 187787 ^ self frontierOnAll: (Array with: aVersionInfo with: otherVersionInfo)! ! 187788MCFileBasedRepository subclass: #MCFtpRepository 187789 instanceVariableNames: 'host directory user password connection' 187790 classVariableNames: '' 187791 poolDictionaries: '' 187792 category: 'Monticello-Repositories'! 187793 187794!MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187795clientDo: aBlock 187796 | client | 187797 client := FTPClient openOnHostNamed: host. 187798 client loginUser: user password: password. 187799 directory isEmpty ifFalse: [client changeDirectoryTo: directory]. 187800 ^ [aBlock value: client] ensure: [client close]! ! 187801 187802!MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187803directory: dirPath 187804 directory := dirPath! ! 187805 187806!MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187807host: hostname 187808 host := hostname! ! 187809 187810!MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187811parseDirectoryListing: aString 187812 | stream files line tokens | 187813 stream := aString readStream. 187814 files := OrderedCollection new. 187815 [stream atEnd] whileFalse: 187816 [line := stream nextLine. 187817 tokens := line findTokens: ' '. 187818 tokens size > 2 ifTrue: [files add: tokens last]]. 187819 ^ files! ! 187820 187821!MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187822password: passwordString 187823 password := passwordString! ! 187824 187825!MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187826user: userString 187827 user := userString! ! 187828 187829 187830!MCFtpRepository methodsFor: 'required' stamp: 'avi 9/16/2003 14:04'! 187831allFileNames 187832 ^ self clientDo: 187833 [:client | 187834 self parseDirectoryListing: client getDirectory]! ! 187835 187836!MCFtpRepository methodsFor: 'required' stamp: 'avi 9/17/2003 12:52'! 187837description 187838 ^ 'ftp://', user, '@', host, '/', directory! ! 187839 187840!MCFtpRepository methodsFor: 'required' stamp: 'stephaneducasse 2/4/2006 20:47'! 187841readStreamForFileNamed: aString do: aBlock 187842 | stream | 187843 ^ self clientDo: 187844 [:client | 187845 client binary. 187846 stream := RWBinaryOrTextStream on: String new. 187847 stream nextPutAll: (client getFileNamed: aString). 187848 aBlock value: stream reset]! ! 187849 187850!MCFtpRepository methodsFor: 'required' stamp: 'stephaneducasse 2/4/2006 20:47'! 187851writeStreamForFileNamed: aString replace: ignoreBoolean do: aBlock 187852 | stream | 187853 stream := RWBinaryOrTextStream on: String new. 187854 aBlock value: stream. 187855 self clientDo: 187856 [:client | 187857 client binary. 187858 client putFileStreamContents: stream reset as: aString]! ! 187859 187860"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 187861 187862MCFtpRepository class 187863 instanceVariableNames: ''! 187864 187865!MCFtpRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:02'! 187866fillInTheBlankRequest 187867 ^ 'FTP Repository:' 187868 187869 ! ! 187870 187871!MCFtpRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:02'! 187872morphicConfigure 187873 ^ self fillInTheBlankConfigure! ! 187874 187875 187876!MCFtpRepository class methodsFor: 'as yet unclassified' stamp: 'avi 9/16/2003 13:57'! 187877creationTemplate 187878 ^ 187879'MCFtpRepository 187880 host: ''modules.squeakfoundation.org'' 187881 directory: ''mc'' 187882 user: ''squeak'' 187883 password: ''squeak''' 187884 ! ! 187885 187886!MCFtpRepository class methodsFor: 'as yet unclassified' stamp: 'avi 9/16/2003 13:57'! 187887description 187888 ^ 'FTP'! ! 187889 187890!MCFtpRepository class methodsFor: 'as yet unclassified' stamp: 'avi 9/16/2003 13:57'! 187891host: host directory: directory user: user password: password 187892 ^ self new 187893 host: host; 187894 directory: directory; 187895 user: user; 187896 password: password! ! 187897 187898!MCFtpRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:38'! 187899templateCreationSelector 187900 ^ #host:directory:user:password: ! ! 187901MCRepository subclass: #MCGOODSRepository 187902 instanceVariableNames: 'hostname port connection' 187903 classVariableNames: '' 187904 poolDictionaries: '' 187905 category: 'Monticello-Repositories'! 187906 187907!MCGOODSRepository methodsFor: '*MonticelloGUI' stamp: 'avi 2/28/2004 20:10'! 187908morphicOpen: aWorkingCopy 187909 (MCRepositoryInspector repository: self workingCopy: aWorkingCopy) show! ! 187910 187911 187912!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:20'! 187913basicStoreVersion: aVersion 187914 self root at: aVersion info put: aVersion. 187915 self db commit.! ! 187916 187917!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'md 9/6/2005 18:37'! 187918db 187919 (connection isNil or: [connection isConnected not]) ifTrue: [ 187920 connection := Smalltalk at: #KKDatabase ifPresent: [:cl | 187921 cl onHost:hostname port: port 187922 ] 187923 ]. 187924 ^ connection! ! 187925 187926!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:35'! 187927description 187928 ^ 'goods://', hostname asString, ':', port asString! ! 187929 187930!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187931host: aString 187932 hostname := aString! ! 187933 187934!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:17'! 187935packages 187936 ^ (self root collect: [:ea | ea package]) asSet asSortedCollection! ! 187937 187938!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 187939port: aNumber 187940 port := aNumber! ! 187941 187942!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 14:35'! 187943root 187944 self db root ifNil: [self db root: Dictionary new]. 187945 ^ self db root! ! 187946 187947!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:18'! 187948versionsAvailableForPackage: aPackage 187949 ^ self root asArray select: [:ea | ea package = aPackage] thenCollect: [:ea | ea info]! ! 187950 187951!MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:21'! 187952versionWithInfo: aVersionInfo ifAbsent: errorBlock 187953 ^ self root at: aVersionInfo ifAbsent: errorBlock! ! 187954 187955"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 187956 187957MCGOODSRepository class 187958 instanceVariableNames: ''! 187959 187960!MCGOODSRepository class methodsFor: '*MonticelloGUI' stamp: 'avi 2/28/2004 20:33'! 187961fillInTheBlankRequest 187962 ^ 'GOODS Repository:'! ! 187963 187964!MCGOODSRepository class methodsFor: '*MonticelloGUI' stamp: 'avi 2/28/2004 20:35'! 187965morphicConfigure 187966 ^ self fillInTheBlankConfigure! ! 187967 187968 187969!MCGOODSRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:36'! 187970creationTemplate 187971 ^ 187972'MCGOODSRepository 187973 host: ''localhost'' 187974 port: 6100'! ! 187975 187976!MCGOODSRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 14:33'! 187977description 187978 ^ 'GOODS'! ! 187979 187980!MCGOODSRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:36'! 187981host: hostname port: portNumber 187982 ^ self new 187983 host: hostname; 187984 port: portNumber! ! 187985MCFileBasedRepository subclass: #MCHttpRepository 187986 instanceVariableNames: 'location user password readerCache' 187987 classVariableNames: '' 187988 poolDictionaries: '' 187989 category: 'Monticello-Repositories'! 187990 187991!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'bf 4/14/2005 17:49'! 187992asCreationTemplate 187993 ^self class creationTemplateLocation: location user: user password: password! ! 187994 187995!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/24/2003 22:17'! 187996locationWithTrailingSlash 187997 ^ (location endsWith: '/') 187998 ifTrue: [location] 187999 ifFalse: [location, '/']! ! 188000 188001!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188002location: aUrlString 188003 location := aUrlString! ! 188004 188005!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188006parseFileNamesFromStream: aStream 188007 | names fullName | 188008 names := OrderedCollection new. 188009 [aStream atEnd] whileFalse: 188010 [[aStream upTo: $<. {$a. $A. nil} includes: aStream next] whileFalse. 188011 aStream upTo: $". 188012 aStream atEnd ifFalse: [ 188013 fullName := aStream upTo: $". 188014 names add: fullName unescapePercents]]. 188015 ^ names! ! 188016 188017!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'DamienCassou 9/29/2009 13:00'! 188018password 188019 self userAndPasswordFromSettingsDo: [:usr :pwd | ^pwd]. 188020 188021 self user isEmpty ifTrue: [^password ifNil: ['']]. 188022 188023 [password isEmptyOrNil] whileTrue: [ 188024 | answer | 188025 "Give the user a chance to change the login" 188026 answer := UIManager default request: 'User name for ', String cr, location 188027 initialAnswer: self user. 188028 answer isEmptyOrNil 188029 ifTrue: [^password] 188030 ifFalse: [self user: answer]. 188031 188032 password := UIManager default requestPassword: 'Password for "', self user, '" at ', String cr, location. 188033 ]. 188034 188035 ^ password! ! 188036 188037!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188038password: passwordString 188039 password := passwordString! ! 188040 188041!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 13:08'! 188042urlForFileNamed: aString 188043 ^ self locationWithTrailingSlash, aString encodeForHTTP! ! 188044 188045!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'bf 8/12/2009 11:21'! 188046user 188047 self userAndPasswordFromSettingsDo: [:usr :pwd | ^usr]. 188048 "not in settings" 188049 ^user ifNil: ['']! ! 188050 188051!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188052userAndPasswordFromSettingsDo: aBlock 188053 "The mcSettings file in ExternalSettings preferenceDirectory should contain entries for each account: 188054 188055 account1: *myhost.mydomain* user:password 188056 account2: *otherhost.mydomain/somerep* dXNlcjpwYXNzd29yZA== 188057 188058 That is it must start with 'account', followed by anything to distinguish accounts, and a colon. Then comes a match expression for the repository url, and after a space the user:password string. 188059 188060 To not have the clear text password on your disc, you can base64 encode it: 188061 (Base64MimeConverter mimeEncode: 'user:password' readStream) contents 188062 " 188063 188064 | entry userAndPassword | 188065 Settings ifNotNil: [ 188066 Settings keysAndValuesDo: [:key :value | 188067 (key asLowercase beginsWith: 'account') ifTrue: [ 188068 entry := value findTokens: ' '. 188069 (entry first match: location) ifTrue: [ 188070 userAndPassword := entry second. 188071 (userAndPassword includes: $:) ifFalse: [ 188072 userAndPassword := (Base64MimeConverter mimeDecodeToChars: userAndPassword readStream) contents]. 188073 userAndPassword := userAndPassword findTokens: $:. 188074 ^aBlock value: userAndPassword first 188075 value: userAndPassword second 188076 ] 188077 ] 188078 ] 188079 ]. 188080 ^nil! ! 188081 188082!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188083user: userString 188084 user := userString! ! 188085 188086!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188087versionReaderForFileNamed: aString 188088 readerCache ifNil: [readerCache := Dictionary new]. 188089 ^ readerCache at: aString ifAbsent: 188090 [self resizeCache: readerCache. 188091 super versionReaderForFileNamed: aString do: 188092 [:r | 188093 r ifNotNil: [readerCache at: aString put: r]]] 188094 ! ! 188095 188096!MCHttpRepository methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 188097versionReaderForFileNamed: aString do: aBlock 188098 ^ (self versionReaderForFileNamed: aString) ifNotNil: aBlock! ! 188099 188100 188101!MCHttpRepository methodsFor: 'required' stamp: 'stephaneducasse 2/4/2006 20:47'! 188102allFileNames 188103 | index | 188104 index := HTTPSocket httpGet: self locationWithTrailingSlash, '?C=M;O=D' args: nil user: self user passwd: self password. 188105 index isString ifTrue: [self error: 'Could not access ', location]. 188106 ^ self parseFileNamesFromStream: index ! ! 188107 188108!MCHttpRepository methodsFor: 'required' stamp: 'ab 7/24/2003 21:10'! 188109description 188110 ^ location! ! 188111 188112!MCHttpRepository methodsFor: 'required' stamp: 'al 12/12/2005 11:06'! 188113flushCache 188114 super flushCache. 188115 readerCache := nil.! ! 188116 188117!MCHttpRepository methodsFor: 'required' stamp: 'stephaneducasse 2/4/2006 20:47'! 188118readStreamForFileNamed: aString do: aBlock 188119 | contents | 188120 contents := HTTPSocket httpGet: (self urlForFileNamed: aString) args: nil user: self user passwd: self password. 188121 ^ contents isString ifFalse: [aBlock value: contents]! ! 188122 188123!MCHttpRepository methodsFor: 'required' stamp: 'stephaneducasse 2/4/2006 20:47'! 188124writeStreamForFileNamed: aString replace: ignoreBoolean do: aBlock 188125 | stream response | 188126 stream := RWBinaryOrTextStream on: String new. 188127 aBlock value: stream. 188128 response := HTTPSocket 188129 httpPut: stream contents 188130 to: (self urlForFileNamed: aString) 188131 user: self user 188132 passwd: self password. 188133 188134 (#( 'HTTP/1.1 201 ' 'HTTP/1.1 200 ' 'HTTP/1.0 201 ' 'HTTP/1.0 200 ') 188135 anySatisfy: [:code | response beginsWith: code ]) 188136 ifFalse: [self error: response].! ! 188137 188138"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 188139 188140MCHttpRepository class 188141 instanceVariableNames: ''! 188142 188143!MCHttpRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:00'! 188144fillInTheBlankRequest 188145 ^ 'HTTP Repository:' 188146 ! ! 188147 188148!MCHttpRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:01'! 188149morphicConfigure 188150 ^ self fillInTheBlankConfigure! ! 188151 188152 188153!MCHttpRepository class methodsFor: 'as yet unclassified' stamp: 'stephane.ducasse 5/24/2008 16:54'! 188154creationTemplate 188155 ^self creationTemplateLocation: 'http://www.squeaksource.com/' 188156 user: 'squeak' 188157 password: 'squeak' 188158! ! 188159 188160!MCHttpRepository class methodsFor: 'as yet unclassified' stamp: 'bf 4/14/2005 15:27'! 188161creationTemplateLocation: location user: user password: password 188162 ^ 188163'MCHttpRepository 188164 location: {1} 188165 user: {2} 188166 password: {3}' format: {location printString. user printString. password printString}! ! 188167 188168!MCHttpRepository class methodsFor: 'as yet unclassified' stamp: 'ab 7/24/2003 21:20'! 188169description 188170 ^ 'HTTP'! ! 188171 188172!MCHttpRepository class methodsFor: 'as yet unclassified' stamp: 'ab 7/24/2003 21:32'! 188173location: location user: user password: password 188174 ^ self new 188175 location: location; 188176 user: user; 188177 password: password! ! 188178 188179 188180!MCHttpRepository class methodsFor: 'initialization' stamp: 'bf 7/28/2005 19:44'! 188181clearPasswords 188182 self allSubInstancesDo: [:ea | ea password: '']. 188183! ! 188184MCTestCase subclass: #MCInitializationTest 188185 instanceVariableNames: '' 188186 classVariableNames: '' 188187 poolDictionaries: '' 188188 category: 'Tests-Monticello'! 188189 188190!MCInitializationTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/11/2003 23:06'! 188191tearDown 188192 (MCWorkingCopy forPackage: self mockPackage) unregister! ! 188193 188194!MCInitializationTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/11/2003 23:50'! 188195testWorkingCopy 188196 MczInstaller storeVersionInfo: self mockVersion. 188197 MCWorkingCopy initialize. 188198 MCWorkingCopy allManagers 188199 detect: [:man | man package name = self mockPackage name] 188200 ifNone: [self assert: false]! ! 188201 188202"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 188203 188204MCInitializationTest class 188205 instanceVariableNames: ''! 188206 188207!MCInitializationTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 12:11'! 188208isAbstract 188209 ^ (Smalltalk hasClassNamed: #MczInstaller) not 188210 ! ! 188211MCVariableDefinition subclass: #MCInstanceVariableDefinition 188212 instanceVariableNames: '' 188213 classVariableNames: '' 188214 poolDictionaries: '' 188215 category: 'Monticello-Modeling'! 188216 188217!MCInstanceVariableDefinition methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 23:32'! 188218isInstanceVariable 188219 ^ true! ! 188220 188221"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 188222 188223MCInstanceVariableDefinition class 188224 instanceVariableNames: ''! 188225 188226!MCInstanceVariableDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 22:59'! 188227type 188228 ^ #instance! ! 188229MCMczReader subclass: #MCMcdReader 188230 instanceVariableNames: 'baseInfo patch' 188231 classVariableNames: '' 188232 poolDictionaries: '' 188233 category: 'Monticello-Storing'! 188234 188235!MCMcdReader methodsFor: 'as yet unclassified' stamp: 'avi 2/14/2004 21:33'! 188236baseInfo 188237 ^ baseInfo ifNil: [self loadBaseInfo]! ! 188238 188239!MCMcdReader methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:41'! 188240basicVersion 188241 ^ MCDiffyVersion 188242 package: self package 188243 info: self info 188244 dependencies: self dependencies 188245 baseInfo: self baseInfo 188246 patch: self patch! ! 188247 188248!MCMcdReader methodsFor: 'as yet unclassified' stamp: 'avi 2/14/2004 21:37'! 188249buildPatchFrom: oldDefinitions to: newDefinitions 188250 ^ MCPatch 188251 fromBase: (MCSnapshot fromDefinitions: oldDefinitions) 188252 target: (MCSnapshot fromDefinitions: newDefinitions)! ! 188253 188254!MCMcdReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188255loadBaseInfo 188256 ^ baseInfo := self extractInfoFrom: (self parseMember: 'base')! ! 188257 188258!MCMcdReader methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 188259loadPatch 188260 | old new | 188261 (self zip memberNamed: 'patch.bin') ifNotNil: 188262 [:m | [^ patch := (DataStream on: m contentStream) next ] 188263 on: Error do: [:fallThrough ]]. 188264 definitions := OrderedCollection new. 188265 (self zip membersMatching: 'old/*') 188266 do: [:m | self extractDefinitionsFrom: m]. 188267 old := definitions asArray. 188268 definitions := OrderedCollection new. 188269 (self zip membersMatching: 'new/*') 188270 do: [:m | self extractDefinitionsFrom: m]. 188271 new := definitions asArray. 188272 ^ patch := self buildPatchFrom: old to: new. 188273 ! ! 188274 188275!MCMcdReader methodsFor: 'as yet unclassified' stamp: 'avi 2/14/2004 21:34'! 188276patch 188277 ^ patch ifNil: [self loadPatch]! ! 188278 188279"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 188280 188281MCMcdReader class 188282 instanceVariableNames: ''! 188283 188284!MCMcdReader class methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:09'! 188285extension 188286 ^ 'mcd'! ! 188287MCMczWriter subclass: #MCMcdWriter 188288 instanceVariableNames: '' 188289 classVariableNames: '' 188290 poolDictionaries: '' 188291 category: 'Monticello-Storing'! 188292 188293!MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188294writeBaseInfo: aVersionInfo 188295 | string | 188296 string := self serializeVersionInfo: aVersionInfo. 188297 self addString: string at: 'base'. 188298! ! 188299 188300!MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 01:48'! 188301writeDefinitions: aVersion 188302 self writeBaseInfo: aVersion baseInfo. 188303 self writePatch: aVersion patch.! ! 188304 188305!MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 02:07'! 188306writeNewDefinitions: aCollection 188307 self addString: (self serializeDefinitions: aCollection) at: 'new/source.', self snapshotWriterClass extension.! ! 188308 188309!MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 02:07'! 188310writeOldDefinitions: aCollection 188311 self addString: (self serializeDefinitions: aCollection) at: 'old/source.', self snapshotWriterClass extension.! ! 188312 188313!MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188314writePatch: aPatch 188315 | old new | 188316 old := OrderedCollection new. 188317 new := OrderedCollection new. 188318 aPatch operations do: 188319 [:ea | 188320 ea isRemoval ifTrue: [old add: ea definition]. 188321 ea isAddition ifTrue: [new add: ea definition]. 188322 ea isModification ifTrue: [old add: ea baseDefinition. new add: ea definition]]. 188323 self writeOldDefinitions: old. 188324 self writeNewDefinitions: new. 188325 self addString: (self serializeInBinary: aPatch) at: 'patch.bin'.! ! 188326 188327"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 188328 188329MCMcdWriter class 188330 instanceVariableNames: ''! 188331 188332!MCMcdWriter class methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:09'! 188333readerClass 188334 ^ MCMcdReader! ! 188335MCVersionReader subclass: #MCMcmReader 188336 instanceVariableNames: 'fileName configuration' 188337 classVariableNames: '' 188338 poolDictionaries: '' 188339 category: 'MonticelloConfigurations'! 188340 188341!MCMcmReader methodsFor: 'accessing' stamp: 'bf 11/26/2005 20:26'! 188342configuration 188343 configuration ifNil: [self loadConfiguration]. 188344 "browser modifies configuration, but the reader might get cached" 188345 ^configuration copy! ! 188346 188347!MCMcmReader methodsFor: 'accessing' stamp: 'bf 3/23/2005 01:17'! 188348configurationName 188349 ^fileName ifNotNil: [(fileName findTokens: '/\:') last copyUpToLast: $.]! ! 188350 188351!MCMcmReader methodsFor: 'accessing' stamp: 'bf 3/23/2005 01:17'! 188352fileName: aString 188353 fileName := aString! ! 188354 188355!MCMcmReader methodsFor: 'accessing' stamp: 'bf 11/16/2005 11:03'! 188356loadConfiguration 188357 stream reset. 188358 configuration := MCConfiguration fromArray: (MCScanner scan: stream). 188359 configuration name: self configurationName. 188360! ! 188361 188362!MCMcmReader methodsFor: 'accessing' stamp: 'bf 11/16/2005 11:01'! 188363loadVersionInfo 188364 info := self configuration! ! 188365 188366!MCMcmReader methodsFor: 'accessing' stamp: 'bf 11/16/2005 11:01'! 188367version 188368 ^self configuration! ! 188369 188370"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 188371 188372MCMcmReader class 188373 instanceVariableNames: ''! 188374 188375!MCMcmReader class methodsFor: 'accessing' stamp: 'bf 3/22/2005 10:47'! 188376extension 188377 ^ 'mcm'! ! 188378 188379 188380!MCMcmReader class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:47'! 188381on: aStream fileName: aFileName 188382 | reader | 188383 reader := self on: aStream. 188384 reader fileName: aFileName. 188385 ^reader! ! 188386MCWriter subclass: #MCMcmWriter 188387 instanceVariableNames: '' 188388 classVariableNames: '' 188389 poolDictionaries: '' 188390 category: 'MonticelloConfigurations'! 188391 188392!MCMcmWriter methodsFor: 'writing' stamp: 'bf 3/22/2005 18:00'! 188393close 188394 stream close! ! 188395 188396!MCMcmWriter methodsFor: 'writing' stamp: 'bf 3/24/2005 01:50'! 188397writeConfiguration: aConfiguration 188398 188399 stream nextPut: $(. 188400 188401 aConfiguration repositories do: [:ea | 188402 stream cr. 188403 stream nextPutAll: 'repository '. 188404 (MCConfiguration repositoryToArray: ea) printElementsOn: stream]. 188405 188406 aConfiguration dependencies do: [:ea | 188407 stream cr. 188408 stream nextPutAll: 'dependency '. 188409 (MCConfiguration dependencyToArray: ea) printElementsOn: stream]. 188410 188411 stream cr. 188412 stream nextPut: $). 188413 stream cr.! ! 188414 188415"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 188416 188417MCMcmWriter class 188418 instanceVariableNames: ''! 188419 188420!MCMcmWriter class methodsFor: 'accessing' stamp: 'bf 3/22/2005 10:49'! 188421readerClass 188422 ^ MCMcmReader! ! 188423 188424 188425!MCMcmWriter class methodsFor: 'writing' stamp: 'stephaneducasse 2/4/2006 20:47'! 188426fileOut: aConfiguration on: aStream 188427 | inst | 188428 inst := self on: aStream. 188429 inst writeConfiguration: aConfiguration. 188430 inst close. 188431 188432! ! 188433MCTestCase subclass: #MCMczInstallerTest 188434 instanceVariableNames: 'expected diff' 188435 classVariableNames: '' 188436 poolDictionaries: '' 188437 category: 'Tests-Monticello'! 188438 188439!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 188440assertDict: dict matchesInfo: info 188441 #(name id message date time author) 188442 do: [:sel | (info perform: sel) ifNotNil: [:i | dict at: sel ifPresent: [:d | self assert: i = d]]]. 188443 info ancestors 188444 with: (dict at: #ancestors) 188445 do: [:i :d | self assertDict: d matchesInfo: i]! ! 188446 188447!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188448assertNoChange 188449 | actual | 188450 actual := MCSnapshotResource takeSnapshot. 188451 diff := actual patchRelativeToBase: expected snapshot. 188452 self assert: diff isEmpty! ! 188453 188454!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188455assertVersionInfoPresent 188456 | dict info | 188457 dict := MczInstaller versionInfo at: self mockPackage name. 188458 info := expected info. 188459 self assertDict: dict matchesInfo: info.! ! 188460 188461!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 18:18'! 188462deleteFile 188463 (FileDirectory default fileExists: self fileName) 188464 ifTrue: [FileDirectory default deleteFileNamed: self fileName]! ! 188465 188466!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 18:15'! 188467fileName 188468 ^ 'InstallerTest.mcz'! ! 188469 188470!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 18:16'! 188471fileStream 188472 ^ FileStream forceNewFileNamed: self fileName.! ! 188473 188474!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188475setUp 188476 expected := self mockVersion. 188477 self change: #one toReturn: 2.! ! 188478 188479!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 19:36'! 188480tearDown 188481 expected snapshot updatePackage: self mockPackage. 188482 self deleteFile.! ! 188483 188484!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 16:25'! 188485testInstallFromFile 188486 MCMczWriter fileOut: expected on: self fileStream. 188487 MczInstaller installFileNamed: self fileName. 188488 self assertNoChange.! ! 188489 188490!MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188491testInstallFromStream 188492 | stream | 188493 stream := RWBinaryOrTextStream on: String new. 188494 MCMczWriter fileOut: expected on: stream. 188495 MczInstaller installStream: stream reset. 188496 self assertNoChange. 188497 self assertVersionInfoPresent. 188498 ! ! 188499 188500"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 188501 188502MCMczInstallerTest class 188503 instanceVariableNames: ''! 188504 188505!MCMczInstallerTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 12:11'! 188506isAbstract 188507 ^ (Smalltalk hasClassNamed: #MczInstaller) not 188508 ! ! 188509 188510!MCMczInstallerTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 11:56'! 188511suite 188512 ^ (Smalltalk hasClassNamed: #MczInstaller) 188513 ifTrue: [super suite] 188514 ifFalse: [TestSuite new name: self name asString]! ! 188515MCVersionReader subclass: #MCMczReader 188516 instanceVariableNames: 'zip infoCache' 188517 classVariableNames: '' 188518 poolDictionaries: '' 188519 category: 'Monticello-Storing'! 188520 188521!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephane.ducasse 3/31/2009 21:23'! 188522associate: tokens 188523 | result | 188524 result := Dictionary new. 188525 tokens pairsDo: [:key :value | 188526 | tmp | 188527 tmp := value. 188528 value isString ifFalse: [tmp := value collect: [:ea | self associate: ea]]. 188529 value = 'nil' ifTrue: [tmp := '']. 188530 result at: key put: tmp]. 188531 ^ result! ! 188532 188533!MCMczReader methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 188534extractDefinitionsFrom: member 188535 | reader | 188536 (MCSnapshotReader readerClassForFileNamed: member fileName) 188537 ifNotNil: [:rc | reader := rc on: member contentStream text. 188538 definitions addAll: reader definitions] 188539! ! 188540 188541!MCMczReader methodsFor: 'as yet unclassified' stamp: 'avi 1/19/2004 16:11'! 188542extractDependencyFrom: zipMember 188543 ^ MCVersionDependency 188544 package: (MCPackage named: (zipMember fileName copyAfterLast: $/)) 188545 info: (self extractInfoFrom: (self parseMember: zipMember fileName))! ! 188546 188547!MCMczReader methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 23:38'! 188548extractInfoFrom: dict 188549 ^ self infoCache at: (dict at: #id) ifAbsentPut: 188550 [MCVersionInfo 188551 name: (dict at: #name ifAbsent: ['']) 188552 id: (UUID fromString: (dict at: #id)) 188553 message: (dict at: #message ifAbsent: ['']) 188554 date: ([Date fromString: (dict at: #date) ] on: Error do: [ :ex | ex return: nil ]) 188555 time: ([ Time fromString:(dict at: #time)] on: Error do: [ :ex | ex return: nil ]) 188556 author: (dict at: #author ifAbsent: ['']) 188557 ancestors: ((dict at: #ancestors) collect: [:ea | self extractInfoFrom: ea]) 188558 stepChildren: ((dict at: #stepChildren ifAbsent: [#()]) collect: [:ea | self extractInfoFrom: ea])]! ! 188559 188560!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188561infoCache 188562 ^ infoCache ifNil: [infoCache := Dictionary new]! ! 188563 188564!MCMczReader methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 188565loadDefinitions 188566 definitions := OrderedCollection new. 188567 (self zip memberNamed: 'snapshot.bin') ifNotNil: 188568 [:m | [^ definitions := (DataStream on: m contentStream) next definitions] 188569 on: Error do: [:fallThrough ]]. 188570 "otherwise" 188571 (self zip membersMatching: 'snapshot/*') 188572 do: [:m | self extractDefinitionsFrom: m]. 188573! ! 188574 188575!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188576loadDependencies 188577 dependencies := (self zip membersMatching: 'dependencies/*') collect: [:m | self extractDependencyFrom: m]. 188578 dependencies := dependencies asArray. 188579! ! 188580 188581!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188582loadPackage 188583 | dict | 188584 dict := self parseMember: 'package'. 188585 package := MCPackage named: (dict at: #name)! ! 188586 188587!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188588loadVersionInfo 188589 info := self extractInfoFrom: (self parseMember: 'version')! ! 188590 188591!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188592parseMember: fileName 188593 | tokens | 188594 tokens := (self scanner scanTokens: (self zip contentsOf: fileName)) first. 188595 ^ self associate: tokens! ! 188596 188597!MCMczReader methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 20:33'! 188598scanner 188599 ^ MCScanner! ! 188600 188601!MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188602zip 188603 zip ifNil: 188604 [zip := ZipArchive new. 188605 zip readFrom: stream]. 188606 ^ zip! ! 188607 188608"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 188609 188610MCMczReader class 188611 instanceVariableNames: ''! 188612 188613!MCMczReader class methodsFor: 'accessing' stamp: 'cwp 8/1/2003 14:59'! 188614extension 188615 ^ 'mcz'! ! 188616 188617 188618!MCMczReader class methodsFor: 'testing' stamp: 'avi 1/19/2004 14:48'! 188619supportsDependencies 188620 ^ true! ! 188621 188622!MCMczReader class methodsFor: 'testing' stamp: 'cwp 8/1/2003 12:19'! 188623supportsVersions 188624 ^ true! ! 188625MCWriter subclass: #MCMczWriter 188626 instanceVariableNames: 'zip infoWriter' 188627 classVariableNames: '' 188628 poolDictionaries: '' 188629 category: 'Monticello-Storing'! 188630 188631!MCMczWriter methodsFor: 'accessing' stamp: 'avi 2/17/2004 01:54'! 188632format 188633 ^ '1'! ! 188634 188635!MCMczWriter methodsFor: 'accessing' stamp: 'avi 2/17/2004 02:07'! 188636snapshotWriterClass 188637 ^ MCStWriter! ! 188638 188639!MCMczWriter methodsFor: 'accessing' stamp: 'cwp 8/1/2003 00:06'! 188640zip 188641 ^ zip! ! 188642 188643 188644!MCMczWriter methodsFor: 'initializing' stamp: 'alain.plantec 5/28/2009 10:03'! 188645initialize 188646 super initialize. 188647 zip := ZipArchive new. 188648! ! 188649 188650 188651!MCMczWriter methodsFor: 'serializing' stamp: 'stephaneducasse 2/4/2006 20:47'! 188652serializeDefinitions: aCollection 188653 | writer s | 188654 s := RWBinaryOrTextStream on: String new. 188655 writer := self snapshotWriterClass on: s. 188656 writer writeDefinitions: aCollection. 188657 ^ s contents! ! 188658 188659!MCMczWriter methodsFor: 'serializing' stamp: 'stephaneducasse 2/4/2006 20:47'! 188660serializeInBinary: aSnapshot 188661 | writer s | 188662 s := RWBinaryOrTextStream on: String new. 188663 writer := DataStream on: s. 188664 writer nextPut: aSnapshot. 188665 ^ s contents! ! 188666 188667!MCMczWriter methodsFor: 'serializing' stamp: 'cwp 8/13/2003 01:06'! 188668serializePackage: aPackage 188669 ^ '(name ''', aPackage name, ''')'! ! 188670 188671!MCMczWriter methodsFor: 'serializing' stamp: 'stephaneducasse 2/4/2006 20:47'! 188672serializeVersionInfo: aVersionInfo 188673 infoWriter ifNil: [infoWriter := MCVersionInfoWriter new]. 188674 ^ String streamContents: 188675 [:s | 188676 infoWriter stream: s. 188677 infoWriter writeVersionInfo: aVersionInfo]! ! 188678 188679 188680!MCMczWriter methodsFor: 'visiting' stamp: 'avi 2/17/2004 01:48'! 188681writeDefinitions: aVersion 188682 self writeSnapshot: aVersion snapshot! ! 188683 188684!MCMczWriter methodsFor: 'visiting' stamp: 'avi 2/17/2004 01:56'! 188685writeFormat 188686" self addString: self format at: 'format'."! ! 188687 188688!MCMczWriter methodsFor: 'visiting' stamp: 'avi 2/17/2004 01:48'! 188689writePackage: aPackage 188690 self addString: (self serializePackage: aPackage) at: 'package'! ! 188691 188692!MCMczWriter methodsFor: 'visiting' stamp: 'avi 9/28/2004 14:26'! 188693writeSnapshot: aSnapshot 188694 self addString: (self serializeDefinitions: aSnapshot definitions) at: 'snapshot/source.', self snapshotWriterClass extension. 188695 self addString: (self serializeInBinary: aSnapshot) at: 'snapshot.bin'! ! 188696 188697!MCMczWriter methodsFor: 'visiting' stamp: 'stephaneducasse 2/4/2006 20:47'! 188698writeVersionDependency: aVersionDependency 188699 | string | 188700 string := (self serializeVersionInfo: aVersionDependency versionInfo). 188701 self addString: string at: 'dependencies/', aVersionDependency package name! ! 188702 188703!MCMczWriter methodsFor: 'visiting' stamp: 'stephaneducasse 2/4/2006 20:47'! 188704writeVersionInfo: aVersionInfo 188705 | string | 188706 string := self serializeVersionInfo: aVersionInfo. 188707 self addString: string at: 'version'. 188708! ! 188709 188710!MCMczWriter methodsFor: 'visiting' stamp: 'avi 9/13/2004 16:49'! 188711writeVersion: aVersion 188712 self writeFormat. 188713 self writePackage: aVersion package. 188714 self writeVersionInfo: aVersion info. 188715 self writeDefinitions: aVersion. 188716 aVersion dependencies do: [:ea | self writeVersionDependency: ea]! ! 188717 188718 188719!MCMczWriter methodsFor: 'writing' stamp: 'stephaneducasse 2/4/2006 20:47'! 188720addString: string at: path 188721 | member | 188722 member := zip addString: string as: path. 188723 member desiredCompressionMethod: ZipArchive compressionDeflated 188724 ! ! 188725 188726!MCMczWriter methodsFor: 'writing' stamp: 'avi 2/17/2004 02:17'! 188727flush 188728 zip writeTo: stream. 188729 stream close! ! 188730 188731"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 188732 188733MCMczWriter class 188734 instanceVariableNames: ''! 188735 188736!MCMczWriter class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188737fileOut: aVersion on: aStream 188738 | inst | 188739 inst := self on: aStream. 188740 inst writeVersion: aVersion. 188741 inst flush. 188742 188743! ! 188744 188745!MCMczWriter class methodsFor: 'as yet unclassified' stamp: 'cwp 8/1/2003 12:35'! 188746readerClass 188747 ^ MCMczReader! ! 188748MCPatchBrowser subclass: #MCMergeBrowser 188749 instanceVariableNames: 'conflicts merger ok' 188750 classVariableNames: '' 188751 poolDictionaries: '' 188752 category: 'MonticelloGUI'! 188753 188754!MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 4/2/2009 13:14'! 188755selection: aNumber 188756 "Notify change of conflicts too." 188757 188758 super selection: aNumber. 188759 self changed: #selectionIsConflicted! ! 188760 188761 188762!MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff-override' stamp: 'gvc 5/16/2007 10:40'! 188763chooseAllNewerConflicts 188764 "Notify the potential new state of canMerge." 188765 188766 conflicts do: [ :ea | ea chooseNewer ]. 188767 self changed: #text; changed: #list; changed: #canMerge! ! 188768 188769!MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff-override' stamp: 'gvc 5/16/2007 10:41'! 188770chooseAllOlderConflicts 188771 "Notify the potential new state of canMerge." 188772 188773 conflicts do: [ :ea | ea chooseOlder ]. 188774 self changed: #text; changed: #list; changed: #canMerge! ! 188775 188776!MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff-override' stamp: 'gvc 5/16/2007 10:41'! 188777chooseAllUnchosenLocal 188778 "Notify the potential new state of canMerge." 188779 188780 conflicts do: [ :ea | ea isResolved ifFalse: [ ea chooseLocal ] ]. 188781 self changed: #text; changed: #list; changed: #canMerge! ! 188782 188783!MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff-override' stamp: 'gvc 5/16/2007 10:41'! 188784chooseAllUnchosenRemote 188785 "Notify the potential new state of canMerge." 188786 188787 conflicts do: [ :ea | ea isResolved ifFalse: [ ea chooseRemote ] ]. 188788 self changed: #text; changed: #list; changed: #canMerge! ! 188789 188790!MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff-override' stamp: 'gvc 5/16/2007 10:41'! 188791chooseLocal 188792 "Notify the potential new state of canMerge." 188793 188794 self conflictSelectionDo: 188795 [selection chooseLocal. 188796 self changed: #text; changed: #list; changed: #canMerge]! ! 188797 188798!MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff-override' stamp: 'gvc 5/16/2007 10:41'! 188799chooseRemote 188800 "Notify the potential new state of canMerge." 188801 188802 self conflictSelectionDo: 188803 [selection chooseRemote. 188804 self changed: #text; changed: #list; changed: #canMerge]! ! 188805 188806 188807!MCMergeBrowser methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/2/2009 16:51'! 188808widgetSpecs 188809 "ToolBuilder doesn't know about innerButtonRow. Made explicit here." 188810 188811 Preferences annotationPanes ifFalse: [ ^#( 188812 ((buttonRow) (0 0 1 0) (0 0 0 30)) 188813 ((listMorph:selection:menu: list selection methodListMenu:) (0 0 1 0.4) (0 30 0 0)) 188814 ((buttonRow: #((Keep chooseRemote 'keep the selected change' selectionIsConflicted) 188815 (Reject chooseLocal 'reject the selected change' selectionIsConflicted))) (0 0.4 1 0.4) (0 0 0 32)) 188816 ((textMorph: text) (0 0.4 1 1) (0 32 0 0)) 188817 )]. 188818 188819 ^ #( 188820 ((buttonRow) (0 0 1 0) (0 0 0 30)) 188821 ((listMorph:selection:menu: list selection methodListMenu:) (0 0 1 0.4) (0 30 0 0)) 188822 ((buttonRow: #((Keep chooseRemote 'keep the selected change' selectionIsConflicted) 188823 (Reject chooseLocal 'reject the selected change' selectionIsConflicted))) (0 0.4 1 0.4) (0 0 0 32)) 188824 ((textMorph: annotations) (0 0.4 1 0.4) (0 32 0 62)) 188825 ((textMorph: text) (0 0.4 1 1) (0 62 0 0)) 188826 )! ! 188827 188828 188829!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'nk 10/21/2003 23:35'! 188830buttonSpecs 188831 ^ #((Merge merge 'Proceed with the merge' canMerge) 188832 (Cancel cancel 'Cancel the merge') 188833 ('All Newer' chooseAllNewerConflicts 'Choose all newer conflict versions') 188834 ('All Older' chooseAllOlderConflicts 'Choose all older conflict versions') 188835 ('Rest Local' chooseAllUnchosenLocal 'Choose local versions of all remaining conflicts') 188836 ('Rest Remote' chooseAllUnchosenRemote 'Choose remote versions of all remaining conflicts') 188837)! ! 188838 188839!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 17:52'! 188840cancel 188841 self answer: false! ! 188842 188843!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/22/2003 00:51'! 188844canMerge 188845 ^ merger isMerged! ! 188846 188847!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:41'! 188848clearChoice 188849 self conflictSelectionDo: 188850 [selection clearChoice. 188851 self changed: #text; changed: #list]! ! 188852 188853!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:42'! 188854conflictSelectionDo: aBlock 188855 self selectionIsConflicted 188856 ifTrue: aBlock 188857 ifFalse: [self inform: 'You must have a conflict selected']! ! 188858 188859!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 21:31'! 188860defaultLabel 188861 ^ 'Merge Browser'! ! 188862 188863!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:04'! 188864getConflictMenu: aMenu 188865 selection remoteChosen 188866 ifTrue: [aMenu add: 'undo keep change' target: self selector: #clearChoice] 188867 ifFalse: [aMenu add: 'keep change' target: self selector: #chooseRemote]. 188868 selection localChosen 188869 ifTrue: [aMenu add: 'undo reject change' target: self selector: #clearChoice] 188870 ifFalse: [aMenu add: 'reject change' target: self selector: #chooseLocal]. 188871 ^ aMenu! ! 188872 188873!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:07'! 188874getMenu: aMenu 188875 selection ifNil: [^ aMenu]. 188876 ^ self selectionIsConflicted 188877 ifTrue: [self getConflictMenu: aMenu] 188878 ifFalse: [self getOperationMenu: aMenu]! ! 188879 188880!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 16:37'! 188881getOperationMenu: aMenu 188882 ^ aMenu! ! 188883 188884!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/22/2003 00:49'! 188885innerButtonRow 188886 ^ self buttonRow: 188887 #((Keep chooseRemote 'keep the selected change' selectionIsConflicted) 188888 (Reject chooseLocal 'reject the selected change' selectionIsConflicted))! ! 188889 188890!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 16:32'! 188891items 188892 ^ conflicts, items! ! 188893 188894!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 17:52'! 188895merge 188896 merger isMerged 188897 ifFalse: [self inform: 'You must resolve all the conflicts first'] 188898 ifTrue: [self answer: true] ! ! 188899 188900!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'NikoSchwarz 10/17/2009 18:25'! 188901merger: aMerger 188902 merger := aMerger. 188903 items := aMerger operations asSortedCollection. 188904 conflicts := aMerger conflicts sort: [:a :b | a operation <= b operation].! ! 188905 188906!MCMergeBrowser methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:07'! 188907selectionIsConflicted 188908 ^ selection isKindOf: MCConflict! ! 188909 188910"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 188911 188912MCMergeBrowser class 188913 instanceVariableNames: ''! 188914 188915!MCMergeBrowser class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188916resolveConflictsInMerger: aMerger 188917 | inst | 188918 inst := self new merger: aMerger. 188919 ^ inst showModally ifNil: [false]! ! 188920Object subclass: #MCMergeRecord 188921 instanceVariableNames: 'version packageSnapshot ancestorInfo ancestor ancestorSnapshot imagePatch mergePatch' 188922 classVariableNames: '' 188923 poolDictionaries: '' 188924 category: 'Monticello-Versioning'! 188925 188926!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188927ancestorInfo 188928 ^ ancestorInfo ifNil: [ancestorInfo := version info commonAncestorWith: version workingCopy ancestry]! ! 188929 188930!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188931ancestorSnapshot 188932 ^ ancestorSnapshot ifNil: [ancestorSnapshot := version workingCopy findSnapshotWithVersionInfo: self ancestorInfo]! ! 188933 188934!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188935imageIsClean 188936 | ancestors | 188937 ancestors := version workingCopy ancestors. 188938 ^ ancestors size = 1 188939 and: [ancestors first = self ancestorInfo] 188940 and: [self imagePatch isEmpty]! ! 188941 188942!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188943imagePatch 188944 ^ imagePatch ifNil: [imagePatch := self packageSnapshot patchRelativeToBase: self ancestorSnapshot]! ! 188945 188946!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188947initializeWithVersion: aVersion 188948 version := aVersion! ! 188949 188950!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'abc 2/13/2004 17:14'! 188951isAncestorMerge 188952 ^ version workingCopy ancestry hasAncestor: version info! ! 188953 188954!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188955mergePatch 188956 ^ mergePatch ifNil: [mergePatch := version snapshot patchRelativeToBase: self ancestorSnapshot]! ! 188957 188958!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 188959packageSnapshot 188960 ^ packageSnapshot ifNil: [packageSnapshot := version package snapshot]! ! 188961 188962!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'abc 2/13/2004 17:14'! 188963updateWorkingCopy 188964 self isAncestorMerge ifFalse: 188965 [self imageIsClean 188966 ifTrue: [version workingCopy loaded: version] 188967 ifFalse: [version workingCopy merged: version]]! ! 188968 188969!MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'abc 2/13/2004 15:52'! 188970version 188971 ^ version! ! 188972 188973"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 188974 188975MCMergeRecord class 188976 instanceVariableNames: ''! 188977 188978!MCMergeRecord class methodsFor: 'as yet unclassified' stamp: 'abc 2/13/2004 15:52'! 188979version: aVersion 188980 ^ self basicNew initializeWithVersion: aVersion! ! 188981Notification subclass: #MCMergeResolutionRequest 188982 instanceVariableNames: 'merger' 188983 classVariableNames: '' 188984 poolDictionaries: '' 188985 category: 'Monticello-Versioning'! 188986 188987!MCMergeResolutionRequest methodsFor: '*MonticelloGUI' stamp: 'gvc 2/7/2009 11:26'! 188988defaultAction 188989 "Modally open a merge tool." 188990 188991 ^self viewMerger! ! 188992 188993 188994!MCMergeResolutionRequest methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 2/3/2009 13:27'! 188995viewMerger 188996 "Open a model browser to perform the merge and answer wheter merged." 188997 188998 ^Preferences useNewDiffToolsForMC 188999 ifTrue: [self viewPatchMerger] 189000 ifFalse: [(MCMergeBrowser new 189001 merger: merger; 189002 label: messageText) showModally]! ! 189003 189004!MCMergeResolutionRequest methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 2/3/2009 13:26'! 189005viewPatchMerger 189006 "Open a modal diff tools browser to perform the merge." 189007 189008 |m modalMorph| 189009 m := PSMCMergeMorph forMerger: self merger. 189010 modalMorph := (UIManager default respondsTo: #modalMorph) 189011 ifTrue: [UIManager default modalMorph] 189012 ifFalse: [World]. 189013 modalMorph openModal: ( 189014 m newWindow 189015 title: messageText). 189016 ^m merged! ! 189017 189018 189019!MCMergeResolutionRequest methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:19'! 189020merger 189021 ^ merger! ! 189022 189023!MCMergeResolutionRequest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 189024merger: aMerger 189025 merger := aMerger! ! 189026 189027"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189028 189029MCMergeResolutionRequest class 189030 instanceVariableNames: ''! 189031Object subclass: #MCMerger 189032 instanceVariableNames: 'conflicts' 189033 classVariableNames: '' 189034 poolDictionaries: '' 189035 category: 'Monticello-Merging'! 189036 189037!MCMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:10'! 189038addConflictWithOperation: anOperation 189039 self conflicts add: (MCConflict operation: anOperation)! ! 189040 189041!MCMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:01'! 189042applyTo: anObject 189043 self isMerged ifFalse: [self error: 'You must resolve all the conflicts first']. 189044 conflicts do: [:ea | ea applyTo: anObject]! ! 189045 189046!MCMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 189047conflicts 189048 ^ conflicts ifNil: [conflicts := OrderedCollection new]! ! 189049 189050!MCMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/5/2003 19:09'! 189051isMerged 189052 ^ self conflicts allSatisfy: [:ea | ea isResolved]! ! 189053 189054!MCMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 189055load 189056 | loader | 189057 loader := MCPackageLoader new. 189058 loader provisions addAll: self provisions. 189059 self applyTo: loader. 189060 loader load! ! 189061 189062!MCMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 189063loadWithNameLike: baseName 189064 | loader | 189065 loader := MCPackageLoader new. 189066 loader provisions addAll: self provisions. 189067 self applyTo: loader. 189068 loader loadWithNameLike: baseName! ! 189069 189070!MCMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:11'! 189071mergedSnapshot 189072 ^ MCPatcher apply: self to: self baseSnapshot! ! 189073 189074!MCMerger methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 16:34'! 189075operations 189076 ^ #()! ! 189077 189078!MCMerger methodsFor: 'as yet unclassified' stamp: 'avi 10/6/2004 15:19'! 189079provisions 189080 ^ #()! ! 189081 189082"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189083 189084MCMerger class 189085 instanceVariableNames: ''! 189086MCTestCase subclass: #MCMergingTest 189087 instanceVariableNames: 'conflictBlock conflicts' 189088 classVariableNames: '' 189089 poolDictionaries: '' 189090 category: 'Tests-Monticello'! 189091 189092!MCMergingTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 189093assertMerge: local with: remote base: ancestor gives: result conflicts: conflictResult 189094 | merger | 189095 conflicts := #(). 189096 merger := MCThreeWayMerger 189097 base: (self snapshotWithElements: local) 189098 target: (self snapshotWithElements: remote) 189099 ancestor: (self snapshotWithElements: ancestor). 189100 merger conflicts do: [:ea | self handleConflict: ea]. 189101 self assert: merger mergedSnapshot definitions hasElements: result. 189102 self assert: conflicts asSet = conflictResult asSet.! ! 189103 189104!MCMergingTest methodsFor: 'asserting' stamp: 'ab 1/15/2003 16:46'! 189105assert: aCollection hasElements: anArray 189106 self assert: (aCollection collect: [:ea | ea token]) asSet = anArray asSet! ! 189107 189108 189109!MCMergingTest methodsFor: 'emulating' stamp: 'marcus.denker 11/10/2008 10:04'! 189110handleConflict: aConflict 189111 |l r| 189112 l := #removed. 189113 r := #removed. 189114 aConflict localDefinition ifNotNil: [:d | l := d token]. 189115 aConflict remoteDefinition ifNotNil: [:d | r := d token]. 189116 conflicts := conflicts copyWith: (Array with: r with: l). 189117 (l = #removed or: [r = #removed]) 189118 ifTrue: [aConflict chooseRemote] 189119 ifFalse: 189120 [l > r 189121 ifTrue: [aConflict chooseLocal] 189122 ifFalse: [aConflict chooseRemote]] 189123 ! ! 189124 189125!MCMergingTest methodsFor: 'emulating' stamp: 'ab 7/6/2003 23:48'! 189126snapshotWithElements: anArray 189127 ^ MCSnapshot 189128 fromDefinitions: (anArray collect: [:t | self mockToken: t])! ! 189129 189130 189131!MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 00:28'! 189132testAdditiveConflictlessMerge 189133 self 189134 assertMerge: #(a1 b1) 189135 with: #(a1 c1) 189136 base: #(a1) 189137 189138 gives: #(a1 b1 c1) 189139 conflicts: #()! ! 189140 189141!MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 00:27'! 189142testComplexConflictlessMerge 189143 self 189144 assertMerge: #(a1 b1 d1) 189145 with: #(a2 c1) 189146 base: #(a1 c1 d1) 189147 189148 gives: #(a2 b1) 189149 conflicts: #()! ! 189150 189151!MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 00:28'! 189152testIdenticalModification 189153 self 189154 assertMerge: #(a2 b1) 189155 with: #(a2 b1) 189156 base: #(a1 b1) 189157 189158 gives: #(a2 b1) 189159 conflicts: #()! ! 189160 189161!MCMergingTest methodsFor: 'tests' stamp: 'ab 6/2/2003 01:44'! 189162testLocalModifyRemoteRemove 189163 self assertMerge: #(a2 b1) 189164 with: #(b1) 189165 base: #(a1 b1) 189166 189167 gives: #(b1) 189168 conflicts: #((removed a2)). 189169 189170 self assertMerge: #(a1 b1) 189171 with: #(b1) 189172 base: #(a2 b1) 189173 189174 gives: #(b1) 189175 conflicts: #((removed a1)).! ! 189176 189177!MCMergingTest methodsFor: 'tests' stamp: 'ab 6/2/2003 01:43'! 189178testLocalRemoveRemoteModify 189179 self assertMerge: #(b1) 189180 with: #(a1 b1) 189181 base: #(a2 b1) 189182 189183 gives: #(a1 b1) 189184 conflicts: #((a1 removed)). 189185 189186 self assertMerge: #(b1) 189187 with: #(a2 b1) 189188 base: #(a1 b1) 189189 189190 gives: #(a2 b1) 189191 conflicts: #((a2 removed)).! ! 189192 189193!MCMergingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 189194testMultiPackageMerge 189195 | merger | 189196 conflicts := #(). 189197 merger := MCThreeWayMerger new. 189198 merger addBaseSnapshot: (self snapshotWithElements: #(a1 b1)). 189199 merger applyPatch: ((self snapshotWithElements: #()) patchRelativeToBase: (self snapshotWithElements: #(a1))). 189200 merger applyPatch: ((self snapshotWithElements: #(a2 b1)) patchRelativeToBase: (self snapshotWithElements: #(b1))). 189201 merger conflicts do: [:ea | self handleConflict: ea]. 189202 self assert: merger mergedSnapshot definitions hasElements: #(a2 b1). 189203 self assert: conflicts isEmpty! ! 189204 189205!MCMergingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 189206testMultiPackageMerge2 189207 | merger | 189208 conflicts := #(). 189209 merger := MCThreeWayMerger new. 189210 merger addBaseSnapshot: (self snapshotWithElements: #(a1 b1)). 189211 merger applyPatch: ((self snapshotWithElements: #()) patchRelativeToBase: (self snapshotWithElements: #(a1))). 189212 merger applyPatch: ((self snapshotWithElements: #(a1 b1)) patchRelativeToBase: (self snapshotWithElements: #(b1))). 189213 merger conflicts do: [:ea | self handleConflict: ea]. 189214 self assert: merger mergedSnapshot definitions hasElements: #(a1 b1). 189215 self assert: conflicts isEmpty! ! 189216 189217!MCMergingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 189218testMultiPackageMerge3 189219 | merger | 189220 conflicts := #(). 189221 merger := MCThreeWayMerger new. 189222 merger addBaseSnapshot: (self snapshotWithElements: #(a1 b1)). 189223 merger applyPatch: ((self snapshotWithElements: #(a1 b1)) patchRelativeToBase: (self snapshotWithElements: #(b1))). 189224 merger applyPatch: ((self snapshotWithElements: #()) patchRelativeToBase: (self snapshotWithElements: #(a1))). 189225 merger conflicts do: [:ea | self handleConflict: ea]. 189226 self assert: merger mergedSnapshot definitions hasElements: #(a1 b1). 189227 self assert: conflicts isEmpty! ! 189228 189229!MCMergingTest methodsFor: 'tests' stamp: 'ab 6/2/2003 01:38'! 189230testMultipleConflicts 189231 self assertMerge: #(a1 b3 c1) 189232 with: #(a1 b2 d1) 189233 base: #(a1 b1 c2) 189234 189235 gives: #(a1 b3 d1) 189236 conflicts: #((removed c1) (b2 b3)) 189237! ! 189238 189239!MCMergingTest methodsFor: 'tests' stamp: 'ab 6/2/2003 01:38'! 189240testSimultaneousModification 189241 self assertMerge: #(a2) 189242 with: #(a3) 189243 base: #(a1) 189244 189245 gives: #(a3) 189246 conflicts: #((a3 a2)).! ! 189247 189248!MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 01:27'! 189249testSimultaneousRemove 189250 self assertMerge: #(a1) 189251 with: #(a1) 189252 base: #(a1 b1) 189253 189254 gives: #(a1) 189255 conflicts: #()! ! 189256 189257!MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 01:31'! 189258testSubtractiveConflictlessMerge 189259 self assertMerge: #(a1 b1) 189260 with: #() 189261 base: #(a1) 189262 189263 gives: #(b1) 189264 conflicts: #()! ! 189265MCDefinition subclass: #MCMethodDefinition 189266 instanceVariableNames: 'classIsMeta source category selector className timeStamp' 189267 classVariableNames: 'Definitions' 189268 poolDictionaries: '' 189269 category: 'Monticello-Modeling'! 189270 189271!MCMethodDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:10'! 189272actualClass 189273 ^Smalltalk at: className 189274 ifPresent: [:class | classIsMeta ifTrue: [class classSide] ifFalse: [class]]! ! 189275 189276!MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 01:59'! 189277category 189278 ^ category! ! 189279 189280!MCMethodDefinition methodsFor: 'accessing' stamp: 'cwp 11/25/2002 07:26'! 189281classIsMeta 189282 ^ classIsMeta! ! 189283 189284!MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/15/2002 01:12'! 189285className 189286 ^className! ! 189287 189288!MCMethodDefinition methodsFor: 'accessing' stamp: 'nk 10/21/2003 23:08'! 189289fullTimeStamp 189290 ^TimeStamp fromMethodTimeStamp: timeStamp! ! 189291 189292!MCMethodDefinition methodsFor: 'accessing' stamp: 'avi 1/24/2004 18:38'! 189293load 189294 self actualClass 189295 compile: source 189296 classified: category 189297 withStamp: timeStamp 189298 notifying: (SyntaxError new category: category)! ! 189299 189300!MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/15/2002 01:11'! 189301selector 189302 ^selector! ! 189303 189304!MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 01:59'! 189305source 189306 ^ source! ! 189307 189308!MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 1/15/2003 13:42'! 189309timeStamp 189310 ^ timeStamp! ! 189311 189312 189313!MCMethodDefinition methodsFor: 'annotations' stamp: 'nk 7/24/2003 16:06'! 189314printAnnotations: requests on: aStream 189315 "Add a string for an annotation pane, trying to fulfill the annotation requests. 189316 These might include anything that 189317 Preferences defaultAnnotationRequests 189318 might return. Which includes anything in 189319 Preferences annotationInfo 189320 To edit these, use:" 189321 "Preferences editAnnotations" 189322 189323 requests do: [ :aRequest | 189324 aRequest == #timeStamp ifTrue: [ aStream nextPutAll: self timeStamp ]. 189325 aRequest == #messageCategory ifTrue: [ aStream nextPutAll: self category ]. 189326 aRequest == #requirements ifTrue: [ 189327 self requirements do: [ :req | 189328 aStream nextPutAll: req ] separatedBy: [ aStream space ]]. 189329 ] separatedBy: [ aStream space ].! ! 189330 189331 189332!MCMethodDefinition methodsFor: 'comparing' stamp: 'stephaneducasse 2/4/2006 20:47'! 189333hash 189334 | hash | 189335 hash := String stringHash: classIsMeta asString initialHash: 0. 189336 hash := String stringHash: source initialHash: hash. 189337 hash := String stringHash: category initialHash: hash. 189338 hash := String stringHash: className initialHash: hash. 189339 ^ hash! ! 189340 189341!MCMethodDefinition methodsFor: 'comparing' stamp: 'ab 5/24/2003 14:11'! 189342requirements 189343 ^ Array with: className! ! 189344 189345!MCMethodDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:01'! 189346sortKey 189347 ^ self className, '.', (self classIsMeta ifTrue: ['meta'] ifFalse: ['nonmeta']), '.', self selector! ! 189348 189349!MCMethodDefinition methodsFor: 'comparing' stamp: 'ab 8/22/2003 17:49'! 189350= aDefinition 189351 ^(super = aDefinition) 189352 and: [aDefinition source = self source] 189353 and: [aDefinition category = self category] 189354 and: [aDefinition timeStamp = self timeStamp]! ! 189355 189356 189357!MCMethodDefinition methodsFor: 'installing' stamp: 'rej 2/26/2007 10:42'! 189358addMethodAdditionTo: aCollection 189359 | methodAddition | 189360 methodAddition := MethodAddition new 189361 compile: source 189362 classified: category 189363 withStamp: timeStamp 189364 notifying: (SyntaxError new category: category) 189365 logSource: true 189366 inClass: self actualClass. 189367 "This might raise an exception and never return" 189368 methodAddition createCompiledMethod. 189369 aCollection add: methodAddition. 189370! ! 189371 189372!MCMethodDefinition methodsFor: 'installing' stamp: 'avi 9/17/2003 22:27'! 189373isExtensionMethod 189374 ^ category beginsWith: '*'! ! 189375 189376!MCMethodDefinition methodsFor: 'installing' stamp: 'avi 11/10/2003 15:45'! 189377isOverrideMethod 189378 "this oughta check the package" 189379 ^ self isExtensionMethod and: [category endsWith: '-override']! ! 189380 189381!MCMethodDefinition methodsFor: 'installing' stamp: 'al 10/13/2008 20:43'! 189382postloadOver: aDefinition 189383 super postloadOver: aDefinition. 189384 (self isInitializer 189385 and: [ self actualClass isTrait not ] 189386 and: [ aDefinition isNil or: [ self source ~= aDefinition source ] ]) ifTrue: [ 189387 self actualClass theNonMetaClass initialize ]! ! 189388 189389!MCMethodDefinition methodsFor: 'installing' stamp: 'stephaneducasse 2/4/2006 20:47'! 189390scanForPreviousVersion 189391 | position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp method file methodCategory | 189392 method := self actualClass compiledMethodAt: selector ifAbsent: [^ nil]. 189393 position := method filePosition. 189394 sourceFilesCopy := SourceFiles collect: 189395 [:x | x isNil ifTrue: [ nil ] 189396 ifFalse: [x readOnlyCopy]]. 189397 [method fileIndex == 0 ifTrue: [^ nil]. 189398 file := sourceFilesCopy at: method fileIndex. 189399 [position notNil & file notNil] 189400 whileTrue: 189401 [file position: (0 max: position-150). "Skip back to before the preamble" 189402 [file position < (position-1)] "then pick it up from the front" 189403 whileTrue: [preamble := file nextChunk]. 189404 189405 "Preamble is likely a linked method preamble, if we're in 189406 a changes file (not the sources file). Try to parse it 189407 for prior source position and file index" 189408 prevPos := nil. 189409 stamp := ''. 189410 (preamble findString: 'methodsFor:' startingAt: 1) > 0 189411 ifTrue: [tokens := Scanner new scanTokens: preamble] 189412 ifFalse: [tokens := Array new "ie cant be back ref"]. 189413 ((tokens size between: 7 and: 8) 189414 and: [(tokens at: tokens size-5) = #methodsFor:]) 189415 ifTrue: 189416 [(tokens at: tokens size-3) = #stamp: 189417 ifTrue: ["New format gives change stamp and unified prior pointer" 189418 stamp := tokens at: tokens size-2. 189419 prevPos := tokens last. 189420 prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos. 189421 prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos] 189422 ifFalse: ["Old format gives no stamp; prior pointer in two parts" 189423 prevPos := tokens at: tokens size-2. 189424 prevFileIndex := tokens last]. 189425 (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos := nil]]. 189426 ((tokens size between: 5 and: 6) 189427 and: [(tokens at: tokens size-3) = #methodsFor:]) 189428 ifTrue: 189429 [(tokens at: tokens size-1) = #stamp: 189430 ifTrue: ["New format gives change stamp and unified prior pointer" 189431 stamp := tokens at: tokens size]]. 189432 methodCategory := tokens after: #methodsFor: ifAbsent: ['as yet unclassifed']. 189433 methodCategory = category ifFalse: 189434 [methodCategory = (Smalltalk 189435 at: #Categorizer 189436 ifAbsent: [Smalltalk at: #ClassOrganizer]) 189437 default ifTrue: [methodCategory := methodCategory, ' ']. 189438 ^ ChangeRecord new file: file position: position type: #method 189439 class: className category: methodCategory meta: classIsMeta stamp: stamp]. 189440 position := prevPos. 189441 prevPos notNil ifTrue: 189442 [file := sourceFilesCopy at: prevFileIndex]]. 189443 ^ nil] 189444 ensure: [sourceFilesCopy do: [:x | x notNil ifTrue: [x close]]] 189445 ! ! 189446 189447!MCMethodDefinition methodsFor: 'installing' stamp: 'marcus.denker 11/10/2008 10:04'! 189448unload 189449 | previousVersion | 189450 self isOverrideMethod ifTrue: [previousVersion := self scanForPreviousVersion]. 189451 previousVersion 189452 ifNil: [self actualClass ifNotNil: [:class | class removeSelector: selector]] 189453 ifNotNil: [previousVersion fileIn] ! ! 189454 189455 189456!MCMethodDefinition methodsFor: 'printing' stamp: 'ab 12/5/2002 21:25'! 189457description 189458 ^ Array 189459 with: className 189460 with: selector 189461 with: classIsMeta! ! 189462 189463!MCMethodDefinition methodsFor: 'printing' stamp: 'al 12/3/2005 12:15'! 189464fullClassName 189465 "Using #class selector for classes for backwards compatibility" 189466 189467 ^ self classIsMeta 189468 ifFalse: [self className] 189469 ifTrue: [ 189470 (self actualClass isNil or: [ self actualClass isTrait ]) 189471 ifFalse: [self className, ' class'] 189472 ifTrue: [self className, ' classSide']]! ! 189473 189474!MCMethodDefinition methodsFor: 'printing' stamp: 'ab 4/8/2003 18:04'! 189475summary 189476 ^ self fullClassName , '>>' , selector! ! 189477 189478 189479!MCMethodDefinition methodsFor: 'serializing' stamp: 'stephaneducasse 2/4/2006 20:47'! 189480initializeWithClassName: classString 189481classIsMeta: metaBoolean 189482selector: selectorString 189483category: catString 189484timeStamp: timeString 189485source: sourceString 189486 className := classString asSymbol. 189487 selector := selectorString asSymbol. 189488 category := catString asSymbol. 189489 timeStamp := timeString. 189490 classIsMeta := metaBoolean. 189491 source := sourceString withSqueakLineEndings. 189492! ! 189493 189494 189495!MCMethodDefinition methodsFor: 'testing' stamp: 'ab 5/24/2003 13:49'! 189496isCodeDefinition 189497 ^ true! ! 189498 189499!MCMethodDefinition methodsFor: 'testing' stamp: 'ab 8/8/2003 17:05'! 189500isInitializer 189501 ^ selector = #initialize and: [classIsMeta] 189502 ! ! 189503 189504!MCMethodDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:52'! 189505isMethodDefinition 189506 ^true! ! 189507 189508 189509!MCMethodDefinition methodsFor: 'visiting' stamp: 'ab 7/18/2003 21:47'! 189510accept: aVisitor 189511 ^ aVisitor visitMethodDefinition: self! ! 189512 189513"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189514 189515MCMethodDefinition class 189516 instanceVariableNames: ''! 189517 189518!MCMethodDefinition class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 189519cachedDefinitions 189520 Definitions ifNil: [Definitions := WeakIdentityKeyDictionary new. WeakArray addWeakDependent: Definitions]. 189521 ^ Definitions! ! 189522 189523!MCMethodDefinition class methodsFor: 'as yet unclassified' stamp: 'ab 7/26/2003 02:05'! 189524className: classString 189525classIsMeta: metaBoolean 189526selector: selectorString 189527category: catString 189528timeStamp: timeString 189529source: sourceString 189530 ^ self instanceLike: 189531 (self new initializeWithClassName: classString 189532 classIsMeta: metaBoolean 189533 selector: selectorString 189534 category: catString 189535 timeStamp: timeString 189536 source: sourceString)! ! 189537 189538!MCMethodDefinition class methodsFor: 'as yet unclassified' stamp: 'ab 4/1/2003 01:40'! 189539className: classString 189540selector: selectorString 189541category: catString 189542timeStamp: timeString 189543source: sourceString 189544 ^ self className: classString 189545 classIsMeta: false 189546 selector: selectorString 189547 category: catString 189548 timeStamp: timeString 189549 source: sourceString! ! 189550 189551!MCMethodDefinition class methodsFor: 'as yet unclassified' stamp: 'dvf 9/8/2004 00:20'! 189552forMethodReference: aMethodReference 189553 | definition | 189554 definition := self cachedDefinitions at: aMethodReference compiledMethod ifAbsent: []. 189555 (definition isNil 189556 or: [definition selector ~= aMethodReference methodSymbol] 189557 or: [definition className ~= aMethodReference classSymbol] 189558 or: [definition classIsMeta ~= aMethodReference classIsMeta] 189559 or: [definition category ~= aMethodReference category]) 189560 ifTrue: [definition := self 189561 className: aMethodReference classSymbol 189562 classIsMeta: aMethodReference classIsMeta 189563 selector: aMethodReference methodSymbol 189564 category: aMethodReference category 189565 timeStamp: aMethodReference timeStamp 189566 source: aMethodReference source. 189567 self cachedDefinitions at: aMethodReference compiledMethod put: definition]. 189568 ^ definition 189569 ! ! 189570 189571!MCMethodDefinition class methodsFor: 'as yet unclassified' stamp: 'ab 8/22/2003 18:14'! 189572initialize 189573 Smalltalk addToShutDownList: self! ! 189574 189575!MCMethodDefinition class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 189576shutDown 189577 WeakArray removeWeakDependent: Definitions. 189578 Definitions := nil.! ! 189579MCTestCase subclass: #MCMethodDefinitionTest 189580 instanceVariableNames: 'navigation isModified' 189581 classVariableNames: '' 189582 poolDictionaries: '' 189583 category: 'Tests-Monticello'! 189584 189585!MCMethodDefinitionTest methodsFor: 'mocks' stamp: 'oscar.nierstrasz 10/18/2009 14:11'! 189586override ^ 1! ! 189587 189588 189589!MCMethodDefinitionTest methodsFor: 'running' stamp: 'cwp 11/13/2003 14:15'! 189590ownPackage 189591 ^ MCWorkingCopy forPackage: (MCPackage named: 'Monticello')! ! 189592 189593!MCMethodDefinitionTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! 189594setUp 189595 navigation := (Smalltalk hasClassNamed: #SystemNavigation) 189596 ifTrue: [(Smalltalk at: #SystemNavigation) new] 189597 ifFalse: [Smalltalk]. 189598 isModified := self ownPackage modified.! ! 189599 189600!MCMethodDefinitionTest methodsFor: 'running' stamp: 'bf 5/20/2005 18:23'! 189601tearDown 189602 self restoreMocks. 189603 (MCWorkingCopy forPackage: (MCPackage named: 'FooBarBaz')) unregister. 189604 self class compile: 'override ^ 1' classified: 'mocks'. 189605 self ownPackage modified: isModified! ! 189606 189607 189608!MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! 189609testCannotLoad 189610 | definition | 189611 definition := self mockMethod: #kjahs87 class: 'NoSuchClass' source: 'kjahs87 ^self' meta: false. 189612 self should: [definition load] raise: Error. 189613 self assert: (navigation allImplementorsOf: #kjahs87) isEmpty! ! 189614 189615!MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! 189616testComparison 189617 |d1 d2 d3 d4 d5 | 189618 d1 := self mockMethod: #one class: 'A' source: '1' meta: false. 189619 d2 := self mockMethod: #one class: 'A' source: '2' meta: false. 189620 d3 := self mockMethod: #one class: 'A' source: '1' meta: true. 189621 d4 := self mockMethod: #two class: 'A' source: '1' meta: false. 189622 d5 := self mockMethod: #two class: 'A' source: '1' meta: false. 189623 189624 self assert: (d1 isRevisionOf: d2). 189625 self deny: (d1 isSameRevisionAs: d2). 189626 189627 self deny: (d1 isRevisionOf: d3). 189628 self deny: (d1 isRevisionOf: d4). 189629 189630 self assert: (d4 isSameRevisionAs: d5).! ! 189631 189632!MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! 189633testLoadAndUnload 189634 |definition| 189635 definition := self mockMethod: #one class: 'MCMockClassA' source: 'one ^2' meta: false. 189636 self assert: self mockInstanceA one = 1. 189637 definition load. 189638 self assert: self mockInstanceA one = 2. 189639 definition unload. 189640 self deny: (self mockInstanceA respondsTo: #one)! ! 189641 189642!MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! 189643testPartiallyRevertOverrideMethod 189644 | definition | 189645 self class compile: 'override ^ 2' classified: '*foobarbaz'. 189646 self class compile: 'override ^ 3' classified: self mockOverrideMethodCategory. 189647 self class compile: 'override ^ 4' classified: self mockOverrideMethodCategory. 189648 definition := (MethodReference class: self class selector: #override) asMethodDefinition. 189649 self assert: definition isOverrideMethod. 189650 self assert: self override = 4. 189651 definition unload. 189652 self assert: self override = 2. 189653 self assert: (MethodReference class: self class selector: #override) category = '*foobarbaz'. 189654 ! ! 189655 189656!MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! 189657testRevertOldMethod 189658 | definition changeRecord | 189659 Object compile: 'yourself ^ self' classified: MCMockPackageInfo new methodCategoryPrefix. 189660 definition := (MethodReference class: Object selector: #yourself) asMethodDefinition. 189661 changeRecord := definition scanForPreviousVersion. 189662 self assert: changeRecord notNil. 189663 self assert: changeRecord category = 'accessing'. 189664 changeRecord fileIn.! ! 189665 189666!MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! 189667testRevertOverrideMethod 189668 | definition | 189669 self class compile: 'override ^ 2' classified: self mockOverrideMethodCategory. 189670 definition := (MethodReference class: self class selector: #override) asMethodDefinition. 189671 self assert: definition isOverrideMethod. 189672 self assert: self override = 2. 189673 definition unload. 189674 self assert: self override = 1. 189675 self assert: (MethodReference class: self class selector: #override) category = 'mocks'. 189676 ! ! 189677Object subclass: #MCMock 189678 instanceVariableNames: '' 189679 classVariableNames: '' 189680 poolDictionaries: '' 189681 category: 'Monticello-Mocks'! 189682 189683"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189684 189685MCMock class 189686 instanceVariableNames: ''! 189687 189688!MCMock class methodsFor: 'as yet unclassified' stamp: 'cwp 7/21/2003 19:40'! 189689wantsChangeSetLogging 189690 ^ false! ! 189691SharedPool subclass: #MCMockAPoolDictionary 189692 instanceVariableNames: '' 189693 classVariableNames: '' 189694 poolDictionaries: '' 189695 category: 'Monticello-Mocks'! 189696 189697"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189698 189699MCMockAPoolDictionary class 189700 instanceVariableNames: ''! 189701MCMockClassA subclass: #MCMockASubclass 189702 instanceVariableNames: 'x' 189703 classVariableNames: 'Y' 189704 poolDictionaries: '' 189705 category: 'Monticello-Mocks'! 189706 189707!MCMockASubclass methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 189708variables 189709 ^ x + Y + MCMockClassA! ! 189710 189711!MCMockASubclass methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 189712variables2 189713 ^ ivar + CVar! ! 189714 189715"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189716 189717MCMockASubclass class 189718 instanceVariableNames: ''! 189719MCMock subclass: #MCMockClassA 189720 instanceVariableNames: 'ivar' 189721 classVariableNames: 'CVar' 189722 poolDictionaries: '' 189723 category: 'Monticello-Mocks'! 189724!MCMockClassA commentStamp: 'cwp 8/10/2003 16:43' prior: 0! 189725This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.! 189726 189727 189728!MCMockClassA methodsFor: 'as yet classified'! 189729d 189730 ^ 'd'! ! 189731 189732 189733!MCMockClassA methodsFor: 'boolean' stamp: 'cwp 7/13/2003 02:49'! 189734falsehood 189735 ^ false! ! 189736 189737!MCMockClassA methodsFor: 'boolean' stamp: 'ab 7/7/2003 23:21'! 189738moreTruth 189739 189740 ^ true! ! 189741 189742!MCMockClassA methodsFor: 'boolean'! 189743truth 189744 ^ true! ! 189745 189746 189747!MCMockClassA methodsFor: 'drag''n''drop' stamp: 'avi 9/23/2003 17:14'! 189748q! ! 189749 189750 189751!MCMockClassA methodsFor: 'numeric'! 189752a 189753 ^ 'a2'! ! 189754 189755!MCMockClassA methodsFor: 'numeric'! 189756b 189757 ^ 'b1'! ! 189758 189759!MCMockClassA methodsFor: 'numeric'! 189760c 189761 ^ 'c1'! ! 189762 189763!MCMockClassA methodsFor: 'numeric' stamp: 'cwp 8/2/2003 17:26'! 189764one 189765 ^ 1! ! 189766 189767!MCMockClassA methodsFor: 'numeric' stamp: 'avi 9/11/2004 15:59'! 189768two 189769 ^ 2! ! 189770 189771"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189772 189773MCMockClassA class 189774 instanceVariableNames: ''! 189775 189776!MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 02:31'! 189777cVar 189778 ^ CVar! ! 189779 189780!MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 189781initialize 189782 CVar := #initialized! ! 189783 189784!MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 189785one 189786 189787 ^ 1! ! 189788 189789!MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 189790touchCVar 189791 CVar := #touched! ! 189792MCMock subclass: #MCMockClassB 189793 instanceVariableNames: 'ivarb' 189794 classVariableNames: 'CVar' 189795 poolDictionaries: 'MCMockAPoolDictionary' 189796 category: 'Monticello-Mocks'! 189797!MCMockClassB commentStamp: '' prior: 0! 189798This comment has a bang!! Bang!! Bang!!! 189799 189800 189801!MCMockClassB methodsFor: 'numeric' stamp: 'ab 7/7/2003 23:21'! 189802two 189803 189804 ^ 2! ! 189805 189806"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189807 189808MCMockClassB class 189809 instanceVariableNames: 'ciVar'! 189810Object subclass: #MCMockClassD 189811 instanceVariableNames: '' 189812 classVariableNames: '' 189813 poolDictionaries: '' 189814 category: 'Monticello-Mocks'! 189815 189816!MCMockClassD methodsFor: 'as yet unclassified' stamp: 'cwp 7/8/2003 21:21'! 189817one 189818 ^ 1! ! 189819 189820"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189821 189822MCMockClassD class 189823 instanceVariableNames: ''! 189824Object variableSubclass: #MCMockClassE 189825 instanceVariableNames: '' 189826 classVariableNames: '' 189827 poolDictionaries: '' 189828 category: 'Monticello-Mocks'! 189829 189830"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189831 189832MCMockClassE class 189833 instanceVariableNames: ''! 189834 189835!MCMockClassE class methodsFor: 'as yet unclassified' stamp: 'cwp 7/8/2003 21:22'! 189836two 189837 ^ 2! ! 189838Object subclass: #MCMockClassF 189839 instanceVariableNames: '' 189840 classVariableNames: 'Foo' 189841 poolDictionaries: '' 189842 category: 'Monticello-Mocks'! 189843 189844"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189845 189846MCMockClassF class 189847 instanceVariableNames: ''! 189848Object variableWordSubclass: #MCMockClassG 189849 instanceVariableNames: '' 189850 classVariableNames: '' 189851 poolDictionaries: '' 189852 category: 'Monticello-Mocks'! 189853 189854"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189855 189856MCMockClassG class 189857 instanceVariableNames: ''! 189858Object variableByteSubclass: #MCMockClassH 189859 instanceVariableNames: '' 189860 classVariableNames: '' 189861 poolDictionaries: '' 189862 category: 'Monticello-Mocks'! 189863 189864"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189865 189866MCMockClassH class 189867 instanceVariableNames: ''! 189868Object weakSubclass: #MCMockClassI 189869 instanceVariableNames: '' 189870 classVariableNames: '' 189871 poolDictionaries: '' 189872 category: 'Monticello-Mocks'! 189873 189874"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189875 189876MCMockClassI class 189877 instanceVariableNames: ''! 189878MCDefinition subclass: #MCMockDefinition 189879 instanceVariableNames: 'token' 189880 classVariableNames: '' 189881 poolDictionaries: '' 189882 category: 'Monticello-Mocks'! 189883 189884!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 189885asString 189886 189887 ^ token! ! 189888 189889!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 189890description 189891 189892 ^ token first! ! 189893 189894!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 189895hash 189896 189897 ^ token hash! ! 189898 189899!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 189900printString 189901 189902 ^ token! ! 189903 189904!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 189905summary 189906 189907 ^ token! ! 189908 189909!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 189910token 189911 189912 ^ token! ! 189913 189914!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 189915token: aString 189916 189917 token := aString! ! 189918 189919!MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 18:25'! 189920= definition 189921 ^definition token = token! ! 189922 189923"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 189924 189925MCMockDefinition class 189926 instanceVariableNames: ''! 189927 189928!MCMockDefinition class methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 189929token: aString 189930 189931 ^ self new token: aString! ! 189932 189933!MCMockDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/21/2003 19:46'! 189934wantsChangeSetLogging 189935 ^ false! ! 189936Object subclass: #MCMockDependency 189937 instanceVariableNames: 'name children hasResolution' 189938 classVariableNames: '' 189939 poolDictionaries: '' 189940 category: 'Tests-Monticello'! 189941 189942!MCMockDependency methodsFor: 'accessing' stamp: 'cwp 11/7/2004 14:43'! 189943children 189944 ^ children collect: [:ea | self class fromTree: ea]! ! 189945 189946!MCMockDependency methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 189947initializeWithTree: expr 189948 expr isSymbol 189949 ifTrue: [name := expr. 189950 children := Array new. 189951 hasResolution := true.] 189952 ifFalse: [name := expr first. 189953 expr second isSymbol 189954 ifTrue: [hasResolution := false. 189955 children := Array new] 189956 ifFalse: [hasResolution := true. 189957 children := expr second]]! ! 189958 189959!MCMockDependency methodsFor: 'accessing' stamp: 'cwp 11/7/2004 14:38'! 189960name 189961 ^ name! ! 189962 189963 189964!MCMockDependency methodsFor: 'comparing' stamp: 'cwp 11/7/2004 13:33'! 189965hash 189966 ^ self name hash! ! 189967 189968!MCMockDependency methodsFor: 'comparing' stamp: 'cwp 11/7/2004 13:32'! 189969= other 189970 ^ self name = other name! ! 189971 189972 189973!MCMockDependency methodsFor: 'mocks' stamp: 'cwp 11/7/2004 14:41'! 189974mockVersionInfo 189975 ^ MCVersionInfo 189976 name: self name 189977 id: (self uuidForName: name) 189978 message: '' 189979 date: nil 189980 time: nil 189981 author: '' 189982 ancestors: #()! ! 189983 189984!MCMockDependency methodsFor: 'mocks' stamp: 'nk 2/22/2005 21:17'! 189985uuidForName: aName 189986 | nm id | 189987 nm := aName asString. 189988 id := '00000000-0000-0000-0000-0000000000' 189989 , (nm size = 1 ifTrue: [nm , '0'] ifFalse: [nm]). 189990 ^UUID fromString: id! ! 189991 189992 189993!MCMockDependency methodsFor: 'resolving' stamp: 'cwp 11/7/2004 14:42'! 189994hasResolution 189995 ^ hasResolution! ! 189996 189997!MCMockDependency methodsFor: 'resolving' stamp: 'cwp 11/7/2004 14:16'! 189998resolve 189999 ^ self hasResolution 190000 ifTrue: [MCVersion new 190001 setPackage: MCSnapshotResource mockPackage 190002 info: self mockVersionInfo 190003 snapshot: MCSnapshotResource current snapshot 190004 dependencies: self children] 190005 ifFalse: [nil]! ! 190006 190007"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 190008 190009MCMockDependency class 190010 instanceVariableNames: ''! 190011 190012!MCMockDependency class methodsFor: 'instance creation' stamp: 'cwp 11/7/2004 14:43'! 190013fromTree: anArray 190014 ^ self new initializeWithTree: anArray! ! 190015MCMock subclass: #MCMockDependentItem 190016 instanceVariableNames: 'name provides requires' 190017 classVariableNames: '' 190018 poolDictionaries: '' 190019 category: 'Monticello-Mocks'! 190020 190021!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 190022name 190023 190024 ^ name! ! 190025 190026!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 190027name: aString 190028 190029 name := aString! ! 190030 190031!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 190032provides: anArray 190033 190034 provides := anArray! ! 190035 190036!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 190037provisions 190038 190039 ^ provides ifNil: [#()]! ! 190040 190041!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! 190042requirements 190043 190044 ^ requires ifNil: [#()]! ! 190045 190046!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 190047requires: anArray 190048 190049 requires := anArray! ! 190050 190051!MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'bf 5/20/2005 16:15'! 190052<= other 190053 ^ self name <= other name! ! 190054 190055"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 190056 190057MCMockDependentItem class 190058 instanceVariableNames: ''! 190059PackageInfo subclass: #MCMockPackageInfo 190060 instanceVariableNames: '' 190061 classVariableNames: '' 190062 poolDictionaries: '' 190063 category: 'Monticello-Mocks'! 190064 190065!MCMockPackageInfo methodsFor: '*Tests-Monticello' stamp: 'cwp 8/1/2003 20:25'! 190066extensionMethods 190067 ^ Array with: (MethodReference new 190068 setStandardClass: MCSnapshotTest 190069 methodSymbol: #mockClassExtension)! ! 190070 190071 190072!MCMockPackageInfo methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 01:12'! 190073classes 190074 ^ self classNames 190075 select: [:name | Smalltalk hasClassNamed: name] 190076 thenCollect: [:name | Smalltalk at: name]! ! 190077 190078!MCMockPackageInfo methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 01:09'! 190079classNames 190080 ^ #( MCMockClassA 190081 MCMockASubclass 190082 MCMockClassB 190083 MCMockClassD 190084 MCMockClassE 190085 MCMockClassF 190086 MCMockClassG 190087 MCMockClassH 190088 MCMockClassI 190089 )! ! 190090 190091!MCMockPackageInfo methodsFor: 'as yet unclassified' stamp: 'bf 5/20/2005 16:54'! 190092includesClass: aClass 190093 ^self classes includes: aClass! ! 190094 190095!MCMockPackageInfo methodsFor: 'as yet unclassified' stamp: 'bf 5/20/2005 17:18'! 190096includesSystemCategory: categoryName 190097 ^self systemCategories anySatisfy: [:cat | cat sameAs: categoryName]! ! 190098 190099!MCMockPackageInfo methodsFor: 'as yet unclassified' stamp: 'cwp 8/1/2003 20:31'! 190100packageName 190101 ^ 'MonticelloMocks'! ! 190102 190103!MCMockPackageInfo methodsFor: 'as yet unclassified' stamp: 'cwp 7/31/2003 15:30'! 190104systemCategories 190105 ^ Array with: 'Monticello-Mocks'! ! 190106 190107"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 190108 190109MCMockPackageInfo class 190110 instanceVariableNames: ''! 190111 190112!MCMockPackageInfo class methodsFor: 'as yet unclassified' stamp: 'avi 2/22/2004 14:04'! 190113initialize 190114 [self new register] on: MessageNotUnderstood do: []! ! 190115MCPatchOperation subclass: #MCModification 190116 instanceVariableNames: 'obsoletion modification' 190117 classVariableNames: '' 190118 poolDictionaries: '' 190119 category: 'Monticello-Patching'! 190120 190121!MCModification methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 4/2/2009 13:26'! 190122diff 190123 "Open a diff browser on the changes." 190124 190125 (DiffMorph 190126 from: self fromSource 190127 to: self toSource 190128 contextClass: (self isClassPatch ifTrue: [nil] ifFalse: [self targetClass])) 190129 extent: 400@300; 190130 openInWindowLabeled: 'Diff' translated! ! 190131 190132!MCModification methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 1/14/2009 14:11'! 190133diffFromSource 190134 "Answer fromSource of the modification. If a class patch then answer 190135 the fromSource with the class-side definition and comment appended." 190136 190137 ^self isClassPatch 190138 ifTrue: [self fromSource, String cr, String cr, 190139 obsoletion classDefinitionString, String cr, String cr, 190140 obsoletion commentStamp, String cr, 190141 obsoletion comment] 190142 ifFalse: [self fromSource]! ! 190143 190144!MCModification methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 1/14/2009 14:12'! 190145diffToSource 190146 "Answer toSource of the modification. If a class patch then answer 190147 the toSource with the class-side definition and comment appended." 190148 190149 ^self isClassPatch 190150 ifTrue: [self toSource, String cr, String cr, 190151 modification classDefinitionString, String cr, String cr, 190152 modification commentStamp, String cr, 190153 modification comment] 190154 ifFalse: [self toSource]! ! 190155 190156 190157!MCModification methodsFor: 'accessing' stamp: 'ab 5/24/2003 16:12'! 190158applyTo: anObject 190159 anObject modifyDefinition: obsoletion to: modification! ! 190160 190161!MCModification methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'! 190162baseDefinition 190163 ^ obsoletion! ! 190164 190165!MCModification methodsFor: 'accessing' stamp: 'cwp 11/28/2002 06:55'! 190166definition 190167 ^ modification! ! 190168 190169!MCModification methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:44'! 190170fromSource 190171 ^ obsoletion source! ! 190172 190173!MCModification methodsFor: 'accessing' stamp: 'cwp 11/27/2002 09:46'! 190174modification 190175 ^ modification! ! 190176 190177!MCModification methodsFor: 'accessing' stamp: 'cwp 11/27/2002 09:48'! 190178obsoletion 190179 ^ obsoletion! ! 190180 190181!MCModification methodsFor: 'accessing' stamp: 'nk 10/21/2003 22:54'! 190182summarySuffix 190183 ^self fromSource = self toSource 190184 ifTrue: [ ' (source same but rev changed)' ] 190185 ifFalse: [ ' (changed)' ]! ! 190186 190187!MCModification methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:18'! 190188targetClass 190189 ^ obsoletion actualClass! ! 190190 190191!MCModification methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'! 190192targetDefinition 190193 ^ modification! ! 190194 190195!MCModification methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:44'! 190196toSource 190197 ^ modification source! ! 190198 190199 190200!MCModification methodsFor: 'as yet unclassified' stamp: 'ab 8/22/2003 02:27'! 190201inverse 190202 ^ MCModification of: modification to: obsoletion! ! 190203 190204!MCModification methodsFor: 'as yet unclassified' stamp: 'nk 2/25/2005 17:29'! 190205isClassPatch 190206 ^obsoletion isClassDefinition! ! 190207 190208!MCModification methodsFor: 'as yet unclassified' stamp: 'nk 11/10/2003 21:44'! 190209printAnnotations: request on: aStream 190210 aStream nextPutAll: 'old: '. 190211 obsoletion printAnnotations: request on: aStream. 190212 aStream cr. 190213 aStream nextPutAll: 'new: '. 190214 modification printAnnotations: request on: aStream.! ! 190215 190216 190217!MCModification methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! 190218initializeWithBase: base target: target 190219 obsoletion := base. 190220 modification := target.! ! 190221 190222 190223!MCModification methodsFor: 'testing' stamp: 'cwp 11/28/2002 07:23'! 190224isModification 190225 ^ true! ! 190226 190227"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 190228 190229MCModification class 190230 instanceVariableNames: ''! 190231 190232!MCModification class methodsFor: 'as yet unclassified' stamp: 'cwp 11/28/2002 07:19'! 190233of: base to: target 190234 ^ self new initializeWithBase: base target: target! ! 190235MCPackageLoader subclass: #MCMultiPackageLoader 190236 instanceVariableNames: '' 190237 classVariableNames: '' 190238 poolDictionaries: '' 190239 category: 'Monticello-Loading'! 190240!MCMultiPackageLoader commentStamp: '<historical>' prior: 0! 190241A PackageLoader doing some additional cross-package checks! 190242 190243 190244!MCMultiPackageLoader methodsFor: 'private' stamp: 'bf 3/17/2006 15:51'! 190245analyze 190246 | index | 190247 index := MCDefinitionIndex definitions: additions. 190248 removals removeAllSuchThat: [:removal | 190249 (index definitionLike: removal 190250 ifPresent: [:addition | obsoletions at: addition put: removal] 190251 ifAbsent: []) notNil]. 190252 super analyze! ! 190253Exception subclass: #MCNoChangesException 190254 instanceVariableNames: '' 190255 classVariableNames: '' 190256 poolDictionaries: '' 190257 category: 'Monticello-Versioning'! 190258 190259!MCNoChangesException methodsFor: 'as yet unclassified' stamp: 'jf 8/21/2003 19:49'! 190260defaultAction 190261 self inform: 'No changes'! ! 190262 190263"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 190264 190265MCNoChangesException class 190266 instanceVariableNames: ''! 190267MCDefinition subclass: #MCOrganizationDefinition 190268 instanceVariableNames: 'categories' 190269 classVariableNames: '' 190270 poolDictionaries: '' 190271 category: 'Monticello-Modeling'! 190272 190273!MCOrganizationDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 10/30/2006 11:18'! 190274patchWrapper 190275 "Answer a wrapper for a patch tree for the receiver." 190276 190277 ^PSMCOrganizationChangeWrapper with: self! ! 190278 190279 190280!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 21:47'! 190281accept: aVisitor 190282 ^ aVisitor visitOrganizationDefinition: self! ! 190283 190284!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'ab 5/24/2003 13:51'! 190285categories 190286 ^ categories! ! 190287 190288!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 190289categories: anArray 190290 categories := anArray! ! 190291 190292!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 190293commonPrefix 190294 | stream | 190295 categories isEmpty ifTrue: [^ '']. 190296 190297 stream := String new writeStream. 190298 categories first withIndexDo: 190299 [:c :i| 190300 categories do: 190301 [:ea | 190302 (ea at: i ifAbsent: []) = c ifFalse: [^ stream contents]]. 190303 stream nextPut: c]. 190304 ^ stream contents! ! 190305 190306!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'avi 9/28/2004 14:53'! 190307description 190308 ^ Array with: #organization with: self commonPrefix! ! 190309 190310!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'cwp 7/11/2003 01:33'! 190311isOrganizationDefinition 190312 ^ true! ! 190313 190314!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/22/2004 13:46'! 190315postloadOver: oldDefinition 190316 SystemOrganization categories: 190317 (self 190318 reorderCategories: SystemOrganization categories 190319 original: (oldDefinition ifNil: [#()] ifNotNil: [oldDefinition categories]))! ! 190320 190321!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 190322reorderCategories: allCategories original: oldCategories 190323 | first | 190324 first := allCategories detect: [:ea | categories includes: ea] ifNone: [^ allCategories]. 190325 ^ ((allCategories copyUpTo: first) copyWithoutAll: oldCategories, categories), 190326 categories, 190327 ((allCategories copyAfter: first) copyWithoutAll: oldCategories, categories) 190328! ! 190329 190330!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 18:01'! 190331sortKey 190332 ^ '<organization>'! ! 190333 190334!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/22/2003 01:14'! 190335source 190336 ^ String streamContents: 190337 [:s | 190338 categories do: [:ea | s nextPutAll: ea] separatedBy: [s cr]]! ! 190339 190340!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'ab 5/24/2003 13:55'! 190341summary 190342 ^ categories asArray printString! ! 190343 190344!MCOrganizationDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 18:25'! 190345= aDefinition 190346 ^ (super = aDefinition) 190347 and: [categories = aDefinition categories]! ! 190348 190349"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 190350 190351MCOrganizationDefinition class 190352 instanceVariableNames: ''! 190353 190354!MCOrganizationDefinition class methodsFor: 'as yet unclassified' stamp: 'ab 7/26/2003 02:06'! 190355categories: anArray 190356 ^ self instanceLike: (self new categories: anArray)! ! 190357MCTestCase subclass: #MCOrganizationTest 190358 instanceVariableNames: '' 190359 classVariableNames: '' 190360 poolDictionaries: '' 190361 category: 'Tests-Monticello'! 190362 190363!MCOrganizationTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 190364testReordering 190365 |dec cats newCats | 190366 dec := MCOrganizationDefinition categories: #(A B C). 190367 cats := #(X Y B Z C A Q). 190368 newCats := dec reorderCategories: cats original: #(B C A). 190369 self assert: newCats asArray = #(X Y A B C Z Q).! ! 190370 190371!MCOrganizationTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 190372testReorderingWithNoCategoriesInVersion 190373 |dec cats newCats | 190374 dec := MCOrganizationDefinition categories: #(). 190375 cats := #(X Y B Z C A Q). 190376 newCats := dec reorderCategories: cats original: #(). 190377 self assert: newCats asArray = cats.! ! 190378 190379!MCOrganizationTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 190380testReorderingWithRemovals 190381 |dec cats newCats | 190382 dec := MCOrganizationDefinition categories: #(A B C). 190383 cats := #(X Y B Z C A Q). 190384 newCats := dec reorderCategories: cats original: #(Y B C A Q). 190385 self assert: newCats asArray = #(X A B C Z).! ! 190386TestCase subclass: #MCPTest 190387 instanceVariableNames: '' 190388 classVariableNames: '' 190389 poolDictionaries: '' 190390 category: 'MorphicTests-Kernel'! 190391 190392!MCPTest methodsFor: 'constants' stamp: 'dgd 2/14/2003 10:13'! 190393defaultBounds 190394 "the default bounds for morphs" 190395 ^ 0 @ 0 corner: 50 @ 40 ! ! 190396 190397!MCPTest methodsFor: 'constants' stamp: 'dgd 2/14/2003 10:13'! 190398defaultTop 190399 "the default top for morphs" 190400 ^ self defaultBounds top ! ! 190401 190402 190403!MCPTest methodsFor: 'tests' stamp: 'gm 2/22/2003 12:58'! 190404testIsMorphicModel 190405 "test isMorphicModel" 190406 self deny: Object new isMorphicModel. 190407 self deny: Morph new isMorphicModel. 190408 self assert: MorphicModel new isMorphicModel. 190409! ! 190410 190411!MCPTest methodsFor: 'tests' stamp: 'dgd 2/14/2003 10:15'! 190412testTop 190413 "test the #top: messages and its consequences" 190414 190415 | morph factor newTop newBounds | 190416 morph := Morph new. 190417 "" 190418 factor := 10. 190419 newTop := self defaultTop + factor. 190420 newBounds := self defaultBounds translateBy: 0 @ factor. 190421 "" 190422 morph top: newTop. 190423 "" 190424 self assert: morph top = newTop; 190425 assert: morph bounds = newBounds! ! 190426Object subclass: #MCPackage 190427 instanceVariableNames: 'name' 190428 classVariableNames: '' 190429 poolDictionaries: '' 190430 category: 'Monticello-Base'! 190431 190432!MCPackage methodsFor: 'as yet unclassified' stamp: 'ar 4/26/2005 21:57'! 190433hash 190434 ^ name asLowercase hash! ! 190435 190436!MCPackage methodsFor: 'as yet unclassified' stamp: 'bf 4/19/2005 16:26'! 190437hasWorkingCopy 190438 ^ MCWorkingCopy registry includesKey: self! ! 190439 190440!MCPackage methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 00:57'! 190441name 190442 ^ name! ! 190443 190444!MCPackage methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 190445name: aString 190446 name := aString! ! 190447 190448!MCPackage methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 13:33'! 190449packageInfo 190450 ^ PackageInfo named: name! ! 190451 190452!MCPackage methodsFor: 'as yet unclassified' stamp: 'nk 7/28/2003 13:30'! 190453printOn: aStream 190454 super printOn: aStream. 190455 aStream 190456 nextPut: $(; 190457 nextPutAll: name; 190458 nextPut: $)! ! 190459 190460!MCPackage methodsFor: 'as yet unclassified' stamp: 'bf 3/17/2005 18:35'! 190461snapshot 190462 | packageInfo definitions categories | 190463 packageInfo := self packageInfo. 190464 definitions := OrderedCollection new. 190465 categories := packageInfo systemCategories. 190466 categories isEmpty ifFalse: [ definitions add: (MCOrganizationDefinition categories: categories) ]. 190467 packageInfo methods do: [:ea | definitions add: ea asMethodDefinition] displayingProgress: 'Snapshotting methods...'. 190468 (packageInfo respondsTo: #overriddenMethods) ifTrue: 190469 [packageInfo overriddenMethods 190470 do: [:ea | definitions add: 190471 (packageInfo changeRecordForOverriddenMethod: ea) asMethodDefinition] 190472 displayingProgress: 'Searching for overrides...']. 190473 packageInfo classes do: [:ea | definitions addAll: ea classDefinitions] displayingProgress: 'Snapshotting classes...'. 190474 (packageInfo respondsTo: #hasPreamble) ifTrue: [ 190475 packageInfo hasPreamble ifTrue: [definitions add: (MCPreambleDefinition from: packageInfo)]. 190476 packageInfo hasPostscript ifTrue: [definitions add: (MCPostscriptDefinition from: packageInfo)]. 190477 packageInfo hasPreambleOfRemoval ifTrue: [definitions add: (MCRemovalPreambleDefinition from: packageInfo)]. 190478 packageInfo hasPostscriptOfRemoval ifTrue: [definitions add: (MCRemovalPostscriptDefinition from: packageInfo)]]. 190479 ^ MCSnapshot fromDefinitions: definitions 190480! ! 190481 190482!MCPackage methodsFor: 'as yet unclassified' stamp: 'ab 7/10/2003 01:13'! 190483storeOn: aStream 190484 aStream 190485 nextPutAll: 'MCPackage'; 190486 space; nextPutAll: 'named: '; store: name.! ! 190487 190488!MCPackage methodsFor: 'as yet unclassified' stamp: 'cwp 11/13/2003 13:32'! 190489unload 190490 ^ self workingCopy unload! ! 190491 190492!MCPackage methodsFor: 'as yet unclassified' stamp: 'cwp 11/13/2003 13:33'! 190493workingCopy 190494 ^ MCWorkingCopy forPackage: self.! ! 190495 190496!MCPackage methodsFor: 'as yet unclassified' stamp: 'ar 4/26/2005 21:57'! 190497= other 190498 ^ other species = self species and: [other name sameAs: name]! ! 190499 190500"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 190501 190502MCPackage class 190503 instanceVariableNames: ''! 190504 190505!MCPackage class methodsFor: 'as yet unclassified' stamp: 'ab 7/10/2003 01:17'! 190506named: aString 190507 ^ self new name: aString! ! 190508Object subclass: #MCPackageCache 190509 instanceVariableNames: 'sorter fileNames' 190510 classVariableNames: '' 190511 poolDictionaries: '' 190512 category: 'Monticello-Repositories'! 190513 190514!MCPackageCache methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:03'! 190515initialize 190516 super initialize. 190517 sorter := MCVersionSorter new. 190518 fileNames := Dictionary new.! ! 190519 190520!MCPackageCache methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 18:25'! 190521recordVersionInfo: aVersionInfo forFileNamed: aString 190522 Transcript cr; show: aString. 190523 fileNames at: aVersionInfo put: aString. 190524 sorter addVersionInfo: aVersionInfo! ! 190525 190526!MCPackageCache methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 18:21'! 190527versionInfos 190528 ^ sorter sortedVersionInfos ! ! 190529 190530"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 190531 190532MCPackageCache class 190533 instanceVariableNames: ''! 190534 190535!MCPackageCache class methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 18:12'! 190536new 190537 ^ self basicNew initialize! ! 190538Object subclass: #MCPackageLoader 190539 instanceVariableNames: 'requirements unloadableDefinitions obsoletions additions removals errorDefinitions provisions methodAdditions' 190540 classVariableNames: '' 190541 poolDictionaries: '' 190542 category: 'Monticello-Loading'! 190543!MCPackageLoader commentStamp: 'rej 2/26/2007 07:35' prior: 0! 190544A MCPackageLoader is responsible for loading packages. It gets used by VersionLoader, so it is eventually responsible for loading everything. 190545 190546Instance Variables 190547 additions: <Definitions> Definitions that need to be added 190548 errorDefinitions: <Object> 190549 obsoletions: <Object> 190550 provisions: <Object> 190551 removals: <Object> 190552 requirements: <Object> 190553 unloadableDefinitions: <Object> 190554 methodAdditions <MethodAdditions> MethodDefinitions corresponding to the Definitions in "additions" that have been added so far. 190555 190556additions 190557 - xxxxx 190558 190559errorDefinitions 190560 - xxxxx 190561 190562obsoletions 190563 - xxxxx 190564 190565provisions 190566 - xxxxx 190567 190568removals 190569 - xxxxx 190570 190571requirements 190572 - xxxxx 190573 190574unloadableDefinitions 190575 - xxxxx 190576! 190577 190578 190579!MCPackageLoader methodsFor: 'patch ops' stamp: 'ab 5/24/2003 16:13'! 190580addDefinition: aDefinition 190581 additions add: aDefinition! ! 190582 190583!MCPackageLoader methodsFor: 'patch ops' stamp: 'avi 2/17/2004 13:14'! 190584modifyDefinition: old to: new 190585 self addDefinition: new. 190586 obsoletions at: new put: old.! ! 190587 190588!MCPackageLoader methodsFor: 'patch ops' stamp: 'ab 5/24/2003 16:14'! 190589removeDefinition: aDefinition 190590 removals add: aDefinition! ! 190591 190592 190593!MCPackageLoader methodsFor: 'public' stamp: 'stephaneducasse 2/4/2006 20:47'! 190594installSnapshot: aSnapshot 190595 | patch | 190596 patch := aSnapshot patchRelativeToBase: MCSnapshot empty. 190597 patch applyTo: self. 190598! ! 190599 190600!MCPackageLoader methodsFor: 'public' stamp: 'ab 8/24/2003 01:03'! 190601load 190602 self analyze. 190603 unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies]. 190604 self useNewChangeSetDuring: [self basicLoad]! ! 190605 190606!MCPackageLoader methodsFor: 'public' stamp: 'nk 8/30/2004 08:39'! 190607loadWithNameLike: baseName 190608 self analyze. 190609 unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies]. 190610 self useNewChangeSetNamedLike: baseName during: [self basicLoad]! ! 190611 190612!MCPackageLoader methodsFor: 'public' stamp: 'nk 2/23/2005 07:51'! 190613loadWithName: baseName 190614 self analyze. 190615 unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies]. 190616 self useChangeSetNamed: baseName during: [self basicLoad]! ! 190617 190618!MCPackageLoader methodsFor: 'public' stamp: 'avi 10/5/2003 11:09'! 190619unloadPackage: aPackage 190620 self updatePackage: aPackage withSnapshot: MCSnapshot empty! ! 190621 190622!MCPackageLoader methodsFor: 'public' stamp: 'stephaneducasse 2/4/2006 20:47'! 190623updatePackage: aPackage withSnapshot: aSnapshot 190624 | patch packageSnap | 190625 packageSnap := aPackage snapshot. 190626 patch := aSnapshot patchRelativeToBase: packageSnap. 190627 patch applyTo: self. 190628 packageSnap definitions do: [:ea | self provisions addAll: ea provisions] 190629! ! 190630 190631 190632!MCPackageLoader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! 190633analyze 190634 | sorter | 190635 sorter := self sorterForItems: additions. 190636 additions := sorter orderedItems. 190637 requirements := sorter externalRequirements. 190638 unloadableDefinitions := sorter itemsWithMissingRequirements asSortedCollection. 190639 190640 sorter := self sorterForItems: removals. 190641 removals := sorter orderedItems reversed.! ! 190642 190643!MCPackageLoader methodsFor: 'private' stamp: 'StephaneDucasse 9/13/2009 18:17'! 190644basicLoad 190645 errorDefinitions := OrderedCollection new. 190646 [[ 190647 190648 "FIXME. Do a separate pass on loading class definitions as the very first thing. 190649 This is a workaround for a problem with the so-called 'atomic' loading (you wish!!) 190650 which isn't atomic at all but mixes compilation of methods with reshapes of classes. 190651 190652 Since the method is not installed until later, any class reshape in the middle *will* 190653 affect methods in subclasses that have been compiled before. There is probably 190654 a better way of dealing with this by ensuring that the sort order of the definition lists 190655 superclass definitions before methods for subclasses but I need this NOW, and adding 190656 an extra pass ensures that methods are compiled against their new class definitions." 190657 190658 additions do: [:ea | self loadClassDefinition: ea] displayingProgress: 'Loading classes...'. 190659 190660 additions do: [:ea | self tryToLoad: ea] displayingProgress: 'Compiling methods...'. 190661 removals do: [:ea | ea unload] displayingProgress: 'Cleaning up...'. 190662 self shouldWarnAboutErrors ifTrue: [self warnAboutErrors]. 190663 errorDefinitions do: [:ea | ea addMethodAdditionTo: methodAdditions] displayingProgress: 'Reloading...'. 190664 methodAdditions do: [:each | each installMethod]. 190665 methodAdditions do: [:each | each notifyObservers]. 190666 additions do: [:ea | ea postloadOver: (self obsoletionFor: ea)] displayingProgress: 'Initializing...'] 190667 on: InMidstOfFileinNotification 190668 do: [:n | n resume: true]] 190669 ensure: [self flushChangesFile]! ! 190670 190671!MCPackageLoader methodsFor: 'private' stamp: 'ab 5/25/2003 01:24'! 190672dependencyWarning 190673 ^ String streamContents: 190674 [:s | 190675 s nextPutAll: 'This package depends on the following classes:'; cr. 190676 requirements do: [:ea | s space; space; nextPutAll: ea; cr]. 190677 s nextPutAll: 'You must resolve these dependencies before you will be able to load these definitions: '; cr. 190678 unloadableDefinitions do: [:ea | s space; space; nextPutAll: ea summary; cr]] ! ! 190679 190680!MCPackageLoader methodsFor: 'private' stamp: 'avi 1/24/2004 17:44'! 190681errorDefinitionWarning 190682 ^ String streamContents: 190683 [:s | 190684 s nextPutAll: 'The following definitions had errors while loading. Press Proceed to try to load them again (they may work on a second pass):'; cr. 190685 errorDefinitions do: [:ea | s space; space; nextPutAll: ea summary; cr]] ! ! 190686 190687!MCPackageLoader methodsFor: 'private' stamp: 'cwp 11/13/2003 02:01'! 190688flushChangesFile 190689 "The changes file is second in the SourceFiles array" 190690 190691 (SourceFiles at: 2) flush! ! 190692 190693!MCPackageLoader methodsFor: 'private' stamp: 'StephaneDucasse 9/13/2009 18:15'! 190694initialize 190695 super initialize. 190696 additions := OrderedCollection new. 190697 removals := OrderedCollection new. 190698 obsoletions := Dictionary new. 190699 methodAdditions := OrderedCollection new. 190700! ! 190701 190702!MCPackageLoader methodsFor: 'private' stamp: 'StephaneDucasse 9/13/2009 18:17'! 190703loadClassDefinition: aDefinition 190704 190705 [aDefinition isClassDefinition ifTrue:[aDefinition load]] on: Error do: [errorDefinitions add: aDefinition].! ! 190706 190707!MCPackageLoader methodsFor: 'private' stamp: 'avi 2/17/2004 13:15'! 190708obsoletionFor: aDefinition 190709 ^ obsoletions at: aDefinition ifAbsent: [nil]! ! 190710 190711!MCPackageLoader methodsFor: 'private' stamp: 'ab 5/25/2003 01:19'! 190712orderDefinitionsForLoading: aCollection 190713 ^ (self sorterForItems: aCollection) orderedItems! ! 190714 190715!MCPackageLoader methodsFor: 'private' stamp: 'ab 5/24/2003 16:52'! 190716orderedAdditions 190717 ^ additions! ! 190718 190719!MCPackageLoader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! 190720provisions 190721 ^ provisions ifNil: [provisions := Set withAll: Smalltalk keys]! ! 190722 190723!MCPackageLoader methodsFor: 'private' stamp: 'avi 1/25/2004 13:32'! 190724shouldWarnAboutErrors 190725 ^ errorDefinitions isEmpty not and: [false "should make this a preference"]! ! 190726 190727!MCPackageLoader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! 190728sorterForItems: aCollection 190729 | sorter | 190730 sorter := MCDependencySorter items: aCollection. 190731 sorter addExternalProvisions: self provisions. 190732 ^ sorter! ! 190733 190734!MCPackageLoader methodsFor: 'private' stamp: 'StephaneDucasse 9/13/2009 18:16'! 190735tryToLoad: aDefinition 190736 [aDefinition addMethodAdditionTo: methodAdditions] on: Error do: [errorDefinitions add: aDefinition].! ! 190737 190738!MCPackageLoader methodsFor: 'private' stamp: 'pk 10/17/2006 09:41'! 190739useChangeSetNamed: baseName during: aBlock 190740 "Use the named change set, or create one with the given name." 190741 | changeHolder oldChanges newChanges | 190742 changeHolder := (ChangeSet respondsTo: #newChanges:) 190743 ifTrue: [ChangeSet] 190744 ifFalse: [Smalltalk]. 190745 oldChanges := (ChangeSet respondsTo: #current) 190746 ifTrue: [ChangeSet current] 190747 ifFalse: [Smalltalk changes]. 190748 190749 newChanges := (ChangesOrganizer changeSetNamed: baseName) ifNil: [ ChangeSet new name: baseName ]. 190750 changeHolder newChanges: newChanges. 190751 [aBlock value] ensure: [changeHolder newChanges: oldChanges]. 190752! ! 190753 190754!MCPackageLoader methodsFor: 'private' stamp: 'nk 8/30/2004 08:38'! 190755useNewChangeSetDuring: aBlock 190756 ^self useNewChangeSetNamedLike: 'MC' during: aBlock! ! 190757 190758!MCPackageLoader methodsFor: 'private' stamp: 'nk 2/23/2005 07:50'! 190759useNewChangeSetNamedLike: baseName during: aBlock 190760 ^self useChangeSetNamed: (ChangeSet uniqueNameLike: baseName) during: aBlock! ! 190761 190762!MCPackageLoader methodsFor: 'private' stamp: 'ab 5/25/2003 01:22'! 190763warnAboutDependencies 190764 self notify: self dependencyWarning! ! 190765 190766!MCPackageLoader methodsFor: 'private' stamp: 'avi 1/24/2004 17:42'! 190767warnAboutErrors 190768 self notify: self errorDefinitionWarning. 190769! ! 190770 190771"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 190772 190773MCPackageLoader class 190774 instanceVariableNames: ''! 190775 190776!MCPackageLoader class methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 23:30'! 190777installSnapshot: aSnapshot 190778 self new 190779 installSnapshot: aSnapshot; 190780 load! ! 190781 190782!MCPackageLoader class methodsFor: 'as yet unclassified' stamp: 'bf 12/5/2004 12:00'! 190783unloadPackage: aPackage 190784 self new 190785 unloadPackage: aPackage; 190786 loadWithNameLike: aPackage name, '-unload'! ! 190787 190788!MCPackageLoader class methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 12:11'! 190789updatePackage: aPackage withSnapshot: aSnapshot 190790 self new 190791 updatePackage: aPackage withSnapshot: aSnapshot; 190792 load! ! 190793Object subclass: #MCPackageManager 190794 instanceVariableNames: 'package modified' 190795 classVariableNames: '' 190796 poolDictionaries: '' 190797 category: 'Monticello-Versioning'! 190798 190799!MCPackageManager methodsFor: 'accessing' stamp: 'cwp 11/13/2003 14:12'! 190800modified 190801 ^ modified! ! 190802 190803!MCPackageManager methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! 190804modified: aBoolean 190805 modified = aBoolean ifTrue: [^ self]. 190806 modified := aBoolean. 190807 self changed: #modified. 190808 190809 modified ifFalse: 190810 [(((Smalltalk classNamed: 'SmalltalkImage') ifNotNil: [:si | si current]) ifNil: [Smalltalk]) 190811 logChange: '"', self packageName, '"'].! ! 190812 190813!MCPackageManager methodsFor: 'accessing' stamp: 'ab 7/7/2003 16:47'! 190814package 190815 ^ package! ! 190816 190817!MCPackageManager methodsFor: 'accessing' stamp: 'ab 7/7/2003 13:33'! 190818packageInfo 190819 ^ package packageInfo! ! 190820 190821!MCPackageManager methodsFor: 'accessing' stamp: 'ab 7/7/2003 12:18'! 190822packageName 190823 ^ package name! ! 190824 190825!MCPackageManager methodsFor: 'accessing' stamp: 'ab 7/5/2003 23:18'! 190826packageNameWithStar 190827 ^ modified 190828 ifTrue: ['* ', self packageName] 190829 ifFalse: [self packageName]! ! 190830 190831 190832!MCPackageManager methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:03'! 190833initialize 190834 super initialize. 190835 modified := false. 190836 self registerForNotifications.! ! 190837 190838!MCPackageManager methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! 190839initializeWithPackage: aPackage 190840 package := aPackage. 190841 self initialize.! ! 190842 190843 190844!MCPackageManager methodsFor: 'operations' stamp: 'ab 7/19/2003 23:30'! 190845unregister 190846 self class registry removeKey: package. 190847 self class changed: #allManagers! ! 190848 190849 190850!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'! 190851classModified: anEvent 190852 "obsolete - remove this later"! ! 190853 190854!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'! 190855classMoved: anEvent 190856 "obsolete - remove this later"! ! 190857 190858!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'! 190859classRemoved: anEvent 190860 "obsolete - remove this later"! ! 190861 190862!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'! 190863methodModified: anEvent 190864 "obsolete - remove this later"! ! 190865 190866!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'! 190867methodMoved: anEvent 190868 "obsolete - remove this later"! ! 190869 190870!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'! 190871methodRemoved: anEvent 190872 "obsolete - remove this later"! ! 190873 190874!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'! 190875registerForNotifications 190876 "obsolete - remove this later"! ! 190877 190878!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'! 190879registerForNotificationsFrom: aNotifier 190880 "obsolete - remove this later"! ! 190881 190882!MCPackageManager methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:17'! 190883systemChange: anEvent 190884 "obsolete - remove this later"! ! 190885 190886!MCPackageManager methodsFor: 'system changes' stamp: 'avi 11/11/2003 12:06'! 190887update: aSymbol 190888 InMidstOfFileinNotification signal ifFalse: [ 190889 [((aSymbol = #recentMethodSubmissions) 190890 and: [self packageInfo 190891 includesMethodReference: Utilities recentMethodSubmissions last]) 190892 ifTrue: [self modified: true]] 190893 on: Error do: []]! ! 190894 190895"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 190896 190897MCPackageManager class 190898 instanceVariableNames: 'registry'! 190899 190900!MCPackageManager class methodsFor: 'as yet unclassified' stamp: 'ab 3/31/2003 20:45'! 190901allManagers 190902 ^ self registry values! ! 190903 190904!MCPackageManager class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 190905forPackage: aPackage 190906 ^ self registry at: aPackage ifAbsent: 190907 [|mgr| 190908 mgr := self new initializeWithPackage: aPackage. 190909 self registry at: aPackage put: mgr. 190910 self changed: #allManagers. 190911 mgr]! ! 190912 190913!MCPackageManager class methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2005 02:09'! 190914initialize 190915 "Remove this later" 190916 Smalltalk at: #SystemChangeNotifier ifPresent:[:cls| 190917 (cls uniqueInstance) noMoreNotificationsFor: self. 190918 ].! ! 190919 190920!MCPackageManager class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 190921registry 190922 ^ registry ifNil: [registry := Dictionary new]! ! 190923 190924 190925!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/27/2005 14:28'! 190926classModified: anEvent 190927 self managersForClass: anEvent item do:[:mgr| mgr modified: true].! ! 190928 190929!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 21:31'! 190930classMoved: anEvent 190931 self classModified: anEvent. 190932 self managersForCategory: anEvent oldCategory do:[:mgr| mgr modified: true].! ! 190933 190934!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 21:31'! 190935classRemoved: anEvent 190936 self classModified: anEvent! ! 190937 190938!MCPackageManager class methodsFor: 'system changes' stamp: 'md 3/14/2006 23:11'! 190939managersForCategory: aSystemCategory do: aBlock 190940 "Got to be careful here - we might get method categories where capitalization is problematic." 190941 | cat foundOne index | 190942 foundOne := false. 190943 cat := aSystemCategory ifNil:[^nil]. "yes this happens; for example in eToy projects" 190944 "first ask PackageInfos, their package name might not match the category" 190945 self registry do: [:mgr | 190946 (mgr packageInfo includesSystemCategory: aSystemCategory) ifTrue: [ 190947 aBlock value: mgr. 190948 foundOne := true. 190949 ] 190950 ]. 190951 foundOne ifTrue: [^self]. 190952 ["Loop over categories until we found a matching one" 190953 self registry at: (MCPackage named: cat) ifPresent:[:mgr| 190954 aBlock value: mgr. 190955 foundOne := true. 190956 ]. 190957 index := cat lastIndexOf: $-. 190958 index > 0]whileTrue:[ 190959 "Step up to next level package" 190960 cat := cat copyFrom: 1 to: index-1. 190961 ]. 190962 foundOne ifFalse:[ 190963 "Create a new (but only top-level)" 190964 aBlock value: (MCWorkingCopy forPackage: (MCPackage named: (aSystemCategory copyUpTo: $-) capitalized)). 190965 ].! ! 190966 190967!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/27/2005 14:11'! 190968managersForClass: aClass category: methodCategory do: aBlock 190969 (methodCategory isEmptyOrNil or:[methodCategory first ~= $*]) ifTrue:[ 190970 "Not an extension method" 190971 ^self managersForClass: aClass do: aBlock. 190972 ]. 190973 self managersForCategory: methodCategory allButFirst do: aBlock.! ! 190974 190975!MCPackageManager class methodsFor: 'system changes' stamp: 'bf 5/20/2005 16:50'! 190976managersForClass: aClass do: aBlock 190977 190978 self registry do: [:mgr | 190979 (mgr packageInfo includesClass: aClass) 190980 ifTrue: [aBlock value: mgr]]! ! 190981 190982!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 21:40'! 190983managersForClass: aClass selector: aSelector do: aBlock 190984 ^self managersForClass: aClass category: (aClass organization categoryOfElement: aSelector) do: aBlock! ! 190985 190986!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 21:40'! 190987methodModified: anEvent 190988 ^self managersForClass: anEvent itemClass selector: anEvent itemSelector do:[:mgr| mgr modified: true].! ! 190989 190990!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 21:40'! 190991methodMoved: anEvent 190992 self managersForClass: anEvent itemClass category: anEvent oldCategory do:[:mgr| mgr modified: true]. 190993 self methodModified: anEvent.! ! 190994 190995!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:12'! 190996methodRemoved: anEvent 190997 self managersForClass: anEvent itemClass category: anEvent itemProtocol do:[:mgr| mgr modified: true]. 190998! ! 190999 191000!MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 22:18'! 191001registerForNotifications 191002 Smalltalk at: #SystemChangeNotifier ifPresent:[:cls| 191003 (cls uniqueInstance) 191004 noMoreNotificationsFor: self; 191005 notify: self ofSystemChangesOfItem: #class change: #Added using: #classModified:; 191006 notify: self ofSystemChangesOfItem: #class change: #Modified using: #classModified:; 191007 notify: self ofSystemChangesOfItem: #class change: #Renamed using: #classModified:; 191008 notify: self ofSystemChangesOfItem: #class change: #Commented using: #classModified:; 191009 notify: self ofSystemChangesOfItem: #class change: #Recategorized using: #classMoved:; 191010 notify: self ofSystemChangesOfItem: #class change: #Removed using: #classRemoved:; 191011 notify: self ofSystemChangesOfItem: #method change: #Added using: #methodModified:; 191012 notify: self ofSystemChangesOfItem: #method change: #Modified using: #methodModified:; 191013 notify: self ofSystemChangesOfItem: #method change: #Recategorized using: #methodMoved:; 191014 notify: self ofSystemChangesOfItem: #method change: #Removed using: #methodRemoved: 191015 ].! ! 191016MCTestCase subclass: #MCPackageTest 191017 instanceVariableNames: '' 191018 classVariableNames: '' 191019 poolDictionaries: '' 191020 category: 'Tests-Monticello'! 191021 191022!MCPackageTest methodsFor: 'running' stamp: 'oscar.nierstrasz 10/18/2009 17:39'! 191023tearDown 191024 self mockSnapshot install. 191025 DataStream initialize "MCMockClassG ends up in the DataStream TypeMap -- we need to reset"! ! 191026 191027 191028!MCPackageTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 191029testUnload 191030 | mock | 191031 self mockPackage unload. 191032 self deny: (Smalltalk hasClassNamed: #MCMockClassA). 191033 self deny: (MCSnapshotTest includesSelector: #mockClassExtension). 191034 191035 mock := (Smalltalk at: #MCMock). 191036 self assert: (mock subclasses detect: [:c | c name = #MCMockClassA] ifNone: []) isNil! ! 191037Object subclass: #MCPatch 191038 instanceVariableNames: 'operations' 191039 classVariableNames: '' 191040 poolDictionaries: '' 191041 category: 'Monticello-Patching'! 191042 191043!MCPatch methodsFor: '*MonticelloGUI' stamp: 'cwp 8/2/2003 13:34'! 191044browse 191045 ^ (MCPatchBrowser forPatch: self) show! ! 191046 191047 191048!MCPatch methodsFor: 'accessing' stamp: 'ab 5/13/2003 12:18'! 191049operations 191050 ^ operations! ! 191051 191052 191053!MCPatch methodsFor: 'applying' stamp: 'ab 5/24/2003 16:12'! 191054applyTo: anObject 191055 operations do: [:ea | ea applyTo: anObject]. 191056! ! 191057 191058 191059!MCPatch methodsFor: 'intializing' stamp: 'stephaneducasse 2/4/2006 20:47'! 191060initializeWithBase: baseSnapshot target: targetSnapshot 191061 | base target | 191062 operations := OrderedCollection new. 191063 base := MCDefinitionIndex definitions: baseSnapshot definitions. 191064 target := MCDefinitionIndex definitions: targetSnapshot definitions. 191065 191066 target definitions do: 191067 [:t | 191068 base 191069 definitionLike: t 191070 ifPresent: [:b | (b isSameRevisionAs: t) ifFalse: [operations add: (MCModification of: b to: t)]] 191071 ifAbsent: [operations add: (MCAddition of: t)]] 191072 displayingProgress: 'Diffing...'. 191073 191074 base definitions do: 191075 [:b | 191076 target 191077 definitionLike: b 191078 ifPresent: [:t] 191079 ifAbsent: [operations add: (MCRemoval of: b)]] ! ! 191080 191081!MCPatch methodsFor: 'intializing' stamp: 'stephaneducasse 2/4/2006 20:47'! 191082initializeWithOperations: aCollection 191083 operations := aCollection! ! 191084 191085 191086!MCPatch methodsFor: 'querying' stamp: 'cwp 6/9/2003 11:53'! 191087isEmpty 191088 ^ operations isEmpty! ! 191089 191090"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 191091 191092MCPatch class 191093 instanceVariableNames: ''! 191094 191095!MCPatch class methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 15:49'! 191096fromBase: baseSnapshot target: targetSnapshot 191097 ^ self new initializeWithBase: baseSnapshot target: targetSnapshot! ! 191098 191099!MCPatch class methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 15:50'! 191100operations: aCollection 191101 ^ self basicNew initializeWithOperations: aCollection! ! 191102MCCodeTool subclass: #MCPatchBrowser 191103 instanceVariableNames: 'selection' 191104 classVariableNames: '' 191105 poolDictionaries: '' 191106 category: 'MonticelloGUI'! 191107 191108!MCPatchBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 10/24/2006 15:44'! 191109diffSelection 191110 "Open a diff browser on the selection." 191111 191112 selection ifNotNil: 191113 [selection diff]! ! 191114 191115 191116 191117!MCPatchBrowser methodsFor: 'accessing' stamp: 'ab 7/16/2003 14:36'! 191118items 191119 ^ items! ! 191120 191121!MCPatchBrowser methodsFor: 'accessing' stamp: 'ab 7/16/2003 14:39'! 191122list 191123 ^ self items collect: [:ea | ea summary]! ! 191124 191125!MCPatchBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 191126patch: aPatch 191127 items := aPatch operations asSortedCollection! ! 191128 191129 191130!MCPatchBrowser methodsFor: 'as yet unclassified' stamp: 'nk 11/10/2003 21:41'! 191131annotations 191132 ^selection ifNil: [ super annotations ] 191133 ifNotNil: [ selection annotations ]! ! 191134 191135!MCPatchBrowser methodsFor: 'as yet unclassified' stamp: 'nk 2/23/2005 08:04'! 191136changeSetNameForInstall 191137 "Answer the name of the change set into which my selection will be installed. 191138 Derive this from my label. 191139 If I have no label, use the current change set." 191140 191141 | tokens | 191142 label ifNil: [ ^ChangeSet current name ]. 191143 tokens := label findTokens: ' '. 191144 tokens removeAllFoundIn: { 'changes'. 'between'. 'and' }. 191145 (tokens size = 3 and: [ tokens second = '<working' ]) ifTrue: [ ^tokens first, '-to-working' ]. 191146 tokens size = 2 ifFalse: [ ^'InstalledPatches' ]. 191147 ^'{1}-to-{2}' format: tokens ! ! 191148 191149 191150!MCPatchBrowser methodsFor: 'morphic ui' stamp: 'ab 8/22/2003 02:21'! 191151buttonSpecs 191152 ^ #((Invert invert 'Show the reverse set of changes') 191153 (Export export 'Export the changes as a change set'))! ! 191154 191155!MCPatchBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 21:31'! 191156defaultLabel 191157 ^ 'Patch Browser'! ! 191158 191159!MCPatchBrowser methodsFor: 'morphic ui' stamp: 'nk 11/10/2003 20:55'! 191160perform: selector orSendTo: otherTarget 191161 "Selector was just chosen from a menu by a user. If can respond, then 191162perform it on myself. If not, send it to otherTarget, presumably the 191163editPane from which the menu was invoked." 191164 191165 (self respondsTo: selector) 191166 ifTrue: [^ self perform: selector] 191167 ifFalse: [^ otherTarget perform: selector]! ! 191168 191169!MCPatchBrowser methodsFor: 'morphic ui' stamp: 'rkrk 8/23/2009 06:17'! 191170widgetSpecs 191171 Preferences annotationPanes ifFalse: [ ^#( 191172 ((listMorph:selection:menu: list selection methodListMenu:) (0 0 1 0.4) (0 0 0 0)) 191173 ((textMorph: text) (0 0.4 1 1)) 191174 ) ]. 191175 191176 ^ { 191177 #((listMorph:selection:menu:keystroke: list selection methodListMenu: methodListKey:from:) (0 0 1 0.4) (0 0 0 0)). 191178 { #(textMorph: annotations). #(0 0.4 1 0.4). { 0. 0. 0. self defaultAnnotationPaneHeight. } }. 191179 { #(textMorph: text). #(0 0.4 1 1). { 0. self defaultAnnotationPaneHeight. 0. 0. } }. 191180 }! ! 191181 191182 191183!MCPatchBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'! 191184invert 191185 items := items collect: [:ea | ea inverse]. 191186 self changed: #list; changed: #text; changed: #selection! ! 191187 191188!MCPatchBrowser methodsFor: 'selecting' stamp: 'ab 7/16/2003 14:30'! 191189selection 191190 ^ selection 191191 ifNil: [0] 191192 ifNotNil: [self items indexOf: selection]! ! 191193 191194!MCPatchBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'! 191195selection: aNumber 191196 selection := aNumber = 0 ifFalse: [self items at: aNumber]. 191197 self changed: #selection; changed: #text; changed: #annotations! ! 191198 191199 191200!MCPatchBrowser methodsFor: 'subclassresponsibility' stamp: 'stephaneducasse 2/4/2006 20:47'! 191201selectedClass 191202 | definition | 191203 selection ifNil: [ ^nil ]. 191204 (definition := selection definition) ifNil: [ ^nil ]. 191205 definition isMethodDefinition ifFalse: [ ^nil ]. 191206 ^Smalltalk at: definition className ifAbsent: [ ]! ! 191207 191208!MCPatchBrowser methodsFor: 'subclassresponsibility' stamp: 'stephaneducasse 2/4/2006 20:47'! 191209selectedClassOrMetaClass 191210 | definition | 191211 selection ifNil: [ ^nil ]. 191212 (definition := selection definition) ifNil: [ ^nil ]. 191213 definition isMethodDefinition ifFalse: [ ^nil ]. 191214 ^definition actualClass! ! 191215 191216!MCPatchBrowser methodsFor: 'subclassresponsibility' stamp: 'stephaneducasse 2/4/2006 20:47'! 191217selectedMessageCategoryName 191218 | definition | 191219 selection ifNil: [ ^nil ]. 191220 (definition := selection definition) ifNil: [ ^nil ]. 191221 definition isMethodDefinition ifFalse: [ ^nil ]. 191222 ^definition category! ! 191223 191224!MCPatchBrowser methodsFor: 'subclassresponsibility' stamp: 'stephaneducasse 2/4/2006 20:47'! 191225selectedMessageName 191226 | definition | 191227 selection ifNil: [ ^nil ]. 191228 (definition := selection definition) ifNil: [ ^nil ]. 191229 definition isMethodDefinition ifFalse: [ ^nil ]. 191230 ^definition selector! ! 191231 191232 191233!MCPatchBrowser methodsFor: 'text' stamp: 'ab 7/16/2003 14:40'! 191234text 191235 ^ selection ifNil: [''] ifNotNil: [selection source]! ! 191236 191237!MCPatchBrowser methodsFor: 'text' stamp: 'ab 7/16/2003 14:27'! 191238text: aTextOrString 191239 self changed: #text! ! 191240 191241 191242!MCPatchBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! 191243installSelection 191244 | loader | 191245 selection ifNotNil: 191246 [loader := MCPackageLoader new. 191247 selection applyTo: loader. 191248 loader loadWithName: self changeSetNameForInstall ]! ! 191249 191250!MCPatchBrowser methodsFor: 'actions' stamp: 'ar 7/10/2009 22:46'! 191251revertSelection 191252 | loader | 191253 selection ifNotNil: 191254 [loader := MCPackageLoader new. 191255 selection inverse applyTo: loader. 191256 loader loadWithName: self changeSetNameForInstall ]! ! 191257 191258 191259!MCPatchBrowser methodsFor: 'menus' stamp: 'ar 7/10/2009 22:46'! 191260methodListMenu: aMenu 191261 selection ifNotNil: 191262 [aMenu addList:#( 191263 ('install' installSelection) 191264 ('revert' revertSelection) 191265 -)]. 191266 super methodListMenu: aMenu. 191267 ^ aMenu 191268! ! 191269 191270"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 191271 191272MCPatchBrowser class 191273 instanceVariableNames: ''! 191274 191275!MCPatchBrowser class methodsFor: 'as yet unclassified' stamp: 'ab 7/16/2003 14:35'! 191276forPatch: aPatch 191277 ^ self new patch: aPatch! ! 191278Object subclass: #MCPatchOperation 191279 instanceVariableNames: '' 191280 classVariableNames: '' 191281 poolDictionaries: '' 191282 category: 'Monticello-Patching'! 191283 191284!MCPatchOperation methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 10/24/2006 15:40'! 191285diff 191286 "Open a diff browser on the changes." 191287! ! 191288 191289!MCPatchOperation methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 1/14/2009 14:07'! 191290diffFromSource 191291 "Answer fromSource of the operation for a diff tool." 191292 191293 ^self fromSource! ! 191294 191295!MCPatchOperation methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 1/14/2009 14:07'! 191296diffToSource 191297 "Answer toSource of the operation for a diff tool." 191298 191299 ^self toSource! ! 191300 191301!MCPatchOperation methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 10/30/2006 11:15'! 191302patchWrapper 191303 "Answer a wrapper for a patch tree for the receiver." 191304 191305 ^PSMCPatchOperationWrapper with: self! ! 191306 191307!MCPatchOperation methodsFor: '*Polymorph-Tools-Diff' stamp: 'nice 8/27/2009 22:45'! 191308shortSummary 191309 "Answer a short summary of the receiver." 191310 191311 |suffix| 191312 suffix := self fromSource = self toSource 191313 ifTrue: [' (revision changed)'] 191314 ifFalse: ['']. 191315 ^(self isClassPatch 191316 ifTrue: [self definition summary] 191317 ifFalse: [self definition isOrganizationDefinition 191318 ifTrue: [self definition description last] 191319 ifFalse: [self definition isMethodDefinition 191320 ifTrue: [self definition selector asString] 191321 ifFalse: [self definition summary]]]), suffix! ! 191322 191323!MCPatchOperation methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 4/1/2009 12:15'! 191324targetClassName 191325 "Answer the full class *name* of the target since the class may no longer exist." 191326 191327 ^self definition fullClassName! ! 191328 191329 191330!MCPatchOperation methodsFor: 'accessing' stamp: 'nk 11/10/2003 21:38'! 191331annotations 191332 ^self annotations: Preferences defaultAnnotationRequests! ! 191333 191334!MCPatchOperation methodsFor: 'accessing' stamp: 'nk 11/10/2003 21:39'! 191335annotations: requests 191336 "Answer a string for an annotation pane, trying to fulfill the annotation requests. 191337 These might include anything that 191338 Preferences defaultAnnotationRequests 191339 might return. Which includes anything in 191340 Preferences annotationInfo 191341 To edit these, use:" 191342 "Preferences editAnnotations" 191343 191344 ^String streamContents: [ :s | self printAnnotations: requests on: s ].! ! 191345 191346!MCPatchOperation methodsFor: 'accessing' stamp: 'cwp 11/28/2002 06:59'! 191347definition 191348 ^ self subclassResponsibility ! ! 191349 191350!MCPatchOperation methodsFor: 'accessing' stamp: 'cwp 11/27/2002 09:26'! 191351inverse 191352 self subclassResponsibility! ! 191353 191354!MCPatchOperation methodsFor: 'accessing' stamp: 'avi 8/31/2003 17:53'! 191355prefixForOperation: aSymbol 191356 aSymbol == #insert ifTrue: [^ '+']. 191357 aSymbol == #remove ifTrue: [^ '-']. 191358 ^ ' '! ! 191359 191360!MCPatchOperation methodsFor: 'accessing' stamp: 'nk 11/10/2003 21:40'! 191361printAnnotations: requests on: aStream 191362 "Add a string for an annotation pane, trying to fulfill the annotation requests. 191363 These might include anything that 191364 Preferences defaultAnnotationRequests 191365 might return. Which includes anything in 191366 Preferences annotationInfo 191367 To edit these, use:" 191368 "Preferences editAnnotations" 191369 191370 self definition printAnnotations: requests on: aStream.! ! 191371 191372!MCPatchOperation methodsFor: 'accessing' stamp: 'avi 8/31/2003 17:55'! 191373source 191374 ^ self sourceText! ! 191375 191376!MCPatchOperation methodsFor: 'accessing' stamp: 'nk 2/25/2005 17:26'! 191377sourceString 191378 ^self sourceText asString! ! 191379 191380!MCPatchOperation methodsFor: 'accessing' stamp: 'nk 2/25/2005 17:29'! 191381sourceText 191382 | builder | 191383 builder := (Preferences diffsWithPrettyPrint and: [ self targetClass notNil and: [ self isClassPatch not ] ]) 191384 ifTrue: 191385 [PrettyTextDiffBuilder 191386 from: self fromSource 191387 to: self toSource 191388 inClass: self targetClass] 191389 ifFalse: [TextDiffBuilder from: self fromSource to: self toSource]. 191390 ^builder buildDisplayPatch.! ! 191391 191392!MCPatchOperation methodsFor: 'accessing' stamp: 'ab 7/6/2003 00:06'! 191393summary 191394 ^ self definition summary, self summarySuffix! ! 191395 191396!MCPatchOperation methodsFor: 'accessing' stamp: 'ab 7/6/2003 00:06'! 191397summarySuffix 191398 ^ ''! ! 191399 191400 191401!MCPatchOperation methodsFor: 'as yet unclassified' stamp: 'nk 2/25/2005 17:28'! 191402isClassPatch 191403 ^false! ! 191404 191405!MCPatchOperation methodsFor: 'as yet unclassified' stamp: 'nk 2/23/2005 18:17'! 191406targetClass 191407 self subclassResponsibility.! ! 191408 191409 191410!MCPatchOperation methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:11'! 191411<= other 191412 ^ self definition <= other definition! ! 191413 191414 191415!MCPatchOperation methodsFor: 'testing' stamp: 'cwp 11/27/2002 09:30'! 191416isAddition 191417 ^ false! ! 191418 191419!MCPatchOperation methodsFor: 'testing' stamp: 'cwp 11/27/2002 09:30'! 191420isModification 191421 ^ false! ! 191422 191423!MCPatchOperation methodsFor: 'testing' stamp: 'cwp 11/27/2002 09:30'! 191424isRemoval 191425 ^ false! ! 191426 191427"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 191428 191429MCPatchOperation class 191430 instanceVariableNames: ''! 191431MCTestCase subclass: #MCPatchTest 191432 instanceVariableNames: 'patch' 191433 classVariableNames: '' 191434 poolDictionaries: '' 191435 category: 'Tests-Monticello'! 191436 191437!MCPatchTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 191438setUp 191439 |rev1 rev2| 191440 rev1 := MCSnapshotResource takeSnapshot. 191441 self change: #one toReturn: 2. 191442 rev2 := MCSnapshotResource takeSnapshot. 191443 patch := rev2 patchRelativeToBase: rev1. 191444 self change: #one toReturn: 1.! ! 191445 191446!MCPatchTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/2/2003 17:24'! 191447tearDown 191448 self restoreMocks! ! 191449 191450!MCPatchTest methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 15:31'! 191451testPatchContents 191452 self assert: patch operations size = 1. 191453 self assert: patch operations first isModification. 191454 self assert: patch operations first definition selector = #one. 191455! ! 191456Object subclass: #MCPatcher 191457 instanceVariableNames: 'definitions' 191458 classVariableNames: '' 191459 poolDictionaries: '' 191460 category: 'Monticello-Patching'! 191461 191462!MCPatcher methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:46'! 191463addDefinition: aDefinition 191464 definitions add: aDefinition! ! 191465 191466!MCPatcher methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 191467initializeWithSnapshot: aSnapshot 191468 definitions := MCDefinitionIndex definitions: aSnapshot definitions! ! 191469 191470!MCPatcher methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 14:23'! 191471modifyDefinition: baseDefinition to: targetDefinition 191472 self addDefinition: targetDefinition! ! 191473 191474!MCPatcher methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 23:48'! 191475patchedSnapshot 191476 ^ MCSnapshot fromDefinitions: definitions definitions! ! 191477 191478!MCPatcher methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:46'! 191479removeDefinition: aDefinition 191480 definitions remove: aDefinition! ! 191481 191482"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 191483 191484MCPatcher class 191485 instanceVariableNames: ''! 191486 191487!MCPatcher class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 191488apply: aPatch to: aSnapshot 191489 | loader | 191490 loader := self snapshot: aSnapshot. 191491 aPatch applyTo: loader. 191492 ^ loader patchedSnapshot! ! 191493 191494!MCPatcher class methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 14:22'! 191495snapshot: aSnapshot 191496 ^ self new initializeWithSnapshot: aSnapshot! ! 191497MCVariableDefinition subclass: #MCPoolImportDefinition 191498 instanceVariableNames: '' 191499 classVariableNames: '' 191500 poolDictionaries: '' 191501 category: 'Monticello-Modeling'! 191502 191503!MCPoolImportDefinition methodsFor: 'testing' stamp: 'bf 8/29/2006 11:41'! 191504isOrderDependend 191505 ^false! ! 191506 191507!MCPoolImportDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:51'! 191508isPoolImport 191509 ^ true! ! 191510 191511"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 191512 191513MCPoolImportDefinition class 191514 instanceVariableNames: ''! 191515 191516!MCPoolImportDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 22:59'! 191517type 191518 ^ #pool! ! 191519MCScriptDefinition subclass: #MCPostscriptDefinition 191520 instanceVariableNames: '' 191521 classVariableNames: '' 191522 poolDictionaries: '' 191523 category: 'Monticello-Modeling'! 191524 191525!MCPostscriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:16'! 191526postload 191527 self evaluate! ! 191528 191529!MCPostscriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:16'! 191530sortKey 191531 ^ 'zzz' "force to the end so it gets loaded late"! ! 191532 191533"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 191534 191535MCPostscriptDefinition class 191536 instanceVariableNames: ''! 191537 191538!MCPostscriptDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:04'! 191539scriptSelector 191540 ^ #postscript! ! 191541MCScriptDefinition subclass: #MCPreambleDefinition 191542 instanceVariableNames: '' 191543 classVariableNames: '' 191544 poolDictionaries: '' 191545 category: 'Monticello-Modeling'! 191546 191547!MCPreambleDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:15'! 191548load 191549 super load. 191550 self evaluate! ! 191551 191552"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 191553 191554MCPreambleDefinition class 191555 instanceVariableNames: ''! 191556 191557!MCPreambleDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:04'! 191558scriptSelector 191559 ^ #preamble! ! 191560RWBinaryOrTextStream subclass: #MCPseudoFileStream 191561 instanceVariableNames: 'localName' 191562 classVariableNames: '' 191563 poolDictionaries: '' 191564 category: 'MonticelloConfigurations'! 191565!MCPseudoFileStream commentStamp: '<historical>' prior: 0! 191566A pseudo file stream which can be used for updates.! 191567 191568 191569!MCPseudoFileStream methodsFor: 'accessing' stamp: 'ar 4/14/2005 19:54'! 191570localName 191571 ^localName! ! 191572 191573!MCPseudoFileStream methodsFor: 'accessing' stamp: 'ar 4/14/2005 19:54'! 191574localName: aString 191575 localName := aString! ! 191576Object subclass: #MCReader 191577 instanceVariableNames: 'stream' 191578 classVariableNames: '' 191579 poolDictionaries: '' 191580 category: 'Monticello-Storing'! 191581 191582!MCReader methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 191583stream: aStream 191584 stream := aStream! ! 191585 191586"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 191587 191588MCReader class 191589 instanceVariableNames: ''! 191590 191591!MCReader class methodsFor: 'instance creation' stamp: 'avi 1/21/2004 19:02'! 191592on: aStream 191593 ^ self new stream: aStream! ! 191594 191595!MCReader class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:47'! 191596on: aStream name: aFileName 191597 | class | 191598 class := self readerClassForFileNamed: aFileName. 191599 ^ class 191600 ifNil: [self error: 'Unsupported format: ', aFileName] 191601 ifNotNil: [class on: aStream]! ! 191602 191603 191604!MCReader class methodsFor: 'testing' stamp: 'avi 1/21/2004 19:00'! 191605canReadFileNamed: fileName 191606 ^ (fileName endsWith: self extension)! ! 191607 191608!MCReader class methodsFor: 'testing' stamp: 'avi 1/21/2004 19:01'! 191609concreteSubclasses 191610 ^ self allSubclasses reject: [:c | c isAbstract]! ! 191611 191612!MCReader class methodsFor: 'testing' stamp: 'avi 1/21/2004 19:01'! 191613isAbstract 191614 ^ (self respondsTo: #extension) not! ! 191615 191616!MCReader class methodsFor: 'testing' stamp: 'avi 1/21/2004 19:03'! 191617readerClassForFileNamed: fileName 191618 ^ self concreteSubclasses 191619 detect: [:c | c canReadFileNamed: fileName] 191620 ifNone: [nil]! ! 191621MCPatchOperation subclass: #MCRemoval 191622 instanceVariableNames: 'definition' 191623 classVariableNames: '' 191624 poolDictionaries: '' 191625 category: 'Monticello-Patching'! 191626 191627!MCRemoval methodsFor: 'accessing' stamp: 'ab 5/24/2003 16:11'! 191628applyTo: anObject 191629 anObject removeDefinition: definition! ! 191630 191631!MCRemoval methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'! 191632baseDefinition 191633 ^ definition! ! 191634 191635!MCRemoval methodsFor: 'accessing' stamp: 'cwp 11/27/2002 10:02'! 191636definition 191637 ^ definition! ! 191638 191639!MCRemoval methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:44'! 191640fromSource 191641 ^ definition source! ! 191642 191643!MCRemoval methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:38'! 191644sourceString 191645 ^self fromSource asText 191646 addAttribute: TextEmphasis struckOut; 191647 addAttribute: TextColor blue; 191648 yourself! ! 191649 191650!MCRemoval methodsFor: 'accessing' stamp: 'ab 5/13/2003 12:22'! 191651summary 191652 ^ definition summary, ' (removed)'! ! 191653 191654!MCRemoval methodsFor: 'accessing' stamp: 'ab 7/6/2003 00:05'! 191655summarySuffix 191656 ^ ' (removed)'! ! 191657 191658!MCRemoval methodsFor: 'accessing' stamp: 'nk 2/25/2005 17:23'! 191659targetClass 191660 ^ definition actualClass! ! 191661 191662!MCRemoval methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'! 191663targetDefinition 191664 ^ nil! ! 191665 191666!MCRemoval methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:44'! 191667toSource 191668 ^ ''! ! 191669 191670 191671!MCRemoval methodsFor: 'as yet unclassified' stamp: 'ab 8/22/2003 02:26'! 191672inverse 191673 ^ MCAddition of: definition! ! 191674 191675!MCRemoval methodsFor: 'as yet unclassified' stamp: 'nk 2/25/2005 17:28'! 191676isClassPatch 191677 ^definition isClassDefinition! ! 191678 191679 191680!MCRemoval methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! 191681intializeWithDefinition: aDefinition 191682 definition := aDefinition! ! 191683 191684 191685!MCRemoval methodsFor: 'testing' stamp: 'cwp 11/28/2002 07:24'! 191686isRemoval 191687 ^ true! ! 191688 191689"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 191690 191691MCRemoval class 191692 instanceVariableNames: ''! 191693 191694!MCRemoval class methodsFor: 'as yet unclassified' stamp: 'cwp 11/27/2002 10:03'! 191695of: aDefinition 191696 ^ self new intializeWithDefinition: aDefinition! ! 191697MCScriptDefinition subclass: #MCRemovalPostscriptDefinition 191698 instanceVariableNames: '' 191699 classVariableNames: '' 191700 poolDictionaries: '' 191701 category: 'Monticello-Modeling'! 191702 191703!MCRemovalPostscriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:15'! 191704unload 191705 super unload. 191706 self evaluate! ! 191707 191708"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 191709 191710MCRemovalPostscriptDefinition class 191711 instanceVariableNames: ''! 191712 191713!MCRemovalPostscriptDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:04'! 191714scriptSelector 191715 ^ #postscriptOfRemoval ! ! 191716MCScriptDefinition subclass: #MCRemovalPreambleDefinition 191717 instanceVariableNames: '' 191718 classVariableNames: '' 191719 poolDictionaries: '' 191720 category: 'Monticello-Modeling'! 191721 191722!MCRemovalPreambleDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:14'! 191723sortKey 191724 ^ 'zzz' "force to the end so it gets unloaded early"! ! 191725 191726!MCRemovalPreambleDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:15'! 191727unload 191728 super unload. 191729 self evaluate! ! 191730 191731"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 191732 191733MCRemovalPreambleDefinition class 191734 instanceVariableNames: ''! 191735 191736!MCRemovalPreambleDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:04'! 191737scriptSelector 191738 ^ #preambleOfRemoval! ! 191739Object subclass: #MCRepository 191740 instanceVariableNames: 'creationTemplate storeDiffs' 191741 classVariableNames: 'Settings' 191742 poolDictionaries: '' 191743 category: 'Monticello-Repositories'! 191744 191745!MCRepository methodsFor: '*MonticelloGUI' stamp: 'lr 9/26/2003 20:03'! 191746morphicOpen 191747 self morphicOpen: nil! ! 191748 191749!MCRepository methodsFor: '*MonticelloGUI' stamp: 'lr 9/26/2003 20:03'! 191750morphicOpen: aWorkingCopy 191751 self subclassResponsibility ! ! 191752 191753!MCRepository methodsFor: '*MonticelloGUI' stamp: 'bf 4/14/2005 17:30'! 191754openAndEditTemplateCopy 191755 ^ self class fillInTheBlankConfigure: (self asCreationTemplate ifNil: [^nil])! ! 191756 191757 191758!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/31/2004 01:08'! 191759alwaysStoreDiffs 191760 ^ storeDiffs ifNil: [false]! ! 191761 191762!MCRepository methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:48'! 191763asCreationTemplate 191764 ^ self creationTemplate! ! 191765 191766!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:20'! 191767basicStoreVersion: aVersion 191768 self subclassResponsibility! ! 191769 191770!MCRepository methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 191771closestAncestorVersionFor: anAncestry ifNone: errorBlock 191772 anAncestry breadthFirstAncestorsDo: 191773 [:ancestorInfo | 191774 (self versionWithInfo: ancestorInfo) ifNotNil: [:v | ^ v]]. 191775 ^ errorBlock value! ! 191776 191777!MCRepository methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:46'! 191778creationTemplate 191779 ^ creationTemplate! ! 191780 191781!MCRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 191782creationTemplate: aString 191783 self creationTemplate ifNotNil: [ self error: 'Creation template already set for this MCRepository instance.' ]. 191784 191785 creationTemplate := aString.! ! 191786 191787!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:53'! 191788description 191789 ^ self class name! ! 191790 191791!MCRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 191792doAlwaysStoreDiffs 191793 storeDiffs := true! ! 191794 191795!MCRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 191796doNotAlwaysStoreDiffs 191797 storeDiffs := false! ! 191798 191799!MCRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 12:36'! 191800hash 191801 ^ self description hash! ! 191802 191803!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:27'! 191804notificationForVersion: aVersion 191805 ^ MCVersionNotification version: aVersion repository: self! ! 191806 191807!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:23'! 191808notifyList 191809 ^ #()! ! 191810 191811!MCRepository methodsFor: 'as yet unclassified' stamp: 'bf 3/10/2005 23:01'! 191812possiblyNewerVersionsOfAnyOf: someVersions 191813 ^#()! ! 191814 191815!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/31/2004 01:06'! 191816prepareVersionForStorage: aVersion 191817 ^ self alwaysStoreDiffs 191818 ifTrue: [aVersion asDiffAgainst: 191819 (self closestAncestorVersionFor: aVersion info ifNone: [^ aVersion])] 191820 ifFalse: [aVersion]! ! 191821 191822!MCRepository methodsFor: 'as yet unclassified' stamp: 'mas 9/24/2003 04:21'! 191823printOn: aStream 191824 super printOn: aStream. 191825 aStream 191826 nextPut: $(; 191827 nextPutAll: self description; 191828 nextPut: $).! ! 191829 191830!MCRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 191831sendNotificationsForVersion: aVersion 191832 | notification notifyList | 191833 notifyList := self notifyList. 191834 notifyList isEmpty ifFalse: 191835 [notification := self notificationForVersion: aVersion. 191836 notifyList do: [:ea | notification notify: ea]]! ! 191837 191838!MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/31/2004 01:05'! 191839storeVersion: aVersion 191840 self basicStoreVersion: (self prepareVersionForStorage: aVersion). 191841 self sendNotificationsForVersion: aVersion! ! 191842 191843!MCRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 12:36'! 191844= other 191845 ^ other species = self species and: [other description = self description]! ! 191846 191847 191848!MCRepository methodsFor: 'interface' stamp: 'ab 8/21/2003 12:40'! 191849includesVersionNamed: aString 191850 self subclassResponsibility! ! 191851 191852!MCRepository methodsFor: 'interface' stamp: 'avi 10/9/2003 12:42'! 191853versionWithInfo: aVersionInfo 191854 ^ self versionWithInfo: aVersionInfo ifAbsent: [nil]! ! 191855 191856!MCRepository methodsFor: 'interface' stamp: 'ab 8/16/2003 18:22'! 191857versionWithInfo: aVersionInfo ifAbsent: aBlock 191858 self subclassResponsibility ! ! 191859 191860 191861!MCRepository methodsFor: 'testing' stamp: 'nk 11/2/2003 10:55'! 191862isValid 191863 ^true! ! 191864 191865 191866!MCRepository methodsFor: '*gofer-testing' stamp: 'lr 9/24/2009 17:02'! 191867isRepositoryGroup 191868 ^ false! ! 191869 191870"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 191871 191872MCRepository class 191873 instanceVariableNames: ''! 191874 191875!MCRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:05'! 191876fillInTheBlankConfigure 191877 ^ self fillInTheBlankConfigure: self creationTemplate 191878 ! ! 191879 191880!MCRepository class methodsFor: '*MonticelloGUI' stamp: 'hfm 9/15/2009 16:46'! 191881fillInTheBlankConfigure: aTemplateString 191882 | chunk repo | 191883 aTemplateString 191884 ifNil: [^ false]. 191885 chunk := UIManager default 191886 multiLineRequest: self fillInTheBlankRequest 191887 centerAt: Sensor cursorPoint 191888 initialAnswer: aTemplateString 191889 answerHeight: 350. 191890 (chunk notNil and: [ chunk notEmpty ]) 191891 ifTrue: [repo := self readFrom: chunk readStream. 191892 repo creationTemplate: chunk]. 191893 ^ repo! ! 191894 191895 191896!MCRepository class methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 00:30'! 191897allConcreteSubclasses 191898 ^ self withAllSubclasses reject: [:ea | ea isAbstract]! ! 191899 191900!MCRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:59'! 191901creationTemplate 191902 self subclassResponsibility.! ! 191903 191904!MCRepository class methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 00:29'! 191905description 191906 ^ nil! ! 191907 191908!MCRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:58'! 191909fillInTheBlankRequest 191910 self subclassResponsibility.! ! 191911 191912!MCRepository class methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 12:59'! 191913isAbstract 191914 ^ self description isNil! ! 191915 191916!MCRepository class methodsFor: 'as yet unclassified' stamp: 'ab 7/24/2003 21:01'! 191917morphicConfigure 191918 ^ self new! ! 191919 191920 191921!MCRepository class methodsFor: 'external settings' stamp: 'stephaneducasse 2/4/2006 20:47'! 191922fetchExternalSettingsIn: aDirectory 191923 "Scan for settings file" 191924 "MCRepository fetchExternalSettingsIn: ExternalSettings preferenceDirectory" 191925 191926 | stream | 191927 (aDirectory fileExists: self settingsFileName) 191928 ifFalse: [^self]. 191929 stream := aDirectory readOnlyFileNamed: self settingsFileName. 191930 stream 191931 ifNotNil: [ 191932 [Settings := ExternalSettings parseServerEntryArgsFrom: stream] 191933 ensure: [stream close]]. 191934! ! 191935 191936!MCRepository class methodsFor: 'external settings' stamp: 'bf 12/17/2004 20:30'! 191937releaseExternalSettings 191938 Settings := nil. 191939! ! 191940 191941!MCRepository class methodsFor: 'external settings' stamp: 'bf 12/17/2004 20:36'! 191942settingsFileName 191943 ^ 'mcSettings'! ! 191944 191945 191946!MCRepository class methodsFor: 'initialization' stamp: 'bf 4/15/2005 10:19'! 191947initialize 191948 "self initialize" 191949 191950 ExternalSettings registerClient: self. 191951! ! 191952Object subclass: #MCRepositoryGroup 191953 instanceVariableNames: 'repositories useCache' 191954 classVariableNames: '' 191955 poolDictionaries: '' 191956 category: 'Monticello-Versioning'! 191957!MCRepositoryGroup commentStamp: '<historical>' prior: 0! 191958A singleton class, holds the list of repositories. Can look for a requested VersionInfo among its repositories.! 191959 191960 191961!MCRepositoryGroup methodsFor: '*scriptloader' stamp: 'sd 3/15/2008 17:33'! 191962removeHTTPRepositoryLocationNamed: aRepositoryString 191963 191964 | httpRepo others | 191965 httpRepo := repositories select: [:each | each isKindOf: MCHttpRepository]. 191966 others := repositories reject: [:each | each isKindOf: MCHttpRepository]. 191967 repositories := others, (httpRepo reject: [:each | each locationWithTrailingSlash = aRepositoryString]). 191968 self changed: #repositories! ! 191969 191970 191971!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'jf 8/31/2009 14:55'! 191972addRepository: aRepository 191973 ((repositories includes: aRepository) or: [aRepository == MCCacheRepository default]) 191974 ifFalse: [repositories add: aRepository. 191975 self class default addRepository: aRepository]. 191976 self changed: #repositories. 191977 ^ aRepository! ! 191978 191979!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'NorbertHartl 6/20/2008 10:11'! 191980disableCache 191981 useCache := false! ! 191982 191983!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'abc 11/6/2004 20:32'! 191984includesVersionNamed: aString 191985 self repositoriesDo: [:ea | (ea includesVersionNamed: aString) ifTrue: [^ true]]. 191986 ^ false ! ! 191987 191988!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'avi 11/7/2003 00:20'! 191989includes: aRepository 191990 ^ self repositories includes: aRepository! ! 191991 191992!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:03'! 191993initialize 191994 super initialize. 191995 repositories := OrderedCollection new! ! 191996 191997!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'ab 7/22/2003 00:11'! 191998removeRepository: aRepository 191999 repositories remove: aRepository ifAbsent: []. 192000 self changed: #repositories! ! 192001 192002!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'al 6/22/2008 11:57'! 192003repositories 192004 ^ (self useCache 192005 ifTrue: [Array with: MCCacheRepository default] 192006 ifFalse: [Array new]) , repositories select: #isValid! ! 192007 192008!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'avi 11/7/2003 00:51'! 192009repositoriesDo: aBlock 192010 self repositories do: [:ea | [aBlock value: ea] on: Error do: []]! ! 192011 192012!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'abc 6/20/2008 10:02'! 192013useCache 192014 ^ useCache ifNil: [ 192015 useCache := true 192016 ]! ! 192017 192018!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'dvf 8/10/2004 23:02'! 192019versionWithInfo: aVersionInfo 192020 ^self versionWithInfo: aVersionInfo ifNone: [ self error: 'Could not find version ', aVersionInfo name printString,'. Maybe you need to add a repository?' ]! ! 192021 192022!MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 192023versionWithInfo: aVersionInfo ifNone: aBlock 192024 self repositoriesDo: [:ea | (ea versionWithInfo: aVersionInfo) ifNotNil: [:v | ^ v]]. 192025 ^aBlock value! ! 192026 192027 192028!MCRepositoryGroup methodsFor: '*gofer-testing' stamp: 'lr 9/24/2009 17:01'! 192029isRepositoryGroup 192030 ^ true! ! 192031 192032"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 192033 192034MCRepositoryGroup class 192035 instanceVariableNames: 'default'! 192036 192037!MCRepositoryGroup class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 192038default 192039 ^ default ifNil: [default := self new]! ! 192040 192041 192042!MCRepositoryGroup class methodsFor: '*gofer-core' stamp: 'lr 10/2/2009 10:29'! 192043withAll: anArray 192044 ^ anArray 192045 inject: self new 192046 into: [ :group :repo | group addRepository: repo ]! ! 192047MCVersionInspector subclass: #MCRepositoryInspector 192048 instanceVariableNames: 'repository packages versions loaded selectedPackage selectedVersion' 192049 classVariableNames: '' 192050 poolDictionaries: '' 192051 category: 'MonticelloGUI'! 192052 192053!MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:20'! 192054hasVersion 192055 ^ selectedVersion notNil! ! 192056 192057!MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 17:11'! 192058load 192059 self hasVersion ifTrue: 192060 [super load. 192061 self version workingCopy repositoryGroup addRepository: repository].! ! 192062 192063!MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 192064refresh 192065 packages := repository packages. 192066 self changed: #packageList. 192067 self packageSelection: self packageSelection. 192068! ! 192069 192070!MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 192071setRepository: aRepository workingCopy: aWorkingCopy 192072 repository := aRepository. 192073 aWorkingCopy isNil ifFalse: [ selectedPackage := aWorkingCopy package]. 192074 self refresh! ! 192075 192076!MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:20'! 192077summary 192078 ^ selectedVersion 192079 ifNotNil: [selectedVersion summary] 192080 ifNil: ['']! ! 192081 192082!MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 192083version 192084 ^ version ifNil: [version := repository versionWithInfo: selectedVersion]! ! 192085 192086 192087!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'! 192088buttonSpecs 192089 ^#(('Refresh' refresh 'refresh the version-list')) , super buttonSpecs! ! 192090 192091!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'! 192092defaultExtent 192093 ^450@300! ! 192094 192095!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'! 192096defaultLabel 192097 ^'Repository: ' , repository description! ! 192098 192099!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:09'! 192100packageList 192101 ^ packages collect: [:ea | ea name]! ! 192102 192103!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'! 192104packageListMenu: aMenu 192105 ^aMenu! ! 192106 192107!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:07'! 192108packageSelection 192109 ^ packages indexOf: selectedPackage! ! 192110 192111!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 192112packageSelection: aNumber 192113 selectedPackage := aNumber isZero ifFalse: [ packages at: aNumber ]. 192114 versions := repository versionsAvailableForPackage: selectedPackage. 192115 self changed: #packageSelection; changed: #versionList! ! 192116 192117!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 192118sortedVersions 192119 | sorter | 192120 sorter := MCVersionSorter new. 192121 sorter addAllVersionInfos: versions. 192122 ^ sorter sortedVersionInfos select: [:ea | versions includes: ea]! ! 192123 192124!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/29/2004 11:32'! 192125versionList 192126 ^ self sortedVersions collect: [:ea | ea name]! ! 192127 192128!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:57'! 192129versionListMenu: aMenu 192130 ^aMenu! ! 192131 192132!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:07'! 192133versionSelection 192134 ^ versions indexOf: selectedVersion! ! 192135 192136!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 192137versionSelection: aNumber 192138 aNumber isZero 192139 ifTrue: [ selectedVersion := nil ] 192140 ifFalse: [ 192141 selectedVersion := versions at: aNumber]. 192142 self changed: #versionSelection; changed: #summary! ! 192143 192144!MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'! 192145widgetSpecs 192146 ^#( ((buttonRow) (0 0 1 0) (0 0 0 30)) 192147 ((listMorph: package) (0 0 0.5 0.6) (0 30 0 0)) 192148 ((listMorph: version) (0.5 0 1 0.6) (0 30 0 0)) 192149 ((textMorph: summary) (0 0.6 1 1) (0 0 0 0)) )! ! 192150 192151"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 192152 192153MCRepositoryInspector class 192154 instanceVariableNames: ''! 192155 192156!MCRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 18:51'! 192157repository: aFileBasedRepository workingCopy: aWorkingCopy 192158 ^self new 192159 setRepository: aFileBasedRepository workingCopy: aWorkingCopy; 192160 yourself! ! 192161MCTestCase subclass: #MCRepositoryTest 192162 instanceVariableNames: 'repository ancestors' 192163 classVariableNames: '' 192164 poolDictionaries: '' 192165 category: 'Tests-Monticello'! 192166 192167!MCRepositoryTest methodsFor: 'accessing' stamp: 'ab 7/7/2003 14:32'! 192168snapshotAt: aVersionInfo 192169 ^ (repository versionWithInfo: aVersionInfo) snapshot! ! 192170 192171 192172!MCRepositoryTest methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! 192173addVersionWithSnapshot: aSnapshot name: aString 192174 | version | 192175 version := self versionWithSnapshot: aSnapshot name: aString. 192176 self addVersion: version. 192177 ^ version info! ! 192178 192179!MCRepositoryTest methodsFor: 'actions' stamp: 'ab 8/16/2003 17:46'! 192180addVersion: aVersion 192181 self subclassResponsibility ! ! 192182 192183!MCRepositoryTest methodsFor: 'actions' stamp: 'ab 7/19/2003 16:20'! 192184saveSnapshot1 192185 ^ self saveSnapshot: self snapshot1 named: 'rev1'! ! 192186 192187!MCRepositoryTest methodsFor: 'actions' stamp: 'ab 7/19/2003 16:20'! 192188saveSnapshot2 192189 ^ self saveSnapshot: self snapshot2 named: 'rev2'! ! 192190 192191!MCRepositoryTest methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! 192192saveSnapshot: aSnapshot named: aString 192193 | version | 192194 version := self versionWithSnapshot: aSnapshot name: aString. 192195 repository storeVersion: version. 192196 ^ version info 192197 ! ! 192198 192199 192200!MCRepositoryTest methodsFor: 'asserting' stamp: 'ab 7/19/2003 23:59'! 192201assertMissing: aVersionInfo 192202 self assert: (repository versionWithInfo: aVersionInfo) isNil! ! 192203 192204!MCRepositoryTest methodsFor: 'asserting' stamp: 'ab 8/16/2003 18:07'! 192205assertVersionInfos: aCollection 192206 self assert: repository allVersionInfos asSet = aCollection asSet! ! 192207 192208 192209!MCRepositoryTest methodsFor: 'building' stamp: 'ab 7/10/2003 01:03'! 192210snapshot1 192211 ^ (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: #('y'))))! ! 192212 192213!MCRepositoryTest methodsFor: 'building' stamp: 'ab 7/10/2003 01:03'! 192214snapshot2 192215 ^ (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: #('x'))))! ! 192216 192217!MCRepositoryTest methodsFor: 'building' stamp: 'stephaneducasse 2/4/2006 20:47'! 192218versionWithSnapshot: aSnapshot name: aString 192219 | info | 192220 info := self mockVersionInfo: aString. 192221 ^ MCVersion 192222 package: (MCPackage new name: aString) 192223 info: info 192224 snapshot: aSnapshot! ! 192225 192226 192227!MCRepositoryTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 192228testAddAndLoad 192229 | node | 192230 node := self addVersionWithSnapshot: self snapshot1 name: 'rev1'. 192231 self assert: (self snapshotAt: node) = self snapshot1. 192232! ! 192233 192234!MCRepositoryTest methodsFor: 'tests' stamp: 'avi 2/17/2004 03:24'! 192235testIncludesName 192236 self deny: (repository includesVersionNamed: 'MonticelloTest-xxx.1-rev1'). 192237 self saveSnapshot1. 192238 self assert: (repository includesVersionNamed: 'MonticelloTest-xxx.1-rev1'). 192239 self deny: (repository includesVersionNamed: 'MonticelloTest-xxx.1-rev2'). 192240 self saveSnapshot2. 192241 self assert: (repository includesVersionNamed: 'MonticelloTest-xxx.1-rev2').! ! 192242 192243!MCRepositoryTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 192244testLoadMissingNode 192245 | node | 192246 node := MCVersionInfo new. 192247 self assertMissing: node! ! 192248 192249!MCRepositoryTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 192250testStoreAndLoad 192251 | node node2 | 192252 node := self saveSnapshot1. 192253 node2 := self saveSnapshot2. 192254 self assert: (self snapshotAt: node) = self snapshot1. 192255 self assert: (self snapshotAt: node2) = self snapshot2.! ! 192256 192257"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 192258 192259MCRepositoryTest class 192260 instanceVariableNames: ''! 192261 192262!MCRepositoryTest class methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 12:45'! 192263isAbstract 192264 ^ self = MCRepositoryTest! ! 192265MCWriteOnlyRepository subclass: #MCSMReleaseRepository 192266 instanceVariableNames: 'packageName user password' 192267 classVariableNames: '' 192268 poolDictionaries: '' 192269 category: 'Monticello-Repositories'! 192270 192271!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 192272basicStoreVersion: aVersion 192273 | url | 192274 url := self uploadVersion: aVersion. 192275 self releaseVersion: aVersion url: url! ! 192276 192277!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/10/2004 14:11'! 192278checkResult: resultString 192279(#( 'HTTP/1.1 201 ' 'HTTP/1.1 200 ' 'HTTP/1.0 201 ' 'HTTP/1.0 200 ') 192280 anySatisfy: [:code | resultString beginsWith: code ]) 192281 ifFalse: [self error: resultString]. 192282! ! 192283 192284!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/10/2004 14:15'! 192285description 192286 ^ 'sm://', packageName! ! 192287 192288!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 192289initializeWithPackage: packageString user: userString password: passString 192290 packageName := packageString. 192291 user := userString. 192292 password := passString. 192293! ! 192294 192295!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 192296releaseVersion: aVersion url: urlString 192297 | result | 192298 result := HTTPSocket 192299 httpPost: self squeakMapUrl, '/packagebyname/', packageName, '/newrelease' 192300 args: {'version' -> {(aVersion info name copyAfter: $.) extractNumber asString}. 192301 'note' -> {aVersion info message}. 192302 'downloadURL' -> {urlString}} 192303 user: user 192304 passwd: password. 192305 result contents size > 4 ifTrue: [self error: result contents] 192306! ! 192307 192308!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/10/2004 14:58'! 192309squeakMapUrl 192310 ^ 'http://localhost:9070/sm' 192311! ! 192312 192313!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 192314stringForVersion: aVersion 192315 | stream | 192316 stream := RWBinaryOrTextStream on: String new. 192317 aVersion fileOutOn: stream. 192318 ^ stream contents! ! 192319 192320!MCSMReleaseRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 192321uploadVersion: aVersion 192322 | result stream | 192323 result := HTTPSocket 192324 httpPut: (self stringForVersion: aVersion) 192325 to: self squeakMapUrl, '/upload/', aVersion fileName 192326 user: user 192327 passwd: password. 192328 self checkResult: result. 192329 stream := result readStream. 192330 stream upToAll: 'http://'. 192331 ^ 'http://', stream upToEnd! ! 192332 192333"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 192334 192335MCSMReleaseRepository class 192336 instanceVariableNames: ''! 192337 192338!MCSMReleaseRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:03'! 192339fillInTheBlankRequest 192340 ^ 'SqueakMap Release Repository:' 192341 ! ! 192342 192343!MCSMReleaseRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:03'! 192344morphicConfigure 192345 ^ self fillInTheBlankConfigure! ! 192346 192347 192348!MCSMReleaseRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/10/2004 14:15'! 192349creationTemplate 192350 ^ 192351'MCSMReleaseRepository 192352 package: ''mypackage'' 192353 user: ''squeak'' 192354 password: ''squeak''' 192355 ! ! 192356 192357!MCSMReleaseRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/10/2004 13:42'! 192358description 192359 ^ 'SqueakMap Release'! ! 192360 192361!MCSMReleaseRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/10/2004 14:14'! 192362package: packageString user: userString password: passString 192363 ^ self basicNew initializeWithPackage: packageString user: userString password: passString! ! 192364MCTool subclass: #MCSaveVersionDialog 192365 instanceVariableNames: 'name message' 192366 classVariableNames: 'PreviousMessages' 192367 poolDictionaries: '' 192368 category: 'MonticelloGUI'! 192369!MCSaveVersionDialog commentStamp: 'ab 9/8/2009 08:24' prior: 0! 192370Monticello's dialog that allows the user to change the version name and to enter a message for the commit log.! 192371 192372 192373 192374!MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'ab 9/8/2009 08:34'! 192375accept 192376 | version message | 192377 version := (self findTextMorph: #versionName) text asString. 192378 message := (self findTextMorph: #logMessage) text asString. 192379 self addAsLastLogMessage: message. 192380 self answer: {version. message}! ! 192381 192382!MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'ab 9/8/2009 08:45'! 192383buttonSpecs 192384 ^ #((Accept accept 'accept version name and log message') 192385 (Cancel cancel 'cancel saving version') 192386 ('Old log messages...' oldLogMessages 're-use a previous log message') 192387 ) ! ! 192388 192389!MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'ab 8/24/2003 20:41'! 192390cancel 192391 self answer: nil! ! 192392 192393!MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'ab 8/24/2003 20:07'! 192394defaultExtent 192395 ^ 400@300! ! 192396 192397!MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'ab 9/8/2009 08:58'! 192398defaultLabel 192399 ^ 'Edit Version Name and Log Message:'! ! 192400 192401!MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'ab 9/8/2009 08:48'! 192402oldLogMessages 192403 | list index | 192404 list := self previousMessages collect: [:s | s truncateWithElipsisTo: 30]. 192405 list ifEmpty: [UIManager default inform: 'No previous log message was entered'. ^ self]. 192406 index := UIManager default chooseFrom: list. 192407 192408 "no comment was selected" 192409 index isZero ifTrue: [ ^ self ]. 192410 192411 self logMessage: (self previousMessages at: index)! ! 192412 192413!MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'jrp 7/2/2005 10:33'! 192414widgetSpecs 192415 ^ #( 192416 ((textMorph: versionName) (0 0 1 0) (0 0 0 30)) 192417 ((textMorph: logMessage) (0 0 1 1) (0 30 0 -30)) 192418 ((buttonRow) (0 1 1 1) (0 -40 0 0)) 192419 )! ! 192420 192421 192422!MCSaveVersionDialog methodsFor: 'log message history' stamp: 'ab 9/8/2009 08:26'! 192423addAsLastLogMessage: aString 192424 ((self previousMessages size > 0) and: [self previousMessages first = aString]) 192425 ifTrue: [ ^ self ]. 192426 192427 self previousMessages addFirst: aString. 192428 (self previousMessages size > self maxLogMessageHistory) 192429 ifTrue: [self previousMessages removeLast]! ! 192430 192431!MCSaveVersionDialog methodsFor: 'log message history' stamp: 'ab 9/8/2009 08:25'! 192432maxLogMessageHistory 192433 ^ 15! ! 192434 192435!MCSaveVersionDialog methodsFor: 'log message history' stamp: 'ab 9/8/2009 08:16'! 192436previousMessages 192437 PreviousMessages ifNil: [ PreviousMessages := OrderedCollection new]. 192438 ^ PreviousMessages! ! 192439 192440 192441!MCSaveVersionDialog methodsFor: 'accessing' stamp: 'ab 8/24/2003 20:41'! 192442logMessage 192443 ^ message ifNil: ['empty log message']! ! 192444 192445!MCSaveVersionDialog methodsFor: 'accessing' stamp: 'AlexandreBergel 8/1/2008 12:18'! 192446logMessage: aString 192447 message := aString. 192448 self changed: #logMessage! ! 192449 192450!MCSaveVersionDialog methodsFor: 'accessing' stamp: 'ab 8/24/2003 20:37'! 192451versionName 192452 ^ name! ! 192453 192454!MCSaveVersionDialog methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 192455versionName: aString 192456 name := aString. 192457 self changed: #versionName! ! 192458 192459"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 192460 192461MCSaveVersionDialog class 192462 instanceVariableNames: ''! 192463Object subclass: #MCScanner 192464 instanceVariableNames: 'stream' 192465 classVariableNames: '' 192466 poolDictionaries: '' 192467 category: 'Monticello-Chunk Format'! 192468 192469!MCScanner methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 192470next 192471 | c | 192472 stream skipSeparators. 192473 c := stream peek. 192474 c = $# ifTrue: [c := stream next; peek]. 192475 c = $' ifTrue: [^ self nextString]. 192476 c = $( ifTrue: [^ self nextArray]. 192477 c isAlphaNumeric ifTrue: [^ self nextSymbol]. 192478 self error: 'Unknown token type'. ! ! 192479 192480!MCScanner methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 20:27'! 192481nextArray 192482 stream next. "(" 192483 ^ Array streamContents: 192484 [:s | 192485 [stream skipSeparators. 192486 (stream peek = $)) or: [stream atEnd]] whileFalse: [s nextPut: self next]. 192487 stream next = $) ifFalse: [self error: 'Unclosed array']]! ! 192488 192489!MCScanner methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 20:09'! 192490nextString 192491 ^ stream nextDelimited: $'! ! 192492 192493!MCScanner methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 20:16'! 192494nextSymbol 192495 ^ (String streamContents: 192496 [:s | 192497 [stream peek isAlphaNumeric] whileTrue: [s nextPut: stream next]]) asSymbol 192498 ! ! 192499 192500!MCScanner methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 192501stream: aStream 192502 stream := aStream! ! 192503 192504"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 192505 192506MCScanner class 192507 instanceVariableNames: ''! 192508 192509!MCScanner class methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 20:32'! 192510scanTokens: aString 192511 "compatibility" 192512 ^ Array with: (self scan: aString readStream)! ! 192513 192514!MCScanner class methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 20:14'! 192515scan: aStream 192516 ^ (self new stream: aStream) next! ! 192517MCTestCase subclass: #MCScannerTest 192518 instanceVariableNames: '' 192519 classVariableNames: '' 192520 poolDictionaries: '' 192521 category: 'Tests-Monticello'! 192522 192523!MCScannerTest methodsFor: 'asserting' stamp: 'avi 1/22/2004 20:23'! 192524assertScans: anArray 192525 self assert: (MCScanner scan: anArray printString readStream) = anArray! ! 192526 192527 192528!MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:19'! 192529test1 192530 self assertScans: #(a '23' (x))! ! 192531 192532!MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:22'! 192533test2 192534 self assertScans: 'it''s alive'! ! 192535 192536!MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:23'! 192537test3 192538 self assert: (MCScanner scan: '(a #b c)' readStream) = #(a #b c)! ! 192539 192540!MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:23'! 192541test4 192542 self assertScans: #(a '23' (x () ')''q' y12)).! ! 192543 192544!MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:26'! 192545test5 192546 self assertScans: #((a) b)! ! 192547 192548!MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:28'! 192549test6 192550 self should: [MCScanner scan: '(a b' readStream] raise: Error! ! 192551MCDefinition subclass: #MCScriptDefinition 192552 instanceVariableNames: 'script packageName' 192553 classVariableNames: '' 192554 poolDictionaries: '' 192555 category: 'Monticello-Modeling'! 192556 192557!MCScriptDefinition methodsFor: 'comparing' stamp: 'avi 2/28/2005 16:55'! 192558= aDefinition 192559 ^ (super = aDefinition) 192560 and: [script = aDefinition script]! ! 192561 192562 192563!MCScriptDefinition methodsFor: 'visiting' stamp: 'bf 8/12/2009 21:41'! 192564accept: aVisitor 192565 aVisitor visitScriptDefinition: self! ! 192566 192567 192568!MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:12'! 192569description 192570 ^ Array with: packageName with: self scriptSelector! ! 192571 192572!MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:22'! 192573packageInfo 192574 ^ PackageInfo named: packageName! ! 192575 192576!MCScriptDefinition methodsFor: 'accessing' stamp: 'bf 8/13/2009 00:09'! 192577packageName 192578 ^ packageName! ! 192579 192580!MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 16:54'! 192581script 192582 ^ script! ! 192583 192584!MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:10'! 192585scriptSelector 192586 ^ self class scriptSelector! ! 192587 192588!MCScriptDefinition methodsFor: 'accessing' stamp: 'bf 10/25/2005 19:05'! 192589sortKey 192590 ^ '!!', self scriptSelector "force to the front so it gets loaded first"! ! 192591 192592!MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:04'! 192593source 192594 ^ script! ! 192595 192596!MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:12'! 192597summary 192598 ^ packageName, ' ', self scriptSelector! ! 192599 192600 192601!MCScriptDefinition methodsFor: 'installing' stamp: 'avi 2/28/2005 17:03'! 192602evaluate 192603 Compiler evaluate: script! ! 192604 192605!MCScriptDefinition methodsFor: 'installing' stamp: 'avi 2/28/2005 17:11'! 192606installScript 192607 self installScript: script! ! 192608 192609!MCScriptDefinition methodsFor: 'installing' stamp: 'bf 10/25/2005 18:55'! 192610installScript: aString 192611 | sel pi | 192612 sel := (self scriptSelector, ':') asSymbol. 192613 pi := self packageInfo. 192614 (pi respondsTo: sel) 192615 ifTrue: [pi perform: sel with: aString]! ! 192616 192617!MCScriptDefinition methodsFor: 'installing' stamp: 'avi 2/28/2005 17:12'! 192618load 192619 self installScript! ! 192620 192621!MCScriptDefinition methodsFor: 'installing' stamp: 'avi 2/28/2005 17:12'! 192622unload 192623 self installScript: nil! ! 192624 192625 192626!MCScriptDefinition methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! 192627initializeWithScript: aString packageName: packageString 192628 script := aString. 192629 packageName := packageString! ! 192630 192631 192632!MCScriptDefinition methodsFor: 'testing' stamp: 'bf 8/12/2009 22:55'! 192633isScriptDefinition 192634 ^true! ! 192635 192636"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 192637 192638MCScriptDefinition class 192639 instanceVariableNames: ''! 192640 192641!MCScriptDefinition class methodsFor: 'as yet unclassified' stamp: 'bf 4/4/2005 12:20'! 192642from: aPackageInfo 192643 ^ self script: (aPackageInfo perform: self scriptSelector) contents asString packageName: aPackageInfo name! ! 192644 192645!MCScriptDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:00'! 192646scriptSelector 192647 self subclassResponsibility! ! 192648 192649!MCScriptDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 16:59'! 192650script: aString packageName: packageString 192651 ^ self instanceLike: (self new initializeWithScript: aString packageName: packageString)! ! 192652 192653!MCScriptDefinition class methodsFor: 'as yet unclassified' stamp: 'bf 8/13/2009 00:24'! 192654scriptSelector: selectorString script: aString packageName: packageString 192655 ^ (self subclassForScriptSelector: selectorString) 192656 script: aString packageName: packageString! ! 192657 192658!MCScriptDefinition class methodsFor: 'as yet unclassified' stamp: 'bf 8/13/2009 00:25'! 192659subclassForScriptSelector: selectorString 192660 ^self allSubclasses detect: [:ea | ea scriptSelector = selectorString]! ! 192661MCDoItParser subclass: #MCScriptParser 192662 instanceVariableNames: '' 192663 classVariableNames: '' 192664 poolDictionaries: '' 192665 category: 'Monticello-Chunk Format'! 192666 192667!MCScriptParser methodsFor: 'as yet unclassified' stamp: 'bf 8/13/2009 00:13'! 192668addDefinitionsTo: aCollection 192669 | tokens definition | 192670 tokens := Scanner new scanTokens: source. 192671 definition := MCScriptDefinition 192672 scriptSelector: tokens second allButLast 192673 script: tokens third 192674 packageName: tokens first third. 192675 aCollection add: definition.! ! 192676 192677"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 192678 192679MCScriptParser class 192680 instanceVariableNames: ''! 192681 192682!MCScriptParser class methodsFor: 'as yet unclassified' stamp: 'bf 8/13/2009 00:07'! 192683pattern 192684 ^'(PackageInfo named: *'! ! 192685MCTestCase subclass: #MCSerializationTest 192686 instanceVariableNames: '' 192687 classVariableNames: '' 192688 poolDictionaries: '' 192689 category: 'Tests-Monticello'! 192690 192691!MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 192692assertClass: readerClass providesServices: labels 192693 | services suffix | 192694 suffix := readerClass extension. 192695 self assert: (FileList isReaderNamedRegistered: readerClass name). 192696 services := readerClass fileReaderServicesForFile: 'foo' suffix: suffix. 192697 self assert: ((services collect: [:service | service buttonLabel]) includesAllOf: labels)! ! 192698 192699!MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 192700assertDependenciesMatchWith: writerClass 192701 | stream readerClass expected actual | 192702 readerClass := writerClass readerClass. 192703 expected := self mockVersionWithDependencies. 192704 stream := RWBinaryOrTextStream on: String new. 192705 writerClass fileOut: expected on: stream. 192706 actual := (readerClass on: stream reset) dependencies. 192707 self assert: actual = expected dependencies.! ! 192708 192709!MCSerializationTest methodsFor: 'asserting' stamp: 'cwp 8/1/2003 14:57'! 192710assertExtensionProvidedBy: aClass 192711 self shouldnt: [aClass readerClass extension] raise: Exception.! ! 192712 192713!MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 192714assertSnapshotsMatchWith: writerClass 192715 | readerClass expected stream actual | 192716 readerClass := writerClass readerClass. 192717 expected := self mockSnapshot. 192718 stream := RWBinaryOrTextStream on: String new. 192719 (writerClass on: stream) writeSnapshot: expected. 192720 actual := readerClass snapshotFromStream: stream reset. 192721 self assertSnapshot: actual matches: expected.! ! 192722 192723!MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 192724assertVersionInfosMatchWith: writerClass 192725 | stream readerClass expected actual | 192726 readerClass := writerClass readerClass. 192727 expected := self mockVersion. 192728 stream := RWBinaryOrTextStream on: String new. 192729 writerClass fileOut: expected on: stream. 192730 actual := readerClass versionInfoFromStream: stream reset. 192731 self assert: actual = expected info.! ! 192732 192733!MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 192734assertVersionsMatchWith: writerClass 192735 | stream readerClass expected actual | 192736 readerClass := writerClass readerClass. 192737 expected := self mockVersion. 192738 stream := RWBinaryOrTextStream on: String new. 192739 writerClass fileOut: expected on: stream. 192740 actual := readerClass versionFromStream: stream reset. 192741 self assertVersion: actual matches: expected.! ! 192742 192743 192744!MCSerializationTest methodsFor: 'mocks' stamp: 'stephaneducasse 2/4/2006 20:47'! 192745mockDiffyVersion 192746 | repos workingCopy base next | 192747 repos := MCDictionaryRepository new. 192748 workingCopy := MCWorkingCopy forPackage: self mockPackage. 192749 workingCopy repositoryGroup addRepository: repos. 192750 MCRepositoryGroup default removeRepository: repos. 192751 base := self mockVersion. 192752 repos storeVersion: base. 192753 self change: #a toReturn: 'a2'. 192754 next := self mockVersionWithAncestor: base. 192755 ^ next asDiffAgainst: base ! ! 192756 192757 192758!MCSerializationTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! 192759testMcdSerialization 192760 | stream expected actual | 192761 expected := self mockDiffyVersion. 192762 stream := RWBinaryOrTextStream on: String new. 192763 MCMcdWriter fileOut: expected on: stream. 192764 actual := MCMcdReader versionFromStream: stream reset. 192765 self assertVersion: actual matches: expected.! ! 192766 192767!MCSerializationTest methodsFor: 'testing' stamp: 'avi 1/19/2004 15:14'! 192768testMczSerialization 192769 self assertVersionsMatchWith: MCMczWriter. 192770 self assertExtensionProvidedBy: MCMczWriter. 192771 self assertVersionInfosMatchWith: MCMczWriter. 192772 self assertDependenciesMatchWith: MCMczWriter.! ! 192773 192774!MCSerializationTest methodsFor: 'testing' stamp: 'cwp 8/3/2003 18:43'! 192775testStSerialization 192776 self assertSnapshotsMatchWith: MCStWriter.! ! 192777MCWriteOnlyRepository subclass: #MCSmtpRepository 192778 instanceVariableNames: 'email' 192779 classVariableNames: '' 192780 poolDictionaries: '' 192781 category: 'Monticello-Repositories'! 192782 192783!MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:21'! 192784basicStoreVersion: aVersion 192785 MailSender sendMessage: (self messageForVersion: aVersion)! ! 192786 192787!MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 13:11'! 192788bodyForVersion: aVersion 192789 ^ String streamContents: 192790 [ :s | 192791 s nextPutAll: 'from version info:'; cr; cr. 192792 s nextPutAll: aVersion info summary]! ! 192793 192794!MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:56'! 192795description 192796 ^ 'mailto://', email! ! 192797 192798!MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 192799emailAddress: aString 192800 email := aString ! ! 192801 192802!MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 192803messageForVersion: aVersion 192804 | message data | 192805 message := MailMessage empty. 192806 message setField: 'from' toString: MailSender userName. 192807 message setField: 'to' toString: email. 192808 message setField: 'subject' toString: (self subjectForVersion: aVersion). 192809 192810 message body: 192811 (MIMEDocument 192812 contentType: 'text/plain' 192813 content: (self bodyForVersion: aVersion)). 192814 192815 "Prepare the gzipped data" 192816 data := RWBinaryOrTextStream on: String new. 192817 aVersion fileOutOn: data. 192818 message addAttachmentFrom: data reset withName: aVersion fileName. 192819 ^ message! ! 192820 192821!MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 13:14'! 192822subjectForVersion: aVersion 192823 ^ '[Package] ', aVersion info name! ! 192824 192825"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 192826 192827MCSmtpRepository class 192828 instanceVariableNames: ''! 192829 192830!MCSmtpRepository class methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:56'! 192831description 192832 ^ 'SMTP'! ! 192833 192834!MCSmtpRepository class methodsFor: 'as yet unclassified' stamp: 'alain.plantec 2/6/2009 17:52'! 192835morphicConfigure 192836 | address | 192837 address := UIManager default request: 'Email address:' translated. 192838 ^ address isEmpty ifFalse: [self new emailAddress: address]! ! 192839Object subclass: #MCSnapshot 192840 instanceVariableNames: 'definitions' 192841 classVariableNames: '' 192842 poolDictionaries: '' 192843 category: 'Monticello-Base'! 192844 192845!MCSnapshot methodsFor: 'accessing' stamp: 'ab 12/4/2002 18:09'! 192846definitions 192847 ^ definitions! ! 192848 192849!MCSnapshot methodsFor: 'accessing' stamp: 'ab 7/10/2003 01:05'! 192850hash 192851 ^ definitions asArray hash! ! 192852 192853!MCSnapshot methodsFor: 'accessing' stamp: 'ab 7/10/2003 01:05'! 192854= other 192855 ^ definitions asArray = other definitions asArray! ! 192856 192857 192858!MCSnapshot methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! 192859initializeWithDefinitions: aCollection 192860 definitions := aCollection.! ! 192861 192862 192863!MCSnapshot methodsFor: 'loading' stamp: 'ab 7/6/2003 23:31'! 192864install 192865 MCPackageLoader installSnapshot: self! ! 192866 192867!MCSnapshot methodsFor: 'loading' stamp: 'ab 7/7/2003 12:11'! 192868updatePackage: aPackage 192869 MCPackageLoader updatePackage: aPackage withSnapshot: self! ! 192870 192871 192872!MCSnapshot methodsFor: 'patching' stamp: 'ab 7/7/2003 00:37'! 192873patchRelativeToBase: aSnapshot 192874 ^ MCPatch fromBase: aSnapshot target: self! ! 192875 192876"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 192877 192878MCSnapshot class 192879 instanceVariableNames: ''! 192880 192881!MCSnapshot class methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 23:48'! 192882empty 192883 ^ self fromDefinitions: #()! ! 192884 192885!MCSnapshot class methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 23:48'! 192886fromDefinitions: aCollection 192887 ^ self new initializeWithDefinitions: aCollection! ! 192888MCCodeTool subclass: #MCSnapshotBrowser 192889 instanceVariableNames: 'categorySelection classSelection protocolSelection methodSelection switch' 192890 classVariableNames: '' 192891 poolDictionaries: '' 192892 category: 'MonticelloGUI'! 192893 192894!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/18/2003 15:47'! 192895allClassNames 192896 ^ (items 192897 select: [:ea | ea isOrganizationDefinition not] 192898 thenCollect: [:ea | ea className]) asSet. 192899! ! 192900 192901!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'cwp 7/10/2003 20:23'! 192902extensionClassNames 192903 ^ (self allClassNames difference: self packageClassNames) asSortedCollection! ! 192904 192905!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/5/2003 23:41'! 192906extensionsCategory 192907 ^ '*Extensions'! ! 192908 192909!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/18/2003 15:48'! 192910methodsForSelectedClass 192911 ^ items select: [:ea | (ea className = classSelection) 192912 and: [ea isMethodDefinition] 192913 and: [ea classIsMeta = self switchIsClass]].! ! 192914 192915!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 192916methodsForSelectedClassCategory 192917 | visibleClasses | 192918 visibleClasses := self visibleClasses. 192919 ^ items select: [:ea | (visibleClasses includes: ea className) 192920 and: [ea isMethodDefinition] 192921 and: [ea classIsMeta = self switchIsClass]].! ! 192922 192923!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 192924methodsForSelectedProtocol 192925 | methods | 192926 protocolSelection ifNil: [^ Array new]. 192927 methods := self methodsForSelectedClass asOrderedCollection. 192928 (protocolSelection = '-- all --') 192929 ifFalse: [methods removeAllSuchThat: [:ea | ea category ~= protocolSelection]]. 192930 ^ methods 192931 192932 ! ! 192933 192934!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/18/2003 15:48'! 192935packageClasses 192936 ^ items select: [:ea | ea isClassDefinition]! ! 192937 192938!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/18/2003 15:48'! 192939packageClassNames 192940 ^ self packageClasses collect: [:ea | ea className]! ! 192941 192942!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'nk 10/11/2003 16:53'! 192943selectedClass 192944 classSelection ifNil: [ ^nil ]. 192945 ^Smalltalk at: classSelection ifAbsent: [ nil ]. 192946! ! 192947 192948!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 192949selectedClassOrMetaClass 192950 | class | 192951 classSelection ifNil: [ ^nil ]. 192952 class := Smalltalk at: classSelection ifAbsent: [ ^nil ]. 192953 ^self switchIsClass ifTrue: [ class class ] 192954 ifFalse: [ class ].! ! 192955 192956!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'nk 11/10/2003 21:29'! 192957selectedMessageCategoryName 192958 ^protocolSelection! ! 192959 192960!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'nk 10/11/2003 16:45'! 192961selectedMessageName 192962 ^methodSelection ifNotNil: [^ methodSelection selector ]. 192963! ! 192964 192965!MCSnapshotBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 192966snapshot: aSnapshot 192967 items := aSnapshot definitions asSortedCollection. 192968 self categorySelection: 0.! ! 192969 192970 192971!MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 18:33'! 192972categoryList 192973 ^ self visibleCategories! ! 192974 192975!MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 20:20'! 192976classList 192977 ^ self visibleClasses! ! 192978 192979!MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/13/2003 02:11'! 192980methodList 192981 ^ self visibleMethods collect: [:ea | ea selector]! ! 192982 192983!MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 19:07'! 192984protocolList 192985 ^ self visibleProtocols! ! 192986 192987!MCSnapshotBrowser methodsFor: 'listing' stamp: 'ab 7/18/2003 15:48'! 192988visibleCategories 192989 ^ (self packageClasses collect: [:ea | ea category]) 192990 asSet asSortedCollection add: self extensionsCategory; yourself.! ! 192991 192992!MCSnapshotBrowser methodsFor: 'listing' stamp: 'ab 7/18/2003 15:48'! 192993visibleClasses 192994 ^ categorySelection = self extensionsCategory 192995 ifTrue: [self extensionClassNames] 192996 ifFalse: [self packageClasses 192997 select: [:ea | ea category = categorySelection] 192998 thenCollect: [:ea | ea className]].! ! 192999 193000!MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 19:46'! 193001visibleMethods 193002 ^ classSelection 193003 ifNil: [#()] 193004 ifNotNil: [self methodsForSelectedProtocol]! ! 193005 193006!MCSnapshotBrowser methodsFor: 'listing' stamp: 'stephaneducasse 2/4/2006 20:47'! 193007visibleProtocols 193008 | methods protocols | 193009 self switchIsComment ifTrue: [^ Array new]. 193010 methods := self methodsForSelectedClass. 193011 protocols := (methods collect: [:ea | ea category]) asSet asSortedCollection. 193012 (protocols size > 1) ifTrue: [protocols add: '-- all --']. 193013 ^ protocols ! ! 193014 193015 193016!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:52'! 193017categoryListMenu: aMenu 193018 categorySelection 193019 ifNotNil: [aMenu 193020 add: (categorySelection = '*Extensions' 193021 ifTrue: ['load all extension methods' translated] 193022 ifFalse: ['load class category {1}' translated format: {categorySelection}]) 193023 action: #loadCategorySelection]. 193024 ^ aMenu! ! 193025 193026!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 6/12/2004 14:01'! 193027classListMenu: aMenu 193028 classSelection ifNil: [ ^aMenu ]. 193029 193030 super classListMenu: aMenu. 193031 193032 aMenu 193033 addLine; 193034 add: ('load class {1}' translated format: {classSelection}) 193035 action: #loadClassSelection. 193036 ^ aMenu! ! 193037 193038!MCSnapshotBrowser methodsFor: 'menus' stamp: 'cwp 7/10/2003 18:03'! 193039inspectSelection 193040 ^ self methodSelection inspect! ! 193041 193042!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:53'! 193043loadCategorySelection 193044 "Load the entire selected category" 193045 categorySelection ifNil: [ ^self ]. 193046 self methodsForSelectedClassCategory do: [ :m | m load ].! ! 193047 193048!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/30/2004 15:06'! 193049loadClassSelection 193050 classSelection ifNil: [ ^self ]. 193051 (self packageClasses detect: [ :ea | ea className = classSelection ] ifNone: [ ^self ]) load. 193052 self methodsForSelectedClass do: [ :m | m load ].! ! 193053 193054!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:45'! 193055loadMethodSelection 193056 methodSelection ifNil: [ ^self ]. 193057 methodSelection load.! ! 193058 193059!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:46'! 193060loadProtocolSelection 193061 protocolSelection ifNil: [ ^self ]. 193062 self methodsForSelectedProtocol do: [ :m | m load ].! ! 193063 193064!MCSnapshotBrowser methodsFor: 'menus' stamp: 'marcus.denker 11/10/2008 10:04'! 193065methodListMenu: aMenu 193066 super methodListMenu: aMenu. 193067 self selectedMessageName 193068 ifNotNil: [:msgName | aMenu addLine; add: 'load method' translated action: #loadMethodSelection]. 193069 ^ aMenu! ! 193070 193071!MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:43'! 193072protocolListMenu: aMenu 193073 protocolSelection 193074 ifNotNil: [aMenu 193075 add: ('load protocol ''{1}''' translated format: {protocolSelection}) 193076 action: #loadProtocolSelection ]. 193077 ^ aMenu! ! 193078 193079 193080!MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'bf 5/27/2005 19:33'! 193081buttonSpecs 193082 ^ #(('instance' switchBeInstance 'show instance' buttonEnabled switchIsInstance) 193083 ('?' switchBeComment 'show comment' buttonEnabled switchIsComment) 193084 ('class' switchBeClass 'show class' buttonEnabled switchIsClass))! ! 193085 193086!MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:29'! 193087defaultExtent 193088 ^ 650@400.! ! 193089 193090!MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 21:31'! 193091defaultLabel 193092 ^ 'Snapshot Browser'! ! 193093 193094!MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'bf 5/27/2005 19:13'! 193095widgetSpecs 193096 193097 Preferences annotationPanes ifFalse: [ ^#( 193098 ((listMorph: category) (0 0 0.25 0.4)) 193099 ((listMorph: class) (0.25 0 0.50 0.4) (0 0 0 -30)) 193100 ((listMorph: protocol) (0.50 0 0.75 0.4)) 193101 ((listMorph:selection:menu:keystroke: methodList methodSelection methodListMenu: methodListKey:from:) (0.75 0 1 0.4)) 193102 ((buttonRow) (0.25 0.4 0.5 0.4) (0 -30 0 0)) 193103 ((textMorph: text) (0 0.4 1 1)) 193104 ) ]. 193105 193106 ^#( 193107 ((listMorph: category) (0 0 0.25 0.4)) 193108 ((listMorph: class) (0.25 0 0.50 0.4) (0 0 0 -30)) 193109 ((listMorph: protocol) (0.50 0 0.75 0.4)) 193110 ((listMorph:selection:menu:keystroke: methodList methodSelection methodListMenu: methodListKey:from:) (0.75 0 1 0.4)) 193111 193112 ((buttonRow) (0.25 0.4 0.5 0.4) (0 -30 0 0)) 193113 193114 ((textMorph: annotations) (0 0.4 1 0.4) (0 0 0 30)) 193115 ((textMorph: text) (0 0.4 1 1) (0 30 0 0)) 193116 )! ! 193117 193118 193119!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 18:33'! 193120categorySelection 193121 ^ categorySelection ifNil: [0] ifNotNil: [self visibleCategories indexOf: categorySelection]! ! 193122 193123!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'! 193124categorySelection: aNumber 193125 categorySelection := aNumber = 0 ifFalse: [self visibleCategories at: aNumber]. 193126 self classSelection: 0. 193127 self changed: #categorySelection; 193128 changed: #annotations; 193129 changed: #classList. 193130! ! 193131 193132!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 18:28'! 193133classSelection 193134 ^ classSelection ifNil: [0] ifNotNil: [self visibleClasses indexOf: classSelection]! ! 193135 193136!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'! 193137classSelection: aNumber 193138 classSelection := aNumber = 0 ifFalse: [self visibleClasses at: aNumber]. 193139 self protocolSelection: 0. 193140 self changed: #classSelection; 193141 changed: #protocolList; 193142 changed: #annotations; 193143 changed: #methodList. 193144! ! 193145 193146!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 20:26'! 193147methodSelection 193148 ^ methodSelection 193149 ifNil: [0] 193150 ifNotNil: [self visibleMethods indexOf: methodSelection]! ! 193151 193152!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'! 193153methodSelection: aNumber 193154 methodSelection := aNumber = 0 ifFalse: [self visibleMethods at: aNumber]. 193155 self changed: #methodSelection; changed: #text; changed: #annotations! ! 193156 193157!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 19:35'! 193158protocolSelection 193159 ^ protocolSelection 193160 ifNil: [0] 193161 ifNotNil: [self visibleProtocols indexOf: protocolSelection]! ! 193162 193163!MCSnapshotBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'! 193164protocolSelection: anInteger 193165 protocolSelection := (anInteger = 0 ifFalse: [self visibleProtocols at: anInteger]). 193166 self methodSelection: 0. 193167 self changed: #protocolSelection; 193168 changed: #methodList; 193169 changed: #annotations! ! 193170 193171 193172!MCSnapshotBrowser methodsFor: 'switch' stamp: 'cwp 7/12/2003 18:57'! 193173signalSwitchChanged 193174 self protocolSelection: 0. 193175 self 193176 changed: #switchIsInstance; 193177 changed: #switchIsComment; 193178 changed: #switchIsClass; 193179 changed: #protocolList; 193180 changed: #methodList; 193181 changed: #text.! ! 193182 193183!MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'! 193184switchBeClass 193185 switch := #class. 193186 self signalSwitchChanged.! ! 193187 193188!MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'! 193189switchBeComment 193190 switch := #comment. 193191 self signalSwitchChanged.! ! 193192 193193!MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'! 193194switchBeInstance 193195 switch := #instance. 193196 self signalSwitchChanged.! ! 193197 193198!MCSnapshotBrowser methodsFor: 'switch' stamp: 'cwp 7/12/2003 18:05'! 193199switchIsClass 193200 ^ switch = #class! ! 193201 193202!MCSnapshotBrowser methodsFor: 'switch' stamp: 'cwp 7/12/2003 18:04'! 193203switchIsComment 193204 ^ switch = #comment.! ! 193205 193206!MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'! 193207switchIsInstance 193208 switch ifNil: [switch := #instance]. 193209 ^ switch = #instance.! ! 193210 193211 193212!MCSnapshotBrowser methodsFor: 'text' stamp: 'nk 7/24/2003 13:40'! 193213annotations 193214 methodSelection ifNotNil: [^ methodSelection annotations ]. 193215 ^ ''! ! 193216 193217!MCSnapshotBrowser methodsFor: 'text' stamp: 'nk 7/24/2003 13:41'! 193218annotations: stuff 193219 self changed: #annotations! ! 193220 193221!MCSnapshotBrowser methodsFor: 'text' stamp: 'ab 7/18/2003 15:48'! 193222classCommentString 193223 ^ (items 193224 detect: [:ea | ea isClassDefinition and: [ea className = classSelection]] 193225 ifNone: [^ '']) comment.! ! 193226 193227!MCSnapshotBrowser methodsFor: 'text' stamp: 'stephaneducasse 2/4/2006 20:47'! 193228classDefinitionString 193229 | defs | 193230 defs := items select: [:ea | (ea isClassDefinition or: [ea isClassDefinitionExtension]) 193231 and: [ea className = classSelection]]. 193232 193233 defs isEmpty ifTrue: [^ 'This class is defined elsewhere.']. 193234 193235 ^ String streamContents: [:stream | 193236 defs asArray sort 193237 do: [:ea | ea printDefinitionOn: stream] 193238 separatedBy: [stream nextPut: $.; cr] 193239 ].! ! 193240 193241!MCSnapshotBrowser methodsFor: 'text' stamp: 'tfel 8/28/2009 20:42'! 193242scriptDefinitionString 193243 | defs | 193244 defs := items select: [:ea | ea isScriptDefinition]. 193245 defs isEmpty ifTrue: [^'(package defines no scripts)']. 193246 193247 ^ String streamContents: [:stream | 193248 defs asArray sort 193249 do: [:ea | stream nextPutAll: '---------- package '; 193250 nextPutAll: ea scriptSelector; 193251 nextPutAll: ' ----------'; cr; 193252 nextPutAll: ea script; cr] 193253 separatedBy: [stream cr]].! ! 193254 193255!MCSnapshotBrowser methodsFor: 'text' stamp: 'bf 8/12/2009 23:00'! 193256text 193257 self switchIsComment ifTrue: [^ self classCommentString]. 193258 methodSelection ifNotNil: [^ methodSelection source]. 193259 protocolSelection ifNotNil: [^ '']. 193260 classSelection ifNotNil: [^ self classDefinitionString]. 193261 categorySelection ifNil: [^self scriptDefinitionString]. 193262 ^ ''! ! 193263 193264!MCSnapshotBrowser methodsFor: 'text' stamp: 'cwp 7/11/2003 00:30'! 193265text: aTextOrString 193266 self changed: #text! ! 193267 193268"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 193269 193270MCSnapshotBrowser class 193271 instanceVariableNames: ''! 193272 193273!MCSnapshotBrowser class methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 18:03'! 193274forSnapshot: aSnapshot 193275 ^ self new snapshot: aSnapshot! ! 193276MCTestCase subclass: #MCSnapshotBrowserTest 193277 instanceVariableNames: 'model morph' 193278 classVariableNames: '' 193279 poolDictionaries: '' 193280 category: 'Tests-Monticello'! 193281 193282!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 01:19'! 193283assertAListIncludes: anArrayOfStrings 193284 self listMorphs 193285 detect: [:m | m getList includesAllOf: anArrayOfStrings] 193286 ifNone: [self assert: false].! ! 193287 193288!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 193289assertAListMatches: strings 193290 | listMorphs list | 193291 listMorphs := self listMorphs. 193292 listMorphs 193293 detect: [:m | list := m getList. (list size = strings size) and: [list includesAllOf: strings]] 193294 ifNone: [self assert: false].! ! 193295 193296!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 09:12'! 193297assertButtonExists: aString 193298 self buttonMorphs detect: [:m | m label = aString] ifNone: [self assert: false]. 193299 ! ! 193300 193301!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 09:26'! 193302assertButtonOn: aString 193303 self assert: (self findButtonWithLabel: aString) getModelState. 193304 ! ! 193305 193306!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 02:38'! 193307assertTextIs: aString 193308 self assert: self textMorph contents = aString.! ! 193309 193310!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 193311denyAListHasSelection: aString 193312 | found | 193313 found := true. 193314 self listMorphs 193315 detect: [:m | m selection = aString] 193316 ifNone: [found := false]. 193317 self deny: found.! ! 193318 193319!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 193320denyAListIncludesAnyOf: anArrayOfStrings 193321 | found | 193322 found := true. 193323 self listMorphs 193324 detect: [:m | m getList includesAnyOf: anArrayOfStrings] 193325 ifNone: [found := false]. 193326 self deny: found.! ! 193327 193328!MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 09:27'! 193329denyButtonOn: aString 193330 self deny: (self findButtonWithLabel: aString) getModelState. 193331 ! ! 193332 193333 193334!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/28/2003 22:21'! 193335annotationTextMorph 193336 ^ (self morphsOfClass: TextMorph) first! ! 193337 193338!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 09:12'! 193339buttonMorphs 193340 ^ self morphsOfClass: PluggableButtonMorph! ! 193341 193342!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 09:19'! 193343findButtonWithLabel: aString 193344 ^ self buttonMorphs detect: [:m | m label = aString]! ! 193345 193346!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 01:28'! 193347findListContaining: aString 193348 ^ self listMorphs detect: [:m | m getList includes: aString]! ! 193349 193350!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 02:34'! 193351listMorphs 193352 ^ self morphsOfClass: PluggableListMorph! ! 193353 193354!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'stephaneducasse 2/4/2006 20:47'! 193355morphsOfClass: aMorphClass 193356 | morphs | 193357 morphs := OrderedCollection new. 193358 morph allMorphsDo: [:m | (m isKindOf: aMorphClass) ifTrue: [morphs add: m]]. 193359 ^ morphs! ! 193360 193361!MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/28/2003 22:21'! 193362textMorph 193363 ^ (self morphsOfClass: TextMorph) last! ! 193364 193365 193366!MCSnapshotBrowserTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! 193367setUp 193368 model := MCSnapshotBrowser forSnapshot: MCSnapshotResource current snapshot. 193369 morph := model buildWindow.! ! 193370 193371 193372!MCSnapshotBrowserTest methodsFor: 'selecting' stamp: 'cwp 7/13/2003 13:04'! 193373selectMockClassA 193374 self clickOnListItem: self mockCategoryName. 193375 self clickOnListItem: 'MCMockClassA'. 193376 ! ! 193377 193378 193379!MCSnapshotBrowserTest methodsFor: 'simulating' stamp: 'cwp 7/13/2003 09:22'! 193380clickOnButton: aString 193381 (self findButtonWithLabel: aString) performAction.! ! 193382 193383!MCSnapshotBrowserTest methodsFor: 'simulating' stamp: 'stephaneducasse 2/4/2006 20:47'! 193384clickOnListItem: aString 193385 | listMorph | 193386 listMorph := self findListContaining: aString. 193387 listMorph changeModelSelection: (listMorph getList indexOf: aString).! ! 193388 193389 193390!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! 193391testAnnotationPane 193392 | oldPref | 193393 oldPref := Preferences annotationPanes. 193394 193395 Preferences disable: #annotationPanes. 193396 morph := model buildWindow. 193397 self assert: (self morphsOfClass: TextMorph) size = 1. 193398 193399 Preferences enable: #annotationPanes. 193400 morph := model buildWindow. 193401 self assert: (self morphsOfClass: TextMorph) size = 2. 193402 193403 Preferences setPreference: #annotationPanes toValue: oldPref! ! 193404 193405!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 09:31'! 193406testButtonMutex 193407 self assertButtonOn: 'instance'. 193408 self denyButtonOn: '?'. 193409 self denyButtonOn: 'class'. 193410 193411 self clickOnButton: '?'. 193412 self assertButtonOn: '?'. 193413 self denyButtonOn: 'instance'. 193414 self denyButtonOn: 'class'. 193415 193416 self clickOnButton: 'class'. 193417 self assertButtonOn: 'class'. 193418 self denyButtonOn: '?'. 193419 self denyButtonOn: 'instance'. 193420! ! 193421 193422!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 02:40'! 193423testCategorySelected 193424 self clickOnListItem: self mockCategoryName. 193425 193426 self assertAListMatches: self allCategories. 193427 self assertAListMatches: self definedClasses. 193428 self denyAListIncludesAnyOf: self allProtocols. 193429 self denyAListIncludesAnyOf: self allMethods. 193430 self assertTextIs: ''.! ! 193431 193432!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 13:04'! 193433testClassSelected 193434 self selectMockClassA. 193435 193436 self assertAListMatches: self allCategories. 193437 self assertAListMatches: self definedClasses. 193438 self assertAListMatches: self classAProtocols. 193439 self denyAListIncludesAnyOf: self allMethods. 193440 self assertTextIs: self classADefinitionString.! ! 193441 193442!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 13:06'! 193443testClassSideClassSelected 193444 self clickOnButton: 'class'. 193445 self selectMockClassA. 193446 193447 self assertAListMatches: self allCategories. 193448 self assertAListMatches: self definedClasses. 193449 self assertAListMatches: self classAClassProtocols. 193450 self denyAListIncludesAnyOf: self allMethods. 193451 self assertTextIs: self classADefinitionString.! ! 193452 193453!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 12:52'! 193454testComment 193455 self clickOnButton: '?'. 193456 self assertTextIs: ''. 193457 193458 self clickOnListItem: self mockCategoryName. 193459 self assertTextIs: ''. 193460 193461 self clickOnListItem: 'MCMockClassA'. 193462 self assertTextIs: self classAComment.! ! 193463 193464!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 02:30'! 193465testFourColumns 193466 self assert: self listMorphs size = 4.! ! 193467 193468!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 09:00'! 193469testMethodIsCleared 193470 self clickOnListItem: self mockCategoryName. 193471 self clickOnListItem: 'MCMockClassA'. 193472 self clickOnListItem: 'boolean'. 193473 self clickOnListItem: 'falsehood'. 193474 self clickOnListItem: '-- all --'. 193475 193476 self denyAListHasSelection: 'falsehood'.! ! 193477 193478!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 02:50'! 193479testMethodSelected 193480 self clickOnListItem: self mockCategoryName. 193481 self clickOnListItem: 'MCMockClassA'. 193482 self clickOnListItem: 'boolean'. 193483 self clickOnListItem: 'falsehood'. 193484 193485 self assertAListMatches: self allCategories. 193486 self assertAListMatches: self definedClasses. 193487 self assertAListMatches: self classAProtocols. 193488 self assertAListMatches: self classABooleanMethods. 193489 self assertTextIs: self falsehoodMethodSource.! ! 193490 193491!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'tfel 8/28/2009 20:43'! 193492testNoSelection 193493 self assertAListMatches: self allCategories. 193494 self denyAListIncludesAnyOf: self definedClasses. 193495 self denyAListIncludesAnyOf: self allProtocols. 193496 self denyAListIncludesAnyOf: self allMethods. 193497 "and if there I need to see the packages scripts (or none)" 193498 self assertTextIs: '(package defines no scripts)'.! ! 193499 193500!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 08:46'! 193501testProtocolIsCleared 193502 self clickOnListItem: self mockCategoryName. 193503 self clickOnListItem: 'MCMockASubclass'. 193504 self clickOnListItem: 'as yet unclassified'. 193505 self clickOnListItem: 'MCMockClassA'. 193506 193507 self denyAListHasSelection: 'as yet unclassified'.! ! 193508 193509!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 08:52'! 193510testProtocolSelected 193511 self clickOnListItem: self mockCategoryName. 193512 self clickOnListItem: 'MCMockClassA'. 193513 self clickOnListItem: 'boolean'. 193514 193515 self assertAListMatches: self allCategories. 193516 self assertAListMatches: self definedClasses. 193517 self assertAListMatches: self classAProtocols. 193518 self assertAListMatches: self classABooleanMethods. 193519 self assertTextIs: ''. ! ! 193520 193521!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 02:37'! 193522testTextPane 193523 self shouldnt: [self textMorph] raise: Exception.! ! 193524 193525!MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 09:14'! 193526testThreeButtons 193527 self assertButtonExists: 'instance'. 193528 self assertButtonExists: '?'. 193529 self assertButtonExists: 'class'.! ! 193530 193531 193532!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/14/2003 14:46'! 193533allCategories 193534 ^ Array with: model extensionsCategory with: self mockCategoryName.! ! 193535 193536!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/14/2003 14:58'! 193537allMethods 193538 ^ MCSnapshotResource current definitions 193539 select: [:def | def isMethodDefinition] 193540 thenCollect: [:def | def selector] ! ! 193541 193542!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/14/2003 14:58'! 193543allProtocols 193544 ^ MCSnapshotResource current definitions 193545 select: [:def | def isMethodDefinition] 193546 thenCollect: [:def | def category] ! ! 193547 193548!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/13/2003 02:23'! 193549classABooleanMethods 193550 ^ #(falsehood moreTruth truth)! ! 193551 193552!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 8/10/2003 02:10'! 193553classAClassProtocols 193554 ^ self protocolsForClass: self mockClassA class.! ! 193555 193556!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 8/10/2003 02:10'! 193557classAComment 193558 ^ self mockClassA organization classComment.! ! 193559 193560!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 8/10/2003 02:10'! 193561classADefinitionString 193562 ^ self mockClassA definition! ! 193563 193564!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 8/10/2003 02:10'! 193565classAProtocols 193566 ^ self protocolsForClass: self mockClassA.! ! 193567 193568!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/14/2003 14:59'! 193569definedClasses 193570 ^ MCSnapshotResource current definitions 193571 select: [:def | def isClassDefinition] 193572 thenCollect: [:def | def className].! ! 193573 193574!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/13/2003 02:53'! 193575falsehoodMethodSource 193576 ^ 'falsehood 193577 ^ false'! ! 193578 193579!MCSnapshotBrowserTest methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! 193580protocolsForClass: aClass 193581 | protocols | 193582 protocols := aClass organization categories. 193583 protocols size > 1 ifTrue: [protocols := protocols copyWith: '-- all --']. 193584 ^ protocols.! ! 193585MCReader subclass: #MCSnapshotReader 193586 instanceVariableNames: 'definitions' 193587 classVariableNames: '' 193588 poolDictionaries: '' 193589 category: 'Monticello-Storing'! 193590 193591!MCSnapshotReader methodsFor: 'as yet unclassified' stamp: 'avi 1/21/2004 23:09'! 193592definitions 193593 definitions ifNil: [self loadDefinitions]. 193594 ^ definitions! ! 193595 193596!MCSnapshotReader methodsFor: 'as yet unclassified' stamp: 'avi 1/21/2004 23:10'! 193597snapshot 193598 ^ MCSnapshot fromDefinitions: self definitions! ! 193599 193600"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 193601 193602MCSnapshotReader class 193603 instanceVariableNames: ''! 193604 193605!MCSnapshotReader class methodsFor: 'as yet unclassified' stamp: 'avi 1/21/2004 22:56'! 193606snapshotFromStream: aStream 193607 ^ (self on: aStream) snapshot! ! 193608TestResource subclass: #MCSnapshotResource 193609 instanceVariableNames: 'snapshot' 193610 classVariableNames: '' 193611 poolDictionaries: '' 193612 category: 'Tests-Monticello'! 193613 193614!MCSnapshotResource methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 14:50'! 193615definitions 193616 ^ snapshot definitions! ! 193617 193618!MCSnapshotResource methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 193619setUp 193620 snapshot := self class takeSnapshot.! ! 193621 193622!MCSnapshotResource methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 14:51'! 193623snapshot 193624 ^ snapshot! ! 193625 193626"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 193627 193628MCSnapshotResource class 193629 instanceVariableNames: ''! 193630 193631!MCSnapshotResource class methodsFor: 'as yet unclassified' stamp: 'cwp 8/1/2003 20:18'! 193632mockPackage 193633 ^ (MCPackage new name: self mockPackageName)! ! 193634 193635!MCSnapshotResource class methodsFor: 'as yet unclassified' stamp: 'avi 2/22/2004 13:54'! 193636mockPackageName 193637 ^ MCMockPackageInfo new packageName! ! 193638 193639!MCSnapshotResource class methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 15:19'! 193640takeSnapshot 193641 ^ self mockPackage snapshot! ! 193642MCTestCase subclass: #MCSnapshotTest 193643 instanceVariableNames: 'snapshot' 193644 classVariableNames: '' 193645 poolDictionaries: '' 193646 category: 'Tests-Monticello'! 193647 193648!MCSnapshotTest methodsFor: '*monticello-mocks' stamp: 'ab 7/7/2003 23:21'! 193649mockClassExtension! ! 193650 193651 193652!MCSnapshotTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! 193653setUp 193654 snapshot := self mockSnapshot.! ! 193655 193656 193657!MCSnapshotTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 193658testCreation 193659 |d| 193660 d := self mockSnapshot definitions. 193661 self assert: (d anySatisfy: [:ea | ea isClassDefinition and: [ea className = #MCMockClassA]]). 193662 self assert: (d anySatisfy: [:ea | ea isMethodDefinition and: [ea selector = #mockClassExtension]]). 193663 self assert: (d allSatisfy: [:ea | ea isClassDefinition not or: [ea category endsWith: 'Mocks']]). 193664 ! ! 193665 193666!MCSnapshotTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 193667testInstanceReuse 193668 | x m n y | 193669 x := (MCPackage new name: self mockCategoryName) snapshot. 193670 Smalltalk garbageCollect. 193671 n := MCDefinition allSubInstances size. 193672 y := (MCPackage new name: self mockCategoryName) snapshot. 193673 Smalltalk garbageCollect. 193674 m := MCDefinition allSubInstances size. 193675 self assert: m = n! ! 193676TestCase subclass: #MCSortingTest 193677 instanceVariableNames: '' 193678 classVariableNames: '' 193679 poolDictionaries: '' 193680 category: 'Tests-Monticello'! 193681 193682!MCSortingTest methodsFor: 'actions' stamp: 'ab 7/19/2003 18:01'! 193683sortDefinitions: aCollection 193684 ^ aCollection asSortedCollection asArray! ! 193685 193686 193687!MCSortingTest methodsFor: 'building' stamp: 'ab 4/8/2003 17:56'! 193688classNamed: aSymbol 193689 ^ MCClassDefinition 193690 name: aSymbol 193691 superclassName: #Object 193692 category: '' 193693 instVarNames: #() 193694 comment: ''! ! 193695 193696!MCSortingTest methodsFor: 'building' stamp: 'ab 4/8/2003 18:03'! 193697methodNamed: aSymbol class: className meta: aBoolean 193698 ^ MCMethodDefinition 193699 className: className 193700 classIsMeta: aBoolean 193701 selector: aSymbol 193702 category: '' 193703 timeStamp: '' 193704 source: ''! ! 193705 193706!MCSortingTest methodsFor: 'building' stamp: 'ab 7/19/2003 17:56'! 193707sortKeyFor: aDefinition 193708 ^ String streamContents: 193709 [:s | 193710 aDefinition description 193711 do: [:ea | s nextPutAll: ea asString] 193712 separatedBy: [s nextPut: $.]]! ! 193713 193714 193715!MCSortingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 193716testConsistentSorting 193717 | definitions shuffledAndSorted| 193718 definitions := 193719 {self methodNamed: #a class: #A meta: false. 193720 self methodNamed: #a class: #A meta: true. 193721 self methodNamed: #a class: #B meta: false. 193722 self methodNamed: #b class: #A meta: false. 193723 self methodNamed: #b class: #B meta: false. 193724 self classNamed: #A. 193725 self classNamed: #B}. 193726 shuffledAndSorted := 193727 (1 to: 100) collect: [:ea | self sortDefinitions: definitions shuffled]. 193728 self assert: shuffledAndSorted asSet size = 1. 193729! ! 193730 193731!MCSortingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 193732testSortOrder 193733 | aA aAm aB bA bB A B cA bAm cAm | 193734 aA := self methodNamed: #a class: #A meta: false. 193735 bA := self methodNamed: #b class: #A meta: false. 193736 cA := self methodNamed: #c class: #A meta: false. 193737 aAm := self methodNamed: #a class: #A meta: true. 193738 bAm := self methodNamed: #b class: #A meta: true. 193739 cAm := self methodNamed: #c class: #A meta: true. 193740 aB := self methodNamed: #a class: #B meta: false. 193741 bB := self methodNamed: #b class: #B meta: false. 193742 A := self classNamed: #A. 193743 B := self classNamed: #B. 193744 self assert: (self sortDefinitions: {aA. aAm. cAm. aB. bAm. bA. bB. A. cA. B}) 193745 = {A. aAm. bAm. cAm. aA. bA. cA. B. aB. bB}! ! 193746MCSnapshotReader subclass: #MCStReader 193747 instanceVariableNames: '' 193748 classVariableNames: '' 193749 poolDictionaries: '' 193750 category: 'Monticello-Chunk Format'! 193751 193752!MCStReader methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 193753addDefinitionsFromDoit: aString 193754 (MCDoItParser forDoit: aString) ifNotNil: 193755 [:parser | 193756 parser addDefinitionsTo: definitions]! ! 193757 193758!MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 193759categoryFromDoIt: aString 193760 | tokens | 193761 tokens := Scanner new scanTokens: aString. 193762 tokens size = 3 ifFalse: [self error: 'Unrecognized category definition']. 193763 ^ tokens at: 3! ! 193764 193765!MCStReader methodsFor: 'as yet unclassified' stamp: 'PeterHugossonMiller 9/2/2009 16:20'! 193766classDefinitionFrom: aPseudoClass 193767 | tokens traitCompositionString lastIndex classTraitCompositionString | 193768 tokens := Scanner new scanTokens: aPseudoClass definition. 193769 traitCompositionString := (aPseudoClass definition readStream 193770 match: 'uses:'; 193771 upToAll: 'instanceVariableNames:') withBlanksTrimmed. 193772 classTraitCompositionString := (aPseudoClass metaClass definition asString readStream 193773 match: 'uses:'; 193774 upToAll: 'instanceVariableNames:') withBlanksTrimmed. 193775 traitCompositionString isEmpty ifTrue: [traitCompositionString := '{}']. 193776 classTraitCompositionString isEmpty ifTrue: [classTraitCompositionString := '{}']. 193777 lastIndex := tokens size. 193778 ^ MCClassDefinition 193779 name: (tokens at: 3) 193780 superclassName: (tokens at: 1) 193781 traitComposition: traitCompositionString 193782 classTraitComposition: classTraitCompositionString 193783 category: (tokens at: lastIndex) 193784 instVarNames: ((tokens at: lastIndex - 6) findTokens: ' ') 193785 classVarNames: ((tokens at: lastIndex - 4) findTokens: ' ') 193786 poolDictionaryNames: ((tokens at: lastIndex - 2) findTokens: ' ') 193787 classInstVarNames: (self classInstVarNamesFor: aPseudoClass) 193788 type: (self typeOfSubclass: (tokens at: 2)) 193789 comment: (self commentFor: aPseudoClass) 193790 commentStamp: (self commentStampFor: aPseudoClass)! ! 193791 193792!MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 193793classInstVarNamesFor: aPseudoClass 193794 | tokens | 193795 193796 self flag: #traits. 193797 aPseudoClass metaClass hasDefinition ifFalse: [^ #()]. 193798 tokens := Scanner new scanTokens: aPseudoClass metaClass definition. 193799 "tokens size = 4 ifFalse: [self error: 'Unrecognized metaclass definition']." 193800 ^ tokens last findTokens: ' '! ! 193801 193802!MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 193803commentFor: aPseudoClass 193804 | comment | 193805 comment := aPseudoClass organization classComment. 193806 ^ comment asString = '' 193807 ifTrue: [comment] 193808 ifFalse: [comment string]! ! 193809 193810!MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 193811commentStampFor: aPseudoClass 193812 | comment | 193813 comment := aPseudoClass organization classComment. 193814 ^ [comment stamp] on: MessageNotUnderstood do: [nil]! ! 193815 193816!MCStReader methodsFor: 'as yet unclassified' stamp: 'avi 3/3/2004 15:23'! 193817methodDefinitionsFor: aPseudoClass 193818 ^ aPseudoClass selectors collect: 193819 [:ea | 193820 MCMethodDefinition 193821 className: aPseudoClass name 193822 classIsMeta: aPseudoClass isMeta 193823 selector: ea 193824 category: (aPseudoClass organization categoryOfElement: ea) 193825 timeStamp: (aPseudoClass stampAt: ea) 193826 source: (aPseudoClass sourceCodeAt: ea)]! ! 193827 193828!MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 193829systemOrganizationFromRecords: changeRecords 193830 | categories | 193831 categories := changeRecords 193832 select: [:ea | 'SystemOrganization*' match: ea string] 193833 thenCollect: [:ea | (self categoryFromDoIt: ea string)]. 193834 ^ categories isEmpty ifFalse: [MCOrganizationDefinition categories: categories asArray]! ! 193835 193836!MCStReader methodsFor: 'as yet unclassified' stamp: 'avi 1/19/2004 21:56'! 193837typeOfSubclass: aSymbol 193838 #( 193839 (subclass: normal) 193840 (variableSubclass: variable) 193841 (variableByteSubclass: bytes) 193842 (variableWordSubclass: words) 193843 (weakSubclass: weak) 193844 ) do: [:ea | ea first = aSymbol ifTrue: [^ ea second]]. 193845 self error: 'Unrecognized class definition'! ! 193846 193847 193848!MCStReader methodsFor: 'evaluating' stamp: 'stephaneducasse 2/4/2006 20:47'! 193849loadDefinitions 193850 | filePackage | 193851 filePackage := 193852 FilePackage new 193853 fullName: 'ReadStream'; 193854 fileInFrom: self readStream. 193855 definitions := OrderedCollection new. 193856 filePackage classes do: 193857 [:pseudoClass | 193858 pseudoClass hasDefinition 193859 ifTrue: [definitions add: 193860 (self classDefinitionFrom: pseudoClass)]. 193861 definitions addAll: (self methodDefinitionsFor: pseudoClass). 193862 definitions addAll: (self methodDefinitionsFor: pseudoClass metaClass)]. 193863 filePackage doIts do: 193864 [:ea | 193865 self addDefinitionsFromDoit: ea string]. 193866 ! ! 193867 193868!MCStReader methodsFor: 'evaluating' stamp: 'avi 1/21/2004 14:21'! 193869readStream 193870 ^ ('!!!! 193871 193872', stream contents) readStream! ! 193873 193874"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 193875 193876MCStReader class 193877 instanceVariableNames: ''! 193878 193879!MCStReader class methodsFor: 'as yet unclassified' stamp: 'avi 1/20/2004 00:17'! 193880extension 193881 ^ 'st'! ! 193882MCTestCase subclass: #MCStReaderTest 193883 instanceVariableNames: '' 193884 classVariableNames: '' 193885 poolDictionaries: '' 193886 category: 'Tests-Monticello'! 193887 193888!MCStReaderTest methodsFor: 'as yet unclassified' stamp: 'ab 8/17/2003 16:52'! 193889commentWithoutStyle 193890 ^ ' 193891CharacterScanner subclass: #CanvasCharacterScanner 193892 instanceVariableNames: ''canvas fillBlt foregroundColor runX lineY '' 193893 classVariableNames: '''' 193894 poolDictionaries: '''' 193895 category: ''Morphic-Support''!! 193896 193897!!CanvasCharacterScanner commentStamp: ''<historical>'' prior: 0!! 193898A displaying scanner which draws its output to a Morphic canvas.!! 193899 193900!!CanvasCharacterScanner methodsFor: ''stop conditions'' stamp: ''ar 12/15/2001 23:27''!! 193901setStopConditions 193902 "Set the font and the stop conditions for the current run." 193903 193904 self setFont. 193905 stopConditions 193906 at: Space asciiValue + 1 193907 put: (alignment = Justified ifTrue: [#paddedSpace])!! !!'! ! 193908 193909!MCStReaderTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/16/2003 23:35'! 193910commentWithStyle 193911 ^ '!!AEDesc commentStamp: ''<historical>'' prior: 0!! 193912I represent an Apple Event Descriptor. I am a low-level representation of Apple Event (and hence Applescript) information. For further Information, see Apple''s Inside Macintosh: Interapplication Communications, at 193913 193914 http://developer.apple.com/techpubs/mac/IAC/IAC-2.html. 193915 193916Essentially, I represent a record comprising a one-word "string" (treating the word as fourbyte characters) representing a data type, followed by a pointer to a pointer (a handle) to the data I represent. Care must be taken to assure that the Handle data is disposed after use, or memory leaks result. At this time, I make no effort to do this automatically through finalization.!! 193917]style[(218 54 384)f1,f1Rhttp://developer.apple.com/techpubs/mac/IAC/IAC-2.html;,f1!! 193918'! ! 193919 193920!MCStReaderTest methodsFor: 'as yet unclassified' stamp: 'sd 3/20/2008 22:31'! 193921methodWithStyle 193922 ^ '!!EventHandler methodsFor: ''copying'' stamp: ''tk 1/22/2001 17:39''!! 193923veryDeepInner: deepCopier 193924 "ALL fields are weakly copied. Can''t duplicate an object by duplicating a button that activates it. See DeepCopier." 193925 193926 super veryDeepInner: deepCopier. 193927 "just keep old pointers to all fields" 193928 clickRecipient := clickRecipient.!! 193929]style[(25 108 10 111)f1b,f1,f1LDeepCopier Comment;,f1!! !! 193930 193931'! ! 193932 193933!MCStReaderTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 193934testCommentWithoutStyle 193935 | reader | 193936 reader := MCStReader on: self commentWithoutStyle readStream. 193937 self assert: (reader definitions anySatisfy: [:ea | ea isMethodDefinition]).! ! 193938 193939!MCStReaderTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 193940testCommentWithStyle 193941 | reader | 193942 reader := MCStReader on: self commentWithStyle readStream. 193943 reader definitions! ! 193944 193945!MCStReaderTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 193946testMethodWithStyle 193947 | reader | 193948 reader := MCStReader on: self methodWithStyle readStream. 193949 self assert: reader definitions first isMethodDefinition.! ! 193950MCWriter subclass: #MCStWriter 193951 instanceVariableNames: 'initStream' 193952 classVariableNames: '' 193953 poolDictionaries: '' 193954 category: 'Monticello-Chunk Format'! 193955 193956!MCStWriter methodsFor: 'visiting' stamp: 'cwp 8/2/2003 11:02'! 193957visitClassDefinition: definition 193958 self writeClassDefinition: definition. 193959 definition hasClassInstanceVariables ifTrue: [self writeMetaclassDefinition: definition]. 193960 definition hasComment ifTrue: [self writeClassComment: definition].! ! 193961 193962!MCStWriter methodsFor: 'visiting' stamp: 'al 10/9/2005 19:52'! 193963visitClassTraitDefinition: definition 193964 self chunkContents: [:s | s 193965 nextPutAll: definition baseTrait; 193966 nextPutAll: ' classTrait'; 193967 cr; tab; 193968 nextPutAll: 'uses: '; 193969 nextPutAll: (definition classTraitComposition ifNil: ['{}'])] 193970! ! 193971 193972!MCStWriter methodsFor: 'visiting' stamp: 'al 10/9/2005 19:40'! 193973visitMetaclassDefinition: definition 193974 self writeMetaclassDefinition: definition! ! 193975 193976!MCStWriter methodsFor: 'visiting' stamp: 'avi 2/17/2004 02:23'! 193977visitMethodDefinition: definition 193978 self writeMethodPreamble: definition. 193979 self writeMethodSource: definition. 193980 self writeMethodPostscript. 193981 self writeMethodInitializer: definition.! ! 193982 193983!MCStWriter methodsFor: 'visiting' stamp: 'cwp 8/2/2003 11:02'! 193984visitOrganizationDefinition: defintion 193985 defintion categories do: [:cat | self writeCategory: cat]. 193986! ! 193987 193988!MCStWriter methodsFor: 'visiting' stamp: 'bf 8/12/2009 21:41'! 193989visitScriptDefinition: definition 193990 self writeScriptDefinition: definition 193991! ! 193992 193993!MCStWriter methodsFor: 'visiting' stamp: 'al 10/9/2005 19:40'! 193994visitTraitDefinition: definition 193995 self writeClassDefinition: definition. 193996 definition hasComment ifTrue: [self writeClassComment: definition].! ! 193997 193998 193999!MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 02:34'! 194000chunkContents: aBlock 194001 stream cr; nextChunkPut: (String streamContents: aBlock); cr! ! 194002 194003!MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 01:46'! 194004writeCategory: categoryName 194005 stream 194006 nextChunkPut: 'SystemOrganization addCategory: ', categoryName printString; 194007 cr! ! 194008 194009!MCStWriter methodsFor: 'writing' stamp: 'ab 8/17/2003 17:09'! 194010writeClassComment: definition 194011 stream 194012 cr; 194013 nextPut: $!!; 194014 nextPutAll: definition className; 194015 nextPutAll: ' commentStamp: '; 194016 store: definition commentStamp; 194017 nextPutAll: ' prior: 0!!'; 194018 cr; 194019 nextChunkPut: definition comment; 194020 cr.! ! 194021 194022!MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 02:16'! 194023writeClassDefinition: definition 194024 self chunkContents: [:s | definition printDefinitionOn: stream]! ! 194025 194026!MCStWriter methodsFor: 'writing' stamp: 'dvf 9/8/2004 10:28'! 194027writeDefinitions: aCollection 194028 "initStream is an ugly hack until we have proper init defs" 194029 initStream := String new writeStream. 194030 194031 (MCDependencySorter sortItems: aCollection) 194032 do: [:ea | ea accept: self] 194033 displayingProgress: 'Writing definitions...'. 194034 194035 stream nextPutAll: initStream contents.! ! 194036 194037!MCStWriter methodsFor: 'writing' stamp: 'al 12/2/2005 15:17'! 194038writeMetaclassDefinition: definition 194039 self chunkContents: [:str | 194040 str nextPutAll: definition className; 194041 nextPutAll: ' class'; 194042 cr; tab. 194043 definition hasClassTraitComposition ifTrue: [ 194044 str nextPutAll: 'uses: '; 194045 nextPutAll: definition classTraitCompositionString; 194046 cr; tab]. 194047 str nextPutAll: 'instanceVariableNames: '''; 194048 nextPutAll: definition classInstanceVariablesString; 194049 nextPut: $']! ! 194050 194051!MCStWriter methodsFor: 'writing' stamp: 'avi 2/17/2004 02:24'! 194052writeMethodInitializer: aMethodDefinition 194053 aMethodDefinition isInitializer ifTrue: 194054 [initStream nextChunkPut: aMethodDefinition className, ' initialize'; cr]! ! 194055 194056!MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 12:43'! 194057writeMethodPostscript 194058 stream 194059 space; 194060 nextPut: $!!; 194061 cr! ! 194062 194063!MCStWriter methodsFor: 'writing' stamp: 'avi 9/23/2003 17:42'! 194064writeMethodPreamble: definition 194065 stream 194066 cr; 194067 nextPut: $!!; 194068 nextPutAll: definition fullClassName; 194069 nextPutAll: ' methodsFor: '; 194070 nextPutAll: definition category asString printString; 194071 nextPutAll: ' stamp: '; 194072 nextPutAll: definition timeStamp asString printString; 194073 nextPutAll: '!!'; 194074 cr! ! 194075 194076!MCStWriter methodsFor: 'writing' stamp: 'cwp 8/4/2003 01:35'! 194077writeMethodSource: definition 194078 stream nextChunkPut: definition source! ! 194079 194080!MCStWriter methodsFor: 'writing' stamp: 'bf 8/13/2009 00:21'! 194081writeScriptDefinition: definition 194082 stream nextChunkPut: ( 194083 '(PackageInfo named: {1}) {2}: {3}' 194084 format: { 194085 "{1}" definition packageName printString. 194086 "{2}" definition scriptSelector. 194087 "{3}" definition script printString 194088 }); cr! ! 194089 194090!MCStWriter methodsFor: 'writing' stamp: 'avi 2/17/2004 02:25'! 194091writeSnapshot: aSnapshot 194092 self writeDefinitions: aSnapshot definitions! ! 194093 194094"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 194095 194096MCStWriter class 194097 instanceVariableNames: ''! 194098 194099!MCStWriter class methodsFor: 'as yet unclassified' stamp: 'avi 1/20/2004 00:16'! 194100readerClass 194101 ^ MCStReader! ! 194102MCTestCase subclass: #MCStWriterTest 194103 instanceVariableNames: 'stream writer' 194104 classVariableNames: '' 194105 poolDictionaries: '' 194106 category: 'Tests-Monticello'! 194107 194108!MCStWriterTest methodsFor: 'asserting' stamp: 'cwp 8/2/2003 12:13'! 194109assertAllChunksAreWellFormed 194110 stream reset. 194111 stream 194112 untilEnd: [self assertChunkIsWellFormed: stream nextChunk] 194113 displayingProgress: 'Checking syntax...'! ! 194114 194115!MCStWriterTest methodsFor: 'asserting' stamp: 'al 7/21/2006 22:14'! 194116assertChunkIsWellFormed: chunk 194117 self class parserClass new 194118 parse: chunk readStream 194119 class: UndefinedObject 194120 noPattern: true 194121 context: nil 194122 notifying: nil 194123 ifFail: [self assert: false]! ! 194124 194125!MCStWriterTest methodsFor: 'asserting' stamp: 'nk 2/22/2005 21:17'! 194126assertContentsOf: strm match: expected 194127 | actual | 194128 actual := strm contents. 194129 self assert: actual size = expected size. 194130 actual with: expected do: [:a :e | self assert: a = e]! ! 194131 194132!MCStWriterTest methodsFor: 'asserting' stamp: 'al 7/21/2006 22:14'! 194133assertMethodChunkIsWellFormed: chunk 194134 self class parserClass new 194135 parse: chunk readStream 194136 class: UndefinedObject 194137 noPattern: false 194138 context: nil 194139 notifying: nil 194140 ifFail: [self assert: false]! ! 194141 194142 194143!MCStWriterTest methodsFor: 'data' stamp: 'cwp 2/3/2004 21:39'! 194144expectedClassDefinitionA 194145 ^ ' 194146MCMock subclass: #MCMockClassA 194147 instanceVariableNames: ''ivar'' 194148 classVariableNames: ''CVar'' 194149 poolDictionaries: '''' 194150 category: ''Monticello-Mocks''!! 194151 194152!!MCMockClassA commentStamp: ''cwp 8/10/2003 16:43'' prior: 0!! 194153This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.!! 194154'! ! 194155 194156!MCStWriterTest methodsFor: 'data' stamp: 'avi 2/17/2004 03:23'! 194157expectedClassDefinitionB 194158 ^ ' 194159MCMock subclass: #MCMockClassB 194160 instanceVariableNames: ''ivarb'' 194161 classVariableNames: ''CVar'' 194162 poolDictionaries: ''MCMockAPoolDictionary'' 194163 category: ''Monticello-Mocks''!! 194164 194165MCMockClassB class 194166 instanceVariableNames: ''ciVar''!! 194167 194168!!MCMockClassB commentStamp: '''' prior: 0!! 194169This comment has a bang!!!! Bang!!!! Bang!!!!!! 194170'! ! 194171 194172!MCStWriterTest methodsFor: 'data' stamp: 'cwp 8/2/2003 14:43'! 194173expectedClassMethodDefinition 194174 ^ ' 194175!!MCMockClassA class methodsFor: ''as yet unclassified'' stamp: ''ab 7/7/2003 23:21''!! 194176one 194177 194178 ^ 1!! !! 194179'! ! 194180 194181!MCStWriterTest methodsFor: 'data' stamp: 'cwp 8/2/2003 17:27'! 194182expectedMethodDefinition 194183 ^ ' 194184!!MCMockClassA methodsFor: ''numeric'' stamp: ''cwp 8/2/2003 17:26''!! 194185one 194186 ^ 1!! !! 194187'! ! 194188 194189!MCStWriterTest methodsFor: 'data' stamp: 'cwp 8/9/2003 14:58'! 194190expectedMethodDefinitionWithBangs 194191 ^ ' 194192!!MCStWriterTest methodsFor: ''testing'' stamp: ''cwp 8/9/2003 14:55''!! 194193methodWithBangs 194194 ^ '' 194195 ^ ReadStream on: 194196''''MCRevisionInfo packageName: ''''MonticelloCompatibilityTest''''!!!!!!!! 194197MCOrganizationDeclaration categories: 194198 #( 194199 ''''Monticello-Mocks'''')!!!!!!!! 194200 194201MCClassDeclaration 194202 name: #MCMockClassD 194203 superclassName: #Object 194204 category: #''''Monticello-Mocks'''' 194205 instVarNames: #() 194206 comment: ''''''''!!!!!!!! 194207 194208MCMethodDeclaration className: #MCMockClassD selector: #one category: #''''as yet unclassified'''' timeStamp: ''''cwp 7/8/2003 21:21'''' source: 194209''''one 194210 ^ 1''''!!!!!!!! 194211'''' 194212'' 194213!! !! 194214'! ! 194215 194216!MCStWriterTest methodsFor: 'data' stamp: 'cwp 8/2/2003 12:14'! 194217expectedOrganizationDefinition 194218 ^ 'SystemOrganization addCategory: ''Monticello-Mocks''!! 194219'! ! 194220 194221 194222!MCStWriterTest methodsFor: 'testing' stamp: 'ab 8/8/2003 17:01'! 194223expectedInitializerA 194224 ^ 'MCMockClassA initialize'! ! 194225 194226!MCStWriterTest methodsFor: 'testing' stamp: 'cwp 8/9/2003 14:55'! 194227methodWithBangs 194228 ^ ' 194229 ^ ReadStream on: 194230''MCRevisionInfo packageName: ''MonticelloCompatibilityTest''!!!! 194231MCOrganizationDeclaration categories: 194232 #( 194233 ''Monticello-Mocks'')!!!! 194234 194235MCClassDeclaration 194236 name: #MCMockClassD 194237 superclassName: #Object 194238 category: #''Monticello-Mocks'' 194239 instVarNames: #() 194240 comment: ''''!!!! 194241 194242MCMethodDeclaration className: #MCMockClassD selector: #one category: #''as yet unclassified'' timeStamp: ''cwp 7/8/2003 21:21'' source: 194243''one 194244 ^ 1''!!!! 194245'' 194246' 194247! ! 194248 194249!MCStWriterTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! 194250setUp 194251 stream := RWBinaryOrTextStream on: String new. 194252 writer := MCStWriter on: stream. 194253! ! 194254 194255!MCStWriterTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 02:11'! 194256testClassDefinitionA 194257 writer visitClassDefinition: (self mockClassA asClassDefinition). 194258 self assertContentsOf: stream match: self expectedClassDefinitionA. 194259 stream reset. 194260 2 timesRepeat: [self assertChunkIsWellFormed: stream nextChunk]! ! 194261 194262!MCStWriterTest methodsFor: 'testing' stamp: 'cwp 9/14/2003 19:39'! 194263testClassDefinitionB 194264 writer visitClassDefinition: (self mockClassB asClassDefinition). 194265 self assertContentsOf: stream match: self expectedClassDefinitionB. 194266 ! ! 194267 194268!MCStWriterTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 02:11'! 194269testClassMethodDefinition 194270 writer visitMethodDefinition: (MethodReference class: self mockClassA class selector: #one) asMethodDefinition. 194271 self assertContentsOf: stream match: self expectedClassMethodDefinition. 194272 stream reset. 194273 self assert: stream nextChunk isAllSeparators. 194274 self assertChunkIsWellFormed: stream nextChunk. 194275 self assertMethodChunkIsWellFormed: stream nextChunk. 194276 self assert: stream nextChunk isAllSeparators ! ! 194277 194278!MCStWriterTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! 194279testInitializerDefinition 194280 |chunk lastChunk| 194281 writer writeSnapshot: self mockSnapshot. 194282 stream reset. 194283 [stream atEnd] whileFalse: 194284 [chunk := stream nextChunk. 194285 chunk isAllSeparators ifFalse: [lastChunk := chunk]]. 194286 self assertContentsOf: lastChunk readStream match: self expectedInitializerA! ! 194287 194288!MCStWriterTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 02:11'! 194289testMethodDefinition 194290 writer visitMethodDefinition: (MethodReference class: self mockClassA selector: #one) asMethodDefinition. 194291 self assertContentsOf: stream match: self expectedMethodDefinition. 194292 stream reset. 194293 self assert: stream nextChunk isAllSeparators. 194294 self assertChunkIsWellFormed: stream nextChunk. 194295 self assertMethodChunkIsWellFormed: stream nextChunk. 194296 self assert: stream nextChunk isAllSeparators ! ! 194297 194298!MCStWriterTest methodsFor: 'testing' stamp: 'cwp 8/9/2003 14:52'! 194299testMethodDefinitionWithBangs 194300 writer visitMethodDefinition: (MethodReference 194301 class: self class 194302 selector: #methodWithBangs) asMethodDefinition. 194303 self assertContentsOf: stream match: self expectedMethodDefinitionWithBangs. 194304 stream reset. 194305 self assert: stream nextChunk isAllSeparators. 194306 self assertChunkIsWellFormed: stream nextChunk. 194307 self assertMethodChunkIsWellFormed: stream nextChunk. 194308 self assert: stream nextChunk isAllSeparators ! ! 194309 194310!MCStWriterTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! 194311testOrganizationDefinition 194312 | definition | 194313 definition := MCOrganizationDefinition categories: 194314 (self mockPackage packageInfo systemCategories). 194315 writer visitOrganizationDefinition: definition. 194316 self assertContentsOf: stream match: self expectedOrganizationDefinition. 194317 self assertAllChunksAreWellFormed.! ! 194318MCDirectoryRepository subclass: #MCSubDirectoryRepository 194319 instanceVariableNames: '' 194320 classVariableNames: '' 194321 poolDictionaries: '' 194322 category: 'Monticello-Repositories'! 194323!MCSubDirectoryRepository commentStamp: 'nk 6/11/2004 18:56' prior: 0! 194324A MCDirectoryRepository that looks in subdirectories too.! 194325 194326 194327!MCSubDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 194328findFullNameForReading: aBaseName 194329 "Answer the latest version of aBaseName" 194330 | possible | 194331 possible := SortedCollection sortBlock: [ :a :b | b first modificationTime < a first modificationTime ]. 194332 self allDirectories 194333 do: [:dir | dir entries 194334 do: [:ent | ent isDirectory 194335 ifFalse: [ 194336 (ent name = aBaseName) ifTrue: [ possible add: {ent. dir fullNameFor: ent name}]]]]. 194337 ^(possible at: 1 ifAbsent: [ ^nil ]) second 194338! ! 194339 194340!MCSubDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 194341findFullNameForWriting: aBaseName 194342 | possible split dirScore fileScore prefix fpattern parts now | 194343 split := directory splitNameVersionExtensionFor: aBaseName. 194344 fpattern := split first, '*'. 194345 possible := SortedCollection sortBlock: [ :a :b | 194346 a first = b first 194347 ifTrue: [ a second = b second 194348 ifFalse: [ a second < b second ] 194349 ifTrue: [ a third fullName size < b third fullName size ]] 194350 ifFalse: [ a first > b first ] ]. 194351 now := Time totalSeconds. 194352 prefix := directory pathParts size. 194353 self allDirectories do: [:dir | 194354 parts := dir pathParts allButFirst: prefix. 194355 dirScore := (parts select: [ :part | fpattern match: part ]) size. 194356 fileScore := (dir entries collect: [ :ent | 194357 (ent isDirectory not and: [ fpattern match: ent name ]) 194358 ifFalse: [ SmallInteger maxVal ] 194359 ifTrue: [ now - ent modificationTime ]]). "minimum age" 194360 fileScore := fileScore isEmpty ifTrue: [ SmallInteger maxVal ] 194361 ifFalse: [ fileScore min ]. 194362 possible add: { dirScore. fileScore. dir } ]. 194363 ^ (possible first third) fullNameFor: aBaseName! ! 194364 194365!MCSubDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 194366readStreamForFileNamed: aString do: aBlock 194367 | file val | 194368 file := FileStream readOnlyFileNamed: (self findFullNameForReading: aString). 194369 val := aBlock value: file. 194370 file close. 194371 ^ val! ! 194372 194373!MCSubDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'nk 6/11/2004 20:34'! 194374writeStreamForFileNamed: aString replace: aBoolean do: aBlock 194375 | file | 194376 file := aBoolean 194377 ifTrue: [FileStream 194378 forceNewFileNamed: (self findFullNameForReading: aString)] 194379 ifFalse: [FileStream 194380 newFileNamed: (self findFullNameForWriting: aString)]. 194381 aBlock value: file. 194382 file close! ! 194383 194384 194385!MCSubDirectoryRepository methodsFor: 'enumeration' stamp: 'nk 6/11/2004 18:55'! 194386allDirectories 194387 | remaining dir dirs | 194388 remaining := OrderedCollection new. 194389 dirs := OrderedCollection new. 194390 remaining addLast: directory. 194391 [remaining isEmpty] 194392 whileFalse: [dir := remaining removeFirst. 194393 dirs add: dir. 194394 dir entries 194395 do: [:ent | ent isDirectory 194396 ifTrue: [remaining 194397 addLast: (dir directoryNamed: ent name)]]]. 194398 ^ dirs! ! 194399 194400!MCSubDirectoryRepository methodsFor: 'enumeration' stamp: 'nk 6/11/2004 20:25'! 194401allFileNames 194402 "sorting {entry. dirName. name}" 194403 194404 | sorted | 194405 sorted := SortedCollection sortBlock: [:a :b | 194406 a first modificationTime >= b first modificationTime ]. 194407 self allDirectories 194408 do: [:dir | dir entries 194409 do: [:ent | ent isDirectory 194410 ifFalse: [sorted add: {ent. dir fullName. ent name}]]]. 194411 ^ sorted 194412 collect: [:ea | ea third ]! ! 194413 194414 194415!MCSubDirectoryRepository methodsFor: 'user interface' stamp: 'nk 6/11/2004 18:23'! 194416description 194417 ^ directory pathName, '/*'! ! 194418 194419"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 194420 194421MCSubDirectoryRepository class 194422 instanceVariableNames: ''! 194423 194424!MCSubDirectoryRepository class methodsFor: 'user interface' stamp: 'nk 6/11/2004 18:48'! 194425description 194426 ^ 'directory with subdirectories'! ! 194427MCDoItParser subclass: #MCSystemCategoryParser 194428 instanceVariableNames: '' 194429 classVariableNames: '' 194430 poolDictionaries: '' 194431 category: 'Monticello-Chunk Format'! 194432 194433!MCSystemCategoryParser methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 194434addDefinitionsTo: aCollection 194435 | definition | 194436 definition := aCollection detect: [:ea | ea isOrganizationDefinition ] ifNone: [aCollection add: (MCOrganizationDefinition categories: #())]. 194437 definition categories: (definition categories copyWith: self category).! ! 194438 194439!MCSystemCategoryParser methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 194440category 194441 | tokens | 194442 tokens := Scanner new scanTokens: source. 194443 tokens size = 3 ifFalse: [self error: 'Unrecognized category definition']. 194444 ^ tokens at: 3! ! 194445 194446"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 194447 194448MCSystemCategoryParser class 194449 instanceVariableNames: ''! 194450 194451!MCSystemCategoryParser class methodsFor: 'as yet unclassified' stamp: 'avi 3/10/2004 12:41'! 194452pattern 194453 ^ 'SystemOrganization*'! ! 194454TestCase subclass: #MCTestCase 194455 instanceVariableNames: '' 194456 classVariableNames: '' 194457 poolDictionaries: '' 194458 category: 'Tests-Monticello'! 194459 194460!MCTestCase methodsFor: 'asserting' stamp: 'cwp 8/8/2003 14:58'! 194461assertPackage: actual matches: expected 194462 self assert: actual = expected 194463! ! 194464 194465!MCTestCase methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 194466assertSnapshot: actual matches: expected 194467 | diff | 194468 diff := actual patchRelativeToBase: expected. 194469 self assert: diff isEmpty 194470! ! 194471 194472!MCTestCase methodsFor: 'asserting' stamp: 'cwp 8/8/2003 15:50'! 194473assertVersionInfo: actual matches: expected 194474 self assert: actual name = expected name. 194475 self assert: actual message = expected message. 194476 self assert: actual ancestors size = expected ancestors size. 194477 actual ancestors with: expected ancestors do: [:a :e | self assertVersionInfo: a matches: e] 194478 ! ! 194479 194480!MCTestCase methodsFor: 'asserting' stamp: 'cwp 8/8/2003 14:58'! 194481assertVersion: actual matches: expected 194482 self assertPackage: actual package matches: expected package. 194483 self assertVersionInfo: actual info matches: expected info. 194484 self assertSnapshot: actual snapshot matches: expected snapshot.! ! 194485 194486 194487!MCTestCase methodsFor: 'compiling' stamp: 'cwp 8/10/2003 02:12'! 194488change: aSelector toReturn: anObject 194489 self 194490 compileClass: self mockClassA 194491 source: aSelector, ' ^ ', anObject printString 194492 category: 'numeric'! ! 194493 194494!MCTestCase methodsFor: 'compiling' stamp: 'abc 2/16/2006 09:24'! 194495compileClass: aClass source: source category: category 194496 aClass compileSilently: source classified: category! ! 194497 194498!MCTestCase methodsFor: 'compiling' stamp: 'cwp 8/2/2003 15:05'! 194499restoreMocks 194500 self mockSnapshot updatePackage: self mockPackage! ! 194501 194502 194503!MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 16:51'! 194504commentForClass: name 194505 ^ 'This is a comment for ', name! ! 194506 194507!MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 16:53'! 194508commentStampForClass: name 194509 ^ 'tester-', name, ' 1/1/2000 00:00'! ! 194510 194511!MCTestCase methodsFor: 'mocks' stamp: 'ab 7/19/2003 15:43'! 194512mockCategoryName 194513 ^ 'Monticello-Mocks'! ! 194514 194515!MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 02:05'! 194516mockClassA 194517 ^ Smalltalk at: #MCMockClassA! ! 194518 194519!MCTestCase methodsFor: 'mocks' stamp: 'cwp 9/14/2003 19:39'! 194520mockClassB 194521 ^ Smalltalk at: #MCMockClassB! ! 194522 194523!MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 16:50'! 194524mockClass: className super: superclassName 194525 ^ MCClassDefinition 194526 name: className 194527 superclassName: superclassName 194528 category: self mockCategoryName 194529 instVarNames: #() 194530 classVarNames: #() 194531 poolDictionaryNames: #() 194532 classInstVarNames: #() 194533 type: #normal 194534 comment: (self commentForClass: className) 194535 commentStamp: (self commentStampForClass: className)! ! 194536 194537!MCTestCase methodsFor: 'mocks' stamp: 'avi 1/19/2004 15:54'! 194538mockDependencies 194539 ^ Array with: (MCVersionDependency package: self mockEmptyPackage info: (self mockVersionInfo: 'x'))! ! 194540 194541!MCTestCase methodsFor: 'mocks' stamp: 'avi 2/22/2004 14:08'! 194542mockEmptyPackage 194543 ^ MCPackage named: (MCEmptyPackageInfo new packageName)! ! 194544 194545!MCTestCase methodsFor: 'mocks' stamp: 'avi 2/22/2004 13:56'! 194546mockExtensionMethodCategory 194547 ^ MCMockPackageInfo new methodCategoryPrefix.! ! 194548 194549!MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 02:06'! 194550mockInstanceA 194551 ^ self mockClassA new! ! 194552 194553!MCTestCase methodsFor: 'mocks' stamp: 'cwp 7/30/2003 19:24'! 194554mockMessageString 194555 ^ 'A version generated for testing purposes.'! ! 194556 194557!MCTestCase methodsFor: 'mocks' stamp: 'ab 4/1/2003 02:02'! 194558mockMethod: aSymbol class: className source: sourceString meta: aBoolean 194559 ^ MCMethodDefinition 194560 className: className 194561 classIsMeta: aBoolean 194562 selector: aSymbol 194563 category: 'as yet unclassified' 194564 timeStamp: '' 194565 source: sourceString! ! 194566 194567!MCTestCase methodsFor: 'mocks' stamp: 'cwp 11/13/2003 13:24'! 194568mockOverrideMethodCategory 194569 ^ self mockExtensionMethodCategory, '-override'! ! 194570 194571!MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/1/2003 20:27'! 194572mockPackage 194573 ^ MCSnapshotResource mockPackage! ! 194574 194575!MCTestCase methodsFor: 'mocks' stamp: 'cwp 7/14/2003 15:07'! 194576mockSnapshot 194577 ^ MCSnapshotResource current snapshot! ! 194578 194579!MCTestCase methodsFor: 'mocks' stamp: 'ab 1/15/2003 17:55'! 194580mockToken: aSymbol 194581 ^ MCMockDefinition token: aSymbol! ! 194582 194583!MCTestCase methodsFor: 'mocks' stamp: 'cwp 7/30/2003 19:23'! 194584mockVersion 194585 ^ MCVersion 194586 package: self mockPackage 194587 info: self mockVersionInfo 194588 snapshot: self mockSnapshot! ! 194589 194590!MCTestCase methodsFor: 'mocks' stamp: 'avi 2/12/2004 19:58'! 194591mockVersionInfo 194592 ^ self treeFrom: #(d ((b ((a))) (c)))! ! 194593 194594!MCTestCase methodsFor: 'mocks' stamp: 'MiguelCoba 7/25/2009 02:01'! 194595mockVersionInfoWithAncestor: aVersionInfo 194596 ^ MCVersionInfo 194597 name: aVersionInfo name, '-child' 194598 id: UUID new 194599 message: self mockMessageString 194600 date: Date today 194601 time: Time now 194602 author: Author fullName 194603 ancestors: {aVersionInfo} 194604! ! 194605 194606!MCTestCase methodsFor: 'mocks' stamp: 'MiguelCoba 7/25/2009 02:01'! 194607mockVersionInfo: tag 194608 ^ MCVersionInfo 194609 name: self mockVersionName, '-', tag asString 194610 id: UUID new 194611 message: self mockMessageString, '-', tag asString 194612 date: Date today 194613 time: Time now 194614 author: Author fullName 194615 ancestors: #() 194616! ! 194617 194618!MCTestCase methodsFor: 'mocks' stamp: 'cwp 7/30/2003 19:25'! 194619mockVersionName 194620 ^ 'MonticelloTest-xxx.1'! ! 194621 194622!MCTestCase methodsFor: 'mocks' stamp: 'cwp 11/6/2004 16:03'! 194623mockVersionWithAncestor: aMCVersion 194624 ^ MCVersion 194625 package: self mockPackage 194626 info: (self mockVersionInfoWithAncestor: aMCVersion info) 194627 snapshot: self mockSnapshot! ! 194628 194629!MCTestCase methodsFor: 'mocks' stamp: 'avi 1/19/2004 15:15'! 194630mockVersionWithDependencies 194631 ^ MCVersion 194632 package: self mockPackage 194633 info: self mockVersionInfo 194634 snapshot: self mockSnapshot 194635 dependencies: self mockDependencies! ! 194636 194637!MCTestCase methodsFor: 'mocks' stamp: 'stephaneducasse 2/4/2006 20:47'! 194638treeFrom: anArray 194639 | name id | 194640 name := anArray first. 194641 id := '00000000-0000-0000-0000-0000000000', (name asString size = 1 ifTrue: [name asString, '0'] ifFalse: [name asString]). 194642 ^ MCVersionInfo 194643 name: name 194644 id: (UUID fromString: id) 194645 message: '' 194646 date: nil 194647 time: nil 194648 author: '' 194649 ancestors: (anArray size > 1 ifTrue: [(anArray second collect: [:ea | self treeFrom: ea])] ifFalse: [#()])! ! 194650 194651"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 194652 194653MCTestCase class 194654 instanceVariableNames: ''! 194655 194656!MCTestCase class methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 15:12'! 194657isAbstract 194658 ^ self = MCTestCase! ! 194659 194660!MCTestCase class methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 15:05'! 194661resources 194662 ^ Array with: MCSnapshotResource! ! 194663MCMerger subclass: #MCThreeWayMerger 194664 instanceVariableNames: 'index operations provisions redundantAdds' 194665 classVariableNames: '' 194666 poolDictionaries: '' 194667 category: 'Monticello-Merging'! 194668 194669!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 10/6/2004 15:18'! 194670addBaseSnapshot: aSnapshot 194671 aSnapshot definitions do: 194672 [:ea | 194673 index add: ea. 194674 provisions addAll: ea provisions]! ! 194675 194676!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 194677addDefinition: aDefinition 194678 index 194679 definitionLike: aDefinition 194680 ifPresent: [:other | 194681 (self removalForDefinition: aDefinition) 194682 ifNotNil: 194683 [:op | 194684 self addOperation: (MCModification of: other to: aDefinition). 194685 self removeOperation: op. 194686 ^ self]. 194687 other = aDefinition 194688 ifFalse: [self addConflictWithOperation: (MCModification of: other to: aDefinition)] 194689 ifTrue: [self redundantAdds add: aDefinition]] 194690 ifAbsent: [self addOperation: (MCAddition of: aDefinition)]! ! 194691 194692!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:30'! 194693addOperation: anOperation 194694 self operations add: anOperation! ! 194695 194696!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:52'! 194697applyPatch: aPatch 194698 aPatch applyTo: self! ! 194699 194700!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:32'! 194701applyTo: anObject 194702 super applyTo: anObject. 194703 self operations do: [:ea | ea applyTo: anObject]! ! 194704 194705!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:49'! 194706baseSnapshot 194707 ^ (MCSnapshot fromDefinitions: index definitions)! ! 194708 194709!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:04'! 194710initialize 194711 super initialize. 194712 index := MCDefinitionIndex new. 194713 provisions := Set new! ! 194714 194715!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 9/19/2005 02:22'! 194716modificationConflictForDefinition: aDefinition 194717 ^ conflicts ifNotNil: 194718 [conflicts detect: 194719 [:ea | (ea definition isRevisionOf: aDefinition) and: 194720 [ea operation isModification]] ifNone: []]! ! 194721 194722!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:34'! 194723modifyDefinition: baseDefinition to: targetDefinition 194724 index 194725 definitionLike: baseDefinition 194726 ifPresent: [:other | other = baseDefinition 194727 ifTrue: [self addOperation: (MCModification of: baseDefinition to: targetDefinition)] 194728 ifFalse: [other = targetDefinition 194729 ifFalse: [self addConflictWithOperation: 194730 (MCModification of: other to: targetDefinition)]]] 194731 ifAbsent: [self addConflictWithOperation: (MCAddition of: targetDefinition)]! ! 194732 194733!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 194734operations 194735 ^ operations ifNil: [operations := OrderedCollection new]! ! 194736 194737!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 10/6/2004 15:19'! 194738provisions 194739 ^ provisions! ! 194740 194741!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 194742redundantAdds 194743 ^ redundantAdds ifNil: [redundantAdds := Set new]! ! 194744 194745!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 9/19/2005 02:40'! 194746removalForDefinition: aDefinition 194747 ^ operations ifNotNil: 194748 [operations 194749 detect: [:ea | (ea definition isRevisionOf: aDefinition) and: [ea isRemoval]] 194750 ifNone: []]! ! 194751 194752!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 9/19/2005 02:40'! 194753removeConflict: aConflict 194754 conflicts remove: aConflict! ! 194755 194756!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 194757removeDefinition: aDefinition 194758 index 194759 definitionLike: aDefinition 194760 ifPresent: [:other | other = aDefinition 194761 ifTrue: 194762 [(self modificationConflictForDefinition: aDefinition) 194763 ifNotNil: 194764 [:c | 194765 self addOperation: c operation. 194766 self removeConflict: c. 194767 ^ self]. 194768 (self redundantAdds includes: aDefinition) 194769 ifFalse: [self addOperation: (MCRemoval of: aDefinition)]] 194770 ifFalse: 194771 [self addConflictWithOperation: (MCRemoval of: other)]] 194772 ifAbsent: []! ! 194773 194774!MCThreeWayMerger methodsFor: 'as yet unclassified' stamp: 'avi 9/19/2005 02:40'! 194775removeOperation: anOperation 194776 operations remove: anOperation! ! 194777 194778"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 194779 194780MCThreeWayMerger class 194781 instanceVariableNames: ''! 194782 194783!MCThreeWayMerger class methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:53'! 194784base: aSnapshot patch: aPatch 194785 aPatch isEmpty ifTrue: [MCNoChangesException signal]. 194786 ^ self new 194787 addBaseSnapshot: aSnapshot; 194788 applyPatch: aPatch; 194789 yourself 194790 ! ! 194791 194792!MCThreeWayMerger class methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:09'! 194793base: aSnapshot target: targetSnapshot ancestor: ancestorSnapshot 194794 ^ self base: aSnapshot patch: (targetSnapshot patchRelativeToBase: ancestorSnapshot)! ! 194795Object subclass: #MCTool 194796 instanceVariableNames: 'morph label modal modalValue' 194797 classVariableNames: '' 194798 poolDictionaries: '' 194799 category: 'MonticelloGUI'! 194800 194801!MCTool methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/11/2006 11:13'! 194802minimumExtent 194803 "Answer the minumum extent for the tool." 194804 194805 ^100@100! ! 194806 194807 194808!MCTool methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/2/2007 10:13'! 194809buildWith: builder 194810 | windowBuilder | 194811 194812 windowBuilder := MCToolWindowBuilder builder: builder tool: self. 194813 (windowBuilder respondsTo: #startWithWindow) 194814 ifTrue: [windowBuilder startWithWindow]. 194815 self widgetSpecs do: 194816 [:spec | | send fractions offsets | 194817 send := spec first. 194818 fractions := spec at: 2 ifAbsent: [#(0 0 1 1)]. 194819 offsets := spec at: 3 ifAbsent: [#(0 0 0 0)]. 194820 windowBuilder frame: (LayoutFrame 194821 fractions: (fractions first @ fractions second corner: fractions third @ fractions fourth) 194822 offsets: (offsets first @ offsets second corner: offsets third @ offsets fourth)). 194823 windowBuilder perform: send first withArguments: send allButFirst]. 194824 ^ windowBuilder build! ! 194825 194826!MCTool methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/16/2009 14:24'! 194827show 194828 "Open the tool returning the window." 194829 194830 modal := false. 194831 Smalltalk at: #ToolBuilder ifPresent: [:tb | ^tb open: self]. 194832 ^self window openInWorldExtent: self defaultExtent; yourself! ! 194833 194834!MCTool methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/16/2007 11:12'! 194835showLabelled: labelString 194836 "Use ToolBuilder if available." 194837 194838 modal := false. 194839 self label: labelString. 194840 Smalltalk at: #ToolBuilder ifPresent: [:tb | tb open: self. ^ self]. 194841 ^(self window) 194842 openInWorldExtent: self defaultExtent; 194843 yourself! ! 194844 194845!MCTool methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/16/2007 11:12'! 194846showModally 194847 "Use ToolBuilder if available." 194848 194849 |tb| 194850 modal := true. 194851 (tb := Smalltalk at: #ToolBuilder ifAbsent: []) notNil 194852 ifTrue: [morph := tb open: self] 194853 ifFalse: [self window openInWorldExtent: (400@400)]. 194854 [self window world notNil] whileTrue: [ 194855 self window outermostWorldMorph doOneCycle]. 194856 morph := nil. 194857 ^ modalValue! ! 194858 194859 194860!MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 194861answer: anObject 194862 modalValue := anObject. 194863 self close.! ! 194864 194865!MCTool methodsFor: 'morphic ui' stamp: 'nk 2/16/2004 16:50'! 194866arrowKey: aCharacter from: aPluggableListMorph 194867 "backstop"! ! 194868 194869!MCTool methodsFor: 'morphic ui' stamp: 'bp 8/9/2009 19:25'! 194870buildWindow 194871 | window | 194872 window := SystemWindow labelled: self label. 194873 window model: self. 194874 self widgetSpecs do: [:spec | 194875 | send fractions offsets | 194876 send := spec first. 194877 fractions := spec at: 2 ifAbsent: [#(0 0 1 1)]. 194878 offsets := spec at: 3 ifAbsent: [#(0 0 0 0)]. 194879 window 194880 addMorph: (self perform: send first withArguments: send allButFirst) 194881 fullFrame: 194882 (LayoutFrame 194883 fractions: 194884 ((fractions first)@(fractions second) corner: 194885 (fractions third)@(fractions fourth)) 194886 offsets: 194887 ((offsets first)@(offsets second) corner: 194888 (offsets third)@(offsets fourth)))]. 194889 ^ window! ! 194890 194891!MCTool methodsFor: 'morphic ui' stamp: 'bf 5/27/2005 19:19'! 194892buttonEnabled 194893 ^ true! ! 194894 194895!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 18:34'! 194896buttonRow 194897 ^ self buttonRow: self buttonSpecs! ! 194898 194899!MCTool methodsFor: 'morphic ui' stamp: 'al 6/21/2008 23:45'! 194900buttonRow: specArray 194901 | aRow aButton state | 194902 aRow := AlignmentMorph newRow. 194903 aRow 194904 color: (Display depth <= 8 ifTrue: [Color transparent] ifFalse: [Color gray alpha: 0.2]); 194905 borderWidth: 0. 194906 194907 aRow hResizing: #spaceFill; vResizing: #spaceFill; rubberBandCells: true. 194908 aRow clipSubmorphs: true. 194909 aRow layoutInset: 2@2; cellInset: 1; color: Color white. 194910 aRow wrapCentering: #center; cellPositioning: #leftCenter. 194911 specArray do: 194912 [:triplet | 194913 state := triplet at: 5 ifAbsent: [#buttonState]. 194914 aButton := PluggableButtonMorph 194915 on: self 194916 getState: state 194917 action: #performButtonAction:enabled:. 194918 aButton 194919 hResizing: #spaceFill; 194920 vResizing: #spaceFill; 194921 label: triplet first asString; 194922 arguments: (Array with: triplet second with: (triplet at: 4 ifAbsent: [#buttonEnabled])); 194923 onColor: Color white offColor: Color white. 194924 aRow addMorphBack: aButton. 194925 aButton setBalloonText: triplet third]. 194926 ^ aRow! ! 194927 194928!MCTool methodsFor: 'morphic ui' stamp: 'bf 5/27/2005 19:22'! 194929buttonSelected 194930 ^ false! ! 194931 194932!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:23'! 194933buttonSpecs 194934 ^ #()! ! 194935 194936!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/22/2003 00:45'! 194937buttonState 194938 ^ true! ! 194939 194940!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:42'! 194941close 194942 self window delete! ! 194943 194944!MCTool methodsFor: 'morphic ui' stamp: 'nk 7/24/2003 13:31'! 194945defaultAnnotationPaneHeight 194946 "Answer the receiver's preferred default height for new annotation panes." 194947 ^ Preferences parameterAt: #defaultAnnotationPaneHeight ifAbsentPut: [25]! ! 194948 194949!MCTool methodsFor: 'morphic ui' stamp: 'avi 2/18/2004 19:56'! 194950defaultBackgroundColor 194951 ^ (Color r: 0.627 g: 0.69 b: 0.976)! ! 194952 194953!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:22'! 194954defaultButtonPaneHeight 194955 "Answer the user's preferred default height for new button panes." 194956 194957 ^ Preferences parameterAt: #defaultButtonPaneHeight ifAbsentPut: [25]! ! 194958 194959!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:10'! 194960defaultExtent 194961 ^ 500@500! ! 194962 194963!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:11'! 194964defaultLabel 194965 ^ self class name! ! 194966 194967!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 22:33'! 194968fillMenu: aMenu fromSpecs: anArray 194969 anArray do: 194970 [:pair | 194971 aMenu add: pair first target: self selector: pair second]. 194972 ^ aMenu! ! 194973 194974!MCTool methodsFor: 'morphic ui' stamp: 'bf 3/16/2005 14:48'! 194975findListMorph: aSymbol 194976 ^ morph submorphs detect: [:ea | (ea respondsTo: #getListSelector) and: [ea getListSelector = aSymbol]] ifNone: []! ! 194977 194978!MCTool methodsFor: 'morphic ui' stamp: 'ab 8/24/2003 20:15'! 194979findTextMorph: aSymbol 194980 ^ morph submorphs detect: [:ea | (ea respondsTo: #getTextSelector) and: [ea getTextSelector = aSymbol]] ifNone: []! ! 194981 194982!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:23'! 194983getMenu: aMenu 194984 ^aMenu! ! 194985 194986!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:36'! 194987label 194988 ^ label ifNil: [self defaultLabel]! ! 194989 194990!MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 194991label: aString 194992 label := aString! ! 194993 194994!MCTool methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 17:30'! 194995listMorph: listSymbol 194996 ^ self 194997 listMorph: (listSymbol, 'List') asSymbol 194998 selection: (listSymbol, 'Selection') asSymbol 194999 menu: (listSymbol, 'ListMenu:') asSymbol! ! 195000 195001!MCTool methodsFor: 'morphic ui' stamp: 'nk 2/16/2004 17:03'! 195002listMorph: listSymbol keystroke: keystrokeSymbol 195003 ^ (self 195004 listMorph: (listSymbol, 'List') asSymbol 195005 selection: (listSymbol, 'Selection') asSymbol 195006 menu: (listSymbol, 'ListMenu:') asSymbol) 195007 keystrokeActionSelector: keystrokeSymbol; 195008 yourself! ! 195009 195010!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:46'! 195011listMorph: listSymbol selection: selectionSymbol 195012 ^ PluggableListMorph 195013 on: self 195014 list: listSymbol 195015 selected: selectionSymbol 195016 changeSelected: (selectionSymbol, ':') asSymbol! ! 195017 195018!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:46'! 195019listMorph: listSymbol selection: selectionSymbol menu: menuSymbol 195020 ^ PluggableListMorph 195021 on: self 195022 list: listSymbol 195023 selected: selectionSymbol 195024 changeSelected: (selectionSymbol, ':') asSymbol 195025 menu: menuSymbol! ! 195026 195027!MCTool methodsFor: 'morphic ui' stamp: 'nk 2/16/2004 16:50'! 195028listMorph: listSymbol selection: selectionSymbol menu: menuSymbol keystroke: keystrokeSymbol 195029 ^ (PluggableListMorph 195030 on: self 195031 list: listSymbol 195032 selected: selectionSymbol 195033 changeSelected: (selectionSymbol, ':') asSymbol 195034 menu: menuSymbol) 195035 keystrokeActionSelector: keystrokeSymbol; 195036 yourself! ! 195037 195038!MCTool methodsFor: 'morphic ui' stamp: 'avi 9/11/2004 16:19'! 195039multiListMorph: listSymbol selection: selectionSymbol listSelection: listSelectionSymbol menu: menuSymbol 195040 ^ PluggableListMorphOfMany 195041 on: self 195042 list: listSymbol 195043 primarySelection: selectionSymbol 195044 changePrimarySelection: (selectionSymbol, ':') asSymbol 195045 listSelection: listSelectionSymbol 195046 changeListSelection: (listSelectionSymbol, 'put:') asSymbol 195047 menu: menuSymbol! ! 195048 195049!MCTool methodsFor: 'morphic ui' stamp: 'lr 10/5/2003 09:09'! 195050performButtonAction: anActionSelector enabled: anEnabledSelector 195051 (self perform: anEnabledSelector) 195052 ifTrue: [ self perform: anActionSelector ]! ! 195053 195054!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:18'! 195055perform: selector orSendTo: otherTarget 195056 "Selector was just chosen from a menu by a user. If can respond, then 195057perform it on myself. If not, send it to otherTarget, presumably the 195058editPane from which the menu was invoked." 195059 195060 (self respondsTo: selector) 195061 ifTrue: [^ self perform: selector] 195062 ifFalse: [^ otherTarget perform: selector]! ! 195063 195064!MCTool methodsFor: 'morphic ui' stamp: 'nk 6/12/2004 14:11'! 195065step 195066! ! 195067 195068!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:36'! 195069textMorph: aSymbol 195070 ^ PluggableTextMorph on: self text: aSymbol accept: (aSymbol, ':') asSymbol! ! 195071 195072!MCTool methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:27'! 195073treeMorph: listSymbol 195074 ^ self 195075 treeMorph: (listSymbol, 'Tree') asSymbol 195076 selection: (listSymbol, 'SelectionWrapper') asSymbol 195077 menu: (listSymbol, 'TreeMenu:') asSymbol! ! 195078 195079!MCTool methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:43'! 195080treeMorph: listSymbol selection: selectionSymbol menu: menuSymbol 195081 ^ SimpleHierarchicalListMorph 195082 on: self 195083 list: listSymbol 195084 selected: selectionSymbol 195085 changeSelected: (selectionSymbol, ':') asSymbol 195086 menu: menuSymbol 195087 keystroke: nil! ! 195088 195089!MCTool methodsFor: 'morphic ui' stamp: 'avi 3/6/2005 22:31'! 195090treeOrListMorph: aSymbol 195091 ^ self treeMorph: aSymbol! ! 195092 195093!MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:40'! 195094widgetSpecs 195095 ^ #()! ! 195096 195097!MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 195098window 195099 ^ morph ifNil: [morph := self buildWindow]! ! 195100 195101"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 195102 195103MCTool class 195104 instanceVariableNames: ''! 195105Object subclass: #MCToolWindowBuilder 195106 instanceVariableNames: 'builder window currentFrame tool' 195107 classVariableNames: '' 195108 poolDictionaries: '' 195109 category: 'MonticelloGUI'! 195110 195111!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:03'! 195112build 195113 ^ builder build: window! ! 195114 195115!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:04'! 195116buttonRow 195117 ^ self buttonRow: tool buttonSpecs! ! 195118 195119!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 195120buttonRow: specArray 195121 | panel button | 195122 panel := builder pluggablePanelSpec new. 195123 panel children: OrderedCollection new. 195124 specArray do: 195125 [:spec | 195126 195127 button := builder pluggableButtonSpec new. 195128 button model: tool. 195129 button label: spec first asString. 195130 button action: spec second. 195131 button help: spec third. 195132 button enabled: (spec at: 4 ifAbsent: [#buttonEnabled]). 195133 button state: (spec at: 5 ifAbsent: [#buttonSelected]). 195134 panel children add: button]. 195135 panel layout: #horizontal. 195136 panel frame: currentFrame. 195137 window children add: panel! ! 195138 195139!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 195140frame: aLayoutFrame 195141 currentFrame := aLayoutFrame! ! 195142 195143!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 195144initializeWithBuilder: aBuilder tool: aTool 195145 builder := aBuilder. 195146 tool := aTool. 195147 window := builder pluggableWindowSpec new. 195148 window children: OrderedCollection new. 195149 window label: tool label asString. 195150 window model: tool. 195151 window extent: tool defaultExtent.! ! 195152 195153!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:04'! 195154listMorph: listSymbol 195155 ^ self 195156 listMorph: (listSymbol, 'List') asSymbol 195157 selection: (listSymbol, 'Selection') asSymbol 195158 menu: (listSymbol, 'ListMenu:') asSymbol! ! 195159 195160!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:04'! 195161listMorph: listSymbol keystroke: keystrokeSymbol 195162 ^ (self 195163 listMorph: (listSymbol, 'List') asSymbol 195164 selection: (listSymbol, 'Selection') asSymbol 195165 menu: (listSymbol, 'ListMenu:') asSymbol) 195166 keystrokeActionSelector: keystrokeSymbol; 195167 yourself! ! 195168 195169!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:15'! 195170listMorph: listSymbol selection: selectionSymbol 195171 self listMorph: listSymbol selection: selectionSymbol menu: nil! ! 195172 195173!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:16'! 195174listMorph: listSymbol selection: selectionSymbol menu: menuSymbol 195175 self listMorph: listSymbol selection: selectionSymbol menu: menuSymbol keystroke: nil! ! 195176 195177!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2005 17:51'! 195178listMorph: listSymbol selection: selectionSymbol menu: menuSymbol keystroke: keystrokeSymbol 195179 | list | 195180 list := builder pluggableListSpec new. 195181 list 195182 model: tool; 195183 list: listSymbol; 195184 getIndex: selectionSymbol; 195185 setIndex: (selectionSymbol, ':') asSymbol; 195186 frame: currentFrame. 195187 menuSymbol ifNotNil: [list menu: menuSymbol]. 195188 keystrokeSymbol ifNotNil: [list keyPress: keystrokeSymbol]. 195189 window children add: list 195190! ! 195191 195192!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2005 17:52'! 195193multiListMorph: listSymbol selection: selectionSymbol listSelection: listSelectionSymbol menu: menuSymbol 195194 | list | 195195 list := builder pluggableMultiSelectionListSpec new. 195196 list 195197 model: tool; 195198 list: listSymbol; 195199 getIndex: selectionSymbol; 195200 setIndex: (selectionSymbol, ':') asSymbol; 195201 getSelectionList: listSelectionSymbol; 195202 setSelectionList: (listSelectionSymbol, 'put:') asSymbol; 195203 frame: currentFrame. 195204 menuSymbol ifNotNil: [list menu: menuSymbol]. 195205 window children add: list 195206! ! 195207 195208!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2005 17:52'! 195209textMorph: aSymbol 195210 | text | 195211 text := builder pluggableTextSpec new. 195212 text 195213 model: tool; 195214 getText: aSymbol; 195215 setText: (aSymbol, ':') asSymbol; 195216 frame: currentFrame. 195217 window children add: text! ! 195218 195219!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:05'! 195220treeMorph: listSymbol 195221 ^ self 195222 treeMorph: (listSymbol, 'Tree') asSymbol 195223 selection: (listSymbol, 'SelectionWrapper') asSymbol 195224 menu: (listSymbol, 'TreeMenu:') asSymbol! ! 195225 195226!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2005 17:52'! 195227treeMorph: listSymbol selection: selectionSymbol menu: menuSymbol 195228 self notYetImplemented! ! 195229 195230!MCToolWindowBuilder methodsFor: 'as yet unclassified' stamp: 'avi 3/6/2005 22:31'! 195231treeOrListMorph: listSymbol 195232 ^ self listMorph: listSymbol! ! 195233 195234"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 195235 195236MCToolWindowBuilder class 195237 instanceVariableNames: ''! 195238 195239!MCToolWindowBuilder class methodsFor: 'as yet unclassified' stamp: 'avi 2/11/2005 12:02'! 195240builder: aBuilder tool: aTool 195241 ^ self basicNew initializeWithBuilder: aBuilder tool: aTool! ! 195242MCClassDefinition subclass: #MCTraitDefinition 195243 instanceVariableNames: '' 195244 classVariableNames: '' 195245 poolDictionaries: '' 195246 category: 'Monticello-Modeling'! 195247 195248!MCTraitDefinition methodsFor: 'accessing' stamp: 'al 6/5/2006 14:05'! 195249classTraitCompositionString 195250 ^self traitComposition ifNil: ['{}'].! ! 195251 195252 195253!MCTraitDefinition methodsFor: 'comparing' stamp: 'al 6/5/2006 14:14'! 195254hash 195255 | hash | 195256 hash := String stringHash: name initialHash: 0. 195257 hash := String stringHash: self traitCompositionString initialHash: hash. 195258 hash := String stringHash: (category ifNil: ['']) initialHash: hash. 195259 ^ hash 195260! ! 195261 195262!MCTraitDefinition methodsFor: 'comparing' stamp: 'al 6/5/2006 14:13'! 195263requirements 195264 "Assuming that traits in a composition can be identified by 195265 testing for the first character beeing an uppercase character 195266 (and thus not a special character such as {, # etc.)" 195267 195268 | tokens traitNames | 195269 self hasTraitComposition ifFalse: [ ^Array new ]. 195270 tokens := Scanner new scanTokens: self traitComposition. 195271 traitNames := tokens select: [:each | each first isUppercase]. 195272 ^traitNames asArray! ! 195273 195274 195275!MCTraitDefinition methodsFor: 'initializing' stamp: 'al 6/5/2006 14:14'! 195276initializeWithName: classNameString 195277 traitComposition: traitCompositionString 195278 category: categoryString 195279 comment: commentString 195280 commentStamp: commentStampString 195281 195282 name := classNameString asSymbol. 195283 traitComposition := traitCompositionString. 195284 category := categoryString. 195285 comment := commentString withSqueakLineEndings. 195286 commentStamp := commentStampString ifNil: [self defaultCommentStamp] 195287! ! 195288 195289 195290!MCTraitDefinition methodsFor: 'installing' stamp: 'marcus.denker 11/10/2008 10:04'! 195291load 195292 self createClass ifNotNil: [:trait | 195293 self hasComment ifTrue: [trait classComment: comment stamp: commentStamp]]! ! 195294 195295 195296!MCTraitDefinition methodsFor: 'printing' stamp: 'al 6/5/2006 14:15'! 195297printDefinitionOn: stream 195298 stream nextPutAll: 'Trait named: #', self className; 195299 cr; 195300 tab; 195301 nextPutAll: 'uses: '; 195302 nextPutAll: self traitCompositionString; 195303 cr; 195304 tab; 195305 nextPutAll: 'category: '; 195306 store: self category asString 195307! ! 195308 195309 195310!MCTraitDefinition methodsFor: 'testing' stamp: 'al 10/9/2005 20:28'! 195311hasClassInstanceVariables 195312 ^ false 195313 195314! ! 195315 195316 195317!MCTraitDefinition methodsFor: 'visiting' stamp: 'al 10/9/2005 20:28'! 195318accept: aVisitor 195319 ^ aVisitor visitTraitDefinition: self 195320! ! 195321 195322!MCTraitDefinition methodsFor: 'visiting' stamp: 'al 6/5/2006 14:15'! 195323createClass 195324 ^Trait 195325 named: name 195326 uses: (Compiler evaluate: self traitCompositionString) 195327 category: category 195328 195329! ! 195330 195331!MCTraitDefinition methodsFor: 'visiting' stamp: 'al 10/9/2005 21:58'! 195332= aDefinition 195333 self flag: #traits. "Ugly we harcoded the super superclass method. We will have to refactor the definition hierarchy" 195334 195335 ^ (self isRevisionOf: aDefinition) 195336 and: [self traitCompositionString = aDefinition traitCompositionString] 195337 and: [category = aDefinition category] 195338 and: [comment = aDefinition comment]! ! 195339 195340"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 195341 195342MCTraitDefinition class 195343 instanceVariableNames: ''! 195344 195345!MCTraitDefinition class methodsFor: 'as yet unclassified' stamp: 'al 10/9/2005 20:28'! 195346name: classNameString traitComposition: traitCompositionString category: categoryString comment: commentString commentStamp: commentStamp 195347 ^ self instanceLike: 195348 (self new initializeWithName: classNameString 195349 traitComposition: traitCompositionString 195350 category: categoryString 195351 comment: commentString 195352 commentStamp: commentStamp) 195353! ! 195354MCDoItParser subclass: #MCTraitParser 195355 instanceVariableNames: '' 195356 classVariableNames: '' 195357 poolDictionaries: '' 195358 category: 'Monticello-Modeling'! 195359 195360!MCTraitParser methodsFor: 'as yet unclassified' stamp: 'PeterHugossonMiller 9/2/2009 16:15'! 195361addDefinitionsTo: aCollection 195362 | tokens definition traitCompositionString | 195363 tokens := Scanner new scanTokens: source. 195364 traitCompositionString := (source readStream 195365 match: 'uses:'; 195366 upToAll: 'category:') withBlanksTrimmed. 195367 definition := MCTraitDefinition 195368 name: (tokens at: 3) 195369 traitComposition: traitCompositionString 195370 category: tokens last 195371 comment: '' 195372 commentStamp: ''. 195373 aCollection add: definition.! ! 195374 195375"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 195376 195377MCTraitParser class 195378 instanceVariableNames: ''! 195379 195380!MCTraitParser class methodsFor: 'as yet unclassified' stamp: 'al 10/9/2005 21:09'! 195381pattern 195382 ^ 'Trait named:*'! ! 195383Object subclass: #MCVariableDefinition 195384 instanceVariableNames: 'name' 195385 classVariableNames: '' 195386 poolDictionaries: '' 195387 category: 'Monticello-Modeling'! 195388 195389!MCVariableDefinition methodsFor: 'accessing' stamp: 'cwp 11/25/2002 05:57'! 195390name 195391 ^ name! ! 195392 195393!MCVariableDefinition methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 195394name: aString 195395 name := aString! ! 195396 195397 195398!MCVariableDefinition methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 14:56'! 195399printOn: aStream 195400 super printOn: aStream. 195401 aStream nextPut: $(; nextPutAll: self name; nextPut: $)! ! 195402 195403 195404!MCVariableDefinition methodsFor: 'comparing' stamp: 'cwp 7/7/2003 23:02'! 195405hash 195406 ^ name hash! ! 195407 195408!MCVariableDefinition methodsFor: 'comparing' stamp: 'cwp 7/7/2003 23:02'! 195409= other 195410 ^ (self species = other species) 195411 and: [self name = other name]! ! 195412 195413 195414!MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:31'! 195415isClassInstanceVariable 195416 ^ false! ! 195417 195418!MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:08'! 195419isClassInstanceVariableDefinition 195420 ^ false! ! 195421 195422!MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:30'! 195423isClassVariable 195424 ^ false! ! 195425 195426!MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:31'! 195427isInstanceVariable 195428 ^ false! ! 195429 195430!MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:10'! 195431isInstanceVariableDefinition 195432 ^ false! ! 195433 195434!MCVariableDefinition methodsFor: 'testing' stamp: 'bf 8/29/2006 11:41'! 195435isOrderDependend 195436 ^true! ! 195437 195438!MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:51'! 195439isPoolImport 195440 ^ false! ! 195441 195442"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 195443 195444MCVariableDefinition class 195445 instanceVariableNames: ''! 195446 195447!MCVariableDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 23:18'! 195448name: aString 195449 ^ self new name: aString 195450 ! ! 195451Object subclass: #MCVersion 195452 instanceVariableNames: 'package info snapshot dependencies' 195453 classVariableNames: '' 195454 poolDictionaries: '' 195455 category: 'Monticello-Versioning'! 195456 195457!MCVersion methodsFor: '*MonticelloGUI' stamp: 'bf 3/22/2005 22:12'! 195458browse 195459 (MCSnapshotBrowser forSnapshot: self snapshot) 195460 showLabelled: 'Snapshot of ', self fileName! ! 195461 195462!MCVersion methodsFor: '*MonticelloGUI' stamp: 'ab 7/12/2003 00:19'! 195463open 195464 (MCVersionInspector new version: self) show! ! 195465 195466 195467!MCVersion methodsFor: 'accessing' stamp: 'avi 2/13/2004 22:42'! 195468changes 195469 ^ self snapshot patchRelativeToBase: package snapshot! ! 195470 195471!MCVersion methodsFor: 'accessing' stamp: 'avi 1/22/2004 00:24'! 195472dependencies 195473 ^ dependencies ifNil: [#()]! ! 195474 195475!MCVersion methodsFor: 'accessing' stamp: 'avi 1/22/2004 12:44'! 195476fileName 195477 ^ info name, '.', self writerClass extension! ! 195478 195479!MCVersion methodsFor: 'accessing' stamp: 'ab 7/7/2003 14:28'! 195480info 195481 ^ info! ! 195482 195483!MCVersion methodsFor: 'accessing' stamp: 'ab 7/7/2003 14:19'! 195484package 195485 ^ package! ! 195486 195487!MCVersion methodsFor: 'accessing' stamp: 'ab 7/7/2003 14:10'! 195488snapshot 195489 ^ snapshot! ! 195490 195491!MCVersion methodsFor: 'accessing' stamp: 'adrian_lienhard 1/7/2009 17:32'! 195492summary 195493 ^ String streamContents: 195494 [:s | 195495 s nextPutAll: info summaryHeader. 195496 (dependencies isNil or: [dependencies isEmpty]) ifFalse: 195497 [s cr; nextPutAll: 'Dependencies: '. 195498 dependencies 195499 do: [:ea | s nextPutAll: ea versionInfo name] 195500 separatedBy: [s nextPutAll: ', ']]. 195501 s cr; cr; nextPutAll: info message]! ! 195502 195503!MCVersion methodsFor: 'accessing' stamp: 'avi 2/12/2004 19:38'! 195504workingCopy 195505 ^ package workingCopy! ! 195506 195507!MCVersion methodsFor: 'accessing' stamp: 'avi 1/22/2004 12:44'! 195508writerClass 195509 ^ MCMczWriter ! ! 195510 195511 195512!MCVersion methodsFor: 'actions' stamp: 'avi 10/9/2003 13:00'! 195513addToCache 195514 MCCacheRepository default storeVersion: self! ! 195515 195516!MCVersion methodsFor: 'actions' stamp: 'avi 2/12/2004 19:37'! 195517adopt 195518 self workingCopy adopt: self! ! 195519 195520!MCVersion methodsFor: 'actions' stamp: 'avi 1/22/2004 12:44'! 195521fileOutOn: aStream 195522 self writerClass fileOut: self on: aStream! ! 195523 195524!MCVersion methodsFor: 'actions' stamp: 'avi 1/24/2004 20:13'! 195525load 195526 MCVersionLoader loadVersion: self! ! 195527 195528!MCVersion methodsFor: 'actions' stamp: 'abc 2/13/2004 15:58'! 195529merge 195530 MCVersionMerger mergeVersion: self! ! 195531 195532 195533!MCVersion methodsFor: 'converting' stamp: 'avi 2/19/2004 21:00'! 195534asDiffAgainst: aVersion 195535 aVersion info = self info ifTrue: [self error: 'Cannot diff against self!!']. 195536 ^ MCDiffyVersion 195537 package: self package 195538 info: self info 195539 snapshot: self snapshot 195540 dependencies: self dependencies 195541 baseVersion: aVersion! ! 195542 195543 195544!MCVersion methodsFor: 'enumerating' stamp: 'stephaneducasse 2/4/2006 20:47'! 195545allAvailableDependenciesDo: aBlock 195546 | version | 195547 self dependencies do: 195548 [:ea | 195549 [version := ea resolve. 195550 version allAvailableDependenciesDo: aBlock. 195551 aBlock value: version] 195552 on: Error do: []]! ! 195553 195554!MCVersion methodsFor: 'enumerating' stamp: 'cwp 11/7/2004 11:58'! 195555allDependenciesDo: aBlock 195556 self allDependenciesDo: aBlock ifUnresolved: [:ignored | true]! ! 195557 195558!MCVersion methodsFor: 'enumerating' stamp: 'stephaneducasse 2/4/2006 20:47'! 195559allDependenciesDo: aBlock ifUnresolved: failBlock 195560 | dict | 195561 dict := Dictionary new. 195562 self allDependenciesNotIn: dict do: aBlock ifUnresolved: failBlock! ! 195563 195564!MCVersion methodsFor: 'enumerating' stamp: 'cwp 11/7/2004 14:24'! 195565allDependenciesNotIn: aDictionary do: aBlock ifUnresolved: failBlock 195566 | version | 195567 self dependencies do: 195568 [:ea | 195569 version := aDictionary at: ea ifAbsent: [ea resolve]. 195570 version 195571 ifNil: [failBlock value: ea] 195572 ifNotNil: [(aDictionary includes: version) ifFalse: 195573 [aDictionary at: ea put: version. 195574 version 195575 allDependenciesNotIn: aDictionary 195576 do: aBlock 195577 ifUnresolved: failBlock. 195578 aBlock value: version]]]! ! 195579 195580!MCVersion methodsFor: 'enumerating' stamp: 'cwp 11/7/2004 14:24'! 195581withAllDependenciesDo: aBlock 195582 self allDependenciesDo: aBlock ifUnresolved: [:ignored]. 195583 aBlock value: self! ! 195584 195585!MCVersion methodsFor: 'enumerating' stamp: 'stephaneducasse 2/4/2006 20:47'! 195586withAllDependenciesDo: aBlock ifUnresolved: failBlock 195587 | dict | 195588 dict := Dictionary new. 195589 self allDependenciesNotIn: dict do: aBlock ifUnresolved: failBlock. 195590 aBlock value: self! ! 195591 195592 195593!MCVersion methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! 195594initializeWithPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection 195595 package := aPackage. 195596 info := aVersionInfo. 195597 snapshot := aSnapshot. 195598 dependencies := aCollection. 195599 self addToCache.! ! 195600 195601!MCVersion methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! 195602setPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection 195603 package := aPackage. 195604 info := aVersionInfo. 195605 snapshot := aSnapshot. 195606 dependencies := aCollection! ! 195607 195608 195609!MCVersion methodsFor: 'printing' stamp: 'nk 3/8/2004 23:54'! 195610printOn: aStream 195611 super printOn: aStream. 195612 aStream nextPut: $(. 195613 aStream nextPutAll: self info name. 195614 aStream nextPut: $).! ! 195615 195616 195617!MCVersion methodsFor: 'testing' stamp: 'bf 5/23/2005 15:43'! 195618canOptimizeLoading 195619 "Answer wether I can provide a patch for the working copy without the usual diff pass" 195620 ^false! ! 195621 195622!MCVersion methodsFor: 'testing' stamp: 'bf 3/22/2005 23:00'! 195623isCacheable 195624 ^true! ! 195625 195626!MCVersion methodsFor: 'testing' stamp: 'avi 2/13/2004 23:24'! 195627isDiffy 195628 ^ false! ! 195629 195630"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 195631 195632MCVersion class 195633 instanceVariableNames: ''! 195634 195635!MCVersion class methodsFor: 'instance creation' stamp: 'ab 7/7/2003 16:13'! 195636package: aPackage 195637 ^ self package: aPackage info: MCVersionInfo new! ! 195638 195639!MCVersion class methodsFor: 'instance creation' stamp: 'ab 7/7/2003 16:13'! 195640package: aPackage info: aVersionInfo 195641 ^ self package: aPackage info: aVersionInfo snapshot: aPackage snapshot! ! 195642 195643!MCVersion class methodsFor: 'instance creation' stamp: 'cwp 11/7/2004 13:02'! 195644package: aPackage info: aVersionInfo snapshot: aSnapshot 195645 ^ self package: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: #()! ! 195646 195647!MCVersion class methodsFor: 'instance creation' stamp: 'avi 1/19/2004 13:11'! 195648package: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection 195649 ^ self new initializeWithPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection! ! 195650Object subclass: #MCVersionDependency 195651 instanceVariableNames: 'package versionInfo' 195652 classVariableNames: '' 195653 poolDictionaries: '' 195654 category: 'Monticello-Versioning'! 195655 195656!MCVersionDependency methodsFor: 'accessing' stamp: 'avi 1/19/2004 15:40'! 195657package 195658 ^ package! ! 195659 195660!MCVersionDependency methodsFor: 'accessing' stamp: 'avi 2/12/2004 19:38'! 195661repositoryGroup 195662 ^ self package workingCopy repositoryGroup! ! 195663 195664!MCVersionDependency methodsFor: 'accessing' stamp: 'avi 1/19/2004 15:40'! 195665versionInfo 195666 ^ versionInfo! ! 195667 195668 195669!MCVersionDependency methodsFor: 'comparing' stamp: 'avi 1/19/2004 16:06'! 195670hash 195671 ^ versionInfo hash! ! 195672 195673!MCVersionDependency methodsFor: 'comparing' stamp: 'avi 1/19/2004 16:12'! 195674= other 195675 ^ other species = self species 195676 and: [other versionInfo = versionInfo 195677 and: [other package = package]]! ! 195678 195679 195680!MCVersionDependency methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! 195681initializeWithPackage: aPackage info: aVersionInfo 195682 package := aPackage. 195683 versionInfo := aVersionInfo! ! 195684 195685 195686!MCVersionDependency methodsFor: 'resolving' stamp: 'nk 6/13/2004 19:21'! 195687resolve 195688 ^ self repositoryGroup 195689 versionWithInfo: versionInfo 195690 ifNone: [ MCRepositoryGroup default versionWithInfo: versionInfo ifNone: []]! ! 195691 195692 195693!MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'! 195694isCurrent 195695 ^ package hasWorkingCopy 195696 and: [self isFulfilled 195697 and: [package workingCopy modified not]]! ! 195698 195699!MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'! 195700isFulfilled 195701 ^package hasWorkingCopy 195702 and: [self isFulfilledBy: package workingCopy ancestry]! ! 195703 195704!MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'! 195705isFulfilledByAncestors 195706 ^ package hasWorkingCopy 195707 and: [self isFulfilledByAncestorsOf: package workingCopy ancestry]! ! 195708 195709!MCVersionDependency methodsFor: 'testing' stamp: 'nk 7/13/2004 08:45'! 195710isFulfilledByAncestorsOf: anAncestry 195711 ^ anAncestry hasAncestor: versionInfo! ! 195712 195713!MCVersionDependency methodsFor: 'testing' stamp: 'avi 3/4/2004 00:34'! 195714isFulfilledBy: anAncestry 195715 ^ anAncestry ancestors includes: versionInfo! ! 195716 195717!MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'! 195718isOlder 195719 "Answer true if I represent an older version of a package that is loaded." 195720 ^ package hasWorkingCopy 195721 and: [self isFulfilled not 195722 and: [ self isFulfilledByAncestors 195723 and: [package workingCopy modified not]]]! ! 195724 195725"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 195726 195727MCVersionDependency class 195728 instanceVariableNames: ''! 195729 195730!MCVersionDependency class methodsFor: 'as yet unclassified' stamp: 'avi 1/19/2004 13:13'! 195731package: aPackage info: aVersionInfo 195732 ^ self basicNew initializeWithPackage: aPackage info: aVersionInfo! ! 195733MCTool subclass: #MCVersionHistoryBrowser 195734 instanceVariableNames: 'ancestry index repositoryGroup package infos' 195735 classVariableNames: '' 195736 poolDictionaries: '' 195737 category: 'MonticelloGUI'! 195738 195739!MCVersionHistoryBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 2/3/2009 13:15'! 195740viewChanges: patch 195741 "Opene a browser on the patch." 195742 195743 |patchLabel| 195744 patchLabel := 'Changes between {1} and {2}' format: { self selectedInfo name. ancestry name }. 195745 Preferences useNewDiffToolsForMC 195746 ifTrue: [((PSMCPatchMorph forPatch: patch) newWindow) 195747 title: patchLabel; 195748 open] 195749 ifFalse: [(MCPatchBrowser forPatch: patch) 195750 label: patchLabel; 195751 show]! ! 195752 195753 195754!MCVersionHistoryBrowser methodsFor: '*Polymorph-Tools-Diff-override' stamp: 'gvc 2/3/2009 13:15'! 195755viewChanges 195756 "Note that the patchLabel will be parsed in MCPatchBrowser>>installSelection, so don't translate it!!" 195757 195758 self viewChanges: (self baseSnapshot patchRelativeToBase: self selectedSnapshot) 195759 ! ! 195760 195761 195762!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 195763ancestry: anAncestry 195764 ancestry := anAncestry! ! 195765 195766!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:10'! 195767baseSnapshot 195768 ^ self snapshotForInfo: ancestry! ! 195769 195770!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/22/2003 01:41'! 195771index 195772 "Answer the value of index" 195773 195774 ^ index! ! 195775 195776!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 195777index: anObject 195778 "Set the value of index" 195779 195780 index := anObject! ! 195781 195782!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 195783infos 195784 ^ infos ifNil: [infos := ancestry withBreadthFirstAncestors]! ! 195785 195786!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'avi 9/17/2005 16:10'! 195787list 195788 ^ self infos collect: [:ea | ea name]! ! 195789 195790!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 195791package: aMCPackage 195792 package := aMCPackage! ! 195793 195794!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/7/2003 21:27'! 195795repositoryGroup 195796 ^ MCRepositoryGroup default! ! 195797 195798!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'avi 9/17/2005 16:09'! 195799selectedInfo 195800 ^ self infos at: self selection ifAbsent: [nil]! ! 195801 195802!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/22/2003 01:39'! 195803selectedSnapshot 195804 ^ self snapshotForInfo: self selectedInfo! ! 195805 195806!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 7/11/2003 23:24'! 195807selection 195808 ^ index ifNil: [0]! ! 195809 195810!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 195811selection: aNumber 195812 index := aNumber. 195813 self changed: #selection; changed: #summary! ! 195814 195815!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/22/2003 01:38'! 195816snapshotForInfo: aVersionInfo 195817 ^ (self repositoryGroup versionWithInfo: aVersionInfo) snapshot! ! 195818 195819!MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 195820summary 195821 | selInfo | 195822 selInfo := self selectedInfo. 195823 ^ selInfo 195824 ifNil: [''] 195825 ifNotNil: [selInfo summary]! ! 195826 195827 195828!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:41'! 195829defaultExtent 195830 ^ 440@169. 195831 ! ! 195832 195833!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'avi 2/13/2004 01:09'! 195834defaultLabel 195835 ^ ancestry name, ' History'! ! 195836 195837!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'avi 2/13/2004 01:09'! 195838getMenu: aMenu 195839 index < 2 ifTrue: [^ aMenu]. 195840 self fillMenu: aMenu fromSpecs: 195841 (Array 195842 with: (Array with: 'view changes -> ', ancestry name with: #viewChanges) 195843 with: #('spawn history' spawnHistory)). 195844 ^ aMenu! ! 195845 195846!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'avi 2/13/2004 01:10'! 195847spawnHistory 195848 MCVersionHistoryBrowser new 195849 ancestry: self selectedInfo; 195850 package: package; 195851 show! ! 195852 195853!MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'nk 7/28/2003 18:05'! 195854widgetSpecs 195855 ^ #( 195856 ((listMorph:selection:menu: list selection getMenu:) (0 0 0.3 1)) 195857 ((textMorph: summary) (0.3 0 1 1)) 195858 )! ! 195859 195860"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 195861 195862MCVersionHistoryBrowser class 195863 instanceVariableNames: ''! 195864MCAncestry subclass: #MCVersionInfo 195865 instanceVariableNames: 'id name message date time author' 195866 classVariableNames: '' 195867 poolDictionaries: '' 195868 category: 'Monticello-Versioning'! 195869!MCVersionInfo commentStamp: '<historical>' prior: 0! 195870Adds to the record of ancestry, other identifying details.! 195871 195872 195873!MCVersionInfo methodsFor: 'accessing' stamp: 'ab 7/12/2003 00:04'! 195874message 195875 ^ message ifNil: ['']! ! 195876 195877!MCVersionInfo methodsFor: 'accessing' stamp: 'ab 7/11/2003 23:33'! 195878name 195879 ^ name ifNil: ['<working copy>']! ! 195880 195881!MCVersionInfo methodsFor: 'accessing' stamp: 'adrian_lienhard 1/7/2009 17:31'! 195882summary 195883 ^ String streamContents: 195884 [:s | 195885 s 195886 nextPutAll: self summaryHeader; cr; cr; 195887 nextPutAll: self message. 195888 ]! ! 195889 195890!MCVersionInfo methodsFor: 'accessing' stamp: 'avi 9/14/2004 15:22'! 195891summaryHeader 195892 ^ String streamContents: 195893 [:s | 195894 s 195895 nextPutAll: 'Name: '; nextPutAll: self name; cr. 195896 date ifNotNil: 195897 [s 195898 nextPutAll: 'Author: '; nextPutAll: author; cr; 195899 nextPutAll: 'Time: '; nextPutAll: date asString, ', ', time asString; cr]. 195900 id ifNotNil: 195901 [s nextPutAll: 'UUID: '; nextPutAll: id asString; cr]. 195902 s 195903 nextPutAll: 'Ancestors: '; nextPutAll: self ancestorString. 195904 self stepChildren isEmpty ifFalse: 195905 [s cr; nextPutAll: 'Backported From: '; nextPutAll: self stepChildrenString]. 195906 ]! ! 195907 195908!MCVersionInfo methodsFor: 'accessing' stamp: 'avi 1/22/2004 16:45'! 195909timeStamp 195910 ^ TimeStamp date: date time: time! ! 195911 195912!MCVersionInfo methodsFor: 'accessing' stamp: 'avi 9/17/2003 11:24'! 195913timeString 195914 ^ date asString, ', ', time asString! ! 195915 195916 195917!MCVersionInfo methodsFor: 'comparing' stamp: 'ab 7/5/2003 14:09'! 195918hash 195919 ^ id hash! ! 195920 195921!MCVersionInfo methodsFor: 'comparing' stamp: 'ab 7/5/2003 14:23'! 195922= other 195923 ^ other species = self species 195924 and: [other hasID: id]! ! 195925 195926 195927!MCVersionInfo methodsFor: 'converting' stamp: 'nk 1/23/2004 21:09'! 195928asDictionary 195929 ^ Dictionary new 195930 at: #name put: name; 195931 at: #id put: id; 195932 at: #message put: message; 195933 at: #date put: date; 195934 at: #time put: time; 195935 at: #author put: author; 195936 at: #ancestors put: (self ancestors collect: [:a | a asDictionary]); 195937 yourself! ! 195938 195939 195940!MCVersionInfo methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! 195941initializeWithName: vName id: aUUID message: aString date: aDate time: aTime author: initials ancestors: aCollection stepChildren: stepCollection 195942 name := vName. 195943 id := aUUID. 195944 message := aString. 195945 date := aDate. 195946 time := aTime. 195947 author := initials. 195948 ancestors := aCollection. 195949 stepChildren := stepCollection! ! 195950 195951 195952!MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:26'! 195953author 195954 ^ author! ! 195955 195956!MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:26'! 195957date 195958 ^ date! ! 195959 195960!MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:24'! 195961id 195962 ^ id ! ! 195963 195964!MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:26'! 195965time 195966 ^ time! ! 195967 195968 195969!MCVersionInfo methodsFor: 'printing' stamp: 'ab 7/5/2003 18:00'! 195970printOn: aStream 195971 super printOn: aStream. 195972 aStream nextPut: $(; nextPutAll: self name; nextPut: $) 195973 ! ! 195974 195975 195976!MCVersionInfo methodsFor: 'private' stamp: 'ab 7/5/2003 14:10'! 195977hasID: aUUID 195978 ^ id = aUUID! ! 195979 195980"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 195981 195982MCVersionInfo class 195983 instanceVariableNames: ''! 195984 195985!MCVersionInfo class methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 10:44'! 195986name: vName id: id message: message date: date time: time author: author ancestors: ancestors 195987 ^ self 195988 name: vName 195989 id: id 195990 message: message 195991 date: date 195992 time: time 195993 author: author 195994 ancestors: ancestors 195995 stepChildren: #()! ! 195996 195997!MCVersionInfo class methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 10:43'! 195998name: vName id: id message: message date: date time: time author: author ancestors: ancestors stepChildren: stepChildren 195999 ^ self new 196000 initializeWithName: vName 196001 id: id 196002 message: message 196003 date: date 196004 time: time 196005 author: author 196006 ancestors: ancestors 196007 stepChildren: stepChildren! ! 196008MCWriter subclass: #MCVersionInfoWriter 196009 instanceVariableNames: 'written' 196010 classVariableNames: '' 196011 poolDictionaries: '' 196012 category: 'Monticello-Storing'! 196013 196014!MCVersionInfoWriter methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 21:10'! 196015isWritten: aVersionInfo 196016 ^ self written includes: aVersionInfo! ! 196017 196018!MCVersionInfoWriter methodsFor: 'as yet unclassified' stamp: 'avi 9/13/2004 16:53'! 196019writeVersionInfo: aVersionInfo 196020 (self isWritten: aVersionInfo) 196021 ifTrue: [^ stream nextPutAll: '(id ', aVersionInfo id asString printString, ')']. 196022 stream nextPut: $(. 196023 #(name message id date time author) 196024 do: [:sel | 196025 stream nextPutAll: sel. 196026 stream nextPut: $ . 196027 ((aVersionInfo perform: sel) ifNil: ['']) asString printOn: stream. 196028 stream nextPut: $ ]. 196029 stream nextPutAll: 'ancestors ('. 196030 aVersionInfo ancestors do: [:ea | self writeVersionInfo: ea]. 196031 stream nextPutAll: ') stepChildren ('. 196032 aVersionInfo stepChildren do: [:ea | self writeVersionInfo: ea]. 196033 stream nextPutAll: '))'. 196034 self wrote: aVersionInfo! ! 196035 196036!MCVersionInfoWriter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196037written 196038 ^ written ifNil: [written := Set new]! ! 196039 196040!MCVersionInfoWriter methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 21:10'! 196041wrote: aVersionInfo 196042 self written add: aVersionInfo! ! 196043 196044"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 196045 196046MCVersionInfoWriter class 196047 instanceVariableNames: ''! 196048MCTool subclass: #MCVersionInspector 196049 instanceVariableNames: 'version' 196050 classVariableNames: '' 196051 poolDictionaries: '' 196052 category: 'MonticelloGUI'! 196053 196054!MCVersionInspector methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 2/3/2009 13:18'! 196055viewChanges: patch 196056 "Open a patch morph for the changes." 196057 196058 |title| 196059 title := 'Changes from {1}' format: {self version info name}. 196060 Preferences useNewDiffToolsForMC 196061 ifTrue: [((PSMCPatchMorph forPatch: patch) newWindow) 196062 title: title; 196063 open] 196064 ifFalse: [(MCPatchBrowser forPatch: self version changes) 196065 showLabelled: title]! ! 196066 196067 196068!MCVersionInspector methodsFor: '*Polymorph-Tools-Diff-override' stamp: 'gvc 2/3/2009 13:23'! 196069changes 196070 "Open a patch morph for the changes." 196071 196072 self viewChanges: (self version package snapshot patchRelativeToBase: self version snapshot)! ! 196073 196074 196075!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:19'! 196076adopt 196077 (self confirm: 196078'Modifying ancestry can be dangerous unless you know 196079what you are doing. Are you sure you want to adopt 196080',self version info name, ' as an ancestor of your working copy?') 196081 ifTrue: [self version adopt]! ! 196082 196083!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'bf 3/22/2005 22:12'! 196084browse 196085 self version browse! ! 196086 196087!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 196088diff 196089 | ancestorVersion | 196090 self pickAncestor ifNotNil: 196091 [:ancestor | 196092 ancestorVersion := self version workingCopy repositoryGroup versionWithInfo: ancestor. 196093 (self version asDiffAgainst: ancestorVersion) open]! ! 196094 196095!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'lr 9/26/2003 20:15'! 196096hasVersion 196097 ^version notNil! ! 196098 196099!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 17:14'! 196100history 196101 (MCVersionHistoryBrowser new ancestry: self versionInfo) show! ! 196102 196103!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'bf 3/14/2005 15:32'! 196104load 196105 Cursor wait showWhile: [self version load]! ! 196106 196107!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:19'! 196108merge 196109 self version merge! ! 196110 196111!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 196112save 196113 self pickRepository ifNotNil: 196114 [:ea | 196115 ea storeVersion: self version]! ! 196116 196117!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 17:16'! 196118summary 196119 ^self hasVersion 196120 ifTrue: [ self versionSummary ] 196121 ifFalse: [ String new ]! ! 196122 196123!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:19'! 196124version 196125 ^ version! ! 196126 196127!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 17:16'! 196128versionInfo 196129 ^ self version info! ! 196130 196131!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 17:16'! 196132versionSummary 196133 ^ self version summary! ! 196134 196135!MCVersionInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196136version: aVersion 196137 version := aVersion! ! 196138 196139 196140!MCVersionInspector methodsFor: 'morphic ui' stamp: 'Rik 12/17/2004 19614106:07'! 196142buttonSpecs 196143 ^ #((Browse browse 'Browse this version' hasVersion) 196144 (History history 'Browse the history of this version' hasVersion) 196145 (Changes changes 'Browse the changes this version would make to the 196146image' hasVersion) 196147 (Load load 'Load this version into the image' hasVersion) 196148 (Merge merge 'Merge this version into the image' hasVersion) 196149 (Adopt adopt 'Adopt this version as an ancestor of your working copy' 196150hasVersion) 196151 (Copy save 'Copy this version to another repository' hasVersion) 196152 (Diff diff 'Create an equivalent version based on an earlier release' 196153hasVersion))! ! 196154 196155!MCVersionInspector methodsFor: 'morphic ui' stamp: 'avi 8/31/2003 00:45'! 196156defaultExtent 196157 ^ 400@200! ! 196158 196159!MCVersionInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:18'! 196160defaultLabel 196161 ^ 'Version: ', self version info name! ! 196162 196163!MCVersionInspector methodsFor: 'morphic ui' stamp: 'ar 8/6/2009 18:25'! 196164pickAncestor 196165 | index versions | 196166 versions := self version info breadthFirstAncestors. 196167 index := UIManager default chooseFrom: (versions collect: [:ea | ea name]) 196168 title: 'Ancestor:'. 196169 ^ index = 0 ifFalse: [versions at: index]! ! 196170 196171!MCVersionInspector methodsFor: 'morphic ui' stamp: 'ar 8/6/2009 18:25'! 196172pickRepository 196173 | index | 196174 index := UIManager default chooseFrom: (self repositories collect: [:ea | ea description]) 196175 title: 'Repository:'. 196176 ^ index = 0 ifFalse: [self repositories at: index]! ! 196177 196178!MCVersionInspector methodsFor: 'morphic ui' stamp: 'avi 8/31/2003 00:44'! 196179repositories 196180 ^ MCRepositoryGroup default repositories! ! 196181 196182!MCVersionInspector methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 18:43'! 196183widgetSpecs 196184 ^ #( 196185 ((buttonRow) (0 0 1 0) (0 0 0 30)) 196186 ((textMorph: summary) (0 0 1 1) (0 30 0 0)) 196187 )! ! 196188 196189"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 196190 196191MCVersionInspector class 196192 instanceVariableNames: ''! 196193Object subclass: #MCVersionLoader 196194 instanceVariableNames: 'versions' 196195 classVariableNames: '' 196196 poolDictionaries: '' 196197 category: 'Monticello-Loading'! 196198 196199!MCVersionLoader methodsFor: '*scriptloader' stamp: 'sd 3/16/2008 08:53'! 196200hasVersions 196201 196202 ^ versions isEmpty not! ! 196203 196204 196205!MCVersionLoader methodsFor: 'checking' stamp: 'stephaneducasse 2/4/2006 20:47'! 196206checkForModifications 196207 | modifications | 196208 modifications := versions select: [:ea | ea package workingCopy modified]. 196209 modifications isEmpty ifFalse: [self warnAboutLosingChangesTo: modifications].! ! 196210 196211!MCVersionLoader methodsFor: 'checking' stamp: 'cwp 11/7/2004 17:00'! 196212checkIfDepIsOlder: aDependency 196213 ^ aDependency isOlder not 196214 or: [self confirm: 'load older dependency ', aDependency versionInfo name , '?']! ! 196215 196216!MCVersionLoader methodsFor: 'checking' stamp: 'cwp 11/7/2004 17:06'! 196217confirmMissingDependency: aDependency 196218 | name | 196219 name := aDependency versionInfo name. 196220 (self confirm: 'Can''t find dependency ', name, '. ignore?') 196221 ifFalse: [self error: 'Can''t find dependency ', name]! ! 196222 196223!MCVersionLoader methodsFor: 'checking' stamp: 'cwp 11/7/2004 17:02'! 196224depAgeIsOk: aDependency 196225 ^ aDependency isOlder not 196226 or: [self confirm: 'load older dependency ', aDependency versionInfo name , '?']! ! 196227 196228!MCVersionLoader methodsFor: 'checking' stamp: 'avi 1/24/2004 20:17'! 196229warnAboutLosingChangesTo: versionCollection 196230 self notify: (String streamContents: [:s | 196231 s nextPutAll: 'You are about to load new versions of the following packages that have unsaved changes in the image. If you continue, you will lose these changes.'; cr. 196232 versionCollection do: 196233 [:ea | 196234 s cr; space; space; nextPutAll: ea package name]])! ! 196235 196236 196237!MCVersionLoader methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:04'! 196238initialize 196239 super initialize. 196240 versions := OrderedCollection new! ! 196241 196242 196243!MCVersionLoader methodsFor: 'loading' stamp: 'cwp 11/7/2004 17:06'! 196244addDependency: aDependency 196245 | dep | 196246 aDependency isCurrent ifTrue: [^ self]. 196247 (self depAgeIsOk: aDependency) ifFalse: [^ self]. 196248 dep := aDependency resolve. 196249 dep 196250 ifNil: [self confirmMissingDependency: aDependency] 196251 ifNotNil: [(versions includes: dep) ifFalse: [self addVersion: dep]]! ! 196252 196253!MCVersionLoader methodsFor: 'loading' stamp: 'cwp 11/7/2004 17:04'! 196254addVersion: aVersion 196255 aVersion dependencies do: [ :ea | self addDependency: ea]. 196256 versions add: aVersion. 196257! ! 196258 196259!MCVersionLoader methodsFor: 'loading' stamp: 'bf 3/16/2006 19:03'! 196260load 196261 self loadWithNameLike: versions first info name. 196262! ! 196263 196264!MCVersionLoader methodsFor: 'loading' stamp: 'bf 3/17/2006 15:38'! 196265loadWithNameLike: aString 196266 | loader | 196267 self checkForModifications. 196268 loader := versions size > 1 196269 ifTrue: [MCMultiPackageLoader new] 196270 ifFalse: [MCPackageLoader new]. 196271 versions do: [:ea | 196272 ea canOptimizeLoading 196273 ifTrue: [ea patch applyTo: loader] 196274 ifFalse: [loader updatePackage: ea package withSnapshot: ea snapshot]]. 196275 loader loadWithNameLike: aString. 196276 versions do: [:ea | ea workingCopy loaded: ea]! ! 196277 196278 196279!MCVersionLoader methodsFor: '*gofer' stamp: 'dkh 10/12/2009 12:54'! 196280goferHasVersions 196281 196282 ^ versions isEmpty not! ! 196283 196284"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 196285 196286MCVersionLoader class 196287 instanceVariableNames: ''! 196288 196289!MCVersionLoader class methodsFor: 'as yet unclassified' stamp: 'avi 1/24/2004 20:06'! 196290loadVersion: aVersion 196291 self new 196292 addVersion: aVersion; 196293 load! ! 196294Object subclass: #MCVersionMerger 196295 instanceVariableNames: 'records merger' 196296 classVariableNames: '' 196297 poolDictionaries: '' 196298 category: 'Monticello-Versioning'! 196299 196300!MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196301addVersion: aVersion 196302 | dep | 196303 records add: (MCMergeRecord version: aVersion). 196304 aVersion dependencies do: 196305 [:ea | 196306 dep := ea resolve. 196307 (records anySatisfy: [:r | r version = dep]) ifFalse: [self addVersion: dep]]! ! 196308 196309!MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:04'! 196310initialize 196311 super initialize. 196312 records := OrderedCollection new. 196313 merger := MCThreeWayMerger new.! ! 196314 196315!MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'abc 2/13/2004 17:15'! 196316merge 196317 records do: [:ea | merger addBaseSnapshot: ea packageSnapshot]. 196318 records do: [:ea | merger applyPatch: ea mergePatch]. 196319 self resolveConflicts ifTrue: 196320 [merger load. 196321 records do: [:ea | ea updateWorkingCopy]].! ! 196322 196323!MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'bf 12/5/2004 12:32'! 196324mergeWithNameLike: baseName 196325 records do: [:ea | merger addBaseSnapshot: ea packageSnapshot]. 196326 records do: [:ea | merger applyPatch: ea mergePatch]. 196327 self resolveConflicts ifTrue: 196328 [merger loadWithNameLike: baseName. 196329 records do: [:ea | ea updateWorkingCopy]].! ! 196330 196331!MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'bf 4/26/2005 14:29'! 196332resolveConflicts 196333 (records allSatisfy: [:ea | ea isAncestorMerge]) ifTrue: [MCNoChangesException signal. ^ false]. 196334 ^ ((MCMergeResolutionRequest new merger: merger) 196335 signal: 'Merging ', records first version info name) = true! ! 196336 196337"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 196338 196339MCVersionMerger class 196340 instanceVariableNames: ''! 196341 196342!MCVersionMerger class methodsFor: 'as yet unclassified' stamp: 'bf 12/5/2004 12:35'! 196343mergeVersion: aVersion 196344 self new 196345 addVersion: aVersion; 196346 mergeWithNameLike: aVersion info name! ! 196347Notification subclass: #MCVersionNameAndMessageRequest 196348 instanceVariableNames: 'suggestion suggestedLogComment' 196349 classVariableNames: '' 196350 poolDictionaries: '' 196351 category: 'Monticello-Versioning'! 196352 196353!MCVersionNameAndMessageRequest methodsFor: '*MonticelloGUI' stamp: 'AndrewBlack 9/4/2009 14:11'! 196354defaultAction 196355 ^ MCSaveVersionDialog new 196356 versionName: suggestion; 196357 logMessage: suggestedLogComment; 196358 showModally! ! 196359 196360 196361!MCVersionNameAndMessageRequest methodsFor: 'as yet unclassified' stamp: 'AndrewBlack 9/4/2009 14:16'! 196362suggestedLogComment 196363 196364 ^ suggestedLogComment! ! 196365 196366!MCVersionNameAndMessageRequest methodsFor: 'as yet unclassified' stamp: 'AndrewBlack 9/4/2009 14:16'! 196367suggestedLogComment: aLogMessage 196368 196369 suggestedLogComment := aLogMessage! ! 196370 196371!MCVersionNameAndMessageRequest methodsFor: 'as yet unclassified' stamp: 'ab 7/10/2003 01:07'! 196372suggestedName 196373 ^ suggestion! ! 196374 196375!MCVersionNameAndMessageRequest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196376suggestedName: aString 196377 suggestion := aString! ! 196378Object subclass: #MCVersionNotification 196379 instanceVariableNames: 'version ancestor repository changes' 196380 classVariableNames: '' 196381 poolDictionaries: '' 196382 category: 'Monticello-Repositories'! 196383 196384!MCVersionNotification methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 15:13'! 196385fromAddress 196386 ^ 'monticello@beta4.com'! ! 196387 196388!MCVersionNotification methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196389initializeWithVersion: aVersion repository: aRepository 196390 version := aVersion. 196391 repository := aRepository. 196392 ancestor := repository closestAncestorVersionFor: version info ifNone: []. 196393 changes := ancestor 196394 ifNil: [#()] 196395 ifNotNil: [(version snapshot patchRelativeToBase: ancestor snapshot) operations asSortedCollection]! ! 196396 196397!MCVersionNotification methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 15:12'! 196398messageText 196399 ^ String streamContents: 196400 [:s | 196401 s nextPutAll: 'Committed to repository: ', repository description; cr; cr. 196402 s nextPutAll: version summary. 196403 changes isEmpty ifFalse: 196404 [s cr; cr. 196405 s nextPutAll: '-----------------------------------------------------'; cr. 196406 s nextPutAll: 'Changes since ', ancestor info name, ':'; cr. 196407 changes do: 196408 [:ea | 196409 s cr; nextPutAll: ea summary; cr. 196410 s nextPutAll: ea sourceString]]]! ! 196411 196412!MCVersionNotification methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196413messageTo: aString 196414 | message | 196415 message := MailMessage empty. 196416 message setField: 'from' toString: self fromAddress. 196417 message setField: 'to' toString: aString. 196418 message setField: 'subject' toString: '[MC] ', version info name. 196419 message body: (MIMEDocument contentType: 'text/plain' content: self messageText). 196420 ^ message! ! 196421 196422!MCVersionNotification methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196423notify: aString 196424 | message | 196425 message := self messageTo: aString. 196426 SMTPClient 196427 deliverMailFrom: message from 196428 to: (Array with: message to) 196429 text: message text 196430 usingServer: MailSender smtpServer! ! 196431 196432"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 196433 196434MCVersionNotification class 196435 instanceVariableNames: ''! 196436 196437!MCVersionNotification class methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:27'! 196438version: aVersion repository: aRepository 196439 ^ self basicNew initializeWithVersion: aVersion repository: aRepository! ! 196440MCReader subclass: #MCVersionReader 196441 instanceVariableNames: 'package info definitions dependencies stepChildren' 196442 classVariableNames: '' 196443 poolDictionaries: '' 196444 category: 'Monticello-Storing'! 196445 196446!MCVersionReader methodsFor: 'accessing' stamp: 'avi 1/19/2004 16:52'! 196447basicVersion 196448 ^ MCVersion 196449 package: self package 196450 info: self info 196451 snapshot: self snapshot 196452 dependencies: self dependencies! ! 196453 196454!MCVersionReader methodsFor: 'accessing' stamp: 'avi 1/21/2004 23:10'! 196455definitions 196456 definitions ifNil: [self loadDefinitions]. 196457 ^ definitions! ! 196458 196459!MCVersionReader methodsFor: 'accessing' stamp: 'avi 1/19/2004 14:50'! 196460dependencies 196461 dependencies ifNil: [self loadDependencies]. 196462 ^ dependencies! ! 196463 196464!MCVersionReader methodsFor: 'accessing' stamp: 'ab 8/20/2003 19:53'! 196465info 196466 info ifNil: [self loadVersionInfo]. 196467 ^ info! ! 196468 196469!MCVersionReader methodsFor: 'accessing' stamp: 'ab 8/20/2003 19:53'! 196470package 196471 package ifNil: [self loadPackage]. 196472 ^ package! ! 196473 196474!MCVersionReader methodsFor: 'accessing' stamp: 'ab 8/20/2003 19:54'! 196475snapshot 196476 ^ MCSnapshot fromDefinitions: self definitions! ! 196477 196478!MCVersionReader methodsFor: 'accessing' stamp: 'avi 10/9/2003 12:38'! 196479version 196480 ^ self basicVersion! ! 196481 196482 196483!MCVersionReader methodsFor: 'loading' stamp: 'ab 8/20/2003 19:54'! 196484loadDefinitions 196485 self subclassResponsibility ! ! 196486 196487!MCVersionReader methodsFor: 'loading' stamp: 'avi 1/19/2004 14:50'! 196488loadDependencies 196489 self subclassResponsibility ! ! 196490 196491!MCVersionReader methodsFor: 'loading' stamp: 'ab 8/20/2003 19:54'! 196492loadPackage 196493 self subclassResponsibility ! ! 196494 196495!MCVersionReader methodsFor: 'loading' stamp: 'ab 8/20/2003 19:54'! 196496loadVersionInfo 196497 self subclassResponsibility! ! 196498 196499"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 196500 196501MCVersionReader class 196502 instanceVariableNames: ''! 196503 196504!MCVersionReader class methodsFor: '*monticello-file services' stamp: 'stephaneducasse 2/4/2006 20:47'! 196505loadVersionStream: stream fromDirectory: directory 196506 | version | 196507 version := self versionFromStream: stream. 196508 directory isRemoteDirectory ifFalse: [ 196509 version workingCopy repositoryGroup addRepository: 196510 (MCDirectoryRepository new directory: directory). ]. 196511 version load. 196512! ! 196513 196514!MCVersionReader class methodsFor: '*monticello-file services' stamp: 'nk 2/25/2005 11:17'! 196515mergeVersionStream: stream 196516 (self versionFromStream: stream) merge! ! 196517 196518!MCVersionReader class methodsFor: '*monticello-file services' stamp: 'nk 2/25/2005 11:12'! 196519openVersionFromStream: stream 196520 (self versionFromStream: stream) open! ! 196521 196522 196523!MCVersionReader class methodsFor: '*monticello-file services-override-override' stamp: 'nk 2/25/2005 11:15'! 196524serviceLoadVersion 196525 ^ (SimpleServiceEntry 196526 provider: self 196527 label: 'load version' 196528 selector: #loadVersionStream:fromDirectory: 196529 description: 'load a package version' 196530 buttonLabel: 'load') 196531 argumentGetter: [ :fileList | { fileList readOnlyStream . fileList directory } ]! ! 196532 196533!MCVersionReader class methodsFor: '*monticello-file services-override-override' stamp: 'nk 2/25/2005 11:16'! 196534serviceMergeVersion 196535 ^ (SimpleServiceEntry 196536 provider: self 196537 label: 'merge version' 196538 selector: #mergeVersionStream: 196539 description: 'merge a package version into the image' 196540 buttonLabel: 'merge') 196541 argumentGetter: [ :fileList | fileList readOnlyStream ]! ! 196542 196543!MCVersionReader class methodsFor: '*monticello-file services-override-override' stamp: 'nk 2/25/2005 11:16'! 196544serviceOpenVersion 196545 ^ (SimpleServiceEntry 196546 provider: self 196547 label: 'open version' 196548 selector: #openVersionFromStream: 196549 description: 'open a package version' 196550 buttonLabel: 'open') 196551 argumentGetter: [ :fileList | fileList readOnlyStream ]! ! 196552 196553 196554!MCVersionReader class methodsFor: 'file services' stamp: 'avi 10/15/2003 02:01'! 196555fileReaderServicesForFile: fullName suffix: suffix 196556 self isAbstract ifTrue: [^ #()]. 196557 ^ ((suffix = self extension) or: [ suffix = '*' ]) 196558 ifTrue: [self services] 196559 ifFalse: [Array new: 0] 196560 ! ! 196561 196562!MCVersionReader class methodsFor: 'file services' stamp: 'avi 1/24/2004 19:01'! 196563initialize 196564 "MCVersionReader initialize" 196565 Smalltalk 196566 at: #MczInstaller 196567 ifPresent: [:installer | FileList unregisterFileReader: installer]. 196568 self concreteSubclasses do: [:aClass | FileList registerFileReader: aClass]. 196569 196570 "get rid of AnObsoleteMCMcReader and AnObsoleteMCMcvReader" 196571 (FileList registeredFileReaderClasses select: [ :ea | ea isObsolete ]) do: 196572 [ :ea | FileList unregisterFileReader: ea ] 196573! ! 196574 196575!MCVersionReader class methodsFor: 'file services' stamp: 'stephaneducasse 2/4/2006 20:47'! 196576loadVersionFile: fileName 196577 | version | 196578 version := self versionFromFile: fileName. 196579 version workingCopy repositoryGroup addRepository: 196580 (MCDirectoryRepository new directory: 196581 (FileDirectory on: (FileDirectory dirPathFor: fileName))). 196582 version load. 196583! ! 196584 196585!MCVersionReader class methodsFor: 'file services' stamp: 'cwp 8/1/2003 14:46'! 196586mergeVersionFile: fileName 196587 (self versionFromFile: fileName) merge! ! 196588 196589!MCVersionReader class methodsFor: 'file services' stamp: 'cwp 8/1/2003 14:46'! 196590openVersionFile: fileName 196591 (self versionFromFile: fileName) open! ! 196592 196593!MCVersionReader class methodsFor: 'file services' stamp: 'avi 1/21/2004 22:55'! 196594services 196595 ^ Array 196596 with: self serviceLoadVersion 196597 with: self serviceMergeVersion 196598 with: self serviceOpenVersion! ! 196599 196600!MCVersionReader class methodsFor: 'file services' stamp: 'cwp 8/1/2003 14:33'! 196601unload 196602 FileList unregisterFileReader: self ! ! 196603 196604 196605!MCVersionReader class methodsFor: 'reading' stamp: 'stephaneducasse 2/4/2006 20:47'! 196606file: fileName streamDo: aBlock 196607 | file | 196608 ^ [file := FileStream readOnlyFileNamed: fileName. 196609 aBlock value: file] 196610 ensure: [file close]! ! 196611 196612!MCVersionReader class methodsFor: 'reading' stamp: 'bf 3/23/2005 01:20'! 196613on: s fileName: f 196614 ^ self on: s! ! 196615 196616!MCVersionReader class methodsFor: 'reading' stamp: 'cwp 7/31/2003 23:03'! 196617versionFromFile: fileName 196618 ^ self file: fileName streamDo: [:stream | self versionFromStream: stream]! ! 196619 196620!MCVersionReader class methodsFor: 'reading' stamp: 'avi 1/21/2004 22:58'! 196621versionFromStream: aStream 196622 ^ (self on: aStream) version! ! 196623 196624!MCVersionReader class methodsFor: 'reading' stamp: 'avi 1/21/2004 22:59'! 196625versionInfoFromStream: aStream 196626 ^ (self on: aStream) info! ! 196627Object subclass: #MCVersionSorter 196628 instanceVariableNames: 'layers depthIndex depths stepparents roots' 196629 classVariableNames: '' 196630 poolDictionaries: '' 196631 category: 'Monticello-Versioning'! 196632 196633!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 14:19'! 196634addAllAncestorsOf: aVersionInfo to: aSet 196635 (aSet includes: aVersionInfo) ifTrue: [^ self]. 196636 aSet add: aVersionInfo. 196637 (self knownAncestorsOf: aVersionInfo) do: 196638 [:ea | 196639 self addAllAncestorsOf: ea to: aSet]! ! 196640 196641!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 8/31/2003 21:30'! 196642addAllVersionInfos: aCollection 196643 aCollection do: [:ea | self addVersionInfo: ea]! ! 196644 196645!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196646addToCurrentLayer: aVersionInfo 196647 | layer | 196648 layer := layers at: depthIndex. 196649 (layer includes: aVersionInfo) ifFalse: 196650 [depths at: aVersionInfo ifPresent: 196651 [:i | 196652 i < depthIndex 196653 ifTrue: [(layers at: i) remove: aVersionInfo] 196654 ifFalse: [^ false]]. 196655 layer add: aVersionInfo. 196656 depths at: aVersionInfo put: depthIndex. 196657 ^ true]. 196658 ^ false ! ! 196659 196660!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 10:49'! 196661addVersionInfo: aVersionInfo 196662 roots add: aVersionInfo. 196663 self registerStepChildrenOf: aVersionInfo seen: Set new! ! 196664 196665!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196666allAncestorsOf: aVersionInfo 196667 | all | 196668 all := Set new. 196669 self addAllAncestorsOf: aVersionInfo to: all. 196670 ^ all! ! 196671 196672!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:04'! 196673initialize 196674 super initialize. 196675 stepparents := Dictionary new. 196676 roots := OrderedCollection new.! ! 196677 196678!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 14:37'! 196679knownAncestorsOf: aVersionInfo 196680 ^ aVersionInfo ancestors, (self stepParentsOf: aVersionInfo) asArray! ! 196681 196682!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'ab 8/17/2003 15:53'! 196683layers 196684 ^ layers! ! 196685 196686!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196687popLayer 196688 depthIndex := depthIndex - 1! ! 196689 196690!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 10:39'! 196691processVersionInfo: aVersionInfo 196692 (self addToCurrentLayer: aVersionInfo) ifTrue: 196693 [self pushLayer. 196694 (self knownAncestorsOf: aVersionInfo) do: [:ea | self processVersionInfo: ea]. 196695 self popLayer] 196696! ! 196697 196698!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196699pushLayer 196700 depthIndex := depthIndex + 1. 196701 depthIndex > layers size ifTrue: [layers add: OrderedCollection new]. 196702 ! ! 196703 196704!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 14:34'! 196705registerStepChildrenOf: aVersionInfo seen: aSet 196706 (aSet includes: aVersionInfo) ifTrue: [^ self]. 196707 aSet add: aVersionInfo. 196708 aVersionInfo stepChildren do: [:ea | (self stepParentsOf: ea) add: aVersionInfo]. 196709 aVersionInfo ancestors do: [:ea | self registerStepChildrenOf: ea seen: aSet].! ! 196710 196711!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196712sortedVersionInfos 196713 layers := OrderedCollection with: OrderedCollection new. 196714 depthIndex := 1. 196715 depths := Dictionary new. 196716 roots do: [:ea | self processVersionInfo: ea]. 196717 ^ layers gather: [:ea | ea]! ! 196718 196719!MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 10:40'! 196720stepParentsOf: aVersionInfo 196721 ^ (stepparents at: aVersionInfo ifAbsentPut: [Set new])! ! 196722 196723"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 196724 196725MCVersionSorter class 196726 instanceVariableNames: ''! 196727MCTestCase subclass: #MCVersionTest 196728 instanceVariableNames: 'version visited' 196729 classVariableNames: '' 196730 poolDictionaries: '' 196731 category: 'Tests-Monticello'! 196732 196733!MCVersionTest methodsFor: 'asserting' stamp: 'cwp 11/7/2004 14:32'! 196734assert: aSelector orders: sexpr as: array 196735 | expected | 196736 expected := OrderedCollection new. 196737 version := self versionFromTree: sexpr. 196738 version perform: aSelector with: [:ea | expected add: ea info name]. 196739 self assert: expected asArray = array! ! 196740 196741!MCVersionTest methodsFor: 'asserting' stamp: 'md 9/6/2005 18:41'! 196742assert: aSelector orders: sexpr as: expected unresolved: unresolved 196743 | missing | 196744 missing := OrderedCollection new. 196745 version := self versionFromTree: sexpr. 196746 version 196747 perform: aSelector 196748 with: [:ea | visited add: ea info name] 196749 with: [:ea | missing add: ea name]. 196750 self assert: visited asArray = expected. 196751 self assert: missing asArray = unresolved.! ! 196752 196753 196754!MCVersionTest methodsFor: 'building' stamp: 'cwp 11/7/2004 12:29'! 196755dependencyFromTree: sexpr 196756 ^ MCMockDependency fromTree: sexpr! ! 196757 196758!MCVersionTest methodsFor: 'building' stamp: 'cwp 11/7/2004 12:40'! 196759versionFromTree: sexpr 196760 ^ (self dependencyFromTree: sexpr) resolve! ! 196761 196762 196763!MCVersionTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! 196764setUp 196765 visited := OrderedCollection new.! ! 196766 196767 196768!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:53'! 196769testAllAvailablePostOrder 196770 self 196771 assert: #allAvailableDependenciesDo: 196772 orders: #(a ((b (d e)) c)) 196773 as: #(d e b c)! ! 196774 196775!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:50'! 196776testAllMissing 196777 self 196778 assert: #allDependenciesDo: 196779 orders: #(a ((b (d e)) (c missing))) 196780 as: #(d e b)! ! 196781 196782!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:47'! 196783testAllUnresolved 196784 self 196785 assert: #allDependenciesDo:ifUnresolved: 196786 orders: #(a ((b (d e)) (c missing))) 196787 as: #(d e b) 196788 unresolved: #(c)! ! 196789 196790!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 13:55'! 196791testDependencyOrder 196792 self 196793 assert: #allDependenciesDo: 196794 orders: #(a (b c)) 196795 as: #(b c)! ! 196796 196797!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:25'! 196798testPostOrder 196799 self 196800 assert: #allDependenciesDo: 196801 orders: #(a ((b (d e)) c)) 196802 as: #(d e b c)! ! 196803 196804!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:22'! 196805testWithAll 196806 self 196807 assert: #withAllDependenciesDo: 196808 orders: #(a ((b (d e)) c)) 196809 as: #(d e b c a)! ! 196810 196811!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:56'! 196812testWithAllMissing 196813 self 196814 assert: #withAllDependenciesDo: 196815 orders: #(a ((b (d e)) (c missing))) 196816 as: #(d e b a)! ! 196817 196818!MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:29'! 196819testWithAllUnresolved 196820 self 196821 assert: #withAllDependenciesDo:ifUnresolved: 196822 orders: #(a ((b (d e)) (c missing))) 196823 as: #(d e b a) 196824 unresolved: #(c)! ! 196825MCAncestry subclass: #MCWorkingAncestry 196826 instanceVariableNames: '' 196827 classVariableNames: '' 196828 poolDictionaries: '' 196829 category: 'Monticello-Versioning'! 196830!MCWorkingAncestry commentStamp: '<historical>' prior: 0! 196831The interim record of ancestry for a working copy, gets merged version added to the ancestry, and is used to create the VersionInfo when the working copy becomes a version. ! 196832 196833 196834!MCWorkingAncestry methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196835addAncestor: aNode 196836 ancestors := (self ancestors reject: [:each | aNode hasAncestor: each]) 196837 copyWith: aNode! ! 196838 196839!MCWorkingAncestry methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 196840addStepChild: aVersionInfo 196841 stepChildren := stepChildren copyWith: aVersionInfo! ! 196842 196843!MCWorkingAncestry methodsFor: 'as yet unclassified' stamp: 'MiguelCoba 7/25/2009 02:01'! 196844infoWithName: nameString message: messageString 196845 ^ MCVersionInfo 196846 name: nameString 196847 id: UUID new 196848 message: messageString 196849 date: Date today 196850 time: Time now 196851 author: Author fullName 196852 ancestors: ancestors asArray 196853 stepChildren: self stepChildren asArray! ! 196854 196855!MCWorkingAncestry methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:14'! 196856name 196857 ^ '<working copy>'! ! 196858 196859!MCWorkingAncestry methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:14'! 196860summary 196861 ^ 'Ancestors: ', self ancestorString! ! 196862 196863"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 196864 196865MCWorkingAncestry class 196866 instanceVariableNames: ''! 196867MCPackageManager subclass: #MCWorkingCopy 196868 instanceVariableNames: 'versionInfo ancestry counter repositoryGroup requiredPackages' 196869 classVariableNames: '' 196870 poolDictionaries: '' 196871 category: 'Monticello-Versioning'! 196872 196873!MCWorkingCopy methodsFor: '*scriptloader' stamp: 'sd 3/24/2008 17:13'! 196874theCachedRepository 196875 196876 ^ MCCacheRepository default! ! 196877 196878 196879!MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:07'! 196880ancestors 196881 ^ ancestry ancestors! ! 196882 196883!MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:13'! 196884ancestry 196885 ^ ancestry! ! 196886 196887!MCWorkingCopy methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 196888clearRequiredPackages 196889 requiredPackages := nil! ! 196890 196891!MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 20:01'! 196892currentVersionInfo 196893 ^ (self needsSaving or: [ancestry ancestors isEmpty]) 196894 ifTrue: [self newVersion info] 196895 ifFalse: [ancestry ancestors first]! ! 196896 196897!MCWorkingCopy methodsFor: 'accessing' stamp: 'AndrewBlack 9/4/2009 14:00'! 196898currentVersionInfoWithMessage: aMessageString 196899 ^ (self needsSaving or: [ancestry ancestors isEmpty]) 196900 ifTrue: [(self newVersionWithMessage: aMessageString) info] 196901 ifFalse: [ancestry ancestors first]! ! 196902 196903!MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:05'! 196904description 196905 ^ self packageNameWithStar, ' (', ancestry ancestorString, ')'! ! 196906 196907!MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 20:02'! 196908needsSaving 196909 ^ self modified or: [self requiredPackages anySatisfy: [:ea | ea workingCopy needsSaving]]! ! 196910 196911!MCWorkingCopy methodsFor: 'accessing' stamp: 'stephane.ducasse 2/6/2009 18:31'! 196912removeRequiredPackage: aPackage 196913 196914 requiredPackages remove: aPackage ifAbsent: [] 196915! ! 196916 196917!MCWorkingCopy methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 196918requiredPackages 196919 ^ requiredPackages ifNil: [requiredPackages := OrderedCollection new]! ! 196920 196921!MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 1/20/2004 16:04'! 196922requirePackage: aPackage 196923 (self requiredPackages includes: aPackage) ifFalse: [requiredPackages add: aPackage]! ! 196924 196925!MCWorkingCopy methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! 196926versionInfo: aVersionInfo 196927 ancestry := MCWorkingAncestry new addAncestor: aVersionInfo! ! 196928 196929 196930!MCWorkingCopy methodsFor: 'migration' stamp: 'stephaneducasse 2/4/2006 20:47'! 196931updateInstVars 196932 ancestry ifNil: 196933 [ancestry := MCWorkingAncestry new. 196934 versionInfo ifNotNil: 196935 [versionInfo ancestors do: [:ea | ancestry addAncestor: ea]. 196936 versionInfo := nil]]! ! 196937 196938 196939!MCWorkingCopy methodsFor: 'operations' stamp: 'avi 2/13/2004 01:07'! 196940adopt: aVersion 196941 ancestry addAncestor: aVersion info. 196942 self changed.! ! 196943 196944!MCWorkingCopy methodsFor: 'operations' stamp: 'marcus.denker 11/10/2008 10:04'! 196945backportChangesTo: aVersionInfo 196946 | baseVersion fullPatch currentVersionInfo currentVersion newSnapshot newAncestry | 196947 currentVersionInfo := self currentVersionInfo. 196948 baseVersion := self repositoryGroup versionWithInfo: aVersionInfo. 196949 currentVersion := self repositoryGroup versionWithInfo: currentVersionInfo. 196950 fullPatch := currentVersion snapshot patchRelativeToBase: baseVersion snapshot. 196951 (MCChangeSelectionRequest new 196952 patch: fullPatch; 196953 label: 'Changes to Backport'; 196954 signal ) ifNotNil: 196955 [:partialPatch | 196956 newSnapshot := MCPatcher apply: partialPatch to: baseVersion snapshot. 196957 newAncestry := MCWorkingAncestry new 196958 addAncestor: aVersionInfo; 196959 addStepChild: currentVersionInfo; 196960 yourself. 196961 MCPackageLoader updatePackage: package withSnapshot: newSnapshot. 196962 ancestry := newAncestry. 196963 self modified: false; modified: true]! ! 196964 196965!MCWorkingCopy methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'! 196966changesRelativeToRepository: aRepository 196967 | ancestorVersion ancestorSnapshot | 196968 ancestorVersion := aRepository closestAncestorVersionFor: ancestry ifNone: []. 196969 ancestorSnapshot := ancestorVersion ifNil: [MCSnapshot empty] ifNotNil: [ancestorVersion snapshot]. 196970 ^ package snapshot patchRelativeToBase: ancestorSnapshot! ! 196971 196972!MCWorkingCopy methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'! 196973loaded: aVersion 196974 ancestry := MCWorkingAncestry new addAncestor: aVersion info. 196975 requiredPackages := OrderedCollection withAll: (aVersion dependencies collect: [:ea | ea package]). 196976 self modified: false. 196977 self changed! ! 196978 196979!MCWorkingCopy methodsFor: 'operations' stamp: 'abc 2/13/2004 15:57'! 196980merged: aVersion 196981 ancestry addAncestor: aVersion info. 196982 self changed! ! 196983 196984!MCWorkingCopy methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'! 196985merge: targetVersion 196986 | ancestorInfo merger ancestorSnapshot packageSnapshot | 196987 targetVersion dependencies do: [:ea | ea resolve merge]. 196988 ancestorInfo := targetVersion info commonAncestorWith: ancestry. 196989 196990 ancestorInfo = targetVersion info ifTrue: [^ MCNoChangesException signal]. 196991 196992 packageSnapshot := package snapshot. 196993 ancestorSnapshot := ancestorInfo 196994 ifNotNil: [(self findSnapshotWithVersionInfo: ancestorInfo)] 196995 ifNil: [self notifyNoCommonAncestorWith: targetVersion. MCSnapshot empty]. 196996 196997 (ancestry ancestors size = 1 196998 and: [ancestry ancestors first = ancestorInfo] 196999 and: [(packageSnapshot patchRelativeToBase: ancestorSnapshot) isEmpty]) 197000 ifTrue: [^ targetVersion load]. 197001 197002 merger := MCThreeWayMerger 197003 base: packageSnapshot 197004 target: targetVersion snapshot 197005 ancestor: ancestorSnapshot. 197006 ((MCMergeResolutionRequest new merger: merger) 197007 signal: 'Merging ', targetVersion info name) = true ifTrue: 197008 [merger loadWithNameLike: targetVersion info name. 197009 ancestry addAncestor: targetVersion info]. 197010 self changed! ! 197011 197012!MCWorkingCopy methodsFor: 'operations' stamp: 'marcus.denker 11/10/2008 10:04'! 197013newVersion 197014 ^ (self requestVersionNameAndMessageWithSuggestion: self uniqueVersionName) ifNotNil: 197015 [:pair | 197016 self newVersionWithName: pair first message: pair last]. 197017! ! 197018 197019!MCWorkingCopy methodsFor: 'operations' stamp: 'AndrewBlack 9/4/2009 14:09'! 197020newVersionWithMessage: aMessageString 197021 ^ self newVersionWithName: self uniqueVersionName message: aMessageString. 197022 197023 "^ (self requestVersionNameAndMessageWithSuggestion: self uniqueVersionName) ifNotNil: 197024 [:pair | 197025 self newVersionWithName: pair first message: aMessageString]. 197026 "! ! 197027 197028!MCWorkingCopy methodsFor: 'operations' stamp: 'AndrewBlack 9/8/2009 07:33'! 197029newVersionWithName: nameString message: messageString 197030 197031 | info deps | 197032 info := ancestry infoWithName: nameString message: messageString. 197033 ancestry := MCWorkingAncestry new addAncestor: info. 197034 self modified: true; modified: false. 197035 197036 deps := self requiredPackages collect: 197037 [:ea | 197038 MCVersionDependency 197039 package: ea 197040 info: (ea workingCopy currentVersionInfoWithMessage: messageString) ]. 197041 197042 ^ MCVersion 197043 package: package 197044 info: info 197045 snapshot: package snapshot 197046 dependencies: deps! ! 197047 197048!MCWorkingCopy methodsFor: 'operations' stamp: 'avi 2/13/2004 01:07'! 197049notifyNoCommonAncestorWith: aVersion 197050 self notify: 197051'Could not find a common ancestor between (', 197052aVersion info name, 197053') and (', 197054ancestry ancestorString, '). 197055Proceeding with this merge may cause spurious conflicts.'! ! 197056 197057!MCWorkingCopy methodsFor: 'operations' stamp: 'avi 10/5/2003 11:09'! 197058unload 197059 MCPackageLoader unloadPackage: self package. 197060 self unregister.! ! 197061 197062 197063!MCWorkingCopy methodsFor: 'printing' stamp: 'sd 3/15/2008 14:13'! 197064printOn: aStream 197065 197066 super printOn: aStream. 197067 package name ifNotNil: [ aStream nextPutAll: '(' , package name asString, ')'].! ! 197068 197069 197070!MCWorkingCopy methodsFor: 'repositories' stamp: 'stephaneducasse 2/4/2006 20:47'! 197071repositoryGroup 197072 ^ repositoryGroup ifNil: [repositoryGroup := MCRepositoryGroup new]! ! 197073 197074!MCWorkingCopy methodsFor: 'repositories' stamp: 'stephaneducasse 2/4/2006 20:47'! 197075repositoryGroup: aRepositoryGroup 197076 repositoryGroup := aRepositoryGroup! ! 197077 197078 197079!MCWorkingCopy methodsFor: 'private' stamp: 'avi 9/24/2004 12:15'! 197080findSnapshotWithVersionInfo: aVersionInfo 197081 ^ aVersionInfo 197082 ifNil: [MCSnapshot empty] 197083 ifNotNil: [(self repositoryGroup versionWithInfo: aVersionInfo) snapshot]! ! 197084 197085!MCWorkingCopy methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! 197086initialize 197087 super initialize. 197088 ancestry := MCWorkingAncestry new! ! 197089 197090!MCWorkingCopy methodsFor: 'private' stamp: 'MiguelCoba 7/25/2009 02:01'! 197091nextVersionName 197092 | branch oldName base author | 197093 branch := ''. 197094 ancestry ancestors isEmpty 197095 ifTrue: [counter ifNil: [counter := 0]. base := package name] 197096 ifFalse: 197097 [oldName := ancestry ancestors first name. 197098 oldName last isDigit 197099 ifFalse: [base := oldName] 197100 ifTrue: [ 197101 base := oldName copyUpToLast: $-. 197102 branch := ((oldName copyAfterLast: $-) copyUpToLast: $.) copyAfter: $. ]. 197103 counter ifNil: [ 197104 counter := (ancestry ancestors collect: [:each | 197105 each name last isDigit 197106 ifFalse: [0] 197107 ifTrue: [(each name copyAfterLast: $.) extractNumber]]) max]]. 197108 197109 branch isEmpty ifFalse: [branch := '.',branch]. 197110 counter := counter + 1. 197111 author := Author fullName collect: [ :each | each isAlphaNumeric ifTrue: [ each ] ifFalse: [ $_ ] ]. 197112 ^ base , '-' , author , branch , '.' , counter asString! ! 197113 197114!MCWorkingCopy methodsFor: 'private' stamp: 'bf 9/8/2005 10:58'! 197115possiblyNewerVersions 197116 197117 ^Array streamContents: [:strm | 197118 self repositoryGroup repositories do: [:repo | 197119 strm nextPutAll: (self possiblyNewerVersionsIn: repo)]]! ! 197120 197121!MCWorkingCopy methodsFor: 'private' stamp: 'bf 9/8/2005 10:58'! 197122possiblyNewerVersionsIn: aRepository 197123 197124 ^aRepository possiblyNewerVersionsOfAnyOf: self ancestors! ! 197125 197126!MCWorkingCopy methodsFor: 'private' stamp: 'ab 8/24/2003 20:38'! 197127requestVersionNameAndMessageWithSuggestion: aString 197128 ^ (MCVersionNameAndMessageRequest new suggestedName: aString) signal! ! 197129 197130!MCWorkingCopy methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! 197131uniqueVersionName 197132 |versionName| 197133 counter := nil. 197134 [versionName := self nextVersionName. 197135 self repositoryGroup includesVersionNamed: versionName] whileTrue. 197136 ^ versionName! ! 197137 197138!MCWorkingCopy methodsFor: 'private' stamp: 'avi 2/4/2004 14:11'! 197139versionSeparator 197140 ^ $_! ! 197141 197142"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 197143 197144MCWorkingCopy class 197145 instanceVariableNames: ''! 197146 197147!MCWorkingCopy class methodsFor: 'as yet unclassified' stamp: 'avi 9/13/2004 18:00'! 197148adoptVersionInfoFrom: anInstaller 197149 |viCache| 197150 viCache := Dictionary new. 197151 anInstaller versionInfo keysAndValuesDo: [:packageName :info | 197152 (self forPackage: (MCPackage named: packageName)) 197153 versionInfo: (self infoFromDictionary: info cache: viCache)]. 197154 [anInstaller clearVersionInfo] on: Error do: ["backwards compat"].! ! 197155 197156!MCWorkingCopy class methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 01:23'! 197157ancestorsFromArray: anArray cache: aDictionary 197158 ^ anArray ifNotNil: [anArray collect: [:dict | self infoFromDictionary: dict cache: aDictionary]]! ! 197159 197160!MCWorkingCopy class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 197161infoFromDictionary: aDictionary cache: cache 197162 | id | 197163 id := aDictionary at: #id. 197164 ^ cache at: id ifAbsentPut: 197165 [MCVersionInfo 197166 name: (aDictionary at: #name) 197167 id: (aDictionary at: #id) 197168 message: (aDictionary at: #message) 197169 date: (aDictionary at: #date) 197170 time: (aDictionary at: #time) 197171 author: (aDictionary at: #author) 197172 ancestors: (self ancestorsFromArray: (aDictionary at: #ancestors) cache: cache)]! ! 197173 197174!MCWorkingCopy class methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2005 02:09'! 197175initialize 197176 Smalltalk 197177 at: #MczInstaller 197178 ifPresent: [:installer | self adoptVersionInfoFrom: installer]. 197179 self updateInstVars. 197180 "Temporary conversion code -- remove later" 197181 registry ifNotNil:[registry rehash]. "changed #=" 197182 self allInstancesDo:[:each| "moved notifications" 197183 Smalltalk at: #SystemChangeNotifier ifPresent:[:cls| 197184 cls uniqueInstance noMoreNotificationsFor: each. 197185 ]. 197186 ]. 197187 self registerForNotifications.! ! 197188 197189!MCWorkingCopy class methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 02:36'! 197190updateInstVars 197191 self allInstances do: [:ea | ea updateInstVars]! ! 197192MCTool subclass: #MCWorkingCopyBrowser 197193 instanceVariableNames: 'workingCopy workingCopyWrapper repository defaults order' 197194 classVariableNames: 'Order' 197195 poolDictionaries: '' 197196 category: 'MonticelloGUI'! 197197 197198!MCWorkingCopyBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 2/3/2009 13:11'! 197199viewChanges: patch 197200 "Open a browser on the given patch." 197201 197202 Preferences useNewDiffToolsForMC 197203 ifTrue: [((PSMCPatchMorph forPatch: patch) newWindow) 197204 title: 'Changes to ', workingCopy description; 197205 open] 197206 ifFalse: [(MCPatchBrowser forPatch: patch) 197207 label: 'Patch Browser: ', workingCopy description; 197208 show]! ! 197209 197210 197211!MCWorkingCopyBrowser methodsFor: '*Polymorph-Tools-Diff-override' stamp: 'gvc 2/3/2009 13:02'! 197212viewChanges 197213 | patch | 197214 'Finding changes' displayProgressAt: Sensor cursorPoint from: 0 to: 10 during:[:bar| 197215 self canSave ifTrue:[ 197216 bar value: 1. 197217 patch := workingCopy changesRelativeToRepository: self repository]. 197218 patch isNil ifTrue: [^ self]. 197219 bar value:3. 197220 patch isEmpty 197221 ifTrue: [ workingCopy modified: false. 197222 bar value: 10. 197223 self inform: 'No changes' ] 197224 ifFalse: 197225 [ workingCopy modified: true. 197226 bar value: 5. 197227 self viewChanges: patch]]! ! 197228 197229 197230!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! 197231addRepository 197232 self newRepository ifNotNil: 197233 [:repos | self addRepository: repos ]. 197234! ! 197235 197236!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! 197237addRepositoryToPackage 197238 self repository ifNotNil: 197239 [:repos | 197240 (self pickWorkingCopySatisfying: [ :p | (p repositoryGroup includes: repos) not ]) ifNotNil: 197241 [:wc | 197242 workingCopy := wc. 197243 workingCopy repositoryGroup addRepository: repos. 197244 self repository: repos. 197245 self 197246 changed: #workingCopySelection; 197247 changed: #repositoryList; 197248 changed: #repositorySelection. 197249 self changedButtons]]! ! 197250 197251!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! 197252addRepositoryToWorkingCopy 197253 workingCopy ifNotNil: 197254 [:wc | 197255 workingCopy repositoryGroup addRepository: self repository. 197256 self 197257 changed: #workingCopySelection; 197258 changed: #repositoryList; 197259 changed: #repositorySelection. 197260 self changedButtons]! ! 197261 197262!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bf 6/21/2005 15:58'! 197263addRepository: aRepository 197264 self repository: aRepository. 197265 self repositoryGroup addRepository: aRepository. 197266 self changed: #repositoryList; changed: #repositorySelection. 197267 self changedButtons.! ! 197268 197269!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! 197270addRequiredDirtyPackage 197271 | dirtyPackages | 197272 dirtyPackages := self workingCopies select: [:copy | copy needsSaving]. 197273 197274 workingCopy ifNotNil: 197275 [:wc | 197276 dirtyPackages do: 197277 [:required | 197278 wc requirePackage: required package]]. 197279 197280 self workingCopyListChanged! ! 197281 197282!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'cwp 8/30/2009 23:00'! 197283addRequiredPackage 197284 | chosen | 197285 workingCopy ifNotNilDo: 197286 [:wc | 197287 chosen := self pickWorkingCopySatisfying: 197288 [:ea | ea ~= wc and: [(wc requiredPackages includes: ea package) not]]. 197289 chosen ifNotNil: 197290 [wc requirePackage: chosen package. 197291 self workingCopyListChanged]]! ! 197292 197293!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'alain.plantec 2/6/2009 17:52'! 197294addWorkingCopy 197295 |name| 197296 name := UIManager default request: 'Name of package:' translated. 197297 name isEmptyOrNil ifFalse: 197298 [PackageInfo registerPackageName: name. 197299 workingCopy := MCWorkingCopy forPackage: (MCPackage new name: name). 197300 workingCopyWrapper := nil. 197301 self repositorySelection: 0]. 197302 self workingCopyListChanged; changed: #workingCopySelection; changed: #repositoryList. 197303 self changedButtons.! ! 197304 197305!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! 197306backportChanges 197307 self canBackport ifFalse: [^self]. 197308 workingCopy ifNotNil: 197309 [workingCopy needsSaving ifTrue: [^ self inform: 'You must save the working copy before backporting.']. 197310 self pickAncestorVersionInfo ifNotNil: 197311 [:baseVersionInfo | 197312 workingCopy backportChangesTo: baseVersionInfo]]! ! 197313 197314!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'ab 7/19/2003 22:58'! 197315browseWorkingCopy 197316 workingCopy ifNotNil: 197317 [(MCSnapshotBrowser forSnapshot: workingCopy package snapshot) 197318 label: 'Snapshot Browser: ', workingCopy packageName; 197319 show]! ! 197320 197321!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'avi 9/14/2004 14:57'! 197322canBackport 197323 ^ self hasWorkingCopy and: [workingCopy needsSaving not]! ! 197324 197325!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! 197326checkForNewerVersions 197327 | newer | 197328 newer := workingCopy possiblyNewerVersionsIn: self repository. 197329 ^ newer isEmpty or: [ 197330 self confirm: 'CAUTION!! These versions in the repository may be newer:', 197331 String cr, newer asString, String cr, 197332 'Do you really want to save this version?'].! ! 197333 197334!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! 197335clearRequiredPackages 197336 workingCopy ifNotNil: 197337 [:wc | 197338 wc clearRequiredPackages. 197339 self workingCopyListChanged]! ! 197340 197341!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'ar 2/14/2004 02:46'! 197342deleteWorkingCopy 197343 workingCopy unregister. 197344 self workingCopySelection: 0. 197345 self workingCopyListChanged.! ! 197346 197347!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bf 4/14/2005 15:31'! 197348editRepository 197349 | newRepo | 197350 197351 newRepo := self repository openAndEditTemplateCopy. 197352 newRepo ifNotNil: [ 197353 newRepo class = self repository class 197354 ifTrue: [self repository copyFrom: newRepo] 197355 ifFalse: [self inform: 'Must not change repository type!!']] 197356! ! 197357 197358!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bf 6/3/2005 15:08'! 197359flushAllCaches 197360 | beforeBytes afterBytes beforeVersions afterVersions | 197361 Cursor wait showWhile: [ 197362 beforeBytes := Smalltalk garbageCollect. 197363 beforeVersions := MCVersion allSubInstances size. 197364 MCFileBasedRepository flushAllCaches. 197365 afterBytes := Smalltalk garbageCollect. 197366 afterVersions := MCVersion allSubInstances size. 197367 ]. 197368 ^self inform: (beforeVersions - afterVersions) asString, ' versions flushed', String cr, 197369 (afterBytes - beforeBytes) asStringWithCommas, ' bytes reclaimed'! ! 197370 197371!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'avi 9/11/2004 15:32'! 197372inspectWorkingCopy 197373 workingCopy ifNotNil: [workingCopy inspect]! ! 197374 197375!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bf 6/21/2005 15:58'! 197376loadRepositories 197377 FileStream fileIn: 'MCRepositories.st'. 197378 self changed: #repositoryList. 197379 self changedButtons. 197380! ! 197381 197382!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'ar 8/6/2009 18:25'! 197383newRepository 197384 | types index | 197385 types := MCRepository allConcreteSubclasses asArray. 197386 index := UIManager default chooseFrom: (types collect: [:ea | ea description]) 197387 title: 'Repository type:'. 197388 ^ index = 0 ifFalse: [(types at: index) morphicConfigure]! ! 197389 197390!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! 197391openRepository 197392 self repository ifNotNil: [:repos | repos morphicOpen: workingCopy ]! ! 197393 197394!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'jf 1/25/2004 14:06'! 197395recompilePackage 197396 workingCopy package packageInfo methods 197397 do: [:ea | ea actualClass recompile: ea methodSymbol] 197398 displayingProgress: 'Recompiling...'! ! 197399 197400!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! 197401removeRepository 197402 self repository ifNotNil: 197403 [:repos | 197404 self repositoryGroup removeRepository: repos. 197405 self repositorySelection: (1 min: self repositories size)]. 197406 self changed: #repositoryList. 197407 self changedButtons. 197408! ! 197409 197410!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'AndrewBlack 9/8/2009 09:29'! 197411removeRequiredPackage 197412 197413 | allRequiredPackages | 197414 workingCopy ifNil: [^ self]. 197415 allRequiredPackages := workingCopy requiredPackages. 197416 allRequiredPackages ifEmpty: [UIManager default inform: 'This package has no requirements'. ^ self]. 197417 (self pickWorkingCopySatisfying: [:wc | allRequiredPackages includes: wc package]) 197418 ifNotNil: 197419 [:required | 197420 workingCopy removeRequiredPackage: required package. 197421 self workingCopyListChanged]! ! 197422 197423!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! 197424repository 197425 workingCopy ifNotNil: [repository := self defaults at: workingCopy ifAbsent: []]. 197426 ^ repository! ! 197427 197428!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! 197429repository: aRepository 197430 repository := aRepository. 197431 workingCopy ifNotNil: [self defaults at: workingCopy put: aRepository]! ! 197432 197433!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! 197434revertPackage 197435 self pickAncestorVersionInfo ifNotNil: [:info | 197436 (self repositoryGroup versionWithInfo: info 197437 ifNone: [^self inform: 'No repository found for ', info name] 197438 ) load]! ! 197439 197440!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'avi 9/10/2004 17:46'! 197441saveRepositories 197442 | f | 197443 f := FileStream forceNewFileNamed: 'MCRepositories.st'. 197444 MCRepositoryGroup default repositoriesDo: [:r | 197445 f nextPutAll: 'MCRepositoryGroup default addRepository: (', r asCreationTemplate, ')!!'; cr.]! ! 197446 197447!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'cwp 8/30/2009 22:17'! 197448saveVersion 197449 | repo | 197450 self canSave ifFalse: [^self]. 197451 repo := self repository. 197452 workingCopy newVersion ifNotNilDo: 197453 [:v | 197454 (MCVersionInspector new version: v) show. 197455 Cursor wait showWhile: [repo storeVersion: v]. 197456 MCCacheRepository default cacheAllFileNamesDuring: 197457 [repo cacheAllFileNamesDuring: 197458 [v allAvailableDependenciesDo: 197459 [:dep | 197460 (repo includesVersionNamed: dep info name) 197461 ifFalse: [repo storeVersion: dep]]]]]! ! 197462 197463!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'ar 2/14/2004 02:46'! 197464unloadPackage 197465 workingCopy unload. 197466 self workingCopySelection: 0. 197467 self workingCopyListChanged.! ! 197468 197469!MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'avi 2/13/2004 01:13'! 197470viewHistory 197471 workingCopy ifNotNil: 197472 [(MCWorkingHistoryBrowser new 197473 ancestry: workingCopy ancestry; 197474 package: workingCopy package) 197475 label: 'Version History: ', workingCopy packageName; 197476 show]! ! 197477 197478 197479!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'Alexandre.Bergel 3/10/2009 17:08'! 197480buttonSpecs 197481 ^ #( 197482 ('+Package' addWorkingCopy 'Add a new package and make it the working copy') 197483 (Browse browseWorkingCopy 'Browse the working copy of the selected package' hasWorkingCopy) 197484 197485 (Changes viewChanges 'View the working copy''s changes relative to the installed version from the repository' canSave) 197486 (Save saveVersion 'Save the working copy as a new version to the selected repository' canSave) 197487 ('+Repository' addRepository 'Add an existing repository to the list of those visible') 197488 (Open openRepository 'Open a browser on the selected repository' hasRepository) 197489 (Scripts editLoadScripts 'Edit the load/unload scripts of this package' hasWorkingCopy) 197490 (History viewHistory 'View the working copy''s history' hasWorkingCopy) 197491 (Backport backportChanges 'Backport the working copy''s changes to an ancestor' canBackport) 197492 )! ! 197493 197494!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 8/7/2003 21:22'! 197495canSave 197496 ^ self hasWorkingCopy and: [self hasRepository]! ! 197497 197498!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'bf 6/21/2005 15:50'! 197499changedButtons 197500 self changed: #hasWorkingCopy. 197501 self changed: #canSave. 197502 self changed: #canBackport. 197503 self changed: #hasRepository. 197504! ! 197505 197506!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephane.ducasse 2/6/2009 18:17'! 197507defaultExtent 197508 ^ 580@200! ! 197509 197510!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 23:38'! 197511defaultLabel 197512 ^ 'Monticello Browser'! ! 197513 197514!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 197515defaults 197516 ^ defaults ifNil: [defaults := Dictionary new]! ! 197517 197518!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 197519editLoadScripts 197520 197521 | menu | 197522 self hasWorkingCopy ifFalse: [^self]. 197523 menu := MenuMorph new defaultTarget: self. 197524 menu add: 'edit preamble' selector: #editScript: argument: #preamble. 197525 menu add: 'edit postscript' selector: #editScript: argument: #postscript. 197526 menu add: 'edit preambleOfRemoval' selector: #editScript: argument: #preambleOfRemoval. 197527 menu add: 'edit postscriptOfRemoval' selector: #editScript: argument: #postscriptOfRemoval. 197528 menu popUpInWorld.! ! 197529 197530!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 197531editScript: scriptSymbol 197532 197533| script | 197534script := workingCopy packageInfo perform: scriptSymbol. 197535script openLabel: scriptSymbol asString, ' of the Package ', workingCopy package name.! ! 197536 197537!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/22/2003 02:21'! 197538hasRepository 197539 ^ self repository notNil! ! 197540 197541!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/22/2003 00:46'! 197542hasWorkingCopy 197543 ^ workingCopy notNil! ! 197544 197545!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephane.ducasse 6/14/2009 23:04'! 197546initialize 197547 super initialize. 197548 order := self class order. 197549 MCWorkingCopy addDependent: self. 197550 self workingCopies do: [:ea | ea addDependent: self].! ! 197551 197552!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 10/14/2008 14:25'! 197553order: anInteger 197554 self class order: (order := anInteger). 197555 self changed: #workingCopyList; changed: #workingCopyTree! ! 197556 197557!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 11/6/2008 15:11'! 197558orderSpecs 197559 ^ { 197560 'sort alphabetically' -> [ :a :b | a package name <= b package name ]. 197561 'sort dirty first' -> [ :a :b | 197562 a needsSaving = b needsSaving 197563 ifTrue: [ a package name <= b package name ] 197564 ifFalse: [ a needsSaving ] ]. 197565 'sort dirty last' -> [ :a :b | 197566 a needsSaving = b needsSaving 197567 ifTrue: [ a package name <= b package name ] 197568 ifFalse: [ b needsSaving ] ]. 197569 'only dirty' -> [ :a :b | a package name <= b package name ] 197570 }! ! 197571 197572!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 10/14/2008 14:22'! 197573orderString: anIndex 197574 ^ String streamContents: [ :stream | 197575 order = anIndex 197576 ifTrue: [ stream nextPutAll: '<yes>' ] 197577 ifFalse: [ stream nextPutAll: '<no>' ]. 197578 stream nextPutAll: (self orderSpecs at: anIndex) key ]! ! 197579 197580!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 8/6/2009 18:26'! 197581pickAncestorVersionInfo 197582 | ancestors index | 197583 ancestors := workingCopy ancestry breadthFirstAncestors. 197584 index := UIManager default chooseFrom: (ancestors collect: [:ea | ea name]) 197585 title: 'Ancestor:'. 197586 ^ index = 0 ifFalse: [ ancestors at: index]! ! 197587 197588!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'nk 3/9/2004 14:39'! 197589pickWorkingCopy 197590 ^self pickWorkingCopySatisfying: [ :c | true ]! ! 197591 197592!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 8/6/2009 18:26'! 197593pickWorkingCopySatisfying: aBlock 197594 | copies index | 197595 copies := self workingCopies select: aBlock. 197596 copies isEmpty ifTrue: [ ^nil ]. 197597 index := UIManager default chooseFrom: (copies collect: [:ea | ea packageName]) 197598 title: 'Package:'. 197599 ^ index = 0 ifFalse: [ copies at: index]! ! 197600 197601!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 8/7/2003 21:32'! 197602repositories 197603 ^ self repositoryGroup repositories! ! 197604 197605!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 8/7/2003 21:32'! 197606repositoryGroup 197607 ^ workingCopy 197608 ifNil: [MCRepositoryGroup default] 197609 ifNotNil: [workingCopy repositoryGroup]! ! 197610 197611!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 22:04'! 197612repositoryList 197613 ^ self repositories collect: [:ea | ea description]! ! 197614 197615!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'bf 6/6/2005 13:20'! 197616repositoryListMenu: aMenu 197617 self repository ifNil: [^ aMenu]. 197618 self fillMenu: aMenu fromSpecs: 197619 #(('open repository' #openRepository) 197620 ('edit repository info' #editRepository) 197621 ('add to package...' #addRepositoryToPackage) 197622 ('remove repository' #removeRepository) 197623 ('load repositories' #loadRepositories) 197624 ('save repositories' #saveRepositories) 197625 ('flush cached versions' #flushAllCaches) 197626 ). 197627 aMenu 197628 add: (self repository alwaysStoreDiffs 197629 ifTrue: ['store full versions'] 197630 ifFalse: ['store diffs']) 197631 target: self 197632 selector: #toggleDiffs. 197633 ^ aMenu 197634 ! ! 197635 197636!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/22/2003 02:22'! 197637repositorySelection 197638 ^ self repositories indexOf: self repository! ! 197639 197640!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'bf 6/21/2005 15:56'! 197641repositorySelection: aNumber 197642 aNumber = 0 197643 ifTrue: [self repository: nil] 197644 ifFalse: [self repository: (self repositories at: aNumber)]. 197645 self changed: #repositorySelection. 197646 self changedButtons. 197647! ! 197648 197649!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 8/31/2004 01:14'! 197650toggleDiffs 197651 self repository alwaysStoreDiffs 197652 ifTrue: [self repository doNotAlwaysStoreDiffs] 197653 ifFalse: [self repository doAlwaysStoreDiffs]! ! 197654 197655!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 9/10/2004 17:54'! 197656unsortedWorkingCopies 197657 ^ MCWorkingCopy allManagers ! ! 197658 197659!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 9/10/2004 17:54'! 197660update: aSymbol 197661 self unsortedWorkingCopies do: [:ea | ea addDependent: self]. 197662 self workingCopyListChanged.! ! 197663 197664!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 3/6/2005 22:30'! 197665widgetSpecs 197666 ^ #( 197667 ((buttonRow) (0 0 1 0) (0 0 0 30)) 197668 ((treeOrListMorph: workingCopy) (0 0 0.5 1) (0 30 0 0)) 197669 ((listMorph: repository) (0.5 0 1 1) (0 30 0 0)) 197670 )! ! 197671 197672!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 11/6/2008 15:13'! 197673workingCopies 197674 ^ (self orderSpecs size = order 197675 ifTrue: [ MCWorkingCopy allManagers select: [ :each | each modified ] ] 197676 ifFalse: [ MCWorkingCopy allManagers ]) 197677 asSortedCollection: (self orderSpecs at: order) value! ! 197678 197679!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 1/19/2004 16:41'! 197680workingCopyList 197681 ^ self workingCopies collect: 197682 [:ea | 197683 (workingCopy notNil and: [workingCopy requiredPackages includes: ea package]) 197684 ifTrue: [Text string: ea description emphasis: (Array with: TextEmphasis bold)] 197685 ifFalse: [ea description]]! ! 197686 197687!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'bf 6/21/2005 15:51'! 197688workingCopyListChanged 197689 self changed: #workingCopyList. 197690 self changed: #workingCopyTree. 197691 self changedButtons. 197692! ! 197693 197694!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'AndrewBlack 9/4/2009 12:12'! 197695workingCopyListMenu: aMenu 197696 workingCopy ifNil: [^ aMenu]. 197697 self fillMenu: aMenu fromSpecs: 197698 #(('add required package' #addRequiredPackage) 197699 ('remove required package' #removeRequiredPackage) 197700 ('add all dirty packages as required' #addRequiredDirtyPackage) 197701 ('clear required packages' #clearRequiredPackages) 197702 ('browse package' #browseWorkingCopy) 197703 ('view changes' #viewChanges) 197704 ('view history' #viewHistory) 197705 ('recompile package' #recompilePackage) 197706 ('revert package...' #revertPackage) 197707 ('unload package' #unloadPackage) 197708 ('delete working copy' #deleteWorkingCopy)). 197709 (Smalltalk includesKey: #SARMCPackageDumper) ifTrue: [ 197710 aMenu add: 'make SAR' target: self selector: #fileOutAsSAR 197711 ]. 197712 aMenu addLine. 197713 1 to: self orderSpecs size do: [ :index | 197714 aMenu addUpdating: #orderString: target: self selector: #order: argumentList: { index } ]. 197715 ^aMenu! ! 197716 197717!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 23:11'! 197718workingCopyListMorph 197719 ^ PluggableMultiColumnListMorph 197720 on: self 197721 list: #workingCopyList 197722 selected: #workingCopySelection 197723 changeSelected: #workingCopySelection: 197724 menu: #workingCopyListMenu:! ! 197725 197726!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 22:05'! 197727workingCopySelection 197728 ^ self workingCopies indexOf: workingCopy! ! 197729 197730!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:38'! 197731workingCopySelectionWrapper 197732 ^workingCopyWrapper! ! 197733 197734!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:57'! 197735workingCopySelectionWrapper: aWrapper 197736 workingCopyWrapper := aWrapper. 197737 self changed: #workingCopySelectionWrapper. 197738 self workingCopy: (aWrapper ifNotNil:[aWrapper item])! ! 197739 197740!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:48'! 197741workingCopySelection: aNumber 197742 self workingCopy: 197743 (aNumber = 0 197744 ifTrue:[nil] 197745 ifFalse:[self workingCopies at: aNumber]). ! ! 197746 197747!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:30'! 197748workingCopyTree 197749 ^ self workingCopies collect:[:each| MCDependentsWrapper with: each model: self].! ! 197750 197751!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 10/14/2008 14:24'! 197752workingCopyTreeMenu: aMenu 197753 ^ self workingCopyListMenu: aMenu! ! 197754 197755!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:24'! 197756workingCopyTreeMorph 197757 ^ SimpleHierarchicalListMorph 197758 on: self 197759 list: #workingCopyTree 197760 selected: #workingCopyWrapper 197761 changeSelected: #workingCopyWrapper: 197762 menu: #workingCopyListMenu:! ! 197763 197764!MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! 197765workingCopy: wc 197766 workingCopy := wc. 197767 self changed: #workingCopyList; changed: #workingCopySelection; changed: #repositoryList. 197768 self changedButtons. 197769! ! 197770 197771"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 197772 197773MCWorkingCopyBrowser class 197774 instanceVariableNames: ''! 197775 197776!MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 23:38'! 197777initialize 197778 (TheWorldMenu respondsTo: #registerOpenCommand:) 197779 ifTrue: [TheWorldMenu registerOpenCommand: {'Monticello Browser'. {self. #open}}]! ! 197780 197781!MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 23:27'! 197782open 197783 self new show! ! 197784 197785!MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'lr 10/14/2008 14:21'! 197786order 197787 ^ Order ifNil: [ Order := 1 ]! ! 197788 197789!MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'lr 10/14/2008 14:21'! 197790order: anInteger 197791 Order := anInteger! ! 197792MCTestCase subclass: #MCWorkingCopyTest 197793 instanceVariableNames: 'workingCopy repositoryGroup versions versions2 savedName' 197794 classVariableNames: '' 197795 poolDictionaries: '' 197796 category: 'Tests-Monticello'! 197797 197798!MCWorkingCopyTest methodsFor: 'accessing' stamp: 'ab 7/7/2003 18:02'! 197799description 197800 ^ self class name! ! 197801 197802 197803!MCWorkingCopyTest methodsFor: 'actions' stamp: 'avi 2/13/2004 14:30'! 197804basicMerge: aVersion 197805 aVersion merge! ! 197806 197807!MCWorkingCopyTest methodsFor: 'actions' stamp: 'avi 1/24/2004 20:13'! 197808load: aVersion 197809 aVersion load! ! 197810 197811!MCWorkingCopyTest methodsFor: 'actions' stamp: 'jf 8/21/2003 20:22'! 197812merge: aVersion 197813 [[self basicMerge: aVersion] 197814 on: MCMergeResolutionRequest do: [:n | n resume: true]] 197815 on: MCNoChangesException do: [:n | ]! ! 197816 197817!MCWorkingCopyTest methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! 197818snapshot 197819 | version | 197820 [version := workingCopy newVersion] 197821 on: MCVersionNameAndMessageRequest 197822 do: [:n | n resume: (Array with: n suggestedName with: '')]. 197823 versions at: version info put: version. 197824 ^ version! ! 197825 197826 197827!MCWorkingCopyTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! 197828assertNameWhenSavingTo: aRepository is: aString 197829 | name | 197830 name := nil. 197831 [aRepository storeVersion: workingCopy newVersion] 197832 on: MCVersionNameAndMessageRequest 197833 do: [:n | name := n suggestedName. n resume: (Array with: name with: '')]. 197834 self assert: name = aString! ! 197835 197836!MCWorkingCopyTest methodsFor: 'asserting' stamp: 'MiguelCoba 7/25/2009 02:01'! 197837assertNumberWhenSavingTo: aRepository is: aNumber 197838 | name | 197839 name := nil. 197840 [aRepository storeVersion: workingCopy newVersion] 197841 on: MCVersionNameAndMessageRequest 197842 do: [:n | name := n suggestedName. n resume: (Array with: name with: '')]. 197843 self assert: name = (self packageName, '-', Author fullName, '.', aNumber asString)! ! 197844 197845 197846!MCWorkingCopyTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! 197847clearPackageCache 197848 | dir | 197849 dir := MCCacheRepository default directory. 197850 (dir fileNamesMatching: 'MonticelloMocks*') do: [:ea | dir deleteFileNamed: ea]. 197851 (dir fileNamesMatching: 'MonticelloTest*') do: [:ea | dir deleteFileNamed: ea]. 197852 (dir fileNamesMatching: 'rev*') do: [:ea | dir deleteFileNamed: ea]. 197853 (dir fileNamesMatching: 'foo-*') do: [:ea | dir deleteFileNamed: ea]. 197854 (dir fileNamesMatching: 'foo2-*') do: [:ea | dir deleteFileNamed: ea].! ! 197855 197856!MCWorkingCopyTest methodsFor: 'running' stamp: 'MiguelCoba 7/25/2009 02:02'! 197857setUp 197858 | repos1 repos2 | 197859 self clearPackageCache. 197860 repositoryGroup := MCRepositoryGroup new. 197861 repositoryGroup disableCache. 197862 workingCopy := MCWorkingCopy forPackage: self mockPackage. 197863 versions := Dictionary new. 197864 versions2 := Dictionary new. 197865 repos1 := MCDictionaryRepository new dictionary: versions. 197866 repos2 := MCDictionaryRepository new dictionary: versions2. 197867 repositoryGroup addRepository: repos1. 197868 repositoryGroup addRepository: repos2. 197869 MCRepositoryGroup default removeRepository: repos1; removeRepository: repos2. 197870 workingCopy repositoryGroup: repositoryGroup. 197871 savedName := Author fullName. 197872 Author fullName: 'abc'.! ! 197873 197874!MCWorkingCopyTest methodsFor: 'running' stamp: 'MiguelCoba 7/25/2009 02:03'! 197875tearDown 197876 workingCopy unregister. 197877 self restoreMocks. 197878 self clearPackageCache. 197879 Author fullName: savedName.! ! 197880 197881 197882!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 197883testAncestorMerge 197884 | base revA revB revC | 197885 197886 base := self snapshot. 197887 self change: #a toReturn: 'a1'. 197888 revA := self snapshot. 197889 self change: #b toReturn: 'b1'. 197890 revB := self snapshot. 197891 self change: #c toReturn: 'c1'. 197892 revC := self snapshot. 197893 197894 self should: [self basicMerge: revA] raise: MCNoChangesException. 197895 ! ! 197896 197897!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 197898testBackport 197899 | inst base final backported | 197900 inst := self mockInstanceA. 197901 base := self snapshot. 197902 self assert: inst one = 1. 197903 self change: #one toReturn: 2. 197904 self change: #two toReturn: 3. 197905 final := self snapshot. 197906 [workingCopy backportChangesTo: base info] 197907 on: MCChangeSelectionRequest 197908 do: [:e | e resume: e patch]. 197909 self assert: inst one = 2. 197910 self assert: inst two = 3. 197911 self assert: workingCopy ancestry ancestors size = 1. 197912 self assert: workingCopy ancestry ancestors first = base info. 197913 self assert: workingCopy ancestry stepChildren size = 1. 197914 self assert: workingCopy ancestry stepChildren first = final info. 197915 backported := self snapshot. 197916 [workingCopy backportChangesTo: base info] 197917 on: MCChangeSelectionRequest 197918 do: [:e | e resume: e patch]. 197919 self assert: workingCopy ancestry ancestors size = 1. 197920 self assert: workingCopy ancestry ancestors first = base info. 197921 self assert: workingCopy ancestry stepChildren size = 1. 197922 self assert: workingCopy ancestry stepChildren first = backported info. 197923 ! ! 197924 197925!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 197926testDoubleRepeatedMerge 197927 | base motherA1 motherA2 motherB1 motherB2 inst | 197928 197929 base := self snapshot. 197930 self change: #a toReturn: 'a1'. 197931 motherA1 := self snapshot. 197932 self change: #c toReturn: 'c1'. 197933 motherA2 := self snapshot. 197934 197935 self load: base. 197936 self change: #b toReturn: 'b1'. 197937 motherB1 := self snapshot. 197938 self change: #d toReturn: 'd1'. 197939 motherB2 := self snapshot. 197940 197941 self load: base. 197942 self merge: motherA1. 197943 self merge: motherB1. 197944 self change: #a toReturn: 'a2'. 197945 self change: #b toReturn: 'b2'. 197946 self snapshot. 197947 197948 self shouldnt: [self merge: motherA2] raise: Error. 197949 self shouldnt: [self merge: motherB2] raise: Error. 197950 197951 inst := self mockInstanceA. 197952 self assert: inst a = 'a2'. 197953 self assert: inst b = 'b2'. 197954 self assert: inst c = 'c1'. 197955 self assert: inst d = 'd1'. 197956 ! ! 197957 197958!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 197959testMergeIntoImageWithNoChanges 197960 | base revB revA1 | 197961 197962 self change: #a toReturn: 'a'. 197963 base := self snapshot. 197964 self change: #b toReturn: 'b'. 197965 revB := self snapshot. 197966 197967 self load: base. 197968 self change: #a toReturn: 'a1'. 197969 revA1 := self snapshot. 197970 197971 self change: #a toReturn: 'a'. 197972 self snapshot. 197973 self merge: revB. 197974 197975 self assert: (workingCopy ancestors size = 2) 197976 ! ! 197977 197978!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 197979testMergeIntoUnmodifiedImage 197980 | base revA | 197981 197982 base := self snapshot. 197983 self change: #a toReturn: 'a1'. 197984 revA := self snapshot. 197985 197986 self load: base. 197987 197988 self merge: revA. 197989 197990 self assert: (workingCopy ancestors size = 1) 197991 ! ! 197992 197993!MCWorkingCopyTest methodsFor: 'tests' stamp: 'bf 5/20/2005 18:25'! 197994testNaming 197995 | repos version | 197996 197997 repos := MCDictionaryRepository new. 197998 self assertNameWhenSavingTo: repos is: self packageName, '-abc.1'. 197999 self assertNameWhenSavingTo: repos is: self packageName, '-abc.2'. 198000 repos := MCDictionaryRepository new. 198001 self assertNameWhenSavingTo: repos is: self packageName, '-abc.3'. 198002 version := self snapshot. 198003 version info instVarNamed: 'name' put: 'foo-jf.32'. 198004 version load. 198005 self assertNameWhenSavingTo: repos is: 'foo-abc.33'. 198006 self assertNameWhenSavingTo: repos is: 'foo-abc.34'. 198007 version info instVarNamed: 'name' put: 'foo-abc.35'. 198008 repos storeVersion: version. 198009 self assertNameWhenSavingTo: repos is: 'foo-abc.36'. 198010 self assertNameWhenSavingTo: repos is: 'foo-abc.37'. 198011 version info instVarNamed: 'name' put: 'foo-abc.10'. 198012 repos storeVersion: version. 198013 self assertNameWhenSavingTo: repos is: 'foo-abc.38'. 198014 version info instVarNamed: 'name' put: 'foo2-ab.40'. 198015 version load. 198016 self assertNameWhenSavingTo: repos is: 'foo2-abc.41'.! ! 198017 198018!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 198019testOptimizedLoad 198020 | inst base diffy | 198021 inst := self mockInstanceA. 198022 base := self snapshot. 198023 self change: #one toReturn: 2. 198024 self assert: inst one = 2. 198025 diffy := self snapshot asDiffAgainst: base. 198026 self deny: diffy canOptimizeLoading. 198027 self load: base. 198028 self assert: inst one = 1. 198029 self assert: diffy canOptimizeLoading. 198030 self load: diffy. 198031 self assert: inst one = 2. 198032! ! 198033 198034!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 198035testRedundantMerge 198036 | base | 198037 base := self snapshot. 198038 self merge: base. 198039 self shouldnt: [self merge: base] raise: Error.! ! 198040 198041!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 198042testRepeatedMerge 198043 | base mother1 mother2 inst | 198044 198045 base := self snapshot. 198046 self change: #one toReturn: 2. 198047 mother1 := self snapshot. 198048 self change: #two toReturn: 3. 198049 mother2 := self snapshot. 198050 198051 self load: base. 198052 self change: #truth toReturn: false. 198053 self snapshot. 198054 198055 inst := self mockInstanceA. 198056 self assert: inst one = 1. 198057 self assert: inst two = 2. 198058 198059 self merge: mother1. 198060 self assert: inst one = 2. 198061 self assert: inst two = 2. 198062 198063 self change: #one toReturn: 7. 198064 self assert: inst one = 7. 198065 self assert: inst two = 2. 198066 198067 self shouldnt: [self merge: mother2] raise: Error. 198068 self assert: inst one = 7. 198069 self assert: inst two = 3.! ! 198070 198071!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 198072testRepositoryFallback 198073 | version | 198074 version := self snapshot. 198075 self assert: (repositoryGroup versionWithInfo: version info) == version. 198076 versions removeKey: version info. 198077 versions2 at: version info put: version. 198078 self assert: ( repositoryGroup versionWithInfo: version info) == version. 198079 versions2 removeKey: version info. 198080 self should: [repositoryGroup versionWithInfo: version info] raise: Error.! ! 198081 198082!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 198083testSelectiveBackport 198084 | inst base intermediate final patch selected | 198085 inst := self mockInstanceA. 198086 base := self snapshot. 198087 self assert: inst one = 1. 198088 self change: #one toReturn: 2. 198089 intermediate := self snapshot. 198090 self change: #two toReturn: 3. 198091 final := self snapshot. 198092 [workingCopy backportChangesTo: base info] 198093 on: MCChangeSelectionRequest 198094 do: [:e | 198095 patch := e patch. 198096 selected := patch operations select: [:ea | ea definition selector = #two]. 198097 e resume: (MCPatch operations: selected)]. 198098 self assert: inst one = 1. 198099 self assert: inst two = 3. 198100 self assert: workingCopy ancestry ancestors size = 1. 198101 self assert: workingCopy ancestry ancestors first = base info. 198102 self assert: workingCopy ancestry stepChildren size = 1. 198103 self assert: workingCopy ancestry stepChildren first = final info! ! 198104 198105!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 198106testSimpleMerge 198107 | mother base inst | 198108 inst := self mockInstanceA. 198109 base := self snapshot. 198110 self change: #one toReturn: 2. 198111 mother := self snapshot. 198112 self load: base. 198113 self change: #two toReturn: 3. 198114 self snapshot. 198115 self assert: inst one = 1. 198116 self assert: inst two = 3. 198117 198118 self merge: mother. 198119 self assert: inst one = 2. 198120 self assert: inst two = 3.! ! 198121 198122!MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 198123testSnapshotAndLoad 198124 | base inst | 198125 inst := self mockInstanceA. 198126 base := self snapshot. 198127 self change: #one toReturn: 2. 198128 self assert: inst one = 2. 198129 self load: base. 198130 self assert: inst one = 1.! ! 198131 198132 198133!MCWorkingCopyTest methodsFor: 'private' stamp: 'cwp 8/2/2003 15:03'! 198134packageName 198135 ^ self mockPackage name! ! 198136MCVersionHistoryBrowser subclass: #MCWorkingHistoryBrowser 198137 instanceVariableNames: '' 198138 classVariableNames: '' 198139 poolDictionaries: '' 198140 category: 'MonticelloGUI'! 198141 198142!MCWorkingHistoryBrowser methodsFor: 'as yet unclassified' stamp: 'ab 8/22/2003 01:37'! 198143baseSnapshot 198144 ^ package snapshot! ! 198145 198146"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 198147 198148MCWorkingHistoryBrowser class 198149 instanceVariableNames: ''! 198150MCRepository subclass: #MCWriteOnlyRepository 198151 instanceVariableNames: '' 198152 classVariableNames: '' 198153 poolDictionaries: '' 198154 category: 'Monticello-Repositories'! 198155 198156!MCWriteOnlyRepository methodsFor: '*MonticelloGUI' stamp: 'avi 10/9/2003 12:53'! 198157morphicOpen: aWorkingCopy 198158 self inform: 'This repository is write-only'! ! 198159 198160 198161!MCWriteOnlyRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:52'! 198162includesVersionNamed: aString 198163 ^ false! ! 198164 198165!MCWriteOnlyRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:52'! 198166versionWithInfo: aVersionInfo ifAbsent: aBlock 198167 ^ aBlock value! ! 198168 198169"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 198170 198171MCWriteOnlyRepository class 198172 instanceVariableNames: ''! 198173Object subclass: #MCWriter 198174 instanceVariableNames: 'stream' 198175 classVariableNames: '' 198176 poolDictionaries: '' 198177 category: 'Monticello-Storing'! 198178 198179!MCWriter methodsFor: 'as yet unclassified' stamp: 'cwp 8/1/2003 01:14'! 198180stream 198181 ^ stream! ! 198182 198183!MCWriter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! 198184stream: aStream 198185 stream := aStream! ! 198186 198187"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 198188 198189MCWriter class 198190 instanceVariableNames: ''! 198191 198192!MCWriter class methodsFor: 'accessing' stamp: 'cwp 8/1/2003 15:00'! 198193extension 198194 ^ self readerClass extension! ! 198195 198196!MCWriter class methodsFor: 'accessing' stamp: 'cwp 7/28/2003 23:46'! 198197readerClass 198198 ^ self subclassResponsibility ! ! 198199 198200 198201!MCWriter class methodsFor: 'writing' stamp: 'cwp 8/1/2003 01:16'! 198202on: aStream 198203 ^ self new stream: aStream! ! 198204HashFunction subclass: #MD5 198205 instanceVariableNames: 'state' 198206 classVariableNames: '' 198207 poolDictionaries: '' 198208 category: 'System-Hashing-MD5'! 198209!MD5 commentStamp: 'ul 3/3/2008 23:40' prior: 0! 198210This class implements the MD5 128-bit one-way hash function. It uses the MD5Plugin for better performance. Some methods are taken from the original version of MD5NonPrimitive.! 198211 198212 198213!MD5 methodsFor: 'accessing' stamp: 'ul 3/3/2008 22:00'! 198214hashStream: aPositionableStream 198215 198216 | startPosition buf bitLength | 198217 self initialize. 198218 198219 aPositionableStream atEnd ifTrue: [ 198220 buf := ByteArray new: 64. 198221 buf at: 1 put: 128. 198222 self processBuffer: buf. 198223 ^self finalValue ]. 198224 198225 startPosition := aPositionableStream position. 198226 [aPositionableStream atEnd] whileFalse: [ 198227 buf := aPositionableStream next: 64. 198228 (aPositionableStream atEnd not and: [buf size = 64]) 198229 ifTrue: [self processBuffer: buf] 198230 ifFalse: [ 198231 bitLength := (aPositionableStream position - startPosition) * 8. 198232 self processFinalBuffer: buf bitLength: bitLength]]. 198233 198234 ^ self finalValue! ! 198235 198236 198237!MD5 methodsFor: 'initialization' stamp: 'ul 3/2/2008 20:19'! 198238initialize 198239 "Some magic numbers to get the process started" 198240 198241 state := ByteArray withAll: #(1 35 69 103 137 171 205 239 254 220 186 152 118 84 50 16) 198242 198243! ! 198244 198245 198246!MD5 methodsFor: 'private-buffers' stamp: 'ul 3/3/2008 21:34'! 198247finalValue 198248 198249 ^state! ! 198250 198251!MD5 methodsFor: 'private-buffers' stamp: 'ul 3/3/2008 22:28'! 198252primProcessBuffer: aByteArray withState: s 198253 198254 <primitive: 'primitiveProcessBufferWithState' module: 'MD5Plugin'> 198255 self primitiveFailed! ! 198256 198257!MD5 methodsFor: 'private-buffers' stamp: 'ul 3/3/2008 19:17'! 198258processBuffer: aByteArray 198259 198260 self primProcessBuffer: aByteArray withState: state. 198261 ! ! 198262 198263!MD5 methodsFor: 'private-buffers' stamp: 'StephaneDucasse 10/17/2009 17:15'! 198264processFinalBuffer: aByteArray bitLength: bitLength 198265 "Pad the buffer until we have an even 64 bytes, then transform" 198266 | out | 198267 out := ByteArray new: 64. 198268 out 198269 replaceFrom: 1 198270 to: aByteArray size 198271 with: aByteArray 198272 startingAt: 1. 198273 aByteArray size < 56 ifTrue: 198274 [ out 198275 at: aByteArray size + 1 198276 put: 128. "trailing bit" 198277 self 198278 storeLength: bitLength 198279 in: out. 198280 self processBuffer: out. 198281 ^ self ]. 198282 198283 "not enough room for the length, so just pad this one, then..." 198284 aByteArray size < 64 ifTrue: 198285 [ out 198286 at: aByteArray size + 1 198287 put: 128 ]. 198288 self processBuffer: out. 198289 198290 "process one additional block of padding ending with the length" 198291 out := ByteArray new: 64. "filled with zeros" 198292 aByteArray size = 64 ifTrue: 198293 [ out 198294 at: 1 198295 put: 128 ]. 198296 self 198297 storeLength: bitLength 198298 in: out. 198299 self processBuffer: out! ! 198300 198301!MD5 methodsFor: 'private-buffers' stamp: 'StephaneDucasse 10/17/2009 17:15'! 198302storeLength: bitLength in: aByteArray 198303 "Fill in the final 8 bytes of the given ByteArray with a 64-bit 198304 little-endian representation of the original message length in bits." 198305 | n i | 198306 n := bitLength. 198307 i := aByteArray size - 8 + 1. 198308 [ n > 0 ] whileTrue: 198309 [ aByteArray 198310 at: i 198311 put: (n bitAnd: 255). 198312 n := n bitShift: -8. 198313 i := i + 1 ]! ! 198314 198315"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 198316 198317MD5 class 198318 instanceVariableNames: ''! 198319 198320!MD5 class methodsFor: 'accessing' stamp: 'ul 3/3/2008 23:37'! 198321blockSize 198322 ^ 64! ! 198323 198324!MD5 class methodsFor: 'accessing' stamp: 'ul 3/3/2008 23:37'! 198325hashSize 198326 ^ 16! ! 198327 198328 198329!MD5 class methodsFor: 'as yet unclassified' stamp: 'ul 3/3/2008 22:46'! 198330isPluginAvailable 198331 198332 <primitive: 'primitivePluginAvailable' module: 'MD5Plugin'> 198333 ^false! ! 198334 198335!MD5 class methodsFor: 'as yet unclassified' stamp: 'ul 3/3/2008 23:01'! 198336new 198337 198338 self isPluginAvailable 198339 ifTrue: [ ^self basicNew ] 198340 ifFalse: [ ^MD5NonPrimitive basicNew ]! ! 198341MD5 subclass: #MD5NonPrimitive 198342 instanceVariableNames: '' 198343 classVariableNames: 'ABCDTable IndexTable ShiftTable SinTable' 198344 poolDictionaries: '' 198345 category: 'System-Hashing-MD5'! 198346!MD5NonPrimitive commentStamp: '<historical>' prior: 0! 198347This class implements the MD5 128-bit one-way hash function. It relies on 198348the ThirtyTwoBitRegister class supplied as part of the "Digital Signatures" 198349functionality included in Squeak 2.7. As of this date (1/20/2000), the 198350U.S. Government has lifted many of the previous restrictions on the export 198351of encryption software, but you should check before exporting anything 198352including this code. MD5 is commonly used for some secure Internet 198353protocols, including authentication in HTTP, which is why I wrote it. 198354 198355Submitted by Duane Maxwell 198356 198357! 198358 198359 198360!MD5NonPrimitive methodsFor: 'initialization' stamp: 'StephaneDucasse 10/17/2009 17:15'! 198361initialize 198362 "Some magic numbers to get the process started" 198363 state := OrderedCollection newFrom: { 198364 (ThirtyTwoBitRegister new load: 1732584193). 198365 (ThirtyTwoBitRegister new load: 4023233417). 198366 (ThirtyTwoBitRegister new load: 2562383102). 198367 (ThirtyTwoBitRegister new load: 271733878) 198368 }! ! 198369 198370 198371!MD5NonPrimitive methodsFor: 'private-buffers' stamp: 'len 10/15/2002 19:58'! 198372finalValue 198373 "Concatenate the state values to produce the 128-bite result" 198374 ^ (state at: 1) asByteArray, (state at: 2) asByteArray, (state at: 3) asByteArray, (state at: 4) asByteArray! ! 198375 198376!MD5NonPrimitive methodsFor: 'private-buffers' stamp: 'StephaneDucasse 10/17/2009 17:15'! 198377processBuffer: aByteArray 198378 "Process a 64-byte buffer" 198379 | saveState data | 198380 saveState := state collect: [ :item | item copy ]. 198381 data := Array new: 16. 198382 1 198383 to: 16 198384 do: 198385 [ :index | 198386 data 198387 at: index 198388 put: (ThirtyTwoBitRegister new 198389 reverseLoadFrom: aByteArray 198390 at: index * 4 - 3) ]. 198391 self rounds: data. 198392 1 198393 to: 4 198394 do: [ :index | (state at: index) += (saveState at: index) ]! ! 198395 198396 198397!MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 01:47'! 198398fX: x Y: y Z: z 198399 " compute 'xy or (not x)z'" 198400 ^ x copy bitAnd: y; bitOr: (x copy bitInvert; bitAnd: z) 198401 198402 ! ! 198403 198404!MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 13:38'! 198405ffA: a B: b C: c D: d M: m S: s T: t 198406 "compute a = b + ((a + f(b,c,d) + m + t) <<< s)" 198407 ^ a += (self fX: b Y: c Z: d); += m; += t; leftRotateBy: s; += b. 198408! ! 198409 198410!MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 01:48'! 198411gX: x Y: y Z: z 198412 " compute 'xz or y(not z)'" 198413 ^ x copy bitAnd: z; bitOr: (z copy bitInvert; bitAnd: y) 198414 198415 ! ! 198416 198417!MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 13:38'! 198418ggA: a B: b C: c D: d M: m S: s T: t 198419 "compute a = b + ((a + g(b,c,d) + m + t) <<< s)" 198420 ^ a += (self gX: b Y: c Z: d); += m; += t; leftRotateBy: s; += b. 198421! ! 198422 198423!MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 01:48'! 198424hX: x Y: y Z: z 198425 " compute 'x xor y xor z'" 198426 ^ x copy bitXor: y; bitXor: z 198427 198428 ! ! 198429 198430!MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 13:38'! 198431hhA: a B: b C: c D: d M: m S: s T: t 198432 "compute a = b + ((a + h(b,c,d) + m + t) <<< s)" 198433 ^ a += (self hX: b Y: c Z: d); += m; += t; leftRotateBy: s; += b. 198434! ! 198435 198436!MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 01:48'! 198437iX: x Y: y Z: z 198438 " compute 'y xor (x or (not z))'" 198439 ^ y copy bitXor: (z copy bitInvert; bitOr: x) 198440! ! 198441 198442!MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 13:39'! 198443iiA: a B: b C: c D: d M: m S: s T: t 198444 "compute a = b + ((a + i(b,c,d) + m + t) <<< s)" 198445 ^ a += (self iX: b Y: c Z: d); += m; += t; leftRotateBy: s; += b. 198446! ! 198447 198448!MD5NonPrimitive methodsFor: 'private-functions' stamp: 'StephaneDucasse 10/17/2009 17:15'! 198449step: data template: item selector: selector 198450 "Perform one step in the round" 198451 | args | 198452 args := { 198453 (state at: (item at: 1)). 198454 (state at: (item at: 2)). 198455 (state at: (item at: 3)). 198456 (state at: (item at: 4)). 198457 (data at: (item at: 5)). 198458 (item at: 6). 198459 (item at: 7) 198460 }. 198461 self 198462 perform: selector 198463 withArguments: args! ! 198464 198465 198466!MD5NonPrimitive methodsFor: 'private-rounds' stamp: 'StephaneDucasse 10/17/2009 17:15'! 198467round: data selector: selector round: round 198468 "Do one round with the given function" 198469 | shiftIndex template abcd | 198470 1 198471 to: 16 198472 do: 198473 [ :i | 198474 shiftIndex := (i - 1) \\ 4 + 1. 198475 abcd := ABCDTable at: shiftIndex. 198476 template := { 198477 (abcd at: 1). 198478 (abcd at: 2). 198479 (abcd at: 3). 198480 (abcd at: 4). 198481 ((IndexTable at: round) at: i). 198482 ((ShiftTable at: round) at: shiftIndex). 198483 (SinTable at: (round - 1) * 16 + i) 198484 }. 198485 self 198486 step: data 198487 template: template 198488 selector: selector ]! ! 198489 198490!MD5NonPrimitive methodsFor: 'private-rounds' stamp: 'DSM 1/20/2000 17:58'! 198491rounds: data 198492 "Perform the four rounds with different functions" 198493 #( 198494 ffA:B:C:D:M:S:T: 198495 ggA:B:C:D:M:S:T: 198496 hhA:B:C:D:M:S:T: 198497 iiA:B:C:D:M:S:T: 198498 ) doWithIndex: [ :selector :index | 198499 self round: data selector: selector round: index.] 198500! ! 198501 198502"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 198503 198504MD5NonPrimitive class 198505 instanceVariableNames: ''! 198506 198507!MD5NonPrimitive class methodsFor: 'class initialization' stamp: 'StephaneDucasse 10/17/2009 17:15'! 198508initialize 198509 "MD5 initialize" 198510 "Obscure fact: those magic hex numbers that are hard to type in correctly are 198511 actually the result of a simple trigonometric function and are therefore 198512 easier to compute than proofread. Laziness is sometimes a virtue." 198513 | c | 198514 c := 2 raisedTo: 32. 198515 SinTable := Array new: 64. 198516 1 198517 to: 64 198518 do: 198519 [ :i | 198520 SinTable 198521 at: i 198522 put: (ThirtyTwoBitRegister new load: (c * i sin abs) truncated) ]. 198523 ShiftTable := { 198524 #(7 12 17 22 ). 198525 #(5 9 14 20 ). 198526 #(4 11 16 23 ). 198527 #(6 10 15 21 ) 198528 }. 198529 IndexTable := { 198530 #( 198531 1 198532 2 198533 3 198534 4 198535 5 198536 6 198537 7 198538 8 198539 9 198540 10 198541 11 198542 12 198543 13 198544 14 198545 15 198546 16 198547 ). 198548 #( 198549 2 198550 7 198551 12 198552 1 198553 6 198554 11 198555 16 198556 5 198557 10 198558 15 198559 4 198560 9 198561 14 198562 3 198563 8 198564 13 198565 ). 198566 #( 198567 6 198568 9 198569 12 198570 15 198571 2 198572 5 198573 8 198574 11 198575 14 198576 1 198577 4 198578 7 198579 10 198580 13 198581 16 198582 3 198583 ). 198584 #( 198585 1 198586 8 198587 15 198588 6 198589 13 198590 4 198591 11 198592 2 198593 9 198594 16 198595 7 198596 14 198597 5 198598 12 198599 3 198600 10 198601 ) 198602 }. 198603 ABCDTable := { 198604 #(1 2 3 4 ). 198605 #(4 1 2 3 ). 198606 #(3 4 1 2 ). 198607 #(2 3 4 1 ) 198608 }! ! 198609Object subclass: #MIMEDocument 198610 instanceVariableNames: 'type contents contentStream uri' 198611 classVariableNames: '' 198612 poolDictionaries: '' 198613 category: 'Network-MIME'! 198614!MIMEDocument commentStamp: '<historical>' prior: 0! 198615a MIME object, along with its type and the URL it was found at (if any)! 198616 198617 198618!MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/4/2002 18:19'! 198619contentStream 198620 "Answer a RWBinaryOrTextStream on the contents." 198621 198622 contentStream 198623 ifNil: [contentStream := contents 198624 ifNil: [self contentStreamOnURI] 198625 ifNotNil: [(RWBinaryOrTextStream with: self contents) reset]]. 198626 ^contentStream! ! 198627 198628!MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/24/2005 17:26'! 198629contents 198630 "Answer the receiver's raw data. If we have a stream to read from. Read in the data, cache it and discard the stream." 198631 198632 contents ifNil: [contents := self getContentFromStream]. 198633 ^contents! ! 198634 198635!MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/26/2005 11:13'! 198636discardContents 198637 contents := nil. 198638 self discardContentStream! ! 198639 198640!MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/4/2002 17:19'! 198641mainType 198642 ^self mimeType main! ! 198643 198644!MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/4/2002 17:19'! 198645mimeType 198646 ^type! ! 198647 198648!MIMEDocument methodsFor: 'accessing' stamp: 'damiencassou 5/30/2008 15:52'! 198649parts 198650 "Return the parts of this message. There is a far more reliable implementation of parts in MailMessage, but for now we are continuing to use this implementation" 198651 | parseStream currLine separator msgStream messages | 198652 self isMultipart ifFalse: 198653 [ ^ #() ]. 198654 parseStream := self content readStream. 198655 currLine := ''. 198656 [ '--*' match: currLine ] whileFalse: [ currLine := parseStream nextLine ]. 198657 separator := currLine copy. 198658 msgStream := LimitingLineStreamWrapper 198659 on: parseStream 198660 delimiter: separator. 198661 messages := OrderedCollection new. 198662 [ parseStream atEnd ] whileFalse: 198663 [ messages add: msgStream upToEnd. 198664 msgStream skipThisLine ]. 198665 ^ messages collect: [ :e | MailMessage from: e ]! ! 198666 198667!MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/4/2002 17:19'! 198668subType 198669 ^self mimeType sub! ! 198670 198671!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:48'! 198672type 198673 "Deprecated. Use contentType instead." 198674 198675 ^ self contentType! ! 198676 198677!MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/4/2002 16:24'! 198678type: mimeType 198679 type := mimeType! ! 198680 198681!MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/27/2005 10:55'! 198682uri 198683 "Answer the URL the receiver was downloaded from. It may legitimately be nil." 198684 198685 ^uri! ! 198686 198687!MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/27/2005 10:53'! 198688uri: aURI 198689 uri := aURI! ! 198690 198691!MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/27/2005 10:55'! 198692url 198693 "Answer the URL the receiver was downloaded from. It may legitimately be nil." 198694 198695 ^ uri asString! ! 198696 198697 198698!MIMEDocument methodsFor: 'as yet unclassified' stamp: 'ls 4/30/2000 18:45'! 198699isMultipartAlternative 198700 "whether the document is in a multipart format where the parts are alternates" 198701 ^ self contentType = 'multipart/alternative' 198702! ! 198703 198704 198705!MIMEDocument methodsFor: 'compatibility' stamp: 'mir 3/22/2005 22:55'! 198706content 198707 ^self contents! ! 198708 198709!MIMEDocument methodsFor: 'compatibility' stamp: 'mir 3/4/2002 17:46'! 198710contentType 198711 ^self mimeType asString! ! 198712 198713 198714!MIMEDocument methodsFor: 'printing' stamp: 'mir 3/26/2005 17:48'! 198715printOn: aStream 198716 aStream nextPutAll: self class name; 198717 nextPutAll: ' ('; 198718 nextPutAll: self mimeType asString; 198719 nextPutAll: ', '. 198720 contents 198721 ifNotNil: [aStream 198722 nextPutAll: self contents size printString; 198723 nextPutAll: ' bytes)'] 198724 ifNil: [aStream nextPutAll: 'unknown size)'].! ! 198725 198726 198727!MIMEDocument methodsFor: 'testing' stamp: 'sbw 1/21/2001 11:13'! 198728isGif 198729 ^ self mainType = 'image' 198730 and: [self subType = 'gif']! ! 198731 198732!MIMEDocument methodsFor: 'testing' stamp: 'sbw 1/21/2001 11:15'! 198733isJpeg 198734 ^ self mainType = 'image' 198735 and: [self subType = 'jpeg' | (self subType = 'jpg')]! ! 198736 198737!MIMEDocument methodsFor: 'testing' stamp: 'ls 4/30/2000 18:07'! 198738isMultipart 198739 ^self mainType = 'multipart'! ! 198740 198741!MIMEDocument methodsFor: 'testing' stamp: 'st 9/18/2004 23:37'! 198742isPng 198743 ^ self mainType = 'image' 198744 and: [self subType = 'png']! ! 198745 198746!MIMEDocument methodsFor: 'testing' stamp: 'st 9/18/2004 23:38'! 198747isPnm 198748 ^ self mainType = 'image' 198749 and: [self subType = 'pnm']! ! 198750 198751 198752!MIMEDocument methodsFor: 'private' stamp: 'mir 3/27/2005 10:53'! 198753contentStream: aStream mimeType: aMimeType uri: aUri 198754 type := aMimeType. 198755 contentStream := aStream. 198756 uri := aUri! ! 198757 198758!MIMEDocument methodsFor: 'private' stamp: 'mir 3/27/2005 10:50'! 198759contentStreamOnURI 198760 ^self uri contentStream! ! 198761 198762!MIMEDocument methodsFor: 'private' stamp: 'mir 3/27/2005 10:53'! 198763contents: contentStringOrBytes mimeType: aMimeType uri: aURI 198764 type := aMimeType. 198765 contents := contentStringOrBytes. 198766 uri := aURI! ! 198767 198768!MIMEDocument methodsFor: 'private' stamp: 'mir 3/26/2005 11:12'! 198769discardContentStream 198770 contentStream ifNotNil: [contentStream close]. 198771 contentStream := nil! ! 198772 198773!MIMEDocument methodsFor: 'private' stamp: 'mir 3/24/2005 17:37'! 198774getContentFromStream 198775 | streamContents | 198776 streamContents := self contentStream contents. 198777 self discardContentStream. 198778 ^streamContents! ! 198779 198780!MIMEDocument methodsFor: 'private' stamp: 'mir 11/8/2005 13:39'! 198781privateContent: aString 198782 contents := aString! ! 198783 198784"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 198785 198786MIMEDocument class 198787 instanceVariableNames: ''! 198788 198789!MIMEDocument class methodsFor: 'accessing' stamp: 'michael.rueger 2/25/2009 12:35'! 198790defaultMIMEType 198791 ^MIMEType fromMIMEString: 'application/octet-stream'! ! 198792 198793 198794!MIMEDocument class methodsFor: 'compatibility' stamp: 'mir 11/8/2005 13:50'! 198795contentType: aString content: content 198796 "create a MIMEObject with the given content-type and content" 198797 "MIMEObject contentType: 'text/plain' content: 'This is a test'" 198798 198799 | ans idx | 198800 ans := self new. 198801 ans privateContent: content. 198802 198803 "parse the content-type" 198804 (aString isNil or: [ 198805 idx := aString indexOf: $/. 198806 idx = 0]) 198807 ifTrue: [ 198808 ans type: (MIMEType main: 'application' sub: 'octet-stream')] 198809 ifFalse: [ 198810 ans type: (MIMEType main: (aString copyFrom: 1 to: idx-1) sub: (aString copyFrom: idx+1 to: aString size))]. 198811 198812 ^ans 198813! ! 198814 198815!MIMEDocument class methodsFor: 'compatibility' stamp: 'Noury 6/15/2009 22:54'! 198816contentType: type content: content url: url 198817 ^self contents: content mimeType: (MIMEType fromMIMEString: type asString) uri: url! ! 198818 198819!MIMEDocument class methodsFor: 'compatibility' stamp: 'michael.rueger 2/25/2009 12:36'! 198820defaultContentType 198821 ^self defaultMIMEType asString! ! 198822 198823!MIMEDocument class methodsFor: 'compatibility' stamp: 'michael.rueger 2/25/2009 13:05'! 198824guessContentTypeFromExtension: ext 198825 "guesses a content type from the extension" 198826 ^(self guessTypeFromExtension: ext) asString! ! 198827 198828!MIMEDocument class methodsFor: 'compatibility' stamp: 'michael.rueger 2/25/2009 13:05'! 198829guessTypeFromExtension: ext 198830 "guesses a content type from the extension" 198831 ^self guessTypeFromName: ext! ! 198832 198833!MIMEDocument class methodsFor: 'compatibility' stamp: 'michael.rueger 1/8/2009 18:59'! 198834guessTypeFromName: url 198835 "guesses a content type from the url" 198836 ^MIMEType forURIReturnSingleMimeTypeOrDefault: url asString asURI! ! 198837 198838!MIMEDocument class methodsFor: 'compatibility' stamp: 'michael.rueger 2/25/2009 12:29'! 198839resetMIMEdatabase 198840 "no-op for catching Kom override"! ! 198841 198842 198843!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 12:25'! 198844contentTypeFormData 198845 ^'application/x-www-form-urlencoded'! ! 198846 198847!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'! 198848contentTypeHtml 198849 ^'text/html'! ! 198850 198851!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 12:25'! 198852contentTypeMultipart 198853 ^'multipart/form-data'! ! 198854 198855!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'! 198856contentTypePlainText 198857 ^'text/plain'! ! 198858 198859!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'! 198860contentTypeXml 198861 ^'text/xml'! ! 198862 198863 198864!MIMEDocument class methodsFor: 'instance creation' stamp: 'ls 7/23/1998 22:59'! 198865content: aString 198866 ^self contentType: self defaultContentType content: aString! ! 198867 198868!MIMEDocument class methodsFor: 'instance creation' stamp: 'mir 3/4/2002 18:26'! 198869contentStream: aStream 198870 ^self contentStream: aStream mimeType: MIMEType defaultStream! ! 198871 198872!MIMEDocument class methodsFor: 'instance creation' stamp: 'mir 3/27/2005 10:52'! 198873contentStream: aStream mimeType: aMimeType 198874 "create a MIMEDocument with the given content-type and contentStream" 198875 "MIMEDocument mimeType: 'text/plain' asMIMEType contentStream: (ReadStream on: 'This is a test')" 198876 198877 ^self contentStream: aStream mimeType: aMimeType uri: aStream uri! ! 198878 198879!MIMEDocument class methodsFor: 'instance creation' stamp: 'mir 3/27/2005 10:52'! 198880contentStream: aStream mimeType: aMimeType uri: aURI 198881 "create a MIMEDocument with the given content-type and contentStream" 198882 "MIMEDocument mimeType: 'text/plain' asMIMEType contentStream: (ReadStream on: 'This is a test')" 198883 198884 ^self new contentStream: aStream mimeType: aMimeType uri: aURI! ! 198885 198886!MIMEDocument class methodsFor: 'instance creation' stamp: 'mir 3/4/2002 18:23'! 198887contents: aString 198888 ^self contents: aString mimeType: MIMEType defaultStream! ! 198889 198890!MIMEDocument class methodsFor: 'instance creation' stamp: 'mir 3/27/2005 10:54'! 198891contents: content mimeType: aMimeType 198892 "create a MIMEDocument with the given content-type and content" 198893 "MIMEDocument mimeType: 'text/plain' asMIMEType content: 'This is a test'" 198894 198895 ^self contents: content mimeType: aMimeType uri: nil! ! 198896 198897!MIMEDocument class methodsFor: 'instance creation' stamp: 'mir 3/27/2005 10:57'! 198898contents: content mimeType: aMimeType uri: aURL 198899 "create a MIMEDocument with the given content-type and content" 198900 "MIMEDocument mimeType: 'text/plain' asMIMEType content: 'This is a test'" 198901 198902 ^self new contents: content mimeType: aMimeType uri: aURL! ! 198903Object subclass: #MIMEHeaderValue 198904 instanceVariableNames: 'mainValue parameters' 198905 classVariableNames: '' 198906 poolDictionaries: '' 198907 category: 'Network-Url'! 198908!MIMEHeaderValue commentStamp: '<historical>' prior: 0! 198909I contain the value portion of a MIME-compatible header. 198910 198911I must be only initialized with the value and not the field name. E.g. in processing 198912 Subject: This is the subject 198913the MIMEHeaderValue should be given only 'This is the subject' 198914 198915For traditional non-MIME headers, the complete value returned for mainValue and paramaters returns an empty collection. 198916 198917For MIME headers, both mainValue and parameters are used.! 198918 198919 198920!MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:55'! 198921mainValue 198922 ^mainValue! ! 198923 198924!MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:13'! 198925mainValue: anObject 198926 mainValue := anObject! ! 198927 198928!MIMEHeaderValue methodsFor: 'accessing' stamp: 'ls 2/10/2001 13:06'! 198929parameterAt: aParameter put: value 198930 parameters at: aParameter put: value! ! 198931 198932!MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:18'! 198933parameters 198934 ^parameters! ! 198935 198936!MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:11'! 198937parameters: anObject 198938 parameters := anObject! ! 198939 198940 198941!MIMEHeaderValue methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 10:01'! 198942asHeaderValue 198943 | strm | 198944 strm := (String new: 20) writeStream. 198945 strm nextPutAll: mainValue. 198946 parameters associationsDo: [:e | strm nextPut: $; ; nextPutAll: e key; 198947 nextPutAll: '="'; 198948 nextPutAll: e value , '"']. 198949 ^ strm contents! ! 198950 198951!MIMEHeaderValue methodsFor: 'printing' stamp: 'ls 2/10/2001 12:37'! 198952printOn: aStream 198953 super printOn: aStream. 198954 aStream nextPutAll: ': '. 198955 aStream nextPutAll: self asHeaderValue! ! 198956 198957"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 198958 198959MIMEHeaderValue class 198960 instanceVariableNames: ''! 198961 198962!MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'mdr 4/11/2001 12:19'! 198963forField: aFName fromString: aString 198964 "Create a MIMEHeaderValue from aString. How it is parsed depends on whether it is a MIME specific field or a generic header field." 198965 198966 (aFName beginsWith: 'content-') 198967 ifTrue: [^self fromMIMEHeader: aString] 198968 ifFalse: [^self fromTraditionalHeader: aString] 198969! ! 198970 198971!MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'damiencassou 5/30/2008 15:52'! 198972fromMIMEHeader: aString 198973 "This is the value of a MIME header field and so is parsed to extract the various parts" 198974 | parts newValue parms separatorPos parmName parmValue | 198975 newValue := self new. 198976 parts := (aString findTokens: ';') readStream. 198977 newValue mainValue: parts next. 198978 parms := Dictionary new. 198979 parts do: 198980 [ :e | 198981 separatorPos := e 198982 findAnySubStr: '=' 198983 startingAt: 1. 198984 separatorPos <= e size ifTrue: 198985 [ parmName := (e 198986 copyFrom: 1 198987 to: separatorPos - 1) withBlanksTrimmed asLowercase. 198988 parmValue := (e 198989 copyFrom: separatorPos + 1 198990 to: e size) withBlanksTrimmed withoutQuoting. 198991 parms 198992 at: parmName 198993 put: parmValue ] ]. 198994 newValue parameters: parms. 198995 ^ newValue! ! 198996 198997!MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'mdr 4/11/2001 12:02'! 198998fromTraditionalHeader: aString 198999 "This is a traditional non-MIME header (like Subject:) and so should be stored whole" 199000 199001 | newValue | 199002 199003 newValue := self new. 199004 newValue mainValue: aString. 199005 newValue parameters: #(). 199006 ^newValue. 199007! ! 199008MIMEDocument subclass: #MIMELocalFileDocument 199009 instanceVariableNames: '' 199010 classVariableNames: '' 199011 poolDictionaries: '' 199012 category: 'Network-MIME'! 199013!MIMELocalFileDocument commentStamp: '<historical>' prior: 0! 199014For local files, we do not read the entire contents unless we absolutely have to.! 199015 199016 199017!MIMELocalFileDocument methodsFor: 'accessing' stamp: 'michael.rueger 1/8/2009 19:19'! 199018content 199019 ^contents ifNil:[contents := contentStream contentsOfEntireFile].! ! 199020 199021!MIMELocalFileDocument methodsFor: 'accessing' stamp: 'ar 4/24/2001 16:27'! 199022contentStream 199023 ^contentStream ifNil:[super contentStream]! ! 199024 199025!MIMELocalFileDocument methodsFor: 'accessing' stamp: 'michael.rueger 1/8/2009 19:20'! 199026contentStream: aFileStream 199027 contentStream := aFileStream. 199028 contents := nil.! ! 199029 199030"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 199031 199032MIMELocalFileDocument class 199033 instanceVariableNames: ''! 199034 199035!MIMELocalFileDocument class methodsFor: 'instance creation' stamp: 'ar 4/24/2001 16:31'! 199036contentType: aString contentStream: aStream 199037 ^(self contentType: aString content: nil) contentStream: aStream! ! 199038Object subclass: #MIMEType 199039 instanceVariableNames: 'main sub parameters' 199040 classVariableNames: 'DefaultSuffixes StandardMIMEMappings' 199041 poolDictionaries: '' 199042 category: 'Network-MIME'! 199043 199044!MIMEType methodsFor: 'accessing' stamp: 'mir 3/4/2002 15:21'! 199045main 199046 ^main! ! 199047 199048!MIMEType methodsFor: 'accessing' stamp: 'mir 3/4/2002 15:21'! 199049main: mainType 199050 main := mainType! ! 199051 199052!MIMEType methodsFor: 'accessing' stamp: 'mir 2/16/2006 23:33'! 199053parameters: params 199054 parameters := params! ! 199055 199056!MIMEType methodsFor: 'accessing' stamp: 'mir 3/4/2002 15:21'! 199057sub 199058 ^sub! ! 199059 199060!MIMEType methodsFor: 'accessing' stamp: 'mir 3/4/2002 15:21'! 199061sub: subType 199062 sub := subType! ! 199063 199064 199065!MIMEType methodsFor: 'comparing' stamp: 'mir 3/6/2002 12:11'! 199066= anotherObject 199067 anotherObject class == self class 199068 ifFalse: [^false]. 199069 ^self main = anotherObject main 199070 and: [self sub = anotherObject sub]! ! 199071 199072!MIMEType methodsFor: 'comparing' stamp: 'JMM 7/26/2006 16:26'! 199073beginsWith: aString 199074 ^self printString beginsWith: aString! ! 199075 199076!MIMEType methodsFor: 'comparing' stamp: 'mir 12/17/2005 14:17'! 199077hash 199078 ^self main hash bitXor: self sub hash! ! 199079 199080 199081!MIMEType methodsFor: 'converting' stamp: 'mir 3/4/2002 18:21'! 199082asMIMEType 199083 ^self! ! 199084 199085 199086!MIMEType methodsFor: 'printing' stamp: 'mir 3/4/2002 16:14'! 199087printOn: stream 199088 stream 199089 nextPutAll: main; nextPut: $/ ; nextPutAll: sub! ! 199090 199091"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 199092 199093MIMEType class 199094 instanceVariableNames: ''! 199095 199096!MIMEType class methodsFor: 'accessing' stamp: 'michael.rueger 2/24/2009 18:42'! 199097defaultSuffixes 199098 "MIMEType defaultSuffixes" 199099 199100 ^DefaultSuffixes! ! 199101 199102!MIMEType class methodsFor: 'accessing' stamp: 'JMM 10/2/2006 12:38'! 199103huntForDashAndRemove: aString 199104 | n | 199105 (n := aString lastIndexOf: $-) > 0 ifTrue: [^aString copyFrom: n+1 to: aString size]. 199106 ^aString 199107! ! 199108 199109!MIMEType class methodsFor: 'accessing' stamp: 'mir 3/4/2002 16:15'! 199110mimeMappings 199111 ^StandardMIMEMappings! ! 199112 199113!MIMEType class methodsFor: 'accessing' stamp: 'JMM 12/2/2007 14:32'! 199114simpleSuffixForMimeType: mimeType 199115 ^(self defaultSuffixes at: mimeType printString ifAbsent: [self huntForDashAndRemove: mimeType sub]) asSymbol! ! 199116 199117!MIMEType class methodsFor: 'accessing' stamp: 'JMM 12/2/2007 14:31'! 199118suffixForMimeType: mimeType 199119 ^self defaultSuffixes at: mimeType printString ifAbsent: [mimeType sub]! ! 199120 199121 199122!MIMEType class methodsFor: 'class initialization' stamp: 'michael.rueger 2/24/2009 18:42'! 199123initialize 199124 "MIMEType initialize" 199125 199126 self initializeStandardMIMETypes. 199127 self initializeDefaultSuffixes! ! 199128 199129!MIMEType class methodsFor: 'class initialization' stamp: 'michael.rueger 2/24/2009 18:43'! 199130initializeDefaultSuffixes 199131 "MIMEType initializeDefaultSuffixes" 199132 199133 DefaultSuffixes := Dictionary new: 43. 199134 DefaultSuffixes 199135 at: 'application/freeloader' put: 'frl'; 199136 at: 'application/gzip' put: 'gz'; 199137 at: 'application/ips' put: 'ips'; 199138 at: 'application/mac-binhex40' put: 'hqx'; 199139 at: 'application/mac-compactpro' put: 'cpt'; 199140 at: 'application/ms-word-document' put: 'doc'; 199141 at: 'application/msword' put: 'doc'; 199142 at: 'application/octet-stream' put: 'o'; 199143 at: 'application/oda' put: 'oda'; 199144 at: 'application/olescript' put: 'axs'; 199145 at: 'application/pcphoto' put: 'zpa'; 199146 at: 'application/pdf' put: 'pdf'; 199147 at: 'application/postscript' put: 'ps'; 199148 at: 'application/rtc' put: 'rtc'; 199149 at: 'application/rtf' put: 'rtf'; 199150 at: 'application/toolbook' put: 'tbk'; 199151 at: 'application/vnd.ms-excel' put: 'xls'; 199152 at: 'application/vnd.ms-powerpoint' put: 'pps'; 199153 at: 'application/x-DemoShield' put: 'wid'; 199154 at: 'application/x-authorware-map' put: 'aas'; 199155 at: 'application/x-bcpio' put: 'bcpio'; 199156 at: 'application/x-chat' put: 'chat'; 199157 at: 'application/x-compress' put: 'z'; 199158 at: 'application/x-connector' put: 'con'; 199159 at: 'application/x-cpio' put: 'cpio'; 199160 at: 'application/x-csh' put: 'csh'; 199161 at: 'application/x-dvi' put: 'dvi'; 199162 at: 'application/x-expandedbook' put: 'ebk'; 199163 at: 'application/x-fontbitmap' put: 'pcf'; 199164 at: 'application/x-fontdataforktruetype' put: 'dfont'; 199165 at: 'application/x-fontopentype' put: 'otf'; 199166 at: 'application/x-fontpostscripttype1' put: 'pfa'; 199167 at: 'application/x-fontsuitcase' put: 'suit'; 199168 at: 'application/x-fonttruetype' put: 'ttf'; 199169 at: 'application/x-gtar' put: 'gtar'; 199170 at: 'application/x-hdf' put: 'hdf'; 199171 at: 'application/x-javascript' put: 'js'; 199172 at: 'application/x-latex' put: 'latex'; 199173 at: 'application/x-msaddr' put: 'adr'; 199174 at: 'application/x-mswallet' put: 'wlt'; 199175 at: 'application/x-netcdf' put: 'cdf'; 199176 at: 'application/x-pgp-plugin' put: 'pgp'; 199177 at: 'application/x-sh' put: 'sh'; 199178 at: 'application/x-shar' put: 'shar'; 199179 at: 'application/x-shockwave-flash' put: 'swf'; 199180 at: 'application/x-stuffit' put: 'sit'; 199181 at: 'application/x-sv4cpio' put: 'sv4cpio'; 199182 at: 'application/x-sv4crc' put: 'sv4crc'; 199183 at: 'application/x-tar' put: 'tar'; 199184 at: 'application/x-texinfo' put: 'texi'; 199185 at: 'application/x-troff' put: 'tr'; 199186 at: 'application/x-troff-man' put: 'man'; 199187 at: 'application/x-troff-me' put: 'me'; 199188 at: 'application/x-troff-ms' put: 'ms'; 199189 at: 'application/x-wais-source' put: 'wsrc'; 199190 at: 'application/x.tex' put: 'tex'; 199191 at: 'application/zip' put: 'zip'; 199192 at: 'audio/aiff' put: 'aiff'; 199193 at: 'audio/basic' put: 'au'; 199194 at: 'audio/midi' put: 'midi'; 199195 at: 'audio/mpeg' put: 'mp3'; 199196 at: 'audio/wav' put: 'wav'; 199197 at: 'audio/x-aiff' put: 'aiff'; 199198 at: 'audio/x-dspeech' put: 'cht'; 199199 at: 'audio/x-midi' put: 'mid'; 199200 at: 'audio/x-mp4-audio' put: 'm4'; 199201 at: 'audio/x-ms-wma' put: 'wma'; 199202 at: 'audio/x-pn-realaudio' put: 'ram'; 199203 at: 'audio/x-pn-realaudio-plugin' put: 'rpm'; 199204 at: 'audio/x-quicktime-protected' put: 'm4p'; 199205 at: 'audio/x-quicktime-protected-b' put: 'm4b'; 199206 at: 'audio/x-realaudio' put: 'ra'; 199207 at: 'audio/x-wav' put: 'wav'; 199208 at: 'i-world/i-vrml' put: 'ivr'; 199209 at: 'image/bmp' put: 'bmp'; 199210 at: 'image/gif' put: 'gif'; 199211 at: 'image/ief' put: 'ief'; 199212 at: 'image/jpeg' put: 'jpg'; 199213 at: 'image/png' put: 'png'; 199214 at: 'image/tiff' put: 'tiff'; 199215 at: 'image/vnd' put: 'dxf'; 199216 at: 'image/vnd' put: 'dwg'; 199217 at: 'image/x-cmu-rast' put: 'ras'; 199218 at: 'image/x-freehand' put: 'fhc'; 199219 at: 'image/x-portable-anymap' put: 'pnm'; 199220 at: 'image/x-portable-bitmap' put: 'pbm'; 199221 at: 'image/x-portable-graymap' put: 'pgm'; 199222 at: 'image/x-portable-pixmap' put: 'ppm'; 199223 at: 'image/x-rgb' put: 'rgb'; 199224 at: 'image/x-xbitmap' put: 'xbm'; 199225 at: 'image/x-xwindowdump' put: 'xwd'; 199226 at: 'message/rfc822' put: 'mime'; 199227 at: 'model/vrml' put: 'vrml'; 199228 at: 'text/css' put: 'css'; 199229 at: 'text/html' put: 'html'; 199230 at: 'text/parsnegar-document' put: 'pgr'; 199231 at: 'text/plain' put: 'text'; 199232 at: 'text/rtf' put: 'rtf'; 199233 at: 'text/tab-separated-values' put: 'tsv'; 199234 at: 'text/x-css' put: 'css'; 199235 at: 'text/x-setext' put: 'etx'; 199236 at: 'text/xml' put: 'xml'; 199237 at: 'video/avi' put: 'avi'; 199238 at: 'video/mov' put: 'mov'; 199239 at: 'video/mpeg' put: 'mpeg'; 199240 at: 'video/mpg' put: 'mpg'; 199241 at: 'video/quicktime' put: 'qt'; 199242 at: 'video/vnd.vivo' put: 'vivo'; 199243 at: 'video/x-mp4-video' put: 'mp4v'; 199244 at: 'video/x-mpeg' put: 'mpeg'; 199245 at: 'video/x-ms-asf' put: 'asf'; 199246 at: 'video/x-ms-asf' put: 'asx'; 199247 at: 'video/x-ms-wm' put: 'wm'; 199248 at: 'video/x-ms-wmv' put: 'wmv'; 199249 at: 'video/x-sgi.movie' put: 'movie'; 199250 at: 'video/x-videogram' put: 'vgm'; 199251 at: 'video/x-videogram-plugin' put: 'vgp'; 199252 yourself. 199253 ^DefaultSuffixes 199254 199255 199256"| stream reverse | 199257stream := StandardFileStream forceNewFileNamed: 'foobar.txt'. 199258reverse := OrderedCollection new. 199259MIMEType mimeMappings associationsDo: [:m | 199260 m value do: [:e | reverse add: m key->e]]. 199261sorted := SortedCollection sortBlock: [:n1 :n2 | n1 value printString <= n2 value printString]. 199262sorted addAll: reverse. 199263sorted do: [:s | 199264 stream nextPutAll: ' at: '''. 199265 stream nextPutAll: s value printString. 199266 stream nextPutAll: ''' put: '''. 199267 stream nextPutAll: s key. 199268 stream nextPutAll: ''';';cr]. 199269stream close." 199270! ! 199271 199272!MIMEType class methodsFor: 'class initialization' stamp: 'michael.rueger 2/24/2009 18:43'! 199273initializeStandardMIMETypes 199274 "MIMEType initializeStandardMIMETypes" 199275 199276 StandardMIMEMappings := Dictionary new. 199277 self standardMIMETypes keysAndValuesDo:[:extension :mimeStrings | 199278 StandardMIMEMappings 199279 at: extension asString asLowercase 199280 put: (mimeStrings collect: [:mimeString | MIMEType fromMIMEString: mimeString]). 199281 ].! ! 199282 199283!MIMEType class methodsFor: 'class initialization' stamp: 'michael.rueger 2/24/2009 18:43'! 199284standardMIMETypes 199285 "We had to split this method because of the 256 literal limit in methods. 199286 Please keep it in alphabetical order for easier maintenance." 199287 "MIMEType standardMIMETypes" 199288 199289 | mimeTypes | 199290 mimeTypes := self standardMIMETypes2. 199291 mimeTypes 199292 at: 'a' put: #('application/octet-stream'); 199293 at: 'aam' put: #('application/x-authorware-map'); 199294 at: 'aas' put: #('application/x-authorware-map'); 199295 at: 'adr' put: #('application/x-msaddr'); 199296 at: 'ai' put: #('application/postscript'); 199297 at: 'aif' put: #('audio/x-aiff'); 199298 at: 'aifc' put: #('audio/x-aiff'); 199299 at: 'aiff' put: #('audio/aiff' 'audio/x-aiff'); 199300 at: 'arc' put: #('application/octet-stream'); 199301 at: 'asf' put: #('video/x-ms-asf'); 199302 at: 'asx' put: #('video/x-ms-asf'); 199303 at: 'au' put: #('audio/basic'); 199304 at: 'avi' put: #('video/avi'); 199305 at: 'axs' put: #('application/olescript'); 199306 at: 'bcpio' put: #('application/x-bcpio'); 199307 at: 'bdf' put: #('application/x-fontbitmap'); 199308 at: 'bin' put: #('application/octet-stream'); 199309 at: 'bmp' put: #('image/bmp'); 199310 at: 'c' put: #('text/plain'); 199311 at: 'cdf' put: #('application/x-netcdf'); 199312 at: 'chat' put: #('application/x-chat'); 199313 at: 'cht' put: #('audio/x-dspeech'); 199314 at: 'class' put: #('application/octet-stream'); 199315 at: 'con' put: #('application/x-connector'); 199316 at: 'cpio' put: #('application/x-cpio'); 199317 at: 'cpp' put: #('text/plain'); 199318 at: 'cpt' put: #('application/mac-compactpro'); 199319 at: 'csh' put: #('application/x-csh'); 199320 at: 'css' put: #('text/css' 'text/x-css'); 199321 at: 'dfon' put: #('application/x-fontdataforktruetype'); 199322 at: 'dfont' put: #('application/x-fontdataforktruetype'); 199323 at: 'dms' put: #('application/octet-stream'); 199324 at: 'doc' put: #('application/ms-word-document' 'application/msword'); 199325 at: 'dot' put: #('application/msword'); 199326 at: 'dump' put: #('application/octet-stream'); 199327 at: 'dus' put: #('audio/x-dspeech'); 199328 at: 'dvi' put: #('application/x-dvi'); 199329 at: 'dwg' put: #('image/vnd'); 199330 at: 'dxf' put: #('image/vnd'); 199331 at: 'ebk' put: #('application/x-expandedbook'); 199332 at: 'eps' put: #('application/postscript'); 199333 at: 'etx' put: #('text/x-setext'); 199334 at: 'exe' put: #('application/octet-stream'); 199335 at: 'ffil' put: #('application/x-fontsuitcase'); 199336 at: 'fh4' put: #('image/x-freehand'); 199337 at: 'fh5' put: #('image/x-freehand'); 199338 at: 'fhc' put: #('image/x-freehand'); 199339 at: 'frl' put: #('application/freeloader'); 199340 at: 'gif' put: #('image/gif'); 199341 at: 'gtar' put: #('application/x-gtar'); 199342 at: 'gtaru' put: #('application/x-gtar'); 199343 at: 'gz' put: #('application/gzip'); 199344 at: 'h' put: #('text/plain'); 199345 at: 'hdf' put: #('application/x-hdf'); 199346 at: 'hqx' put: #('application/mac-binhex40' 'application/octet-stream'); 199347 at: 'htm' put: #('text/html' 'text/plain'); 199348 at: 'html' put: #('text/html' 'text/plain'); 199349 at: 'ief' put: #('image/ief'); 199350 at: 'ips' put: #('application/ips'); 199351 at: 'ivr' put: #('i-world/i-vrml'); 199352 at: 'java' put: #('text/plain'); 199353 at: 'jfif' put: #('image/jpeg'); 199354 at: 'jfif-tbnl' put: #('image/jpeg'); 199355 at: 'jpe' put: #('image/jpeg'); 199356 at: 'jpeg' put: #('image/jpeg'); 199357 at: 'jpg' put: #('image/jpeg'); 199358 at: 'js' put: #('application/x-javascript'); 199359 at: 'latex' put: #('application/x-latex'); 199360 at: 'lha' put: #('application/octet-stream'); 199361 at: 'lwfn' put: #('application/x-fontpostscripttype1'); 199362 at: 'lzh' put: #('application/octet-stream'); 199363 at: 'm4' put: #('audio/x-mp4-audio'); 199364 at: 'm4b' put: #('audio/x-quicktime-protected-b'); 199365 at: 'm4p' put: #('audio/x-quicktime-protected'); 199366 at: 'm4v' put: #('video/x-mp4-video'); 199367 at: 'man' put: #('application/x-troff-man'); 199368 at: 'me' put: #('application/x-troff-me'); 199369 at: 'mid' put: #('audio/midi' 'audio/x-midi'); 199370 at: 'midi' put: #('audio/midi'); 199371 at: 'mime' put: #('message/rfc822'); 199372 at: 'mov' put: #('video/mov'); 199373 at: 'movie' put: #('video/x-sgi-movie' 'video/x-sgi.movie'); 199374 at: 'mp2' put: #('audio/mpeg'); 199375 at: 'mp3' put: #('audio/mpeg' 'audio/x-mpeg'); 199376 at: 'mp4' put: #('video/x-mp4-video'); 199377 at: 'mp4v' put: #('video/x-mp4-video'); 199378 at: 'mpe' put: #('video/mpeg'); 199379 at: 'mpeg' put: #('video/mpeg' 'video/x-mpeg'); 199380 at: 'mpg' put: #('video/mpg' 'video/mpeg' 'video/x-mpeg'); 199381 at: 'mpga' put: #('audio/mpeg'); 199382 at: 'ms' put: #('application/x-troff-ms'); 199383 at: 'mv' put: #('video/x-sgi-movie'); yourself. 199384 ^mimeTypes! ! 199385 199386!MIMEType class methodsFor: 'class initialization' stamp: 'michael.rueger 2/24/2009 18:43'! 199387standardMIMETypes2 199388 "MIMEType standardMimeTypes2" 199389 "We had to split this method because of the 256 literal limit in methods." 199390 | mimeTypes | 199391 mimeTypes := Dictionary new: 100. 199392 mimeTypes 199393 at: 'nc' put: #('application/x-netcdf'); 199394 at: 'o' put: #('application/octet-stream'); 199395 at: 'oda' put: #('application/oda'); 199396 at: 'ogg' put: #('audio/ogg'); 199397 at: 'otf' put: #('application/x-fontopentype'); 199398 at: 'otto' put: #('application/x-fontopentype'); 199399 at: 'pbm' put: #('image/x-portable-bitmap'); 199400 at: 'pcf' put: #('application/x-fontbitmap'); 199401 at: 'pdf' put: #('application/pdf'); 199402 at: 'pfa' put: #('application/x-fontpostscripttype1'); 199403 at: 'pfb' put: #('application/x-fontpostscripttype1'); 199404 at: 'pgm' put: #('image/x-portable-graymap'); 199405 at: 'pgp' put: #('application/x-pgp-plugin'); 199406 at: 'pgr' put: #('text/parsnegar-document'); 199407 at: 'pl' put: #('text/plain'); 199408 at: 'png' put: #('image/png'); 199409 at: 'pnm' put: #('image/x-portable-anymap'); 199410 at: 'pot' put: #('application/vnd.ms-powerpoint'); 199411 at: 'ppa' put: #('application/vnd.ms-powerpoint'); 199412 at: 'ppm' put: #('image/x-portable-pixmap'); 199413 at: 'pps' put: #('application/vnd.ms-powerpoint'); 199414 at: 'ppt' put: #('application/mspowerpoint'); 199415 at: 'ppz' put: #('application/vnd.ms-powerpoint'); 199416 at: 'pr' put: #('application/x-squeak-project'); 199417 at: 'ps' put: #('application/postscript'); 199418 at: 'pwz' put: #('application/vnd.ms-powerpoint'); 199419 at: 'qt' put: #('video/quicktime'); 199420 at: 'ra' put: #('audio/x-realaudio'); 199421 at: 'ram' put: #('audio/x-pn-realaudio'); 199422 at: 'ras' put: #('image/x-cmu-rast'); 199423 at: 'rgb' put: #('image/x-rgb'); 199424 at: 'rm' put: #('audio/x-pn-realaudio'); 199425 at: 'roff' put: #('application/x-troff'); 199426 at: 'rpm' put: #('audio/x-pn-realaudio-plugin'); 199427 at: 'rtc' put: #('application/rtc'); 199428 at: 'rtf' put: #('text/rtf' 'application/rtf'); 199429 at: 'rtx' put: #('application/rtf'); 199430 at: 'saveme' put: #('application/octet-stream'); 199431 at: 'sfnt' put: #('application/x-fontsuitcase'); 199432 at: 'sh' put: #('application/x-sh'); 199433 at: 'shar' put: #('application/x-shar'); 199434 at: 'sit' put: #('application/x-stuffit'); 199435 at: 'snd' put: #('audio/basic'); 199436 at: 'spx' put: #('audio/x-speex'); 199437 at: 'src' put: #('application/x-wais-source'); 199438 at: 'sts' put: #('application/x-squeak-source'); 199439 at: 'suit' put: #('application/x-fontsuitcase'); 199440 at: 'sv4cpio' put: #('application/x-sv4cpio'); 199441 at: 'sv4crc' put: #('application/x-sv4crc'); 199442 at: 'swf' put: #('application/x-shockwave-flash'); 199443 at: 't' put: #('application/x-troff'); 199444 at: 'tar' put: #('application/x-tar'); 199445 at: 'tbk' put: #('application/toolbook'); 199446 at: 'tex' put: #('application/x.tex'); 199447 at: 'texi' put: #('application/x-texinfo'); 199448 at: 'texinfo' put: #('application/x-texinfo'); 199449 at: 'text' put: #('text/plain'); 199450 at: 'tfil' put: #('application/x-fontsuitcase'); 199451 at: 'tif' put: #('image/tiff'); 199452 at: 'tiff' put: #('image/tiff'); 199453 at: 'tr' put: #('application/x-troff'); 199454 at: 'tsv' put: #('text/tab-separated-values'); 199455 at: 'ttc' put: #('application/x-fonttruetype'); 199456 at: 'ttcf' put: #('application/x-fonttruetype'); 199457 at: 'ttf' put: #('application/x-fonttruetype'); 199458 at: 'txt' put: #('text/plain'); 199459 at: 'ua' put: #('text/plain'); 199460 at: 'ustar' put: #('audio/basic'); 199461 at: 'uu' put: #('application/octet-stream'); 199462 at: 'vgm' put: #('video/x-videogram'); 199463 at: 'vgp' put: #('video/x-videogram-plugin'); 199464 at: 'vgx' put: #('video/x-videogram'); 199465 at: 'viv' put: #('video/vnd.vivo'); 199466 at: 'vivo' put: #('video/vnd.vivo'); 199467 at: 'vrml' put: #('model/vrml'); 199468 at: 'wav' put: #('audio/wav' 'audio/x-wav'); 199469 at: 'wid' put: #('application/x-DemoShield'); 199470 at: 'wiz' put: #('application/msword'); 199471 at: 'wlt' put: #('application/x-mswallet'); 199472 at: 'wm' put: #('video/x-ms-wm'); 199473 at: 'wma' put: #('audio/x-ms-wma'); 199474 at: 'wmv' put: #('video/x-ms-wmv'); 199475 at: 'wrl' put: #('model/vrml'); 199476 at: 'wsrc' put: #('application/x-wais-source'); 199477 at: 'xbm' put: #('image/x-xbitmap'); 199478 at: 'xlb' put: #('application/vnd.ms-excel'); 199479 at: 'xls' put: #('application/vnd.ms-excel'); 199480 at: 'xml' put: #('text/xml' 'text/html'); 199481 at: 'xpm' put: #('image/x-xpixmap'); 199482 at: 'xul' put: #('application/vnd.mozilla.xul+xml'); 199483 at: 'xwd' put: #('image/x-xwindowdump'); 199484 at: 'z' put: #('application/x-compress'); 199485 at: 'zip' put: #('application/zip'); 199486 at: 'zpa' put: #('application/pcphoto'); 199487 yourself. 199488 ^mimeTypes 199489! ! 199490 199491 199492!MIMEType class methodsFor: 'instance creation' stamp: 'mir 3/6/2002 13:07'! 199493contentTypeURLEncoded 199494 ^self main: 'application' sub: 'x-www-form-urlencoded'! ! 199495 199496!MIMEType class methodsFor: 'instance creation' stamp: 'mir 3/4/2002 17:06'! 199497defaultHTML 199498 ^self main: 'text' sub: 'html'! ! 199499 199500!MIMEType class methodsFor: 'instance creation' stamp: 'mir 3/4/2002 15:25'! 199501defaultStream 199502 ^self main: 'application' sub: 'octet-stream'! ! 199503 199504!MIMEType class methodsFor: 'instance creation' stamp: 'mir 3/4/2002 15:23'! 199505defaultText 199506 ^self main: 'text' sub: 'plain'! ! 199507 199508!MIMEType class methodsFor: 'instance creation' stamp: 'michael.rueger 2/9/2009 15:02'! 199509forExtensionReturnMimeTypesOrNil: fileExtension 199510 | loweredFileExtension | 199511 199512 loweredFileExtension := fileExtension asLowercase. 199513 199514" Disabled for now as the default Pharo image does not have FFI included. 199515 Should probably be moved into a future version of the directory plugin. 199516 SmalltalkImage current platformName = 'Mac OS' 199517 ifTrue: 199518 [loweredFileExtension = '' ifTrue: [^nil]. 199519 mime := MacUTI callGetMimeTypeOrNilForFileExtension: loweredFileExtension]. 199520 mime ifNotNil: [^Array with: mime]. 199521" 199522 ^self mimeMappings at: loweredFileExtension ifAbsent: [^nil]! ! 199523 199524!MIMEType class methodsFor: 'instance creation' stamp: 'JMM 12/1/2007 17:03'! 199525forFileNameReturnMimeTypesOrDefault: fileName 199526 | mimeTypes | 199527 mimeTypes := self forFileNameReturnMimeTypesOrNil: fileName. 199528 mimeTypes ifNil: [^Array with: (MIMEType defaultStream)]. 199529 ^mimeTypes! ! 199530 199531!MIMEType class methodsFor: 'instance creation' stamp: 'michael.rueger 2/9/2009 15:02'! 199532forFileNameReturnMimeTypesOrNil: fileName 199533 | ext | 199534 199535 ext := FileDirectory extensionFor: fileName. 199536 199537" Disabled for now as the default Pharo image does not have FFI included. 199538 Should probably be moved into a future version of the directory plugin. 199539 SmalltalkImage current platformName = 'Mac OS' 199540 ifTrue: 199541 [type := MacUTI callGetMimeTypeOrNilForFileExtension: ext. 199542 type ifNil: 199543 [fileType := (FileDirectory default getMacFileTypeAndCreator: fileName) at: 1. 199544 (fileType = '????' or: [fileType = ((ByteArray new: 4 withAll:0) asString asByteString)]) 199545 ifTrue: [^self forExtensionReturnMimeTypesOrNil: ext]. 199546 consider := MacUTI callGetMimeTypeOrNilForOSType: fileType. 199547 consider ifNotNil: [^Array with: consider]] 199548 ifNotNil: 199549 [^Array with: type]]. 199550" 199551 ^self forExtensionReturnMimeTypesOrNil: ext! ! 199552 199553!MIMEType class methodsFor: 'instance creation' stamp: 'JMM 12/1/2007 23:02'! 199554forFileNameReturnSingleMimeTypeOrDefault: fileName 199555 | types | 199556 types := self forFileNameReturnMimeTypesOrDefault: fileName. 199557 ^types first! ! 199558 199559!MIMEType class methodsFor: 'instance creation' stamp: 'JMM 12/1/2007 12:19'! 199560forFileNameReturnSingleMimeTypeOrNil: fileName 199561 | types | 199562 types := self forFileNameReturnMimeTypesOrNil: fileName. 199563 types ifNotNil: [^types first]. 199564 ^nil! ! 199565 199566!MIMEType class methodsFor: 'instance creation' stamp: 'JMM 12/14/2007 11:01'! 199567forURIReturnMimeTypesOrNil: aURI 199568 | ext fileName mimes | 199569 199570 mimes := aURI schemeIsFile 199571 ifTrue: 199572 [fileName := FileDirectory fullPathForURI: aURI. 199573 self forFileNameReturnMimeTypesOrNil: fileName] 199574 ifFalse: 199575 [ext := aURI extension. 199576 self forExtensionReturnMimeTypesOrNil: ext]. 199577 ^mimes 199578 199579! ! 199580 199581!MIMEType class methodsFor: 'instance creation' stamp: 'JMM 12/1/2007 15:31'! 199582forURIReturnSingleMimeTypeOrDefault: aURI 199583 | mimes | 199584 199585 mimes := self forURIReturnMimeTypesOrNil: aURI. 199586 mimes ifNil: [^MIMEType defaultStream]. 199587 ^mimes first 199588 199589! ! 199590 199591!MIMEType class methodsFor: 'instance creation' stamp: 'JMM 12/1/2007 23:15'! 199592forURIReturnSingleMimeTypeOrNil: aURI 199593 | mimes | 199594 199595 mimes := self forURIReturnMimeTypesOrNil: aURI. 199596 mimes ifNil: [^nil]. 199597 ^mimes first 199598 199599! ! 199600 199601!MIMEType class methodsFor: 'instance creation' stamp: 'mir 2/16/2006 23:33'! 199602fromMIMEString: mimeString 199603 | idx main rest sub parameters | 199604 idx := mimeString indexOf: $/. 199605 idx = 0 199606 ifTrue: [self error: 'Illegal mime type string "' , mimeString , '".']. 199607 main := mimeString copyFrom: 1 to: idx-1. 199608 rest := mimeString copyFrom: idx+1 to: mimeString size. 199609 idx := mimeString indexOf: $;. 199610 idx = 0 199611 ifTrue: [sub := rest] 199612 ifFalse: [ 199613 sub := rest copyFrom: 1 to: idx. 199614 parameters := rest copyFrom: idx+1 to: rest size]. 199615 ^self 199616 main: main 199617 sub: sub 199618 parameters: parameters 199619! ! 199620 199621!MIMEType class methodsFor: 'instance creation' stamp: 'mir 3/4/2002 15:22'! 199622main: mainType sub: subType 199623 ^self new 199624 main: mainType; 199625 sub: subType! ! 199626 199627!MIMEType class methodsFor: 'instance creation' stamp: 'mir 2/16/2006 23:33'! 199628main: mainType sub: subType parameters: parameters 199629 ^self new 199630 main: mainType; 199631 sub: subType; 199632 parameters: parameters! ! 199633Object subclass: #MOPTestClassA 199634 uses: Trait3 199635 instanceVariableNames: '' 199636 classVariableNames: '' 199637 poolDictionaries: '' 199638 category: 'Tests-Traits-MOP'! 199639 199640!MOPTestClassA methodsFor: 'local'! 199641c 199642 199643 ^ 'Trait3>>c'! ! 199644 199645!MOPTestClassA methodsFor: 'local'! 199646c3 199647 199648 ^ 'Trait3>>c3'! ! 199649 199650 199651!MOPTestClassA methodsFor: 'trait2 - c'! 199652c2 199653 199654 ^ 'Trait2>>c2'! ! 199655 199656"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 199657 199658MOPTestClassA class 199659 uses: Trait3 classTrait 199660 instanceVariableNames: ''! 199661Object subclass: #MOPTestClassB 199662 uses: Trait1 + Trait2 - {#c} 199663 instanceVariableNames: '' 199664 classVariableNames: '' 199665 poolDictionaries: '' 199666 category: 'Tests-Traits-MOP'! 199667 199668!MOPTestClassB methodsFor: 'trait1 - c'! 199669c 199670 199671 ^ 'Trait1>>c'! ! 199672 199673!MOPTestClassB methodsFor: 'trait1 - c'! 199674c1 199675 199676 ^ 'Trait1>>c1'! ! 199677 199678 199679!MOPTestClassB methodsFor: 'trait2 - c'! 199680c2 199681 199682 ^ 'Trait2>>c2'! ! 199683 199684"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 199685 199686MOPTestClassB class 199687 uses: Trait1 classTrait + Trait2 classTrait 199688 instanceVariableNames: ''! 199689Object subclass: #MOPTestClassC 199690 uses: Trait2 199691 instanceVariableNames: '' 199692 classVariableNames: '' 199693 poolDictionaries: '' 199694 category: 'Tests-Traits-MOP'! 199695 199696!MOPTestClassC methodsFor: 'local' stamp: 'stephane.ducasse 10/7/2008 16:57'! 199697c 199698 199699 ^ 'C>>c'! ! 199700 199701 199702!MOPTestClassC methodsFor: 'trait2 - c'! 199703c2 199704 199705 ^ 'Trait2>>c2'! ! 199706 199707"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 199708 199709MOPTestClassC class 199710 uses: Trait2 classTrait 199711 instanceVariableNames: ''! 199712Object subclass: #MOPTestClassD 199713 uses: Trait2 @ {#c3->#c2} 199714 instanceVariableNames: '' 199715 classVariableNames: '' 199716 poolDictionaries: '' 199717 category: 'Tests-Traits-MOP'! 199718 199719!MOPTestClassD methodsFor: 'trait2 - c'! 199720c 199721 199722 ^ 'Trait2>>c'! ! 199723 199724!MOPTestClassD methodsFor: 'trait2 - c'! 199725c2 199726 199727 ^ 'Trait2>>c2'! ! 199728 199729!MOPTestClassD methodsFor: 'trait2 - c'! 199730c3 199731 199732 ^ 'Trait2>>c2'! ! 199733 199734"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 199735 199736MOPTestClassD class 199737 uses: Trait2 classTrait 199738 instanceVariableNames: ''! 199739TestCase subclass: #MOPTraitTest 199740 instanceVariableNames: '' 199741 classVariableNames: '' 199742 poolDictionaries: '' 199743 category: 'Tests-Traits-MOP'! 199744 199745!MOPTraitTest methodsFor: 'tests' stamp: 'matthew_fulmer 7/29/2009 14:24'! 199746testClass 199747 "self debug: #testClass" 199748 "The class of a compiled method is the class that contains it. 199749 A compiled method is shared." 199750 "methodClass could call 199751 -> methodClassOrTrait" 199752 199753 self assert: (Trait1>>#c) methodClass = Trait1. 199754 self assert: (Trait2>>#c) methodClass = Trait2. 199755 self assert: (MOPTestClassC>>#c) methodClass = MOPTestClassC. 199756 self assert: (MOPTestClassC>>#c2) methodClass = MOPTestClassC. 199757 self assert: (MOPTestClassD>>#c) methodClass = MOPTestClassD. 199758 self assert: (MOPTestClassD>>#c2) methodClass = MOPTestClassD. 199759 self assert: (MOPTestClassD>>#c3) methodClass = MOPTestClassD. 199760 self assert: (MOPTestClassA>>#c2) methodClass = MOPTestClassA. 199761 ! ! 199762 199763!MOPTraitTest methodsFor: 'tests' stamp: 'matthew_fulmer 7/29/2009 14:24'! 199764testOrigin 199765 "self debug: #testClass" 199766 "The origin of a compiledMethod is its defining class or trait." 199767 199768 self assert: (MOPTestClassC>>#c) origin = MOPTestClassC. 199769 self assert: (MOPTestClassA>>#c) origin = Trait3. 199770 self assert: (Trait3>>#c2) origin = Trait2. 199771 self assert: (MOPTestClassA>>#c2) origin = Trait2. 199772 self assert: (MOPTestClassB>>#c) origin = Trait1. 199773 self assert: (MOPTestClassD>>#c3) origin = Trait2. 199774 self assert: (MOPTestClassD>>#c2) origin = Trait2.! ! 199775 199776!MOPTraitTest methodsFor: 'tests' stamp: 'matthew_fulmer 7/29/2009 14:24'! 199777testSelector 199778 "self debug: #testSelector" 199779 "The selector of a compiled method should be its name. 199780 An aliased method should have the name of its alias name." 199781 199782 self assert: (MOPTestClassA>>#c) selector = #c. 199783 self assert: (MOPTestClassC>>#c) selector = #c. 199784 self assert: (Trait3>>#c) selector = #c. 199785 self assert: (Trait3>>#c2) selector = #c2. 199786 self assert: (MOPTestClassD>>#c3) selector = #c3.! ! 199787FileDirectory subclass: #MacFileDirectory 199788 instanceVariableNames: '' 199789 classVariableNames: 'TypeToMimeMappings' 199790 poolDictionaries: '' 199791 category: 'Files-Directories'! 199792!MacFileDirectory commentStamp: '<historical>' prior: 0! 199793I represent a Macintosh FileDirectory. 199794! 199795 199796 199797!MacFileDirectory methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'! 199798fullNameFor: fileName 199799 "Return a corrected, fully-qualified name for the given file name. If the given name is already a full path (i.e., it contains a delimiter character), assume it is already a fully-qualified name. Otherwise, prefix it with the path to this directory. In either case, correct the local part of the file name." 199800 "Details: Note that path relative to a directory, such as '../../foo' are disallowed by this algorithm. Also note that this method is tolerent of a nil argument -- is simply returns nil in this case." 199801 "Fix by hmm: for a file in the root directory of a volume on MacOS, the filePath (name of the directory) is not recognizable as an absolute path anymore (it has no delimiters). Therefore, the original fileName is tested for absoluteness, and the filePath is only made absolute if the original fileName was not absolute" 199802 199803 | correctedLocalName prefix | 199804 fileName isEmptyOrNil ifTrue: [^ fileName]. 199805 DirectoryClass splitName: fileName to: 199806 [:filePath :localName | 199807 correctedLocalName := localName isEmpty 199808 ifFalse: [self checkName: localName fixErrors: true] 199809 ifTrue: [localName]. 199810 prefix := (DirectoryClass isAbsolute: fileName) 199811 ifTrue: [filePath] 199812 ifFalse: [self fullPathFor: filePath]]. 199813 prefix isEmpty 199814 ifTrue: [^correctedLocalName]. 199815 prefix last = self pathNameDelimiter 199816 ifTrue:[^ prefix, correctedLocalName] 199817 ifFalse:[^ prefix, self slash, correctedLocalName]! ! 199818 199819 199820!MacFileDirectory methodsFor: 'file operations' stamp: 'yo 12/19/2003 21:15'! 199821fullPathFor: path 199822 "Return the fully-qualified path name for the given file." 199823 path isEmptyOrNil ifTrue: [^ pathName asSqueakPathName]. 199824 (self class isAbsolute: path) ifTrue: [^ path]. 199825 pathName asSqueakPathName = '' "Root dir?" 199826 ifTrue: [ ^path]. 199827 ^(path first = $:) 199828 ifTrue: [ pathName asSqueakPathName, path ] 199829 ifFalse: [pathName asSqueakPathName, ':' , path]! ! 199830 199831!MacFileDirectory methodsFor: 'file operations' stamp: 'stephaneducasse 2/4/2006 20:31'! 199832mimeTypesFor: fileName 199833 "Return a list of MIME types applicable to the receiver. This default implementation uses the file name extension to figure out what we're looking at but specific subclasses may use other means of figuring out what the type of some file is. Some systems like the macintosh use meta data on the file to indicate data type" 199834 | typeCreator type | 199835 typeCreator := self getMacFileTypeAndCreator: ((self fullNameFor: fileName)). 199836 type := (typeCreator at: 1) asLowercase. 199837 ^TypeToMimeMappings at: type ifAbsent:[super mimeTypesFor: fileName]! ! 199838 199839"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 199840 199841MacFileDirectory class 199842 instanceVariableNames: ''! 199843 199844!MacFileDirectory class methodsFor: '*Network-MIME' stamp: 'JMM 4/3/2006 11:04'! 199845getTypeToMimeMappings 199846 ^TypeToMimeMappings! ! 199847 199848 199849!MacFileDirectory class methodsFor: '*network-uri' stamp: 'JMM 2/17/2006 19:16'! 199850privateFullPathForURI: aURI 199851 | first path | 199852 199853 path := String streamContents: [ :s | 199854 first := false. 199855 aURI pathComponents do: [ :p | 199856 first ifTrue: [ s nextPut: self pathNameDelimiter ]. 199857 first := true. 199858 s nextPutAll: p ] ]. 199859 aURI path last = $/ ifTrue: [path := path,FileDirectory slash]. 199860 ^path unescapePercents 199861! ! 199862 199863 199864!MacFileDirectory class methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:32'! 199865initializeTypeToMimeMappings 199866 "MacFileDirectory initializeTypeToMimeMappings" 199867 TypeToMimeMappings := Dictionary new. 199868 #( 199869 "format" 199870 "(abcd ('image/gif'))" 199871 ) do:[:spec| 199872 TypeToMimeMappings at: spec first asString put: spec last. 199873 ]. 199874! ! 199875 199876!MacFileDirectory class methodsFor: 'initialization' stamp: 'nk 12/5/2002 11:17'! 199877isAbsolute: fileName 199878 "Return true if the given fileName is absolute. The rules are: 199879 199880If a path begins with a colon, it is relative. 199881Otherwise, 199882 If it contains a colon anywhere, it is absolute and the first component is the volume name. 199883 Otherwise, 199884 It is relative." 199885 199886 ^fileName first ~= $: 199887 and: [ fileName includes: $: ]! ! 199888 199889 199890!MacFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:06'! 199891isActiveDirectoryClass 199892 ^ super isActiveDirectoryClass 199893 and: [(SmalltalkImage current getSystemAttribute: 1201) isNil 199894 or: [(SmalltalkImage current getSystemAttribute: 1201) asNumber <= 31]]! ! 199895 199896!MacFileDirectory class methodsFor: 'platform specific' stamp: 'di 5/11/1999 08:53'! 199897isCaseSensitive 199898 "Mac OS ignores the case of file names" 199899 ^ false! ! 199900 199901!MacFileDirectory class methodsFor: 'platform specific' stamp: 'stephaneducasse 2/4/2006 20:32'! 199902makeAbsolute: path 199903 "Ensure that path looks like an absolute path" 199904 | absolutePath | 199905 (self isAbsolute: path) 199906 ifTrue: [ ^path ]. 199907 "If a path begins with a colon, it is relative." 199908 absolutePath := (path first = $:) 199909 ifTrue: [ path copyWithoutFirst ] 199910 ifFalse: [ path ]. 199911 (self isAbsolute: absolutePath) 199912 ifTrue: [ ^absolutePath ]. 199913 "Otherwise, if it contains a colon anywhere, it is absolute and the first component is the volume name." 199914 ^absolutePath, ':'! ! 199915 199916!MacFileDirectory class methodsFor: 'platform specific' stamp: 'nk 3/13/2003 10:59'! 199917makeRelative: path 199918 "Ensure that path looks like an relative path" 199919 ^path first = $: 199920 ifTrue: [ path ] 199921 ifFalse: [ ':', path ]! ! 199922 199923!MacFileDirectory class methodsFor: 'platform specific' stamp: 'jm 12/4/97 22:57'! 199924pathNameDelimiter 199925 199926 ^ $: 199927! ! 199928TestCase subclass: #MacFileDirectoryTest 199929 instanceVariableNames: '' 199930 classVariableNames: '' 199931 poolDictionaries: '' 199932 category: 'Tests-Files'! 199933 199934!MacFileDirectoryTest methodsFor: 'test' stamp: 'sd 10/27/2003 18:05'! 199935testMacFileDirectory 199936 "(self run: #testMacFileDirectory)" 199937 199938 "This fails before the the fix if the Squeak directory is on the root 199939 directory like: 'HardDisk:Squeak' 199940 But should work both before and after the fix of John if there is several 199941 directories in the hieracry: HardDisk:User:Squeak" 199942 "If somebody can find a way to make the test failed all the time when the fix is not 199943 present we should replace it" 199944 199945 self assert: (FileDirectory default fullName) = (FileDirectory default fullNameFor: (FileDirectory default fullName))! ! 199946 199947!MacFileDirectoryTest methodsFor: 'test' stamp: 'kfr 7/28/2004 15:06'! 199948testMacIsAbsolute 199949 "(self selector: #testMacIsAbsolute) run" 199950 199951 199952 self deny: (MacFileDirectory isAbsolute: 'Volumes'). 199953 self assert: (MacFileDirectory isAbsolute: 'Volumes:Data:Stef'). 199954 self deny: (MacFileDirectory isAbsolute: ':Desktop:test.st')! ! 199955 199956!MacFileDirectoryTest methodsFor: 'test' stamp: 'sd 10/27/2003 18:02'! 199957testMakeAbsolute 199958 199959 self assert: (MacFileDirectory isAbsolute: (MacFileDirectory makeAbsolute: 'Data')). 199960 self assert: (MacFileDirectory isAbsolute: (MacFileDirectory makeAbsolute: ':Data')). 199961! ! 199962MacFileDirectory subclass: #MacHFSPlusFileDirectory 199963 instanceVariableNames: '' 199964 classVariableNames: '' 199965 poolDictionaries: '' 199966 category: 'Files-Directories'! 199967 199968"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 199969 199970MacHFSPlusFileDirectory class 199971 instanceVariableNames: ''! 199972 199973!MacHFSPlusFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:06'! 199974isActiveDirectoryClass 199975 "Ok, lets see if we support HFS Plus file names, the long ones" 199976 199977 ^ (self pathNameDelimiter = self primPathNameDelimiter) and: [(SmalltalkImage current getSystemAttribute: 1201) notNil and: [(SmalltalkImage current getSystemAttribute: 1201) asNumber > 31]]! ! 199978 199979!MacHFSPlusFileDirectory class methodsFor: 'platform specific' stamp: 'JMM 11/14/1935 00:02'! 199980maxFileNameLength 199981 199982 ^ 255! ! 199983HostWindowProxy subclass: #MacOS9WindowProxy 199984 instanceVariableNames: 'windowClass windowAttributes' 199985 classVariableNames: '' 199986 poolDictionaries: '' 199987 category: 'Graphics-External-Ffenestri'! 199988 199989!MacOS9WindowProxy methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 199990attributes 199991 | val | 199992 val := ByteArray new: 8. 199993 val 199994 unsignedLongAt: 1 199995 put: windowClass 199996 bigEndian: SmalltalkImage current isBigEndian. 199997 val 199998 unsignedLongAt: 5 199999 put: windowAttributes 200000 bigEndian: SmalltalkImage current isBigEndian. 200001 ^ val! ! 200002 200003!MacOS9WindowProxy methodsFor: 'accessing' stamp: 'JMM 10/7/2004 17:38'! 200004windowAttributes 200005 ^windowAttributes 200006! ! 200007 200008!MacOS9WindowProxy methodsFor: 'accessing' stamp: 'JMM 10/7/2004 17:38'! 200009windowAttributes: aNumber 200010 windowAttributes := aNumber! ! 200011 200012!MacOS9WindowProxy methodsFor: 'accessing' stamp: 'JMM 10/7/2004 17:38'! 200013windowClass 200014 ^windowClass 200015! ! 200016 200017!MacOS9WindowProxy methodsFor: 'accessing' stamp: 'JMM 10/7/2004 17:38'! 200018windowClass: aNumber 200019 windowClass := aNumber! ! 200020 200021 200022!MacOS9WindowProxy methodsFor: 'metrics' stamp: 'JMM 10/7/2004 20:53'! 200023defaultWindowType 200024 self windowClass: self class documentWindowClass. 200025 self windowAttributes: self class standardDocumentAttributes.! ! 200026 200027"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 200028 200029MacOS9WindowProxy class 200030 instanceVariableNames: ''! 200031 200032!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:40'! 200033altDBoxProc 200034 ^3 200035! ! 200036 200037!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:29'! 200038closeBoxAttribute 200039 ^1! ! 200040 200041!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:40'! 200042dBoxProc 200043 ^1! ! 200044 200045!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:40'! 200046documentProc 200047 ^0! ! 200048 200049!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:39'! 200050documentWindowClass 200051 ^self zoomDocProc! ! 200052 200053!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:41'! 200054floatGrowProc 200055 ^1987 200056! ! 200057 200058!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:41'! 200059floatProc 200060 ^1985 200061! ! 200062 200063!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:42'! 200064floatSideGrowProc 200065 ^1995 200066! ! 200067 200068!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:42'! 200069floatSideProc 200070 ^1993 200071! ! 200072 200073!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:42'! 200074floatSideZoomGrowProc 200075 ^1999! ! 200076 200077!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:42'! 200078floatSideZoomProc 200079 ^1997! ! 200080 200081!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:42'! 200082floatZoomGrowProc 200083 ^1991 200084! ! 200085 200086!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:41'! 200087floatZoomProc 200088 ^1989 200089! ! 200090 200091!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:40'! 200092movableDBoxProc 200093 ^5 200094! ! 200095 200096!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:10'! 200097noAttributes 200098 ^0! ! 200099 200100!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:40'! 200101noGrowDocProc 200102 ^4 200103! ! 200104 200105!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:40'! 200106plainDBox 200107 ^2! ! 200108 200109!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:41'! 200110rDocProc 200111 ^16 200112! ! 200113 200114!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:43'! 200115standardDocumentAttributes 200116 ^self closeBoxAttribute! ! 200117 200118!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:39'! 200119zoomDocProc 200120 ^8! ! 200121 200122!MacOS9WindowProxy class methodsFor: 'constants' stamp: 'JMM 10/8/2004 12:41'! 200123zoomNoGrow 200124 ^12 200125! ! 200126 200127 200128!MacOS9WindowProxy class methodsFor: 'system startup' stamp: 'JMM 10/8/2004 12:28'! 200129isActiveHostWindowProxyClass 200130"Am I active?" 200131 ^SmalltalkImage current platformName = 'Mac OS' and: [SmalltalkImage current osVersion asInteger < 1000]! ! 200132ExternalClipboard subclass: #MacOSClipboard 200133 instanceVariableNames: '' 200134 classVariableNames: '' 200135 poolDictionaries: '' 200136 category: 'System-Clipboard'! 200137 200138!MacOSClipboard methodsFor: 'private' stamp: 'michael.rueger 3/2/2009 12:51'! 200139addUF8StringClipboardData: aString 200140 | ba | 200141 200142 self clearClipboard. 200143 ba := aString convertToWithConverter: (UTF8TextConverter new). 200144 self addClipboardData: ba dataFormat: 'public.utf8-plain-text' 200145! ! 200146HostSystemMenusProxy subclass: #MacOSType 200147 instanceVariableNames: '' 200148 classVariableNames: '' 200149 poolDictionaries: '' 200150 category: 'HostMenus-Mac'! 200151 200152"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 200153 200154MacOSType class 200155 instanceVariableNames: ''! 200156 200157!MacOSType class methodsFor: 'utility' stamp: 'JMM 1/15/2007 12:28'! 200158buildOSTypeFromCharString: folderTypeData 200159 "preserve platform endianness" 200160 200161 ^folderTypeData asByteArray unsignedLongAt: 1 bigEndian: true! ! 200162OSPlatform subclass: #MacOSXPlatform 200163 instanceVariableNames: '' 200164 classVariableNames: '' 200165 poolDictionaries: '' 200166 category: 'System-Platforms'! 200167 200168!MacOSXPlatform methodsFor: '*System-Clipboard' stamp: 'michael.rueger 3/2/2009 10:56'! 200169clipboardClass 200170 ^MacOSClipboard! ! 200171 200172 200173!MacOSXPlatform methodsFor: 'accessing' stamp: 'michael.rueger 2/25/2009 18:18'! 200174platformFamily 200175 ^#MacOSX! ! 200176 200177"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 200178 200179MacOSXPlatform class 200180 instanceVariableNames: ''! 200181 200182!MacOSXPlatform class methodsFor: 'private' stamp: 'sd 3/21/2009 13:52'! 200183isActivePlatform 200184 ^SmalltalkImage current platformName = 'Mac OS' and:[SmalltalkImage current osVersion asNumber >= 1000]! ! 200185HostWindowProxy subclass: #MacOSXWindowProxy 200186 instanceVariableNames: 'windowClass windowAttributes' 200187 classVariableNames: '' 200188 poolDictionaries: '' 200189 category: 'Graphics-External-Ffenestri'! 200190 200191!MacOSXWindowProxy methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 200192attributes 200193 | val | 200194 val := ByteArray new: 8. 200195 val 200196 unsignedLongAt: 1 200197 put: windowClass 200198 bigEndian: SmalltalkImage current isBigEndian. 200199 val 200200 unsignedLongAt: 5 200201 put: windowAttributes 200202 bigEndian: SmalltalkImage current isBigEndian. 200203 ^ val! ! 200204 200205!MacOSXWindowProxy methodsFor: 'accessing' stamp: 'JMM 10/7/2004 17:38'! 200206windowAttributes 200207 ^windowAttributes 200208! ! 200209 200210!MacOSXWindowProxy methodsFor: 'accessing' stamp: 'JMM 10/7/2004 17:38'! 200211windowAttributes: aNumber 200212 windowAttributes := aNumber! ! 200213 200214!MacOSXWindowProxy methodsFor: 'accessing' stamp: 'JMM 10/7/2004 17:38'! 200215windowClass 200216 ^windowClass 200217! ! 200218 200219!MacOSXWindowProxy methodsFor: 'accessing' stamp: 'JMM 10/7/2004 17:38'! 200220windowClass: aNumber 200221 windowClass := aNumber! ! 200222 200223 200224!MacOSXWindowProxy methodsFor: 'metrics' stamp: 'JMM 10/7/2004 20:53'! 200225defaultWindowType 200226 self windowClass: self class documentWindowClass. 200227 self windowAttributes: self class standardDocumentAttributes.! ! 200228 200229"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 200230 200231MacOSXWindowProxy class 200232 instanceVariableNames: ''! 200233 200234!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:19'! 200235activatesAttribute 200236 ^2 raisedTo: 17! ! 200237 200238!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:25'! 200239alertWindowClass 200240 ^1! ! 200241 200242!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:28'! 200243altPlainWindowClass 200244 ^16! ! 200245 200246!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:20'! 200247asyncDragAttribute 200248 ^2 raisedTo: 23! ! 200249 200250!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:16'! 200251closeBoxAttribute 200252 ^2 raisedTo: 0! ! 200253 200254!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:17'! 200255collapseBoxAttribute 200256 ^2 raisedTo: 3! ! 200257 200258!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:19'! 200259compositingAttribute 200260 ^2 raisedTo: 19! ! 200261 200262!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:27'! 200263documentWindowClass 200264 ^6! ! 200265 200266!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:18'! 200267doesNotCycleAttribute 200268 ^2 raisedTo: 15! ! 200269 200270!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:29'! 200271drawerWindowClass 200272 ^20! ! 200273 200274!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:26'! 200275floatingWindowClass 200276 ^5! ! 200277 200278!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:13'! 200279fullZoomAttribute 200280 ^self verticalZoomAttribute bitOr: self horizontalZoomAttribute! ! 200281 200282!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:27'! 200283helpWindowClass 200284 ^10! ! 200285 200286!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:21'! 200287hideOnFullScreenAttribute 200288 ^2 raisedTo: 26! ! 200289 200290!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:20'! 200291hideOnSuspendAttribute 200292 ^2 raisedTo: 24! ! 200293 200294!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:16'! 200295horizontalZoomAttribute 200296 ^2 raisedTo: 1! ! 200297 200298!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:22'! 200299ignoreClicksAttribute 200300 ^2 raisedTo: 29! ! 200301 200302!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:21'! 200303inWindowMenuAttribute 200304 ^2 raisedTo: 27! ! 200305 200306!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:22'! 200307liveResizeAttribute 200308 ^2 raisedTo: 28! ! 200309 200310!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:18'! 200311metalAttribute 200312 ^2 raisedTo: 8! ! 200313 200314!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:26'! 200315modalWindowClass 200316 ^3! ! 200317 200318!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:26'! 200319movableAlertWindowClass 200320 ^2! ! 200321 200322!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:26'! 200323movableModalWindowClass 200324 ^4! ! 200325 200326!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:10'! 200327noAttributes 200328 ^0! ! 200329 200330!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:22'! 200331noConstrainAttribute 200332 ^2 raisedTo: 31! ! 200333 200334!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:20'! 200335noShadowAttribute 200336 ^2 raisedTo: 21! ! 200337 200338!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:18'! 200339noUpdatesAttribute 200340 ^2 raisedTo: 16! ! 200341 200342!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:19'! 200343opaqueForEventsAttribute 200344 ^2 raisedTo: 18! ! 200345 200346!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:28'! 200347overlayWindowClass 200348 ^14! ! 200349 200350!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:28'! 200351plainWindowClass 200352 ^13! ! 200353 200354!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:17'! 200355resizableAttribute 200356 ^2 raisedTo: 4! ! 200357 200358!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:28'! 200359sheetAlertWindowClass 200360 ^15! ! 200361 200362!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:27'! 200363sheetWindowClass 200364 ^11! ! 200365 200366!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:17'! 200367sideTitlebarAttribute 200368 ^2 raisedTo: 5! ! 200369 200370!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:28'! 200371simpleWindowClass 200372 ^18! ! 200373 200374!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 20:40'! 200375standardDocumentAttributes 200376 ^self noConstrainAttribute + self standardHandlerAttribute + self closeBoxAttribute + self fullZoomAttribute + self collapseBoxAttribute + self resizableAttribute 200377 200378 200379"16r8200001E printStringBase: 2 '2r 10000010 00000000 00000000 00011110'"! ! 200380 200381!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:25'! 200382standardFloatingAttributes 200383 ^self closeBoxAttribute + self collapseBoxAttribute 200384! ! 200385 200386!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:21'! 200387standardHandlerAttribute 200388 ^2 raisedTo: 25! ! 200389 200390!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:18'! 200391toolbarButtonAttribute 200392 ^2 raisedTo: 6! ! 200393 200394!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:27'! 200395toolbarWindowClass 200396 ^12! ! 200397 200398!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 17:27'! 200399utilityWindowClass 200400 ^8! ! 200401 200402!MacOSXWindowProxy class methodsFor: 'constants' stamp: 'JMM 10/7/2004 20:31'! 200403verticalZoomAttribute 200404 ^2 raisedTo: 2! ! 200405 200406 200407!MacOSXWindowProxy class methodsFor: 'system startup' stamp: 'JMM 10/8/2004 12:28'! 200408isActiveHostWindowProxyClass 200409"Am I active?" 200410 ^SmalltalkImage current platformName = 'Mac OS' and: [SmalltalkImage current osVersion asInteger >= 1000]! ! 200411ByteTextConverter subclass: #MacRomanTextConverter 200412 instanceVariableNames: '' 200413 classVariableNames: '' 200414 poolDictionaries: '' 200415 category: 'Multilingual-TextConversion'! 200416!MacRomanTextConverter commentStamp: '<historical>' prior: 0! 200417Text converter for Mac Roman. An encoding used for the languages originated from Western Europe area.! 200418 200419 200420"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 200421 200422MacRomanTextConverter class 200423 instanceVariableNames: ''! 200424 200425!MacRomanTextConverter class methodsFor: 'accessing' stamp: 'yo 8/4/2003 12:33'! 200426encodingNames 200427 200428 ^ #('mac-roman' ) copy 200429! ! 200430 200431!MacRomanTextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 19:31'! 200432languageEnvironment 200433 ^Latin1Environment! ! 200434 200435 200436!MacRomanTextConverter class methodsFor: 'initialization' stamp: 'michael.rueger 2/5/2009 14:07'! 200437byteToUnicodeSpec 200438 "Sepcify a table mapping the entries 0x80 to 0xFF to their unicode counterparts by returning a 128 element array.. 200439 The entries 0x00 to 0x7F map to identical values so we don't need to specify them." 200440 200441 "http://en.wikipedia.org/wiki/Mac:=OS:=Roman" 200442 "http://unicode.org/Public/MAPPINGS/VENDORS/APPLE/ROMAN.TXT" 200443 ^#( 200444 16r00C4 16r00C5 16r00C7 16r00C9 16r00D1 16r00D6 16r00DC 16r00E1 200445 16r00E0 16r00E2 16r00E4 16r00E3 16r00E5 16r00E7 16r00E9 16r00E8 200446 200447 16r00EA 16r00EB 16r00ED 16r00EC 16r00EE 16r00EF 16r00F1 16r00F3 200448 16r00F2 16r00F4 16r00F6 16r00F5 16r00FA 16r00F9 16r00FB 16r00FC 200449 200450 16r2020 16r00B0 16r00A2 16r00A3 16r00A7 16r2022 16r00B6 16r00DF 200451 16r00AE 16r00A9 16r2122 16r00B4 16r00A8 16r2260 16r00C6 16r00D8 200452 200453 16r221E 16r00B1 16r2264 16r2265 16r00A5 16r00B5 16r2202 16r2211 200454 16r220F 16r03C0 16r222B 16r00AA 16r00BA 16r03A9 16r00E6 16r00F8 200455 200456 16r00BF 16r00A1 16r00AC 16r221A 16r0192 16r2248 16r2206 16r00AB 200457 16r00BB 16r2026 16r00A0 16r00C0 16r00C3 16r00D5 16r0152 16r0153 200458 200459 16r2013 16r2014 16r201C 16r201D 16r2018 16r2019 16r00F7 16r25CA 200460 16r00FF 16r0178 16r2044 16r20AC 16r2039 16r203A 16rFB01 16rFB02 200461 200462 16r2021 16r00B7 16r201A 16r201E 16r2030 16r00C2 16r00CA 16r00C1 200463 16r00CB 16r00C8 16r00CD 16r00CE 16r00CF 16r00CC 16r00D3 16r00D4 200464 200465 16rF8FF 16r00D2 16r00DA 16r00DB 16r00D9 16r0131 16r02C6 16r02DC 200466 16r00AF 16r00D8 16r00D9 16r00DA 16r00B8 16r00DD 16r00DB 16r02C7 200467 200468)! ! 200469Object subclass: #Magnitude 200470 instanceVariableNames: '' 200471 classVariableNames: '' 200472 poolDictionaries: '' 200473 category: 'Kernel-Numbers'! 200474!Magnitude commentStamp: 'sd 9/4/2005 10:14' prior: 0! 200475I'm the abstract class Magnitude that provides common protocol for objects that have 200476the ability to be compared along a linear dimension, such as dates or times. 200477Subclasses of Magnitude include Date, ArithmeticValue, and Time, as well as 200478Character and LookupKey. 200479 200480 200481My subclasses should implement 200482 < aMagnitude 200483 = aMagnitude 200484 hash 200485 200486Here are some example of my protocol: 200487 3 > 4 200488 5 = 6 200489 100 max: 9 200490 7 between: 5 and: 10 200491! 200492 200493 200494!Magnitude methodsFor: '*kernel-extensions-streaming' stamp: 'kph 9/27/2007 22:10'! 200495putOn: aStream 200496 200497 (aStream isBinary ifTrue: [ self asByteArray ] ifFalse: [ self asString]) putOn: aStream 200498 200499 ! ! 200500 200501 200502!Magnitude methodsFor: 'comparing'! 200503< aMagnitude 200504 "Answer whether the receiver is less than the argument." 200505 200506 ^self subclassResponsibility! ! 200507 200508!Magnitude methodsFor: 'comparing'! 200509<= aMagnitude 200510 "Answer whether the receiver is less than or equal to the argument." 200511 200512 ^(self > aMagnitude) not! ! 200513 200514!Magnitude methodsFor: 'comparing'! 200515= aMagnitude 200516 "Compare the receiver with the argument and answer with true if the 200517 receiver is equal to the argument. Otherwise answer false." 200518 200519 ^self subclassResponsibility! ! 200520 200521!Magnitude methodsFor: 'comparing'! 200522> aMagnitude 200523 "Answer whether the receiver is greater than the argument." 200524 200525 ^aMagnitude < self! ! 200526 200527!Magnitude methodsFor: 'comparing'! 200528>= aMagnitude 200529 "Answer whether the receiver is greater than or equal to the argument." 200530 200531 ^(self < aMagnitude) not! ! 200532 200533!Magnitude methodsFor: 'comparing'! 200534between: min and: max 200535 "Answer whether the receiver is less than or equal to the argument, max, 200536 and greater than or equal to the argument, min." 200537 200538 ^self >= min and: [self <= max]! ! 200539 200540!Magnitude methodsFor: 'comparing'! 200541hash 200542 "Hash must be redefined whenever = is redefined." 200543 200544 ^self subclassResponsibility! ! 200545 200546 200547!Magnitude methodsFor: 'testing'! 200548max: aMagnitude 200549 "Answer the receiver or the argument, whichever has the greater 200550 magnitude." 200551 200552 self > aMagnitude 200553 ifTrue: [^self] 200554 ifFalse: [^aMagnitude]! ! 200555 200556!Magnitude methodsFor: 'testing'! 200557min: aMagnitude 200558 "Answer the receiver or the argument, whichever has the lesser 200559 magnitude." 200560 200561 self < aMagnitude 200562 ifTrue: [^self] 200563 ifFalse: [^aMagnitude]! ! 200564 200565!Magnitude methodsFor: 'testing'! 200566min: aMin max: aMax 200567 200568 ^ (self min: aMin) max: aMax! ! 200569 200570"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 200571 200572Magnitude class 200573 instanceVariableNames: ''! 200574Object subclass: #MailAddressParser 200575 instanceVariableNames: 'tokens addresses curAddrTokens' 200576 classVariableNames: '' 200577 poolDictionaries: '' 200578 category: 'Network-RFC822'! 200579!MailAddressParser commentStamp: '<historical>' prior: 0! 200580Parse mail addresses. The basic syntax is: 200581 200582 addressList := MailAddressParser addressesIn: aString 200583 200584This currently only returns the bare addresses, but it could also return a list of the address "source codes". For example, if you give it "Joe <joe@foo>, <jane>", it will currently return a list ('joe@foo' 'jane'). It would be nice to also get a list ('Joe <joe@foo>' '<jane>').! 200585 200586 200587!MailAddressParser methodsFor: 'building address list' stamp: 'ls 9/13/1998 01:31'! 200588addToAddress 200589 "add the last token to the address. removes the token from the collection" 200590 curAddrTokens addFirst: (tokens removeLast)! ! 200591 200592!MailAddressParser methodsFor: 'building address list' stamp: 'ls 9/13/1998 01:30'! 200593finishAddress 200594 "we've finished one address. Bundle it up and add it to the list of addresses" 200595 | address | 200596 200597 address := String streamContents: [ :str | 200598 curAddrTokens do: [ :tok | str nextPutAll: tok text ] ]. 200599 200600 addresses addFirst: address. 200601 200602 curAddrTokens := nil.! ! 200603 200604!MailAddressParser methodsFor: 'building address list' stamp: 'ls 9/13/1998 01:30'! 200605startNewAddress 200606 "set up data structures to begin a new address" 200607 (curAddrTokens ~~ nil) ifTrue: [ 200608 self error: 'starting new address before finishing the last one!!' ]. 200609 200610 curAddrTokens := OrderedCollection new. 200611 ! ! 200612 200613 200614!MailAddressParser methodsFor: 'parsing' stamp: 'ls 9/13/1998 02:08'! 200615grabAddressWithRoute 200616 "grad an address of the form 'Descriptive Text <real.address@c.d.e>" 200617 200618 self startNewAddress. 200619 200620 tokens removeLast. "remove the >" 200621 200622 "grab until we see a $<" 200623 [ 200624 tokens isEmpty ifTrue: [ 200625 self error: '<> are not matched' ]. 200626 tokens last type = $< 200627 ] whileFalse: [ self addToAddress ]. 200628 200629 tokens removeLast. "remove the <" 200630 200631 200632 self removePhrase. 200633 200634 self finishAddress! ! 200635 200636!MailAddressParser methodsFor: 'parsing' stamp: 'bf 3/12/2000 20:06'! 200637grabAddresses 200638 "grab all the addresses in the string" 200639 | token | 200640 "remove comments" 200641 tokens removeAllSuchThat: [:t | t type == #Comment]. 200642 "grab one address or address group each time through this loop" 200643 [ 200644 "remove commas" 200645 [ 200646 tokens isEmpty not and: [ tokens last type = $, ] 200647 ] whileTrue: [ tokens removeLast ]. 200648 200649 "check whether any tokens are left" 200650 tokens isEmpty 200651 ] whileFalse: [ 200652 token := tokens last. 200653 200654 "delegate, depending on what form the address is in" 200655 "the from can be determined from the last token" 200656 200657 token type = $> ifTrue: [ 200658 self grabAddressWithRoute ] 200659 ifFalse: [ 200660 (#(Atom DomainLiteral QuotedString) includes: token type) ifTrue: [ 200661 self grabBasicAddress ] 200662 ifFalse: [ 200663 token type = $; ifTrue: [ 200664 self grabGroupAddress ] 200665 ifFalse: [ 200666 ^self error: 'un-recognized address format' ] ] ] 200667 ]. 200668 200669 ^addresses! ! 200670 200671!MailAddressParser methodsFor: 'parsing' stamp: 'ls 10/23/1998 13:39'! 200672grabBasicAddress 200673 "grad an address of the form a.b@c.d.e" 200674 self startNewAddress. 200675 "grab either the domain if specified, or the domain if not" 200676 self addToAddress. 200677 [tokens isEmpty not and: [ tokens last type = $.] ] 200678 whileTrue: 200679 ["add name-dot pairs of tokens" 200680 self addToAddress. 200681 (#(Atom QuotedString ) includes: tokens last type) 200682 ifFalse: [self error: 'bad token in address: ' , tokens last text]. 200683 self addToAddress]. 200684 (tokens isEmpty or: [tokens last type ~= $@]) 200685 ifTrue: ["no domain specified" 200686 self finishAddress] 200687 ifFalse: 200688 ["that was the domain. check that no QuotedString's slipped in" 200689 curAddrTokens do: [:tok | tok type = #QuotedString ifTrue: [self error: 'quote marks are not allowed within a domain name (' , tok text , ')']]. 200690 "add the @ sign" 200691 self addToAddress. 200692 "add the local part" 200693 (#(Atom QuotedString ) includes: tokens last type) 200694 ifFalse: [self error: 'invalid local part for address: ' , tokens last text]. 200695 self addToAddress. 200696 "add word-dot pairs if there are any" 200697 [tokens isEmpty not and: [tokens last type = $.]] 200698 whileTrue: 200699 [self addToAddress. 200700 (tokens isEmpty not and: [#(Atom QuotedString ) includes: tokens last type]) 200701 ifTrue: [self addToAddress]]. 200702 self finishAddress]! ! 200703 200704!MailAddressParser methodsFor: 'parsing' stamp: 'ls 9/13/1998 02:07'! 200705grabGroupAddress 200706 "grab an address of the form 'phrase : address, address, ..., address;'" 200707 "I'm not 100% sure what this format means, so I'm just returningthe list of addresses between the : and ; -ls (if this sounds right to someone, feel free to remove this comment :)" 200708 200709 "remove the $; " 200710 tokens removeLast. 200711 200712 "grab one address each time through this loop" 200713 [ 200714 "remove commas" 200715 [ 200716 tokens isEmpty not and: [ tokens last type = $, ] 200717 ] whileTrue: [ tokens removeLast ]. 200718 200719 tokens isEmpty ifTrue: [ 200720 "no matching :" 200721 ^self error: 'stray ; in address list'. ]. 200722 200723 tokens last type = $: 200724 ] whileFalse: [ 200725 "delegate to either grabAddressWithRoute, or grabBasicAddress. nested groups are not allowed" 200726 200727 tokens last type = $> ifTrue: [ 200728 self grabAddressWithRoute ] 200729 ifFalse: [ 200730 (#(Atom DomainLiteral QuotedString) includes: tokens last type) ifTrue: [ 200731 self grabBasicAddress ] 200732 ifFalse: [ 200733 ^self error: 'un-recognized address format' ] ] 200734 ]. 200735 200736 tokens removeLast. "remove the :" 200737 200738 self removePhrase.! ! 200739 200740!MailAddressParser methodsFor: 'parsing' stamp: 'ls 9/13/1998 02:08'! 200741removePhrase 200742 "skip most characters to the left of this" 200743 200744 [ 200745 tokens isEmpty not and: [ 200746 #(Atom QuotedString $. $@) includes: (tokens last type) ] 200747 ] whileTrue: [ tokens removeLast ]. 200748! ! 200749 200750 200751!MailAddressParser methodsFor: 'private-initialization' stamp: 'ls 9/13/1998 01:25'! 200752initialize: tokenList 200753 tokens := tokenList asOrderedCollection copy. 200754 addresses := OrderedCollection new.! ! 200755 200756"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 200757 200758MailAddressParser class 200759 instanceVariableNames: ''! 200760 200761!MailAddressParser class methodsFor: 'parsing' stamp: 'ls 9/13/1998 01:34'! 200762addressesIn: aString 200763 "return a collection of the bare addresses listed in aString" 200764 | tokens | 200765 tokens := MailAddressTokenizer tokensIn: aString. 200766 ^(self new initialize: tokens) grabAddresses! ! 200767TestCase subclass: #MailAddressParserTest 200768 instanceVariableNames: '' 200769 classVariableNames: '' 200770 poolDictionaries: '' 200771 category: 'NetworkTests-RFC822'! 200772!MailAddressParserTest commentStamp: '<historical>' prior: 0! 200773This is the unit test for the class MailAddressParser. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 200774 - http://www.c2.com/cgi/wiki?UnitTest 200775 - http://minnow.cc.gatech.edu/squeak/1547 200776 - the sunit class category! 200777 200778 200779!MailAddressParserTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:31'! 200780testAddressesIn 200781 200782 | testString correctAnswer | 200783 200784 testString := 'joe@lama.com, joe2@lama.com joe3@lama.com joe4 , Not an Address <joe5@address>, joe.(annoying (nested) comment)literal@[1.2.3.4], "an annoying" group : joe1@groupie, joe2@groupie, "Joey" joe3@groupy, "joe6"."joe8"@group.com;, Lex''s email account <lex>'. 200785 200786correctAnswer := #('joe@lama.com' 'joe2@lama.com' 'joe3@lama.com' 'joe4' 'joe5@address' 'joe.literal@[1.2.3.4]' 'joe1@groupie' 'joe2@groupie' '"Joey"' 'joe3@groupy' '"joe6"."joe8"@group.com' 'lex') asOrderedCollection. 200787 200788 self assert: ((MailAddressParser addressesIn: testString) = correctAnswer).! ! 200789Object subclass: #MailAddressToken 200790 instanceVariableNames: 'type text' 200791 classVariableNames: '' 200792 poolDictionaries: '' 200793 category: 'Network-RFC822'! 200794!MailAddressToken commentStamp: '<historical>' prior: 0! 200795a single token from an RFC822 mail address. Used internally in MailAddressParser! 200796 200797 200798!MailAddressToken methodsFor: 'access' stamp: 'ls 9/12/1998 20:42'! 200799text 200800 ^text! ! 200801 200802!MailAddressToken methodsFor: 'access' stamp: 'ls 9/12/1998 20:42'! 200803type 200804 ^type! ! 200805 200806 200807!MailAddressToken methodsFor: 'printing' stamp: 'ls 9/12/1998 20:40'! 200808printOn: aStream 200809 aStream nextPut: $[. 200810 aStream nextPutAll: self type asString. 200811 aStream nextPut: $|. 200812 aStream nextPutAll: self text. 200813 aStream nextPut: $].! ! 200814 200815 200816!MailAddressToken methodsFor: 'private' stamp: 'ls 9/12/1998 20:24'! 200817type: type0 text: text0 200818 type := type0. 200819 text := text0.! ! 200820 200821"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 200822 200823MailAddressToken class 200824 instanceVariableNames: ''! 200825 200826!MailAddressToken class methodsFor: 'instance creation' stamp: 'ls 9/12/1998 20:31'! 200827type: type text: text 200828 ^self new type: type text: text! ! 200829Stream subclass: #MailAddressTokenizer 200830 instanceVariableNames: 'cachedToken text pos' 200831 classVariableNames: 'CSNonAtom CSNonSeparators CSParens CSSpecials' 200832 poolDictionaries: '' 200833 category: 'Network-RFC822'! 200834!MailAddressTokenizer commentStamp: '<historical>' prior: 0! 200835Divides an address into tokens, as specified in RFC 822. Used by MailAddressParser.! 200836 200837 200838!MailAddressTokenizer methodsFor: 'initialization' stamp: 'ls 9/12/1998 20:13'! 200839initialize: aString 200840 text := aString. 200841 pos := 1.! ! 200842 200843 200844!MailAddressTokenizer methodsFor: 'stream protocol' stamp: 'ls 9/12/1998 20:53'! 200845atEnd 200846 ^self peek == nil! ! 200847 200848!MailAddressTokenizer methodsFor: 'stream protocol' stamp: 'ls 9/12/1998 20:51'! 200849next 200850 | ans | 200851 cachedToken ifNil: [ ^self nextToken ]. 200852 ans := cachedToken. 200853 cachedToken := nil. 200854 ^ans! ! 200855 200856!MailAddressTokenizer methodsFor: 'stream protocol' stamp: 'ls 9/12/1998 20:53'! 200857peek 200858 cachedToken ifNil: [ cachedToken := self nextToken. ]. 200859 200860 ^cachedToken ! ! 200861 200862 200863!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:51'! 200864atEndOfChars 200865 ^pos > text size! ! 200866 200867!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:44'! 200868nextAtom 200869 | start end | 200870 start := pos. 200871 pos := text indexOfAnyOf: CSNonAtom startingAt: start ifAbsent: [ text size + 1]. 200872 end := pos - 1. 200873 ^MailAddressToken 200874 type: #Atom 200875 text: (text copyFrom: start to: end)! ! 200876 200877!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:52'! 200878nextChar 200879 self atEndOfChars ifTrue: [ ^nil ]. 200880 pos := pos + 1. 200881 ^text at: (pos-1)! ! 200882 200883!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'mas 2/8/2001 11:36'! 200884nextComment 200885 | start nestLevel paren | 200886 start := pos. 200887 pos := pos + 1. 200888 nestLevel := 1. 200889 200890 [ nestLevel > 0 ] whileTrue: [ 200891 pos := text indexOfAnyOf: CSParens startingAt: pos ifAbsent: [ 0 ]. 200892 pos = 0 ifTrue: [ 200893 self error: 'unterminated comment. ie, more (''s than )''s' ]. 200894 200895 paren := self nextChar. 200896 paren = $( ifTrue: [ nestLevel := nestLevel + 1 ] ifFalse: [ nestLevel := nestLevel - 1 ]]. 200897 ^ MailAddressToken type: #Comment 200898 text: (text copyFrom: start to: pos - 1)! ! 200899 200900!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/13/1998 01:39'! 200901nextDomainLiteral 200902 | start end | 200903 start := pos. 200904 end := text indexOf: $] startingAt: start ifAbsent: [ 0 ]. 200905 end = 0 ifTrue: [ 200906 "not specified" 200907 self error: 'saw [ without a matching ]' ]. 200908 200909 pos := end+1. 200910 200911 ^MailAddressToken 200912 type: #DomainLiteral 200913 text: (text copyFrom: start to: end)! ! 200914 200915!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'PeterHugossonMiller 9/3/2009 10:02'! 200916nextQuotedString 200917 | res c | 200918 res := String new writeStream. 200919 res nextPut: self nextChar. "record the starting quote" 200920 [ self atEndOfChars ] whileFalse: [ 200921 c := self nextChar. 200922 c = $\ ifTrue: [ 200923 res nextPut: c. 200924 res nextPut: self nextChar ] 200925 ifFalse: [ 200926 c = $" ifTrue: [ 200927 res nextPut: c. 200928 ^MailAddressToken type: #QuotedString text: res contents ] 200929 ifFalse: [ 200930 res nextPut: c ] ] ]. 200931 200932 "hmm, never saw the final quote mark" 200933 ^MailAddressToken type: #QuotedString text: (res contents, '"')! ! 200934 200935!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:44'! 200936nextSpecial 200937 | c | 200938 c := self nextChar. 200939 ^MailAddressToken type: c text: c asString.! ! 200940 200941!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'bf 3/12/2000 19:53'! 200942nextToken 200943 | c | 200944 self skipSeparators. 200945 c := self peekChar. 200946 c ifNil: [ ^nil ]. 200947 c = $( ifTrue: [ ^self nextComment ]. 200948 c = $" ifTrue: [ ^self nextQuotedString ]. 200949 c = $[ ifTrue: [ ^self nextDomainLiteral ]. 200950 (CSSpecials includes: c) ifTrue: [ ^self nextSpecial ]. 200951 ^self nextAtom! ! 200952 200953!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:15'! 200954peekChar 200955 ^text at: pos ifAbsent: [ nil ]! ! 200956 200957!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:14'! 200958skipSeparators 200959 pos := text indexOfAnyOf: CSNonSeparators startingAt: pos ifAbsent: [ text size + 1 ].! ! 200960 200961"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 200962 200963MailAddressTokenizer class 200964 instanceVariableNames: ''! 200965 200966!MailAddressTokenizer class methodsFor: 'initialization' stamp: 'stephane.ducasse 7/3/2009 21:34'! 200967initialize 200968 "Initalize class variables using MailAddressTokenizer initialize" 200969 200970 | atomChars | 200971 200972 CSParens := CharacterSet empty. 200973 CSParens addAll: '()'. 200974 200975 CSSpecials := CharacterSet empty. 200976 CSSpecials addAll: '()<>@,;:\".[]'. 200977 200978 CSNonSeparators := CharacterSet separators complement. 200979 200980 200981 "(from RFC 2822)" 200982 atomChars := CharacterSet empty. 200983 atomChars addAll: ($A to: $Z). 200984 atomChars addAll: ($a to: $z). 200985 atomChars addAll: ($0 to: $9). 200986 atomChars addAll: '!!#$%^''*+-/=?^_`{|}~'. 200987 200988 CSNonAtom := atomChars complement.! ! 200989 200990 200991!MailAddressTokenizer class methodsFor: 'instance creation' stamp: 'ls 9/12/1998 20:54'! 200992forString: aString 200993 ^super basicNew initialize: aString! ! 200994 200995!MailAddressTokenizer class methodsFor: 'instance creation' stamp: 'ls 9/13/1998 01:34'! 200996tokensIn: aString 200997 "return a collection of the tokens in aString" 200998 ^(self forString: aString) upToEnd! ! 200999Model subclass: #MailComposition 201000 instanceVariableNames: 'messageText textEditor morphicWindow' 201001 classVariableNames: '' 201002 poolDictionaries: '' 201003 category: 'Network-MailSending'! 201004!MailComposition commentStamp: '<historical>' prior: 0! 201005a message being composed. When finished, it will be submitted via a Celeste.! 201006 201007 201008!MailComposition methodsFor: 'access' stamp: 'yo 7/26/2004 22:06'! 201009messageText 201010 "return the current text" 201011 ^messageText. 201012! ! 201013 201014!MailComposition methodsFor: 'access' stamp: 'yo 7/26/2004 22:47'! 201015messageText: aText 201016 "change the current text" 201017 messageText := aText. 201018 self changed: #messageText. 201019 ^true! ! 201020 201021!MailComposition methodsFor: 'access' stamp: 'dvf 5/11/2002 00:24'! 201022smtpServer 201023 ^MailSender smtpServer! ! 201024 201025!MailComposition methodsFor: 'access' stamp: 'alain.plantec 6/19/2008 09:45'! 201026submit 201027 | message | 201028 "submit the message" 201029 textEditor 201030 ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]]. 201031 message := MailMessage from: messageText asString. 201032 self breakLinesInMessage: message. 201033 SMTPClient deliverMailFrom: message from to: (Array with: message to) text: message text usingServer: self smtpServer. 201034 201035 morphicWindow ifNotNil: [morphicWindow delete]. 201036! ! 201037 201038 201039!MailComposition methodsFor: 'interface' stamp: 'mdr 4/10/2001 14:27'! 201040addAttachment 201041 | file fileResult fileName | 201042 textEditor 201043 ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]]. 201044 201045 (fileResult := StandardFileMenu oldFile) 201046 ifNotNil: 201047 [fileName := fileResult directory fullNameFor: fileResult name. 201048 file := FileStream readOnlyFileNamed: fileName. 201049 file ifNotNil: 201050 [file binary. 201051 self messageText: 201052 ((MailMessage from: self messageText asString) 201053 addAttachmentFrom: file withName: fileResult name; text). 201054 file close]] ! ! 201055 201056!MailComposition methodsFor: 'interface' stamp: 'fc 1/19/2005 18:56'! 201057menuGet: aMenu shifted: shifted 201058 201059 aMenu addList: { 201060 {'find...(f)' translated. #find}. 201061 {'find again (g)' translated. #findAgain}. 201062 {'set search string (h)' translated. #setSearchString}. 201063 #-. 201064 {'accept (s)' translated. #accept}. 201065 {'send message' translated. #submit}}. 201066 201067 ^aMenu.! ! 201068 201069!MailComposition methodsFor: 'interface' stamp: 'alain.plantec 5/30/2008 13:43'! 201070open 201071 "open an interface" 201072 self openInMorphic ! ! 201073 201074!MailComposition methodsFor: 'interface' stamp: 'alain.plantec 6/10/2008 22:30'! 201075openInMorphic 201076 "open an interface for sending a mail message with the given initial 201077 text" 201078 | textMorph buttonsList sendButton attachmentButton | 201079 morphicWindow := SystemWindow labelled: 'Mister Postman'. 201080 morphicWindow model: self. 201081 textEditor := textMorph := PluggableTextMorph 201082 on: self 201083 text: #messageText 201084 accept: #messageText: 201085 readSelection: nil 201086 menu: #menuGet:shifted:. 201087 morphicWindow 201088 addMorph: textMorph 201089 frame: (0 @ 0.1 corner: 1 @ 1). 201090 buttonsList := AlignmentMorph newRow. 201091 sendButton := PluggableButtonMorph 201092 on: self 201093 getState: nil 201094 action: #submit. 201095 sendButton hResizing: #spaceFill; 201096 vResizing: #spaceFill; 201097 label: 'send message'; 201098 setBalloonText: 'Accept any unaccepted edits and add this to the queue of messages to be sent'; 201099 onColor: Color white offColor: Color white. 201100 buttonsList addMorphBack: sendButton. 201101 attachmentButton := PluggableButtonMorph 201102 on: self 201103 getState: nil 201104 action: #addAttachment. 201105 attachmentButton hResizing: #spaceFill; 201106 vResizing: #spaceFill; 201107 label: 'add attachment'; 201108 setBalloonText: 'Send a file with the message'; 201109 onColor: Color white offColor: Color white. 201110 buttonsList addMorphBack: attachmentButton. 201111 morphicWindow 201112 addMorph: buttonsList 201113 frame: (0 @ 0 extent: 1 @ 0.1). 201114 morphicWindow openInWorld! ! 201115 201116!MailComposition methodsFor: 'interface' stamp: 'dvf 5/11/2002 01:23'! 201117sendMailMessage: aMailMessage 201118 self messageText: aMailMessage text! ! 201119 201120 201121!MailComposition methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 10:02'! 201122breakLines: aString atWidth: width 201123 "break lines in the given string into shorter lines" 201124 | result start end atAttachment | 201125 201126 result := (String new: (aString size * 50 // 49)) writeStream. 201127 201128 atAttachment := false. 201129 aString asString linesDo: [ :line | 201130 (line beginsWith: '====') ifTrue: [ atAttachment := true ]. 201131 atAttachment ifTrue: [ 201132 "at or after an attachment line; no more wrapping for the rest of the message" 201133 result nextPutAll: line. result cr ] 201134 ifFalse: [ 201135 (line beginsWith: '>') ifTrue: [ 201136 "it's quoted text; don't wrap it" 201137 result nextPutAll: line. result cr. ] 201138 ifFalse: [ 201139 "regular old line. Wrap it to multiple lines" 201140 start := 1. 201141 "output one shorter line each time through this loop" 201142 [ start + width <= line size ] whileTrue: [ 201143 201144 "find the end of the line" 201145 end := start + width - 1. 201146 [end >= start and: [ (line at: (end+1)) isSeparator not ]] whileTrue: [ 201147 end := end - 1 ]. 201148 end < start ifTrue: [ 201149 "a word spans the entire width!!" 201150 end := start + width - 1 ]. 201151 201152 "copy the line to the output" 201153 result nextPutAll: (line copyFrom: start to: end). 201154 result cr. 201155 201156 "get ready for next iteration" 201157 start := end+1. 201158 (line at: start) isSeparator ifTrue: [ start := start + 1 ]. 201159 ]. 201160 201161 "write out the final part of the line" 201162 result nextPutAll: (line copyFrom: start to: line size). 201163 result cr. 201164 ]. 201165 ]. 201166 ]. 201167 201168 ^result contents! ! 201169 201170!MailComposition methodsFor: 'private' stamp: 'ls 2/10/2001 14:08'! 201171breakLinesInMessage: message 201172 "reformat long lines in the specified message into shorter ones" 201173 message body mainType = 'text' ifTrue: [ 201174 "it's a single-part text message. reformat the text" 201175 | newBodyText | 201176 newBodyText := self breakLines: message bodyText atWidth: 72. 201177 message body: (MIMEDocument contentType: message body contentType content: newBodyText). 201178 201179 ^self ]. 201180 201181 message body isMultipart ifTrue: [ 201182 "multipart message; process the top-level parts. HACK: the parts are modified in place" 201183 message parts do: [ :part | 201184 part body mainType = 'text' ifTrue: [ 201185 | newBodyText | 201186 newBodyText := self breakLines: part bodyText atWidth: 72. 201187 part body: (MIMEDocument contentType: part body contentType content: newBodyText) ] ]. 201188 message regenerateBodyFromParts. ].! ! 201189 201190!MailComposition methodsFor: 'private' stamp: 'fc 1/19/2005 20:53'! 201191perform: selector orSendTo: otherTarget 201192 201193 (self respondsTo: selector) 201194 ifTrue: [^self perform: selector] 201195 ifFalse: [^otherTarget perform: selector] 201196 201197 ! ! 201198 201199"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 201200 201201MailComposition class 201202 instanceVariableNames: ''! 201203 201204!MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 00:40'! 201205initialize 201206 super initialize. 201207 MailSender register: self.! ! 201208 201209!MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 01:25'! 201210sendMailMessage: aMailMessage 201211 | newComposition | 201212 newComposition := self new. 201213 newComposition messageText: aMailMessage text; open! ! 201214 201215!MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 00:40'! 201216unload 201217 201218 MailSender unregister: self ! ! 201219Object subclass: #MailMessage 201220 instanceVariableNames: 'text body fields parts' 201221 classVariableNames: '' 201222 poolDictionaries: '' 201223 category: 'Network-Url'! 201224!MailMessage commentStamp: '<historical>' prior: 0! 201225I represent an Internet mail or news message. 201226 201227 text - the raw text of my message 201228 body - the body of my message, as a MIMEDocument 201229 fields - a dictionary mapping lowercased field names into collections of MIMEHeaderValue's 201230 parts - if I am a multipart message, then this is a cache of my parts! 201231 201232 201233!MailMessage methodsFor: 'access' stamp: 'ls 1/3/1999 15:48'! 201234body 201235 "return just the body of the message" 201236 ^body! ! 201237 201238!MailMessage methodsFor: 'access' stamp: 'ls 1/3/1999 15:52'! 201239bodyText 201240 "return the text of the body of the message" 201241 ^body content! ! 201242 201243!MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:34'! 201244cc 201245 201246 ^self fieldsNamed: 'cc' separatedBy: ', '! ! 201247 201248!MailMessage methodsFor: 'access' stamp: 'ls 2/10/2001 12:19'! 201249date 201250 "Answer a date string for this message." 201251 201252 ^(Date fromSeconds: self time + (Date newDay: 1 year: 1980) asSeconds) 201253 printFormat: #(2 1 3 47 1 2)! ! 201254 201255!MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:27'! 201256fields 201257 "return the internal fields structure. This is private and subject to change!!" 201258 ^ fields! ! 201259 201260!MailMessage methodsFor: 'access' stamp: 'mdr 3/21/2001 15:28'! 201261from 201262 201263 ^(self fieldNamed: 'from' ifAbsent: [ ^'' ]) mainValue! ! 201264 201265!MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:26'! 201266name 201267 "return a default name for this part, if any was specified. If not, return nil" 201268 | type nameField disposition | 201269 201270 "try in the content-type: header" 201271 type := self fieldNamed: 'content-type' ifAbsent: [nil]. 201272 (type notNil and: [(nameField := type parameters at: 'name' ifAbsent: [nil]) notNil]) 201273 ifTrue: [^ nameField]. 201274 201275 "try in content-disposition:" 201276 disposition := self fieldNamed: 'content-disposition' ifAbsent: [nil]. 201277 (disposition notNil and: [(nameField := disposition parameters at: 'filename' ifAbsent: [nil]) notNil]) 201278 ifTrue: [^ nameField]. 201279 201280 "give up" 201281 ^ nil! ! 201282 201283!MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:24'! 201284subject 201285 201286 ^(self fieldNamed: 'subject' ifAbsent: [ ^'' ]) mainValue! ! 201287 201288!MailMessage methodsFor: 'access' stamp: 'ls 2/10/2001 12:49'! 201289text 201290 "the full, unprocessed text of the message" 201291 text ifNil: [ self regenerateText ]. 201292 ^text! ! 201293 201294!MailMessage methodsFor: 'access' stamp: 'mdr 4/7/2001 17:48'! 201295time 201296 | dateField | 201297 dateField := (self fieldNamed: 'date' ifAbsent: [ ^0 ]) mainValue. 201298 ^ [self timeFrom: dateField] ifError: [:err :rcvr | Date today asSeconds]. 201299! ! 201300 201301!MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:35'! 201302to 201303 ^self fieldsNamed: 'to' separatedBy: ', '! ! 201304 201305 201306!MailMessage methodsFor: 'fields' stamp: 'bf 3/10/2000 15:22'! 201307canonicalFields 201308 "Break long header fields and escape those containing high-ascii characters according to RFC2047" 201309 201310 self rewriteFields: 201311 [ :fName :fValue | 201312 (fName size + fValue size < 72 and: [fValue allSatisfy: [:c | c asciiValue <= 128]]) 201313 ifFalse: [RFC2047MimeConverter mimeEncode: fName, ': ', fValue]] 201314 append: []. 201315 201316! ! 201317 201318!MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:32'! 201319fieldNamed: aString ifAbsent: aBlock 201320 | matchingFields | 201321 "return the value of the field with the specified name. If there is more than one field, then return the first one" 201322 matchingFields := fields at: aString asLowercase ifAbsent: [ ^aBlock value ]. 201323 ^matchingFields first! ! 201324 201325!MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:21'! 201326fieldsNamed: aString ifAbsent: aBlock 201327 "return a list of all fields with the given name" 201328 ^fields at: aString asLowercase ifAbsent: aBlock! ! 201329 201330!MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:36'! 201331fieldsNamed: aString separatedBy: separationString 201332 "return all fields with the specified name, concatenated together with separationString between each element. Return an empty string if no fields with the specified name are present" 201333 | matchingFields | 201334 matchingFields := self fieldsNamed: aString ifAbsent: [ ^'' ]. 201335 ^String streamContents: [ :str | 201336 matchingFields 201337 do: [ :field | str nextPutAll: field mainValue ] 201338 separatedBy: [ str nextPutAll: separationString ]]. 201339! ! 201340 201341!MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:28'! 201342hasFieldNamed: aString 201343 ^fields includesKey: aString asLowercase! ! 201344 201345!MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:30'! 201346removeFieldNamed: name 201347 "remove all fields with the specified name" 201348 fields removeKey: name ifAbsent: []! ! 201349 201350!MailMessage methodsFor: 'fields' stamp: 'PeterHugossonMiller 9/3/2009 10:03'! 201351rewriteFields: aBlock append: appendBlock 201352 "Rewrite header fields. The body is not modified. 201353 Each field's key and value is reported to aBlock. The block's return value is the replacement for the entire header line. Nil means don't change the line, empty means delete it. After all fields are processed, evaluate appendBlock and append the result to the header." 201354 | old new result appendString | 201355 self halt: 'this method is out of date. it needs to update body, at the very least. do we really need this now that we have setField:to: and setField:toString: ?!!'. 201356 old := text readStream. 201357 new := (String new: text size) writeStream. 201358 self 201359 fieldsFrom: old 201360 do: 201361 [ :fName :fValue | 201362 result := aBlock 201363 value: fName 201364 value: fValue. 201365 result 201366 ifNil: 201367 [ new 201368 nextPutAll: fName , ': ' , fValue; 201369 cr ] 201370 ifNotNil: 201371 [ result isEmpty ifFalse: 201372 [ new nextPutAll: result. 201373 result last = Character cr ifFalse: [ new cr ] ] ] ]. 201374 appendString := appendBlock value. 201375 appendString isEmptyOrNil ifFalse: 201376 [ new nextPutAll: appendString. 201377 appendString last = Character cr ifFalse: [ new cr ] ]. 201378 new cr. "End of header" 201379 text := new contents , old upToEnd! ! 201380 201381 201382!MailMessage methodsFor: 'initialization' stamp: 'ls 2/10/2001 12:48'! 201383body: newBody 201384 "change the body" 201385 body := newBody. 201386 text := nil.! ! 201387 201388!MailMessage methodsFor: 'initialization' stamp: 'damiencassou 5/30/2008 15:52'! 201389from: aString 201390 "Parse aString to initialize myself." 201391 | parseStream contentType bodyText contentTransferEncoding | 201392 text := aString withoutTrailingBlanks , String cr. 201393 parseStream := text readStream. 201394 contentType := 'text/plain'. 201395 contentTransferEncoding := nil. 201396 fields := Dictionary new. 201397 201398 "Extract information out of the header fields" 201399 self 201400 fieldsFrom: parseStream 201401 do: 201402 [ :fName :fValue | 201403 "NB: fName is all lowercase" 201404 fName = 'content-type' ifTrue: [ contentType := (fValue copyUpTo: $;) asLowercase ]. 201405 fName = 'content-transfer-encoding' ifTrue: [ contentTransferEncoding := fValue asLowercase ]. 201406 (fields 201407 at: fName 201408 ifAbsentPut: [ OrderedCollection new: 1 ]) add: (MIMEHeaderValue 201409 forField: fName 201410 fromString: fValue) ]. 201411 201412 "Extract the body of the message" 201413 bodyText := parseStream upToEnd. 201414 contentTransferEncoding = 'base64' ifTrue: 201415 [ bodyText := Base64MimeConverter mimeDecodeToChars: bodyText readStream. 201416 bodyText := bodyText contents ]. 201417 contentTransferEncoding = 'quoted-printable' ifTrue: [ bodyText := bodyText decodeQuotedPrintable ]. 201418 body := MIMEDocument 201419 contentType: contentType 201420 content: bodyText! ! 201421 201422!MailMessage methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:06'! 201423initialize 201424 "initialize as an empty message" 201425 201426 super initialize. 201427 text := String cr. 201428 fields := Dictionary new. 201429 body := MIMEDocument contentType: 'text/plain' content: String cr! ! 201430 201431!MailMessage methodsFor: 'initialization' stamp: 'ls 3/18/2001 16:20'! 201432setField: fieldName to: aFieldValue 201433 "set a field. If any field of the specified name exists, it will be overwritten" 201434 fields at: fieldName asLowercase put: (OrderedCollection with: aFieldValue). 201435 text := nil.! ! 201436 201437!MailMessage methodsFor: 'initialization' stamp: 'mdr 4/11/2001 11:59'! 201438setField: fieldName toString: fieldValue 201439 ^self setField: fieldName to: (MIMEHeaderValue forField: fieldName fromString: fieldValue)! ! 201440 201441 201442!MailMessage methodsFor: 'multipart' stamp: 'mdr 4/11/2001 12:04'! 201443addAttachmentFrom: aStream withName: aName 201444 "add an attachment, encoding with base64. aName is the option filename to encode" 201445 | newPart | 201446 self makeMultipart. 201447 self parts. "make sure parts have been parsed" 201448 201449 "create the attachment as a MailMessage" 201450 newPart := MailMessage empty. 201451 newPart setField: 'content-type' toString: 'application/octet-stream'. 201452 newPart setField: 'content-transfer-encoding' toString: 'base64'. 201453 aName ifNotNil: [ 201454 | dispositionField | 201455 dispositionField := MIMEHeaderValue fromMIMEHeader: 'attachment'. 201456 dispositionField parameterAt: 'filename' put: aName. 201457 newPart setField: 'content-disposition' to: dispositionField ]. 201458 newPart body: (MIMEDocument contentType: 'application/octet-stream' content: aStream upToEnd). 201459 201460 201461 "regenerate our text" 201462 parts := parts copyWith: newPart. 201463 self regenerateBodyFromParts. 201464 text := nil.! ! 201465 201466!MailMessage methodsFor: 'multipart' stamp: 'mdr 5/7/2001 11:22'! 201467atomicParts 201468 "Answer all of the leaf parts of this message, including those of multipart included messages" 201469 201470 self body isMultipart ifFalse: [^ OrderedCollection with: self]. 201471 ^ self parts inject: OrderedCollection new into: [:col :part | col , part atomicParts]! ! 201472 201473!MailMessage methodsFor: 'multipart' stamp: 'mdr 3/22/2001 09:06'! 201474attachmentSeparator 201475 ^(self fieldNamed: 'content-type' ifAbsent: [^nil]) parameters 201476 at: 'boundary' ifAbsent: [^nil]! ! 201477 201478!MailMessage methodsFor: 'multipart' stamp: 'ls 3/18/2001 16:26'! 201479decoderClass 201480 | encoding | 201481 encoding := self fieldNamed: 'content-transfer-encoding' ifAbsent: [^ nil]. 201482 encoding := encoding mainValue. 201483 encoding asLowercase = 'base64' ifTrue: [^ Base64MimeConverter]. 201484 encoding asLowercase = 'quoted-printable' ifTrue: [^ QuotedPrintableMimeConverter]. 201485 ^ nil! ! 201486 201487!MailMessage methodsFor: 'multipart' stamp: 'mdr 4/11/2001 12:06'! 201488makeMultipart 201489 "if I am not multipart already, then become a multipart message with one part" 201490 201491 | part multipartHeader | 201492 201493 body isMultipart ifTrue: [ ^self ]. 201494 201495 "set up the new message part" 201496 part := MailMessage empty. 201497 part body: body. 201498 (self hasFieldNamed: 'content-type') ifTrue: [ 201499 part setField: 'content-type' to: (self fieldNamed: 'content-type' ifAbsent: ['']) ]. 201500 parts := Array with: part. 201501 201502 "fix up our header" 201503 multipartHeader := MIMEHeaderValue fromMIMEHeader: 'multipart/mixed'. 201504 multipartHeader parameterAt: 'boundary' put: self class generateSeparator . 201505 self setField: 'content-type' to: multipartHeader. 201506 201507 self setField: 'mime-version' to: (MIMEHeaderValue fromMIMEHeader: '1.0'). 201508 self removeFieldNamed: 'content-transfer-encoding'. 201509 201510 "regenerate everything" 201511 self regenerateBodyFromParts. 201512 text := nil.! ! 201513 201514!MailMessage methodsFor: 'multipart' stamp: 'damiencassou 5/30/2008 15:52'! 201515parseParts 201516 "private -- parse the parts of the message and store them into a collection" 201517 "If this is not multipart, store an empty collection" 201518 | parseStream msgStream messages separator | 201519 self body isMultipart ifFalse: 201520 [ parts := #(). 201521 ^ self ]. 201522 201523 "If we can't find a valid separator, handle it as if the message is not multipart" 201524 separator := self attachmentSeparator. 201525 separator ifNil: 201526 [ Transcript 201527 show: 'Ignoring bad attachment separater'; 201528 cr. 201529 parts := #(). 201530 ^ self ]. 201531 separator := '--' , separator withoutTrailingBlanks. 201532 parseStream := self bodyText readStream. 201533 msgStream := LimitingLineStreamWrapper 201534 on: parseStream 201535 delimiter: separator. 201536 msgStream limitingBlock: 201537 [ :aLine | 201538 aLine withoutTrailingBlanks = separator or: 201539 [ "Match the separator" 201540 aLine withoutTrailingBlanks = (separator , '--') ] ]. "or the final separator with --" 201541 201542 "Throw away everything up to and including the first separator" 201543 msgStream upToEnd. 201544 msgStream skipThisLine. 201545 201546 "Extract each of the multi-parts as strings" 201547 messages := OrderedCollection new. 201548 [ parseStream atEnd ] whileFalse: 201549 [ messages add: msgStream upToEnd. 201550 msgStream skipThisLine ]. 201551 parts := messages collect: [ :e | MailMessage from: e ]! ! 201552 201553!MailMessage methodsFor: 'multipart' stamp: 'ls 4/30/2000 18:22'! 201554parts 201555 parts ifNil: [self parseParts]. 201556 ^ parts! ! 201557 201558!MailMessage methodsFor: 'multipart' stamp: 'DamienCassou 9/29/2009 13:00'! 201559save 201560 "save the part to a file" 201561 | fileName file | 201562 fileName := self name 201563 ifNil: ['attachment' , Utilities dateTimeSuffix]. 201564 (fileName includes: $.) ifFalse: [ 201565 #(isJpeg 'jpg' isGif 'gif' isPng 'png' isPnm 'pnm') pairsDo: [ :s :e | 201566 (self body perform: s) ifTrue: [fileName := fileName, '.', e] 201567 ] 201568 ]. 201569 fileName := UIManager default request: 'File name for save?' initialAnswer: fileName. 201570 fileName isEmptyOrNil 201571 ifTrue: [^ nil]. 201572 file := FileStream newFileNamed: fileName. 201573 file nextPutAll: self bodyText. 201574 file close! ! 201575 201576 201577!MailMessage methodsFor: 'parsing' stamp: 'damiencassou 5/30/2008 15:52'! 201578fieldsFrom: aStream do: aBlock 201579 "Invoke the given block with each of the header fields from the given stream. The block arguments are the field name and value. The streams position is left right after the empty line separating header and body." 201580 | savedLine line s | 201581 savedLine := self readStringLineFrom: aStream. 201582 [ aStream atEnd ] whileFalse: 201583 [ line := savedLine. 201584 line isEmpty ifTrue: [ ^ self ]. "quit when we hit a blank line" 201585 201586 [ savedLine := self readStringLineFrom: aStream. 201587 savedLine size > 0 and: [ savedLine first isSeparator ] ] whileTrue: 201588 [ "lines starting with white space are continuation lines" 201589 s := savedLine readStream. 201590 s skipSeparators. 201591 line := line , ' ' , s upToEnd ]. 201592 self 201593 reportField: line withBlanksTrimmed 201594 to: aBlock ]. 201595 201596 "process final header line of a body-less message" 201597 savedLine isEmpty ifFalse: 201598 [ self 201599 reportField: savedLine withBlanksTrimmed 201600 to: aBlock ]! ! 201601 201602!MailMessage methodsFor: 'parsing' stamp: 'damiencassou 5/30/2008 15:52'! 201603headerFieldsNamed: fieldName do: aBlock 201604 "Evalue aBlock once for each header field which matches fieldName. The block is valued with one parameter, the value of the field" 201605 self 201606 fieldsFrom: text readStream 201607 do: [ :fName :fValue | (fieldName sameAs: fName) ifTrue: [ aBlock value: fValue ] ]! ! 201608 201609!MailMessage methodsFor: 'parsing' stamp: 'PeterHugossonMiller 9/3/2009 10:03'! 201610readDateFrom: aStream 201611 "Parse a date from the given stream and answer nil if the date can't be parsed. The date may be in any of the following forms: 201612 <day> <monthName> <year> (5 April 1982; 5-APR-82) 201613 <monthName> <day> <year> (April 5, 1982) 201614 <monthNumber> <day> <year> (4/5/82) 201615 In addition, the date may be preceded by the day of the week and an optional comma, such as: 201616 Tue, November 14, 1989" 201617 201618 | day month year | 201619 self skipWeekdayName: aStream. 201620 aStream peek isDigit ifTrue: [day := Integer readFrom: aStream]. 201621 [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. 201622 aStream peek isLetter 201623 ifTrue: "month name or weekday name" 201624 [month := (String new: 10) writeStream. 201625 [aStream peek isLetter] whileTrue: [month nextPut: aStream next]. 201626 month := month contents. 201627 day isNil ifTrue: "name/number..." 201628 [[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. 201629 (aStream peek isDigit) ifFalse: [^nil]. 201630 day := Integer readFrom: aStream]] 201631 ifFalse: "number/number..." 201632 [month := Date nameOfMonth: day. 201633 day := Integer readFrom: aStream]. 201634 [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. 201635 (aStream peek isDigit) ifFalse: [^nil]. 201636 year := Integer readFrom: aStream. 201637 ^Date newDay: day month: month year: year! ! 201638 201639!MailMessage methodsFor: 'parsing' stamp: 'dvf 5/10/2002 21:43'! 201640readStringLineFrom: aStream 201641 "Read and answer the next line from the given stream. Consume the carriage return but do not append it to the string." 201642 201643 | | 201644 201645 ^aStream upTo: Character cr! ! 201646 201647!MailMessage methodsFor: 'parsing' stamp: 'damiencassou 5/30/2008 15:52'! 201648reportField: aString to: aBlock 201649 "Evaluate the given block with the field name a value in the given field. Do nothing if the field is malformed." 201650 | s fieldName fieldValue | 201651 (aString includes: $:) ifFalse: [ ^ self ]. 201652 s := aString readStream. 201653 fieldName := (s upTo: $:) asLowercase. "fieldname must be lowercase" 201654 fieldValue := s upToEnd withBlanksTrimmed. 201655 fieldValue isEmpty ifFalse: 201656 [ aBlock 201657 value: fieldName 201658 value: fieldValue ]! ! 201659 201660!MailMessage methodsFor: 'parsing' stamp: 'PeterHugossonMiller 9/3/2009 10:03'! 201661skipWeekdayName: aStream 201662 "If the given stream starts with a weekday name or its abbreviation, advance the stream to the first alphaNumeric character following the weekday name." 201663 201664 | position name abbrev | 201665 aStream skipSeparators. 201666 (aStream peek isDigit) ifTrue: [^self]. 201667 (aStream peek isLetter) ifTrue: 201668 [position := aStream position. 201669 name := (String new: 10) writeStream. 201670 [aStream peek isLetter] whileTrue: [name nextPut: aStream next]. 201671 abbrev := (name contents copyFrom: 1 to: (3 min: name position)). 201672 abbrev := abbrev asLowercase. 201673 (#('sun' 'mon' 'tue' 'wed' 'thu' 'fri' 'sat') includes: abbrev asLowercase) 201674 ifTrue: 201675 ["found a weekday; skip to the next alphanumeric character" 201676 [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]] 201677 ifFalse: 201678 ["didn't find a weekday so restore stream position" 201679 aStream position: position]].! ! 201680 201681!MailMessage methodsFor: 'parsing' stamp: 'damiencassou 5/30/2008 15:52'! 201682timeFrom: aString 201683 "Parse the date and time (rfc822) and answer the result as the number of seconds 201684 since the start of 1980." 201685 | s t rawDelta delta plusOrMinus | 201686 s := aString readStream. 201687 201688 "date part" 201689 t := ((self readDateFrom: s) ifNil: [ Date today ]) asSeconds. 201690 [ s atEnd or: [ s peek isAlphaNumeric ] ] whileFalse: [ s next ]. 201691 201692 "time part" 201693 s atEnd ifFalse: 201694 [ "read time part (interpreted as local, regardless of sender's timezone)" 201695 s peek isDigit ifTrue: [ t := t + (Time readFrom: s) asSeconds ] ]. 201696 s skipSeparators. 201697 201698 "Check for a numeric time zone offset" 201699 ('+-' includes: s peek) ifTrue: 201700 [ plusOrMinus := s next. 201701 rawDelta := s peek isDigit 201702 ifTrue: [ Integer readFrom: s ] 201703 ifFalse: [ 0 ]. 201704 delta := (rawDelta // 100 * 60 + (rawDelta \\ 100)) * 60. 201705 t := plusOrMinus = $+ 201706 ifTrue: [ t - delta ] 201707 ifFalse: [ t + delta ] ]. 201708 201709 "We ignore text time zone offsets like EST, GMT, etc..." 201710 ^ t - (Date 201711 newDay: 1 201712 year: 1980) asSeconds 201713 201714 "MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 -500'" 201715 "MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 --500'" 201716 "MailMessage new timeFrom: 'on, 04 apr 2001 14:57:32'"! ! 201717 201718 201719!MailMessage methodsFor: 'printing/formatting' stamp: 'PeterHugossonMiller 9/3/2009 10:02'! 201720asSendableText 201721 "break lines in the given string into shorter lines" 201722 | result start end pastHeader atAttachment width aString | 201723 width := 72. 201724 aString := self text. 201725 result := (String new: aString size * 50 // 49) writeStream. 201726 pastHeader := false. 201727 atAttachment := false. 201728 aString asString 201729 linesDo: 201730 [:line | 201731 line isEmpty ifTrue: [pastHeader := true]. 201732 pastHeader 201733 ifTrue: 201734 ["(line beginsWith: '--==') 201735 ifTrue: [atAttachment := true]." 201736 atAttachment 201737 ifTrue: 201738 ["at or after an attachment line; no more 201739 wrapping for the rest of the message" 201740 result nextPutAll: line. 201741 result cr] 201742 ifFalse: [(line beginsWith: '>') 201743 ifTrue: 201744 ["it's quoted text; don't wrap it" 201745 result nextPutAll: line. 201746 result cr] 201747 ifFalse: 201748 ["regular old line. Wrap it to multiple 201749 lines " 201750 start := 1. 201751 "output one shorter line each time 201752 through this loop" 201753 [start + width <= line size] 201754 whileTrue: 201755 ["find the end of the line" 201756 end := start + width - 1. 201757 [end >= start and: [(line at: end + 1) isSeparator not]] 201758 whileTrue: [end := end - 1]. 201759 end < start ifTrue: ["a word spans the entire 201760 width!! " 201761 end := start + width - 1]. 201762 "copy the line to the output" 201763 result nextPutAll: (line copyFrom: start to: end). 201764 result cr. 201765 "get ready for next iteration" 201766 start := end + 1. 201767 (line at: start) isSeparator ifTrue: [start := start + 1]]. 201768 "write out the final part of the line" 201769 result nextPutAll: (line copyFrom: start to: line size). 201770 result cr]]] 201771 ifFalse: 201772 [result nextPutAll: line. 201773 result cr]]. 201774 ^ result contents! ! 201775 201776!MailMessage methodsFor: 'printing/formatting' stamp: 'damiencassou 5/30/2008 15:52'! 201777bodyTextFormatted 201778 "Answer a version of the text in my body suitable for display. This will parse multipart forms, decode HTML, and other such things" 201779 "check for multipart" 201780 self body isMultipart ifTrue: 201781 [ "check for alternative forms" 201782 self body isMultipartAlternative ifTrue: 201783 [ "it's multipart/alternative. search for a part that we can display, biasing towards nicer formats" 201784 #('text/html' 'text/plain' ) do: 201785 [ :format | 201786 self parts do: [ :part | part body contentType = format ifTrue: [ ^ part bodyTextFormatted ] ] ]. 201787 201788 "couldn't find a desirable part to display; just display the first part" 201789 ^ self parts first bodyTextFormatted ]. 201790 201791 "not alternative parts. put something for each part" 201792 ^ Text streamContents: 201793 [ :str | 201794 self parts do: 201795 [ :part | 201796 ((#('text' 'multipart' ) includes: part body mainType) or: [ part body contentType = 'message/rfc822' ]) 201797 ifTrue: 201798 [ "try to inline the message part" 201799 str nextPutAll: part bodyTextFormatted ] 201800 ifFalse: 201801 [ | descript | 201802 str cr. 201803 descript := part name ifNil: [ 'attachment' ]. 201804 str nextPutAll: (Text 201805 string: '[' , descript , ']' 201806 attribute: (TextMessageLink message: part)) ] ] ] ]. 201807 201808 201809 "check for HTML" 201810 self body contentType = 'text/html' ifTrue: 201811 [ Smalltalk 201812 at: #HtmlParser 201813 ifPresentAndInMemory: 201814 [ :htmlParser | 201815 ^ (htmlParser parse: body content readStream) formattedText ] ]. 201816 201817 "check for an embedded message" 201818 self body contentType = 'message/rfc822' ifTrue: [ ^ (MailMessage from: self body content) formattedText ]. 201819 201820 "nothing special--just return the text" 201821 ^ body content! ! 201822 201823!MailMessage methodsFor: 'printing/formatting' stamp: 'PeterHugossonMiller 9/3/2009 10:03'! 201824cleanedHeader 201825 "Reply with a cleaned up version email header. First show fields people would normally want to see (in a regular order for easy browsing), and then any other fields not explictly excluded" 201826 | new priorityFields omittedFields | 201827 new := (String new: text size) writeStream. 201828 priorityFields := #('Date' 'From' 'Subject' 'To' 'Cc' ). 201829 omittedFields := MailMessage omittedHeaderFields. 201830 201831 "Show the priority fields first, in the order given in priorityFields" 201832 priorityFields do: 201833 [ :pField | 201834 "We don't check whether the priority field is in the omitted list!!" 201835 self 201836 headerFieldsNamed: pField 201837 do: 201838 [ :fValue | 201839 new 201840 nextPutAll: pField , ': ' , fValue decodeMimeHeader; 201841 cr ] ]. 201842 201843 "Show the rest of the fields, omitting the uninteresting ones and ones we have already shown" 201844 omittedFields := omittedFields , priorityFields. 201845 self 201846 fieldsFrom: text readStream 201847 do: 201848 [ :fName :fValue | 201849 ((fName beginsWith: 'x-') or: [ omittedFields anySatisfy: [ :omitted | fName sameAs: omitted ] ]) ifFalse: 201850 [ new 201851 nextPutAll: fName , ': ' , fValue; 201852 cr ] ]. 201853 ^ new contents! ! 201854 201855!MailMessage methodsFor: 'printing/formatting' stamp: 'mdr 5/7/2001 11:07'! 201856excerpt 201857 "Return a short excerpt of the text of the message" 201858 201859 ^ self bodyText withSeparatorsCompacted truncateWithElipsisTo: 60! ! 201860 201861!MailMessage methodsFor: 'printing/formatting'! 201862format 201863 "Replace the text of this message with a formatted version." 201864 "NOTE: This operation discards extra header fields." 201865 201866 text := self formattedText.! ! 201867 201868!MailMessage methodsFor: 'printing/formatting' stamp: 'ls 4/30/2000 18:52'! 201869formattedText 201870 "Answer a version of my text suitable for display. This cleans up the header, decodes HTML, and things like that" 201871 201872 201873 ^ self cleanedHeader asText, String cr , self bodyTextFormatted! ! 201874 201875!MailMessage methodsFor: 'printing/formatting' stamp: 'ls 11/11/2001 13:27'! 201876printOn: aStream 201877 "For text parts with no filename show: 'text/plain: first line of text...' 201878 for attachments/filenamed parts show: 'attachment: filename.ext'" 201879 201880 | name | 201881 201882 aStream nextPutAll: ((name := self name) ifNil: ['Text: ' , self excerpt] 201883 ifNotNil: ['File: ' , name])! ! 201884 201885!MailMessage methodsFor: 'printing/formatting' stamp: 'bkv 6/23/2003 14:17'! 201886regenerateBodyFromParts 201887 "regenerate the message body from the multiple parts" 201888 | bodyText | 201889 201890 bodyText := String streamContents: [ :str | 201891 str cr. 201892 parts do: [ :part | 201893 str 201894 cr; 201895 nextPutAll: '--'; 201896 nextPutAll: self attachmentSeparator; 201897 cr; 201898 nextPutAll: part text ]. 201899 201900 str 201901 cr; 201902 nextPutAll: '--'; 201903 nextPutAll: self attachmentSeparator; 201904 nextPutAll: '--'; 201905 cr ]. 201906 201907 body := MIMEDocument contentType: 'multipart/mixed' content: bodyText. 201908 text := nil. "text needs to be reformatted"! ! 201909 201910!MailMessage methodsFor: 'printing/formatting' stamp: 'damiencassou 5/30/2008 15:52'! 201911regenerateText 201912 "regenerate the full text from the body and headers" 201913 | encodedBodyText | 201914 text := String streamContents: 201915 [ :str | 201916 "first put the header" 201917 fields keysAndValuesDo: 201918 [ :fieldName :fieldValues | 201919 fieldValues do: 201920 [ :fieldValue | 201921 str 201922 nextPutAll: fieldName capitalized; 201923 nextPutAll: ': '; 201924 nextPutAll: fieldValue asHeaderValue; 201925 cr ] ]. 201926 201927 "skip a line between header and body" 201928 str cr. 201929 201930 "put the body, being sure to encode it according to the header" 201931 encodedBodyText := body content. 201932 self decoderClass ifNotNil: 201933 [ encodedBodyText := (self decoderClass mimeEncode: encodedBodyText readStream) upToEnd ]. 201934 str nextPutAll: encodedBodyText ]! ! 201935 201936!MailMessage methodsFor: 'printing/formatting' stamp: 'sbw 1/21/2001 19:47'! 201937viewBody 201938 "open a viewer on the body of this message" 201939 self containsViewableImage 201940 ifTrue: [^ self viewImageInBody]. 201941 (StringHolder new contents: self bodyTextFormatted; 201942 yourself) 201943 openLabel: (self name 201944 ifNil: ['(a message part)'])! ! 201945 201946!MailMessage methodsFor: 'printing/formatting' stamp: 'nk 6/12/2004 09:36'! 201947viewImageInBody 201948 | stream image | 201949 stream := self body contentStream. 201950 image := Form fromBinaryStream: stream. 201951 (World drawingClass withForm: image) openInWorld! ! 201952 201953 201954!MailMessage methodsFor: 'testing' stamp: 'kfr 11/5/2004 17:32'! 201955containsViewableImage 201956 ^self body isJpeg | self body isGif | self body isPng! ! 201957 201958!MailMessage methodsFor: 'testing' stamp: 'mdr 4/11/2001 19:44'! 201959selfTest 201960 "For testing only: Check that this instance is well formed and makes sense" 201961 201962 self formattedText. 201963 201964 [MailAddressParser addressesIn: self from] ifError: 201965 [ :err :rcvr | Transcript show: 'Error parsing From: (', self from, ') ', err]. 201966 [MailAddressParser addressesIn: self to] ifError: 201967 [ :err :rcvr | Transcript show: 'Error parsing To: (', self to, ') ', err]. 201968 [MailAddressParser addressesIn: self cc] ifError: 201969 [ :err :rcvr | Transcript show: 'Error parsing CC: (', self cc, ') ', err]. 201970! ! 201971 201972"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 201973 201974MailMessage class 201975 instanceVariableNames: ''! 201976 201977!MailMessage class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 18:08'! 201978empty 201979 "return a message with no text and no header" 201980 201981 ^self new! ! 201982 201983!MailMessage class methodsFor: 'instance creation'! 201984from: aString 201985 "Initialize a new instance from the given string." 201986 201987 ^(self new) from: aString! ! 201988 201989 201990!MailMessage class methodsFor: 'preferences' stamp: 'mdr 7/9/2001 13:23'! 201991omittedHeaderFields 201992 "Reply a list of fields to omit when displaying a nice simple message" 201993 201994 "Note that heads of the form 201995 X-something: value 201996 are filtered programatically. This is done since we don't want any of them 201997 and it is impossible to predict them in advance." 201998 201999 ^ #( 202000 'comments' 202001 'priority' 202002 'disposition-notification-to' 202003 'content-id' 202004 'received' 202005 'return-path' 202006 'newsgroups' 202007 'message-id' 202008 'path' 202009 'in-reply-to' 202010 'sender' 202011 'fonts' 202012 'mime-version' 202013 'status' 202014 'content-type' 202015 'content-transfer-encoding' 202016 'errors-to' 202017 'keywords' 202018 'references' 202019 'nntp-posting-host' 202020 'lines' 202021 'return-receipt-to' 202022 'precedence' 202023 'originator' 202024 'distribution' 202025 'content-disposition' 202026 'importance' 202027 'resent-to' 202028 'resent-cc' 202029 'resent-message-id' 202030 'resent-date' 202031 'resent-sender' 202032 'resent-from' 202033 'delivered-to' 202034 'user-agent' 202035 'content-class' 202036 'thread-topic' 202037 'thread-index' 202038 'list-help', 202039 'list-post', 202040 'list-subscribe', 202041 'list-id', 202042 'list-unsubscribe', 202043 'list-archive' 202044 ) 202045! ! 202046 202047 202048!MailMessage class methodsFor: 'testing' stamp: 'mdr 3/21/2001 15:59'! 202049selfTest 202050 202051 | msgText msg | 202052 202053 msgText := 202054'Date: Tue, 20 Feb 2001 13:52:53 +0300 202055From: mdr@scn.rg (Me Ru) 202056Subject: RE: Windows 2000 on your laptop 202057To: "Greg Y" <to1@mail.com> 202058cc: cc1@scn.org, cc1also@test.org 202059To: to2@no.scn.org, to2also@op.org 202060cc: cc2@scn.org 202061 202062Hmmm... Good. I will try to swap my German copy for something in 202063English, and then do the deed. Oh, and expand my RAM to 128 first. 202064 202065Mike 202066'. 202067 202068 msg := self new from: msgText. 202069 202070 [msg text = msgText] assert. 202071 [msg subject = 'RE: Windows 2000 on your laptop'] assert. 202072 [msg from = 'mdr@scn.rg (Me Ru)'] assert. 202073 [msg date = '2/20/01'] assert. 202074 [msg time = 667133573] assert. 202075 "[msg name] assert." 202076 [msg to = '"Greg Y" <to1@mail.com>, to2@no.scn.org, to2also@op.org'] assert. 202077 [msg cc = 'cc1@scn.org, cc1also@test.org, cc2@scn.org'] assert. 202078 202079 "MailMessage selfTest" 202080! ! 202081 202082 202083!MailMessage class methodsFor: 'utilities' stamp: 'mdr 2/18/1999 20:47'! 202084dateStampNow 202085 "Return the current date and time formatted as a email Date: line" 202086 "The result conforms to RFC822 with a long year, e.g. 'Thu, 18 Feb 1999 20:38:51'" 202087 202088 ^ (Date today weekday copyFrom: 1 to: 3), ', ', 202089 (Date today printFormat: #(1 2 3 $ 2 1 1)), ' ', 202090 Time now print24! ! 202091 202092!MailMessage class methodsFor: 'utilities' stamp: 'ls 4/30/2000 22:58'! 202093generateSeparator 202094 "generate a separator usable for making MIME multipart documents. A leading -- will *not* be included" 202095 ^'==CelesteAttachment' , (10000 to: 99999) atRandom asString , '=='.! ! 202096AppRegistry subclass: #MailSender 202097 instanceVariableNames: '' 202098 classVariableNames: 'SmtpServer UserName' 202099 poolDictionaries: '' 202100 category: 'System-Applications'! 202101 202102"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 202103 202104MailSender class 202105 instanceVariableNames: ''! 202106 202107!MailSender class methodsFor: 'accessing' stamp: 'dvf 5/11/2002 01:29'! 202108smtpServer 202109 "Answer the server for sending email" 202110 202111 self isSmtpServerSet 202112 ifFalse: [self setSmtpServer]. 202113 SmtpServer isEmpty ifTrue: [ 202114 self error: 'no SMTP server specified' ]. 202115 202116 ^SmtpServer! ! 202117 202118!MailSender class methodsFor: 'accessing' stamp: 'dvf 5/11/2002 00:49'! 202119userName 202120 "Answer the user name to be used in composing messages." 202121 202122 (UserName isNil or: [UserName isEmpty]) 202123 ifTrue: [self setUserName]. 202124 202125 UserName isEmpty ifTrue: [ self error: 'no user name specified' ]. 202126 202127 ^UserName! ! 202128 202129 202130!MailSender class methodsFor: 'communication' stamp: 'ads 5/11/2003 21:11'! 202131sendMessage: aMailMessage 202132 202133 self default ifNotNil: [self default sendMailMessage: aMailMessage]! ! 202134 202135 202136!MailSender class methodsFor: 'settings' stamp: 'rbb 3/1/2005 10:59'! 202137setSmtpServer 202138 "Set the SMTP server used to send outgoing messages via" 202139 SmtpServer ifNil: [SmtpServer := '']. 202140 SmtpServer := UIManager default 202141 request: 'What is your mail server for outgoing mail?' 202142 initialAnswer: SmtpServer. 202143! ! 202144 202145!MailSender class methodsFor: 'settings' stamp: 'rbb 3/1/2005 11:00'! 202146setUserName 202147 "Change the user's email name for use in composing messages." 202148 202149 (UserName isNil) ifTrue: [UserName := '']. 202150 UserName := UIManager default 202151 request: 'What is your email address?\(This is the address other people will reply to you)' withCRs 202152 initialAnswer: UserName. 202153 UserName ifNotNil: [UserName := UserName]! ! 202154 202155 202156!MailSender class methodsFor: 'testing' stamp: 'dvf 5/11/2002 01:31'! 202157isSmtpServerSet 202158 ^ SmtpServer notNil and: [SmtpServer notEmpty] 202159! ! 202160GenericUrl subclass: #MailtoUrl 202161 instanceVariableNames: '' 202162 classVariableNames: '' 202163 poolDictionaries: '' 202164 category: 'Network-Url'! 202165!MailtoUrl commentStamp: '<historical>' prior: 0! 202166a URL specifying a mailing address; activating it triggers a mail-sender to start up, if one is present.! 202167 202168 202169!MailtoUrl methodsFor: 'downloading' stamp: 'dvf 5/11/2002 00:47'! 202170activate 202171 "Activate a Celeste window for the receiver" 202172 202173 MailSender sendMessage: (MailMessage from: self composeText)! ! 202174 202175!MailtoUrl methodsFor: 'downloading' stamp: 'dvf 5/11/2002 01:00'! 202176composeText 202177 "Answer the template for a new message." 202178 202179 ^ String streamContents: [:str | 202180 str nextPutAll: 'From: '. 202181 str nextPutAll: MailSender userName; cr. 202182 str nextPutAll: 'To: '. 202183 str nextPutAll: locator asString; cr. 202184 202185 str nextPutAll: 'Subject: '; cr. 202186 202187 str cr].! ! 202188SimpleBorder subclass: #MarginBorder 202189 instanceVariableNames: 'margin' 202190 classVariableNames: '' 202191 poolDictionaries: '' 202192 category: 'Polymorph-Widgets-Borders'! 202193!MarginBorder commentStamp: 'gvc 5/18/2007 12:46' prior: 0! 202194Border with customisable inner margin.! 202195 202196 202197!MarginBorder methodsFor: 'accessing' stamp: 'gvc 10/17/2006 11:07'! 202198drawLineFrom: startPoint to: stopPoint on: aCanvas 202199 "Reduce the width by the margin." 202200 202201 | lineColor | 202202 lineColor := (stopPoint truncated quadrantOf: startPoint truncated) > 2 202203 ifTrue: [self topLeftColor] 202204 ifFalse: [self bottomRightColor]. 202205 aCanvas 202206 line: startPoint 202207 to: stopPoint 202208 width: (self width - self margin max: 0) 202209 color: lineColor! ! 202210 202211!MarginBorder methodsFor: 'accessing' stamp: 'gvc 10/17/2006 11:06'! 202212frameRectangle: aRectangle on: aCanvas 202213 "Reduce width by the margin." 202214 202215 aCanvas frameAndFillRectangle: aRectangle 202216 fillColor: Color transparent 202217 borderWidth: (self width - self margin max: 0) 202218 topLeftColor: self topLeftColor 202219 bottomRightColor: self bottomRightColor.! ! 202220 202221!MarginBorder methodsFor: 'accessing' stamp: 'gvc 10/17/2006 11:05'! 202222initialize 202223 "Initialize the receiver." 202224 202225 super initialize. 202226 self 202227 margin: 0! ! 202228 202229!MarginBorder methodsFor: 'accessing' stamp: 'gvc 10/17/2006 11:04'! 202230margin 202231 "Answer the value of margin" 202232 202233 ^ margin! ! 202234 202235!MarginBorder methodsFor: 'accessing' stamp: 'gvc 10/17/2006 11:04'! 202236margin: anObject 202237 "Set the value of margin" 202238 202239 margin := anObject! ! 202240Collection subclass: #Matrix 202241 instanceVariableNames: 'nrows ncols contents' 202242 classVariableNames: '' 202243 poolDictionaries: '' 202244 category: 'Collections-Unordered'! 202245!Matrix commentStamp: '<historical>' prior: 0! 202246I represent a two-dimensional array, rather like Array2D. 202247There are three main differences between me and Array2D: 202248(1) Array2D inherits from ArrayedCollection, but isn't one. A lot of things that should work 202249 do not work in consequence of this. 202250(2) Array2D uses "at: column at: row" index order, which means that nothing you write using 202251 it is likely to work either. I use the almost universal "at: row at: column" order, so it is 202252 much easier to adapt code from other languages without going doolally. 202253(3) Array2D lets you specify the class of the underlying collection, I don't. 202254 202255Structure: 202256 nrows : a non-negative integer saying how many rows there are. 202257 ncols : a non-negative integer saying how many columns there are. 202258 contents : an Array holding the elements in row-major order. That is, for a 2x3 array 202259 the contents are (11 12 13 21 22 23). Array2D uses column major order. 202260 202261 You can specify the class of 'contents' when you create a new Array2D, 202262 but Matrix always gives you an Array. 202263 202264 There is a reason for this. In strongly typed languages like Haskell and Clean, 202265 'unboxed arrays' save you both space AND time. But in Squeak, while 202266 WordArray and FloatArray and so on do save space, it costs time to use them. 202267 A LOT of time. I've measured aFloatArray sum running nearly twice as slow as 202268 anArray sum. The reason is that whenever you fetch an element from an Array, 202269 that's all that happens, but when you fetch an element from aFloatArray, a whole 202270 new Float gets allocated to hold the value. This takes time and churns memory. 202271 So the paradox is that if you want fast numerical stuff, DON'T use unboxed arrays!! 202272 202273 Another reason for always insisting on an Array is that letting it be something 202274 else would make things like #, and #,, rather more complicated. Always using Array 202275 is the simplest thing that could possibly work, and it works rather well. 202276 202277I was trying to patch Array2D to make more things work, but just couldn't get my head 202278around the subscript order. That's why I made Matrix. 202279 202280Element-wise matrix arithmetic works; you can freely mix matrices and numbers but 202281don't try to mix matrices and arrays (yet). 202282Matrix multiplication, using the symbol +* (derived from APL's +.x), works between 202283(Matrix or Array) +* (Matrix or Array). Don't try to use a number as an argument of +*. 202284Matrix * Number and Number * Matrix work fine, so you don't need +* with numbers. 202285 202286Still to come: oodles of stuff. Gaussian elimination maybe, other stuff probably not. 202287! 202288 202289 202290!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:37'! 202291anyOne 202292 ^contents anyOne! ! 202293 202294!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:37'! 202295at: row at: column 202296 ^contents at: (self indexForRow: row andColumn: column)! ! 202297 202298!Matrix methodsFor: 'accessing' stamp: 'raok 11/28/2002 14:14'! 202299at: r at: c ifInvalid: v 202300 "If r,c is a valid index for this matrix, answer the corresponding element. 202301 Otherwise, answer v." 202302 202303 (r between: 1 and: nrows) ifFalse: [^v]. 202304 (c between: 1 and: ncols) ifFalse: [^v]. 202305 ^contents at: (r-1)*ncols + c 202306! ! 202307 202308!Matrix methodsFor: 'accessing' stamp: 'raok 11/22/2002 12:37'! 202309at: row at: column incrementBy: value 202310 "Array2D>>at:at:add: was the origin of this method, but in Smalltalk add: 202311 generally suggests adding an element to a collection, not doing a sum. 202312 This method, and SequenceableCollection>>at:incrementBy: that supports 202313 it, have been renamed to reveal their intention more clearly." 202314 202315 ^contents at: (self indexForRow: row andColumn: column) incrementBy: value! ! 202316 202317!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:40'! 202318at: row at: column put: value 202319 ^contents at: (self indexForRow: row andColumn: column) put: value! ! 202320 202321!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:42'! 202322atAllPut: value 202323 contents atAllPut: value! ! 202324 202325!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:43'! 202326atRandom 202327 ^contents atRandom 202328! ! 202329 202330!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:43'! 202331atRandom: aGenerator 202332 ^contents atRandom: aGenerator! ! 202333 202334!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:44'! 202335columnCount 202336 ^ncols! ! 202337 202338!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:48'! 202339identityIndexOf: anElement 202340 ^self identityIndexOf: anElement ifAbsent: [0@0] 202341! ! 202342 202343!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:48'! 202344identityIndexOf: anElement ifAbsent: anExceptionBlock 202345 ^self rowAndColumnForIndex: 202346 (contents identityIndexOf: anElement ifAbsent: [^anExceptionBlock value]) 202347! ! 202348 202349!Matrix methodsFor: 'accessing' stamp: 'raok 11/22/2002 13:13'! 202350indexOf: anElement 202351 "If there are integers r, c such that (self at: r at: c) = anElement, 202352 answer some such r@c, otherwise answer 0@0. This kind of perverse 202353 result is provided by analogy with SequenceableCollection>>indexOf:. 202354 The order in which the receiver are searched is UNSPECIFIED except 202355 that it is the same as the order used by #indexOf:ifAbsent: and #readStream." 202356 202357 ^self indexOf: anElement ifAbsent: [0@0] 202358! ! 202359 202360!Matrix methodsFor: 'accessing' stamp: 'raok 11/22/2002 13:10'! 202361indexOf: anElement ifAbsent: anExceptionBlock 202362 "If there are integers r, c such that (self at: r at: c) = anElement, 202363 answer some such r@c, otherwise answer the result of anExceptionBlock." 202364 202365 ^self rowAndColumnForIndex: 202366 (contents indexOf: anElement ifAbsent: [^anExceptionBlock value]) 202367! ! 202368 202369!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:49'! 202370replaceAll: oldObject with: newObject 202371 contents replaceAll: oldObject with: newObject! ! 202372 202373!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:44'! 202374rowCount 202375 ^nrows! ! 202376 202377!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:49'! 202378size 202379 ^contents size! ! 202380 202381!Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:52'! 202382swap: r1 at: c1 with: r2 at: c2 202383 contents swap: (self indexForRow: r1 andColumn: c1) 202384 with: (self indexForRow: r2 andColumn: c2)! ! 202385 202386 202387!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/22/2002 12:41'! 202388atColumn: column 202389 |p| 202390 202391 p := (self indexForRow: 1 andColumn: column)-ncols. 202392 ^(1 to: nrows) collect: [:row | contents at: (p := p+ncols)] 202393! ! 202394 202395!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/28/2002 14:21'! 202396atColumn: column put: aCollection 202397 |p| 202398 202399 aCollection size = nrows ifFalse: [self error: 'wrong column size']. 202400 p := (self indexForRow: 1 andColumn: column)-ncols. 202401 aCollection do: [:each | contents at: (p := p+ncols) put: each]. 202402 ^aCollection 202403! ! 202404 202405!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 10/21/2002 23:32'! 202406atRow: row 202407 (row between: 1 and: nrows) 202408 ifFalse: [self error: '1st subscript out of range']. 202409 ^contents copyFrom: (row-1)*ncols+1 to: row*ncols! ! 202410 202411!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/22/2002 12:42'! 202412atRow: row put: aCollection 202413 |p| 202414 202415 aCollection size = ncols ifFalse: [self error: 'wrong row size']. 202416 p := (self indexForRow: row andColumn: 1)-1. 202417 aCollection do: [:each | contents at: (p := p+1) put: each]. 202418 ^aCollection! ! 202419 202420!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 10/23/2002 20:41'! 202421diagonal 202422 "Answer (1 to: (nrows min: ncols)) collect: [:i | self at: i at: i]" 202423 |i| 202424 202425 i := ncols negated. 202426 ^(1 to: (nrows min: ncols)) collect: [:j | contents at: (i := i + ncols + 1)]! ! 202427 202428!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/28/2002 14:21'! 202429swapColumn: anIndex withColumn: anotherIndex 202430 |a b| 202431 202432 a := self indexForRow: 1 andColumn: anIndex. 202433 b := self indexForRow: 1 andColumn: anotherIndex. 202434 nrows timesRepeat: [ 202435 contents swap: a with: b. 202436 a := a + ncols. 202437 b := b + ncols]. 202438! ! 202439 202440!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/28/2002 14:22'! 202441swapRow: anIndex withRow: anotherIndex 202442 |a b| 202443 202444 a := self indexForRow: anIndex andColumn: 1. 202445 b := self indexForRow: anotherIndex andColumn: 1. 202446 ncols timesRepeat: [ 202447 contents swap: a with: b. 202448 a := a + 1. 202449 b := b + 1]. 202450! ! 202451 202452!Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 10/22/2002 00:13'! 202453transposed 202454 self assert: [nrows = ncols]. 202455 ^self indicesCollect: [:row :column | self at: column at: row]! ! 202456 202457 202458!Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 13:09'! 202459atRows: rs columns: cs 202460 "Answer a Matrix obtained by slicing the receiver. 202461 rs and cs should be sequenceable collections of positive integers." 202462 202463 ^self class rows: rs size columns: cs size tabulate: [:r :c | 202464 self at: (rs at: r) at: (cs at: c)]! ! 202465 202466!Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 12:30'! 202467atRows: r1 to: r2 columns: c1 to: c2 202468 "Answer a submatrix [r1..r2][c1..c2] of the receiver." 202469 |rd cd| 202470 202471 rd := r1 - 1. 202472 cd := c1 - 1. 202473 ^self class rows: r2-rd columns: c2-cd tabulate: [:r :c| self at: r+rd at: c+cd] 202474! ! 202475 202476!Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 13:05'! 202477atRows: r1 to: r2 columns: c1 to: c2 ifInvalid: element 202478 "Answer a submatrix [r1..r2][c1..c2] of the receiver. 202479 Portions of the result outside the bounds of the original matrix 202480 are filled in with element." 202481 |rd cd| 202482 202483 rd := r1 - 1. 202484 cd := c1 - 1. 202485 ^self class rows: r2-rd columns: c2-cd tabulate: [:r :c| self at: r+rd at: c+cd ifInvalid: element] 202486! ! 202487 202488!Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 12:32'! 202489atRows: r1 to: r2 columns: c1 to: c2 put: aMatrix 202490 "Set the [r1..r2][c1..c2] submatrix of the receiver 202491 from the [1..r2-r1+1][1..c2-c1+1] submatrix of aMatrix. 202492 As long as aMatrix responds to at:at: and accepts arguments in the range shown, 202493 we don't care if it is bigger or even if it is a Matrix at all." 202494 |rd cd| 202495 202496 rd := r1 - 1. 202497 cd := c1 - 1. 202498 r1 to: r2 do: [:r | 202499 c1 to: c2 do: [:c | 202500 self at: r at: c put: (aMatrix at: r-rd at: c-cd)]]. 202501 ^aMatrix 202502! ! 202503 202504 202505!Matrix methodsFor: 'adding' stamp: 'raok 10/21/2002 22:53'! 202506add: newObject 202507 self shouldNotImplement! ! 202508 202509 202510!Matrix methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:01'! 202511+* aCollection 202512 "Premultiply aCollection by self. aCollection should be an Array or Matrix. 202513 The name of this method is APL's +.x squished into Smalltalk syntax." 202514 202515 ^aCollection preMultiplyByMatrix: self 202516! ! 202517 202518!Matrix methodsFor: 'arithmetic' stamp: 'raok 11/28/2002 14:22'! 202519preMultiplyByArray: a 202520 "Answer a +* self where a is an Array." 202521 202522 nrows = 1 ifFalse: [self error: 'dimensions do not conform']. 202523 ^Matrix rows: a size columns: ncols tabulate: [:row :col | 202524 (a at: row) * (contents at: col)] 202525! ! 202526 202527!Matrix methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:02'! 202528preMultiplyByMatrix: m 202529 "Answer m +* self where m is a Matrix." 202530 |s| 202531 202532 nrows = m columnCount ifFalse: [self error: 'dimensions do not conform']. 202533 ^Matrix rows: m rowCount columns: ncols tabulate: [:row :col | 202534 s := 0. 202535 1 to: nrows do: [:k | s := (m at: row at: k) * (self at: k at: col) + s]. 202536 s]! ! 202537 202538 202539!Matrix methodsFor: 'comparing' stamp: 'raok 11/22/2002 12:58'! 202540= aMatrix 202541 ^aMatrix class == self class and: [ 202542 aMatrix rowCount = nrows and: [ 202543 aMatrix columnCount = ncols and: [ 202544 aMatrix privateContents = contents]]]! ! 202545 202546!Matrix methodsFor: 'comparing' stamp: 'raok 11/22/2002 13:14'! 202547hash 202548 "I'm really not sure what would be a good hash function here. 202549 The essential thing is that it must be compatible with #=, and 202550 this satisfies that requirement." 202551 202552 ^contents hash! ! 202553 202554 202555!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:57'! 202556asArray 202557 ^contents shallowCopy! ! 202558 202559!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:57'! 202560asBag 202561 ^contents asBag! ! 202562 202563!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! 202564asByteArray 202565 ^contents asByteArray! ! 202566 202567!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! 202568asCharacterSet 202569 ^contents asCharacterSet! ! 202570 202571!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'! 202572asFloatArray 202573 ^contents asFloatArray! ! 202574 202575!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! 202576asIdentitySet 202577 ^contents asIdentitySet! ! 202578 202579!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'! 202580asIntegerArray 202581 ^contents asIntegerArray! ! 202582 202583!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! 202584asOrderedCollection 202585 ^contents asOrderedCollection! ! 202586 202587!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! 202588asSet 202589 ^contents asSet! ! 202590 202591!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! 202592asSortedArray 202593 ^contents asSortedArray! ! 202594 202595!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:59'! 202596asSortedCollection 202597 ^contents asSortedCollection! ! 202598 202599!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:59'! 202600asSortedCollection: aBlock 202601 ^contents asSortedCollection: aBlock! ! 202602 202603!Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'! 202604asWordArray 202605 ^contents asWordArray! ! 202606 202607!Matrix methodsFor: 'converting' stamp: 'damiencassou 5/30/2008 11:45'! 202608readStream 202609 "Answer a ReadStream that returns all the elements of the receiver 202610 in some UNSPECIFIED order." 202611 ^ contents readStream! ! 202612 202613 202614!Matrix methodsFor: 'copying' stamp: 'raok 11/22/2002 12:57'! 202615, aMatrix 202616 "Answer a new matrix having the same number of rows as the receiver and aMatrix, 202617 its columns being the columns of the receiver followed by the columns of aMatrix." 202618 |newCont newCols anArray oldCols a b c| 202619 202620 self assert: [nrows = aMatrix rowCount]. 202621 newCont := Array new: self size + aMatrix size. 202622 anArray := aMatrix privateContents. 202623 oldCols := aMatrix columnCount. 202624 newCols := ncols + oldCols. 202625 a := b := c := 1. 202626 1 to: nrows do: [:r | 202627 newCont replaceFrom: a to: a+ncols-1 with: contents startingAt: b. 202628 newCont replaceFrom: a+ncols to: a+newCols-1 with: anArray startingAt: c. 202629 a := a + newCols. 202630 b := b + ncols. 202631 c := c + oldCols]. 202632 ^self class rows: nrows columns: newCols contents: newCont 202633 202634! ! 202635 202636!Matrix methodsFor: 'copying' stamp: 'raok 11/22/2002 12:58'! 202637,, aMatrix 202638 "Answer a new matrix having the same number of columns as the receiver and aMatrix, 202639 its rows being the rows of the receiver followed by the rows of aMatrix." 202640 202641 self assert: [ncols = aMatrix columnCount]. 202642 ^self class rows: nrows + aMatrix rowCount columns: ncols 202643 contents: contents , aMatrix privateContents 202644! ! 202645 202646!Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:07'! 202647copy 202648 ^self class rows: nrows columns: ncols contents: contents copy! ! 202649 202650!Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:07'! 202651shallowCopy 202652 ^self class rows: nrows columns: ncols contents: contents shallowCopy! ! 202653 202654!Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:27'! 202655shuffled 202656 ^self class rows: nrows columns: ncols contents: (contents shuffled)! ! 202657 202658!Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:27'! 202659shuffledBy: aRandom 202660 ^self class rows: nrows columns: ncols contents: (contents shuffledBy: aRandom)! ! 202661 202662 202663!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:41'! 202664collect: aBlock 202665 "Answer a new matrix with transformed elements; transformations should be independent." 202666 202667 ^self class rows: nrows columns: ncols contents: (contents collect: aBlock)! ! 202668 202669!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'! 202670difference: aCollection 202671 "Union is in because the result is always a Set. 202672 Difference and intersection are out because the result is like the receiver, 202673 and with irregular seleection that cannot be." 202674 self shouldNotImplement! ! 202675 202676!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:40'! 202677do: aBlock 202678 "Pass elements to aBlock one at a time in row-major order." 202679 contents do: aBlock! ! 202680 202681!Matrix methodsFor: 'enumerating' stamp: 'raok 10/23/2002 20:57'! 202682indicesCollect: aBlock 202683 |r i| 202684 202685 r := Array new: nrows * ncols. 202686 i := 0. 202687 1 to: nrows do: [:row | 202688 1 to: ncols do: [:column | 202689 r at: (i := i+1) put: (aBlock value: row value: column)]]. 202690 ^self class rows: nrows columns: ncols contents: r! ! 202691 202692!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:49'! 202693indicesDo: aBlock 202694 1 to: nrows do: [:row | 202695 1 to: ncols do: [:column | 202696 aBlock value: row value: column]].! ! 202697 202698!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:51'! 202699indicesInject: start into: aBlock 202700 |current| 202701 202702 current := start. 202703 1 to: nrows do: [:row | 202704 1 to: ncols do: [:column | 202705 current := aBlock value: current value: row value: column]]. 202706 ^current! ! 202707 202708!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'! 202709intersection: aCollection 202710 "Union is in because the result is always a Set. 202711 Difference and intersection are out because the result is like the receiver, 202712 and with irregular seleection that cannot be." 202713 self shouldNotImplement! ! 202714 202715!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'! 202716reject: aBlock 202717 self shouldNotImplement! ! 202718 202719!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'! 202720select: aBlock 202721 self shouldNotImplement! ! 202722 202723!Matrix methodsFor: 'enumerating' stamp: 'raok 10/22/2002 00:15'! 202724with: aCollection collect: aBlock 202725 "aCollection must support #at:at: and be at least as large as the receiver." 202726 202727 ^self withIndicesCollect: [:each :row :column | 202728 aBlock value: each value: (aCollection at: row at: column)] 202729! ! 202730 202731!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:53'! 202732with: aCollection do: aBlock 202733 "aCollection must support #at:at: and be at least as large as the receiver." 202734 202735 self withIndicesDo: [:each :row :column | 202736 aBlock value: each value: (aCollection at: row at: column)]. 202737! ! 202738 202739!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:55'! 202740with: aCollection inject: startingValue into: aBlock 202741 "aCollection must support #at:at: and be at least as large as the receiver." 202742 202743 ^self withIndicesInject: startingValue into: [:value :each :row :column | 202744 aBlock value: value value: each value: (aCollection at: row at: column)]! ! 202745 202746!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:52'! 202747withIndicesCollect: aBlock 202748 |i r| 202749 202750 i := 0. 202751 r := contents shallowCopy. 202752 1 to: nrows do: [:row | 202753 1 to: ncols do: [:column | 202754 i := i+1. 202755 r at: i put: (aBlock value: (r at: i) value: row value: column)]]. 202756 ^self class rows: nrows columns: ncols contents: r 202757! ! 202758 202759!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:52'! 202760withIndicesDo: aBlock 202761 |i| 202762 202763 i := 0. 202764 1 to: nrows do: [:row | 202765 1 to: ncols do: [:column | 202766 aBlock value: (contents at: (i := i+1)) value: row value: column]]. 202767! ! 202768 202769!Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:52'! 202770withIndicesInject: start into: aBlock 202771 |i current| 202772 202773 i := 0. 202774 current := start. 202775 1 to: nrows do: [:row | 202776 1 to: ncols do: [:column | 202777 current := aBlock value: current value: (contents at: (i := i+1)) 202778 value: row value: column]]. 202779 ^current! ! 202780 202781 202782!Matrix methodsFor: 'printing' stamp: 'raok 10/21/2002 23:22'! 202783storeOn: aStream 202784 aStream nextPut: $(; nextPutAll: self class name; 202785 nextPutAll: ' rows: '; store: nrows; 202786 nextPutAll: ' columns: '; store: ncols; 202787 nextPutAll: ' contents: '; store: contents; 202788 nextPut: $)! ! 202789 202790 202791!Matrix methodsFor: 'removing' stamp: 'raok 10/21/2002 22:54'! 202792remove: anObject ifAbsent: anExceptionBlock 202793 self shouldNotImplement! ! 202794 202795 202796!Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:24'! 202797identityIncludes: anObject 202798 ^contents identityIncludes: anObject! ! 202799 202800!Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:23'! 202801includes: anObject 202802 ^contents includes: anObject! ! 202803 202804!Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:24'! 202805includesAllOf: aCollection 202806 ^contents includesAllOf: aCollection! ! 202807 202808!Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:24'! 202809includesAnyOf: aCollection 202810 ^contents includesAnyOf: aCollection! ! 202811 202812!Matrix methodsFor: 'testing' stamp: 'raok 11/22/2002 13:03'! 202813isSequenceable 202814 "LIE so that arithmetic on matrices will work. 202815 What matters for arithmetic is not that there should be random indexing 202816 but that the structure should be stable and independent of the values of 202817 the elements. #isSequenceable is simply the wrong question to ask." 202818 ^true! ! 202819 202820!Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:25'! 202821occurrencesOf: anObject 202822 ^contents occurrencesOf: anObject! ! 202823 202824 202825!Matrix methodsFor: 'private' stamp: 'raok 10/21/2002 22:40'! 202826indexForRow: row andColumn: column 202827 (row between: 1 and: nrows) 202828 ifFalse: [self error: '1st subscript out of range']. 202829 (column between: 1 and: ncols) 202830 ifFalse: [self error: '2nd subscript out of range']. 202831 ^(row-1) * ncols + column! ! 202832 202833!Matrix methodsFor: 'private' stamp: 'raok 11/22/2002 12:56'! 202834privateContents 202835 "Only used in #, #,, and #= so far. 202836 It used to be called #contents, but that clashes with Collection>>contents." 202837 202838 ^contents! ! 202839 202840!Matrix methodsFor: 'private' stamp: 'raok 10/21/2002 22:47'! 202841rowAndColumnForIndex: index 202842 |t| 202843 202844 t := index - 1. 202845 ^(t // ncols + 1)@(t \\ ncols + 1)! ! 202846 202847!Matrix methodsFor: 'private' stamp: 'raok 10/21/2002 23:05'! 202848rows: rows columns: columns contents: anArray 202849 self assert: [rows isInteger and: [rows >= 0]]. 202850 self assert: [columns isInteger and: [columns >= 0]]. 202851 self assert: [rows * columns = anArray size]. 202852 nrows := rows. 202853 ncols := columns. 202854 contents := anArray. 202855 ^self! ! 202856 202857"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 202858 202859Matrix class 202860 instanceVariableNames: ''! 202861 202862!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/23/2002 20:58'! 202863column: aCollection 202864 "Should this be called #fromColumn:?" 202865 202866 ^self rows: aCollection size columns: 1 contents: aCollection asArray shallowCopy! ! 202867 202868!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 00:09'! 202869diagonal: aCollection 202870 |r i| 202871 r := self zeros: aCollection size. 202872 i := 0. 202873 aCollection do: [:each | i := i+1. r at: i at: i put: each]. 202874 ^r! ! 202875 202876!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/23/2002 20:59'! 202877identity: n 202878 |r| 202879 202880 r := self zeros: n. 202881 1 to: n do: [:i | r at: i at: i put: 1]. 202882 ^r! ! 202883 202884!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 00:06'! 202885new: dim 202886 "Answer a dim*dim matrix. Is this an abuse of #new:? The argument is NOT a size." 202887 ^self rows: dim columns: dim! ! 202888 202889!Matrix class methodsFor: 'instance creation' stamp: 'raok 11/25/2002 12:51'! 202890new: dim element: element 202891 "Answer a dim*dim matrix with all elements set to element. 202892 Is this an abuse of #new:? The argument is NOT a size." 202893 202894 ^self rows: dim columns: dim element: element! ! 202895 202896!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 19:54'! 202897new: dim tabulate: aBlock 202898 "Answer a dim*dim matrix where it at: i at: j is aBlock value: i value: j." 202899 ^self rows: dim columns: dim tabulate: aBlock! ! 202900 202901!Matrix class methodsFor: 'instance creation' stamp: 'raok 11/28/2002 14:08'! 202902ones: n 202903 ^self new: n element: 1 202904! ! 202905 202906!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/23/2002 20:59'! 202907row: aCollection 202908 "Should this be called #fromRow:?" 202909 202910 ^self rows: 1 columns: aCollection size contents: aCollection asArray shallowCopy! ! 202911 202912!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 00:04'! 202913rows: rows columns: columns 202914 ^self rows: rows columns: columns contents: (Array new: rows*columns)! ! 202915 202916!Matrix class methodsFor: 'instance creation' stamp: 'raok 11/28/2002 14:10'! 202917rows: rows columns: columns element: element 202918 ^self rows: rows columns: columns 202919 contents: ((Array new: rows*columns) atAllPut: element; yourself)! ! 202920 202921!Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 19:51'! 202922rows: rows columns: columns tabulate: aBlock 202923 "Answer a new Matrix of the given dimensions where 202924 result at: i at: j is aBlock value: i value: j" 202925 |a i| 202926 202927 a := Array new: rows*columns. 202928 i := 0. 202929 1 to: rows do: [:row | 202930 1 to: columns do: [:column | 202931 a at: (i := i+1) put: (aBlock value: row value: column)]]. 202932 ^self rows: rows columns: columns contents: a 202933! ! 202934 202935!Matrix class methodsFor: 'instance creation' stamp: 'raok 11/28/2002 14:09'! 202936zeros: n 202937 ^self new: n element: 0! ! 202938 202939 202940!Matrix class methodsFor: 'private' stamp: 'raok 10/21/2002 23:06'! 202941rows: rows columns: columns contents: contents 202942 ^self new rows: rows columns: columns contents: contents! ! 202943TestCase subclass: #MatrixTest 202944 instanceVariableNames: 'matrix1 matrix2 matrix3' 202945 classVariableNames: '' 202946 poolDictionaries: '' 202947 category: 'CollectionsTests-Unordered'! 202948 202949!MatrixTest methodsFor: 'testing' stamp: 'dc 3/3/2007 17:58'! 202950setUp 202951 matrix1 := Matrix new: 2. 202952 matrix1 at:1 at:1 put: 1. 202953 matrix1 at:1 at:2 put: 3. 202954 matrix1 at:2 at:1 put: 2. 202955 matrix1 at:2 at:2 put: 4. 202956 202957 matrix2 := Matrix new: 2. 202958 matrix2 at:1 at:1 put: 3. 202959 matrix2 at:1 at:2 put: 7. 202960 matrix2 at:2 at:1 put: 4. 202961 matrix2 at:2 at:2 put: 8.! ! 202962 202963 202964!MatrixTest methodsFor: 'tests - accessing' stamp: 'dc 3/3/2007 17:47'! 202965testAtAt 202966 self should:[matrix1 at: 2 at: 3] raise: Error. 202967 self should:[matrix1 at: 3 at: 2] raise: Error. 202968 self should:[matrix1 at: 3 at: 3] raise: Error. 202969 self should:[matrix1 at: 0 at: 1] raise: Error. 202970 self should:[matrix1 at: 1 at: 0] raise: Error. 202971 self should:[matrix1 at: 0 at: 0] raise: Error. 202972 202973 self assert: (matrix1 at: 1 at: 1) = 1! ! 202974 202975!MatrixTest methodsFor: 'tests - accessing' stamp: 'dc 3/3/2007 17:52'! 202976testReplaceAll 202977 202978 matrix1 replaceAll: 1 with: 10. 202979 self assert: (matrix1 at:1 at:1) = 10. 202980 self assert: (matrix1 at:2 at:1) = 2. 202981 self assert: (matrix1 at:1 at:2) = 3. 202982 self assert: (matrix1 at:2 at:2) = 4.! ! 202983 202984!MatrixTest methodsFor: 'tests - accessing' stamp: 'dc 3/3/2007 17:53'! 202985testSwap 202986 matrix1 swap: 1 at: 2 with: 1 at: 1. 202987 self assert: (matrix1 at: 1 at: 1) = 3. 202988 self assert: (matrix1 at: 1 at: 2) = 1.! ! 202989 202990!MatrixTest methodsFor: 'tests - accessing' stamp: 'dc 3/3/2007 17:58'! 202991testTransposed 202992 | transposedMatrix | 202993 202994 transposedMatrix := matrix1 transposed. 202995 self assert: [(transposedMatrix at:1 at:1) = 1]. 202996 self assert: [(transposedMatrix at:1 at:2) = 2]. 202997 self assert: [(transposedMatrix at:2 at:1) = 3]. 202998 self assert: [(transposedMatrix at:2 at:2) = 4].! ! 202999 203000 203001!MatrixTest methodsFor: 'tests - arithmetic' stamp: 'dc 3/3/2007 17:50'! 203002testMultiply 203003 203004 | result | 203005 self should: [matrix1 preMultiplyByMatrix: (Matrix new: 3)]raise: Error. 203006 203007 result := matrix2 preMultiplyByMatrix: matrix1. 203008 self assert: (result at: 1 at: 1) = 15. 203009 self assert: (result at: 1 at: 2) = 31. 203010 self assert: (result at: 2 at: 1) = 22. 203011 self assert: (result at: 2 at: 2) = 46! ! 203012 203013 203014!MatrixTest methodsFor: 'tests - copying' stamp: 'dc 3/3/2007 17:48'! 203015testCopy 203016 203017 | copyMatrix | 203018 203019 copyMatrix := matrix1 copy. 203020 self assert: matrix1 = copyMatrix ! ! 203021 203022 203023!MatrixTest methodsFor: 'tests - testing' stamp: 'dc 3/3/2007 17:49'! 203024testIncludes 203025 self assert: 203026 ((1 to: 4) 203027 allSatisfy: [:i | matrix1 includes: i]) 203028! ! 203029DisplayTransform variableWordSubclass: #MatrixTransform2x3 203030 instanceVariableNames: '' 203031 classVariableNames: '' 203032 poolDictionaries: '' 203033 category: 'Graphics-Transformations'! 203034!MatrixTransform2x3 commentStamp: '<historical>' prior: 0! 203035This class represents a transformation for points, that is a combination of scale, offset, and rotation. It is implemented as a 2x3 matrix containing the transformation from the local coordinate system in the global coordinate system. Thus, transforming points from local to global coordinates is fast and cheap whereas transformations from global to local coordinate systems are relatively expensive. 203036 203037Implementation Note: It is assumed that the transformation deals with Integer points. All transformations will return Integer coordinates (even though float points may be passed in here).! 203038 203039 203040!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! 203041at: index 203042 <primitive: 'primitiveAt' module: 'FloatArrayPlugin'> 203043 ^Float fromIEEE32Bit: (self basicAt: index)! ! 203044 203045!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! 203046at: index put: value 203047 <primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'> 203048 value isFloat 203049 ifTrue:[self basicAt: index put: value asIEEE32BitWord] 203050 ifFalse:[self at: index put: value asFloat]. 203051 ^value! ! 203052 203053!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 203054inverseTransformation 203055 "Return the inverse transformation of the receiver. 203056 The inverse transformation is computed by first calculating 203057 the inverse offset and then computing transformations 203058 for the two identity vectors (1@0) and (0@1)" 203059 | r1 r2 r3 m | 203060 r3 := self invertPoint: 0 @ 0. 203061 r1 := (self invertPoint: 1 @ 0) - r3. 203062 r2 := (self invertPoint: 0 @ 1) - r3. 203063 m := self species new. 203064 m 203065 a11: r1 x; 203066 a12: r2 x; 203067 a13: r3 x; 203068 a21: r1 y; 203069 a22: r2 y; 203070 a23: r3 y. 203071 ^ m! ! 203072 203073!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/2/1998 23:19'! 203074offset 203075 ^self a13 @ self a23! ! 203076 203077!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/2/1998 23:05'! 203078offset: aPoint 203079 self a13: aPoint x asFloat. 203080 self a23: aPoint y asFloat.! ! 203081 203082 203083!MatrixTransform2x3 methodsFor: 'comparing' stamp: 'lr 7/4/2009 10:42'! 203084hash 203085 | result | 203086 <primitive: 'primitiveHashArray' module: 'FloatArrayPlugin'> 203087 result := 0. 203088 1 203089 to: self size 203090 do: [ :i | result := result + (self basicAt: i) ]. 203091 ^ result bitAnd: 536870911! ! 203092 203093!MatrixTransform2x3 methodsFor: 'comparing' stamp: 'lr 7/4/2009 10:42'! 203094= aMatrixTransform2x3 203095 | length | 203096 <primitive: 'primitiveEqual' module: 'FloatArrayPlugin'> 203097 self class = aMatrixTransform2x3 class ifFalse: [ ^ false ]. 203098 length := self size. 203099 length = aMatrixTransform2x3 size ifFalse: [ ^ false ]. 203100 1 203101 to: self size 203102 do: [ :i | (self at: i) = (aMatrixTransform2x3 at: i) ifFalse: [ ^ false ] ]. 203103 ^ true! ! 203104 203105 203106!MatrixTransform2x3 methodsFor: 'composing' stamp: 'RAA 9/20/2000 13:10'! 203107composedWithLocal: aTransformation 203108 "Return the composition of the receiver and the local transformation passed in" 203109 aTransformation isMatrixTransform2x3 ifFalse:[^super composedWithLocal: aTransformation]. 203110 ^self composedWithLocal: aTransformation asMatrixTransform2x3 into: self class new! ! 203111 203112!MatrixTransform2x3 methodsFor: 'composing' stamp: 'lr 7/4/2009 10:42'! 203113composedWithLocal: aTransformation into: result 203114 "Return the composition of the receiver and the local transformation passed in. 203115 Store the composed matrix into result." 203116 | a11 a12 a13 a21 a22 a23 b11 b12 b13 b21 b22 b23 matrix | 203117 <primitive: 'primitiveComposeMatrix' module: 'Matrix2x3Plugin'> 203118 matrix := aTransformation asMatrixTransform2x3. 203119 a11 := self a11. 203120 b11 := matrix a11. 203121 a12 := self a12. 203122 b12 := matrix a12. 203123 a13 := self a13. 203124 b13 := matrix a13. 203125 a21 := self a21. 203126 b21 := matrix a21. 203127 a22 := self a22. 203128 b22 := matrix a22. 203129 a23 := self a23. 203130 b23 := matrix a23. 203131 result a11: a11 * b11 + (a12 * b21). 203132 result a12: a11 * b12 + (a12 * b22). 203133 result a13: a13 + (a11 * b13) + (a12 * b23). 203134 result a21: a21 * b11 + (a22 * b21). 203135 result a22: a21 * b12 + (a22 * b22). 203136 result a23: a23 + (a21 * b13) + (a22 * b23). 203137 ^ result! ! 203138 203139 203140!MatrixTransform2x3 methodsFor: 'converting' stamp: 'ar 11/2/1998 15:34'! 203141asMatrixTransform2x3 203142 ^self! ! 203143 203144 203145!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! 203146a11 203147 ^self at: 1! ! 203148 203149!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! 203150a11: value 203151 self at: 1 put: value! ! 203152 203153!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! 203154a12 203155 ^self at: 2! ! 203156 203157!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! 203158a12: value 203159 self at: 2 put: value! ! 203160 203161!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! 203162a13 203163 ^self at: 3! ! 203164 203165!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! 203166a13: value 203167 self at: 3 put: value! ! 203168 203169!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! 203170a21 203171 ^self at: 4! ! 203172 203173!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! 203174a21: value 203175 self at: 4 put: value! ! 203176 203177!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! 203178a22 203179 ^self at: 5! ! 203180 203181!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! 203182a22: value 203183 self at: 5 put: value! ! 203184 203185!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! 203186a23 203187 ^self at: 6! ! 203188 203189!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! 203190a23: value 203191 self at: 6 put: value! ! 203192 203193 203194!MatrixTransform2x3 methodsFor: 'initialize' stamp: 'ar 11/2/1998 23:17'! 203195setIdentiy 203196 "Initialize the receiver to the identity transformation (e.g., not affecting points)" 203197 self 203198 a11: 1.0; a12: 0.0; a13: 0.0; 203199 a21: 0.0; a22: 1.0; a23: 0.0.! ! 203200 203201 203202!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:06'! 203203byteSize 203204 ^self basicSize * self bytesPerBasicElement! ! 203205 203206!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 15:04'! 203207bytesPerBasicElement 203208 "Answer the number of bytes that each of my basic elements requires. 203209 In other words: 203210 self basicSize * self bytesPerBasicElement 203211 should equal the space required on disk by my variable sized representation." 203212 ^4! ! 203213 203214!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'yo 3/6/2004 12:57'! 203215bytesPerElement 203216 203217 ^ 4. 203218! ! 203219 203220!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'lr 7/4/2009 10:42'! 203221restoreEndianness 203222 "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian. 203223 Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap." 203224 | w b1 b2 b3 b4 | 203225 SmalltalkImage current isLittleEndian ifTrue: 203226 [ 1 203227 to: self basicSize 203228 do: 203229 [ :i | 203230 w := self basicAt: i. 203231 b1 := w digitAt: 1. 203232 b2 := w digitAt: 2. 203233 b3 := w digitAt: 3. 203234 b4 := w digitAt: 4. 203235 w := (b1 << 24) + (b2 << 16) + (b3 << 8) + b4. 203236 self 203237 basicAt: i 203238 put: w ] ]! ! 203239 203240!MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'ar 8/6/2001 17:52'! 203241writeOn: aStream 203242 aStream nextWordsPutAll: self.! ! 203243 203244 203245!MatrixTransform2x3 methodsFor: 'printing' stamp: 'ar 11/2/1998 23:11'! 203246printOn: aStream 203247 aStream 203248 nextPutAll: self class name; 203249 nextPut: $(; 203250 cr; print: self a11; tab; print: self a12; tab; print: self a13; 203251 cr; print: self a21; tab; print: self a22; tab; print: self a23; 203252 cr; nextPut:$).! ! 203253 203254 203255!MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 2/2/2001 15:47'! 203256isIdentity 203257 "Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself." 203258 <primitive: 'primitiveIsIdentity' module: 'Matrix2x3Plugin'> 203259 ^self isPureTranslation and:[self a13 = 0.0 and:[self a23 = 0.0]]! ! 203260 203261!MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 11/2/1998 23:15'! 203262isMatrixTransform2x3 203263 "Return true if the receiver is 2x3 matrix transformation" 203264 ^true! ! 203265 203266!MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 2/2/2001 15:47'! 203267isPureTranslation 203268 "Return true if the receiver specifies no rotation or scaling." 203269 <primitive: 'primitiveIsPureTranslation' module: 'Matrix2x3Plugin'> 203270 ^self a11 = 1.0 and:[self a12 = 0.0 and:[self a22 = 0.0 and:[self a21 = 1.0]]]! ! 203271 203272 203273!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 2/2/2001 15:47'! 203274globalPointToLocal: aPoint 203275 "Transform aPoint from global coordinates into local coordinates" 203276 <primitive: 'primitiveInvertPoint' module: 'Matrix2x3Plugin'> 203277 ^(self invertPoint: aPoint) rounded! ! 203278 203279!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'lr 7/4/2009 10:42'! 203280invertPoint: aPoint 203281 "Transform aPoint from global coordinates into local coordinates" 203282 | x y det a11 a12 a21 a22 detX detY | 203283 x := aPoint x asFloat - self a13. 203284 y := aPoint y asFloat - self a23. 203285 a11 := self a11. 203286 a12 := self a12. 203287 a21 := self a21. 203288 a22 := self a22. 203289 det := a11 * a22 - (a12 * a21). 203290 det = 0.0 ifTrue: [ ^ 0 @ 0 ]. "So we have at least a valid result" 203291 det := 1.0 / det. 203292 detX := x * a22 - (a12 * y). 203293 detY := a11 * y - (x * a21). 203294 ^ (detX * det) @ (detY * det)! ! 203295 203296!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 2/2/2001 15:47'! 203297localPointToGlobal: aPoint 203298 "Transform aPoint from local coordinates into global coordinates" 203299 <primitive: 'primitiveTransformPoint' module: 'Matrix2x3Plugin'> 203300 ^(self transformPoint: aPoint) rounded! ! 203301 203302!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'lr 7/4/2009 10:42'! 203303transformDirection: aPoint 203304 "Transform aPoint from local coordinates into global coordinates" 203305 | x y | 203306 x := aPoint x * self a11 + (aPoint y * self a12). 203307 y := aPoint x * self a21 + (aPoint y * self a22). 203308 ^ x @ y! ! 203309 203310!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'lr 7/4/2009 10:42'! 203311transformPoint: aPoint 203312 "Transform aPoint from local coordinates into global coordinates" 203313 | x y | 203314 x := aPoint x * self a11 + (aPoint y * self a12) + self a13. 203315 y := aPoint x * self a21 + (aPoint y * self a22) + self a23. 203316 ^ x @ y! ! 203317 203318 203319!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 11/9/1998 14:40'! 203320globalBoundsToLocal: aRectangle 203321 "Transform aRectangle from global coordinates into local coordinates" 203322 ^self globalBounds: aRectangle toLocal: Rectangle new! ! 203323 203324!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 2/2/2001 15:47'! 203325globalBounds: srcRect toLocal: dstRect 203326 "Transform aRectangle from global coordinates into local coordinates" 203327 <primitive: 'primitiveInvertRectInto' module: 'Matrix2x3Plugin'> 203328 ^super globalBoundsToLocal: srcRect! ! 203329 203330!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 11/9/1998 14:40'! 203331localBoundsToGlobal: aRectangle 203332 "Transform aRectangle from local coordinates into global coordinates" 203333 ^self localBounds: aRectangle toGlobal: Rectangle new! ! 203334 203335!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 2/2/2001 15:47'! 203336localBounds: srcRect toGlobal: dstRect 203337 "Transform aRectangle from local coordinates into global coordinates" 203338 <primitive: 'primitiveTransformRectInto' module: 'Matrix2x3Plugin'> 203339 ^super localBoundsToGlobal: srcRect! ! 203340 203341 203342!MatrixTransform2x3 methodsFor: 'private' stamp: 'ar 11/2/1998 23:17'! 203343setAngle: angle 203344 "Set the raw rotation angle in the receiver" 203345 | rad s c | 203346 rad := angle degreesToRadians. 203347 s := rad sin. 203348 c := rad cos. 203349 self a11: c. 203350 self a12: s negated. 203351 self a21: s. 203352 self a22: c.! ! 203353 203354!MatrixTransform2x3 methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 203355setOffset: aPoint 203356 "Set the raw offset in the receiver" 203357 | pt | 203358 pt := aPoint asPoint. 203359 self a13: pt x asFloat. 203360 self a23: pt y asFloat! ! 203361 203362!MatrixTransform2x3 methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 203363setScale: aPoint 203364 "Set the raw scale in the receiver" 203365 | pt | 203366 pt := aPoint asPoint. 203367 self a11: pt x asFloat. 203368 self a22: pt y asFloat! ! 203369 203370"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 203371 203372MatrixTransform2x3 class 203373 instanceVariableNames: ''! 203374 203375!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 22:50'! 203376identity 203377 ^self new setScale: 1.0! ! 203378 203379!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 7/9/1998 20:09'! 203380new 203381 ^self new: 6! ! 203382 203383!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'mir 6/12/2001 15:34'! 203384newFromStream: s 203385 "Only meant for my subclasses that are raw bits and word-like. For quick unpack form the disk." 203386 self isPointers | self isWords not ifTrue: [^ super newFromStream: s]. 203387 "super may cause an error, but will not be called." 203388 ^ s nextWordsInto: (self new: 6)! ! 203389 203390!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/12/1998 01:25'! 203391transformFromLocal: localBounds toGlobal: globalBounds 203392 ^((self withOffset: (globalBounds center)) composedWithLocal: 203393 (self withScale: (globalBounds extent / localBounds extent) asFloatPoint)) 203394 composedWithLocal: (self withOffset: localBounds center negated) 203395" 203396 ^(self identity) 203397 setScale: (globalBounds extent / localBounds extent) asFloatPoint; 203398 setOffset: localBounds center negated asFloatPoint; 203399 composedWithGlobal:(self withOffset: globalBounds center asFloatPoint) 203400"! ! 203401 203402!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 02:49'! 203403withAngle: angle 203404 ^self new setAngle: angle! ! 203405 203406!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 02:52'! 203407withOffset: aPoint 203408 ^self identity setOffset: aPoint! ! 203409 203410!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 23:17'! 203411withRotation: angle 203412 ^self new setAngle: angle! ! 203413 203414!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 02:49'! 203415withScale: aPoint 203416 ^self new setScale: aPoint! ! 203417Morph subclass: #MatrixTransformMorph 203418 instanceVariableNames: 'transform' 203419 classVariableNames: '' 203420 poolDictionaries: '' 203421 category: 'Morphic-Balloon'! 203422!MatrixTransformMorph commentStamp: '<historical>' prior: 0! 203423MatrixTransformMorph is similar to TransformMorph but uses a MatrixTransform2x3 instead of a MorphicTransform. It is used by clients who want use the BalloonEngine for vector-based scaling instead of the standard WarpBlt pixel-based mechanism.! 203424 203425 203426!MatrixTransformMorph methodsFor: '*etoys-geometry etoy' stamp: 'ar 6/12/2001 06:03'! 203427heading: newHeading 203428 "Set the receiver's heading (in eToy terms)" 203429 self rotateBy: ((newHeading - self forwardDirection) - self innerAngle).! ! 203430 203431 203432!MatrixTransformMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 21:51'! 203433transform: aMatrixTransform 203434 transform := aMatrixTransform. 203435 self computeBounds.! ! 203436 203437 203438!MatrixTransformMorph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:44'! 203439invalidRect: rect from: aMorph 203440 aMorph == self 203441 ifTrue:[super invalidRect: rect from: self] 203442 ifFalse:[super invalidRect: (self transform localBoundsToGlobal: rect) from: aMorph].! ! 203443 203444 203445!MatrixTransformMorph methodsFor: 'drawing' stamp: 'ar 11/15/1998 22:20'! 203446drawOn: aCanvas! ! 203447 203448!MatrixTransformMorph methodsFor: 'drawing' stamp: 'ar 5/29/1999 09:01'! 203449drawSubmorphsOn: aCanvas 203450 aCanvas asBalloonCanvas transformBy: self transform 203451 during:[:myCanvas| super drawSubmorphsOn: myCanvas].! ! 203452 203453!MatrixTransformMorph methodsFor: 'drawing' stamp: 'md 2/27/2006 09:51'! 203454visible: aBoolean 203455 "set the 'visible' attribute of the receiver to aBoolean" 203456 extension ifNil: [aBoolean ifTrue: [^ self]]. 203457 self assureExtension visible: aBoolean! ! 203458 203459 203460!MatrixTransformMorph methodsFor: 'event handling' stamp: 'ar 9/12/2000 01:22'! 203461transformFrom: uberMorph 203462 (owner isNil or:[self == uberMorph]) ifTrue:[^self transform]. 203463 ^(owner transformFrom: uberMorph) asMatrixTransform2x3 composedWithLocal: self transform! ! 203464 203465 203466!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/16/1998 01:19'! 203467changeRotationCenter: evt with: rotHandle 203468 | pos | 203469 pos := evt cursorPoint. 203470 rotHandle referencePosition: pos. 203471 self referencePosition: pos.! ! 203472 203473!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:55'! 203474hasNoScaleOrRotation 203475 ^true! ! 203476 203477!MatrixTransformMorph methodsFor: 'flexing' stamp: 'fbs 11/26/2004 10:59'! 203478innerAngle 203479 ^ (self transform a11 @ self transform a21) degrees! ! 203480 203481!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'! 203482lastRotationDegrees 203483 ^(self valueOfProperty: #lastRotationDegrees) ifNil:[0.0].! ! 203484 203485!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'! 203486lastRotationDegrees: deg 203487 deg = 0.0 203488 ifTrue:[self removeProperty: #lastRotationDegrees] 203489 ifFalse:[self setProperty: #lastRotationDegrees toValue: deg]! ! 203490 203491!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'! 203492removeFlexShell 203493 "Do nothing"! ! 203494 203495!MatrixTransformMorph methodsFor: 'flexing' stamp: 'mdr 12/19/2001 10:49'! 203496rotateBy: delta 203497 | pt m | 203498 delta = 0.0 ifTrue:[^self]. 203499 self changed. 203500 pt := self transformFromWorld globalPointToLocal: self referencePosition. 203501 m := MatrixTransform2x3 withOffset: pt. 203502 m := m composedWithLocal: (MatrixTransform2x3 withAngle: delta). 203503 m := m composedWithLocal: (MatrixTransform2x3 withOffset: pt negated). 203504 self transform: (transform composedWithLocal: m). 203505 self changed.! ! 203506 203507!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'! 203508rotationDegrees: degrees 203509 | last delta | 203510 last := self lastRotationDegrees. 203511 delta := degrees - last. 203512 self rotateBy: delta. 203513 self lastRotationDegrees: degrees.! ! 203514 203515!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 9/11/2000 21:16'! 203516transform 203517 ^ transform ifNil: [MatrixTransform2x3 identity]! ! 203518 203519 203520!MatrixTransformMorph methodsFor: 'geometry' stamp: 'mdr 12/19/2001 10:48'! 203521boundsChangedFrom: oldBounds to: newBounds 203522 oldBounds extent = newBounds extent ifFalse:[ 203523 transform := transform composedWithGlobal: 203524 (MatrixTransform2x3 withOffset: oldBounds origin negated). 203525 transform := transform composedWithGlobal: 203526 (MatrixTransform2x3 withScale: newBounds extent / oldBounds extent). 203527 transform := transform composedWithGlobal: 203528 (MatrixTransform2x3 withOffset: newBounds origin). 203529 ]. 203530 transform offset: transform offset + (newBounds origin - oldBounds origin)! ! 203531 203532!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 6/12/2001 06:18'! 203533computeBounds 203534 | subBounds box | 203535 (submorphs isNil or:[submorphs isEmpty]) ifTrue:[^self]. 203536 box := nil. 203537 submorphs do:[:m| 203538 subBounds := self transform localBoundsToGlobal: m bounds. 203539 box 203540 ifNil:[box := subBounds] 203541 ifNotNil:[box := box quickMerge: subBounds]. 203542 ]. 203543 box ifNil:[box := 0@0 corner: 20@20]. 203544 fullBounds := bounds := box! ! 203545 203546!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 21:52'! 203547extent: extent 203548 self handleBoundsChange:[super extent: extent]! ! 203549 203550!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 21:52'! 203551handleBoundsChange: aBlock 203552 | oldBounds newBounds | 203553 oldBounds := bounds. 203554 aBlock value. 203555 newBounds := bounds. 203556 self boundsChangedFrom: oldBounds to: newBounds.! ! 203557 203558!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 10/6/2000 15:37'! 203559transformedBy: aTransform 203560 self transform: (self transform composedWithGlobal: aTransform).! ! 203561 203562 203563!MatrixTransformMorph methodsFor: 'geometry etoy' stamp: 'ar 6/12/2001 06:03'! 203564heading 203565 "Return the receiver's heading (in eToy terms)" 203566 ^ self forwardDirection + self innerAngle! ! 203567 203568!MatrixTransformMorph methodsFor: 'geometry etoy' stamp: 'ar 6/12/2001 05:11'! 203569rotationCenter 203570 | pt | 203571 pt := self transform localPointToGlobal: super rotationCenter. 203572 ^pt - bounds origin / bounds extent asFloatPoint! ! 203573 203574!MatrixTransformMorph methodsFor: 'geometry etoy' stamp: 'ar 6/12/2001 05:07'! 203575rotationCenter: aPoint 203576 super rotationCenter: (self transform globalPointToLocal: bounds origin + (bounds extent * aPoint))! ! 203577 203578!MatrixTransformMorph methodsFor: 'geometry etoy' stamp: 'ar 6/12/2001 05:50'! 203579setDirectionFrom: aPoint 203580 | delta degrees | 203581 delta := (self transformFromWorld globalPointToLocal: aPoint) - super rotationCenter. 203582 degrees := delta degrees + 90.0. 203583 self forwardDirection: (degrees \\ 360) rounded. 203584! ! 203585 203586 203587!MatrixTransformMorph methodsFor: 'geometry testing' stamp: 'ar 1/15/1999 16:34'! 203588containsPoint: aPoint 203589 self visible ifFalse:[^false]. 203590 (bounds containsPoint: aPoint) ifFalse: [^ false]. 203591 self hasSubmorphs 203592 ifTrue: [self submorphsDo: 203593 [:m | (m fullContainsPoint: (self transform globalPointToLocal: aPoint)) 203594 ifTrue: [^ true]]. 203595 ^ false] 203596 ifFalse: [^ true]! ! 203597 203598!MatrixTransformMorph methodsFor: 'geometry testing' stamp: 'ar 11/15/1998 21:52'! 203599fullContainsPoint: aPoint 203600 | p | 203601 self visible ifFalse:[^false]. 203602 (self fullBounds containsPoint: aPoint) ifFalse:[^false]. 203603 (self containsPoint: aPoint) ifTrue:[^true]. 203604 p := self transform globalPointToLocal: aPoint. 203605 submorphs do:[:m| 203606 (m fullContainsPoint: p) ifTrue:[^true]. 203607 ]. 203608 ^false! ! 203609 203610 203611!MatrixTransformMorph methodsFor: 'halos and balloon help' stamp: 'ar 11/15/1998 21:50'! 203612balloonHelpTextForHandle: aHandle 203613 aHandle eventHandler firstMouseSelector == #changeRotationCenter:with: 203614 ifTrue:[^'set center of rotation']. 203615 ^super balloonHelpTextForHandle: aHandle! ! 203616 203617 203618!MatrixTransformMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:38'! 203619initialize 203620"initialize the state of the receiver" 203621 super initialize. 203622"" 203623 transform := MatrixTransform2x3 identity! ! 203624 203625 203626!MatrixTransformMorph methodsFor: 'initialize' stamp: 'wiz 11/6/2005 16:58'! 203627asFlexOf: aMorph 203628 "Initialize me with position and bounds of aMorph, 203629 and with an offset that provides centered rotation." 203630 self addMorph: aMorph. 203631 self setRotationCenterFrom: aMorph center . 203632 self lastRotationDegrees: 0.0. 203633 self computeBounds! ! 203634 203635 203636!MatrixTransformMorph methodsFor: 'layout' stamp: 'ar 11/15/1998 21:52'! 203637fullBounds 203638 | subBounds | 203639 fullBounds ifNil:[ 203640 fullBounds := self bounds. 203641 submorphs do:[:m| 203642 subBounds := (self transform localBoundsToGlobal: m fullBounds). 203643 fullBounds := fullBounds quickMerge: subBounds. 203644 ]. 203645 ]. 203646 ^fullBounds! ! 203647 203648 203649!MatrixTransformMorph methodsFor: 'menus' stamp: 'jcg 11/1/2001 13:03'! 203650setRotationCenterFrom: aPoint 203651 203652 super setRotationCenterFrom: (self transformFromWorld localPointToGlobal: aPoint) 203653! ! 203654 203655 203656!MatrixTransformMorph methodsFor: 'rotate scale and flex' stamp: 'ar 11/15/1998 21:55'! 203657addFlexShell 203658 "No flex shell necessary" 203659 self lastRotationDegrees: 0.0.! ! 203660 203661 203662!MatrixTransformMorph methodsFor: 'updating' stamp: 'ar 11/12/2000 18:51'! 203663changed 203664 ^self invalidRect: (self fullBounds insetBy: -1)! ! 203665 203666 203667!MatrixTransformMorph methodsFor: 'private' stamp: 'ar 6/12/2001 06:38'! 203668privateFullMoveBy: delta 203669 self privateMoveBy: delta. 203670 transform offset: transform offset + delta.! ! 203671InstanceVariableNode subclass: #MaybeContextInstanceVariableNode 203672 instanceVariableNames: '' 203673 classVariableNames: '' 203674 poolDictionaries: '' 203675 category: 'Compiler-ParseNodes'! 203676!MaybeContextInstanceVariableNode commentStamp: '<historical>' prior: 0! 203677This class conspires to arrange that inst var access for contexts is done exclusively using the long-form instance variabl;e access bytecodes. See InstructionStream class>>variablesAndOffsetsDo:. 203678 203679A virtual machine can benefit in performance by organizing method and block activations using a more conventional stack organization than by using first-class activation records (contexts). But such a virtual machine is also cabable of hiding the stack and making it appear as if contexts are still used. This means the system has better performance but still has all the benefits of first-class activation records. To pull this off the VM needs to intercept any and all accesses to context objects so that it can make contexts function as proxy objects for stack frames. 203680 203681Without help from the image such a virtual machine based on an interpreter would have to perform an expensive check on all instance variable accesses to determine if the instance variable was that of a context serving as a proxy for a stack frame. A simple hack is to take advantage of the short and long forms of instance variable access bytecodes. The BlueBook instruction set (and likely any bytecode set evolved from it) has short form bytecodes for fetching and storing the first few bytecodes (BlueBook fetch first 16, store first 8). Contexts typically have at most 6 instance variables. If we arrange to use the long-form bytecodes for all context inst var accesses then we only have to check for context inst var access in long-form bytecodes, and then only if the index is within the context inst var range. This effectively makes the check free because on modern processors checking an index fetched from memory into a register against a constant costs far less than the memry read to fetch the index.! 203682]style[(1792)i! 203683 203684 203685!MaybeContextInstanceVariableNode methodsFor: 'accessing' stamp: 'eem 6/19/2008 09:27'! 203686code 203687 "Answer a bogus code to avoid creating quick methods. 203688 See MethodNode>>generate:ifQuick:" 203689 ^LoadLong! ! 203690 203691 203692!MaybeContextInstanceVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:08'! 203693emitCodeForStore: stack encoder: encoder 203694 encoder genStoreInstVarLong: index! ! 203695 203696!MaybeContextInstanceVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 6/19/2008 09:36'! 203697emitCodeForStorePop: stack encoder: encoder 203698 encoder genStorePopInstVarLong: index. 203699 stack pop: 1! ! 203700 203701!MaybeContextInstanceVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:08'! 203702emitCodeForValue: stack encoder: encoder 203703 stack push: 1. 203704 ^encoder genPushInstVarLong: index! ! 203705 203706!MaybeContextInstanceVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:57'! 203707sizeCodeForStore: encoder 203708 ^encoder sizeStoreInstVarLong: index! ! 203709 203710!MaybeContextInstanceVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:07'! 203711sizeCodeForStorePop: encoder 203712 ^encoder sizeStorePopInstVarLong: index! ! 203713 203714!MaybeContextInstanceVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:53'! 203715sizeCodeForValue: encoder 203716 ^encoder sizePushInstVarLong: index! ! 203717Object subclass: #MczInstaller 203718 instanceVariableNames: 'stream zip' 203719 classVariableNames: 'Versions' 203720 poolDictionaries: '' 203721 category: 'System-Support'! 203722 203723!MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/13/2003 01:58'! 203724extractPackageName 203725 ^ (self parseMember: 'package') at: #name. 203726 ! ! 203727 203728!MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/13/2003 02:17'! 203729extractVersionInfo 203730 ^ self extractInfoFrom: (self parseMember: 'version')! ! 203731 203732!MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/7/2003 19:18'! 203733recordVersionInfo 203734 Versions 203735 at: self extractPackageName 203736 put: self extractVersionInfo! ! 203737 203738!MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/13/2003 02:04'! 203739scanner 203740 ^ Scanner new! ! 203741 203742!MczInstaller methodsFor: 'accessing' stamp: 'avi 2/17/2004 02:55'! 203743stream: aStream 203744 stream := aStream! ! 203745 203746 203747!MczInstaller methodsFor: 'installation' stamp: 'avi 2/17/2004 02:56'! 203748install 203749 | sources | 203750 zip := ZipArchive new. 203751 zip readFrom: stream. 203752 self checkDependencies ifFalse: [^false]. 203753 self recordVersionInfo. 203754 sources := (zip membersMatching: 'snapshot/*') 203755 asSortedCollection: [:a :b | a fileName < b fileName]. 203756 sources do: [:src | self installMember: src].! ! 203757 203758!MczInstaller methodsFor: 'installation' stamp: 'yo 8/17/2004 10:03'! 203759installMember: member 203760 | str | 203761 self useNewChangeSetDuring: 203762 [str := member contentStream text. 203763 str setConverterForCode. 203764 str fileInAnnouncing: 'loading ', member fileName]! ! 203765 203766 203767!MczInstaller methodsFor: 'utilities' stamp: 'stephane.ducasse 3/31/2009 21:10'! 203768associate: tokens 203769 | result | 203770 result := Dictionary new. 203771 tokens pairsDo: [:key :value | 203772 | tmp | 203773 tmp := value. 203774 value isString ifFalse: [tmp := value collect: [:ea | self associate: ea]]. 203775 value = 'nil' ifTrue: [tmp := '']. 203776 result at: key put: tmp]. 203777 ^ result! ! 203778 203779!MczInstaller methodsFor: 'utilities' stamp: 'avi 2/17/2004 02:53'! 203780checkDependencies 203781 | dependencies unmet | 203782 dependencies := (zip membersMatching: 'dependencies/*') 203783 collect: [:member | self extractInfoFrom: (self parseMember: member)]. 203784 unmet := dependencies reject: [:dep | 203785 self versions: Versions anySatisfy: (dep at: #id)]. 203786 ^ unmet isEmpty or: [ 203787 self confirm: (String streamContents: [:s| 203788 s nextPutAll: 'The following dependencies seem to be missing:'; cr. 203789 unmet do: [:each | s nextPutAll: (each at: #name); cr]. 203790 s nextPutAll: 'Do you still want to install this package?'])]! ! 203791 203792!MczInstaller methodsFor: 'utilities' stamp: 'avi 2/17/2004 03:26'! 203793extractInfoFrom: dict 203794 dict at: #id put: (UUID fromString: (dict at: #id)). 203795 dict at: #date ifPresent: [:d | d isEmpty ifFalse: [dict at: #date put: (Date fromString: d)]]. 203796 dict at: #time ifPresent: [:t | t isEmpty ifFalse: [dict at: #time put: (Time readFrom: t readStream)]]. 203797 dict at: #ancestors ifPresent: [:a | dict at: #ancestors put: (a collect: [:ea | self extractInfoFrom: ea])]. 203798 ^ dict! ! 203799 203800!MczInstaller methodsFor: 'utilities' stamp: 'cwp 8/13/2003 01:58'! 203801parseMember: fileName 203802 | tokens | 203803 tokens := (self scanner scanTokens: (zip contentsOf: fileName)) first. 203804 ^ self associate: tokens! ! 203805 203806!MczInstaller methodsFor: 'utilities' stamp: 'bf 2/9/2004 13:56'! 203807useNewChangeSetDuring: aBlock 203808 | changeHolder oldChanges newChanges | 203809 changeHolder := (ChangeSet respondsTo: #newChanges:) 203810 ifTrue: [ChangeSet] 203811 ifFalse: [Smalltalk]. 203812 oldChanges := (ChangeSet respondsTo: #current) 203813 ifTrue: [ChangeSet current] 203814 ifFalse: [Smalltalk changes]. 203815 203816 newChanges := ChangeSet new name: (ChangeSet uniqueNameLike: self extractPackageName). 203817 changeHolder newChanges: newChanges. 203818 [aBlock value] ensure: [changeHolder newChanges: oldChanges].! ! 203819 203820!MczInstaller methodsFor: 'utilities' stamp: 'bf 2/9/2004 15:00'! 203821versions: aVersionList anySatisfy: aDependencyID 203822 ^ aVersionList anySatisfy: [:version | 203823 aDependencyID = (version at: #id) 203824 or: [self versions: (version at: #ancestors) anySatisfy: aDependencyID]]! ! 203825 203826"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 203827 203828MczInstaller class 203829 instanceVariableNames: ''! 203830 203831!MczInstaller class methodsFor: 'installing' stamp: 'cwp 8/7/2003 18:13'! 203832installFileNamed: aFileName 203833 self installStream: (FileStream readOnlyFileNamed: aFileName)! ! 203834 203835!MczInstaller class methodsFor: 'installing' stamp: 'cwp 8/7/2003 17:56'! 203836installStream: aStream 203837 (self on: aStream) install! ! 203838 203839 203840!MczInstaller class methodsFor: 'instance creation' stamp: 'cwp 8/7/2003 17:56'! 203841on: aStream 203842 ^ self new stream: aStream! ! 203843 203844 203845!MczInstaller class methodsFor: 'services' stamp: 'cwp 8/7/2003 18:49'! 203846extension 203847 ^ 'mcz'! ! 203848 203849!MczInstaller class methodsFor: 'services' stamp: 'nk 6/8/2004 17:29'! 203850fileReaderServicesForFile: fileName suffix: suffix 203851 ^({ self extension. '*' } includes: suffix) 203852 ifTrue: [ self services ] 203853 ifFalse: [#()]. 203854! ! 203855 203856!MczInstaller class methodsFor: 'services' stamp: 'avi 3/7/2004 14:51'! 203857initialize 203858 self clearVersionInfo. 203859 self registerForFileList.! ! 203860 203861!MczInstaller class methodsFor: 'services' stamp: 'cwp 8/7/2003 18:54'! 203862loadVersionFile: fileName 203863 self installFileNamed: fileName 203864! ! 203865 203866!MczInstaller class methodsFor: 'services' stamp: 'avi 3/7/2004 14:49'! 203867registerForFileList 203868 Smalltalk at: #MCReader ifAbsent: [FileList registerFileReader: self]! ! 203869 203870!MczInstaller class methodsFor: 'services' stamp: 'cwp 8/7/2003 18:53'! 203871serviceLoadVersion 203872 ^ SimpleServiceEntry 203873 provider: self 203874 label: 'load' 203875 selector: #loadVersionFile: 203876 description: 'load a package version'! ! 203877 203878!MczInstaller class methodsFor: 'services' stamp: 'ab 8/8/2003 18:01'! 203879services 203880 ^ Array with: self serviceLoadVersion! ! 203881 203882 203883!MczInstaller class methodsFor: 'versioninfo' stamp: 'avi 1/19/2004 13:13'! 203884clearVersionInfo 203885 Versions := Dictionary new! ! 203886 203887!MczInstaller class methodsFor: 'versioninfo' stamp: 'cwp 8/11/2003 23:49'! 203888storeVersionInfo: aVersion 203889 Versions 203890 at: aVersion package name 203891 put: aVersion info asDictionary! ! 203892 203893!MczInstaller class methodsFor: 'versioninfo' stamp: 'avi 3/7/2004 14:51'! 203894unloadMonticello 203895 "self unloadMonticello" 203896 Utilities breakDependents. 203897 203898 Smalltalk at: #MCWorkingCopy ifPresent: 203899 [:wc | 203900 wc allInstances do: 203901 [:ea | 203902 Versions at: ea package name put: ea currentVersionInfo asDictionary. 203903 ea breakDependents. 203904 Smalltalk at: #SystemChangeNotifier ifPresent: [:scn | scn uniqueInstance noMoreNotificationsFor: ea]] 203905 displayingProgress: 'Saving version info...']. 203906 203907 "keep things simple and don't unload any class extensions" 203908 (ChangeSet superclassOrder: ((PackageInfo named: 'Monticello') classes)) reverseDo: 203909 [:ea | 203910 ea removeFromSystem]. 203911 203912 self registerForFileList.! ! 203913 203914!MczInstaller class methodsFor: 'versioninfo' stamp: 'avi 2/17/2004 02:49'! 203915versionInfo 203916 ^ Versions! ! 203917Object subclass: #MenuIcons 203918 instanceVariableNames: '' 203919 classVariableNames: 'Icons TranslatedIcons' 203920 poolDictionaries: '' 203921 category: 'Morphic-Menus'! 203922!MenuIcons commentStamp: 'sd 11/9/2003 14:09' prior: 0! 203923I represent a registry for icons. You can see the icons I contain using the following script: 203924 203925| dict methods | 203926dict := Dictionary new. 203927methods := MenuIcons class selectors select: [:each | '*Icon' match: each asString]. 203928methods do: [:each | dict at: each put: (MenuIcons perform: each)]. 203929GraphicalDictionaryMenu openOn: dict withLabel: 'MenuIcons'! 203930 203931 203932"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 203933 203934MenuIcons class 203935 instanceVariableNames: ''! 203936 203937!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 9/25/2004 22:59'! 203938backIcon 203939 "Private - Generated method" 203940 ^ Icons 203941 at: #'back' 203942 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self backIconContents readStream) ].! ! 203943 203944!MenuIcons class methodsFor: 'accessing - icons' stamp: 'KR 5/4/2006 21:37'! 203945blankIcon 203946 ^self blankIconOfWidth: 16. 203947! ! 203948 203949!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 9/25/2004 22:59'! 203950forwardIcon 203951 "Private - Generated method" 203952 ^ Icons 203953 at: #'forward' 203954 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self forwardIconContents readStream) ].! ! 203955 203956!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 9/25/2004 22:59'! 203957helpIcon 203958 "Private - Generated method" 203959 ^ Icons 203960 at: #'help' 203961 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self helpIconContents readStream) ].! ! 203962 203963!MenuIcons class methodsFor: 'accessing - icons' stamp: 'dgd 9/22/2004 19:35'! 203964openIcon 203965 "Private - Generated method" 203966 ^ Icons 203967 at: #'open' 203968 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self openIconContents readStream) ].! ! 203969 203970 203971!MenuIcons class methodsFor: 'class initialization' stamp: 'al 10/12/2008 20:53'! 203972initialize 203973 "self initialize" 203974 203975 self initializeIcons. 203976 Smalltalk addToStartUpList: self! ! 203977 203978 203979!MenuIcons class methodsFor: 'icons creation' stamp: 'dgd 9/22/2004 18:28'! 203980base64ContentsOfFileNamed: aString 203981 "Private - convenient method" 203982 203983 | file base64Contents | 203984 file := FileStream readOnlyFileNamed: aString. 203985 base64Contents := (Base64MimeConverter mimeEncode: file binary) contents. 203986 file close. 203987 ^ base64Contents! ! 203988 203989!MenuIcons class methodsFor: 'icons creation' stamp: 'dgd 4/20/2006 12:31'! 203990createIconMethodsFromDirectory: directory 203991 " 203992 Preferences disable: #showWorldMainDockingBar. 203993 MenuIcons createIconMethodsFromDirectory: '/home/dgd/'. 203994 Preferences enable: #showWorldMainDockingBar. 203995 " 203996 | iconContentsSourceTemplate iconSourceTemplate normalSize smallSize | 203997 iconContentsSourceTemplate := '{1}IconContents 203998 "Private - Method generated with the content of the file {2}" 203999 ^ ''{3}'''. 204000 iconSourceTemplate := '{1}Icon 204001 "Private - Generated method" 204002 ^ Icons 204003 at: #''{1}'' 204004 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self {1}IconContents readStream) ].'. 204005 "" 204006 normalSize := #('back' 'configuration' 'confirm' 'forward' 'fullScreen' 'help' 'home' 'jump' 'objectCatalog' 'objects' 'paint' 'project' 'publish' 'squeak' 'volume' 'window' 'open' 'loadProject' ). 204007 smallSize := #('smallExport' 'smallAuthoringTools' 'smallDebug' 'smallBack' 'smallCancel' 'smallConfiguration' 'smallCopy' 'smallCut' 'smallDelete' 'smallDoIt' 'smallExpert' 'smallFind' 'smallForward' 'smallFullScreen' 'smallHelp' 'smallHome' 'smallInspectIt' 'smallJump' 'smallLanguage' 'smallNew' 'smallObjectCatalog' 'smallObjects' 'smallOk' 'smallOpen' 'smallPaint' 'smallPaste' 'smallPrint' 'smallProject' 'smallPublish' 'smallQuit' 'smallRedo' 'smallRemoteOpen' 'smallSave' 'smallSaveAs' 'smallSelect' 'smallSqueak' 'smallUndo' 'smallUpdate' 'smallVolume' 'smallWindow' 'smallLeftFlush' 'smallCentered' 'smallJustified' 'smallRightFlush' 'smallFonts' 'smallLoadProject' ). 204008 normalSize , smallSize 204009 do: [:each | 204010 | png base64 contentsSelector selector | 204011 png := directory , each , '.png'. 204012 base64 := self base64ContentsOfFileNamed: png. 204013 "" 204014 contentsSelector := (each , 'IconContents') asSymbol. 204015 ((self respondsTo: contentsSelector) 204016 and: [(self perform: contentsSelector) 204017 = base64]) 204018 ifFalse: [| contentsSource | 204019 contentsSource := iconContentsSourceTemplate format: {each. png. base64}. 204020 self class compile: contentsSource classified: 'private - icons']. 204021 "" 204022 selector := (each , 'Icon') asSymbol. 204023 (self respondsTo: selector) 204024 ifFalse: [| source | 204025 source := iconSourceTemplate format: {each}. 204026 self class compile: source classified: 'private - icons']]. 204027 "" 204028 self initializeIcons! ! 204029 204030 204031!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/9/2003 16:16'! 204032exportAllIconsAsGif 204033 "self exportAllIconsAsGif" 204034 204035 | sels | 204036 sels := self class selectors select: [:each | '*Icon' match: each asString]. 204037 sels do: [:each | self exportIcon: (MenuIcons perform: each) asGifNamed: each asString]. 204038! ! 204039 204040!MenuIcons class methodsFor: 'import/export' stamp: 'nk 2/16/2004 13:38'! 204041exportAllIconsAsPNG 204042 "self exportAllIconsAsPNG" 204043 204044 | sels | 204045 sels := self class selectors select: [:each | '*Icon' match: each asString]. 204046 sels do: [:each | self exportIcon: (MenuIcons perform: each) asPNGNamed: each asString]. 204047! ! 204048 204049!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/11/2003 11:36'! 204050exportIcon: image asGifNamed: aString 204051 "self exportIcon: self newIcon asGifNamed: 'newIcon'" 204052 204053 | writer | 204054 writer := GIFReadWriter on: (FileStream newFileNamed: aString, '.gif'). 204055 [ writer nextPutImage: image] 204056 ensure: [writer close]! ! 204057 204058!MenuIcons class methodsFor: 'import/export' stamp: 'nk 2/16/2004 13:38'! 204059exportIcon: image asPNGNamed: aString 204060 "self exportIcon: self newIcon asPNGNamed: 'newIcon'" 204061 204062 | writer | 204063 writer := PNGReadWriter on: (FileStream newFileNamed: aString, '.png'). 204064 [ writer nextPutImage: image] 204065 ensure: [writer close]! ! 204066 204067!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/10/2003 00:04'! 204068importAllIconNamed: aString 204069 "self importIconNamed: 'Icons16:appearanceIcon'" 204070 204071 204072 | writer image stream | 204073 writer := GIFReadWriter on: (FileStream fileNamed: aString, '.gif'). 204074 [ image := writer nextImage] 204075 ensure: [writer close]. 204076 stream := ReadWriteStream on: (String new). 204077 stream nextPutAll: aString ; cr. 204078 stream nextPutAll: (self methodStart: aString). 204079 image storeOn: stream. 204080 stream nextPutAll: self methodEnd. 204081 ^ stream contents! ! 204082 204083!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/10/2003 13:06'! 204084importAllIcons 204085 "self importAllIcons; initialize" 204086 204087 | icons | 204088 icons := FileDirectory default fileNames select: [:each | '*Icon.gif' match: each ]. 204089 icons do: [:icon | self importIconNamed: (icon upTo: $.)] ! ! 204090 204091!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/10/2003 00:05'! 204092importIconNamed: aString 204093 "self importIconNamed: 'Icons16:appearanceIcon'" 204094 204095 204096 | writer image stream | 204097 writer := GIFReadWriter on: (FileStream fileNamed: aString, '.gif'). 204098 [ image := writer nextImage] 204099 ensure: [writer close]. 204100 stream := ReadWriteStream on: (String new). 204101 stream nextPutAll: aString ; cr. 204102 stream nextPutAll: (self methodStart: aString). 204103 image storeOn: stream. 204104 stream nextPutAll: self methodEnd. 204105 MenuIcons class compile: stream contents classified: 'accessing - icons' notifying: nil. 204106 ^ stream contents! ! 204107 204108!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/9/2003 23:49'! 204109methodEnd 204110 204111 ^ ']'! ! 204112 204113!MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/10/2003 00:04'! 204114methodStart: aString 204115 204116 ^'^ Icons 204117 at: #', aString, 204118 ' ifAbsentPut: ['! ! 204119 204120 204121!MenuIcons class methodsFor: 'initialization' stamp: 'dgd 9/22/2004 18:27'! 204122initializeIcons 204123 "self initialize" 204124 | methods | 204125 Icons := IdentityDictionary new. 204126 methods := self class selectors 204127 select: [:each | '*Icon' match: each asString]. 204128 methods 204129 do: [:each | Icons 204130 at: each 204131 put: (MenuIcons perform: each)]. 204132 self initializeTranslations. 204133! ! 204134 204135!MenuIcons class methodsFor: 'initialization' stamp: 'nk 5/1/2004 16:49'! 204136initializeTranslations 204137 "Initialize the dictionary of <translated menu string>-><icon>" 204138 204139 TranslatedIcons := Dictionary new. 204140 self itemsIcons do: [ :assoc | 204141 assoc key do: [ :str | TranslatedIcons at: str translated asLowercase put: assoc value ] 204142 ]! ! 204143 204144!MenuIcons class methodsFor: 'initialization' stamp: 'dgd 9/22/2004 18:32'! 204145startUp: resuming 204146 resuming 204147 ifFalse: [^ self]. 204148 self initializeTranslations! ! 204149 204150 204151!MenuIcons class methodsFor: 'menu decoration' stamp: 'dgd 4/3/2006 14:45'! 204152decorateMenu: aMenu 204153 "decorate aMenu with icons" 204154 204155 | maxWidth | 204156 204157 Preferences menuWithIcons ifFalse: [^ self]. 204158 Preferences tinyDisplay ifTrue:[^ self]. 204159 204160 maxWidth := 0. 204161 204162 aMenu items do: [:item | 204163 item icon isNil ifTrue: [ 204164 | icon | 204165 icon := self iconForMenuItem: item. 204166 icon isNil ifFalse: [ 204167 item icon: icon. 204168 maxWidth := maxWidth max: item icon width. 204169 ] 204170 ] 204171 ifFalse: [ 204172 maxWidth := maxWidth max: item icon width 204173 ]. 204174 204175 item hasSubMenu ifTrue: [ 204176 self decorateMenu: item subMenu. 204177 ]. 204178 ]. 204179 204180 maxWidth isZero ifFalse: [ 204181 aMenu addBlankIconsIfNecessary: (self blankIconOfWidth: maxWidth). 204182 ]. 204183! ! 204184 204185!MenuIcons class methodsFor: 'menu decoration' stamp: 'nk 5/1/2004 16:48'! 204186iconForMenuItem: anItem 204187 "Answer the icon (or nil) corresponding to the (translated) string." 204188 204189 ^TranslatedIcons at: anItem contents asString asLowercase ifAbsent: [ ]! ! 204190 204191!MenuIcons class methodsFor: 'menu decoration' stamp: 'AdrianLienhard 8/26/2009 22:01'! 204192itemsIcons 204193 "answer a collection of associations wordings -> icon 204194 to decorate the menus all over the image" 204195 204196 | icons | 204197 icons := OrderedCollection new. 204198 204199 "world menu" 204200 icons add: #('previous project' ) -> self smallBackIcon. 204201 icons add: #('select' ) -> self smallSelectIcon. 204202 icons add: #('jump to project...' ) -> self smallForwardIcon. 204203 icons add: #('Tools...' ) -> self smallOpenIcon. 204204 icons add: #('System...' ) -> self smallConfigurationIcon. 204205 icons add: #('Software update' ) -> self smallUpdateIcon. 204206 icons add: #('About...' ) -> self smallLanguageIcon. 204207 icons add: #('open...' ) -> self smallOpenIcon. 204208 icons add: #('preferences...' ) -> self smallConfigurationIcon. 204209 icons add: #('Keyboard shortcuts...' ) -> self smallHelpIcon. 204210 icons add: #('windows...' ) -> self smallWindowIcon. 204211 icons add: #('print PS to file...' ) -> self smallPrintIcon. 204212 icons add: #('debug...' ) -> self smallDebugIcon. 204213 icons add: #('export...' ) -> self smallExportIcon. 204214 icons add: #('save' ) -> self smallSaveIcon. 204215 icons add: #('save project on file...' ) -> self smallPublishIcon. 204216 icons add: #('save as...' 'save as new version' ) -> self smallSaveAsIcon. 204217 icons add: #('quit' 'save and quit' ) -> self smallQuitIcon. 204218 icons add: #('load project from file...' ) -> self smallLoadProjectIcon. 204219 "" 204220 icons add: #('do it (d)' ) -> self smallDoItIcon. 204221 icons add: #('inspect it (i)' 'explore it (I)' 'inspect world' 'explore world' 'inspect model' 'inspect morph' 'explore morph' 'inspect owner chain' 'explore' 'inspect' 'explore (I)' 'inspect (i)' 'basic inspect' ) -> self smallInspectItIcon. 204222 icons add: #('print it (p)' ) -> self smallPrintIcon. 204223 icons add: #('debug it (D)' ) -> self smallDebugIcon. 204224 icons add: #('watch it' ) -> self blankIcon. 204225 icons add: #('profile it' ) -> self blankIcon. 204226 "" 204227 icons add: #('copy (c)' 'copy to paste buffer' 'copy text' ) -> self smallCopyIcon. 204228 icons add: #('paste (v)' 'paste...' ) -> self smallPasteIcon. 204229 icons add: #('cut (x)' ) -> self smallCutIcon. 204230 "" 204231 icons add: #('accept (s)' 'yes' 'Yes' ) -> self smallOkIcon. 204232 icons add: #('cancel (l)' 'no' 'No' ) -> self smallCancelIcon. 204233 "" 204234 icons add: #('do again (j)' ) -> self smallRedoIcon. 204235 icons add: #('undo (z)' ) -> self smallUndoIcon. 204236 "" 204237 icons add: #('find...(f)' 'find again (g)' 'find class... (f)' 'find method...' 'extended search...') -> self smallFindIcon. 204238 "" 204239 icons add: #('remove' 'remove class (x)' 'delete method from changeset (d)' 'remove method from system (x)' 'delete class from change set (d)' 'remove class from system (x)' 'destroy change set (X)' ) -> self smallDeleteIcon. 204240 icons add: #('add item...' 'new category...' 'new change set... (n)' ) -> self smallNewIcon. 204241 "" 204242 icons add: #('new morph...' 'objects (o)' ) -> self smallObjectCatalogIcon. 204243 icons add: #('authoring tools...') -> self smallAuthoringToolsIcon. 204244 "" 204245 icons add: #('leftFlush' ) -> self smallLeftFlushIcon. 204246 icons add: #('rightFlush' ) -> self smallRightFlushIcon. 204247 icons add: #('centered' 'set alignment... (u)' ) -> self smallCenteredIcon. 204248 icons add: #('justified' ) -> self smallJustifiedIcon. 204249 "" 204250 icons add: #('set font... (k)' 'list font...' 'set subtitles font' 'change font' 'system fonts...' 'change font...' ) -> self smallFontsIcon. 204251 icons add: #('full screen on' 'full screen off' ) -> self smallFullScreenIcon. 204252 "" 204253 ^ icons! ! 204254 204255 204256!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:37'! 204257backIconContents 204258 "Private - Method generated with the content of the file /home/dgd/back.png" 204259 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204260RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADRElEQVRIie3WW4hVVRgH8N/e+5y56aCizpnR 204261jJzUCNFqLhqEWGlQDz0mGEJBCSL1Ur1YZA9BSIZGZg9dVBoo0B5D6qGwOzVaairZiJiKZ0hs 2042621NE5c2bm7N3DmXF2zQyO5lv+YbFZa/2/77+/y9prcxNpNFnoHi3/xUU4LtYiszX5WGC/ULsW 204263m69XMLgqo8UzEhtRlVpNJJb62Tc3TnCxnH7bBR65sra0nt8vkC9Ah9Ay7U5d2Z+jUrUaoRqx 204264Hr/qGp9gk0cFPsB0UFfFugUsybH1N7YfS7O7UTE4/u2vgDze02ijXUrRCLFmzwtswwRhwGO3 204265Wb55tcWNzQ75g7+KfNmZtqhEZoyXz2IKlutSIe+LNCnQ7A08NxRVuKHVywvXWG+lDXZ5SRs9 204266A7Qd53g3pSQlG1GboTY7PKojNh/hXBFK+s0oC85XocoOrASzJ6p9+wE7c69I8K7PfKrdgBK4 204267XYNWc+VMFgwGlkgU9Svo06OooOiksw7u3MPrhwySVmVAlTasAAummPzWg16oXWGdD+13fESe 204268ulxSZ5I7zTJHg1tNVxIr6FNQ1KlLuw7fOkJ9dTqHDwWarBJoA7lqPlqiflJO58gGuz78cJZn 204269fxya/ZQRutdQKZY1MKlifGJJzEA/A32UUs+4NDhispVcjtMRdmeU7BBag8iJM5yOmDmPYIwj 2042702pXn5MGy2LhQl3pJF0O/2CuwBXzfS0cnR7+j9/IoUSWcPnINYuhNcRN/DnXpRFUOoFFNwKYa 204271wgJ1s2mYS1TuLedOceLAsIMwIsoSZEhC4oCBgD70xpzB9ktcGExr4PHhvLVqFPsaM02NeC2L 204272XjKVTJtVdp7vKNfufB1bznO2RLE03lhj5P5ZqBZ3SHyFnFsyrM+SFEaabqrm6CjrY6Mf79tn 2042737cjOaDVfbA+mmRzyajUVqXpGE3g6NQ88IXZYKFISCUVioUAfetDjolOOKZbpo6HV3WK70SCL 204274F2uZ0V3eOzCFd64cm8/t8/C1hDr29dSqXuwT3AfuyjIvy66etPVT9tp2YwShWRZvYu0ouydd 204275MG8oVePFyOspjbxY3m4znMD9hm/90xJPOuzYmLZj4Oq/GENYZKqS1QKxPlsdNMqX4Sb+D/gb 204276LOgMCUjhiw4AAAAASUVORK5CYII='! ! 204277 204278!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/13/2004 20:01'! 204279blankIconOfWidth: aNumber 204280 ^ Icons 204281 at: ('blankIcon-' , aNumber asString) asSymbol 204282 ifAbsentPut: [Form extent: aNumber @ 1 depth:8]! ! 204283 204284!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204285configurationIcon 204286 "Private - Generated method" 204287 ^ Icons 204288 at: #'configuration' 204289 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self configurationIconContents readStream) ].! ! 204290 204291!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:47'! 204292configurationIconContents 204293 "Private - Method generated with the content of the file /home/dgd/configuration.png" 204294 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204295RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAF30lEQVRIia2WfWyV1R3HP8/L7X3p09tCZRWx 204296oE2x4Es2CIMmjiVjtKSQ4R9ONzbrtgQMakI3EoWiA3QMssTF1U2zGhZsQ5buzQmdZJszULAd 204297ULTUYPClaKm7VLkwS2/v6/M897c/zn3u7a2VSNwvObnnOfec8znf3/n9zjkGn99M4HFgF3Az 204298oAGjgHMNc3xuuw04BciSJV+TjRs3S3X1TQKkgCPADuDrgP+LggxgC5AKBkvl2Wd/Lx9/nJHh 2042994bScPBmX/ftPyKZNe6S29naxrLAASeBVlCfuBHxTJzSvArsF6ADqGxvvoq3teSorZxKNOsRi 2043002XyngwdfYHj4HebOnc+OHXsDn3wSXXH6dO+KgYFeRkfPJ4Be4HCunNSmAWlAC7C7oqIy2NTU 204301SFNTE5HIKAMDQyxYsJRly77JkSMHaGtrJZNJsWrVvWzd+muCQatoov7+wzz66HdIJuNe0+yp 204302sBqgB5CHH26V4eGYjIyMyd69f5HFi5eLrusC5IthmLJu3SY5evSyHD8eLypbtjwjgUBI0HVB 20430317wx+RVpwIPAxMKFX5aenrckGrXlwoWMDAwk8pM89dSfJByeIYBoWn4S8fuDUl+/Ulpa9kh7 204304+yuyfPka9V+FJTz3YyHoFyCb4xACXgGkrKxcurr+JZFIQs6dS8uJEwrU1zcu69c/JrpuCCBr 2043051nxfDh36QHbt6pCGhnskFLImwQOqfus84W97hFPtgmkIEPOUVQEfTfZrIBCkrm4R9fUrqav7 204306Cp2dv+T06V6CwVIeeeRXrF79vaJ9iMfH2blzA6+99jIiApVh6N4DJSaIwFc3kmPMNoE4QMua 204307Ju667VYOHj/Bb4/1ZgcH+/TBwT7lb03Dssppbt7M0qUrimBDQ2fYvv2HvP/+WQUwDLCCqg5g 204308u17XmFfRAfnp3XeL+9KL4rzwOxm7eY50z75O7ijxSVlhw/OltvZ2aW7+iWzY8Lj4fH7VXjVD 2043096GwVZlUIc65TrjzVLvxxhzfuDVB5mDUgk3adEoU3CGgaDcEAu/VxYlnhyZnllOkaf0+k6Emm 204310ZWjojDY0dKYgc+kC2L0BKizwmeDkVP2zH36+v0ihCWBoWqoA1PPzOKJ+bzIN7rVCPBi2SIlo 204311R5Np9sXi/DWeVLDftBTGlZgwnoYnOqC7b7L3Jzx3YkIqbefOYKMA9LxfOmkRAU2jMRRgnRVS 204312DZXlRYskm4WxuIKV+GDj2iKFCqiRito2H7kuohsFoCiJljbdgeR1yh1zItD5D/gwqqC1c2D/ 204313NmhYUqRQuRQtOWE7HE6m0W2bnktj3GMFsfMKrwZ04dIV2L4PTp7NecmAzlalcCjyaYUGJH2u 204314y1zTIKvrtI9PsPJClHczCnnOdpDPAl4cg+8+qWAVFtRVq+wuyV0Umfx1WdhDQ9OStuNwZ8DP 204315t8MWe2fNZGUwkL9Zf3Dxv9wyMkrr5Su8ns4UA8+eh7EJWLYQurbDl2YUohTAyQMnRynJtKs6 204316+TSN+8Kl3FcWYv7IKB86Lov8JQykMzx9JcbTV2LU+EwWewqCfvhREzQ3gKaptAC1t4YO/e8U 204317KTRzMhMpZ9JLQTfALbjxyA2ziDguXRMJuiYSvGs7DHtRPf9GuL+xMNY7YVIZaPszvHgM1FPk 204318aN6lpqYnku5koAoSR8DUwK9p1PhMts0I82b19fx7ThWrQwHVd2o8ecBNz3iwY8Bi4EweGHfd 2043196AfnR2g/cIALkUg+r1wES9OZaov8Pu4vK1Uf2SnhlEhDuBQGzwG0ASuYdDmYANFstoPx8ZqH 2043209nWsemhfh77AZ9oPhC2fLRC6WkqASgvPXn0Djr0JaTsOrAe6pnb3lt8PrEY9/372tu1c3Hx5 204321jJhINpkV6U2lPxvoZFXSt3fD1uchbb8H1E8Hu5oZwFrgZdQJJ/NMI/GLynKJzLtBUjU3yh+q 204322Kl1AmFclfGORdyO8BJRfC2g6qwaeAP4DiAHO2lAwvrm8zKZwZbnANj4dQl/IDOBbQDfqte3B 204323LgEN/0/QdFYN7AQOAXOvZeD/AIXZmm50KVY/AAAAAElFTkSuQmCC'! ! 204324 204325!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 13:33'! 204326confirmIcon 204327 "Private - Generated method" 204328 ^ Icons 204329 at: #'confirm' 204330 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self confirmIconContents readStream) ].! ! 204331 204332!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 13:33'! 204333confirmIconContents 204334 "Private - Method generated with the content of the file /home/dgd/confirm.png" 204335 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204336RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACsElEQVR4nK3WvW8URxjH8c+CDxtsYg6FCJDy 204337IqUIWKAUiCJFWuiRIqWCKn9AynRJnS4VShEpEimSBlGkiKBAGIkUWIoUBVtC4IvBb2BsH8fd 204338+fD5NsWM7VO43bXPPNJoZnafme/MPL95oT8r4RCS3TbcTYNSibEynw1xusXiKyp1FvAQT5G+ 204339LeB7H/HdCFdwcLNRStri1gK/1HiMP7G+V+ChT7hd4vwRXMB+vIxpEs+pzvB1jakIzZzp/iLa 204340x3w/yKWL+DECP8cpLGEULxgqcXaZ8ZR6HEtfwOQkv51h8CqGun68E6ETgoJmKadM1HkmxLWn 2043417cujneCDhMNfZjiOYgzlWB/mUxzO6zMXOBpjfDTHp2xbJSlN1PoGTlFJmZ3K8XmCf2O5yTRW 204342+gZCm2s/d3XabY9wM+YbTC5yL8N1ywpVWma8zRe/8+5BDGAef+BbVNBhvca948yfYOFZUGpP 204343y9uH+87yVco3+HDT+f8bLMVGHHmCOpenuY5XvTodyKKdY6jF1UFB/idj5yuCKgZwTDhQ4Q5W 2043446cyyJgh4d8AJmmfwPq5FWBXLoWO1MBt/xe8v0WH6dVBqT1guMDLW2nG/JzgSU7fD/TjrFOs8 204345iMVMYJFKmxs5P+eF9VuO9Qb/hExms1xgQrOd839T/5vAaphh/xs/pZEHnLMtpA7z9VDMXM5C 204346oIIZLgliaduKH3uZIZpZt2kqXAkvYr0V4rdnYCMr+nMBshW/2g4UWghMc5Z0OubLwa+6wqyg 2043470E7fwDyVzgkbv4X2DpezEIhGqveQl2zHb22HgikEJuGYeuMZ1hH24GSoNle3H06LewLGG/yN 204348Y+MJxvEaq/xQDaC/QzXf8s5SKc0ElzCIAzE1hLVb48ZT7goamimC7QT4K2Yq4VkzkjDSYThh 204349uEO7wk/CZfEgr59u+w8LnvWEFNR9UgAAAABJRU5ErkJggg=='! ! 204350 204351!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:34'! 204352forwardIconContents 204353 "Private - Method generated with the content of the file /home/dgd/forward.png" 204354 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204355RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADXUlEQVRIie3WX2iVZRwH8M97znv2f1o2Fy4r 204356hxMvhhCeTewmJcuEbiLLP0GECoJWEIlYUBoR3QTVhRRIXffvJupiBF4oRCZukq5Na4LhlKnT 2043576XE7c/P8ebs4O8fNlh3nVdEPHnif5/d8f9/3+33e53le/usRvyv0UknzzDXgQrmQ2IzJkt4V 2043586BT4xVJfWKa5HFgwI7J27fIOmerQmMBOnfbeGWGrChXmoVZeSlZKjzQisEyznA4s1lhFWwMd 204359Z4tZIh0SNjk8vc03CZO2Yzcap32R6WLLIrYt5sgl3jvOudFiZlBki6O+vxVSsKTNK9iLurLJ 2043604PkFLKy38YE1Wp5b7uT1P+hJEakV2KDJiAGHpipMSmAIdeoT7GwlGzGaJT2pjeUK49l8Aflw 204361HZtaqI57xwv22OhD33qj+2OZXYe5OFaYF/nIUTtMmB5ot0LeAbB5kSXbn9LqIRXCUksIBZOE 204362Dxl2RJ8T+ktjKy2x1RpN5lh7aY/Lr+6n71qR9EvjXtLjRijnyVKt+TVOOqtNiyc84kENQnGJ 204363Cef7XXLKgGtG9Ruc4u4B3Q7o1mKelxue9ennCYOv76fzMoENqmXxYiDpK6wD7y9ldVPZS3i7 204364mKPe0PAQ6w/etDfwTIjh0qx0mounuXEdAUFAECMekqgkrCCsJFFReA7+/twYMkx9guVz+W7C 204365+rwVIVKlWUGK/vPlSQgC5rfSuGD6fD7H6V76SvXGBPbFBJM2aCpTHhlEEQO/E+X/mhu+TO9B 204366jl3lxETNyG5dTsbdb1xgK+gaY3YdFdXkagiqCWuIVxFWEYbEYhMkUUFFWEntPYWimXHOdHO2 204367l5Fa3koVyQ5aaJteUYCYpAtoKFtdTYwd9zF/sGBtY3OBfOgcuSz5Wbw2zHgEXVilq7B0cUSa 204368jKEdNWURZiL6MqyMCkrTVxhNFZTnZ7MrzWgeesSt0ulKETr1GFviXjUqkJAVE8rLysnIqZKT 2043690SzmR1SCfXVEIzfxV+t5e4QbEZzCY7oMTKa48+sp6TNsAetn8fi1wvY4Vssnw8Vb41c8rcuZ 204370W+EzIVyNH0r99gT9Oc6XvtavZWx2XHo6+Mwu4DY/iTx6y2hO5E1HfXA76Ex/MTbh50n930RW 204371/xMZM1VYxLZZK2/MQh2+kbuLWv/Hvyj+BJaPHpqZ0oo8AAAAAElFTkSuQmCC'! ! 204372 204373!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204374fullScreenIcon 204375 "Private - Generated method" 204376 ^ Icons 204377 at: #'fullScreen' 204378 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self fullScreenIconContents readStream) ].! ! 204379 204380!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204381fullScreenIconContents 204382 "Private - Method generated with the content of the file /home/dgd/fullScreen.png" 204383 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204384RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAHT0lEQVR4nL2WW2xc1RWGv7X3OWcutmfGYzuO 2043857TjBSYAAgaSQEGhRQVwU2pAgFQFC6iuKhBAvCEWVKtWPBCpVquhTq6pUBURFaVrUBmQuBRWh 204386FJELhIRQGi42SUx8HY9n5lz2Xn3whAZIipCq/tJ6Odr7/Gv9/1rrHPg/QwAeffTRjjiOK2EY 204387DotIRURKqpoXEauqAnhVTY0xdWDBWnu6VqtNDwwMzO3cubPxjQl37959jYgMqepaEbFAoKoB 204388gIio9x5jjPPeZyLi2nc90BSRaRE5HgTBJ0NDQ5/ddddd7jxcS4SqKo888siNwJWLycJlx04e 204389Gwisdb1dy+qD5aHaOe54EUmApqo2gWb7WR2Ycs69H4bh+IMPPjgtIvoVwtHR0c5CoXCtiNzw 204390i5d+dm881Ojr7a8yO1UjPpGkF5cueXfHxjve+i9Je2BBROZVNRYRFZF559wnxpj3G43Gx6Oj 204391o9mZw0GxWOxUVUSkM+5Y7Or+XoH+rirbe2/jqZeeCGtvLHSpqpwr2zYMUFbVsoi0VLWmqlZE 204392Kt77Ffl8/pOHH374aKvVmhgdHfV269atPara49VveKPx2tW5FYEsmjrHakeodvTw8ZsnuoYr 204393K5NKoWKNMREQyBL8OcgDoAOoiogXESMi/UC/MaZz27ZtdeO9j1Q1yLIs1EwlmcmIT6YkpzOG 204394+4e5+d7vhs8cfHLTqfmTZVUtAmWgV1UHgG4RyZ2n6hFVXd2uvt8YU0qSZMCISM5amw+D0LmT 204395mrp5pX4gxtU9B47up2ugg0t/uDb688Fn13/B/CUUgV6gH+g821fv/SKwQlU3GGM6RMSGYRgY 204396wKhqBPCt5VcfKr7ZM71Fr383edU2XcPzyqEXef/Nf1LMdcTn6xoRCUSkDPS1ZeWM5+1ZVmOM 204397zbIsDEQkExHnnOOWy249JiKzgLtk4NLTT4z9dlO9Wu8sz/fMb99y+wdf0zyISNSWcPosUmlX 204398bAETiEjmvY/PyOS9t8YY19PVl+y84f53Do0fWL6sUk7+Mbb34oWFhTBpNUwaxzZzqc3li3Gx 204399q9LsKlUa1d7l9eGRi2a7q1WstYalcfFtBTMRSVQ1DpxzznufGGMUEGst7S3TlQ/zZsvqa6de 204400fO6pVdtv/0Hf+g1XUSqXKZe76SpXSOJW/sg7B8uH336LI+8c5KU//cZJWJwdXHXhB+vWX3m8 204401r6/PAUZEUlVNRaQVGGMyVfUiknrvRUQCIC8ickaq2uxMfscd97BqZO1XZBwcWsH1N99ClrZo 204402LNbs88/t6X3290/27vndYxuGRi45ccWm644PDg6qiGTW2iVC5xze+xRw3vvIGCNnv7RWm8n3 2044039Q9w9MPj7NULmM1gLhGqkbImDyM5ZV2UYa1h623f56Zbb+bQ/v2Fpx5/fM3zz/xqsG/4osb6 204404jVuOr1y5shUkSVJvF7MgIqW21h1nBjtLU2NEomKxgw/mG7yRNVAEr8J4Aw4AXkNypsymYsh1 204405+ZTVEVy+cSOfjo9z9z33FH6068cXnTq1qjIyMtIyu3btqgGZiEyqqvPeN9udBUCzUbd9y5YD 204406ME9AybQoSYuyaVK2TUrSomSaRMQcXLT8fHoZT8/3YIzBWkso4FwWJEkSdnd3N4yIaBAEc977 204407yXanTra7C4B8scOlSQJAqhkV02J1IeXb3cKNvYZ1nY6KbS0lYmLKJuZwK2QqCwijCO8VkCRN 20440808WdO3emAYCqzojIbHv5ApwClouIhmHkp6dOKyCha7CuXGKgaFCWPnvdXYLxGXNJhkeWQoXx 2044091BJFEUmWoiIzaZqehqWdRxRFp9pj8VG7sEkR+UhVW6qKima1+TlK1jFUAPExxrcQHyMas6YI 204410ZRt/HhUbY8URBJZms4W10Wwcx5OfEz7wwAOxc+6kiBwTkRpLq2FeVY+r6qedpe7Fo4cP0dmc 204411J/ANAhpYbbajQZdNWNMB3bZJ5Yy3JiOwAfX6AibM1SYmJv5DCLBr164jwIfe+1eNMVPttZQB 20441205Vq3/hf9jzNhYOriHydnG8Q0SDSBpFvEmqTauC4oGDpC5d8rlrFinDi0xNokD8+MTEx9QVC 204413EdGHHnrosLX2befcq8BhVa0DfsXKtSde+Oseunv6qMYtCtKgSJMiDQrSIM8ieRbpNC0GcsoF 204414BaFkhcZinddff33OefMeEAPYL2+OsbGxuR07dow75+aBmjGmWe1bPntg32vrioV85zVbvkNO 204415Hfg6VhIio0TiyIknMo7IOMoIeQIO79/P3hdePjgxOffrNE0nz0kIsHfvXjc2NvbZnXfe+a8s 204416y8aByeUrVr33xC8f2/jZqROl9euvoJwrk8cQkpLDEZKRQ8mrUJQ8Rw6+zcz0FH/7+74/TM0u 2044177gUWOXvAvw6qKvfdd19l38t/vDdNWvevv+Ly4as2b+bKzZsZWbuWIAi+cH7fKy+ze/dPpw4c 204418PXl3Bq8A+o0Iv4w1VYadsk1FthuRS8uVSndPb09XoVg0C7V5NzMzMz0xWfvJbIMngXP9bv5v 2044190N9PB+exCuDf3d6HA+fU4WgAAAAASUVORK5CYII='! ! 204420 204421!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:43'! 204422helpIconContents 204423 "Private - Method generated with the content of the file /home/dgd/help.png" 204424 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204425RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAGoklEQVRIicWWeWxU1xWHv/fmzZvF4wF3AION 204426XXuKgSAT0yZhNaRKIMIToARSkbQJIVEw2CW0FRQEIoUUNWpLSCsFlECxUKpilsqCsFjESzFl 204427bGpsEG4DqUjBLRiN8W6P7Vk8753+ETCbIbSq2t8/V/e+q/vdc879HT34H0t5xH2PAbOByTfn 204428UeA68CngB/r+28COzXxt0GNYARDgLBEO08tFot3ANuAdIPxIQNmEejZAriK8BDhNCCkKn13r 2044294srmSrLqrvJqE2nEo953QD19rKCFUkLXgTnA+YcBVYBzDXwT4SeGsB6T1yIma1eWEFtyXN88 204430bNwzCzLRB4QBHKOXckJYNCXJEW/5aPpo68QTm9AeBNQAFJOAWGifuJMqwDrI49xvt+m+fXv3 2044312CyqlZ0VL6MMSwKLBSJRJNAEIvyUNt7Xe/ng19vx+XKUtetWZx49dqiyutbx98o8a9ctiICu 204432wF+jii2/n1y7jO01S8nxJLpLn587q7epuUlERM6cOSPzJk2TnvIqCZVXSaS8SowDx6T82RfF 2044336XRKZWWl3Klfbnk35ozXwpqDKXcAFX/eoC2V+YPe6weeWcqERU/FfTZufEYkEomIiEhnZ1CK 204434i0+I3e6Ro08vktIn5knFs6/I56+ukinDU6SwsFAG0sof5cfcHkeAIcTfOr9yuSvTn+eu/TK6 204435XJw75rHX7lLFX3lKRETa2jrkyJFyKSo6LpmZk2Q6HnkOj8zCI9PxSGKiV5qb2wYEBoNBSU0f 204436HhvscWzrB+a5X/HnufeoZ9/kceAvBZcGT16y+A2ZNjWbUCjMqVM1RKN9tLQ009p6PVqtB3tO 2044372robTurBi+fjo1esVvOfM2Y8E6upqb3vYbhcLpblrrAYhrkUcJ3Kd+eLQr6uGKuoyaXoD4t4 204438yxanSH39lZt1q5OiouPy4Ye/Mz2eYdfgdj3uVHZ2dlZqqjdYV1d3X5Tlf/SL7kTiB9tf8+e5 204439L/tXOJMAVAUyV1fQk5aWHktLS6ejo4tr1wIAbN26paG1tWkucHogoN/vr+vrCy3ZuHFj8N5v 2044404VAfSUkpjBo1ai7wZ0xLDoDWZ1A20mXd1Gpq2vz58zlXc562zhAOh4OOjmaVrzByIBA4Vlpa 204441epdJw+EI4XCE5KRkWtuax6jSN9vAeuJkvqtKnVLAb62XtZStjQoHVq6hOGMq7/U4yG4JEYtF 204442Enl4+1OAHaqq9t65eONGCwDd3d3YbHZt6keh68ARDUu2CiTOJ47nvGOwohDs6cWDhZt9UwOy 204443HgJ8B1jc29vrKSsr61/84ot/ICIEAg3YdL27arkjWRFllihGlQo0dWCACABxaSMB8GJFBWw2 2044442/cHAKlAHvD2ehJYb7hVn8/H7t27CQSa6Orqpr7+Ch2dHUxMsSWYivWoqLIme3v3BQDXHJxm 2044451DZWzOMnpenAMdmZ8Lh4cciECRNkxIgRoZkzZ751R2rnAFcAeYN4ieCVKF75ZEqOaCji8y2U 204446PXsOSY7vO6I7kVULx+fe11ttKCVX+brE3lwnV3ftk9R4j6xbt04Mw5Bdu3bJkCFDRNM0w+12 20444796iqagBSwgiJ3oTFXv6hGOVV8umLy2QobklISBbNZpXMrNEdD6rFwnnESbN9jEwdniKrV6+X 2044489vbOfk+1t7fLjh07ZMOGDeLz+QSQ0yRLVMuQ2HdXiFFeJe3FFXIkeYrsJl2ySBBQJGPMqIIH 204449AVWgJBlNdJsuP3/3fTl4sEQuXaqXWCx2l6EbGxsFkKJpPjH2HZVQeZU0Hi6Tkqzn5QBe+T3p 204450kkqc6DY9CiTcC7LcHAUo9gw2X4pqqsN/usLidLqx6S7q6xsIBnuIxQzC4QhWq87evfvxjh3H 2044512Kee5GpFNRd+9gHdl68CsI8uziidaBYtxzCMC/cC7/JYbS4Na/5EXk2jXhiJRl3Dhqay4IXv 204452MSP7aRTl9taCggL8pWVsiyVgl9s3LqSLw0ordrv9x6FQ6DcDpfJeYLtuwTv5YxzOePfHXcGu 204453maCQOCyVMRmZjExJxaJaaGtt4+DBT8jDzSTsXCBCMZ18rob6TNNcABx9UO3uUm0uLdU/wHNr 204454bnfx7SGJg0ptcYqhOxHdoYrVoYnVroui6mJHFwVNQDGBQ8Dor2Lc++9xwxojEWitXspoVcGn 2044550ll95BJLf1FLuhjm+NezePvkdcv+S4FIT1gYjVANHAYuPkpQd6X0bC7rTXgB6FXAA6xFwYuw 204456XCwswOQbirDliZ1kKl+W7d/WfY353OsMBfjWbpr7L7KM2WKyWBTCCvzqyZ387T+B/V/0L+bC 204457W2tds0/6AAAAAElFTkSuQmCC'! ! 204458 204459!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204460homeIcon 204461 "Private - Generated method" 204462 ^ Icons 204463 at: #'home' 204464 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self homeIconContents readStream) ].! ! 204465 204466!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:33'! 204467homeIconContents 204468 "Private - Method generated with the content of the file /home/dgd/home.png" 204469 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204470RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAHDklEQVRIic2WbXBUZxXHf8+9d1+y2WR3w5IQ 204471SOgmgIA2VECgUJuGIoJBapkBHKY6dFp1BMEPLVosY+WLWh2ZdkoHLP3QocN0SkY7CoJFQEBB 204472MLwk2YQEAqFJCCSbl33Nbu7u3nsfP2xgEiq+fHE8M3eemfuce35z7v885zzwPzbxsI1HYYkC 2044736wQEHuYjwQLSAtLW6Cqg14IOC05ehfC/Bc4HTwbeE7Bm8ee8uPJUslmLWNKgO6RT7LOjCEHG 204474sMhmLSLDBqoqyBqSrGFhGBY+n4OhcLpThZoG6HoocDo4XHAemLtlfRnLljoBOFOf4PSFBC+s 20447581NeagfAtCRvv9+Pv0jjuWcmAJCIw6kGky8vr+BA3U2OHOs+G4SnyP2JTwPnwB5FsKmsxElh 204476YW4rPmwSiZmUl9pRVXA5FfKcKh3dOjMCTtau9FHitxEJQ0OXytLqcgAsS/LTXzUQbAl/vQnq 204477PgWsyulVt3XtFJYs1kBA6w2dQ6fibHuxGLsmkEBs2OSN9waonGpngkfjdl+W3v4sNdVlLF8W 204478IJHI0tA8SPWSUrpuD/PyjgvNQXgsJzmo93Sz4M/Vs73OpxcqpFMG8WiWd34TYdMaD4phkU4Z 204479ZEYMDh6NUTXNwYpFLipKbVRVOshKN6u+Oh3TlPxsVyMNwRA1T5bhn+Ck45N4iexLBUPQBqAB 204480ZGFjoUPzLJupMPiJjlDgj006Cx+xkerLMCJACOgImYQHs6z4rJ1wt45QBNe7HSxfOw2Affuv 2044818Y0NGn6/jyPHuln7tQrWrA5wuXHwVeCj+0Bg02xPHof/GiOckSQNiGUkPb2Ci606Tk3gcQja 204482Iya10+z0XdNRhECKPMqeKiXfpfHxidt4vElWLYphCgfbXxuidnk5s2Z4CUwtmG91J+a0QFCt 204483gmqHovygRDfJT1lMzUAoK5mHoCIDJRko0CVtCQu3KegeMLh0x6DxTpZsgZvVayrouZPk98fa 204484eXNHFgUj97j9NDalmT3TSzJl0Hw1PNIPf1IUqHmsoICAaVI8mq4OFI0KbBtdDWABsABBDYKV 204485Ph/rnp+BaUrefreFva87UaV+v+KfXZbl+KkepJQ8sagEAc/VgKZImFeuafcdO4GAGN8P2qVk 204486+gPvqCqkdJKLgx918PL38/Fo45tKoRahqsrOlaYhiifmMb2ysCQM1RpgNo6M4Ha7MaUkbhio 204487isKglChAkc2GzGYpcblQAJtpYikKj68u42pbBKnGWDIrAVIZe74B2PxCHj/f1cP8z/t54vFJ 2044883LgV/4IGtN1KpQCsr6z0KN/eYCORFETjkqGIJBw2CfVDb1+c/v4skTgMDMHJX1xm7fpStr8U 204489wNIMkDIHlBKkBVhUuuB2bxcDgzqLFxSz/4P2uVoQfjwX9piwJTZs+1Hl1DzeOqxyN1lBYkTg 204490LbCjlEb4yYZLFHtACoW21JcomejA49FGO7iVO9djoAKJlBJXfojjp++wYK4fwKMBsgHuzoHg 204491pfowZv5iooZk5xtH2L17N1u3buXMycO092xj4mQN3bTjLyqnwOtAz5gMDSSJRXTiMZ1kIs3T 204492KwI5NpKbHRE6b8Wt7s6E+N0fOoWAa/erRcLVTMYikvHj8Wbp7OzE7XYzPDyMp2gKkU4/Vl4h 204493g4MW3jI/ll1l/6/PEn2/lYk2Gy5F4brdpOaZeaOZwocH6gHOmJbcISAwE+q0MRr3AAxE7eQX 204494ONm7dy/19fWcOHGCQCDAwkcmIp1e+iIxJuS5kEB7U4gVbvf9hlwwJR9LywMpicdSHKprBjjU 204495nJtA54OAco/WDBEgFY5DKiPYuXMnGzduZM+ePdTW1pKhEMtRRCgskIqJJSzirf3jxo3vM34s 204496AZYqOHm0DcuUSDg0tnIVxtudgcEMSd3A7XYTiUTwer34fD7chU6krZBY1MCyUoR6QxSmxh+D 204497yXP9WIxgSZ0Lp9sBWprh1lgfjfHW09sTnTF/wSy2b/smsWGNSCRCNBolv8COpTmxFJBSp725 204498h8n23DBuTSfxqTbmzc5HWkmkhCvnugAOPxB/PFBA/bu7/rJ0/YspXnlpKUPRDPvf+R4XG4d4 204499ZeujSEW9P0H7e4fxjHaoItVGVtGYNKUAgM4bYRKxNAKO/0tgE2yfY8qLH+67+NbRuubJ3321 204500hs3fmoeiqCAEEhM5WoFDoSTFqgrAJM1OS2YElzuXcbD+LsBIEv72IPBBDQnCb9MwKxbVd//y 204501hx9bzy/fx+Vz15FSx5JphMjpNtifxD0KBEjnq9xsHeTIwVYOf9AKcO4mpB+M/9BrIkAVzBfw 204502BvBk9cpKtrz2RS6d7WHV+tns3HyM8ps6Ybuka0Tnek+UTNq892lMwJYmOPBfAceAnxXwus2u 204503zvT584iFddK6MdalH7gC/B24kA9nzsPIP4v1HwEBakALw3ck1AroA1qAZqA5mAP+f9o/ACsL 204504HrLG8KKGAAAAAElFTkSuQmCC'! ! 204505 204506!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204507jumpIcon 204508 "Private - Generated method" 204509 ^ Icons 204510 at: #'jump' 204511 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self jumpIconContents readStream) ].! ! 204512 204513!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:34'! 204514jumpIconContents 204515 "Private - Method generated with the content of the file /home/dgd/jump.png" 204516 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204517RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACuElEQVRIie3WT2hcVRQG8N+dJtGkZiyiNpUs 2045180gZRqWhM1GihxU1BMLhx0UVFKiJqXAhuxJV0UxHcFCvuSjbqzo0LqxUXXWgFE5GAUmtTzWia 204519ltraZuwkk8kcFxOT+Zc0JSIU+sHl8c495/u++9479z5u4HpHuqbsfvdhQNIFwjRGjfnpvxXs 204520tzcl+9G7QsapCG8Z8+H6BAf0Jj7A7jUZ42jwilGnrl3wIbtSxhG0g2wr2zdxd1Z0tUu5v/ll 204521hvELzJarKwtR9qTvHVujSQzKpgGn04BID4vMgZ54v/hpTMR0XIx8vBEjIYYqY2pnpBdFGqgZ 204522pw3KNqPONA2WHESPTIo4+Ki333zXcOuQrTabVwKbbKwkb7lVvLZRPFtD0bPI0YANDZFH7BDe 204523gxi+Nw0//ZIDngMTpj1lv098bdb8cs3Mn2zOS5cwuRTt0+2oKblVV5gp21Px2FHs2LfdO55f 204524mtumyyEvN9qOyjuMPehswrWaYITHwWN3tj2TdrjFzTXzg+7Rrq22qFioXFuxrQnXaoKSLRAP 2045253GavJ0DO+aXpEV8qKC7nz12hkF8WqRL8l6saLQ2CS67Lsjqc8If7vWq3Pmf9Zay+xc5OIJbv 204526SysyriAYzki60/hFM0MFHzumZMFnRhur8xc4/1tNKE3UcdWh4ZGm5Btw/NzCifLvjjQTguIs 204527E6NE1equoEpwiasKDW0R3S6n8IKZUubHlpxCf6e8QuPKTh5nfq7W7GGqmyAyXq9vi8Y+nJLL 2045283KUHfZdGJ81tvclC72KTl+Y58zOT4yxUvazAF6SvqsQZie8cqqdvvpcOyqaSH9ADdt4u9nUS 204529uVqhikHpI5ysif4aLR70rctrE6SyeW/wuVhsxAy6KhbiDtKUyq5yTs1H6iqb99WPpzaHFe1a 204530NW8Z6zieqvG/HcCNwuv+xbiB6x//APor/zPsp+AoAAAAAElFTkSuQmCC'! ! 204531 204532!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:31'! 204533loadProjectIconContents 204534 "Private - Method generated with the content of the file /home/dgd/loadProject.png" 204535 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204536RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAGz0lEQVRIia2Ue3CUVxXAf/d+376TzeZB3oGQ 204537BgykpOQhD4sUMFIeLTpFKoq0RVBwRKodp1ZnWizSoTgWiuO0yNCBFoulaYUyUqnOAGGYQcCk 204538JjSmPBMCm3eyyZJsdr/v2+/6RyAWdNqBembOnHvnnHN/c8899wj+D1Iyd7nPiEVLRFyVIu2Y 204539QNSKHtnQ0FBl3B4rPg9o/KxvpUnL2IZgKSBvc8dQbI3qic83H9sd/dzACTMf+aZS/E7XZGDa 204540A5P6Tqc8GJOji7KJW3G7+WzQqq8esJvOTgQuIOUTH1dXnbxr4PgZS2ZIYVcX53vFr1dmiYLC 204541dDb0LeZwWzZL3LXsGZoGQLzpbLv51iZTWYZfU7Kk4URVy+1l+EwpL3/YK4W9Kz3gZNdTeaIg 2045420wmWSUWgCwmsGVVNgSsEgDZ2UqZrzctJCKHHhf06IO4YOOh1rAQKN383UyZ6JOgOzjgr+O35 204543Ig7lbMOjx3jA0zQSL5LT/XrlY63ArKIZix+6YyCI6VkpLntqcTJIjXPuEtY1zOJA9iskyTBY 204544Jve6O27JcExZMA6EgRDT7wJIeUmBRxyuy0VJBy1WGobSeOPifQSvZxAllZretFszpIbw+ltA 204545let3Acxwunyx37vnu+fZO/iqq4ajGWPY3jGP7SEgBLNHtbIl9Tij49dASIJmEs+keGVvpD/n 204546boB17zeYeYFZgbF2XKL1d7Mh+wOOdK3AsDVSnDF+M+bPiK5roBQABYBjsGcsij/ecUkVojbe 204547350ZsTVev1SKcnrpNnwYtgZAyHBhDUZBSGzhASFp7dPpCBlCCHVGu1Ngen7REIpV6npvS83E 204548ZYELwUSuDPipt3NHYuYmXcYRM1jUtJrgNRfP7ay7agyEXZqm/eSOb9h4/E/HlVCvxuuO5dnn 204549TvUf9Uxmr/HFEX+SwyDbe51oXKPbEeDN2o7gQPu1PFBPNxyrunhXk6a8/GHvoNd5AijVxk+5 2045506vj62jzh8jLKMcT+e3bijXQSDCkWbIkEjfaWHCGoajz+7qNwY7StLuMRJXkIRT4CTSiEAoFC 204551IhFCIWyQQiFu7hVohvBkhmVK+gVXuWX6MzsDuXn2NF9r9vmrA7KpIyKUsvuao9UfRu3eXmAd 204552NbSJNRWUuhMCtZXLniK/uJSEQACPz4fL40HTFJqEUF8XDoeL5OQAQmpIqWFEI7S3tPPm5p9x 2045536nx39XlXRQwoBWIgakHVXIwe0q3lzmcRTtjdvZsaVuhxuLdoSiULV60DFQZl3aJxy+DIoR0k 2045546W0kZkwmI3ccEybcg0tajCnwk146k3P/2ho5F79yBmhEUMM/2ANABW9xv4CCIjhtLqCmH10q 204555RhWUTAXV918wy4yx/pmneWLmRcblCqpO9lFSMQ2UweXWII9v2sqJ/kvwZGA+Y5iPLwZrh+rh 204556BhDSkDoE0iEvmA796Eqge7wJYJusf/UIORnpgAKlSPZFeGHzRvZsW8ulvhQamkJ8w+8G22TZ 204557Cy/x9+/0wugkSEwGXzJ0toBzyDPcWXhxi2JkHIHAHdUYAnTAoTkcoExyM9JYuqBypBvfeX8f 204558KJOyOd+jeGIBc5eYCIZvr1IdUDkVxCca/Uoz+EijnH1olPGD5Ezcktn2JI7V/y0GoKOQUgLK 204559INjZy4naj/5zgIqDMiiemA/KQAoLw4xSf6mJOTkFnLoUxl+YQZjIcLxHwcbEZAzrUZwm+DWS 204560s0pJOhXBDkWrbwKv9/d0gW3y/UX5GGYPqDidnT18eXYW2CYoi/BAmGX7ttHS2UdSkptUzYn3 204561tR4SNo1hEVP5A0ehcArETbBMnA4vX9EqmHglhS2/+CkotgNIBX2hjjZQFtlpLhyxMNXLn2dg 2045628XreXfQcweYgKBO/10EkFmXD/QtZNrqMjyJBVicU0nq8ERubFVTCgavI/e1k/dPNjJNZnN74 204563Di8t+XFEDZg/opb9ALqUhMI97cMzQBkc2X6Axxs7h0v0cTd7X/uAb/9yMZve3s/5riAH62q4 2045643N1Jjt/P175UzNuvvMfecYdx44AXz2LbalebXV/fJhHYNKKo4UO6br6STpxQf087oIFtMveH 204565C3jjbDP+5i7C+anMWz0bbJMnF85h/n1foDArhQS3Nvx19FR+Ps3NuqUvR6M+3Y2lDlLLyuE2 204566/9+ixwV9ofarKC0bYQ+RkZ3FYwd/xWAkhs/rBWWDiuH1DTF5XALYQ6BMEE7wTMLbe5QHB61n 204567/xKx6vBz9NNgAGLldFI0g/bRRWWOxJR0IuEQcctE0x1ITUfT9OG1/om1pg+rlJz5674hO24V 2045687aih5dNAI0CAVWWUS0kF4FUKTQjkTYu6oQIbRfx2a+u8t/M0TZ/BGZF/A2P54ZZvw1VGAAAA 204569AElFTkSuQmCC'! ! 204570 204571!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204572objectCatalogIcon 204573 "Private - Generated method" 204574 ^ Icons 204575 at: #'objectCatalog' 204576 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self objectCatalogIconContents readStream) ].! ! 204577 204578!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204579objectCatalogIconContents 204580 "Private - Method generated with the content of the file /home/dgd/objectCatalog.png" 204581 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204582RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAD5klEQVR4nN2VW2wUVRjH/+ecmdmd7c7e2qVb 204583uu1ulrZWoNUURYILSiKoBcRIN+gLUUKMifLiAzHEhHcVtInaxJQYY0g0Jo1CEBXaKBA3RhMp 2045840Ai10NpUbO32uu3u7GXO8QF6o7NLL5FE/8nJZL75n+/3zZn5zgH+S6r0s+cAVN4z4NqQfLE6 204585KLcDkBY6hy6D56oOSIVHDjjvC/hYI4BCACW3rznFlgh7oNTL3n5jr7ZuZ1i1MEYq/F62v6pc 204586fnV4nNfHE6J5iXnnyVnooH++/oI22P5psRBR/5yxdb21D0BFvgSLXdIxVSGHO25k9LLiuYtz 204587/NtEouN6+n0AXfkSzHzsNRE75ExRTienWVxq6euLGc19MeP8roND35xr8ganHrsd1AKA363i 204588GSDVG2pDgffKfN6kmTF68aoxDPhv317jQowCwMnzyURPvyEatqgFTo3tuTnE37ob9JZqdr7Y 2045899PkpMT4RNx2hp1/unm3fsFZpPxCxDwRLpEbNxp6tKpdaHQUkBsC6sDdcpG7GjJ4vziYP9Y8Y 204590pwAg3osvARAA4l8B9vYbu0zCeWHA8hp/SbrnwDlLeibanh4ajRtmxoSeUhaa1PMIHGlJeYJJ 204591dLshcHzinN42H8jR1tIa3dPSGjXPIpDIB7FvUlYTTupLKtyRVXUrHpKLJUrdDD80XrEDmAaS 204592hVadT1rYuu+x5+8/pvgtSExQ9FwbQurvNIrXSPijc0D/6/q4C6eRmvuGJrIBz/goi1AC5yBw 204593cswwPgaQvdPHCf/F7rEi2taD0Stjv/E0PyEovqMZ7ROtzuqfaNefiiP9VT6WJUDY94cs2shl 204594rVh0OXziQ9WdCFGpA8BKEz999HBVMniwUGhh676poD2svFnzUalw7bC1TMVMj6dyyj44qrq2 204595v2a121dQBg+heFhS5K2Sxfu1kdo4KvixO6aIuKJvKQ97QrFL8f50yDirlVqaJI1FhMxdkkZC 204596cZo6gj5kTdvCAbptt6LO26JWMxkPMjmAmT31ln+TpYnIvC4ukiAE6zVDXaf4pP361UzAVqtA 204597rVIsdkmpB8z7ULESknM/rCFygQRUT8M2WyrBySt6Z9YtNAHZy2pJlg/wDM+4nrRh4tcURs4k 204598khDEB5j/NOlRYeQ8Zi6LzGQW6Jyuzkj1Z51qrGhzQVHyRgaGLiih3GWM8HBiiG8EEQOqLX1i 204599+AImgRxtUUZZ87tW597dik2eHe/iWWybHPyp2zA2zI67HrcGeUbsAEU3Eakfxy5gJFfBuaSW 204600E/bzO6pzvNdRImLOleIzmye1irLfAQQXm2y28jU+8TD2khukQQDapOCnBzg/CkBfDvD/r38A 2046010MR5I7Mls/AAAAAASUVORK5CYII='! ! 204602 204603!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204604objectsIcon 204605 "Private - Generated method" 204606 ^ Icons 204607 at: #'objects' 204608 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self objectsIconContents readStream) ].! ! 204609 204610!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204611objectsIconContents 204612 "Private - Method generated with the content of the file /home/dgd/objects.png" 204613 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204614RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADhElEQVR4nMWWW0wcVRzGv3POXHZhZdldoAud 204615RkzRQFsaxBpTNcUtIMZaTdoQBa+tsYRYS2mjD/riiyY2pkL6JulTaUgkaayJ8aUoohgfWlOl 204616GiNqTY1chr1Bmc7uzuX40E4i7A7Nsqt+yTzM+X///++cyXeSAf5n1Ycp+2gDoVcrCVUVwr4s 204617BXvxXyEFKO0NE5o8UxK05/zVXPdv5JO+Kr5bkBcrCZkAIBUNJgHbFcKSCX8N5+VK1nNYLtVC 204618oIPFYBEAqCbsq6GSwMN7RE9Ok845apdmr6vc3gxgoRAgBYA0+NZ2UXY1eQlBq+CxBKC5EJgD 204619FEWASjcP66o6yrwcUIoBNGxAi3J7TePXVlqjwFQxgCAE50+klnQ30xXLwPec2xsU5bZAr4Su 204620ynJ62Zm9WgwANM4//9k2D4Qo8TUzaYXxJ8vAXi26aFZv6tnSsr/zrsad2tWpb/9yA4Yr2ECk 204621WW5Sk7ag6Xx8rc2Fqwgbq6dC8nXZd+N9r998XPDEA4SqAtDumNq6+59q7e5/s6OzP5jrALU1 204622bMacVPj2OnEBwJbVhqykSMBWC2iWgJABfGcCFwHc+Kdn76FDJfpyaQ/n9sLYyOBZAPxWaf/B 204623J0o/PP1WIPjLNRN7jkdVRolOCBBdtMr0NHl17WjeRq1PH7snOj99LDE9ETRSyzt3NEieD476 204624KzZvFFb4/pg18eAr6rXZmL2tICAAhMrZ5P310gMfnwgyWcweZ1rAfS/Nx3741egAcClnkvJR 204625LGlFLk+nhx49Ek2qieyrNXR+2fhz3joN4BLgEt08lZmL2b0/zvgOtPUltNXFhlpR9HrJJue9 204626GEB0dr4tNbU935hOm1Fn7crvBgyTY1eTDNjY7bAE1yl5KC4lj1siTlGCl1MZjoPvJBa/uJie 204627ppTXtNzrkcMV9I6ZqLULwHjBsNauvp727iN3A4BSxeYb7hRioTJ6+FaZAHiopoINl/uEiLOw 204628QuGWF0ZlWWxyA+ipzG/qxJnHACDyXN+TDGTpwvDAOABUBdk5NW69i5t3N6eyPiljdNvUuYE6 204629t4bGfUcBAO3P9O+wLbvswsjAJ05NjVv73PocrSs0jzz7msKJHRkbGRzOtzd/IAdlnPYGzJmT 204630efeuB0gAJhH7vdHRUes/AXIC47Ozp5bWA1sXsFBlpTRjWJmuN07OuTVoeqq4wIV4rOPTb67n 204631/l8EAN3OFAL8G3xJPtRdAsoRAAAAAElFTkSuQmCC'! ! 204632 204633!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:10'! 204634openIconContents 204635 "Private - Method generated with the content of the file /home/dgd/open.png" 204636 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204637RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAGO0lEQVRIieWWW0wc5xXHf9/MzuwNFnNbYLFJ 204638ggFjgs1l1yYhqTExdlKlbpVA7FiK08qt3SqqJSt5cCu/9MVSq0qtKiupZNLkIU2bKoG0TsCY 204639RtTGhYLDGjvBxlAcQ1i8G67mzt5m+jDLxU6jKm3y1CMdndGMvu93/uc78+nA/4UdzcEM8DOQ 204640Dm9j2xE3+YD4OljiSCmnEPwYWATmEtPSUmVZZmzk9hzwV0nibVWm4VQnM18FUHZncNSW4Mjd 2046415PEo0xMTdmtcHAeOH2fnMzWqSVE2j/tGqhcXgy+6XTzkycD80AaGPxxh8b9WeNjNzwvKyo4f 204642e/lldF2nu6WF906fxpGcTM2xY7iys+lpb6ezsZGPWlsJh0IRBBfQqTNJvPvKhwS+lEKPC6ce 204643DVXv2rmAQCcjv4yKmn0oqsrvTpzA/0kfj3znacr37qVy/36cWVnS0vx89mQg8KSm6S+Wutjj 204644ySShOA1/d4Dp/6jwRx4KNZ2PT9W9gMooyDZIehxsm7h98ya/+uER8rcm84MTz4N1o+FCZWp0 204645lEtNTXQ2NjIyMGBsBl4N6pCpq71E/79V+K08JmdD/GTbrnLZ4ZAAHRb7IDxJfGYZkXCEno7L 204646PLbHCQt9MNMBwUGsFsgpLadi30FKKiux2O1M+P2u4Pz8LqFz1O3iGU8GE14/1+4Cnh9Ec7uo 204647ydq8OT0rOwEkFYQK0Rmw5ZGceT/v177Ojic9mG12EApE5iA4BDNdsHADR4JCwcM7qXruMLml 204648pUiyzJjP54yEwzUeF0VuF/VePxqADODOoNwSt66o9JEcAyYpxsamdVgTs7h64QIfdfyTnC3Z 2046492BMcse8qyCpoYQjdhrkriIUeUtITKK56mh3VzzLc38+Yz7cZnSWvn4srwFIXGxdnF/ZU7Xvc 204650OIlloK6BZQMFZWXc7LnBO789Q2BkBmucg+SMVISkGhVZdqIQDMBcN6oSpuypF+g8e5aFmRmH 20465110/tCnB7JmJxfv5Q1YFqFAUDJimgB0EyY0vMxLN7D+6qKob7B2n64wd8UN/JZ7dnQTaTlJaC 204652rFiMNZIaK/sdhKOUqdEx+q9cDXUHqAXChsIMAsBLuSVFijMzBSQTCJMRI1MQnQWixCWmsmXH 204653LnY/9zybPG6mJ6dpfa+Nd2qbCYUk8orzYqoVY73lPob7b9HTeSl4JWC+DNGADOD1o7ldVKhm 20465468aiRz0g5FWokEEPQ2TaOKvwOESXSEhNJW9bBTtqnmXrNx7l3Jv1jPnv8OD2wliJFTC7+LR/ 204655kI/b2pe6A+YGUGVpuV11ON/V8neiugUk66rLNpBsqxEgMgkLAzDbBUtDrM/bxLFXTtPd1sut 204656vnGQ40COB0BRVQSYjIWaZRWo87el+XkG+3wgWe52eTnem4jFgIfGiE9KYvfB79LacAkkO8h2 204657QKBYLAhh9AogrQBfvUwnMNjRdH71X5TMhosYUHxBApEp0DXK936bXu91giHJgCKhqCoIlBhG 204658WwEaVeW1tjPvc2d8brXVhXlN639BApLRlWarle1PfBPvhStGIkIgm0xIKyWVgmuBaCZej0Yi 204659wT/88jdomrz6e4hlxWsTMN+dgLYIukbl/v10NLUa71cqufwQDt0FfLUTn65z4Grrxeipl36K 204660b+BTAypMsbg2AeXzFdDmSXQ6cSSnMDoyDmJle6HKyCCCMvfYZT833C56x3y+na3179oHr90g 204661dcN9JKZnGLeQEIBkbLbsyLGog1BJTE+nz9tN9pYtBIaG6Wpu5vqYqT4UFUPSvUCA017eBnLR 204662+XVPe3vkF4e+z8mD36PhtTcY+cQXK+Ma5ctXoTCBHuKBwkJ0YonFzCJjAvnzCpfN6yfo9XOu 204663bD21IY1r45+N09/V5bxYV2f9R0Mj47cDKGYr65wZSLJpVTWAkNB1QVJ6OoHBIbqamxmYMP15 204664Lqz2funJrLqAMllIT5lNeqVF1otUs2p+oLCQnOJicktLyN66FYvNhhbVAGg7c4bfnzzJ2ZuW 204665Q8N3lv70P42CrnhSHkyRn7CpekWcqhdZFD1fkaX49Xl55JaUkJWfT8tbb3Hreu/Cm1etBxej 204666i3/5KmdPO5jTi9J0jzNOe3idJVpgNbEhojE1OCWfa/eZLsJSy9cy7AIy2FMAJ2gOkOZBvQVT 2046670/8ClPo3sCGCJrEAAAAASUVORK5CYII='! ! 204668 204669!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204670paintIcon 204671 "Private - Generated method" 204672 ^ Icons 204673 at: #'paint' 204674 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self paintIconContents readStream) ].! ! 204675 204676!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204677paintIconContents 204678 "Private - Method generated with the content of the file /home/dgd/paint.png" 204679 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204680RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAEK0lEQVR4nLXWW2xUdRoA8N85M53O2Av0Rgus 204681tJZCKASvUO+E3aBFN7IbWGNMdqMmPGlMdC/ZGB/U+GI0IfqiPigvGLImXtaYdReMAomu2TXB 204682FYGFRSUVSgstCKWdGTpzztmHKaQhiEaHLzk5+V++/M53/l9yTsqlibCHNS3kTjB8iYxKLKS1 204683my39c7JJX0Mm6eHFS+mF3ezYsLY7GXru2uTdh/qSK3PppJtl5zZUU5vPH3ovz65Yv34Nde2S 204684oMb1S2fBLVUHu+jC0w+t7aT9GtGZgiihrSUnYEnVwRRPLOnM1d7y81uJI6WxEyKhQqEMcVXB 204685Lhbhdw+u6WB2H2PfiGLKAvliCSarCqb4/fzZtambbr2e2kbGBsRxIBIaz5fgZNXAn5HDPf3L 204686ZjL3hsrkVIURJvJlAfurBmZYi8Zf9V9FXQeTp5k4WqkwCAwcGRezr2pgwAOLO3Nm9VxZmRjZ 204687DaKEdFA2li9FuWqB3czDL1Yvm0HTwilwVwWMA/l8Hv69h/GqgAH3Ibhz5aJKs0wMkx8Bcczg 2046880VMCtk7P+amv9N7u2bVauhZXRsd2nVuIksCufcclvF8V8Ao60XtTbz2N84hKjHxxbr1Yju3+ 2046896tuxy/lXVcCQ1XDj4gZSGY7upFw4t35gaFyS2Lad8vS89I8FcUcQkCSJ/25/22XRqHmtKUFA 204690HLFt1yi8d4EH/dHRPP/qa3zWer+O324ycPUz/rS9x9YvSg6PTvpk38lCwuvnJ12wwn76WlmX 204691ITvI5q3nncNUDDe3t+vu7dXU3KwUxxb03ezz44u8smmjhDe/5tT3gneycCn/XEUqwB4eDvnN 204692P3jrvK3RgZ07fdLRJB1N+vqbQUE6LYoiA0fGinjhQsUEsJ7NXdz2Hx45zYcd/HUWc7NkM9Tt 2046935tPXWXE2qYdHc3W1G5bd2CXbkBEFjAyfduxI4tihwxNxFN31FdsuBKYRNLJ0Di37WXiKkSFe 204694Ha6c7ztbGOrnqrMJK0kf4vFV110hW5NRnqQcJrJtDUYPHRZH0RvfhZ0Fkw0sXUl9LS+sYktW 2046955QO2k+dv574t0w7/NEEYBE1zk6xykVKqApbDREdTncFD39Z9F8a0Lt3OeEDbBzz5N/5yBvdS 20469628Lm1dwNS6g/yfI4STaOHJ/QnE9pyodmFkKNxVAuDqH4g8DbWTHCuq08FfPnUVyGXxPW8NrN 204697/LHIwTDwcYqP3th7YHjGRKgtn9IydR05Oibg04uB07s03cqX/eyYw7XLpyZbsIbMOzy7sr3b 204698L8MOj536/OVEkJ03lnGmJlFIx947M+TgyMn/Zdl4MTCYPuhndT0vddLVgAbUIYMU/p6qiR+Z 204699sTxcUMgp1sSOZUt2ZE54+8SAwfzEjjQP7OfgDwbhScKPmR/SENIQVe71CTPRdpzriql0thCV 204700UzgcVH7lN33J3otBZ+P/SNx4XWnWkNMAAAAASUVORK5CYII='! ! 204701 204702!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204703projectIcon 204704 "Private - Generated method" 204705 ^ Icons 204706 at: #'project' 204707 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self projectIconContents readStream) ].! ! 204708 204709!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:21'! 204710projectIconContents 204711 "Private - Method generated with the content of the file /home/dgd/project.png" 204712 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204713RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAF3ElEQVRIid2Va2xcRxXHfzN37j7sZBs77+A8 204714nIcTu25M4jYRKU0qqMqjIlLNoxQhERFUoKhfKJACElQBqRRqHq1SIqcQ2hKwKKkEaYhkpaZp 204715aFJqgwN2E9dJGtO4iet4d+3dtb2Pe+fw4a7Xtkz7BVVCHOlo5s49M/9z/uecGfh/FzX9455G 204716yrSiXixVaMIihEQIKQgpRVggJMW5Cv45QAEooPFK82kqUEDRe6CD04AogN2bWOloDgI7AP0u 204717BdcDbDUARnNYoDFSHmNtw828Z+0NlMUqKI9VUharoCxWQSRaRigaIRQO4YZdXNfgGE0oEkEp 204718hVgP6xew1kesw1hqjPjQEK91nKS99VHGUol64AYDKIEN6zZv56v729HagmRAJkCKLEkB8EH8 2047194loOxHL3p79IU9NH+OQnPowSH40N7LQlfJ1PZcyyrn43S6prOfDNuxBNRN97E1VAeXX9VrTO 204720gVwBSYKMAxMg+QBEioBF4EQiwebqFO1HDzEwcHWaQ/5M20I/y1bXAaA9xOR9VmkFK2o3Mzh0 204721iWMv9YAIYAMtzufHIuzcvgYRj47OHlp+fpAH7hxj4TxNc/MDaMfl5N9Heeihr7OlsWYK0Eug 204722nQUA+AoxgAuwdNV6evsH6LmY5oNbG2Zl/BeHn+Oj25bTeFMT9zU5/PBzUBkzAOzdVaD3jSzj 2047231LGlcV2RdltKgXYCO60Q42gcEQiFwyCWmhVLuWVz7SzA1j+1YRz43W8fofnhR9i4Zpgtsan/ 204724P302yqP7vjKNTlsajUMJUGNxAIxrQOw7VLWA+KxfV8X+lmaeen4uACOZYE/j2hy9ff+akedJ 2047251Y5Mo1SjETDGLQK+QxsWD9Mq8LrliKWjfxmxckV+7C0u/uYIG7//pSJQsWLF4mg7VTRYHBQ4 204726rhMYvB2gyAzPz/YXeP8HPsWBPTsAn1w2RyKZmk2p+EGrTUZoNUoJgGXenBBtp05zqqsroHCS 204727SmBORIrtERzU9tyPZ9AXDmmWLp5LNpflr+fO4xrYVrs6ACwmUSvEiCWjFIynR3hvzUIO/+CO 204728GQm3vsebb76F5xUo5HO4RpeoQnzyXp7O3vO82H2WVwsDxMMZoouiDHfGObHhfsDHcSJTgMAo 204729QGYkwcKFZTMO+/2vj3HoR63U5yyuQLcRtn9mB/ft+XgpR9892Mr5qkHGygyXX08ydnWCBRUT 204730pBel6ekfoH7lIpQbKVGqHUsKIJOMM/36On7sFF0PPs2zw5bvpeE7GXhmRGGe+DO/3HekdPvc 204731tqmOnO/RdaiHPbXbeOn+e9ld20jsuihPnjgNMi1CD9HKBhGmkvEZV9jTza08OKFnvl/Al/MO 204732xw+dKDl38/VriF9K48+3fOjGWlwHfN9n6G8p/ni1G98voJypCE22klQoDaPDw0F9TBZCtoA7 204733Cy4QnQ8c832PJ9teZPSNMaKrXF4+d4GW9r9w8pWLVN5Rhh8TjnedZ8etuVIO9a9eIAvk08lr 204734oCIlz2vet4EXlD8LrNd6VKxfAuLT2XeRr/3sGYYSKcIrDC+fe53qigoiqw1eyiL/EK6MeGQz 204735qdJ+UxxT6eS1BahIidJv7P0s97x6ie6zg9yZ04SV4nntcbh6Dk88tgvEp275YlZdX0ly/jjm 204736jEOoRvOTL+zk7tc2EjGahtWLccobuJpIzahSgNFM8toC9JxSr7kuHPzDt2k71sn+ox3kJnI0 2047373lpH611bcTSAz9yoobv5W4xkMswrD5daaduGqqnWMksYvHQOACt4pQiHBi5QYDFuWMBPgR0H 204738fG7/2E5u39kEyp1SscE7abMgOeaFcyBZsLngsVYmsAsth2gD/zz5OEAuPEqfKV4mg/Er/Ty8 2047396xZW1t2I7xVIxQfJjAyDUjjGxXFMMBoX/TbzSRttJtc68fKtnD76FAKdj10gFwAqWoDbLved 204740cS/3nfmPlflfyriCvQFUUT6/iWWOoU4Ly7A4aLS1aA0KhRZQCBpdHAUNuKKYfMRLqgQPRRJF 204741EiHhOrTve4X4uxHJ/578G1jL6Ak/aE7qAAAAAElFTkSuQmCC'! ! 204742 204743!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204744publishIcon 204745 "Private - Generated method" 204746 ^ Icons 204747 at: #'publish' 204748 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self publishIconContents readStream) ].! ! 204749 204750!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:26'! 204751publishIconContents 204752 "Private - Method generated with the content of the file /home/dgd/publish.png" 204753 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 204754RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAHJElEQVRIia2Ua2wU1xXHf/fOzK696/Uav7Fx 204755bIyhEIwDxgQETRojcEPd8gFCmwgRSKkKCh+oqFqllZJQWpK26iMvBAFUSkjSgEMaKESURsTm 204756EV7BaXEcnsbGxvb6xa5f693Zmbn9YENcR02x1CMd3TM6d+7/nv//3CP4P1hR2QqvGY0UCVvN 204757QDpRgagWXbK2trbCHLlX/M/TiimghyauEx2ZmvTIE6nSMl9G8DggR6SjKP4Y0X2/aKj8c+Te 204758AGeyG7/rSSwnTL/1G/LZTAU2wJSHl3xPKV7TNZk05xvTQueSvxmV903OwrZsp6Gm2bpY1efU 20475919wPXEPKVZerKk5/NeBMSoFjbJ2DPj0Na8812HnlBJb67iT3sgIpnKqpeR7x29VjRX5BOptC 204760SznSmsWyuGr2DMwBwK6vCcTeeTGmLDNRU7Ko9mRF40gaYCYTKGYV8ApSkF04gaPGr5jy/VLY 204761Oe8hUuPOWqrnzfQkF7s25Ij8TBdYMUqSOpDA2rQq8t1BALTx0zLda1/yI4RuC2c3IL6osIR5 204762KJ6hJKU8ZUmhiGTrDOQYOIk68bgoYwa1NHK99Qba09UcWLqM8lnpoBuc98zl2cuz2Zu5Db9r 204763gFdvf5tdoeK7R8fO/O2a9Y/dE1Es1gAoZhVx2vsLdjz9tcmrS8Wt3D56PJ2o/gCYYSxPAldo 2047645jZ94DNQhQnIQ/UsmX0/V+IfYM3nZRwZ9woJohcch7BI5mjfxLuAWlZBinViv4kQTToPkoLN 204765liUvrZfNhYqzgb3QchV64qHNDZMikJIz+KdtQVsdXO/mRvs4lDRotFIxlcYb1x+gPOM6KT6L 204766C7dT/1MmqSE8iY0q3D1Tx2KRGOf1+EpyOHt1MwRNeIEBWvr2oPqy+b23nEgvhNqg/SZ8Ek/S 204767Llt517wucD5gofsCH2Xksq3tUbYFgSCUprXwh5Tj3GffAiFpjvl5Jtkjb4e7s3VAL1o0j0+p 204768g3AIdhnQai/mEz6khMc4K8tJPAmtibDVUr52byAzrSwaTivMc+wjaN2dbMr6O8c6nsJ0NJJd 204769UX6XewjRcQuUAiAfMPq7xqP4i0RwMzjQTQ03wTsGdBsUPQAYHGZ/bwMbRTXPBX9ER+y+LPfs 204770vfT2ZIQdjd11M1AuD52mF9MZbIeg6cbqj4CQOCIehKQlpNMWNIUQ6rxOPscbq690Q5qfxDSY 204771Y8IZ8+vAOU4zAEwAy7krx8POX5US680Ptt98bfG63NqabLITvxhCCrhpppFhxlh6czXzw9Xs 20477233ewCUiTmnZIUoHNpdBbfNwO0X7IVaCYO0xyZ1jMpePvHVdCbbX/VZnjXDnb/VH8dN42Z93N 204773+w2TLE8vEVuj00jireq25r7ArRxQP62trLg+yEMqpzkeWEG87qMyAs3Wblo49aWhMGR5qQWV 204774MUMrt2s/zlOBhiYxsdgvdIM0Y4CDE3bg6Wsl1BvmzS2HmmOfn8kWgorLJ977CQyNtjXFLOkQ 204775PHEJZvnAnAZt2iA/EokQCuGAFApx59tGavVGYWaLXpCupLTxJbcljctx5nhbsq429cn6trBA 204776iZCj+PGVk+/uunNZsbaEGXEJSdULlm8gb+p0EvyJxHu9uOPj0KRC0xyCwU4Ml8GYpCSElEip 204777YUYGCDR1smXz85xqklW3tbFRYAYQBVEN6oKmye21lRWB4ezoNhROfnAB5avXgQqCssCJgRp0 20477824py7PB2/EYAX8Y0MrLzmTI5FzcxcvPG8MjCckJbnz224wKb/psEw01KRVp+0WxQoS+BWbEo 204779z/3s58wee4rvTL9BR/0pMjKSh/ZYEGvBcLmQIxrrq0xXAj3ekwDK4vmtlWRnpA89WMUYTy+b 204780f72RPS9voC6URG19iMf8cYNgQ5dyuXWUGgUgYGiGASrGuIw0Hv/WwrvJdw+/DU6M4vkrmTol 204781j7KlMQTWEOCgu9wSJVD3DqiQUgLKorm9i5PVnw1L26Aspk4ZDyqGFBZmLMLFugYy/PHkpCag 204782G8boKEXR293VAcrih4vHY8Y6QVm0t3fyUOnYu5X09PWyfN8WGtu78fvjyHS72Ld8BZruG1WF 204783UkEo2NYKyiYrNQ4j2kvVil/St3QT+xdvpLmhGZRFoscgHI2waW4Zy3Om8WlPM+3BIFL3jkpD 204784KSXBnq4AKAkqxrFtB1h5qZ35A4qVl7uo+tOHoGK8WPE+VztaOHjxn7xz/gLZjo+6QBemaY2S 204785Uptgd1cA0EBZlK0r543P6kms76AnL4VH15SCslhfXsqiokkUjE0iIU4b7FIthcrK0OiaxhaE 204786goEmlDYW4QyQkZXFkwc20x+O4PXEg3LAieDxeJk+MQGcAVAmCBd4iqmveRUBXfcMqNzc6myp 204787j73wVLnhS04n3BPEtmJouoHUdDRNH4z1YbGmD7o8z/mjeweUovJeAQXAD4qZKSUlgEcpNCGQ 204788d1bUkAscFPbI1dE5sPMc9fcK+G+8HDQjZjwS2gAAAABJRU5ErkJggg=='! ! 204789 204790!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/10/2006 13:56'! 204791smallAuthoringToolsIcon 204792 "Private - Generated method" 204793 ^ Icons 204794 at: #'smallAuthoringTools' 204795 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallAuthoringToolsIconContents readStream) ].! ! 204796 204797!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/10/2006 13:56'! 204798smallAuthoringToolsIconContents 204799 "Private - Method generated with the content of the file /home/dgd/smallAuthoringTools.png" 204800 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0 204801RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAAIDSURBVDiNpZM/aFNxEMc/v5fk 204802aWJrFJoY0iriM6KCODloF0HUQUtFCgbEQZTSsSChnaIOLqXQOlRw1CGgQwVJ/VcDlRgaMSDP 204803Dm2CMZDSajWIMU2IrXnnVhIMtuLBLcd973v35XtKRPif0P4VoJTaopQ6s1YQkQ1n21YuPLh+ 204804uDwR9ghwU0Swb5C1JeC3jyfunjq5r+Ujb2YFwK2U2rQuK+ANnvB/+Pb8nMi4Rx7d2L/q3aYP 204805AbtFZP0Terv3ZgpPu2UpckDCl/Z8Bi4CrWsEfwNrmtZ/e2RY7t86b+1s2xwFjgK2hg2bAXVd 204806H/H5fDPt7e3vQ6FQDQgCnma9f4io6/qVyL1If8AIkM6myWQzAvhF5GtTgeuNpJQ6NDo8anad 2048077lKVaoVSpUTxR5H5xXnG7oxlTdPsE5GX9QPsdeDW3qu9r3rO9qiVXysAaJqGruv4dvgYHBg0 2048085tJzk06n82G1Wr0sIhWoc2Lnsc7H4Wvh7Q6Ho6kXRATDMHC5XAeBjoYNvF5vaPrF9HF3q5vK 204809zwoAllgsl5cploqYMybxeLycSqXelUqlCLCwNkApdSQWjQ0ZuwwK3wvkF/PkP+WZik+RSCS+ 204810mKaZrNVqk0AMyItIuUEDl8sVtDlsRKIRos+iVjKZzOVyudfABPAWWBCR1aZ3AQro0DRtwLKs 204811KvAEmAWWZIN//hsvzWIyGWZzGQAAAABJRU5ErkJggg=='! ! 204812 204813!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204814smallBackIcon 204815 "Private - Generated method" 204816 ^ Icons 204817 at: #'smallBack' 204818 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallBackIconContents readStream) ].! ! 204819 204820!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:37'! 204821smallBackIconContents 204822 "Private - Method generated with the content of the file /home/dgd/smallBack.png" 204823 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 204824RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABqklEQVQ4jb3Sv0uUARgH8M9792bHmZRJJYIt 204825tghFeW8HJSGBhNDY0tAQKbRWUA1tTg5lf0AtTREaERWEEE1BDRZEtQSZS3CdyqXe+eP03rfh 204826BClJsKAvPNPzfL/Pry//iPQfM0edsk9GwdTWJPNa5TwUSUQqcg5sVh781rVf4pa2bLNLnQx9 2048274Ef1O0YQowENEnMY885YXeCkUNkdiQvh2Q7DV4ZdC++p3n7PyCRhiu1pGkN2hNQSvsxXBfoC 204828kSweCYO+XYMn9PedN6HgsTcahLp1yunQKCMWKykbjV+Z6h1lfuV+IHITV904pPXMEQWlDXu2 204829aNJuD5hQMGeB0y8oLn0O0QYOZzeSi19ZmDWzWjWzuoKEVJp0yMIq1NLavMaAWiVjf4nG5npB 204830ucTEWxbnWK6wsrQWy1RSPFkk8bF+xC49Up673Jx1sMzOvVRK1DI8qFKMmY6ZrrIcr0+YuL7+ 204831xi69Up4Z2J1xbJa4xngLd2cIDIp9E9iGUGJJYFKTl7/u3KVHpOhiNvG0KXE8SEQ+bWakjchr 204832Fxlfc2Is59zWBOoI5HXLy/8N+f/iJ/5OkGsa/+A/AAAAAElFTkSuQmCC'! ! 204833 204834!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204835smallCancelIcon 204836 "Private - Generated method" 204837 ^ Icons 204838 at: #'smallCancel' 204839 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallCancelIconContents readStream) ].! ! 204840 204841!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204842smallCancelIconContents 204843 "Private - Method generated with the content of the file /home/dgd/smallCancel.png" 204844 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 204845RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACC0lEQVR4nK2RX0hTYRjGf+d85882bWZMESIC 204846CSHOaYu6TIksRwRCXhgUOLqWsn9IlFAQ3YRSoFTQWEFGeFUXBd4FQVC3zrrJIOgiglzTOd12 204847tp23myY6XBfRe/XxPt/zvs/3++B/Vgx27oXdjfQ9EI5C+8aeXjs4kDhu8zVu8dmFvi2Gdx01 204848WThh892F85vELohctPHKvTFZfvVUxrYHSg4cqekuREe3mdnl6UnxBnrkWgDfgRiAAaCBlfOp 204849+Ok5U31ZYHTmiVUaTMzqK+W4D8X+sPnm6nSySfM89A/v+eWDArUpxT44fM6i6LUhK8k7svTy 204850sYwEVeFmi1VYev1McjMPpdyhZMTGdyBR82kbhzjQe8xmdqJFswr3pvA1DVpb0TMZAlcucDnr 204851+289hubhecOfcKHvko1X7VCSn7olq+PXpdSuy7BFxYVT9feN+oYG5i6FplerlMduoGmgTKhA 204852WYdvDTf/eUL//RAVaUN+NCPzBpJWSCaMFCLIWZN8FA40ij7wqIlqzZw2kCGDwoRNNa2QbBjJ 204853R5CEyVIU3PrNh1IbzPMGcsZgzYFuB05PBvDTClluQXIRZNBg8SCE1hlo0OoY6ItF+FmE21D4 204854WCH+Cd4BJIsErCAp8midYehU7JirEALW1lOcVKReNCODilUHurfgMzweQB4EkRjc3ZJDFHpc 204855iP4F8v6GEP+1fgOfrL0AYYB91QAAAABJRU5ErkJggg=='! ! 204856 204857!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'! 204858smallCenteredIcon 204859 "Private - Generated method" 204860 ^ Icons 204861 at: #'smallCentered' 204862 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallCenteredIconContents readStream) ].! ! 204863 204864!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'! 204865smallCenteredIconContents 204866 "Private - Method generated with the content of the file /home/dgd/smallCentered.png" 204867 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 204868RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADNElEQVR4nHWT3U+bZRjGf8/bt+WjtNBC27e0 204869UFAyHZXpVnSKa2aWmbBlGyZ+m8XsQGEHSuKR/4dnoskO8CNZYswkWRyJmdMxjRnRNTi3FEpH 204870W/rdl0FbWmjfxwPYznaf3cmdX3Ld13UJnjCnTn3asqU0fCYVnyGlT0jplwIf0COl/PLm3MxN 204871ABUgfHbyCIJ3QQTtHdZ+l8vpt1vbHHa7lU67HbvNhs3Wga3DSj6X5dL3cyFgGECE37j4UqvZ 204872vDD98Xvq0IFnMVnaqdYNKvUmlZpBfdegYUiaTUnDgDOhTs58MC0tlbJtfn62otJk+Kkhnxp8 204873PsTDSoOd8g6lkk4hX6SglygVi+ilErV6DZPJzMlDU/i8bhFPGgeB26pQDKvH5UTXdS7NXkZR 204874FBxOB06Hkx6nk6HBAJ1dDiyWVhqGxJAw4NdIJNNB4LaKpIyAfm83n392EUNKarVd0tkc6+kc 2048750fv/kcnlqFa3+WTyAvY2E4E+L7/9+ffw/hNNerVao8WigJB8d3mO5HoGzeNC87g5FDzAxHiY 204876Pk8XZlUAEPBrgAjuA4yNSrWGxSRAwoX3z2FIyWa5SjaXp1DIc/1GlOR6lq1KlfNvjhPo8/LI 204877BVUKCg83y6gmwbXrf7Dw1x12dxt02q3093rw97p59cUR/L0n6bC2AbBdqyOEGAidnWxXq4aM 204878Z3JFAF4bO8Lrx4/SalEBSTpX5EEizZ1/l7ly7XeOv3KYl0PP0dbagrvHITLFjYPq4txMNXxu 204879KlMo6pq7xwnAtz/8TOTuMpq7m4Bf4+lBHyfCo7i6ux4nNeDXyOT0YXVvFbH1TF7zuPYA598a 204880f3wopSSVzrN0b4WVeJLVtTTTH72Dz+tCUe4G9wEylsrkxw6PPMNaKks0tsbyapJ4Ik2z2cSn 204881uRka9HPs6At8+PZpLBYz+sYWEtr3AJJYKl2g2TS4+sstAj6NE8dGGejzYjIpJNZzRGMJfl1Y 2048825OtvrhBdTaJvbKaFkF+pAEIoi/8s3SeVyTM2OsJKPMmPV2+wHE+y+iAl6zs7KxIRARlBKBFD 204883GJFbP83EACkeaQ1PTH2BZAKIg4yAEpHCiLRvby/Nz89WnlT7/wF5FV54cVgUugAAAABJRU5E 204884rkJggg=='! ! 204885 204886!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204887smallConfigurationIcon 204888 "Private - Generated method" 204889 ^ Icons 204890 at: #'smallConfiguration' 204891 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallConfigurationIconContents readStream) ].! ! 204892 204893!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:47'! 204894smallConfigurationIconContents 204895 "Private - Method generated with the content of the file /home/dgd/smallConfiguration.png" 204896 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 204897RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAC1ElEQVQ4jY2TTWhUZxiFn++742TuTObHxNSJ 204898RqOjaMW2INWqVQjRqLVqIIhWhaKgiGm6KCqUulAs7cqVG7EtIq0BfwIRUYiShnQxgqKOSmkw 204899sU0hE03MD4bMDPfembn3dREiCoqe9TkHznnfY/BmVAB/RKNlhx3HmgtoYBAovIX/GurD4djQ 204900mTOt0ttrS2vr37J9e6PMn/+RV129IAX8CNQCAQD1ijACnKypWb+noaEey9IEg1XcvHmd9vYW 204901jh37jRUr1jE8/JRTp47S1nbeAb6dFNfOmpXov3IlKf39eblx4z/Zu/cHCQbDYhiGLFtWKwcP 204902npDm5tuybVujUFkuJGYI8J0OGOwGOlatWjPTcfJ0dT0jlbpFS8tpduxo4urVx9TVbaWj4zJN 204903TRtp6WqDc0cgPhUg4zNFV33/5QZV4Qxbh3atc554EguFIqxevZGVK9cTi02jWCzw6NF9nAVx 204904WPohxEohX5wwEMjOi8fZ+fFic9/De2aib4A68qT/as19c/1CifYHfI724Phu6EmD68HFTnj2 204905fMIApTK266IMg8lWNwdN6kNmyBZh8+DIcHLn2grqPoXuNPyZgkwOyiIAWS2QfWzbPCi6jLoe 204906nkBQTxwnoBQRpR1E4G43XOqEfAHOHwWf8TJCJiDC/65HTd8ABaDTclji91NuaATxuN8Dze2w 204907fBHEy2D61Jcd6ILrjk/xPBqiYXqrKylRkLQcEn0DbBoYYdBzSxjLwS+HoHYJeB6MjsNYdiJC 204908EbJ20QVtENWaKUrx6wdl/Du7ki2hADlXDD5bBJ8kwO+DkXH4+mdhPHccGPIVYPT3ZNIyHJu1 204909dt4UgZBSVBiaA5FSruWssZ6iOw2A9BDc+idDvvgV0Pbq/5dqOBDRqjuslfVTedQemjND7ESV 204910rDFLutnyubDnCwFSwNx3jWmpH86aSo01hMz+hX5fGp8hwNnJAb0vIkCjgjvA/reRXgAJIyij 20491102CJYQAAAABJRU5ErkJggg=='! ! 204912 204913!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204914smallCopyIcon 204915 "Private - Generated method" 204916 ^ Icons 204917 at: #'smallCopy' 204918 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallCopyIconContents readStream) ].! ! 204919 204920!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204921smallCopyIconContents 204922 "Private - Method generated with the content of the file /home/dgd/smallCopy.png" 204923 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 204924RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACp0lEQVR4nHXRz29UVRjG8e977pk7HTpzOwPt 204925TFqbWGscWOiGuCCAhI1oMNYfCzcNCQuSmpCQ6ELiwsjCBX8BJl0YV6xYKQsSQgIETNCMxhJD 204926m7SRqdg6pUwLzHRm7r3nvC4KiLW+2/M8n/ckr/A/c+TIsf52tm8sMOZFDxXV5MLN7755vDVn 204927ATk0MfWBwoHKUGn30M7S+I7+3AuFfD6KogJRIU+jscKlKz+MAV9uBeSNiamPD+/f+/WxyY9w 204928kmWj52l1Hb1EcU5JvVIdSjlx6ouLcRJOhpl0TPDF63uHb3DmjLdA6eD+fXRdiPMer0pjaZF6 204929fZFmc41Op811El7dM350IMo/LEZ5lhoP8D/PTd2AaavQiwo5dmQNXuHylWs0lhf58N23KO4c 204930wqnQiZVO7EySKqlTImnyy+mz+4Bpa0R7Lk3IhZvAo0frvHf0TQqlMrED7xUj0JcxZAJwXqkU 204931B0GoAlhVE8e9Ln1PgNAGFAfym6AHr4r34HQTcwr9uQwDUX73E0BbrfYGWSt4hWwYoC4lmzGo 204932/gN4VQJjKOQCcqFhpDI4ePj940Ur+KXG/SbWCoKQzQTESfwMVBUA+kJDaOXZ+UZHytxZqFet 204933C+Teyuoa1gjGCGGYod1qY62AboZDaxD59/1HR8rgtWrC9fjPldUmgREEKO8q8tf9JtYINhCy 204934mf+WAUaHy6C8Yq5e/ba72lxfe/pQKe9iubGKESEw2zSf/4Fo1QIsNx7cvvnjzCHvPbWZWR63 204935Nrbd+vyUB0uAvGQBfNed/Pyrc59iZFnQmdf2vHweMFtLSZKycPces/N1btV+A5Xb2+55Z/KT 204936hXNnPxvv9GLm5uvMzdeZna/73/9YupOm7idUasZr7drrw7e2BQ5OTL0tymkMd5+GW6K/1r6f 2049373tia/RuMlS09PH8/SwAAAABJRU5ErkJggg=='! ! 204938 204939!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204940smallCutIcon 204941 "Private - Generated method" 204942 ^ Icons 204943 at: #'smallCut' 204944 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallCutIconContents readStream) ].! ! 204945 204946!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204947smallCutIconContents 204948 "Private - Method generated with the content of the file /home/dgd/smallCut.png" 204949 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 204950RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABp0lEQVR4nI2RwWuScRjHP77vmq9TWzqb0+iw 204951dAahluhhQV42MDwogyBo/8JgEEF/QhA7BF3WZYe26tDJLjtIG4w13A4lMbaFF8UyTGKa5pyN 20495217fLa2w2X/2cfvye5/vheXhAm2fA0x49/xCBKKBrf8S81lzEO9ZUa+cinHpHH8T8q067OQFI 204953AIZB4ZLLIgwC1/sRbKV3s4eJF7Nxp928CYwaLggmz2UJwN+PoPwlV3u09Po9a0uxkG/CknbZ 204954DOL4iARws5ugc7fPH/fLoamg2fNkPmC2isDRCS93SlXgTTdJJ5YhScxur0wrrfR9pbA8rQCF 204955fsNtAqNWfSO/MKlkHvoU9xWjAoT7WaFNsd6Qj6N+W8R928GtiWHebhQCcot76jTZXgKAin1o 204956YC6ZKv5O7pZ/lSrNk8af1nNgEagBn7RWMAE7oqCTr9mkH+EblkUdvFNrd4CvnL3gf8wA24BR 204957Bwd6UYwDVeCuGqwDHoCBLoIwkALqCqSasuxTpa+AQ+A7kNES7KkBADeQANaBIHAVyGuND+AA 204958fgIfgG/AcK/AeYwBj4GLWk1/AX4ycm0mm5UYAAAAAElFTkSuQmCC'! ! 204959 204960!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/10/2006 13:45'! 204961smallDebugIcon 204962 "Private - Generated method" 204963 ^ Icons 204964 at: #'smallDebug' 204965 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallDebugIconContents readStream) ].! ! 204966 204967!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/10/2006 13:45'! 204968smallDebugIconContents 204969 "Private - Method generated with the content of the file /home/dgd/smallDebug.png" 204970 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0 204971RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAAIqSURBVDiNhZK9a1NhFMZ/5+bj 2049722pSmNmmixUiGCiFiRdRuNX47ODk4pAhKEUSHIuji4FZxkP4FDnaxpW4OCkWF2IrFdhFCIaSK 204973S2sJ/QjcxOaj8eY49FbSpOKBw8t5ed4fz3t4UFUaG/AB/Q3z2WZNY7tpKlUticiQiFwENoCj 204974wHSzbqdaACLyJBqN3kkmk/Vyucz4+LiKyLSqvt4LII7NncdB4Kff7ze9Xi8ul4tKpYJlWTmg 204975T1XX/+fgVgjq1woF4qEQnbUaacviLQS+wz1g5J8ORKT7isez8GxwMBxKJGQpFuOIKmQyFGZm 204976dGRysjpm2+dUda4FICISg7mxoaFThwcGDBOoqtIOyPZm+ZVKcXNiopiCXlVda/5C322R4+lA 204977wFjPZjkJeFTZAt4A51XpCAZ5BPtS8EBEHquq3Qg4c0xVwuk07T4feWA/YKpyEGhXZbNYpAie 204978MAysQg+w/BfQAXEfeEuzsxiRCE9FuApcVuU0QL3Oh+VlXgI9EFmFQ7sARchYUOrc3PSVslnu 204979AmERSk7SfgMJoB+4ACtA184ODOd8P+XAcsAXoKZKujPAEnDJuZ+FrTx8BaxdAFVdfAUv1qCy 204980wrYi4+/iefwEphiMAAXDZY9u204Di80OyMP9YXgnhlEZBqaivVr0mnzuPmDnzDb7Rt3+9ANG 204981gXlV3WgJkhMmAa7H4OE3w1Vzezxt7molX4IFYB74qKq5liDtVSJiACagQNXR1pt1fwBQXQnk 204982LaacTwAAAABJRU5ErkJggg=='! ! 204983 204984!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204985smallDeleteIcon 204986 "Private - Generated method" 204987 ^ Icons 204988 at: #'smallDelete' 204989 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallDeleteIconContents readStream) ].! ! 204990 204991!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 204992smallDeleteIconContents 204993 "Private - Method generated with the content of the file /home/dgd/smallDelete.png" 204994 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 204995RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACrElEQVR4nG2TW0hTcRzHv+ecqdt0l1YT2pq3 204996NFyaLCK8RNiDdqMiBJFeDIogIujBtzB6ypcu0FsFgQ/ZBSEpUSu6EUo9RGltiCXihk7ntnbO 204997zjyX7Zz/v4fyMufv7f//ffj84ff7/hlsXkxpqasRhGsCsIXT9fsz4XBoU3D9wePx1LKgFytK 204998He3HWrzFh5urEIlLeDni1999mn4mqVpPKBQK5AhcLpc5j2Me1nq3d1w+f4DxmCQkZqYxNrGI 204999pmorEgYH6g414unAT/qo/9srUZZvhELhsbWX3e6rT2630fjUTTrx4gK93rmbFhZwFAC1mAy0 20500063QZ7b9WT6P+HhqZvEUvnWulHo+rAwA4ACg0m492nXIdDPv94HUjjrS3otq7E2yeAz5fJc50 205001tqCmwQdFA6yWAmQ0gpG3gVgqtTzEAIDNZmtx2GwD+/Y3FXWfVEBlEdaKXSjfuwdqhiApKrBa 205002jPg6HsbQFxnDzwdTwblIlyCIDwwAIAjCqLWoaPH773Rl+918lLnc6D4RhdO9hNcTKt6M5yFJ 205003TLC7mqGaNURjfYOCIA4DgOH/GBRQwnt99YCuQ0zyuNIXg/2jBmd5HfK3FoMzGCFQFvzCD2hE 205004nwUwt14AAiRWtmqx2mGx2gFHMdhtZdDWrU3hF0E1spoJdq1FEwQkKyQGY2FOcBRhAWldD+YI 205005KEGcEC0LZhkWG0sVY1RRlNlcAaVxoqezYF1dzhFkZDGVTqeFHIGayYz+mQ8QcNwarErZwowC 205006KT4XASCv3K3SsiwH5cT8lMwHG+w7aqwsGGRYApOzBHpaRjTwATPv7+n8UuixJMmDwL+BZX0m 205007ADCZTCV2m+1OVUNHG5NvZKTkAuK/xkRpOTWSFMVeSZI+A+BX+BzB/zI4nY6zBi7/ONH1ST6Z 2050087FVVdRaAthH8C1vLN+tQdL6MAAAAAElFTkSuQmCC'! ! 205009 205010!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205011smallDoItIcon 205012 "Private - Generated method" 205013 ^ Icons 205014 at: #'smallDoIt' 205015 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallDoItIconContents readStream) ].! ! 205016 205017!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/20/2006 12:19'! 205018smallDoItIconContents 205019 "Private - Method generated with the content of the file /home/dgd/smallDoIt.png" 205020 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0 205021RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAAMRSURBVDiNfVNbaFRXFF3n3DNz 205022r3cm10nsaJxYMU5joon4QvGZYjUGtLZEBWkiRWwj+iEq4odIW6S0P/VXEIvFDzP4iB/6IRLR 205023ZDCjVpsJksekKsaQaXwlmceN9c6duWf7EQ0y2O6/zVqstdl7bUZE+L+qXzW3GEAFgM5QJJbK 205024x1m+wJ7ayl+IaCdj7HZ6TB4wvPyvJVWqO9qTyaRMuTYUif39IZ/nuW0JzhT7ThzzB5YtcG90 205025CYS/WqcXNW43iuo26MWJ11ZD/gQir896dEVyIdBQV6gvX2QHPyt1QzKG+AuZ0VVl457aygYC 205026Os0xWR+KxGzxznmmz+BnfAbH44GsJK5AuIHyOeP6BGDrJp82I+BetGKJh5+7nAy03jX3A/hN 205027AMBkQzn7XcMnqwt9ghV4OIgLXLgyaoXvmHYuR1hfbajbvixUv6hWOQAESzW15XZyHWPsuAAA 205028KVFaXu5h6jiOe1FTXmtLDjWFHx5kDP1ZZ86Piotvrts0RQ1HUnbTpZGRtq6hZgCCA4Ak+uHw 205029TwOJyL3XNnGBrphldT9NnJdE4Zwju3I2+/npgG0SF7BsBoDxpbOnDRNRlgPA7y09ZzIZ+qPj 205030wViGuILi6ZrqNyZNJ6IUAGgaX6npwkVcQU2N3/3rsbJpJVP104wxJgDg28/nba+c593d2Dir 205031gDjHmmq/cr8jvW13bVWh28Wl1yvW7tjx6WTiCgDAY3DQ+AXH1+w4pAZKJgmX5kIqnUVBgQtH 205032jlZ4e7rTX3s8AoESDZqm4OLFuNXaOpzjnLEnz9LNABwBAEQ4394+eijamSodTdjO0mVF7l3f 205033B/WqhVMmAkIA0mMSj4eSJyN9z05LIg7gCQeAUCSWMc3c4pY/48sfDiaPMs6zxBUMxi3s29vx 205034prk5niGuIFhmqH6fXuZI2UdEvUQkJ5IYisQcAL31q+Y6fb3pXGc0hZvX/3nT3T9yim5gQ9eD 205035ZMnwK8tq7xm6yhhTiMj56DO9S+ZCEnTk+ei/Zlv3YNM3KytuPXqemB/tf+mRRI+I6MV77kcF 205036JkDGBBHl/pMA4C2oHVtvUbiwmAAAAABJRU5ErkJggg=='! ! 205037 205038!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205039smallExpertIcon 205040 "Private - Generated method" 205041 ^ Icons 205042 at: #'smallExpert' 205043 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallExpertIconContents readStream) ].! ! 205044 205045!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205046smallExpertIconContents 205047 "Private - Method generated with the content of the file /home/dgd/smallExpert.png" 205048 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205049RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACS0lEQVR4nJWRu09TcRTHP+1tL33QVkjB0lqN 205050QABRiiE6SDCEElJcYWbV4GRSw9zBP8BFSRwk6mCiI4Mp0dCQaHwwgQllACqlPEIfVOhte3vb 205051n4M0ImICZzq/c36f73lJnMHehJDfRiiLGW44nGRGfMj6swjU1qObfoSHNWJ2lcZ7z1B0p4W/ 205052PsEraTR61yg7BWHFwsRKM3On5X0+Jx/uXiM3NYRYGuPTx4c0AvyvAxm4CnQDWeAxsNpgZrLX 205053w/eZH9ieB1GlFRZOgseQSNY214pWf6twd7oFIID3wOXDP9dDIfQCdMc7eMo5xj13PPR099Du 205054biefyBOdjyLbZcIvw0qlXLkFfyobjsCjyIxzG1wXXTTVNdFyvoWOng7Mo2ZiuzEKhYJl9vXs 205055K+AmoAIcPeMEV8BoNVJjrMEsm7Fb7HjqPbS526iz1jEwMoCl3uIDAlWoKmAAfDRAqVyiWCqS 205056V/NklSzxVJxoIkrqIIWiKji8DoDe4yNYARPy70fyZ5LN9CY2k428mscoGUntp4in4miSBuA8 205057LpAFVsjQghXWU+uYZBOlcomtvS0kvcR+fp+N9AaZRAbg80lLnGaVB1wAIQTLm8vs5fZwWBzo 2050589XqUosJ2bBttV8sB4Sp09IxmYJ4uOungXysAc0CW+8BkNSxVnVAopDcYDEs7iztdpa1SE4bD 2050597AEQB90XnXrJeWkqGAy+6+/vVyORSO4vgUAgYHe5XA19fX0LxXRxmzjFynJFsiVtCa/R+214 205060aPjF4ODgohBC1jRN8fv96UgkIn4BMVjYCuwVUJAAAAAASUVORK5CYII='! ! 205061 205062!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/20/2006 12:32'! 205063smallExportIcon 205064 "Private - Generated method" 205065 ^ Icons 205066 at: #'smallExport' 205067 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallExportIconContents readStream) ].! ! 205068 205069!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 4/20/2006 12:32'! 205070smallExportIconContents 205071 "Private - Method generated with the content of the file /home/dgd/smallExport.png" 205072 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0 205073RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAAJTSURBVDiNlZPNTxNhEMaf2d2y 20507429IWW6rAoiEhVRP5sBIlcqgHL0YTrScvePDEyZuJqf+BB2/ExHjxwFUTKtFEkyZgoySgpGCU 205075AEK4uKLUVtvdbbfd3fEgEChN0Oc4mfc3z8w7Q8yMRgrGFRnATQA5ADPFTOVbozxqBAjGlSE1 2050761vY0erpbbfepmExPlX4s564WM5WpAwGBC/K18EXfuO9UE9UKNkgU0NPVh6X0mvX17cYVAOsA 2050771ouZigsAQj1RbpdGPapA5moVuefmRz1b0RcWs1DOsexpE9NSRFglkR9t5+8BpNRwgLVatjhj 205078FQsvy7d/vSj3G/O1QfNzzdF/m4je6kTizmUIihjYfiPtKc/87MlqcxevUSSh6bVgXPGKIZpQ 205079opLoaRGhiAp0S4djuF/2OUip4WGJecBnO4cB3N0KH1KOSRFRITCAUq2E7EIWANJ7hphSw61g 205080XurN637ZdeUPkaAJolhCy68E48rxJlWY9g/IrXKnB/lX5uzmmD5Y7+BByLKNUNWWfbaLTsMy 205081wPwYAIqZykpVc0/8nLBGN8asudJy/yjFks07DsY7QlEAK5LjFgTABkAAxKoohABcSmj513Tm 2050823kMwj+yamUNE48x8Y7uFHgCeuh9lAIvXj4wMAZiMnT2P9o6jICLkNr9jdvoNAxiWACCh5T/V 20508378OOYskQAHRHT0IU/xrwB4KYm3nnOI7dsm+R/lf/AnABwND1nUC5bMJ1HQGA2/CYdotiSZlI 205084eM/s9nq9PgtEKJtGExFpzNx3IGAL4gcQBzCw5XoeQIaz9wt/AFR4+5g8QPOiAAAAAElFTkSu 205085QmCC'! ! 205086 205087!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205088smallFindIcon 205089 "Private - Generated method" 205090 ^ Icons 205091 at: #'smallFind' 205092 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallFindIconContents readStream) ].! ! 205093 205094!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205095smallFindIconContents 205096 "Private - Method generated with the content of the file /home/dgd/smallFind.png" 205097 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205098RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADIUlEQVR4nHWTXUybZRTHf8/zvOVted+2g20d 205099HyV0H7iNKoMQYjKH06BeYMZ0yW6MMUanWZZl3hgJ6hKN8cZ4R8zUeMPVxqZibJaiDk3N4iKR 2051006RrF+MGoVoLCaKFQSj/e9/GCQWLUk/wvzzn/nP/vCP67RE/fiVBJy0YhVFjjNCJkWGgdRlPj 205101ot+4Gnv3KoAB0H3kmcNCyMcQIlpftzWyvWbLjkDANoJ+P/5gEL9l4fdb2LZFavomQ8OXLaAH 205102wDh05NlD1T7v5/1nnpLhyG7KWrFadMivuRSKLhVXr8vRLLjQ+0A9Qxcut29YlUjRsjPSKJt2 2051037yVfEhRKLlqDaQjsakXAt66gZRCoVgSDQXw+s/a+3lN1AFKiq0PbavAogeVV2KbE8iosn2Il 205104M0NidJjxRAynsIjfpyg70Byuw5FOFEC6iGU0WKbCVyXxmZJyfonXB55mfPQMHdEUzduucenc 205105cUaG3sRraJqb6tBKRzeOmF1ZLeCtEiAk2tU81/8kL776MMuhEzj4MIHHD6aZ+Pg1Xn5pgAN3 2051069yC1WHeAq7OrqwU8SmIagtjIRY4dC5MLncTBt5lrtrydrwuPkk59QqmwhIbbAww9t5DNYSjw 205107GILkjevcdfAhXDz/AKNUqpDJFWnr7mF+Ng3QCiD9a97f5m5lXdd1MaSgUl5Debz/IiuzuLJO 205108mBnAUAKPYdTc03e6Qcbjg0XXdWf+mltASUHbgXZ+n/wK0JvNi0t5Pk18h1KS6esJOjs7CTeE 205109EKLYKm+Te3Pmz3mEgEeOHuWdt8aoL8eYncsQuzLBe+fHWM6vcXZlhCcyaWzbJtwQQmoZVQDN 205110d3Tee+e+XR37WyJYlsWelg7OPv8CkR23kB6TptoCkeIox5Vm1+EtDH14nsk5m+VC5QsJoKWY 205111mpmd37Tc1dXF8KUECykv375/kYkPPuLHSQ/3f5bm59A++nsjTI1fyJTKnrcNAIX48to339O6 205112dyeZbI5fp//gl+k0qfSsUy7X/gQ6mc2SrNq650Z737n9r5xqG3B0YWwiPpgTG1u7+06eBvdB 205113NFMgk+Am7Yr5Qzw+WPyflwfgb70YMA7AGG7WAAAAAElFTkSuQmCC'! ! 205114 205115!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 20:58'! 205116smallFontsIcon 205117 "Private - Generated method" 205118 ^ Icons 205119 at: #'smallFonts' 205120 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallFontsIconContents readStream) ].! ! 205121 205122!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 21:02'! 205123smallFontsIconContents 205124 "Private - Method generated with the content of the file /home/dgd/smallFonts.png" 205125 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205126RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABw0lEQVR4nNWRP0xTURTGv3vP+8Pro9CqQ1Pw 20512734tplIGYgIZASZogFWpinEy0mGCJiX+Cg4uM3R1MHNwMMwMrcRAGFhwaEjVRQTSS1DQMbaWN 2051280tf77r0OakUWWDnJGb58J79zvhzg0BftFuPj03an5/XHI6erpdK6OAiA7xYVXZ8KtXW+Vu3W 20512944Ne8B+AOM8BgON2TOz10ulbbipzP7YX0IqQzNxJCOEnORlHiYx4JBpb3Sp+WgOAgbHJR4Lo 2051302U6j1nPy3MUnXV7vZScRn69sbMjWFqnFvWr52wspmrMA4IQjd/96vt94U1xfzRaW5nIqCOYs 20513127kSqltT/yLk85wxlmqPHiuRZS0C0Kbjjnh9yRMAEA5HKt2J/pnBzO1lTubV33HJawGGCsUx 205132KcR3JnFzp1YdFU3/LQOzouHYNABIKWY58esfVhYegOnnAKC15gBgAIBSavLr58LDrS8f3wHA 205133hdHsiAn7le123AAwo5TcNsgwvd7hs8ToGgAwzttSqbxBA+mJrNbqkuse6S5tvl8AgONnzueC 205134ps8CIcqxUz3Jxo/6U61UFyPq+1krvwyk8Bnnoer22iYAMADmn97v5fY+M4exfgFP/5Zri/7V 205135SwAAAABJRU5ErkJggg=='! ! 205136 205137!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205138smallForwardIcon 205139 "Private - Generated method" 205140 ^ Icons 205141 at: #'smallForward' 205142 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallForwardIconContents readStream) ].! ! 205143 205144!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:34'! 205145smallForwardIconContents 205146 "Private - Method generated with the content of the file /home/dgd/smallForward.png" 205147 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205148RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABr0lEQVQ4jb3ST0uUcRTF8c/jPDPqlKORiqSt 205149JqSNRfM0LlqElkRtItAIa9HWF9DKXkCbIAQhIohoURQFtQ2iYDYZkpAEUS1CamOBjppmOvNr 205150MZRUi/5And2F+z33cO/ln6tXt6KBv4N365SYkwgKbivq+LElAnv1YUjQLrIkWEAdBrVkthnt 205151YfwFMx/nRM6YdGXDomifxIrBzcFwLjiaDQ5mgr500J8OxvIhE46FsfV7IR7vDopRkLjsuFQt 205152QeKiVDTSUhpyMtOvS6u02IJlT7z0yLRVaw7YZacu1x/eND9aYq161ycnIokJjalepSPqpW3X 205153ql7arLL3yj+tpV2z2TvPODcN52ORipUKryasVta9DlWiOuI0cYaGJjry3wxmlcnHtSJoigVv 205154wbs1mpdRJVQIYWNsNkeujdVl3jzn0nzNK3Y2kjiNq9/lbEixNaYjxUgjqSWyLSx+oJTl2mJZ 2051551YApk7UzJgqCHeo0qKqIfBZ0ilxwagv750ilub+JW/OLgkOeevzrR0pM6Y2CG7lguD5IzEgU 205156fg1+VcFhiRWJIPHAHm2/D2+kyEv0/Dn4v/QF8kyGaRoL4uEAAAAASUVORK5CYII='! ! 205157 205158!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205159smallFullScreenIcon 205160 "Private - Generated method" 205161 ^ Icons 205162 at: #'smallFullScreen' 205163 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallFullScreenIconContents readStream) ].! ! 205164 205165!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205166smallFullScreenIconContents 205167 "Private - Method generated with the content of the file /home/dgd/smallFullScreen.png" 205168 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205169RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADIklEQVR4nH2TTWhcVRzFz//e++7Me+1MxkxS 2051700jR0nJZSbI0am07c2OomI7HrilB0GVy5kJDtZJNVEHQTcONKF2otlGmUEhoQSUtClTAWalJp 205171Pmtik/l47828efM+/m6yiFA8cDaHw1n84BAAMDNNTU2ZWutjWmsrCALDNE3HNM3q+Ph4gP8R 205172TU9P90oprwHIARBHHBJRi5nrQog9rfVap9N5OjEx0fzPwMzMTG6nuvVp+dmPH/fnTiad9ebO 205173Bxc++uVIJwbgMbMNYJ+INpj5t8nJyS0iYjk6OnpybXf12vbQ6mU+7xvVf+rd/UFuP22mIyIC 205174AAagiShFRD1E1EtEpxcXF7PFYrEq4ji2rIRFkR3B3nBx7t08/dS4ddULvB4AJwD0AegCoABI 205175Zu6N4/jNOI4vM/NZRURGvuesnX80uOqppvXEezLgd1hpqWMAICIJ4DgzHwNgA3CJKH2YaUVE 205176YcJIBO+9+v5TIQQeri+5sd9OLMz9MAgiYZkWeW2/menudc9deH03ne5yD9n4YRiGKgzDkIg6 205177RGQws3Xp5YKz8uDeqTvz91PKMAAAraaLysoy5m5/f/Hu7Tsbr7w2sjmQO+MqpTxFRB0hhB/H 205178sRRCSAAwrWRi6VkVXzeycCKB00kTQ6cK+OSzM+LDG5v57779Jr8wd9MYLFwtKwCNKIr2AdSZ 205179uYuIglS6S246LsJAISUktpvAhkO4K9O4nu7D8PAw7IbTr5RqKc/zqpZl7QA4OKSuojDg4ypE 205180MRWhS0vUgwjL+y10AFTaBoa0xt+7e3YGmQNRKpXazLzGzAfM/JiZ9xzb9nuojazyICMbL8kW 205181BlM+BgwbGdmElBLr61vPZ2dn6woAMpnMSq1WSwohiswc1WqNR1lCIYyqiEmCmZBLCJyQIZIc 205182od1qot5w/wDAEgDK5XI8Pz+/OTY29lgI4Wid6Cz9eq9QvPK2UtyAZBeafJjko08aqCwt88KD 205183Sqlet/+iFz2sVCqpPysPz9vV7a9G3iqMvDF8SXZnMxBSI/Da+PLzL36/+fP9dwDYLxw4qouA 205184drK4EofIsYBBgPLauHXgYQcA/gWOnHIlydMKjQAAAABJRU5ErkJggg=='! ! 205185 205186!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205187smallHelpIcon 205188 "Private - Generated method" 205189 ^ Icons 205190 at: #'smallHelp' 205191 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallHelpIconContents readStream) ].! ! 205192 205193!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:43'! 205194smallHelpIconContents 205195 "Private - Method generated with the content of the file /home/dgd/smallHelp.png" 205196 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205197RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADJklEQVQ4jY2TbUxbdRTGn/+90K7ry9oyIEUs 205198ShVYOwgDKcrkLcHQZWZB3IzGBdnmFpeYoOI3jdHMGN3itsQR6Fg2TWbC0C0Qh+JMeJ0RQUow 205199XUlG6cJW6izhQgfclvbee/zEB11N9vv8O09OzsnDIzmpAEoBZANIAFj/Hw8MAKaaYSQ1chBH 205200qOQSFvOg8n8Gkw0AphGnfiYGJ2jjCIBfHgqgj8FNhtDFGK6O3sPTfav2JuvYX0+1J0xsUzqH 205201CD7SiauZuvjblxv0IwoPkjlJrPpqbZH/ZAh0rARFB3+1PdAV73/vm8s9tsDgTVba9Co462Po 205202Ds1hobUZfX0/qn135p+74Q1ZKzKiAq9wOw471S8DAL7djxOvvd4YlCSJxsen6UD5C3TJUUdf 205203l+2lw3sbaRNFUejFfa6wcfuWWgC4edxwhp88hnfO3Ctscl+4kuvzzcHrnZGv9PeEe8KB0I2V 205204UCiWwq+YzSa9w2FPYYzBbi/UjgwP7br2UkxUGM1wRMhNqEza9fUYgsH76OzsGAgEbj++srKU 205205LwiLRR7PeEFb27mrgiAAAMymdKyJYq6kIIdXJA/2PcG5v8h/Rukod1Edn0Fq9dbvk3zrg8HB 205206wTUioqmpW1RU4khU5sAyetzwJTd3l4+27nSy+p3FaJQ1YAxV/xk+4IDq04vu81pRjGJ+PgRh 205207ScDne7Y1MGK/cwuKHFieuwNTfSX+4GOoqakyOJ3OH9LS0hoYY54aaLoHkIV3F2W4nq3G0PAA 2052080reblyWOv/58R6QbALKOQK+cLqqgrq7viIiot7eXWlpaFIvFQjMpT1LijfdJ6OwityafLJyO 205209amurT2+uxwNY9avi0bHEg/KMTKtau3UbHA47XK49LBhcQFZdNWAwYvLUeXgjSxjeIsZmZ/31 205210AKTNAPx2CHKBeeNW+5A/r//nn4zhcITz+WYhywztJ8/COvonxsRlXFBHxDgpu2RZvv+vK40f 205211RfXkUbwCAIXFtuYCh82bbc1a1hl1kiZVI2k5laTX664BMCctk+cQ0pVUfAhClBj+5gADCH6F 205212g1LmxnUAawAoaR2TMfYmsifewu5Hcf8BgHpju8aEKUAAAAAASUVORK5CYII='! ! 205213 205214!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/7/2004 13:43'! 205215smallHomeIcon 205216 "Private - Generated method" 205217 ^ Icons 205218 at: #'smallHome' 205219 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallHomeIconContents readStream) ].! ! 205220 205221!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:33'! 205222smallHomeIconContents 205223 "Private - Method generated with the content of the file /home/dgd/smallHome.png" 205224 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205225RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADD0lEQVQ4jXWT22ubBRiHn+/UHEiWZk3S1m/t 2052262jVtl6Wx29DMA4LTgbsQN8ThgXohDkEU9C/wRvGmN4oXXqqImzhExTPTC7vpaEVHsyahWddk 205227Tdo0TWPymWT5knwHb4zgxOfqfXlfnqvfT+A2ojCrgL+3m2AJ0LChZkHtEGgXwOzdhd4wA3f6 205228XPJbpx8MHm+0THJbLSZH3BgmFMo6g/193CzpNAyhls39eWwZMv8IjkDQ41FS9x/1BCTZJrfZ 205229JjLhAmyyhQ6PnehnJORidcfJ7EyIN+avZs+lq2HAkgCGBc6/9px6JD4rk17XOXvaz/SYQmJV 20523059RDXqoVk5Luxedzk0xXid8V8qcvFW+UICFFYfTk9N53jXpd+GqhTkCGeqnDz782mRwQUW4Z 205231FDU3R+/ZR625gX/AZOqASjpTjV0r6+/IIjzVyuvC9UyLBlDZMLgJlIBiAga8Ls68PsZPV9Z5 205232da6Ibnv44uIu9x0bCidT1TFxyOGYG2y36QoCByWJoCiiA3cDB2yIHFf5ZanIS3NVBNvEhYbW 205233rHJvPITDpZySPKb5dNK29z961o80rVAJinQUmT8EB1XJialKPD+n41M0wAZgSHWyUfDQbHYH 205234ZQUe7sL8s08GX/loMUYkruITN3g8/BkZLcJoeBxFsjEsC9MwkSWbtmHw4ccr3NINl/wbdGfh 205235xra+H8t9kHafiveOMNbeLYxugHJH5YMnPidgS6gvRnnkmRnen/+BxErlAQu2xL9zlM0V+5ia 205236nkSWZVYyO5h7InSkANl8m0OykxGHg+HD41RaDr6+kFpehsvXYF3uCTKZOk4jjbc/ysRoBMtl 205237YEkF8slNfKJAodPm8ISb36+sYVn2l70EiwAGXH/v7cvna+kFpoYX0XYXMBUnDqfNbmoHCQFd 205238sPHuMUksZQG+7wkkgDKYW6b9aWkx/+Olb5PxWMwX2jfuw7LaJM5l8DRMygMyBaPDN5+km7LW 205239fjkH1r/K1OMMSKvwgjrqezMcDfRnUxU289q2adlLNly04LskrP2njbcTA78IUQPWkrD9f39/ 205240AVvbS1v83SMwAAAAAElFTkSuQmCC'! ! 205241 205242!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205243smallInspectItIcon 205244 "Private - Generated method" 205245 ^ Icons 205246 at: #'smallInspectIt' 205247 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallInspectItIconContents readStream) ].! ! 205248 205249!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205250smallInspectItIconContents 205251 "Private - Method generated with the content of the file /home/dgd/smallInspectIt.png" 205252 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205253RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACX0lEQVR4nKWST08TURTFT2f6nyntlJbWAq2h 205254BYxUSAoblBg0rsTECiEkfgANSgyuXejaj2CMicaFhhhdINGYKAYQYjUYTG1EBIZph1JaSodO 205255W9uZqSvISAYT41299847v3fuzQP+szQHD3wNtf2+o9Yhu03frNUSBp6vrJZF6cnUNPtCDaBV 205256rG2dQef9sZFQX9/p5oLB6lmRqwa+xDMdk5OxS5IoR1bZ7eF4vJhQS0C1+unx188H+yr0ufdr 2052575LBBeYkqzZXq+YehkbFX62+mmB4A4p5GAgBNG++8fBo+L3kGp1lywHww5qZA10wu6G03wnnv 205258x4VkY3JTmNjTCADobHd2N3rdCY64YFHrsyLJBJu1GCVrx/LxFnuvUiMAWNpa6LqCxsuqmQFA 205259KPzSAcDiRqPJ5TI7AeiUAKfnCAVJY5IOA2R3BCMAVGQ9HLRZC8CqBKzMRzi+prrmUDOn0rwp 2052609oN1AUDAniww8VwKQPqPGURjmSW5lAlZq9Hd/b5FiYgtJ+xvZ7/6RVEm9ZDELvMXOs7ll5QP 205261kACQ48vR+chGz/WBYluy4E7PLPJNc5+WfCyXpiVJJkx6qXzv2ShVM/7ZzpxsIKKxbEQoivF9 205262AICdrUwpOheJnxnqSXV1eLitOqpYDjhyhXDw2+5F7yxtybnNuHqC6KV4K6MznF1niu+EUjl1 2052638CvbAs22260BOuRxU26djtRv7xQTCS4fJQnNsYkHV05RmTRZZRYrg4/XuZ+s0H7Y4PfSEYq9 205264sdVPP/o+c3NXmr8s3r3VnQoG611/A6iW02kaDff7P/iaaq/9s1mtfgOeOPMUwSrvxgAAAABJ 205265RU5ErkJggg=='! ! 205266 205267!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205268smallJumpIcon 205269 "Private - Generated method" 205270 ^ Icons 205271 at: #'smallJump' 205272 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallJumpIconContents readStream) ].! ! 205273 205274!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:34'! 205275smallJumpIconContents 205276 "Private - Method generated with the content of the file /home/dgd/smallJump.png" 205277 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205278RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABdklEQVQ4jcWSPUuCcRTFf/d51LSIgmfphSBo 205279iobCBx16oSUaApemgqCGQGhq6wNEn6ChrakIWlskiKgpqCdqqKkXSlJCibA3M/U2aFZaEDR4 205280xv8593DP/R+oNuRXxqYDxS6qHBzO/2Zg4xeXLJPV7jLlgSphHA6/Pptlw8MCO572RmtsYda0 205281Jnq49L8h6UclmmkVmKaFPeI/bRPEkiC3xlzT82p+W1/1TRd1Q306qjwNKEuo2KjYxAhifYwZ 205282JYMsIbxm3dT8nG9cBsmRZ41dXsiAYUIA6BWAZrKEKgwMIUBn/dOke4gkKby4aaC2QD4kAdBu 205283/dQW4fp+KDG8eOhiBh81XJMAVbiLFXitTF7aIK/sc5KqW8lskSBVHM7DxQE83hX8nS/ail9o 205284Iyo5wufRM/dzX6NJ+h6ujiGVKPC7IBEA4riY5YYXKO+BzbAIESwR7VdoAe5BjgROFSCnMILD 205285Zil1RSgbv9TLOg/a8f0+Pxfp31WuPt4BdGiFIfxoncEAAAAASUVORK5CYII='! ! 205286 205287!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'! 205288smallJustifiedIcon 205289 "Private - Generated method" 205290 ^ Icons 205291 at: #'smallJustified' 205292 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallJustifiedIconContents readStream) ].! ! 205293 205294!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'! 205295smallJustifiedIconContents 205296 "Private - Method generated with the content of the file /home/dgd/smallJustified.png" 205297 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205298RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADOUlEQVR4nG2T22ubdQCGn9+XL8cmbdLm2BzX 205299Ve2Wbc5DFVmG4s3m2DoPqyC7cQg7XIgIgiBexCu98A9Q0QuZV1YEN9wEHegcKzoZmrUWNUkz 20530026RJviZp2ibN8ft50dWrvVfv5cvD8wruk6em37Sa2+1gT9FDik5QlzIkFIJSEhQIv0R+fuPS 205301x58ACIDDJ86/JIV82Wa2xMd3hyI+t8vhsA9gt9ux2QexWm3YbFYsFitKb5133/9o4+dHA06S 205302SV1NnDz7pMmofvXe2+cZDY+x2ZY02zqNlk6nq9PTJT1d0uhLSmtNXji0n6FBuyNxqxS7AVlV 205303kSIYDHjwh3ejrW2xWqlSqVapVKpUqzVqtRrtdgsQ2B1DHJ08TTTkZ20jHQeyKgird8RFp7XF 205304zMyXuJxOXMPD+L0jTDz4AENOJ6rRRL8vqdRqdDt9YuEAdxb+iQOXVV1S7/X7+IYdvHHhDGv1 205305dYqlVYpljfm5P9C0ChuNBooQ+DzD7I8cIRYOIGEvgCoEtUazhdkk+PSLr2k0tvB53Xg9biYf 2053062YfX6ybgHsRhNdDtdhAIoiE/SBEHUBGy1mxuYTQoXHh1GimhUquTXylT1kr8OT9HvqjRarUx 205307m428eOwZouEAwATJpKKaFLVUqdUxKHDl+5/49fYcLucQkaCXSNDHw3smGfV7sFrMAPT6fVSD 205308AavFbEvcKsW2PZg6V7988cPBgYEBAAyKQAgoaVUyuWUyuTzZu3nWN5vse2iMM68c5+xbH7CQ 205309zk2p92zKFkqrB3dFTFycuUru3wLtbhe/Z4SxWJADe8d5/rmncdht/9saC/n5K70YVwF0yOZX 205310tIMT41GeTTxGePQYJpMRXddZKpTJ5vL89vsCi0sFWu0Or782jc87AlLs2V4gyBaKGkIIMrk8 205311V67NslwoI6UkPOplLBrk0BMHOH3qKCaTkcKKxsLfiwAtFQAps4XiKgAOu42pIwlCAR/dbpfM 2053123QLpxSW+/eEm6Xs8Wq32soSbZoP6zvYCg/rjL7fne998d12tr29y9dos6dwyhRWtqetyDkQK 205313ZAr0VM+i35m99Fl1h4XYKYdPnjslJCekJAciJaRMXX88kCGZ1O93+Z38B+86X+e9hfCwAAAA 205314AElFTkSuQmCC'! ! 205315 205316!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205317smallLanguageIcon 205318 "Private - Generated method" 205319 ^ Icons 205320 at: #'smallLanguage' 205321 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallLanguageIconContents readStream) ].! ! 205322 205323!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205324smallLanguageIconContents 205325 "Private - Method generated with the content of the file /home/dgd/smallLanguage.png" 205326 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205327RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABlElEQVR4nMWRv0sbARTHP+bulOCQwaQnauoF 205328rYGiDpa2Wtupg7q5Fsng/+CmODqUigouDuLg4L/goCBxiFkEtRXj0CVNuWhE6cn9MOZeB1NI 205329S07qlC+84T34fHnf96DRaqozawE+Aa8ikchLTdOaS6XSN+AY2ASsxwxTuq7/XFz8LPn8d/F9 205330V0Q8Mc28rK+vSSJh3AAzgXBvb49/eVkQEa9u2faNDA+/FWCu3tr24WE2EP5TppkXTdMEeA6g 205331Vg3eGUZ3uF9R+PVlCTXehZowqBQvENtG6ezAy2RRYlHaPrxndHSEvb30R2AjVDVwXNflLneO 2053321vcCpV2n+c1rymc5lK5OvEwWymWaWlupFAo4jgvg1EZQAHN3Z1tEPPHvbh9Wrjh/974r52cn 205333EgqFHKDt3zsM6fqz61zua2D+YvGHJJN9LjAe9AkjHA5nVleXxbKuxPddsawrOTjYl/n52fto 205334NLoF9AfBAKiqmj09PZJ0elcGBwcqwA4wCUQeBauKT0yM+anUlAesAPH/gWo1DSwAsaeCjdNv 205335pz0BrfQjq7kAAAAASUVORK5CYII='! ! 205336 205337!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'! 205338smallLeftFlushIcon 205339 "Private - Generated method" 205340 ^ Icons 205341 at: #'smallLeftFlush' 205342 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallLeftFlushIconContents readStream) ].! ! 205343 205344!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'! 205345smallLeftFlushIconContents 205346 "Private - Method generated with the content of the file /home/dgd/smallLeftFlush.png" 205347 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205348RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADHklEQVR4nHXSz2vbdRzH8ecn+TY/vvk2+Tam 205349sWmaJevqSjUtqDu4Yes6BanSjs5dxthJ2SaIBxF22cGd/Bd0DkRQL+Jg9rAqYqUbKMIc6cLK 205350RpPWNU2z/E7zw+bX5+MhsovzdXtfHofX+yV4Sl6eP6+7lAhKTQQtkqCCoFAElUUGUZaAQn11 205351+4fPrwJoADMLF89K1Kl+3TkxNhoK+bym4e7XMQw3TpeBrjtx6Tq604FsVbn86WfPA18ASnv1 2053525MVF3en4+sql9/EFDlDflzSaknpT0mpLOlLRkYpqV7FbrLN4bBKP2zBn5t+LrC5d29RQ6uBo 205353eBiPP0Sp2qJYrpDPFygUChSKJUrFIo1GHRDoLoMTU2cIjwwRq9aiwKaGEE6/b4B8Lst315cw 205354TROv14vX6+VgOITHHMDucCIldKTCqvURCQVYu78RBZY0IdUewHORYT7+8DxdKSmXq+SLJex2 205355B4MDBlKBVAqPruFz9xEeGUIpEe2VKCjtN1s4bRZu/rxCbG0dj8eNd8DkhYlxXA4rLrsFt27F 205356ahEAhEMBhJA9QClRbrba2DTBqbdmWZybpbHfZGc3Sz6fZ2XlF9K7WRCCSx+c6wEjQ4AYP378 205357E00TVrKVSg3NKvj2+jLx9Q0cdjuhYT+hYT+TE4eYO/EKPq/5ZCd+3wAOh93eVukxjWZzM/04 205358h0UIzp2eA8BqEQjxtIn1IoQgHHyWB8lHUe3WzS9z0wsXatVa3VAK/ow/YHsnw6PUY8p7Vd55 205359e5ajRyb/g4RDAR4mtqNa71TJdCY3ZbP10aj/zYvRwyy8OYPpNqjW6ty995DEXykSmylyxTLv 205360nlkgGBhECfkvIERyJ5Ofen36CIXSHvH1JDeWb1GqVPH0uxiNBBmLjPDa0ZcYfMak3e5wY3kV 205361ENYeoEimMzm6XUkqneXwoQPMvXEM021QKFXY2EyR2Nrhp1//ILGVYnsnIztdeU8qeVkDUELc 205362Xv3t7kfjY2GcDhu/34nzzfc/srGVolyp7gFrCmICEcNCrNGV8TtLVxsAT7qenr9wBcFJAUmJ 205363iglFTCBjq0vXtgD1fx/5B+BjSYe2EELYAAAAAElFTkSuQmCC'! ! 205364 205365!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/22/2004 19:35'! 205366smallLoadProjectIcon 205367 "Private - Generated method" 205368 ^ Icons 205369 at: #'smallLoadProject' 205370 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallLoadProjectIconContents readStream) ].! ! 205371 205372!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:32'! 205373smallLoadProjectIconContents 205374 "Private - Method generated with the content of the file /home/dgd/smallLoadProject.png" 205375 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205376RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADA0lEQVQ4jY2SW0zbZRjGf9+/358eKIUW6AE7 205377SlvcxiImc8PIlnmKkmAyt5ktWaYx8cAu1At3ockWZ2I27iDemHjjMTEsgnE6ncQsJrhMM2RM 205378kQnLQKRoS4GW0lJKD/T/eWe8EOJ7++b3vHne5xH8j2l56MjjhmF6QkBIYYwZQl2YunpxEsC0 205379JXnsmOke966+XU3Os/aO4w3r7SeahMvrZ+7O87X+7So5Nzm8pcBO1843nzpQ9/K7r3jNDTua 205380Xc/UjFf9WH/QW7r/iKN889vttf7wLW0LXjjsFafOnqgXCUuA8nKaVtsM+8wR0M0m/fgZuzC0 205381V+Wm1x8+HPDVWUV8zU2hsooLyd2YSgYRw0l7dYxFm9t7S4jWTQVM6InpeDH1UzbgOOoaw+w8 205382wBvZw/zQ8g5kkqTWFB0Wrbiphd+GBrLlYjFyfvKu+cvxe/l51c16WZIvCC7F7+N0v1peXS/1 205383b/UDBMaLhc96ymfGGmMFw0RX7QhmY5We79KR769P/1m2r3eLrr10un3B3lp/yOkNNEtzZaWm 20538461JomgCBSC8l1ODlQUatj2Y8TmtFKbfmmM1MDUdDE/VMr+2XUuqd574cbREqDarAYux3ZkY+ 205385wtCqaXvkKLl8lmvRiJqc/XRgWtpkydZxkj23r9IVaOXQRKes99/dmFqJk1gpgTKwCI1CbgV7 205386jRldK/LYh29x4+mUoDF4snRlKc9zA130VgU0iwsDhHR5/N50ZpmNsg9QFFWUBw+dQlAklVnC 2053877HWit4cpsQHNixY+dxYIaTL8l5cpjT9kPpvJBX02ssk73P7gEpVtYYQnxLMfv41UGsFcgbkF 205388Mw2eMCPBLL7dbumPVDHR/fV17PwqkwuRGIZivG+QB3q+YnjvNrb1v8R8fIk2TxNWn5XZ3pny 205389L/tmTcb54aEo9EcVCzj4hiHyMp2Yj61mNmh74SA33DUE9+xAaE6uvNYNqgBaNXXj76Wvnbt4 205390GsEnjJL7d9RSCfpef3J/SJXLJqXUPwtNSqHrZk1WWEQuu/IFN3n/v7ryN/fUMc5/02mQAAAA 205391AElFTkSuQmCC'! ! 205392 205393!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205394smallNewIcon 205395 "Private - Generated method" 205396 ^ Icons 205397 at: #'smallNew' 205398 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallNewIconContents readStream) ].! ! 205399 205400!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205401smallNewIconContents 205402 "Private - Method generated with the content of the file /home/dgd/smallNew.png" 205403 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205404RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACb0lEQVR4nI2RzWsUaRCHn3r7ne6e7p5MPjTu 205405mMRE8bIOe9iFsKwiePAgQcGFBW+aYy7e/APyXwQPe9uL5CJIbnszgrCw7IQISr7Nl05kY9Rm 205406ZpJ53/LQKIgfWJeqQz1Vv1+V8I24dH2y98iVhowJhsXrsBcdBjmuav569GDmMYAtGqfGvNM/ 205407EH6Kk2j05OCxU0kS1yppEvdkKZVKRpYlVLKUl81X3Lv/98/ABQD57erUkBVduHljov/X8XHS 205408ai/tQ8g7nrztyDuOI6c4p3Q9XK5H/H7rTuvhL7WM6WlvrLizfb2V/omJK7hSD/u5J+84nPNY 205409K1TigJ5yQDW1VJOAUlSmr1opn/9v53RhQSQ7MTiAKqRxgPeKU3Be8b7IH+quV7pOGRup8Xox 205410rwMrRpUDAZLQUA4N5ciQhIY0MiRRkbM4II0NQ/0hWRwwOlJD8fVCgdVm3moTlQxOQb3iFbwW 205411W70qcWioJpbQCgBjIzWAc8WAQ7uX5y1KgRBZQVUKWAVrhCQy2EA+ee/o8A8AdQAzPzfz+s3b 205412vCOilKxQskJoTXG8JPgMBhg7VQP4kelpYwA96naf/79/gDWCDYQ4NJTs5+CHGOirkibl+NK/ 205413zTMGQGF9e7dJYArZ5uvsJyqcuroBEJWN7Rd7iIB8BwwwUhsEtBighvXt3VffR1J85uBtjogJ 205414LYBR1nde7H2xud3usLKxw/LaJkurmyyvbbG6sU27c9gQCf60AD5w/yw+W+0uPl2x7/IWK+tb 205415LK1usby2ydZOs6WqT0AXvNAQrw31dmF+7u4+wEfHF69NTSJ6G9hFpCHogvHaOB7vL83Ozrqv 2054162XkPgdkFGpcRD6AAAAAASUVORK5CYII='! ! 205417 205418!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205419smallObjectCatalogIcon 205420 "Private - Generated method" 205421 ^ Icons 205422 at: #'smallObjectCatalog' 205423 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallObjectCatalogIconContents readStream) ].! ! 205424 205425!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205426smallObjectCatalogIconContents 205427 "Private - Method generated with the content of the file /home/dgd/smallObjectCatalog.png" 205428 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205429RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAB9UlEQVR4nGNgIAxYGBgYuIlQhx2YqrNFR7hx 205430bcAlz4xHL6OiDKuZkQZbUUMynyM/N6MTEyNj0IMXf1cQZbOICINkuAvXpR+HpP//Py7z/9Q8 205431sY9OJuye6OpYGBgYGMzDC90EBHidYIJ//zIw7Tl7unvlnu1mJhqs5xJ9uDXff/7HdPvx/8dY 205432DZCWFvVZ0JSbCxO8dOshw57YS8sYGBgu7D714+/eUz/KmJmZ5MSF/hs+fslwBcMAfGDXqZ82 205433DAwMH3HJMxEyAJ9muAvevvt0o3ry0o0wwU9ffrAzMP9F1RjKwMz7gtPCwFk2+8e/X/qnDz3Q 205434ZzjA8IcRh8EcDAwMP5AFzBtVXnOKcIs8f/jxJ6vQX+an+94Gvt/1bQuKF5zZ2ELS2LhOVLDz 205435XvZg5VjAwMAAt+A/4//Hl3bf2nfz1AOeL/e+bWNXZS5kYEBNSMzBrFwLJ3EKmrqwcgipM7No 205436nfj748ar//+vCbow8P/48t+XRZxRk+kDM9M/1n9ZXCpssh/Yvnchu0BGg4lZHsbRY2ZlE2Fg 205437cWRgYGD4+4PN6zfLHxdGDiZJxn9/bzFzMj3+cu7nKr4PaHkkio1r2zt+qf9/BWT+t3HyvRVn 205438YFBiYGBgYDBmYOWz5YjhteO0YgjFm/wZ+GxZ2Ds9WdhXq7CyWuBTSDUAANeVnXOvNaMbAAAA 205439AElFTkSuQmCC'! ! 205440 205441!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205442smallObjectsIcon 205443 "Private - Generated method" 205444 ^ Icons 205445 at: #'smallObjects' 205446 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallObjectsIconContents readStream) ].! ! 205447 205448!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205449smallObjectsIconContents 205450 "Private - Method generated with the content of the file /home/dgd/smallObjects.png" 205451 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205452RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAB/0lEQVR4nJWQXUgUURTH/zN3ZnMGbXcM+9AN 205453spaelETtQyLbsiWofAjspYwegggfpJ6KoqjH6KEEeyjDoBfFCvbBqChZiGJD7EMa66koQzPX 205454zf1o292ZuXN6aWSM2KYDl8s55///nXsuw+/wAfW1jO3LEsEGZvA/sVGSe64qgXm9YgXdVLTM 205455dubr92xeDmnrdTWQokCQnBNVl+VCjLV78YvVIsJ7JMXvLu6Uy1RNEHd5AiQEGn/LDcNdfG+b 205456dpZs/S96bUOtvGkRYIrz4cvFH09GedEiADo37bP5THzVga7pyMETDW5xS53v+Pq18i0AFU5N 205457cO56Ue5SBWzOEY3rttUDwAp3ngxJHI0kGyMjt69Rxw5lqO+M1tZ5YX6MCZT8PGu/8bImGuuq 205458hi8e0+bmHlYTxYNE8SDdOK1NhWqkFk8AAFq4SYl9uLfScgC7tyy5CwDMI6CwdF2EKoVPrYwJ 205459wkzSpi/frMLoO7NPWpA0tavgzLfIZso/MXHHiBzqbnv5YGhsIJc3++/nz3/PcL3KLx4GUOZ8 205460Iho6uqN7tzU3O3kqm2OPnr++tKay/IXAjcnHg70Jvx+r02l8dM9YeIHmL8epo/trnHzyawLP 205461XulBblM2Ntg7DQB/mgFALLW4ZSMfG7gyUUpTEkBE6VJ9wLXCbDIVbT1yLuVuZgrFp/8C/AKq 205462oMu3BdqijAAAAABJRU5ErkJggg=='! ! 205463 205464!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205465smallOkIcon 205466 "Private - Generated method" 205467 ^ Icons 205468 at: #'smallOk' 205469 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallOkIconContents readStream) ].! ! 205470 205471!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205472smallOkIconContents 205473 "Private - Method generated with the content of the file /home/dgd/smallOk.png" 205474 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205475RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACF0lEQVR4nKWSz0sUYRjHP+/7jvuOuzMbq7uZ 205476lkJESlSHLoExkAmF0K+DLBV0S5I6SKf6EzpVHrpU0LFLaZeiLh6KOXjIS5FREpUIi9oiOuOu 205477M9vMdHANEYWy5/rw+T5fvt8H/nPEdiDb0XuAPuCJsQ24E3BlWhSiStwl/xHOAS8a9xmFQr8N 2054780PTXArajDeCZblP7m89YeBMrCMQjo748DlwGXntuMLKFxn1lyd7mcxbhfMTyZDDuu+G4tB1d 205479lFqMNXY2DMhG8dh2dGGT60MoBpvPZ5CmZGGsgkDcA5DA1ZaLWZU/a5E9ZmaB4ga4D7ibO5lG 2054807zJYdCvUZqNvwMiqgKRruO8hQwduYR02MfLqeh0UtqNvAM+tIyllHdRUp0K8d0ECXPHcIAJQ 205481ut3omcl/7ZpTJeaCEjLFzjhMssBN4FrmUMrI9Wb4tRQxP+pDxLDnBg/WHCrdYewu++VTXkcZ 205482gIYmg+VPYXcSJHuz3Sa5E2mIE+afekRe8gG4EE5H0ZqAsB3djmSqbXCHVunVVmvliCSGVEFB 205483DD9f+lS/1H4AjucGM+szUuF0tKTbjRZpyqOpVoWQApWWSFMghKD8yqf6uTYL9Hhu8H1jQ6Ie 205484WKtI8TFfzOSIBYgEoQT+REhlMlyow+83ew4J4LlBKQm5tPh2JZGmQCSSxTcrVCbDEnB6K/iP 205485g3Wd96uMuB1V4yqxGAXueG7gbwUD/AavXL0SoSTm+AAAAABJRU5ErkJggg=='! ! 205486 205487!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205488smallOpenIcon 205489 "Private - Generated method" 205490 ^ Icons 205491 at: #'smallOpen' 205492 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallOpenIconContents readStream) ].! ! 205493 205494!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:06'! 205495smallOpenIconContents 205496 "Private - Method generated with the content of the file /home/dgd/smallOpen.png" 205497 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205498RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAC0klEQVQ4jaWTW0xTdwCHv3P+/9NLegWhpV3n 205499hYvchIoWcAwjRKkm6oYmW4xvY1my12U+7XG6x/mqZpkONZkgmsUlbtrFZRrxgkXxFhCNupFW 205500RBARCj2n7fFBlxhN1MRf8r1+T98P3nPK1xHqAM9chkLAyOaIHbjKzLsKZM5k78Lq6qVCSiJt 205501bdyKx3WXo/dE1kj3qGl+33WNx28SiIb5ovWHA98tWRbdzOClK0ipio7t28sDi4o3zaSmtxWL 2055020eZIAEdjiJG+BNOvCeqKzLKWaGi1i/NUNDaTSju4eWo/a9sr+fiT9WpT+9YSZ37BhsmxR98u 205503tk1GlwfJqy3i9pUHpABEJIinakX91kK/Feb+JRjexPHOozQ0+1D1u9jNIcqq/bR8/plS19b+ 205504ocVmjyZuDX4V9uX+6E8yKhpDzOUF5n9TEV4Ewo4i3di9Czi4s4vZWYUPihcgpQGz93BbR6iu 205505LyO4pM0Wj8UC8SRdoi/BVG0hHSs3rvIgrJB5QqC4lBWfbiE1I+k9cZnL5+4gLE58oQBkpymq 205506XM2RPZ3mwANHtwS4f3Owe+qpdZvb6wQzA3oSaf5HOJJPuKmDnPRzsvMXMrmHhD8qB9NAk5oF 205507MhUqQNbk2NULQyC9L5EHigR9DDV1nXVffEnf6SHQ5oFpIjSpAZoK8KSE3uOd3Y91Q4JwgXA/ 205508R3qeI5xgjFPVtIp7w49AEQihakBWBTh8mOx4MvHjoZ0/kdYFCMcLnC+ELjANGqJruH7hBiga 205509miYlKGnxfxDxBGd8U8Pjf/f8tnJu1rB6/UFc+QWgCFA0UDVUoTAxNkmobDF//XpIP3fH2Cte 205510riqe5OIyt757oH/g9smuo5mLf8byJkbHnKq04S4oQmoWPAU+UFT+OdKTPTts7FHedpaWhZYK 205511ry2z3m5TW6tqKuvLl9b4gqWl7Pt+x8jPca31rYJX5qj1azXzbNmmkafy/vCEHnsGoAD3o8FK 2055124poAAAAASUVORK5CYII='! ! 205513 205514!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205515smallPaintIcon 205516 "Private - Generated method" 205517 ^ Icons 205518 at: #'smallPaint' 205519 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallPaintIconContents readStream) ].! ! 205520 205521!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205522smallPaintIconContents 205523 "Private - Method generated with the content of the file /home/dgd/smallPaint.png" 205524 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205525RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAB60lEQVR4nJXQT0iTcRzH8ffze/5srT0zNvqr 205526KM42JTskoRJISVARCf0RCTp4KCMhELpJx4gQomNBl+jgtX8QnQorqIyg/5atpZmOlk62PXPP 2055279uCz5+kQ7bAObd/rh8+LD1+o8cJwIgzDgKi1S0Qw/Gi0wx0f3O62wAi1KG0Q6tu1/nLnnr3o 205528uh8JumoCXFmMjZze56eYxgYcyFQNNENTT7v/VKi1B4w5Vl0AFqoGBAwdP9IlIWuQX8SyS4hq 205529gV5QhMTJju6dsPwJcFk2TFyYrAr4AQd2tKzd4tkQhdQUpVVIpsylbxCvCpBgf19vM5hLkEtQ 205530tFzeTqfu/M2V/wKStNsQIV6+eMNWbN7FinxdyI3/AwyAvAbOBED9CFcfgw2gB4NqtP88iqZx 205531/d5dpiZuGrPwvAwcgnA9DM7Bg04YC4DPgM3AaBgiqrAablw6h+INkU1bzvRs9ixQKgNe8Ot/ 205532kGPfYTIGFySYAVCFGDrYHq4reSQsJcur1x+exaE8H0Dcgvef4WIaMl7YdhSeKnA4At224yS0 205533lE1jRqHekPFpmlT5IwXAgTYVGppgXStIebjWHNy0uNGr1+krwowWPL77TpKcaV2pBGSAOHxp 205534hPwvMGMQL8D8z8KKFdACqt+W1du5+YmHyUT/DDypBH4Dwguh75kYJgEAAAAASUVORK5CYII='! ! 205535 205536!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205537smallPasteIcon 205538 "Private - Generated method" 205539 ^ Icons 205540 at: #'smallPaste' 205541 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallPasteIconContents readStream) ].! ! 205542 205543!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205544smallPasteIconContents 205545 "Private - Method generated with the content of the file /home/dgd/smallPaste.png" 205546 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205547RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACpklEQVR4nHWTPWxTVxTHf/f6vuv3np/TJPaz 205548HTuJgdBEoqGoWyQEA4KBDRgYmECRYIxgR2Jh6sjEUlWt1KlrhRgqJlpEJQZEA0kAJxFfMSTg 205549b7883/c6OJiv8h+P7u937jnSEXyW+fn5g5lM5pxt29MbGxs/jl6/fkfBLgGTBu5checfv1cA 205550V8CO4BgwW33y5MzY7Oys7/u4CXGIE4fZu72GEHD7j7V7wClg7RMBgr/mznz7Q3uqyKI6guu6 205551NOrvKO8ZpyZyzEy0GC/nWfr71TRbweQXgnTePTBzssDLapu4dpNcGDJkG+IARFEQGkGjY9BT 205552JW+/nzk2vmfu7o0b14IPgpwTtbtGuo5kyulR2fS4VRmig490Clgpn1SQYXRhiLPN5uWffv5l 205553BLgEhApACiKtLXoGmoHi1uZxLl46jxGa7TAiNAAxQghy6Yhff/t9GhgGXiuAsBsZbWuCMCYO 205554FZMTExihAdCWRFsgdmZ2nSQ53y8DqY8EPaO1ImH1sIwkDgyulgPqPZyQAkdLypOlsR1Bfwet 205555t0EjmVSeshRJkyAyBlvLASwEOFoOamPFQtr2hjPd5jskQKe+XYnDGK0Ved/GmB62JbAtgZOU 205556DKfUAAYo5bMiW9w1A/QFAtZb1Q6ea1HMahr1GpaSaCVxtEQIPkmp4JNKj04BQvb3y1rrdZeR 205557b5IAxNtvUAmBpT4jd1IsZEkm3TLgvhesNzY6JGQfsKIt5P+zAAylPZR2soCrABKwWn1c63eP 205558wY3qNJpt0p4LQLPV5uHyKv8uV1hcqnD/waPq1qvVP4GugP4xxVKsFPeNjG+uNsLl4d1vChcW 205559xjzPYfHhSnP58dOVTqu+FLRr/1RfrN+ubz57BrwF2oNvXQH3NBxNwfdA6bu54wfzpb1zQAnw 205560vjbOfw2z5rrakfVdAAAAAElFTkSuQmCC'! ! 205561 205562!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205563smallPrintIcon 205564 "Private - Generated method" 205565 ^ Icons 205566 at: #'smallPrint' 205567 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallPrintIconContents readStream) ].! ! 205568 205569!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205570smallPrintIconContents 205571 "Private - Method generated with the content of the file /home/dgd/smallPrint.png" 205572 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205573RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACSklEQVR4nK2SS0iUURiGn19/RWcaL/xjVgs1 205574GoqZEhuHoSItFDFcVaDBhCGtrIUiWlEobrqtJMXLRIISgQUt0o0geNk52iKELMRAUsrFEOoo 205575+IvjnK+NTjoZtejZfJvzvuc5F9iLFfABz1NSUmZ0XX/DP3IM6HI6nWv19fUyPDwspmlKYWHh 205576JpAJJPwpGLc9z7a0tNweHBw8YBgGzc3NVFZW4na7E+x2+6LX610DavcriN+eZk5OTq2madTU 2055771ODxeDAMO4FAgNTUVG1iYlLf2NgoCwTG44Gx/YqOu1yuiN/vl4KCAgHEarVKY2OjhEIhUUpE 205578KZGioqIt4Ohv6bS0tO8NDXdEKZH5+QUZGRmVYDAoSimJRFS0oLW1TYCm2Hymz+eT2dkv0tXl 205579jy6ORJSEQqtyt6pKFuYXRCmR9vYOAV7GXmJufr4Hh8NBdnY2pmkCoGkaaysrWG02DLsdgHA4 205580DPAj1qBudHRMlBLZ3AxLf/9A1GK3TU9Pr5zKzRXgLZCx2+BIYmIiALqus76+vqd9aGiIB4+e 205581ojvc3Ot8Rd3jZ+Un8vIXgdfAuTigraKifGlubi6qaZomL7q7uf/wCcGkDPJKLmNkHgbg9PkL 205582eC+W6PG67gSSdza6brFYvlZXV0tpaalkZWVtJSVbVq/evCV949MyMP1N+sY/SVNHrxgHD5lA 205583J1AMpGu7jnISKAMswEcgBFzRNO3ameJLGavLS3z+8H4KaAcmgRkgslOwQwKQDiwDYcAGuIAb 205584gADvgClgKfYl/oYNcPDr6/8/fgJnMgqt6rM6ggAAAABJRU5ErkJggg=='! ! 205585 205586!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'! 205587smallProjectIcon 205588 "Private - Generated method" 205589 ^ Icons 205590 at: #'smallProject' 205591 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallProjectIconContents readStream) ].! ! 205592 205593!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:21'! 205594smallProjectIconContents 205595 "Private - Method generated with the content of the file /home/dgd/smallProject.png" 205596 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205597RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACrElEQVQ4jaWTS0jUYRTFf9/3/2ZGzXfTu0zK 205598KIqemJC9oEiiBxUu3FQEvSmKQmjXokVtgigKolpEGSFFC6mkIgtLeroojB6YadiYOTrjTNbf 205599+c98t8UYEbTrwtncyz33nAMX/rMUwNZ5lBhNuVgKlUILKASNRilBWdBKUL9nkt4L+1wumV2l 205600LDSBrIeTZy80o4qmkFM4gpz8AvwZAYzfYBEcR+P3BdDaIKKIhrtpqD1PqK2lwFgoq9hUbdbu 205601PAASB/GGkATrUXftItHeLjZv3/unLwWMGH+CE3tWBA1QVDK3jFM19WRlBkAsAz9cKuYX8PZp 205602HbmpZmYX93D6yEtSOaXs37cZrEdmViYARgn+7Nw8MjKSVK1cDsDrDx38THzEMZrRWREmjrQM 205603L8ylasdGsAmQJMYJAKABn2M0iPyVrlYp1lVWceORovb5NDp7hFAoNGQjgTE2rUAURjvQ/iXE 2056041Vt3AaG7t5/KJXkgHsvWbmFR+SwQD7EeHV0hJo7MR+v0IYNlwP0e4+ju+SBJWt+38aTmAe3O 205605WErGlLOofCZ1L5qobW2isz9GIuByfeU2MnwThiwoIrFIL4jHl45Onm84zMYLDyk7dIXL1efA 205606Jvj4NcSnr984tmANk5L5nHx0D2Wy/xDEe9METTcaWN83iAKCKKTlM4hHNBznW3+Urr4+Hr9r 205607pb7nDclk2oMWSyQaDoNNsHprBWemDeezstzLNeSvmkkq6XKxsRGMEMwOsG7qDKqLFxOL/Uhn 205608oDWRSE836DyGZQ5ysP4wjfXNTJ8zmXHjgiAubWePo62LYpClM4rABLlz8ykIcWMVoWe3a3AH 2056094niDP3EHYijt0PLsFY7x/RtOO833r6MVDQpQ20up0kKJgB+FI4KjwbGglUIjpBBSKCxCSilS 205610Ak3nmrn7v9/ML585JOJNwHhVAAAAAElFTkSuQmCC'! ! 205611 205612!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205613smallPublishIcon 205614 "Private - Generated method" 205615 ^ Icons 205616 at: #'smallPublish' 205617 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallPublishIconContents readStream) ].! ! 205618 205619!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:26'! 205620smallPublishIconContents 205621 "Private - Method generated with the content of the file /home/dgd/smallPublish.png" 205622 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205623RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADG0lEQVQ4jY2Sb2jUdQDGP9/fn7vN29+7tv2c 205624t5tenulsUd1miWlEFCjZzRdRVPiiEnohBBaLIiRIg9heDAuiFwVJONgcWrBilajlKlKU5cEa 205625zrlluzvnbfd/9/f3/fYiKgoOel4/z4cHnkfwP7Tl4X2PSanvEeBXyCkp1PC1705NA4h/Obfi 205626oMU8R6fLQzi5H/9Tl+6+rT7b3Nn4RK63Lxap73LZ878sVc6NNqhycWjmwtgx/e9wkG4cvM2T 205627vr5nB171zPiSL3gmbgeeeyjwzIcHLWf7XRvdzzddrf+hZa9V3ravwb48scnjvTOsE8R0Pej5 205628eus7oYH0675guUcn7IzTGLDE8tpE99D6dmFaXUTjgu1101wvdjAj12rC11WSV852GMChbe89 205629/ehZbRy+SkuUlCrkMlYSNxC/RVh0P0Kdqmd4+T70smRBNrO9McLSmlYrLES3galtDnsXYSxt 205630M5TowGsexrr8MhP2zc7JHkfh8M62QGUKZ/NO3sr2MbnlA0gvk8gpHq/RShoV+X08lgS30pFU 205631iJf7eS3h52jaVyM9M0em10XHY/dwJdNK3jYoFAVfxO7njRG1ksmXRzTyjKjha1FWAEEjk2T4 205632mRt/TiRfKp4ctN+c8kWKUueA5yJOmWHwTGrh/E+zN+26/FFxoIfdjpaOY7hb3Tu6g9Lpcmmm 205633oQtNEyCEmJu/pY5fiIqcozXV1lzrKK/mGlK50qlVQxyc+3Y0ZRiGufv98amNQiVAFliKzDJ3 2056348ThSr6d3VwhTt7HuOK8Ojcbay6vZ9tl15jzjJ+2/1jdavAFfIrlEPFkCVaFGGBTzaeoaHZh6 205635BWSB2lpd/f7jaB64/t+XGu42r5XKJKnYLYCipBbZFXoFoQokUnFqTYXDIWS1mxuFbHp1g+Ui 205636uzLHrx+fxtXrR7StZ/+nQxhK0NHkYgf3qmoAbfnWQgTg6okvCQ5+TnRgDGkXiMbiWKzBUIpS 205637SaveIBWPRjKpEr0vhrjU2syG4CaE3sQ3/e+CLIDWwEdHPslVBSjBif69D/iVbetK/dNUMwxh 205638mk7NcNSI1WzydDXAH4NwUmsvAPcyAAAAAElFTkSuQmCC'! ! 205639 205640!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205641smallQuitIcon 205642 "Private - Generated method" 205643 ^ Icons 205644 at: #'smallQuit' 205645 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallQuitIconContents readStream) ].! ! 205646 205647!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205648smallQuitIconContents 205649 "Private - Method generated with the content of the file /home/dgd/smallQuit.png" 205650 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205651RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACkElEQVR4nIWSS0iUURTHf/fxfTNOPsZpzCxC 205652GWuqMSOn1yKIIIiIahPZoqiIilpFtAkiKIQ24aIWLTIICulBkG1s0SIsyB5aIkn0fmii1ZTm 205653aM5833y3jX4qBv1X9557zo9zz/8IxrR9eazIhOSVilgo6bqO1MJILQ2WzAklkFpBX8pTrR3D 205654vQgoyLNbShLdR/Q4IKOorz+7auuciCI3OsLAjzS/UmlSqWGG0g4AA20jtH/sjwAU5wcXL/Hm 205655vfcBlYvCydmzQuBmsLSiNBqgLAyy3MLJuKQGHV6+dsbT+ZUeVVnXqZXjAW1JxRQJ/2RbgrKo 205656zexIYEqG8dATACn5nzxjpsX8KimFmPaKmNLJP+onAEJNAhhwM55/zXmGxvtprFBkGsAfYmHB 205657DAFgPMPto4/oef6dDccWUb0+gpKCitICPn/xSCQSfvEMlUGchBoBl1RxaEl+vrLdPw7m5ygH 20565855dwb8Ahu0Cx7XScYL6m8a5L08s5PuBP75s2DZzZGLGTKzesw43OQvT3EmhrBWGoPbCHJzdv 205659cflQJ3svLMW2A1RVVfmAV4M9aAGlxdksv5ubMYAWYBQE1RBcPMdqren64dJ+p49AbCGJyokv 2056609HQ8Qgt4/TVDzagHxgNvbNILwxBU8GbAZSQaJLmllIdv84hNmsHDUB5awI0HDnND82auDEdV 205661MN0/TOzbMGIQtIRWW1GxfzUt3dWE42soKiqacMCy0KegCWi6eXz7s42bciv6nvbQuOMuEQte 205662WDblJ46xbPdhbDuAlBKlFHJs6dxsJuvb+OlDqqHlfigpdY2M7yumb8hhV10dM+Pxad4bz+NG 205663w/mhZx1dV6ds377Na3cWFoYPmEn78S+5bs48ft55rf1d9/W/IR3hO/1r6QwAAAAASUVORK5C 205664YII='! ! 205665 205666!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205667smallRedoIcon 205668 "Private - Generated method" 205669 ^ Icons 205670 at: #'smallRedo' 205671 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallRedoIconContents readStream) ].! ! 205672 205673!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205674smallRedoIconContents 205675 "Private - Method generated with the content of the file /home/dgd/smallRedo.png" 205676 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205677RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACWElEQVR4nI2ST0hUURTGf/e+O/OqmXHEhLJs 205678FiItgoykEHGIiFoZtJCIoFYhhLSJCFoIrVtF5KooIoqCIqKkjUSboaTE/kApZYgzkjk4pr4c 205679fe/dd28LFYYi9Vtd7rnf73DO/RzWUCrrtroZddLNqOkgH039XRdrmNuB3vh2RVjU1oZcAbq9 205680nB+tvHFWA7gZdU/Vyu11p9Ik97rC+DYbTkZtbkY9D/LR4n8Bqazb6GZUF3B6Y0OMC0cvcaS+ 205681nS/pAUStbSiPBIfdHephkI98UWESQAfQHa9Xe9wtDsm6BNRpYlWKvTX7aappprfwhMLwOFPP 205682yv1oe0gsm2uAPlUtm493dpDYupFPv97zY76ACS0yJhFyqVFMxglNgDe4yMyrhcvO8qzP3HS8 205683redqD31zvQyOv2VqokRQ1Oi5COkKZHyJYGyEtRYRE/z+6DepVNZtAQ6fu9jF/dHb5Atj6LkI 205684XbIsDIeoWgeVdlDJpXXp+YhgSrP4VSMQAwpolUmJqpYMvf6MKRtmXvrWePYJcFPPmBebdsWk 205685ThrCaY3xLfODPv5YNAycVQA7dzfyzRvGakswaTCeveXl/M7l/byz2rb4EwG6aJjtX0BE8gZw 2056863sv5ZQVMCCH4UBpAugKwAIWKX33kvfFb9Kz5aX3uCuQdL+cPrRQV0Pd9dMRsaa2STsJBVRuA 205687fRWA62HRDAC5ygSuSAAks/HctjPpNpkQLOQDSk/LnkBs9nJ+uFpSAeQSRVyb7isTlPTKvcMa 205688Mf9Hqaz7OHEgZlMH4zaVdR+s16cqziekkccwbAAerhfwB4uIABacJugRAAAAAElFTkSuQmCC'! ! 205689 205690!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'! 205691smallRemoteOpenIcon 205692 "Private - Generated method" 205693 ^ Icons 205694 at: #'smallRemoteOpen' 205695 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallRemoteOpenIconContents readStream) ].! ! 205696 205697!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/6/2004 17:12'! 205698smallRemoteOpenIconContents 205699 "Private - Method generated with the content of the file /home/dgd/smallRemoteOpen.png" 205700 ^ 'iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAYAAABWzo5XAAAABHNCSVQICAgIfAhkiAAAABF0 205701RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAD2klEQVQ4ja3T+0/VdRzH8efn+/18OTcOnJtc 205702zhFCg+EVD56BiYU4qQw1XdocttSt6VrL1fyh1vpBN7dq9mPZlv1Wm1OsDRZqU/DSkKkFelKS 205703wEsonANM1AOHw/d7Lt/TD9lWW2219f4DHnu/fnjC/3RidzkWIx+r1MkkLcxVBDcO9ZD6r5A0 2057048jiTY7XWyTzNrG9aq4TPnU/sDEXbEHwjspw81EPiX320K0T7gfbWtWORcc61tFBSWUnZwoX0 205705dnTQ09k5E4/FjitZvlYNjn/WR/yfIDUUYGFDrfpMyawEoRe3YySh5cAH7HpvG2t2vq2VLapa 205706kM2am8fHRvYsKcjU1BQjQ36GeqIYf4GWFuGrCC56uTjvEUz0UlBRzVRCYWqgk1JLmCJvhlBD 205707Hat3vCGL5lTMM/SZlx5Eo3uW+rO1NX76f4wwCqAuC5B2eArfXFw1G0QOZE0cpTV8d/QEoWXl 205708qGYCpm4jH1yixC956oXnWbl1l2pzuipvhsM7gn6zpXeECXVdhIfj7vQ79WtWaD/fy9AVjhET 205709RXiLA5w6doaxsQROtxun2w3pBEzexDJ1lYrqJVh88+T17ou23ijfyn1gNg/Hr2zeN1SXVG3k 205710BOZgvznKSH+E5cGNNK4OcPnCKUZb+ygpyadpQxCRTYE+wRPz5xM3RDnkeuXip7e6b9mM4Meb 205711illWW8prt5p5zjXBkChjuO0TPj38Awf3b0M4Z3O96zxHDrfSvH0lCAuqlAAapOcraWVm/871 205712flv9AgsXp5/kfVcb613XyAhJcMtb9EcFHae7IdLFouXLyS9dwODtSVCsKFKigAbZHMVplWub 205713an1i2l7EsbtzqbRH0UhimJCjKpStWMWFn6ZAOiA+QsOWV+i5fAe0PKQqEAIVMGU6K9xfjDey 205714t+AsxZ4Mtbfe5dlZD9jt78KuqkzmjjE0LDBMK5Z0EnuuxO4pQk/noKgqQkGCMJT4tNF3YsKj 205715p5IKm51XMYXCptyL+Geu4IqdJXZviEKvHc2WD5oD9Bh1GzYS7hlAVSWCx1AmlTo62XZwbN2d 2057161/loaAUAg7qLG/dtNHc3cvpKjODiEhRL7u/zEPgKvDg8hSjyD0hJqg8jg5dcroIN8TsD6fvl 205717q1xznLrY62sl/MtE9qtD7Y/kve5f49c6s+N3hx0zehprngdHfh4Ojw9D1+k40vIoPCq+FI9T 205718sZZWNXxoc3k3qtKSa5OmLZVMDURu931+/27/CWCkrkyr8lozTXY1Wx8I+JZWVi+ZZZom506e 205719/f7odeur4k/dCSCgaZovlUpJIAZE4e+Kz3dXFU5Xq6oouzGuDupp/fJvhgd0/Din8aMAAAAA 205720SUVORK5CYII='! ! 205721 205722!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'! 205723smallRightFlushIcon 205724 "Private - Generated method" 205725 ^ Icons 205726 at: #'smallRightFlush' 205727 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallRightFlushIconContents readStream) ].! ! 205728 205729!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/12/2004 14:05'! 205730smallRightFlushIconContents 205731 "Private - Method generated with the content of the file /home/dgd/smallRightFlush.png" 205732 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205733RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADKElEQVR4nG2T3WtbdRzGP79zTlPzVro0yUl2 205734kmW2c140btjKRLaAKBt4sW6Iu3AFoaBYhheieL8/QEHwYsx6ORDGUDpXfJnOi1bxBVEaXecw 205735TVqb13OStE1fkrTn9/MivXPfq+/F93l4eJ7nK3jUXL2qZRZLptwXlqawFFhCExYKC1QYxcz8 205736F9dnAQxAnJmYnhLIs56+vpFjjydTg3owPJBJaYGAH18giN/vw+f14/N5aTVrfDjzaRqYBRCZ 205737iem34ubQR+9eeY2hWILOnmCn67Ldlux2JPtSsS8Vrqvo7LlcOBViYvJtuh0ZWpi71jQU6tiz 20573842kC4SStXclGq4Xj1KnX69QbTRqNBpsbG0gl8foCvDQ2hRWPkF8tjQILhlDCHw0fIr+c46tv 2057397hEMBAgNhTgUCvHkE8MMDo4TCA6glGBfKvZcRSoZo/BvOQ0sGCBbSkrGnjrOydHjSKXo7rnU 205740bIdyxWbpr0WqVZvG+jqaULx3ZZJUIo7i93TPREFzZ7eNr19jzwUlFTdvzeJKiRmNMHI0wdnM 205741OMPJMIauAXA0GUMoRg9S0Jpb27t4DA1NKJQSTF2+QLlWx7EdbMfmy6X7lGsOrit59eVzpBJx 205742EPQUCKHs5kaLPl3wyY3PKKyW0HWdw2aY5OEoRyyT555JE4+G0Q8UtDtdhBDhFydeNw0h5XK5 2057434qBpgjcmL2IYOrouEAed2tlts7pW4dsHv7CyViFuhjl/7gxmJES12hg1BCJfqtpoAvo9BuIA 205744OXf3B77/8Tf8Xi9HLJNUMs7zp8dIJWIHPsQp205aAGQm3ty8c+OD4EDQ/79WtztdlleK5PJr 2057455FaKlCo270xf5ubsd9y6c2/G6J2pfLFinwj4vWSXcuQKa/xTKFJzGjzW72E4ZTGSsnjl/AtY 205746sQgA65tbgPD0CIRYLlWcE1YsQvZBjpGUxelTJzEjIbZ32uQKa+QKRX79/G5vXynRbnce6q54 2057473wAQqJ/nf/rjYtwcIhGPcv9hgdtfz5MrFKnU6lsC/lSQRZFVusj2Cz07f/t6vYcFRi9d8oQ6 205748Qx+DfFqg/Q1qUSmySmrZhblreUA98u2B/wBi/FnBrgGW6wAAAABJRU5ErkJggg=='! ! 205749 205750!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205751smallSaveAsIcon 205752 "Private - Generated method" 205753 ^ Icons 205754 at: #'smallSaveAs' 205755 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallSaveAsIconContents readStream) ].! ! 205756 205757!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205758smallSaveAsIconContents 205759 "Private - Method generated with the content of the file /home/dgd/smallSaveAs.png" 205760 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205761RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADIklEQVR4nIWTXWibBRSGny9fm37pSFqTNOlP 2057626qJrsv5gpRR1izqmjG2oqxeWug2ZDiqKG4oMBS8mgqhMREFBdyOo4EAnliIrrpYWVjfT0NLQ 205763tU1nN7vVNj9t07RJ87O0X443Y8458b193/ecc/Eclf+RZ7OtwWoqU5bX1jK3WQqA4b+K9TVm 205764m7e24utGr22y2KRfcLvd2g3L9nhLS99bhw4lAZ96x60u+0Fv8wM/H3n3020vPpPEoCjW0ZE5 205765Z6mWN391Yv9gq0fzNOvVxh+DwdV/FJudzk3eWvv375z4SPojBekNi3zz3Unp626XA7srC7HB 205766V0WGn5Wp03tll8MRAfb9fbK70t16n2e8yz8hvWGR/ojIyOV5eelwuwS6jokEO0X66qT3451S 205767V1nSDewGHABsrbE/1vbUnkT/nznpDYsElkQG/QHpfL5duk52igxul/Fvt8vx/dViNhUPAT5A 205768AzB4XPaD9U3WX44dcZQruRR1Zrh09hSvvHac4hILwYsx3vxylc8HsmzZ0YzbdVeLzWxyAjkA 205769taK89L03Xm+td9+9icWpM5iNXhobm9hcaSGbvMDDOzSslWX8frmU5zpqqHVZ1KFArCmRyvYA 205770q6pBUUpyGf3pKodFefSRCkYCA0xMJri3+hxtT1SRSOj8Mf8QpWYnPT2jHH15K/6hqCMSSYeu 205771r29Mq5ncejS5sr5lz053Qzyexuez47knjtOh0TcQ4Up4G/HlBH6/n9jidYLBGQLD4auLycwZ 205772XRdNBdYyeX16MhRv69hbZTaaTWhaEd0/zTIwuIKqpBgdmyGRWGF5KUooFL04G1t9O5/XM8CS 205773ClAoFKIFnXRBlydd5TnFUevApBk49cM1Xjhg49yvM8zPhsmmU+dnY8n3Nzb0HHAJCN0kMZ3L 205774j0dj+cZ9PmPDxNQyTfe7sNtUPvxkjIVIXFJr2dPXoitfiEgOGAbmAG5FeSOvK+eDk/mOw7vW 205775LPnYFQLTJn7zzyUXljIfhOOps8AyEABuIqzc/gdGI/X2MstRrajoQUXFEF1KfZbOrS8AU8BV 205776QG7N/2vADZmBWsAK6MAYkL5T8C8m0GUZPNX0AAAAAABJRU5ErkJggg=='! ! 205777 205778!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205779smallSaveIcon 205780 "Private - Generated method" 205781 ^ Icons 205782 at: #'smallSave' 205783 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallSaveIconContents readStream) ].! ! 205784 205785!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205786smallSaveIconContents 205787 "Private - Method generated with the content of the file /home/dgd/smallSave.png" 205788 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205789RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAC40lEQVR4nIWSXWxTdRjGf+ecWlqWdlvPoWXZ 205790JiWyTwQEP7JMTCQhKJkChgSVhCgXJhAW0XDBHYGQ4EdMTORCE6/0QkVnDGkIDAlLUKQUljX7 205791KmaQsVr7tbXrej7WdT39ewOGwNDn9n1+7/u8yaPwP2pZpXb43LVS3jCspeby48D2Ro/a2rzi 205792m85WdfwJt/1HMBh0LeVTlrzapO1tXf/8hUMnv+h6b3cRWZJ8Q4OJQMGYD/1n3PWBQE1rs/bj 2057938U8+E5dTVXExKcS3Z74S2dsHxZauYGWl5u15LNweXBl8dl3L6C/hMXExKcTllBAJU4jpbEac 20579479snLvTtFmsa1dseUB95oa1R29K2YePAse+vPOmob6DOCZtU8C2D5TU19PffoGebk0TC8E0l 205795rfo5c+E8UAWQW5q0ve1rfb8eOeSvk0o6azzwnApuBQxD5+vTR9m1PQfAh4c34ldr3lE9y1+7 205796n0CWZd7av69TCWgO5qMfsBAfRQLGRqKEfujlzTcsdL3CiY9TOBSZ93ufcdZ5XSeBVQCKLEnL 205797Spa9s8HvlV7avILByADXI3/hcfzMi121jIwVuDb0NLKznlBokN4DbYSvp/2plBlbWKxMKFZp 205798MV0sLD71ysvBjlzOpLtbo2V1joDfxaWBFHeSXeTys4TDYTLTC0Sjk0RuJu9OF61zti1cCmBY 205799ZXtiPJbbsefVBo/T48blcnA2FGfgtwKKpDM0PMnsbIH8TJpYLD0Sz8wdK5dtC5hRAKrVarpq 205800Y1Zt0dNUV5L8zX7cLpnv+qZ4922VK79P8nc8ybypX41niqcqFbsE/AnE/m2iWSqPpjPlzte7 205801nR1jt/Ks3dCEpip8+vkw2VRO6Mb8T1PpwpdCiBJwE0g8XOVK2ZauRsfLe/ZvNbzlzB0iE26u 205802hRPF7Iz1UTKn9wN5IALM3YekhxvpdNKu1Xp7XQ7HC5KCnJ7RT5ulxSxwC7gLiAf9jyy4Jw/Q 205803DPgAGxgGzKWM/wCIojxGWb3q0gAAAABJRU5ErkJggg=='! ! 205804 205805!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'! 205806smallSelectIcon 205807 "Private - Generated method" 205808 ^ Icons 205809 at: #'smallSelect' 205810 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallSelectIconContents readStream) ].! ! 205811 205812!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'! 205813smallSelectIconContents 205814 "Private - Method generated with the content of the file /home/dgd/smallSelect.png" 205815 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205816RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAABK0lEQVR4nKXOO0oEQRAG4L+6q2cfjojgBmJi 205817YmroEQwNBBPxFF7AzBt4DMHcyFwUE2MRPIDruuxMd9VvsKCbrOJOQVNNPT5KcHK7gTjdA2UH 205818MQzgnoCQIJ6AEAE3QFqQBSFk0DMcBaot1uxOobPjm/ODy/WhxrqvWvei1r35v1+FUIzM5mwz 205819PZt7a2Qx98eX9/Hp1cOFJpV0uD8aYUmkKJJixLBCXKxv1qmCSz/0VKtly79FEJlnjdBVgG+o 205820CljpgoVLJP499guQVFInIDtKJ6DJ3nQCPps86wTkgoYAVwYAycXYARAW8/8DKQZBgCgczdPr 205821x3h3azBwEtmc5qQZWZx0gsXJUpzFOe85+fw2mQCIgrPrbVg6AtFAQgHpAOznyTzTHRCDLNRt 205822ev8FfDedurn+q90AAAAASUVORK5CYII='! ! 205823 205824!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 10/7/2004 13:42'! 205825smallSqueakIcon 205826 "Private - Generated method" 205827 ^ Icons 205828 at: #'smallSqueak' 205829 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallSqueakIconContents readStream) ].! ! 205830 205831!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:49'! 205832smallSqueakIconContents 205833 "Private - Method generated with the content of the file /home/dgd/smallSqueak.png" 205834 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205835RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACWklEQVQ4jcWSW0hTARzGv52zeXY25ub0eEFd 205836BBsztbYcC8PWhZEsctm6jFlEWkQRBT4U0ioiirSHMAgzijDqLeqlop60jGhGiEoaydKtXXWX 205837pmdubpN5eukhTKM3v8f/x//38v2A1Q75j05UpVNfy5NLbdFwzANgCgCZV5h3qLiMaZ2JsjSA 205838sZUA5Jb62uFae3Mju1FZM+cLH6eynENdvfbe4dPWMw1NJj3KGWPSG6KXBejqNHeNF47uejo1 205839zWP7R5AqZ0hJcr7x7PlmlUgioi6fuA6/qpQWpRfy+csBKtUbjoiHEqj7HoCsQIVMGYEhZ0Cq 2058403WNAgUCAm/YupL66QcokxQQAHgkcLAH/EgAZAFRVa4TvevvQcqAJ2dgcnHMp7LfVo292Ft1+ 205841PwiSACWikQzFUoQExK1OMHceg7m6GULHTsv2jkg0QnBiGi6XC8FgEJkgiwabCYowi8EbT+Af 205842/wG5VsnFIzND/CoI1+8DU7QIHixEVilpaWwrUinw6dE0KIqCx+MBXVOCjJdEca4YW5UK8E9a 2058434B33JOIT/nYiBzn5I+AjCAoDQoLU1WkgpQRob7XhQ+Ab1pmNsO7ehp+RBE7Z7CHn6EQ0PDYZ 205844i/YPdwIY4FMQHOuAp4uleSrVOaucTWfIZDyB9HwabRetWOA4OD5OYtTnRTKZvvK858XD3/6k 205845AID3pziMVvlerKuoUGyqFNDy3Jzc0kL0vv3M7fAtcu5w8OXgs9d7ly7GW3owm82v9Hq9UV6Q 205846H7/dc/+Ly+3uzoZn3wBIrCDd3xYaDAa7yWR6AGDN/z6tXn4B2ljYZPClNw8AAAAASUVORK5C 205847YII='! ! 205848 205849!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'! 205850smallUndoIcon 205851 "Private - Generated method" 205852 ^ Icons 205853 at: #'smallUndo' 205854 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallUndoIconContents readStream) ].! ! 205855 205856!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205857smallUndoIconContents 205858 "Private - Method generated with the content of the file /home/dgd/smallUndo.png" 205859 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205860RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACOklEQVR4nI3RT4iUdRzH8dfzPDOzOynJ7tZu 205861sJBCQaBJQUXkSiZeIumghy4FHpJOnez/QXfwECHBHjrpKS+CmEEbUst62A6CSMialmsabZjr 2058625Li27rizMz3PPL8OjYttSn5uv9/v83l/f9/vN3IXfURfke2Bm1McPUL7bj6Il19UeKWLi6uL 205863DpQih9fyyb3C/9EeKgcK8uu9QuiPwrdlYQ/ND+n53x8MM/J82fCbvVHUt2MnXxw3UABdJfbv 2058645rm3KC4HRJ3Kn75Q9s7Lfd28sZPZGuPHtG7d8msoqmZcbaYutcxmjMR8VmEeot1seqxkYscq 205865dHXTai7RFzOKMYW+Xp561sLAoNGDh0zVW3Mx2ypMJJvZN1SybqBAnGdL4Xbg7A3+WGTu5qIw 205866/Yue6Snr331fc2am+3LtxrYhDiabePjP3NYH/iIPrCgQRdRTrqScuN1oynwjs/LMSY+/94Hv 205867x8a7s2Au2czpRvDEdPBkf6DWII5YyPgp5/fc21eDHy8G6x9NdM3W2wbb89Keh0xfqTaSCcJ3 205868HN1A9UJuS54oljMaKaeCdIHXP+bYS1ya47XBwCP1qnjoRZOT535bWuNe9sesuZDZ9WXmzKmY 205869ZjC2j3rHci0ESglJnln4YVJErXDnTitcwwhGKm1PJ1Rvv+U8sybhwU6ien5KYPRfgGWwyTvP 205870gY39KHcS51vSmG/uCViuiGIh4nqTnwO1ts/3Mn/fgMDo16lXY2SZyxnDHfD9q8KGnHUxX1X+ 205871mZe/ASGg28UCHOe+AAAAAElFTkSuQmCC'! ! 205872 205873!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'! 205874smallUpdateIcon 205875 "Private - Generated method" 205876 ^ Icons 205877 at: #'smallUpdate' 205878 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallUpdateIconContents readStream) ].! ! 205879 205880!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'! 205881smallUpdateIconContents 205882 "Private - Method generated with the content of the file /home/dgd/smallUpdate.png" 205883 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205884RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAACz0lEQVR4nI3SW2hTBwDG8f85iSdpEnIxR+01 2058850TlmbawOWy8PdXZYFRXLVHwYLt5ARMUXH0Rh0DxIq1jQl3irw6KCSMecKDiYVZEZ6+jEFsrs 205886apektsY2tWnNSU/S0+T45IMgxO/5+35Pn8CXRyqysRmROoOIVReJSDl+MeZbOcx85XaYL2/Z 205887tnV1bd16saKyGovVgZJ8z/ZNNQvzAYt27tja/dOe3UJfLEXwfhjloQqiAX+1i5JS75J8gDh/ 205888/jzhbqifJxNejHIFVWUzmcxo9IR7sNrs5nzAlDqp6mFVEYQCAZ9nJovnyuR0nbe9r3n+Ovom 205889HzCazkzp5aUOwW1zM8tupvvvByhDL1lTs5Shwcg1sbzUsq92xcK++rqVI99VL+gvdnLLbWHZ 205890R6C9/VFkTbWXRF+IcPtF0rF/WVtTyc0r5yfC72gRdmypGzjbcrPsRU8vnuLZSKLGrbartN24 2058918bb/VeRoMsd/P9av+8vhchlNZhMDkQGms9ncLM/immAw+FS0O53uI40XOPnnMAdau/Cf/oNh 205892oZizF84VHjy0r1VVGej8p6szq88gqYgsqKhiND7aVVRUdALAKCLqU7qRVb5isjmdjl4DnUkd 20589357OX2O02Ach0vxpe2xe97isw4RlTuAcotRtzjwHEWGww7il0kZvWMBkNfF3oACClTDIxkcwC 205894aUBRNZ6NKbQBSiAQcEqSpAIYX3SGWv0HjwXu3G7BOnseGYsXr7uQ5XPLaAn+PgJMAjQ1NS0T 205895BEFOp9OqLMtHotHoJQABkDasXvLcv3evr6M7yrSWwfNNJb45Art37W86fDTwsyzLv42Pj49o 205896mpaSJMmUSCTuNTc33/kIUAUW/6njqY5QCKvNSmwwRkpNx1d+X7+npKTkQCKRaG9oaDjzuaMY 205897AGKgxYf+r9hU/0O5JBWIY2PvctGheOjbquWueDz+a2NjY2uew30SJ2D70vIHGPAd/9jj14AA 205898AAAASUVORK5CYII='! ! 205899 205900!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'! 205901smallVolumeIcon 205902 "Private - Generated method" 205903 ^ Icons 205904 at: #'smallVolume' 205905 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallVolumeIconContents readStream) ].! ! 205906 205907!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'! 205908smallVolumeIconContents 205909 "Private - Method generated with the content of the file /home/dgd/smallVolume.png" 205910 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAQAAAC1+jfqAAAAAmJLR0QA/4ePzL8AAAE3SURB 205911VHjajdE/SJRxHMfxF/f8Hp/n7vLhlAKhyKRCOpccA6EbFEW0BsciyKWphiBoCRuiQXEJnIyG 205912ampyEppydy8wBOFEyPzHA0X1wNGggV0Ivbbv8h3eH44rKWkT/XUNqdhxgrjz5kBTA90SiVlD 205913h0+PdI6PvZhKwDmPVL13G4KaOqcuTL+6k3z8iis+Sd0175pxy0H91ss066g+SKo+Q68uq4Zd 2059149M5DyyUdE6dHzg7XIrmdM7XHPriq8NoNaxJdgRypA7/Ezo8e9NjDpgzfhMC+kp92FXZb++u+ 205915KKPbd5S1Ak2xVJ+WH3nzqQE5Jq3IpPJgY2GOrDe+NxhCYUvZkkGXvHHfkuJPhkr/4pNiZlsD 205916dbPq+ryVHS9Zqc1c39JAJhF5Zqw9dsXzw7yIXBb/u0fUNt7/+A0ZzEdfNHX2/wAAAABJRU5E 205917rkJggg=='! ! 205918 205919!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'! 205920smallWindowIcon 205921 "Private - Generated method" 205922 ^ Icons 205923 at: #'smallWindow' 205924 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallWindowIconContents readStream) ].! ! 205925 205926!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 23:00'! 205927smallWindowIconContents 205928 "Private - Method generated with the content of the file /home/dgd/smallWindow.png" 205929 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABF0 205930RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAA80lEQVR4nO2PMUvDUBhFz5c+IjFp0YJD0SWL 205931i6OL0FIQQUQo/gk3wcXN0X8hOvgHXFRo54qWLoogKC2Eoh26iOBQadP3XpeOBpJBXLzj5TuH 205932+8FfR6q1/XC3XL7TYRgIjhWbfKyVFbEwiHofT7f3282b065yPW9zY/RVikpFbGGRfM5LFAzG 205933n1hg2XXzzavLQ+BYjb5j019bpbKyAFhgmDzBnwOg/vCGnsQ+UFQAeztVAn8+/eNbcHZ+AYCT 205934nvo5/wJwxDHj59coE/TS6WGMjgFU7OrGwdHJteQkSCuwEzN87z62AGTWrQNLmWaABtoZmV/I 205935FJjvR0sUmC0hAAAAAElFTkSuQmCC'! ! 205936 205937!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205938squeakIcon 205939 "Private - Generated method" 205940 ^ Icons 205941 at: #'squeak' 205942 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self squeakIconContents readStream) ].! ! 205943 205944!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 11/5/2004 13:49'! 205945squeakIconContents 205946 "Private - Method generated with the content of the file /home/dgd/squeak.png" 205947 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 205948RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAFoklEQVRIie2VbXBU1RnHf/fu3ddsNrtsdmGT 205949QN5gk2wQsiFWYpMgWE2DLaVqU5sPpEVq0VZn0k+ttaVjKwQcmLF+YIoNji/pkKYyrYQWMYIE 205950quhEA+ElWRuTkLqbCNld9m6yy97N3tsPDLbTzmjkmzP+Pp455/mdeeb/nANf8kVHdxNnbi2v 2059518m63Zmc9Il+NuzVNOw8o/7On0Ol2/MjpdjwxIyeqNE2TgBEA4XOIxPzi/D/mL1l0R8PGNQs/ 205952SCY5deBoZiZ0ZU6vZDbOyrNHAJ07z9UxI89+984NDXqHy6ELjoVi7554X0kkEl2ZdObReQuL 205953vIWvtDx8/73OTY08NzlJQlVBVYl1HEY9cHwmfiW6wrbA+pi/duVD7fu3WRa4F5CYTRJJp9l3 205954LkBv8xPx8FS4QZyn7xs+f1n94u838btgkISqkgnLpAZHydl8D6am1VlZDtvBHId9y479v7bo 205955DXqe/MkuGvKb+GbxtzgeGGVpa5MEbJTmYytctuTx5f7lrt1Pv0RuaR4fPvUCXFNQVZVYOoNx 205956w+1Cvn/ZigdbN4hOtwMlpZDJZIjHZgDQHRtg5jtrzSazoXE+PrF+Xd1MMBjUuru7Nbe/TNu9 205957Z4+2d+9erezer2kvv7VfW1JeqBX6SrTD57u0d9OntYDWr51Jva25PLkaoJlqyrWC489ouR7X 205958h/Npqanav8rQ399PIBBg0/r7+GlbG5s3b6alqp6uaJTOY7/HbsuipKKYE7EYAAevRslxZANg 205959yDajxhMg6eZuCPXAVhH+IMFOoPa/hKniolKpo6ODrq4uVvurOXnyJBUVFaSupXjtyD+wL3Li 205960XV6KKIq8Mj3NoXCYU1emCV6aul7cmYM6Febq5ciIBGTr4LXbMXs2YS2IoQrPEtsqoz4VRd0F 205961iJejV9R0Oq2zWq3U1dXR3t6O3W5ncHAQpwOCqRS/2fcLAJySxJFIBOG5wyRnkwBYbvORGRhJ 205962zqWUPhH4+XqyrG/gKWolW3qMHN2b5NtsiI97K0t6Vn6l8lJgeFhsbm7GarViNBqZmJigpaUF 205963t9uNUW8gMDBKPHo9IHUnL9Jf+zBvPNMFQG6eC92aKuS/nY4CJ3QCbPsLC312JEMCCQGwIzAp 205964qMaC1ru8e/7Unu2vrxRePXKakekpli7MI5lM0tnZiaqqDCw282BJDaF/higoX0RFVRlKSuGd 2059654/1Ysi1Ubt+KcnEsM3Wwbwh4UhIRDDI24wXMaDdSQgazIAvuskIAFrgd/HDbfXjluxjsvEBr 205966ayuBQIBFHg9n1now63TYbIv52cuHeGBpMT/+5RZubfBz4FqCM+NBIu2dMU3TfgVoUinmcDey 2059679ADmT1Iyi8jf9Wna71hFcDz0yfpah40ui8zY+DhtbW207N/NQ6ub+Pj1ECWLl3G055R2bvCF 205968i5U1Pl9BUZ4gjwX5uLs3PZdK7wJeB5DuxrntVcJ3p0FqIAeZDM8ziX9dDUtKC1BVlVQyRTw2 205969y/RUmB+0fp3u/vP0BMb43vYtbHK5mMgXGZ4YRRwNXRsZGq8vLC+6rfevJx6dvDQpz6XSHUDv 205970jUsLAN8m1ztEYk8KbUXcIlotDSvtu/+8Q7jFYiEWkVFSCiazEVOWBZ1ORKf7z/j2HX2PcouP 205971nvdP8/yLHQOX3xuu/rSh/v/Hu9i9UK+J54R11bkNj9wvrDMYKTeZyJH0uDy5GE0GkqrKcCJB 205972XyyG8dhHrPEs5bdP7wj3H33TA6Q/n/A6ea4Sz7OynLgn685V6my116i/pVjMynOhZDLIsVky 205973Z0fIfntIq01b1JH45UOjve80f5bs04QA1NTU9NbW1n41FAqlLv1rQhQknRqORMSP5EhAyahv 205974EZ3pQ1F6gNRnieaL3efzXdi5c2fi7NmzmizLWmNj4weA/WYLzusD9nq9651O51ZFUYShoaF9 205975iUTi0M0Kv+SLz78BjzNWmYcZV74AAAAASUVORK5CYII='! ! 205976 205977!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205978volumeIcon 205979 "Private - Generated method" 205980 ^ Icons 205981 at: #'volume' 205982 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self volumeIconContents readStream) ].! ! 205983 205984!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 205985volumeIconContents 205986 "Private - Method generated with the content of the file /home/dgd/volume.png" 205987 ^ 'iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAQAAABKfvVzAAAABGdBTUEAALGOfPtRkwAAACBj 205988SFJNAAB6JQAAgIMAAPn/AACA6QAAdTAAAOpgAAA6mAAAF2+SX8VGAAAAAmJLR0QA/4ePzL8A 205989AAAJcEhZcwAACxMAAAsTAQCanBgAAAHrSURBVDjLldTLahRBFMbx/xu02hEvm1mZIC4qovaA 205990LhoE142+QIMvILoRgjASdKEilSBxO5CFIhKbmUAQNWmD6KCQxCAMEi+JGGKISuETfC665uIM 205991DqRqd6hfn9Nd5zRidxsBV/jOH5rc5QhjJBDwnyUQ43xmix9ssMo8GRiygaBBg0dMM887FsCE 205992jvyfUwEZaRdY5CrDnOUyt8GE7pbaIKEEgEGYNnjpowmYIXdfeQfErJMAUCliArFMAJwEM+Sm 2059939V5r6iopIC+eXdDiK1lycux+90Qb2tavAlQxFxgBwwoAl8haIH+sTKN6oZ/6rW1ttjJYzEMO 205994QZUEKPnTgnxHmzqjHW3pm77ooxApEFC9QwoxVV+U8eCTmirrq9bU1KqWVNZBEewDe55JwGfM 205995iT1Y0hud0gct661ea1HndEzEQOUiUxzoBwt6quNq6JVyPdOcTuuwCE6AtUywpx/Mqq5RPdec 205996ZlVTTTjSBxBgp7gGCRYA136HG7qpYU2qrppqqou8VtxAcI8RyDBACddzD6GzbTAOFYIxjkLs 205997C6pQbYHWMqGbUF11kcNeH2OdEhDgiHsBmNBZzXRaI2XFN4YtWr4LREREYEJ3vQNKfpRSXNGh 205998PaBMBIb+ebA+Tz/wZPDE0ZMjgiAaBHb919jd/gvLk2YJrn7DBgAAAABJRU5ErkJggg=='! ! 205999 206000!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 206001windowIcon 206002 "Private - Generated method" 206003 ^ Icons 206004 at: #'window' 206005 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self windowIconContents readStream) ].! ! 206006 206007!MenuIcons class methodsFor: 'private - icons' stamp: 'dgd 9/25/2004 22:59'! 206008windowIconContents 206009 "Private - Method generated with the content of the file /home/dgd/window.png" 206010 ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0 206011RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAB5UlEQVR4nO2WP2gTURzHP/fuEqMpZ1vUKBqq 206012FHFTB/+0XVSKRSxCBUVHQXHoUHeh4thFVwcnFwWdNFBErWgVVBIXBRGs1pZEjamtucvl7nKX 206013O4fkoPXPkHqCw32m977vz4f3ePB7EBEyUtDoGzrbLRDpMDeX63XjceZqDvCDTAHoP3HuwsHd 206014uy5uVNukuXQXruSR8ORlSaqyS6IuYwqX79MFfKG8mLx9pWeJcNv2HSOnx69Lq18+Z+zRJHmj 206015xNEt+5Al0ZJs3tZ4kM/SrW7ivZant7+Xzx9n9n79NHDkbfbeXcBRAN69eq3cHzzJ+sPHWGsn 206016SMopSvlCy6fz8NmqpOiwYgglxdybaWanpjArCzuBBeCpAmCZVZ4Uiwzs30NXpdRcXm5ZCLAO 206017AJ2U6/Iwl8N1nGCoA5pXGospjI0Oo7YllyX5E4cO9HD8zHlmF2UCYE1nuwhbBhCPx9ic3rAk 206018a+1VhEAkjISR8D8RGlXT9zzvnwjKuvGrsKxXStdujmPZtdBEtZrDrTsTfJgpUDMqepBLAH2D 206019p4aFiF+WJGlFaMYGvmVoz7ITNy4BDpAJvhirVibVoaTaqYZps23L1ue/BHXOATJKs2OahvbN 206020NDQrTOFPFGHRJwqQaRRJ6bfT/w6XRsWPCJ8feQeiSATBXJcAAAAASUVORK5CYII='! ! 206021StringMorph subclass: #MenuItemMorph 206022 instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon' 206023 classVariableNames: 'SubMenuMarker' 206024 poolDictionaries: '' 206025 category: 'Morphic-Menus'! 206026!MenuItemMorph commentStamp: '<historical>' prior: 0! 206027I represent an item in a menu. 206028 206029Instance variables: 206030 isEnabled <Boolean> True if the menu item can be executed. 206031 subMenu <MenuMorph | nil> The submenu to activate automatically when the user mouses over the item. 206032 isSelected <Boolean> True if the item is currently selected. 206033 target <Object> The target of the associated action. 206034 selector <Symbol> The associated action. 206035 arguments <Array> The arguments for the associated action. 206036 icon <Form | nil> An optional icon form to be displayed to my left. 206037 206038If I have a dynamic marker, created by strings like <yes> or <no> in my contents, it will be installed as a submorph.! 206039 206040 206041!MenuItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/17/2008 14:43'! 206042enabled 206043 "Delegate to exisitng method." 206044 206045 ^self isEnabled! ! 206046 206047!MenuItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/17/2008 14:43'! 206048enabled: aBoolean 206049 "Delegate to exisitng method." 206050 206051 self isEnabled: aBoolean! ! 206052 206053!MenuItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/22/2007 14:47'! 206054themeChanged 206055 "Also pass on to the submenu if any." 206056 206057 super themeChanged. 206058 self subMenu ifNotNilDo: [:m | m themeChanged]! ! 206059 206060 206061!MenuItemMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 11/20/2007 12:39'! 206062mouseDown: evt 206063 "Handle a mouse down event. Menu items get activated when the mouse is over them." 206064 206065 evt shiftPressed ifTrue: [^ super mouseDown: evt]. "enable label editing" 206066 206067 "Quick hack to bring menu to the front if it is obscured. See 206068 http://bugs.squeak.org/view.php?id=1780" "fixed by gvc to work with embedded menus" 206069 self owner owner = self world ifTrue: [ 206070 self world morphsInFrontOf: self owner overlapping: self owner bounds 206071 do: [:ignored | ^ self owner comeToFront]]. 206072 206073 (self isInDockingBar 206074 and:[isSelected] 206075 "and:[owner selectedItem == self]") 206076 ifTrue:[ 206077 evt hand newMouseFocus: nil. 206078 owner selectItem: nil event: evt. ] 206079 ifFalse:[ 206080 evt hand newMouseFocus: owner. "Redirect to menu for valid transitions" 206081 owner selectItem: self event: evt. ] 206082! ! 206083 206084 206085!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 3/17/2001 20:16'! 206086adaptToWorld: aWorld 206087 206088 super adaptToWorld: aWorld. 206089 target := target adaptedToWorld: aWorld.! ! 206090 206091!MenuItemMorph methodsFor: 'accessing' stamp: 'sw 10/3/2002 20:50'! 206092allWordingsNotInSubMenus: verbotenSubmenuContentsList 206093 "Answer a collection of the wordings of all items and subitems, but omit the stay-up item, and also any items in any submenu whose tag is in verbotenSubmenuContentsList" 206094 206095 self isStayUpItem ifTrue:[^ #()]. 206096 subMenu ifNotNil: 206097 [^ (verbotenSubmenuContentsList includes: self contents asString) 206098 ifTrue: 206099 [#()] 206100 ifFalse: 206101 [subMenu allWordingsNotInSubMenus: verbotenSubmenuContentsList]]. 206102 206103 ^ Array with: self contents asString! ! 206104 206105!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! 206106arguments 206107 206108 ^ arguments 206109! ! 206110 206111!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! 206112arguments: aCollection 206113 206114 arguments := aCollection. 206115! ! 206116 206117!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 1/16/2001 16:58'! 206118contentString 206119 ^self valueOfProperty: #contentString! ! 206120 206121!MenuItemMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:51'! 206122contentString: aString 206123 aString isNil 206124 ifTrue: [self removeProperty: #contentString] 206125 ifFalse: [self setProperty: #contentString toValue: aString]! ! 206126 206127!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/17/2000 18:32'! 206128contents: aString 206129 ^self contents: aString withMarkers: true! ! 206130 206131!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 1/16/2001 16:57'! 206132contents: aString withMarkers: aBool 206133 ^self contents: aString withMarkers: aBool inverse: false! ! 206134 206135!MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:55'! 206136contents: aString withMarkers: aBool inverse: inverse 206137 "Set the menu item entry. If aBool is true, parse aString for embedded markers." 206138 206139 | markerIndex marker | 206140 self contentString: nil. "get rid of old" 206141 aBool ifFalse: [^super contents: aString]. 206142 self removeAllMorphs. "get rid of old markers if updating" 206143 self hasIcon ifTrue: [ self icon: nil ]. 206144 (aString notEmpty and: [aString first = $<]) 206145 ifFalse: [^super contents: aString]. 206146 markerIndex := aString indexOf: $>. 206147 markerIndex = 0 ifTrue: [^super contents: aString]. 206148 marker := (aString copyFrom: 1 to: markerIndex) asLowercase. 206149 (#('<on>' '<off>' '<yes>' '<no>') includes: marker) 206150 ifFalse: [^super contents: aString]. 206151 self contentString: aString. "remember actual string" 206152 marker := (marker = '<on>' or: [marker = '<yes>']) ~= inverse 206153 ifTrue: [self onImage] 206154 ifFalse: [self offImage]. 206155 super contents: (aString copyFrom: markerIndex + 1 to: aString size). 206156 "And set the marker" 206157 marker := ImageMorph new image: marker. 206158 marker position: self left @ (self top + 2). 206159 self addMorphFront: marker! ! 206160 206161!MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:19'! 206162hasIcon 206163 "Answer whether the receiver has an icon." 206164 ^ icon notNil! ! 206165 206166!MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:19'! 206167hasIconOrMarker 206168 "Answer whether the receiver has an icon or a marker." 206169 ^ self hasIcon or: [ submorphs isEmpty not ]! ! 206170 206171!MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:25'! 206172hasMarker 206173 "Answer whether the receiver has a marker morph." 206174 ^ submorphs isEmpty not! ! 206175 206176!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:40'! 206177hasSubMenu 206178 "Return true if the receiver has a submenu" 206179 ^subMenu notNil! ! 206180 206181!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:18'! 206182hasSubMenu: aMenuMorph 206183 subMenu ifNil:[^false]. 206184 subMenu == aMenuMorph ifTrue:[^true]. 206185 ^subMenu hasSubMenu: aMenuMorph! ! 206186 206187!MenuItemMorph methodsFor: 'accessing' stamp: 'dgd 3/22/2003 14:45'! 206188icon 206189 "answer the receiver's icon" 206190 ^ icon! ! 206191 206192!MenuItemMorph methodsFor: 'accessing' stamp: 'dgd 9/13/2004 19:00'! 206193icon: aForm 206194 "change the the receiver's icon" 206195 icon := aForm. 206196 self height: self minHeight. 206197self width: self minWidth! ! 206198 206199!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! 206200isEnabled 206201 206202 ^ isEnabled 206203! ! 206204 206205!MenuItemMorph methodsFor: 'accessing' stamp: 'RAA 1/18/2001 18:24'! 206206isStayUpItem 206207 206208 ^selector == #toggleStayUp: or: [selector == #toggleStayUpIgnore:evt:]! ! 206209 206210!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:22'! 206211itemWithWording: wording 206212 "If any of the receiver's items or submenu items have the given wording (case-blind comparison done), then return it, else return nil." 206213 (self contents asString sameAs: wording) ifTrue:[^self]. 206214 subMenu ifNotNil:[^subMenu itemWithWording: wording]. 206215 ^nil! ! 206216 206217!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! 206218selector 206219 206220 ^ selector 206221! ! 206222 206223!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! 206224selector: aSymbol 206225 206226 selector := aSymbol. 206227! ! 206228 206229!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! 206230subMenu 206231 206232 ^ subMenu 206233! ! 206234 206235!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! 206236subMenu: aMenuMorph 206237 206238 subMenu := aMenuMorph. 206239 self changed. 206240! ! 206241 206242!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! 206243target 206244 206245 ^ target! ! 206246 206247!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! 206248target: anObject 206249 206250 target := anObject. 206251! ! 206252 206253 206254!MenuItemMorph methodsFor: 'change reporting' stamp: 'dgd 9/1/2004 18:29'! 206255ownerChanged 206256 "The receiver's owner, some kind of a pasteup, has changed its 206257 layout." 206258 super ownerChanged. 206259 self updateLayoutInDockingBar! ! 206260 206261 206262!MenuItemMorph methodsFor: 'copying' stamp: 'sw 9/25/2002 03:24'! 206263veryDeepFixupWith: deepCopier 206264 "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 206265 206266 super veryDeepFixupWith: deepCopier. 206267 target := deepCopier references at: target ifAbsent: [target]. 206268 arguments notNil ifTrue: 206269 [arguments := arguments collect: [:each | 206270 deepCopier references at: each ifAbsent: [each]]]! ! 206271 206272!MenuItemMorph methodsFor: 'copying' stamp: 'dgd 3/22/2003 14:56'! 206273veryDeepInner: deepCopier 206274 "Copy all of my instance variables. Some need to be not copied 206275 at all, but shared. Warning!!!! Every instance variable defined in 206276 this class must be handled. We must also implement 206277 veryDeepFixupWith:. See DeepCopier class comment." 206278 super veryDeepInner: deepCopier. 206279 isEnabled := isEnabled veryDeepCopyWith: deepCopier. 206280 subMenu := subMenu veryDeepCopyWith: deepCopier. 206281 isSelected := isSelected veryDeepCopyWith: deepCopier. 206282 icon := icon veryDeepCopyWith: deepCopier. 206283 "target := target. Weakly copied" 206284 "selector := selector. a Symbol" 206285 arguments := arguments! ! 206286 206287 206288!MenuItemMorph methodsFor: 'drawing' stamp: 'dgd 7/28/2005 13:13'! 206289drawOn: aCanvas 206290 | stringColor stringBounds | 206291 isSelected & isEnabled 206292 ifTrue: [aCanvas fillRectangle: self bounds fillStyle: self selectionFillStyle. 206293 stringColor := color negated] 206294 ifFalse: [stringColor := color]. 206295 stringBounds := bounds. 206296 self isInDockingBar 206297 ifTrue: [stringBounds := stringBounds left: stringBounds left 206298 + (Preferences tinyDisplay 206299 ifTrue: [1] 206300 ifFalse: [4])]. 206301 self hasIcon 206302 ifTrue: [| iconForm | 206303 iconForm := self iconForm. 206304 aCanvas translucentImage: iconForm at: stringBounds left @ (self top + (self height - iconForm height // 2)). 206305 stringBounds := stringBounds left: stringBounds left + iconForm width + 2]. 206306 self hasMarker 206307 ifTrue: [stringBounds := stringBounds left: stringBounds left + self submorphBounds width + 8]. 206308 stringBounds := stringBounds top: stringBounds top + stringBounds bottom - self fontToUse height // 2. 206309 aCanvas 206310 drawString: contents 206311 in: stringBounds 206312 font: self fontToUse 206313 color: stringColor. 206314 self hasSubMenu 206315 ifTrue: [| subMenuMarker subMenuMarkerPosition | 206316 subMenuMarker := self subMenuMarker. 206317 subMenuMarkerPosition := self right - subMenuMarker width @ (self top + self bottom - subMenuMarker height // 2). 206318 self isInDockingBar 206319 ifTrue: [subMenuMarkerPosition := subMenuMarkerPosition - (4 @ -1)]. 206320 aCanvas paintImage: subMenuMarker at: subMenuMarkerPosition]! ! 206321 206322 206323!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:38'! 206324activateOwnerMenu: evt 206325 "Activate our owner menu; e.g., pass control to it" 206326 owner ifNil:[^false]. "not applicable" 206327 (owner fullContainsPoint: evt position) ifFalse:[^false]. 206328 owner activate: evt. 206329 ^true! ! 206330 206331!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:37'! 206332activateSubmenu: evt 206333 "Activate our submenu; e.g., pass control to it" 206334 subMenu ifNil:[^false]. "not applicable" 206335 (subMenu fullContainsPoint: evt position) ifFalse:[^false]. 206336 subMenu activate: evt. 206337 self removeAlarm: #deselectTimeOut:. 206338 ^true! ! 206339 206340!MenuItemMorph methodsFor: 'events' stamp: 'kph 1/11/2008 07:29'! 206341deselectTimeOut: evt 206342 "Deselect timout. Now really deselect" 206343 owner selectedItem == self 206344 ifTrue:[ 206345 evt hand newMouseFocus: owner. 206346 owner selectItem: nil event: evt ].! ! 206347 206348!MenuItemMorph methodsFor: 'events' stamp: 'sw 2/7/2001 00:03'! 206349doButtonAction 206350 "Called programattically, this should trigger the action for which the receiver is programmed" 206351 206352 self invokeWithEvent: nil! ! 206353 206354!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 22:45'! 206355handleMouseUp: anEvent 206356 "The handling of control between menu item requires them to act on mouse up even if not the current focus. This is different from the default behavior which really only wants to handle mouse ups when they got mouse downs before" 206357 anEvent wasHandled ifTrue:[^self]. "not interested" 206358 anEvent hand releaseMouseFocus: self. 206359 anEvent wasHandled: true. 206360 anEvent blueButtonChanged 206361 ifTrue:[self blueButtonUp: anEvent] 206362 ifFalse:[self mouseUp: anEvent].! ! 206363 206364!MenuItemMorph methodsFor: 'events' stamp: 'jm 11/4/97 07:15'! 206365handlesMouseDown: evt 206366 206367 ^ true 206368! ! 206369 206370!MenuItemMorph methodsFor: 'events' stamp: 'ar 9/16/2000 14:40'! 206371handlesMouseOver: anEvent 206372 ^true! ! 206373 206374!MenuItemMorph methodsFor: 'events' stamp: 'ar 9/18/2000 21:46'! 206375handlesMouseOverDragging: evt 206376 ^true! ! 206377 206378!MenuItemMorph methodsFor: 'events' stamp: 'RAA 1/18/2001 18:21'! 206379invokeWithEvent: evt 206380 "Perform the action associated with the given menu item." 206381 206382 | selArgCount w | 206383 self isEnabled ifFalse: [^ self]. 206384 target class == HandMorph ifTrue: [(self notObsolete) ifFalse: [^ self]]. 206385 owner ifNotNil:[self isStayUpItem ifFalse:[ 206386 self flag: #workAround. "The tile system invokes menus straightforwardly so the menu might not be in the world." 206387 (w := self world) ifNotNil:[ 206388 owner deleteIfPopUp: evt. 206389 "Repair damage before invoking the action for better feedback" 206390 w displayWorldSafely]]]. 206391 selector ifNil:[^self]. 206392 Cursor normal showWhile: [ "show cursor in case item opens a new MVC window" 206393 (selArgCount := selector numArgs) = 0 206394 ifTrue: 206395 [target perform: selector] 206396 ifFalse: 206397 [selArgCount = arguments size 206398 ifTrue: [target perform: selector withArguments: arguments] 206399 ifFalse: [target perform: selector withArguments: (arguments copyWith: evt)]]].! ! 206400 206401!MenuItemMorph methodsFor: 'events' stamp: 'dgd 9/9/2004 20:37'! 206402mouseEnter: evt 206403 "The mouse entered the receiver" 206404 206405 owner ifNotNil: [owner stayUp ifFalse: [self mouseEnterDragging: evt]]. 206406 206407 self isInDockingBar ifTrue:[ 206408 (owner selectedItem notNil 206409 and:[owner selectedItem ~~ self]) 206410 ifTrue:[owner selectItem: self event: evt.]. 206411 ]. 206412! ! 206413 206414!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 00:24'! 206415mouseEnterDragging: evt 206416 "The mouse entered the receiver. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu." 206417 evt hand mouseFocus == owner ifTrue:[owner selectItem: self event: evt]! ! 206418 206419!MenuItemMorph methodsFor: 'events' stamp: 'sw 5/5/2001 00:25'! 206420mouseLeave: evt 206421 "The mouse has left the interior of the receiver..." 206422 206423 owner ifNotNil: [owner stayUp ifFalse: [self mouseLeaveDragging: evt]]! ! 206424 206425!MenuItemMorph methodsFor: 'events' stamp: 'dgd 2/22/2003 14:52'! 206426mouseLeaveDragging: evt 206427 "The mouse left the receiver. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu." 206428 206429 owner ifNil: [^self]. 206430 evt hand mouseFocus == owner ifFalse: [^self]. 206431 "If we have a submenu, make sure we've got some time to enter it before actually leaving the menu item" 206432 subMenu isNil 206433 ifTrue: [owner selectItem: nil event: evt] 206434 ifFalse: 206435 [self 206436 addAlarm: #deselectTimeOut: 206437 with: evt 206438 after: 500]! ! 206439 206440!MenuItemMorph methodsFor: 'events' stamp: 'dgd 9/9/2004 21:20'! 206441mouseUp: evt 206442 "Handle a mouse up event. Menu items get activated when the mouse is over them. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu." 206443 evt hand mouseFocus == owner ifFalse:[^self]. 206444 self contentString ifNotNil:[ 206445 self contents: self contentString withMarkers: true inverse: true. 206446 self refreshWorld. 206447 (Delay forMilliseconds: 200) wait]. 206448 206449 self isInDockingBar 206450 ifTrue:[ owner rootMenu selectItem: nil event: evt ] 206451 ifFalse:[ self deselect: evt ]. 206452 206453 self invokeWithEvent: evt. 206454! ! 206455 206456 206457!MenuItemMorph methodsFor: 'grabbing' stamp: 'spfa 3/13/2004 18:34'! 206458aboutToBeGrabbedBy: aHand 206459 "Don't allow the receiver to act outside a Menu" 206460 | menu box | 206461 (owner notNil and:[owner submorphs size = 1]) ifTrue:[ 206462 "I am a lonely menuitem already; just grab my owner" 206463 owner stayUp: true. 206464 ^owner aboutToBeGrabbedBy: aHand]. 206465 box := self bounds. 206466 menu := MenuMorph new defaultTarget: nil. 206467 menu addMorphFront: self. 206468 menu bounds: box. 206469 menu stayUp: true. 206470 self isSelected: false. 206471 ^menu! ! 206472 206473!MenuItemMorph methodsFor: 'grabbing' stamp: 'spfa 3/13/2004 18:32'! 206474duplicateMorph: evt 206475 "Make and return a duplicate of the receiver's argument" 206476 | dup menu | 206477 dup := self duplicate isSelected: false. 206478 menu := MenuMorph new defaultTarget: nil. 206479 menu addMorphFront: dup. 206480 menu bounds: self bounds. 206481 menu stayUp: true. 206482 evt hand grabMorph: menu from: owner. "duplicate was ownerless so use #grabMorph:from: here" 206483 ^menu! ! 206484 206485 206486!MenuItemMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:07'! 206487defaultBounds 206488"answer the default bounds for the receiver" 206489 ^ 0 @ 0 extent: 10 @ 10! ! 206490 206491!MenuItemMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 02:05'! 206492deleteIfPopUp: evt 206493 "Recurse up for nested pop ups" 206494 owner ifNotNil:[owner deleteIfPopUp: evt].! ! 206495 206496!MenuItemMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:43'! 206497initialize 206498 "initialize the state of the receiver" 206499 super initialize. 206500 "" 206501 206502 contents := ''. 206503 hasFocus := false. 206504 isEnabled := true. 206505 subMenu := nil. 206506 isSelected := false. 206507 target := nil. 206508 selector := nil. 206509 arguments := nil. 206510 font := Preferences standardMenuFont. 206511 self hResizing: #spaceFill; 206512 vResizing: #shrinkWrap! ! 206513 206514 206515!MenuItemMorph methodsFor: 'layout' stamp: 'dgd 9/4/2004 15:49'! 206516minHeight 206517 | iconHeight | 206518 iconHeight := self hasIcon 206519 ifTrue: [self icon height + 2] 206520 ifFalse: [0]. 206521 ^ self fontToUse height max: iconHeight ! ! 206522 206523!MenuItemMorph methodsFor: 'layout' stamp: 'dgd 7/28/2005 13:12'! 206524minWidth 206525 | subMenuWidth iconWidth markerWidth margin | 206526 subMenuWidth := self hasSubMenu 206527 ifTrue: [10] 206528 ifFalse: [0]. 206529 iconWidth := self hasIcon 206530 ifTrue: [self icon width + 2] 206531 ifFalse: [0]. 206532 markerWidth := self hasMarker 206533 ifTrue: [self submorphBounds width + 8] 206534 ifFalse: [0]. 206535 margin := (self isInDockingBar) 206536 ifTrue: [Preferences tinyDisplay ifFalse:[10] ifTrue:[4]] 206537 ifFalse: [0]. 206538 ^ (self fontToUse widthOfString: contents) 206539 + subMenuWidth + iconWidth + markerWidth + margin! ! 206540 206541 206542!MenuItemMorph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:58'! 206543hResizing 206544 "Default to #spaceFill" 206545 | props | 206546 props := self layoutProperties. 206547 ^props ifNil:[#spaceFill] ifNotNil:[props hResizing].! ! 206548 206549!MenuItemMorph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:59'! 206550vResizing 206551 "Default to #shrinkWrap" 206552 | props | 206553 props := self layoutProperties. 206554 ^props ifNil:[#shrinkWrap] ifNotNil:[props vResizing].! ! 206555 206556 206557!MenuItemMorph methodsFor: 'meta actions' stamp: 'ar 10/10/2000 02:13'! 206558wantsHaloFromClick 206559 "Only if I'm not a lonely submenu" 206560 ^owner notNil and:[owner submorphs size > 1]! ! 206561 206562 206563!MenuItemMorph methodsFor: 'nil' stamp: 'di 2/23/98 16:24'! 206564deselectItem 206565 | item | 206566 self isSelected: false. 206567 subMenu ifNotNil: [subMenu deleteIfPopUp]. 206568 (owner isKindOf: MenuMorph) ifTrue: 206569 [item := owner popUpOwner. 206570 (item isKindOf: MenuItemMorph) ifTrue: [item deselectItem]]. 206571! ! 206572 206573!MenuItemMorph methodsFor: 'nil' stamp: 'jm 11/4/97 07:46'! 206574isEnabled: aBoolean 206575 206576 isEnabled = aBoolean ifTrue: [^ self]. 206577 isEnabled := aBoolean. 206578 self color: (aBoolean ifTrue: [Color black] ifFalse: [Color gray]). 206579! ! 206580 206581 206582!MenuItemMorph methodsFor: 'rounding' stamp: 'dgd 9/1/2004 18:11'! 206583roundedCorners 206584 "Return a list of those corners to round" 206585 self isInDockingBar 206586 ifFalse: [^ super roundedCorners]. 206587 "" 206588 owner isFloating 206589 ifTrue: [^ #(1 4 )]. 206590 owner isAdheringToTop 206591 ifTrue: [^ #(1 4 )]. 206592 owner isAdheringToBottom 206593 ifTrue: [^ #(2 3 )]. 206594 owner isAdheringToLeft 206595 ifTrue: [^ #(1 2 )]. 206596 owner isAdheringToRight 206597 ifTrue: [^ #(3 4 )]. 206598 "" 206599 ^ #(1 2 3 4 )! ! 206600 206601!MenuItemMorph methodsFor: 'rounding' stamp: 'dgd 9/1/2004 18:11'! 206602wantsRoundedCorners 206603 ^ self isInDockingBar 206604 ifTrue: [true] 206605 ifFalse: [super wantsRoundedCorners]! ! 206606 206607 206608!MenuItemMorph methodsFor: 'selecting' stamp: 'dgd 9/13/2004 20:29'! 206609adjacentTo 206610 self isInDockingBar 206611 ifFalse: [^ {self bounds topRight + (10 @ 0). self bounds topLeft}]. 206612 "" 206613 owner isFloating 206614 ifTrue: [^ {self bounds bottomLeft + (5 @ 5)}]. 206615 owner isAdheringToTop 206616 ifTrue: [^ {self bounds bottomLeft + (5 @ 5)}]. 206617 owner isAdheringToLeft 206618 ifTrue: [^ {self bounds topRight + (5 @ 5)}]. 206619 "" 206620 owner isAdheringToBottom 206621 ifTrue: [^ {self bounds topLeft + (5 @ 5)}]. 206622 owner isAdheringToRight 206623 ifTrue: [^ {self bounds topLeft + (5 @ -5)}]. 206624 "" 206625 ^ {self bounds bottomLeft + (3 @ 5)}! ! 206626 206627!MenuItemMorph methodsFor: 'selecting' stamp: 'ar 10/10/2000 01:39'! 206628deselect: evt 206629 self isSelected: false. 206630 subMenu ifNotNil: [ 206631 owner ifNotNil:[owner activeSubmenu: nil]. 206632 self removeAlarm: #deselectTimeOut:].! ! 206633 206634!MenuItemMorph methodsFor: 'selecting' stamp: 'dgd 9/9/2004 21:26'! 206635isSelected 206636 ^ isSelected ! ! 206637 206638!MenuItemMorph methodsFor: 'selecting' stamp: 'ar 9/18/2000 11:09'! 206639isSelected: aBoolean 206640 206641 isSelected := aBoolean. 206642 self changed. 206643! ! 206644 206645!MenuItemMorph methodsFor: 'selecting' stamp: 'dgd 9/1/2004 18:52'! 206646select: evt 206647 self isSelected: true. 206648 owner activeSubmenu: subMenu. 206649 subMenu ifNotNil: [ 206650 subMenu delete. 206651 subMenu 206652 popUpAdjacentTo: self adjacentTo 206653 forHand: evt hand 206654 from: self. 206655 subMenu selectItem: nil event: evt].! ! 206656 206657 206658!MenuItemMorph methodsFor: 'submorphs-accessing' stamp: 'dgd 9/9/2004 20:25'! 206659noteNewOwner: aMorph 206660 "I have just been added as a submorph of aMorph" 206661 super noteNewOwner: aMorph. 206662 206663 self updateLayoutInDockingBar! ! 206664 206665 206666!MenuItemMorph methodsFor: 'private' stamp: 'dgd 3/31/2006 12:15'! 206667bottomArrow 206668 ^ ColorForm 206669 mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 90) asFormOfDepth:8)! ! 206670 206671!MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 17:10'! 206672iconForm 206673 "private - answer the form to be used as the icon" 206674 ^ isEnabled 206675 ifTrue: [self icon] 206676 ifFalse: [self icon asGrayScale]! ! 206677 206678!MenuItemMorph methodsFor: 'private' stamp: 'dgd 3/31/2006 12:16'! 206679leftArrow 206680 ^ ColorForm 206681 mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 180)asFormOfDepth: 8)! ! 206682 206683!MenuItemMorph methodsFor: 'private' stamp: 'ar 9/18/2000 10:27'! 206684notObsolete 206685 "Provide backward compatibility with messages being sent to the Hand. Remove this when no projects made prior to 2.9 are likely to be used. If this method is removed early, the worst that can happen is a notifier when invoking an item in an obsolete menu." 206686 206687 (HandMorph canUnderstand: (selector)) ifTrue: [^ true]. "a modern one" 206688 206689 self inform: 'This world menu is obsolete. 206690Please dismiss the menu and open a new one.'. 206691 ^ false 206692! ! 206693 206694!MenuItemMorph methodsFor: 'private' stamp: 'ar 9/17/2000 18:36'! 206695offImage 206696 "Return the form to be used for indicating an '<off>' marker" 206697 | form | 206698 form := Form extent: (self fontToUse ascent-2) asPoint depth: 16. 206699 (form getCanvas) 206700 frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.9) 206701 borderWidth: 1 borderColor: Color black. 206702 ^form! ! 206703 206704!MenuItemMorph methodsFor: 'private' stamp: 'ar 9/19/2000 09:34'! 206705onImage 206706 "Return the form to be used for indicating an '<off>' marker" 206707 | form | 206708 form := Form extent: (self fontToUse ascent-2) asPoint depth: 16. 206709 (form getCanvas) 206710 frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.8) 206711 borderWidth: 1 borderColor: Color black; 206712 fillRectangle: (form boundingBox insetBy: 2) fillStyle: Color black. 206713 ^form! ! 206714 206715!MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 18:07'! 206716rightArrow 206717 206718 ^ SubMenuMarker! ! 206719 206720!MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 17:51'! 206721selectionFillStyle 206722 "answer the fill style to use with the receiver is the selected 206723 element" 206724 | fill baseColor preferenced | 206725 Display depth <= 2 206726 ifTrue: [^ Color gray]. 206727 206728 preferenced := Preferences menuSelectionColor. 206729 preferenced notNil ifTrue:[^ preferenced]. 206730 206731 baseColor := owner color negated. 206732 Preferences gradientMenu 206733 ifFalse: [^ baseColor]. 206734 fill := GradientFillStyle ramp: {0.0 -> baseColor twiceLighter . 1 -> baseColor twiceDarker}. 206735 fill origin: self topLeft. 206736 (self isInDockingBar 206737 and: [self owner isVertical not]) 206738 ifTrue: [fill direction: 0 @ self height] 206739 ifFalse: [fill direction: self width @ 0]. 206740 ^ fill! ! 206741 206742!MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 18:09'! 206743subMenuMarker 206744 "private - answer the form to be used as submenu marker" 206745 self isInDockingBar 206746 ifFalse: [^ self rightArrow]. 206747 "" 206748 owner isFloating 206749 ifTrue: [^ self bottomArrow]. 206750 owner isAdheringToTop 206751 ifTrue: [^ self bottomArrow]. 206752 owner isAdheringToBottom 206753 ifTrue: [^ self upArrow]. 206754owner isAdheringToLeft ifTrue:[^ self rightArrow]. 206755owner isAdheringToRight ifTrue:[^ self leftArrow]. 206756 "" 206757 ^ self rightArrow! ! 206758 206759!MenuItemMorph methodsFor: 'private' stamp: 'dgd 3/31/2006 12:16'! 206760upArrow 206761 ^ ColorForm 206762 mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 270)asFormOfDepth: 8)! ! 206763 206764!MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 19:24'! 206765updateLayoutInDockingBar 206766 self isInDockingBar 206767 ifFalse: [^ self]. 206768 "" 206769 owner isVertical 206770 ifTrue: ["" 206771 self hResizing: #spaceFill. 206772 self vResizing: #shrinkWrap] 206773 ifFalse: ["" 206774 self hResizing: #shrinkWrap. 206775 self vResizing: #spaceFill]. 206776 self extent: self minWidth @ self minHeight! ! 206777 206778"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 206779 206780MenuItemMorph class 206781 instanceVariableNames: ''! 206782 206783!MenuItemMorph class methodsFor: 'initialization' stamp: 'jm 11/16/97 09:17'! 206784initialize 206785 "MenuItemMorph initialize" 206786 206787 | f | 206788 f := Form 206789 extent: 5@9 206790 fromArray: #(2147483648 3221225472 3758096384 4026531840 4160749568 4026531840 3758096384 3221225472 2147483648) 206791 offset: 0@0. 206792 SubMenuMarker := ColorForm mappingWhiteToTransparentFrom: f. 206793! ! 206794Morph subclass: #MenuLineMorph 206795 instanceVariableNames: '' 206796 classVariableNames: '' 206797 poolDictionaries: '' 206798 category: 'Morphic-Menus'! 206799 206800!MenuLineMorph methodsFor: 'change reporting' stamp: 'dgd 9/1/2004 19:12'! 206801ownerChanged 206802 "The receiver's owner, some kind of a pasteup, has changed its 206803 layout." 206804 super ownerChanged. 206805 self updateLayoutInDockingBar! ! 206806 206807 206808!MenuLineMorph methodsFor: 'drawing' stamp: 'sd 11/8/2003 16:00'! 206809drawOn: aCanvas 206810 | baseColor | 206811 baseColor := Preferences menuColorFromWorld 206812 ifTrue: [owner color twiceDarker] 206813 ifFalse: [Preferences menuAppearance3d 206814 ifTrue: [owner color] 206815 ifFalse: [Preferences menuLineColor]]. 206816 Preferences menuAppearance3d 206817 ifTrue: [ 206818 aCanvas 206819 fillRectangle: (bounds topLeft corner: bounds rightCenter) 206820 color: baseColor twiceDarker. 206821 206822 aCanvas 206823 fillRectangle: (bounds leftCenter corner: bounds bottomRight) 206824 color: baseColor twiceLighter] 206825 ifFalse: [ 206826 aCanvas 206827 fillRectangle: (bounds topLeft corner: bounds bottomRight) 206828 color: baseColor]! ! 206829 206830 206831!MenuLineMorph methodsFor: 'initialization' stamp: 'ar 11/8/2000 23:09'! 206832initialize 206833 super initialize. 206834 self hResizing: #spaceFill; vResizing: #spaceFill.! ! 206835 206836 206837!MenuLineMorph methodsFor: 'layout' stamp: 'dgd 9/1/2004 19:20'! 206838minHeight 206839 "answer the receiver's minHeight" 206840 ^ self isInDockingBar 206841 ifTrue: [owner isVertical 206842 ifTrue: [2] 206843 ifFalse: [10]] 206844 ifFalse: [2]! ! 206845 206846!MenuLineMorph methodsFor: 'layout' stamp: 'dgd 9/1/2004 19:21'! 206847minWidth 206848 "answer the receiver's minWidth" 206849 ^ self isInDockingBar 206850 ifTrue: [owner isVertical 206851 ifTrue: [10] 206852 ifFalse: [2]] 206853 ifFalse: [10]! ! 206854 206855 206856!MenuLineMorph methodsFor: 'submorphs-accessing' stamp: 'dgd 9/1/2004 19:12'! 206857noteNewOwner: aMorph 206858 "I have just been added as a submorph of aMorph" 206859 super noteNewOwner: aMorph. 206860 self updateLayoutInDockingBar! ! 206861 206862 206863!MenuLineMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 19:20'! 206864updateLayoutInDockingBar 206865 self isInDockingBar 206866 ifFalse: [^ self]. 206867 "" 206868 owner isVertical 206869 ifFalse: ["" 206870 self hResizing: #shrinkWrap. 206871 self vResizing: #spaceFill] 206872 ifTrue: ["" 206873 self hResizing: #spaceFill. 206874 self vResizing: #shrinkWrap]. 206875 self extent: self minWidth @ self minHeight! ! 206876AlignmentMorph subclass: #MenuMorph 206877 instanceVariableNames: 'defaultTarget selectedItem stayUp popUpOwner activeSubMenu activatorDockingBar' 206878 classVariableNames: 'CloseBoxImage PushPinImage' 206879 poolDictionaries: '' 206880 category: 'Morphic-Menus'! 206881!MenuMorph commentStamp: '<historical>' prior: 0! 206882Instance variables: 206883 defaultTarget <Object> The default target for creating menu items 206884 selectedItem <MenuItemMorph> The currently selected item in the receiver 206885 stayUp <Boolean> True if the receiver should stay up after clicks 206886 popUpOwner <MenuItemMorph> The menu item that automatically invoked the receiver, if any. 206887 activeSubMenu <MenuMorph> The currently active submenu.! 206888 206889 206890!MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 11/20/2007 13:34'! 206891addToggle: aString selector: aSymbol 206892 "Append a menu item with the given label. If the item is selected, 206893 it will send the given selector to the default target object." 206894 206895 self addToggle: aString 206896 target: defaultTarget 206897 selector: aSymbol 206898 getStateSelector: nil 206899 argumentList: EmptyArray! ! 206900 206901!MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/12/2006 15:32'! 206902addToggle: aString target: anObject selector: aSymbol 206903 "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." 206904 206905 self addToggle: aString 206906 target: anObject 206907 selector: aSymbol 206908 getStateSelector: nil 206909 argumentList: EmptyArray! ! 206910 206911!MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/9/2006 09:25'! 206912addToggle: aString target: anObject selector: aSymbol getStateSelector: stateSymbol 206913 "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." 206914 206915 self addToggle: aString 206916 target: anObject 206917 selector: aSymbol 206918 getStateSelector: stateSymbol 206919 argumentList: EmptyArray! ! 206920 206921!MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/9/2006 09:39'! 206922addToggle: aString target: anObject selector: aSymbol getStateSelector: stateSymbol argumentList: argList 206923 "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." 206924 206925 self addToggle: aString 206926 target: anObject 206927 selector: aSymbol 206928 getStateSelector: stateSymbol 206929 enablementSelector: nil 206930 argumentList: argList! ! 206931 206932!MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/9/2006 09:45'! 206933addToggle: aString target: anObject selector: aSymbol getStateSelector: stateSymbol enablementSelector: enableSymbol 206934 "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." 206935 206936 self addToggle: aString 206937 target: anObject 206938 selector: aSymbol 206939 getStateSelector: stateSymbol 206940 enablementSelector: enableSymbol 206941 argumentList: EmptyArray! ! 206942 206943!MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/9/2006 09:39'! 206944addToggle: aString target: anObject selector: aSymbol getStateSelector: stateSymbol enablementSelector: enableSymbol argumentList: argList 206945 "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." 206946 206947 |item| 206948 item := ToggleMenuItemMorph new 206949 contents: aString; 206950 target: anObject; 206951 selector: aSymbol; 206952 arguments: argList asArray; 206953 getStateSelector: stateSymbol; 206954 enablementSelector: enableSymbol. 206955 self addMorphBack: item. 206956! ! 206957 206958!MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/29/2007 16:28'! 206959adoptPaneColor: paneColor 206960 "Change our color." 206961 206962 super adoptPaneColor: paneColor. 206963 paneColor ifNil: [^self]. 206964 self color: paneColor! ! 206965 206966!MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 14:28'! 206967color: aColor 206968 "Set the receiver's color. Remember the base color in the case of a gradient background." 206969 206970 super color: aColor. 206971 self setProperty: #basicColor toValue: aColor! ! 206972 206973!MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'mtf 9/19/2007 12:26'! 206974mouseDownInTitle: evt 206975 "Handle a mouse down event in the title bar." 206976 "Grab the menu and drag it to some other place" 206977 evt hand grabMorph: self.! ! 206978 206979!MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/16/2007 12:59'! 206980takesKeyboardFocus 206981 "Answer whether the receiver can normally take keyboard focus." 206982 206983 ^true! ! 206984 206985!MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/16/2008 16:37'! 206986themeChanged 206987 "Update the colour if specified." 206988 206989 self color: (self theme menuColorFor: nil). 206990 super themeChanged! ! 206991 206992 206993!MenuMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/17/2008 11:55'! 206994add: wordingString icon: aForm help: helpString subMenu: aMenuMorph 206995 "Append the given submenu with the given label." 206996 206997 self 206998 addToggle: wordingString 206999 target: nil 207000 selector: nil. 207001 self lastItem 207002 icon: aForm; 207003 subMenu: aMenuMorph. 207004 helpString isNil 207005 ifFalse: [self lastItem setBalloonText: helpString].! ! 207006 207007!MenuMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/17/2008 11:45'! 207008add: aString subMenu: aMenuMorph target: target selector: aSymbol argumentList: argList 207009 "Append the given submenu with the given label." 207010 207011 self 207012 addToggle: aString 207013 target: target 207014 selector: aSymbol 207015 getStateSelector: nil 207016 enablementSelector: nil 207017 argumentList: argList. 207018 self lastItem subMenu: aMenuMorph! ! 207019 207020!MenuMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/17/2008 11:46'! 207021add: aString target: target selector: aSymbol argumentList: argList 207022 "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument." 207023 207024 self 207025 addToggle: aString 207026 target: target 207027 selector: aSymbol 207028 getStateSelector: nil 207029 enablementSelector: nil 207030 argumentList: argList! ! 207031 207032!MenuMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/10/2009 16:32'! 207033addStayUpIcons 207034 "Add the titlebar with buttons." 207035 207036 |title closeBox pinBox titleBarArea titleString spacer1 spacer2| 207037 title := submorphs 207038 detect: [:ea | ea hasProperty: #titleString] 207039 ifNone: [self setProperty: #needsTitlebarWidgets toValue: true. 207040 ^self]. 207041 closeBox := IconicButton new target: self; 207042 actionSelector: #delete; 207043 labelGraphic: self theme menuCloseForm; 207044 color: Color transparent; 207045 extent: 18 @ 18; 207046 borderWidth: 0. 207047 pinBox := IconicButton new target: self; 207048 actionSelector: #stayUp:; 207049 arguments: {true}; 207050 labelGraphic: self theme menuPinForm; 207051 color: Color transparent; 207052 extent: 18 @ 18; 207053 borderWidth: 0. 207054 closeBox setBalloonText: 'close this menu' translated. 207055 pinBox setBalloonText: 'keep this menu up' translated. 207056 spacer1 := AlignmentMorph newSpacer: Color transparent. 207057 spacer1 width: 14; 207058 hResizing: #rigid. 207059 spacer2 := AlignmentMorph newSpacer: Color transparent. 207060 spacer2 width: 14; 207061 hResizing: #rigid. 207062 titleBarArea := AlignmentMorph newRow vResizing: #shrinkWrap; 207063 layoutInset: 2; 207064 color: title color; 207065 addMorphBack: closeBox; 207066 addMorphBack: spacer1; 207067 addMorphBack: title; 207068 addMorphBack: spacer2; 207069 addMorphBack: pinBox. 207070 title color: Color transparent. 207071 titleString := title 207072 findDeepSubmorphThat: [:each | each respondsTo: #font:] 207073 ifAbsent: []. 207074 titleString font: Preferences windowTitleFont. 207075 Preferences roundedMenuCorners ifTrue: [ 207076 titleBarArea 207077 roundedCorners: #(1 4); 207078 useRoundedCorners]. 207079 self addMorphFront: titleBarArea. 207080 titleBarArea 207081 setProperty: #titleString 207082 toValue: (title valueOfProperty: #titleString). 207083 title removeProperty: #titleString. 207084 self setProperty: #hasTitlebarWidgets toValue: true. 207085 self removeProperty: #needsTitlebarWidgets. 207086 self removeStayUpItems! ! 207087 207088!MenuMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/16/2008 14:31'! 207089addTitle: aString icon: aForm updatingSelector: aSelector updateTarget: aTarget 207090 "Add a title line at the top of this menu Make aString its initial 207091 contents. 207092 If aSelector is not nil, then periodically obtain fresh values for 207093 its 207094 contents by sending aSelector to aTarget.." 207095 207096 "Overridden to support menu dragging from the title-bar" 207097 207098 | title titleContainer | 207099 title := AlignmentMorph newColumn. 207100 self setTitleParametersFor: title. 207101 "" 207102 aForm isNil 207103 ifTrue: [titleContainer := title] 207104 ifFalse: [| pair | 207105 pair := AlignmentMorph newRow. 207106 207107 pair color: Color transparent. 207108 pair hResizing: #shrinkWrap. 207109 pair layoutInset: 0. 207110 "" 207111 pair addMorphBack: aForm asMorph. 207112 "" 207113 titleContainer := AlignmentMorph newColumn. 207114 titleContainer color: Color transparent. 207115 titleContainer vResizing: #shrinkWrap. 207116 titleContainer wrapCentering: #center. 207117 titleContainer cellPositioning: #topCenter. 207118 titleContainer layoutInset: 0. 207119 pair addMorphBack: titleContainer. 207120 "" 207121 title addMorphBack: pair]. 207122 "" 207123 aSelector 207124 ifNil: ["" 207125 aString asString 207126 linesDo: [:line | titleContainer 207127 addMorphBack: (StringMorph contents: line font: Preferences standardMenuFont)]] 207128 ifNotNil: [| usm | 207129 usm := UpdatingStringMorph on: aTarget selector: aSelector. 207130 usm font: Preferences standardMenuFont. 207131 usm useStringFormat. 207132 usm lock. 207133 titleContainer addMorphBack: usm]. 207134 "" 207135 title setProperty: #titleString toValue: aString. 207136 self addMorphFront: title. 207137 "" 207138 title useSquareCorners. 207139 title on: #mouseDown send: #mouseDownInTitle: to: self. 207140 (self hasProperty: #needsTitlebarWidgets) 207141 ifTrue: [self addStayUpIcons]! ! 207142 207143!MenuMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/17/2008 15:46'! 207144addUpdating: wordingSelector target: target selector: aSymbol argumentList: argList 207145 "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the initial wording of the menu item is obtained by sending the wordingSelector to the target. If the wording prefixed with <yes> or <no>, the on/off state of the menu item will reflect it." 207146 207147 |aString str| 207148 aString := (MessageSend receiver: target selector: wordingSelector) 207149 valueWithEnoughArguments: argList. 207150 str := aString readStream. 207151 (str skipTo: $>) ifTrue: [aString := str upToEnd]. 207152 self 207153 addToggle: aString 207154 target: target 207155 selector: aSymbol 207156 getStateSelector: wordingSelector 207157 enablementSelector: nil 207158 argumentList: argList 207159! ! 207160 207161!MenuMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/17/2008 15:17'! 207162addWithLabel: aLabel enablementSelector: enablementSelector target: target selector: aSymbol argumentList: argList 207163 "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the wording of the menu item is constant, and the optional enablementSelector determines whether or not the item should be enabled." 207164 207165 self 207166 addToggle: aLabel 207167 target: target 207168 selector: aSymbol 207169 getStateSelector: nil 207170 enablementSelector: enablementSelector 207171 argumentList: argList! ! 207172 207173!MenuMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/30/2009 14:07'! 207174keyStroke: evt 207175 "Handle keboard item matching." 207176 207177 | matchString char asc selectable help | 207178 help := UITheme builder newBalloonHelp: 'Enter text to\narrow selection down\to matching items ' withCRs for: self corner: #topLeft. 207179 help popUpForHand: self activeHand. 207180 (self rootMenu hasProperty: #hasUsedKeyboard) 207181 ifFalse: 207182 [self rootMenu setProperty: #hasUsedKeyboard toValue: true. 207183 self changed]. 207184 (evt commandKeyPressed and: [self commandKeyHandler notNil]) 207185 ifTrue: 207186 [self commandKeyHandler commandKeyTypedIntoMenu: evt. 207187 ^self deleteIfPopUp: evt]. 207188 char := evt keyCharacter. 207189 asc := char asciiValue. 207190 char = Character cr 207191 ifTrue: 207192 [selectedItem ifNotNil: 207193 [selectedItem hasSubMenu 207194 ifTrue: 207195 [evt hand newMouseFocus: selectedItem subMenu. 207196 ^evt hand newKeyboardFocus: selectedItem subMenu] 207197 ifFalse: 207198 ["self delete." 207199 207200 ^selectedItem invokeWithEvent: evt]]. 207201 (selectable := self items) size = 1 207202 ifTrue: [^selectable first invokeWithEvent: evt]. 207203 ^self]. 207204 asc = 27 207205 ifTrue: 207206 ["escape key" 207207 207208 self valueOfProperty: #matchString 207209 ifPresentDo: 207210 [:str | 207211 str isEmpty 207212 ifFalse: 207213 ["If filtered, first ESC removes filter" 207214 207215 self setProperty: #matchString toValue: String new. 207216 self selectItem: nil event: evt. 207217 ^self displayFiltered: evt]]. 207218 "If a stand-alone menu, just delete it" 207219 popUpOwner ifNil: [^self delete]. 207220 "If a sub-menu, then deselect, and return focus to outer menu" 207221 self selectItem: nil event: evt. 207222 evt hand newMouseFocus: popUpOwner owner. 207223 ^evt hand newKeyboardFocus: popUpOwner owner]. 207224 (asc = 28 or: [asc = 29]) 207225 ifTrue: 207226 ["left or right arrow key" 207227 207228 (selectedItem notNil and: [selectedItem hasSubMenu]) 207229 ifTrue: 207230 [evt hand newMouseFocus: selectedItem subMenu. 207231 selectedItem subMenu moveSelectionDown: 1 event: evt. 207232 ^evt hand newKeyboardFocus: selectedItem subMenu]]. 207233 asc = 30 ifTrue: [^self moveSelectionDown: -1 event: evt]. "up arrow key" 207234 asc = 31 ifTrue: [^self moveSelectionDown: 1 event: evt]. "down arrow key" 207235 asc = 11 ifTrue: [^self moveSelectionDown: -5 event: evt]. "page up key" 207236 asc = 12 ifTrue: [^self moveSelectionDown: 5 event: evt]. "page down key" 207237 matchString := self valueOfProperty: #matchString ifAbsentPut: [String new]. 207238 matchString := char = Character backspace 207239 ifTrue: 207240 [matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]] 207241 ifFalse: [matchString copyWith: evt keyCharacter]. 207242 self setProperty: #matchString toValue: matchString. 207243 self displayFiltered: evt. 207244 help := BalloonMorph string: 'Enter text to\narrow selection down\to matching items ' withCRs for: self corner: #topLeft. 207245 help popUpForHand: self activeHand. 207246! ! 207247 207248!MenuMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'mtf 9/20/2007 05:37'! 207249mouseDown: evt 207250 "Handle a mouse down event." 207251 "Overridden to not grab on mouse down" 207252 (stayUp or:[self fullContainsPoint: evt position]) 207253 ifFalse:[^self deleteIfPopUp: evt]. "click outside" 207254 self comeToFront! ! 207255 207256!MenuMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/12/2009 16:34'! 207257popUpAdjacentTo: rightOrLeftPoint forHand: hand from: sourceItem 207258 "Present this menu at the given point under control of the given 207259 hand." 207260 | delta tryToPlace selectedOffset | 207261 hand world startSteppingSubmorphsOf: self. 207262 popUpOwner := sourceItem. 207263 self fullBounds. 207264self updateColor. 207265 "ensure layout is current" 207266 selectedOffset := (selectedItem 207267 ifNil: [self items first]) position - self position. 207268 tryToPlace := [:where :mustFit | 207269 self position: where - selectedOffset. 207270 delta := self fullBoundsInWorld amountToTranslateWithin: sourceItem worldBounds. 207271 (delta x = 0 207272 or: [mustFit]) 207273 ifTrue: [delta = (0 @ 0) 207274 ifFalse: [self position: self position + delta]. 207275 sourceItem world addMorphFront: self. 207276 ^ self]]. 207277 tryToPlace value: rightOrLeftPoint first value: false; 207278 value: rightOrLeftPoint last - (self width @ 0) value: false; 207279 value: rightOrLeftPoint first value: true! ! 207280 207281!MenuMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/16/2008 15:35'! 207282setDefaultParameters 207283 "change the receiver's appareance parameters" 207284 207285 | colorFromMenu worldColor menuColor | 207286 207287 colorFromMenu := Preferences menuColorFromWorld 207288 and: [Display depth > 4] 207289 and: [(worldColor := self currentWorld color) isColor]. 207290 207291 menuColor := colorFromMenu 207292 ifTrue: [worldColor luminance > 0.7 207293 ifTrue: [worldColor mixed: 0.85 with: Color black] 207294 ifFalse: [worldColor mixed: 0.4 with: Color white]] 207295 ifFalse: [self theme menuColorFor: 207296 ((UIManager default respondsTo: #modalMorph) 207297 ifTrue: [UIManager default modalMorph] 207298 ifFalse: [nil])]. 207299 207300 self color: menuColor. 207301 self borderWidth: Preferences menuBorderWidth. 207302 207303 Preferences menuAppearance3d ifTrue: [ 207304 self borderStyle: BorderStyle thinGray. 207305 self 207306 addDropShadow; 207307 shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.666); 207308 shadowOffset: 1 @ 1 207309 ] 207310 ifFalse: [ 207311 | menuBorderColor | 207312 menuBorderColor := colorFromMenu 207313 ifTrue: [worldColor muchDarker] 207314 ifFalse: [Preferences menuBorderColor]. 207315 self borderColor: menuBorderColor. 207316 ]. 207317 207318 207319 self layoutInset: 3. 207320! ! 207321 207322!MenuMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/16/2008 15:34'! 207323setTitleParametersFor: aMenuTitle 207324 | menuTitleColor menuTitleBorderColor | 207325 Preferences roundedMenuCorners 207326 ifTrue: [aMenuTitle useRoundedCorners]. 207327 207328 menuTitleColor := Preferences menuColorFromWorld 207329 ifTrue: [self color darker] 207330 ifFalse: [self theme menuTitleColorFor: 207331 ((UIManager default respondsTo: #modalMorph) 207332 ifTrue: [UIManager default modalMorph] 207333 ifFalse: [nil])]. 207334 207335 menuTitleBorderColor := Preferences menuAppearance3d 207336 ifTrue: [#inset] 207337 ifFalse: [Preferences menuColorFromWorld 207338 ifTrue: [self color darker muchDarker] 207339 ifFalse: [Preferences menuTitleBorderColor]]. 207340 207341 aMenuTitle 207342 setColor: menuTitleColor 207343 borderWidth: 0 207344 borderColor: menuTitleBorderColor; 207345 vResizing: #shrinkWrap; 207346 wrapCentering: #center; 207347 cellPositioning: #topCenter; 207348 layoutInset: 0. 207349! ! 207350 207351!MenuMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/10/2009 13:14'! 207352updateColor 207353 "Update the color of the menu." 207354 207355 | fill title bc | 207356 Preferences gradientMenu 207357 ifFalse: [^ self]. 207358 bc := self valueOfProperty: #basicColor ifAbsent: [self theme menuColor]. 207359 fill := GradientFillStyle 207360 ramp: {0.0 -> (bc alphaMixed: 0.2 with: Color white). 1.0 -> bc}. 207361 fill 207362 radial: false; 207363 origin: self topLeft; 207364 direction: 0 @ self height. 207365 self fillStyle: fill. 207366 "update the title color" 207367 title := self allMorphs 207368 detect: [:each | each hasProperty: #titleString] 207369 ifNone: [^ self]. 207370 fill := GradientFillStyle ramp: {0.0 -> title color twiceLighter. 1 -> title color twiceDarker}. 207371 fill 207372 origin: title topLeft; 207373 direction: title width @ 0. 207374 title fillStyle: fill! ! 207375 207376 207377!MenuMorph methodsFor: 'accessing' stamp: 'dgd 9/1/2004 17:56'! 207378activatedFromDockingBar: aDockingBar 207379 activatorDockingBar := aDockingBar! ! 207380 207381!MenuMorph methodsFor: 'accessing' stamp: 'dgd 9/13/2004 19:59'! 207382addBlankIconsIfNecessary: anIcon 207383 "If any of my items have an icon, ensure that all do by using 207384 anIcon for those that don't" 207385 self items 207386 reject: [:each | each hasIconOrMarker] 207387 thenDo: [:each | each icon: anIcon]! ! 207388 207389!MenuMorph methodsFor: 'accessing' stamp: 'sw 12/4/2001 21:22'! 207390commandKeyHandler 207391 "Answer the receiver's commandKeyHandler" 207392 207393 ^ self valueOfProperty: #commandKeyHandler ifAbsent: [nil]! ! 207394 207395!MenuMorph methodsFor: 'accessing' stamp: 'sw 12/4/2001 21:23'! 207396commandKeyHandler: anObject 207397 "Set the receiver's commandKeyHandler. Whatever you set here needs to be prepared to respond to the message #commandKeyTypedIntoMenu: " 207398 207399 self setProperty: #commandKeyHandler toValue: anObject! ! 207400 207401!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 13:19'! 207402defaultTarget 207403 ^defaultTarget! ! 207404 207405!MenuMorph methodsFor: 'accessing' stamp: 'dgd 9/13/2004 13:36'! 207406hasItems 207407 "Answer if the receiver has menu items" 207408 ^ submorphs 207409 anySatisfy: [:each | each isKindOf: MenuItemMorph] ! ! 207410 207411!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:18'! 207412hasSubMenu: aMenuMorph 207413 self items do: [:each | (each hasSubMenu: aMenuMorph) ifTrue:[^true]]. 207414 ^ false 207415! ! 207416 207417!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:22'! 207418itemWithWording: wording 207419 "If any of the receiver's items or submenu items have the given wording (case-blind comparison done), then return it, else return nil." 207420 | found | 207421 self items do:[:anItem | 207422 found := anItem itemWithWording: wording. 207423 found ifNotNil:[^found]]. 207424 ^ nil! ! 207425 207426!MenuMorph methodsFor: 'accessing' stamp: 'nk 6/8/2004 16:52'! 207427lastItem 207428 ^ submorphs reverse 207429 detect: [ :m | m isKindOf: MenuItemMorph ] 207430 ifNone: [ submorphs last ]! ! 207431 207432!MenuMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 23:18'! 207433lastSelection 207434 "Return the label of the last selected item or nil." 207435 207436 selectedItem isNil ifTrue: [^selectedItem selector] ifFalse: [^nil]! ! 207437 207438!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 10:06'! 207439popUpOwner 207440 "Return the current pop-up owner that is the menu item that automatically initiated the receiver." 207441 ^ popUpOwner 207442! ! 207443 207444!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 10:07'! 207445popUpOwner: aMenuItemMorph 207446 "Set the current pop-up owner" 207447 popUpOwner := aMenuItemMorph. 207448! ! 207449 207450!MenuMorph methodsFor: 'accessing' stamp: 'di 12/10/2001 22:11'! 207451rootMenu 207452 popUpOwner ifNil: [^ self]. 207453 popUpOwner owner ifNil: [^ self]. 207454 ^ popUpOwner owner rootMenu! ! 207455 207456!MenuMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! 207457stayUp 207458 207459 ^ stayUp 207460! ! 207461 207462!MenuMorph methodsFor: 'accessing' stamp: 'alain.plantec 2/9/2009 16:16'! 207463stayUp: aBoolean 207464 207465 stayUp := aBoolean. 207466 aBoolean ifTrue: [ self removeStayUpBox ].! ! 207467 207468!MenuMorph methodsFor: 'accessing' stamp: 'dgd 9/1/2004 17:57'! 207469wasActivatedFromDockingBar 207470 "answer true if the receiver was activated from a docking bar" 207471 ^ activatorDockingBar notNil! ! 207472 207473 207474!MenuMorph methodsFor: 'construction' stamp: 'dgd 10/1/2004 13:48'! 207475addAllFrom: aMenuMorph 207476 aMenuMorph submorphs 207477 do: [:each | 207478 (each isKindOf: MenuItemMorph) 207479 ifTrue: [self 207480 add: each contents 207481 target: each target 207482 selector: each selector 207483 argumentList: each arguments]. 207484 (each isKindOf: MenuLineMorph) 207485 ifTrue: [self addLine]] ! ! 207486 207487!MenuMorph methodsFor: 'construction' stamp: 'dgd 9/13/2004 13:35'! 207488addTitle: aString icon: aForm 207489 "Add a title line at the top of this menu." 207490 self 207491 addTitle: aString 207492 icon: aForm 207493 updatingSelector: nil 207494 updateTarget: nil ! ! 207495 207496!MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'! 207497add: aString action: aSymbol 207498 "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." 207499 "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." 207500 207501 self add: aString 207502 target: defaultTarget 207503 selector: aSymbol 207504 argumentList: EmptyArray. 207505! ! 207506 207507!MenuMorph methodsFor: 'construction' stamp: 'dgd 9/20/2004 14:25'! 207508add: wordingString help: helpString action: aSymbol 207509 "Append a menu item with the given label. If the item is 207510 selected, it will send the given selector to the default target 207511 object." 207512 "Details: Note that the menu item added captures the default 207513 target object at the time the item is added; the default target 207514 can later be changed before added additional items without 207515 affecting the targets of previously added entries. The model is 207516 that each entry is like a button that knows everything it needs 207517 to perform its action." 207518 self 207519 add: wordingString 207520 target: defaultTarget 207521 selector: aSymbol 207522 argumentList: EmptyArray. 207523self balloonTextForLastItem:helpString! ! 207524 207525!MenuMorph methodsFor: 'construction' stamp: 'dgd 9/13/2004 14:01'! 207526add: wordingString icon: aForm subMenu: aMenuMorph 207527 "Append the given submenu with the given label." 207528 ^ self 207529 add: wordingString 207530 icon: aForm 207531 help: nil 207532 subMenu: aMenuMorph! ! 207533 207534!MenuMorph methodsFor: 'construction' stamp: 'sw 5/1/1998 00:48'! 207535add: aString selector: aSymbol argument: arg 207536 207537 self add: aString 207538 target: defaultTarget 207539 selector: aSymbol 207540 argumentList: (Array with: arg) 207541! ! 207542 207543!MenuMorph methodsFor: 'construction' stamp: 'dgd 9/13/2004 14:01'! 207544add: aString subMenu: aMenuMorph 207545 "Append the given submenu with the given label." 207546 self 207547 add: aString 207548 icon: nil 207549 subMenu: aMenuMorph! ! 207550 207551!MenuMorph methodsFor: 'construction' stamp: 'sw 4/17/1998 22:45'! 207552add: aString target: aTarget action: aSymbol 207553 self add: aString 207554 target: aTarget 207555 selector: aSymbol 207556 argumentList: EmptyArray 207557! ! 207558 207559!MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'! 207560add: aString target: anObject selector: aSymbol 207561 "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." 207562 207563 self add: aString 207564 target: anObject 207565 selector: aSymbol 207566 argumentList: EmptyArray. 207567! ! 207568 207569!MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'! 207570add: aString target: target selector: aSymbol argument: arg 207571 "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument." 207572 207573 self add: aString 207574 target: target 207575 selector: aSymbol 207576 argumentList: (Array with: arg) 207577! ! 207578 207579!MenuMorph methodsFor: 'construction' stamp: 'dgd 9/13/2004 13:35'! 207580addLine 207581 "Append a divider line to this menu. Suppress duplicate lines." 207582 self hasItems 207583 ifFalse: [^ self]. 207584 (self lastSubmorph isKindOf: MenuLineMorph) 207585 ifFalse: [self addMorphBack: MenuLineMorph new] ! ! 207586 207587!MenuMorph methodsFor: 'construction' stamp: 'sd 3/1/2008 21:35'! 207588addList: aList 207589 "Add the given items to this menu, where each item is a pair (<string> <actionSelector>).. If an element of the list is simply the symobl $-, add a line to the receiver. The optional third element of each entry, if present, provides balloon help." 207590 207591 aList do: [:tuple | 207592 (tuple == #-) 207593 ifTrue: [self addLine] 207594 ifFalse: 207595 [self add: tuple first capitalized action: tuple second. 207596 tuple size > 2 ifTrue: 207597 [self balloonTextForLastItem: tuple third]]]! ! 207598 207599!MenuMorph methodsFor: 'construction' stamp: 'nk 2/15/2004 16:19'! 207600addService: aService for: serviceUser 207601 "Append a menu item with the given service. If the item is selected, it will perform the given service." 207602 207603 aService addServiceFor: serviceUser toMenu: self.! ! 207604 207605!MenuMorph methodsFor: 'construction' stamp: 'nk 2/15/2004 16:11'! 207606addServices2: services for: served extraLines: linesArray 207607 207608 services withIndexDo: [:service :i | 207609 service addServiceFor: served toMenu: self. 207610 self lastItem setBalloonText: service description. 207611 (linesArray includes: i) ifTrue: [self addLine] ] 207612! ! 207613 207614!MenuMorph methodsFor: 'construction' stamp: 'nk 11/26/2002 13:53'! 207615addServices: services for: served extraLines: linesArray 207616 207617 services withIndexDo: [:service :i | 207618 self addService: service for: served. 207619 submorphs last setBalloonText: service description. 207620 (linesArray includes: i) | service useLineAfter 207621 ifTrue: [self addLine]]. 207622! ! 207623 207624!MenuMorph methodsFor: 'construction' stamp: 'nk 4/6/2002 22:41'! 207625addStayUpItem 207626 "Append a menu item that can be used to toggle this menu's persistence." 207627 207628 (self valueOfProperty: #hasTitlebarWidgets ifAbsent: [ false ]) 207629 ifTrue: [ ^self ]. 207630 self addStayUpIcons.! ! 207631 207632!MenuMorph methodsFor: 'construction' stamp: 'nk 4/6/2002 22:41'! 207633addStayUpItemSpecial 207634 "Append a menu item that can be used to toggle this menu's persistent." 207635 207636 "This variant is resistant to the MVC compatibility in #setInvokingView:" 207637 207638 (self valueOfProperty: #hasTitlebarWidgets ifAbsent: [ false ]) 207639 ifTrue: [ ^self ]. 207640 self addStayUpIcons.! ! 207641 207642!MenuMorph methodsFor: 'construction' stamp: 'sw 6/19/1999 23:09'! 207643addTitle: aString 207644 "Add a title line at the top of this menu." 207645 207646 self addTitle: aString updatingSelector: nil updateTarget: nil! ! 207647 207648!MenuMorph methodsFor: 'construction' stamp: 'dgd 4/3/2006 13:01'! 207649addTitle: aString updatingSelector: aSelector updateTarget: aTarget 207650 "Add a title line at the top of this menu Make aString its initial 207651 contents. 207652 If aSelector is not nil, then periodically obtain fresh values for 207653 its contents by sending aSelector to aTarget.." 207654 ^ self 207655 addTitle: aString 207656 icon: nil 207657 updatingSelector: aSelector 207658 updateTarget: aTarget! ! 207659 207660!MenuMorph methodsFor: 'construction' stamp: 'nk 11/25/2003 09:59'! 207661addTranslatedList: aList 207662 "Add the given items to this menu, where each item is a pair (<string> <actionSelector>).. If an element of the list is simply the symobl $-, add a line to the receiver. The optional third element of each entry, if present, provides balloon help. 207663 The first and third items will be translated." 207664 207665 aList do: [:tuple | 207666 (tuple == #-) 207667 ifTrue: [self addLine] 207668 ifFalse: 207669 [self add: tuple first translated action: tuple second. 207670 tuple size > 2 ifTrue: 207671 [self balloonTextForLastItem: tuple third translated ]]]! ! 207672 207673!MenuMorph methodsFor: 'construction' stamp: 'sw 6/11/1999 16:49'! 207674addUpdating: aWordingSelector action: aSymbol 207675 207676 self addUpdating: aWordingSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray 207677! ! 207678 207679!MenuMorph methodsFor: 'construction' stamp: 'sw 6/21/1999 11:34'! 207680addUpdating: aWordingSelector enablement: anEnablementSelector action: aSymbol 207681 207682 self addUpdating: aWordingSelector enablementSelector: anEnablementSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray 207683! ! 207684 207685!MenuMorph methodsFor: 'construction' stamp: 'sw 11/6/2000 13:39'! 207686addUpdating: wordingSelector enablementSelector: enablementSelector target: target selector: aSymbol argumentList: argList 207687 "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target, and the optional enablementSelector determines whether or not the item should be enabled. Answer the item itself." 207688 207689 | item | 207690 item := UpdatingMenuItemMorph new 207691 target: target; 207692 selector: aSymbol; 207693 wordingProvider: target wordingSelector: wordingSelector; 207694 enablementSelector: enablementSelector; 207695 arguments: argList asArray. 207696 self addMorphBack: item. 207697 ^ item 207698! ! 207699 207700!MenuMorph methodsFor: 'construction' stamp: 'sw 6/11/1999 17:26'! 207701addUpdating: aWordingSelector target: aTarget action: aSymbol 207702 207703 self addUpdating: aWordingSelector target: aTarget selector: aSymbol argumentList: EmptyArray 207704! ! 207705 207706!MenuMorph methodsFor: 'construction' stamp: 'sw 8/28/2000 18:02'! 207707addWithLabel: aLabel enablement: anEnablementSelector action: aSymbol 207708 207709 self addWithLabel: aLabel enablementSelector: anEnablementSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray 207710! ! 207711 207712!MenuMorph methodsFor: 'construction' stamp: 'sw 11/5/1998 21:13'! 207713balloonTextForLastItem: balloonText 207714 submorphs last setBalloonText: balloonText! ! 207715 207716!MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'! 207717defaultTarget: anObject 207718 "Set the default target for adding menu items." 207719 207720 defaultTarget := anObject. 207721! ! 207722 207723!MenuMorph methodsFor: 'construction' stamp: 'yo 7/16/2003 15:15'! 207724labels: labelList lines: linesArray selections: selectionsArray 207725 "This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:." 207726 207727 "Labels can be either a sting with embedded crs, or a collection of strings." 207728 207729 | labelArray | 207730 labelArray := (labelList isString) 207731 ifTrue: [labelList findTokens: String cr] 207732 ifFalse: [labelList]. 207733 1 to: labelArray size 207734 do: 207735 [:i | 207736 self add: (labelArray at: i) action: (selectionsArray at: i). 207737 (linesArray includes: i) ifTrue: [self addLine]]! ! 207738 207739!MenuMorph methodsFor: 'construction' stamp: 'sw 7/1/1999 22:21'! 207740title: aString 207741 "Add a title line at the top of this menu." 207742 207743 self addTitle: aString! ! 207744 207745 207746!MenuMorph methodsFor: 'control' stamp: 'dgd 9/1/2004 17:57'! 207747activeSubmenu: aSubmenu 207748 activeSubMenu 207749 ifNotNil: [activeSubMenu delete]. 207750 activeSubMenu := aSubmenu. 207751 aSubmenu 207752 ifNotNil: [ 207753 activeSubMenu activatedFromDockingBar: nil. 207754]! ! 207755 207756!MenuMorph methodsFor: 'control' stamp: 'ar 10/10/2000 00:54'! 207757deleteIfPopUp: evt 207758 "Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu." 207759 207760 stayUp ifFalse: [self topRendererOrSelf delete]. 207761 (popUpOwner notNil) ifTrue: [ 207762 popUpOwner isSelected: false. 207763 popUpOwner deleteIfPopUp: evt]. 207764 evt ifNotNil:[evt hand releaseMouseFocus: self].! ! 207765 207766!MenuMorph methodsFor: 'control' stamp: 'alain.plantec 2/9/2009 12:20'! 207767displayAt: aPoint during: aBlock 207768 "Add this menu to the Morphic world during the execution of the given block." 207769 ActiveWorld addMorph: self centeredNear: aPoint. 207770 self world displayWorld. "show myself" 207771 aBlock value. 207772 self delete! ! 207773 207774!MenuMorph methodsFor: 'control' stamp: 'ar 12/27/2001 22:46'! 207775popUpAt: aPoint forHand: hand in: aWorld 207776 "Present this menu at the given point under control of the given hand. Allow keyboard input into the menu." 207777 207778 ^ self popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: Preferences menuKeyboardControl! ! 207779 207780!MenuMorph methodsFor: 'control' stamp: 'tak 1/6/2005 13:28'! 207781popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean 207782 "Present this menu at the given point under control of the given 207783 hand." 207784 | evt | 207785 aWorld submorphs 207786 select: [ :each | (each isKindOf: MenuMorph) 207787 and: [each stayUp not]] 207788 thenCollect: [ :menu | menu delete]. 207789 207790 self items isEmpty 207791 ifTrue: [^ self]. 207792 207793 MenuIcons decorateMenu: self. 207794 207795 (self submorphs 207796 select: [:m | m isKindOf: UpdatingMenuItemMorph]) 207797 do: [:m | m updateContents]. 207798 "precompute width" 207799 self 207800 positionAt: aPoint 207801 relativeTo: (selectedItem 207802 ifNil: [self items first]) 207803 inWorld: aWorld. 207804 aWorld addMorphFront: self. 207805 "Acquire focus for valid pop up behavior" 207806 hand newMouseFocus: self. 207807 aBoolean 207808 ifTrue: [hand newKeyboardFocus: self]. 207809 evt := hand lastEvent. 207810 (evt isKeyboard 207811 or: [evt isMouse 207812 and: [evt anyButtonPressed not]]) 207813 ifTrue: ["Select first item if button not down" 207814 self moveSelectionDown: 1 event: evt]. 207815 self updateColor. 207816 self changed! ! 207817 207818!MenuMorph methodsFor: 'control' stamp: 'alain.plantec 2/9/2009 14:29'! 207819popUpEvent: evt in: aWorld 207820 "Present this menu in response to the given event." 207821 207822 | aHand aPosition | 207823 aHand := evt ifNotNil: [evt hand] ifNil: [ActiveHand]. 207824 aPosition := aHand position truncated. 207825 ^ self popUpAt: aPosition forHand: aHand in: aWorld 207826! ! 207827 207828!MenuMorph methodsFor: 'control' stamp: 'alain.plantec 2/9/2009 14:29'! 207829popUpForHand: hand in: aWorld 207830 | p | 207831 "Present this menu under control of the given hand." 207832 207833 p := hand position truncated. 207834 ^self popUpAt: p forHand: hand in: aWorld 207835! ! 207836 207837!MenuMorph methodsFor: 'control' stamp: 'sw 2/18/2001 00:52'! 207838popUpInWorld 207839 "Present this menu in the current World" 207840 207841 ^ self popUpInWorld: self currentWorld! ! 207842 207843!MenuMorph methodsFor: 'control' stamp: 'ar 10/5/2000 19:31'! 207844popUpInWorld: aWorld 207845 "Present this menu under control of the given hand." 207846 ^self popUpAt: aWorld primaryHand position forHand: aWorld primaryHand in: aWorld 207847! ! 207848 207849!MenuMorph methodsFor: 'control' stamp: 'sw 12/17/2001 16:43'! 207850popUpNoKeyboard 207851 "Present this menu in the current World, *not* allowing keyboard input into the menu" 207852 207853 ^ self popUpAt: ActiveHand position forHand: ActiveHand in: ActiveWorld allowKeyboard: false! ! 207854 207855!MenuMorph methodsFor: 'control' stamp: 'alain.plantec 2/9/2009 12:41'! 207856selectItem: aMenuItem event: anEvent 207857 selectedItem ifNotNil:[selectedItem deselect: anEvent]. 207858 selectedItem := aMenuItem. 207859 selectedItem ifNotNil:[selectedItem select: anEvent].! ! 207860 207861!MenuMorph methodsFor: 'control' stamp: 'sw 2/7/2002 12:06'! 207862wantsToBeDroppedInto: aMorph 207863 "Return true if it's okay to drop the receiver into aMorph. A single-item MenuMorph is in effect a button rather than a menu, and as such should not be reluctant to be dropped into another object." 207864 207865 ^ (aMorph isWorldMorph or: [submorphs size == 1]) or: 207866 [Preferences systemWindowEmbedOK]! ! 207867 207868 207869!MenuMorph methodsFor: 'copying' stamp: 'ar 9/18/2000 09:34'! 207870veryDeepFixupWith: deepCopier 207871 "If fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals." 207872 207873super veryDeepFixupWith: deepCopier. 207874defaultTarget := deepCopier references at: defaultTarget ifAbsent: [defaultTarget]. 207875popUpOwner := deepCopier references at: popUpOwner ifAbsent: [popUpOwner]. 207876activeSubMenu := deepCopier references at: activeSubMenu ifAbsent:[activeSubMenu].! ! 207877 207878!MenuMorph methodsFor: 'copying' stamp: 'dgd 9/1/2004 17:54'! 207879veryDeepInner: deepCopier 207880 "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." 207881 207882super veryDeepInner: deepCopier. 207883"defaultTarget := defaultTarget. Weakly copied" 207884selectedItem := selectedItem veryDeepCopyWith: deepCopier. 207885stayUp := stayUp veryDeepCopyWith: deepCopier. 207886popUpOwner := popUpOwner. "Weakly copied" 207887activeSubMenu := activeSubMenu. "Weakly copied" 207888activatorDockingBar := activatorDockingBar. "Weakly copied" 207889! ! 207890 207891 207892!MenuMorph methodsFor: 'drawing' stamp: 'dgd 4/3/2006 10:37'! 207893drawOn: aCanvas 207894 "Draw the menu. Add keyboard-focus feedback if appropriate" 207895 207896 super drawOn: aCanvas. 207897 207898 (ActiveHand notNil 207899 and: [ActiveHand keyboardFocus == self] 207900 and: [self rootMenu hasProperty: #hasUsedKeyboard]) 207901 ifTrue: [ 207902 aCanvas 207903 frameAndFillRectangle: self innerBounds 207904 fillColor: Color transparent 207905 borderWidth: Preferences menuBorderWidth 207906 borderColor: Preferences keyboardFocusColor 207907 ]. 207908! ! 207909 207910 207911!MenuMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 14:23'! 207912justDroppedInto: aMorph event: evt 207913 | halo | 207914 super justDroppedInto: aMorph event: evt. 207915 halo := evt hand halo. 207916 (halo notNil and:[halo target hasOwner: self]) ifTrue:[ 207917 "Grabbed single menu item" 207918 self addHalo: evt. 207919 ]. 207920 stayUp ifFalse:[evt hand newMouseFocus: self].! ! 207921 207922!MenuMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:16'! 207923undoGrabCommand 207924 ^nil! ! 207925 207926 207927!MenuMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:35'! 207928activate: evt 207929 "Receiver should be activated; e.g., so that control passes correctly." 207930 evt hand newMouseFocus: self.! ! 207931 207932!MenuMorph methodsFor: 'events' stamp: 'di 12/5/2001 10:26'! 207933handleFocusEvent: evt 207934 "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." 207935 self processEvent: evt. 207936 207937 "Need to handle keyboard input if we have the focus." 207938 evt isKeyboard ifTrue: [^ self handleEvent: evt]. 207939 207940 "We need to handle button clicks outside and transitions to local popUps so throw away everything else" 207941 (evt isMouseOver or:[evt isMouse not]) ifTrue:[^self]. 207942 "What remains are mouse buttons and moves" 207943 evt isMove ifFalse:[^self handleEvent: evt]. "handle clicks outside by regular means" 207944 "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." 207945 selectedItem ifNotNil:[(selectedItem activateSubmenu: evt) ifTrue:[^self]]. 207946 "Note: The following does not traverse upwards but it's the best I can do for now" 207947 popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: evt) ifTrue:[^self]].! ! 207948 207949!MenuMorph methodsFor: 'events' stamp: 'ar 9/18/2000 10:13'! 207950handlesMouseDown: evt 207951 ^true! ! 207952 207953!MenuMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:57'! 207954mouseUp: evt 207955 "Handle a mouse up event. 207956 Note: This might be sent from a modal shell." 207957 (self fullContainsPoint: evt position) ifFalse:[ 207958 "Mouse up outside. Release eventual focus and delete if pop up." 207959 evt hand releaseMouseFocus: self. 207960 ^self deleteIfPopUp: evt]. 207961 stayUp ifFalse:[ 207962 "Still in pop-up transition; keep focus" 207963 evt hand newMouseFocus: self].! ! 207964 207965 207966!MenuMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 01:57'! 207967delete 207968 activeSubMenu ifNotNil:[activeSubMenu delete]. 207969 ^super delete! ! 207970 207971!MenuMorph methodsFor: 'initialization' stamp: 'alain.plantec 2/9/2009 12:18'! 207972initialize 207973 super initialize. 207974 207975 bounds := 0 @ 0 corner: 40 @ 10. 207976 207977 self setDefaultParameters. 207978 207979 self listDirection: #topToBottom. 207980 self hResizing: #shrinkWrap. 207981 self vResizing: #shrinkWrap. 207982 defaultTarget := nil. 207983 selectedItem := nil. 207984 stayUp := false. 207985 popUpOwner := nil. 207986 self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber. 207987 Preferences roundedMenuCorners 207988 ifTrue: [self useRoundedCorners]. 207989! ! 207990 207991 207992!MenuMorph methodsFor: 'invoking' stamp: 'alain.plantec 2/9/2009 12:19'! 207993informUserAt: aPoint during: aBlock 207994 "Add this menu to the Morphic world during the execution of the given 207995 block. " 207996 | title w | 207997 title := self allMorphs 207998 detect: [:ea | ea hasProperty: #titleString]. 207999 title := title submorphs first. 208000 self visible: false. 208001 w := ActiveWorld. 208002 aBlock 208003 value: [:string | 208004 self visible 208005 ifFalse: [w addMorph: self centeredNear: aPoint. 208006 self visible: true]. 208007 title contents: string. 208008 self setConstrainedPosition: Sensor cursorPoint hangOut: false. 208009 self changed. 208010 w displayWorld 208011 "show myself"]. 208012 self delete. 208013 w displayWorld! ! 208014 208015!MenuMorph methodsFor: 'invoking' stamp: 'alain.plantec 2/9/2009 11:52'! 208016invokeAt: aPoint in: aWorld 208017 "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." 208018 "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." 208019 208020 ^ self invokeAt: aPoint in: aWorld allowKeyboard: Preferences menuKeyboardControl! ! 208021 208022!MenuMorph methodsFor: 'invoking' stamp: 'alain.plantec 2/9/2009 14:20'! 208023invokeAt: aPoint in: aWorld allowKeyboard: aBoolean 208024 "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." 208025 "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." 208026 | w originalFocusHolder | 208027 originalFocusHolder := aWorld primaryHand keyboardFocus. 208028 self popUpAt: aPoint forHand: aWorld primaryHand in: aWorld allowKeyboard: aBoolean. 208029 w := aWorld outermostWorldMorph. "containing hand" 208030 [self isInWorld] whileTrue: [w doOneSubCycle]. 208031 self delete. 208032 originalFocusHolder ifNotNil: [aWorld primaryHand newKeyboardFocus: originalFocusHolder]. 208033 ^ selectedItem ifNotNil: [selectedItem target] 208034! ! 208035 208036 208037!MenuMorph methodsFor: 'keyboard control' stamp: 'cmm 3/26/2003 22:52'! 208038displayFiltered: evt 208039 | matchStr allItems isMatch matches feedbackMorph | 208040 matchStr := self valueOfProperty: #matchString. 208041 allItems := self submorphs select: [:m | m isKindOf: MenuItemMorph]. 208042 matches := allItems select: [:m | 208043 isMatch := 208044 matchStr isEmpty or: [ 208045 m contents includesSubstring: matchStr caseSensitive: false]. 208046 m isEnabled: isMatch. 208047 isMatch]. 208048 feedbackMorph := self valueOfProperty: #feedbackMorph. 208049 feedbackMorph ifNil: [ 208050 feedbackMorph := 208051 TextMorph new 208052 autoFit: true; 208053 color: Color darkGray. 208054 self 208055 addLine; 208056 addMorphBack: feedbackMorph lock. 208057 self setProperty: #feedbackMorph toValue: feedbackMorph. 208058 self fullBounds. "Lay out for submorph adjacency"]. 208059 feedbackMorph contents: '<', matchStr, '>'. 208060 matchStr isEmpty ifTrue: [ 208061 feedbackMorph delete. 208062 self submorphs last delete. 208063 self removeProperty: #feedbackMorph]. 208064 matches size >= 1 ifTrue: [ 208065 self selectItem: matches first event: evt] 208066! ! 208067 208068!MenuMorph methodsFor: 'keyboard control' stamp: 'rr 3/24/2004 13:45'! 208069filterListWith: char 208070 | matchString | 208071 matchString := self valueOfProperty: #matchString ifAbsentPut: [String new]. 208072 matchString := char = Character backspace 208073 ifTrue: 208074 [matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]] 208075 ifFalse: [matchString copyWith: char]. 208076 self setProperty: #matchString toValue: matchString! ! 208077 208078!MenuMorph methodsFor: 'keyboard control' stamp: 'sw 12/4/2001 20:13'! 208079handlesKeyboard: evt 208080 "Answer whether the receiver handles the keystroke represented by the event" 208081 208082 ^ evt anyModifierKeyPressed not or: [evt commandKeyPressed and: [self commandKeyHandler notNil]]! ! 208083 208084!MenuMorph methodsFor: 'keyboard control' stamp: 'di 12/5/2001 11:41'! 208085keyboardFocusChange: aBoolean 208086 "Notify change due to green border for keyboard focus" 208087 208088 self changed! ! 208089 208090!MenuMorph methodsFor: 'keyboard control' stamp: 'rr 3/24/2004 13:41'! 208091moveDown: evt 208092 ^self moveSelectionDown: 1 event: evt! ! 208093 208094!MenuMorph methodsFor: 'keyboard control' stamp: 'rr 3/24/2004 13:42'! 208095moveRightOrDown: evt 208096 selectedItem ifNotNil: 208097 [selectedItem hasSubMenu 208098 ifTrue: 208099 [self selectSubMenu: evt. 208100 selectedItem subMenu moveDown: evt] 208101 ifFalse: [self moveDown: evt]]! ! 208102 208103!MenuMorph methodsFor: 'keyboard control' stamp: 'di 12/10/2001 22:52'! 208104moveSelectionDown: direction event: evt 208105 "Move the current selection up or down by one, presumably under keyboard control. 208106 direction = +/-1" 208107 208108 | index m | 208109 index := (submorphs indexOf: selectedItem ifAbsent: [1-direction]) + direction. 208110 submorphs do: "Ensure finite" 208111 [:unused | m := submorphs atWrap: index. 208112 ((m isKindOf: MenuItemMorph) and: [m isEnabled]) ifTrue: 208113 [^ self selectItem: m event: evt]. 208114 "Keep looking for an enabled item" 208115 index := index + direction sign]. 208116 ^ self selectItem: nil event: evt! ! 208117 208118!MenuMorph methodsFor: 'keyboard control' stamp: 'rr 3/24/2004 13:40'! 208119moveUp: evt 208120 ^self moveSelectionDown: -1 event: evt! ! 208121 208122!MenuMorph methodsFor: 'keyboard control' stamp: 'dgd 9/9/2004 21:48'! 208123removeMatchString 208124 "Remove the matchString, if any." 208125 self setProperty: #matchString toValue: String new. 208126 self displayFiltered: nil! ! 208127 208128!MenuMorph methodsFor: 'keyboard control' stamp: 'rr 3/25/2004 12:14'! 208129selectCurrentItem: evt 208130 | selectable | 208131 selectedItem ifNotNil: 208132 [selectedItem hasSubMenu 208133 ifTrue: [self selectSubMenu: evt] 208134 ifFalse: [selectedItem invokeWithEvent: evt]]. 208135 (selectable := self items) size = 1 208136 ifTrue: [selectable first invokeWithEvent: evt]! ! 208137 208138!MenuMorph methodsFor: 'keyboard control' stamp: 'rr 9/15/2005 16:24'! 208139selectMoreItem: evt 208140 | allItems more | 208141 allItems := self submorphs select: [:m | m isKindOf: MenuItemMorph]. 208142 more := allItems detect: [:m | (m contents size >= 4) and: [(m contents first: 4) asString = 'more'.]] ifNone: [^ self flash]. 208143 self selectItem: more event: evt. 208144 selectedItem invokeWithEvent: evt! ! 208145 208146!MenuMorph methodsFor: 'keyboard control' stamp: 'md 1/19/2006 18:02'! 208147unfilterOrEscape: evt 208148 self valueOfProperty: #matchString 208149 ifPresentDo: 208150 [:str | 208151 208152 str isEmpty 208153 ifFalse: 208154 ["If filtered, first ESC removes filter" 208155 208156 self setProperty: #matchString toValue: String new. 208157 self selectItem: nil event: evt. 208158 self displayFiltered: evt]]. 208159 "If a stand-alone menu, just delete it" 208160 popUpOwner ifNil: [^self delete]. 208161 "If a sub-menu, then deselect, and return focus to outer menu" 208162 self selectSuperMenu: evt! ! 208163 208164 208165!MenuMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:52'! 208166addCustomMenuItems: aCustomMenu hand: aHandMorph 208167 208168 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 208169 aCustomMenu addLine. 208170 aCustomMenu add: 'add title...' translated action: #addTitle. 208171 aCustomMenu add: 'set target...' translated action: #setTarget:. 208172 defaultTarget ifNotNil: [ 208173 aCustomMenu add: 'add item...' translated action: #addItem]. 208174 aCustomMenu add: 'add line' translated action: #addLine. 208175 (self items count:[:any| any hasSubMenu]) > 0 208176 ifTrue:[aCustomMenu add: 'detach submenu' translated action: #detachSubMenu:].! ! 208177 208178!MenuMorph methodsFor: 'menu' stamp: 'alain.plantec 2/6/2009 15:30'! 208179addItem 208180 208181 | string sel | 208182 string := UIManager default request: 'Label for new item?' translated. 208183 string isEmpty ifTrue: [^ self]. 208184 sel := UIManager default request: 'Selector?' translated. 208185 sel isEmpty ifFalse: [sel := sel asSymbol]. 208186 self add: string action: sel. 208187! ! 208188 208189!MenuMorph methodsFor: 'menu' stamp: 'DamienCassou 9/23/2009 08:46'! 208190addTitle 208191 208192 | string | 208193 string := UIManager default request: 'Title for this menu?' translated. 208194 string isEmptyOrNil ifTrue: [^ self]. 208195 self addTitle: string. 208196! ! 208197 208198!MenuMorph methodsFor: 'menu' stamp: 'alain.plantec 2/8/2009 19:27'! 208199detachSubMenu: evt 208200 | possibleTargets item subMenu index | 208201 possibleTargets := self items select:[:any| any hasSubMenu]. 208202 possibleTargets size > 0 ifTrue:[ 208203 index := UIManager default 208204 chooseFrom: (possibleTargets collect:[:t| t contents asString]) 208205 title: 'Which menu?' translated. 208206 index = 0 ifTrue:[^self]]. 208207 item := possibleTargets at: index. 208208 subMenu := item subMenu. 208209 subMenu ifNotNil: [ 208210 item subMenu: nil. 208211 item delete. 208212 subMenu stayUp: true. 208213 subMenu popUpOwner: nil. 208214 subMenu addTitle: item contents. 208215 evt hand attachMorph: subMenu]. 208216! ! 208217 208218!MenuMorph methodsFor: 'menu' stamp: 'marcus.denker 11/10/2008 10:04'! 208219doButtonAction 208220 "Do the receiver's inherent button action. Makes sense for the kind of MenuMorph that is a wrapper for a single menu-item -- pass it on the the item" 208221 208222 (self findA: MenuItemMorph) ifNotNil: [:aMenuItem | aMenuItem doButtonAction]! ! 208223 208224!MenuMorph methodsFor: 'menu' stamp: 'alain.plantec 2/9/2009 17:48'! 208225removeStayUpBox 208226 | box ext | 208227 submorphs isEmpty ifTrue: [^self]. 208228 (submorphs first isAlignmentMorph) ifFalse: [^self]. 208229 box := submorphs first submorphs last. 208230 ext := box extent. 208231 (box isKindOf: IconicButton) 208232 ifTrue: 208233 [box 208234 labelGraphic: (Form extent: ext depth: 8); 208235 shedSelvedge; 208236 borderWidth: 0; 208237 lock]. 208238 box extent: ext.! ! 208239 208240!MenuMorph methodsFor: 'menu' stamp: 'nk 3/31/2002 18:36'! 208241removeStayUpItems 208242 | stayUpItems | 208243 stayUpItems := self items select: [ :item | item isStayUpItem ]. 208244 stayUpItems do: [ :ea | ea delete ]. 208245! ! 208246 208247!MenuMorph methodsFor: 'menu' stamp: 'efo 3/27/2003 23:32'! 208248setInvokingView: invokingView 208249 "Re-work every menu item of the form 208250 <target> perform: <selector> 208251 to the form 208252 <target> perform: <selector> orSendTo: <invokingView>. 208253 This supports MVC's vectoring of non-model messages to the editPane." 208254 self items do: 208255 [:item | 208256 item hasSubMenu 208257 ifTrue: [ item subMenu setInvokingView: invokingView] 208258 ifFalse: [ item arguments isEmpty ifTrue: "only the simple messages" 208259 [item arguments: (Array with: item selector with: invokingView). 208260 item selector: #perform:orSendTo:]]]! ! 208261 208262!MenuMorph methodsFor: 'menu' stamp: 'wiz 1/16/2006 21:40'! 208263setTarget: evt 208264 "Set the default target object to be used for add item commands, and re-target all existing items to the new target or the the invoking hand." 208265 208266 | oldDefaultTarget | 208267 oldDefaultTarget := defaultTarget . 208268 self sightTargets: evt. 208269 oldDefaultTarget ~~ defaultTarget 208270 ifTrue: [self updateItemsWithTarget: defaultTarget orWithHand: evt hand ]. 208271 ! ! 208272 208273!MenuMorph methodsFor: 'menu' stamp: 'wiz 1/16/2006 21:26'! 208274target: aMorph 208275"Set defaultTarget since thats what we got. 208276For the sake of targetSighting which assumes #target is a word we know." 208277 208278defaultTarget := aMorph! ! 208279 208280!MenuMorph methodsFor: 'menu' stamp: 'RAA 1/18/2001 18:21'! 208281toggleStayUp: evt 208282 "Toggle my 'stayUp' flag and adjust the menu item to reflect its new state." 208283 208284 self items do: [:item | 208285 item isStayUpItem ifTrue: 208286 [self stayUp: stayUp not. 208287 stayUp 208288 ifTrue: [item contents: 'dismiss this menu'] 208289 ifFalse: [item contents: 'keep this menu up']]]. 208290 evt hand releaseMouseFocus: self. 208291 stayUp ifFalse: [self topRendererOrSelf delete]. 208292! ! 208293 208294!MenuMorph methodsFor: 'menu' stamp: 'RAA 1/19/2001 15:10'! 208295toggleStayUpIgnore: ignored evt: evt 208296 208297 "This variant is resistant to the MVC compatibility in #setInvokingView:" 208298 208299 self toggleStayUp: evt. 208300! ! 208301 208302!MenuMorph methodsFor: 'menu' stamp: 'wiz 3/14/2006 23:40'! 208303updateItemsWithTarget: aTarget orWithHand: aHand 208304 "re-target all existing items" 208305 self items do: 208306 [:item | item target ifNotNil: [ 208307 item target isHandMorph 208308 ifTrue: [item target: aHand] 208309 ifFalse: [item target: aTarget] ] ]! ! 208310 208311 208312!MenuMorph methodsFor: 'modal control' stamp: 'alain.plantec 2/9/2009 14:27'! 208313invokeModal 208314 "Invoke this menu and don't return until the user has chosen a value. 208315 See example below on how to use modal menu morphs." 208316 ^ self invokeModal: Preferences menuKeyboardControl 208317 208318 "Example: 208319 | menu sub entry | 208320 menu := MenuMorph new. 208321 1 to: 3 do: [:i | 208322 entry := 'Line', i printString. 208323 sub := MenuMorph new. 208324 menu add: entry subMenu: sub. 208325 #('Item A' 'Item B' 'Item C') do:[:subEntry| 208326 sub add: subEntry target: menu 208327 selector: #modalSelection: argument: {entry. subEntry}]]. 208328 menu invokeModal. 208329" 208330 208331! ! 208332 208333!MenuMorph methodsFor: 'modal control' stamp: 'sw 2/3/2002 14:26'! 208334invokeModal: allowKeyboardControl 208335 "Invoke this menu and don't return until the user has chosen a value. If the allowKeyboarControl boolean is true, permit keyboard control of the menu" 208336 208337 ^ self invokeModalAt: ActiveHand position in: ActiveWorld allowKeyboard: allowKeyboardControl! ! 208338 208339!MenuMorph methodsFor: 'modal control' stamp: 'KLC 4/11/2004 09:06'! 208340invokeModalAt: aPoint in: aWorld allowKeyboard: aBoolean 208341 "Invoke this menu and don't return until the user has chosen a value. 208342 See senders of this method for finding out how to use modal menu morphs." 208343 | w originalFocusHolder | 208344 originalFocusHolder := aWorld primaryHand keyboardFocus. 208345 self popUpAt: aPoint forHand: aWorld primaryHand in: aWorld allowKeyboard: aBoolean. 208346 self isModalInvokationDone: false. 208347 w := aWorld outermostWorldMorph. "containing hand" 208348 [self isInWorld & self isModalInvokationDone not] whileTrue: [w doOneSubCycle]. 208349 self delete. 208350 originalFocusHolder ifNotNil: [aWorld primaryHand newKeyboardFocus: originalFocusHolder]. 208351 ^ self modalSelection! ! 208352 208353!MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:33'! 208354isModalInvokationDone 208355 ^self valueOfProperty: #isModalInvokationDone ifAbsent:[false]! ! 208356 208357!MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'! 208358isModalInvokationDone: aBool 208359 self setProperty: #isModalInvokationDone toValue: aBool 208360! ! 208361 208362!MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'! 208363modalSelection 208364 ^self valueOfProperty: #modalSelection ifAbsent:[nil]! ! 208365 208366!MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'! 208367modalSelection: anObject 208368 self setProperty: #modalSelection toValue: anObject. 208369 self isModalInvokationDone: true! ! 208370 208371 208372!MenuMorph methodsFor: 'nil' stamp: 'di 10/28/1999 09:50'! 208373deleteIfPopUp 208374 "Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu." 208375 208376 stayUp ifFalse: [self topRendererOrSelf delete]. 208377 (popUpOwner notNil and: [popUpOwner isKindOf: MenuItemMorph]) ifTrue: [ 208378 popUpOwner isSelected: false. 208379 (popUpOwner owner isKindOf: MenuMorph) 208380 ifTrue: [popUpOwner owner deleteIfPopUp]]. 208381! ! 208382 208383!MenuMorph methodsFor: 'nil' stamp: 'jm 11/4/97 07:46'! 208384items 208385 208386 ^ submorphs select: [:m | m isKindOf: MenuItemMorph] 208387! ! 208388 208389 208390!MenuMorph methodsFor: 'rounding' stamp: 'dgd 9/1/2004 18:12'! 208391roundedCorners 208392 "Return a list of those corners to round" 208393 self wasActivatedFromDockingBar 208394 ifTrue: ["" 208395 activatorDockingBar isFloating 208396 ifTrue: [^ #(2 3 )]. 208397 activatorDockingBar isAdheringToTop 208398 ifTrue: [^ #(2 3 )]. 208399 activatorDockingBar isAdheringToBottom 208400 ifTrue: [^ #(1 4 )]. 208401 activatorDockingBar isAdheringToLeft 208402 ifTrue: [^ #(3 4 )]. 208403 activatorDockingBar isAdheringToRight 208404 ifTrue: [^ #(1 2 )]]. 208405 ^ super roundedCorners! ! 208406 208407 208408!MenuMorph methodsFor: 'private' stamp: 'ar 10/7/2000 21:08'! 208409invokeMetaMenu: evt 208410 stayUp ifFalse:[^self]. "Don't allow this" 208411 ^super invokeMetaMenu: evt! ! 208412 208413!MenuMorph methodsFor: 'private' stamp: 'ar 2/10/2001 00:37'! 208414morphicLayerNumber 208415 208416 "helpful for insuring some morphs always appear in front of or behind others. 208417 smaller numbers are in front" 208418 ^self valueOfProperty: #morphicLayerNumber ifAbsent: [ 208419 stayUp ifTrue:[100] ifFalse:[10] 208420 ]! ! 208421 208422!MenuMorph methodsFor: 'private' stamp: 'sw 5/1/2002 01:39'! 208423positionAt: aPoint relativeTo: aMenuItem inWorld: aWorld 208424 "Note: items may not be laid out yet (I found them all to be at 0@0), 208425 so we have to add up heights of items above the selected item." 208426 208427 | i yOffset sub delta | 208428 self fullBounds. "force layout" 208429 i := 0. 208430 yOffset := 0. 208431 [(sub := self submorphs at: (i := i + 1)) == aMenuItem] 208432 whileFalse: [yOffset := yOffset + sub height]. 208433 208434 self position: aPoint - (2 @ (yOffset + 8)). 208435 208436 "If it doesn't fit, show it to the left, not to the right of the hand." 208437 self right > aWorld worldBounds right 208438 ifTrue: 208439 [self right: aPoint x + 1]. 208440 208441 "Make sure that the menu fits in the world." 208442 delta := self bounds amountToTranslateWithin: 208443 (aWorld worldBounds withHeight: ((aWorld worldBounds height - 18) max: (ActiveHand position y) + 1)). 208444 delta = (0 @ 0) ifFalse: [self position: self position + delta]! ! 208445 208446!MenuMorph methodsFor: 'private' stamp: 'ar 9/18/2000 12:12'! 208447selectedItem 208448 ^selectedItem! ! 208449 208450"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 208451 208452MenuMorph class 208453 instanceVariableNames: ''! 208454 208455!MenuMorph class methodsFor: 'example' stamp: 'alain.plantec 2/9/2009 13:36'! 208456example 208457 "MenuMorph example" 208458 208459 | menu | 208460 menu := MenuMorph new. 208461 menu addStayUpItem. 208462 menu add: 'apples' action: #apples. 208463 menu add: 'oranges' action: #oranges. 208464 menu addLine. 208465 menu addLine. "extra lines ignored" 208466 menu add: 'peaches' action: #peaches. 208467 menu addLine. 208468 menu add: 'pears' action: #pears. 208469 menu addLine. 208470 ^ menu 208471! ! 208472 208473 208474!MenuMorph class methodsFor: 'images' stamp: 'jrp 7/27/2005 23:11'! 208475closeBoxImage 208476 "Supplied here because we don't necessarily have ComicBold" 208477 208478 ^ CloseBoxImage ifNil: [CloseBoxImage := SystemWindow closeBoxImage]! ! 208479 208480!MenuMorph class methodsFor: 'images' stamp: 'alain.plantec 2/9/2009 16:44'! 208481pushPinImage 208482 "Answer the push-pin image, creating and caching 208483 it at this time if it is absent" 208484 ^ PushPinImage 208485 ifNil: [PushPinImage := Form 208486 extent: 16 @ 16 208487 depth: 32 208488 fromArray: #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4289374634 4280690213 4282467139 4281811785 4286217083 0 0 0 0 0 0 0 0 0 0 0 4279900698 4289771447 4283150819 4278686942 4278602609 4281216819 4292862175 0 0 0 0 0 0 0 0 4292598747 4278519045 4291812321 4278425828 4278229220 4278360034 4278533726 4281676595 0 0 0 0 0 0 0 0 4293059298 4278781959 4289902007 4280591330 4278294757 4278359779 4278618315 4278454800 4287730065 0 0 0 0 4293717228 4289835441 4291743438 4288782753 4278782730 4283980117 4287155693 4278294756 4278360036 4278425831 4278725183 4281348657 0 0 0 4293190884 4281413937 4281677109 4278387459 4278584069 4278457889 4278717198 4285372595 4278753764 4278359781 4278556389 4278468957 4278650887 0 0 0 4286019447 4284243036 4283914071 4278781702 4285033581 4279932888 4278683597 4278490589 4278490848 4278620633 4278621404 4278591793 4279242768 0 0 0 4283519312 4285295466 4290165174 4290164405 4294638071 4282232039 4278491363 4278620380 4278723896 4278519564 4278389263 4278387459 4285427310 0 0 0 4285887863 4280431419 4286696174 4290634484 4286170860 4278818529 4278619863 4278661191 4278913293 4285493359 4284177243 4288585374 4294177779 0 0 0 4291480781 4278322439 4278614713 4278490852 4278622435 4278613940 4278458404 4278321667 4278518531 4288914340 0 0 0 0 0 0 0 4281018922 4278464064 4278359263 4278491102 4278724669 4278518276 4278387461 4278321666 4282532418 0 0 0 0 0 0 4292730333 4279045132 4278584327 4278665827 4278489307 4278621404 4278480807 4278595138 4278453252 4281677109 0 0 0 0 0 0 4284900966 4278848010 4283650898 4278781962 4278523682 4278726730 4278592304 4278454027 4278519045 4287861651 0 0 0 0 0 0 4280887593 4290493371 0 4290822079 4284308832 4280163615 4279439633 4281611320 4288322202 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ) 208489 offset: 0 @ 0]! ! 208490 208491 208492!MenuMorph class methodsFor: 'instance creation' stamp: 'jm 5/14/1998 17:21'! 208493entitled: aString 208494 "Answer a new instance of me with the given title." 208495 208496 ^ self new addTitle: aString 208497! ! 208498 208499!MenuMorph class methodsFor: 'instance creation' stamp: 'alain.plantec 2/9/2009 13:51'! 208500fromArray: anArray 208501 "Construct a menu from anArray. The elements of anArray 208502 must be either: 208503 * A pair of the form: <label> <selector> 208504 or * The 'dash' (or 'minus sign') symbol" 208505 | menu | 208506 208507 menu := self new. 208508 208509 anArray 208510 do: [:anElement | 208511 anElement size == 1 208512 ifTrue: [ 208513 anElement == #- ifFalse: [^ self error: 'badly-formed menu constructor']. 208514 menu addLine. 208515 ] 208516 ifFalse: [ 208517 anElement size == 2 ifFalse: [^ self error: 'badly-formed menu constructor']. 208518 menu add: anElement first action: anElement second. 208519 ] 208520 ]. 208521 208522 ^ menu! ! 208523 208524!MenuMorph class methodsFor: 'instance creation' stamp: 'alain.plantec 2/10/2009 17:33'! 208525initialize 208526 208527 "MenuMorph initialize" 208528 208529 Preferences 208530 setParameter: #menuTitleBorderWidth to: 0; 208531 setParameter: #menuTitleColor to: (TranslucentColor r: 0.87 g: 0.8 b: 1 alpha: 0.65); 208532 setParameter: #menuColor to: (Color 208533 r: (215/255) asFloat 208534 g: (220/255) asFloat 208535 b: (232/255) asFloat). 208536 PushPinImage := nil! ! 208537WidgetStub subclass: #MenuStub 208538 instanceVariableNames: '' 208539 classVariableNames: '' 208540 poolDictionaries: '' 208541 category: 'ToolBuilder-SUnit'! 208542 208543!MenuStub methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2006 10:43'! 208544click: aString 208545 | item | 208546 item := self items detect: [:ea | ea label = aString] ifNone: [^ self]. 208547 item action isSymbol 208548 ifTrue: [self model perform: item action] 208549 ifFalse: [item action value]! ! 208550 208551!MenuStub methodsFor: 'as yet unclassified' stamp: 'cwp 6/9/2005 00:29'! 208552items 208553 ^ spec items! ! 208554 208555!MenuStub methodsFor: 'as yet unclassified' stamp: 'cwp 6/9/2005 00:36'! 208556labels 208557 ^ self items keys! ! 208558DiffMorph subclass: #MergeDiffMorph 208559 instanceVariableNames: 'allowJoinClicks' 208560 classVariableNames: '' 208561 poolDictionaries: '' 208562 category: 'Polymorph-Tools-Diff'! 208563 208564!MergeDiffMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2009 18:17'! 208565allowJoinClicks 208566 "Answer the value of allowJoinClicks" 208567 208568 ^ allowJoinClicks! ! 208569 208570!MergeDiffMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2009 18:17'! 208571allowJoinClicks: anObject 208572 "Set the value of allowJoinClicks" 208573 208574 allowJoinClicks := anObject! ! 208575 208576 208577!MergeDiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/8/2009 18:17'! 208578calculatedJoinMappings 208579 "Specify click allowance for each section." 208580 208581 ^super calculatedJoinMappings do: [:j | 208582 j allowClick: self allowJoinClicks]! ! 208583 208584!MergeDiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:15'! 208585compositeText 208586 "Answer the composite text based on the selection state 208587 of the joins." 208588 208589 ^self joinMorph compositeText 208590 ! ! 208591 208592!MergeDiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:37'! 208593indicateDst 208594 "Change the indicators of the joins to the dst side." 208595 208596 self joinMappings do: [:section | 208597 section selectionState: #dst]. 208598 self 208599 changed; 208600 changed: #selectedDifferences! ! 208601 208602!MergeDiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:38'! 208603indicateSrc 208604 "Change the indicators of the joins to the src side." 208605 208606 self joinMappings do: [:section | 208607 section selectionState: #src]. 208608 self 208609 changed; 208610 changed: #selectedDifferences! ! 208611 208612!MergeDiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:13'! 208613joinSectionClass 208614 "Answer the class to use for a new join section." 208615 208616 ^MergeJoinSection! ! 208617 208618!MergeDiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:15'! 208619newJoinMorph 208620 "Answer a new join morph." 208621 208622 ^super newJoinMorph 208623 when: #joinClicked send: #update: to: self with: #joinClicked! ! 208624 208625!MergeDiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:15'! 208626update: aspect 208627 "A join has probably changed its selection state." 208628 208629 super update: aspect. 208630 aspect == #joinClicked 208631 ifTrue: [self 208632 changed; 208633 changed: #selectedDifferences]! ! 208634 208635 208636!MergeDiffMorph methodsFor: 'initialize-release' stamp: 'gvc 1/8/2009 18:17'! 208637initialize 208638 "Initialize the receiver." 208639 208640 super initialize. 208641 self 208642 allowJoinClicks: true! ! 208643JoinSection subclass: #MergeJoinSection 208644 instanceVariableNames: 'selectedBorderColor selected selectionState stateIcons allowClick' 208645 classVariableNames: '' 208646 poolDictionaries: '' 208647 category: 'Polymorph-Tools-Diff'! 208648 208649!MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 1/8/2009 18:04'! 208650allowClick 208651 "Answer the value of allowClick" 208652 208653 ^ allowClick! ! 208654 208655!MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 1/8/2009 18:04'! 208656allowClick: anObject 208657 "Set the value of allowClick" 208658 208659 allowClick := anObject! ! 208660 208661!MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/25/2006 17:47'! 208662selected 208663 "Answer the value of selected" 208664 208665 ^ selected! ! 208666 208667!MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/30/2006 15:25'! 208668selected: aBoolean 208669 "Set the value of selected" 208670 208671 selected := aBoolean. 208672 self 208673 updateHighlights; 208674 changed: #selected! ! 208675 208676!MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/25/2006 17:43'! 208677selectedBorderColor 208678 "Answer the value of selectedBorderColor" 208679 208680 ^ selectedBorderColor! ! 208681 208682!MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/25/2006 17:43'! 208683selectedBorderColor: anObject 208684 "Set the value of selectedBorderColor" 208685 208686 selectedBorderColor := anObject! ! 208687 208688!MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/31/2006 13:00'! 208689selectionState 208690 "Answer the value of selectionState" 208691 208692 ^ selectionState! ! 208693 208694!MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/31/2006 13:00'! 208695selectionState: anObject 208696 "Set the value of selectionState" 208697 208698 selectionState := anObject! ! 208699 208700!MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/31/2006 13:03'! 208701stateIcons 208702 "Answer the value of stateIcons" 208703 208704 ^ stateIcons! ! 208705 208706!MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/31/2006 13:03'! 208707stateIcons: anObject 208708 "Set the value of stateIcons" 208709 208710 stateIcons := anObject! ! 208711 208712 208713!MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 12:10'! 208714appendToCompositeText: aText 208715 "If appropriate append the relevant src or dst text to the given text." 208716 208717 self selectionState == #src ifTrue: [^aText append: self src text]. 208718 self selectionState == #dst ifTrue: [^aText append: self dst text]. 208719 self selectionState == #both ifTrue: [ 208720 ^aText 208721 append: self src text; 208722 append: self dst text]! ! 208723 208724!MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:22'! 208725borderColorToUse 208726 "Answer the border color to use based on the selection state." 208727 208728 ^self selected 208729 ifTrue: [self selectedBorderColor] 208730 ifFalse: [super borderColorToUse]! ! 208731 208732!MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 13:09'! 208733clicked 208734 "The receiver or a highlight was clicked." 208735 208736 self wantsClick ifFalse: [^false]. 208737 self selectNextState. 208738 ^true! ! 208739 208740!MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:18'! 208741containsPoint: aPoint 208742 "Answer whether the receiver contains the given point." 208743 208744 ^(super containsPoint: aPoint) or: [ 208745 self stateIcon notNil and: [self stateIconBounds containsPoint: aPoint]]! ! 208746 208747!MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 13:05'! 208748defaultStateIcons 208749 "Answer the default state icons." 208750 208751 ^{MenuIcons smallBackIcon. 208752 MenuIcons smallForwardIcon. 208753 MenuIcons smallOkIcon. 208754 MenuIcons smallCancelIcon}! ! 208755 208756!MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:19'! 208757drawOn: aCanvas 208758 "Draw the join on the given canvas." 208759 208760 super drawOn: aCanvas. 208761 self stateIcon ifNotNilDo: [:i | 208762 aCanvas 208763 translucentImage: i 208764 at: self stateIconBounds topLeft]! ! 208765 208766!MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 1/8/2009 18:05'! 208767initialize 208768 "Initialize the receiver." 208769 208770 self 208771 allowClick: true; 208772 selected: false; 208773 selectionState: #dst; 208774 stateIcons: self defaultStateIcons; 208775 selectedBorderColor: Color black. 208776 super initialize! ! 208777 208778!MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 13:03'! 208779selectNextState 208780 "Set the selection state to the next one with wraparound." 208781 208782 self selectionState: ( 208783 self selectionStates at: ( 208784 (self selectionStates indexOf: self selectionState) \\ 208785 self selectionStates size + 1))! ! 208786 208787!MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 13:01'! 208788selectionStates 208789 "Answer the valid selection states in order." 208790 208791 ^#(src dst both neither)! ! 208792 208793!MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:14'! 208794stateIcon 208795 "Answer the state icon to use." 208796 208797 self wantsClick ifFalse: [^nil]. 208798 ^self stateIcons at: (self selectionStates indexOf: self selectionState)! ! 208799 208800!MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:44'! 208801stateIconBounds 208802 "Answer the bounds of the state icon." 208803 208804 |i| 208805 i := self stateIcon ifNil: [^nil]. 208806 ^self shape bounds center - (i extent // 2) 208807 extent: i extent! ! 208808 208809!MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 1/8/2009 18:04'! 208810wantsClick 208811 "Allow if explictly enabled and super." 208812 208813 ^self allowClick and: [super wantsClick]! ! 208814Object subclass: #Message 208815 instanceVariableNames: 'selector args lookupClass' 208816 classVariableNames: '' 208817 poolDictionaries: '' 208818 category: 'Kernel-Methods'! 208819!Message commentStamp: '<historical>' prior: 0! 208820I represent a selector and its argument values. 208821 208822Generally, the system does not use instances of Message for efficiency reasons. However, when a message is not understood by its receiver, the interpreter will make up an instance of me in order to capture the information involved in an actual message transmission. This instance is sent it as an argument with the message doesNotUnderstand: to the receiver.! 208823 208824 208825!Message methodsFor: 'accessing'! 208826argument 208827 "Answer the first (presumably sole) argument" 208828 208829 ^args at: 1! ! 208830 208831!Message methodsFor: 'accessing'! 208832argument: newValue 208833 "Change the first argument to newValue and answer self" 208834 208835 args at: 1 put: newValue! ! 208836 208837!Message methodsFor: 'accessing'! 208838arguments 208839 "Answer the arguments of the receiver." 208840 208841 ^args! ! 208842 208843!Message methodsFor: 'accessing' stamp: 'ajh 10/9/2001 16:32'! 208844lookupClass 208845 208846 ^ lookupClass! ! 208847 208848!Message methodsFor: 'accessing' stamp: 'eem 1/3/2009 10:42'! 208849numArgs 208850 "Answer the number of arguments in this message" 208851 208852 ^args size! ! 208853 208854!Message methodsFor: 'accessing'! 208855selector 208856 "Answer the selector of the receiver." 208857 208858 ^selector! ! 208859 208860!Message methodsFor: 'accessing'! 208861sends: aSelector 208862 "answer whether this message's selector is aSelector" 208863 208864 ^selector == aSelector! ! 208865 208866 208867!Message methodsFor: 'as yet unclassified' stamp: 'md 11/14/2003 17:37'! 208868pushReceiver! ! 208869 208870 208871!Message methodsFor: 'printing' stamp: 'ajh 10/9/2001 15:31'! 208872printOn: stream 208873 208874 args isEmpty ifTrue: [^ stream nextPutAll: selector]. 208875 args with: selector keywords do: [:arg :word | 208876 stream nextPutAll: word. 208877 stream space. 208878 arg printOn: stream. 208879 stream space. 208880 ]. 208881 stream skip: -1. 208882! ! 208883 208884!Message methodsFor: 'printing' stamp: 'sma 6/1/2000 10:01'! 208885storeOn: aStream 208886 "Refer to the comment in Object|storeOn:." 208887 208888 aStream nextPut: $(; 208889 nextPutAll: self class name; 208890 nextPutAll: ' selector: '; 208891 store: selector; 208892 nextPutAll: ' arguments: '; 208893 store: args; 208894 nextPut: $)! ! 208895 208896 208897!Message methodsFor: 'sending' stamp: 'ajh 1/22/2003 11:51'! 208898sendTo: receiver 208899 "answer the result of sending this message to receiver" 208900 208901 ^ receiver perform: selector withArguments: args! ! 208902 208903!Message methodsFor: 'sending' stamp: 'di 3/25/1999 21:54'! 208904sentTo: receiver 208905 "answer the result of sending this message to receiver" 208906 208907 lookupClass == nil 208908 ifTrue: [^ receiver perform: selector withArguments: args] 208909 ifFalse: [^ receiver perform: selector withArguments: args inSuperclass: lookupClass]! ! 208910 208911 208912!Message methodsFor: 'stub creation' stamp: 'ads 7/21/2003 17:33'! 208913createStubMethod 208914 | argNames aOrAn argName arg argClassName | 208915 argNames := Set new. 208916 ^ String streamContents: [ :s | 208917 self selector keywords doWithIndex: [ :key :i | 208918 s nextPutAll: key. 208919 ((key last = $:) or: [self selector isInfix]) ifTrue: [ 208920 arg := self arguments at: i. 208921 argClassName := (arg isKindOf: Class) ifTrue: ['Class'] ifFalse: [arg class name]. 208922 aOrAn := argClassName first isVowel ifTrue: ['an'] ifFalse: ['a']. 208923 argName := aOrAn, argClassName. 208924 [argNames includes: argName] whileTrue: [argName := argName, i asString]. 208925 argNames add: argName. 208926 s nextPutAll: ' '; nextPutAll: argName; space 208927 ]. 208928 ]. 208929 s cr; tab. 208930 s nextPutAll: 'self shouldBeImplemented' 208931 ]! ! 208932 208933 208934!Message methodsFor: 'private' stamp: 'ajh 9/23/2001 04:59'! 208935lookupClass: aClass 208936 208937 lookupClass := aClass! ! 208938 208939!Message methodsFor: 'private' stamp: 'ajh 3/9/2003 19:25'! 208940setSelector: aSymbol 208941 208942 selector := aSymbol. 208943! ! 208944 208945!Message methodsFor: 'private'! 208946setSelector: aSymbol arguments: anArray 208947 208948 selector := aSymbol. 208949 args := anArray! ! 208950 208951 208952!Message methodsFor: 'comparing' stamp: 'eem 11/27/2008 13:17'! 208953analogousCodeTo: anObject 208954 "For MethodPropertires comparison." 208955 ^self class == anObject class 208956 and: [selector == anObject selector 208957 and: [args = anObject arguments 208958 and: [lookupClass == anObject lookupClass]]]! ! 208959 208960"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 208961 208962Message class 208963 instanceVariableNames: ''! 208964 208965!Message class methodsFor: 'instance creation'! 208966selector: aSymbol 208967 "Answer an instance of me with unary selector, aSymbol." 208968 208969 ^self new setSelector: aSymbol arguments: (Array new: 0)! ! 208970 208971!Message class methodsFor: 'instance creation'! 208972selector: aSymbol argument: anObject 208973 "Answer an instance of me whose selector is aSymbol and single 208974 argument is anObject." 208975 208976 ^self new setSelector: aSymbol arguments: (Array with: anObject)! ! 208977 208978!Message class methodsFor: 'instance creation'! 208979selector: aSymbol arguments: anArray 208980 "Answer an instance of me with selector, aSymbol, and arguments, 208981 anArray." 208982 208983 ^self new setSelector: aSymbol arguments: anArray! ! 208984MessageNode subclass: #MessageAsTempNode 208985 instanceVariableNames: '' 208986 classVariableNames: '' 208987 poolDictionaries: '' 208988 category: 'Compiler-ParseNodes'! 208989!MessageAsTempNode commentStamp: '<historical>' prior: 0! 208990This node represents accesses to temporary variables for do-its in the debugger. Since they execute in another context, they must send a message to the original context to access the value of the temporary variable in that context.! 208991 208992 208993!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:38'! 208994asStorableNode: encoder 208995 "This node is a message masquerading as a temporary variable. 208996 It currently has the form {homeContext tempAt: offset}. 208997 We need to generate code for {expr storeAt: offset inTempFrame: homeContext}, 208998 where the expr, the block argument, is already on the stack. 208999 This, in turn will get turned into {homeContext tempAt: offset put: expr} 209000 at runtime if nobody disturbs storeAt:inTempFrame: in Object (not clean)" 209001 ^ MessageAsTempNode new 209002 receiver: nil "suppress code generation for reciever already on stack" 209003 selector: #storeAt:inTempFrame: 209004 arguments: (arguments copyWith: receiver) 209005 precedence: precedence 209006 from: encoder! ! 209007 209008!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 10/12/1999 17:29'! 209009code 209010 "Allow synthetic temp nodes to be sorted by code" 209011 ^ arguments first literalValue! ! 209012 209013!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'! 209014emitStorePop: stack on: codeStream 209015 "This node has the form {expr storeAt: offset inTempFrame: homeContext}, 209016 where the expr, the block argument, is already on the stack." 209017 ^ self emitForEffect: stack on: codeStream! ! 209018 209019!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'! 209020sizeForStorePop: encoder 209021 "This node has the form {expr storeAt: offset inTempFrame: homeContext}, 209022 where the expr, the block argument, is already on the stack." 209023 ^ self sizeForEffect: encoder! ! 209024 209025!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'eem 6/24/2008 11:50'! 209026store: expr from: encoder 209027 "ctxt tempAt: n -> ctxt tempAt: n put: expr (see Assignment). 209028 For assigning into temps of a context being debugged." 209029 209030 selector key ~= #namedTempAt: 209031 ifTrue: [^self error: 'cant transform this message']. 209032 ^ MessageAsTempNode new 209033 receiver: receiver 209034 selector: #namedTempAt:put: 209035 arguments: (arguments copyWith: expr) 209036 precedence: precedence 209037 from: encoder! ! 209038 209039 209040!MessageAsTempNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 209041emitCodeForStorePop: stack encoder: encoder 209042 "This node has the form {expr storeAt: offset inTempFrame: homeContext}, 209043 where the expr, the block argument, is already on the stack." 209044 ^self emitCodeForEffect: stack encoder: encoder! ! 209045 209046!MessageAsTempNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 209047sizeCodeForStorePop: encoder 209048 "This node has the form {expr storeAt: offset inTempFrame: homeContext}, 209049 where the expr, the block argument, is already on the stack." 209050 ^self sizeCodeForEffect: encoder! ! 209051ProtoObject subclass: #MessageCatcher 209052 instanceVariableNames: 'accumulator' 209053 classVariableNames: '' 209054 poolDictionaries: '' 209055 category: 'Kernel-Methods'! 209056!MessageCatcher commentStamp: '<historical>' prior: 0! 209057Any message sent to me is returned as a Message object. 209058 209059"Message catcher" creates an instance of me. 209060! 209061 209062 209063!MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'! 209064doesNotUnderstand: aMessage 209065 209066 accumulator ifNotNil: [accumulator add: aMessage]. 209067 ^ aMessage! ! 209068 209069!MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'! 209070privAccumulator 209071 209072 ^ accumulator! ! 209073 209074!MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'! 209075privAccumulator: collection 209076 209077 accumulator := collection! ! 209078 209079"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 209080 209081MessageCatcher class 209082 instanceVariableNames: ''! 209083DialogWindow subclass: #MessageDialogWindow 209084 instanceVariableNames: 'textMorph textFont iconMorph' 209085 classVariableNames: '' 209086 poolDictionaries: '' 209087 category: 'Polymorph-Widgets-Windows'! 209088!MessageDialogWindow commentStamp: 'gvc 5/18/2007 13:27' prior: 0! 209089Dialog window displaying a message with a single OK button. Escape/return will close. Icon is a themed information icon.! 209090 209091 209092!MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/29/2007 13:29'! 209093iconMorph 209094 "Answer the value of iconMorph" 209095 209096 ^ iconMorph! ! 209097 209098!MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/29/2007 13:28'! 209099iconMorph: anObject 209100 "Set the value of iconMorph" 209101 209102 iconMorph := anObject! ! 209103 209104!MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 7/30/2009 13:58'! 209105text: aStringOrText 209106 "Set the text." 209107 209108 |t| 209109 t := aStringOrText isString 209110 ifTrue: [aStringOrText asText addAttribute: (TextFontReference toFont: self textFont); yourself] 209111 ifFalse: [aStringOrText]. 209112 t addAttribute: TextAlignment centered. 209113 self textMorph newContents: t! ! 209114 209115!MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 10/17/2006 14:19'! 209116textFont 209117 "Answer the text font." 209118 209119 ^textFont! ! 209120 209121!MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 7/30/2009 13:58'! 209122textFont: aFont 209123 "Set the text font." 209124 209125 textFont := aFont! ! 209126 209127!MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/27/2006 10:26'! 209128textMorph 209129 "Answer the value of textMorph" 209130 209131 ^ textMorph! ! 209132 209133!MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/27/2006 10:26'! 209134textMorph: anObject 209135 "Set the value of textMorph" 209136 209137 textMorph := anObject! ! 209138 209139 209140!MessageDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 2/2/2009 13:25'! 209141initialExtent 209142 "Answer the initial extent for the receiver. 209143 Adjust the text if the text would be wider than 1/4 the display width." 209144 209145 |ext| 209146 ext := super initialExtent. 209147 self textMorph width > (Display width // 4) ifTrue: [ 209148 self textMorph 209149 wrapFlag: true; 209150 hResizing: #rigid; 209151 extent: Display width // 4 @ 0. 209152 ext := super initialExtent]. 209153 ^ext! ! 209154 209155!MessageDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 15:15'! 209156newButtons 209157 "Answer new buttons as appropriate." 209158 209159 ^{self newOKButton isDefault: true}! ! 209160 209161!MessageDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/29/2007 13:29'! 209162newContentMorph 209163 "Answer a new content morph." 209164 209165 self iconMorph: self newIconMorph. 209166 self textMorph: self newTextMorph. 209167 ^self newGroupboxFor: (self newRow: {self iconMorph. self textMorph})! ! 209168 209169!MessageDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/29/2007 13:29'! 209170newIconMorph 209171 "Answer an icon for the receiver." 209172 209173 ^ImageMorph new image: self icon! ! 209174 209175!MessageDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/31/2006 17:54'! 209176newTextMorph 209177 "Answer a text morph." 209178 209179 ^self newText: ''! ! 209180 209181 209182!MessageDialogWindow methodsFor: 'theme' stamp: 'gvc 9/12/2007 17:47'! 209183playOpenSound 209184 "Play the themed sound for opening. 209185 Do nothing at present, done by the UIManager."! ! 209186 209187!MessageDialogWindow methodsFor: 'theme' stamp: 'gvc 8/29/2007 13:30'! 209188themeChanged 209189 "Update the icon." 209190 209191 super themeChanged. 209192 self iconMorph image: self icon! ! 209193 209194 209195!MessageDialogWindow methodsFor: 'visual properties' stamp: 'gvc 5/18/2007 10:30'! 209196icon 209197 "Answer an icon for the receiver." 209198 209199 ^self theme infoIcon! ! 209200 209201"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 209202 209203MessageDialogWindow class 209204 instanceVariableNames: ''! 209205 209206!MessageDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 13:58'! 209207taskbarIcon 209208 "Answer the icon for the receiver in a task bar." 209209 209210 ^self theme smallInfoIcon! ! 209211MessageSet subclass: #MessageNames 209212 instanceVariableNames: 'searchString selectorList selectorListIndex' 209213 classVariableNames: '' 209214 poolDictionaries: '' 209215 category: 'Tools-Browser'! 209216 209217!MessageNames methodsFor: 'initialization' stamp: 'sw 7/28/2001 02:16'! 209218inMorphicWindowLabeled: labelString 209219 "Answer a morphic window with the given label that can display the receiver" 209220"MessageNames openMessageNames" 209221 209222 ^ self inMorphicWindowWithInitialSearchString: nil! ! 209223 209224!MessageNames methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 209225inMorphicWindowWithInitialSearchString: initialString 209226 "Answer a morphic window with the given initial search string, nil if none" 209227 209228"MessageNames openMessageNames" 209229 209230 | window selectorListView firstDivider secondDivider horizDivider typeInPane searchButton plugTextMor | 209231 window := (SystemWindow labelled: 'Message Names') model: self. 209232 firstDivider := 0.07. 209233 secondDivider := 0.5. 209234 horizDivider := 0.5. 209235 typeInPane := AlignmentMorph newRow vResizing: #spaceFill; height: 14. 209236 typeInPane hResizing: #spaceFill. 209237 typeInPane listDirection: #leftToRight. 209238 209239 plugTextMor := PluggableTextMorph on: self 209240 text: #searchString accept: #searchString:notifying: 209241 readSelection: nil menu: nil. 209242 plugTextMor setProperty: #alwaysAccept toValue: true. 209243 plugTextMor askBeforeDiscardingEdits: false. 209244 plugTextMor acceptOnCR: true. 209245 plugTextMor setTextColor: Color brown. 209246 plugTextMor setNameTo: 'Search'. 209247 plugTextMor vResizing: #spaceFill; hResizing: #spaceFill. 209248 plugTextMor hideScrollBarsIndefinitely. 209249 plugTextMor setTextMorphToSelectAllOnMouseEnter. 209250 209251 searchButton := SimpleButtonMorph new 209252 target: self; 209253 color: Color white; 209254 label: 'Search'; 209255 actionSelector: #doSearchFrom:; 209256 arguments: {plugTextMor}. 209257 searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'. 209258 209259 typeInPane addMorphFront: searchButton. 209260 typeInPane addTransparentSpacerOfSize: 6@0. 209261 typeInPane addMorphBack: plugTextMor. 209262 initialString isEmptyOrNil ifFalse: 209263 [plugTextMor setText: initialString]. 209264 209265 window addMorph: typeInPane frame: (0@0 corner: horizDivider @ firstDivider). 209266 209267 selectorListView := PluggableListMorph on: self 209268 list: #selectorList 209269 selected: #selectorListIndex 209270 changeSelected: #selectorListIndex: 209271 menu: #selectorListMenu: 209272 keystroke: #selectorListKey:from:. 209273 selectorListView menuTitleSelector: #selectorListMenuTitle. 209274 window addMorph: selectorListView frame: (0 @ firstDivider corner: horizDivider @ secondDivider). 209275 209276 window addMorph: self buildMorphicMessageList frame: (horizDivider @ 0 corner: 1@ secondDivider). 209277 209278 self 209279 addLowerPanesTo: window 209280 at: (0 @ secondDivider corner: 1@1) 209281 with: nil. 209282 209283 initialString isEmptyOrNil ifFalse: 209284 [self searchString: initialString notifying: nil]. 209285 ^ window! ! 209286 209287!MessageNames methodsFor: 'initialization' stamp: 'sw 7/24/2001 01:35'! 209288selectorListKey: aChar from: view 209289 "Respond to a Command key in the message-list pane." 209290 209291 aChar == $n ifTrue: [^ self browseSenders]. 209292 aChar == $c ifTrue: [^ self copyName]. 209293 aChar == $b ifTrue: [^ self browseMethodFull]. 209294! ! 209295 209296 209297!MessageNames methodsFor: 'message list menu' stamp: 'sd 11/20/2005 21:27'! 209298copyName 209299 "Copy the current selector to the clipboard" 209300 209301 | selector | 209302 (selector := self selectorList at: selectorListIndex ifAbsent: [nil]) ifNotNil: 209303 [Clipboard clipboardText: selector asString asText]! ! 209304 209305 209306!MessageNames methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'! 209307computeSelectorListFromSearchString 209308 "Compute selector list from search string" 209309 | raw sorted | 209310 searchString := searchString asString copyWithout: $ . 209311 selectorList := Cursor wait 209312 showWhile: [raw := Symbol selectorsContaining: searchString. 209313 sorted := raw as: SortedCollection. 209314 sorted 209315 sortBlock: [:x :y | x asLowercase <= y asLowercase]. 209316 sorted asArray]. 209317 selectorList size > 19 209318 ifFalse: ["else the following filtering is considered too expensive. This 19 209319 should be a system-maintained Parameter, someday" 209320 selectorList := self systemNavigation allSelectorsWithAnyImplementorsIn: selectorList]. 209321 ^ selectorList! ! 209322 209323!MessageNames methodsFor: 'search' stamp: 'sw 7/28/2001 00:32'! 209324doSearchFrom: aPane 209325 "The user hit the Search button -- treat it as a synonym for the user having hit the Return or Enter (or cmd-s) in the type-in pane" 209326 209327 aPane accept. 209328 aPane selectAll! ! 209329 209330!MessageNames methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'! 209331searchString 209332 "Answer the current searchString, initializing it if need be" 209333 209334 | pane | 209335 searchString isEmptyOrNil ifTrue: 209336 [searchString := 'type here, then hit Search'. 209337 pane := self containingWindow findDeepSubmorphThat: 209338 [:m | m knownName = 'Search'] ifAbsent: ["this happens during window creation" ^ searchString]. 209339 pane setText: searchString. 209340 pane setTextMorphToSelectAllOnMouseEnter. 209341 pane selectAll]. 209342 ^ searchString! ! 209343 209344!MessageNames methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'! 209345searchString: aString notifying: aController 209346 "Take what the user typed and find all selectors containing it" 209347 209348 searchString := aString asString copyWithout: $ . 209349 self containingWindow setLabel: 'Message names containing "', searchString asLowercase, '"'. 209350 selectorList := nil. 209351 self changed: #selectorList. 209352 self changed: #messageList. 209353 ^ true! ! 209354 209355!MessageNames methodsFor: 'search' stamp: 'sd 11/20/2005 21:27'! 209356showOnlyImplementedSelectors 209357 "Caution -- can be slow!! Filter my selector list down such that it only 209358 shows selectors that are actually implemented somewhere in the system." 209359 self okToChange 209360 ifTrue: [Cursor wait 209361 showWhile: [selectorList := self systemNavigation allSelectorsWithAnyImplementorsIn: selectorList. 209362 self changed: #selectorList. 209363 self changed: #messageList]]! ! 209364 209365 209366!MessageNames methodsFor: 'selection' stamp: 'sw 7/24/2001 01:46'! 209367selection 209368 "Answer the item in the list that is currently selected, or nil if no selection is present" 209369 209370 ^ self messageList at: messageListIndex ifAbsent: [nil]! ! 209371 209372 209373!MessageNames methodsFor: 'selector list' stamp: 'sd 11/20/2005 21:27'! 209374messageList 209375 "Answer the receiver's message list, computing it if necessary. The way 209376 to force a recomputation is to set the messageList to nil" 209377 messageList 209378 ifNil: [messageList := selectorListIndex == 0 209379 ifTrue: [#()] 209380 ifFalse: [self systemNavigation 209381 allImplementorsOf: (selectorList at: selectorListIndex)]. 209382 self 209383 messageListIndex: (messageList size > 0 209384 ifTrue: [1] 209385 ifFalse: [0])]. 209386 ^ messageList! ! 209387 209388!MessageNames methodsFor: 'selector list' stamp: 'sd 11/20/2005 21:27'! 209389selectorList 209390 "Answer the selectorList" 209391 209392 selectorList ifNil: 209393 [self computeSelectorListFromSearchString. 209394 selectorListIndex := selectorList size > 0 209395 ifTrue: [1] 209396 ifFalse: [0]. 209397 messageList := nil]. 209398 ^ selectorList! ! 209399 209400!MessageNames methodsFor: 'selector list' stamp: 'sw 7/24/2001 01:55'! 209401selectorListIndex 209402 "Answer the selectorListIndex" 209403 209404 ^ selectorListIndex! ! 209405 209406!MessageNames methodsFor: 'selector list' stamp: 'sd 11/20/2005 21:27'! 209407selectorListIndex: anInteger 209408 "Set the selectorListIndex as specified, and propagate consequences" 209409 209410 selectorListIndex := anInteger. 209411 selectorListIndex = 0 209412 ifTrue: [^ self]. 209413 messageList := nil. 209414 self changed: #selectorListIndex. 209415 self changed: #messageList! ! 209416 209417!MessageNames methodsFor: 'selector list' stamp: 'sw 7/24/2001 01:58'! 209418selectorListMenu: aMenu 209419 "Answer the menu associated with the selectorList" 209420 209421 aMenu addList: #( 209422 ('senders (n)' browseSenders 'browse senders of the chosen selector') 209423 ('copy selector to clipboard' copyName 'copy the chosen selector to the clipboard, for subsequent pasting elsewhere') 209424 - 209425 ('show only implemented selectors' showOnlyImplementedSelectors 'remove from the selector-list all symbols that do not represent implemented methods')). 209426 209427 ^ aMenu! ! 209428 209429!MessageNames methodsFor: 'selector list' stamp: 'sw 7/24/2001 01:47'! 209430selectorListMenuTitle 209431 "Answer the title to supply for the menu belonging to the selector-list pane" 209432 209433 ^ 'Click on any item in the list 209434to see all implementors of it'! ! 209435 209436"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 209437 209438MessageNames class 209439 instanceVariableNames: ''! 209440 209441!MessageNames class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 209442methodBrowserSearchingFor: searchString 209443 "Answer an method-browser window whose search-string is initially as indicated" 209444 209445 | aWindow | 209446 aWindow := self new inMorphicWindowWithInitialSearchString: searchString. 209447 aWindow applyModelExtent. 209448 ^ aWindow! ! 209449 209450!MessageNames class methodsFor: 'instance creation' stamp: 'sw 7/24/2001 18:03'! 209451openMessageNames 209452 "Open a new instance of the receiver in the active world" 209453 209454 self new openAsMorphNamed: 'Message Names' inWorld: ActiveWorld 209455 209456 "MessageNames openMessageNames" 209457! ! 209458 209459!MessageNames class methodsFor: 'instance creation' stamp: 'sw 7/28/2001 00:56'! 209460prototypicalToolWindow 209461 "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" 209462 209463 ^ self methodBrowserSearchingFor: nil! ! 209464 209465 209466!MessageNames class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:35'! 209467windowColorSpecification 209468 "Answer a WindowColorSpec object that declares my preference" 209469 209470 ^ WindowColorSpec classSymbol: self name wording: 'Message Names' brightColor: #(0.645 1.0 0.452) pastelColor: #(0.843 0.976 0.843) helpMessage: 'A tool finding, viewing, and editing all methods whose names contiane a given character sequence.'! ! 209471ParseNode subclass: #MessageNode 209472 instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode' 209473 classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers NewStyleMacroEmitters NewStyleMacroSizers StdTypers ThenFlag' 209474 poolDictionaries: '' 209475 category: 'Compiler-ParseNodes'! 209476!MessageNode commentStamp: '<historical>' prior: 0! 209477I represent a receiver and its message. 209478 209479Precedence codes: 209480 1 unary 209481 2 binary 209482 3 keyword 209483 4 other 209484 209485If special>0, I compile special code in-line instead of sending messages with literal methods as remotely copied contexts.! 209486 209487 209488!MessageNode methodsFor: 'cascading'! 209489cascadeReceiver 209490 "Nil out rcvr (to indicate cascade) and return what it had been." 209491 209492 | rcvr | 209493 rcvr := receiver. 209494 receiver := nil. 209495 ^rcvr! ! 209496 209497 209498!MessageNode methodsFor: 'code generation' stamp: 'PeterHugossonMiller 9/2/2009 16:14'! 209499emitCase: stack on: strm value: forValue 209500 209501 | braceNode sizeStream thenSize elseSize | 209502 forValue not 209503 ifTrue: [^super emitForEffect: stack on: strm]. 209504 braceNode := arguments first. 209505 sizeStream := sizes readStream. 209506 receiver emitForValue: stack on: strm. 209507 braceNode casesForwardDo: 209508 [:keyNode :valueNode :last | 209509 thenSize := sizeStream next. 209510 elseSize := sizeStream next. 209511 last ifFalse: [strm nextPut: Dup. stack push: 1]. 209512 keyNode emitForEvaluatedValue: stack on: strm. 209513 equalNode emit: stack args: 1 on: strm. 209514 self emitBranchOn: false dist: thenSize pop: stack on: strm. 209515 last ifFalse: [strm nextPut: Pop. stack pop: 1]. 209516 valueNode emitForEvaluatedValue: stack on: strm. 209517 last ifTrue: [stack pop: 1]. 209518 valueNode returns ifFalse: [self emitJump: elseSize on: strm]]. 209519 arguments size = 2 209520 ifTrue: 209521 [arguments last emitForEvaluatedValue: stack on: strm] "otherwise: [...]" 209522 ifFalse: 209523 [NodeSelf emitForValue: stack on: strm. 209524 caseErrorNode emit: stack args: 0 on: strm]! ! 209525 209526!MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:39'! 209527emitForEffect: stack on: strm 209528 "For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly." 209529 special > 0 209530 ifTrue: 209531 [pc := 0. 209532 self perform: (MacroEmitters at: special) with: stack with: strm with: false] 209533 ifFalse: 209534 [super emitForEffect: stack on: strm]! ! 209535 209536!MessageNode methodsFor: 'code generation' stamp: 'eem 7/29/2008 20:44'! 209537emitForValue: stack on: strm 209538 "For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly." 209539 special > 0 209540 ifTrue: 209541 [pc := 0. 209542 self perform: (MacroEmitters at: special) with: stack with: strm with: true] 209543 ifFalse: 209544 [receiver ~~ nil ifTrue: [receiver emitForValue: stack on: strm]. 209545 arguments do: [:argument | argument emitForValue: stack on: strm]. 209546 pc := strm position + 1. "debug pc is first byte of the send, i.e. the next byte". 209547 selector 209548 emit: stack 209549 args: arguments size 209550 on: strm 209551 super: receiver == NodeSuper]! ! 209552 209553!MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:23'! 209554emitIf: stack on: strm value: forValue 209555 | thenExpr thenSize elseExpr elseSize | 209556 thenSize := sizes at: 1. 209557 elseSize := sizes at: 2. 209558 (forValue not and: [(elseSize*thenSize) > 0]) 209559 ifTrue: "Two-armed IFs forEffect share a single pop" 209560 [^ super emitForEffect: stack on: strm]. 209561 thenExpr := arguments at: 1. 209562 elseExpr := arguments at: 2. 209563 receiver emitForValue: stack on: strm. 209564 forValue 209565 ifTrue: "Code all forValue as two-armed" 209566 [self emitBranchOn: false dist: thenSize pop: stack on: strm. 209567 pc := strm position. 209568 thenExpr emitForEvaluatedValue: stack on: strm. 209569 stack pop: 1. "then and else alternate; they don't accumulate" 209570 thenExpr returns not 209571 ifTrue: "Elide jump over else after a return" 209572 [self emitJump: elseSize on: strm]. 209573 elseExpr emitForEvaluatedValue: stack on: strm] 209574 ifFalse: "One arm is empty here (two-arms code forValue)" 209575 [thenSize > 0 209576 ifTrue: 209577 [self emitBranchOn: false dist: thenSize pop: stack on: strm. 209578 pc := strm position. 209579 thenExpr emitForEvaluatedEffect: stack on: strm] 209580 ifFalse: 209581 [self emitBranchOn: true dist: elseSize pop: stack on: strm. 209582 pc := strm position. 209583 elseExpr emitForEvaluatedEffect: stack on: strm]]! ! 209584 209585!MessageNode methodsFor: 'code generation' stamp: 'eem 5/23/2008 10:47'! 209586emitIfNil: stack on: strm value: forValue 209587 209588 | theNode theSize | 209589 theNode := arguments first. 209590 theSize := sizes at: 1. 209591 receiver emitForValue: stack on: strm. 209592 forValue ifTrue: [strm nextPut: Dup. stack push: 1]. 209593 strm nextPut: LdNil. stack push: 1. 209594 equalNode emit: stack args: 1 on: strm. 209595 self 209596 emitBranchOn: selector key == #ifNotNil: 209597 dist: theSize 209598 pop: stack 209599 on: strm. 209600 pc := strm position. 209601 forValue 209602 ifTrue: 209603 [strm nextPut: Pop. 209604 stack pop: 1. 209605 theNode emitForEvaluatedValue: stack on: strm] 209606 ifFalse: 209607 [theNode emitForEvaluatedEffect: stack on: strm].! ! 209608 209609!MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:42'! 209610emitToDo: stack on: strm value: forValue 209611 " var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: " 209612 | loopSize initStmt limitInit test block incStmt blockSize | 209613 initStmt := arguments at: 4. 209614 limitInit := arguments at: 7. 209615 test := arguments at: 5. 209616 block := arguments at: 3. 209617 incStmt := arguments at: 6. 209618 blockSize := sizes at: 1. 209619 loopSize := sizes at: 2. 209620 limitInit == nil 209621 ifFalse: [limitInit emitForEffect: stack on: strm]. 209622 initStmt emitForEffect: stack on: strm. 209623 test emitForValue: stack on: strm. 209624 self emitBranchOn: false dist: blockSize pop: stack on: strm. 209625 pc := strm position. 209626 block emitForEvaluatedEffect: stack on: strm. 209627 incStmt emitForEffect: stack on: strm. 209628 self emitJump: 0 - loopSize on: strm. 209629 forValue ifTrue: [strm nextPut: LdNil. stack push: 1]! ! 209630 209631!MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:36'! 209632emitWhile: stack on: strm value: forValue 209633 " L1: ... Bfp(L2)|Btp(L2) ... Jmp(L1) L2: " 209634 | cond stmt stmtSize loopSize | 209635 cond := receiver. 209636 stmt := arguments at: 1. 209637 stmtSize := sizes at: 1. 209638 loopSize := sizes at: 2. 209639 cond emitForEvaluatedValue: stack on: strm. 209640 self emitBranchOn: (selector key == #whileFalse:) "Bfp for whileTrue" 209641 dist: stmtSize pop: stack on: strm. "Btp for whileFalse" 209642 pc := strm position. 209643 stmt emitForEvaluatedEffect: stack on: strm. 209644 self emitJump: 0 - loopSize on: strm. 209645 forValue ifTrue: [strm nextPut: LdNil. stack push: 1]! ! 209646 209647!MessageNode methodsFor: 'code generation' stamp: 'tao 8/20/97 22:25'! 209648sizeCase: encoder value: forValue 209649 209650 | braceNode sizeIndex thenSize elseSize | 209651 forValue not 209652 ifTrue: [^super sizeForEffect: encoder]. 209653 equalNode := encoder encodeSelector: #=. 209654 braceNode := arguments first. 209655 sizes := Array new: 2 * braceNode numElements. 209656 sizeIndex := sizes size. 209657 elseSize := arguments size = 2 209658 ifTrue: 209659 [arguments last sizeForEvaluatedValue: encoder] "otherwise: [...]" 209660 ifFalse: 209661 [caseErrorNode := encoder encodeSelector: #caseError. 209662 1 + (caseErrorNode size: encoder args: 0 super: false)]. "self caseError" 209663 braceNode casesReverseDo: 209664 [:keyNode :valueNode :last | 209665 sizes at: sizeIndex put: elseSize. 209666 thenSize := valueNode sizeForEvaluatedValue: encoder. 209667 last ifFalse: [thenSize := thenSize + 1]. "Pop" 209668 valueNode returns ifFalse: [thenSize := thenSize + (self sizeJump: elseSize)]. 209669 sizes at: sizeIndex-1 put: thenSize. 209670 last ifFalse: [elseSize := elseSize + 1]. "Dup" 209671 elseSize := elseSize + (keyNode sizeForEvaluatedValue: encoder) + 209672 (equalNode size: encoder args: 1 super: false) + 209673 (self sizeBranchOn: false dist: thenSize) + thenSize. 209674 sizeIndex := sizeIndex - 2]. 209675 ^(receiver sizeForValue: encoder) + elseSize 209676! ! 209677 209678!MessageNode methodsFor: 'code generation'! 209679sizeForEffect: encoder 209680 209681 special > 0 209682 ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: false]. 209683 ^super sizeForEffect: encoder! ! 209684 209685!MessageNode methodsFor: 'code generation'! 209686sizeForValue: encoder 209687 | total argSize | 209688 special > 0 209689 ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: true]. 209690 receiver == NodeSuper 209691 ifTrue: [selector := selector copy "only necess for splOops"]. 209692 total := selector size: encoder args: arguments size super: receiver == NodeSuper. 209693 receiver == nil 209694 ifFalse: [total := total + (receiver sizeForValue: encoder)]. 209695 sizes := arguments collect: 209696 [:arg | 209697 argSize := arg sizeForValue: encoder. 209698 total := total + argSize. 209699 argSize]. 209700 ^total! ! 209701 209702!MessageNode methodsFor: 'code generation'! 209703sizeIf: encoder value: forValue 209704 | thenExpr elseExpr branchSize thenSize elseSize | 209705 thenExpr := arguments at: 1. 209706 elseExpr := arguments at: 2. 209707 (forValue 209708 or: [(thenExpr isJust: NodeNil) 209709 or: [elseExpr isJust: NodeNil]]) not 209710 "(...not ifTrue: avoids using ifFalse: alone during this compile)" 209711 ifTrue: "Two-armed IFs forEffect share a single pop" 209712 [^ super sizeForEffect: encoder]. 209713 forValue 209714 ifTrue: "Code all forValue as two-armed" 209715 [elseSize := elseExpr sizeForEvaluatedValue: encoder. 209716 thenSize := (thenExpr sizeForEvaluatedValue: encoder) 209717 + (thenExpr returns 209718 ifTrue: [0] "Elide jump over else after a return" 209719 ifFalse: [self sizeJump: elseSize]). 209720 branchSize := self sizeBranchOn: false dist: thenSize] 209721 ifFalse: "One arm is empty here (two-arms code forValue)" 209722 [(elseExpr isJust: NodeNil) 209723 ifTrue: 209724 [elseSize := 0. 209725 thenSize := thenExpr sizeForEvaluatedEffect: encoder. 209726 branchSize := self sizeBranchOn: false dist: thenSize] 209727 ifFalse: 209728 [thenSize := 0. 209729 elseSize := elseExpr sizeForEvaluatedEffect: encoder. 209730 branchSize := self sizeBranchOn: true dist: elseSize]]. 209731 sizes := Array with: thenSize with: elseSize. 209732 ^ (receiver sizeForValue: encoder) + branchSize 209733 + thenSize + elseSize! ! 209734 209735!MessageNode methodsFor: 'code generation' stamp: 'acg 1/28/2000 22:00'! 209736sizeIfNil: encoder value: forValue 209737 209738 | theNode theSize theSelector | 209739 equalNode := encoder encodeSelector: #==. 209740 sizes := Array new: 1. 209741 theNode := arguments first. 209742 theSelector := #ifNotNil:. 209743 forValue 209744 ifTrue: 209745 [sizes at: 1 put: (theSize := (1 "pop" + (theNode sizeForEvaluatedValue: encoder))). 209746 ^(receiver sizeForValue: encoder) + 209747 2 "Dup. LdNil" + 209748 (equalNode size: encoder args: 1 super: false) + 209749 (self 209750 sizeBranchOn: (selector key == theSelector) 209751 dist: theSize) + 209752 theSize] 209753 ifFalse: 209754 [sizes at: 1 put: (theSize := (theNode sizeForEvaluatedEffect: encoder)). 209755 ^(receiver sizeForValue: encoder) + 209756 1 "LdNil" + 209757 (equalNode size: encoder args: 1 super: false) + 209758 (self 209759 sizeBranchOn: (selector key == theSelector) 209760 dist: theSize) + 209761 theSize] 209762 209763! ! 209764 209765!MessageNode methodsFor: 'code generation'! 209766sizeToDo: encoder value: forValue 209767 " var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: " 209768 | loopSize initStmt test block incStmt blockSize blockVar initSize limitInit | 209769 block := arguments at: 3. 209770 blockVar := block firstArgument. 209771 initStmt := arguments at: 4. 209772 test := arguments at: 5. 209773 incStmt := arguments at: 6. 209774 limitInit := arguments at: 7. 209775 initSize := initStmt sizeForEffect: encoder. 209776 limitInit == nil 209777 ifFalse: [initSize := initSize + (limitInit sizeForEffect: encoder)]. 209778 blockSize := (block sizeForEvaluatedEffect: encoder) 209779 + (incStmt sizeForEffect: encoder) + 2. "+2 for Jmp backward" 209780 loopSize := (test sizeForValue: encoder) 209781 + (self sizeBranchOn: false dist: blockSize) 209782 + blockSize. 209783 sizes := Array with: blockSize with: loopSize. 209784 ^ initSize + loopSize 209785 + (forValue ifTrue: [1] ifFalse: [0]) " +1 for value (push nil) "! ! 209786 209787!MessageNode methodsFor: 'code generation'! 209788sizeWhile: encoder value: forValue 209789 "L1: ... Bfp(L2) ... Jmp(L1) L2: nil (nil for value only); 209790 justStmt, wholeLoop, justJump." 209791 | cond stmt stmtSize loopSize branchSize | 209792 cond := receiver. 209793 stmt := arguments at: 1. 209794 stmtSize := (stmt sizeForEvaluatedEffect: encoder) + 2. 209795 branchSize := self sizeBranchOn: (selector key == #whileFalse:) "Btp for whileFalse" 209796 dist: stmtSize. 209797 loopSize := (cond sizeForEvaluatedValue: encoder) 209798 + branchSize + stmtSize. 209799 sizes := Array with: stmtSize with: loopSize. 209800 ^ loopSize " +1 for value (push nil) " 209801 + (forValue ifTrue: [1] ifFalse: [0])! ! 209802 209803 209804!MessageNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2009 11:58'! 209805analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>" 209806 "Assignments within optimized loops are tricky. Because a loop repeats a 209807 write to a temporary in an optimized loop effectively occurs after the loop. 209808 To handle this collect the set of temps assigned to in optimized loops and 209809 add extra writes after traversing the optimized loop constituents." 209810 | writtenToTemps | 209811 self isOptimizedLoop ifTrue: 209812 [{ receiver }, arguments do: 209813 [:node| 209814 (node notNil and: [node isBlockNode and: [node optimized]]) ifTrue: 209815 [assignmentPools at: node put: Set new]]]. 209816 "receiver is nil in cascades" 209817 receiver == nil ifFalse: 209818 [receiver analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools]. 209819 arguments do: 209820 [:node| 209821 node == nil ifFalse: "last argument of optimized to:do: can be nil" 209822 [node analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools]]. 209823 "Add assignments representing subsequent iterations 209824 and redo the closure analysis for the written-to temps." 209825 self isOptimizedLoop ifTrue: 209826 [writtenToTemps := Set new. 209827 { receiver }, arguments do: 209828 [:node| 209829 (node notNil and: [node isBlockNode and: [node optimized]]) ifTrue: 209830 [(assignmentPools removeKey: node) do: 209831 [:temp| 209832 temp isBlockArg ifFalse: "ignore added assignments to to:do: loop args" 209833 [writtenToTemps add: temp. 209834 temp addWriteWithin: node at: rootNode locationCounter]]]]. 209835 writtenToTemps isEmpty ifFalse: 209836 [(writtenToTemps asSortedCollection: ParseNode tempSortBlock) do: 209837 [:each| each analyseClosure: rootNode]. 209838 (writtenToTemps collect: [:each| each definingScope]) do: 209839 [:blockNode| 209840 blockNode ifHasRemoteTempNodeEnsureInitializationStatementExists: rootNode]]]! ! 209841 209842 209843!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'PeterHugossonMiller 9/2/2009 16:13'! 209844emitCodeForCase: stack encoder: encoder value: forValue 209845 209846 | braceNode sizeStream allReturn | 209847 forValue ifFalse: 209848 [^super emitCodeForEffect: stack encoder: encoder]. 209849 braceNode := arguments first. 209850 sizeStream := sizes readStream. 209851 receiver emitCodeForValue: stack encoder: encoder. 209852 "There must be at least one branch around the otherwise/caseError 209853 so the decompiler can identify the end of the otherwise/caseError." 209854 allReturn := true. "assume every case ends with a return" 209855 braceNode casesForwardDo: 209856 [:keyNode :valueNode :last | | thenSize elseSize | 209857 thenSize := sizeStream next. 209858 elseSize := sizeStream next. 209859 last ifFalse: [encoder genDup. stack push: 1]. 209860 keyNode emitCodeForEvaluatedValue: stack encoder: encoder. 209861 equalNode emitCode: stack args: 1 encoder: encoder. 209862 self emitCodeForBranchOn: false dist: thenSize pop: stack encoder: encoder. 209863 last ifFalse: [encoder genPop. stack pop: 1]. 209864 valueNode emitCodeForEvaluatedValue: stack encoder: encoder. 209865 last ifTrue: [stack pop: 1]. 209866 valueNode returns ifFalse: 209867 [self emitCodeForJump: elseSize encoder: encoder. 209868 allReturn := false]. 209869 (last and: [allReturn]) ifTrue: 209870 [self emitCodeForJump: elseSize encoder: encoder]]. 209871 arguments size = 2 209872 ifTrue: 209873 [arguments last emitCodeForEvaluatedValue: stack encoder: encoder] "otherwise: [...]" 209874 ifFalse: 209875 [NodeSelf emitCodeForValue: stack encoder: encoder. 209876 caseErrorNode emitCode: stack args: 0 encoder: encoder]! ! 209877 209878!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:13'! 209879emitCodeForEffect: stack encoder: encoder 209880 "For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly." 209881 special > 0 209882 ifTrue: 209883 [pc := 0. 209884 self perform: (NewStyleMacroEmitters at: special) with: stack with: encoder with: false] 209885 ifFalse: 209886 [super emitCodeForEffect: stack encoder: encoder]! ! 209887 209888!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:12'! 209889emitCodeForIf: stack encoder: encoder value: forValue 209890 | thenExpr thenSize elseExpr elseSize | 209891 thenSize := sizes at: 1. 209892 elseSize := sizes at: 2. 209893 (forValue not and: [elseSize * thenSize > 0]) ifTrue: 209894 "Two-armed IFs forEffect share a single pop" 209895 [^super emitCodeForEffect: stack encoder: encoder]. 209896 thenExpr := arguments at: 1. 209897 elseExpr := arguments at: 2. 209898 receiver emitCodeForValue: stack encoder: encoder. 209899 forValue 209900 ifTrue: "Code all forValue as two-armed" 209901 [self emitCodeForBranchOn: false dist: thenSize pop: stack encoder: encoder. 209902 pc := encoder methodStreamPosition. 209903 thenExpr emitCodeForEvaluatedValue: stack encoder: encoder. 209904 stack pop: 1. "then and else alternate; they don't accumulate" 209905 thenExpr returns not ifTrue: 209906 "...not ifTrue: avoids using ifFalse: alone during this compile)" 209907 "Elide jump over else after a return" 209908 [self emitCodeForJump: elseSize encoder: encoder]. 209909 elseExpr emitCodeForEvaluatedValue: stack encoder: encoder] 209910 ifFalse: "One arm is empty here (two-arms code forValue)" 209911 [thenSize > 0 209912 ifTrue: 209913 [self emitCodeForBranchOn: false dist: thenSize pop: stack encoder: encoder. 209914 pc := encoder methodStreamPosition. 209915 thenExpr emitCodeForEvaluatedEffect: stack encoder: encoder] 209916 ifFalse: 209917 [self emitCodeForBranchOn: true dist: elseSize pop: stack encoder: encoder. 209918 pc := encoder methodStreamPosition. 209919 elseExpr emitCodeForEvaluatedEffect: stack encoder: encoder]]! ! 209920 209921!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:28'! 209922emitCodeForIfNil: stack encoder: encoder value: forValue 209923 209924 | theNode theSize ifNotNilSelector | 209925 theNode := arguments first. 209926 theSize := sizes at: 1. 209927 ifNotNilSelector := #ifNotNil:. 209928 receiver emitCodeForValue: stack encoder: encoder. 209929 forValue ifTrue: [encoder genDup. stack push: 1]. 209930 encoder genPushSpecialLiteral: nil. stack push: 1. 209931 equalNode emitCode: stack args: 1 encoder: encoder. 209932 self 209933 emitCodeForBranchOn: (selector key == ifNotNilSelector) 209934 dist: theSize 209935 pop: stack 209936 encoder: encoder. 209937 pc := encoder methodStreamPosition. 209938 forValue 209939 ifTrue: 209940 [encoder genPop. stack pop: 1. 209941 theNode emitCodeForEvaluatedValue: stack encoder: encoder] 209942 ifFalse: [theNode emitCodeForEvaluatedEffect: stack encoder: encoder]! ! 209943 209944!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:31'! 209945emitCodeForToDo: stack encoder: encoder value: forValue 209946 " var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: " 209947 | loopSize initStmt limitInit test block incStmt blockSize | 209948 initStmt := arguments at: 4. 209949 limitInit := arguments at: 7. 209950 test := arguments at: 5. 209951 block := arguments at: 3. 209952 incStmt := arguments at: 6. 209953 blockSize := sizes at: 1. 209954 loopSize := sizes at: 2. 209955 limitInit == nil 209956 ifFalse: [limitInit emitCodeForEffect: stack encoder: encoder]. 209957 initStmt emitCodeForEffect: stack encoder: encoder. 209958 test emitCodeForValue: stack encoder: encoder. 209959 self emitCodeForBranchOn: false dist: blockSize pop: stack encoder: encoder. 209960 pc := encoder methodStreamPosition. 209961 block emitCodeForEvaluatedEffect: stack encoder: encoder. 209962 incStmt emitCodeForEffect: stack encoder: encoder. 209963 self emitCodeForJump: 0 - loopSize encoder: encoder. 209964 forValue ifTrue: [encoder genPushSpecialLiteral: nil. stack push: 1]! ! 209965 209966!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'eem 6/5/2008 16:48'! 209967emitCodeForValue: stack encoder: encoder 209968 "For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly." 209969 special > 0 209970 ifTrue: 209971 [pc := 0. 209972 self perform: (NewStyleMacroEmitters at: special) with: stack with: encoder with: true] 209973 ifFalse: 209974 [receiver ~~ nil ifTrue: [receiver emitCodeForValue: stack encoder: encoder]. 209975 arguments do: [:argument | argument emitCodeForValue: stack encoder: encoder]. 209976 pc := encoder methodStreamPosition + 1. "debug pc is first byte of the send, i.e. the next byte". 209977 selector 209978 emitCode: stack 209979 args: arguments size 209980 encoder: encoder 209981 super: receiver == NodeSuper]! ! 209982 209983!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:36'! 209984emitCodeForWhile: stack encoder: encoder value: forValue 209985 "L1: ... Bfp(L2)|Btp(L2) ... Jmp(L1) L2: " 209986 | cond stmt stmtSize loopSize | 209987 cond := receiver. 209988 stmt := arguments at: 1. 209989 stmtSize := sizes at: 1. 209990 loopSize := sizes at: 2. 209991 cond emitCodeForEvaluatedValue: stack encoder: encoder. 209992 self emitCodeForBranchOn: (selector key == #whileFalse:) "Bfp for whileTrue" 209993 dist: stmtSize pop: stack encoder: encoder. "Btp for whileFalse" 209994 pc := encoder methodStreamPosition. 209995 stmt emitCodeForEvaluatedEffect: stack encoder: encoder. 209996 self emitCodeForJump: 0 - loopSize encoder: encoder. 209997 forValue ifTrue: [encoder genPushSpecialLiteral: nil. stack push: 1]! ! 209998 209999!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'eem 9/29/2008 14:43'! 210000sizeCodeForCase: encoder value: forValue 210001 210002 | braceNode sizeIndex thenSize elseSize allReturn | 210003 forValue not ifTrue: 210004 [^super sizeCodeForEffect: encoder]. 210005 equalNode := encoder encodeSelector: #=. 210006 braceNode := arguments first. 210007 sizes := Array new: 2 * braceNode numElements. 210008 sizeIndex := sizes size. 210009 elseSize := arguments size = 2 210010 ifTrue: 210011 [arguments last sizeCodeForEvaluatedValue: encoder] "otherwise: [...]" 210012 ifFalse: 210013 [caseErrorNode := encoder encodeSelector: #caseError. 210014 (NodeSelf sizeCodeForValue: encoder) 210015 + (caseErrorNode sizeCode: encoder args: 0 super: false)]. "self caseError" 210016 "There must be at least one branch around the otherwise/caseError 210017 so the decompiler can identify the end of the otherwise/caseError." 210018 allReturn := true. "assume every case ends with a return" 210019 braceNode casesForwardDo: 210020 [:keyNode :valueNode :last | 210021 valueNode returns ifFalse: [allReturn := false]]. 210022 braceNode casesReverseDo: 210023 [:keyNode :valueNode :last | 210024 sizes at: sizeIndex put: elseSize. 210025 thenSize := valueNode sizeCodeForEvaluatedValue: encoder. 210026 last ifFalse: [thenSize := thenSize + encoder sizePop]. 210027 valueNode returns ifFalse: [thenSize := thenSize + (self sizeCode: encoder forJump: elseSize)]. 210028 (last and: [allReturn]) ifTrue: [thenSize := thenSize + (self sizeCode: encoder forJump: elseSize)]. 210029 sizes at: sizeIndex-1 put: thenSize. 210030 last ifFalse: [elseSize := elseSize + encoder sizeDup]. 210031 elseSize := elseSize 210032 + (keyNode sizeCodeForEvaluatedValue: encoder) 210033 + (equalNode sizeCode: encoder args: 1 super: false) 210034 + (self sizeCode: encoder forBranchOn: false dist: thenSize) 210035 + thenSize. 210036 sizeIndex := sizeIndex - 2]. 210037 ^(receiver sizeCodeForValue: encoder) + elseSize! ! 210038 210039!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:16'! 210040sizeCodeForEffect: encoder 210041 210042 special > 0 210043 ifTrue: [^self perform: (NewStyleMacroSizers at: special) with: encoder with: false]. 210044 ^super sizeCodeForEffect: encoder! ! 210045 210046!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:15'! 210047sizeCodeForIf: encoder value: forValue 210048 | thenExpr elseExpr branchSize thenSize elseSize | 210049 thenExpr := arguments at: 1. 210050 elseExpr := arguments at: 2. 210051 (forValue 210052 or: [(thenExpr isJust: NodeNil) 210053 or: [elseExpr isJust: NodeNil]]) not 210054 "(...not ifTrue: avoids using ifFalse: alone during this compile)" 210055 ifTrue: "Two-armed IFs forEffect share a single pop" 210056 [^super sizeCodeForEffect: encoder]. 210057 forValue 210058 ifTrue: "Code all forValue as two-armed" 210059 [elseSize := elseExpr sizeCodeForEvaluatedValue: encoder. 210060 thenSize := (thenExpr sizeCodeForEvaluatedValue: encoder) 210061 + (thenExpr returns 210062 ifTrue: [0] "Elide jump over else after a return" 210063 ifFalse: [self sizeCode: encoder forJump: elseSize]). 210064 branchSize := self sizeCode: encoder forBranchOn: false dist: thenSize] 210065 ifFalse: "One arm is empty here (two-arms code forValue)" 210066 [(elseExpr isJust: NodeNil) 210067 ifTrue: 210068 [elseSize := 0. 210069 thenSize := thenExpr sizeCodeForEvaluatedEffect: encoder. 210070 branchSize := self sizeCode: encoder forBranchOn: false dist: thenSize] 210071 ifFalse: 210072 [thenSize := 0. 210073 elseSize := elseExpr sizeCodeForEvaluatedEffect: encoder. 210074 branchSize := self sizeCode: encoder forBranchOn: true dist: elseSize]]. 210075 sizes := Array with: thenSize with: elseSize. 210076 ^(receiver sizeCodeForValue: encoder) 210077 + branchSize + thenSize + elseSize! ! 210078 210079!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/15/2008 09:57'! 210080sizeCodeForIfNil: encoder value: forValue 210081 210082 | theNode theSize theSelector | 210083 equalNode := encoder encodeSelector: #==. 210084 sizes := Array new: 1. 210085 theNode := arguments first. 210086 theSelector := #ifNotNil:. 210087 forValue 210088 ifTrue: 210089 [sizes at: 1 put: (theSize := (encoder sizePop + (theNode sizeCodeForEvaluatedValue: encoder))). 210090 ^(receiver sizeCodeForValue: encoder) 210091 + encoder sizeDup 210092 + (encoder sizePushSpecialLiteral: nil) 210093 + (equalNode sizeCode: encoder args: 1 super: false) 210094 + (self 210095 sizeCode: encoder forBranchOn: selector key == theSelector 210096 dist: theSize) 210097 + theSize] 210098 ifFalse: 210099 [sizes at: 1 put: (theSize := (theNode sizeCodeForEvaluatedEffect: encoder)). 210100 ^(receiver sizeCodeForValue: encoder) 210101 + (encoder sizePushSpecialLiteral: nil) 210102 + (equalNode sizeCode: encoder args: 1 super: false) 210103 + (self 210104 sizeCode: encoder 210105 forBranchOn: selector key == theSelector 210106 dist: theSize) 210107 + theSize]! ! 210108 210109!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/19/2008 15:09'! 210110sizeCodeForToDo: encoder value: forValue 210111 " var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: " 210112 | loopSize initStmt test block incStmt blockSize initSize limitInit | 210113 block := arguments at: 3. 210114 initStmt := arguments at: 4. 210115 test := arguments at: 5. 210116 incStmt := arguments at: 6. 210117 limitInit := arguments at: 7. 210118 initSize := initStmt sizeCodeForEffect: encoder. 210119 limitInit == nil ifFalse: 210120 [initSize := initSize + (limitInit sizeCodeForEffect: encoder)]. 210121 blockSize := (block sizeCodeForEvaluatedEffect: encoder) 210122 + (incStmt sizeCodeForEffect: encoder) 210123 + (encoder sizeJumpLong: -1). 210124 loopSize := (test sizeCodeForValue: encoder) 210125 + (self sizeCode: encoder forBranchOn: false dist: blockSize) 210126 + blockSize. 210127 sizes := Array with: blockSize with: loopSize. 210128 ^initSize 210129 + loopSize 210130 + (forValue ifTrue: [encoder sizePushSpecialLiteral: nil] ifFalse: [0])! ! 210131 210132!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:17'! 210133sizeCodeForValue: encoder 210134 | total argSize | 210135 special > 0 210136 ifTrue: [^self perform: (NewStyleMacroSizers at: special) with: encoder with: true]. 210137 receiver == NodeSuper 210138 ifTrue: [selector := selector copy "only necess for splOops"]. 210139 total := selector sizeCode: encoder args: arguments size super: receiver == NodeSuper. 210140 receiver == nil 210141 ifFalse: [total := total + (receiver sizeCodeForValue: encoder)]. 210142 sizes := arguments collect: 210143 [:arg | 210144 argSize := arg sizeCodeForValue: encoder. 210145 total := total + argSize. 210146 argSize]. 210147 ^total! ! 210148 210149!MessageNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/15/2008 10:00'! 210150sizeCodeForWhile: encoder value: forValue 210151 "L1: ... Bfp(L2) ... Jmp(L1) L2: nil (nil for value only); 210152 justStmt, wholeLoop, justJump." 210153 | cond stmt stmtSize loopSize branchSize | 210154 cond := receiver. 210155 stmt := arguments at: 1. 210156 stmtSize := (stmt sizeCodeForEvaluatedEffect: encoder) + (encoder sizeJumpLong: 1). 210157 branchSize := self 210158 sizeCode: encoder 210159 forBranchOn: selector key == #whileFalse: "Btp for whileFalse" 210160 dist: stmtSize. 210161 loopSize := (cond sizeCodeForEvaluatedValue: encoder) + branchSize + stmtSize. 210162 sizes := Array with: stmtSize with: loopSize. 210163 ^loopSize + (forValue ifTrue: [encoder sizePushSpecialLiteral: nil] ifFalse: [0])! ! 210164 210165 210166!MessageNode methodsFor: 'equation translation'! 210167arguments 210168 ^arguments! ! 210169 210170!MessageNode methodsFor: 'equation translation' stamp: 'tk 10/27/2000 15:11'! 210171arguments: list 210172 arguments := list! ! 210173 210174!MessageNode methodsFor: 'equation translation' stamp: 'eem 9/25/2008 14:50'! 210175eval 210176 "When everything in me is a constant, I can produce a value. This is only used by the Scripting system (TilePadMorph tilesFrom:in:)" 210177 210178 | rec args | 210179 receiver isVariableNode ifFalse: [^ #illegal]. 210180 rec := receiver key value. 210181 args := arguments collect: [:each | each eval]. 210182 ^ rec perform: selector key withArguments: args! ! 210183 210184!MessageNode methodsFor: 'equation translation'! 210185receiver 210186 ^receiver! ! 210187 210188!MessageNode methodsFor: 'equation translation' stamp: 'RAA 2/14/2001 14:07'! 210189receiver: val 210190 "14 feb 2001 - removed return arrow" 210191 210192 receiver := val! ! 210193 210194!MessageNode methodsFor: 'equation translation'! 210195selector 210196 ^selector! ! 210197 210198 210199!MessageNode methodsFor: 'initialize-release' stamp: 'eem 9/25/2008 17:22'! 210200receiver: rcvr selector: selNode arguments: args precedence: p 210201 "Decompile." 210202 210203 self receiver: rcvr 210204 arguments: args 210205 precedence: p. 210206 selNode code == #macro 210207 ifTrue: [self noteSpecialSelector: selNode key] 210208 ifFalse: [special := 0]. 210209 selector := selNode. 210210 "self pvtCheckForPvtSelector: encoder" 210211 "We could test code being decompiled, but the compiler should've checked already. And where to send the complaint?"! ! 210212 210213!MessageNode methodsFor: 'initialize-release' stamp: 'eem 5/10/2008 12:10'! 210214receiver: rcvr selector: aSelector arguments: args precedence: p from: encoder 210215 "Compile." 210216 210217 self receiver: rcvr 210218 arguments: args 210219 precedence: p. 210220 self noteSpecialSelector: aSelector. 210221 (self transform: encoder) 210222 ifTrue: 210223 [selector isNil ifTrue: 210224 [selector := SelectorNode new 210225 key: (MacroSelectors at: special) 210226 code: #macro]] 210227 ifFalse: 210228 [selector := encoder encodeSelector: aSelector. 210229 rcvr == NodeSuper ifTrue: [encoder noteSuper]]. 210230 self pvtCheckForPvtSelector: encoder! ! 210231 210232!MessageNode methodsFor: 'initialize-release' stamp: 'eem 7/18/2008 16:26'! 210233receiver: rcvr selector: selName arguments: args precedence: p from: encoder sourceRange: range 210234 "Compile." 210235 ((selName == #future) or:[selName == #future:]) ifTrue: 210236 [Smalltalk at: #FutureNode ifPresent: 210237 [:futureNode| 210238 ^futureNode new 210239 receiver: rcvr 210240 selector: selName 210241 arguments: args 210242 precedence: p 210243 from: encoder 210244 sourceRange: range]]. 210245 (rcvr isFutureNode 210246 and: [rcvr futureSelector == nil]) ifTrue: 210247 "Transform regular message into future" 210248 [^rcvr futureMessage: selName 210249 arguments: args 210250 from: encoder 210251 sourceRange: range]. 210252 210253 encoder noteSourceRange: range forNode: self. 210254 ^self 210255 receiver: rcvr 210256 selector: selName 210257 arguments: args 210258 precedence: p 210259 from: encoder! ! 210260 210261!MessageNode methodsFor: 'initialize-release' stamp: 'tk 10/26/2000 15:37'! 210262selector: sel 210263 selector := sel! ! 210264 210265 210266!MessageNode methodsFor: 'macro transformations' stamp: 'eem 5/23/2008 13:14'! 210267noteSpecialSelector: selectorSymbol 210268 "special > 0 denotes specially treated (potentially inlined) messages. " 210269 210270 special := MacroSelectors indexOf: selectorSymbol. 210271! ! 210272 210273!MessageNode methodsFor: 'macro transformations' stamp: 'eem 7/21/2009 12:34'! 210274toDoFromWhileWithInit: initStmt 210275 "Return nil, or a to:do: expression equivalent to this whileTrue:" 210276 | variable increment limit toDoBlock body test | 210277 (selector key == #whileTrue: 210278 and: [initStmt isAssignmentNode 210279 and: [initStmt variable isTemp]]) ifFalse: 210280 [^nil]. 210281 body := arguments last statements. 210282 variable := initStmt variable. 210283 increment := body last toDoIncrement: variable. 210284 (increment == nil 210285 or: [receiver statements size ~= 1]) ifTrue: 210286 [^nil]. 210287 test := receiver statements first. 210288 "Note: test chould really be checked that <= or >= comparison 210289 jibes with the sign of the (constant) increment" 210290 (test isMessageNode 210291 and: [(limit := test toDoLimit: variable) notNil]) ifFalse: 210292 [^nil]. 210293 toDoBlock := BlockNode statements: body allButLast returns: false. 210294 toDoBlock arguments: (Array with: variable). 210295 variable scope: -1. 210296 variable beBlockArg. 210297 ^MessageNode new 210298 receiver: initStmt value 210299 selector: (SelectorNode new key: #to:by:do: code: #macro) 210300 arguments: (Array with: limit with: increment with: toDoBlock) 210301 precedence: precedence! ! 210302 210303!MessageNode methodsFor: 'macro transformations'! 210304transform: encoder 210305 special = 0 ifTrue: [^false]. 210306 (self perform: (MacroTransformers at: special) with: encoder) 210307 ifTrue: 210308 [^true] 210309 ifFalse: 210310 [special := 0. ^false]! ! 210311 210312!MessageNode methodsFor: 'macro transformations' stamp: 'eem 5/19/2008 17:15'! 210313transformAnd: encoder 210314 (self transformBoolean: encoder) 210315 ifTrue: 210316 [arguments := 210317 Array 210318 with: (arguments at: 1) noteOptimized 210319 with: (BlockNode withJust: NodeFalse) noteOptimized. 210320 ^true] 210321 ifFalse: 210322 [^false]! ! 210323 210324!MessageNode methodsFor: 'macro transformations'! 210325transformBoolean: encoder 210326 ^self 210327 checkBlock: (arguments at: 1) 210328 as: 'argument' 210329 from: encoder! ! 210330 210331!MessageNode methodsFor: 'macro transformations' stamp: 'eem 7/27/2008 18:50'! 210332transformCase: encoder 210333 210334 | caseNode | 210335 caseNode := arguments first. 210336 (caseNode isMemberOf: BraceNode) ifTrue: 210337 [((caseNode blockAssociationCheck: encoder) 210338 and: [arguments size = 1 210339 or: [self checkBlock: arguments last as: 'otherwise arg' from: encoder]]) ifFalse: 210340 [^false]. 210341 caseNode elements do: 210342 [:messageNode| 210343 messageNode receiver noteOptimized. 210344 messageNode arguments first noteOptimized]. 210345 arguments size = 2 ifTrue: 210346 [arguments last noteOptimized]. 210347 ^true]. 210348 (caseNode canBeSpecialArgument and: [(caseNode isMemberOf: BlockNode) not]) ifTrue: 210349 [^false]. "caseOf: variable" 210350 ^encoder notify: 'caseOf: argument must be a brace construct or a variable'! ! 210351 210352!MessageNode methodsFor: 'macro transformations' stamp: 'eem 5/19/2008 17:15'! 210353transformIfFalse: encoder 210354 (self transformBoolean: encoder) 210355 ifTrue: 210356 [arguments := 210357 Array 210358 with: (BlockNode withJust: NodeNil) noteOptimized 210359 with: (arguments at: 1) noteOptimized. 210360 ^true] 210361 ifFalse: 210362 [^false]! ! 210363 210364!MessageNode methodsFor: 'macro transformations' stamp: 'eem 7/27/2008 16:19'! 210365transformIfFalseIfTrue: encoder 210366 ^(self checkBlock: (arguments at: 1) as: 'False arg' from: encoder) 210367 and: [(self checkBlock: (arguments at: 2) as: 'True arg' from: encoder) 210368 and: [selector := SelectorNode new key: #ifTrue:ifFalse: code: #macro. 210369 arguments swap: 1 with: 2. 210370 arguments do: [:arg| arg noteOptimized]. 210371 true]]! ! 210372 210373!MessageNode methodsFor: 'macro transformations' stamp: 'eem 5/23/2008 10:51'! 210374transformIfNil: encoder 210375 210376 "vb: Removed the original transformBoolean: which amounds to a test we perform in each of the branches below." 210377 (MacroSelectors at: special) = #ifNotNil: ifTrue: 210378 [(self checkBlock: arguments first as: 'ifNotNil arg' from: encoder maxArgs: 1) ifFalse: 210379 [^false]. 210380 210381 "Transform 'ifNotNil: [stuff]' to 'ifNil: [nil] ifNotNil: [stuff]'. 210382 Slightly better code and more consistent with decompilation." 210383 self noteSpecialSelector: #ifNil:ifNotNil:. 210384 selector := SelectorNode new key: (MacroSelectors at: special) code: #macro. 210385 arguments := Array 210386 with: (BlockNode withJust: NodeNil) noteOptimized 210387 with: arguments first noteOptimized. 210388 (self transform: encoder) ifFalse: 210389 [self error: 'compiler logic error']. 210390 ^true]. 210391 (self checkBlock: arguments first as: 'ifNil arg' from: encoder) ifFalse: 210392 [^false]. 210393 arguments first noteOptimized. 210394 ^true! ! 210395 210396!MessageNode methodsFor: 'macro transformations' stamp: 'eem 5/23/2008 10:56'! 210397transformIfNilIfNotNil: encoder 210398 "vb: Changed to support one-argument ifNotNil: branch. In the 1-arg case we 210399 transform the receiver to 210400 (var := receiver) 210401 which is further transformed to 210402 (var := receiver) == nil ifTrue: .... ifFalse: ... 210403 This does not allow the block variable to shadow an existing temp, but it's no different 210404 from how to:do: is done." 210405 | ifNotNilArg | 210406 ifNotNilArg := arguments at: 2. 210407 ((self checkBlock: (arguments at: 1) as: 'Nil arg' from: encoder) 210408 and: [self checkBlock: ifNotNilArg as: 'NotNil arg' from: encoder maxArgs: 1]) ifFalse: 210409 [^false]. 210410 210411 ifNotNilArg numberOfArguments = 1 ifTrue: 210412 [receiver := AssignmentNode new 210413 variable: ifNotNilArg firstArgument 210414 value: receiver]. 210415 210416 selector := SelectorNode new key: #ifTrue:ifFalse: code: #macro. 210417 receiver := MessageNode new 210418 receiver: receiver 210419 selector: #== 210420 arguments: (Array with: NodeNil) 210421 precedence: 2 210422 from: encoder. 210423 arguments do: [:arg| arg noteOptimized]. 210424 ^true! ! 210425 210426!MessageNode methodsFor: 'macro transformations' stamp: 'eem 5/23/2008 11:00'! 210427transformIfNotNilIfNil: encoder 210428 "vb: Changed to support one-argument ifNotNil: branch. In the 1-arg case we 210429 transform the receiver to 210430 (var := receiver) 210431 which is further transformed to 210432 (var := receiver) == nil ifTrue: .... ifFalse: ... 210433 This does not allow the block variable to shadow an existing temp, but it's no different 210434 from how to:do: is done." 210435 | ifNotNilArg | 210436 ifNotNilArg := arguments at: 1. 210437 ((self checkBlock: ifNotNilArg as: 'NotNil arg' from: encoder maxArgs: 1) 210438 and: [self checkBlock: (arguments at: 2) as: 'Nil arg' from: encoder]) ifFalse: 210439 [^false]. 210440 210441 ifNotNilArg numberOfArguments = 1 ifTrue: 210442 [receiver := AssignmentNode new 210443 variable: ifNotNilArg firstArgument 210444 value: receiver]. 210445 210446 selector := SelectorNode new key: #ifTrue:ifFalse: code: #macro. 210447 receiver := MessageNode new 210448 receiver: receiver 210449 selector: #== 210450 arguments: (Array with: NodeNil) 210451 precedence: 2 210452 from: encoder. 210453 arguments swap: 1 with: 2. 210454 arguments do: [:arg| arg noteOptimized]. 210455 ^true! ! 210456 210457!MessageNode methodsFor: 'macro transformations' stamp: 'eem 5/19/2008 17:17'! 210458transformIfTrue: encoder 210459 (self transformBoolean: encoder) 210460 ifTrue: 210461 [arguments := 210462 Array 210463 with: (arguments at: 1) noteOptimized 210464 with: (BlockNode withJust: NodeNil) noteOptimized. 210465 ^true] 210466 ifFalse: 210467 [^false]! ! 210468 210469!MessageNode methodsFor: 'macro transformations' stamp: 'eem 5/19/2008 17:17'! 210470transformIfTrueIfFalse: encoder 210471 ^(self checkBlock: (arguments at: 1) as: 'True arg' from: encoder) 210472 and: [(self checkBlock: (arguments at: 2) as: 'False arg' from: encoder) 210473 and: [arguments do: [:arg| arg noteOptimized]. 210474 true]]! ! 210475 210476!MessageNode methodsFor: 'macro transformations' stamp: 'eem 5/19/2008 17:15'! 210477transformOr: encoder 210478 (self transformBoolean: encoder) 210479 ifTrue: 210480 [arguments := 210481 Array 210482 with: (BlockNode withJust: NodeTrue) noteOptimized 210483 with: (arguments at: 1) noteOptimized. 210484 ^true] 210485 ifFalse: 210486 [^false]! ! 210487 210488!MessageNode methodsFor: 'macro transformations' stamp: 'eem 6/2/2008 14:14'! 210489transformToDo: encoder 210490 " var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] 210491Jmp(L1) L2: " 210492 | limit increment block initStmt test incStmt limitInit blockVar myRange blockRange | 210493 "First check for valid arguments" 210494 ((arguments last isMemberOf: BlockNode) 210495 and: [arguments last numberOfArguments = 1 210496 and: [arguments last firstArgument isVariableReference "As with debugger remote vars"]]) ifFalse: 210497 [^false]. 210498 arguments size = 3 210499 ifTrue: [increment := arguments at: 2. 210500 (increment isConstantNumber 210501 and: [increment literalValue ~= 0]) ifFalse: [^ false]] 210502 ifFalse: [increment := encoder encodeLiteral: 1]. 210503 arguments size < 3 ifTrue: "transform to full form" 210504 [selector := SelectorNode new key: #to:by:do: code: #macro]. 210505 210506 "Now generate auxiliary structures" 210507 myRange := encoder rawSourceRanges at: self ifAbsent: [1 to: 0]. 210508 block := arguments last. 210509 blockRange := encoder rawSourceRanges at: block ifAbsent: [1 to: 0]. 210510 blockVar := block firstArgument. 210511 initStmt := AssignmentNode new variable: blockVar value: receiver. 210512 limit := arguments at: 1. 210513 limit isVariableReference | limit isConstantNumber 210514 ifTrue: [limitInit := nil] 210515 ifFalse: "Need to store limit in a var" 210516 [limit := encoder bindBlockArg: blockVar key, 'LimiT' within: block. 210517 limit scope: -2. "Already done parsing block; flag so it won't print" 210518 block addArgument: limit. 210519 limitInit := AssignmentNode new 210520 variable: limit 210521 value: arguments first]. 210522 test := MessageNode new 210523 receiver: blockVar 210524 selector: (increment key > 0 ifTrue: [#<=] ifFalse: [#>=]) 210525 arguments: (Array with: limit) 210526 precedence: precedence from: encoder 210527 sourceRange: (myRange first to: blockRange first). 210528 incStmt := AssignmentNode new 210529 variable: blockVar 210530 value: (MessageNode new 210531 receiver: blockVar selector: #+ 210532 arguments: (Array with: increment) 210533 precedence: precedence from: encoder) 210534 from: encoder 210535 sourceRange: (myRange last to: myRange last). 210536 arguments := (Array with: limit with: increment with: block), 210537 (Array with: initStmt with: test with: incStmt with: limitInit). 210538 block noteOptimized. 210539 ^true! ! 210540 210541!MessageNode methodsFor: 'macro transformations' stamp: 'eem 5/19/2008 19:17'! 210542transformWhile: encoder 210543 (self checkBlock: receiver as: 'receiver' from: encoder) ifFalse: 210544 [^false]. 210545 arguments size = 0 ifTrue: "transform bodyless form to body form" 210546 [selector := SelectorNode new 210547 key: (special = 10 ifTrue: [#whileTrue:] ifFalse: [#whileFalse:]) 210548 code: #macro. 210549 arguments := Array with: (BlockNode withJust: NodeNil) noteOptimized. 210550 receiver noteOptimized. 210551 ^true]. 210552 ^(self transformBoolean: encoder) 210553 and: [receiver noteOptimized. 210554 arguments first noteOptimized. 210555 true]! ! 210556 210557 210558!MessageNode methodsFor: 'printing' stamp: 'RAA 2/15/2001 19:25'! 210559macroPrinter 210560 210561 special > 0 ifTrue: [^MacroPrinters at: special]. 210562 ^nil 210563! ! 210564 210565!MessageNode methodsFor: 'printing'! 210566precedence 210567 210568 ^precedence! ! 210569 210570!MessageNode methodsFor: 'printing' stamp: 'eem 5/6/2008 13:56'! 210571printCaseOn: aStream indent: level 210572 "receiver caseOf: {[key]->[value]. ...} otherwise: [otherwise]" 210573 | braceNode otherwise extra | 210574 braceNode := arguments first. 210575 otherwise := arguments last. 210576 (arguments size = 1 or: [otherwise isJustCaseError]) ifTrue: 210577 [otherwise := nil]. 210578 receiver 210579 printOn: aStream 210580 indent: level 210581 precedence: 3. 210582 aStream nextPutAll: ' caseOf: '. 210583 braceNode isVariableReference 210584 ifTrue: [braceNode printOn: aStream indent: level] 210585 ifFalse: 210586 [aStream nextPutAll: '{'; crtab: level + 1. 210587 braceNode casesForwardDo: 210588 [:keyNode :valueNode :last | 210589 keyNode printOn: aStream indent: level + 1. 210590 aStream nextPutAll: ' -> '. 210591 valueNode isComplex 210592 ifTrue: 210593 [aStream crtab: level + 2. 210594 extra := 1] 210595 ifFalse: [extra := 0]. 210596 valueNode printOn: aStream indent: level + 1 + extra. 210597 last ifTrue: [aStream nextPut: $}] 210598 ifFalse: [aStream nextPut: $.; 210599 crtab: level + 1]]]. 210600 otherwise notNil ifTrue: 210601 [aStream crtab: level + 1; nextPutAll: ' otherwise: '. 210602 extra := otherwise isComplex 210603 ifTrue: 210604 [aStream crtab: level + 2. 210605 1] 210606 ifFalse: [0]. 210607 otherwise printOn: aStream indent: level + 1 + extra]! ! 210608 210609!MessageNode methodsFor: 'printing' stamp: 'di 5/1/2000 23:20'! 210610printIfNil: aStream indent: level 210611 210612 self printReceiver: receiver on: aStream indent: level. 210613 210614 ^self printKeywords: selector key 210615 arguments: (Array with: arguments first) 210616 on: aStream indent: level! ! 210617 210618!MessageNode methodsFor: 'printing' stamp: 'di 5/1/2000 23:20'! 210619printIfNilNotNil: aStream indent: level 210620 210621 self printReceiver: receiver ifNilReceiver on: aStream indent: level. 210622 210623 (arguments first isJust: NodeNil) ifTrue: 210624 [^ self printKeywords: #ifNotNil: 210625 arguments: { arguments second } 210626 on: aStream indent: level]. 210627 (arguments second isJust: NodeNil) ifTrue: 210628 [^ self printKeywords: #ifNil: 210629 arguments: { arguments first } 210630 on: aStream indent: level]. 210631 ^ self printKeywords: #ifNil:ifNotNil: 210632 arguments: arguments 210633 on: aStream indent: level! ! 210634 210635!MessageNode methodsFor: 'printing' stamp: 'eem 5/6/2008 13:57'! 210636printIfOn: aStream indent: level 210637 210638 receiver ifNotNil: 210639 [receiver printOn: aStream indent: level + 1 precedence: precedence]. 210640 (arguments last isJust: NodeNil) ifTrue: 210641 [^self printKeywords: #ifTrue: arguments: (Array with: arguments first) 210642 on: aStream indent: level]. 210643 (arguments last isJust: NodeFalse) ifTrue: 210644 [^self printKeywords: #and: arguments: (Array with: arguments first) 210645 on: aStream indent: level]. 210646 (arguments first isJust: NodeNil) ifTrue: 210647 [^self printKeywords: #ifFalse: arguments: (Array with: arguments last) 210648 on: aStream indent: level]. 210649 (arguments first isJust: NodeTrue) ifTrue: 210650 [^self printKeywords: #or: arguments: (Array with: arguments last) 210651 on: aStream indent: level]. 210652 self printKeywords: #ifTrue:ifFalse: arguments: arguments 210653 on: aStream indent: level! ! 210654 210655!MessageNode methodsFor: 'printing' stamp: 'eem 9/25/2008 15:41'! 210656printKeywords: key arguments: args on: aStream indent: level 210657 | keywords indent arg kwd doCrTab | 210658 args size = 0 ifTrue: 210659 [aStream space; nextPutAll: key. 210660 ^self]. 210661 keywords := key keywords. 210662 doCrTab := args size > 2 210663 or: [{receiver} , args anySatisfy: 210664 [:thisArg | 210665 thisArg notNil 210666 and: [thisArg isBlockNode 210667 or: [thisArg isMessageNode and: [thisArg precedence >= 3]]]]]. 210668 1 to: (args size min: keywords size) do: 210669 [:i | 210670 arg := args at: i. 210671 kwd := keywords at: i. 210672 doCrTab 210673 ifTrue: [aStream crtab: level+1. indent := 1] "newline after big args" 210674 ifFalse: [aStream space. indent := 0]. 210675 aStream nextPutAll: kwd; space. 210676 arg printOn: aStream 210677 indent: level + 1 + indent 210678 precedence: (precedence = 2 ifTrue: [1] ifFalse: [precedence])]! ! 210679 210680!MessageNode methodsFor: 'printing' stamp: 'eem 9/25/2008 16:12'! 210681printOn: aStream indent: level 210682 "may not need this check anymore - may be fixed by the #receiver: change" 210683 special ifNil: [^aStream nextPutAll: '** MessageNode with nil special **']. 210684 210685 special > 0 ifTrue: 210686 [^self perform: self macroPrinter with: aStream with: level]. 210687 210688 self printReceiver: receiver on: aStream indent: level. 210689 selector isForFFICall 210690 ifTrue: 210691 [aStream space. 210692 selector 210693 printAsFFICallWithArguments: arguments 210694 on: aStream 210695 indent: 0] 210696 ifFalse: 210697 [self printKeywords: selector key 210698 arguments: arguments 210699 on: aStream 210700 indent: level]! ! 210701 210702!MessageNode methodsFor: 'printing' stamp: 'di 5/30/2000 23:17'! 210703printOn: strm indent: level precedence: outerPrecedence 210704 210705 | parenthesize | 210706 parenthesize := precedence > outerPrecedence 210707 or: [outerPrecedence = 3 and: [precedence = 3 "both keywords"]]. 210708 parenthesize 210709 ifTrue: [strm nextPutAll: '('. 210710 self printOn: strm indent: level. 210711 strm nextPutAll: ')'] 210712 ifFalse: [self printOn: strm indent: level]! ! 210713 210714!MessageNode methodsFor: 'printing' stamp: 'eem 9/25/2008 14:51'! 210715printParenReceiver: rcvr on: aStream indent: level 210716 210717 rcvr isBlockNode ifTrue: 210718 [^rcvr printOn: aStream indent: level]. 210719 aStream nextPut: $(. 210720 rcvr printOn: aStream indent: level. 210721 aStream nextPut: $) 210722! ! 210723 210724!MessageNode methodsFor: 'printing' stamp: 'eem 5/6/2008 14:09'! 210725printReceiver: rcvr on: aStream indent: level 210726 210727 rcvr ifNil: [^ self]. 210728 210729 "Force parens around keyword receiver of kwd message" 210730 rcvr printOn: aStream indent: level precedence: precedence! ! 210731 210732!MessageNode methodsFor: 'printing' stamp: 'eem 9/25/2008 14:41'! 210733printToDoOn: aStream indent: level 210734 210735 | limitNode | 210736 self printReceiver: receiver on: aStream indent: level. 210737 210738 (arguments last == nil or: [(arguments last isMemberOf: AssignmentNode) not]) 210739 ifTrue: [limitNode := arguments first] 210740 ifFalse: [limitNode := arguments last value]. 210741 (selector key = #to:by:do: 210742 and: [(arguments at: 2) isConstantNumber 210743 and: [(arguments at: 2) key == 1]]) 210744 ifTrue: [self printKeywords: #to:do: 210745 arguments: (Array with: limitNode with: (arguments at: 3)) 210746 on: aStream indent: level] 210747 ifFalse: [self printKeywords: selector key 210748 arguments: (Array with: limitNode) , arguments allButFirst 210749 on: aStream indent: level]! ! 210750 210751!MessageNode methodsFor: 'printing' stamp: 'eem 5/6/2008 14:14'! 210752printWhileOn: aStream indent: level 210753 210754 self printReceiver: receiver on: aStream indent: level. 210755 (arguments isEmpty not 210756 and: [arguments first isJust: NodeNil]) ifTrue: 210757 [selector := SelectorNode new 210758 key: 210759 (selector key == #whileTrue: 210760 ifTrue: [#whileTrue] 210761 ifFalse: [#whileFalse]) 210762 code: #macro. 210763 arguments := Array new]. 210764 self printKeywords: selector key arguments: arguments 210765 on: aStream indent: level! ! 210766 210767!MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 210768printWithClosureAnalysisCaseOn: aStream indent: level 210769 "receiver caseOf: {[key]->[value]. ...} otherwise: [otherwise]" 210770 | braceNode otherwise extra | 210771 braceNode := arguments first. 210772 otherwise := arguments last. 210773 (arguments size = 1 or: [otherwise isJustCaseError]) ifTrue: 210774 [otherwise := nil]. 210775 receiver 210776 printWithClosureAnalysisOn: aStream 210777 indent: level 210778 precedence: 3. 210779 aStream nextPutAll: ' caseOf: '. 210780 braceNode isVariableReference 210781 ifTrue: [braceNode printWithClosureAnalysisOn: aStream indent: level] 210782 ifFalse: 210783 [aStream nextPutAll: '{'; crtab: level + 1. 210784 braceNode casesForwardDo: 210785 [:keyNode :valueNode :last | 210786 keyNode printWithClosureAnalysisOn: aStream indent: level + 1. 210787 aStream nextPutAll: ' -> '. 210788 valueNode isComplex 210789 ifTrue: 210790 [aStream crtab: level + 2. 210791 extra := 1] 210792 ifFalse: [extra := 0]. 210793 valueNode printWithClosureAnalysisOn: aStream indent: level + 1 + extra. 210794 last ifTrue: [aStream nextPut: $}] 210795 ifFalse: [aStream nextPut: $.; 210796 crtab: level + 1]]]. 210797 otherwise notNil ifTrue: 210798 [aStream crtab: level + 1; nextPutAll: ' otherwise: '. 210799 extra := otherwise isComplex 210800 ifTrue: 210801 [aStream crtab: level + 2. 210802 1] 210803 ifFalse: [0]. 210804 otherwise printWithClosureAnalysisOn: aStream indent: level + 1 + extra]! ! 210805 210806!MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 210807printWithClosureAnalysisIfNil: aStream indent: level 210808 210809 self printWithClosureAnalysisReceiver: receiver on: aStream indent: level. 210810 210811 ^self printWithClosureAnalysisKeywords: selector key 210812 arguments: (Array with: arguments first) 210813 on: aStream indent: level! ! 210814 210815!MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 210816printWithClosureAnalysisIfNilNotNil: aStream indent: level 210817 210818 self printWithClosureAnalysisReceiver: receiver ifNilReceiver on: aStream indent: level. 210819 210820 (arguments first isJust: NodeNil) ifTrue: 210821 [^self printWithClosureAnalysisKeywords: #ifNotNil: 210822 arguments: { arguments second } 210823 on: aStream indent: level]. 210824 (arguments second isJust: NodeNil) ifTrue: 210825 [^self printWithClosureAnalysisKeywords: #ifNil: 210826 arguments: { arguments first } 210827 on: aStream indent: level]. 210828 ^self printWithClosureAnalysisKeywords: #ifNil:ifNotNil: 210829 arguments: arguments 210830 on: aStream indent: level! ! 210831 210832!MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 210833printWithClosureAnalysisIfOn: aStream indent: level 210834 210835 receiver ifNotNil: 210836 [receiver printWithClosureAnalysisOn: aStream indent: level + 1 precedence: precedence]. 210837 (arguments last isJust: NodeNil) ifTrue: 210838 [^self printWithClosureAnalysisKeywords: #ifTrue: arguments: (Array with: arguments first) 210839 on: aStream indent: level]. 210840 (arguments last isJust: NodeFalse) ifTrue: 210841 [^self printWithClosureAnalysisKeywords: #and: arguments: (Array with: arguments first) 210842 on: aStream indent: level]. 210843 (arguments first isJust: NodeNil) ifTrue: 210844 [^self printWithClosureAnalysisKeywords: #ifFalse: arguments: (Array with: arguments last) 210845 on: aStream indent: level]. 210846 (arguments first isJust: NodeTrue) ifTrue: 210847 [^self printWithClosureAnalysisKeywords: #or: arguments: (Array with: arguments last) 210848 on: aStream indent: level]. 210849 self printWithClosureAnalysisKeywords: #ifTrue:ifFalse: arguments: arguments 210850 on: aStream indent: level! ! 210851 210852!MessageNode methodsFor: 'printing' stamp: 'eem 9/25/2008 14:51'! 210853printWithClosureAnalysisKeywords: key arguments: args on: aStream indent: level 210854 | keywords indent arg kwd doCrTab | 210855 args size = 0 ifTrue: [aStream space; nextPutAll: key. ^self]. 210856 keywords := key keywords. 210857 doCrTab := args size > 2 210858 or: [{receiver} , args anySatisfy: 210859 [:thisArg | 210860 thisArg isBlockNode 210861 or: [thisArg isMessageNode and: [thisArg precedence >= 3]]]]. 210862 1 to: (args size min: keywords size) do: 210863 [:i | 210864 arg := args at: i. 210865 kwd := keywords at: i. 210866 doCrTab 210867 ifTrue: [aStream crtab: level+1. indent := 1] "newline after big args" 210868 ifFalse: [aStream space. indent := 0]. 210869 aStream nextPutAll: kwd; space. 210870 arg printWithClosureAnalysisOn: aStream 210871 indent: level + 1 + indent 210872 precedence: (precedence = 2 ifTrue: [1] ifFalse: [precedence])]! ! 210873 210874!MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 210875printWithClosureAnalysisOn: aStream indent: level 210876 "may not need this check anymore - may be fixed by the #receiver: change" 210877 special ifNil: [^aStream nextPutAll: '** MessageNode with nil special **']. 210878 210879 special > 0 ifTrue: 210880 [^self perform: self macroPrinter with: aStream with: level]. 210881 210882 self printWithClosureAnalysisReceiver: receiver on: aStream indent: level. 210883 self printWithClosureAnalysisKeywords: selector key 210884 arguments: arguments 210885 on: aStream 210886 indent: level! ! 210887 210888!MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 210889printWithClosureAnalysisOn: strm indent: level precedence: outerPrecedence 210890 210891 | parenthesize | 210892 parenthesize := precedence > outerPrecedence 210893 or: [outerPrecedence = 3 and: [precedence = 3 "both keywords"]]. 210894 parenthesize 210895 ifTrue: [strm nextPutAll: '('. 210896 self printWithClosureAnalysisOn: strm indent: level. 210897 strm nextPutAll: ')'] 210898 ifFalse: [self printWithClosureAnalysisOn: strm indent: level]! ! 210899 210900!MessageNode methodsFor: 'printing' stamp: 'eem 9/25/2008 14:53'! 210901printWithClosureAnalysisParenReceiver: rcvr on: aStream indent: level 210902 210903 rcvr isBlockNode ifTrue: 210904 [^rcvr printWithClosureAnalysisOn: aStream indent: level]. 210905 aStream nextPut: $(. 210906 rcvr printWithClosureAnalysisOn: aStream indent: level. 210907 aStream nextPut: $)! ! 210908 210909!MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 210910printWithClosureAnalysisReceiver: rcvr on: aStream indent: level 210911 210912 rcvr ifNil: [^self]. 210913 210914 "Force parens around keyword receiver of kwd message" 210915 rcvr printWithClosureAnalysisOn: aStream indent: level precedence: precedence! ! 210916 210917!MessageNode methodsFor: 'printing' stamp: 'eem 9/25/2008 14:53'! 210918printWithClosureAnalysisToDoOn: aStream indent: level 210919 210920 | limitNode | 210921 self printWithClosureAnalysisReceiver: receiver on: aStream indent: level. 210922 210923 limitNode := (arguments last == nil 210924 or: [arguments last isAssignmentNode not]) 210925 ifTrue: [arguments first] 210926 ifFalse: [arguments last value]. 210927 (selector key = #to:by:do: 210928 and: [(arguments at: 2) isConstantNumber 210929 and: [(arguments at: 2) key == 1]]) 210930 ifTrue: [self printWithClosureAnalysisKeywords: #to:do: 210931 arguments: (Array with: limitNode with: (arguments at: 3)) 210932 on: aStream indent: level] 210933 ifFalse: [self printWithClosureAnalysisKeywords: selector key 210934 arguments: (Array with: limitNode) , arguments allButFirst 210935 on: aStream indent: level]! ! 210936 210937!MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 210938printWithClosureAnalysisWhileOn: aStream indent: level 210939 210940 self printWithClosureAnalysisReceiver: receiver on: aStream indent: level. 210941 (arguments isEmpty not 210942 and: [arguments first isJust: NodeNil]) ifTrue: 210943 [selector := SelectorNode new 210944 key: 210945 (selector key == #whileTrue: 210946 ifTrue: [#whileTrue] 210947 ifFalse: [#whileFalse]) 210948 code: #macro. 210949 arguments := Array new]. 210950 self printWithClosureAnalysisKeywords: selector key arguments: arguments 210951 on: aStream indent: level! ! 210952 210953!MessageNode methodsFor: 'printing' stamp: 'di 5/2/2000 00:16'! 210954test 210955 210956 3 > 4 ifTrue: [4+5 between: 6 and: 7] 210957 ifFalse: [4 between: 6+5 and: 7-2]! ! 210958 210959 210960!MessageNode methodsFor: 'testing'! 210961canCascade 210962 210963 ^(receiver == NodeSuper or: [special > 0]) not! ! 210964 210965!MessageNode methodsFor: 'testing'! 210966isComplex 210967 210968 ^(special between: 1 and: 10) or: [arguments size > 2 or: [receiver isComplex]]! ! 210969 210970!MessageNode methodsFor: 'testing' stamp: 'md 7/27/2006 19:09'! 210971isMessage 210972 ^true! ! 210973 210974!MessageNode methodsFor: 'testing'! 210975isMessage: selSymbol receiver: rcvrPred arguments: argsPred 210976 "Answer whether selector is selSymbol, and the predicates rcvrPred and argsPred 210977 evaluate to true with respect to receiver and the list of arguments. If selSymbol or 210978 either predicate is nil, it means 'don't care'. Note that argsPred takes numArgs 210979 arguments. All block arguments are ParseNodes." 210980 210981 ^(selSymbol isNil or: [selSymbol==selector key]) and: 210982 [(rcvrPred isNil or: [rcvrPred value: receiver]) and: 210983 [(argsPred isNil or: [argsPred valueWithArguments: arguments])]]! ! 210984 210985!MessageNode methodsFor: 'testing' stamp: 'John M McIntosh 3/2/2009 19:58'! 210986isMessageNode 210987 ^true! ! 210988 210989!MessageNode methodsFor: 'testing' stamp: 'eem 9/23/2008 14:06'! 210990isNilIf 210991 210992 ^(special between: 3 and: 4) 210993 and: [(arguments first returns or: [arguments first isJust: NodeNil]) 210994 and: [(arguments last returns or: [arguments last isJust: NodeNil])]]! ! 210995 210996!MessageNode methodsFor: 'testing' stamp: 'eem 7/20/2009 09:31'! 210997isOptimized 210998 ^special > 0! ! 210999 211000!MessageNode methodsFor: 'testing' stamp: 'eem 7/20/2009 10:44'! 211001isOptimizedLoop 211002 ^special > 0 211003 and: [#(transformWhile: transformToDo:) includes: (MacroTransformers at: special)]! ! 211004 211005!MessageNode methodsFor: 'testing' stamp: 'eem 9/26/2008 12:39'! 211006isReturningIf 211007 211008 ^((special between: 3 and: 4) "ifTrue:ifFalse:/ifFalse:ifTrue:" 211009 or: [special between: 17 and: 18]) "ifNil:ifNotNil:/ifNotNil:ifNil:" 211010 and: [arguments first returns and: [arguments last returns]]! ! 211011 211012!MessageNode methodsFor: 'testing'! 211013toDoIncrement: variable 211014 (receiver = variable and: [selector key = #+]) 211015 ifFalse: [^ nil]. 211016 arguments first isConstantNumber 211017 ifTrue: [^ arguments first] 211018 ifFalse: [^ nil]! ! 211019 211020!MessageNode methodsFor: 'testing'! 211021toDoLimit: variable 211022 (receiver = variable and: [selector key = #<= or: [selector key = #>=]]) 211023 ifTrue: [^ arguments first] 211024 ifFalse: [^ nil]! ! 211025 211026 211027!MessageNode methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:50'! 211028accept: aVisitor 211029 aVisitor visitMessageNode: self! ! 211030 211031!MessageNode methodsFor: 'visiting' stamp: 'eem 9/23/2008 21:52'! 211032argumentsInEvaluationOrder 211033 "Answer the receivers arguments in evaluation order. 211034 If the receiver is a transformed to:do: node this will undo the misordering done by the transformation." 211035 ^(special > 0 211036 and: [(MacroTransformers at: special) == #transformToDo: 211037 and: [arguments size >= 7]]) 211038 "arguments are in a weid order and may be nil in a transformed to:do: loop. sigh... 211039 c.f. emitCodeForToDo:encoder:value:" 211040 ifTrue: 211041 [(arguments at: 7) "limitInit" 211042 ifNil: [{ (arguments at: 4). "initStmt" 211043 (arguments at: 5). "test" 211044 (arguments at: 3). "block" 211045 (arguments at: 6) "incStmt" }] 211046 ifNotNil: [:limitInit| 211047 { limitInit. 211048 (arguments at: 4). "initStmt" 211049 (arguments at: 5). "test" 211050 (arguments at: 3). "block" 211051 (arguments at: 6) "incStmt" }]] 211052 ifFalse: 211053 [arguments]! ! 211054 211055 211056!MessageNode methodsFor: 'private' stamp: 'vb 4/15/2007 09:10'! 211057checkBlock: node as: nodeName from: encoder 211058 211059 ^self checkBlock: node as: nodeName from: encoder maxArgs: 0! ! 211060 211061!MessageNode methodsFor: 'private' stamp: 'eem 9/25/2008 14:48'! 211062checkBlock: node as: nodeName from: encoder maxArgs: maxArgs 211063 "vb: #canBeSpecialArgument for blocks hardcodes 0 arguments as the requirement for special blocks. We work around that here by further checking the number of arguments for blocks.." 211064 211065 node canBeSpecialArgument ifTrue: 211066 [^node isBlockNode]. 211067 ^node isBlockNode 211068 ifTrue: 211069 [node numberOfArguments <= maxArgs 211070 ifTrue: [true] 211071 ifFalse: [encoder notify: '<- ', nodeName , ' of ' , 211072 (MacroSelectors at: special) , ' has too many arguments']] 211073 ifFalse: 211074 [encoder notify: '<- ', nodeName , ' of ' , 211075 (MacroSelectors at: special) , ' must be a block or variable']! ! 211076 211077!MessageNode methodsFor: 'private' stamp: 'acg 1/28/2000 00:57'! 211078ifNilReceiver 211079 211080 ^receiver! ! 211081 211082!MessageNode methodsFor: 'private' stamp: 'tk 8/2/1999 18:40'! 211083pvtCheckForPvtSelector: encoder 211084 "If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder." 211085 211086 selector isPvtSelector ifTrue: 211087 [receiver isSelfPseudoVariable ifFalse: 211088 [encoder notify: 'Private messages may only be sent to self']].! ! 211089 211090!MessageNode methodsFor: 'private'! 211091receiver: rcvr arguments: args precedence: p 211092 211093 receiver := rcvr. 211094 arguments := args. 211095 sizes := Array new: arguments size. 211096 precedence := p! ! 211097 211098"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 211099 211100MessageNode class 211101 instanceVariableNames: ''! 211102 211103!MessageNode class methodsFor: 'class initialization' stamp: 'eem 5/14/2008 18:15'! 211104initialize "MessageNode initialize" 211105 MacroSelectors := 211106 #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: 211107 and: or: 211108 whileFalse: whileTrue: whileFalse whileTrue 211109 to:do: to:by:do: 211110 caseOf: caseOf:otherwise: 211111 ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:). 211112 MacroTransformers := 211113 #( transformIfTrue: transformIfFalse: transformIfTrueIfFalse: transformIfFalseIfTrue: 211114 transformAnd: transformOr: 211115 transformWhile: transformWhile: transformWhile: transformWhile: 211116 transformToDo: transformToDo: 211117 transformCase: transformCase: 211118 transformIfNil: transformIfNil: transformIfNilIfNotNil: transformIfNotNilIfNil:). 211119 MacroEmitters := 211120 #( emitIf:on:value: emitIf:on:value: emitIf:on:value: emitIf:on:value: 211121 emitIf:on:value: emitIf:on:value: 211122 emitWhile:on:value: emitWhile:on:value: emitWhile:on:value: emitWhile:on:value: 211123 emitToDo:on:value: emitToDo:on:value: 211124 emitCase:on:value: emitCase:on:value: 211125 emitIfNil:on:value: emitIfNil:on:value: emitIf:on:value: emitIf:on:value:). 211126 NewStyleMacroEmitters := 211127 #( emitCodeForIf:encoder:value: emitCodeForIf:encoder:value: 211128 emitCodeForIf:encoder:value: emitCodeForIf:encoder:value: 211129 emitCodeForIf:encoder:value: emitCodeForIf:encoder:value: 211130 emitCodeForWhile:encoder:value: emitCodeForWhile:encoder:value: 211131 emitCodeForWhile:encoder:value: emitCodeForWhile:encoder:value: 211132 emitCodeForToDo:encoder:value: emitCodeForToDo:encoder:value: 211133 emitCodeForCase:encoder:value: emitCodeForCase:encoder:value: 211134 emitCodeForIfNil:encoder:value: emitCodeForIfNil:encoder:value: 211135 emitCodeForIf:encoder:value: emitCodeForIf:encoder:value:). 211136 MacroSizers := 211137 #( sizeIf:value: sizeIf:value: sizeIf:value: sizeIf:value: 211138 sizeIf:value: sizeIf:value: 211139 sizeWhile:value: sizeWhile:value: sizeWhile:value: sizeWhile:value: 211140 sizeToDo:value: sizeToDo:value: 211141 sizeCase:value: sizeCase:value: 211142 sizeIfNil:value: sizeIfNil:value: sizeIf:value: sizeIf:value:). 211143 NewStyleMacroSizers := 211144 #( sizeCodeForIf:value: sizeCodeForIf:value: sizeCodeForIf:value: sizeCodeForIf:value: 211145 sizeCodeForIf:value: sizeCodeForIf:value: 211146 sizeCodeForWhile:value: sizeCodeForWhile:value: sizeCodeForWhile:value: sizeCodeForWhile:value: 211147 sizeCodeForToDo:value: sizeCodeForToDo:value: 211148 sizeCodeForCase:value: sizeCodeForCase:value: 211149 sizeCodeForIfNil:value: sizeCodeForIfNil:value: sizeCodeForIf:value: sizeCodeForIf:value:). 211150 MacroPrinters := 211151 #( printIfOn:indent: printIfOn:indent: printIfOn:indent: printIfOn:indent: 211152 printIfOn:indent: printIfOn:indent: 211153 printWhileOn:indent: printWhileOn:indent: printWhileOn:indent: printWhileOn:indent: 211154 printToDoOn:indent: printToDoOn:indent: 211155 printCaseOn:indent: printCaseOn:indent: 211156 printIfNil:indent: printIfNil:indent: printIfNilNotNil:indent: printIfNilNotNil:indent:)! ! 211157Error subclass: #MessageNotUnderstood 211158 instanceVariableNames: 'message receiver reachedDefaultHandler' 211159 classVariableNames: '' 211160 poolDictionaries: '' 211161 category: 'Exceptions-Kernel'! 211162!MessageNotUnderstood commentStamp: '<historical>' prior: 0! 211163This exception is provided to support Object>>doesNotUnderstand:.! 211164 211165 211166!MessageNotUnderstood methodsFor: 'accessing' stamp: 'stephane.ducasse 12/22/2008 13:51'! 211167reachedDefaultHandler 211168 ^reachedDefaultHandler! ! 211169 211170 211171!MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'bf 6/17/2009 13:44'! 211172messageText 211173 "Return an exception's message text." 211174 211175 ^messageText == nil 211176 ifTrue: 211177 [message == nil 211178 ifTrue: [super messageText] 211179 ifFalse: [ 211180 message lookupClass == UndefinedObject 211181 ifTrue: ['receiver of "{1}" is nil' translated format: {message selector asString}] 211182 ifFalse: [message lookupClass printString, '>>', message selector asString]]] 211183 ifFalse: [messageText]! ! 211184 211185 211186!MessageNotUnderstood methodsFor: 'exceptionbuilder' stamp: 'pnm 8/16/2000 15:03'! 211187message: aMessage 211188 211189 message := aMessage! ! 211190 211191!MessageNotUnderstood methodsFor: 'exceptionbuilder' stamp: 'ajh 10/9/2001 16:38'! 211192receiver: obj 211193 211194 receiver := obj! ! 211195 211196 211197!MessageNotUnderstood methodsFor: 'exceptiondescription' stamp: 'stephane.ducasse 12/22/2008 13:50'! 211198defaultAction 211199 211200 reachedDefaultHandler := true. 211201 super defaultAction.! ! 211202 211203!MessageNotUnderstood methodsFor: 'exceptiondescription' stamp: 'tfei 6/4/1999 18:30'! 211204isResumable 211205 "Determine whether an exception is resumable." 211206 211207 ^true! ! 211208 211209!MessageNotUnderstood methodsFor: 'exceptiondescription' stamp: 'tfei 6/4/1999 18:27'! 211210message 211211 "Answer the selector and arguments of the message that failed." 211212 211213 ^message! ! 211214 211215!MessageNotUnderstood methodsFor: 'exceptiondescription' stamp: 'ajh 10/9/2001 16:39'! 211216receiver 211217 "Answer the receiver that did not understand the message" 211218 211219 ^ receiver! ! 211220 211221 211222!MessageNotUnderstood methodsFor: 'initialization' stamp: 'stephane.ducasse 12/22/2008 13:50'! 211223initialize 211224 211225 super initialize. 211226 reachedDefaultHandler := false ! ! 211227Object subclass: #MessageSend 211228 instanceVariableNames: 'receiver selector arguments' 211229 classVariableNames: '' 211230 poolDictionaries: '' 211231 category: 'Kernel-Objects'! 211232!MessageSend commentStamp: 'DF 5/25/2006 19:54' prior: 0! 211233Instances of MessageSend encapsulate message sends to objects. Arguments can be either predefined or supplied when the message send is performed. 211234 211235Use #value to perform a message send with its predefined arguments and #valueWithArguments: if additonal arguments have to supplied. 211236 211237Structure: 211238 receiver Object -- object receiving the message send 211239 selector Symbol -- message selector 211240 arguments Array -- bound arguments! 211241 211242 211243!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! 211244arguments 211245 ^ arguments! ! 211246 211247!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:40'! 211248arguments: anArray 211249 arguments := anArray! ! 211250 211251!MessageSend methodsFor: 'accessing' stamp: 'eem 1/3/2009 10:42'! 211252numArgs 211253 "Answer the number of arguments in this message" 211254 211255 ^arguments size! ! 211256 211257!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! 211258receiver 211259 ^ receiver! ! 211260 211261!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! 211262receiver: anObject 211263 receiver := anObject! ! 211264 211265!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! 211266selector 211267 ^ selector! ! 211268 211269!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! 211270selector: aSymbol 211271 selector := aSymbol! ! 211272 211273 211274!MessageSend methodsFor: 'comparing' stamp: 'sma 2/29/2000 20:43'! 211275= anObject 211276 ^ anObject species == self species 211277 and: [receiver == anObject receiver 211278 and: [selector == anObject selector 211279 and: [arguments = anObject arguments]]]! ! 211280 211281!MessageSend methodsFor: 'comparing' stamp: 'sma 3/11/2000 10:35'! 211282hash 211283 ^ receiver hash bitXor: selector hash! ! 211284 211285 211286!MessageSend methodsFor: 'converting' stamp: 'nk 12/20/2002 17:54'! 211287asMinimalRepresentation 211288 ^self! ! 211289 211290 211291!MessageSend methodsFor: 'evaluating' stamp: 'sw 2/20/2002 22:17'! 211292value 211293 "Send the message and answer the return value" 211294 211295 arguments ifNil: [^ receiver perform: selector]. 211296 211297 ^ receiver 211298 perform: selector 211299 withArguments: (self collectArguments: arguments)! ! 211300 211301!MessageSend methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 16:51'! 211302valueWithArguments: anArray 211303 211304 ^ receiver 211305 perform: selector 211306 withArguments: (self collectArguments: anArray)! ! 211307 211308!MessageSend methodsFor: 'evaluating' stamp: 'nk 3/11/2001 11:42'! 211309valueWithEnoughArguments: anArray 211310 "call the selector with enough arguments from arguments and anArray" 211311 | args | 211312 args := Array new: selector numArgs. 211313 args replaceFrom: 1 211314 to: (arguments size min: args size) 211315 with: arguments 211316 startingAt: 1. 211317 args size > arguments size ifTrue: [ 211318 args replaceFrom: arguments size + 1 211319 to: (arguments size + anArray size min: args size) 211320 with: anArray 211321 startingAt: 1. 211322 ]. 211323 ^ receiver perform: selector withArguments: args! ! 211324 211325 211326!MessageSend methodsFor: 'printing' stamp: 'SqR 7/14/2001 11:36'! 211327printOn: aStream 211328 211329 aStream 211330 nextPutAll: self class name; 211331 nextPut: $(. 211332 selector printOn: aStream. 211333 aStream nextPutAll: ' -> '. 211334 receiver printOn: aStream. 211335 aStream nextPut: $)! ! 211336 211337 211338!MessageSend methodsFor: 'testing' stamp: 'nk 4/25/2002 08:04'! 211339isMessageSend 211340 ^true 211341! ! 211342 211343!MessageSend methodsFor: 'testing' stamp: 'nk 7/21/2003 15:16'! 211344isValid 211345 ^true! ! 211346 211347 211348!MessageSend methodsFor: 'tiles' stamp: 'eem 7/21/2008 12:09'! 211349stringFor: anObject 211350 "Return a string suitable for compiling. Literal or reference from global ref dictionary. self is always named via the ref dictionary." 211351 211352 | generic aName | 211353 anObject isLiteral ifTrue: [^ anObject printString]. 211354 anObject class == Color ifTrue: [^ anObject printString]. 211355 anObject class superclass == Boolean ifTrue: [^ anObject printString]. 211356 anObject isBlock ifTrue: [^ '[''do nothing'']']. "default block" 211357 "Real blocks need to construct tiles in a different way" 211358 anObject class isMeta ifTrue: ["a class" ^ anObject name]. 211359 generic := anObject knownName. "may be nil or 'Ellipse' " 211360 aName := anObject uniqueNameForReference. 211361 generic ifNil: 211362 [(anObject respondsTo: #renameTo:) 211363 ifTrue: [anObject renameTo: aName] 211364 ifFalse: [aName := anObject storeString]]. "for Fraction, LargeInt, etc" 211365 ^ aName 211366! ! 211367 211368 211369!MessageSend methodsFor: 'private' stamp: 'reThink 2/18/2001 17:33'! 211370collectArguments: anArgArray 211371 "Private" 211372 211373 | staticArgs | 211374 staticArgs := self arguments. 211375 ^(anArgArray size = staticArgs size) 211376 ifTrue: [anArgArray] 211377 ifFalse: 211378 [(staticArgs isEmpty 211379 ifTrue: [ staticArgs := Array new: selector numArgs] 211380 ifFalse: [staticArgs copy] ) 211381 replaceFrom: 1 211382 to: (anArgArray size min: staticArgs size) 211383 with: anArgArray 211384 startingAt: 1]! ! 211385 211386"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 211387 211388MessageSend class 211389 instanceVariableNames: ''! 211390 211391!MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:44'! 211392receiver: anObject selector: aSymbol 211393 ^ self receiver: anObject selector: aSymbol arguments: #()! ! 211394 211395!MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:44'! 211396receiver: anObject selector: aSymbol argument: aParameter 211397 ^ self receiver: anObject selector: aSymbol arguments: (Array with: aParameter)! ! 211398 211399!MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:39'! 211400receiver: anObject selector: aSymbol arguments: anArray 211401 ^ self new 211402 receiver: anObject; 211403 selector: aSymbol; 211404 arguments: anArray! ! 211405Browser subclass: #MessageSet 211406 instanceVariableNames: 'messageList autoSelectString growable' 211407 classVariableNames: '' 211408 poolDictionaries: '' 211409 category: 'Tools-Browser'! 211410!MessageSet commentStamp: '<historical>' prior: 0! 211411I represent a query path of the retrieval result of making a query about methods in the system. The result is a set of methods, denoted by a message selector and the class in which the method was found. As a StringHolder, the string I represent is the source code of the currently selected method. I am typically viewed in a Message Set Browser consisting of a MessageListView and a BrowserCodeView.! 211412 211413 211414!MessageSet methodsFor: '*services-base' stamp: 'rr 8/25/2005 15:42'! 211415browseReference: ref 211416 self okToChange ifTrue: [ 211417 self initializeMessageList: (OrderedCollection with: ref). 211418 self changed: #messageList. 211419 self messageListIndex: 1. 211420 ] ! ! 211421 211422!MessageSet methodsFor: '*services-base' stamp: 'rr 8/27/2005 13:01'! 211423selectReference: ref 211424 self okToChange ifTrue: [self messageListIndex: (self messageList indexOf: ref)]! ! 211425 211426 211427!MessageSet methodsFor: 'class list'! 211428metaClassIndicated 211429 "Answer the boolean flag that indicates whether 211430 this is a class method." 211431 211432 ^ self selectedClassOrMetaClass isMeta! ! 211433 211434!MessageSet methodsFor: 'class list' stamp: 'sd 11/20/2005 21:27'! 211435selectedClass 211436 "Return the base class for the current selection. 1/17/96 sw fixed up so that it doesn't fall into a debugger in a msg browser that has no message selected" 211437 211438 | aClass | 211439 ^ (aClass := self selectedClassOrMetaClass) == nil 211440 ifTrue: 211441 [nil] 211442 ifFalse: 211443 [aClass theNonMetaClass]! ! 211444 211445!MessageSet methodsFor: 'class list' stamp: 'sd 11/20/2005 21:27'! 211446selectedClassName 211447 "Answer the name of class of the currently selected message. Answer nil if no selection 211448 exists." 211449 211450 | cls | 211451 (cls := self selectedClass) ifNil: [^ nil]. 211452 ^ cls name! ! 211453 211454!MessageSet methodsFor: 'class list'! 211455selectedClassOrMetaClass 211456 "Answer the currently selected class (or metaclass)." 211457 messageListIndex = 0 ifTrue: [^nil]. 211458 self setClassAndSelectorIn: [:c :s | ^c]! ! 211459 211460!MessageSet methodsFor: 'class list'! 211461selectedMessageCategoryName 211462 "Answer the name of the selected message category or nil." 211463 messageListIndex = 0 ifTrue: [^ nil]. 211464 ^ self selectedClassOrMetaClass organization categoryOfElement: self selectedMessageName! ! 211465 211466 211467!MessageSet methodsFor: 'contents' stamp: 'sd 11/20/2005 21:27'! 211468contents 211469 "Answer the contents of the receiver" 211470 211471 ^ contents == nil 211472 ifTrue: [currentCompiledMethod := nil. ''] 211473 ifFalse: [messageListIndex = 0 211474 ifTrue: [currentCompiledMethod := nil. contents] 211475 ifFalse: [self showingByteCodes 211476 ifTrue: [self selectedBytecodes] 211477 ifFalse: [self selectedMessage]]]! ! 211478 211479!MessageSet methodsFor: 'contents' stamp: 'marcus.denker 8/15/2008 17:18'! 211480selectedMessage 211481 "Answer the source method for the currently selected message." 211482 211483 | source | 211484 self setClassAndSelectorIn: [:class :selector | 211485 class ifNil: [^ 'Class vanished']. 211486 selector first isUppercase ifTrue: 211487 [selector == #Comment ifTrue: 211488 [currentCompiledMethod := class organization commentRemoteStr. 211489 ^ class comment]. 211490 selector == #Definition ifTrue: 211491 [^ class definition]. 211492 selector == #Hierarchy ifTrue: [^ class printHierarchy]]. 211493 source := class sourceMethodAt: selector ifAbsent: 211494 [currentCompiledMethod := nil. 211495 ^ 'Missing']. 211496 211497 self showingDecompile ifTrue: [^ self decompiledSourceIntoContents]. 211498 211499 currentCompiledMethod := class compiledMethodAt: selector ifAbsent: [nil]. 211500 self showingDocumentation ifTrue: [^ self commentContents]. 211501 211502 source := self sourceStringPrettifiedAndDiffed. 211503 ^ source asText makeSelectorBoldIn: class]! ! 211504 211505!MessageSet methodsFor: 'contents' stamp: 'sd 11/20/2005 21:27'! 211506setContentsToForceRefetch 211507 "Set the receiver's contents such that on the next update the contents will be formulated afresh. This is a critical and obscure difference between Browsers on the one hand and MessageSets on the other, and has over the years been the source of much confusion and much difficulty. By centralizing the different handling here, we don't need so many idiosyncratic overrides in MessageSet any more" 211508 211509 contents := ''! ! 211510 211511 211512!MessageSet methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:27'! 211513dragPassengerFor: item inMorph: dragSource 211514 | transferType | 211515 transferType := self dragTransferTypeForMorph: dragSource. 211516 transferType == #messageList 211517 ifTrue: [^self selectedClassOrMetaClass->(item contents findTokens: ' ') second asSymbol]. 211518 transferType == #classList 211519 ifTrue: [^self selectedClass]. 211520 ^nil! ! 211521 211522 211523!MessageSet methodsFor: 'filtering' stamp: 'sd 11/20/2005 21:27'! 211524filterFrom: aBlock 211525 "Filter the receiver's list down to only those items that satisfy aBlock, which takes a class an a selector as its arguments." 211526 211527 | newList | 211528 newList := messageList select: 211529 [:anElement | 211530 self class parse: anElement toClassAndSelector: [ :cls :sel | 211531 (self class isPseudoSelector: sel) not and: [ aBlock value: cls value: sel ]]]. 211532 self setFilteredList: newList! ! 211533 211534!MessageSet methodsFor: 'filtering' stamp: 'stephane.ducasse 9/20/2008 21:52'! 211535filterMessageList 211536 "Allow the user to refine the list of messages." 211537 211538 | aMenu evt | 211539 messageList size <= 1 ifTrue: [^ self inform: 'this is not a propitious filtering situation']. 211540 211541 "would like to get the evt coming in but thwarted by the setInvokingView: circumlocution" 211542 evt := self currentWorld activeHand lastEvent. 211543 aMenu := MenuMorph new defaultTarget: self. 211544 aMenu addTitle: 'Filter by only showing...'. 211545 aMenu addStayUpItem. 211546 211547 aMenu addList: #( 211548 ('unsent messages' filterToUnsentMessages 'filter to show only messages that have no senders') 211549 - 211550 ('messages that send...' filterToSendersOf 'filter to show only messages that send a selector I specify') 211551 ('messages that do not send...' filterToNotSendersOf 'filter to show only messages that do not send a selector I specify') 211552 - 211553 ('messages whose selector is...' filterToImplementorsOf 'filter to show only messages with a given selector I specify') 211554 ('messages whose selector is NOT...' filterToNotImplementorsOf 'filter to show only messages whose selector is NOT a seletor I specify') 211555 - 211556 ('messages in current change set' filterToCurrentChangeSet 'filter to show only messages that are in the current change set') 211557 ('messages not in current change set' filterToNotCurrentChangeSet 'filter to show only messages that are not in the current change set') 211558 - 211559 ('messages in any change set' filterToAnyChangeSet 'filter to show only messages that occur in at least one change set') 211560 ('messages not in any change set' filterToNotAnyChangeSet 'filter to show only messages that do not occur in any change set in the system') 211561 - 211562 ('messages authored by me' filterToCurrentAuthor 'filter to show only messages whose authoring stamp has my initials') 211563 ('messages not authored by me' filterToNotCurrentAuthor 'filter to show only messages whose authoring stamp does not have my initials') 211564 - 211565 ('messages logged in .changes file' filterToMessagesInChangesFile 'filter to show only messages whose latest source code is logged in the .changes file') 211566 ('messages only in .sources file' filterToMessagesInSourcesFile 'filter to show only messages whose latest source code is logged in the .sources file') 211567 - 211568 ('messages with prior versions' filterToMessagesWithPriorVersions 'filter to show only messages that have at least one prior version') 211569 ('messages without prior versions' filterToMessagesWithoutPriorVersions 'filter to show only messages that have no prior versions') 211570 - 211571 ('uncommented messages' filterToUncommentedMethods 'filter to show only messages that do not have comments at the beginning') 211572 ('commented messages' filterToCommentedMethods 'fileter to show only messages that have comments at the beginning') 211573 - 211574 ('messages that...' filterToMessagesThat 'let me type in a block taking a class and a selector, which will specify yea or nay concerning which elements should remain in the list') 211575 ). 211576 211577 aMenu popUpEvent: evt hand lastEvent in: evt hand world.! ! 211578 211579!MessageSet methodsFor: 'filtering' stamp: 'sw 6/6/2001 12:55'! 211580filterToAnyChangeSet 211581 "Filter down only to messages present in ANY change set" 211582 211583 self filterFrom: 211584 [:aClass :aSelector | 211585 ChangeSorter doesAnyChangeSetHaveClass: aClass andSelector: aSelector] 211586! ! 211587 211588!MessageSet methodsFor: 'filtering' stamp: 'sw 8/10/2001 14:45'! 211589filterToCommentedMethods 211590 "Filter the receiver's list down to only those items which have comments" 211591 211592 self filterFrom: 211593 [:aClass :aSelector | 211594 (aClass selectors includes: aSelector) and: 211595 [(aClass firstPrecodeCommentFor: aSelector) isEmptyOrNil not]]! ! 211596 211597!MessageSet methodsFor: 'filtering' stamp: 'MiguelCoba 7/25/2009 02:18'! 211598filterToCurrentAuthor 211599 "Filter down only to messages with my full name as most recent author" 211600 211601 | myFullName aMethod aTimeStamp | 211602 (myFullName := Author fullNamePerSe) ifNil: [^ self inform: 'No author full name set in this image']. 211603 self filterFrom: 211604 [:aClass :aSelector | 211605 (aClass notNil and: [aSelector notNil]) and: 211606 [aMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil]. 211607 aMethod notNil and: 211608 [(aTimeStamp := Utilities timeStampForMethod: aMethod) notNil and: 211609 [aTimeStamp beginsWith: myFullName]]]]! ! 211610 211611!MessageSet methodsFor: 'filtering' stamp: 'sd 5/23/2003 14:38'! 211612filterToCurrentChangeSet 211613 "Filter the receiver's list down to only those items in the current change set" 211614 211615 self filterFrom: 211616 [:aClass :aSelector | 211617 (aClass notNil and: [aSelector notNil]) and: 211618 [(ChangeSet current atSelector: aSelector class: aClass) ~~ #none]]! ! 211619 211620!MessageSet methodsFor: 'filtering' stamp: 'rbb 3/1/2005 11:00'! 211621filterToImplementorsOf 211622 "Filter the receiver's list down to only those items with a given selector" 211623 211624 | aFragment inputWithBlanksTrimmed | 211625 211626 aFragment := UIManager default request: 'type selector:' initialAnswer: ''. 211627 aFragment isEmptyOrNil ifTrue: [^ self]. 211628 inputWithBlanksTrimmed := aFragment withBlanksTrimmed. 211629 Symbol hasInterned: inputWithBlanksTrimmed ifTrue: 211630 [:aSymbol | 211631 self filterFrom: 211632 [:aClass :aSelector | 211633 aSelector == aSymbol]]! ! 211634 211635!MessageSet methodsFor: 'filtering' stamp: 'sd 11/20/2005 21:27'! 211636filterToMessagesInChangesFile 211637 "Filter down only to messages whose source code risides in the Changes file. This allows one to ignore long-standing methods that live in the .sources file." 211638 211639 | cm | 211640 self filterFrom: 211641 [:aClass :aSelector | 211642 aClass notNil and: [aSelector notNil and: 211643 [(self class isPseudoSelector: aSelector) not and: 211644 [(cm := aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil and: 211645 [cm fileIndex ~~ 1]]]]]! ! 211646 211647!MessageSet methodsFor: 'filtering' stamp: 'sd 11/20/2005 21:27'! 211648filterToMessagesInSourcesFile 211649 "Filter down only to messages whose source code resides in the .sources file." 211650 211651 | cm | 211652 self filterFrom: [:aClass :aSelector | 211653 (aClass notNil and: [aSelector notNil]) and: 211654 [(self class isPseudoSelector: aSelector) not and: 211655 [(cm := aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil and: 211656 [cm fileIndex == 1]]]]! ! 211657 211658!MessageSet methodsFor: 'filtering' stamp: 'rbb 3/1/2005 11:00'! 211659filterToMessagesThat 211660 "Allow the user to type in a block which will be" 211661 211662 | reply | 211663 reply := UIManager default 211664 multiLineRequest: 'Type your block here' 211665 centerAt: Sensor cursorPoint 211666 initialAnswer: '[:aClass :aSelector | 211667 211668 ]' 211669 answerHeight: 200. 211670 reply isEmptyOrNil ifTrue: [^ self]. 211671 self filterFrom: (Compiler evaluate: reply) 211672! ! 211673 211674!MessageSet methodsFor: 'filtering' stamp: 'sw 8/12/2001 22:25'! 211675filterToMessagesWithPriorVersions 211676 "Filter down only to messages which have at least one prior version" 211677 211678 self filterFrom: 211679 [:aClass :aSelector | 211680 (aClass notNil and: [aSelector notNil]) and: 211681 [(self class isPseudoSelector: aSelector) not and: 211682 [(VersionsBrowser versionCountForSelector: aSelector class: aClass) > 1]]]! ! 211683 211684!MessageSet methodsFor: 'filtering' stamp: 'sw 6/6/2001 15:12'! 211685filterToMessagesWithoutPriorVersions 211686 "Filter down only to messages which have no prior version stored" 211687 211688 self filterFrom: 211689 [:aClass :aSelector | 211690 (aClass notNil and: [aSelector notNil]) and: 211691 [(self class isPseudoSelector: aSelector) not and: 211692 [(VersionsBrowser versionCountForSelector: aSelector class: aClass) <= 1]]]! ! 211693 211694!MessageSet methodsFor: 'filtering' stamp: 'sw 6/6/2001 13:07'! 211695filterToNotAnyChangeSet 211696 "Filter down only to messages present in NO change set" 211697 211698 self filterFrom: 211699 [:aClass :aSelector | 211700 (ChangeSorter doesAnyChangeSetHaveClass: aClass andSelector: aSelector) not] 211701! ! 211702 211703!MessageSet methodsFor: 'filtering' stamp: 'MiguelCoba 7/25/2009 02:18'! 211704filterToNotCurrentAuthor 211705 "Filter down only to messages not stamped with my initials" 211706 211707 | myFullName aMethod aTimeStamp | 211708 (myFullName := Author fullNamePerSe) ifNil: [^ self inform: 'No author full name set in this image']. 211709 self filterFrom: 211710 [:aClass :aSelector | 211711 (aClass notNil and: [aSelector notNil]) and: 211712 [aMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil]. 211713 aMethod notNil and: 211714 [(aTimeStamp := Utilities timeStampForMethod: aMethod) isNil or: 211715 [(aTimeStamp beginsWith: myFullName) not]]]]! ! 211716 211717!MessageSet methodsFor: 'filtering' stamp: 'sd 5/23/2003 14:38'! 211718filterToNotCurrentChangeSet 211719 "Filter the receiver's list down to only those items not in the current change set" 211720 211721 self filterFrom: 211722 [:aClass :aSelector | 211723 (aClass notNil and: [aSelector notNil]) and: 211724 [(ChangeSet current atSelector: aSelector class: aClass) == #none]]! ! 211725 211726!MessageSet methodsFor: 'filtering' stamp: 'rbb 3/1/2005 11:00'! 211727filterToNotImplementorsOf 211728 "Filter the receiver's list down to only those items whose selector is NOT one solicited from the user." 211729 211730 | aFragment inputWithBlanksTrimmed | 211731 211732 aFragment := UIManager default request: 'type selector: ' initialAnswer: ''. 211733 aFragment isEmptyOrNil ifTrue: [^ self]. 211734 inputWithBlanksTrimmed := aFragment withBlanksTrimmed. 211735 Symbol hasInterned: inputWithBlanksTrimmed ifTrue: 211736 [:aSymbol | 211737 self filterFrom: 211738 [:aClass :aSelector | 211739 aSelector ~~ aSymbol]]! ! 211740 211741!MessageSet methodsFor: 'filtering' stamp: 'G.C 10/22/2008 09:59'! 211742filterToNotSendersOf 211743 "Filter the receiver's list down to only those items which do not send a given selector" 211744 | aFragment inputWithBlanksTrimmed aMethod | 211745 aFragment := UIManager default 211746 request: 'type selector:' 211747 initialAnswer: ''. 211748 aFragment isEmptyOrNil ifTrue: [ ^ self ]. 211749 inputWithBlanksTrimmed := aFragment withBlanksTrimmed. 211750 Symbol 211751 hasInterned: inputWithBlanksTrimmed 211752 ifTrue: 211753 [ :aSymbol | 211754 self filterFrom: 211755 [ :aClass :aSelector | 211756 (aMethod := aClass compiledMethodAt: aSelector) isNil or: [ (aMethod refersToLiteral: aSymbol) not ] ] ]! ! 211757 211758!MessageSet methodsFor: 'filtering' stamp: 'G.C 10/22/2008 09:59'! 211759filterToSendersOf 211760 "Filter the receiver's list down to only those items which send a given selector" 211761 | aFragment inputWithBlanksTrimmed aMethod | 211762 aFragment := UIManager default 211763 request: 'type selector:' 211764 initialAnswer: ''. 211765 aFragment isEmptyOrNil ifTrue: [ ^ self ]. 211766 inputWithBlanksTrimmed := aFragment withBlanksTrimmed. 211767 Symbol 211768 hasInterned: inputWithBlanksTrimmed 211769 ifTrue: 211770 [ :aSymbol | 211771 self filterFrom: 211772 [ :aClass :aSelector | 211773 (aMethod := aClass compiledMethodAt: aSelector) notNil and: [ aMethod refersToLiteral: aSymbol ] ] ]! ! 211774 211775!MessageSet methodsFor: 'filtering' stamp: 'sw 8/10/2001 14:43'! 211776filterToUncommentedMethods 211777 "Filter the receiver's list down to only those items which lack comments" 211778 211779 self filterFrom: 211780 [:aClass :aSelector | 211781 (aClass selectors includes: aSelector) and: 211782 [(aClass firstPrecodeCommentFor: aSelector) isEmptyOrNil]]! ! 211783 211784!MessageSet methodsFor: 'filtering' stamp: 'sd 4/29/2003 12:24'! 211785filterToUnsentMessages 211786 "Filter the receiver's list down to only those items which have no 211787 senders" 211788 self 211789 filterFrom: [:aClass :aSelector | (self systemNavigation allCallsOn: aSelector) isEmpty]! ! 211790 211791 211792!MessageSet methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:10'! 211793canShowMultipleMessageCategories 211794 "Answer whether the receiver is capable of showing multiple message categories" 211795 211796 ^ false! ! 211797 211798 211799!MessageSet methodsFor: 'message functions' stamp: 'sd 11/20/2005 21:27'! 211800deleteFromMessageList: aMessage 211801 "Delete the given message from the receiver's message list" 211802 211803 messageList := messageList copyWithout: aMessage! ! 211804 211805!MessageSet methodsFor: 'message functions' stamp: 'sw 2/24/1999 18:31'! 211806methodCategoryChanged 211807 self changed: #annotation! ! 211808 211809!MessageSet methodsFor: 'message functions' stamp: 'sw 12/1/2000 11:54'! 211810reformulateList 211811 "The receiver's messageList has been changed; rebuild it" 211812 211813 super reformulateList. 211814 self initializeMessageList: messageList. 211815 self changed: #messageList. 211816 self changed: #messageListIndex. 211817 self contentsChanged 211818! ! 211819 211820!MessageSet methodsFor: 'message functions' stamp: 'sd 11/20/2005 21:27'! 211821removeMessage 211822 "Remove the selected message from the system. 1/15/96 sw" 211823 | messageName confirmation | 211824 messageListIndex = 0 211825 ifTrue: [^ self]. 211826 self okToChange 211827 ifFalse: [^ self]. 211828 messageName := self selectedMessageName. 211829 confirmation := self systemNavigation confirmRemovalOf: messageName on: self selectedClassOrMetaClass. 211830 confirmation == 3 211831 ifTrue: [^ self]. 211832 self selectedClassOrMetaClass removeSelector: messageName. 211833 self deleteFromMessageList: self selection. 211834 self reformulateList. 211835 confirmation == 2 211836 ifTrue: [self systemNavigation browseAllCallsOn: messageName]! ! 211837 211838!MessageSet methodsFor: 'message functions' stamp: 'sw 1/12/2001 00:19'! 211839removeMessageFromBrowser 211840 "Remove the selected message from the browser." 211841 211842 messageListIndex = 0 ifTrue: [^ self]. 211843 self deleteFromMessageList: self selection. 211844 self reformulateList. 211845 self adjustWindowTitleAfterFiltering 211846! ! 211847 211848 211849!MessageSet methodsFor: 'message list' stamp: 'stephane.ducasse 9/25/2008 16:27'! 211850addExtraShiftedItemsTo: aMenu 211851 "The shifted selector-list menu is being built. Add items specific to MessageSet" 211852 211853 self growable ifTrue: 211854 [aMenu addList: #( 211855 - 211856 ('remove from this browser' removeMessageFromBrowser) 211857 ('filter message list...' filterMessageList) 211858 )]. 211859 aMenu add: 'sort by date' action: #sortByDate! ! 211860 211861!MessageSet methodsFor: 'message list' stamp: 'tk 5/1/2001 18:14'! 211862addItem: classAndMethod 211863 "Append a classAndMethod string to the list. Select the new item." 211864 211865 "Do some checks on the input?" 211866 self okToChange ifFalse: [^ self]. 211867 messageList add: classAndMethod. 211868 self changed: #messageList. 211869 self messageListIndex: messageList size.! ! 211870 211871!MessageSet methodsFor: 'message list' stamp: 'sw 1/28/2001 20:56'! 211872growable 211873 "Answer whether the receiver is capable of growing/shrinking dynamically" 211874 211875 ^ growable ~~ false! ! 211876 211877!MessageSet methodsFor: 'message list' stamp: 'sd 11/20/2005 21:27'! 211878growable: aBoolean 211879 "Give or take away the growable trait; when a message set is growable, methods submitted within it will be added to its message list" 211880 211881 growable := aBoolean! ! 211882 211883!MessageSet methodsFor: 'message list'! 211884messageList 211885 "Answer the current list of messages." 211886 211887 ^messageList! ! 211888 211889!MessageSet methodsFor: 'message list' stamp: 'sd 11/20/2005 21:27'! 211890messageListIndex: anInteger 211891 "Set the index of the selected item to be anInteger." 211892 211893 messageListIndex := anInteger. 211894 contents := 211895 messageListIndex ~= 0 211896 ifTrue: [self selectedMessage] 211897 ifFalse: ['']. 211898 self changed: #messageListIndex. "update my selection" 211899 self editSelection: #editMessage. 211900 self contentsChanged. 211901 (messageListIndex ~= 0 and: [autoSelectString notNil]) 211902 ifTrue: [self changed: #autoSelect]. 211903 self decorateButtons 211904! ! 211905 211906!MessageSet methodsFor: 'message list' stamp: 'sma 3/3/2000 11:17'! 211907selectedMessageName 211908 "Answer the name of the currently selected message." 211909 "wod 6/16/1998: answer nil if none are selected." 211910 211911 messageListIndex = 0 ifTrue: [^ nil]. 211912 ^ self setClassAndSelectorIn: [:class :selector | ^ selector]! ! 211913 211914!MessageSet methodsFor: 'message list' stamp: 'sd 11/20/2005 21:27'! 211915sortByDate 211916 "Sort the message-list by date of time-stamp" 211917 211918 | assocs aCompiledMethod aDate inOrder | 211919 assocs := messageList collect: 211920 [:aRef | 211921 aDate := aRef methodSymbol == #Comment 211922 ifTrue: 211923 [aRef actualClass organization dateCommentLastSubmitted] 211924 ifFalse: 211925 [aCompiledMethod := aRef actualClass compiledMethodAt: aRef methodSymbol ifAbsent: [nil]. 211926 aCompiledMethod ifNotNil: [aCompiledMethod dateMethodLastSubmitted]]. 211927 aRef -> (aDate ifNil: [Date fromString: '01/01/1996'])]. "The dawn of Squeak history" 211928 inOrder := assocs asSortedCollection: 211929 [:a :b | a value < b value]. 211930 211931 messageList := inOrder asArray collect: [:assoc | assoc key]. 211932 self changed: #messageList! ! 211933 211934 211935!MessageSet methodsFor: 'metaclass' stamp: 'nk 4/29/2004 12:20'! 211936classCommentIndicated 211937 "Answer true iff we're viewing the class comment." 211938 211939 ^ editSelection == #editComment or: [ self selectedMessageName == #Comment ]! ! 211940 211941 211942!MessageSet methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:53'! 211943buildWith: builder 211944 | windowSpec max listSpec panelSpec textSpec | 211945 windowSpec := builder pluggableWindowSpec new. 211946 windowSpec model: self. 211947 windowSpec label: 'System Browser'. 211948 windowSpec children: OrderedCollection new. 211949 211950 self wantsOptionalButtons ifTrue:[max := 0.3] ifFalse:[max := 0.2]. 211951 listSpec := builder pluggableListSpec new. 211952 listSpec 211953 model: self; 211954 list: #messageList; 211955 getIndex: #messageListIndex; 211956 setIndex: #messageListIndex:; 211957 menu: #messageListMenu:shifted:; 211958 keyPress: #messageListKey:from:; 211959 frame: (0@0 corner: 1@0.2). 211960 windowSpec children add: listSpec. 211961 211962 self wantsOptionalButtons ifTrue:[ 211963 panelSpec := self buildOptionalButtonsWith: builder. 211964 panelSpec frame: (0@0.2 corner: 1@max). 211965 windowSpec children add: panelSpec. 211966 ]. 211967 211968 textSpec := builder pluggableTextSpec new. 211969 textSpec 211970 model: self; 211971 getText: #contents; 211972 setText: #contents:notifying:; 211973 selection: #contentsSelection; 211974 menu: #codePaneMenu:shifted:; 211975 frame: (0@max corner: 1@1). 211976 windowSpec children add: textSpec. 211977 211978 ^builder build: windowSpec! ! 211979 211980 211981!MessageSet methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! 211982adjustWindowTitleAfterFiltering 211983 "Set the title of the receiver's window, if any, to reflect the just-completed filtering" 211984 211985 | aWindow existingLabel newLabel | 211986 211987 (aWindow := self containingWindow) ifNil: [^ self]. 211988 (existingLabel := aWindow label) isEmptyOrNil ifTrue: [^ self]. 211989 (((existingLabel size < 3) or: [existingLabel last ~~ $]]) or: [(existingLabel at: (existingLabel size - 1)) isDigit not]) ifTrue: [^ self]. 211990 existingLabel size to: 1 by: -1 do: 211991 [:anIndex | ((existingLabel at: anIndex) == $[) ifTrue: 211992 [newLabel := (existingLabel copyFrom: 1 to: anIndex), 211993 'Filtered: ', 211994 messageList size printString, 211995 ']'. 211996 ^ aWindow setLabel: newLabel]] 211997 211998 211999! ! 212000 212001!MessageSet methodsFor: 'private'! 212002autoSelectString 212003 "Return the string to be highlighted when making new selections" 212004 ^ autoSelectString! ! 212005 212006!MessageSet methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! 212007autoSelectString: aString 212008 "Set the string to be highlighted when making new selections" 212009 autoSelectString := aString! ! 212010 212011!MessageSet methodsFor: 'private' stamp: 'alain.plantec 5/15/2009 09:38'! 212012buildMorphicMessageList 212013 "Build my message-list object in morphic" 212014 212015 | aListMorph | 212016 aListMorph := PluggableListMorph new. 212017 aListMorph 212018 on: self list: #messageList 212019 selected: #messageListIndex changeSelected: #messageListIndex: 212020 menu: #messageListMenu:shifted: 212021 keystroke: #messageListKey:from:. 212022 aListMorph enableDragNDrop: true. 212023 aListMorph menuTitleSelector: #messageListSelectorTitle. 212024 ^ aListMorph 212025 212026! ! 212027 212028!MessageSet methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! 212029contents: aString notifying: aController 212030 "Compile the code in aString. Notify aController of any syntax errors. 212031 Answer false if the compilation fails. Otherwise, if the compilation 212032 created a new method, deselect the current selection. Then answer true." 212033 212034 | category selector class oldSelector | 212035 self okayToAccept ifFalse: [^ false]. 212036 self setClassAndSelectorIn: [:c :os | class := c. oldSelector := os]. 212037 class ifNil: [^ false]. 212038 (oldSelector ~~ nil and: [oldSelector first isUppercase]) ifTrue: 212039 [oldSelector = #Comment ifTrue: 212040 [class comment: aString stamp: Utilities changeStamp. 212041 self changed: #annotation. 212042 self clearUserEditFlag. 212043 ^ false]. 212044 oldSelector = #Definition ifTrue: 212045 ["self defineClass: aString notifying: aController." 212046 class subclassDefinerClass 212047 evaluate: aString 212048 notifying: aController 212049 logged: true. 212050 self clearUserEditFlag. 212051 ^ false]. 212052 oldSelector = #Hierarchy ifTrue: 212053 [self inform: 'To change the hierarchy, edit the class definitions'. 212054 ^ false]]. 212055 "Normal method accept" 212056 category := class organization categoryOfElement: oldSelector. 212057 selector := class compile: aString 212058 classified: category 212059 notifying: aController. 212060 selector == nil ifTrue: [^ false]. 212061 self noteAcceptanceOfCodeFor: selector. 212062 selector == oldSelector ifFalse: 212063 [self reformulateListNoting: selector]. 212064 contents := aString copy. 212065 self changed: #annotation. 212066 ^ true! ! 212067 212068!MessageSet methodsFor: 'private' stamp: 'al 9/21/2008 20:08'! 212069inMorphicWindowLabeled: labelString 212070 "Answer a morphic window with the given label that can display the receiver" 212071 212072 | window listFraction | 212073 window := (SystemWindow labelled: labelString) model: self. 212074 listFraction := 0.4. 212075 window addMorph: self buildMorphicMessageList frame: (0@0 extent: 1@listFraction). 212076 self 212077 addLowerPanesTo: window 212078 at: (0@listFraction corner: 1@1) 212079 with: nil. 212080 212081 window setUpdatablePanesFrom: #(messageList). 212082 ^ window! ! 212083 212084!MessageSet methodsFor: 'private' stamp: 'al 9/21/2008 20:11'! 212085initialExtent 212086 ^ 500@500! ! 212087 212088!MessageSet methodsFor: 'private' stamp: 'stephane.ducasse 9/25/2008 16:40'! 212089initializeMessageList: anArray 212090 "Initialize my messageList from the given list of MethodReference or string objects. NB: special handling for uniclasses." 212091 212092 | s | 212093 messageList := OrderedCollection new. 212094 anArray do: [ :each | 212095 MessageSet 212096 parse: each 212097 toClassAndSelector: [ :class :sel | 212098 class ifNotNil: 212099 [s := self methodDisplayStringForClass: class selector: sel. 212100 messageList add: ( 212101 MethodReference new 212102 setClass: class 212103 methodSymbol: sel 212104 stringVersion: s)]]]. 212105 messageListIndex := messageList isEmpty ifTrue: [0] ifFalse: [1]. 212106 contents := ''! ! 212107 212108!MessageSet methodsFor: 'private' stamp: 'stephane.ducasse 7/11/2009 09:04'! 212109methodDisplayStringForClass: class selector: sel 212110 212111 ^ String streamContents: [ :s | 212112 s nextPutAll: class name ; 212113 nextPutAll: ' ' ; nextPutAll: sel ; 212114 nextPutAll: ' {' ; 212115 nextPutAll: ((class organization categoryOfElement: sel) ifNil: ['']) ; 212116 nextPutAll: '} '] 212117 212118 " 212119 nextPut: $[ ; 212120 nextPutAll: (PackageOrganizer default mostSpecificPackageOfClass: class ifNone: [PackageInfo named: '**unpackaged**']) packageName ; 212121 nextPut: $]]." 212122! ! 212123 212124!MessageSet methodsFor: 'private' stamp: 'yo 7/30/2004 16:36'! 212125openAsMorphNamed: labelString inWorld: aWorld 212126 "Open the receiver in a morphic window in the given world" 212127 212128 (self inMorphicWindowLabeled: labelString) openInWorld: aWorld. 212129 self messageListIndex: 1. 212130! ! 212131 212132!MessageSet methodsFor: 'private' stamp: 'sw 12/28/2000 14:28'! 212133selection 212134 "Answer the item in the list that is currently selected, or nil if no selection is present" 212135 212136 ^ messageList at: messageListIndex ifAbsent: [nil]! ! 212137 212138!MessageSet methodsFor: 'private' stamp: 'marcus.denker 8/24/2008 22:04'! 212139setClassAndSelectorIn: csBlock 212140 | sel | 212141 "Decode strings of the form <className> [class] <selectorName>." 212142 212143 sel := self selection. 212144 ^(sel isKindOf: MethodReference) ifTrue: [ 212145 sel setClassAndSelectorIn: csBlock 212146 ] ifFalse: [ 212147 MessageSet parse: sel toClassAndSelector: csBlock 212148 ]! ! 212149 212150!MessageSet methodsFor: 'private' stamp: 'sw 1/11/2001 09:18'! 212151setFilteredList: newList 212152 "Establish newList as the new list if appropriate, and adjust the window title accordingly; if the new list is of the same size as the old, warn and do nothing" 212153 212154 newList size == 0 212155 ifTrue: 212156 [^ self inform: 'Nothing would be left in the list if you did that']. 212157 newList size == messageList size 212158 ifTrue: 212159 [^ self inform: 'That leaves the list unchanged']. 212160 self initializeMessageList: newList. 212161 self adjustWindowTitleAfterFiltering! ! 212162 212163"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 212164 212165MessageSet class 212166 instanceVariableNames: ''! 212167 212168!MessageSet class methodsFor: 'instance creation'! 212169messageList: anArray 212170 "Answer an instance of me with message list anArray." 212171 212172 ^self new initializeMessageList: anArray! ! 212173 212174!MessageSet class methodsFor: 'instance creation' stamp: 'alain.plantec 5/30/2008 13:44'! 212175open: aMessageSet name: aString 212176 "Create a standard system view for the messageSet, aMessageSet, whose label is aString." 212177 ^ self openAsMorph: aMessageSet name: aString! ! 212178 212179!MessageSet class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:41'! 212180openAsMorph: aMessageSet name: labelString 212181 "Create a SystemWindow aMessageSet, with the label labelString, in a Morphic project" 212182 ^ self openAsMorph: aMessageSet name: labelString inWorld: self currentWorld! ! 212183 212184!MessageSet class methodsFor: 'instance creation' stamp: 'RAA 1/10/2001 11:07'! 212185openAsMorph: aMessageSet name: labelString inWorld: aWorld 212186 212187 ^aMessageSet openAsMorphNamed: labelString inWorld: aWorld 212188! ! 212189 212190!MessageSet class methodsFor: 'instance creation'! 212191openMessageList: anArray name: aString 212192 "Create a standard system view for the message set on the list, anArray. 212193 The label of the view is aString." 212194 212195 self open: (self messageList: anArray) name: aString! ! 212196 212197!MessageSet class methodsFor: 'instance creation' stamp: 'alain.plantec 5/30/2008 13:45'! 212198openMessageList: messageList name: labelString autoSelect: autoSelectString 212199 "Open a system view for a MessageSet on messageList. 212200 1/24/96 sw: the there-are-no msg now supplied by my sender" 212201 212202 | messageSet | 212203 messageSet := self messageList: messageList. 212204 messageSet autoSelectString: autoSelectString. 212205 ^ self openAsMorph: messageSet name: labelString! ! 212206 212207 212208!MessageSet class methodsFor: 'utilities' stamp: 'RAA 5/29/2001 10:19'! 212209extantMethodsIn: aListOfMethodRefs 212210 "Answer the subset of the incoming list consisting only of those message markers that refer to methods actually in the current image" 212211 212212 212213 self flag: #mref. "may be removed in second round" 212214 212215 212216 ^ aListOfMethodRefs select: [:aToken | 212217 self 212218 parse: aToken 212219 toClassAndSelector: [ :aClass :aSelector | 212220 aClass notNil and: [aClass includesSelector: aSelector] 212221 ] 212222 ]! ! 212223 212224!MessageSet class methodsFor: 'utilities' stamp: 'sw 6/6/2001 15:09'! 212225isPseudoSelector: aSelector 212226 "Answer whether the given selector is a special marker" 212227 212228 ^ #(Comment Definition Hierarchy) includes: aSelector! ! 212229 212230!MessageSet class methodsFor: 'utilities' stamp: 'md 3/3/2006 09:25'! 212231parse: methodRef toClassAndSelector: csBlock 212232 "Decode strings of the form <className> [class] <selectorName>." 212233 212234 | tuple cl | 212235 212236 212237 self flag: #mref. "compatibility with pre-MethodReference lists" 212238 212239 methodRef ifNil: [^ csBlock value: nil value: nil]. 212240 (methodRef isKindOf: MethodReference) ifTrue: [ 212241 ^methodRef setClassAndSelectorIn: csBlock 212242 ]. 212243 methodRef isEmpty ifTrue: [^ csBlock value: nil value: nil]. 212244 tuple := methodRef asString findTokens: ' .'. 212245 cl := Smalltalk at: tuple first asSymbol ifAbsent: [^ csBlock value: nil value: nil]. 212246 (tuple size = 2 or: [tuple size > 2 and: [(tuple at: 2) ~= 'class']]) 212247 ifTrue: [^ csBlock value: cl value: (tuple at: 2) asSymbol] 212248 ifFalse: [^ csBlock value: cl class value: (tuple at: 3) asSymbol]! ! 212249 212250 212251!MessageSet class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:37'! 212252windowColorSpecification 212253 "Answer a WindowColorSpec object that declares my preference" 212254 212255 ^ WindowColorSpec classSymbol: self name wording: 'Message List' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A list of messages (e.g. senders, implementors)'! ! 212256Magnitude subclass: #MessageTally 212257 instanceVariableNames: 'class method process tally receivers senders time gcStats maxClassNameSize maxClassPlusSelectorSize maxTabs reportOtherProcesses' 212258 classVariableNames: 'DefaultPollPeriod Timer' 212259 poolDictionaries: '' 212260 category: 'Tools-Debugger'! 212261!MessageTally commentStamp: 'StephaneDucasse 9/27/2009 10:42' prior: 0! 212262My instances observe and report the amount of time spent in methods. 212263 212264NOTE: a higher-level user interface (combining the MessageTally result tree with a method browser) is available from TimeProfileBrowser. Note that TimeProfileBrowser was not fancy with the different setting possibilities. 212265 212266 TimeProfileBrowser spyOn: [20 timesRepeat: 212267 [Transcript show: 100 factorial printString]] 212268 212269 212270Strategies 212271----------- 212272MessageTally provides two different strategies available for profiling: 212273 212274* spyOn: and friends use a high-priority Process to interrupt the block or process being spied on at periodic intervals. The interrupted call stack is then examined for caller information. See below for an example showing different settings 212275 212276* tallySends: and friends use the interpreter simulator to run the block, recording every method call. 212277 212278The two give you different results: 212279 212280 * spyOn: gives you a view of where the time is being spent in your program, at least on a rough statistical level (assuming you've run the block for long enough and have a high enough poll rate). If you're trying to optimize your code, start here and optimize the methods where most of the time is being spent first. 212281 212282 * tallySends: gives you accurate counts of how many times methods get called, and by exactly which route. If you're debugging, or trying to figure out if a given method is getting called too many times, this is your tool. 212283 212284Q: How do you interpret MessageTally>>tallySends 212285A: The methods #tallySends and #spyOn: measure two very different quantities, but broken down in the same who-called-who format. #spyOn: is approximate, but more indicative of real time spent, whereas #tallySends is exact and a precise record of how many times each method got executed. 212286 212287Examples 212288---------- 212289 212290Here you can see all the processes computation time 212291 212292 [1000 timesRepeat: [3.14159 printString. Processor yield]] fork. 212293 [1000 timesRepeat: [30 factorial. Processor yield]] fork. 212294 [1000 timesRepeat: [30 factorial. Processor yield]] fork. 212295 MessageTally spyAllOn: [ (Delay forMilliseconds: 100) wait] 212296 212297 212298Settings 212299--------- 212300You can change the printing format (that is, the whitespace and string compression) by using these instance methods: 212301 maxClassNameSize: 212302 maxClassPlusSelectorSize: 212303 maxTabs: 212304 212305You can change the default polling period (initially set to 1) by calling 212306 MessageTally defaultPollPeriod: numberOfMilliseconds 212307 212308 212309To understand the difference 212310---------------------------------- 212311Here we see all the processes 212312 [1000 timesRepeat: [ 212313 100 timesRepeat: [120 factorial]. 212314 (Delay forMilliseconds: 10) wait 212315 ]] forkAt: 45 named: '45'. 212316 MessageTally spyAllOn: [10000 timesRepeat: [1.23 printString]] 212317 212318 212319Here we only see the execution of the expression [10000 timesRepeat: [1.23 printString] 212320 [1000 timesRepeat: [ 212321 100 timesRepeat: [120 factorial]. 212322 (Delay forMilliseconds: 10) wait 212323 ]] forkAt: 45 named: '45'. 212324 MessageTally spyOn: [10000 timesRepeat: [1.23 printString]] 212325 212326Here we only check the exact message sends: this is not a pc-sampling approach 212327 [1000 timesRepeat: [ 212328 100 timesRepeat: [120 factorial]. 212329 (Delay forMilliseconds: 10) wait 212330 ]] forkAt: 45 named: '45'. 212331 MessageTally tallySends: [10000 timesRepeat: [1.23 printString]] 212332 212333 212334 212335! 212336 212337 212338!MessageTally methodsFor: 'collecting leaves'! 212339bump: hitCount 212340 tally := tally + hitCount! ! 212341 212342!MessageTally methodsFor: 'collecting leaves'! 212343bump: hitCount fromSender: senderTally 212344 "Add this hitCount to the total, and include a reference to the 212345 sender responsible for the increment" 212346 self bump: hitCount. 212347 senders == nil ifTrue: [senders := OrderedCollection new]. 212348 senderTally == nil 212349 ifFalse: [senders add: (senderTally copyWithTally: hitCount)]! ! 212350 212351!MessageTally methodsFor: 'collecting leaves' stamp: 'jmv 9/24/2009 16:10'! 212352into: leafDict fromSender: senderTally 212353 | leafNode | 212354 leafNode := leafDict at: method 212355 ifAbsent: [leafDict at: method 212356 put: ((MessageTally new class: class method: method) 212357 process: process; 212358 reportOtherProcesses: reportOtherProcesses)]. 212359 leafNode bump: tally fromSender: senderTally! ! 212360 212361!MessageTally methodsFor: 'collecting leaves' stamp: 'jmv 9/24/2009 16:07'! 212362leavesInto: leafDict fromSender: senderTally 212363 212364 | rcvrs | 212365 rcvrs := self sonsOver: 0. 212366 rcvrs size = 0 212367 ifTrue: [ self into: leafDict fromSender: senderTally ] 212368 ifFalse: [ 212369 212370 (reportOtherProcesses not and: [ rcvrs anyOne process isNil ]) ifTrue: [ 212371 ^self]. 212372 212373 rcvrs do: [ :node | 212374 node isPrimitives 212375 ifTrue: [ node leavesInto: leafDict fromSender: senderTally ] 212376 ifFalse: [ node leavesInto: leafDict fromSender: self ]]]! ! 212377 212378 212379!MessageTally methodsFor: 'comparing'! 212380< aMessageTally 212381 "Refer to the comment in Magnitude|<." 212382 212383 ^tally > aMessageTally tally! ! 212384 212385!MessageTally methodsFor: 'comparing' stamp: 'ar 3/3/2009 19:36'! 212386= aMessageTally 212387 212388 self species == aMessageTally species ifFalse: [^ false]. 212389 ^ aMessageTally method == method and:[aMessageTally process == process]! ! 212390 212391!MessageTally methodsFor: 'comparing'! 212392> aMessageTally 212393 "Refer to the comment in Magnitude|>." 212394 212395 ^tally < aMessageTally tally! ! 212396 212397!MessageTally methodsFor: 'comparing' stamp: 'TorstenBergmann 8/19/2009 14:45'! 212398hash 212399 "Hash is reimplemented because = is implemented." 212400 212401 ^method identityHash! ! 212402 212403!MessageTally methodsFor: 'comparing'! 212404isPrimitives 212405 "Detect pseudo node used to carry tally of local hits" 212406 ^ receivers == nil! ! 212407 212408!MessageTally methodsFor: 'comparing' stamp: 'jmv 9/24/2009 16:11'! 212409sonsOver: threshold 212410 212411 | hereTally last sons | 212412 (receivers == nil or: [receivers size = 0]) ifTrue: [^#()]. 212413 hereTally := tally. 212414 sons := receivers select: "subtract subNode tallies for primitive hits here" 212415 [:son | 212416 hereTally := hereTally - son tally. 212417 son tally > threshold]. 212418 hereTally > threshold 212419 ifTrue: [ 212420 last := MessageTally new class: class method: method. 212421 last process: process. 212422 last reportOtherProcesses: reportOtherProcesses. 212423 ^sons copyWith: (last primitives: hereTally)]. 212424 ^sons! ! 212425 212426!MessageTally methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:04'! 212427species 212428 ^MessageTally! ! 212429 212430 212431!MessageTally methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:06'! 212432initialize 212433 super initialize. 212434 maxClassNameSize := self class defaultMaxClassNameSize. 212435 maxClassPlusSelectorSize := self class defaultMaxClassPlusSelectorSize. 212436 maxTabs := self class defaultMaxTabs.! ! 212437 212438 212439!MessageTally methodsFor: 'initialize-release' stamp: 'jmv 9/25/2009 08:48'! 212440close 212441 212442 Timer ifNotNil: [ Timer terminate ]. 212443 Timer := nil. 212444 class := method := tally := receivers := nil! ! 212445 212446!MessageTally methodsFor: 'initialize-release' stamp: 'jmv 9/25/2009 08:49'! 212447spyAllEvery: millisecs on: aBlock 212448 "Create a spy and spy on the given block at the specified rate." 212449 "Spy all the system processes" 212450 212451 | myDelay startTime time0 observedProcess | 212452 (aBlock isMemberOf: BlockClosure) 212453 ifFalse: [self error: 'spy needs a block here']. 212454 self class: aBlock receiver class method: aBlock method. 212455 "set up the probe" 212456 myDelay := Delay forMilliseconds: millisecs. 212457 time0 := Time millisecondClockValue. 212458 gcStats := SmalltalkImage current getVMParameters. 212459 Timer ifNotNil: [ Timer terminate ]. 212460 Timer := [ 212461 [true] whileTrue: [ 212462 startTime := Time millisecondClockValue. 212463 myDelay wait. 212464 observedProcess := Processor preemptedProcess. 212465 self 212466 tally: observedProcess suspendedContext 212467 in: observedProcess 212468 "tally can be > 1 if ran a long primitive" 212469 by: (Time millisecondClockValue - startTime) // millisecs]. 212470 nil] newProcess. 212471 Timer priority: Processor timingPriority-1. 212472 "activate the probe and evaluate the block" 212473 Timer resume. 212474 ^ aBlock ensure: [ 212475 "Collect gc statistics" 212476 SmalltalkImage current getVMParameters keysAndValuesDo: [ :idx :gcVal | 212477 gcStats at: idx put: (gcVal - (gcStats at: idx))]. 212478 "cancel the probe and return the value" 212479 Timer terminate. 212480 Timer := nil. 212481 time := Time millisecondClockValue - time0]! ! 212482 212483!MessageTally methodsFor: 'initialize-release' stamp: 'jmv 9/25/2009 08:49'! 212484spyEvery: millisecs on: aBlock 212485 "Create a spy and spy on the given block at the specified rate." 212486 "Spy only on the active process (in which aBlock is run)" 212487 212488 | myDelay startTime time0 observedProcess | 212489 (aBlock isMemberOf: BlockClosure) 212490 ifFalse: [self error: 'spy needs a block here']. 212491 self class: aBlock receiver class method: aBlock method. 212492 "set up the probe" 212493 observedProcess := Processor activeProcess. 212494 myDelay := Delay forMilliseconds: millisecs. 212495 time0 := Time millisecondClockValue. 212496 gcStats := SmalltalkImage current getVMParameters. 212497 Timer ifNotNil: [ Timer terminate ]. 212498 Timer := [ 212499 [true] whileTrue: [ 212500 startTime := Time millisecondClockValue. 212501 myDelay wait. 212502 self 212503 tally: Processor preemptedProcess suspendedContext 212504 in: (observedProcess == Processor preemptedProcess ifTrue: [observedProcess] ifFalse: [nil]) 212505 "tally can be > 1 if ran a long primitive" 212506 by: (Time millisecondClockValue - startTime) // millisecs]. 212507 nil] newProcess. 212508 Timer priority: Processor timingPriority-1. 212509 "activate the probe and evaluate the block" 212510 Timer resume. 212511 ^ aBlock ensure: [ 212512 "Collect gc statistics" 212513 SmalltalkImage current getVMParameters keysAndValuesDo: [ :idx :gcVal | 212514 gcStats at: idx put: (gcVal - (gcStats at: idx))]. 212515 "cancel the probe and return the value" 212516 Timer terminate. 212517 Timer := nil. 212518 time := Time millisecondClockValue - time0]! ! 212519 212520!MessageTally methodsFor: 'initialize-release' stamp: 'jmv 9/25/2009 08:49'! 212521spyEvery: millisecs onProcess: aProcess forMilliseconds: msecDuration 212522 "Create a spy and spy on the given process at the specified rate." 212523 | myDelay startTime time0 endTime observedProcess sem | 212524 (aProcess isKindOf: Process) 212525 ifFalse: [self error: 'spy needs a Process here']. 212526 self class: aProcess suspendedContext receiver class method: aProcess suspendedContext method. 212527 "set up the probe" 212528 observedProcess := aProcess. 212529 myDelay := Delay forMilliseconds: millisecs. 212530 time0 := Time millisecondClockValue. 212531 endTime := time0 + msecDuration. 212532 sem := Semaphore new. 212533 gcStats := SmalltalkImage current getVMParameters. 212534 Timer ifNotNil: [ Timer terminate ]. 212535 Timer := [ 212536 [ 212537 startTime := Time millisecondClockValue. 212538 myDelay wait. 212539 self 212540 tally: Processor preemptedProcess suspendedContext 212541 in: (observedProcess == Processor preemptedProcess ifTrue: [observedProcess] ifFalse: [nil]) 212542 "tally can be > 1 if ran a long primitive" 212543 by: (Time millisecondClockValue - startTime) // millisecs. 212544 startTime < endTime 212545 ] whileTrue. 212546 sem signal. 212547 ] newProcess. 212548 Timer priority: Processor timingPriority-1. 212549 "activate the probe and evaluate the block" 212550 Timer resume. 212551 "activate the probe and wait for it to finish" 212552 sem wait. 212553 "Collect gc statistics" 212554 SmalltalkImage current getVMParameters keysAndValuesDo: [ :idx :gcVal | 212555 gcStats at: idx put: (gcVal - gcStats at: idx)]. 212556 time := Time millisecondClockValue - time0! ! 212557 212558 212559!MessageTally methodsFor: 'printing' stamp: 'jmv 9/24/2009 15:49'! 212560fullPrintExactOn: aStream 212561 aStream nextPutAll: '**Tree**'; cr. 212562 self 212563 treePrintOn: aStream 212564 tabs: OrderedCollection new 212565 thisTab: '' 212566 total: tally 212567 totalTime: time 212568 tallyExact: true 212569 orThreshold: nil. 212570 aStream nextPut: Character newPage; cr. 212571 aStream nextPutAll: '**Leaves**'; cr. 212572 self leavesPrintExactOn: aStream! ! 212573 212574!MessageTally methodsFor: 'printing' stamp: 'jmv 9/24/2009 15:49'! 212575fullPrintOn: aStream threshold: perCent 212576 | threshold | 212577 threshold := (perCent asFloat / 100 * tally) rounded. 212578 aStream nextPutAll: '**Tree**'; cr. 212579 self 212580 rootPrintOn: aStream 212581 total: tally 212582 totalTime: time 212583 threshold: threshold. 212584 aStream nextPut: Character newPage; cr. 212585 aStream nextPutAll: '**Leaves**'; cr. 212586 self 212587 leavesPrintOn: aStream 212588 threshold: threshold! ! 212589 212590!MessageTally methodsFor: 'printing' stamp: 'jmv 9/24/2009 15:47'! 212591leavesPrintExactOn: aStream 212592 | dict | 212593 dict := IdentityDictionary new: 100. 212594 self leavesInto: dict fromSender: nil. 212595 dict asSortedCollection 212596 do: [ :node | 212597 node printOn: aStream total: tally totalTime: nil tallyExact: true. 212598 node printSenderCountsOn: aStream ]! ! 212599 212600!MessageTally methodsFor: 'printing' stamp: 'jmv 9/24/2009 15:48'! 212601leavesPrintOn: aStream threshold: threshold 212602 | dict | 212603 dict := IdentityDictionary new: 100. 212604 self leavesInto: dict fromSender: nil. 212605 (dict asOrderedCollection 212606 select: [:node | node tally > threshold]) 212607 asSortedCollection do: [:node | 212608 node printOn: aStream total: tally totalTime: time tallyExact: false ]! ! 212609 212610!MessageTally methodsFor: 'printing' stamp: 'md 2/17/2006 13:44'! 212611printOn: aStream 212612 | className | 212613 (class isNil or: [method isNil]) ifTrue: [^super printOn: aStream]. 212614 className := method methodClass name contractTo: self maxClassNameSize. 212615 aStream 212616 nextPutAll: className; 212617 nextPutAll: ' >> '; 212618 nextPutAll: (method selector contractTo: self maxClassPlusSelectorSize - className size)! ! 212619 212620!MessageTally methodsFor: 'printing' stamp: 'md 2/17/2006 13:43'! 212621printOn: aStream total: total totalTime: totalTime tallyExact: isExact 212622 | aSelector className myTally aClass percentage | 212623 isExact 212624 ifTrue: 212625 [myTally := tally. 212626 receivers == nil 212627 ifFalse: [receivers do: [:r | myTally := myTally - r tally]]. 212628 aStream 212629 print: myTally; 212630 space] 212631 ifFalse: 212632 [percentage := tally asFloat / total * 100.0 roundTo: 0.1. 212633 aStream 212634 print: percentage; 212635 nextPutAll: '% {'; 212636 print: (percentage * totalTime / 100) rounded; 212637 nextPutAll: 'ms} ']. 212638 receivers == nil 212639 ifTrue: 212640 [aStream 212641 nextPutAll: 'primitives'; 212642 cr] 212643 ifFalse: 212644 [aSelector := method selector. 212645 aClass := method methodClass. 212646 className := aClass name contractTo: self maxClassNameSize. 212647 aStream 212648 nextPutAll: class name; 212649 nextPutAll: (aClass = class 212650 ifTrue: ['>>'] 212651 ifFalse: ['(' , aClass name , ')>>']); 212652 nextPutAll: (aSelector 212653 contractTo: self maxClassPlusSelectorSize - className size); 212654 cr]! ! 212655 212656!MessageTally methodsFor: 'printing' stamp: 'dew 3/22/2000 02:28'! 212657printSenderCountsOn: aStream 212658 | mergedSenders mergedNode | 212659 mergedSenders := IdentityDictionary new. 212660 senders do: 212661 [:node | 212662 mergedNode := mergedSenders at: node method ifAbsent: [nil]. 212663 mergedNode == nil 212664 ifTrue: [mergedSenders at: node method put: node] 212665 ifFalse: [mergedNode bump: node tally]]. 212666 mergedSenders asSortedCollection do: 212667 [:node | 212668 10 to: node tally printString size by: -1 do: [:i | aStream space]. 212669 node printOn: aStream total: tally totalTime: nil tallyExact: true]! ! 212670 212671!MessageTally methodsFor: 'printing' stamp: 'jmv 9/24/2009 16:07'! 212672rootPrintOn: aStream total: total totalTime: totalTime threshold: threshold 212673 212674 | sons groups p | 212675 sons := self sonsOver: threshold. 212676 groups := sons groupBy: [ :aTally | aTally process] having: [ :g | true]. 212677 groups do:[:g| 212678 sons := g asSortedCollection. 212679 p := g anyOne process. 212680 (reportOtherProcesses or: [ p notNil ]) ifTrue: [ 212681 aStream nextPutAll: '--------------------------------'; cr. 212682 aStream nextPutAll: 'Process: ', (p ifNil: [ 'other processes'] ifNotNil: [ p browserPrintString]); cr. 212683 aStream nextPutAll: '--------------------------------'; cr. 212684 (1 to: sons size) do:[:i | 212685 (sons at: i) 212686 treePrintOn: aStream 212687 tabs: OrderedCollection new 212688 thisTab: '' 212689 total: total 212690 totalTime: totalTime 212691 tallyExact: false 212692 orThreshold: threshold]]. 212693 ]! ! 212694 212695!MessageTally methodsFor: 'printing' stamp: 'nk 3/8/2004 12:23'! 212696treePrintOn: aStream tabs: tabs thisTab: myTab total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold 212697 | sons sonTab | 212698 tabs do: [:tab | aStream nextPutAll: tab]. 212699 tabs size > 0 212700 ifTrue: 212701 [self 212702 printOn: aStream 212703 total: total 212704 totalTime: totalTime 212705 tallyExact: isExact]. 212706 sons := isExact ifTrue: [receivers] ifFalse: [self sonsOver: threshold]. 212707 sons isEmpty 212708 ifFalse: 212709 [tabs addLast: myTab. 212710 sons := sons asSortedCollection. 212711 (1 to: sons size) do: 212712 [:i | 212713 sonTab := i < sons size ifTrue: [' |'] ifFalse: [' ']. 212714 (sons at: i) 212715 treePrintOn: aStream 212716 tabs: (tabs size < self maxTabs 212717 ifTrue: [tabs] 212718 ifFalse: [(tabs select: [:x | x = '[']) copyWith: '[']) 212719 thisTab: sonTab 212720 total: total 212721 totalTime: totalTime 212722 tallyExact: isExact 212723 orThreshold: threshold]. 212724 tabs removeLast]! ! 212725 212726 212727!MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'! 212728maxClassNameSize 212729 ^maxClassNameSize! ! 212730 212731!MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'! 212732maxClassNameSize: aNumber 212733 maxClassNameSize := aNumber! ! 212734 212735!MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'! 212736maxClassPlusSelectorSize 212737 ^maxClassPlusSelectorSize! ! 212738 212739!MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'! 212740maxClassPlusSelectorSize: aNumber 212741 maxClassPlusSelectorSize := aNumber! ! 212742 212743!MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'! 212744maxTabs 212745 ^maxTabs! ! 212746 212747!MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'! 212748maxTabs: aNumber 212749 maxTabs := aNumber! ! 212750 212751 212752!MessageTally methodsFor: 'reporting' stamp: 'jmv 3/4/2009 09:27'! 212753report: strm 212754 "Print a report, with cutoff percentage of each element of the tree 212755 (leaves, roots, tree), on the stream, strm." 212756 212757 self report: strm cutoff: 1! ! 212758 212759!MessageTally methodsFor: 'reporting' stamp: 'jmv 9/24/2009 15:35'! 212760report: strm cutoff: threshold 212761 tally = 0 212762 ifTrue: [strm nextPutAll: ' - no tallies obtained'] 212763 ifFalse: 212764 [strm nextPutAll: ' - '; print: tally; nextPutAll: ' tallies, ', time printString, ' msec.'; cr; cr. 212765 self fullPrintOn: strm threshold: threshold]. 212766 212767 time isZero ifFalse: 212768 [self reportGCStatsOn: strm].! ! 212769 212770!MessageTally methodsFor: 'reporting' stamp: 'ar 7/18/2001 22:12'! 212771reportGCStatsOn: str 212772 | oldSpaceEnd youngSpaceEnd memoryEnd fullGCs fullGCTime incrGCs incrGCTime tenureCount upTime rootOverflows | 212773 upTime := time. 212774 oldSpaceEnd := gcStats at: 1. 212775 youngSpaceEnd := gcStats at: 2. 212776 memoryEnd := gcStats at: 3. 212777 fullGCs := gcStats at: 7. 212778 fullGCTime := gcStats at: 8. 212779 incrGCs := gcStats at: 9. 212780 incrGCTime := gcStats at: 10. 212781 tenureCount := gcStats at: 11. 212782 rootOverflows := gcStats at: 22. 212783 212784 str cr. 212785 str nextPutAll: '**Memory**'; cr. 212786 str nextPutAll: ' old '; 212787 nextPutAll: oldSpaceEnd asStringWithCommasSigned; nextPutAll: ' bytes'; cr. 212788 str nextPutAll: ' young '; 212789 nextPutAll: (youngSpaceEnd - oldSpaceEnd) asStringWithCommasSigned; nextPutAll: ' bytes'; cr. 212790 str nextPutAll: ' used '; 212791 nextPutAll: youngSpaceEnd asStringWithCommasSigned; nextPutAll: ' bytes'; cr. 212792 str nextPutAll: ' free '; 212793 nextPutAll: (memoryEnd - youngSpaceEnd) asStringWithCommasSigned; nextPutAll: ' bytes'; cr. 212794 212795 str cr. 212796 str nextPutAll: '**GCs**'; cr. 212797 str nextPutAll: ' full '; 212798 print: fullGCs; nextPutAll: ' totalling '; nextPutAll: fullGCTime asStringWithCommas; nextPutAll: 'ms ('; 212799 print: ((fullGCTime / upTime * 100) roundTo: 1.0); 212800 nextPutAll: '% uptime)'. 212801 fullGCs = 0 ifFalse: 212802 [str nextPutAll: ', avg '; print: ((fullGCTime / fullGCs) roundTo: 1.0); nextPutAll: 'ms']. 212803 str cr. 212804 str nextPutAll: ' incr '; 212805 print: incrGCs; nextPutAll: ' totalling '; nextPutAll: incrGCTime asStringWithCommas; nextPutAll: 'ms ('; 212806 print: ((incrGCTime / upTime * 100) roundTo: 1.0); 212807 nextPutAll: '% uptime)'. 212808 incrGCs = 0 ifFalse: 212809 [str nextPutAll:', avg '; print: ((incrGCTime / incrGCs) roundTo: 1.0); nextPutAll: 'ms']. 212810 str cr. 212811 str nextPutAll: ' tenures '; 212812 nextPutAll: tenureCount asStringWithCommas. 212813 tenureCount = 0 ifFalse: 212814 [str nextPutAll: ' (avg '; print: (incrGCs / tenureCount) asInteger; nextPutAll: ' GCs/tenure)']. 212815 str cr. 212816 str nextPutAll: ' root table '; 212817 nextPutAll: rootOverflows asStringWithCommas; nextPutAll:' overflows'. 212818 str cr. 212819! ! 212820 212821!MessageTally methodsFor: 'reporting' stamp: 'stp 05/08/1999 12:06'! 212822tally 212823 "Answer the receiver's number of tally." 212824 212825 ^tally! ! 212826 212827!MessageTally methodsFor: 'reporting' stamp: 'stp 05/08/1999 11:47'! 212828time 212829 "Answer the receiver's run time." 212830 212831 ^time! ! 212832 212833 212834!MessageTally methodsFor: 'tallying'! 212835bumpBy: count 212836 212837 tally := tally + count! ! 212838 212839!MessageTally methodsFor: 'tallying' stamp: 'jmv 3/4/2009 09:42'! 212840tally: context by: count 212841 "Explicitly tally the specified context and its stack." 212842 | sender | 212843 212844 "Add to this node if appropriate" 212845 context method == method ifTrue: [^self bumpBy: count]. 212846 212847 "No sender? Add new branch to the tree." 212848 (sender := context home sender)ifNil: [ 212849 ^ (self bumpBy: count) tallyPath: context by: count]. 212850 212851 "Find the node for the sending context (or add it if necessary)" 212852 ^ (self tally: sender by: count) tallyPath: context by: count! ! 212853 212854!MessageTally methodsFor: 'tallying' stamp: 'jmv 3/4/2009 10:37'! 212855tally: context in: aProcess by: count 212856 "Explicitly tally the specified context and its stack." 212857 | sender | 212858 212859 "Add to this node if appropriate" 212860 context method == method ifTrue: [^self bumpBy: count]. 212861 212862 "No sender? Add new branch to the tree." 212863 (sender := context home sender) ifNil: [ 212864 ^ (self bumpBy: count) tallyPath: context in: aProcess by: count]. 212865 212866 "Find the node for the sending context (or add it if necessary)" 212867 ^ (self tally: sender in: aProcess by: count) tallyPath: context in: aProcess by: count! ! 212868 212869!MessageTally methodsFor: 'tallying' stamp: 'jmv 9/24/2009 16:11'! 212870tallyPath: context by: count 212871 | aMethod path | 212872 aMethod := context method. 212873 212874 "Find the correct child (if there)" 212875 receivers do: [ :oldTally | 212876 oldTally method == aMethod ifTrue: [path := oldTally]]. 212877 212878 "Add new child if needed" 212879 path ifNil: [ 212880 path := MessageTally new class: context receiver class method: aMethod. 212881 path reportOtherProcesses: reportOtherProcesses. 212882 receivers := receivers copyWith: path]. 212883 212884 ^ path bumpBy: count! ! 212885 212886!MessageTally methodsFor: 'tallying' stamp: 'jmv 9/24/2009 16:11'! 212887tallyPath: context in: aProcess by: count 212888 | aMethod path | 212889 aMethod := context method. 212890 212891 "Find the correct child (if there)" 212892 receivers do: [ :oldTally | 212893 (oldTally method == aMethod and: [oldTally process == aProcess]) 212894 ifTrue: [path := oldTally]]. 212895 212896 "Add new child if needed" 212897 path ifNil:[ 212898 path := MessageTally new class: context receiver class method: aMethod; 212899 process: aProcess; 212900 reportOtherProcesses: reportOtherProcesses; 212901 maxClassNameSize: maxClassNameSize; 212902 maxClassPlusSelectorSize: maxClassPlusSelectorSize; 212903 maxTabs: maxTabs. 212904 receivers := receivers copyWith: path]. 212905 212906 ^ path bumpBy: count! ! 212907 212908 212909!MessageTally methodsFor: 'private'! 212910class: aClass method: aMethod 212911 212912 class := aClass. 212913 method := aMethod. 212914 tally := 0. 212915 receivers := Array new: 0! ! 212916 212917!MessageTally methodsFor: 'private' stamp: 'StephaneDucasse 9/27/2009 10:29'! 212918copyWithTally: hitCount 212919 ^ (MessageTally new class: class method: method) 212920 reportOtherProcesses: reportOtherProcesses; 212921 process: process; 212922 bump: hitCount! ! 212923 212924!MessageTally methodsFor: 'private'! 212925method 212926 212927 ^method! ! 212928 212929!MessageTally methodsFor: 'private'! 212930primitives: anInteger 212931 212932 tally := anInteger. 212933 receivers := nil! ! 212934 212935!MessageTally methodsFor: 'private' stamp: 'ar 3/3/2009 19:29'! 212936process 212937 ^process! ! 212938 212939!MessageTally methodsFor: 'private' stamp: 'ar 3/3/2009 19:29'! 212940process: aProcess 212941 process := aProcess! ! 212942 212943 212944!MessageTally methodsFor: 'accessing' stamp: 'jmv 9/24/2009 16:02'! 212945reportOtherProcesses: aBoolean 212946 reportOtherProcesses := aBoolean! ! 212947 212948"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 212949 212950MessageTally class 212951 instanceVariableNames: ''! 212952 212953 212954!MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:27'! 212955defaultMaxClassNameSize 212956 "Return the default maximum width of the class name alone" 212957 ^30! ! 212958 212959!MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:27'! 212960defaultMaxClassPlusSelectorSize 212961 "Return the default maximum width of the class plus selector together (not counting the '>>')" 212962 ^60! ! 212963 212964!MessageTally class methodsFor: 'defaults' stamp: 'jmv 3/2/2009 12:32'! 212965defaultMaxTabs 212966 "Return the default number of tabs after which leading white space is compressed" 212967 ^120! ! 212968 212969!MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:41'! 212970defaultPollPeriod 212971 "Answer the number of milliseconds between interrupts for spyOn: and friends. 212972 This should be faster for faster machines." 212973 ^DefaultPollPeriod ifNil: [ DefaultPollPeriod := 1 ]! ! 212974 212975!MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:41'! 212976defaultPollPeriod: numberOfMilliseconds 212977 "Set the default number of milliseconds between interrupts for spyOn: and friends. 212978 This should be faster for faster machines." 212979 DefaultPollPeriod := numberOfMilliseconds! ! 212980 212981 212982!MessageTally class methodsFor: 'spying' stamp: 'jmv 9/24/2009 16:05'! 212983spyAllOn: aBlock 212984 "Spy on all the processes in the system 212985 212986 [1000 timesRepeat: [3.14159 printString. Processor yield]] fork. 212987 [1000 timesRepeat: [20 factorial. Processor yield]] fork. 212988 [1000 timesRepeat: [20 factorial. Processor yield]] fork. 212989 MessageTally spyAllOn: [ (Delay forMilliseconds: 100) wait] 212990 212991 " 212992 | node result | 212993 node := self new. 212994 node reportOtherProcesses: true. "Irrelevant in this case. All processes will be reported on their own." 212995 result := node spyAllEvery: self defaultPollPeriod on: aBlock. 212996 (CodeHolder new contents: (String streamContents: [:s | node report: s; close])) 212997 openLabel: 'Spy Results' wrap: false. 212998 ^ result! ! 212999 213000!MessageTally class methodsFor: 'spying' stamp: 'jmv 9/24/2009 15:59'! 213001spyOn: aBlock 213002 " 213003 Spy on aBlock, in the current process. Can include or not statistics on other processes in the report. 213004 [1000 timesRepeat: [ 213005 100 timesRepeat: [120 factorial]. 213006 (Delay forMilliseconds: 10) wait 213007 ]] forkAt: 45 named: '45'. 213008 MessageTally spyOn: [10000 timesRepeat: [1.23 printString]] 213009 " 213010 ^self spyOn: aBlock reportOtherProcesses: false! ! 213011 213012!MessageTally class methodsFor: 'spying' stamp: 'jmv 9/24/2009 16:14'! 213013spyOn: aBlock reportOtherProcesses: aBoolean 213014 " 213015 Spy on aBlock, in the current process. Can include or not statistics on other processes in the report. 213016 [1000 timesRepeat: [ 213017 100 timesRepeat: [120 factorial]. 213018 (Delay forMilliseconds: 10) wait 213019 ]] forkAt: 45 named: '45'. 213020 MessageTally spyOn: [10000 timesRepeat: [1.23 printString]] reportOtherProcesses: true 213021 " 213022 | node result | 213023 node := self new. 213024 node reportOtherProcesses: aBoolean. 213025 result := node spyEvery: self defaultPollPeriod on: aBlock. 213026 (CodeHolder new contents: (String streamContents: [:s | node report: s; close])) 213027 openLabel: 'Spy Results' wrap: false. 213028 ^ result! ! 213029 213030!MessageTally class methodsFor: 'spying' stamp: 'jmv 9/24/2009 16:02'! 213031spyOn: aBlock toFileNamed: fileName reportOtherProcesses: aBoolean 213032 "Spy on the evaluation of aBlock. Write the data collected on a file 213033 named fileName." 213034 213035 | file value node | 213036 node := self new. 213037 node reportOtherProcesses: aBoolean. 213038 value := node spyEvery: self defaultPollPeriod on: aBlock. 213039 file := FileStream newFileNamed: fileName. 213040 node report: file; close. 213041 file close. 213042 ^value! ! 213043 213044!MessageTally class methodsFor: 'spying' stamp: 'jmv 9/24/2009 16:00'! 213045spyOnProcess: aProcess forMilliseconds: msecDuration 213046 " 213047 Spy on aProcess for a certain amount of time 213048 | p1 p2 | 213049 p1 := [100000 timesRepeat: [3.14159 printString. Processor yield]] newProcess. 213050 p2 := [100000 timesRepeat: [3.14159 printString. Processor yield]] newProcess. 213051 p1 resume. 213052 p2 resume. 213053 (Delay forMilliseconds: 100) wait. 213054 MessageTally spyOnProcess: p1 forMilliseconds: 1000 213055 " 213056 ^self spyOnProcess: aProcess forMilliseconds: msecDuration reportOtherProcesses: false 213057! ! 213058 213059!MessageTally class methodsFor: 'spying' stamp: 'jmv 9/24/2009 16:15'! 213060spyOnProcess: aProcess forMilliseconds: msecDuration reportOtherProcesses: aBoolean 213061 " 213062 Spy on aProcess for a certain amount of time 213063 | p1 p2 | 213064 p1 := [100000 timesRepeat: [3.14159 printString. Processor yield]] newProcess. 213065 p2 := [100000 timesRepeat: [3.14159 printString. Processor yield]] newProcess. 213066 p1 resume. 213067 p2 resume. 213068 (Delay forMilliseconds: 100) wait. 213069 MessageTally spyOnProcess: p1 forMilliseconds: 1000 reportOtherProcesses: true 213070 " 213071 | node | 213072 node := self new. 213073 node reportOtherProcesses: aBoolean. 213074 node 213075 spyEvery: self defaultPollPeriod 213076 onProcess: aProcess 213077 forMilliseconds: msecDuration. 213078 (CodeHolder new 213079 contents: (String 213080 streamContents: [:s | node report: s; 213081 close])) 213082 openLabel: 'Spy Results' wrap: false! ! 213083 213084!MessageTally class methodsFor: 'spying' stamp: 'jmv 9/24/2009 16:02'! 213085spyOnProcess: aProcess forMilliseconds: msecDuration toFileNamed: fileName reportOtherProcesses: aBoolean 213086 "Spy on the evaluation of aProcess. Write the data collected on a file 213087 named fileName. Will overwrite fileName" 213088 | file node | 213089 node := self new. 213090 node reportOtherProcesses: aBoolean. 213091 node 213092 spyEvery: self defaultPollPeriod 213093 onProcess: aProcess 213094 forMilliseconds: msecDuration. 213095 file := FileStream fileNamed: fileName. 213096 node report: file; 213097 close. 213098 file close! ! 213099 213100!MessageTally class methodsFor: 'spying' stamp: 'jmv 9/24/2009 16:17'! 213101tallySends: aBlock 213102 " 213103 MessageTally tallySends: [3.14159 printString] 213104 " 213105 213106 ^ self tallySendsTo: nil inBlock: aBlock showTree: true! ! 213107 213108!MessageTally class methodsFor: 'spying' stamp: 'jmv 9/24/2009 16:04'! 213109tallySendsTo: receiver inBlock: aBlock showTree: treeOption 213110 " 213111 MessageTally tallySends: [3.14159 printString] 213112 " 213113 "This method uses the simulator to count the number of calls on each method 213114 invoked in evaluating aBlock. If receiver is not nil, then only sends 213115 to that receiver are tallied. 213116 Results are presented as leaves, sorted by frequency, 213117 preceded, optionally, by the whole tree." 213118 | prev tallies startTime totalTime | 213119 startTime := Time millisecondClockValue. 213120 tallies := MessageTally new class: aBlock receiver class method: aBlock method. 213121 tallies reportOtherProcesses: true. "Do NOT filter nodes with nil process" 213122 prev := aBlock. 213123 thisContext sender 213124 runSimulated: aBlock 213125 contextAtEachStep: 213126 [:current | 213127 current == prev ifFalse: 213128 ["call or return" 213129 prev sender == nil ifFalse: 213130 ["call only" 213131 (receiver == nil or: [current receiver == receiver]) 213132 ifTrue: [tallies tally: current by: 1]]. 213133 prev := current]]. 213134 213135 totalTime := Time millisecondClockValue - startTime // 1000.0 roundTo: 0.01. 213136 (CodeHolder new contents: 213137 (String streamContents: 213138 [:s | 213139 s nextPutAll: 'This simulation took ' , totalTime printString 213140 , ' seconds.'; cr. 213141 treeOption 213142 ifTrue: [ tallies fullPrintExactOn: s ] 213143 ifFalse: [ tallies leavesPrintExactOn: s ]. 213144 tallies close ])) 213145 openLabel: 'Spy Results' wrap: false! ! 213146 213147!MessageTally class methodsFor: 'spying'! 213148time: aBlock 213149 213150 ^ Time millisecondsToRun: aBlock! ! 213151ClassDescription subclass: #Metaclass 213152 uses: TApplyingOnClassSide 213153 instanceVariableNames: 'thisClass traitComposition localSelectors' 213154 classVariableNames: '' 213155 poolDictionaries: '' 213156 category: 'Kernel-Classes'! 213157!Metaclass commentStamp: '<historical>' prior: 0! 213158My instances add instance-specific behavior to various class-describing objects in the system. This typically includes messages for initializing class variables and instance creation messages particular to a class. There is only one instance of a particular Metaclass, namely the class which is being described. A Metaclass shares the class variables of its instance. 213159 213160[Subtle] In general, the superclass hierarchy for metaclasses parallels that for classes. Thus, 213161 Integer superclass == Number, and 213162 Integer class superclass == Number class. 213163However there is a singularity at Object. Here the class hierarchy terminates, but the metaclass hierarchy must wrap around to Class, since ALL metaclasses are subclasses of Class. Thus, 213164 Object superclass == nil, and 213165 Object class superclass == Class. 213166 213167[Subtle detail] A class is know by name to an environment. Typically this is the SystemDictionary named Smalltalk. If we ever make lightweight classes that are not in Smalltalk, they must be in some environment. Specifically, the code that sets 'wasPresent' in name:inEnvironment:subclassOf:instanceVariableNames:variable:words:pointers:classVariableNames:poolDictionaries:category:comment:changed: must continue to work.! 213168 213169 213170!Metaclass methodsFor: 'accessing' stamp: 'ar 7/11/1999 08:14'! 213171allInstances 213172 thisClass class == self ifTrue:[^Array with: thisClass]. 213173 ^super allInstances! ! 213174 213175!Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'! 213176basicLocalSelectors 213177 "Direct accessor for the instance variable localSelectors. 213178 Since localSelectors is lazily initialized, this may 213179 return nil, which means that all selectors are local." 213180 213181 ^ localSelectors! ! 213182 213183!Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'! 213184basicLocalSelectors: aSetOrNil 213185 localSelectors := aSetOrNil! ! 213186 213187!Metaclass methodsFor: 'accessing' stamp: 'ar 7/11/1999 05:19'! 213188environment 213189 ^thisClass environment! ! 213190 213191!Metaclass methodsFor: 'accessing' stamp: 'al 3/26/2006 11:32'! 213192hasTraitComposition 213193 ^traitComposition notNil! ! 213194 213195!Metaclass methodsFor: 'accessing' stamp: 'tk 6/17/1998 09:48'! 213196isSystemDefined 213197 "Answer false if I am a UniClass (an instance-specific lightweight class)" 213198 213199 ^ true! ! 213200 213201!Metaclass methodsFor: 'accessing'! 213202name 213203 "Answer a String that is the name of the receiver, either 'Metaclass' or 213204 the name of the receiver's class followed by ' class'." 213205 213206 thisClass == nil 213207 ifTrue: [^'a Metaclass'] 213208 ifFalse: [^thisClass name , ' class']! ! 213209 213210!Metaclass methodsFor: 'accessing'! 213211soleInstance 213212 "The receiver has only one instance. Answer it." 213213 213214 ^thisClass! ! 213215 213216!Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 12:35'! 213217traitComposition 213218 traitComposition ifNil: [traitComposition := TraitComposition new]. 213219 ^traitComposition! ! 213220 213221!Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 12:38'! 213222traitComposition: aTraitComposition 213223 traitComposition := aTraitComposition! ! 213224 213225 213226!Metaclass methodsFor: 'accessing parallel hierarchy' stamp: 'sd 6/27/2003 22:51'! 213227theMetaClass 213228 "Sent to a class or metaclass, always return the metaclass" 213229 213230 ^self! ! 213231 213232!Metaclass methodsFor: 'accessing parallel hierarchy'! 213233theNonMetaClass 213234 "Sent to a class or metaclass, always return the class" 213235 213236 ^thisClass! ! 213237 213238 213239!Metaclass methodsFor: 'as yet unclassified' stamp: 'adrian.lienhard 1/5/2009 23:04'! 213240classVarNames 213241 "Answer a set of the names of the class variables defined in the receiver's instance." 213242 213243 thisClass ifNil: [ ^ Set new ]. 213244 ^thisClass classVarNames! ! 213245 213246 213247!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'! 213248addObsoleteSubclass: aClass 213249 "Do nothing."! ! 213250 213251!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/11/1999 15:43'! 213252addSubclass: aClass 213253 "Do nothing."! ! 213254 213255!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'! 213256obsoleteSubclasses 213257 "Answer the receiver's subclasses." 213258 thisClass == nil ifTrue:[^#()]. 213259 ^thisClass obsoleteSubclasses 213260 select:[:aSubclass| aSubclass isMeta not] 213261 thenCollect:[:aSubclass| aSubclass class] 213262 213263 "Metaclass allInstancesDo: 213264 [:m | Compiler evaluate: 'subclasses:=nil' for: m logged: false]"! ! 213265 213266!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'! 213267removeObsoleteSubclass: aClass 213268 "Do nothing."! ! 213269 213270!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/11/1999 15:43'! 213271removeSubclass: aClass 213272 "Do nothing."! ! 213273 213274!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/14/1999 11:19'! 213275subclasses 213276 "Answer the receiver's subclasses." 213277 thisClass == nil ifTrue:[^#()]. 213278 ^thisClass subclasses 213279 select:[:aSubclass| aSubclass isMeta not] 213280 thenCollect:[:aSubclass| aSubclass class] 213281 213282 "Metaclass allInstancesDo: 213283 [:m | Compiler evaluate: 'subclasses:=nil' for: m logged: false]"! ! 213284 213285!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/9/1999 14:11'! 213286subclassesDo: aBlock 213287 "Evaluate aBlock for each of the receiver's immediate subclasses." 213288 thisClass subclassesDo:[:aSubclass| 213289 "The following test is for Class class which has to exclude 213290 the Metaclasses being subclasses of Class." 213291 aSubclass isMeta ifFalse:[aBlock value: aSubclass class]].! ! 213292 213293!Metaclass methodsFor: 'class hierarchy' stamp: 'tk 8/18/1999 17:37'! 213294subclassesDoGently: aBlock 213295 "Evaluate aBlock for each of the receiver's immediate subclasses." 213296 thisClass subclassesDo: [:aSubclass | 213297 "The following test is for Class class which has to exclude 213298 the Metaclasses being subclasses of Class." 213299 aSubclass isInMemory ifTrue: [ 213300 aSubclass isMeta ifFalse: [aBlock value: aSubclass class]]].! ! 213301 213302 213303!Metaclass methodsFor: 'compiling'! 213304acceptsLoggingOfCompilation 213305 "Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set. The metaclass follows the rule of the class itself. 6/18/96 sw" 213306 213307 ^ thisClass acceptsLoggingOfCompilation! ! 213308 213309!Metaclass methodsFor: 'compiling' stamp: 'ar 5/18/2003 18:13'! 213310bindingOf: varName 213311 213312 ^thisClass classBindingOf: varName! ! 213313 213314!Metaclass methodsFor: 'compiling'! 213315possibleVariablesFor: misspelled continuedFrom: oldResults 213316 213317 ^ thisClass possibleVariablesFor: misspelled continuedFrom: oldResults 213318! ! 213319 213320!Metaclass methodsFor: 'compiling'! 213321wantsChangeSetLogging 213322 "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.The metaclass follows the rule of the class itself. 7/12/96 sw" 213323 213324 ^ thisClass wantsChangeSetLogging! ! 213325 213326!Metaclass methodsFor: 'compiling' stamp: 'sw 7/31/2000 14:29'! 213327wantsRecompilationProgressReported 213328 "The metaclass follows the rule of the class itself." 213329 213330 ^ thisClass wantsRecompilationProgressReported! ! 213331 213332 213333!Metaclass methodsFor: 'composition'! 213334assertConsistantCompositionsForNew: aTraitComposition 213335 "Applying or modifying a trait composition on the class side 213336 of a behavior has some restrictions." 213337 213338 | baseTraits notAddable message | 213339 baseTraits := aTraitComposition traits select: [:each | each isBaseTrait]. 213340 baseTraits isEmpty ifFalse: [ 213341 notAddable := (baseTraits reject: [:each | each classSide methodDict isEmpty]). 213342 notAddable isEmpty ifFalse: [ 213343 message := String streamContents: [:stream | 213344 stream nextPutAll: 'You can not add the base trait(s)'; cr. 213345 notAddable 213346 do: [:each | stream nextPutAll: each name] 213347 separatedBy: [ stream nextPutAll: ', ']. 213348 stream cr; nextPutAll: 'to this composition because it/they define(s) methods on the class side.']. 213349 ^TraitCompositionException signal: message]]. 213350 213351 (self instanceSide traitComposition traits asSet = 213352 (aTraitComposition traits 213353 select: [:each | each isClassTrait] 213354 thenCollect: [:each | each baseTrait]) asSet) ifFalse: [ 213355 ^TraitCompositionException signal: 'You can not add or remove class side traits on 213356 the class side of a composition. (But you can specify aliases or exclusions 213357 for existing traits or add a trait which does not have any methods on the class side.)']! ! 213358 213359!Metaclass methodsFor: 'composition'! 213360noteNewBaseTraitCompositionApplied: aTraitComposition 213361 "The argument is the new trait composition of my base trait - add 213362 the new traits or remove non existing traits on my class side composition. 213363 (Each class trait in my composition has its base trait on the instance side 213364 of the composition - manually added traits to the class side are always 213365 base traits.)" 213366 213367 | newComposition traitsFromInstanceSide | 213368 traitsFromInstanceSide := self traitComposition traits 213369 select: [:each | each isClassTrait] 213370 thenCollect: [:each | each baseTrait]. 213371 213372 newComposition := self traitComposition copyTraitExpression. 213373 (traitsFromInstanceSide copyWithoutAll: aTraitComposition traits) do: [:each | 213374 newComposition removeFromComposition: each classTrait]. 213375 (aTraitComposition traits copyWithoutAll: traitsFromInstanceSide) do: [:each | 213376 newComposition add: (each classTrait)]. 213377 213378 self setTraitComposition: newComposition! ! 213379 213380 213381!Metaclass methodsFor: 'copying'! 213382copy 213383 "Make a copy of the receiver without a list of subclasses. Share the 213384 reference to the sole instance." 213385 213386 | copy t | 213387 t := thisClass. 213388 thisClass := nil. 213389 copy := super copy. 213390 thisClass := t. 213391 ^copy! ! 213392 213393!Metaclass methodsFor: 'copying' stamp: 'tk 8/19/1998 16:16'! 213394veryDeepCopyWith: deepCopier 213395 "Return self. Must be created, not copied. Do not record me."! ! 213396 213397 213398!Metaclass methodsFor: 'enumerating' stamp: 'ar 7/15/1999 16:43'! 213399allInstancesDo: aBlock 213400 "There should be only one" 213401 thisClass class == self ifTrue:[^aBlock value: thisClass]. 213402 ^super allInstancesDo: aBlock! ! 213403 213404!Metaclass methodsFor: 'enumerating' stamp: 'tk 11/12/1999 11:45'! 213405allInstancesEverywhereDo: aBlock 213406 "There should be only one" 213407 thisClass class == self ifTrue:[^ aBlock value: thisClass]. 213408 ^ super allInstancesEverywhereDo: aBlock! ! 213409 213410 213411!Metaclass methodsFor: 'fileIn/Out' stamp: 'al 7/4/2009 17:45'! 213412definition 213413 "Refer to the comment in ClassDescription|definition." 213414 213415 ^ String streamContents: 213416 [:strm | 213417 strm print: self. 213418 (self hasTraitComposition and: [self traitComposition notEmpty]) ifTrue: [ 213419 strm 213420 crtab; 213421 nextPutAll: 'uses: '; 213422 print: self traitComposition ]. 213423 strm 213424 crtab; 213425 nextPutAll: 'instanceVariableNames: '; 213426 store: self instanceVariablesString]! ! 213427 213428!Metaclass methodsFor: 'fileIn/Out' stamp: 'di 2/17/2000 22:33'! 213429fileOutInitializerOn: aStream 213430 (self methodDict includesKey: #initialize) ifTrue: 213431 [aStream cr. 213432 aStream nextChunkPut: thisClass name , ' initialize'].! ! 213433 213434!Metaclass methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:31'! 213435fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex 213436 ^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! ! 213437 213438!Metaclass methodsFor: 'fileIn/Out' stamp: 'al 7/19/2004 18:28'! 213439fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool 213440 super fileOutOn: aFileStream 213441 moveSource: moveSource 213442 toFile: fileIndex. 213443 (aBool and:[moveSource not and: [self methodDict includesKey: #initialize]]) ifTrue: 213444 [aFileStream cr. 213445 aFileStream cr. 213446 aFileStream nextChunkPut: thisClass name , ' initialize'. 213447 aFileStream cr]! ! 213448 213449!Metaclass methodsFor: 'fileIn/Out' stamp: 'marcus.denker 8/25/2008 09:02'! 213450nonTrivial 213451 "Answer whether the receiver has any methods or instance variables." 213452 213453 ^ self instVarNames notEmpty or: [self hasMethods] or: [self hasTraitComposition]! ! 213454 213455!Metaclass methodsFor: 'fileIn/Out' stamp: 'tk 9/28/2000 15:44'! 213456objectForDataStream: refStrm 213457 | dp | 213458 "I am about to be written on an object file. Write a reference to a class in Smalltalk instead." 213459 213460 (refStrm insideASegment and: [self isSystemDefined not]) ifTrue: [ 213461 ^ self]. "do trace me" 213462 dp := DiskProxy global: self theNonMetaClass name selector: #class 213463 args: (Array new). 213464 refStrm replace: self with: dp. 213465 ^ dp 213466! ! 213467 213468!Metaclass methodsFor: 'fileIn/Out' stamp: 'tk 9/27/2000 11:39'! 213469storeDataOn: aDataStream 213470 "I don't get stored. Use a DiskProxy" 213471 213472 (aDataStream insideASegment and: [self isSystemDefined not]) ifTrue: [ 213473 ^ super storeDataOn: aDataStream]. "do trace me" 213474 self error: 'use a DiskProxy to store a Class'! ! 213475 213476 213477!Metaclass methodsFor: 'initialize-release' stamp: 'ar 7/13/1999 04:52'! 213478adoptInstance: oldInstance from: oldMetaClass 213479 "Recreate any existing instances of the argument, oldClass, as instances of 213480 the receiver, which is a newly changed class. Permute variables as 213481 necessary." 213482 thisClass class == self ifTrue:[^self error:'Metaclasses have only one instance']. 213483 oldMetaClass isMeta ifFalse:[^self error:'Argument must be Metaclass']. 213484 oldInstance class == oldMetaClass ifFalse:[^self error:'Not the class of argument']. 213485 ^thisClass := self 213486 newInstanceFrom: oldInstance 213487 variable: self isVariable 213488 size: self instSize 213489 map: (self instVarMappingFrom: oldMetaClass)! ! 213490 213491!Metaclass methodsFor: 'initialize-release' stamp: 'ar 7/15/1999 18:56'! 213492instanceVariableNames: instVarString 213493 "Declare additional named variables for my instance." 213494 ^(ClassBuilder new) 213495 class: self 213496 instanceVariableNames: instVarString! ! 213497 213498!Metaclass methodsFor: 'initialize-release' stamp: 'al 7/19/2004 20:49'! 213499uses: aTraitCompositionOrArray instanceVariableNames: instVarString 213500 | newComposition newMetaClass copyOfOldMetaClass | 213501 213502 copyOfOldMetaClass := self copy. 213503 newMetaClass := self instanceVariableNames: instVarString. 213504 213505 newComposition := aTraitCompositionOrArray asTraitComposition. 213506 newMetaClass assertConsistantCompositionsForNew: newComposition. 213507 newMetaClass setTraitComposition: newComposition. 213508 213509 SystemChangeNotifier uniqueInstance 213510 classDefinitionChangedFrom: copyOfOldMetaClass to: newMetaClass! ! 213511 213512 213513!Metaclass methodsFor: 'instance creation' stamp: 'nk 11/9/2003 10:00'! 213514new 213515 "The receiver can only have one instance. Create it or complain that 213516 one already exists." 213517 213518 thisClass class ~~ self 213519 ifTrue: [^thisClass := self basicNew] 213520 ifFalse: [self error: 'A Metaclass should only have one instance!!']! ! 213521 213522 213523!Metaclass methodsFor: 'instance variables'! 213524addInstVarName: aString 213525 "Add the argument, aString, as one of the receiver's instance variables." 213526 213527 | fullString | 213528 fullString := aString. 213529 self instVarNames do: [:aString2 | fullString := aString2 , ' ' , fullString]. 213530 self instanceVariableNames: fullString! ! 213531 213532!Metaclass methodsFor: 'instance variables'! 213533removeInstVarName: aString 213534 "Remove the argument, aString, as one of the receiver's instance variables." 213535 213536 | newArray newString | 213537 (self instVarNames includes: aString) 213538 ifFalse: [self error: aString , ' is not one of my instance variables']. 213539 newArray := self instVarNames copyWithout: aString. 213540 newString := ''. 213541 newArray do: [:aString2 | newString := aString2 , ' ' , newString]. 213542 self instanceVariableNames: newString! ! 213543 213544 213545!Metaclass methodsFor: 'pool variables'! 213546classPool 213547 "Answer the dictionary of class variables." 213548 213549 ^thisClass classPool! ! 213550 213551 213552!Metaclass methodsFor: 'testing' stamp: 'ar 9/10/1999 17:41'! 213553canZapMethodDictionary 213554 "Return true if it is safe to zap the method dictionary on #obsolete" 213555 thisClass == nil 213556 ifTrue:[^true] 213557 ifFalse:[^thisClass canZapMethodDictionary]! ! 213558 213559!Metaclass methodsFor: 'testing' stamp: 'dvf 9/27/2005 14:59'! 213560isMeta 213561 ^ true! ! 213562 213563!Metaclass methodsFor: 'testing' stamp: 'ar 7/11/1999 07:27'! 213564isObsolete 213565 "Return true if the receiver is obsolete" 213566 ^thisClass == nil "Either no thisClass" 213567 or:[thisClass class ~~ self "or I am not the class of thisClass" 213568 or:[thisClass isObsolete]] "or my instance is obsolete"! ! 213569 213570!Metaclass methodsFor: 'testing' stamp: 'wbk 7/26/2007 12:41'! 213571isSelfEvaluating 213572 ^ true! ! 213573 213574 213575!Metaclass methodsFor: 'private' stamp: 'ar 3/3/2001 00:20'! 213576replaceObsoleteInstanceWith: newInstance 213577 thisClass class == self ifTrue:[^self error:'I am fine, thanks']. 213578 newInstance class == self ifFalse:[^self error:'Not an instance of me']. 213579 thisClass := newInstance.! ! 213580 213581"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 213582 213583Metaclass class 213584 uses: TApplyingOnClassSide classTrait 213585 instanceVariableNames: ''! 213586Object subclass: #MethodAddition 213587 instanceVariableNames: 'text category changeStamp requestor logSource myClass methodAndNode selector compiledMethod priorMethodOrNil' 213588 classVariableNames: '' 213589 poolDictionaries: '' 213590 category: 'Monticello-Loading'! 213591!MethodAddition commentStamp: 'rej 2/25/2007 19:30' prior: 0! 213592I represent the addition of a method to a class. I can produce the CompiledMethod, install it, and then notify the system that the method has been added. This allows Monticello to implement atomic addition. A loader can compile all classes and methods first and then install all methods only after they have been all compiled, and in a way that executes little code.ß! 213593 213594 213595!MethodAddition methodsFor: 'as yet unclassified' stamp: 'rej 2/26/2007 10:51'! 213596compile 213597 "This method is the how compiling a method used to work. All these steps were done at once. 213598 This method should not normally be used, because the whole point of MethodAddition is to let 213599 you first create a compiled method and then install the method later." 213600 self createCompiledMethod. 213601 self installMethod. 213602 self notifyObservers. 213603 ^selector! ! 213604 213605!MethodAddition methodsFor: 'as yet unclassified' stamp: 'rej 2/25/2007 20:36'! 213606compile: aString classified: aString1 withStamp: aString2 notifying: aRequestor logSource: aBoolean inClass: aClass 213607 213608 text := aString. 213609 category := aString1. 213610 changeStamp := aString2. 213611 requestor := aRequestor. 213612 logSource := aBoolean. 213613 myClass := aClass! ! 213614 213615!MethodAddition methodsFor: 'as yet unclassified' stamp: 'rej 2/26/2007 05:17'! 213616createCompiledMethod 213617 methodAndNode := myClass compile: text asString classified: category notifying: requestor 213618 trailer: myClass defaultMethodTrailer ifFail: [^nil]. 213619 selector := methodAndNode selector. 213620 compiledMethod := methodAndNode method. 213621 self writeSourceToLog. 213622 priorMethodOrNil := myClass compiledMethodAt: selector ifAbsent: [nil]. 213623! ! 213624 213625!MethodAddition methodsFor: 'as yet unclassified' stamp: 'rej 2/25/2007 22:09'! 213626installMethod 213627 myClass addSelectorSilently: selector withMethod: compiledMethod. 213628! ! 213629 213630!MethodAddition methodsFor: 'as yet unclassified' stamp: 'rej 2/25/2007 22:12'! 213631notifyObservers 213632 SystemChangeNotifier uniqueInstance 213633 doSilently: [myClass organization classify: selector under: category]. 213634 priorMethodOrNil isNil 213635 ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: myClass requestor: requestor] 213636 ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: myClass requestor: requestor]. 213637 "The following code doesn't seem to do anything." 213638 myClass instanceSide noteCompilationOf: selector meta: myClass isClassSide. 213639! ! 213640 213641!MethodAddition methodsFor: 'as yet unclassified' stamp: 'rej 2/25/2007 20:42'! 213642writeSourceToLog 213643 logSource ifTrue: [ 213644 myClass logMethodSource: text forMethodWithNode: methodAndNode 213645 inCategory: category withStamp: changeStamp notifying: requestor. 213646 ]. 213647! ! 213648Object subclass: #MethodChangeRecord 213649 instanceVariableNames: 'changeType currentMethod infoFromRemoval' 213650 classVariableNames: '' 213651 poolDictionaries: '' 213652 category: 'System-Changes'! 213653!MethodChangeRecord commentStamp: '<historical>' prior: 0! 213654MethodChangeRecords are used to record method changes. Here is a simple summary of the relationship between the changeType symbol and the recording of prior state 213655 213656 | prior == nil | prior not nil 213657 --------- |---------------------------- |-------------------- 213658 add | add | change 213659 --------- |---------------------------- |-------------------- 213660 remove | addedThenRemoved | remove 213661 213662Structure: 213663changeType symbol -- as summarized above 213664currentMethod method 213665 This is the current version of the method. 213666 It can be used to assert this change upon entry to a layer. 213667infoFromRemoval -- an array of size 2. 213668 The first element is the source index of the last version of the method. 213669 The second element is the category in which it was defined, so it 213670 can be put back there if re-accepted from a version browser. 213671 213672Note that the above states each have an associated revoke action: 213673 add --> remove 213674 change --> change back 213675 remove --> add back 213676 addedThenRemoved --> no change 213677However all of these are accomplished trivially by restoring the original method dictionary.! 213678 213679 213680!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 12:02'! 213681changeType 213682 213683 ^ changeType! ! 213684 213685!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 3/28/2000 23:34'! 213686currentMethod 213687 213688 ^ currentMethod! ! 213689 213690!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 12:02'! 213691methodInfoFromRemoval 213692 "Return an array with the source index of the last version of the method, 213693 and the category in which it was defined (so it can be put back there if 213694 re-accepted from a version browser)." 213695 213696 (changeType == #remove or: [changeType == #addedThenRemoved]) 213697 ifTrue: [^ infoFromRemoval] 213698 ifFalse: [^ nil]! ! 213699 213700!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/4/2000 11:05'! 213701noteChangeType: newChangeType 213702 213703 (changeType == #addedThenRemoved and: [newChangeType == #change]) 213704 ifTrue: [changeType := #add] 213705 ifFalse: [changeType := newChangeType]! ! 213706 213707!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 11:05'! 213708noteMethodInfoFromRemoval: info 213709 "Store an array with the source index of the last version of the method, 213710 and the category in which it was defined (so it can be put back there if 213711 re-accepted from a version browser)." 213712 213713 infoFromRemoval := info! ! 213714 213715!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'ar 6/3/2005 17:01'! 213716noteNewMethod: newMethod 213717 "NEVER do this. It is evil." 213718 currentMethod := nil.! ! 213719 213720!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 12:02'! 213721printOn: strm 213722 213723 super printOn: strm. 213724 strm nextPutAll: ' ('; print: changeType; nextPutAll: ')'! ! 213725 213726!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 10:47'! 213727priorMethod: ignored 213728 213729 "We do not save original versions of changed methods because we only 213730 revoke changes at the level of entire classes, and that is done by 213731 restoration of the entire methodDictionary."! ! 213732 213733!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'ar 5/23/2001 16:16'! 213734storeDataOn: aDataStream 213735 | oldMethod | 213736 oldMethod := currentMethod. 213737 currentMethod := nil. 213738 super storeDataOn: aDataStream. 213739 currentMethod := oldMethod. 213740! ! 213741ContextPart variableSubclass: #MethodContext 213742 instanceVariableNames: 'method closureOrNil receiver' 213743 classVariableNames: '' 213744 poolDictionaries: '' 213745 category: 'Kernel-Methods'! 213746!MethodContext commentStamp: '<historical>' prior: 0! 213747My instances hold all the dynamic state associated with the execution of either a method activation resulting from a message send or a block activation resulting from a block evaluation. In addition to their inherited state, this includes the receiver (self), the closure for a BlockClosure activation (which is nil for a method activation), a CompiledMethod, and space in the variable part of the context for arguments and temporary variables. 213748 213749MethodContexts, though normal in their variable size, are actually only used in two sizes, small and large, which are determined by the temporary space required by the method being executed. 213750 213751MethodContexts must only be created using the method newForMethod:. Note that it is impossible to determine the real object size of a MethodContext except by asking for the frameSize of its method. Any fields above the stack pointer (stackp) are truly invisible -- even (and especially!!) to the garbage collector. Any store into stackp other than by the primitive method stackp: is potentially fatal.! 213752 213753 213754!MethodContext methodsFor: 'accessing' stamp: 'eem 6/15/2008 11:28'! 213755activeHome 213756 "If executing closure, search senders for the activation of the original 213757 (outermost) method that (indirectly) created my closure (the closureHome). 213758 If the closureHome is not found on the sender chain answer nil." 213759 213760 | methodReturnContext | 213761 self isExecutingBlock ifFalse: [^self]. 213762 self sender ifNil: [^nil]. 213763 methodReturnContext := self methodReturnContext. 213764 ^self sender findContextSuchThat: [:ctxt | ctxt = methodReturnContext]! ! 213765 213766!MethodContext methodsFor: 'accessing' stamp: 'eem 5/28/2008 10:45'! 213767activeOuterContext 213768 "If executing closure, search senders for the activation in which the receiver's 213769 closure was created (the receiver's outerContext). If the outerContext is not 213770 found on the sender chain answer nil." 213771 213772 | outerContext | 213773 self isExecutingBlock ifFalse: [^self]. 213774 self sender ifNil: [^nil]. 213775 outerContext := self outerContext. 213776 ^self sender findContextSuchThat: [:ctxt | ctxt = outerContext]! ! 213777 213778!MethodContext methodsFor: 'accessing' stamp: 'eem 7/22/2008 11:57'! 213779closure 213780 ^closureOrNil! ! 213781 213782!MethodContext methodsFor: 'accessing' stamp: 'eem 6/15/2008 11:31'! 213783contextForLocalVariables 213784 "Answer the context in which local variables (temporaries) are stored." 213785 213786 ^self! ! 213787 213788!MethodContext methodsFor: 'accessing' stamp: 'md 4/27/2006 15:12'! 213789hasInstVarRef 213790 "Answer whether the receiver references an instance variable." 213791 213792 ^self method hasInstVarRef.! ! 213793 213794!MethodContext methodsFor: 'accessing' stamp: 'eem 4/25/2009 09:50'! 213795hasMethodReturn 213796 ^closureOrNil hasMethodReturn! ! 213797 213798!MethodContext methodsFor: 'accessing' stamp: 'eem 7/22/2008 11:57'! 213799home 213800 "Answer the context in which the receiver was defined." 213801 213802 closureOrNil == nil ifTrue: 213803 [^self]. 213804 ^closureOrNil outerContext home! ! 213805 213806!MethodContext methodsFor: 'accessing' stamp: 'eem 7/22/2008 11:57'! 213807isExecutingBlock 213808 "Is this executing a block versus a method? In the new closure 213809 implemetation this is true if closureOrNil is not nil, in which case 213810 it should be holding a BlockClosure." 213811 213812 ^closureOrNil isClosure! ! 213813 213814!MethodContext methodsFor: 'accessing'! 213815method 213816 213817 ^method! ! 213818 213819!MethodContext methodsFor: 'accessing' stamp: 'eem 7/22/2008 11:58'! 213820methodReturnContext 213821 "Answer the context from which an ^-return should return from." 213822 213823 closureOrNil == nil ifTrue: 213824 [^self]. 213825 ^closureOrNil outerContext methodReturnContext! ! 213826 213827!MethodContext methodsFor: 'accessing' stamp: 'eem 7/22/2008 11:58'! 213828outerContext 213829 "Answer the context within which the receiver is nested." 213830 213831 ^closureOrNil == nil ifFalse: 213832 [closureOrNil outerContext]! ! 213833 213834!MethodContext methodsFor: 'accessing'! 213835receiver 213836 "Refer to the comment in ContextPart|receiver." 213837 213838 ^receiver! ! 213839 213840!MethodContext methodsFor: 'accessing'! 213841removeSelf 213842 "Nil the receiver pointer and answer its former value." 213843 213844 | tempSelf | 213845 tempSelf := receiver. 213846 receiver := nil. 213847 ^tempSelf! ! 213848 213849!MethodContext methodsFor: 'accessing' stamp: 'eem 8/20/2008 09:28'! 213850tempAt: index 213851 "Answer the value of the temporary variable whose index is the 213852 argument, index. Primitive. Assumes receiver is indexable. Answer the 213853 value of an indexable element in the receiver. Fail if the argument index 213854 is not an Integer or is out of bounds. Essential. See Object documentation 213855 whatIsAPrimitive. Override the default at: primitive to give latitude to the 213856 VM in context management." 213857 213858 <primitive: 210> 213859 ^self at: index! ! 213860 213861!MethodContext methodsFor: 'accessing' stamp: 'eem 8/20/2008 09:29'! 213862tempAt: index put: value 213863 "Store the argument, value, as the temporary variable whose index is the 213864 argument, index. Primitive. Assumes receiver is indexable. Answer the 213865 value of an indexable element in the receiver. Fail if the argument index 213866 is not an Integer or is out of bounds. Essential. See Object documentation 213867 whatIsAPrimitive. Override the default at:put: primitive to give latitude to 213868 the VM in context management." 213869 213870 <primitive: 211> 213871 ^self at: index put: value! ! 213872 213873!MethodContext methodsFor: 'accessing' stamp: 'md 2/9/2007 19:06'! 213874tempNamed: aName 213875 ^self tempAt: (self tempNames indexOf: aName)! ! 213876 213877!MethodContext methodsFor: 'accessing' stamp: 'md 2/9/2007 19:07'! 213878tempNamed: aName put: anObject 213879 ^self tempAt: (self tempNames indexOf: aName) put: anObject! ! 213880 213881 213882!MethodContext methodsFor: 'closure support' stamp: 'md 1/20/2006 17:17'! 213883asContext 213884 213885 ^ self! ! 213886 213887!MethodContext methodsFor: 'closure support' stamp: 'md 2/20/2006 20:38'! 213888capturedTempNames 213889 213890 ^ self methodNode scope capturedVars collect: [:var | var name]! ! 213891 213892!MethodContext methodsFor: 'closure support' stamp: 'ar 6/28/2003 00:15'! 213893contextTag 213894 "Context tags may be used for referring to contexts instead of contexts themselves as they can be copied and will continue to work in other processes (continuations). By default, we use the context itself to as its tag." 213895 ^self! ! 213896 213897!MethodContext methodsFor: 'closure support' stamp: 'md 2/20/2006 20:38'! 213898doItScope 213899 "scope (environment) for expressions executed within a method context. self will be the receiver of the do-it method. We want temp vars directly accessible" 213900 213901 ^ self methodNode scope asDoItScope! ! 213902 213903!MethodContext methodsFor: 'closure support' stamp: 'md 2/20/2006 20:38'! 213904freeNames 213905 213906 ^ self methodNode freeNames! ! 213907 213908!MethodContext methodsFor: 'closure support' stamp: 'damiencassou 5/30/2008 10:56'! 213909freeNamesAndValues 213910 | aStream eval | 213911 eval := 213912 [ :string | 213913 self class evaluatorClass new 213914 evaluate2: string readStream 213915 in: self 213916 to: nil 213917 notifying: nil 213918 ifFail: 213919 [ "fix this" 213920 self error: 'bug' ] 213921 logged: false ]. 213922 aStream := '' writeStream. 213923 self freeNames doWithIndex: 213924 [ :name :index | 213925 aStream 213926 nextPutAll: name; 213927 nextPut: $:; 213928 space; 213929 tab. 213930 (eval value: name) printOn: aStream. 213931 aStream cr ]. 213932 ^ aStream contents! ! 213933 213934!MethodContext methodsFor: 'closure support' stamp: 'md 1/20/2006 17:16'! 213935isClosureContext 213936 213937 ^ self isExecutingBlock! ! 213938 213939 213940!MethodContext methodsFor: 'initialize-release' stamp: 'ajh 1/23/2003 20:27'! 213941privRefresh 213942 "Reinitialize the receiver so that it is in the state it was at its creation." 213943 213944 pc := method initialPC. 213945 self stackp: method numTemps. 213946 method numArgs+1 to: method numTemps 213947 do: [:i | self tempAt: i put: nil]! ! 213948 213949!MethodContext methodsFor: 'initialize-release' stamp: 'eem 8/22/2008 09:57'! 213950privRefreshWith: aCompiledMethod 213951 "Reinitialize the receiver as though it had been for a different method. 213952 Used by a Debugger when one of the methods to which it refers is 213953 recompiled." 213954 213955 aCompiledMethod isCompiledMethod ifFalse: 213956 [self error: 'method can only be set to aCompiledMethod']. 213957 method := aCompiledMethod. 213958 self assert: closureOrNil == nil. 213959 "was: receiverMap := nil." 213960 self privRefresh! ! 213961 213962 213963!MethodContext methodsFor: 'instruction decoding (closures)' stamp: 'eem 7/22/2008 11:56'! 213964blockReturnTop 213965 "Simulate the interpreter's action when a ReturnTopOfStackToCaller bytecode is 213966 encountered in the receiver. This should only happen in a closure activation." 213967 self assert: closureOrNil isClosure. 213968 ^self return: self pop from: self! ! 213969 213970!MethodContext methodsFor: 'instruction decoding (closures)' stamp: 'eem 5/30/2008 18:40'! 213971pushConsArrayWithElements: numElements 213972 | array | 213973 array := Array new: numElements. 213974 numElements to: 1 by: -1 do: 213975 [:i| 213976 array at: i put: self pop]. 213977 self push: array! ! 213978 213979 213980!MethodContext methodsFor: 'printing' stamp: 'tk 10/19/2001 11:34'! 213981printDetails: strm 213982 "Put my class>>selector and instance variables and arguments and temporaries on the stream. Protect against errors during printing." 213983 213984 | pe str pos | 213985 self printOn: strm. 213986 strm cr. 213987 strm tab; nextPutAll: 'Receiver: '. 213988 pe := '<<error during printing>>'. 213989 strm nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [:err :rcvr | pe]). 213990 213991 strm cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr. 213992 str := [(self tempsAndValuesLimitedTo: 80 indent: 2) 213993 padded: #right to: 1 with: $x] ifError: [:err :rcvr | pe]. 213994 strm nextPutAll: (str allButLast). 213995 213996 strm cr; tab; nextPutAll: 'Receiver''s instance variables: '; cr. 213997 pos := strm position. 213998 [receiver longPrintOn: strm limitedTo: 80 indent: 2] ifError: [:err :rcvr | 213999 strm nextPutAll: pe]. 214000 pos = strm position ifTrue: ["normal printString for an Array (it has no inst vars)" 214001 strm nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [:err :rcvr | pe])]. 214002 strm peekLast == Character cr ifFalse: [strm cr].! ! 214003 214004!MethodContext methodsFor: 'printing' stamp: 'eem 5/27/2008 17:23'! 214005printOn: aStream 214006 214007 self outerContext 214008 ifNil: [super printOn: aStream] 214009 ifNotNil: 214010 [:outerContext| 214011 aStream nextPutAll: '[] in '. 214012 outerContext printOn: aStream]! ! 214013 214014!MethodContext methodsFor: 'printing' stamp: 'mvl 3/13/2007 11:40'! 214015printString 214016 "Answer an emphasized string in case of a breakpoint method" 214017 214018 ^(self method notNil and: [self method hasBreakpoint]) 214019 ifTrue:[(super printString , ' [break]') asText allBold] 214020 ifFalse:[super printString]! ! 214021 214022 214023!MethodContext methodsFor: 'system simulation' stamp: 'eem 9/3/2008 13:58'! 214024pushArgs: args "<Array>" from: sendr "<ContextPart>" 214025 "Helps simulate action of the value primitive for closures. 214026 This is used by ContextPart>>runSimulated:contextAtEachStep:" 214027 214028 stackp ~= 0 ifTrue: 214029 [self error: 'stack pointer should be zero!!']. 214030 closureOrNil ifNil: 214031 [self error: 'context needs a closure!!']. 214032 args do: [:arg| self push: arg]. 214033 1 to: closureOrNil numCopiedValues do: 214034 [:i| 214035 self push: (closureOrNil copiedValueAt: i)]. 214036 sender := sendr! ! 214037 214038 214039!MethodContext methodsFor: 'private' stamp: 'eem 6/15/2008 11:27'! 214040aboutToReturn: result through: firstUnwindContext 214041 "Called from VM when an unwindBlock is found between self and its home. 214042 Return to home's sender, executing unwind blocks on the way." 214043 214044 self methodReturnContext return: result! ! 214045 214046!MethodContext methodsFor: 'private' stamp: 'di 1/14/1999 22:30'! 214047instVarAt: index put: value 214048 index = 3 ifTrue: [self stackp: value. ^ value]. 214049 ^ super instVarAt: index put: value! ! 214050 214051!MethodContext methodsFor: 'private' stamp: 'eem 7/22/2008 11:59'! 214052setSender: s receiver: r method: m arguments: args 214053 "Create the receiver's initial state." 214054 214055 sender := s. 214056 receiver := r. 214057 method := m. 214058 closureOrNil := nil. 214059 pc := method initialPC. 214060 self stackp: method numTemps. 214061 1 to: args size do: [:i | self at: i put: (args at: i)]! ! 214062 214063!MethodContext methodsFor: 'private' stamp: 'eem 7/22/2008 12:00'! 214064setSender: s receiver: r method: m closure: c startpc: startpc 214065 "Create the receiver's initial state." 214066 214067 sender := s. 214068 receiver := r. 214069 method := m. 214070 closureOrNil := c. 214071 pc := startpc. 214072 stackp := 0! ! 214073 214074!MethodContext methodsFor: 'private' stamp: 'eem 7/22/2008 12:00'! 214075startpc 214076 ^closureOrNil 214077 ifNil: [self method initialPC] 214078 ifNotNil: [closureOrNil startpc]! ! 214079 214080 214081!MethodContext methodsFor: 'private-debugger' stamp: 'tfei 3/19/2000 23:55'! 214082cachedStackTop 214083 "WARNING - this method depends on a very dirty trick, viz. snitching information off the variable stack of a particular CompiledMethod. So if you add/remove a temp in BlockContext>>valueUninterruptably, this method will fail, probably with some horrible consequences I'd rather not think through just now ... assumption is that the variable declaration in that method looks like: 214084 | sendingContext result homeSender |" 214085 214086 ^self tempAt: 3! ! 214087 214088 214089!MethodContext methodsFor: 'private-exceptions' stamp: 'eem 2/7/2009 18:07'! 214090cannotReturn: result 214091 214092 closureOrNil notNil ifTrue: 214093 [^self cannotReturn: result to: self home sender]. 214094 ToolSet 214095 debugContext: thisContext 214096 label: 'computation has been terminated' 214097 contents: nil! ! 214098 214099!MethodContext methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 22:05'! 214100isHandlerContext 214101"is this context for method that is marked?" 214102 ^method primitive = 199! ! 214103 214104!MethodContext methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 22:05'! 214105isUnwindContext 214106"is this context for method that is marked?" 214107 ^method primitive = 198! ! 214108 214109!MethodContext methodsFor: 'private-exceptions' stamp: 'tfei 3/23/1999 13:00'! 214110receiver: r 214111 214112 receiver := r! ! 214113 214114!MethodContext methodsFor: 'private-exceptions' stamp: 'ar 6/28/2003 00:10'! 214115restartWithNewReceiver: obj 214116 214117 self 214118 swapReceiver: obj; 214119 restart! ! 214120 214121!MethodContext methodsFor: 'private-exceptions' stamp: 'ajh 10/8/2001 23:56'! 214122swapReceiver: r 214123 214124 receiver := r! ! 214125 214126"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 214127 214128MethodContext class 214129 instanceVariableNames: ''! 214130 214131!MethodContext class methodsFor: 'closure support' stamp: 'md 2/20/2006 20:41'! 214132myEnvFieldIndex 214133 214134 ^ self allInstVarNames indexOf: 'receiverMap'! ! 214135 214136 214137!MethodContext class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:06'! 214138sender: s receiver: r method: m arguments: args 214139 "Answer an instance of me with attributes set to the arguments." 214140 214141 ^(self newForMethod: m) setSender: s receiver: r method: m arguments: args! ! 214142TestCase subclass: #MethodContextTest 214143 instanceVariableNames: 'aCompiledMethod aReceiver aMethodContext aSender' 214144 classVariableNames: '' 214145 poolDictionaries: '' 214146 category: 'KernelTests-Methods'! 214147!MethodContextTest commentStamp: 'tlk 5/31/2004 16:07' prior: 0! 214148I am an SUnit Test of MethodContext and its super type, ContextPart. See also BlockContextTest. 214149See pages 430-437 of A. Goldberg and D. Robson's Smalltalk-80 The Language (aka the purple book), which deal with Contexts. My fixtures are from their example. (The Squeak byte codes are not quite the same as Smalltalk-80.) 214150My fixtures are: 214151aReceiver - just some arbitrary object, "Rectangle origin: 100@100 corner: 200@200" 214152aSender - just some arbitrary object, thisContext 214153aCompiledMethod - just some arbitrary method, "Rectangle rightCenter". 214154aMethodContext - just some arbitray context ... 214155 214156! 214157 214158 214159!MethodContextTest methodsFor: 'running' stamp: 'tlk 5/31/2004 16:18'! 214160setUp 214161 super setUp. 214162 aCompiledMethod := Rectangle methodDict at: #rightCenter. 214163 aReceiver := 100@100 corner: 200@200. 214164 aSender := thisContext. 214165 aMethodContext := MethodContext sender: aSender receiver: aReceiver method: aCompiledMethod arguments: #(). ! ! 214166 214167 214168!MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/30/2004 13:35'! 214169testActivateReturnValue 214170 self assert: ((aSender activateReturn: aMethodContext value: #()) isKindOf: MethodContext). 214171 self assert: ((aSender activateReturn: aMethodContext value: #()) receiver = aMethodContext).! ! 214172 214173!MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 17:10'! 214174testFindContextSuchThat 214175 self assert: (aMethodContext findContextSuchThat: [:each| true]) printString = aMethodContext printString. 214176 self assert: (aMethodContext hasContext: aMethodContext). ! ! 214177 214178!MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/30/2004 10:57'! 214179testMethodContext 214180 self deny: aMethodContext isPseudoContext. 214181 self assert: aMethodContext home notNil. 214182 self assert: aMethodContext receiver notNil. 214183 self assert: (aMethodContext method isKindOf: CompiledMethod).! ! 214184 214185!MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 17:08'! 214186testMethodIsBottomContext 214187 self assert: aMethodContext bottomContext = aSender. 214188 self assert: aMethodContext secondFromBottom = aMethodContext.! ! 214189 214190!MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 16:55'! 214191testReturn 214192 "Why am I overriding setUp? Because sender must be thisContext, i.e, testReturn, not setUp." 214193 aMethodContext := MethodContext sender: thisContext receiver: aReceiver method: aCompiledMethod arguments: #(). 214194 self assert: (aMethodContext return: 5) = 5.! ! 214195 214196!MethodContextTest methodsFor: 'tests' stamp: 'pmm 7/4/2009 15:45'! 214197testSetUp 214198 "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'" 214199 self deny: aMethodContext isPseudoContext. 214200 self deny: aMethodContext isDead. 214201 self assert: aMethodContext home = aMethodContext. 214202 self assert: aMethodContext receiver = aReceiver. 214203 self assert: (aMethodContext method isKindOf: CompiledMethod). 214204 self assert: aMethodContext method = aCompiledMethod. 214205 self assert: aMethodContext methodNode selector = #rightCenter. 214206 self assert: aMethodContext client printString = 'MethodContextTest>>#testSetUp'. 214207! ! 214208 214209!MethodContextTest methodsFor: 'tests' stamp: 'md 2/9/2007 19:06'! 214210testTempNamed 214211 | oneTemp | 214212 214213 oneTemp := 1. 214214 self assert: (thisContext tempNamed: 'oneTemp') = oneTemp. 214215 ! ! 214216 214217!MethodContextTest methodsFor: 'tests' stamp: 'md 2/9/2007 19:08'! 214218testTempNamedPut 214219 | oneTemp | 214220 214221 oneTemp := 1. 214222 self assert: (thisContext tempNamed: 'oneTemp') = oneTemp. 214223 thisContext tempNamed: 'oneTemp' put: 2. 214224 self assert: (thisContext tempNamed: 'oneTemp') = 2.! ! 214225Dictionary variableSubclass: #MethodDictionary 214226 instanceVariableNames: '' 214227 classVariableNames: '' 214228 poolDictionaries: '' 214229 category: 'Kernel-Methods'! 214230!MethodDictionary commentStamp: '<historical>' prior: 0! 214231I am just like a normal Dictionary, except that I am implemented differently. Each Class has an instances of MethodDictionary to hold the correspondence between selectors (names of methods) and methods themselves. 214232 214233In a normal Dictionary, the instance variable 'array' holds an array of Associations. Since there are thousands of methods in the system, these Associations waste space. 214234 214235Each MethodDictionary is a variable object, with the list of keys (selector Symbols) in the variable part of the instance. The variable 'array' holds the values, which are CompiledMethods.! 214236 214237 214238!MethodDictionary methodsFor: 'accessing'! 214239add: anAssociation 214240 ^ self at: anAssociation key put: anAssociation value! ! 214241 214242!MethodDictionary methodsFor: 'accessing'! 214243at: key ifAbsent: aBlock 214244 214245 | index | 214246 index := self findElementOrNil: key. 214247 (self basicAt: index) == nil ifTrue: [ ^ aBlock value ]. 214248 ^ array at: index! ! 214249 214250!MethodDictionary methodsFor: 'accessing' stamp: 'ar 10/12/2000 17:25'! 214251at: key put: value 214252 "Set the value at key to be value." 214253 | index | 214254 index := self findElementOrNil: key. 214255 (self basicAt: index) == nil 214256 ifTrue: 214257 [tally := tally + 1. 214258 self basicAt: index put: key] 214259 ifFalse: 214260 [(array at: index) flushCache]. 214261 array at: index put: value. 214262 self fullCheck. 214263 ^ value! ! 214264 214265!MethodDictionary methodsFor: 'accessing' stamp: 'tk 6/30/2000 00:14'! 214266includesKey: aSymbol 214267 "This override assumes that pointsTo is a fast primitive" 214268 214269 aSymbol ifNil: [^ false]. 214270 ^ super pointsTo: aSymbol! ! 214271 214272!MethodDictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:17'! 214273keyAtIdentityValue: value ifAbsent: exceptionBlock 214274 "Answer the key whose value equals the argument, value. If there is 214275 none, answer the result of evaluating exceptionBlock." 214276 | theKey | 214277 1 to: self basicSize do: 214278 [:index | 214279 value == (array at: index) 214280 ifTrue: 214281 [(theKey := self basicAt: index) == nil 214282 ifFalse: [^ theKey]]]. 214283 ^ exceptionBlock value! ! 214284 214285!MethodDictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:00'! 214286keyAtValue: value ifAbsent: exceptionBlock 214287 "Answer the key whose value equals the argument, value. If there is 214288 none, answer the result of evaluating exceptionBlock." 214289 | theKey | 214290 1 to: self basicSize do: 214291 [:index | 214292 value = (array at: index) 214293 ifTrue: 214294 [(theKey := self basicAt: index) == nil 214295 ifFalse: [^ theKey]]]. 214296 ^ exceptionBlock value! ! 214297 214298!MethodDictionary methodsFor: 'accessing' stamp: 'NS 3/30/2004 13:42'! 214299keys 214300 "Since method all method selectors are symbols it is more efficient 214301 to use an IdentitySet rather than a Set." 214302 | aSet | 214303 aSet := IdentitySet new: self size. 214304 self keysDo: [:key | aSet add: key]. 214305 ^ aSet! ! 214306 214307 214308!MethodDictionary methodsFor: 'enumeration'! 214309associationsDo: aBlock 214310 | key | 214311 tally = 0 ifTrue: [^ self]. 214312 1 to: self basicSize do: 214313 [:i | (key := self basicAt: i) == nil ifFalse: 214314 [aBlock value: (Association key: key 214315 value: (array at: i))]]! ! 214316 214317!MethodDictionary methodsFor: 'enumeration' stamp: 'adrian-lienhard 6/4/2009 21:27'! 214318do: aBlock 214319 ^ self valuesDo: aBlock! ! 214320 214321!MethodDictionary methodsFor: 'enumeration' stamp: 'ar 7/11/1999 08:05'! 214322keysAndValuesDo: aBlock 214323 "Enumerate the receiver with all the keys and values passed to the block" 214324 | key | 214325 tally = 0 ifTrue: [^ self]. 214326 1 to: self basicSize do: 214327 [:i | (key := self basicAt: i) == nil ifFalse: 214328 [aBlock value: key value: (array at: i)] 214329 ]! ! 214330 214331!MethodDictionary methodsFor: 'enumeration'! 214332keysDo: aBlock 214333 | key | 214334 tally = 0 ifTrue: [^ self]. 214335 1 to: self basicSize do: 214336 [:i | (key := self basicAt: i) == nil 214337 ifFalse: [aBlock value: key]]! ! 214338 214339!MethodDictionary methodsFor: 'enumeration' stamp: 'ar 7/11/1999 07:29'! 214340valuesDo: aBlock 214341 | value | 214342 tally = 0 ifTrue: [^ self]. 214343 1 to: self basicSize do: 214344 [:i | (value := array at: i) == nil 214345 ifFalse: [aBlock value: value]]! ! 214346 214347 214348!MethodDictionary methodsFor: 'removing'! 214349removeKey: key ifAbsent: errorBlock 214350 "The interpreter might be using this MethodDict while 214351 this method is running!! Therefore we perform the removal 214352 in a copy, and then atomically become that copy" 214353 | copy | 214354 copy := self copy. 214355 copy removeDangerouslyKey: key ifAbsent: [^ errorBlock value]. 214356 self become: copy! ! 214357 214358!MethodDictionary methodsFor: 'removing' stamp: 'raa 5/30/2001 15:19'! 214359removeKeyNoBecome: key 214360 214361 "The interpreter might be using this MethodDict while 214362 this method is running!! Therefore we perform the removal 214363 in a copy, and then return the copy for subsequent installation" 214364 214365 | copy | 214366 copy := self copy. 214367 copy removeDangerouslyKey: key ifAbsent: [^ self]. 214368 ^copy! ! 214369 214370 214371!MethodDictionary methodsFor: 'private' stamp: 'tk 8/21/97 16:26'! 214372copy 214373 ^ self shallowCopy withArray: array shallowCopy! ! 214374 214375!MethodDictionary methodsFor: 'private' stamp: 'di 11/4/97 20:11'! 214376grow 214377 | newSelf key | 214378 newSelf := self species new: self basicSize. "This will double the size" 214379 1 to: self basicSize do: 214380 [:i | key := self basicAt: i. 214381 key == nil ifFalse: [newSelf at: key put: (array at: i)]]. 214382 self become: newSelf! ! 214383 214384!MethodDictionary methodsFor: 'private'! 214385keyAt: index 214386 214387 ^ self basicAt: index! ! 214388 214389!MethodDictionary methodsFor: 'private'! 214390methodArray 214391 ^ array! ! 214392 214393!MethodDictionary methodsFor: 'private'! 214394rehash 214395 | newSelf key | 214396 newSelf := self species new: self size. 214397 1 to: self basicSize do: 214398 [:i | key := self basicAt: i. 214399 key == nil ifFalse: [newSelf at: key put: (array at: i)]]. 214400 self become: newSelf! ! 214401 214402!MethodDictionary methodsFor: 'private' stamp: 'RAA 12/17/2000 11:11'! 214403rehashWithoutBecome 214404 | newSelf key | 214405 newSelf := self species new: self size. 214406 1 to: self basicSize do: 214407 [:i | key := self basicAt: i. 214408 key == nil ifFalse: [newSelf at: key put: (array at: i)]]. 214409 ^newSelf! ! 214410 214411!MethodDictionary methodsFor: 'private'! 214412removeDangerouslyKey: key ifAbsent: aBlock 214413 "This is not really dangerous. But if normal removal 214414 were done WHILE a MethodDict were being used, the 214415 system might crash. So instead we make a copy, then do 214416 this operation (which is NOT dangerous in a copy that is 214417 not being used), and then use the copy after the removal." 214418 214419 | index element | 214420 index := self findElementOrNil: key. 214421 (self basicAt: index) == nil ifTrue: [ ^ aBlock value ]. 214422 element := array at: index. 214423 array at: index put: nil. 214424 self basicAt: index put: nil. 214425 tally := tally - 1. 214426 self fixCollisionsFrom: index. 214427 ^ element! ! 214428 214429!MethodDictionary methodsFor: 'private' stamp: 'md 10/5/2005 15:43'! 214430scanFor: anObject 214431 "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 214432 | element start finish | 214433 finish := array size. 214434 start := (anObject identityHash \\ finish) + 1. 214435 214436 "Search from (hash mod size) to the end." 214437 start to: finish do: 214438 [:index | ((element := self basicAt: index) == nil or: [element == anObject]) 214439 ifTrue: [^ index ]]. 214440 214441 "Search from 1 to where we started." 214442 1 to: start-1 do: 214443 [:index | ((element := self basicAt: index) == nil or: [element == anObject]) 214444 ifTrue: [^ index ]]. 214445 214446 ^ 0 "No match AND no empty slot"! ! 214447 214448!MethodDictionary methodsFor: 'private'! 214449swap: oneIndex with: otherIndex 214450 | element | 214451 element := self basicAt: oneIndex. 214452 self basicAt: oneIndex put: (self basicAt: otherIndex). 214453 self basicAt: otherIndex put: element. 214454 super swap: oneIndex with: otherIndex. 214455! ! 214456 214457"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 214458 214459MethodDictionary class 214460 instanceVariableNames: ''! 214461 214462!MethodDictionary class methodsFor: 'instance creation' stamp: 'RAA 5/29/2001 09:53'! 214463new 214464 "change the default size to be a bit bigger to help reduce the number of #grows while filing in" 214465 ^self new: 16! ! 214466 214467!MethodDictionary class methodsFor: 'instance creation' stamp: 'nice 4/4/2006 22:09'! 214468new: nElements 214469 "Create a Dictionary large enough to hold nElements without growing. 214470 Note that the basic size must be a power of 2. 214471 It is VITAL (see grow) that size gets doubled if nElements is a power of 2" 214472 | size | 214473 size := 1 bitShift: nElements highBit. 214474 ^ (self basicNew: size) initialize: size! ! 214475Object subclass: #MethodFinder 214476 instanceVariableNames: 'data answers selector argMap thisData mapStage mapList expressions cachedClass cachedArgNum cachedSelectorLists' 214477 classVariableNames: 'AddAndRemove Approved Blocks Dangerous' 214478 poolDictionaries: '' 214479 category: 'Tools-Browser'! 214480!MethodFinder commentStamp: '<historical>' prior: 0! 214481Find a method in the system from a set of examples. Done by brute force, trying every possible selector. Errors are skipped over using ( [3 + 'xyz'] ifError: [^ false] ). 214482Submit an array of the form ((data1 data2) answer (data1 data2) answer). 214483 214484 MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10). 214485 214486answer: 'data1 + data2' 214487 214488More generally, use the brace notation to construct live examples. 214489 214490The program tries data1 as the receiver, and 214491 tries all other permutations of the data for the receiver and args, and 214492 tries leaving out one argument, and 214493 uses all selectors data understands, and 214494 uses all selectors in all od data's superclasses. 214495 214496Floating point values must be precise to 0.01 percent, or (X * 0.0001). 214497 214498If you get an error, you have probably discovered a selector that needs to be removed from the Approved list. See MethodFinder.initialize. Please email the Squeak Team. 214499 214500Only considers 0, 1, 2, and 3 argument messages. The argument data may have 1 to 5 entries, but only a max of 4 used at a time. For now, we only test messages that use given number of args or one fewer. For example, this data (100 true 0.6) would test the receiver plus two args, and the receiver plus one arg, but not any other patterns. 214501 214502Three sets of selectors: Approved, AddAndRemove, and Blocks selectors. When testing a selector in AddAndRemove, deepCopy the receiver. We do not handle selectors that modify an argument (printOn: etc.). Blocks is a set of (selector argNumber) where that argument must be a block. 214503 214504For perform, the selector is tested. It must be in the Approved list. 214505 214506do: is not on the Approved list. It does not produce a result that can be tested. Type 'do' into the upper pane of the Selector Finder to find messages list that. 214507 214508[Later, allow the user to supply a block that tests the answer, not just the literal answer.] 214509 MethodFinder methodFor: { { true. [3]. [4]}. 3}. 214510Later allow this to work without the blocks around 3 and 4.! 214511 214512 214513!MethodFinder methodsFor: 'access' stamp: 'tk 12/29/2000 13:39'! 214514answers 214515 214516 ^ answers! ! 214517 214518!MethodFinder methodsFor: 'access' stamp: 'tk 12/29/2000 13:39'! 214519data 214520 214521 ^ data! ! 214522 214523!MethodFinder methodsFor: 'access' stamp: 'tk 12/29/2000 13:20'! 214524expressions 214525 ^ expressions! ! 214526 214527!MethodFinder methodsFor: 'access' stamp: 'tk 1/4/2001 17:18'! 214528selectors 214529 "Note the inst var does not have an S on the end" 214530 214531 ^ selector! ! 214532 214533 214534!MethodFinder methodsFor: 'arg maps' stamp: 'tk 4/24/1999 19:29'! 214535argMap 214536 ^ argMap ! ! 214537 214538!MethodFinder methodsFor: 'arg maps' stamp: 'tk 5/18/1999 14:46'! 214539makeAllMaps 214540 "Make a giant list of all permutations of the args. To find the function, we will try these permutations of the input data. receiver, args." 214541 214542 | ii | 214543 mapList := Array new: argMap size factorial. 214544 ii := 1. 214545 argMap permutationsDo: [:perm | 214546 mapList at: ii put: perm copy. 214547 ii := ii + 1]. 214548 mapStage := 1. "about to be bumped"! ! 214549 214550!MethodFinder methodsFor: 'arg maps' stamp: 'tk 4/24/1999 19:29'! 214551mapData 214552 "Force the data through the map (permutation) to create the data to test." 214553 214554 thisData := data collect: [:realData | 214555 argMap collect: [:ind | realData at: ind]]. 214556 ! ! 214557 214558!MethodFinder methodsFor: 'arg maps' stamp: 'tk 5/24/1999 16:31'! 214559permuteArgs 214560 "Run through ALL the permutations. First one was as presented." 214561 214562 data first size <= 1 ifTrue: [^ false]. "no other way" 214563 mapList ifNil: [self makeAllMaps]. 214564 mapStage := mapStage + 1. 214565 mapStage > mapList size ifTrue: [^ false]. 214566 argMap := mapList at: mapStage. 214567 self mapData. 214568 ^ true 214569 ! ! 214570 214571!MethodFinder methodsFor: 'arg maps' stamp: 'tk 4/24/1999 19:29'! 214572thisData 214573 ^ thisData ! ! 214574 214575 214576!MethodFinder methodsFor: 'debugging it' stamp: 'ar 4/10/2005 18:48'! 214577test2: anArray 214578 "look for bad association" 214579 214580 anArray do: [:sub | 214581 sub class == Association ifTrue: [ 214582 (#('true' '$a' '2' 'false') includes: sub value printString) ifFalse: [ 214583 self error: 'bad assn']. 214584 (#('3' '5.6' 'x' '''abcd''') includes: sub key printString) ifFalse: [ 214585 self error: 'bad assn']. 214586 ]. 214587 sub class == Array ifTrue: [ 214588 sub do: [:element | 214589 element isString ifTrue: [element first asciiValue < 32 ifTrue: [ 214590 self error: 'store into string in data']]. 214591 element class == Association ifTrue: [ 214592 element value class == Association ifTrue: [ 214593 self error: 'bad assn']]]]. 214594 sub class == Date ifTrue: [sub year isInteger ifFalse: [ 214595 self error: 'stored into input date!!!!']]. 214596 sub class == Dictionary ifTrue: [ 214597 sub size > 0 ifTrue: [ 214598 self error: 'store into dictionary']]. 214599 sub class == OrderedCollection ifTrue: [ 214600 sub size > 4 ifTrue: [ 214601 self error: 'store into OC']]. 214602 ].! ! 214603 214604!MethodFinder methodsFor: 'debugging it' stamp: 'tk 4/24/1999 19:34'! 214605test3 214606 "find the modification of the caracter table" 214607 214608 (#x at: 1) asciiValue = 120 ifFalse: [self error: 'Character table mod'].! ! 214609 214610 214611!MethodFinder methodsFor: 'find a constant' stamp: 'tk 12/29/2000 22:34'! 214612allNumbers 214613 "Return true if all answers and all data are numbers." 214614 214615 answers do: [:aa | aa isNumber ifFalse: [^ false]]. 214616 thisData do: [:vec | 214617 vec do: [:nn | nn isNumber ifFalse: [^ false]]]. 214618 ^ true! ! 214619 214620!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/18/2001 22:45'! 214621const 214622 | const | 214623 "See if (^ constant) is the answer" 214624 214625 "quick test" 214626 ((const := answers at: 1) closeTo: (answers at: 2)) ifFalse: [^ false]. 214627 3 to: answers size do: [:ii | (const closeTo: (answers at: ii)) ifFalse: [^ false]]. 214628 expressions add: '^ ', const printString. 214629 selector add: #yourself. 214630 ^ true! ! 214631 214632!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:49'! 214633constDiv 214634 | const subTest got | 214635 "See if (data1 // C) is the answer" 214636 214637 const := ((thisData at: 1) at: 1) // (answers at: 1). "May not be right!!" 214638 got := (subTest := MethodFinder new copy: self addArg: const) 214639 searchForOne isEmpty not. 214640 got ifFalse: [^ false]. 214641 214642 "replace data2 with const in expressions" 214643 subTest expressions do: [:exp | 214644 expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. 214645 selector addAll: subTest selectors. 214646 ^ true! ! 214647 214648!MethodFinder methodsFor: 'find a constant' stamp: 'md 11/14/2003 16:47'! 214649constEquiv 214650 | const subTest got jj | 214651 "See if (data1 = C) or (data1 ~= C) is the answer" 214652 214653 "quick test" 214654 ((answers at: 1) class superclass == Boolean) ifFalse: [^ false]. 214655 2 to: answers size do: [:ii | 214656 ((answers at: ii) class superclass == Boolean) ifFalse: [^ false]]. 214657 214658 const := (thisData at: 1) at: 1. 214659 got := (subTest := MethodFinder new copy: self addArg: const) 214660 searchForOne isEmpty not. 214661 got ifFalse: ["try other polarity for ~~ " 214662 (jj := answers indexOf: (answers at: 1) not) > 0 ifTrue: [ 214663 const := (thisData at: jj) at: 1. 214664 got := (subTest := MethodFinder new copy: self addArg: const) 214665 searchForOne isEmpty not]]. 214666 got ifFalse: [^ false]. 214667 214668 "replace data2 with const in expressions" 214669 subTest expressions do: [:exp | 214670 expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. 214671 selector addAll: subTest selectors. 214672 ^ true! ! 214673 214674!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:47'! 214675constLinear 214676 | const subTest got denom num slope offset | 214677 "See if (data1 * C1) + C2 is the answer. In the form #(C2 C1) polynomialEval: data1 " 214678 214679 denom := ((thisData at: 2) at: 1) - ((thisData at: 1) at: 1). 214680 denom = 0 ifTrue: [^ false]. "will divide by it" 214681 num := (answers at: 2) - (answers at: 1). 214682 214683 slope := (num asFloat / denom) reduce. 214684 offset := ((answers at: 2) - (((thisData at: 2) at: 1) * slope)) reduce. 214685 214686 const := Array with: offset with: slope. 214687 got := (subTest := MethodFinder new copy: self addArg: const) 214688 searchForOne isEmpty not. 214689 got ifFalse: [^ false]. 214690 214691 "replace data2 with const in expressions" 214692 subTest expressions do: [:exp | 214693 expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. 214694 selector addAll: subTest selectors. 214695 ^ true! ! 214696 214697!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/18/2001 22:46'! 214698constMod 214699 | subTest low | 214700 "See if mod, (data1 \\ C) is the answer" 214701 214702 low := answers max. 214703 low+1 to: low+20 do: [:const | 214704 subTest := MethodFinder new copy: self addArg: const. 214705 (subTest testPerfect: #\\) ifTrue: [ 214706 expressions add: 'data1 \\ ', const printString. 214707 selector add: #\\. 214708 ^ true]]. 214709 ^ false! ! 214710 214711!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:49'! 214712constMult 214713 | const subTest got | 214714 "See if (data1 * C) is the answer" 214715 214716 ((thisData at: 1) at: 1) = 0 ifTrue: [^ false]. 214717 const := ((answers at: 1) asFloat / ((thisData at: 1) at: 1)) reduce. 214718 got := (subTest := MethodFinder new copy: self addArg: const) 214719 searchForOne isEmpty not. 214720 got ifFalse: [^ false]. 214721 214722 "replace data2 with const in expressions" 214723 subTest expressions do: [:exp | 214724 expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. 214725 selector addAll: subTest selectors. 214726 ^ true! ! 214727 214728!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:48'! 214729constPlus 214730 | const subTest got | 214731 "See if (data1 + C) is the answer" 214732 214733 const := (answers at: 1) - ((thisData at: 1) at: 1). 214734 got := (subTest := MethodFinder new copy: self addArg: const) 214735 searchForOne isEmpty not. 214736 got ifFalse: [^ false]. 214737 214738 "replace data2 with const in expressions" 214739 subTest expressions do: [:exp | 214740 expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. 214741 selector addAll: subTest selectors. 214742 ^ true! ! 214743 214744!MethodFinder methodsFor: 'find a constant' stamp: 'tk 4/9/2001 17:59'! 214745constUsingData1Value 214746 | const subTest got | 214747 "See if (data1 <= C) or (data1 >= C) is the answer" 214748 214749 "quick test" 214750 ((answers at: 1) class superclass == Boolean) ifFalse: [^ false]. 214751 2 to: answers size do: [:ii | 214752 ((answers at: ii) class superclass == Boolean) ifFalse: [^ false]]. 214753 214754 thisData do: [:datums | 214755 const := datums first. "use data as a constant!!" 214756 got := (subTest := MethodFinder new copy: self addArg: const) 214757 searchForOne isEmpty not. 214758 got ifTrue: [ 214759 "replace data2 with const in expressions" 214760 subTest expressions do: [:exp | 214761 expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. 214762 selector addAll: subTest selectors. 214763 ^ true]]. 214764 ^ false! ! 214765 214766 214767!MethodFinder methodsFor: 'initialize' stamp: 'damiencassou 5/30/2008 10:56'! 214768cleanInputs: dataAndAnswerString 214769 "Find an remove common mistakes. Complain when ill formed." 214770 | fixed ddd rs places | 214771 ddd := dataAndAnswerString. 214772 fixed := false. 214773 rs := (ddd , ' ') readStream. 214774 places := OrderedCollection new. 214775 214776 [ rs upToAll: '#true'. 214777 rs atEnd ] whileFalse: [ places addFirst: rs position - 4 ]. 214778 places do: 214779 [ :pos | 214780 ddd := ddd 214781 copyReplaceFrom: pos 214782 to: pos 214783 with: ''. 214784 fixed := true ]. "remove #" 214785 rs := ddd readStream. 214786 places := OrderedCollection new. 214787 214788 [ rs upToAll: '#false'. 214789 rs atEnd ] whileFalse: [ places addFirst: rs position - 5 ]. 214790 places do: 214791 [ :pos | 214792 ddd := ddd 214793 copyReplaceFrom: pos 214794 to: pos 214795 with: ''. 214796 fixed := true ]. "remove #" 214797 fixed ifTrue: 214798 [ self inform: '#(true false) are Symbols, not Booleans. 214799Next time use { true. false }.' ]. 214800 fixed := false. 214801 rs := ddd readStream. 214802 places := OrderedCollection new. 214803 214804 [ rs upToAll: '#nil'. 214805 rs atEnd ] whileFalse: [ places addFirst: rs position - 3 ]. 214806 places do: 214807 [ :pos | 214808 ddd := ddd 214809 copyReplaceFrom: pos 214810 to: pos 214811 with: ''. 214812 fixed := true ]. "remove #" 214813 fixed ifTrue: 214814 [ self inform: '#nil is a Symbol, not the authentic UndefinedObject. 214815Next time use nil instead of #nil' ]. 214816 ^ ddd! ! 214817 214818!MethodFinder methodsFor: 'initialize' stamp: 'md 11/14/2003 16:47'! 214819copy: mthFinder addArg: aConstant 214820 | more | 214821 "Copy inputs and answers, add an additional data argument to the inputs. The same constant for every example" 214822 214823 more := Array with: aConstant. 214824 data := mthFinder data collect: [:argList | argList, more]. 214825 answers := mthFinder answers. 214826 self load: nil. 214827! ! 214828 214829!MethodFinder methodsFor: 'initialize' stamp: 'StephaneDucasse 9/15/2009 09:48'! 214830initialize 214831 "The methods we are allowed to use. (MethodFinder new initialize) " 214832 super initialize. 214833 214834 Approved := Set new. 214835 AddAndRemove := Set new. 214836 Blocks := Set new. 214837 "These modify an argument and are not used by the MethodFinder: longPrintOn: printOn: storeOn: sentTo: storeOn:base: printOn:base: absPrintExactlyOn:base: absPrintOn:base: absPrintOn:base:digitCount: writeOn: writeScanOn: possibleVariablesFor:continuedFrom: printOn:format:" 214838 214839"Object" 214840 #("in class, instance creation" chooseUniqueClassName isSystemDefined newFrom: officialClass readCarefullyFrom: 214841"accessing" at: basicAt: basicSize in: size yourself 214842"testing" ifNil: ifNil:ifNotNil: ifNotNil: ifNotNil:ifNil: isColor isFloat isFraction isInMemory isInteger isMorph isNil isNumber isPoint isPseudoContext isText isTransparent isWebBrowser knownName notNil pointsTo: wantsSteps 214843"comparing" = == closeTo: hash identityHash identityHashPrintString ~= ~~ 214844"copying" clone copy shallowCopy 214845"dependents access" canDiscardEdits dependents hasUnacceptedEdits 214846"updating" changed changed: okToChange update: windowIsClosing 214847"printing" fullPrintString isLiteral longPrintString printString storeString stringForReadout stringRepresentation 214848"class membership" class isKindOf: isMemberOf: respondsTo: xxxClass 214849"error handling" 214850"user interface" addModelMenuItemsTo:forMorph:hand: defaultBackgroundColor defaultLabelForInspector fullScreenSize initialExtent modelWakeUp mouseUpBalk: windowActiveOnFirstClick windowReqNewLabel: 214851"system primitives" instVarAt: instVarNamed: 214852"private" 214853"associating" -> 214854"converting" as: asOrderedCollection asString 214855"casing" caseOf: caseOf:otherwise: 214856"binding" bindingOf: 214857"macpal" contentsChanged currentEvent currentHand currentWorld flash instanceVariableValues 214858"flagging" flag: 214859"translation support" "objects from disk" "finalization" ) do: [:sel | Approved add: sel]. 214860 #(at:add: at:modify: at:put: basicAt:put: "NOT instVar:at:" 214861"message handling" perform: perform:orSendTo: perform:with: perform:with:with: perform:with:with:with: perform:withArguments: perform:withArguments:inSuperclass: 214862) do: [:sel | AddAndRemove add: sel]. 214863 214864"Boolean, True, False, UndefinedObject" 214865 #("logical operations" & eqv: not xor: | 214866"controlling" and: ifFalse: ifFalse:ifTrue: ifTrue: ifTrue:ifFalse: or: 214867"copying" 214868"testing" isEmptyOrNil) do: [:sel | Approved add: sel]. 214869 214870"Behavior" 214871 #("initialize-release" 214872"accessing" compilerClass decompilerClass evaluatorClass format methodDict parserClass sourceCodeTemplate subclassDefinerClass 214873"testing" instSize instSpec isBits isBytes isFixed isPointers isVariable isWeak isWords 214874"copying" 214875"printing" defaultNameStemForInstances printHierarchy 214876"creating class hierarchy" 214877"creating method dictionary" 214878"instance creation" basicNew basicNew: new new: 214879"accessing class hierarchy" allSubclasses allSubclassesWithLevelDo:startingLevel: allSuperclasses subclasses superclass withAllSubclasses withAllSuperclasses 214880"accessing method dictionary" allSelectors changeRecordsAt: compiledMethodAt: compiledMethodAt:ifAbsent: firstCommentAt: lookupSelector: selectors selectorsDo: selectorsWithArgs: "slow but useful ->" sourceCodeAt: sourceCodeAt:ifAbsent: sourceMethodAt: sourceMethodAt:ifAbsent: 214881"accessing instances and variables" allClassVarNames allInstVarNames allSharedPools classVarNames instVarNames instanceCount sharedPools someInstance subclassInstVarNames 214882"testing class hierarchy" inheritsFrom: kindOfSubclass 214883"testing method dictionary" canUnderstand: classThatUnderstands: hasMethods includesSelector: whichClassIncludesSelector: whichSelectorsAccess: whichSelectorsReferTo: whichSelectorsReferTo:special:byte: whichSelectorsStoreInto: 214884"enumerating" 214885"user interface" 214886"private" indexIfCompact) do: [:sel | Approved add: sel]. 214887 214888"ClassDescription" 214889 #("initialize-release" 214890"accessing" classVersion isMeta name theNonMetaClass 214891"copying" 214892"printing" classVariablesString instanceVariablesString sharedPoolsString 214893"instance variables" checkForInstVarsOK: 214894"method dictionary" 214895"organization" category organization whichCategoryIncludesSelector: 214896"compiling" acceptsLoggingOfCompilation wantsChangeSetLogging 214897"fileIn/Out" definition 214898"private" ) do: [:sel | Approved add: sel]. 214899 214900"Class" 214901 #("initialize-release" 214902"accessing" classPool 214903"testing" 214904"copying" 214905"class name" 214906"instance variables" 214907"class variables" classVarAt: classVariableAssociationAt: 214908"pool variables" 214909"compiling" 214910"subclass creation" 214911"fileIn/Out" ) do: [:sel | Approved add: sel]. 214912 214913"Metaclass" 214914 #("initialize-release" 214915"accessing" isSystemDefined soleInstance 214916"copying" "instance creation" "instance variables" "pool variables" "class hierarchy" "compiling" 214917"fileIn/Out" nonTrivial ) do: [:sel | Approved add: sel]. 214918 214919"Context, BlockContext" 214920 #(receiver client method receiver tempAt: 214921"debugger access" pc selector sender shortStack sourceCode tempNames tempsAndValues 214922"controlling" "printing" "system simulation" 214923"initialize-release" 214924"accessing" hasMethodReturn home numArgs 214925"evaluating" value value:ifError: value:value: value:value:value: value:value:value:value: valueWithArguments: 214926"controlling" "scheduling" "instruction decoding" "printing" "private" "system simulation" ) do: [:sel | Approved add: sel]. 214927 #(value: "<- Association has it as a store" ) do: [:sel | AddAndRemove add: sel]. 214928 214929"Message" 214930 #("inclass, instance creation" selector: selector:argument: selector:arguments: 214931"accessing" argument argument: arguments sends: 214932"printing" "sending" ) do: [:sel | Approved add: sel]. 214933 #("private" setSelector:arguments:) do: [:sel | AddAndRemove add: sel]. 214934 214935"Magnitude" 214936 #("comparing" < <= > >= between:and: 214937"testing" max: min: min:max: ) do: [:sel | Approved add: sel]. 214938 214939"Date, Time" 214940 #("in class, instance creation" fromDays: fromSeconds: fromString: newDay:month:year: newDay:year: today 214941 "in class, general inquiries" dateAndTimeNow dayOfWeek: daysInMonth:forYear: daysInYear: firstWeekdayOfMonth:year: indexOfMonth: leapYear: nameOfDay: nameOfMonth: 214942"accessing" day leap monthIndex monthName weekday year 214943"arithmetic" addDays: subtractDate: subtractDays: 214944"comparing" 214945"inquiries" dayOfMonth daysInMonth daysInYear daysLeftInYear firstDayOfMonth previous: 214946"converting" asSeconds 214947"printing" mmddyyyy printFormat: 214948"private" weekdayIndex 214949 "in class, instance creation" fromSeconds: now 214950 "in class, general inquiries" dateAndTimeFromSeconds: dateAndTimeNow millisecondClockValue millisecondsToRun: totalSeconds 214951"accessing" hours minutes seconds 214952"arithmetic" addTime: subtractTime: 214953"comparing" 214954"printing" intervalString print24 214955"converting") do: [:sel | Approved add: sel]. 214956 #("private" 214957 ) do: [:sel | AddAndRemove add: sel]. 214958 214959"Number" 214960 #("in class" readFrom:base: 214961"arithmetic" * + - / // \\ abs negated quo: reciprocal rem: 214962"mathematical functions" arcCos arcSin arcTan arcTan: cos exp floorLog: ln log log: raisedTo: raisedToInteger: sin sqrt squared tan 214963"truncation and round off" ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated 214964"comparing" 214965"testing" even isDivisibleBy: isInfinite isNaN isZero negative odd positive sign strictlyPositive 214966"converting" @ asInteger asNumber asPoint asSmallAngleDegrees degreesToRadians radiansToDegrees 214967"intervals" to: to:by: 214968"printing" printStringBase: storeStringBase: ) do: [:sel | Approved add: sel]. 214969 214970"Integer" 214971 #("in class" primesUpTo: 214972"testing" isPowerOfTwo 214973"arithmetic" alignedTo: 214974"comparing" 214975"truncation and round off" atRandom normalize 214976"enumerating" timesRepeat: 214977"mathematical functions" degreeCos degreeSin factorial gcd: lcm: take: 214978"bit manipulation" << >> allMask: anyMask: bitAnd: bitClear: bitInvert bitInvert32 bitOr: bitShift: bitXor: lowBit noMask: 214979"converting" asCharacter asColorOfDepth: asFloat asFraction asHexDigit 214980"printing" asStringWithCommas hex hex8 radix: 214981"system primitives" lastDigit replaceFrom:to:with:startingAt: 214982"private" "benchmarks" ) do: [:sel | Approved add: sel]. 214983 214984"SmallInteger, LargeNegativeInteger, LargePositiveInteger" 214985 #("arithmetic" "bit manipulation" highBit "testing" "comparing" "copying" "converting" "printing" 214986"system primitives" digitAt: digitLength 214987"private" fromString:radix: ) do: [:sel | Approved add: sel]. 214988 #(digitAt:put: ) do: [:sel | AddAndRemove add: sel]. 214989 214990"Float" 214991 #("arithmetic" 214992"mathematical functions" reciprocalFloorLog: reciprocalLogBase2 timesTwoPower: 214993"comparing" "testing" 214994"truncation and round off" exponent fractionPart integerPart significand significandAsInteger 214995"converting" asApproximateFraction asIEEE32BitWord asTrueFraction 214996"copying") do: [:sel | Approved add: sel]. 214997 214998"Fraction, Random" 214999 #(denominator numerator reduced next nextValue) do: [:sel | Approved add: sel]. 215000 #(setNumerator:denominator:) do: [:sel | AddAndRemove add: sel]. 215001 215002"Collection" 215003 #("accessing" anyOne 215004"testing" includes: includesAllOf: includesAnyOf: includesSubstringAnywhere: isEmpty isSequenceable occurrencesOf: 215005"enumerating" collect: collect:thenSelect: count: detect: detect:ifNone: detectMax: detectMin: detectSum: inject:into: reject: select: select:thenCollect: intersection: 215006"converting" asBag asCharacterSet asSet asSortedArray asSortedCollection asSortedCollection: 215007"printing" 215008"private" maxSize 215009"arithmetic" 215010"math functions" average max median min range sum) do: [:sel | Approved add: sel]. 215011 #("adding" add: addAll: addIfNotPresent: 215012"removing" remove: remove:ifAbsent: removeAll: removeAllFoundIn: removeAllSuchThat: remove:ifAbsent:) do: [:sel | AddAndRemove add: sel]. 215013 215014"SequenceableCollection" 215015 #("comparing" hasEqualElements: 215016"accessing" allButFirst allButLast at:ifAbsent: atAll: atPin: atRandom: atWrap: fifth first fourth identityIndexOf: identityIndexOf:ifAbsent: indexOf: indexOf:ifAbsent: indexOf:startingAt:ifAbsent: indexOfSubCollection:startingAt: indexOfSubCollection:startingAt:ifAbsent: last second sixth third 215017"removing" 215018"copying" , copyAfterLast: copyAt:put: copyFrom:to: copyReplaceAll:with: copyReplaceFrom:to:with: copyUpTo: copyUpToLast: copyWith: copyWithout: copyWithoutAll: forceTo:paddingWith: shuffled sortBy: 215019"enumerating" collectWithIndex: findFirst: findLast: pairsCollect: with:collect: withIndexCollect: polynomialEval: 215020"converting" asArray asDictionary asFloatArray asIntegerArray asStringWithCr asWordArray reversed 215021"private" copyReplaceAll:with:asTokens: ) do: [:sel | Approved add: sel]. 215022 #( swap:with:) do: [:sel | AddAndRemove add: sel]. 215023 215024"ArrayedCollection, Bag" 215025 #("private" defaultElement 215026"sorting" isSorted 215027"accessing" cumulativeCounts sortedCounts sortedElements "testing" "adding" add:withOccurrences: "removing" "enumerating" 215028 ) do: [:sel | Approved add: sel]. 215029 #( mergeSortFrom:to:by: sort sort: add: add:withOccurrences: 215030"private" setDictionary ) do: [:sel | AddAndRemove add: sel]. 215031 215032"Other messages that modify the receiver" 215033 #(atAll:put: atAll:putAll: atAllPut: atWrap:put: replaceAll:with: replaceFrom:to:with: removeFirst removeLast) do: [:sel | AddAndRemove add: sel]. 215034 215035 self initialize2. 215036 215037" 215038MethodFinder new initialize. 215039MethodFinder new organizationFiltered: Set 215040" 215041 215042! ! 215043 215044!MethodFinder methodsFor: 'initialize' stamp: 'stephane.ducasse 10/18/2008 21:45'! 215045initialize2 215046 "The methods we are allowed to use. (MethodFinder new initialize) " 215047 215048"Set" 215049 #("in class" sizeFor: 215050"testing" "adding" "removing" "enumerating" 215051"private" array findElementOrNil: 215052"accessing" someElement) do: [:sel | Approved add: sel]. 215053 215054"Dictionary, IdentityDictionary, IdentitySet" 215055 #("accessing" associationAt: associationAt:ifAbsent: at:ifPresent: keyAtIdentityValue: keyAtIdentityValue:ifAbsent: keyAtValue: keyAtValue:ifAbsent: keys 215056"testing" includesKey: ) do: [:sel | Approved add: sel]. 215057 #(removeKey: removeKey:ifAbsent: 215058) do: [:sel | AddAndRemove add: sel]. 215059 215060"LinkedList, Interval, MappedCollection" 215061 #("in class" from:to: from:to:by: 215062"accessing" contents) do: [:sel | Approved add: sel]. 215063 #( 215064"adding" addFirst: addLast:) do: [:sel | AddAndRemove add: sel]. 215065 215066"OrderedCollection, SortedCollection" 215067 #("accessing" after: before: 215068"copying" copyEmpty 215069"adding" growSize 215070"removing" "enumerating" "private" 215071"accessing" sortBlock) do: [:sel | Approved add: sel]. 215072 #("adding" add:after: add:afterIndex: add:before: addAllFirst: addAllLast: addFirst: addLast: 215073"removing" removeAt: removeFirst removeLast 215074"accessing" sortBlock:) do: [:sel | AddAndRemove add: sel]. 215075 215076"Character" 215077 #("in class, instance creation" allCharacters digitValue: new separators 215078 "accessing untypeable characters" backspace cr enter lf linefeed nbsp newPage space tab 215079 "constants" alphabet characterTable 215080"accessing" asciiValue digitValue 215081"comparing" 215082"testing" isAlphaNumeric isDigit isLetter isLowercase isSafeForHTTP isSeparator isSpecial isUppercase isVowel tokenish 215083"copying" 215084"converting" asIRCLowercase asLowercase asUppercase 215085 ) do: [:sel | Approved add: sel]. 215086 215087"String" 215088 #("in class, instance creation" crlf fromPacked: 215089 "primitives" findFirstInString:inSet:startingAt: indexOfAscii:inString:startingAt: "internet" 215090"accessing" byteAt: endsWithDigit findAnySubStr:startingAt: findBetweenSubStrs: findDelimiters:startingAt: findString:startingAt: findString:startingAt:caseSensitive: findTokens: findTokens:includes: findTokens:keep: includesSubString: includesSubstring:caseSensitive: indexOf:startingAt: indexOfAnyOf: indexOfAnyOf:ifAbsent: indexOfAnyOf:startingAt: indexOfAnyOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: skipAnySubStr:startingAt: skipDelimiters:startingAt: startsWithDigit 215091"comparing" alike: beginsWith: caseSensitiveLessOrEqual: charactersExactlyMatching: compare: crc16 endsWith: endsWithAnyOf: sameAs: startingAt:match:startingAt: 215092"copying" copyReplaceTokens:with: padded:to:with: 215093"converting" asByteArray asDate asDisplayText asFileName asLegalSelector asPacked asParagraph asText asTime asUrl asUrlRelativeTo: capitalized compressWithTable: contractTo: correctAgainst: encodeForHTTP initialIntegerOrNil keywords quoted sansPeriodSuffix splitInteger stemAndNumericSuffix substrings surroundedBySingleQuotes truncateWithElipsisTo: withBlanksTrimmed withFirstCharacterDownshifted withNoLineLongerThan: withSeparatorsCompacted withoutLeadingDigits withoutTrailingBlanks 215094"displaying" "printing" 215095"system primitives" compare:with:collated: 215096"Celeste" withCRs 215097"internet" decodeMimeHeader decodeQuotedPrintable unescapePercents withInternetLineEndings withSqueakLineEndings withoutQuoting 215098"testing" isAllSeparators lastSpacePosition 215099"paragraph support" indentationIfBlank: 215100"arithmetic" ) do: [:sel | Approved add: sel]. 215101 #(byteAt:put: translateToLowercase match:) do: [:sel | AddAndRemove add: sel]. 215102 215103"Symbol" 215104 #("in class, private" hasInterned:ifTrue: 215105 "access" morePossibleSelectorsFor: possibleSelectorsFor: selectorsContaining: thatStarts:skipping: 215106"accessing" "comparing" "copying" "converting" "printing" 215107"testing" isInfix isKeyword isPvtSelector isUnary) do: [:sel | Approved add: sel]. 215108 215109"Array" 215110 #("comparing" "converting" evalStrings 215111"printing" "private" hasLiteralSuchThat:) do: [:sel | Approved add: sel]. 215112 215113"Array2D" 215114 #("access" at:at: atCol: atCol:put: atRow: extent extent:fromArray: height width width:height:type:) do: [:sel | Approved add: sel]. 215115 #(at:at:add: at:at:put: atRow:put: ) do: [:sel | AddAndRemove add: sel]. 215116 215117"ByteArray" 215118 #("accessing" doubleWordAt: wordAt: 215119"platform independent access" longAt:bigEndian: shortAt:bigEndian: unsignedLongAt:bigEndian: unsignedShortAt:bigEndian: 215120"converting") do: [:sel | Approved add: sel]. 215121 #(doubleWordAt:put: wordAt:put: longAt:put:bigEndian: shortAt:put:bigEndian: unsignedLongAt:put:bigEndian: unsignedShortAt:put:bigEndian: 215122 ) do: [:sel | AddAndRemove add: sel]. 215123 215124"FloatArray" "Dont know what happens when prims not here" 215125 false ifTrue: [#("accessing" "arithmetic" *= += -= /= 215126"comparing" 215127"primitives-plugin" primAddArray: primAddScalar: primDivArray: primDivScalar: primMulArray: primMulScalar: primSubArray: primSubScalar: 215128"primitives-translated" primAddArray:withArray:from:to: primMulArray:withArray:from:to: primSubArray:withArray:from:to: 215129"converting" "private" "user interface") do: [:sel | Approved add: sel]. 215130 ]. 215131 215132"IntegerArray, WordArray" 215133"RunArray" 215134 #("in class, instance creation" runs:values: scanFrom: 215135"accessing" runLengthAt: 215136"adding" "copying" 215137"private" runs values) do: [:sel | Approved add: sel]. 215138 #(coalesce addLast:times: repeatLast:ifEmpty: repeatLastIfEmpty: 215139 ) do: [:sel | AddAndRemove add: sel]. 215140 215141"Stream -- many operations change its state" 215142 #("testing" atEnd) do: [:sel | Approved add: sel]. 215143 #("accessing" next: nextMatchAll: nextMatchFor: upToEnd 215144next:put: nextPut: nextPutAll: "printing" print: 215145 ) do: [:sel | AddAndRemove add: sel]. 215146 215147"PositionableStream" 215148 #("accessing" contentsOfEntireFile originalContents peek peekFor: "testing" 215149"positioning" position ) do: [:sel | Approved add: sel]. 215150 #(nextDelimited: nextLine upTo: position: reset resetContents setToEnd skip: skipTo: upToAll: ) do: [:sel | AddAndRemove add: sel]. 215151 "Because it is so difficult to test the result of an operation on a Stream (you have to supply another Stream in the same state), we don't support Streams beyond the basics. We want to find the messages that convert Streams to other things." 215152 215153"ReadWriteStream" 215154 #("file status" closed) do: [:sel | Approved add: sel]. 215155 #("accessing" next: on: ) do: [:sel | AddAndRemove add: sel]. 215156 215157"WriteStream" 215158 #("in class, instance creation" on:from:to: with: with:from:to: 215159 ) do: [:sel | Approved add: sel]. 215160 #("positioning" resetToStart 215161"character writing" crtab crtab:) do: [:sel | AddAndRemove add: sel]. 215162 215163"LookupKey, Association, Link" 215164 #("accessing" key nextLink) do: [:sel | Approved add: sel]. 215165 #(key: key:value: nextLink:) do: [:sel | AddAndRemove add: sel]. 215166 215167"Point" 215168 #("in class, instance creation" r:degrees: x:y: 215169"accessing" x y "comparing" "arithmetic" "truncation and round off" 215170"polar coordinates" degrees r theta 215171"point functions" bearingToPoint: crossProduct: dist: dotProduct: eightNeighbors flipBy:centerAt: fourNeighbors grid: nearestPointAlongLineFrom:to: nearestPointOnLineFrom:to: normal normalized octantOf: onLineFrom:to: onLineFrom:to:within: quadrantOf: rotateBy:centerAt: transposed unitVector 215172"converting" asFloatPoint asIntegerPoint corner: extent: rect: 215173"transforming" adhereTo: rotateBy:about: scaleBy: scaleFrom:to: translateBy: "copying" 215174"interpolating" interpolateTo:at:) do: [:sel | Approved add: sel]. 215175 215176"Rectangle" 215177 #("in class, instance creation" center:extent: encompassing: left:right:top:bottom: 215178 merging: origin:corner: origin:extent: 215179"accessing" area bottom bottomCenter bottomLeft bottomRight boundingBox center corner corners innerCorners left leftCenter origin right rightCenter top topCenter topLeft topRight 215180"comparing" 215181"rectangle functions" adjustTo:along: amountToTranslateWithin: areasOutside: bordersOn:along: encompass: expandBy: extendBy: forPoint:closestSideDistLen: insetBy: insetOriginBy:cornerBy: intersect: merge: pointNearestTo: quickMerge: rectanglesAt:height: sideNearestTo: translatedToBeWithin: withBottom: withHeight: withLeft: withRight: withSide:setTo: withTop: withWidth: 215182"testing" containsPoint: containsRect: hasPositiveExtent intersects: isTall isWide 215183"truncation and round off" 215184"transforming" align:with: centeredBeneath: newRectFrom: squishedWithin: "copying" 215185 ) do: [:sel | Approved add: sel]. 215186 215187"Color" 215188 #("in class, instance creation" colorFrom: colorFromPixelValue:depth: fromRgbTriplet: gray: h:s:v: r:g:b: r:g:b:alpha: r:g:b:range: 215189 "named colors" black blue brown cyan darkGray gray green lightBlue lightBrown lightCyan lightGray lightGreen lightMagenta lightOrange lightRed lightYellow magenta orange red transparent veryDarkGray veryLightGray veryVeryDarkGray veryVeryLightGray white yellow 215190 "other" colorNames indexedColors pixelScreenForDepth: quickHighLight: 215191"access" alpha blue brightness green hue luminance red saturation 215192"equality" 215193"queries" isBitmapFill isBlack isGray isSolidFill isTranslucent isTranslucentColor 215194"transformations" alpha: dansDarker darker lighter mixed:with: muchLighter slightlyDarker slightlyLighter veryMuchLighter alphaMixed:with: 215195"groups of shades" darkShades: lightShades: mix:shades: wheel: 215196"printing" shortPrintString 215197"other" colorForInsets rgbTriplet 215198"conversions" asB3DColor asColor balancedPatternForDepth: bitPatternForDepth: closestPixelValue1 closestPixelValue2 closestPixelValue4 closestPixelValue8 dominantColor halfTonePattern1 halfTonePattern2 indexInMap: pixelValueForDepth: pixelWordFor:filledWith: pixelWordForDepth: scaledPixelValue32 215199"private" privateAlpha privateBlue privateGreen privateRGB privateRed "copying" 215200 ) do: [:sel | Approved add: sel]. 215201 215202" For each selector that requires a block argument, add (selector argNum) 215203 to the set Blocks." 215204"ourClasses := #(Object Boolean True False UndefinedObject Behavior ClassDescription Class Metaclass MethodContext BlockContext Message Magnitude Date Time Number Integer SmallInteger LargeNegativeInteger LargePositiveInteger Float Fraction Random Collection SequenceableCollection ArrayedCollection Bag Set Dictionary IdentityDictionary IdentitySet LinkedList Interval MappedCollection OrderedCollection SortedCollection Character String Symbol Array Array2D ByteArray FloatArray IntegerArray WordArray RunArray Stream PositionableStream ReadWriteStream WriteStream LookupKey Association Link Point Rectangle Color). 215205ourClasses do: [:clsName | cls := Smalltalk at: clsName. 215206 (cls selectors) do: [:aSel | 215207 ((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [ 215208 (cls formalParametersAt: aSel) withIndexDo: [:tName :ind | 215209 (tName endsWith: 'Block') ifTrue: [ 215210 Blocks add: (Array with: aSel with: ind)]]]]]. 215211" 215212#((timesRepeat: 1 ) (indexOf:ifAbsent: 2 ) (pairsCollect: 1 ) (mergeSortFrom:to:by: 3 ) (ifNotNil:ifNil: 1 ) (ifNotNil:ifNil: 2 ) (ifNil: 1 ) (at:ifAbsent: 2 ) (ifNil:ifNotNil: 1 ) (ifNil:ifNotNil: 2 ) (ifNotNil: 1 ) (at:modify: 2 ) (identityIndexOf:ifAbsent: 2 ) (sort: 1 ) (sortBlock: 1 ) (detectMax: 1 ) (repeatLastIfEmpty: 1 ) (allSubclassesWithLevelDo:startingLevel: 1 ) (keyAtValue:ifAbsent: 2 ) (in: 1 ) (ifTrue: 1 ) (or: 1 ) (select: 1 ) (inject:into: 2 ) (forPoint:closestSideDistLen: 2 ) (value:ifError: 2 ) (selectorsDo: 1 ) (removeAllSuchThat: 1 ) (keyAtIdentityValue:ifAbsent: 2 ) (detectMin: 1 ) (detect:ifNone: 1 ) (ifTrue:ifFalse: 1 ) (ifTrue:ifFalse: 2 ) (detect:ifNone: 2 ) (hasLiteralSuchThat: 1 ) (indexOfAnyOf:ifAbsent: 2 ) (reject: 1 ) (newRectFrom: 1 ) (removeKey:ifAbsent: 2 ) (at:ifPresent: 2 ) (associationAt:ifAbsent: 2 ) (withIndexCollect: 1 ) (repeatLast:ifEmpty: 2 ) (findLast: 1 ) (indexOf:startingAt:ifAbsent: 3 ) (remove:ifAbsent: 2 ) (ifFalse:ifTrue: 1 ) (ifFalse:ifTrue: 2 ) (caseOf:otherwise: 2 ) (count: 1 ) (collect: 1 ) (sortBy: 1 ) (and: 1 ) (asSortedCollection: 1 ) (with:collect: 2 ) (sourceCodeAt:ifAbsent: 2 ) (detect: 1 ) (collectWithIndex: 1 ) (compiledMethodAt:ifAbsent: 2 ) (detectSum: 1 ) (indexOfSubCollection:startingAt:ifAbsent: 3 ) (findFirst: 1 ) (sourceMethodAt:ifAbsent: 2 ) (collect:thenSelect: 1 ) (collect:thenSelect: 2 ) (select:thenCollect: 1 ) (select:thenCollect: 2 ) (ifFalse: 1 ) (indexOfAnyOf:startingAt:ifAbsent: 3 ) (indentationIfBlank: 1 ) ) do: [:anArray | 215213 Blocks add: anArray]. 215214 215215self initialize3. 215216 215217" 215218MethodFinder new initialize. 215219MethodFinder new organizationFiltered: TranslucentColor class 215220" 215221"Do not forget class messages for each of these classes" 215222! ! 215223 215224!MethodFinder methodsFor: 'initialize' stamp: 'tk 4/1/2002 11:33'! 215225initialize3 215226 "additional selectors to consider" 215227 215228#(asWords threeDigitName ) do: [:sel | Approved add: sel].! ! 215229 215230!MethodFinder methodsFor: 'initialize' stamp: 'tk 12/29/2000 13:22'! 215231load: dataWithAnswers 215232 "Find a function that takes the data and gives the answers. Odd list entries are data for it, even ones are the answers. nil input means data and answers were supplied already." 215233" (MethodFinder new) load: #( (4 3) 7 (-10 5) -5 (-3 11) 8); 215234 findMessage " 215235 215236dataWithAnswers ifNotNil: [ 215237 data := Array new: dataWithAnswers size // 2. 215238 1 to: data size do: [:ii | data at: ii put: (dataWithAnswers at: ii*2-1)]. 215239 answers := Array new: data size. 215240 1 to: answers size do: [:ii | answers at: ii put: (dataWithAnswers at: ii*2)]]. 215241data do: [:list | 215242 (list isKindOf: SequenceableCollection) ifFalse: [ 215243 ^ self inform: 'first and third items are not Arrays']. 215244 ]. 215245argMap := (1 to: data first size) asArray. 215246data do: [:list | list size = argMap size ifFalse: [ 215247 self inform: 'data arrays must all be the same size']]. 215248argMap size > 4 ifTrue: [self inform: 'No more than a receiver and 215249three arguments allowed']. 215250 "Really only test receiver and three args." 215251thisData := data copy. 215252mapStage := mapList := nil. 215253! ! 215254 215255!MethodFinder methodsFor: 'initialize' stamp: 'torsten.bergmann 12/16/2008 12:52'! 215256noteDangerous 215257 "Remember the methods with really bad side effects." 215258 215259 Dangerous := Set new. 215260"Object accessing, testing, copying, dependent access, macpal, flagging" 215261 #(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit) 215262 do: [:sel | Dangerous add: sel]. 215263 215264"Object error handling" 215265 #(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility) 215266 do: [:sel | Dangerous add: sel]. 215267 215268"Object user interface" 215269 #(basicInspect inform: inspect inspectWithLabel: notYetImplemented inspectElement ) 215270 do: [:sel | Dangerous add: sel]. 215271 215272"Object system primitives" 215273 #(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:) 215274 do: [:sel | Dangerous add: sel]. 215275 215276"Object private" 215277 #(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:) 215278 do: [:sel | Dangerous add: sel]. 215279 215280"Object, translation support" 215281 #(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:) 215282 do: [:sel | Dangerous add: sel]. 215283 215284"Object, objects from disk, finalization. And UndefinedObject" 215285 #(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until: suspend) 215286 do: [:sel | Dangerous add: sel]. 215287 215288"No Restrictions: Boolean, False, True, " 215289 215290"Morph" 215291 #() 215292 do: [:sel | Dangerous add: sel]. 215293 215294"Behavior" 215295 #(obsolete confirmRemovalOf: copyOfMethodDictionary literalScannedAs:notifying: storeLiteral:on: addSubclass: removeSubclass: superclass: 215296"creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo: 215297 "too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables 215298"private" becomeCompact becomeUncompact flushCache format:variable:words:pointers: format:variable:words:pointers:weak: printSubclassesOn:level: basicRemoveSelector: addSelector:withMethod:notifying: addSelectorSilently:withMethod:) 215299 do: [:sel | Dangerous add: sel]. 215300 215301"CompiledMethod" 215302 #(defaultSelector) 215303 do: [:sel | Dangerous add: sel]. 215304 215305"Others " 215306 #("no tangible result" do: associationsDo: 215307"private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: doWithIndex: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser) 215308 do: [:sel | Dangerous add: sel]. 215309 215310 215311 #( fileOutPrototype addSpareFields makeFileOutFile ) 215312 do: [:sel | Dangerous add: sel]. 215313 #(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: instanceVariableNames: ) 215314 do: [:sel | Dangerous add: sel]. 215315 215316 ! ! 215317 215318!MethodFinder methodsFor: 'initialize' stamp: 'tk 4/14/1999 11:16'! 215319organizationFiltered: aClass 215320 "Return the organization of the class with all selectors defined in superclasses removed. (except those in Object)" 215321 215322 | org str | 215323 org := aClass organization deepCopy. 215324 Dangerous do: [:sel | 215325 org removeElement: sel]. 215326 Approved do: [:sel | 215327 org removeElement: sel]. 215328 AddAndRemove do: [:sel | 215329 org removeElement: sel]. 215330 str := org printString copyWithout: $(. 215331 str := '(', (str copyWithout: $) ). 215332 str := str replaceAll: $' with: $". 215333 ^ str 215334! ! 215335 215336!MethodFinder methodsFor: 'initialize' stamp: 'tk 5/4/1999 20:18'! 215337testFromTuple: nth 215338 "verify that the methods allowed don't crash the system. Try N of each of the fundamental types. up to 4 of each kind." 215339 215340| objects nonRepeating even other aa cnt | 215341objects := #((1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four') 215342 (x + rect: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3) 215343 ). 215344 215345objects := objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}. 215346 {Point class. SmallInteger class. Association class. Array class}. 215347 "{ 4 blocks }." 215348 {Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}. 215349 {'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}. 215350 {Dictionary new. Dictionary new. Dictionary new. Dictionary new}. 215351 {#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection. 215352 #($a 3 d) asOrderedCollection. #() asOrderedCollection}. 215353 {3->true. 5.6->$a. #x->2. 'abcd'->false}. 215354 {9@3 extent: 5@4. 0@0 extent: 45@9. -3@-7 extent: 2@2. 4@4 extent: 16@16}. 215355 {Color red. Color blue. Color black. Color gray}}. 215356 215357self test2: objects. 215358"rec+0, rec+1, rec+2, rec+3 need to be tested. " 215359cnt := 0. 215360nth to: 4 do: [:take | 215361 nonRepeating := OrderedCollection new. 215362 objects do: [:each | 215363 nonRepeating addAll: (each copyFrom: 1 to: take)]. 215364 "all combinations of take, from nonRepeating" 215365 even := true. 215366 nonRepeating combinations: take atATimeDo: [:tuple | 215367 even ifTrue: [other := tuple clone] 215368 ifFalse: [self load: (aa := Array with: tuple with: 1 with: other with: 7). 215369 (cnt := cnt+1) \\ 50 = 0 ifTrue: [ 215370 Transcript cr; show: aa first printString]. 215371 self search: true. 215372 self test2: aa. 215373 self test2: nonRepeating. 215374 "self test2: objects"]. 215375 even := even not]. 215376 ].! ! 215377 215378!MethodFinder methodsFor: 'initialize' stamp: 'tk 5/18/2001 19:18'! 215379verify 215380 "Test a bunch of examples" 215381 " MethodFinder new verify " 215382Approved ifNil: [self initialize]. "Sets of allowed selectors" 215383(MethodFinder new load: #( (0) 0 (30) 0.5 (45) 0.707106 (90) 1) 215384 ) searchForOne asArray = #('data1 degreeSin') ifFalse: [self error: 'should have found it']. 215385(MethodFinder new load: { { true. [3]. [4]}. 3. { false. [0]. [6]}. 6} 215386 ) searchForOne asArray = #('data1 ifTrue: data2 ifFalse: data3') ifFalse: [ 215387 self error: 'should have found it']. 215388(MethodFinder new load: {#(1). true. #(2). false. #(5). true. #(10). false} 215389 ) searchForOne asArray = #('data1 odd') ifFalse: [self error: 'should have found it']. 215390 "will correct the date type of #true, and complain" 215391(MethodFinder new load: #((4 2) '2r100' (255 16) '16rFF' (14 8) '8r16') 215392 ) searchForOne asArray = 215393 #('data1 radix: data2' 'data1 printStringBase: data2' 'data1 storeStringBase: data2') 215394 ifFalse: [self error: 'should have found it']. 215395(MethodFinder new load: {{Point x: 3 y: 4}. 4. {Point x: 1 y: 5}. 5} 215396 ) searchForOne asArray = #('data1 y') ifFalse: [self error: 'should have found it']. 215397(MethodFinder new load: #(('abcd') $a ('TedK') $T) 215398 ) searchForOne asArray = #('data1 asCharacter' 'data1 first' 'data1 anyOne') 215399 ifFalse: [self error: 'should have found it']. 215400(MethodFinder new load: #(('abcd' 1) $a ('Ted ' 3) $d ) 215401 ) searchForOne asArray = #('data1 at: data2' 'data1 atPin: data2' 'data1 atWrap: data2') 215402 ifFalse: [self error: 'should have found it']. 215403(MethodFinder new load: #(((12 4 8)) 24 ((1 3 6)) 10 ) 215404 ) searchForOne asArray= #('data1 sum') ifFalse: [self error: 'should have found it']. 215405 "note extra () needed for an Array object as an argument" 215406 215407(MethodFinder new load: #((14 3) 11 (-10 5) -15 (4 -3) 7) 215408 ) searchForOne asArray = #('data1 - data2') ifFalse: [self error: 'should have found it']. 215409(MethodFinder new load: #((4) 4 (-10) 10 (-3) 3 (2) 2 (-6) 6 (612) 612) 215410 ) searchForOne asArray = #('data1 abs') ifFalse: [self error: 'should have found it']. 215411(MethodFinder new load: {#(4 3). true. #(-7 3). false. #(5 1). true. #(5 5). false} 215412 ) searchForOne asArray = #('data1 > data2') ifFalse: [self error: 'should have found it']. 215413(MethodFinder new load: #((5) 0.2 (2) 0.5) 215414 ) searchForOne asArray = #('data1 reciprocal') ifFalse: [self error: 'should have found it']. 215415(MethodFinder new load: #((12 4 8) 2 (1 3 6) 2 (5 2 16) 8) 215416 ) searchForOne asArray = #() " '(data3 / data2) ' want to be able to leave out args" 215417 ifFalse: [self error: 'should have found it']. 215418(MethodFinder new load: #((0.0) 0.0 (1.5) 0.997495 (0.75) 0.681639) 215419 ) searchForOne asArray = #('data1 sin') ifFalse: [self error: 'should have found it']. 215420(MethodFinder new load: #((7 5) 2 (4 5) 4 (-9 4) 3) 215421 ) searchForOne asArray = #('data1 \\ data2') ifFalse: [self error: 'should have found it']. 215422 215423(MethodFinder new load: #((7) 2 (4) 2 ) 215424 ) searchForOne asArray = #('^ 2') ifFalse: [self error: 'should have found it']. 215425(MethodFinder new load: {#(7). true. #(4.1). true. #(1.5). false} 215426 ) searchForOne asArray = #('data1 >= 4.1') ifFalse: [self error: 'should have found it']. 215427(MethodFinder new load: #((35) 3 (17) 1 (5) 5) 215428 ) searchForOne asArray = #('data1 \\ 8') ifFalse: [self error: 'should have found it']. 215429(MethodFinder new load: #((36) 7 (50) 10 ) 215430 ) searchForOne asArray = #('data1 quo: 5' 'data1 // 5') ifFalse: [ 215431 self error: 'should have found it']. 215432(MethodFinder new load: #( ((2 3) 2) 8 ((2 3) 5) 17 ) 215433 ) searchForOne asArray = #('data1 polynomialEval: data2') ifFalse: [ 215434 self error: 'should have found it']. 215435(MethodFinder new load: #((2) 8 (5) 17 ) 215436 ) searchForOne asArray = #('#(2 3) polynomialEval: data1') ifFalse: [ 215437 self error: 'should have found it']. 215438! ! 215439 215440 215441!MethodFinder methodsFor: 'search' stamp: 'ar 4/10/2005 22:20'! 215442exceptions 215443 "Handle some very slippery selectors. 215444 asSymbol -- want to be able to produce it, but do not want to make every string submitted into a Symbol!!" 215445 215446 | aSel | 215447 answers first isSymbol ifFalse: [^ self]. 215448 thisData first first isString ifFalse: [^ self]. 215449 aSel := #asSymbol. 215450 (self testPerfect: aSel) ifTrue: [ 215451 selector add: aSel. 215452 expressions add: (String streamContents: [:strm | 215453 strm nextPutAll: 'data', argMap first printString. 215454 aSel keywords doWithIndex: [:key :ind | 215455 strm nextPutAll: ' ',key. 215456 (key last == $:) | (key first isLetter not) 215457 ifTrue: [strm nextPutAll: ' data', 215458 (argMap at: ind+1) printString]]])]. 215459! ! 215460 215461!MethodFinder methodsFor: 'search' stamp: 'ar 4/10/2005 18:48'! 215462findMessage 215463 "Control the search." 215464 215465 data do: [:alist | 215466 (alist isKindOf: SequenceableCollection) ifFalse: [ 215467 ^ OrderedCollection with: 'first and third items are not Arrays']]. 215468 Approved ifNil: [self initialize]. "Sets of allowed selectors" 215469 expressions := OrderedCollection new. 215470 self search: true. "multi" 215471 expressions isEmpty ifTrue: [^ OrderedCollection with: 'no single method does that function']. 215472 expressions isString ifTrue: [^ OrderedCollection with: expressions]. 215473 ^ expressions! ! 215474 215475!MethodFinder methodsFor: 'search' stamp: 'tk 4/12/2001 10:47'! 215476insertConstants 215477 "see if one of several known expressions will do it. C is the constant we discover here." 215478 "C data1+C data1*C data1//C (data1*C1 + C2) (data1 = C) (data1 ~= C) (data1 <= C) (data1 >= C) 215479 (data1 mod C)" 215480 215481 thisData size >= 2 ifFalse: [^ false]. "need 2 examples" 215482 (thisData at: 1) size = 1 ifFalse: [^ false]. "only one arg, data1" 215483 215484 self const ifTrue: [^ true]. 215485 self constUsingData1Value ifTrue: [^ true]. 215486 "(data1 ?? const), where const is one of the values of data1" 215487 " == ~~ ~= = <= >= " 215488 215489 self allNumbers ifFalse: [^ false]. 215490 self constMod ifTrue: [^ true]. 215491 self constPlus ifTrue: [^ true]. 215492 self constMult ifTrue: [^ true]. 215493 self constDiv ifTrue: [^ true]. 215494 self constLinear ifTrue: [^ true]. 215495 ^ false! ! 215496 215497!MethodFinder methodsFor: 'search' stamp: 'md 2/22/2006 21:23'! 215498search: multi 215499 "if Multi is true, collect all selectors that work." 215500 selector := OrderedCollection new. "list of them" 215501 self simpleSearch. 215502 multi not & (selector isEmpty not) ifTrue:[^ selector]. 215503 215504 [self permuteArgs] whileTrue: 215505 [self simpleSearch. 215506 multi not & (selector isEmpty not) ifTrue: [^ selector]]. 215507 215508 self insertConstants. 215509 "(selector isEmpty not) ifTrue: [^ selector]]. expression is the answer, not a selector" 215510 ^ #()! ! 215511 215512!MethodFinder methodsFor: 'search' stamp: 'tk 1/8/2001 17:53'! 215513searchForOne 215514 "Look for and return just one answer" 215515 215516 expressions := OrderedCollection new. 215517 self search: false. "non-multi" 215518 ^ expressions 215519 ! ! 215520 215521!MethodFinder methodsFor: 'search' stamp: 'Henrik Sperre Johansen 8/14/2009 15:34'! 215522simpleSearch 215523 "Run through first arg's class' selectors, looking for one that works." 215524 215525| class supers listOfLists | 215526self exceptions. 215527class := thisData first first class. 215528"Cache the selectors for the receiver class" 215529(class == cachedClass and: [cachedArgNum = ((argMap size) - 1)]) 215530 ifTrue: [listOfLists := cachedSelectorLists] 215531 ifFalse: [ 215532 supers := class withAllSuperclasses. 215533 listOfLists := OrderedCollection new. 215534 supers do: [:cls | 215535 listOfLists add: (cls selectorsWithArgs: (argMap size) - 1)]. 215536 cachedClass := class. 215537 cachedArgNum := (argMap size) - 1. 215538 cachedSelectorLists := listOfLists]. 215539listOfLists do: [:selectorList | 215540 selectorList do: [:aSel | 215541 (selector includes: aSel) ifFalse: [ 215542 ((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [ 215543 (self testPerfect: aSel) ifTrue: [ 215544 selector add: aSel. 215545 expressions add: (String streamContents: [:strm | 215546 strm nextPutAll: 'data', argMap first printString. 215547 aSel keywords doWithIndex: [:key :ind | 215548 strm nextPutAll: ' ',key. 215549 (key last == $:) | (key first isLetter not) 215550 ifTrue: [strm nextPutAll: ' data', 215551 (argMap at: ind+1) printString]]]) 215552 ]]]]]. 215553! ! 215554 215555!MethodFinder methodsFor: 'search' stamp: 'Henrik Sperre Johansen 8/14/2009 15:33'! 215556testPerfect: aSelector 215557 "Try this selector!! Return true if it answers every example perfectly. Take the args in the order they are. Do not permute them. Survive errors. later cache arg lists." 215558 215559| sz argList val rec activeSel perform | 215560 "Transcript cr; show: aSelector. debug" 215561perform := aSelector beginsWith: 'perform:'. 215562sz := argMap size. 2155631 to: thisData size do: [:ii | "each example set of args" 215564 argList := (thisData at: ii) copyFrom: 2 to: sz. 215565 perform 215566 ifFalse: [activeSel := aSelector] 215567 ifTrue: [activeSel := argList first. "what will be performed" 215568 ((Approved includes: activeSel) or: [AddAndRemove includes: activeSel]) 215569 ifFalse: [^ false]. "not approved" 215570 aSelector == #perform:withArguments: 215571 ifTrue: [activeSel numArgs = (argList at: 2) basicSize "avoid error" 215572 ifFalse: [^ false]] 215573 ifFalse: [activeSel numArgs = (aSelector numArgs - 1) 215574 ifFalse: [^ false]]]. 215575 1 to: sz do: [:num | 215576 (Blocks includes: (Array with: activeSel with: num)) ifTrue: [ 215577 (argList at: num) isBlock ifFalse: [^ false]]]. 215578 rec := (AddAndRemove includes: activeSel) 215579 ifTrue: [(thisData at: ii) first isSymbol ifTrue: [^ false]. 215580 "vulnerable to modification" 215581 (thisData at: ii) first copyTwoLevel] "protect from damage" 215582 ifFalse: [(thisData at: ii) first]. 215583 val := [[rec perform: aSelector withArguments: argList] 215584 ifError: [:aString :aReceiver | 215585 "self test3." 215586 "self test2: (thisData at: ii)." 215587 ^ false]] on: Deprecation do: [:depr | 215588 "We do not want to list deprecated methods" 215589 ^false.]. 215590 "self test3." 215591 "self test2: (thisData at: ii)." 215592 ((answers at: ii) closeTo: val) ifFalse: [^ false]. 215593 ]. 215594^ true! ! 215595 215596 215597!MethodFinder methodsFor: 'tests' stamp: 'tk 5/4/1999 20:19'! 215598testRandom 215599 "verify that the methods allowed don't crash the system. Pick 3 or 4 from a mixed list of the fundamental types." 215600 215601| objects other aa cnt take tuple fName sss | 215602objects := #((1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four') 215603 (x + rect: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3) 215604 ). 215605 215606objects := objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}. 215607 {Point class. SmallInteger class. Association class. Array class}. 215608 "{ 4 blocks }." 215609 {Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}. 215610 {'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}. 215611 {Dictionary new. Dictionary new. Dictionary new. Dictionary new}. 215612 {#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection. 215613 #($a 3 d) asOrderedCollection. #() asOrderedCollection}. 215614 {3->true. 5.6->$a. #x->2. 'abcd'->false}. 215615 {9@3 extent: 5@4. 0@0 extent: 45@9. -3@-7 extent: 2@2. 4@4 extent: 16@16}. 215616 {Color red. Color blue. Color black. Color gray}}. 215617 215618self test2: objects. 215619"rec+0, rec+1, rec+2, rec+3 need to be tested. " 215620fName := (FileDirectory default fileNamesMatching: '*.ran') first. 215621sss := fName splitInteger first. 215622(Collection classPool at: #RandomForPicking) seed: sss. 215623cnt := 0. 215624[take := #(3 4) atRandom. 215625 tuple := (1 to: take) collect: [:ind | (objects atRandom) atRandom]. 215626 other := (1 to: take) collect: [:ind | (objects atRandom) atRandom]. 215627 self load: (aa := Array with: tuple with: 1 with: other with: 7). 215628 ((cnt := cnt+1) \\ 10 = 0) " | (cnt > Skip)" ifTrue: [ 215629 Transcript cr; show: cnt printString; tab; tab; show: aa first printString]. 215630 cnt > (Smalltalk at: #StopHere) ifTrue: [self halt]. "stop just before crash" 215631 cnt > (Smalltalk at: #Skip) ifTrue: ["skip this many at start" 215632 self search: true. 215633 self test2: aa first. self test2: (aa at: 3). 215634 "self test2: objects" 215635 ]. 215636 true] whileTrue. 215637 ! ! 215638 215639"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 215640 215641MethodFinder class 215642 instanceVariableNames: ''! 215643 215644!MethodFinder class methodsFor: 'as yet unclassified' stamp: 'ar 9/27/2005 22:45'! 215645methodFor: dataAndAnswers 215646 "Return a Squeak expression that computes these answers. (This method is called by the comment in the bottom pane of a MethodFinder. Do not delete this method.)" 215647 215648 | resultOC resultString | 215649 resultOC := (self new) load: dataAndAnswers; findMessage. 215650 resultString := String streamContents: [:strm | 215651 resultOC do: [:exp | strm nextPut: $(; nextPutAll: exp; nextPut: $); space]]. 215652 ^ resultString! ! 215653ClosureCompilerTest subclass: #MethodHighlightingTests 215654 instanceVariableNames: 'creator timeStamp duration tracks' 215655 classVariableNames: '' 215656 poolDictionaries: '' 215657 category: 'Tests-Compiler'! 215658 215659!MethodHighlightingTests methodsFor: 'tests' stamp: 'AdrianLienhard 10/17/2009 16:45'! 215660asXML 215661 "This method is just used as an example for #testMethodHighlighting." 215662 215663 | writer | 215664 ^String streamContents:[:s| 215665 writer := nil. 215666 writer xmlDeclaration: '1.0'. 215667 writer startTag: 'recording'; endTag. 215668 writer tag: 'creator' pcData: creator. 215669 writer tag: 'timestamp' pcData: timeStamp. 215670 writer tag: 'duration' pcData: duration. 215671 writer startTag: 'tracks'; endTag. 215672 tracks do:[:tdata| 215673 writer startTag: 'track'; attribute: 'type' value: tdata value; endTag. 215674 writer pcData: tdata key. 215675 writer endTag: 'track'. 215676 ]. 215677 writer endTag: 'tracks'. 215678 writer endTag: 'recording'. 215679 ]. 215680! ! 215681 215682!MethodHighlightingTests methodsFor: 'tests' stamp: 'AdrianLienhard 10/17/2009 16:43'! 215683testMethodHighlighting 215684 | map before after method retpc | 215685 "Test the highlighting of the asXML method. Test the highlighting of the return 215686 statement which should include the whole block supplied to streamContents:." 215687 "DebuggerMethodMap voidMapCache" 215688 "DebuggerMethodMap forMethod: MethodHighlightingTests >> #asXML" 215689 method := MethodHighlightingTests >> #asXML. 215690 map := DebuggerMethodMap forMethod: method. 215691 retpc := method endPC. 215692 before := map rangeForPC: retpc contextIsActiveContext: false. 215693 map instVarNamed: 'abstractSourceRanges' put: nil. 215694 after := map rangeForPC: retpc contextIsActiveContext: false. 215695 self assert: before size > 500. 215696 self assert: before = after! ! 215697ParseNode subclass: #MethodNode 215698 instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText' 215699 classVariableNames: '' 215700 poolDictionaries: '' 215701 category: 'Compiler-ParseNodes'! 215702!MethodNode commentStamp: '<historical>' prior: 0! 215703I am the root of the parse tree.! 215704 215705 215706!MethodNode methodsFor: 'accessing' stamp: 'eem 7/21/2009 16:00'! 215707arguments 215708 "For transformations etc, not used in compilation" 215709 ^arguments! ! 215710 215711!MethodNode methodsFor: 'accessing' stamp: 'eem 7/21/2009 16:00'! 215712arguments: aSequence 215713 "For transformations etc, not used in compilation" 215714 arguments := aSequence! ! 215715 215716!MethodNode methodsFor: 'accessing' stamp: 'md 7/27/2006 19:12'! 215717body 215718 ^block! ! 215719 215720!MethodNode methodsFor: 'accessing' stamp: 'eem 1/19/2009 10:28'! 215721primitiveErrorVariableName 215722 "Answer the primitive error code temp name, or nil if none." 215723 (primitive isInteger and: [primitive > 0]) ifTrue: 215724 [properties pragmas do: 215725 [:pragma| | kwds ecIndex | 215726 ((kwds := pragma keyword keywords) first = 'primitive:' 215727 and: [(ecIndex := kwds indexOf: 'error:') > 0]) ifTrue: 215728 [^pragma argumentAt: ecIndex]]]. 215729 ^nil 215730 215731 "(Parser new parse: (MethodNode sourceCodeAt: #primitiveErrorVariableName) class: Parser) primitiveErrorVariableName" 215732 215733 "(Parser new parse: 'foo <primitive: 111 error: ''foo''> self primitiveFailed' class: Object) primitiveErrorVariableName" 215734 215735 "(Parser new parse: 'foo <primitive: 111 error: foo> self primitiveFailed' class: Object) primitiveErrorVariableName" 215736 215737 "(Parser new parse: 'foo <primitive: 111> self primitiveFailed' class: Object) primitiveErrorVariableName" 215738 215739 "(Parser new parse: 'foo <primitive: ''foo'' error: foo module: ''bar''> self primitiveFailed' class: Object) primitiveErrorVariableName" 215740 215741 "(Parser new parse: 'foo <primitive: ''foo'' module: ''bar'' error: foo> self primitiveFailed' class: Object) primitiveErrorVariableName" 215742 215743 "(Parser new parse: 'foo <primitive: 111 error: foo> self primitiveFailed' class: Object) generate"! ! 215744 215745!MethodNode methodsFor: 'accessing' stamp: 'eem 6/11/2009 17:27'! 215746removeProperty: aSymbol 215747 properties := properties copyWithout: (Association 215748 key: aSymbol 215749 value: (properties propertyValueAt: aSymbol))! ! 215750 215751!MethodNode methodsFor: 'accessing' stamp: 'eem 7/21/2009 15:59'! 215752temporaries 215753 "For transformations etc, not used in compilation" 215754 ^temporaries! ! 215755 215756!MethodNode methodsFor: 'accessing' stamp: 'eem 7/21/2009 15:59'! 215757temporaries: aSequence 215758 "For transformations etc, not used in compilation" 215759 temporaries := aSequence! ! 215760 215761 215762!MethodNode methodsFor: 'code generation'! 215763encoder 215764 ^ encoder! ! 215765 215766!MethodNode methodsFor: 'code generation' stamp: 'al 4/21/2006 17:25'! 215767generate 215768 "The receiver is the root of a parse tree. Answer a CompiledMethod. The 215769 argument, trailer, is the references to the source code that is stored with 215770 every CompiledMethod." 215771 215772 ^self generate: #(0 0 0 0)! ! 215773 215774!MethodNode methodsFor: 'code generation' stamp: 'eem 12/1/2008 12:03'! 215775generate: trailer 215776 "The receiver is the root of a parse tree. Answer a CompiledMethod. The 215777 argument, trailer, is the references to the source code that is stored with 215778 every CompiledMethod." 215779 215780 | literals blkSize method nArgs nLits primErrNode stack strm | 215781 self generate: trailer ifQuick: 215782 [:m | 215783 literals := encoder allLiterals. 215784 (nLits := literals size) > 255 ifTrue: 215785 [^self error: 'Too many literals referenced']. 215786 1 to: nLits do: [:lit | m literalAt: lit put: (literals at: lit)]. 215787 m properties: properties. 215788 ^m]. 215789 primErrNode := self primitiveErrorVariableName ifNotNil: 215790 [encoder fixTemp: self primitiveErrorVariableName]. 215791 nArgs := arguments size. 215792 blkSize := (block sizeForEvaluatedValue: encoder) 215793 + (primErrNode ifNil: [0] ifNotNil: [2 "We force store-long (129)"]). 215794 (nLits := (literals := encoder allLiterals) size) > 255 ifTrue: 215795 [^self error: 'Too many literals referenced']. 215796 method := CompiledMethod "Dummy to allocate right size" 215797 newBytes: blkSize 215798 trailerBytes: trailer 215799 nArgs: nArgs 215800 nTemps: encoder maxTemp 215801 nStack: 0 215802 nLits: nLits 215803 primitive: primitive. 215804 strm := ReadWriteStream with: method. 215805 strm position: method initialPC - 1. 215806 stack := ParseStack new init. 215807 primErrNode ifNotNil: [primErrNode emitStore: stack on: strm]. 215808 block emitForEvaluatedValue: stack on: strm. 215809 stack position ~= 1 ifTrue: 215810 [^self error: 'Compiler stack discrepancy']. 215811 strm position ~= (method size - trailer size) ifTrue: 215812 [^self error: 'Compiler code size discrepancy']. 215813 method needsFrameSize: stack size. 215814 1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)]. 215815 method properties: properties. 215816 ^method! ! 215817 215818!MethodNode methodsFor: 'code generation' stamp: 'di 5/25/2000 06:45'! 215819generate: trailer ifQuick: methodBlock 215820 | v | 215821 (primitive = 0 and: [arguments size = 0 and: [block isQuick]]) 215822 ifFalse: [^ self]. 215823 v := block code. 215824 v < 0 215825 ifTrue: [^ self]. 215826 v = LdSelf 215827 ifTrue: [^ methodBlock value: (CompiledMethod toReturnSelfTrailerBytes: trailer)]. 215828 (v between: LdTrue and: LdMinus1 + 3) 215829 ifTrue: [^ methodBlock value: (CompiledMethod toReturnConstant: v - LdSelf trailerBytes: trailer)]. 215830 v < ((CodeBases at: LdInstType) + (CodeLimits at: LdInstType)) 215831 ifTrue: [^ methodBlock value: (CompiledMethod toReturnField: v trailerBytes: trailer)]. 215832 v // 256 = 1 215833 ifTrue: [^ methodBlock value: (CompiledMethod toReturnField: v \\ 256 trailerBytes: trailer)]! ! 215834 215835!MethodNode methodsFor: 'code generation' stamp: 'ajh 7/6/2003 15:25'! 215836parserClass 215837 "Which parser produces this class of parse node" 215838 215839 ^ Parser! ! 215840 215841!MethodNode methodsFor: 'code generation' stamp: 'lr 2/6/2006 23:24'! 215842properties 215843 ^ properties! ! 215844 215845!MethodNode methodsFor: 'code generation' stamp: 'yo 8/30/2002 14:07'! 215846selector 215847 "Answer the message selector for the method represented by the receiver." 215848 215849 (selectorOrFalse isSymbol) 215850 ifTrue: [^selectorOrFalse]. 215851 ^selectorOrFalse key. 215852! ! 215853 215854!MethodNode methodsFor: 'code generation' stamp: 'eem 9/25/2008 15:20'! 215855selectorNode 215856 "Answer a SelectorNode for the message selector of the method represented by the receiver." 215857 215858 ^(selectorOrFalse isMemberOf: SelectorNode) 215859 ifTrue: [selectorOrFalse] 215860 ifFalse: [SelectorNode new key: selectorOrFalse]! ! 215861 215862 215863!MethodNode methodsFor: 'converting' stamp: 'eem 7/18/2008 06:37'! 215864asColorizedSmalltalk80Text 215865 "Answer a colorized Smalltalk-80-syntax string description of the parse tree whose root is the receiver." 215866 215867 | printText | 215868 printText := self printString asText. 215869 ^(Smalltalk at: #SHTextStylerST80 ifAbsent: [nil]) 215870 ifNotNil: [:stylerClass| stylerClass new styledTextFor: printText] 215871 ifNil: [printText]! ! 215872 215873!MethodNode methodsFor: 'converting' stamp: 'eem 5/6/2008 15:17'! 215874decompileString 215875 "Answer a string description of the parse tree whose root is the receiver." 215876 215877 ^self printString 215878! ! 215879 215880 215881!MethodNode methodsFor: 'initialize-release' stamp: 'tk 8/3/1999 12:47'! 215882block 215883 ^ block! ! 215884 215885!MethodNode methodsFor: 'initialize-release' stamp: 'ajh 1/24/2003 17:37'! 215886selector: symbol 215887 215888 selectorOrFalse := symbol! ! 215889 215890!MethodNode methodsFor: 'initialize-release'! 215891selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim 215892 "Initialize the receiver with respect to the arguments given." 215893 215894 encoder := anEncoder. 215895 selectorOrFalse := selOrFalse. 215896 precedence := p. 215897 arguments := args. 215898 temporaries := temps. 215899 block := blk. 215900 primitive := prim! ! 215901 215902!MethodNode methodsFor: 'initialize-release' stamp: 'ar 1/4/2002 00:23'! 215903selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict 215904 "Initialize the receiver with respect to the arguments given." 215905 215906 encoder := anEncoder. 215907 selectorOrFalse := selOrFalse. 215908 precedence := p. 215909 arguments := args. 215910 temporaries := temps. 215911 block := blk. 215912 primitive := prim. 215913 properties := propDict.! ! 215914 215915!MethodNode methodsFor: 'initialize-release' stamp: 'ajh 1/22/2003 17:53'! 215916sourceText: stringOrText 215917 215918 sourceText := stringOrText! ! 215919 215920 215921!MethodNode methodsFor: 'printing' stamp: 'ajh 1/22/2003 17:39'! 215922methodClass 215923 215924 ^ encoder classEncoding! ! 215925 215926!MethodNode methodsFor: 'printing' stamp: 'eem 12/1/2008 14:36'! 215927printOn: aStream 215928 | selectorNode | 215929 selectorNode := self selectorNode. 215930 precedence = 1 215931 ifTrue: 215932 [selectorNode isForFFICall 215933 ifTrue: [selectorNode 215934 printAsFFICallWithArguments: arguments 215935 on: aStream 215936 indent: 0] 215937 ifFalse: [aStream nextPutAll: selectorNode key]] 215938 ifFalse: 215939 [selectorNode key keywords with: arguments do: 215940 [:kwd :arg | 215941 aStream nextPutAll: kwd; space; nextPutAll: arg key; space]]. 215942 comment == nil ifFalse: 215943 [aStream crtab: 1. 215944 self printCommentOn: aStream indent: 1]. 215945 block printTemporaries: temporaries on: aStream doPrior: [aStream crtab: 1]. 215946 primitive > 0 ifTrue: 215947 [(primitive between: 255 and: 519) ifFalse: "Dont decompile quick prims e.g, ^ self or ^instVar" 215948 [aStream crtab: 1. 215949 self printPrimitiveOn: aStream]]. 215950 self printPropertiesOn: aStream. 215951 self printPragmasOn: aStream. 215952 aStream crtab: 1. 215953 block printStatementsOn: aStream indent: 0! ! 215954 215955!MethodNode methodsFor: 'printing' stamp: 'eem 12/1/2008 14:35'! 215956printPragmasOn: aStream 215957 properties ifNil: [^self]. 215958 properties pragmas do: 215959 [:pragma| 215960 "Primitives are printed in printPrimitiveOn:; skip these" 215961 (Parser primitivePragmaSelectors includes: pragma keyword) ifFalse: 215962 [aStream crtab: 1. 215963 pragma printOn: aStream]]! ! 215964 215965!MethodNode methodsFor: 'printing' stamp: 'eem 12/5/2008 09:49'! 215966printPrimitiveOn: aStream 215967 "Print the primitive on aStream" 215968 | primDecl | 215969 primitive = 0 ifTrue: 215970 [^self]. 215971 primitive = 120 ifTrue: "External call spec" 215972 [^aStream print: encoder literals first]. 215973 aStream nextPutAll: '<primitive: '. 215974 primitive = 117 215975 ifTrue: 215976 [primDecl := encoder literals at: 1. 215977 (primDecl at: 2) asString printOn: aStream. 215978 (primDecl at: 1) ifNotNil: 215979 [:moduleName| 215980 aStream nextPutAll:' module: '. 215981 moduleName asString printOn: aStream]] 215982 ifFalse: 215983 [aStream print: primitive]. 215984 self primitiveErrorVariableName ifNotNil: 215985 [:primitiveErrorVariableName| 215986 aStream nextPutAll: ' error: '; nextPutAll: primitiveErrorVariableName]. 215987 aStream nextPut: $>. 215988 Smalltalk at: #Interpreter ifPresent:[:cls| 215989 aStream nextPutAll: ' "', 215990 ((cls classPool at: #PrimitiveTable) at: primitive + 1), 215991 '" ']! ! 215992 215993!MethodNode methodsFor: 'printing' stamp: 'eem 12/1/2008 14:25'! 215994printPropertiesOn: aStream 215995 properties ifNil: [^self]. 215996 properties propertyKeysAndValuesDo: 215997 [:prop :val| 215998 aStream crtab; nextPut: $<. 215999 prop = #on:in: 216000 ifTrue: 216001 [prop keywords with: val do: 216002 [:k :v | aStream nextPutAll: k; space; nextPutAll: v; space]] 216003 ifFalse: 216004 [prop = #on 216005 ifTrue: [aStream nextPutAll: prop; nextPutAll:': '; nextPutAll: val] 216006 ifFalse: [aStream nextPutAll: prop; nextPutAll:': '; print: val]]. 216007 aStream nextPut: $>]! ! 216008 216009!MethodNode methodsFor: 'printing' stamp: 'eem 12/1/2008 14:36'! 216010printWithClosureAnalysisOn: aStream 216011 216012 precedence = 1 216013 ifTrue: 216014 [(self selector includesSubString: '()/') 216015 ifTrue: [aStream nextPutAll: (self selector copyUpTo: $)). 216016 arguments 216017 do: [:arg| aStream nextPutAll: arg key] 216018 separatedBy: [aStream nextPutAll: ', ']. 216019 aStream nextPut: $)] 216020 ifFalse: [aStream nextPutAll: self selector]] "no node for method selector" 216021 ifFalse: 216022 [self selector keywords with: arguments do: 216023 [:kwd :arg | 216024 aStream nextPutAll: kwd; space. 216025 arg printDefinitionForClosureAnalysisOn: aStream. 216026 aStream space]]. 216027 comment == nil ifFalse: 216028 [aStream crtab: 1. 216029 self printCommentOn: aStream indent: 1]. 216030 temporaries size > 0 ifTrue: 216031 [aStream crtab: 1; nextPut: $|. 216032 temporaries do: [:temp | 216033 aStream space. 216034 temp printDefinitionForClosureAnalysisOn: aStream]. 216035 aStream space; nextPut: $|]. 216036 primitive > 0 ifTrue: 216037 [(primitive between: 255 and: 519) ifFalse: "Dont decompile quick prims e.g, ^ self or ^instVar" 216038 [aStream crtab: 1. 216039 self printPrimitiveOn: aStream]]. 216040 self printPropertiesOn: aStream. 216041 self printPragmasOn: aStream. 216042 aStream crtab: 1. 216043 block printWithClosureAnalysisStatementsOn: aStream indent: 0! ! 216044 216045!MethodNode methodsFor: 'printing' stamp: 'ajh 1/24/2003 17:41'! 216046sourceText 216047 216048 ^ sourceText ifNil: [self printString]! ! 216049 216050!MethodNode methodsFor: 'printing'! 216051tempNames 216052 ^ encoder tempNames! ! 216053 216054 216055!MethodNode methodsFor: 'source mapping' stamp: 'eem 6/4/2008 19:21'! 216056rawSourceRanges 216057 216058 ^self rawSourceRangesAndMethodDo: [:rawSourceRanges :method| rawSourceRanges]! ! 216059 216060!MethodNode methodsFor: 'source mapping' stamp: 'eem 3/14/2009 17:01'! 216061rawSourceRangesAndMethodDo: aBinaryBlock 216062 "Evaluate aBinaryBlock with the rawSourceRanges and method generated from the receiver." 216063 216064 | methNode method | 216065 methNode := encoder classEncoding parserClass new 216066 encoderClass: encoder class; 216067 parse: (sourceText "If no source, use decompile string as source to map from" 216068 ifNil: [self decompileString] 216069 ifNotNil: [sourceText]) 216070 class: self methodClass. 216071 method := methNode generate: #(0 0 0 0). "set bytecodes to map to" 216072 ^aBinaryBlock 216073 value: methNode encoder rawSourceRanges 216074 value: method! ! 216075 216076 216077!MethodNode methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:52'! 216078accept: aVisitor 216079 aVisitor visitMethodNode: self. 216080 ^aVisitor! ! 216081 216082 216083!MethodNode methodsFor: 'primitive error codes' stamp: 'eem 12/1/2008 14:56'! 216084removeAndRenameLastTempIfErrorCode 216085 self primitiveErrorVariableName ifNotNil: 216086 [:primitiveErrorVariableName| 216087 temporaries last 216088 name: primitiveErrorVariableName 216089 key: primitiveErrorVariableName 216090 code: temporaries last code. 216091 temporaries removeLast].! ! 216092TestCase subclass: #MethodPragmaTest 216093 instanceVariableNames: '' 216094 classVariableNames: '' 216095 poolDictionaries: '' 216096 category: 'KernelTests-Methods'! 216097 216098!MethodPragmaTest methodsFor: 'running' stamp: 'lr 1/20/2006 02:15'! 216099tearDown 216100 (self class organization listAtCategoryNamed: self methodCategory) 216101 do: [ :each | self class removeSelectorSilently: each ]. 216102 self class organization removeCategory: self methodCategory.! ! 216103 216104 216105!MethodPragmaTest methodsFor: 'testing' stamp: 'lr 3/19/2007 11:40'! 216106testArgumentAt 216107 | pragma | 216108 pragma := Pragma keyword: #value:value:value: arguments: #( 3 2 1 ). 216109 self assert: (pragma argumentAt: 1) = 3. 216110 self assert: (pragma argumentAt: 2) = 2. 216111 self assert: (pragma argumentAt: 3) = 1! ! 216112 216113!MethodPragmaTest methodsFor: 'testing' stamp: 'lr 3/19/2007 11:42'! 216114testNumArgs 216115 | pragma | 216116 pragma := Pragma keyword: #value arguments: #(). 216117 self assert: pragma numArgs = 0. 216118 216119 pragma := Pragma keyword: #+ arguments: #( 1 ). 216120 self assert: pragma numArgs = 1. 216121 216122 pragma := Pragma keyword: #value:value: arguments: #( 1 2 ). 216123 self assert: pragma numArgs = 2! ! 216124 216125!MethodPragmaTest methodsFor: 'testing' stamp: 'lr 3/19/2007 11:38'! 216126testSendTo 216127 | pragma wasHere | 216128 pragma := Pragma keyword: #value:value: arguments: #( 1 2 ). 216129 self assert: (pragma sendTo: [ :a :b | 216130 self assert: a = 1; assert: b = 2. 216131 wasHere := true ]). 216132 self assert: wasHere! ! 216133 216134!MethodPragmaTest methodsFor: 'testing' stamp: 'lr 3/19/2007 11:38'! 216135testWithArgumentsDo 216136 | pragma wasHere | 216137 pragma := Pragma keyword: #add:after: arguments: #( 1 2 ). 216138 self assert: (pragma withArgumentsDo: [ :a :b | 216139 self assert: a = 1; assert: b = 2. 216140 wasHere := true ]). 216141 self assert: wasHere! ! 216142 216143 216144!MethodPragmaTest methodsFor: 'testing-compiled' stamp: 'lr 2/6/2006 21:03'! 216145testNoPragma 216146 | method | 216147 method := self compile: '' selector: #foo. 216148 self assert: method pragmas = #().! ! 216149 216150 216151!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'! 216152testCompileArray 216153 self assertPragma: 'foo: #()' givesKeyword: #foo: arguments: #( () ). 216154 self assertPragma: 'foo: #( foo )' givesKeyword: #foo: arguments: #( ( foo ) ). 216155 self assertPragma: 'foo: #( foo: )' givesKeyword: #foo: arguments: #( ( foo: ) ). 216156 self assertPragma: 'foo: #( 12 )' givesKeyword: #foo: arguments: #( ( 12 ) ). 216157 self assertPragma: 'foo: #( true )' givesKeyword: #foo: arguments: #( ( true ) ). 216158 ! ! 216159 216160!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 8/19/2006 20:44'! 216161testCompileBinary 216162 self assertPragma: ' = 1' givesKeyword: #= arguments: #( 1 ). 216163 self assertPragma: ' , 3' givesKeyword: #, arguments: #( 3 ). 216164 self assertPragma: ' > 4' givesKeyword: #> arguments: #( 4 ). 216165 self assertPragma: ' < 5' givesKeyword: #< arguments: #( 5 ). 216166 216167 self assertPragma: ' == 1' givesKeyword: #== arguments: #( 1 ). 216168 self assertPragma: ' <> 3' givesKeyword: #<> arguments: #( 3 ). 216169 self assertPragma: ' >< 4' givesKeyword: #>< arguments: #( 4 ). 216170 self assertPragma: ' ** 5' givesKeyword: #** arguments: #( 5 )! ! 216171 216172!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'! 216173testCompileCharacter 216174 self assertPragma: 'foo: $a' givesKeyword: #foo: arguments: #( $a ). 216175 self assertPragma: 'foo: $ ' givesKeyword: #foo: arguments: #( $ ).! ! 216176 216177!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'! 216178testCompileEmpty 216179 self assertPragma: 'foo' givesKeyword: #foo arguments: #().! ! 216180 216181!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 07:39'! 216182testCompileFull 216183 self assertPragma: 'foo: 1' givesKeyword: #foo: arguments: #( 1 ). 216184 self assertPragma: 'foo: 1 bar: 2' givesKeyword: #foo:bar: arguments: #( 1 2 ).! ! 216185 216186!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 10/5/2006 10:15'! 216187testCompileInvalid 216188 "Invalid pragmas should properly raise an error." 216189 216190 self should: [ self compile: '<>' selector: #zork ] raise: SyntaxErrorNotification. 216191 self should: [ self compile: '<1>' selector: #zork ] raise: SyntaxErrorNotification. 216192 self should: [ self compile: '<#123>' selector: #zork ] raise: SyntaxErrorNotification. 216193 216194 self should: [ self compile: '<foo bar>' selector: #zork ] raise: SyntaxErrorNotification. 216195 self should: [ self compile: '<foo 1>' selector: #zork ] raise: SyntaxErrorNotification. 216196 self should: [ self compile: '<foo bar zork>' selector: #zork ] raise: SyntaxErrorNotification. 216197 self should: [ self compile: '<foo bar 1>' selector: #zork ] raise: SyntaxErrorNotification. 216198 216199 self should: [ self compile: '<foo: bar:>' selector: #zork ] raise: SyntaxErrorNotification. 216200 self should: [ self compile: '<foo: #bar: zork:>' selector: #zork ] raise: SyntaxErrorNotification. 216201 216202 self should: [ self compile: '<<1>' selector: #zork ] raise: SyntaxErrorNotification. 216203 self should: [ self compile: '<=2>' selector: #zork ] raise: SyntaxErrorNotification. 216204 216205 self should: [ self compile: '< =1 = >' selector: #zork ] raise: SyntaxErrorNotification. 216206 self should: [ self compile: '< =1 =2 >' selector: #zork ] raise: SyntaxErrorNotification. 216207 216208 self should: [ self compile: '<foo: String>' selector: #zork ] raise: SyntaxErrorNotification. 216209 self should: [ self compile: '<foo: Pragma>' selector: #zork ] raise: SyntaxErrorNotification! ! 216210 216211!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'! 216212testCompileNumber 216213 self assertPragma: 'foo: 123' givesKeyword: #foo: arguments: #( 123 ). 216214 self assertPragma: 'foo: -123' givesKeyword: #foo: arguments: #( -123 ). 216215 self assertPragma: 'foo: 12.3' givesKeyword: #foo: arguments: #( 12.3 ). 216216 self assertPragma: 'foo: -12.3' givesKeyword: #foo: arguments: #( -12.3 ).! ! 216217 216218!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'! 216219testCompileString 216220 self assertPragma: 'foo: ''''' givesKeyword: #foo: arguments: #( '' ). 216221 self assertPragma: 'foo: ''bar''' givesKeyword: #foo: arguments: #( 'bar' ).! ! 216222 216223!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'! 216224testCompileSymbol 216225 self assertPragma: 'foo: #bar' givesKeyword: #foo: arguments: #( bar ). 216226 self assertPragma: 'foo: #bar:' givesKeyword: #foo: arguments: #( bar: ). 216227 self assertPragma: 'foo: #bar:zork:' givesKeyword: #foo: arguments: #( bar:zork: ).! ! 216228 216229!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 7/3/2006 15:00'! 216230testCompileTemps 216231 "Pragmas should be placeable before and after temps." 216232 216233 self 216234 shouldnt: [ 216235 self assert: (self compile: '| temps | <foo>' selector: #zork) 216236 pragmas notEmpty ] 216237 raise: SyntaxErrorNotification. 216238 self 216239 shouldnt: [ 216240 self assert: (self compile: '<foo> | temps |' selector: #zork) 216241 pragmas notEmpty ] 216242 raise: SyntaxErrorNotification.! ! 216243 216244!MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 10/5/2006 09:49'! 216245testCompileValue 216246 self assertPragma: 'foo: true' givesKeyword: #foo: arguments: #( true ). 216247 self assertPragma: 'foo: false' givesKeyword: #foo: arguments: #( false ). 216248 self assertPragma: 'foo: nil' givesKeyword: #foo: arguments: #( nil )! ! 216249 216250 216251!MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:18'! 216252testAllNamedFromTo 216253 | pragmasCompiled pragmasDetected | 216254 pragmasCompiled := self pragma: #foo: selector: #bar times: 5. 216255 pragmasDetected := Pragma allNamed: #foo: from: self class to: Object. 216256 self assert: pragmasDetected = pragmasCompiled. 216257 216258 pragmasDetected := Pragma allNamed: #foo: from: Object to: Object. 216259 self assert: pragmasDetected isEmpty.! ! 216260 216261!MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:17'! 216262testAllNamedFromToSortedByArgument 216263 | pragmasCompiled pragmasDetected | 216264 pragmasCompiled := self pragma: #foo: selector: #bar times: 5. 216265 pragmasDetected := Pragma allNamed: #foo: from: self class to: Object sortedByArgument: 1. 216266 self assert: pragmasDetected = (pragmasCompiled 216267 sort: [ :a :b | (a argumentAt: 1) < (b argumentAt: 1) ])! ! 216268 216269!MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:17'! 216270testAllNamedFromToSortedUsing 216271 | pragmasCompiled pragmasDetected | 216272 pragmasCompiled := self pragma: #foo: selector: #bar times: 5. 216273 pragmasDetected := Pragma 216274 allNamed: #foo: from: self class to: Object 216275 sortedUsing: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]. 216276 self assert: pragmasDetected = (pragmasCompiled 216277 sort: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]).! ! 216278 216279!MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:19'! 216280testAllNamedIn 216281 | pragmasCompiled pragmasDetected | 216282 pragmasCompiled := self pragma: #foo: selector: #bar times: 5. 216283 pragmasDetected := Pragma allNamed: #foo: in: self class. 216284 self assert: pragmasDetected = pragmasCompiled. 216285 216286 pragmasDetected := Pragma allNamed: #foo: in: Object. 216287 self assert: pragmasDetected isEmpty.! ! 216288 216289!MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:15'! 216290testAllNamedInSortedByArgument 216291 | pragmasCompiled pragmasDetected | 216292 pragmasCompiled := self pragma: #foo: selector: #bar times: 5. 216293 pragmasDetected := Pragma allNamed: #foo: in: self class sortedByArgument: 1. 216294 self assert: pragmasDetected = (pragmasCompiled 216295 sort: [ :a :b | (a argumentAt: 1) < (b argumentAt: 1) ])! ! 216296 216297!MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/21/2006 13:01'! 216298testAllNamedInSortedUsing 216299 | pragmasCompiled pragmasDetected | 216300 pragmasCompiled := self pragma: #foo: selector: #bar times: 5. 216301 pragmasDetected := Pragma 216302 allNamed: #foo: in: self class 216303 sortedUsing: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]. 216304 self assert: pragmasDetected = (pragmasCompiled 216305 sort: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]).! ! 216306 216307 216308!MethodPragmaTest methodsFor: 'testing-method' stamp: 'lr 1/20/2006 07:54'! 216309testMethod 216310 | pragma | 216311 pragma := self pragma: 'foo' selector: #bar. 216312 self assert: pragma method == (self class >> #bar).! ! 216313 216314!MethodPragmaTest methodsFor: 'testing-method' stamp: 'md 2/18/2006 19:59'! 216315testMethodClass 216316 | pragma | 216317 pragma := self pragma: 'foo' selector: #bar. 216318 self assert: pragma methodClass == self class.! ! 216319 216320!MethodPragmaTest methodsFor: 'testing-method' stamp: 'lr 1/20/2006 07:54'! 216321testSelector 216322 | pragma | 216323 pragma := self pragma: 'foo' selector: #bar. 216324 self assert: pragma selector == #bar.! ! 216325 216326 216327!MethodPragmaTest methodsFor: 'testing-pragma' stamp: 'lr 1/20/2006 00:35'! 216328testArguments 216329 | pragma | 216330 pragma := Pragma keyword: #foo: arguments: #( 123 ). 216331 self assert: pragma arguments = #( 123 ).! ! 216332 216333!MethodPragmaTest methodsFor: 'testing-pragma' stamp: 'lr 1/20/2006 00:35'! 216334testKeyword 216335 | pragma | 216336 pragma := Pragma keyword: #foo: arguments: #( 123 ). 216337 self assert: pragma keyword = #foo:.! ! 216338 216339!MethodPragmaTest methodsFor: 'testing-pragma' stamp: 'lr 1/20/2006 00:36'! 216340testMessage 216341 | pragma message | 216342 pragma := Pragma keyword: #foo: arguments: #( 123 ). 216343 message := pragma message. 216344 216345 self assert: message selector = #foo:. 216346 self assert: message arguments = #( 123 ).! ! 216347 216348 216349!MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'lr 1/20/2006 02:31'! 216350testPrimitiveIndexed1 216351 "This test useses the #instVarAt: primitive." 216352 216353 self compile: '<primitive: 74> ^ #inst' selector: #inst. 216354 self assert: self inst = #inst.! ! 216355 216356!MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'TorstenBergmann 8/19/2009 14:45'! 216357testPrimitiveIndexed2 216358 "This test useses the #identityHash primitive." 216359 216360 self compile: '<primitive: 75> ^ #idHash' selector: #idHash. 216361 self assert: self idHash = self identityHash.! ! 216362 216363!MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'lr 1/20/2006 02:42'! 216364testPrimitiveNamed1 216365 "This test useses the #primitiveDirectoryLookup primitive." 216366 216367 self compile: '<primitive: ''primitiveDirectoryLookup'' module: ''FilePlugin''> ^ #lookup' selector: #lookup. 216368 self assert: self lookup = #lookup. 216369 216370! ! 216371 216372!MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'lr 1/20/2006 02:41'! 216373testPrimitiveNamed2 216374 "This test useses the #primPathNameDelimiter primitive." 216375 216376 self compile: '<primitive: ''primitiveDirectoryDelimitor'' module: ''FilePlugin''> ^ #delim' selector: #delim. 216377 self assert: self delim = FileDirectory primPathNameDelimiter. 216378 216379! ! 216380 216381 216382!MethodPragmaTest methodsFor: 'testing-printing-reformating' stamp: 'md 2/3/2007 11:55'! 216383testReformat 216384 216385 216386 self assert: (DisplayScreen class compiledMethodAt: #actualScreenDepth) getSource string = 'actualScreenDepth 216387 <primitive: ''primitiveScreenDepth''> 216388 ^ Display depth'. 216389 216390 216391 self shouldnt: [ DisplayScreen class reformatMethodAt: #actualScreenDepth] raise: Error. 216392 216393 self assert: (DisplayScreen class compiledMethodAt: #actualScreenDepth) getSource string = 'actualScreenDepth 216394 <primitive: ''primitiveScreenDepth''> 216395 ^ Display depth'. 216396! ! 216397 216398 216399!MethodPragmaTest methodsFor: 'utilities' stamp: 'md 2/18/2006 19:39'! 216400assertPragma: aString givesKeyword: aSymbol arguments: anArray 216401 | pragma decompiled | 216402 pragma := self pragma: aString selector: #zork. 216403 self assert: pragma keyword = aSymbol. 216404 self assert: pragma arguments = anArray. 216405 decompiled := (self class>>#zork) decompile. 216406 self assert: (decompiled properties pragmas includes: pragma). 216407 self assert: (decompiled asString includesSubString: pragma asString).! ! 216408 216409!MethodPragmaTest methodsFor: 'utilities' stamp: 'lr 1/20/2006 02:23'! 216410compile: aString selector: aSelector 216411 self class 216412 compileSilently: aSelector , String lf , aString 216413 classified: self methodCategory. 216414 ^ self class >> aSelector.! ! 216415 216416!MethodPragmaTest methodsFor: 'utilities' stamp: 'lr 1/20/2006 11:50'! 216417methodCategory 216418 ^ #generated! ! 216419 216420!MethodPragmaTest methodsFor: 'utilities' stamp: 'lr 2/6/2006 20:48'! 216421pragma: aString selector: aSelector 216422 ^ (self compile: '<' , aString , '>' selector: aSelector) 216423 pragmas first.! ! 216424 216425!MethodPragmaTest methodsFor: 'utilities' stamp: 'lr 1/20/2006 08:11'! 216426pragma: aSymbol selector: aSelector times: anInteger 216427 ^ (self 216428 compile: (String streamContents: [ :stream | 216429 (1 to: anInteger) asArray shuffled do: [ :each | 216430 stream 216431 nextPut: $<; nextPutAll: aSymbol; space; 216432 print: each; nextPut: $>; cr ] ]) 216433 selector: aSelector) 216434 pragmas.! ! 216435Object subclass: #MethodProperties 216436 instanceVariableNames: 'properties pragmas selector' 216437 classVariableNames: '' 216438 poolDictionaries: '' 216439 category: 'Kernel-Methods'! 216440!MethodProperties commentStamp: 'lr 2/6/2006 19:31' prior: 0! 216441I am class holding state for compiled methods. All my instance variables should be actually part of the CompiledMethod itself, but the current implementation of the VM doesn't allow this. 216442 216443I am a compact class and optimized for size and speed, since every CompiledMethod points onto an instance of myself. I am mostly polymorphic to the protocol of an identity-dictionary, so that key-value pairs can be easily stored and retreived without the need to add new variables. However keep in mind that instantiating a dictionary consumes much more memory than adding an instance-variable, so it might be clever to add a new variable if the property is going to be used by every compiled method.! 216444 216445 216446!MethodProperties methodsFor: 'accessing' stamp: 'ar 2/28/2006 18:30'! 216447pragmas 216448 ^pragmas ifNil:[#()]! ! 216449 216450!MethodProperties methodsFor: 'accessing' stamp: 'ar 2/28/2006 18:31'! 216451pragmas: anArray 216452 pragmas := anArray! ! 216453 216454!MethodProperties methodsFor: 'accessing' stamp: 'ms 8/8/2007 01:50'! 216455properties 216456 216457 ^properties ! ! 216458 216459!MethodProperties methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'! 216460selector 216461 ^selector! ! 216462 216463!MethodProperties methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'! 216464selector: aSymbol 216465 selector := aSymbol! ! 216466 216467 216468!MethodProperties methodsFor: 'copying' stamp: 'md 3/1/2006 15:30'! 216469postCopy 216470 properties := properties copy. 216471 pragmas := pragmas copy. 216472! ! 216473 216474 216475!MethodProperties methodsFor: 'initialization' stamp: 'lr 2/6/2006 19:12'! 216476initialize 216477 super initialize. 216478 pragmas := #().! ! 216479 216480 216481!MethodProperties methodsFor: 'literals' stamp: 'G.C 10/22/2008 09:59'! 216482refersToLiteral: aLiteral 216483 ^ self pragmas anySatisfy: [ :pragma | pragma hasLiteral: aLiteral ]! ! 216484 216485 216486!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 19:04'! 216487at: aKey 216488 "Answer the property value associated with aKey." 216489 216490 ^ self at: aKey ifAbsent: [ self error: 'Property not found' ].! ! 216491 216492!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 20:47'! 216493at: aKey ifAbsentPut: aBlock 216494 "Answer the property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value." 216495 216496 ^ self at: aKey ifAbsent: [ self at: aKey put: aBlock value ].! ! 216497 216498!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 19:07'! 216499at: aKey ifAbsent: aBlock 216500 "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 216501 216502 properties isNil ifTrue: [ ^ aBlock value ]. 216503 ^ properties at: aKey ifAbsent: aBlock.! ! 216504 216505!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 19:06'! 216506at: aKey put: anObject 216507 "Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject." 216508 216509 properties ifNil: [ properties := IdentityDictionary new ]. 216510 ^ properties at: aKey put: anObject.! ! 216511 216512!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 19:11'! 216513includesKey: aKey 216514 "Test if the property aKey is present." 216515 216516 ^ properties notNil and: [ properties includesKey: aKey ].! ! 216517 216518!MethodProperties methodsFor: 'properties' stamp: 'ar 3/8/2006 00:24'! 216519keysAndValuesDo: aBlock 216520 "Enumerate the receiver with all the keys and values." 216521 ^properties ifNotNil:[properties keysAndValuesDo: aBlock]! ! 216522 216523!MethodProperties methodsFor: 'properties' stamp: 'eem 9/5/2009 15:01'! 216524propertyKeysAndValuesDo: aBlock 216525 "Enumerate the receiver with all the keys and values." 216526 ^properties ifNotNil:[properties keysAndValuesDo: aBlock]! ! 216527 216528!MethodProperties methodsFor: 'properties' stamp: 'eem 12/1/2008 17:49'! 216529propertyValueAt: aKey ifAbsent: aBlock 216530 "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 216531 ^self at: aKey ifAbsent: aBlock! ! 216532 216533!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 20:48'! 216534removeKey: aKey 216535 "Remove the property with aKey. Answer the property or raise an error if aKey isn't found." 216536 216537 ^ self removeKey: aKey ifAbsent: [ self error: 'Property not found' ].! ! 216538 216539!MethodProperties methodsFor: 'properties' stamp: 'lr 2/6/2006 19:07'! 216540removeKey: aKey ifAbsent: aBlock 216541 "Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock." 216542 216543 | answer | 216544 properties isNil ifTrue: [ ^ aBlock value ]. 216545 answer := properties removeKey: aKey ifAbsent: aBlock. 216546 properties isEmpty ifTrue: [ properties := nil ]. 216547 ^ answer.! ! 216548 216549 216550!MethodProperties methodsFor: 'testing' stamp: 'md 8/20/2007 13:36'! 216551= other 216552 self class == other class ifFalse: [^false]. 216553 self pragmas = other pragmas ifFalse:[^false]. 216554 self selector = other selector ifFalse:[^false]. 216555 self properties = other properties ifFalse:[^false]. 216556 ^true! ! 216557 216558!MethodProperties methodsFor: 'testing' stamp: 'NikoSchwarz 10/17/2009 17:53'! 216559analogousCodeTo: aMethodProperties 216560 pragmas 216561 ifNil: [aMethodProperties pragmas notEmpty ifTrue: [^false]] 216562 ifNotNil: 216563 [aMethodProperties pragmas isEmpty ifTrue: [^false]. 216564 pragmas size ~= aMethodProperties pragmas size ifTrue: 216565 [^false]. 216566 pragmas with: aMethodProperties pragmas do: 216567 [:mine :others| 216568 (mine analogousCodeTo: others) ifFalse: [^false]]]. 216569 ^(self hasAtLeastTheSamePropertiesAs: aMethodProperties) 216570 and: [aMethodProperties hasAtLeastTheSamePropertiesAs: self]! ! 216571 216572!MethodProperties methodsFor: 'testing' stamp: 'eem 5/15/2008 09:25'! 216573hasAtLeastTheSamePropertiesAs: aMethodProperties 216574 "Answer if the recever has at least the same properties as the argument. 216575 N.B. The receiver may have additional properties and still answer true." 216576 aMethodProperties keysAndValuesDo: 216577 [:k :v| 216578 properties ifNil: [^false]. 216579 ^(properties at: k ifAbsent: [^false]) = v]. 216580 ^true! ! 216581 216582!MethodProperties methodsFor: 'testing' stamp: 'eem 12/3/2008 11:00'! 216583hasLiteralSuchThat: aBlock 216584 "Answer true if litBlock returns true for any literal in this array, even if embedded in further array structure. 216585 This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" 216586 properties ifNil:[^false]. 216587 properties keysAndValuesDo: [:key :value | 216588 ((aBlock value: key) 216589 or: [(aBlock value: value) 216590 or: [value isArray 216591 and: [value hasLiteralSuchThat: aBlock]]]) ifTrue: [^true]]. 216592 ^false! ! 216593 216594!MethodProperties methodsFor: 'testing' stamp: 'ar 3/7/2006 16:35'! 216595hasLiteralThorough: literal 216596 "Answer true if any literal in this method is literal, 216597 even if embedded in array structure." 216598 properties ifNil:[^false]. 216599 properties keysAndValuesDo: [:key :value | 216600 key == literal ifTrue: [^true]. 216601 value == literal ifTrue:[^true]. 216602 (value class == Array and: [value hasLiteral: literal]) ifTrue: [^ true]]. 216603 ^false! ! 216604 216605!MethodProperties methodsFor: 'testing' stamp: 'eem 11/29/2008 13:48'! 216606isEmpty 216607 ^(properties isNil or: [properties isEmpty]) 216608 and: [pragmas isNil or: [pragmas isEmpty]]! ! 216609 216610!MethodProperties methodsFor: 'testing' stamp: 'md 2/19/2006 11:24'! 216611isMethodProperties 216612 ^true! ! 216613 216614!MethodProperties methodsFor: 'testing' stamp: 'eem 12/1/2008 16:49'! 216615notEmpty 216616 ^(properties notNil and: [properties notEmpty]) 216617 or: [pragmas notNil and: [pragmas notEmpty]]! ! 216618 216619!MethodProperties methodsFor: 'testing' stamp: 'StephaneDucasse 8/30/2009 16:26'! 216620propertiesIsNil 216621 216622 ^ properties isNil! ! 216623 216624 216625!MethodProperties methodsFor: 'private' stamp: 'ar 2/28/2006 18:30'! 216626addPragma: aPragma 216627 pragmas := self pragmas copyWith: aPragma.! ! 216628 216629 216630!MethodProperties methodsFor: 'forward compatibility' stamp: 'eem 9/5/2009 15:09'! 216631method: ignored 216632 "For forward compatibility wth AdditionalMethodState, for decompilation"! ! 216633 216634!MethodProperties methodsFor: 'forward compatibility' stamp: 'eem 9/5/2009 14:31'! 216635setMethod: ignored 216636 "For forward compatibility wth AdditionalMethodState"! ! 216637 216638"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 216639 216640MethodProperties class 216641 instanceVariableNames: ''! 216642 216643!MethodProperties class methodsFor: 'class initialization' stamp: 'lr 2/6/2006 22:06'! 216644initialize 216645 self becomeCompact.! ! 216646TestCase subclass: #MethodPropertiesTest 216647 instanceVariableNames: 'method' 216648 classVariableNames: '' 216649 poolDictionaries: '' 216650 category: 'KernelTests-Methods'! 216651 216652!MethodPropertiesTest methodsFor: 'running' stamp: 'MikeRoberts 9/26/2009 16:56'! 216653expectedFailures 216654 "The new closure compiler does not use MethodProperties. These tests end up performing 216655 their assertions on AdditionalMethodState." 216656 216657 ^#(testAt testAtIfAbsent testIncludesKey testRemoveKey testRemoveKeyifAbsent)! ! 216658 216659!MethodPropertiesTest methodsFor: 'running' stamp: 'lr 1/20/2006 19:16'! 216660setUp 216661 method := Object >> #halt.! ! 216662 216663!MethodPropertiesTest methodsFor: 'running' stamp: 'lr 1/20/2006 19:20'! 216664tearDown 216665 Object recompile: #halt from: Object.! ! 216666 216667 216668!MethodPropertiesTest methodsFor: 'testing' stamp: 'kwl 7/26/2006 11:41'! 216669testAllMethodsHaveMethodClass 216670 Smalltalk garbageCollect. 216671 self assert: (CompiledMethod allInstances 216672 reject: [:cm | cm literals last isVariableBinding 216673 and: [cm literals last value isBehavior 216674 or: [cm literals last value isTrait]]]) isEmpty 216675 description: 'CompiledMethods must have methodClass literal'! ! 216676 216677!MethodPropertiesTest methodsFor: 'testing' stamp: 'kwl 7/26/2006 11:40'! 216678testAllMethodsHaveNewPropertyFormat 216679 Smalltalk garbageCollect. 216680 self assert: (CompiledMethod allInstances 216681 reject: [:cm | cm hasNewPropertyFormat]) isEmpty 216682 description: 'CompiledMethods must have new property format'! ! 216683 216684!MethodPropertiesTest methodsFor: 'testing' stamp: 'StephaneDucasse 8/30/2009 16:50'! 216685testAnalogousCodeTo 216686 "self debug: #testAnalogousCodeTo" 216687 216688 method properties at: #zork put: 'hello'. 216689 self assert: (method = method). 216690 ! ! 216691 216692!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:21'! 216693testAt 216694 self should: [ method properties at: #zork ] raise: Error. 216695 self assert: (self propertyDictionaryFor: method) isNil. 216696 method properties at: #zork put: 'hello'. 216697 self assert: (method properties at: #zork) = 'hello'.! ! 216698 216699!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:18'! 216700testAtIfAbsent 216701 self assert: (method properties at: #zork ifAbsent: [ 'hello' ]) = 'hello'. 216702 self assert: (self propertyDictionaryFor: method) isNil. 216703 method properties at: #zork put: 'hi'. 216704 self assert: (method properties at: #zork ifAbsent: [ 'hello' ]) = 'hi'.! ! 216705 216706!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:18'! 216707testAtIfAbsentPut 216708 self assert: (method properties at: #zork ifAbsentPut: [ 'hello' ]) = 'hello'. 216709 self assert: (method properties at: #zork ifAbsentPut: [ 'hi' ]) = 'hello'.! ! 216710 216711!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:18'! 216712testAtPut 216713 self assert: (method properties at: #zork put: 'hello') = 'hello'. 216714 self assert: (method properties at: #zork) = 'hello'.! ! 216715 216716!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:19'! 216717testIncludesKey 216718 self deny: (method properties includesKey: #zork). 216719 self assert: (self propertyDictionaryFor: method) isNil. 216720 method properties at: #zork put: 123. 216721 self assert: (method properties includesKey: #zork).! ! 216722 216723!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:18'! 216724testRemoveKey 216725 method properties at: #zork put: 'hello'. 216726 self should: [ method properties removeKey: #halt ] raise: Error. 216727 self assert: (method properties removeKey: #zork) = 'hello'. 216728 self assert: (self propertyDictionaryFor: method) isNil. 216729 self should: [ method properties removeKey: #zork ] raise: Error. 216730 self assert: (self propertyDictionaryFor: method) isNil.! ! 216731 216732!MethodPropertiesTest methodsFor: 'testing' stamp: 'lr 2/6/2006 22:18'! 216733testRemoveKeyifAbsent 216734 method properties at: #zork put: 'hello'. 216735 self assert: (method properties removeKey: #halt ifAbsent: [ 'hi' ]) = 'hi'. 216736 self assert: (method properties removeKey: #zork ifAbsent: [ 'hi' ]) = 'hello'. 216737 self assert: (self propertyDictionaryFor: method) isNil. 216738 self should: (method properties removeKey: #zork ifAbsent: [ 'hi' ]) = 'hi'. 216739 self assert: (self propertyDictionaryFor: method) isNil.! ! 216740 216741 216742!MethodPropertiesTest methodsFor: 'private' stamp: 'lr 2/6/2006 20:43'! 216743propertyDictionaryFor: aMethod 216744 ^ aMethod properties instVarNamed: 'properties'.! ! 216745Object subclass: #MethodReference 216746 instanceVariableNames: 'classSymbol classIsMeta methodSymbol stringVersion category package' 216747 classVariableNames: '' 216748 poolDictionaries: '' 216749 category: 'System-Tools'! 216750!MethodReference commentStamp: 'tlk 5/9/2006 18:43' prior: 0! 216751A MethodReference is is a lightweight proxy for a CompiledMethod. Has methods for pointed to the CompileMethod's source statements, byte codes. Is heavily used my Tools. 216752 216753Instance Variables 216754 classIsMeta: Boolean class vs. instance 216755 classSymbol: Symbol for method's class (without class keyword if meta) 216756 methodSymbol: Symbol for method's selector 216757 stringVersion: 'Class>>selector:' format 216758 216759! 216760 216761 216762!MethodReference methodsFor: '*Kernel-Traits' stamp: 'stephane.ducasse 8/5/2009 12:46'! 216763actualClass 216764 216765 | actualClass traitName| 216766 ('*classTrait' match: classSymbol) 216767 ifTrue: [ traitName := classSymbol copyUpTo: Character space. 216768 ^ Smalltalk at: traitName asSymbol ifAbsent: [nil]]. 216769 actualClass := Smalltalk at: classSymbol ifAbsent: [^nil]. 216770 classIsMeta ifTrue: [^actualClass classSide]. 216771 ^actualClass! ! 216772 216773 216774!MethodReference methodsFor: '*fixunderscores' stamp: 'stephane.ducasse 2/28/2009 22:35'! 216775fixLFInvisible 216776 "Replace invisible with space. Answer true if fixed or no fix necessary, false if manual fix required" 216777 216778 | src ts | 216779 "Check if we do need to do anything" 216780 src := self actualClass sourceCodeAt: methodSymbol. 216781 (src includes: Character lf) ifFalse: [^true]. 216782 216783 "Chicken out if there is a literal underscore" 216784 "cm := self actualClass compiledMethodAt: methodSymbol. 216785 (cm hasLiteralSuchThat: [:lit | 216786 lit = Character lf or: [lit isString and: [lit includes: Character lf]]]) ifTrue: [^false]." 216787 216788 "Otherwise, replace underscores with :=" 216789 src := src copyReplaceAll: Character lf asString with: Character space asString, Character cr asString. 216790 ts := self timeStamp. 216791 ts = '' ifTrue: [ts := nil]. 216792 self actualClass 216793 compile: src 216794 classified: ClassOrganizer default 216795 withStamp: ts 216796 notifying: nil. 216797 216798 ^true 216799! ! 216800 216801!MethodReference methodsFor: '*fixunderscores' stamp: 'cmm 5/1/2006 19:38'! 216802fixUnderscores 216803 "Replace underscores with :=. Answer true if fixed or no fix necessary, false if manual fix required" 216804 216805 | src cm ts | 216806 "Check if we do need to do anything" 216807 src := self actualClass sourceCodeAt: methodSymbol. 216808 (src includes: $_) ifFalse: [^true]. 216809 216810 "Chicken out if there is a literal underscore" 216811 cm := self actualClass compiledMethodAt: methodSymbol. 216812 (cm hasLiteralSuchThat: [:lit | 216813 lit = $_ or: [lit isString and: [lit includes: $_]]]) ifTrue: [^false]. 216814 216815 "Otherwise, replace underscores with :=" 216816 src := src copyReplaceAll: '_' with: ':='. 216817 ts := self timeStamp. 216818 ts = '' ifTrue: [ts := nil]. 216819 self actualClass 216820 compile: src 216821 classified: ClassOrganizer default 216822 withStamp: ts 216823 notifying: nil. 216824 216825 ^true 216826! ! 216827 216828 216829!MethodReference methodsFor: '*monticello' stamp: 'ab 8/22/2003 17:55'! 216830asMethodDefinition 216831 ^ MCMethodDefinition forMethodReference: self! ! 216832 216833!MethodReference methodsFor: '*monticello' stamp: 'ab 8/22/2003 17:58'! 216834compiledMethod 216835 ^ self actualClass compiledMethodAt: methodSymbol! ! 216836 216837!MethodReference methodsFor: '*monticello' stamp: 'al 10/9/2005 20:05'! 216838isLocalSelector 216839 ^self actualClass 216840 includesLocalSelector: self methodSymbol! ! 216841 216842!MethodReference methodsFor: '*monticello' stamp: 'ab 8/22/2003 17:59'! 216843source 216844 ^ (self actualClass sourceCodeAt: methodSymbol) asString withSqueakLineEndings! ! 216845 216846!MethodReference methodsFor: '*monticello' stamp: 'ab 8/22/2003 17:58'! 216847timeStamp 216848 ^ self compiledMethod timeStamp! ! 216849 216850 216851!MethodReference methodsFor: '*packageinfo-base' stamp: 'ab 5/23/2003 22:58'! 216852sourceCode 216853 ^ self actualClass sourceCodeAt: methodSymbol! ! 216854 216855 216856!MethodReference methodsFor: 'accessing' stamp: 'stephane.ducasse 6/2/2009 16:02'! 216857methodClass 216858 216859 ^ self actualClass ! ! 216860 216861!MethodReference methodsFor: 'accessing' stamp: 'stephane.ducasse 7/8/2009 11:26'! 216862package 216863 "we will have to change that in the future since we will not rely on * convention" 216864 216865 ^ package! ! 216866 216867!MethodReference methodsFor: 'accessing' stamp: 'stephane.ducasse 7/8/2009 11:27'! 216868package: aPackage 216869 216870 package := aPackage! ! 216871 216872!MethodReference methodsFor: 'accessing' stamp: 'stephane.ducasse 7/22/2009 11:47'! 216873selector 216874 216875 ^ methodSymbol! ! 216876 216877 216878!MethodReference methodsFor: 'comparisons' stamp: 'dgd 3/8/2003 11:54'! 216879hash 216880 "Answer a SmallInteger whose value is related to the receiver's 216881 identity." 216882 ^ (self species hash bitXor: self classSymbol hash) 216883 bitXor: self methodSymbol hash! ! 216884 216885!MethodReference methodsFor: 'comparisons' stamp: 'RAA 5/28/2001 11:56'! 216886<= anotherMethodReference 216887 216888 classSymbol < anotherMethodReference classSymbol ifTrue: [^true]. 216889 classSymbol > anotherMethodReference classSymbol ifTrue: [^false]. 216890 classIsMeta = anotherMethodReference classIsMeta ifFalse: [^classIsMeta not]. 216891 ^methodSymbol <= anotherMethodReference methodSymbol 216892! ! 216893 216894!MethodReference methodsFor: 'comparisons' stamp: 'dgd 3/7/2003 13:18'! 216895= anotherMethodReference 216896 "Answer whether the receiver and the argument represent the 216897 same object." 216898 ^ self species == anotherMethodReference species 216899 and: [self classSymbol = anotherMethodReference classSymbol] 216900 and: [self classIsMeta = anotherMethodReference classIsMeta] 216901 and: [self methodSymbol = anotherMethodReference methodSymbol]! ! 216902 216903 216904!MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 06:19'! 216905asStringOrText 216906 216907 ^stringVersion! ! 216908 216909!MethodReference methodsFor: 'queries' stamp: 'stephane.ducasse 10/12/2008 20:01'! 216910category 216911 ^ category ifNil: [category := self actualClass organization categoryOfElement: methodSymbol]! ! 216912 216913!MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 08:11'! 216914classIsMeta 216915 216916 ^classIsMeta! ! 216917 216918!MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 08:10'! 216919classSymbol 216920 216921 ^classSymbol! ! 216922 216923!MethodReference methodsFor: 'queries' stamp: 'md 8/27/2005 17:17'! 216924isValid 216925 "Answer whether the receiver represents a current selector or Comment" 216926 216927 | aClass | 216928 methodSymbol isDoIt ifTrue: [^ false]. 216929 (aClass := self actualClass) ifNil: [^ false]. 216930 ^ (aClass includesSelector: methodSymbol) or: 216931 [methodSymbol == #Comment]! ! 216932 216933!MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 08:10'! 216934methodSymbol 216935 216936 ^methodSymbol! ! 216937 216938!MethodReference methodsFor: 'queries' stamp: 'stephane.ducasse 10/27/2008 20:40'! 216939printOn: aStream 216940 "Print the receiver on a stream" 216941 216942 super printOn: aStream. 216943 aStream nextPutAll: ' ', self actualClass name, ' >> #', methodSymbol! ! 216944 216945!MethodReference methodsFor: 'queries' stamp: 'sr 6/4/2004 01:55'! 216946sourceString 216947 ^ (self actualClass sourceCodeAt: self methodSymbol) asString! ! 216948 216949 216950!MethodReference methodsFor: 'setting' stamp: 'RAA 5/28/2001 07:34'! 216951setClassAndSelectorIn: csBlock 216952 216953 ^csBlock value: self actualClass value: methodSymbol! ! 216954 216955!MethodReference methodsFor: 'setting' stamp: 'RAA 5/28/2001 06:04'! 216956setClassSymbol: classSym classIsMeta: isMeta methodSymbol: methodSym stringVersion: aString 216957 216958 classSymbol := classSym. 216959 classIsMeta := isMeta. 216960 methodSymbol := methodSym. 216961 stringVersion := aString.! ! 216962 216963!MethodReference methodsFor: 'setting' stamp: 'RAA 5/28/2001 08:06'! 216964setClass: aClass methodSymbol: methodSym stringVersion: aString 216965 216966 classSymbol := aClass theNonMetaClass name. 216967 classIsMeta := aClass isMeta. 216968 methodSymbol := methodSym. 216969 stringVersion := aString.! ! 216970 216971!MethodReference methodsFor: 'setting' stamp: 'RAA 5/28/2001 11:34'! 216972setStandardClass: aClass methodSymbol: methodSym 216973 216974 classSymbol := aClass theNonMetaClass name. 216975 classIsMeta := aClass isMeta. 216976 methodSymbol := methodSym. 216977 stringVersion := aClass name , ' ' , methodSym.! ! 216978 216979 216980!MethodReference methodsFor: 'string version' stamp: 'stephane.ducasse 10/12/2008 20:08'! 216981category: aString 216982 216983 category := aString! ! 216984 216985!MethodReference methodsFor: 'string version' stamp: 'RAA 5/29/2001 14:44'! 216986stringVersion 216987 216988 ^stringVersion! ! 216989 216990!MethodReference methodsFor: 'string version' stamp: 'RAA 5/29/2001 14:44'! 216991stringVersion: aString 216992 216993 stringVersion := aString! ! 216994 216995"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 216996 216997MethodReference class 216998 instanceVariableNames: ''! 216999 217000!MethodReference class methodsFor: 'Package' stamp: 'stephane.ducasse 7/10/2009 09:27'! 217001class: aClass selector: aSelector package: aPackage 217002 217003 ^ (self class: aClass selector: aSelector ) package: aPackage ; yourself! ! 217004 217005 217006!MethodReference class methodsFor: 'instance creation' stamp: 'ab 2/6/2005 16:22'! 217007class: aClass selector: aSelector 217008 ^ self new setStandardClass: aClass methodSymbol: aSelector! ! 217009ClassTestCase subclass: #MethodReferenceTest 217010 instanceVariableNames: '' 217011 classVariableNames: '' 217012 poolDictionaries: '' 217013 category: 'Tests-Browser'! 217014 217015!MethodReferenceTest methodsFor: 'running' stamp: 'sd 11/20/2005 21:27'! 217016testEquals 217017 | aMethodReference anotherMethodReference | 217018 aMethodReference := MethodReference new. 217019 anotherMethodReference := MethodReference new. 217020 " 217021 two fresh instances should be equals between them" 217022 self 217023 should: [aMethodReference = anotherMethodReference]. 217024 self 217025 should: [aMethodReference hash = anotherMethodReference hash]. 217026 " 217027 two instances representing the same method (same class and 217028 same selector) should be equals" 217029 aMethodReference setStandardClass: String methodSymbol: #foo. 217030 anotherMethodReference setStandardClass: String methodSymbol: #foo. 217031 self 217032 should: [aMethodReference = anotherMethodReference]. 217033 self 217034 should: [aMethodReference hash = anotherMethodReference hash] ! ! 217035 217036!MethodReferenceTest methodsFor: 'running' stamp: 'sd 11/20/2005 21:27'! 217037testNotEquals 217038 | aMethodReference anotherMethodReference | 217039 aMethodReference := MethodReference new. 217040 anotherMethodReference := MethodReference new. 217041 "" 217042 aMethodReference setStandardClass: String methodSymbol: #foo. 217043 anotherMethodReference setStandardClass: String class methodSymbol: #foo. 217044 " 217045 differente classes, same selector -> no more equals" 217046 self 217047 shouldnt: [aMethodReference = anotherMethodReference]. 217048 " 217049 same classes, diferente selector -> no more equals" 217050 anotherMethodReference setStandardClass: String methodSymbol: #bar. 217051 self 217052 shouldnt: [aMethodReference = anotherMethodReference] ! ! 217053ParseNode subclass: #MethodTempsNode 217054 instanceVariableNames: 'temporaries' 217055 classVariableNames: '' 217056 poolDictionaries: '' 217057 category: 'Compiler-ParseNodes'! 217058Object subclass: #MidiPrimTester 217059 instanceVariableNames: 'port' 217060 classVariableNames: 'CanSetClock CanUseSemaphore ClockTicksPerSec EchoOn EventsAvailable FlushDriver HasBuffer HasDurs HasInputClock Installed UseControllerCache Version' 217061 poolDictionaries: '' 217062 category: 'System-Serial Port'! 217063!MidiPrimTester commentStamp: '<historical>' prior: 0! 217064This class simply demonstrates and tests the MIDI primitives. MIDI applications should use Stephen Pope's MIDIPort class, which will replace this one. 217065 217066The Macintosh, and perhaps some other platforms, can send and receive MIDI data over a serial port by using an external clock signal supplied by an external MIDI adapter to generate the correct MIDI baud rate. Typical clock speeds of such adapters are 1, 2, or 0.5 MHz. This clock speed can be specified when a MIDI port is opened. On other platforms, this clock speed parameter is ignored. 217067! 217068 217069 217070!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 217071primMIDIClosePort: portNum 217072 217073 <primitive: 'primitiveMIDIClosePort' module: 'MIDIPlugin'> 217074 self primitiveFailed. 217075! ! 217076 217077!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 217078primMIDIGetClock 217079 217080 <primitive: 'primitiveMIDIGetClock' module: 'MIDIPlugin'> 217081 self primitiveFailed. 217082! ! 217083 217084!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 217085primMIDIGetPortCount 217086 217087 <primitive: 'primitiveMIDIGetPortCount' module: 'MIDIPlugin'> 217088 self primitiveFailed. 217089! ! 217090 217091!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 217092primMIDIGetPortDirectionality: portNum 217093 217094 <primitive: 'primitiveMIDIGetPortDirectionality' module: 'MIDIPlugin'> 217095 self primitiveFailed. 217096! ! 217097 217098!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 217099primMIDIGetPortName: portNum 217100 217101 <primitive: 'primitiveMIDIGetPortName' module: 'MIDIPlugin'> 217102 self primitiveFailed. 217103! ! 217104 217105!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 217106primMIDIOpenPort: portNum readSemaIndex: readSemaIndex interfaceClockRate: interfaceClockRate 217107 "Open the given MIDI port. If non-zero, readSemaIndex specifies the index in the external objects array of a semaphore to be signalled when incoming MIDI data is available. Not all platforms support signalling the read semaphore. InterfaceClockRate specifies the clock rate of the external MIDI interface adaptor on Macintosh computers; it is ignored on other platforms." 217108 217109 <primitive: 'primitiveMIDIOpenPort' module: 'MIDIPlugin'> 217110 self primitiveFailed. 217111! ! 217112 217113!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 217114primMIDIParameterGet: whichParameter 217115 217116 <primitive: 'primitiveMIDIParameterGetOrSet' module: 'MIDIPlugin'> 217117 self primitiveFailed. 217118! ! 217119 217120!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 217121primMIDIParameterSet: whichParameter to: newValue 217122 217123 <primitive: 'primitiveMIDIParameterGetOrSet' module: 'MIDIPlugin'> 217124 self primitiveFailed. 217125! ! 217126 217127!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 217128primMIDIReadPort: portNum into: byteArray 217129 217130 <primitive: 'primitiveMIDIRead' module: 'MIDIPlugin'> 217131 self primitiveFailed. 217132! ! 217133 217134!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 217135primMIDIWritePort: portNum from: byteArray at: midiClockValue 217136 217137 <primitive: 'primitiveMIDIWrite' module: 'MIDIPlugin'> 217138 self primitiveFailed. 217139! ! 217140 217141 217142!MidiPrimTester methodsFor: 'tests' stamp: 'PeterHugossonMiller 9/3/2009 10:04'! 217143getDriverParameters 217144 "Return a string that describes this platform's MIDI parameters." 217145 "MidiPrimTester new getDriverParameters" 217146 217147 | s parameterNames v | 217148 parameterNames := #(Installed Version HasBuffer HasDurs CanSetClock CanUseSemaphore EchoOn UseControllerCache EventsAvailable FlushDriver ClockTicksPerSec HasInputClock). 217149 217150 s := String new writeStream. 217151 s cr. 217152 1 to: parameterNames size do: [:i | 217153 v := self primMIDIParameterGet: i. 217154 s nextPutAll: (parameterNames at: i). 217155 s nextPutAll: ' = '. 217156 s print: v; cr]. 217157 217158 s nextPutAll: 'MIDI Echoing is '. 217159 (self canTurnOnParameter: EchoOn) 217160 ifTrue: [s nextPutAll: 'supported.'; cr] 217161 ifFalse: [s nextPutAll: 'not supported.'; cr]. 217162 217163 s nextPutAll: 'Controller Caching is '. 217164 (self canTurnOnParameter: UseControllerCache) 217165 ifTrue: [s nextPutAll: 'supported.'; cr] 217166 ifFalse: [s nextPutAll: 'not supported.'; cr]. 217167 217168 ^ s contents 217169! ! 217170 217171!MidiPrimTester methodsFor: 'tests' stamp: 'PeterHugossonMiller 9/3/2009 10:04'! 217172getInputForSeconds: seconds onPort: portNum 217173 "Collect MIDI input from the given port for the given number of seconds, and answer a string describing the data read." 217174 "MidiPrimTester new getInputForSeconds: 5 onPort: 0" 217175 217176 | buf bufList endTime n midiStartTime s t | 217177 "collect the data" 217178 self openPort: portNum andDo: [ 217179 buf := ByteArray new: 1000. 217180 bufList := OrderedCollection new. 217181 midiStartTime := self primMIDIGetClock. 217182 endTime := Time millisecondClockValue + (seconds * 1000). 217183 [Time millisecondClockValue < endTime] whileTrue: [ 217184 n := self primMIDIReadPort: portNum into: buf. 217185 n > 0 ifTrue: [bufList add: (buf copyFrom: 1 to: n)]. 217186 (Delay forMilliseconds: 5) wait]]. 217187 217188 "format the data into a string" 217189 s := String new writeStream. 217190 s cr. 217191 bufList do: [:b | 217192 t := (self bufferTimeStampFrom: b) - midiStartTime. 217193 s print: t. 217194 s nextPutAll: ': '. 217195 5 to: b size do: [:i | s print: (b at: i); space]. 217196 s cr]. 217197 ^ s contents 217198! ! 217199 217200!MidiPrimTester methodsFor: 'tests' stamp: 'PeterHugossonMiller 9/3/2009 10:04'! 217201getPortList 217202 "Return a string that describes this platform's MIDI ports." 217203 "MidiPrimTester new getPortList" 217204 217205 | s portCount dir directionString | 217206 s := String new writeStream. 217207 s cr; nextPutAll: 'MIDI Ports:'; cr. 217208 portCount := self primMIDIGetPortCount. 217209 0 to: portCount - 1 do: [:i | 217210 s tab. 217211 s print: i; nextPutAll: ': '. 217212 s nextPutAll: (self primMIDIGetPortName: i). 217213 dir := self primMIDIGetPortDirectionality: i. 217214 directionString := dir printString. "default" 217215 dir = 1 ifTrue: [directionString := '(in)']. 217216 dir = 2 ifTrue: [directionString := '(out)']. 217217 dir = 3 ifTrue: [directionString := '(in/out)']. 217218 s space; nextPutAll: directionString; cr]. 217219 ^ s contents 217220! ! 217221 217222!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 11:24'! 217223playDrumRoll: mSecsBetweenNotes count: tapCount onPort: portNum 217224 "MidiPrimTester new playDrumRoll: 75 count: 64 onPort: 0" 217225 "Play middle-C tapCount times with the given space between notes. This example works best with a short percussive voice, like a drum." 217226 "Details: This test can be used to investigate the real-time performance of your system. On a 110 MHz PowerPC Mac, this method can genererate very fast and smooth drum rolls up to about 100 beats/sec (10 mSecs between notes). However, many factors can prevent one from seeing this level of performance including a slow CPU, lack of a level-2 cache, networking or other background processes stealing chunks of processor time from Squeak, or a sluggish MIDI synthesizer." 217227 "Details: By default, this method does an incremental GC on every note. While not really needed for this example, it illustrates a useful technique for real-time processing in Squeak: do an incremental GC when you know you have a few milliseconds of idle time to avoid triggering one during a time-critical task. In this case, we're also using the GC time to provide a small delay between the note-on and note-off events. If the GC time is too short, as it could be on a fast machine, the note may not sound at all unless you add a few milliseconds of additional delay!!" 217228 "Note: This example works best if the VM's millisecond clock has 1 millisecond resolution." 217229 217230 | gcDuringNote noteOn noteOff endTime waitTime | 217231 gcDuringNote := true. 217232 "these events use running status, so the command byte is omitted" 217233 noteOn := #(60 100) as: ByteArray. 217234 noteOff := #(60 0) as: ByteArray. 217235 self primMIDIOpenPort: portNum readSemaIndex: 0 interfaceClockRate: 1000000. 217236 217237 "send an initial event with command byte to initiate running status" 217238 self primMIDIWritePort: portNum from: (#(144 60 0) as: ByteArray) at: 0. 217239 217240 1 to: tapCount do: [:i | 217241 endTime := Time millisecondClockValue + mSecsBetweenNotes. 217242 self primMIDIWritePort: portNum from: noteOn at: 0. 217243 gcDuringNote 217244 ifTrue: [ 217245 "do quick GC; takes a few milliseconds and provides the note-down time" 217246 "Note: if GC is too fast on your machine, you need to add a few mSecs delay!!" 217247 Smalltalk garbageCollectMost] 217248 ifFalse: [(Delay forMilliseconds: 3) wait]. 217249 217250 self primMIDIWritePort: portNum from: noteOff at: 0. 217251 waitTime := endTime - Time millisecondClockValue. 217252 waitTime > 0 ifTrue: [(Delay forMilliseconds: waitTime) wait]]. 217253 217254 self primMIDIClosePort: portNum. 217255! ! 217256 217257!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 15:16'! 217258playNoteOnPort: portNum 217259 "MidiPrimTester new playNoteOnPort: 0" 217260 217261 | noteOn noteOff bytesWritten | 217262 noteOn := #(144 60 100) as: ByteArray. 217263 noteOff := #(144 60 0) as: ByteArray. 217264 self openPort: portNum andDo: [ 217265 bytesWritten := self primMIDIWritePort: portNum from: noteOn at: 0. 217266 (Delay forMilliseconds: 500) wait. 217267 bytesWritten := bytesWritten + (self primMIDIWritePort: portNum from: noteOff at: 0)]. 217268 217269 bytesWritten = 6 ifFalse: [self error: 'not all bytes were sent']. 217270! ! 217271 217272!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 15:17'! 217273playScale: mSecsPerNote onPort: portNum 217274 "MidiPrimTester new playScale: 130 onPort: 0" 217275 217276 | noteOn noteOff | 217277 noteOn := #(144 0 100) as: ByteArray. 217278 noteOff := #(144 0 0) as: ByteArray. 217279 self openPort: portNum andDo: [ 217280 #(60 62 64 65 67 69 71 72 74 72 71 69 67 65 64 62 60) do: [:midiKey | 217281 noteOn at: 2 put: midiKey. 217282 noteOff at: 2 put: midiKey. 217283 self primMIDIWritePort: portNum from: noteOn at: 0. 217284 (Delay forMilliseconds: mSecsPerNote - 10) wait. 217285 self primMIDIWritePort: portNum from: noteOff at: 0. 217286 (Delay forMilliseconds: 10) wait]]. 217287! ! 217288 217289 217290!MidiPrimTester methodsFor: 'private' stamp: 'jm 5/18/1998 12:48'! 217291bufferTimeStampFrom: aByteArray 217292 "Return the timestamp from the given MIDI input buffer. Assume the given buffer is at least 4 bytes long." 217293 217294 ^ ((aByteArray at: 1) bitShift: 24) + 217295 ((aByteArray at: 2) bitShift: 16) + 217296 ((aByteArray at: 3) bitShift: 8) + 217297 (aByteArray at: 4) 217298! ! 217299 217300!MidiPrimTester methodsFor: 'private' stamp: 'jm 5/18/1998 12:48'! 217301canTurnOnParameter: whichParameter 217302 "Return true if the given MIDI parameter can be turned on. Leave the parameter in its orginal state." 217303 217304 | old canSet | 217305 old := self primMIDIParameterGet: whichParameter. 217306 self primMIDIParameterSet: whichParameter to: 1. 217307 canSet := (self primMIDIParameterGet: whichParameter) = 1. 217308 self primMIDIParameterSet: whichParameter to: old. 217309 ^ canSet 217310! ! 217311 217312!MidiPrimTester methodsFor: 'private' stamp: 'jm 5/18/1998 15:32'! 217313openPort: portNum andDo: aBlock 217314 "Open the given MIDI port, evaluate the block, and close the port again. Answer the value of the block." 217315 217316 | result | 217317 self primMIDIClosePort: portNum. 217318 self primMIDIOpenPort: portNum readSemaIndex: 0 interfaceClockRate: 1000000. 217319 result := aBlock value. 217320 self primMIDIClosePort: portNum. 217321 ^ result 217322! ! 217323 217324"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 217325 217326MidiPrimTester class 217327 instanceVariableNames: ''! 217328 217329!MidiPrimTester class methodsFor: 'initialization' stamp: 'yo 12/3/2004 17:05'! 217330initialize 217331 "Initialize the MIDI parameter constants." 217332 "MidiPrimTester initialize" 217333 217334 Installed := 1. 217335 "Read-only. Return 1 if a MIDI driver is installed, 0 if not. 217336 On OMS-based MIDI drivers, this returns 1 only if the OMS 217337 system is properly installed and configured." 217338 217339 Version := 2. 217340 "Read-only. Return the integer version number of this MIDI driver. 217341 The version numbering sequence is relative to a particular driver. 217342 That is, version 3 of the Macintosh MIDI driver is not necessarily 217343 related to version 3 of the Win95 MIDI driver." 217344 217345 HasBuffer := 3. 217346 "Read-only. Return 1 if this MIDI driver has a time-stamped output 217347 buffer, 0 otherwise. Such a buffer allows the client to schedule 217348 MIDI output packets to be sent later. This can allow more precise 217349 timing, since the driver uses timer interrupts to send the data 217350 at the right time even if the processor is in the midst of a 217351 long-running Squeak primitive or is running some other application 217352 or system task." 217353 217354 HasDurs := 4. 217355 "Read-only. Return 1 if this MIDI driver supports an extended 217356 primitive for note-playing that includes the note duration and 217357 schedules both the note-on and the note-off messages in the 217358 driver. Otherwise, return 0." 217359 217360 CanSetClock := 5. 217361 "Read-only. Return 1 if this MIDI driver's clock can be set 217362 via an extended primitive, 0 if not." 217363 217364 CanUseSemaphore := 6. 217365 "Read-only. Return 1 if this MIDI driver can signal a semaphore 217366 when MIDI input arrives. Otherwise, return 0. If this driver 217367 supports controller caching and it is enabled, then incoming 217368 controller messages will not signal the semaphore." 217369 217370 EchoOn := 7. 217371 "Read-write. If this flag is set to a non-zero value, and if 217372 the driver supports echoing, then incoming MIDI events will 217373 be echoed immediately. If this driver does not support echoing, 217374 then queries of this parameter will always return 0 and 217375 attempts to change its value will do nothing." 217376 217377 UseControllerCache := 8. 217378 "Read-write. If this flag is set to a non-zero value, and if 217379 the driver supports a controller cache, then the driver will 217380 maintain a cache of the latest value seen for each MIDI controller, 217381 and control update messages will be filtered out of the incoming 217382 MIDI stream. An extended MIDI primitive allows the client to 217383 poll the driver for the current value of each controller. If 217384 this driver does not support a controller cache, then queries 217385 of this parameter will always return 0 and attempts to change 217386 its value will do nothing." 217387 217388 EventsAvailable := 9. 217389 "Read-only. Return the number of MIDI packets in the input queue." 217390 217391 FlushDriver := 10. 217392 "Write-only. Setting this parameter to any value forces the driver 217393 to flush its I/0 buffer, discarding all unprocessed data. Reading 217394 this parameter returns 0. Setting this parameter will do nothing 217395 if the driver does not support buffer flushing." 217396 217397 ClockTicksPerSec := 11. 217398 "Read-only. Return the MIDI clock rate in ticks per second." 217399 217400 HasInputClock := 12. 217401 "Read-only. Return 1 if this MIDI driver timestamps incoming 217402 MIDI data with the current value of the MIDI clock, 0 otherwise. 217403 If the driver does not support such timestamping, then the 217404 client must read input data frequently and provide its own 217405 timestamping." 217406! ! 217407Object subclass: #MimeConverter 217408 instanceVariableNames: 'dataStream mimeStream' 217409 classVariableNames: '' 217410 poolDictionaries: '' 217411 category: 'Network-MIME'! 217412 217413!MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:55'! 217414dataStream 217415 ^dataStream! ! 217416 217417!MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:51'! 217418dataStream: anObject 217419 dataStream := anObject! ! 217420 217421!MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:53'! 217422mimeStream 217423 ^mimeStream! ! 217424 217425!MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:51'! 217426mimeStream: anObject 217427 mimeStream := anObject! ! 217428 217429 217430!MimeConverter methodsFor: 'conversion' stamp: 'bf 11/12/1998 13:30'! 217431mimeDecode 217432 "Do conversion reading from mimeStream writing to dataStream" 217433 217434 self subclassResponsibility! ! 217435 217436!MimeConverter methodsFor: 'conversion' stamp: 'bf 11/12/1998 13:31'! 217437mimeEncode 217438 "Do conversion reading from dataStream writing to mimeStream" 217439 217440 self subclassResponsibility! ! 217441 217442"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 217443 217444MimeConverter class 217445 instanceVariableNames: ''! 217446 217447!MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:47'! 217448forEncoding: encodingString 217449 "Answer a converter class for the given encoding or nil if unknown" 217450 encodingString ifNil: [^nil]. 217451 ^ encodingString asLowercase caseOf: 217452 { ['base64'] -> [Base64MimeConverter]. 217453 ['quoted-printable'] -> [QuotedPrintableMimeConverter]} 217454 otherwise: []. 217455! ! 217456 217457!MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:43'! 217458mimeDecode: aStringOrStream as: contentsClass 217459 ^ contentsClass streamContents: [:out | 217460 self mimeDecode: aStringOrStream to: out]! ! 217461 217462!MimeConverter class methodsFor: 'convenience' stamp: 'damiencassou 5/30/2008 11:45'! 217463mimeDecode: aStringOrStream to: outStream 217464 self new 217465 mimeStream: (aStringOrStream isStream 217466 ifTrue: [ aStringOrStream ] 217467 ifFalse: [ aStringOrStream readStream ]); 217468 dataStream: outStream; 217469 mimeDecode! ! 217470 217471!MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:40'! 217472mimeEncode: aCollectionOrStream 217473 ^ String streamContents: [:out | 217474 self mimeEncode: aCollectionOrStream to: out]! ! 217475 217476!MimeConverter class methodsFor: 'convenience' stamp: 'damiencassou 5/30/2008 11:45'! 217477mimeEncode: aCollectionOrStream to: outStream 217478 self new 217479 dataStream: (aCollectionOrStream isStream 217480 ifTrue: [ aCollectionOrStream ] 217481 ifFalse: [ aCollectionOrStream readStream ]); 217482 mimeStream: outStream; 217483 mimeEncode! ! 217484TestCase subclass: #MirrorPrimitiveTests 217485 instanceVariableNames: '' 217486 classVariableNames: '' 217487 poolDictionaries: '' 217488 category: 'Tests-Compiler'! 217489 217490!MirrorPrimitiveTests methodsFor: 'running' stamp: 'MikeRoberts 9/27/2009 17:53'! 217491expectedFailures 217492 "Expected failures until the VM supports the mirror primitives." 217493 217494 ^#(testMirrorAt testMirrorClass testMirrorEqEq testMirrorInstVarAt testMirrorPerform testMirrorSize)! ! 217495 217496 217497!MirrorPrimitiveTests methodsFor: 'tests' stamp: 'eem 5/8/2009 09:52'! 217498testMirrorAt 217499 | stackpBefore stackpAfter array byteArray | 217500 stackpBefore := thisContext stackPtr. 217501 array := { 1. 2. 3 }. 217502 byteArray := ByteArray with: 1 with: 2 with: 3. 217503 self assert: (thisContext object: array basicAt: 1) = 1. 217504 self assert: (thisContext object: byteArray basicAt: 2) = 2. 217505 thisContext object: array basicAt: 2 put: #two. 217506 self assert: array = #(1 #two 3). 217507 thisContext object: byteArray basicAt: 2 put: 222. 217508 self assert: byteArray asArray = #(1 222 3). 217509 stackpAfter := thisContext stackPtr. 217510 self assert: stackpBefore = stackpAfter. "Make sure primitives pop all their arguments" 217511 self should: [thisContext object: array basicAt: 4] raise: Error. 217512 self should: [thisContext object: byteArray basicAt: 0] raise: Error. 217513 self should: [thisContext object: byteArray basicAt: 1 put: -1] raise: Error! ! 217514 217515!MirrorPrimitiveTests methodsFor: 'tests' stamp: 'eem 4/8/2009 19:44'! 217516testMirrorClass 217517 | stackpBefore stackpAfter | 217518 stackpBefore := thisContext stackPtr. 217519 self assert: (thisContext objectClass: Array new) = Array. 217520 self assert: (thisContext objectClass: 1) = 1 class. 217521 self assert: (thisContext objectClass: ProtoObject new) = ProtoObject. 217522 stackpAfter := thisContext stackPtr. 217523 self assert: stackpBefore = stackpAfter "Make sure primitives pop all their arguments"! ! 217524 217525!MirrorPrimitiveTests methodsFor: 'tests' stamp: 'eem 5/8/2009 09:54'! 217526testMirrorEqEq 217527 | stackpBefore stackpAfter | 217528 stackpBefore := thisContext stackPtr. 217529 self assert: (thisContext object: Array new eqeq: Array new) == false. 217530 self assert: (thisContext object: Array eqeq: Array) == true. 217531 stackpAfter := thisContext stackPtr. 217532 self assert: stackpBefore = stackpAfter "Make sure primitives pop all their arguments"! ! 217533 217534!MirrorPrimitiveTests methodsFor: 'tests' stamp: 'eem 4/8/2009 22:45'! 217535testMirrorInstVarAt 217536 | stackpBefore stackpAfter array point | 217537 stackpBefore := thisContext stackPtr. 217538 array := { 1. 2. 3 }. 217539 point := Point x: 1 y: 2. 217540 self assert: (thisContext object: array instVarAt: 1) = 1. 217541 self assert: (thisContext object: point instVarAt: 2) = 2. 217542 thisContext object: array instVarAt: 2 put: #two. 217543 self assert: array = #(1 #two 3). 217544 thisContext object: point instVarAt: 1 put: 1/2. 217545 self assert: point = (Point x: 1 / 2 y: 2). 217546 stackpAfter := thisContext stackPtr. 217547 self assert: stackpBefore = stackpAfter. "Make sure primitives pop all their arguments" 217548 self should: [thisContext object: array instVarAt: 4] raise: Error. 217549 self should: [thisContext object: point instVarAt: 3] raise: Error! ! 217550 217551!MirrorPrimitiveTests methodsFor: 'tests' stamp: 'eem 5/12/2009 21:17'! 217552testMirrorPerform 217553 | stackpBefore stackpAfter anInterval | 217554 stackpBefore := thisContext stackPtr. 217555 anInterval := 1 to: 2. 217556 self assert: (thisContext object: anInterval perform:# species withArguments: #() inClass: Interval) == Array. 217557 self assert: (thisContext object: anInterval perform:# species withArguments: #() inClass: Interval superclass) == Interval. 217558 self should: [thisContext object: anInterval perform:# species withArguments: #() inClass: Point] 217559 raise: Error. 217560 self should: [thisContext object: anInterval perform:# species withArguments: OrderedCollection new inClass: Interval] 217561 raise: Error. 217562 stackpAfter := thisContext stackPtr. 217563 self assert: stackpBefore = stackpAfter "Make sure primitives pop all their arguments"! ! 217564 217565!MirrorPrimitiveTests methodsFor: 'tests' stamp: 'eem 4/8/2009 22:50'! 217566testMirrorSize 217567 | stackpBefore stackpAfter | 217568 stackpBefore := thisContext stackPtr. 217569 self assert: (thisContext objectSize: #(1 2 3)) = 3. 217570 self assert: (thisContext objectSize: '123') = 3. 217571 self assert: (thisContext objectSize: nil) = 0. 217572 self assert: (thisContext objectSize: 1) = 0. 217573 stackpAfter := thisContext stackPtr. 217574 self assert: stackpBefore = stackpAfter. "Make sure primitives pop all their arguments"! ! 217575 217576"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 217577 217578MirrorPrimitiveTests class 217579 instanceVariableNames: ''! 217580PolygonMorph subclass: #MixedCurveMorph 217581 instanceVariableNames: 'slopeClamps' 217582 classVariableNames: '' 217583 poolDictionaries: '' 217584 category: 'Morphic-Basic-NewCurve'! 217585!MixedCurveMorph commentStamp: '<historical>' prior: 0! 217586A MixedCurveMorph is Curve that can be broken up into separately curved segments. It allows for the creation of matching edges( e. g. for jigsaw puzzle pieces). 217587 217588Instance Variables 217589 slopeClamps: <Array> 217590 217591slopeClamps 217592 - elements of array are either 0 or nil. Indicating whether slope for the corresponding vertex is 0@0 or unknown and therefore to be calculated. There is one element for each vertex. 217593 217594 217595! 217596 217597 217598!MixedCurveMorph methodsFor: 'access' stamp: 'wiz 2/8/2006 18:59'! 217599clamps 217600" Return a collection of clamps the same size as vertices. 217601 If necessary default to unclamped slopes. 217602" 217603 217604slopeClamps 217605 ifNil: [ ^ slopeClamps := Array new: vertices size ] . 217606slopeClamps size = vertices size 217607 ifFalse: [ ^ slopeClamps := Array new: vertices size ] . 217608 ^ slopeClamps ! ! 217609 217610!MixedCurveMorph methodsFor: 'access' stamp: 'wiz 2/8/2006 17:44'! 217611handleColorAt: vertIndex 217612 " clamped handles are cyan and 217613 unclamped handles are yellow." 217614 217615(self clamps at: vertIndex ) ifNil: [ ^ Color yellow ] . 217616^ Color cyan 217617! ! 217618 217619 217620!MixedCurveMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 17:50'! 217621clickVertex: ix event: evt fromHandle: handle 217622" Toggle the state of the clamp. " 217623"Note: self clamps assures slopeClamps will be same size as vertices" 217624 217625(self clamps at: ix) 217626 ifNil: [ slopeClamps at: ix put: 0 ] 217627 ifNotNil: [ slopeClamps at: ix put: nil ] . 217628 self setVertices: vertices . 217629 217630! ! 217631 217632!MixedCurveMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:01'! 217633deleteVertexAt: anIndex 217634 (slopeClamps := 217635 slopeClamps 217636 copyReplaceFrom: anIndex 217637 to: anIndex 217638 with: Array new) . 217639 self 217640 setVertices: (vertices 217641 copyReplaceFrom: anIndex 217642 to: anIndex 217643 with: Array new). 217644 ! ! 217645 217646!MixedCurveMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:29'! 217647insertVertexAt: anIndex put: aValue 217648 "New vertexs are unclamped." 217649 "Note: order is important. 217650 The clamps array must match vertex size before setVertices: is performed." 217651 slopeClamps := slopeClamps 217652 copyReplaceFrom: anIndex + 1 to: anIndex with: (Array with: nil). 217653 self setVertices: (vertices copyReplaceFrom: anIndex + 1 to: anIndex 217654 with: (Array with: aValue)).! ! 217655 217656 217657!MixedCurveMorph methodsFor: 'initialization' stamp: 'wiz 2/12/2006 05:59'! 217658initialize 217659"initialize the state of the receiver" 217660 super initialize. 217661 self extent: 32@20 . 217662 217663 self rectOval. 217664 self clamps . "This initializes slopeClamps." 217665 slopeClamps at: 1 put: 0 . 217666 slopeClamps at: 4 put: 0 . 217667 217668 closed := true. 217669 smoothCurve := true. 217670 arrows := #none. 217671 self computeBounds! ! 217672 217673 217674!MixedCurveMorph methodsFor: 'smoothing' stamp: 'wiz 2/18/2006 12:53'! 217675slopes: knots 217676 "Choose slopes according to state of polygon and preferences" 217677 self isCurvy 217678 ifFalse: [^ knots segmentedSlopes]. 217679 ^ (closed 217680 and: [self isCurvier]) 217681 ifTrue: [ knots closedCubicSlopes: self clamps ] 217682 ifFalse: [knots naturalCubicSlopes: self clamps ]! ! 217683Stream subclass: #MockSocketStream 217684 instanceVariableNames: 'atEnd inStream outStream' 217685 classVariableNames: '' 217686 poolDictionaries: '' 217687 category: 'NetworkTests-Kernel'! 217688 217689!MockSocketStream methodsFor: 'accessing' stamp: 'fbs 3/22/2004 12:51'! 217690atEnd: aBoolean 217691 atEnd := aBoolean.! ! 217692 217693!MockSocketStream methodsFor: 'accessing' stamp: 'fbs 3/22/2004 13:29'! 217694inStream 217695 ^inStream! ! 217696 217697!MockSocketStream methodsFor: 'accessing' stamp: 'fbs 3/22/2004 13:08'! 217698outStream 217699 ^outStream! ! 217700 217701 217702!MockSocketStream methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:08'! 217703initialize 217704 super initialize. 217705 self resetInStream. 217706 self resetOutStream.! ! 217707 217708 217709!MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:10'! 217710nextLine 217711 ^self nextLineCrLf! ! 217712 217713!MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:09'! 217714nextLineCrLf 217715 ^(self upToAll: String crlf).! ! 217716 217717!MockSocketStream methodsFor: 'stream in' stamp: 'PeterHugossonMiller 9/3/2009 10:05'! 217718resetInStream 217719 inStream := String new writeStream.! ! 217720 217721!MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:09'! 217722upToAll: delims 217723 ^self inStream upToAll: delims.! ! 217724 217725 217726!MockSocketStream methodsFor: 'stream out' stamp: 'PeterHugossonMiller 9/3/2009 10:05'! 217727resetOutStream 217728 outStream := String new writeStream.! ! 217729 217730!MockSocketStream methodsFor: 'stream out' stamp: 'fbs 3/22/2004 13:07'! 217731sendCommand: aString 217732 self outStream 217733 nextPutAll: aString; 217734 nextPutAll: String crlf.! ! 217735 217736 217737!MockSocketStream methodsFor: 'testing' stamp: 'fbs 3/22/2004 13:08'! 217738atEnd 217739 ^self inStream atEnd.! ! 217740 217741"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 217742 217743MockSocketStream class 217744 instanceVariableNames: ''! 217745 217746!MockSocketStream class methodsFor: 'instance creation' stamp: 'fbs 3/22/2004 12:46'! 217747on: socket 217748 ^self basicNew initialize! ! 217749Object subclass: #Model 217750 instanceVariableNames: 'dependents' 217751 classVariableNames: '' 217752 poolDictionaries: '' 217753 category: 'Kernel-Objects'! 217754!Model commentStamp: '<historical>' prior: 0! 217755Provides a superclass for classes that function as models. The only behavior provided is fast dependents maintenance, which bypasses the generic DependentsFields mechanism. 1/23/96 sw! 217756 217757 217758!Model methodsFor: '*tools' stamp: 'ar 9/27/2005 20:59'! 217759addItem: classAndMethod 217760 "Make a linked message list and put this method in it" 217761 | list | 217762 217763 self flag: #mref. "classAndMethod is a String" 217764 217765 MessageSet 217766 parse: classAndMethod 217767 toClassAndSelector: [ :class :sel | 217768 class ifNil: [^self]. 217769 list := OrderedCollection with: ( 217770 MethodReference new 217771 setClass: class 217772 methodSymbol: sel 217773 stringVersion: classAndMethod 217774 ). 217775 MessageSet 217776 openMessageList: list 217777 name: 'Linked by HyperText'. 217778 ] 217779 217780! ! 217781 217782 217783!Model methodsFor: 'copying' stamp: 'tk 10/21/2002 12:59'! 217784veryDeepFixupWith: deepCopier 217785 "See if the dependents are being copied also. If so, point at the new copies. (The dependent has self as its model.) 217786 Dependents handled in class Object, when the model is not a Model, are fixed up in Object veryDeepCopy." 217787 217788 | originalDependents refs newDependent | 217789 super veryDeepFixupWith: deepCopier. 217790 originalDependents := dependents. 217791 originalDependents ifNil: [ 217792 ^self. 217793 ]. 217794 dependents := nil. 217795 refs := deepCopier references. 217796 originalDependents 217797 do: [:originalDependent | 217798 newDependent := refs 217799 at: originalDependent 217800 ifAbsent: []. 217801 newDependent 217802 ifNotNil: [self addDependent: newDependent]]! ! 217803 217804 217805!Model methodsFor: 'dependents' stamp: 'sma 2/29/2000 19:26'! 217806canDiscardEdits 217807 "Answer true if none of the views on this model has unaccepted edits that matter." 217808 217809 dependents ifNil: [^ true]. 217810 ^ super canDiscardEdits 217811! ! 217812 217813!Model methodsFor: 'dependents' stamp: 'alain.plantec 6/10/2008 20:22'! 217814containingWindow 217815 "Answer the window that holds the receiver. The dependents technique is 217816 odious and may not be airtight, if multiple windows have the same 217817 model. " 217818 ^ self dependents 217819 detect: [:d | (d isSystemWindow) 217820 and: [d model == self]] 217821 ifNone: []! ! 217822 217823!Model methodsFor: 'dependents' stamp: 'jm 3/24/98 15:12'! 217824hasUnacceptedEdits 217825 "Answer true if any of the views on this model has unaccepted edits." 217826 217827 dependents == nil ifTrue: [^ false]. 217828 ^ super hasUnacceptedEdits 217829! ! 217830 217831!Model methodsFor: 'dependents' stamp: 'sma 2/29/2000 19:54'! 217832myDependents 217833 ^ dependents! ! 217834 217835!Model methodsFor: 'dependents' stamp: 'sma 2/29/2000 19:54'! 217836myDependents: aCollectionOrNil 217837 dependents := aCollectionOrNil! ! 217838 217839!Model methodsFor: 'dependents' stamp: 'alain.plantec 5/30/2008 13:47'! 217840topView 217841 "Find the first top view on me. Is there any danger of their being two 217842 with the same model? Any danger from ungarbage collected old views? 217843 Ask if schedulled?" 217844 dependents 217845 ifNil: [^ nil]. 217846 dependents 217847 do: [:v | (v isSystemWindow 217848 and: [v isInWorld]) 217849 ifTrue: [^ v]]. 217850 ^ nil! ! 217851 217852 217853!Model methodsFor: 'keyboard' stamp: 'nk 6/29/2004 14:46'! 217854arrowKey: aChar from: view 217855 "backstop; all the PluggableList* classes actually handle arrow keys, and the models handle other keys." 217856 ^false! ! 217857 217858 217859!Model methodsFor: 'menus' stamp: 'di 4/11/98 11:34'! 217860perform: selector orSendTo: otherTarget 217861 "Selector was just chosen from a menu by a user. If can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." 217862 217863 "default is that the editor does all" 217864 ^ otherTarget perform: selector.! ! 217865 217866!Model methodsFor: 'menus' stamp: 'tk 4/17/1998 17:28'! 217867selectedClass 217868 "All owners of TextViews are asked this during a doIt" 217869 ^ nil! ! 217870 217871!Model methodsFor: 'menus' stamp: 'zz 3/2/2004 23:49'! 217872step 217873 "Default for morphic models is no-op"! ! 217874 217875!Model methodsFor: 'menus' stamp: 'sw 12/15/2000 13:21'! 217876trash 217877 "What should be displayed if a trash pane is restored to initial state" 217878 217879 ^ ''! ! 217880 217881!Model methodsFor: 'menus' stamp: 'sw 12/15/2000 13:21'! 217882trash: ignored 217883 "Whatever the user submits to the trash, it need not be saved." 217884 217885 ^ true! ! 217886 217887"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 217888 217889Model class 217890 instanceVariableNames: ''! 217891 217892!Model class methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 16:26'! 217893buildWith: toolBuilder 217894 ^self new buildWith: toolBuilder! ! 217895DialogWindow subclass: #ModelDependentDialogWindow 217896 instanceVariableNames: '' 217897 classVariableNames: '' 217898 poolDictionaries: '' 217899 category: 'Polymorph-Widgets-Windows'! 217900!ModelDependentDialogWindow commentStamp: 'gvc 5/18/2007 12:44' prior: 0! 217901DialogWindow that updates content based upon its model.! 217902 217903 217904!ModelDependentDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 15:27'! 217905addInitialPanel 217906 "Don't until the model is set."! ! 217907 217908!ModelDependentDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 15:27'! 217909model: anObject 217910 "Set the model and add the panel for it." 217911 217912 super model: anObject. 217913 self paneMorphs copy do: [:p | p delete]. 217914 self addMainPanel! ! 217915Object subclass: #ModelExtension 217916 instanceVariableNames: 'interests lock' 217917 classVariableNames: '' 217918 poolDictionaries: '' 217919 category: 'Traits-LocalSends'! 217920 217921!ModelExtension methodsFor: 'access to cache' stamp: 'dvf 9/14/2005 11:27'! 217922haveInterestsIn: aClass 217923 lock critical: [^interests includes: aClass] 217924! ! 217925 217926 217927!ModelExtension methodsFor: 'interests' stamp: 'dvf 9/14/2005 11:11'! 217928lostInterest: client inAll: classes 217929 lock critical: [interests removeAll: classes]! ! 217930 217931!ModelExtension methodsFor: 'interests' stamp: 'dvf 9/2/2005 11:43'! 217932lostInterest: client in: class 217933 self lostInterest: client inAll: {class}! ! 217934 217935!ModelExtension methodsFor: 'interests' stamp: 'dvf 9/14/2005 11:28'! 217936noteInterestOf: client inAll: classes 217937 lock critical: [interests addAll: classes].! ! 217938 217939!ModelExtension methodsFor: 'interests' stamp: 'dvf 9/2/2005 11:44'! 217940noteInterestOf: client in: class 217941 self noteInterestOf: client inAll: {class}! ! 217942 217943 217944!ModelExtension methodsFor: 'invalidation' stamp: 'alain.plantec 5/28/2009 10:08'! 217945initialize 217946 super initialize. 217947 lock := Semaphore forMutualExclusion. 217948 interests := IdentityBag new. 217949 SystemChangeNotifier uniqueInstance 217950 notify: self 217951 ofSystemChangesOfItem: #class 217952 using: #classChanged:. 217953 SystemChangeNotifier uniqueInstance 217954 notify: self 217955 ofSystemChangesOfItem: #method 217956 using: #classChanged:. 217957! ! 217958 217959"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 217960 217961ModelExtension class 217962 instanceVariableNames: 'current'! 217963 217964!ModelExtension class methodsFor: 'accessing' stamp: 'dvf 9/1/2005 21:16'! 217965current 217966 ^current! ! 217967 217968!ModelExtension class methodsFor: 'accessing' stamp: 'dvf 9/1/2005 21:16'! 217969current: anObject 217970 ^current := anObject! ! 217971 217972 217973!ModelExtension class methodsFor: 'initialization' stamp: 'dvf 9/2/2005 12:20'! 217974initialize 217975 self isAbstract not ifTrue: 217976 [self current: self new]! ! 217977 217978!ModelExtension class methodsFor: 'initialization' stamp: 'dvf 9/2/2005 12:20'! 217979isAbstract 217980 ^self == ModelExtension! ! 217981 217982 217983!ModelExtension class methodsFor: 'instance creation' stamp: 'dvf 9/1/2005 21:16'! 217984doWithTemporaryInstance: aBlock 217985 | singleton | 217986 singleton := self current. 217987 217988 [self current: self new. 217989 aBlock value] ensure: [self current: singleton]! ! 217990ModifiedEvent subclass: #ModifiedClassDefinitionEvent 217991 instanceVariableNames: '' 217992 classVariableNames: '' 217993 poolDictionaries: '' 217994 category: 'System-Change Notification'! 217995 217996!ModifiedClassDefinitionEvent methodsFor: '*Kernel-Classes' stamp: 'al 7/17/2004 21:48'! 217997anyChanges 217998 ^ self isSuperclassModified or: [self areInstVarsModified or: [self areClassVarsModified or: [self areSharedPoolsModified or: [self isTraitCompositionModified]]]]! ! 217999 218000!ModifiedClassDefinitionEvent methodsFor: '*Kernel-Classes' stamp: 'al 7/17/2004 21:59'! 218001isTraitCompositionModified 218002 ^self traitComposition printString ~= self oldTraitComposition printString! ! 218003 218004!ModifiedClassDefinitionEvent methodsFor: '*Kernel-Classes' stamp: 'al 7/17/2004 21:50'! 218005oldTraitComposition 218006 ^ oldItem traitComposition! ! 218007 218008!ModifiedClassDefinitionEvent methodsFor: '*Kernel-Classes' stamp: 'al 7/18/2004 10:47'! 218009printOn: aStream 218010 super printOn: aStream. 218011 aStream 218012 nextPutAll: ' Super: '; 218013 print: self isSuperclassModified; 218014 nextPutAll: ' TraitComposition: '; 218015 print: self isTraitCompositionModified; 218016 nextPutAll: ' InstVars: '; 218017 print: self areInstVarsModified; 218018 nextPutAll: ' ClassVars: '; 218019 print: self areClassVarsModified; 218020 nextPutAll: ' SharedPools: '; 218021 print: self areSharedPoolsModified.! ! 218022 218023!ModifiedClassDefinitionEvent methodsFor: '*Kernel-Classes' stamp: 'al 7/17/2004 21:50'! 218024traitComposition 218025 ^ item traitComposition! ! 218026 218027 218028!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'gk 8/22/2007 01:10'! 218029classVarNames 218030 ^ item classVarNames! ! 218031 218032!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'gk 8/22/2007 00:11'! 218033instVarNames 218034 ^ item instVarNames! ! 218035 218036!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'gk 8/22/2007 01:10'! 218037oldClassVarNames 218038 ^ oldItem classVarNames! ! 218039 218040!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'gk 8/22/2007 00:30'! 218041oldInstVarNames 218042 ^ oldItem instVarNames! ! 218043 218044!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:31'! 218045oldSharedPools 218046 ^ oldItem sharedPools! ! 218047 218048!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:28'! 218049oldSuperclass 218050 ^ oldItem superclass! ! 218051 218052!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'gk 8/21/2007 02:23'! 218053oldTypeOfClass 218054 ^ oldItem typeOfClass! ! 218055 218056!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:31'! 218057sharedPools 218058 ^ item sharedPools! ! 218059 218060!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:28'! 218061superclass 218062 ^ item superclass! ! 218063 218064!ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'gk 8/21/2007 02:23'! 218065typeOfClass 218066 ^ item typeOfClass! ! 218067 218068 218069!ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'NS 1/20/2004 19:31'! 218070areClassVarsModified 218071 ^ self classVarNames ~= self oldClassVarNames! ! 218072 218073!ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'NS 1/20/2004 19:30'! 218074areInstVarsModified 218075 ^ self instVarNames ~= self oldInstVarNames! ! 218076 218077!ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'NS 1/20/2004 19:32'! 218078areSharedPoolsModified 218079 ^ self sharedPools ~= self oldSharedPools! ! 218080 218081!ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'NS 1/20/2004 19:29'! 218082isSuperclassModified 218083 ^ item superclass ~~ oldItem superclass! ! 218084 218085!ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'gk 8/21/2007 02:21'! 218086isTypeModified 218087 ^ item typeOfClass ~~ oldItem typeOfClass! ! 218088 218089"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 218090 218091ModifiedClassDefinitionEvent class 218092 instanceVariableNames: ''! 218093 218094!ModifiedClassDefinitionEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:26'! 218095supportedKinds 218096 "All the kinds of items that this event can take." 218097 218098 ^ Array with: self classKind! ! 218099 218100 218101!ModifiedClassDefinitionEvent class methodsFor: 'instance creation' stamp: 'NS 1/20/2004 11:52'! 218102classDefinitionChangedFrom: oldClass to: newClass 218103 | instance | 218104 instance := self item: newClass kind: self classKind. 218105 instance oldItem: oldClass. 218106 ^instance! ! 218107AbstractEvent subclass: #ModifiedEvent 218108 instanceVariableNames: 'oldItem' 218109 classVariableNames: '' 218110 poolDictionaries: '' 218111 category: 'System-Change Notification'! 218112 218113!ModifiedEvent methodsFor: 'accessing' stamp: 'NS 1/19/2004 15:08'! 218114oldItem 218115 ^ oldItem! ! 218116 218117 218118!ModifiedEvent methodsFor: 'printing' stamp: 'NS 1/19/2004 15:10'! 218119printEventKindOn: aStream 218120 218121 aStream nextPutAll: 'Modified'! ! 218122 218123!ModifiedEvent methodsFor: 'printing' stamp: 'NS 1/19/2004 17:57'! 218124printOn: aStream 218125 super printOn: aStream. 218126 aStream 218127 nextPutAll: ' oldItem: '; 218128 print: oldItem.! ! 218129 218130 218131!ModifiedEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 15:09'! 218132isModified 218133 218134 ^true! ! 218135 218136!ModifiedEvent methodsFor: 'testing' stamp: 'mtf 10/9/2007 10:16'! 218137isProtocolModified 218138 ^ false! ! 218139 218140 218141!ModifiedEvent methodsFor: 'private-accessing' stamp: 'NS 1/19/2004 15:08'! 218142oldItem: anItem 218143 oldItem := anItem! ! 218144 218145"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 218146 218147ModifiedEvent class 218148 instanceVariableNames: ''! 218149 218150!ModifiedEvent class methodsFor: 'accessing' stamp: 'NS 1/19/2004 15:10'! 218151changeKind 218152 218153 ^#Modified! ! 218154 218155!ModifiedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:25'! 218156supportedKinds 218157 "All the kinds of items that this event can take." 218158 218159 ^ Array with: self classKind with: self methodKind with: self categoryKind with: self protocolKind! ! 218160 218161 218162!ModifiedEvent class methodsFor: 'instance creation' stamp: 'NS 1/20/2004 19:37'! 218163classDefinitionChangedFrom: oldClass to: newClass 218164 ^ ModifiedClassDefinitionEvent classDefinitionChangedFrom: oldClass to: newClass! ! 218165 218166!ModifiedEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 11:40'! 218167methodChangedFrom: oldMethod to: newMethod selector: aSymbol inClass: aClass 218168 | instance | 218169 instance := self method: newMethod selector: aSymbol class: aClass. 218170 instance oldItem: oldMethod. 218171 ^ instance! ! 218172 218173!ModifiedEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 11:40'! 218174methodChangedFrom: oldMethod to: newMethod selector: aSymbol inClass: aClass requestor: requestor 218175 | instance | 218176 instance := self method: newMethod selector: aSymbol class: aClass requestor: requestor. 218177 instance oldItem: oldMethod. 218178 ^ instance! ! 218179ModifiedEvent subclass: #ModifiedMethodEvent 218180 instanceVariableNames: 'oldProtocol newProtocol' 218181 classVariableNames: '' 218182 poolDictionaries: '' 218183 category: 'System-Change Notification'! 218184 218185!ModifiedMethodEvent methodsFor: 'accessing' stamp: 'mtf 8/25/2007 23:17'! 218186newProtocol 218187 ^ newProtocol! ! 218188 218189!ModifiedMethodEvent methodsFor: 'accessing' stamp: 'mtf 8/25/2007 23:17'! 218190newProtocol: anObject 218191 newProtocol := anObject! ! 218192 218193!ModifiedMethodEvent methodsFor: 'accessing' stamp: 'mtf 8/25/2007 23:17'! 218194oldProtocol 218195 ^ oldProtocol! ! 218196 218197!ModifiedMethodEvent methodsFor: 'accessing' stamp: 'mtf 8/25/2007 23:17'! 218198oldProtocol: anObject 218199 oldProtocol := anObject! ! 218200 218201 218202!ModifiedMethodEvent methodsFor: 'testing' stamp: 'test 8/26/2007 00:18'! 218203isProtocolModified 218204 ^ self oldProtocol ~~ self newProtocol! ! 218205ModifiedEvent subclass: #ModifiedTraitDefinitionEvent 218206 instanceVariableNames: '' 218207 classVariableNames: '' 218208 poolDictionaries: '' 218209 category: 'System-Change Notification'! 218210 218211!ModifiedTraitDefinitionEvent methodsFor: 'accessing' stamp: 'al 7/18/2004 10:43'! 218212oldTraitComposition 218213 ^ oldItem traitComposition! ! 218214 218215!ModifiedTraitDefinitionEvent methodsFor: 'accessing' stamp: 'al 7/18/2004 10:43'! 218216traitComposition 218217 ^ item traitComposition! ! 218218 218219 218220!ModifiedTraitDefinitionEvent methodsFor: 'printing' stamp: 'al 7/18/2004 10:47'! 218221printOn: aStream 218222 super printOn: aStream. 218223 aStream 218224 nextPutAll: ' TraitComposition: '; 218225 print: self isTraitCompositionModified! ! 218226 218227 218228!ModifiedTraitDefinitionEvent methodsFor: 'testing' stamp: 'al 7/18/2004 11:08'! 218229anyChanges 218230 ^ self isTraitCompositionModified! ! 218231 218232!ModifiedTraitDefinitionEvent methodsFor: 'testing' stamp: 'al 7/18/2004 10:43'! 218233isTraitCompositionModified 218234 ^self traitComposition printString ~= self oldTraitComposition printString! ! 218235 218236"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 218237 218238ModifiedTraitDefinitionEvent class 218239 instanceVariableNames: ''! 218240 218241!ModifiedTraitDefinitionEvent class methodsFor: 'accessing' stamp: 'al 7/18/2004 10:43'! 218242supportedKinds 218243 "All the kinds of items that this event can take." 218244 218245 ^ Array with: self classKind! ! 218246 218247 218248!ModifiedTraitDefinitionEvent class methodsFor: 'instance creation' stamp: 'al 7/18/2004 10:50'! 218249traitDefinitionChangedFrom: oldTrait to: newTrait 218250 | instance | 218251 instance := self item: newTrait kind: self classKind. 218252 instance oldItem: oldTrait. 218253 ^instance! ! 218254Object subclass: #Monitor 218255 instanceVariableNames: 'mutex ownerProcess nestingLevel defaultQueue queueDict queuesMutex' 218256 classVariableNames: '' 218257 poolDictionaries: '' 218258 category: 'Kernel-Processes'! 218259!Monitor commentStamp: 'md 3/3/2006 09:19' prior: 0! 218260A monitor provides process synchronization that is more high level than the one provided by a Semaphore. Similar to the classical definition of a Monitor it has the following properties: 218261 2182621) At any time, only one process can execute code inside a critical section of a monitor. 2182632) A monitor is reentrant, which means that the active process in a monitor never gets blocked when it enters a (nested) critical section of the same monitor. 2182643) Inside a critical section, a process can wait for an event that may be coupled to a certain condition. If the condition is not fulfilled, the process leaves the monitor temporarily (in order to let other processes enter) and waits until another process signals the event. Then, the original process checks the condition again (this is often necessary because the state of the monitor could have changed in the meantime) and continues if it is fulfilled. 2182654) The monitor is fair, which means that the process that is waiting on a signaled condition the longest gets activated first. 2182665) The monitor allows you to define timeouts after which a process gets activated automatically. 218267 218268 218269Basic usage: 218270 218271Monitor>>critical: aBlock 218272Critical section. 218273Executes aBlock as a critical section. At any time, only one process can execute code in a critical section. 218274NOTE: All the following synchronization operations are only valid inside the critical section of the monitor!! 218275 218276Monitor>>wait 218277Unconditional waiting for the default event. 218278The current process gets blocked and leaves the monitor, which means that the monitor allows another process to execute critical code. When the default event is signaled, the original process is resumed. 218279 218280Monitor>>waitWhile: aBlock 218281Conditional waiting for the default event. 218282The current process gets blocked and leaves the monitor only if the argument block evaluates to true. This means that another process can enter the monitor. When the default event is signaled, the original process is resumed, which means that the condition (argument block) is checked again. Only if it evaluates to false, does execution proceed. Otherwise, the process gets blocked and leaves the monitor again... 218283 218284Monitor>>waitUntil: aBlock 218285Conditional waiting for the default event. 218286See Monitor>>waitWhile: aBlock. 218287 218288Monitor>>signal 218289One process waiting for the default event is woken up. 218290 218291Monitor>>signalAll 218292All processes waiting for the default event are woken up. 218293 218294 218295Using non-default (specific) events: 218296 218297Monitor>>waitFor: aSymbol 218298Unconditional waiting for the non-default event represented by the argument symbol. 218299Same as Monitor>>wait, but the process gets only reactivated by the specific event and not the default event. 218300 218301Monitor>>waitWhile: aBlock for: aSymbol 218302Confitional waiting for the non-default event represented by the argument symbol. 218303Same as Monitor>>waitWhile:for:, but the process gets only reactivated by the specific event and not the default event. 218304 218305Monitor>>waitUntil: aBlock for: aSymbol 218306Confitional waiting for the non-default event represented by the argument symbol. 218307See Monitor>>waitWhile:for: aBlock. 218308 218309Monitor>>signal: aSymbol 218310One process waiting for the given event is woken up. If there is no process waiting for this specific event, a process waiting for the default event gets resumed. 218311 218312Monitor>>signalAll: aSymbol 218313All process waiting for the given event or the default event are woken up. 218314 218315Monitor>>signalReallyAll 218316All processes waiting for any events (default or specific) are woken up. 218317 218318 218319Using timeouts 218320 218321Monitor>>waitMaxMilliseconds: anInteger 218322Monitor>>waitFor: aSymbol maxMilliseconds: anInteger 218323Same as Monitor>>wait (resp. Monitor>>waitFor:), but the process gets automatically woken up when the specified time has passed. 218324 218325Monitor>>waitWhile: aBlock maxMilliseconds: anInteger 218326Monitor>>waitWhile: aBlock for: aSymbol maxMilliseconds: anInteger 218327Same as Monitor>>waitWhile: (resp. Monitor>>waitWhile:for:), but the process gets automatically woken up when the specified time has passed. 218328 218329Monitor>>waitUntil: aBlock maxMilliseconds: anInteger 218330Monitor>>waitUntil: aBlock for: aSymbol maxMilliseconds: anInteger 218331Same as Monitor>>waitUntil: (resp. Monitor>>waitUntil:for:), but the process gets automatically woken up when the specified time has passed.! 218332 218333 218334!Monitor methodsFor: 'accessing' stamp: 'NS 7/1/2002 20:02'! 218335cleanup 218336 self checkOwnerProcess. 218337 self critical: [self privateCleanup].! ! 218338 218339 218340!Monitor methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 10:08'! 218341initialize 218342 super initialize. 218343 mutex := Semaphore forMutualExclusion. 218344 queuesMutex := Semaphore forMutualExclusion. 218345 nestingLevel := 0.! ! 218346 218347 218348!Monitor methodsFor: 'signaling-default' stamp: 'NS 7/1/2002 21:57'! 218349signal 218350 "One process waiting for the default event is woken up." 218351 218352 ^ self signal: nil! ! 218353 218354!Monitor methodsFor: 'signaling-default' stamp: 'NS 7/1/2002 21:57'! 218355signalAll 218356 "All processes waiting for the default event are woken up." 218357 218358 ^ self signalAll: nil! ! 218359 218360 218361!Monitor methodsFor: 'signaling-specific' stamp: 'NS 4/13/2004 15:12'! 218362signal: aSymbolOrNil 218363 "One process waiting for the given event is woken up. If there is no process waiting 218364 for this specific event, a process waiting for the default event gets resumed." 218365 218366 | queue | 218367 self checkOwnerProcess. 218368 queue := self queueFor: aSymbolOrNil. 218369 queue isEmpty ifTrue: [queue := self defaultQueue]. 218370 self signalQueue: queue.! ! 218371 218372!Monitor methodsFor: 'signaling-specific' stamp: 'NS 7/1/2002 22:02'! 218373signalAll: aSymbolOrNil 218374 "All process waiting for the given event or the default event are woken up." 218375 218376 | queue | 218377 self checkOwnerProcess. 218378 queue := self queueFor: aSymbolOrNil. 218379 self signalAllInQueue: self defaultQueue. 218380 queue ~~ self defaultQueue ifTrue: [self signalAllInQueue: queue].! ! 218381 218382!Monitor methodsFor: 'signaling-specific' stamp: 'NS 7/1/2002 22:02'! 218383signalReallyAll 218384 "All processes waiting for any events (default or specific) are woken up." 218385 218386 self checkOwnerProcess. 218387 self signalAll. 218388 self queueDict valuesDo: [:queue | 218389 self signalAllInQueue: queue].! ! 218390 218391 218392!Monitor methodsFor: 'synchronization' stamp: 'NS 4/14/2004 13:13'! 218393critical: aBlock 218394 "Critical section. 218395 Executes aBlock as a critical section. At any time, only one process can be executing code 218396 in a critical section. 218397 NOTE: All the following synchronization operations are only valid inside the critical section 218398 of the monitor!!" 218399 218400 | result | 218401 [self enter. 218402 result := aBlock value] ensure: [self exit]. 218403 ^ result.! ! 218404 218405 218406!Monitor methodsFor: 'waiting-basic' stamp: 'NS 7/1/2002 21:55'! 218407wait 218408 "Unconditional waiting for the default event. 218409 The current process gets blocked and leaves the monitor, which means that the monitor 218410 allows another process to execute critical code. When the default event is signaled, the 218411 original process is resumed." 218412 218413 ^ self waitMaxMilliseconds: nil! ! 218414 218415!Monitor methodsFor: 'waiting-basic' stamp: 'NS 7/1/2002 21:56'! 218416waitUntil: aBlock 218417 "Conditional waiting for the default event. 218418 See Monitor>>waitWhile: aBlock." 218419 218420 ^ self waitUntil: aBlock for: nil! ! 218421 218422!Monitor methodsFor: 'waiting-basic' stamp: 'fbs 3/24/2004 14:39'! 218423waitWhile: aBlock 218424 "Conditional waiting for the default event. 218425 The current process gets blocked and leaves the monitor only if the argument block 218426 evaluates to true. This means that another process can enter the monitor. When the 218427 default event is signaled, the original process is resumed, which means that the condition 218428 (argument block) is checked again. Only if it evaluates to false, does execution proceed. 218429 Otherwise, the process gets blocked and leaves the monitor again..." 218430 218431 ^ self waitWhile: aBlock for: nil! ! 218432 218433 218434!Monitor methodsFor: 'waiting-specific' stamp: 'NS 7/1/2002 21:58'! 218435waitFor: aSymbolOrNil 218436 "Unconditional waiting for the non-default event represented by the argument symbol. 218437 Same as Monitor>>wait, but the process gets only reactivated by the specific event and 218438 not the default event." 218439 218440 ^ self waitFor: aSymbolOrNil maxMilliseconds: nil! ! 218441 218442!Monitor methodsFor: 'waiting-specific' stamp: 'NS 7/1/2002 22:01'! 218443waitUntil: aBlock for: aSymbolOrNil 218444 "Confitional waiting for the non-default event represented by the argument symbol. 218445 See Monitor>>waitWhile:for: aBlock." 218446 218447 ^ self waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: nil! ! 218448 218449!Monitor methodsFor: 'waiting-specific' stamp: 'NS 7/1/2002 22:01'! 218450waitWhile: aBlock for: aSymbolOrNil 218451 "Confitional waiting for the non-default event represented by the argument symbol. 218452 Same as Monitor>>waitWhile:for:, but the process gets only reactivated by the specific 218453 event and not the default event." 218454 218455 ^ self waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: nil! ! 218456 218457 218458!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:03'! 218459waitFor: aSymbolOrNil maxMilliseconds: anIntegerOrNil 218460 "Same as Monitor>>waitFor:, but the process gets automatically woken up when the 218461 specified time has passed." 218462 218463 self checkOwnerProcess. 218464 self waitInQueue: (self queueFor: aSymbolOrNil) maxMilliseconds: anIntegerOrNil.! ! 218465 218466!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:04'! 218467waitFor: aSymbolOrNil maxSeconds: aNumber 218468 "Same as Monitor>>waitFor:, but the process gets automatically woken up when the 218469 specified time has passed." 218470 218471 ^ self waitFor: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! ! 218472 218473!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:04'! 218474waitMaxMilliseconds: anIntegerOrNil 218475 "Same as Monitor>>wait, but the process gets automatically woken up when the 218476 specified time has passed." 218477 218478 ^ self waitFor: nil maxMilliseconds: anIntegerOrNil! ! 218479 218480!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'! 218481waitMaxSeconds: aNumber 218482 "Same as Monitor>>wait, but the process gets automatically woken up when the 218483 specified time has passed." 218484 218485 ^ self waitMaxMilliseconds: (aNumber * 1000) asInteger! ! 218486 218487!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'! 218488waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: anIntegerOrNil 218489 "Same as Monitor>>waitUntil:for:, but the process gets automatically woken up when the 218490 specified time has passed." 218491 218492 ^ self waitWhile: [aBlock value not] for: aSymbolOrNil maxMilliseconds: anIntegerOrNil! ! 218493 218494!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'! 218495waitUntil: aBlock for: aSymbolOrNil maxSeconds: aNumber 218496 "Same as Monitor>>waitUntil:for:, but the process gets automatically woken up when the 218497 specified time has passed." 218498 218499 ^ self waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! ! 218500 218501!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'! 218502waitUntil: aBlock maxMilliseconds: anIntegerOrNil 218503 "Same as Monitor>>waitUntil:, but the process gets automatically woken up when the 218504 specified time has passed." 218505 218506 ^ self waitUntil: aBlock for: nil maxMilliseconds: anIntegerOrNil! ! 218507 218508!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! 218509waitUntil: aBlock maxSeconds: aNumber 218510 "Same as Monitor>>waitUntil:, but the process gets automatically woken up when the 218511 specified time has passed." 218512 218513 ^ self waitUntil: aBlock maxMilliseconds: (aNumber * 1000) asInteger! ! 218514 218515!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! 218516waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: anIntegerOrNil 218517 "Same as Monitor>>waitWhile:for:, but the process gets automatically woken up when the 218518 specified time has passed." 218519 218520 self checkOwnerProcess. 218521 self waitWhile: aBlock inQueue: (self queueFor: aSymbolOrNil) maxMilliseconds: anIntegerOrNil.! ! 218522 218523!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! 218524waitWhile: aBlock for: aSymbolOrNil maxSeconds: aNumber 218525 "Same as Monitor>>waitWhile:for:, but the process gets automatically woken up when the 218526 specified time has passed." 218527 218528 ^ self waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! ! 218529 218530!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! 218531waitWhile: aBlock maxMilliseconds: anIntegerOrNil 218532 "Same as Monitor>>waitWhile:, but the process gets automatically woken up when the 218533 specified time has passed." 218534 218535 ^ self waitWhile: aBlock for: nil maxMilliseconds: anIntegerOrNil! ! 218536 218537!Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! 218538waitWhile: aBlock maxSeconds: aNumber 218539 "Same as Monitor>>waitWhile:, but the process gets automatically woken up when the 218540 specified time has passed." 218541 218542 ^ self waitWhile: aBlock maxMilliseconds: (aNumber * 1000) asInteger! ! 218543 218544 218545!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:40'! 218546checkOwnerProcess 218547 self isOwnerProcess 218548 ifFalse: [self error: 'Monitor access violation'].! ! 218549 218550!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:06'! 218551defaultQueue 218552 defaultQueue ifNil: [defaultQueue := OrderedCollection new]. 218553 ^ defaultQueue! ! 218554 218555!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:37'! 218556enter 218557 self isOwnerProcess ifTrue: [ 218558 nestingLevel := nestingLevel + 1. 218559 ] ifFalse: [ 218560 mutex wait. 218561 ownerProcess := Processor activeProcess. 218562 nestingLevel := 1. 218563 ].! ! 218564 218565!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:38'! 218566exit 218567 nestingLevel := nestingLevel - 1. 218568 nestingLevel < 1 ifTrue: [ 218569 ownerProcess := nil. 218570 mutex signal 218571 ].! ! 218572 218573!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:32'! 218574exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil 218575 | lock delay | 218576 queuesMutex 218577 critical: [lock := anOrderedCollection addLast: Semaphore new]. 218578 self exit. 218579 anIntegerOrNil isNil ifTrue: [ 218580 lock wait 218581 ] ifFalse: [ 218582 delay := MonitorDelay signalLock: lock afterMSecs: anIntegerOrNil inMonitor: self queue: anOrderedCollection. 218583 lock wait. 218584 delay unschedule. 218585 ]. 218586 self enter.! ! 218587 218588!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:42'! 218589isOwnerProcess 218590 ^ Processor activeProcess == ownerProcess! ! 218591 218592!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:14'! 218593privateCleanup 218594 queuesMutex critical: [ 218595 defaultQueue isEmpty ifTrue: [defaultQueue := nil]. 218596 queueDict ifNotNil: [ 218597 queueDict copy keysAndValuesDo: [:id :queue | 218598 queue isEmpty ifTrue: [queueDict removeKey: id]]. 218599 queueDict isEmpty ifTrue: [queueDict := nil]. 218600 ]. 218601 ].! ! 218602 218603!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:10'! 218604queueDict 218605 queueDict ifNil: [queueDict := IdentityDictionary new]. 218606 ^ queueDict.! ! 218607 218608!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:12'! 218609queueFor: aSymbol 218610 aSymbol ifNil: [^ self defaultQueue]. 218611 ^ self queueDict 218612 at: aSymbol 218613 ifAbsent: [self queueDict at: aSymbol put: OrderedCollection new].! ! 218614 218615!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:10'! 218616signalAllInQueue: anOrderedCollection 218617 queuesMutex critical: [ 218618 anOrderedCollection do: [:lock | lock signal]. 218619 anOrderedCollection removeAllSuchThat: [:each | true]. 218620 ].! ! 218621 218622!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:34'! 218623signalLock: aSemaphore inQueue: anOrderedCollection 218624 queuesMutex critical: [ 218625 aSemaphore signal. 218626 anOrderedCollection remove: aSemaphore ifAbsent: []. 218627 ].! ! 218628 218629!Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:10'! 218630signalQueue: anOrderedCollection 218631 queuesMutex critical: [ 218632 anOrderedCollection isEmpty ifTrue: [^ self]. 218633 anOrderedCollection removeFirst signal. 218634 ].! ! 218635 218636!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 13:17'! 218637waitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil 218638 self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil.! ! 218639 218640!Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 13:17'! 218641waitWhile: aBlock inQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil 218642 [aBlock value] whileTrue: [self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil].! ! 218643 218644"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 218645 218646Monitor class 218647 instanceVariableNames: ''! 218648Delay subclass: #MonitorDelay 218649 instanceVariableNames: 'monitor queue' 218650 classVariableNames: '' 218651 poolDictionaries: '' 218652 category: 'Kernel-Processes'! 218653!MonitorDelay commentStamp: 'NS 4/13/2004 16:51' prior: 0! 218654This is a specialization of the class Delay that is used for the implementation of the class Monitor.! 218655 218656 218657!MonitorDelay methodsFor: 'private' stamp: 'NS 4/13/2004 16:26'! 218658setDelay: anInteger forSemaphore: aSemaphore monitor: aMonitor queue: anOrderedCollection 218659 monitor := aMonitor. 218660 queue := anOrderedCollection. 218661 self setDelay: anInteger forSemaphore: aSemaphore.! ! 218662 218663!MonitorDelay methodsFor: 'private' stamp: 'NS 4/13/2004 16:22'! 218664signalWaitingProcess 218665 "The delay time has elapsed; signal the waiting process." 218666 218667 beingWaitedOn := false. 218668 monitor signalLock: delaySemaphore inQueue: queue. 218669! ! 218670 218671"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 218672 218673MonitorDelay class 218674 instanceVariableNames: ''! 218675 218676!MonitorDelay class methodsFor: 'instance creation' stamp: 'NS 4/13/2004 16:25'! 218677signalLock: aSemaphore afterMSecs: anInteger inMonitor: aMonitor queue: anOrderedCollection 218678 anInteger < 0 ifTrue: [self error: 'delay times cannot be negative']. 218679 ^ (self new setDelay: anInteger forSemaphore: aSemaphore monitor: aMonitor queue: anOrderedCollection) schedule! ! 218680TestCase subclass: #MonitorTest 218681 instanceVariableNames: '' 218682 classVariableNames: '' 218683 poolDictionaries: '' 218684 category: 'KernelTests-Processes'! 218685 218686!MonitorTest methodsFor: 'examples' stamp: 'md 3/19/2006 21:15'! 218687testExample1 218688 218689 | producer1 producer2 monitor goal work counter goalReached finished | 218690 goal := (1 to: 1000) asOrderedCollection. 218691 work := OrderedCollection new. 218692 counter := 0. 218693 goalReached := false. 218694 finished := Semaphore new. 218695 monitor := Monitor new. 218696 218697 producer1 := [ 218698 [monitor critical: 218699 [monitor waitUntil: [counter \\5 = 0]. 218700 goalReached or: [work add: (counter := counter + 1)]. 218701 goalReached := counter >= goal size. 218702 monitor signal 218703 ]. 218704 goalReached 218705 ] 218706 whileFalse. 218707 finished signal. 218708 ]. 218709 218710 producer2 := [ 218711 [monitor critical: 218712 [monitor waitWhile: [counter \\5 = 0]. 218713 goalReached or: [work add: (counter := counter + 1)]. 218714 goalReached := counter >= goal size. 218715 monitor signal]. 218716 goalReached 218717 ] whileFalse. 218718 finished signal 218719 ]. 218720 218721 producer1 forkAt: Processor userBackgroundPriority. 218722 producer2 forkAt: Processor userBackgroundPriority. 218723 218724 finished wait; wait. 218725 self assert: goal = work! ! 218726 218727!MonitorTest methodsFor: 'examples' stamp: 'md 3/19/2006 21:19'! 218728testExample2 218729 "Here is a second version that does not use a semaphore to inform the 218730 forking process about termination of both forked processes" 218731 218732 | producer1 producer2 monitor goal work counter goalReached activeProducers| 218733 goal := (1 to: 1000) asOrderedCollection. 218734 work := OrderedCollection new. 218735 counter := 0. 218736 goalReached := false. 218737 activeProducers := 0. 218738 monitor := Monitor new. 218739 218740 producer1 := 218741 [ monitor critical: [activeProducers := activeProducers + 1]. 218742 [monitor critical: 218743 [monitor waitUntil: [counter \\5 = 0]. 218744 goalReached or: [work add: (counter := counter + 1)]. 218745 " Transcript show: 'P1 '; show: counter printString; show: ' '; 218746 show: activeProducers printString; cr." 218747 goalReached := counter >= goal size. 218748 monitor signal 218749 ]. 218750 goalReached 218751 ] 218752 whileFalse. 218753 monitor critical: [activeProducers := activeProducers - 1. 218754 monitor signal: #finish]. 218755 ] . 218756 218757 producer2 := 218758 [monitor critical: [activeProducers := activeProducers + 1]. 218759 218760 [monitor critical: 218761 [monitor waitWhile: [counter \\5 = 0]. 218762 goalReached or: [work add: (counter := counter + 1)]. 218763 goalReached := counter >= goal size. 218764 monitor signal]. 218765 goalReached ] whileFalse. 218766 monitor critical: [ 218767 activeProducers := activeProducers - 1. 218768 monitor signal: #finish]. 218769 ]. 218770 218771 producer1 forkAt: Processor userBackgroundPriority. 218772 producer2 forkAt: Processor userBackgroundPriority. 218773 218774 218775 monitor critical: [ 218776 monitor waitUntil: [activeProducers = 0 & (goalReached)] 218777 for: #finish. 218778 ]. 218779 218780 self assert: goal = work 218781! ! 218782Timespan subclass: #Month 218783 instanceVariableNames: '' 218784 classVariableNames: '' 218785 poolDictionaries: 'ChronologyConstants' 218786 category: 'Kernel-Chronology'! 218787!Month commentStamp: 'brp 5/13/2003 09:48' prior: 0! 218788I represent a month.! 218789 218790 218791!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:04'! 218792asMonth 218793 218794 ^ self ! ! 218795 218796!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! 218797daysInMonth 218798 218799 ^ self duration days.! ! 218800 218801!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! 218802index 218803 218804 ^ self monthIndex ! ! 218805 218806!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! 218807name 218808 218809 ^ self monthName ! ! 218810 218811!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! 218812previous 218813 218814 ^ self class starting: (self start - 1) ! ! 218815 218816!Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! 218817printOn: aStream 218818 218819 aStream nextPutAll: self monthName, ' ', self year printString.! ! 218820 218821"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 218822 218823Month class 218824 instanceVariableNames: ''! 218825 218826!Month class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:27'! 218827daysInMonth: indexOrName forYear: yearInteger 218828 218829 | index | 218830 index := indexOrName isInteger 218831 ifTrue: [indexOrName] 218832 ifFalse: [self indexOfMonth: indexOrName]. 218833 ^ (DaysInMonth at: index) 218834 + ((index = 2 218835 and: [Year isLeapYear: yearInteger]) 218836 ifTrue: [1] ifFalse: [0])! ! 218837 218838!Month class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 09:29'! 218839indexOfMonth: aMonthName 218840 218841 1 to: 12 do: [ :i | (aMonthName, '*' match: (MonthNames at: i)) ifTrue: [^i] ]. 218842 self error: aMonthName , ' is not a recognized month name'.! ! 218843 218844!Month class methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 09:02'! 218845nameOfMonth: anIndex 218846 218847 ^ MonthNames at: anIndex.! ! 218848 218849 218850!Month class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:22'! 218851month: month year: year 218852 "Create a Month for the given <year> and <month>. 218853 <month> may be a number or a String with the 218854 name of the month. <year> should be with 4 digits." 218855 218856 ^ self starting: (DateAndTime year: year month: month day: 1) 218857! ! 218858 218859!Month class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:21'! 218860readFrom: aStream 218861 218862 | m y c | 218863 m := (ReadWriteStream with: '') reset. 218864 [(c := aStream next) isSeparator] whileFalse: [m nextPut: c]. 218865 [(c := aStream next) isSeparator] whileTrue. 218866 y := (ReadWriteStream with: '') reset. 218867 y nextPut: c. 218868 [aStream atEnd] whileFalse: [y nextPut: aStream next]. 218869 218870 ^ self 218871 month: m contents 218872 year: y contents 218873 218874"Month readFrom: 'July 1998' readStream" 218875! ! 218876 218877!Month class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 13:59'! 218878starting: aDateAndTime duration: aDuration 218879 "Override - a each month has a defined duration" 218880 | start adjusted days | 218881 start := aDateAndTime asDateAndTime. 218882 adjusted := DateAndTime 218883 year: start year 218884 month: start month 218885 day: 1. 218886 days := self daysInMonth: adjusted month forYear: adjusted year. 218887 ^ super 218888 starting: adjusted 218889 duration: (Duration days: days)! ! 218890ClassTestCase subclass: #MonthTest 218891 instanceVariableNames: 'month' 218892 classVariableNames: '' 218893 poolDictionaries: '' 218894 category: 'KernelTests-Chronology'! 218895!MonthTest commentStamp: 'brp 7/26/2003 22:44' prior: 0! 218896This is the unit test for the class Month. 218897! 218898 218899 218900!MonthTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 12:42'! 218901classToBeTested 218902 218903 ^ Month! ! 218904 218905!MonthTest methodsFor: 'Coverage' stamp: 'brp 7/26/2003 23:29'! 218906selectorsToBeIgnored 218907 218908 | deprecated private special | 218909 deprecated := #(). 218910 private := #( #printOn: ). 218911 special := #( #next ). 218912 218913 ^ super selectorsToBeIgnored, deprecated, private, special.! ! 218914 218915 218916!MonthTest methodsFor: 'Running' stamp: 'brp 8/6/2003 19:37'! 218917setUp 218918 218919 super setUp. 218920 month := Month month: 7 year: 1998.! ! 218921 218922!MonthTest methodsFor: 'Running' stamp: 'brp 8/6/2003 19:37'! 218923tearDown 218924 218925 super tearDown. 218926 month := nil.! ! 218927 218928 218929!MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:52'! 218930testConverting 218931 218932 self assert: month asDate = '1 July 1998' asDate! ! 218933 218934!MonthTest methodsFor: 'Tests' stamp: 'brp 1/30/2005 09:35'! 218935testEnumerating 218936 | weeks | 218937 weeks := OrderedCollection new. 218938 month weeksDo: [ :w | weeks add: w start ]. 218939 0 to: 4 do: [ :i | weeks remove: (Week starting: ('29 June 1998' asDate addDays: i * 7)) start ]. 218940 self assert: weeks isEmpty! ! 218941 218942!MonthTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 16:08'! 218943testInquiries 218944 218945 self 218946 assert: month index = 7; 218947 assert: month name = #July; 218948 assert: month duration = (31 days). 218949! ! 218950 218951!MonthTest methodsFor: 'Tests' stamp: 'nk 7/30/2004 17:52'! 218952testInstanceCreation 218953 | m1 m2 | 218954 m1 := Month starting: '4 July 1998' asDate. 218955 m2 := Month month: #July year: 1998. 218956 self 218957 assert: month = m1; 218958 assert: month = m2! ! 218959 218960!MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 23:02'! 218961testPreviousNext 218962 | n p | 218963 n := month next. 218964 p := month previous. 218965 218966 self 218967 assert: n year = 1998; 218968 assert: n index = 8; 218969 assert: p year = 1998; 218970 assert: p index = 6. 218971 218972! ! 218973 218974!MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:50'! 218975testPrinting 218976 218977 self 218978 assert: month printString = 'July 1998'. 218979! ! 218980 218981!MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:46'! 218982testReadFrom 218983 218984 | m | 218985 m := Month readFrom: 'July 1998' readStream. 218986 self 218987 assert: m = month! ! 218988Object subclass: #Morph 218989 instanceVariableNames: 'bounds owner submorphs fullBounds color extension' 218990 classVariableNames: 'EmptyArray' 218991 poolDictionaries: '' 218992 category: 'Morphic-Kernel'! 218993!Morph commentStamp: 'efc 2/26/2003 20:01' prior: 0! 218994A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://minnow.cc.gatech.edu/squeak/30. 218995 218996Morphs exist in a tree, rooted at a World (generally a PasteUpMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets drawn. To hide a Morph and its submorphs, set its #visible property to false using the #visible: method. 218997 218998The World (screen) coordinate system is used for most coordinates, but can be changed if there is a TransformMorph somewhere in the owner chain. 218999 219000My instance variables have accessor methods (e.g., #bounds, #bounds:). Most users should use the accessor methods instead of using the instance variables directly. 219001 219002Structure: 219003instance var Type Description 219004bounds Rectangle A Rectangle indicating my position and a size that will enclose me. 219005owner Morph My parent Morph, or nil for the top-level Morph, which is a 219006 or nil world, typically a PasteUpMorph. 219007submorphs Array My child Morphs. 219008fullBounds Rectangle A Rectangle minimally enclosing me and my submorphs. 219009color Color My primary color. Subclasses can use this in different ways. 219010extension MorphExtension Allows extra properties to be stored without adding a 219011 or nil storage burden to all morphs. 219012 219013By default, Morphs do not position their submorphs. Morphs may position their submorphs directly or use a LayoutPolicy to automatically control their submorph positioning. 219014 219015Although Morph has some support for BorderStyle, most users should use BorderedMorph if they want borders.! 219016]style[(2 5 130 37 59 12 325 14 209 12 2 4 4 11 1 11 9 90 5 123 5 35 9 66 5 78 14 209 12 91 11 24 13 22)f1,f1LMorph Hierarchy;,f1,f1Rhttp://minnow.cc.gatech.edu/squeak/30;,f1,f1LPasteUpMorph Comment;,f1,f1LTransformMorph Comment;,f1,f1u,f1,f1u,f1,f1u,f1i,f1,f1LRectangle Comment;,f1,f1LMorph Comment;,f1,f1LArray Comment;,f1,f1LRectangle Comment;,f1,f1LColor Comment;,f1,f1LMorphExtension Comment;,f1,f1LLayoutPolicy Comment;,f1,f1LBorderStyle Comment;,f1,f1LBorderedMorph Comment;,f1! 219017 219018 219019!Morph methodsFor: '*Morphic-Worlds' stamp: 'dgd 9/1/2004 16:10'! 219020clearArea 219021 "Answer the clear area of the receiver. It means the area free 219022 of docking bars." 219023 | visTop visBottom visLeft visRight | 219024 219025 visTop := self top. 219026 visBottom := self bottom. 219027 visLeft := self left. 219028 visRight := self right. 219029 219030 self dockingBars 219031 do: [:each | 219032 (each isAdheringToTop and: [each bottom > visTop]) 219033 ifTrue: [visTop := each bottom]. 219034 219035 (each isAdheringToBottom and: [each top < visBottom]) 219036 ifTrue: [visBottom := each top]. 219037 219038 (each isAdheringToLeft and: [each right > visLeft]) 219039 ifTrue: [visLeft := each right]. 219040 219041 (each isAdheringToRight and: [each left < visRight]) 219042 ifTrue: [visRight := each left] 219043 ]. 219044 219045 ^ Rectangle 219046 left: visLeft 219047 right: visRight 219048 top: visTop 219049 bottom: visBottom 219050! ! 219051 219052!Morph methodsFor: '*Morphic-Worlds' stamp: 'sw 7/1/1998 18:02'! 219053pasteUpMorph 219054 "Answer the closest containing morph that is a PasteUp morph" 219055 ^ self ownerThatIsA: PasteUpMorph! ! 219056 219057!Morph methodsFor: '*Morphic-Worlds' stamp: 'dgd 8/28/2004 18:43'! 219058pasteUpMorphHandlingTabAmongFields 219059 "Answer the nearest PasteUpMorph in my owner chain that has the tabAmongFields property, or nil if none" 219060 219061 | aPasteUp | 219062 aPasteUp := self owner. 219063 [aPasteUp notNil] whileTrue: 219064 [aPasteUp tabAmongFields ifTrue: 219065 [^ aPasteUp]. 219066 aPasteUp := aPasteUp owner]. 219067 ^ nil! ! 219068 219069!Morph methodsFor: '*Morphic-Worlds' stamp: 'sw 8/30/1998 09:47'! 219070topPasteUp 219071 "If the receiver is in a world, return that; otherwise return the outermost pasteup morph" 219072 ^ self outermostMorphThat: [:m | m isKindOf: PasteUpMorph]! ! 219073 219074!Morph methodsFor: '*Morphic-Worlds' stamp: 'dgd 9/27/2004 11:45'! 219075viewBox 219076 ^ self pasteUpMorph viewBox! ! 219077 219078 219079!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/21/2008 16:50'! 219080activate 219081 "Mark the receiver and submorphs as active (foreground)." 219082 219083 self submorphsDo: [:m | m activate]! ! 219084 219085!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/18/2006 11:58'! 219086adoptPaneColor 219087 "Adopt our pane color." 219088 219089 self adoptPaneColor: self paneColor! ! 219090 219091!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/20/2007 10:31'! 219092defaultTaskbarThumbnailExtent 219093 "Answer the default size of a taskbar thumbnail for the receiver." 219094 219095 ^320@320! ! 219096 219097!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/10/2007 13:40'! 219098dialogWindow 219099 "Answer the receiver's dialog window." 219100 219101 ^self ownerThatIsA: DialogWindow! ! 219102 219103!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/5/2007 12:55'! 219104drawKeyboardFocusOn: aCanvas 219105 "Draw the keyboard focus indication." 219106 219107 self focusIndicatorMorph 219108 drawOn: aCanvas! ! 219109 219110!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:21'! 219111enabled 219112 "Answer whether the receiver is enabled." 219113 219114 ^true! ! 219115 219116!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 14:29'! 219117focusBounds 219118 "Answer the bounds for drawing the focus indication." 219119 219120 ^self bounds! ! 219121 219122!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 14:59'! 219123focusColor 219124 "Answer the keyboard focus indication color." 219125 219126 ^self borderStyle color contrastingColor! ! 219127 219128!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/9/2009 17:44'! 219129focusIndicatorCornerRadius 219130 "Answer the corner radius preferred for the focus indicator 219131 for the receiver for themes that support this." 219132 219133 ^self theme focusIndicatorCornerRadiusFor: self ! ! 219134 219135!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/6/2007 15:35'! 219136focusIndicatorMorph 219137 "Answer the focus indicator morph for the receiver." 219138 219139 ^self theme focusIndicatorMorphFor: self! ! 219140 219141!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/28/2008 17:21'! 219142handleMouseWheel: anEvent 219143 "System level event handling." 219144 219145 anEvent wasHandled ifTrue:[^self]. 219146 (self handlesMouseWheel: anEvent) ifTrue:[ 219147 anEvent wasHandled: true. 219148 self mouseWheel: anEvent]! ! 219149 219150!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/23/2009 13:23'! 219151handlesDropShadowInHand 219152 "Answer whether the receiver will handle drop shadow drawing when picked up in the hand." 219153 219154 ^false! ! 219155 219156!Morph methodsFor: '*Polymorph-Widgets' stamp: 'di 9/14/1998 07:31'! 219157handlesMouseOver: evt 219158 "Do I want to receive mouseEnter: and mouseLeave: when the button is up and the hand is empty? The default response is false, except if you have added sensitivity to mouseEnter: or mouseLeave:, using the on:send:to: mechanism." 219159 219160 self eventHandler ifNotNil: [^ self eventHandler handlesMouseOver: evt]. 219161 ^ false! ! 219162 219163!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/25/2008 17:34'! 219164handlesMouseWheel: evt 219165 "Do I want to receive mouseWheel events?." 219166 219167 ^false! ! 219168 219169!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 17:21'! 219170hasKeyboardFocus 219171 "Answer whether the receiver has keyboard focus." 219172 219173 ^((self world ifNil: [^false]) 219174 activeHand ifNil: [^false]) keyboardFocus = self! ! 219175 219176!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/12/2007 10:12'! 219177initialColorInSystemWindow: aSystemWindow 219178 "Answer the colour the receiver should be when added to a SystemWindow." 219179 219180 ^Color white! ! 219181 219182!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/9/2007 10:36'! 219183isTaskbar 219184 "Answer false in the general case." 219185 219186 ^false! ! 219187 219188!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/27/2007 18:11'! 219189lastSubmorphRecursive 219190 "Answer recursive last submorph of the receiver." 219191 219192 ^self hasSubmorphs 219193 ifTrue: [self lastSubmorph lastSubmorphRecursive] 219194 ifFalse: [self]! ! 219195 219196!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/11/2006 09:37'! 219197modalLockTo: aSystemWindow 219198 "Lock the receiver as a modal owner of the given window." 219199 219200 self lock! ! 219201 219202!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/11/2006 09:38'! 219203modalUnlockFrom: aSystemWindow 219204 "Unlock the receiver as a modal owner of the given window." 219205 219206 self unlock! ! 219207 219208!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/25/2008 17:35'! 219209mouseWheel: evt 219210 "Handle a mouseWheel event."! ! 219211 219212!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/7/2006 15:53'! 219213myDependents 219214 "Improved performance dependents." 219215 219216 ^(self valueOfProperty: #myDependents) ifNil: [super myDependents]! ! 219217 219218!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/7/2006 15:55'! 219219myDependents: aCollectionOrNil 219220 "Improved performance dependents." 219221 219222 aCollectionOrNil isNil 219223 ifTrue: [self removeProperty: #myDependents] 219224 ifFalse: [self setProperty: #myDependents toValue: aCollectionOrNil]! ! 219225 219226!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/21/2007 14:37'! 219227navigateFocusBackward 219228 "Change the keyboard focus to the previous morph." 219229 219230 self previousMorphWantingFocus ifNotNilDo: [:m | 219231 m takeKeyboardFocus] 219232 ! ! 219233 219234!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/21/2007 14:38'! 219235navigateFocusForward 219236 "Change the keyboard focus to the next morph." 219237 219238 self nextMorphWantingFocus ifNotNilDo: [:m | 219239 m takeKeyboardFocus] 219240 ! ! 219241 219242!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/27/2008 15:16'! 219243navigationKey: event 219244 "Check for tab key activity and change focus as appropriate. 219245 Check for menu key to do popup." 219246 219247 (self tabKey: event) ifTrue: [^true]. 219248 (event keyCharacter = Character escape and: [ 219249 event anyModifierKeyPressed]) ifTrue: [ 219250 self yellowButtonActivity: false. 219251 ^true]. 219252 self window ifNotNilDo: [:win | 219253 (win handlesKeyboard: event) ifTrue: [ 219254 (win keyStroke: event) ifTrue: [^true]]]. 219255 ^false! ! 219256 219257!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 11:32'! 219258nextMorphAcrossInWindow 219259 "Answer the next morph in the window. Traverse 219260 from the receiver to its next sibling or owner's next sibling etc." 219261 219262 ^self submorphAfter ifNil: [ 219263 (self owner ifNil: [^self]) nextMorphAcrossInWindow]! ! 219264 219265!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 11:34'! 219266nextMorphInWindow 219267 "Answer the next morph in the window. Traverse 219268 from the receiver to its first child or next sibling or owner's next sibling etc." 219269 219270 ^self hasSubmorphs 219271 ifTrue: [self submorphs first] 219272 ifFalse: [self nextMorphAcrossInWindow]! ! 219273 219274!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/14/2009 17:53'! 219275nextMorphWantingFocus 219276 "Answer the next morph that wants keyboard focus." 219277 219278 |m| 219279 m := self nextMorphInWindow ifNil: [^nil]. 219280 [m = self or: [m wantsKeyboardFocusNavigation]] 219281 whileFalse: [m := m nextMorphInWindow]. 219282 ^m wantsKeyboardFocusNavigation 219283 ifTrue: [m] 219284 ! ! 219285 219286!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/22/2008 12:48'! 219287openModal: aSystemWindow 219288 "Open the given window locking the receiver until it is dismissed. 219289 Answer the system window. 219290 Restore the original keyboard focus when closed." 219291 219292 |area mySysWin keyboardFocus| 219293 keyboardFocus := self activeHand keyboardFocus. 219294 mySysWin := self isSystemWindow ifTrue: [self] ifFalse: [self ownerThatIsA: SystemWindow]. 219295 mySysWin ifNil: [mySysWin := self]. 219296 mySysWin modalLockTo: aSystemWindow. 219297 area := RealEstateAgent maximumUsableArea. 219298 self class environment at: #Flaps ifPresent: [:cl | 219299 RealEstateAgent reduceByFlaps: area]. 219300 aSystemWindow extent: aSystemWindow initialExtent. 219301 aSystemWindow position = (0@0) 219302 ifTrue: [aSystemWindow 219303 position: self activeHand position - (aSystemWindow extent // 2)]. 219304 aSystemWindow 219305 bounds: (aSystemWindow bounds translatedToBeWithin: area). 219306 [ToolBuilder default runModal: aSystemWindow openAsIs] 219307 ensure: [mySysWin modalUnlockFrom: aSystemWindow. 219308 self activeHand newKeyboardFocus: keyboardFocus]. 219309 ^aSystemWindow! ! 219310 219311!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/8/2007 09:58'! 219312optimalExtent 219313 "Answer the submorphBounds extent plus twice our border width." 219314 219315 ^self submorphBounds extent + (self borderWidth * 2)! ! 219316 219317!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/9/2007 12:25'! 219318paneColor 219319 "Answer the window's pane color or our color otherwise." 219320 219321 ^self paneColorOrNil ifNil: [self color]! ! 219322 219323!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/29/2008 15:14'! 219324paneColor: aColor 219325 "Explicitly set the pane color for the reveiver." 219326 219327 self setProperty: #paneColor toValue: aColor. 219328 self adoptPaneColor! ! 219329 219330!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/29/2008 14:56'! 219331paneColorOrNil 219332 "Answer the window's pane color or nil otherwise." 219333 219334 ^self valueOfProperty: #paneColor ifAbsent: [ 219335 (self owner ifNil: [^nil]) paneColorOrNil]! ! 219336 219337!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/21/2008 16:51'! 219338passivate 219339 "Mark the receiver and submorphs as passive (background)." 219340 219341 self submorphsDo: [:m | m passivate]! ! 219342 219343!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/27/2009 13:47'! 219344preferredButtonCornerStyle 219345 "Answer the preferred button corner style 219346 for submorphs. Answer nil for no preference." 219347 219348 ^nil! ! 219349 219350!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/13/2007 15:25'! 219351preferredCornerStyle 219352 "Answer the preferred corner style." 219353 219354 ^#square! ! 219355 219356!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:06'! 219357previousMorphInWindow 219358 "Answer the next morph in the window. Traverse 219359 from the receiver to its previous sibling's last submorph (recursive) 219360 or owner's previous sibling's last submorph (recursive) etc." 219361 219362 ^self submorphBefore notNil 219363 ifTrue: [self submorphBefore lastSubmorphRecursive] 219364 ifFalse: [self owner]! ! 219365 219366!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/8/2007 13:41'! 219367previousMorphWantingFocus 219368 "Answer the previous morph that wants keyboard focus." 219369 219370 |m| 219371 m := self previousMorphInWindow ifNil: [^nil]. 219372 [m = self or: [m wantsKeyboardFocusNavigation]] 219373 whileFalse: [m := m previousMorphInWindow ifNil: [^nil]]. 219374 ^m wantsKeyboardFocusNavigation 219375 ifTrue: [m] 219376 ! ! 219377 219378!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/12/2009 18:14'! 219379roundedCorners: anArray 219380 "Set the corners to round." 219381 219382 anArray = #(1 2 3 4) 219383 ifTrue: [self removeProperty: #roundedCorners] 219384 ifFalse: [self setProperty: #roundedCorners toValue: anArray]. 219385 self changed! ! 219386 219387!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/15/2009 13:35'! 219388shadowOffsetRectangle 219389 "Answer a rectangle describing the offsets to the 219390 receiver's bounds for a drop shadow." 219391 219392 ^self shadowOffset negated corner: self shadowOffset! ! 219393 219394!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/16/2008 16:57'! 219395tabKey: event 219396 "Check for tab key activity and change focus as appropriate." 219397 219398 event controlKeyPressed ifFalse: [ 219399 event keyCharacter = Character tab ifTrue: [ 219400 event shiftPressed 219401 ifTrue: [self navigateFocusBackward] 219402 ifFalse: [self navigateFocusForward]. 219403 ^true]]. 219404 ^false! ! 219405 219406!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/21/2007 14:35'! 219407takeKeyboardFocus 219408 "Make the receiver the keyboard focus for the active hand." 219409 219410 self activeHand newKeyboardFocus: self! ! 219411 219412!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:27'! 219413takesKeyboardFocus 219414 "Answer whether the receiver can normally take keyboard focus." 219415 219416 ^ false! ! 219417 219418!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/20/2007 11:30'! 219419taskThumbnailOfSize: thumbExtent 219420 "Answer a new task thumbnail for the receiver." 219421 219422 |f t r| 219423 r := self bounds scaledAndCenteredIn: (0@0 extent: thumbExtent). 219424 f := Form extent: r extent depth: Display depth. 219425 t := MatrixTransform2x3 withScale: f extent / self extent. 219426 f getCanvas 219427 transformBy: t 219428 clippingTo: f boundingBox 219429 during: [:c | c translateBy: self topLeft negated during: [:ct | self fullDrawOn: ct]] 219430 smoothing: 2. 219431 ^ImageMorph new 219432 image: f! ! 219433 219434!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/17/2007 17:44'! 219435taskbarButtonFor: aTaskBar 219436 "Answer a new task bar button for the receiver. 219437 Answer nil if not required." 219438 219439 ^nil! ! 219440 219441!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 12:30'! 219442taskbarTask 219443 "Answer a new taskbar task for the receiver. 219444 Answer nil if not required." 219445 219446 ^nil! ! 219447 219448!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/11/2007 15:04'! 219449taskbarThumbnail 219450 "Answer a new taskbar thumbnail for the receiver." 219451 219452 ^self taskThumbnailOfSize: self taskbarThumbnailExtent! ! 219453 219454!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/11/2007 15:03'! 219455taskbarThumbnailExtent 219456 "Answer the size of a taskbar thumbnail for the receiver." 219457 219458 ^self extent min: self defaultTaskbarThumbnailExtent! ! 219459 219460!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/9/2007 10:36'! 219461taskbars 219462 "Answer the receiver's taskbars." 219463 219464 ^self submorphs select: [:each | 219465 each isTaskbar]! ! 219466 219467!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 15:51'! 219468theme 219469 "Answer the current theme for the receiver." 219470 219471 (self valueOfProperty: #theme) ifNotNilDo: [:t | ^ t]. 219472 ^(self window ifNil: [self class]) theme! ! 219473 219474!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/10/2008 16:47'! 219475theme: aUITheme 219476 "Set the current theme for the receiver." 219477 219478 self theme = aUITheme ifFalse: [ 219479 self setProperty: #theme toValue: aUITheme. 219480 self themeChanged]! ! 219481 219482!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/9/2007 11:26'! 219483themeChanged 219484 "The current theme has changed. 219485 Update any dependent visual aspects." 219486 219487 self submorphsDo: [:m | m themeChanged]. 219488 self changed! ! 219489 219490!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/29/2008 16:06'! 219491toggleVisible 219492 "Toggle the visibility of the receiver." 219493 219494 self visible 219495 ifTrue: [self hide] 219496 ifFalse: [self show]! ! 219497 219498!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/29/2008 16:18'! 219499toggleVisibleAndRaise 219500 "Toggle the visibility of the receiver, brining to 219501 the front if becoming visible." 219502 219503 self visible 219504 ifTrue: [self hide] 219505 ifFalse: [self comeToFront; show]! ! 219506 219507!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/5/2007 15:22'! 219508wantsKeyboardFocus 219509 "Answer whether the receiver would like keyboard focus 219510 in the general case (mouse action normally)." 219511 219512 ^self takesKeyboardFocus and: [ 219513 self visible and: [self enabled]]! ! 219514 219515!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/5/2007 15:24'! 219516wantsKeyboardFocusNavigation 219517 "Answer whether the receiver would like keyboard focus 219518 when navigated to by keyboard." 219519 219520 ^self wantsKeyboardFocus! ! 219521 219522!Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/10/2007 10:07'! 219523window 219524 "Answer the receiver's window." 219525 219526 ^self ownerThatIsA: SystemWindow! ! 219527 219528 219529!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/20/2009 18:42'! 219530boundsWithinCorners 219531 "Changed to be more realistic..." 219532 219533 ^self bounds insetBy: 2! ! 219534 219535!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/16/2007 11:26'! 219536changed 219537 "Report that the area occupied by this morph should be redrawn. 219538 Fixed to include submorphs outside the outerBounds." 219539 219540 ^fullBounds 219541 ifNil: [self invalidRect: self privateFullBounds] 219542 ifNotNil: [self invalidRect: fullBounds]! ! 219543 219544!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/16/2009 11:15'! 219545expandFullBoundsForDropShadow: aRectangle 219546 "Return an expanded rectangle for an eventual drop shadow." 219547 219548 ^(aRectangle expandBy: self shadowOffsetRectangle) 219549 quickMerge: aRectangle! ! 219550 219551!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2007 14:31'! 219552fillStyle: aFillStyle 219553 "Set the current fillStyle of the receiver. 219554 Optimized for no change." 219555 219556 (self valueOfProperty: #fillStyle ifAbsent: []) = aFillStyle 219557 ifTrue: [^self]. "no change optimization" 219558 self setProperty: #fillStyle toValue: aFillStyle. 219559 "Workaround for Morphs not yet converted" 219560 color := aFillStyle asColor. 219561 self changed.! ! 219562 219563!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/25/2008 22:42'! 219564focusChanged 219565 "Report that the area occupied by the morph's focus indicator should be redrawn. 219566 Optimized for border-only (no fill)." 219567 219568 |rects fm| 219569 fm := self focusIndicatorMorph. 219570 fm fillStyle isTransparent 219571 ifTrue: [fm borderWidth > 0 ifTrue: [ 219572 rects := fm bounds areasOutside: (fm bounds insetBy: fm borderWidth). 219573 rects do: [:r | self invalidRect: r]]] 219574 ifFalse: [self invalidRect: fm bounds]! ! 219575 219576!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'damiencassou 7/3/2009 13:09'! 219577handlerForBlueButtonDown: anEvent 219578 "Return the (prospective) handler for a mouse down event. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event. 219579 Note: Halos handle blue button events themselves so we will only be asked if there is currently no halo on top of us. 219580 Check whtehr halods are enabled (for deployment)." 219581 219582 "Preferences halosEnabled ifFalse: [^nil]." 219583 "self halt." 219584 self wantsHaloFromClick ifFalse:[^nil]. 219585 "anEvent handler ifNil:[^self]. 219586 anEvent handler isPlayfieldLike ifTrue:[^self]. ""by default exclude playfields" 219587 (anEvent shiftPressed) 219588 ifFalse:[^nil] "let outer guy have it" 219589 ifTrue:[^self] "let me have it" 219590! ! 219591 219592!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/2/2009 13:24'! 219593layoutChanged 219594 "Fixed to always flush layout cache - finally tracked down 219595 layout anomalies due to cached extents in layout 219596 policies not being flushed, the previous (incorrect) assumption being 219597 that it did not matter if layout was to be recomputed (fullBounds being nil). 219598 Recomputing of the layout apparently does not flush so must be done here." 219599 219600 | layout | 219601 fullBounds := nil. 219602 layout := self layoutPolicy. 219603 layout ifNotNil:[layout flushLayoutCache]. 219604 owner ifNotNil: [owner layoutChanged]. 219605 "note: does not send #ownerChanged here - we'll do this when computing the new layout"! ! 219606 219607!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 11/12/2007 17:20'! 219608layoutInBounds: cellBounds 219609 "Layout specific. Apply the given bounds to the receiver after being layed out in its owner." 219610 | box aSymbol delta | 219611 fullBounds ifNil:["We are getting new bounds here but we haven't computed the receiver's layout yet. Although the receiver has reported its minimal size before the actual size it has may differ from what would be after the layout. Normally, this isn't a real problem, but if we have #shrinkWrap constraints then the receiver's bounds may be larger than the cellBounds. THAT is a problem because the centering may not work correctly if the receiver shrinks after the owner layout has been computed. To avoid this problem, we compute the receiver's layout now. Note that the layout computation is based on the new cell bounds rather than the receiver's current bounds." 219612 cellBounds origin = self bounds origin ifFalse:[ 219613 box := self outerBounds. 219614 delta := cellBounds origin - self bounds origin. 219615 self invalidRect: (box merge: (box translateBy: delta)). 219616 self privateFullMoveBy: delta]. "sigh..." 219617 box := cellBounds origin extent: "adjust for #rigid receiver" 219618 (self hResizing == #rigid ifTrue:[self bounds extent x] ifFalse:[cellBounds extent x]) @ 219619 (self vResizing == #rigid ifTrue:[self bounds extent y] ifFalse:[cellBounds extent y]). 219620 "Compute inset of layout bounds" 219621 box := box origin - (self bounds origin - self layoutBounds origin) corner: 219622 box corner - (self bounds corner - self layoutBounds corner). 219623 "And do the layout within the new bounds" 219624 self layoutBounds: box. 219625 self doLayoutIn: box]. 219626 cellBounds = self bounds ifTrue:[^self]. "already up to date. Fixed here to use bounds rather than fullBounds for the check." 219627 cellBounds extent = self bounds extent "nice fit. Fixed here to use bounds rather than fullBounds for the check." 219628 ifTrue:[^self position: cellBounds origin]. 219629 box := bounds. 219630 "match #spaceFill constraints" 219631 self hResizing == #spaceFill 219632 ifTrue:[box := box origin extent: cellBounds width @ box height]. 219633 self vResizing == #spaceFill 219634 ifTrue:[box := box origin extent: box width @ cellBounds height]. 219635 "align accordingly" 219636 aSymbol := (owner ifNil:[self]) cellPositioning. 219637 box := box align: (box perform: aSymbol) with: (cellBounds perform: aSymbol). 219638 "and install new bounds" 219639 self bounds: box.! ! 219640 219641!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2007 14:32'! 219642minExtent 219643 "Layout specific. Return the minimum size the receiver can be represented in. 219644 Implementation note: When this message is sent from an owner trying to lay out its children it will traverse down the morph tree and recompute the minimal arrangement of the morphs based on which the minimal extent is returned. When a morph with some layout strategy is encountered, the morph will ask its strategy to compute the new arrangement. However, since the final size given to the receiver is unknown at the point of the query, the assumption is made that the current bounds of the receiver are the base on which the layout should be computed. This scheme prevents strange layout changes when for instance, a table is contained in another table. Unless the inner table has been resized manually (which means its bounds are already enlarged) the arrangement of the inner table will not change here. Thus the entire layout computation is basically an iterative process which may have different results depending on the incremental changes applied. 219645 Fixed for shrinkWrap." 219646 219647 | layout minExtent extra hFit vFit | 219648 hFit := self hResizing. 219649 vFit := self vResizing. 219650 (hFit == #rigid and: [vFit == #rigid]) 219651 ifTrue: 219652 ["The receiver will not adjust to parents layout by growing or shrinking, 219653 which means that an accurate layout defines the minimum size." 219654 219655 ^self fullBounds extent]. 219656 219657 "An exception -- a receiver with #shrinkWrap constraints but no children is being treated #rigid (the equivalent to a #spaceFill receiver in a non-layouting owner)" 219658 self hasSubmorphs 219659 ifFalse: 219660 [hFit == #shrinkWrap ifTrue: [hFit := #rigid]. 219661 vFit == #shrinkWrap ifTrue: [vFit := #rigid]]. 219662 layout := self layoutPolicy. 219663 layout isNil 219664 ifTrue: [minExtent := 0 @ 0] 219665 ifFalse: [minExtent := layout minExtentOf: self in: self layoutBounds]. 219666 hFit == #rigid 219667 ifTrue: [minExtent := self fullBounds extent x @ minExtent y] 219668 ifFalse: 219669 [extra := self bounds width - self layoutBounds width. 219670 minExtent := (minExtent x + extra) @ minExtent y]. 219671 minExtent := vFit == #rigid 219672 ifTrue: [minExtent x @ self fullBounds extent y] 219673 ifFalse: 219674 [extra := self bounds height - self layoutBounds height. 219675 minExtent x @ (minExtent y + extra)]. 219676 minExtent := minExtent max: self minWidth @ self minHeight. 219677 ^minExtent! ! 219678 219679!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/24/2009 13:43'! 219680morphicLayerNumberWithin: anOwner 219681 "Helpful for insuring some morphs always appear in front of or behind others. 219682 Smaller numbers are in front. 219683 Fixed here to call #morphicLayerNumber rather than access property directly." 219684 219685 ^self morphicLayerNumber! ! 219686 219687!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/16/2007 15:18'! 219688openInWindowLabeled: aString inWorld: aWorld 219689 "Changed to include the inset margin in the bound calculation." 219690 219691 | window extent | 219692 window := (SystemWindow labelled: aString) model: nil. 219693 window 219694 " guess at initial extent" 219695 bounds: (RealEstateAgent initialFrameFor: window initialExtent: self fullBounds extent world: aWorld); 219696 addMorph: self frame: (0@0 extent: 1@1); 219697 updatePaneColors. 219698 " calculate extent after adding in case any size related attributes were changed. Use 219699 fullBounds in order to trigger re-layout of layout morphs" 219700 extent := self fullBounds extent + 219701 (window borderWidth@window labelHeight) + window borderWidth + 219702 (window class borderWidth * 2 @ (window class borderWidth + 1)). "include inset margin" 219703 window extent: extent. 219704 aWorld addMorph: window. 219705 window activate. 219706 aWorld startSteppingSubmorphsOf: window. 219707 ^window 219708! ! 219709 219710!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/25/2008 12:12'! 219711privateMoveBy: delta 219712 "Private!! Use 'position:' instead." 219713 | fill border| 219714 extension ifNotNil: [extension player 219715 ifNotNil: ["Most cases eliminated fast by above test" 219716 self getPenDown 219717 ifTrue: ["If this is a costume for a player with its 219718 pen down, draw a line." 219719 self moveWithPenDownBy: delta]]]. 219720 bounds := bounds translateBy: delta. 219721 fullBounds ifNotNil: [fullBounds := fullBounds translateBy: delta]. 219722 fill := self fillStyle. 219723 fill isOrientedFill ifTrue: [fill origin: fill origin + delta]. 219724 border := self borderStyle. 219725 (border hasFillStyle and: [border fillStyle isOrientedFill]) ifTrue: [ 219726 border fillStyle origin: border fillStyle origin + delta]! ! 219727 219728!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/28/2008 16:17'! 219729rejectsEvent: anEvent 219730 "Return true to reject the given event. 219731 Rejecting an event means neither the receiver nor any of it's submorphs will be given any chance to handle it. 219732 If the event is a mouse wheel event then only reject if the receiver is not visible." 219733 219734 (anEvent isMouse and: [anEvent isMouseWheel]) 219735 ifTrue: [^self visible not]. 219736 ^self isLocked or: [self visible not]! ! 219737 219738!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/12/2009 18:12'! 219739roundedCorners 219740 "Return a list of those corners to round. 219741 219742 1-4 219743 | | 219744 2-3 219745 219746 Returned array contains `codes' of those corners, which should be rounded. 219747 219748 1 denotes top-left corner 219749 2 denotes bottom-left corner 219750 3 denotes bottom-right corner 219751 4 denotes top-right corner. 219752 219753 Thus, if this method returned #(2 3) that would mean that bottom (left and right) 219754 corners would be rounded whereas top (left and right) corners wouldn't be rounded. 219755 219756 This method returns #(1 2 3 4) and that means that all the corners should be rounded." 219757 219758 ^self valueOfProperty: #roundedCorners ifAbsent: [#(1 2 3 4)]! ! 219759 219760!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/30/2009 14:10'! 219761showBalloon: msgString hand: aHand 219762 "Pop up a balloon containing the given string, 219763 first removing any existing BalloonMorphs in the world." 219764 219765 |w h| 219766 (w := self world) ifNil: [^self]. 219767 h := aHand ifNil: [w activeHand]. 219768 (UITheme builder newBalloonHelp: msgString for: self balloonHelpAligner) 219769 popUpFor: self hand: h! ! 219770 219771!Morph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/17/2006 10:36'! 219772visible: aBoolean 219773 "set the 'visible' attribute of the receiver to aBoolean. 219774 Must update owner layout since its full bounds may depend 219775 on the receiver extending beyond its bounds." 219776 219777 (extension isNil and:[aBoolean]) ifTrue: [^ self]. 219778 self visible == aBoolean ifTrue: [^ self]. 219779 self assureExtension visible: aBoolean. 219780 self changed. 219781 owner ifNotNil: [owner layoutChanged]! ! 219782 219783 219784!Morph methodsFor: '*services-base' stamp: 'rr 6/10/2005 11:30'! 219785requestor 219786 ^ owner ifNil: [super requestor] ifNotNil: [owner requestor]! ! 219787 219788 219789!Morph methodsFor: 'accessing' stamp: 'ar 12/18/2001 20:09'! 219790adoptPaneColor: paneColor 219791 self submorphsDo:[:m| m adoptPaneColor: paneColor].! ! 219792 219793!Morph methodsFor: 'accessing' stamp: 'marcus.denker 11/20/2008 12:21'! 219794balloonText 219795 "Answer balloon help text or nil, if no help is available. 219796 NB: subclasses may override such that they programatically 219797 construct the text, for economy's sake, such as model phrases in 219798 a Viewer" 219799 219800 | text balloonSelector aString | 219801 extension ifNil: [^nil]. 219802 (text := extension balloonText) ifNotNil: [^text]. 219803 (balloonSelector := extension balloonTextSelector) ifNotNil: 219804 [aString := ScriptingSystem helpStringOrNilFor: balloonSelector. 219805 ((aString isNil and: [balloonSelector numArgs = 0]) 219806 and: [self respondsTo: balloonSelector]) 219807 ifTrue: [aString := self perform: balloonSelector]]. 219808 ^aString ifNotNil: 219809 [aString asString 219810 withNoLineLongerThan: Preferences maxBalloonHelpLineLength]! ! 219811 219812!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:52'! 219813balloonTextSelector 219814 "Answer balloon text selector item in the extension, nil if none" 219815 ^ extension ifNotNil: [extension balloonTextSelector]! ! 219816 219817!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:50'! 219818balloonTextSelector: aSelector 219819 "change the receiver's balloonTextSelector" 219820 self assureExtension balloonTextSelector: aSelector! ! 219821 219822!Morph methodsFor: 'accessing' stamp: 'sw 10/31/2001 21:06'! 219823beFlap: aBool 219824 "Mark the receiver with the #flap property, or unmark it" 219825 219826 aBool 219827 ifTrue: 219828 [self setProperty: #flap toValue: true. 219829 self hResizing: #rigid. 219830 self vResizing: #rigid] 219831 ifFalse: 219832 [self removeProperty: #flap]! ! 219833 219834!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:57'! 219835beSticky 219836 "make the receiver sticky" 219837 self assureExtension sticky: true! ! 219838 219839!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:52'! 219840beUnsticky 219841 "If the receiver is marked as sticky, make it now be unsticky" 219842 extension ifNotNil: [extension sticky: false]! ! 219843 219844!Morph methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:28'! 219845borderColor 219846 ^self borderStyle color! ! 219847 219848!Morph methodsFor: 'accessing' stamp: 'nk 4/15/2004 10:55'! 219849borderColor: aColorOrSymbolOrNil 219850 "Unfortunately, the argument to borderColor could be more than just a color. 219851 It could also be a symbol, in which case it is to be interpreted as a style identifier. 219852 But I might not be able to draw that kind of border, so it may have to be ignored. 219853 Or it could be nil, in which case I should revert to the default border." 219854 219855 | style newStyle | 219856 style := self borderStyle. 219857 style baseColor = aColorOrSymbolOrNil 219858 ifTrue: [^ self]. 219859 219860 aColorOrSymbolOrNil isColor 219861 ifTrue: [style style = #none "default border?" 219862 ifTrue: [self borderStyle: (SimpleBorder width: 0 color: aColorOrSymbolOrNil)] 219863 ifFalse: [style baseColor: aColorOrSymbolOrNil. 219864 self changed]. 219865 ^ self]. 219866 219867 self 219868 borderStyle: ( ({ nil. #none } includes: aColorOrSymbolOrNil) 219869 ifTrue: [BorderStyle default] 219870 ifFalse: [ "a symbol" 219871 self doesBevels ifFalse: [ ^self ]. 219872 newStyle := (BorderStyle perform: aColorOrSymbolOrNil) 219873 color: style color; 219874 width: style width; 219875 yourself. 219876 (self canDrawBorder: newStyle) 219877 ifTrue: [newStyle] 219878 ifFalse: [style]])! ! 219879 219880!Morph methodsFor: 'accessing' stamp: 'marcus.denker 9/14/2008 18:37'! 219881borderStyle 219882 extension ifNil: [^BorderStyle default trackColorFrom: self]. 219883 ^(extension valueOfProperty: #borderStyle ifAbsent:[BorderStyle default]) trackColorFrom: self! ! 219884 219885!Morph methodsFor: 'accessing' stamp: 'sw 11/26/2001 16:18'! 219886borderStyleForSymbol: aStyleSymbol 219887 "Answer a suitable BorderStyle for me of the type represented by a given symbol" 219888 219889 | aStyle existing | 219890 aStyle := BorderStyle borderStyleForSymbol: aStyleSymbol asSymbol. 219891 aStyle ifNil: [self error: 'bad style']. 219892 existing := self borderStyle. 219893 aStyle width: existing width; 219894 baseColor: existing baseColor. 219895 ^ (self canDrawBorder: aStyle) 219896 ifTrue: 219897 [aStyle] 219898 ifFalse: 219899 [nil]! ! 219900 219901!Morph methodsFor: 'accessing' stamp: 'ar 12/11/2001 22:14'! 219902borderStyle: newStyle 219903 newStyle = self borderStyle ifFalse:[ 219904 (self canDrawBorder: newStyle) ifFalse:[ 219905 "Replace the suggested border with a simple one" 219906 ^self borderStyle: (BorderStyle width: newStyle width color: (newStyle trackColorFrom: self) color)]. 219907 self setProperty: #borderStyle toValue: newStyle. 219908 self changed].! ! 219909 219910!Morph methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:28'! 219911borderWidth 219912 ^self borderStyle width! ! 219913 219914!Morph methodsFor: 'accessing' stamp: 'di 2/6/2001 14:02'! 219915borderWidthForRounding 219916 219917 ^ self borderWidth! ! 219918 219919!Morph methodsFor: 'accessing' stamp: 'nk 4/14/2004 17:48'! 219920borderWidth: aNumber 219921 | style | 219922 style := self borderStyle. 219923 style width = aNumber ifTrue: [ ^self ]. 219924 219925 style style = #none 219926 ifTrue: [ self borderStyle: (SimpleBorder width: aNumber color: Color transparent) ] 219927 ifFalse: [ style width: aNumber. self changed ]. 219928! ! 219929 219930!Morph methodsFor: 'accessing' stamp: 'tk 2/15/2001 15:55'! 219931color 219932 219933 ^ color "has already been set to ((self valueOfProperty: #fillStyle) asColor)"! ! 219934 219935!Morph methodsFor: 'accessing' stamp: 'ar 8/15/2001 22:40'! 219936colorForInsets 219937 "Return the color to be used for shading inset borders. The default is my own color, but it might want to be, eg, my owner's color. Whoever's color ends up prevailing, the color itself gets the last chance to determine, so that when, for example, an InfiniteForm serves as the color, callers won't choke on some non-Color object being returned" 219938 (color isColor and:[color isTransparent and:[owner notNil]]) ifTrue:[^owner colorForInsets]. 219939 ^ color colorForInsets 219940! ! 219941 219942!Morph methodsFor: 'accessing' stamp: 'ar 8/6/2001 09:03'! 219943color: aColor 219944 "Set the receiver's color. Directly set the color if appropriate, else go by way of fillStyle" 219945 219946 (aColor isColor or: [aColor isKindOf: InfiniteForm]) ifFalse:[^ self fillStyle: aColor]. 219947 color = aColor ifFalse: 219948 [self removeProperty: #fillStyle. 219949 color := aColor. 219950 self changed]! ! 219951 219952!Morph methodsFor: 'accessing' stamp: 'ar 12/27/2001 17:56'! 219953couldHaveRoundedCorners 219954 ^ true! ! 219955 219956!Morph methodsFor: 'accessing' stamp: 'nk 4/15/2004 07:50'! 219957doesBevels 219958 "To return true means that this object can show bevelled borders, and 219959 therefore can accept, eg, #raised or #inset as valid borderColors. 219960 Must be overridden by subclasses that do not support bevelled borders." 219961 219962 ^ false! ! 219963 219964!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:53'! 219965eventHandler 219966 "answer the receiver's eventHandler" 219967 ^ extension ifNotNil: [extension eventHandler] ! ! 219968 219969!Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 19:25'! 219970eventHandler: anEventHandler 219971 "Note that morphs can share eventHandlers and all is OK. " 219972 self assureExtension eventHandler: anEventHandler! ! 219973 219974!Morph methodsFor: 'accessing' stamp: 'ar 9/22/2000 13:36'! 219975forwardDirection 219976 "Return the receiver's forward direction (in eToy terms)" 219977 ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! ! 219978 219979!Morph methodsFor: 'accessing' stamp: 'di 1/3/1999 12:25'! 219980hasTranslucentColor 219981 "Answer true if this any of this morph is translucent but not transparent." 219982 219983 ^ color isColor and: [color isTranslucentColor] 219984! ! 219985 219986!Morph methodsFor: 'accessing' stamp: 'sw 11/30/1998 12:44'! 219987highlight 219988 "The receiver is being asked to appear in a highlighted state. Mostly used for textual morphs" 219989 self color: self highlightColor! ! 219990 219991!Morph methodsFor: 'accessing' stamp: 'sw 3/6/1999 02:09'! 219992highlightColor 219993 219994 | val | 219995 ^ (val := self valueOfProperty: #highlightColor) 219996 ifNotNil: 219997 [val ifNil: [self error: 'nil highlightColor']] 219998 ifNil: 219999 [owner ifNil: [self color] ifNotNil: [owner highlightColor]]! ! 220000 220001!Morph methodsFor: 'accessing' stamp: 'sw 7/2/1998 13:51'! 220002highlightColor: aColor 220003 self setProperty: #highlightColor toValue: aColor! ! 220004 220005!Morph methodsFor: 'accessing' stamp: 'tk 1/31/2002 10:25'! 220006insetColor 220007 owner ifNil:[^self color]. 220008 ^ self colorForInsets! ! 220009 220010!Morph methodsFor: 'accessing' stamp: 'sw 6/13/2001 01:04'! 220011isFlap 220012 "Answer whether the receiver claims to be a flap" 220013 220014 ^ self hasProperty: #flap! ! 220015 220016!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:53'! 220017isLocked 220018 "answer whether the receiver is Locked" 220019 extension ifNil: [^ false]. 220020 ^ extension locked! ! 220021 220022!Morph methodsFor: 'accessing' stamp: 'sw 10/27/2000 17:42'! 220023isShared 220024 "Answer whether the receiver has the #shared property. This property allows it to be treated as a 'background' item" 220025 220026 ^ self hasProperty: #shared! ! 220027 220028!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:57'! 220029isSticky 220030 "answer whether the receiver is Sticky" 220031 extension ifNil: [^ false]. 220032 ^ extension sticky! ! 220033 220034!Morph methodsFor: 'accessing' stamp: 'sw 8/4/97 12:05'! 220035lock 220036 self lock: true! ! 220037 220038!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:58'! 220039lock: aBoolean 220040 "change the receiver's lock property" 220041 (extension isNil and: [aBoolean not]) ifTrue: [^ self]. 220042 self assureExtension locked: aBoolean! ! 220043 220044!Morph methodsFor: 'accessing' stamp: 'sw 10/23/1999 22:35'! 220045modelOrNil 220046 ^ nil! ! 220047 220048!Morph methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 9/10/2009 15:07'! 220049player 220050 "answer the receiver's player" 220051 ^ nil! ! 220052 220053!Morph methodsFor: 'accessing' stamp: 'sw 3/3/1999 13:08'! 220054presenter 220055 ^ owner ifNotNil: [owner presenter] ifNil: [self currentWorld presenter]! ! 220056 220057!Morph methodsFor: 'accessing' stamp: 'dgd 3/7/2003 15:24'! 220058raisedColor 220059 "Return the color to be used for shading raised borders. The 220060 default is my own color, but it might want to be, eg, my 220061 owner's color. Whoever's color ends up prevailing, the color 220062 itself gets the last chance to determine, so that when, for 220063 example, an InfiniteForm serves as the color, callers won't choke 220064 on some non-Color object being returned" 220065 (color isColor 220066 and: [color isTransparent 220067 and: [owner notNil]]) 220068 ifTrue: [^ owner raisedColor]. 220069 ^ color asColor raisedColor! 220070]style[(11 2 355 3 5 18 5 26 5 24 5 18 5 20)f2b,f2,f2c144042000,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2! ! 220071 220072!Morph methodsFor: 'accessing' stamp: 'sw 3/6/1999 02:09'! 220073regularColor 220074 220075 | val | 220076 ^ (val := self valueOfProperty: #regularColor) 220077 ifNotNil: 220078 [val ifNil: [self error: 'nil regularColor']] 220079 ifNil: 220080 [owner ifNil: [self color] ifNotNil: [owner regularColor]]! ! 220081 220082!Morph methodsFor: 'accessing' stamp: 'sw 7/2/1998 13:51'! 220083regularColor: aColor 220084 self setProperty: #regularColor toValue: aColor! ! 220085 220086!Morph methodsFor: 'accessing' stamp: 'sw 8/29/2000 14:56'! 220087rememberedColor 220088 "Answer a rememberedColor, or nil if none" 220089 220090 ^ self valueOfProperty: #rememberedColor ifAbsent: [nil]! ! 220091 220092!Morph methodsFor: 'accessing' stamp: 'sw 8/29/2000 15:47'! 220093rememberedColor: aColor 220094 "Place aColor in a property so I can retrieve it later. A tortuous but expedient flow of data" 220095 220096 ^ self setProperty: #rememberedColor toValue: aColor! ! 220097 220098!Morph methodsFor: 'accessing' stamp: 'sw 11/15/2001 16:33'! 220099resistsRemoval 220100 "Answer whether the receiver is marked as resisting removal" 220101 220102 ^ self hasProperty: #resistsRemoval! ! 220103 220104!Morph methodsFor: 'accessing' stamp: 'sw 11/15/2001 16:33'! 220105resistsRemoval: aBoolean 220106 "Set the receiver's resistsRemoval property as indicated" 220107 220108 aBoolean 220109 ifTrue: 220110 [self setProperty: #resistsRemoval toValue: true] 220111 ifFalse: 220112 [self removeProperty: #resistsRemoval]! ! 220113 220114!Morph methodsFor: 'accessing' stamp: 'nk 9/4/2004 10:49'! 220115scaleFactor 220116 ^self valueOfProperty: #scaleFactor ifAbsent: [ 1.0 ] 220117! ! 220118 220119!Morph methodsFor: 'accessing' stamp: 'sw 11/26/2001 16:16'! 220120setBorderStyle: aSymbol 220121 "Set the border style of my costume" 220122 220123 | aStyle | 220124 aStyle := self borderStyleForSymbol: aSymbol. 220125 aStyle ifNil: [^ self]. 220126 (self canDrawBorder: aStyle) 220127 ifTrue: 220128 [self borderStyle: aStyle]! ! 220129 220130!Morph methodsFor: 'accessing' stamp: 'tk 12/4/1998 13:06'! 220131sqkPage 220132 ^ self valueOfProperty: #SqueakPage! ! 220133 220134!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 08:33'! 220135sticky: aBoolean 220136 "change the receiver's sticky property" 220137 extension sticky: aBoolean! ! 220138 220139!Morph methodsFor: 'accessing' stamp: 'RAA 2/19/2001 17:38'! 220140toggleLocked 220141 220142 self lock: self isLocked not! ! 220143 220144!Morph methodsFor: 'accessing' stamp: 'sw 11/15/2001 12:21'! 220145toggleResistsRemoval 220146 "Toggle the resistsRemoval property" 220147 220148 self resistsRemoval 220149 ifTrue: 220150 [self removeProperty: #resistsRemoval] 220151 ifFalse: 220152 [self setProperty: #resistsRemoval toValue: true]! ! 220153 220154!Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 08:53'! 220155toggleStickiness 220156 "togle the receiver's Stickiness" 220157 extension ifNil: [^ self beSticky]. 220158 extension sticky: extension sticky not! ! 220159 220160!Morph methodsFor: 'accessing' stamp: 'sw 11/30/1998 12:44'! 220161unHighlight 220162 self color: self regularColor! ! 220163 220164!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 12:33'! 220165unlock 220166 self lock: false! ! 220167 220168!Morph methodsFor: 'accessing' stamp: 'sw 8/15/97 23:59'! 220169unlockContents 220170 self submorphsDo: 220171 [:m | m unlock]! ! 220172 220173!Morph methodsFor: 'accessing' stamp: 'tk 2/17/1999 11:45'! 220174url 220175 "If I have been assigned a url, return it. For PasteUpMorphs mostly." 220176 | sq | 220177 (sq := self sqkPage) ifNotNil: [^ sq url]. 220178 ^ self valueOfProperty: #url 220179 ! ! 220180 220181!Morph methodsFor: 'accessing' stamp: 'tk 12/16/1998 11:54'! 220182userString 220183 "Do I have a text string to be searched on?" 220184 220185 ^ nil! ! 220186 220187!Morph methodsFor: 'accessing' stamp: 'dgd 9/1/2004 16:14'! 220188visibleClearArea 220189 "Answer the receiver visible clear area. The intersection 220190 between the clear area and the viewbox." 220191 ^ self viewBox intersect: self clearArea! ! 220192 220193!Morph methodsFor: 'accessing' stamp: 'ar 6/23/2001 16:06'! 220194wantsToBeCachedByHand 220195 "Return true if the receiver wants to be cached by the hand when it is dragged around. 220196 Note: The default implementation queries all submorphs since subclasses may have shapes that do not fill the receiver's bounds completely." 220197 self hasTranslucentColor ifTrue:[^false]. 220198 self submorphsDo:[:m| 220199 m wantsToBeCachedByHand ifFalse:[^false]. 220200 ]. 220201 ^true! ! 220202 220203!Morph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 16:21'! 220204wantsToBeTopmost 220205 "Answer if the receiver want to be one of the topmost objects in its owner" 220206 ^ self isFlapOrTab! ! 220207 220208 220209!Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:46'! 220210assureExtension 220211 "creates an extension for the receiver if needed" 220212 extension ifNil: [self initializeExtension]. 220213 ^ extension! ! 220214 220215!Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:22'! 220216extension 220217 "answer the recevier's extension" 220218 ^ extension! ! 220219 220220!Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:31'! 220221hasExtension 220222 "answer whether the receiver has extention" 220223 ^ extension notNil! ! 220224 220225!Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:35'! 220226initializeExtension 220227 "private - initializes the receiver's extension" 220228 extension := MorphExtension new! ! 220229 220230!Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:46'! 220231privateExtension: aMorphExtension 220232 "private - change the receiver's extension" 220233 extension := aMorphExtension! ! 220234 220235!Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:47'! 220236resetExtension 220237 "reset the extension slot if it is not needed" 220238 (extension notNil and: [extension isDefault]) ifTrue: [extension := nil] ! ! 220239 220240 220241!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 09:47'! 220242hasProperty: aSymbol 220243 "Answer whether the receiver has the property named aSymbol" 220244 extension ifNil: [^ false]. 220245 ^extension hasProperty: aSymbol! ! 220246 220247!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 09:47'! 220248otherProperties 220249 "answer the receiver's otherProperties" 220250 ^ extension ifNotNil: [extension otherProperties]! ! 220251 220252!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 09:48'! 220253removeProperty: aSymbol 220254 "removes the property named aSymbol if it exists" 220255 extension ifNil: [^ self]. 220256 extension removeProperty: aSymbol! ! 220257 220258!Morph methodsFor: 'accessing - properties' stamp: 'tk 10/9/2002 08:30'! 220259setProperties: aList 220260 "Set many properties at once from a list of prop, value, prop, value" 220261 220262 1 to: aList size by: 2 do: [:ii | 220263 self setProperty: (aList at: ii) toValue: (aList at: ii+1)].! ! 220264 220265!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 09:48'! 220266setProperty: aSymbol toValue: anObject 220267 "change the receiver's property named aSymbol to anObject" 220268 anObject ifNil: [^ self removeProperty: aSymbol]. 220269 self assureExtension setProperty: aSymbol toValue: anObject! ! 220270 220271!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 08:53'! 220272valueOfProperty: aSymbol 220273 "answer the value of the receiver's property named aSymbol" 220274 ^ extension ifNotNil: [extension valueOfProperty: aSymbol]! ! 220275 220276!Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 20:55'! 220277valueOfProperty: aSymbol ifAbsentPut: aBlock 220278 "If the receiver possesses a property of the given name, answer 220279 its value. If not, then create a property of the given name, give 220280 it the value obtained by evaluating aBlock, then answer that 220281 value" 220282 ^ self assureExtension valueOfProperty: aSymbol ifAbsentPut: aBlock! ! 220283 220284!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 08:50'! 220285valueOfProperty: aSymbol ifAbsent: aBlock 220286 "if the receiver possesses a property of the given name, answer 220287 its value. If not then evaluate aBlock and answer the result of 220288 this block evaluation" 220289 ^ extension 220290 ifNotNil: [extension valueOfProperty: aSymbol ifAbsent: aBlock] 220291 ifNil: [aBlock value]! ! 220292 220293!Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 08:49'! 220294valueOfProperty: aSymbol ifPresentDo: aBlock 220295 "If the receiver has a property of the given name, evaluate 220296 aBlock on behalf of the value of that property" 220297 extension ifNil: [^ self]. 220298 ^ aBlock value: (extension valueOfProperty: aSymbol ifAbsent: [^ self])! ! 220299 220300 220301!Morph methodsFor: 'accessing-backstop' stamp: 'wiz 2/14/2006 19:02'! 220302target: aMorph 220303"Morphs with targets will override. This backstop does nothing." 220304"This is here because targeting meta-actions are taken at morph level. 220305Do not remove."! ! 220306 220307 220308!Morph methodsFor: 'button' stamp: 'sw 2/6/2001 23:09'! 220309doButtonAction 220310 "If the receiver has a button-action defined, do it now. The default button action of any morph is, well, to do nothing. Note that there are several ways -- too many ways -- for morphs to have button-like actions. This one refers not to the #mouseUpCodeToRun feature, nor does it refer to the Player-scripting mechanism. Instead it is intended for morph classes whose very nature is to be buttons -- this method provides glue so that arbitrary buttons on the UI can be 'fired' programatticaly from user scripts"! ! 220311 220312!Morph methodsFor: 'button' stamp: 'stephane.ducasse 10/16/2008 19:22'! 220313fire 220314 "If the receiver has any kind of button-action defined, fire that action now. Any morph can have special, personal mouseUpCodeToRun, and that will be triggered by this. Additionally, some morphs have specific buttonness, and these get sent the #doButtonAction message to carry out their firing. Finally, some morphs have mouse behaviors associated with one or more Player scripts. 220315 For the present, we'll try out doing *all* the firings this object can do. " 220316 220317 self firedMouseUpCode. "This will run the mouseUpCodeToRun, if any" 220318 self doButtonAction "Do my native button action, if any"! ! 220319 220320!Morph methodsFor: 'button' stamp: 'marcus.denker 8/24/2008 21:42'! 220321firedMouseUpCode 220322 "If the user has special mouseUpCodeToRun, then fire it once right now and return true, else return false" 220323 220324 | evt | 220325 (self world isNil or: [self mouseUpCodeOrNil isNil]) ifTrue: [^false]. 220326 evt := MouseEvent basicNew 220327 setType: nil 220328 position: self center 220329 buttons: 0 220330 hand: self world activeHand. 220331 self programmedMouseUp: evt for: self. 220332 ^true! ! 220333 220334 220335!Morph methodsFor: 'caching' stamp: 'jm 11/13/97 16:35'! 220336fullLoadCachedState 220337 "Load the cached state of the receiver and its full submorph tree." 220338 220339 self allMorphsDo: [:m | m loadCachedState]. 220340! ! 220341 220342!Morph methodsFor: 'caching' stamp: 'jm 11/13/97 16:34'! 220343fullReleaseCachedState 220344 "Release the cached state of the receiver and its full submorph tree." 220345 220346 self allMorphsDo: [:m | m releaseCachedState]. 220347! ! 220348 220349!Morph methodsFor: 'caching' stamp: 'jm 11/13/97 16:37'! 220350loadCachedState 220351 "Load the cached state of this morph. This method may be called to pre-load the cached state of a morph to avoid delays when it is first used. (Cached state can always be recompued on demand, so a morph should not rely on this method being called.) Implementations of this method should do 'super loadCachedState'. This default implementation does nothing." 220352! ! 220353 220354!Morph methodsFor: 'caching' stamp: 'md 4/3/2006 12:02'! 220355releaseCachedState 220356 "Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'." 220357 self borderStyle releaseCachedState. 220358! ! 220359 220360 220361!Morph methodsFor: 'card in a stack' stamp: 'sw 10/27/2000 17:41'! 220362holdsSeparateDataForEachInstance 220363 "Answer whether the receiver is currently behaving as a 'background field', i.e., whether it is marked as shared (viz. occurring on the background of a stack) *and* is marked as holding separate data for each instance" 220364 220365 ^ self isShared and: [self hasProperty: #holdsSeparateDataForEachInstance]! ! 220366 220367!Morph methodsFor: 'card in a stack' stamp: 'stephane.ducasse 11/15/2008 14:34'! 220368tabHitWithEvent: anEvent 220369 "The tab key was hit. The keyboard focus has referred this event to me, though this perhaps seems rather backwards. Anyway, the assumption is that I have the property #tabAmongFields, so now the task is to tab to the next field." 220370 220371 | currentFocus fieldList anIndex itemToHighlight | 220372 currentFocus := anEvent hand keyboardFocus. 220373 fieldList := self allMorphs select: 220374 [:aMorph | (aMorph wouldAcceptKeyboardFocusUponTab) and: [aMorph isLocked not]]. 220375 220376 fieldList isEmpty ifTrue:[^ self]. 220377 220378 anIndex := fieldList indexOf: currentFocus ifAbsent: [nil]. 220379 itemToHighlight := fieldList atWrap: 220380 (anIndex ifNotNil: [anEvent shiftPressed ifTrue: [anIndex - 1] ifFalse: [anIndex + 1]] 220381 ifNil: [1]). 220382 anEvent hand newKeyboardFocus: itemToHighlight. self flag: #arNote. "really???" 220383 itemToHighlight editor selectAll. 220384 itemToHighlight invalidRect: itemToHighlight bounds ! ! 220385 220386 220387!Morph methodsFor: 'change reporting' stamp: 'ar 8/12/2003 21:50'! 220388addedMorph: aMorph 220389 "Notify the receiver that the given morph was just added." 220390! ! 220391 220392!Morph methodsFor: 'change reporting' stamp: 'sw 9/10/1998 08:18'! 220393colorChangedForSubmorph: aSubmorph 220394 "The color associated with aSubmorph was changed through the UI; react if needed"! ! 220395 220396!Morph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:50'! 220397invalidRect: damageRect 220398 ^self invalidRect: damageRect from: self! ! 220399 220400!Morph methodsFor: 'change reporting' stamp: 'md 4/3/2006 11:52'! 220401invalidRect: aRectangle from: aMorph 220402 | damageRect | 220403 aRectangle hasPositiveExtent ifFalse: [ ^self ]. 220404 damageRect := aRectangle. 220405 aMorph == self ifFalse:[ 220406 "Clip to receiver's clipping bounds if the damage came from a child" 220407 self clipSubmorphs 220408 ifTrue:[damageRect := aRectangle intersect: self clippingBounds]]. 220409 owner ifNotNil: [owner invalidRect: damageRect from: self].! ! 220410 220411!Morph methodsFor: 'change reporting' stamp: 'sw 7/8/1998 13:21'! 220412ownerChanged 220413 "The receiver's owner, some kind of a pasteup, has changed its layout." 220414 220415 self snapToEdgeIfAppropriate! ! 220416 220417!Morph methodsFor: 'change reporting' stamp: 'ar 8/12/2003 22:26'! 220418privateInvalidateMorph: aMorph 220419 "Private. Invalidate the given morph after adding or removing. 220420 This method is private because a) we're invalidating the morph 'remotely' 220421 and b) it forces a fullBounds computation which should not be necessary 220422 for a general morph c) the morph may or may not actually invalidate 220423 anything (if it's not in the world nothing will happen) and d) the entire 220424 mechanism should be rewritten." 220425 aMorph fullBounds. 220426 aMorph changed! ! 220427 220428!Morph methodsFor: 'change reporting' stamp: 'tk 8/24/2001 22:07'! 220429userSelectedColor: aColor 220430 "The user, via the UI, chose aColor to be the color for the receiver; set it, and tell my owner in case he wishes to react" 220431 self color: aColor. 220432 self world ifNotNil: [owner colorChangedForSubmorph: self]! ! 220433 220434 220435!Morph methodsFor: 'classification' stamp: 'di 5/7/1998 01:21'! 220436isAlignmentMorph 220437 220438 ^ false! ! 220439 220440!Morph methodsFor: 'classification' stamp: 'ar 9/15/2000 17:56'! 220441isBalloonHelp 220442 ^false! ! 220443 220444!Morph methodsFor: 'classification' stamp: 'ar 9/28/2000 13:54'! 220445isFlapOrTab 220446 ^self isFlap or:[self isFlapTab]! ! 220447 220448!Morph methodsFor: 'classification' stamp: 'ar 9/28/2000 13:53'! 220449isFlapTab 220450 ^false! ! 220451 220452!Morph methodsFor: 'classification' stamp: 'jm 4/17/1998 00:44'! 220453isFlexMorph 220454 220455 ^ false 220456! ! 220457 220458!Morph methodsFor: 'classification'! 220459isHandMorph 220460 220461 ^ false! ! 220462 220463!Morph methodsFor: 'classification' stamp: 'sw 1/29/98 21:51'! 220464isPlayfieldLike 220465 ^ false! ! 220466 220467!Morph methodsFor: 'classification' stamp: 'jm 5/7/1998 13:45'! 220468isRenderer 220469 "A *renderer* morph transforms the appearance of its submorph in some manner. For example, it might supply a drop shadow or scale and rotate the morph it encases. Answer true if this morph acts as a renderer. This default implementation returns false." 220470 "Details: A renderer is assumed to have a single submorph. Renderers may be nested to concatenate their transformations. It is useful to be able to find the outer-most renderer. This can be done by ascending the owner chain from the rendered morph. To find the morph being rendered, one can descend through the (singleton) submorph lists of the renderer chain until a non-renderer is encountered." 220471 220472 ^ false 220473! ! 220474 220475!Morph methodsFor: 'classification' stamp: 'ar 12/16/2001 18:28'! 220476isTextMorph 220477 ^false! ! 220478 220479!Morph methodsFor: 'classification'! 220480isWorldMorph 220481 220482 ^ false! ! 220483 220484!Morph methodsFor: 'classification'! 220485isWorldOrHandMorph 220486 220487 ^ self isWorldMorph or: [self isHandMorph]! ! 220488 220489 220490!Morph methodsFor: 'converting'! 220491asDraggableMorph 220492 ^self! ! 220493 220494!Morph methodsFor: 'converting' stamp: 'wiz 2/19/2006 19:01'! 220495asSnapshotThumbnail 220496 ^(ThumbnailImageMorph new newImage: self imageForm ) extent: 90 asPoint .! ! 220497 220498 220499!Morph methodsFor: 'copying' stamp: 'tk 2/19/2001 18:21'! 220500copy 220501 220502 ^ self veryDeepCopy! ! 220503 220504!Morph methodsFor: 'copying' stamp: 'tk 2/14/2001 12:47'! 220505deepCopy 220506 220507 self error: 'Please use veryDeepCopy'. 220508! ! 220509 220510!Morph methodsFor: 'copying' stamp: 'stephane.ducasse 11/8/2008 21:46'! 220511duplicate 220512 "Make and return a duplicate of the receiver" 220513 220514 | newMorph aName w topRend | 220515 ((topRend := self topRendererOrSelf) ~~ self) ifTrue: [^ topRend duplicate]. 220516 220517 self okayToDuplicate ifFalse: [^ self]. 220518 aName := (w := self world) ifNotNil: 220519 [w nameForCopyIfAlreadyNamed: self]. 220520 newMorph := self veryDeepCopy. 220521 aName ifNotNil: [newMorph setNameTo: aName]. 220522 220523 newMorph arrangeToStartStepping. 220524 newMorph privateOwner: nil. "no longer in world" 220525 newMorph isPartsDonor: false. "no longer parts donor" 220526 ^ newMorph! ! 220527 220528!Morph methodsFor: 'copying' stamp: 'nk 3/12/2001 17:07'! 220529duplicateMorphCollection: aCollection 220530 "Make and return a duplicate of the receiver" 220531 220532 | newCollection names | 220533 220534 names := aCollection collect: [ :ea | | newMorph w | 220535 (w := ea world) ifNotNil: 220536 [w nameForCopyIfAlreadyNamed: ea]. 220537 ]. 220538 220539 newCollection := aCollection veryDeepCopy. 220540 220541 newCollection with: names do: [ :newMorph :name | 220542 name ifNotNil: [ newMorph setNameTo: name ]. 220543 newMorph arrangeToStartStepping. 220544 newMorph privateOwner: nil. "no longer in world" 220545 newMorph isPartsDonor: false. "no longer parts donor" 220546 ]. 220547 220548 ^newCollection! ! 220549 220550!Morph methodsFor: 'copying' stamp: 'sw 2/16/2001 16:30'! 220551fullCopy 220552 "Deprecated, but maintained for backward compatibility with existing code (no senders in the base 3.0 image). Calls are revectored to #veryDeepCopy, but note that #veryDeepCopy does not do exactly the same thing that the original #fullCopy did, so beware!!" 220553 220554 ^ self veryDeepCopy! ! 220555 220556!Morph methodsFor: 'copying' stamp: 'tk 1/6/1999 17:27'! 220557veryDeepCopyWith: deepCopier 220558 "Copy me and the entire tree of objects I point to. An object in the tree twice is copied once, and both references point to him. deepCopier holds a dictionary of objects we have seen. See veryDeepInner:, veryDeepFixupWith:" 220559 220560 self prepareToBeSaved. 220561 ^ super veryDeepCopyWith: deepCopier! ! 220562 220563!Morph methodsFor: 'copying' stamp: 'tk 2/3/2001 14:29'! 220564veryDeepFixupWith: deepCopier 220565 "If some fields were weakly copied, fix new copy here." 220566 220567 "super veryDeepFixupWith: deepCopier. Object has no fixups, so don't call it" 220568 220569 "If my owner is being duplicated too, then store his duplicate. 220570 If I am owned outside the duplicated tree, then I am no longer owned!!" 220571 owner := deepCopier references at: owner ifAbsent: [nil]. 220572 220573! ! 220574 220575!Morph methodsFor: 'copying' stamp: 'md 2/27/2006 08:47'! 220576veryDeepInner: deepCopier 220577 "The inner loop, so it can be overridden when a field should not 220578 be traced." 220579 "super veryDeepInner: deepCopier. know Object has no inst vars" 220580 bounds := bounds clone. 220581 "Points are shared with original" 220582 "owner := owner. special, see veryDeepFixupWith:" 220583 submorphs := submorphs veryDeepCopyWith: deepCopier. 220584 "each submorph's fixup will install me as the owner" 220585 "fullBounds := fullBounds. fullBounds is shared with original!!" 220586 color := color veryDeepCopyWith: deepCopier. 220587 "color, if simple, will return self. may be complex" 220588 extension := (extension veryDeepCopyWith: deepCopier)! ! 220589 220590 220591!Morph methodsFor: 'creation' stamp: 'tk 2/6/1999 22:43'! 220592asMorph 220593 ^ self! ! 220594 220595 220596!Morph methodsFor: 'debug and other' stamp: 'dgd 8/30/2003 20:36'! 220597addDebuggingItemsTo: aMenu hand: aHandMorph 220598 aMenu add: 'debug...' translated subMenu: (self buildDebugMenu: aHandMorph)! ! 220599 220600!Morph methodsFor: 'debug and other' stamp: 'RAA 1/19/2001 07:51'! 220601addMouseActionIndicatorsWidth: anInteger color: aColor 220602 220603 self deleteAnyMouseActionIndicators. 220604 220605 self changed. 220606 self hasRolloverBorder: true. 220607 self setProperty: #rolloverWidth toValue: anInteger@anInteger. 220608 self setProperty: #rolloverColor toValue: aColor. 220609 self layoutChanged. 220610 self changed. 220611 220612! ! 220613 220614!Morph methodsFor: 'debug and other' stamp: 'alain.plantec 2/6/2009 15:31'! 220615addMouseUpAction 220616 | codeToRun oldCode | 220617 oldCode := self 220618 valueOfProperty: #mouseUpCodeToRun 220619 ifAbsent: ['']. 220620 codeToRun := UIManager default request: 'MouseUp expression:' translated initialAnswer: oldCode. 220621 self addMouseUpActionWith: codeToRun! ! 220622 220623!Morph methodsFor: 'debug and other' stamp: 'gm 2/22/2003 13:41'! 220624addMouseUpActionWith: codeToRun 220625 ((codeToRun isMessageSend) not and: [codeToRun isEmptyOrNil]) 220626 ifTrue: [^self]. 220627 self setProperty: #mouseUpCodeToRun toValue: codeToRun. 220628 self 220629 on: #mouseUp 220630 send: #programmedMouseUp:for: 220631 to: self. 220632 self 220633 on: #mouseDown 220634 send: #programmedMouseDown:for: 220635 to: self. 220636 self 220637 on: #mouseEnter 220638 send: #programmedMouseEnter:for: 220639 to: self. 220640 self 220641 on: #mouseLeave 220642 send: #programmedMouseLeave:for: 220643 to: self! ! 220644 220645!Morph methodsFor: 'debug and other' stamp: 'sw 1/3/2001 06:42'! 220646addViewingItemsTo: aMenu 220647 "Add viewing-related items to the given menu. If any are added, this method is also responsible for adding a line after them"! ! 220648 220649!Morph methodsFor: 'debug and other' stamp: 'dgd 2/22/2003 14:27'! 220650allStringsAfter: aSubmorph 220651 "return an OrderedCollection of strings of text in my submorphs. If aSubmorph is non-nil, begin with that container." 220652 220653 | list string ok | 220654 list := OrderedCollection new. 220655 ok := aSubmorph isNil. 220656 self allMorphsDo: 220657 [:sub | 220658 ok ifFalse: [ok := sub == aSubmorph]. "and do this one too" 220659 ok 220660 ifTrue: 220661 [(string := sub userString) ifNotNil: 220662 [string isString ifTrue: [list add: string] ifFalse: [list addAll: string]]]]. 220663 ^list! ! 220664 220665!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:28'! 220666altSpecialCursor1 220667 "a star and an arrow" 220668 ^(Form 220669 extent: 31@26 220670 depth: 8 220671 fromArray: #( 14417920 0 0 0 0 0 0 0 3705461980 3705461980 3705405440 0 0 0 0 0 3705461980 3705461980 3705461760 0 0 0 0 0 14474460 3705461980 3705405440 0 0 0 0 0 56540 3705461980 3690987520 0 0 3690987520 0 0 220 3705461980 3705461760 0 0 3690987520 0 0 220 3705405440 3705461980 0 0 3705405440 0 0 0 3705461760 56540 3690987520 220 3705405440 0 0 0 3705405440 220 3705461760 220 3705405440 0 0 0 0 0 14474460 220 3705461760 0 0 0 0 0 56540 3691044060 3705461760 0 0 0 0 0 220 3705461980 3705461760 0 0 0 0 56540 3705461980 3705461980 3705461980 3705461980 3705461760 0 0 220 3705461980 3705461980 3705461980 3705461980 3705461760 0 0 0 3705461980 3705461980 3705461980 3705461980 3705405440 0 0 0 14474460 3705461980 3705461980 3705461980 3690987520 0 0 0 56540 3705461980 3705461980 3705461760 0 0 0 0 220 3705461980 3705461980 3705405440 0 0 0 0 0 3705461980 3705461980 3690987520 0 0 0 0 0 3705461980 3705461980 3705405440 0 0 0 0 220 3705461980 3705461980 3705405440 0 0 0 0 220 3705461980 3705461980 3705405440 0 0 0 0 220 3705461980 14474460 3705405440 0 0 0 0 220 3705405440 220 3705461760 0 0 0 0 56540 3690987520 0 3705461760 0 0 0 0 56540 0 0 14474240 0) 220672 offset: 0@0)! ! 220673 220674!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:41'! 220675altSpecialCursor3: aColor 220676 | f box | 220677 "a bulls-eye pattern in this color" 220678 f := Form extent: 32@32 depth: 32. 220679 f offset: (f extent // 2) negated. 220680 box := f boundingBox. 220681 [ box width > 0] whileTrue: [ 220682 f fill: box rule: Form over fillColor: aColor. 220683 f fill: (box insetBy: 2) rule: Form over fillColor: Color transparent. 220684 box := box insetBy: 4. 220685 ]. 220686 ^f 220687! ! 220688 220689!Morph methodsFor: 'debug and other' stamp: 'marcus.denker 11/27/2008 23:45'! 220690buildDebugMenu: aHand 220691 "Answer a debugging menu for the receiver. 220692 The hand argument is seemingly historical and plays no role presently" 220693 220694 | aMenu | 220695 aMenu := MenuMorph new defaultTarget: self. 220696 aMenu addStayUpItem. 220697 (self hasProperty: #errorOnDraw) ifTrue: 220698 [aMenu add: 'start drawing again' translated action: #resumeAfterDrawError. 220699 aMenu addLine]. 220700 (self hasProperty: #errorOnStep) ifTrue: 220701 [aMenu add: 'start stepping again' translated action: #resumeAfterStepError. 220702 aMenu addLine]. 220703 220704 aMenu add: 'inspect morph' translated action: #inspectInMorphic:. 220705 aMenu add: 'inspect owner chain' translated action: #inspectOwnerChain. 220706 self isMorphicModel ifTrue: 220707 [aMenu add: 'inspect model' translated target: self model action: #inspect]. 220708 aMenu add: 'explore morph' translated target: self selector: #explore. 220709 aMenu addLine. 220710 aMenu add: 'browse morph class' translated target: self selector: #browseHierarchy. 220711 (self isMorphicModel) 220712 ifTrue: [aMenu 220713 add: 'browse model class' 220714 target: self model 220715 selector: #browseHierarchy]. 220716 aMenu addLine. 220717 220718 self addViewingItemsTo: aMenu. 220719 aMenu 220720 add: 'make own subclass' translated action: #subclassMorph; 220721 addLine; 220722 add: 'call #tempCommand' translated action: #tempCommand; 220723 add: 'define #tempCommand' translated action: #defineTempCommand; 220724 addLine. 220725 ^ aMenu! ! 220726 220727!Morph methodsFor: 'debug and other' stamp: 'ar 9/27/2005 20:29'! 220728defineTempCommand 220729 "To use this, comment out what's below here, and substitute your own code. 220730You will then be able to invoke it from the standard debugging menus. If invoked from the world menu, you'll always get it invoked on behalf of the world, but if invoked from an individual morph's meta-menu, it will be invoked on behalf of that individual morph. 220731 220732Note that you can indeed reimplement tempCommand in an individual morph's class if you wish" 220733 220734 ToolSet browse: Morph 220735 selector: #tempCommand! ! 220736 220737!Morph methodsFor: 'debug and other' stamp: 'RAA 1/19/2001 07:51'! 220738deleteAnyMouseActionIndicators 220739 220740 self changed. 220741 (self valueOfProperty: #mouseActionIndicatorMorphs ifAbsent: [#()]) do: [ :each | 220742 each deleteWithSiblings "one is probably enough, but be safe" 220743 ]. 220744 self removeProperty: #mouseActionIndicatorMorphs. 220745 self hasRolloverBorder: false. 220746 self removeProperty: #rolloverWidth. 220747 self removeProperty: #rolloverColor. 220748 self layoutChanged. 220749 self changed. 220750 220751! ! 220752 220753!Morph methodsFor: 'debug and other' stamp: 'sw 11/5/1998 20:31'! 220754inspectOwnerChain 220755 self ownerChain inspectWithLabel: 'Owner chain for ', self printString! ! 220756 220757!Morph methodsFor: 'debug and other' stamp: 'sw 2/6/2001 22:35'! 220758mouseUpCodeOrNil 220759 "If the receiver has a mouseUpCodeToRun, return it, else return nil" 220760 220761 ^ self valueOfProperty: #mouseUpCodeToRun ifAbsent: [nil]! ! 220762 220763!Morph methodsFor: 'debug and other' stamp: 'dgd 2/22/2003 19:05'! 220764ownerChain 220765 "Answer a list of objects representing the receiver and all of its owners. The first element is the receiver, and the last one is typically the world in which the receiver resides" 220766 220767 | c next | 220768 c := OrderedCollection with: self. 220769 next := self. 220770 [(next := next owner) notNil] whileTrue: [c add: next]. 220771 ^c asArray! ! 220772 220773!Morph methodsFor: 'debug and other' stamp: 'RAA 7/12/2000 11:16'! 220774programmedMouseDown: anEvent for: aMorph 220775 220776 aMorph addMouseActionIndicatorsWidth: 15 color: (Color blue alpha: 0.7). 220777 220778! ! 220779 220780!Morph methodsFor: 'debug and other' stamp: 'RAA 7/12/2000 11:16'! 220781programmedMouseEnter: anEvent for: aMorph 220782 220783 aMorph addMouseActionIndicatorsWidth: 10 color: (Color blue alpha: 0.3). 220784 220785! ! 220786 220787!Morph methodsFor: 'debug and other' stamp: 'RAA 7/12/2000 11:10'! 220788programmedMouseLeave: anEvent for: aMorph 220789 220790 self deleteAnyMouseActionIndicators. 220791! ! 220792 220793!Morph methodsFor: 'debug and other' stamp: 'gm 2/22/2003 13:41'! 220794programmedMouseUp: anEvent for: aMorph 220795 | aCodeString | 220796 self deleteAnyMouseActionIndicators. 220797 aCodeString := self valueOfProperty: #mouseUpCodeToRun ifAbsent: [^self]. 220798 (self fullBounds containsPoint: anEvent cursorPoint) ifFalse: [^self]. 220799 220800 [(aCodeString isMessageSend) 220801 ifTrue: [aCodeString value] 220802 ifFalse: 220803 [Compiler 220804 evaluate: aCodeString 220805 for: self 220806 notifying: nil 220807 logged: false]] 220808 on: ProgressTargetRequestNotification 220809 do: [:ex | ex resume: self] "in case a save/load progress display needs a home"! ! 220810 220811!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:43'! 220812removeMouseUpAction 220813 220814 self primaryHand showTemporaryCursor: nil. 220815 self removeProperty: #mouseUpCodeToRun. 220816 #(mouseUp mouseEnter mouseLeave mouseDown) do: [ :sym | 220817 self 220818 on: sym 220819 send: #yourself 220820 to: nil. 220821 ] 220822 220823! ! 220824 220825!Morph methodsFor: 'debug and other' stamp: 'RAA 5/24/2000 18:20'! 220826resumeAfterDrawError 220827 220828 self changed. 220829 self removeProperty:#errorOnDraw. 220830 self changed.! ! 220831 220832!Morph methodsFor: 'debug and other' stamp: 'RAA 5/24/2000 18:20'! 220833resumeAfterStepError 220834 "Resume stepping after an error has occured." 220835 220836 self startStepping. "Will #step" 220837 self removeProperty:#errorOnStep. "Will remove prop only if #step was okay" 220838! ! 220839 220840!Morph methodsFor: 'debug and other' stamp: 'dgd 8/30/2003 20:43'! 220841tempCommand 220842 "Generic backstop. If you care to, you can comment out what's below here, and substitute your own code, though the intention of design of the feature is that you leave this method as it is, and instead reimplement tempCommand in the class of whatever individual morph you care to. In any case, once you have your own #tempCommand in place, you will then be able to invoke it from the standard debugging menus." 220843 220844 self inform: 'Before calling tempCommand, you 220845should first give it a definition. To 220846do this, choose "define tempCommand" 220847from the debug menu.' translated! ! 220848 220849 220850!Morph methodsFor: 'dispatching' stamp: 'nk 2/15/2004 09:16'! 220851disableSubmorphFocusForHand: aHandMorph 220852 "Check whether this morph or any of its submorph has the Genie focus. 220853 If yes, disable it." 220854! ! 220855 220856 220857!Morph methodsFor: 'drawing' stamp: 'Henrik Sperre Johansen 3/15/2009 00:03'! 220858areasRemainingToFill: aRectangle 220859 "Pushed up from BorderedMorph, all cases tested for there are 220860 supported by basic Morph." 220861 "Morphs which achieve translucency by other means than fillStyle will have 220862 to reimplement this" 220863 "Fixed here to test the fillStyle rather than color for translucency. 220864 Since can have a translucent fillStyle while the (calculated) color is not." 220865 self fillStyle isTranslucent 220866 ifTrue: [^ Array with: aRectangle]. 220867 self wantsRoundedCorners 220868 ifTrue: [(self borderWidth > 0 220869 and: [self borderColor isColor 220870 and: [self borderColor isTranslucent]]) 220871 ifTrue: [^ aRectangle 220872 areasOutside: (self innerBounds intersect: self boundsWithinCorners)] 220873 ifFalse: [^ aRectangle areasOutside: self boundsWithinCorners]] 220874 ifFalse: [(self borderWidth > 0 220875 and: [self borderColor isColor 220876 and: [self borderColor isTranslucent]]) 220877 ifTrue: [^ aRectangle areasOutside: self innerBounds] 220878 ifFalse: [^ aRectangle areasOutside: self bounds]]! ! 220879 220880!Morph methodsFor: 'drawing' stamp: 'sw 6/4/2000 22:02'! 220881boundingBoxOfSubmorphs 220882 | aBox | 220883 aBox := bounds origin extent: self minimumExtent. "so won't end up with something empty" 220884 submorphs do: 220885 [:m | m visible ifTrue: [aBox := aBox quickMerge: m fullBounds]]. 220886 ^ aBox 220887! ! 220888 220889!Morph methodsFor: 'drawing' stamp: 'ar 11/4/2000 23:39'! 220890changeClipSubmorphs 220891 self clipSubmorphs: self clipSubmorphs not.! ! 220892 220893!Morph methodsFor: 'drawing' stamp: 'dgd 2/16/2003 20:02'! 220894clipLayoutCells 220895 "Drawing/layout specific. If this property is set, clip the 220896 submorphs of the receiver by its cell bounds." 220897 ^ self 220898 valueOfProperty: #clipLayoutCells 220899 ifAbsent: [false]! ! 220900 220901!Morph methodsFor: 'drawing' stamp: 'ar 10/29/2000 19:22'! 220902clipLayoutCells: aBool 220903 "Drawing/layout specific. If this property is set, clip the submorphs of the receiver by its cell bounds." 220904 aBool == false 220905 ifTrue:[self removeProperty: #clipLayoutCells] 220906 ifFalse:[self setProperty: #clipLayoutCells toValue: aBool]. 220907 self changed.! ! 220908 220909!Morph methodsFor: 'drawing' stamp: 'ar 10/29/2000 19:16'! 220910clippingBounds 220911 "Return the bounds to which any submorphs should be clipped if the property is set" 220912 ^self innerBounds! ! 220913 220914!Morph methodsFor: 'drawing' stamp: 'md 4/3/2006 11:53'! 220915clipSubmorphs 220916 "Drawing specific. If this property is set, clip the receiver's 220917 submorphs to the receiver's clipping bounds." 220918 220919 extension ifNil: [^false]. 220920 ^ self 220921 valueOfProperty: #clipSubmorphs 220922 ifAbsent: [false]! ! 220923 220924!Morph methodsFor: 'drawing' stamp: 'ar 11/12/2000 18:47'! 220925clipSubmorphs: aBool 220926 "Drawing specific. If this property is set, clip the receiver's submorphs to the receiver's clipping bounds." 220927 self invalidRect: self fullBounds. 220928 aBool == false 220929 ifTrue:[self removeProperty: #clipSubmorphs] 220930 ifFalse:[self setProperty: #clipSubmorphs toValue: aBool]. 220931 self invalidRect: self fullBounds.! ! 220932 220933!Morph methodsFor: 'drawing' stamp: 'tk 8/2/1998 14:33'! 220934doesOwnRotation 220935 "Some morphs don't want to TransformMorph to rotate their images, but we do" 220936 ^ false! ! 220937 220938!Morph methodsFor: 'drawing' stamp: 'panda 4/28/2000 11:59'! 220939drawDropHighlightOn: aCanvas 220940 self highlightedForDrop ifTrue: [ 220941 aCanvas frameRectangle: self fullBounds color: self dropHighlightColor].! ! 220942 220943!Morph methodsFor: 'drawing' stamp: 'ar 12/30/2001 19:17'! 220944drawDropShadowOn: aCanvas 220945 220946 aCanvas 220947 translateBy: self shadowOffset 220948 during: [ :shadowCanvas | 220949 shadowCanvas shadowColor: self shadowColor. 220950 shadowCanvas roundCornersOf: self during: [ 220951 (shadowCanvas isVisible: self bounds) ifTrue:[shadowCanvas drawMorph: self ]] 220952 ]. 220953! ! 220954 220955!Morph methodsFor: 'drawing' stamp: 'ar 4/2/1999 13:13'! 220956drawErrorOn: aCanvas 220957 "The morph (or one of its submorphs) had an error in its drawing method." 220958 aCanvas 220959 frameAndFillRectangle: bounds 220960 fillColor: Color red 220961 borderWidth: 1 220962 borderColor: Color yellow. 220963 aCanvas line: bounds topLeft to: bounds bottomRight width: 1 color: Color yellow. 220964 aCanvas line: bounds topRight to: bounds bottomLeft width: 1 color: Color yellow.! ! 220965 220966!Morph methodsFor: 'drawing' stamp: ' 9/3/2000 13:55'! 220967drawMouseDownHighlightOn: aCanvas 220968 self highlightedForMouseDown ifTrue: [ 220969 aCanvas frameRectangle: self fullBounds color: self color darker darker].! ! 220970 220971!Morph methodsFor: 'drawing' stamp: 'ar 8/25/2001 17:31'! 220972drawOn: aCanvas 220973 220974 aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle. 220975! ! 220976 220977!Morph methodsFor: 'drawing' stamp: 'wiz 3/21/2006 20:44'! 220978drawRolloverBorderOn: aCanvas 220979 | colorToUse offsetToUse myShadow newForm f | 220980 colorToUse := self 220981 valueOfProperty: #rolloverColor 220982 ifAbsent: [Color blue alpha: 0.5]. 220983 offsetToUse := self 220984 valueOfProperty: #rolloverWidth 220985 ifAbsent: [10 @ 10]. 220986 self hasRolloverBorder: false. 220987 myShadow := self shadowForm. 220988 self hasRolloverBorder: true. 220989 myShadow offset: 0 @ 0. 220990 f := ColorForm extent: myShadow extent depth: 1. 220991 myShadow displayOn: f. 220992 f colors: {Color transparent. colorToUse}. 220993 newForm := Form extent: offsetToUse * 2 + myShadow extent depth: 32. 220994 (WarpBlt current toForm: newForm) sourceForm: f; 220995 cellSize: 1; 220996 combinationRule: 3; 220997 copyQuad: f boundingBox innerCorners toRect: newForm boundingBox. 220998 aCanvas 220999 translateBy: offsetToUse negated 221000 during: [:shadowCanvas | 221001 shadowCanvas shadowColor: colorToUse. 221002 shadowCanvas paintImage: newForm at: self position]! ! 221003 221004!Morph methodsFor: 'drawing' stamp: 'Henrik Sperre Johansen 5/19/2009 21:48'! 221005drawSubmorphsOn: aCanvas 221006 "Display submorphs back to front" 221007 221008 | drawBlock | 221009 submorphs isEmpty ifTrue: [^self]. 221010 drawBlock := [:canvas | submorphs reverseDo: [:m | canvas fullDrawMorph: m]]. 221011 self clipSubmorphs 221012 ifTrue: [aCanvas clipBy: (aCanvas clipRect intersect: self clippingBounds) during: drawBlock] 221013 ifFalse: [drawBlock value: aCanvas]! ! 221014 221015!Morph methodsFor: 'drawing' stamp: 'ar 11/8/2000 19:29'! 221016expandFullBoundsForRolloverBorder: aRectangle 221017 | delta | 221018 delta := self valueOfProperty: #rolloverWidth ifAbsent: [10@10]. 221019 ^aRectangle expandBy: delta. 221020 221021! ! 221022 221023!Morph methodsFor: 'drawing' stamp: 'sw 11/26/2003 17:43'! 221024flashBounds 221025 "Flash the receiver's bounds -- does not use the receiver's color, thus works with StringMorphs and SketchMorphs, etc., for which #flash is useless. No senders initially, but useful to send this from a debugger or inspector" 221026 221027 5 timesRepeat: 221028 [Display flash: self boundsInWorld andWait: 120]! ! 221029 221030!Morph methodsFor: 'drawing' stamp: 'ar 12/30/2001 15:22'! 221031fullDrawOn: aCanvas 221032 "Draw the full Morphic structure on the given Canvas" 221033 221034 self visible ifFalse: [^ self]. 221035 (aCanvas isVisible: self fullBounds) ifFalse:[^self]. 221036 (self hasProperty: #errorOnDraw) ifTrue:[^self drawErrorOn: aCanvas]. 221037 "Note: At some point we should generalize this into some sort of 221038 multi-canvas so that we can cross-optimize some drawing operations." 221039 "Pass 1: Draw eventual drop-shadow" 221040 self hasDropShadow ifTrue: [self drawDropShadowOn: aCanvas]. 221041 (self hasRolloverBorder and: [(aCanvas seesNothingOutside: self bounds) not]) 221042 ifTrue: [self drawRolloverBorderOn: aCanvas]. 221043 221044 "Pass 2: Draw receiver itself" 221045 aCanvas roundCornersOf: self during:[ 221046 (aCanvas isVisible: self bounds) ifTrue:[aCanvas drawMorph: self]. 221047 self drawSubmorphsOn: aCanvas. 221048 self drawDropHighlightOn: aCanvas. 221049 self drawMouseDownHighlightOn: aCanvas].! ! 221050 221051!Morph methodsFor: 'drawing' stamp: 'dgd 8/30/2003 20:20'! 221052hasClipSubmorphsString 221053 "Answer a string that represents the clip-submophs checkbox" 221054 ^ (self clipSubmorphs 221055 ifTrue: ['<on>'] 221056 ifFalse: ['<off>']) 221057 , 'provide clipping' translated! ! 221058 221059!Morph methodsFor: 'drawing' stamp: 'sw 10/30/1998 18:27'! 221060hide 221061 owner ifNil: [^ self]. 221062 self visible ifTrue: [self visible: false. self changed]! ! 221063 221064!Morph methodsFor: 'drawing' stamp: 'LC 5/18/2000 08:48'! 221065highlightedForMouseDown 221066 ^(self valueOfProperty: #highlightedForMouseDown) == true! ! 221067 221068!Morph methodsFor: 'drawing' stamp: 'LC 5/18/2000 08:51'! 221069highlightForMouseDown 221070 self highlightForMouseDown: true! ! 221071 221072!Morph methodsFor: 'drawing' stamp: 'ar 3/17/2001 15:56'! 221073highlightForMouseDown: aBoolean 221074 aBoolean 221075 ifTrue:[self setProperty: #highlightedForMouseDown toValue: aBoolean] 221076 ifFalse:[self removeProperty: #highlightedForMouseDown. self resetExtension]. 221077 self changed! ! 221078 221079!Morph methodsFor: 'drawing' stamp: 'jm 6/11/97 17:21'! 221080imageForm 221081 221082 ^ self imageFormForRectangle: self fullBounds 221083! ! 221084 221085!Morph methodsFor: 'drawing' stamp: 'di 7/8/1998 12:42'! 221086imageFormDepth: depth 221087 221088 ^ self imageForm: depth forRectangle: self fullBounds 221089! ! 221090 221091!Morph methodsFor: 'drawing' stamp: 'di 9/9/1998 22:25'! 221092imageFormForRectangle: rect 221093 221094 ^ self imageForm: Display depth forRectangle: rect 221095! ! 221096 221097!Morph methodsFor: 'drawing' stamp: 'nk 9/1/2004 15:08'! 221098imageForm: depth backgroundColor: aColor forRectangle: rect 221099 | canvas | 221100 canvas := Display defaultCanvasClass extent: rect extent depth: depth. 221101 canvas translateBy: rect topLeft negated 221102 during:[:tempCanvas| 221103 tempCanvas fillRectangle: rect color: aColor. 221104 tempCanvas fullDrawMorph: self]. 221105 ^ canvas form offset: rect topLeft! ! 221106 221107!Morph methodsFor: 'drawing' stamp: 'ar 9/1/2000 14:23'! 221108imageForm: depth forRectangle: rect 221109 | canvas | 221110 canvas := Display defaultCanvasClass extent: rect extent depth: depth. 221111 canvas translateBy: rect topLeft negated 221112 during:[:tempCanvas| tempCanvas fullDrawMorph: self]. 221113 ^ canvas form offset: rect topLeft! ! 221114 221115!Morph methodsFor: 'drawing' stamp: 'sw 10/10/1999 23:25'! 221116refreshWorld 221117 | aWorld | 221118 (aWorld := self world) ifNotNil: [aWorld displayWorldSafely] 221119! ! 221120 221121!Morph methodsFor: 'drawing' stamp: 'JW 7/12/2005 20:12'! 221122shadowForm 221123 "Return a form representing the 'shadow' of the receiver - e.g., all pixels that are occupied by the receiver are one, all others are zero." 221124 | canvas | 221125 canvas := (Display defaultCanvasClass extent: self fullBounds extent depth: 1) 221126 asShadowDrawingCanvas: Color black. "Color black represents one for 1bpp" 221127 canvas translateBy: bounds topLeft negated 221128 during:[:tempCanvas| tempCanvas fullDrawMorph: self]. 221129 ^ canvas form offset: bounds topLeft 221130! ! 221131 221132!Morph methodsFor: 'drawing' stamp: 'sw 10/22/1998 20:29'! 221133show 221134 "Make sure this morph is on-stage." 221135 self visible ifFalse: [self visible: true. self changed]! ! 221136 221137!Morph methodsFor: 'drawing' stamp: 'md 2/27/2006 08:49'! 221138visible 221139 "answer whether the receiver is visible" 221140 extension ifNil: [^ true]. 221141 ^ extension visible! ! 221142 221143 221144!Morph methodsFor: 'drop shadows' stamp: 'RAA 1/19/2001 07:51'! 221145addDropShadow 221146 221147 self hasDropShadow ifTrue:[^self]. 221148 self changed. 221149 self hasDropShadow: true. 221150 self shadowOffset: 3@3. 221151 self layoutChanged. 221152 self changed.! ! 221153 221154!Morph methodsFor: 'drop shadows' stamp: 'dgd 8/30/2003 16:48'! 221155addDropShadowMenuItems: aMenu hand: aHand 221156 | menu | 221157 menu := MenuMorph new defaultTarget: self. 221158 menu 221159 addUpdating: #hasDropShadowString 221160 action: #toggleDropShadow. 221161 menu addLine. 221162 menu add: 'shadow color...' translated target: self selector: #changeShadowColor. 221163 menu add: 'shadow offset...' translated target: self selector: #setShadowOffset:. 221164 aMenu add: 'drop shadow' translated subMenu: menu.! ! 221165 221166!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 20:22'! 221167changeShadowColor 221168 "Change the shadow color of the receiver -- triggered, e.g. from a menu" 221169 221170 ColorPickerMorph new 221171 choseModalityFromPreference; 221172 sourceHand: self activeHand; 221173 target: self; 221174 selector: #shadowColor:; 221175 originalColor: self shadowColor; 221176 putUpFor: self near: self fullBoundsInWorld! ! 221177 221178!Morph methodsFor: 'drop shadows' stamp: 'dgd 2/16/2003 21:42'! 221179hasDropShadow 221180 "answer whether the receiver has DropShadow" 221181 ^ self 221182 valueOfProperty: #hasDropShadow 221183 ifAbsent: [false]! ! 221184 221185!Morph methodsFor: 'drop shadows' stamp: 'dgd 8/30/2003 16:49'! 221186hasDropShadowString 221187 ^ (self hasDropShadow 221188 ifTrue: ['<on>'] 221189 ifFalse: ['<off>']) 221190 , 'show shadow' translated! ! 221191 221192!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 19:03'! 221193hasDropShadow: aBool 221194 aBool 221195 ifTrue:[self setProperty: #hasDropShadow toValue: true] 221196 ifFalse:[self removeProperty: #hasDropShadow]! ! 221197 221198!Morph methodsFor: 'drop shadows' stamp: 'dgd 2/16/2003 21:58'! 221199hasRolloverBorder 221200 "answer whether the receiver has RolloverBorder" 221201 ^ self 221202 valueOfProperty: #hasRolloverBorder 221203 ifAbsent: [false]! ! 221204 221205!Morph methodsFor: 'drop shadows' stamp: 'RAA 11/7/2000 15:54'! 221206hasRolloverBorder: aBool 221207 aBool 221208 ifTrue:[self setProperty: #hasRolloverBorder toValue: true] 221209 ifFalse:[self removeProperty: #hasRolloverBorder]! ! 221210 221211!Morph methodsFor: 'drop shadows' stamp: 'ar 11/12/2000 18:57'! 221212removeDropShadow 221213 self hasDropShadow ifFalse:[^self]. 221214 self changed. 221215 self hasDropShadow: false. 221216 fullBounds ifNotNil:[fullBounds := self privateFullBounds]. 221217 self changed.! ! 221218 221219!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 18:58'! 221220setShadowOffset: evt 221221 | handle | 221222 handle := HandleMorph new forEachPointDo: 221223 [:newPoint | self shadowPoint: newPoint]. 221224 evt hand attachMorph: handle. 221225 handle startStepping. 221226! ! 221227 221228!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 18:59'! 221229shadowColor 221230 ^self valueOfProperty: #shadowColor ifAbsent:[Color black]! ! 221231 221232!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 20:22'! 221233shadowColor: aColor 221234 self shadowColor = aColor ifFalse:[self changed]. 221235 self setProperty: #shadowColor toValue: aColor.! ! 221236 221237!Morph methodsFor: 'drop shadows' stamp: 'marcus.denker 8/24/2008 22:50'! 221238shadowOffset 221239 "Return the current shadow offset" 221240 221241 extension ifNil: [^0@0]. 221242 ^self valueOfProperty: #shadowOffset ifAbsent:[0@0]! ! 221243 221244!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 19:00'! 221245shadowOffset: aPoint 221246 "Set the current shadow offset" 221247 (aPoint isNil or:[(aPoint x isZero) & (aPoint y isZero)]) 221248 ifTrue:[self removeProperty: #shadowOffset] 221249 ifFalse:[self setProperty: #shadowOffset toValue: aPoint].! ! 221250 221251!Morph methodsFor: 'drop shadows' stamp: 'ar 11/12/2000 18:58'! 221252shadowPoint: newPoint 221253 self changed. 221254 self shadowOffset: newPoint - self center // 5. 221255 fullBounds ifNotNil:[fullBounds := self privateFullBounds]. 221256 self changed.! ! 221257 221258!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 20:16'! 221259toggleDropShadow 221260 self hasDropShadow 221261 ifTrue:[self removeDropShadow] 221262 ifFalse:[self addDropShadow].! ! 221263 221264 221265!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 20:00'! 221266aboutToBeGrabbedBy: aHand 221267 "The receiver is being grabbed by a hand. 221268 Perform necessary adjustments (if any) and return the actual morph 221269 that should be added to the hand." 221270 | extentToHandToHand cmd | 221271 self formerOwner: owner. 221272 self formerPosition: self position. 221273 cmd := self undoGrabCommand. 221274 cmd ifNotNil:[self setProperty: #undoGrabCommand toValue: cmd]. 221275 (extentToHandToHand := self valueOfProperty: #expandedExtent) 221276 ifNotNil: 221277 [self removeProperty: #expandedExtent. 221278 self extent: extentToHandToHand]. 221279 ^self "Grab me"! ! 221280 221281!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:41'! 221282disableDragNDrop 221283 self enableDragNDrop: false! ! 221284 221285!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:50'! 221286dragEnabled 221287 "Get this morph's ability to add and remove morphs via drag-n-drop." 221288 ^(self valueOfProperty: #dragEnabled) == true 221289! ! 221290 221291!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:18'! 221292dragEnabled: aBool 221293 ^self enableDrag: aBool! ! 221294 221295!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:20'! 221296dragNDropEnabled 221297 "Note: This method is only useful for dragEnabled == dropEnabled at all times" 221298 self separateDragAndDrop. 221299 ^self dragEnabled and:[self dropEnabled]! ! 221300 221301!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 18:36'! 221302dragSelectionColor 221303 ^ Color magenta! ! 221304 221305!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:51'! 221306dropEnabled 221307 "Get this morph's ability to add and remove morphs via drag-n-drop." 221308 ^(self valueOfProperty: #dropEnabled) == true 221309! ! 221310 221311!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:18'! 221312dropEnabled: aBool 221313 ^self enableDrop: aBool! ! 221314 221315!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 10:52'! 221316dropHighlightColor 221317 ^ Color blue! ! 221318 221319!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 18:08'! 221320dropSuccessColor 221321 ^ Color blue! ! 221322 221323!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:41'! 221324enableDragNDrop 221325 self enableDragNDrop: true! ! 221326 221327!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:21'! 221328enableDragNDrop: aBoolean 221329 "Set both properties at once" 221330 self separateDragAndDrop. 221331 self enableDrag: aBoolean. 221332 self enableDrop: aBoolean.! ! 221333 221334!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:50'! 221335enableDrag: aBoolean 221336 self setProperty: #dragEnabled toValue: aBoolean! ! 221337 221338!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:51'! 221339enableDrop: aBoolean 221340 self setProperty: #dropEnabled toValue: aBoolean! ! 221341 221342!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:13'! 221343formerOwner 221344 ^self valueOfProperty: #formerOwner! ! 221345 221346!Morph methodsFor: 'dropping/grabbing' stamp: 'dgd 2/22/2003 14:31'! 221347formerOwner: aMorphOrNil 221348 aMorphOrNil isNil 221349 ifTrue: [self removeProperty: #formerOwner] 221350 ifFalse: [self setProperty: #formerOwner toValue: aMorphOrNil]! ! 221351 221352!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:13'! 221353formerPosition 221354 ^self valueOfProperty: #formerPosition! ! 221355 221356!Morph methodsFor: 'dropping/grabbing' stamp: 'dgd 2/22/2003 14:31'! 221357formerPosition: formerPosition 221358 formerPosition isNil 221359 ifTrue: [self removeProperty: #formerPosition] 221360 ifFalse: [self setProperty: #formerPosition toValue: formerPosition]! ! 221361 221362!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/6/2000 15:13'! 221363grabTransform 221364 "Return the transform for the receiver which should be applied during grabbing" 221365 ^owner ifNil:[IdentityTransform new] ifNotNil:[owner grabTransform]! ! 221366 221367!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 10:53'! 221368highlightedForDrop 221369 ^(self valueOfProperty: #highlightedForDrop) == true! ! 221370 221371!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 11:51'! 221372highlightForDrop 221373 self highlightForDrop: true! ! 221374 221375!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 12:01'! 221376highlightForDrop: aBoolean 221377 self setProperty: #highlightedForDrop toValue: aBoolean. 221378 self changed! ! 221379 221380!Morph methodsFor: 'dropping/grabbing' stamp: 'stephane.ducasse 10/16/2008 18:08'! 221381justDroppedInto: aMorph event: anEvent 221382 "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph" 221383 221384 | aWindow partsBinCase cmd | 221385 (self formerOwner notNil and: [self formerOwner ~~ aMorph]) 221386 ifTrue: [self removeHalo]. 221387 self formerOwner: nil. 221388 self formerPosition: nil. 221389 cmd := self valueOfProperty: #undoGrabCommand. 221390 cmd ifNotNil:[aMorph rememberCommand: cmd. 221391 self removeProperty: #undoGrabCommand]. 221392 (partsBinCase := aMorph isPartsBin) ifFalse: 221393 [self isPartsDonor: false]. 221394 (aWindow := aMorph ownerThatIsA: SystemWindow) ifNotNil: 221395 [aWindow isActive ifFalse: 221396 [aWindow activate]]. 221397 (self isInWorld and: [partsBinCase not]) ifTrue: 221398 [self world startSteppingSubmorphsOf: self]. 221399 "Note an unhappy inefficiency here: the startStepping... call will often have already been called in the sequence leading up to entry to this method, but unfortunately the isPartsDonor: call often will not have already happened, with the result that the startStepping... call will not have resulted in the startage of the steppage." 221400 221401 "An object launched by certain parts-launcher mechanisms should end up fully visible..." 221402 (self hasProperty: #beFullyVisibleAfterDrop) ifTrue: 221403 [aMorph == ActiveWorld ifTrue: 221404 [self goHome]. 221405 self removeProperty: #beFullyVisibleAfterDrop]. 221406 221407! ! 221408 221409!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 2/6/2001 22:12'! 221410justGrabbedFrom: formerOwner 221411 "The receiver was just grabbed from its former owner and is now attached to the hand. By default, we pass this message on if we're a renderer." 221412 (self isRenderer and:[self hasSubmorphs]) 221413 ifTrue:[self firstSubmorph justGrabbedFrom: formerOwner].! ! 221414 221415!Morph methodsFor: 'dropping/grabbing' stamp: 'sw 3/27/2001 11:52'! 221416nameForUndoWording 221417 "Return wording appropriate to the receiver for use in an undo-related menu item (and perhaps elsewhere)" 221418 221419 | aName | 221420 aName := self knownName ifNil: [self renderedMorph class name]. 221421 ^ aName truncateTo: 24! ! 221422 221423!Morph methodsFor: 'dropping/grabbing' stamp: 'di 12/12/2000 14:35'! 221424rejectDropMorphEvent: evt 221425 "The receiver has been rejected, and must be put back somewhere. There are three cases: 221426 (1) It remembers its former owner and position, and goes right back there 221427 (2) It remembers its former position only, in which case it was torn off from a parts bin, and the UI is that it floats back to its donor position and then vanishes. 221428 (3) Neither former owner nor position is remembered, in which case it is whisked to the Trash" 221429 221430 self removeProperty: #undoGrabCommand. 221431 (self formerOwner notNil and: [self formerOwner isPartsBin not]) ifTrue: 221432 [^ self slideBackToFormerSituation: evt]. 221433 221434 self formerPosition ifNotNil: "Position but no owner -- can just make it vanish" 221435 [^ self vanishAfterSlidingTo: self formerPosition event: evt]. 221436 221437 self slideToTrash: evt! ! 221438 221439!Morph methodsFor: 'dropping/grabbing' stamp: 'sw 1/11/1999 20:07'! 221440repelsMorph: aMorph event: ev 221441 ^ false! ! 221442 221443!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 12:02'! 221444resetHighlightForDrop 221445 self highlightForDrop: false! ! 221446 221447!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:24'! 221448separateDragAndDrop 221449 "Conversion only. Separate the old #dragNDropEnabled into #dragEnabled and #dropEnabled and remove the old property." 221450 | dnd | 221451 (self hasProperty: #dragNDropEnabled) ifFalse:[^self]. 221452 dnd := (self valueOfProperty: #dragNDropEnabled) == true. 221453 self dragEnabled: dnd. 221454 self dropEnabled: dnd. 221455 self removeProperty: #dragNDropEnabled. 221456! ! 221457 221458!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 8/12/2003 23:35'! 221459slideBackToFormerSituation: evt 221460 | slideForm formerOwner formerPosition aWorld startPoint endPoint trans | 221461 formerOwner := self formerOwner. 221462 formerPosition := self formerPosition. 221463 aWorld := evt hand world. 221464 trans := formerOwner transformFromWorld. 221465 slideForm := trans isPureTranslation 221466 ifTrue: [self imageForm offset: 0 @ 0] 221467 ifFalse: 221468 [((TransformationMorph new asFlexOf: self) transform: trans) imageForm 221469 offset: 0 @ 0]. 221470 startPoint := evt hand fullBounds origin. 221471 endPoint := trans localPointToGlobal: formerPosition. 221472 owner removeMorph: self. 221473 aWorld displayWorld. 221474 slideForm 221475 slideFrom: startPoint 221476 to: endPoint 221477 nSteps: 12 221478 delay: 15. 221479 formerOwner addMorph: self. 221480 self position: formerPosition. 221481 self justDroppedInto: formerOwner event: evt! ! 221482 221483!Morph methodsFor: 'dropping/grabbing' stamp: 'stephane.ducasse 4/14/2009 11:36'! 221484slideToTrash: evt 221485 "Morph do not slide to trash anymore." 221486 221487 221488 ^ self! ! 221489 221490!Morph methodsFor: 'dropping/grabbing' stamp: 'mir 1/4/2001 11:02'! 221491startDrag: anItem with: anObject 221492 self currentHand attachMorph: anObject! ! 221493 221494!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:46'! 221495toggleDragNDrop 221496 "Toggle this morph's ability to add and remove morphs via drag-n-drop." 221497 221498 self enableDragNDrop: self dragNDropEnabled not. 221499! ! 221500 221501!Morph methodsFor: 'dropping/grabbing'! 221502transportedMorph 221503 ^self! ! 221504 221505!Morph methodsFor: 'dropping/grabbing' stamp: 'dgd 8/26/2003 21:44'! 221506undoGrabCommand 221507 "Return an undo command for grabbing the receiver" 221508 221509 | cmd | 221510 owner ifNil: 221511 [^ nil]. "no owner - no undo" 221512 ^ (cmd := Command new) 221513 cmdWording: 'move ' translated, self nameForUndoWording; 221514 undoTarget: self 221515 selector: #undoMove:redo:owner:bounds:predecessor: 221516 arguments: {cmd. false. owner. self bounds. (owner morphPreceding: self)}; 221517 yourself! ! 221518 221519!Morph methodsFor: 'dropping/grabbing' stamp: 'adrian_lienhard 7/19/2009 17:35'! 221520vanishAfterSlidingTo: aPosition event: evt 221521 221522 | aForm aWorld startPoint endPoint | 221523 aForm := self imageForm offset: 0@0. 221524 aWorld := self world. 221525 startPoint := evt hand fullBounds origin. 221526 self delete. 221527 aWorld displayWorld. 221528 endPoint := aPosition. 221529 aForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15.! ! 221530 221531!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:24'! 221532wantsDroppedMorph: aMorph event: evt 221533 "Return true if the receiver wishes to accept the given morph, which is being dropped by a hand in response to the given event. Note that for a successful drop operation both parties need to agree. The symmetric check is done automatically via aMorph wantsToBeDroppedInto: self." 221534 221535 ^self dropEnabled! ! 221536 221537!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 9/18/2000 18:34'! 221538wantsToBeDroppedInto: aMorph 221539 "Return true if it's okay to drop the receiver into aMorph. This check is symmetric to #wantsDroppedMorph:event: to give both parties a chance of figuring out whether they like each other." 221540 ^true! ! 221541 221542!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 2/10/1999 05:44'! 221543wantsToBeOpenedInWorld 221544 "Return true if the receiver wants to be put into the World directly, 221545 rather than allowing the user to place it (e.g., prevent attaching me 221546 to the hand after choosing 'new morph' in the world menu)" 221547 ^false! ! 221548 221549!Morph methodsFor: 'dropping/grabbing' stamp: 'sw 8/15/2000 16:58'! 221550willingToBeDiscarded 221551 ^ true! ! 221552 221553 221554!Morph methodsFor: 'e-toy support' stamp: 'sw 2/9/1999 17:43'! 221555adaptToWorld: aWorld 221556 "The receiver finds itself operating in a possibly-different new world. If any of the receiver's parts are world-dependent (such as a target of a SimpleButtonMorph, etc.), then have them adapt accordingly" 221557 submorphs do: [:m | m adaptToWorld: aWorld]. 221558 self eventHandler ifNotNil: 221559 [self eventHandler adaptToWorld: aWorld]! ! 221560 221561!Morph methodsFor: 'e-toy support' stamp: 'alain.plantec 6/8/2009 23:41'! 221562allMorphsInto: aSet 221563 "Return a set of all submorphs. Don't forget the hidden ones. Consider only objects that are in memory (see allNonSubmorphMorphs)." 221564 221565 submorphs do: [:m | m allMorphsInto: aSet]. 221566 self allNonSubmorphMorphs do: [:m | 221567 (aSet includes: m) ifFalse: ["Stop infinite recursion" 221568 m allMorphsInto: aSet]]. 221569 aSet add: self. 221570 ^ aSet! ! 221571 221572!Morph methodsFor: 'e-toy support'! 221573asNumber: aPointOrNumber 221574 "Support for e-toy demo." 221575 221576 aPointOrNumber class = Point 221577 ifTrue: [^ aPointOrNumber r] 221578 ifFalse: [^ aPointOrNumber]. 221579! ! 221580 221581!Morph methodsFor: 'e-toy support' stamp: 'sw 5/18/2001 11:17'! 221582changeAllBorderColorsFrom: oldColor to: newColor 221583 "Set any occurrence of oldColor as a border color in my entire submorph tree to be newColor" 221584 221585 (self allMorphs select: [:m | m respondsTo: #borderColor:]) do: 221586 [:aMorph | aMorph borderColor = oldColor ifTrue: [aMorph borderColor: newColor]]! ! 221587 221588!Morph methodsFor: 'e-toy support' stamp: 'alain.plantec 6/19/2008 09:34'! 221589containingWindow 221590 "Answer a window that contains the receiver" 221591 221592 ^ self ownerThatIsA: SystemWindow! ! 221593 221594!Morph methodsFor: 'e-toy support' stamp: 'sw 9/8/2000 16:34'! 221595cursor 221596 "vacuous backstop in case it gets sent to a morph that doesn't know what to do with it" 221597 221598 ^ 1! ! 221599 221600!Morph methodsFor: 'e-toy support' stamp: 'sw 9/7/2000 09:28'! 221601cursor: aNumber 221602 "vacuous backstop in case it gets sent to a morph that doesn't know what to do with it" 221603! ! 221604 221605!Morph methodsFor: 'e-toy support' stamp: 'sw 9/13/2002 17:44'! 221606decimalPlacesForGetter: aGetter 221607 "Answer the decimal places I prefer for showing a slot with the given getter, or nil if none" 221608 221609 | decimalPrefs | 221610 decimalPrefs := self renderedMorph valueOfProperty: #decimalPlacePreferences ifAbsent: [^ nil]. 221611 ^ decimalPrefs at: aGetter ifAbsent: [nil]! ! 221612 221613!Morph methodsFor: 'e-toy support' stamp: 'sw 10/26/1999 23:32'! 221614embeddedInMorphicWindowLabeled: labelString 221615 | window | 221616 window := (SystemWindow labelled: labelString) model: nil. 221617 window setStripeColorsFrom: nil defaultBackgroundColor. 221618 window addMorph: self frame: (0@0 extent: 1@1). 221619 ^ window! ! 221620 221621!Morph methodsFor: 'e-toy support' stamp: 'RAA 5/25/2000 09:06'! 221622embedInWindow 221623 221624 | window worldToUse | 221625 221626 worldToUse := self world. "I'm assuming we are already in a world" 221627 window := (SystemWindow labelled: self defaultLabelForInspector) model: nil. 221628 window bounds: ((self position - ((0@window labelHeight) + window borderWidth)) 221629 corner: self bottomRight + window borderWidth). 221630 window addMorph: self frame: (0@0 extent: 1@1). 221631 window updatePaneColors. 221632 worldToUse addMorph: window. 221633 window activate! ! 221634 221635!Morph methodsFor: 'e-toy support' stamp: 'sw 2/18/2003 02:54'! 221636getCharacters 221637 "obtain a string value from the receiver. The default generic response is simply the name of the object." 221638 221639 ^ self externalName! ! 221640 221641!Morph methodsFor: 'e-toy support' stamp: 'sw 9/1/2000 10:15'! 221642getNumericValue 221643 "Only certain kinds of morphs know how to deal with this frontally; here we provide support for a numeric property of any morph" 221644 221645 ^ self valueOfProperty: #numericValue ifAbsent: [0]! ! 221646 221647!Morph methodsFor: 'e-toy support' stamp: 'kfr 9/4/2004 15:22'! 221648gridFormOrigin: origin grid: smallGrid background: backColor line: lineColor 221649 221650 | bigGrid gridForm gridOrigin | 221651 gridOrigin := origin \\ smallGrid. 221652 bigGrid := (smallGrid asPoint x) @ (smallGrid asPoint y). 221653 gridForm := Form extent: bigGrid depth: Display depth. 221654 backColor ifNotNil: [gridForm fillWithColor: backColor]. 221655 gridOrigin x to: gridForm width by: smallGrid x do: 221656 [:x | gridForm fill: (x@0 extent: 1@gridForm height) fillColor: lineColor]. 221657 gridOrigin y to: gridForm height by: smallGrid y do: 221658 [:y | gridForm fill: (0@y extent: gridForm width@1) fillColor: lineColor]. 221659 ^ InfiniteForm with: gridForm 221660! ! 221661 221662!Morph methodsFor: 'e-toy support' stamp: 'alain.plantec 2/6/2009 15:34'! 221663makeGraphPaper 221664 | smallGrid backColor lineColor | 221665 smallGrid := Compiler evaluate: (UIManager default 221666 request: 'Enter grid size' translated 221667 initialAnswer: '16'). 221668 smallGrid ifNil: [ ^ self ]. 221669 UIManager default 221670 informUser: 'Choose a background color' translated 221671 during: [ backColor := Color fromUser ]. 221672 UIManager default 221673 informUser: 'Choose a line color' translated 221674 during: [ lineColor := Color fromUser ]. 221675 self 221676 makeGraphPaperGrid: smallGrid 221677 background: backColor 221678 line: lineColor! ! 221679 221680!Morph methodsFor: 'e-toy support' stamp: 'di 9/7/2000 20:44'! 221681makeGraphPaperGrid: smallGrid background: backColor line: lineColor 221682 221683 | gridForm | 221684 gridForm := self gridFormOrigin: 0@0 grid: smallGrid asPoint background: backColor line: lineColor. 221685 self color: gridForm. 221686 self world ifNotNil: [self world fullRepaintNeeded]. 221687 self changed: #newColor. "propagate to view" 221688! ! 221689 221690!Morph methodsFor: 'e-toy support' stamp: 'sw 9/13/2002 17:45'! 221691noteDecimalPlaces: aNumber forGetter: aGetter 221692 "Make a mental note of the user's preference for a particular number of decimal places to be associated with the slot with the given getter" 221693 221694 (self renderedMorph valueOfProperty: #decimalPlacePreferences ifAbsentPut: [IdentityDictionary new]) 221695 at: aGetter put: aNumber! ! 221696 221697!Morph methodsFor: 'e-toy support' stamp: 'ar 9/23/2000 22:40'! 221698rotationStyle 221699 "Return the 'rotation style' of the receiver" 221700 ^#normal! ! 221701 221702!Morph methodsFor: 'e-toy support' stamp: 'ar 9/23/2000 22:40'! 221703rotationStyle: aSymbol 221704 "Set the 'rotation style' of the receiver; this is ignored for non-sketches"! ! 221705 221706!Morph methodsFor: 'e-toy support' stamp: 'sw 7/21/1998 21:18'! 221707setStandardTexture 221708 | parms | 221709 parms := self textureParameters. 221710 self makeGraphPaperGrid: parms first 221711 background: parms second 221712 line: parms third! ! 221713 221714!Morph methodsFor: 'e-toy support' stamp: 'sw 7/21/1998 21:17'! 221715textureParameters 221716 "Answer a triplet giving the preferred grid size, background color, and line color. The choices here are as suggested by Alan, 9/13/97" 221717 221718 ^ Array with: 16 with: Color lightYellow with: Color lightGreen lighter lighter! ! 221719 221720!Morph methodsFor: 'e-toy support' stamp: 'tk 10/19/1999 07:16'! 221721updateCachedThumbnail 221722 "If I have a cached thumbnail, then update it. Copied up from Dan's original version in PasteUpMorph so it can be used by all morphs." 221723 | cachedThumbnail | 221724 221725 (cachedThumbnail := self valueOfProperty: #cachedThumbnail) ifNotNil: 221726 [(cachedThumbnail respondsTo: #computeThumbnail) 221727 ifTrue: [cachedThumbnail computeThumbnail] 221728 ifFalse: [self removeProperty: #computeThumbnail]]. 221729 "Test and removal are because the thumbnail is being replaced by another Morph. We don't know why. Need to fix that at the source."! ! 221730 221731!Morph methodsFor: 'e-toy support' stamp: 'sw 11/27/2001 14:52'! 221732wantsRecolorHandle 221733 "Answer whether the receiver would like a recoloring halo handle to be put up. Since this handle also presently affords access to the property-sheet, it is presently always allowed, even though SketchMorphs don't like regular recoloring" 221734 221735 ^ true 221736 221737! ! 221738 221739!Morph methodsFor: 'e-toy support' stamp: 'stephane.ducasse 10/16/2008 18:31'! 221740wrappedInWindowWithTitle: aTitle 221741 221742 | aWindow w2 | 221743 aWindow := (SystemWindow labelled: aTitle) model: Model new. 221744 aWindow addMorph: self frame: (0@0 extent: 1@1). 221745 "w2 := aWindow borderWidth * 2." 221746 w2 := 3. 221747 aWindow extent: self fullBounds extent + (0 @ aWindow labelHeight) + (w2 @ w2). 221748 ^ aWindow! ! 221749 221750!Morph methodsFor: 'e-toy support' stamp: 'stephane.ducasse 10/16/2008 18:32'! 221751wrappedInWindow: aSystemWindow 221752 | aWindow | 221753 aWindow := aSystemWindow model: Model new. 221754 aWindow addMorph: self frame: (0@0 extent: 1@1). 221755 aWindow extent: self extent. 221756 ^ aWindow! ! 221757 221758 221759!Morph methodsFor: 'event handling' stamp: 'tk 9/6/2000 12:42'! 221760click 221761 "Pretend the user clicked on me." 221762 221763 (self handlesMouseDown: nil) ifTrue: [ 221764 self mouseDown: nil. 221765 self mouseUp: nil].! ! 221766 221767!Morph methodsFor: 'event handling' stamp: 'LC 5/18/2000 09:54'! 221768click: evt 221769 "Handle a single-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing. 221770 LC 2/14/2000 08:32 - added: EventHandler notification" 221771 221772 self eventHandler ifNotNil: 221773 [self eventHandler click: evt fromMorph: self].! ! 221774 221775!Morph methodsFor: 'event handling' stamp: 'sw 3/8/1999 00:17'! 221776cursorPoint 221777 ^ self currentHand lastEvent cursorPoint! ! 221778 221779!Morph methodsFor: 'event handling' stamp: 'jcg 10/2/2001 09:26'! 221780doubleClickTimeout: evt 221781 "Handle a double-click timeout event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing." 221782 221783 self eventHandler ifNotNil: 221784 [self eventHandler doubleClickTimeout: evt fromMorph: self].! ! 221785 221786!Morph methodsFor: 'event handling' stamp: 'LC 5/18/2000 09:54'! 221787doubleClick: evt 221788 "Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing. 221789 LC 2/14/2000 08:32 - added: EventHandler notification" 221790 221791 self eventHandler ifNotNil: 221792 [self eventHandler doubleClick: evt fromMorph: self].! ! 221793 221794!Morph methodsFor: 'event handling' stamp: 'ar 1/10/2001 21:28'! 221795dropFiles: anEvent 221796 "Handle a number of files dropped from the OS" 221797! ! 221798 221799!Morph methodsFor: 'event handling' stamp: 'RAA 2/12/2001 15:26'! 221800firstClickTimedOut: evt 221801 "Useful for double-click candidates who want to know whether or not the click is a single or double. In this case, ignore the #click: and wait for either this or #doubleClick:" 221802 221803! ! 221804 221805!Morph methodsFor: 'event handling' stamp: 'nk 3/10/2004 19:48'! 221806handlerForYellowButtonDown: anEvent 221807 "Return the (prospective) handler for a mouse down event with the yellow button pressed. 221808 The handler is temporarily installed and can be used for morphs further 221809 down the hierarchy to negotiate whether the inner or the outer 221810 morph should finally handle the event." 221811 221812 (self hasYellowButtonMenu or: [ self handlesMouseDown: anEvent ]) 221813 ifFalse: [ ^ nil]. "Not interested." 221814 221815 anEvent handler 221816 ifNil: [^ self]. "Nobody else was interested" 221817 221818 "Same priority but I am innermost." 221819 ^ self mouseDownPriority >= anEvent handler mouseDownPriority 221820 ifFalse: [nil ] 221821 ifTrue: [self]! ! 221822 221823!Morph methodsFor: 'event handling' stamp: 'ar 10/28/2000 22:18'! 221824handlesKeyboard: evt 221825 "Return true if the receiver wishes to handle the given keyboard event" 221826 self eventHandler ifNotNil: [^ self eventHandler handlesKeyboard: evt]. 221827 ^ false 221828! ! 221829 221830!Morph methodsFor: 'event handling' stamp: 'nk 2/14/2004 18:42'! 221831handlesMouseDown: evt 221832 "Do I want to receive mouseDown events (mouseDown:, mouseMove:, mouseUp:)?" 221833 "NOTE: The default response is false, except if you have added sensitivity to mouseDown events using the on:send:to: mechanism. Subclasses that implement these messages directly should override this one to return true." 221834 221835 self eventHandler ifNotNil: [^ self eventHandler handlesMouseDown: evt]. 221836 ^ false! ! 221837 221838!Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:31'! 221839handlesMouseOverDragging: evt 221840 "Return true if I want to receive mouseEnterDragging: and mouseLeaveDragging: when the hand drags something over me (button up or button down), or when the mouse button is down but there is no mouseDown recipient. The default response is false, except if you have added sensitivity to mouseEnterLaden: or mouseLeaveLaden:, using the on:send:to: mechanism." 221841 "NOTE: If the hand state matters in these cases, it may be tested by constructs such as 221842 event anyButtonPressed 221843 event hand hasSubmorphs" 221844 221845 self eventHandler ifNotNil: [^ self eventHandler handlesMouseOverDragging: evt]. 221846 ^ false! ! 221847 221848!Morph methodsFor: 'event handling' stamp: 'ar 10/22/2000 17:06'! 221849handlesMouseStillDown: evt 221850 "Return true if the receiver wants to get repeated #mouseStillDown: messages between #mouseDown: and #mouseUp" 221851 self eventHandler ifNotNil: [^ self eventHandler handlesMouseStillDown: evt]. 221852 ^ false 221853! ! 221854 221855!Morph methodsFor: 'event handling' stamp: 'sw 4/2/98 14:16'! 221856hasFocus 221857 ^ false! ! 221858 221859!Morph methodsFor: 'event handling'! 221860keyboardFocusChange: aBoolean 221861 "The message is sent to a morph when its keyboard focus change. The given argument indicates that the receiver is gaining keyboard focus (versus losing) the keyboard focus. Morphs that accept keystrokes should change their appearance in some way when they are the current keyboard focus. This default implementation does nothing."! ! 221862 221863!Morph methodsFor: 'event handling' stamp: 'ar 9/14/2000 18:23'! 221864keyDown: anEvent 221865 "Handle a key down event. The default response is to do nothing."! ! 221866 221867!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:05'! 221868keyStroke: anEvent 221869 "Handle a keystroke event. The default response is to let my eventHandler, if any, handle it." 221870 221871 self eventHandler ifNotNil: 221872 [self eventHandler keyStroke: anEvent fromMorph: self]. 221873! ! 221874 221875!Morph methodsFor: 'event handling' stamp: 'KTT 6/1/2004 11:41'! 221876keyUp: anEvent 221877 "Handle a key up event. The default response is to do nothing."! ! 221878 221879!Morph methodsFor: 'event handling' stamp: 'dgd 9/19/2004 13:14'! 221880mouseDown: evt 221881 "Handle a mouse down event. The default response is to let my 221882 eventHandler, if any, handle it." 221883 evt yellowButtonPressed 221884 ifTrue: ["First check for option (menu) click" 221885 ^ self yellowButtonActivity: evt shiftPressed]. 221886 self eventHandler 221887 ifNotNil: [self eventHandler mouseDown: evt fromMorph: self] 221888! ! 221889 221890!Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:33'! 221891mouseEnterDragging: evt 221892 "Handle a mouseEnterDragging event, meaning the mouse just entered my bounds with a button pressed or laden with submorphs. The default response is to let my eventHandler, if any, handle it, or else to do nothing." 221893 221894 self eventHandler ifNotNil: 221895 [^ self eventHandler mouseEnterDragging: evt fromMorph: self]. 221896! ! 221897 221898!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:00'! 221899mouseEnter: evt 221900 "Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it." 221901 221902 self eventHandler ifNotNil: 221903 [self eventHandler mouseEnter: evt fromMorph: self]. 221904! ! 221905 221906!Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:38'! 221907mouseLeaveDragging: evt 221908 "Handle a mouseLeaveLaden event, meaning the mouse just left my bounds with a button pressed or laden with submorphs. The default response is to let my eventHandler, if any, handle it; else to do nothing." 221909 221910 self eventHandler ifNotNil: 221911 [self eventHandler mouseLeaveDragging: evt fromMorph: self]! ! 221912 221913!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:01'! 221914mouseLeave: evt 221915 "Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it." 221916 221917 self eventHandler ifNotNil: 221918 [self eventHandler mouseLeave: evt fromMorph: self]. 221919! ! 221920 221921!Morph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:04'! 221922mouseMove: evt 221923 "Handle a mouse move event. The default response is to let my eventHandler, if any, handle it." 221924 self eventHandler ifNotNil: 221925 [self eventHandler mouseMove: evt fromMorph: self]. 221926! ! 221927 221928!Morph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:02'! 221929mouseStillDownThreshold 221930 "Return the number of milliseconds after which mouseStillDown: should be sent" 221931 ^200! ! 221932 221933!Morph methodsFor: 'event handling' stamp: 'ar 10/22/2000 17:08'! 221934mouseStillDown: evt 221935 "Handle a mouse move event. The default response is to let my eventHandler, if any, handle it." 221936 221937 self eventHandler ifNotNil: 221938 [self eventHandler mouseStillDown: evt fromMorph: self]. 221939! ! 221940 221941!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:05'! 221942mouseUp: evt 221943 "Handle a mouse up event. The default response is to let my eventHandler, if any, handle it." 221944 221945 self eventHandler ifNotNil: 221946 [self eventHandler mouseUp: evt fromMorph: self]. 221947! ! 221948 221949!Morph methodsFor: 'event handling' stamp: 'dgd 8/28/2004 18:20'! 221950moveOrResizeFromKeystroke: anEvent 221951 "move or resize the receiver based on a keystroke" 221952 | dir | 221953 221954 anEvent keyValue = 28 ifTrue: [dir := -1 @ 0]. 221955 anEvent keyValue = 29 ifTrue: [dir := 1 @ 0]. 221956 anEvent keyValue = 30 ifTrue: [dir := 0 @ -1]. 221957 anEvent keyValue = 31 ifTrue: [dir := 0 @ 1]. 221958 221959 dir notNil 221960 ifTrue:[ 221961 anEvent controlKeyPressed ifTrue: [dir := dir * 10]. 221962 221963 anEvent shiftPressed 221964 ifTrue: [self extent: self extent + dir] 221965 ifFalse: [self position: self position + dir]. 221966 221967 "anEvent wasHandled: true." 221968 ] 221969! ! 221970 221971!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:01'! 221972on: eventName send: selector to: recipient 221973 self eventHandler ifNil: [self eventHandler: EventHandler new]. 221974 self eventHandler on: eventName send: selector to: recipient! ! 221975 221976!Morph methodsFor: 'event handling' stamp: 'ar 3/18/2001 17:21'! 221977on: eventName send: selector to: recipient withValue: value 221978 "NOTE: selector must take 3 arguments, of which value will be the *** FIRST ***" 221979 221980 self eventHandler ifNil: [self eventHandler: EventHandler new]. 221981 self eventHandler on: eventName send: selector to: recipient withValue: value 221982! ! 221983 221984!Morph methodsFor: 'event handling' stamp: 'fbs 1/7/2005 15:43'! 221985preferredKeyboardBounds 221986 221987 ^ self bounds: self bounds in: World. 221988! ! 221989 221990!Morph methodsFor: 'event handling' stamp: 'fbs 1/7/2005 15:42'! 221991preferredKeyboardPosition 221992 221993 ^ (self bounds: self bounds in: World) topLeft. 221994! ! 221995 221996!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:02'! 221997removeLink: actionCode 221998 self eventHandler ifNotNil: 221999 [self eventHandler on: actionCode send: nil to: nil]! ! 222000 222001!Morph methodsFor: 'event handling' stamp: 'sw 11/16/1998 08:06'! 222002restoreSuspendedEventHandler 222003 | savedHandler | 222004 (savedHandler := self valueOfProperty: #suspendedEventHandler) ifNotNil: 222005 [self eventHandler: savedHandler]. 222006 submorphs do: [:m | m restoreSuspendedEventHandler] 222007! ! 222008 222009!Morph methodsFor: 'event handling' stamp: 'mir 5/23/2000 17:43'! 222010startDrag: evt 222011 "Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing." 222012 222013 self eventHandler ifNotNil: 222014 [self eventHandler startDrag: evt fromMorph: self].! ! 222015 222016!Morph methodsFor: 'event handling' stamp: 'sw 11/16/1998 08:07'! 222017suspendEventHandler 222018 self eventHandler ifNotNil: 222019 [self setProperty: #suspendedEventHandler toValue: self eventHandler. 222020 self eventHandler: nil]. 222021 submorphs do: [:m | m suspendEventHandler]. "All those rectangles"! ! 222022 222023!Morph methodsFor: 'event handling' stamp: 'dgd 8/28/2004 18:42'! 222024tabAmongFields 222025 ^ Preferences tabAmongFields 222026 or: [self hasProperty: #tabAmongFields] ! ! 222027 222028!Morph methodsFor: 'event handling' stamp: 'RAA 6/19/2000 07:13'! 222029transformFromOutermostWorld 222030 "Return a transform to map world coordinates into my local coordinates" 222031 222032 "self isWorldMorph ifTrue: [^ MorphicTransform identity]." 222033 ^ self transformFrom: self outermostWorldMorph! ! 222034 222035!Morph methodsFor: 'event handling'! 222036transformFromWorld 222037 "Return a transform to map world coordinates into my local coordinates" 222038 222039 ^ self transformFrom: nil! ! 222040 222041!Morph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 14:36'! 222042transformFrom: uberMorph 222043 "Return a transform to be used to map coordinates in a morph above me into my childrens coordinates, or vice-versa. This is used to support scrolling, scaling, and/or rotation. This default implementation just returns my owner's transform or the identity transform if my owner is nil. 222044 Note: This method cannot be used to map into the receiver's coordinate system!!" 222045 222046 (self == uberMorph or: [owner isNil]) ifTrue: [^IdentityTransform new]. 222047 ^owner transformFrom: uberMorph! ! 222048 222049!Morph methodsFor: 'event handling' stamp: 'ar 1/10/2001 21:28'! 222050wantsDropFiles: anEvent 222051 "Return true if the receiver wants files dropped from the OS." 222052 ^false! ! 222053 222054!Morph methodsFor: 'event handling' stamp: 'di 9/14/2000 11:46'! 222055wantsEveryMouseMove 222056 "Unless overridden, this method allows processing to skip mouse move events 222057 when processing is lagging. No 'significant' event (down/up, etc) will be skipped." 222058 222059 ^ false! ! 222060 222061!Morph methodsFor: 'event handling' stamp: 'sw 11/3/97 02:11'! 222062wantsKeyboardFocusFor: aSubmorph 222063 "Answer whether a plain mouse click on aSubmorph, a text-edit-capable thing, should result in a text selection there" 222064 ^ false! ! 222065 222066!Morph methodsFor: 'event handling' stamp: 'sw 5/6/1998 12:54'! 222067wouldAcceptKeyboardFocus 222068 "Answer whether a plain mouse click on the receiver should result in a text selection there" 222069 ^ false! ! 222070 222071!Morph methodsFor: 'event handling' stamp: 'sw 8/29/2000 14:57'! 222072wouldAcceptKeyboardFocusUponTab 222073 "Answer whether the receiver is in the running as the new keyboard focus if the tab key were hit at a meta level. This provides the leverage for tabbing among fields of a card, for example." 222074 222075 ^ false! ! 222076 222077!Morph methodsFor: 'event handling' stamp: 'dgd 7/28/2005 13:02'! 222078yellowButtonActivity: shiftState 222079 "Find me or my outermost owner that has items to add to a 222080 yellow button menu. 222081 shiftState is true if the shift was pressed. 222082 Otherwise, build a menu that contains the contributions from 222083 myself and my interested submorphs, 222084 and present it to the user." 222085 | menu | 222086 self isWorldMorph 222087 ifFalse: [| outerOwner | 222088 outerOwner := self outermostOwnerWithYellowButtonMenu. 222089 outerOwner 222090 ifNil: [^ self]. 222091 outerOwner == self 222092 ifFalse: [^ outerOwner yellowButtonActivity: shiftState]]. 222093 menu := self buildYellowButtonMenu: ActiveHand. 222094 menu 222095 addTitle: self externalName 222096 icon: (self iconOrThumbnailOfSize: (Preferences tinyDisplay ifTrue: [16] ifFalse: [28])). 222097 menu popUpInWorld: self currentWorld! ! 222098 222099 222100!Morph methodsFor: 'event handling-override' stamp: 'nk 3/10/2004 19:47'! 222101handlerForMouseDown: anEvent 222102 "Return the (prospective) handler for a mouse down event. The handler is temporarily 222103 installed and can be used for morphs further down the hierarchy to negotiate whether 222104 the inner or the outer morph should finally handle the event." 222105 222106 anEvent blueButtonPressed 222107 ifTrue: [^ self handlerForBlueButtonDown: anEvent]. 222108 anEvent yellowButtonPressed 222109 ifTrue: [^ self handlerForYellowButtonDown: anEvent]. 222110 anEvent controlKeyPressed 222111 ifTrue: [^ self handlerForMetaMenu: anEvent]. 222112 (self handlesMouseDown: anEvent) 222113 ifFalse: [^ nil]. "not interested" 222114 222115 anEvent handler 222116 ifNil: [^ self ]. "Same priority but I am innermost" 222117 222118 "Nobody else was interested" 222119 ^self mouseDownPriority >= anEvent handler mouseDownPriority 222120 ifTrue: [ self] 222121 ifFalse: [ nil]! ! 222122 222123 222124!Morph methodsFor: 'events-accessing' stamp: 'rw 4/25/2002 07:18'! 222125actionMap 222126 "Answer an action map" 222127 222128 | actionMap | 222129 actionMap := self valueOfProperty: #actionMap. 222130 actionMap ifNil: 222131 [actionMap := self createActionMap]. 222132 ^ actionMap! ! 222133 222134!Morph methodsFor: 'events-accessing' stamp: 'rw 4/25/2002 07:17'! 222135updateableActionMap 222136 "Answer an updateable action map, saving it in my #actionMap property" 222137 222138 | actionMap | 222139 actionMap := self valueOfProperty: #actionMap. 222140 actionMap ifNil: 222141 [actionMap := self createActionMap. 222142 self setProperty: #actionMap toValue: actionMap]. 222143 ^ actionMap! ! 222144 222145 222146!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! 222147addAlarm: aSelector after: delayTime 222148 "Add an alarm (that is an action to be executed once) with the given set of parameters" 222149 ^self addAlarm: aSelector withArguments: #() after: delayTime! ! 222150 222151!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! 222152addAlarm: aSelector at: scheduledTime 222153 "Add an alarm (that is an action to be executed once) with the given set of parameters" 222154 ^self addAlarm: aSelector withArguments: #() at: scheduledTime! ! 222155 222156!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! 222157addAlarm: aSelector withArguments: args after: delayTime 222158 "Add an alarm (that is an action to be executed once) with the given set of parameters" 222159 ^self addAlarm: aSelector withArguments: args at: Time millisecondClockValue + delayTime! ! 222160 222161!Morph methodsFor: 'events-alarms' stamp: 'ar 9/14/2000 12:15'! 222162addAlarm: aSelector withArguments: args at: scheduledTime 222163 "Add an alarm (that is an action to be executed once) with the given set of parameters" 222164 | scheduler | 222165 scheduler := self alarmScheduler. 222166 scheduler ifNotNil:[scheduler addAlarm: aSelector withArguments: args for: self at: scheduledTime].! ! 222167 222168!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! 222169addAlarm: aSelector with: arg1 after: delayTime 222170 "Add an alarm (that is an action to be executed once) with the given set of parameters" 222171 ^self addAlarm: aSelector withArguments: (Array with: arg1) after: delayTime! ! 222172 222173!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! 222174addAlarm: aSelector with: arg1 at: scheduledTime 222175 "Add an alarm (that is an action to be executed once) with the given set of parameters" 222176 ^self addAlarm: aSelector withArguments: (Array with: arg1) at: scheduledTime! ! 222177 222178!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! 222179addAlarm: aSelector with: arg1 with: arg2 after: delayTime 222180 "Add an alarm (that is an action to be executed once) with the given set of parameters" 222181 ^self addAlarm: aSelector withArguments: (Array with: arg1 with: arg2) after: delayTime! ! 222182 222183!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! 222184addAlarm: aSelector with: arg1 with: arg2 at: scheduledTime 222185 "Add an alarm (that is an action to be executed once) with the given set of parameters" 222186 ^self addAlarm: aSelector withArguments: (Array with: arg1 with: arg2) at: scheduledTime! ! 222187 222188!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:34'! 222189alarmScheduler 222190 "Return the scheduler being responsible for triggering alarms" 222191 ^self world! ! 222192 222193!Morph methodsFor: 'events-alarms' stamp: 'ar 9/14/2000 12:14'! 222194removeAlarm: aSelector 222195 "Remove the given alarm" 222196 | scheduler | 222197 scheduler := self alarmScheduler. 222198 scheduler ifNotNil:[scheduler removeAlarm: aSelector for: self].! ! 222199 222200!Morph methodsFor: 'events-alarms' stamp: 'ar 9/14/2000 12:15'! 222201removeAlarm: aSelector at: scheduledTime 222202 "Remove the given alarm" 222203 | scheduler | 222204 scheduler := self alarmScheduler. 222205 scheduler ifNotNil:[scheduler removeAlarm: aSelector at: scheduledTime for: self].! ! 222206 222207 222208!Morph methodsFor: 'events-processing' stamp: 'ar 9/13/2000 17:58'! 222209containsPoint: aPoint event: anEvent 222210 "Return true if aPoint is considered to be inside the receiver for the given event. 222211 The default implementation treats locked children as integral part of their owners." 222212 (self fullBounds containsPoint: aPoint) ifFalse:[^false]. 222213 (self containsPoint: aPoint) ifTrue:[^true]. 222214 self submorphsDo:[:m| 222215 (m isLocked and:[m fullContainsPoint: 222216 ((m transformedFrom: self) globalPointToLocal: aPoint)]) ifTrue:[^true]]. 222217 ^false! ! 222218 222219!Morph methodsFor: 'events-processing' stamp: 'ar 9/13/2000 14:51'! 222220defaultEventDispatcher 222221 "Return the default event dispatcher to use with events that are directly sent to the receiver" 222222 ^MorphicEventDispatcher new! ! 222223 222224!Morph methodsFor: 'events-processing' stamp: 'ar 1/10/2001 21:35'! 222225handleDropFiles: anEvent 222226 "Handle a drop from the OS." 222227 anEvent wasHandled ifTrue:[^self]. "not interested" 222228 (self wantsDropFiles: anEvent) ifFalse:[^self]. 222229 anEvent wasHandled: true. 222230 self dropFiles: anEvent. 222231! ! 222232 222233!Morph methodsFor: 'events-processing' stamp: 'di 12/12/2000 14:39'! 222234handleDropMorph: anEvent 222235 "Handle a dropping morph." 222236 | aMorph localPt | 222237 aMorph := anEvent contents. 222238 "Do a symmetric check if both morphs like each other" 222239 ((self wantsDroppedMorph: aMorph event: anEvent) "I want her" 222240 and: [aMorph wantsToBeDroppedInto: self]) "she wants me" 222241 ifFalse: [aMorph removeProperty: #undoGrabCommand. 222242 ^ self]. 222243 anEvent wasHandled: true. 222244 "Transform the morph into the receiver's coordinate frame. This is currently incomplete since it only takes the offset into account where it really should take the entire transform." 222245 localPt := (self transformedFrom: anEvent hand world) "full transform down" 222246 globalPointToLocal: aMorph referencePosition. 222247 aMorph referencePosition: localPt. 222248 self acceptDroppingMorph: aMorph event: anEvent. 222249 aMorph justDroppedInto: self event: anEvent. 222250! ! 222251 222252!Morph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 21:13'! 222253handleEvent: anEvent 222254 "Handle the given event" 222255 ^anEvent sentTo: self.! ! 222256 222257!Morph methodsFor: 'events-processing' stamp: 'ar 10/4/2000 18:48'! 222258handleFocusEvent: anEvent 222259 "Handle the given event. This message is sent if the receiver currently has the focus and is therefore receiving events directly from some hand." 222260 ^self handleEvent: anEvent! ! 222261 222262!Morph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 23:01'! 222263handleKeyDown: anEvent 222264 "System level event handling." 222265 anEvent wasHandled ifTrue:[^self]. 222266 (self handlesKeyboard: anEvent) ifFalse:[^self]. 222267 anEvent wasHandled: true. 222268 ^self keyDown: anEvent! ! 222269 222270!Morph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 23:01'! 222271handleKeyUp: anEvent 222272 "System level event handling." 222273 anEvent wasHandled ifTrue:[^self]. 222274 (self handlesKeyboard: anEvent) ifFalse:[^self]. 222275 anEvent wasHandled: true. 222276 ^self keyUp: anEvent! ! 222277 222278!Morph methodsFor: 'events-processing' stamp: 'md 8/2/2006 18:57'! 222279handleKeystroke: anEvent 222280 "System level event handling." 222281 222282 anEvent wasHandled 222283 ifTrue: [^ self]. 222284 (self handlesKeyboard: anEvent) 222285 ifFalse: [^ self]. 222286 anEvent wasHandled: true. 222287 ^ self keyStroke: anEvent! ! 222288 222289!Morph methodsFor: 'events-processing' stamp: 'ar 9/16/2000 14:22'! 222290handleListenEvent: anEvent 222291 "Handle the given event. This message is sent if the receiver is a registered listener for the given event." 222292 ^anEvent sentTo: self.! ! 222293 222294!Morph methodsFor: 'events-processing' stamp: 'marcus.denker 9/23/2008 21:52'! 222295handleMouseDown: anEvent 222296 "System level event handling." 222297 anEvent wasHandled ifTrue:[^self]. "not interested" 222298 anEvent hand removePendingBalloonFor: self. 222299 anEvent hand removePendingHaloFor: self. 222300 anEvent wasHandled: true. 222301 222302 (anEvent controlKeyPressed 222303 and: [Preferences cmdGesturesEnabled]) 222304 ifTrue: [^ self invokeMetaMenu: anEvent]. 222305 222306 "Make me modal during mouse transitions" 222307 anEvent hand newMouseFocus: self event: anEvent. 222308 anEvent blueButtonChanged ifTrue:[^self blueButtonDown: anEvent]. 222309 222310 self mouseDown: anEvent. 222311 222312 Preferences maintainHalos 222313 ifFalse:[ anEvent hand removeHaloFromClick: anEvent on: self ]. 222314 222315 (self handlesMouseStillDown: anEvent) ifTrue:[ 222316 self startStepping: #handleMouseStillDown: 222317 at: Time millisecondClockValue + self mouseStillDownThreshold 222318 arguments: {anEvent copy resetHandlerFields} 222319 stepTime: self mouseStillDownStepRate ]. 222320! ! 222321 222322!Morph methodsFor: 'events-processing' stamp: 'ar 8/8/2001 15:29'! 222323handleMouseEnter: anEvent 222324 "System level event handling." 222325 (anEvent isDraggingEvent) ifTrue:[ 222326 (self handlesMouseOverDragging: anEvent) ifTrue:[ 222327 anEvent wasHandled: true. 222328 self mouseEnterDragging: anEvent]. 222329 ^self]. 222330 self wantsHalo "If receiver wants halo and balloon, trigger balloon after halo" 222331 ifTrue:[anEvent hand triggerHaloFor: self after: self haloDelayTime] 222332 ifFalse:[self wantsBalloon 222333 ifTrue:[anEvent hand triggerBalloonFor: self after: self balloonHelpDelayTime]]. 222334 (self handlesMouseOver: anEvent) ifTrue:[ 222335 anEvent wasHandled: true. 222336 self mouseEnter: anEvent. 222337 ].! ! 222338 222339!Morph methodsFor: 'events-processing' stamp: 'ar 10/6/2000 00:15'! 222340handleMouseLeave: anEvent 222341 "System level event handling." 222342 anEvent hand removePendingBalloonFor: self. 222343 anEvent hand removePendingHaloFor: self. 222344 anEvent isDraggingEvent ifTrue:[ 222345 (self handlesMouseOverDragging: anEvent) ifTrue:[ 222346 anEvent wasHandled: true. 222347 self mouseLeaveDragging: anEvent]. 222348 ^self]. 222349 (self handlesMouseOver: anEvent) ifTrue:[ 222350 anEvent wasHandled: true. 222351 self mouseLeave: anEvent. 222352 ]. 222353! ! 222354 222355!Morph methodsFor: 'events-processing' stamp: 'nk 6/13/2004 09:16'! 222356handleMouseMove: anEvent 222357 "System level event handling." 222358 anEvent wasHandled ifTrue:[^self]. "not interested" 222359 "Rules say that by default a morph gets #mouseMove iff 222360 * the hand is not dragging anything, 222361 + and some button is down, 222362 + and the receiver is the current mouse focus." 222363 (anEvent hand hasSubmorphs) ifTrue:[^self]. 222364 (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self]. 222365 anEvent wasHandled: true. 222366 self mouseMove: anEvent. 222367 (self handlesMouseStillDown: anEvent) ifTrue:[ 222368 "Step at the new location" 222369 self startStepping: #handleMouseStillDown: 222370 at: Time millisecondClockValue 222371 arguments: {anEvent copy resetHandlerFields} 222372 stepTime: self mouseStillDownStepRate ]. 222373! ! 222374 222375!Morph methodsFor: 'events-processing' stamp: 'ar 4/23/2001 17:24'! 222376handleMouseOver: anEvent 222377 "System level event handling." 222378 anEvent hand mouseFocus == self ifTrue:[ 222379 "Got this directly through #handleFocusEvent: so check explicitly" 222380 (self containsPoint: anEvent position event: anEvent) ifFalse:[^self]]. 222381 anEvent hand noticeMouseOver: self event: anEvent! ! 222382 222383!Morph methodsFor: 'events-processing' stamp: 'ar 10/22/2000 17:11'! 222384handleMouseStillDown: anEvent 222385 "Called from the stepping mechanism for morphs wanting continuously repeated 'yes the mouse is still down, yes it is still down, yes it has not changed yet, no the mouse is still not up, yes the button is down' etc messages" 222386 (anEvent hand mouseFocus == self) 222387 ifFalse:[^self stopSteppingSelector: #handleMouseStillDown:]. 222388 self mouseStillDown: anEvent. 222389! ! 222390 222391!Morph methodsFor: 'events-processing' stamp: 'ar 10/22/2000 17:09'! 222392handleMouseUp: anEvent 222393 "System level event handling." 222394 anEvent wasHandled ifTrue:[^self]. "not interested" 222395 anEvent hand mouseFocus == self ifFalse:[^self]. "Not interested in other parties" 222396 anEvent hand releaseMouseFocus: self. 222397 anEvent wasHandled: true. 222398 anEvent blueButtonChanged 222399 ifTrue:[self blueButtonUp: anEvent] 222400 ifFalse:[self mouseUp: anEvent. 222401 self stopSteppingSelector: #handleMouseStillDown:].! ! 222402 222403!Morph methodsFor: 'events-processing' stamp: 'md 10/22/2003 15:55'! 222404handleUnknownEvent: anEvent 222405 "An event of an unknown type was sent to the receiver. What shall we do?!!" 222406 Beeper beep. 222407 anEvent printString displayAt: 0@0. 222408 anEvent wasHandled: true.! ! 222409 222410!Morph methodsFor: 'events-processing' stamp: 'sw 10/5/2002 01:47'! 222411mouseDownPriority 222412 "Return the default mouse down priority for the receiver" 222413 222414 ^ (self isPartsDonor or: [self isPartsBin]) 222415 ifTrue: [50] 222416 ifFalse: [0] 222417 222418 "The above is a workaround for the complete confusion between parts donors and parts bins. Morphs residing in a parts bin may or may not have the parts donor property set; if they have they may or may not actually handle events. To work around this, parts bins get an equal priority to parts donors so that when a morph in the parts bin does have the property set but does not handle the event we still get a copy from picking it up through the parts bin. Argh. This just *cries* for a cleanup." 222419 "And the above comment is Andreas's from 10/2000, which was formerly retrievable by a #flag: call which however caused a problem when trying to recompile the method from decompiled source."! ! 222420 222421!Morph methodsFor: 'events-processing' stamp: 'ar 9/13/2000 17:14'! 222422processEvent: anEvent 222423 "Process the given event using the default event dispatcher." 222424 ^self processEvent: anEvent using: self defaultEventDispatcher! ! 222425 222426!Morph methodsFor: 'events-processing' stamp: 'ar 9/18/2000 19:14'! 222427processEvent: anEvent using: defaultDispatcher 222428 "This is the central entry for dispatching events in morphic. Given some event and a default dispatch strategy, find the right receiver and let him handle it. 222429 WARNING: This is a powerful hook. If you want to use a different event dispatcher from the default, here is the place to hook it in. Depending on how the dispatcher is written (e.g., whether it calls simply #processEvent: or #processEvent:using:) you can change the dispatch strategy for entire trees of morphs. Similarly, you can disable entire trees of morphs from receiving any events whatsoever. Read the documentation in class MorphicEventDispatcher before playing with it. " 222430 (self rejectsEvent: anEvent) ifTrue:[^#rejected]. 222431 ^defaultDispatcher dispatchEvent: anEvent with: self! ! 222432 222433!Morph methodsFor: 'events-processing' stamp: 'ar 10/5/2000 19:25'! 222434rejectDropEvent: anEvent 222435 "This hook allows the receiver to repel a drop operation currently executed. The method is called prior to checking children so the receiver must validate that the event was really designated for it. 222436 Note that the ordering of the tests below is designed to avoid a (possibly expensive) #fullContainsPoint: test. If the receiver doesn't want to repel the morph anyways we don't need to check after all." 222437 (self repelsMorph: anEvent contents event: anEvent) ifFalse:[^self]. "not repelled" 222438 (self fullContainsPoint: anEvent position) ifFalse:[^self]. "not for me" 222439 "Throw it away" 222440 anEvent wasHandled: true. 222441 anEvent contents rejectDropMorphEvent: anEvent.! ! 222442 222443!Morph methodsFor: 'events-processing' stamp: 'marcus.denker 8/24/2008 22:02'! 222444transformedFrom: uberMorph 222445 "Return a transform to map coordinates of uberMorph, a morph above me in my owner chain, into the coordinates of MYSELF not any of my children." 222446 "self flag: #arNote." "rename this method" 222447 owner ifNil:[^IdentityTransform basicNew]. 222448 ^ (owner transformFrom: uberMorph)! ! 222449 222450 222451!Morph methodsFor: 'events-removing' stamp: 'rw 4/25/2002 07:18'! 222452releaseActionMap 222453 "Release the action map" 222454 222455 self removeProperty: #actionMap! ! 222456 222457 222458!Morph methodsFor: 'filein/out' stamp: 'di 11/18/1999 08:35'! 222459attachToResource 222460 "Produce a morph from a file -- either a saved .morph file or a graphics file" 222461 222462 | pathName | 222463 pathName := Utilities chooseFileWithSuffixFromList: (#('.morph'), Utilities graphicsFileSuffixes) 222464 withCaption: 'Choose a file 222465to load'. 222466 pathName ifNil: [^ self]. "User made no choice" 222467 pathName == #none ifTrue: [^ self inform: 222468'Sorry, no suitable files found 222469(names should end with .morph, .gif, 222470.bmp, .jpeg, .jpe, .jp, or .form)']. 222471 222472 self setProperty: #resourceFilePath toValue: pathName! ! 222473 222474!Morph methodsFor: 'filein/out' stamp: 'stephane.ducasse 3/13/2009 17:53'! 222475postLoad 222476 "when I'm read from a file" 222477 222478 ^ self! ! 222479 222480!Morph methodsFor: 'filein/out' stamp: 'tak 2/10/2006 02:24'! 222481prepareToBeSaved 222482 "Prepare this morph to be saved to disk. Subclasses should nil out any instance variables that holds state that should not be saved, such as cached Forms. Note that this operation may take more drastic measures than releaseCachedState; for example, it might discard the transcript of an interactive chat session." 222483 222484 self releaseCachedState. 222485 self formerOwner: nil. 222486 self formerPosition: nil. 222487 self removeProperty: #undoGrabCommand. 222488 fullBounds := nil! ! 222489 222490!Morph methodsFor: 'filein/out' stamp: 'di 11/18/1999 08:52'! 222491saveAsResource 222492 222493 | pathName | 222494 (self hasProperty: #resourceFilePath) ifFalse: [^ self]. 222495 pathName := self valueOfProperty: #resourceFilePath. 222496 (pathName asLowercase endsWith: '.morph') ifFalse: 222497 [^ self error: 'Can only update morphic resources']. 222498 (FileStream newFileNamed: pathName) fileOutClass: nil andObject: self.! ! 222499 222500!Morph methodsFor: 'filein/out' stamp: 'ar 9/27/2005 21:02'! 222501saveDocPane 222502 222503 Smalltalk at: #DocLibrary ifPresent:[:dl| dl external saveDocCheck: self]! ! 222504 222505!Morph methodsFor: 'filein/out' stamp: 'DamienCassou 9/29/2009 13:02'! 222506saveOnFile 222507 "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out." 222508 222509 | aFileName fileStream ok | 222510 aFileName := (('my' translated, ' {1}') format: {self class name}) asFileName. "do better?" 222511 aFileName := UIManager default request: ('File name?' translated, ' (".morph" ', 'will be added to end' translated,')' ) 222512 initialAnswer: aFileName. 222513 aFileName isEmptyOrNil ifTrue: [^ Beeper beep]. 222514 self allMorphsDo: [:m | m prepareToBeSaved]. 222515 222516 ok := aFileName endsWith: '.morph'. "don't double them" 222517 ok := ok | (aFileName endsWith: '.sp'). 222518 ok ifFalse: [aFileName := aFileName,'.morph']. 222519 fileStream := FileStream newFileNamed: aFileName asFileName. 222520 fileStream fileOutClass: nil andObject: self. "Puts UniClass definitions out anyway"! ! 222521 222522!Morph methodsFor: 'filein/out' stamp: 'di 11/18/1999 09:15'! 222523updateAllFromResources 222524 222525 self allMorphsDo: [:m | m updateFromResource]! ! 222526 222527!Morph methodsFor: 'filein/out' stamp: 'nk 1/6/2004 12:38'! 222528updateFromResource 222529 | pathName newMorph f | 222530 (pathName := self valueOfProperty: #resourceFilePath) ifNil: [^self]. 222531 (pathName asLowercase endsWith: '.morph') 222532 ifTrue: 222533 [newMorph := (FileStream readOnlyFileNamed: pathName) fileInObjectAndCode. 222534 (newMorph isMorph) 222535 ifFalse: [^self error: 'Resource not a single morph']] 222536 ifFalse: 222537 [f := Form fromFileNamed: pathName. 222538 f ifNil: [^self error: 'unrecognized image file format']. 222539 newMorph := World drawingClass withForm: f]. 222540 newMorph setProperty: #resourceFilePath toValue: pathName. 222541 self owner replaceSubmorph: self by: newMorph! ! 222542 222543 222544!Morph methodsFor: 'filter streaming' stamp: 'ar 10/26/2000 19:55'! 222545drawOnCanvas: aCanvas 222546 ^aCanvas fullDraw: self. 222547! ! 222548 222549 222550!Morph methodsFor: 'geniestubs' stamp: 'nk 3/11/2004 17:30'! 222551mouseStillDownStepRate 222552 "At what rate do I want to receive #mouseStillDown: notifications?" 222553 ^1! ! 222554 222555 222556!Morph methodsFor: 'geometry' stamp: 'di 7/24/97 11:55'! 222557align: aPoint1 with: aPoint2 222558 "Translate by aPoint2 - aPoint1." 222559 222560 ^ self position: self position + (aPoint2 - aPoint1)! ! 222561 222562!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:17'! 222563bottom 222564 " Return the y-coordinate of my bottom side " 222565 222566 ^ bounds bottom! ! 222567 222568!Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! 222569bottomCenter 222570 222571 ^ bounds bottomCenter! ! 222572 222573!Morph methodsFor: 'geometry' stamp: 'tk 9/8/97 10:44'! 222574bottomLeft 222575 222576 ^ bounds bottomLeft! ! 222577 222578!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:08'! 222579bottomLeft: aPoint 222580 " Move me so that my bottom left corner is at aPoint. My extent (width & height) are unchanged " 222581 222582 self position: ((aPoint x) @ (aPoint y - self height)). 222583! ! 222584 222585!Morph methodsFor: 'geometry' stamp: 'di 6/12/97 11:17'! 222586bottomRight 222587 222588 ^ bounds bottomRight! ! 222589 222590!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:09'! 222591bottomRight: aPoint 222592 " Move me so that my bottom right corner is at aPoint. My extent (width & height) are unchanged " 222593 222594 self position: ((aPoint x - bounds width) @ (aPoint y - self height)) 222595! ! 222596 222597!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:14'! 222598bottom: aNumber 222599 " Move me so that my bottom is at the y-coordinate aNumber. My extent (width & height) are unchanged " 222600 222601 self position: (bounds left @ (aNumber - self height))! ! 222602 222603!Morph methodsFor: 'geometry' stamp: 'jm 8/3/97 15:50'! 222604bounds 222605 "Return the bounds of this morph." 222606 "Note: It is best not to override this method because many methods in Morph and its subclasses use the instance variable directly rather than 'self bounds'. Instead, subclasses should be sure that the bounds instance variable is correct." 222607 222608 ^ bounds 222609! ! 222610 222611!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:05'! 222612boundsInWorld 222613 ^self bounds: self bounds in: self world! ! 222614 222615!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:04'! 222616boundsIn: referenceMorph 222617 "Return the receiver's bounds as seen by aMorphs coordinate frame" 222618 ^self bounds: self bounds in: referenceMorph! ! 222619 222620!Morph methodsFor: 'geometry' stamp: 'ar 12/14/2000 13:48'! 222621bounds: newBounds 222622 | oldExtent newExtent | 222623 oldExtent := self extent. 222624 newExtent := newBounds extent. 222625 (oldExtent dotProduct: oldExtent) <= (newExtent dotProduct: newExtent) ifTrue:[ 222626 "We're growing. First move then resize." 222627 self position: newBounds topLeft; extent: newExtent. 222628 ] ifFalse:[ 222629 "We're shrinking. First resize then move." 222630 self extent: newExtent; position: newBounds topLeft. 222631 ].! ! 222632 222633!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:04'! 222634bounds: aRectangle from: referenceMorph 222635 "Return the receiver's bounds as seen by aMorphs coordinate frame" 222636 owner ifNil: [^ aRectangle]. 222637 ^(owner transformFrom: referenceMorph) globalBoundsToLocal: aRectangle 222638! ! 222639 222640!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:04'! 222641bounds: aRectangle in: referenceMorph 222642 "Return the receiver's bounds as seen by aMorphs coordinate frame" 222643 owner ifNil: [^ aRectangle]. 222644 ^(owner transformFrom: referenceMorph) localBoundsToGlobal: aRectangle 222645! ! 222646 222647!Morph methodsFor: 'geometry'! 222648center 222649 222650 ^ bounds center! ! 222651 222652!Morph methodsFor: 'geometry' stamp: 'sw 6/11/1999 18:48'! 222653center: aPoint 222654 self position: (aPoint - (self extent // 2))! ! 222655 222656!Morph methodsFor: 'geometry'! 222657extent 222658 222659 ^ bounds extent! ! 222660 222661!Morph methodsFor: 'geometry' stamp: 'laza 3/25/2004 21:31'! 222662extent: aPoint 222663 222664 bounds extent = aPoint ifTrue: [^ self]. 222665 self changed. 222666 bounds := (bounds topLeft extent: aPoint) rounded. 222667 self layoutChanged. 222668 self changed. 222669! ! 222670 222671!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:06'! 222672fullBoundsInWorld 222673 ^self bounds: self fullBounds in: self world! ! 222674 222675!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:06'! 222676globalPointToLocal: aPoint 222677 ^self point: aPoint from: nil! ! 222678 222679!Morph methodsFor: 'geometry' stamp: 'ar 9/15/2000 14:21'! 222680griddedPoint: ungriddedPoint 222681 222682 | griddingContext | 222683 self flag: #arNote. "Used by event handling - should transform to pasteUp for gridding" 222684 (griddingContext := self pasteUpMorph) ifNil: [^ ungriddedPoint]. 222685 ^ griddingContext gridPoint: ungriddedPoint! ! 222686 222687!Morph methodsFor: 'geometry' stamp: 'di 8/25/2000 00:35'! 222688gridPoint: ungriddedPoint 222689 222690 ^ ungriddedPoint! ! 222691 222692!Morph methodsFor: 'geometry'! 222693height 222694 222695 ^ bounds height! ! 222696 222697!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:22'! 222698height: aNumber 222699 " Set my height; my position (top-left corner) and width will remain the same " 222700 222701 self extent: self width@aNumber asInteger. 222702! ! 222703 222704!Morph methodsFor: 'geometry' stamp: 'ar 12/22/2001 22:43'! 222705innerBounds 222706 "Return the inner rectangle enclosed by the bounds of this morph excluding the space taken by its borders. For an unbordered morph, this is just its bounds." 222707 222708 ^ self bounds insetBy: self borderWidth! ! 222709 222710!Morph methodsFor: 'geometry' stamp: 'nk 4/27/2003 16:16'! 222711intersects: aRectangle 222712 "Answer whether aRectangle, which is in World coordinates, intersects me." 222713 222714 ^self fullBoundsInWorld intersects: aRectangle! ! 222715 222716!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:16'! 222717left 222718 " Return the x-coordinate of my left side " 222719 222720 ^ bounds left! ! 222721 222722!Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! 222723leftCenter 222724 222725 ^ bounds leftCenter! ! 222726 222727!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:15'! 222728left: aNumber 222729 " Move me so that my left side is at the x-coordinate aNumber. My extent (width & height) are unchanged " 222730 222731 self position: (aNumber @ bounds top)! ! 222732 222733!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:07'! 222734localPointToGlobal: aPoint 222735 ^self point: aPoint in: nil! ! 222736 222737!Morph methodsFor: 'geometry' stamp: 'sw 6/4/2000 21:59'! 222738minimumExtent 222739 | ext | 222740 "This returns the minimum extent that the morph may be shrunk to. Not honored in too many places yet, but respected by the resizeToFit feature, at least. copied up from SystemWindow 6/00" 222741 (ext := self valueOfProperty: #minimumExtent) 222742 ifNotNil: 222743 [^ ext]. 222744 ^ 100 @ 80! ! 222745 222746!Morph methodsFor: 'geometry' stamp: 'sw 6/4/2000 22:00'! 222747minimumExtent: aPoint 222748 "Remember a minimumExtent, for possible future use" 222749 222750 self setProperty: #minimumExtent toValue: aPoint 222751! ! 222752 222753!Morph methodsFor: 'geometry' stamp: 'ar 11/12/2000 22:06'! 222754outerBounds 222755 "Return the 'outer' bounds of the receiver, e.g., the bounds that need to be invalidated when the receiver changes." 222756 | box | 222757 box := self bounds. 222758 self hasDropShadow ifTrue:[box := self expandFullBoundsForDropShadow: box]. 222759 self hasRolloverBorder ifTrue:[box := self expandFullBoundsForRolloverBorder: box]. 222760 ^box! ! 222761 222762!Morph methodsFor: 'geometry' stamp: 'nk 5/19/2003 20:39'! 222763overlapsShadowForm: itsShadow bounds: itsBounds 222764 "Answer true if itsShadow and my shadow overlap at all" 222765 | andForm overlapExtent | 222766 overlapExtent := (itsBounds intersect: self fullBounds) extent. 222767 overlapExtent > (0 @ 0) 222768 ifFalse: [^ false]. 222769 andForm := self shadowForm. 222770 overlapExtent ~= self fullBounds extent 222771 ifTrue: [andForm := andForm 222772 contentsOfArea: (0 @ 0 extent: overlapExtent)]. 222773 andForm := andForm 222774 copyBits: (self fullBounds translateBy: itsShadow offset negated) 222775 from: itsShadow 222776 at: 0 @ 0 222777 clippingBox: (0 @ 0 extent: overlapExtent) 222778 rule: Form and 222779 fillColor: nil. 222780 ^ andForm bits 222781 anySatisfy: [:w | w ~= 0]! ! 222782 222783!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:02'! 222784pointFromWorld: aPoint 222785 ^self point: aPoint from: self world! ! 222786 222787!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:03'! 222788pointInWorld: aPoint 222789 ^self point: aPoint in: self world! ! 222790 222791!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:01'! 222792point: aPoint from: aReferenceMorph 222793 222794 owner ifNil: [^ aPoint]. 222795 ^ (owner transformFrom: aReferenceMorph) globalPointToLocal: aPoint. 222796! ! 222797 222798!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:01'! 222799point: aPoint in: aReferenceMorph 222800 222801 owner ifNil: [^ aPoint]. 222802 ^ (owner transformFrom: aReferenceMorph) localPointToGlobal: aPoint. 222803! ! 222804 222805!Morph methodsFor: 'geometry'! 222806position 222807 222808 ^ bounds topLeft! ! 222809 222810!Morph methodsFor: 'geometry' stamp: 'di 9/30/1998 12:11'! 222811positionInWorld 222812 222813 ^ self pointInWorld: self position. 222814! ! 222815 222816!Morph methodsFor: 'geometry' stamp: 'sw 10/9/1998 08:56'! 222817positionSubmorphs 222818 self submorphsDo: 222819 [:aMorph | aMorph snapToEdgeIfAppropriate]! ! 222820 222821!Morph methodsFor: 'geometry' stamp: 'wiz 11/25/2004 12:54'! 222822position: aPoint 222823 "Change the position of this morph and and all of its 222824 submorphs. " 222825 | delta box | 222826 delta := aPoint asNonFractionalPoint - bounds topLeft. 222827 (delta x = 0 222828 and: [delta y = 0]) 222829 ifTrue: [^ self]. 222830 "Null change" 222831 box := self fullBounds. 222832 (delta dotProduct: delta) 222833 > 100 222834 ifTrue: ["e.g., more than 10 pixels moved" 222835 self invalidRect: box. 222836 self 222837 invalidRect: (box translateBy: delta)] 222838 ifFalse: [self 222839 invalidRect: (box 222840 merge: (box translateBy: delta))]. 222841 self privateFullMoveBy: delta. 222842 owner 222843 ifNotNil: [owner layoutChanged]! ! 222844 222845!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:16'! 222846right 222847 " Return the x-coordinate of my right side " 222848 ^ bounds right! ! 222849 222850!Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! 222851rightCenter 222852 222853 ^ bounds rightCenter! ! 222854 222855!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:15'! 222856right: aNumber 222857 " Move me so that my right side is at the x-coordinate aNumber. My extent (width & height) are unchanged " 222858 222859 self position: ((aNumber - bounds width) @ bounds top)! ! 222860 222861!Morph methodsFor: 'geometry' stamp: 'bf 1/5/2000 19:08'! 222862screenLocation 222863 "For compatibility only" 222864 222865 ^ self fullBounds origin! ! 222866 222867!Morph methodsFor: 'geometry' stamp: 'sma 2/5/2000 13:58'! 222868screenRectangle 222869 "For compatibility only" 222870 222871 ^ self fullBounds! ! 222872 222873!Morph methodsFor: 'geometry' stamp: 'tk 7/14/2001 11:11'! 222874setConstrainedPosition: aPoint hangOut: partiallyOutside 222875 "Change the position of this morph and and all of its submorphs to aPoint, but don't let me go outside my owner's bounds. Let me go within two pixels of completely outside if partiallyOutside is true." 222876 222877 | trialRect delta boundingMorph bRect | 222878 owner ifNil:[^self]. 222879 trialRect := aPoint extent: self bounds extent. 222880 boundingMorph := self topRendererOrSelf owner. 222881 delta := boundingMorph 222882 ifNil: [0@0] 222883 ifNotNil: [ 222884 bRect := partiallyOutside 222885 ifTrue: [boundingMorph bounds insetBy: 222886 self extent negated + boundingMorph borderWidth + (2@2)] 222887 ifFalse: [boundingMorph bounds]. 222888 trialRect amountToTranslateWithin: bRect]. 222889 self position: aPoint + delta. 222890 self layoutChanged "So that, eg, surrounding text will readjust" 222891! ! 222892 222893!Morph methodsFor: 'geometry' stamp: 'sw 2/16/1999 22:05'! 222894shiftSubmorphsOtherThan: listNotToShift by: delta 222895 | rejectList | 222896 rejectList := listNotToShift ifNil: [OrderedCollection new]. 222897 (submorphs copyWithoutAll: rejectList) do: 222898 [:m | m position: (m position + delta)]! ! 222899 222900!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:17'! 222901top 222902 " Return the y-coordinate of my top side " 222903 222904 ^ bounds top! ! 222905 222906!Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! 222907topCenter 222908 222909 ^ bounds topCenter! ! 222910 222911!Morph methodsFor: 'geometry' stamp: 'di 6/12/97 11:07'! 222912topLeft 222913 222914 ^ bounds topLeft! ! 222915 222916!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:10'! 222917topLeft: aPoint 222918 " Move me so that my top left corner is at aPoint. My extent (width & height) are unchanged " 222919 222920 self position: aPoint 222921! ! 222922 222923!Morph methodsFor: 'geometry' stamp: 'sw 8/20/97 23:04'! 222924topRight 222925 222926 ^ bounds topRight! ! 222927 222928!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:12'! 222929topRight: aPoint 222930 " Move me so that my top right corner is at aPoint. My extent (width & height) are unchanged " 222931 222932 self position: ((aPoint x - bounds width) @ (aPoint y)) 222933! ! 222934 222935!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:14'! 222936top: aNumber 222937 " Move me so that my top is at the y-coordinate aNumber. My extent (width & height) are unchanged " 222938 222939 self position: (bounds left @ aNumber)! ! 222940 222941!Morph methodsFor: 'geometry' stamp: 'ar 10/22/2000 18:03'! 222942transformedBy: aTransform 222943 aTransform isIdentity ifTrue:[^self]. 222944 aTransform isPureTranslation ifTrue:[ 222945 ^self position: (aTransform localPointToGlobal: self position). 222946 ]. 222947 ^self addFlexShell transformedBy: aTransform! ! 222948 222949!Morph methodsFor: 'geometry'! 222950width 222951 222952 ^ bounds width! ! 222953 222954!Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:22'! 222955width: aNumber 222956 " Set my width; my position (top-left corner) and height will remain the same " 222957 222958 self extent: aNumber asInteger@self height. 222959! ! 222960 222961!Morph methodsFor: 'geometry' stamp: 'di 2/23/98 11:36'! 222962worldBounds 222963 ^ self world bounds! ! 222964 222965!Morph methodsFor: 'geometry' stamp: 'dgd 9/10/2004 12:37'! 222966worldBoundsForHalo 222967 "Answer the rectangle to be used as the inner dimension of my halos. 222968 Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle." 222969 222970 | r | 222971 r := (Preferences haloEnclosesFullBounds) 222972 ifFalse: [ self boundsIn: nil ] 222973 ifTrue: [ self fullBoundsInWorld ]. 222974 Preferences showBoundsInHalo ifTrue: [ ^r outsetBy: 2 ]. 222975 ^r! ! 222976 222977 222978!Morph methodsFor: 'geometry etoy' stamp: 'sw 10/23/1998 12:00'! 222979addTransparentSpacerOfSize: aPoint 222980 self addMorphBack: (self transparentSpacerOfSize: aPoint)! ! 222981 222982!Morph methodsFor: 'geometry etoy' stamp: 'sw 10/23/1998 12:01'! 222983beTransparent 222984 self color: Color transparent! ! 222985 222986!Morph methodsFor: 'geometry etoy' stamp: 'di 10/1/2000 11:54'! 222987degreesOfFlex 222988 "Return any rotation due to flexing" 222989 "NOTE: because renderedMorph, which is used by the halo to set heading, goes down through dropShadows as well as transformations, we need this method (and its other implems) to come back up through such a chain." 222990 ^ 0.0! ! 222991 222992!Morph methodsFor: 'geometry etoy' stamp: 'ar 9/22/2000 14:29'! 222993forwardDirection: newDirection 222994 "Set the receiver's forward direction (in eToy terms)" 222995 self setProperty: #forwardDirection toValue: newDirection.! ! 222996 222997!Morph methodsFor: 'geometry etoy' stamp: 'dgd 9/20/2004 14:15'! 222998goHome 222999 | box fb | 223000 owner isInMemory ifFalse: [^ self]. 223001 owner isNil ifTrue: [^ self]. 223002 self visible ifFalse: [^ self]. 223003 223004 box := owner visibleClearArea. 223005 fb := self fullBounds. 223006 223007 fb left < box left 223008 ifTrue: [self left: box left - fb left + self left]. 223009 fb right > box right 223010 ifTrue: [self right: box right - fb right + self right]. 223011 223012 fb top < box top 223013 ifTrue: [self top: box top - fb top + self top]. 223014 fb bottom > box bottom 223015 ifTrue: [self bottom: box bottom - fb bottom + self bottom]. 223016! ! 223017 223018!Morph methodsFor: 'geometry etoy' stamp: 'di 10/1/2000 11:50'! 223019heading 223020 "Return the receiver's heading (in eToy terms)" 223021 owner ifNil: [^ self forwardDirection]. 223022 ^ self forwardDirection + owner degreesOfFlex! ! 223023 223024!Morph methodsFor: 'geometry etoy' stamp: 'ar 9/22/2000 13:37'! 223025heading: newHeading 223026 "Set the receiver's heading (in eToy terms)" 223027 self isFlexed ifFalse:[self addFlexShell]. 223028 owner rotationDegrees: (newHeading - self forwardDirection).! ! 223029 223030!Morph methodsFor: 'geometry etoy' stamp: 'ar 9/22/2000 20:12'! 223031referencePosition 223032 "Return the current reference position of the receiver" 223033 | box | 223034 box := self bounds. 223035 ^box origin + (self rotationCenter * box extent). 223036! ! 223037 223038!Morph methodsFor: 'geometry etoy' stamp: 'ar 9/27/2000 14:04'! 223039referencePosition: aPosition 223040 "Move the receiver to match its reference position with aPosition" 223041 | newPos intPos | 223042 newPos := self position + (aPosition - self referencePosition). 223043 intPos := newPos asIntegerPoint. 223044 newPos = intPos 223045 ifTrue:[self position: intPos] 223046 ifFalse:[self position: newPos].! ! 223047 223048!Morph methodsFor: 'geometry etoy' stamp: 'sw 10/25/1999 16:49'! 223049referencePositionInWorld 223050 223051 ^ self pointInWorld: self referencePosition 223052! ! 223053 223054!Morph methodsFor: 'geometry etoy' stamp: 'sw 10/25/1999 23:33'! 223055referencePositionInWorld: aPoint 223056 | localPosition | 223057 localPosition := owner 223058 ifNil: [aPoint] 223059 ifNotNil: [(owner transformFrom: self world) globalPointToLocal: aPoint]. 223060 223061 self referencePosition: localPosition 223062! ! 223063 223064!Morph methodsFor: 'geometry etoy' stamp: 'ar 9/22/2000 20:10'! 223065rotationCenter 223066 "Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." 223067 ^self valueOfProperty: #rotationCenter ifAbsent:[0.5@0.5] 223068! ! 223069 223070!Morph methodsFor: 'geometry etoy' stamp: 'ar 9/22/2000 20:11'! 223071rotationCenter: aPointOrNil 223072 "Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." 223073 aPointOrNil isNil 223074 ifTrue:[self removeProperty: #rotationCenter] 223075 ifFalse:[self setProperty: #rotationCenter toValue: aPointOrNil] 223076! ! 223077 223078!Morph methodsFor: 'geometry etoy' stamp: 'nk 9/4/2004 11:00'! 223079scale: newScale 223080 "Backstop for morphs that don't have to do something special to set their scale" 223081! ! 223082 223083!Morph methodsFor: 'geometry etoy' stamp: 'nk 9/4/2004 11:04'! 223084scaleFactor: newScale 223085 "Backstop for morphs that don't have to do something special to set their 223086 scale " 223087 | toBeScaled | 223088 toBeScaled := self. 223089 newScale = 1.0 223090 ifTrue: [(self heading isZero 223091 and: [self isFlexMorph]) 223092 ifTrue: [toBeScaled := self removeFlexShell]] 223093 ifFalse: [self isFlexMorph 223094 ifFalse: [toBeScaled := self addFlexShellIfNecessary]]. 223095 223096 toBeScaled scale: newScale. 223097 223098 toBeScaled == self ifTrue: [ 223099 newScale = 1.0 223100 ifTrue: [ self removeProperty: #scaleFactor ] 223101 ifFalse: [ self setProperty: #scaleFactor toValue: newScale ]]! ! 223102 223103!Morph methodsFor: 'geometry etoy' stamp: 'ar 6/12/2001 05:23'! 223104setDirectionFrom: aPoint 223105 | delta degrees | 223106 delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition. 223107 degrees := delta degrees + 90.0. 223108 self forwardDirection: (degrees \\ 360) rounded. 223109! ! 223110 223111!Morph methodsFor: 'geometry etoy' stamp: 'wiz 11/6/2005 17:10'! 223112simplySetVisible: aBoolean 223113 "Set the receiver's visibility property. This mild circumlocution is because my TransfomationMorph #visible: method would also set the visibility flag of my flexee, which in this case is pointless because it's the flexee that calls this. 223114 This appears in morph as a backstop for morphs that don't inherit from TFMorph" 223115 223116 self visible: aBoolean! ! 223117 223118!Morph methodsFor: 'geometry etoy' stamp: 'sw 10/23/1998 11:50'! 223119transparentSpacerOfSize: aPoint 223120 ^ (Morph new extent: aPoint) color: Color transparent! ! 223121 223122 223123!Morph methodsFor: 'geometry testing'! 223124containsPoint: aPoint 223125 223126 ^ self bounds containsPoint: aPoint! ! 223127 223128!Morph methodsFor: 'geometry testing' stamp: 'di 5/3/2000 19:05'! 223129fullContainsPoint: aPoint 223130 223131 (self fullBounds containsPoint: aPoint) ifFalse: [^ false]. "quick elimination" 223132 (self containsPoint: aPoint) ifTrue: [^ true]. "quick acceptance" 223133 submorphs do: [:m | (m fullContainsPoint: aPoint) ifTrue: [^ true]]. 223134 ^ false 223135! ! 223136 223137 223138!Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/7/1999 18:57'! 223139addHalo 223140 "Invoke a halo programatically (e.g., not from a meta gesture)" 223141 ^self addHalo: nil! ! 223142 223143!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/10/2000 19:03'! 223144addHalo: evt 223145 | halo prospectiveHaloClass | 223146 prospectiveHaloClass := Smalltalk at: self haloClass ifAbsent: [HaloMorph]. 223147 halo := prospectiveHaloClass new bounds: self worldBoundsForHalo. 223148 halo popUpFor: self event: evt. 223149 ^halo! ! 223150 223151!Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/7/1999 21:55'! 223152addHalo: evt from: formerHaloOwner 223153 "Transfer a halo from the former halo owner to the receiver" 223154 ^self addHalo: evt! ! 223155 223156!Morph methodsFor: 'halos and balloon help' stamp: 'stephane.ducasse 11/8/2008 19:49'! 223157addHandlesTo: aHaloMorph box: box 223158 "Add halo handles to the halo. Apply the halo filter if appropriate" 223159 223160 | wantsIt aSelector | 223161 aHaloMorph haloBox: box. 223162 Preferences haloSpecifications do: 223163 [:aSpec | 223164 aSelector := aSpec addHandleSelector. 223165 wantsIt := Preferences selectiveHalos 223166 ifTrue: 223167 [self wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph] 223168 ifFalse: 223169 [true]. 223170 wantsIt ifTrue: 223171 [(#(addDupHandle:) includes: aSelector) ifTrue: 223172 [wantsIt := self preferredDuplicationHandleSelector = aSelector]. 223173 wantsIt ifTrue: 223174 [aHaloMorph perform: aSelector with: aSpec]]]. 223175 223176 aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box! ! 223177 223178!Morph methodsFor: 'halos and balloon help' stamp: 'ar 8/8/2001 17:31'! 223179addMagicHaloFor: aHand 223180 | halo prospectiveHaloClass | 223181 aHand halo ifNotNil:[ 223182 aHand halo target == self ifTrue:[^self]. 223183 aHand halo isMagicHalo ifFalse:[^self]]. 223184 prospectiveHaloClass := Smalltalk at: self haloClass ifAbsent: [HaloMorph]. 223185 halo := prospectiveHaloClass new bounds: self worldBoundsForHalo. 223186 halo popUpMagicallyFor: self hand: aHand.! ! 223187 223188!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/22/2000 20:41'! 223189addOptionalHandlesTo: aHalo box: box 223190 aHalo addDirectionHandles! ! 223191 223192!Morph methodsFor: 'halos and balloon help' stamp: 'sw 12/21/1999 17:52'! 223193addSimpleHandlesTo: aHaloMorph box: aBox 223194 ^ aHaloMorph addSimpleHandlesTo: aHaloMorph box: aBox! ! 223195 223196!Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/26/2000 19:37'! 223197addWorldHandlesTo: aHaloMorph box: box 223198 aHaloMorph haloBox: box. 223199 Preferences haloSpecificationsForWorld do: 223200 [:aSpec | 223201 aHaloMorph perform: aSpec addHandleSelector with: aSpec]. 223202 aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box! ! 223203 223204!Morph methodsFor: 'halos and balloon help' stamp: 'sma 11/11/2000 14:54'! 223205balloonColor 223206 ^ self 223207 valueOfProperty: #balloonColor 223208 ifAbsent: [self defaultBalloonColor]! ! 223209 223210!Morph methodsFor: 'halos and balloon help' stamp: 'sma 11/11/2000 14:55'! 223211balloonColor: aColor 223212 ^ self 223213 setProperty: #balloonColor 223214 toValue: aColor! ! 223215 223216!Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:29'! 223217balloonFont 223218 ^ self 223219 valueOfProperty: #balloonFont 223220 ifAbsent: [self defaultBalloonFont]! ! 223221 223222!Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:30'! 223223balloonFont: aFont 223224 ^ self setProperty: #balloonFont toValue: aFont! ! 223225 223226!Morph methodsFor: 'halos and balloon help' stamp: 'sw 2/7/2000 11:27'! 223227balloonHelpAligner 223228 "Answer the morph to which the receiver's balloon help should point" 223229 ^ (self valueOfProperty: #balloonTarget) ifNil: [self]! ! 223230 223231!Morph methodsFor: 'halos and balloon help' stamp: 'dgd 9/7/2004 18:35'! 223232balloonHelpDelayTime 223233 "Return the number of milliseconds before a balloon help should be put up on the receiver. The balloon help will only be put up if the receiver responds to #wantsBalloon by returning true." 223234 ^ Preferences balloonHelpDelayTime! ! 223235 223236!Morph methodsFor: 'halos and balloon help' stamp: 'adrian_lienhard 7/19/2009 20:13'! 223237balloonHelpTextForHandle: aHandle 223238 "Answer a string providing balloon help for the 223239 given halo handle" 223240 | itsSelector | 223241 itsSelector := aHandle eventHandler firstMouseSelector. 223242 itsSelector == #doRecolor:with: ifTrue: [^ 'Change color']. 223243 itsSelector == #mouseDownInDimissHandle:with: 223244 ifTrue: [^ Preferences preserveTrash 223245 ifTrue: ['Move to trash'] 223246 ifFalse: ['Remove from screen']]. 223247 #(#(#addFullHandles 'More halo handles') #(#addSimpleHandles 'Fewer halo handles') #(#chooseEmphasisOrAlignment 'Emphasis & alignment') #(#chooseFont 'Change font') #(#chooseNewGraphicFromHalo 'Choose a new graphic') #(#chooseStyle 'Change style') #(#dismiss 'Remove') #(#doDebug:with: 'Debug') #(#doDirection:with: 'Choose forward direction') #(#doDup:with: 'Duplicate') #(#doMenu:with: 'Menu') #(#doGrab:with: 'Pick up') #(#editDrawing 'Repaint') #(#mouseDownInCollapseHandle:with: 'Collapse') #(#mouseDownOnHelpHandle: 'Help') #(#prepareToTrackCenterOfRotation:with: 'Move object or set center of rotation') #(#presentViewMenu 'Present the Viewing menu') #(#startDrag:with: 'Move') #(#startGrow:with: 'Change size') #(#startRot:with: 'Rotate') #(#startScale:with: 'Change scale')#(#trackCenterOfRotation:with: 'Set center of rotation') ) 223248 do: [:pair | itsSelector == pair first 223249 ifTrue: [^ pair last]]. 223250 ^ 'unknown halo handle'translated! ! 223251 223252!Morph methodsFor: 'halos and balloon help' stamp: 'RAA 7/21/2000 11:10'! 223253boundsForBalloon 223254 223255 "some morphs have bounds that are way too big" 223256 ^self boundsInWorld! ! 223257 223258!Morph methodsFor: 'halos and balloon help' stamp: 'sw 3/1/2000 11:39'! 223259comeToFrontAndAddHalo 223260 self comeToFront. 223261 self addHalo! ! 223262 223263!Morph methodsFor: 'halos and balloon help' stamp: 'sma 11/11/2000 16:15'! 223264defaultBalloonColor 223265 ^ Display depth <= 2 223266 ifTrue: [Color white] 223267 ifFalse: [BalloonMorph balloonColor]! ! 223268 223269!Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:23'! 223270defaultBalloonFont 223271 ^ BalloonMorph balloonFont! ! 223272 223273!Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/11/2000 18:24'! 223274defersHaloOnClickTo: aSubMorph 223275 "If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true" 223276 "May want to add a way (via a property) for morphs to assert true here -- this would let certain kinds of morphs that are unusually reluctant to take the halo on initial click" 223277 223278 ^ false 223279 ! ! 223280 223281!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/3/2000 17:03'! 223282deleteBalloon 223283 "If I am showing a balloon, delete it." 223284 | w | 223285 w := self world ifNil:[^self]. 223286 w deleteBalloonTarget: self.! ! 223287 223288!Morph methodsFor: 'halos and balloon help' stamp: 'alain.plantec 2/6/2009 15:32'! 223289editBalloonHelpContent: aString 223290 | reply | 223291 reply := UIManager default 223292 multiLineRequest: 'Edit the balloon help text for ' translated, self externalName 223293 centerAt: Sensor cursorPoint 223294 initialAnswer: (aString ifNil: [self noHelpString] ifNotNil: [aString]) 223295 answerHeight: 200. 223296 reply ifNil: [^ self]. "User cancelled out of the dialog" 223297 (reply isEmpty or: [reply asString = self noHelpString]) 223298 ifTrue: [self setBalloonText: nil] 223299 ifFalse: [self setBalloonText: reply]! ! 223300 223301!Morph methodsFor: 'halos and balloon help' stamp: 'sma 12/23/1999 13:24'! 223302editBalloonHelpText 223303 "Modify the receiver's balloon help text." 223304 223305 self editBalloonHelpContent: self balloonText! ! 223306 223307!Morph methodsFor: 'halos and balloon help' stamp: 'ar 3/17/2001 13:19'! 223308halo 223309 223310 (self outermostWorldMorph ifNil: [^nil]) haloMorphs do: [:h | h target == self ifTrue: [^ h]]. 223311 ^ nil! ! 223312 223313!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/15/2000 16:13'! 223314haloClass 223315 "Answer the name of the desired kind of HaloMorph to launch on behalf of the receiver" 223316 223317 ^ #HaloMorph 223318! ! 223319 223320!Morph methodsFor: 'halos and balloon help' stamp: 'ar 8/8/2001 15:40'! 223321haloDelayTime 223322 "Return the number of milliseconds before a halo should be put up on the receiver. The halo will only be put up if the receiver responds to #wantsHalo by returning true." 223323 ^800! ! 223324 223325!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/15/2000 16:16'! 223326hasHalo 223327 ^self hasProperty: #hasHalo.! ! 223328 223329!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/28/2000 17:54'! 223330hasHalo: aBool 223331 aBool 223332 ifTrue:[self setProperty: #hasHalo toValue: true] 223333 ifFalse:[self removeProperty: #hasHalo]! ! 223334 223335!Morph methodsFor: 'halos and balloon help' stamp: 'stephane.ducasse 10/16/2008 16:46'! 223336isLikelyRecipientForMouseOverHalos 223337 ^ false! ! 223338 223339!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/3/2000 17:05'! 223340mouseDownOnHelpHandle: anEvent 223341 "The mouse went down in the show-balloon handle" 223342 223343 | str | 223344 anEvent shiftPressed ifTrue: [^ self editBalloonHelpText]. 223345 str := self balloonText. 223346 str ifNil: [str := self noHelpString]. 223347 self showBalloon: str hand: anEvent hand. 223348! ! 223349 223350!Morph methodsFor: 'halos and balloon help' stamp: 'em 3/24/2005 10:05'! 223351noHelpString 223352 ^ 'Help not yet supplied' translated! ! 223353 223354!Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/15/2001 12:23'! 223355okayToAddDismissHandle 223356 "Answer whether a halo on the receiver should offer a dismiss handle. This provides a hook for making it harder to disassemble some strucures even momentarily" 223357 223358 ^ self holdsSeparateDataForEachInstance not and: 223359 [self resistsRemoval not]! ! 223360 223361!Morph methodsFor: 'halos and balloon help' stamp: 'sw 10/26/2000 12:11'! 223362okayToAddGrabHandle 223363 "Answer whether a halo on the receiver should offer a grab handle. This provides a hook for making it harder to deconstruct some strucures even momentarily" 223364 223365 ^ self holdsSeparateDataForEachInstance not ! ! 223366 223367!Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/27/2001 14:50'! 223368okayToBrownDragEasily 223369 "Answer whether it it okay for the receiver to be brown-dragged easily -- i.e. repositioned within its container without extracting it. At present this is just a hook -- nobody declines." 223370 223371 ^ true 223372 223373 223374 223375" 223376 ^ (self topRendererOrSelf owner isKindOf: PasteUpMorph) and: 223377 [self layoutPolicy isNil]"! ! 223378 223379!Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/29/2001 06:29'! 223380okayToResizeEasily 223381 "Answer whether it is appropriate to have the receiver be easily resized by the user from the halo" 223382 223383 ^ true 223384 223385 "This one was too jarring, not that it didn't most of the time do the right thing but because some of the time it didn't, such as in a holder. If we pursue this path, the test needs to be airtight, obviously... 223386 ^ (self topRendererOrSelf owner isKindOf: PasteUpMorph) and: 223387 [self layoutPolicy isNil]"! ! 223388 223389!Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/27/2001 14:44'! 223390okayToRotateEasily 223391 "Answer whether it is appropriate for a rotation handle to be shown for the receiver. This is a hook -- at present nobody declines." 223392 223393 ^ true! ! 223394 223395!Morph methodsFor: 'halos and balloon help' stamp: 'stephane.ducasse 9/20/2008 21:57'! 223396preferredDuplicationHandleSelector 223397 "Answer the selector, either #addMakeSiblingHandle: or addDupHandle:, to be offered as the default in a halo open on me" 223398 223399 ^ #addDupHandle:! ! 223400 223401!Morph methodsFor: 'halos and balloon help' stamp: 'dgd 9/9/2004 22:43'! 223402removeHalo 223403 "remove the surrounding halo (if any)" 223404 self halo isNil 223405 ifFalse: [self primaryHand removeHalo]! ! 223406 223407!Morph methodsFor: 'halos and balloon help' stamp: 'sma 12/23/1999 13:32'! 223408setBalloonText: stringOrText 223409 "Set receiver's balloon help text. Pass nil to remove the help." 223410 223411 self setBalloonText: stringOrText maxLineLength: Preferences maxBalloonHelpLineLength! ! 223412 223413!Morph methodsFor: 'halos and balloon help' stamp: 'md 2/27/2006 09:54'! 223414setBalloonText: stringOrText maxLineLength: aLength 223415 "Set receiver's balloon help text. Pass nil to remove the help." 223416 (extension isNil and: [stringOrText isNil]) ifTrue: [^ self]. 223417 self assureExtension balloonText: 223418 (stringOrText ifNotNil: [stringOrText asString withNoLineLongerThan: aLength])! ! 223419 223420!Morph methodsFor: 'halos and balloon help' stamp: 'sw 10/29/1999 17:38'! 223421setCenteredBalloonText: aString 223422 self setBalloonText: aString. 223423 self setProperty: #helpAtCenter toValue: true! ! 223424 223425!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/3/2000 17:06'! 223426showBalloon: msgString 223427 "Pop up a balloon containing the given string, 223428 first removing any existing BalloonMorphs in the world." 223429 | w | 223430 self showBalloon: msgString hand: ((w := self world) ifNotNil:[w activeHand]).! ! 223431 223432!Morph methodsFor: 'halos and balloon help' stamp: 'dgd 9/10/2004 13:59'! 223433transferHalo: event from: formerHaloOwner 223434 "Progressively transfer the halo to the next likely recipient" 223435 | localEvt w target | 223436 223437 self flag: #workAround. "For halo's distinction between 'target' and 'innerTarget' we need to bypass any renderers." 223438 (formerHaloOwner == self and:[self isRenderer and:[self wantsHaloFromClick not]]) ifTrue:[ 223439 event shiftPressed ifTrue:[ 223440 target := owner. 223441 localEvt := event transformedBy: (self transformedFrom: owner). 223442 ] ifFalse:[ 223443 target := self renderedMorph. 223444 localEvt := event transformedBy: (target transformedFrom: self). 223445 ]. 223446 ^target transferHalo: localEvt from: target]. 223447 223448" formerHaloOwner == self ifTrue:[^ self removeHalo]." 223449 223450 "Never transfer halo to top-most world" 223451 (self isWorldMorph and:[owner isNil]) ifFalse:[ 223452 (self wantsHaloFromClick and:[formerHaloOwner ~~ self]) 223453 ifTrue:[^self addHalo: event from: formerHaloOwner]]. 223454 223455 event shiftPressed ifTrue:[ 223456 "Pass it outwards" 223457 owner ifNotNil:[^owner transferHalo: event from: formerHaloOwner]. 223458 "We're at the top level; throw the event back in to find recipient" 223459 formerHaloOwner removeHalo. 223460 ^self processEvent: event copy resetHandlerFields. 223461 ]. 223462 self submorphsDo:[:m| 223463 localEvt := event transformedBy: (m transformedFrom: self). 223464 (m fullContainsPoint: localEvt position) 223465 ifTrue:[^m transferHalo: event from: formerHaloOwner]. 223466 ]. 223467 "We're at the bottom most level; throw the event back up to the root to find recipient" 223468 formerHaloOwner removeHalo. 223469 223470 Preferences maintainHalos ifFalse:[ 223471 (w := self world) ifNil: [ ^self ]. 223472 localEvt := event transformedBy: (self transformedFrom: w) inverseTransformation. 223473 ^w processEvent: localEvt resetHandlerFields. 223474 ]. 223475! ! 223476 223477!Morph methodsFor: 'halos and balloon help' stamp: 'rhi 10/5/2001 20:49'! 223478wantsBalloon 223479 "Answer true if receiver wants to show a balloon help text is a few moments." 223480 223481 ^ (self balloonText notNil) and: [Preferences balloonHelpEnabled]! ! 223482 223483!Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/29/2001 19:50'! 223484wantsDirectionHandles 223485 ^self valueOfProperty: #wantsDirectionHandles ifAbsent:[Preferences showDirectionHandles]! ! 223486 223487!Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/29/2001 19:52'! 223488wantsDirectionHandles: aBool 223489 aBool == Preferences showDirectionHandles 223490 ifTrue:[self removeProperty: #wantsDirectionHandles] 223491 ifFalse:[self setProperty: #wantsDirectionHandles toValue: aBool]. 223492! ! 223493 223494!Morph methodsFor: 'halos and balloon help' stamp: 'dgd 2/22/2003 19:06'! 223495wantsHalo 223496 | topOwner | 223497 ^(topOwner := self topRendererOrSelf owner) notNil 223498 and: [topOwner wantsHaloFor: self]! ! 223499 223500!Morph methodsFor: 'halos and balloon help' stamp: 'sw 4/8/98 13:26'! 223501wantsHaloFor: aSubMorph 223502 ^ false! ! 223503 223504!Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/25/2000 17:43'! 223505wantsHaloFromClick 223506 ^ true! ! 223507 223508!Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/27/2001 14:49'! 223509wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph 223510 "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" 223511 223512 (#(addDismissHandle:) includes: aSelector) ifTrue: 223513 [^ self resistsRemoval not]. 223514 223515 (#( addDragHandle: ) includes: aSelector) ifTrue: 223516 [^ self okayToBrownDragEasily]. 223517 223518 (#(addGrowHandle: addScaleHandle:) includes: aSelector) ifTrue: 223519 [^ self okayToResizeEasily]. 223520 223521 (#( addRotateHandle: ) includes: aSelector) ifTrue: 223522 [^ self okayToRotateEasily]. 223523 223524 (#(addRecolorHandle:) includes: aSelector) ifTrue: 223525 [^ self renderedMorph wantsRecolorHandle]. 223526 223527 true ifTrue: [^ true] 223528 ! ! 223529 223530!Morph methodsFor: 'halos and balloon help' stamp: 'nk 6/12/2004 09:32'! 223531wantsSimpleSketchMorphHandles 223532 "Answer true if my halo's simple handles should include the simple sketch morph handles." 223533 ^false! ! 223534 223535 223536!Morph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:01'! 223537basicInitialize 223538 "Do basic generic initialization of the instance variables: 223539 Set up the receiver, created by a #basicNew and now ready to 223540 be initialized, by placing initial values in the instance variables 223541 as appropriate" 223542 owner := nil. 223543 submorphs := EmptyArray. 223544 bounds := self defaultBounds. 223545 color := self defaultColor! ! 223546 223547!Morph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:06'! 223548defaultBounds 223549"answer the default bounds for the receiver" 223550 ^ 0 @ 0 corner: 50 @ 40! ! 223551 223552!Morph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:28'! 223553defaultColor 223554 "answer the default color/fill style for the receiver" 223555 ^ Color blue! ! 223556 223557!Morph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:09'! 223558initialize 223559 "initialize the state of the receiver" 223560 super initialize. 223561 owner := nil. 223562 submorphs := EmptyArray. 223563 bounds := self defaultBounds. 223564 color := self defaultColor! ! 223565 223566!Morph methodsFor: 'initialization' stamp: 'ar 1/31/2001 13:57'! 223567intoWorld: aWorld 223568 "The receiver has just appeared in a new world. Note: 223569 * aWorld can be nil (due to optimizations in other places) 223570 * owner is already set 223571 * owner's submorphs may not include receiver yet. 223572 Important: Keep this method fast - it is run whenever morphs are added." 223573 aWorld ifNil:[^self]. 223574 self wantsSteps ifTrue:[aWorld startStepping: self]. 223575 self submorphsDo:[:m| m intoWorld: aWorld]. 223576! ! 223577 223578!Morph methodsFor: 'initialization' stamp: 'RAA 10/18/2000 12:33'! 223579openCenteredInWorld 223580 223581 self 223582 fullBounds; 223583 position: Display extent - self extent // 2; 223584 openInWorld.! ! 223585 223586!Morph methodsFor: 'initialization' stamp: 'sw 3/21/2000 14:46'! 223587openInHand 223588 "Attach the receiver to the current hand in the current morphic world" 223589 223590 self currentHand attachMorph: self! ! 223591 223592!Morph methodsFor: 'initialization' stamp: 'djp 10/24/1999 17:13'! 223593openInWindow 223594 223595 ^self openInWindowLabeled: self defaultLabelForInspector 223596! ! 223597 223598!Morph methodsFor: 'initialization' stamp: 'sma 4/22/2000 20:28'! 223599openInWindowLabeled: aString 223600 223601 ^self openInWindowLabeled: aString inWorld: self currentWorld! ! 223602 223603!Morph methodsFor: 'initialization' stamp: 'alain.plantec 6/10/2008 18:35'! 223604openInWorld 223605 "Add this morph to the world." 223606 223607 self openInWorld: self currentWorld! ! 223608 223609!Morph methodsFor: 'initialization' stamp: 'dgd 9/1/2004 16:12'! 223610openInWorld: aWorld 223611 "Add this morph to the requested World." 223612 (aWorld visibleClearArea origin ~= (0@0) and: [self position = (0@0)]) ifTrue: 223613 [self position: aWorld visibleClearArea origin]. 223614 aWorld addMorph: self. 223615 aWorld startSteppingSubmorphsOf: self! ! 223616 223617!Morph methodsFor: 'initialization' stamp: 'ar 1/31/2001 13:58'! 223618outOfWorld: aWorld 223619 "The receiver has just appeared in a new world. Notes: 223620 * aWorld can be nil (due to optimizations in other places) 223621 * owner is still valid 223622 Important: Keep this method fast - it is run whenever morphs are removed." 223623 aWorld ifNil:[^self]. 223624 "ar 1/31/2001: We could explicitly stop stepping the receiver here but for the sake of speed I'm for now relying on the lazy machinery in the world itself." 223625 "aWorld stopStepping: self." 223626 self submorphsDo:[:m| m outOfWorld: aWorld]. 223627! ! 223628 223629!Morph methodsFor: 'initialization' stamp: 'ar 3/3/2001 15:28'! 223630resourceJustLoaded 223631 "In case resource relates to me" 223632 self releaseCachedState.! ! 223633 223634!Morph methodsFor: 'initialization' stamp: 'stephane.ducasse 11/29/2008 16:14'! 223635standardPalette 223636 "Answer a standard palette forced by some level of enclosing presenter, or nil if none" 223637 | | 223638 223639 ^ nil! ! 223640 223641 223642!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 17:33'! 223643acceptDroppingMorph: aMorph event: evt 223644 "This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:Event: message. This default implementation just adds the given morph to the receiver." 223645 | layout | 223646 layout := self layoutPolicy. 223647 layout ifNil:[^self addMorph: aMorph]. 223648 self privateAddMorph: aMorph 223649 atIndex: (layout indexForInserting: aMorph at: evt position in: self).! ! 223650 223651!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 17:34'! 223652adjustLayoutBounds 223653 "Adjust the receivers bounds depending on the resizing strategy imposed" 223654 | hFit vFit box myExtent extent | 223655 hFit := self hResizing. 223656 vFit := self vResizing. 223657 (hFit == #shrinkWrap or:[vFit == #shrinkWrap]) ifFalse:[^self]. "not needed" 223658 box := self layoutBounds. 223659 myExtent := box extent. 223660 extent := self submorphBounds corner - box origin. 223661 hFit == #shrinkWrap ifTrue:[myExtent := extent x @ myExtent y]. 223662 vFit == #shrinkWrap ifTrue:[myExtent := myExtent x @ extent y]. 223663 "Make sure we don't get smaller than minWidth/minHeight" 223664 myExtent x < self minWidth ifTrue:[ 223665 myExtent := (myExtent x max: 223666 (self minWidth - self bounds width + self layoutBounds width)) @ myExtent y]. 223667 myExtent y < self minHeight ifTrue:[ 223668 myExtent := myExtent x @ (myExtent y max: 223669 (self minHeight - self bounds height + self layoutBounds height))]. 223670 self layoutBounds: (box origin extent: myExtent).! ! 223671 223672!Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:31'! 223673doLayoutIn: layoutBounds 223674 "Compute a new layout based on the given layout bounds." 223675 223676 "Note: Testing for #bounds or #layoutBounds would be sufficient to 223677 figure out if we need an invalidation afterwards but #outerBounds 223678 is what we need for all leaf nodes so we use that." 223679 223680 | layout box priorBounds | 223681 priorBounds := self outerBounds. 223682 submorphs isEmpty ifTrue: [^fullBounds := priorBounds]. 223683 "Send #ownerChanged to our children" 223684 submorphs do: [:m | m ownerChanged]. 223685 layout := self layoutPolicy. 223686 layout ifNotNil: [layout layout: self in: layoutBounds]. 223687 self adjustLayoutBounds. 223688 fullBounds := self privateFullBounds. 223689 box := self outerBounds. 223690 box = priorBounds 223691 ifFalse: [self invalidRect: (priorBounds quickMerge: box)]! ! 223692 223693!Morph methodsFor: 'layout' stamp: 'ar 1/1/2002 20:00'! 223694fullBounds 223695 "Return the bounding box of the receiver and all its children. Recompute the layout if necessary." 223696 fullBounds ifNotNil:[^fullBounds]. 223697 "Errors at this point can be critical so make sure we catch 'em all right" 223698 [self doLayoutIn: self layoutBounds] on: Error do:[:ex| 223699 "This should do it unless you don't screw up the bounds" 223700 fullBounds := bounds. 223701 ex pass]. 223702 ^fullBounds! ! 223703 223704!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 23:10'! 223705layoutBounds 223706 "Return the bounds for laying out children of the receiver" 223707 | inset box | 223708 inset := self layoutInset. 223709 box := self innerBounds. 223710 inset isZero ifTrue:[^box]. 223711 ^box insetBy: inset.! ! 223712 223713!Morph methodsFor: 'layout' stamp: 'ar 10/31/2000 21:09'! 223714layoutBounds: aRectangle 223715 "Set the bounds for laying out children of the receiver. 223716 Note: written so that #layoutBounds can be changed without touching this method" 223717 | outer inner | 223718 outer := self bounds. 223719 inner := self layoutBounds. 223720 bounds := aRectangle origin + (outer origin - inner origin) corner: 223721 aRectangle corner + (outer corner - inner corner).! ! 223722 223723!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 17:35'! 223724layoutProportionallyIn: newBounds 223725 "Layout specific. Apply the given bounds to the receiver." 223726 | box frame | 223727 frame := self layoutFrame ifNil:[^self]. 223728 "before applying the proportional values make sure the receiver's layout is computed" 223729 self fullBounds. "sigh..." 223730 "compute the cell size the receiver has given its layout frame" 223731 box := frame layout: self bounds in: newBounds. 223732 (box = self bounds) ifTrue:[^self]. "no change" 223733 ^self layoutInBounds: box.! ! 223734 223735!Morph methodsFor: 'layout' stamp: 'dgd 2/16/2003 21:52'! 223736minHeight 223737 "answer the receiver's minHeight" 223738 ^ self 223739 valueOfProperty: #minHeight 223740 ifAbsent: [2]! ! 223741 223742!Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:32'! 223743minHeight: aNumber 223744 aNumber isNil 223745 ifTrue: [self removeProperty: #minHeight] 223746 ifFalse: [self setProperty: #minHeight toValue: aNumber]. 223747 self layoutChanged! ! 223748 223749!Morph methodsFor: 'layout' stamp: 'dgd 2/16/2003 21:54'! 223750minWidth 223751 "answer the receiver's minWidth" 223752 ^ self 223753 valueOfProperty: #minWidth 223754 ifAbsent: [2]! ! 223755 223756!Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:32'! 223757minWidth: aNumber 223758 aNumber isNil 223759 ifTrue: [self removeProperty: #minWidth] 223760 ifFalse: [self setProperty: #minWidth toValue: aNumber]. 223761 self layoutChanged! ! 223762 223763!Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:33'! 223764privateFullBounds 223765 "Private. Compute the actual full bounds of the receiver" 223766 223767 | box | 223768 submorphs isEmpty ifTrue: [^self outerBounds]. 223769 box := self outerBounds copy. 223770 box := box quickMerge: (self clipSubmorphs 223771 ifTrue: [self submorphBounds intersect: self clippingBounds] 223772 ifFalse: [self submorphBounds]). 223773 ^box origin asIntegerPoint corner: box corner asIntegerPoint! ! 223774 223775!Morph methodsFor: 'layout' stamp: 'ar 11/2/2000 17:42'! 223776submorphBounds 223777 "Private. Compute the actual full bounds of the receiver" 223778 | box subBox | 223779 submorphs do: [:m | 223780 (m visible) ifTrue: [ 223781 subBox := m fullBounds. 223782 box 223783 ifNil:[box := subBox copy] 223784 ifNotNil:[box := box quickMerge: subBox]]]. 223785 box ifNil:[^self bounds]. "e.g., having submorphs but not visible" 223786 ^ box origin asIntegerPoint corner: box corner asIntegerPoint 223787! ! 223788 223789 223790!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:57'! 223791addCellLayoutMenuItems: aMenu hand: aHand 223792 "Cell (e.g., child) related items" 223793 | menu sub | 223794 menu := MenuMorph new defaultTarget: self. 223795 menu addUpdating: #hasDisableTableLayoutString action: #changeDisableTableLayout. 223796 menu addLine. 223797 223798 sub := MenuMorph new defaultTarget: self. 223799 #(rigid shrinkWrap spaceFill) do:[:sym| 223800 sub addUpdating: #hResizingString: target: self selector: #hResizing: argumentList: (Array with: sym)]. 223801 menu add:'horizontal resizing' translated subMenu: sub. 223802 223803 sub := MenuMorph new defaultTarget: self. 223804 #(rigid shrinkWrap spaceFill) do:[:sym| 223805 sub addUpdating: #vResizingString: target: self selector: #vResizing: argumentList: (Array with: sym)]. 223806 menu add:'vertical resizing' translated subMenu: sub. 223807 223808 aMenu ifNotNil:[aMenu add: 'child layout' translated subMenu: menu]. 223809 ^menu! ! 223810 223811!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:51'! 223812addLayoutMenuItems: topMenu hand: aHand 223813 | aMenu | 223814 aMenu := MenuMorph new defaultTarget: self. 223815 aMenu addUpdating: #hasNoLayoutString action: #changeNoLayout. 223816 aMenu addUpdating: #hasProportionalLayoutString action: #changeProportionalLayout. 223817 aMenu addUpdating: #hasTableLayoutString action: #changeTableLayout. 223818 aMenu addLine. 223819 aMenu add: 'change layout inset...' translated action: #changeLayoutInset:. 223820 aMenu addLine. 223821 self addCellLayoutMenuItems: aMenu hand: aHand. 223822 self addTableLayoutMenuItems: aMenu hand: aHand. 223823 topMenu ifNotNil:[topMenu add: 'layout' translated subMenu: aMenu]. 223824 ^aMenu! ! 223825 223826!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 20:07'! 223827addTableLayoutMenuItems: aMenu hand: aHand 223828 | menu sub | 223829 menu := MenuMorph new defaultTarget: self. 223830 menu addUpdating: #hasReverseCellsString action: #changeReverseCells. 223831 menu addUpdating: #hasClipLayoutCellsString action: #changeClipLayoutCells. 223832 menu addUpdating: #hasRubberBandCellsString action: #changeRubberBandCells. 223833 menu addLine. 223834 menu add: 'change cell inset...' translated action: #changeCellInset:. 223835 menu add: 'change min cell size...' translated action: #changeMinCellSize:. 223836 menu add: 'change max cell size...' translated action: #changeMaxCellSize:. 223837 menu addLine. 223838 223839 sub := MenuMorph new defaultTarget: self. 223840 #(leftToRight rightToLeft topToBottom bottomToTop) do:[:sym| 223841 sub addUpdating: #listDirectionString: target: self selector: #changeListDirection: argumentList: (Array with: sym)]. 223842 menu add: 'list direction' translated subMenu: sub. 223843 223844 sub := MenuMorph new defaultTarget: self. 223845 #(none leftToRight rightToLeft topToBottom bottomToTop) do:[:sym| 223846 sub addUpdating: #wrapDirectionString: target: self selector: #wrapDirection: argumentList: (Array with: sym)]. 223847 menu add: 'wrap direction' translated subMenu: sub. 223848 223849 sub := MenuMorph new defaultTarget: self. 223850 #(center topLeft topRight bottomLeft bottomRight topCenter leftCenter rightCenter bottomCenter) do:[:sym| 223851 sub addUpdating: #cellPositioningString: target: self selector: #cellPositioning: argumentList: (Array with: sym)]. 223852 menu add: 'cell positioning' translated subMenu: sub. 223853 223854 sub := MenuMorph new defaultTarget: self. 223855 #(topLeft bottomRight center justified) do:[:sym| 223856 sub addUpdating: #listCenteringString: target: self selector: #listCentering: argumentList: (Array with: sym)]. 223857 menu add: 'list centering' translated subMenu: sub. 223858 223859 sub := MenuMorph new defaultTarget: self. 223860 #(topLeft bottomRight center justified) do:[:sym| 223861 sub addUpdating: #wrapCenteringString: target: self selector: #wrapCentering: argumentList: (Array with: sym)]. 223862 menu add: 'wrap centering' translated subMenu: sub. 223863 223864 sub := MenuMorph new defaultTarget: self. 223865 #(none equal) do:[:sym| 223866 sub addUpdating: #listSpacingString: target: self selector: #listSpacing: argumentList: (Array with: sym)]. 223867 menu add: 'list spacing' translated subMenu: sub. 223868 223869 sub := MenuMorph new defaultTarget: self. 223870 #(none localRect localSquare globalRect globalSquare) do:[:sym| 223871 sub addUpdating: #cellSpacingString: target: self selector: #cellSpacing: argumentList: (Array with: sym)]. 223872 menu add: 'cell spacing' translated subMenu: sub. 223873 223874 aMenu ifNotNil:[aMenu add: 'table layout' translated subMenu: menu]. 223875 ^menu! ! 223876 223877!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:08'! 223878changeCellInset: evt 223879 | handle | 223880 handle := HandleMorph new forEachPointDo:[:newPoint | 223881 self cellInset: (newPoint - evt cursorPoint) asIntegerPoint // 5]. 223882 evt hand attachMorph: handle. 223883 handle startStepping. 223884! ! 223885 223886!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 18:54'! 223887changeClipLayoutCells 223888 self invalidRect: self fullBounds. 223889 self clipLayoutCells: self clipLayoutCells not. 223890 self invalidRect: self fullBounds.! ! 223891 223892!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:19'! 223893changeDisableTableLayout 223894 self disableTableLayout: self disableTableLayout not. 223895 self layoutChanged.! ! 223896 223897!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:09'! 223898changeLayoutInset: evt 223899 | handle | 223900 handle := HandleMorph new forEachPointDo:[:newPoint | 223901 self layoutInset: (newPoint - evt cursorPoint) asIntegerPoint // 5]. 223902 evt hand attachMorph: handle. 223903 handle startStepping. 223904! ! 223905 223906!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'! 223907changeListDirection: aSymbol 223908 | listDir wrapDir | 223909 self listDirection: aSymbol. 223910 (self wrapDirection == #none) ifTrue:[^self]. 223911 "otherwise automatically keep a valid table layout" 223912 listDir := self listDirection. 223913 wrapDir := self wrapDirection. 223914 (listDir == #leftToRight or:[listDir == #rightToLeft]) ifTrue:[ 223915 wrapDir == #leftToRight ifTrue:[^self wrapDirection: #topToBottom]. 223916 wrapDir == #rightToLeft ifTrue:[^self wrapDirection: #bottomToTop]. 223917 ] ifFalse:[ 223918 wrapDir == #topToBottom ifTrue:[^self wrapDirection: #leftToRight]. 223919 wrapDir == #bottomToTop ifTrue:[^self wrapDirection: #rightToLeft]. 223920 ]. 223921! ! 223922 223923!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'! 223924changeMaxCellSize: evt 223925 | handle | 223926 handle := HandleMorph new forEachPointDo:[:newPoint | 223927 self maxCellSize: (newPoint - evt cursorPoint) asIntegerPoint]. 223928 evt hand attachMorph: handle. 223929 handle startStepping. 223930! ! 223931 223932!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'! 223933changeMinCellSize: evt 223934 | handle | 223935 handle := HandleMorph new forEachPointDo:[:newPoint | 223936 self minCellSize: (newPoint - evt cursorPoint) asIntegerPoint]. 223937 evt hand attachMorph: handle. 223938 handle startStepping. 223939! ! 223940 223941!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:19'! 223942changeNoLayout 223943 self layoutPolicy ifNil:[^self]. "already no layout" 223944 self layoutPolicy: nil. 223945 self layoutChanged.! ! 223946 223947!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:19'! 223948changeProportionalLayout 223949 | layout | 223950 ((layout := self layoutPolicy) notNil and:[layout isProportionalLayout]) 223951 ifTrue:[^self]. "already proportional layout" 223952 self layoutPolicy: ProportionalLayout new. 223953 self layoutChanged.! ! 223954 223955!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'! 223956changeReverseCells 223957 self reverseTableCells: self reverseTableCells not.! ! 223958 223959!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'! 223960changeRubberBandCells 223961 self rubberBandCells: self rubberBandCells not.! ! 223962 223963!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:20'! 223964changeTableLayout 223965 | layout | 223966 ((layout := self layoutPolicy) notNil and:[layout isTableLayout]) 223967 ifTrue:[^self]. "already table layout" 223968 self layoutPolicy: TableLayout new. 223969 self layoutChanged.! ! 223970 223971!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 20:09'! 223972hasClipLayoutCellsString 223973 ^ (self clipLayoutCells 223974 ifTrue: ['<on>'] 223975 ifFalse: ['<off>']), 'clip to cell size' translated! ! 223976 223977!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:58'! 223978hasDisableTableLayoutString 223979 ^ (self disableTableLayout 223980 ifTrue: ['<on>'] 223981 ifFalse: ['<off>']) 223982 , 'disable layout in tables' translated! ! 223983 223984!Morph methodsFor: 'layout-menu' stamp: 'dgd 10/8/2003 19:23'! 223985hasNoLayoutString 223986 ^ (self layoutPolicy isNil 223987 ifTrue: ['<on>'] 223988 ifFalse: ['<off>']) 223989 , 'no layout' translated! ! 223990 223991!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:55'! 223992hasProportionalLayoutString 223993 | layout | 223994 ^ (((layout := self layoutPolicy) notNil 223995 and: [layout isProportionalLayout]) 223996 ifTrue: ['<on>'] 223997 ifFalse: ['<off>']) 223998 , 'proportional layout' translated! ! 223999 224000!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 20:08'! 224001hasReverseCellsString 224002 ^ (self reverseTableCells 224003 ifTrue: ['<on>'] 224004 ifFalse: ['<off>']), 'reverse table cells' translated! ! 224005 224006!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 20:09'! 224007hasRubberBandCellsString 224008 ^ (self rubberBandCells 224009 ifTrue: ['<on>'] 224010 ifFalse: ['<off>']), 'rubber band cells' translated! ! 224011 224012!Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:59'! 224013hasTableLayoutString 224014 | layout | 224015 ^ (((layout := self layoutPolicy) notNil 224016 and: [layout isTableLayout]) 224017 ifTrue: ['<on>'] 224018 ifFalse: ['<off>']) 224019 , 'table layout' translated! ! 224020 224021!Morph methodsFor: 'layout-menu' stamp: 'dgd 10/19/2003 11:23'! 224022layoutMenuPropertyString: aSymbol from: currentSetting 224023 | onOff wording | 224024 onOff := aSymbol == currentSetting 224025 ifTrue: ['<on>'] 224026 ifFalse: ['<off>']. 224027 "" 224028 wording := String 224029 streamContents: [:stream | 224030 | index | 224031 index := 1. 224032 aSymbol 224033 keysAndValuesDo: [:idx :ch | ch isUppercase 224034 ifTrue: [""stream nextPutAll: (aSymbol copyFrom: index to: idx - 1) asLowercase. 224035 stream nextPutAll: ' '. 224036 index := idx]]. 224037 index < aSymbol size 224038 ifTrue: [stream nextPutAll: (aSymbol copyFrom: index to: aSymbol size) asLowercase]]. 224039 "" 224040 ^ onOff , wording translated! ! 224041 224042 224043!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:56'! 224044assureLayoutProperties 224045 | props | 224046 props := self layoutProperties. 224047 props == self ifTrue:[props := nil]. 224048 props ifNil:[ 224049 props := LayoutProperties new initializeFrom: self. 224050 self layoutProperties: props]. 224051 ^props! ! 224052 224053!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:57'! 224054assureTableProperties 224055 | props | 224056 props := self layoutProperties. 224057 props == self ifTrue:[props := nil]. 224058 props ifNil:[ 224059 props := TableLayoutProperties new initializeFrom: self. 224060 self layoutProperties: props]. 224061 props includesTableProperties 224062 ifFalse:[self layoutProperties: (props := props asTableLayoutProperties)]. 224063 ^props! ! 224064 224065!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:54'! 224066cellInset 224067 "Layout specific. This property specifies an extra inset for each cell in the layout." 224068 | props | 224069 props := self layoutProperties. 224070 ^props ifNil:[0] ifNotNil:[props cellInset].! ! 224071 224072!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:54'! 224073cellInset: aNumber 224074 "Layout specific. This property specifies an extra inset for each cell in the layout." 224075 self assureTableProperties cellInset: aNumber. 224076 self layoutChanged.! ! 224077 224078!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:54'! 224079cellPositioning 224080 "Layout specific. This property describes how the receiver should be layed out in its owner when the bounds of the cell assigned to the receiver do not exactly match its bounds. Possible values are: 224081 #topLeft, #topRight, #bottomLeft, #bottomRight, #topCenter, #leftCenter, #rightCenter, #bottomCenter, #center 224082 which align the receiver's bounds with the cell at the given point." 224083 | props | 224084 props := self layoutProperties. 224085 ^props ifNil:[#center] ifNotNil:[props cellPositioning].! ! 224086 224087!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:48'! 224088cellPositioningString: aSymbol 224089 ^self layoutMenuPropertyString: aSymbol from: self cellPositioning! ! 224090 224091!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:39'! 224092cellPositioning: aSymbol 224093 "Layout specific. This property describes how the receiver should be layed out in its owner when the bounds of the cell assigned to the receiver do not exactly match its bounds. Possible values are: 224094 #topLeft, #topRight, #bottomLeft, #bottomRight, #topCenter, #leftCenter, #rightCenter, #bottomCenter, #center 224095 which align the receiver's bounds with the cell at the given point." 224096 self assureTableProperties cellPositioning: aSymbol. 224097 self layoutChanged.! ! 224098 224099!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:55'! 224100cellSpacing 224101 "Layout specific. This property describes how the cell size for each element in a list should be computed. 224102 #globalRect - globally equal rectangular cells 224103 #globalSquare - globally equal square cells 224104 #localRect - locally (e.g., per row/column) equal rectangular cells 224105 #localSquare - locally (e.g., per row/column) equal square cells 224106 #none - cells are sized based on available row/column constraints 224107 " 224108 | props | 224109 props := self layoutProperties. 224110 ^props ifNil:[#none] ifNotNil:[props cellSpacing].! ! 224111 224112!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'! 224113cellSpacingString: aSymbol 224114 ^self layoutMenuPropertyString: aSymbol from: self cellSpacing! ! 224115 224116!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:56'! 224117cellSpacing: aSymbol 224118 "Layout specific. This property describes how the cell size for each element in a list should be computed. 224119 #globalRect - globally equal rectangular cells 224120 #globalSquare - globally equal square cells 224121 #localRect - locally (e.g., per row/column) equal rectangular cells 224122 #localSquare - locally (e.g., per row/column) equal square cells 224123 #none - cells are sized based on available row/column constraints 224124 " 224125 self assureTableProperties cellSpacing: aSymbol. 224126 self layoutChanged.! ! 224127 224128!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:56'! 224129disableTableLayout 224130 "Layout specific. Disable laying out the receiver in table layout" 224131 | props | 224132 props := self layoutProperties. 224133 ^props ifNil:[false] ifNotNil:[props disableTableLayout].! ! 224134 224135!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:06'! 224136disableTableLayout: aBool 224137 "Layout specific. Disable laying out the receiver in table layout" 224138 self assureLayoutProperties disableTableLayout: aBool. 224139 self layoutChanged.! ! 224140 224141!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:57'! 224142hResizing 224143 "Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are: 224144 #rigid - do not resize the receiver 224145 #spaceFill - resize to fill owner's available space 224146 #shrinkWrap - resize to fit children 224147 " 224148 | props | 224149 props := self layoutProperties. 224150 ^props ifNil:[#rigid] ifNotNil:[props hResizing].! ! 224151 224152!Morph methodsFor: 'layout-properties' stamp: 'ar 10/31/2000 20:45'! 224153hResizingString: aSymbol 224154 ^self layoutMenuPropertyString: aSymbol from: self hResizing! ! 224155 224156!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:06'! 224157hResizing: aSymbol 224158 "Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are: 224159 #rigid - do not resize the receiver 224160 #spaceFill - resize to fill owner's available space 224161 #shrinkWrap - resize to fit children 224162 " 224163 self assureLayoutProperties hResizing: aSymbol. 224164 self layoutChanged. 224165! ! 224166 224167!Morph methodsFor: 'layout-properties' stamp: 'md 2/27/2006 09:59'! 224168layoutFrame 224169 "Layout specific. Return the layout frame describing where the 224170 receiver should appear in a proportional layout" 224171 ^ extension ifNotNil: [extension layoutFrame]! ! 224172 224173!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:20'! 224174layoutFrame: aLayoutFrame 224175 "Layout specific. Return the layout frame describing where the receiver should appear in a proportional layout" 224176 self layoutFrame == aLayoutFrame ifTrue:[^self]. 224177 self assureExtension layoutFrame: aLayoutFrame. 224178 self layoutChanged.! ! 224179 224180!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 16:38'! 224181layoutInset 224182 "Return the extra inset for layouts" 224183 | props | 224184 props := self layoutProperties. 224185 ^props ifNil:[0] ifNotNil:[props layoutInset].! ! 224186 224187!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 16:38'! 224188layoutInset: aNumber 224189 "Return the extra inset for layouts" 224190 self assureTableProperties layoutInset: aNumber. 224191 self layoutChanged.! ! 224192 224193!Morph methodsFor: 'layout-properties' stamp: 'md 2/27/2006 10:00'! 224194layoutPolicy 224195 "Layout specific. Return the layout policy describing how children 224196 of the receiver should appear." 224197 ^ extension ifNotNil: [ extension layoutPolicy]! ! 224198 224199!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:21'! 224200layoutPolicy: aLayoutPolicy 224201 "Layout specific. Return the layout policy describing how children of the receiver should appear." 224202 self layoutPolicy == aLayoutPolicy ifTrue:[^self]. 224203 self assureExtension layoutPolicy: aLayoutPolicy. 224204 self layoutChanged.! ! 224205 224206!Morph methodsFor: 'layout-properties' stamp: 'md 2/27/2006 09:58'! 224207layoutProperties 224208 "Return the current layout properties associated with the 224209 receiver" 224210 ^ extension ifNotNil: [ extension layoutProperties]! ! 224211 224212!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:21'! 224213layoutProperties: newProperties 224214 "Return the current layout properties associated with the receiver" 224215 self layoutProperties == newProperties ifTrue:[^self]. 224216 self assureExtension layoutProperties: newProperties. 224217! ! 224218 224219!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:58'! 224220listCentering 224221 "Layout specific. This property describes how the rows/columns in a list-like layout should be centered. 224222 #topLeft - center at start of primary direction 224223 #bottomRight - center at end of primary direction 224224 #center - center in the middle of primary direction 224225 #justified - insert extra space inbetween rows/columns 224226 " 224227 | props | 224228 props := self layoutProperties. 224229 ^props ifNil:[#topLeft] ifNotNil:[props listCentering].! ! 224230 224231!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'! 224232listCenteringString: aSymbol 224233 ^self layoutMenuPropertyString: aSymbol from: self listCentering! ! 224234 224235!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:05'! 224236listCentering: aSymbol 224237 "Layout specific. This property describes how the rows/columns in a list-like layout should be centered. 224238 #topLeft - center at start of primary direction 224239 #bottomRight - center at end of primary direction 224240 #center - center in the middle of primary direction 224241 #justified - insert extra space inbetween rows/columns 224242 " 224243 self assureTableProperties listCentering: aSymbol. 224244 self layoutChanged.! ! 224245 224246!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:59'! 224247listDirection 224248 "Layout specific. This property describes the direction in which a list-like layout should be applied. Possible values are: 224249 #leftToRight 224250 #rightToLeft 224251 #topToBottom 224252 #bottomToTop 224253 indicating the direction in which any layout should take place" 224254 | props | 224255 props := self layoutProperties. 224256 ^props ifNil:[#topToBottom] ifNotNil:[props listDirection].! ! 224257 224258!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'! 224259listDirectionString: aSymbol 224260 ^self layoutMenuPropertyString: aSymbol from: self listDirection! ! 224261 224262!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'! 224263listDirection: aSymbol 224264 "Layout specific. This property describes the direction in which a list-like layout should be applied. Possible values are: 224265 #leftToRight 224266 #rightToLeft 224267 #topToBottom 224268 #bottomToTop 224269 indicating the direction in which any layout should take place" 224270 self assureTableProperties listDirection: aSymbol. 224271 self layoutChanged.! ! 224272 224273!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:59'! 224274listSpacing 224275 "Layout specific. This property describes how the heights for different rows in a table layout should be handled. 224276 #equal - all rows have the same height 224277 #none - all rows may have different heights 224278 " 224279 | props | 224280 props := self layoutProperties. 224281 ^props ifNil:[#none] ifNotNil:[props listSpacing].! ! 224282 224283!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'! 224284listSpacingString: aSymbol 224285 ^self layoutMenuPropertyString: aSymbol from: self listSpacing! ! 224286 224287!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'! 224288listSpacing: aSymbol 224289 "Layout specific. This property describes how the heights for different rows in a table layout should be handled. 224290 #equal - all rows have the same height 224291 #none - all rows may have different heights 224292 " 224293 self assureTableProperties listSpacing: aSymbol. 224294 self layoutChanged.! ! 224295 224296!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:59'! 224297maxCellSize 224298 "Layout specific. This property specifies the maximum size of a table cell." 224299 | props | 224300 props := self layoutProperties. 224301 ^props ifNil:[SmallInteger maxVal] ifNotNil:[props maxCellSize].! ! 224302 224303!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'! 224304maxCellSize: aPoint 224305 "Layout specific. This property specifies the maximum size of a table cell." 224306 self assureTableProperties maxCellSize: aPoint. 224307 self layoutChanged.! ! 224308 224309!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:00'! 224310minCellSize 224311 "Layout specific. This property specifies the minimal size of a table cell." 224312 | props | 224313 props := self layoutProperties. 224314 ^props ifNil:[0] ifNotNil:[props minCellSize].! ! 224315 224316!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'! 224317minCellSize: aPoint 224318 "Layout specific. This property specifies the minimal size of a table cell." 224319 self assureTableProperties minCellSize: aPoint. 224320 self layoutChanged.! ! 224321 224322!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:01'! 224323reverseTableCells 224324 "Layout specific. This property describes if the cells should be treated in reverse order of submorphs." 224325 | props | 224326 props := self layoutProperties. 224327 ^props ifNil:[false] ifNotNil:[props reverseTableCells].! ! 224328 224329!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'! 224330reverseTableCells: aBool 224331 "Layout specific. This property describes if the cells should be treated in reverse order of submorphs." 224332 self assureTableProperties reverseTableCells: aBool. 224333 self layoutChanged.! ! 224334 224335!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:01'! 224336rubberBandCells 224337 "Layout specific. This property describes if a parent that is #shrinkWrapped around its children should ignore any #spaceFill children. E.g., when #rubberBandCells is true, the compound layout will always stay at the smallest available size, even though some child may be able to grow." 224338 | props | 224339 props := self layoutProperties. 224340 ^props ifNil:[false] ifNotNil:[props rubberBandCells].! ! 224341 224342!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'! 224343rubberBandCells: aBool 224344 "Layout specific. This property describes if a parent that is #shrinkWrapped around its children should ignore any #spaceFill children. E.g., when #rubberBandCells is true, the compound layout will always stay at the smallest available size, even though some child may be able to grow." 224345 self assureTableProperties rubberBandCells: aBool. 224346 self layoutChanged.! ! 224347 224348!Morph methodsFor: 'layout-properties' stamp: 'dgd 2/16/2003 20:02'! 224349spaceFillWeight 224350 "Layout specific. This property describes the relative weight that 224351 should be given to the receiver when extra space is distributed 224352 between different #spaceFill cells." 224353 224354 ^ self 224355 valueOfProperty: #spaceFillWeight 224356 ifAbsent: [1]! ! 224357 224358!Morph methodsFor: 'layout-properties' stamp: 'ar 11/15/2000 14:16'! 224359spaceFillWeight: aNumber 224360 "Layout specific. This property describes the relative weight that should be given to the receiver when extra space is distributed between different #spaceFill cells." 224361 aNumber = 1 224362 ifTrue:[self removeProperty: #spaceFillWeight] 224363 ifFalse:[self setProperty: #spaceFillWeight toValue: aNumber]. 224364 self layoutChanged.! ! 224365 224366!Morph methodsFor: 'layout-properties' stamp: 'tk 10/30/2001 18:39'! 224367vResizeToFit: aBoolean 224368 aBoolean ifTrue:[ 224369 self vResizing: #shrinkWrap. 224370 ] ifFalse:[ 224371 self vResizing: #rigid. 224372 ].! ! 224373 224374!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:02'! 224375vResizing 224376 "Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are: 224377 #rigid - do not resize the receiver 224378 #spaceFill - resize to fill owner's available space 224379 #shrinkWrap - resize to fit children 224380 " 224381 | props | 224382 props := self layoutProperties. 224383 ^props ifNil:[#rigid] ifNotNil:[props vResizing].! ! 224384 224385!Morph methodsFor: 'layout-properties' stamp: 'ar 10/31/2000 20:45'! 224386vResizingString: aSymbol 224387 ^self layoutMenuPropertyString: aSymbol from: self vResizing! ! 224388 224389!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'! 224390vResizing: aSymbol 224391 "Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are: 224392 #rigid - do not resize the receiver 224393 #spaceFill - resize to fill owner's available space 224394 #shrinkWrap - resize to fit children 224395 " 224396 self assureLayoutProperties vResizing: aSymbol. 224397 self layoutChanged. 224398! ! 224399 224400!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:02'! 224401wrapCentering 224402 "Layout specific. This property describes how the rows/columns in a list-like layout should be centered. 224403 #topLeft - center at start of secondary direction 224404 #bottomRight - center at end of secondary direction 224405 #center - center in the middle of secondary direction 224406 #justified - insert extra space inbetween rows/columns 224407 " 224408 | props | 224409 props := self layoutProperties. 224410 ^props ifNil:[#topLeft] ifNotNil:[props wrapCentering].! ! 224411 224412!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 03:00'! 224413wrapCenteringString: aSymbol 224414 ^self layoutMenuPropertyString: aSymbol from: self wrapCentering! ! 224415 224416!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'! 224417wrapCentering: aSymbol 224418 "Layout specific. This property describes how the rows/columns in a list-like layout should be centered. 224419 #topLeft - center at start of secondary direction 224420 #bottomRight - center at end of secondary direction 224421 #center - center in the middle of secondary direction 224422 #justified - insert extra space inbetween rows/columns 224423 " 224424 self assureTableProperties wrapCentering: aSymbol. 224425 self layoutChanged.! ! 224426 224427!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'! 224428wrapDirection 224429 "Layout specific. This property describes the direction along which a list-like layout should be wrapped. Possible values are: 224430 #leftToRight 224431 #rightToLeft 224432 #topToBottom 224433 #bottomToTop 224434 #none 224435 indicating in which direction wrapping should occur. This direction must be orthogonal to the list direction, that is if listDirection is #leftToRight or #rightToLeft then wrapDirection must be #topToBottom or #bottomToTop and vice versa." 224436 | props | 224437 props := self layoutProperties. 224438 ^props ifNil:[#none] ifNotNil:[props wrapDirection].! ! 224439 224440!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 03:00'! 224441wrapDirectionString: aSymbol 224442 ^self layoutMenuPropertyString: aSymbol from: self wrapDirection ! ! 224443 224444!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'! 224445wrapDirection: aSymbol 224446 "Layout specific. This property describes the direction along which a list-like layout should be wrapped. Possible values are: 224447 #leftToRight 224448 #rightToLeft 224449 #topToBottom 224450 #bottomToTop 224451 #none 224452 indicating in which direction wrapping should occur. This direction must be orthogonal to the list direction, that is if listDirection is #leftToRight or #rightToLeft then wrapDirection must be #topToBottom or #bottomToTop and vice versa." 224453 self assureTableProperties wrapDirection: aSymbol. 224454 self layoutChanged. 224455! ! 224456 224457 224458!Morph methodsFor: 'macpal' stamp: 'sw 10/10/1999 10:23'! 224459flash 224460 | c w | 224461 c := self color. 224462 self color: Color black. 224463 (w := self world) ifNotNil: [w displayWorldSafely]. 224464 self color: c 224465! ! 224466 224467 224468!Morph methodsFor: 'menu' stamp: 'sw 11/27/2001 15:21'! 224469addBorderStyleMenuItems: aMenu hand: aHandMorph 224470 "Probably one could offer border-style items even if it's not a borderedMorph, so this remains a loose end for the moment" 224471! ! 224472 224473!Morph methodsFor: 'menu' stamp: 'marcus.denker 11/10/2008 10:04'! 224474addModelYellowButtonItemsTo: aCustomMenu event: evt 224475 "Give my models a chance to add their context-menu items to 224476 aCustomMenu." 224477 self model 224478 ifNotNil: [:mod | 224479 mod 224480 addModelYellowButtonMenuItemsTo: aCustomMenu 224481 forMorph: self 224482 hand: evt hand]! ! 224483 224484!Morph methodsFor: 'menu' stamp: 'nk 3/10/2004 19:49'! 224485addMyYellowButtonMenuItemsToSubmorphMenus 224486 "Answer true if I have items to add to the context menus of my submorphs" 224487 224488 ^true! ! 224489 224490!Morph methodsFor: 'menu' stamp: 'dgd 9/13/2004 19:23'! 224491addNestedYellowButtonItemsTo: aMenu event: evt 224492 "Add items to aMenu starting with me and proceeding down 224493 through my submorph chain, 224494 letting any submorphs that include the event position 224495 contribute their items to the bottom of the menu, separated by 224496 a line." 224497 | underMouse | 224498 224499 self addYellowButtonMenuItemsTo: aMenu event: evt. 224500 224501 underMouse := self 224502 submorphThat: [:each | each containsPoint: evt position] 224503 ifNone: [^ self]. 224504 224505 (underMouse addMyYellowButtonMenuItemsToSubmorphMenus 224506 and: [underMouse hasYellowButtonMenu]) 224507 ifTrue: [| submenu | 224508 aMenu addLine. 224509 submenu := MenuMorph new defaultTarget: underMouse. 224510 underMouse addNestedYellowButtonItemsTo: submenu event: evt. 224511 aMenu 224512 add: underMouse externalName 224513 icon: (underMouse iconOrThumbnailOfSize: 16) 224514 subMenu: submenu 224515 ] 224516! ! 224517 224518!Morph methodsFor: 'menu' stamp: 'dgd 7/28/2005 13:02'! 224519addTitleForHaloMenu: aMenu 224520 aMenu 224521 addTitle: self externalName 224522 icon: (self iconOrThumbnailOfSize: (Preferences tinyDisplay ifFalse:[28] ifTrue:[16]))! ! 224523 224524!Morph methodsFor: 'menu' stamp: 'michael.rueger 3/9/2009 18:50'! 224525addYellowButtonMenuItemsTo: aMenu event: evt 224526 "Populate aMenu with appropriate menu items for a 224527 yellow-button (context menu) click." 224528 aMenu defaultTarget: self. 224529 224530 224531 aMenu addStayUpItem. 224532 self addModelYellowButtonItemsTo: aMenu event: evt. 224533 Preferences generalizedYellowButtonMenu ifFalse: [^ self]. 224534 Preferences cmdGesturesEnabled ifTrue: [ 224535 aMenu addLine. 224536 aMenu add: 'inspect' translated action: #inspect]. 224537 aMenu addLine. 224538 self world selectedObject == self 224539 ifTrue: [aMenu add: 'deselect' translated action: #removeHalo] 224540 ifFalse: [aMenu add: 'select' translated action: #addHalo]. 224541 (self isWorldMorph 224542 or: [self wantsToBeTopmost]) 224543 ifFalse: [ 224544 aMenu addLine. 224545 aMenu add: 'send to back' translated action: #goBehind. 224546 aMenu add: 'bring to front' translated action: #comeToFront. 224547 self addEmbeddingMenuItemsTo: aMenu hand: evt hand]. 224548 self isWorldMorph ifFalse: [ 224549 self isFullOnScreen ifFalse: [aMenu add: 'move onscreen' translated action: #goHome]]. 224550 self addLayoutMenuItems: aMenu hand: evt hand. 224551 (owner notNil 224552 and: [owner isTextMorph]) 224553 ifTrue: [self addTextAnchorMenuItems: aMenu hand: evt hand]. 224554 self isWorldMorph ifFalse: [ 224555 aMenu addLine. 224556 self addToggleItemsToHaloMenu: aMenu]. 224557 aMenu addLine. 224558 self isWorldMorph 224559 ifFalse: [aMenu add: 'copy to paste buffer' translated action: #copyToPasteBuffer:]. 224560 (self allStringsAfter: nil) isEmpty ifFalse: [aMenu add: 'copy text' translated action: #clipText]. 224561 self addExportMenuItems: aMenu hand: evt hand. 224562 aMenu addLine. 224563 aMenu add: 'adhere to edge...' translated action: #adhereToEdge. 224564 self addCustomMenuItems: aMenu hand: evt hand! ! 224565 224566!Morph methodsFor: 'menu' stamp: 'dgd 9/18/2004 17:23'! 224567buildYellowButtonMenu: aHand 224568 "build the morph menu for the yellow button" 224569 | menu | 224570 menu := MenuMorph new defaultTarget: self. 224571 self addNestedYellowButtonItemsTo: menu event: ActiveEvent. 224572 MenuIcons decorateMenu: menu. 224573 ^ menu! ! 224574 224575!Morph methodsFor: 'menu' stamp: 'dgd 4/4/2006 14:43'! 224576hasYellowButtonMenu 224577 "Answer true if I have any items at all for a context (yellow 224578 button) menu." 224579 ^ self wantsYellowButtonMenu 224580 or: [self models anySatisfy: [:each | each hasModelYellowButtonMenuItems]]! ! 224581 224582!Morph methodsFor: 'menu' stamp: 'nk 3/10/2004 19:51'! 224583outermostOwnerWithYellowButtonMenu 224584 "Answer me or my outermost owner that is willing to contribute menu items to a context menu. 224585 Don't include the world." 224586 224587 | outermost | 224588 outermost := self outermostMorphThat: [ :ea | 224589 ea isWorldMorph not and: [ ea hasYellowButtonMenu ]]. 224590 ^outermost ifNil: [ self hasYellowButtonMenu ifTrue: [ self ] ifFalse: []] ! ! 224591 224592!Morph methodsFor: 'menu' stamp: 'marcus.denker 11/19/2008 13:46'! 224593wantsYellowButtonMenu 224594 "Answer true if the receiver wants a yellow button menu" 224595 self 224596 valueOfProperty: #wantsYellowButtonMenu 224597 ifPresentDo: [:value | ^ value]. 224598 self isInSystemWindow ifTrue: [^ false]. 224599 ^ Preferences generalizedYellowButtonMenu! ! 224600 224601!Morph methodsFor: 'menu' stamp: 'dgd 9/18/2004 18:35'! 224602wantsYellowButtonMenu: aBoolean 224603 "Change the receiver to wants or not a yellow button menu" 224604 self setProperty: #wantsYellowButtonMenu toValue: aBoolean! ! 224605 224606 224607!Morph methodsFor: 'menus' stamp: 'sw 11/27/2001 14:36'! 224608addAddHandMenuItemsForHalo: aMenu hand: aHandMorph 224609 "The former charter of this method was to add halo menu items that pertained specifically to the hand. Over time this charter has withered, and most morphs reimplement this method simply to add their morph-specific menu items. So in the latest round, all other implementors in the standard image have been removed. However, this is left here as a hook for the benefit of existing code in client uses." 224610 224611! ! 224612 224613!Morph methodsFor: 'menus' stamp: 'sw 4/27/1998 03:44'! 224614addCustomHaloMenuItems: aMenu hand: aHandMorph 224615 "Add morph-specific items to the given menu which was invoked by the given hand from the halo. To get started, we defer to the counterpart method used with the option-menu, but in time we can have separate menu choices for halo-menus and for option-menus" 224616 224617 self addCustomMenuItems: aMenu hand: aHandMorph! ! 224618 224619!Morph methodsFor: 'menus' stamp: 'sw 11/27/2001 07:17'! 224620addCustomMenuItems: aCustomMenu hand: aHandMorph 224621 "Add morph-specific items to the given menu which was invoked by the given hand. This method provides is invoked both from the halo-menu and from the control-menu regimes." 224622! ! 224623 224624!Morph methodsFor: 'menus' stamp: 'nk 2/16/2004 13:29'! 224625addExportMenuItems: aMenu hand: aHandMorph 224626 "Add export items to the menu" 224627 224628 aMenu ifNotNil: 224629 [ | aSubMenu | 224630 aSubMenu := MenuMorph new defaultTarget: self. 224631 aSubMenu add: 'BMP file' translated action: #exportAsBMP. 224632 aSubMenu add: 'GIF file' translated action: #exportAsGIF. 224633 aSubMenu add: 'JPEG file' translated action: #exportAsJPEG. 224634 aSubMenu add: 'PNG file' translated action: #exportAsPNG. 224635 aMenu add: 'export...' translated subMenu: aSubMenu] 224636! ! 224637 224638!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 16:44'! 224639addFillStyleMenuItems: aMenu hand: aHand 224640 "Add the items for changing the current fill style of the Morph" 224641 | menu | 224642 self canHaveFillStyles ifFalse:[^aMenu add: 'change color...' translated target: self action: #changeColor]. 224643 menu := MenuMorph new defaultTarget: self. 224644 self fillStyle addFillStyleMenuItems: menu hand: aHand from: self. 224645 menu addLine. 224646 menu add: 'solid fill' translated action: #useSolidFill. 224647 menu add: 'gradient fill' translated action: #useGradientFill. 224648 menu add: 'bitmap fill' translated action: #useBitmapFill. 224649 menu add: 'default fill' translated action: #useDefaultFill. 224650 aMenu add: 'fill style' translated subMenu: menu. 224651 "aMenu add: 'change color...' translated action: #changeColor"! ! 224652 224653!Morph methodsFor: 'menus' stamp: 'marcus.denker 11/20/2008 12:24'! 224654addHaloActionsTo: aMenu 224655 "Add items to aMenu representing actions requestable via halo" 224656 224657 | subMenu | 224658 subMenu := MenuMorph new defaultTarget: self. 224659 subMenu addTitle: self externalName. 224660 subMenu addStayUpItemSpecial. 224661 subMenu addLine. 224662 subMenu add: 'delete' translated action: #dismissViaHalo. 224663 subMenu balloonTextForLastItem: 'Delete this object -- warning -- can be destructive!!' translated. 224664 224665 self maybeAddCollapseItemTo: subMenu. 224666 subMenu add: 'grab' translated action: #openInHand. 224667 subMenu balloonTextForLastItem: 'Pick this object up -- warning, since this removes it from its container, it can have adverse effects.' translated. 224668 224669 subMenu addLine. 224670 224671 subMenu add: 'resize' translated action: #resizeFromMenu. 224672 subMenu balloonTextForLastItem: 'Change the size of this object' translated. 224673 224674 subMenu add: 'duplicate' translated action: #maybeDuplicateMorph. 224675 subMenu balloonTextForLastItem: 'Hand me a copy of this object' translated. 224676 "Note that this allows access to the non-instancing duplicate even when this is a uniclass instance" 224677 224678 subMenu addLine. 224679 224680 subMenu add: 'set color' translated target: self renderedMorph action: #changeColor. 224681 subMenu balloonTextForLastItem: 'Change the color of this object' translated. 224682 224683 subMenu addLine. 224684 224685 subMenu add: 'inspect' translated target: self action: #inspect. 224686 subMenu balloonTextForLastItem: 'Open an Inspector on this object' translated. 224687 224688 aMenu add: 'halo actions...' translated subMenu: subMenu 224689! ! 224690 224691!Morph methodsFor: 'menus' stamp: 'stephane.ducasse 5/1/2009 22:22'! 224692addMiscExtrasTo: aMenu 224693 "Add a submenu of miscellaneous extra items to the menu." 224694 224695 | subMenu | 224696 subMenu := MenuMorph new defaultTarget: self. 224697 (self isWorldMorph not and: [(self renderedMorph isSystemWindow) not]) 224698 ifTrue: [subMenu add: 'put in a window' translated action: #embedInWindow]. 224699 224700 self isWorldMorph ifFalse: 224701 [subMenu add: 'adhere to edge...' translated action: #adhereToEdge. 224702 subMenu addLine]. 224703 224704 subMenu 224705 add: 'add mouse up action' translated action: #addMouseUpAction; 224706 add: 'remove mouse up action' translated action: #removeMouseUpAction. 224707 subMenu addLine. 224708 aMenu add: 'extras...' translated subMenu: subMenu! ! 224709 224710!Morph methodsFor: 'menus' stamp: 'wiz 12/4/2006 00:24'! 224711addPaintingItemsTo: aMenu hand: aHandMorph 224712 | subMenu movies | 224713 subMenu := MenuMorph new defaultTarget: self. 224714 subMenu add: 'repaint' translated action: #editDrawing. 224715 subMenu add: 'set rotation center' translated action: #setRotationCenter. 224716 subMenu add: 'reset forward-direction' translated 224717 action: #resetForwardDirection. 224718 subMenu add: 'set rotation style' translated action: #setRotationStyle. 224719 subMenu add: 'erase pixels of color' translated 224720 action: #erasePixelsOfColor:. 224721 subMenu add: 'recolor pixels of color' translated 224722 action: #recolorPixelsOfColor:. 224723 subMenu add: 'reduce color palette' translated action: #reduceColorPalette:. 224724 subMenu add: 'add a border around this shape...' translated 224725 action: #addBorderToShape:. 224726 movies := (self world rootMorphsAt: aHandMorph targetPoint) 224727 select: [:m | (m isKindOf: MovieMorph) or: [m isSketchMorph]]. 224728 movies size > 1 224729 ifTrue: 224730 [subMenu add: 'insert into movie' translated action: #insertIntoMovie:]. 224731 aMenu add: 'painting...' translated subMenu: subMenu! ! 224732 224733!Morph methodsFor: 'menus' stamp: 'adrian_lienhard 7/19/2009 21:12'! 224734addStandardHaloMenuItemsTo: aMenu hand: aHandMorph 224735 "Add standard halo items to the menu" 224736 224737 | | 224738 224739 self isWorldMorph ifTrue: 224740 [^ self addWorldHaloMenuItemsTo: aMenu hand: aHandMorph]. 224741 224742 aMenu add: 'send to back' translated action: #goBehind. 224743 aMenu add: 'bring to front' translated action: #comeToFront. 224744 self addEmbeddingMenuItemsTo: aMenu hand: aHandMorph. 224745 aMenu addLine. 224746 224747 self addFillStyleMenuItems: aMenu hand: aHandMorph. 224748 self addBorderStyleMenuItems: aMenu hand: aHandMorph. 224749 self addDropShadowMenuItems: aMenu hand: aHandMorph. 224750 self addLayoutMenuItems: aMenu hand: aHandMorph. 224751 self addHaloActionsTo: aMenu. 224752 owner isTextMorph ifTrue:[self addTextAnchorMenuItems: aMenu hand: aHandMorph]. 224753 aMenu addLine. 224754 self addToggleItemsToHaloMenu: aMenu. 224755 aMenu addLine. 224756 self addExportMenuItems: aMenu hand: aHandMorph. 224757 self addMiscExtrasTo: aMenu. 224758 self addDebuggingItemsTo: aMenu hand: aHandMorph. 224759 aMenu addLine. 224760 aMenu defaultTarget: aHandMorph. 224761! ! 224762 224763!Morph methodsFor: 'menus' stamp: 'marcus.denker 11/19/2008 13:44'! 224764addToggleItemsToHaloMenu: aMenu 224765 "Add standard true/false-checkbox items to the memu" 224766 224767 #( 224768 (resistsRemovalString toggleResistsRemoval 'whether I should be reistant to easy deletion via the pink X handle' true) 224769 (stickinessString toggleStickiness 'whether I should be resistant to a drag done by mousing down on me' true) 224770 (lockedString lockUnlockMorph 'when "locked", I am inert to all user interactions' true) 224771 (hasClipSubmorphsString changeClipSubmorphs 'whether the parts of objects within me that are outside my bounds should be masked.' false) 224772 (hasDirectionHandlesString changeDirectionHandles 'whether direction handles are shown with the halo' false) 224773 (hasDragAndDropEnabledString changeDragAndDrop 'whether I am open to having objects dropped into me' false) 224774 ) do: [:each | 224775 aMenu addUpdating: each first action: each second. 224776 aMenu balloonTextForLastItem: each third translated]. 224777 224778 self couldHaveRoundedCorners ifTrue: 224779 [aMenu addUpdating: #roundedCornersString action: #toggleCornerRounding. 224780 aMenu balloonTextForLastItem: 'whether my corners should be rounded' translated]! ! 224781 224782!Morph methodsFor: 'menus' stamp: 'wiz 2/14/2006 18:54'! 224783addWorldTargetSightingItems: aCustomMenu hand: aHandMorph 224784"Use cursor to select a point on screen. 224785Set target from all possible morphs under cursor sight." 224786 224787 aCustomMenu addLine. 224788 224789 aCustomMenu add: 'sight target' translated action: #sightWorldTargets:. 224790 ! ! 224791 224792!Morph methodsFor: 'menus' stamp: 'dgd 10/17/2003 22:51'! 224793adhereToEdge 224794 | menu | 224795 menu := MenuMorph new defaultTarget: self. 224796 #(top right bottom left - center - topLeft topRight bottomRight bottomLeft - none) 224797 do: [:each | 224798 each == #- 224799 ifTrue: [menu addLine] 224800 ifFalse: [menu add: each asString translated selector: #setToAdhereToEdge: argument: each]]. 224801 menu popUpEvent: self currentEvent in: self world! ! 224802 224803!Morph methodsFor: 'menus' stamp: 'wiz 10/19/2006 00:35'! 224804adhereToEdge: edgeSymbol 224805 | edgeMessage | 224806 (owner isNil or: [owner isHandMorph]) ifTrue: [^self]. 224807 (owner class canUnderstand: edgeSymbol) ifFalse: [^self]. 224808 (self class canUnderstand: ( edgeMessage := (edgeSymbol , ':') asSymbol )) 224809 ifFalse: [^self]. 224810 224811 self perform: edgeMessage 224812 withArguments: (Array with: (owner perform: edgeSymbol))! ! 224813 224814!Morph methodsFor: 'menus' stamp: 'sw 2/3/2000 00:14'! 224815adjustedCenter 224816 "Provides a hook for objects to provide a reference point other than the receiver's center,for the purpose of centering a submorph under special circumstances, such as BalloonMorph" 224817 224818 ^ self center! ! 224819 224820!Morph methodsFor: 'menus' stamp: 'sw 2/3/2000 00:12'! 224821adjustedCenter: c 224822 "Set the receiver's position based on the #adjustedCenter protocol for adhereToEdge. By default this simply sets the receiver's center. Though there are (at its inception anyway) no other implementors of this method, it is required in use with the #adhereToEdge when the centering of a submorph is to be with reference to a rectangle other than the receiver's center." 224823 224824 self center: c! ! 224825 224826!Morph methodsFor: 'menus' stamp: 'ar 10/5/2000 17:20'! 224827allMenuWordings 224828 | tempMenu | 224829 tempMenu := self buildHandleMenu: self currentHand. 224830 tempMenu allMorphsDo: [:m | m step]. "Get wordings current" 224831 ^ tempMenu allWordings! ! 224832 224833!Morph methodsFor: 'menus' stamp: 'sw 9/6/2000 18:45'! 224834changeColor 224835 "Change the color of the receiver -- triggered, e.g. from a menu" 224836 224837 ColorPickerMorph new 224838 choseModalityFromPreference; 224839 sourceHand: self activeHand; 224840 target: self; 224841 selector: #fillStyle:; 224842 originalColor: self color; 224843 putUpFor: self near: self fullBoundsInWorld! ! 224844 224845!Morph methodsFor: 'menus' stamp: 'ar 11/29/2001 19:57'! 224846changeDirectionHandles 224847 ^self wantsDirectionHandles: self wantsDirectionHandles not! ! 224848 224849!Morph methodsFor: 'menus' stamp: 'ar 11/2/2000 15:04'! 224850changeDragAndDrop 224851 ^self enableDragNDrop: self dragNDropEnabled not! ! 224852 224853!Morph methodsFor: 'menus' stamp: 'sw 2/21/2000 15:21'! 224854collapse 224855 CollapsedMorph new beReplacementFor: self! ! 224856 224857!Morph methodsFor: 'menus' stamp: 'DamienCassou 9/29/2009 13:01'! 224858exportAsBMP 224859 | fName | 224860 fName := UIManager default request:'Please enter the name' translated initialAnswer: self externalName,'.bmp'. 224861 fName isEmptyOrNil ifTrue:[^self]. 224862 self imageForm writeBMPfileNamed: fName.! ! 224863 224864!Morph methodsFor: 'menus' stamp: 'DamienCassou 9/29/2009 13:01'! 224865exportAsGIF 224866 | fName | 224867 fName := UIManager default request:'Please enter the name' translated initialAnswer: self externalName,'.gif'. 224868 fName isEmptyOrNil ifTrue:[^self]. 224869 GIFReadWriter putForm: self imageForm onFileNamed: fName.! ! 224870 224871!Morph methodsFor: 'menus' stamp: 'DamienCassou 9/29/2009 13:01'! 224872exportAsJPEG 224873 "Export the receiver's image as a JPEG" 224874 224875 | fName | 224876 fName := UIManager default request: 'Please enter the name' translated initialAnswer: self externalName,'.jpeg'. 224877 fName isEmptyOrNil ifTrue: [^ self]. 224878 self imageForm writeJPEGfileNamed: fName! ! 224879 224880!Morph methodsFor: 'menus' stamp: 'DamienCassou 9/29/2009 13:01'! 224881exportAsPNG 224882 | fName | 224883 fName := UIManager default request:'Please enter the name' translated initialAnswer: self externalName,'.png'. 224884 fName isEmptyOrNil ifTrue:[^self]. 224885 PNGReadWriter putForm: self imageForm onFileNamed: fName.! ! 224886 224887!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:23'! 224888hasDirectionHandlesString 224889 ^ (self wantsDirectionHandles 224890 ifTrue: ['<on>'] 224891 ifFalse: ['<off>']) 224892 , 'direction handles' translated! ! 224893 224894!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:24'! 224895hasDragAndDropEnabledString 224896 "Answer a string to characterize the drag & drop status of the 224897 receiver" 224898 ^ (self dragNDropEnabled 224899 ifTrue: ['<on>'] 224900 ifFalse: ['<off>']) 224901 , 'accept drops' translated! ! 224902 224903!Morph methodsFor: 'menus' stamp: 'dgd 4/3/2006 14:09'! 224904helpButton 224905 "Answer a button whose action would be to put up help concerning the receiver" 224906 224907 | aButton | 224908 aButton := SimpleButtonMorph new. 224909 aButton 224910 target: self; 224911 color: ColorTheme current helpColor; 224912 borderColor: ColorTheme current helpColor muchDarker; 224913 borderWidth: 1; 224914 label: '?' translated font: Preferences standardButtonFont; 224915 actionSelector: #presentHelp; 224916 setBalloonText: 'click here for help' translated. 224917 ^ aButton! ! 224918 224919!Morph methodsFor: 'menus' stamp: 'ar 9/27/2005 21:01'! 224920inspectInMorphic 224921 self currentHand attachMorph: ((ToolSet inspect: self) extent: 300@200)! ! 224922 224923!Morph methodsFor: 'menus' stamp: 'ar 9/27/2005 21:01'! 224924inspectInMorphic: evt 224925 evt hand attachMorph: ((ToolSet inspect: self) extent: 300@200)! ! 224926 224927!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:20'! 224928lockedString 224929 "Answer the string to be shown in a menu to represent the 224930 'locked' status" 224931 ^ (self isLocked 224932 ifTrue: ['<on>'] 224933 ifFalse: ['<off>']), 'be locked' translated! ! 224934 224935!Morph methodsFor: 'menus' stamp: 'sw 9/21/2000 22:50'! 224936lockUnlockMorph 224937 "If the receiver is locked, unlock it; if unlocked, lock it" 224938 224939 self isLocked ifTrue: [self unlock] ifFalse: [self lock]! ! 224940 224941!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:15'! 224942maybeAddCollapseItemTo: aMenu 224943 "If appropriate, add a collapse item to the given menu" 224944 224945 | anOwner | 224946 (anOwner := self topRendererOrSelf owner) ifNotNil: 224947 [anOwner isWorldMorph ifTrue: 224948 [aMenu add: 'collapse' translated target: self action: #collapse]]! ! 224949 224950!Morph methodsFor: 'menus' stamp: 'sw 11/22/1999 12:13'! 224951menuItemAfter: menuString 224952 | allWordings | 224953 allWordings := self allMenuWordings. 224954 ^ allWordings atWrap: ((allWordings indexOf: menuString) + 1)! ! 224955 224956!Morph methodsFor: 'menus' stamp: 'sw 11/22/1999 12:14'! 224957menuItemBefore: menuString 224958 | allWordings | 224959 allWordings := self allMenuWordings. 224960 ^ allWordings atWrap: ((allWordings indexOf: menuString) - 1)! ! 224961 224962!Morph methodsFor: 'menus' stamp: 'dgd 9/22/2004 20:30'! 224963model 224964 ^ nil ! ! 224965 224966!Morph methodsFor: 'menus' stamp: 'sw 6/12/2001 21:08'! 224967presentHelp 224968 "Present a help message if there is one available" 224969 224970 self inform: 'Sorry, no help has been 224971provided here yet.'! ! 224972 224973!Morph methodsFor: 'menus' stamp: 'ar 9/22/2000 20:36'! 224974resetForwardDirection 224975 self forwardDirection: 0.! ! 224976 224977!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:18'! 224978resistsRemovalString 224979 "Answer the string to be shown in a menu to represent the 224980 'resistsRemoval' status" 224981 ^ (self resistsRemoval 224982 ifTrue: ['<on>'] 224983 ifFalse: ['<off>']), 'resist being deleted' translated! ! 224984 224985!Morph methodsFor: 'menus' stamp: 'yo 2/17/2005 16:58'! 224986setArrowheads 224987 "Let the user edit the size of arrowheads for this object" 224988 224989 | aParameter result | 224990 aParameter := self renderedMorph valueOfProperty: #arrowSpec ifAbsent: 224991 [Preferences parameterAt: #arrowSpec ifAbsent: [5 @ 4]]. 224992 result := Morph obtainArrowheadFor: 'Head size for arrowheads: ' translated defaultValue: aParameter asString. 224993 result ifNotNil: 224994 [self renderedMorph setProperty: #arrowSpec toValue: result] 224995 ifNil: 224996 [Beeper beep]! ! 224997 224998!Morph methodsFor: 'menus' stamp: 'ar 9/22/2000 20:15'! 224999setRotationCenter 225000 | p | 225001 self world displayWorld. 225002 Cursor crossHair showWhile: 225003 [p := Sensor waitButton]. 225004 Sensor waitNoButton. 225005 self setRotationCenterFrom: (self transformFromWorld globalPointToLocal: p). 225006 225007! ! 225008 225009!Morph methodsFor: 'menus' stamp: 'ar 9/22/2000 20:14'! 225010setRotationCenterFrom: aPoint 225011 self rotationCenter: (aPoint - self bounds origin) / self bounds extent asFloatPoint.! ! 225012 225013!Morph methodsFor: 'menus' stamp: 'di 12/21/2000 17:18'! 225014setToAdhereToEdge: anEdge 225015 anEdge ifNil: [^ self]. 225016 anEdge == #none ifTrue: [^ self removeProperty: #edgeToAdhereTo]. 225017 self setProperty: #edgeToAdhereTo toValue: anEdge. 225018! ! 225019 225020!Morph methodsFor: 'menus' stamp: 'sw 8/30/1998 09:42'! 225021snapToEdgeIfAppropriate 225022 | edgeSymbol oldBounds aWorld | 225023 (edgeSymbol := self valueOfProperty: #edgeToAdhereTo) ifNotNil: 225024 [oldBounds := bounds. 225025 self adhereToEdge: edgeSymbol. 225026 bounds ~= oldBounds ifTrue: [(aWorld := self world) ifNotNil: [aWorld viewBox ifNotNil: 225027 [aWorld displayWorld]]]]! ! 225028 225029!Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:19'! 225030stickinessString 225031 "Answer the string to be shown in a menu to represent the 225032 stickiness status" 225033 ^ (self isSticky 225034 ifTrue: ['<yes>'] 225035 ifFalse: ['<no>']) 225036 , 'resist being picked up' translated! ! 225037 225038!Morph methodsFor: 'menus' stamp: 'stephane.ducasse 11/27/2008 22:39'! 225039transferStateToRenderer: aRenderer 225040 "Transfer knownName, and visible over to aRenderer, which is being imposed above me as a transformation shell" 225041 225042 | current | 225043 (current := self knownName) ifNotNil: 225044 [aRenderer setNameTo: current. 225045 self setNameTo: nil]. 225046 aRenderer simplySetVisible: self visible 225047 225048 225049 225050 225051 225052 ! ! 225053 225054!Morph methodsFor: 'menus' stamp: 'RAA 11/14/2000 13:46'! 225055uncollapseSketch 225056 225057 | uncollapsedVersion w whomToDelete | 225058 225059 (w := self world) ifNil: [^self]. 225060 uncollapsedVersion := self valueOfProperty: #uncollapsedMorph. 225061 uncollapsedVersion ifNil: [^self]. 225062 whomToDelete := self valueOfProperty: #collapsedMorphCarrier. 225063 uncollapsedVersion setProperty: #collapsedPosition toValue: whomToDelete position. 225064 225065 whomToDelete delete. 225066 w addMorphFront: uncollapsedVersion. 225067 225068! ! 225069 225070 225071!Morph methodsFor: 'messenger' stamp: 'sw 11/3/2001 12:23'! 225072affiliatedSelector 225073 "Answer a selector affiliated with the receiver for the purposes of launching a messenger. Reimplement this to plug into the messenger service" 225074 225075 ^ nil! ! 225076 225077 225078!Morph methodsFor: 'meta-actions' stamp: 'dgd 9/18/2004 16:24'! 225079addEmbeddingMenuItemsTo: aMenu hand: aHandMorph 225080 "Construct a menu offerring embed targets for the receiver. If the incoming menu is is not degenerate, add the constructed menu as a submenu; in any case, answer the embed-target menu" 225081 225082 | menu potentialEmbeddingTargets | 225083 225084 potentialEmbeddingTargets := self potentialEmbeddingTargets. 225085 potentialEmbeddingTargets size > 1 ifFalse:[^ self]. 225086 225087 menu := MenuMorph new defaultTarget: self. 225088 225089 potentialEmbeddingTargets reverseDo: [:m | 225090 menu 225091 add: (m knownName ifNil:[m class name asString]) 225092 target: m 225093 selector: #addMorphFrontFromWorldPosition: 225094 argument: self topRendererOrSelf. 225095 225096 menu lastItem icon: (m iconOrThumbnailOfSize: 16). 225097 225098 self owner == m ifTrue:[menu lastItem emphasis: 1]. 225099 ]. 225100 225101 aMenu add:'embed into' translated subMenu: menu. 225102 225103 ^ menu! ! 225104 225105!Morph methodsFor: 'meta-actions' stamp: 'yo 3/15/2005 14:45'! 225106blueButtonDown: anEvent 225107 "Special gestures (cmd-mouse on the Macintosh; Alt-mouse on Windows and Unix) allow a mouse-sensitive morph to be moved or bring up a halo for the morph." 225108 | h tfm doNotDrag | 225109 h := anEvent hand halo. 225110 "Prevent wrap around halo transfers originating from throwing the event back in" 225111 doNotDrag := false. 225112 h ifNotNil:[ 225113 (h innerTarget == self) ifTrue:[doNotDrag := true]. 225114 (h innerTarget hasOwner: self) ifTrue:[doNotDrag := true]. 225115 (self hasOwner: h target) ifTrue:[doNotDrag := true]]. 225116 225117 tfm := (self transformedFrom: nil) inverseTransformation. 225118 225119 "cmd-drag on flexed morphs works better this way" 225120 h := self addHalo: (anEvent transformedBy: tfm). 225121 h ifNil: [^ self]. 225122 doNotDrag ifTrue:[^self]. 225123 "Initiate drag transition if requested" 225124 anEvent hand 225125 waitForClicksOrDrag: h 225126 event: (anEvent transformedBy: tfm) 225127 selectors: { nil. nil. nil. #dragTarget:. } 225128 threshold: 5. 225129 "Pass focus explicitly here" 225130 anEvent hand newMouseFocus: h.! ! 225131 225132!Morph methodsFor: 'meta-actions' stamp: 'ar 9/15/2000 20:25'! 225133blueButtonUp: anEvent 225134 "Ignored. Theoretically we should never get here since control is transferred to the halo on #blueButtonDown: but subclasses may implement this differently."! ! 225135 225136!Morph methodsFor: 'meta-actions' stamp: 'marcus.denker 11/19/2008 13:45'! 225137buildHandleMenu: aHand 225138 "Build the morph menu for the given morph's halo's menu handle. This menu has two sections. The first section contains commands that are interpreted by the hand; the second contains commands provided by the target morph. This method allows the morph to decide which items should be included in the hand's section of the menu." 225139 225140 | menu | 225141 menu := MenuMorph new defaultTarget: self. 225142 menu addStayUpItem. 225143 menu addLine. 225144 self addStandardHaloMenuItemsTo: menu hand: aHand. 225145 menu defaultTarget: aHand. 225146 self addAddHandMenuItemsForHalo: menu hand: aHand. 225147 menu defaultTarget: self. 225148 self addCustomHaloMenuItems: menu hand: aHand. 225149 menu defaultTarget: aHand. 225150 ^ menu 225151! ! 225152 225153!Morph methodsFor: 'meta-actions' stamp: 'adrian_lienhard 7/19/2009 21:13'! 225154buildMetaMenu: evt 225155 "Build the morph menu. This menu has two sections. The first section contains commands that are handled by the hand; the second contains commands handled by the argument morph." 225156 | menu | 225157 menu := MenuMorph new defaultTarget: self. 225158 menu addStayUpItem. 225159 menu add: 'grab' translated action: #grabMorph:. 225160 menu add: 'copy to paste buffer' translated action: #copyToPasteBuffer:. 225161 self maybeAddCollapseItemTo: menu. 225162 menu add: 'delete' translated action: #dismissMorph:. 225163 menu addLine. 225164 menu add: 'copy text' translated action: #clipText. 225165 menu addLine. 225166 menu add: 'go behind' translated action: #goBehind. 225167 menu add: 'add halo' translated action: #addHalo:. 225168 menu add: 'duplicate' translated action: #maybeDuplicateMorph:. 225169 225170 self addEmbeddingMenuItemsTo: menu hand: evt hand. 225171 225172 menu add: 'resize' translated action: #resizeMorph:. 225173 "Give the argument control over what should be done about fill styles" 225174 self addFillStyleMenuItems: menu hand: evt hand. 225175 self addDropShadowMenuItems: menu hand: evt hand. 225176 self addLayoutMenuItems: menu hand: evt hand. 225177 menu addUpdating: #hasClipSubmorphsString target: self selector: #changeClipSubmorphs argumentList: #(). 225178 menu addLine. 225179 225180 (self morphsAt: evt position) size > 1 ifTrue: 225181 [menu add: 'submorphs...' translated 225182 target: self 225183 selector: #invokeMetaMenuAt:event: 225184 argument: evt position]. 225185 menu addLine. 225186 menu add: 'inspect' translated selector: #inspectAt:event: argument: evt position. 225187 menu add: 'explore' translated action: #explore. 225188 menu add: 'browse hierarchy' translated action: #browseHierarchy. 225189 menu add: 'make own subclass' translated action: #subclassMorph. 225190 menu addLine. 225191 menu add: 'save morph in file' translated action: #saveOnFile. 225192 (self hasProperty: #resourceFilePath) 225193 ifTrue: [((self valueOfProperty: #resourceFilePath) endsWith: '.morph') 225194 ifTrue: [menu add: 'save as resource' translated action: #saveAsResource]. 225195 menu add: 'update from resource' translated action: #updateFromResource] 225196 ifFalse: [menu add: 'attach to resource' translated action: #attachToResource]. 225197 menu add: 'show actions' translated action: #showActions. 225198 menu addLine. 225199 self addDebuggingItemsTo: menu hand: evt hand. 225200 225201 self addCustomMenuItems: menu hand: evt hand. 225202 ^ menu 225203! ! 225204 225205!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 18:54'! 225206changeColorTarget: anObject selector: aSymbol originalColor: aColor hand: aHand 225207 "Put up a color picker for changing some kind of color. May be modal or modeless, depending on #modalColorPickers setting" 225208 self flag: #arNote. "Simplify this due to anObject == self for almost all cases" 225209 ^ ColorPickerMorph new 225210 choseModalityFromPreference; 225211 sourceHand: aHand; 225212 target: anObject; 225213 selector: aSymbol; 225214 originalColor: aColor; 225215 putUpFor: anObject near: (anObject isMorph 225216 ifTrue: [Rectangle center: self position extent: 20] 225217 ifFalse: [anObject == self world 225218 ifTrue: [anObject viewBox bottomLeft + (20@-20) extent: 200] 225219 ifFalse: [anObject fullBoundsInWorld]]); 225220 yourself! ! 225221 225222!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 16:44'! 225223copyToPasteBuffer: evt 225224 self okayToDuplicate ifTrue:[evt hand copyToPasteBuffer: self].! ! 225225 225226!Morph methodsFor: 'meta-actions' stamp: 'mir 3/17/2006 18:02'! 225227dismissMorph 225228 "This is called from an explicit halo destroy/delete action." 225229 225230 | w | 225231 w := self world ifNil:[^self]. 225232 w abandonAllHalos; stopStepping: self. 225233 self delete! ! 225234 225235!Morph methodsFor: 'meta-actions' stamp: 'mir 3/17/2006 18:01'! 225236dismissMorph: evt 225237 self dismissMorph! ! 225238 225239!Morph methodsFor: 'meta-actions' stamp: 'wiz 2/19/2006 12:41'! 225240duplicateMorphImage: evt 225241 "Make and return a imageMorph of the receiver's argument imageForm" 225242 | dup | 225243 dup := self asSnapshotThumbnail withSnapshotBorder. 225244 dup bounds: self bounds. 225245 evt hand grabMorph: dup from: owner. 225246 "duplicate was ownerless so use #grabMorph:from: here" 225247 ^ dup! ! 225248 225249!Morph methodsFor: 'meta-actions' stamp: 'ar 11/4/2000 17:56'! 225250duplicateMorph: evt 225251 "Make and return a duplicate of the receiver's argument" 225252 | dup | 225253 dup := self duplicate. 225254 evt hand grabMorph: dup from: owner. "duplicate was ownerless so use #grabMorph:from: here" 225255 ^dup! ! 225256 225257!Morph methodsFor: 'meta-actions' stamp: 'alain.plantec 2/8/2009 22:44'! 225258embedInto: evt 225259 "Embed the receiver into some other morph" 225260 | target | 225261 target := UIManager default 225262 chooseFrom: (self potentialEmbeddingTargets 225263 collect: [:t | t knownName 225264 ifNil: [t class name asString]]) 225265 values: self potentialEmbeddingTargets 225266 title: 'Place ' translated, self externalName , ' in...' translated. 225267 target 225268 ifNil: [^ self]. 225269 target addMorphFront: self fromWorldPosition: self positionInWorld! ! 225270 225271!Morph methodsFor: 'meta-actions' stamp: 'ar 10/6/2000 16:37'! 225272grabMorph: evt 225273 225274 evt hand grabMorph: self! ! 225275 225276!Morph methodsFor: 'meta-actions' stamp: 'ar 10/12/2000 17:07'! 225277handlerForMetaMenu: evt 225278 "Return the prospective handler for invoking the meta menu. By default, the top-most morph in the innermost world gets this menu" 225279 self isWorldMorph ifTrue:[^self]. 225280 evt handler ifNotNil:[evt handler isWorldMorph ifTrue:[^self]]. 225281 ^nil! ! 225282 225283!Morph methodsFor: 'meta-actions' stamp: 'alain.plantec 2/8/2009 22:38'! 225284inspectAt: aPoint event: evt 225285 | morphs target | 225286 morphs := self morphsAt: aPoint. 225287 (morphs includes: self) ifFalse:[morphs := morphs copyWith: self]. 225288 target := UIManager default 225289 chooseFrom: (morphs 225290 collect: [:t | t knownName 225291 ifNil: [t class name asString]]) 225292 values: morphs 225293 title: ('inspect whom? (deepest at top)' translated). 225294 target ifNil:[^self]. 225295 target inspectInMorphic: evt! ! 225296 225297!Morph methodsFor: 'meta-actions' stamp: 'alain.plantec 2/8/2009 22:41'! 225298invokeMetaMenuAt: aPoint event: evt 225299 | morphs target | 225300 morphs := self morphsAt: aPoint. 225301 (morphs includes: self) 225302 ifFalse: [morphs := morphs copyWith: self]. 225303 morphs size = 1 225304 ifTrue: [morphs anyOne invokeMetaMenu: evt] 225305 ifFalse: [target := UIManager default 225306 chooseFrom: (morphs 225307 collect: [:t | t knownName 225308 ifNil: [t class name asString]]) 225309 values: morphs. 225310 target 225311 ifNil: [^ self]. 225312 target invokeMetaMenu: evt]! ! 225313 225314!Morph methodsFor: 'meta-actions' stamp: 'fc 4/27/2004 21:54'! 225315invokeMetaMenu: evt 225316 | menu | 225317 menu := self buildMetaMenu: evt. 225318 menu addTitle: self externalName. 225319 self world ifNotNil: [ 225320 menu popUpEvent: evt in: self world 225321 ]! ! 225322 225323!Morph methodsFor: 'meta-actions' stamp: 'sw 4/19/2005 14:55'! 225324maybeDuplicateMorph 225325 "Maybe duplicate the morph" 225326 225327 self okayToDuplicate ifTrue: 225328 [self topRendererOrSelf duplicate openInHand]! ! 225329 225330!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 17:32'! 225331maybeDuplicateMorph: evt 225332 self okayToDuplicate ifTrue:[^self duplicateMorph: evt]! ! 225333 225334!Morph methodsFor: 'meta-actions' stamp: 'wiz 1/2/2005 01:06'! 225335potentialEmbeddingTargets 225336 "Return the potential targets for embedding the receiver" 225337 225338 | oneUp topRend | 225339 (oneUp := (topRend := self topRendererOrSelf) owner) ifNil:[^#()]. 225340 ^ (oneUp morphsAt: topRend referencePosition behind: topRend unlocked: true) select: 225341 [:m | m isFlexMorph not]! ! 225342 225343!Morph methodsFor: 'meta-actions' stamp: 'wiz 7/17/2004 22:17'! 225344potentialTargets 225345 "Return the potential targets for the receiver. 225346 This is derived from Morph>>potentialEmbeddingTargets." 225347 owner ifNil:[^#()]. 225348 ^owner morphsAt: self referencePosition behind: self unlocked: true not! ! 225349 225350!Morph methodsFor: 'meta-actions' stamp: 'wiz 11/9/2006 23:04'! 225351potentialTargetsAt: aPoint 225352 "Return the potential targets for the receiver. 225353 This is derived from Morph>>potentialEmbeddingTargets." 225354 | realOwner | 225355 realOwner := self topRendererOrSelf 225356 owner 225357 ifNil: [^ #()]. 225358 ^ realOwner 225359 morphsAt: aPoint 225360 ! ! 225361 225362!Morph methodsFor: 'meta-actions' stamp: 'sw 11/27/2001 14:59'! 225363resizeFromMenu 225364 "Commence an interaction that will resize the receiver" 225365 225366 self resizeMorph: ActiveEvent! ! 225367 225368!Morph methodsFor: 'meta-actions' stamp: 'st 9/14/2004 12:30'! 225369resizeMorph: evt 225370 | handle | 225371 handle := HandleMorph new forEachPointDo: [:newPoint | 225372 self extent: (self griddedPoint: newPoint) - self bounds topLeft]. 225373 evt hand attachMorph: handle. 225374 handle startStepping. 225375! ! 225376 225377!Morph methodsFor: 'meta-actions' stamp: 'alain.plantec 2/6/2009 17:08'! 225378saveAsPrototype 225379 (self confirm: 'Make this morph the prototype for ' translated, self class printString, '?') 225380 ifFalse: [^ self]. 225381 self class prototype: self. 225382! ! 225383 225384!Morph methodsFor: 'meta-actions' stamp: 'ar 9/27/2005 20:29'! 225385showActions 225386 "Put up a message list browser of all the code that this morph 225387 would run for mouseUp, mouseDown, mouseMove, mouseEnter, 225388 mouseLeave, and 225389 mouseLinger. tk 9/13/97" 225390 | list cls selector adder | 225391 list := SortedCollection new. 225392 adder := [:mrClass :mrSel | list 225393 add: (MethodReference new setStandardClass: mrClass methodSymbol: mrSel)]. 225394 "the eventHandler" 225395 self eventHandler 225396 ifNotNil: [list := self eventHandler methodRefList. 225397 (self eventHandler handlesMouseDown: nil) 225398 ifFalse: [adder value: HandMorph value: #grabMorph:]]. 225399 "If not those, then non-default raw events" 225400 #(#keyStroke: #mouseDown: #mouseEnter: #mouseLeave: #mouseMove: #mouseUp: #doButtonAction ) 225401 do: [:sel | 225402 cls := self class whichClassIncludesSelector: sel. 225403 cls 225404 ifNotNil: ["want more than default behavior" 225405 cls == Morph 225406 ifFalse: [adder value: cls value: sel]]]. 225407 "The mechanism on a Button" 225408 (self respondsTo: #actionSelector) 225409 ifTrue: ["A button" 225410 selector := self actionSelector. 225411 cls := self target class whichClassIncludesSelector: selector. 225412 cls 225413 ifNotNil: ["want more than default behavior" 225414 cls == Morph 225415 ifFalse: [adder value: cls value: selector]]]. 225416 ToolSet openMessageList: list name: 'Actions of ' , self printString autoSelect: false! ! 225417 225418!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 19:21'! 225419showHiders 225420 self allMorphsDo:[:m | m show]! ! 225421 225422!Morph methodsFor: 'meta-actions' stamp: 'wiz 7/13/2006 22:09'! 225423sightTargets: event 225424 "Return the potential targets for the receiver. 225425 This is derived from Morph>>potentialEmbeddingTargets." 225426 | bullseye | 225427 owner 225428 ifNil: [^ #()]. 225429 bullseye := Point fromUserWithCursor: Cursor target. 225430 self targetFromMenu: (self potentialTargetsAt: bullseye) asKnownNameMenu popupAt: bullseye! ! 225431 225432!Morph methodsFor: 'meta-actions' stamp: 'wiz 7/13/2006 22:10'! 225433sightWorldTargets: event 225434 "Return the potential targets for the receiver. 225435 This is derived from Morph>>potentialEmbeddingTargets." 225436 | bullseye myWorld | 225437 myWorld := self world 225438 ifNil: [^ #()]. 225439 bullseye := Point fromUserWithCursor: Cursor target. 225440 self targetFromMenu: ( myWorld morphsAt: bullseye) asKnownNameMenu popupAt: bullseye! ! 225441 225442!Morph methodsFor: 'meta-actions' stamp: 'DamienCassou 9/29/2009 13:02'! 225443subclassMorph 225444 "Create a new subclass of this morph's class and make this morph be an instance of it." 225445 225446 | oldClass newClassName newClass newMorph | 225447 oldClass := self class. 225448 newClassName := UIManager default 225449 request: 'Please give this new class a name' translated 225450 initialAnswer: oldClass name. 225451 newClassName isEmptyOrNil ifTrue: [^ self]. 225452 (Smalltalk includesKey: newClassName) 225453 ifTrue: [^ self inform: 'Sorry, there is already a class of that name']. 225454 225455 newClass := oldClass subclass: newClassName asSymbol 225456 instanceVariableNames: '' 225457 classVariableNames: '' 225458 poolDictionaries: '' 225459 category: oldClass category asString. 225460 newMorph := self as: newClass. 225461 self become: newMorph. 225462! ! 225463 225464!Morph methodsFor: 'meta-actions' stamp: 'wiz 7/20/2004 01:25'! 225465targetFromMenu: aMenu 225466 "Some other morph become target of the receiver" 225467 | newTarget | 225468 225469 newTarget := aMenu startUpWithCaption: self externalName , ' targets...'. 225470 newTarget 225471 ifNil: [^ self]. 225472 self target: newTarget! ! 225473 225474!Morph methodsFor: 'meta-actions' stamp: 'wiz 7/20/2004 12:22'! 225475targetFromMenu: aMenu popupAt: aPoint 225476 "Some other morph become target of the receiver" 225477 | newTarget | 225478 newTarget := aMenu startUpWithCaption: self externalName , ' targets... ' 225479 at: aPoint . 225480 "self halt ." 225481 newTarget 225482 ifNil: [^ self]. 225483 self target: newTarget! ! 225484 225485!Morph methodsFor: 'meta-actions' stamp: 'alain.plantec 2/8/2009 22:43'! 225486targetWith: evt 225487 "Some other morph become target of the receiver" 225488 | newTarget | 225489 newTarget := UIManager default 225490 chooseFrom: (self potentialTargets 225491 collect: [:t | t knownName 225492 ifNil: [t class name asString]]) 225493 values: self potentialTargets 225494 title: (self externalName, ' targets...' translated). 225495 newTarget ifNil:[^self]. 225496 self target: newTarget.! ! 225497 225498 225499!Morph methodsFor: 'miscellaneous' stamp: 'dgd 9/27/2004 12:12'! 225500roundUpStrays 225501 self submorphs 225502 do: [:each | each roundUpStrays]! ! 225503 225504!Morph methodsFor: 'miscellaneous' stamp: 'sw 7/20/2001 00:15'! 225505setExtentFromHalo: anExtent 225506 "The user has dragged the grow box such that the receiver's extent would be anExtent. Do what's needed" 225507 225508 self extent: anExtent! ! 225509 225510!Morph methodsFor: 'miscellaneous' stamp: 'sw 2/2/2006 00:43'! 225511setFlexExtentFromHalo: anExtent 225512 "The user has dragged the grow box such that the receiver's extent would be anExtent. Do what's needed. Set the extent of the top renderer as indicated." 225513 225514 self addFlexShellIfNecessary. 225515 self topRendererOrSelf extent: anExtent! ! 225516 225517 225518!Morph methodsFor: 'model access' stamp: 'nk 3/10/2004 19:51'! 225519models 225520 "Answer a collection of whatever models I may have." 225521 225522 self modelOrNil ifNil: [ ^EmptyArray ]. 225523 ^Array with: self modelOrNil! ! 225524 225525 225526!Morph methodsFor: 'naming' stamp: 'dgd 8/30/2003 15:52'! 225527innocuousName 225528 "Choose an innocuous name for the receiver -- one that does not end in the word Morph" 225529 225530 | className allKnownNames | 225531 className := self defaultNameStemForInstances. 225532 (className size > 5 and: [className endsWith: 'Morph']) 225533 ifTrue: [className := className copyFrom: 1 to: className size - 5]. 225534 className := className asString translated. 225535 allKnownNames := self world ifNil: [OrderedCollection new] ifNotNil: [self world allKnownNames]. 225536 ^ Utilities keyLike: className asString satisfying: 225537 [:aName | (allKnownNames includes: aName) not]! ! 225538 225539!Morph methodsFor: 'naming' stamp: 'sw 9/21/2000 13:18'! 225540nameForFindWindowFeature 225541 "Answer the name to show in a list of windows-and-morphs to represent the receiver" 225542 225543 ^ self knownName ifNil: [self class name]! ! 225544 225545!Morph methodsFor: 'naming' stamp: 'gm 2/22/2003 13:16'! 225546name: aName 225547 (aName isString) ifTrue: [self setNameTo: aName]! ! 225548 225549!Morph methodsFor: 'naming' stamp: 'dgd 2/16/2003 21:57'! 225550setNamePropertyTo: aName 225551 "change the receiver's externalName" 225552 self assureExtension externalName: aName! ! 225553 225554!Morph methodsFor: 'naming' stamp: 'yo 12/3/2004 17:02'! 225555setNameTo: aName 225556 | nameToUse nameString | 225557 nameToUse := aName ifNotNil: 225558 [(nameString := aName asString) notEmpty ifTrue: [nameString] ifFalse: ['*']]. 225559 self setNamePropertyTo: nameToUse "no Texts here!!"! ! 225560 225561 225562!Morph methodsFor: 'object filein' stamp: 'sd 11/9/2008 14:25'! 225563convertNovember2000DropShadow: varDict using: smartRefStrm 225564 "Work hard to eliminate the DropShadow. Inst vars are already 225565 stored into." 225566 225567 | rend | 225568 submorphs notEmpty 225569 ifTrue: 225570 [rend := submorphs first renderedMorph. 225571 "a text?" 225572 rend setProperty: #hasDropShadow toValue: true. 225573 rend setProperty: #shadowColor toValue: (varDict at: 'color'). 225574 rend setProperty: #shadowOffset toValue: (varDict at: 'shadowOffset'). 225575 rend privateOwner: owner. 225576 extension ifNotNil: [ 225577 extension externalName ifNotNil: [rend setNameTo: self extension externalName]]. 225578 ^rend]. 225579 (rend := Morph new) color: Color transparent. 225580 ^ rend! ! 225581 225582 225583!Morph methodsFor: 'objects from disk' stamp: 'stephane.ducasse 4/14/2009 11:24'! 225584objectForDataStream: refStrm 225585 "I am being written out on an object file" 225586 225587 self prepareToBeSaved. "Amen" 225588 ^self! ! 225589 225590!Morph methodsFor: 'objects from disk' stamp: 'tk 7/11/1998 18:53'! 225591storeDataOn: aDataStream 225592 "Let all Morphs be written out. All owners are weak references. They only go out if the owner is in the tree being written." 225593 | cntInstVars cntIndexedVars ti localInstVars | 225594 225595 "block my owner unless he is written out by someone else" 225596 cntInstVars := self class instSize. 225597 cntIndexedVars := self basicSize. 225598 localInstVars := Morph instVarNames. 225599 ti := 2. 225600 ((localInstVars at: ti) = 'owner') & (Morph superclass == Object) ifFalse: 225601 [self error: 'this method is out of date']. 225602 aDataStream 225603 beginInstance: self class 225604 size: cntInstVars + cntIndexedVars. 225605 1 to: ti-1 do: 225606 [:i | aDataStream nextPut: (self instVarAt: i)]. 225607 aDataStream nextPutWeak: owner. "owner only written if in our tree" 225608 ti+1 to: cntInstVars do: 225609 [:i | aDataStream nextPut: (self instVarAt: i)]. 225610 1 to: cntIndexedVars do: 225611 [:i | aDataStream nextPut: (self basicAt: i)]! ! 225612 225613 225614!Morph methodsFor: 'other' stamp: 'sw 10/30/2001 13:12'! 225615removeAllButFirstSubmorph 225616 "Remove all of the receiver's submorphs other than the first one." 225617 225618 self submorphs allButFirst do: [:m | m delete]! ! 225619 225620 225621!Morph methodsFor: 'other events' stamp: 'sw 8/1/2001 14:08'! 225622menuButtonMouseEnter: event 225623 "The mouse entered a menu-button area; show the menu cursor temporarily" 225624 225625 event hand showTemporaryCursor: Cursor menu! ! 225626 225627!Morph methodsFor: 'other events' stamp: 'sw 8/1/2001 14:09'! 225628menuButtonMouseLeave: event 225629 "The mouse left a menu-button area; restore standard cursor" 225630 225631 event hand showTemporaryCursor: nil! ! 225632 225633 225634!Morph methodsFor: 'parts bin' stamp: 'sw 8/12/2001 02:07'! 225635initializeToStandAlone 225636 "Set up the receiver, created by a #basicNew and now ready to be initialized, as a fully-formed morph suitable for providing a graphic for a parts bin surrogate, and, when such a parts-bin surrogate is clicked on, for attaching to the hand as a viable stand-alone morph. Because of historical precedent, #initialize has been expected to handle this burden, though a great number of morphs actually cannot stand alone. In any case, by default we call the historical #initialize, though unhappily, so that all existing morphs will work no worse than before when using this protocol." 225637 225638 self initialize! ! 225639 225640!Morph methodsFor: 'parts bin' stamp: 'di 11/13/2000 00:49'! 225641inPartsBin 225642 225643 self isPartsDonor ifTrue: [^ true]. 225644 self allOwnersDo: [:m | m isPartsBin ifTrue: [^ true]]. 225645 ^ false 225646! ! 225647 225648!Morph methodsFor: 'parts bin' stamp: 'sw 8/12/97 14:16'! 225649isPartsBin 225650 ^ false! ! 225651 225652!Morph methodsFor: 'parts bin' stamp: 'md 2/27/2006 09:53'! 225653isPartsDonor 225654 "answer whether the receiver is PartsDonor" 225655 extension ifNil: [^ false]. 225656 ^ extension isPartsDonor! ! 225657 225658!Morph methodsFor: 'parts bin' stamp: 'md 2/27/2006 09:59'! 225659isPartsDonor: aBoolean 225660 "change the receiver's isPartDonor property" 225661 (extension isNil and: [aBoolean not]) ifTrue: [^ self]. 225662 self assureExtension isPartsDonor: aBoolean! ! 225663 225664!Morph methodsFor: 'parts bin' stamp: 'di 8/11/1998 13:02'! 225665markAsPartsDonor 225666 "Mark the receiver specially so that mouse actions on it are interpreted as 'tearing off a copy'" 225667 225668 self isPartsDonor: true! ! 225669 225670!Morph methodsFor: 'parts bin' stamp: 'ar 10/6/2000 22:45'! 225671partRepresented 225672 ^self! ! 225673 225674 225675!Morph methodsFor: 'player' stamp: 'sw 8/10/2000 00:06'! 225676assureExternalName 225677 | aName | 225678 ^ (aName := self knownName) ifNil: 225679 [self setNameTo: (aName := self externalName). 225680 ^ aName]! ! 225681 225682!Morph methodsFor: 'player' stamp: 'sw 1/22/2001 14:25'! 225683okayToDuplicate 225684 "Formerly this protocol was used to guard against awkward situations when there were anonymous scripts in the etoy system. Nowadays we just always allow duplication" 225685 225686 ^ true! ! 225687 225688 225689!Morph methodsFor: 'player commands' stamp: 'gk 2/23/2004 21:08'! 225690playSoundNamed: soundName 225691 "Play the sound with the given name. 225692 Does nothing if this image lacks sound playing facilities." 225693 225694 SoundService default playSoundNamed: soundName asString! ! 225695 225696 225697!Morph methodsFor: 'printing' stamp: 'bf 7/17/2003 12:53'! 225698clipText 225699 "Copy the text in the receiver or in its submorphs to the clipboard" 225700 | content | 225701 "My own text" 225702 content := self userString. 225703 "Or in my submorphs" 225704 content ifNil: [ 225705 | list | 225706 list := self allStringsAfter: nil. 225707 list notEmpty ifTrue: [ 225708 content := String streamContents: [:stream | 225709 list do: [:each | stream nextPutAll: each; cr]]]]. 225710 "Did we find something?" 225711 content 225712 ifNil: [self flash "provide feedback"] 225713 ifNotNil: [Clipboard clipboardText: content].! ! 225714 225715!Morph methodsFor: 'printing' stamp: 'dgd 2/22/2003 14:27'! 225716colorString: aColor 225717 aColor isNil ifTrue: [^'nil']. 225718 Color colorNames 225719 do: [:colorName | aColor = (Color perform: colorName) ifTrue: [^'Color ' , colorName]]. 225720 ^aColor storeString! ! 225721 225722!Morph methodsFor: 'printing'! 225723constructorString 225724 225725 ^ String streamContents: [:s | self printConstructorOn: s indent: 0]. 225726! ! 225727 225728!Morph methodsFor: 'printing'! 225729fullPrintOn: aStream 225730 225731 aStream nextPutAll: self class name , ' newBounds: ('; 225732 print: bounds; 225733 nextPutAll: ') color: ' , (self colorString: color)! ! 225734 225735!Morph methodsFor: 'printing' stamp: 'RAA 2/1/2001 17:42'! 225736pagesHandledAutomatically 225737 225738 ^false! ! 225739 225740!Morph methodsFor: 'printing'! 225741printConstructorOn: aStream indent: level 225742 225743 ^ self printConstructorOn: aStream indent: level nodeDict: IdentityDictionary new 225744! ! 225745 225746!Morph methodsFor: 'printing'! 225747printConstructorOn: aStream indent: level nodeDict: nodeDict 225748 | nodeString | 225749 (nodeString := nodeDict at: self ifAbsent: [nil]) 225750 ifNotNil: [^ aStream nextPutAll: nodeString]. 225751 submorphs isEmpty ifFalse: [aStream nextPutAll: '(']. 225752 aStream nextPutAll: '('. 225753 self fullPrintOn: aStream. 225754 aStream nextPutAll: ')'. 225755 submorphs isEmpty ifTrue: [^ self]. 225756 submorphs size <= 4 225757 ifTrue: 225758 [aStream crtab: level+1; 225759 nextPutAll: 'addAllMorphs: (Array'. 225760 1 to: submorphs size do: 225761 [:i | aStream crtab: level+1; nextPutAll: 'with: '. 225762 (submorphs at: i) printConstructorOn: aStream indent: level+1 nodeDict: nodeDict]. 225763 aStream nextPutAll: '))'] 225764 ifFalse: 225765 [aStream crtab: level+1; 225766 nextPutAll: 'addAllMorphs: ((Array new: ', submorphs size printString, ')'. 225767 1 to: submorphs size do: 225768 [:i | 225769 aStream crtab: level+1; nextPutAll: 'at: ', i printString, ' put: '. 225770 (submorphs at: i) printConstructorOn: aStream indent: level+1 nodeDict: nodeDict. 225771 aStream nextPutAll: ';']. 225772 aStream crtab: level+1; nextPutAll: 'yourself))']! ! 225773 225774!Morph methodsFor: 'printing' stamp: 'dgd 2/22/2003 19:05'! 225775printOn: aStream 225776 | aName | 225777 super printOn: aStream. 225778 (aName := self knownName) notNil 225779 ifTrue: [aStream nextPutAll: '<' , aName , '>']. 225780 aStream nextPutAll: '('. 225781 aStream 225782 print: self identityHash; 225783 nextPutAll: ')'! ! 225784 225785!Morph methodsFor: 'printing' stamp: 'jm 5/28/1998 18:00'! 225786printStructureOn: aStream indent: tabCount 225787 225788 tabCount timesRepeat: [aStream tab]. 225789 self printOn: aStream. 225790 aStream cr. 225791 self submorphsDo: [:m | m printStructureOn: aStream indent: tabCount + 1]. 225792! ! 225793 225794!Morph methodsFor: 'printing' stamp: 'sw 10/27/2000 17:45'! 225795reportableSize 225796 "Answer a size worth reporting as the receiver's size in a list view" 225797 225798 | total | 225799 total := super reportableSize. 225800 submorphs do: 225801 [:m | total := total + m reportableSize]. 225802 ^ total! ! 225803 225804!Morph methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 10:06'! 225805structureString 225806 "Return a string that showing this morph and all its submorphs in an indented list that reflects its structure." 225807 225808 | s | 225809 s := (String new: 1000) writeStream. 225810 self printStructureOn: s indent: 0. 225811 ^ s contents 225812! ! 225813 225814 225815!Morph methodsFor: 'rotate scale and flex' stamp: 'sw 3/30/2005 03:44'! 225816addFlexShell 225817 "Wrap a rotating and scaling shell around this morph." 225818 225819 | oldHalo flexMorph myWorld anIndex | 225820 225821 myWorld := self world. 225822 oldHalo := self halo. 225823 anIndex := self owner submorphIndexOf: self. 225824 self owner addMorph: (flexMorph := self newTransformationMorph asFlexOf: self) 225825 asElementNumber: anIndex. 225826 self transferStateToRenderer: flexMorph. 225827 oldHalo ifNotNil: [oldHalo setTarget: flexMorph]. 225828 myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: flexMorph]. 225829 225830 ^ flexMorph! ! 225831 225832!Morph methodsFor: 'rotate scale and flex' stamp: 'di 11/28/2001 18:22'! 225833addFlexShellIfNecessary 225834 "If this morph requires a flex shell to scale or rotate, 225835 then wrap it in one and return it. 225836 Polygons, eg, may override to return themselves." 225837 225838 ^ self addFlexShell! ! 225839 225840!Morph methodsFor: 'rotate scale and flex' stamp: 'ar 11/24/1998 14:19'! 225841keepsTransform 225842 "Return true if the receiver will keep it's transform while being grabbed by a hand." 225843 ^false! ! 225844 225845!Morph methodsFor: 'rotate scale and flex' stamp: 'ar 2/16/1999 18:59'! 225846newTransformationMorph 225847 ^TransformationMorph new! ! 225848 225849!Morph methodsFor: 'rotate scale and flex' stamp: 'mu 3/29/2004 17:33'! 225850removeFlexShell 225851 self isFlexed 225852 ifTrue: [self owner removeFlexShell]! ! 225853 225854!Morph methodsFor: 'rotate scale and flex' stamp: 'jm 4/25/1998 05:19'! 225855rotationDegrees 225856 "Default implementation." 225857 225858 ^ 0.0 225859! ! 225860 225861 225862!Morph methodsFor: 'rounding' stamp: 'mk 8/7/2005 10:03'! 225863cornerStyle: aSymbol 225864 "This method makes it possible to set up desired corner style. aSymbol has to be one of: 225865 #square 225866 #rounded" 225867 225868 aSymbol == #square 225869 ifTrue:[self removeProperty: #cornerStyle] 225870 ifFalse:[self setProperty: #cornerStyle toValue: aSymbol]. 225871 self changed! ! 225872 225873!Morph methodsFor: 'rounding' stamp: 'dgd 9/6/2003 18:27'! 225874roundedCornersString 225875 "Answer the string to put in a menu that will invite the user to 225876 switch to the opposite corner-rounding mode" 225877 ^ (self wantsRoundedCorners 225878 ifTrue: ['<yes>'] 225879 ifFalse: ['<no>']) 225880 , 'round corners' translated! ! 225881 225882!Morph methodsFor: 'rounding' stamp: 'ar 12/25/2001 19:44'! 225883toggleCornerRounding 225884 self cornerStyle == #rounded 225885 ifTrue: [self cornerStyle: #square] 225886 ifFalse: [self cornerStyle: #rounded]. 225887 self changed! ! 225888 225889!Morph methodsFor: 'rounding' stamp: 'ar 12/22/2001 22:45'! 225890wantsRoundedCorners 225891 "Return true if the receiver wants its corners rounded" 225892 ^ self cornerStyle == #rounded! ! 225893 225894 225895!Morph methodsFor: 'scripting' stamp: 'stephane.ducasse 11/28/2008 10:25'! 225896defaultFloatPrecisionFor: aGetSelector 225897 "Answer a number indicating the default float precision to be used in a numeric readout for which the receiver provides the data. Individual morphs can override this. Showing fractional values for readouts of getCursor was in response to an explicit request from ack" 225898 225899 (self renderedMorph decimalPlacesForGetter: aGetSelector) ifNotNil: [:places | ^ (Utilities floatPrecisionForDecimalPlaces: places)]. 225900 225901 (#(getNumericValue getCursorWrapped getScaleFactor getAlpha) includes: aGetSelector) 225902 ifTrue: 225903 [^ 0.01]. 225904 ^ 1! ! 225905 225906 225907!Morph methodsFor: 'selected object' stamp: 'dgd 8/28/2004 16:30'! 225908selectedObject 225909 "answer the selected object for the hand or nil is none" 225910 ^ self primaryHand selectedObject! ! 225911 225912 225913!Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:27'! 225914arrangeToStartStepping 225915 "Arrange to start getting sent the 'step' message, but don't do that initial #step call that startStepping does" 225916 225917 self arrangeToStartSteppingIn: self world! ! 225918 225919!Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:26'! 225920arrangeToStartSteppingIn: aWorld 225921 "Start getting sent the 'step' message in aWorld. Like startSteppingIn:, but without the initial one to get started'" 225922 aWorld ifNotNil: 225923 [aWorld startStepping: self. 225924 self changed]! ! 225925 225926!Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:28'! 225927isStepping 225928 "Return true if the receiver is currently stepping in its world" 225929 | aWorld | 225930 ^ (aWorld := self world) 225931 ifNil: [false] 225932 ifNotNil: [aWorld isStepping: self]! ! 225933 225934!Morph methodsFor: 'stepping and presenter' stamp: 'ar 10/22/2000 16:43'! 225935isSteppingSelector: aSelector 225936 "Return true if the receiver is currently stepping in its world" 225937 | aWorld | 225938 ^ (aWorld := self world) 225939 ifNil: [false] 225940 ifNotNil: [aWorld isStepping: self selector: aSelector]! ! 225941 225942!Morph methodsFor: 'stepping and presenter'! 225943start 225944 "Start running my script. For ordinary morphs, this means start stepping." 225945 225946 self startStepping. 225947! ! 225948 225949!Morph methodsFor: 'stepping and presenter' stamp: 'ar 1/31/2001 13:07'! 225950startStepping 225951 "Start getting sent the 'step' message." 225952 self startStepping: #stepAt: at: Time millisecondClockValue arguments: nil stepTime: nil.! ! 225953 225954!Morph methodsFor: 'stepping and presenter' stamp: 'sw 7/19/1998 11:51'! 225955startSteppingIn: aWorld 225956 "Start getting sent the 'step' message in aWorld" 225957 225958 self step. "one to get started!!" 225959 aWorld ifNotNil: [aWorld startStepping: self]. 225960 self changed! ! 225961 225962!Morph methodsFor: 'stepping and presenter' stamp: 'ar 10/22/2000 16:42'! 225963startSteppingSelector: aSelector 225964 "Start getting sent the 'step' message." 225965 self startStepping: aSelector at: Time millisecondClockValue arguments: nil stepTime: nil.! ! 225966 225967!Morph methodsFor: 'stepping and presenter' stamp: 'ar 10/22/2000 16:36'! 225968startStepping: aSelector at: scheduledTime arguments: args stepTime: stepTime 225969 "Start stepping the receiver" 225970 | w | 225971 w := self world. 225972 w ifNotNil: [ 225973 w startStepping: self at: scheduledTime selector: aSelector arguments: args stepTime: stepTime. 225974 self changed].! ! 225975 225976!Morph methodsFor: 'stepping and presenter' stamp: 'ar 2/12/2001 17:04'! 225977step 225978 "Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message. The generic version dispatches control to the player, if any. The nasty circumlocation about owner's transformation is necessitated by the flexing problem that the player remains in the properties dictionary both of the flex and the real morph. In the current architecture, only the top renderer's pointer to the player should actually be honored for the purpose of firing." 225979! ! 225980 225981!Morph methodsFor: 'stepping and presenter' stamp: 'stephane.ducasse 11/27/2008 22:31'! 225982stepAt: millisecondClockValue 225983 "Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message. 225984 The millisecondClockValue parameter gives the value of the millisecond clock at the moment of dispatch. 225985 Default is to dispatch to the parameterless step method for the morph, but this protocol makes it possible for some morphs to do differing things depending on the clock value" 225986 225987 self step 225988! ! 225989 225990!Morph methodsFor: 'stepping and presenter'! 225991stop 225992 "Stop running my script. For ordinary morphs, this means stop stepping." 225993 225994 self stopStepping. 225995! ! 225996 225997!Morph methodsFor: 'stepping and presenter' stamp: 'ar 12/15/2000 00:00'! 225998stopStepping 225999 "Stop getting sent the 'step' message." 226000 226001 | w | 226002 w := self world. 226003 w ifNotNil: [w stopStepping: self]. 226004! ! 226005 226006!Morph methodsFor: 'stepping and presenter' stamp: 'ar 12/15/2000 00:00'! 226007stopSteppingSelector: aSelector 226008 "Stop getting sent the given message." 226009 | w | 226010 w := self world. 226011 w ifNotNil: [w stopStepping: self selector: aSelector]. 226012! ! 226013 226014!Morph methodsFor: 'stepping and presenter' stamp: 'sw 10/11/1999 12:59'! 226015stopSteppingSelfAndSubmorphs 226016 self allMorphsDo: [:m | m stopStepping] 226017! ! 226018 226019 226020!Morph methodsFor: 'structure' stamp: 'ar 3/18/2001 00:11'! 226021activeHand 226022 ^ActiveHand! ! 226023 226024!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 01:00'! 226025allOwners 226026 "Return the owners of the reciever" 226027 226028 ^ Array streamContents: [:strm | self allOwnersDo: [:m | strm nextPut: m]]! ! 226029 226030!Morph methodsFor: 'structure' stamp: 'ar 9/14/2000 16:47'! 226031allOwnersDo: aBlock 226032 "Evaluate aBlock with all owners of the receiver" 226033 owner ifNotNil:[^owner withAllOwnersDo: aBlock].! ! 226034 226035!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:48'! 226036firstOwnerSuchThat: conditionBlock 226037 226038 self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [^ m]]. 226039 ^ nil 226040! ! 226041 226042!Morph methodsFor: 'structure' stamp: 'ar 10/3/2000 15:36'! 226043hasOwner: aMorph 226044 "Return true if the receiver has aMorph in its owner chain" 226045 aMorph ifNil:[^true]. 226046 self allOwnersDo:[:m| m = aMorph ifTrue:[^true]]. 226047 ^false! ! 226048 226049!Morph methodsFor: 'structure' stamp: 'dgd 9/1/2004 17:17'! 226050isInDockingBar 226051 "answer if the receiver is in a menu bar" 226052 ^ (owner notNil) and: [owner isDockingBar]! ! 226053 226054!Morph methodsFor: 'structure' stamp: 'dgd 9/18/2004 15:56'! 226055isInSystemWindow 226056 "answer if the receiver is in a system window" 226057 ^ owner isMorph and:[owner isSystemWindow or:[owner isInSystemWindow]]! ! 226058 226059!Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 19:05'! 226060isInWorld 226061 "Return true if this morph is in a world." 226062 226063 ^self world notNil! ! 226064 226065!Morph methodsFor: 'structure' stamp: 'sw 8/29/2000 14:55'! 226066morphPreceding: aSubmorph 226067 "Answer the morph immediately preceding aSubmorph, or nil if none" 226068 226069 | anIndex | 226070 anIndex := submorphs indexOf: aSubmorph ifAbsent: [^ nil]. 226071 ^ anIndex > 1 226072 ifTrue: 226073 [submorphs at: (anIndex - 1)] 226074 ifFalse: 226075 [nil]! ! 226076 226077!Morph methodsFor: 'structure' stamp: 'di 11/12/2000 16:13'! 226078nearestOwnerThat: conditionBlock 226079 "Return the first enclosing morph for which aBlock evaluates to true, or nil if none" 226080 226081 ^ self firstOwnerSuchThat: conditionBlock 226082! ! 226083 226084!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:50'! 226085outermostMorphThat: conditionBlock 226086 "Return the outermost containing morph for which aBlock is true, or nil if none" 226087 226088 | outermost | 226089 self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [outermost := m]]. 226090 ^ outermost! ! 226091 226092!Morph methodsFor: 'structure' stamp: 'marcus.denker 7/24/2009 14:07'! 226093outermostWorldMorph 226094 226095 ^World.! ! 226096 226097!Morph methodsFor: 'structure'! 226098owner 226099 "Returns the owner of this morph, which may be nil." 226100 226101 ^ owner! ! 226102 226103!Morph methodsFor: 'structure' stamp: 'di 11/12/2000 16:18'! 226104ownerThatIsA: aClass 226105 "Return the first enclosing morph that is a kind of aClass, or nil if none" 226106 226107 ^ self firstOwnerSuchThat: [:m | m isKindOf: aClass]! ! 226108 226109!Morph methodsFor: 'structure' stamp: 'RAA 6/13/2000 15:01'! 226110primaryHand 226111 226112 | outer | 226113 outer := self outermostWorldMorph ifNil: [^ nil]. 226114 ^ outer activeHand ifNil: [outer firstHand]! ! 226115 226116!Morph methodsFor: 'structure' stamp: 'wiz 12/7/2006 15:12'! 226117renderedMorph 226118 "This now gets overridden by rendering morphs." 226119 226120 ^self! ! 226121 226122!Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 14:34'! 226123root 226124 "Return the root of the composite morph containing the receiver. The owner of the root is either nil, a WorldMorph, or a HandMorph. If the receiver's owner is nil, the root is the receiver itself. This method always returns a morph." 226125 226126 (owner isNil or: [owner isWorldOrHandMorph]) ifTrue: [^self]. 226127 ^owner root! ! 226128 226129!Morph methodsFor: 'structure' stamp: 'di 8/4/1999 15:41'! 226130rootAt: location 226131 "Just return myself, unless I am a WorldWindow. 226132 If so, then return the appropriate root in that world" 226133 226134 ^ self! ! 226135 226136!Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 19:06'! 226137topRendererOrSelf 226138 "Answer the topmost renderer for this morph, or this morph itself if it has no renderer. See the comment in Morph>isRenderer." 226139 226140 | top topsOwner | 226141 owner ifNil: [^self]. 226142 self isWorldMorph ifTrue: [^self]. "ignore scaling of this world" 226143 top := self. 226144 topsOwner := top owner. 226145 [topsOwner notNil and: [topsOwner isRenderer]] whileTrue: 226146 [top := topsOwner. 226147 topsOwner := top owner]. 226148 ^top! ! 226149 226150!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:59'! 226151withAllOwners 226152 "Return the receiver and all its owners" 226153 226154 ^ Array streamContents: [:strm | self withAllOwnersDo: [:m | strm nextPut: m]]! ! 226155 226156!Morph methodsFor: 'structure' stamp: 'ar 9/14/2000 16:48'! 226157withAllOwnersDo: aBlock 226158 "Evaluate aBlock with the receiver and all of its owners" 226159 aBlock value: self. 226160 owner ifNotNil:[^owner withAllOwnersDo: aBlock].! ! 226161 226162!Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 14:36'! 226163world 226164 ^owner isNil ifTrue: [nil] ifFalse: [owner world]! ! 226165 226166 226167!Morph methodsFor: 'submorphs-accessing' stamp: 'di 11/14/2001 12:50'! 226168allKnownNames 226169 "Return a list of all known names based on the scope of the receiver. Does not include the name of the receiver itself. Items in parts bins are excluded. Reimplementors (q.v.) can extend the list" 226170 226171 ^ Array streamContents: 226172 [:s | self allSubmorphNamesDo: [:n | s nextPut: n]] 226173! ! 226174 226175!Morph methodsFor: 'submorphs-accessing' stamp: 'stephane.ducasse 4/13/2009 20:31'! 226176allMorphs 226177 "Return a collection containing all morphs in this composite morph (including the receiver)." 226178 226179 | all | 226180 all := OrderedCollection new: 100. 226181 self allMorphsDo: [:m | all add: m]. 226182 ^ all! ! 226183 226184!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:27'! 226185allMorphsDo: aBlock 226186 "Evaluate the given block for all morphs in this composite morph (including the receiver)." 226187 226188 submorphs do: [:m | m allMorphsDo: aBlock]. 226189 aBlock value: self! ! 226190 226191!Morph methodsFor: 'submorphs-accessing' stamp: 'alain.plantec 6/8/2009 23:44'! 226192allNonSubmorphMorphs 226193 "Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy" 226194 226195 ^ OrderedCollection new! ! 226196 226197!Morph methodsFor: 'submorphs-accessing' stamp: 'marcus.denker 11/10/2008 10:04'! 226198allSubmorphNamesDo: nameBlock 226199 "Return a list of all known names of submorphs and nested submorphs of the receiver, based on the scope of the receiver. Items in parts bins are excluded" 226200 226201 self isPartsBin ifTrue: [^ self]. "Don't report names from parts bins" 226202 self submorphsDo: 226203 [:m | m knownName ifNotNil: [:n | nameBlock value: n]. 226204 m allSubmorphNamesDo: nameBlock]. 226205! ! 226206 226207!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 8/31/2004 16:53'! 226208dockingBars 226209 "Answer the receiver's dockingBars" 226210 ^ self submorphs 226211 select: [:each | each isDockingBar] 226212! ! 226213 226214!Morph methodsFor: 'submorphs-accessing' stamp: 'rhi 9/10/2000 12:12'! 226215findA: aClass 226216 "Return the first submorph of the receiver that is descended from the given class. Return nil if there is no such submorph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart." 226217 226218 ^self submorphs 226219 detect: [:p | p isKindOf: aClass] 226220 ifNone: [nil]! ! 226221 226222!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 1/9/2001 12:30'! 226223findDeeplyA: aClass 226224 "Return a morph in the submorph tree of the receiver that is descended from the given class. Return nil if there is no such morph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart." 226225 226226 ^ (self allMorphs copyWithout: self) 226227 detect: [:p | p isKindOf: aClass] 226228 ifNone: [nil]! ! 226229 226230!Morph methodsFor: 'submorphs-accessing' stamp: 'LC 9/28/1999 19:12'! 226231findDeepSubmorphThat: block1 ifAbsent: block2 226232 self 226233 allMorphsDo: [:m | (block1 value: m) 226234 == true ifTrue: [^ m]]. 226235 ^ block2 value! ! 226236 226237!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 3/17/2001 15:32'! 226238findSubmorphBinary: aBlock 226239 "Use binary search for finding a specific submorph of the receiver. Caller must be certain that the ordering holds for the submorphs." 226240 ^submorphs findBinary: aBlock ifNone:[nil].! ! 226241 226242!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:31'! 226243firstSubmorph 226244 ^submorphs first! ! 226245 226246!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32'! 226247hasSubmorphs 226248 ^submorphs notEmpty! ! 226249 226250!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 7/3/1998 17:11'! 226251hasSubmorphWithProperty: aSymbol 226252 submorphs detect: [:m | m hasProperty: aSymbol] ifNone: [^ false]. 226253 ^ true! ! 226254 226255!Morph methodsFor: 'submorphs-accessing' stamp: 'tk 10/31/2000 11:04'! 226256indexOfMorphAbove: aPoint 226257 "Return index of lowest morph whose bottom is above aPoint. 226258 Will return 0 if the first morph is not above aPoint." 226259 226260 submorphs withIndexDo: [:mm :ii | 226261 mm fullBounds bottom >= aPoint y ifTrue: [^ ii - 1]]. 226262 ^ submorphs size! ! 226263 226264!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32'! 226265lastSubmorph 226266 ^submorphs last! ! 226267 226268!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 9/6/2004 14:17'! 226269mainDockingBars 226270 "Answer the receiver's main dockingBars" 226271 ^ self dockingBars 226272 select: [:each | each hasProperty: #mainDockingBarTimeStamp]! ! 226273 226274!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/8/2000 15:40'! 226275morphsAt: aPoint 226276 "Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself. The order is deepest embedding first." 226277 ^self morphsAt: aPoint unlocked: false! ! 226278 226279!Morph methodsFor: 'submorphs-accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:06'! 226280morphsAt: aPoint behind: aMorph unlocked: aBool 226281 "Return all morphs at aPoint that are behind frontMorph; if aBool is true return only unlocked, visible morphs." 226282 226283 | isBack found all tfm | 226284 all := (aMorph isNil or: [owner isNil]) 226285 ifTrue: 226286 ["Traverse down" 226287 226288 (self fullBounds containsPoint: aPoint) ifFalse: [^#()]. 226289 (aBool and: [self isLocked or: [self visible not]]) ifTrue: [^#()]. 226290 nil] 226291 ifFalse: 226292 ["Traverse up" 226293 226294 tfm := self transformedFrom: owner. 226295 all := owner 226296 morphsAt: (tfm localPointToGlobal: aPoint) 226297 behind: self 226298 unlocked: aBool. 226299 WriteStream with: all]. 226300 isBack := aMorph isNil. 226301 self submorphsDo: 226302 [:m | 226303 isBack 226304 ifTrue: 226305 [tfm := m transformedFrom: self. 226306 found := m 226307 morphsAt: (tfm globalPointToLocal: aPoint) 226308 behind: nil 226309 unlocked: aBool. 226310 found notEmpty 226311 ifTrue: 226312 [all ifNil: [all := Array new writeStream]. 226313 all nextPutAll: found]]. 226314 m == aMorph ifTrue: [isBack := true]]. 226315 (isBack and: [self containsPoint: aPoint]) 226316 ifTrue: 226317 [all ifNil: [^Array with: self]. 226318 all nextPut: self]. 226319 ^all ifNil: [#()] ifNotNil: [all contents]! ! 226320 226321!Morph methodsFor: 'submorphs-accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:06'! 226322morphsAt: aPoint unlocked: aBool 226323 "Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself. The order is deepest embedding first." 226324 | mList | 226325 mList := Array new writeStream. 226326 self morphsAt: aPoint unlocked: aBool do:[:m| mList nextPut: m]. 226327 ^mList contents! ! 226328 226329!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/8/2000 15:37'! 226330morphsAt: aPoint unlocked: aBool do: aBlock 226331 "Evaluate aBlock with all the morphs starting at the receiver which appear at aPoint. If aBool is true take only visible, unlocked morphs into account." 226332 | tfm | 226333 (self fullBounds containsPoint: aPoint) ifFalse:[^self]. 226334 (aBool and:[self isLocked or:[self visible not]]) ifTrue:[^self]. 226335 self submorphsDo:[:m| 226336 tfm := m transformedFrom: self. 226337 m morphsAt: (tfm globalPointToLocal: aPoint) unlocked: aBool do: aBlock]. 226338 (self containsPoint: aPoint) ifTrue:[aBlock value: self].! ! 226339 226340!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 9/9/2000 17:31'! 226341morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock 226342 "Evaluate aBlock with all top-level morphs in front of someMorph that overlap with the given rectangle. someMorph is either an immediate child of the receiver or nil (in which case all submorphs of the receiver are enumerated)." 226343 self submorphsDo:[:m| 226344 m == someMorph ifTrue:["Try getting out quickly" 226345 owner ifNil:[^self]. 226346 ^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock]. 226347 (m fullBoundsInWorld intersects: aRectangle) 226348 ifTrue:[aBlock value: m]]. 226349 owner ifNil:[^self]. 226350 ^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock.! ! 226351 226352!Morph methodsFor: 'submorphs-accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:06'! 226353morphsInFrontOverlapping: aRectangle 226354 "Return all top-level morphs in front of someMorph that overlap with the given rectangle." 226355 | morphList | 226356 morphList := Array new writeStream. 226357 self morphsInFrontOf: nil overlapping: aRectangle do:[:m | morphList nextPut: m]. 226358 ^morphList contents! ! 226359 226360!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 9/9/2000 17:31'! 226361morphsInFrontOverlapping: aRectangle do: aBlock 226362 "Evaluate aBlock with all top-level morphs in front of someMorph that overlap with the given rectangle." 226363 ^self morphsInFrontOf: nil overlapping: aRectangle do: aBlock! ! 226364 226365!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 8/13/2003 11:32'! 226366noteNewOwner: aMorph 226367 "I have just been added as a submorph of aMorph"! ! 226368 226369!Morph methodsFor: 'submorphs-accessing' stamp: 'RAA 6/11/2000 20:41'! 226370rootMorphsAtGlobal: aPoint 226371 "Return the list of root morphs containing the given point, excluding the receiver. 226372 ar 11/8/1999: Moved into morph for an incredibly ugly hack in 3D worlds" 226373 226374 ^ self rootMorphsAt: (self pointFromWorld: aPoint)! ! 226375 226376!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/8/2000 15:44'! 226377rootMorphsAt: aPoint 226378 "Return the list of root morphs containing the given point, excluding the receiver. 226379 ar 11/8/1999: Moved into morph for an incredibly ugly hack in 3D worlds" 226380self flag: #arNote. "check this at some point" 226381 ^ self submorphs select: 226382 [:m | (m fullContainsPoint: aPoint) and: [m isLocked not]]! ! 226383 226384!Morph methodsFor: 'submorphs-accessing' stamp: 'michael.rueger 3/9/2009 18:50'! 226385shuffleSubmorphs 226386 "Randomly shuffle the order of my submorphs. Don't call this method lightly!!" 226387 226388 self invalidRect: self fullBounds. 226389 submorphs := submorphs shuffled. 226390 self layoutChanged! ! 226391 226392!Morph methodsFor: 'submorphs-accessing' stamp: 'tk 10/20/2000 13:12'! 226393submorphAfter 226394 "Return the submorph after (behind) me, or nil" 226395 | ii | 226396 owner ifNil: [^ nil]. 226397 ^ (ii := owner submorphIndexOf: self) = owner submorphs size 226398 ifTrue: [nil] 226399 ifFalse: [owner submorphs at: ii+1]. 226400 226401! ! 226402 226403!Morph methodsFor: 'submorphs-accessing' stamp: 'tk 10/20/2000 13:13'! 226404submorphBefore 226405 "Return the submorph after (behind) me, or nil" 226406 | ii | 226407 owner ifNil: [^ nil]. 226408 ^ (ii := owner submorphIndexOf: self) = 1 226409 ifTrue: [nil] 226410 ifFalse: [owner submorphs at: ii-1]. 226411 226412! ! 226413 226414!Morph methodsFor: 'submorphs-accessing'! 226415submorphCount 226416 226417 ^ submorphs size! ! 226418 226419!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 4/9/98 14:26'! 226420submorphNamed: aName 226421 ^ self submorphNamed: aName ifNone: [nil]! ! 226422 226423!Morph methodsFor: 'submorphs-accessing' stamp: 'gm 2/22/2003 13:16'! 226424submorphNamed: aName ifNone: aBlock 226425 "Find the first submorph with this name, or a button with an action selector of that name" 226426 226427 | sub args | 226428 self submorphs do: [:p | p knownName = aName ifTrue: [^p]]. 226429 self submorphs do: 226430 [:button | 226431 (button respondsTo: #actionSelector) 226432 ifTrue: [button actionSelector == aName ifTrue: [^button]]. 226433 ((button respondsTo: #arguments) and: [(args := button arguments) notNil]) 226434 ifTrue: [(args at: 2 ifAbsent: [nil]) == aName ifTrue: [^button]]. 226435 (button isAlignmentMorph) 226436 ifTrue: [(sub := button submorphNamed: aName ifNone: [nil]) ifNotNil: [^sub]]]. 226437 ^aBlock value! ! 226438 226439!Morph methodsFor: 'submorphs-accessing' stamp: 'efc 8/6/2005 11:35'! 226440submorphs 226441 "This method returns my actual submorphs collection. Modifying the collection directly could be dangerous; make a copy if you need to alter it." 226442 ^ submorphs ! ! 226443 226444!Morph methodsFor: 'submorphs-accessing' stamp: 'di 11/4/97 14:30'! 226445submorphsBehind: aMorph do: aBlock 226446 | behind | 226447 behind := false. 226448 submorphs do: 226449 [:m | m == aMorph ifTrue: [behind := true] 226450 ifFalse: [behind ifTrue: [aBlock value: m]]]. 226451! ! 226452 226453!Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:35'! 226454submorphsDo: aBlock 226455 submorphs do: aBlock! ! 226456 226457!Morph methodsFor: 'submorphs-accessing' stamp: 'di 11/4/97 14:29'! 226458submorphsInFrontOf: aMorph do: aBlock 226459 | behind | 226460 behind := false. 226461 submorphs do: 226462 [:m | m == aMorph ifTrue: [behind := true] 226463 ifFalse: [behind ifFalse: [aBlock value: m]]]. 226464! ! 226465 226466!Morph methodsFor: 'submorphs-accessing'! 226467submorphsReverseDo: aBlock 226468 226469 submorphs reverseDo: aBlock.! ! 226470 226471!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 8/15/97 22:03'! 226472submorphsSatisfying: aBlock 226473 ^ submorphs select: [:m | (aBlock value: m) == true]! ! 226474 226475!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 10/26/1999 23:42'! 226476submorphThat: block1 ifNone: block2 226477 ^ submorphs detect: [:m | (block1 value: m) == true] ifNone: [block2 value] 226478 ! ! 226479 226480!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 7/3/1998 18:47'! 226481submorphWithProperty: aSymbol 226482 ^ submorphs detect: [:aMorph | aMorph hasProperty: aSymbol] ifNone: [nil]! ! 226483 226484 226485!Morph methodsFor: 'submorphs-add/remove' stamp: 'tk 12/15/1998 14:23'! 226486abandon 226487 "Like delete, but we really intend not to use this morph again. Clean up a few things." 226488 226489 self delete! ! 226490 226491!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/28/2001 08:39'! 226492actWhen 226493 "Answer when the receiver, probably being used as a button, should have its action triggered" 226494 226495 ^ self valueOfProperty: #actWhen ifAbsentPut: [#buttonDown]! ! 226496 226497!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/25/2001 10:23'! 226498actWhen: aButtonPhase 226499 "Set the receiver's actWhen trait" 226500 226501 self setProperty: #actWhen toValue: aButtonPhase! ! 226502 226503!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 23:28'! 226504addAllMorphs: aCollection 226505 ^self privateAddAllMorphs: aCollection atIndex: submorphs size! ! 226506 226507!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 23:29'! 226508addAllMorphs: aCollection after: anotherMorph 226509 ^self privateAddAllMorphs: aCollection 226510 atIndex: (submorphs indexOf: anotherMorph ifAbsent: [submorphs size])! ! 226511 226512!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:55'! 226513addMorphBack: aMorph 226514 ^self privateAddMorph: aMorph atIndex: submorphs size+1! ! 226515 226516!Morph methodsFor: 'submorphs-add/remove' stamp: 'RAA 12/15/2000 19:34'! 226517addMorphCentered: aMorph 226518 226519 aMorph position: bounds center - (aMorph extent // 2). 226520 self addMorphFront: aMorph. 226521! ! 226522 226523!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 12/16/2001 21:08'! 226524addMorphFrontFromWorldPosition: aMorph 226525 ^self addMorphFront: aMorph fromWorldPosition: aMorph positionInWorld.! ! 226526 226527!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:54'! 226528addMorphFront: aMorph 226529 ^self privateAddMorph: aMorph atIndex: 1! ! 226530 226531!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 11/15/1998 23:42'! 226532addMorphFront: aMorph fromWorldPosition: wp 226533 226534 self addMorphFront: aMorph. 226535 aMorph position: (self transformFromWorld globalPointToLocal: wp)! ! 226536 226537!Morph methodsFor: 'submorphs-add/remove'! 226538addMorph: aMorph 226539 226540 self addMorphFront: aMorph.! ! 226541 226542!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:54'! 226543addMorph: newMorph after: aMorph 226544 "Add the given morph as one of my submorphs, inserting it after anotherMorph" 226545 ^self privateAddMorph: newMorph atIndex: (submorphs indexOf: aMorph)+1! ! 226546 226547!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/7/2000 08:29'! 226548addMorph: aMorph asElementNumber: aNumber 226549 "Add the given morph so that it becomes the aNumber'th element of my submorph list. If aMorph is already one of my submorphs, reposition it" 226550 226551 (submorphs includes: aMorph) ifTrue: 226552 [aMorph privateDelete]. 226553 (aNumber <= submorphs size) 226554 ifTrue: 226555 [self addMorph: aMorph inFrontOf: (submorphs at: aNumber)] 226556 ifFalse: 226557 [self addMorphBack: aMorph] 226558! ! 226559 226560!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:44'! 226561addMorph: newMorph behind: aMorph 226562 "Add a morph to the list of submorphs behind the specified morph" 226563 ^self privateAddMorph: newMorph atIndex: (submorphs indexOf: aMorph) + 1. 226564! ! 226565 226566!Morph methodsFor: 'submorphs-add/remove' stamp: 'JW 2/1/2001 12:52'! 226567addMorph: aMorph fullFrame: aLayoutFrame 226568 226569 aMorph layoutFrame: aLayoutFrame. 226570 aMorph hResizing: #spaceFill; vResizing: #spaceFill. 226571 self addMorph: aMorph. 226572 226573! ! 226574 226575!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:45'! 226576addMorph: newMorph inFrontOf: aMorph 226577 "Add a morph to the list of submorphs in front of the specified morph" 226578 ^self privateAddMorph: newMorph atIndex: ((submorphs indexOf: aMorph) max: 1).! ! 226579 226580!Morph methodsFor: 'submorphs-add/remove' stamp: 'dgd 2/22/2003 14:30'! 226581comeToFront 226582 | outerMorph | 226583 outerMorph := self topRendererOrSelf. 226584 (outerMorph owner isNil or: [outerMorph owner hasSubmorphs not]) 226585 ifTrue: [^self]. 226586 outerMorph owner firstSubmorph == outerMorph 226587 ifFalse: [outerMorph owner addMorphFront: outerMorph]! ! 226588 226589!Morph methodsFor: 'submorphs-add/remove' stamp: 'di 10/27/97 23:26'! 226590copyWithoutSubmorph: sub 226591 "Needed to get a morph to draw without one of its submorphs. 226592 NOTE: This must be thrown away immediately after use." 226593 ^ self clone privateSubmorphs: (submorphs copyWithout: sub)! ! 226594 226595!Morph methodsFor: 'submorphs-add/remove' stamp: 'stephane.ducasse 11/12/2008 10:24'! 226596delete 226597 "Remove the receiver as a submorph of its owner and make its 226598 new owner be nil." 226599 226600 | aWorld | 226601 self removeHalo. 226602 aWorld := self world ifNil: [World]. 226603 "Terminate genie recognition focus" 226604 "I encountered a case where the hand was nil, so I put in a little 226605 protection - raa " 226606 " This happens when we are in an MVC project and open 226607 a morphic window. - BG " 226608 aWorld ifNotNil: 226609 [self disableSubmorphFocusForHand: self activeHand. 226610 self activeHand releaseKeyboardFocus: self; 226611 releaseMouseFocus: self.]. 226612 owner ifNotNil:[ self privateDelete].! ! 226613 226614!Morph methodsFor: 'submorphs-add/remove' stamp: 'dgd 9/1/2004 16:26'! 226615deleteDockingBars 226616 "Delete the receiver's docking bars" 226617 self dockingBars 226618 do: [:each | each delete]! ! 226619 226620!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 7/3/1998 11:02'! 226621deleteSubmorphsWithProperty: aSymbol 226622 submorphs copy do: 226623 [:m | (m hasProperty: aSymbol) ifTrue: [m delete]]! ! 226624 226625!Morph methodsFor: 'submorphs-add/remove' stamp: 'adrian_lienhard 7/19/2009 17:35'! 226626dismissViaHalo 226627 "The user has clicked in the delete halo-handle. This provides a hook in case some concomitant action should be taken, or if the particular morph is not one which should be put in the trash can, for example." 226628 226629 | cmd | 226630 self setProperty: #lastPosition toValue: self positionInWorld. 226631 self dismissMorph. 226632 Preferences preserveTrash ifTrue: [ 226633 Preferences slideDismissalsToTrash 226634 ifTrue:[self slideToTrash: nil]. 226635 ]. 226636 226637 cmd := Command new cmdWording: 'dismiss ' translated, self externalName. 226638 cmd undoTarget: ActiveWorld selector: #reintroduceIntoWorld: argument: self. 226639 cmd redoTarget: ActiveWorld selector: #onceAgainDismiss: argument: self. 226640 ActiveWorld rememberCommand: cmd! ! 226641 226642!Morph methodsFor: 'submorphs-add/remove' stamp: 'michael.rueger 3/9/2009 18:48'! 226643goBehind 226644 226645 owner addMorphBack: self. 226646! ! 226647 226648!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/10/2003 18:31'! 226649privateDelete 226650 "Remove the receiver as a submorph of its owner" 226651 owner ifNotNil:[owner removeMorph: self].! ! 226652 226653!Morph methodsFor: 'submorphs-add/remove' stamp: 'nk 10/16/2003 14:08'! 226654removeAllMorphs 226655 | oldMorphs myWorld | 226656 myWorld := self world. 226657 (fullBounds notNil or:[myWorld notNil]) ifTrue:[self invalidRect: self fullBounds]. 226658 submorphs do: [:m | myWorld ifNotNil: [ m outOfWorld: myWorld ]. m privateOwner: nil]. 226659 oldMorphs := submorphs. 226660 submorphs := EmptyArray. 226661 oldMorphs do: [ :m | self removedMorph: m ]. 226662 self layoutChanged. 226663! ! 226664 226665!Morph methodsFor: 'submorphs-add/remove' stamp: 'nk 10/16/2003 14:02'! 226666removeAllMorphsIn: aCollection 226667 "greatly speeds up the removal of *lots* of submorphs" 226668 | set myWorld | 226669 set := IdentitySet new: aCollection size * 4 // 3. 226670 aCollection do: [:each | each owner == self ifTrue: [ set add: each]]. 226671 myWorld := self world. 226672 (fullBounds notNil or:[myWorld notNil]) ifTrue:[self invalidRect: self fullBounds]. 226673 set do: [:m | myWorld ifNotNil: [ m outOfWorld: myWorld ]. m privateOwner: nil]. 226674 submorphs := submorphs reject: [ :each | set includes: each]. 226675 set do: [ :m | self removedMorph: m ]. 226676 self layoutChanged. 226677! ! 226678 226679!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 22:01'! 226680removedMorph: aMorph 226681 "Notify the receiver that aMorph was just removed from its children" 226682! ! 226683 226684!Morph methodsFor: 'submorphs-add/remove' stamp: 'di 10/18/2004 21:50'! 226685removeMorph: aMorph 226686 "Remove the given morph from my submorphs" 226687 | aWorld | 226688 aMorph owner == self ifFalse:[^self]. 226689 aWorld := self world. 226690 aWorld ifNotNil:[ 226691 aMorph outOfWorld: aWorld. 226692 self privateInvalidateMorph: aMorph. 226693 ]. 226694 self privateRemove: aMorph. 226695 aMorph privateOwner: nil. 226696 self removedMorph: aMorph. 226697! ! 226698 226699!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 10/25/1999 23:34'! 226700replaceSubmorph: oldMorph by: newMorph 226701 | index itsPosition w | 226702 oldMorph stopStepping. 226703 itsPosition := oldMorph referencePositionInWorld. 226704 index := submorphs indexOf: oldMorph. 226705 oldMorph privateDelete. 226706 self privateAddMorph: newMorph atIndex: index. 226707 newMorph referencePositionInWorld: itsPosition. 226708 (w := newMorph world) ifNotNil: 226709 [w startSteppingSubmorphsOf: newMorph]! ! 226710 226711!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/1/2000 10:16'! 226712submorphIndexOf: aMorph 226713 "Assuming aMorph to be one of my submorphs, answer where it occurs in my submorph list" 226714 226715 ^ submorphs indexOf: aMorph ifAbsent: [nil]! ! 226716 226717 226718!Morph methodsFor: 'system primitives' stamp: 'sw 10/27/2000 17:37'! 226719creationStamp 226720 "Answer the creation stamp stored within the receiver, if any" 226721 226722 ^ self valueOfProperty: #creationStamp ifAbsent: [super creationStamp]! ! 226723 226724 226725!Morph methodsFor: 'testing' stamp: 'RAA 12/4/2000 10:44'! 226726canDrawAtHigherResolution 226727 226728 ^false! ! 226729 226730!Morph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:14'! 226731canDrawBorder: aBorderStyle 226732 "Return true if the receiver can be drawn with the given border style." 226733 ^true! ! 226734 226735!Morph methodsFor: 'testing' stamp: 'RAA 10/20/2000 14:47'! 226736completeModificationHash 226737 226738"World completeModificationHash" 226739 226740 | resultSize result here i | 226741 resultSize := 10. 226742 result := ByteArray new: resultSize. 226743 self allMorphsDo: [ :each | 226744 here := each modificationHash. 226745 here withIndexDo: [ :ch :index | 226746 i := index \\ resultSize + 1. 226747 result at: i put: ((result at: i) bitXor: ch asciiValue) 226748 ]. 226749 ]. 226750 ^result! ! 226751 226752!Morph methodsFor: 'testing' stamp: 'dgd 8/31/2004 15:00'! 226753isDockingBar 226754 "Return true if the receiver is a docking bar" 226755 ^ false! ! 226756 226757!Morph methodsFor: 'testing' stamp: 'ar 9/22/2000 13:44'! 226758isFlexed 226759 "Return true if the receiver is currently flexed" 226760 owner ifNil:[^false]. 226761 ^owner isFlexMorph! ! 226762 226763!Morph methodsFor: 'testing' stamp: 'dgd 9/20/2004 14:31'! 226764isFullOnScreen 226765 "Answer if the receiver is full contained in the owner visible 226766 area." 226767 owner isInMemory 226768 ifFalse: [^ true]. 226769 owner isNil 226770 ifTrue: [^ true]. 226771 self visible 226772 ifFalse: [^ true]. 226773 ^ owner clearArea containsRect: self fullBounds! ! 226774 226775!Morph methodsFor: 'testing' stamp: 'nk 10/13/2003 18:36'! 226776isLineMorph 226777 ^false! ! 226778 226779!Morph methodsFor: 'testing'! 226780isMorph 226781 226782 ^ true! ! 226783 226784!Morph methodsFor: 'testing' stamp: 'md 2/27/2006 09:59'! 226785knownName 226786 "answer a name by which the receiver is known, or nil if none" 226787 ^ extension ifNotNil: [extension externalName]! ! 226788 226789!Morph methodsFor: 'testing' stamp: 'RAA 10/20/2000 14:47'! 226790modificationHash 226791 226792 ^String 226793 streamContents: [ :strm | 226794 self longPrintOn: strm 226795 ] 226796 limitedTo: 25 226797! ! 226798 226799!Morph methodsFor: 'testing' stamp: 'tk 7/28/2005 04:46'! 226800renameInternal: aName 226801 "Change the internal name (because of a conflict) but leave the external name unchanged. Change Player class name, but do not change the names that appear in tiles. When coming in from disk, and have name conflict, References will already have the new name. " 226802 226803 self knownName = aName ifTrue: [^ aName]. 226804 self topRendererOrSelf setNameTo: aName. 226805 226806 "References dictionary already has key aName" 226807 226808 "If this player has a viewer flap, it will remain present" 226809 226810 "Tiles in scripts all stay the same" 226811 226812 "Compiled methods for scripts have been fixed up because the same association was reused" 226813 226814 ^ aName! ! 226815 226816!Morph methodsFor: 'testing' stamp: 'stephane.ducasse 11/14/2008 21:48'! 226817renameTo: aName 226818 "Set The morph name." 226819 226820 self topRendererOrSelf setNameTo: aName. 226821 ^aName! ! 226822 226823!Morph methodsFor: 'testing' stamp: 'ar 12/3/2001 12:33'! 226824shouldDropOnMouseUp 226825 | former | 226826 former := self formerPosition ifNil:[^false]. 226827 ^(former dist: self position) > 10! ! 226828 226829!Morph methodsFor: 'testing' stamp: 'stephane.ducasse 11/27/2008 22:31'! 226830stepTime 226831 "Answer the desired time between steps in milliseconds. This default implementation requests that the 'step' method be called once every second." 226832 226833 ^ 1000 ! ! 226834 226835!Morph methodsFor: 'testing' stamp: 'stephane.ducasse 10/16/2008 18:36'! 226836wantsSteps 226837 "Return true if the receiver overrides the default Morph step method." 226838 "Details: Find first class in superclass chain that implements #step and return true if it isn't class Morph." 226839 226840 | c | 226841 self isPartsDonor ifTrue: [^ false]. 226842 c := self class. 226843 [c includesSelector: #step] whileFalse: [c := c superclass]. 226844 ^ c ~= Morph! ! 226845 226846 226847!Morph methodsFor: 'text-anchor' stamp: 'ar 12/17/2001 12:45'! 226848addTextAnchorMenuItems: topMenu hand: aHand 226849 | aMenu | 226850 aMenu := MenuMorph new defaultTarget: self. 226851 aMenu addUpdating: #hasInlineAnchorString action: #changeInlineAnchor. 226852 aMenu addUpdating: #hasParagraphAnchorString action: #changeParagraphAnchor. 226853 aMenu addUpdating: #hasDocumentAnchorString action: #changeDocumentAnchor. 226854 topMenu ifNotNil:[topMenu add: 'text anchor' subMenu: aMenu]. 226855 ^aMenu! ! 226856 226857!Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:47'! 226858changeDocumentAnchor 226859 "Change the anchor from/to document anchoring" 226860 226861 | newType | 226862 newType := self textAnchorType == #document 226863 ifTrue: [#paragraph] 226864 ifFalse: [ #document]. 226865 owner isTextMorph 226866 ifTrue: 226867 [owner 226868 anchorMorph: self 226869 at: self position 226870 type: newType]! ! 226871 226872!Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:48'! 226873changeInlineAnchor 226874 "Change the anchor from/to line anchoring" 226875 226876 | newType | 226877 newType := self textAnchorType == #inline 226878 ifTrue: [#paragraph] 226879 ifFalse: [#inline]. 226880 owner isTextMorph 226881 ifTrue: 226882 [owner 226883 anchorMorph: self 226884 at: self position 226885 type: newType]! ! 226886 226887!Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:48'! 226888changeParagraphAnchor 226889 "Change the anchor from/to paragraph anchoring" 226890 226891 | newType | 226892 newType := self textAnchorType == #paragraph 226893 ifTrue: [#document] 226894 ifFalse: [#paragraph]. 226895 owner isTextMorph 226896 ifTrue: 226897 [owner 226898 anchorMorph: self 226899 at: self position 226900 type: newType]! ! 226901 226902!Morph methodsFor: 'text-anchor' stamp: 'dgd 9/6/2003 18:14'! 226903hasDocumentAnchorString 226904 ^ (self textAnchorType == #document 226905 ifTrue: ['<on>'] 226906 ifFalse: ['<off>']) 226907 , 'Document' translated! ! 226908 226909!Morph methodsFor: 'text-anchor' stamp: 'dgd 9/6/2003 18:14'! 226910hasInlineAnchorString 226911 ^ (self textAnchorType == #inline 226912 ifTrue: ['<on>'] 226913 ifFalse: ['<off>']) 226914 , 'Inline' translated! ! 226915 226916!Morph methodsFor: 'text-anchor' stamp: 'dgd 9/6/2003 18:14'! 226917hasParagraphAnchorString 226918 ^ (self textAnchorType == #paragraph 226919 ifTrue: ['<on>'] 226920 ifFalse: ['<off>']) 226921 , 'Paragraph' translated! ! 226922 226923!Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 19:47'! 226924relativeTextAnchorPosition 226925 ^self valueOfProperty: #relativeTextAnchorPosition! ! 226926 226927!Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 19:22'! 226928relativeTextAnchorPosition: aPoint 226929 ^self setProperty: #relativeTextAnchorPosition toValue: aPoint! ! 226930 226931!Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 18:36'! 226932textAnchorType 226933 ^self valueOfProperty: #textAnchorType ifAbsent:[#document]! ! 226934 226935!Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 18:37'! 226936textAnchorType: aSymbol 226937 aSymbol == #document 226938 ifTrue:[^self removeProperty: #textAnchorType] 226939 ifFalse:[^self setProperty: #textAnchorType toValue: aSymbol].! ! 226940 226941 226942!Morph methodsFor: 'thumbnail' stamp: 'dgd 9/12/2004 21:12'! 226943icon 226944 "Answer a form with an icon to represent the receiver" 226945 ^ self valueOfProperty: #icon! ! 226946 226947!Morph methodsFor: 'thumbnail' stamp: 'dgd 9/12/2004 20:33'! 226948iconOrThumbnail 226949 "Answer an appropiate form to represent the receiver" 226950 226951 ^ self icon 226952 ifNil: [ | maxExtent fb |maxExtent := 320 @ 240. 226953 fb := self fullBounds. 226954 fb area <= (maxExtent x * maxExtent y) 226955 ifTrue: [self imageForm] 226956 ifFalse: [self imageFormForRectangle: (fb topLeft extent: maxExtent)] 226957 ] 226958! ! 226959 226960!Morph methodsFor: 'thumbnail' stamp: 'dgd 9/13/2004 12:43'! 226961iconOrThumbnailOfSize: aNumberOrPoint 226962 "Answer an appropiate form to represent the receiver" 226963 226964 ^ self iconOrThumbnail scaledIntoFormOfSize: aNumberOrPoint 226965! ! 226966 226967!Morph methodsFor: 'thumbnail' stamp: 'sw 8/16/2000 17:40'! 226968morphRepresented 226969 "If the receiver is an alias, answer the morph it represents; else answer self" 226970 226971 ^ self! ! 226972 226973!Morph methodsFor: 'thumbnail' stamp: 'sw 6/16/1999 11:29'! 226974permitsThumbnailing 226975 ^ true! ! 226976 226977!Morph methodsFor: 'thumbnail' stamp: 'ar 11/9/2000 20:42'! 226978readoutForField: fieldSym 226979 "Provide a readout that will show the value of the slot/pseudoslot of the receiver generated by sending fieldSym to the receiver" 226980 226981 | aContainer | 226982 "still need to get this right" 226983 aContainer := AlignmentMorph newColumn. 226984 aContainer layoutInset: 0; hResizing: #rigid; vResizing: #shrinkWrap. 226985 aContainer addMorphBack: (StringMorph new contents: (self perform: fieldSym) asString). 226986 ^ aContainer! ! 226987 226988 226989!Morph methodsFor: 'undo' stamp: 'ar 8/31/2000 23:15'! 226990commandHistory 226991 "Return the command history for the receiver" 226992 | w | 226993 (w := self world) ifNotNil:[^w commandHistory]. 226994 (w := self currentWorld) ifNotNil:[^w commandHistory]. 226995 ^CommandHistory new. "won't really record anything but prevent breaking things"! ! 226996 226997!Morph methodsFor: 'undo' stamp: 'md 10/22/2003 15:56'! 226998undoMove: cmd redo: redo owner: formerOwner bounds: formerBounds predecessor: formerPredecessor 226999 "Handle undo and redo of move commands in morphic" 227000 227001 self owner ifNil: [^Beeper beep]. 227002 redo 227003 ifFalse: 227004 ["undo sets up the redo state first" 227005 227006 cmd 227007 redoTarget: self 227008 selector: #undoMove:redo:owner:bounds:predecessor: 227009 arguments: { 227010 cmd. 227011 true. 227012 owner. 227013 bounds. 227014 owner morphPreceding: self}]. 227015 formerOwner ifNotNil: 227016 [formerPredecessor ifNil: [formerOwner addMorphFront: self] 227017 ifNotNil: [formerOwner addMorph: self after: formerPredecessor]]. 227018 self bounds: formerBounds. 227019 (self isSystemWindow) ifTrue: [self activate]! ! 227020 227021 227022!Morph methodsFor: 'user interface' stamp: 'tak 3/15/2005 17:36'! 227023becomeModal 227024 self currentWorld 227025 ifNotNil: [self currentWorld modalWindow: self]! ! 227026 227027!Morph methodsFor: 'user interface' stamp: 'sw 5/29/2000 00:41'! 227028defaultLabelForInspector 227029 "Answer the default label to be used for an Inspector window on the receiver." 227030 ^ super printString truncateTo: 40! ! 227031 227032!Morph methodsFor: 'user interface' stamp: 'tak 3/15/2005 17:10'! 227033doCancel 227034 self delete! ! 227035 227036!Morph methodsFor: 'user interface' stamp: 'sw 10/2/97 23:08'! 227037initialExtent 227038 | ext | 227039 (ext := self valueOfProperty: #initialExtent) 227040 ifNotNil: 227041 [^ ext]. 227042 ^ super initialExtent! ! 227043 227044 227045!Morph methodsFor: 'viewer' stamp: 'sw 10/30/1998 14:46'! 227046externalName 227047 ^ self knownName ifNil: [self innocuousName]! ! 227048 227049 227050!Morph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:11'! 227051canHaveFillStyles 227052 "Return true if the receiver can have general fill styles; not just colors. 227053 This method is for gradually converting old morphs." 227054 ^self class == Morph "no subclasses"! ! 227055 227056!Morph methodsFor: 'visual properties' stamp: 'mk 8/7/2005 10:02'! 227057cornerStyle 227058 "Returns one of the following symbols: 227059 #square 227060 #rounded 227061 according to the current corner style." 227062 227063 ^ self valueOfProperty: #cornerStyle ifAbsent: [#square]! ! 227064 227065!Morph methodsFor: 'visual properties' stamp: 'nk 8/28/2003 15:56'! 227066defaultBitmapFillForm 227067 ^ImageMorph defaultForm. 227068! ! 227069 227070!Morph methodsFor: 'visual properties' stamp: 'marcus.denker 8/24/2008 22:43'! 227071fillStyle 227072 "Return the current fillStyle of the receiver." 227073 227074 extension ifNil: [^color]. 227075 227076 ^ self 227077 valueOfProperty: #fillStyle 227078 ifAbsent: ["Workaround already converted morphs" 227079 color]! ! 227080 227081!Morph methodsFor: 'visual properties' stamp: 'dgd 1/7/2005 19:31'! 227082fillWithRamp: rampSpecsOrColor oriented: aRatio 227083 rampSpecsOrColor isColor 227084 ifTrue: [self color: rampSpecsOrColor". 227085 self borderColor: rampSpecsOrColor muchDarker"] 227086 ifFalse: [| fill | 227087 fill := GradientFillStyle ramp: rampSpecsOrColor. 227088 fill origin: self bounds topLeft. 227089 fill direction: (self bounds extent * aRatio) truncated. 227090 fill radial: false. 227091 self fillStyle: fill. 227092 self borderColor: (rampSpecsOrColor first value mixed: 0.5 with: rampSpecsOrColor last value) muchDarker]! ! 227093 227094!Morph methodsFor: 'visual properties' stamp: 'nk 8/28/2003 15:57'! 227095useBitmapFill 227096 "Make receiver use a solid fill style (e.g., a simple color)" 227097 | fill | 227098 self fillStyle isBitmapFill ifTrue:[^self]. "Already done" 227099 fill := BitmapFillStyle fromForm: self defaultBitmapFillForm. 227100 "Note: Must fix the origin due to global coordinates" 227101 fill origin: self bounds origin. 227102 self fillStyle: fill.! ! 227103 227104!Morph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:11'! 227105useDefaultFill 227106 "Make receiver use a solid fill style (e.g., a simple color)" 227107 self fillStyle: self defaultColor.! ! 227108 227109!Morph methodsFor: 'visual properties' stamp: 'nk 2/27/2003 11:48'! 227110useGradientFill 227111 "Make receiver use a solid fill style (e.g., a simple color)" 227112 | fill color1 color2 | 227113 self fillStyle isGradientFill ifTrue:[^self]. "Already done" 227114 color1 := self color asColor. 227115 color2 := color1 negated. 227116 fill := GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}. 227117 fill origin: self topLeft. 227118 fill direction: 0 @ self bounds extent y. 227119 fill normal: self bounds extent x @ 0. 227120 fill radial: false. 227121 self fillStyle: fill! ! 227122 227123!Morph methodsFor: 'visual properties' stamp: 'ar 6/18/1999 06:57'! 227124useSolidFill 227125 "Make receiver use a solid fill style (e.g., a simple color)" 227126 self fillStyle isSolidFill ifTrue:[^self]. "Already done" 227127 self fillStyle: self fillStyle asColor. "Try minimizing changes"! ! 227128 227129 227130!Morph methodsFor: 'wiw support' stamp: 'RAA 2/16/2001 13:57'! 227131addMorphInFrontOfLayer: aMorph 227132 227133 | targetLayer layerHere | 227134 227135 targetLayer := aMorph morphicLayerNumberWithin: self. 227136 submorphs do: [ :each | 227137 each == aMorph ifTrue: [^self]. 227138 layerHere := each morphicLayerNumberWithin: self. 227139 "the <= is the difference - it insures we go to the front of our layer" 227140 targetLayer <= layerHere ifTrue: [ 227141 ^self addMorph: aMorph inFrontOf: each 227142 ]. 227143 ]. 227144 self addMorphBack: aMorph. 227145! ! 227146 227147!Morph methodsFor: 'wiw support' stamp: 'RAA 6/29/2000 10:49'! 227148addMorphInLayer: aMorph 227149 227150 submorphs do: [ :each | 227151 each == aMorph ifTrue: [^self]. 227152 aMorph morphicLayerNumber < each morphicLayerNumber ifTrue: [ 227153 ^self addMorph: aMorph inFrontOf: each 227154 ]. 227155 ]. 227156 self addMorphBack: aMorph 227157! ! 227158 227159!Morph methodsFor: 'wiw support' stamp: 'RAA 7/19/2000 20:44'! 227160morphicLayerNumber 227161 227162 "helpful for insuring some morphs always appear in front of or behind others. 227163 smaller numbers are in front" 227164 227165 ^(owner isNil or: [owner isWorldMorph]) ifTrue: [ 227166 self valueOfProperty: #morphicLayerNumber ifAbsent: [100] 227167 ] ifFalse: [ 227168 owner morphicLayerNumber 227169 ]. 227170 227171 "leave lots of room for special things"! ! 227172 227173!Morph methodsFor: 'wiw support' stamp: 'ar 3/18/2001 00:14'! 227174shouldGetStepsFrom: aWorld 227175 ^self world == aWorld! ! 227176 227177 227178!Morph methodsFor: 'private' stamp: 'nk 10/11/2003 16:08'! 227179privateAddAllMorphs: aCollection atIndex: index 227180 "Private. Add aCollection of morphs to the receiver" 227181 | myWorld itsWorld otherSubmorphs | 227182 myWorld := self world. 227183 otherSubmorphs := submorphs copyWithoutAll: aCollection. 227184 (index between: 0 and: otherSubmorphs size) 227185 ifFalse: [^ self error: 'index out of range']. 227186 index = 0 227187 ifTrue:[ submorphs := aCollection asArray, otherSubmorphs] 227188 ifFalse:[ index = otherSubmorphs size 227189 ifTrue:[ submorphs := otherSubmorphs, aCollection] 227190 ifFalse:[ submorphs := otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]]. 227191 aCollection do: [:m | | itsOwner | 227192 itsOwner := m owner. 227193 itsOwner ifNotNil: [ 227194 itsWorld := m world. 227195 (itsWorld == myWorld) ifFalse: [ 227196 itsWorld ifNotNil: [self privateInvalidateMorph: m]. 227197 m outOfWorld: itsWorld]. 227198 (itsOwner ~~ self) ifTrue: [ 227199 m owner privateRemove: m. 227200 m owner removedMorph: m ]]. 227201 m privateOwner: self. 227202 myWorld ifNotNil: [self privateInvalidateMorph: m]. 227203 (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld]. 227204 itsOwner == self ifFalse: [ 227205 self addedMorph: m. 227206 m noteNewOwner: self ]. 227207 ]. 227208 self layoutChanged. 227209! ! 227210 227211!Morph methodsFor: 'private' stamp: 'nk 10/11/2003 16:08'! 227212privateAddMorph: aMorph atIndex: index 227213 227214 | oldIndex myWorld itsWorld oldOwner | 227215 ((index >= 1) and: [index <= (submorphs size + 1)]) 227216 ifFalse: [^ self error: 'index out of range']. 227217 myWorld := self world. 227218 oldOwner := aMorph owner. 227219 (oldOwner == self and: [(oldIndex := submorphs indexOf: aMorph) > 0]) ifTrue:[ 227220 "aMorph's position changes within in the submorph chain" 227221 oldIndex < index ifTrue:[ 227222 "moving aMorph to back" 227223 submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. 227224 submorphs at: index-1 put: aMorph. 227225 ] ifFalse:[ 227226 "moving aMorph to front" 227227 oldIndex-1 to: index by: -1 do:[:i| 227228 submorphs at: i+1 put: (submorphs at: i)]. 227229 submorphs at: index put: aMorph. 227230 ]. 227231 ] ifFalse:[ 227232 "adding a new morph" 227233 oldOwner ifNotNil:[ 227234 itsWorld := aMorph world. 227235 itsWorld ifNotNil: [self privateInvalidateMorph: aMorph]. 227236 (itsWorld == myWorld) ifFalse: [aMorph outOfWorld: itsWorld]. 227237 oldOwner privateRemove: aMorph. 227238 oldOwner removedMorph: aMorph. 227239 ]. 227240 aMorph privateOwner: self. 227241 submorphs := submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). 227242 (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. 227243 ]. 227244 myWorld ifNotNil:[self privateInvalidateMorph: aMorph]. 227245 self layoutChanged. 227246 oldOwner == self ifFalse: [ 227247 self addedMorph: aMorph. 227248 aMorph noteNewOwner: self ]. 227249! ! 227250 227251!Morph methodsFor: 'private'! 227252privateBounds: boundsRect 227253 "Private!! Use position: and/or extent: instead." 227254 227255 fullBounds := nil. 227256 bounds := boundsRect.! ! 227257 227258!Morph methodsFor: 'private' stamp: 'jm 5/29/1998 21:28'! 227259privateColor: aColor 227260 227261 color := aColor. 227262! ! 227263 227264!Morph methodsFor: 'private' stamp: 'RAA 5/23/2000 11:31'! 227265privateDeleteWithAbsolutelyNoSideEffects 227266 "Private!! Should only be used by methods that maintain the ower/submorph invariant." 227267 "used to delete a morph from an inactive world" 227268 227269 owner ifNil: [^self]. 227270 owner privateRemoveMorphWithAbsolutelyNoSideEffects: self. 227271 owner := nil. 227272 227273! ! 227274 227275!Morph methodsFor: 'private' stamp: 'tk 8/30/1998 09:58'! 227276privateFullBounds: boundsRect 227277 "Private!! Computed automatically." 227278 227279 fullBounds := boundsRect.! ! 227280 227281!Morph methodsFor: 'private' stamp: 'ar 12/16/2001 21:47'! 227282privateFullMoveBy: delta 227283 "Private!! Relocate me and all of my subMorphs by recursion. Subclasses that implement different coordinate systems may override this method." 227284 227285 self privateMoveBy: delta. 227286 1 to: submorphs size do: [:i | 227287 (submorphs at: i) privateFullMoveBy: delta]. 227288 owner ifNotNil:[ 227289 owner isTextMorph ifTrue:[owner adjustTextAnchor: self]].! ! 227290 227291!Morph methodsFor: 'private'! 227292privateOwner: aMorph 227293 "Private!! Should only be used by methods that maintain the ower/submorph invariant." 227294 227295 owner := aMorph.! ! 227296 227297!Morph methodsFor: 'private' stamp: 'RAA 5/23/2000 11:30'! 227298privateRemoveMorphWithAbsolutelyNoSideEffects: aMorph 227299 "Private!! Should only be used by methods that maintain the ower/submorph invariant." 227300 "used to delete a morph from an inactive world" 227301 227302 submorphs := submorphs copyWithout: aMorph. 227303 227304! ! 227305 227306!Morph methodsFor: 'private' stamp: 'di 10/18/2004 21:49'! 227307privateRemove: aMorph 227308 "Private!! Should only be used by methods that maintain the ower/submorph invariant." 227309 227310 submorphs := submorphs copyWithout: aMorph. 227311 self layoutChanged.! ! 227312 227313!Morph methodsFor: 'private'! 227314privateSubmorphs 227315 "Private!! Use 'submorphs' instead." 227316 227317 ^ submorphs! ! 227318 227319!Morph methodsFor: 'private'! 227320privateSubmorphs: aCollection 227321 "Private!! Should only be used by methods that maintain the ower/submorph invariant." 227322 227323 submorphs := aCollection.! ! 227324 227325"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 227326 227327Morph class 227328 instanceVariableNames: ''! 227329 227330!Morph class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 15:48'! 227331theme 227332 "Answer the ui theme that provides controls." 227333 227334 ^UITheme current! ! 227335 227336 227337!Morph class methodsFor: 'filein/out' stamp: 'nk 7/16/2003 15:54'! 227338fileReaderServicesForFile: fullName suffix: suffix 227339 227340 ^({ 'morph'. 'morphs'. 'sp'. '*' } includes: suffix) 227341 ifTrue: [ 227342 {SimpleServiceEntry 227343 provider: self 227344 label: 'load as morph' 227345 selector: #fromFileName: 227346 description: 'load as morph'}] 227347 ifFalse: [#()]! ! 227348 227349!Morph class methodsFor: 'filein/out' stamp: 'stephane.ducasse 3/13/2009 17:53'! 227350fromFileName: fullName 227351 "Reconstitute a Morph from the file, presumed to be represent a Morph 227352 saved via the SmartRefStream mechanism, and open it in an 227353 appropriate Morphic world" 227354 | aFileStream morphOrList | 227355 aFileStream := (MultiByteBinaryOrTextStream with: (FileStream readOnlyFileNamed: fullName) binary contentsOfEntireFile) binary reset. 227356 morphOrList := aFileStream fileInObjectAndCode. 227357 morphOrList := self postLoad. 227358 ActiveWorld addMorphsAndModel: morphOrList! ! 227359 227360!Morph class methodsFor: 'filein/out' stamp: 'sw 2/17/2002 02:43'! 227361serviceLoadMorphFromFile 227362 "Answer a service for loading a .morph file" 227363 227364 ^ SimpleServiceEntry 227365 provider: self 227366 label: 'load as morph' 227367 selector: #fromFileName: 227368 description: 'load as morph' 227369 buttonLabel: 'load'! ! 227370 227371!Morph class methodsFor: 'filein/out' stamp: 'sd 2/1/2002 21:45'! 227372services 227373 227374 ^ Array with: self serviceLoadMorphFromFile! ! 227375 227376 227377!Morph class methodsFor: 'initialize-release' stamp: 'SD 11/15/2001 22:22'! 227378unload 227379 227380 FileList unregisterFileReader: self ! ! 227381 227382 227383!Morph class methodsFor: 'instance creation' stamp: 'efo 5/3/2002 14:59'! 227384initializedInstance 227385 "Answer an instance of the receiver which in some sense is initialized. In the case of Morphs, this will yield an instance that can be attached to the Hand after having received the same kind of basic initialization that would be obtained from an instance chosen from the 'new morph' menu. 227386 Return nil if the receiver is reluctant for some reason to return such a thing" 227387 227388 ^ (self class includesSelector: #descriptionForPartsBin) 227389 ifTrue: 227390 [self newStandAlone] 227391 ifFalse: 227392 [self new]! ! 227393 227394!Morph class methodsFor: 'instance creation'! 227395newBounds: bounds 227396 227397 ^ self new privateBounds: bounds! ! 227398 227399!Morph class methodsFor: 'instance creation' stamp: 'jm 5/29/1998 21:28'! 227400newBounds: bounds color: color 227401 227402 ^ (self new privateBounds: bounds) privateColor: color 227403! ! 227404 227405!Morph class methodsFor: 'instance creation' stamp: 'sw 8/4/97 12:05'! 227406newSticky 227407 227408 ^ self new beSticky! ! 227409 227410 227411!Morph class methodsFor: 'misc' stamp: 'sw 8/4/1998 16:51'! 227412morphsUnknownToTheirOwners 227413 "Return a list of all morphs (other than HandMorphs) whose owners do not contain them in their submorph lists" 227414 "Morph morphsUnknownToTheirOwners" 227415 | problemMorphs itsOwner | 227416 problemMorphs := OrderedCollection new. 227417 self allSubInstances do: 227418 [:m | (m isHandMorph not and: [((itsOwner := m owner) ~~ nil and: [(itsOwner submorphs includes: m) not])]) 227419 ifTrue: 227420 [problemMorphs add: m]]. 227421 ^ problemMorphs! ! 227422 227423!Morph class methodsFor: 'misc' stamp: 'PeterHugossonMiller 9/2/2009 16:13'! 227424obtainArrowheadFor: aPrompt defaultValue: defaultPoint 227425 "Allow the user to supply a point to serve as an arrowhead size. Answer nil if we fail to get a good point" 227426 227427 | result | 227428 result := UIManager default request: aPrompt initialAnswer: defaultPoint asString. 227429 result isEmptyOrNil ifTrue: [^ nil]. 227430 ^ [(Point readFrom: result readStream)] 227431 on: Error do: [:ex | nil].! ! 227432 227433 227434!Morph class methodsFor: 'new-morph participation' stamp: 'di 6/22/97 09:07'! 227435includeInNewMorphMenu 227436 "Return true for all classes that can be instantiated from the menu" 227437 ^ true! ! 227438 227439!Morph class methodsFor: 'new-morph participation' stamp: 'sw 6/28/2001 11:33'! 227440newStandAlone 227441 "Answer an instance capable of standing by itself as a usable morph." 227442 227443 ^ self basicNew initializeToStandAlone! ! 227444 227445 227446!Morph class methodsFor: 'nil'! 227447initialize 227448 "Morph initialize" 227449 227450 "this empty array object is shared by all morphs with no submorphs:" 227451 EmptyArray := Array new. 227452! ! 227453 227454 227455!Morph class methodsFor: 'scripting' stamp: 'sw 8/11/97 13:17'! 227456authoringPrototype 227457 "Answer an instance of the receiver suitable for placing in a parts bin for authors" 227458 227459 ^ self new markAsPartsDonor! ! 227460TestCase subclass: #MorphBugs 227461 instanceVariableNames: '' 227462 classVariableNames: '' 227463 poolDictionaries: '' 227464 category: 'Tests-Bugs'! 227465 227466!MorphBugs methodsFor: 'as yet unclassified' stamp: 'wiz 10/19/2006 00:32'! 227467adhereToEdgeTest 227468"self new adhereToEdgeTest" 227469"self run: #adhereToEdgeTest" 227470 227471| r | 227472r := RectangleMorph new openInWorld . 227473 227474self shouldnt: [ [ r adhereToEdge: #eternity ] ensure: [ r delete ] ] raise: Error . 227475 r delete . 227476 227477^true ! ! 227478DropListMorph subclass: #MorphDropListMorph 227479 instanceVariableNames: '' 227480 classVariableNames: '' 227481 poolDictionaries: '' 227482 category: 'Polymorph-Widgets'! 227483!MorphDropListMorph commentStamp: 'gvc 5/18/2007 12:43' prior: 0! 227484Drop list supporting morphs in list.! 227485 227486 227487!MorphDropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2006 15:07'! 227488font: aFont 227489 "Set the list font" 227490 227491 self listMorph font: aFont! ! 227492 227493!MorphDropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/17/2006 11:43'! 227494listMorphClass 227495 "Answer the class for a new list morph" 227496 227497 ^PluggableMorphListMorph! ! 227498 227499!MorphDropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/17/2006 12:11'! 227500newContentMorph 227501 "Answer a new content morph" 227502 227503 ^Morph new 227504 changeTableLayout; 227505 listDirection: #leftToRight; 227506 wrapCentering: #center; 227507 vResizing: #spaceFill; 227508 hResizing: #spaceFill; 227509 layoutInset: 2; 227510 color: Color transparent; 227511 borderWidth: 0; 227512 clipSubmorphs: true; 227513 lock! ! 227514 227515!MorphDropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/29/2006 11:58'! 227516updateContentColor: paneColor 227517 "Change the content text color." 227518 ! ! 227519 227520!MorphDropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/17/2006 13:35'! 227521updateContents 227522 "Update the contents." 227523 227524 |item| 227525 self contentMorph removeAllMorphs. 227526 self listSelectionIndex > 0 227527 ifTrue: [item := (self list at: self listSelectionIndex) copy 227528 hResizing: #spaceFill; 227529 vResizing: #rigid. 227530 self contentMorph 227531 addMorph: item]! ! 227532Object subclass: #MorphExtension 227533 instanceVariableNames: 'locked visible sticky balloonText balloonTextSelector externalName isPartsDonor actorState player eventHandler otherProperties' 227534 classVariableNames: '' 227535 poolDictionaries: '' 227536 category: 'Morphic-Kernel'! 227537!MorphExtension commentStamp: '<historical>' prior: 0! 227538MorphExtension provides access to extra instance state that is not required in most simple morphs. This allows simple morphs to remain relatively lightweight while still admitting more complex structures as necessary. The otherProperties field takes this policy to the extreme of allowing any number of additional named attributes, albeit at a certain cost in speed and space.! 227539 227540 227541!MorphExtension methodsFor: '*etoys-accessing' stamp: 'HenrikSperreJohansen 9/9/2009 00:29'! 227542player 227543 "We no longer have players" 227544 ^ nil! ! 227545 227546 227547!MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:52'! 227548balloonText 227549 ^ balloonText! ! 227550 227551!MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:52'! 227552balloonTextSelector 227553 ^ balloonTextSelector! ! 227554 227555!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:51'! 227556balloonTextSelector: aSymbol 227557 "change the receiver's balloonTextSelector" 227558 balloonTextSelector := aSymbol! ! 227559 227560!MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:55'! 227561balloonText: newValue 227562 balloonText := newValue! ! 227563 227564!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:51'! 227565eventHandler 227566 "answer the receiver's eventHandler" 227567 ^ eventHandler ! ! 227568 227569!MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:56'! 227570eventHandler: newValue 227571 eventHandler := newValue! ! 227572 227573!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:57'! 227574externalName: aString 227575 "change the receiver's externalName" 227576 externalName := aString! ! 227577 227578!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:37'! 227579isPartsDonor 227580 "answer whether the receiver is PartsDonor" 227581 ^ isPartsDonor! ! 227582 227583!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:40'! 227584isPartsDonor: aBoolean 227585 "change the receiver's isPartDonor property" 227586 isPartsDonor := aBoolean! ! 227587 227588!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:38'! 227589locked 227590 "answer whether the receiver is Locked" 227591 ^ locked! ! 227592 227593!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:48'! 227594locked: aBoolean 227595 "change the receiver's locked property" 227596 locked := aBoolean! ! 227597 227598!MorphExtension methodsFor: 'accessing' stamp: 'di 8/14/1998 13:07'! 227599sticky 227600 ^ sticky! ! 227601 227602!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:47'! 227603sticky: aBoolean 227604 "change the receiver's sticky property" 227605 sticky := aBoolean! ! 227606 227607!MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:41'! 227608visible 227609 "answer whether the receiver is visible" 227610 ^ visible! ! 227611 227612!MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:55'! 227613visible: newValue 227614 visible := newValue! ! 227615 227616 227617!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'ar 11/14/2000 17:17'! 227618layoutFrame 227619 ^self valueOfProperty: #layoutFrame ifAbsent:[nil]! ! 227620 227621!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'md 12/18/2008 14:09'! 227622layoutFrame: aLayoutFrame 227623 aLayoutFrame 227624 ifNil: [self removeProperty: #layoutFrame] 227625 ifNotNil: [self setProperty: #layoutFrame toValue: aLayoutFrame]! ! 227626 227627!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'ar 11/14/2000 17:17'! 227628layoutPolicy 227629 ^self valueOfProperty: #layoutPolicy ifAbsent:[nil]! ! 227630 227631!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'md 12/18/2008 14:10'! 227632layoutPolicy: aLayoutPolicy 227633 aLayoutPolicy 227634 ifNil: [self removeProperty: #layoutPolicy] 227635 ifNotNil: [self setProperty: #layoutPolicy toValue: aLayoutPolicy]! ! 227636 227637!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'ar 11/14/2000 17:18'! 227638layoutProperties 227639 ^self valueOfProperty: #layoutProperties ifAbsent:[nil]! ! 227640 227641!MorphExtension methodsFor: 'accessing - layout properties' stamp: 'md 12/18/2008 14:10'! 227642layoutProperties: newProperties 227643 "Return the current layout properties associated with the receiver" 227644 227645 newProperties 227646 ifNil: [self removeProperty: #layoutProperties] 227647 ifNotNil: [self setProperty: #layoutProperties toValue: newProperties]! ! 227648 227649 227650!MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:41'! 227651assureOtherProperties 227652 "creates an otherProperties for the receiver if needed" 227653 otherProperties ifNil: [self initializeOtherProperties]. 227654 ^ otherProperties! ! 227655 227656!MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:42'! 227657hasProperty: aSymbol 227658 "Answer whether the receiver has the property named aSymbol" 227659 | property | 227660 otherProperties ifNil: [^ false]. 227661 property := otherProperties at: aSymbol ifAbsent: []. 227662 property isNil ifTrue: [^ false]. 227663 property == false ifTrue: [^ false]. 227664 ^ true! ! 227665 227666!MorphExtension methodsFor: 'accessing - other properties' stamp: 'marcus.denker 9/17/2008 17:39'! 227667initializeOtherProperties 227668 "private - initializes the receiver's otherProperties" 227669 otherProperties := SmallIdentityDictionary new! ! 227670 227671!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:04'! 227672otherProperties 227673 "answer the receiver's otherProperties" 227674 ^ otherProperties! ! 227675 227676!MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:37'! 227677removeOtherProperties 227678 "Remove the 'other' properties" 227679 otherProperties := nil! ! 227680 227681!MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:43'! 227682removeProperty: aSymbol 227683 "removes the property named aSymbol if it exists" 227684 otherProperties ifNil: [^ self]. 227685 otherProperties removeKey: aSymbol ifAbsent: []. 227686 otherProperties isEmpty ifTrue: [self removeOtherProperties]! ! 227687 227688!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:49'! 227689setProperty: aSymbol toValue: abObject 227690 "change the receiver's property named aSymbol to anObject" 227691 self assureOtherProperties at: aSymbol put: abObject! ! 227692 227693!MorphExtension methodsFor: 'accessing - other properties' stamp: 'PeterHugossonMiller 9/3/2009 10:07'! 227694sortedPropertyNames 227695 "answer the receiver's property names in a sorted way" 227696 227697 | props | 227698 props := (Array new: 10) writeStream. 227699 locked == true ifTrue: [props nextPut: #locked]. 227700 visible == false ifTrue: [props nextPut: #visible]. 227701 sticky == true ifTrue: [props nextPut: #sticky]. 227702 balloonText isNil ifFalse: [props nextPut: #balloonText]. 227703 balloonTextSelector isNil ifFalse: [props nextPut: #balloonTextSelector]. 227704 externalName isNil ifFalse: [props nextPut: #externalName]. 227705 isPartsDonor == true ifTrue: [props nextPut: #isPartsDonor]. 227706 eventHandler isNil ifFalse: [props nextPut: #eventHandler]. 227707 otherProperties ifNotNil: [otherProperties associationsDo: [:a | props nextPut: a key]]. 227708 ^props contents sort: [:s1 :s2 | s1 <= s2]! ! 227709 227710!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:00'! 227711valueOfProperty: aSymbol 227712"answer the value of the receiver's property named aSymbol" 227713 ^ self 227714 valueOfProperty: aSymbol 227715 ifAbsent: []! ! 227716 227717!MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:28'! 227718valueOfProperty: aSymbol ifAbsentPut: aBlock 227719 "If the receiver possesses a property of the given name, answer 227720 its value. If not, then create a property of the given name, give 227721 it the value obtained by evaluating aBlock, then answer that 227722 value" 227723 ^self assureOtherProperties at: aSymbol ifAbsentPut: aBlock! ! 227724 227725!MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:43'! 227726valueOfProperty: aSymbol ifAbsent: aBlock 227727 "if the receiver possesses a property of the given name, answer 227728 its value. If not then evaluate aBlock and answer the result of 227729 this block evaluation" 227730 otherProperties ifNil: [^ aBlock value]. 227731 ^ otherProperties at: aSymbol ifAbsent: [^ aBlock value]! ! 227732 227733 227734!MorphExtension methodsFor: 'connectors-copying' stamp: 'nk 5/1/2004 17:20'! 227735copyWeakly 227736 "list of names of properties whose values should be weak-copied when veryDeepCopying a morph. See DeepCopier." 227737 227738 ^ #(formerOwner newPermanentPlayer logger graphModel gestureDictionaryOrName) 227739 "add yours to this list" 227740 227741 "formerOwner should really be nil at the time of the copy, but this will work just fine."! ! 227742 227743!MorphExtension methodsFor: 'connectors-copying' stamp: 'nk 5/1/2004 17:23'! 227744propertyNamesNotCopied 227745 "list of names of properties whose values should be deleted when veryDeepCopying a morph. 227746 See DeepCopier." 227747 227748 ^ #(connectedConstraints connectionHighlights highlightedTargets) 227749 "add yours to this list" 227750! ! 227751 227752!MorphExtension methodsFor: 'connectors-copying' stamp: 'nk 5/1/2004 17:39'! 227753veryDeepFixupWith: deepCopier 227754 "If target and arguments fields were weakly copied, fix them here. 227755 If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 227756 227757 super veryDeepFixupWith: deepCopier. 227758 otherProperties ifNil: [ ^self ]. 227759 227760 "Properties whose values are only copied weakly replace those values if they were copied via another path" 227761 self copyWeakly do: [ :propertyName | 227762 otherProperties at: propertyName ifPresent: [ :property | 227763 otherProperties at: propertyName 227764 put: (deepCopier references at: property ifAbsent: [ property ])]]. 227765! ! 227766 227767!MorphExtension methodsFor: 'connectors-copying' stamp: 'nk 5/1/2004 17:45'! 227768veryDeepInner: deepCopier 227769 "Copy all of my instance variables. 227770 Some otherProperties need to be not copied at all, but shared. Their names are given by copyWeakly. 227771 Some otherProperties should not be copied or shared. Their names are given by propertyNamesNotCopied. 227772 This is special code for the dictionary. See DeepCopier, and veryDeepFixupWith:." 227773 227774 | namesOfWeaklyCopiedProperties weaklyCopiedValues | 227775 super veryDeepInner: deepCopier. 227776 locked := locked veryDeepCopyWith: deepCopier. 227777 visible := visible veryDeepCopyWith: deepCopier. 227778 sticky := sticky veryDeepCopyWith: deepCopier. 227779 balloonText := balloonText veryDeepCopyWith: deepCopier. 227780 balloonTextSelector := balloonTextSelector veryDeepCopyWith: deepCopier. 227781 externalName := externalName veryDeepCopyWith: deepCopier. 227782 isPartsDonor := isPartsDonor veryDeepCopyWith: deepCopier. 227783 actorState := actorState veryDeepCopyWith: deepCopier. 227784 player := player veryDeepCopyWith: deepCopier. "Do copy the player of this morph" 227785 eventHandler := eventHandler veryDeepCopyWith: deepCopier. "has its own restrictions" 227786 227787 otherProperties ifNil: [ ^self ]. 227788 227789 otherProperties := otherProperties copy. 227790 self propertyNamesNotCopied do: [ :propName | otherProperties removeKey: propName ifAbsent: [] ]. 227791 227792 namesOfWeaklyCopiedProperties := self copyWeakly. 227793 weaklyCopiedValues := namesOfWeaklyCopiedProperties collect: [ :propName | otherProperties removeKey: propName ifAbsent: [] ]. 227794 227795 "Now copy all the others." 227796 otherProperties := otherProperties veryDeepCopyWith: deepCopier. 227797 227798 "And replace the weak ones." 227799 namesOfWeaklyCopiedProperties with: weaklyCopiedValues do: [ :name :value | value ifNotNil: [ otherProperties at: name put: value ]]. 227800! ! 227801 227802 227803!MorphExtension methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:09'! 227804initialize 227805 "Init all booleans to default values" 227806 locked := false. 227807 visible := true. 227808 sticky := false. 227809 isPartsDonor := false. 227810! ! 227811 227812 227813!MorphExtension methodsFor: 'object filein' stamp: 'stephane.ducasse 11/8/2008 17:50'! 227814convertProperty: aSymbol toValue: anObject 227815 "These special cases move old properties into named fields of the 227816 extension" 227817 aSymbol == #locked 227818 ifTrue: [^ locked := anObject]. 227819 aSymbol == #visible 227820 ifTrue: [^ visible := anObject]. 227821 aSymbol == #sticky 227822 ifTrue: [^ sticky := anObject]. 227823 aSymbol == #balloonText 227824 ifTrue: [^ balloonText := anObject]. 227825 aSymbol == #balloonTextSelector 227826 ifTrue: [^ balloonTextSelector := anObject]. 227827 aSymbol == #name 227828 ifTrue: [^ externalName := anObject]. 227829 "*renamed*" 227830 aSymbol == #partsDonor 227831 ifTrue: [^ isPartsDonor := anObject]. 227832 "*renamed*" 227833 self assureOtherProperties at: aSymbol put: anObject! ! 227834 227835 227836!MorphExtension methodsFor: 'objects from disk' stamp: 'tk 4/8/1999 12:45'! 227837comeFullyUpOnReload: smartRefStream 227838 "inst vars have default booplean values." 227839 227840 locked ifNil: [locked := false]. 227841 visible ifNil: [visible := true]. 227842 sticky ifNil: [sticky := false]. 227843 isPartsDonor ifNil: [isPartsDonor := false]. 227844 ^ self! ! 227845 227846 227847!MorphExtension methodsFor: 'other' stamp: 'alain.plantec 2/6/2009 17:09'! 227848inspectElement 227849 "Create and schedule an Inspector on the otherProperties and the 227850 named properties." 227851 | key obj | 227852 key := UIManager default 227853 chooseFrom: self sortedPropertyNames 227854 values: self sortedPropertyNames 227855 title: 'Inspect which property?' translated. 227856 key 227857 ifNil: [^ self]. 227858 obj := otherProperties 227859 at: key 227860 ifAbsent: ['nOT a vALuE']. 227861 obj = 'nOT a vALuE' 227862 ifTrue: [(self perform: key) inspect 227863 "named properties"] 227864 ifFalse: [obj inspect]! ! 227865 227866!MorphExtension methodsFor: 'other' stamp: 'md 2/27/2006 08:42'! 227867isDefault 227868 "Return true if the receiver is a default and can be omitted" 227869 locked == true 227870 ifTrue: [^ false]. 227871 visible == false 227872 ifTrue: [^ false]. 227873 sticky == true 227874 ifTrue: [^ false]. 227875 balloonText isNil 227876 ifFalse: [^ false]. 227877 balloonTextSelector isNil 227878 ifFalse: [^ false]. 227879 externalName isNil 227880 ifFalse: [^ false]. 227881 isPartsDonor == true 227882 ifTrue: [^ false]. 227883 actorState isNil 227884 ifFalse: [^ false]. 227885 player isNil 227886 ifFalse: [^ false]. 227887 eventHandler isNil 227888 ifFalse: [^ false]. 227889 otherProperties ifNotNil: [otherProperties isEmpty ifFalse: [^ false]]. 227890 ^ true! ! 227891 227892 227893!MorphExtension methodsFor: 'printing' stamp: 'md 2/27/2006 08:45'! 227894printOn: aStream 227895 "Append to the argument, aStream, a sequence of characters that 227896 identifies the receiver." 227897 super printOn: aStream. 227898 aStream nextPutAll: ' ' , self identityHashPrintString. 227899 locked == true 227900 ifTrue: [aStream nextPutAll: ' [locked] ']. 227901 visible == false 227902 ifTrue: [aStream nextPutAll: '[not visible] ']. 227903 sticky == true 227904 ifTrue: [aStream nextPutAll: ' [sticky] ']. 227905 balloonText 227906 ifNotNil: [aStream nextPutAll: ' [balloonText] ']. 227907 balloonTextSelector 227908 ifNotNil: [aStream nextPutAll: ' [balloonTextSelector: ' , balloonTextSelector printString , '] ']. 227909 externalName 227910 ifNotNil: [aStream nextPutAll: ' [externalName = ' , externalName , ' ] ']. 227911 isPartsDonor == true 227912 ifTrue: [aStream nextPutAll: ' [isPartsDonor] ']. 227913 player 227914 ifNotNil: [aStream nextPutAll: ' [player = ' , player printString , '] ']. 227915 eventHandler 227916 ifNotNil: [aStream nextPutAll: ' [eventHandler = ' , eventHandler printString , '] ']. 227917 (otherProperties isNil or: [otherProperties isEmpty ]) ifTrue: [^ self]. 227918 aStream nextPutAll: ' [other: '. 227919 self otherProperties 227920 keysDo: [:aKey | aStream nextPutAll: ' (' , aKey , ' -> ' , (self otherProperties at: aKey) printString , ')']. 227921 aStream nextPut: $]! ! 227922 227923 227924!MorphExtension methodsFor: 'viewer' stamp: 'di 8/10/1998 14:47'! 227925externalName 227926 ^ externalName! ! 227927Object subclass: #MorphHierarchy 227928 instanceVariableNames: '' 227929 classVariableNames: '' 227930 poolDictionaries: '' 227931 category: 'Morphic-Widgets'! 227932 227933!MorphHierarchy methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:29'! 227934roots 227935 "Answer the roots for the Object Hierarchy, that means answer the World" 227936 ^ {MorphListItemWrapper with: World}! ! 227937 227938!MorphHierarchy methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:30'! 227939selected: aMorphListItemWrapper 227940 "Change the selected object" 227941 | newSelection | 227942 aMorphListItemWrapper isNil 227943 ifTrue: [^ self]. 227944 newSelection := aMorphListItemWrapper withoutListWrapper. 227945 newSelection == World selectedObject 227946 ifTrue: [newSelection removeHalo] 227947 ifFalse: [newSelection addHalo]. 227948 self changed: #selected! ! 227949 227950 227951!MorphHierarchy methodsFor: 'private' stamp: 'dgd 9/26/2004 18:28'! 227952asMorph 227953 "Answer the morph version of the receiver" 227954 | morph | 227955 morph := MorphHierarchyListMorph 227956 on: self 227957 list: #roots 227958 selected: nil 227959 changeSelected: #selected:. 227960 "" 227961 ^ morph inAContainer! ! 227962 227963"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 227964 227965MorphHierarchy class 227966 instanceVariableNames: ''! 227967 227968!MorphHierarchy class methodsFor: 'opening' stamp: 'dgd 9/25/2004 21:50'! 227969openOrDelete 227970 | oldMorph | 227971 oldMorph := World submorphs 227972 detect: [:each | each hasProperty: #morphHierarchy] 227973 ifNone: [| newMorph | 227974 newMorph := self new asMorph. 227975 newMorph bottomLeft: ActiveHand position. 227976 newMorph openInWorld. 227977 newMorph isFullOnScreen 227978 ifFalse: [newMorph goHome]. 227979 ^ self]. 227980 "" 227981 oldMorph delete! ! 227982SimpleHierarchicalListMorph subclass: #MorphHierarchyListMorph 227983 instanceVariableNames: '' 227984 classVariableNames: '' 227985 poolDictionaries: '' 227986 category: 'Morphic-Widgets'! 227987 227988!MorphHierarchyListMorph methodsFor: 'initialization' stamp: 'dgd 9/26/2004 18:18'! 227989on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel 227990 super 227991 on: anObject 227992 list: getListSel 227993 selected: getSelectionSel 227994 changeSelected: setSelectionSel 227995 menu: getMenuSel 227996 keystroke: keyActionSel. 227997 "" 227998 self borderWidth: 0. 227999 self autoDeselect: false. 228000 self enableDrag: false. 228001 self enableDrop: true. 228002 self hResizing: #spaceFill. 228003 self vResizing: #spaceFill. 228004self expandRoots! ! 228005 228006 228007!MorphHierarchyListMorph methodsFor: 'selection' stamp: 'dgd 9/25/2004 21:28'! 228008setSelectedMorph: aMorph 228009 super setSelectedMorph: aMorph. 228010self owner isNil ifFalse:[self owner delete]! ! 228011 228012 228013!MorphHierarchyListMorph methodsFor: 'private' stamp: 'dgd 9/26/2004 18:57'! 228014createContainer 228015 "Private - Create a container" 228016 | container | 228017 container := BorderedMorph new. 228018 container extent: (World extent * (1 / 4 @ (2 / 3))) rounded. 228019 container layoutPolicy: TableLayout new. 228020 container hResizing: #rigid. 228021 container vResizing: #rigid. 228022 container 228023 setColor: Preferences menuColor 228024 borderWidth: Preferences menuBorderWidth 228025 borderColor: Preferences menuBorderColor. 228026 container layoutInset: 0. 228027 "container useRoundedCorners." 228028 "" 228029 container setProperty: #morphHierarchy toValue: true. 228030 container setNameTo: 'Objects Hierarchy' translated. 228031 "" 228032 ^ container! ! 228033 228034!MorphHierarchyListMorph methodsFor: 'private' stamp: 'dgd 9/26/2004 18:27'! 228035inAContainer 228036 "Answer the receiver contained in a proper container" 228037 | container | 228038 container := self createContainer. 228039 container addMorphBack: self. 228040 " 228041 nasty hack to force the scroolbar recreation" 228042 self extent: container extent - container borderWidth. 228043 "" 228044 ^ container! ! 228045ListItemWrapper subclass: #MorphListItemWrapper 228046 instanceVariableNames: '' 228047 classVariableNames: '' 228048 poolDictionaries: '' 228049 category: 'Morphic-Widgets'! 228050 228051!MorphListItemWrapper methodsFor: 'accessing' stamp: 'marcus.denker 11/19/2008 13:47'! 228052contents 228053 "Answer the receiver's contents" 228054 228055 | tentative submorphs | 228056 tentative := item submorphs collect: [:each | each renderedMorph]. 228057 submorphs := tentative reject: [:each | each isKindOf: HaloMorph]. 228058 ^ submorphs collect: [:each | self class with: each]! ! 228059 228060!MorphListItemWrapper methodsFor: 'accessing' stamp: 'dgd 7/28/2005 13:03'! 228061icon 228062 "Answer a form to be used as icon" 228063 ^ item iconOrThumbnailOfSize: ((Preferences tinyDisplay ifTrue: [16] ifFalse: [28]))! ! 228064 228065 228066!MorphListItemWrapper methodsFor: 'converting' stamp: 'dgd 9/26/2004 18:26'! 228067asString 228068 "Answer the string representation of the receiver" 228069 ^ item externalName! ! 228070TestCase subclass: #MorphTest 228071 instanceVariableNames: 'morph world' 228072 classVariableNames: '' 228073 poolDictionaries: '' 228074 category: 'MorphicTests-Kernel'! 228075!MorphTest commentStamp: '<historical>' prior: 0! 228076This is the unit test for the class Morph. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 228077 - http://www.c2.com/cgi/wiki?UnitTest 228078 - http://minnow.cc.gatech.edu/squeak/1547 228079 - the sunit class category! 228080 228081 228082!MorphTest methodsFor: 'initialization' stamp: 'tak 1/21/2005 11:12'! 228083getWorld 228084 ^ world 228085 ifNil: [world := Project newMorphic world]! ! 228086 228087!MorphTest methodsFor: 'initialization' stamp: 'tak 1/21/2005 11:12'! 228088setUp 228089 morph := Morph new! ! 228090 228091!MorphTest methodsFor: 'initialization' stamp: 'tak 1/21/2005 11:12'! 228092tearDown 228093 morph delete. 228094 world 228095 ifNotNil: [Project deletingProject: world project]! ! 228096 228097 228098!MorphTest methodsFor: 'testing - classification' stamp: 'md 4/16/2003 17:11'! 228099testIsMorph 228100 self assert: (morph isMorph).! ! 228101 228102 228103!MorphTest methodsFor: 'testing - initialization' stamp: 'md 4/16/2003 17:10'! 228104testOpenInWorld 228105 self shouldnt: [morph openInWorld] raise: Error.! ! 228106 228107 228108!MorphTest methodsFor: 'testing - into/outof world' stamp: 'ar 8/4/2003 00:11'! 228109testIntoWorldCollapseOutOfWorld 228110 | m1 m2 collapsed | 228111 "Create the guys" 228112 m1 := TestInWorldMorph new. 228113 m2 := TestInWorldMorph new. 228114 self assert: (m1 intoWorldCount = 0). 228115 self assert: (m1 outOfWorldCount = 0). 228116 self assert: (m2 intoWorldCount = 0). 228117 self assert: (m2 outOfWorldCount = 0). 228118 228119 "add them to basic morph" 228120 morph addMorphFront: m1. 228121 m1 addMorphFront: m2. 228122 self assert: (m1 intoWorldCount = 0). 228123 self assert: (m1 outOfWorldCount = 0). 228124 self assert: (m2 intoWorldCount = 0). 228125 self assert: (m2 outOfWorldCount = 0). 228126 228127 "open the guy" 228128 morph openInWorld. 228129 self assert: (m1 intoWorldCount = 1). 228130 self assert: (m1 outOfWorldCount = 0). 228131 self assert: (m2 intoWorldCount = 1). 228132 self assert: (m2 outOfWorldCount = 0). 228133 228134 "collapse it" 228135 collapsed := CollapsedMorph new beReplacementFor: morph. 228136 self assert: (m1 intoWorldCount = 1). 228137 self assert: (m1 outOfWorldCount = 1). 228138 self assert: (m2 intoWorldCount = 1). 228139 self assert: (m2 outOfWorldCount = 1). 228140 228141 "expand it" 228142 collapsed collapseOrExpand. 228143 self assert: (m1 intoWorldCount = 2). 228144 self assert: (m1 outOfWorldCount = 1). 228145 self assert: (m2 intoWorldCount = 2). 228146 self assert: (m2 outOfWorldCount = 1). 228147 228148 "delete it" 228149 morph delete. 228150 self assert: (m1 intoWorldCount = 2). 228151 self assert: (m1 outOfWorldCount = 2). 228152 self assert: (m2 intoWorldCount = 2). 228153 self assert: (m2 outOfWorldCount = 2). 228154! ! 228155 228156!MorphTest methodsFor: 'testing - into/outof world' stamp: 'ar 8/4/2003 00:12'! 228157testIntoWorldDeleteOutOfWorld 228158 | m1 m2 | 228159 "Create the guys" 228160 m1 := TestInWorldMorph new. 228161 m2 := TestInWorldMorph new. 228162 self assert: (m1 intoWorldCount = 0). 228163 self assert: (m1 outOfWorldCount = 0). 228164 self assert: (m2 intoWorldCount = 0). 228165 self assert: (m2 outOfWorldCount = 0). 228166 228167 morph addMorphFront: m1. 228168 m1 addMorphFront: m2. 228169 self assert: (m1 intoWorldCount = 0). 228170 self assert: (m1 outOfWorldCount = 0). 228171 self assert: (m2 intoWorldCount = 0). 228172 self assert: (m2 outOfWorldCount = 0). 228173 228174 morph openInWorld. 228175 self assert: (m1 intoWorldCount = 1). 228176 self assert: (m1 outOfWorldCount = 0). 228177 self assert: (m2 intoWorldCount = 1). 228178 self assert: (m2 outOfWorldCount = 0). 228179 228180 morph delete. 228181 self assert: (m1 intoWorldCount = 1). 228182 self assert: (m1 outOfWorldCount = 1). 228183 self assert: (m2 intoWorldCount = 1). 228184 self assert: (m2 outOfWorldCount = 1). 228185 ! ! 228186 228187!MorphTest methodsFor: 'testing - into/outof world' stamp: 'ar 8/10/2003 18:30'! 228188testIntoWorldTransferToNewGuy 228189 | m1 m2 | 228190 "Create the guys" 228191 m1 := TestInWorldMorph new. 228192 m2 := TestInWorldMorph new. 228193 self assert: (m1 intoWorldCount = 0). 228194 self assert: (m1 outOfWorldCount = 0). 228195 self assert: (m2 intoWorldCount = 0). 228196 self assert: (m2 outOfWorldCount = 0). 228197 228198 morph addMorphFront: m1. 228199 m1 addMorphFront: m2. 228200 self assert: (m1 intoWorldCount = 0). 228201 self assert: (m1 outOfWorldCount = 0). 228202 self assert: (m2 intoWorldCount = 0). 228203 self assert: (m2 outOfWorldCount = 0). 228204 228205 morph openInWorld. 228206 self assert: (m1 intoWorldCount = 1). 228207 self assert: (m1 outOfWorldCount = 0). 228208 self assert: (m2 intoWorldCount = 1). 228209 self assert: (m2 outOfWorldCount = 0). 228210 228211 morph addMorphFront: m2. 228212 self assert: (m1 intoWorldCount = 1). 228213 self assert: (m1 outOfWorldCount = 0). 228214 self assert: (m2 intoWorldCount = 1). 228215 self assert: (m2 outOfWorldCount = 0). 228216 228217 morph addMorphFront: m1. 228218 self assert: (m1 intoWorldCount = 1). 228219 self assert: (m1 outOfWorldCount = 0). 228220 self assert: (m2 intoWorldCount = 1). 228221 self assert: (m2 outOfWorldCount = 0). 228222 228223 m2 addMorphFront: m1. 228224 self assert: (m1 intoWorldCount = 1). 228225 self assert: (m1 outOfWorldCount = 0). 228226 self assert: (m2 intoWorldCount = 1). 228227 self assert: (m2 outOfWorldCount = 0). 228228 228229 morph delete. 228230 self assert: (m1 intoWorldCount = 1). 228231 self assert: (m1 outOfWorldCount = 1). 228232 self assert: (m2 intoWorldCount = 1). 228233 self assert: (m2 outOfWorldCount = 1). 228234! ! 228235ListItemWrapper subclass: #MorphWithSubmorphsWrapper 228236 instanceVariableNames: '' 228237 classVariableNames: '' 228238 poolDictionaries: '' 228239 category: 'Morphic-Explorer'! 228240!MorphWithSubmorphsWrapper commentStamp: 'ls 3/1/2004 17:32' prior: 0! 228241Display a morph in a SimpleHierarchicalListMorph, and arrange to recursively display the morph's submorphs. The "item" that is wrapped is the morph to display.! 228242 228243 228244!MorphWithSubmorphsWrapper methodsFor: 'hierarchy' stamp: 'ls 3/1/2004 17:34'! 228245contents 228246 ^item submorphs collect: [ :m | 228247 self class with: m ]! ! 228248MessageSend subclass: #MorphicAlarm 228249 instanceVariableNames: 'scheduledTime numArgs' 228250 classVariableNames: '' 228251 poolDictionaries: '' 228252 category: 'Morphic-Events'! 228253 228254!MorphicAlarm methodsFor: 'accessing' stamp: 'ar 9/11/2000 16:44'! 228255scheduledTime 228256 "Return the time (in milliseconds) that the receiver is scheduled to be executed" 228257 ^scheduledTime! ! 228258 228259!MorphicAlarm methodsFor: 'accessing' stamp: 'ar 9/11/2000 16:45'! 228260scheduledTime: msecs 228261 "Set the time (in milliseconds) that the receiver is scheduled to be executed" 228262 scheduledTime := msecs! ! 228263 228264 228265!MorphicAlarm methodsFor: 'evaluating' stamp: 'ar 10/22/2000 17:36'! 228266value: anArgument 228267 | nArgs | 228268 numArgs ifNil:[numArgs := selector numArgs]. 228269 nArgs := arguments ifNil:[0] ifNotNil:[arguments size]. 228270 nArgs = numArgs ifTrue:[ 228271 "Ignore extra argument" 228272 ^self value]. 228273 ^arguments isNil 228274 ifTrue: [receiver perform: selector with: anArgument] 228275 ifFalse: [receiver perform: selector withArguments: (arguments copyWith: anArgument)]! ! 228276 228277"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 228278 228279MorphicAlarm class 228280 instanceVariableNames: ''! 228281 228282!MorphicAlarm class methodsFor: 'instance creation' stamp: 'ar 9/11/2000 16:44'! 228283scheduledAt: scheduledTime receiver: aTarget selector: aSelector arguments: argArray 228284 ^(self receiver: aTarget selector: aSelector arguments: argArray) 228285 scheduledTime: scheduledTime.! ! 228286Object subclass: #MorphicEvent 228287 instanceVariableNames: 'timeStamp source windowIndex' 228288 classVariableNames: '' 228289 poolDictionaries: '' 228290 category: 'Morphic-Events'! 228291!MorphicEvent commentStamp: '<historical>' prior: 0! 228292This class represents the base for all events. 228293 228294Instance variables: 228295 stamp <Integer> The millisecond clock time stamp (based on Time millisecondClock) 228296 source <Hand | nil> If non-nil the hand that generated the event.! 228297 228298 228299!MorphicEvent methodsFor: 'accessing' stamp: 'ar 10/10/2000 21:28'! 228300cursorPoint 228301 "Backward compatibility. Use #position instead" 228302 ^ self position! ! 228303 228304!MorphicEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 16:48'! 228305hand 228306 "Return the source that generated the event" 228307 ^source! ! 228308 228309!MorphicEvent methodsFor: 'accessing' stamp: 'wiz 12/8/2004 23:13'! 228310position 228311 "Since cursorPoint is defined and refers to position it should be defined 228312 here as well" 228313 ^ self subclassResponsibility! ! 228314 228315!MorphicEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:29'! 228316timeStamp 228317 "Return the millisecond clock value at which the event was generated" 228318 ^timeStamp ifNil:[timeStamp := Time millisecondClockValue]! ! 228319 228320!MorphicEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:34'! 228321type 228322 "Return a symbol indicating the type this event." 228323 ^self subclassResponsibility! ! 228324 228325!MorphicEvent methodsFor: 'accessing' stamp: 'ar 10/10/2000 01:19'! 228326wasHandled 228327 "Return true if this event was handled. May be ignored for some types of events." 228328 ^false! ! 228329 228330!MorphicEvent methodsFor: 'accessing' stamp: 'ar 10/10/2000 01:20'! 228331wasHandled: aBool 228332 "Determine if this event was handled. May be ignored for some types of events."! ! 228333 228334!MorphicEvent methodsFor: 'accessing' stamp: 'JMM 7/20/2004 22:10'! 228335windowIndex 228336 ^windowIndex! ! 228337 228338!MorphicEvent methodsFor: 'accessing' stamp: 'JMM 7/20/2004 22:10'! 228339windowIndex: aValue 228340 windowIndex := aValue! ! 228341 228342 228343!MorphicEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:36'! 228344= anEvent 228345 anEvent isMorphicEvent ifFalse:[^false]. 228346 ^self type = anEvent type! ! 228347 228348!MorphicEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:36'! 228349hash 228350 ^self type hash! ! 228351 228352 228353!MorphicEvent methodsFor: 'dispatching' stamp: 'ar 9/15/2000 21:12'! 228354sentTo: anObject 228355 "Dispatch the receiver into anObject" 228356 ^anObject handleUnknownEvent: self! ! 228357 228358 228359!MorphicEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:18'! 228360copyHandlerState: anEvent 228361 "Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events." 228362! ! 228363 228364!MorphicEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:18'! 228365resetHandlerFields 228366 "Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"! ! 228367 228368!MorphicEvent methodsFor: 'initialize' stamp: 'ar 10/24/2000 16:21'! 228369type: eventType readFrom: aStream 228370 "Read a MorphicEvent from the given stream." 228371! ! 228372 228373 228374!MorphicEvent methodsFor: 'object filein' stamp: 'marcus.denker 8/24/2008 21:40'! 228375convertOctober2000: varDict using: smartRefStrm 228376 "ar 10/25/2000: This method is used to convert OLD MorphicEvents into new ones." 228377 "These are going away #('type' 'cursorPoint' 'buttons' 'keyValue' 'sourceHand'). Possibly store their info in another variable?" 228378 | type cursorPoint buttons keyValue sourceHand | 228379 type := varDict at: 'type'. 228380 cursorPoint := varDict at: 'cursorPoint'. 228381 buttons := varDict at: 'buttons'. 228382 keyValue := varDict at: 'keyValue'. 228383 sourceHand := varDict at: 'sourceHand'. 228384 type == #mouseMove ifTrue:[ 228385 ^MouseMoveEvent basicNew 228386 setType: #mouseMove 228387 startPoint: cursorPoint 228388 endPoint: cursorPoint 228389 trail: #() 228390 buttons: buttons 228391 hand: sourceHand 228392 stamp: nil]. 228393 (type == #mouseDown) | (type == #mouseUp) ifTrue:[ 228394 ^MouseButtonEvent basicNew 228395 setType: type 228396 position: cursorPoint 228397 which: 0 228398 buttons: buttons 228399 hand: sourceHand 228400 stamp: nil]. 228401 (type == #keystroke) | (type == #keyDown) | (type == #keyUp) ifTrue:[ 228402 ^KeyboardEvent basicNew 228403 setType: type 228404 buttons: buttons 228405 position: cursorPoint 228406 keyValue: keyValue 228407 hand: sourceHand 228408 stamp: nil]. 228409 "All others will be handled there" 228410 ^MorphicUnknownEvent basicNew! ! 228411 228412 228413!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/22/2000 10:36'! 228414isDraggingEvent 228415 ^false! ! 228416 228417!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:17'! 228418isDropEvent 228419 ^false! ! 228420 228421!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:19'! 228422isKeyboard 228423 ^false! ! 228424 228425!MorphicEvent methodsFor: 'testing' stamp: 'ar 10/10/2000 21:27'! 228426isKeystroke 228427 ^false! ! 228428 228429!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:37'! 228430isMorphicEvent 228431 ^true! ! 228432 228433!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:19'! 228434isMouse 228435 ^false! ! 228436 228437!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/14/2000 18:21'! 228438isMouseOver 228439 ^self type == #mouseOver! ! 228440 228441!MorphicEvent methodsFor: 'testing' stamp: 'JMM 10/6/2004 21:23'! 228442isMove 228443 ^false! ! 228444 228445!MorphicEvent methodsFor: 'testing' stamp: 'JMM 10/6/2004 21:35'! 228446isWindowEvent 228447 ^false! ! 228448 228449 228450!MorphicEvent methodsFor: 'transforming' stamp: 'ar 9/13/2000 15:47'! 228451transformedBy: aMorphicTransform 228452 "Return the receiver transformed by the given transform into a local coordinate system." 228453! ! 228454 228455 228456!MorphicEvent methodsFor: 'private' stamp: 'ar 10/25/2000 21:26'! 228457setHand: aHand 228458 source := aHand! ! 228459 228460!MorphicEvent methodsFor: 'private' stamp: 'ar 10/25/2000 20:53'! 228461setTimeStamp: stamp 228462 timeStamp := stamp.! ! 228463 228464"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 228465 228466MorphicEvent class 228467 instanceVariableNames: ''! 228468 228469!MorphicEvent class methodsFor: 'instance creation' stamp: 'marcus.denker 8/24/2008 21:54'! 228470readFrom: aStream 228471 228472 "Read a MorphicEvent from the given stream." 228473 | typeString c | 228474 typeString := String streamContents: 228475 [:s | [(c := aStream next) isLetter] whileTrue: [s nextPut: c]]. 228476 typeString = 'mouseMove' ifTrue:[^MouseMoveEvent type: #mouseMove readFrom: aStream]. 228477 typeString = 'mouseDown' ifTrue:[^MouseButtonEvent type: #mouseDown readFrom: aStream]. 228478 typeString = 'mouseUp' ifTrue:[^MouseButtonEvent type: #mouseUp readFrom: aStream]. 228479 228480 typeString = 'keystroke' ifTrue:[^KeyboardEvent type: #keystroke readFrom: aStream]. 228481 typeString = 'keyDown' ifTrue:[^KeyboardEvent type: #keyDown readFrom: aStream]. 228482 typeString = 'keyUp' ifTrue:[^KeyboardEvent type: #keyUp readFrom: aStream]. 228483 228484 typeString = 'mouseOver' ifTrue:[^MouseEvent type: #mouseOver readFrom: aStream]. 228485 typeString = 'mouseEnter' ifTrue:[^MouseEvent type: #mouseEnter readFrom: aStream]. 228486 typeString = 'mouseLeave' ifTrue:[^MouseEvent type: #mouseLeave readFrom: aStream]. 228487 228488 typeString = 'unknown' ifTrue:[^MorphicUnknownEvent type: #unknown readFrom: aStream]. 228489 228490 ^nil 228491! ! 228492 228493!MorphicEvent class methodsFor: 'instance creation' stamp: 'marcus.denker 8/24/2008 21:41'! 228494readFromObsolete: aStream 228495 "Read one of those old and now obsolete events from the stream" 228496 | type x y buttons keyValue typeString c | 228497 typeString := String streamContents: 228498 [:s | [(c := aStream next) isLetter] whileTrue: [s nextPut: c]]. 228499 typeString = 'mouseMove' 228500 ifTrue: [type := #mouseMove "fast treatment of common case"] 228501 ifFalse: [type := typeString asSymbol]. 228502 228503 x := Integer readFrom: aStream. 228504 aStream skip: 1. 228505 y := Integer readFrom: aStream. 228506 aStream skip: 1. 228507 228508 buttons := Integer readFrom: aStream. 228509 aStream skip: 1. 228510 228511 keyValue := Integer readFrom: aStream. 228512 228513 typeString = 'mouseMove' ifTrue:[ 228514 ^MouseMoveEvent basicNew 228515 setType: #mouseMove 228516 startPoint: x@y 228517 endPoint: x@y 228518 trail: #() 228519 buttons: buttons 228520 hand: nil 228521 stamp: nil]. 228522 (typeString = 'mouseDown') | (typeString = 'mouseUp') ifTrue:[ 228523 ^MouseButtonEvent basicNew 228524 setType: type 228525 position: x@y 228526 which: 0 228527 buttons: buttons 228528 hand: nil 228529 stamp: nil]. 228530 (typeString = 'keystroke') | (typeString = 'keyDown') | (typeString = 'keyUp') ifTrue:[ 228531 ^KeyboardEvent basicNew 228532 setType: type 228533 buttons: buttons 228534 position: x@y 228535 keyValue: keyValue 228536 hand: nil 228537 stamp: nil]. 228538 228539 ^nil! ! 228540 228541!MorphicEvent class methodsFor: 'instance creation' stamp: 'marcus.denker 8/24/2008 21:39'! 228542type: eventType readFrom: aStream 228543 ^self basicNew type: eventType readFrom: aStream! ! 228544Object subclass: #MorphicEventDispatcher 228545 instanceVariableNames: 'lastType lastDispatch' 228546 classVariableNames: '' 228547 poolDictionaries: '' 228548 category: 'Morphic-Events'! 228549!MorphicEventDispatcher commentStamp: '<historical>' prior: 0! 228550The class represents a strategy for dispatching events to some immediate child of a morph. It is used by morphs to delegate the somewhat complex action of dispatching events accurately. ! 228551 228552 228553!MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 10/10/2000 01:20'! 228554dispatchDefault: anEvent with: aMorph 228555 "Dispatch the given event. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." 228556 | localEvt index child morphs inside | 228557 "See if we're fully outside aMorphs bounds" 228558 (aMorph fullBounds containsPoint: anEvent position) ifFalse:[^#rejected]. "outside" 228559 "Traverse children" 228560 index := 1. 228561 morphs := aMorph submorphs. 228562 inside := false. 228563 [index <= morphs size] whileTrue:[ 228564 child := morphs at: index. 228565 localEvt := anEvent transformedBy: (child transformedFrom: aMorph). 228566 (child processEvent: localEvt using: self) == #rejected ifFalse:[ 228567 "Not rejected. The event was in some submorph of the receiver" 228568 inside := true. 228569 localEvt wasHandled ifTrue:[anEvent copyHandlerState: localEvt]. 228570 index := morphs size. "break" 228571 ]. 228572 index := index + 1. 228573 ]. 228574 228575 "Check for being inside the receiver" 228576 inside ifFalse:[inside := aMorph containsPoint: anEvent position event: anEvent]. 228577 inside ifTrue:[^aMorph handleEvent: anEvent]. 228578 ^#rejected 228579! ! 228580 228581!MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:13'! 228582dispatchDropEvent: anEvent with: aMorph 228583 "Find the appropriate receiver for the event and let it handle it. The dispatch is similar to the default dispatch with one difference: Morphs are given the chance to reject an entire drop operation. If the operation is rejected, no drop will be executed." 228584 | inside index morphs child localEvt | 228585 "Try to get out quickly" 228586 (aMorph fullBounds containsPoint: anEvent cursorPoint) 228587 ifFalse:[^#rejected]. 228588 "Give aMorph a chance to repel the dropping morph" 228589 aMorph rejectDropEvent: anEvent. 228590 anEvent wasHandled ifTrue:[^self]. 228591 228592 "Go looking if any of our submorphs wants it" 228593 index := 1. 228594 inside := false. 228595 morphs := aMorph submorphs. 228596 [index <= morphs size] whileTrue:[ 228597 child := morphs at: index. 228598 localEvt := anEvent transformedBy: (child transformedFrom: aMorph). 228599 (child processEvent: localEvt using: self) == #rejected ifFalse:[ 228600 localEvt wasHandled ifTrue:[^anEvent wasHandled: true]. "done" 228601 inside := true. 228602 index := morphs size]. "break" 228603 index := index + 1. 228604 ]. 228605 228606 inside ifFalse:[inside := aMorph containsPoint: anEvent cursorPoint event: anEvent]. 228607 inside ifTrue:[^aMorph handleEvent: anEvent]. 228608 ^#rejected! ! 228609 228610!MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 1/10/2001 21:43'! 228611dispatchEvent: anEvent with: aMorph 228612 "Dispatch the given event for a morph that has chosen the receiver to dispatch its events. The method implements a shortcut for repeated dispatches of events using the same dispatcher." 228613 anEvent type == lastType ifTrue:[^self perform: lastDispatch with: anEvent with: aMorph]. 228614 "Otherwise classify" 228615 lastType := anEvent type. 228616 anEvent isMouse ifTrue:[ 228617 anEvent isMouseDown ifTrue:[ 228618 lastDispatch := #dispatchMouseDown:with:. 228619 ^self dispatchMouseDown: anEvent with: aMorph]]. 228620 anEvent type == #dropEvent ifTrue:[ 228621 lastDispatch := #dispatchDropEvent:with:. 228622 ^self dispatchDropEvent: anEvent with: aMorph]. 228623 lastDispatch := #dispatchDefault:with:. 228624 ^self dispatchDefault: anEvent with: aMorph! ! 228625 228626!MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:14'! 228627dispatchMouseDown: anEvent with: aMorph 228628 "Find the appropriate receiver for the event and let it handle it. Default rules: 228629 * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. 228630 * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. 228631 * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. 228632 * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. 228633" 228634 | globalPt localEvt index child morphs handler inside lastHandler | 228635 "Try to get out quickly" 228636 globalPt := anEvent cursorPoint. 228637 (aMorph fullBounds containsPoint: globalPt) ifFalse:[^#rejected]. 228638 228639 "Install the prospective handler for the receiver" 228640 lastHandler := anEvent handler. "in case the mouse wasn't even in the receiver" 228641 handler := aMorph handlerForMouseDown: anEvent. 228642 handler ifNotNil:[anEvent handler: handler]. 228643 228644 "Now give our submorphs a chance to handle the event" 228645 index := 1. 228646 morphs := aMorph submorphs. 228647 [index <= morphs size] whileTrue:[ 228648 child := morphs at: index. 228649 localEvt := anEvent transformedBy: (child transformedFrom: aMorph). 228650 (child processEvent: localEvt using: self) == #rejected ifFalse:[ 228651 "Some child did contain the point so we're part of the top-most chain." 228652 inside := false. 228653 localEvt wasHandled ifTrue:[anEvent copyHandlerState: localEvt]. 228654 index := morphs size]. 228655 index := index + 1. 228656 ]. 228657 228658 (inside == false or:[aMorph containsPoint: anEvent cursorPoint event: anEvent]) ifTrue:[ 228659 "Receiver is in the top-most unlocked, visible chain." 228660 handler ifNotNil:[handler handleEvent: anEvent]. 228661 "Note: Re-installing the handler is not really necessary but good style." 228662 anEvent handler: lastHandler. 228663 ^self 228664 ]. 228665 "Mouse was not on receiver nor any of its children" 228666 anEvent handler: lastHandler. 228667 ^#rejected! ! 228668BorderedMorph subclass: #MorphicModel 228669 instanceVariableNames: 'model slotName open' 228670 classVariableNames: '' 228671 poolDictionaries: '' 228672 category: 'Morphic-Kernel'! 228673!MorphicModel commentStamp: '<historical>' prior: 0! 228674MorphicModels are used to represent structures with state and behavior as well as graphical structure. A morphicModel is usually the root of a morphic tree depicting its appearance. The tree is constructed concretely by adding its consituent morphs to a world. 228675 228676When a part is named in a world, it is given a new slot in the model. When a part is sensitized, it is named, and a set of mouse-driven methods is also generated in the model. These may be edited to induce particular behavior. When a variable is added through the morphic world, it is given a slot in the model, along with a set of access methods. 228677 228678In addition for public variables (and this is the default for now), methods are generated and called in any outer model in which this model gets embedded, thus propagating variable changes outward.! 228679 228680 228681!MorphicModel methodsFor: 'access'! 228682model 228683 ^ model! ! 228684 228685 228686!MorphicModel methodsFor: 'accessing' stamp: 'sw 10/23/1999 22:36'! 228687modelOrNil 228688 ^ model! ! 228689 228690 228691!MorphicModel methodsFor: 'caching' stamp: 'sw 3/6/2001 11:22'! 228692releaseCachedState 228693 "Release cached state of the receiver" 228694 228695 (model ~~ self and: [model respondsTo: #releaseCachedState]) ifTrue: 228696 [model releaseCachedState]. 228697 super releaseCachedState! ! 228698 228699 228700!MorphicModel methodsFor: 'classification' stamp: 'ar 10/5/2000 16:40'! 228701isMorphicModel 228702 ^true! ! 228703 228704 228705!MorphicModel methodsFor: 'compilation' stamp: 'DamienCassou 9/29/2009 13:02'! 228706addPartNameLike: className withValue: aMorph 228707 | otherNames i default partName stem | 228708 stem := className first asLowercase asString , className allButFirst. 228709 otherNames := self class allInstVarNames. 228710 i := 1. 228711 [otherNames includes: (default := stem, i printString)] 228712 whileTrue: [i := i + 1]. 228713 partName := UIManager default 228714 request: 'Please give this part a name' translated 228715 initialAnswer: default. 228716 partName ifNil: [partName := String new]. 228717 (otherNames includes: partName) 228718 ifTrue: [self inform: 'Sorry, that name is already used' translated. ^ nil]. 228719 self class addInstVarName: partName. 228720 self instVarAt: self class instSize put: aMorph. "Assumes added as last field" 228721 ^ partName! ! 228722 228723!MorphicModel methodsFor: 'compilation'! 228724nameFor: aMorph 228725 "Return the name of the slot containing the given morph or nil if that morph has not been named." 228726 228727 | allNames start | 228728 allNames := self class allInstVarNames. 228729 start := MorphicModel allInstVarNames size + 1. 228730 start to: allNames size do: [:i | 228731 (self instVarAt: i) == aMorph ifTrue: [^ allNames at: i]]. 228732 ^ nil 228733! ! 228734 228735!MorphicModel methodsFor: 'compilation' stamp: 'tk 10/31/97 12:33'! 228736removeAll 228737 "Clear out all script methods and subpart instance variables in me. Start over." 228738 "self removeAll" 228739 "MorphicModel2 removeAll" 228740 228741self class == MorphicModel ifTrue: [^ self]. "Must be a subclass!!" 228742self class removeCategory: 'scripts'. 228743self class instVarNames do: [:nn | self class removeInstVarName: nn].! ! 228744 228745!MorphicModel methodsFor: 'compilation'! 228746use: cachedSelector orMakeModelSelectorFor: selectorBody in: selectorBlock 228747 | selector | 228748 model ifNil: [^ nil]. 228749 cachedSelector ifNil: 228750 ["Make up selector from slotname if any" 228751 selector := (slotName ifNil: [selectorBody] 228752 ifNotNil: [slotName , selectorBody]) asSymbol. 228753 (model class canUnderstand: selector) ifFalse: 228754 [(self confirm: 'Shall I compile a null response for' 228755 , Character cr asString 228756 , model class name , '>>' , selector) 228757 ifFalse: [self halt]. 228758 model class compile: (String streamContents: 228759 [:s | selector keywords doWithIndex: 228760 [:k :i | s nextPutAll: k , ' arg' , i printString]. 228761 s cr; nextPutAll: '"Automatically generated null response."'. 228762 s cr; nextPutAll: '"Add code below for appropriate behavior..."'.]) 228763 classified: 'input events' 228764 notifying: nil]] 228765 ifNotNil: 228766 [selector := cachedSelector]. 228767 ^ selectorBlock value: selector! ! 228768 228769 228770!MorphicModel methodsFor: 'drag and drop' stamp: 'di 6/22/97 23:16'! 228771isOpen 228772 "Support drag/drop and other edits." 228773 ^ open! ! 228774 228775 228776!MorphicModel methodsFor: 'geometry'! 228777newBounds: newBounds 228778 self bounds: newBounds! ! 228779 228780 228781!MorphicModel methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'! 228782defaultBorderColor 228783 "answer the default border color/fill style for the receiver" 228784 ^ Color yellow! ! 228785 228786!MorphicModel methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:07'! 228787defaultBounds 228788"answer the default bounds for the receiver" 228789 ^ 0 @ 0 corner: 200 @ 100! ! 228790 228791!MorphicModel methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:28'! 228792defaultColor 228793 "answer the default color/fill style for the receiver" 228794 ^ Color transparent! ! 228795 228796!MorphicModel methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:10'! 228797initialize 228798 "initialize the state of the receiver" 228799 super initialize. 228800"" 228801 open := false! ! 228802 228803!MorphicModel methodsFor: 'initialization' stamp: 'jm 228804 8/20/1998 09:08'! 228805model: anObject 228806 "Set my model and make me me a dependent of the given object." 228807 228808 model ifNotNil: [model removeDependent: self]. 228809 anObject ifNotNil: [anObject addDependent: self]. 228810 model := anObject. 228811! ! 228812 228813!MorphicModel methodsFor: 'initialization' stamp: 'di 6/21/97 13:25'! 228814model: thang slotName: nameOfThisPart 228815 model := thang. 228816 slotName := nameOfThisPart. 228817 open := false.! ! 228818 228819 228820!MorphicModel methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:53'! 228821addCustomMenuItems: aCustomMenu hand: aHandMorph 228822 228823 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 228824 model ifNotNil: [model addModelMenuItemsTo: aCustomMenu forMorph: self hand: aHandMorph]. 228825 self isOpen ifTrue: [aCustomMenu add: 'close editing' translated action: #closeToEdits] 228826 ifFalse: [aCustomMenu add: 'open editing' translated action: #openToEdits]. 228827! ! 228828 228829!MorphicModel methodsFor: 'menu' stamp: 'di 6/20/97 15:36'! 228830closeToEdits 228831 "Disable this morph's ability to add and remove morphs via drag-n-drop." 228832 228833 open := false 228834! ! 228835 228836!MorphicModel methodsFor: 'menu' stamp: 'di 6/20/97 15:36'! 228837openToEdits 228838 "Enable this morph's ability to add and remove morphs via drag-n-drop." 228839 228840 open := true 228841! ! 228842 228843 228844!MorphicModel methodsFor: 'submorphs-add/remove' stamp: 'alain.plantec 2/6/2009 11:33'! 228845delete 228846 model isMorphicModel 228847 ifFalse: [^ super delete]. 228848 slotName 228849 ifNotNil: [(self confirm: 'Shall I remove the slot "' translated , slotName , '"\along with all associated methods?' withCRs translated) 228850 ifTrue: [(model class selectors 228851 select: [:s | s beginsWith: slotName]) 228852 do: [:s | model class removeSelector: s]. 228853 (model class instVarNames includes: slotName) 228854 ifTrue: [model class removeInstVarName: slotName]] 228855 ifFalse: [(self confirm: '...but should I at least dismiss this morph?' translated , ('\' , 'Choose "No" to leave everything unchanged' translated) withCRs) 228856 ifFalse: [^ self]]]. 228857 super delete! ! 228858 228859"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 228860 228861MorphicModel class 228862 instanceVariableNames: 'prototype'! 228863 228864!MorphicModel class methodsFor: 'compilation' stamp: 'tk 3/10/98 18:03'! 228865categoryForSubclasses 228866 ^ 'Morphic-Models'! ! 228867 228868!MorphicModel class methodsFor: 'compilation' stamp: 'alain.plantec 2/6/2009 15:39'! 228869chooseNewName 228870 "Choose a new name for the receiver, persisting until an acceptable name is provided or until the existing name is resubmitted" 228871 228872 | oldName newName | 228873 oldName := self name. 228874 [newName := (UIManager default request: 'Please give this Model a name' translated 228875 initialAnswer: oldName) asSymbol. 228876 newName = oldName ifTrue: [^ self]. 228877 Smalltalk includesKey: newName] 228878 whileTrue: 228879 [self inform: 'Sorry, that name is already in use.' translated]. 228880 self rename: newName.! ! 228881 228882!MorphicModel class methodsFor: 'compilation' stamp: 'stephane.ducasse 7/3/2009 21:39'! 228883compileAccessorsFor: varName 228884 self compile: ( 228885'&var 228886 "Return the value of &var" 228887 ^ &var' 228888 copyReplaceAll: '&var' with: varName) 228889 classified: 'public access' notifying: nil. 228890 self compile: ( 228891'&varPut: newValue 228892 "Assign newValue to &var. 228893 Add code below to update related graphics appropriately..." 228894 228895 &var := newValue.' 228896 copyReplaceAll: '&var' with: varName) 228897 classified: 'public access' notifying: nil. 228898 self compile: ( 228899'&var: newValue 228900 "Assigns newValue to &var and updates owner" 228901 &var := newValue. 228902 self propagate: &var as: ''&var:''' 228903 copyReplaceAll: '&var' with: varName) 228904 classified: 'private - propagation' notifying: nil. 228905! ! 228906 228907!MorphicModel class methodsFor: 'compilation'! 228908compilePropagationForVarName: varName slotName: slotName 228909 self compile: (( 228910'&slot&var: newValue 228911 "The value of &var in &slot has changed to newValue. 228912 This value can be read elsewhere in code with 228913 &slot &var 228914 and it can be stored into with 228915 &slot &varPut: someValue" 228916 228917 "Add code for appropriate response here..."' 228918 copyReplaceAll: '&var' with: varName) 228919 copyReplaceAll: '&slot' with: slotName) 228920 classified: 'input events' notifying: nil. 228921! ! 228922 228923 228924!MorphicModel class methodsFor: 'compiling' stamp: 'sw 5/13/1998 14:33'! 228925acceptsLoggingOfCompilation 228926 "Dont log sources for my automatically-generated subclasses. Can easily switch this back when it comes to deal with Versions, etc." 228927 228928 ^ self == MorphicModel or: [(name last isDigit) not]! ! 228929 228930!MorphicModel class methodsFor: 'compiling' stamp: 'sw 8/4/97 17:16'! 228931wantsChangeSetLogging 228932 "Log changes for MorphicModel itself and for things like PlayWithMe2, but not for automatically-created subclasses like MorphicModel1, MorphicModel2, etc." 228933 228934 ^ self == MorphicModel or: 228935 [(self class name beginsWith: 'Morphic') not]! ! 228936 228937 228938!MorphicModel class methodsFor: 'housekeeping' stamp: 'jm 7/30/97 16:40'! 228939removeUninstantiatedModels 228940 "With the user's permission, remove the classes of any models that have neither instances nor subclasses." 228941 "MorphicModel removeUninstantiatedModels" 228942 228943 | candidatesForRemoval ok | 228944 Smalltalk garbageCollect. 228945 candidatesForRemoval := 228946 MorphicModel subclasses select: [:c | 228947 (c instanceCount = 0) and: [c subclasses size = 0]]. 228948 candidatesForRemoval do: [:c | 228949 ok := self confirm: 'Are you certain that you 228950want to delete the class ', c name, '?'. 228951 ok ifTrue: [c removeFromSystem]]. 228952! ! 228953 228954 228955!MorphicModel class methodsFor: 'instance creation' stamp: 'tk 8/13/1998 12:58'! 228956new 228957 "Return a copy of the prototype, if there is one. 228958 Otherwise create a new instance normally." 228959 228960 self hasPrototype ifTrue: [^ prototype veryDeepCopy]. 228961 ^ super new 228962! ! 228963 228964!MorphicModel class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:27'! 228965newBounds: bounds model: thang slotName: nameOfThisPart 228966 ^ (super new model: thang slotName: nameOfThisPart) 228967 newBounds: bounds! ! 228968 228969 228970!MorphicModel class methodsFor: 'new-morph participation' stamp: 'di 2/21/98 11:01'! 228971includeInNewMorphMenu 228972 "Only include Models that are appropriate" 228973 ^ false! ! 228974 228975 228976!MorphicModel class methodsFor: 'prototype access'! 228977prototype 228978 "Return the prototype for this morph." 228979 228980 ^ prototype 228981! ! 228982 228983!MorphicModel class methodsFor: 'prototype access' stamp: 'gm 2/22/2003 19:13'! 228984prototype: aMorph 228985 "Store a copy of the given morph as a prototype to be copied to make new instances." 228986 228987 aMorph ifNil: [prototype := nil. ^ self]. 228988 228989 prototype := aMorph veryDeepCopy. 228990 (prototype isMorphicModel) ifTrue: 228991 [prototype model: nil slotName: nil]. 228992! ! 228993 228994 228995!MorphicModel class methodsFor: 'queries'! 228996hasPrototype 228997 "Return true if there is a prototype for this morph." 228998 228999 ^ prototype ~~ nil 229000! ! 229001 229002 229003!MorphicModel class methodsFor: 'subclass creation'! 229004newSubclass 229005 | i className | 229006 i := 1. 229007 [className := (self name , i printString) asSymbol. 229008 Smalltalk includesKey: className] 229009 whileTrue: [i := i + 1]. 229010 229011 ^ self subclass: className 229012 instanceVariableNames: '' 229013 classVariableNames: '' 229014 poolDictionaries: '' 229015 category: 'Morphic-Models'! ! 229016 229017 229018!MorphicModel class methodsFor: 'testing' stamp: 'tk 3/15/98 20:13'! 229019officialClass 229020 "We want to make a new instance of the receiver, which is a subclass of MorphicModel. Answer who to make a new subclass of. Also used to tell if a given class is a UniClass, existing only for its single instance." 229021 229022 ^ self name last isDigit ifTrue: [MorphicModel] ifFalse: [self] 229023 "MorphicModel7 can not have subclasses, but Slider and SystemWindow may"! ! 229024AppRegistry subclass: #MorphicTextEditor 229025 instanceVariableNames: '' 229026 classVariableNames: '' 229027 poolDictionaries: '' 229028 category: 'System-Applications'! 229029ToolBuilder subclass: #MorphicToolBuilder 229030 instanceVariableNames: 'widgets panes parentMenu' 229031 classVariableNames: '' 229032 poolDictionaries: '' 229033 category: 'ToolBuilder-Morphic'! 229034!MorphicToolBuilder commentStamp: 'ar 2/11/2005 15:02' prior: 0! 229035The Morphic tool builder.! 229036 229037 229038!MorphicToolBuilder methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/3/2007 13:16'! 229039setFrame: aRectangle in: widget 229040 "Updated to recognize real layout frames for flexibility." 229041 229042 | frame | 229043 aRectangle ifNil: [^nil]. 229044 frame := aRectangle isRectangle 229045 ifTrue: [self asFrame: aRectangle] 229046 ifFalse: [aRectangle]. "assume LayoutFrame" 229047 widget layoutFrame: frame. 229048 widget hResizing: #spaceFill; vResizing: #spaceFill. 229049 (parent isSystemWindow) ifTrue:[ 229050 widget borderWidth: 2; borderColor: #inset]! ! 229051 229052 229053!MorphicToolBuilder methodsFor: 'building' stamp: 'ar 2/28/2006 17:30'! 229054buildPluggableMenu: menuSpec 229055 | prior menu | 229056 prior := parentMenu. 229057 parentMenu := menu := MenuMorph new. 229058 menuSpec label ifNotNil:[parentMenu addTitle: menuSpec label]. 229059 menuSpec items do:[:each| each buildWith: self]. 229060 parentMenu := prior. 229061 ^menu! ! 229062 229063!MorphicToolBuilder methodsFor: 'building' stamp: 'ar 2/28/2006 17:37'! 229064buildPluggableMenuItem: itemSpec 229065 | item action label menu | 229066 item := MenuItemMorph new. 229067 label := itemSpec label. 229068 itemSpec checked ifTrue:[label := '<on>', label] ifFalse:[label := '<off>', label]. 229069 item contents: label. 229070 item isEnabled: itemSpec enabled. 229071 (action := itemSpec action) ifNotNil:[ 229072 item 229073 target: action receiver; 229074 selector: action selector; 229075 arguments: action arguments. 229076 ]. 229077 (menu := itemSpec subMenu) ifNotNil:[ 229078 item subMenu: (menu buildWith: self). 229079 ]. 229080 parentMenu ifNotNil:[parentMenu addMorphBack: item]. 229081 ^item! ! 229082 229083 229084!MorphicToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:40'! 229085close: aWidget 229086 "Close a previously opened widget" 229087 aWidget delete! ! 229088 229089!MorphicToolBuilder methodsFor: 'opening' stamp: 'ar 2/28/2006 17:39'! 229090open: anObject 229091 "Build and open the object. Answer the widget opened." 229092 | morph | 229093 morph := self build: anObject. 229094 (morph isKindOf: MenuMorph) 229095 ifTrue:[morph popUpInWorld: World]. 229096 (morph isKindOf: SystemWindow) 229097 ifTrue:[morph openInWorldExtent: morph extent] 229098 ifFalse:[morph openInWorld]. 229099 ^morph! ! 229100 229101!MorphicToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:40'! 229102open: anObject label: aString 229103 "Build an open the object, labeling it appropriately. Answer the widget opened." 229104 | window | 229105 window := self open: anObject. 229106 window setLabel: aString. 229107 ^window! ! 229108 229109!MorphicToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:41'! 229110runModal: aWidget 229111 "Run the (previously opened) widget modally, e.g., 229112 do not return control to the sender before the user has responded." 229113 [aWidget world notNil] whileTrue: [ 229114 aWidget outermostWorldMorph doOneCycle. 229115 ]. 229116! ! 229117 229118 229119!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 2/12/2005 14:22'! 229120buildPluggableActionButton: aSpec 229121 | button | 229122 button := self buildPluggableButton: aSpec. 229123 button beActionButton. 229124 ^button! ! 229125 229126!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/14/2005 22:27'! 229127buildPluggableButton: aSpec 229128 | widget label state action enabled | 229129 label := aSpec label. 229130 state := aSpec state. 229131 action := aSpec action. 229132 widget := PluggableButtonMorphPlus on: aSpec model 229133 getState: (state isSymbol ifTrue:[state]) 229134 action: nil 229135 label: (label isSymbol ifTrue:[label]). 229136 self register: widget id: aSpec name. 229137 enabled := aSpec enabled. 229138 enabled isSymbol 229139 ifTrue:[widget getEnabledSelector: enabled] 229140 ifFalse:[widget enabled:enabled]. 229141 widget action: action. 229142 widget getColorSelector: aSpec color. 229143 widget offColor: Color transparent. 229144 aSpec help ifNotNil:[widget setBalloonText: aSpec help]. 229145 (label isSymbol or:[label == nil]) ifFalse:[widget label: label]. 229146 self setFrame: aSpec frame in: widget. 229147 parent ifNotNil:[self add: widget to: parent]. 229148 ^widget! ! 229149 229150!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'md 8/15/2005 17:55'! 229151buildPluggableInputField: aSpec 229152 | widget | 229153 widget := self buildPluggableText: aSpec. 229154 widget acceptOnCR: true. 229155 widget hideScrollBarsIndefinitely. 229156 ^widget! ! 229157 229158!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/15/2005 12:07'! 229159buildPluggableList: aSpec 229160 | widget listClass getIndex setIndex | 229161 aSpec getSelected ifNil:[ 229162 listClass := PluggableListMorphPlus. 229163 getIndex := aSpec getIndex. 229164 setIndex := aSpec setIndex. 229165 ] ifNotNil:[ 229166 listClass := PluggableListMorphByItemPlus. 229167 getIndex := aSpec getSelected. 229168 setIndex := aSpec setSelected. 229169 ]. 229170 widget := listClass on: aSpec model 229171 list: aSpec list 229172 selected: getIndex 229173 changeSelected: setIndex 229174 menu: aSpec menu 229175 keystroke: aSpec keyPress. 229176 self register: widget id: aSpec name. 229177 widget dragItemSelector: aSpec dragItem. 229178 widget dropItemSelector: aSpec dropItem. 229179 widget wantsDropSelector: aSpec dropAccept. 229180 widget autoDeselect: aSpec autoDeselect. 229181 self setFrame: aSpec frame in: widget. 229182 parent ifNotNil:[self add: widget to: parent]. 229183 panes ifNotNil:[ 229184 aSpec list ifNotNil:[panes add: aSpec list]. 229185 ]. 229186 ^widget! ! 229187 229188!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/14/2005 22:27'! 229189buildPluggableMultiSelectionList: aSpec 229190 | widget listClass | 229191 aSpec getSelected ifNotNil:[^self error:'There is no PluggableListMorphOfManyByItem']. 229192 listClass := PluggableListMorphOfMany. 229193 widget := listClass on: aSpec model 229194 list: aSpec list 229195 primarySelection: aSpec getIndex 229196 changePrimarySelection: aSpec setIndex 229197 listSelection: aSpec getSelectionList 229198 changeListSelection: aSpec setSelectionList 229199 menu: aSpec menu. 229200 self register: widget id: aSpec name. 229201 widget keystrokeActionSelector: aSpec keyPress. 229202 self setFrame: aSpec frame in: widget. 229203 parent ifNotNil:[self add: widget to: parent]. 229204 panes ifNotNil:[ 229205 aSpec list ifNotNil:[panes add: aSpec list]. 229206 ]. 229207 ^widget! ! 229208 229209!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/14/2005 22:28'! 229210buildPluggablePanel: aSpec 229211 | widget children | 229212 widget := PluggablePanelMorph new. 229213 self register: widget id: aSpec name. 229214 widget model: aSpec model. 229215 widget color: Color transparent. 229216 widget clipSubmorphs: true. 229217 children := aSpec children. 229218 children isSymbol ifTrue:[ 229219 widget getChildrenSelector: children. 229220 widget update: children. 229221 children := #(). 229222 ]. 229223 self buildAll: children in: widget. 229224 self setFrame: aSpec frame in: widget. 229225 parent ifNotNil:[self add: widget to: parent]. 229226 self setLayout: aSpec layout in: widget. 229227 ^widget! ! 229228 229229!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/14/2005 22:28'! 229230buildPluggableText: aSpec 229231 | widget | 229232 widget := PluggableTextMorphPlus on: aSpec model 229233 text: aSpec getText 229234 accept: aSpec setText 229235 readSelection: aSpec selection 229236 menu: aSpec menu. 229237 self register: widget id: aSpec name. 229238 widget getColorSelector: aSpec color. 229239 self setFrame: aSpec frame in: widget. 229240 parent ifNotNil:[self add: widget to: parent]. 229241 panes ifNotNil:[ 229242 aSpec getText ifNotNil:[panes add: aSpec getText]. 229243 ]. 229244 ^widget! ! 229245 229246!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 7/15/2005 12:10'! 229247buildPluggableTree: aSpec 229248 | widget | 229249 widget := PluggableTreeMorph new. 229250 self register: widget id: aSpec name. 229251 widget model: aSpec model. 229252 widget getSelectedPathSelector: aSpec getSelectedPath. 229253 widget setSelectedSelector: aSpec setSelected. 229254 widget getChildrenSelector: aSpec getChildren. 229255 widget hasChildrenSelector: aSpec hasChildren. 229256 widget getLabelSelector: aSpec label. 229257 widget getIconSelector: aSpec icon. 229258 widget getHelpSelector: aSpec help. 229259 widget getMenuSelector: aSpec menu. 229260 widget keystrokeActionSelector: aSpec keyPress. 229261 widget getRootsSelector: aSpec roots. 229262 widget autoDeselect: aSpec autoDeselect. 229263 widget dropItemSelector: aSpec dropItem. 229264 widget wantsDropSelector: aSpec dropAccept. 229265 self setFrame: aSpec frame in: widget. 229266 parent ifNotNil:[self add: widget to: parent]. 229267 panes ifNotNil:[ 229268 aSpec roots ifNotNil:[panes add: aSpec roots]. 229269 ]. 229270 ^widget! ! 229271 229272!MorphicToolBuilder methodsFor: 'pluggable widgets' stamp: 'ar 9/17/2005 21:07'! 229273buildPluggableWindow: aSpec 229274 | widget children label | 229275 aSpec layout == #proportional ifFalse:[ 229276 "This needs to be implemented - probably by adding a single pane and then the rest" 229277 ^self error: 'Not implemented'. 229278 ]. 229279 widget := PluggableSystemWindow new. 229280 self register: widget id: aSpec name. 229281 widget model: aSpec model. 229282 (label := aSpec label) ifNotNil:[ 229283 label isSymbol 229284 ifTrue:[widget getLabelSelector: label] 229285 ifFalse:[widget setLabel: label]]. 229286 children := aSpec children. 229287 children isSymbol ifTrue:[ 229288 widget getChildrenSelector: children. 229289 widget update: children. 229290 children := #(). 229291 ]. 229292 widget closeWindowSelector: aSpec closeAction. 229293 panes := OrderedCollection new. 229294 self buildAll: children in: widget. 229295 aSpec extent ifNotNil:[widget extent: aSpec extent]. 229296 widget setUpdatablePanesFrom: panes. 229297 ^widget! ! 229298 229299 229300!MorphicToolBuilder methodsFor: 'private' stamp: 'ar 7/17/2005 00:00'! 229301add: aMorph to: aParent 229302 aParent addMorphBack: aMorph. 229303 aParent isSystemWindow ifTrue:[ 229304 aParent addPaneMorph: aMorph. 229305 ].! ! 229306 229307!MorphicToolBuilder methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:35'! 229308asFrame: aRectangle 229309 | frame | 229310 aRectangle ifNil:[^nil]. 229311 frame := LayoutFrame new. 229312 frame 229313 leftFraction: aRectangle left; 229314 rightFraction: aRectangle right; 229315 topFraction: aRectangle top; 229316 bottomFraction: aRectangle bottom. 229317 ^frame! ! 229318 229319!MorphicToolBuilder methodsFor: 'private' stamp: 'ar 7/14/2005 22:28'! 229320register: widget id: id 229321 id ifNil:[^self]. 229322 widgets ifNil:[widgets := Dictionary new]. 229323 widgets at: id put: widget.! ! 229324 229325!MorphicToolBuilder methodsFor: 'private' stamp: 'ar 2/10/2005 22:28'! 229326setLayout: layout in: widget 229327 layout == #proportional ifTrue:[ 229328 widget layoutPolicy: ProportionalLayout new. 229329 ^self]. 229330 layout == #horizontal ifTrue:[ 229331 widget layoutPolicy: TableLayout new. 229332 widget listDirection: #leftToRight. 229333 widget submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. 229334 "and then some..." 229335 ^self]. 229336 layout == #vertical ifTrue:[ 229337 widget layoutPolicy: TableLayout new. 229338 widget listDirection: #topToBottom. 229339 widget submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. 229340 "and then some..." 229341 ^self]. 229342 ^self error: 'Unknown layout: ', layout.! ! 229343 229344!MorphicToolBuilder methodsFor: 'private' stamp: 'ar 7/14/2005 22:30'! 229345widgetAt: id ifAbsent: aBlock 229346 widgets ifNil:[^aBlock value]. 229347 ^widgets at: id ifAbsent: aBlock! ! 229348 229349"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 229350 229351MorphicToolBuilder class 229352 instanceVariableNames: ''! 229353 229354!MorphicToolBuilder class methodsFor: 'accessing' stamp: 'alain.plantec 5/30/2008 13:55'! 229355isActiveBuilder 229356 "Answer whether I am the currently active builder" 229357 ^ true! ! 229358ToolBuilderTests subclass: #MorphicToolBuilderTests 229359 instanceVariableNames: '' 229360 classVariableNames: '' 229361 poolDictionaries: '' 229362 category: 'Tests-Morphic'! 229363!MorphicToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0! 229364Tests for the Morphic tool builder.! 229365 229366 229367!MorphicToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 19:26'! 229368acceptWidgetText 229369 widget hasUnacceptedEdits: true. 229370 widget accept.! ! 229371 229372!MorphicToolBuilderTests methodsFor: 'support' stamp: 'ar 6/21/2005 10:35'! 229373buttonWidgetEnabled 229374 "Answer whether the current widget (a button) is currently enabled" 229375 ^widget enabled! ! 229376 229377!MorphicToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 19:22'! 229378changeListWidget 229379 widget changeModelSelection: widget getCurrentSelectionIndex + 1.! ! 229380 229381!MorphicToolBuilderTests methodsFor: 'support' stamp: 'AdrianLienhard 10/11/2009 14:54'! 229382expectedFailures 229383 "Polymorph override of PluggableButtonMorphPlus>>update: makes color not being updated anymore in respond to sending #changed:. Was this an intentional change and this test is obsolete?" 229384 ^ #(testGetButtonColor)! ! 229385 229386!MorphicToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 19:15'! 229387fireButtonWidget 229388 widget performAction.! ! 229389 229390!MorphicToolBuilderTests methodsFor: 'support' stamp: 'marcus.denker 11/10/2008 10:04'! 229391fireMenuItemWidget 229392 (widget itemWithWording: 'Menu Item') 229393 ifNotNil: [:item | item doButtonAction]! ! 229394 229395!MorphicToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 14:46'! 229396setUp 229397 super setUp. 229398 builder := MorphicToolBuilder new.! ! 229399 229400!MorphicToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 21:43'! 229401widgetColor 229402 "Answer color from widget" 229403 ^widget color! ! 229404 229405 229406!MorphicToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 2/13/2005 13:52'! 229407testWindowDynamicLabel 229408 self makeWindow. 229409 self assert: (widget label = 'TestLabel').! ! 229410 229411!MorphicToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 2/13/2005 13:52'! 229412testWindowStaticLabel 229413 | spec | 229414 spec := builder pluggableWindowSpec new. 229415 spec model: self. 229416 spec children: #(). 229417 spec label: 'TestLabel'. 229418 widget := builder build: spec. 229419 self assert: (widget label = 'TestLabel').! ! 229420DisplayTransform subclass: #MorphicTransform 229421 instanceVariableNames: 'offset angle scale' 229422 classVariableNames: '' 229423 poolDictionaries: '' 229424 category: 'Graphics-Transformations'! 229425!MorphicTransform commentStamp: '<historical>' prior: 0! 229426This class implements simple translation, scaling and rotation for points, as well as inverse transformations. These transformations are used in TransformMorphs (clipping scrollers) and TransformationMorphs (general flex-morph wrappers) to map, eg, global mouse coords into local coords, and to invert, eg, local damage rectangles into global damage rectangles.! 229427 229428 229429!MorphicTransform methodsFor: 'accessing'! 229430angle 229431 ^ angle! ! 229432 229433!MorphicTransform methodsFor: 'accessing' stamp: 'ar 11/9/1998 14:33'! 229434inverseTransformation 229435 "Return the inverse transformation of the receiver" 229436 ^MorphicTransform 229437 offset: (self transform: 0@0) - (self transform: offset) 229438 angle: angle negated 229439 scale: scale reciprocal! ! 229440 229441!MorphicTransform methodsFor: 'accessing'! 229442offset 229443 ^ offset 229444! ! 229445 229446!MorphicTransform methodsFor: 'accessing'! 229447scale 229448 ^ scale! ! 229449 229450!MorphicTransform methodsFor: 'accessing'! 229451withAngle: a 229452 "Return a copy of me with a different Angle" 229453 ^ self copy setAngle: a! ! 229454 229455!MorphicTransform methodsFor: 'accessing'! 229456withOffset: a 229457 "Return a copy of me with a different Offset" 229458 ^ self copy setOffset: a! ! 229459 229460!MorphicTransform methodsFor: 'accessing'! 229461withScale: a 229462 "Return a copy of me with a different Scale" 229463 ^ self copy setScale: a! ! 229464 229465 229466!MorphicTransform methodsFor: 'composing' stamp: 'nk 3/9/2001 13:55'! 229467composedWithLocal: aTransform 229468 aTransform isIdentity ifTrue:[^self]. 229469 self isIdentity ifTrue:[^aTransform]. 229470 aTransform isMorphicTransform ifFalse:[^super composedWithLocal: aTransform]. 229471 self isPureTranslation ifTrue:[ 229472 ^aTransform withOffset: aTransform offset + self offset]. 229473 aTransform isPureTranslation ifTrue:[ 229474 ^self withOffset: (self localPointToGlobal: aTransform offset negated) negated]. 229475 ^super composedWithLocal: aTransform.! ! 229476 229477 229478!MorphicTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:14'! 229479asMatrixTransform2x3 229480 ^((MatrixTransform2x3 withRotation: angle radiansToDegrees negated) composedWithLocal: 229481 (MatrixTransform2x3 withScale: scale)) 229482 offset: offset negated! ! 229483 229484!MorphicTransform methodsFor: 'converting' stamp: 'di 10/26/1999 17:03'! 229485asMorphicTransform 229486 229487 ^ self! ! 229488 229489 229490!MorphicTransform methodsFor: 'initialize' stamp: 'lr 7/4/2009 10:42'! 229491setIdentiy 229492 scale := 1.0. 229493 offset := 0 @ 0. 229494 angle := 0.0! ! 229495 229496 229497!MorphicTransform methodsFor: 'printing' stamp: 'ar 5/19/1999 18:21'! 229498printOn: aStream 229499 super printOn: aStream. 229500 aStream nextPut:$(; 229501 nextPutAll:'angle = '; print: angle; 229502 nextPutAll:'; scale = '; print: scale; 229503 nextPutAll:'; offset = '; print: offset; 229504 nextPut:$).! ! 229505 229506 229507!MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:57'! 229508isIdentity 229509 "Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself." 229510 229511 ^ self isPureTranslation and: [offset = (0@0)] 229512! ! 229513 229514!MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 19:51'! 229515isMorphicTransform 229516 ^true! ! 229517 229518!MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:57'! 229519isPureTranslation 229520 "Return true if the receiver specifies no rotation or scaling." 229521 229522 ^ angle = 0.0 and: [scale = 1.0] 229523! ! 229524 229525 229526!MorphicTransform methodsFor: 'transformations' stamp: 'di 3/4/98 19:10'! 229527composedWith: aTransform 229528 "Return a new transform that has the effect of transforming points first by the receiver and then by the argument." 229529 229530 self isIdentity ifTrue: [^ aTransform]. 229531 aTransform isIdentity ifTrue: [^ self]. 229532 ^ CompositeTransform new globalTransform: self 229533 localTransform: aTransform! ! 229534 229535!MorphicTransform methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! 229536invert: aPoint 229537 "Transform the given point from local to global coordinates." 229538 | p3 p2 | 229539 self isPureTranslation ifTrue: [ ^ aPoint - offset ]. 229540 p3 := aPoint * scale. 229541 p2 := (p3 x * angle cos + (p3 y * angle sin)) @ (p3 y * angle cos - (p3 x * angle sin)). 229542 ^ p2 - offset! ! 229543 229544!MorphicTransform methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! 229545invertBoundsRect: aRectangle 229546 "Return a rectangle whose coordinates have been transformed 229547 from local back to global coordinates. NOTE: if the transformation 229548 is not just a translation, then it will compute the bounding box 229549 in global coordinates." 229550 | outerRect | 229551 self isPureTranslation 229552 ifTrue: 229553 [ ^ (self invert: aRectangle topLeft) corner: (self invert: aRectangle bottomRight) ] 229554 ifFalse: 229555 [ outerRect := Rectangle encompassing: (aRectangle innerCorners collect: [ :p | self invert: p ]). 229556 "Following asymmetry due to likely subsequent truncation" 229557 ^ outerRect topLeft - (1 @ 1) corner: outerRect bottomRight + (2 @ 2) ]! ! 229558 229559!MorphicTransform methodsFor: 'transformations' stamp: 'di 10/2/1998 08:54'! 229560invertRect: aRectangle 229561 229562 self error: 'method name changed to emphasize enclosing bounds'. 229563 ^ self invertBoundsRect: aRectangle! ! 229564 229565!MorphicTransform methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! 229566transform: aPoint 229567 "Transform the given point from global to local coordinates." 229568 | p2 p3 | 229569 self isPureTranslation ifTrue: [ ^ aPoint + offset ]. 229570 p2 := aPoint + offset. 229571 p3 := (p2 x * angle cos - (p2 y * angle sin)) @ (p2 y * angle cos + (p2 x * angle sin)) / scale. 229572 ^ p3! ! 229573 229574!MorphicTransform methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! 229575transformBoundsRect: aRectangle 229576 "Return a rectangle whose coordinates have been transformed 229577 from global to local coordinates. NOTE: if the transformation 229578 is not just a translation, then it will compute the bounding box 229579 in global coordinates." 229580 | outerRect | 229581 self isPureTranslation 229582 ifTrue: 229583 [ ^ (self transform: aRectangle topLeft) corner: (self transform: aRectangle bottomRight) ] 229584 ifFalse: 229585 [ outerRect := Rectangle encompassing: (aRectangle innerCorners collect: [ :p | self transform: p ]). 229586 "Following asymmetry due to likely subsequent truncation" 229587 ^ outerRect topLeft - (1 @ 1) corner: outerRect bottomRight + (2 @ 2) ]! ! 229588 229589 229590!MorphicTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:13'! 229591globalPointToLocal: aPoint 229592 "Transform aPoint from global coordinates into local coordinates" 229593 ^self transform: aPoint! ! 229594 229595!MorphicTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:32'! 229596localPointToGlobal: aPoint 229597 "Transform aPoint from global coordinates into local coordinates" 229598 ^self invert: aPoint! ! 229599 229600 229601!MorphicTransform methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 229602setAngle: aFloat 229603 angle := aFloat! ! 229604 229605!MorphicTransform methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 229606setOffset: aPoint 229607 offset := aPoint! ! 229608 229609!MorphicTransform methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 229610setOffset: aPoint angle: a scale: s 229611 offset := aPoint. 229612 angle := a. 229613 scale := s! ! 229614 229615!MorphicTransform methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 229616setScale: aFloat 229617 scale := aFloat! ! 229618 229619"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 229620 229621MorphicTransform class 229622 instanceVariableNames: ''! 229623 229624!MorphicTransform class methodsFor: 'instance creation'! 229625identity 229626 229627 ^ self offset: 0@0 angle: 0.0 scale: 1.0! ! 229628 229629!MorphicTransform class methodsFor: 'instance creation'! 229630new 229631 229632 ^ self offset: 0@0 229633! ! 229634 229635!MorphicTransform class methodsFor: 'instance creation'! 229636offset: aPoint 229637 229638 ^ self offset: aPoint angle: 0.0 scale: 1.0! ! 229639 229640!MorphicTransform class methodsFor: 'instance creation'! 229641offset: aPoint angle: a scale: s 229642 229643 ^ self basicNew setOffset: aPoint angle: a scale: s! ! 229644TestCase subclass: #MorphicUIBugTest 229645 instanceVariableNames: 'cases' 229646 classVariableNames: '' 229647 poolDictionaries: '' 229648 category: 'Tests-Bugs'! 229649!MorphicUIBugTest commentStamp: 'wiz 1/3/2007 13:57' prior: 0! 229650A MorphicUIBugTest is a class for testing the shortcomings and repairs of the MorphicUI manager. 229651. 229652 229653Instance Variables 229654 cases: <aCollection> 229655 229656cases 229657 - a list of morphs that may need to be deleted during teardown. 229658 the tests are expected to fill this list it starts out empty by default. 229659 229660 229661! 229662 229663 229664!MorphicUIBugTest methodsFor: 'as yet unclassified' stamp: 'wiz 1/3/2007 12:16'! 229665findWindowInWorldLabeled: aLabel 229666^ World submorphs detect: [ :each | 229667 each class == SystemWindow 229668 and: [ each label = aLabel ] ] ifNone: [ nil ] .! ! 229669 229670!MorphicUIBugTest methodsFor: 'as yet unclassified' stamp: 'wiz 6/11/2007 20:34'! 229671setUp 229672"default. tests will add morphs to list. Teardown will delete." 229673 229674cases := #() .! ! 229675 229676!MorphicUIBugTest methodsFor: 'as yet unclassified' stamp: 'wiz 1/3/2007 11:25'! 229677tearDown 229678"default. tests will add morphs to list. Teardown will delete." 229679 229680cases do: [ :each | each delete ] .! ! 229681 229682!MorphicUIBugTest methodsFor: 'as yet unclassified' stamp: 'norbert_hartl 6/13/2009 11:55'! 229683testOpenWorkspace 229684"self new testOpenWorkspace" 229685"MorphicUIBugTest run: #testOpenWorkspace" 229686 229687| window myLabel foundWindow myModel | 229688 229689myLabel := 'Workspace from ', 'SUnit test' . 229690foundWindow := self findWindowInWorldLabeled: myLabel . 229691self assert: ( foundWindow isNil ) . 229692 229693window := 229694UIManager default edit: '"MorphicUIBugTest run: #openWorkspaceTest"' label: myLabel . 229695 229696window = window. 229697 229698foundWindow := self findWindowInWorldLabeled: myLabel . 229699 229700cases := Array with: foundWindow . "For teardown." 229701 229702myModel := (foundWindow submorphs detect: [ :each | 229703 each isMorphicModel ] ) . 229704 229705self assert: ( myModel model class == Workspace ) . 229706self assert: ( foundWindow model class == Workspace ) . 229707 229708foundWindow delete .! ! 229709UIManager subclass: #MorphicUIManager 229710 instanceVariableNames: 'interactiveParser' 229711 classVariableNames: '' 229712 poolDictionaries: '' 229713 category: 'ToolBuilder-Morphic'! 229714!MorphicUIManager commentStamp: 'ar 2/11/2005 21:52' prior: 0! 229715The Morphic ui manager.! 229716 229717 229718!MorphicUIManager methodsFor: 'accessing' stamp: 'pavel.krivanek 11/21/2008 17:30'! 229719interactiveParser 229720 "Answer the value of interactiveParser" 229721 229722 ^ interactiveParser! ! 229723 229724!MorphicUIManager methodsFor: 'accessing' stamp: 'pavel.krivanek 11/21/2008 17:30'! 229725interactiveParser: anObject 229726 "Set the value of interactiveParser" 229727 229728 interactiveParser := anObject! ! 229729 229730 229731!MorphicUIManager methodsFor: 'bitBlt' stamp: 'Pavel.Krivanek 10/28/2008 11:02'! 229732grafPort 229733 229734 ^ Display defaultBitBltClass asGrafPort! ! 229735 229736 229737!MorphicUIManager methodsFor: 'events' stamp: 'Pavel.Krivanek 10/28/2008 11:24'! 229738onDebug: process context: context title: title full: bool 229739 229740 | topCtxt | 229741 229742 topCtxt := process isActiveProcess ifTrue: [thisContext] ifFalse: [process suspendedContext]. 229743 (topCtxt hasContext: context) ifFalse: [^ self error: 'context not in process']. 229744 ToolSet debug: process context: context label: title contents: nil fullView: bool.! ! 229745 229746!MorphicUIManager methodsFor: 'events' stamp: 'Pavel.Krivanek 10/28/2008 11:22'! 229747onEventSensorStartup: anEventSensor 229748 229749 anEventSensor flushAllButDandDEvents! ! 229750 229751!MorphicUIManager methodsFor: 'events' stamp: 'Pavel.Krivanek 10/28/2008 11:16'! 229752onPrimitiveError: aString 229753 | context | 229754 229755 (String 229756 streamContents: 229757 [:s | 229758 s nextPutAll: '***System error handling failed***'. 229759 s cr; nextPutAll: aString. 229760 context := thisContext sender sender. 229761 20 timesRepeat: [context == nil ifFalse: [s cr; print: (context := context sender)]]. 229762 s cr; nextPutAll: '-------------------------------'. 229763 s cr; nextPutAll: 'Type CR to enter an emergency evaluator.'. 229764 s cr; nextPutAll: 'Type any other character to restart.']) 229765 displayAt: 0 @ 0. 229766 [Sensor keyboardPressed] whileFalse. 229767 Sensor keyboard = Character cr ifTrue: [Transcripter emergencyEvaluator]. 229768 229769 World install "init hands and redisplay"! ! 229770 229771!MorphicUIManager methodsFor: 'events' stamp: 'Pavel.Krivanek 10/28/2008 11:11'! 229772onSnapshot 229773 229774 SystemWindow wakeUpTopWindowUponStartup! ! 229775 229776 229777!MorphicUIManager methodsFor: 'paragraph' stamp: 'Pavel.Krivanek 10/28/2008 11:09'! 229778composeFormFor: aDisplayText 229779 229780 | canvas tmpText | 229781 229782 tmpText := TextMorph new contentsAsIs: aDisplayText text deepCopy. 229783 aDisplayText foregroundColor ifNotNil: [tmpText text addAttribute: (TextColor color: aDisplayText foregroundColor)]. 229784 aDisplayText backgroundColor ifNotNil: [tmpText backgroundColor: aDisplayText backgroundColor]. 229785 tmpText setTextStyle: aDisplayText textStyle. 229786 canvas := FormCanvas on: (Form extent: tmpText extent depth: 32). 229787 tmpText drawOn: canvas. 229788 aDisplayText form: canvas form. 229789 229790 ^ canvas form ! ! 229791 229792 229793!MorphicUIManager methodsFor: 'settings' stamp: 'pavel.krivanek 11/21/2008 17:29'! 229794interactiveParserFor: requestor 229795 229796 " during Morphic loading the interactive parser must be disabled " 229797 229798 (interactiveParser = false) ifTrue: [ ^ false ]. "can be nil" 229799 229800 ^ (requestor == nil or: [requestor isKindOf: SyntaxError]) not! ! 229801 229802 229803!MorphicUIManager methodsFor: 'ui requests' stamp: 'hfm 11/29/2008 20:06'! 229804chooseDirectory: label from: dir 229805 "Let the user choose a directory" 229806 ^FileList modalFolderSelector: dir! ! 229807 229808!MorphicUIManager methodsFor: 'ui requests' stamp: 'hfm 11/29/2008 20:06'! 229809chooseFileMatching: patterns label: aString 229810 "Let the user choose a file matching the given patterns" 229811 | result | 229812 result := FileList modalFileSelectorForSuffixes: patterns. 229813 ^result ifNotNil:[result fullName]! ! 229814 229815!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 10:47'! 229816chooseFrom: aList lines: linesArray title: aString 229817 "Choose an item from the given list. Answer the index of the selected item." 229818 | menu | 229819 menu := PopUpMenu labelArray: aList lines: linesArray. 229820 ^aString isEmpty ifTrue:[menu startUp] ifFalse:[menu startUpWithCaption: aString]! ! 229821 229822!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 7/15/2005 23:44'! 229823chooseFrom: labelList values: valueList lines: linesArray title: aString 229824 "Choose an item from the given list. Answer the selected item." 229825 | menu | 229826 menu := SelectionMenu labels: labelList lines: linesArray selections: valueList. 229827 ^aString isEmpty ifTrue:[menu startUp] ifFalse:[menu startUpWithCaption: aString]! ! 229828 229829!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:45'! 229830confirm: queryString 229831 "Put up a yes/no menu with caption queryString. Answer true if the 229832 response is yes, false if no. This is a modal question--the user must 229833 respond yes or no." 229834 ^PopUpMenu confirm: queryString! ! 229835 229836!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 09:49'! 229837confirm: aString orCancel: cancelBlock 229838 "Put up a yes/no/cancel menu with caption aString. Answer true if 229839 the response is yes, false if no. If cancel is chosen, evaluate 229840 cancelBlock. This is a modal question--the user must respond yes or no." 229841 ^PopUpMenu confirm: aString orCancel: cancelBlock! ! 229842 229843!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 17:13'! 229844displayProgress: titleString at: aPoint from: minVal to: maxVal during: workBlock 229845 "Display titleString as a caption over a progress bar while workBlock is evaluated." 229846 ^ProgressInitiationException 229847 display: titleString 229848 at: aPoint 229849 from: minVal 229850 to: maxVal 229851 during: workBlock! ! 229852 229853!MorphicUIManager methodsFor: 'ui requests' stamp: 'wiz 1/3/2007 14:21'! 229854edit: aText label: labelString accept: anAction 229855 "Open an editor on the given string/text" 229856 229857 ^Workspace new 229858 acceptContents: aText; 229859 acceptAction: anAction; 229860 openLabel: labelString 229861! ! 229862 229863!MorphicUIManager methodsFor: 'ui requests' stamp: 'Pavel.Krivanek 10/28/2008 10:46'! 229864fontFromUser: priorFont 229865 229866 ^ StrikeFont fromUser: priorFont allowKeyboard: true! ! 229867 229868!MorphicUIManager methodsFor: 'ui requests' stamp: 'alain.plantec 2/9/2009 13:50'! 229869informUserDuring: aBlock 229870 "Display a message above (or below if insufficient room) the cursor 229871 during execution of the given block. 229872 UIManager default informUserDuring:[:bar| 229873 #('one' 'two' 'three') do:[:info| 229874 bar value: info. 229875 (Delay forSeconds: 1) wait]]" 229876 ((SelectionMenu labels: '') menuMorphWithTitle: ' ') 229877 informUserAt: Sensor cursorPoint during: aBlock.! ! 229878 229879!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:46'! 229880inform: aString 229881 "Display a message for the user to read and then dismiss" 229882 ^PopUpMenu inform: aString! ! 229883 229884!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 17:05'! 229885multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight 229886 "Create a multi-line instance of me whose question is queryString with 229887 the given initial answer. Invoke it centered at the given point, and 229888 answer the string the user accepts. Answer nil if the user cancels. An 229889 empty string returned means that the ussr cleared the editing area and 229890 then hit 'accept'. Because multiple lines are invited, we ask that the user 229891 use the ENTER key, or (in morphic anyway) hit the 'accept' button, to 229892 submit; that way, the return key can be typed to move to the next line." 229893 ^FillInTheBlank multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight! ! 229894 229895!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:47'! 229896requestPassword: queryString 229897 "Create an instance of me whose question is queryString. Invoke it centered 229898 at the cursor, and answer the string the user accepts. Answer the empty 229899 string if the user cancels." 229900 ^FillInTheBlank requestPassword: queryString! ! 229901 229902!MorphicUIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:46'! 229903request: queryString initialAnswer: defaultAnswer 229904 "Create an instance of me whose question is queryString with the given 229905 initial answer. Invoke it centered at the given point, and answer the 229906 string the user accepts. Answer the empty string if the user cancels." 229907 ^FillInTheBlank request: queryString initialAnswer: defaultAnswer ! ! 229908 229909"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 229910 229911MorphicUIManager class 229912 instanceVariableNames: ''! 229913 229914!MorphicUIManager class methodsFor: 'accessing' stamp: 'alain.plantec 5/30/2008 13:55'! 229915isActiveManager 229916 "Answer whether I should act as the active ui manager" 229917 ^ true! ! 229918MorphicEvent subclass: #MorphicUnknownEvent 229919 instanceVariableNames: 'type argument' 229920 classVariableNames: '' 229921 poolDictionaries: 'EventSensorConstants' 229922 category: 'Morphic-Events'! 229923 229924!MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 20:04'! 229925argument 229926 ^argument! ! 229927 229928!MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 20:04'! 229929argument: arg 229930 argument := arg! ! 229931 229932!MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 19:55'! 229933position 229934 ^0@0! ! 229935 229936!MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 19:55'! 229937type 229938 ^type! ! 229939 229940 229941!MorphicUnknownEvent methodsFor: 'initialize' stamp: 'ar 10/26/2000 01:20'! 229942type: eventType readFrom: aStream 229943 | typeAndArg | 229944 timeStamp := Integer readFrom: aStream. 229945 aStream skip: 1. 229946 typeAndArg := Object readFrom: aStream. 229947 type := typeAndArg first. 229948 argument := typeAndArg last.! ! 229949 229950 229951!MorphicUnknownEvent methodsFor: 'printing' stamp: 'ar 10/26/2000 01:19'! 229952storeOn: aStream 229953 aStream nextPutAll: 'unknown'. 229954 aStream space. 229955 self timeStamp storeOn: aStream. 229956 aStream space. 229957 {type. argument} storeOn: aStream.! ! 229958 229959 229960!MorphicUnknownEvent methodsFor: 'private' stamp: 'ar 10/25/2000 19:59'! 229961setType: evtType argument: arg 229962 type := evtType. 229963 argument := arg.! ! 229964 229965!MorphicUnknownEvent methodsFor: 'private' stamp: 'ar 10/25/2000 19:58'! 229966setType: evtType argument: arg hand: evtHand stamp: stamp 229967 type := evtType. 229968 argument := arg. 229969 source := evtHand. 229970 timeStamp := stamp.! ! 229971MouseEvent subclass: #MouseButtonEvent 229972 instanceVariableNames: 'whichButton' 229973 classVariableNames: '' 229974 poolDictionaries: '' 229975 category: 'Morphic-Events'! 229976 229977!MouseButtonEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 19:58'! 229978blueButtonChanged 229979 "Answer true if the blue mouse button has changed. This is the third mouse button or cmd+click on the Mac." 229980 229981 ^ whichButton anyMask: 1! ! 229982 229983!MouseButtonEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 19:58'! 229984redButtonChanged 229985 "Answer true if the red mouse button has changed. This is the first mouse button." 229986 229987 ^ whichButton anyMask: 4! ! 229988 229989!MouseButtonEvent methodsFor: 'accessing' stamp: 'nk 3/11/2004 17:44'! 229990whichButton 229991 ^whichButton! ! 229992 229993!MouseButtonEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 19:59'! 229994yellowButtonChanged 229995 "Answer true if the yellow mouse button has changed. This is the second mouse button or option+click on the Mac." 229996 229997 ^ whichButton anyMask: 2! ! 229998 229999 230000!MouseButtonEvent methodsFor: 'dispatching' stamp: 'ar 9/16/2000 13:05'! 230001sentTo: anObject 230002 "Dispatch the receiver into anObject" 230003 type == #mouseDown ifTrue:[^anObject handleMouseDown: self]. 230004 type == #mouseUp ifTrue:[^anObject handleMouseUp: self]. 230005 ^super sentTo: anObject! ! 230006 230007 230008!MouseButtonEvent methodsFor: 'initialize' stamp: 'ar 10/24/2000 16:29'! 230009type: eventType readFrom: aStream 230010 super type: eventType readFrom: aStream. 230011 aStream skip: 1. 230012 whichButton := Integer readFrom: aStream.! ! 230013 230014 230015!MouseButtonEvent methodsFor: 'printing' stamp: 'ar 10/24/2000 16:29'! 230016storeOn: aStream 230017 super storeOn: aStream. 230018 aStream space. 230019 whichButton storeOn: aStream.! ! 230020 230021 230022!MouseButtonEvent methodsFor: 'private' stamp: 'ar 10/5/2000 23:55'! 230023setType: evtType position: evtPos which: button buttons: evtButtons hand: evtHand stamp: stamp 230024 type := evtType. 230025 position := evtPos. 230026 buttons := evtButtons. 230027 source := evtHand. 230028 wasHandled := false. 230029 whichButton := button. 230030 timeStamp := stamp.! ! 230031Object subclass: #MouseClickState 230032 instanceVariableNames: 'clickClient clickState firstClickDown firstClickUp firstClickTime clickSelector dblClickSelector dblClickTime dblClickTimeoutSelector dragSelector dragThreshold' 230033 classVariableNames: '' 230034 poolDictionaries: '' 230035 category: 'Morphic-Kernel'! 230036!MouseClickState commentStamp: '<historical>' prior: 0! 230037MouseClickState is a simple class managing the distinction between clicks, double clicks, and drag operations. It has been factored out of HandMorph due to the many instVars. 230038 230039Instance variables: 230040 clickClient <Morph> The client wishing to receive #click:, #dblClick:, or #drag messages 230041 clickState <Symbol> The internal state of handling the last event (#firstClickDown, #firstClickUp, #firstClickTimedOut) 230042 firstClickDown <MorphicEvent> The #mouseDown event after which the client wished to receive #click: or similar messages 230043 firstClickUp <MorphicEvent> The first mouse up event which came in before the double click time out was exceeded (it is sent if there is a timout after the first mouse up event occured) 230044 firstClickTime <Integer> The millisecond clock value of the first event 230045 clickSelector <Symbol> The selector to use for sending #click: messages 230046 dblClickSelector <Symbol> The selector to use for sending #doubleClick: messages 230047 dblClickTime <Integer> Timout in milliseconds for a double click operation 230048 dragSelector <Symbol> The selector to use for sending #drag: messages 230049 dragThreshold <Integer> Threshold used for determining if a #drag: message is sent (pixels!!) 230050! 230051 230052 230053!MouseClickState methodsFor: 'as yet unclassified' stamp: 'nk 7/26/2004 09:13'! 230054printOn: aStream 230055 super printOn: aStream. 230056 aStream nextPut: $[; print: clickState; nextPut: $] 230057! ! 230058 230059 230060!MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 11:23'! 230061click 230062 230063 clickSelector ifNotNil: [clickClient perform: clickSelector with: firstClickDown]! ! 230064 230065!MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 11:24'! 230066doubleClick 230067 230068 dblClickSelector ifNotNil: [clickClient perform: dblClickSelector with: firstClickDown]! ! 230069 230070!MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 13:09'! 230071doubleClickTimeout 230072 230073 dblClickTimeoutSelector ifNotNil: [ 230074 clickClient perform: dblClickTimeoutSelector with: firstClickDown]! ! 230075 230076!MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 11:27'! 230077drag: event 230078 230079 dragSelector ifNotNil: [clickClient perform: dragSelector with: event]! ! 230080 230081!MouseClickState methodsFor: 'event handling' stamp: 'nk 7/26/2004 10:21'! 230082handleEvent: evt from: aHand 230083 "Process the given mouse event to detect a click, double-click, or drag. 230084 Return true if the event should be processed by the sender, false if it shouldn't. 230085 NOTE: This method heavily relies on getting *all* mouse button events." 230086 | localEvt timedOut isDrag | 230087 timedOut := (evt timeStamp - firstClickTime) > dblClickTime. 230088 localEvt := evt transformedBy: (clickClient transformedFrom: aHand owner). 230089 isDrag := (localEvt position - firstClickDown position) r > dragThreshold. 230090 clickState == #firstClickDown ifTrue: [ 230091 "Careful here - if we had a slow cycle we may have a timedOut mouseUp event" 230092 (timedOut and:[localEvt isMouseUp not]) ifTrue:[ 230093 "timeout before #mouseUp -> keep waiting for drag if requested" 230094 clickState := #firstClickTimedOut. 230095 dragSelector ifNil:[ 230096 aHand resetClickState. 230097 self doubleClickTimeout; click "***"]. 230098 ^true]. 230099 localEvt isMouseUp ifTrue:[ 230100 230101 (timedOut or:[dblClickSelector isNil]) ifTrue:[ 230102 self click. 230103 aHand resetClickState. 230104 ^true]. 230105 "Otherwise transfer to #firstClickUp" 230106 firstClickUp := evt copy. 230107 clickState := #firstClickUp. 230108 "If timedOut or the client's not interested in dbl clicks get outta here" 230109 self click. 230110 aHand handleEvent: firstClickUp. 230111 ^false]. 230112 isDrag ifTrue:["drag start" 230113 self doubleClickTimeout. "***" 230114 aHand resetClickState. 230115 dragSelector "If no drag selector send #click instead" 230116 ifNil: [self click] 230117 ifNotNil: [self drag: firstClickDown]. 230118 ^true]. 230119 ^false]. 230120 230121 clickState == #firstClickTimedOut ifTrue:[ 230122 localEvt isMouseUp ifTrue:["neither drag nor double click" 230123 aHand resetClickState. 230124 self doubleClickTimeout; click. "***" 230125 ^true]. 230126 isDrag ifTrue:["drag start" 230127 aHand resetClickState. 230128 self doubleClickTimeout; drag: firstClickDown. "***" 230129 ^true]. 230130 ^false]. 230131 230132 clickState = #firstClickUp ifTrue:[ 230133 (timedOut) ifTrue:[ 230134 "timed out after mouseUp - signal timeout and pass the event" 230135 aHand resetClickState. 230136 self doubleClickTimeout. "***" 230137 ^true]. 230138 localEvt isMouseDown ifTrue:["double click" 230139 clickState := #secondClickDown. 230140 ^false]]. 230141 230142 clickState == #secondClickDown ifTrue: [ 230143 timedOut ifTrue:[ 230144 "timed out after second mouseDown - pass event after signaling timeout" 230145 aHand resetClickState. 230146 self doubleClickTimeout. "***" 230147 ^true]. 230148 isDrag ifTrue: ["drag start" 230149 self doubleClickTimeout. "***" 230150 aHand resetClickState. 230151 dragSelector "If no drag selector send #click instead" 230152 ifNil: [self click] 230153 ifNotNil: [self drag: firstClickDown]. 230154 ^true]. 230155 localEvt isMouseUp ifTrue: ["double click" 230156 aHand resetClickState. 230157 self doubleClick. 230158 ^false] 230159 ]. 230160 230161 ^true 230162! ! 230163 230164 230165!MouseClickState methodsFor: 'initialize' stamp: 'jcg 9/21/2001 13:08'! 230166client: aMorph click: aClickSelector dblClick: aDblClickSelector dblClickTime: timeOut dblClickTimeout: aDblClickTimeoutSelector drag: aDragSelector threshold: aNumber event: firstClickEvent 230167 clickClient := aMorph. 230168 clickSelector := aClickSelector. 230169 dblClickSelector := aDblClickSelector. 230170 dblClickTime := timeOut. 230171 dblClickTimeoutSelector := aDblClickTimeoutSelector. 230172 dragSelector := aDragSelector. 230173 dragThreshold := aNumber. 230174 firstClickDown := firstClickEvent. 230175 firstClickTime := firstClickEvent timeStamp. 230176 clickState := #firstClickDown.! ! 230177UserInputEvent subclass: #MouseEvent 230178 instanceVariableNames: '' 230179 classVariableNames: '' 230180 poolDictionaries: '' 230181 category: 'Morphic-Events'! 230182 230183!MouseEvent methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/28/2008 13:14'! 230184isMouseWheel 230185 "Answer whether the receiver is a mouse wheel event." 230186 230187 ^false! ! 230188 230189 230190!MouseEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 22:51'! 230191cursorPoint 230192 "Answer the location of the cursor's hotspot when this event occured." 230193 230194 ^ position! ! 230195 230196 230197!MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'! 230198anyButtonPressed 230199 "Answer true if any mouse button is being pressed." 230200 230201 ^ buttons anyMask: self class anyButton! ! 230202 230203!MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'! 230204blueButtonPressed 230205 "Answer true if the blue mouse button is being pressed. This is the third mouse button or cmd+click on the Mac." 230206 230207 ^ buttons anyMask: self class blueButton! ! 230208 230209!MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'! 230210redButtonPressed 230211 "Answer true if the red mouse button is being pressed. This is the first mouse button." 230212 230213 ^ buttons anyMask: self class redButton! ! 230214 230215!MouseEvent methodsFor: 'button state' stamp: 'ar 9/15/2000 22:51'! 230216targetPoint 230217 "Answer the location of the cursor's hotspot, adjusted by the offset 230218 of the last mouseDown relative to the recipient morph." 230219 230220 ^ position - source targetOffset! ! 230221 230222!MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'! 230223yellowButtonPressed 230224 "Answer true if the yellow mouse button is being pressed. This is the second mouse button or option+click on the Mac." 230225 230226 ^ buttons anyMask: self class yellowButton! ! 230227 230228 230229!MouseEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:50'! 230230= aMorphicEvent 230231 super = aMorphicEvent ifFalse:[^false]. 230232 position = aMorphicEvent position ifFalse: [^ false]. 230233 buttons = aMorphicEvent buttons ifFalse: [^ false]. 230234 ^ true 230235! ! 230236 230237!MouseEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:47'! 230238hash 230239 ^ position hash + buttons hash! ! 230240 230241 230242!MouseEvent methodsFor: 'converting' stamp: 'ar 10/10/2000 21:17'! 230243asMouseEnter 230244 ^self clone setType: #mouseEnter! ! 230245 230246!MouseEvent methodsFor: 'converting' stamp: 'ar 10/10/2000 21:17'! 230247asMouseLeave 230248 ^self clone setType: #mouseLeave! ! 230249 230250!MouseEvent methodsFor: 'converting' stamp: 'marcus.denker 8/24/2008 21:41'! 230251asMouseMove 230252 "Convert the receiver into a mouse move" 230253 ^MouseMoveEvent basicNew setType: #mouseMove startPoint: position endPoint: position trail: {position. position} buttons: buttons hand: source stamp: Time millisecondClockValue.! ! 230254 230255!MouseEvent methodsFor: 'converting' stamp: 'marcus.denker 8/24/2008 21:42'! 230256asMouseOver 230257 "Convert the receiver into a mouse over event" 230258 ^MouseEvent basicNew setType: #mouseOver position: position buttons: buttons hand: source! ! 230259 230260 230261!MouseEvent methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:15'! 230262sentTo: anObject 230263 "Dispatch the receiver into anObject" 230264 type == #mouseOver ifTrue:[^anObject handleMouseOver: self]. 230265 type == #mouseEnter ifTrue:[^anObject handleMouseEnter: self]. 230266 type == #mouseLeave ifTrue:[^anObject handleMouseLeave: self]. 230267 ^super sentTo: anObject.! ! 230268 230269 230270!MouseEvent methodsFor: 'initialize' stamp: 'ar 10/25/2000 22:08'! 230271type: eventType readFrom: aStream 230272 | x y | 230273 type := eventType. 230274 timeStamp := Integer readFrom: aStream. 230275 aStream skip: 1. 230276 x := Integer readFrom: aStream. 230277 aStream skip: 1. 230278 y := Integer readFrom: aStream. 230279 aStream skip: 1. 230280 buttons := Integer readFrom: aStream. 230281 position := x@y. 230282! ! 230283 230284 230285!MouseEvent methodsFor: 'printing' stamp: 'JMM 9/29/2004 13:25'! 230286printOn: aStream 230287 230288 aStream nextPut: $[. 230289 aStream nextPutAll: self cursorPoint printString; space. 230290 aStream nextPutAll: type; space. 230291 aStream nextPutAll: self modifierString. 230292 aStream nextPutAll: self buttonString. 230293 aStream nextPutAll: timeStamp printString; space. 230294 aStream nextPutAll: self windowIndex printString. 230295 aStream nextPut: $].! ! 230296 230297!MouseEvent methodsFor: 'printing' stamp: 'ar 10/25/2000 22:09'! 230298storeOn: aStream 230299 230300 aStream nextPutAll: type. 230301 aStream space. 230302 self timeStamp storeOn: aStream. 230303 aStream space. 230304 position x storeOn: aStream. 230305 aStream space. 230306 position y storeOn: aStream. 230307 aStream space. 230308 buttons storeOn: aStream.! ! 230309 230310 230311!MouseEvent methodsFor: 'testing' stamp: 'ar 10/5/2000 19:43'! 230312isDraggingEvent 230313 source ifNil:[^false]. 230314 source hasSubmorphs ifTrue:[^true]. 230315 self anyButtonPressed ifTrue:[^true]. 230316 ^false! ! 230317 230318!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:30'! 230319isMouse 230320 ^true! ! 230321 230322!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! 230323isMouseDown 230324 ^self type == #mouseDown! ! 230325 230326!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! 230327isMouseEnter 230328 ^self type == #mouseEnter! ! 230329 230330!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! 230331isMouseLeave 230332 ^self type == #mouseLeave! ! 230333 230334!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! 230335isMouseMove 230336 ^self type == #mouseMove! ! 230337 230338!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! 230339isMouseUp 230340 ^self type == #mouseUp! ! 230341 230342 230343!MouseEvent methodsFor: 'private' stamp: 'ar 10/10/2000 21:15'! 230344setType: aSymbol 230345 "For quick conversion between event types" 230346 type := aSymbol.! ! 230347 230348!MouseEvent methodsFor: 'private' stamp: 'ar 9/15/2000 22:53'! 230349setType: evtType position: evtPos buttons: evtButtons hand: evtHand 230350 type := evtType. 230351 position := evtPos. 230352 buttons := evtButtons. 230353 source := evtHand. 230354 wasHandled := false.! ! 230355 230356"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 230357 230358MouseEvent class 230359 instanceVariableNames: ''! 230360 230361!MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! 230362anyButton 230363 ^ 7! ! 230364 230365!MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! 230366blueButton 230367 ^ 1! ! 230368 230369!MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! 230370redButton 230371 ^ 4! ! 230372 230373!MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! 230374yellowButton 230375 ^ 2! ! 230376MouseEvent subclass: #MouseMoveEvent 230377 instanceVariableNames: 'startPoint trail' 230378 classVariableNames: '' 230379 poolDictionaries: '' 230380 category: 'Morphic-Events'! 230381 230382!MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 22:51'! 230383endPoint 230384 "Return the point where the movement ended." 230385 ^position! ! 230386 230387!MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 16:25'! 230388startPoint 230389 "Return the point where the movement started." 230390 ^startPoint! ! 230391 230392!MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 10/24/2000 16:33'! 230393trail 230394 "Return any immediate points that have been assembled along the move" 230395 ^trail ifNil:[#()]! ! 230396 230397 230398!MouseMoveEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:49'! 230399= aMorphicEvent 230400 super = aMorphicEvent ifFalse:[^false]. 230401 position = aMorphicEvent position ifFalse: [^ false]. 230402 startPoint = aMorphicEvent startPoint ifFalse: [^ false]. 230403 buttons = aMorphicEvent buttons ifFalse: [^ false]. 230404 ^ true 230405! ! 230406 230407!MouseMoveEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:49'! 230408hash 230409 ^ position hash + startPoint hash + buttons hash! ! 230410 230411 230412!MouseMoveEvent methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:15'! 230413sentTo: anObject 230414 "Dispatch the receiver into anObject" 230415 type == #mouseMove ifTrue:[^anObject handleMouseMove: self]. 230416 ^super sentTo: anObject. 230417! ! 230418 230419 230420!MouseMoveEvent methodsFor: 'initialize' stamp: 'ar 10/24/2000 16:31'! 230421type: eventType readFrom: aStream 230422 | x y | 230423 super type: eventType readFrom: aStream. 230424 aStream skip: 1. 230425 x := Integer readFrom: aStream. 230426 aStream skip: 1. 230427 y := Integer readFrom: aStream. 230428 startPoint := x@y.! ! 230429 230430 230431!MouseMoveEvent methodsFor: 'printing' stamp: 'JMM 9/29/2004 13:25'! 230432printOn: aStream 230433 230434 aStream nextPut: $[. 230435 aStream nextPutAll: self startPoint printString; space. 230436 aStream nextPutAll: self endPoint printString; space. 230437 aStream nextPutAll: self type; space. 230438 aStream nextPutAll: self modifierString. 230439 aStream nextPutAll: self buttonString. 230440 aStream nextPutAll: timeStamp printString; space. 230441 aStream nextPutAll: self windowIndex printString. 230442 aStream nextPut: $].! ! 230443 230444!MouseMoveEvent methodsFor: 'printing' stamp: 'ar 10/24/2000 16:30'! 230445storeOn: aStream 230446 super storeOn: aStream. 230447 aStream space. 230448 self startPoint x storeOn: aStream. 230449 aStream space. 230450 self startPoint y storeOn: aStream. 230451 aStream space. 230452 "trail storeOn: aStream."! ! 230453 230454 230455!MouseMoveEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:29'! 230456isMove 230457 ^true! ! 230458 230459 230460!MouseMoveEvent methodsFor: 'transforming' stamp: 'ar 9/15/2000 22:52'! 230461transformBy: aMorphicTransform 230462 "Transform the receiver into a local coordinate system." 230463 position := aMorphicTransform globalPointToLocal: position. 230464 startPoint := aMorphicTransform globalPointToLocal: startPoint.! ! 230465 230466!MouseMoveEvent methodsFor: 'transforming' stamp: 'ar 9/15/2000 22:52'! 230467translateBy: delta 230468 "add delta to cursorPoint, and return the new event" 230469 position := position + delta. 230470 startPoint := startPoint + delta.! ! 230471 230472 230473!MouseMoveEvent methodsFor: 'private' stamp: 'ar 10/5/2000 23:55'! 230474setType: evtType startPoint: evtStart endPoint: evtEnd trail: evtTrail buttons: evtButtons hand: evtHand stamp: stamp 230475 type := evtType. 230476 startPoint := evtStart. 230477 position := evtEnd. 230478 trail := evtTrail. 230479 buttons := evtButtons. 230480 source := evtHand. 230481 wasHandled := false. 230482 timeStamp := stamp.! ! 230483Object subclass: #MouseOverHandler 230484 instanceVariableNames: 'mouseOverMorphs enteredMorphs overMorphs leftMorphs' 230485 classVariableNames: '' 230486 poolDictionaries: '' 230487 category: 'Morphic-Events'! 230488 230489!MouseOverHandler methodsFor: 'event handling' stamp: 'stephane.ducasse 6/8/2009 16:46'! 230490noticeMouseOver: aMorph event: anEvent 230491 "Remember that the mouse is currently over some morph" 230492 230493 leftMorphs isNil ifFalse: [ 230494 (leftMorphs includes: aMorph) 230495 ifTrue:[leftMorphs remove: aMorph] 230496 ifFalse:[enteredMorphs nextPut: aMorph]. 230497 overMorphs nextPut: aMorph.] 230498 230499 ! ! 230500 230501!MouseOverHandler methodsFor: 'event handling' stamp: 'PeterHugossonMiller 9/3/2009 10:07'! 230502processMouseOver: anEvent 230503 "Re-establish the z-order for all morphs wrt the given event" 230504 230505 | hand localEvt focus evt | 230506 hand := anEvent hand. 230507 leftMorphs := mouseOverMorphs asIdentitySet. 230508 "Assume some coherence for the number of objects in over list" 230509 overMorphs := (Array new: leftMorphs size) writeStream. 230510 enteredMorphs := Array new writeStream. 230511 "Now go looking for eventual mouse overs" 230512 hand handleEvent: anEvent asMouseOver. 230513 "Get out early if there's no change" 230514 (leftMorphs isEmpty and: [enteredMorphs position = 0]) 230515 ifTrue: [^leftMorphs := enteredMorphs := overMorphs := nil]. 230516 focus := hand mouseFocus. 230517 "Send #mouseLeave as appropriate" 230518 evt := anEvent asMouseLeave. 230519 "Keep the order of the left morphs by recreating it from the mouseOverMorphs" 230520 leftMorphs size > 1 230521 ifTrue: [leftMorphs := mouseOverMorphs select: [:m | leftMorphs includes: m]]. 230522 leftMorphs do: 230523 [:m | 230524 (m == focus or: [m hasOwner: focus]) 230525 ifTrue: 230526 [localEvt := evt transformedBy: (m transformedFrom: hand). 230527 m handleEvent: localEvt] 230528 ifFalse: [overMorphs nextPut: m]]. 230529 "Send #mouseEnter as appropriate" 230530 evt := anEvent asMouseEnter. 230531 enteredMorphs ifNil: 230532 ["inform: was called in handleEvent:" 230533 230534 ^leftMorphs := enteredMorphs := overMorphs := nil]. 230535 enteredMorphs := enteredMorphs contents. 230536 enteredMorphs reverseDo: 230537 [:m | 230538 (m == focus or: [m hasOwner: focus]) 230539 ifTrue: 230540 [localEvt := evt transformedBy: (m transformedFrom: hand). 230541 m handleEvent: localEvt]]. 230542 "And remember the over list" 230543 overMorphs ifNil: 230544 ["inform: was called in handleEvent:" 230545 230546 ^leftMorphs := enteredMorphs := overMorphs := nil]. 230547 mouseOverMorphs := overMorphs contents. 230548 leftMorphs := enteredMorphs := overMorphs := nil! ! 230549 230550 230551!MouseOverHandler methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:10'! 230552initialize 230553 super initialize. 230554 mouseOverMorphs := #().! ! 230555MouseEvent subclass: #MouseWheelEvent 230556 instanceVariableNames: 'direction' 230557 classVariableNames: '' 230558 poolDictionaries: '' 230559 category: 'Polymorph-Widgets'! 230560!MouseWheelEvent commentStamp: 'gvc 9/23/2008 11:46' prior: 0! 230561A mouse event generated by intercepting the keyboard events (ctrl+up/down arrow) generated by the VM in response to mouse wheel activity.! 230562 230563 230564!MouseWheelEvent methodsFor: 'accessing' stamp: 'gvc 1/25/2008 17:40'! 230565direction 230566 "Answer the value of direction" 230567 230568 ^ direction! ! 230569 230570!MouseWheelEvent methodsFor: 'accessing' stamp: 'gvc 1/25/2008 17:40'! 230571direction: anObject 230572 "Set the value of direction" 230573 230574 direction := anObject! ! 230575 230576 230577!MouseWheelEvent methodsFor: 'as yet unclassified' stamp: 'gvc 1/28/2008 13:14'! 230578isMouseWheel 230579 "Answer whether the receiver is a mouse wheel event." 230580 230581 ^true! ! 230582 230583!MouseWheelEvent methodsFor: 'as yet unclassified' stamp: 'gvc 1/25/2008 17:42'! 230584sentTo: anObject 230585 "Dispatch the receiver into anObject" 230586 230587 type == #mouseWheel ifTrue:[^anObject handleMouseWheel: self]. 230588 ^super sentTo: anObject. 230589! ! 230590 230591!MouseWheelEvent methodsFor: 'as yet unclassified' stamp: 'gvc 1/28/2008 15:31'! 230592setType: evtType position: evtPos direction: dirSymbol buttons: evtButtons hand: evtHand stamp: stamp 230593 "Set the state for the receiver." 230594 230595 type := evtType. 230596 position := evtPos. 230597 buttons := evtButtons. 230598 source := evtHand. 230599 wasHandled := false. 230600 direction := dirSymbol. 230601 timeStamp := stamp.! ! 230602Morph subclass: #MovieMorph 230603 instanceVariableNames: 'playMode msecsPerFrame rotationDegrees scalePoint frameList currentFrameIndex dwellCount' 230604 classVariableNames: '' 230605 poolDictionaries: '' 230606 category: 'Morphic-Basic'! 230607 230608!MovieMorph methodsFor: 'accessing'! 230609form 230610 230611 ^ self currentFrame form 230612! ! 230613 230614!MovieMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:05'! 230615scalePoint 230616 230617 ^ scalePoint 230618! ! 230619 230620!MovieMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:05'! 230621scalePoint: newScalePoint 230622 230623 | frame | 230624 newScalePoint ~= scalePoint ifTrue: [ 230625 self changed. 230626 scalePoint := newScalePoint. 230627 frame := self currentFrame. 230628 frame ifNotNil: [frame scalePoint: newScalePoint]. 230629 self layoutChanged. 230630 self changed]. 230631! ! 230632 230633 230634!MovieMorph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 18:47'! 230635drawOn: aCanvas 230636 | frame | 230637 frame := self currentFrame. 230638 frame notNil 230639 ifTrue: [^frame drawOn: aCanvas] 230640 ifFalse: [^super drawOn: aCanvas]! ! 230641 230642 230643!MovieMorph methodsFor: 'geometry testing' stamp: 'dgd 2/22/2003 18:48'! 230644containsPoint: p 230645 | frame | 230646 frame := self currentFrame. 230647 ^ (frame notNil and: [playMode = #stop]) 230648 ifTrue: [frame containsPoint: p] 230649 ifFalse: [super containsPoint: p]! ! 230650 230651 230652!MovieMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:28'! 230653defaultColor 230654 "answer the default color/fill style for the receiver" 230655 ^ Color 230656 r: 1 230657 g: 0 230658 b: 1! ! 230659 230660!MovieMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:11'! 230661initialize 230662 "initialize the state of the receiver" 230663 super initialize. 230664 "" 230665 230666 playMode := #stop. 230667 "#stop, #playOnce, or #loop" 230668 msecsPerFrame := 200. 230669 rotationDegrees := 0. 230670 scalePoint := 1.0 @ 1.0. 230671 frameList := EmptyArray. 230672 currentFrameIndex := 1. 230673 dwellCount := 0! ! 230674 230675 230676!MovieMorph methodsFor: 'menu' stamp: 'wiz 12/4/2006 00:25'! 230677addCustomMenuItems: aCustomMenu hand: aHandMorph 230678 230679 | movies subMenu | 230680 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 230681 aCustomMenu addLine. 230682 subMenu := MenuMorph new defaultTarget: self. 230683 frameList size > 1 ifTrue: [ 230684 subMenu add: 'repaint' translated action: #editDrawing. 230685 subMenu add: 'set rotation center' translated action: #setRotationCenter. 230686 subMenu add: 'play once' translated action: #playOnce. 230687 subMenu add: 'play loop' translated action: #playLoop. 230688 subMenu add: 'stop playing' translated action: #stopPlaying. 230689 currentFrameIndex > 1 ifTrue: [ 230690 subMenu add: 'previous frame' translated action: #previousFrame]. 230691 currentFrameIndex < frameList size ifTrue: [ 230692 subMenu add: 'next frame' translated action: #nextFrame]]. 230693 subMenu add: 'extract this frame' translated action: #extractFrame:. 230694 movies := 230695 (self world rootMorphsAt: aHandMorph targetPoint) 230696 select: [:m | (m isKindOf: MovieMorph) or: 230697 [m isSketchMorph]]. 230698 (movies size > 1) ifTrue: 230699 [subMenu add: 'insert into movie' translated action: #insertIntoMovie:]. 230700 aCustomMenu add: 'movie...' translated subMenu: subMenu 230701! ! 230702 230703!MovieMorph methodsFor: 'menu'! 230704advanceFrame 230705 230706 currentFrameIndex < frameList size 230707 ifTrue: [self setFrame: currentFrameIndex + 1] 230708 ifFalse: [self setFrame: 1]. 230709! ! 230710 230711!MovieMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:47'! 230712editDrawing 230713 | frame | 230714 frame := self currentFrame. 230715 frame notNil 230716 ifTrue: [frame editDrawingIn: self pasteUpMorph forBackground: false]! ! 230717 230718!MovieMorph methodsFor: 'menu'! 230719extractFrame: evt 230720 230721 | f | 230722 f := self currentFrame. 230723 f ifNil: [^ self]. 230724 frameList := frameList copyWithout: f. 230725 frameList isEmpty 230726 ifTrue: [self position: f position] 230727 ifFalse: [self setFrame: currentFrameIndex]. 230728 evt hand attachMorph: f. 230729! ! 230730 230731!MovieMorph methodsFor: 'menu' stamp: 'wiz 12/4/2006 00:25'! 230732insertIntoMovie: evt 230733 230734 | movies aTarget | 230735 movies := 230736 (self world rootMorphsAt: evt hand targetPoint) 230737 select: [:m | ((m isKindOf: MovieMorph) or: 230738 [m isSketchMorph]) and: [m ~= self]]. 230739 movies isEmpty ifTrue: [^ self]. 230740 aTarget := movies first. 230741 (aTarget isSketchMorph) ifTrue: 230742 [aTarget := aTarget replaceSelfWithMovie]. 230743 movies first insertFrames: frameList. 230744 self delete. 230745! ! 230746 230747!MovieMorph methodsFor: 'menu'! 230748nextFrame 230749 230750 currentFrameIndex < frameList size 230751 ifTrue: [self setFrame: currentFrameIndex + 1]. 230752! ! 230753 230754!MovieMorph methodsFor: 'menu'! 230755playLoop 230756 230757 playMode := #loop. 230758! ! 230759 230760!MovieMorph methodsFor: 'menu'! 230761playOnce 230762 230763 self setFrame: 1. 230764 playMode := #playOnce. 230765! ! 230766 230767!MovieMorph methodsFor: 'menu'! 230768previousFrame 230769 230770 currentFrameIndex > 1 230771 ifTrue: [self setFrame: currentFrameIndex - 1]. 230772! ! 230773 230774!MovieMorph methodsFor: 'menu'! 230775stopPlaying 230776 230777 playMode := #stop. 230778 self setFrame: 1. 230779! ! 230780 230781 230782!MovieMorph methodsFor: 'nil'! 230783currentFrame 230784 230785 frameList isEmpty ifTrue: [^ nil]. 230786 currentFrameIndex > frameList size 230787 ifTrue: [currentFrameIndex := frameList size]. 230788 currentFrameIndex < 1 230789 ifTrue: [currentFrameIndex := 1]. 230790 ^ frameList at: currentFrameIndex 230791! ! 230792 230793!MovieMorph methodsFor: 'nil' stamp: 'ar 9/23/2000 12:44'! 230794setFrame: newFrameIndex 230795 230796 | oldFrame p newFrame | 230797 oldFrame := self currentFrame. 230798 oldFrame ifNil: [^ self]. 230799 230800 self changed. 230801 p := oldFrame referencePosition. 230802 currentFrameIndex := newFrameIndex. 230803 currentFrameIndex > frameList size 230804 ifTrue: [currentFrameIndex := frameList size]. 230805 currentFrameIndex < 1 230806 ifTrue: [currentFrameIndex := 1]. 230807 newFrame := frameList at: currentFrameIndex. 230808 newFrame referencePosition: p. 230809 oldFrame delete. 230810 self addMorph: newFrame. 230811 dwellCount := newFrame framesToDwell. 230812 self layoutChanged. 230813 self changed. 230814! ! 230815 230816 230817!MovieMorph methodsFor: 'rotate scale and flex'! 230818rotationDegrees 230819 230820 ^ rotationDegrees 230821! ! 230822 230823 230824!MovieMorph methodsFor: 'stepping and presenter'! 230825step 230826 230827 playMode = #stop ifTrue: [^ self]. 230828 230829 dwellCount > 0 ifTrue: [ 230830 dwellCount := dwellCount - 1. 230831 ^ self]. 230832 230833 currentFrameIndex < frameList size 230834 ifTrue: [^ self setFrame: currentFrameIndex + 1]. 230835 230836 playMode = #loop 230837 ifTrue: [self setFrame: 1] 230838 ifFalse: [playMode := #stop]. 230839! ! 230840 230841 230842!MovieMorph methodsFor: 'testing'! 230843stepTime 230844 230845 ^ msecsPerFrame 230846! ! 230847 230848 230849!MovieMorph methodsFor: 'private'! 230850insertFrames: newFrames 230851 "Insert the given collection of frames into this movie just after the currentrame." 230852 230853 frameList isEmpty ifTrue: [ 230854 frameList := newFrames asArray copy. 230855 self setFrame: 1. 230856 ^ self]. 230857 230858 frameList := 230859 frameList 230860 copyReplaceFrom: currentFrameIndex + 1 "insert before" 230861 to: currentFrameIndex 230862 with: newFrames. 230863! ! 230864ReadWriteStream subclass: #MultiByteBinaryOrTextStream 230865 instanceVariableNames: 'isBinary converter' 230866 classVariableNames: '' 230867 poolDictionaries: '' 230868 category: 'Multilingual-TextConversion'! 230869!MultiByteBinaryOrTextStream commentStamp: '<historical>' prior: 0! 230870It is similar to MultiByteFileStream, but works on in memory stream.! 230871 230872 230873!MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:16'! 230874ascii 230875 isBinary := false 230876! ! 230877 230878!MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:16'! 230879binary 230880 isBinary := true 230881! ! 230882 230883!MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'nk 8/2/2004 17:02'! 230884converter 230885 230886 converter ifNil: [converter := self class defaultConverter]. 230887 ^ converter 230888! ! 230889 230890!MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 8/7/2003 09:12'! 230891converter: aConverter 230892 230893 converter := aConverter. 230894! ! 230895 230896!MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:25'! 230897isBinary 230898 ^ isBinary! ! 230899 230900!MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 16:33'! 230901text 230902 isBinary := false 230903! ! 230904 230905 230906!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2005 06:10'! 230907fileInObjectAndCodeForProject 230908 "This file may contain: 2309091) a fileIn of code 2309102) just an object in SmartReferenceStream format 2309113) both code and an object. 230912 File it in and return the object. Note that self must be a FileStream or RWBinaryOrTextStream. Maybe ReadWriteStream incorporate RWBinaryOrTextStream?" 230913 | refStream object | 230914 self text. 230915 self peek asciiValue = 4 230916 ifTrue: [ "pure object file" 230917 self binary. 230918 refStream := SmartRefStream on: self. 230919 object := refStream nextAndClose] 230920 ifFalse: [ "objects mixed with a fileIn" 230921 self fileInProject. "reads code and objects, then closes the file" 230922 self binary. 230923 object := SmartRefStream scannedObject]. "set by side effect of one of the chunks" 230924 SmartRefStream scannedObject: nil. "clear scannedObject" 230925 ^ object! ! 230926 230927!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2005 06:46'! 230928fileInProject 230929 230930 self setConverterForCodeForProject. 230931 super fileIn. 230932! ! 230933 230934!MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2005 06:46'! 230935setConverterForCodeForProject 230936 230937 self converter: UTF8TextConverter new. 230938! ! 230939 230940 230941!MultiByteBinaryOrTextStream methodsFor: 'converting' stamp: 'yo 11/11/2002 13:16'! 230942asBinaryOrTextStream 230943 230944 ^ self 230945! ! 230946 230947 230948!MultiByteBinaryOrTextStream methodsFor: 'filein/out' stamp: 'yo 8/17/2004 10:02'! 230949fileIn 230950 230951 self setConverterForCode. 230952 super fileIn. 230953! ! 230954 230955!MultiByteBinaryOrTextStream methodsFor: 'filein/out' stamp: 'yo 11/11/2002 16:31'! 230956fileInObjectAndCode 230957 "This file may contain: 2309581) a fileIn of code 2309592) just an object in SmartReferenceStream format 2309603) both code and an object. 230961 File it in and return the object. Note that self must be a FileStream or RWBinaryOrTextStream. Maybe ReadWriteStream incorporate RWBinaryOrTextStream?" 230962 | refStream object | 230963 self text. 230964 self peek asciiValue = 4 230965 ifTrue: [ "pure object file" 230966 self binary. 230967 refStream := SmartRefStream on: self. 230968 object := refStream nextAndClose] 230969 ifFalse: [ "objects mixed with a fileIn" 230970 self fileIn. "reads code and objects, then closes the file" 230971 self binary. 230972 object := SmartRefStream scannedObject]. "set by side effect of one of the chunks" 230973 SmartRefStream scannedObject: nil. "clear scannedObject" 230974 ^ object! ! 230975 230976!MultiByteBinaryOrTextStream methodsFor: 'filein/out' stamp: 'tak 1/12/2005 13:47'! 230977fileOutClass: extraClass andObject: theObject 230978 UTF8TextConverter writeBOMOn: self. 230979 ^ super fileOutClass: extraClass andObject: theObject! ! 230980 230981!MultiByteBinaryOrTextStream methodsFor: 'filein/out' stamp: 'yo 8/18/2004 09:36'! 230982setConverterForCode 230983 230984 | current | 230985 current := converter saveStateOf: self. 230986 self position: 0. 230987 self binary. 230988 ((self next: 3) = (ByteArray with: 16rEF with: 16rBB with: 16rBF)) ifTrue: [ 230989 self converter: UTF8TextConverter new 230990 ] ifFalse: [ 230991 self converter: MacRomanTextConverter new. 230992 ]. 230993 converter restoreStateOf: self with: current. 230994 self text. 230995! ! 230996 230997!MultiByteBinaryOrTextStream methodsFor: 'filein/out' stamp: 'yo 7/7/2004 09:43'! 230998setEncoderForSourceCodeNamed: streamName 230999 231000 | l | 231001 l := streamName asLowercase. 231002" ((l endsWith: FileStream multiCs) or: [ 231003 (l endsWith: FileStream multiSt) or: [ 231004 (l endsWith: (FileStream multiSt, '.gz')) or: [ 231005 (l endsWith: (FileStream multiCs, '.gz'))]]]) ifTrue: [ 231006 self converter: UTF8TextConverter new. 231007 ^ self. 231008 ]. 231009" 231010 ((l endsWith: FileStream cs) or: [ 231011 (l endsWith: FileStream st) or: [ 231012 (l endsWith: (FileStream st, '.gz')) or: [ 231013 (l endsWith: (FileStream cs, '.gz'))]]]) ifTrue: [ 231014 self converter: MacRomanTextConverter new. 231015 ^ self. 231016 ]. 231017 231018 self converter: UTF8TextConverter new. 231019! ! 231020 231021 231022!MultiByteBinaryOrTextStream methodsFor: 'properties-setting' stamp: 'yo 11/14/2002 13:49'! 231023setFileTypeToObject 231024 "do nothing. We don't have a file type"! ! 231025 231026 231027!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 7/30/2004 06:59'! 231028contents 231029 231030 | ret state | 231031 state := converter saveStateOf: self. 231032 ret := self upToEnd. 231033 converter restoreStateOf: self with: state. 231034 ^ ret. 231035! ! 231036 231037!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 16:39'! 231038next 231039 231040 | n | 231041 n := self converter nextFromStream: self. 231042 n ifNil: [^ nil]. 231043 isBinary and: [n isCharacter ifTrue: [^ n asciiValue]]. 231044 ^ n. 231045! ! 231046 231047!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'ar 4/12/2005 17:34'! 231048next: anInteger 231049 231050 | multiString | 231051 "self halt." 231052 self isBinary ifTrue: [^ (super next: anInteger) asByteArray]. 231053 multiString := WideString new: anInteger. 231054 1 to: anInteger do: [:index | 231055 | character | 231056 (character := self next) ifNotNil: [ 231057 multiString at: index put: character 231058 ] ifNil: [ 231059 multiString := multiString copyFrom: 1 to: index - 1. 231060 ^ multiString 231061 ] 231062 ]. 231063 ^ multiString. 231064! ! 231065 231066!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'PeterHugossonMiller 9/3/2009 10:07'! 231067nextDelimited: terminator 231068 231069 | out ch pos | 231070 out := (String new: 1000) writeStream. 231071 self atEnd ifTrue: [^ '']. 231072 pos := self position. 231073 self next = terminator ifFalse: [ 231074 "absorb initial terminator" 231075 self position: pos. 231076 ]. 231077 [(ch := self next) == nil] whileFalse: [ 231078 (ch = terminator) ifTrue: [ 231079 self peek = terminator ifTrue: [ 231080 self next. "skip doubled terminator" 231081 ] ifFalse: [ 231082 ^ out contents "terminator is not doubled; we're done!!" 231083 ]. 231084 ]. 231085 out nextPut: ch. 231086 ]. 231087 ^ out contents. 231088! ! 231089 231090!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 13:24'! 231091nextMatchAll: aColl 231092 231093 | save | 231094 save := converter saveStateOf: self. 231095 aColl do: [:each | 231096 (self next) = each ifFalse: [ 231097 converter restoreStateOf: self with: save. 231098 ^ false. 231099 ]. 231100 ]. 231101 ^ true. 231102! ! 231103 231104!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/14/2002 13:54'! 231105nextPut: aCharacter 231106 231107 aCharacter isInteger ifTrue: [^ super nextPut: aCharacter asCharacter]. 231108 ^ self converter nextPut: aCharacter toStream: self 231109! ! 231110 231111!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 13:24'! 231112nextPutAll: aCollection 231113 231114 self isBinary ifTrue: [ 231115 ^ super nextPutAll: aCollection. 231116 ]. 231117 aCollection do: [:e | self nextPut: e]. 231118! ! 231119 231120!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/14/2002 13:54'! 231121padToEndWith: aChar 231122 "We don't have pages, so we are at the end, and don't need to pad."! ! 231123 231124!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 12/25/2003 16:04'! 231125peek 231126 "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " 231127 231128 | next pos | 231129 self atEnd ifTrue: [^ nil]. 231130 pos := self position. 231131 next := self next. 231132 self position: pos. 231133 ^ next. 231134 231135! ! 231136 231137!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 13:25'! 231138peekFor: item 231139 231140 | next state | 231141 "self atEnd ifTrue: [^ false]. -- SFStream will give nil" 231142 state := converter saveStateOf: self. 231143 (next := self next) == nil ifTrue: [^ false]. 231144 item = next ifTrue: [^ true]. 231145 converter restoreStateOf: self with: state. 231146 ^ false. 231147! ! 231148 231149!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'nk 7/29/2004 12:02'! 231150reset 231151 231152 super reset. 231153 isBinary ifNil: [isBinary := false]. 231154 collection class == ByteArray ifTrue: ["Store as String and convert as needed." 231155 collection := collection asString. 231156 isBinary := true]. 231157 231158 self converter. "ensure that we have a converter."! ! 231159 231160!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 16:17'! 231161skipSeparators 231162 231163 [self atEnd] whileFalse: [ 231164 self basicNext isSeparator ifFalse: [ 231165 ^ self position: self position - 1]] 231166 231167! ! 231168 231169!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 12/25/2003 16:04'! 231170skipSeparatorsAndPeekNext 231171 231172 "A special function to make nextChunk fast" 231173 | peek pos | 231174 [self atEnd] whileFalse: [ 231175 pos := self position. 231176 (peek := self next) isSeparator ifFalse: [ 231177 self position: pos. 231178 ^ peek. 231179 ]. 231180 ]. 231181! ! 231182 231183!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'PeterHugossonMiller 9/3/2009 10:08'! 231184upTo: delim 231185 231186 | out ch | 231187 out := (String new: 1000) writeStream. 231188 self atEnd ifTrue: [^ '']. 231189 [(ch := self next) isNil] whileFalse: [ 231190 (ch = delim) ifTrue: [ 231191 ^ out contents "terminator is not doubled; we're done!!" 231192 ]. 231193 out nextPut: ch. 231194 ]. 231195 ^ out contents. 231196! ! 231197 231198!MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'PeterHugossonMiller 9/3/2009 10:08'! 231199upToEnd 231200 231201 | newStream element newCollection | 231202 newCollection := self isBinary 231203 ifTrue: [ByteArray new: 100] 231204 ifFalse: [String new: 100]. 231205 newStream := newCollection writeStream. 231206 [(element := self next) notNil] 231207 whileTrue: [newStream nextPut: element]. 231208 ^ newStream contents 231209! ! 231210 231211 231212!MultiByteBinaryOrTextStream methodsFor: 'private' stamp: 'nk 8/2/2004 17:01'! 231213guessConverter 231214 ^ (self originalContents includesSubString: (ByteArray withAll: {27. 36}) asString) 231215 ifTrue: [CompoundTextConverter new] 231216 ifFalse: [self class defaultConverter ]! ! 231217 231218 231219!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 16:01'! 231220basicNext 231221 231222 ^ super next 231223! ! 231224 231225!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'md 10/20/2004 15:32'! 231226basicNext: anInteger 231227 231228 ^ super next: anInteger. 231229! ! 231230 231231!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! 231232basicNext: n into: aString 231233 231234 ^ super next: n into: aString. 231235! ! 231236 231237!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! 231238basicNextInto: aString 231239 231240 ^ super nextInto: aString. 231241! ! 231242 231243!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! 231244basicNextPut: char 231245 231246 ^ super nextPut: char. 231247! ! 231248 231249!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! 231250basicNextPutAll: aString 231251 231252 ^ super nextPutAll: aString. 231253! ! 231254 231255!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! 231256basicPeek 231257 231258 ^ super peek 231259! ! 231260 231261!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! 231262basicPosition 231263 231264 ^ super position. 231265! ! 231266 231267!MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! 231268basicPosition: pos 231269 231270 ^ super position: pos. 231271! ! 231272 231273"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 231274 231275MultiByteBinaryOrTextStream class 231276 instanceVariableNames: ''! 231277 231278!MultiByteBinaryOrTextStream class methodsFor: 'defaults' stamp: 'yo 2/25/2005 20:04'! 231279defaultConverter 231280 ^ Latin1TextConverter new. 231281! ! 231282 231283 231284!MultiByteBinaryOrTextStream class methodsFor: 'instance creation' stamp: 'ykoubo 9/28/2003 19:59'! 231285on: aCollection encoding: encodingName 231286 | aTextConverter | 231287 encodingName isNil 231288 ifTrue: [aTextConverter := TextConverter default] 231289 ifFalse: [aTextConverter := TextConverter newForEncoding: encodingName]. 231290 ^ (self on: aCollection) 231291 converter: aTextConverter! ! 231292 231293!MultiByteBinaryOrTextStream class methodsFor: 'instance creation' stamp: 'yo 11/23/2003 20:32'! 231294with: aCollection encoding: encodingName 231295 | aTextConverter | 231296 encodingName isNil 231297 ifTrue: [aTextConverter := TextConverter default] 231298 ifFalse: [aTextConverter := TextConverter newForEncoding: encodingName]. 231299 ^ (self with: aCollection) 231300 converter: aTextConverter! ! 231301StandardFileStream subclass: #MultiByteFileStream 231302 instanceVariableNames: 'converter lineEndConvention wantsLineEndConversion' 231303 classVariableNames: 'Cr CrLf Lf LineEndDefault LineEndStrings LookAheadCount' 231304 poolDictionaries: '' 231305 category: 'Multilingual-TextConversion'! 231306!MultiByteFileStream commentStamp: '<historical>' prior: 0! 231307The central class to access the external file. The interface of this object is similar to good old StandardFileStream, but internally it asks the converter, which is a sub-instance of TextConverter, and do the text conversion. 231308 231309 It also combined the good old CrLfFileStream. CrLfFileStream class>>new now returns an instance of MultiByteFileStream. 231310 231311 There are several pitfalls: 231312 231313 * You always have to be careful about the binary/text distinction. In #text mode, it usually interpret the bytes. 231314 * A few file pointer operations treat the file as uninterpreted byte no matter what. This means that if you use 'fileStream skip: -1', 'fileStream position: x', etc. in #text mode, the file position can be in the middle of multi byte character. If you want to implement some function similar to #peek for example, call the saveStateOf: and restoreStateOf: methods to be able to get back to the original state. 231315 * #lineEndConvention: and #wantsLineEndConversion: (and #binary) can cause some puzzling situation because the inst var lineEndConvention and wantsLineEndConversion are mutated. If you have any suggestions to clean up the protocol, please let me know.! 231316 231317 231318!MultiByteFileStream methodsFor: 'accessing' stamp: 'al 5/10/2008 13:14'! 231319ascii 231320 super ascii. 231321 self detectLineEndConvention. 231322! ! 231323 231324!MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 2/21/2004 02:57'! 231325binary 231326 231327 super binary. 231328 lineEndConvention := nil. 231329! ! 231330 231331!MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 8/18/2003 15:11'! 231332converter 231333 231334 converter ifNil: [converter := TextConverter defaultSystemConverter]. 231335 ^ converter 231336! ! 231337 231338!MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 8/28/2002 11:09'! 231339converter: aConverter 231340 231341 converter := aConverter. 231342! ! 231343 231344!MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 8/6/2003 11:56'! 231345fileInEncodingName: aString 231346 231347 self converter: (TextConverter newForEncoding: aString). 231348 super fileIn. 231349! ! 231350 231351!MultiByteFileStream methodsFor: 'accessing' stamp: 'nk 9/5/2004 12:57'! 231352lineEndConvention 231353 231354 ^lineEndConvention! ! 231355 231356 231357!MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/24/2004 13:38'! 231358bareNext 231359 231360 ^ self converter nextFromStream: self. 231361! ! 231362 231363!MultiByteFileStream methodsFor: 'crlf private' stamp: 'PeterHugossonMiller 9/3/2009 10:08'! 231364convertStringFromCr: aString 231365 | inStream outStream | 231366 lineEndConvention ifNil: [ ^ aString ]. 231367 lineEndConvention == #cr ifTrue: [ ^ aString ]. 231368 lineEndConvention == #lf ifTrue: 231369 [ ^ aString copy 231370 replaceAll: Cr 231371 with: Lf ]. 231372 "lineEndConvention == #crlf" 231373 inStream := aString readStream. 231374 outStream := (String new: aString size) writeStream. 231375 [ inStream atEnd ] whileFalse: 231376 [ outStream nextPutAll: (inStream upTo: Cr). 231377 (inStream atEnd not or: [ aString last = Cr ]) ifTrue: [ outStream nextPutAll: CrLf ] ]. 231378 ^ outStream contents! ! 231379 231380!MultiByteFileStream methodsFor: 'crlf private' stamp: 'PeterHugossonMiller 9/3/2009 10:08'! 231381convertStringToCr: aString 231382 | inStream outStream | 231383 lineEndConvention ifNil: [ ^ aString ]. 231384 lineEndConvention == #cr ifTrue: [ ^ aString ]. 231385 lineEndConvention == #lf ifTrue: 231386 [ ^ aString copy 231387 replaceAll: Lf 231388 with: Cr ]. 231389 "lineEndConvention == #crlf" 231390 inStream := aString readStream. 231391 outStream := (String new: aString size) writeStream. 231392 [ inStream atEnd ] whileFalse: 231393 [ outStream nextPutAll: (inStream upTo: Cr). 231394 (inStream atEnd not or: [ aString last = Cr ]) ifTrue: 231395 [ outStream nextPut: Cr. 231396 inStream peek = Lf ifTrue: [ inStream next ] ] ]. 231397 ^ outStream contents! ! 231398 231399!MultiByteFileStream methodsFor: 'crlf private' stamp: 'nk 9/5/2004 12:50'! 231400detectLineEndConvention 231401 "Detect the line end convention used in this stream. The result may be either #cr, #lf or #crlf." 231402 | char numRead state | 231403 self isBinary ifTrue: [^ self error: 'Line end conventions are not used on binary streams']. 231404 self wantsLineEndConversion ifFalse: [^ lineEndConvention := nil.]. 231405 self closed ifTrue: [^ lineEndConvention := LineEndDefault.]. 231406 231407 "Default if nothing else found" 231408 numRead := 0. 231409 state := converter saveStateOf: self. 231410 lineEndConvention := nil. 231411 [super atEnd not and: [numRead < LookAheadCount]] 231412 whileTrue: 231413 [char := self next. 231414 char = Lf 231415 ifTrue: 231416 [converter restoreStateOf: self with: state. 231417 ^ lineEndConvention := #lf]. 231418 char = Cr 231419 ifTrue: 231420 [self peek = Lf 231421 ifTrue: [lineEndConvention := #crlf] 231422 ifFalse: [lineEndConvention := #cr]. 231423 converter restoreStateOf: self with: state. 231424 ^ lineEndConvention]. 231425 numRead := numRead + 1]. 231426 converter restoreStateOf: self with: state. 231427 ^ lineEndConvention := LineEndDefault. 231428! ! 231429 231430!MultiByteFileStream methodsFor: 'crlf private' stamp: 'nk 9/5/2004 12:51'! 231431doConversion 231432 231433 ^self wantsLineEndConversion and: [ lineEndConvention notNil ]! ! 231434 231435!MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/24/2004 13:44'! 231436next: n innerFor: aString 231437 231438 | peekChar state | 231439 "if we just read a CR, and the next character is an LF, then skip the LF" 231440 aString size = 0 ifTrue: [^ aString]. 231441 (aString last = Character cr) ifTrue: [ 231442 state := converter saveStateOf: self. 231443 peekChar := self bareNext. "super peek doesn't work because it relies on #next" 231444 (peekChar notNil and: [peekChar ~= Character lf]) ifTrue: [ 231445 converter restoreStateOf: self with: state. 231446 ]. 231447 ]. 231448 231449 ^ aString withSqueakLineEndings. 231450! ! 231451 231452!MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/21/2004 03:51'! 231453wantsLineEndConversion 231454 231455 ^ wantsLineEndConversion ifNil: [false]. 231456! ! 231457 231458 231459!MultiByteFileStream methodsFor: 'filein/out' stamp: 'yo 8/17/2004 10:03'! 231460fileIn 231461 231462 self setConverterForCode. 231463 super fileIn. 231464! ! 231465 231466!MultiByteFileStream methodsFor: 'filein/out' stamp: 'ar 7/29/2005 22:33'! 231467fileInObjectAndCodeForProject 231468 "This file may contain: 2314691) a fileIn of code 2314702) just an object in SmartReferenceStream format 2314713) both code and an object. 231472 File it in and return the object. Note that self must be a FileStream or RWBinaryOrTextStream. Maybe ReadWriteStream incorporate RWBinaryOrTextStream?" 231473 | refStream object | 231474 self text. 231475 self peek asciiValue = 4 231476 ifTrue: [ "pure object file" 231477 self binary. 231478 refStream := SmartRefStream on: self. 231479 object := refStream nextAndClose] 231480 ifFalse: [ "objects mixed with a fileIn" 231481 self fileInProject. "reads code and objects, then closes the file" 231482 self binary. 231483 object := SmartRefStream scannedObject]. "set by side effect of one of the chunks" 231484 SmartRefStream scannedObject: nil. "clear scannedObject" 231485 ^ object! ! 231486 231487!MultiByteFileStream methodsFor: 'filein/out' stamp: 'ar 7/29/2005 22:33'! 231488fileInProject 231489 231490 self setConverterForCodeForProject. 231491 super fileIn. 231492! ! 231493 231494!MultiByteFileStream methodsFor: 'filein/out' stamp: 'tak 1/12/2005 14:48'! 231495fileOutClass: extraClass andObject: theObject 231496 self binary. 231497 UTF8TextConverter writeBOMOn: self. 231498 self text. 231499 ^ super fileOutClass: extraClass andObject: theObject! ! 231500 231501 231502!MultiByteFileStream methodsFor: 'open/close' stamp: 'kph 2/15/2007 03:18'! 231503open: fileName forWrite: writeMode 231504 | result | 231505 result := super open: fileName forWrite: writeMode. 231506 result ifNotNil: [ 231507 converter ifNil: [converter := UTF8TextConverter new]. 231508 lineEndConvention ifNil: [ self detectLineEndConvention ] 231509 ]. 231510 ^result! ! 231511 231512!MultiByteFileStream methodsFor: 'open/close' stamp: 'yo 8/13/2003 13:51'! 231513reset 231514 231515 super reset. 231516 converter ifNil: [ 231517 converter := UTF8TextConverter new. 231518 ]. 231519! ! 231520 231521 231522!MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/24/2004 13:49'! 231523next 231524 231525 | char secondChar state | 231526 char := self converter nextFromStream: self. 231527 self doConversion ifTrue: [ 231528 char == Cr ifTrue: [ 231529 state := converter saveStateOf: self. 231530 secondChar := self bareNext. 231531 secondChar ifNotNil: [secondChar == Lf ifFalse: [converter restoreStateOf: self with: state]]. 231532 ^Cr]. 231533 char == Lf ifTrue: [^Cr]. 231534 ]. 231535 ^ char. 231536 231537! ! 231538 231539!MultiByteFileStream methodsFor: 'public' stamp: 'yo 7/31/2004 18:03'! 231540next: anInteger 231541 231542 | multiString | 231543 self isBinary ifTrue: [^ super next: anInteger]. 231544 multiString := String new: anInteger. 231545 1 to: anInteger do: [:index | 231546 | character | 231547 (character := self next) ifNotNil: [ 231548 multiString at: index put: character 231549 ] ifNil: [ 231550 multiString := multiString copyFrom: 1 to: index - 1. 231551 self doConversion ifFalse: [ 231552 ^ multiString 231553 ]. 231554 ^ self next: anInteger innerFor: multiString. 231555 ] 231556 ]. 231557 self doConversion ifFalse: [ 231558 ^ multiString 231559 ]. 231560 231561 multiString := self next: anInteger innerFor: multiString. 231562 (multiString size = anInteger or: [self atEnd]) ifTrue: [ ^ multiString]. 231563 ^ multiString, (self next: anInteger - multiString size). 231564! ! 231565 231566!MultiByteFileStream methodsFor: 'public' stamp: 'PeterHugossonMiller 9/3/2009 10:09'! 231567nextDelimited: terminator 231568 231569 | out ch save | 231570 out := (String new: 1000) writeStream. 231571 self atEnd ifTrue: [^ '']. 231572 save := converter saveStateOf: self. 231573 231574 self next = terminator ifFalse: [ 231575 "absorb initial terminator" 231576 converter restoreStateOf: self with: save. 231577 ]. 231578 [(ch := self next) == nil] whileFalse: [ 231579 (ch = terminator) ifTrue: [ 231580 self peek = terminator ifTrue: [ 231581 self next. "skip doubled terminator" 231582 ] ifFalse: [ 231583 ^ out contents "terminator is not doubled; we're done!!" 231584 ]. 231585 ]. 231586 out nextPut: ch. 231587 ]. 231588 ^ out contents. 231589! ! 231590 231591!MultiByteFileStream methodsFor: 'public' stamp: 'yo 8/28/2002 11:13'! 231592nextMatchAll: aColl 231593 231594 | save | 231595 save := converter saveStateOf: self. 231596 aColl do: [:each | 231597 (self next) = each ifFalse: [ 231598 converter restoreStateOf: self with: save. 231599 ^ false. 231600 ]. 231601 ]. 231602 ^ true. 231603! ! 231604 231605!MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/21/2004 03:42'! 231606nextPut: aCharacter 231607 231608 aCharacter isInteger ifTrue: [^ super nextPut: aCharacter]. 231609 self doConversion ifTrue: [ 231610 aCharacter = Cr ifTrue: [ 231611 (LineEndStrings at: lineEndConvention) do: [:e | converter nextPut: e toStream: self]. 231612 ] ifFalse: [ 231613 converter nextPut: aCharacter toStream: self 231614 ]. 231615 ^ aCharacter 231616 ]. 231617 ^ self converter nextPut: aCharacter toStream: self 231618! ! 231619 231620!MultiByteFileStream methodsFor: 'public' stamp: 'yo 5/23/2003 09:40'! 231621nextPutAll: aCollection 231622 231623 (self isBinary or: [aCollection class == ByteArray]) ifTrue: [ 231624 ^ super nextPutAll: aCollection. 231625 ]. 231626 aCollection do: [:e | self nextPut: e]. 231627! ! 231628 231629!MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/21/2004 04:00'! 231630peek 231631 "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " 231632 231633 | next save | 231634 self atEnd ifTrue: [^ nil]. 231635 save := converter saveStateOf: self. 231636 next := self next. 231637 converter restoreStateOf: self with: save. 231638 ^ next. 231639 231640! ! 231641 231642!MultiByteFileStream methodsFor: 'public' stamp: 'yo 8/28/2002 11:15'! 231643peekFor: item 231644 231645 | next state | 231646 "self atEnd ifTrue: [^ false]. -- SFStream will give nil" 231647 state := converter saveStateOf: self. 231648 (next := self next) == nil ifTrue: [^ false]. 231649 item = next ifTrue: [^ true]. 231650 converter restoreStateOf: self with: state. 231651 ^ false. 231652! ! 231653 231654!MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/24/2004 13:35'! 231655skipSeparators 231656 231657 | state | 231658 [self atEnd] whileFalse: [ 231659 state := converter saveStateOf: self. 231660 self next isSeparator ifFalse: [ 231661 ^ converter restoreStateOf: self with: state]] 231662 231663 231664" [self atEnd] whileFalse: [ 231665 self next isSeparator ifFalse: [ 231666 ^ self position: self position - converter currentCharSize. 231667 ]. 231668 ]. 231669" 231670! ! 231671 231672!MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/21/2004 04:01'! 231673skipSeparatorsAndPeekNext 231674 231675 "A special function to make nextChunk fast" 231676 | peek save | 231677 [self atEnd] whileFalse: [ 231678 save := converter saveStateOf: self. 231679 (peek := self next) isSeparator ifFalse: [ 231680 converter restoreStateOf: self with: save. 231681 ^ peek. 231682 ]. 231683 ]. 231684! ! 231685 231686!MultiByteFileStream methodsFor: 'public' stamp: 'PeterHugossonMiller 9/3/2009 10:09'! 231687upTo: delim 231688 | out ch collectorClass | 231689 collectorClass := self isBinary 231690 ifTrue: [ByteArray] 231691 ifFalse: [String]. 231692 out := (collectorClass new: 1000) writeStream. 231693 [(ch := self next) isNil] 231694 whileFalse: [ch = delim 231695 ifTrue: [^ out contents]. 231696 out nextPut: ch]. 231697 ^ out contents! ! 231698 231699!MultiByteFileStream methodsFor: 'public' stamp: 'PeterHugossonMiller 9/3/2009 10:09'! 231700upToEnd 231701 231702 | newStream element | 231703 collection := self isBinary 231704 ifTrue: [ByteArray new: 100] 231705 ifFalse: [String new: 100]. 231706 newStream := collection writeStream. 231707 [(element := self next) notNil] 231708 whileTrue: [newStream nextPut: element]. 231709 ^ newStream contents 231710! ! 231711 231712 231713!MultiByteFileStream methodsFor: 'remnant' stamp: 'yo 8/28/2002 11:09'! 231714filterFor: aFileStream 231715 231716 | rw | 231717 name := aFileStream name. 231718 rw := aFileStream isReadOnly not. 231719 aFileStream close. 231720 self open: name forWrite: rw. 231721 ^self. 231722! ! 231723 231724!MultiByteFileStream methodsFor: 'remnant' stamp: 'kph 3/1/2009 15:50'! 231725wantsLineEndConversion: aBoolean 231726 231727 wantsLineEndConversion := aBoolean. 231728 231729 lineEndConvention ifNil: [ self detectLineEndConvention ]. ! ! 231730 231731 231732!MultiByteFileStream methodsFor: 'private' stamp: 'mir 8/25/2004 17:27'! 231733setConverterForCode 231734 231735 | current | 231736 (SourceFiles at: 2) 231737 ifNotNil: [self fullName = (SourceFiles at: 2) fullName ifTrue: [^ self]]. 231738 current := self converter saveStateOf: self. 231739 self position: 0. 231740 self binary. 231741 ((self next: 3) = (ByteArray with: 16rEF with: 16rBB with: 16rBF)) ifTrue: [ 231742 self converter: UTF8TextConverter new 231743 ] ifFalse: [ 231744 self converter: MacRomanTextConverter new. 231745 ]. 231746 converter restoreStateOf: self with: current. 231747 self text. 231748! ! 231749 231750!MultiByteFileStream methodsFor: 'private' stamp: 'ar 7/29/2005 22:33'! 231751setConverterForCodeForProject 231752 231753 self converter: UTF8TextConverter new. 231754! ! 231755 231756 231757!MultiByteFileStream methodsFor: 'private basic' stamp: 'md 10/17/2004 16:09'! 231758basicNext: anInteger 231759 231760 ^ super next: anInteger. 231761! ! 231762 231763!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! 231764basicNext: n into: aString 231765 231766 ^ super next: n into: aString. 231767! ! 231768 231769!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! 231770basicNextInto: aString 231771 231772 ^ super nextInto: aString. 231773! ! 231774 231775!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! 231776basicNextPut: char 231777 231778 ^ super nextPut: char. 231779! ! 231780 231781!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! 231782basicNextPutAll: aString 231783 231784 ^ super nextPutAll: aString. 231785! ! 231786 231787!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! 231788basicPeek 231789 231790 ^ super peek 231791! ! 231792 231793!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! 231794basicPosition 231795 231796 ^ super position. 231797! ! 231798 231799!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! 231800basicPosition: pos 231801 231802 ^ super position: pos. 231803! ! 231804 231805!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! 231806basicReadInto: byteArray startingAt: startIndex count: count 231807 231808 ^ super readInto: byteArray startingAt: startIndex count: count. 231809! ! 231810 231811!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! 231812basicSetToEnd 231813 231814 ^ super setToEnd. 231815! ! 231816 231817!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! 231818basicSkip: n 231819 231820 ^ super skip: n. 231821! ! 231822 231823!MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! 231824basicUpTo: delim 231825 231826 ^ super upTo: delim. 231827! ! 231828 231829!MultiByteFileStream methodsFor: 'private basic' stamp: 'kph 3/1/2009 01:53'! 231830lineEndConvention: aSymbol 231831 231832 (lineEndConvention := aSymbol) ifNotNil: [ self wantsLineEndConversion: true ]! ! 231833 231834 231835!MultiByteFileStream methodsFor: 'private-deprecated' stamp: 'AndrewBlack 9/1/2009 07:52'! 231836basicVerbatim: aString 231837 self deprecated: 'This method is private but not called. It will be deleted'. 231838 ^ super verbatim: aString. 231839! ! 231840 231841"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 231842 231843MultiByteFileStream class 231844 instanceVariableNames: ''! 231845 231846!MultiByteFileStream class methodsFor: 'initialization' stamp: 'yo 2/21/2004 02:45'! 231847defaultToCR 231848 231849 "MultiByteFileStream defaultToCR" 231850 LineEndDefault := #cr. 231851! ! 231852 231853!MultiByteFileStream class methodsFor: 'initialization' stamp: 'yo 2/21/2004 02:45'! 231854defaultToCRLF 231855 231856 "MultiByteFileStream defaultToCRLF" 231857 LineEndDefault := #crlf.! ! 231858 231859!MultiByteFileStream class methodsFor: 'initialization' stamp: 'yo 2/21/2004 02:46'! 231860defaultToLF 231861 231862 "MultiByteFileStream defaultToLF" 231863 LineEndDefault := #lf. 231864! ! 231865 231866!MultiByteFileStream class methodsFor: 'initialization' stamp: 'norbert_hartl 6/13/2009 10:57'! 231867guessDefaultLineEndConvention 231868 231869 "Lets try to guess the line end convention from what we know about the path name delimiter from FileDirectory." 231870 FileDirectory pathNameDelimiter = $: ifTrue:[^self defaultToCR]. 231871 FileDirectory pathNameDelimiter = $/ 231872 ifTrue:[((SmalltalkImage current getSystemAttribute: 1002) 231873 beginsWith: 'darwin') 231874 ifTrue: [^ self defaultToCR] 231875 ifFalse: [^ self defaultToLF]]. 231876 FileDirectory pathNameDelimiter = $\ ifTrue:[^self defaultToCRLF]. 231877 "in case we don't know" 231878 ^self defaultToCR. 231879! ! 231880 231881!MultiByteFileStream class methodsFor: 'initialization' stamp: 'yo 2/21/2004 02:44'! 231882initialize 231883 231884 "MultiByteFileStream initialize" 231885 Cr := Character cr. 231886 Lf := Character lf. 231887 CrLf := String with: Cr with: Lf. 231888 LineEndStrings := Dictionary new. 231889 LineEndStrings at: #cr put: (String with: Character cr). 231890 LineEndStrings at: #lf put: (String with: Character lf). 231891 LineEndStrings at: #crlf put: (String with: Character cr with: Character lf). 231892 LookAheadCount := 2048. 231893 Smalltalk addToStartUpList: self. 231894 self startUp. 231895! ! 231896 231897!MultiByteFileStream class methodsFor: 'initialization' stamp: 'yo 2/21/2004 02:44'! 231898startUp 231899 231900 self guessDefaultLineEndConvention. 231901! ! 231902 231903 231904!MultiByteFileStream class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 11:43'! 231905newFrom: aFileStream 231906 231907 | rw n | 231908 n := aFileStream name. 231909 rw := aFileStream isReadOnly not. 231910 aFileStream close. 231911 ^self new open: n forWrite: rw. 231912! ! 231913TestCase subclass: #MultiByteFileStreamTest 231914 instanceVariableNames: '' 231915 classVariableNames: '' 231916 poolDictionaries: '' 231917 category: 'MultilingualTests-TextConversion'! 231918 231919!MultiByteFileStreamTest methodsFor: 'testing' stamp: 'nice 10/16/2008 21:14'! 231920testBinaryUpTo 231921 "This is a non regression test for bug http://bugs.squeak.org/view.php?id=6933" 231922 231923 | foo | 231924 231925 foo := MultiByteFileStream forceNewFileNamed: 'foobug6933'. 231926 [foo binary. 231927 foo nextPutAll: #(1 2 3 4) asByteArray] ensure: [foo close]. 231928 231929 foo := MultiByteFileStream oldFileNamed: 'foobug6933'. 231930 [foo binary. 231931 self assert: (foo upTo: 3) = #(1 2 ) asByteArray] ensure: [foo close]! ! 231932PluggableCanvas subclass: #MultiCanvas 231933 instanceVariableNames: 'canvases extent depth' 231934 classVariableNames: '' 231935 poolDictionaries: '' 231936 category: 'Morphic-Support'! 231937!MultiCanvas commentStamp: '<historical>' prior: 0! 231938A canvas which forwards drawing commands to sub-canvases.! 231939 231940 231941!MultiCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 20:48'! 231942addCanvas: aCanvas 231943 canvases add: aCanvas! ! 231944 231945!MultiCanvas methodsFor: 'accessing' stamp: 'RAA 11/7/2000 17:46'! 231946clipRect 231947 231948 ^super clipRect ifNil: [ 231949 0@0 extent: 5000@5000 231950 ].! ! 231951 231952!MultiCanvas methodsFor: 'accessing' stamp: 'RAA 8/14/2000 10:27'! 231953contentsOfArea: aRectangle into: aForm 231954 231955 self apply: [ :c | 231956 (c isKindOf: FormCanvas) ifTrue: [ 231957 c contentsOfArea: aRectangle into: aForm. 231958 ^aForm 231959 ]. 231960 ]. 231961 self apply: [ :c | 231962 c contentsOfArea: aRectangle into: aForm. 231963 ^aForm. 231964 ]. 231965 ^aForm! ! 231966 231967!MultiCanvas methodsFor: 'accessing' stamp: 'ls 4/8/2000 22:35'! 231968depth 231969 ^depth! ! 231970 231971!MultiCanvas methodsFor: 'accessing' stamp: 'ls 4/8/2000 22:35'! 231972extent 231973 ^extent! ! 231974 231975!MultiCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 20:48'! 231976removeCanvas: aCanvas 231977 canvases remove: aCanvas ifAbsent: []! ! 231978 231979 231980!MultiCanvas methodsFor: 'initialization' stamp: 'RAA 8/1/2000 13:50'! 231981allocateForm: extentPoint 231982 "Allocate a new form which is similar to the receiver and can be used for accelerated blts" 231983 ^Form extent: extentPoint depth: self depth! ! 231984 231985!MultiCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:35'! 231986depth: newDepth 231987 "set the extent to be used with this canvas" 231988 depth := newDepth.! ! 231989 231990!MultiCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:34'! 231991extent: newExtent 231992 "set the extent to be used with this canvas" 231993 extent := newExtent.! ! 231994 231995!MultiCanvas methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:11'! 231996initialize 231997 super initialize. 231998 canvases := Set new. 231999 extent := 600@400. 232000 depth := 32. ! ! 232001 232002 232003!MultiCanvas methodsFor: 'private' stamp: 'RAA 11/6/2000 14:17'! 232004apply: aCommand 232005 232006 self flag: #roundedRudeness. 232007 "This rudeness is to help get rounded corners to work right on RemoteCanvases. Since the RemoteCanvas has no other way to read its bits, we are grabbing them from Display for now. To support this, we need to see that the Display is written before any RemoteCanvases" 232008 232009 canvases do: [ :canvas | 232010 (canvas isKindOf: FormCanvas) ifTrue: [aCommand value: canvas] 232011 ]. 232012 canvases do: [ :canvas | 232013 (canvas isKindOf: FormCanvas) ifFalse: [aCommand value: canvas] 232014 ]. 232015! ! 232016MultiCharacterScanner subclass: #MultiCanvasCharacterScanner 232017 instanceVariableNames: 'canvas fillBlt foregroundColor runX lineY' 232018 classVariableNames: '' 232019 poolDictionaries: '' 232020 category: 'Multilingual-Scanning'! 232021 232022!MultiCanvasCharacterScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 11:18'! 232023cr 232024 "When a carriage return is encountered, simply increment the pointer 232025 into the paragraph." 232026 232027 pendingKernX := 0. 232028 lastIndex:= lastIndex + 1. 232029 ^false! ! 232030 232031!MultiCanvasCharacterScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 12:51'! 232032paddedSpace 232033 "Each space is a stop condition when the alignment is right justified. 232034 Padding must be added to the base width of the space according to 232035 which space in the line this space is and according to the amount of 232036 space that remained at the end of the line when it was composed." 232037 232038 pendingKernX := 0. 232039 destX := destX + spaceWidth + (line justifiedPadFor: spaceCount font: font). 232040 lastIndex := lastIndex + 1. 232041 ^ false! ! 232042 232043!MultiCanvasCharacterScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 11:19'! 232044tab 232045 232046 pendingKernX := 0. 232047 destX := (alignment == Justified and: [self leadingTab not]) 232048 ifTrue: "imbedded tabs in justified text are weird" 232049 [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] 232050 ifFalse: 232051 [textStyle nextTabXFrom: destX 232052 leftMargin: leftMargin 232053 rightMargin: rightMargin]. 232054 232055 lastIndex := lastIndex + 1. 232056 ^ false! ! 232057 232058 232059!MultiCanvasCharacterScanner methodsFor: 'accessing' stamp: 'sd 2/4/2008 21:22'! 232060canvas: aCanvas 232061 "set the canvas to draw on" 232062 canvas ifNotNil: [ self inform: 'initializing twice!!' ]. 232063 canvas := aCanvas! ! 232064 232065 232066!MultiCanvasCharacterScanner methodsFor: 'scanning' stamp: 'gvc 3/5/2008 17:10'! 232067displayLine: textLine offset: offset leftInRun: leftInRun 232068 | nowLeftInRun done startLoc startIndex stopCondition | 232069 "largely copied from DisplayScanner's routine. 232070 Fixed to set left margin after setting up alignment." 232071 232072 line := textLine. 232073 foregroundColor ifNil: [ foregroundColor := Color black ]. 232074 rightMargin := line rightMargin + offset x. 232075 lineY := line top + offset y. 232076 lastIndex := textLine first. 232077 leftInRun <= 0 232078 ifTrue: [self setStopConditions. "also sets the font" 232079 nowLeftInRun := text runLengthFor: lastIndex] 232080 ifFalse: [nowLeftInRun := leftInRun]. 232081 leftMargin := (line leftMarginForAlignment: alignment) + offset x. 232082 runX := destX := leftMargin. 232083 232084 runStopIndex := lastIndex + (nowLeftInRun - 1) min: line last. 232085 spaceCount := 0. 232086 done := false. 232087 232088 [done] whileFalse: [ 232089 "remember where this portion of the line starts" 232090 startLoc := destX@destY. 232091 startIndex := lastIndex. 232092 232093 "find the end of this portion of the line" 232094 stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex 232095 in: text string rightX: rightMargin stopConditions: stopConditions 232096 kern: kern "displaying: false". 232097 232098 "display that portion of the line" 232099 canvas drawString: text string 232100 from: startIndex to: lastIndex 232101 at: startLoc 232102 font: font 232103 color: foregroundColor. 232104 232105 "handle the stop condition" 232106 done := self perform: stopCondition 232107 ]. 232108 232109 ^runStopIndex - lastIndex! ! 232110 232111 232112!MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'! 232113crossedX 232114 "This condition will sometimes be reached 'legally' during display, when, 232115 for instance the space that caused the line to wrap actually extends over 232116 the right boundary. This character is allowed to display, even though it 232117 is technically outside or straddling the clipping ectangle since it is in 232118 the normal case not visible and is in any case appropriately clipped by 232119 the scanner." 232120 232121 "self fillLeading." 232122 ^ true ! ! 232123 232124!MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 232125endOfRun 232126 "The end of a run in the display case either means that there is actually 232127 a change in the style (run code) to be associated with the string or the 232128 end of this line has been reached." 232129 | runLength | 232130 232131 lastIndex = line last ifTrue: [^true]. 232132 runX := destX. 232133 runLength := text runLengthFor: (lastIndex := lastIndex + 1). 232134 runStopIndex := lastIndex + (runLength - 1) min: line last. 232135 self setStopConditions. 232136 ^ false! ! 232137 232138!MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'! 232139setStopConditions 232140 "Set the font and the stop conditions for the current run." 232141 232142 self setFont. 232143 self setConditionArray: (textStyle alignment = Justified ifTrue: [#paddedSpace]). 232144! ! 232145 232146 232147!MultiCanvasCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:55'! 232148doesDisplaying 232149 ^false "it doesn't do displaying using copyBits"! ! 232150 232151!MultiCanvasCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 232152setFont 232153 foregroundColor ifNil: [foregroundColor := Color black]. 232154 super setFont. 232155 baselineY := lineY + line baseline. 232156 destY := baselineY - font ascent.! ! 232157 232158!MultiCanvasCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 232159textColor: color 232160 foregroundColor := color! ! 232161MultiCharacterScanner subclass: #MultiCharacterBlockScanner 232162 instanceVariableNames: 'characterPoint characterIndex lastCharacter lastCharacterExtent lastSpaceOrTabExtent nextLeftMargin specialWidth' 232163 classVariableNames: '' 232164 poolDictionaries: '' 232165 category: 'Multilingual-Scanning'! 232166 232167!MultiCharacterBlockScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 12:52'! 232168crossedX 232169 "Text display has wrapping. The scanner just found a character past the x 232170 location of the cursor. We know that the cursor is pointing at a character 232171 or before one." 232172 232173 | leadingTab currentX | 232174 characterIndex == nil ifFalse: [ 232175 "If the last character of the last line is a space, 232176 and it crosses the right margin, then locating 232177 the character block after it is impossible without this hack." 232178 characterIndex > text size ifTrue: [ 232179 lastIndex := characterIndex. 232180 characterPoint := (nextLeftMargin ifNil: [leftMargin]) @ (destY + line lineHeight). 232181 ^true]]. 232182 characterPoint x <= (destX + (lastCharacterExtent x // 2)) 232183 ifTrue: [lastCharacter := (text at: lastIndex). 232184 characterPoint := destX @ destY. 232185 ^true]. 232186 lastIndex >= line last 232187 ifTrue: [lastCharacter := (text at: line last). 232188 characterPoint := destX @ destY. 232189 ^true]. 232190 232191 "Pointing past middle of a character, return the next character." 232192 lastIndex := lastIndex + 1. 232193 lastCharacter := text at: lastIndex. 232194 currentX := destX + lastCharacterExtent x + kern. 232195 self lastCharacterExtentSetX: (font widthOf: lastCharacter). 232196 characterPoint := currentX @ destY. 232197 lastCharacter = Space ifFalse: [^ true]. 232198 232199 "Yukky if next character is space or tab." 232200 alignment = Justified ifTrue: 232201 [self lastCharacterExtentSetX: 232202 (lastCharacterExtent x + (line justifiedPadFor: (spaceCount + 1) font: font)). 232203 ^ true]. 232204 232205 true ifTrue: [^ true]. 232206 "NOTE: I find no value to the following code, and so have defeated it - DI" 232207 232208 "See tabForDisplay for illumination on the following awfulness." 232209 leadingTab := true. 232210 line first to: lastIndex - 1 do: 232211 [:index | (text at: index) ~= Tab ifTrue: [leadingTab := false]]. 232212 (alignment ~= Justified or: [leadingTab]) 232213 ifTrue: [self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX 232214 leftMargin: leftMargin rightMargin: rightMargin) - 232215 currentX] 232216 ifFalse: [self lastCharacterExtentSetX: (((currentX + (textStyle tabWidth - 232217 (line justifiedTabDeltaFor: spaceCount))) - 232218 currentX) max: 0)]. 232219 ^ true! ! 232220 232221!MultiCharacterBlockScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 12:52'! 232222paddedSpace 232223 "When the line is justified, the spaces will not be the same as the font's 232224 space character. A padding of extra space must be considered in trying 232225 to find which character the cursor is pointing at. Answer whether the 232226 scanning has crossed the cursor." 232227 232228 | pad | 232229 pad := 0. 232230 spaceCount := spaceCount + 1. 232231 pad := line justifiedPadFor: spaceCount font: font. 232232 lastSpaceOrTabExtent := lastCharacterExtent copy. 232233 self lastSpaceOrTabExtentSetX: spaceWidth + pad. 232234 (destX + lastSpaceOrTabExtent x) >= characterPoint x 232235 ifTrue: [lastCharacterExtent := lastSpaceOrTabExtent copy. 232236 ^self crossedX]. 232237 lastIndex := lastIndex + 1. 232238 destX := destX + lastSpaceOrTabExtent x. 232239 ^ false 232240! ! 232241 232242!MultiCharacterBlockScanner methodsFor: '*FreeType-override' stamp: 'tween 4/2/2007 23:59'! 232243scanMultiCharactersCombiningFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta 232244 232245 | encoding f nextDestX maxAscii startEncoding char charValue floatDestX widthAndKernedWidth nextChar | 232246 lastIndex := startIndex. 232247 lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun]. 232248 startEncoding := (sourceString at: startIndex) leadingChar. 232249 font ifNil: [font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. 232250 ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ 232251 [f := font fontArray at: startEncoding + 1] 232252 on: Exception do: [:ex | f := font fontArray at: 1]. 232253 f ifNil: [ f := font fontArray at: 1]. 232254 maxAscii := f maxAscii. 232255 spaceWidth := f widthOf: Space. 232256 ] ifFalse: [ 232257 maxAscii := font maxAscii. 232258 ]. 232259 floatDestX := destX. 232260 widthAndKernedWidth := Array new: 2. 232261 [lastIndex <= stopIndex] whileTrue: [ 232262 encoding := (sourceString at: lastIndex) leadingChar. 232263 encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^ stops at: EndOfRun]. 232264 char := (sourceString at: lastIndex). 232265 charValue := char charCode. 232266 charValue > maxAscii ifTrue: [charValue := maxAscii]. 232267 (encoding = 0 and: [(stopConditions at: charValue + 1) ~~ nil]) ifTrue: [ 232268 ^ stops at: charValue + 1 232269 ]. 232270 nextChar := (lastIndex + 1 <= stopIndex) 232271 ifTrue:[sourceString at: lastIndex + 1] 232272 ifFalse:[nil]. 232273 font 232274 widthAndKernedWidthOfLeft: ((char isMemberOf: CombinedChar) ifTrue:[char base] ifFalse:[char]) 232275 right: nextChar 232276 into: widthAndKernedWidth. 232277 nextDestX := floatDestX + (widthAndKernedWidth at: 1). 232278 nextDestX > rightX ifTrue: [^ stops at: CrossedX]. 232279 floatDestX := floatDestX + kernDelta + (widthAndKernedWidth at: 2). 232280 destX := floatDestX. 232281 lastIndex := lastIndex + 1. 232282 ]. 232283 lastIndex := stopIndex. 232284 ^ stops at: EndOfRun! ! 232285 232286 232287!MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! 232288characterBlockAtPoint: aPoint in: aParagraph 232289 "Answer a CharacterBlock for character in aParagraph at point aPoint. It 232290 is assumed that aPoint has been transformed into coordinates appropriate 232291 to the text's destination form rectangle and the composition rectangle." 232292 232293 self initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle. 232294 characterPoint := aPoint. 232295 ^self buildCharacterBlockIn: aParagraph! ! 232296 232297!MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'nk 11/22/2004 14:36'! 232298characterBlockAtPoint: aPoint index: index in: textLine 232299 "This method is the Morphic characterBlock finder. It combines 232300 MVC's characterBlockAtPoint:, -ForIndex:, and buildCharcterBlock:in:" 232301 | runLength lineStop done stopCondition | 232302 line := textLine. 232303 rightMargin := line rightMargin. 232304 lastIndex := line first. 232305 self setStopConditions. "also sets font" 232306 characterIndex := index. " == nil means scanning for point" 232307 characterPoint := aPoint. 232308 (characterPoint isNil or: [characterPoint y > line bottom]) 232309 ifTrue: [characterPoint := line bottomRight]. 232310 (text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left]) 232311 or: [characterIndex notNil and: [characterIndex < line first]]]) 232312 ifTrue: [^ (CharacterBlock new stringIndex: line first text: text 232313 topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid) 232314 textLine: line]. 232315 destX := leftMargin := line leftMarginForAlignment: alignment. 232316 destY := line top. 232317 runLength := text runLengthFor: line first. 232318 characterIndex 232319 ifNotNil: [lineStop := characterIndex "scanning for index"] 232320 ifNil: [lineStop := line last "scanning for point"]. 232321 runStopIndex := lastIndex + (runLength - 1) min: lineStop. 232322 lastCharacterExtent := 0 @ line lineHeight. 232323 spaceCount := 0. 232324 232325 done := false. 232326 [done] whileFalse: 232327 [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex 232328 in: text string rightX: characterPoint x 232329 stopConditions: stopConditions kern: kern. 232330 "see setStopConditions for stopping conditions for character block operations." 232331 self lastCharacterExtentSetX: (specialWidth 232332 ifNil: [font widthOf: (text at: lastIndex)] 232333 ifNotNil: [specialWidth]). 232334 (self perform: stopCondition) ifTrue: 232335 [characterIndex 232336 ifNil: [ 232337 "Result for characterBlockAtPoint: " 232338 (stopCondition ~~ #cr and: [ lastIndex == line last 232339 and: [ aPoint x > ((characterPoint x) + (lastCharacterExtent x / 2)) ]]) 232340 ifTrue: [ "Correct for right half of last character in line" 232341 ^ (CharacterBlock new stringIndex: lastIndex + 1 232342 text: text 232343 topLeft: characterPoint + (lastCharacterExtent x @ 0) + (font descentKern @ 0) 232344 extent: 0 @ lastCharacterExtent y) 232345 textLine: line ]. 232346 ^ (CharacterBlock new stringIndex: lastIndex 232347 text: text topLeft: characterPoint + (font descentKern @ 0) 232348 extent: lastCharacterExtent - (font baseKern @ 0)) 232349 textLine: line] 232350 ifNotNil: ["Result for characterBlockForIndex: " 232351 ^ (CharacterBlock new stringIndex: characterIndex 232352 text: text topLeft: characterPoint + ((font descentKern) - kern @ 0) 232353 extent: lastCharacterExtent) 232354 textLine: line]]]! ! 232355 232356!MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! 232357characterBlockForIndex: targetIndex in: aParagraph 232358 "Answer a CharacterBlock for character in aParagraph at targetIndex. The 232359 coordinates in the CharacterBlock will be appropriate to the intersection 232360 of the destination form rectangle and the composition rectangle." 232361 232362 self 232363 initializeFromParagraph: aParagraph 232364 clippedBy: aParagraph clippingRectangle. 232365 characterIndex := targetIndex. 232366 characterPoint := 232367 aParagraph rightMarginForDisplay @ 232368 (aParagraph topAtLineIndex: 232369 (aParagraph lineIndexOfCharacterIndex: characterIndex)). 232370 ^self buildCharacterBlockIn: aParagraph! ! 232371 232372!MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! 232373indentationLevel: anInteger 232374 super indentationLevel: anInteger. 232375 nextLeftMargin := leftMargin. 232376 indentationLevel timesRepeat: [ 232377 nextLeftMargin := textStyle nextTabXFrom: nextLeftMargin 232378 leftMargin: leftMargin 232379 rightMargin: rightMargin]! ! 232380 232381!MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! 232382placeEmbeddedObject: anchoredMorph 232383 "Workaround: The following should really use #textAnchorType" 232384 anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. 232385 (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. 232386 specialWidth := anchoredMorph width. 232387 ^ true! ! 232388 232389 232390!MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 232391cr 232392 "Answer a CharacterBlock that specifies the current location of the mouse 232393 relative to a carriage return stop condition that has just been 232394 encountered. The ParagraphEditor convention is to denote selections by 232395 CharacterBlocks, sometimes including the carriage return (cursor is at 232396 the end) and sometimes not (cursor is in the middle of the text)." 232397 232398 ((characterIndex ~= nil 232399 and: [characterIndex > text size]) 232400 or: [(line last = text size) 232401 and: [(destY + line lineHeight) < characterPoint y]]) 232402 ifTrue: ["When off end of string, give data for next character" 232403 destY := destY + line lineHeight. 232404 baselineY := line lineHeight. 232405 lastCharacter := nil. 232406 characterPoint := (nextLeftMargin ifNil: [leftMargin]) @ destY. 232407 lastIndex := lastIndex + 1. 232408 self lastCharacterExtentSetX: 0. 232409 ^ true]. 232410 lastCharacter := CR. 232411 characterPoint := destX @ destY. 232412 self lastCharacterExtentSetX: rightMargin - destX. 232413 ^true! ! 232414 232415!MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 232416endOfRun 232417 "Before arriving at the cursor location, the selection has encountered an 232418 end of run. Answer false if the selection continues, true otherwise. Set 232419 up indexes for building the appropriate CharacterBlock." 232420 232421 | runLength lineStop | 232422 (((characterIndex ~~ nil and: 232423 [runStopIndex < characterIndex and: [runStopIndex < text size]]) 232424 or: [characterIndex == nil and: [lastIndex < line last]]) or: [ 232425 ((lastIndex < line last) 232426 and: [((text at: lastIndex) leadingChar ~= (text at: lastIndex+1) leadingChar) 232427 and: [lastIndex ~= characterIndex]])]) 232428 ifTrue: ["We're really at the end of a real run." 232429 runLength := (text runLengthFor: (lastIndex := lastIndex + 1)). 232430 characterIndex ~~ nil 232431 ifTrue: [lineStop := characterIndex "scanning for index"] 232432 ifFalse: [lineStop := line last "scanning for point"]. 232433 (runStopIndex := lastIndex + (runLength - 1)) > lineStop 232434 ifTrue: [runStopIndex := lineStop]. 232435 self setStopConditions. 232436 ^false]. 232437 232438 lastCharacter := text at: lastIndex. 232439 characterPoint := destX @ destY. 232440 ((lastCharacter = Space and: [alignment = Justified]) 232441 or: [lastCharacter = Tab and: [lastSpaceOrTabExtent notNil]]) 232442 ifTrue: [lastCharacterExtent := lastSpaceOrTabExtent]. 232443 characterIndex ~~ nil 232444 ifTrue: ["If scanning for an index and we've stopped on that index, 232445 then we back destX off by the width of the character stopped on 232446 (it will be pointing at the right side of the character) and return" 232447 runStopIndex = characterIndex 232448 ifTrue: [self characterPointSetX: destX - lastCharacterExtent x. 232449 ^true]. 232450 "Otherwise the requested index was greater than the length of the 232451 string. Return string size + 1 as index, indicate further that off the 232452 string by setting character to nil and the extent to 0." 232453 lastIndex := lastIndex + 1. 232454 lastCharacter := nil. 232455 self lastCharacterExtentSetX: 0. 232456 ^true]. 232457 232458 "Scanning for a point and either off the end of the line or off the end of the string." 232459 runStopIndex = text size 232460 ifTrue: ["off end of string" 232461 lastIndex := lastIndex + 1. 232462 lastCharacter := nil. 232463 self lastCharacterExtentSetX: 0. 232464 ^true]. 232465 "just off end of line without crossing x" 232466 lastIndex := lastIndex + 1. 232467 ^true! ! 232468 232469!MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 232470setFont 232471 specialWidth := nil. 232472 super setFont! ! 232473 232474!MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 10/18/2004 14:31'! 232475setStopConditions 232476 "Set the font and the stop conditions for the current run." 232477 232478 self setFont. 232479 self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]). 232480! ! 232481 232482!MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 232483tab 232484 | currentX | 232485 currentX := (alignment == Justified and: [self leadingTab not]) 232486 ifTrue: "imbedded tabs in justified text are weird" 232487 [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] 232488 ifFalse: 232489 [textStyle 232490 nextTabXFrom: destX 232491 leftMargin: leftMargin 232492 rightMargin: rightMargin]. 232493 lastSpaceOrTabExtent := lastCharacterExtent copy. 232494 self lastSpaceOrTabExtentSetX: (currentX - destX max: 0). 232495 currentX >= characterPoint x 232496 ifTrue: 232497 [lastCharacterExtent := lastSpaceOrTabExtent copy. 232498 ^ self crossedX]. 232499 destX := currentX. 232500 lastIndex := lastIndex + 1. 232501 ^false! ! 232502 232503 232504!MultiCharacterBlockScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 232505buildCharacterBlockIn: para 232506 | lineIndex runLength lineStop done stopCondition | 232507 "handle nullText" 232508 (para numberOfLines = 0 or: [text size = 0]) 232509 ifTrue: [^ CharacterBlock new stringIndex: 1 "like being off end of string" 232510 text: para text 232511 topLeft: (para leftMarginForDisplayForLine: 1 alignment: (alignment ifNil:[textStyle alignment])) 232512 @ para compositionRectangle top 232513 extent: 0 @ textStyle lineGrid]. 232514 "find the line" 232515 lineIndex := para lineIndexOfTop: characterPoint y. 232516 destY := para topAtLineIndex: lineIndex. 232517 line := para lines at: lineIndex. 232518 rightMargin := para rightMarginForDisplay. 232519 232520 (lineIndex = para numberOfLines and: 232521 [(destY + line lineHeight) < characterPoint y]) 232522 ifTrue: ["if beyond lastLine, force search to last character" 232523 self characterPointSetX: rightMargin] 232524 ifFalse: [characterPoint y < (para compositionRectangle) top 232525 ifTrue: ["force search to first line" 232526 characterPoint := (para compositionRectangle) topLeft]. 232527 characterPoint x > rightMargin 232528 ifTrue: [self characterPointSetX: rightMargin]]. 232529 destX := (leftMargin := para leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment])). 232530 nextLeftMargin:= para leftMarginForDisplayForLine: lineIndex+1 alignment: (alignment ifNil:[textStyle alignment]). 232531 lastIndex := line first. 232532 232533 self setStopConditions. "also sets font" 232534 runLength := (text runLengthFor: line first). 232535 characterIndex == nil 232536 ifTrue: [lineStop := line last "characterBlockAtPoint"] 232537 ifFalse: [lineStop := characterIndex "characterBlockForIndex"]. 232538 (runStopIndex := lastIndex + (runLength - 1)) > lineStop 232539 ifTrue: [runStopIndex := lineStop]. 232540 lastCharacterExtent := 0 @ line lineHeight. 232541 spaceCount := 0. done := false. 232542 self handleIndentation. 232543 232544 [done] 232545 whileFalse: 232546 [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex 232547 in: text string rightX: characterPoint x 232548 stopConditions: stopConditions kern: kern. 232549 232550 "see setStopConditions for stopping conditions for character block operations." 232551 self lastCharacterExtentSetX: (font widthOf: (text at: lastIndex)). 232552 (self perform: stopCondition) ifTrue: 232553 [characterIndex == nil 232554 ifTrue: ["characterBlockAtPoint" 232555 ^ CharacterBlock new stringIndex: lastIndex text: text 232556 topLeft: characterPoint + (font descentKern @ 0) 232557 extent: lastCharacterExtent] 232558 ifFalse: ["characterBlockForIndex" 232559 ^ CharacterBlock new stringIndex: lastIndex text: text 232560 topLeft: characterPoint + ((font descentKern) - kern @ 0) 232561 extent: lastCharacterExtent]]]! ! 232562 232563!MultiCharacterBlockScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 232564characterPointSetX: xVal 232565 characterPoint := xVal @ characterPoint y! ! 232566 232567!MultiCharacterBlockScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 232568lastCharacterExtentSetX: xVal 232569 lastCharacterExtent := xVal @ lastCharacterExtent y! ! 232570 232571!MultiCharacterBlockScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 232572lastSpaceOrTabExtentSetX: xVal 232573 lastSpaceOrTabExtent := xVal @ lastSpaceOrTabExtent y! ! 232574Object subclass: #MultiCharacterScanner 232575 instanceVariableNames: 'destX lastIndex xTable destY stopConditions text textStyle alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern indentationLevel wantsColumnBreaks presentation presentationLine numOfComposition baselineY firstDestX pendingKernX' 232576 classVariableNames: 'DefaultStopConditions NilCondition PaddedSpaceCondition SpaceCondition' 232577 poolDictionaries: 'TextConstants' 232578 category: 'Multilingual-Scanning'! 232579 232580!MultiCharacterScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 10:11'! 232581basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta 232582 "Primitive. This is the inner loop of text display--but see 232583 scanCharactersFrom: to:rightX: which would get the string, 232584 stopConditions and displaying from the instance. March through source 232585 String from startIndex to stopIndex. If any character is flagged with a 232586 non-nil entry in stops, then return the corresponding value. Determine 232587 width of each character from xTable, indexed by map. 232588 If dextX would exceed rightX, then return stops at: 258. 232589 Advance destX by the width of the character. If stopIndex has been 232590 reached, then return stops at: 257. Optional. 232591 See Object documentation whatIsAPrimitive." 232592 | ascii nextDestX char floatDestX widthAndKernedWidth nextChar atEndOfRun | 232593 <primitive: 103> 232594 lastIndex := startIndex. 232595 floatDestX := destX. 232596 widthAndKernedWidth := Array new: 2. 232597 atEndOfRun := false. 232598 [lastIndex <= stopIndex] 232599 whileTrue: 232600 [char := (sourceString at: lastIndex). 232601 ascii := char asciiValue + 1. 232602 (stops at: ascii) == nil ifFalse: [^stops at: ascii]. 232603 "Note: The following is querying the font about the width 232604 since the primitive may have failed due to a non-trivial 232605 mapping of characters to glyphs or a non-existing xTable." 232606 nextChar := (lastIndex + 1 <= stopIndex) 232607 ifTrue:[sourceString at: lastIndex + 1] 232608 ifFalse:[ 232609 atEndOfRun := true. 232610 "if there is a next char in sourceString, then get the kern 232611 and store it in pendingKernX" 232612 lastIndex + 1 <= sourceString size 232613 ifTrue:[sourceString at: lastIndex + 1] 232614 ifFalse:[ nil]]. 232615 font 232616 widthAndKernedWidthOfLeft: char 232617 right: nextChar 232618 into: widthAndKernedWidth. 232619 nextDestX := floatDestX + (widthAndKernedWidth at: 1). 232620 nextDestX > rightX ifTrue: [^stops at: CrossedX]. 232621 floatDestX := floatDestX + kernDelta + (widthAndKernedWidth at: 2). 232622 atEndOfRun 232623 ifTrue:[ 232624 pendingKernX := (widthAndKernedWidth at: 2) - (widthAndKernedWidth at: 1). 232625 floatDestX := floatDestX - pendingKernX]. 232626 destX := floatDestX. 232627 lastIndex := lastIndex + 1]. 232628 lastIndex := stopIndex. 232629 ^stops at: EndOfRun! ! 232630 232631!MultiCharacterScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 11:17'! 232632columnBreak 232633 232634 pendingKernX := 0. 232635 ^true! ! 232636 232637!MultiCharacterScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 10:56'! 232638plainTab 232639 "This is the basic method of adjusting destX for a tab." 232640 destX := (alignment == Justified and: [self leadingTab not]) 232641 ifTrue: "embedded tabs in justified text are weird" 232642 [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] 232643 ifFalse: 232644 [textStyle nextTabXFrom: destX 232645 leftMargin: leftMargin 232646 rightMargin: rightMargin]. 232647 pendingKernX := 0.! ! 232648 232649!MultiCharacterScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 10:14'! 232650scanMultiCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta 232651 232652 | ascii encoding f nextDestX maxAscii startEncoding floatDestX widthAndKernedWidth nextChar atEndOfRun | 232653 lastIndex := startIndex. 232654 lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun]. 232655 startEncoding := (sourceString at: startIndex) leadingChar. 232656 font ifNil: [font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. 232657 ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ 232658 [f := font fontArray at: startEncoding + 1] 232659 on: Exception do: [:ex | f := font fontArray at: 1]. 232660 f ifNil: [ f := font fontArray at: 1]. 232661 maxAscii := f maxAscii. 232662 spaceWidth := f widthOf: Space. 232663 ] ifFalse: [ 232664 maxAscii := font maxAscii. 232665 ]. 232666 floatDestX := destX. 232667 widthAndKernedWidth := Array new: 2. 232668 atEndOfRun := false. 232669 [lastIndex <= stopIndex] whileTrue: [ 232670 encoding := (sourceString at: lastIndex) leadingChar. 232671 encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^ stops at: EndOfRun]. 232672 ascii := (sourceString at: lastIndex) charCode. 232673 ascii > maxAscii ifTrue: [ascii := maxAscii]. 232674 (encoding = 0 and: [ascii < stopConditions size and: [(stopConditions at: ascii + 1) ~~ nil]]) ifTrue: [^ stops at: ascii + 1]. 232675 (self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [ 232676 self registerBreakableIndex. 232677 ]. 232678 nextChar := (lastIndex + 1 <= stopIndex) 232679 ifTrue:[sourceString at: lastIndex + 1] 232680 ifFalse:[ 232681 atEndOfRun := true. 232682 "if there is a next char in sourceString, then get the kern 232683 and store it in pendingKernX" 232684 lastIndex + 1 <= sourceString size 232685 ifTrue:[sourceString at: lastIndex + 1] 232686 ifFalse:[ nil]]. 232687 font 232688 widthAndKernedWidthOfLeft: (sourceString at: lastIndex) 232689 right: nextChar 232690 into: widthAndKernedWidth. 232691 nextDestX := floatDestX + (widthAndKernedWidth at: 1). 232692 nextDestX > rightX ifTrue: [destX ~= firstDestX ifTrue: [^stops at: CrossedX]]. 232693 floatDestX := floatDestX + kernDelta + (widthAndKernedWidth at: 2). 232694 atEndOfRun 232695 ifTrue:[ 232696 pendingKernX := (widthAndKernedWidth at: 2) - (widthAndKernedWidth at: 1). 232697 floatDestX := floatDestX - pendingKernX]. 232698 destX := floatDestX . 232699 lastIndex := lastIndex + 1. 232700 ]. 232701 lastIndex := stopIndex. 232702 ^ stops at: EndOfRun! ! 232703 232704!MultiCharacterScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 10:16'! 232705setFont 232706 | priorFont | 232707 "Set the font and other emphasis." 232708 priorFont := font. 232709 text == nil ifFalse:[ 232710 emphasisCode := 0. 232711 kern := 0. 232712 indentationLevel := 0. 232713 alignment := textStyle alignment. 232714 font := nil. 232715 (text attributesAt: lastIndex forStyle: textStyle) 232716 do: [:att | att emphasizeScanner: self]]. 232717 font == nil ifTrue: 232718 [self setFont: textStyle defaultFontIndex]. 232719 font := font emphasized: emphasisCode. 232720 priorFont 232721 ifNotNil: [ 232722 font = priorFont 232723 ifTrue:[ 232724 "font is the same, perhaps the color has changed? 232725 We still want kerning between chars of the same 232726 font, but of different color. So add any pending kern to destX" 232727 destX := destX + (pendingKernX ifNil:[0])]. 232728 destX := destX + priorFont descentKern]. 232729 pendingKernX := 0. "clear any pending kern so there is no danger of it being added twice" 232730 destX := destX - font descentKern. 232731 "NOTE: next statement should be removed when clipping works" 232732 leftMargin ifNotNil: [destX := destX max: leftMargin]. 232733 kern := kern - font baseKern. 232734 232735 "Install various parameters from the font." 232736 spaceWidth := font widthOf: Space. 232737 xTable := font xTable. 232738" map := font characterToGlyphMap." 232739 stopConditions := DefaultStopConditions.! ! 232740 232741 232742!MultiCharacterScanner methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 10:11'! 232743initialize 232744 super initialize. 232745 destX := destY := leftMargin := 0.! ! 232746 232747!MultiCharacterScanner methodsFor: 'initialize' stamp: 'sd 2/4/2008 21:22'! 232748initializeStringMeasurer 232749 stopConditions := Array new: 258. 232750 stopConditions at: CrossedX put: #crossedX. 232751 stopConditions at: EndOfRun put: #endOfRun. 232752! ! 232753 232754!MultiCharacterScanner methodsFor: 'initialize' stamp: 'sd 2/4/2008 21:22'! 232755wantsColumnBreaks: aBoolean 232756 232757 wantsColumnBreaks := aBoolean! ! 232758 232759 232760!MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/3/2003 12:09'! 232761addCharToPresentation: char 232762 232763! ! 232764 232765!MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'yo 12/20/2002 16:15'! 232766registerBreakableIndex 232767 232768 "Record left x and character index of the line-wrappable point. 232769 The default implementation here does nothing." 232770 232771 ^ false. 232772! ! 232773 232774!MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/23/2003 14:25'! 232775removeLastCharFromPresentation 232776! ! 232777 232778!MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/1/2003 10:43'! 232779widthOf: char inFont: aFont 232780 232781 (char isMemberOf: CombinedChar) ifTrue: [ 232782 ^ aFont widthOf: char base. 232783 ] ifFalse: [ 232784 ^ aFont widthOf: char. 232785 ]. 232786 232787 232788! ! 232789 232790 232791!MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/30/2002 22:59'! 232792combinableChar: char for: prevEntity 232793 232794! ! 232795 232796!MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/20/2002 11:46'! 232797isBreakableAt: index in: sourceString in: encodingClass 232798 232799 ^ encodingClass isBreakableAt: index in: sourceString. 232800! ! 232801 232802!MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'sd 2/4/2008 21:22'! 232803scanJapaneseCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta 232804 232805 | ascii encoding f nextDestX maxAscii startEncoding | 232806 lastIndex := startIndex. 232807 lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun]. 232808 startEncoding := (sourceString at: startIndex) leadingChar. 232809 font ifNil: [font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. 232810 ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ 232811 [f := font fontArray at: startEncoding + 1] 232812 on: Exception do: [:ex | f := font fontArray at: 1]. 232813 f ifNil: [ f := font fontArray at: 1]. 232814 maxAscii := f maxAscii. 232815 "xTable := f xTable. 232816 maxAscii := xTable size - 2." 232817 spaceWidth := f widthOf: Space. 232818 ] ifFalse: [ 232819 (font isMemberOf: HostFont) ifTrue: [ 232820 f := font. 232821 maxAscii := f maxAscii. 232822 spaceWidth := f widthOf: Space. 232823 ] ifFalse: [ 232824 maxAscii := font maxAscii. 232825 ]. 232826 ]. 232827 [lastIndex <= stopIndex] whileTrue: [ 232828 "self halt." 232829 encoding := (sourceString at: lastIndex) leadingChar. 232830 encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^ stops at: EndOfRun]. 232831 ascii := (sourceString at: lastIndex) charCode. 232832 ascii > maxAscii ifTrue: [ascii := maxAscii]. 232833 (encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1]. 232834 (self isBreakableAt: lastIndex in: sourceString in: (EncodedCharSet charsetAt: encoding)) ifTrue: [ 232835 self registerBreakableIndex. 232836 ]. 232837 nextDestX := destX + (font widthOf: (sourceString at: lastIndex)). 232838 nextDestX > rightX ifTrue: [firstDestX ~= destX ifTrue: [^ stops at: CrossedX]]. 232839 destX := nextDestX + kernDelta. 232840 lastIndex := lastIndex + 1. 232841 ]. 232842 lastIndex := stopIndex. 232843 ^ stops at: EndOfRun! ! 232844 232845!MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'sd 2/4/2008 21:22'! 232846scanMultiCharactersCombiningFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta 232847 232848 | charCode encoding f maxAscii startEncoding combining combined combiningIndex c | 232849 lastIndex := startIndex. 232850 lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun]. 232851 startEncoding := (sourceString at: startIndex) leadingChar. 232852 font ifNil: [font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. 232853 ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ 232854 [f := font fontArray at: startEncoding + 1] 232855 on: Exception do: [:ex | f := font fontArray at: 1]. 232856 f ifNil: [ f := font fontArray at: 1]. 232857 maxAscii := f maxAscii. 232858 spaceWidth := font widthOf: Space. 232859 ] ifFalse: [ 232860 maxAscii := font maxAscii. 232861 spaceWidth := font widthOf: Space. 232862 ]. 232863 232864 combining := nil. 232865 [lastIndex <= stopIndex] whileTrue: [ 232866 charCode := (sourceString at: lastIndex) charCode. 232867 c := (sourceString at: lastIndex). 232868 combining ifNil: [ 232869 combining := CombinedChar new. 232870 combining add: c. 232871 combiningIndex := lastIndex. 232872 lastIndex := lastIndex + 1. 232873 ] ifNotNil: [ 232874 (combining add: c) ifFalse: [ 232875 self addCharToPresentation: (combined := combining combined). 232876 combining := CombinedChar new. 232877 combining add: c. 232878 charCode := combined charCode. 232879 encoding := combined leadingChar. 232880 encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. 232881 (encoding = 0 and: [(stopConditions at: charCode + 1) ~~ nil]) ifTrue: [ 232882 ^ stops at: charCode + 1 232883 ] ifFalse: [ 232884 ^ stops at: EndOfRun 232885 ]. 232886 ]. 232887 charCode > maxAscii ifTrue: [charCode := maxAscii]. 232888 "" 232889 (encoding = 0 and: [(stopConditions at: charCode + 1) ~~ nil]) ifTrue: [ 232890 combining ifNotNil: [ 232891 self addCharToPresentation: (combining combined). 232892 ]. 232893 ^ stops at: charCode + 1 232894 ]. 232895 (self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [ 232896 self registerBreakableIndex. 232897 ]. 232898 destX > rightX ifTrue: [ 232899 destX ~= firstDestX ifTrue: [ 232900 lastIndex := combiningIndex. 232901 self removeLastCharFromPresentation. 232902 ^ stops at: CrossedX]]. 232903 combiningIndex := lastIndex. 232904 lastIndex := lastIndex + 1. 232905 ] ifTrue: [ 232906 lastIndex := lastIndex + 1. 232907 numOfComposition := numOfComposition + 1. 232908 ]. 232909 ]. 232910 ]. 232911 lastIndex := stopIndex. 232912 combining ifNotNil: [ 232913 combined := combining combined. 232914 self addCharToPresentation: combined. 232915 "assuming that there is always enough space for at least one character". 232916 destX := destX + (self widthOf: combined inFont: font). 232917 ]. 232918 ^ stops at: EndOfRun! ! 232919 232920!MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'sd 2/4/2008 21:22'! 232921scanMultiCharactersR2LFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta 232922 232923 "Note that 'rightX' really means 'endX' in R2L context. Ie. rightX is usually smaller than destX." 232924 | ascii encoding f nextDestX maxAscii startEncoding | 232925 lastIndex := startIndex. 232926 lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun]. 232927 startEncoding := (sourceString at: startIndex) leadingChar. 232928 font ifNil: [font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. 232929 ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ 232930 [f := font fontArray at: startEncoding + 1] 232931 on: Exception do: [:ex | f := font fontArray at: 1]. 232932 f ifNil: [ f := font fontArray at: 1]. 232933 maxAscii := f maxAscii. 232934 spaceWidth := f widthOf: Space. 232935 ] ifFalse: [ 232936 maxAscii := font maxAscii. 232937 ]. 232938 232939 [lastIndex <= stopIndex] whileTrue: [ 232940 encoding := (sourceString at: lastIndex) leadingChar. 232941 encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^ stops at: EndOfRun]. 232942 ascii := (sourceString at: lastIndex) charCode. 232943 ascii > maxAscii ifTrue: [ascii := maxAscii]. 232944 (encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1]. 232945 (self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [ 232946 self registerBreakableIndex. 232947 ]. 232948 nextDestX := destX - (font widthOf: (sourceString at: lastIndex)). 232949 nextDestX < rightX ifTrue: [^ stops at: CrossedX]. 232950 destX := nextDestX - kernDelta. 232951 lastIndex := lastIndex + 1. 232952 ]. 232953 lastIndex := stopIndex. 232954 ^ stops at: EndOfRun! ! 232955 232956 232957!MultiCharacterScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! 232958embeddedObject 232959 | savedIndex | 232960 savedIndex := lastIndex. 232961 text attributesAt: lastIndex do:[:attr| 232962 attr anchoredMorph ifNotNil:[ 232963 "Following may look strange but logic gets reversed. 232964 If the morph fits on this line we're not done (return false for true) 232965 and if the morph won't fit we're done (return true for false)" 232966 (self placeEmbeddedObject: attr anchoredMorph) ifFalse:[^true]]]. 232967 lastIndex := savedIndex + 1. "for multiple(!!) embedded morphs" 232968 ^false! ! 232969 232970!MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! 232971handleIndentation 232972 self indentationLevel timesRepeat: [ 232973 self plainTab]! ! 232974 232975!MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! 232976indentationLevel 232977 "return the number of tabs that are currently being placed at the beginning of each line" 232978 ^indentationLevel ifNil:[0]! ! 232979 232980!MultiCharacterScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! 232981indentationLevel: anInteger 232982 "set the number of tabs to put at the beginning of each line" 232983 indentationLevel := anInteger! ! 232984 232985!MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! 232986leadingTab 232987 "return true if only tabs lie to the left" 232988 line first to: lastIndex do: 232989 [:i | (text at: i) == Tab ifFalse: [^ false]]. 232990 ^ true! ! 232991 232992!MultiCharacterScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! 232993measureString: aString inFont: aFont from: startIndex to: stopIndex 232994 "WARNING: In order to use this method the receiver has to be set up using #initializeStringMeasurer" 232995 destX := destY := lastIndex := 0. 232996 baselineY := aFont ascent. 232997 xTable := aFont xTable. 232998 font := aFont. " added Dec 03, 2004 " 232999" map := aFont characterToGlyphMap." 233000 self scanCharactersFrom: startIndex to: stopIndex in: aString rightX: 999999 stopConditions: stopConditions kern: 0. 233001 ^destX! ! 233002 233003!MultiCharacterScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! 233004placeEmbeddedObject: anchoredMorph 233005 "Place the anchoredMorph or return false if it cannot be placed. 233006 In any event, advance destX by its width." 233007 | w | 233008 "Workaround: The following should really use #textAnchorType" 233009 anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. 233010 destX := destX + (w := anchoredMorph width). 233011 (destX > rightMargin and: [(leftMargin + w) <= rightMargin]) 233012 ifTrue: ["Won't fit, but would on next line" 233013 ^ false]. 233014 lastIndex := lastIndex + 1. 233015 self setFont. "Force recalculation of emphasis for next run" 233016 ^ true! ! 233017 233018!MultiCharacterScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! 233019scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta 233020 233021 | startEncoding selector | 233022 (sourceString isByteString) ifTrue: [^ self basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta.]. 233023 233024 (sourceString isWideString) ifTrue: [ 233025 startIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun]. 233026 startEncoding := (sourceString at: startIndex) leadingChar. 233027 selector := (EncodedCharSet charsetAt: startEncoding) scanSelector. 233028 ^ self perform: selector withArguments: (Array with: startIndex with: stopIndex with: sourceString with: rightX with: stopConditions with: kernDelta). 233029 ]. 233030 233031 ^ stops at: EndOfRun 233032! ! 233033 233034 233035!MultiCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 233036addEmphasis: code 233037 "Set the bold-ital-under-strike emphasis." 233038 emphasisCode := emphasisCode bitOr: code! ! 233039 233040!MultiCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 233041addKern: kernDelta 233042 "Set the current kern amount." 233043 kern := kern + kernDelta! ! 233044 233045!MultiCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 233046initializeFromParagraph: aParagraph clippedBy: clippingRectangle 233047 233048 text := aParagraph text. 233049 textStyle := aParagraph textStyle. 233050! ! 233051 233052!MultiCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 233053setActualFont: aFont 233054 "Set the basal font to an isolated font reference." 233055 233056 font := aFont! ! 233057 233058!MultiCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 233059setAlignment: style 233060 alignment := style. 233061 ! ! 233062 233063!MultiCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 233064setConditionArray: aSymbol 233065 233066 aSymbol == #paddedSpace ifTrue: [^stopConditions := PaddedSpaceCondition "copy"]. 233067 "aSymbol == #space ifTrue: [^stopConditions := SpaceCondition copy]." 233068 aSymbol == nil ifTrue: [^stopConditions := NilCondition "copy"]. 233069 self error: 'undefined stopcondition for space character'. 233070! ! 233071 233072!MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'! 233073setFont: fontNumber 233074 "Set the font by number from the textStyle." 233075 233076 self setActualFont: (textStyle fontAt: fontNumber)! ! 233077 233078!MultiCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 233079text: t textStyle: ts 233080 text := t. 233081 textStyle := ts! ! 233082 233083!MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'! 233084textColor: ignored 233085 "Overridden in DisplayScanner"! ! 233086 233087"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 233088 233089MultiCharacterScanner class 233090 instanceVariableNames: ''! 233091 233092!MultiCharacterScanner class methodsFor: 'initialization' stamp: 'sd 2/4/2008 21:22'! 233093initialize 233094" 233095 MultiCharacterScanner initialize 233096" 233097 | a | 233098 a := Array new: 258. 233099 a at: 1 + 1 put: #embeddedObject. 233100 a at: Tab asciiValue + 1 put: #tab. 233101 a at: CR asciiValue + 1 put: #cr. 233102 a at: EndOfRun put: #endOfRun. 233103 a at: CrossedX put: #crossedX. 233104 NilCondition := a copy. 233105 DefaultStopConditions := a copy. 233106 233107 PaddedSpaceCondition := a copy. 233108 PaddedSpaceCondition at: Space asciiValue + 1 put: #paddedSpace. 233109 233110 SpaceCondition := a copy. 233111 SpaceCondition at: Space asciiValue + 1 put: #space. 233112! ! 233113MultiCharacterScanner subclass: #MultiCompositionScanner 233114 instanceVariableNames: 'spaceX lineHeight baseline breakableIndex lineHeightAtBreak baselineAtBreak breakAtSpace lastWidth' 233115 classVariableNames: '' 233116 poolDictionaries: '' 233117 category: 'Multilingual-Scanning'! 233118 233119!MultiCompositionScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 11:11'! 233120columnBreak 233121 233122 "Answer true. Set up values for the text line interval currently being 233123 composed." 233124 233125 pendingKernX := 0. 233126 line stop: lastIndex. 233127 presentationLine stop: lastIndex - numOfComposition. 233128 spaceX := destX. 233129 line paddingWidth: rightMargin - spaceX. 233130 presentationLine paddingWidth: rightMargin - spaceX. 233131 ^true! ! 233132 233133!MultiCompositionScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 11:11'! 233134cr 233135 "Answer true. Set up values for the text line interval currently being 233136 composed." 233137 233138 pendingKernX := 0. 233139 line stop: lastIndex. 233140 presentationLine stop: lastIndex - numOfComposition. 233141 spaceX := destX. 233142 line paddingWidth: rightMargin - spaceX. 233143 presentationLine paddingWidth: rightMargin - spaceX. 233144 ^true! ! 233145 233146!MultiCompositionScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 11:21'! 233147crossedX 233148 "There is a word that has fallen across the right edge of the composition 233149 rectangle. This signals the need for wrapping which is done to the last 233150 space that was encountered, as recorded by the space stop condition." 233151 233152 pendingKernX := 0. 233153 (breakAtSpace) ifTrue: [ 233154 spaceCount >= 1 ifTrue: 233155 ["The common case. First back off to the space at which we wrap." 233156 line stop: breakableIndex. 233157 presentationLine stop: breakableIndex - numOfComposition. 233158 lineHeight := lineHeightAtBreak. 233159 baseline := baselineAtBreak. 233160 spaceCount := spaceCount - 1. 233161 breakableIndex := breakableIndex - 1. 233162 233163 "Check to see if any spaces preceding the one at which we wrap. 233164 Double space after punctuation, most likely." 233165 [(spaceCount > 1 and: [(text at: breakableIndex) = Space])] 233166 whileTrue: 233167 [spaceCount := spaceCount - 1. 233168 "Account for backing over a run which might 233169 change width of space." 233170 font := text fontAt: breakableIndex withStyle: textStyle. 233171 breakableIndex := breakableIndex - 1. 233172 spaceX := spaceX - (font widthOf: Space)]. 233173 line paddingWidth: rightMargin - spaceX. 233174 presentationLine paddingWidth: rightMargin - spaceX. 233175 presentationLine internalSpaces: spaceCount. 233176 line internalSpaces: spaceCount] 233177 ifFalse: 233178 ["Neither internal nor trailing spaces -- almost never happens." 233179 lastIndex := lastIndex - 1. 233180 [destX <= rightMargin] 233181 whileFalse: 233182 [destX := destX - (font widthOf: (text at: lastIndex)). 233183 lastIndex := lastIndex - 1]. 233184 spaceX := destX. 233185 line paddingWidth: rightMargin - destX. 233186 presentationLine paddingWidth: rightMargin - destX. 233187 presentationLine stop: (lastIndex max: line first). 233188 line stop: (lastIndex max: line first)]. 233189 ^true 233190 ]. 233191 233192 (breakableIndex isNil or: [breakableIndex < line first]) ifTrue: [ 233193 "Any breakable point in this line. Just wrap last character." 233194 breakableIndex := lastIndex - 1. 233195 lineHeightAtBreak := lineHeight. 233196 baselineAtBreak := baseline. 233197 ]. 233198 233199 "It wasn't a space, but anyway this is where we break the line." 233200 line stop: breakableIndex. 233201 presentationLine stop: breakableIndex. 233202 lineHeight := lineHeightAtBreak. 233203 baseline := baselineAtBreak. 233204 ^ true. 233205! ! 233206 233207!MultiCompositionScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 11:12'! 233208tab 233209 "Advance destination x according to tab settings in the paragraph's 233210 textStyle. Answer whether the character has crossed the right edge of 233211 the composition rectangle of the paragraph." 233212 233213 pendingKernX := 0. 233214 destX := textStyle 233215 nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin. 233216 destX > rightMargin ifTrue: [^self crossedX]. 233217 lastIndex := lastIndex + 1. 233218 ^false 233219! ! 233220 233221 233222!MultiCompositionScanner methodsFor: 'accessing' stamp: 'yo 1/3/2003 02:33'! 233223presentation 233224 233225 ^ presentation. 233226! ! 233227 233228!MultiCompositionScanner methodsFor: 'accessing' stamp: 'yo 1/3/2003 02:33'! 233229presentationLine 233230 233231 ^ presentationLine. 233232! ! 233233 233234!MultiCompositionScanner methodsFor: 'accessing' stamp: 'yo 12/18/2002 14:56'! 233235rightX 233236 "Meaningful only when a line has just been composed -- refers to the 233237 line most recently composed. This is a subtrefuge to allow for easy 233238 resizing of a composition rectangle to the width of the maximum line. 233239 Useful only when there is only one line in the form or when each line 233240 is terminated by a carriage return. Handy for sizing menus and lists." 233241 233242 breakAtSpace ifTrue: [^ spaceX]. 233243 233244 ^ destX. 233245! ! 233246 233247 233248!MultiCompositionScanner methodsFor: 'intialize-release' stamp: 'yo 12/18/2002 13:57'! 233249forParagraph: aParagraph 233250 "Initialize the receiver for scanning the given paragraph." 233251 233252 self 233253 initializeFromParagraph: aParagraph 233254 clippedBy: aParagraph clippingRectangle. 233255! ! 233256 233257 233258!MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'sd 2/4/2008 21:22'! 233259addCharToPresentation: char 233260 233261 presentation nextPut: char. 233262 lastWidth := self widthOf: char inFont: font. 233263 destX := destX + lastWidth. 233264! ! 233265 233266!MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/16/2003 17:38'! 233267getPresentation 233268 233269 ^ presentation contents. 233270 233271! ! 233272 233273!MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/16/2003 17:28'! 233274getPresentationLine 233275 233276 ^ presentationLine. 233277! ! 233278 233279!MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'sd 2/4/2008 21:22'! 233280registerBreakableIndex 233281 233282 "Record left x and character index of the line-wrappable point. 233283 Used for wrap-around. Answer whether the character has crossed the 233284 right edge of the composition rectangle of the paragraph." 233285 233286 (text at: lastIndex) = Character space ifTrue: [ 233287 breakAtSpace := true. 233288 spaceX := destX. 233289 spaceCount := spaceCount + 1. 233290 lineHeightAtBreak := lineHeight. 233291 baselineAtBreak := baseline. 233292 breakableIndex := lastIndex. 233293 destX > rightMargin ifTrue: [^self crossedX]. 233294 ] ifFalse: [ 233295 breakAtSpace := false. 233296 lineHeightAtBreak := lineHeight. 233297 baselineAtBreak := baseline. 233298 breakableIndex := lastIndex - 1. 233299 ]. 233300 ^ false. 233301! ! 233302 233303!MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'sd 2/4/2008 21:22'! 233304removeLastCharFromPresentation 233305 233306 presentation ifNotNil: [ 233307 presentation position: presentation position - 1. 233308 ]. 233309 destX := destX - lastWidth. 233310! ! 233311 233312 233313!MultiCompositionScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! 233314composeFrom: startIndex inRectangle: lineRectangle 233315 firstLine: firstLine leftSide: leftSide rightSide: rightSide 233316 "Answer an instance of TextLineInterval that represents the next line in the paragraph." 233317 | runLength done stopCondition | 233318 "Set up margins" 233319 leftMargin := lineRectangle left. 233320 leftSide ifTrue: [leftMargin := leftMargin + 233321 (firstLine ifTrue: [textStyle firstIndent] 233322 ifFalse: [textStyle restIndent])]. 233323 destX := spaceX := leftMargin. 233324 firstDestX := destX. 233325 rightMargin := lineRectangle right. 233326 rightSide ifTrue: [rightMargin := rightMargin - textStyle rightIndent]. 233327 lastIndex := startIndex. "scanning sets last index" 233328 destY := lineRectangle top. 233329 lineHeight := baseline := 0. "Will be increased by setFont" 233330 self setStopConditions. "also sets font" 233331 runLength := text runLengthFor: startIndex. 233332 runStopIndex := (lastIndex := startIndex) + (runLength - 1). 233333 line := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) 233334 rectangle: lineRectangle. 233335 presentationLine := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) 233336 rectangle: lineRectangle. 233337 numOfComposition := 0. 233338 spaceCount := 0. 233339 self handleIndentation. 233340 leftMargin := destX. 233341 line leftMargin: leftMargin. 233342 presentationLine leftMargin: leftMargin. 233343 233344 presentation := TextStream on: (Text fromString: (WideString new: text size)). 233345 233346 done := false. 233347 [done] 233348 whileFalse: 233349 [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex 233350 in: text string rightX: rightMargin stopConditions: stopConditions 233351 kern: kern. 233352 "See setStopConditions for stopping conditions for composing." 233353 (self perform: stopCondition) 233354 ifTrue: [presentationLine lineHeight: lineHeight + textStyle leading 233355 baseline: baseline + textStyle leading. 233356 ^ line lineHeight: lineHeight + textStyle leading 233357 baseline: baseline + textStyle leading]]! ! 233358 233359!MultiCompositionScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! 233360composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph 233361 "Answer an instance of TextLineInterval that represents the next line in the paragraph." 233362 | runLength done stopCondition | 233363 destX := spaceX := leftMargin := aParagraph leftMarginForCompositionForLine: lineIndex. 233364 destY := 0. 233365 rightMargin := aParagraph rightMarginForComposition. 233366 leftMargin >= rightMargin ifTrue: [self error: 'No room between margins to compose']. 233367 lastIndex := startIndex. "scanning sets last index" 233368 lineHeight := textStyle lineGrid. "may be increased by setFont:..." 233369 baseline := textStyle baseline. 233370 baselineY := destY + baseline. 233371 self setStopConditions. "also sets font" 233372 self handleIndentation. 233373 runLength := text runLengthFor: startIndex. 233374 runStopIndex := (lastIndex := startIndex) + (runLength - 1). 233375 line := TextLineInterval 233376 start: lastIndex 233377 stop: 0 233378 internalSpaces: 0 233379 paddingWidth: 0. 233380 presentationLine := TextLineInterval 233381 start: lastIndex 233382 stop: 0 233383 internalSpaces: 0 233384 paddingWidth: 0. 233385 numOfComposition := 0. 233386 presentation := TextStream on: (Text fromString: (WideString new: text size)). 233387 spaceCount := 0. 233388 done := false. 233389 [done] 233390 whileFalse: 233391 [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex 233392 in: text string rightX: rightMargin stopConditions: stopConditions 233393 kern: kern. 233394 "See setStopConditions for stopping conditions for composing." 233395 (self perform: stopCondition) 233396 ifTrue: [presentationLine lineHeight: lineHeight + textStyle leading 233397 baseline: baseline + textStyle leading. 233398 ^line lineHeight: lineHeight + textStyle leading 233399 baseline: baseline + textStyle leading]]! ! 233400 233401!MultiCompositionScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! 233402setActualFont: aFont 233403 "Keep track of max height and ascent for auto lineheight" 233404 | descent | 233405 super setActualFont: aFont. 233406 "' ', lastIndex printString, ' ' displayAt: (lastIndex * 15)@0." 233407 lineHeight == nil 233408 ifTrue: [descent := font descent. 233409 baseline := font ascent. 233410 lineHeight := baseline + descent] 233411 ifFalse: [descent := lineHeight - baseline max: font descent. 233412 baseline := baseline max: font ascent. 233413 lineHeight := lineHeight max: baseline + descent]! ! 233414 233415 233416!MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 233417endOfRun 233418 "Answer true if scanning has reached the end of the paragraph. 233419 Otherwise step conditions (mostly install potential new font) and answer 233420 false." 233421 233422 | runLength | 233423 lastIndex = text size 233424 ifTrue: [line stop: lastIndex. 233425 presentationLine stop: lastIndex - numOfComposition. 233426 spaceX := destX. 233427 line paddingWidth: rightMargin - destX. 233428 presentationLine paddingWidth: rightMargin - destX. 233429 ^true] 233430 ifFalse: [ 233431 "(text at: lastIndex) charCode = 32 ifTrue: [destX := destX + spaceWidth]." 233432 runLength := (text runLengthFor: (lastIndex := lastIndex + 1)). 233433 runStopIndex := lastIndex + (runLength - 1). 233434 self setStopConditions. 233435 ^false] 233436! ! 233437 233438!MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 233439placeEmbeddedObject: anchoredMorph 233440 | descent | 233441 "Workaround: The following should really use #textAnchorType" 233442 anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. 233443 (super placeEmbeddedObject: anchoredMorph) ifFalse: ["It doesn't fit" 233444 "But if it's the first character then leave it here" 233445 lastIndex < line first ifFalse:[ 233446 line stop: lastIndex-1. 233447 ^ false]]. 233448 descent := lineHeight - baseline. 233449 lineHeight := lineHeight max: anchoredMorph height. 233450 baseline := lineHeight - descent. 233451 line stop: lastIndex. 233452 presentationLine stop: lastIndex - numOfComposition. 233453 ^ true! ! 233454 233455!MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 233456setFont 233457 super setFont. 233458 breakAtSpace := false. 233459 wantsColumnBreaks == true ifTrue: [ 233460 stopConditions := stopConditions copy. 233461 stopConditions at: TextComposer characterForColumnBreak asciiValue + 1 put: #columnBreak. 233462 ]. 233463! ! 233464 233465!MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:57'! 233466setStopConditions 233467 "Set the font and the stop conditions for the current run." 233468 233469 self setFont! ! 233470MultiCharacterScanner subclass: #MultiDisplayScanner 233471 instanceVariableNames: 'bitBlt lineY runX foregroundColor backgroundColor fillBlt lineHeight paragraph paragraphColor morphicOffset ignoreColorChanges' 233472 classVariableNames: '' 233473 poolDictionaries: '' 233474 category: 'Multilingual-Scanning'! 233475 233476!MultiDisplayScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 10:43'! 233477cr 233478 "When a carriage return is encountered, simply increment the pointer 233479 into the paragraph." 233480 233481 lastIndex:= lastIndex + 1. 233482 pendingKernX := 0. 233483 ^false! ! 233484 233485!MultiDisplayScanner methodsFor: '*FreeType-override' stamp: 'tween 8/1/2006 20:22'! 233486displayLine: textLine offset: offset leftInRun: leftInRun 233487 "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." 233488 | done stopCondition nowLeftInRun startIndex string lastPos underline strikeout | 233489 line := textLine. 233490 morphicOffset := offset. 233491 lineY := line top + offset y. 233492 lineHeight := line lineHeight. 233493 rightMargin := line rightMargin + offset x. 233494 lastIndex := line first. 233495 leftInRun <= 0 ifTrue: [self setStopConditions]. 233496 leftMargin := (line leftMarginForAlignment: alignment) + offset x. 233497 destX := runX := leftMargin. 233498 fillBlt == nil ifFalse: 233499 ["Not right" 233500 fillBlt destX: line left destY: lineY 233501 width: line width left height: lineHeight; copyBits]. 233502 lastIndex := line first. 233503 leftInRun <= 0 233504 ifTrue: [nowLeftInRun := text runLengthFor: lastIndex] 233505 ifFalse: [nowLeftInRun := leftInRun]. 233506 baselineY := lineY + line baseline. 233507 destY := baselineY - font ascent. 233508 runStopIndex := lastIndex + (nowLeftInRun - 1) min: line last. 233509 spaceCount := 0. 233510 done := false. 233511 string := text string. 233512 [done] whileFalse:[ 233513 startIndex := lastIndex. 233514 lastPos := destX@destY. 233515 stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex 233516 in: string rightX: rightMargin stopConditions: stopConditions 233517 kern: kern. 233518 lastIndex >= startIndex ifTrue:[ 233519 underline := (emphasisCode bitAnd: 4) > 0. 233520 strikeout := (emphasisCode bitAnd: 16) > 0. 233521 font displayString: string on: bitBlt 233522 from: startIndex to: lastIndex at: lastPos kern: kern baselineY: baselineY. 233523 underline 233524 ifTrue:[font displayUnderlineOn: bitBlt from: lastPos x@baselineY to: destX@baselineY]. 233525 strikeout 233526 ifTrue:[font displayStrikeoutOn: bitBlt from: lastPos x@baselineY to: destX@baselineY ] ]. 233527 "see setStopConditions for stopping conditions for displaying." 233528 done := self perform: stopCondition. 233529 "lastIndex > runStopIndex ifTrue: [done := true]." 233530 ]. 233531 ^ runStopIndex - lastIndex "Number of characters remaining in the current run"! ! 233532 233533!MultiDisplayScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 12:52'! 233534paddedSpace 233535 "Each space is a stop condition when the alignment is right justified. 233536 Padding must be added to the base width of the space according to 233537 which space in the line this space is and according to the amount of 233538 space that remained at the end of the line when it was composed." 233539 233540 spaceCount := spaceCount + 1. 233541 destX := destX + spaceWidth + (line justifiedPadFor: spaceCount font: font). 233542 lastIndex := lastIndex + 1. 233543 pendingKernX := 0. 233544 ^ false! ! 233545 233546 233547!MultiDisplayScanner methodsFor: 'multilingual scanning' stamp: 'yo 12/20/2002 11:52'! 233548isBreakableAt: index in: sourceString in: encodingClass 233549 233550 ^ false. 233551! ! 233552 233553!MultiDisplayScanner methodsFor: 'multilingual scanning' stamp: 'sd 2/4/2008 21:22'! 233554scanMultiCharactersCombiningFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta 233555 233556 | encoding f nextDestX maxAscii startEncoding char charValue | 233557 lastIndex := startIndex. 233558 lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops at: EndOfRun]. 233559 startEncoding := (sourceString at: startIndex) leadingChar. 233560 font ifNil: [font := (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. 233561 ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ 233562 [f := font fontArray at: startEncoding + 1] 233563 on: Exception do: [:ex | f := font fontArray at: 1]. 233564 f ifNil: [ f := font fontArray at: 1]. 233565 maxAscii := f maxAscii. 233566 spaceWidth := f widthOf: Space. 233567 ] ifFalse: [ 233568 maxAscii := font maxAscii. 233569 ]. 233570 233571 [lastIndex <= stopIndex] whileTrue: [ 233572 encoding := (sourceString at: lastIndex) leadingChar. 233573 encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^ stops at: EndOfRun]. 233574 char := (sourceString at: lastIndex). 233575 charValue := char charCode. 233576 charValue > maxAscii ifTrue: [charValue := maxAscii]. 233577 (encoding = 0 and: [(stopConditions at: charValue + 1) ~~ nil]) ifTrue: [ 233578 ^ stops at: charValue + 1 233579 ]. 233580 nextDestX := destX + (self widthOf: char inFont: font). 233581 nextDestX > rightX ifTrue: [^ stops at: CrossedX]. 233582 destX := nextDestX + kernDelta. 233583 lastIndex := lastIndex + 1. 233584 ]. 233585 lastIndex := stopIndex. 233586 ^ stops at: EndOfRun! ! 233587 233588 233589!MultiDisplayScanner methodsFor: 'mvc-compatibility' stamp: 'sd 2/4/2008 21:22'! 233590displayLines: linesInterval in: aParagraph clippedBy: visibleRectangle 233591 "The central display routine. The call on the primitive 233592 (scanCharactersFrom:to:in:rightX:) will be interrupted according to an 233593 array of stop conditions passed to the scanner at which time the code to 233594 handle the stop condition is run and the call on the primitive continued 233595 until a stop condition returns true (which means the line has 233596 terminated)." 233597 | runLength done stopCondition leftInRun startIndex string lastPos | 233598 "leftInRun is the # of characters left to scan in the current run; 233599 when 0, it is time to call 'self setStopConditions'" 233600 morphicOffset := 0@0. 233601 leftInRun := 0. 233602 self initializeFromParagraph: aParagraph clippedBy: visibleRectangle. 233603 ignoreColorChanges := false. 233604 paragraph := aParagraph. 233605 foregroundColor := paragraphColor := aParagraph foregroundColor. 233606 backgroundColor := aParagraph backgroundColor. 233607 aParagraph backgroundColor isTransparent 233608 ifTrue: [fillBlt := nil] 233609 ifFalse: [fillBlt := bitBlt copy. "Blt to fill spaces, tabs, margins" 233610 fillBlt sourceForm: nil; sourceOrigin: 0@0. 233611 fillBlt fillColor: aParagraph backgroundColor]. 233612 rightMargin := aParagraph rightMarginForDisplay. 233613 lineY := aParagraph topAtLineIndex: linesInterval first. 233614 bitBlt destForm deferUpdatesIn: visibleRectangle while: [ 233615 linesInterval do: 233616 [:lineIndex | 233617 leftMargin := aParagraph leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment]). 233618 destX := (runX := leftMargin). 233619 line := aParagraph lines at: lineIndex. 233620 lineHeight := line lineHeight. 233621 fillBlt == nil ifFalse: 233622 [fillBlt destX: visibleRectangle left destY: lineY 233623 width: visibleRectangle width height: lineHeight; copyBits]. 233624 lastIndex := line first. 233625 leftInRun <= 0 233626 ifTrue: [self setStopConditions. "also sets the font" 233627 leftInRun := text runLengthFor: line first]. 233628 baselineY := lineY + line baseline. 233629 destY := baselineY - font ascent. "Should have happened in setFont" 233630 runLength := leftInRun. 233631 runStopIndex := lastIndex + (runLength - 1) min: line last. 233632 leftInRun := leftInRun - (runStopIndex - lastIndex + 1). 233633 spaceCount := 0. 233634 done := false. 233635 string := text string. 233636 self handleIndentation. 233637 [done] whileFalse:[ 233638 startIndex := lastIndex. 233639 lastPos := destX@destY. 233640 stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex 233641 in: string rightX: rightMargin stopConditions: stopConditions 233642 kern: kern. 233643 lastIndex >= startIndex ifTrue:[ 233644 font displayString: string on: bitBlt 233645 from: startIndex to: lastIndex at: lastPos kern: kern baselineY: baselineY]. 233646 "see setStopConditions for stopping conditions for displaying." 233647 done := self perform: stopCondition]. 233648 fillBlt == nil ifFalse: 233649 [fillBlt destX: destX destY: lineY width: visibleRectangle right-destX height: lineHeight; copyBits]. 233650 lineY := lineY + lineHeight]]! ! 233651 233652!MultiDisplayScanner methodsFor: 'mvc-compatibility' stamp: 'pavel.krivanek 11/21/2008 16:56'! 233653initializeFromParagraph: aParagraph clippedBy: clippingRectangle 233654 233655 super initializeFromParagraph: aParagraph clippedBy: clippingRectangle. 233656 bitBlt := UIManager default grafPort toForm: aParagraph destinationForm. 233657 bitBlt sourceX: 0; width: 0. "Init BitBlt so that the first call to a primitive will not fail" 233658 bitBlt combinationRule: Form paint. 233659 bitBlt colorMap: 233660 (Bitmap with: 0 "Assumes 1-bit deep fonts" 233661 with: (bitBlt destForm pixelValueFor: aParagraph foregroundColor)). 233662 bitBlt clipRect: clippingRectangle. 233663! ! 233664 233665 233666!MultiDisplayScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! 233667placeEmbeddedObject: anchoredMorph 233668 anchoredMorph relativeTextAnchorPosition ifNotNil:[ 233669 anchoredMorph position: 233670 anchoredMorph relativeTextAnchorPosition + 233671 (anchoredMorph owner textBounds origin x @ 0) 233672 - (0@morphicOffset y) + (0@lineY). 233673 ^true 233674 ]. 233675 (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. 233676 anchoredMorph isMorph ifTrue: [ 233677 anchoredMorph position: ((destX - anchoredMorph width)@lineY) - morphicOffset 233678 ] ifFalse: [ 233679 destY := lineY. 233680 baselineY := lineY + anchoredMorph height.. 233681 runX := destX. 233682 anchoredMorph 233683 displayOn: bitBlt destForm 233684 at: destX - anchoredMorph width @ destY 233685 clippingBox: bitBlt clipRect 233686 rule: Form blend 233687 fillColor: Color white 233688 ]. 233689 ^ true! ! 233690 233691 233692!MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'! 233693crossedX 233694 "This condition will sometimes be reached 'legally' during display, when, 233695 for instance the space that caused the line to wrap actually extends over 233696 the right boundary. This character is allowed to display, even though it 233697 is technically outside or straddling the clipping ectangle since it is in 233698 the normal case not visible and is in any case appropriately clipped by 233699 the scanner." 233700 233701 ^ true ! ! 233702 233703!MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 233704endOfRun 233705 "The end of a run in the display case either means that there is actually 233706 a change in the style (run code) to be associated with the string or the 233707 end of this line has been reached." 233708 | runLength | 233709 lastIndex = line last ifTrue: [^true]. 233710 runX := destX. 233711 runLength := text runLengthFor: (lastIndex := lastIndex + 1). 233712 runStopIndex := lastIndex + (runLength - 1) min: line last. 233713 self setStopConditions. 233714 ^ false! ! 233715 233716!MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 233717plainTab 233718 | oldX | 233719 oldX := destX. 233720 super plainTab. 233721 fillBlt == nil ifFalse: 233722 [fillBlt destX: oldX destY: destY width: destX - oldX height: font height; copyBits]! ! 233723 233724!MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 233725setStopConditions 233726 "Set the font and the stop conditions for the current run." 233727 233728 self setFont. 233729 self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]). 233730 233731" 233732 alignment = Justified ifTrue: [ 233733 stopConditions == DefaultStopConditions 233734 ifTrue:[stopConditions := stopConditions copy]. 233735 stopConditions at: Space asciiValue + 1 put: #paddedSpace] 233736"! ! 233737 233738!MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 233739tab 233740 self plainTab. 233741 lastIndex := lastIndex + 1. 233742 ^ false! ! 233743 233744 233745!MultiDisplayScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 233746presentationText: t 233747 233748 text := t. 233749! ! 233750 233751!MultiDisplayScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:58'! 233752setDestForm: df 233753 bitBlt setDestForm: df.! ! 233754 233755!MultiDisplayScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 233756setFont 233757 foregroundColor := paragraphColor. 233758 super setFont. "Sets font and emphasis bits, and maybe foregroundColor" 233759 font installOn: bitBlt foregroundColor: foregroundColor backgroundColor: Color transparent. 233760 text ifNotNil:[ 233761 baselineY := lineY + line baseline. 233762 destY := baselineY - font ascent]. 233763! ! 233764 233765!MultiDisplayScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 233766setPort: aBitBlt 233767 "Install the BitBlt to use" 233768 bitBlt := aBitBlt. 233769 bitBlt sourceX: 0; width: 0. "Init BitBlt so that the first call to a primitive will not fail" 233770 bitBlt sourceForm: nil. "Make sure font installation won't be confused" 233771! ! 233772 233773!MultiDisplayScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 233774text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode 233775 text := t. 233776 textStyle := ts. 233777 foregroundColor := paragraphColor := foreColor. 233778 (backgroundColor := backColor) isTransparent ifFalse: 233779 [fillBlt := blt. 233780 fillBlt fillColor: backgroundColor]. 233781 ignoreColorChanges := shadowMode! ! 233782 233783!MultiDisplayScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 233784textColor: textColor 233785 ignoreColorChanges ifTrue: [^ self]. 233786 foregroundColor := textColor! ! 233787 233788"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 233789 233790MultiDisplayScanner class 233791 instanceVariableNames: ''! 233792 233793!MultiDisplayScanner class methodsFor: 'queries' stamp: 'yo 12/18/2002 13:58'! 233794defaultFont 233795 ^ TextStyle defaultFont! ! 233796NewParagraph subclass: #MultiNewParagraph 233797 instanceVariableNames: 'presentationText presentationLines' 233798 classVariableNames: '' 233799 poolDictionaries: 'TextConstants' 233800 category: 'Multilingual-Scanning'! 233801 233802!MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:22'! 233803displayOn: aCanvas using: displayScanner at: somePosition 233804 "Send all visible lines to the displayScanner for display" 233805 233806 | visibleRectangle offset leftInRun line | 233807 visibleRectangle := aCanvas clipRect. 233808 offset := somePosition - positionWhenComposed. 233809 leftInRun := 0. 233810 (self lineIndexForPoint: visibleRectangle topLeft) 233811 to: (self lineIndexForPoint: visibleRectangle bottomRight) 233812 do: [:i | line := lines at: i. 233813 self displaySelectionInLine: line on: aCanvas. 233814 line first <= line last ifTrue: 233815 [leftInRun := displayScanner displayLine: line 233816 offset: offset leftInRun: leftInRun]]. 233817! ! 233818 233819!MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:22'! 233820displayOnTest: aCanvas using: displayScanner at: somePosition 233821 "Send all visible lines to the displayScanner for display" 233822 233823 | visibleRectangle offset leftInRun line | 233824 (presentationText isNil or: [presentationLines isNil]) ifTrue: [ 233825 ^ self displayOn: aCanvas using: displayScanner at: somePosition. 233826 ]. 233827 visibleRectangle := aCanvas clipRect. 233828 offset := somePosition - positionWhenComposed. 233829 leftInRun := 0. 233830 (self lineIndexForPoint: visibleRectangle topLeft) 233831 to: (self lineIndexForPoint: visibleRectangle bottomRight) 233832 do: [:i | line := presentationLines at: i. 233833 self displaySelectionInLine: line on: aCanvas. 233834 line first <= line last ifTrue: 233835 [leftInRun := displayScanner displayLine: line 233836 offset: offset leftInRun: leftInRun]]. 233837! ! 233838 233839!MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:22'! 233840multiComposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines 233841 atY: startingY 233842 "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" 233843 233844 | newResult composer presentationInfo | 233845 233846 composer := MultiTextComposer new. 233847 presentationLines := nil. 233848 presentationText := nil. 233849 newResult := composer 233850 multiComposeLinesFrom: start 233851 to: stop 233852 delta: delta 233853 into: lineColl 233854 priorLines: priorLines 233855 atY: startingY 233856 textStyle: textStyle 233857 text: text 233858 container: container 233859 wantsColumnBreaks: wantsColumnBreaks == true. 233860 lines := newResult first asArray. 233861 maxRightX := newResult second. 233862 presentationInfo := composer getPresentationInfo. 233863 presentationLines := presentationInfo first asArray. 233864 presentationText := presentationInfo second. 233865 "maxRightX printString displayAt: 0@0." 233866 ^maxRightX 233867! ! 233868 233869!MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 17:31'! 233870presentationLines 233871 233872 ^ presentationLines. 233873! ! 233874 233875!MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 17:31'! 233876presentationText 233877 233878 ^ presentationText. 233879! ! 233880MultiNewParagraph subclass: #MultiNewParagraphWithSelectionColor 233881 instanceVariableNames: 'selectionColor' 233882 classVariableNames: '' 233883 poolDictionaries: '' 233884 category: 'Polymorph-Widgets'! 233885!MultiNewParagraphWithSelectionColor commentStamp: 'gvc 5/18/2007 12:43' prior: 0! 233886Paragraph supporting custom selection colour.! 233887 233888 233889!MultiNewParagraphWithSelectionColor methodsFor: 'accessing' stamp: 'gvc 10/24/2006 16:12'! 233890selectionColor 233891 "Answer the selection color." 233892 233893 ^selectionColor ifNil: [super selectionColor]! ! 233894 233895!MultiNewParagraphWithSelectionColor methodsFor: 'accessing' stamp: 'gvc 10/24/2006 16:11'! 233896selectionColor: anObject 233897 "Set the value of selectionColor" 233898 233899 selectionColor := anObject! ! 233900TTCFont subclass: #MultiTTCFont 233901 instanceVariableNames: '' 233902 classVariableNames: '' 233903 poolDictionaries: '' 233904 category: 'Multilingual-Display'! 233905 233906!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:11'! 233907access: char at: index 233908 233909 | wcache entry | 233910 wcache := self cache. 233911 entry := wcache at: index. 233912 wcache replaceFrom: index to: wcache size - 1 with: wcache startingAt: index + 1. 233913 wcache at: wcache size put: entry. 233914! ! 233915 233916!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:11'! 233917at: char put: form 233918 233919 | wcache | 233920 wcache := self cache. 233921 wcache replaceFrom: 1 to: wcache size - 1 with: wcache startingAt: 2. 233922 wcache at: wcache size 233923 put: (Array with: char asciiValue with: foregroundColor with: form). 233924! ! 233925 233926!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:12'! 233927formOf: char 233928 233929 | newForm | 233930 self hasCached: char ifTrue: [:form :index | 233931 self access: char at: index. 233932 ^ form. 233933 ]. 233934 233935 newForm := self computeForm: char. 233936 self at: char put: newForm. 233937 ^ newForm. 233938! ! 233939 233940!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:12'! 233941glyphInfoOf: char into: glyphInfoArray 233942 233943 | newForm | 233944 self hasCached: char ifTrue: [:form :index | 233945 self access: char at: index. 233946 glyphInfoArray at: 1 put: form; 233947 at: 2 put: 0; 233948 at: 3 put: form width; 233949 at: 4 put: (self ascentOf: char); 233950 at: 5 put: self. 233951 ^ glyphInfoArray. 233952 ]. 233953 233954 newForm := self computeForm: char. 233955 self at: char put: newForm. 233956 233957 glyphInfoArray at: 1 put: newForm; 233958 at: 2 put: 0; 233959 at: 3 put: newForm width; 233960 at: 4 put: (self ascentOf: char); 233961 at: 5 put: self. 233962 ^ glyphInfoArray. 233963! ! 233964 233965!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:12'! 233966hasCached: char ifTrue: twoArgBlock 233967 233968 | value elem | 233969 value := char asciiValue. 233970 233971 self cache size to: 1 by: -1 do: [:i | 233972 elem := self cache at: i. 233973 (elem first = value and: [elem second = foregroundColor]) ifTrue: [ 233974 ^ twoArgBlock value: elem third value: i. 233975 ]. 233976 ]. 233977 ^ false. 233978! ! 233979 233980!MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:12'! 233981widthOf: char 233982 233983 "This method cannot use #formOf: because formOf: discriminates the color and causes unnecessary bitmap creation." 233984 233985 | newForm | 233986 self hasCached: char ifTrue: [:form :index | 233987 self access: char at: index. 233988 ^ form width. 233989 ]. 233990 233991 newForm := self computeForm: char. 233992 self at: char put: newForm. 233993 ^ newForm width. 233994 233995! ! 233996 233997"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 233998 233999MultiTTCFont class 234000 instanceVariableNames: ''! 234001 234002!MultiTTCFont class methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:34'! 234003cacheAllNil 234004" 234005 self cacheAllNil 234006" 234007 self allInstances do: [:inst | 234008 inst cache do: [:e | 234009 e third ifNotNil: [^ false]. 234010 ]. 234011 ]. 234012 234013 ^ true. 234014! ! 234015TextComposer subclass: #MultiTextComposer 234016 instanceVariableNames: 'presentation presentationLines' 234017 classVariableNames: '' 234018 poolDictionaries: 'TextConstants' 234019 category: 'Multilingual-Scanning'! 234020 234021!MultiTextComposer methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:22'! 234022composeEachRectangleIn: rectangles 234023 234024 | myLine lastChar | 234025 234026 1 to: rectangles size do: [:i | 234027 currCharIndex <= theText size ifFalse: [^false]. 234028 myLine := scanner 234029 composeFrom: currCharIndex 234030 inRectangle: (rectangles at: i) 234031 firstLine: isFirstLine 234032 leftSide: i=1 234033 rightSide: i=rectangles size. 234034 lines addLast: myLine. 234035 presentationLines addLast: scanner getPresentationLine. 234036 presentation ifNil: [presentation := scanner getPresentation] 234037 ifNotNil: [presentation := presentation, scanner getPresentation]. 234038 actualHeight := actualHeight max: myLine lineHeight. "includes font changes" 234039 currCharIndex := myLine last + 1. 234040 lastChar := theText at: myLine last. 234041 lastChar = Character cr ifTrue: [^#cr]. 234042 wantsColumnBreaks ifTrue: [ 234043 lastChar = TextComposer characterForColumnBreak ifTrue: [^#columnBreak]. 234044 ]. 234045 ]. 234046 ^false! ! 234047 234048!MultiTextComposer methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 12:53'! 234049getPresentationInfo 234050 234051 ^ Array with: presentationLines with: presentation. 234052! ! 234053 234054!MultiTextComposer methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:22'! 234055multiComposeLinesFrom: argStart to: argStop delta: argDelta into: argLinesCollection priorLines: argPriorLines atY: argStartY textStyle: argTextStyle text: argText container: argContainer wantsColumnBreaks: argWantsColumnBreaks 234056 234057 wantsColumnBreaks := argWantsColumnBreaks. 234058 lines := argLinesCollection. 234059 presentationLines := argLinesCollection copy. 234060 theTextStyle := argTextStyle. 234061 theText := argText. 234062 theContainer := argContainer. 234063 deltaCharIndex := argDelta. 234064 currCharIndex := startCharIndex := argStart. 234065 stopCharIndex := argStop. 234066 prevLines := argPriorLines. 234067 currentY := argStartY. 234068 defaultLineHeight := theTextStyle lineGrid. 234069 maxRightX := theContainer left. 234070 possibleSlide := stopCharIndex < theText size and: [theContainer isMemberOf: Rectangle]. 234071 nowSliding := false. 234072 prevIndex := 1. 234073 scanner := MultiCompositionScanner new text: theText textStyle: theTextStyle. 234074 scanner wantsColumnBreaks: wantsColumnBreaks. 234075 isFirstLine := true. 234076 self composeAllLines. 234077 isFirstLine ifTrue: ["No space in container or empty text" 234078 self 234079 addNullLineWithIndex: startCharIndex 234080 andRectangle: (theContainer topLeft extent: 0@defaultLineHeight) 234081 ] ifFalse: [ 234082 self fixupLastLineIfCR 234083 ]. 234084 ^{lines asArray. maxRightX} 234085 234086! ! 234087LazyListMorph subclass: #MulticolumnLazyListMorph 234088 instanceVariableNames: 'columnWidths' 234089 classVariableNames: '' 234090 poolDictionaries: '' 234091 category: 'Morphic-Widgets'! 234092!MulticolumnLazyListMorph commentStamp: '<historical>' prior: 0! 234093A variant of LazyListMorph that can display multi-column lists.! 234094 234095 234096!MulticolumnLazyListMorph methodsFor: 'as yet unclassified' stamp: 'ls 5/17/2001 21:23'! 234097getListItem: index 234098 ^listSource getListRow: index! ! 234099 234100!MulticolumnLazyListMorph methodsFor: 'as yet unclassified' stamp: 'ls 5/18/2001 16:43'! 234101listChanged 234102 columnWidths := nil. 234103 super listChanged! ! 234104 234105 234106!MulticolumnLazyListMorph methodsFor: 'drawing' stamp: 'nk 1/10/2004 16:19'! 234107display: items atRow: row on: canvas 234108 "display the specified item, which is on the specified row; for Multicolumn 234109 lists, items will be a list of strings" 234110 | drawBounds | 234111 drawBounds := self drawBoundsForRow: row. 234112 drawBounds := drawBounds intersect: self bounds. 234113 items 234114 with: (1 to: items size) 234115 do: [:item :index | 234116 "move the bounds to the right at each step" 234117 index > 1 234118 ifTrue: [drawBounds := drawBounds left: drawBounds left + 6 234119 + (columnWidths at: index - 1)]. 234120 item isText 234121 ifTrue: [canvas 234122 drawString: item 234123 in: drawBounds 234124 font: (font 234125 emphasized: (item emphasisAt: 1)) 234126 color: (self colorForRow: row)] 234127 ifFalse: [canvas 234128 drawString: item 234129 in: drawBounds 234130 font: font 234131 color: (self colorForRow: row)]]! ! 234132 234133!MulticolumnLazyListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 21:58'! 234134drawOn: aCanvas 234135 self getListSize = 0 ifTrue:[ ^self ]. 234136 234137 self setColumnWidthsFor: aCanvas. 234138 234139 super drawOn: aCanvas! ! 234140 234141!MulticolumnLazyListMorph methodsFor: 'drawing' stamp: 'sps 3/23/2004 15:51'! 234142setColumnWidthsFor: aCanvas 234143 | row topRow bottomRow | 234144 "set columnWidths for drawing on the specified canvas" 234145 columnWidths ifNil: [ 234146 columnWidths := (self item: 1) collect: [ :ignored | 0 ]. ]. 234147 topRow := (self topVisibleRowForCanvas: aCanvas) max: 1. 234148 bottomRow := (self bottomVisibleRowForCanvas: aCanvas) max: 1. 234149 topRow > bottomRow ifTrue: [ ^ self ]. 234150 topRow to: bottomRow do: [ :rowIndex | 234151 row := self item: rowIndex. 234152 columnWidths := columnWidths with: row collect: [ :currentWidth :item | 234153 | widthOfItem | 234154 widthOfItem := (font widthOfStringOrText: item). 234155 widthOfItem > currentWidth 234156 ifTrue: [ self changed. widthOfItem ] 234157 ifFalse: [ currentWidth ] ] ]! ! 234158 234159 234160!MulticolumnLazyListMorph methodsFor: 'scroll range' stamp: 'sps 4/2/2004 12:16'! 234161hUnadjustedScrollRange 234162"multi column list morphs don't use hScrollbars" 234163 234164 ^0 234165 234166! ! 234167 234168!MulticolumnLazyListMorph methodsFor: 'scroll range' stamp: 'ls 4/17/2004 12:21'! 234169widthToDisplayItem: item 234170 | widths | 234171 widths := item collect: [ :each | super widthToDisplayItem: each ]. 234172 ^widths sum + (10 * (widths size - 1)) "add in space between the columns" 234173! ! 234174Morph subclass: #MultistateButtonMorph 234175 instanceVariableNames: 'enabled active over down stateMap' 234176 classVariableNames: '' 234177 poolDictionaries: '' 234178 category: 'Polymorph-Widgets'! 234179!MultistateButtonMorph commentStamp: 'gvc 10/21/2008 13:27' prior: 0! 234180A simple button that handles multiple fillstyle states: 234181 Normal 234182 Mouse-over 234183 Mouse-down-inside 234184 Mouse-down outside 234185with variants being a combination of passive/active and enabled/disabled.! 234186 234187 234188!MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:28'! 234189active 234190 "Answer the value of active" 234191 234192 ^ active! ! 234193 234194!MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:57'! 234195active: anObject 234196 "Set the value of active" 234197 234198 active := anObject. 234199 self changed! ! 234200 234201!MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:31'! 234202down 234203 "Answer the value of down" 234204 234205 ^ down! ! 234206 234207!MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:57'! 234208down: anObject 234209 "Set the value of down" 234210 234211 down := anObject. 234212 self changed! ! 234213 234214!MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:28'! 234215enabled 234216 "Answer whether the button is rnabled." 234217 234218 ^enabled! ! 234219 234220!MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:57'! 234221enabled: anObject 234222 "Set the value of enabled" 234223 234224 enabled := anObject. 234225 self changed! ! 234226 234227!MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:31'! 234228over 234229 "Answer the value of over" 234230 234231 ^ over! ! 234232 234233!MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:57'! 234234over: anObject 234235 "Set the value of over" 234236 234237 over := anObject. 234238 self changed! ! 234239 234240!MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:28'! 234241stateMap 234242 "Answer the value of stateMap" 234243 234244 ^ stateMap! ! 234245 234246!MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:28'! 234247stateMap: anObject 234248 "Set the value of stateMap" 234249 234250 stateMap := anObject! ! 234251 234252 234253!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:50'! 234254activate 234255 "Make active." 234256 234257 super activate. 234258 self active: true! ! 234259 234260!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:38'! 234261addDownAction: anActionOrBlock 234262 "Add a down event handler." 234263 234264 self when: #down evaluate: anActionOrBlock! ! 234265 234266!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:38'! 234267addUpAction: anActionOrBlock 234268 "Add an up event handler." 234269 234270 self when: #up evaluate: anActionOrBlock! ! 234271 234272!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 12:32'! 234273extent: aPoint 234274 "Center the fill style origin." 234275 234276 |delta| 234277 self bounds extent = aPoint ifTrue: [^self]. 234278 delta := aPoint - self extent // 2. 234279 self fillStyles do: [:fs | fs isOrientedFill ifTrue: [fs origin: fs origin + delta]]. 234280 super extent: aPoint! ! 234281 234282!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:32'! 234283handlesMouseDown: evt 234284 "Yes." 234285 234286 ^true! ! 234287 234288!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:27'! 234289handlesMouseOver: anEvent 234290 "Answer true, otherwise what is all that 234291 #mouseEnter:/#mouseLeave: stuff about?" 234292 234293 ^true! ! 234294 234295!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:34'! 234296handlesMouseOverDragging: evt 234297 "Yes, for other states." 234298 234299 ^true! ! 234300 234301!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:34'! 234302mouseDown: evt 234303 "Handle a mouse down event." 234304 234305 super mouseDown: evt. 234306 self enabled ifFalse: [^self]. 234307 self down: true. 234308 self triggerEvent: #down ! ! 234309 234310!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:27'! 234311mouseEnter: evt 234312 "Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed." 234313 234314 super mouseEnter: evt. 234315 self over: true! ! 234316 234317!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:31'! 234318mouseEnterDragging: evt 234319 "Handle a mouseEnterDragging event, meaning the mouse just entered my bounds with a button pressed or laden with submorphs." 234320 234321 super mouseEnterDragging: evt. 234322 self over: true! ! 234323 234324!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:28'! 234325mouseLeave: evt 234326 "Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed." 234327 234328 super mouseLeave: evt. 234329 self over: false! ! 234330 234331!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:30'! 234332mouseLeaveDragging: evt 234333 "Handle a mouseLeaveLaden event, meaning the mouse just left my bounds with a button pressed or laden with submorphs." 234334 234335 super mouseLeaveDragging: evt. 234336 self over: false! ! 234337 234338!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:34'! 234339mouseUp: evt 234340 "Handle a mouse up event." 234341 234342 super mouseUp: evt. 234343 self enabled ifFalse: [^self]. 234344 self down: false. 234345 (self containsPoint: evt cursorPoint) 234346 ifTrue: [self triggerEvent: #up] 234347 ifFalse: [self triggerEvent: #upOutside]! ! 234348 234349!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:50'! 234350passivate 234351 "Make passive." 234352 234353 super passivate. 234354 self active: false! ! 234355 234356!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:11'! 234357privateMoveBy: delta 234358 "Adjust all the fill styles" 234359 234360 super privateMoveBy: delta. 234361 (self fillStyles copyWithout: self fillStyle) do: [:fs | fs isOrientedFill ifTrue: [fs origin: fs origin + delta]]! ! 234362 234363!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:39'! 234364removeDownActions 234365 "Remove all down event handlers" 234366 234367 self removeActionsForEvent: #down! ! 234368 234369!MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:39'! 234370removeUpActions 234371 "Remove all up event handlers" 234372 234373 self removeActionsForEvent: #up! ! 234374 234375 234376!MultistateButtonMorph methodsFor: 'initialize-release' stamp: 'gvc 10/21/2008 16:07'! 234377initialize 234378 "Initialize the receiver." 234379 234380 self stateMap: KeyedTree new. 234381 enabled := true. 234382 active := true. 234383 over := false. 234384 down := false. 234385 super initialize! ! 234386 234387 234388!MultistateButtonMorph methodsFor: 'updating' stamp: 'gvc 10/21/2008 15:46'! 234389changed 234390 "Update the fillStyle here." 234391 234392 self setProperty: #fillStyle toValue: self fillStyleToUse. 234393 color := self fillStyle asColor. 234394 super changed! ! 234395 234396 234397!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:16'! 234398activeDisabledNotOverDownFillStyle: aFillStyle 234399 "Set the active, disabled, notOver, down fill style." 234400 234401 self stateMap atPath: #(active disabled notOver down) put: aFillStyle. 234402 self changed! ! 234403 234404!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:16'! 234405activeDisabledNotOverUpFillStyle: aFillStyle 234406 "Set the active, disabled, notOver, up fill style." 234407 234408 self stateMap atPath: #(active disabled notOver up) put: aFillStyle. 234409 self changed! ! 234410 234411!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:17'! 234412activeDisabledOverDownFillStyle: aFillStyle 234413 "Set the active, disabled, over, down fill style." 234414 234415 self stateMap atPath: #(active disabled over down) put: aFillStyle. 234416 self changed! ! 234417 234418!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:17'! 234419activeDisabledOverUpFillStyle: aFillStyle 234420 "Set the active, disabled, over, up fill style." 234421 234422 self stateMap atPath: #(active disabled over up) put: aFillStyle. 234423 self changed! ! 234424 234425!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 15:55'! 234426activeEnabledNotOverDownFillStyle: aFillStyle 234427 "Set the active, enabled, notOver, down fill style." 234428 234429 self stateMap atPath: #(active enabled notOver down) put: aFillStyle. 234430 self changed! ! 234431 234432!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 15:55'! 234433activeEnabledNotOverUpFillStyle: aFillStyle 234434 "Set the active, enabled, notOver, up fill style." 234435 234436 self stateMap atPath: #(active enabled notOver up) put: aFillStyle. 234437 self changed! ! 234438 234439!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:17'! 234440activeEnabledOverDownFillStyle: aFillStyle 234441 "Set the active, enabled, over, down fill style." 234442 234443 self stateMap atPath: #(active enabled over down) put: aFillStyle. 234444 self changed! ! 234445 234446!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 15:55'! 234447activeEnabledOverUpFillStyle: aFillStyle 234448 "Set the active, enabled, over, up fill style." 234449 234450 self stateMap atPath: #(active enabled over up) put: aFillStyle. 234451 self changed! ! 234452 234453!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:01'! 234454fillStyleToUse 234455 "Answer the fill style to used based on the current state." 234456 234457 |map| 234458 map := self active 234459 ifTrue: [self stateMap at: #active ifAbsent: [self stateMap at: #passive ifAbsent: [Dictionary new]]] 234460 ifFalse: [self stateMap at: #passive ifAbsent: [self stateMap at: #active ifAbsent: [Dictionary new]]]. 234461 map := self enabled 234462 ifTrue: [map at: #enabled ifAbsent: [map at: #disabled ifAbsent: [Dictionary new]]] 234463 ifFalse: [map at: #disabled ifAbsent: [map at: #enabled ifAbsent: [Dictionary new]]]. 234464 map := self over 234465 ifTrue: [map at: #over ifAbsent: [map at: #notOver ifAbsent: [Dictionary new]]] 234466 ifFalse: [map at: #notOver ifAbsent: [map at: #over ifAbsent: [Dictionary new]]]. 234467 ^map at: (self down ifTrue: [#down] ifFalse: [#up]) ifAbsent: [ 234468 map at: (self down ifTrue: [#up] ifFalse: [#down]) ifAbsent: [Color transparent]]! ! 234469 234470!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:13'! 234471fillStyles 234472 "Answer all the fill styles" 234473 234474 |styles| 234475 styles := OrderedCollection new. 234476 self stateMap do: [:actives | 234477 actives do: [:enableds | 234478 enableds do: [:overs | 234479 overs do: [:fs | styles add: fs]]]]. 234480 ^styles! ! 234481 234482!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:44'! 234483passiveDisabledNotOverDownFillStyle: aFillStyle 234484 "Set the passive, disabled, notOver, down fill style." 234485 234486 self stateMap atPath: #(passive disabled notOver down) put: aFillStyle. 234487 self changed! ! 234488 234489!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:44'! 234490passiveDisabledNotOverUpFillStyle: aFillStyle 234491 "Set the passive, disabled, notOver, up fill style." 234492 234493 self stateMap atPath: #(passive disabled notOver up) put: aFillStyle. 234494 self changed! ! 234495 234496!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:44'! 234497passiveDisabledOverDownFillStyle: aFillStyle 234498 "Set the passive, disabled, over, down fill style." 234499 234500 self stateMap atPath: #(passive disabled over down) put: aFillStyle. 234501 self changed! ! 234502 234503!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:44'! 234504passiveDisabledOverUpFillStyle: aFillStyle 234505 "Set the passive, disabled, over, up fill style." 234506 234507 self stateMap atPath: #(passive disabled over up) put: aFillStyle. 234508 self changed! ! 234509 234510!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:44'! 234511passiveEnabledNotOverDownFillStyle: aFillStyle 234512 "Set the passive, enabled, notOver, down fill style." 234513 234514 self stateMap atPath: #(passive enabled notOver down) put: aFillStyle. 234515 self changed! ! 234516 234517!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:44'! 234518passiveEnabledNotOverUpFillStyle: aFillStyle 234519 "Set the passive, enabled, notOver, up fill style." 234520 234521 self stateMap atPath: #(passive enabled notOver up) put: aFillStyle. 234522 self changed! ! 234523 234524!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:45'! 234525passiveEnabledOverDownFillStyle: aFillStyle 234526 "Set the passive, enabled, over, down fill style." 234527 234528 self stateMap atPath: #(passive enabled over down) put: aFillStyle. 234529 self changed! ! 234530 234531!MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:45'! 234532passiveEnabledOverUpFillStyle: aFillStyle 234533 "Set the passive, enabled, over, up fill style." 234534 234535 self stateMap atPath: #(passive enabled over up) put: aFillStyle. 234536 self changed! ! 234537Object subclass: #Mutex 234538 instanceVariableNames: 'semaphore owner' 234539 classVariableNames: '' 234540 poolDictionaries: '' 234541 category: 'Kernel-Processes'! 234542!Mutex commentStamp: '<historical>' prior: 0! 234543A Mutex is a light-weight MUTual EXclusion object being used when two or more processes need to access a shared resource concurrently. A Mutex grants ownership to a single process and will suspend any other process trying to aquire the mutex while in use. Waiting processes are granted access to the mutex in the order the access was requested. 234544 234545Instance variables: 234546 semaphore <Semaphore> The (primitive) semaphore used for synchronization. 234547 owner <Process> The process owning the mutex.! 234548 234549 234550!Mutex methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 10:11'! 234551initialize 234552 super initialize. 234553 semaphore := Semaphore forMutualExclusion.! ! 234554 234555 234556!Mutex methodsFor: 'mutual exclusion' stamp: 'das 11/3/2005 22:53'! 234557critical: aBlock 234558 "Evaluate aBlock protected by the receiver." 234559 | activeProcess | 234560 activeProcess := Processor activeProcess. 234561 activeProcess == owner ifTrue:[^aBlock value]. 234562 ^semaphore critical:[ 234563 owner := activeProcess. 234564 aBlock ensure:[owner := nil]].! ! 234565 234566"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 234567 234568Mutex class 234569 instanceVariableNames: ''! 234570Object subclass: #MutexSet 234571 instanceVariableNames: 'array' 234572 classVariableNames: '' 234573 poolDictionaries: '' 234574 category: 'Kernel-Processes'! 234575!MutexSet commentStamp: '<historical>' prior: 0! 234576A MutexSet helps with aquiring a set of mutexes.! 234577 234578 234579!MutexSet methodsFor: 'initialize' stamp: 'das 11/3/2005 22:54'! 234580withAll: mutexList 234581 array := mutexList.! ! 234582 234583 234584!MutexSet methodsFor: 'mutual exclusion' stamp: 'das 11/3/2005 22:54'! 234585critical: aBlock 234586 "Evaluate aBlock aquiring all mutexes" 234587 ^self pvtCritical: aBlock startingAt: 1! ! 234588 234589 234590!MutexSet methodsFor: 'private' stamp: 'das 11/3/2005 22:54'! 234591pvtCritical: aBlock startingAt: index 234592 | mutex | 234593 index > array size ifTrue:[^aBlock value]. 234594 mutex := array at: index. 234595 ^mutex critical:[self pvtCritical: aBlock startingAt: index+1].! ! 234596 234597"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 234598 234599MutexSet class 234600 instanceVariableNames: ''! 234601 234602!MutexSet class methodsFor: 'instance creation' stamp: 'das 11/3/2005 22:54'! 234603withAll: mutexList 234604 ^self new withAll: mutexList! ! 234605Error subclass: #MyResumableTestError 234606 instanceVariableNames: '' 234607 classVariableNames: '' 234608 poolDictionaries: '' 234609 category: 'Tests-Exceptions'! 234610 234611!MyResumableTestError methodsFor: 'exceptiondescription' stamp: 'tfei 6/13/1999 00:46'! 234612isResumable 234613 234614 ^true! ! 234615Error subclass: #MyTestError 234616 instanceVariableNames: '' 234617 classVariableNames: '' 234618 poolDictionaries: '' 234619 category: 'Tests-Exceptions'! 234620Notification subclass: #MyTestNotification 234621 instanceVariableNames: '' 234622 classVariableNames: '' 234623 poolDictionaries: '' 234624 category: 'Tests-Exceptions'! 234625NetworkError subclass: #NameLookupFailure 234626 instanceVariableNames: 'hostName' 234627 classVariableNames: '' 234628 poolDictionaries: '' 234629 category: 'Network-Kernel'! 234630!NameLookupFailure commentStamp: 'mir 5/12/2003 18:16' prior: 0! 234631Signals that a name lookup operation failed. 234632 234633 hostName hostName for which the name loopup failed 234634! 234635 234636 234637!NameLookupFailure methodsFor: 'accessing' stamp: 'rbb 2/18/2005 14:27'! 234638defaultAction 234639 "Backward compatibility" 234640 | response | 234641 response := (UIManager default chooseFrom: #( 'Retry' 'Give Up') 234642 title: self messageText). 234643 ^ response = 2 234644 ifFalse: [self retry]! ! 234645 234646!NameLookupFailure methodsFor: 'accessing' stamp: 'len 12/14/2002 11:57'! 234647hostName 234648 ^ hostName! ! 234649 234650!NameLookupFailure methodsFor: 'accessing' stamp: 'len 12/14/2002 11:57'! 234651hostName: aString 234652 hostName := aString! ! 234653 234654"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 234655 234656NameLookupFailure class 234657 instanceVariableNames: ''! 234658 234659!NameLookupFailure class methodsFor: 'instance creation' stamp: 'len 12/14/2002 11:57'! 234660hostName: aString 234661 ^ self new hostName: aString! ! 234662Object subclass: #NameOfSubclass 234663 instanceVariableNames: '' 234664 classVariableNames: '' 234665 poolDictionaries: '' 234666 category: 'Tests-Compiler'! 234667UpdatingStringMorph subclass: #NameStringInHalo 234668 instanceVariableNames: '' 234669 classVariableNames: '' 234670 poolDictionaries: '' 234671 category: 'Morphic-Widgets'! 234672!NameStringInHalo commentStamp: 'kfr 10/27/2003 16:29' prior: 0! 234673Shows the name of the morph in the halo. ! 234674 234675 234676!NameStringInHalo methodsFor: 'accessing' stamp: 'sw 9/17/1999 13:17'! 234677interimContents: aString 234678 self contents: aString. 234679 self placeContents! ! 234680 234681 234682!NameStringInHalo methodsFor: 'as yet unclassified' stamp: 'di 11/25/1999 23:40'! 234683placeContents 234684 | namePosition | 234685 (owner notNil and: [owner isInWorld]) ifTrue: 234686 [namePosition := owner basicBox bottomCenter - 234687 ((self width // 2) @ (owner handleSize negated // 2 - 1)). 234688 namePosition := namePosition min: self world viewBox bottomRight - self extent y + 2. 234689 self bounds: (namePosition extent: self extent)]! ! 234690 234691 234692!NameStringInHalo methodsFor: 'drawing' stamp: 'sw 9/7/1999 21:27'! 234693drawOn: aCanvas 234694 aCanvas fillRectangle: self bounds color: Color white. 234695 super drawOn: aCanvas.! ! 234696 234697 234698!NameStringInHalo methodsFor: 'editing' stamp: 'sw 9/17/1999 13:41'! 234699cancelEdits 234700 self interimContents: target externalName. 234701 super cancelEdits! ! 234702Object subclass: #NaturalLanguageFormTranslator 234703 instanceVariableNames: 'id generics' 234704 classVariableNames: 'CachedTranslations' 234705 poolDictionaries: '' 234706 category: 'System-Localization'! 234707 234708!NaturalLanguageFormTranslator methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:15'! 234709generics 234710 ^generics ifNil: [generics := Dictionary new]! ! 234711 234712!NaturalLanguageFormTranslator methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:27'! 234713localeID 234714 ^id! ! 234715 234716!NaturalLanguageFormTranslator methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:26'! 234717localeID: anID 234718 id := anID! ! 234719 234720!NaturalLanguageFormTranslator methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:17'! 234721name: formName form: translatedForm 234722 self generics at: formName put: translatedForm. 234723! ! 234724 234725 234726!NaturalLanguageFormTranslator methodsFor: 'i/o' stamp: 'yo 1/13/2005 14:02'! 234727saveFormsOn: aStream 234728 234729 | rr | 234730 rr := ReferenceStream on: aStream. 234731 rr nextPut: {id isoString. generics}. 234732 rr close. 234733! ! 234734 234735 234736!NaturalLanguageFormTranslator methodsFor: 'utilities' stamp: 'yo 1/13/2005 11:35'! 234737translate: aString 234738 234739 ^ (self generics 234740 at: aString ifAbsent: [nil]) deepCopy. 234741 234742 "Do you like to write 'form ifNotNil: [form deepCopy]'?" 234743! ! 234744 234745"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 234746 234747NaturalLanguageFormTranslator class 234748 instanceVariableNames: ''! 234749 234750!NaturalLanguageFormTranslator class methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:13'! 234751cachedTranslations 234752 "CachedTranslations := nil" 234753 ^CachedTranslations ifNil: [CachedTranslations := Dictionary new]! ! 234754 234755!NaturalLanguageFormTranslator class methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:13'! 234756isoLanguage: isoLanguage 234757 "Return the generic language translator as there is no information about the country code" 234758 234759 ^self isoLanguage: isoLanguage isoCountry: nil! ! 234760 234761!NaturalLanguageFormTranslator class methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:13'! 234762isoLanguage: isoLanguage isoCountry: isoCountry 234763 ^self localeID: (LocaleID isoLanguage: isoLanguage isoCountry: isoCountry)! ! 234764 234765!NaturalLanguageFormTranslator class methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:13'! 234766localeID: localeID 234767 ^ self cachedTranslations 234768 at: localeID 234769 ifAbsentPut: [self new localeID: localeID]! ! 234770 234771 234772!NaturalLanguageFormTranslator class methodsFor: 'i/o' stamp: 'yo 1/13/2005 14:02'! 234773loadFormsFrom: aStream 234774 234775 | rr pair inst | 234776 rr := ReferenceStream on: aStream. 234777 pair := rr next. 234778 inst := self localeID: (LocaleID isoString: pair first). 234779 pair second associationsDo: [:assoc | 234780 inst name: assoc key form: assoc value. 234781 ]. 234782 ^ inst. 234783! ! 234784Object subclass: #NaturalLanguageTranslator 234785 instanceVariableNames: 'id generics contexts' 234786 classVariableNames: 'AllKnownPhrases CachedTranslations' 234787 poolDictionaries: '' 234788 category: 'System-Localization'! 234789 234790!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'dgd 8/13/2004 21:12'! 234791displayLanguage 234792 ^ id displayLanguage! ! 234793 234794!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'dgd 10/7/2004 20:50'! 234795displayName 234796 ^ id displayName! ! 234797 234798!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:41'! 234799isoCountry 234800 ^self localeID isoCountry! ! 234801 234802!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:42'! 234803isoLanguage 234804 ^self localeID isoLanguage! ! 234805 234806!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:42'! 234807localeID 234808 ^id! ! 234809 234810!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/21/2004 17:00'! 234811translations 234812 ^self generics! ! 234813 234814!NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/21/2004 17:03'! 234815untranslated 234816 | translations | 234817 translations := self translations. 234818 ^self class allKnownPhrases reject: [:each | translations includesKey: each]! ! 234819 234820 234821!NaturalLanguageTranslator methodsFor: 'filein/fileout' stamp: 'tak 11/16/2004 11:04'! 234822fileOutHeader 234823 ^ '''Translation dictionary'''! ! 234824 234825!NaturalLanguageTranslator methodsFor: 'filein/fileout' stamp: 'tak 11/28/2004 14:50'! 234826fileOutHeaderOn: aStream 234827 aStream nextChunkPut: self fileOutHeader; 234828 cr. 234829 aStream timeStamp; cr. 234830 aStream nextPut: $!!. 234831 aStream nextChunkPut: '(' , self class name , ' localeID: ' , id storeString , ')'. 234832 aStream cr! ! 234833 234834!NaturalLanguageTranslator methodsFor: 'filein/fileout' stamp: 'yo 11/29/2005 11:19'! 234835fileOutOn: aStream 234836 "self current fileOutOn: Transcript. Transcript endEntry" 234837 self fileOutHeaderOn: aStream. 234838 self fileOutOn: aStream keys: nil! ! 234839 234840!NaturalLanguageTranslator methodsFor: 'filein/fileout' stamp: 'yo 11/29/2005 11:19'! 234841fileOutOn: aStream keys: keys 234842 "self current fileOutOn: Transcript. Transcript endEntry" 234843 (keys 234844 ifNil: [generics keys asSortedCollection]) 234845 do: [:key | self 234846 nextChunkPut: (generics associationAt: key) 234847 on: aStream]. 234848 keys 234849 ifNil: [self untranslated 234850 do: [:each | self nextChunkPut: each -> '' on: aStream]]. 234851 aStream nextPut: $!!; 234852 cr! ! 234853 234854!NaturalLanguageTranslator methodsFor: 'filein/fileout' stamp: 'tak 11/16/2004 09:26'! 234855nextChunkPut: anObject on: aStream 234856 | i remainder terminator | 234857 terminator := $!!. 234858 remainder := anObject storeString. 234859 [(i := remainder indexOf: terminator) = 0] 234860 whileFalse: [aStream 234861 nextPutAll: (remainder copyFrom: 1 to: i). 234862 aStream nextPut: terminator. 234863 "double imbedded terminators" 234864 remainder := remainder copyFrom: i + 1 to: remainder size]. 234865 aStream nextPutAll: remainder. 234866 aStream nextPut: terminator; cr.! ! 234867 234868!NaturalLanguageTranslator methodsFor: 'filein/fileout' stamp: 'tak 12/15/2004 16:07'! 234869scanFrom: aStream 234870 "Read a definition of dictionary. 234871 Make sure current locale corresponds my locale id" 234872 | aString newTranslations assoc currentPlatform | 234873 newTranslations := Dictionary new. 234874 currentPlatform := Locale currentPlatform. 234875 [Locale 234876 currentPlatform: (Locale localeID: id). 234877 [aString := aStream nextChunk withSqueakLineEndings. 234878 aString size > 0] 234879 whileTrue: [assoc := Compiler evaluate: aString. 234880 assoc value = '' 234881 ifTrue: [self class registerPhrase: assoc key] 234882 ifFalse: [newTranslations add: assoc]]] 234883 ensure: [Locale currentPlatform: currentPlatform]. 234884 self mergeTranslations: newTranslations! ! 234885 234886!NaturalLanguageTranslator methodsFor: 'filein/fileout' stamp: 'yo 2/25/2005 09:37'! 234887writeAsMimeString 234888 234889 | fileName fileStream tmpStream s2 gzs | 234890 tmpStream := MultiByteBinaryOrTextStream on: ''. 234891 tmpStream converter: UTF8TextConverter new. 234892 self fileOutOn: tmpStream. 234893 s2 := RWBinaryOrTextStream on: ''. 234894 gzs := GZipWriteStream on: s2. 234895 tmpStream reset. 234896 gzs nextPutAll: (tmpStream binary contentsOfEntireFile asString) contents. 234897 gzs close. 234898 s2 reset. 234899 234900 fileName := id isoString, '.translation.gz.mime'. 234901 fileStream := FileStream newFileNamed: fileName. 234902 fileStream nextPutAll: (Base64MimeConverter mimeEncode: s2) contents. 234903 fileStream close. 234904! ! 234905 234906 234907!NaturalLanguageTranslator methodsFor: 'initialization' stamp: 'mir 7/15/2004 14:41'! 234908localeID: anID 234909 id := anID! ! 234910 234911 234912!NaturalLanguageTranslator methodsFor: 'printing' stamp: 'nk 8/29/2004 10:51'! 234913printOn: aStream 234914 aStream nextPutAll: self class name; nextPut: $(; print: self localeID; nextPut: $)! ! 234915 234916 234917!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'mir 7/21/2004 18:02'! 234918checkPhrase: phrase translation: translation! ! 234919 234920!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 7/30/2004 13:03'! 234921phrase: phraseString translation: translationString 234922 self generics at: phraseString put: translationString asString. 234923 self changed: #translations. 234924 self changed: #untranslated.! ! 234925 234926!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 8/2/2004 12:27'! 234927rawPhrase: phraseString translation: translationString 234928 self generics at: phraseString put: translationString asString. 234929! ! 234930 234931!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 1/14/2005 16:25'! 234932rawRemoveUntranslated: untranslated 234933 234934 self class allKnownPhrases removeKey: untranslated ifAbsent: []. 234935 self changed: #untranslated.! ! 234936 234937!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 8/1/2004 01:07'! 234938removeTranslationFor: phraseString 234939 self generics removeKey: phraseString ifAbsent: []. 234940 self changed: #translations. 234941 self changed: #untranslated.! ! 234942 234943!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 1/14/2005 16:25'! 234944removeUntranslated: untranslated 234945 234946 self class allKnownPhrases removeKey: untranslated ifAbsent: []. 234947! ! 234948 234949!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'em 3/23/2005 12:08'! 234950translate: aString 234951 ^self generics 234952 at: aString 234953 ifAbsent: [self class registeredPhraseFor: aString. 234954 self changed: #untranslated. 234955 self localeID hasParent 234956 ifTrue: [(self class localeID: self localeID parent) translate: aString] 234957 ifFalse: [aString]]! ! 234958 234959!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'mir 6/30/2004 20:22'! 234960translate: aString in: aContext! ! 234961 234962!NaturalLanguageTranslator methodsFor: 'translation' stamp: 'mir 7/15/2004 14:58'! 234963translationFor: aString 234964 ^self translate: aString! ! 234965 234966 234967!NaturalLanguageTranslator methodsFor: 'user interface' stamp: 'dgd 8/13/2004 21:54'! 234968defaultBackgroundColor 234969 "answer the receiver's defaultBackgroundColor for views" 234970 ^ Color cyan! ! 234971 234972 234973!NaturalLanguageTranslator methodsFor: 'private' stamp: 'mir 6/30/2004 20:23'! 234974generics 234975 ^generics ifNil: [generics := Dictionary new]! ! 234976 234977 234978!NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'yo 7/30/2004 13:00'! 234979loadFromFileNamed: fileNameString 234980 "Load translations from an external file" 234981 234982 | stream | 234983 [stream := FileStream readOnlyFileNamed: fileNameString. 234984 self loadFromStream: stream] 234985 ensure: [stream close]. 234986 self changed: #translations. 234987 self changed: #untranslated. 234988! ! 234989 234990!NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'tak 11/16/2004 12:37'! 234991loadFromRefStream: stream 234992 "Load translations from an external file" 234993 | loadedArray refStream | 234994 refStream := ReferenceStream on: stream. 234995 [loadedArray := refStream next] 234996 ensure: [refStream close]. 234997 self processExternalObject: loadedArray ! ! 234998 234999!NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'em 3/30/2005 14:32'! 235000loadFromStream: stream 235001 "Load translations from an external file" 235002 | header isFileIn | 235003 header := '''Translation dictionary'''. 235004 isFileIn := (stream next: header size) 235005 = header. 235006 stream reset. 235007 isFileIn 235008 ifTrue: [stream fileInAnnouncing: 'Loading ' translated, stream localName] 235009 ifFalse: [self loadFromRefStream: stream]! ! 235010 235011!NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'yo 8/2/2004 12:27'! 235012mergeTranslations: newTranslations 235013 "Merge a new set of translations into the exiting table. 235014 Overwrites existing entries." 235015 235016 newTranslations keysAndValuesDo: [:key :value | 235017 self rawPhrase: (self class registeredPhraseFor: key) translation: value]. 235018 self changed: #translations. 235019 self changed: #untranslated.! ! 235020 235021!NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'mir 7/15/2004 20:04'! 235022processExternalObject: anArray 235023 "pivate - process the external object" 235024 235025 "new format -> {translations. untranslated}" 235026 235027 anArray second do: [:each | self class registerPhrase: each]. 235028 235029 self mergeTranslations: anArray first! ! 235030 235031!NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'yo 2/17/2005 15:45'! 235032saveToFileNamed: fileNameString 235033 "save the receiver's translations to a file named fileNameString" 235034 | stream | 235035 "Set true if you need to save as binary" 235036 false 235037 ifTrue: [stream := ReferenceStream fileNamed: fileNameString. 235038 stream nextPut: {self translations. self untranslated}. 235039 stream close. 235040 ^ self]. 235041 stream := FileStream fileNamed: fileNameString. 235042 [self fileOutOn: stream] 235043 ensure: [stream close]! ! 235044 235045"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 235046 235047NaturalLanguageTranslator class 235048 instanceVariableNames: ''! 235049 235050!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'dgd 8/24/2004 20:20'! 235051availableLanguageLocaleIDs 235052 "Return the locale ids for the currently available languages. 235053 Meaning those which either internally or externally have 235054 translations available." 235055 "NaturalLanguageTranslator availableLanguageLocaleIDs" 235056 ^ CachedTranslations values collect:[:each | each localeID]! ! 235057 235058!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'dgd 8/24/2004 19:39'! 235059current 235060 ^ LocaleID current translator 235061 235062! ! 235063 235064!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'nk 8/29/2004 14:23'! 235065default 235066 ^self localeID: (LocaleID default) 235067! ! 235068 235069!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:36'! 235070isoLanguage: isoLanguage 235071 "Return the generic language translator as there is no information about the country code" 235072 235073 ^self isoLanguage: isoLanguage isoCountry: nil! ! 235074 235075!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:36'! 235076isoLanguage: isoLanguage isoCountry: isoCountry 235077 ^self localeID: (LocaleID isoLanguage: isoLanguage isoCountry: isoCountry)! ! 235078 235079!NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'dgd 8/24/2004 19:18'! 235080localeID: localeID 235081 ^ self cachedTranslations 235082 at: localeID 235083 ifAbsentPut: [self new localeID: localeID]! ! 235084 235085 235086!NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'mir 8/11/2004 10:52'! 235087fileReaderServicesForFile: fullName suffix: suffix 235088 "Answer the file services associated with given file" 235089 ^ (suffix = self translationSuffix) | (suffix = '*') 235090 ifTrue: [{self serviceMergeLanguageTranslations}] 235091 ifFalse: [#()]! ! 235092 235093!NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'dc 5/30/2008 10:17'! 235094loadForLocaleIsoString: localeString fromGzippedMimeLiteral: mimeString 235095 "merge the translation from the mime literal." 235096 | stream localeID translator gs rbStream s currentPlatform | 235097 s := Base64MimeConverter mimeDecodeToBytes: mimeString readStream. 235098 s reset. 235099 gs := GZipReadStream on: s. 235100 rbStream := MultiByteBinaryOrTextStream with: gs contents asString. 235101 rbStream converter: UTF8TextConverter new. 235102 rbStream reset. 235103 localeID := LocaleID isoString: localeString. 235104 currentPlatform := Locale currentPlatform. 235105 235106 [ Locale currentPlatform: (Locale localeID: localeID). 235107 stream := rbStream contents readStream ] ensure: [ Locale currentPlatform: currentPlatform ]. 235108 translator := self localeID: localeID. 235109 translator loadFromStream: stream. 235110 LanguageEnvironment resetKnownEnvironments! ! 235111 235112!NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'yo 2/24/2005 21:04'! 235113mergeTranslationFileNamed: fileFullNameString 235114 "merge the translation in the file named fileFullNameString" 235115 235116 | stream localeID translator | 235117 stream := FileStream readOnlyFileNamed: fileFullNameString. 235118 [localeID := LocaleID isoString: stream localName sansPeriodSuffix. 235119 translator := self localeID: localeID. 235120 translator loadFromStream: stream] 235121 ensure: [stream close]. 235122 LanguageEnvironment resetKnownEnvironments. 235123 235124! ! 235125 235126!NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'mir 7/21/2004 13:45'! 235127serviceMergeLanguageTranslations 235128 "Answer a service for merging of translation files" 235129 ^ SimpleServiceEntry 235130 provider: self 235131 label: 'merge the translation file' 235132 selector: #mergeTranslationFileNamed: 235133 description: 'merge the translation file into the language named like the file' 235134 buttonLabel: 'merge'! ! 235135 235136!NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'mir 7/21/2004 13:45'! 235137services 235138 "Answer potential file services associated with this class" 235139 ^ {self serviceMergeLanguageTranslations}! ! 235140 235141 235142!NaturalLanguageTranslator class methodsFor: 'initialization' stamp: 'gvc 7/6/2007 10:30'! 235143initialize 235144 "NaturalLanguageTranslator initialize" 235145 235146 FileList registerFileReader: self. 235147 Smalltalk addToStartUpList: NaturalLanguageTranslator after: PasteUpMorph 235148 "since may use progress bar" 235149! ! 235150 235151!NaturalLanguageTranslator class methodsFor: 'initialization' stamp: 'mir 7/15/2004 19:48'! 235152resetCaches 235153 "NaturalLanguageTranslator resetCaches" 235154 235155 CachedTranslations := nil. 235156! ! 235157 235158!NaturalLanguageTranslator class methodsFor: 'initialization' stamp: 'mir 8/31/2005 23:37'! 235159startUp: resuming 235160 | defaultID | 235161 resuming 235162 ifFalse: [^ self]. 235163 "" 235164 defaultID := LocaleID current. 235165 self cachedTranslations 235166 at: defaultID 235167 ifAbsent: [self localeID: defaultID]. 235168 "" 235169 self loadAvailableExternalLocales! ! 235170 235171 235172!NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 7/15/2004 19:58'! 235173allKnownPhrases 235174 ^AllKnownPhrases ifNil: [AllKnownPhrases := Dictionary new: 2051]! ! 235175 235176!NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 7/13/2004 00:06'! 235177cachedTranslations 235178 "CachedTranslations := nil" 235179 ^CachedTranslations ifNil: [CachedTranslations := Dictionary new]! ! 235180 235181!NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 8/31/2005 16:55'! 235182cleanUpCache 235183 "NaturalLanguageTranslator cleanUpCache" 235184 235185 self cachedTranslations keys do: [:key | 235186 key isoLanguage size > 2 ifTrue: [self cachedTranslations removeKey: key]]! ! 235187 235188!NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 7/15/2004 20:02'! 235189registerPhrase: phrase 235190 "Using a Dictionary so we can lookup existing string instead of creating needless copies when loading a translation." 235191 self allKnownPhrases at: phrase put: phrase! ! 235192 235193!NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 7/21/2004 14:18'! 235194registeredPhraseFor: phrase 235195 "Using a Dictionary so we can lookup existing string instead of creating needless copies when loading a translation." 235196 ^self allKnownPhrases at: phrase ifAbsentPut: [phrase]! ! 235197 235198!NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 8/11/2004 10:52'! 235199translationSuffix 235200 ^'translation'! ! 235201 235202 235203!NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'nk 8/21/2004 13:03'! 235204directoryForLanguage: isoLanguage country: isoCountry create: createDir 235205 "Try to locate the <prefs>/locale/<language>{/<country>} folder. 235206 If createDir is set, create the path down to country or language, depending on wether it's specified.. 235207 Return the directory for country or language depending on specification. 235208 If neither exists, nil" 235209 235210 "NaturalLanguageTranslator directoryForLanguage: 'es' country: nil create: true" 235211 "NaturalLanguageTranslator directoryForLanguage: 'de' country: 'DE' create: true" 235212 "NaturalLanguageTranslator directoryForLanguage: 'en' country: 'US' create: false" 235213 "NaturalLanguageTranslator directoryForLanguage: 'en' country: nil create: true" 235214 235215 "If this fails, there is nothing we can do about it here" 235216 | localeDir countryDir languageDir | 235217 localeDir := self localeDirCreate: createDir. 235218 localeDir ifNil: [^nil]. 235219 235220 isoCountry ifNil: [ 235221 languageDir := localeDir directoryNamed: isoLanguage. 235222 createDir 235223 ifTrue: [languageDir assureExistence]. 235224 ^languageDir exists 235225 ifTrue: [languageDir] 235226 ifFalse: [nil]]. 235227 235228 countryDir := languageDir directoryNamed: isoCountry. 235229 createDir 235230 ifTrue: [countryDir assureExistence]. 235231 235232 ^countryDir exists 235233 ifTrue: [countryDir] 235234 ifFalse: [nil]! ! 235235 235236!NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'mir 8/11/2004 10:44'! 235237directoryForLocaleID: localeID create: createDir 235238 "Try to locate the <prefs>/locale/<language>{/<country>} folder. 235239 If createDir is set, create the path down to country or language, depending on locale. 235240 Return the directory for country or language depending on locale. 235241 If neither exists, nil" 235242 235243 "NaturalLanguageTranslator directoryForLanguage: 'de' country: nil readOnly: true" 235244 "NaturalLanguageTranslator directoryForLanguage: 'de' country: 'DE' readOnly: true" 235245 "NaturalLanguageTranslator directoryForLanguage: 'en' country: 'US' readOnly: false" 235246 "NaturalLanguageTranslator directoryForLanguage: 'en' country: nil readOnly: true" 235247 235248 ^self directoryForLanguage: localeID isoLanguage country: localeID isoCountry create: createDir! ! 235249 235250!NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'mir 8/25/2004 11:57'! 235251loadAvailableExternalLocales 235252 "private - register locales IDs based on the content of the <prefs>/locale/ directory" 235253 | localeDir | 235254 localeDir := self localeDirCreate: false. 235255 localeDir ifNil: [^ #()]. 235256 235257 localeDir directoryNames 235258 do: [:langDirName | 235259 | langDir | 235260 langDir := localeDir directoryNamed: langDirName. 235261 235262 (langDir fileNamesMatching: '*.' , self translationSuffix) 235263 ifNotEmpty: [self loadTranslatorForIsoLanguage: langDirName isoCountry: nil]. 235264 235265 langDir directoryNames 235266 do: [:countryDirName | 235267 | countryDir | 235268 countryDir := langDirName directoryNamed: countryDirName. 235269 (countryDir fileNamesMatching: '*.' , self translationSuffix) 235270 ifNotEmpty: [self loadTranslatorForIsoLanguage: langDirName isoCountry: countryDirName] 235271 ] 235272 ]. 235273! ! 235274 235275!NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'nk 8/21/2004 13:00'! 235276loadExternalTranslationsFor: translator 235277 "Try to load translations from external external files. 235278 The files are located in the <prefs>/locale/<language>{/<country>} folder. 235279 There can be more than one file for each location, so applications can install their own partial translation tables. All files in the specific folder are loaded." 235280 235281 | translationDir | 235282 translationDir := self directoryForLocaleID: translator localeID create: false. 235283 translationDir ifNil: [ ^nil ]. 235284 (translationDir fileNamesMatching: '*.' , self translationSuffix) 235285 do: [:fileName | translator loadFromFileNamed: (translationDir fullNameFor: fileName)]! ! 235286 235287!NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'mir 8/25/2004 11:59'! 235288loadTranslatorForIsoLanguage: isoLanguage isoCountry: isoCountry 235289 "private - load the translations from <prefs>/locale/ directory 235290 the procedure is to assure the existence of a translator for the 235291 given language/country and then load the external translations for this translator" 235292 235293 | translator | 235294 translator := self localeID: (LocaleID isoLanguage: isoLanguage isoCountry: isoCountry). 235295 235296 self loadExternalTranslationsFor: translator! ! 235297 235298!NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'mir 8/25/2004 12:03'! 235299localeDirCreate: createDir 235300 "Try to locate the <prefs>/locale/ folder. 235301 If createDir is set, try to create the path. 235302 If it doesn't exist, return nil" 235303 235304 "If this fails, there is nothing we can do about it here" 235305 | prefDir localeDir | 235306 (createDir not 235307 and: [ExternalSettings preferenceDirectory isNil]) 235308 ifTrue: [^ nil]. 235309 235310 prefDir := ExternalSettings assuredPreferenceDirectory. 235311 prefDir exists 235312 ifFalse: [^nil]. 235313 235314 235315 localeDir := prefDir directoryNamed: 'locale'. 235316 createDir 235317 ifTrue: [localeDir assureExistence]. 235318 ^localeDir exists 235319 ifTrue: [localeDir] 235320 ifFalse: [nil]! ! 235321LanguageEnvironment subclass: #NepaleseEnvironment 235322 instanceVariableNames: '' 235323 classVariableNames: '' 235324 poolDictionaries: '' 235325 category: 'Multilingual-Languages'! 235326 235327!NepaleseEnvironment methodsFor: 'as yet unclassified' stamp: 'pavel.krivanek 7/6/2009 12:56'! 235328isFontAvailable 235329 235330 ^ (Smalltalk classNamed: #RomePluginCanvas) 235331 ifNil: [false ] ifNotNil: [:canvasClass | canvasClass pangoIsAvailable]. 235332! ! 235333 235334"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 235335 235336NepaleseEnvironment class 235337 instanceVariableNames: ''! 235338 235339!NepaleseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 6/12/2008 17:24'! 235340leadingChar 235341 235342 ^ 15. 235343! ! 235344 235345!NepaleseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 6/19/2008 13:22'! 235346supportedLanguages 235347 "Return the languages that this class supports. 235348 Any translations for those languages will use this class as their environment." 235349 235350 ^#('ne')! ! 235351 235352!NepaleseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 6/12/2008 17:56'! 235353systemConverterClass 235354 235355 ^ UTF8TextConverter. 235356! ! 235357Object subclass: #NetNameResolver 235358 instanceVariableNames: '' 235359 classVariableNames: 'DefaultHostName HaveNetwork ResolverBusy ResolverError ResolverMutex ResolverReady ResolverSemaphore ResolverUninitialized UseOldNetwork' 235360 poolDictionaries: '' 235361 category: 'Network-Kernel'! 235362!NetNameResolver commentStamp: '<historical>' prior: 0! 235363This class implements TCP/IP style network name lookup and translation facilities. 235364 235365Attempt to keep track of whether there is a network available. 235366HaveNetwork true if last attempt to contact the network was successful. 235367LastContact Time of that contact (totalSeconds). 235368haveNetwork returns true, false, or #expired. True means there was contact in the last 30 minutes. False means contact failed or was false last time we asked. Get out of false state by making contact with a server in some way (FileList or updates).! 235369 235370 235371"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 235372 235373NetNameResolver class 235374 instanceVariableNames: ''! 235375 235376!NetNameResolver class methodsFor: 'address string utils' stamp: 'PeterHugossonMiller 9/3/2009 10:10'! 235377stringFromAddress: addr 235378 "Return a string representing the given host address as four decimal bytes delimited with decimal points." 235379 "NetNameResolver stringFromAddress: NetNameResolver localHostAddress" 235380 235381 | s | 235382 s := String new writeStream. 235383 1 to: 3 do: [ :i | (addr at: i) printOn: s. s nextPut: $.]. 235384 (addr at: 4) printOn: s. 235385 ^ s contents 235386! ! 235387 235388 235389!NetNameResolver class methodsFor: 'class initialization' stamp: 'jm 9/17/97 16:18'! 235390initialize 235391 "NetNameResolver initialize" 235392 "Note: On the Mac, the name resolver is asynchronous (i.e., Squeak can do other things while it is working), but can only handle one request at a time. On other platforms, such as Unix, the resolver is synchronous; a call to, say, the name lookup primitive will block all Squeak processes until it returns." 235393 235394 "Resolver Status Values" 235395 ResolverUninitialized := 0. "network is not initialized" 235396 ResolverReady := 1. "resolver idle, last request succeeded" 235397 ResolverBusy := 2. "lookup in progress" 235398 ResolverError := 3. "resolver idle, last request failed" 235399 235400 DefaultHostName := ''. 235401! ! 235402 235403 235404!NetNameResolver class methodsFor: 'lookup' stamp: 'mir 6/26/2007 18:29'! 235405addressForName: hostName 235406 "NetNameResolver addressForName: 'impara.de' " 235407 "NetNameResolver addressForName: 'localhost' " 235408 "NetNameResolver addressForName: '127.0.0.1' " 235409 | addresses | 235410 self useOldNetwork 235411 ifTrue: [^self oldAddressForName: hostName]. 235412 addresses := self addressesForName: hostName. 235413 ^addresses 235414 ifEmpty: [nil] 235415 ifNotEmpty: [addresses first socketAddress]! ! 235416 235417!NetNameResolver class methodsFor: 'lookup' stamp: 'mir 6/17/2007 19:27'! 235418addressesForName: hostName 235419 "NetNameResolver addressesForName: 'impara.de' " 235420 | adresses | 235421 adresses := SocketAddressInformation 235422 forHost: hostName 235423 service: '' 235424 flags: 0 235425 addressFamily: 0 235426 socketType: SocketAddressInformation socketTypeStream 235427 protocol: SocketAddressInformation protocolTCP. 235428 ^adresses! ! 235429 235430!NetNameResolver class methodsFor: 'lookup' stamp: 'mir 7/30/2007 11:37'! 235431localAddressString 235432 "Return a string representing the local host address as four decimal bytes delimited with decimal points." 235433 "NetNameResolver localAddressString" 235434 235435 self useOldNetwork 235436 ifTrue: [^self stringFromAddress: self primLocalAddress]. 235437 ^self localHostAddress hostNumber! ! 235438 235439!NetNameResolver class methodsFor: 'lookup' stamp: 'bf 7/19/2007 13:15'! 235440localHostAddress 235441 "Return the local address of this host." 235442 "NetNameResolver localHostAddress" 235443 235444 ^NetNameResolver addressForName: self localHostName! ! 235445 235446!NetNameResolver class methodsFor: 'lookup' stamp: 'mir 6/17/2007 19:32'! 235447localHostName 235448 "Return the local name of this host." 235449 "NetNameResolver localHostName" 235450 235451 | host | 235452 host := String new: NetNameResolver primHostNameSize. 235453 NetNameResolver primHostNameResult: host. 235454 ^host! ! 235455 235456 235457!NetNameResolver class methodsFor: 'lookups-old' stamp: 'michael.rueger 3/30/2009 13:49'! 235458addressForName: hostName timeout: secs 235459 "Look up the given host name and return its address. Return nil if the address is not found in the given number of seconds." 235460 "NetNameResolver addressForName: 'create.ucsb.edu' timeout: 30" 235461 "NetNameResolver addressForName: '100000jobs.de' timeout: 30" 235462 "NetNameResolver addressForName: '1.7.6.4' timeout: 30" 235463 "NetNameResolver addressForName: '' timeout: 30 (This seems to return nil?)" 235464 235465 | deadline result | 235466 self initializeNetwork. 235467 self useOldNetwork 235468 ifFalse: [^self addressForName: hostName]. 235469 "check if this is a valid numeric host address (e.g. 1.2.3.4)" 235470 result := self addressFromString: hostName. 235471 result isNil ifFalse: [^result asSocketAddress]. 235472 235473 "Look up a host name, including ones that start with a digit (e.g. 100000jobs.de or squeak.org)" 235474 deadline := Time millisecondClockValue + (secs * 1000). 235475 "Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction." 235476 self resolverMutex 235477 critical: [ 235478 (self waitForResolverReadyUntil: deadline) 235479 ifTrue: [ 235480 self primStartLookupOfName: hostName. 235481 (self waitForCompletionUntil: deadline) 235482 ifTrue: [result := self primNameLookupResult] 235483 ifFalse: [(NameLookupFailure hostName: hostName) signal: 'Could not resolve the server named: ', hostName]] 235484 ifFalse: [(NameLookupFailure hostName: hostName) signal: 'Could not resolve the server named: ', hostName]]. 235485 ^result asSocketAddress! ! 235486 235487!NetNameResolver class methodsFor: 'lookups-old' stamp: 'PeterHugossonMiller 9/2/2009 16:12'! 235488addressFromString: addressString 235489 "Return the internet address represented by the given string. The string should contain four positive decimal integers delimited by periods, commas, or spaces, where each integer represents one address byte. Return nil if the string is not a host address in an acceptable format." 235490 "NetNameResolver addressFromString: '1.2.3.4'" 235491 "NetNameResolver addressFromString: '1,2,3,4'" 235492 "NetNameResolver addressFromString: '1 2 3 4'" 235493 235494 | newAddr s byte delimiter | 235495 newAddr := ByteArray new: 4. 235496 s := addressString readStream. 235497 s skipSeparators. 235498 1 to: 4 do: [:i | 235499 byte := self readDecimalByteFrom: s. 235500 byte = nil ifTrue: [^ nil]. 235501 newAddr at: i put: byte. 235502 i < 4 ifTrue: [ 235503 delimiter := s next. 235504 ((delimiter = $.) or: [(delimiter = $,) or: [delimiter = $ ]]) 235505 ifFalse: [^ nil]]]. 235506 ^ newAddr 235507! ! 235508 235509!NetNameResolver class methodsFor: 'lookups-old' stamp: 'mir 6/26/2007 18:53'! 235510oldAddressForName: aString 235511 "NetNameResolver oldAddressForName: 'vpri.org' " 235512 ^self addressForName: aString timeout: 60! ! 235513 235514!NetNameResolver class methodsFor: 'lookups-old' stamp: 'jm 9/17/97 16:26'! 235515promptUserForHostAddress 235516 "Ask the user for a host name and return its address." 235517 "NetNameResolver promptUserForHostAddress" 235518 235519 ^ NetNameResolver promptUserForHostAddressDefault: '' 235520! ! 235521 235522!NetNameResolver class methodsFor: 'lookups-old' stamp: 'DamienCassou 9/29/2009 13:03'! 235523promptUserForHostAddressDefault: defaultName 235524 "Ask the user for a host name and return its address. If the default name is the empty string, use the last host name as the default." 235525 "NetNameResolver promptUserForHostAddressDefault: ''" 235526 235527 | default hostName serverAddr | 235528 defaultName isEmpty 235529 ifTrue: [default := DefaultHostName] 235530 ifFalse: [default := defaultName]. 235531 hostName := UIManager default 235532 request: 'Host name or address?' 235533 initialAnswer: default. 235534 hostName isEmptyOrNil ifTrue: [^ 0]. 235535 serverAddr := NetNameResolver addressForName: hostName timeout: 15. 235536 hostName size > 0 ifTrue: [DefaultHostName := hostName]. 235537 ^ serverAddr! ! 235538 235539!NetNameResolver class methodsFor: 'lookups-old' stamp: 'JMM 5/3/2000 11:25'! 235540resolverError 235541 ^self primNameResolverError 235542! ! 235543 235544!NetNameResolver class methodsFor: 'lookups-old' stamp: 'JMM 5/3/2000 11:25'! 235545resolverStatus 235546 ^self primNameResolverStatus 235547! ! 235548 235549 235550!NetNameResolver class methodsFor: 'network initialization' stamp: 'michael.rueger 3/30/2009 11:56'! 235551initializeNetwork 235552 "Initialize the network drivers and record the semaphore to be used by the resolver. Do nothing if the network is already initialized. Evaluate the given block if network initialization fails." 235553 "NetNameResolver initializeNetwork" 235554 235555 | semaIndex | 235556 self resolverStatus = ResolverUninitialized 235557 ifFalse: [^HaveNetwork := true]. "network is already initialized" 235558 235559 HaveNetwork := false. "in case abort" 235560 ResolverSemaphore := Semaphore new. 235561 semaIndex := Smalltalk registerExternalObject: ResolverSemaphore. 235562 235563 "result is nil if network initialization failed, self if it succeeds" 235564 (self primInitializeNetwork: semaIndex) 235565 ifNil: [NoNetworkError signal: 'failed network initialization'] 235566 ifNotNil: [HaveNetwork := true]. 235567 235568 UseOldNetwork := [NetNameResolver primHostNameSize. false] 235569 on: Error 235570 do: [:ex | ex return: true] 235571! ! 235572 235573!NetNameResolver class methodsFor: 'network initialization' stamp: 'ar 2/2/2001 15:09'! 235574primInitializeNetwork: resolverSemaIndex 235575 "Initialize the network drivers on platforms that need it, such as the Macintosh, and return nil if network initialization failed or the reciever if it succeeds. Since mobile computers may not always be connected to a network, this method should NOT be called automatically at startup time; rather, it should be called when first starting a networking application. It is a noop if the network driver has already been initialized. If non-zero, resolverSemaIndex is the index of a VM semaphore to be associated with the network name resolver. This semaphore will be signalled when the resolver status changes, such as when a name lookup query is completed." 235576 "Note: some platforms (e.g., Mac) only allow only one name lookup query at a time, so a manager process should be used to serialize resolver lookup requests." 235577 235578 <primitive: 'primitiveInitializeNetwork' module: 'SocketPlugin'> 235579 ^ nil "return nil if primitive fails" 235580! ! 235581 235582 235583!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 235584primAbortLookup 235585 "Abort the current lookup operation, freeing the name resolver for the next query." 235586 235587 <primitive: 'primitiveResolverAbortLookup' module: 'SocketPlugin'> 235588 self primitiveFailed 235589! ! 235590 235591!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 235592primAddressLookupResult 235593 "Return the host name found by the last host address lookup. Returns nil if the last lookup was unsuccessful." 235594 235595 <primitive: 'primitiveResolverAddressLookupResult' module: 'SocketPlugin'> 235596 self primitiveFailed 235597! ! 235598 235599!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 235600primLocalAddress 235601 "Return the local address of this host." 235602 235603 <primitive: 'primitiveResolverLocalAddress' module: 'SocketPlugin'> 235604 self primitiveFailed 235605! ! 235606 235607!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 235608primNameLookupResult 235609 "Return the host address found by the last host name lookup. Returns nil if the last lookup was unsuccessful." 235610 235611 <primitive: 'primitiveResolverNameLookupResult' module: 'SocketPlugin'> 235612 self primitiveFailed 235613! ! 235614 235615!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 235616primNameResolverError 235617 "Return an integer reflecting the error status of the last network name resolver request. Zero means no error." 235618 235619 <primitive: 'primitiveResolverError' module: 'SocketPlugin'> 235620 self primitiveFailed 235621! ! 235622 235623!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 235624primNameResolverStatus 235625 "Return an integer reflecting the status of the network name resolver. For a list of possible values, see the comment in the 'initialize' method of this class." 235626 235627 <primitive: 'primitiveResolverStatus' module: 'SocketPlugin'> 235628 self primitiveFailed 235629! ! 235630 235631!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 235632primStartLookupOfAddress: hostAddr 235633 "Look up the given host address in the Domain Name Server to find its name. This call is asynchronous. To get the results, wait for it to complete or time out and then use primAddressLookupResult." 235634 235635 <primitive: 'primitiveResolverStartAddressLookup' module: 'SocketPlugin'> 235636 self primitiveFailed 235637! ! 235638 235639!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 235640primStartLookupOfName: hostName 235641 "Look up the given host name in the Domain Name Server to find its address. This call is asynchronous. To get the results, wait for it to complete or time out and then use primNameLookupResult." 235642 235643 <primitive: 'primitiveResolverStartNameLookup' module: 'SocketPlugin'> 235644 self primitiveFailed 235645! ! 235646 235647 235648!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/8/2007 18:00'! 235649primGetAddressInfoFamily 235650 235651 <primitive: 'primitiveResolverGetAddressInfoFamily' module: 'SocketPlugin'> 235652 self primitiveFailed 235653! ! 235654 235655!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/8/2007 17:24'! 235656primGetAddressInfoHost: hostName service: servName flags: flags family: family type: type protocol: protocol 235657 235658 <primitive: 'primitiveResolverGetAddressInfo' module: 'SocketPlugin'> 235659 self primitiveFailed 235660! ! 235661 235662!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/8/2007 18:19'! 235663primGetAddressInfoNext 235664 235665 <primitive: 'primitiveResolverGetAddressInfoNext' module: 'SocketPlugin'> 235666 self primitiveFailed 235667! ! 235668 235669!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/8/2007 18:00'! 235670primGetAddressInfoProtocol 235671 235672 <primitive: 'primitiveResolverGetAddressInfoProtocol' module: 'SocketPlugin'> 235673 self primitiveFailed 235674! ! 235675 235676!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/8/2007 17:41'! 235677primGetAddressInfoResult: socketAddress 235678 235679 <primitive: 'primitiveResolverGetAddressInfoResult' module: 'SocketPlugin'> 235680 self primitiveFailed 235681! ! 235682 235683!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/8/2007 17:30'! 235684primGetAddressInfoSize 235685 235686 <primitive: 'primitiveResolverGetAddressInfoSize' module: 'SocketPlugin'> 235687 self primitiveFailed 235688! ! 235689 235690!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/8/2007 18:00'! 235691primGetAddressInfoType 235692 235693 <primitive: 'primitiveResolverGetAddressInfoType' module: 'SocketPlugin'> 235694 self primitiveFailed 235695! ! 235696 235697!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/9/2007 10:36'! 235698primGetNameInfo: socketAddress flags: flags 235699 235700 <primitive: 'primitiveResolverGetNameInfo' module: 'SocketPlugin'> 235701 flags == 0 ifTrue: [^self primGetNameInfo: socketAddress 235702 flags: SocketAddressInformation numericFlag]. 235703 self primitiveFailed! ! 235704 235705!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/8/2007 18:34'! 235706primGetNameInfoHostResult: aString 235707 235708 <primitive: 'primitiveResolverGetNameInfoHostResult' module: 'SocketPlugin'> 235709 self primitiveFailed 235710! ! 235711 235712!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/8/2007 18:34'! 235713primGetNameInfoHostSize 235714 235715 <primitive: 'primitiveResolverGetNameInfoHostSize' module: 'SocketPlugin'> 235716 self primitiveFailed 235717! ! 235718 235719!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/8/2007 18:35'! 235720primGetNameInfoServiceResult: aString 235721 235722 <primitive: 'primitiveResolverGetNameInfoServiceResult' module: 'SocketPlugin'> 235723 self primitiveFailed 235724! ! 235725 235726!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/8/2007 18:34'! 235727primGetNameInfoServiceSize 235728 235729 <primitive: 'primitiveResolverGetNameInfoServiceSize' module: 'SocketPlugin'> 235730 self primitiveFailed 235731! ! 235732 235733!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/9/2007 09:05'! 235734primHostNameResult: aString 235735 235736 <primitive: 'primitiveResolverHostNameResult' module: 'SocketPlugin'> 235737 self primitiveFailed 235738! ! 235739 235740!NetNameResolver class methodsFor: 'primitives-ipv6' stamp: 'ikp 6/9/2007 09:04'! 235741primHostNameSize 235742 235743 <primitive: 'primitiveResolverHostNameSize' module: 'SocketPlugin'> 235744 self primitiveFailed 235745! ! 235746 235747 235748!NetNameResolver class methodsFor: 'tests' stamp: 'michael.rueger 3/27/2009 16:55'! 235749testIPv6 235750 "NetNameResolver testIPv6" 235751 | infos size host serverSocket listeningSocket clientSocket | 235752 World findATranscript: World currentEvent. 235753 Transcript clear. 235754 "Transcript show: SmalltalkImage current listLoadedModules; cr." 235755 self initializeNetwork. 235756 Transcript show: '---- host name ----'; cr. 235757 size := NetNameResolver primHostNameSize. 235758 host := String new: size. 235759 NetNameResolver primHostNameResult: host. 235760 Transcript show: host; cr. 235761 235762 Transcript show: '---- localhost defaults: loopback and wildcard addresses ----'; cr. 235763 Transcript show: (SocketAddress loopbacks) printString; cr. 235764 Transcript show: (SocketAddress wildcards) printString; cr. 235765 Transcript show: (SocketAddress loopback4) printString; cr. 235766 Transcript show: (SocketAddress wildcard4) printString; cr. 235767 Transcript show: '---- impossible constraints ----'; cr. 235768 Transcript show: (SocketAddressInformation 235769 forHost: 'localhost' service: 'echo' flags: 0 235770 addressFamily: 0 235771 socketType: SocketAddressInformation socketTypeDGram 235772 protocol: SocketAddressInformation protocolTCP) printString; cr. 235773 Transcript show: '---- INET4 client-server ----'; cr. 235774 Transcript show: (infos := SocketAddressInformation 235775 forHost: '' service: '4242' 235776 flags: SocketAddressInformation passiveFlag 235777 addressFamily: SocketAddressInformation addressFamilyINET4 235778 socketType: SocketAddressInformation socketTypeStream 235779 protocol: SocketAddressInformation protocolTCP) printString; cr. 235780 listeningSocket := infos first listenWithBacklog: 5. 235781 Transcript show: (infos := SocketAddressInformation 235782 forHost: 'localhost' service: '4242' 235783 flags: 0 235784 addressFamily: SocketAddressInformation addressFamilyINET4 235785 socketType: SocketAddressInformation socketTypeStream 235786 protocol: SocketAddressInformation protocolTCP) printString; cr. 235787 clientSocket := infos first connect. 235788 serverSocket := listeningSocket accept. 235789 serverSocket sendData: 'Hi there!!' count: 9. 235790 Transcript show: clientSocket receiveData; cr. 235791 Transcript nextPutAll: 'client side local/remote: '; 235792 print: clientSocket localSocketAddress; space; 235793 print: clientSocket remoteSocketAddress; cr. 235794 Transcript nextPutAll: 'server side local/remote: '; 235795 print: serverSocket localSocketAddress; space; 235796 print: serverSocket remoteSocketAddress; cr; 235797 endEntry. 235798 clientSocket close; destroy. 235799 serverSocket close; destroy. 235800 listeningSocket close; destroy. 235801 Transcript show: '---- INET6 client-server ----'; cr. 235802 Transcript show: (infos := SocketAddressInformation 235803 forHost: '' service: '4242' 235804 flags: SocketAddressInformation passiveFlag 235805 addressFamily: SocketAddressInformation addressFamilyINET6 235806 socketType: SocketAddressInformation socketTypeStream 235807 protocol: SocketAddressInformation protocolTCP) printString; cr. 235808 infos isEmpty 235809 ifTrue: [Transcript show: 'FAIL -- CANNOT CREATE INET6 SERVER'; cr] 235810 ifFalse: 235811 [listeningSocket := infos first listenWithBacklog: 5. 235812 Transcript show: (infos := SocketAddressInformation 235813 forHost: 'localhost' service: '4242' 235814 flags: 0 235815 addressFamily: SocketAddressInformation addressFamilyINET6 235816 socketType: SocketAddressInformation socketTypeStream 235817 protocol: SocketAddressInformation protocolTCP) printString; cr. 235818 clientSocket := infos first connect. 235819 serverSocket := listeningSocket accept. 235820 serverSocket sendData: 'Hi there!!' count: 9. 235821 Transcript show: clientSocket receiveData; cr. 235822 Transcript nextPutAll: 'client side local/remote: '; 235823 print: clientSocket localSocketAddress; space; 235824 print: clientSocket remoteSocketAddress; cr. 235825 Transcript nextPutAll: 'server side local/remote: '; 235826 print: serverSocket localSocketAddress; space; 235827 print: serverSocket remoteSocketAddress; cr; 235828 endEntry. 235829 clientSocket close; destroy. 235830 serverSocket close; destroy. 235831 listeningSocket close; destroy]. 235832 Transcript show: '---- trivial tests done ---'; cr.! ! 235833 235834!NetNameResolver class methodsFor: 'tests' stamp: 'michael.rueger 3/27/2009 16:55'! 235835testIPv6Echo 235836 "NetNameResolver testIPv6Echo" 235837 | infos addr sock size host serverSocket listeningSocket clientSocket | 235838 World findATranscript: World currentEvent. 235839 Transcript clear. 235840 "Transcript show: SmalltalkImage current listLoadedModules; cr." 235841 self initializeNetwork. 235842 Transcript show: '---- host name ----'; cr. 235843 size := NetNameResolver primHostNameSize. 235844 host := String new: size. 235845 NetNameResolver primHostNameResult: host. 235846 Transcript show: host; cr. 235847 Transcript show: '---- address information ----'; cr. 235848 Transcript show: (infos := SocketAddressInformation 235849 forHost: 'localhost' service: 'echo' flags: 0 235850 addressFamily: 0 socketType: 0 protocol: 0) printString; cr. 235851 Transcript show: '---- port manipulation ----'; cr. 235852 addr := infos first socketAddress. 235853 Transcript show: addr port printString; cr. 235854 addr port: 1234. 235855 Transcript show: addr port printString; cr. 235856 Transcript show: addr printString; cr. 235857 Transcript show: '---- client socket ----'; cr. 235858 Transcript show: (infos := SocketAddressInformation 235859 forHost: 'localhost' service: 'echo' flags: 0 235860 addressFamily: 0 235861 socketType: SocketAddressInformation socketTypeStream 235862 protocol: SocketAddressInformation protocolTCP) printString; cr. 235863 infos do: [:info | 235864 Transcript show: 'Trying ', info printString, '... '. 235865 (sock := info connect) notNil 235866 ifTrue: 235867 [sock sendData: 'hello' count: 5. 235868 Transcript show: sock receiveData printString. 235869 sock close; destroy]. 235870 Transcript cr]. 235871 Transcript show: '---- localhost defaults: loopback and wildcard addresses ----'; cr. 235872 Transcript show: (SocketAddress loopbacks) printString; cr. 235873 Transcript show: (SocketAddress wildcards) printString; cr. 235874 Transcript show: (SocketAddress loopback4) printString; cr. 235875 Transcript show: (SocketAddress wildcard4) printString; cr. 235876 Transcript show: '---- impossible constraints ----'; cr. 235877 Transcript show: (SocketAddressInformation 235878 forHost: 'localhost' service: 'echo' flags: 0 235879 addressFamily: 0 235880 socketType: SocketAddressInformation socketTypeDGram 235881 protocol: SocketAddressInformation protocolTCP) printString; cr. 235882 Transcript show: '---- INET4 client-server ----'; cr. 235883 Transcript show: (infos := SocketAddressInformation 235884 forHost: '' service: '4242' 235885 flags: SocketAddressInformation passiveFlag 235886 addressFamily: SocketAddressInformation addressFamilyINET4 235887 socketType: SocketAddressInformation socketTypeStream 235888 protocol: SocketAddressInformation protocolTCP) printString; cr. 235889 listeningSocket := infos first listenWithBacklog: 5. 235890 Transcript show: (infos := SocketAddressInformation 235891 forHost: 'localhost' service: '4242' 235892 flags: 0 235893 addressFamily: SocketAddressInformation addressFamilyINET4 235894 socketType: SocketAddressInformation socketTypeStream 235895 protocol: SocketAddressInformation protocolTCP) printString; cr. 235896 clientSocket := infos first connect. 235897 serverSocket := listeningSocket accept. 235898 serverSocket sendData: 'Hi there!!' count: 9. 235899 Transcript show: clientSocket receiveData; cr. 235900 Transcript nextPutAll: 'client side local/remote: '; 235901 print: clientSocket localSocketAddress; space; 235902 print: clientSocket remoteSocketAddress; cr. 235903 Transcript nextPutAll: 'server side local/remote: '; 235904 print: serverSocket localSocketAddress; space; 235905 print: serverSocket remoteSocketAddress; cr; 235906 endEntry. 235907 clientSocket close; destroy. 235908 serverSocket close; destroy. 235909 listeningSocket close; destroy. 235910 Transcript show: '---- INET6 client-server ----'; cr. 235911 Transcript show: (infos := SocketAddressInformation 235912 forHost: '' service: '4242' 235913 flags: SocketAddressInformation passiveFlag 235914 addressFamily: SocketAddressInformation addressFamilyINET6 235915 socketType: SocketAddressInformation socketTypeStream 235916 protocol: SocketAddressInformation protocolTCP) printString; cr. 235917 infos isEmpty 235918 ifTrue: [Transcript show: 'FAIL -- CANNOT CREATE INET6 SERVER'; cr] 235919 ifFalse: 235920 [listeningSocket := infos first listenWithBacklog: 5. 235921 Transcript show: (infos := SocketAddressInformation 235922 forHost: 'localhost' service: '4242' 235923 flags: 0 235924 addressFamily: SocketAddressInformation addressFamilyINET6 235925 socketType: SocketAddressInformation socketTypeStream 235926 protocol: SocketAddressInformation protocolTCP) printString; cr. 235927 clientSocket := infos first connect. 235928 serverSocket := listeningSocket accept. 235929 serverSocket sendData: 'Hi there!!' count: 9. 235930 Transcript show: clientSocket receiveData; cr. 235931 Transcript nextPutAll: 'client side local/remote: '; 235932 print: clientSocket localSocketAddress; space; 235933 print: clientSocket remoteSocketAddress; cr. 235934 Transcript nextPutAll: 'server side local/remote: '; 235935 print: serverSocket localSocketAddress; space; 235936 print: serverSocket remoteSocketAddress; cr; 235937 endEntry. 235938 clientSocket close; destroy. 235939 serverSocket close; destroy. 235940 listeningSocket close; destroy]. 235941 Transcript show: '---- trivial tests done ---'; cr.! ! 235942 235943!NetNameResolver class methodsFor: 'tests' stamp: 'mir 1/5/2007 18:18'! 235944testPort80 235945 "NetNameResolver testPort80" 235946 | infos | 235947 Transcript show: (infos := SocketAddressInformation 235948 forHost: 'localhost' service: '80' flags: 0 235949 addressFamily: 0 socketType: 0 protocol: 0) printString; cr. 235950 Transcript show: (infos := SocketAddressInformation 235951 forHost: '::1' service: '80' flags: 0 235952 addressFamily: 0 socketType: 0 protocol: 0) printString; cr. 235953! ! 235954 235955 235956!NetNameResolver class methodsFor: 'private' stamp: 'ikp 6/8/2007 18:12'! 235957nextSocketAddressInformation 235958 235959 | addrSize addr info | 235960 addrSize := self primGetAddressInfoSize. 235961 addrSize < 0 ifTrue: [^nil]. 235962 addr := SocketAddress new: addrSize. 235963 self primGetAddressInfoResult: addr. 235964 info := SocketAddressInformation 235965 withSocketAddress: addr 235966 family: self primGetAddressInfoFamily 235967 type: self primGetAddressInfoType 235968 protocol: self primGetAddressInfoProtocol. 235969 self primGetAddressInfoNext. 235970 ^info! ! 235971 235972!NetNameResolver class methodsFor: 'private' stamp: 'JMM 5/3/2000 13:57'! 235973readDecimalByteFrom: aStream 235974 "Read a positive, decimal integer from the given stream. Stop when a non-digit or end-of-stream is encountered. Return nil if stream is not positioned at a decimal digit or if the integer value read exceeds 255. 235975JMM - 000503 fixed didn't work correctly" 235976 235977 | digitSeen value digit | 235978 digitSeen := false. 235979 value := 0. 235980 [aStream atEnd] whileFalse: 235981 [digit := aStream next digitValue. 235982 (digit < 0 or: [digit > 9]) ifTrue: [ 235983 aStream skip: -1. 235984 (digitSeen not or: [value > 255]) ifTrue: [^ nil]. 235985 ^ value]. 235986 digitSeen := true. 235987 value := (value * 10) + digit]. 235988 (digitSeen not or: [value > 255]) ifTrue: [^ nil]. 235989 ^ value 235990! ! 235991 235992!NetNameResolver class methodsFor: 'private' stamp: 'mir 6/18/2001 21:05'! 235993resolverMutex 235994 ResolverMutex ifNil: [ResolverMutex := Semaphore forMutualExclusion]. 235995 ^ResolverMutex! ! 235996 235997!NetNameResolver class methodsFor: 'private' stamp: 'bf 6/27/2007 11:38'! 235998useOldNetwork 235999 ^UseOldNetwork ~~ false! ! 236000 236001!NetNameResolver class methodsFor: 'private' stamp: 'JMM 5/3/2000 11:35'! 236002waitForCompletionUntil: deadline 236003 "Wait up to the given number of seconds for the resolver to be ready to accept a new request. Return true if the resolver is ready, false if the network is not initialized or the resolver does not become free within the given time period." 236004 236005 | status | 236006 status := self resolverStatus. 236007 [(status = ResolverBusy) and: 236008 [Time millisecondClockValue < deadline]] 236009 whileTrue: [ 236010 "wait for resolver to be available" 236011 ResolverSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue). 236012 status := self resolverStatus]. 236013 236014 status = ResolverReady 236015 ifTrue: [^ true] 236016 ifFalse: [ 236017 status = ResolverBusy ifTrue: [self primAbortLookup]. 236018 ^ false]. 236019! ! 236020 236021!NetNameResolver class methodsFor: 'private' stamp: 'JMM 5/3/2000 11:36'! 236022waitForResolverReadyUntil: deadline 236023 "Wait up to the given number of seconds for the resolver to be ready to accept a new request. Return true if the resolver is not busy, false if the network is not initialized or the resolver does not become free within the given time period." 236024 236025 | status | 236026 status := self resolverStatus. 236027 status = ResolverUninitialized ifTrue: [^ false]. 236028 236029 [(status = ResolverBusy) and: 236030 [Time millisecondClockValue < deadline]] 236031 whileTrue: [ 236032 "wait for resolver to be available" 236033 ResolverSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue). 236034 status := self resolverStatus]. 236035 236036 ^ status ~= ResolverBusy 236037! ! 236038Error subclass: #NetworkError 236039 instanceVariableNames: '' 236040 classVariableNames: '' 236041 poolDictionaries: '' 236042 category: 'Network-Kernel'! 236043!NetworkError commentStamp: 'mir 5/12/2003 18:12' prior: 0! 236044Abstract super class for all network related exceptions.! 236045 236046ParseNode subclass: #NewArrayNode 236047 instanceVariableNames: 'numElements' 236048 classVariableNames: '' 236049 poolDictionaries: '' 236050 category: 'Compiler-ParseNodes'! 236051!NewArrayNode commentStamp: '<historical>' prior: 0! 236052I represent a node for the genPushNewArray: opcode.! 236053]style[(51)i! 236054 236055 236056!NewArrayNode methodsFor: 'accessing' stamp: 'eem 5/25/2008 14:58'! 236057numElements 236058 ^numElements! ! 236059 236060!NewArrayNode methodsFor: 'accessing' stamp: 'eem 5/25/2008 14:59'! 236061numElements: n 236062 numElements := n! ! 236063 236064 236065!NewArrayNode methodsFor: 'code generation (closures)' stamp: 'eem 6/16/2008 09:31'! 236066analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>" 236067 "This is a no-op except in TempVariableNode" 236068 ^self! ! 236069 236070 236071!NewArrayNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/25/2008 14:58'! 236072emitCodeForValue: stack encoder: encoder 236073 encoder genPushNewArray: numElements. 236074 stack push: 1! ! 236075 236076!NewArrayNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/25/2008 14:58'! 236077sizeCodeForValue: encoder 236078 ^encoder sizePushNewArray: numElements! ! 236079 236080 236081!NewArrayNode methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:55'! 236082accept: aVisitor 236083 aVisitor visitNewArrayNode: self! ! 236084 236085"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 236086 236087NewArrayNode class 236088 instanceVariableNames: ''! 236089HandleMorph subclass: #NewHandleMorph 236090 instanceVariableNames: 'hand waitingForClickInside' 236091 classVariableNames: '' 236092 poolDictionaries: '' 236093 category: 'Morphic-Widgets'! 236094 236095!NewHandleMorph methodsFor: 'all' stamp: 'di 5/18/1998 15:27'! 236096followHand: aHand forEachPointDo: block1 lastPointDo: block2 236097 hand := aHand. 236098 pointBlock := block1. 236099 lastPointBlock := block2. 236100 self position: hand lastEvent cursorPoint - (self extent // 2)! ! 236101 236102!NewHandleMorph methodsFor: 'all' stamp: 'ar 8/16/2001 15:48'! 236103followHand: aHand forEachPointDo: block1 lastPointDo: block2 withCursor: aCursor 236104 hand := aHand. 236105 hand showTemporaryCursor: aCursor "hotSpotOffset: aCursor offset negated". 236106 borderWidth := 0. 236107 color := Color transparent. 236108 pointBlock := block1. 236109 lastPointBlock := block2. 236110 self position: hand lastEvent cursorPoint - (self extent // 2)! ! 236111 236112!NewHandleMorph methodsFor: 'all' stamp: 'RAA 4/19/2001 11:36'! 236113sensorMode 236114 236115 "If our client is still addressing the Sensor directly, we need to do so as well" 236116 ^self valueOfProperty: #sensorMode ifAbsent: [false]. 236117! ! 236118 236119!NewHandleMorph methodsFor: 'all' stamp: 'RAA 4/19/2001 11:36'! 236120sensorMode: aBoolean 236121 236122 "If our client is still addressing the Sensor directly, we need to do so as well" 236123 self setProperty: #sensorMode toValue: aBoolean. 236124! ! 236125 236126 236127!NewHandleMorph methodsFor: 'dropping/grabbing' stamp: 'di 4/30/1999 14:06'! 236128justDroppedInto: aMorph event: anEvent 236129 "No dropping behavior because stepping will delete me. 236130 Moreover it needs to be done that way to evaluate lastPointBlock" 236131! ! 236132 236133!NewHandleMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:16'! 236134undoGrabCommand 236135 ^nil! ! 236136 236137 236138!NewHandleMorph methodsFor: 'initialization' stamp: 'marcus.denker 11/19/2008 13:47'! 236139initialize 236140 "initialize the state of the receiver" 236141 236142 super initialize. 236143 waitingForClickInside := true. 236144 ! ! 236145 236146 236147!NewHandleMorph methodsFor: 'stepping and presenter' stamp: 'RAA 4/19/2001 11:37'! 236148step 236149 | eventSource | 236150 236151 eventSource := self sensorMode ifTrue: [ 236152 Sensor 236153 ] ifFalse: [ 236154 hand lastEvent 236155 ]. 236156 eventSource anyButtonPressed 236157 ifTrue: [waitingForClickInside := false. 236158 self position: eventSource cursorPoint - (self extent // 2). 236159 pointBlock value: self center] 236160 ifFalse: [waitingForClickInside 236161 ifTrue: [(self containsPoint: eventSource cursorPoint) 236162 ifFalse: ["mouse wandered out before clicked" 236163 ^ self delete]] 236164 ifFalse: [lastPointBlock value: self center. 236165 ^ self delete]]! ! 236166 236167 236168!NewHandleMorph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/16/2001 15:38'! 236169delete 236170 hand ifNotNil:[ 236171 hand showTemporaryCursor: nil. 236172 ]. 236173 super delete.! ! 236174 236175 236176!NewHandleMorph methodsFor: 'wiw support' stamp: 'RAA 1/10/2001 10:15'! 236177morphicLayerNumber 236178 236179 ^1 "handles are very front-like - e.g. the spawn reframe logic actually asks if the first submorph of the world is one of us before deciding to create one"! ! 236180 236181"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 236182 236183NewHandleMorph class 236184 instanceVariableNames: ''! 236185 236186!NewHandleMorph class methodsFor: 'new-morph participation' stamp: 'di 5/3/1998 10:08'! 236187includeInNewMorphMenu 236188 ^ false! ! 236189Object subclass: #NewParagraph 236190 instanceVariableNames: 'text textStyle firstCharacterIndex container lines positionWhenComposed offsetToEnd maxRightX selectionStart selectionStop wantsColumnBreaks focused caretRect showCaret' 236191 classVariableNames: '' 236192 poolDictionaries: '' 236193 category: 'Morphic-Text Support'! 236194!NewParagraph commentStamp: '<historical>' prior: 0! 236195A Paragraph represents text that has been laid out, or composed, in some container. 236196 text A Text with encoded per-character emphasis. 236197 textStyle A TextStyle with font set, line height and horizontal alignment. 236198 firstCharacterIndex The starting index in text for this paragraph, allowing 236199 composition of a long text into a number of containers. 236200 container A Rectangle or TextContainer that determines where text can go. 236201 lines An Array of TextLines comprising the final layout of the text 236202 after it has been composed within its container. 236203 positionWhenComposed As its name implies. Allows display at new locations 236204 without the need to recompose the text. 236205Lines are ordered vertically. However, for a given y, there may be several lines in left to right order. Lines must never be empty, even if text is empty. 236206 236207Notes on yet another hack - 5 Feb 2001 236208 236209We really need to clean up #composeLinesFrom:to:delta:into:priorLines:atY:!!!!!! 236210 236211I added one more habdful of code to correct: 236212 236213This is an annoying bug that's been around for a couple of years, but I finally figured out how to duplicate the problem, so I figured I'd just report it now. (It doesn't necessarily have to be fixed for 3.0 if it looks messy, but if it's a simple fix, it would be worth it.) 236214 236215In Morphic, if you have the following text in a workspace: 236216 236217This is line 1 236218This is line 2 236219 236220**and** you have a return character after line 2, you will normally be able to click the mouse two times below line 2 in order to select all the text. If you edit line 2 (e.g. so that it reads "line number 2"), you can still select all the text by clicking below the second line. However, if you edit line 1, you will not be able to select all the text from the bottom in the same way. Things get messed up such that the last return character seems to be gone. In this state, if you position the cursor immediately after the 2, and press the right arrow, the cursor jumps to the beginning of line 2... oof. (report by Doug Way) 236221 236222While I don't have a very deep understanding of the above mentioned method, I was able to determine that text ending in a CR worked better in the editor when the last entry in <lines> had a start of text size + 1 and a stop of text size. I have accordingly added code near the end to ensure this. It seems to have fixed the problem, but we do need to clean this baby up some day. - Bob 236223! 236224 236225 236226!NewParagraph methodsFor: 'access' stamp: 'di 11/16/97 09:02'! 236227adjustedFirstCharacterIndex 236228 "Return the index in the text where this paragraph WOULD begin if nothing had changed, except the size of the text -- ie if there have only been an insertion of deletion in the preceding morphs" 236229 offsetToEnd ifNil: [^ -1]. 236230 ^ text size - offsetToEnd! ! 236231 236232!NewParagraph methodsFor: 'access' stamp: 'tbn 8/5/2009 09:50'! 236233caretRect 236234 "The rectangle in which the caret was last drawn, 236235 or nil if the last drawing drew a range-selection rather than insertion point." 236236 ^ caretRect! ! 236237 236238!NewParagraph methodsFor: 'access' stamp: 'tbn 8/5/2009 09:51'! 236239caretWidth 236240 ^ 0! ! 236241 236242!NewParagraph methodsFor: 'access' stamp: 'di 10/24/97 17:38'! 236243extent 236244 ^ container width @ (lines last bottom - lines first top)! ! 236245 236246!NewParagraph methodsFor: 'access' stamp: 'di 11/8/97 15:41'! 236247firstCharacterIndex 236248 ^ firstCharacterIndex! ! 236249 236250!NewParagraph methodsFor: 'access' stamp: 'rr 3/22/2004 12:42'! 236251focused 236252 focused ifNil: [focused := false]. 236253 ^ focused! ! 236254 236255!NewParagraph methodsFor: 'access' stamp: 'rr 3/22/2004 12:41'! 236256focused: aBoolean 236257 focused := aBoolean! ! 236258 236259!NewParagraph methodsFor: 'access' stamp: 'di 10/23/97 21:01'! 236260lastCharacterIndex 236261 ^ lines last last! ! 236262 236263!NewParagraph methodsFor: 'access' stamp: 'sbw 10/13/1999 22:31'! 236264numberOfLines 236265 236266 ^lines size! ! 236267 236268!NewParagraph methodsFor: 'access' stamp: 'tbn 8/5/2009 09:51'! 236269showCaret 236270 ^showCaret ifNil:[true] 236271! ! 236272 236273!NewParagraph methodsFor: 'access' stamp: 'tbn 8/5/2009 09:51'! 236274showCaret: aBool 236275 showCaret := aBool 236276! ! 236277 236278!NewParagraph methodsFor: 'access' stamp: 'sw 1/13/98 21:31'! 236279string 236280 ^ text string! ! 236281 236282!NewParagraph methodsFor: 'access' stamp: 'di 10/21/97 14:39'! 236283text 236284 ^ text! ! 236285 236286!NewParagraph methodsFor: 'access' stamp: 'jm 11/19/97 20:27'! 236287textOwner: ignored "See TextOnCurve"! ! 236288 236289!NewParagraph methodsFor: 'access' stamp: 'di 10/21/97 14:39'! 236290textStyle 236291 ^ textStyle! ! 236292 236293!NewParagraph methodsFor: 'access' stamp: 'di 10/23/97 19:33'! 236294textStyle: aTextStyle 236295 "Set the style by which the receiver should display its text." 236296 textStyle := aTextStyle! ! 236297 236298!NewParagraph methodsFor: 'access' stamp: 'RAA 5/6/2001 15:04'! 236299wantsColumnBreaks 236300 236301 ^wantsColumnBreaks! ! 236302 236303!NewParagraph methodsFor: 'access' stamp: 'RAA 5/6/2001 15:03'! 236304wantsColumnBreaks: aBoolean 236305 236306 wantsColumnBreaks := aBoolean! ! 236307 236308 236309!NewParagraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'! 236310centered 236311 textStyle centered! ! 236312 236313!NewParagraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'! 236314justified 236315 textStyle justified! ! 236316 236317!NewParagraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'! 236318leftFlush 236319 textStyle leftFlush! ! 236320 236321!NewParagraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'! 236322rightFlush 236323 textStyle rightFlush! ! 236324 236325 236326!NewParagraph methodsFor: 'composition' stamp: 'jm 2/25/2003 16:20'! 236327OLDcomposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY 236328 "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" 236329 236330 | charIndex lineY lineHeight scanner line row firstLine lineHeightGuess saveCharIndex hitCR maybeSlide sliding bottom priorIndex priorLine | 236331 charIndex := start. 236332 lines := lineColl. 236333 lineY := startingY. 236334 lineHeightGuess := textStyle lineGrid. 236335 maxRightX := container left. 236336 maybeSlide := stop < text size and: [container isMemberOf: Rectangle]. 236337 sliding := false. 236338 priorIndex := 1. 236339 bottom := container bottom. 236340 scanner := CompositionScanner new text: text textStyle: textStyle. 236341 firstLine := true. 236342 [charIndex <= text size and: [lineY + lineHeightGuess <= bottom]] 236343 whileTrue: 236344 [sliding 236345 ifTrue: 236346 ["Having detected the end of rippling recoposition, we are only sliding old lines" 236347 236348 priorIndex < priorLines size 236349 ifTrue: 236350 ["Adjust and re-use previously composed line" 236351 236352 priorIndex := priorIndex + 1. 236353 priorLine := (priorLines at: priorIndex) slideIndexBy: delta 236354 andMoveTopTo: lineY. 236355 lineColl addLast: priorLine. 236356 lineY := priorLine bottom. 236357 charIndex := priorLine last + 1] 236358 ifFalse: 236359 ["There are no more priorLines to slide." 236360 236361 sliding := maybeSlide := false]] 236362 ifFalse: 236363 [lineHeight := lineHeightGuess. 236364 saveCharIndex := charIndex. 236365 hitCR := false. 236366 row := container rectanglesAt: lineY height: lineHeight. 236367 1 to: row size 236368 do: 236369 [:i | 236370 (charIndex <= text size and: [hitCR not]) 236371 ifTrue: 236372 [line := scanner 236373 composeFrom: charIndex 236374 inRectangle: (row at: i) 236375 firstLine: firstLine 236376 leftSide: i = 1 236377 rightSide: i = row size. 236378 lines addLast: line. 236379 (text at: line last) = Character cr ifTrue: [hitCR := true]. 236380 lineHeight := lineHeight max: line lineHeight. "includes font changes" 236381 charIndex := line last + 1]]. 236382 236383 lineY := lineY + lineHeight. 236384 row notEmpty 236385 ifTrue: 236386 [lineY > bottom 236387 ifTrue: 236388 ["Oops -- the line is really too high to fit -- back out" 236389 236390 charIndex := saveCharIndex. 236391 row do: [:r | lines removeLast]] 236392 ifFalse: 236393 ["It's OK -- the line still fits." 236394 236395 maxRightX := maxRightX max: scanner rightX. 236396 1 to: row size - 1 236397 do: 236398 [:i | 236399 "Adjust heights across row if necess" 236400 236401 (lines at: lines size - row size + i) lineHeight: lines last lineHeight 236402 baseline: lines last baseline]. 236403 charIndex > text size 236404 ifTrue: 236405 ["end of text" 236406 236407 hitCR 236408 ifTrue: 236409 ["If text ends with CR, add a null line at the end" 236410 236411 lineY + lineHeightGuess <= container bottom 236412 ifTrue: 236413 [row := container rectanglesAt: lineY height: lineHeightGuess. 236414 row notEmpty 236415 ifTrue: 236416 [line := (TextLine 236417 start: charIndex 236418 stop: charIndex - 1 236419 internalSpaces: 0 236420 paddingWidth: 0) 236421 rectangle: row first; 236422 lineHeight: lineHeightGuess baseline: textStyle baseline. 236423 lines addLast: line]]]. 236424 lines := lines asArray. 236425 ^maxRightX]. 236426 firstLine := false]]. 236427 236428 (maybeSlide and: [charIndex > stop]) 236429 ifTrue: 236430 ["Check whether we are now in sync with previously composed lines" 236431 236432 236433 [priorIndex < priorLines size 236434 and: [(priorLines at: priorIndex) first < (charIndex - delta)]] 236435 whileTrue: [priorIndex := priorIndex + 1]. 236436 (priorLines at: priorIndex) first = (charIndex - delta) 236437 ifTrue: 236438 ["Yes -- next line will have same start as prior line." 236439 236440 priorIndex := priorIndex - 1. 236441 maybeSlide := false. 236442 sliding := true] 236443 ifFalse: 236444 [priorIndex = priorLines size 236445 ifTrue: 236446 ["Weve reached the end of priorLines, 236447 so no use to keep looking for lines to slide." 236448 236449 maybeSlide := false]]]]]. 236450 firstLine 236451 ifTrue: 236452 ["No space in container or empty text" 236453 236454 line := (TextLine 236455 start: start 236456 stop: start - 1 236457 internalSpaces: 0 236458 paddingWidth: 0) 236459 rectangle: (container topLeft extent: 0 @ lineHeightGuess); 236460 lineHeight: lineHeightGuess baseline: textStyle baseline. 236461 lines := Array with: line] 236462 ifFalse: [self fixLastWithHeight: lineHeightGuess]. 236463 "end of container" 236464 lines := lines asArray. 236465 ^maxRightX! ! 236466 236467!NewParagraph methodsFor: 'composition' stamp: 'di 11/8/97 15:31'! 236468compose: t style: ts from: startingIndex in: textContainer 236469 text := t. 236470 textStyle := ts. 236471 firstCharacterIndex := startingIndex. 236472 offsetToEnd := text size - firstCharacterIndex. 236473 container := textContainer. 236474 self composeAll! ! 236475 236476!NewParagraph methodsFor: 'composition' stamp: 'yo 12/20/2002 16:18'! 236477composeAll 236478 text string isOctetString ifTrue: [ 236479 ^ self composeLinesFrom: firstCharacterIndex to: text size delta: 0 236480 into: OrderedCollection new priorLines: Array new atY: container top. 236481 ]. 236482 236483 ^ self multiComposeLinesFrom: firstCharacterIndex to: text size delta: 0 236484 into: OrderedCollection new priorLines: Array new atY: container top. 236485! ! 236486 236487!NewParagraph methodsFor: 'composition' stamp: 'di 11/15/97 09:21'! 236488composeAllStartingAt: characterIndex 236489 firstCharacterIndex := characterIndex. 236490 offsetToEnd := text size - firstCharacterIndex. 236491 self composeAll! ! 236492 236493!NewParagraph methodsFor: 'composition' stamp: 'RAA 5/7/2001 10:58'! 236494composeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines 236495 atY: startingY 236496 "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" 236497 236498 | newResult | 236499 236500 newResult := TextComposer new 236501 composeLinesFrom: start 236502 to: stop 236503 delta: delta 236504 into: lineColl 236505 priorLines: priorLines 236506 atY: startingY 236507 textStyle: textStyle 236508 text: text 236509 container: container 236510 wantsColumnBreaks: wantsColumnBreaks == true. 236511 lines := newResult first asArray. 236512 maxRightX := newResult second. 236513 ^maxRightX 236514! ! 236515 236516!NewParagraph methodsFor: 'composition' stamp: 'di 10/22/97 11:13'! 236517compositionRectangle 236518 ^ container! ! 236519 236520!NewParagraph methodsFor: 'composition' stamp: 'RAA 2/25/2001 15:02'! 236521fixLastWithHeight: lineHeightGuess 236522"This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I coul;dn't figure out where to put it in the main logic." 236523 236524 | oldLastLine newRectangle line | 236525 236526 (text size > 1 and: [text last = Character cr]) ifFalse: [^self]. 236527 236528 oldLastLine := lines last. 236529 oldLastLine last - oldLastLine first >= 0 ifFalse: [^self]. 236530 oldLastLine last = text size ifFalse: [^self]. 236531 236532 newRectangle := oldLastLine left @ oldLastLine bottom 236533 extent: 0@(oldLastLine bottom - oldLastLine top). 236534 "Even though we may be below the bottom of the container, 236535 it is still necessary to compose the last line for consistency..." 236536 236537 line := TextLine start: text size+1 stop: text size internalSpaces: 0 paddingWidth: 0. 236538 line rectangle: newRectangle. 236539 line lineHeight: lineHeightGuess baseline: textStyle baseline. 236540 lines := lines, (Array with: line). 236541! ! 236542 236543!NewParagraph methodsFor: 'composition' stamp: 'yo 1/3/2003 12:17'! 236544multiComposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines 236545 atY: startingY 236546 "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" 236547 236548 | newResult | 236549 236550 newResult := MultiTextComposer new 236551 multiComposeLinesFrom: start 236552 to: stop 236553 delta: delta 236554 into: lineColl 236555 priorLines: priorLines 236556 atY: startingY 236557 textStyle: textStyle 236558 text: text 236559 container: container 236560 wantsColumnBreaks: wantsColumnBreaks == true. 236561 lines := newResult first asArray. 236562 maxRightX := newResult second. 236563 "maxRightX printString displayAt: 0@0." 236564 ^maxRightX 236565! ! 236566 236567!NewParagraph methodsFor: 'composition' stamp: 'yo 12/20/2002 16:18'! 236568recomposeFrom: start to: stop delta: delta 236569 "Recompose this paragraph. The altered portion is between start and stop. 236570 Recomposition may continue to the end of the text, due to a ripple effect. 236571 Delta is the amount by which the current text is longer than it was 236572 when its current lines were composed." 236573 | startLine newLines | 236574 "Have to recompose line above in case a word-break was affected." 236575 startLine := (self lineIndexForCharacter: start) - 1 max: 1. 236576 [startLine > 1 and: [(lines at: startLine-1) top = (lines at: startLine) top]] 236577 whileTrue: [startLine := startLine - 1]. "Find leftmost of line pieces" 236578 newLines := OrderedCollection new: lines size + 1. 236579 1 to: startLine-1 do: [:i | newLines addLast: (lines at: i)]. 236580 text string isOctetString ifTrue: [ 236581 ^ self composeLinesFrom: (lines at: startLine) first to: stop delta: delta 236582 into: newLines priorLines: lines 236583 atY: (lines at: startLine) top. 236584 ]. 236585 self multiComposeLinesFrom: (lines at: startLine) first to: stop delta: delta 236586 into: newLines priorLines: lines 236587 atY: (lines at: startLine) top. 236588! ! 236589 236590!NewParagraph methodsFor: 'composition' stamp: 'RAA 5/6/2001 15:09'! 236591testNewComposeAll 236592 | newResult | 236593 self 236594 OLDcomposeLinesFrom: firstCharacterIndex 236595 to: text size 236596 delta: 0 236597 into: OrderedCollection new 236598 priorLines: Array new 236599 atY: container top. 236600 newResult := TextComposer new 236601 composeLinesFrom: firstCharacterIndex 236602 to: text size 236603 delta: 0 236604 into: OrderedCollection new 236605 priorLines: Array new 236606 atY: container top 236607 textStyle: textStyle 236608 text: text 236609 container: container 236610 wantsColumnBreaks: false. 236611 newResult first with: lines do: [ :e1 :e2 | 236612 e1 longPrintString = e2 longPrintString ifFalse: [self halt]. 236613 ]. 236614 newResult second = maxRightX ifFalse: [self halt]. 236615 ^{newResult. {lines. maxRightX}} 236616! ! 236617 236618!NewParagraph methodsFor: 'composition' stamp: 'yo 12/17/2002 14:48'! 236619testNewComposeAll2 236620 | newResult | 236621 newResult := TextComposer new 236622 composeLinesFrom: firstCharacterIndex 236623 to: text size 236624 delta: 0 236625 into: OrderedCollection new 236626 priorLines: Array new 236627 atY: container top 236628 textStyle: textStyle 236629 text: text 236630 container: container 236631 wantsColumnBreaks: false. 236632 ^{newResult. {lines. maxRightX}} 236633! ! 236634 236635!NewParagraph methodsFor: 'composition' stamp: 'yo 12/18/2002 15:00'! 236636testNewComposeAll3 236637 | newResult | 236638 newResult := TextComposer new 236639 multiComposeLinesFrom: firstCharacterIndex 236640 to: text size 236641 delta: 0 236642 into: OrderedCollection new 236643 priorLines: Array new 236644 atY: container top 236645 textStyle: textStyle 236646 text: text 236647 container: (0@0 extent: 31@60) 236648 wantsColumnBreaks: false. 236649 ^{newResult. {lines. maxRightX}} 236650! ! 236651 236652 236653!NewParagraph methodsFor: 'copying' stamp: 'di 5/21/1998 21:45'! 236654deepCopy 236655 "Don't want to copy the container (etc) or fonts in the TextStyle." 236656 | new | 236657 new := self copy. 236658 new textStyle: textStyle copy 236659 lines: lines copy 236660 text: text deepCopy. 236661 ^ new! ! 236662 236663 236664!NewParagraph methodsFor: 'display' stamp: 'di 8/13/2000 12:27'! 236665asParagraphForPostscript 236666 236667 ^ self! ! 236668 236669!NewParagraph methodsFor: 'display' stamp: 'tbn 8/5/2009 10:01'! 236670displaySelectionInLine: line on: aCanvas 236671 | leftX rightX w caretColor | 236672 selectionStart ifNil: [^self]. "No selection" 236673 aCanvas isShadowDrawing ifTrue: [ ^self ]. "don't draw selection with shadow" 236674 selectionStart = selectionStop 236675 ifTrue: 236676 ["Only show caret on line where clicked" 236677 236678 selectionStart textLine ~= line ifTrue: [^self]] 236679 ifFalse: 236680 ["Test entire selection before or after here" 236681 236682 (selectionStop stringIndex < line first 236683 or: [selectionStart stringIndex > (line last + 1)]) ifTrue: [^self]. "No selection on this line" 236684 (selectionStop stringIndex = line first 236685 and: [selectionStop textLine ~= line]) ifTrue: [^self]. "Selection ends on line above" 236686 (selectionStart stringIndex = (line last + 1) 236687 and: [selectionStop textLine ~= line]) ifTrue: [^self]]. "Selection begins on line below" 236688 leftX := (selectionStart stringIndex < line first 236689 ifTrue: [line ] 236690 ifFalse: [selectionStart ])left. 236691 rightX := (selectionStop stringIndex > (line last + 1) or: 236692 [selectionStop stringIndex = (line last + 1) 236693 and: [selectionStop textLine ~= line]]) 236694 ifTrue: [line right] 236695 ifFalse: [selectionStop left]. 236696 selectionStart = selectionStop 236697 ifTrue: 236698 [rightX := rightX + 1. 236699 w := self caretWidth. 236700 caretRect := (leftX-w) @ line top corner: (rightX+w)@ line bottom. 236701 self showCaret ifFalse:[^self]. 236702 caretColor := self insertionPointColor. 236703 1 to: w 236704 do: 236705 [:i | 236706 "Draw caret triangles at top and bottom" 236707 236708 aCanvas fillRectangle: ((leftX - w + i - 1) @ (line top + i - 1) 236709 extent: ((w - i) * 2 + 3) @ 1) 236710 color: caretColor. 236711 aCanvas fillRectangle: ((leftX - w + i - 1) @ (line bottom - i) 236712 extent: ((w - i) * 2 + 3) @ 1) 236713 color: caretColor]. 236714 aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom) 236715 color: caretColor] 236716 ifFalse: 236717 [caretRect := nil. 236718 aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom) 236719 color: self selectionColor]! ! 236720 236721!NewParagraph methodsFor: 'display' stamp: 'rr 3/22/2004 19:56'! 236722insertionPointColor 236723 self focused ifFalse: [^ Color transparent]. 236724 ^ Display depth <= 2 236725 ifTrue: [Color black] 236726 ifFalse: [Preferences insertionPointColor]! ! 236727 236728!NewParagraph methodsFor: 'display' stamp: 'rr 3/23/2004 19:52'! 236729selectionColor 236730 | color | 236731 Display depth = 1 ifTrue: [^ Color veryLightGray]. 236732 Display depth = 2 ifTrue: [^ Color gray]. 236733 color := Preferences textHighlightColor. 236734 self focused ifFalse: [color := color alphaMixed: 0.2 with: Color veryVeryLightGray]. 236735 ^ color! ! 236736 236737 236738!NewParagraph methodsFor: 'editing' stamp: 'mk 5/28/2005 11:15'! 236739clickAt: clickPoint for: model controller: editor 236740 "Give sensitive text a chance to fire. Display flash: (100@100 extent: 100@100)." 236741 | startBlock action target range boxes box | 236742 action := false. 236743 startBlock := self characterBlockAtPoint: clickPoint. 236744 (text attributesAt: startBlock stringIndex forStyle: textStyle) 236745 do: [:att | att mayActOnClick ifTrue: 236746 [(target := model) ifNil: [target := editor morph]. 236747 range := text rangeOf: att startingAt: startBlock stringIndex. 236748 boxes := self selectionRectsFrom: (self characterBlockForIndex: range first) 236749 to: (self characterBlockForIndex: range last+1). 236750 box := boxes detect: [:each | each containsPoint: clickPoint] ifNone: [nil]. 236751 box ifNotNil: 236752 [ box := (editor transformFrom: nil) invertBoundsRect: box. 236753 editor morph allOwnersDo: [ :m | box := box intersect: (m boundsInWorld) ]. 236754 Utilities awaitMouseUpIn: box 236755 repeating: [] 236756 ifSucceed: [(att actOnClickFor: target in: self at: clickPoint editor: editor) ifTrue: [action := true]]. 236757 Cursor currentCursor == Cursor webLink ifTrue:[Cursor normal show]. 236758 ]]]. 236759 ^ action! ! 236760 236761!NewParagraph methodsFor: 'editing' stamp: 'di 4/28/1999 10:14'! 236762replaceFrom: start to: stop with: aText displaying: displayBoolean 236763 "Edit the text, and then recompose the lines." 236764 text replaceFrom: start to: stop with: aText. 236765 self recomposeFrom: start to: start + aText size - 1 delta: aText size - (stop-start+1)! ! 236766 236767 236768!NewParagraph methodsFor: 'fonts-display' stamp: 'nk 3/20/2004 11:13'! 236769displayOn: aCanvas using: displayScanner at: somePosition 236770 "Send all visible lines to the displayScanner for display" 236771 | visibleRectangle offset leftInRun line | 236772 visibleRectangle := aCanvas clipRect. 236773 offset := (somePosition - positionWhenComposed) truncated. 236774 leftInRun := 0. 236775 (self lineIndexForPoint: visibleRectangle topLeft) 236776 to: (self lineIndexForPoint: visibleRectangle bottomRight) 236777 do: [:i | line := lines at: i. 236778 self displaySelectionInLine: line on: aCanvas. 236779 line first <= line last ifTrue: 236780 [leftInRun := displayScanner displayLine: line 236781 offset: offset leftInRun: leftInRun]]. 236782! ! 236783 236784 236785!NewParagraph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:12'! 236786initialize 236787 super initialize. 236788 self positionWhenComposed: 0 @ 0! ! 236789 236790 236791!NewParagraph methodsFor: 'selection' stamp: 'ar 4/12/2005 19:53'! 236792characterBlockAtPoint: aPoint 236793 "Answer a CharacterBlock for the character in the text at aPoint." 236794 | line | 236795 line := lines at: (self lineIndexForPoint: aPoint). 236796 ^ ((text string isWideString) ifTrue: [ 236797 MultiCharacterBlockScanner new text: text textStyle: textStyle 236798 ] ifFalse: [CharacterBlockScanner new text: text textStyle: textStyle]) 236799 characterBlockAtPoint: aPoint index: nil 236800 in: line! ! 236801 236802!NewParagraph methodsFor: 'selection' stamp: 'ar 4/12/2005 19:53'! 236803characterBlockForIndex: index 236804 "Answer a CharacterBlock for the character in text at index." 236805 | line | 236806 line := lines at: (self lineIndexForCharacter: index). 236807 ^ ((text string isWideString) ifTrue: [ 236808 MultiCharacterBlockScanner new text: text textStyle: textStyle 236809 ] ifFalse: [ 236810 CharacterBlockScanner new text: text textStyle: textStyle 236811 ]) 236812 characterBlockAtPoint: nil index: ((index max: line first) min: text size+1) 236813 in: line! ! 236814 236815!NewParagraph methodsFor: 'selection' stamp: 'jm 11/19/97 22:56'! 236816containsPoint: aPoint 236817 ^ (lines at: (self lineIndexForPoint: aPoint)) rectangle 236818 containsPoint: aPoint! ! 236819 236820!NewParagraph methodsFor: 'selection' stamp: 'di 10/5/1998 12:59'! 236821defaultCharacterBlock 236822 ^ (CharacterBlock new stringIndex: firstCharacterIndex text: text 236823 topLeft: lines first topLeft extent: 0 @ 0) 236824 textLine: lines first! ! 236825 236826!NewParagraph methodsFor: 'selection' stamp: 'di 11/30/97 12:10'! 236827selectionRects 236828 "Return an array of rectangles representing the selection region." 236829 selectionStart ifNil: [^ Array new]. 236830 ^ self selectionRectsFrom: selectionStart to: selectionStop! ! 236831 236832!NewParagraph methodsFor: 'selection' stamp: 'ls 11/2/2001 23:10'! 236833selectionRectsFrom: characterBlock1 to: characterBlock2 236834 "Return an array of rectangles representing the area between the two character blocks given as arguments." 236835 | line1 line2 rects cb1 cb2 w | 236836 characterBlock1 <= characterBlock2 236837 ifTrue: [cb1 := characterBlock1. cb2 := characterBlock2] 236838 ifFalse: [cb2 := characterBlock1. cb1 := characterBlock2]. 236839 cb1 = cb2 ifTrue: 236840 [w := self caretWidth. 236841 ^ Array with: (cb1 topLeft - (w@0) corner: cb1 bottomLeft + ((w+1)@0))]. 236842 line1 := self lineIndexForCharacter: cb1 stringIndex. 236843 line2 := self lineIndexForCharacter: cb2 stringIndex. 236844 line1 = line2 ifTrue: 236845 [^ Array with: (cb1 topLeft corner: cb2 bottomRight)]. 236846 rects := OrderedCollection new. 236847 rects addLast: (cb1 topLeft corner: (lines at: line1) bottomRight). 236848 line1+1 to: line2-1 do: [ :i | 236849 | line | 236850 line := lines at: i. 236851 (line left = rects last left and: [ line right = rects last right ]) 236852 ifTrue: [ "new line has same margins as old one -- merge them, so that the caller gets as few rectangles as possible" 236853 | lastRect | 236854 lastRect := rects removeLast. 236855 rects add: (lastRect bottom: line bottom) ] 236856 ifFalse: [ "differing margins; cannot merge" 236857 rects add: line rectangle ] ]. 236858 236859 rects addLast: ((lines at: line2) topLeft corner: cb2 bottomLeft). 236860 ^ rects! ! 236861 236862!NewParagraph methodsFor: 'selection' stamp: 'di 12/2/97 19:57'! 236863selectionStart: startBlock selectionStop: stopBlock 236864 selectionStart := startBlock. 236865 selectionStop := stopBlock.! ! 236866 236867 236868!NewParagraph methodsFor: 'private' stamp: 'di 11/8/97 15:47'! 236869adjustLineIndicesBy: delta 236870 firstCharacterIndex := firstCharacterIndex + delta. 236871 lines do: [:line | line slide: delta]. 236872! ! 236873 236874!NewParagraph methodsFor: 'private' stamp: 'di 10/26/97 15:57'! 236875adjustRightX 236876 | shrink | 236877 shrink := container right - maxRightX. 236878 lines do: [:line | line paddingWidth: (line paddingWidth - shrink)]. 236879 container := container withRight: maxRightX! ! 236880 236881!NewParagraph methodsFor: 'private' stamp: 'di 4/14/98 13:17'! 236882fastFindFirstLineSuchThat: lineBlock 236883 "Perform a binary search of the lines array and return the index 236884 of the first element for which lineBlock evaluates as true. 236885 This assumes the condition is one that goes from false to true for 236886 increasing line numbers (as, eg, yval > somey or start char > somex). 236887 If lineBlock is not true for any element, return size+1." 236888 | index low high | 236889 low := 1. 236890 high := lines size. 236891 [index := high + low // 2. 236892 low > high] 236893 whileFalse: 236894 [(lineBlock value: (lines at: index)) 236895 ifTrue: [high := index - 1] 236896 ifFalse: [low := index + 1]]. 236897 ^ low! ! 236898 236899!NewParagraph methodsFor: 'private' stamp: 'RAA 8/30/1998 15:30'! 236900indentationOfLineIndex: lineIndex ifBlank: aBlock 236901 "Answer the number of leading tabs in the line at lineIndex. If there are 236902 no visible characters, pass the number of tabs to aBlock and return its value. 236903 If the line is word-wrap overflow, back up a line and recur." 236904 236905 | arrayIndex first last cr | 236906 cr := Character cr. 236907 arrayIndex := lineIndex. 236908 [first := (lines at: arrayIndex) first. 236909 first > 1 and: [(text string at: first - 1) ~~ cr]] whileTrue: "word wrap" 236910 [arrayIndex := arrayIndex - 1]. 236911 last := (lines at: arrayIndex) last. 236912 236913 ^(text string copyFrom: first to: last) indentationIfBlank: aBlock. 236914! ! 236915 236916!NewParagraph methodsFor: 'private' stamp: 'di 4/14/98 13:11'! 236917lineIndexForCharacter: index 236918 "Answer the index of the line in which to select the character at index." 236919 ^ (self fastFindFirstLineSuchThat: [:line | line first > index]) - 1 max: 1! ! 236920 236921!NewParagraph methodsFor: 'private' stamp: 'di 4/14/98 13:13'! 236922lineIndexForPoint: aPoint 236923 "Answer the index of the line in which to select the character nearest to aPoint." 236924 | i py | 236925 py := aPoint y truncated. 236926 236927 "Find the first line at this y-value" 236928 i := (self fastFindFirstLineSuchThat: [:line | line bottom > py]) min: lines size. 236929 236930 "Now find the first line at this x-value" 236931 [i < lines size and: [(lines at: i+1) top = (lines at: i) top 236932 and: [aPoint x >= (lines at: i+1) left]]] 236933 whileTrue: [i := i + 1]. 236934 ^ i! ! 236935 236936!NewParagraph methodsFor: 'private' stamp: 'RAA 8/30/1998 15:04'! 236937lineIndexOfCharacterIndex: characterIndex 236938 "Answer the line index for a given characterIndex." 236939 "apparently the selector changed with NewParagraph" 236940 236941 ^self lineIndexForCharacter: characterIndex 236942! ! 236943 236944!NewParagraph methodsFor: 'private' stamp: 'di 10/24/97 17:40'! 236945lines 236946 ^ lines! ! 236947 236948!NewParagraph methodsFor: 'private' stamp: 'edc 6/18/2004 09:10'! 236949moveBy: delta 236950 lines do: [:line | line moveBy: delta]. 236951 positionWhenComposed ifNotNil:[ 236952 positionWhenComposed := positionWhenComposed + delta]. 236953 container := container translateBy: delta! ! 236954 236955!NewParagraph methodsFor: 'private' stamp: 'di 10/21/97 21:36'! 236956positionWhenComposed: pos 236957 positionWhenComposed := pos! ! 236958 236959!NewParagraph methodsFor: 'private' stamp: 'di 5/21/1998 21:47'! 236960textStyle: ts lines: l text: t 236961 "Private -- just a service for deepCopy" 236962 textStyle := ts. 236963 lines := l. 236964 text := t.! ! 236965NetworkError subclass: #NoNetworkError 236966 instanceVariableNames: '' 236967 classVariableNames: '' 236968 poolDictionaries: '' 236969 category: 'Network-Kernel'! 236970!NoNetworkError commentStamp: 'mir 5/12/2003 18:17' prior: 0! 236971Signals that no network was found. This could happen, e.g., on dial-up connection when no connection was established when Squeak tried to access it. 236972 236973! 236974 236975Error subclass: #NonBooleanReceiver 236976 instanceVariableNames: 'object' 236977 classVariableNames: '' 236978 poolDictionaries: '' 236979 category: 'Exceptions-Kernel'! 236980 236981!NonBooleanReceiver methodsFor: 'accessing' stamp: 'hmm 7/29/2001 21:30'! 236982object 236983 ^object! ! 236984 236985!NonBooleanReceiver methodsFor: 'accessing' stamp: 'hmm 7/29/2001 21:30'! 236986object: anObject 236987 object := anObject! ! 236988 236989 236990!NonBooleanReceiver methodsFor: 'signaledexception' stamp: 'hmm 7/29/2001 21:37'! 236991isResumable 236992 236993 ^true! ! 236994WeakMessageSend weakSubclass: #NonReentrantWeakMessageSend 236995 instanceVariableNames: 'executing' 236996 classVariableNames: '' 236997 poolDictionaries: '' 236998 category: 'Polymorph-EventEnhancements'! 236999 237000!NonReentrantWeakMessageSend methodsFor: 'accessing' stamp: 'gvc 10/25/2006 18:03'! 237001executing 237002 "Answer the value of executing" 237003 237004 ^ executing! ! 237005 237006!NonReentrantWeakMessageSend methodsFor: 'accessing' stamp: 'gvc 10/25/2006 18:03'! 237007executing: anObject 237008 "Set the value of executing" 237009 237010 executing := anObject! ! 237011 237012 237013!NonReentrantWeakMessageSend methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:03'! 237014execute: aBlock 237015 "Answer the value of the block or nil if already executing." 237016 237017 self executing ifTrue: [^nil]. 237018 self executing: true. 237019 ^aBlock ensure: [self executing: false]! ! 237020 237021!NonReentrantWeakMessageSend methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:04'! 237022initialize 237023 "Initialize the receiver." 237024 237025 super initialize. 237026 self executing: false! ! 237027 237028!NonReentrantWeakMessageSend methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:15'! 237029isValid 237030 "Answer the superclass vlaue of isValid or false if 237031 executing is true." 237032 237033 ^self executing 237034 ifTrue: [false] 237035 ifFalse: [super isValid]! ! 237036 237037!NonReentrantWeakMessageSend methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 11:42'! 237038value 237039 "Answer the superclass value or nil if already executing." 237040 237041 ^self execute: [super value]! ! 237042 237043!NonReentrantWeakMessageSend methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 11:56'! 237044valueWithArguments: anArray 237045 "Answer the superclass value or nil if already executing." 237046 237047 ^self execute: [super valueWithArguments: anArray]! ! 237048 237049!NonReentrantWeakMessageSend methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 11:56'! 237050valueWithEnoughArguments: anArray 237051 "Answer the superclass value or nil if already executing." 237052 237053 ^self execute: [super valueWithEnoughArguments: anArray]! ! 237054Exception subclass: #Notification 237055 instanceVariableNames: '' 237056 classVariableNames: '' 237057 poolDictionaries: '' 237058 category: 'Exceptions-Kernel'! 237059!Notification commentStamp: '<historical>' prior: 0! 237060A Notification is an indication that something interesting has occurred. If it is not handled, it will pass by without effect.! 237061 237062 237063!Notification methodsFor: 'exceptiondescription' stamp: 'pnm 8/16/2000 15:04'! 237064defaultAction 237065 "No action is taken. The value nil is returned as the value of the message that signaled the exception." 237066 237067 ^nil! ! 237068PluggableCanvas subclass: #NullCanvas 237069 instanceVariableNames: '' 237070 classVariableNames: '' 237071 poolDictionaries: '' 237072 category: 'Morphic-Support'! 237073!NullCanvas commentStamp: '<historical>' prior: 0! 237074A canvas which ignores all drawing commands.! 237075 237076 237077!NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:11'! 237078clipRect 237079 ^1@1 extent: 99@99! ! 237080 237081!NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:11'! 237082extent 237083 ^100@100! ! 237084 237085!NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:12'! 237086form 237087 ^Form extent: self extent! ! 237088 237089!NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:13'! 237090origin 237091 ^0@0! ! 237092 237093 237094!NullCanvas methodsFor: 'copying' stamp: 'ls 3/20/2000 21:26'! 237095copyClipRect: clipRect 237096 "who cares what the clipping rectangle is?" 237097 ^self! ! 237098 237099 237100!NullCanvas methodsFor: 'drawing-support' stamp: 'ls 3/27/2000 21:41'! 237101clipBy: region during: aBlock 237102 "do this in order that timing runs work better" 237103 aBlock value: self! ! 237104 237105!NullCanvas methodsFor: 'drawing-support' stamp: 'ls 3/27/2000 21:39'! 237106transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize 237107 "do this in order that timing runs work better" 237108 aBlock value: self! ! 237109 237110!NullCanvas methodsFor: 'drawing-support' stamp: 'ls 3/27/2000 21:40'! 237111translateBy: delta during: aBlock 237112 "do this in order that timing runs work better" 237113 aBlock value: self! ! 237114Object subclass: #NullEncoder 237115 instanceVariableNames: 'target filterSelector' 237116 classVariableNames: '' 237117 poolDictionaries: '' 237118 category: 'Morphic-Support'! 237119 237120!NullEncoder methodsFor: 'accessing' stamp: 'RAA 9/17/2000 11:53'! 237121close 237122 237123 ^target close. 237124! ! 237125 237126!NullEncoder methodsFor: 'accessing' stamp: 'MPW 1/1/1901 00:56'! 237127contents 237128 ^target contents. 237129! ! 237130 237131!NullEncoder methodsFor: 'accessing' stamp: 'MPW 1/1/1901 00:16'! 237132target 237133 ^target.! ! 237134 237135 237136!NullEncoder methodsFor: 'initialization' stamp: 'MPW 1/1/1901 00:04'! 237137initWithTarget:aTarget 237138 target := aTarget. 237139 filterSelector := self class filterSelector. 237140 ^self. 237141! ! 237142 237143 237144!NullEncoder methodsFor: 'processing' stamp: 'MPW 1/1/1901 01:19'! 237145process:anObject 237146 self write:anObject. 237147 ^self contents.! ! 237148 237149 237150!NullEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 01:17'! 237151forward:anObject 237152 anObject ~= nil ifTrue:[target write:anObject]. 237153! ! 237154 237155!NullEncoder methodsFor: 'writing' stamp: 'mpw 8/13/1999 10:54'! 237156write:anObject 237157 filterSelector ifNil:[filterSelector:=self class filterSelector]. 237158 anObject ifNotNil: [anObject perform:filterSelector with:self]. 237159! ! 237160 237161!NullEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 01:16'! 237162writeObject:anObject 237163 ^self forward:anObject. 237164! ! 237165 237166"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 237167 237168NullEncoder class 237169 instanceVariableNames: ''! 237170 237171!NullEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 00:02'! 237172defaultTarget 237173 ^OrderedCollection new. 237174! ! 237175 237176!NullEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 00:02'! 237177filterSelector 237178 ^#writeOnFilterStream: 237179! ! 237180 237181 237182!NullEncoder class methodsFor: 'creation' stamp: 'MPW 1/1/1901 00:55'! 237183stream 237184 ^self streamOn:self defaultTarget. 237185! ! 237186 237187!NullEncoder class methodsFor: 'creation' stamp: 'MPW 1/1/1901 00:05'! 237188stream:newTarget 237189 ^self new initWithTarget:newTarget. 237190! ! 237191 237192!NullEncoder class methodsFor: 'creation' stamp: 'MPW 1/1/1901 01:15'! 237193streamOn:newTargetCollection 237194 ^self new initWithTarget:newTargetCollection. 237195! ! 237196 237197!NullEncoder class methodsFor: 'creation' stamp: 'MPW 1/1/1901 02:20'! 237198streamOnFile:fileName 237199 ^self new initWithTarget:(FileStream newFileNamed: fileName). 237200! ! 237201 237202 237203!NullEncoder class methodsFor: 'processing' stamp: 'MPW 1/1/1901 01:20'! 237204process:anObject 237205 ^self stream process:anObject. 237206 237207! ! 237208Object subclass: #NullSound 237209 instanceVariableNames: '' 237210 classVariableNames: '' 237211 poolDictionaries: '' 237212 category: 'Polymorph-Widgets-Themes'! 237213 237214"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 237215 237216NullSound class 237217 instanceVariableNames: ''! 237218 237219!NullSound class methodsFor: 'playing' stamp: 'gvc 7/30/2009 17:55'! 237220play 237221 "Do nothing for the null sound."! ! 237222SoundTheme subclass: #NullSoundTheme 237223 instanceVariableNames: '' 237224 classVariableNames: '' 237225 poolDictionaries: '' 237226 category: 'Polymorph-Widgets-Themes'! 237227 237228!NullSoundTheme methodsFor: 'initialize-release' stamp: 'gvc 7/30/2009 17:56'! 237229defaultDefaultSound 237230 "Answer the default default sound!!" 237231 237232 ^NullSound! ! 237233 237234"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 237235 237236NullSoundTheme class 237237 instanceVariableNames: ''! 237238 237239!NullSoundTheme class methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 17:57'! 237240themeName 237241 "Answer the friendly name of the theme." 237242 237243 ^'No Sounds'! ! 237244Magnitude subclass: #Number 237245 instanceVariableNames: '' 237246 classVariableNames: '' 237247 poolDictionaries: '' 237248 category: 'Kernel-Numbers'! 237249!Number commentStamp: '<historical>' prior: 0! 237250Class Number holds the most general methods for dealing with numbers. Subclasses Float, Fraction, and Integer, and their subclasses, provide concrete representations of a numeric quantity. 237251 237252All of Number's subclasses participate in a simple type coercion mechanism that supports mixed-mode arithmetic and comparisons. It works as follows: If 237253 self<typeA> op: arg<typeB> 237254fails because of incompatible types, then it is retried in the following guise: 237255 (arg adaptTypeA: self) op: arg adaptToTypeA. 237256This gives the arg of typeB an opportunity to resolve the incompatibility, knowing exactly what two types are involved. If self is more general, then arg will be converted, and viceVersa. This mechanism is extensible to any new number classes that one might wish to add to Squeak. The only requirement is that every subclass of Number must support a pair of conversion methods specific to each of the other subclasses of Number.! 237257 237258 237259!Number methodsFor: 'arithmetic'! 237260* aNumber 237261 "Answer the result of multiplying the receiver by aNumber." 237262 237263 self subclassResponsibility! ! 237264 237265!Number methodsFor: 'arithmetic'! 237266+ aNumber 237267 "Answer the sum of the receiver and aNumber." 237268 237269 self subclassResponsibility! ! 237270 237271!Number methodsFor: 'arithmetic'! 237272- aNumber 237273 "Answer the difference between the receiver and aNumber." 237274 237275 self subclassResponsibility! ! 237276 237277!Number methodsFor: 'arithmetic'! 237278/ aNumber 237279 "Answer the result of dividing the receiver by aNumber." 237280 237281 self subclassResponsibility! ! 237282 237283!Number methodsFor: 'arithmetic'! 237284// aNumber 237285 "Integer quotient defined by division with truncation toward negative 237286 infinity. 9//4 = 2, -9//4 = -3. -0.9//0.4 = -3. \\ answers the remainder 237287 from this division." 237288 237289 ^(self / aNumber) floor! ! 237290 237291!Number methodsFor: 'arithmetic'! 237292\\ aNumber 237293 "modulo. Remainder defined in terms of //. Answer a Number with the 237294 same sign as aNumber. e.g. 9\\4 = 1, -9\\4 = 3, 9\\-4 = -3, 0.9\\0.4 = 0.1." 237295 237296 ^self - (self // aNumber * aNumber)! ! 237297 237298!Number methodsFor: 'arithmetic'! 237299abs 237300 "Answer a Number that is the absolute value (positive magnitude) of the 237301 receiver." 237302 237303 self < 0 237304 ifTrue: [^self negated] 237305 ifFalse: [^self]! ! 237306 237307!Number methodsFor: 'arithmetic' stamp: 'mk 10/27/2003 21:00'! 237308arg 237309 "Answer the argument of the receiver (see Complex | arg)." 237310 237311 self isZero ifTrue: [self error: 'Zero (0 + 0 i) does not have an argument.']. 237312 0 < self 237313 ifTrue: [^ 0] 237314 ifFalse: [^ Float pi]! ! 237315 237316!Number methodsFor: 'arithmetic'! 237317negated 237318 "Answer a Number that is the negation of the receiver." 237319 237320 ^0 - self! ! 237321 237322!Number methodsFor: 'arithmetic'! 237323quo: aNumber 237324 "Integer quotient defined by division with truncation toward zero. -9 quo: 237325 4 = -2, -0.9 quo: 0.4 = -2. rem: answers the remainder from this division." 237326 237327 ^(self / aNumber) truncated! ! 237328 237329!Number methodsFor: 'arithmetic' stamp: 'GabrielOmarCotelli 5/23/2009 20:20'! 237330reciprocal 237331 "Returns the reciprocal of self. 237332 In case self is 0 the / signals ZeroDivide" 237333 237334 ^1 / self! ! 237335 237336!Number methodsFor: 'arithmetic'! 237337rem: aNumber 237338 "Remainder defined in terms of quo:. Answer a Number with the same 237339 sign as self. e.g. 9 rem: 4 = 1, -9 rem: 4 = -1. 0.9 rem: 0.4 = 0.1." 237340 237341 ^self - ((self quo: aNumber) * aNumber)! ! 237342 237343 237344!Number methodsFor: 'comparing' stamp: 'eem 6/11/2008 17:51'! 237345closeTo: num 237346 "are these two numbers close?" 237347 237348 num isFloat ifTrue: [^ num closeTo: self asFloat]. 237349 ^[self = num] ifError: [:aString :aReceiver | ^ false]! ! 237350 237351 237352!Number methodsFor: 'converting'! 237353@ y 237354 "Primitive. Answer a Point whose x value is the receiver and whose y 237355 value is the argument. Optional. No Lookup. See Object documentation 237356 whatIsAPrimitive." 237357 237358 <primitive: 18> 237359 ^Point x: self y: y! ! 237360 237361!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:43'! 237362adaptToCollection: rcvr andSend: selector 237363 "If I am involved in arithmetic with a Collection, return a Collection of 237364 the results of each element combined with me in that expression." 237365 237366 ^ rcvr collect: [:element | element perform: selector with: self]! ! 237367 237368!Number methodsFor: 'converting' stamp: 'nice 1/4/2009 20:31'! 237369adaptToFloat: rcvr andCompare: selector 237370 "If I am involved in comparison with a Float, convert rcvr to a 237371 Fraction. This way, no bit is lost and comparison is exact." 237372 237373 rcvr isFinite 237374 ifFalse: [ 237375 selector == #= ifTrue: [^false]. 237376 selector == #~= ifTrue: [^true]. 237377 rcvr isNaN ifTrue: [^ false]. 237378 (selector = #< or: [selector = #'<=']) 237379 ifTrue: [^ rcvr positive not]. 237380 (selector = #> or: [selector = #'>=']) 237381 ifTrue: [^ rcvr positive]. 237382 ^self error: 'unknow comparison selector']. 237383 237384 ^ rcvr asTrueFraction perform: selector with: self! ! 237385 237386!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:21'! 237387adaptToFloat: rcvr andSend: selector 237388 "If I am involved in arithmetic with a Float, convert me to a Float." 237389 ^ rcvr perform: selector with: self asFloat! ! 237390 237391!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'! 237392adaptToFraction: rcvr andSend: selector 237393 "If I am involved in arithmetic with a Fraction, convert us and evaluate exprBlock." 237394 ^ self subclassResponsibility! ! 237395 237396!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'! 237397adaptToInteger: rcvr andSend: selector 237398 "If I am involved in arithmetic with a Integer, convert us and evaluate exprBlock." 237399 ^ self subclassResponsibility! ! 237400 237401!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'! 237402adaptToPoint: rcvr andSend: selector 237403 "If I am involved in arithmetic with a Point, convert me to a Point." 237404 ^ rcvr perform: selector with: self@self! ! 237405 237406!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:45'! 237407adaptToString: rcvr andSend: selector 237408 "If I am involved in arithmetic with a String, convert it to a Number." 237409 ^ rcvr asNumber perform: selector with: self! ! 237410 237411!Number methodsFor: 'converting' stamp: 'ar 5/20/2001 01:40'! 237412asB3DVector3 237413 ^self@self@self! ! 237414 237415!Number methodsFor: 'converting' stamp: 'brp 5/13/2003 10:13'! 237416asDuration 237417 237418 ^ Duration nanoSeconds: self asInteger 237419 ! ! 237420 237421!Number methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'! 237422asFloatD 237423 "Answer a d precision floating-point number approximating the receiver." 237424 #Numeric. 237425 "add 200/01/19 For ANSI <number> protocol." 237426 ^ self asFloat! ! 237427 237428!Number methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'! 237429asFloatE 237430 "Answer a floating-point number approximating the receiver." 237431 #Numeric. 237432 "add 200/01/19 For ANSI <number> protocol." 237433 ^ self asFloat! ! 237434 237435!Number methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'! 237436asFloatQ 237437 "Answer a floating-point number approximating the receiver." 237438 #Numeric. 237439 "add 200/01/19 For ANSI <number> protocol." 237440 ^ self asFloat! ! 237441 237442!Number methodsFor: 'converting'! 237443asInteger 237444 "Answer an Integer nearest the receiver toward zero." 237445 237446 ^self truncated! ! 237447 237448!Number methodsFor: 'converting' stamp: 'sw 2/16/1999 18:15'! 237449asNumber 237450 ^ self! ! 237451 237452!Number methodsFor: 'converting'! 237453asPoint 237454 "Answer a Point with the receiver as both coordinates; often used to 237455 supply the same value in two dimensions, as with symmetrical gridding 237456 or scaling." 237457 237458 ^self @ self! ! 237459 237460!Number methodsFor: 'converting' stamp: 'dtl 9/25/2004 11:47'! 237461asScaledDecimal 237462 "Answer a scaled decimal number approximating the receiver." 237463 #Numeric. 237464 237465 ^ self asScaledDecimal: 8 237466! ! 237467 237468!Number methodsFor: 'converting' stamp: 'nice 5/16/2009 22:46'! 237469asScaledDecimal: scale 237470 "Answer the receiver converted to a ScaledDecimal." 237471 237472 ^ ScaledDecimal newFromNumber: self scale: scale! ! 237473 237474!Number methodsFor: 'converting' stamp: 'sw 9/8/97 16:30'! 237475asSmallAngleDegrees 237476 "Return the receiver normalized to lie within the range (-180, 180)" 237477 237478 | pos | 237479 pos := self \\ 360. 237480 pos > 180 ifTrue: [pos := pos - 360]. 237481 ^ pos 237482 237483"#(-500 -300 -150 -5 0 5 150 300 500 1200) collect: [:n | n asSmallAngleDegrees]"! ! 237484 237485!Number methodsFor: 'converting' stamp: 'sw 10/7/1999 12:24'! 237486asSmallPositiveDegrees 237487 "Return the receiver normalized to lie within the range (0, 360)" 237488 237489 | result | 237490 result := self. 237491 [result < 0] whileTrue: [result := result + 360]. 237492 ^ result \\ 360 237493 237494"#(-500 -300 -150 -5 0 5 150 300 500 1200) collect: [:n | n asSmallPositiveDegrees]"! ! 237495 237496!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:12'! 237497day 237498 237499 ^ self sign days! ! 237500 237501!Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:56'! 237502days 237503 237504 ^ Duration days: self! ! 237505 237506!Number methodsFor: 'converting'! 237507degreesToRadians 237508 "The receiver is assumed to represent degrees. Answer the conversion to 237509 radians." 237510 237511 ^self asFloat degreesToRadians! ! 237512 237513!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:28'! 237514hour 237515 237516 ^ self sign hours 237517 ! ! 237518 237519!Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:56'! 237520hours 237521 237522 ^ Duration hours: self! ! 237523 237524!Number methodsFor: 'converting' stamp: 'mk 10/27/2003 18:17'! 237525i 237526 ^ Complex real: 0 imaginary: self! ! 237527 237528!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:26'! 237529milliSecond 237530 237531 ^ self sign milliSeconds 237532 ! ! 237533 237534!Number methodsFor: 'converting' stamp: 'brp 9/25/2003 13:16'! 237535milliSeconds 237536 237537 ^ Duration milliSeconds: self 237538 ! ! 237539 237540!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:16'! 237541minute 237542 237543 ^ self sign minutes 237544 ! ! 237545 237546!Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:56'! 237547minutes 237548 237549 ^ Duration minutes: self! ! 237550 237551!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:27'! 237552nanoSecond 237553 237554 ^ self sign nanoSeconds 237555 ! ! 237556 237557!Number methodsFor: 'converting' stamp: 'brp 5/16/2003 08:52'! 237558nanoSeconds 237559 237560 ^ Duration nanoSeconds: self.! ! 237561 237562!Number methodsFor: 'converting'! 237563radiansToDegrees 237564 "The receiver is assumed to represent radians. Answer the conversion to 237565 degrees." 237566 237567 ^self asFloat radiansToDegrees! ! 237568 237569!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:17'! 237570second 237571 237572 ^ self sign seconds 237573 ! ! 237574 237575!Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:57'! 237576seconds 237577 237578 ^ Duration seconds: self! ! 237579 237580!Number methodsFor: 'converting' stamp: 'brp 5/21/2003 08:20'! 237581sign: aNumber 237582 "Return a Number with the same sign as aNumber" 237583 237584 ^ aNumber positive ifTrue: [self abs] ifFalse: [self abs negated].! ! 237585 237586!Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:19'! 237587week 237588 237589 ^ self sign weeks 237590 ! ! 237591 237592!Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:57'! 237593weeks 237594 237595 ^ Duration weeks: self! ! 237596 237597 237598!Number methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:07'! 237599byteEncode:aStream 237600 ^aStream writeNumber:self. 237601! ! 237602 237603 237604!Number methodsFor: 'intervals'! 237605to: stop 237606 "Answer an Interval from the receiver up to the argument, stop, 237607 incrementing by 1." 237608 237609 ^Interval from: self to: stop by: 1! ! 237610 237611!Number methodsFor: 'intervals'! 237612to: stop by: step 237613 "Answer an Interval from the receiver up to the argument, stop, 237614 incrementing by step." 237615 237616 ^Interval from: self to: stop by: step! ! 237617 237618!Number methodsFor: 'intervals' stamp: 'tao 1/30/1999 08:58'! 237619to: stop by: step do: aBlock 237620 "Normally compiled in-line, and therefore not overridable. 237621 Evaluate aBlock for each element of the interval (self to: stop by: 237622step)." 237623 | nextValue | 237624 nextValue := self. 237625 step = 0 ifTrue: [self error: 'step must be non-zero']. 237626 step < 0 237627 ifTrue: [[stop <= nextValue] 237628 whileTrue: 237629 [aBlock value: nextValue. 237630 nextValue := nextValue + step]] 237631 ifFalse: [[stop >= nextValue] 237632 whileTrue: 237633 [aBlock value: nextValue. 237634 nextValue := nextValue + step]]! ! 237635 237636!Number methodsFor: 'intervals'! 237637to: stop do: aBlock 237638 "Normally compiled in-line, and therefore not overridable. 237639 Evaluate aBlock for each element of the interval (self to: stop by: 1)." 237640 | nextValue | 237641 nextValue := self. 237642 [nextValue <= stop] 237643 whileTrue: 237644 [aBlock value: nextValue. 237645 nextValue := nextValue + 1]! ! 237646 237647 237648!Number methodsFor: 'mathematical functions'! 237649arcCos 237650 "The receiver is the cosine of an angle. Answer the angle measured in 237651 radians." 237652 237653 ^self asFloat arcCos! ! 237654 237655!Number methodsFor: 'mathematical functions'! 237656arcSin 237657 "The receiver is the sine of an angle. Answer the angle measured in 237658 radians." 237659 237660 ^self asFloat arcSin! ! 237661 237662!Number methodsFor: 'mathematical functions'! 237663arcTan 237664 "The receiver is the tangent of an angle. Answer the angle measured in 237665 radians." 237666 237667 ^self asFloat arcTan! ! 237668 237669!Number methodsFor: 'mathematical functions' stamp: 'jsp 2/24/1999 15:20'! 237670arcTan: denominator 237671 "The receiver is the tangent of an angle. Answer the angle measured in 237672 radians." 237673 237674 ^(self asFloat) arcTan: denominator.! ! 237675 237676!Number methodsFor: 'mathematical functions'! 237677cos 237678 "The receiver represents an angle measured in radians. Answer its cosine." 237679 237680 ^self asFloat cos! ! 237681 237682!Number methodsFor: 'mathematical functions' stamp: 'sd 3/5/2004 10:04'! 237683degreeCos 237684 "Answer the cosine of the receiver taken as an angle in degrees." 237685 237686 ^ (90 + self) degreeSin! ! 237687 237688!Number methodsFor: 'mathematical functions' stamp: 'sd 3/5/2004 10:04'! 237689degreeSin 237690 "Answer the sine of the receiver taken as an angle in degrees." 237691 237692 ^ self asFloat degreesToRadians sin! ! 237693 237694!Number methodsFor: 'mathematical functions'! 237695exp 237696 "Answer the exponential of the receiver as a floating point number." 237697 237698 ^self asFloat exp! ! 237699 237700!Number methodsFor: 'mathematical functions' stamp: 'jm 3/27/98 06:16'! 237701floorLog: radix 237702 "Answer the floor of the log base radix of the receiver." 237703 237704 ^ self asFloat floorLog: radix 237705! ! 237706 237707!Number methodsFor: 'mathematical functions' stamp: 'ar 8/31/2000 20:05'! 237708interpolateTo: aNumber at: param 237709 ^self + (aNumber - self * param)! ! 237710 237711!Number methodsFor: 'mathematical functions'! 237712ln 237713 "Answer the natural log of the receiver." 237714 237715 ^self asFloat ln! ! 237716 237717!Number methodsFor: 'mathematical functions' stamp: 'di 9/8/1998 17:10'! 237718log 237719 "Answer the base-10 log of the receiver." 237720 237721 ^self asFloat log! ! 237722 237723!Number methodsFor: 'mathematical functions'! 237724log: aNumber 237725 "Answer the log base aNumber of the receiver." 237726 237727 ^self ln / aNumber ln! ! 237728 237729!Number methodsFor: 'mathematical functions' stamp: 'nice 12/6/2007 21:46'! 237730raisedTo: aNumber 237731 "Answer the receiver raised to aNumber." 237732 237733 aNumber isInteger ifTrue: 237734 ["Do the special case of integer power" 237735 ^ self raisedToInteger: aNumber]. 237736 self < 0 ifTrue: 237737 [ self error: self printString, ' raised to a non-integer power' ]. 237738 0 = aNumber ifTrue: [^ self class one]. "Special case of exponent=0" 237739 1 = aNumber ifTrue: [^ self]. "Special case of exponent=1" 237740 0 = self ifTrue: [ "Special case of self = 0" 237741 aNumber < 0 237742 ifTrue: [^ (ZeroDivide dividend: self) signal] 237743 ifFalse: [^ self]]. 237744 ^ (aNumber * self ln) exp "Otherwise use logarithms"! ! 237745 237746!Number methodsFor: 'mathematical functions' stamp: 'GabrielOmarCotelli 5/26/2009 19:49'! 237747raisedToInteger: anInteger 237748 237749 "The 0 raisedToInteger: 0 is an special case. In some contexts must be 1 and in others must 237750 be handled as an indeterminate form. 237751 I take the first context because that's the way that was previously handled. 237752 Maybe further discussion is required on this topic." 237753 237754 |bitProbe result| 237755 237756 anInteger negative ifTrue: [^(self raisedToInteger: anInteger negated) reciprocal]. 237757 bitProbe := 1 bitShift: anInteger highBit - 1. 237758 result := self class one. 237759 [ 237760 (anInteger bitAnd: bitProbe) = 0 ifFalse: [result := result * self]. 237761 bitProbe := bitProbe bitShift: -1. 237762 bitProbe > 0 ] 237763 whileTrue: [result := result * result]. 237764 237765 ^result! ! 237766 237767!Number methodsFor: 'mathematical functions'! 237768sin 237769 "The receiver represents an angle measured in radians. Answer its sine." 237770 237771 ^self asFloat sin! ! 237772 237773!Number methodsFor: 'mathematical functions'! 237774sqrt 237775 "Answer the square root of the receiver." 237776 237777 ^self asFloat sqrt! ! 237778 237779!Number methodsFor: 'mathematical functions'! 237780squared 237781 "Answer the receiver multipled by itself." 237782 237783 ^self * self! ! 237784 237785!Number methodsFor: 'mathematical functions'! 237786tan 237787 "The receiver represents an angle measured in radians. Answer its 237788 tangent." 237789 237790 ^self asFloat tan! ! 237791 237792 237793!Number methodsFor: 'printing'! 237794defaultLabelForInspector 237795 "Answer the default label to be used for an Inspector window on the receiver." 237796 237797 ^ super defaultLabelForInspector, ': ', self printString! ! 237798 237799!Number methodsFor: 'printing' stamp: 'sw 6/29/1999 21:10'! 237800isOrAreStringWith: aNoun 237801 | result | 237802 result := self = 1 237803 ifTrue: 237804 [' is one '] 237805 ifFalse: 237806 [self = 0 237807 ifTrue: 237808 [' are no '] 237809 ifFalse: 237810 [' are ', self printString, ' ']]. 237811 result := result, aNoun. 237812 self = 1 ifFalse: [result := result, 's']. 237813 ^ result 237814 237815"#(0 1 2 98.6) do: 237816 [:num | Transcript cr; show: 'There', (num isOrAreStringWith: 'way'), ' to skin a cat']"! ! 237817 237818!Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:53'! 237819printOn: aStream 237820 self printOn: aStream base: 10! ! 237821 237822!Number methodsFor: 'printing' stamp: 'nice 9/25/2007 02:36'! 237823printOn: aStream base: base 237824 "This method should print a representation of the number for the given base, 237825 excluding the base prefix (and the letter r for radix)" 237826 237827 ^self subclassResponsibility! ! 237828 237829!Number methodsFor: 'printing' stamp: 'nice 4/24/2008 00:38'! 237830printShowingDecimalPlaces: placesDesired 237831 "Print the receiver showing precisely the given number of places desired. If placesDesired is positive, a decimal point and that many digits after the decimal point will always be shown. If placesDesired is zero, a whole number will be shown, without a decimal point." 237832 237833 | rounder rounded frac sign integerString fractionString result | 237834 placesDesired <= 0 ifTrue: [^ self rounded printString]. 237835 rounder := 10 raisedToInteger: placesDesired. 237836 rounded := self roundTo: rounder reciprocal. 237837 sign := rounded negative ifTrue: ['-'] ifFalse: ['']. 237838 integerString := rounded abs integerPart truncated printString. 237839 frac := ((rounded abs fractionPart) * rounder) truncated. 237840 fractionString := frac printString padded: #left to: placesDesired with: $0. 237841 result := sign , integerString , '.' , fractionString. 237842 ^result 237843" 23784423 printShowingDecimalPlaces: 2 23784523.5698 printShowingDecimalPlaces: 2 237846-234.567 printShowingDecimalPlaces: 5 23784723.4567 printShowingDecimalPlaces: 0 23784823.5567 printShowingDecimalPlaces: 0 237849-23.4567 printShowingDecimalPlaces: 0 237850-23.5567 printShowingDecimalPlaces: 0 237851100000000 printShowingDecimalPlaces: 1 2378520.98 printShowingDecimalPlaces: 5 237853-0.98 printShowingDecimalPlaces: 2 2378542.567 printShowingDecimalPlaces: 2 237855-2.567 printShowingDecimalPlaces: 2 2378560 printShowingDecimalPlaces: 2 237857"! ! 237858 237859!Number methodsFor: 'printing' stamp: 'laza 3/30/2004 10:50'! 237860printString 237861 ^self printStringBase: 10! ! 237862 237863!Number methodsFor: 'printing'! 237864printStringBase: base 237865 ^ String streamContents: 237866 [:strm | self printOn: strm base: base]! ! 237867 237868!Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:50'! 237869storeOn: aStream 237870 self printOn: aStream! ! 237871 237872!Number methodsFor: 'printing' stamp: 'nice 9/25/2007 02:35'! 237873storeOn: aStream base: base 237874 "This method should print a representation of the number for the given base, 237875 including the base prefix (with letter r for radix)" 237876 237877 ^self subclassResponsibility! ! 237878 237879!Number methodsFor: 'printing'! 237880storeStringBase: base 237881 ^ String streamContents: [:strm | self storeOn: strm base: base]! ! 237882 237883!Number methodsFor: 'printing' stamp: 'sw 7/1/1998 12:33'! 237884stringForReadout 237885 ^ self rounded printString! ! 237886 237887 237888!Number methodsFor: 'testing' stamp: 'sw 9/27/2001 17:26'! 237889basicType 237890 "Answer a symbol representing the inherent type of the receiver" 237891 237892 ^ #Number! ! 237893 237894!Number methodsFor: 'testing'! 237895even 237896 "Answer whether the receiver is an even number." 237897 237898 ^self \\ 2 = 0! ! 237899 237900!Number methodsFor: 'testing' stamp: 'sw 12/30/1998 13:21'! 237901isDivisibleBy: aNumber 237902 aNumber = 0 ifTrue: [^ false]. 237903 aNumber isInteger ifFalse: [^ false]. 237904 ^ (self \\ aNumber) = 0! ! 237905 237906!Number methodsFor: 'testing' stamp: 'nice 8/9/2009 21:02'! 237907isInf 237908 self deprecated: 'Use #isInfinite instead'. 237909 ^self isInfinite! ! 237910 237911!Number methodsFor: 'testing' stamp: 'tao 4/19/98 23:33'! 237912isInfinite 237913 237914 ^ false! ! 237915 237916!Number methodsFor: 'testing' stamp: 'tao 10/10/97 16:36'! 237917isNaN 237918 ^ false! ! 237919 237920!Number methodsFor: 'testing'! 237921isNumber 237922 ^ true! ! 237923 237924!Number methodsFor: 'testing'! 237925isZero 237926 ^self = 0! ! 237927 237928!Number methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'! 237929negative 237930 "Answer whether the receiver is mathematically negative." 237931 237932 ^ self < 0! ! 237933 237934!Number methodsFor: 'testing'! 237935odd 237936 "Answer whether the receiver is an odd number." 237937 237938 ^self even == false! ! 237939 237940!Number methodsFor: 'testing' stamp: 'di 4/23/1998 11:17'! 237941positive 237942 "Answer whether the receiver is positive or equal to 0. (ST-80 protocol). 237943 See also strictlyPositive" 237944 237945 ^ self >= 0! ! 237946 237947!Number methodsFor: 'testing'! 237948sign 237949 "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0." 237950 237951 self > 0 ifTrue: [^1]. 237952 self < 0 ifTrue: [^-1]. 237953 ^0! ! 237954 237955!Number methodsFor: 'testing' stamp: 'di 4/23/1998 11:02'! 237956strictlyPositive 237957 "Answer whether the receiver is mathematically positive." 237958 237959 ^ self > 0! ! 237960 237961 237962!Number methodsFor: 'truncation and round off'! 237963ceiling 237964 "Answer the integer nearest the receiver toward positive infinity." 237965 237966 self <= 0.0 237967 ifTrue: [^self truncated] 237968 ifFalse: [^self negated floor negated]! ! 237969 237970!Number methodsFor: 'truncation and round off' stamp: 'di 2/19/98 21:58'! 237971detentBy: detent atMultiplesOf: grid snap: snap 237972 "Map all values that are within detent/2 of any multiple of grid to that multiple. Otherwise, if snap is true, return self, meaning that the values in the dead zone will never be returned. If snap is false, then expand the range between dead zones so that it covers the range between multiples of the grid, and scale the value by that factor." 237973 | r1 r2 | 237974 r1 := self roundTo: grid. "Nearest multiple of grid" 237975 (self roundTo: detent) = r1 ifTrue: [^ r1]. "Snap to that multiple..." 237976 snap ifTrue: [^ self]. "...or return self" 237977 237978 r2 := self < r1 "Nearest end of dead zone" 237979 ifTrue: [r1 - (detent asFloat/2)] 237980 ifFalse: [r1 + (detent asFloat/2)]. 237981 "Scale values between dead zones to fill range between multiples" 237982 ^ r1 + ((self - r2) * grid asFloat / (grid - detent)) 237983" 237984 (170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: true] (170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: false] 237985 (3.9 to: 4.1 by: 0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: true] (-3.9 to: -4.1 by: -0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: false] 237986"! ! 237987 237988!Number methodsFor: 'truncation and round off'! 237989floor 237990 "Answer the integer nearest the receiver toward negative infinity." 237991 237992 | truncation | 237993 truncation := self truncated. 237994 self >= 0 ifTrue: [^truncation]. 237995 self = truncation 237996 ifTrue: [^truncation] 237997 ifFalse: [^truncation - 1]! ! 237998 237999!Number methodsFor: 'truncation and round off' stamp: 'GabrielOmarCotelli 5/26/2009 21:58'! 238000fractionPart 238001 238002 "Added for ANSI compatibility" 238003 238004 ^self - self integerPart! ! 238005 238006!Number methodsFor: 'truncation and round off' stamp: 'GabrielOmarCotelli 5/26/2009 21:57'! 238007integerPart 238008 "Added for ANSI compatibility" 238009 ^self truncated! ! 238010 238011!Number methodsFor: 'truncation and round off'! 238012reduce 238013 "If self is close to an integer, return that integer" 238014 ^ self! ! 238015 238016!Number methodsFor: 'truncation and round off' stamp: 'di 10/4/1999 08:08'! 238017roundTo: quantum 238018 "Answer the nearest number that is a multiple of quantum." 238019 238020 ^(self / quantum) rounded * quantum! ! 238021 238022!Number methodsFor: 'truncation and round off'! 238023roundUpTo: aNumber 238024 "Answer the next multiple of aNumber toward infinity that is nearest the 238025 receiver." 238026 238027 ^(self/aNumber) ceiling * aNumber! ! 238028 238029!Number methodsFor: 'truncation and round off'! 238030rounded 238031 "Answer the integer nearest the receiver." 238032 238033 ^(self + (self sign / 2)) truncated! ! 238034 238035!Number methodsFor: 'truncation and round off'! 238036truncateTo: aNumber 238037 "Answer the next multiple of aNumber toward zero that is nearest the 238038 receiver." 238039 238040 ^(self quo: aNumber) 238041 * aNumber! ! 238042 238043!Number methodsFor: 'truncation and round off'! 238044truncated 238045 "Answer an integer nearest the receiver toward zero." 238046 238047 ^self quo: 1! ! 238048 238049"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 238050 238051Number class 238052 instanceVariableNames: ''! 238053 238054!Number class methodsFor: 'constants' stamp: 'GabrielOmarCotelli 5/23/2009 20:46'! 238055one 238056 238057 ^1! ! 238058 238059 238060!Number class methodsFor: 'deprecated' stamp: 'dtl 7/3/2006 17:41'! 238061readExponent: baseValue base: base from: aStream 238062 "Complete creation of a number, reading exponent from aStream. Answer the 238063 number, or nil if parsing fails. 238064 <number>(e|d|q)<exponent>>" 238065 238066 | sign exp value | 238067 ('edq' includes: aStream next) ifFalse: [^ nil]. 238068 sign := ((aStream peek) == $-) 238069 ifTrue: [aStream next. -1] 238070 ifFalse: [1]. 238071 (aStream atEnd or: [(aStream peek digitValue between: 0 and: 9) not]) 238072 ifTrue: [^ nil]. "Avoid throwing an error" 238073 exp := (Integer readFrom: aStream base: 10) * sign. 238074 value := baseValue * (base raisedTo: exp). 238075 ^ value 238076! ! 238077 238078!Number class methodsFor: 'deprecated' stamp: 'dtl 7/4/2006 08:32'! 238079readRemainderOf: integerPart from: aStream base: base withSign: sign 238080 "Read optional fractional part and exponent or decimal scale, and return the final result" 238081 "Changed 200/01/19 For ANSI Numeric Literals support." 238082 "Number readFrom: '3r-22.2'" 238083 238084 | value fractionDigits fracpos fractionPart fraction pos v foundDecimal | 238085 #Numeric. 238086 value := integerPart. 238087 fractionDigits := 0. 238088 foundDecimal := false. 238089 (aStream peekFor: $.) 238090 ifTrue: ["<integer>.<fraction>" 238091 foundDecimal := true. 238092 (aStream atEnd not 238093 and: [aStream peek digitValue between: 0 and: base - 1]) 238094 ifTrue: [fracpos := aStream position. 238095 fractionPart := Integer readFrom: aStream base: base. 238096 fraction := fractionPart asFloat 238097 / (base raisedTo: aStream position - fracpos). 238098 fractionDigits := aStream position - fracpos. 238099 value := value asFloat + fraction]]. 238100 238101 pos := aStream position. 238102 (v := self readScaledDecimal: integerPart 238103 fractionPart: fractionPart 238104 digits: fractionDigits 238105 base: base 238106 sign: sign 238107 from: aStream) 238108 ifNil: [aStream position: pos] 238109 ifNotNil: [^ v "<number>s<scale>>"]. 238110 238111 pos := aStream position. 238112 (v := self readExponent: value base: base from: aStream) 238113 ifNil: [aStream position: pos. 238114 (foundDecimal and: [fractionDigits = 0]) 238115 ifTrue: ["oops - just <integer>." 238116 aStream skip: -1. 238117 "un-gobble the period" 238118 ^ value * sign]] 238119 ifNotNil: [value := v "<number>(e|d|q)<exponent>>"]. 238120 238121 (value isFloat 238122 and: [value = 0.0 238123 and: [sign = -1]]) 238124 ifTrue: [^ Float negativeZero] 238125 ifFalse: [^ value * sign]! ! 238126 238127!Number class methodsFor: 'deprecated' stamp: 'nice 5/16/2009 22:11'! 238128readScaledDecimal: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream 238129 "Complete creation of a ScaledDecimal, reading scale from aStream. Answer 238130 a ScaledDecimal, or nil if parsing fails. 238131 <number>s[<scale>]" 238132 238133 | scale decimalMultiplier decimalFraction | 238134 aStream atEnd ifTrue: [^ nil]. 238135 (aStream next == $s) ifFalse: [^ nil]. 238136 "<number>s<scale>" 238137 (aStream atEnd not and: [aStream peek digitValue between: 0 and: 9]) 238138 ifTrue: [scale := Integer readFrom: aStream] 238139 ifFalse: [^ nil]. 238140 scale isNil 238141 ifTrue: ["<number>s" 238142 fractionDigits = 0 238143 ifTrue: ["<integer>s" 238144 scale := 0] 238145 ifFalse: ["<integer>.<fraction>s" 238146 scale := fractionDigits]]. 238147 fractionPart isNil 238148 ifTrue: [^integerPart * sign asScaledDecimal: scale] 238149 ifFalse: [decimalMultiplier := base raisedTo: fractionDigits. 238150 decimalFraction := integerPart * decimalMultiplier + fractionPart * sign / decimalMultiplier. 238151 ^decimalFraction asScaledDecimal: scale]! ! 238152 238153 238154!Number class methodsFor: 'instance creation' stamp: 'nice 6/11/2009 03:38'! 238155readExactlyFrom: stringOrStream 238156 "Answer a number as described on aStream. The number may 238157 be any accepted Smalltalk literal Number format. 238158 It can include a leading radix specification, as in 16rFADE. 238159 It can as well be NaN, Infinity or -Infinity for conveniency. 238160 If stringOrStream does not start with a valid number description, then an Error is raised." 238161 238162 ^(SqNumberParser on: stringOrStream) nextNumber! ! 238163 238164!Number class methodsFor: 'instance creation' stamp: 'NikoSchwarz 10/17/2009 10:44'! 238165readFrom: stringOrStream 238166 "Answer a number as described on aStream. The number may 238167 be any accepted Smalltalk literal Number format. 238168 It can include a leading radix specification, as in 16rFADE. 238169 It can as well be NaN, Infinity or -Infinity for conveniency. 238170 If stringOrStream does not start with a valid number description, fail." 238171 238172 ^(SqNumberParser on: stringOrStream) failBlock: [^ self error: 'Reading a number failed']; nextNumber! ! 238173 238174!Number class methodsFor: 'instance creation' stamp: 'nice 6/11/2009 03:34'! 238175readFrom: stringOrStream base: base 238176 "Answer a number as described on aStream in the given number base. 238177 If stringOrStream does not start with a valid number description, answer 0 for backward compatibility. This is not clever and should better be changed." 238178 238179 ^(SqNumberParser on: stringOrStream) failBlock: [^0]; nextNumberBase: base! ! 238180 238181!Number class methodsFor: 'instance creation' stamp: 'nice 3/15/2008 00:42'! 238182readFrom: stringOrStream ifFail: aBlock 238183 "Answer a number as described on aStream. The number may 238184 be any accepted Smalltalk literal Number format. 238185 It can include a leading radix specification, as in 16rFADE. 238186 It can as well be NaN, Infinity or -Infinity for conveniency. 238187 If input does not represent a valid number, then execute fail block 238188 and leave the stream positioned before offending character" 238189 238190 ^(SqNumberParser on: stringOrStream) failBlock: aBlock; nextNumber! ! 238191TestCase subclass: #NumberParsingTest 238192 instanceVariableNames: '' 238193 classVariableNames: '' 238194 poolDictionaries: '' 238195 category: 'KernelTests-Numbers'! 238196!NumberParsingTest commentStamp: 'dtl 11/24/2004 15:35' prior: 0! 238197Tests to verify parsing of numbers from streams and strings. 238198 238199Note: ScaledDecimalTest contains related tests for parsing ScaledDecimal.! 238200 238201 238202!NumberParsingTest methodsFor: 'tests - Float' stamp: 'dtl 11/24/2004 14:29'! 238203testFloatFromStreamAsNumber 238204 "This covers parsing in Number>>readFrom:" 238205 238206 | rs aFloat | 238207 rs := '10r-12.3456' readStream. 238208 aFloat := Number readFrom: rs. 238209 self assert: -12.3456 = aFloat. 238210 self assert: rs atEnd. 238211 238212 rs := '10r-12.3456e2' readStream. 238213 aFloat := Number readFrom: rs. 238214 self assert: -1234.56 = aFloat. 238215 self assert: rs atEnd. 238216 238217 rs := '10r-12.3456e2e2' readStream. 238218 aFloat := Number readFrom: rs. 238219 self assert: -1234.56 = aFloat. 238220 self assert: rs upToEnd = 'e2'. 238221 238222 rs := '10r-12.3456d2' readStream. 238223 aFloat := Number readFrom: rs. 238224 self assert: -1234.56 = aFloat. 238225 self assert: rs atEnd. 238226 238227 rs := '10r-12.3456q2' readStream. 238228 aFloat := Number readFrom: rs. 238229 self assert: -1234.56 = aFloat. 238230 self assert: rs atEnd. 238231 238232 rs := '-12.3456q2' readStream. 238233 aFloat := Number readFrom: rs. 238234 self assert: -1234.56 = aFloat. 238235 self assert: rs atEnd. 238236 238237 rs := '12.3456q2' readStream. 238238 aFloat := Number readFrom: rs. 238239 self assert: 1234.56 = aFloat. 238240 self assert: rs atEnd. 238241 238242 rs := '12.3456z2' readStream. 238243 aFloat := Number readFrom: rs. 238244 self assert: 12.3456 = aFloat. 238245 self assert: rs upToEnd = 'z2'. 238246! ! 238247 238248!NumberParsingTest methodsFor: 'tests - Float' stamp: 'nice 4/28/2006 01:20'! 238249testFloatFromStreamWithExponent 238250 "This covers parsing in Number>>readFrom:" 238251 238252 | rs aFloat | 238253 rs := '1.0e-14' readStream. 238254 aFloat := Number readFrom: rs. 238255 self assert: 1.0e-14 = aFloat. 238256 self assert: rs atEnd. 238257 238258 rs := '1.0e-14 1' readStream. 238259 aFloat := Number readFrom: rs. 238260 self assert: 1.0e-14 = aFloat. 238261 self assert: rs upToEnd = ' 1'. 238262 238263 rs := '1.0e-14eee' readStream. 238264 aFloat := Number readFrom: rs. 238265 self assert: 1.0e-14 = aFloat. 238266 self assert: rs upToEnd = 'eee'. 238267 238268 rs := '1.0e14e10' readStream. 238269 aFloat := Number readFrom: rs. 238270 self assert: 1.0e14 = aFloat. 238271 self assert: rs upToEnd = 'e10'. 238272 238273 rs := '1.0e+14e' readStream. "Plus sign is not parseable" 238274 aFloat := Number readFrom: rs. 238275 self assert: 1.0 = aFloat. 238276 self assert: rs upToEnd = 'e+14e'. 238277 238278 rs := '1.0e' readStream. 238279 aFloat := Number readFrom: rs. 238280 self assert: 1.0 = aFloat. 238281 self assert: rs upToEnd = 'e'.! ! 238282 238283!NumberParsingTest methodsFor: 'tests - Float' stamp: 'dtl 11/24/2004 14:07'! 238284testFloatFromStringAsNumber 238285 "This covers parsing in Number>>readFrom:" 238286 238287 | aFloat | 238288 aFloat := '10r-12.3456' asNumber. 238289 self assert: -12.3456 = aFloat. 238290 aFloat := '10r-12.3456e2' asNumber. 238291 self assert: -1234.56 = aFloat. 238292 aFloat := '10r-12.3456d2' asNumber. 238293 self assert: -1234.56 = aFloat. 238294 aFloat := '10r-12.3456q2' asNumber. 238295 self assert: -1234.56 = aFloat. 238296 aFloat := '-12.3456q2' asNumber. 238297 self assert: -1234.56 = aFloat. 238298 aFloat := '12.3456q2' asNumber. 238299 self assert: 1234.56 = aFloat. 238300! ! 238301 238302!NumberParsingTest methodsFor: 'tests - Float' stamp: 'dtl 11/24/2004 14:12'! 238303testFloatFromStringWithExponent 238304 "This covers parsing in Number>>readFrom:" 238305 238306 | aFloat | 238307 aFloat := '1.0e-14' asNumber. 238308 self assert: 1.0e-14 = aFloat. 238309 aFloat := '1.0e-14 1' asNumber. 238310 self assert: 1.0e-14 = aFloat. 238311 aFloat := '1.0e-14e' asNumber. 238312 self assert: 1.0e-14 = aFloat. 238313 aFloat := '1.0e14e' asNumber. 238314 self assert: 1.0e14 = aFloat. 238315 aFloat := '1.0e+14e' asNumber. "Plus sign is not parseable" 238316 self assert: 1.0 = aFloat. 238317! ! 238318 238319!NumberParsingTest methodsFor: 'tests - Float' stamp: 'damiencassou 5/30/2008 11:09'! 238320testFloatReadWithRadix 238321 "This covers parsing in Number>>readFrom: 238322 Note: In most Smalltalk dialects, the radix notation is not used for numbers 238323 with exponents. In Squeak, a string with radix and exponent can be parsed, 238324 and the exponent is always treated as base 10 (not the base indicated in the 238325 radix prefix). I am not sure if this is a feature, a bug, or both, but the 238326 Squeak behavior is documented in this test. -dtl" 238327 | aNumber rs | 238328 aNumber := '2r1.0101e9' asNumber. 238329 self assert: 672.0 = aNumber. 238330 self assert: (Number readFrom: '2r1.0101e9') = (1.3125 * (2 raisedTo: 9)). 238331 rs := '2r1.0101e9e9' readStream. 238332 self assert: (Number readFrom: rs) = 672.0. 238333 self assert: rs upToEnd = 'e9'! ! 238334 238335!NumberParsingTest methodsFor: 'tests - Float' stamp: 'NorbertHartl 5/28/2008 09:46'! 238336testNumberReadExactlyError 238337 "This covers parsing in Number>>readExactlyFrom:" 238338 238339 | rs | 238340 238341 rs := '' readStream. 238342 self should: [Number readExactlyFrom: rs] raise: Error. 238343 238344 rs := 'foo' readStream. 238345 self should: [Number readExactlyFrom: rs] raise: Error. 238346 238347 rs := 'radix' readStream. 238348 self should: [Number readFrom: rs] raise: Error. 238349 238350 rs := '.e0' readStream. 238351 self should: [Number readExactlyFrom: rs] raise: Error. 238352 238353 rs := '-.e0' readStream. 238354 self should: [Number readExactlyFrom: rs] raise: Error. 238355 238356 rs := '--1' readStream. 238357 self should: [Number readExactlyFrom: rs] raise: Error.! ! 238358 238359!NumberParsingTest methodsFor: 'tests - Float' stamp: 'NorbertHartl 5/28/2008 09:45'! 238360testNumberReadOnlyDigit 238361 "This covers parsing in Number>>readFrom:" 238362 238363 | rs num | 238364 rs := '1e' readStream. 238365 num := Number readFrom: rs. 238366 self assert: 1 = num. 238367 self assert: rs upToEnd = 'e'. 238368 238369 rs := '1s' readStream. 238370 num := Number readFrom: rs. 238371 self assert: 1 = num. 238372 self assert: rs upToEnd = 's'. 238373 238374 rs := '1.' readStream. 238375 num := Number readFrom: rs. 238376 self assert: 1 = num. 238377 self assert: num isInteger. 238378 self assert: rs upToEnd = '.'.! ! 238379 238380 238381!NumberParsingTest methodsFor: 'tests - Integer' stamp: 'dtl 11/24/2004 14:05'! 238382testIntegerFromString 238383 "This covers parsing in Number>>readFrom: 238384 Trailing decimal points should be ignored." 238385 238386 self assert: ('123' asNumber == 123). 238387 self assert: ('-123' asNumber == -123). 238388 self assert: ('123.' asNumber == 123). 238389 self assert: ('-123.' asNumber == -123). 238390 self assert: ('123This is not to be read' asNumber == 123). 238391 self assert: ('123s could be confused with a ScaledDecimal' asNumber == 123). 238392 self assert: ('123e could be confused with a Float' asNumber == 123). 238393! ! 238394 238395!NumberParsingTest methodsFor: 'tests - Integer' stamp: 'damiencassou 5/30/2008 11:09'! 238396testIntegerReadFrom 238397 "Ensure remaining characters in a stream are not lost when parsing an integer." 238398 | rs i s | 238399 rs := '123s could be confused with a ScaledDecimal' readStream. 238400 i := Number readFrom: rs. 238401 self assert: i == 123. 238402 s := rs upToEnd. 238403 self assert: 's could be confused with a ScaledDecimal' = s. 238404 rs := '123.s could be confused with a ScaledDecimal' readStream. 238405 i := Number readFrom: rs. 238406 self assert: i == 123. 238407 s := rs upToEnd. 238408 self assert: '.s could be confused with a ScaledDecimal' = s. 238409 rs := '123sA has unary message sA' readStream. 238410 i := Number readFrom: rs. 238411 self assert: i == 123. 238412 s := rs upToEnd. 238413 self assert: 'sA has unary message sA' = s. 238414 rs := '123sB has unary message sB' readStream. 238415 i := Number readFrom: rs. 238416 self assert: i == 123. 238417 s := rs upToEnd. 238418 self assert: 'sB has unary message sB' = s! ! 238419 238420!NumberParsingTest methodsFor: 'tests - Integer' stamp: 'dtl 11/24/2004 18:18'! 238421testIntegerReadWithRadix 238422 "This covers parsing in Number>>readFrom: 238423 Note: In most Smalltalk dialects, the radix notation is not used for numbers 238424 with exponents. In Squeak, a string with radix and exponent can be parsed, 238425 and the exponent is always treated as base 10 (not the base indicated in the 238426 radix prefix). I am not sure if this is a feature, a bug, or both, but the 238427 Squeak behavior is documented in this test. -dtl" 238428 238429 | aNumber rs | 238430 aNumber := '2r1e26' asNumber. 238431 self assert: 67108864 = aNumber. 238432 self assert: (Number readFrom: '2r1e26') = (2 raisedTo: 26). 238433 rs := '2r1e26eee' readStream. 238434 self assert: (Number readFrom: rs) = 67108864. 238435 self assert: rs upToEnd = 'eee' 238436! ! 238437 238438 238439!NumberParsingTest methodsFor: 'tests - ScaledDecimal' stamp: 'nice 8/29/2008 22:04'! 238440testScaledDecimalWithTrailingZeroes 238441 "This is a non regression tests for http://bugs.squeak.org/view.php?id=7169" 238442 238443 self assert: (Number readFrom: '0.50s2') = (1/2). 238444 self assert: (Number readFrom: '0.500s3') = (1/2). 238445 self assert: (Number readFrom: '0.050s3') = (1/20).! ! 238446ClassTestCase subclass: #NumberTest 238447 instanceVariableNames: '' 238448 classVariableNames: '' 238449 poolDictionaries: '' 238450 category: 'KernelTests-Numbers'! 238451 238452!NumberTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/26/2009 21:57'! 238453testFractionPart 238454 238455 self 238456 assert: 2 fractionPart = 0; 238457 assert: (1/2) fractionPart = (1/2); 238458 assert: (4/3) fractionPart = (1/3); 238459 assert: 2.0 fractionPart = 0.0; 238460 assert: 0.5 fractionPart = 0.5; 238461 assert: 2.5 fractionPart = 0.5 238462! ! 238463 238464!NumberTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/26/2009 21:55'! 238465testIntegerPart 238466 238467 self 238468 assert: 2 integerPart = 2; 238469 assert: (1/2) integerPart = 0; 238470 assert: (4/3) integerPart = 1; 238471 assert: 2.0 integerPart = 2.0; 238472 assert: 0.5 integerPart = 0.0; 238473 assert: 2.5 integerPart = 2.0 238474! ! 238475 238476!NumberTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/23/2009 20:49'! 238477testOne 238478 238479 self 238480 assert: Integer one = 1; 238481 assert: Float one = 1.0; 238482 assert: Fraction one = 1! ! 238483 238484!NumberTest methodsFor: 'tests' stamp: 'adrian_lienhard 1/7/2009 17:55'! 238485testPrintShowingDecimalPlaces 238486 self assert: (111.2 printShowingDecimalPlaces: 2) = '111.20'. 238487 self assert: (111.2 printShowingDecimalPlaces: 0) = '111'. 238488 self assert: (111 printShowingDecimalPlaces: 0) = '111'. 238489 self assert: (111111111111111 printShowingDecimalPlaces: 2) = '111111111111111.00'. 238490 self assert: (10 printShowingDecimalPlaces: 20) ='10.00000000000000000000'. 238491 self assert: (0.98 printShowingDecimalPlaces: 2) = '0.98'. 238492 self assert: (-0.98 printShowingDecimalPlaces: 2) = '-0.98'. 238493 self assert: (2.567 printShowingDecimalPlaces: 2) = '2.57'. 238494 self assert: (-2.567 printShowingDecimalPlaces: 2) = '-2.57'. 238495 self assert: (0.01 printShowingDecimalPlaces: 2) = '0.01'. 238496 self assert: (-0.001 printShowingDecimalPlaces: 2) = '0.00'.! ! 238497 238498!NumberTest methodsFor: 'tests' stamp: 'nice 3/24/2008 16:50'! 238499testPrintShowingDecimalPlaces2 238500 "This tests problems related to Float>>rounded and Float>>roundTo:: 238501 - Float>>#rounded is inexact 238502 - Float>>#roundTo: might overflow" 238503 238504 "5000000000000001.0 asTrueFraction = 5000000000000001. 238505 5000000000000001 highBit = 53. 238506 This number is represented exactly asFloat, it should print exactly. 238507 Beware, 5000000000000001.0 rounded is inexact and will answer 5000000000000002" 238508 self assert: (5000000000000001.0 printShowingDecimalPlaces: 0) = '5000000000000001'. 238509 238510 "50000000000001.25 asTrueFraction = (200000000000005/4). 238511 200000000000005 highBit = 48, 4 isPowerOfTwo, 238512 So this number is also represented exactly as Float, it should print exactly. 238513 Beware: (50000000000001.25 / 0.01) rounded exhibit the same problem as above." 238514 self assert: (50000000000001.25 printShowingDecimalPlaces: 2) = '50000000000001.25'. 238515 238516 "This number is close to maximum float value" 238517 self shouldnt: [1.0e306 printShowingDecimalPlaces: 3] raise: Error.! ! 238518 238519!NumberTest methodsFor: 'tests' stamp: 'nice 4/24/2008 00:58'! 238520testPrintShowingDecimalPlaces3 238521 "This problem were reported at http://bugs.squeak.org/view.php?id=7028 238522 unfortunate inversion of left / right padding" 238523 238524 self assert: (1.009 printShowingDecimalPlaces: 3) = '1.009'. 238525 self assert: (35.900 printShowingDecimalPlaces: 3) = '35.900'. 238526 self assert: (-0.097 printShowingDecimalPlaces: 3) = '-0.097'.! ! 238527 238528!NumberTest methodsFor: 'tests' stamp: 'nice 12/6/2007 21:24'! 238529testRaisedTo 238530 "this is a test related to http://bugs.squeak.org/view.php?id=6781" 238531 238532 self should: [0 raisedTo: -1] raise: ZeroDivide. 238533 self should: [0 raisedTo: -1.0] raise: ZeroDivide.! ! 238534 238535!NumberTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2009 16:41'! 238536testRaisedToInteger 238537 238538 self 238539 assert: (2 raisedToInteger: 0) = 1; 238540 assert: (2 raisedToInteger: 1) = 2; 238541 assert: (2 raisedToInteger: 4) = 16; 238542 assert: (0 raisedToInteger: 0) = 1; 238543 assert: (0 raisedToInteger: 2) = 0; 238544 assert: (2 raisedToInteger: -1) = (1/2); 238545 assert: (2 raisedToInteger: -4) = (1/16). 238546 238547 self 238548 assert: (-3 raisedTo: 0) = 1; 238549 assert: (-3 raisedTo: 1) = -3; 238550 assert: (-3 raisedTo: 2) = 9; 238551 assert: (-3 raisedTo: 3) = -27; 238552 assert: (-3 raisedTo: -2) = (1/9); 238553 assert: (-3 raisedTo: -3) = (-1/27). 238554 238555 self should: [ 0 raisedTo: -1 ] raise: ZeroDivide! ! 238556 238557!NumberTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2009 16:46'! 238558testRaisedToIntegerWithFloats 238559 238560 self 238561 assert: (2.0 raisedToInteger: 0) = 1.0; 238562 assert: (2.0 raisedToInteger: 1) = 2.0; 238563 assert: (2.0 raisedToInteger: 4) = 16.0; 238564 assert: (0.0 raisedToInteger: 0) = 1.0; 238565 assert: (0.0 raisedToInteger: 2) = 0.0; 238566 assert: (2.0 raisedToInteger: -1) = 0.5; 238567 assert: (2.0 raisedToInteger: -4) = 0.0625. 238568 238569 self 238570 assert: (-3.0 raisedTo: 0) = 1.0; 238571 assert: (-3.0 raisedTo: 1) = -3.0; 238572 assert: (-3.0 raisedTo: 2) = 9.0; 238573 assert: (-3.0 raisedTo: 3) = -27.0; 238574 assert: (-2.0 raisedTo: -2) = 0.25; 238575 assert: (-2.0 raisedTo: -3) = -0.125. 238576 238577 self should: [ 0.0 raisedTo: -1 ] raise: ZeroDivide! ! 238578 238579!NumberTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:56'! 238580testReadFrom 238581 238582 self assert: 1.0e-14 = (Number readFrom: '1.0e-14'). 238583 self assert: 2r1e26 = (Number readFrom: '2r1e26').! ! 238584 238585!NumberTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/23/2009 19:26'! 238586testReciprocal 238587 238588 self 238589 assert: 1 reciprocal = 1; 238590 assert: 2 reciprocal = (1/2); 238591 assert: -1 reciprocal = -1; 238592 assert: -3 reciprocal = (-1/3). 238593 238594 self should: [ 0 reciprocal ] raise: ZeroDivide! ! 238595Object subclass: #OSPlatform 238596 instanceVariableNames: '' 238597 classVariableNames: 'Current' 238598 poolDictionaries: '' 238599 category: 'System-Platforms'! 238600!OSPlatform commentStamp: 'michael.rueger 2/25/2009 18:29' prior: 0! 238601An OSPlatform is an abstract representation of a 'OS platform'. 238602Platforms can be hierarchical, e.g., a "general" platform as superclass and more specific platforms as subclasses as long as the subclasses provide sufficient means to identify themselves. 238603The original implementation was for Tweak. 238604 238605Current holds the current OSPlatform subclass 238606 238607Architectural considerations: 238608most platform specific methods that need to be added to the platform class should be in the form of extensions rather then adding them directly to this package. Otherwise the platform class will degenerate very quickly into a dependence hub for all kinds of sub systems.! 238609 238610 238611!OSPlatform methodsFor: '*System-Clipboard' stamp: 'michael.rueger 3/2/2009 13:45'! 238612clipboardClass 238613 ^SqueakClipboard! ! 238614 238615 238616!OSPlatform methodsFor: 'accessing' stamp: 'michael.rueger 2/25/2009 18:18'! 238617platformFamily 238618 "Returns a symbol specific to the platform family (MacOSX, Windows, Unix, RiscOS). 238619 This may need to be extended if there are new platforms added or significant differences within a platform family arise (as was the case between MacOS 9 and X)." 238620 238621 self subclassResponsibility! ! 238622 238623!OSPlatform methodsFor: 'accessing' stamp: 'michael.rueger 2/25/2009 22:19'! 238624virtualKey: virtualKeyCode 238625 ^self class virtualKey: virtualKeyCode! ! 238626 238627 238628!OSPlatform methodsFor: 'initialize' stamp: 'ar 12/11/2004 22:47'! 238629shutDown: quitting 238630 "Squeak is shutting down. If this platform requires specific shutdown code, this is a great place to put it." 238631! ! 238632 238633!OSPlatform methodsFor: 'initialize' stamp: 'michael.rueger 2/25/2009 18:11'! 238634startUp: resuming 238635 "Squeak is starting up. If this platform requires specific intialization, this is a great place to put it." 238636! ! 238637 238638"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 238639 238640OSPlatform class 238641 instanceVariableNames: ''! 238642 238643!OSPlatform class methodsFor: 'accessing' stamp: 'ar 12/11/2004 23:04'! 238644current 238645 "Answer the current platform" 238646 ^Current! ! 238647 238648!OSPlatform class methodsFor: 'accessing' stamp: 'michael.rueger 2/27/2009 17:25'! 238649virtualKey: virtualKeyCode 238650 "Subclass responsibility to override if necessary" 238651 ^nil! ! 238652 238653 238654!OSPlatform class methodsFor: 'class initialization' stamp: 'michael.rueger 3/2/2009 11:16'! 238655initialize 238656 "Initialize the receiver" 238657 "OSPlatform initialize" 238658 238659 Smalltalk removeFromStartUpList: self. 238660 Smalltalk addToStartUpList: self after: Delay. 238661 Smalltalk removeFromShutDownList: self. 238662 Smalltalk addToShutDownList: self after: DisplayScreen. 238663 self startUp: true.! ! 238664 238665!OSPlatform class methodsFor: 'class initialization' stamp: 'ar 12/11/2004 22:49'! 238666shutDown: quitting 238667 "The system is going down" 238668 Current ifNotNil:[Current shutDown: quitting]. 238669! ! 238670 238671!OSPlatform class methodsFor: 'class initialization' stamp: 'michael.rueger 2/25/2009 18:20'! 238672startUp: resuming 238673 "Determine the current platform. 238674 Use the most specific (in terms of subclasses) platform available." 238675 238676 | platformClass | 238677 "Look for the matching platform class" 238678 platformClass := self determineActivePlatformStartingAt: self. 238679 platformClass 238680 ifNil: [^self]. 238681 Current := platformClass new. 238682 Current startUp: resuming! ! 238683 238684 238685!OSPlatform class methodsFor: 'private' stamp: 'michael.rueger 2/25/2009 18:20'! 238686determineActivePlatformStartingAt: parentClass 238687 "Determine the current platform starting at parentClass. 238688 This is a potentially recursive process as we want to determine the most specific (in terms of subclasses) platform available." 238689 "OSPlatform determineActivePlatformStartingAt: OSPlatform" 238690 238691 | platformClass | 238692 parentClass subclasses isEmpty 238693 ifTrue: [^parentClass]. 238694 238695 "Look for the matching platform class" 238696 platformClass := parentClass allSubclasses detect:[:any| any isActivePlatform] ifNone:[nil]. 238697 238698 "Check if there is a more specific subclass" 238699 ^self determineActivePlatformStartingAt: platformClass! ! 238700 238701!OSPlatform class methodsFor: 'private' stamp: 'ar 12/11/2004 22:22'! 238702isActivePlatform 238703 "Answer whether the receiver is the active platform" 238704 ^false! ! 238705TestCase subclass: #OSPlatformTest 238706 instanceVariableNames: '' 238707 classVariableNames: '' 238708 poolDictionaries: '' 238709 category: 'Tests-System'! 238710 238711!OSPlatformTest methodsFor: 'testing' stamp: 'AdrianLienhard 8/26/2009 21:27'! 238712testStartUpList 238713 "This test documents issue http://code.google.com/p/pharo/issues/detail?id=838" 238714 238715 self assert: [ ((SystemDictionary classPool at: 'StartUpList') indexOf: #OSPlatform) < ((SystemDictionary classPool at: 'StartUpList') indexOf: #InputEventSensor) ]! ! 238716ProtoObject subclass: #Object 238717 instanceVariableNames: '' 238718 classVariableNames: 'DependentsFields' 238719 poolDictionaries: '' 238720 category: 'Kernel-Objects'! 238721!Object commentStamp: '<historical>' prior: 0! 238722Object is the root class for almost all of the other classes in the class hierarchy. The exceptions are ProtoObject (the superclass of Object) and its subclasses. 238723 238724Class Object provides default behavior common to all normal objects, such as access, copying, comparison, error handling, message sending, and reflection. Also utility messages that all objects should respond to are defined here. 238725 238726Object has no instance variables, nor should any be added. This is due to several classes of objects that inherit from Object that have special implementations (SmallInteger and UndefinedObject for example) or the VM knows about and depends on the structure and layout of certain standard classes. 238727 238728Class Variables: 238729 DependentsFields an IdentityDictionary 238730 Provides a virtual 'dependents' field so that any object may have one 238731 or more dependent views, synchronized by the changed:/update: protocol. 238732 Note that class Model has a real slot for its dependents, and overrides 238733 the associated protocol with more efficient implementations. 238734 EventsFields an IdentityDictionary that maps each object to its dependents. 238735 Registers a message send (consisting of a selector and a receiver object) 238736 which should be performed when anEventSymbol is triggered by the receiver. 238737 Part of a new event notification framework which could eventually replace 238738 the existing changed/update mechanism. It is intended to be compatible 238739 with Dolphin Smalltalk and VSE as much as possible. 238740 238741Because Object is the root of the inheritance tree, methods are often defined in Object to give all objects special behaviors needed by certain subsystems or applications, or to respond to certain general test messages such as isMorph.! 238742 238743 238744!Object methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/25/2006 18:18'! 238745when: anEventSelector 238746send: aMessageSelector 238747to: anObject 238748exclusive: aValueHolder 238749 238750 self 238751 when: anEventSelector 238752 evaluate: ((ExclusiveWeakMessageSend 238753 receiver: anObject 238754 selector: aMessageSelector) 238755 basicExecuting: aValueHolder)! ! 238756 238757!Object methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/25/2006 18:17'! 238758when: anEventSelector 238759send: aMessageSelector 238760to: anObject 238761with: anArg 238762exclusive: aValueHolder 238763 238764 self 238765 when: anEventSelector 238766 evaluate: ((ExclusiveWeakMessageSend 238767 receiver: anObject 238768 selector: aMessageSelector 238769 arguments: (Array with: anArg)) 238770 basicExecuting: aValueHolder)! ! 238771 238772!Object methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/25/2006 18:17'! 238773when: anEventSelector 238774send: aMessageSelector 238775to: anObject 238776withArguments: anArgArray 238777exclusive: aValueHolder 238778 238779 self 238780 when: anEventSelector 238781 evaluate: ((ExclusiveWeakMessageSend 238782 receiver: anObject 238783 selector: aMessageSelector 238784 arguments: anArgArray) 238785 basicExecuting: aValueHolder)! ! 238786 238787!Object methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/24/2006 11:50'! 238788when: anEventSelector 238789sendOnce: aMessageSelector 238790to: anObject 238791 238792 self 238793 when: anEventSelector 238794 evaluate: (NonReentrantWeakMessageSend 238795 receiver: anObject 238796 selector: aMessageSelector)! ! 238797 238798!Object methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/24/2006 11:49'! 238799when: anEventSelector 238800sendOnce: aMessageSelector 238801to: anObject 238802with: anArg 238803 238804 self 238805 when: anEventSelector 238806 evaluate: (NonReentrantWeakMessageSend 238807 receiver: anObject 238808 selector: aMessageSelector 238809 arguments: (Array with: anArg))! ! 238810 238811!Object methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/24/2006 11:49'! 238812when: anEventSelector 238813sendOnce: aMessageSelector 238814to: anObject 238815withArguments: anArgArray 238816 238817 self 238818 when: anEventSelector 238819 evaluate: (NonReentrantWeakMessageSend 238820 receiver: anObject 238821 selector: aMessageSelector 238822 arguments: anArgArray)! ! 238823 238824 238825!Object methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/10/2007 11:41'! 238826okToClose 238827 "Sent to models when a window closing. 238828 Allows this check to be independent of okToChange." 238829 238830 ^true! ! 238831 238832!Object methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/17/2007 17:41'! 238833taskbarIcon 238834 "Answer the icon for the receiver in a task bar 238835 or nil for the default." 238836 238837 ^self class taskbarIcon! ! 238838 238839!Object methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/31/2009 15:52'! 238840taskbarLabel 238841 "Answer the label string for the receiver in a task bar 238842 or nil for the default." 238843 238844 ^self class taskbarLabel! ! 238845 238846 238847!Object methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/4/2007 12:32'! 238848windowActiveOnFirstClick 238849 "Return true if my window should be active on first click." 238850 238851 ^true! ! 238852 238853 238854!Object methodsFor: '*monticello' stamp: 'dvf 8/10/2004 23:25'! 238855isConflict 238856 ^false! ! 238857 238858 238859!Object methodsFor: '*services-base' stamp: 'rr 3/21/2006 11:54'! 238860requestor 238861 "returns the focused window's requestor" 238862 238863 "SystemWindow focusedWindow ifNotNilDo: [:w | ^ w requestor]." 238864 238865 "triggers an infinite loop" 238866 238867 ^ Requestor default! ! 238868 238869 238870!Object methodsFor: '*splitjoin' stamp: 'onierstrasz 4/12/2009 19:58'! 238871appendTo: aCollection 238872 "double dispatch for join:" 238873 ^ aCollection addLast: self! ! 238874 238875!Object methodsFor: '*splitjoin' stamp: 'onierstrasz 4/10/2009 22:50'! 238876join: aSequenceableCollection 238877 ^ (Array with: self) join: aSequenceableCollection! ! 238878 238879!Object methodsFor: '*splitjoin' stamp: 'onierstrasz 4/12/2009 19:58'! 238880joinTo: stream 238881 "double dispatch for join:" 238882 ^ stream nextPut: self! ! 238883 238884!Object methodsFor: '*splitjoin' stamp: 'onierstrasz 4/10/2009 22:49'! 238885split: aSequenceableCollection 238886 ^ (Array with: self) split: aSequenceableCollection! ! 238887 238888 238889!Object methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:27'! 238890systemNavigation 238891 238892 ^ SystemNavigation default! ! 238893 238894 238895!Object methodsFor: '*tools-browser' stamp: 'mu 3/6/2004 15:13'! 238896browse 238897 self systemNavigation browseClass: self class! ! 238898 238899!Object methodsFor: '*tools-browser' stamp: 'mu 3/11/2004 16:00'! 238900browseHierarchy 238901 self systemNavigation browseHierarchy: self class! ! 238902 238903 238904!Object methodsFor: '*tools-explorer' stamp: 'stephaneducasse 9/17/2005 21:52'! 238905exploreAndYourself 238906 "i.e. explore; yourself. Thisway i can peek w/o typing all the parentheses" 238907 self explore. 238908 ^self! ! 238909 238910!Object methodsFor: '*tools-explorer' stamp: 'stephaneducasse 9/17/2005 21:48'! 238911exploreWithLabel: label 238912 238913 ^ ObjectExplorer new openExplorerFor: self withLabel: 238914label! ! 238915 238916 238917!Object methodsFor: 'accessing' stamp: 'sw 4/30/1998 12:18'! 238918addInstanceVarNamed: aName withValue: aValue 238919 "Add an instance variable named aName and give it value aValue" 238920 self class addInstVarName: aName asString. 238921 self instVarAt: self class instSize put: aValue! ! 238922 238923!Object methodsFor: 'accessing' stamp: 'yo 6/29/2004 11:39'! 238924at: index 238925 "Primitive. Assumes receiver is indexable. Answer the value of an 238926 indexable element in the receiver. Fail if the argument index is not an 238927 Integer or is out of bounds. Essential. See Object documentation 238928 whatIsAPrimitive." 238929 238930 <primitive: 60> 238931 index isInteger ifTrue: 238932 [self class isVariable 238933 ifTrue: [self errorSubscriptBounds: index] 238934 ifFalse: [self errorNotIndexable]]. 238935 index isNumber 238936 ifTrue: [^self at: index asInteger] 238937 ifFalse: [self errorNonIntegerIndex]! ! 238938 238939!Object methodsFor: 'accessing'! 238940at: index modify: aBlock 238941 "Replace the element of the collection with itself transformed by the block" 238942 ^ self at: index put: (aBlock value: (self at: index))! ! 238943 238944!Object methodsFor: 'accessing' stamp: 'yo 6/29/2004 13:08'! 238945at: index put: value 238946 "Primitive. Assumes receiver is indexable. Store the argument value in 238947 the indexable element of the receiver indicated by index. Fail if the 238948 index is not an Integer or is out of bounds. Or fail if the value is not of 238949 the right type for this kind of collection. Answer the value that was 238950 stored. Essential. See Object documentation whatIsAPrimitive." 238951 238952 <primitive: 61> 238953 index isInteger ifTrue: 238954 [self class isVariable 238955 ifTrue: [(index >= 1 and: [index <= self size]) 238956 ifTrue: [self errorImproperStore] 238957 ifFalse: [self errorSubscriptBounds: index]] 238958 ifFalse: [self errorNotIndexable]]. 238959 index isNumber 238960 ifTrue: [^self at: index asInteger put: value] 238961 ifFalse: [self errorNonIntegerIndex]! ! 238962 238963!Object methodsFor: 'accessing'! 238964basicAt: index 238965 "Primitive. Assumes receiver is indexable. Answer the value of an 238966 indexable element in the receiver. Fail if the argument index is not an 238967 Integer or is out of bounds. Essential. Do not override in a subclass. See 238968 Object documentation whatIsAPrimitive." 238969 238970 <primitive: 60> 238971 index isInteger ifTrue: [self errorSubscriptBounds: index]. 238972 index isNumber 238973 ifTrue: [^self basicAt: index asInteger] 238974 ifFalse: [self errorNonIntegerIndex]! ! 238975 238976!Object methodsFor: 'accessing'! 238977basicAt: index put: value 238978 "Primitive. Assumes receiver is indexable. Store the second argument 238979 value in the indexable element of the receiver indicated by index. Fail 238980 if the index is not an Integer or is out of bounds. Or fail if the value is 238981 not of the right type for this kind of collection. Answer the value that 238982 was stored. Essential. Do not override in a subclass. See Object 238983 documentation whatIsAPrimitive." 238984 238985 <primitive: 61> 238986 index isInteger 238987 ifTrue: [(index >= 1 and: [index <= self size]) 238988 ifTrue: [self errorImproperStore] 238989 ifFalse: [self errorSubscriptBounds: index]]. 238990 index isNumber 238991 ifTrue: [^self basicAt: index asInteger put: value] 238992 ifFalse: [self errorNonIntegerIndex]! ! 238993 238994!Object methodsFor: 'accessing'! 238995basicSize 238996 "Primitive. Answer the number of indexable variables in the receiver. 238997 This value is the same as the largest legal subscript. Essential. Do not 238998 override in any subclass. See Object documentation whatIsAPrimitive." 238999 239000 <primitive: 62> 239001 "The number of indexable fields of fixed-length objects is 0" 239002 ^0 ! ! 239003 239004!Object methodsFor: 'accessing' stamp: 'yo 8/27/2008 23:16'! 239005customizeExplorerContents 239006 239007 ^ false. 239008! ! 239009 239010!Object methodsFor: 'accessing' stamp: 'md 10/7/2004 15:43'! 239011ifNil: nilBlock ifNotNilDo: aBlock 239012 "Evaluate aBlock with the receiver as its argument." 239013 239014 ^ aBlock value: self 239015! ! 239016 239017!Object methodsFor: 'accessing' stamp: 'di 11/8/2000 21:04'! 239018ifNotNilDo: aBlock 239019 "Evaluate the given block with the receiver as its argument." 239020 239021 ^ aBlock value: self 239022! ! 239023 239024!Object methodsFor: 'accessing' stamp: 'md 10/7/2004 15:43'! 239025ifNotNilDo: aBlock ifNil: nilBlock 239026 "Evaluate aBlock with the receiver as its argument." 239027 239028 ^ aBlock value: self 239029! ! 239030 239031!Object methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:59'! 239032in: aBlock 239033 "Evaluate the given block with the receiver as its argument." 239034 239035 ^ aBlock value: self 239036! ! 239037 239038!Object methodsFor: 'accessing' stamp: 'sw 10/17/2000 11:15'! 239039presenter 239040 "Answer the presenter object associated with the receiver. For morphs, there is in effect a clear containment hierarchy of presenters (accessed via their association with PasteUpMorphs); for arbitrary objects the hook is simply via the current world, at least at present." 239041 239042 ^ self currentWorld presenter! ! 239043 239044!Object methodsFor: 'accessing' stamp: 'damiencassou 5/30/2008 10:56'! 239045readFromString: aString 239046 "Create an object based on the contents of aString." 239047 ^ self readFrom: aString readStream! ! 239048 239049!Object methodsFor: 'accessing' stamp: 'di 3/29/1999 13:10'! 239050size 239051 "Primitive. Answer the number of indexable variables in the receiver. 239052 This value is the same as the largest legal subscript. Essential. See Object 239053 documentation whatIsAPrimitive." 239054 239055 <primitive: 62> 239056 self class isVariable ifFalse: [self errorNotIndexable]. 239057 ^ 0! ! 239058 239059!Object methodsFor: 'accessing' stamp: 'md 5/16/2006 12:34'! 239060yourself 239061 "Answer self." 239062 ^self! ! 239063 239064 239065!Object methodsFor: 'associating' stamp: 'md 7/22/2005 16:03'! 239066-> anObject 239067 "Answer an Association between self and anObject" 239068 239069 ^Association basicNew key: self value: anObject! ! 239070 239071 239072!Object methodsFor: 'binding'! 239073bindingOf: aString 239074 ^nil! ! 239075 239076 239077!Object methodsFor: 'breakpoint' stamp: 'bkv 7/1/2003 12:33'! 239078break 239079 "This is a simple message to use for inserting breakpoints during debugging. 239080 The debugger is opened by sending a signal. This gives a chance to restore 239081 invariants related to multiple processes." 239082 239083 BreakPoint signal. 239084 239085 "nil break."! ! 239086 239087 239088!Object methodsFor: 'casing'! 239089caseOf: aBlockAssociationCollection 239090 "The elements of aBlockAssociationCollection are associations between blocks. 239091 Answer the evaluated value of the first association in aBlockAssociationCollection 239092 whose evaluated key equals the receiver. If no match is found, report an error." 239093 239094 ^ self caseOf: aBlockAssociationCollection otherwise: [self caseError] 239095 239096"| z | z := {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z" 239097"| z | z := {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z" 239098"The following are compiled in-line:" 239099"#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}" 239100"#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}"! ! 239101 239102!Object methodsFor: 'casing'! 239103caseOf: aBlockAssociationCollection otherwise: aBlock 239104 "The elements of aBlockAssociationCollection are associations between blocks. 239105 Answer the evaluated value of the first association in aBlockAssociationCollection 239106 whose evaluated key equals the receiver. If no match is found, answer the result 239107 of evaluating aBlock." 239108 239109 aBlockAssociationCollection associationsDo: 239110 [:assoc | (assoc key value = self) ifTrue: [^assoc value value]]. 239111 ^ aBlock value 239112 239113"| z | z := {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]" 239114"| z | z := {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]" 239115"The following are compiled in-line:" 239116"#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]" 239117"#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]"! ! 239118 239119 239120!Object methodsFor: 'class membership'! 239121class 239122 "Primitive. Answer the object which is the receiver's class. Essential. See 239123 Object documentation whatIsAPrimitive." 239124 239125 <primitive: 111> 239126 self primitiveFailed! ! 239127 239128!Object methodsFor: 'class membership' stamp: 'sw 9/27/2001 15:51'! 239129inheritsFromAnyIn: aList 239130 "Answer whether the receiver inherits from any class represented by any element in the list. The elements of the list can be classes, class name symbols, or strings representing possible class names. This allows speculative membership tests to be made even when some of the classes may not be known to the current image, and even when their names are not interned symbols." 239131 239132 | aClass | 239133 aList do: 239134 [:elem | Symbol hasInterned: elem asString ifTrue: 239135 [:elemSymbol | (((aClass := Smalltalk at: elemSymbol ifAbsent: [nil]) isKindOf: Class) 239136 and: [self isKindOf: aClass]) 239137 ifTrue: 239138 [^ true]]]. 239139 ^ false 239140 239141 239142" 239143{3. true. 'olive'} do: 239144 [:token | 239145 {{#Number. #Boolean}. {Number. Boolean }. {'Number'. 'Boolean'}} do: 239146 [:list | 239147 Transcript cr; show: token asString, ' list element provided as a ', list first class name, ' - ', (token inheritsFromAnyIn: list) asString]] 239148"! ! 239149 239150!Object methodsFor: 'class membership'! 239151isKindOf: aClass 239152 "Answer whether the class, aClass, is a superclass or class of the receiver." 239153 239154 self class == aClass 239155 ifTrue: [^true] 239156 ifFalse: [^self class inheritsFrom: aClass]! ! 239157 239158!Object methodsFor: 'class membership'! 239159isMemberOf: aClass 239160 "Answer whether the receiver is an instance of the class, aClass." 239161 239162 ^self class == aClass! ! 239163 239164!Object methodsFor: 'class membership'! 239165respondsTo: aSymbol 239166 "Answer whether the method dictionary of the receiver's class contains 239167 aSymbol as a message selector." 239168 239169 ^self class canUnderstand: aSymbol! ! 239170 239171!Object methodsFor: 'class membership' stamp: 'tk 10/21/1998 12:38'! 239172xxxClass 239173 "For subclasses of nil, such as ObjectOut" 239174 ^ self class! ! 239175 239176 239177!Object methodsFor: 'comparing' stamp: 'eem 6/11/2008 17:52'! 239178closeTo: anObject 239179 "Answer whether the receiver and the argument represent the same 239180 object. If = is redefined in any subclass, consider also redefining the 239181 message hash." 239182 239183 ^[self = anObject] ifError: [:aString :aReceiver | ^ false]! ! 239184 239185!Object methodsFor: 'comparing'! 239186hash 239187 "Answer a SmallInteger whose value is related to the receiver's identity. 239188 May be overridden, and should be overridden in any classes that define = " 239189 239190 ^ self identityHash! ! 239191 239192!Object methodsFor: 'comparing' stamp: 'sw 8/20/1998 12:34'! 239193identityHashPrintString 239194 "'fred' identityHashPrintString" 239195 239196 ^ '(', self identityHash printString, ')'! ! 239197 239198!Object methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:02'! 239199literalEqual: other 239200 239201 ^ self class == other class and: [self = other]! ! 239202 239203!Object methodsFor: 'comparing'! 239204= anObject 239205 "Answer whether the receiver and the argument represent the same 239206 object. If = is redefined in any subclass, consider also redefining the 239207 message hash." 239208 239209 ^self == anObject! ! 239210 239211!Object methodsFor: 'comparing'! 239212~= anObject 239213 "Answer whether the receiver and the argument do not represent the 239214 same object." 239215 239216 ^self = anObject == false! ! 239217 239218 239219!Object methodsFor: 'converting' stamp: 'nice 3/28/2006 23:29'! 239220adaptToFloat: rcvr andCompare: selector 239221 "If I am involved in comparison with a Float. 239222 Default behaviour is to process comparison as any other selectors." 239223 ^ self adaptToFloat: rcvr andSend: selector! ! 239224 239225!Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:15'! 239226adaptToFloat: rcvr andSend: selector 239227 "If no method has been provided for adapting an object to a Float, 239228 then it may be adequate to simply adapt it to a number." 239229 ^ self adaptToNumber: rcvr andSend: selector! ! 239230 239231!Object methodsFor: 'converting' stamp: 'nice 3/28/2006 23:29'! 239232adaptToFraction: rcvr andCompare: selector 239233 "If I am involved in comparison with a Fraction. 239234 Default behaviour is to process comparison as any other selectors." 239235 ^ self adaptToFraction: rcvr andSend: selector! ! 239236 239237!Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:14'! 239238adaptToFraction: rcvr andSend: selector 239239 "If no method has been provided for adapting an object to a Fraction, 239240 then it may be adequate to simply adapt it to a number." 239241 ^ self adaptToNumber: rcvr andSend: selector! ! 239242 239243!Object methodsFor: 'converting' stamp: 'nice 3/28/2006 23:29'! 239244adaptToInteger: rcvr andCompare: selector 239245 "If I am involved in comparison with an Integer. 239246 Default behaviour is to process comparison as any other selectors." 239247 ^ self adaptToInteger: rcvr andSend: selector! ! 239248 239249!Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:15'! 239250adaptToInteger: rcvr andSend: selector 239251 "If no method has been provided for adapting an object to a Integer, 239252 then it may be adequate to simply adapt it to a number." 239253 ^ self adaptToNumber: rcvr andSend: selector! ! 239254 239255!Object methodsFor: 'converting' stamp: 'rw 4/27/2002 07:48'! 239256asActionSequence 239257 239258 ^WeakActionSequence with: self! ! 239259 239260!Object methodsFor: 'converting' stamp: 'rw 7/20/2003 16:03'! 239261asActionSequenceTrappingErrors 239262 239263 ^WeakActionSequenceTrappingErrors with: self! ! 239264 239265!Object methodsFor: 'converting' stamp: 'svp 5/16/2000 18:14'! 239266asDraggableMorph 239267 ^(StringMorph contents: self printString) 239268 color: Color white; 239269 yourself! ! 239270 239271!Object methodsFor: 'converting' stamp: 'sma 5/12/2000 17:39'! 239272asOrderedCollection 239273 "Answer an OrderedCollection with the receiver as its only element." 239274 239275 ^ OrderedCollection with: self! ! 239276 239277!Object methodsFor: 'converting'! 239278asString 239279 "Answer a string that represents the receiver." 239280 239281 ^ self printString ! ! 239282 239283!Object methodsFor: 'converting' stamp: 'ajh 3/11/2003 10:27'! 239284asStringOrText 239285 "Answer a string that represents the receiver." 239286 239287 ^ self printString ! ! 239288 239289!Object methodsFor: 'converting'! 239290as: aSimilarClass 239291 "Create an object of class aSimilarClass that has similar contents to the receiver." 239292 239293 ^ aSimilarClass newFrom: self! ! 239294 239295!Object methodsFor: 'converting' stamp: 'RAA 8/2/1999 12:41'! 239296complexContents 239297 239298 ^self! ! 239299 239300!Object methodsFor: 'converting' stamp: 'ajh 7/6/2003 20:37'! 239301mustBeBoolean 239302 "Catches attempts to test truth of non-Booleans. This message is sent from the VM. The sending context is rewound to just before the jump causing this exception." 239303 239304 ^ self mustBeBooleanIn: thisContext sender! ! 239305 239306!Object methodsFor: 'converting' stamp: 'ajh 7/6/2003 20:40'! 239307mustBeBooleanIn: context 239308 "context is the where the non-boolean error occurred. Rewind context to before jump then raise error." 239309 239310 | proceedValue | 239311 context skipBackBeforeJump. 239312 proceedValue := NonBooleanReceiver new 239313 object: self; 239314 signal: 'proceed for truth.'. 239315 ^ proceedValue ~~ false! ! 239316 239317!Object methodsFor: 'converting' stamp: 'sw 3/26/2001 12:12'! 239318printDirectlyToDisplay 239319 "For debugging: write the receiver's printString directly to the display at (0, 100); senders of this are detected by the check-for-slips mechanism." 239320 239321 self asString displayAt: 0@100 239322 239323"StringMorph someInstance printDirectlyToDisplay"! ! 239324 239325!Object methodsFor: 'converting' stamp: 'RAA 3/31/1999 12:13'! 239326withoutListWrapper 239327 239328 ^self! ! 239329 239330 239331!Object methodsFor: 'copying' stamp: 'jm 11/14/97 11:08'! 239332basicShallowCopy 239333 "Answer a copy of the receiver which shares the receiver's instance variables." 239334 | class newObject index | 239335 <primitive: 148> 239336 class := self class. 239337 class isVariable 239338 ifTrue: 239339 [index := self basicSize. 239340 newObject := class basicNew: index. 239341 [index > 0] 239342 whileTrue: 239343 [newObject basicAt: index put: (self basicAt: index). 239344 index := index - 1]] 239345 ifFalse: [newObject := class basicNew]. 239346 index := class instSize. 239347 [index > 0] 239348 whileTrue: 239349 [newObject instVarAt: index put: (self instVarAt: index). 239350 index := index - 1]. 239351 ^ newObject! ! 239352 239353!Object methodsFor: 'copying'! 239354clone 239355 239356 <primitive: 148> 239357 self primitiveFailed! ! 239358 239359!Object methodsFor: 'copying' stamp: 'ajh 8/18/2001 21:25'! 239360copy 239361 "Answer another instance just like the receiver. Subclasses typically override postCopy; they typically do not override shallowCopy." 239362 239363 ^self shallowCopy postCopy! ! 239364 239365!Object methodsFor: 'copying' stamp: 'tk 8/20/1998 16:01'! 239366copyAddedStateFrom: anotherObject 239367 "Copy over the values of instance variables added by the receiver's class from anotherObject to the receiver. These will be remapped in mapUniClasses, if needed." 239368 239369 self class superclass instSize + 1 to: self class instSize do: 239370 [:index | self instVarAt: index put: (anotherObject instVarAt: index)]! ! 239371 239372!Object methodsFor: 'copying' stamp: 'tpr 2/14/2004 21:53'! 239373copyFrom: anotherObject 239374 "Copy to myself all instance variables I have in common with anotherObject. This is dangerous because it ignores an object's control over its own inst vars. " 239375 239376 | mine his | 239377 <primitive: 168> 239378 mine := self class allInstVarNames. 239379 his := anotherObject class allInstVarNames. 239380 1 to: (mine size min: his size) do: [:ind | 239381 (mine at: ind) = (his at: ind) ifTrue: [ 239382 self instVarAt: ind put: (anotherObject instVarAt: ind)]]. 239383 self class isVariable & anotherObject class isVariable ifTrue: [ 239384 1 to: (self basicSize min: anotherObject basicSize) do: [:ind | 239385 self basicAt: ind put: (anotherObject basicAt: ind)]].! ! 239386 239387!Object methodsFor: 'copying' stamp: 'eem 6/11/2008 17:52'! 239388copySameFrom: otherObject 239389 "Copy to myself all instance variables named the same in otherObject. 239390 This ignores otherObject's control over its own inst vars." 239391 239392 | myInstVars otherInstVars | 239393 myInstVars := self class allInstVarNames. 239394 otherInstVars := otherObject class allInstVarNames. 239395 myInstVars doWithIndex: [:each :index | | match | 239396 (match := otherInstVars indexOf: each) > 0 ifTrue: 239397 [self instVarAt: index put: (otherObject instVarAt: match)]]. 239398 1 to: (self basicSize min: otherObject basicSize) do: [:i | 239399 self basicAt: i put: (otherObject basicAt: i)]. 239400! ! 239401 239402!Object methodsFor: 'copying' stamp: 'tk 4/20/1999 14:44'! 239403copyTwoLevel 239404 "one more level than a shallowCopy" 239405 239406 | newObject class index | 239407 class := self class. 239408 newObject := self clone. 239409 newObject == self ifTrue: [^ self]. 239410 class isVariable 239411 ifTrue: 239412 [index := self basicSize. 239413 [index > 0] 239414 whileTrue: 239415 [newObject basicAt: index put: (self basicAt: index) shallowCopy. 239416 index := index - 1]]. 239417 index := class instSize. 239418 [index > 0] 239419 whileTrue: 239420 [newObject instVarAt: index put: (self instVarAt: index) shallowCopy. 239421 index := index - 1]. 239422 ^newObject! ! 239423 239424!Object methodsFor: 'copying'! 239425deepCopy 239426 "Answer a copy of the receiver with its own copy of each instance 239427 variable." 239428 239429 | newObject class index | 239430 class := self class. 239431 (class == Object) ifTrue: [^self]. 239432 class isVariable 239433 ifTrue: 239434 [index := self basicSize. 239435 newObject := class basicNew: index. 239436 [index > 0] 239437 whileTrue: 239438 [newObject basicAt: index put: (self basicAt: index) deepCopy. 239439 index := index - 1]] 239440 ifFalse: [newObject := class basicNew]. 239441 index := class instSize. 239442 [index > 0] 239443 whileTrue: 239444 [newObject instVarAt: index put: (self instVarAt: index) deepCopy. 239445 index := index - 1]. 239446 ^newObject! ! 239447 239448!Object methodsFor: 'copying' stamp: 'ajh 1/27/2003 18:45'! 239449postCopy 239450 "self is a shallow copy, subclasses should copy fields as necessary to complete the full copy" 239451 239452 ^ self! ! 239453 239454!Object methodsFor: 'copying' stamp: 'nice 5/22/2008 10:40'! 239455shallowCopy 239456 "Answer a copy of the receiver which shares the receiver's instance variables." 239457 239458 ^self basicShallowCopy! ! 239459 239460!Object methodsFor: 'copying' stamp: 'stephane.ducasse 6/1/2009 13:49'! 239461veryDeepCopy 239462 "Do a complete tree copy using a dictionary. An object in the tree twice is only copied once. All references to the object in the copy of the tree will point to the new copy." 239463 239464 | copier new | 239465 copier := DeepCopier new initialize: 4096 "self initialDeepCopierSize". 239466 new := self veryDeepCopyWith: copier. 239467 copier references associationsDo: [:assoc | 239468 assoc value veryDeepFixupWith: copier]. 239469 copier fixDependents. 239470 ^ new! ! 239471 239472!Object methodsFor: 'copying' stamp: 'stephane.ducasse 6/1/2009 13:49'! 239473veryDeepCopySibling 239474 "Do a complete tree copy using a dictionary. Substitute a clone of oldPlayer for the root. Normally, a Player or non systemDefined object would have a new class. We do not want one this time. An object in the tree twice, is only copied once. All references to the object in the copy of the tree will point to the new copy." 239475 239476 | copier new | 239477 copier := DeepCopier new initialize: 4096 "self initialDeepCopierSize". 239478 new := self veryDeepCopyWith: copier. 239479 copier references associationsDo: [:assoc | 239480 assoc value veryDeepFixupWith: copier]. 239481 copier fixDependents. 239482 ^ new! ! 239483 239484!Object methodsFor: 'copying' stamp: 'stephane.ducasse 9/25/2008 17:44'! 239485veryDeepCopyUsing: copier 239486 "Do a complete tree copy using a dictionary. An object in the tree twice is only copied once. All references to the object in the copy of the tree will point to the new copy. 239487 Same as veryDeepCopy except copier (with dictionary) is supplied. 239488 ** do not delete this method, even if it has no callers **" 239489 239490 | new refs newDep newModel | 239491 new := self veryDeepCopyWith: copier. 239492 copier references associationsDo: [:assoc | 239493 assoc value veryDeepFixupWith: copier]. 239494 "Fix dependents" 239495 refs := copier references. 239496 DependentsFields associationsDo: [:pair | 239497 pair value do: [:dep | 239498 (newDep := refs at: dep ifAbsent: [nil]) ifNotNil: [ 239499 newModel := refs at: pair key ifAbsent: [pair key]. 239500 newModel addDependent: newDep]]]. 239501 ^ new! ! 239502 239503!Object methodsFor: 'copying' stamp: 'stephane.ducasse 9/25/2008 17:50'! 239504veryDeepCopyWith: deepCopier 239505 "Copy me and the entire tree of objects I point to. An object in the tree twice is copied once, and both references point to him. deepCopier holds a dictionary of objects we have seen. Some classes refuse to be copied. Some classes are picky about which fields get deep copied." 239506 | class index sub subAss new sup has mine | 239507 deepCopier references at: self ifPresent: [:newer | ^ newer]. "already did him" 239508 class := self class. 239509 class isMeta ifTrue: [^ self]. "a class" 239510 new := self clone. 239511 deepCopier references at: self put: new. "remember" 239512 (class isVariable and: [class isPointers]) ifTrue: 239513 [index := self basicSize. 239514 [index > 0] whileTrue: 239515 [sub := self basicAt: index. 239516 (subAss := deepCopier references associationAt: sub ifAbsent: [nil]) 239517 ifNil: [new basicAt: index put: (sub veryDeepCopyWith: deepCopier)] 239518 ifNotNil: [new basicAt: index put: subAss value]. 239519 index := index - 1]]. 239520 "Ask each superclass if it wants to share (weak copy) any inst vars" 239521 new veryDeepInner: deepCopier. "does super a lot" 239522 239523 "other superclasses want all inst vars deep copied" 239524 sup := class. index := class instSize. 239525 [has := sup compiledMethodAt: #veryDeepInner: ifAbsent: [nil]. 239526 has := has ifNil: [class isSystemDefined not "is a uniClass"] ifNotNil: [true]. 239527 mine := sup instVarNames. 239528 has ifTrue: [index := index - mine size] "skip inst vars" 239529 ifFalse: [1 to: mine size do: [:xx | 239530 sub := self instVarAt: index. 239531 (subAss := deepCopier references associationAt: sub ifAbsent: [nil]) 239532 "use association, not value, so nil is an exceptional value" 239533 ifNil: [new instVarAt: index put: 239534 (sub veryDeepCopyWith: deepCopier)] 239535 ifNotNil: [new instVarAt: index put: subAss value]. 239536 index := index - 1]]. 239537 (sup := sup superclass) == nil] whileFalse. 239538 new rehash. "force Sets and Dictionaries to rehash" 239539 ^ new 239540! ! 239541 239542!Object methodsFor: 'copying' stamp: 'tk 1/6/1999 17:39'! 239543veryDeepFixupWith: deepCopier 239544 "I have no fields and no superclass. Catch the super call." 239545! ! 239546 239547!Object methodsFor: 'copying' stamp: 'tk 9/4/2001 10:30'! 239548veryDeepInner: deepCopier 239549 "No special treatment for inst vars of my superclasses. Override when some need to be weakly copied. Object>>veryDeepCopyWith: will veryDeepCopy any inst var whose class does not actually define veryDeepInner:" 239550! ! 239551 239552 239553!Object methodsFor: 'creation' stamp: 'nk 2/26/2004 13:33'! 239554asMorph 239555 "Open a morph, as best one can, on the receiver" 239556 239557 ^ self asStringMorph 239558 239559 " 239560234 asMorph 239561(ScriptingSystem formAtKey: #TinyMenu) asMorph 239562'fred' asMorph 239563" 239564 239565! ! 239566 239567!Object methodsFor: 'creation' stamp: 'nk 2/26/2004 13:35'! 239568asStringMorph 239569 "Open a StringMorph, as best one can, on the receiver" 239570 239571 ^ self asStringOrText asStringMorph 239572! ! 239573 239574!Object methodsFor: 'creation' stamp: 'nk 2/26/2004 13:35'! 239575asTextMorph 239576 "Open a TextMorph, as best one can, on the receiver" 239577 239578 ^ TextMorph new contentsAsIs: self asStringOrText 239579! ! 239580 239581!Object methodsFor: 'creation' stamp: 'sw 1/29/2002 21:45'! 239582openAsMorph 239583 "Open a morph, as best one can, on the receiver" 239584 239585 ^ self asMorph openInHand 239586 239587" 239588234 openAsMorph 239589(ScriptingSystem formAtKey: #TinyMenu) openAsMorph 239590'fred' openAsMorph 239591"! ! 239592 239593 239594!Object methodsFor: 'debugging' stamp: 'md 11/24/2004 11:45'! 239595haltIf: condition 239596 "This is the typical message to use for inserting breakpoints during 239597 debugging. Param can be a block or expression, halt if true. 239598 If the Block has one arg, the receiver is bound to that. 239599 If the condition is a selector, we look up in the callchain. Halt if 239600 any method's selector equals selector." 239601 | cntxt | 239602 239603 condition isSymbol ifTrue:[ 239604 "only halt if a method with selector symbol is in callchain" 239605 cntxt := thisContext. 239606 [cntxt sender isNil] whileFalse: [ 239607 cntxt := cntxt sender. 239608 (cntxt selector = condition) ifTrue: [Halt signal]. 239609 ]. 239610 ^self. 239611 ]. 239612 (condition isBlock 239613 ifTrue: [condition valueWithPossibleArgument: self] 239614 ifFalse: [condition] 239615 ) ifTrue: [ 239616 Halt signal 239617 ].! ! 239618 239619!Object methodsFor: 'debugging'! 239620needsWork! ! 239621 239622 239623!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:26'! 239624checkHaltCountExpired 239625 | counter | 239626 counter := Smalltalk at: #HaltCount ifAbsent: [0]. 239627 ^counter = 0! ! 239628 239629!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:04'! 239630clearHaltOnce 239631 "Turn on the halt once flag." 239632 Smalltalk at: #HaltOnce put: false! ! 239633 239634!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:30'! 239635decrementAndCheckHaltCount 239636 self decrementHaltCount. 239637 ^self checkHaltCountExpired! ! 239638 239639!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:28'! 239640decrementHaltCount 239641 | counter | 239642 counter := Smalltalk 239643 at: #HaltCount 239644 ifAbsent: [0]. 239645 counter > 0 ifTrue: [ 239646 counter := counter - 1. 239647 self setHaltCountTo: counter]! ! 239648 239649!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:42'! 239650doExpiredHaltCount 239651 self clearHaltOnce. 239652 self removeHaltCount. 239653 self halt! ! 239654 239655!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:44'! 239656doExpiredHaltCount: aString 239657 self clearHaltOnce. 239658 self removeHaltCount. 239659 self halt: aString! ! 239660 239661!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:45'! 239662doExpiredInspectCount 239663 self clearHaltOnce. 239664 self removeHaltCount. 239665 self inspect! ! 239666 239667!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:45'! 239668halt: aString onCount: int 239669 self haltOnceEnabled 239670 ifTrue: [self hasHaltCount 239671 ifTrue: [self decrementAndCheckHaltCount 239672 ifTrue: [self doExpiredHaltCount: aString]] 239673 ifFalse: [int = 1 239674 ifTrue: [self doExpiredHaltCount: aString] 239675 ifFalse: [self setHaltCountTo: int - 1]]]! ! 239676 239677!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:43'! 239678haltOnCount: int 239679 self haltOnceEnabled 239680 ifTrue: [self hasHaltCount 239681 ifTrue: [self decrementAndCheckHaltCount 239682 ifTrue: [self doExpiredHaltCount]] 239683 ifFalse: [int = 1 239684 ifTrue: [self doExpiredHaltCount] 239685 ifFalse: [self setHaltCountTo: int - 1]]]! ! 239686 239687!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:05'! 239688haltOnce 239689 "Halt unless we have already done it once." 239690 self haltOnceEnabled 239691 ifTrue: [self clearHaltOnce. 239692 ^ self halt]! ! 239693 239694!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:05'! 239695haltOnce: aString 239696 "Halt unless we have already done it once." 239697 self haltOnceEnabled 239698 ifTrue: [self clearHaltOnce. 239699 ^ self halt: aString]! ! 239700 239701!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:04'! 239702haltOnceEnabled 239703 ^ Smalltalk 239704 at: #HaltOnce 239705 ifAbsent: [false]! ! 239706 239707!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:36'! 239708hasHaltCount 239709 ^Smalltalk 239710 includesKey: #HaltCount! ! 239711 239712!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:46'! 239713inspectOnCount: int 239714 self haltOnceEnabled 239715 ifTrue: [self hasHaltCount 239716 ifTrue: [self decrementAndCheckHaltCount 239717 ifTrue: [self doExpiredInspectCount]] 239718 ifFalse: [int = 1 239719 ifTrue: [self doExpiredInspectCount] 239720 ifFalse: [self setHaltCountTo: int - 1]]]! ! 239721 239722!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:05'! 239723inspectOnce 239724 "Inspect unless we have already done it once." 239725 self haltOnceEnabled 239726 ifTrue: [self clearHaltOnce. 239727 ^ self inspect]! ! 239728 239729!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 13:20'! 239730inspectUntilCount: int 239731 self haltOnceEnabled 239732 ifTrue: [self hasHaltCount 239733 ifTrue: [self decrementAndCheckHaltCount 239734 ifTrue: [self doExpiredInspectCount] 239735 ifFalse: [self inspect]] 239736 ifFalse: [int = 1 239737 ifTrue: [self doExpiredInspectCount] 239738 ifFalse: [self setHaltCountTo: int - 1]]]! ! 239739 239740!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:49'! 239741removeHaltCount 239742 (Smalltalk includesKey: #HaltCount) ifTrue: [ 239743 Smalltalk removeKey: #HaltCount]! ! 239744 239745!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 6/2/2004 08:25'! 239746setHaltCountTo: int 239747 Smalltalk at: #HaltCount put: int! ! 239748 239749!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:04'! 239750setHaltOnce 239751 "Turn on the halt once flag." 239752 Smalltalk at: #HaltOnce put: true! ! 239753 239754!Object methodsFor: 'debugging-haltOnce' stamp: 'sbw 5/19/2004 19:04'! 239755toggleHaltOnce 239756 self haltOnceEnabled 239757 ifTrue: [self clearHaltOnce] 239758 ifFalse: [self setHaltOnce]! ! 239759 239760 239761!Object methodsFor: 'dependents access' stamp: 'ar 2/11/2001 01:55'! 239762addDependent: anObject 239763 "Make the given object one of the receiver's dependents." 239764 239765 | dependents | 239766 dependents := self dependents. 239767 (dependents includes: anObject) ifFalse: 239768 [self myDependents: (dependents copyWithDependent: anObject)]. 239769 ^ anObject! ! 239770 239771!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:53'! 239772breakDependents 239773 "Remove all of the receiver's dependents." 239774 239775 self myDependents: nil! ! 239776 239777!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:26'! 239778canDiscardEdits 239779 "Answer true if none of the views on this model has unaccepted edits that matter." 239780 239781 self dependents 239782 do: [:each | each canDiscardEdits ifFalse: [^ false]] 239783 without: self. 239784 ^ true! ! 239785 239786!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:58'! 239787dependents 239788 "Answer a collection of objects that are 'dependent' on the receiver; 239789 that is, all objects that should be notified if the receiver changes." 239790 239791 ^ self myDependents ifNil: [#()]! ! 239792 239793!Object methodsFor: 'dependents access'! 239794evaluate: actionBlock wheneverChangeIn: aspectBlock 239795 | viewerThenObject objectThenViewer | 239796 objectThenViewer := self. 239797 viewerThenObject := ObjectViewer on: objectThenViewer. 239798 objectThenViewer become: viewerThenObject. 239799 "--- Then ---" 239800 objectThenViewer xxxViewedObject: viewerThenObject 239801 evaluate: actionBlock 239802 wheneverChangeIn: aspectBlock! ! 239803 239804!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:59'! 239805hasUnacceptedEdits 239806 "Answer true if any of the views on this object has unaccepted edits." 239807 239808 self dependents 239809 do: [:each | each hasUnacceptedEdits ifTrue: [^ true]] 239810 without: self. 239811 ^ false! ! 239812 239813!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:55'! 239814myDependents 239815 "Private. Answer a list of all the receiver's dependents." 239816 239817 ^ DependentsFields at: self ifAbsent: []! ! 239818 239819!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:52'! 239820myDependents: aCollectionOrNil 239821 "Private. Set (or remove) the receiver's dependents list." 239822 239823 aCollectionOrNil 239824 ifNil: [DependentsFields removeKey: self ifAbsent: []] 239825 ifNotNil: [DependentsFields at: self put: aCollectionOrNil]! ! 239826 239827!Object methodsFor: 'dependents access' stamp: 'reThink 2/18/2001 17:06'! 239828release 239829 "Remove references to objects that may refer to the receiver. This message 239830 should be overridden by subclasses with any cycles, in which case the 239831 subclass should also include the expression super release." 239832 239833 self releaseActionMap! ! 239834 239835!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 20:23'! 239836removeDependent: anObject 239837 "Remove the given object as one of the receiver's dependents." 239838 239839 | dependents | 239840 dependents := self dependents reject: [:each | each == anObject]. 239841 self myDependents: (dependents isEmpty ifFalse: [dependents]). 239842 ^ anObject! ! 239843 239844 239845!Object methodsFor: 'drag and drop' stamp: 'bh 9/16/2001 18:10'! 239846acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph 239847 239848 ^false.! ! 239849 239850!Object methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:20'! 239851dragPassengerFor: item inMorph: dragSource 239852 ^item! ! 239853 239854!Object methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:11'! 239855dragTransferType 239856 ^nil! ! 239857 239858!Object methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:05'! 239859dragTransferTypeForMorph: dragSource 239860 ^nil! ! 239861 239862!Object methodsFor: 'drag and drop' stamp: 'mir 5/8/2000 17:19'! 239863wantsDroppedMorph: aMorph event: anEvent inMorph: destinationLM 239864 ^false! ! 239865 239866 239867!Object methodsFor: 'error handling' stamp: 'sma 5/6/2000 19:35'! 239868assert: aBlock 239869 "Throw an assertion error if aBlock does not evaluates to true." 239870 239871 aBlock value ifFalse: [AssertionFailure signal: 'Assertion failed']! ! 239872 239873!Object methodsFor: 'error handling' stamp: 'nk 1/15/2004 10:54'! 239874assert: aBlock descriptionBlock: descriptionBlock 239875 "Throw an assertion error if aBlock does not evaluate to true." 239876 239877 aBlock value ifFalse: [AssertionFailure signal: descriptionBlock value asString ]! ! 239878 239879!Object methodsFor: 'error handling' stamp: 'nk 10/25/2003 16:47'! 239880assert: aBlock description: aString 239881 "Throw an assertion error if aBlock does not evaluates to true." 239882 239883 aBlock value ifFalse: [AssertionFailure signal: aString ]! ! 239884 239885!Object methodsFor: 'error handling' stamp: 'md 10/13/2004 15:59'! 239886backwardCompatibilityOnly: anExplanationString 239887 "Warn that the sending method has been deprecated. Methods that are tagt with #backwardCompatibility: 239888 are kept for compatibility." 239889 239890 Preferences showDeprecationWarnings ifTrue: 239891 [Deprecation signal: thisContext sender printString, ' has been deprecated (but will be kept for compatibility). ', anExplanationString]! ! 239892 239893!Object methodsFor: 'error handling' stamp: 'jcg 8/10/2008 21:58'! 239894caseError 239895 "Report an error from an in-line or explicit case statement." 239896 239897 self error: 'Case not found (', self printString, '), and no otherwise clause'! ! 239898 239899!Object methodsFor: 'error handling' stamp: 'rbb 3/1/2005 09:26'! 239900confirm: queryString 239901 "Put up a yes/no menu with caption queryString. Answer true if the 239902 response is yes, false if no. This is a modal question--the user must 239903 respond yes or no." 239904 239905 "nil confirm: 'Are you hungry?'" 239906 239907 ^ UIManager default confirm: queryString! ! 239908 239909!Object methodsFor: 'error handling' stamp: 'rbb 3/1/2005 09:27'! 239910confirm: aString orCancel: cancelBlock 239911 "Put up a yes/no/cancel menu with caption aString. Answer true if 239912 the response is yes, false if no. If cancel is chosen, evaluate 239913 cancelBlock. This is a modal question--the user must respond yes or no." 239914 239915 ^ UIManager default confirm: aString orCancel: cancelBlock! ! 239916 239917!Object methodsFor: 'error handling' stamp: 'eem 7/3/2009 19:17'! 239918deprecated: anExplanationString 239919 "Warn that the sending method has been deprecated." 239920 239921 (Deprecation 239922 method: thisContext sender method 239923 explanation: anExplanationString 239924 on: nil 239925 in: nil) signal! ! 239926 239927!Object methodsFor: 'error handling' stamp: 'AndrewBlack 9/6/2009 08:58'! 239928deprecated: anExplanationString on: date in: version 239929 "Warn that the sending method has been deprecated" 239930 239931 (Deprecation 239932 method: thisContext sender method 239933 explanation: anExplanationString 239934 on: date 239935 in: version) signal! ! 239936 239937!Object methodsFor: 'error handling' stamp: 'stephane.ducasse 12/22/2008 13:53'! 239938doesNotUnderstand: aMessage 239939 "Handle the fact that there was an attempt to send the given message to the receiver but the receiver does not understand this message (typically sent from the machine when a message is sent to the receiver and no method is defined for that selector)." 239940 "Testing: (3 activeProcess)" 239941 "fixed suggested by Eliot miranda to make sure 239942 239943 [Object new blah + 1] 239944 on: MessageNotUnderstood 239945 do: [:e | e resume: 1] does not loop indefinitively" 239946 239947 | exception resumeValue | 239948 (exception := MessageNotUnderstood new) 239949 message: aMessage; 239950 receiver: self. 239951 resumeValue := exception signal. 239952 ^exception reachedDefaultHandler 239953 ifTrue: [aMessage sentTo: self] 239954 ifFalse: [resumeValue]! ! 239955 239956!Object methodsFor: 'error handling' stamp: 'TRee 11/4/2003 16:47'! 239957dpsTrace: reportObject 239958 Transcript myDependents isNil ifTrue: [^self]. 239959 self dpsTrace: reportObject levels: 1 withContext: thisContext 239960 239961" nil dpsTrace: 'sludder'. "! ! 239962 239963!Object methodsFor: 'error handling' stamp: 'TRee 11/4/2003 16:49'! 239964dpsTrace: reportObject levels: anInt 239965 self dpsTrace: reportObject levels: anInt withContext: thisContext 239966 239967"(1 to: 3) do: [:int | nil dpsTrace: int levels: 5.]"! ! 239968 239969!Object methodsFor: 'error handling' stamp: 'TRee 11/4/2003 17:02'! 239970dpsTrace: reportObject levels: anInt withContext: currentContext 239971 | reportString context displayCount | 239972 reportString := (reportObject respondsTo: #asString) 239973 ifTrue: [reportObject asString] ifFalse: [reportObject printString]. 239974 (Smalltalk at: #Decompiler ifAbsent: [nil]) 239975 ifNil: 239976 [Transcript cr; show: reportString] 239977 ifNotNil: 239978 [context := currentContext. 239979 displayCount := anInt > 1. 239980 1 to: anInt do: 239981 [:count | 239982 Transcript cr. 239983 displayCount 239984 ifTrue: [Transcript show: count printString, ': ']. 239985 239986 reportString notNil 239987 ifTrue: 239988 [Transcript show: context home class name 239989 , '/' , context sender selector, ' (' , reportString , ')'. 239990 context := context sender. 239991 reportString := nil] 239992 ifFalse: 239993 [(context notNil and: [(context := context sender) notNil]) 239994 ifTrue: [Transcript show: context receiver class name , '/' , context selector]]]. 239995 "Transcript cr"].! ! 239996 239997!Object methodsFor: 'error handling' stamp: 'md 8/2/2005 22:17'! 239998error 239999 "Throw a generic Error exception." 240000 240001 ^self error: 'Error!!'.! ! 240002 240003!Object methodsFor: 'error handling' stamp: 'tfei 4/12/1999 12:55'! 240004error: aString 240005 "Throw a generic Error exception." 240006 240007 ^Error new signal: aString! ! 240008 240009!Object methodsFor: 'error handling' stamp: 'al 9/16/2005 14:12'! 240010explicitRequirement 240011 self error: 'Explicitly required method'! ! 240012 240013!Object methodsFor: 'error handling' stamp: 'al 2/13/2006 22:20'! 240014halt 240015 "This is the typical message to use for inserting breakpoints during 240016 debugging. It behaves like halt:, but does not call on halt: in order to 240017 avoid putting this message on the stack. Halt is especially useful when 240018 the breakpoint message is an arbitrary one." 240019 240020 Halt signal! ! 240021 240022!Object methodsFor: 'error handling' stamp: 'tfei 4/12/1999 12:59'! 240023halt: aString 240024 "This is the typical message to use for inserting breakpoints during 240025 debugging. It creates and schedules a Notifier with the argument, 240026 aString, as the label." 240027 240028 Halt new signal: aString! ! 240029 240030!Object methodsFor: 'error handling' stamp: 'md 1/20/2006 16:24'! 240031handles: exception 240032 "This method exists in case a non exception class is the first arg in an on:do: (for instance using a exception class that is not loaded). We prefer this to raising an error during error handling itself. Also, semantically it makes sense that the exception handler is not active if its exception class is not loaded" 240033 240034 ^ false! ! 240035 240036!Object methodsFor: 'error handling' stamp: 'ar 9/27/2005 20:24'! 240037notifyWithLabel: aString 240038 "Create and schedule a Notifier with aString as the window label as well as the contents of the window, in order to request confirmation before a process can proceed." 240039 240040 ToolSet 240041 debugContext: thisContext 240042 label: aString 240043 contents: aString 240044 240045 "nil notifyWithLabel: 'let us see if this works'"! ! 240046 240047!Object methodsFor: 'error handling' stamp: 'stephane.ducasse 6/1/2009 13:51'! 240048notify: aString 240049 "Create and schedule a Notifier with the argument as the message in 240050 order to request confirmation before a process can proceed." 240051 240052 Warning signal: aString! ! 240053 240054!Object methodsFor: 'error handling'! 240055notify: aString at: location 240056 "Create and schedule a Notifier with the argument as the message in 240057 order to request confirmation before a process can proceed. Subclasses can 240058 override this and insert an error message at location within aString." 240059 240060 self notify: aString 240061 240062 "nil notify: 'confirmation message' at: 12"! ! 240063 240064!Object methodsFor: 'error handling'! 240065primitiveFailed 240066 "Announce that a primitive has failed and there is no appropriate 240067 Smalltalk code to run." 240068 240069 self error: 'a primitive has failed'! ! 240070 240071!Object methodsFor: 'error handling' stamp: 'al 9/16/2005 14:12'! 240072requirement 240073 self error: 'Implicitly required method'! ! 240074 240075!Object methodsFor: 'error handling' stamp: 'AFi 2/8/2003 22:52'! 240076shouldBeImplemented 240077 "Announce that this message should be implemented" 240078 240079 self error: 'This message should be implemented'! ! 240080 240081!Object methodsFor: 'error handling'! 240082shouldNotImplement 240083 "Announce that, although the receiver inherits this message, it should 240084 not implement it." 240085 240086 self error: 'This message is not appropriate for this object'! ! 240087 240088!Object methodsFor: 'error handling' stamp: 'md 2/17/2006 12:02'! 240089subclassResponsibility 240090 "This message sets up a framework for the behavior of the class' subclasses. 240091 Announce that the subclass should have implemented this message." 240092 240093 self error: 'My subclass should have overridden ', thisContext sender selector printString! ! 240094 240095!Object methodsFor: 'error handling' stamp: 'al 12/16/2003 16:16'! 240096traitConflict 240097 self error: 'A class or trait does not properly resolve a conflict between multiple traits it uses.'! ! 240098 240099 240100!Object methodsFor: 'evaluating' stamp: 'reThink 3/12/2001 18:14'! 240101value 240102 240103 ^self! ! 240104 240105!Object methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 15:23'! 240106valueWithArguments: aSequenceOfArguments 240107 240108 ^self! ! 240109 240110 240111!Object methodsFor: 'events-accessing' stamp: 'nk 12/20/2002 17:48'! 240112actionForEvent: anEventSelector 240113 "Answer the action to be evaluated when <anEventSelector> has been triggered." 240114 240115 | actions | 240116 actions := self actionMap 240117 at: anEventSelector asSymbol 240118 ifAbsent: [nil]. 240119 actions ifNil: [^nil]. 240120 ^ actions asMinimalRepresentation! ! 240121 240122!Object methodsFor: 'events-accessing' stamp: 'nk 12/20/2002 17:48'! 240123actionForEvent: anEventSelector 240124ifAbsent: anExceptionBlock 240125 "Answer the action to be evaluated when <anEventSelector> has been triggered." 240126 240127 | actions | 240128 actions := self actionMap 240129 at: anEventSelector asSymbol 240130 ifAbsent: [nil]. 240131 actions ifNil: [^anExceptionBlock value]. 240132 ^ actions asMinimalRepresentation! ! 240133 240134!Object methodsFor: 'events-accessing' stamp: 'reThink 2/18/2001 14:43'! 240135actionMap 240136 240137 ^EventManager actionMapFor: self! ! 240138 240139!Object methodsFor: 'events-accessing' stamp: 'rw 4/27/2002 08:35'! 240140actionSequenceForEvent: anEventSelector 240141 240142 ^(self actionMap 240143 at: anEventSelector asSymbol 240144 ifAbsent: [^WeakActionSequence new]) 240145 asActionSequence! ! 240146 240147!Object methodsFor: 'events-accessing' stamp: 'SqR 6/28/2001 13:19'! 240148actionsDo: aBlock 240149 240150 self actionMap do: aBlock! ! 240151 240152!Object methodsFor: 'events-accessing' stamp: 'rw 2/10/2002 13:05'! 240153createActionMap 240154 240155 ^IdentityDictionary new! ! 240156 240157!Object methodsFor: 'events-accessing' stamp: 'SqR 2/19/2001 14:04'! 240158hasActionForEvent: anEventSelector 240159 "Answer true if there is an action associated with anEventSelector" 240160 240161 ^(self actionForEvent: anEventSelector) notNil! ! 240162 240163!Object methodsFor: 'events-accessing' stamp: 'gk 8/14/2007 23:53'! 240164hasActionsWithReceiver: anObject 240165 240166 ^self actionMap keys anySatisfy: 240167 [:eachEventSelector | 240168 (self actionSequenceForEvent: eachEventSelector) 240169 anySatisfy: [:anAction | anAction receiver == anObject]]! ! 240170 240171!Object methodsFor: 'events-accessing' stamp: 'reThink 2/18/2001 15:29'! 240172setActionSequence: actionSequence 240173forEvent: anEventSelector 240174 240175 | action | 240176 action := actionSequence asMinimalRepresentation. 240177 action == nil 240178 ifTrue: 240179 [self removeActionsForEvent: anEventSelector] 240180 ifFalse: 240181 [self updateableActionMap 240182 at: anEventSelector asSymbol 240183 put: action]! ! 240184 240185!Object methodsFor: 'events-accessing' stamp: 'reThink 2/25/2001 08:50'! 240186updateableActionMap 240187 240188 ^EventManager updateableActionMapFor: self! ! 240189 240190 240191!Object methodsFor: 'events-registering' stamp: 'reThink 2/18/2001 15:04'! 240192when: anEventSelector evaluate: anAction 240193 240194 | actions | 240195 actions := self actionSequenceForEvent: anEventSelector. 240196 (actions includes: anAction) 240197 ifTrue: [^ self]. 240198 self 240199 setActionSequence: (actions copyWith: anAction) 240200 forEvent: anEventSelector! ! 240201 240202!Object methodsFor: 'events-registering' stamp: 'rww 12/30/2002 10:37'! 240203when: anEventSelector 240204send: aMessageSelector 240205to: anObject 240206 240207 self 240208 when: anEventSelector 240209 evaluate: (WeakMessageSend 240210 receiver: anObject 240211 selector: aMessageSelector)! ! 240212 240213!Object methodsFor: 'events-registering' stamp: 'rww 12/30/2002 10:37'! 240214when: anEventSelector 240215send: aMessageSelector 240216to: anObject 240217withArguments: anArgArray 240218 240219 self 240220 when: anEventSelector 240221 evaluate: (WeakMessageSend 240222 receiver: anObject 240223 selector: aMessageSelector 240224 arguments: anArgArray)! ! 240225 240226!Object methodsFor: 'events-registering' stamp: 'rww 12/30/2002 10:37'! 240227when: anEventSelector 240228send: aMessageSelector 240229to: anObject 240230with: anArg 240231 240232 self 240233 when: anEventSelector 240234 evaluate: (WeakMessageSend 240235 receiver: anObject 240236 selector: aMessageSelector 240237 arguments: (Array with: anArg))! ! 240238 240239 240240!Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:33'! 240241releaseActionMap 240242 240243 EventManager releaseActionMapFor: self! ! 240244 240245!Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:33'! 240246removeActionsForEvent: anEventSelector 240247 240248 | map | 240249 map := self actionMap. 240250 map removeKey: anEventSelector asSymbol ifAbsent: []. 240251 map isEmpty 240252 ifTrue: [self releaseActionMap]! ! 240253 240254!Object methodsFor: 'events-removing' stamp: 'nk 8/25/2003 21:46'! 240255removeActionsSatisfying: aBlock 240256 240257 self actionMap keys do: 240258 [:eachEventSelector | 240259 self 240260 removeActionsSatisfying: aBlock 240261 forEvent: eachEventSelector 240262 ]! ! 240263 240264!Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:31'! 240265removeActionsSatisfying: aOneArgBlock 240266forEvent: anEventSelector 240267 240268 self 240269 setActionSequence: 240270 ((self actionSequenceForEvent: anEventSelector) 240271 reject: [:anAction | aOneArgBlock value: anAction]) 240272 forEvent: anEventSelector! ! 240273 240274!Object methodsFor: 'events-removing' stamp: 'rw 7/29/2003 17:18'! 240275removeActionsWithReceiver: anObject 240276 240277 self actionMap copy keysDo: 240278 [:eachEventSelector | 240279 self 240280 removeActionsSatisfying: [:anAction | anAction receiver == anObject] 240281 forEvent: eachEventSelector 240282 ]! ! 240283 240284!Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:36'! 240285removeActionsWithReceiver: anObject 240286forEvent: anEventSelector 240287 240288 self 240289 removeActionsSatisfying: 240290 [:anAction | 240291 anAction receiver == anObject] 240292 forEvent: anEventSelector! ! 240293 240294!Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:31'! 240295removeAction: anAction 240296forEvent: anEventSelector 240297 240298 self 240299 removeActionsSatisfying: [:action | action = anAction] 240300 forEvent: anEventSelector! ! 240301 240302 240303!Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 15:22'! 240304triggerEvent: anEventSelector 240305 "Evaluate all actions registered for <anEventSelector>. Return the value of the last registered action." 240306 240307 ^(self actionForEvent: anEventSelector) value! ! 240308 240309!Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 17:09'! 240310triggerEvent: anEventSelector 240311ifNotHandled: anExceptionBlock 240312 "Evaluate all actions registered for <anEventSelector>. Return the value of the last registered action." 240313 240314 ^(self 240315 actionForEvent: anEventSelector 240316 ifAbsent: [^anExceptionBlock value]) value 240317! ! 240318 240319!Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 15:21'! 240320triggerEvent: anEventSelector 240321withArguments: anArgumentList 240322 240323 ^(self actionForEvent: anEventSelector) 240324 valueWithArguments: anArgumentList! ! 240325 240326!Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 15:21'! 240327triggerEvent: anEventSelector 240328withArguments: anArgumentList 240329ifNotHandled: anExceptionBlock 240330 240331 ^(self 240332 actionForEvent: anEventSelector 240333 ifAbsent: [^anExceptionBlock value]) 240334 valueWithArguments: anArgumentList! ! 240335 240336!Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 14:59'! 240337triggerEvent: anEventSelector 240338with: anObject 240339 240340 ^self 240341 triggerEvent: anEventSelector 240342 withArguments: (Array with: anObject)! ! 240343 240344!Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 14:59'! 240345triggerEvent: anEventSelector 240346with: anObject 240347ifNotHandled: anExceptionBlock 240348 240349 ^self 240350 triggerEvent: anEventSelector 240351 withArguments: (Array with: anObject) 240352 ifNotHandled: anExceptionBlock! ! 240353 240354 240355!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:42'! 240356byteEncode:aStream 240357 self flattenOnStream:aStream. 240358! ! 240359 240360!Object methodsFor: 'filter streaming'! 240361drawOnCanvas:aStream 240362 self flattenOnStream:aStream. 240363! ! 240364 240365!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:31'! 240366elementSeparator 240367 ^nil.! ! 240368 240369!Object methodsFor: 'filter streaming'! 240370encodePostscriptOn:aStream 240371 self byteEncode:aStream. 240372! ! 240373 240374!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:07'! 240375flattenOnStream:aStream 240376 self writeOnFilterStream:aStream. 240377! ! 240378 240379!Object methodsFor: 'filter streaming' stamp: 'mpw 6/22/1930 22:56'! 240380fullDrawPostscriptOn:aStream 240381 ^aStream fullDraw:self. 240382! ! 240383 240384!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:51'! 240385printOnStream:aStream 240386 self byteEncode:aStream. 240387! ! 240388 240389!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:49'! 240390putOn:aStream 240391 ^aStream nextPut:self. 240392! ! 240393 240394!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:53'! 240395storeOnStream:aStream 240396 self printOnStream:aStream. 240397! ! 240398 240399!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:06'! 240400writeOnFilterStream:aStream 240401 aStream writeObject:self. 240402! ! 240403 240404 240405!Object methodsFor: 'finalization' stamp: 'ar 3/21/98 16:26'! 240406actAsExecutor 240407 "Prepare the receiver to act as executor for any resources associated with it" 240408 self breakDependents! ! 240409 240410!Object methodsFor: 'finalization' stamp: 'ar 3/20/98 22:19'! 240411executor 240412 "Return an object which can act as executor for finalization of the receiver" 240413 ^self shallowCopy actAsExecutor! ! 240414 240415!Object methodsFor: 'finalization' stamp: 'ar 5/19/2003 20:10'! 240416finalizationRegistry 240417 "Answer the finalization registry associated with the receiver." 240418 ^WeakRegistry default! ! 240419 240420!Object methodsFor: 'finalization' stamp: 'ar 3/21/98 16:27'! 240421finalize 240422 "Finalize the resource associated with the receiver. This message should only be sent during the finalization process. There is NO garantuee that the resource associated with the receiver hasn't been free'd before so take care that you don't run into trouble - this all may happen with interrupt priority."! ! 240423 240424!Object methodsFor: 'finalization' stamp: 'ar 3/21/98 18:38'! 240425retryWithGC: execBlock until: testBlock 240426 "Retry execBlock as long as testBlock returns false. Do an incremental GC after the first try, a full GC after the second try." 240427 | blockValue | 240428 blockValue := execBlock value. 240429 (testBlock value: blockValue) ifTrue:[^blockValue]. 240430 Smalltalk garbageCollectMost. 240431 blockValue := execBlock value. 240432 (testBlock value: blockValue) ifTrue:[^blockValue]. 240433 Smalltalk garbageCollect. 240434 ^execBlock value.! ! 240435 240436!Object methodsFor: 'finalization' stamp: 'ar 5/19/2003 20:14'! 240437toFinalizeSend: aSelector to: aFinalizer with: aResourceHandle 240438 "When I am finalized (e.g., garbage collected) close the associated resource handle by sending aSelector to the appropriate finalizer (the guy who knows how to get rid of the resource). 240439 WARNING: Neither the finalizer nor the resource handle are allowed to reference me. If they do, then I will NEVER be garbage collected. Since this cannot be validated here, it is up to the client to make sure this invariant is not broken." 240440 self == aFinalizer ifTrue:[self error: 'I cannot finalize myself']. 240441 self == aResourceHandle ifTrue:[self error: 'I cannot finalize myself']. 240442 ^self finalizationRegistry add: self executor: 240443 (ObjectFinalizer new 240444 receiver: aFinalizer 240445 selector: aSelector 240446 argument: aResourceHandle)! ! 240447 240448 240449!Object methodsFor: 'flagging' stamp: 'sw 8/4/97 16:49'! 240450isThisEverCalled 240451 ^ self isThisEverCalled: thisContext sender printString! ! 240452 240453!Object methodsFor: 'flagging'! 240454isThisEverCalled: msg 240455 "Send this message, with some useful printable argument, from methods or branches of methods which you believe are never reached. 2/5/96 sw" 240456 240457 self halt: 'This is indeed called: ', msg printString! ! 240458 240459!Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:23'! 240460logEntry 240461 240462 Transcript show: 'Entered ', thisContext sender printString; cr. 240463! ! 240464 240465!Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:23'! 240466logExecution 240467 240468 Transcript show: 'Executing ', thisContext sender printString; cr. 240469! ! 240470 240471!Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:22'! 240472logExit 240473 240474 Transcript show: 'Exited ', thisContext sender printString; cr. 240475! ! 240476 240477 240478!Object methodsFor: 'graph model' stamp: 'dgd 9/18/2004 15:07'! 240479addModelYellowButtonMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph 240480 "The receiver serves as the model for aMorph; a menu is being constructed for the morph, and here the receiver is able to add its own items" 240481 Preferences cmdGesturesEnabled ifTrue: [ "build mode" 240482 aCustomMenu add: 'inspect model' translated target: self action: #inspect. 240483 ]. 240484 240485 ^aCustomMenu 240486! ! 240487 240488!Object methodsFor: 'graph model' stamp: 'nk 1/23/2004 14:35'! 240489hasModelYellowButtonMenuItems 240490 ^Preferences cmdGesturesEnabled! ! 240491 240492 240493!Object methodsFor: 'inspecting' stamp: 'ar 9/27/2005 18:31'! 240494basicInspect 240495 "Create and schedule an Inspector in which the user can examine the 240496 receiver's variables. This method should not be overriden." 240497 ^ToolSet basicInspect: self! ! 240498 240499!Object methodsFor: 'inspecting' stamp: 'md 1/18/2006 19:09'! 240500inspect 240501 "Create and schedule an Inspector in which the user can examine the receiver's variables." 240502 ToolSet inspect: self! ! 240503 240504!Object methodsFor: 'inspecting' stamp: 'apb 7/14/2004 12:19'! 240505inspectorClass 240506 "Answer the class of the inspector to be used on the receiver. Called by inspect; 240507 use basicInspect to get a normal (less useful) type of inspector." 240508 240509 ^ Inspector! ! 240510 240511 240512!Object methodsFor: 'locales' stamp: 'tak 8/4/2005 14:55'! 240513localeChanged 240514 self shouldBeImplemented! ! 240515 240516 240517!Object methodsFor: 'macpal' stamp: 'sw 5/7/1998 23:00'! 240518codeStrippedOut: messageString 240519 "When a method is stripped out for external release, it is replaced by a method that calls this" 240520 240521 self halt: 'Code stripped out -- ', messageString, '-- do not proceed.'! ! 240522 240523!Object methodsFor: 'macpal' stamp: 'sw 1/28/1999 17:31'! 240524contentsChanged 240525 self changed: #contents! ! 240526 240527!Object methodsFor: 'macpal' stamp: 'ar 3/18/2001 00:03'! 240528currentEvent 240529 "Answer the current Morphic event. This method never returns nil." 240530 ^ActiveEvent ifNil:[self currentHand lastEvent]! ! 240531 240532!Object methodsFor: 'macpal' stamp: 'nk 9/1/2004 10:41'! 240533currentHand 240534 "Return a usable HandMorph -- the one associated with the object's current environment. This method will always return a hand, even if it has to conjure one up as a last resort. If a particular hand is actually handling events at the moment (such as a remote hand or a ghost hand), it will be returned." 240535 240536 ^ActiveHand ifNil: [ self currentWorld primaryHand ]! ! 240537 240538!Object methodsFor: 'macpal' stamp: 'alain.plantec 6/10/2008 20:24'! 240539currentWorld 240540 "Answer a morphic world that is the current UI focus. 240541 If in an embedded world, it's that world. 240542 If in a morphic project, it's that project's world. 240543 240544 This method will never return nil, it will always return its best effort at returning a relevant world morph, but if need be -- if there are no worlds anywhere, it will create a new one." 240545 240546 ActiveWorld ifNotNil:[^ActiveWorld]. 240547 World ifNotNil:[^World]. 240548 240549 ^ PasteUpMorph newWorldForProject: nil! ! 240550 240551!Object methodsFor: 'macpal' stamp: 'jm 5/6/1998 22:35'! 240552flash 240553 "Do nothing." 240554! ! 240555 240556!Object methodsFor: 'macpal' stamp: 'sw 6/16/1998 15:07'! 240557instanceVariableValues 240558 "Answer a collection whose elements are the values of those instance variables of the receiver which were added by the receiver's class" 240559 | c | 240560 c := OrderedCollection new. 240561 self class superclass instSize + 1 to: self class instSize do: 240562 [:i | c add: (self instVarAt: i)]. 240563 ^ c! ! 240564 240565!Object methodsFor: 'macpal' stamp: 'sw 10/24/2000 07:04'! 240566objectRepresented 240567 "most objects represent themselves; this provides a hook for aliases to grab on to" 240568 240569 ^ self! ! 240570 240571!Object methodsFor: 'macpal' stamp: 'sw 5/22/2001 18:31'! 240572refusesToAcceptCode 240573 "Answer whether the receiver is a code-bearing instrument which at the moment refuses to allow its contents to be submitted" 240574 240575 ^ false 240576 ! ! 240577 240578 240579!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:52'! 240580perform: aSymbol 240581 "Send the unary selector, aSymbol, to the receiver. 240582 Fail if the number of arguments expected by the selector is not zero. 240583 Primitive. Optional. See Object documentation whatIsAPrimitive." 240584 240585 <primitive: 83> 240586 ^ self perform: aSymbol withArguments: (Array new: 0)! ! 240587 240588!Object methodsFor: 'message handling' stamp: 'st 11/5/2004 16:19'! 240589perform: selector orSendTo: otherTarget 240590 "If I wish to intercept and handle selector myself, do it; else send it to otherTarget" 240591 ^ (self respondsTo: selector) ifTrue: [self perform: selector] ifFalse: [otherTarget perform: selector]! ! 240592 240593!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:55'! 240594perform: selector withArguments: argArray 240595 "Send the selector, aSymbol, to the receiver with arguments in argArray. 240596 Fail if the number of arguments expected by the selector 240597 does not match the size of argArray. 240598 Primitive. Optional. See Object documentation whatIsAPrimitive." 240599 240600 <primitive: 84> 240601 ^ self perform: selector withArguments: argArray inSuperclass: self class! ! 240602 240603!Object methodsFor: 'message handling' stamp: 'ar 4/25/2005 13:35'! 240604perform: selector withArguments: argArray inSuperclass: lookupClass 240605 "NOTE: This is just like perform:withArguments:, except that 240606 the message lookup process begins, not with the receivers's class, 240607 but with the supplied superclass instead. It will fail if lookupClass 240608 cannot be found among the receiver's superclasses. 240609 Primitive. Essential. See Object documentation whatIsAPrimitive." 240610 240611 <primitive: 100> 240612 (selector isSymbol) 240613 ifFalse: [^ self error: 'selector argument must be a Symbol']. 240614 (selector numArgs = argArray size) 240615 ifFalse: [^ self error: 'incorrect number of arguments']. 240616 (self class == lookupClass or: [self class inheritsFrom: lookupClass]) 240617 ifFalse: [^ self error: 'lookupClass is not in my inheritance chain']. 240618 self primitiveFailed! ! 240619 240620!Object methodsFor: 'message handling' stamp: 'nk 4/11/2002 14:13'! 240621perform: selector withEnoughArguments: anArray 240622 "Send the selector, aSymbol, to the receiver with arguments in argArray. 240623 Only use enough arguments for the arity of the selector; supply nils for missing ones." 240624 | numArgs args | 240625 numArgs := selector numArgs. 240626 anArray size == numArgs 240627 ifTrue: [ ^self perform: selector withArguments: anArray asArray ]. 240628 240629 args := Array new: numArgs. 240630 args replaceFrom: 1 240631 to: (anArray size min: args size) 240632 with: anArray 240633 startingAt: 1. 240634 240635 ^ self perform: selector withArguments: args! ! 240636 240637!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:52'! 240638perform: aSymbol with: anObject 240639 "Send the selector, aSymbol, to the receiver with anObject as its argument. 240640 Fail if the number of arguments expected by the selector is not one. 240641 Primitive. Optional. See Object documentation whatIsAPrimitive." 240642 240643 <primitive: 83> 240644 ^ self perform: aSymbol withArguments: (Array with: anObject)! ! 240645 240646!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:52'! 240647perform: aSymbol with: firstObject with: secondObject 240648 "Send the selector, aSymbol, to the receiver with the given arguments. 240649 Fail if the number of arguments expected by the selector is not two. 240650 Primitive. Optional. See Object documentation whatIsAPrimitive." 240651 240652 <primitive: 83> 240653 ^ self perform: aSymbol withArguments: (Array with: firstObject with: secondObject)! ! 240654 240655!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:51'! 240656perform: aSymbol with: firstObject with: secondObject with: thirdObject 240657 "Send the selector, aSymbol, to the receiver with the given arguments. 240658 Fail if the number of arguments expected by the selector is not three. 240659 Primitive. Optional. See Object documentation whatIsAPrimitive." 240660 240661 <primitive: 83> 240662 ^ self perform: aSymbol 240663 withArguments: (Array with: firstObject with: secondObject with: thirdObject)! ! 240664 240665 240666!Object methodsFor: 'objects from disk' stamp: 'tk 4/8/1999 12:46'! 240667comeFullyUpOnReload: smartRefStream 240668 "Normally this read-in object is exactly what we want to store. 7/26/96 tk" 240669 240670 ^ self! ! 240671 240672!Object methodsFor: 'objects from disk' stamp: 'tk 11/29/2004 15:04'! 240673fixUponLoad: aProject seg: anImageSegment 240674 "change the object due to conventions that have changed on 240675 the project level. (sent to all objects in the incoming project). 240676 Specific classes should reimplement this."! ! 240677 240678!Object methodsFor: 'objects from disk' stamp: 'RAA 1/10/2001 14:02'! 240679indexIfCompact 240680 240681 ^0 "helps avoid a #respondsTo: in publishing"! ! 240682 240683!Object methodsFor: 'objects from disk' stamp: 'tk 2/24/1999 11:08'! 240684objectForDataStream: refStrm 240685 "Return an object to store on an external data stream." 240686 240687 ^ self! ! 240688 240689!Object methodsFor: 'objects from disk' stamp: 'tk 4/8/1999 12:05'! 240690readDataFrom: aDataStream size: varsOnDisk 240691 "Fill in the fields of self based on the contents of aDataStream. Return self. 240692 Read in the instance-variables written by Object>>storeDataOn:. 240693 NOTE: This method must send beginReference: before reading any objects from aDataStream that might reference it. 240694 Allow aDataStream to have fewer inst vars. See SmartRefStream." 240695 | cntInstVars cntIndexedVars | 240696 240697 cntInstVars := self class instSize. 240698 self class isVariable 240699 ifTrue: [cntIndexedVars := varsOnDisk - cntInstVars. 240700 cntIndexedVars < 0 ifTrue: [ 240701 self error: 'Class has changed too much. Define a convertxxx method']] 240702 ifFalse: [cntIndexedVars := 0. 240703 cntInstVars := varsOnDisk]. "OK if fewer than now" 240704 240705 aDataStream beginReference: self. 240706 1 to: cntInstVars do: 240707 [:i | self instVarAt: i put: aDataStream next]. 240708 1 to: cntIndexedVars do: 240709 [:i | self basicAt: i put: aDataStream next]. 240710 "Total number read MUST be equal to varsOnDisk!!" 240711 ^ self "If we ever return something other than self, fix calls 240712 on (super readDataFrom: aDataStream size: anInteger)"! ! 240713 240714!Object methodsFor: 'objects from disk' stamp: 'DamienCassou 9/29/2009 13:05'! 240715saveOnFile 240716 "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. Does not file out the class of the object. tk 6/26/97 13:48" 240717 240718 | aFileName fileStream | 240719 aFileName := self class name asFileName. "do better?" 240720 aFileName := UIManager default 240721 request: 'File name?' translated initialAnswer: aFileName. 240722 aFileName isEmptyOrNil ifTrue: [^ Beeper beep]. 240723 240724 fileStream := FileStream newFileNamed: aFileName asFileName. 240725 fileStream fileOutClass: nil andObject: self.! ! 240726 240727!Object methodsFor: 'objects from disk' stamp: 'tk 8/9/2001 15:40'! 240728storeDataOn: aDataStream 240729 "Store myself on a DataStream. Answer self. This is a low-level DataStream/ReferenceStream method. See also objectToStoreOnDataStream. NOTE: This method must send 'aDataStream beginInstance:size:' and then (nextPut:/nextPutWeak:) its subobjects. readDataFrom:size: reads back what we write here." 240730 | cntInstVars cntIndexedVars | 240731 240732 cntInstVars := self class instSize. 240733 cntIndexedVars := self basicSize. 240734 aDataStream 240735 beginInstance: self class 240736 size: cntInstVars + cntIndexedVars. 240737 1 to: cntInstVars do: 240738 [:i | aDataStream nextPut: (self instVarAt: i)]. 240739 240740 "Write fields of a variable length object. When writing to a dummy 240741 stream, don't bother to write the bytes" 240742 ((aDataStream byteStream class == DummyStream) and: [self class isBits]) ifFalse: [ 240743 1 to: cntIndexedVars do: 240744 [:i | aDataStream nextPut: (self basicAt: i)]]. 240745! ! 240746 240747 240748!Object methodsFor: 'printing' stamp: 'di 6/20/97 08:57'! 240749fullPrintString 240750 "Answer a String whose characters are a description of the receiver." 240751 240752 ^ String streamContents: [:s | self printOn: s]! ! 240753 240754!Object methodsFor: 'printing'! 240755isLiteral 240756 "Answer whether the receiver has a literal text form recognized by the 240757 compiler." 240758 240759 ^false! ! 240760 240761!Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:28'! 240762longPrintOn: aStream 240763 "Append to the argument, aStream, the names and values of all 240764 of the receiver's instance variables." 240765 240766 self class allInstVarNames doWithIndex: 240767 [:title :index | 240768 aStream nextPutAll: title; 240769 nextPut: $:; 240770 space; 240771 tab; 240772 print: (self instVarAt: index); 240773 cr]! ! 240774 240775!Object methodsFor: 'printing' stamp: 'tk 10/19/2001 11:18'! 240776longPrintOn: aStream limitedTo: sizeLimit indent: indent 240777 "Append to the argument, aStream, the names and values of all of the receiver's instance variables. Limit is the length limit for each inst var." 240778 240779 self class allInstVarNames doWithIndex: 240780 [:title :index | 240781 indent timesRepeat: [aStream tab]. 240782 aStream nextPutAll: title; 240783 nextPut: $:; 240784 space; 240785 tab; 240786 nextPutAll: 240787 ((self instVarAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)); 240788 cr]! ! 240789 240790!Object methodsFor: 'printing' stamp: 'tk 10/16/2001 19:41'! 240791longPrintString 240792 "Answer a String whose characters are a description of the receiver." 240793 240794 | str | 240795 str := String streamContents: [:aStream | self longPrintOn: aStream]. 240796 "Objects without inst vars should return something" 240797 ^ str isEmpty ifTrue: [self printString, String cr] ifFalse: [str]! ! 240798 240799!Object methodsFor: 'printing' stamp: 'BG 11/7/2004 13:39'! 240800longPrintStringLimitedTo: aLimitValue 240801 "Answer a String whose characters are a description of the receiver." 240802 240803 | str | 240804 str := String streamContents: [:aStream | self longPrintOn: aStream limitedTo: aLimitValue indent: 0]. 240805 "Objects without inst vars should return something" 240806 ^ str isEmpty ifTrue: [self printString, String cr] ifFalse: [str]! ! 240807 240808!Object methodsFor: 'printing' stamp: 'sw 3/7/2001 13:14'! 240809nominallyUnsent: aSelectorSymbol 240810 "From within the body of a method which is not formally sent within the system, but which you intend to have remain in the system (for potential manual invocation, or for documentation, or perhaps because it's sent by commented-out-code that you anticipate uncommenting out someday, send this message, with the selector itself as the argument. 240811 240812This will serve two purposes: 240813 240814 (1) The method will not be returned by searches for unsent selectors (because it, in a manner of speaking, sends itself). 240815 (2) You can locate all such methods by browsing senders of #nominallyUnsent:" 240816 240817 false ifTrue: [self flag: #nominallyUnsent:] "So that this method itself will appear to be sent" 240818! ! 240819 240820!Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:31'! 240821printOn: aStream 240822 "Append to the argument, aStream, a sequence of characters that 240823 identifies the receiver." 240824 240825 | title | 240826 title := self class name. 240827 aStream 240828 nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']); 240829 nextPutAll: title! ! 240830 240831!Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:22'! 240832printString 240833 "Answer a String whose characters are a description of the receiver. 240834 If you want to print without a character limit, use fullPrintString." 240835 240836 ^ self printStringLimitedTo: 50000! ! 240837 240838!Object methodsFor: 'printing' stamp: 'tk 5/7/1999 16:20'! 240839printStringLimitedTo: limit 240840 "Answer a String whose characters are a description of the receiver. 240841 If you want to print without a character limit, use fullPrintString." 240842 | limitedString | 240843 limitedString := String streamContents: [:s | self printOn: s] limitedTo: limit. 240844 limitedString size < limit ifTrue: [^ limitedString]. 240845 ^ limitedString , '...etc...'! ! 240846 240847!Object methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 240848printWithClosureAnalysisOn: aStream 240849 "Append to the argument, aStream, a sequence of characters that 240850 identifies the receiver." 240851 240852 | title | 240853 title := self class name. 240854 aStream 240855 nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']); 240856 nextPutAll: title! ! 240857 240858!Object methodsFor: 'printing' stamp: 'sw 10/17/2000 11:16'! 240859reportableSize 240860 "Answer a string that reports the size of the receiver -- useful for showing in a list view, for example" 240861 240862 ^ (self basicSize + self class instSize) printString! ! 240863 240864!Object methodsFor: 'printing'! 240865storeOn: aStream 240866 "Append to the argument aStream a sequence of characters that is an 240867 expression whose evaluation creates an object similar to the receiver." 240868 240869 aStream nextPut: $(. 240870 self class isVariable 240871 ifTrue: [aStream nextPutAll: '(', self class name, ' basicNew: '; 240872 store: self basicSize; 240873 nextPutAll: ') '] 240874 ifFalse: [aStream nextPutAll: self class name, ' basicNew']. 240875 1 to: self class instSize do: 240876 [:i | 240877 aStream nextPutAll: ' instVarAt: '; 240878 store: i; 240879 nextPutAll: ' put: '; 240880 store: (self instVarAt: i); 240881 nextPut: $;]. 240882 1 to: self basicSize do: 240883 [:i | 240884 aStream nextPutAll: ' basicAt: '; 240885 store: i; 240886 nextPutAll: ' put: '; 240887 store: (self basicAt: i); 240888 nextPut: $;]. 240889 aStream nextPutAll: ' yourself)' 240890! ! 240891 240892!Object methodsFor: 'printing' stamp: 'di 6/20/97 09:12'! 240893storeString 240894 "Answer a String representation of the receiver from which the receiver 240895 can be reconstructed." 240896 240897 ^ String streamContents: [:s | self storeOn: s]! ! 240898 240899!Object methodsFor: 'printing' stamp: 'sw 5/2/1998 13:55'! 240900stringForReadout 240901 ^ self stringRepresentation! ! 240902 240903!Object methodsFor: 'printing'! 240904stringRepresentation 240905 "Answer a string that represents the receiver. For most objects this is simply its printString, but for strings themselves, it's themselves. 6/12/96 sw" 240906 240907 ^ self printString ! ! 240908 240909 240910!Object methodsFor: 'scripting' stamp: 'ar 3/17/2001 20:11'! 240911adaptedToWorld: aWorld 240912 "If I refer to a world or a hand, return the corresponding items in the new world." 240913 ^self! ! 240914 240915!Object methodsFor: 'scripting' stamp: 'sw 3/10/2000 13:57'! 240916defaultFloatPrecisionFor: aGetSelector 240917 "Answer a number indicating the default float precision to be used in a numeric readout for which the receiver is the model." 240918 240919 ^ 1! ! 240920 240921!Object methodsFor: 'scripting' stamp: 'RAA 3/9/2001 17:08'! 240922evaluateUnloggedForSelf: aCodeString 240923 240924 ^Compiler evaluate: 240925 aCodeString 240926 for: self 240927 logged: false! ! 240928 240929 240930!Object methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:47'! 240931isSelfEvaluating 240932 ^ self isLiteral! ! 240933 240934 240935!Object methodsFor: 'system primitives'! 240936asOop 240937 "Primitive. Answer a SmallInteger whose value is half of the receiver's 240938 object pointer (interpreting object pointers as 16-bit signed quantities). 240939 Fail if the receiver is a SmallInteger. Essential. See Object documentation 240940 whatIsAPrimitive." 240941 240942 <primitive: 75> 240943 self primitiveFailed! ! 240944 240945!Object methodsFor: 'system primitives' stamp: 'di 1/9/1999 15:19'! 240946becomeForward: otherObject 240947 "Primitive. All variables in the entire system that used to point 240948 to the receiver now point to the argument. 240949 Fails if either argument is a SmallInteger." 240950 240951 (Array with: self) 240952 elementsForwardIdentityTo: 240953 (Array with: otherObject)! ! 240954 240955!Object methodsFor: 'system primitives' stamp: 'zz 3/3/2004 23:53'! 240956becomeForward: otherObject copyHash: copyHash 240957 "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. 240958 If copyHash is true, the argument's identity hash bits will be set to those of the receiver. 240959 Fails if either argument is a SmallInteger." 240960 240961 (Array with: self) 240962 elementsForwardIdentityTo: 240963 (Array with: otherObject) 240964 copyHash: copyHash! ! 240965 240966!Object methodsFor: 'system primitives' stamp: 'sw 10/16/2000 10:59'! 240967className 240968 "Answer a string characterizing the receiver's class, for use in list views for example" 240969 240970 ^ self class name asString! ! 240971 240972!Object methodsFor: 'system primitives' stamp: 'sw 10/16/2000 11:04'! 240973creationStamp 240974 "Answer a string which reports the creation particulars of the receiver. Intended perhaps for list views, but this is presently a feature not easily accessible" 240975 240976 ^ '<no creation stamp>'! ! 240977 240978!Object methodsFor: 'system primitives'! 240979instVarAt: index 240980 "Primitive. Answer a fixed variable in an object. The numbering of the 240981 variables corresponds to the named instance variables. Fail if the index 240982 is not an Integer or is not the index of a fixed variable. Essential. See 240983 Object documentation whatIsAPrimitive." 240984 240985 <primitive: 73> 240986 "Access beyond fixed variables." 240987 ^self basicAt: index - self class instSize ! ! 240988 240989!Object methodsFor: 'system primitives'! 240990instVarAt: anInteger put: anObject 240991 "Primitive. Store a value into a fixed variable in the receiver. The 240992 numbering of the variables corresponds to the named instance variables. 240993 Fail if the index is not an Integer or is not the index of a fixed variable. 240994 Answer the value stored as the result. Using this message violates the 240995 principle that each object has sovereign control over the storing of 240996 values into its instance variables. Essential. See Object documentation 240997 whatIsAPrimitive." 240998 240999 <primitive: 74> 241000 "Access beyond fixed fields" 241001 ^self basicAt: anInteger - self class instSize put: anObject! ! 241002 241003!Object methodsFor: 'system primitives' stamp: 'eem 5/14/2008 13:20'! 241004instVarNamed: aString 241005 "Return the value of the instance variable in me with that name. Slow and unclean, but very useful. " 241006 241007 ^ self instVarAt: (self class 241008 instVarIndexFor: aString asString 241009 ifAbsent: [self error: 'no such inst var']) 241010 241011 241012! ! 241013 241014!Object methodsFor: 'system primitives' stamp: 'eem 5/14/2008 13:20'! 241015instVarNamed: aString put: aValue 241016 "Store into the value of the instance variable in me of that name. Slow and unclean, but very useful. " 241017 241018 ^self 241019 instVarAt: (self class 241020 instVarIndexFor: aString asString 241021 ifAbsent: [self error: 'no such inst var']) 241022 put: aValue 241023! ! 241024 241025!Object methodsFor: 'system primitives' stamp: 'sw 10/17/2000 11:12'! 241026oopString 241027 "Answer a string that represents the oop of the receiver" 241028 241029 ^ self asOop printString! ! 241030 241031!Object methodsFor: 'system primitives' stamp: 'ar 3/2/2001 01:34'! 241032primitiveChangeClassTo: anObject 241033 "Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have. 241034 Note: The primitive will fail in most cases that you think might work. This is mostly because of a) the difference between compact and non-compact classes, and b) because of differences in the format. As an example, '(Array new: 3) primitiveChangeClassTo: Morph basicNew' would fail for three of the reasons mentioned above. Array is compact, Morph is not (failure #1). Array is variable and Morph is fixed (different format - failure #2). Morph is a fixed-field-only object and the array is too short (failure #3). 241035 The facility is really provided for certain, very specific applications (mostly related to classes changing shape) and not for casual use." 241036 241037 <primitive: 115> 241038 self primitiveFailed! ! 241039 241040!Object methodsFor: 'system primitives' stamp: 'di 3/27/1999 12:21'! 241041rootStubInImageSegment: imageSegment 241042 241043 ^ ImageSegmentRootStub new 241044 xxSuperclass: nil 241045 format: nil 241046 segment: imageSegment! ! 241047 241048!Object methodsFor: 'system primitives'! 241049someObject 241050 "Primitive. Answer the first object in the enumeration of all 241051 objects." 241052 241053 <primitive: 138> 241054 self primitiveFailed.! ! 241055 241056 241057!Object methodsFor: 'testing' stamp: 'sw 1/12/98 18:09'! 241058haltIfNil! ! 241059 241060!Object methodsFor: 'testing' stamp: 'md 1/20/2006 17:09'! 241061hasLiteralSuchThat: testBlock 241062 "This is the end of the imbedded structure path so return false." 241063 241064 ^ false! ! 241065 241066!Object methodsFor: 'testing' stamp: 'eem 5/8/2008 11:13'! 241067isArray 241068 ^false! ! 241069 241070!Object methodsFor: 'testing' stamp: 'ar 7/9/1999 18:18'! 241071isBehavior 241072 "Return true if the receiver is a behavior. 241073 Note: Do not override in any class except behavior." 241074 ^false! ! 241075 241076!Object methodsFor: 'testing' stamp: 'ajh 1/21/2003 13:15'! 241077isBlock 241078 241079 ^ false! ! 241080 241081!Object methodsFor: 'testing' stamp: 'yo 8/28/2002 13:41'! 241082isCharacter 241083 241084 ^ false. 241085! ! 241086 241087!Object methodsFor: 'testing' stamp: 'eem 5/23/2008 13:47'! 241088isClosure 241089 ^false! ! 241090 241091!Object methodsFor: 'testing' stamp: 'ar 8/17/1999 19:43'! 241092isCollection 241093 "Return true if the receiver is some sort of Collection and responds to basic collection messages such as #size and #do:" 241094 ^false! ! 241095 241096!Object methodsFor: 'testing'! 241097isColor 241098 "Answer true if receiver is a Color. False by default." 241099 241100 ^ false 241101! ! 241102 241103!Object methodsFor: 'testing' stamp: 'nk 4/17/2004 19:43'! 241104isColorForm 241105 ^false! ! 241106 241107!Object methodsFor: 'testing' stamp: 'md 11/21/2003 12:14'! 241108isCompiledMethod 241109 241110 ^ false! ! 241111 241112!Object methodsFor: 'testing' stamp: 'mk 10/27/2003 17:33'! 241113isComplex 241114 "Answer true if receiver is a Complex number. False by default." 241115 241116 ^ false 241117! ! 241118 241119!Object methodsFor: 'testing' stamp: 'eem 11/26/2008 20:22'! 241120isContext 241121 ^false! ! 241122 241123!Object methodsFor: 'testing' stamp: 'md 8/11/2005 16:45'! 241124isDictionary 241125 ^false! ! 241126 241127!Object methodsFor: 'testing' stamp: 'di 11/9/1998 09:38'! 241128isFloat 241129 "Overridden to return true in Float, natch" 241130 ^ false! ! 241131 241132!Object methodsFor: 'testing' stamp: 'ar 10/30/2000 23:22'! 241133isForm 241134 ^false! ! 241135 241136!Object methodsFor: 'testing' stamp: 'len 1/13/98 21:18'! 241137isFraction 241138 "Answer true if the receiver is a Fraction." 241139 241140 ^ false! ! 241141 241142!Object methodsFor: 'testing' stamp: 'rhi 8/14/2003 08:51'! 241143isHeap 241144 241145 ^ false! ! 241146 241147!Object methodsFor: 'testing'! 241148isInteger 241149 "Overridden to return true in Integer." 241150 241151 ^ false! ! 241152 241153!Object methodsFor: 'testing' stamp: 'rhi 8/12/2003 09:52'! 241154isInterval 241155 241156 ^ false! ! 241157 241158!Object methodsFor: 'testing' stamp: 'nk 4/25/2002 08:04'! 241159isMessageSend 241160 ^false 241161! ! 241162 241163!Object methodsFor: 'testing' stamp: 'md 2/19/2006 11:24'! 241164isMethodProperties 241165 ^false! ! 241166 241167!Object methodsFor: 'testing'! 241168isMorph 241169 241170 ^ false! ! 241171 241172!Object methodsFor: 'testing' stamp: 'ar 9/13/2000 15:37'! 241173isMorphicEvent 241174 ^false! ! 241175 241176!Object methodsFor: 'testing' stamp: 'gm 2/22/2003 12:56'! 241177isMorphicModel 241178 "Return true if the receiver is a morphic model" 241179 ^false 241180! ! 241181 241182!Object methodsFor: 'testing'! 241183isNumber 241184 "Overridden to return true in Number, natch" 241185 ^ false! ! 241186 241187!Object methodsFor: 'testing' stamp: 'di 11/6/1998 08:04'! 241188isPoint 241189 "Overridden to return true in Point." 241190 241191 ^ false! ! 241192 241193!Object methodsFor: 'testing' stamp: 'ikp 9/26/97 14:45'! 241194isPseudoContext 241195 ^false! ! 241196 241197!Object methodsFor: 'testing' stamp: 'md 10/2/2005 21:52'! 241198isRectangle 241199 ^false! ! 241200 241201!Object methodsFor: 'testing' stamp: 'nk 6/14/2004 16:49'! 241202isSketchMorph 241203 ^false! ! 241204 241205!Object methodsFor: 'testing' stamp: 'ar 12/23/1999 15:43'! 241206isStream 241207 "Return true if the receiver responds to the stream protocol" 241208 ^false 241209! ! 241210 241211!Object methodsFor: 'testing' stamp: 'sma 6/15/2000 15:48'! 241212isString 241213 "Overridden to return true in String, natch" 241214 ^ false! ! 241215 241216!Object methodsFor: 'testing' stamp: 'md 4/30/2003 15:30'! 241217isSymbol 241218 ^ false ! ! 241219 241220!Object methodsFor: 'testing' stamp: 'jam 3/9/2003 15:10'! 241221isSystemWindow 241222"answer whatever the receiver is a SystemWindow" 241223 ^ false! ! 241224 241225!Object methodsFor: 'testing'! 241226isText 241227 ^ false! ! 241228 241229!Object methodsFor: 'testing' stamp: 'adrian-lienhard 6/21/2009 23:52'! 241230isTrait 241231 ^false! ! 241232 241233!Object methodsFor: 'testing' stamp: 'ar 8/14/2001 23:19'! 241234isVariableBinding 241235 "Return true if I represent a literal variable binding" 241236 ^false 241237 ! ! 241238 241239!Object methodsFor: 'testing' stamp: 'ls 7/14/1998 21:45'! 241240isWebBrowser 241241 "whether this object is a web browser. See class: Scamper" 241242 ^false! ! 241243 241244!Object methodsFor: 'testing' stamp: 'marcus.denker 11/21/2008 16:42'! 241245knownName 241246 "If a formal name has been handed out for this object, answer it, else nil" 241247 241248 ^ References keyAtValue: self ifAbsent: [nil]! ! 241249 241250!Object methodsFor: 'testing' stamp: 'sw 9/27/96'! 241251name 241252 "Answer a name for the receiver. This is used generically in the title of certain inspectors, such as the referred-to inspector, and specificially by various subsystems. By default, we let the object just print itself out.. " 241253 241254 ^ self printString! ! 241255 241256!Object methodsFor: 'testing' stamp: 'marcus.denker 2/8/2009 17:55'! 241257nameForViewer 241258 "Answer a name to be shown in a Viewer that is viewing the receiver" 241259 241260 | aName | 241261 (aName := self knownName) ifNotNil: [^ aName]. 241262 241263 ^ [(self asString copyWithout: Character cr) truncateTo: 27] ifError: 241264 [:msg :rcvr | ^ self class name printString]! ! 241265 241266!Object methodsFor: 'testing'! 241267notNil 241268 "Coerces nil to false and everything else to true." 241269 241270 ^true! ! 241271 241272!Object methodsFor: 'testing' stamp: 'G.C 10/22/2008 09:59'! 241273refersToLiteral: literal 241274 "Answer true if literal is identical to any literal in this array, even if imbedded in further structures. This is the end of the imbedded structure path so return false." 241275 ^ false! ! 241276 241277!Object methodsFor: 'testing' stamp: 'tk 7/28/2005 04:50'! 241278renameInternal: newName 241279 "Change the internal name (because of a conflict) but leave the external name unchanged. Change Player class name, but do not change the names that appear in tiles. Any object that might be pointed to in the References dictionary might get this message sent to it upon reload" 241280 241281 ^ nil "caller will renameTo:. new name may be different"! ! 241282 241283!Object methodsFor: 'testing' stamp: 'stephane.ducasse 11/8/2008 21:15'! 241284renameTo: newName 241285 "If the receiver has an inherent idea about its own name, it should take action here. Any object that might be pointed to in the References dictionary might get this message sent to it upon reload" 241286 self flag: #ToCheckAfterEtoyRemoval.! ! 241287 241288!Object methodsFor: 'testing' stamp: 'sw 1/18/2001 13:43'! 241289showDiffs 241290 "Answer whether the receiver, serving as the model of a text-bearing entity, is 'showing differences' -- if it is, the editor may wish to show special feedback" 241291 241292 ^ false! ! 241293 241294!Object methodsFor: 'testing' stamp: 'sw 10/20/1999 14:52'! 241295stepAt: millisecondClockValue in: aWindow 241296 241297 ^ self stepIn: aWindow! ! 241298 241299!Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:16'! 241300stepIn: aWindow 241301 241302 ^ self step! ! 241303 241304!Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:21'! 241305stepTime 241306 241307 ^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! ! 241308 241309!Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:22'! 241310stepTimeIn: aSystemWindow 241311 241312 ^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! ! 241313 241314!Object methodsFor: 'testing' stamp: 'sw 11/13/2001 07:26'! 241315wantsDiffFeedback 241316 "Answer whether the receiver, serving as the model of a text-bearing entity, would like for 'diffs' green pane-border feedback to be shown" 241317 241318 ^ false! ! 241319 241320!Object methodsFor: 'testing' stamp: 'di 1/8/1999 15:04'! 241321wantsSteps 241322 "Overridden by morphic classes whose instances want to be stepped, 241323 or by model classes who want their morphic views to be stepped." 241324 241325 ^ false! ! 241326 241327!Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:26'! 241328wantsStepsIn: aSystemWindow 241329 241330 ^ self wantsSteps! ! 241331 241332 241333!Object methodsFor: 'thumbnail' stamp: 'dgd 9/25/2004 23:17'! 241334iconOrThumbnailOfSize: aNumberOrPoint 241335 "Answer an appropiate form to represent the receiver" 241336 ^ nil! ! 241337 241338 241339!Object methodsFor: 'translation support'! 241340inline: inlineFlag 241341 "For translation only; noop when running in Smalltalk."! ! 241342 241343!Object methodsFor: 'translation support'! 241344var: varSymbol declareC: declString 241345 "For translation only; noop when running in Smalltalk."! ! 241346 241347 241348!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:32'! 241349capturedState 241350 "May be overridden in subclasses." 241351 241352 ^ self shallowCopy 241353! ! 241354 241355!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:29'! 241356commandHistory 241357 "Return the command history for the receiver" 241358 | w | 241359 (w := self currentWorld) ifNotNil: [^ w commandHistory]. 241360 ^ CommandHistory new. "won't really record anything but prevent breaking things"! ! 241361 241362!Object methodsFor: 'undo' stamp: 'di 12/12/2000 15:01'! 241363purgeAllCommands 241364 "Purge all commands for this object" 241365 Preferences useUndo ifFalse: [^ self]. "get out quickly" 241366 self commandHistory purgeAllCommandsSuchThat: [:cmd | cmd undoTarget == self]. 241367! ! 241368 241369!Object methodsFor: 'undo' stamp: 'di 9/12/2000 08:15'! 241370redoFromCapturedState: st 241371 "May be overridden in subclasses. See also capturedState" 241372 241373 self undoFromCapturedState: st "Simple cases are symmetric" 241374! ! 241375 241376!Object methodsFor: 'undo' stamp: 'sw 11/16/2000 14:42'! 241377refineRedoTarget: target selector: aSymbol arguments: arguments in: refineBlock 241378 "Any object can override this method to refine its redo specification" 241379 241380 ^ refineBlock 241381 value: target 241382 value: aSymbol 241383 value: arguments! ! 241384 241385!Object methodsFor: 'undo' stamp: 'sw 11/16/2000 14:42'! 241386refineUndoTarget: target selector: aSymbol arguments: arguments in: refineBlock 241387 "Any object can override this method to refine its undo specification" 241388 241389 ^ refineBlock 241390 value: target 241391 value: aSymbol 241392 value: arguments! ! 241393 241394!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:30'! 241395rememberCommand: aCommand 241396 "Remember the given command for undo" 241397 Preferences useUndo ifFalse: [^ self]. "get out quickly" 241398 ^ self commandHistory rememberCommand: aCommand! ! 241399 241400!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:30'! 241401rememberUndoableAction: actionBlock named: caption 241402 | cmd result | 241403 cmd := Command new cmdWording: caption. 241404 cmd undoTarget: self selector: #undoFromCapturedState: argument: self capturedState. 241405 result := actionBlock value. 241406 cmd redoTarget: self selector: #redoFromCapturedState: argument: self capturedState. 241407 self rememberCommand: cmd. 241408 ^ result! ! 241409 241410!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:32'! 241411undoFromCapturedState: st 241412 "May be overridden in subclasses. See also capturedState" 241413 241414 self copyFrom: st 241415! ! 241416 241417 241418!Object methodsFor: 'updating'! 241419changed 241420 "Receiver changed in a general way; inform all the dependents by 241421 sending each dependent an update: message." 241422 241423 self changed: self! ! 241424 241425!Object methodsFor: 'updating'! 241426changed: aParameter 241427 "Receiver changed. The change is denoted by the argument aParameter. 241428 Usually the argument is a Symbol that is part of the dependent's change 241429 protocol. Inform all of the dependents." 241430 241431 self dependents do: [:aDependent | aDependent update: aParameter]! ! 241432 241433!Object methodsFor: 'updating' stamp: 'nk 2/17/2004 11:12'! 241434changed: anAspect with: anObject 241435 "Receiver changed. The change is denoted by the argument anAspect. 241436 Usually the argument is a Symbol that is part of the dependent's change 241437 protocol. Inform all of the dependents. Also pass anObject for additional information." 241438 241439 self dependents do: [:aDependent | aDependent update: anAspect with: anObject]! ! 241440 241441!Object methodsFor: 'updating' stamp: 'sw 10/31/1999 00:15'! 241442noteSelectionIndex: anInteger for: aSymbol 241443 "backstop"! ! 241444 241445!Object methodsFor: 'updating'! 241446okToChange 241447 "Allows a controller to ask this of any model" 241448 ^ true! ! 241449 241450!Object methodsFor: 'updating' stamp: 'sw 10/19/1999 14:39'! 241451updateListsAndCodeIn: aWindow 241452 self canDiscardEdits ifFalse: [^ self]. 241453 aWindow updatablePanes do: [:aPane | aPane verifyContents]! ! 241454 241455!Object methodsFor: 'updating' stamp: 'sma 2/29/2000 20:05'! 241456update: aParameter 241457 "Receive a change notice from an object of whom the receiver is a 241458 dependent. The default behavior is to do nothing; a subclass might want 241459 to change itself in some way." 241460 241461 ^ self! ! 241462 241463!Object methodsFor: 'updating' stamp: 'nk 2/17/2004 11:13'! 241464update: anAspect with: anObject 241465 "Receive a change notice from an object of whom the receiver is a 241466 dependent. The default behavior is to call update:, 241467 which by default does nothing; a subclass might want 241468 to change itself in some way." 241469 241470 ^ self update: anAspect! ! 241471 241472!Object methodsFor: 'updating' stamp: 'jm 8/20/1998 18:26'! 241473windowIsClosing 241474 "This message is used to inform a models that its window is closing. Most models do nothing, but some, such as the Debugger, must do some cleanup. Note that this mechanism must be used with care by models that support multiple views, since one view may be closed while others left open." 241475! ! 241476 241477 241478!Object methodsFor: 'user interface' stamp: 'sw 10/4/1999 08:13'! 241479addModelItemsToWindowMenu: aMenu 241480 "aMenu is being constructed to be presented to the user in response to the user's pressing on the menu widget in the title bar of a morphic window. Here, the model is given the opportunity to add any model-specific items to the menu, whose default target is the SystemWindow itself."! ! 241481 241482!Object methodsFor: 'user interface' stamp: 'sw 10/5/1998 14:39'! 241483addModelMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph 241484 "The receiver serves as the model for aMorph; a menu is being constructed for the morph, and here the receiver is able to add its own items" 241485! ! 241486 241487!Object methodsFor: 'user interface' stamp: 'sma 11/12/2000 11:43'! 241488asExplorerString 241489 ^ self printString! ! 241490 241491!Object methodsFor: 'user interface' stamp: 'sw 7/13/1999 15:53'! 241492defaultBackgroundColor 241493 "Answer the color to be used as the base window color for a window whose model is an object of the receiver's class" 241494 241495 ^ Preferences windowColorFor: self class name! ! 241496 241497!Object methodsFor: 'user interface'! 241498defaultLabelForInspector 241499 "Answer the default label to be used for an Inspector window on the receiver." 241500 241501 ^ self class name! ! 241502 241503!Object methodsFor: 'user interface' stamp: 'ar 9/27/2005 20:29'! 241504explore 241505 ^ToolSet explore: self! ! 241506 241507!Object methodsFor: 'user interface' stamp: 'md 8/13/2008 21:39'! 241508hasContentsInExplorer 241509 241510 ^self basicSize > 0 or: [self class allInstVarNames notEmpty] 241511! ! 241512 241513!Object methodsFor: 'user interface' stamp: 'rbb 3/1/2005 09:28'! 241514inform: aString 241515 "Display a message for the user to read and then dismiss. 6/9/96 sw" 241516 241517 aString isEmptyOrNil ifFalse: [UIManager default inform: aString]! ! 241518 241519!Object methodsFor: 'user interface'! 241520initialExtent 241521 "Answer the desired extent for the receiver when a view on it is first opened on the screen. 241522 5/22/96 sw: in the absence of any override, obtain from RealEstateAgent" 241523 241524 ^ RealEstateAgent standardWindowExtent! ! 241525 241526!Object methodsFor: 'user interface' stamp: 'ar 9/27/2005 20:30'! 241527inspectWithLabel: aLabel 241528 "Create and schedule an Inspector in which the user can examine the receiver's variables." 241529 ^ToolSet inspect: self label: aLabel! ! 241530 241531!Object methodsFor: 'user interface' stamp: 'sw 6/12/2001 11:09'! 241532launchPartVia: aSelector 241533 "Obtain a morph by sending aSelector to self, and attach it to the morphic hand. This provides a general protocol for parts bins" 241534 241535 | aMorph | 241536 aMorph := self perform: aSelector. 241537 aMorph setProperty: #beFullyVisibleAfterDrop toValue: true. 241538 aMorph openInHand! ! 241539 241540!Object methodsFor: 'user interface' stamp: 'sw 6/17/2004 01:47'! 241541launchPartVia: aSelector label: aString 241542 "Obtain a morph by sending aSelector to self, and attach it to the morphic hand. This provides a general protocol for parts bins" 241543 241544 | aMorph | 241545 aMorph := self perform: aSelector. 241546 aMorph setNameTo: (ActiveWorld unusedMorphNameLike: aString). 241547 aMorph setProperty: #beFullyVisibleAfterDrop toValue: true. 241548 aMorph openInHand! ! 241549 241550!Object methodsFor: 'user interface' stamp: 'di 5/11/1999 22:26'! 241551modelSleep 241552 "A window with me as model is being exited or collapsed or closed. 241553 Default response is no-op" ! ! 241554 241555!Object methodsFor: 'user interface' stamp: 'di 5/11/1999 22:01'! 241556modelWakeUp 241557 "A window with me as model is being entered or expanded. Default response is no-op" ! ! 241558 241559!Object methodsFor: 'user interface' stamp: 'sw 10/16/1999 22:45'! 241560modelWakeUpIn: aWindow 241561 "A window with me as model is being entered or expanded. Default response is no-op" 241562 self modelWakeUp! ! 241563 241564!Object methodsFor: 'user interface' stamp: 'sw 3/8/1999 15:27'! 241565mouseUpBalk: evt 241566 "A button I own got a mouseDown, but the user moved out before letting up. Certain kinds of objects (so-called 'radio buttons', for example, and other structures that must always have some selection, e.g. PaintBoxMorph) wish to take special action in this case; this default does nothing." 241567! ! 241568 241569!Object methodsFor: 'user interface' stamp: 'jcg 11/1/2001 13:13'! 241570notYetImplemented 241571 self inform: 'Not yet implemented (', thisContext sender printString, ')'! ! 241572 241573!Object methodsFor: 'user interface' stamp: 'di 6/10/1998 15:06'! 241574windowReqNewLabel: labelString 241575 "My window's title has been edited. 241576 Return true if this is OK, and override for further behavior." 241577 241578 ^ true! ! 241579 241580 241581!Object methodsFor: 'viewer' stamp: 'sw 12/11/2000 15:37'! 241582browseOwnClassSubProtocol 241583 "Open up a ProtocolBrowser on the subprotocol of the receiver" 241584 241585 ProtocolBrowser openSubProtocolForClass: self class 241586! ! 241587 241588!Object methodsFor: 'viewer' stamp: 'sw 2/14/2000 14:24'! 241589defaultNameStemForInstances 241590 "Answer a basis for names of default instances of the receiver. The default is to let the class specify, but certain instances will want to override. (PasteUpMorphs serving as Worlds come to mind" 241591 241592 ^ self class defaultNameStemForInstances! ! 241593 241594!Object methodsFor: 'viewer' stamp: 'sw 5/4/2001 07:04'! 241595externalName 241596 "Answer an external name by which the receiver is known. Generic implementation here is a transitional backstop. probably" 241597 241598 ^ self nameForViewer! ! 241599 241600!Object methodsFor: 'viewer' stamp: 'sw 5/4/2001 07:06'! 241601graphicForViewerTab 241602 "When a Viewer is open on the receiver, its tab needs some graphic to show to the user. Answer a form or a morph to serve that purpose. A generic image is used for arbitrary objects, but note my reimplementors" 241603 241604 ^ ScriptingSystem formAtKey: 'Image'! ! 241605 241606 241607!Object methodsFor: 'world hacking' stamp: 'alain.plantec 6/10/2008 20:07'! 241608couldOpenInMorphic 241609 "is there an obvious morphic world in which to open a new morph?" 241610 self deprecated: #mvcIsRemoved. 241611 ^ World notNil 241612 or: [ActiveWorld notNil]! ! 241613 241614 241615!Object methodsFor: 'private'! 241616errorImproperStore 241617 "Create an error notification that an improper store was attempted." 241618 241619 self error: 'Improper store into indexable object'! ! 241620 241621!Object methodsFor: 'private'! 241622errorNonIntegerIndex 241623 "Create an error notification that an improper object was used as an index." 241624 241625 self error: 'only integers should be used as indices'! ! 241626 241627!Object methodsFor: 'private' stamp: 'yo 6/29/2004 11:37'! 241628errorNotIndexable 241629 "Create an error notification that the receiver is not indexable." 241630 241631 self error: ('Instances of {1} are not indexable' translated format: {self class name})! ! 241632 241633!Object methodsFor: 'private'! 241634errorSubscriptBounds: index 241635 "Create an error notification that an improper integer was used as an index." 241636 241637 self error: 'subscript is out of bounds: ' , index printString! ! 241638 241639!Object methodsFor: 'private' stamp: 'pavel.krivanek 11/21/2008 16:50'! 241640primitiveError: aString 241641 "This method is called when the error handling results in a recursion in 241642 calling on error: or halt or halt:." 241643 241644 UIManager default onPrimitiveError: aString.! ! 241645 241646!Object methodsFor: 'private' stamp: 'eem 5/9/2008 09:04'! 241647species 241648 "Answer the preferred class for reconstructing the receiver. For example, 241649 collections create new collections whenever enumeration messages such as 241650 collect: or select: are invoked. The new kind of collection is determined by 241651 the species of the original collection. Species and class are not always the 241652 same. For example, the species of Interval is Array." 241653 <primitive: 111> 241654 ^self class! ! 241655 241656!Object methodsFor: 'private'! 241657storeAt: offset inTempFrame: aContext 241658 "This message had to get sent to an expression already on the stack 241659 as a Block argument being accessed by the debugger. 241660 Just re-route it to the temp frame." 241661 ^ aContext tempAt: offset put: self! ! 241662 241663 241664!Object methodsFor: 'deprecated' stamp: 'AndrewBlack 9/3/2009 02:22'! 241665deprecated: anExplanationString block: aBlock 241666 "Warn that the sender has been deprecated. Answer the value of aBlock on resumption. 241667 (Note that deprecated: is the preferred method.)" 241668 241669 self deprecated: anExplanationString. 241670 ^ aBlock value. 241671! ! 241672 241673!Object methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 08:06'! 241674isKindOf: aClass orOf: anotherClass 241675 "Answer whether the class, aClass, is a superclass or class of the receiver." 241676 241677 self deprecated: 'Use isKindOf: or, even better, don''t.'. 241678 ^ (self isKindOf: aClass) or: [self isKindOf: anotherClass]! ! 241679 241680"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 241681 241682Object class 241683 instanceVariableNames: ''! 241684 241685!Object class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/17/2007 17:40'! 241686taskbarIcon 241687 "Answer the icon for an instance of the receiver in a task bar 241688 or nil for the default." 241689 241690 ^nil! ! 241691 241692!Object class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/31/2009 15:53'! 241693taskbarLabel 241694 "Answer the label string for the receiver in a task bar 241695 or nil for the default." 241696 241697 ^nil! ! 241698 241699 241700!Object class methodsFor: 'class initialization' stamp: 'ar 2/11/2001 02:00'! 241701flushDependents 241702 DependentsFields keysAndValuesDo:[:key :dep| 241703 key ifNotNil:[key removeDependent: nil]. 241704 ]. 241705 DependentsFields finalizeValues.! ! 241706 241707!Object class methodsFor: 'class initialization' stamp: 'rw 2/10/2002 13:09'! 241708flushEvents 241709 "Object flushEvents" 241710 241711 EventManager flushEvents. ! ! 241712 241713!Object class methodsFor: 'class initialization' stamp: 'rww 10/2/2001 07:35'! 241714initialize 241715 "Object initialize" 241716 DependentsFields ifNil:[self initializeDependentsFields].! ! 241717 241718!Object class methodsFor: 'class initialization' stamp: 'ar 2/11/2001 01:41'! 241719initializeDependentsFields 241720 "Object initialize" 241721 DependentsFields := WeakIdentityKeyDictionary new. 241722! ! 241723 241724!Object class methodsFor: 'class initialization' stamp: 'ar 2/11/2001 01:45'! 241725reInitializeDependentsFields 241726 "Object reInitializeDependentsFields" 241727 | oldFields | 241728 oldFields := DependentsFields. 241729 DependentsFields := WeakIdentityKeyDictionary new. 241730 oldFields keysAndValuesDo:[:obj :deps| 241731 deps do:[:d| obj addDependent: d]]. 241732! ! 241733 241734 241735!Object class methodsFor: 'documentation'! 241736howToModifyPrimitives 241737 "You are allowed to write methods which specify primitives, but please use 241738 caution. If you make a subclass of a class which contains a primitive method, 241739 the subclass inherits the primitive. The message which is implemented 241740 primitively may be overridden in the subclass (E.g., see at:put: in String's 241741 subclass Symbol). The primitive behavior can be invoked using super (see 241742 Symbol string:). 241743 241744 A class which attempts to mimic the behavior of another class without being 241745 its subclass may or may not be able to use the primitives of the original class. 241746 In general, if the instance variables read or written by a primitive have the 241747 same meanings and are in the same fields in both classes, the primitive will 241748 work. 241749 241750 For certain frequently used 'special selectors', the compiler emits a 241751 send-special-selector bytecode instead of a send-message bytecode. 241752 Special selectors were created because they offer two advantages. Code 241753 which sends special selectors compiles into fewer bytes than normal. For 241754 some pairs of receiver classes and special selectors, the interpreter jumps 241755 directly to a primitive routine without looking up the method in the class. 241756 This is much faster than a normal message lookup. 241757 241758 A selector which is a special selector solely in order to save space has a 241759 normal behavior. Methods whose selectors are special in order to 241760 gain speed contain the comment, 'No Lookup'. When the interpreter 241761 encounters a send-special-selector bytecode, it checks the class of the 241762 receiver and the selector. If the class-selector pair is a no-lookup pair, 241763 then the interpreter swiftly jumps to the routine which implements the 241764 corresponding primitive. (A special selector whose receiver is not of the 241765 right class to make a no-lookup pair, is looked up normally). The pairs are 241766 listed below. No-lookup methods contain a primitive number specification, 241767 <primitive: xx>, which is redundant. Since the method is not normally looked 241768 up, deleting the primitive number specification cannot prevent this 241769 primitive from running. If a no-lookup primitive fails, the method is looked 241770 up normally, and the expressions in it are executed. 241771 241772 No Lookup pairs of (class, selector) 241773 241774 SmallInteger with any of + - * / \\ bitOr: bitShift: bitAnd: // 241775 SmallInteger with any of = ~= > < >= <= 241776 Any class with == 241777 Any class with @ 241778 Point with either of x y 241779 ContextPart with blockCopy: 241780 BlockContext with either of value value: 241781 " 241782 241783 self error: 'comment only'! ! 241784 241785!Object class methodsFor: 'documentation'! 241786whatIsAPrimitive 241787 "Some messages in the system are responded to primitively. A primitive 241788 response is performed directly by the interpreter rather than by evaluating 241789 expressions in a method. The methods for these messages indicate the 241790 presence of a primitive response by including <primitive: xx> before the 241791 first expression in the method. 241792 241793 Primitives exist for several reasons. Certain basic or 'primitive' 241794 operations cannot be performed in any other way. Smalltalk without 241795 primitives can move values from one variable to another, but cannot add two 241796 SmallIntegers together. Many methods for arithmetic and comparison 241797 between numbers are primitives. Some primitives allow Smalltalk to 241798 communicate with I/O devices such as the disk, the display, and the keyboard. 241799 Some primitives exist only to make the system run faster; each does the same 241800 thing as a certain Smalltalk method, and its implementation as a primitive is 241801 optional. 241802 241803 When the Smalltalk interpreter begins to execute a method which specifies a 241804 primitive response, it tries to perform the primitive action and to return a 241805 result. If the routine in the interpreter for this primitive is successful, 241806 it will return a value and the expressions in the method will not be evaluated. 241807 If the primitive routine is not successful, the primitive 'fails', and the 241808 Smalltalk expressions in the method are executed instead. These 241809 expressions are evaluated as though the primitive routine had not been 241810 called. 241811 241812 The Smalltalk code that is evaluated when a primitive fails usually 241813 anticipates why that primitive might fail. If the primitive is optional, the 241814 expressions in the method do exactly what the primitive would have done (See 241815 Number @). If the primitive only works on certain classes of arguments, the 241816 Smalltalk code tries to coerce the argument or appeals to a superclass to find 241817 a more general way of doing the operation (see SmallInteger +). If the 241818 primitive is never supposed to fail, the expressions signal an error (see 241819 SmallInteger asFloat). 241820 241821 Each method that specifies a primitive has a comment in it. If the primitive is 241822 optional, the comment will say 'Optional'. An optional primitive that is not 241823 implemented always fails, and the Smalltalk expressions do the work 241824 instead. 241825 241826 If a primitive is not optional, the comment will say, 'Essential'. Some 241827 methods will have the comment, 'No Lookup'. See Object 241828 howToModifyPrimitives for an explanation of special selectors which are 241829 not looked up. 241830 241831 For the primitives for +, -, *, and bitShift: in SmallInteger, and truncated 241832 in Float, the primitive constructs and returns a 16-bit 241833 LargePositiveInteger when the result warrants it. Returning 16-bit 241834 LargePositiveIntegers from these primitives instead of failing is 241835 optional in the same sense that the LargePositiveInteger arithmetic 241836 primitives are optional. The comments in the SmallInteger primitives say, 241837 'Fails if result is not a SmallInteger', even though the implementor has the 241838 option to construct a LargePositiveInteger. For further information on 241839 primitives, see the 'Primitive Methods' part of the chapter on the formal 241840 specification of the interpreter in the Smalltalk book." 241841 241842 self error: 'comment only'! ! 241843 241844 241845!Object class methodsFor: 'file list services' stamp: 'nk 6/12/2004 11:41'! 241846fileReaderServicesForDirectory: aFileDirectory 241847 "Backstop" 241848 ^#()! ! 241849 241850!Object class methodsFor: 'file list services' stamp: 'nk 6/12/2004 11:30'! 241851fileReaderServicesForFile: fullName suffix: suffix 241852 "Backstop" 241853 ^#()! ! 241854 241855!Object class methodsFor: 'file list services' stamp: 'md 2/15/2006 17:20'! 241856services 241857 "Backstop" 241858 ^#()! ! 241859 241860 241861!Object class methodsFor: 'instance creation' stamp: 'sw 7/28/97 15:56'! 241862chooseUniqueClassName 241863 | i className | 241864 i := 1. 241865 [className := (self name , i printString) asSymbol. 241866 Smalltalk includesKey: className] 241867 whileTrue: [i := i + 1]. 241868 ^ className! ! 241869 241870!Object class methodsFor: 'instance creation' stamp: 'sw 5/5/2000 09:30'! 241871initializedInstance 241872 ^ self new! ! 241873 241874!Object class methodsFor: 'instance creation' stamp: 'ajh 5/23/2002 00:35'! 241875newFrom: aSimilarObject 241876 "Create an object that has similar contents to aSimilarObject. 241877 If the classes have any instance varaibles with the same names, copy them across. 241878 If this is bad for a class, override this method." 241879 241880 ^ (self isVariable 241881 ifTrue: [self basicNew: aSimilarObject basicSize] 241882 ifFalse: [self basicNew] 241883 ) copySameFrom: aSimilarObject! ! 241884 241885 241886!Object class methodsFor: 'objects from disk' stamp: 'tk 1/8/97'! 241887createFrom: aSmartRefStream size: varsOnDisk version: instVarList 241888 "Create an instance of me so objects on the disk can be read in. Tricky part is computing the size if variable. Inst vars will be filled in later. " 241889 241890 ^ self isVariable 241891 ifFalse: [self basicNew] 241892 ifTrue: ["instVarList is names of old class's inst vars plus a version number" 241893 self basicNew: (varsOnDisk - (instVarList size - 1))] 241894! ! 241895 241896!Object class methodsFor: 'objects from disk' stamp: 'nk 8/30/2004 07:57'! 241897readCarefullyFrom: textStringOrStream 241898 "Create an object based on the contents of textStringOrStream. Return an error instead of putting up a SyntaxError window." 241899 241900 | object | 241901 (Compiler couldEvaluate: textStringOrStream) 241902 ifFalse: [^ self error: 'expected String, Stream, or Text']. 241903 object := Compiler evaluate: textStringOrStream for: nil 241904 notifying: #error: "signal we want errors" logged: false. 241905 (object isKindOf: self) ifFalse: [self error: self name, ' expected']. 241906 ^object! ! 241907 241908!Object class methodsFor: 'objects from disk' stamp: 'nk 8/30/2004 07:57'! 241909readFrom: textStringOrStream 241910 "Create an object based on the contents of textStringOrStream." 241911 241912 | object | 241913 (Compiler couldEvaluate: textStringOrStream) 241914 ifFalse: [^ self error: 'expected String, Stream, or Text']. 241915 object := Compiler evaluate: textStringOrStream. 241916 (object isKindOf: self) ifFalse: [self error: self name, ' expected']. 241917 ^object! ! 241918 241919 241920 241921!Object class methodsFor: 'private' stamp: 'mir 8/22/2001 15:20'! 241922releaseExternalSettings 241923 "Do nothing as a default"! ! 241924 241925 241926!Object class methodsFor: 'deprecated' stamp: 'StephaneDucasse 9/15/2009 09:49'! 241927initialInstance 241928 "Answer the first instance of the receiver, generate an error if there is one already" 241929 "self instanceCount > 0 ifTrue: [self error: 'instance(s) already exist.']." 241930 "Debugging test that is very slow" 241931 self deprecated: 'Do not use this method.' on: '14 September 2009' in: #Pharo1.0. 241932 ^ self new! ! 241933 241934 241935!Object class methodsFor: '*Morphic' stamp: 'StephaneDucasse 9/26/2009 09:19'! 241936windowColorSpecification 241937 "Answer a WindowColorSpec object that declares my preference. 241938 This is a backstop for classes that don't otherwise define a preference." 241939 241940 ^ WindowColorSpec classSymbol: self name 241941 wording: 'Default' brightColor: #white 241942 pastelColor: #white 241943 helpMessage: 'Other windows without color preferences.'! ! 241944AbstractHierarchicalList subclass: #ObjectExplorer 241945 instanceVariableNames: 'rootObject inspector monitorList' 241946 classVariableNames: '' 241947 poolDictionaries: '' 241948 category: 'Tools-Explorer'! 241949!ObjectExplorer commentStamp: '<historical>' prior: 0! 241950ObjectExplorer provides a hierarchical alternative to #inspect. Simply evaluate an expression like: 241951 241952World explore 241953 241954and enjoy.! 241955]style[(101 13 12)f1,f3cblue;,f1! 241956 241957 241958!ObjectExplorer methodsFor: 'accessing' stamp: 'RAA 9/23/1999 13:11'! 241959contentsSelection 241960 "Return the interval of text in the code pane to select when I set the pane's contents" 241961 241962 ^ 1 to: 0 "null selection"! ! 241963 241964!ObjectExplorer methodsFor: 'accessing' stamp: 'RAA 9/23/1999 13:15'! 241965doItContext 241966 "Answer the context in which a text selection can be evaluated." 241967 241968 ^nil! ! 241969 241970!ObjectExplorer methodsFor: 'accessing' stamp: 'RAA 9/23/1999 13:19'! 241971doItReceiver 241972 "Answer the object that should be informed of the result of evaluating a 241973 text selection." 241974 241975 currentSelection ifNil: [^rootObject]. 241976 ^currentSelection withoutListWrapper 241977! ! 241978 241979!ObjectExplorer methodsFor: 'accessing' stamp: 'yo 8/27/2008 23:54'! 241980explorerFor: anObject 241981 | window listMorph | 241982 rootObject := anObject. 241983 window := (SystemWindow labelled: (rootObject printStringLimitedTo: 32)) model: self. 241984 window addMorph: (listMorph := SimpleHierarchicalListMorph 241985 on: self 241986 list: #getList 241987 selected: #getCurrentSelection 241988 changeSelected: #noteNewSelection: 241989 menu: #genericMenu: 241990 keystroke: #explorerKey:from:) 241991 frame: (0@0 corner: 1@0.8). 241992 window addMorph: ((PluggableTextMorph on: self text: #trash accept: #trash: 241993 readSelection: #contentsSelection menu: #codePaneMenu:shifted:) 241994 askBeforeDiscardingEdits: false) 241995 frame: (0@0.8 corner: 1@1). 241996 listMorph autoDeselect: false. 241997 ^ window! ! 241998 241999!ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:16'! 242000getList 242001 242002 ^Array with: (ObjectExplorerWrapper with: rootObject name: 'root' model: self parent: nil) 242003! ! 242004 242005!ObjectExplorer methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! 242006object 242007 ^currentSelection ifNotNil: [ :cs | cs withoutListWrapper ]! ! 242008 242009!ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 10:02'! 242010parentObject 242011 currentSelection ifNil: [ ^nil ]. 242012 currentSelection parent ifNil: [ ^rootObject ]. 242013 ^currentSelection parent withoutListWrapper! ! 242014 242015!ObjectExplorer methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! 242016selector 242017 ^currentSelection ifNotNil: [ :cs | cs selector ]! ! 242018 242019 242020!ObjectExplorer methodsFor: 'error handling' stamp: 'nk 7/24/2003 09:29'! 242021doesNotUnderstand: aMessage 242022 inspector ifNotNil: [ (inspector respondsTo: aMessage selector) ifTrue: [ ^inspector perform: aMessage selector withArguments: aMessage arguments ]]. 242023 ^super doesNotUnderstand: aMessage! ! 242024 242025 242026!ObjectExplorer methodsFor: 'menus' stamp: 'sd 11/20/2005 21:27'! 242027chasePointers 242028 "Open a PointerFinder on the selected item" 242029 | path sel savedRoot saved | 242030 path := OrderedCollection new. 242031 sel := currentSelection. 242032 [ sel isNil ] whileFalse: [ path addFirst: sel asString. sel := sel parent ]. 242033 path addFirst: #openPath. 242034 path := path asArray. 242035 savedRoot := rootObject. 242036 saved := self object. 242037 [ rootObject := nil. 242038 self changed: #getList. 242039 (Smalltalk includesKey: #PointerFinder) 242040 ifTrue: [PointerFinder on: saved] 242041 ifFalse: [self objectReferencesToSelection ]] 242042 ensure: [ rootObject := savedRoot. 242043 self changed: #getList. 242044 self changed: path. 242045 ]! ! 242046 242047!ObjectExplorer methodsFor: 'menus' stamp: 'RAA 9/23/1999 13:22'! 242048codePaneMenu: aMenu shifted: shifted 242049 "Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items" 242050 ^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted 242051! ! 242052 242053!ObjectExplorer methodsFor: 'menus' stamp: 'sd 11/20/2005 21:27'! 242054defsOfSelection 242055 "Open a browser on all defining references to the selected instance variable, if that's what's currently selected." 242056 | aClass sel | 242057 242058 (aClass := self parentObject class) isVariable ifTrue: [^ self changed: #flash]. 242059 sel := self selector. 242060 self systemNavigation browseAllStoresInto: sel from: aClass! ! 242061 242062!ObjectExplorer methodsFor: 'menus' stamp: 'mtf 4/25/2008 17:41'! 242063explorePointers 242064 "Open a PointerExplorer on the current selection" 242065 PointerExplorer new openExplorerFor: self object! ! 242066 242067!ObjectExplorer methodsFor: 'menus' stamp: 'stephane.ducasse 9/20/2008 22:23'! 242068explorerKey: aChar from: view 242069 242070 "Similar to #genericMenu:..." 242071 | insideObject parentObject | 242072 currentSelection ifNotNil: [ 242073 insideObject := self object. 242074 parentObject := self parentObject. 242075 inspector ifNil: [inspector := Inspector new]. 242076 inspector 242077 inspect: parentObject; 242078 object: insideObject. 242079 242080 aChar == $i ifTrue: [^ self inspectSelection]. 242081 aChar == $I ifTrue: [^ self exploreSelection]. 242082 242083 aChar == $b ifTrue: [^ inspector browseMethodFull]. 242084 aChar == $h ifTrue: [^ inspector classHierarchy]. 242085 aChar == $c ifTrue: [^ inspector copyName]. 242086 aChar == $p ifTrue: [^ inspector browseFullProtocol]. 242087 aChar == $N ifTrue: [^ inspector browseClassRefs]]. 242088 242089 ^ self arrowKey: aChar from: view! ! 242090 242091!ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:26'! 242092exploreSelection 242093 "Open an ObjectExplorer on the current selection" 242094 self object explore! ! 242095 242096!ObjectExplorer methodsFor: 'menus' stamp: 'mtf 4/25/2008 17:40'! 242097genericMenu: aMenu 242098 "Borrow a menu from my inspector" 242099 | insideObject menu parentObject | 242100 currentSelection 242101 ifNil: [menu := aMenu. 242102 menu 242103 add: '*nothing selected*' 242104 target: self 242105 selector: #yourself] 242106 ifNotNil: [insideObject := self object. 242107 parentObject := self parentObject. 242108 inspector 242109 ifNil: [inspector := Inspector new]. 242110 inspector inspect: parentObject; 242111 object: insideObject. 242112 aMenu defaultTarget: inspector. 242113 inspector fieldListMenu: aMenu. 242114 aMenu items 242115 do: [:i | (#(#inspectSelection #exploreSelection #referencesToSelection #defsOfSelection #objectReferencesToSelection #chasePointers #explorePointers) includes: i selector) 242116 ifTrue: [i target: self]]. 242117 aMenu addLine; 242118 add: 'monitor changes' 242119 target: self 242120 selector: #monitor: 242121 argument: currentSelection]. 242122 monitorList isEmptyOrNil 242123 ifFalse: [aMenu addLine; 242124 add: 'stop monitoring all' 242125 target: self 242126 selector: #stopMonitoring]. 242127 ^ aMenu! ! 242128 242129!ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:26'! 242130inspectSelection 242131 "Open an Inspector on the current selection" 242132 self object inspect! ! 242133 242134!ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:00'! 242135objectReferencesToSelection 242136 "Open a browser on all references to the selected instance variable, if that's what currently selected. " 242137 self systemNavigation 242138 browseAllObjectReferencesTo: self object 242139 except: (Array with: self parentObject with: currentSelection with: inspector) 242140 ifNone: [:obj | self changed: #flash]. 242141! ! 242142 242143!ObjectExplorer methodsFor: 'menus' stamp: 'sd 11/20/2005 21:27'! 242144referencesToSelection 242145 "Open a browser on all references to the selected instance variable, if that's what's currently selected." 242146 | aClass sel | 242147 242148 (aClass := self parentObject class) isVariable ifTrue: [^ self changed: #flash]. 242149 sel := self selector. 242150 self systemNavigation browseAllAccessesTo: sel from: aClass! ! 242151 242152!ObjectExplorer methodsFor: 'menus' stamp: 'RAA 9/23/1999 13:19'! 242153selectedClass 242154 "Answer the class of the receiver's current selection" 242155 242156 ^self doItReceiver class 242157! ! 242158 242159 242160!ObjectExplorer methodsFor: 'monitoring' stamp: 'sd 11/20/2005 21:27'! 242161monitorList 242162 ^monitorList ifNil: [ monitorList := WeakIdentityKeyDictionary new ].! ! 242163 242164!ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:02'! 242165monitor: anObjectExplorerWrapper 242166 "Start stepping and watching the given wrapper for changes." 242167 anObjectExplorerWrapper ifNil: [ ^self ]. 242168 self world ifNil: [ ^self ]. 242169 self monitorList at: anObjectExplorerWrapper put: anObjectExplorerWrapper asString. 242170 self world startStepping: self at: Time millisecondClockValue selector: #step arguments: #() stepTime: 200.! ! 242171 242172!ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:01'! 242173release 242174 self world ifNotNil: [ self world stopStepping: self selector: #step ]. 242175 super release.! ! 242176 242177!ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/12/2003 17:55'! 242178shouldGetStepsFrom: aWorld 242179 ^self monitorList notEmpty! ! 242180 242181!ObjectExplorer methodsFor: 'monitoring' stamp: 'sd 11/20/2005 21:27'! 242182step 242183 "If there's anything in my monitor list, see if the strings have changed." 242184 | string changes | 242185 changes := false. 242186 self monitorList keysAndValuesDo: [ :k :v | 242187 k ifNotNil: [ 242188 k refresh. 242189 (string := k asString) ~= v ifTrue: [ self monitorList at: k put: string. changes := true ]. 242190 ] 242191 ]. 242192 changes ifTrue: [ | sel | 242193 sel := currentSelection. 242194 self changed: #getList. 242195 self noteNewSelection: sel. 242196 ]. 242197 self monitorList isEmpty ifTrue: [ ActiveWorld stopStepping: self selector: #step ].! ! 242198 242199!ObjectExplorer methodsFor: 'monitoring' stamp: 'sd 11/20/2005 21:27'! 242200stopMonitoring 242201 monitorList := nil. 242202 self world stopStepping: self selector: #step! ! 242203 242204!ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:01'! 242205world 242206 ^ActiveWorld! ! 242207 242208 242209!ObjectExplorer methodsFor: 'user interface' stamp: 'stephaneducasse 9/17/2005 21:50'! 242210explorerFor: anObject withLabel: label 242211 | window listMorph | 242212 rootObject := anObject. 242213 window := (SystemWindow labelled: label) 242214 model: self. 242215 window 242216 addMorph: (listMorph := SimpleHierarchicalListMorph 242217 on: self 242218 list: #getList 242219 selected: #getCurrentSelection 242220 changeSelected: #noteNewSelection: 242221 menu: #genericMenu: 242222 keystroke: nil) 242223 frame: (0 @ 0 corner: 1 @ 0.8). 242224 window 242225 addMorph: ((PluggableTextMorph 242226 on: self 242227 text: #trash 242228 accept: #trash: 242229 readSelection: #contentsSelection 242230 menu: #codePaneMenu:shifted:) 242231 askBeforeDiscardingEdits: false) 242232 frame: (0 @ 0.8 corner: 1 @ 1). 242233 listMorph autoDeselect: false. 242234 ^ window! ! 242235 242236!ObjectExplorer methodsFor: 'user interface' stamp: 'RAA 6/2/2000 16:23'! 242237initialExtent 242238 242239 ^300@500! ! 242240 242241!ObjectExplorer methodsFor: 'user interface' stamp: 'ar 9/27/2005 20:31'! 242242openBrowser: aClass 242243 242244 ToolSet browse: aClass selector: nil! ! 242245 242246!ObjectExplorer methodsFor: 'user interface' stamp: 'eem 5/7/2008 11:17'! 242247openExplorerFor: anObject 242248" 242249ObjectExplorer new openExplorerFor: Smalltalk 242250" 242251 242252 | win | 242253 win := (self explorerFor: anObject) openInWorld. 242254 Cursor wait showWhile: 242255 [win submorphs do: 242256 [:sm| 242257 (sm respondsTo: #expandRoots) ifTrue: 242258 [sm expandRoots]]]. 242259 ^self 242260! ! 242261 242262!ObjectExplorer methodsFor: 'user interface' stamp: 'stephaneducasse 9/17/2005 21:51'! 242263openExplorerFor: anObject withLabel: label 242264 "ObjectExplorer new openExplorerFor: Smalltalk withLabel: 'Smalltalk'" 242265 242266 (self explorerFor: anObject withLabel: label) 242267openInWorld! ! 242268 242269"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 242270 242271ObjectExplorer class 242272 instanceVariableNames: ''! 242273 242274!ObjectExplorer class methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 15:55'! 242275about 242276 242277 StringHolder new textContents: self comment; openLabel: 'about ',self asString! ! 242278ListItemWrapper subclass: #ObjectExplorerWrapper 242279 instanceVariableNames: 'itemName parent' 242280 classVariableNames: '' 242281 poolDictionaries: '' 242282 category: 'Morphic-Explorer'! 242283!ObjectExplorerWrapper commentStamp: '<historical>' prior: 0! 242284Contributed by Bob Arning as part of the ObjectExplorer package. 242285! 242286 242287 242288!ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'yo 8/27/2008 23:39'! 242289contents 242290 242291 (item customizeExplorerContents) ifTrue: [^item explorerContents]. 242292 "For all others, show named vars first, then indexed vars" 242293 ^(item class allInstVarNames asOrderedCollection withIndexCollect: [:each :index | 242294 self class 242295 with: (item instVarAt: index) 242296 name: each 242297 model: item 242298 parent: self]) , 242299 ((1 to: item basicSize) collect: [:index | 242300 self class 242301 with: (item basicAt: index) 242302 name: index printString 242303 model: item 242304 parent: self])! ! 242305 242306!ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'RAA 6/21/1999 11:27'! 242307hasContents 242308 242309 ^item hasContentsInExplorer 242310 242311! ! 242312 242313!ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:34'! 242314icon 242315 "Answer a form to be used as icon" 242316 ^ Preferences visualExplorer 242317 ifTrue: [item iconOrThumbnailOfSize: 16] 242318 ifFalse: [nil]! ! 242319 242320 242321!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 15:48'! 242322canBeDragged 242323 242324 ^false! ! 242325 242326!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:14'! 242327parent 242328 ^parent! ! 242329 242330!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:14'! 242331parent: anObject 242332 parent := anObject! ! 242333 242334!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:49'! 242335selector 242336 parent ifNil: [ ^nil ]. 242337 ^(parent withoutListWrapper class allInstVarNames includes: itemName) ifTrue: [ itemName asSymbol ]! ! 242338 242339!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 10:49'! 242340setItem: anObject name: aString model: aModel 242341 242342 item := anObject. 242343 model := aModel. 242344 itemName := aString.! ! 242345 242346!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:14'! 242347setItem: anObject name: aString model: aModel parent: itemParent 242348 parent := itemParent. 242349 self setItem: anObject name: aString model: aModel! ! 242350 242351 242352!ObjectExplorerWrapper methodsFor: 'converting' stamp: 'nk 7/24/2003 10:16'! 242353itemName 242354 ^itemName! ! 242355 242356 242357!ObjectExplorerWrapper methodsFor: 'monitoring' stamp: 'nk 7/12/2003 18:28'! 242358refresh 242359 "hack to refresh item given an object and a string that is either an index or an instance variable name." 242360 [ | index | 242361 (model class allInstVarNames includes: itemName) 242362 ifTrue: [ item := model instVarNamed: itemName ] 242363 ifFalse: [ index := itemName asNumber. 242364 (index between: 1 and: model basicSize) ifTrue: [ item := model basicAt: index]] 242365 ] on: Error do: [ :ex | item := nil ]! ! 242366 242367 242368!ObjectExplorerWrapper methodsFor: 'nil' stamp: 'sge 4/12/2001 08:24'! 242369asString 242370 | explorerString string | 242371 explorerString := 242372 [item asExplorerString] 242373 on: Error 242374 do: ['<error in asExplorerString: evaluate "' , itemName , ' asExplorerString" to debug>']. 242375 string := itemName , ': ' , explorerString. 242376 (string includes: Character cr) 242377 ifTrue: [^ string withSeparatorsCompacted]. 242378 ^ string! ! 242379 242380"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 242381 242382ObjectExplorerWrapper class 242383 instanceVariableNames: ''! 242384 242385!ObjectExplorerWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 10:50'! 242386with: anObject name: aString model: aModel 242387 242388 ^self new 242389 setItem: anObject name: aString model: aModel! ! 242390 242391!ObjectExplorerWrapper class methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:16'! 242392with: anObject name: aString model: aModel parent: aParent 242393 242394 ^self new 242395 setItem: anObject name: aString model: aModel parent: aParent 242396! ! 242397Object subclass: #ObjectFinalizer 242398 instanceVariableNames: 'receiver selector arguments' 242399 classVariableNames: '' 242400 poolDictionaries: '' 242401 category: 'System-Finalization'! 242402 242403!ObjectFinalizer methodsFor: 'finalization' stamp: 'ar 5/19/2003 20:13'! 242404finalize 242405 "Finalize the resource associated with the receiver. This message should only be sent during the finalization process. There is NO garantuee that the resource associated with the receiver hasn't been free'd before so take care that you don't run into trouble - this all may happen with interrupt priority." 242406 [receiver perform: selector withArguments: arguments] 242407 on: Error do:[:ex| ex return]. 242408! ! 242409 242410 242411!ObjectFinalizer methodsFor: 'initialize' stamp: 'ar 5/19/2003 20:12'! 242412receiver: aReceiver selector: aSelector argument: anObject 242413 receiver := aReceiver. 242414 selector := aSelector. 242415 arguments := Array with: anObject! ! 242416TestCase subclass: #ObjectFinalizerTests 242417 instanceVariableNames: '' 242418 classVariableNames: '' 242419 poolDictionaries: '' 242420 category: 'Tests-Finalization'! 242421 242422 242423 242424!ObjectFinalizerTests methodsFor: 'tests' stamp: 'nice 9/26/2008 01:30'! 242425testFinalizationOfEquals 242426 "self run: #testFinalizationOfEquals" 242427 242428 | finalizationProbe o1 o2 242429 forAnyTwoEqualObjects 242430 ofDifferentIdentity 242431 registeringAnActionAtFinalizationForEachObject 242432 thenForcingFinalizationOfObjects 242433 implyBothRegisteredActionsAreExecuted | 242434 242435 finalizationProbe := Set new. 242436 o1 := 'hello' copy. 242437 o2 := 'hello' copy. 242438 forAnyTwoEqualObjects := [o1 = o2]. 242439 ofDifferentIdentity := [o1 ~~ o2]. 242440 registeringAnActionAtFinalizationForEachObject := [ 242441 o1 toFinalizeSend: #add: to: finalizationProbe with: 'first object finalized'. 242442 o2 toFinalizeSend: #add: to: finalizationProbe with: 'second object finalized']. 242443 thenForcingFinalizationOfObjects := [ 242444 o1 := o2 := nil. Smalltalk garbageCollect]. 242445 implyBothRegisteredActionsAreExecuted := [finalizationProbe size = 2]. 242446 242447 self 242448 assert: forAnyTwoEqualObjects; 242449 assert: ofDifferentIdentity; 242450 should: [ 242451 registeringAnActionAtFinalizationForEachObject value. 242452 thenForcingFinalizationOfObjects value. 242453 implyBothRegisteredActionsAreExecuted value].! ! 242454 242455 242456!ObjectFinalizerTests methodsFor: 'as yet unclassified' stamp: 'AdrianLienhard 10/19/2009 14:33'! 242457expectedFailures 242458 "This is the new test from mantis but it fails. We need to figure out why..." 242459 242460 ^ #(testFinalizationOfEquals)! ! 242461Object subclass: #ObjectScanner 242462 instanceVariableNames: 'pvt3SmartRefStrm' 242463 classVariableNames: '' 242464 poolDictionaries: '' 242465 category: 'System-Object Storage'! 242466!ObjectScanner commentStamp: '<historical>' prior: 0! 242467An instance of this class is the compiler's context for filing in a SmartRefStream containing instance-specific classes. When the old name of a new object's class conflicts with an existing class name, install a class var in me. It has the old name but points at the new class. The compiler uses it when compiling the code in the fileIn. Fill the SmartRefStream's renamed class dictionary. 242468 242469An object fileout: 242470!!ObjectScanner new initialize!! "allow me to take control with scanFrom:" 242471 242472Player subclass: Player23 instanceVariableNames: 'foo' classVariableNames: '' 242473 poolDictionaries: nil category: 'Instance Specific'!! 242474 "I prescan this and (self rename: #Player23 toBe: #Player30)" 242475 242476!!Player23 methodsFor: 'all' stamp: 'tk 3/9/98 18:58'!! "actually sent to Player30" 242477foo 242478 ^ foo!! !! 242479 242480!!self smartRefStream!!<binary representation of the objects>!! 242481 242482 242483! 242484 242485 242486!ObjectScanner methodsFor: 'accessing' stamp: 'tk 3/15/98 19:33'! 242487smartRefStream 242488 242489 ^ pvt3SmartRefStrm! ! 242490 242491 242492!ObjectScanner methodsFor: 'initialization' stamp: 'tk 3/15/98 20:17'! 242493clear 242494 "remove all old class vars. They were UniClasses being remapped to aviod a name conflict." 242495 242496 self class classPool keys do: [:key | 242497 self class classPool removeKey: key]. "brute force"! ! 242498 242499!ObjectScanner methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:12'! 242500initialize 242501 "remove all old class vars that are not instance-specific classes being renamed" 242502 242503 super initialize. 242504 self clear. 242505 "Most importantly, return self, so a fileIn will let ObjectScanner seize control. So UniClasses can be remapped. See the transfer of control where ReadWriteStream fileIn calls scanFrom:"! ! 242506 242507 242508!ObjectScanner methodsFor: 'scanning' stamp: 'yo 11/11/2002 10:27'! 242509lookAhead: aChunk 242510 "See if this chunk is a class Definition, and if the new class name already exists and is instance-specific. Modify the chunk, and record the rename in the SmartRefStream and in me." 242511 242512 | pieces sup oldName existing newName newDefn | 242513 aChunk size < 90 ifTrue: [^ aChunk]. "class defn is big!!" 242514 (aChunk at: 1) == $!! ifTrue: [^ aChunk]. "method def, fast exit" 242515 pieces := (aChunk copyFrom: 1 to: (300 min: aChunk size)) findTokens: ' # \' withCRs. 242516 pieces size < 3 ifTrue: [^ aChunk]. "really bigger, but just took front" 242517 (pieces at: 2) = 'subclass:' ifFalse: [^ aChunk]. 242518 sup := Smalltalk at: (pieces at: 1) asSymbol ifAbsent: [^ aChunk]. 242519 sup class class == Metaclass ifFalse: [^ aChunk]. 242520 ((oldName := pieces at: 3) at: 1) canBeGlobalVarInitial ifFalse: [^ aChunk]. 242521 oldName := oldName asSymbol. 242522 (Smalltalk includesKey: oldName) ifFalse: [^ aChunk]. "no conflict" 242523 existing := Smalltalk at: oldName. 242524 (existing isKindOf: Class) ifFalse: [^ aChunk]. "Write over non-class global" 242525 existing isSystemDefined ifTrue: [^ aChunk]. "Go ahead and redefine it!!" 242526 "Is a UniClass" 242527 newName := sup chooseUniqueClassName. 242528 newDefn := aChunk copyReplaceAll: oldName with: newName. 242529 Compiler evaluate: newDefn for: self logged: true. "Create the new class" 242530 self rename: oldName toBe: newName. 242531 ^ newName asString "to be evaluated" 242532! ! 242533 242534!ObjectScanner methodsFor: 'scanning' stamp: 'tk 3/15/98 20:22'! 242535scanFrom: aByteStream 242536 "Sieze control of the fileIn. Put myself in as the context. If any UniClasses (for just one instance) are defined, they will do it through me, and I will look for conflicting class names. If so, install the old name as a class var of me, so the compile will work. Tell my SmartRefStream about renaming the class." 242537 242538 | valWithOddName47 scannerNamed53 chunkNamed117 | 242539 pvt3SmartRefStrm := SmartRefStream on: aByteStream. 242540 aByteStream ascii. 242541 [aByteStream atEnd] whileFalse: 242542 [aByteStream skipSeparators. 242543 valWithOddName47 := (aByteStream peekFor: $!!) 242544 ifTrue: [chunkNamed117 := aByteStream nextChunk. "debug" 242545 scannerNamed53 := Compiler evaluate: chunkNamed117 242546 for: self logged: false. 242547 scannerNamed53 class == self class 242548 ifTrue: ["I already am the scanner for this file"] 242549 ifFalse: [scannerNamed53 scanFrom: aByteStream]] 242550 ifFalse: [chunkNamed117 := aByteStream nextChunk. 242551 chunkNamed117 := self lookAhead: chunkNamed117. 242552 Compiler evaluate: chunkNamed117 for: self logged: true]. 242553 aByteStream skipStyleChunk]. 242554 ^ valWithOddName47! ! 242555 242556 242557!ObjectScanner methodsFor: 'utilities' stamp: 'tk 3/15/98 20:21'! 242558rename: existingName toBe: newName 242559 "See if there is a conflict between what the fileIn wants to call the new UniClass (Player23) and what already exists for another unique instance. If conflict, make a class variable to intercept the existingName and direct it to class newName." 242560 242561 existingName = newName ifFalse: [ 242562 self class ensureClassPool. "create the dictionary" 242563 "can't use addClassVarName: because it checks for conflicts with Smalltalk" 242564 (self class classPool includesKey: existingName) ifFalse: 242565 ["Pick up any refs in Undeclared" 242566 self class classPool declare: existingName from: Undeclared]. 242567 self class classPool at: existingName put: (Smalltalk at: newName). 242568 pvt3SmartRefStrm renamed at: existingName put: newName]! ! 242569Object subclass: #ObjectStringConverter 242570 instanceVariableNames: 'objectClass' 242571 classVariableNames: '' 242572 poolDictionaries: '' 242573 category: 'Polymorph-Widgets'! 242574!ObjectStringConverter commentStamp: 'gvc 5/18/2007 12:43' prior: 0! 242575Generic object<->string converter for use with PluggableTextFieldMorph. #next: and #previous: unused at present.! 242576 242577 242578!ObjectStringConverter methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 08:55'! 242579isStringValid: aString 242580 "Answer whether the given string is valid for conversion." 242581 242582 ^true! ! 242583 242584!ObjectStringConverter methodsFor: 'as yet unclassified' stamp: 'gvc 9/25/2006 13:20'! 242585needsConversion 242586 "Answer whether conversion is required for the receiver's object class." 242587 242588 ^(self objectClass includesBehavior: String) not! ! 242589 242590!ObjectStringConverter methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 15:24'! 242591next: aString 242592 "Answer the next item (upwards)." 242593 242594 self subclassResponsibility! ! 242595 242596!ObjectStringConverter methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 12:06'! 242597objectAsString: anObject 242598 "Answer the given object in string form." 242599 242600 ^anObject asString! ! 242601 242602!ObjectStringConverter methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 12:10'! 242603objectClass 242604 "Answer the class of object we are dealing with." 242605 242606 ^objectClass! ! 242607 242608!ObjectStringConverter methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 14:09'! 242609objectClass: aClass 242610 "Set the class of object we are dealing with." 242611 242612 objectClass := aClass! ! 242613 242614!ObjectStringConverter methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 15:25'! 242615previous: aString 242616 "Answer the previous item (downwards)." 242617 242618 self subclassResponsibility! ! 242619 242620!ObjectStringConverter methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 12:47'! 242621stringAsObject: aString 242622 "Answer the given string in object form." 242623 242624 ^self needsConversion 242625 ifTrue: [self objectClass readFromString: aString] 242626 ifFalse: [aString]! ! 242627 242628"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 242629 242630ObjectStringConverter class 242631 instanceVariableNames: ''! 242632 242633!ObjectStringConverter class methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 12:11'! 242634forClass: aClass 242635 "Answer a new instance of the receiver that converts to and from 242636 the given class of object and a string." 242637 242638 ^self new objectClass: aClass! ! 242639ClassTestCase subclass: #ObjectTest 242640 instanceVariableNames: '' 242641 classVariableNames: '' 242642 poolDictionaries: '' 242643 category: 'KernelTests-Objects'! 242644 242645!ObjectTest methodsFor: 'tests' stamp: 'md 11/26/2004 16:37'! 242646testBecome 242647 "self debug: #testBecome" 242648 "this test should that all the variables pointing to an object are pointing now to another one, and all 242649 object pointing to the other are pointing to the object" 242650 242651 | pt1 pt2 pt3 | 242652 pt1 := 0@0. 242653 pt2 := pt1. 242654 pt3 := 100@100. 242655 242656 pt1 become: pt3. 242657 self assert: pt2 = (100@100). 242658 self assert: pt3 = (0@0). 242659 self assert: pt1 = (100@100).! ! 242660 242661!ObjectTest methodsFor: 'tests' stamp: 'md 11/26/2004 16:36'! 242662testBecomeForward 242663 "self debug: #testBecomeForward" 242664 "this test should that all the variables pointing to an object are pointing now to another one. 242665 Not that this inverse is not true. This kind of become is called oneWayBecome in VW" 242666 242667 | pt1 pt2 pt3 | 242668 pt1 := 0@0. 242669 pt2 := pt1. 242670 pt3 := 100@100. 242671 pt1 becomeForward: pt3. 242672 self assert: pt2 = (100@100). 242673 self assert: pt3 == pt2. 242674 self assert: pt1 = (100@100)! ! 242675 242676 242677!ObjectTest methodsFor: 'tests - debugging' stamp: 'sd 6/5/2005 09:05'! 242678testAssert 242679 242680 self shouldnt: [Object assert: [true]] raise: Error. 242681 self shouldnt: [Object assert: true] raise: Error. 242682 self should: [Object assert: [false]] raise: AssertionFailure. 242683 self should: [Object assert: false] raise: AssertionFailure.! ! 242684 242685!ObjectTest methodsFor: 'tests - debugging' stamp: 'sd 6/5/2005 09:05'! 242686testHaltIf 242687 242688 self should: [self haltIf: true] raise: Halt. 242689 self shouldnt: [self haltIf: false] raise: Halt. 242690 242691 self should: [self haltIf: [true]] raise: Halt. 242692 self shouldnt: [self haltIf: [false]] raise: Halt. 242693 242694 self should: [self haltIf: #testHaltIf.] raise: Halt. 242695 self shouldnt: [self haltIf: #teadfasdfltIf.] raise: Halt. 242696 242697 self should: [self a] raise: Halt. 242698 self shouldnt: [self a1] raise: Halt. 242699 242700 self should: [self haltIf: [:o | o class = self class]] raise: Halt. 242701 self shouldnt: [self haltIf: [:o | o class ~= self class]] raise: Halt. 242702! ! 242703 242704 242705!ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:45'! 242706a 242707 self b.! ! 242708 242709!ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:46'! 242710a1 242711 self b1.! ! 242712 242713!ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:45'! 242714b 242715 self haltIf: #testHaltIf.! ! 242716 242717!ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:46'! 242718b1 242719 self haltIf: #testasdasdfHaltIf.! ! 242720ProtoObject subclass: #ObjectTracer 242721 instanceVariableNames: 'tracedObject recursionFlag' 242722 classVariableNames: '' 242723 poolDictionaries: '' 242724 category: 'Kernel-Objects'. 242725ObjectTracer superclass: nil! 242726!ObjectTracer commentStamp: '<historical>' prior: 0! 242727An ObjectTracer can be wrapped around another object, and then give you a chance to inspect it whenever it receives messages from the outside. For instance... 242728 (ObjectTracer on: Display) flash: (50@50 extent: 50@50) 242729will give control to a debugger just before the message flash is sent. 242730Obviously this facility can be embellished in many useful ways. 242731See also the even more perverse subclass, ObjectViewer, and its example. 242732! 242733 242734 242735!ObjectTracer methodsFor: 'very few messages' stamp: 'ar 9/27/2005 20:24'! 242736doesNotUnderstand: aMessage 242737 "All external messages (those not caused by the re-send) get trapped here" 242738 "Present a dubugger before proceeding to re-send the message" 242739 242740 ToolSet debugContext: thisContext 242741 label: 'About to perform: ', aMessage selector 242742 contents: nil. 242743 ^ aMessage sentTo: tracedObject. 242744! ! 242745 242746!ObjectTracer methodsFor: 'very few messages'! 242747xxxUnTrace 242748 242749 tracedObject become: self! ! 242750 242751!ObjectTracer methodsFor: 'very few messages'! 242752xxxViewedObject 242753 "This message name must not clash with any other (natch)." 242754 ^ tracedObject! ! 242755 242756!ObjectTracer methodsFor: 'very few messages'! 242757xxxViewedObject: anObject 242758 "This message name must not clash with any other (natch)." 242759 tracedObject := anObject! ! 242760 242761"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 242762 242763ObjectTracer class 242764 instanceVariableNames: ''! 242765 242766!ObjectTracer class methodsFor: 'instance creation'! 242767on: anObject 242768 ^ self new xxxViewedObject: anObject! ! 242769ObjectStringConverter subclass: #ObjectTransformedStringConverter 242770 instanceVariableNames: 'transformBlock' 242771 classVariableNames: '' 242772 poolDictionaries: '' 242773 category: 'Polymorph-Widgets'! 242774 242775!ObjectTransformedStringConverter methodsFor: 'accessing' stamp: 'gvc 8/27/2009 17:07'! 242776transformBlock 242777 "Answer the value of transformBlock" 242778 242779 ^ transformBlock! ! 242780 242781!ObjectTransformedStringConverter methodsFor: 'accessing' stamp: 'gvc 8/27/2009 17:07'! 242782transformBlock: anObject 242783 "Set the value of transformBlock" 242784 242785 transformBlock := anObject! ! 242786 242787 242788!ObjectTransformedStringConverter methodsFor: 'as yet unclassified' stamp: 'gvc 8/27/2009 17:07'! 242789initialize 242790 "Initialize the receiver." 242791 242792 super initialize. 242793 self 242794 transformBlock: [:string | string]! ! 242795 242796!ObjectTransformedStringConverter methodsFor: 'as yet unclassified' stamp: 'gvc 8/27/2009 17:07'! 242797stringAsObject: aString 242798 "Answer the given string in object form." 242799 242800 ^super stringAsObject: (self transformBlock value: aString)! ! 242801ObjectTracer subclass: #ObjectViewer 242802 instanceVariableNames: 'valueBlock lastValue changeBlock' 242803 classVariableNames: '' 242804 poolDictionaries: '' 242805 category: 'Kernel-Objects'! 242806!ObjectViewer commentStamp: '<historical>' prior: 0! 242807ObjectViewers offers the same kind of interception of messages (via doesnotUnderstand:) as ObjectTracers, but instead of just being wrappers, they actually replace the object being viewed. This makes them a lot more dangerous to use, but one can do amazing things. For instance, the example below actually intercepts the InputSensor object, and prints the mouse coordinates asynchronously, every time they change: 242808 Sensor evaluate: [Sensor cursorPoint printString displayAt: 0@0] 242809 wheneverChangeIn: [Sensor cursorPoint]. 242810To exit from this example, execute: 242811 Sensor xxxUnTrace 242812! 242813 242814 242815!ObjectViewer methodsFor: 'very few messages'! 242816doesNotUnderstand: aMessage 242817 "Check for change after sending aMessage" 242818 | returnValue newValue | 242819 recursionFlag ifTrue: [^ aMessage sentTo: tracedObject]. 242820 recursionFlag := true. 242821 returnValue := aMessage sentTo: tracedObject. 242822 newValue := valueBlock value. 242823 newValue = lastValue ifFalse: 242824 [changeBlock value. 242825 lastValue := newValue]. 242826 recursionFlag := false. 242827 ^ returnValue! ! 242828 242829!ObjectViewer methodsFor: 'very few messages'! 242830xxxViewedObject: viewedObject evaluate: block1 wheneverChangeIn: block2 242831 "This message name must not clash with any other (natch)." 242832 tracedObject := viewedObject. 242833 valueBlock := block2. 242834 changeBlock := block1. 242835 recursionFlag := false! ! 242836 242837"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 242838 242839ObjectViewer class 242840 instanceVariableNames: ''! 242841 242842!ObjectViewer class methodsFor: 'instance creation'! 242843on: viewedObject evaluate: block1 wheneverChangeIn: block2 242844 ^ self new xxxViewedObject: viewedObject evaluate: block1 wheneverChangeIn: block2! ! 242845Object subclass: #ObjectWithDocumentation 242846 instanceVariableNames: 'authoringStamp properties elementSymbol naturalLanguageTranslations' 242847 classVariableNames: '' 242848 poolDictionaries: '' 242849 category: 'Tools-Changes'! 242850!ObjectWithDocumentation commentStamp: '<historical>' prior: 0! 242851ObjectWithDocumentation - an abstract superclass for objects that allows maintenance of an authoring stamp, a body of documentation, and a properties dictionary. 242852The Properties implementation has not happened yet -- it would closely mirror the implemenation of properties in the MorphExtension, for example.! 242853 242854 242855!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 21:21'! 242856documentation 242857 "Answer the receiver's documentation" 242858 242859 ^self helpMessage! ! 242860 242861!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 19:33'! 242862documentation: somethingUsefulHopefully 242863 "Set the receiver's documentation, in the current langauge" 242864 242865 self helpMessage: somethingUsefulHopefully! ! 242866 242867!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'sw 8/18/2004 20:23'! 242868helpMessage 242869 "Check if there is a getterSetterHelpMessage. 242870 Otherwise try the normal help message or return nil." 242871 242872 ^ self getterSetterHelpMessage 242873 ifNil: [(self propertyAt: #helpMessage ifAbsent: 242874 [self legacyHelpMessage ifNil: [^ nil]]) translated]! ! 242875 242876!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 19:32'! 242877helpMessage: somethingUsefulHopefully 242878 "Set the receiver's documentation, in the current langauge" 242879 242880 self propertyAt: #helpMessage put: somethingUsefulHopefully! ! 242881 242882!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:39'! 242883legacyHelpMessage 242884 "If I have a help message stashed in my legacy naturalTranslations slot, answer its translated rendition, else answer nil. If I *do* come across a legacy help message, transfer it to my properties dictionary." 242885 242886 | untranslated | 242887 naturalLanguageTranslations isEmptyOrNil "only in legacy (pre-3.8) projects" 242888 ifTrue: [^ nil]. 242889 untranslated := naturalLanguageTranslations first helpMessage ifNil: [^ nil]. 242890 self propertyAt: #helpMessage put: untranslated. 242891 naturalLanguageTranslations removeFirst. 242892 naturalLanguageTranslations isEmpty ifTrue: [naturalLanguageTranslations := nil]. 242893 ^ untranslated translated! ! 242894 242895!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 21:34'! 242896wording 242897 "Answer the receiver's wording" 242898 242899 | wording | 242900 (wording := self propertyAt: #wording ifAbsent: [nil]) 242901 ifNotNil: [^wording translated]. 242902 242903 self initWordingAndDocumentation. 242904 ^self propertyAt: #wording ifAbsent: ['']! ! 242905 242906!ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 21:39'! 242907wording: aString 242908 "Set the receiver's wording, in the current langauge" 242909 242910 self propertyAt: #wording put: aString! ! 242911 242912 242913!ObjectWithDocumentation methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:12'! 242914initialize 242915 "Initialize the receiver (automatically called when instances are created via 'new')" 242916 242917 super initialize. 242918 authoringStamp := Utilities changeStampPerSe 242919! ! 242920 242921 242922!ObjectWithDocumentation methodsFor: 'miscellaneous' stamp: 'sw 9/12/2001 23:03'! 242923elementSymbol 242924 "Answer the receiver's element symbol" 242925 242926 ^ elementSymbol! ! 242927 242928 242929!ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 21:28'! 242930getterSetterHelpMessage 242931 "Returns a helpMessage that has been computed previously and needs to be translated and then formatted with the elementSymbol. 242932 'get value of {1}' translated format: {elSym}" 242933 242934 ^(self propertyAt: #getterSetterHelpMessage ifAbsent: [^nil]) 242935 translated format: {self elementSymbol}! ! 242936 242937!ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 21:29'! 242938getterSetterHelpMessage: aString 242939 "Sets a helpMessage that needs to be translated and then formatted with the elementSymbol. 242940 'get value of {1}' translated format: {elSym}" 242941 242942 self propertyAt: #getterSetterHelpMessage put: aString! ! 242943 242944!ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 21:31'! 242945initWordingAndDocumentation 242946 "Initialize wording and documentation (helpMessage) for getters and setters" 242947 242948 | elSym | 242949 elSym := self elementSymbol. 242950 elSym 242951 ifNil: [^self]. 242952 242953 ((elSym beginsWith: 'get') 242954 and: [elSym size > 3]) 242955 ifTrue: [ 242956 self wording: (elSym allButFirst: 3) withFirstCharacterDownshifted. 242957 self getterSetterHelpMessage: 'get value of {1}'] 242958 ifFalse: [ 242959 ((elSym beginsWith: 'set') 242960 and: [elSym size > 4]) 242961 ifTrue: [ 242962 self wording: (elSym allButFirst: 3) withFirstCharacterDownshifted. 242963 self getterSetterHelpMessage: 'set value of {1}']]! ! 242964 242965!ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 19:30'! 242966properties 242967 ^properties ifNil: [properties := Dictionary new]! ! 242968 242969!ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 19:29'! 242970propertyAt: key ifAbsent: aBlock 242971 ^properties 242972 ifNil: aBlock 242973 ifNotNil: [properties at: key ifAbsent: aBlock]! ! 242974 242975!ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 19:29'! 242976propertyAt: key put: aValue 242977 self properties at: key put: aValue! ! 242978AbstractObjectsAsMethod subclass: #ObjectsAsMethodsExample 242979 instanceVariableNames: '' 242980 classVariableNames: '' 242981 poolDictionaries: '' 242982 category: 'Tests-ObjectsAsMethods'! 242983 242984!ObjectsAsMethodsExample methodsFor: 'as yet unclassified' stamp: 'ar 5/17/2003 20:16'! 242985add: a with: b 242986 ^a + b! ! 242987 242988!ObjectsAsMethodsExample methodsFor: 'as yet unclassified' stamp: 'ar 5/17/2003 20:16'! 242989answer42 242990 ^42! ! 242991 242992!ObjectsAsMethodsExample methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 19:37'! 242993run: oldSelector with: arguments in: aReceiver 242994 ^self perform: oldSelector withArguments: arguments! ! 242995URI subclass: #OpaqueURI 242996 instanceVariableNames: '' 242997 classVariableNames: '' 242998 poolDictionaries: '' 242999 category: 'Network-URI'! 243000 243001!OpaqueURI methodsFor: 'testing' stamp: 'mir 2/20/2002 16:55'! 243002isOpaque 243003 ^true! ! 243004SequenceableCollection subclass: #OrderedCollection 243005 instanceVariableNames: 'array firstIndex lastIndex' 243006 classVariableNames: '' 243007 poolDictionaries: '' 243008 category: 'Collections-Sequenceable'! 243009!OrderedCollection commentStamp: '<historical>' prior: 0! 243010I represent a collection of objects ordered by the collector.! 243011 243012 243013!OrderedCollection methodsFor: '*splitjoin' stamp: 'onierstrasz 4/12/2009 19:44'! 243014join: aCollection 243015 | result | 243016 result := self class new. 243017 aCollection 243018 do: [:each | each appendTo: result] 243019 separatedBy: [self appendTo: result]. 243020 ^ result! ! 243021 243022 243023!OrderedCollection methodsFor: '*tools-inspector' stamp: 'ar 9/27/2005 18:33'! 243024inspectorClass 243025 "Answer the class of the inspector to be used on the receiver. Called by inspect; 243026 use basicInspect to get a normal (less useful) type of inspector." 243027 243028 ^OrderedCollectionInspector! ! 243029 243030 243031!OrderedCollection methodsFor: 'accessing'! 243032at: anInteger 243033 "Answer my element at index anInteger. at: is used by a knowledgeable 243034 client to access an existing element" 243035 243036 (anInteger < 1 or: [anInteger + firstIndex - 1 > lastIndex]) 243037 ifTrue: [self errorNoSuchElement] 243038 ifFalse: [^ array at: anInteger + firstIndex - 1]! ! 243039 243040!OrderedCollection methodsFor: 'accessing'! 243041at: anInteger put: anObject 243042 "Put anObject at element index anInteger. at:put: cannot be used to 243043 append, front or back, to an ordered collection; it is used by a 243044 knowledgeable client to replace an element." 243045 243046 | index | 243047 index := anInteger asInteger. 243048 (index < 1 or: [index + firstIndex - 1 > lastIndex]) 243049 ifTrue: [self errorNoSuchElement] 243050 ifFalse: [^array at: index + firstIndex - 1 put: anObject]! ! 243051 243052!OrderedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:42'! 243053capacity 243054 "Answer the current capacity of the receiver." 243055 243056 ^ array size! ! 243057 243058!OrderedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:39'! 243059size 243060 "Answer how many elements the receiver contains." 243061 243062 ^ lastIndex - firstIndex + 1! ! 243063 243064 243065!OrderedCollection methodsFor: 'adding'! 243066add: newObject 243067 243068 ^self addLast: newObject! ! 243069 243070!OrderedCollection methodsFor: 'adding'! 243071add: newObject after: oldObject 243072 "Add the argument, newObject, as an element of the receiver. Put it in 243073 the sequence just succeeding oldObject. Answer newObject." 243074 243075 | index | 243076 index := self find: oldObject. 243077 self insert: newObject before: index + 1. 243078 ^newObject! ! 243079 243080!OrderedCollection methodsFor: 'adding' stamp: 'ar 7/15/2008 23:03'! 243081add: newObject afterIndex: index 243082 "Add the argument, newObject, as an element of the receiver. Put it in 243083 the sequence just after index. Answer newObject." 243084 (index between: 0 and: self size) ifFalse:[^self errorSubscriptBounds: index]. 243085 self insert: newObject before: firstIndex + index. 243086 ^ newObject! ! 243087 243088!OrderedCollection methodsFor: 'adding'! 243089add: newObject before: oldObject 243090 "Add the argument, newObject, as an element of the receiver. Put it in 243091 the sequence just preceding oldObject. Answer newObject." 243092 243093 | index | 243094 index := self find: oldObject. 243095 self insert: newObject before: index. 243096 ^newObject! ! 243097 243098!OrderedCollection methodsFor: 'adding' stamp: 'ar 7/15/2008 23:05'! 243099add: newObject beforeIndex: index 243100 "Add the argument, newObject, as an element of the receiver. Put it in 243101 the sequence just before index. Answer newObject." 243102 (index between: 1 and: self size+1) ifFalse:[^self errorSubscriptBounds: index]. 243103 self insert: newObject before: firstIndex + index - 1. 243104 ^ newObject! ! 243105 243106!OrderedCollection methodsFor: 'adding' stamp: 'sma 5/12/2000 11:26'! 243107addAll: aCollection 243108 "Add each element of aCollection at my end. Answer aCollection." 243109 243110 ^ self addAllLast: aCollection! ! 243111 243112!OrderedCollection methodsFor: 'adding'! 243113addAllFirst: anOrderedCollection 243114 "Add each element of anOrderedCollection at the beginning of the 243115 receiver. Answer anOrderedCollection." 243116 243117 anOrderedCollection reverseDo: [:each | self addFirst: each]. 243118 ^anOrderedCollection! ! 243119 243120!OrderedCollection methodsFor: 'adding' stamp: 'sw 3/1/2001 11:03'! 243121addAllFirstUnlessAlreadyPresent: anOrderedCollection 243122 "Add each element of anOrderedCollection at the beginning of the receiver, preserving the order, but do not add any items that are already in the receiver. Answer anOrderedCollection." 243123 243124 anOrderedCollection reverseDo: 243125 [:each | (self includes: each) ifFalse: [self addFirst: each]]. 243126 ^ anOrderedCollection! ! 243127 243128!OrderedCollection methodsFor: 'adding'! 243129addAllLast: anOrderedCollection 243130 "Add each element of anOrderedCollection at the end of the receiver. 243131 Answer anOrderedCollection." 243132 243133 anOrderedCollection do: [:each | self addLast: each]. 243134 ^anOrderedCollection! ! 243135 243136!OrderedCollection methodsFor: 'adding'! 243137addFirst: newObject 243138 "Add newObject to the beginning of the receiver. Answer newObject." 243139 243140 firstIndex = 1 ifTrue: [self makeRoomAtFirst]. 243141 firstIndex := firstIndex - 1. 243142 array at: firstIndex put: newObject. 243143 ^ newObject! ! 243144 243145!OrderedCollection methodsFor: 'adding'! 243146addLast: newObject 243147 "Add newObject to the end of the receiver. Answer newObject." 243148 243149 lastIndex = array size ifTrue: [self makeRoomAtLast]. 243150 lastIndex := lastIndex + 1. 243151 array at: lastIndex put: newObject. 243152 ^ newObject! ! 243153 243154!OrderedCollection methodsFor: 'adding' stamp: 'ajh 5/22/2003 12:03'! 243155at: index ifAbsentPut: block 243156 "Return value at index, however, if value does not exist (nil or out of bounds) then add block's value at index (growing self if necessary)" 243157 243158 | v | 243159 index <= self size ifTrue: [ 243160 ^ (v := self at: index) 243161 ifNotNil: [v] 243162 ifNil: [self at: index put: block value] 243163 ]. 243164 [self size < index] whileTrue: [self add: nil]. 243165 ^ self at: index put: block value! ! 243166 243167!OrderedCollection methodsFor: 'adding'! 243168grow 243169 "Become larger. Typically, a subclass has to override this if the subclass 243170 adds instance variables." 243171 | newArray | 243172 newArray := Array new: self size + self growSize. 243173 newArray replaceFrom: 1 to: array size with: array startingAt: 1. 243174 array := newArray! ! 243175 243176!OrderedCollection methodsFor: 'adding'! 243177growSize 243178 ^ array size max: 2! ! 243179 243180 243181!OrderedCollection methodsFor: 'converting' stamp: 'stephane.ducasse 8/8/2009 10:48'! 243182asArray 243183 ^ (Array new: self size) replaceFrom: 1 to: self size with: array startingAt: firstIndex.! ! 243184 243185 243186!OrderedCollection methodsFor: 'copying'! 243187copyEmpty 243188 "Answer a copy of the receiver that contains no elements." 243189 243190 ^self species new! ! 243191 243192!OrderedCollection methodsFor: 'copying' stamp: 'nice 5/22/2008 10:43'! 243193copyFrom: startIndex to: endIndex 243194 "Answer a copy of the receiver that contains elements from position 243195 startIndex to endIndex. " 243196 243197 "cannot call shallowCopy because shallowCopy calls copyFrom:to:" 243198 ^self basicShallowCopy postCopyFrom: startIndex to: endIndex ! ! 243199 243200!OrderedCollection methodsFor: 'copying'! 243201copyReplaceFrom: start to: stop with: replacementCollection 243202 "Answer a copy of the receiver with replacementCollection's elements in 243203 place of the receiver's start'th to stop'th elements. This does not expect 243204 a 1-1 map from replacementCollection to the start to stop elements, so it 243205 will do an insert or append." 243206 243207 | newOrderedCollection delta startIndex stopIndex | 243208 "if start is less than 1, ignore stop and assume this is inserting at the front. 243209 if start greater than self size, ignore stop and assume this is appending. 243210 otherwise, it is replacing part of me and start and stop have to be within my 243211 bounds. " 243212 delta := 0. 243213 startIndex := start. 243214 stopIndex := stop. 243215 start < 1 243216 ifTrue: [startIndex := stopIndex := 0] 243217 ifFalse: [startIndex > self size 243218 ifTrue: [startIndex := stopIndex := self size + 1] 243219 ifFalse: 243220 [(stopIndex < (startIndex - 1) or: [stopIndex > self size]) 243221 ifTrue: [self errorOutOfBounds]. 243222 delta := stopIndex - startIndex + 1]]. 243223 newOrderedCollection := 243224 self species new: self size + replacementCollection size - delta. 243225 1 to: startIndex - 1 do: [:index | newOrderedCollection add: (self at: index)]. 243226 1 to: replacementCollection size do: 243227 [:index | newOrderedCollection add: (replacementCollection at: index)]. 243228 stopIndex + 1 to: self size do: [:index | newOrderedCollection add: (self at: index)]. 243229 ^newOrderedCollection! ! 243230 243231!OrderedCollection methodsFor: 'copying'! 243232copyWith: newElement 243233 "Answer a copy of the receiver that is 1 bigger than the receiver and 243234 includes the argument, newElement, at the end." 243235 243236 | newCollection | 243237 newCollection := self copy. 243238 newCollection add: newElement. 243239 ^newCollection! ! 243240 243241!OrderedCollection methodsFor: 'copying' stamp: 'nice 5/28/2008 21:02'! 243242postCopyFrom: startIndex to: endIndex 243243 "finish copying the array in a certain range." 243244 243245 endIndex < startIndex ifFalse: [ 243246 "Because actual size of the array may be greater than used size, 243247 postCopyFrom:to: may fail to fail and answer an incorrect result 243248 if this sanity check were not applied" 243249 (startIndex between: 1 and: self size) ifFalse: [^self error: 'startIndex is out of bounds']. 243250 (endIndex between: 1 and: self size) ifFalse: [^self error: 'endIndex is out of bounds']]. 243251 243252 "Add a protection that lacks in Array>>postcopy" 243253 array := array copyFrom: startIndex + firstIndex - 1 to: (endIndex max: startIndex - 1) + firstIndex - 1. 243254 firstIndex := 1. 243255 lastIndex := array size! ! 243256 243257!OrderedCollection methodsFor: 'copying' stamp: 'sw 1/26/96'! 243258reversed 243259 "Answer a copy of the receiver with element order reversed. " 243260 | newCol | 243261 newCol := self species new. 243262 self reverseDo: 243263 [:elem | newCol addLast: elem]. 243264 ^ newCol 243265 243266"#(2 3 4 'fred') reversed"! ! 243267 243268 243269!OrderedCollection methodsFor: 'enumerating' stamp: 'sma 2/5/2000 15:22'! 243270collect: aBlock 243271 "Evaluate aBlock with each of my elements as the argument. Collect the 243272 resulting values into a collection that is like me. Answer the new 243273 collection. Override superclass in order to use addLast:, not at:put:." 243274 243275 | newCollection | 243276 newCollection := self species new: self size. 243277 firstIndex to: lastIndex do: 243278 [:index | 243279 newCollection addLast: (aBlock value: (array at: index))]. 243280 ^ newCollection! ! 243281 243282!OrderedCollection methodsFor: 'enumerating' stamp: 'bf 5/18/2000 17:34'! 243283collect: aBlock from: fromIndex to: toIndex 243284 "Override superclass in order to use addLast:, not at:put:." 243285 | result | 243286 (fromIndex < 1 or:[toIndex + firstIndex - 1 > lastIndex]) 243287 ifTrue: [^self errorNoSuchElement]. 243288 result := self species new: toIndex - fromIndex + 1. 243289 firstIndex + fromIndex - 1 to: firstIndex + toIndex - 1 do: 243290 [:index | result addLast: (aBlock value: (array at: index))]. 243291 ^ result 243292! ! 243293 243294!OrderedCollection methodsFor: 'enumerating' stamp: 'hfm 2/12/2009 13:28'! 243295collect: collectBlock thenSelect: selectBlock 243296 " Utility method to improve readability. 243297 Do not create the intermediate collection." 243298 243299 | newCollection | 243300 243301 newCollection := self copyEmpty. 243302 firstIndex to: lastIndex do:[: index | 243303 | newElement | 243304 newElement := collectBlock value: ( array at: index ). 243305 ( selectBlock value: newElement ) 243306 ifTrue:[ newCollection addLast: newElement. ] 243307 ]. 243308 ^ newCollection! ! 243309 243310!OrderedCollection methodsFor: 'enumerating'! 243311do: aBlock 243312 "Override the superclass for performance reasons." 243313 | index | 243314 index := firstIndex. 243315 [index <= lastIndex] 243316 whileTrue: 243317 [aBlock value: (array at: index). 243318 index := index + 1]! ! 243319 243320!OrderedCollection methodsFor: 'enumerating'! 243321reverseDo: aBlock 243322 "Override the superclass for performance reasons." 243323 | index | 243324 index := lastIndex. 243325 [index >= firstIndex] 243326 whileTrue: 243327 [aBlock value: (array at: index). 243328 index := index - 1]! ! 243329 243330!OrderedCollection methodsFor: 'enumerating' stamp: 'sma 2/5/2000 15:13'! 243331select: aBlock 243332 "Evaluate aBlock with each of my elements as the argument. Collect into 243333 a new collection like the receiver, only those elements for which aBlock 243334 evaluates to true." 243335 243336 | newCollection element | 243337 newCollection := self copyEmpty. 243338 firstIndex to: lastIndex do: 243339 [:index | 243340 (aBlock value: (element := array at: index)) 243341 ifTrue: [newCollection addLast: element]]. 243342 ^ newCollection! ! 243343 243344!OrderedCollection methodsFor: 'enumerating' stamp: 'hfm 2/12/2009 13:30'! 243345select: selectBlock thenCollect: collectBlock 243346 " Utility method to improve readability. 243347 Do not create the intermediate collection. " 243348 243349 | newCollection | 243350 243351 newCollection := self copyEmpty. 243352 firstIndex to: lastIndex do:[:index | 243353 | element | 243354 element := array at: index. 243355 ( selectBlock value: element ) 243356 ifTrue:[ newCollection addLast: ( collectBlock value: element ) ] 243357 ]. 243358 ^ newCollection! ! 243359 243360!OrderedCollection methodsFor: 'enumerating' stamp: 'di 8/31/1999 13:13'! 243361with: otherCollection collect: twoArgBlock 243362 "Collect and return the result of evaluating twoArgBlock with 243363 corresponding elements from this collection and otherCollection." 243364 | result | 243365 otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size']. 243366 result := self species new: self size. 243367 1 to: self size do: 243368 [:index | result addLast: (twoArgBlock value: (self at: index) 243369 value: (otherCollection at: index))]. 243370 ^ result! ! 243371 243372!OrderedCollection methodsFor: 'enumerating' stamp: 'bf 5/16/2000 16:30'! 243373withIndexCollect: elementAndIndexBlock 243374 "Just like with:collect: except that the iteration index supplies the second argument to the block. Override superclass in order to use addLast:, not at:put:." 243375 243376 | newCollection | 243377 newCollection := self species new: self size. 243378 firstIndex to: lastIndex do: 243379 [:index | 243380 newCollection addLast: (elementAndIndexBlock 243381 value: (array at: index) 243382 value: index - firstIndex + 1)]. 243383 ^ newCollection! ! 243384 243385 243386!OrderedCollection methodsFor: 'removing'! 243387remove: oldObject ifAbsent: absentBlock 243388 243389 | index | 243390 index := firstIndex. 243391 [index <= lastIndex] 243392 whileTrue: 243393 [oldObject = (array at: index) 243394 ifTrue: 243395 [self removeIndex: index. 243396 ^ oldObject] 243397 ifFalse: [index := index + 1]]. 243398 ^ absentBlock value! ! 243399 243400!OrderedCollection methodsFor: 'removing' stamp: 'nice 12/30/2008 18:44'! 243401removeAll 243402 "remove all the elements from this collection. 243403 Keep same amount of storage" 243404 243405 self setCollection: (Array new: array size)! ! 243406 243407!OrderedCollection methodsFor: 'removing' stamp: 'raok 4/27/2001 15:35'! 243408removeAllSuchThat: aBlock 243409 "Remove each element of the receiver for which aBlock evaluates to true. 243410 The method in Collection is O(N^2), this is O(N)." 243411 243412 | n | 243413 n := firstIndex. 243414 firstIndex to: lastIndex do: [:index | 243415 (aBlock value: (array at: index)) ifFalse: [ 243416 array at: n put: (array at: index). 243417 n := n + 1]]. 243418 n to: lastIndex do: [:index | array at: index put: nil]. 243419 lastIndex := n - 1! ! 243420 243421!OrderedCollection methodsFor: 'removing' stamp: 'ar 5/22/2000 12:19'! 243422removeAt: index 243423 | removed | 243424 removed := self at: index. 243425 self removeIndex: index + firstIndex - 1. 243426 ^removed! ! 243427 243428!OrderedCollection methodsFor: 'removing'! 243429removeFirst 243430 "Remove the first element of the receiver and answer it. If the receiver is 243431 empty, create an error notification." 243432 | firstObject | 243433 self emptyCheck. 243434 firstObject := array at: firstIndex. 243435 array at: firstIndex put: nil. 243436 firstIndex := firstIndex + 1. 243437 ^ firstObject! ! 243438 243439!OrderedCollection methodsFor: 'removing' stamp: 'ajh 6/22/2003 14:37'! 243440removeFirst: n 243441 "Remove first n object into an array" 243442 243443 | list | 243444 list := Array new: n. 243445 1 to: n do: [:i | 243446 list at: i put: self removeFirst]. 243447 ^ list! ! 243448 243449!OrderedCollection methodsFor: 'removing'! 243450removeLast 243451 "Remove the last element of the receiver and answer it. If the receiver is 243452 empty, create an error notification." 243453 | lastObject | 243454 self emptyCheck. 243455 lastObject := array at: lastIndex. 243456 array at: lastIndex put: nil. 243457 lastIndex := lastIndex - 1. 243458 ^ lastObject! ! 243459 243460!OrderedCollection methodsFor: 'removing' stamp: 'ajh 6/22/2003 14:36'! 243461removeLast: n 243462 "Remove last n object into an array with last in last position" 243463 243464 | list | 243465 list := Array new: n. 243466 n to: 1 by: -1 do: [:i | 243467 list at: i put: self removeLast]. 243468 ^ list! ! 243469 243470 243471!OrderedCollection methodsFor: 'testing' stamp: 'md 8/13/2008 21:40'! 243472hasContentsInExplorer 243473 243474 ^self notEmpty! ! 243475 243476 243477!OrderedCollection methodsFor: 'private'! 243478collector "Private" 243479 ^ array! ! 243480 243481!OrderedCollection methodsFor: 'private'! 243482errorConditionNotSatisfied 243483 243484 self error: 'no element satisfies condition'! ! 243485 243486!OrderedCollection methodsFor: 'private'! 243487errorNoSuchElement 243488 243489 self error: 'attempt to index non-existent element in an ordered collection'! ! 243490 243491!OrderedCollection methodsFor: 'private' stamp: 'BG 1/9/2004 12:26'! 243492find: oldObject 243493 " This method answers an index in the range firstIndex .. lastIndex, which is meant for internal use only. 243494 Never use this method in your code, the methods for public use are: 243495 #indexOf: 243496 #indexOf:ifAbsent: " 243497 243498 | index | 243499 index := firstIndex. 243500 [index <= lastIndex] 243501 whileTrue: 243502 [(array at: index) = oldObject ifTrue: [^ index]. 243503 index := index + 1]. 243504 self errorNotFound: oldObject! ! 243505 243506!OrderedCollection methodsFor: 'private' stamp: 'BG 1/9/2004 12:29'! 243507insert: anObject before: spot 243508 243509 " spot is an index in the range firstIndex .. lastIndex, such an index is not known from outside the collection. 243510 Never use this method in your code, it is meant for private use by OrderedCollection only. 243511 The methods for use are: 243512 #add:before: to insert an object before another object 243513 #add:beforeIndex: to insert an object before a given position. " 243514 | "index" delta spotIndex| 243515 spotIndex := spot. 243516 delta := spotIndex - firstIndex. 243517 firstIndex = 1 243518 ifTrue: 243519 [self makeRoomAtFirst. 243520 spotIndex := firstIndex + delta]. 243521 firstIndex := firstIndex - 1. 243522 array 243523 replaceFrom: firstIndex 243524 to: spotIndex - 2 243525 with: array 243526 startingAt: firstIndex + 1. 243527 array at: spotIndex - 1 put: anObject. 243528" index := firstIndex := firstIndex - 1. 243529 [index < (spotIndex - 1)] 243530 whileTrue: 243531 [array at: index put: (array at: index + 1). 243532 index := index + 1]. 243533 array at: index put: anObject." 243534 ^ anObject! ! 243535 243536!OrderedCollection methodsFor: 'private'! 243537makeRoomAtFirst 243538 | delta index | 243539 delta := array size - self size. 243540 delta = 0 ifTrue: 243541 [self grow. 243542 delta := array size - self size]. 243543 lastIndex = array size ifTrue: [^ self]. "just in case we got lucky" 243544 index := array size. 243545 [index > delta] 243546 whileTrue: 243547 [array at: index put: (array at: index - delta + firstIndex - 1). 243548 array at: index - delta + firstIndex - 1 put: nil. 243549 index := index - 1]. 243550 firstIndex := delta + 1. 243551 lastIndex := array size! ! 243552 243553!OrderedCollection methodsFor: 'private'! 243554makeRoomAtLast 243555 | newLast delta | 243556 newLast := self size. 243557 array size - self size = 0 ifTrue: [self grow]. 243558 (delta := firstIndex - 1) = 0 ifTrue: [^ self]. 243559 "we might be here under false premises or grow did the job for us" 243560 1 to: newLast do: 243561 [:index | 243562 array at: index put: (array at: index + delta). 243563 array at: index + delta put: nil]. 243564 firstIndex := 1. 243565 lastIndex := newLast! ! 243566 243567!OrderedCollection methodsFor: 'private' stamp: 'BG 1/9/2004 12:28'! 243568removeIndex: removedIndex 243569 " removedIndex is an index in the range firstIndex .. lastIndex, such an index is not known from outside the collection. 243570 Never use this method in your code, it is meant for private use by OrderedCollection only. 243571 The method for public use is: 243572 #removeAt: " 243573 243574 array 243575 replaceFrom: removedIndex 243576 to: lastIndex - 1 243577 with: array 243578 startingAt: removedIndex+1. 243579 array at: lastIndex put: nil. 243580 lastIndex := lastIndex - 1.! ! 243581 243582!OrderedCollection methodsFor: 'private' stamp: 'di 11/14/97 12:54'! 243583reset 243584 firstIndex := array size // 3 max: 1. 243585 lastIndex := firstIndex - 1! ! 243586 243587!OrderedCollection methodsFor: 'private' stamp: 'ar 4/16/1999 07:59'! 243588resetTo: index 243589 firstIndex := index. 243590 lastIndex := firstIndex - 1! ! 243591 243592!OrderedCollection methodsFor: 'private' stamp: 'di 11/14/97 12:54'! 243593setCollection: anArray 243594 array := anArray. 243595 self reset! ! 243596 243597!OrderedCollection methodsFor: 'private' stamp: 'apb 10/15/2000 18:10'! 243598setContents: anArray 243599 array := anArray. 243600 firstIndex := 1. 243601 lastIndex := array size.! ! 243602 243603"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 243604 243605OrderedCollection class 243606 instanceVariableNames: ''! 243607 243608!OrderedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:41'! 243609new 243610 ^ self new: 10! ! 243611 243612!OrderedCollection class methodsFor: 'instance creation' stamp: 'nice 3/11/2008 21:15'! 243613new: anInteger 243614 "Create a collection with enough room allocated to contain up to anInteger elements. 243615 The new instance will be of size 0 (allocated room is not necessarily used)." 243616 243617 ^self basicNew setCollection: (Array new: anInteger)! ! 243618 243619!OrderedCollection class methodsFor: 'instance creation' stamp: 'StephaneDucasse 9/6/2009 15:47'! 243620new: anInteger withAll: anObject 243621 ^ self basicNew setContents: (Array new: anInteger withAll: anObject)! ! 243622 243623!OrderedCollection class methodsFor: 'instance creation'! 243624newFrom: aCollection 243625 "Answer an instance of me containing the same elements as aCollection." 243626 243627 | newCollection | 243628 newCollection := self new: aCollection size. 243629 newCollection addAll: aCollection. 243630 ^newCollection 243631 243632" OrderedCollection newFrom: {1. 2. 3} 243633 {1. 2. 3} as: OrderedCollection 243634 {4. 2. 7} as: SortedCollection 243635"! ! 243636 243637!OrderedCollection class methodsFor: 'instance creation' stamp: 'apb 10/15/2000 22:02'! 243638ofSize: n 243639 "Create a new collection of size n with nil as its elements. 243640 This method exists because OrderedCollection new: n creates an 243641 empty collection, not one of size n." 243642 | collection | 243643 collection := self new: n. 243644 collection setContents: (collection collector). 243645 ^ collection 243646! ! 243647Inspector subclass: #OrderedCollectionInspector 243648 instanceVariableNames: '' 243649 classVariableNames: '' 243650 poolDictionaries: '' 243651 category: 'Tools-Inspector'! 243652 243653!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'dew 9/19/2001 03:27'! 243654fieldList 243655 object ifNil: [ ^ OrderedCollection new]. 243656 ^ self baseFieldList , 243657 (object size <= (self i1 + self i2) 243658 ifTrue: [(1 to: object size) 243659 collect: [:i | i printString]] 243660 ifFalse: [(1 to: self i1) , (object size-(self i2-1) to: object size) 243661 collect: [:i | i printString]]) 243662" 243663OrderedCollection new inspect 243664(OrderedCollection newFrom: #(3 5 7 123)) inspect 243665(OrderedCollection newFrom: (1 to: 1000)) inspect 243666"! ! 243667 243668!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'sw 9/16/97 22:38'! 243669replaceSelectionValue: anObject 243670 "The receiver has a list of variables of its inspected object. One of these 243671 is selected. The value of the selected variable is set to the value, anObject." 243672 243673 (selectionIndex - 2) <= object class instSize 243674 ifTrue: [^ super replaceSelectionValue: anObject]. 243675 object at: self selectedObjectIndex put: anObject! ! 243676 243677!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:27'! 243678selectedObjectIndex 243679 "Answer the index of the inspectee's collection that the current selection refers to." 243680 243681 | basicIndex | 243682 basicIndex := selectionIndex - 2 - object class instSize. 243683 ^ (object size <= (self i1 + self i2) or: [basicIndex <= self i1]) 243684 ifTrue: [basicIndex] 243685 ifFalse: [object size - (self i1 + self i2) + basicIndex]! ! 243686 243687!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'sw 9/16/97 22:39'! 243688selection 243689 "The receiver has a list of variables of its inspected object. 243690 One of these is selected. Answer the value of the selected variable." 243691 243692 (selectionIndex - 2) <= object class instSize 243693 ifTrue: [^ super selection]. 243694 ^ object at: self selectedObjectIndex! ! 243695CollectionRootTest subclass: #OrderedCollectionTest 243696 uses: TEmptySequenceableTest + TAddTest + TSequencedElementAccessTest + TIncludesWithIdentityCheckTest + TCloneTest + TSetArithmetic + TRemoveForMultiplenessTest + TCreationWithTest + TCopyTest + TPutBasicTest + TIterateSequencedReadableTest + TSubCollectionAccess + TIndexAccess + TCopySequenceableWithReplacement + TCopyPartOfSequenceable + TCopySequenceableSameContents + TCopySequenceableWithOrWithoutSpecificElements - {#testForceToPaddingWith. #testForceToPaddingStartWith} + TPrintOnSequencedTest + TAsStringCommaAndDelimiterSequenceableTest + TConvertTest + TConvertAsSetForMultiplinessIdentityTest + TSequencedConcatenationTest + TBeginsEndsWith + TReplacementSequencedTest + TIndexAccessForMultipliness + TCopyPartOfSequenceableForMultipliness + TConvertAsSortedTest + TPutTest + TSequencedStructuralEqualityTest + TOccurrencesForMultiplinessTest 243697 instanceVariableNames: 'empty nonEmpty collection result emptyButAllocatedWith20 otherCollection indexCollection elementExistsTwice collectionWithElement collectionOfFloat elementNotIn indexArray withoutEqualElements floatCollectionWithSameBeginingEnd duplicateElement collectionWithDuplicateElement collection5Elements' 243698 classVariableNames: '' 243699 poolDictionaries: '' 243700 category: 'CollectionsTests-Sequenceable'! 243701!OrderedCollectionTest commentStamp: 'BG 1/10/2004 22:07' prior: 0! 243702These test cases demonstrate addition of items into an OrderedCollection as well as item removal. 243703 243704Some of the assertions are quite complicated and use a lot of collection protocol. Such methods do not test one single method, but protocol in general.! 243705 243706 243707!OrderedCollectionTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:13'! 243708aValue 243709 243710 ^ 33! ! 243711 243712!OrderedCollectionTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:13'! 243713anIndex 243714 243715 ^ 2! ! 243716 243717!OrderedCollectionTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:19'! 243718anotherValue 243719 243720 ^ 66! ! 243721 243722 243723!OrderedCollectionTest methodsFor: 'parameters'! 243724accessValuePutIn 243725 "return access the element put in the non-empty collection" 243726 243727 ^ self perform: self selectorToAccessValuePutIn! ! 243728 243729!OrderedCollectionTest methodsFor: 'parameters'! 243730accessValuePutInOn: s 243731 243732 "return access the element put in the non-empty collection" 243733 243734 ^ s perform: self selectorToAccessValuePutIn! ! 243735 243736!OrderedCollectionTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/5/2008 12:38'! 243737selectorToAccessValuePutIn 243738 "return the selector of the method that should be invoked to access an element" 243739 243740 ^ #first! ! 243741 243742!OrderedCollectionTest methodsFor: 'parameters'! 243743valuePutIn 243744 "the value that we will put in the non empty collection" 243745 243746 ^ #x! ! 243747 243748 243749!OrderedCollectionTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/30/2008 19:03'! 243750accessCollection 243751 243752 ^ indexCollection! ! 243753 243754!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:04'! 243755anotherElementOrAssociationIn 243756 " return an element (or an association for Dictionary ) present in 'collection' " 243757 ^ self collection anyOne! ! 243758 243759!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:04'! 243760anotherElementOrAssociationNotIn 243761 " return an element (or an association for Dictionary )not present in 'collection' " 243762 ^ elementNotIn ! ! 243763 243764!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:00'! 243765collectionInForIncluding 243766 ^ self nonEmpty copyWithoutFirst.! ! 243767 243768!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:16'! 243769collectionMoreThan1NoDuplicates 243770 " return a collection of size 5 without equal elements" 243771 ^ withoutEqualElements ! ! 243772 243773!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 13:59'! 243774collectionMoreThan5Elements 243775" return a collection including at least 5 elements" 243776 243777 ^collection5Elements ! ! 243778 243779!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:26'! 243780collectionNotIncluded 243781 ^ OrderedCollection new add: elementNotIn ; add: elementNotIn ; yourself.! ! 243782 243783!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:56'! 243784collectionOfFloat 243785 ^ collectionOfFloat ! ! 243786 243787!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 13:40'! 243788collectionWith1TimeSubcollection 243789" return a collection including 'oldSubCollection' only one time " 243790 ^ ((OrderedCollection new add: elementNotIn; yourself),self oldSubCollection) add: elementNotIn;yourself ! ! 243791 243792!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:27'! 243793collectionWith2TimeSubcollection 243794" return a collection including 'oldSubCollection' two or many time " 243795 ^ (((OrderedCollection new add: elementNotIn; yourself),self oldSubCollection ) add: elementNotIn;yourself),self oldSubCollection! ! 243796 243797!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 10:21'! 243798collectionWith5Elements 243799" return a collection of size 5 including 5 elements" 243800^ indexCollection ! ! 243801 243802!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:49'! 243803collectionWithCopy 243804 "return a collection of type 'self collectionWIithoutEqualsElements clas' containing no elements equals ( with identity equality) 243805 but 2 elements only equals with classic equality" 243806 | result collection | 243807 collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. 243808 collection add: collection first copy. 243809 result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. 243810 ^ result! ! 243811 243812!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! 243813collectionWithCopyNonIdentical 243814 " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" 243815 ^ collectionOfFloat! ! 243816 243817!OrderedCollectionTest methodsFor: 'requirements' stamp: 'sd 1/28/2009 16:29'! 243818collectionWithElement 243819 "Returns a collection that already includes what is returned by #element." 243820 ^ collectionWithElement! ! 243821 243822!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:22'! 243823collectionWithElementsToRemove 243824 ^ nonEmpty copyWithoutFirst.! ! 243825 243826!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:10'! 243827collectionWithEqualElements 243828" return a collecition including atLeast two elements equal" 243829 243830^collectionWithDuplicateElement ! ! 243831 243832!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:50'! 243833collectionWithIdentical 243834 "return a collection of type : 'self collectionWIithoutEqualsElements class containing two elements equals ( with identity equality)" 243835 | result collection element | 243836 collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. 243837 element := collection first. 243838 collection add: element. 243839 result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. 243840 ^ result! ! 243841 243842!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:16'! 243843collectionWithNonIdentitySameAtEndAndBegining 243844 " return a collection with elements at end and begining equals only with classic equality (they are not the same object). 243845(others elements of the collection are not equal to those elements)" 243846 ^ floatCollectionWithSameBeginingEnd ! ! 243847 243848!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 11:14'! 243849collectionWithSameAtEndAndBegining 243850" return a collection with elements at end and begining equals . 243851(others elements of the collection are not equal to those elements)" 243852 ^ floatCollectionWithSameBeginingEnd ! ! 243853 243854!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:24'! 243855collectionWithSortableElements 243856" return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" 243857 ^ collectionOfFloat ! ! 243858 243859!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:00'! 243860collectionWithoutEqualElements 243861" return a collection without equal elements" 243862 ^ withoutEqualElements ! ! 243863 243864!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:35'! 243865collectionWithoutEqualsElements 243866 243867" return a collection not including equal elements " 243868 ^ withoutEqualElements ! ! 243869 243870!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:17'! 243871collectionWithoutNilElements 243872" return a collection that doesn't includes a nil element and that doesn't includes equal elements'" 243873 ^ withoutEqualElements ! ! 243874 243875!OrderedCollectionTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/8/2008 16:30'! 243876element 243877 ^ 3! ! 243878 243879!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:03'! 243880elementInCollectionOfFloat 243881 ^ collectionOfFloat anyOne.! ! 243882 243883!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:42'! 243884elementInForElementAccessing 243885" return an element inculded in 'accessCollection '" 243886 ^ self accessCollection anyOne! ! 243887 243888!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:03'! 243889elementInForIncludesTest 243890" return an element included in nonEmpty " 243891 ^ self nonEmpty anyOne! ! 243892 243893!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 13:27'! 243894elementInForIndexAccessing 243895 243896^ self accessCollection anyOne.! ! 243897 243898!OrderedCollectionTest methodsFor: 'requirements'! 243899elementInForReplacement 243900" return an element included in 'nonEmpty' " 243901^ self nonEmpty anyOne.! ! 243902 243903!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:02'! 243904elementNotIn 243905 ^ elementNotIn ! ! 243906 243907!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:42'! 243908elementNotInForElementAccessing 243909" return an element not included in 'accessCollection' " 243910 ^ elementNotIn ! ! 243911 243912!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:32'! 243913elementNotInForIndexAccessing 243914 243915 ^ elementNotIn ! ! 243916 243917!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:10'! 243918elementTwiceInForOccurrences 243919" return an element included exactly two time in # collectionWithEqualElements" 243920^ duplicateElement ! ! 243921 243922!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:46'! 243923elementsCopyNonIdenticalWithoutEqualElements 243924 " return a collection that does niot incllude equal elements ( classic equality )" 243925 ^ collectionOfFloat! ! 243926 243927!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:12'! 243928firstCollection 243929" return a collection that will be the first part of the concatenation" 243930 ^ nonEmpty ! ! 243931 243932!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:41'! 243933firstIndex 243934" return an index between 'nonEmpty' bounds that is < to 'second index' " 243935 ^1! ! 243936 243937!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 13:48'! 243938floatCollectionWithSameAtEndAndBegining 243939" return a collection with elements at end and begining equals only with classic equality (they are not the same object). 243940(others elements of the collection are not equal to those elements)" 243941 ^ floatCollectionWithSameBeginingEnd ! ! 243942 243943!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:49'! 243944indexArray 243945 ^ indexArray .! ! 243946 243947!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:35'! 243948indexInForCollectionWithoutDuplicates 243949" return an index between 'collectionWithoutEqualsElements' bounds" 243950 ^ 2! ! 243951 243952!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:44'! 243953indexInNonEmpty 243954" return an index between bounds of 'nonEmpty' " 243955 243956 ^ 2! ! 243957 243958!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:37'! 243959integerCollection 243960" return a collection only including SmallInteger elements" 243961 ^ indexCollection ! ! 243962 243963!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:01'! 243964integerCollectionWithoutEqualElements 243965" return a collection of integer without equal elements" 243966 ^ withoutEqualElements ! ! 243967 243968!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:52'! 243969moreThan3Elements 243970 " return a collection including atLeast 3 elements" 243971 ^ indexCollection ! ! 243972 243973!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:52'! 243974moreThan4Elements 243975 243976" return a collection including at leat 4 elements" 243977 ^ indexCollection ! ! 243978 243979!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:42'! 243980newElement 243981"return an element that will be put in the collection in place of another" 243982 ^999! ! 243983 243984!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:57'! 243985nonEmpty1Element 243986" return a collection of size 1 including one element" 243987 ^ OrderedCollection new add:( self nonEmpty anyOne); yourself.! ! 243988 243989!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 14:05'! 243990nonEmptyMoreThan1Element 243991" return a collection with more than one element" 243992 ^ withoutEqualElements .! ! 243993 243994!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:29'! 243995nonEmptyWithoutEqualElements 243996" return a collection without equal elements " 243997 ^ withoutEqualElements ! ! 243998 243999!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 13:38'! 244000oldSubCollection 244001" return a subCollection included in collectionWith1TimeSubcollection . 244002ex : subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)" 244003 ^ nonEmpty ! ! 244004 244005!OrderedCollectionTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/8/2008 16:04'! 244006otherCollection 244007 ^ otherCollection! ! 244008 244009!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 13:41'! 244010replacementCollection 244011" return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection' " 244012 ^ collection! ! 244013 244014!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:45'! 244015replacementCollectionSameSize 244016" return a collection of size (secondIndex - firstIndex + 1)" 244017 244018| res | 244019res := OrderedCollection new. 2440201 to: (self secondIndex - self firstIndex + 1) do: 244021 [ 244022 :i | 244023 res add: 99. 244024 ]. 244025 ^res.! ! 244026 244027!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:19'! 244028result 244029 244030^ result ! ! 244031 244032!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:18'! 244033resultForCollectElementsClass 244034" return the retsult expected by collecting the class of each element of collectionWithoutNilElements" 244035 ^ result ! ! 244036 244037!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:13'! 244038secondCollection 244039" return a collection that will be the second part of the concatenation" 244040 ^ collection ! ! 244041 244042!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:42'! 244043secondIndex 244044" return an index between 'nonEmpty' bounds that is > to 'second index' " 244045 ^2! ! 244046 244047!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:02'! 244048subCollectionNotIn 244049 244050 ^ self collectionNotIncluded .! ! 244051 244052!OrderedCollectionTest methodsFor: 'requirements'! 244053valueArray 244054" return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty' at indexes in 'indexArray' " 244055 | result | 244056 result := Array new: self indexArray size. 244057 1 to: result size do: 244058 [:i | 244059 result at:i put: (self aValue ). 244060 ]. 244061 ^ result.! ! 244062 244063!OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:11'! 244064withEqualElements 244065 " return a collection of float including equal elements (classic equality)" 244066 ^ collectionOfFloat , collectionOfFloat! ! 244067 244068 244069!OrderedCollectionTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 15:53'! 244070collection 244071 244072 ^ collection! ! 244073 244074!OrderedCollectionTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 12:10'! 244075empty 244076 244077 ^ empty! ! 244078 244079!OrderedCollectionTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 16:29'! 244080emptyButAllocatedWith20 244081 244082 ^ emptyButAllocatedWith20! ! 244083 244084!OrderedCollectionTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 12:10'! 244085nonEmpty 244086 244087 ^ nonEmpty! ! 244088 244089!OrderedCollectionTest methodsFor: 'setup' stamp: 'delaunay 5/14/2009 13:59'! 244090setUp 244091 244092 244093 nonEmpty := OrderedCollection new add: self valuePutIn; add: self elementTwiceIn; add: self elementTwiceIn; yourself. 244094 empty := OrderedCollection new. 244095 elementNotIn := 99. 244096 collection := OrderedCollection new add: 1; add: -2; add: 3; add: 1; yourself. 244097 indexArray := { 3. 1.}. 244098 indexCollection := OrderedCollection new add: 1; add: 2;add: 3; add: 4; add:5; yourself. 244099 otherCollection := OrderedCollection new add: 1;add: 20; add: 30; yourself. 244100 withoutEqualElements := OrderedCollection new add: 1;add: 20; add: 30; yourself. 244101 result := OrderedCollection new add: SmallInteger; add: SmallInteger; add: SmallInteger; yourself. 244102 emptyButAllocatedWith20 := OrderedCollection new: 20. 244103 collectionWithElement := OrderedCollection new add: self element; yourself. 244104 collectionOfFloat := OrderedCollection new add: 4.1; add: 7.2; add: 2.5; yourself. 244105 floatCollectionWithSameBeginingEnd := OrderedCollection new add: 4.1; add: 7.2; add: 4.1 copy ; yourself. 244106 duplicateElement := 2. 244107 collectionWithDuplicateElement := OrderedCollection new add: duplicateElement ; add: duplicateElement ; add:4 ; yourself. 244108 244109 collection5Elements := OrderedCollection new add: 1; add: 2; add: 3; add: 4; add: 5; yourself.! ! 244110 244111!OrderedCollectionTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 19:45'! 244112sizeCollection 244113 244114 ^ collection! ! 244115 244116 244117!OrderedCollectionTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! 244118elementToAdd 244119 ^ 55! ! 244120 244121 244122!OrderedCollectionTest methodsFor: 'test - creation' stamp: 'stephane.ducasse 12/9/2008 18:31'! 244123collectionClass 244124 244125 ^ OrderedCollection! ! 244126 244127!OrderedCollectionTest methodsFor: 'test - creation'! 244128testOfSize 244129 "self debug: #testOfSize" 244130 244131 | aCol | 244132 aCol := self collectionClass ofSize: 3. 244133 self assert: (aCol size = 3). 244134! ! 244135 244136!OrderedCollectionTest methodsFor: 'test - creation'! 244137testWith 244138 "self debug: #testWith" 244139 244140 | aCol element | 244141 element := self collectionMoreThan5Elements anyOne. 244142 aCol := self collectionClass with: element. 244143 self assert: (aCol includes: element).! ! 244144 244145!OrderedCollectionTest methodsFor: 'test - creation'! 244146testWithAll 244147 "self debug: #testWithAll" 244148 244149 | aCol collection | 244150 collection := self collectionMoreThan5Elements asOrderedCollection . 244151 aCol := self collectionClass withAll: collection . 244152 244153 collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. 244154 244155 self assert: (aCol size = collection size ).! ! 244156 244157!OrderedCollectionTest methodsFor: 'test - creation'! 244158testWithWith 244159 "self debug: #testWithWith" 244160 244161 | aCol collection element1 element2 | 244162 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . 244163 element1 := collection at: 1. 244164 element2 := collection at:2. 244165 244166 aCol := self collectionClass with: element1 with: element2 . 244167 self assert: (aCol occurrencesOf: element1 ) == ( collection occurrencesOf: element1). 244168 self assert: (aCol occurrencesOf: element2 ) == ( collection occurrencesOf: element2). 244169 244170 ! ! 244171 244172!OrderedCollectionTest methodsFor: 'test - creation'! 244173testWithWithWith 244174 "self debug: #testWithWithWith" 244175 244176 | aCol collection | 244177 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . 244178 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 244179 244180 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 244181 244182!OrderedCollectionTest methodsFor: 'test - creation'! 244183testWithWithWithWith 244184 "self debug: #testWithWithWithWith" 244185 244186 | aCol collection | 244187 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. 244188 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 244189 244190 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 244191 244192!OrderedCollectionTest methodsFor: 'test - creation'! 244193testWithWithWithWithWith 244194 "self debug: #testWithWithWithWithWith" 244195 244196 | aCol collection | 244197 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . 244198 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 244199 244200 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 244201 244202 244203!OrderedCollectionTest methodsFor: 'test - equality'! 244204testEqualSign 244205 "self debug: #testEqualSign" 244206 244207 self deny: (self empty = self nonEmpty).! ! 244208 244209!OrderedCollectionTest methodsFor: 'test - equality'! 244210testEqualSignIsTrueForNonIdenticalButEqualCollections 244211 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 244212 244213 self assert: (self empty = self empty copy). 244214 self assert: (self empty copy = self empty). 244215 self assert: (self empty copy = self empty copy). 244216 244217 self assert: (self nonEmpty = self nonEmpty copy). 244218 self assert: (self nonEmpty copy = self nonEmpty). 244219 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 244220 244221!OrderedCollectionTest methodsFor: 'test - equality'! 244222testEqualSignOfIdenticalCollectionObjects 244223 "self debug: #testEqualSignOfIdenticalCollectionObjects" 244224 244225 self assert: (self empty = self empty). 244226 self assert: (self nonEmpty = self nonEmpty). 244227 ! ! 244228 244229 244230!OrderedCollectionTest methodsFor: 'test - iterate' stamp: 'luc.fabresse 11/29/2008 23:09'! 244231expectedSizeAfterReject 244232 ^1! ! 244233 244234!OrderedCollectionTest methodsFor: 'test - iterate' stamp: 'stephane.ducasse 10/6/2008 17:38'! 244235speciesClass 244236 244237 ^ OrderedCollection! ! 244238 244239 244240!OrderedCollectionTest methodsFor: 'test - remove' stamp: 'damienpollet 1/30/2009 17:16'! 244241elementTwiceIn 244242 ^ super elementTwiceIn! ! 244243 244244!OrderedCollectionTest methodsFor: 'test - remove'! 244245testRemoveElementThatExistsTwice 244246 "self debug: #testRemoveElementThatDoesExistsTwice" 244247 244248 | size | 244249 size := self nonEmpty size. 244250 self assert: (self nonEmpty includes: self elementTwiceIn). 244251 self nonEmpty remove: self elementTwiceIn. 244252 self assert: size - 1 = self nonEmpty size. 244253 244254 self assert: (self nonEmpty includes: self elementTwiceIn). 244255 self nonEmpty remove: self elementTwiceIn. 244256 self assert: size - 2 = self nonEmpty size! ! 244257 244258 244259!OrderedCollectionTest methodsFor: 'testing-public methods' stamp: 'nice 10/8/2008 23:16'! 244260testAddAfterIndex 244261 "self run: #testAddAfterIndex" 244262 | l | 244263 l := #(1 2 3 4) asOrderedCollection. 244264 l add: 77 afterIndex: 0. 244265 self assert: (l = #(77 1 2 3 4) asOrderedCollection). 244266 l add: 88 afterIndex: 2. 244267 self assert: (l = #(77 1 88 2 3 4) asOrderedCollection). 244268 l add: 99 afterIndex: l size. 244269 self assert: (l = #(77 1 88 2 3 4 99) asOrderedCollection). 244270 self should:[l add: 666 afterIndex: -1] raise: Error. 244271 self should:[l add: 666 afterIndex: l size+1] raise: Error. 244272 244273 "Now make room by removing first two and last two elements, 244274 and see if the illegal bounds test still fails" 244275 (l first: 2) , (l last: 2) reverse do: [:e | l remove: e]. 244276 self should: [l add: 666 afterIndex: -1] raise: Error. 244277 self should: [l add: 666 afterIndex: l size+1] raise: Error.! ! 244278 244279!OrderedCollectionTest methodsFor: 'testing-public methods' stamp: 'nice 10/8/2008 23:17'! 244280testAddBeforeIndex 244281 "self run: #testAddBeforeIndex" 244282 | l | 244283 l := #(1 2 3 4) asOrderedCollection. 244284 l add: 77 beforeIndex: 1. 244285 self assert: (l = #(77 1 2 3 4) asOrderedCollection). 244286 l add: 88 beforeIndex: 3. 244287 self assert: (l = #(77 1 88 2 3 4) asOrderedCollection). 244288 l add: 99 beforeIndex: l size+1. 244289 self assert: (l = #(77 1 88 2 3 4 99) asOrderedCollection). 244290 self should:[l add: 666 beforeIndex: 0] raise: Error. 244291 self should:[l add: 666 beforeIndex: l size+2] raise: Error. 244292 244293 "Now make room by removing first two and last two elements, 244294 and see if the illegal bounds test still fails" 244295 (l first: 2) , (l last: 2) reverse do: [:e | l remove: e]. 244296 self should:[l add: 666 beforeIndex: 0] raise: Error. 244297 self should:[l add: 666 beforeIndex: l size+2] raise: Error. 244298 244299! ! 244300 244301 244302!OrderedCollectionTest methodsFor: 'tests - accessing' stamp: 'zz 12/7/2005 18:50'! 244303testAt 244304 | collection | 244305 collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. 244306 self assert: (collection at:1) = 'Jim'. 244307 self assert: (collection at:2) = 'Mary'! ! 244308 244309!OrderedCollectionTest methodsFor: 'tests - accessing' stamp: 'sd 3/21/2006 22:38'! 244310testAtPut 244311 "Allows one to replace an element but not at an off range index" 244312 "self run:#testAtPut" 244313 | c | 244314 c := #(1 2 3 4 ) asOrderedCollection. 244315 c at: 2 put: 5. 244316 self assert: c = #(1 5 3 4 ) asOrderedCollection. 244317 self 244318 should: [c at: 5 put: 8] 244319 raise: Error. 244320 self deny: c = #(1 5 3 4 8 ) asOrderedCollection! ! 244321 244322!OrderedCollectionTest methodsFor: 'tests - accessing' stamp: 'stephane.ducasse 10/6/2008 16:32'! 244323testCapacityFromAsOrderedCollection 244324 "Allows one to check the current capacity of an Ordered collection" 244325 "self run:#testCapacityFromAsOrderedCollection" 244326 244327 | c1 c2 c3 | 244328 c1 := #(1 2 ) asOrderedCollection. 244329 self assert: (c1 capacity = 2). 244330 c2 := OrderedCollection new: 10. 244331 c2 add: 3. 244332 self assert: (c2 capacity = 10). 244333 c3 := OrderedCollection new. 244334 self deny: (c3 capacity = 0). 244335 ! ! 244336 244337 244338!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 19:00'! 244339testAdd 244340 | l | 244341 l := #(1 2 3 4) asOrderedCollection. 244342 l add: 88. 244343 self assert: (l = #(1 2 3 4 88) asOrderedCollection). 244344 l add: 99. 244345 self assert: (l = #(1 2 3 4 88 99) asOrderedCollection). 244346 244347! ! 244348 244349!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 18:52'! 244350testAddAfter 244351 244352 | l | 244353 l := #(1 2 3 4) asOrderedCollection. 244354 l add: 88 after: 1. 244355 self assert: (l = #(1 88 2 3 4) asOrderedCollection). 244356 l add: 99 after: 2. 244357 self assert: (l = #(1 88 2 99 3 4) asOrderedCollection). 244358 244359! ! 244360 244361!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'sd 3/21/2006 22:36'! 244362testAddAll 244363 "Allows one to add each element of an orderedCollection at the end of another 244364 orderedCollection " 244365 "self run:#testAddAll" 244366 244367 | c1 c2 | 244368 c1 := #(1 2 3 4 ) asOrderedCollection. 244369 c2 := #(5 6 7 8 9 ) asOrderedCollection. 244370 c1 addAll: c2. 244371 self assert: c1 = #(1 2 3 4 5 6 7 8 9) asOrderedCollection! ! 244372 244373!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'sd 3/21/2006 22:36'! 244374testAddAllFirst 244375 "Allows one to add each element of an orderedCollection at the beginning of another 244376 orderedCollection " 244377 "self run:#testAddAllFirst" 244378 244379 | c1 c2 | 244380 c1 := #(1 2 3 4 ) asOrderedCollection. 244381 c2 := #(5 6 7 8 9 ) asOrderedCollection. 244382 c2 addAllFirst: c1. 244383 self assert: c2 = #(1 2 3 4 5 6 7 8 9) asOrderedCollection! ! 244384 244385!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'sd 3/21/2006 22:36'! 244386testAddAllFirstUnlessAlreadyPresent 244387 "Allows one to add each element of an orderedCollection at the beginning of 244388 another orderedCollection preserving the order but no duplicate element" 244389 "self run:#testAddAllFirstUnlessAlreadyPresent" 244390 244391 | c1 c2 c3 | 244392 c1 := #(1 2 3 4 ) asOrderedCollection. 244393 c2 := #(5 6 7 8 9 ) asOrderedCollection. 244394 c3 := #(0 1 ) asOrderedCollection. 244395 c2 addAllFirstUnlessAlreadyPresent: c1. 244396 self assert: c2 = #(1 2 3 4 5 6 7 8 9 ) asOrderedCollection. 244397 c1 addAllFirstUnlessAlreadyPresent: c3. 244398 self deny: c1 = #(0 1 1 2 3 4 ) asOrderedCollection. 244399 self assert: c1 = #(0 1 2 3 4 ) asOrderedCollection. 244400 ! ! 244401 244402!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'sd 3/21/2006 22:36'! 244403testAddAllLast 244404 "Allows one to add each element of an orderedCollection at the beginning of another 244405 orderedCollection " 244406 "self run:#testAddAllLast" 244407 244408 | c1 c2 | 244409 c1 := #(1 2 3 4 ) asOrderedCollection. 244410 c2 := #(5 6 7 8 9 ) asOrderedCollection. 244411 c1 addAllLast: c2. 244412 self assert: c1 = #(1 2 3 4 5 6 7 8 9) asOrderedCollection! ! 244413 244414!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 18:57'! 244415testAddBefore 244416 244417 | l | 244418 l := #(1 2 3 4) asOrderedCollection. 244419 l add: 88 before: 1. 244420 self assert: (l = #(88 1 2 3 4) asOrderedCollection). 244421 l add: 99 before: 2. 244422 self assert: (l = #(88 1 99 2 3 4) asOrderedCollection). 244423 244424! ! 244425 244426!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 13:42'! 244427testAddBeforeAndRemove 244428 244429 | l initialCollection | 244430 l := #(1 2 3 4) asOrderedCollection. 244431 initialCollection := l shallowCopy. 244432 l add: 88 before: 1. 244433 self assert: (l = #(88 1 2 3 4) asOrderedCollection). 244434 l add: 99 before: 2. 244435 self assert: (l = #(88 1 99 2 3 4) asOrderedCollection). 244436 l remove: 99. 244437 l remove: 88. 244438 self assert: l = initialCollection. 244439 244440! ! 244441 244442!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 13:43'! 244443testAddDuplicateItem1 244444 | collection | 244445 collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. 244446 collection add: 'John' before: 'John'. 244447 self 244448 assert: ((collection asBag occurrencesOf: 'John') 244449 = 2 244450 and: [(collection at: (collection indexOf: 'John') 244451 + 1) 244452 = (collection 244453 at: (collection indexOf: 'John'))])! ! 244454 244455!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 18:58'! 244456testAddFirst 244457 | l | 244458 l := #(1 2 3 4) asOrderedCollection. 244459 l addFirst: 88. 244460 self assert: (l = #(88 1 2 3 4) asOrderedCollection). 244461 l addFirst: 99. 244462 self assert: (l = #(99 88 1 2 3 4) asOrderedCollection). 244463 244464! ! 244465 244466!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'sd 6/5/2005 09:21'! 244467testAddItem1 244468 244469 | collection size | 244470 collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. 244471 size := collection size. 244472 collection add: 'James' before: 'Jim'. 244473 collection add: 'Margaret' before: 'Andrew'. 244474 self assert: size + 2 = collection size. 244475! ! 244476 244477!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 19:07'! 244478testAddItem2 244479 | collection | 244480 collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. 244481 collection add: 'James' before: 'Jim'. 244482 collection add: 'Margaret' before: 'Andrew'. 244483 self assert: (collection indexOf: 'James') 244484 + 1 244485 = (collection indexOf: 'Jim'). 244486 self assert: (collection indexOf: 'Margaret') 244487 + 1 244488 = (collection indexOf: 'Andrew')! ! 244489 244490!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 18:59'! 244491testAddLast 244492 | l | 244493 l := #(1 2 3 4) asOrderedCollection. 244494 l addLast: 88. 244495 self assert: (l = #(1 2 3 4 88) asOrderedCollection). 244496 l addLast: 99. 244497 self assert: (l = #(1 2 3 4 88 99) asOrderedCollection). 244498 244499! ! 244500 244501!OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'sd 3/21/2006 22:37'! 244502testAtIfAbsentPut 244503 "Allows one to add an element at an index if no element exist at this index" 244504 "self run:#testAtIfAbsentPut" 244505 244506 | c | 244507 c := #(1 2 3 4 ) asOrderedCollection. 244508 self 244509 shouldnt: [c at: 2 ifAbsentPut: [5]] 244510 raise: Error. 244511 self assert: c = #(1 2 3 4 ) asOrderedCollection. 244512 c at: 5 ifAbsentPut: [5]. 244513 self assert: c = #(1 2 3 4 5 ) asOrderedCollection. 244514 c at: 7 ifAbsentPut: [7]. 244515 self assert: c = #(1 2 3 4 5 nil 7 ) asOrderedCollection! ! 244516 244517!OrderedCollectionTest methodsFor: 'tests - adding'! 244518testTAdd 244519 | added collection | 244520 collection :=self otherCollection . 244521 added := collection add: self element. 244522 244523 self assert: added == self element. "test for identiy because #add: has not reason to copy its parameter." 244524 self assert: (collection includes: self element) . 244525 self assert: (self collectionWithElement includes: self element). 244526 244527 ! ! 244528 244529!OrderedCollectionTest methodsFor: 'tests - adding'! 244530testTAddAll 244531 | added collection toBeAdded | 244532 collection := self collectionWithElement . 244533 toBeAdded := self otherCollection . 244534 added := collection addAll: toBeAdded . 244535 self assert: added == toBeAdded . "test for identiy because #addAll: has not reason to copy its parameter." 244536 self assert: (collection includesAllOf: toBeAdded )! ! 244537 244538!OrderedCollectionTest methodsFor: 'tests - adding'! 244539testTAddIfNotPresentWithElementAlreadyIn 244540 244541 | added oldSize collection element | 244542 collection := self collectionWithElement . 244543 oldSize := collection size. 244544 element := self element . 244545 self assert: (collection includes: element ). 244546 244547 added := collection addIfNotPresent: element . 244548 244549 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 244550 self assert: collection size = oldSize! ! 244551 244552!OrderedCollectionTest methodsFor: 'tests - adding'! 244553testTAddIfNotPresentWithNewElement 244554 244555 | added oldSize collection element | 244556 collection := self otherCollection . 244557 oldSize := collection size. 244558 element := self element . 244559 self deny: (collection includes: element ). 244560 244561 added := collection addIfNotPresent: element . 244562 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 244563 self assert: (collection size = (oldSize + 1)). 244564 244565 ! ! 244566 244567!OrderedCollectionTest methodsFor: 'tests - adding'! 244568testTAddTwice 244569 | added oldSize collection element | 244570 collection := self collectionWithElement . 244571 element := self element . 244572 oldSize := collection size. 244573 added := collection 244574 add: element ; 244575 add: element . 244576 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 244577 self assert: (collection includes: element ). 244578 self assert: collection size = (oldSize + 2)! ! 244579 244580!OrderedCollectionTest methodsFor: 'tests - adding'! 244581testTAddWithOccurences 244582 | added oldSize collection element | 244583 collection := self collectionWithElement . 244584 element := self element . 244585 oldSize := collection size. 244586 added := collection add: element withOccurrences: 5. 244587 244588 self assert: added == element. "test for identiy because #add: has not reason to copy its parameter." 244589 self assert: (collection includes: element). 244590 self assert: collection size = (oldSize + 5)! ! 244591 244592!OrderedCollectionTest methodsFor: 'tests - adding'! 244593testTWrite 244594 | added collection element | 244595 collection := self otherCollection . 244596 element := self element . 244597 added := collection write: element . 244598 244599 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 244600 self assert: (collection includes: element ) . 244601 self assert: (collection includes: element ). 244602 244603 ! ! 244604 244605!OrderedCollectionTest methodsFor: 'tests - adding'! 244606testTWriteTwice 244607 | added oldSize collection element | 244608 collection := self collectionWithElement . 244609 element := self element . 244610 oldSize := collection size. 244611 added := collection 244612 write: element ; 244613 write: element . 244614 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 244615 self assert: (collection includes: element ). 244616 self assert: collection size = (oldSize + 2)! ! 244617 244618 244619!OrderedCollectionTest methodsFor: 'tests - as identity set'! 244620testAsIdentitySetWithIdentityEqualsElements 244621 | result | 244622 result := self collectionWithIdentical asIdentitySet. 244623 " Only one element should have been removed as two elements are equals with Identity equality" 244624 self assert: result size = (self collectionWithIdentical size - 1). 244625 self collectionWithIdentical do: 244626 [ :each | 244627 (self collectionWithIdentical occurrencesOf: each) > 1 244628 ifTrue: 244629 [ "the two elements equals only with classic equality shouldn't 'have been removed" 244630 self assert: (result asOrderedCollection occurrencesOf: each) = 1 244631 " the other elements are still here" ] 244632 ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ]. 244633 self assert: result class = IdentitySet! ! 244634 244635!OrderedCollectionTest methodsFor: 'tests - as identity set'! 244636testAsIdentitySetWithoutIdentityEqualsElements 244637 | result collection | 244638 collection := self collectionWithCopy. 244639 result := collection asIdentitySet. 244640 " no elements should have been removed as no elements are equels with Identity equality" 244641 self assert: result size = collection size. 244642 collection do: 244643 [ :each | 244644 (collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ]. 244645 self assert: result class = IdentitySet! ! 244646 244647 244648!OrderedCollectionTest methodsFor: 'tests - as set tests'! 244649testAsIdentitySetWithEqualsElements 244650 | result collection | 244651 collection := self withEqualElements . 244652 result := collection asIdentitySet. 244653 collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 244654 self assert: result class = IdentitySet.! ! 244655 244656!OrderedCollectionTest methodsFor: 'tests - as set tests'! 244657testAsSetWithEqualsElements 244658 | result | 244659 result := self withEqualElements asSet. 244660 self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 244661 self assert: result class = Set! ! 244662 244663 244664!OrderedCollectionTest methodsFor: 'tests - as sorted collection'! 244665testAsSortedArray 244666 | result collection | 244667 collection := self collectionWithSortableElements . 244668 result := collection asSortedArray. 244669 self assert: (result class includesBehavior: Array). 244670 self assert: result isSorted. 244671 self assert: result size = collection size! ! 244672 244673!OrderedCollectionTest methodsFor: 'tests - as sorted collection'! 244674testAsSortedCollection 244675 244676 | aCollection result | 244677 aCollection := self collectionWithSortableElements . 244678 result := aCollection asSortedCollection. 244679 244680 self assert: (result class includesBehavior: SortedCollection). 244681 result do: 244682 [ :each | 244683 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 244684 244685 self assert: result size = aCollection size.! ! 244686 244687!OrderedCollectionTest methodsFor: 'tests - as sorted collection'! 244688testAsSortedCollectionWithSortBlock 244689 | result tmp | 244690 result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. 244691 self assert: (result class includesBehavior: SortedCollection). 244692 result do: 244693 [ :each | 244694 self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 244695 self assert: result size = self collectionWithSortableElements size. 244696 tmp:=result at: 1. 244697 result do: [:each| self assert: tmp>=each. tmp:=each]. 244698 ! ! 244699 244700 244701!OrderedCollectionTest methodsFor: 'tests - at put'! 244702testAtPutOutOfBounds 244703 "self debug: #testAtPutOutOfBounds" 244704 244705 self should: [self empty at: self anIndex put: self aValue] raise: Error 244706 ! ! 244707 244708!OrderedCollectionTest methodsFor: 'tests - at put'! 244709testAtPutTwoValues 244710 "self debug: #testAtPutTwoValues" 244711 244712 self nonEmpty at: self anIndex put: self aValue. 244713 self nonEmpty at: self anIndex put: self anotherValue. 244714 self assert: (self nonEmpty at: self anIndex) = self anotherValue.! ! 244715 244716 244717!OrderedCollectionTest methodsFor: 'tests - begins ends with'! 244718testsBeginsWith 244719 244720 self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty size)). 244721 self assert: (self nonEmpty beginsWith:(self nonEmpty )). 244722 self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 244723 244724!OrderedCollectionTest methodsFor: 'tests - begins ends with'! 244725testsBeginsWithEmpty 244726 244727 self deny: (self nonEmpty beginsWith:(self empty)). 244728 self deny: (self empty beginsWith:(self nonEmpty )). 244729! ! 244730 244731!OrderedCollectionTest methodsFor: 'tests - begins ends with'! 244732testsEndsWith 244733 244734 self assert: (self nonEmpty endsWith:(self nonEmpty copyWithoutFirst)). 244735 self assert: (self nonEmpty endsWith:(self nonEmpty )). 244736 self deny: (self nonEmpty endsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 244737 244738!OrderedCollectionTest methodsFor: 'tests - begins ends with'! 244739testsEndsWithEmpty 244740 244741 self deny: (self nonEmpty endsWith:(self empty )). 244742 self deny: (self empty endsWith:(self nonEmpty )). 244743 ! ! 244744 244745 244746!OrderedCollectionTest methodsFor: 'tests - comma and delimiter'! 244747testAsCommaStringEmpty 244748 244749 self assert: self empty asCommaString = ''. 244750 self assert: self empty asCommaStringAnd = ''. 244751 244752 244753! ! 244754 244755!OrderedCollectionTest methodsFor: 'tests - comma and delimiter'! 244756testAsCommaStringMore 244757 244758 "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. 244759 self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' 244760" 244761 244762 | result resultAnd index allElementsAsString | 244763 result:= self nonEmpty asCommaString . 244764 resultAnd:= self nonEmpty asCommaStringAnd . 244765 244766 index := 1. 244767 (result findBetweenSubStrs: ',' )do: 244768 [:each | 244769 index = 1 244770 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] 244771 ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. 244772 index:=index+1 244773 ]. 244774 244775 "verifying esultAnd :" 244776 allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 244777 1 to: allElementsAsString size do: 244778 [:i | 244779 i<(allElementsAsString size ) 244780 ifTrue: [ 244781 i = 1 244782 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] 244783 ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] 244784 ]. 244785 i=(allElementsAsString size) 244786 ifTrue:[ 244787 i = 1 244788 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 244789 ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 244790 ]. 244791 244792 244793 ].! ! 244794 244795!OrderedCollectionTest methodsFor: 'tests - comma and delimiter'! 244796testAsCommaStringOne 244797 244798 "self assert: self oneItemCol asCommaString = '1'. 244799 self assert: self oneItemCol asCommaStringAnd = '1'." 244800 244801 self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). 244802 self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). 244803 ! ! 244804 244805!OrderedCollectionTest methodsFor: 'tests - comma and delimiter'! 244806testAsStringOnDelimiterEmpty 244807 244808 | delim emptyStream | 244809 delim := ', '. 244810 emptyStream := ReadWriteStream on: ''. 244811 self empty asStringOn: emptyStream delimiter: delim. 244812 self assert: emptyStream contents = ''. 244813! ! 244814 244815!OrderedCollectionTest methodsFor: 'tests - comma and delimiter'! 244816testAsStringOnDelimiterLastEmpty 244817 244818 | delim emptyStream | 244819 delim := ', '. 244820 emptyStream := ReadWriteStream on: ''. 244821 self empty asStringOn: emptyStream delimiter: delim last:'and'. 244822 self assert: emptyStream contents = ''. 244823! ! 244824 244825!OrderedCollectionTest methodsFor: 'tests - comma and delimiter'! 244826testAsStringOnDelimiterLastMore 244827 244828 | delim multiItemStream result last allElementsAsString | 244829 244830 delim := ', '. 244831 last := 'and'. 244832 result:=''. 244833 multiItemStream := ReadWriteStream on:result. 244834 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 244835 244836 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 244837 1 to: allElementsAsString size do: 244838 [:i | 244839 i<(allElementsAsString size-1 ) 244840 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 244841 i=(allElementsAsString size-1) 244842 ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. 244843 i=(allElementsAsString size) 244844 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 244845 ]. 244846 244847! ! 244848 244849!OrderedCollectionTest methodsFor: 'tests - comma and delimiter'! 244850testAsStringOnDelimiterLastOne 244851 244852 | delim oneItemStream result | 244853 244854 delim := ', '. 244855 result:=''. 244856 oneItemStream := ReadWriteStream on: result. 244857 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 244858 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 244859 244860 244861 ! ! 244862 244863!OrderedCollectionTest methodsFor: 'tests - comma and delimiter'! 244864testAsStringOnDelimiterMore 244865 244866 | delim multiItemStream result index | 244867 "delim := ', '. 244868 multiItemStream := '' readWrite. 244869 self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. 244870 self assert: multiItemStream contents = '1, 2, 3'." 244871 244872 delim := ', '. 244873 result:=''. 244874 multiItemStream := ReadWriteStream on:result. 244875 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 244876 244877 index:=1. 244878 (result findBetweenSubStrs: ', ' )do: 244879 [:each | 244880 self assert: each= ((self nonEmpty at:index)asString). 244881 index:=index+1 244882 ].! ! 244883 244884!OrderedCollectionTest methodsFor: 'tests - comma and delimiter'! 244885testAsStringOnDelimiterOne 244886 244887 | delim oneItemStream result | 244888 "delim := ', '. 244889 oneItemStream := '' readWrite. 244890 self oneItemCol asStringOn: oneItemStream delimiter: delim. 244891 self assert: oneItemStream contents = '1'." 244892 244893 delim := ', '. 244894 result:=''. 244895 oneItemStream := ReadWriteStream on: result. 244896 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 244897 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 244898 244899 244900 ! ! 244901 244902 244903!OrderedCollectionTest methodsFor: 'tests - concatenation'! 244904testConcatenation 244905 | result index | 244906 result:= self firstCollection,self secondCollection . 244907 "first part : " 244908 index := 1. 244909 self firstCollection do: 244910 [:each | 244911 self assert: (self firstCollection at: index)=each. 244912 index := index+1.]. 244913 "second part : " 244914 1 to: self secondCollection size do: 244915 [:i | 244916 self assert: (self secondCollection at:i)= (result at:index). 244917 index:=index+1]. 244918 "size : " 244919 self assert: result size = (self firstCollection size + self secondCollection size).! ! 244920 244921!OrderedCollectionTest methodsFor: 'tests - concatenation'! 244922testConcatenationWithEmpty 244923 | result | 244924 result:= self empty,self secondCollection . 244925 244926 1 to: self secondCollection size do: 244927 [:i | 244928 self assert: (self secondCollection at:i)= (result at:i). 244929 ]. 244930 "size : " 244931 self assert: result size = ( self secondCollection size).! ! 244932 244933 244934!OrderedCollectionTest methodsFor: 'tests - converting'! 244935assertNoDuplicates: aCollection whenConvertedTo: aClass 244936 | result | 244937 result := self collectionWithEqualElements asIdentitySet. 244938 self assert: (result class includesBehavior: IdentitySet). 244939 self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! 244940 244941!OrderedCollectionTest methodsFor: 'tests - converting'! 244942assertNonDuplicatedContents: aCollection whenConvertedTo: aClass 244943 | result | 244944 result := aCollection perform: ('as' , aClass name) asSymbol. 244945 self assert: (result class includesBehavior: aClass). 244946 result do: 244947 [ :each | 244948 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 244949 ^ result! ! 244950 244951!OrderedCollectionTest methodsFor: 'tests - converting'! 244952assertSameContents: aCollection whenConvertedTo: aClass 244953 | result | 244954 result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. 244955 self assert: result size = aCollection size! ! 244956 244957!OrderedCollectionTest methodsFor: 'tests - converting'! 244958testAsArray 244959 "self debug: #testAsArray3" 244960 self 244961 assertSameContents: self collectionWithoutEqualElements 244962 whenConvertedTo: Array! ! 244963 244964!OrderedCollectionTest methodsFor: 'tests - converting'! 244965testAsBag 244966 244967 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! 244968 244969!OrderedCollectionTest methodsFor: 'tests - converting'! 244970testAsByteArray 244971| res | 244972self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 244973 self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . 244974 244975 res := true. 244976 self integerCollectionWithoutEqualElements 244977 detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] 244978 ifNone: [ res := false ]. 244979 self assert: res = false. 244980 244981 244982 self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! 244983 244984!OrderedCollectionTest methodsFor: 'tests - converting'! 244985testAsIdentitySet 244986 "test with a collection without equal elements :" 244987 self 244988 assertSameContents: self collectionWithoutEqualElements 244989 whenConvertedTo: IdentitySet. 244990! ! 244991 244992!OrderedCollectionTest methodsFor: 'tests - converting'! 244993testAsOrderedCollection 244994 244995 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! 244996 244997!OrderedCollectionTest methodsFor: 'tests - converting'! 244998testAsSet 244999 | | 245000 "test with a collection without equal elements :" 245001 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. 245002 ! ! 245003 245004 245005!OrderedCollectionTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 245006testCopyEmptyWith 245007 "self debug: #testCopyWith" 245008 | res | 245009 res := self empty copyWith: self elementToAdd. 245010 self assert: res size = (self empty size + 1). 245011 self assert: (res includes: self elementToAdd)! ! 245012 245013!OrderedCollectionTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 245014testCopyEmptyWithout 245015 "self debug: #testCopyEmptyWithout" 245016 | res | 245017 res := self empty copyWithout: self elementToAdd. 245018 self assert: res size = self empty size. 245019 self deny: (res includes: self elementToAdd)! ! 245020 245021!OrderedCollectionTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 245022testCopyEmptyWithoutAll 245023 "self debug: #testCopyEmptyWithoutAll" 245024 | res | 245025 res := self empty copyWithoutAll: self collectionWithElementsToRemove. 245026 self assert: res size = self empty size. 245027 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! 245028 245029!OrderedCollectionTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 245030testCopyNonEmptyWith 245031 "self debug: #testCopyNonEmptyWith" 245032 | res | 245033 res := self nonEmpty copyWith: self elementToAdd. 245034 "here we do not test the size since for a non empty set we would get a problem. 245035 Then in addition copy is not about duplicate management. The element should 245036 be in at the end." 245037 self assert: (res includes: self elementToAdd). 245038 self nonEmpty do: [ :each | res includes: each ]! ! 245039 245040!OrderedCollectionTest methodsFor: 'tests - copy'! 245041testCopyNonEmptyWithout 245042 "self debug: #testCopyNonEmptyWithout" 245043 245044 | res anElementOfTheCollection | 245045 anElementOfTheCollection := self nonEmpty anyOne. 245046 res := (self nonEmpty copyWithout: anElementOfTheCollection). 245047 "here we do not test the size since for a non empty set we would get a problem. 245048 Then in addition copy is not about duplicate management. The element should 245049 be in at the end." 245050 self deny: (res includes: anElementOfTheCollection). 245051 self nonEmpty do: 245052 [:each | (each = anElementOfTheCollection) 245053 ifFalse: [self assert: (res includes: each)]]. 245054 245055! ! 245056 245057!OrderedCollectionTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 245058testCopyNonEmptyWithoutAll 245059 "self debug: #testCopyNonEmptyWithoutAll" 245060 | res | 245061 res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. 245062 "here we do not test the size since for a non empty set we would get a problem. 245063 Then in addition copy is not about duplicate management. The element should 245064 be in at the end." 245065 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]. 245066 self nonEmpty do: 245067 [ :each | 245068 (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! 245069 245070!OrderedCollectionTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! 245071testCopyNonEmptyWithoutAllNotIncluded 245072 ! ! 245073 245074!OrderedCollectionTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 245075testCopyNonEmptyWithoutNotIncluded 245076 "self debug: #testCopyNonEmptyWithoutNotIncluded" 245077 | res | 245078 res := self nonEmpty copyWithout: self elementToAdd. 245079 "here we do not test the size since for a non empty set we would get a problem. 245080 Then in addition copy is not about duplicate management. The element should 245081 be in at the end." 245082 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 245083 245084 245085!OrderedCollectionTest methodsFor: 'tests - copy - clone'! 245086testCopyCreatesNewObject 245087 "self debug: #testCopyCreatesNewObject" 245088 245089 | copy | 245090 copy := self nonEmpty copy. 245091 self deny: self nonEmpty == copy. 245092 ! ! 245093 245094!OrderedCollectionTest methodsFor: 'tests - copy - clone'! 245095testCopyEmpty 245096 "self debug: #testCopyEmpty" 245097 245098 | copy | 245099 copy := self empty copy. 245100 self assert: copy isEmpty.! ! 245101 245102!OrderedCollectionTest methodsFor: 'tests - copy - clone'! 245103testCopyNonEmpty 245104 "self debug: #testCopyNonEmpty" 245105 245106 | copy | 245107 copy := self nonEmpty copy. 245108 self deny: copy isEmpty. 245109 self assert: copy size = self nonEmpty size. 245110 self nonEmpty do: 245111 [:each | copy includes: each]! ! 245112 245113 245114!OrderedCollectionTest methodsFor: 'tests - copying' stamp: 'stephane.ducasse 1/12/2009 15:02'! 245115testCopyEmptyOld 245116 "Allows one to create a copy of the receiver that contains no elements" 245117 "self run:#testCopyEmpty" 245118 245119 | c1 c2 | 245120 c1 := #(1 2 3 4 ) asOrderedCollection. 245121 c2 := c1 copyEmpty. 245122 self assert: (c2 size = 0).! ! 245123 245124!OrderedCollectionTest methodsFor: 'tests - copying' stamp: 'sd 3/21/2006 22:41'! 245125testCopyFromTo 245126 "Allows one to create a copy of the receiver that contains elements from position start to end" 245127 "self run: #testCopyFromTo" 245128 245129 | c1 c2 c3 | 245130 c1 := #(1 2 3 4) asOrderedCollection. 245131 c2 := (c1 copyFrom: 1 to: 2). 245132 self assert: c2 = #(1 2) asOrderedCollection. 245133 self should: [c1 copyFrom: 10 to: 20] raise: Error. 245134 245135 c3 := c1 copyFrom: 4 to: 2. 245136 self assert: c3 isEmpty. 245137 245138 self should: [c1 copyFrom: 4 to: 5 ] raise: Error. 245139 245140 245141 245142! ! 245143 245144!OrderedCollectionTest methodsFor: 'tests - copying' stamp: 'sd 3/21/2006 22:41'! 245145testCopyReplaceFromToWith 245146 "Allows one to create a copy from the receiver which elements between start and end of the receiver being replace by element of the collection after with:" 245147 "self run:#testCopyReplaceFromToWith" 245148 245149 | c1 c2 c3 c4 | 245150 c1 := #(1 2 3 4) asOrderedCollection. 245151 c2 := #(5 6 7 8 9) asOrderedCollection. 245152 c3 := (c2 copyReplaceFrom: 1 to: 2 with: c1). 245153 self assert: c3 = #(1 2 3 4 7 8 9) asOrderedCollection. 245154 self should: [c2 copyReplaceFrom: 3 to: 1 with: c1] raise: Error. 245155 245156 c4 := (c2 copyReplaceFrom: 10 to: 25 with: c1). 245157 self assert: c4 = #(5 6 7 8 9 1 2 3 4) asOrderedCollection. 245158 245159 ! ! 245160 245161!OrderedCollectionTest methodsFor: 'tests - copying' stamp: 'sd 3/21/2006 22:41'! 245162testCopyWith 245163 "Allows one to create a copy of the receiver that contains the new element at the end" 245164 "self run: #testCopyWith" 245165 245166 | c1 | 245167 c1 := #(1 2 3 4) asOrderedCollection. 245168 c1 := c1 copyWith: 6. 245169 self assert: c1 = #(1 2 3 4 6) asOrderedCollection. 245170 245171 245172 245173 245174 245175 245176! ! 245177 245178!OrderedCollectionTest methodsFor: 'tests - copying' stamp: 'zz 12/7/2005 13:47'! 245179testReversed 245180 | collection1 collection2 | 245181 collection1 := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. 245182 collection2 := collection1 reversed. 245183 self assert: collection2 first = 'Andrew'. 245184 self assert: collection2 last = 'Jim'! ! 245185 245186 245187!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 245188testCopyAfter 245189 | result index collection | 245190 collection := self collectionWithoutEqualsElements . 245191 index:= self indexInForCollectionWithoutDuplicates . 245192 result := collection copyAfter: (collection at:index ). 245193 245194 "verifying content: " 245195 (1) to: result size do: 245196 [:i | 245197 self assert: (collection at:(i + index ))=(result at: (i))]. 245198 245199 "verify size: " 245200 self assert: result size = (collection size - index).! ! 245201 245202!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 245203testCopyAfterEmpty 245204 | result | 245205 result := self empty copyAfter: self collectionWithoutEqualsElements first. 245206 self assert: result isEmpty. 245207 ! ! 245208 245209!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 245210testCopyAfterLast 245211 | result index collection | 245212 collection := self collectionWithoutEqualsElements . 245213 index:= self indexInForCollectionWithoutDuplicates . 245214 result := collection copyAfterLast: (collection at:index ). 245215 245216 "verifying content: " 245217 (1) to: result size do: 245218 [:i | 245219 self assert: (collection at:(i + index ))=(result at: (i))]. 245220 245221 "verify size: " 245222 self assert: result size = (collection size - index).! ! 245223 245224!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 245225testCopyAfterLastEmpty 245226 | result | 245227 result := self empty copyAfterLast: self collectionWithoutEqualsElements first. 245228 self assert: result isEmpty.! ! 245229 245230!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 245231testCopyEmptyMethod 245232 | result | 245233 result := self collectionWithoutEqualsElements copyEmpty . 245234 self assert: result isEmpty . 245235 self assert: result class= self nonEmpty class.! ! 245236 245237!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 245238testCopyUpTo 245239 | result index collection | 245240 collection := self collectionWithoutEqualsElements . 245241 index:= self indexInForCollectionWithoutDuplicates . 245242 result := collection copyUpTo: (collection at:index). 245243 245244 "verify content of 'result' :" 245245 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 245246 245247 "verify size of 'result' :" 245248 self assert: result size = (index-1). 245249 ! ! 245250 245251!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 245252testCopyUpToEmpty 245253 | result | 245254 result := self empty copyUpTo: self collectionWithoutEqualsElements first. 245255 self assert: result isEmpty. 245256 ! ! 245257 245258!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 245259testCopyUpToLast 245260 | result index collection | 245261 collection := self collectionWithoutEqualsElements . 245262 index:= self indexInForCollectionWithoutDuplicates . 245263 result := collection copyUpToLast: (collection at:index). 245264 245265 "verify content of 'result' :" 245266 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 245267 245268 "verify size of 'result' :" 245269 self assert: result size = (index-1).! ! 245270 245271!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 245272testCopyUpToLastEmpty 245273 | result | 245274 result := self empty copyUpToLast: self collectionWithoutEqualsElements first. 245275 self assert: result isEmpty.! ! 245276 245277 245278!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 245279testCopyAfterLastWithDuplicate 245280 | result element collection | 245281 collection := self collectionWithSameAtEndAndBegining . 245282 element := collection first. 245283 245284 " collectionWithSameAtEndAndBegining first and last elements are equals. 245285 'copyAfter:' should copy after the last occurence of element :" 245286 result := collection copyAfterLast: (element ). 245287 245288 "verifying content: " 245289 self assert: result isEmpty. 245290 245291! ! 245292 245293!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 245294testCopyAfterWithDuplicate 245295 | result element collection | 245296 collection := self collectionWithSameAtEndAndBegining . 245297 element := collection last. 245298 245299 " collectionWithSameAtEndAndBegining first and last elements are equals. 245300 'copyAfter:' should copy after the first occurence :" 245301 result := collection copyAfter: (element ). 245302 245303 "verifying content: " 245304 1 to: result size do: 245305 [:i | 245306 self assert: (collection at:(i + 1 )) = (result at: (i)) 245307 ]. 245308 245309 "verify size: " 245310 self assert: result size = (collection size - 1).! ! 245311 245312!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 245313testCopyUpToLastWithDuplicate 245314 | result element collection | 245315 collection := self collectionWithSameAtEndAndBegining . 245316 element := collection first. 245317 245318 " collectionWithSameAtEndAndBegining first and last elements are equals. 245319 'copyUpToLast:' should copy until the last occurence :" 245320 result := collection copyUpToLast: (element ). 245321 245322 "verifying content: " 245323 1 to: result size do: 245324 [:i | 245325 self assert: (result at: i ) = ( collection at: i ) 245326 ]. 245327 245328 self assert: result size = (collection size - 1). 245329 245330! ! 245331 245332!OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 245333testCopyUpToWithDuplicate 245334 | result element collection | 245335 collection := self collectionWithSameAtEndAndBegining . 245336 element := collection last. 245337 245338 " collectionWithSameAtEndAndBegining first and last elements are equals. 245339 'copyUpTo:' should copy until the first occurence :" 245340 result := collection copyUpTo: (element ). 245341 245342 "verifying content: " 245343 self assert: result isEmpty. 245344 245345! ! 245346 245347 245348!OrderedCollectionTest methodsFor: 'tests - copying same contents'! 245349testReverse 245350 | result | 245351 result := self nonEmpty reverse . 245352 245353 "verify content of 'result: '" 245354 1 to: result size do: 245355 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 245356 "verify size of 'result' :" 245357 self assert: result size=self nonEmpty size.! ! 245358 245359!OrderedCollectionTest methodsFor: 'tests - copying same contents'! 245360testShallowCopy 245361 | result | 245362 result := self nonEmpty shallowCopy . 245363 245364 "verify content of 'result: '" 245365 1 to: self nonEmpty size do: 245366 [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. 245367 "verify size of 'result' :" 245368 self assert: result size=self nonEmpty size.! ! 245369 245370!OrderedCollectionTest methodsFor: 'tests - copying same contents'! 245371testShallowCopyEmpty 245372 | result | 245373 result := self empty shallowCopy . 245374 self assert: result isEmpty .! ! 245375 245376!OrderedCollectionTest methodsFor: 'tests - copying same contents'! 245377testShuffled 245378 | result | 245379 result := self nonEmpty shuffled . 245380 245381 "verify content of 'result: '" 245382 result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. 245383 "verify size of 'result' :" 245384 self assert: result size=self nonEmpty size.! ! 245385 245386!OrderedCollectionTest methodsFor: 'tests - copying same contents'! 245387testSortBy 245388 " can only be used if the collection tested can include sortable elements :" 245389 | result tmp | 245390 self 245391 shouldnt: [ self collectionWithSortableElements ] 245392 raise: Error. 245393 self shouldnt: [self collectionWithSortableElements anyOne < self collectionWithSortableElements anyOne] raise: Error. 245394 result := self collectionWithSortableElements sortBy: [ :a :b | a < b ]. 245395 245396 "verify content of 'result' : " 245397 result do: 245398 [ :each | 245399 (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 245400 tmp := result first. 245401 result do: 245402 [ :each | 245403 self assert: each >= tmp. 245404 tmp := each ]. 245405 245406 "verify size of 'result' :" 245407 self assert: result size = self collectionWithSortableElements size! ! 245408 245409 245410!OrderedCollectionTest methodsFor: 'tests - copying with or without'! 245411testCopyWithFirst 245412 245413 | index element result | 245414 index:= self indexInNonEmpty . 245415 element:= self nonEmpty at: index. 245416 245417 result := self nonEmpty copyWithFirst: element. 245418 245419 self assert: result size = (self nonEmpty size + 1). 245420 self assert: result first = element . 245421 245422 2 to: result size do: 245423 [ :i | 245424 self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! 245425 245426!OrderedCollectionTest methodsFor: 'tests - copying with or without'! 245427testCopyWithSequenceable 245428 245429 | result index element | 245430 index := self indexInNonEmpty . 245431 element := self nonEmpty at: index. 245432 result := self nonEmpty copyWith: (element ). 245433 245434 self assert: result size = (self nonEmpty size + 1). 245435 self assert: result last = element . 245436 245437 1 to: (result size - 1) do: 245438 [ :i | 245439 self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! 245440 245441!OrderedCollectionTest methodsFor: 'tests - copying with or without'! 245442testCopyWithoutFirst 245443 245444 | result | 245445 result := self nonEmpty copyWithoutFirst. 245446 245447 self assert: result size = (self nonEmpty size - 1). 245448 245449 1 to: result size do: 245450 [:i | 245451 self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! 245452 245453!OrderedCollectionTest methodsFor: 'tests - copying with or without'! 245454testCopyWithoutIndex 245455 | result index | 245456 index := self indexInNonEmpty . 245457 result := self nonEmpty copyWithoutIndex: index . 245458 245459 "verify content of 'result:'" 245460 1 to: result size do: 245461 [:i | 245462 i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. 245463 i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. 245464 245465 "verify size of result : " 245466 self assert: result size=(self nonEmpty size -1).! ! 245467 245468 245469!OrderedCollectionTest methodsFor: 'tests - copying with replacement'! 245470firstIndexesOf: subCollection in: collection 245471" return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " 245472 | tmp result currentIndex | 245473 tmp:= collection. 245474 result:= OrderedCollection new. 245475 currentIndex := 1. 245476 245477 [tmp isEmpty ]whileFalse: 245478 [ 245479 (tmp beginsWith: subCollection) 245480 ifTrue: [ 245481 result add: currentIndex. 245482 1 to: subCollection size do: 245483 [:i | 245484 tmp := tmp copyWithoutFirst. 245485 currentIndex := currentIndex + 1] 245486 ] 245487 ifFalse: [ 245488 tmp := tmp copyWithoutFirst. 245489 currentIndex := currentIndex +1. 245490 ] 245491 ]. 245492 245493 ^ result. 245494 ! ! 245495 245496!OrderedCollectionTest methodsFor: 'tests - copying with replacement'! 245497testCopyReplaceAllWith1Occurence 245498 | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | 245499 245500 result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 245501 245502 "detecting indexes of olSubCollection" 245503 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . 245504 index:= firstIndexesOfOccurrence at: 1. 245505 245506 "verify content of 'result' : " 245507 "first part of 'result'' : '" 245508 245509 1 to: (index -1) do: 245510 [ 245511 :i | 245512 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 245513 ]. 245514 245515 " middle part containing replacementCollection : " 245516 245517 index to: (index + self replacementCollection size-1) do: 245518 [ 245519 :i | 245520 self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) 245521 ]. 245522 245523 " end part :" 245524 245525 endPartIndexResult := index + self replacementCollection size . 245526 endPartIndexCollection := index + self oldSubCollection size . 245527 245528 1 to: (result size - endPartIndexResult - 1 ) do: 245529 [ 245530 :i | 245531 self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). 245532 ]. 245533 245534 245535 ! ! 245536 245537!OrderedCollectionTest methodsFor: 'tests - copying with replacement'! 245538testCopyReplaceAllWithManyOccurence 245539 | result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff | 245540 " testing fixture here as this method may be not used for collection that can't contain equals element :" 245541 self shouldnt: [self collectionWith2TimeSubcollection ]raise: Error. 245542 self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection ) = 2. 245543 245544 " test :" 245545 diff := self replacementCollection size - self oldSubCollection size. 245546 result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 245547 245548 "detecting indexes of olSubCollection" 245549 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection . 245550 245551 " verifying that replacementCollection has been put in places of oldSubCollections " 245552 firstIndexesOfOccurrence do: [ 245553 :each | 245554 (firstIndexesOfOccurrence indexOf: each) = 1 245555 ifTrue: [ 245556 each to: self replacementCollection size do: 245557 [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. 245558 ] 245559 ifFalse:[ 245560 (each + diff) to: self replacementCollection size do: 245561 [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. 245562 ]. 245563 245564 ]. 245565 245566 " verifying that the 'between' parts correspond to the initial collection : " 245567 1 to: firstIndexesOfOccurrence size do: [ 245568 :i | 245569 i = 1 245570 " specific comportement for the begining of the collection :" 245571 ifTrue: [ 245572 1 to: ((firstIndexesOfOccurrence at: i) - 1 ) do: 245573 [ :j | 245574 self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] 245575 ] 245576 " between parts till the end : " 245577 ifFalse: [ 245578 resultBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self replacementCollection size. 245579 collectionBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self oldSubCollection size. 245580 245581 1 to: ( firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: 245582 [ :j | 245583 self assert: (result at: (resultBetweenPartIndex + i - 1)) = (self collectionWith2TimeSubcollection at: (collectionBetweenPartIndex +i - 1)) ] 245584 ] 245585 ]. 245586 245587 "final part :" 245588 1 to: (self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size ) ) do: 245589 [ 245590 :i | 245591 self assert: ( result at:(firstIndexesOfOccurrence last + self replacementCollection size -1) + i ) = ( self collectionWith2TimeSubcollection at:(firstIndexesOfOccurrence last + self oldSubCollection size -1) + i ) . 245592 ]! ! 245593 245594!OrderedCollectionTest methodsFor: 'tests - copying with replacement'! 245595testCopyReplaceFromToWithInsertion 245596 | result indexOfSubcollection | 245597 245598 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 245599 245600 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . 245601 245602 "verify content of 'result' : " 245603 "first part of 'result'' : '" 245604 245605 1 to: (indexOfSubcollection -1) do: 245606 [ 245607 :i | 245608 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 245609 ]. 245610 245611 " middle part containing replacementCollection : " 245612 indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: 245613 [ 245614 :i | 245615 self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) 245616 ]. 245617 245618 " end part :" 245619 (indexOfSubcollection + self replacementCollection size) to: (result size) do: 245620 [:i| 245621 self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. 245622 245623 " verify size: " 245624 self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). 245625 245626 245627 245628 245629 245630 ! ! 245631 245632 245633!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245634testAfter 245635 "self debug: #testAfter" 245636 self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). 245637 self 245638 should: 245639 [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] 245640 raise: Error. 245641 self 245642 should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] 245643 raise: Error! ! 245644 245645!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245646testAfterIfAbsent 245647 "self debug: #testAfterIfAbsent" 245648 self assert: (self moreThan4Elements 245649 after: (self moreThan4Elements at: 1) 245650 ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). 245651 self assert: (self moreThan4Elements 245652 after: (self moreThan4Elements at: self moreThan4Elements size) 245653 ifAbsent: [ 33 ]) == 33. 245654 self assert: (self moreThan4Elements 245655 after: self elementNotInForElementAccessing 245656 ifAbsent: [ 33 ]) = 33! ! 245657 245658!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245659testAtAll 245660 "self debug: #testAtAll" 245661 " self flag: #theCollectionshouldbe102030intheFixture. 245662 245663 self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. 245664 self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." 245665 | result | 245666 result := self moreThan4Elements atAll: #(2 1 2 ). 245667 self assert: (result at: 1) = (self moreThan4Elements at: 2). 245668 self assert: (result at: 2) = (self moreThan4Elements at: 1). 245669 self assert: (result at: 3) = (self moreThan4Elements at: 2). 245670 self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! 245671 245672!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245673testAtIfAbsent 245674 "self debug: #testAt" 245675 | absent | 245676 absent := false. 245677 self moreThan4Elements 245678 at: self moreThan4Elements size + 1 245679 ifAbsent: [ absent := true ]. 245680 self assert: absent = true. 245681 absent := false. 245682 self moreThan4Elements 245683 at: self moreThan4Elements size 245684 ifAbsent: [ absent := true ]. 245685 self assert: absent = false! ! 245686 245687!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245688testAtLast 245689 "self debug: #testAtLast" 245690 | index | 245691 self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. 245692 "tmp:=1. 245693 self do: 245694 [:each | 245695 each =self elementInForIndexAccessing 245696 ifTrue:[index:=tmp]. 245697 tmp:=tmp+1]." 245698 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 245699 self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! 245700 245701!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245702testAtLastError 245703 "self debug: #testAtLast" 245704 self 245705 should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] 245706 raise: Error! ! 245707 245708!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245709testAtLastIfAbsent 245710 "self debug: #testAtLastIfAbsent" 245711 self assert: (self moreThan4Elements 245712 atLast: 1 245713 ifAbsent: [ nil ]) = self moreThan4Elements last. 245714 self assert: (self moreThan4Elements 245715 atLast: self moreThan4Elements size + 1 245716 ifAbsent: [ 222 ]) = 222! ! 245717 245718!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245719testAtOutOfBounds 245720 "self debug: #testAtOutOfBounds" 245721 self 245722 should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] 245723 raise: Error. 245724 self 245725 should: [ self moreThan4Elements at: -1 ] 245726 raise: Error! ! 245727 245728!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245729testAtPin 245730 "self debug: #testAtPin" 245731 self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. 245732 self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. 245733 self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! 245734 245735!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245736testAtRandom 245737 | result | 245738 result := self nonEmpty atRandom . 245739 self assert: (self nonEmpty includes: result).! ! 245740 245741!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245742testAtWrap 245743 "self debug: #testAt" 245744 " 245745 self assert: (self accessCollection at: 1) = 1. 245746 self assert: (self accessCollection at: 2) = 2. 245747 " 245748 | index | 245749 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 245750 self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. 245751 self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. 245752 self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. 245753 self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! 245754 245755!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245756testBefore 245757 "self debug: #testBefore" 245758 self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). 245759 self 245760 should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] 245761 raise: Error. 245762 self 245763 should: [ self moreThan4Elements before: 66 ] 245764 raise: Error! ! 245765 245766!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245767testBeforeIfAbsent 245768 "self debug: #testBefore" 245769 self assert: (self moreThan4Elements 245770 before: (self moreThan4Elements at: 1) 245771 ifAbsent: [ 99 ]) = 99. 245772 self assert: (self moreThan4Elements 245773 before: (self moreThan4Elements at: 2) 245774 ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! 245775 245776!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245777testFirstSecondThird 245778 "self debug: #testFirstSecondThird" 245779 self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). 245780 self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). 245781 self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). 245782 self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! 245783 245784!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245785testLast 245786 "self debug: #testLast" 245787 self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! 245788 245789!OrderedCollectionTest methodsFor: 'tests - element accessing'! 245790testMiddle 245791 "self debug: #testMiddle" 245792 self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! 245793 245794 245795!OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: 'sd 3/21/2006 22:41'! 245796testCollect 245797 "Allows one to collect some element of a collection into another collection" 245798 "self run: #testCollect" 245799 245800 | c1 c2 res | 245801 c1 := #(-1 2 -3 4) asOrderedCollection. 245802 c2 := #(1 2 3 4) asOrderedCollection. 245803 res := c1 collect: [:each | each abs]. 245804 self assert: (c2 = res).! ! 245805 245806!OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: 'cm 3/8/2006 09:09'! 245807testCollectFromTo 245808 "Allows one to collect some element of a collection into another collection between a first index and an end index for the collect" 245809 "self run: #testCollectFromTo" 245810 245811 | c1 res | 245812 c1 := #(-1 2 -3 4 -5 6 -7 8) asOrderedCollection. 245813 res := c1 collect: [:each | each abs] from: 1 to: 3. 245814 self assert: (res = #(1 2 3) asOrderedCollection). 245815 self should: [c1 collect: [:each | each abs] from: 10 to: 13] raise: Error. 245816 self should: [c1 collect: [:each | each abs] from: 5 to: 2] raise: Error.! ! 245817 245818!OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: 'sd 6/5/2005 09:21'! 245819testIndexOfWithDuplicates 245820 245821 | collection indices bagOfIndices | 245822 collection := #('Jim' 'Mary' 'John' 'Andrew' 'Mary' 'John' 'Jim' 'Micheal') asOrderedCollection. 245823 indices := collection collect: [:item | collection indexOf: item]. 245824 self assert: indices asSet size = collection asSet size. 245825 bagOfIndices := indices asBag. 245826 self assert: (indices asSet 245827 allSatisfy: [:index | (bagOfIndices occurrencesOf: index) 245828 = (collection occurrencesOf: (collection at: index))]). 245829 245830 " indexOf: returns the index of the first occurrence of an item. 245831 For an item with n occurrences, the index of its first occurrence 245832 is found n times. "! ! 245833 245834!OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: 'cm 3/8/2006 10:02'! 245835testWithCollect 245836 "Allows one to collect some element of two collections into another collection with element corresponding to the condition in the blocks" 245837 "self run: #testWithCollect" 245838 245839 | c1 c2 res | 245840 c1 := #(-1 2 -3 4 -5 6 -7 8) asOrderedCollection. 245841 c2 := #(-9 10 -11 12 -13 14 -15 16) asOrderedCollection. 245842 res := c1 with: c2 collect: [:each1 :each2 | each1 < each2 245843 ifTrue: [each1] 245844 ifFalse: [each2]]. 245845 self assert: (res = #(-9 2 -11 4 -13 6 -15 8) asOrderedCollection). 245846 ! ! 245847 245848 245849!OrderedCollectionTest methodsFor: 'tests - equality'! 245850testEqualSignForSequenceableCollections 245851 "self debug: #testEqualSign" 245852 245853 self deny: (self nonEmpty = self nonEmpty asSet). 245854 self deny: (self nonEmpty reversed = self nonEmpty). 245855 self deny: (self nonEmpty = self nonEmpty reversed).! ! 245856 245857!OrderedCollectionTest methodsFor: 'tests - equality'! 245858testHasEqualElements 245859 "self debug: #testHasEqualElements" 245860 245861 self deny: (self empty hasEqualElements: self nonEmpty). 245862 self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). 245863 self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). 245864 self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! 245865 245866!OrderedCollectionTest methodsFor: 'tests - equality'! 245867testHasEqualElementsIsTrueForNonIdenticalButEqualCollections 245868 "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" 245869 245870 self assert: (self empty hasEqualElements: self empty copy). 245871 self assert: (self empty copy hasEqualElements: self empty). 245872 self assert: (self empty copy hasEqualElements: self empty copy). 245873 245874 self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). 245875 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). 245876 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! 245877 245878!OrderedCollectionTest methodsFor: 'tests - equality'! 245879testHasEqualElementsOfIdenticalCollectionObjects 245880 "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" 245881 245882 self assert: (self empty hasEqualElements: self empty). 245883 self assert: (self nonEmpty hasEqualElements: self nonEmpty). 245884 ! ! 245885 245886 245887!OrderedCollectionTest methodsFor: 'tests - fixture'! 245888howMany: subCollection in: collection 245889" return an integer representing how many time 'subCollection' appears in 'collection' " 245890 | tmp nTime | 245891 tmp:= collection. 245892 nTime:= 0. 245893 245894 [tmp isEmpty ]whileFalse: 245895 [ 245896 (tmp beginsWith: subCollection) 245897 ifTrue: [ 245898 nTime := nTime + 1. 245899 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] 245900 ] 245901 ifFalse: [tmp := tmp copyWithoutFirst.] 245902 ]. 245903 245904 ^ nTime. 245905 ! ! 245906 245907!OrderedCollectionTest methodsFor: 'tests - fixture'! 245908test0CopyTest 245909 self shouldnt: [ self empty ]raise: Error. 245910 self assert: self empty size = 0. 245911 self shouldnt: [ self nonEmpty ]raise: Error. 245912 self assert: (self nonEmpty size = 0) not. 245913 self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. 245914 self assert: (self collectionWithElementsToRemove size = 0) not. 245915 self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. 245916 245917 self shouldnt: [ self elementToAdd ]raise: Error. 245918 self deny: (self nonEmpty includes: self elementToAdd ). 245919 self shouldnt: [ self collectionNotIncluded ]raise: Error. 245920 self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! 245921 245922!OrderedCollectionTest methodsFor: 'tests - fixture'! 245923test0FixtureAsSetForIdentityMultiplinessTest 245924 245925 "a collection (of elements for which copy is not identical ) without equal elements:" 245926 | element res | 245927 self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ]raise: Error. 245928 element := self elementsCopyNonIdenticalWithoutEqualElements anyOne. 245929 self deny: element copy == element . 245930 245931 res := true. 245932 self elementsCopyNonIdenticalWithoutEqualElements 245933 detect: 245934 [ :each | 245935 (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] 245936 ifNone: [ res := false ]. 245937 self assert: res = false 245938 245939 ! ! 245940 245941!OrderedCollectionTest methodsFor: 'tests - fixture'! 245942test0FixtureAsStringCommaAndDelimiterTest 245943 245944 self shouldnt: [self nonEmpty] raise:Error . 245945 self deny: self nonEmpty isEmpty. 245946 245947 self shouldnt: [self empty] raise:Error . 245948 self assert: self empty isEmpty. 245949 245950 self shouldnt: [self nonEmpty1Element ] raise:Error . 245951 self assert: self nonEmpty1Element size=1.! ! 245952 245953!OrderedCollectionTest methodsFor: 'tests - fixture'! 245954test0FixtureBeginsEndsWithTest 245955 245956 self shouldnt: [self nonEmpty ] raise: Error. 245957 self deny: self nonEmpty isEmpty. 245958 self assert: self nonEmpty size>1. 245959 245960 self shouldnt: [self empty ] raise: Error. 245961 self assert: self empty isEmpty.! ! 245962 245963!OrderedCollectionTest methodsFor: 'tests - fixture'! 245964test0FixtureCloneTest 245965 245966self shouldnt: [ self nonEmpty ] raise: Error. 245967self deny: self nonEmpty isEmpty. 245968 245969self shouldnt: [ self empty ] raise: Error. 245970self assert: self empty isEmpty. 245971 245972! ! 245973 245974!OrderedCollectionTest methodsFor: 'tests - fixture'! 245975test0FixtureConverAsSortedTest 245976 245977 self shouldnt: [self collectionWithSortableElements ] raise: Error. 245978 self deny: self collectionWithSortableElements isEmpty .! ! 245979 245980!OrderedCollectionTest methodsFor: 'tests - fixture'! 245981test0FixtureCopyPartOfForMultipliness 245982 245983self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. 245984 245985self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 245986 245987self assert: self collectionWithSameAtEndAndBegining size > 1. 245988 2459891 to: self collectionWithSameAtEndAndBegining size do: 245990 [:i | 245991 (i > 1 ) & (i < self collectionWithSameAtEndAndBegining size) 245992 ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at:i) = (self collectionWithSameAtEndAndBegining first)]. 245993 ]! ! 245994 245995!OrderedCollectionTest methodsFor: 'tests - fixture'! 245996test0FixtureCopyPartOfSequenceableTest 245997 245998 self shouldnt: [self collectionWithoutEqualsElements ] raise: Error. 245999 self collectionWithoutEqualsElements do: 246000 [:each | self assert: (self collectionWithoutEqualsElements occurrencesOf: each)=1]. 246001 246002 self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. 246003 self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualsElements size. 246004 246005 self shouldnt: [self empty] raise: Error. 246006 self assert: self empty isEmpty .! ! 246007 246008!OrderedCollectionTest methodsFor: 'tests - fixture'! 246009test0FixtureCopySameContentsTest 246010 246011 self shouldnt: [self nonEmpty ] raise: Error. 246012 self deny: self nonEmpty isEmpty. 246013 246014 self shouldnt: [self empty ] raise: Error. 246015 self assert: self empty isEmpty. 246016 246017! ! 246018 246019!OrderedCollectionTest methodsFor: 'tests - fixture'! 246020test0FixtureCopyWithOrWithoutSpecificElementsTest 246021 246022 self shouldnt: [self nonEmpty ] raise: Error. 246023 self deny: self nonEmpty isEmpty . 246024 246025 self shouldnt: [self indexInNonEmpty ] raise: Error. 246026 self assert: self indexInNonEmpty > 0. 246027 self assert: self indexInNonEmpty <= self nonEmpty size.! ! 246028 246029!OrderedCollectionTest methodsFor: 'tests - fixture'! 246030test0FixtureCopyWithReplacementTest 246031 246032 self shouldnt: [self replacementCollection ]raise: Error. 246033 self shouldnt: [self oldSubCollection] raise: Error. 246034 246035 self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. 246036 self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. 246037 246038 ! ! 246039 246040!OrderedCollectionTest methodsFor: 'tests - fixture'! 246041test0FixtureCreationWithTest 246042 246043self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. 246044self assert: self collectionMoreThan5Elements size >= 5.! ! 246045 246046!OrderedCollectionTest methodsFor: 'tests - fixture'! 246047test0FixtureEmptySequenceableTest 246048 246049self shouldnt: [ self nonEmpty ] raise: Error. 246050self deny: self nonEmpty isEmpty . 246051 246052self shouldnt: [ self empty ] raise: Error. 246053self assert: self empty isEmpty.! ! 246054 246055!OrderedCollectionTest methodsFor: 'tests - fixture'! 246056test0FixtureIncludeTest 246057 | elementIn | 246058 self shouldnt: [ self nonEmpty ]raise: Error. 246059 self deny: self nonEmpty isEmpty. 246060 246061 self shouldnt: [ self elementNotIn ]raise: Error. 246062 246063 elementIn := true. 246064 self nonEmpty detect: 246065 [ :each | each = self elementNotIn ] 246066 ifNone: [ elementIn := false ]. 246067 self assert: elementIn = false. 246068 246069 self shouldnt: [ self anotherElementNotIn ]raise: Error. 246070 246071 elementIn := true. 246072 self nonEmpty detect: 246073 [ :each | each = self anotherElementNotIn ] 246074 ifNone: [ elementIn := false ]. 246075 self assert: elementIn = false. 246076 246077 self shouldnt: [ self empty ] raise: Error. 246078 self assert: self empty isEmpty. 246079 246080! ! 246081 246082!OrderedCollectionTest methodsFor: 'tests - fixture'! 246083test0FixtureIncludeWithIdentityTest 246084 | element | 246085 self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. 246086 element := self collectionWithCopyNonIdentical anyOne. 246087 self deny: element == element copy. 246088! ! 246089 246090!OrderedCollectionTest methodsFor: 'tests - fixture'! 246091test0FixtureIndexAccessFotMultipliness 246092 self 246093 shouldnt: [ self collectionWithSameAtEndAndBegining ] 246094 raise: Error. 246095 self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 246096 self assert: self collectionWithSameAtEndAndBegining size > 1. 246097 1 to: self collectionWithSameAtEndAndBegining size 246098 do: 246099 [ :i | 246100 i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: 246101 [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! 246102 246103!OrderedCollectionTest methodsFor: 'tests - fixture'! 246104test0FixtureIndexAccessTest 246105 | res collection element | 246106 self 246107 shouldnt: [ self collectionMoreThan1NoDuplicates ] 246108 raise: Error. 246109 self assert: self collectionMoreThan1NoDuplicates size >1. 246110 res := true. 246111 self collectionMoreThan1NoDuplicates 246112 detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] 246113 ifNone: [ res := false ]. 246114 self assert: res = false. 246115 self 246116 shouldnt: [ self elementInForIndexAccessing ] 246117 raise: Error. 246118 self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). 246119 self 246120 shouldnt: [ self elementNotInForIndexAccessing ] 246121 raise: Error. 246122 self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! 246123 246124!OrderedCollectionTest methodsFor: 'tests - fixture'! 246125test0FixtureIterateSequencedReadableTest 246126 246127 | res | 246128 246129 self shouldnt: self nonEmptyMoreThan1Element raise: Error. 246130 self assert: self nonEmptyMoreThan1Element size > 1. 246131 246132 246133 self shouldnt: self empty raise: Error. 246134 self assert: self empty isEmpty . 246135 246136 res := true. 246137 self nonEmptyMoreThan1Element 246138 detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] 246139 ifNone: [ res := false ]. 246140 self assert: res = false.! ! 246141 246142!OrderedCollectionTest methodsFor: 'tests - fixture'! 246143test0FixtureOccurrencesForMultiplinessTest 246144 | cpt element collection | 246145 self shouldnt: [self collectionWithEqualElements ]raise: Error. 246146self shouldnt: [self collectionWithEqualElements ]raise: Error. 246147 246148self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 246149element := self elementTwiceInForOccurrences . 246150collection := self collectionWithEqualElements . 246151 246152cpt := 0 . 246153" testing with identity check ( == ) so that identy collections can use this trait : " 246154self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. 246155self assert: cpt = 2.! ! 246156 246157!OrderedCollectionTest methodsFor: 'tests - fixture'! 246158test0FixtureOccurrencesTest 246159 | tmp | 246160 self shouldnt: [self empty ]raise: Error. 246161 self assert: self empty isEmpty. 246162 246163 self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. 246164 self deny: self collectionWithoutEqualElements isEmpty. 246165 246166 tmp := OrderedCollection new. 246167 self collectionWithoutEqualElements do: [ 246168 :each | 246169 self deny: (tmp includes: each). 246170 tmp add: each. 246171 ]. 246172 246173 246174 self shouldnt: [ self elementNotInForOccurrences ] raise: Error. 246175 self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! 246176 246177!OrderedCollectionTest methodsFor: 'tests - fixture'! 246178test0FixturePrintTest 246179 246180 self shouldnt: [self nonEmpty ] raise: Error.! ! 246181 246182!OrderedCollectionTest methodsFor: 'tests - fixture'! 246183test0FixturePutOneOrMoreElementsTest 246184 self shouldnt: self aValue raise: Error. 246185 246186 246187 self shouldnt: self indexArray raise: Error. 246188 self indexArray do: [ 246189 :each| 246190 self assert: each class = SmallInteger. 246191 self assert: (each>=1 & each<= self nonEmpty size). 246192 ]. 246193 246194 self assert: self indexArray size = self valueArray size. 246195 246196 self shouldnt: self empty raise: Error. 246197 self assert: self empty isEmpty . 246198 246199 self shouldnt: self nonEmpty raise: Error. 246200 self deny: self nonEmpty isEmpty.! ! 246201 246202!OrderedCollectionTest methodsFor: 'tests - fixture'! 246203test0FixturePutTest 246204 self shouldnt: self aValue raise: Error. 246205 self shouldnt: self anotherValue raise: Error. 246206 246207 self shouldnt: self anIndex raise: Error. 246208 self nonEmpty isDictionary 246209 ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. 246210 246211 self shouldnt: self empty raise: Error. 246212 self assert: self empty isEmpty . 246213 246214 self shouldnt: self nonEmpty raise: Error. 246215 self deny: self nonEmpty isEmpty.! ! 246216 246217!OrderedCollectionTest methodsFor: 'tests - fixture'! 246218test0FixtureRequirementsOfTAddTest 246219 self 246220 shouldnt: [ self collectionWithElement ] 246221 raise: Exception. 246222 self 246223 shouldnt: [ self otherCollection ] 246224 raise: Exception. 246225 self 246226 shouldnt: [ self element ] 246227 raise: Exception. 246228 self assert: (self collectionWithElement includes: self element). 246229 self deny: (self otherCollection includes: self element)! ! 246230 246231!OrderedCollectionTest methodsFor: 'tests - fixture'! 246232test0FixtureSequencedConcatenationTest 246233 self 246234 shouldnt: self empty 246235 raise: Exception. 246236 self assert: self empty isEmpty. 246237 self 246238 shouldnt: self firstCollection 246239 raise: Exception. 246240 self 246241 shouldnt: self secondCollection 246242 raise: Exception! ! 246243 246244!OrderedCollectionTest methodsFor: 'tests - fixture'! 246245test0FixtureSequencedElementAccessTest 246246 self 246247 shouldnt: [ self moreThan4Elements ] 246248 raise: Error. 246249 self assert: self moreThan4Elements size >= 4. 246250 self 246251 shouldnt: [ self subCollectionNotIn ] 246252 raise: Error. 246253 self subCollectionNotIn 246254 detect: [ :each | (self moreThan4Elements includes: each) not ] 246255 ifNone: [ self assert: false ]. 246256 self 246257 shouldnt: [ self elementNotInForElementAccessing ] 246258 raise: Error. 246259 self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). 246260 self 246261 shouldnt: [ self elementInForElementAccessing ] 246262 raise: Error. 246263 self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! 246264 246265!OrderedCollectionTest methodsFor: 'tests - fixture'! 246266test0FixtureSetAritmeticTest 246267 self 246268 shouldnt: [ self collection ] 246269 raise: Error. 246270 self deny: self collection isEmpty. 246271 self 246272 shouldnt: [ self nonEmpty ] 246273 raise: Error. 246274 self deny: self nonEmpty isEmpty. 246275 self 246276 shouldnt: [ self anotherElementOrAssociationNotIn ] 246277 raise: Error. 246278 self collection isDictionary 246279 ifTrue: 246280 [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] 246281 ifFalse: 246282 [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. 246283 self 246284 shouldnt: [ self collectionClass ] 246285 raise: Error! ! 246286 246287!OrderedCollectionTest methodsFor: 'tests - fixture'! 246288test0FixtureSubcollectionAccessTest 246289 self 246290 shouldnt: [ self moreThan3Elements ] 246291 raise: Error. 246292 self assert: self moreThan3Elements size > 2! ! 246293 246294!OrderedCollectionTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/28/2009 14:11'! 246295test0FixtureTConvertAsSetForMultiplinessTest 246296 "a collection ofFloat with equal elements:" 246297 | res | 246298 self 246299 shouldnt: [ self withEqualElements ] 246300 raise: Error. 246301 self 246302 shouldnt: 246303 [ self withEqualElements do: [ :each | self assert: each class = Float ] ] 246304 raise: Error. 246305 res := true. 246306 self withEqualElements 246307 detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] 246308 ifNone: [ res := false ]. 246309 self assert: res = true. 246310 246311 "a collection of Float without equal elements:" 246312 self 246313 shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ] 246314 raise: Error. 246315 self 246316 shouldnt: 246317 [ self elementsCopyNonIdenticalWithoutEqualElements do: [ :each | self assert: each class = Float ] ] 246318 raise: Error. 246319 res := true. 246320 self elementsCopyNonIdenticalWithoutEqualElements 246321 detect: 246322 [ :each | 246323 (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] 246324 ifNone: [ res := false ]. 246325 self assert: res = false! ! 246326 246327!OrderedCollectionTest methodsFor: 'tests - fixture'! 246328test0FixtureTConvertTest 246329 "a collection of number without equal elements:" 246330 | res | 246331 self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. 246332 246333 res := true. 246334 self collectionWithoutEqualElements 246335 detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] 246336 ifNone: [ res := false ]. 246337 self assert: res = false. 246338 246339 246340! ! 246341 246342!OrderedCollectionTest methodsFor: 'tests - fixture'! 246343test0FixtureTRemoveTest 246344 | duplicate | 246345 self shouldnt: [ self empty ]raise: Error. 246346 self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. 246347 self deny: self nonEmptyWithoutEqualElements isEmpty. 246348 duplicate := true. 246349 self nonEmptyWithoutEqualElements detect: 246350 [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] 246351 ifNone: [duplicate := false]. 246352 self assert: duplicate = false. 246353 246354 246355 self shouldnt: [ self elementNotIn ] raise: Error. 246356 self assert: self empty isEmpty. 246357 self deny: self nonEmptyWithoutEqualElements isEmpty. 246358 self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! 246359 246360!OrderedCollectionTest methodsFor: 'tests - fixture'! 246361test0TSequencedStructuralEqualityTest 246362 246363 self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! 246364 246365!OrderedCollectionTest methodsFor: 'tests - fixture'! 246366test0TStructuralEqualityTest 246367 self shouldnt: [self empty] raise: Error. 246368 self shouldnt: [self nonEmpty] raise: Error. 246369 self assert: self empty isEmpty. 246370 self deny: self nonEmpty isEmpty.! ! 246371 246372!OrderedCollectionTest methodsFor: 'tests - fixture'! 246373testOFixtureReplacementSequencedTest 246374 246375 self shouldnt: self nonEmpty raise: Error. 246376 self deny: self nonEmpty isEmpty. 246377 246378 self shouldnt: self elementInForReplacement raise: Error. 246379 self assert: (self nonEmpty includes: self elementInForReplacement ) . 246380 246381 self shouldnt: self newElement raise: Error. 246382 246383 self shouldnt: self firstIndex raise: Error. 246384 self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). 246385 246386 self shouldnt: self secondIndex raise: Error. 246387 self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). 246388 246389 self assert: self firstIndex <=self secondIndex . 246390 246391 self shouldnt: self replacementCollection raise: Error. 246392 246393 self shouldnt: self replacementCollectionSameSize raise: Error. 246394 self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size 246395 ! ! 246396 246397 246398!OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:57'! 246399anotherElementNotIn 246400 ^ 42! ! 246401 246402!OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 246403elementNotInForOccurrences 246404 ^ 666! ! 246405 246406!OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! 246407testIdentityIncludes 246408 " test the comportement in presence of elements 'includes' but not 'identityIncludes' " 246409 " can not be used by collections that can't include elements for wich copy doesn't return another instance " 246410 | collection element | 246411 self 246412 shouldnt: [ self collectionWithCopyNonIdentical ] 246413 raise: Error. 246414 collection := self collectionWithCopyNonIdentical. 246415 element := collection anyOne copy. 246416 "self assert: (collection includes: element)." 246417 self deny: (collection identityIncludes: element)! ! 246418 246419!OrderedCollectionTest methodsFor: 'tests - includes'! 246420testIdentityIncludesNonSpecificComportement 246421 " test the same comportement than 'includes: ' " 246422 | collection | 246423 collection := self nonEmpty . 246424 246425 self deny: (collection identityIncludes: self elementNotIn ). 246426 self assert:(collection identityIncludes: collection anyOne) 246427! ! 246428 246429!OrderedCollectionTest methodsFor: 'tests - includes'! 246430testIncludesAllOfAllThere 246431 "self debug: #testIncludesAllOfAllThere'" 246432 self assert: (self empty includesAllOf: self empty). 246433 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 246434 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 246435 246436!OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 246437testIncludesAllOfNoneThere 246438 "self debug: #testIncludesAllOfNoneThere'" 246439 self deny: (self empty includesAllOf: self collection). 246440 self deny: (self nonEmpty includesAllOf: { 246441 (self elementNotIn). 246442 (self anotherElementNotIn) 246443 })! ! 246444 246445!OrderedCollectionTest methodsFor: 'tests - includes'! 246446testIncludesAnyOfAllThere 246447 "self debug: #testIncludesAnyOfAllThere'" 246448 self deny: (self nonEmpty includesAnyOf: self empty). 246449 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 246450 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 246451 246452!OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 246453testIncludesAnyOfNoneThere 246454 "self debug: #testIncludesAnyOfNoneThere'" 246455 self deny: (self nonEmpty includesAnyOf: self empty). 246456 self deny: (self nonEmpty includesAnyOf: { 246457 (self elementNotIn). 246458 (self anotherElementNotIn) 246459 })! ! 246460 246461!OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 246462testIncludesElementIsNotThere 246463 "self debug: #testIncludesElementIsNotThere" 246464 self deny: (self nonEmpty includes: self elementNotInForOccurrences). 246465 self assert: (self nonEmpty includes: self nonEmpty anyOne). 246466 self deny: (self empty includes: self elementNotInForOccurrences)! ! 246467 246468!OrderedCollectionTest methodsFor: 'tests - includes'! 246469testIncludesElementIsThere 246470 "self debug: #testIncludesElementIsThere" 246471 246472 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 246473 246474!OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'delaunay 4/9/2009 10:44'! 246475testIncludesSubstringAnywhere 246476 "self debug: #testIncludesSubstringAnywher'" 246477 self assert: (self empty includesAllOf: self empty). 246478 self assert: (self nonEmpty includesAllOf: { (self nonEmpty anyOne) }). 246479 self assert: (self nonEmpty includesAllOf: self nonEmpty)! ! 246480 246481 246482!OrderedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 246483testIdentityIndexOf 246484 "self debug: #testIdentityIndexOf" 246485 | collection element | 246486 collection := self collectionMoreThan1NoDuplicates. 246487 element := collection first. 246488 self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! 246489 246490!OrderedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 246491testIdentityIndexOfIAbsent 246492 | collection element | 246493 collection := self collectionMoreThan1NoDuplicates. 246494 element := collection first. 246495 self assert: (collection 246496 identityIndexOf: element 246497 ifAbsent: [ 0 ]) = 1. 246498 self assert: (collection 246499 identityIndexOf: self elementNotInForIndexAccessing 246500 ifAbsent: [ 55 ]) = 55! ! 246501 246502!OrderedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 246503testIndexOf 246504 "self debug: #testIndexOf" 246505 | tmp index collection | 246506 collection := self collectionMoreThan1NoDuplicates. 246507 tmp := collection size. 246508 collection reverseDo: 246509 [ :each | 246510 each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. 246511 tmp := tmp - 1 ]. 246512 self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! 246513 246514!OrderedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 246515testIndexOfIfAbsent 246516 "self debug: #testIndexOfIfAbsent" 246517 | collection | 246518 collection := self collectionMoreThan1NoDuplicates. 246519 self assert: (collection 246520 indexOf: collection first 246521 ifAbsent: [ 33 ]) = 1. 246522 self assert: (collection 246523 indexOf: self elementNotInForIndexAccessing 246524 ifAbsent: [ 33 ]) = 33! ! 246525 246526!OrderedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 246527testIndexOfStartingAt 246528 "self debug: #testLastIndexOf" 246529 | element collection | 246530 collection := self collectionMoreThan1NoDuplicates. 246531 element := collection first. 246532 self assert: (collection 246533 indexOf: element 246534 startingAt: 2 246535 ifAbsent: [ 99 ]) = 99. 246536 self assert: (collection 246537 indexOf: element 246538 startingAt: 1 246539 ifAbsent: [ 99 ]) = 1. 246540 self assert: (collection 246541 indexOf: self elementNotInForIndexAccessing 246542 startingAt: 1 246543 ifAbsent: [ 99 ]) = 99! ! 246544 246545!OrderedCollectionTest methodsFor: 'tests - index access'! 246546testIndexOfStartingAtIfAbsent 246547 "self debug: #testLastIndexOf" 246548 | element collection | 246549 collection := self collectionMoreThan1NoDuplicates. 246550 element := collection first. 246551 self assert: (collection 246552 indexOf: element 246553 startingAt: 2 246554 ifAbsent: [ 99 ]) = 99. 246555 self assert: (collection 246556 indexOf: element 246557 startingAt: 1 246558 ifAbsent: [ 99 ]) = 1. 246559 self assert: (collection 246560 indexOf: self elementNotInForIndexAccessing 246561 startingAt: 1 246562 ifAbsent: [ 99 ]) = 99! ! 246563 246564!OrderedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 246565testIndexOfSubCollectionStartingAt 246566 "self debug: #testIndexOfIfAbsent" 246567 | subcollection index collection | 246568 collection := self collectionMoreThan1NoDuplicates. 246569 subcollection := self collectionMoreThan1NoDuplicates. 246570 index := collection 246571 indexOfSubCollection: subcollection 246572 startingAt: 1. 246573 self assert: index = 1. 246574 index := collection 246575 indexOfSubCollection: subcollection 246576 startingAt: 2. 246577 self assert: index = 0! ! 246578 246579!OrderedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 246580testIndexOfSubCollectionStartingAtIfAbsent 246581 "self debug: #testIndexOfIfAbsent" 246582 | index absent subcollection collection | 246583 collection := self collectionMoreThan1NoDuplicates. 246584 subcollection := self collectionMoreThan1NoDuplicates. 246585 absent := false. 246586 index := collection 246587 indexOfSubCollection: subcollection 246588 startingAt: 1 246589 ifAbsent: [ absent := true ]. 246590 self assert: absent = false. 246591 absent := false. 246592 index := collection 246593 indexOfSubCollection: subcollection 246594 startingAt: 2 246595 ifAbsent: [ absent := true ]. 246596 self assert: absent = true! ! 246597 246598!OrderedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 246599testLastIndexOf 246600 "self debug: #testLastIndexOf" 246601 | element collection | 246602 collection := self collectionMoreThan1NoDuplicates. 246603 element := collection first. 246604 self assert: (collection lastIndexOf: element) = 1. 246605 self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! 246606 246607!OrderedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 246608testLastIndexOfIfAbsent 246609 "self debug: #testIndexOfIfAbsent" 246610 | element collection | 246611 collection := self collectionMoreThan1NoDuplicates. 246612 element := collection first. 246613 self assert: (collection 246614 lastIndexOf: element 246615 ifAbsent: [ 99 ]) = 1. 246616 self assert: (collection 246617 lastIndexOf: self elementNotInForIndexAccessing 246618 ifAbsent: [ 99 ]) = 99! ! 246619 246620!OrderedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 246621testLastIndexOfStartingAt 246622 "self debug: #testLastIndexOf" 246623 | element collection | 246624 collection := self collectionMoreThan1NoDuplicates. 246625 element := collection last. 246626 self assert: (collection 246627 lastIndexOf: element 246628 startingAt: collection size 246629 ifAbsent: [ 99 ]) = collection size. 246630 self assert: (collection 246631 lastIndexOf: element 246632 startingAt: collection size - 1 246633 ifAbsent: [ 99 ]) = 99. 246634 self assert: (collection 246635 lastIndexOf: self elementNotInForIndexAccessing 246636 startingAt: collection size 246637 ifAbsent: [ 99 ]) = 99! ! 246638 246639 246640!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 246641testIdentityIndexOfDuplicate 246642 "self debug: #testIdentityIndexOf" 246643 | collection element | 246644 246645 "testing fixture here as this method may not be used by some collections testClass" 246646 self shouldnt: [self collectionWithNonIdentitySameAtEndAndBegining ] raise: Error. 246647 collection := self collectionWithNonIdentitySameAtEndAndBegining . 246648 self assert: collection first = collection last. 246649 self deny: collection first == collection last. 246650 1 to: collection size do: 246651 [ :i | 246652 i > 1 & (i < collection size) ifTrue: 246653 [ self deny: (collection at: i) = collection first ] ]. 246654 246655 246656 element := collection last. 246657 " floatCollectionWithSameAtEndAndBegining first and last elements are equals but are not the same object" 246658 self assert: (collection identityIndexOf: element) = collection size! ! 246659 246660!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 246661testIdentityIndexOfIAbsentDuplicate 246662 "self debug: #testIdentityIndexOfIfAbsent" 246663 | collection element elementCopy | 246664 collection := self collectionWithNonIdentitySameAtEndAndBegining . 246665 element := collection last. 246666 elementCopy := element copy. 246667 self deny: element == elementCopy . 246668 self assert: (collection 246669 identityIndexOf: element 246670 ifAbsent: [ 0 ]) = collection size. 246671 self assert: (collection 246672 identityIndexOf: elementCopy 246673 ifAbsent: [ 55 ]) = 55! ! 246674 246675!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 246676testIndexOfDuplicate 246677 "self debug: #testIndexOf" 246678 | collection element | 246679 collection := self collectionWithSameAtEndAndBegining. 246680 element := collection last. 246681 246682 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 246683 'indexOf: should return the position of the first occurrence :'" 246684 self assert: (collection indexOf: element) = 1! ! 246685 246686!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 246687testIndexOfIfAbsentDuplicate 246688 "self debug: #testIndexOfIfAbsent" 246689 | collection element | 246690 collection := self collectionWithSameAtEndAndBegining. 246691 element := collection last. 246692 246693 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 246694 'indexOf:ifAbsent: should return the position of the first occurrence :'" 246695 self assert: (collection 246696 indexOf: element 246697 ifAbsent: [ 55 ]) = 1! ! 246698 246699!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 246700testIndexOfStartingAtDuplicate 246701 "self debug: #testLastIndexOf" 246702 | collection element | 246703 collection := self collectionWithSameAtEndAndBegining. 246704 element := collection last. 246705 246706 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 246707 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" 246708 self assert: (collection 246709 indexOf: element 246710 startingAt: 1 246711 ifAbsent: [ 55 ]) = 1. 246712 self assert: (collection 246713 indexOf: element 246714 startingAt: 2 246715 ifAbsent: [ 55 ]) = collection size! ! 246716 246717!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 246718testLastIndexOfDuplicate 246719 "self debug: #testLastIndexOf" 246720 | collection element | 246721 collection := self collectionWithSameAtEndAndBegining. 246722 element := collection first. 246723 246724 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 246725 'lastIndexOf: should return the position of the last occurrence :'" 246726 self assert: (collection lastIndexOf: element) = collection size! ! 246727 246728!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 246729testLastIndexOfIfAbsentDuplicate 246730 "self debug: #testIndexOfIfAbsent" 246731 "self debug: #testLastIndexOf" 246732 | collection element | 246733 collection := self collectionWithSameAtEndAndBegining. 246734 element := collection first. 246735 246736 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 246737 'lastIndexOf: should return the position of the last occurrence :'" 246738 self assert: (collection 246739 lastIndexOf: element 246740 ifAbsent: [ 55 ]) = collection size! ! 246741 246742!OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 246743testLastIndexOfStartingAtDuplicate 246744 "self debug: #testLastIndexOf" 246745 | collection element | 246746 collection := self collectionWithSameAtEndAndBegining. 246747 element := collection last. 246748 246749 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 246750 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" 246751 self assert: (collection 246752 lastIndexOf: element 246753 startingAt: collection size 246754 ifAbsent: [ 55 ]) = collection size. 246755 self assert: (collection 246756 lastIndexOf: element 246757 startingAt: collection size - 1 246758 ifAbsent: [ 55 ]) = 1! ! 246759 246760 246761!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246762testAllButFirstDo 246763 246764 | result | 246765 result:= OrderedCollection new. 246766 246767 self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 246768 246769 1 to: (result size) do: 246770 [:i| 246771 self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. 246772 246773 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 246774 246775!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246776testAllButLastDo 246777 246778 | result | 246779 result:= OrderedCollection new. 246780 246781 self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 246782 246783 1 to: (result size) do: 246784 [:i| 246785 self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. 246786 246787 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 246788 246789!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246790testDetectSequenced 246791" testing that detect keep the first element returning true for sequenceable collections " 246792 246793 | element result | 246794 element := self nonEmptyMoreThan1Element at:1. 246795 result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. 246796 self assert: result = element. ! ! 246797 246798!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246799testDo! ! 246800 246801!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246802testFindFirst 246803 246804 | element result | 246805 element := self nonEmptyMoreThan1Element at:1. 246806 result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. 246807 246808 self assert: result=1. ! ! 246809 246810!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246811testFindFirstNotIn 246812 246813 | result | 246814 246815 result:=self empty findFirst: [:each | true]. 246816 246817 self assert: result=0. ! ! 246818 246819!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246820testFindLast 246821 246822 | element result | 246823 element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. 246824 result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. 246825 246826 self assert: result=self nonEmptyMoreThan1Element size. ! ! 246827 246828!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246829testFindLastNotIn 246830 246831 | result | 246832 246833 result:=self empty findFirst: [:each | true]. 246834 246835 self assert: result=0. ! ! 246836 246837!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246838testFromToDo 246839 246840 | result | 246841 result:= OrderedCollection new. 246842 246843 self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 246844 246845 1 to: (self nonEmptyMoreThan1Element size -1) do: 246846 [:i| 246847 self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. 246848 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 246849 246850!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246851testKeysAndValuesDo 246852 "| result | 246853 result:= OrderedCollection new. 246854 246855 self nonEmptyMoreThan1Element keysAndValuesDo: 246856 [:i :value| 246857 result add: (value+i)]. 246858 246859 1 to: result size do: 246860 [:i| 246861 self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" 246862 | indexes elements | 246863 indexes:= OrderedCollection new. 246864 elements := OrderedCollection new. 246865 246866 self nonEmptyMoreThan1Element keysAndValuesDo: 246867 [:i :value| 246868 indexes add: (i). 246869 elements add: value]. 246870 246871 (1 to: self nonEmptyMoreThan1Element size )do: 246872 [ :i | 246873 self assert: (indexes at: i) = i. 246874 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 246875 ]. 246876 246877 self assert: indexes size = elements size. 246878 self assert: indexes size = self nonEmptyMoreThan1Element size . 246879 246880 ! ! 246881 246882!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246883testKeysAndValuesDoEmpty 246884 | result | 246885 result:= OrderedCollection new. 246886 246887 self empty keysAndValuesDo: 246888 [:i :value| 246889 result add: (value+i)]. 246890 246891 self assert: result isEmpty .! ! 246892 246893!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246894testPairsCollect 246895 246896 | index result | 246897 index:=0. 246898 246899 result:=self nonEmptyMoreThan1Element pairsCollect: 246900 [:each1 :each2 | 246901 self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). 246902 (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). 246903 ]. 246904 246905 result do: 246906 [:each | self assert: each = true]. 246907 246908! ! 246909 246910!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246911testPairsDo 246912 | index | 246913 index:=1. 246914 246915 self nonEmptyMoreThan1Element pairsDo: 246916 [:each1 :each2 | 246917 self assert:(self nonEmptyMoreThan1Element at:index)=each1. 246918 self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. 246919 index:=index+2]. 246920 246921 self nonEmptyMoreThan1Element size odd 246922 ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] 246923 ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! 246924 246925!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246926testReverseDo 246927 | result | 246928 result:= OrderedCollection new. 246929 self nonEmpty reverseDo: [: each | result add: each]. 246930 246931 1 to: result size do: 246932 [:i| 246933 self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! 246934 246935!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246936testReverseDoEmpty 246937 | result | 246938 result:= OrderedCollection new. 246939 self empty reverseDo: [: each | result add: each]. 246940 246941 self assert: result isEmpty .! ! 246942 246943!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246944testReverseWithDo 246945 246946 | secondCollection result index | 246947 result:= OrderedCollection new. 246948 index := self nonEmptyMoreThan1Element size + 1. 246949 secondCollection:= self nonEmptyMoreThan1Element copy. 246950 246951 self nonEmptyMoreThan1Element reverseWith: secondCollection do: 246952 [:a :b | 246953 self assert: (self nonEmptyMoreThan1Element indexOf: a ) = (index := index - 1 ). 246954 result add: (a = b)]. 246955 246956 1 to: result size do: 246957 [:i| 246958 self assert: (result at:i)=(true)]. 246959 self assert: result size = self nonEmptyMoreThan1Element size.! ! 246960 246961!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246962testWithCollectError 246963 self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! 246964 246965!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246966testWithDo 246967 246968 | secondCollection result index | 246969 result:= OrderedCollection new. 246970 secondCollection:= self nonEmptyMoreThan1Element copy. 246971 index := 0. 246972 246973 self nonEmptyMoreThan1Element with: secondCollection do: 246974 [:a :b | 246975 self assert: (self nonEmptyMoreThan1Element indexOf: a) = ( index := index + 1). 246976 result add: (a =b)]. 246977 246978 1 to: result size do: 246979 [:i| 246980 self assert: (result at:i)=(true)]. 246981 self assert: result size = self nonEmptyMoreThan1Element size.! ! 246982 246983!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246984testWithDoError 246985 246986 self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! 246987 246988!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 246989testWithIndexCollect 246990 246991 | result index collection | 246992 index := 0. 246993 collection := self nonEmptyMoreThan1Element . 246994 result := collection withIndexCollect: [:each :i | 246995 self assert: i = (index := index + 1). 246996 self assert: i = (collection indexOf: each) . 246997 each] . 246998 246999 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 247000 self assert: result size = collection size.! ! 247001 247002!OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 247003testWithIndexDo 247004 247005 "| result | 247006 result:=Array new: self nonEmptyMoreThan1Element size. 247007 self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 247008 247009 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" 247010 | indexes elements | 247011 indexes:= OrderedCollection new. 247012 elements := OrderedCollection new. 247013 247014 self nonEmptyMoreThan1Element withIndexDo: 247015 [:value :i | 247016 indexes add: (i). 247017 elements add: value]. 247018 247019 (1 to: self nonEmptyMoreThan1Element size )do: 247020 [ :i | 247021 self assert: (indexes at: i) = i. 247022 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 247023 ]. 247024 247025 self assert: indexes size = elements size. 247026 self assert: indexes size = self nonEmptyMoreThan1Element size . 247027 ! ! 247028 247029 247030!OrderedCollectionTest methodsFor: 'tests - occurrencesOf'! 247031testOccurrencesOf 247032 | collection | 247033 collection := self collectionWithoutEqualElements . 247034 247035 collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! 247036 247037!OrderedCollectionTest methodsFor: 'tests - occurrencesOf'! 247038testOccurrencesOfEmpty 247039 | result | 247040 result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). 247041 self assert: result = 0! ! 247042 247043!OrderedCollectionTest methodsFor: 'tests - occurrencesOf'! 247044testOccurrencesOfNotIn 247045 | result | 247046 result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. 247047 self assert: result = 0! ! 247048 247049 247050!OrderedCollectionTest methodsFor: 'tests - occurrencesOf for multipliness'! 247051testOccurrencesOfForMultipliness 247052 247053| collection element | 247054collection := self collectionWithEqualElements . 247055element := self elementTwiceInForOccurrences . 247056 247057self assert: (collection occurrencesOf: element ) = 2. ! ! 247058 247059 247060!OrderedCollectionTest methodsFor: 'tests - printing'! 247061testPrintElementsOn 247062 247063 | aStream result allElementsAsString | 247064 result:=''. 247065 aStream:= ReadWriteStream on: result. 247066 247067 self nonEmpty printElementsOn: aStream . 247068 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 247069 1 to: allElementsAsString size do: 247070 [:i | 247071 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 247072 ].! ! 247073 247074!OrderedCollectionTest methodsFor: 'tests - printing'! 247075testPrintNameOn 247076 247077 | aStream result | 247078 result:=''. 247079 aStream:= ReadWriteStream on: result. 247080 247081 self nonEmpty printNameOn: aStream . 247082 Transcript show: result asString. 247083 self nonEmpty class name first isVowel 247084 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 247085 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 247086 247087!OrderedCollectionTest methodsFor: 'tests - printing'! 247088testPrintOn 247089 | aStream result allElementsAsString | 247090 result:=''. 247091 aStream:= ReadWriteStream on: result. 247092 247093 self nonEmpty printOn: aStream . 247094 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 247095 1 to: allElementsAsString size do: 247096 [:i | 247097 i=1 247098 ifTrue:[ 247099 self accessCollection class name first isVowel 247100 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 247101 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 247102 i=2 247103 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 247104 i>2 247105 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. 247106 ].! ! 247107 247108!OrderedCollectionTest methodsFor: 'tests - printing'! 247109testPrintOnDelimiter 247110 | aStream result allElementsAsString | 247111 result:=''. 247112 aStream:= ReadWriteStream on: result. 247113 247114 self nonEmpty printOn: aStream delimiter: ', ' . 247115 247116 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 247117 1 to: allElementsAsString size do: 247118 [:i | 247119 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 247120 ].! ! 247121 247122!OrderedCollectionTest methodsFor: 'tests - printing'! 247123testPrintOnDelimiterLast 247124 247125 | aStream result allElementsAsString | 247126 result:=''. 247127 aStream:= ReadWriteStream on: result. 247128 247129 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 247130 247131 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 247132 1 to: allElementsAsString size do: 247133 [:i | 247134 i<(allElementsAsString size-1 ) 247135 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 247136 i=(allElementsAsString size-1) 247137 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 247138 i=(allElementsAsString size) 247139 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 247140 ].! ! 247141 247142!OrderedCollectionTest methodsFor: 'tests - printing'! 247143testStoreOn 247144" for the moment work only for collection that include simple elements such that Integer" 247145 247146"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 247147string := ''. 247148str := ReadWriteStream on: string. 247149elementsAsStringExpected := OrderedCollection new. 247150elementsAsStringObtained := OrderedCollection new. 247151self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 247152 247153self nonEmpty storeOn: str. 247154result := str contents . 247155cuttedResult := ( result findBetweenSubStrs: ';' ). 247156 247157index := 1. 247158 247159cuttedResult do: 247160 [ :each | 247161 index = 1 247162 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 247163 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 247164 elementsAsStringObtained add: tmp. 247165 index := index + 1. ] 247166 ifFalse: [ 247167 index < cuttedResult size 247168 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 247169 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 247170 elementsAsStringObtained add: tmp. 247171 index := index + 1.] 247172 ifFalse: [self assert: ( each = ' yourself)' ) ]. 247173 ] 247174 247175 ]. 247176 247177 247178 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 247179 247180! ! 247181 247182 247183!OrderedCollectionTest methodsFor: 'tests - puting with indexes'! 247184testAtAllIndexesPut 247185 247186 self nonEmpty atAllPut: self aValue. 247187 self nonEmpty do:[ :each| self assert: each = self aValue]. 247188 ! ! 247189 247190!OrderedCollectionTest methodsFor: 'tests - puting with indexes'! 247191testAtAllPut 247192 | | 247193 self nonEmpty atAll: self indexArray put: self aValue.. 247194 247195 self indexArray do: 247196 [:i | self assert: (self nonEmpty at: i)=self aValue ]. 247197 ! ! 247198 247199!OrderedCollectionTest methodsFor: 'tests - puting with indexes'! 247200testAtAllPutAll 247201 247202 | valueArray | 247203 valueArray := self valueArray . 247204 self nonEmpty atAll: self indexArray putAll: valueArray . 247205 247206 1 to: self indexArray size do: 247207 [:i | 247208 self assert: (self nonEmpty at:(self indexArray at: i))= (valueArray at:i) ]! ! 247209 247210!OrderedCollectionTest methodsFor: 'tests - puting with indexes'! 247211testAtLastPut 247212 | result index | 247213 index := self indexArray anyOne. 247214 result := self nonEmpty atLast: index put: self aValue. 247215 247216 self assert: (self nonEmpty at: (self nonEmpty size +1 - index)) = self aValue .! ! 247217 247218!OrderedCollectionTest methodsFor: 'tests - puting with indexes'! 247219testAtWrapPut 247220 "self debug: #testAtWrapPut" 247221 | index | 247222 index := self indexArray anyOne. 247223 247224 self nonEmpty atWrap: 0 put: self aValue. 247225 self assert: (self nonEmpty at:(self nonEmpty size))=self aValue. 247226 247227 self nonEmpty atWrap: (self nonEmpty size+1) put: self aValue. 247228 self assert: (self nonEmpty at:(1))=self aValue. 247229 247230 self nonEmpty atWrap: (index ) put: self aValue. 247231 self assert: (self nonEmpty at: index ) = self aValue. 247232 247233 self nonEmpty atWrap: (self nonEmpty size+index ) put: self aValue . 247234 self assert: (self nonEmpty at:(index ))=self aValue .! ! 247235 247236!OrderedCollectionTest methodsFor: 'tests - puting with indexes'! 247237testFromToPut 247238 247239 | collection index | 247240 index := self indexArray anyOne. 247241 collection := self nonEmpty copy. 247242 collection from: 1 to: index put: self aValue.. 247243 1 to: index do: 247244 [:i | self assert: (collection at: i)= self aValue]. 247245 (index +1) to: collection size do: 247246 [:i | self assert: (collection at:i)= (self nonEmpty at:i)].! ! 247247 247248!OrderedCollectionTest methodsFor: 'tests - puting with indexes'! 247249testSwapWith 247250 "self debug: #testSwapWith" 247251 | result index | 247252 index := self indexArray anyOne. 247253 result:= self nonEmpty copy . 247254 result swap: index with: 1. 247255 self assert: (result at: index) = (self nonEmpty at:1). 247256 self assert: (result at: 1) = (self nonEmpty at: index). 247257 ! ! 247258 247259 247260!OrderedCollectionTest methodsFor: 'tests - remove'! 247261testRemoveAllError 247262 "self debug: #testRemoveElementThatExists" 247263 | el res subCollection | 247264 el := self elementNotIn. 247265 subCollection := self nonEmptyWithoutEqualElements copyWith: el. 247266 self 247267 should: [ res := self nonEmptyWithoutEqualElements removeAll: subCollection ] 247268 raise: Error! ! 247269 247270!OrderedCollectionTest methodsFor: 'tests - remove'! 247271testRemoveAllFoundIn 247272 "self debug: #testRemoveElementThatExists" 247273 | el res subCollection | 247274 el := self nonEmptyWithoutEqualElements anyOne. 247275 subCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. 247276 self 247277 shouldnt: 247278 [ res := self nonEmptyWithoutEqualElements removeAllFoundIn: subCollection ] 247279 raise: Error. 247280 self assert: self nonEmptyWithoutEqualElements size = 1. 247281 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 247282 247283!OrderedCollectionTest methodsFor: 'tests - remove'! 247284testRemoveElementFromEmpty 247285 "self debug: #testRemoveElementFromEmpty" 247286 self 247287 should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] 247288 raise: Error! ! 247289 247290!OrderedCollectionTest methodsFor: 'tests - remove'! 247291testRemoveElementReallyRemovesElement 247292 "self debug: #testRemoveElementReallyRemovesElement" 247293 | size | 247294 size := self nonEmptyWithoutEqualElements size. 247295 self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. 247296 self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! 247297 247298!OrderedCollectionTest methodsFor: 'tests - remove'! 247299testRemoveElementThatExists 247300 "self debug: #testRemoveElementThatExists" 247301 | el res | 247302 el := self nonEmptyWithoutEqualElements anyOne. 247303 self 247304 shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] 247305 raise: Error. 247306 self assert: res == el! ! 247307 247308 247309!OrderedCollectionTest methodsFor: 'tests - removing' stamp: 'zz 12/7/2005 19:05'! 247310testRemoveAllSuchThat 247311 | collection | 247312 collection := (1 to: 10) asOrderedCollection. 247313 collection 247314 removeAllSuchThat: [:e | e even]. 247315 self assert: collection = (1 to: 10 by: 2) asOrderedCollection! ! 247316 247317!OrderedCollectionTest methodsFor: 'tests - removing' stamp: 'sd 3/21/2006 22:39'! 247318testRemoveAt 247319 "Allows one to remove an element from a collection at an index" 247320 "self run:#testRemoveAt" 247321 247322 | c1 | 247323 c1 := #(2 3 4 6) asOrderedCollection. 247324 c1 removeAt: 2. 247325 self assert: (c1 = #(2 4 6) asOrderedCollection). 247326 self should: [c1 removeAt: 10] raise: Error. 247327 self should: [c1 removeAt: -1] raise: Error. 247328 ! ! 247329 247330!OrderedCollectionTest methodsFor: 'tests - removing' stamp: 'sd 3/21/2006 22:39'! 247331testRemoveFirst 247332 "Allows one to remove n element of a collection at the first" 247333 "self run:#testRemoveFirst" 247334 247335 | c1 | 247336 c1 := #(2 3 4 6) asOrderedCollection. 247337 c1 removeFirst: 1. 247338 self assert: (c1 = #(3 4 6) asOrderedCollection). 247339 c1 removeFirst: 2. 247340 self assert: (c1 = #(6) asOrderedCollection). 247341 self should: [c1 removeFirst: 10] raise: Error. 247342 247343 ! ! 247344 247345!OrderedCollectionTest methodsFor: 'tests - removing' stamp: 'sd 3/21/2006 22:39'! 247346testRemoveIfAbsent 247347 "Allows one to remove an element from a collection and to copy it in another collection." 247348 "If the element isn't in the first collection, the second collection copy the element after ifAbsent" 247349 "self run:#testRemoveIfAbsent" 247350 247351 | c1 c2 | 247352 c1 := #(1 2 3 4) asOrderedCollection. 247353 c2 := OrderedCollection new. 247354 247355 c2 add: (c1 remove: 2 ifAbsent: [6]). 247356 self assert: (c1 = #(1 3 4) asOrderedCollection). 247357 self assert: (c2 = #(2) asOrderedCollection). 247358 247359 c2 add: (c1 remove: 18 ifAbsent: [6]). 247360 self assert: (c1 = #(1 3 4) asOrderedCollection). 247361 self assert: (c2 = #(2 6) asOrderedCollection).! ! 247362 247363!OrderedCollectionTest methodsFor: 'tests - removing' stamp: 'sd 3/21/2006 22:39'! 247364testRemoveLast 247365 "Allows one to remove n element of a collection at the end" 247366 "self run:#testRemoveLast" 247367 247368 | c1 | 247369 c1 := #(2 3 4 6) asOrderedCollection. 247370 c1 removeLast: 1. 247371 self assert: (c1 = #(2 3 4) asOrderedCollection). 247372 c1 removeLast: 2. 247373 self assert: (c1 = #(2) asOrderedCollection). 247374 self should: [c1 removeLast: 10] raise: Error.! ! 247375 247376 247377!OrderedCollectionTest methodsFor: 'tests - replacing'! 247378testReplaceAllWith 247379 | result collection oldElement newElement | 247380 collection := self nonEmpty . 247381 result := collection copy. 247382 oldElement := self elementInForReplacement . 247383 newElement := self newElement . 247384 result replaceAll: oldElement with: newElement . 247385 247386 1 to: collection size do: 247387 [: 247388 each | 247389 ( collection at: each ) = oldElement 247390 ifTrue: [ self assert: ( result at: each ) = newElement ]. 247391 ].! ! 247392 247393!OrderedCollectionTest methodsFor: 'tests - replacing'! 247394testReplaceFromToWith 247395 | result collection replacementCollection firstIndex secondIndex | 247396 collection := self nonEmpty . 247397 replacementCollection := self replacementCollectionSameSize . 247398 firstIndex := self firstIndex . 247399 secondIndex := self secondIndex . 247400 result := collection copy. 247401 result replaceFrom: firstIndex to: secondIndex with: replacementCollection . 247402 247403 "verify content of 'result' : " 247404 "first part of 'result'' : '" 247405 247406 1 to: ( firstIndex - 1 ) do: [ :i | self assert: (collection at:i ) = ( result at: i ) ]. 247407 247408 " middle part containing replacementCollection : " 247409 247410 ( firstIndex ) to: ( firstIndex + replacementCollection size - 1 ) do: 247411 [ :i | 247412 self assert: ( result at: i ) = ( replacementCollection at: ( i - firstIndex +1 ) ) 247413 ]. 247414 247415 " end part :" 247416 ( firstIndex + replacementCollection size) to: (result size) do: 247417 [:i| 247418 self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ]. 247419 247420 ! ! 247421 247422!OrderedCollectionTest methodsFor: 'tests - replacing'! 247423testReplaceFromToWithStartingAt 247424 | result repStart collection replacementCollection firstIndex secondIndex | 247425 collection := self nonEmpty . 247426 result := collection copy. 247427 replacementCollection := self replacementCollectionSameSize . 247428 firstIndex := self firstIndex . 247429 secondIndex := self secondIndex . 247430 repStart := replacementCollection size - ( secondIndex - firstIndex + 1 ) + 1. 247431 result replaceFrom: firstIndex to: secondIndex with: replacementCollection startingAt: repStart . 247432 247433 "verify content of 'result' : " 247434 "first part of 'result'' : '" 247435 247436 1 to: ( firstIndex - 1 ) do: [ :i | self assert: ( collection at:i ) = ( result at: i ) ]. 247437 247438 " middle part containing replacementCollection : " 247439 247440 ( firstIndex ) to: ( replacementCollection size - repStart +1 ) do: 247441 [:i| 247442 self assert: (result at: i)=( replacementCollection at: ( repStart + ( i -firstIndex ) ) ) ]. 247443 247444 " end part :" 247445 ( firstIndex + replacementCollection size ) to: ( result size ) do: 247446 [ :i | 247447 self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ].! ! 247448 247449 247450!OrderedCollectionTest methodsFor: 'tests - sequence isempty'! 247451testSequenceAbleIfEmptyifNotEmptyDo 247452 "self debug: #testSequenceAbleIfEmptyifNotEmptyDo" 247453 247454 self assert: (self nonEmpty 247455 ifEmpty: [false] 247456 ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! 247457 247458!OrderedCollectionTest methodsFor: 'tests - sequence isempty'! 247459testSequenceIfEmptyifNotEmptyDo 247460 "self debug #testSequenceIfEmptyifNotEmptyDo" 247461 247462 self assert: (self nonEmpty 247463 ifEmpty: [false] 247464 ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! 247465 247466!OrderedCollectionTest methodsFor: 'tests - sequence isempty'! 247467testSequenceIfNotEmpty 247468 247469 self assert: (self nonEmpty 247470 ifNotEmpty: [:s | self accessValuePutInOn: s]) = self valuePutIn! ! 247471 247472!OrderedCollectionTest methodsFor: 'tests - sequence isempty'! 247473testSequenceIfNotEmptyDo 247474 247475 self empty ifNotEmptyDo: [:s | self assert: false]. 247476 self assert: (self nonEmpty ifNotEmptyDo: [:s | self accessValuePutInOn: s]) = self valuePutIn 247477! ! 247478 247479!OrderedCollectionTest methodsFor: 'tests - sequence isempty'! 247480testSequenceIfNotEmptyDoifNotEmpty 247481 247482 self assert: (self nonEmpty 247483 ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn] 247484 ifEmpty: [false])! ! 247485 247486!OrderedCollectionTest methodsFor: 'tests - sequence isempty'! 247487testSequenceIfNotEmptyifEmpty 247488 247489 self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [:s | (self accessValuePutInOn: s) = self valuePutIn])! ! 247490 247491 247492!OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 247493containsAll: union of: one andOf: another 247494 247495 self assert: (one allSatisfy: [:each | union includes: each]). 247496 self assert: (another allSatisfy: [:each | union includes: each])! ! 247497 247498!OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 247499numberOfSimilarElementsInIntersection 247500 ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! 247501 247502!OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 247503testDifference 247504 "Answer the set theoretic difference of two collections." 247505 "self debug: #testDifference" 247506 247507 self assert: (self collection difference: self collection) isEmpty. 247508 self assert: (self empty difference: self collection) isEmpty. 247509 self assert: (self collection difference: self empty) = self collection 247510! ! 247511 247512!OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 247513testDifferenceWithNonNullIntersection 247514 "Answer the set theoretic difference of two collections." 247515 "self debug: #testDifferenceWithNonNullIntersection" 247516 " #(1 2 3) difference: #(2 4) 247517 -> #(1 3)" 247518 | res overlapping | 247519 overlapping := self collectionClass 247520 with: self anotherElementOrAssociationNotIn 247521 with: self anotherElementOrAssociationIn. 247522 res := self collection difference: overlapping. 247523 self deny: (res includes: self anotherElementOrAssociationIn). 247524 overlapping do: [ :each | self deny: (res includes: each) ]! ! 247525 247526!OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 247527testDifferenceWithSeparateCollection 247528 "Answer the set theoretic difference of two collections." 247529 "self debug: #testDifferenceWithSeparateCollection" 247530 | res separateCol | 247531 separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. 247532 res := self collection difference: separateCol. 247533 self deny: (res includes: self anotherElementOrAssociationNotIn). 247534 self assert: res = self collection. 247535 res := separateCol difference: self collection. 247536 self deny: (res includes: self collection anyOne). 247537 self assert: res = separateCol! ! 247538 247539!OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 247540testIntersectionBasic 247541 "self debug: #testIntersectionBasic" 247542 | inter | 247543 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 247544 self deny: inter isEmpty. 247545 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 247546 247547!OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 247548testIntersectionEmpty 247549 "self debug: #testIntersectionEmpty" 247550 247551 | inter | 247552 inter := self empty intersection: self empty. 247553 self assert: inter isEmpty. 247554 inter := self empty intersection: self collection . 247555 self assert: inter = self empty. 247556 ! ! 247557 247558!OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 247559testIntersectionItself 247560 "self debug: #testIntersectionItself" 247561 247562 self assert: (self collection intersection: self collection) = self collection. 247563 ! ! 247564 247565!OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 247566testIntersectionTwoSimilarElementsInIntersection 247567 "self debug: #testIntersectionBasic" 247568 | inter | 247569 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 247570 self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. 247571 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 247572 247573!OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 247574testUnion 247575 "self debug: #testUnionOfEmpties" 247576 247577 | union | 247578 union := self empty union: self nonEmpty. 247579 self containsAll: union of: self empty andOf: self nonEmpty. 247580 union := self nonEmpty union: self empty. 247581 self containsAll: union of: self empty andOf: self nonEmpty. 247582 union := self collection union: self nonEmpty. 247583 self containsAll: union of: self collection andOf: self nonEmpty.! ! 247584 247585!OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 247586testUnionOfEmpties 247587 "self debug: #testUnionOfEmpties" 247588 247589 self assert: (self empty union: self empty) isEmpty. 247590 247591 ! ! 247592 247593 247594!OrderedCollectionTest methodsFor: 'tests - subcollections access'! 247595testAllButFirst 247596 "self debug: #testAllButFirst" 247597 | abf col | 247598 col := self moreThan3Elements. 247599 abf := col allButFirst. 247600 self deny: abf first = col first. 247601 self assert: abf size + 1 = col size! ! 247602 247603!OrderedCollectionTest methodsFor: 'tests - subcollections access'! 247604testAllButFirstNElements 247605 "self debug: #testAllButFirst" 247606 | abf col | 247607 col := self moreThan3Elements. 247608 abf := col allButFirst: 2. 247609 1 247610 to: abf size 247611 do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. 247612 self assert: abf size + 2 = col size! ! 247613 247614!OrderedCollectionTest methodsFor: 'tests - subcollections access'! 247615testAllButLast 247616 "self debug: #testAllButLast" 247617 | abf col | 247618 col := self moreThan3Elements. 247619 abf := col allButLast. 247620 self deny: abf last = col last. 247621 self assert: abf size + 1 = col size! ! 247622 247623!OrderedCollectionTest methodsFor: 'tests - subcollections access'! 247624testAllButLastNElements 247625 "self debug: #testAllButFirst" 247626 | abf col | 247627 col := self moreThan3Elements. 247628 abf := col allButLast: 2. 247629 1 247630 to: abf size 247631 do: [ :i | self assert: (abf at: i) = (col at: i) ]. 247632 self assert: abf size + 2 = col size! ! 247633 247634!OrderedCollectionTest methodsFor: 'tests - subcollections access'! 247635testFirstNElements 247636 "self debug: #testFirstNElements" 247637 | result | 247638 result := self moreThan3Elements first: self moreThan3Elements size - 1. 247639 1 247640 to: result size 247641 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. 247642 self assert: result size = (self moreThan3Elements size - 1). 247643 self 247644 should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] 247645 raise: Error! ! 247646 247647!OrderedCollectionTest methodsFor: 'tests - subcollections access'! 247648testLastNElements 247649 "self debug: #testLastNElements" 247650 | result | 247651 result := self moreThan3Elements last: self moreThan3Elements size - 1. 247652 1 247653 to: result size 247654 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. 247655 self assert: result size = (self moreThan3Elements size - 1). 247656 self 247657 should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] 247658 raise: Error! ! 247659 247660 247661!OrderedCollectionTest methodsFor: 'testsRemoving' stamp: 'nice 9/14/2009 20:57'! 247662testRemoveAll 247663 "Allows one to remove all elements of a collection" 247664 247665 | c1 c2 s2 | 247666 c1 := #(2 3 4 6) asOrderedCollection. 247667 c1 addAll: (1 to: 200). 247668 c2 := c1 copy. 247669 s2 := c2 size. 247670 247671 c1 removeAll. 247672 247673 self assert: c1 size = 0. 247674 self assert: c2 size = s2 description: 'the copy has not been modified' 247675 ! ! 247676 247677"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 247678 247679OrderedCollectionTest class 247680 uses: TEmptySequenceableTest classTrait + TAddTest classTrait + TSequencedElementAccessTest classTrait + TCloneTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TCreationWithTest classTrait + TRemoveForMultiplenessTest classTrait + TPutBasicTest classTrait + TIterateSequencedReadableTest classTrait + TSubCollectionAccess classTrait + TIndexAccess classTrait + TCopySequenceableWithReplacement classTrait + TCopyPartOfSequenceable classTrait + TCopySequenceableSameContents classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TPrintOnSequencedTest classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TConvertTest classTrait + TSequencedConcatenationTest classTrait + TBeginsEndsWith classTrait + TReplacementSequencedTest classTrait + TIndexAccessForMultipliness classTrait + TCopyPartOfSequenceableForMultipliness classTrait + TConvertAsSortedTest classTrait + TPutTest classTrait + TIncludesWithIdentityCheckTest classTrait + TConvertAsSetForMultiplinessIdentityTest classTrait + TSequencedStructuralEqualityTest classTrait + TOccurrencesForMultiplinessTest classTrait 247681 instanceVariableNames: ''! 247682FillStyle subclass: #OrientedFillStyle 247683 instanceVariableNames: 'origin direction normal' 247684 classVariableNames: '' 247685 poolDictionaries: '' 247686 category: 'Balloon-Fills'! 247687!OrientedFillStyle commentStamp: '<historical>' prior: 0! 247688OrientedFill is an abstract superclass for fills which can be aligned appropriately. 247689 247690Instance variables: 247691 origin <Point> The point at which to align the fill. 247692 direction <Point> The direction in which the fill is defined 247693 normal <Point> Typically, just the direction rotated by 90 degrees.! 247694 247695 247696!OrientedFillStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 12:19'! 247697= anOrientedFillStyle 247698 "Answer whether equal." 247699 247700 ^self species = anOrientedFillStyle species 247701 and: [self origin = anOrientedFillStyle origin 247702 and: [self direction = anOrientedFillStyle direction 247703 and: [self normal = anOrientedFillStyle normal]]]! ! 247704 247705!OrientedFillStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 12:20'! 247706hash 247707 "Hash is implemented because #= is implemented." 247708 247709 ^self species hash 247710 bitXor: (self origin hash 247711 bitXor: (self direction hash 247712 bitXor: (self normal hash)))! ! 247713 247714 247715!OrientedFillStyle methodsFor: '*morphic-balloon' stamp: 'dgd 10/17/2003 22:35'! 247716addFillStyleMenuItems: aMenu hand: aHand from: aMorph 247717 "Add the items for changing the current fill style of the receiver" 247718 aMenu add: 'change origin' translated target: self selector: #changeOriginIn:event: argument: aMorph. 247719 aMenu add: 'change orientation' translated target: self selector: #changeOrientationIn:event: argument: aMorph.! ! 247720 247721!OrientedFillStyle methodsFor: '*morphic-balloon' stamp: 'ar 6/18/1999 07:41'! 247722changeOrientationIn: aMorph event: evt 247723 "Interactively change the origin of the receiver" 247724 | handle | 247725 handle := HandleMorph new forEachPointDo:[:pt| 247726 self direction: pt - self origin. 247727 self normal: nil. 247728 aMorph changed]. 247729 evt hand attachMorph: handle. 247730 handle startStepping.! ! 247731 247732!OrientedFillStyle methodsFor: '*morphic-balloon' stamp: 'ar 6/18/1999 07:28'! 247733changeOriginIn: aMorph event: evt 247734 "Interactively change the origin of the receiver" 247735 | handle | 247736 handle := HandleMorph new forEachPointDo:[:pt| 247737 self origin: pt. 247738 aMorph changed]. 247739 evt hand attachMorph: handle. 247740 handle startStepping.! ! 247741 247742 247743!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:03'! 247744direction 247745 ^direction ifNil:[direction := normal y @ normal x negated]! ! 247746 247747!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:37'! 247748direction: aPoint 247749 direction := aPoint! ! 247750 247751!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/14/1998 23:31'! 247752normal 247753 ^normal ifNil:[normal := direction y negated @ direction x]! ! 247754 247755!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:37'! 247756normal: aPoint 247757 normal := aPoint! ! 247758 247759!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:38'! 247760origin 247761 ^origin! ! 247762 247763!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:38'! 247764origin: aPoint 247765 origin := aPoint.! ! 247766 247767 247768!OrientedFillStyle methodsFor: 'testing' stamp: 'ar 6/18/1999 07:57'! 247769isOrientedFill 247770 "Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)" 247771 ^true! ! 247772Notification subclass: #OutOfScopeNotification 247773 instanceVariableNames: '' 247774 classVariableNames: '' 247775 poolDictionaries: '' 247776 category: 'Exceptions-Kernel'! 247777 247778!OutOfScopeNotification methodsFor: 'as yet unclassified' stamp: 'RAA 2/5/2001 10:41'! 247779defaultAction 247780 247781 self resume: false! ! 247782PBPreferenceView subclass: #PBBooleanPreferenceView 247783 instanceVariableNames: '' 247784 classVariableNames: '' 247785 poolDictionaries: '' 247786 category: 'PreferenceBrowser'! 247787!PBBooleanPreferenceView commentStamp: '<historical>' prior: 0! 247788I am responsible for building the visual representation of a preference that accepts true and false values. This view is aimed to be used inside a PreferenceBrowser panel.! 247789 247790 247791!PBBooleanPreferenceView methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/7/2007 20:38'! 247792enabledButton 247793 "Answer a checkbox for the enablement state." 247794 247795 ^UITheme current 247796 newCheckboxIn: World 247797 for: self preference 247798 getSelected: #preferenceValue 247799 setSelected: #preferenceValue: 247800 getEnabled: nil 247801 label: 'enabled' translated 247802 help: nil! ! 247803 247804!PBBooleanPreferenceView methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/7/2007 20:40'! 247805localToProjectButton 247806 "Answer a checkbox for the local enablement state." 247807 247808 ^UITheme current 247809 newCheckboxIn: World 247810 for: self preference 247811 getSelected: #localToProject 247812 setSelected: #toggleProjectLocalness 247813 getEnabled: nil 247814 label: 'local' translated 247815 help: nil 247816 ! ! 247817 247818 247819!PBBooleanPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 00:25'! 247820representativeButtonWithColor: aColor inPanel: aPreferencesPanel 247821 ^self horizontalPanel 247822 layoutInset: 2; 247823 cellInset: 7; 247824 color: aColor; 247825 addMorphBack: (StringMorph contents: self preference name); 247826 addMorphBack: self horizontalFiller; 247827 addMorphBack: self enabledButton; 247828 addMorphBack: self localToProjectButton; 247829 yourself.! ! 247830 247831"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 247832 247833PBBooleanPreferenceView class 247834 instanceVariableNames: ''! 247835 247836!PBBooleanPreferenceView class methodsFor: 'initialization' stamp: 'hpt 9/26/2004 15:47'! 247837initialize 247838 PreferenceViewRegistry ofBooleanPreferences register: self. 247839! ! 247840 247841!PBBooleanPreferenceView class methodsFor: 'initialization' stamp: 'hpt 9/26/2004 15:47'! 247842unload 247843 PreferenceViewRegistry ofBooleanPreferences unregister: self.! ! 247844PBPreferenceView subclass: #PBColorPreferenceView 247845 instanceVariableNames: '' 247846 classVariableNames: '' 247847 poolDictionaries: '' 247848 category: 'PreferenceBrowser'! 247849 247850!PBColorPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/6/2004 21:24'! 247851colorSwatch 247852 ^UpdatingRectangleMorph new 247853 target: self preference; 247854 getSelector: #preferenceValue; 247855 putSelector: #preferenceValue:; 247856 extent: 22@22; 247857 setBalloonText: 'click here to change the color' translated; 247858 yourself.! ! 247859 247860!PBColorPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/6/2004 21:12'! 247861representativeButtonWithColor: aColor inPanel: aPreferenceBrowser 247862 ^self horizontalPanel 247863 layoutInset: 2; 247864 color: aColor; 247865 cellInset: 20; 247866 cellPositioning: #center; 247867 addMorphBack: (StringMorph contents: self preference name); 247868 addMorphBack: self horizontalFiller; 247869 addMorphBack: self colorSwatch; 247870 yourself! ! 247871 247872"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 247873 247874PBColorPreferenceView class 247875 instanceVariableNames: ''! 247876 247877!PBColorPreferenceView class methodsFor: 'initialization' stamp: 'hpt 12/6/2004 20:49'! 247878initialize 247879 PreferenceViewRegistry ofColorPreferences register: self.! ! 247880 247881!PBColorPreferenceView class methodsFor: 'initialization' stamp: 'hpt 12/6/2004 20:49'! 247882unload 247883 PreferenceViewRegistry ofColorPreferences unregister: self.! ! 247884PBPreferenceView subclass: #PBHaloThemePreferenceView 247885 instanceVariableNames: '' 247886 classVariableNames: '' 247887 poolDictionaries: '' 247888 category: 'PreferenceBrowser'! 247889!PBHaloThemePreferenceView commentStamp: '<historical>' prior: 0! 247890I am responsible for building the button for the Halo Theme preference! 247891 247892 247893!PBHaloThemePreferenceView methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:13'! 247894initialize 247895 super initialize. 247896 self addActionTitled: 'edit custom halos' 247897 target: Preferences 247898 selector: #editCustomHalos 247899 arguments: {} 247900 balloonText: 'Click here to edit the method that defines the custom halos' translated.! ! 247901 247902 247903!PBHaloThemePreferenceView methodsFor: 'user interface' stamp: 'md 12/18/2008 16:22'! 247904haloThemeRadioButtons 247905 "Answer a column of butons representing the choices of halo theme" 247906 247907 | buttonColumn aRow aRadioButton aLabel | 247908 buttonColumn := self verticalPanel. 247909 #( (iconicHaloSpecifications iconic iconicHalosInForce 'circular halos with icons inside') 247910 (classicHaloSpecs classic classicHalosInForce 'plain circular halos') 247911 (customHaloSpecs custom customHalosInForce 'customizable halos')) do: 247912 247913 [:quad | 247914 aRadioButton := UpdatingThreePhaseButtonMorph radioButton 247915 target: Preferences; 247916 setBalloonText: quad fourth; 247917 actionSelector: #installHaloTheme:; 247918 getSelector: quad third; 247919 arguments: (Array with: quad first); 247920 yourself. 247921 aLabel := (StringMorph contents: quad second asString) 247922 setBalloonText: quad fourth; 247923 yourself. 247924 aRow := self horizontalPanel 247925 cellInset: 4; 247926 addMorphBack: aRadioButton; 247927 addMorphBack: aLabel. 247928 buttonColumn addMorphBack: aRow]. 247929 ^ buttonColumn 247930 247931 "(Preferences preferenceAt: #haloTheme) view tearOffButton"! ! 247932 247933!PBHaloThemePreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 00:45'! 247934representativeButtonWithColor: aColor inPanel: aPreferencesPanel 247935 | innerPanel | 247936 innerPanel := self horizontalPanel 247937 addMorphBack: (self blankSpaceOf: 10@0); 247938 addMorphBack: self haloThemeRadioButtons; 247939 yourself. 247940 ^self verticalPanel 247941 color: aColor; 247942 layoutInset: 2; 247943 addMorphBack: (StringMorph contents: self preference name); 247944 addMorphBack: innerPanel.! ! 247945 247946"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 247947 247948PBHaloThemePreferenceView class 247949 instanceVariableNames: ''! 247950 247951!PBHaloThemePreferenceView class methodsFor: 'initialization' stamp: 'hpt 9/26/2004 15:48'! 247952initialize 247953 PreferenceViewRegistry ofHaloThemePreferences register: self.! ! 247954 247955!PBHaloThemePreferenceView class methodsFor: 'initialization' stamp: 'hpt 9/26/2004 15:48'! 247956unload 247957 PreferenceViewRegistry ofHaloThemePreferences unregister: self.! ! 247958PBPreferenceView subclass: #PBNumericPreferenceView 247959 instanceVariableNames: '' 247960 classVariableNames: '' 247961 poolDictionaries: '' 247962 category: 'PreferenceBrowser'! 247963 247964!PBNumericPreferenceView methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/7/2007 20:27'! 247965textField 247966 "Answer a text field for the preference." 247967 247968 ^UITheme current 247969 newAutoAcceptTextEntryIn: World 247970 for: self 247971 get: #preferenceValue 247972 set: #preferenceValue: 247973 class: String 247974 getEnabled: nil 247975 help: nil! ! 247976 247977 247978!PBNumericPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/9/2004 22:23'! 247979preferenceValue 247980 ^self preference preferenceValue asString! ! 247981 247982!PBNumericPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/10/2004 22:53'! 247983preferenceValue: aTextOrString 247984 (aTextOrString notEmpty and: [aTextOrString asString isAllDigits]) 247985 ifFalse: [^false]. 247986 self preference preferenceValue: aTextOrString asNumber. 247987 ^true.! ! 247988 247989!PBNumericPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/9/2004 22:19'! 247990representativeButtonWithColor: aColor inPanel: aPreferenceBrowser 247991 ^self horizontalPanel 247992 layoutInset: 2; 247993 color: aColor; 247994 cellInset: 20; 247995 cellPositioning: #center; 247996 addMorphBack: (StringMorph contents: self preference name); 247997 addMorphBack: self textField; 247998 yourself.! ! 247999 248000"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 248001 248002PBNumericPreferenceView class 248003 instanceVariableNames: ''! 248004 248005!PBNumericPreferenceView class methodsFor: 'initialization' stamp: 'hpt 12/9/2004 22:21'! 248006initialize 248007 PreferenceViewRegistry ofNumericPreferences register: self.! ! 248008 248009!PBNumericPreferenceView class methodsFor: 'initialization' stamp: 'hpt 12/9/2004 22:21'! 248010unload 248011 PreferenceViewRegistry ofNumericPreferences unregister: self.! ! 248012Morph subclass: #PBPreferenceButtonMorph 248013 instanceVariableNames: 'moreButton model preference preferenceMorphicView preferenceView' 248014 classVariableNames: '' 248015 poolDictionaries: '' 248016 category: 'PreferenceBrowser'! 248017 248018!PBPreferenceButtonMorph methodsFor: 'accessing' stamp: 'hpt 12/8/2004 15:34'! 248019model 248020 ^model! ! 248021 248022 248023!PBPreferenceButtonMorph methodsFor: 'extra controls' stamp: 'hpt 12/8/2004 18:15'! 248024actionButtons 248025 ^self preferenceView actions collect: [:aTuple | 248026 self basicButton 248027 label: aTuple first; 248028 target: aTuple second; 248029 actionSelector: aTuple third; 248030 arguments: aTuple fourth; 248031 setBalloonText: aTuple fifth ]! ! 248032 248033!PBPreferenceButtonMorph methodsFor: 'extra controls' stamp: 'hpt 8/24/2005 20:33'! 248034addExtraControls 248035 | m | 248036 m := self horizontalPanel 248037 cellInset: 3; 248038 addAllMorphs: self actionButtons; 248039 addMorphBack: self horizontalFiller; 248040 addMorphBack: self moreButton; 248041 yourself. 248042 self 248043 addMorphBack: (self blankSpaceOf: 2@2); 248044 addMorphBack: self preferenceHelpTextMorph; 248045 fullBounds; "to force a layout compute needed by the textMorphs's autoFit" 248046 addMorphBack: m 248047! ! 248048 248049!PBPreferenceButtonMorph methodsFor: 'extra controls' stamp: 'hpt 12/8/2004 17:16'! 248050advancedOptionsSelected 248051 self preferenceView offerPreferenceNameMenu: self model! ! 248052 248053!PBPreferenceButtonMorph methodsFor: 'extra controls' stamp: 'hpt 12/8/2004 18:17'! 248054moreButton 248055 ^moreButton ifNil: 248056 [moreButton := self basicButton 248057 label: 'more' translated; 248058 setBalloonText: 248059 'Click here for advanced options'translated; 248060 actionSelector: #advancedOptionsSelected]! ! 248061 248062!PBPreferenceButtonMorph methodsFor: 'extra controls' stamp: 'stephaneducasse 2/4/2006 20:39'! 248063preferenceHelpTextMorph 248064 | text tm | 248065 text := self preferenceHelpText. 248066 tm := TextMorph new 248067 contents: text; 248068 wrapOnOff; 248069 hResizing: #spaceFill; 248070 vResizing: #shrinkWrap; 248071 lock: true; 248072 visible: text notEmpty; 248073 yourself. "we don't want an empty textmorph showing" 248074 tm isAutoFit 248075 ifFalse: [tm autoFitOnOff]. 248076 ^tm.! ! 248077 248078!PBPreferenceButtonMorph methodsFor: 'extra controls' stamp: 'hpt 12/8/2004 16:40'! 248079removeExtraControls 248080 self submorphs copyWithoutFirst do: [:ea | ea delete]! ! 248081 248082 248083!PBPreferenceButtonMorph methodsFor: 'highlighting' stamp: 'hpt 12/8/2004 15:55'! 248084highlightOff 248085 self beTransparent. 248086 self label color: Color black. 248087 self removeExtraControls.! ! 248088 248089!PBPreferenceButtonMorph methodsFor: 'highlighting' stamp: 'hpt 12/8/2004 17:25'! 248090highlightOn 248091 self color: (Color gray alpha: 0.1). 248092 self label color: Color red. 248093 self addExtraControls.! ! 248094 248095 248096!PBPreferenceButtonMorph methodsFor: 'initialization' stamp: 'hpt 12/8/2004 15:38'! 248097initializeLayout 248098 self layoutPolicy: TableLayout new; 248099 beTransparent; 248100 layoutInset: 0; 248101 cellInset: 0; 248102 listCentering: #topLeft; 248103 cellPositioning: #topLeft; 248104 listDirection: #topToBottom; 248105 hResizing: #spaceFill; 248106 vResizing: #shrinkWrap. ! ! 248107 248108!PBPreferenceButtonMorph methodsFor: 'initialization' stamp: 'hpt 12/8/2004 15:38'! 248109initializeWithPreference: aPreference model: aModel 248110 preference := aPreference. 248111 model := aModel. 248112 self initializeLayout. 248113 self addMorphBack: self preferenceMorphicView. 248114 self highlightOff.! ! 248115 248116 248117!PBPreferenceButtonMorph methodsFor: 'preference accessing' stamp: 'hpt 12/8/2004 15:42'! 248118label 248119 ^self preferenceMorphicView firstSubmorph! ! 248120 248121!PBPreferenceButtonMorph methodsFor: 'preference accessing' stamp: 'hpt 12/8/2004 15:13'! 248122preference 248123 ^preference! ! 248124 248125!PBPreferenceButtonMorph methodsFor: 'preference accessing' stamp: 'hpt 12/8/2004 15:56'! 248126preferenceHelp 248127 | help name | 248128 help := self preference helpString withBlanksTrimmed. 248129 name := self preference name. 248130 (self caseInsensitiveBeginsWith: name in: help) 248131 ifTrue: [help := help allButFirst: name size]. 248132 (help notEmpty and: [help first = $:]) 248133 ifTrue: [help := help allButFirst]. 248134 ^help withBlanksTrimmed. 248135! ! 248136 248137!PBPreferenceButtonMorph methodsFor: 'preference accessing' stamp: 'hpt 12/8/2004 15:25'! 248138preferenceHelpText 248139 ^self preferenceHelp asText 248140 addAttribute: TextEmphasis italic; 248141 yourself.! ! 248142 248143!PBPreferenceButtonMorph methodsFor: 'preference accessing' stamp: 'hpt 12/8/2004 15:48'! 248144preferenceMorphicView 248145 ^preferenceMorphicView 248146 ifNil: 248147 [preferenceMorphicView := self preferenceView 248148 representativeButtonWithColor: Color transparent inPanel: self model. 248149 preferenceMorphicView hResizing: #spaceFill. 248150 ^preferenceMorphicView]! ! 248151 248152!PBPreferenceButtonMorph methodsFor: 'preference accessing' stamp: 'stephaneducasse 2/4/2006 20:39'! 248153preferenceView 248154 ^preferenceView 248155 ifNil: [preferenceView := self preference viewForPanel: self model.]! ! 248156 248157 248158!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 17:06'! 248159basicButton 248160 | button | 248161 button := SimpleButtonMorph new. 248162 button 248163 borderWidth: 1; 248164 borderColor: self paneColor; 248165 on: #mouseEnter send: #value to: [button borderWidth: 2]; 248166 on: #mouseLeave send: #value to: [button borderWidth: 1]; 248167 vResizing: #rigid; 248168 height: (TextStyle defaultFont height + 4); 248169 useSquareCorners; 248170 clipSubmorphs: true; 248171 color: self paneColor muchLighter; 248172 target: self. 248173 ^button! ! 248174 248175!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 15:59'! 248176basicPanel 248177 ^BorderedMorph new 248178 beTransparent; 248179 extent: 0@0; 248180 borderWidth: 0; 248181 layoutInset: 0; 248182 cellInset: 0; 248183 layoutPolicy: TableLayout new; 248184 listCentering: #topLeft; 248185 cellPositioning: #center; 248186 hResizing: #spaceFill; 248187 vResizing: #shrinkWrap; 248188 yourself! ! 248189 248190!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 15:29'! 248191blankSpaceOf: aPoint 248192 ^Morph new 248193 beTransparent; 248194 extent: aPoint; 248195 yourself! ! 248196 248197!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 15:43'! 248198caseInsensitiveBeginsWith: prefix in: string 248199 ^(string findString: prefix startingAt: 1 caseSensitive: false) = 1! ! 248200 248201!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 16:42'! 248202horizontalFiller 248203 ^self horizontalPanel 248204 hResizing: #spaceFill; 248205 yourself.! ! 248206 248207!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 16:42'! 248208horizontalPanel 248209 ^self basicPanel 248210 cellPositioning: #center; 248211 listDirection: #leftToRight; 248212 yourself.! ! 248213 248214!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'stephaneducasse 2/4/2006 20:39'! 248215paneColor 248216 | browser | 248217 browser := (self ownerChain 248218 detect: [:ea | ea isKindOf: PreferenceBrowserMorph] 248219 ifNone: [^Color black]) . 248220 ^browser paneColor! ! 248221 248222!PBPreferenceButtonMorph methodsFor: 'utility methods' stamp: 'hpt 12/8/2004 15:27'! 248223verticalPanel 248224 ^self basicPanel 248225 cellPositioning: #topLeft; 248226 listDirection: #topToBottom; 248227 yourself.! ! 248228 248229"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 248230 248231PBPreferenceButtonMorph class 248232 instanceVariableNames: ''! 248233 248234!PBPreferenceButtonMorph class methodsFor: 'instance creation' stamp: 'hpt 12/8/2004 15:20'! 248235preference: aPreference 248236 ^self preference: aPreference model: nil! ! 248237 248238!PBPreferenceButtonMorph class methodsFor: 'instance creation' stamp: 'hpt 12/8/2004 15:19'! 248239preference: aPreference model: aModel 248240 ^self new 248241 initializeWithPreference: aPreference model: aModel; 248242 yourself.! ! 248243PreferenceView subclass: #PBPreferenceView 248244 instanceVariableNames: 'actions' 248245 classVariableNames: '' 248246 poolDictionaries: '' 248247 category: 'PreferenceBrowser'! 248248!PBPreferenceView commentStamp: '<historical>' prior: 0! 248249I am just a refactor of all the common method of the PreferenceBrowser preference views! 248250 248251 248252!PBPreferenceView methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:39'! 248253actions 248254 ^actions ifNil: [actions := OrderedCollection new.]! ! 248255 248256!PBPreferenceView methodsFor: 'actions' stamp: 'hpt 12/8/2004 18:13'! 248257addActionTitled: aTitle target: aTarget selector: aSelector arguments: aCollection balloonText: aText 248258 self actions add: { aTitle. aTarget. aSelector. aCollection. aText }! ! 248259 248260 248261!PBPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 11:42'! 248262basicPanel 248263 ^BorderedMorph new 248264 beTransparent; 248265 extent: 0@0; 248266 borderWidth: 0; 248267 layoutInset: 0; 248268 cellInset: 2; 248269 layoutPolicy: TableLayout new; 248270 listCentering: #topLeft; 248271 cellPositioning: #center; 248272 hResizing: #shrinkWrap; 248273 vResizing: #shrinkWrap; 248274 yourself! ! 248275 248276!PBPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 00:15'! 248277blankSpaceOf: aPoint 248278 ^Morph new 248279 beTransparent; 248280 extent: aPoint; 248281 yourself! ! 248282 248283!PBPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 00:13'! 248284horizontalFiller 248285 ^self horizontalPanel 248286 hResizing: #spaceFill; 248287 yourself.! ! 248288 248289!PBPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 11:43'! 248290horizontalPanel 248291 ^self basicPanel 248292 cellPositioning: #center; 248293 listDirection: #leftToRight; 248294 yourself.! ! 248295 248296!PBPreferenceView methodsFor: 'user interface' stamp: 'alain.plantec 5/30/2008 14:00'! 248297offerPreferenceNameMenu: aPreferenceBrowser 248298 "the user clicked on a preference name -- put up a menu" 248299 248300 | aMenu | 248301 aMenu := MenuMorph new 248302 defaultTarget: self preference; 248303 addTitle: self preference name. 248304 248305 (Preferences okayToChangeProjectLocalnessOf: self preference name) ifTrue: 248306 [aMenu addUpdating: #isProjectLocalString target: self preference action: #toggleProjectLocalness. 248307 aMenu balloonTextForLastItem: 'Some preferences are best applied uniformly to all projects, and others are best set by each individual project. If this item is checked, then this preference will be printed in bold and will have a separate value for each project']. 248308 248309 aMenu add: 'browse senders' translated target: self systemNavigation selector: #browseAllCallsOn: argument: self preference name. 248310 aMenu balloonTextForLastItem: 'This will open a method-list browser on all methods that the send the preference "', self preference name, '".'. 248311 aMenu add: 'show category...' target: aPreferenceBrowser selector: #findCategoryFromPreference: argument: self preference name. 248312 aMenu balloonTextForLastItem: 'Allows you to find out which category, or categories, this preference belongs to.'. 248313 248314 aMenu add: 'hand me a button for this preference' target: self selector: #tearOffButton. 248315 aMenu balloonTextForLastItem: 'Will give you a button that governs this preference, which you may deposit wherever you wish'. 248316 248317 aMenu add: 'copy this name to clipboard' target: self preference selector: #copyName. 248318 aMenu balloonTextForLastItem: 'Copy the name of the preference to the text clipboard, so that you can paste into code somewhere'. 248319 248320 aMenu popUpInWorld! ! 248321 248322!PBPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 11:43'! 248323verticalPanel 248324 ^self basicPanel 248325 cellPositioning: #topLeft; 248326 listDirection: #topToBottom; 248327 yourself.! ! 248328 248329"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 248330 248331PBPreferenceView class 248332 instanceVariableNames: ''! 248333 248334!PBPreferenceView class methodsFor: 'view registry' stamp: 'hpt 9/26/2004 16:09'! 248335handlesPanel: aPreferencePanel 248336 ^aPreferencePanel isKindOf: PreferenceBrowser! ! 248337PBUIThemePreferenceView subclass: #PBSoundThemePreferenceView 248338 instanceVariableNames: '' 248339 classVariableNames: '' 248340 poolDictionaries: '' 248341 category: 'Polymorph-Widgets-Themes'! 248342!PBSoundThemePreferenceView commentStamp: 'gvc 9/23/2008 11:53' prior: 0! 248343PreferenceBrowser support for selecting a SoundTheme.! 248344 248345 248346!PBSoundThemePreferenceView methodsFor: 'as yet unclassified' stamp: 'gvc 9/12/2007 15:10'! 248347allThemeClasses 248348 "Answer the classes that may chosen for the theme." 248349 248350 ^SoundTheme allThemeClasses! ! 248351 248352!PBSoundThemePreferenceView methodsFor: 'as yet unclassified' stamp: 'gvc 1/31/2009 16:18'! 248353preferenceName 248354 "Answer the label to use for this preference." 248355 248356 ^'Sound Theme' translated! ! 248357 248358"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 248359 248360PBSoundThemePreferenceView class 248361 instanceVariableNames: ''! 248362 248363!PBSoundThemePreferenceView class methodsFor: 'as yet unclassified' stamp: 'gvc 9/12/2007 15:18'! 248364initialize 248365 "Inititalize the class. 248366 Register with the PreferenceViewRegistry for ui sound themes." 248367 248368 PreferenceViewRegistry ofSoundThemePreferences register: self. 248369 Preferences 248370 addPreference: #soundTheme 248371 categories: #(morphic windows) 248372 default: SoundTheme 248373 balloonHelp: 'The sound theme used for user interface events.' 248374 projectLocal: false 248375 changeInformee: nil 248376 changeSelector: nil 248377 viewRegistry: PreferenceViewRegistry ofSoundThemePreferences! ! 248378 248379!PBSoundThemePreferenceView class methodsFor: 'as yet unclassified' stamp: 'gvc 9/12/2007 15:17'! 248380unload 248381 "Unload the class. 248382 Unregister with the PreferenceViewRegistry for sound themes." 248383 248384 PreferenceViewRegistry ofSoundThemePreferences unregister: self! ! 248385PBPreferenceView subclass: #PBTextPreferenceView 248386 instanceVariableNames: '' 248387 classVariableNames: '' 248388 poolDictionaries: '' 248389 category: 'PreferenceBrowser'! 248390 248391!PBTextPreferenceView methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/7/2007 20:27'! 248392textField 248393 "Answer a text field for the preference." 248394 248395 ^UITheme current 248396 newAutoAcceptTextEntryIn: World 248397 for: self 248398 get: #preferenceValue 248399 set: #preferenceValue: 248400 class: String 248401 getEnabled: nil 248402 help: nil! ! 248403 248404 248405!PBTextPreferenceView methodsFor: 'user interface' stamp: 'hpt 12/10/2004 22:46'! 248406preferenceValue 248407 ^self preference preferenceValue ifNil: ['']! ! 248408 248409!PBTextPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 11:38'! 248410preferenceValue: aTextOrString 248411 self preference preferenceValue: aTextOrString asString. 248412 ^true.! ! 248413 248414!PBTextPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 11:41'! 248415representativeButtonWithColor: aColor inPanel: aPreferenceBrowser 248416 ^self horizontalPanel 248417 layoutInset: 2; 248418 color: aColor; 248419 cellInset: 20; 248420 cellPositioning: #center; 248421 addMorphBack: (StringMorph contents: self preference name); 248422 addMorphBack: self textField; 248423 yourself.! ! 248424 248425"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 248426 248427PBTextPreferenceView class 248428 instanceVariableNames: ''! 248429 248430!PBTextPreferenceView class methodsFor: 'initialization' stamp: 'hpt 9/26/2004 17:01'! 248431initialize 248432 PreferenceViewRegistry ofTextPreferences register: self.! ! 248433 248434!PBTextPreferenceView class methodsFor: 'initialization' stamp: 'hpt 9/26/2004 17:01'! 248435unload 248436 PreferenceViewRegistry ofTextPreferences unregister: self.! ! 248437PBPreferenceView subclass: #PBUIThemePreferenceView 248438 instanceVariableNames: '' 248439 classVariableNames: '' 248440 poolDictionaries: '' 248441 category: 'Polymorph-Widgets-Themes'! 248442!PBUIThemePreferenceView commentStamp: 'gvc 7/16/2007 13:51' prior: 0! 248443PreferenceBrowser support for selecting a UITheme.! 248444 248445 248446!PBUIThemePreferenceView methodsFor: 'as yet unclassified' stamp: 'gvc 9/12/2007 15:10'! 248447allThemeClasses 248448 "Answer the classes that may chosen for the theme." 248449 248450 ^UITheme allThemeClasses! ! 248451 248452!PBUIThemePreferenceView methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2007 20:51'! 248453newRadioButtonFor: aThemeClass 248454 "Answer radio button for selecting a theme" 248455 248456 ^UITheme current 248457 newRadioButtonIn: World 248458 for: aThemeClass 248459 getSelected: #isCurrent 248460 setSelected: #beCurrent 248461 getEnabled: nil 248462 label: aThemeClass themeName 248463 help: ('Use the {1} theme' translated format: {aThemeClass themeName})! ! 248464 248465!PBUIThemePreferenceView methodsFor: 'as yet unclassified' stamp: 'gvc 1/31/2009 16:18'! 248466preferenceName 248467 "Answer the label to use for this preference." 248468 248469 ^'UI Theme' translated! ! 248470 248471!PBUIThemePreferenceView methodsFor: 'as yet unclassified' stamp: 'gvc 1/31/2009 16:18'! 248472representativeButtonWithColor: aColor inPanel: aPreferencesPanel 248473 "Answer the morph for the panel." 248474 248475 | innerPanel | 248476 innerPanel := self horizontalPanel 248477 addMorphBack: (self blankSpaceOf: 10@0); 248478 addMorphBack: self uiThemeRadioButtons; 248479 yourself. 248480 ^self verticalPanel 248481 color: aColor; 248482 layoutInset: 2; 248483 addMorphBack: (StringMorph contents: self preferenceName); 248484 addMorphBack: innerPanel! ! 248485 248486!PBUIThemePreferenceView methodsFor: 'as yet unclassified' stamp: 'gvc 9/12/2007 15:07'! 248487uiThemeRadioButtons 248488 "Answer a column of butons representing the choices of ui theme" 248489 248490 | buttonColumn | 248491 buttonColumn := self verticalPanel. 248492 self allThemeClasses do: [:c | 248493 buttonColumn addMorphBack: (self newRadioButtonFor: c)]. 248494 ^buttonColumn! ! 248495 248496"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 248497 248498PBUIThemePreferenceView class 248499 instanceVariableNames: ''! 248500 248501!PBUIThemePreferenceView class methodsFor: 'as yet unclassified' stamp: 'gvc 9/12/2007 15:19'! 248502initialize 248503 "Inititalize the class. 248504 Register with the PreferenceViewRegistry for ui themes." 248505 248506 PreferenceViewRegistry ofUIThemePreferences register: self. 248507 Preferences 248508 addPreference: #uiTheme 248509 categories: #(morphic windows) 248510 default: UIThemeStandardSqueak 248511 balloonHelp: 'The style of user interface to use.' 248512 projectLocal: false 248513 changeInformee: nil 248514 changeSelector: nil 248515 viewRegistry: PreferenceViewRegistry ofUIThemePreferences! ! 248516 248517!PBUIThemePreferenceView class methodsFor: 'as yet unclassified' stamp: 'gvc 6/22/2007 15:23'! 248518unload 248519 "Unload the class. 248520 Unregister with the PreferenceViewRegistry for ui themes." 248521 248522 PreferenceViewRegistry ofUIThemePreferences unregister: self! ! 248523PBColorPreferenceView subclass: #PBWindowColorPreferenceView 248524 instanceVariableNames: '' 248525 classVariableNames: '' 248526 poolDictionaries: '' 248527 category: 'PreferenceBrowser'! 248528 248529!PBWindowColorPreferenceView methodsFor: 'initialization' stamp: 'hpt 12/8/2004 18:38'! 248530initialize 248531 super initialize. 248532 self addActionTitled: 'Bright' target: Preferences selector: #installBrightWindowColors arguments: {} balloonText: 'Use standard bright colors for all windows' translated. 248533 self addActionTitled: 'Pastel' target: Preferences selector: #installPastelWindowColors arguments: {} balloonText: 'Use standard pastel colors for all windows' translated. 248534 self addActionTitled: 'White' target: Preferences selector: #installUniformWindowColors arguments: {} balloonText: 'Use white backgrounds for all standard windows' translated.! ! 248535 248536"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 248537 248538PBWindowColorPreferenceView class 248539 instanceVariableNames: ''! 248540 248541!PBWindowColorPreferenceView class methodsFor: 'initialization' stamp: 'hpt 12/8/2004 18:40'! 248542initialize 248543 self viewRegistry register: self.! ! 248544 248545!PBWindowColorPreferenceView class methodsFor: 'initialization' stamp: 'hpt 12/8/2004 18:40'! 248546unload 248547 self viewRegistry unregister: self.! ! 248548 248549!PBWindowColorPreferenceView class methodsFor: 'initialization' stamp: 'hpt 12/8/2004 18:40'! 248550viewRegistry 248551 ^(PreferenceViewRegistry registryOf: #windowColorPreferences) 248552 viewOrder: 6; 248553 yourself.! ! 248554PrimCallControllerAbstract subclass: #PCCByCompilation 248555 instanceVariableNames: '' 248556 classVariableNames: '' 248557 poolDictionaries: '' 248558 category: 'Tests-PrimCallController'! 248559!PCCByCompilation commentStamp: 'sr 6/16/2004 09:00' prior: 0! 248560This class is for switching external prim calls (primitiveExternalCall) on and off. 248561 248562It is best suited for permanently switching plugin calls off while preserving the possibility to switch them on later. For plugin testing purposes you probably should use PCCByLiterals for temporarily switch on/off them instead. 248563 248564It works on a source code basis by compilation: 248565 Disabling works by putting an enabled prim call into a special comment followed by a recompile to transform it into a disabled one. 248566 Enabling works by pulling the disabled prim call out of the special comment followed by a recompile to transform it into an enabled one. 248567 248568As a consequence, enabling of prims only works with method sources containing the mentioned special comment, which normally has been generated by this tool for disabling the corresponding prim. 248569 248570Please look into superclass PrimCallControllerAbstract for more info and the user interface. 248571 248572Structure: 248573 No instVars here: look into superclass. 248574 248575Implementation note: 248576To harden it for sunit testing purposes some special accessing of the source code has been necessary: to avoid accessing different processes a sources file at once, followed by generating garbage, the process priority of actions leading to these accesses has been increased (sunit tests run in the background). A better solution would be to introduce a source file locking mechanism.! 248577]style[(107 11 138 13 5 11 62 14 3 9 124 8 245 9 36 9 26 28 26 93 20 384)f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2LPCCByLiterals Comment;,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2,f2FAccuny#12,f3FAccuny#12,f2FAccuny#12,f2,f2LPrimCallControllerAbstract Comment;,f2,FAccuny#15uf2,f2! 248578 248579 248580!PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:30'! 248581comment 248582 ^ '{prim disabled by ', self className, '} '! ! 248583 248584!PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:31'! 248585disabledPrimStartString 248586 ^ '"', self comment, self enabledPrimStartString! ! 248587 248588!PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:31'! 248589disabledPrimStopChar 248590 "end of disabling comment" 248591 ^ $"! ! 248592 248593!PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:31'! 248594enabledPrimStartString 248595 ^ '<primitive:'! ! 248596 248597!PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:31'! 248598enabledPrimStopChar 248599 ^ $>! ! 248600 248601 248602!PCCByCompilation methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:33'! 248603extractCallModuleNames: aMethodRef 248604 ^ (self existsCompiledCallIn: aMethodRef) 248605 ifTrue: [self extractCallModuleNamesFromLiterals: aMethodRef] 248606 ifFalse: [| src | 248607 "try source" 248608 "higher priority to avoid source file accessing errors" 248609 [src := aMethodRef sourceString] 248610 valueAt: self higherPriority. 248611 self extractCallNamesFromPrimString: ((self extractDisabledPrimStringFrom: src) 248612 ifNil: ["no disabled prim string found" 248613 ^ nil]) first]! ! 248614 248615!PCCByCompilation methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:38'! 248616methodsWithCall 248617 "Expensive!! For just querying the system unaffected by an instance of 248618 this class use PCCByLiterals instead." 248619 ^ self methodsWithCompiledCall , self methodsWithDisabledCall! ! 248620 248621!PCCByCompilation methodsFor: 'ui querying' stamp: 'md 8/27/2005 17:17'! 248622methodsWithDisabledCall 248623 "Answer a SortedCollection of all the methods that contain, in source 248624 code, the substring indicating a disabled prim." 248625 "The alternative implementation 248626 ^ SystemNavigation new allMethodsWithSourceString: self disabledPrimStartString 248627 matchCase: true 248628 also searches in class comments." 248629 | list classCount string | 248630 string := self disabledPrimStartString. 248631 list := Set new. 248632 'Searching all method source code...' 248633 displayProgressAt: Sensor cursorPoint 248634 from: 0 248635 to: Smalltalk classNames size * 2 "classes with their metaclasses" 248636 during: [:bar | 248637 classCount := 0. 248638 SystemNavigation default 248639 allBehaviorsDo: [:class | 248640 bar value: (classCount := classCount + 1). 248641 class 248642 selectorsDo: [:sel | 248643 | src | 248644 "higher priority to avoid source file accessing 248645 errors" 248646 [src := class sourceCodeAt: sel] 248647 valueAt: self higherPriority. 248648 (src 248649 findString: string 248650 startingAt: 1 248651 caseSensitive: true) > 0 248652 ifTrue: [sel isDoIt ifFalse: [ 248653 list add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]]]. 248654 ^ list asSortedCollection! ! 248655 248656 248657!PCCByCompilation methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:26'! 248658existsCallIn: aMethodRef 248659 "Here existsCompiledCallIn: (see also comment there) is sufficient to 248660 query for enabled and failed, but not for disabled prim calls: so check 248661 for disabled ones in sources, too." 248662 ^ (self existsCompiledCallIn: aMethodRef) 248663 or: [self existsDisabledCallIn: aMethodRef]! ! 248664 248665!PCCByCompilation methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:07'! 248666existsDisabledCallIn: aMethodRef 248667 | src | 248668 ^ (self existsCompiledCallIn: aMethodRef) not 248669 and: ["higher priority to avoid source file accessing errors" 248670 [src := aMethodRef sourceString] 248671 valueAt: self higherPriority. 248672 self methodSourceContainsDisabledCall: src]! ! 248673 248674 248675!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:26'! 248676disabled2EnabledPrimMethodString: aSourceString 248677 | start stop primString extract | 248678 extract := self extractDisabledPrimStringFrom: aSourceString. 248679 primString := extract at: 1. 248680 start := extract at: 2. 248681 stop := start + primString size - 1. 248682 ^ aSourceString 248683 copyReplaceFrom: start 248684 to: stop 248685 with: (self disabled2EnabledPrimString: primString)! ! 248686 248687!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:26'! 248688disabled2EnabledPrimString: aDisabledPrimString 248689 "remove comment quotes and comment after first comment quote" 248690 | enabledPrimString | 248691 enabledPrimString := aDisabledPrimString copyFrom: self comment size + 2 to: aDisabledPrimString size - 1. 248692 ^ enabledPrimString! ! 248693 248694!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:28'! 248695enabled2DisabledPrimMethodString: aSourceString 248696 | start stop primString extract | 248697 extract := self extractEnabledPrimStringFrom: aSourceString. 248698 primString := extract at: 1. 248699 start := extract at: 2. 248700 stop := start + primString size - 1. 248701 ^ aSourceString 248702 copyReplaceFrom: start 248703 to: stop 248704 with: (self enabled2DisabledPrimString: primString)! ! 248705 248706!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:28'! 248707enabled2DisabledPrimString: anEnabledPrimString 248708 | disabledPrimString | 248709 disabledPrimString := '"' , self comment , anEnabledPrimString , '"'. 248710 ^ disabledPrimString! ! 248711 248712!PCCByCompilation methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'! 248713extractCallNamesFromPrimString: aString 248714 "method works for both enabled and disabled prim strings" 248715 "<primitive: 'doSomething' module:'ModuleFoo'" 248716 | tokens | 248717 tokens := aString findTokens: ''''. 248718 ^ (tokens at: 2) -> (tokens at: 4 ifAbsent: [nil])! ! 248719 248720!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/11/2004 07:10'! 248721extractDisabledPrimStringFrom: aSourceString 248722 | startString start stop | 248723 startString := self disabledPrimStartString. 248724 start := aSourceString findString: startString. 248725 start = 0 248726 ifTrue: [^ nil]. 248727 stop := aSourceString indexOf: self disabledPrimStopChar startingAt: start + startString size. 248728 stop = 0 248729 ifTrue: [^ nil]. 248730 ^ {aSourceString copyFrom: start to: stop. start}! ! 248731 248732!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:29'! 248733extractEnabledPrimStringFrom: aSourceString 248734 | startString start stop | 248735 startString := self enabledPrimStartString. 248736 start := aSourceString findString: startString. 248737 start = 0 248738 ifTrue: [^ nil]. 248739 stop := aSourceString indexOf: self enabledPrimStopChar startingAt: start + startString size. 248740 stop = 0 248741 ifTrue: [^ nil]. 248742 ^ {aSourceString copyFrom: start to: stop. start}! ! 248743 248744!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:29'! 248745higherPriority 248746 "this priority seems to be necessary to avoid source file accessing errors" 248747 ^ Processor userSchedulingPriority + 1! ! 248748 248749!PCCByCompilation methodsFor: 'private' stamp: 'sr 6/11/2004 07:06'! 248750methodSourceContainsDisabledCall: methodSource 248751 ^ (methodSource findString: self disabledPrimStartString) 248752 ~= 0! ! 248753 248754 248755!PCCByCompilation methodsFor: 'private user interface' stamp: 'sr 6/14/2004 01:37'! 248756privateDisableCallIn: aMethodRef 248757 "Disables enabled or failed external prim call by recompiling method 248758 with prim call commented out, will be called by superclass." 248759 | src newMethodSource | 248760 "higher priority to avoid source file accessing errors" 248761 [src := aMethodRef sourceString] 248762 valueAt: self higherPriority. 248763 newMethodSource := self enabled2DisabledPrimMethodString: src. 248764 "higher priority to avoid source file accessing errors" 248765 [aMethodRef actualClass 248766 compile: newMethodSource 248767 classified: (aMethodRef actualClass whichCategoryIncludesSelector: aMethodRef methodSymbol) 248768 notifying: nil] 248769 valueAt: self higherPriority! ! 248770 248771!PCCByCompilation methodsFor: 'private user interface' stamp: 'sr 6/14/2004 02:10'! 248772privateEnableCallIn: aMethodRef 248773 "Enables disabled external prim call by recompiling method with prim 248774 call taken from disabling comment, will be called by superclass." 248775 | src newMethodSource | 248776 "higher priority to avoid source file accessing errors" 248777 [src := aMethodRef sourceString] 248778 valueAt: self higherPriority. 248779 newMethodSource := self disabled2EnabledPrimMethodString: src. 248780 "higher priority to avoid source file accessing errors" 248781 [aMethodRef actualClass 248782 compile: newMethodSource 248783 classified: (aMethodRef actualClass whichCategoryIncludesSelector: aMethodRef methodSymbol) 248784 notifying: nil] 248785 valueAt: self higherPriority! ! 248786PrimCallControllerAbstractTest subclass: #PCCByCompilationTest 248787 instanceVariableNames: '' 248788 classVariableNames: '' 248789 poolDictionaries: '' 248790 category: 'Tests-PrimCallController'! 248791!PCCByCompilationTest commentStamp: 'sr 6/14/2004 22:05' prior: 0! 248792PCCByCompilation tests. 248793 248794Tests are in the superclass and inherited from there.! 248795 248796 248797!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/11/2004 05:22'! 248798classToBeTested 248799 ^ PCCByCompilation! ! 248800 248801!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:36'! 248802disabledCallSelectors 248803 ^ #(#cDisabledRealExternalCall #cDisabledRealExternalCallNaked #cDisabledRealExternalCallOrPrimitiveFailed #cDisabledExternalCallWithoutModule )! ! 248804 248805!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:34'! 248806enabledCallSelectors 248807 ^ #(#cRealExternalCall #cRealExternalCallNaked #cRealExternalCallOrPrimitiveFailed #cExternalCallWithoutModule )! ! 248808 248809!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:44'! 248810exampleModuleName 248811 ^ 'CPCCT'! ! 248812 248813!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/15/2004 02:42'! 248814failModuleName 248815 ^ 'CFailModule'! ! 248816 248817!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/14/2004 00:14'! 248818failedCallSelector 248819 ^ #cFailedCall! ! 248820 248821!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:40'! 248822methodSelectorsToExampleModule 248823 ^ #(#cExternalCall1 #cExternalCall2 )! ! 248824 248825!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'! 248826moduleNameNotWithSingularCallName 248827 ^ 'CNotOne'! ! 248828 248829!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'! 248830moduleNameWithSingularCallName 248831 ^ 'COne'! ! 248832 248833!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 09:52'! 248834noExternalCallSelector 248835 ^ #cNoExternalCall! ! 248836 248837!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:28'! 248838realExternalCallOrPrimitiveFailedSelector 248839 ^ #cRealExternalCallOrPrimitiveFailed! ! 248840 248841!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:54'! 248842singularCallName 248843 "occurrs exactly once as prim call name in >>cSingularExternalCall" 248844 ^ 'cSingularExternalCall'! ! 248845 248846!PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/14/2004 23:33'! 248847singularCallSelector 248848 ^ #cSingularExternalCall! ! 248849 248850 248851!PCCByCompilationTest methodsFor: 'example module' stamp: 'sd 7/21/2009 10:04'! 248852cExternalCall1 248853 <primitive: 'prim1' module: 'CPCCT'> 248854! ! 248855 248856!PCCByCompilationTest methodsFor: 'example module' stamp: 'sd 7/21/2009 10:04'! 248857cExternalCall2 248858 <primitive:'prim2'module:'CPCCT'> 248859 self primitiveFailed! ! 248860 248861 248862!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/11/2004 05:36'! 248863cDisabledExternalCallWithoutModule 248864 "{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName'>" 248865 ^ 'Hello World!!'! ! 248866 248867!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 23:54'! 248868cDisabledRealExternalCall 248869 "{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName' module:'LargeIntegers'>" 248870 ^ 'Hello World!!'! ! 248871 248872!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 23:54'! 248873cDisabledRealExternalCallNaked 248874 "{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName' module:'LargeIntegers'>"! ! 248875 248876!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 23:54'! 248877cDisabledRealExternalCallOrPrimitiveFailed 248878 "{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName' module:'LargeIntegers'>" 248879 self primitiveFailed! ! 248880 248881!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 09:48'! 248882cExternalCallWithoutModule 248883 <primitive: 'primGetModuleName'> 248884 ^ 'Hello World!!'! ! 248885 248886!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sd 7/21/2009 10:04'! 248887cFailedCall 248888 <primitive: 'primGetModuleName' module:'CFailModule'> 248889 ^ 'failed call'! ! 248890 248891!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 09:48'! 248892cNoExternalCall 248893 ^ 'Hello World!!'! ! 248894 248895!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! 248896cRealExternalCall 248897 <primitive: 'primGetModuleName' module:'LargeIntegers'> 248898 ^ 'Hello World!!'! ! 248899 248900!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! 248901cRealExternalCallNaked 248902 <primitive: 'primGetModuleName' module:'LargeIntegers'>! ! 248903 248904!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sd 7/21/2009 10:04'! 248905cRealExternalCallOrPrimitiveFailed 248906 <primitive: 'primGetModuleName' module:'LargeIntegers'> 248907 self primitiveFailed! ! 248908 248909!PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/15/2004 04:35'! 248910cSingularExternalCall 248911 <primitive: 'cSingularExternalCall' module:'COne'> 248912 ^ 'Hello World!!'! ! 248913 248914"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 248915 248916PCCByCompilationTest class 248917 instanceVariableNames: ''! 248918 248919!PCCByCompilationTest class methodsFor: 'testing' stamp: 'sr 6/7/2004 12:01'! 248920isAbstract 248921 ^ false! ! 248922PrimCallControllerAbstract subclass: #PCCByLiterals 248923 instanceVariableNames: '' 248924 classVariableNames: '' 248925 poolDictionaries: '' 248926 category: 'Tests-PrimCallController'! 248927!PCCByLiterals commentStamp: 'sr 6/16/2004 09:14' prior: 0! 248928This class is for switching external prim calls (primitiveExternalCall) on and off. 248929 248930It is best suited for plugin testing purposes with temporarily switching plugin calls off and on. For permanently switching plugin calls off while preserving the possibility to switch them on later, you should use PCCByCompilation instead. 248931 248932It works by manipulating literals in the CompiledMethods: 248933 Disabling works by changing the function index in the first literal of the CompiledMethod to a negative value (-2). This leads to a fast fail (value -2 is used for disabling to make a difference to the standard failed value of -1). 248934 Enabling works by changing the function index in the first literal of the CompiledMethod to 0, followed by flushing the method cache. This enforces a fresh lookup. 248935 248936Please look into superclass PrimCallControllerAbstract for more info and the user interface. 248937 248938Structure: 248939 No instVars here: look into superclass.! 248940]style[(136 11 40 11 101 16 10 1 9 2 14 8 26 9 224 8 157 28 26 91)f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2LPCCByCompilation Comment;,f2FAccuny#12,f2,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2,f2LPrimCallControllerAbstract Comment;,f2! 248941 248942 248943!PCCByLiterals methodsFor: 'ui querying' stamp: 'sr 6/11/2004 07:04'! 248944extractCallModuleNames: aMethodRef 248945 ^ (self existsCallIn: aMethodRef) 248946 ifTrue: [self extractCallModuleNamesFromLiterals: aMethodRef]! ! 248947 248948!PCCByLiterals methodsFor: 'ui querying' stamp: 'sr 6/11/2004 07:05'! 248949methodsWithCall 248950 ^ self methodsWithCompiledCall! ! 248951 248952!PCCByLiterals methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:24'! 248953methodsWithDisabledCall 248954 ^ self methodsWithCompiledCall 248955 select: [:mRef | (mRef compiledMethod literals first at: 4) 248956 = -2]! ! 248957 248958 248959!PCCByLiterals methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:04'! 248960existsCallIn: aMethodRef 248961 "Here >>existsCompiledCallIn: (see also comment there) is sufficient to 248962 query for all enabled, failed and disabled prim calls; for the by 248963 compiler version it is not sufficient for disabled ones." 248964 ^ self existsCompiledCallIn: aMethodRef! ! 248965 248966!PCCByLiterals methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:30'! 248967existsDisabledCallIn: aMethodRef 248968 ^ (self existsCompiledCallIn: aMethodRef) 248969 and: [(aMethodRef compiledMethod literals first at: 4) 248970 = -2]! ! 248971 248972 248973!PCCByLiterals methodsFor: 'private user interface' stamp: 'sr 6/14/2004 01:35'! 248974privateDisableCallIn: aMethodRef 248975 "Disables enabled or failed external prim call by filling function ref 248976 literal with special fail value, will be called by superclass." 248977 aMethodRef compiledMethod literals first at: 4 put: -2! ! 248978 248979!PCCByLiterals methodsFor: 'private user interface' stamp: 'sr 6/14/2004 02:07'! 248980privateEnableCallIn: aMethodRef 248981 "Enables disabled external prim call." 248982 self privateEnableViaLiteralIn: aMethodRef! ! 248983PrimCallControllerAbstractTest subclass: #PCCByLiteralsTest 248984 instanceVariableNames: '' 248985 classVariableNames: '' 248986 poolDictionaries: '' 248987 category: 'Tests-PrimCallController'! 248988!PCCByLiteralsTest commentStamp: 'sr 6/14/2004 22:05' prior: 0! 248989PCCByLiterals tests. 248990 248991Tests are in the superclass and inherited from there.! 248992 248993 248994!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/11/2004 05:23'! 248995classToBeTested 248996 ^ PCCByLiterals! ! 248997 248998!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:37'! 248999disabledCallSelectors 249000 ^ #(#lDisabledRealExternalCall #lDisabledRealExternalCallNaked #lDisabledRealExternalCallOrPrimitiveFailed #lDisabledExternalCallWithoutModule )! ! 249001 249002!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:34'! 249003enabledCallSelectors 249004 ^ #(#lRealExternalCall #lRealExternalCallNaked #lRealExternalCallOrPrimitiveFailed #lExternalCallWithoutModule )! ! 249005 249006!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:45'! 249007exampleModuleName 249008 ^ 'LPCCT'! ! 249009 249010!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/15/2004 02:42'! 249011failModuleName 249012 ^ 'LFailModule'! ! 249013 249014!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/14/2004 00:12'! 249015failedCallSelector 249016 ^ #lFailedCall! ! 249017 249018!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:41'! 249019methodSelectorsToExampleModule 249020 ^ #(#lExternalCall1 #lExternalCall2 )! ! 249021 249022!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'! 249023moduleNameNotWithSingularCallName 249024 ^ 'LNotOne'! ! 249025 249026!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'! 249027moduleNameWithSingularCallName 249028 ^ 'LOne'! ! 249029 249030!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:16'! 249031noExternalCallSelector 249032 ^ #lNoExternalCall! ! 249033 249034!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:29'! 249035realExternalCallOrPrimitiveFailedSelector 249036 ^ #lRealExternalCallOrPrimitiveFailed! ! 249037 249038!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:54'! 249039singularCallName 249040 "occurrs exactly once as prim call name in >>lSingularExternalCall" 249041 ^ 'lSingularExternalCall'! ! 249042 249043!PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/14/2004 23:32'! 249044singularCallSelector 249045 ^ #lSingularExternalCall! ! 249046 249047 249048!PCCByLiteralsTest methodsFor: 'example module' stamp: 'sr 6/7/2004 08:39'! 249049lExternalCall1 249050 <primitive: 'prim1' module: 'LPCCT'> 249051! ! 249052 249053!PCCByLiteralsTest methodsFor: 'example module' stamp: 'sr 6/7/2004 08:39'! 249054lExternalCall2 249055 <primitive:'prim2'module:'LPCCT'> 249056 self primitiveFailed! ! 249057 249058 249059!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 08:51'! 249060lDisabledExternalCallWithoutModule 249061 <primitive: 'primGetModuleName'> 249062 ^ 'Hello World!!'! ! 249063 249064!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! 249065lDisabledRealExternalCall 249066 <primitive: 'primGetModuleName' module:'LargeIntegers'> 249067 ^ 'Hello World!!'! ! 249068 249069!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! 249070lDisabledRealExternalCallNaked 249071 <primitive: 'primGetModuleName' module:'LargeIntegers'>! ! 249072 249073!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! 249074lDisabledRealExternalCallOrPrimitiveFailed 249075 <primitive: 'primGetModuleName' module:'LargeIntegers'> "primitiveExternalCall" 249076 self primitiveFailed! ! 249077 249078!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 09:59'! 249079lExternalCallWithoutModule 249080 <primitive: 'primGetModuleName'> "primitiveExternalCall" 249081 ^ 'Hello World!!'! ! 249082 249083!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/15/2004 02:41'! 249084lFailedCall 249085 <primitive: 'primGetModuleName' module:'LFailModule'> 249086 ^ 'failed call'! ! 249087 249088!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 09:57'! 249089lNoExternalCall 249090 ^ 'Hello World!!'! ! 249091 249092!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! 249093lRealExternalCall 249094 <primitive: 'primGetModuleName' module:'LargeIntegers'> 249095 ^ 'Hello World!!'! ! 249096 249097!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! 249098lRealExternalCallNaked 249099 <primitive: 'primGetModuleName' module:'LargeIntegers'>! ! 249100 249101!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! 249102lRealExternalCallOrPrimitiveFailed 249103 <primitive: 'primGetModuleName' module:'LargeIntegers'> 249104 self primitiveFailed! ! 249105 249106!PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 10:52'! 249107lSingularExternalCall 249108 <primitive: 'lSingularExternalCall' module:'LOne'> 249109 ^ 'Hello World!!'! ! 249110 249111 249112!PCCByLiteralsTest methodsFor: 'tests' stamp: 'sr 6/7/2004 11:30'! 249113setUp 249114 super setUp. 249115 "disable external calls" 249116 (self class selectors 249117 select: [:sel | sel beginsWith: 'lDisabled']) 249118 do: [:sel | (self class >> sel) literals first at: 4 put: -2]! ! 249119 249120"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 249121 249122PCCByLiteralsTest class 249123 instanceVariableNames: ''! 249124 249125!PCCByLiteralsTest class methodsFor: 'testing' stamp: 'sr 6/7/2004 12:01'! 249126isAbstract 249127 ^ false! ! 249128ImageReadWriter subclass: #PCXReadWriter 249129 instanceVariableNames: 'version encoding colorPlanes isGrayScale width height bitsPerPixel colorPalette rowByteSize' 249130 classVariableNames: '' 249131 poolDictionaries: '' 249132 category: 'Graphics-Files'! 249133 249134!PCXReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 249135nextImage 249136 "Read in the next PCX image from the stream." 249137 | bytes form | 249138 self readHeader. 249139 bytes := self readBody. 249140 colorPalette := self readPalette. 249141 self close. 249142 form := ColorForm 249143 extent: width @ height 249144 depth: bitsPerPixel. 249145 (Form new hackBits: bytes) displayOn: (Form new hackBits: form bits). 249146 form colors: colorPalette. 249147 ^ form! ! 249148 249149 249150!PCXReadWriter methodsFor: 'private-decoding' stamp: 'tao 10/6/97 08:38'! 249151nextWord 249152 ^self next + (self next bitShift: 8)! ! 249153 249154!PCXReadWriter methodsFor: 'private-decoding' stamp: 'lr 7/4/2009 10:42'! 249155readBody 249156 | array scanLine rowBytes position byte count pad | 249157 pad := #(0 3 2 1 ) at: width \\ 4 + 1. 249158 array := ByteArray new: (width + pad) * height * bitsPerPixel // 8. 249159 scanLine := ByteArray new: rowByteSize. 249160 position := 1. 249161 1 249162 to: height 249163 do: 249164 [ :line | 249165 rowBytes := 0. 249166 [ rowBytes < rowByteSize ] whileTrue: 249167 [ byte := self next. 249168 byte < 192 249169 ifTrue: 249170 [ rowBytes := rowBytes + 1. 249171 scanLine 249172 at: rowBytes 249173 put: byte ] 249174 ifFalse: 249175 [ count := byte - 192. 249176 byte := self next. 249177 1 249178 to: count 249179 do: 249180 [ :i | 249181 scanLine 249182 at: rowBytes + i 249183 put: byte ]. 249184 rowBytes := rowBytes + count ] ]. 249185 array 249186 replaceFrom: position 249187 to: position + width - 1 249188 with: scanLine 249189 startingAt: 1. 249190 position := position + width + pad ]. 249191 ^ array! ! 249192 249193!PCXReadWriter methodsFor: 'private-decoding' stamp: 'lr 7/4/2009 10:42'! 249194readHeader 249195 | xMin xMax yMin yMax | 249196 self next. "skip over manufacturer field" 249197 version := self next. 249198 encoding := self next. 249199 bitsPerPixel := self next. 249200 xMin := self nextWord. 249201 yMin := self nextWord. 249202 xMax := self nextWord. 249203 yMax := self nextWord. 249204 width := xMax - xMin + 1. 249205 height := yMax - yMin + 1. 249206 self next: 4. "skip over device resolution" 249207 self next: 49. "skip over EGA color palette" 249208 colorPlanes := self next. 249209 rowByteSize := self nextWord. 249210 isGrayScale := (self next: 2) = 2. 249211 self next: 58 "skip over filler"! ! 249212 249213!PCXReadWriter methodsFor: 'private-decoding' stamp: 'lr 7/4/2009 10:42'! 249214readPalette 249215 | r g b array | 249216 self next = 12 ifFalse: [ self error: 'no Color Palette!!' ]. 249217 array := Array new: (1 bitShift: bitsPerPixel). 249218 1 249219 to: array size 249220 do: 249221 [ :i | 249222 r := self next. 249223 g := self next. 249224 b := self next. 249225 array 249226 at: i 249227 put: (Color 249228 r: r 249229 g: g 249230 b: b 249231 range: 255) ]. 249232 ^ array! ! 249233 249234"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 249235 249236PCXReadWriter class 249237 instanceVariableNames: ''! 249238 249239!PCXReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:57'! 249240typicalFileExtensions 249241 "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" 249242 ^#('pcx')! ! 249243ImageReadWriter subclass: #PNGReadWriter 249244 instanceVariableNames: 'chunk form width height depth backColor bitsPerChannel colorType interlaceMethod bitsPerPixel bytesPerScanline thisScanline prevScanline rowSize globalDataChunk unknownChunks palette transparentPixelValue filtersSeen swizzleMap cachedDecoderMap bigEndian' 249245 classVariableNames: 'BPP BlockHeight BlockWidth Debugging StandardColors StandardSwizzleMaps' 249246 poolDictionaries: '' 249247 category: 'Graphics-Files'! 249248!PNGReadWriter commentStamp: '<historical>' prior: 0! 249249I am a subclass of ImageReadWriter that decodes Portable Network Graphics 249250(PNG) images. 249251 249252Submitted by Duane Maxwell! 249253 249254 249255!PNGReadWriter methodsFor: 'accessing' stamp: 'RAA 11/7/2000 09:20'! 249256debugging 249257 249258 ^Debugging == true! ! 249259 249260!PNGReadWriter methodsFor: 'accessing' stamp: 'nk 7/30/2004 17:51'! 249261nextImage 249262 bigEndian := SmalltalkImage current isBigEndian. 249263 filtersSeen := Bag new. 249264 globalDataChunk := nil. 249265 transparentPixelValue := nil. 249266 unknownChunks := Set new. 249267 stream reset. 249268 stream binary. 249269 stream skip: 8. 249270 [stream atEnd] whileFalse: [self processNextChunk]. 249271 "Set up our form" 249272 palette ifNotNil: 249273 ["Dump the palette if it's the same as our standard palette" 249274 249275 palette = (StandardColors copyFrom: 1 to: palette size) 249276 ifTrue: [palette := nil]]. 249277 (depth <= 8 and: [palette notNil]) 249278 ifTrue: 249279 [form := ColorForm extent: width @ height depth: depth. 249280 form colors: palette] 249281 ifFalse: [form := Form extent: width @ height depth: depth]. 249282 backColor ifNotNil: [form fillColor: backColor]. 249283 chunk := globalDataChunk ifNil: [self error: 'image data is missing']. 249284 chunk ifNotNil: [self processIDATChunk]. 249285 unknownChunks isEmpty 249286 ifFalse: 249287 ["Transcript show: ' ',unknownChunks asSortedCollection asArray printString." 249288 249289 ]. 249290 self debugging 249291 ifTrue: 249292 [Transcript 249293 cr; 249294 show: 'form = ' , form printString. 249295 Transcript 249296 cr; 249297 show: 'colorType = ' , colorType printString. 249298 Transcript 249299 cr; 249300 show: 'interlaceMethod = ' , interlaceMethod printString. 249301 Transcript 249302 cr; 249303 show: 'filters = ' , filtersSeen sortedCounts asArray printString]. 249304 ^form! ! 249305 249306!PNGReadWriter methodsFor: 'accessing' stamp: 'DSM 3/24/2000 01:12'! 249307understandsImageFormat 249308 #(137 80 78 71 13 10 26 10) do: [ :byte | 249309 stream next = byte ifFalse: [^ false]]. 249310 ^ true 249311! ! 249312 249313 249314!PNGReadWriter methodsFor: 'chunks' stamp: 'lr 7/4/2009 10:42'! 249315processBackgroundChunk 249316 "Transcript show: ' BACKGROUND: ',chunk printString." 249317 | val red green blue max | 249318 colorType = 3 ifTrue: 249319 [ backColor := palette at: chunk first + 1. 249320 ^ self ]. 249321 max := (2 raisedTo: bitsPerChannel) - 1. 249322 (colorType = 0 or: [ colorType = 4 ]) ifTrue: 249323 [ val := chunk 249324 unsignedShortAt: 1 249325 bigEndian: true. 249326 backColor := Color gray: val / max. 249327 ^ self ]. 249328 (colorType = 2 or: [ colorType = 6 ]) ifTrue: 249329 [ red := chunk 249330 unsignedShortAt: 1 249331 bigEndian: true. 249332 green := chunk 249333 unsignedShortAt: 3 249334 bigEndian: true. 249335 blue := chunk 249336 unsignedShortAt: 5 249337 bigEndian: true. 249338 backColor := Color 249339 r: red / max 249340 g: green / max 249341 b: blue / max. 249342 ^ self ] 249343 "self halt." 249344 249345 "==== 249346The bKGD chunk specifies a default background color to present the image against. Note that viewers are not bound to honor this chunk; a viewer can choose to use a different background. 249347 249348For color type 3 (indexed color), the bKGD chunk contains: 249349 249350 249351 Palette index: 1 byte 249352 249353The value is the palette index of the color to be used as background. 249354 249355For color types 0 and 4 (grayscale, with or without alpha), bKGD contains: 249356 249357 249358 Gray: 2 bytes, range 0 .. (2^bitdepth)-1 249359 249360(For consistency, 2 bytes are used regardless of the image bit depth.) The value is the gray level to be used as background. 249361 249362For color types 2 and 6 (truecolor, with or without alpha), bKGD contains: 249363 249364 249365 Red: 2 bytes, range 0 .. (2^bitdepth)-1 249366 Green: 2 bytes, range 0 .. (2^bitdepth)-1 249367 Blue: 2 bytes, range 0 .. (2^bitdepth)-1 249368 249369(For consistency, 2 bytes per sample are used regardless of the image bit depth.) This is the RGB color to be used as background. 249370 249371When present, the bKGD chunk must precede the first IDAT chunk, and must follow the PLTE chunk, if any. 249372==="! ! 249373 249374!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/4/2000 17:00'! 249375processIDATChunk 249376 249377 interlaceMethod = 0 249378 ifTrue: [ self processNonInterlaced ] 249379 ifFalse: [ self processInterlaced ] 249380! ! 249381 249382!PNGReadWriter methodsFor: 'chunks' stamp: 'lr 7/4/2009 10:42'! 249383processIHDRChunk 249384 width := chunk 249385 longAt: 1 249386 bigEndian: true. 249387 height := chunk 249388 longAt: 5 249389 bigEndian: true. 249390 bitsPerChannel := chunk at: 9. 249391 colorType := chunk at: 10. 249392 "compression _ chunk at: 11." "TODO - validate compression" 249393 "filterMethod _ chunk at: 12." "TODO - validate filterMethod" 249394 interlaceMethod := chunk at: 13. "TODO - validate interlace method" 249395 (#(2 4 6 ) includes: colorType) ifTrue: [ depth := 32 ]. 249396 (#(0 3 ) includes: colorType) ifTrue: 249397 [ depth := bitsPerChannel min: 8. 249398 colorType = 0 ifTrue: 249399 [ "grayscale" 249400 palette := self grayColorsFor: depth ] ]. 249401 bitsPerPixel := (BPP at: colorType + 1) at: bitsPerChannel highBit. 249402 bytesPerScanline := (width * bitsPerPixel + 7) // 8. 249403 rowSize := width * depth + 31 >> 5! ! 249404 249405!PNGReadWriter methodsFor: 'chunks' stamp: 'lr 7/4/2009 10:42'! 249406processInterlaced 249407 | z filter bytesPerPass startingCol colIncrement rowIncrement startingRow cx sc temp | 249408 startingCol := #(0 4 0 2 0 1 0 ). 249409 colIncrement := #(8 8 4 4 2 2 1 ). 249410 rowIncrement := #(8 8 8 4 4 2 2 ). 249411 startingRow := #(0 0 4 0 2 0 1 ). 249412 z := ZLibReadStream 249413 on: chunk 249414 from: 1 249415 to: chunk size. 249416 1 249417 to: 7 249418 do: 249419 [ :pass | 249420 (self doPass: pass) ifTrue: 249421 [ cx := colIncrement at: pass. 249422 sc := startingCol at: pass. 249423 bytesPerPass := ((width - sc + cx - 1) // cx * bitsPerPixel + 7) // 8. 249424 prevScanline := ByteArray new: bytesPerPass. 249425 thisScanline := ByteArray new: bytesPerScanline. 249426 (startingRow at: pass) 249427 to: height - 1 249428 by: (rowIncrement at: pass) 249429 do: 249430 [ :y | 249431 filter := z next. 249432 filtersSeen add: filter. 249433 (filter isNil or: [ (filter 249434 between: 0 249435 and: 4) not ]) ifTrue: [ ^ self ]. 249436 thisScanline := z 249437 next: bytesPerPass 249438 into: thisScanline 249439 startingAt: 1. 249440 self 249441 filterScanline: filter 249442 count: bytesPerPass. 249443 self 249444 copyPixels: y 249445 at: sc 249446 by: cx. 249447 temp := prevScanline. 249448 prevScanline := thisScanline. 249449 thisScanline := temp ] ] ]. 249450 z atEnd ifFalse: [ self error: 'Unexpected data' ]! ! 249451 249452!PNGReadWriter methodsFor: 'chunks' stamp: 'lr 7/4/2009 10:42'! 249453processNextChunk 249454 | length chunkType crc chunkCrc | 249455 length := self nextLong. 249456 chunkType := (self next: 4) asString. 249457 chunk := self next: length. 249458 chunkCrc := self nextLong bitXor: 4294967295. 249459 crc := self 249460 updateCrc: 4294967295 249461 from: 1 249462 to: 4 249463 in: chunkType. 249464 crc := self 249465 updateCrc: crc 249466 from: 1 249467 to: length 249468 in: chunk. 249469 crc = chunkCrc ifFalse: [ self error: 'PNGReadWriter crc error in chunk ' , chunkType ]. 249470 chunkType = 'IEND' ifTrue: [ ^ self "*should* be the last chunk" ]. 249471 chunkType = 'sBIT' ifTrue: 249472 [ ^ self processSBITChunk "could indicate unusual sample depth in original" ]. 249473 chunkType = 'gAMA' ifTrue: [ ^ self "indicates gamma correction value" ]. 249474 chunkType = 'bKGD' ifTrue: [ ^ self processBackgroundChunk ]. 249475 chunkType = 'pHYs' ifTrue: [ ^ self processPhysicalPixelChunk ]. 249476 chunkType = 'tRNS' ifTrue: [ ^ self processTransparencyChunk ]. 249477 chunkType = 'IHDR' ifTrue: [ ^ self processIHDRChunk ]. 249478 chunkType = 'PLTE' ifTrue: [ ^ self processPLTEChunk ]. 249479 chunkType = 'IDAT' ifTrue: 249480 [ "---since the compressed data can span multiple 249481 chunks, stitch them all together first. later, 249482 if memory is an issue, we need to figure out how 249483 to do this on the fly---" 249484 globalDataChunk := globalDataChunk 249485 ifNil: [ chunk ] 249486 ifNotNil: [ globalDataChunk , chunk ]. 249487 ^ self ]. 249488 unknownChunks add: chunkType! ! 249489 249490!PNGReadWriter methodsFor: 'chunks' stamp: 'lr 7/4/2009 10:42'! 249491processNonInterlaced 249492 | z filter temp copyMethod debug | 249493 debug := self debugging. 249494 copyMethod := #( 249495 #copyPixelsGray: 249496 nil 249497 #copyPixelsRGB: 249498 #copyPixelsIndexed: 249499 #copyPixelsGrayAlpha: 249500 nil 249501 #copyPixelsRGBA: 249502 ) at: colorType + 1. 249503 debug ifTrue: 249504 [ Transcript 249505 cr; 249506 nextPutAll: 'NI chunk size='; 249507 print: chunk size ]. 249508 z := ZLibReadStream 249509 on: chunk 249510 from: 1 249511 to: chunk size. 249512 prevScanline := ByteArray new: bytesPerScanline. 249513 thisScanline := ByteArray new: bytesPerScanline. 249514 0 249515 to: height - 1 249516 do: 249517 [ :y | 249518 filter := (z next: 1) first. 249519 debug ifTrue: [ filtersSeen add: filter ]. 249520 thisScanline := z 249521 next: bytesPerScanline 249522 into: thisScanline 249523 startingAt: 1. 249524 (debug and: [ thisScanline size < bytesPerScanline ]) ifTrue: 249525 [ Transcript 249526 nextPutAll: ('wanted {1} but only got {2}' format: { bytesPerScanline. (thisScanline size) }); 249527 cr ]. 249528 filter = 0 ifFalse: 249529 [ self 249530 filterScanline: filter 249531 count: bytesPerScanline ]. 249532 self 249533 perform: copyMethod 249534 with: y. 249535 temp := prevScanline. 249536 prevScanline := thisScanline. 249537 thisScanline := temp ]. 249538 z atEnd ifFalse: [ self error: 'Unexpected data' ]. 249539 debug ifTrue: 249540 [ Transcript 249541 nextPutAll: ' compressed size='; 249542 print: z position ]! ! 249543 249544!PNGReadWriter methodsFor: 'chunks' stamp: 'lr 7/4/2009 10:42'! 249545processPLTEChunk 249546 | colorCount i | 249547 colorCount := chunk size // 3. "TODO - validate colorCount against depth" 249548 palette := Array new: colorCount. 249549 0 249550 to: colorCount - 1 249551 do: 249552 [ :index | 249553 i := index * 3 + 1. 249554 palette 249555 at: index + 1 249556 put: (Color 249557 r: (chunk at: i) / 255.0 249558 g: (chunk at: i + 1) / 255.0 249559 b: (chunk at: i + 2) / 255.0) ]! ! 249560 249561!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/5/2000 11:24'! 249562processPhysicalPixelChunk 249563 249564 "Transcript show: ' PHYSICAL: ',chunk printString." 249565! ! 249566 249567!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 12/12/2003 18:33'! 249568processSBITChunk 249569 | rBits gBits bBits aBits | 249570 colorType = 6 ifFalse:[^self]. 249571 rBits := chunk at: 1. 249572 gBits := chunk at: 2. 249573 bBits := chunk at: 3. 249574 aBits := chunk at: 4. 249575 (rBits = 5 and:[gBits = 5 and:[bBits = 5 and:[aBits = 1]]]) ifTrue:[ 249576 depth := 16. 249577 ].! ! 249578 249579!PNGReadWriter methodsFor: 'chunks' stamp: 'lr 7/4/2009 10:42'! 249580processTransparencyChunk 249581 "Transcript show: ' TRANSPARENCY ',chunk printString." 249582 | red green blue | 249583 colorType = 0 ifTrue: 249584 [ transparentPixelValue := chunk 249585 unsignedShortAt: 1 249586 bigEndian: true. 249587 ^ self ]. 249588 colorType = 2 ifTrue: 249589 [ red := chunk at: 2. 249590 green := chunk at: 2. 249591 blue := chunk at: 2. 249592 transparentPixelValue := ((65280 + red << 8) + green << 8) + blue. 249593 ^ self ]. 249594 colorType = 3 ifTrue: 249595 [ chunk withIndexDo: 249596 [ :alpha :index | 249597 palette 249598 at: index 249599 put: ((palette at: index) alpha: alpha / 255) ]. 249600 ^ self ]! ! 249601 249602 249603!PNGReadWriter methodsFor: 'filtering' stamp: 'lr 7/4/2009 10:42'! 249604filterAverage: count 249605 "Use the average of the pixel to the left and the pixel above as a predictor" 249606 | delta | 249607 delta := bitsPerPixel // 8 max: 1. 249608 1 249609 to: delta 249610 do: 249611 [ :i | 249612 thisScanline 249613 at: i 249614 put: ((thisScanline at: i) + ((prevScanline at: i) // 2) bitAnd: 255) ]. 249615 delta + 1 249616 to: count 249617 do: 249618 [ :i | 249619 thisScanline 249620 at: i 249621 put: ((thisScanline at: i) + (((prevScanline at: i) + (thisScanline at: i - delta)) // 2) bitAnd: 255) ]! ! 249622 249623!PNGReadWriter methodsFor: 'filtering' stamp: 'lr 7/4/2009 10:42'! 249624filterHorizontal: count 249625 "Use the pixel to the left as a predictor" 249626 | delta | 249627 delta := bitsPerPixel // 8 max: 1. 249628 delta + 1 249629 to: count 249630 do: 249631 [ :i | 249632 thisScanline 249633 at: i 249634 put: ((thisScanline at: i) + (thisScanline at: i - delta) bitAnd: 255) ]! ! 249635 249636!PNGReadWriter methodsFor: 'filtering' stamp: 'DSM 3/25/2000 17:55'! 249637filterNone: count 249638! ! 249639 249640!PNGReadWriter methodsFor: 'filtering' stamp: 'lr 7/4/2009 10:42'! 249641filterPaeth: count 249642 "Select one of (the pixel to the left, the pixel above and the pixel to above left) to 249643 predict the value of this pixel" 249644 | delta | 249645 delta := bitsPerPixel // 8 max: 1. 249646 1 249647 to: delta 249648 do: 249649 [ :i | 249650 thisScanline 249651 at: i 249652 put: ((thisScanline at: i) + (prevScanline at: i) bitAnd: 255) ]. 249653 delta + 1 249654 to: count 249655 do: 249656 [ :i | 249657 thisScanline 249658 at: i 249659 put: ((thisScanline at: i) + (self 249660 paethPredictLeft: (thisScanline at: i - delta) 249661 above: (prevScanline at: i) 249662 aboveLeft: (prevScanline at: i - delta)) bitAnd: 255) ]! ! 249663 249664!PNGReadWriter methodsFor: 'filtering' stamp: 'eat 9/11/2000 20:08'! 249665filterScanline: filterType count: count 249666 249667 self 249668 perform: ( 249669 #(filterNone: filterHorizontal: filterVertical: filterAverage: filterPaeth:) 249670 at: filterType+1) 249671 with: count. 249672 249673! ! 249674 249675!PNGReadWriter methodsFor: 'filtering' stamp: 'DSM 3/25/2000 17:54'! 249676filterVertical: count 249677 "Use the pixel above as a predictor" 249678 249679 1 to: count do: [ :i | 249680 thisScanline at: i put: (((thisScanline at: i) + 249681(prevScanline at: i)) bitAnd: 255) ] 249682 249683! ! 249684 249685!PNGReadWriter methodsFor: 'filtering' stamp: 'lr 7/4/2009 10:42'! 249686paethPredictLeft: a above: b aboveLeft: c 249687 "Predicts the value of a pixel based on nearby pixels, based on 249688Paeth (GG II, 1991)" 249689 | pa pb pc | 249690 pa := b > c 249691 ifTrue: [ b - c ] 249692 ifFalse: [ c - b ]. 249693 pb := a > c 249694 ifTrue: [ a - c ] 249695 ifFalse: [ c - a ]. 249696 pc := a + b - c - c. 249697 pc < 0 ifTrue: [ pc := pc * -1 ]. 249698 (pa <= pb and: [ pa <= pc ]) ifTrue: [ ^ a ]. 249699 pb <= pc ifTrue: [ ^ b ]. 249700 ^ c! ! 249701 249702 249703!PNGReadWriter methodsFor: 'miscellaneous' stamp: 'DSM 4/27/2000 13:09'! 249704doPass: pass 249705 "Certain interlace passes are skipped with certain small image 249706dimensions" 249707 249708 pass = 1 ifTrue: [ ^ true ]. 249709 ((width = 1) and: [height = 1]) ifTrue: [ ^ false ]. 249710 pass = 2 ifTrue: [ ^ width >= 5 ]. 249711 pass = 3 ifTrue: [ ^ height >= 5 ]. 249712 pass = 4 ifTrue: [ ^ (width >=3 ) or: [height >= 5] ]. 249713 pass = 5 ifTrue: [ ^ height >=3 ]. 249714 pass = 6 ifTrue: [ ^ width >=2 ]. 249715 pass = 7 ifTrue: [ ^ height >=2 ]. 249716 249717! ! 249718 249719!PNGReadWriter methodsFor: 'miscellaneous' stamp: 'lr 7/4/2009 10:42'! 249720grayColorsFor: d 249721 "return a color table for a gray image" 249722 palette := Array new: 1 << d. 249723 d = 1 ifTrue: 249724 [ palette 249725 at: 1 249726 put: Color black. 249727 palette 249728 at: 2 249729 put: Color white. 249730 ^ palette , { (Color transparent) } ]. 249731 d = 2 ifTrue: 249732 [ palette 249733 at: 1 249734 put: Color black. 249735 palette 249736 at: 2 249737 put: (Color gray: 85.0 / 255.0). 249738 palette 249739 at: 3 249740 put: (Color gray: 170.0 / 255.0). 249741 palette 249742 at: 4 249743 put: Color white. 249744 ^ palette , { (Color transparent) } ]. 249745 d = 4 ifTrue: 249746 [ 0 249747 to: 15 249748 do: 249749 [ :g | 249750 palette 249751 at: g + 1 249752 put: (Color gray: (g / 15) asFloat) ]. 249753 ^ palette , { (Color transparent) } ]. 249754 d = 8 ifTrue: 249755 [ 0 249756 to: 255 249757 do: 249758 [ :g | 249759 palette 249760 at: g + 1 249761 put: (Color gray: (g / 255) asFloat) ]. 249762 ^ palette "??transparent??" ]! ! 249763 249764 249765!PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! 249766copyPixels: y 249767 "Handle non-interlaced pixels of supported colorTypes" 249768 | s | 249769 s := #( 249770 #copyPixelsGray: 249771 nil 249772 #copyPixelsRGB: 249773 #copyPixelsIndexed: 249774 #copyPixelsGrayAlpha: 249775 nil 249776 #copyPixelsRGBA: 249777 ) at: colorType + 1. 249778 self 249779 perform: s asSymbol 249780 with: y! ! 249781 249782!PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! 249783copyPixels: y at: startX by: incX 249784 "Handle interlaced pixels of supported colorTypes" 249785 | s | 249786 s := #( 249787 #copyPixelsGray:at:by: 249788 nil 249789 #copyPixelsRGB:at:by: 249790 #copyPixelsIndexed:at:by: 249791 #copyPixelsGrayAlpha:at:by: 249792 nil 249793 #copyPixelsRGBA:at:by: 249794 ) at: colorType + 1. 249795 self 249796 perform: s asSymbol 249797 with: y 249798 with: startX 249799 with: incX! ! 249800 249801!PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! 249802copyPixelsGray: y 249803 "Handle non-interlaced grayscale color mode (colorType = 0)" 249804 | blitter pixPerByte mask shifts pixelNumber rawByte pixel transparentIndex | 249805 blitter := BitBlt current bitPokerToForm: form. 249806 transparentIndex := form colors size. 249807 bitsPerChannel = 16 249808 ifTrue: 249809 [ 0 249810 to: width - 1 249811 do: 249812 [ :x | 249813 blitter 249814 pixelAt: x @ y 249815 put: 255 - (thisScanline at: (x << 1) + 1) ]. 249816 ^ self ] 249817 ifFalse: 249818 [ bitsPerChannel = 8 ifTrue: 249819 [ 1 249820 to: width 249821 do: 249822 [ :x | 249823 blitter 249824 pixelAt: (x - 1) @ y 249825 put: (thisScanline at: x) ]. 249826 ^ self ]. 249827 bitsPerChannel = 1 ifTrue: 249828 [ pixPerByte := 8. 249829 mask := 1. 249830 shifts := #(7 6 5 4 3 2 1 0 ) ]. 249831 bitsPerChannel = 2 ifTrue: 249832 [ pixPerByte := 4. 249833 mask := 3. 249834 shifts := #(6 4 2 0 ) ]. 249835 bitsPerChannel = 4 ifTrue: 249836 [ pixPerByte := 2. 249837 mask := 15. 249838 shifts := #(4 0 ) ]. 249839 pixelNumber := 0. 249840 0 249841 to: width - 1 249842 do: 249843 [ :x | 249844 rawByte := thisScanline at: pixelNumber // pixPerByte + 1. 249845 pixel := rawByte >> (shifts at: pixelNumber \\ pixPerByte + 1) bitAnd: mask. 249846 pixel = transparentPixelValue ifTrue: [ pixel := transparentIndex ]. 249847 blitter 249848 pixelAt: x @ y 249849 put: pixel. 249850 pixelNumber := pixelNumber + 1 ] ]! ! 249851 249852!PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! 249853copyPixelsGray: y at: startX by: incX 249854 "Handle interlaced grayscale color mode (colorType = 0)" 249855 | b offset bits w pixel mask blitter pixelNumber pixPerByte rawByte shifts | 249856 bitsPerChannel = 16 ifTrue: 249857 [ b := BitBlt current bitPokerToForm: form. 249858 startX 249859 to: width - 1 249860 by: incX 249861 do: 249862 [ :x | 249863 b 249864 pixelAt: x @ y 249865 put: 255 - (thisScanline at: (x // incX << 1) + 1) ]. 249866 ^ self ]. 249867 offset := y * rowSize + 1. 249868 bits := form bits. 249869 bitsPerChannel = 8 ifTrue: 249870 [ startX 249871 to: width - 1 249872 by: incX 249873 do: 249874 [ :x | 249875 w := offset + (x >> 2). 249876 b := (3 - (x \\ 4)) * 8. 249877 pixel := (thisScanline at: x // incX + 1) << b. 249878 mask := (255 << b) bitInvert32. 249879 bits 249880 at: w 249881 put: (((bits at: w) bitAnd: mask) bitOr: pixel) ]. 249882 ^ self ]. 249883 bitsPerChannel = 1 ifTrue: 249884 [ pixPerByte := 8. 249885 mask := 1. 249886 shifts := #(7 6 5 4 3 2 1 0 ) ]. 249887 bitsPerChannel = 2 ifTrue: 249888 [ pixPerByte := 4. 249889 mask := 3. 249890 shifts := #(6 4 2 0 ) ]. 249891 bitsPerChannel = 4 ifTrue: 249892 [ pixPerByte := 2. 249893 mask := 15. 249894 shifts := #(4 0 ) ]. 249895 blitter := BitBlt current bitPokerToForm: form. 249896 pixelNumber := 0. 249897 startX 249898 to: width - 1 249899 by: incX 249900 do: 249901 [ :x | 249902 rawByte := thisScanline at: pixelNumber // pixPerByte + 1. 249903 pixel := rawByte >> (shifts at: pixelNumber \\ pixPerByte + 1) bitAnd: mask. 249904 blitter 249905 pixelAt: x @ y 249906 put: pixel. 249907 pixelNumber := pixelNumber + 1 ]! ! 249908 249909!PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! 249910copyPixelsGrayAlpha: y 249911 "Handle non-interlaced grayscale with alpha color mode (colorType = 4)" 249912 | i pixel gray b | 249913 b := BitBlt current bitPokerToForm: form. 249914 bitsPerChannel = 8 249915 ifTrue: 249916 [ 0 249917 to: width - 1 249918 do: 249919 [ :x | 249920 i := (x << 1) + 1. 249921 gray := thisScanline at: i. 249922 pixel := ((thisScanline at: i + 1) << 24) + (gray << 16) + (gray << 8) + gray. 249923 b 249924 pixelAt: x @ y 249925 put: pixel ] ] 249926 ifFalse: 249927 [ 0 249928 to: width - 1 249929 do: 249930 [ :x | 249931 i := (x << 2) + 1. 249932 gray := thisScanline at: i. 249933 pixel := ((thisScanline at: i + 2) << 24) + (gray << 16) + (gray << 8) + gray. 249934 b 249935 pixelAt: x @ y 249936 put: pixel ] ]! ! 249937 249938!PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! 249939copyPixelsGrayAlpha: y at: startX by: incX 249940 "Handle interlaced grayscale with alpha color mode (colorType = 4)" 249941 | i pixel gray b | 249942 b := BitBlt current bitPokerToForm: form. 249943 bitsPerChannel = 8 249944 ifTrue: 249945 [ startX 249946 to: width - 1 249947 by: incX 249948 do: 249949 [ :x | 249950 i := (x // incX << 1) + 1. 249951 gray := thisScanline at: i. 249952 pixel := ((thisScanline at: i + 1) << 24) + (gray << 16) + (gray << 8) + gray. 249953 b 249954 pixelAt: x @ y 249955 put: pixel ] ] 249956 ifFalse: 249957 [ startX 249958 to: width - 1 249959 by: incX 249960 do: 249961 [ :x | 249962 i := (x // incX << 2) + 1. 249963 gray := thisScanline at: i. 249964 pixel := ((thisScanline at: i + 2) << 24) + (gray << 16) + (gray << 8) + gray. 249965 b 249966 pixelAt: x @ y 249967 put: pixel ] ]! ! 249968 249969!PNGReadWriter methodsFor: 'pixel copies' stamp: 'ar 1/1/1970 21:00'! 249970copyPixelsIndexed: y 249971 "Handle non-interlaced indexed color mode (colorType = 3)" 249972 | hack hackBlt swizzleHack swizzleBlt scanline hackDepth | 249973 scanline := ByteArray new: bytesPerScanline + 3 // 4 * 4. 249974 scanline replaceFrom: 1 to: thisScanline size with: thisScanline startingAt: 1. 249975 hackDepth := bigEndian ifTrue:[form depth] ifFalse:[form depth negated]. 249976 hack := Form extent: width@1 depth: hackDepth bits: scanline. 249977 hackBlt := BitBlt toForm: form. 249978 hackBlt sourceForm: hack. 249979 hackBlt combinationRule: Form over. 249980 hackBlt destOrigin: 0@y. 249981 hackBlt width: width; height: 1. 249982 249983 (form depth < 8 and:[bigEndian not]) ifTrue:[ 249984 swizzleHack := Form new hackBits: scanline. 249985 swizzleBlt := BitBlt toForm: swizzleHack. 249986 swizzleBlt sourceForm: swizzleHack. 249987 swizzleBlt combinationRule: Form over. 249988 swizzleBlt colorMap: (StandardSwizzleMaps at: form depth). 249989 swizzleBlt copyBits. 249990 ]. 249991 249992 hackBlt copyBits.! ! 249993 249994!PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! 249995copyPixelsIndexed: y at: startX by: incX 249996 "Handle interlaced indexed color mode (colorType = 3)" 249997 | offset b bits w pixel mask pixPerByte shifts blitter pixelNumber rawByte | 249998 offset := y * rowSize + 1. 249999 bits := form bits. 250000 bitsPerChannel = 8 ifTrue: 250001 [ startX 250002 to: width - 1 250003 by: incX 250004 do: 250005 [ :x | 250006 w := offset + (x >> 2). 250007 b := (3 - (x \\ 4)) * 8. 250008 pixel := (thisScanline at: x // incX + 1) << b. 250009 mask := (255 << b) bitInvert32. 250010 bits 250011 at: w 250012 put: (((bits at: w) bitAnd: mask) bitOr: pixel) ]. 250013 ^ self ]. 250014 bitsPerChannel = 1 ifTrue: 250015 [ pixPerByte := 8. 250016 mask := 1. 250017 shifts := #(7 6 5 4 3 2 1 0 ) ]. 250018 bitsPerChannel = 2 ifTrue: 250019 [ pixPerByte := 4. 250020 mask := 3. 250021 shifts := #(6 4 2 0 ) ]. 250022 bitsPerChannel = 4 ifTrue: 250023 [ pixPerByte := 2. 250024 mask := 15. 250025 shifts := #(4 0 ) ]. 250026 blitter := BitBlt current bitPokerToForm: form. 250027 pixelNumber := 0. 250028 startX 250029 to: width - 1 250030 by: incX 250031 do: 250032 [ :x | 250033 rawByte := thisScanline at: pixelNumber // pixPerByte + 1. 250034 pixel := rawByte >> (shifts at: pixelNumber \\ pixPerByte + 1) bitAnd: mask. 250035 blitter 250036 pixelAt: x @ y 250037 put: pixel. 250038 pixelNumber := pixelNumber + 1 ]! ! 250039 250040!PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! 250041copyPixelsRGB: y 250042 "Handle non-interlaced RGB color mode (colorType = 2)" 250043 | i pixel tempForm tempBits | 250044 tempForm := Form 250045 extent: width @ 1 250046 depth: 32. 250047 tempBits := tempForm bits. 250048 pixel := LargePositiveInteger new: 4. 250049 pixel 250050 at: 4 250051 put: 255. 250052 bitsPerChannel = 8 250053 ifTrue: 250054 [ i := 1. 250055 1 250056 to: width 250057 do: 250058 [ :x | 250059 pixel 250060 at: 3 250061 put: (thisScanline at: i); 250062 at: 2 250063 put: (thisScanline at: i + 1); 250064 at: 1 250065 put: (thisScanline at: i + 2). 250066 tempBits 250067 at: x 250068 put: pixel. 250069 i := i + 3 ] ] 250070 ifFalse: 250071 [ i := 1. 250072 1 250073 to: width 250074 do: 250075 [ :x | 250076 pixel 250077 at: 3 250078 put: (thisScanline at: i); 250079 at: 2 250080 put: (thisScanline at: i + 2); 250081 at: 1 250082 put: (thisScanline at: i + 4). 250083 tempBits 250084 at: x 250085 put: pixel. 250086 i := i + 6 ] ]. 250087 transparentPixelValue ifNotNil: 250088 [ 1 250089 to: width 250090 do: 250091 [ :x | 250092 (tempBits at: x) = transparentPixelValue ifTrue: 250093 [ tempBits 250094 at: x 250095 put: 0 ] ] ]. 250096 tempForm 250097 displayOn: form 250098 at: 0 @ y 250099 rule: Form paint! ! 250100 250101!PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! 250102copyPixelsRGB: y at: startX by: incX 250103 "Handle interlaced RGB color mode (colorType = 2)" 250104 | i pixel tempForm tempBits xx loopsToDo | 250105 tempForm := Form 250106 extent: width @ 1 250107 depth: 32. 250108 tempBits := tempForm bits. 250109 pixel := LargePositiveInteger new: 4. 250110 pixel 250111 at: 4 250112 put: 255. 250113 loopsToDo := (width - startX + incX - 1) // incX. 250114 bitsPerChannel = 8 250115 ifTrue: 250116 [ i := startX // incX * 3 + 1. 250117 xx := startX + 1. 250118 1 250119 to: loopsToDo 250120 do: 250121 [ :j | 250122 pixel 250123 at: 3 250124 put: (thisScanline at: i); 250125 at: 2 250126 put: (thisScanline at: i + 1); 250127 at: 1 250128 put: (thisScanline at: i + 2). 250129 tempBits 250130 at: xx 250131 put: pixel. 250132 i := i + 3. 250133 xx := xx + incX ] ] 250134 ifFalse: 250135 [ i := startX // incX * 6 + 1. 250136 xx := startX + 1. 250137 1 250138 to: loopsToDo 250139 do: 250140 [ :j | 250141 pixel 250142 at: 3 250143 put: (thisScanline at: i); 250144 at: 2 250145 put: (thisScanline at: i + 2); 250146 at: 1 250147 put: (thisScanline at: i + 4). 250148 tempBits 250149 at: xx 250150 put: pixel. 250151 i := i + 6. 250152 xx := xx + incX ] ]. 250153 transparentPixelValue ifNotNil: 250154 [ startX 250155 to: width - 1 250156 by: incX 250157 do: 250158 [ :x | 250159 (tempBits at: x + 1) = transparentPixelValue ifTrue: 250160 [ tempBits 250161 at: x + 1 250162 put: 0 ] ] ]. 250163 tempForm 250164 displayOn: form 250165 at: 0 @ y 250166 rule: Form paint! ! 250167 250168!PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! 250169copyPixelsRGBA: y 250170 "Handle non-interlaced RGBA color modes (colorType = 6)" 250171 | i pixel tempForm tempBits ff | 250172 bitsPerChannel = 8 ifTrue: 250173 [ ff := Form 250174 extent: width @ 1 250175 depth: 32 250176 bits: thisScanline. 250177 cachedDecoderMap ifNil: [ cachedDecoderMap := self rgbaDecoderMapForDepth: depth ]. 250178 (BitBlt toForm: form) 250179 sourceForm: ff; 250180 destOrigin: 0 @ y; 250181 combinationRule: Form over; 250182 colorMap: cachedDecoderMap; 250183 copyBits. 250184 ^ self ]. 250185 tempForm := Form 250186 extent: width @ 1 250187 depth: 32. 250188 tempBits := tempForm bits. 250189 pixel := LargePositiveInteger new: 4. 250190 i := -7. 250191 0 250192 to: width - 1 250193 do: 250194 [ :x | 250195 i := i + 8. 250196 pixel 250197 at: 4 250198 put: (thisScanline at: i + 6); 250199 at: 3 250200 put: (thisScanline at: i); 250201 at: 2 250202 put: (thisScanline at: i + 2); 250203 at: 1 250204 put: (thisScanline at: i + 4). 250205 tempBits 250206 at: x + 1 250207 put: pixel ]. 250208 tempForm 250209 displayOn: form 250210 at: 0 @ y 250211 rule: Form over! ! 250212 250213!PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! 250214copyPixelsRGBA: y at: startX by: incX 250215 "Handle interlaced RGBA color modes (colorType = 6)" 250216 | i pixel tempForm tempBits | 250217 tempForm := Form 250218 extent: width @ 1 250219 depth: 32. 250220 tempBits := tempForm bits. 250221 pixel := LargePositiveInteger new: 4. 250222 bitsPerChannel = 8 250223 ifTrue: 250224 [ i := (startX // incX << 2) + 1. 250225 startX 250226 to: width - 1 250227 by: incX 250228 do: 250229 [ :x | 250230 pixel 250231 at: 4 250232 put: (thisScanline at: i + 3); 250233 at: 3 250234 put: (thisScanline at: i); 250235 at: 2 250236 put: (thisScanline at: i + 1); 250237 at: 1 250238 put: (thisScanline at: i + 2). 250239 tempBits 250240 at: x + 1 250241 put: pixel. 250242 i := i + 4 ] ] 250243 ifFalse: 250244 [ i := (startX // incX << 3) + 1. 250245 startX 250246 to: width - 1 250247 by: incX 250248 do: 250249 [ :x | 250250 pixel 250251 at: 4 250252 put: (thisScanline at: i + 6); 250253 at: 3 250254 put: (thisScanline at: i); 250255 at: 2 250256 put: (thisScanline at: i + 2); 250257 at: 1 250258 put: (thisScanline at: i + 4). 250259 tempBits 250260 at: x + 1 250261 put: pixel. 250262 i := i + 8 ] ]. 250263 tempForm 250264 displayOn: form 250265 at: 0 @ y 250266 rule: Form paintAlpha! ! 250267 250268!PNGReadWriter methodsFor: 'pixel copies' stamp: 'ar 2/19/2004 00:10'! 250269rgbaDecoderMapForDepth: decoderDepth 250270 bigEndian ifTrue:[ 250271 depth = 16 ifTrue:[ 250272 "Big endian, 32 -> 16 color mapping." 250273 ^ColorMap 250274 shifts: #(-17 -14 -11 0) 250275 masks: #(16rF8000000 16rF80000 16rF800 16r00) 250276 ] ifFalse:[ 250277 "Big endian, 32 -> 32 color mapping" 250278 ^ColorMap 250279 shifts: #(-8 -8 -8 24) 250280 masks: #(16rFF000000 16rFF0000 16rFF00 16rFF). 250281 ]. 250282 ]. 250283 depth = 16 ifTrue:[ 250284 "Little endian, 32 -> 16 color mapping." 250285 ^ColorMap 250286 shifts: #(7 -6 -19 0) 250287 masks: #(16rF8 16rF800 16rF80000 0) 250288 ] ifFalse:[ 250289 "Little endian, 32 -> 32 color mapping" 250290 ^ColorMap 250291 shifts: #(-16 0 16 0) 250292 masks: #(16rFF0000 16rFF00 16rFF 16rFF000000). 250293 ].! ! 250294 250295 250296!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 16:37'! 250297nextPutImage: aForm 250298 "Write out the given form. We're keeping it simple here, no interlacing, no filters." 250299 ^self nextPutImage: aForm interlace: 0 filter: 0. "no filtering"! ! 250300 250301!PNGReadWriter methodsFor: 'writing' stamp: 'PeterHugossonMiller 9/3/2009 10:11'! 250302nextPutImage: aForm interlace: aMethod filter: aFilterType 250303 "Note: For now we keep it simple - interlace and filtering are simply ignored" 250304 250305 | crcStream | 250306 bigEndian := SmalltalkImage current isBigEndian. 250307 form := aForm. 250308 width := aForm width. 250309 height := aForm height. 250310 aForm depth <= 8 250311 ifTrue: 250312 [bitsPerChannel := aForm depth. 250313 colorType := 3. 250314 bytesPerScanline := (width * aForm depth + 7) // 8] 250315 ifFalse: 250316 [bitsPerChannel := 8. 250317 colorType := 6. 250318 bytesPerScanline := width * 4]. 250319 self writeFileSignature. 250320 crcStream := (ByteArray new: 1000) writeStream. 250321 crcStream resetToStart. 250322 self writeIHDRChunkOn: crcStream. 250323 self writeChunk: crcStream. 250324 form depth <= 8 250325 ifTrue: 250326 [crcStream resetToStart. 250327 self writePLTEChunkOn: crcStream. 250328 self writeChunk: crcStream. 250329 form isColorForm 250330 ifTrue: 250331 [crcStream resetToStart. 250332 self writeTRNSChunkOn: crcStream. 250333 self writeChunk: crcStream]]. 250334 form depth = 16 250335 ifTrue: 250336 [crcStream resetToStart. 250337 self writeSBITChunkOn: crcStream. 250338 self writeChunk: crcStream]. 250339 crcStream resetToStart. 250340 self writeIDATChunkOn: crcStream. 250341 self writeChunk: crcStream. 250342 crcStream resetToStart. 250343 self writeIENDChunkOn: crcStream. 250344 self writeChunk: crcStream! ! 250345 250346!PNGReadWriter methodsFor: 'writing' stamp: 'nk 2/17/2004 16:51'! 250347updateCrc: oldCrc from: start to: stop in: aCollection 250348 ^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection! ! 250349 250350!PNGReadWriter methodsFor: 'writing' stamp: 'lr 7/4/2009 10:42'! 250351writeChunk: crcStream 250352 | bytes length crc debug | 250353 debug := self debugging. 250354 bytes := crcStream originalContents. 250355 length := crcStream position. 250356 crc := self 250357 updateCrc: 4294967295 250358 from: 1 250359 to: length 250360 in: bytes. 250361 crc := crc bitXor: 4294967295. 250362 debug ifTrue: 250363 [ Transcript 250364 cr; 250365 print: stream position; 250366 space; 250367 nextPutAll: (bytes 250368 copyFrom: 1 250369 to: 4) asString; 250370 nextPutAll: ' len='; 250371 print: length; 250372 nextPutAll: ' crc=0x'; 250373 nextPutAll: crc printStringHex ]. 250374 stream 250375 nextNumber: 4 250376 put: length - 4. "exclude chunk name" 250377 stream 250378 next: length 250379 putAll: bytes 250380 startingAt: 1. 250381 stream 250382 nextNumber: 4 250383 put: crc. 250384 debug ifTrue: 250385 [ Transcript 250386 nextPutAll: ' afterPos='; 250387 print: stream position ]. 250388 crcStream resetToStart! ! 250389 250390!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 16:40'! 250391writeFileSignature 250392 stream nextPutAll: #(16r89 16r50 16r4E 16r47 16r0D 16r0A 16r1A 16r0A) asByteArray! ! 250393 250394!PNGReadWriter methodsFor: 'writing' stamp: 'lr 7/4/2009 10:42'! 250395writeIDATChunkOn: aStream 250396 "Write the IDAT chunk" 250397 | z | 250398 aStream nextPutAll: 'IDAT' asByteArray. 250399 z := ZLibWriteStream on: aStream. 250400 form depth <= 8 250401 ifTrue: [ self writeType3DataOn: z ] 250402 ifFalse: [ self writeType6DataOn: z ]. 250403 self debugging ifTrue: 250404 [ Transcript 250405 cr; 250406 nextPutAll: 'compressed size='; 250407 print: aStream position; 250408 nextPutAll: ' uncompressed size='; 250409 print: z position ]! ! 250410 250411!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:08'! 250412writeIENDChunkOn: aStream 250413 "Write the IEND chunk" 250414 aStream nextPutAll: 'IEND' asByteArray.! ! 250415 250416!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:21'! 250417writeIHDRChunkOn: aStream 250418 "Write the IHDR chunk" 250419 aStream nextPutAll: 'IHDR' asByteArray. 250420 aStream nextInt32Put: width. 250421 aStream nextInt32Put: height. 250422 aStream nextNumber: 1 put: bitsPerChannel. 250423 aStream nextNumber: 1 put: colorType. 250424 aStream nextNumber: 1 put: 0. "compression" 250425 aStream nextNumber: 1 put: 0. "filter method" 250426 aStream nextNumber: 1 put: 0. "interlace method" 250427! ! 250428 250429!PNGReadWriter methodsFor: 'writing' stamp: 'nk 4/17/2004 19:44'! 250430writePLTEChunkOn: aStream 250431 "Write the PLTE chunk" 250432 | r g b colors | 250433 aStream nextPutAll: 'PLTE' asByteArray. 250434 (form isColorForm) 250435 ifTrue:[colors := form colors] 250436 ifFalse:[colors := Color indexedColors copyFrom: 1 to: (1 bitShift: form depth)]. 250437 colors do:[:aColor| 250438 r := (aColor red * 255) truncated. 250439 g := (aColor green * 255) truncated. 250440 b := (aColor blue * 255) truncated. 250441 aStream nextPut: r; nextPut: g; nextPut: b. 250442 ].! ! 250443 250444!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 18:29'! 250445writeSBITChunkOn: aStream 250446 "Write the IDAT chunk" 250447 aStream nextPutAll: 'sBIT' asByteArray. 250448 form depth = 16 ifFalse:[self error: 'Unimplemented feature']. 250449 aStream nextPut: 5. 250450 aStream nextPut: 5. 250451 aStream nextPut: 5. 250452 aStream nextPut: 1.! ! 250453 250454!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:34'! 250455writeTRNSChunkOn: aStream 250456 "Write out tRNS chunk" 250457 aStream nextPutAll: 'tRNS' asByteArray. 250458 form colors do:[:aColor| 250459 aStream nextPut: (aColor alpha * 255) truncated. 250460 ].! ! 250461 250462!PNGReadWriter methodsFor: 'writing' stamp: 'ar 1/1/1970 20:58'! 250463writeType3DataOn: zStream 250464 "Write color indexed data." 250465 | scanline hack hackBlt swizzleBlt swizzleHack hackDepth | 250466 scanline := ByteArray new: bytesPerScanline + 3 // 4 * 4. 250467 hackDepth := bigEndian ifTrue:[form depth] ifFalse:[form depth negated]. 250468 hack := Form extent: width@1 depth: hackDepth bits: scanline. 250469 hackBlt := BitBlt toForm: hack. 250470 hackBlt sourceForm: form. 250471 hackBlt combinationRule: Form over. 250472 hackBlt destOrigin: 0@0. 250473 hackBlt width: width; height: 1. 250474 (form depth < 8 and:[bigEndian not]) ifTrue:[ 250475 swizzleHack := Form new hackBits: scanline. 250476 swizzleBlt := BitBlt toForm: swizzleHack. 250477 swizzleBlt sourceForm: swizzleHack. 250478 swizzleBlt combinationRule: Form over. 250479 swizzleBlt colorMap: (StandardSwizzleMaps at: form depth). 250480 ]. 250481 0 to: height-1 do:[:i| 250482 hackBlt sourceOrigin: 0@i; copyBits. 250483 swizzleBlt ifNotNil:[swizzleBlt copyBits]. 250484 zStream nextPut: 0. "filterType" 250485 zStream next: bytesPerScanline putAll: scanline startingAt: 1. 250486 ]. 250487 zStream close.! ! 250488 250489!PNGReadWriter methodsFor: 'writing' stamp: 'ar 2/19/2004 00:10'! 250490writeType6DataOn: zStream 250491 "Write RGBA data." 250492 | scanline hack hackBlt cm miscBlt | 250493 scanline := ByteArray new: bytesPerScanline. 250494 hack := Form extent: width@1 depth: 32 bits: scanline. 250495 form depth = 16 ifTrue:[ 250496 "Expand 16 -> 32" 250497 miscBlt := BitBlt toForm: hack. 250498 miscBlt sourceForm: form. 250499 miscBlt combinationRule: Form over. 250500 miscBlt destOrigin: 0@0. 250501 miscBlt width: width; height: 1. 250502 ]. 250503 hackBlt := BitBlt toForm: hack. 250504 hackBlt sourceForm: (miscBlt ifNil:[form] ifNotNil:[hack]). 250505 hackBlt combinationRule: Form over. 250506 hackBlt destOrigin: 0@0. 250507 hackBlt width: width; height: 1. 250508 bigEndian ifTrue:[ 250509 cm := ColorMap 250510 shifts: #(8 8 8 -24) 250511 masks: #(16rFF0000 16rFF00 16rFF 16rFF000000). 250512 ] ifFalse:[ 250513 cm := ColorMap 250514 shifts: #(-16 0 16 0) 250515 masks: #(16rFF0000 16rFF00 16rFF 16rFF000000). 250516 ]. 250517 hackBlt colorMap: cm. 250518 0 to: height-1 do:[:i| 250519 miscBlt ifNil:[ 250520 hackBlt sourceOrigin: 0@i; copyBits. 250521 ] ifNotNil:[ 250522 miscBlt sourceOrigin: 0@i; copyBits. 250523 hack fixAlpha. 250524 hackBlt copyBits. 250525 ]. 250526 zStream nextPut: 0. "filterType" 250527 zStream nextPutAll: scanline. 250528 ]. 250529 zStream close.! ! 250530 250531"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 250532 250533PNGReadWriter class 250534 instanceVariableNames: ''! 250535 250536!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'ar 2/11/2004 00:54'! 250537computeSwizzleMapForDepth: depth 250538 "Answer a map that maps pixels in a word to their opposite location. Used for 'middle-endian' forms where the byte-order is different from the bit order (good joke, eh?)." 250539 | map swizzled | 250540 map := Bitmap new: 256. 250541 depth = 4 ifTrue:[ 250542 0 to: 255 do:[:pix| 250543 swizzled := 0. 250544 swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 15) bitShift: 4). 250545 swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 15) bitShift: 0). 250546 map at: pix+1 put: swizzled. 250547 ]. 250548 ^ColorMap colors: map 250549 ]. 250550 250551 depth = 2 ifTrue:[ 250552 0 to: 255 do:[:pix| 250553 swizzled := 0. 250554 swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 3) bitShift: 6). 250555 swizzled := swizzled bitOr: (((pix bitShift: -2) bitAnd: 3) bitShift: 4). 250556 swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 3) bitShift: 2). 250557 swizzled := swizzled bitOr: (((pix bitShift: -6) bitAnd: 3) bitShift: 0). 250558 map at: pix+1 put: swizzled. 250559 ]. 250560 ^ColorMap colors: map 250561 ]. 250562 250563 depth = 1 ifTrue:[ 250564 0 to: 255 do:[:pix| 250565 swizzled := 0. 250566 swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 1) bitShift: 7). 250567 swizzled := swizzled bitOr: (((pix bitShift: -1) bitAnd: 1) bitShift: 6). 250568 swizzled := swizzled bitOr: (((pix bitShift: -2) bitAnd: 1) bitShift: 5). 250569 swizzled := swizzled bitOr: (((pix bitShift: -3) bitAnd: 1) bitShift: 4). 250570 swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 1) bitShift: 3). 250571 swizzled := swizzled bitOr: (((pix bitShift: -5) bitAnd: 1) bitShift: 2). 250572 swizzled := swizzled bitOr: (((pix bitShift: -6) bitAnd: 1) bitShift: 1). 250573 swizzled := swizzled bitOr: (((pix bitShift: -7) bitAnd: 1) bitShift: 0). 250574 map at: pix+1 put: swizzled. 250575 ]. 250576 ^ColorMap colors: map 250577 ]. 250578 self error: 'Unrecognized depth'! ! 250579 250580!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'lr 7/4/2009 10:42'! 250581createAFormFrom: data 250582 | error f | 250583 error := ''. 250584 f := [ self formFromStream: (RWBinaryOrTextStream with: data) ] ifError: 250585 [ :a :b | 250586 error := a printString , ' ' , b printString. 250587 (StringMorph contents: error) 250588 color: Color red; 250589 imageForm ]. 250590 ^ { f. error }! ! 250591 250592!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'lr 7/4/2009 10:42'! 250593debugging: aBoolean 250594 Debugging := aBoolean! ! 250595 250596!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'lr 7/4/2009 10:42'! 250597initialize 250598 " 250599 PNGReadWriter initialize 250600 " 250601 BPP := { 250602 #(1 2 4 8 16 ). 250603 #(0 0 0 0 0 ). 250604 #(0 0 0 24 48 ). 250605 #(1 2 4 8 0 ). 250606 #(0 0 0 16 32 ). 250607 #(0 0 0 0 0 ). 250608 #(0 0 0 32 64 ). 250609 #(0 0 0 0 0 ) 250610 }. 250611 BlockHeight := #(8 8 4 4 2 2 1 ). 250612 BlockWidth := #(8 4 4 2 2 1 1 ). 250613 StandardColors := Color indexedColors collect: 250614 [ :aColor | 250615 Color 250616 r: (aColor red * 255) truncated / 255 250617 g: (aColor green * 255) truncated / 255 250618 b: (aColor blue * 255) truncated / 255 ]. 250619 StandardSwizzleMaps := Array new: 4. 250620 #(1 2 4 ) do: 250621 [ :i | 250622 StandardSwizzleMaps 250623 at: i 250624 put: (self computeSwizzleMapForDepth: i) ]! ! 250625 250626 250627!PNGReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:57'! 250628typicalFileExtensions 250629 "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" 250630 ^#('png')! ! 250631TestCase subclass: #PNGReadWriterTest 250632 instanceVariableNames: 'fileName' 250633 classVariableNames: '' 250634 poolDictionaries: '' 250635 category: 'GraphicsTests-Files'! 250636 250637!PNGReadWriterTest methodsFor: 'helpers' stamp: 'on 6/10/2008 16:36'! 250638deleteFile 250639 FileDirectory default deleteFileNamed: fileName! ! 250640 250641!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/11/2004 00:42'! 250642drawStuffOn: aForm 250643 "Draw stuff on aForm. Avoid any symmetry." 250644 | canvas | 250645 canvas := FormCanvas on: aForm. 250646 canvas frameAndFillRectangle: (1@1 corner: aForm extent - 15) fillColor: Color red borderWidth: 3 borderColor: Color green. 250647 canvas fillOval: (aForm boundingBox topRight - (15@-5) extent: 20@20) color: Color blue borderWidth: 1 borderColor: Color white. 250648 ^aForm 250649 "(PNGReadWriterTest new drawStuffOn: (Form extent: 32@32 depth: 16)) display"! ! 250650 250651!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/11/2004 00:42'! 250652drawTransparentStuffOn: aForm 250653 "Draw stuff on aForm. Avoid any symmetry." 250654 | canvas | 250655 canvas := FormCanvas on: aForm. 250656 canvas frameAndFillRectangle: (1@1 corner: aForm extent - 15) fillColor: (Color red alpha: 0.25) borderWidth: 3 borderColor: (Color green alpha: 0.5). 250657 canvas fillOval: (aForm boundingBox topRight - (15@-5) extent: 20@20) color: (Color white alpha: 0.75) borderWidth: 1 borderColor: Color blue. 250658 ^aForm 250659 "(PNGReadWriterTest new drawStuffOn: (Form extent: 32@32 depth: 16)) display"! ! 250660 250661!PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 4/17/2004 19:45'! 250662encodeAndDecode: original 250663 "Make sure that the given form is encoded and decoded correctly" 250664 | stream bytes decoded maxErr | 250665 "encode" 250666 stream := ByteArray new writeStream. 250667 (PNGReadWriter on: stream) nextPutImage: original; close. 250668 bytes := stream contents. 250669 250670 self writeEncoded: bytes. 250671 250672 "decode" 250673 stream := self readEncoded: bytes. 250674 decoded := (PNGReadWriter new on: stream) nextImage. 250675 decoded display. 250676 250677 "compare" 250678 self assert: original width = decoded width. 250679 self assert: original height = decoded height. 250680 self assert: original depth = decoded depth. 250681 self assert: original bits = decoded bits. 250682 self assert: original class == decoded class. 250683 (original isColorForm) ifTrue:[ 250684 original colors with: decoded colors do:[:c1 :c2| 250685 "we must round here due to encoding errors" 250686 maxErr := 1. "max. error for 8bit rgb component" 250687 self assert: ((c1 red * 255) truncated - (c2 red * 255) truncated) abs <= maxErr. 250688 self assert: ((c1 green * 255) truncated - (c2 green * 255) truncated) abs <= maxErr. 250689 self assert: ((c1 blue * 255) truncated - (c2 blue * 255) truncated) abs <= maxErr. 250690 self assert: ((c1 alpha * 255) truncated - (c2 alpha * 255) truncated) abs <= maxErr. 250691 ]. 250692 ].! ! 250693 250694!PNGReadWriterTest methodsFor: 'helpers' stamp: 'on 6/10/2008 16:36'! 250695encodeAndDecodeAlpha: original 250696 fileName := 'testAlpha', original depth printString,'.png'. 250697 self encodeAndDecode: original. 250698 self deleteFile.! ! 250699 250700!PNGReadWriterTest methodsFor: 'helpers' stamp: 'on 6/10/2008 16:36'! 250701encodeAndDecodeColor: aColor depth: aDepth 250702 | aForm | 250703 fileName := 'testColor', aColor name, aDepth printString,'.png'. 250704 aForm := Form extent: 32@32 depth: aDepth. 250705 aForm fillColor: aColor. 250706 self encodeAndDecode: aForm. 250707 self deleteFile. 250708! ! 250709 250710!PNGReadWriterTest methodsFor: 'helpers' stamp: 'stephane.ducasse 6/14/2008 15:26'! 250711encodeAndDecodeDisplay: depth 250712 | form | 250713 fileName := 'testDisplay', depth printString,'.png'. 250714 form := Form extent: (Display extent min: 560@560) depth: depth. 250715 World fullDrawOn: form getCanvas. 250716 self encodeAndDecode: form. 250717 self deleteFile.! ! 250718 250719!PNGReadWriterTest methodsFor: 'helpers' stamp: 'on 6/10/2008 16:36'! 250720encodeAndDecodeForm: original 250721 fileName := 'testForm', original depth printString,'.png'. 250722 self encodeAndDecode: original. 250723 self deleteFile.! ! 250724 250725!PNGReadWriterTest methodsFor: 'helpers' stamp: 'on 6/10/2008 16:36'! 250726encodeAndDecodeReverse: original 250727 "Make sure that the given form is encoded and decoded correctly" 250728 | stream bytes decoded maxErr reversed | 250729 fileName := 'testReverse', original depth printString,'.png'. 250730 self assert: original class == Form. "won't work with ColorForm" 250731 "Switch pixel order" 250732 reversed := Form extent: original extent depth: original depth negated. 250733 original displayOn: reversed. 250734 self assert: original width = reversed width. 250735 self assert: original height = reversed height. 250736 self assert: original depth = reversed depth. 250737 self deny: original nativeDepth = reversed nativeDepth. 250738 original depth = 32 250739 ifTrue:[self assert: original bits = reversed bits] 250740 ifFalse:[self deny: original bits = reversed bits]. 250741 250742 "encode" 250743 stream := ByteArray new writeStream. 250744 (PNGReadWriter on: stream) nextPutImage: reversed; close. 250745 bytes := stream contents. 250746 self writeEncoded: bytes. 250747 250748 "decode" 250749 stream := bytes readStream. 250750 decoded := (PNGReadWriter new on: stream) nextImage. 250751 decoded display. 250752 250753 "compare" 250754 self assert: original width = decoded width. 250755 self assert: original height = decoded height. 250756 self assert: original depth = decoded depth. 250757 self assert: original bits = decoded bits. 250758 self assert: original class == decoded class. 250759 (original isColorForm) ifTrue:[ 250760 original colors with: decoded colors do:[:c1 :c2| 250761 "we must round here due to encoding errors" 250762 maxErr := 1. "max. error for 8bit rgb component" 250763 self assert: ((c1 red * 255) truncated - (c2 red * 255) truncated) abs <= maxErr. 250764 self assert: ((c1 green * 255) truncated - (c2 green * 255) truncated) abs <= maxErr. 250765 self assert: ((c1 blue * 255) truncated - (c2 blue * 255) truncated) abs <= maxErr. 250766 self assert: ((c1 alpha * 255) truncated - (c2 alpha * 255) truncated) abs <= maxErr. 250767 ]. 250768 ]. 250769 self deleteFile.! ! 250770 250771!PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 18:18'! 250772encodeAndDecodeStream: file 250773 | aForm | 250774 file reset. 250775 (PNGReadWriter new on: file) understandsImageFormat ifFalse:[^self error: 'don''t understand format!!' ]. 250776 file reset. 250777 aForm := (PNGReadWriter new on: file) nextImage. 250778 aForm ifNil:[^self error: 'nil form' ]. 250779 aForm display. 250780 self encodeAndDecode: aForm. 250781! ! 250782 250783!PNGReadWriterTest methodsFor: 'helpers' stamp: 'PeterHugossonMiller 9/3/2009 10:12'! 250784encodeAndDecodeWithColors: aColorForm 250785 "Screw around with aColorForm colors" 250786 | colors nColors indexedColors max myRandom | 250787 fileName := 'testColors', aColorForm depth printString,'.png'. 250788 indexedColors := Color indexedColors. 250789 nColors := 1 bitShift: aColorForm depth. 250790 colors := Array new writeStream. 250791 250792 "Make first half translucent" 250793 max := nColors // 2. 250794 1 to: max do:[:i| 250795 colors nextPut: ((indexedColors at: i) alpha: i / max asFloat). 250796 ]. 250797 250798 "Make random choices for second half" 250799 myRandom := Random seed: 42315. 250800 max to: nColors do:[:i| 250801 colors nextPut: (indexedColors atRandom: myRandom). 250802 ]. 250803 self deleteFile. 250804! ! 250805 250806!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/29/2004 03:55'! 250807encodeAndDecodeWithError: aStream 250808 self should:[self encodeAndDecodeStream: aStream] raise: Error! ! 250809 250810!PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 11:10'! 250811readEncoded: bytes 250812 "Answer a ReadStream on the file named by fileName, if possible; else a ReadStream on bytes" 250813 250814 fileName ifNil:[^ bytes readStream ]. 250815 ^(FileStream oldFileOrNoneNamed: fileName) ifNil: [ 250816 Transcript nextPutAll: 'can''t open ', fileName; cr. 250817 bytes readStream ]. 250818! ! 250819 250820!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/12/2004 22:45'! 250821setUp 250822 fileName := nil.! ! 250823 250824!PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 11:29'! 250825tearDown 250826 World changed.! ! 250827 250828!PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/12/2004 22:51'! 250829writeEncoded: bytes 250830 | file | 250831 fileName ifNil:[^self]. 250832 false ifTrue:[^self]. 250833 file := FileStream forceNewFileNamed: fileName. 250834 [file nextPutAll: bytes] ensure:[file close].! ! 250835 250836 250837!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'! 250838test16Bit 250839 self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 16))! ! 250840 250841!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! 250842test16BitDisplay 250843 self encodeAndDecodeDisplay: 16! ! 250844 250845!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:57'! 250846test16BitReversed 250847 self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 16))! ! 250848 250849!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'! 250850test1Bit 250851 self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 1))! ! 250852 250853!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:43'! 250854test1BitColors 250855 self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 1))! ! 250856 250857!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! 250858test1BitDisplay 250859 self encodeAndDecodeDisplay: 1! ! 250860 250861!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:56'! 250862test1BitReversed 250863 self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 1))! ! 250864 250865!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'! 250866test2Bit 250867 self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 2))! ! 250868 250869!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:43'! 250870test2BitColors 250871 self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 2))! ! 250872 250873!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! 250874test2BitDisplay 250875 self encodeAndDecodeDisplay: 2! ! 250876 250877!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:56'! 250878test2BitReversed 250879 self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 2))! ! 250880 250881!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'! 250882test32Bit 250883 self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 32))! ! 250884 250885!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! 250886test32BitDisplay 250887 self encodeAndDecodeDisplay: 32! ! 250888 250889!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:57'! 250890test32BitReversed 250891 self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 32))! ! 250892 250893!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'! 250894test4Bit 250895 self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 4))! ! 250896 250897!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:44'! 250898test4BitColors 250899 self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 4))! ! 250900 250901!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! 250902test4BitDisplay 250903 self encodeAndDecodeDisplay: 4! ! 250904 250905!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:56'! 250906test4BitReversed 250907 self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 4))! ! 250908 250909!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'! 250910test8Bit 250911 self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 8))! ! 250912 250913!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:44'! 250914test8BitColors 250915 self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 8))! ! 250916 250917!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! 250918test8BitDisplay 250919 self encodeAndDecodeDisplay: 8! ! 250920 250921!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:57'! 250922test8BitReversed 250923 self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 8))! ! 250924 250925!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:49'! 250926testAlphaCoding 250927 self encodeAndDecodeAlpha: (self drawTransparentStuffOn: (Form extent: 33@33 depth: 32))! ! 250928 250929!PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/29/2004 03:55'! 250930testPngSuite 250931 "Requires the suite from 250932 ftp://swrinde.nde.swri.edu/pub/png/images/suite/PngSuite.zip 250933 to be present as PngSuite.zip" 250934 | file zip entries | 250935 [file := FileStream readOnlyFileNamed: 'PngSuite.zip'] on: Error do:[:ex| ex return]. 250936 file ifNil:[^self]. 250937 [zip := ZipArchive new readFrom: file. 250938 entries := zip members select:[:mbr| mbr fileName asLowercase endsWith: '.png']. 250939 entries do:[:mbr| 250940 (mbr fileName asLowercase first = $x) 250941 ifTrue: [self encodeAndDecodeWithError: mbr contentStream ] 250942 ifFalse: [self encodeAndDecodeStream: mbr contentStream ] ]. 250943 ] ensure:[file close].! ! 250944 250945 250946!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! 250947testBlack16 250948 self encodeAndDecodeColor: Color blue depth: 16! ! 250949 250950!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! 250951testBlack32 250952 self encodeAndDecodeColor: Color blue depth: 32! ! 250953 250954!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! 250955testBlack8 250956 self encodeAndDecodeColor: Color blue depth: 8! ! 250957 250958!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! 250959testBlue16 250960 self encodeAndDecodeColor: Color blue depth: 16! ! 250961 250962!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! 250963testBlue32 250964 self encodeAndDecodeColor: Color blue depth: 32! ! 250965 250966!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! 250967testBlue8 250968 self encodeAndDecodeColor: Color blue depth: 8! ! 250969 250970!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! 250971testGreen16 250972 self encodeAndDecodeColor: Color green depth: 16! ! 250973 250974!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! 250975testGreen32 250976 self encodeAndDecodeColor: Color green depth: 32! ! 250977 250978!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:49'! 250979testGreen8 250980 self encodeAndDecodeColor: Color green depth: 8! ! 250981 250982!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:49'! 250983testRed16 250984 self encodeAndDecodeColor: Color red depth: 16! ! 250985 250986!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:48'! 250987testRed32 250988 self encodeAndDecodeColor: Color red depth: 32! ! 250989 250990!PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:49'! 250991testRed8 250992 self encodeAndDecodeColor: Color red depth: 8! ! 250993 250994 250995!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:25'! 250996coloredFiles16 250997 "Created by 250998 {Color red. Color green. Color blue. Color black} collect:[:fillC| 250999 | ff bytes | 251000 ff := Form extent: 32@32 depth: 16. 251001 ff fillColor: fillC. 251002 bytes := WriteStream on: ByteArray new. 251003 PNGReadWriter putForm: ff onStream: bytes. 251004 fillC -> 251005 (Base64MimeConverter mimeEncode: (bytes contents readStream)) contents 251006 ]. 251007 " 251008 ^{Color red-> 251009'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADZJ 251010REFUeF7lziEBAAAMAjD6J8b9MRAT80uT65Af8AN+wA/4AT/gB/yAH/ADfsAP+AE/4AfmgQdc 251011z9xqBS2pdAAAAABJRU5ErkJggg=='. 251012 Color green-> 251013'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADVJ 251014REFUeF7lziEBAAAMAjD6J77jMRAT80sunfIDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA68HyT 2510153Gqf2I6NAAAAAElFTkSuQmCC'. 251016 Color blue-> 251017'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADVJ 251018REFUeF7lziEBAAAMAjD6J77jMRAT80ty3fIDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA48JxX 2510193GpYhihrAAAAAElFTkSuQmCC'. 251020 Color black-> 251021'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADVJ 251022REFUeF7lziEBAAAMAjDk+xfmMRAT80ty3fIDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA48LbT 251023HD3MKH3GAAAAAElFTkSuQmCC' 251024}! ! 251025 251026!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:24'! 251027coloredFiles32 251028 "Created by 251029 {Color red. Color green. Color blue. Color black} collect:[:fillC| 251030 | ff bytes | 251031 ff := Form extent: 32@32 depth: 32. 251032 ff fillColor: fillC. 251033 bytes := WriteStream on: ByteArray new. 251034 PNGReadWriter putForm: ff onStream: bytes. 251035 fillC -> 251036 (Base64MimeConverter mimeEncode: (bytes contents readStream)) contents 251037 ]. 251038 " 251039 ^{ 251040 Color red -> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAANUlEQVR4XuXOIQEAAAwEoe9f 251041+hZjAoFnbfVo+QE/4Af8gB/wA37AD/gBP+AH/IAf8AN+4DlwVA34ajP6EEoAAAAASUVORK5C 251042YII='. 251043 Color green -> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAAM0lEQVR4XuXOMQ0AAAACIPuX 2510441hgejAIkPfMDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA7MFfR+Grvv2BdAAAAAElFTkSuQmCC'. 251045 251046 Color blue-> 251047'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAANElEQVR4XuXOIQEAAAACIP+f 2510481hkGAp0k7Zcf8AN+wA/4AT/gB/yAH/ADfsAP+AE/4AfOgQFblfhqnnPWHAAAAABJRU5ErkJg 251049gg=='. 251050 Color black -> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAANUlEQVR4XuXOMQEAAAwCINc/ 251051tIvhwcFPkuuWH/ADfsAP+AE/4Af8gB/wA37AD/gBP+AHxoEH95UAPU59TTMAAAAASUVORK5C 251052YII=' 251053}! ! 251054 251055!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:19'! 251056coloredFiles8 251057 "Created by 251058 {Color red. Color green. Color blue. Color black} collect:[:fillC| 251059 | ff bytes | 251060 ff := Form extent: 32@32 depth: 8. 251061 ff fillColor: fillC. 251062 bytes := WriteStream on: ByteArray new. 251063 PNGReadWriter putForm: ff onStream: bytes. 251064 fillC -> 251065 (Base64MimeConverter mimeEncode: (bytes contents readStream)) contents 251066 ]. 251067 " 251068 ^{Color red-> 251069'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3// 251070AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH 251071R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA 251072AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA 251073AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y 251074AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy 251075AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l 251076AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl 251077AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y 251078AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY 251079AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L 251080AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL 251081AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L//// 251082AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/ 251083AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E 251084CiHUAAAAGklEQVR4XmO4cwc/YLgz8hWMfAUjX8EIVQAAbnlwLukXXkcAAAAASUVORK5CYII='. 251085 251086 Color green-> 251087'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3// 251088AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH 251089R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA 251090AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA 251091AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y 251092AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy 251093AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l 251094AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl 251095AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y 251096AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY 251097AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L 251098AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL 251099AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L//// 251100AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/ 251101AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E 251102CiHUAAAAGUlEQVR4XmPQ1cUPGHRHvoKRr2DkKxihCgBZ3bQBCq5u/AAAAABJRU5ErkJggg=='. 251103 251104 Color blue-> 251105'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3// 251106AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH 251107R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA 251108AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA 251109AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y 251110AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy 251111AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l 251112AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl 251113AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y 251114AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY 251115AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L 251116AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL 251117AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L//// 251118AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/ 251119AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E 251120CiHUAAAAGUlEQVR4XmNwc8MPGNxGvoKRr2DkKxihCgCl7xgQRbPxcwAAAABJRU5ErkJggg=='. 251121 251122 Color black-> 251123'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3// 251124AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH 251125R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA 251126AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA 251127AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y 251128AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy 251129AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l 251130AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl 251131AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y 251132AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY 251133AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L 251134AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL 251135AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L//// 251136AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/ 251137AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E 251138CiHUAAAAGUlEQVR4XmNgZMQPGBhHvoKRr2DkKxihCgBEmAQBphO0cAAAAABJRU5ErkJggg==' 251139}! ! 251140 251141!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:25'! 251142decodeColors: colorsAndFiles depth: requiredDepth 251143 | color bytes form | 251144 colorsAndFiles do:[:assoc| 251145 color := assoc key. 251146 bytes := Base64MimeConverter mimeDecodeToBytes: assoc value readStream. 251147 form := PNGReadWriter formFromStream: bytes. 251148 self assert: form depth = requiredDepth. 251149 self assert: (form pixelValueAt: 1@1) = (color pixelValueForDepth: requiredDepth). 251150 ].! ! 251151 251152!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'PeterHugossonMiller 9/3/2009 10:12'! 251153encodeColors: colorsAndFiles depth: requiredDepth 251154 | color original ff encoded | 251155 colorsAndFiles do:[:assoc| 251156 color := assoc key. 251157 original := Base64MimeConverter mimeDecodeToBytes: assoc value readStream. 251158 ff := Form extent: 32@32 depth: requiredDepth. 251159 ff fillColor: color. 251160 encoded := ByteArray new writeStream. 251161 PNGReadWriter putForm: ff onStream: encoded. 251162 self assert: (encoded contents = original contents). 251163 ].! ! 251164 251165!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:20'! 251166testPngDecodingColors16 251167 self decodeColors: self coloredFiles16 depth: 16.! ! 251168 251169!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:20'! 251170testPngDecodingColors32 251171 self decodeColors: self coloredFiles32 depth: 32.! ! 251172 251173!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:20'! 251174testPngDecodingColors8 251175 self decodeColors: self coloredFiles8 depth: 8.! ! 251176 251177!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:28'! 251178testPngEncodingColors16 251179 self encodeColors: self coloredFiles16 depth: 16.! ! 251180 251181!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:28'! 251182testPngEncodingColors32 251183 self encodeColors: self coloredFiles32 depth: 32.! ! 251184 251185!PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:28'! 251186testPngEncodingColors8 251187 self encodeColors: self coloredFiles8 depth: 8.! ! 251188ImageReadWriter subclass: #PNMReadWriter 251189 instanceVariableNames: 'first type origin cols rows depth maxValue tupleType pragma' 251190 classVariableNames: '' 251191 poolDictionaries: '' 251192 category: 'Graphics-Files'! 251193!PNMReadWriter commentStamp: 'jdr 10/20/2003 17:08' prior: 0! 251194I am a subclass of ImageReadWriter that decodes portable anymap file formats 251195(pbm, pgm, ppm and pam) images. 251196 251197I accept the #origin pragma for SE files as described in: 251198Algoritms For Image Processing And Computer Vision. J. R. Parker 251199 251200Don't work with 2 bytes samples (16 bit grays, > 32 bits color, etc...), 251201pam files preliminary support. 251202 251203f _ ImageReadWriter formFromFileNamed: 'Tools:Squeak3.4:Carmen.ppm'. 251204f morphEdit 251205 251206Submitted by Javier Diaz Reinoso, Oct/2003! 251207]style[(361 18 2 26 3 11 1 43)f1,cblack;f1,f1b,f1,f1b,f1,f1b,f1! 251208 251209 251210!PNMReadWriter methodsFor: 'accessing' stamp: 'jdr 10/16/2003 14:52'! 251211origin 251212 ^origin! ! 251213 251214!PNMReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 251215pragma: s 251216 pragma := s! ! 251217 251218!PNMReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 251219stream: s 251220 stream := s! ! 251221 251222!PNMReadWriter methodsFor: 'accessing' stamp: 'jdr 10/16/2003 14:53'! 251223tupleType 251224 ^tupleType! ! 251225 251226 251227!PNMReadWriter methodsFor: 'reading' stamp: 'PeterHugossonMiller 9/3/2009 10:12'! 251228cleanLine 251229 "upTo LF or CR, tab as space" 251230 | line loop b | 251231 line := String new writeStream. 251232 loop := true. 251233 [ loop ] whileTrue: 251234 [ b := stream next. 251235 b 251236 ifNil: [ loop := false "EOS" ] 251237 ifNotNil: 251238 [ (b = Character cr or: [ b = Character lf ]) 251239 ifTrue: [ loop := false ] 251240 ifFalse: 251241 [ b = Character tab ifTrue: [ b := Character space ]. 251242 line nextPut: b ] ] ]. 251243 ^ line contents! ! 251244 251245!PNMReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 251246getTokenPbm: aCollection 251247 "get a number, return rest of collection" 251248 | line tokens token | 251249 tokens := aCollection. 251250 tokens size = 0 ifTrue: 251251 [ 251252 [ line := self pbmGetLine. 251253 line ifNil: 251254 [ ^ { nil. nil } ]. 251255 tokens := line findTokens: ' '. 251256 tokens size = 0 ] whileTrue: [ ] ]. 251257 "Transcript cr; show: tokens asString." 251258 token := tokens removeFirst. 251259 ^ { (token asInteger). tokens }! ! 251260 251261!PNMReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 251262nextImage 251263 "read one image" 251264 | data p | 251265 first 251266 ifNil: 251267 [ first := false. 251268 data := stream contentsOfEntireFile. 251269 stream := (RWBinaryOrTextStream with: data) reset ] 251270 ifNotNil: 251271 [ type < 4 ifTrue: [ self error: 'Plain PBM, PGM or PPM have only one image' ] ]. 251272 stream ascii. 251273 p := stream next. 251274 type := stream next asInteger - 48. 251275 (p = $P and: [ type > 0 and: [ type < 8 ] ]) ifFalse: [ self error: 'Not a PNM file' ]. 251276 type = 7 251277 ifTrue: [ self readHeaderPAM ] 251278 ifFalse: [ self readHeader ]. 251279 type caseOf: { 251280 ([ 1 ] -> [ ^ self readPlainBW ]). 251281 ([ 2 ] -> [ ^ self readPlainGray ]). 251282 ([ 3 ] -> [ ^ self readPlainRGB ]). 251283 ([ 4 ] -> [ ^ self readBWreverse: false ]). 251284 ([ 5 ] -> [ ^ self readGray ]). 251285 ([ 6 ] -> [ ^ self readRGB ]). 251286 ([ 7 ] -> 251287 [ "PAM" 251288 tupleType asUppercase 251289 caseOf: { 251290 ([ 'BLACKANDWHITE' ] -> [ ^ self readBWreverse: true ]). 251291 ([ 'GRAYSCALE' ] -> [ ^ self readGray ]). 251292 ([ 'RGB' ] -> [ ^ self readRGB ]). 251293 ([ 'RGB_ALPHA' ] -> [ ^ self error: 'Not implemented' ]). 251294 ([ 'GRAYSCALE_ALPHA' ] -> [ ^ self error: 'Not implemented' ]) 251295 } 251296 otherwise: [ ^ self readData ] ]) 251297 }! ! 251298 251299!PNMReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 251300pbmGetLine 251301 "Get the next non-comment line from the PBM stream 251302 Look for 'pragmas' - commands hidden in the comments" 251303 | line | 251304 251305 [ line := self cleanLine. 251306 line ifNil: [ ^ nil ]. 251307 (line size > 0 and: [ (line at: 1) = $# ]) ifTrue: [ self pbmParam: line ]. 251308 line size = 0 or: [ (line at: 1) = $# ] ] whileTrue: [ ]. 251309 ^ line! ! 251310 251311!PNMReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 251312pbmParam: line 251313 "Look for a parameter hidden in a comment" 251314 | key tokens | 251315 tokens := line findTokens: ' '. 251316 key := (tokens at: 1) asLowercase. 251317 (key = '#origin' and: [ tokens size = 3 ]) ifTrue: 251318 [ "ORIGIN key word" 251319 "This is for SE files as described in: 251320 Algoritms For Image Processing And Computer Vision. J. R. Parker" 251321 origin := (tokens at: 2) asInteger @ (tokens at: 3) asInteger ]! ! 251322 251323!PNMReadWriter methodsFor: 'reading' stamp: 'jdr 7/18/2005 17:02'! 251324r: r g: g b: b for: aDepth 251325 "integer value according depth" 251326 | val | 251327 aDepth = 16 ifTrue: [ 251328 val := (1 << 15) + (r << 10) + (g << 5) + b. 251329 ] 251330 ifFalse:[ 251331 val := (16rFF << 24) + (r << 16) + (g << 8) + b. 251332 ]. 251333 ^val 251334! ! 251335 251336!PNMReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 251337readBWreverse: flagXor 251338 "B&W for PAM" 251339 | val form bytesRow nBytes | 251340 stream binary. 251341 form := Form 251342 extent: cols @ rows 251343 depth: 1. 251344 nBytes := (cols / 8) ceiling. 251345 bytesRow := (cols / 32) ceiling * 4. 251346 0 251347 to: rows - 1 251348 do: 251349 [ :y | 251350 | i | 251351 i := 1 + (bytesRow * y). 251352 0 251353 to: nBytes - 1 251354 do: 251355 [ :x | 251356 val := stream next. 251357 flagXor ifTrue: [ val := val bitXor: 255 ]. 251358 form bits 251359 byteAt: i 251360 put: val. 251361 i := i + 1 ] ]. 251362 ^ form! ! 251363 251364!PNMReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 251365readData 251366 "generic data" 251367 | data nBits nBytes val sample | 251368 stream binary. 251369 data := OrderedCollection new. 251370 nBits := maxValue floorLog: 2. 251371 nBytes := nBits + 1 >> 3. 251372 (nBits + 1 rem: 8) > 0 ifTrue: [ nBytes := nBytes + 1 ]. 251373 0 251374 to: rows - 1 251375 do: 251376 [ :y | 251377 0 251378 to: cols - 1 251379 do: 251380 [ :x | 251381 val := 0. 251382 1 251383 to: nBytes 251384 do: 251385 [ :n | 251386 sample := stream next. 251387 val := (val << 8) + sample ]. 251388 data add: val ] ]. 251389 ^ data! ! 251390 251391!PNMReadWriter methodsFor: 'reading' stamp: 'adrian_lienhard 7/18/2009 15:58'! 251392readGray 251393 "gray form" 251394 | val form poker | 251395 maxValue > 255 ifTrue: [ self error: 'Gray value > 8 bits not supported' ]. 251396 stream binary. 251397 form := Form 251398 extent: cols @ rows 251399 depth: depth. 251400 poker := BitBlt current bitPokerToForm: form. 251401 0 251402 to: rows - 1 251403 do: 251404 [ :y | 251405 0 251406 to: cols - 1 251407 do: 251408 [ :x | 251409 val := stream next. 251410 poker 251411 pixelAt: x @ y 251412 put: val ] ]. 251413 ^ form! ! 251414 251415!PNMReadWriter methodsFor: 'reading' stamp: 'adrian_lienhard 7/18/2009 15:58'! 251416readHeader 251417 "read header for pbm, pgm or ppm" 251418 | tokens aux d c | 251419 tokens := OrderedCollection new. 251420 aux := self getTokenPbm: tokens. 251421 cols := aux at: 1. 251422 tokens := aux at: 2. 251423 aux := self getTokenPbm: tokens. 251424 rows := aux at: 1. 251425 tokens := aux at: 2. 251426 (type = 1 or: [ type = 4 ]) 251427 ifTrue: [ maxValue := 1 ] 251428 ifFalse: 251429 [ aux := self getTokenPbm: tokens. 251430 maxValue := aux at: 1. 251431 tokens := aux at: 2 ]. 251432 d := { 1. 2. 4. 8. 16. 32 }. 251433 c := { 2. 4. 16. 256. 32768. 16777216 }. 251434 (type = 3 or: [ type = 6 ]) 251435 ifTrue: 251436 [ maxValue >= 65536 ifTrue: [ self error: 'Pixmap > 48 bits not supported in PPM' ]. 251437 maxValue >= 256 ifTrue: [ self error: 'Pixmap > 32 bits are not supported' ]. 251438 maxValue < 32 251439 ifTrue: [ depth := 16 ] 251440 ifFalse: [ depth := 32 ] ] 251441 ifFalse: 251442 [ depth := nil. 251443 1 251444 to: c size 251445 do: [ :i | ((c at: i) > maxValue and: [ depth = nil ]) ifTrue: [ depth := d at: i ] ] ]. 251446 Transcript 251447 cr; 251448 show: 'PBM file class ' , type asString , ' size ' , cols asString , ' x ' , rows asString , ' maxValue =' , maxValue asString , ' depth=' , depth asString! ! 251449 251450!PNMReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 251451readHeaderPAM 251452 "read pam header, not tested" 251453 | loop line tokens key val | 251454 tupleType := ''. 251455 loop := true. 251456 loop whileTrue: 251457 [ line := self pbmGetLine. 251458 tokens := line findTokens: ' '. 251459 tokens size = 2 ifTrue: 251460 [ key := tokens at: 1 asUppercase. 251461 val := tokens at: 2. 251462 key caseOf: { 251463 ([ 'WIDTH' ] -> [ cols := val asInteger ]). 251464 ([ 'HEIGHT' ] -> [ rows := val asInteger ]). 251465 ([ 'DEPTH' ] -> [ depth := val asInteger ]). 251466 ([ 'MAXVAL' ] -> [ maxValue := val asInteger ]). 251467 ([ 'TUPLETYPE' ] -> [ tupleType := tupleType , ' ' , val ]). 251468 ([ 'ENDHDR' ] -> [ loop := false ]) 251469 } ] ]. 251470 Transcript 251471 cr; 251472 show: 'PAM file class ' , type asString , ' size ' , cols asString , ' x ' , rows asString , ' maxValue =' , maxValue asString , ' depth=' , depth asString! ! 251473 251474!PNMReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 251475readPlainBW 251476 "plain BW" 251477 | val form poker | 251478 form := Form 251479 extent: cols @ rows 251480 depth: depth. 251481 poker := BitBlt current bitPokerToForm: form. 251482 0 251483 to: rows - 1 251484 do: 251485 [ :y | 251486 0 251487 to: cols - 1 251488 do: 251489 [ :x | 251490 251491 [ val := stream next. 251492 val = $0 or: [ val = $1 ] ] whileFalse: [ val ifNil: [ self error: 'End of file reading PBM' ] ]. 251493 poker 251494 pixelAt: x @ y 251495 put: val asInteger ] ]. 251496 ^ form! ! 251497 251498!PNMReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! 251499readPlainGray 251500 "plain gray" 251501 | val form poker aux tokens | 251502 form := Form 251503 extent: cols @ rows 251504 depth: depth. 251505 poker := BitBlt current bitPokerToForm: form. 251506 tokens := OrderedCollection new. 251507 0 251508 to: rows - 1 251509 do: 251510 [ :y | 251511 0 251512 to: cols - 1 251513 do: 251514 [ :x | 251515 aux := self getTokenPbm: tokens. 251516 val := aux at: 1. 251517 tokens := aux at: 2. 251518 poker 251519 pixelAt: x @ y 251520 put: val ] ]. 251521 ^ form! ! 251522 251523!PNMReadWriter methodsFor: 'reading' stamp: 'adrian_lienhard 7/18/2009 15:58'! 251524readPlainRGB 251525 "RGB form, use 32 bits" 251526 | val form poker tokens aux | 251527 maxValue > 255 ifTrue: [ self error: 'RGB value > 32 bits not supported' ]. 251528 form := Form 251529 extent: cols @ rows 251530 depth: 32. 251531 poker := BitBlt current bitPokerToForm: form. 251532 tokens := OrderedCollection new. 251533 0 251534 to: rows - 1 251535 do: 251536 [ :y | 251537 0 251538 to: cols - 1 251539 do: 251540 [ :x | 251541 | r g b | 251542 aux := self getTokenPbm: tokens. 251543 r := aux at: 1. 251544 tokens := aux at: 2. 251545 aux := self getTokenPbm: tokens. 251546 g := aux at: 1. 251547 tokens := aux at: 2. 251548 aux := self getTokenPbm: tokens. 251549 b := aux at: 1. 251550 tokens := aux at: 2. 251551 val := self 251552 r: r 251553 g: g 251554 b: b 251555 for: depth. 251556 poker 251557 pixelAt: x @ y 251558 put: val ] ]. 251559 ^ form! ! 251560 251561!PNMReadWriter methodsFor: 'reading' stamp: 'adrian_lienhard 7/18/2009 15:58'! 251562readRGB 251563 "RGB form, use 16/32 bits" 251564 | val form poker sample shift | 251565 maxValue > 255 ifTrue:[self error:'RGB value > 32 bits not supported']. 251566 stream binary. 251567 form := Form extent: cols@rows depth: depth. 251568 poker := BitBlt current bitPokerToForm: form. 251569 depth = 32 ifTrue:[shift := 8] ifFalse:[shift := 5]. 251570 0 to: rows-1 do: [:y | 251571 0 to: cols-1 do: [:x | 251572 val := 16rFF. "no transparency" 251573 1 to: 3 do: [:i | 251574 sample := stream next. 251575 val := val << shift + sample. 251576 ]. 251577 poker pixelAt: x@y put: val. 251578 ] 251579 ]. 251580 ^form 251581! ! 251582 251583 251584!PNMReadWriter methodsFor: 'testing' stamp: 'lr 7/4/2009 10:42'! 251585understandsImageFormat 251586 "P1 to P7" 251587 | p | 251588 p := stream next asCharacter. 251589 type := stream next - 48. 251590 ^ p = $P and: [ type > 0 and: [ type < 8 ] ]! ! 251591 251592 251593!PNMReadWriter methodsFor: 'writing' stamp: 'lr 7/4/2009 10:42'! 251594nextPutBW: aForm reverse: flagXor 251595 | myType val nBytes bytesRow | 251596 cols := aForm width. 251597 rows := aForm height. 251598 depth := aForm depth. 251599 "stream position: 0." 251600 aForm depth = 1 251601 ifTrue: [ myType := $4 ] 251602 ifFalse: [ myType := $5 ]. 251603 self writeHeader: myType. 251604 stream binary. 251605 nBytes := (cols / 8) ceiling. 251606 bytesRow := (cols / 32) ceiling * 4. 251607 0 251608 to: rows - 1 251609 do: 251610 [ :y | 251611 | i | 251612 i := 1 + (bytesRow * y). 251613 0 251614 to: nBytes - 1 251615 do: 251616 [ :x | 251617 val := aForm bits byteAt: i. 251618 flagXor ifTrue: [ val := val bitXor: 255 ]. 251619 stream nextPut: val. 251620 i := i + 1 ] ]! ! 251621 251622!PNMReadWriter methodsFor: 'writing' stamp: 'lr 7/4/2009 10:42'! 251623nextPutGray: aForm 251624 | myType peeker val | 251625 cols := aForm width. 251626 rows := aForm height. 251627 depth := aForm depth. 251628 "stream position: 0." 251629 aForm depth = 1 251630 ifTrue: [ myType := $4 ] 251631 ifFalse: [ myType := $5 ]. 251632 self writeHeader: myType. 251633 peeker := BitBlt current bitPeekerFromForm: aForm. 251634 0 251635 to: rows - 1 251636 do: 251637 [ :y | 251638 0 251639 to: cols - 1 251640 do: 251641 [ :x | 251642 val := peeker pixelAt: x @ y. 251643 stream nextPut: val ] ]! ! 251644 251645!PNMReadWriter methodsFor: 'writing' stamp: 'jdr 10/16/2003 14:22'! 251646nextPutImage: aForm 251647 aForm unhibernate. 251648 aForm depth caseOf: { 251649 [1] -> [self nextPutBW: aForm reverse: false]. 251650 [16] -> [self nextPutRGB: aForm]. 251651 [32] -> [self nextPutRGB: aForm]. 251652 } otherwise: [ 251653 (aForm respondsTo: #colors) ifTrue:[ 251654 aForm colors ifNil: [ 251655 self nextPutGray: aForm 251656 ] 251657 ifNotNil: [ 251658 self nextPutRGB: aForm 251659 ] 251660 ] 251661 ifFalse:[ 251662 self nextPutGray: aForm 251663 ] 251664 ]! ! 251665 251666!PNMReadWriter methodsFor: 'writing' stamp: 'lr 7/4/2009 10:42'! 251667nextPutRGB: aForm 251668 | myType peeker f shift mask | 251669 cols := aForm width. 251670 rows := aForm height. 251671 depth := aForm depth. 251672 f := aForm. 251673 depth < 16 ifTrue: 251674 [ f := aForm asFormOfDepth: 32. 251675 depth := 32 ]. 251676 myType := $6. 251677 "stream position: 0." 251678 self writeHeader: myType. 251679 depth = 32 251680 ifTrue: 251681 [ shift := 8. 251682 mask := 255 ] 251683 ifFalse: 251684 [ shift := 5. 251685 mask := 31 ]. 251686 peeker := BitBlt current bitPeekerFromForm: f. 251687 0 251688 to: rows - 1 251689 do: 251690 [ :y | 251691 0 251692 to: cols - 1 251693 do: 251694 [ :x | 251695 | p r g b | 251696 p := peeker pixelAt: x @ y. 251697 b := p bitAnd: mask. 251698 p := p >> shift. 251699 g := p bitAnd: mask. 251700 p := p >> shift. 251701 r := p bitAnd: mask. 251702 stream nextPut: r. 251703 stream nextPut: g. 251704 stream nextPut: b ] ]! ! 251705 251706!PNMReadWriter methodsFor: 'writing' stamp: 'lr 7/4/2009 10:42'! 251707writeHeader: myType 251708 "this is ascii" 251709 stream nextPut: $P asciiValue. 251710 stream nextPut: myType asciiValue. 251711 stream nextPut: 10. "nl" 251712 pragma ifNotNil: [ stream nextPutAll: pragma asByteArray ]. 251713 stream nextPutAll: cols printString asByteArray. 251714 stream nextPut: 32. " " 251715 stream nextPutAll: rows printString asByteArray. 251716 stream nextPut: 10. "nl" 251717 depth > 1 ifTrue: 251718 [ | d c maxV | 251719 d := { 1. 2. 4. 8. 16. 32 }. 251720 c := { 1. 3. 15. 255. 31. 255 }. 251721 maxV := nil. 251722 1 251723 to: d size 251724 do: [ :i | ((d at: i) = depth and: [ maxV = nil ]) ifTrue: [ maxV := c at: i ] ]. 251725 stream nextPutAll: maxV printString asByteArray. 251726 stream nextPut: 10 "nl" ]! ! 251727 251728"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 251729 251730PNMReadWriter class 251731 instanceVariableNames: ''! 251732 251733!PNMReadWriter class methodsFor: 'image reading/writing' stamp: 'jdr 7/18/2005 16:25'! 251734typicalFileExtensions 251735 "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" 251736 ^#('pbm' 'pnm' 'ppm' 'pam')! ! 251737 251738 251739!PNMReadWriter class methodsFor: 'testing' stamp: 'lr 7/4/2009 10:42'! 251740testToSEFile: filename 251741 "write SE file with origin 251742 PNMReadWriter testToSEFile: 'Tools:Squeak3.4:outSE.pbm'. 251743 " 251744 | prw f | 251745 prw := self new. 251746 prw stream: (FileStream newFileNamed: filename) binary. 251747 prw pragma: '#origin 10 10' , String lf. 251748 f := Form fromUser. 251749 prw nextPutImage: f! ! 251750ProtocolClient subclass: #POP3Client 251751 instanceVariableNames: '' 251752 classVariableNames: '' 251753 poolDictionaries: '' 251754 category: 'Network-Protocols'! 251755!POP3Client commentStamp: 'mir 5/12/2003 17:57' prior: 0! 251756This class implements POP3 (Post Office Protocol 3) as specified in RFC 1939. (see http://www.ietf.org/rfc.html) 251757 251758You can use it to download email from the mail server to your personal mail program. 251759 251760To see an example of it's use, see POPSocket class>>example.! 251761 251762 251763!POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:58'! 251764apopLoginUser: userName password: password 251765 251766 self loginUser: userName password: password loginMethod: #APOP! ! 251767 251768!POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:35'! 251769deleteMessage: num 251770 "delete the numbered message" 251771 251772 self ensureConnection. 251773 self sendCommand: 'DELE ', num printString. 251774 self checkResponse. 251775 self logProgress: self lastResponse! ! 251776 251777!POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:57'! 251778loginUser: userName password: password 251779 251780 self loginUser: userName password: password loginMethod: #clearText! ! 251781 251782!POP3Client methodsFor: 'public protocol' stamp: 'mir 3/8/2002 11:40'! 251783loginUser: userName password: password loginMethod: aLoginMethod 251784 251785 self user: userName. 251786 self password: password. 251787 self loginMethod: aLoginMethod. 251788 self login! ! 251789 251790!POP3Client methodsFor: 'public protocol' stamp: 'mir 4/7/2003 17:17'! 251791messageCount 251792 "Query the server and answer the number of messages that are in the user's mailbox." 251793 251794 | answerString numMessages | 251795 self ensureConnection. 251796 self sendCommand: 'STAT'. 251797 self checkResponse. 251798 self logProgress: self lastResponse. 251799 251800 [answerString := (self lastResponse findTokens: Character separators) second. 251801 numMessages := answerString asNumber asInteger] 251802 on: Error 251803 do: [:ex | (ProtocolClientError protocolInstance: self) signal: 'Invalid STAT response.']. 251804 ^numMessages! ! 251805 251806!POP3Client methodsFor: 'public protocol' stamp: 'len 12/14/2002 17:50'! 251807quit 251808 "QUIT <CRLF>" 251809 251810 self sendCommand: 'QUIT'. 251811 self checkResponse.! ! 251812 251813!POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:35'! 251814retrieveMessage: number 251815 "retrieve the numbered message" 251816 251817 self ensureConnection. 251818 self sendCommand: 'RETR ', number printString. 251819 self checkResponse. 251820 self logProgress: self lastResponse. 251821 251822 ^self getMultilineResponse! ! 251823 251824 251825!POP3Client methodsFor: 'private' stamp: 'mir 11/11/2002 16:20'! 251826loginMethod 251827 ^self connectionInfo at: #loginMethod ifAbsent: [nil]! ! 251828 251829!POP3Client methodsFor: 'private' stamp: 'mir 3/8/2002 11:41'! 251830loginMethod: aSymbol 251831 ^self connectionInfo at: #loginMethod put: aSymbol! ! 251832 251833 251834!POP3Client methodsFor: 'private protocol' stamp: 'BG 3/16/2005 08:27'! 251835apopLogin 251836 251837 "Attempt to authenticate ourselves to the server without sending the password as cleartext." 251838 251839 "For secure authentication, we look for a timestamp in the initial response string we get from the server, and then try the APOP command as specified in RFC 1939. If the initial response from the server is 251840 +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us> 251841we extract the timestamp 251842 <1896.697170952@dbc.mtview.ca.us> 251843then form a string of the form 251844 <1896.697170952@dbc.mtview.ca.us>USERPASSWORD 251845and then send only the MD5 hash of that to the server. Thus the password never hits the wire" 251846 251847 | timestamp hash | 251848 251849 [ 251850 "Look for a timestamp in the response we received from the server" 251851 timestamp := self lastResponse findTokens: '<>' includes: '@'. 251852 timestamp 251853 ifNil: [(POP3LoginError protocolInstance: self) signal: 'APOP not supported.']. 251854 251855 (Smalltalk includesKey: #MD5) 251856 ifTrue: [ 251857 hash := ((Smalltalk at: #MD5) hashMessage: ('<', timestamp, '>', self password)) storeStringHex asLowercase. 251858 "trim starting 16r and zero pad it to 32 characters if needed" 251859 hash := hash padded: #left to: 32 with: $0] 251860 ifFalse: [(POP3LoginError protocolInstance: self) signal: 'APOP (MD5) not supported.']. 251861 251862 self sendCommand: 'APOP ', self user, ' ', hash. 251863 self checkResponse. 251864 self logProgress: self lastResponse] 251865 on: ProtocolClientError 251866 do: [:ex | 251867 self close. 251868 (LoginFailedException protocolInstance: self) signal: 'Login failed.']! ! 251869 251870!POP3Client methodsFor: 'private protocol' stamp: 'mir 4/7/2003 17:38'! 251871clearTextLogin 251872 251873 [self sendCommand: 'USER ', self user. 251874 self checkResponse. 251875 self logProgress: self lastResponse. 251876 251877 self sendCommand: 'PASS ', self password. 251878 self checkResponse. 251879 self logProgress: self lastResponse] 251880 on: TelnetProtocolError 251881 do: [:ex | 251882 "Neither authentication worked. Indicate an error and close up" 251883 self close. 251884 ex resignalAs: ((LoginFailedException protocolInstance: self) signal: 'Login failed.')]! ! 251885 251886!POP3Client methodsFor: 'private protocol' stamp: 'PeterHugossonMiller 9/3/2009 10:12'! 251887getMultilineResponse 251888 "Get a multiple line response to the last command, filtering out LF characters. A multiple line response ends with a line containing only a single period (.) character." 251889 251890 | response done chunk | 251891 response := String new writeStream. 251892 done := false. 251893 [done] whileFalse: [ 251894 chunk := self stream nextLine. 251895 (chunk beginsWith: '.') 251896 ifTrue: [response nextPutAll: (chunk copyFrom: 2 to: chunk size); cr ] 251897 ifFalse: [response nextPutAll: chunk; cr ]. 251898 done := (chunk = '.') ]. 251899 251900 ^ response contents 251901! ! 251902 251903!POP3Client methodsFor: 'private protocol' stamp: 'mir 4/7/2003 17:39'! 251904login 251905 self loginMethod 251906 ifNil: [^self]. 251907 self loginMethod == #clearText 251908 ifTrue: [^self clearTextLogin]. 251909 self loginMethod == #APOP 251910 ifTrue: [^self apopLogin]. 251911 (POP3LoginError protocolInstance: self) signal: 'Unsupported login procedure.'! ! 251912 251913 251914!POP3Client methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:43'! 251915responseIsError 251916 ^self lastResponse beginsWith: '-'! ! 251917 251918!POP3Client methodsFor: 'private testing' stamp: 'mir 11/11/2002 15:44'! 251919responseIsWarning 251920 ^self lastResponse beginsWith: '-'! ! 251921 251922"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 251923 251924POP3Client class 251925 instanceVariableNames: ''! 251926 251927!POP3Client class methodsFor: 'accessing' stamp: 'mir 3/7/2002 12:51'! 251928defaultPortNumber 251929 ^110! ! 251930 251931!POP3Client class methodsFor: 'accessing' stamp: 'mir 3/7/2002 12:52'! 251932logFlag 251933 ^#pop! ! 251934 251935 251936!POP3Client class methodsFor: 'example' stamp: 'rbb 3/1/2005 11:05'! 251937example 251938 "POP3Client example" 251939 "download a user's messages into an OrderedCollection and inspect the OrderedCollection" 251940 251941 | ps messages userName password | 251942 userName := (UIManager default request: 'POP username'). 251943 password := (UIManager default request: 'POP password'). 251944 ps := POP3Client openOnHostNamed: (UIManager default request: 'POP server'). 251945 [ 251946 ps loginUser: userName password: password. 251947 ps logProgressToTranscript. 251948 251949 messages := OrderedCollection new. 251950 1 to: ps messageCount do: [ :messageNr | 251951 messages add: (ps retrieveMessage: messageNr) ]] 251952 ensure: [ps close]. 251953 251954 messages inspect.! ! 251955ProtocolClientError subclass: #POP3LoginError 251956 instanceVariableNames: '' 251957 classVariableNames: '' 251958 poolDictionaries: '' 251959 category: 'Network-Protocols'! 251960!POP3LoginError commentStamp: 'mir 5/12/2003 17:58' prior: 0! 251961Exception for signaling POP3 login failures.! 251962 251963ListItemWrapper subclass: #PSMCChangeWrapper 251964 instanceVariableNames: '' 251965 classVariableNames: '' 251966 poolDictionaries: '' 251967 category: 'Polymorph-Tools-Diff'! 251968 251969!PSMCChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 1/14/2009 12:42'! 251970actualClass 251971 "Answer the class represented in the receiver." 251972 251973 ^(self operation ifNil: [^nil]) targetClass! ! 251974 251975!PSMCChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 11:23'! 251976icon 251977 "Answer a form with an icon to represent the receiver" 251978 |o| 251979 o := self operation. 251980 o isNil ifTrue: [^MenuIcons smallJumpIcon]. 251981 o isAddition ifTrue: [^MenuIcons smallOkIcon]. 251982 o isRemoval ifTrue: [^MenuIcons smallCancelIcon]. 251983 ^MenuIcons smallForwardIcon! ! 251984 251985!PSMCChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 14:41'! 251986isConflict 251987 "Answer whether the receiver is a conflict item." 251988 251989 ^false! ! 251990 251991!PSMCChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:44'! 251992model: anObject 251993 "Set the model." 251994 251995 model := anObject! ! 251996 251997!PSMCChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 11:22'! 251998operation 251999 "Answer the underlying operation." 252000 252001 self subclassResponsibility ! ! 252002PSMCChangeWrapper subclass: #PSMCClassChangeWrapper 252003 instanceVariableNames: 'conflict contents' 252004 classVariableNames: '' 252005 poolDictionaries: '' 252006 category: 'Polymorph-Tools-Diff'! 252007 252008!PSMCClassChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 1/14/2009 12:44'! 252009actualClass 252010 "Answer the class represented in the receiver." 252011 252012 ^super actualClass ifNil: [Smalltalk classNamed: self item]! ! 252013 252014!PSMCClassChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 14:44'! 252015chooseLocal 252016 "Choose the local version." 252017 252018 self conflict chooseLocal! ! 252019 252020!PSMCClassChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 14:44'! 252021chooseRemote 252022 "Choose the remote version." 252023 252024 self conflict chooseRemote! ! 252025 252026!PSMCClassChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 14:44'! 252027clearChoice 252028 "Choose neither version (be in conflict)." 252029 252030 self conflict clearChoice! ! 252031 252032!PSMCClassChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:45'! 252033conflict 252034 "Answer the conflict for the class itself or nil if none." 252035 252036 |o| 252037 conflict ifNotNil: [^conflict]. 252038 o := self model detect: [:i | i targetClassName == self item and: [ 252039 i definition isClassDefinition]] ifNone: []. 252040 o ifNil: [^nil]. 252041 o isConflict ifTrue: [conflict := o]. 252042 ^conflict! ! 252043 252044!PSMCClassChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 4/1/2009 13:30'! 252045contents 252046 "Answer the contents of the change." 252047 252048 ^contents ifNil: [contents := self gatherContents]! ! 252049 252050!PSMCClassChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 4/1/2009 13:30'! 252051gatherContents 252052 "Answer the contents of the change from the model." 252053 252054 ^((self model select: [:i | i targetClassName = self item and: [ 252055 i definition isClassDefinition not]]) 252056 collect: [:o | o patchWrapper model: self model]) asSortedCollection: [:a :b | 252057 a asString <= b asString]! ! 252058 252059!PSMCClassChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:11'! 252060icon 252061 "Answer a form with an icon to represent the receiver" 252062 252063 self conflict ifNotNilDo: [:c | 252064 c localChosen ifTrue: [^MenuIcons smallBackIcon]]. 252065 ^super icon! ! 252066 252067!PSMCClassChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 14:41'! 252068isConflict 252069 "Answer whether the receiver is a conflict item." 252070 252071 ^self conflict notNil! ! 252072 252073!PSMCClassChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:43'! 252074localChosen 252075 "Answer whether the local version is chosen." 252076 252077 ^self conflict localChosen! ! 252078 252079!PSMCClassChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 1/14/2009 12:43'! 252080operation 252081 "Answer the patch operation for the class itself or nil if none." 252082 252083 |o| 252084 o := self model detect: [:i | i targetClassName = self item and: [ 252085 i definition isClassDefinition]] ifNone: []. 252086 o ifNil: [^nil]. 252087 o isConflict ifTrue: [^o operation]. 252088 ^o! ! 252089 252090!PSMCClassChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 14:39'! 252091preferredColor 252092 "Answer the colour for the string. 252093 If a conflict and unresolved answer red." 252094 252095 ^(self conflict 252096 ifNil: [true] 252097 ifNotNilDo: [:c | c isResolved]) 252098 ifTrue: [super preferredColor] 252099 ifFalse: [Color red]! ! 252100 252101!PSMCClassChangeWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:42'! 252102remoteChosen 252103 "Answer whether the remote version is chosen." 252104 252105 ^self conflict remoteChosen! ! 252106PSMCChangeWrapper subclass: #PSMCConflictWrapper 252107 instanceVariableNames: '' 252108 classVariableNames: '' 252109 poolDictionaries: '' 252110 category: 'Polymorph-Tools-Diff'! 252111 252112!PSMCConflictWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 11:24'! 252113asString 252114 "Answer the method name." 252115 252116 ^self operation shortSummary! ! 252117 252118!PSMCConflictWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 14:42'! 252119chooseLocal 252120 "Choose the local version." 252121 252122 self item chooseLocal! ! 252123 252124!PSMCConflictWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 14:43'! 252125chooseRemote 252126 "Choose the remote version." 252127 252128 self item chooseRemote! ! 252129 252130!PSMCConflictWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 14:43'! 252131clearChoice 252132 "Choose neither version (be in conflict)." 252133 252134 self item clearChoice! ! 252135 252136!PSMCConflictWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:09'! 252137icon 252138 "Answer a form with an icon to represent the receiver" 252139 252140 self item localChosen ifTrue: [^MenuIcons smallBackIcon]. 252141 ^super icon! ! 252142 252143!PSMCConflictWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 14:42'! 252144isConflict 252145 "Answer whether the receiver is a conflict item." 252146 252147 ^true! ! 252148 252149!PSMCConflictWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:41'! 252150localChosen 252151 "Answer whether the local version is chosen." 252152 252153 ^self item localChosen! ! 252154 252155!PSMCConflictWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 11:34'! 252156operation 252157 "Answer the patch operation for the conflict." 252158 252159 ^self item operation! ! 252160 252161!PSMCConflictWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 11:43'! 252162preferredColor 252163 252164 ^self item isResolved 252165 ifTrue: [super preferredColor] 252166 ifFalse: [Color red]! ! 252167 252168!PSMCConflictWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:41'! 252169remoteChosen 252170 "Answer whether the remote version is chosen." 252171 252172 ^self item remoteChosen! ! 252173ComposableMorph subclass: #PSMCMergeMorph 252174 instanceVariableNames: 'patchMorph codeMorph merged' 252175 classVariableNames: '' 252176 poolDictionaries: '' 252177 category: 'Polymorph-Tools-Diff'! 252178 252179!PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:28'! 252180codeMorph 252181 "Answer the value of codeMorph" 252182 252183 ^ codeMorph! ! 252184 252185!PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:28'! 252186codeMorph: anObject 252187 "Set the value of codeMorph" 252188 252189 codeMorph := anObject! ! 252190 252191!PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2009 17:42'! 252192merged 252193 "Answer the value of merged. Indicates whether 252194 the merge button was pressed with no conflicts remaining." 252195 252196 ^ merged! ! 252197 252198!PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2009 17:42'! 252199merged: anObject 252200 "Set the value of merged" 252201 252202 merged := anObject! ! 252203 252204!PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:28'! 252205patchMorph 252206 "Answer the value of patchMorph" 252207 252208 ^ patchMorph! ! 252209 252210!PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:28'! 252211patchMorph: anObject 252212 "Set the value of patchMorph" 252213 252214 patchMorph := anObject! ! 252215 252216 252217!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/9/2009 15:18'! 252218allConflictsResolved 252219 "Answer whether all conflicts were resolved." 252220 252221 ^(self model ifNil: [^false]) isMerged! ! 252222 252223!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/9/2009 15:43'! 252224cancel 252225 "Delete the window to cancel." 252226 252227 self window delete! ! 252228 252229!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 11:53'! 252230compositeText 252231 "Answer the composite text from the patch morph." 252232 252233 ^self patchMorph compositeText! ! 252234 252235!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2009 17:12'! 252236compositeText: aString 252237 "Save the new method text for the selected method. 252238 Yet to be implemented." 252239 252240 UIManager default inform: 'Saving of replacement methods is not yet imlemented.'! ! 252241 252242!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 12:52'! 252243conflictCount 252244 "Answer the number of conflicts that are unresolved." 252245 252246 ^(self model ifNil: [^0]) conflicts count: [:c | c isResolved not]! ! 252247 252248!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 12:50'! 252249conflictCountString 252250 "Answer a string describing the number of conflicts." 252251 252252 |count| 252253 count := self conflictCount. 252254 ^count = 1 252255 ifTrue: ['1 conflict' translated] 252256 ifFalse: ['{1} conflicts' translated format: {count}]! ! 252257 252258!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 09:47'! 252259defaultTitle 252260 "Answer the default title label for the receiver." 252261 252262 ^'Merge' translated! ! 252263 252264!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/9/2009 15:38'! 252265initialize 252266 "Initialize the receiver." 252267 252268 |buttons buttonsHeight| 252269 super initialize. 252270 buttons := self newButtonsMorph. 252271 buttonsHeight := buttons minExtent y. 252272 self 252273 merged: false; 252274 patchMorph: self newPatchMorph; 252275 codeMorph: self newCodeMorph; 252276 changeProportionalLayout; 252277 addMorph: self patchMorph 252278 fullFrame: (LayoutFrame fractions: (0@0 corner: 1@0.6)); 252279 addMorph: self codeMorph 252280 fullFrame: (LayoutFrame fractions: (0@0.6 corner: 1@1) offsets: (0@0 corner: 0@buttonsHeight negated)); 252281 addMorph: self newButtonsMorph 252282 fullFrame: (LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@buttonsHeight negated corner: 0@0)); 252283 addPaneSplitters! ! 252284 252285!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/9/2009 15:44'! 252286merge 252287 "Do the merge and close if no conflicts." 252288 252289 ^self model isMerged 252290 ifTrue: [self merged: true. 252291 self window delete] 252292 ifFalse: [self inform: 'You must resolve all conflicts first.' translated]! ! 252293 252294!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/1/2009 13:57'! 252295model: aMerger 252296 "Set the model and update the window." 252297 252298 |grouped sorted| 252299 super model: aMerger. 252300 grouped := aMerger operations, aMerger conflicts 252301 groupBy: [:o | o targetClassName ifNil: [o shortSummary]] 252302 having: [:g | true]. 252303 sorted := OrderedCollection new. 252304 grouped keys asSortedCollection do: [:k | 252305 sorted addAll: ((grouped at: k) asSortedCollection: [:a :b | a shortSummary <= b shortSummary])]. 252306 self patchMorph model: sorted! ! 252307 252308!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 12:43'! 252309newButtonsMorph 252310 "Answer a new buttons morph." 252311 252312 ^(self newRow: { 252313 self newConflictsButton. 252314 self newToolSpacer hResizing: #spaceFill. 252315 self newMergeButton. 252316 self newCancelButton}) 252317 removeProperty: #fillStyle; 252318 listCentering: #bottomRight; 252319 layoutInset: 4! ! 252320 252321!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 11:53'! 252322newCodeMorph 252323 "Answer a new code morph." 252324 252325 ^(self newTextEditorFor: self 252326 getText: #compositeText 252327 setText: #compositeText: 252328 getEnabled: nil) 252329 wrapFlag: false; 252330 setText: ''! ! 252331 252332!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 12:54'! 252333newConflictsButton 252334 "Answer a new button for displaying the count 252335 of outstanding conflicts and navigating to each. 252336 It will be disabled if all conflicts are resolved." 252337 252338 ^(self 252339 newButtonFor: self 252340 getState: nil 252341 action: #selectNextConflict 252342 arguments: #() 252343 getEnabled: #notAllConflictsResolved 252344 getLabel: #conflictCountString 252345 help: 'Select the next conflict in the tree' translated) 252346 vResizing: #spaceFill "workaround until table layout fixed"! ! 252347 252348!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 12:42'! 252349newMergeButton 252350 "Answer a new button for performing the merge. 252351 It will be disabled if any conflicts are unresolved." 252352 252353 ^self 252354 newButtonFor: self 252355 action: #merge 252356 getEnabled: #allConflictsResolved 252357 label: 'Merge' translated 252358 help: 'Merge the version into the image' translated! ! 252359 252360!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:26'! 252361newPatchMorph 252362 "Answer a new patch morph." 252363 252364 ^PSMCMergePatchMorph new 252365 borderWidth: 0; 252366 addDependent: self; 252367 yourself! ! 252368 252369!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 12:46'! 252370notAllConflictsResolved 252371 "Answer whether any conflicts are unresolved." 252372 252373 ^self allConflictsResolved not! ! 252374 252375!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 12:57'! 252376selectNextConflict 252377 "Select the next conflict in the tree." 252378 252379 self patchMorph selectNextConflict! ! 252380 252381!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 13:22'! 252382update: aspect 252383 "A join has probably changed its selection state." 252384 252385 super update: aspect. 252386 aspect == #compositeText 252387 ifTrue: [self updateCode]. 252388 aspect == #changes 252389 ifTrue: [self 252390 changed: #conflictCountString; 252391 changed: #allConflictsResolved; 252392 changed: #notAllConflictsResolved]! ! 252393 252394!PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 11:54'! 252395updateCode 252396 "Update the code morph to match selected differences." 252397 252398 self changed: #compositeText! ! 252399 252400"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 252401 252402PSMCMergeMorph class 252403 instanceVariableNames: ''! 252404 252405!PSMCMergeMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 10:31'! 252406forMerger: aMerger 252407 "Answer a new instance of the receiver 252408 with the given merger as the model." 252409 252410 ^ self new model: aMerger! ! 252411PSMCPatchMorph subclass: #PSMCMergePatchMorph 252412 instanceVariableNames: '' 252413 classVariableNames: '' 252414 poolDictionaries: '' 252415 category: 'Polymorph-Tools-Diff'! 252416 252417!PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 14:28'! 252418changesMenu: m 252419 "Answer the changes menu." 252420 252421 |menu| 252422 menu := super changesMenu: m. 252423 menu addLine. 252424 menu 252425 addToggle: 'Keep current version' translated 252426 target: self 252427 selector: #keepCurrentVersion 252428 getStateSelector: nil 252429 enablementSelector: #selectionIsConflict. 252430 menu lastItem 252431 font: self theme menuFont; 252432 icon: MenuIcons smallBackIcon. 252433 menu 252434 addToggle: 'Use incoming version' translated 252435 target: self 252436 selector: #useIncomingVersion 252437 getStateSelector: nil 252438 enablementSelector: #selectionIsConflict. 252439 menu lastItem 252440 font: self theme menuFont; 252441 icon: MenuIcons smallForwardIcon. 252442 menu 252443 addToggle: 'Mark as conflict' translated 252444 target: self 252445 selector: #markAsConflict 252446 getStateSelector: nil 252447 enablementSelector: #selectionIsConflict. 252448 menu lastItem 252449 font: self theme menuFont; 252450 icon: MenuIcons smallCancelIcon. 252451 menu addLine. 252452 menu 252453 addToggle: 'Select next conflict' translated 252454 target: self 252455 selector: #selectNextConflict 252456 getStateSelector: nil 252457 enablementSelector: #notAllConflictsResolved. 252458 menu lastItem 252459 font: self theme menuFont; 252460 icon: MenuIcons smallRightFlushIcon. 252461 ^menu! ! 252462 252463!PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:25'! 252464diffMorphClass 252465 "Answer a the class to use for a new diff morph." 252466 252467 ^MergeDiffMorph! ! 252468 252469!PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:46'! 252470keepCurrentVersion 252471 "Mark the conflict as local." 252472 252473 self selectedChangeWrapper chooseLocal. 252474 self changed: #changes. 252475 self updateSource! ! 252476 252477!PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:45'! 252478markAsConflict 252479 "Mark the conflict as unresolved." 252480 252481 self selectedChangeWrapper clearChoice. 252482 self changed: #changes. 252483 self updateSource.! ! 252484 252485!PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 13:45'! 252486nextConflict 252487 "Answer the first conflict or, if the current selection is a conflict, 252488 the subsequent conflict." 252489 252490 |coll current index| 252491 current := self selectedChangeWrapper. 252492 coll := current isConflict 252493 ifTrue: [(self model 252494 copyFrom: (index := self model indexOf: current item) + 1 252495 to: self model size), 252496 (self model copyFrom: 1 to: index)] 252497 ifFalse: [self model]. 252498 ^coll detect: [:item | item isConflict] ifNone: [nil]! ! 252499 252500!PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 14:26'! 252501notAllConflictsResolved 252502 "Answer whether any conflicts are unresolved." 252503 252504 ^self model anySatisfy: [:item | item isConflict and: [item isResolved not]]! ! 252505 252506!PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/2/2009 13:03'! 252507selectNextConflict 252508 "Select the next conflict after the current selection, if any." 252509 252510 |next op def path| 252511 next := self nextConflict ifNil: [^self]. 252512 op := next operation. 252513 def := next remoteDefinition ifNil: [next localDefinition]. 252514 path := {#changes. #openPath}. 252515 def isMethodDefinition ifTrue: [path := path, {def fullClassName}]. 252516 path := path, {op shortSummary}. 252517 self changed: path! ! 252518 252519!PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 14:40'! 252520selectionIsConflict 252521 "Answer whether the currently selected change is a conflict." 252522 252523 ^self selectedChangeWrapper isNil 252524 ifTrue: [false] 252525 ifFalse: [self selectedChangeWrapper isConflict]! ! 252526 252527!PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2009 14:06'! 252528updateSource 252529 "Update the source difference morph." 252530 252531 |sel| 252532 sel := self selectedChangeWrapper. 252533 self diffMorph allowJoinClicks: (sel notNil and: [ 252534 sel isConflict and: [sel operation isModification]]). 252535 super updateSource. 252536 (sel isNil or: [sel isConflict not]) ifTrue: [^self]. 252537 sel localChosen 252538 ifTrue: [self diffMorph indicateSrc] 252539 ifFalse: [self diffMorph indicateDst]! ! 252540 252541!PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:46'! 252542useIncomingVersion 252543 "Mark the conflict as remote." 252544 252545 self selectedChangeWrapper chooseRemote. 252546 self changed: #changes. 252547 self updateSource! ! 252548PSMCPatchOperationWrapper subclass: #PSMCOrganizationChangeWrapper 252549 instanceVariableNames: '' 252550 classVariableNames: '' 252551 poolDictionaries: '' 252552 category: 'Polymorph-Tools-Diff'! 252553ComposableMorph subclass: #PSMCPatchMorph 252554 instanceVariableNames: 'diffMorph changeTree selectedChangeWrapper' 252555 classVariableNames: '' 252556 poolDictionaries: '' 252557 category: 'Polymorph-Tools-Diff'! 252558 252559!PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 1/29/2009 13:17'! 252560changeTree 252561 "Answer the value of changeTree" 252562 252563 ^ changeTree! ! 252564 252565!PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 1/29/2009 13:17'! 252566changeTree: anObject 252567 "Set the value of changeTree" 252568 252569 changeTree := anObject! ! 252570 252571!PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 11:56'! 252572diffMorph 252573 "Answer the value of diffMorph" 252574 252575 ^ diffMorph! ! 252576 252577!PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 11:56'! 252578diffMorph: anObject 252579 "Set the value of diffMorph" 252580 252581 diffMorph := anObject! ! 252582 252583!PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 11:58'! 252584selectedChange 252585 "Answer the selected change." 252586 252587 ^(self selectedChangeWrapper ifNil: [^nil]) operation! ! 252588 252589!PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 11:57'! 252590selectedChangeWrapper 252591 "Answer the selected change." 252592 252593 ^selectedChangeWrapper! ! 252594 252595!PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 11/1/2006 12:18'! 252596selectedChangeWrapper: aWrapper 252597 "Set the selected change." 252598 252599 selectedChangeWrapper := aWrapper. 252600 self 252601 changed: #selectedChangeWrapper; 252602 updateSource; 252603 changed: #compositeText! ! 252604 252605 252606!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/14/2009 12:45'! 252607browseClass 252608 "Browse the class of the selected item." 252609 252610 ToolSet default 252611 browse: self selectedChangeWrapper actualClass 252612 selector: self selectedMessageName! ! 252613 252614!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/14/2009 12:47'! 252615browseImplementors 252616 "Browse the method implementors." 252617 252618 self systemNavigation 252619 browseAllImplementorsOf: (self selectedMessageName ifNil: [^self])! ! 252620 252621!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/14/2009 12:47'! 252622browseSenders 252623 "Browse the method senders." 252624 252625 self systemNavigation 252626 browseAllCallsOn: (self selectedMessageName ifNil: [^self])! ! 252627 252628!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/14/2009 12:47'! 252629browseVersions 252630 "Browse the method versions." 252631 252632 ToolSet default 252633 browseVersionsOf: self selectedChangeWrapper actualClass 252634 selector: (self selectedMessageName ifNil: [^self])! ! 252635 252636!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'nice 8/27/2009 22:47'! 252637changes 252638 "Answer the changes tree roots." 252639 252640 |changes classes| 252641 self model ifNil: [^#()]. 252642 changes := OrderedCollection new. 252643 classes := Set new. 252644 self model do: [:o | 252645 (o definition isOrganizationDefinition or: [o targetClassName isNil]) 252646 ifTrue: [changes add: (o patchWrapper model: self model)] 252647 ifFalse: [(classes includes: o targetClassName) 252648 ifFalse: [classes add: o targetClassName. 252649 changes add: (PSMCClassChangeWrapper with: o targetClassName model: self model)]]]. 252650 ^changes! ! 252651 252652!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'nice 10/7/2009 01:24'! 252653changesMenu: m 252654 "Answer the changes menu." 252655 252656 |menu| 252657 menu := self newMenu 252658 addTitle: 'Changes' 252659 icon: MenuIcons smallCopyIcon. 252660 menu 252661 addToggle: 'Browse class...' translated 252662 target: self 252663 selector: #browseClass 252664 getStateSelector: nil 252665 enablementSelector: #selectionHasAcutalClass. 252666 menu lastItem 252667 font: self theme menuFont; 252668 icon: Browser taskbarIcon. 252669 menu addLine. 252670 menu 252671 addToggle: 'Versions...' translated 252672 target: self 252673 selector: #browseVersions 252674 getStateSelector: nil 252675 enablementSelector: #selectionIsMethodChange. 252676 menu lastItem 252677 font: self theme menuFont; 252678 icon: MenuIcons smallJustifiedIcon. 252679 menu 252680 addToggle: 'Senders...' translated 252681 target: self 252682 selector: #browseSenders 252683 getStateSelector: nil 252684 enablementSelector: #selectionIsMethodChange. 252685 menu lastItem 252686 font: self theme menuFont; 252687 icon: MenuIcons smallForwardIcon. 252688 menu 252689 addToggle: 'Implementors...' translated 252690 target: self 252691 selector: #browseImplementors 252692 getStateSelector: nil 252693 enablementSelector: #selectionIsMethodChange. 252694 menu lastItem 252695 font: self theme menuFont; 252696 icon: MenuIcons smallDoItIcon. 252697 menu 252698 addToggle: 'Install incoming version' translated 252699 target: self 252700 selector: #loadMethodSelection 252701 getStateSelector: nil 252702 enablementSelector: #selectionIsMethodChange. 252703 menu lastItem 252704 font: self theme menuFont; 252705 icon: MenuIcons smallUpdateIcon. 252706 ^menu! ! 252707 252708!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 12:02'! 252709compositeText 252710 "Answer the composite text based on the selection state 252711 of the joins." 252712 252713 ^self diffMorph compositeText! ! 252714 252715!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/29/2006 18:18'! 252716defaultTitle 252717 "Answer the default title label for the receiver." 252718 252719 ^'Changes' translated! ! 252720 252721!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:25'! 252722diffMorphClass 252723 "Answer a the class to use for a new diff morph." 252724 252725 ^DiffMorph! ! 252726 252727!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 13:16'! 252728initialize 252729 "Initialize the receiver." 252730 252731 super initialize. 252732 self diffMorph: self newDiffMorph. 252733 self changeTree: self newChangeTreeMorph. 252734 self 252735 changeProportionalLayout; 252736 addMorph: self changeTree 252737 fullFrame: (LayoutFrame fractions: (0@0 corner: 0.3@1)); 252738 addMorph: self diffMorph 252739 fullFrame: (LayoutFrame fractions: (0.3@0 corner: 1@1) 252740 offsets: (ProportionalSplitterMorph splitterWidth @ 0 corner: 0@0)); 252741 addPaneSplitters! ! 252742 252743!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'nice 10/7/2009 01:21'! 252744loadMethodSelection 252745 "Install the selected change" 252746 252747 self selectedChange ifNil: [ ^self ]. 252748 self selectedChange definition load.! ! 252749 252750!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 11:08'! 252751model: aCollection 252752 "Set the model and update the window." 252753 252754 super model: aCollection. 252755 self changed: #changes! ! 252756 252757!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 15:33'! 252758newChangeTreeMorph 252759 "Answer a new morph for the tree of changes." 252760 252761 ^(self 252762 newTreeFor: self 252763 list: #changes 252764 selected: #selectedChangeWrapper 252765 changeSelected: #selectedChangeWrapper:) 252766 getMenuSelector: #changesMenu:! ! 252767 252768!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:25'! 252769newDiffMorph 252770 "Answer a new morph for the source difference." 252771 252772 ^self diffMorphClass new 252773 borderStyle: (BorderStyle inset width: 1); 252774 font: self theme statusFont; 252775 addDependent: self; 252776 yourself! ! 252777 252778!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 15:45'! 252779perform: selector orSendTo: otherTarget 252780 "Selector was just chosen from a menu by a user. If can respond, then 252781perform it on myself. If not, send it to otherTarget, presumably the 252782editPane from which the menu was invoked." 252783 252784 (self respondsTo: selector) 252785 ifTrue: [^ self perform: selector] 252786 ifFalse: [^ otherTarget perform: selector]! ! 252787 252788!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 15:52'! 252789selectedMessageName 252790 "Answer the method selector or nil if no method change 252791 is selected.." 252792 252793 ^self selectionIsMethodChange 252794 ifTrue: [self selectedChange definition selector] 252795 ! ! 252796 252797!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/1/2009 13:19'! 252798selectionHasAcutalClass 252799 "Answer whether the currently selected change has an actual 252800 class in the image." 252801 252802 ^self selectedChangeWrapper actualClass notNil! ! 252803 252804!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 15:40'! 252805selectionIsMethodChange 252806 "Answer whether the currently selected change is for a method." 252807 252808 ^self selectedChange isNil 252809 ifTrue: [false] 252810 ifFalse: [self selectedChange definition isMethodDefinition]! ! 252811 252812!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 15:30'! 252813update: aspect 252814 "A join has probably changed its selection state." 252815 252816 super update: aspect. 252817 aspect == #selectedDifferences 252818 ifTrue: [self changed: #compositeText]! ! 252819 252820!PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/14/2009 13:28'! 252821updateSource 252822 "Update the source difference morph." 252823 252824 |sel| 252825 sel := self selectedChange. 252826 sel isNil 252827 ifTrue: [self diffMorph 252828 from: '' 252829 to: ''] 252830 ifFalse: [self diffMorph 252831 from: sel diffFromSource 252832 to: sel diffToSource 252833 contextClass: (sel isClassPatch ifTrue: [nil] ifFalse: [sel targetClass])]! ! 252834 252835"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 252836 252837PSMCPatchMorph class 252838 instanceVariableNames: ''! 252839 252840!PSMCPatchMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 11:08'! 252841forPatch: aPatch 252842 "Answer a new instance of the receiver 252843 with the given patch as the model." 252844 252845 ^ self new model: aPatch operations! ! 252846 252847!PSMCPatchMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 2/3/2009 13:12'! 252848initialize 252849 "Set up extra diff preferences here." 252850 252851 Preferences 252852 addPreference: #useNewDiffToolsForMC 252853 categories: #(browsing) 252854 default: true 252855 balloonHelp: 'When enabled the Polymorph diff tools will be used with Monticello. When diabled, the original tools are used.' translated! ! 252856 252857!PSMCPatchMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 4/17/2007 17:51'! 252858taskbarIcon 252859 "Answer the icon for the receiver in a task bar." 252860 252861 ^MenuIcons smallForwardIcon! ! 252862PSMCChangeWrapper subclass: #PSMCPatchOperationWrapper 252863 instanceVariableNames: '' 252864 classVariableNames: '' 252865 poolDictionaries: '' 252866 category: 'Polymorph-Tools-Diff'! 252867 252868!PSMCPatchOperationWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 11:44'! 252869asString 252870 "Answer the method name." 252871 252872 ^self item shortSummary! ! 252873 252874!PSMCPatchOperationWrapper methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 12:00'! 252875operation 252876 "Answer the pacth operation for the receiver or nil if none." 252877 252878 ^self item! ! 252879PluggableListSpec subclass: #PSPluggableListSpec 252880 instanceVariableNames: 'icon action' 252881 classVariableNames: '' 252882 poolDictionaries: '' 252883 category: 'Polymorph-ToolBuilder-Kernel'! 252884 252885!PSPluggableListSpec methodsFor: 'accessing' stamp: 'gvc 1/8/2007 17:19'! 252886action 252887 "Answer the value of action" 252888 252889 ^ action! ! 252890 252891!PSPluggableListSpec methodsFor: 'accessing' stamp: 'gvc 1/8/2007 17:19'! 252892action: anObject 252893 "Set the value of action" 252894 252895 action := anObject! ! 252896 252897!PSPluggableListSpec methodsFor: 'accessing' stamp: 'gvc 1/8/2007 17:19'! 252898icon 252899 "Answer the value of icon" 252900 252901 ^ icon! ! 252902 252903!PSPluggableListSpec methodsFor: 'accessing' stamp: 'gvc 1/8/2007 17:19'! 252904icon: anObject 252905 "Set the value of icon" 252906 252907 icon := anObject! ! 252908MorphicToolBuilder subclass: #PSToolBuilder 252909 instanceVariableNames: '' 252910 classVariableNames: '' 252911 poolDictionaries: '' 252912 category: 'Polymorph-ToolBuilder-Morphic'! 252913 252914!PSToolBuilder methodsFor: 'as yet unclassified' stamp: 'gvc 1/8/2007 18:09'! 252915buildPluggableList: aSpec 252916 "Build an appropriate pluggable list." 252917 252918 | widget | 252919 aSpec icon 252920 ifNil: [widget := super buildPluggableList: aSpec] 252921 ifNotNil: [widget := PluggableIconListMorph new 252922 getIconSelector: aSpec icon; 252923 on: aSpec model 252924 list: aSpec list 252925 selected: aSpec getIndex 252926 changeSelected: aSpec setIndex 252927 menu: aSpec menu 252928 keystroke: aSpec keyPress. 252929 self register: widget id: aSpec name. 252930 widget autoDeselect: aSpec autoDeselect. 252931 self setFrame: aSpec frame in: widget. 252932 parent ifNotNil:[self add: widget to: parent]. 252933 panes ifNotNil:[aSpec list ifNotNil:[panes add: aSpec list]]]. 252934 widget doubleClickSelector: aSpec action. 252935 ^widget! ! 252936 252937!PSToolBuilder methodsFor: 'as yet unclassified' stamp: 'gvc 3/14/2007 15:31'! 252938buildPluggablePanel: aSpec 252939 "Build a pluggable panel (aka button row!!)." 252940 252941 | widget children | 252942 widget := PluggableThemedPanelMorph new. 252943 self register: widget id: aSpec name. 252944 widget model: aSpec model. 252945 widget fillStyle: widget normalFillStyle. 252946 widget clipSubmorphs: true. 252947 children := aSpec children. 252948 children isSymbol ifTrue:[ 252949 widget getChildrenSelector: children. 252950 widget update: children. 252951 children := #(). 252952 ]. 252953 self buildAll: children in: widget. 252954 self setFrame: aSpec frame in: widget. 252955 parent ifNotNil:[self add: widget to: parent]. 252956 self setLayout: aSpec layout in: widget. 252957 ^widget! ! 252958 252959!PSToolBuilder methodsFor: 'as yet unclassified' stamp: 'gvc 1/9/2007 13:34'! 252960buildPluggableWindow: aSpec 252961 | widget children label | 252962 aSpec layout == #proportional ifFalse:[ 252963 "This needs to be implemented - probably by adding a single pane and then the rest" 252964 ^self error: 'Not implemented'. 252965 ]. 252966 widget := PluggableStandardWindow new. 252967 self register: widget id: aSpec name. 252968 widget model: aSpec model. 252969 (label := aSpec label) ifNotNil:[ 252970 label isSymbol 252971 ifTrue:[widget getLabelSelector: label] 252972 ifFalse:[widget setLabel: label]]. 252973 children := aSpec children. 252974 children isSymbol ifTrue:[ 252975 widget getChildrenSelector: children. 252976 widget update: children. 252977 children := #(). 252978 ]. 252979 widget closeWindowSelector: aSpec closeAction. 252980 panes := OrderedCollection new. 252981 self buildAll: children in: widget. 252982 aSpec extent ifNotNil:[widget extent: aSpec extent]. 252983 widget setUpdatablePanesFrom: panes. 252984 ^widget! ! 252985 252986!PSToolBuilder methodsFor: 'as yet unclassified' stamp: 'gvc 1/8/2007 17:39'! 252987pluggableListSpec 252988 "Answer the spec supporting an action selector (doubleclick)." 252989 252990 ^PSPluggableListSpec! ! 252991MorphicUIManager subclass: #PSUIManager 252992 instanceVariableNames: '' 252993 classVariableNames: '' 252994 poolDictionaries: '' 252995 category: 'Polymorph-ToolBuilder-Morphic'! 252996 252997!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2007 14:21'! 252998chooseColor 252999 "Answer the user choice of a colour." 253000 253001 ^self 253002 chooseColor: Color black 253003 title: nil! ! 253004 253005!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2007 14:21'! 253006chooseColor: aColor 253007 "Answer the user choice of a colour." 253008 253009 ^self 253010 chooseColor: aColor 253011 title: nil! ! 253012 253013!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2007 14:20'! 253014chooseColor: aColor title: label 253015 "Answer the user choice of a colour." 253016 253017 ^UITheme current 253018 chooseColorIn: self modalMorph 253019 title: (label ifNil: ['Choose Color' translated]) 253020 color: aColor! ! 253021 253022!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 12:38'! 253023chooseDirectory: label from: dir 253024 "Answer the user choice of a directory." 253025 253026 ^UITheme current 253027 chooseDirectoryIn: self modalMorph 253028 title: (label ifNil: ['Choose Directory' translated]) 253029 path: (dir ifNotNil: [dir pathName])! ! 253030 253031!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 10/4/2007 13:29'! 253032chooseFileMatching: patterns label: label 253033 "Let the user choose a file matching the given patterns" 253034 253035 ^UITheme current 253036 chooseFileNameIn: self modalMorph 253037 title: (label ifNil: ['Choose File' translated]) 253038 extensions: patterns 253039 path: nil 253040 preview: false! ! 253041 253042!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2007 14:01'! 253043chooseFont 253044 "Answer the user choice of a font." 253045 253046 ^self chooseFont: nil! ! 253047 253048!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2007 14:01'! 253049chooseFont: aFontOrNil 253050 "Answer the user choice of a font." 253051 253052 ^self 253053 chooseFont: aFontOrNil 253054 title: nil! ! 253055 253056!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2007 14:00'! 253057chooseFont: aFontOrNil title: label 253058 "Answer the user choice of a font." 253059 253060 ^UITheme current 253061 chooseFontIn: self modalMorph 253062 title: (label ifNil: ['Choose Font' translated]) 253063 font: aFontOrNil! ! 253064 253065!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 2/6/2009 13:00'! 253066chooseFrom: aList lines: linesArray message: messageString title: aString 253067 "Choose an item from the given list. Answer the selected item." 253068 253069 ^(self 253070 chooseFrom: aList 253071 values: nil 253072 lines: linesArray 253073 message: messageString 253074 title: aString) ifNil: [0]! ! 253075 253076!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 1/15/2007 16:34'! 253077chooseFrom: aList lines: linesArray title: aString 253078 "Choose an item from the given list. Answer the index of the selected item." 253079 253080 ^(self 253081 chooseFrom: aList 253082 values: nil 253083 lines: linesArray 253084 title: aString) ifNil: [0]! ! 253085 253086!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 2/6/2009 12:36'! 253087chooseFrom: labelList values: valueList lines: linesArray message: messageString title: aString 253088 "Choose an item from the given list. Answer the selected item." 253089 253090 ^UITheme current 253091 chooseIn: self modalMorph 253092 title: aString 253093 message: messageString 253094 labels: labelList 253095 values: valueList 253096 lines: linesArray! ! 253097 253098!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 12:38'! 253099chooseFrom: labelList values: valueList lines: linesArray title: aString 253100 "Choose an item from the given list. Answer the selected item." 253101 253102 ^UITheme current 253103 chooseIn: self modalMorph 253104 title: aString 253105 labels: labelList 253106 values: valueList 253107 lines: linesArray! ! 253108 253109!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 3/30/2009 16:46'! 253110confirm: aStringOrText 253111 "Put up a question dialog (without cancel) with the text queryString. 253112 Answer true if the response is yes, false if no. 253113 This is a modal question--the user must respond yes or no." 253114 253115 (ProvideAnswerNotification signal: aStringOrText) ifNotNilDo: [:answer | 253116 ^answer]. 253117 ^UITheme current 253118 questionWithoutCancelIn: self modalMorph 253119 text: aStringOrText 253120 title: 'Question' translated! ! 253121 253122!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 3/30/2009 16:46'! 253123confirm: aStringOrText orCancel: cancelBlock 253124 "Put up a question dialog (with cancel) with the text queryString. 253125 Answer true if the response is yes, false if no. 253126 Answer the value of the cancel block if cancelled. 253127 This is a modal question--the user must respond yes or no or cancel." 253128 253129 (ProvideAnswerNotification signal: aStringOrText) ifNotNilDo: [:answer | 253130 ^answer == #cancel ifTrue: [cancelBlock value] ifFalse: [answer]]. 253131 ^(UITheme current 253132 questionIn: self modalMorph 253133 text: aStringOrText 253134 title: 'Question' translated) ifNil: cancelBlock! ! 253135 253136!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 3/30/2009 16:47'! 253137confirm: queryString trueChoice: trueChoice falseChoice: falseChoice 253138 "Put up a yes/no menu with caption queryString. The actual wording for the two choices will be as provided in the trueChoice and falseChoice parameters. Answer true if the response is the true-choice, false if it's the false-choice. 253139 This is a modal question -- the user must respond one way or the other." 253140 253141 (ProvideAnswerNotification signal: queryString) ifNotNilDo: [:answer | 253142 ^answer]. 253143 ^UITheme current 253144 customQuestionIn: self modalMorph 253145 text: queryString 253146 yesText: trueChoice 253147 noText: falseChoice 253148 title: 'Question' translated! ! 253149 253150!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 3/30/2009 16:44'! 253151inform: aStringOrText 253152 "Display a message for the user to read and then dismiss." 253153 253154 (ProvideAnswerNotification signal: aStringOrText) ifNotNilDo: [:answer | 253155 ^true]. 253156 ^UITheme current 253157 messageIn: self modalMorph 253158 text: aStringOrText 253159 title: 'Information' translated! ! 253160 253161!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 5/12/2009 13:01'! 253162informUserDuring: aBlock 253163 "Display a message as progress during execution of the given block." 253164 "UIManager default informUserDuring: [:bar| 253165 #('one' 'two' 'three') do: [:info| 253166 bar value: info. 253167 1 to: 100 do: [:v | 253168 bar value: v. 253169 (Delay forMilliseconds: 20) wait]]]" 253170 253171 self 253172 displayProgress: '' 253173 at: Sensor cursorPoint 253174 from: 1 to: 100 253175 during: [:bar | aBlock value: bar]! ! 253176 253177!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 12/2/2008 16:35'! 253178modalMorph 253179 "Answer the morph that should be used to handle modality." 253180 253181 |sender receiver foundWorld| 253182 sender := thisContext sender. 253183 foundWorld := false. 253184 [foundWorld or: [sender isNil]] whileFalse: [ 253185 receiver := sender receiver. 253186 ((receiver isKindOf: TheWorldMainDockingBar) or: [ 253187 ((receiver isKindOf: TheWorldMenu) or: [sender selector = #putUpWorldMenu:]) or: [ 253188 receiver == World and: [sender selector == #handleEvent: or: [sender selector == #findWindow:]]]]) 253189 ifTrue: [ foundWorld := true] 253190 ifFalse: [sender := sender sender]]. 253191 foundWorld ifTrue: [^receiver world ifNil: [World]]. 253192 ^SystemWindow topWindow ifNil: [World]! ! 253193 253194!PSUIManager methodsFor: 'as yet unclassified' stamp: 'DamienCassou 9/8/2009 15:22'! 253195multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight 253196 "Create a multi-line instance of me whose question is queryString with 253197 the given initial answer. Invoke it centered at the given point, and 253198 answer the string the user accepts. Answer nil if the user cancels. An 253199 empty string returned means that the ussr cleared the editing area and 253200 then hit 'accept'. Because multiple lines are invited, we ask that the user 253201 use the ENTER key, or (in morphic anyway) hit the 'accept' button, to 253202 submit; that way, the return key can be typed to move to the next line." 253203 253204 (ProvideAnswerNotification signal: queryString) ifNotNilDo: [:answer | 253205 ^answer == #default ifTrue: [defaultAnswer] ifFalse: [answer]]. 253206 ^(UITheme current 253207 textEditorIn: self modalMorph 253208 text: queryString 253209 title: 'Information Required' translated 253210 entryText: defaultAnswer 253211 entryHeight: answerHeight) 253212 ifNotNil: [:text | text asString]! ! 253213 253214!PSUIManager methodsFor: 'as yet unclassified' stamp: 'DamienCassou 9/8/2009 15:22'! 253215request: aStringOrText initialAnswer: defaultAnswer 253216 "Create an instance of me whose question is queryString with the given 253217 initial answer. Answer the string the user accepts. 253218 Answer the empty string if the user cancels. 253219 Allow for interception with a ProvideAnswerNotification handler." 253220 253221 (ProvideAnswerNotification signal: aStringOrText) ifNotNilDo: [:answer | 253222 ^answer == #default ifTrue: [defaultAnswer] ifFalse: [answer]]. 253223 ^(UITheme current 253224 textEntryIn: self modalMorph 253225 text: aStringOrText 253226 title: 'Information Required' translated 253227 entryText: defaultAnswer)! ! 253228 253229!PSUIManager methodsFor: 'as yet unclassified' stamp: 'gvc 9/11/2009 11:50'! 253230requestPassword: aStringOrText 253231 "Request for a password. 253232 Allow for interception with a ProvideAnswerNotification handler. 253233 Answer nil if the user cancels." 253234 253235 (ProvideAnswerNotification signal: aStringOrText) ifNotNilDo: [:answer | 253236 ^answer == #default ifTrue: [''] ifFalse: [answer]]. 253237 ^UITheme current 253238 passwordEntryIn: self modalMorph 253239 text: aStringOrText 253240 title: 'Password Required' translated 253241 entryText: ''! ! 253242Object subclass: #PackageInfo 253243 instanceVariableNames: 'packageName methodCategoryPrefix' 253244 classVariableNames: '' 253245 poolDictionaries: '' 253246 category: 'PackageInfo-Base'! 253247!PackageInfo commentStamp: '<historical>' prior: 0! 253248Subclass this class to create new Packages.! 253249 253250 253251!PackageInfo methodsFor: 'comparing' stamp: 'avi 10/11/2003 14:20'! 253252hash 253253 ^ packageName hash! ! 253254 253255!PackageInfo methodsFor: 'comparing' stamp: 'avi 10/11/2003 00:09'! 253256= other 253257 ^ other species = self species and: [other packageName = self packageName]! ! 253258 253259 253260!PackageInfo methodsFor: 'dependencies' stamp: 'ab 11/18/2002 01:16'! 253261externalCallers 253262 ^ self 253263 externalRefsSelect: [:literal | literal isKindOf: Symbol] 253264 thenCollect: [:l | l].! ! 253265 253266!PackageInfo methodsFor: 'dependencies' stamp: 'Henrik Sperre Johansen 7/10/2009 10:31'! 253267externalClasses 253268 | myClasses | 253269 myClasses := self classesAndMetaClasses asSet. 253270 ^ Array streamContents: 253271 [:s | 253272 ProtoObject withAllSubclassesDo: 253273 [:class | 253274 (myClasses includes: class) ifFalse: [s nextPut: class]]]! ! 253275 253276!PackageInfo methodsFor: 'dependencies' stamp: 'stephaneducasse 2/4/2006 20:40'! 253277externalRefsSelect: selBlock thenCollect: colBlock 253278 | pkgMethods dependents refs extMethods otherClasses otherMethods classNames | 253279 253280 classNames := self classes collect: [:c | c name]. 253281 extMethods := self extensionMethods collect: [:mr | mr methodSymbol]. 253282 otherClasses := self externalClasses difference: self externalSubclasses. 253283 otherMethods := otherClasses gather: [:c | c selectors]. 253284 pkgMethods := self methods asSet collect: [:mr | mr methodSymbol]. 253285 pkgMethods removeAllFoundIn: otherMethods. 253286 253287 dependents := Set new. 253288 otherClasses do: [:c | 253289 c selectorsAndMethodsDo: 253290 [:sel :compiled | 253291 (extMethods includes: sel) ifFalse: 253292 [refs := compiled literals select: selBlock thenCollect: colBlock. 253293 refs do: [:ea | 253294 ((classNames includes: ea) or: [pkgMethods includes: ea]) 253295 ifTrue: [dependents add: (self referenceForMethod: sel ofClass: c) -> ea]]]]]. 253296 ^ dependents! ! 253297 253298!PackageInfo methodsFor: 'dependencies' stamp: 'stephaneducasse 2/4/2006 20:40'! 253299externalSubclasses 253300 | pkgClasses subClasses | 253301 pkgClasses := self classes. 253302 subClasses := Set new. 253303 pkgClasses do: [:c | subClasses addAll: (c allSubclasses)]. 253304 ^ subClasses difference: pkgClasses 253305! ! 253306 253307!PackageInfo methodsFor: 'dependencies' stamp: 'ab 11/18/2002 01:15'! 253308externalUsers 253309 ^ self 253310 externalRefsSelect: [:literal | literal isVariableBinding] 253311 thenCollect: [:l | l key]! ! 253312 253313 253314!PackageInfo methodsFor: 'listing' stamp: 'ac 5/14/2003 16:23'! 253315classes 253316 ^(self systemCategories gather: 253317 [:cat | 253318 (SystemOrganization listAtCategoryNamed: cat) 253319 collect: [:className | Smalltalk at: className]]) 253320 sortBy: [:a :b | a className <= b className]! ! 253321 253322!PackageInfo methodsFor: 'listing' stamp: 'al 12/14/2005 18:06'! 253323classesAndMetaClasses 253324 | baseClasses | 253325 baseClasses := self classes. 253326 ^baseClasses , (baseClasses collect: [:c | c classSide])! ! 253327 253328!PackageInfo methodsFor: 'listing' stamp: 'ab 11/13/2002 01:23'! 253329coreMethods 253330 ^ self classesAndMetaClasses gather: [:class | self coreMethodsForClass: class]! ! 253331 253332!PackageInfo methodsFor: 'listing' stamp: 'al 3/1/2006 21:51'! 253333extensionClasses 253334 ^ self externalBehaviors reject: [:classOrTrait | (self extensionCategoriesForClass: classOrTrait) isEmpty]! ! 253335 253336!PackageInfo methodsFor: 'listing' stamp: 'al 3/1/2006 21:51'! 253337extensionMethods 253338 ^ self externalBehaviors gather: [:classOrTrait | self extensionMethodsForClass: classOrTrait]! ! 253339 253340!PackageInfo methodsFor: 'listing' stamp: 'stephaneducasse 2/4/2006 20:40'! 253341foreignClasses 253342 | s | 253343 s := IdentitySet new. 253344 self foreignSystemCategories 253345 do: [:c | (SystemOrganization listAtCategoryNamed: c) 253346 do: [:cl | 253347 | cls | 253348 cls := Smalltalk at: cl. 253349 s add: cls; 253350 add: cls class]]. 253351 ^ s! ! 253352 253353!PackageInfo methodsFor: 'listing' stamp: 'ab 12/3/2002 14:34'! 253354foreignSystemCategories 253355 ^ SystemOrganization categories 253356 reject: [:cat | self includesSystemCategory: cat] ! ! 253357 253358!PackageInfo methodsFor: 'listing' stamp: 'al 10/9/2005 20:00'! 253359methods 253360 ^ (self extensionMethods, self coreMethods) select: [:method | 253361 method isValid 253362 and: [method isLocalSelector] 253363 and: [method methodSymbol isDoIt not]]! ! 253364 253365!PackageInfo methodsFor: 'listing' stamp: 'avi 11/10/2003 15:35'! 253366overrideMethods 253367 ^ self extensionMethods select: [:ea | self isOvverideMethod: ea]! ! 253368 253369!PackageInfo methodsFor: 'listing' stamp: 'ab 11/14/2002 18:39'! 253370selectors 253371 ^ self methods collect: [:ea | ea methodSymbol]! ! 253372 253373!PackageInfo methodsFor: 'listing' stamp: 'ab 11/11/2002 21:51'! 253374systemCategories 253375 ^ SystemOrganization categories select: [:cat | self includesSystemCategory: cat]! ! 253376 253377 253378!PackageInfo methodsFor: 'modifying' stamp: 'stephaneducasse 2/4/2006 20:40'! 253379addCoreMethod: aMethodReference 253380 | category | 253381 category := self baseCategoryOfMethod: aMethodReference. 253382 aMethodReference actualClass organization 253383 classify: aMethodReference methodSymbol 253384 under: category 253385 suppressIfDefault: false! ! 253386 253387!PackageInfo methodsFor: 'modifying' stamp: 'stephaneducasse 2/4/2006 20:40'! 253388addExtensionMethod: aMethodReference 253389 | category | 253390 category := self baseCategoryOfMethod: aMethodReference. 253391 aMethodReference actualClass organization 253392 classify: aMethodReference methodSymbol 253393 under: self methodCategoryPrefix, '-', category! ! 253394 253395!PackageInfo methodsFor: 'modifying' stamp: 'StephaneDucasse 8/18/2009 23:17'! 253396addMethod: aMethodReference 253397 (self includesClass: aMethodReference actualClass) 253398 ifTrue: [self addCoreMethod: aMethodReference] 253399 ifFalse: [self addExtensionMethod: aMethodReference]! ! 253400 253401!PackageInfo methodsFor: 'modifying' stamp: 'stephaneducasse 2/4/2006 20:40'! 253402baseCategoryOfMethod: aMethodReference 253403 | oldCat oldPrefix tokens | 253404 oldCat := aMethodReference category. 253405 ({ 'as yet unclassified'. 'all' } includes: oldCat) ifTrue: [ oldCat := '' ]. 253406 tokens := oldCat findTokens: '*-' keep: '*'. 253407 253408 "Strip off any old prefixes" 253409 ((tokens at: 1 ifAbsent: [ '' ]) = '*') ifTrue: [ 253410 [ ((tokens at: 1 ifAbsent: [ '' ]) = '*') ] 253411 whileTrue: [ tokens removeFirst ]. 253412 oldPrefix := tokens removeFirst asLowercase. 253413 [ (tokens at: 1 ifAbsent: [ '' ]) asLowercase = oldPrefix ] 253414 whileTrue: [ tokens removeFirst ]. 253415 ]. 253416 253417 tokens isEmpty ifTrue: [^ 'as yet unclassified']. 253418 ^ String streamContents: 253419 [ :s | 253420 tokens 253421 do: [ :tok | s nextPutAll: tok ] 253422 separatedBy: [ s nextPut: $- ]]! ! 253423 253424!PackageInfo methodsFor: 'modifying' stamp: 'al 3/1/2006 21:42'! 253425externalBehaviors 253426 ^self externalClasses , self externalTraits! ! 253427 253428!PackageInfo methodsFor: 'modifying' stamp: 'al 3/1/2006 22:08'! 253429externalTraits 253430 | behaviors | 253431 253432 ^ Array streamContents: [:s | 253433 behaviors := self classesAndMetaClasses. 253434 Smalltalk allTraits do: [:trait | 253435 (behaviors includes: trait) ifFalse: [s nextPut: trait]. 253436 (behaviors includes: trait classSide) ifFalse: [s nextPut: trait classSide]]]. ! ! 253437 253438!PackageInfo methodsFor: 'modifying' stamp: 'avi 10/11/2003 15:14'! 253439removeMethod: aMethodReference! ! 253440 253441 253442!PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'! 253443categoryName 253444 |category| 253445 category := self class category. 253446 ^ (category endsWith: '-Info') 253447 ifTrue: [category copyUpToLast: $-] 253448 ifFalse: [category]! ! 253449 253450!PackageInfo methodsFor: 'naming' stamp: 'ab 10/16/2002 21:22'! 253451externalName 253452 ^ self packageName! ! 253453 253454!PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'! 253455methodCategoryPrefix 253456 ^ methodCategoryPrefix ifNil: [methodCategoryPrefix := '*', self packageName asLowercase]! ! 253457 253458!PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'! 253459packageName 253460 ^ packageName ifNil: [packageName := self categoryName]! ! 253461 253462!PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'! 253463packageName: aString 253464 packageName := aString! ! 253465 253466!PackageInfo methodsFor: 'naming' stamp: 'ab 10/28/2002 10:38'! 253467systemCategoryPrefix 253468 ^ self packageName! ! 253469 253470 253471!PackageInfo methodsFor: 'printing' stamp: 'stephane.ducasse 8/26/2008 20:43'! 253472printOn: aStream 253473 253474 super printOn: aStream. 253475 aStream nextPutAll: '(',self packageName,')'.! ! 253476 253477 253478!PackageInfo methodsFor: 'registering' stamp: 'avi 11/12/2003 23:12'! 253479register 253480 PackageOrganizer default registerPackage: self! ! 253481 253482 253483!PackageInfo methodsFor: 'testing' stamp: 'avi 3/9/2004 15:53'! 253484category: categoryName matches: prefix 253485 ^ categoryName notNil and: [categoryName = prefix or: [categoryName beginsWith: prefix, '-']]! ! 253486 253487!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:18'! 253488coreCategoriesForClass: aClass 253489 ^ aClass organization categories select: [:cat | (self isForeignClassExtension: cat) not]! ! 253490 253491!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:22'! 253492coreMethodsForClass: aClass 253493 ^ (aClass selectors difference: 253494 ((self foreignExtensionMethodsForClass: aClass) collect: [:r | r methodSymbol])) 253495 asArray collect: [:sel | self referenceForMethod: sel ofClass: aClass]! ! 253496 253497!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:20'! 253498extensionCategoriesForClass: aClass 253499 ^ aClass organization categories select: [:cat | self isYourClassExtension: cat]! ! 253500 253501!PackageInfo methodsFor: 'testing' stamp: 'avi 4/6/2004 15:16'! 253502extensionMethodsForClass: aClass 253503 ^ (self extensionCategoriesForClass: aClass) 253504 gather: [:cat | ((aClass organization listAtCategoryNamed: cat) ifNil: [#()]) 253505 collect: [:sel | self referenceForMethod: sel ofClass: aClass]]! ! 253506 253507!PackageInfo methodsFor: 'testing' stamp: 'dvf 10/18/2002 23:22'! 253508extensionMethodsFromClasses: classes 253509 ^classes 253510 gather: [:class | self extensionMethodsForClass: class]! ! 253511 253512!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:22'! 253513foreignExtensionCategoriesForClass: aClass 253514 ^ aClass organization categories select: [:cat | self isForeignClassExtension: cat]! ! 253515 253516!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! 253517foreignExtensionMethodsForClass: aClass 253518 ^ (self foreignExtensionCategoriesForClass: aClass) 253519 gather: [:cat | (aClass organization listAtCategoryNamed: cat) 253520 collect: [:sel | self referenceForMethod: sel ofClass: aClass]]! ! 253521 253522!PackageInfo methodsFor: 'testing' stamp: 'dvf 7/23/2003 14:08'! 253523includesClassNamed: aClassName 253524 ^ self includesSystemCategory: ((SystemOrganization categoryOfElement: aClassName) ifNil: [^false])! ! 253525 253526!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! 253527includesClass: aClass 253528 ^ self includesSystemCategory: aClass theNonMetaClass category! ! 253529 253530!PackageInfo methodsFor: 'testing' stamp: 'dvf 7/23/2003 14:06'! 253531includesMethodCategory: categoryName ofClassNamed: aClass 253532 ^ (self isYourClassExtension: categoryName) 253533 or: [(self includesClassNamed: aClass) 253534 and: [(self isForeignClassExtension: categoryName) not]]! ! 253535 253536!PackageInfo methodsFor: 'testing' stamp: 'dvf 9/17/2002 00:18'! 253537includesMethodCategory: categoryName ofClass: aClass 253538 ^ (self isYourClassExtension: categoryName) 253539 or: [(self includesClass: aClass) 253540 and: [(self isForeignClassExtension: categoryName) not]]! ! 253541 253542!PackageInfo methodsFor: 'testing' stamp: 'ab 11/14/2002 18:06'! 253543includesMethodReference: aMethodRef 253544 ^ self includesMethod: aMethodRef methodSymbol ofClass: aMethodRef actualClass! ! 253545 253546!PackageInfo methodsFor: 'testing' stamp: 'ab 12/5/2002 00:16'! 253547includesMethod: aSymbol ofClass: aClass 253548 aClass ifNil: [^ false]. 253549 ^ self 253550 includesMethodCategory: ((aClass organization categoryOfElement: aSymbol) 253551 ifNil: [' ']) 253552 ofClass: aClass! ! 253553 253554!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! 253555includesSystemCategory: categoryName 253556 ^ self category: categoryName matches: self systemCategoryPrefix! ! 253557 253558!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! 253559isForeignClassExtension: categoryName 253560 ^ categoryName first = $* and: [(self isYourClassExtension: categoryName) not]! ! 253561 253562!PackageInfo methodsFor: 'testing' stamp: 'avi 11/10/2003 15:42'! 253563isOverrideMethod: aMethodReference 253564 ^ aMethodReference category endsWith: '-override'! ! 253565 253566!PackageInfo methodsFor: 'testing' stamp: 'avi 3/10/2004 12:37'! 253567isYourClassExtension: categoryName 253568 ^ categoryName notNil and: [self category: categoryName asLowercase matches: self methodCategoryPrefix]! ! 253569 253570!PackageInfo methodsFor: 'testing' stamp: 'dvf 10/18/2002 23:22'! 253571outsideClasses 253572 ^ProtoObject withAllSubclasses difference: self classesAndMetaClasses! ! 253573 253574!PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:25'! 253575referenceForMethod: aSymbol ofClass: aClass 253576 ^ MethodReference new setStandardClass: aClass methodSymbol: aSymbol! ! 253577 253578"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 253579 253580PackageInfo class 253581 instanceVariableNames: ''! 253582 253583!PackageInfo class methodsFor: 'compatibility' stamp: 'avi 3/9/2004 16:28'! 253584default 253585 ^ self allPackages detect: [:ea | ea class = self] ifNone: [self new register]! ! 253586 253587 253588!PackageInfo class methodsFor: 'initialization' stamp: 'avi 2/18/2004 00:46'! 253589initialize 253590 self allSubclassesDo: [:ea | ea new register]! ! 253591 253592 253593!PackageInfo class methodsFor: 'packages access' stamp: 'Alexandre.Bergel 4/4/2009 09:26'! 253594allPackages 253595 ^PackageOrganizer default packages! ! 253596 253597!PackageInfo class methodsFor: 'packages access' stamp: 'avi 11/12/2003 23:00'! 253598named: aString 253599 ^ PackageOrganizer default packageNamed: aString ifAbsent: [(self new packageName: aString) register]! ! 253600 253601!PackageInfo class methodsFor: 'packages access' stamp: 'avi 11/11/2003 17:19'! 253602registerPackageName: aString 253603 ^ PackageOrganizer default registerPackageNamed: aString! ! 253604 253605 253606!PackageInfo class methodsFor: 'testing' stamp: 'Alexandre.Bergel 4/4/2009 09:29'! 253607existPackageNamed: aString 253608 " 253609 self existPackageNamed: 'PackageInfo' 253610 self existPackageNamed: 'Zork' 253611 " 253612 ^ (self allPackages anySatisfy: [:each | each packageName = aString]) 253613 ! ! 253614TestCase subclass: #PackageInfoTest 253615 instanceVariableNames: 'createdClasses' 253616 classVariableNames: '' 253617 poolDictionaries: '' 253618 category: 'Tests-PackageInfo'! 253619 253620!PackageInfoTest methodsFor: 'as yet unclassified' stamp: 'Alexandre.Bergel 4/4/2009 09:34'! 253621testKernelPackage 253622 | kernelPackage | 253623 "We make sure that the package Kernel exist" 253624 self assert: (self packageClass existPackageNamed: 'Kernel'). 253625 253626 kernelPackage := self packageClass named: 'Kernel'. 253627 253628 "Testing the name of the kernel" 253629 self assert: (kernelPackage packageName = 'Kernel'). 253630 self assert: (kernelPackage externalName = 'Kernel'). 253631 253632 "The kernel package includes the class Object" 253633 self assert: (kernelPackage includesClass: Object). 253634 self assert: (kernelPackage includesClassNamed: #Object). 253635 253636 "All methods defined in Object belongs to the package Kernel" 253637 self assert: ((kernelPackage coreMethodsForClass: Object) allSatisfy: [:m | m isKindOf: MethodReference]). 253638 self assert: ((Object methods collect: [:cm | cm methodReference]) 253639 includesAllOf: (kernelPackage coreMethodsForClass: Object)). 253640 253641 "However, all methods defined in the class do not belong to the package because of methods extensions" 253642 self deny: ((kernelPackage coreMethodsForClass: Object) 253643 includesAllOf: (Object methodDict values collect: [:cm | cm methodReference])). 253644 253645 "Check some methods defined in the package" 253646 self assert: (kernelPackage includesMethod: #at: ofClass: Object). 253647 self assert: (kernelPackage includesMethod: #at:put ofClass: Object). 253648 self assert: (kernelPackage includesMethod: #basicAt: ofClass: Object). 253649 253650 "Methods that belong to other packages do not belong to kernel" 253651 "browser and browseHierarchy belong to the Tools package" 253652 self deny: (kernelPackage includesMethod: #browse ofClass: Object). 253653 self deny: (kernelPackage includesMethod: #browseHierarchy ofClass: Object). 253654! ! 253655 253656 253657!PackageInfoTest methodsFor: 'running' stamp: 'AlexandreBergel 5/26/2008 22:23'! 253658setUp 253659 super setUp. 253660 createdClasses := nil! ! 253661 253662!PackageInfoTest methodsFor: 'running' stamp: 'AlexandreBergel 5/26/2008 22:29'! 253663tearDown 253664 super tearDown. 253665 createdClasses ifNotNil: [createdClasses do: [:cls | cls removeFromSystem ]]! ! 253666 253667 253668!PackageInfoTest methodsFor: 'util' stamp: 'AlexandreBergel 5/26/2008 22:31'! 253669packageClass 253670 ^ PackageInfo! ! 253671Object subclass: #PackageOrganizer 253672 instanceVariableNames: 'packages' 253673 classVariableNames: '' 253674 poolDictionaries: '' 253675 category: 'PackageInfo-Base'! 253676 253677!PackageOrganizer methodsFor: 'accessing' stamp: 'avi 11/12/2003 23:01'! 253678packageNames 253679 ^ packages keys! ! 253680 253681!PackageOrganizer methodsFor: 'accessing' stamp: 'avi 11/12/2003 23:01'! 253682packages 253683 ^ packages values! ! 253684 253685 253686!PackageOrganizer methodsFor: 'initializing' stamp: 'alain.plantec 5/28/2009 10:13'! 253687initialize 253688 super initialize. 253689 packages := Dictionary new! ! 253690 253691 253692!PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 23:01'! 253693registerPackage: aPackageInfo 253694 packages at: aPackageInfo packageName put: aPackageInfo. 253695 self changed: #packages; changed: #packageNames. 253696! ! 253697 253698!PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 21:08'! 253699registerPackageNamed: aString 253700 ^ self registerPackage: (PackageInfo named: aString)! ! 253701 253702!PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 23:08'! 253703unregisterPackage: aPackageInfo 253704 packages removeKey: aPackageInfo packageName ifAbsent: []. 253705 self changed: #packages; changed: #packageNames. 253706! ! 253707 253708!PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 21:10'! 253709unregisterPackageNamed: aString 253710 self unregisterPackage: (self packageNamed: aString ifAbsent: [^ self])! ! 253711 253712 253713!PackageOrganizer methodsFor: 'searching' stamp: 'oha 6/27/2008 15:38'! 253714allPackagesContainingUnimplementedCalls 253715 "Answer a Set of Packages that have classes which contain messages that 253716 have unimplemented calls" 253717 ^ (SystemNavigation default allClassesWithUnimplementedCalls keys collect: [:d| 253718 (self packageOfClass: d) packageName 253719 ]) . 253720! ! 253721 253722!PackageOrganizer methodsFor: 'searching' stamp: 'stephane.ducasse 9/4/2008 12:50'! 253723mostSpecificPackageOfClass: aClass 253724 ^ self mostSpecificPackageOfClass: aClass ifNone: [self noPackageFound]! ! 253725 253726!PackageOrganizer methodsFor: 'searching' stamp: 'stephane.ducasse 9/4/2008 12:51'! 253727mostSpecificPackageOfClass: aClass ifNone: aBlock 253728 253729 ^ self 253730 mostSpecificPackageIn: (self packages select: [ :each | each includesClass: aClass ]) 253731 ifNone: aBlock! ! 253732 253733!PackageOrganizer methodsFor: 'searching' stamp: 'stephane.ducasse 9/4/2008 12:50'! 253734mostSpecificPackageOfMethod: aMethodReference 253735 ^ self mostSpecificPackageOfMethod: aMethodReference ifNone: [self noPackageFound]! ! 253736 253737!PackageOrganizer methodsFor: 'searching' stamp: 'stephane.ducasse 9/4/2008 12:52'! 253738mostSpecificPackageOfMethod: aMethodReference ifNone: aBlock 253739 253740 ^ self 253741 mostSpecificPackageIn: (self packages select: [ :each | each includesMethodReference: aMethodReference ]) 253742 ifNone: aBlock! ! 253743 253744!PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:21'! 253745noPackageFound 253746 self error: 'No package found'! ! 253747 253748!PackageOrganizer methodsFor: 'searching' stamp: 'avi 11/12/2003 23:08'! 253749packageNamed: aString ifAbsent: errorBlock 253750 ^ packages at: aString ifAbsent: errorBlock! ! 253751 253752!PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:21'! 253753packageOfClass: aClass 253754 ^ self packageOfClass: aClass ifNone: [self noPackageFound]! ! 253755 253756!PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:22'! 253757packageOfClass: aClass ifNone: errorBlock 253758 ^ self packages detect: [:ea | ea includesClass: aClass] ifNone: errorBlock! ! 253759 253760!PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:21'! 253761packageOfMethod: aMethodReference 253762 ^ self packageOfMethod: aMethodReference ifNone: [self noPackageFound]! ! 253763 253764!PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:22'! 253765packageOfMethod: aMethodReference ifNone: errorBlock 253766 ^ self packages detect: [:ea | ea includesMethodReference: aMethodReference] ifNone: errorBlock! ! 253767 253768 253769!PackageOrganizer methodsFor: 'private' stamp: 'stephane.ducasse 9/4/2008 12:51'! 253770mostSpecificPackageIn: aCollection ifNone: aBlock 253771 aCollection isEmpty 253772 ifTrue: [ ^ aBlock value ]. 253773 ^ (aCollection asArray 253774 sort: [ :a :b | a packageName size > b packageName size ]) 253775 first! ! 253776 253777"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 253778 253779PackageOrganizer class 253780 instanceVariableNames: 'default'! 253781 253782!PackageOrganizer class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:40'! 253783default 253784 ^ default ifNil: [default := self new]! ! 253785 253786!PackageOrganizer class methodsFor: 'as yet unclassified' stamp: 'avi 10/13/2003 15:25'! 253787new 253788 ^ self basicNew initialize! ! 253789Object subclass: #PackageServices 253790 instanceVariableNames: '' 253791 classVariableNames: 'ServiceClasses' 253792 poolDictionaries: '' 253793 category: 'PackageInfo-Base'! 253794 253795!PackageServices methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 14:06'! 253796seeClassSide! ! 253797 253798"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 253799 253800PackageServices class 253801 instanceVariableNames: ''! 253802 253803!PackageServices class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 13:01'! 253804allServices 253805 ^ ServiceClasses gather: [:ea | ea services]! ! 253806 253807!PackageServices class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:40'! 253808initialize 253809 ServiceClasses := Set new! ! 253810 253811!PackageServices class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 12:59'! 253812register: aClass 253813 ServiceClasses add: aClass! ! 253814 253815!PackageServices class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 12:59'! 253816unregister: aClass 253817 ServiceClasses remove: aClass! ! 253818ImageMorph subclass: #PaintBoxColorPicker 253819 instanceVariableNames: 'currentColor locOfCurrent' 253820 classVariableNames: '' 253821 poolDictionaries: '' 253822 category: 'Morphic-Extras'! 253823!PaintBoxColorPicker commentStamp: 'JMM 9/13/2004 07:37' prior: 0! 253824A pop-up, 32-bit color palette used as part of a PaintBoxMorph. 253825! 253826 253827 253828!PaintBoxColorPicker methodsFor: 'accessing' stamp: 'jm 4/29/1998 20:07'! 253829currentColor 253830 253831 ^ currentColor 253832! ! 253833 253834!PaintBoxColorPicker methodsFor: 'accessing' stamp: 'jm 4/29/1998 20:18'! 253835currentColor: aColor 253836 "Force me to select the given color." 253837 253838 currentColor := aColor. 253839 locOfCurrent := nil. "remove the marker" 253840! ! 253841 253842 253843!PaintBoxColorPicker methodsFor: 'drawing' stamp: 'jm 4/29/1998 20:00'! 253844drawOn: aCanvas 253845 "Image plus circles for currently selected color." 253846 253847 | c | 253848 super drawOn: aCanvas. 253849 locOfCurrent ifNotNil: [ 253850 c := self ringColor. 253851 aCanvas 253852 fillOval: (Rectangle center: locOfCurrent + self topLeft extent: 9@9) 253853 color: Color transparent 253854 borderWidth: 1 253855 borderColor: c]. 253856! ! 253857 253858!PaintBoxColorPicker methodsFor: 'drawing' stamp: 'jm 4/29/1998 20:00'! 253859ringColor 253860 "Choose a color that contrasts with my current color. If that color isn't redish, return red. Otherwise, return green" 253861 253862 currentColor isTransparent ifTrue: [^ Color red]. 253863 currentColor red < 0.5 ifTrue: [^ Color red]. 253864 currentColor red > (currentColor green + (currentColor blue * 0.5)) 253865 ifTrue: [^ Color green] 253866 ifFalse: [^ Color red]. 253867! ! 253868 253869 253870!PaintBoxColorPicker methodsFor: 'event handling' stamp: 'ar 10/5/2000 16:01'! 253871endColorSelection: evt 253872 "Update current color and report it to paint box." 253873 253874 self selectColor: evt. 253875 "restore mouseLeave handling" 253876 self on: #mouseLeave send: #delete to: self. 253877! ! 253878 253879!PaintBoxColorPicker methodsFor: 'event handling' stamp: 'ar 10/25/2000 17:49'! 253880initMouseHandlers 253881 253882 self on: #mouseDown send: #startColorSelection: to: self. 253883 self on: #mouseMove send: #selectColor: to: self. 253884 self on: #mouseUp send: #endColorSelection: to: self. 253885 self on: #mouseLeave send: #delete to: self. 253886! ! 253887 253888!PaintBoxColorPicker methodsFor: 'event handling' stamp: 'JMM 9/13/2004 09:08'! 253889selectColor: evt 253890 "Update the receiver from the given event. Constrain locOfCurrent's center to lie within the color selection area. If it is partially in the transparent area, snap it entirely into it vertically." 253891 253892 | r | 253893 253894 locOfCurrent := evt cursorPoint - self topLeft. 253895 r := Rectangle center: locOfCurrent extent: 9 @ 9. 253896 locOfCurrent := locOfCurrent 253897 + (r amountToTranslateWithin: (8 @ 11 corner: (self image width-6) @ (self image height-6))). 253898 locOfCurrent x > (self image width-(12+7)) ifTrue: [locOfCurrent := (self image width - 12) @ locOfCurrent y]. "snap into grayscale" 253899 currentColor := locOfCurrent y < 19 253900 ifTrue: 253901 [locOfCurrent := locOfCurrent x @ 11. "snap into transparent" 253902 Color transparent] 253903 ifFalse: [image colorAt: locOfCurrent]. 253904 (owner isKindOf: PaintBoxMorph) 253905 ifTrue: [owner takeColorEvt: evt from: self]. 253906 self changed! ! 253907 253908!PaintBoxColorPicker methodsFor: 'event handling' stamp: 'jm 4/29/1998 21:21'! 253909startColorSelection: evt 253910 "Start color selection. Make me stay up as long as the mouse is down." 253911 253912 self on: #mouseLeave send: nil to: nil. 253913 self selectColor: evt. 253914! ! 253915 253916 253917!PaintBoxColorPicker methodsFor: 'initialization' stamp: 'RAA 8/15/2000 14:57'! 253918beStatic 253919 253920 "an aid for Nebraska: make the color chart a static image to reduce traffic" 253921 image isStatic ifFalse: [ 253922 image := image as: StaticForm 253923 ].! ! 253924 253925!PaintBoxColorPicker methodsFor: 'initialization' stamp: 'jm 4/29/1998 21:24'! 253926initialize 253927 253928 super initialize. 253929 currentColor := Color black. 253930 locOfCurrent := nil. 253931 self initMouseHandlers. 253932! ! 253933ImageMorph subclass: #PaintBoxMorph 253934 instanceVariableNames: 'action tool currentCursor thumbnail currentColor currentBrush colorMemory colorPatch stampHolder rotationTabForm scaleTabForm colorMemoryThin brushes focusMorph weakDependents recentColors' 253935 classVariableNames: 'AllOffImage AllOnImage AllPressedImage ColorChart OriginalBounds Prototype RecentColors' 253936 poolDictionaries: '' 253937 category: 'Morphic-Extras'! 253938 253939!PaintBoxMorph methodsFor: 'actions' stamp: 'laza 3/24/2000 17:58'! 253940action 253941 ^ action ! ! 253942 253943!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:35'! 253944actionCursor 253945 "Return the cursor to use with this painting action/tool. Offset of the form must be set." 253946 253947 ^self 253948 cursorFor: action 253949 oldCursor: currentCursor 253950 currentNib: self getNib 253951 color: currentColor 253952! ! 253953 253954!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:03'! 253955brush: brushButton action: aSelector nib: aMask evt: evt 253956 "Set the current tool and action for the paintBox. " 253957 253958 currentBrush 253959 ifNotNil: [currentBrush == brushButton ifFalse: [currentBrush state: #off]]. 253960 currentBrush := brushButton. "A ThreePhaseButtonMorph" 253961 253962 "currentBrush state: #on. already done" 253963 "aSelector is like brush3:. Don't save it. Can always say (currentBrush arguments at: 2) 253964 aMask is the brush shape. Don't save it. Can always say (currentBrush arguments at: 3)" 253965 self notifyWeakDependentsWith: { 253966 #currentNib. 253967 evt. 253968 currentBrush arguments third}. 253969 self brushable ifFalse: [self setAction: #paint: evt: evt] "User now thinking of painting"! ! 253970 253971!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 10/19/97 11:12'! 253972brushable 253973 "Return true if the current tool uses a brush." 253974 ^ (#("non-brushable" eyedropper: fill: pickup: stamp:) indexOf: action) = 0! ! 253975 253976!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:34'! 253977clear: clearButton with: clearSelector evt: evt 253978 253979 | ss | 253980 (ss := self focusMorph) 253981 ifNotNil: [ss clearPainting: self] 253982 ifNil: [self notCurrentlyPainting]. 253983 clearButton state: #off.! ! 253984 253985!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/15/97 13:35'! 253986colorable 253987 "Return true if the current tool uses a color." 253988 ^ (#("These use no color" erase: eyedropper: "fill: does" pickup: stamp:) indexOf: action) = 0! ! 253989 253990!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/17/2000 17:06'! 253991currentColor: aColor evt: evt 253992 "Accept a color from the outside. (my colorMemoryMorph must call takeColorEvt: evt from: colorPicker instead)" 253993 253994 currentColor := aColor. 253995 colorMemory currentColor: aColor. 253996 self notifyWeakDependentsWith: {#currentColor. evt. currentColor}. 253997 self showColor. 253998 self colorable ifFalse: [self setAction: #paint: evt: evt]. "User now thinking of painting"! ! 253999 254000!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:37'! 254001cursorFor: anAction oldCursor: oldCursor currentNib: aNibForm color: aColor 254002 "Return the cursor to use with this painting action/tool. Offset of the 254003 form must be set." 254004 254005 | ff width co larger c box | 254006 254007 anAction == #paint: 254008 ifTrue: ["Make a cursor from the brush and the color" 254009 width := aNibForm width. 254010 c := self ringColorFor: aColor. 254011 co := oldCursor offset - (width // 4 @ 34 - (width // 6)) min: 0 @ 0. 254012 larger := width negated + 10 @ 0 extent: oldCursor extent + (width @ width). 254013 ff := oldCursor copy: larger. 254014 ff colors at: 1 put: Color transparent. 254015 ff colors at: 2 put: Color transparent. 254016 ff offset: co - (width @ width // 2). 254017 ff getCanvas 254018 fillOval: (Rectangle center: ff offset negated extent: width @ width) 254019 color: Color transparent 254020 borderWidth: 1 254021 borderColor: c. 254022 ^ ff]. 254023 anAction == #erase: 254024 ifTrue: ["Make a cursor from the cursor and the color" 254025 width := aNibForm width. 254026 co := oldCursor offset + (width // 2 @ 4) min: 0 @ 0. 254027 larger := 0 @ 0 extent: oldCursor extent + (width @ width). 254028 ff := oldCursor copy: larger. 254029 ff offset: co - (width @ width // 2). 254030 ff 254031 fill: (box := co negated extent: width @ width) 254032 fillColor: (Color r: 0.5 g: 0.5 b: 1.0). 254033 ff 254034 fill: (box insetBy: 1 @ 1) 254035 fillColor: Color transparent. 254036 ^ ff]. 254037 ^ oldCursor! ! 254038 254039!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:03'! 254040deleteCurrentStamp: evt 254041 "The trash is telling us to delete the currently selected stamp" 254042 254043 (tool arguments second) == #stamp: 254044 ifTrue: 254045 [stampHolder remove: tool. 254046 self setAction: #paint: evt: evt] "no use stamping with a blank stamp"! ! 254047 254048!PaintBoxMorph methodsFor: 'actions' stamp: 'JMM 9/13/2004 09:47'! 254049eyedropper: aButton action: aSelector cursor: aCursor evt: evt 254050 "Take total control and pick up a color!!!!" 254051 254052 | pt feedbackColor delay | 254053 delay := Delay forMilliseconds: 10. 254054 aButton state: #on. 254055 tool ifNotNil: [tool state: #off]. 254056 currentCursor := aCursor. 254057 evt hand showTemporaryCursor: currentCursor 254058 hotSpotOffset: 6 negated @ 4 negated. 254059 "<<<< the form was changed a bit??" 254060 feedbackColor := Display colorAt: Sensor cursorPoint. 254061 colorMemory align: colorMemory bounds topRight 254062 with: colorMemoryThin bounds topRight. 254063 self addMorphFront: colorMemory. 254064 254065 "Full color picker" 254066 [Sensor anyButtonPressed] whileFalse: 254067 [pt := Sensor cursorPoint. 254068 "deal with the fact that 32 bit displays may have garbage in the 254069 alpha bits" 254070 feedbackColor := Display depth = 32 254071 ifTrue: 254072 [Color colorFromPixelValue: ((Display pixelValueAt: pt) bitOr: 4278190080) 254073 depth: 32] 254074 ifFalse: [Display colorAt: pt]. 254075 "the hand needs to be drawn" 254076 evt hand position: pt. 254077 currentColor ~= feedbackColor ifTrue: [ 254078 currentColor := feedbackColor. 254079 self showColor ]. 254080 self world displayWorldSafely. 254081 delay wait]. 254082 254083 "Now wait for the button to be released." 254084 [Sensor anyButtonPressed] whileTrue: 254085 [ pt := Sensor cursorPoint. 254086 "the hand needs to be drawn" 254087 evt hand position: pt. 254088 self world displayWorldSafely. 254089 delay wait]. 254090 254091 evt hand showTemporaryCursor: nil hotSpotOffset: 0 @ 0. 254092 self currentColor: feedbackColor evt: evt. 254093 colorMemory delete. 254094 tool ifNotNil: 254095 [tool state: #on. 254096 currentCursor := tool arguments third]. 254097 aButton state: #off 254098! ! 254099 254100!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/1/97 12:52'! 254101getColor 254102 ^ currentColor! ! 254103 254104!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:03'! 254105getNib 254106 ^currentBrush arguments third! ! 254107 254108!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/1/97 13:02'! 254109getSpecial 254110 ^ action "a selector like #paint:"! ! 254111 254112!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/21/2003 23:17'! 254113grabFromScreen: evt 254114 "Allow the user to grab a picture from the screen OUTSIDE THE PAINTING AREA and install it in a blank stamp. To get a stamp in the painting area, click on the stamp tool in a blank stamp." 254115 254116 "scroll to blank stamp" 254117 254118 | stampButton form | 254119 stampButton := stampHolder stampButtons first. 254120 [(stampHolder stampFormFor: stampButton) isNil] 254121 whileFalse: [stampHolder scroll: 1]. 254122 form := Form fromUser. 254123 tool state: #off. 254124 tool := stampHolder otherButtonFor: stampButton. 254125 stampHolder stampForm: form for: tool. "install it" 254126 stampButton state: #on. 254127 stampButton doButtonAction: evt. 254128 evt hand showTemporaryCursor: (focusMorph getCursorFor: evt)! ! 254129 254130!PaintBoxMorph methodsFor: 'actions' stamp: 'sw 8/29/2000 15:31'! 254131indicateColorUnderMouse 254132 "Track the mouse with the special eyedropper cursor, and accept whatever color is under the mouse as the currently-chosen color; reflect that choice in the feedback box, and return that color." 254133 254134 | pt feedbackColor | 254135 pt := Sensor cursorPoint. 254136 "deal with the fact that 32 bit displays may have garbage in the alpha bits" 254137 feedbackColor := Display depth = 32 254138 ifTrue: [ Color colorFromPixelValue: ((Display pixelValueAt: pt) bitOr: 16rFF000000) depth: 32] ifFalse: [Display colorAt: pt]. 254139 254140 self activeHand position: pt. 254141 self world displayWorldSafely. 254142 Display fill: colorPatch bounds fillColor: feedbackColor. 254143 ^ feedbackColor ! ! 254144 254145!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:48'! 254146keep: keepButton with: keepSelector evt: evt 254147 "Showing of the corrent palette (viewer or noPalette) is done by the block submitted to the SketchMorphEditor, see (EToyHand makeNewDrawing) and (SketchMorph editDrawingInWorld:forBackground:)." 254148 | ss | 254149 owner ifNil: [^ self]. 254150 keepButton ifNotNil: [keepButton state: #off]. 254151 (ss := self focusMorph) 254152 ifNotNil: [ss savePainting: self evt: evt] 254153 ifNil: 254154 [keepSelector == #silent ifTrue: [^ self]. 254155 self notCurrentlyPainting].! ! 254156 254157!PaintBoxMorph methodsFor: 'actions' stamp: 'sw 5/3/1998 18:22'! 254158notCurrentlyPainting 254159 self inform: 'You are not currently painting'! ! 254160 254161!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:04'! 254162pickup: actionButton action: aSelector cursor: aCursor evt: evt 254163 "Special version for pickup: and stamp:, because of these tests" 254164 254165 | ss picker old map stamper | 254166 self 254167 tool: actionButton 254168 action: aSelector 254169 cursor: aCursor 254170 evt: evt. 254171 aSelector == #stamp: 254172 ifTrue: 254173 [(stampHolder pickupButtons includes: actionButton) 254174 ifTrue: 254175 [stamper := stampHolder otherButtonFor: actionButton. 254176 ^self 254177 pickup: stamper 254178 action: #stamp: 254179 cursor: (stamper arguments third) 254180 evt: evt]. 254181 (stampHolder stampFormFor: actionButton) ifNil: 254182 ["If not stamp there, go to pickup mode" 254183 254184 picker := stampHolder otherButtonFor: actionButton. 254185 picker state: #on. 254186 ^self 254187 pickup: picker 254188 action: #pickup: 254189 cursor: (picker arguments third) 254190 evt: evt] 254191 ifNotNil: 254192 [old := stampHolder stampFormFor: actionButton. 254193 currentCursor := ColorForm extent: old extent depth: 8. 254194 old displayOn: currentCursor. 254195 map := Color indexedColors copy. 254196 map at: 1 put: Color transparent. 254197 currentCursor colors: map. 254198 currentCursor offset: currentCursor extent // -2. 254199 "Emphisize the stamp button" 254200 actionButton owner borderColor: (Color 254201 r: 0.65 254202 g: 0.599 254203 b: 0.8) "layoutMorph" "color: (Color r: 1.0 g: 0.645 b: 0.419);"]]. 254204 aSelector == #pickup: 254205 ifTrue: 254206 [ss := self focusMorph. 254207 ss ifNotNil: [currentCursor := aCursor] 254208 ifNil: 254209 [self notCurrentlyPainting. 254210 self setAction: #paint: evt: evt]]! ! 254211 254212!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/2/97 22:13'! 254213pickupForm: stampForm 254214 "Install the new picture in this stamp" 254215 254216 | stampButton | 254217 stampHolder stampForm: stampForm for: tool. 254218 stampButton := action == #pickup: 254219 ifTrue: [stampHolder otherButtonFor: tool] 254220 ifFalse: [tool]. "was a nil stampForm" 254221 stampButton state: #on. 254222 stampButton doButtonAction.! ! 254223 254224!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/17/2000 14:59'! 254225pickupForm: stampForm evt: evt 254226 "Install the new picture in this stamp" 254227 254228 | stampButton | 254229 stampHolder stampForm: stampForm for: tool. 254230 stampButton := action == #pickup: 254231 ifTrue: [stampHolder otherButtonFor: tool] 254232 ifFalse: [tool]. "was a nil stampForm" 254233 stampButton state: #on. 254234 stampButton doButtonAction: evt.! ! 254235 254236!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:40'! 254237plainCursor 254238 "Return the cursor to use with this painting action/tool. Offset of the form must be set." 254239 254240 ^currentCursor 254241! ! 254242 254243!PaintBoxMorph methodsFor: 'actions' stamp: 'ar 10/10/2000 16:38'! 254244plainCursor: aCursor event: anEvent 254245 "Set the cursor to use with this painting action/tool. Offset of the form must be set." 254246 254247 currentCursor := aCursor. 254248 anEvent hand showTemporaryCursor: aCursor. 254249 self notifyWeakDependentsWith: {#currentCursor. anEvent. currentCursor}.! ! 254250 254251!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:30'! 254252ringColor 254253 "Choose a color that contrasts with my current color. If that color isn't redish, return red. Otherwise, return green" 254254 254255 ^self ringColorFor: currentColor 254256! ! 254257 254258!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:29'! 254259ringColorFor: aColor 254260 "Choose a color that contrasts with my current color. If that color isn't redish, return red. Otherwise, return green" 254261 254262 aColor isTransparent ifTrue: [^ Color red]. 254263 aColor red < 0.5 ifTrue: [^ Color red]. 254264 aColor red > (aColor green + (aColor blue * 0.5)) 254265 ifTrue: [^ Color green] 254266 ifFalse: [^ Color red]. 254267! ! 254268 254269!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:44'! 254270scrollStamps: actionButton action: aSelector evt: evt 254271 "Move the stamps over" 254272 254273 aSelector == #prevStamp: 254274 ifTrue: [stampHolder scroll: -1] 254275 ifFalse: [stampHolder scroll: 1]. 254276 actionButton state: #off. 254277 action == #stamp: ifTrue: ["reselect the stamp and compute the cursor" 254278 self stampForm 254279 ifNil: [self setAction: #paint: evt: evt] 254280 ifNotNil: [tool doButtonAction: evt]]. 254281 ! ! 254282 254283!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/22/2000 11:57'! 254284setAction: aSelector evt: evt 254285 "Find this button and turn it on. Does not work for stamps or pickups" 254286 254287 | button | 254288 button := self submorphNamed: aSelector. 254289 254290 button ifNotNil: [ 254291 button state: #on. 254292 button doButtonAction: evt]. "select it!!"! ! 254293 254294!PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:04'! 254295showColor 254296 "Display the current color in all brushes, both on and off." 254297 254298 | offIndex onIndex center | 254299 currentColor ifNil: [^self]. 254300 "colorPatch color: currentColor. May delete later" 254301 (brushes isNil or: [brushes first owner ~~ self]) 254302 ifTrue: 254303 [brushes := OrderedCollection new. 254304 #(#brush1: #brush2: #brush3: #brush4: #brush5: #brush6:) 254305 do: [:sel | brushes addLast: (self submorphNamed: sel)]]. 254306 center := (brushes sixth) offImage extent // 2. 254307 offIndex := (brushes sixth) offImage pixelValueAt: center. 254308 onIndex := (brushes sixth) onImage pixelValueAt: center. 254309 brushes do: 254310 [:bb | 254311 bb offImage colors at: offIndex + 1 put: currentColor. 254312 bb offImage clearColormapCache. 254313 bb onImage colors at: onIndex + 1 put: currentColor. 254314 bb onImage clearColormapCache. 254315 bb invalidRect: bb bounds]. 254316 self invalidRect: (brushes first topLeft rect: brushes last bottomRight)! ! 254317 254318!PaintBoxMorph methodsFor: 'actions' stamp: 'ar 12/19/2000 19:16'! 254319showColorPalette: evt 254320 254321 | w box | 254322 self comeToFront. 254323 colorMemory align: colorMemory bounds topRight 254324 with: colorMemoryThin bounds topRight. 254325 "make sure color memory fits or else align with left" 254326 w := self world. 254327 box := self bounds: colorMemory fullBounds in: w. 254328 box left < 0 ifTrue:[ 254329 colorMemory align: colorMemory bounds topLeft 254330 with: colorMemoryThin bounds topLeft]. 254331 self addMorphFront: colorMemory.! ! 254332 254333!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/22/2000 11:58'! 254334stampCursorBeCursorFor: anAction 254335 "User just chose a stamp. Take that stamp picture and make it be the cursor for the tool named." 254336 "self stampCursorBeCursorFor: #star:. 254337 currentCursor offset: -9@-3. Has side effect on the saved cursor." 254338 254339 (self submorphNamed: anAction) arguments at: 3 put: currentCursor. 254340 "Already converted to 8 bits and in the right form"! ! 254341 254342!PaintBoxMorph methodsFor: 'actions' stamp: 'di 5/6/1998 21:08'! 254343stampDeEmphasize 254344 "Turn off an emphasized stamp. Was turned on in pickup:action:cursor:" 254345 254346 tool owner class == AlignmentMorph ifTrue: [ 254347 tool "actionButton" owner "layoutMorph" color: Color transparent; 254348 borderColor: Color transparent].! ! 254349 254350!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/2/97 14:02'! 254351stampForm 254352 "Return the selected stamp" 254353 254354 ^ stampHolder stampFormFor: tool. 254355! ! 254356 254357!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/17/97 11:47'! 254358stampHolder 254359 254360 ^ stampHolder! ! 254361 254362!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/17/97 11:48'! 254363stampHolder: newOne 254364 254365 stampHolder := newOne! ! 254366 254367!PaintBoxMorph methodsFor: 'actions' stamp: 'ar 9/23/2000 20:00'! 254368takeColor: aColor event: evt 254369 "Accept the given color programmatically" 254370 currentColor := aColor. 254371 self notifyWeakDependentsWith: {#currentColor. evt. currentColor}. 254372 self showColor. 254373 self colorable ifFalse: [self setAction: #paint: evt: evt]. "User now thinking of painting"! ! 254374 254375!PaintBoxMorph methodsFor: 'actions' stamp: 'ar 9/23/2000 20:39'! 254376takeColorEvt: evt from: colorPicker 254377 "Accept a new color from the colorMemory. Programs use currentColor: instead. Do not do this before the picker has a chance to set its own color!!" 254378 ^self takeColor: colorPicker currentColor event: evt! ! 254379 254380!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/21/2000 16:06'! 254381toggleShapes 254382 | tab sh stamps | 254383 "The sub panel that has the shape tools on it. Rect, line..." 254384 stamps := self submorphNamed: 'stamps'. 254385 tab := self submorphNamed: 'shapeTab'. 254386 (sh := self submorphNamed: 'shapes') visible 254387 ifTrue: [sh hide. tab top: stamps bottom-1] 254388 ifFalse: [sh comeToFront. sh top: stamps bottom-9. 254389 sh show. tab top: sh bottom - tab height + 10]. 254390 self layoutChanged. 254391! ! 254392 254393!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/21/2000 15:57'! 254394toggleStamps 254395 | tab otherTab st shapes | 254396 "The sub panel that has the stamps in it. For saving and moving parts of an image." 254397 shapes := self submorphNamed: 'shapes'. 254398 otherTab := self submorphNamed: 'shapeTab'. 254399 tab := self submorphNamed: 'stampTab'. 254400 (st := self submorphNamed: 'stamps') visible 254401 ifTrue: [st hide. st bottom: self bottom. tab top: self bottom-1. 254402 shapes top: self bottom-9. 254403 otherTab top: (shapes visible ifTrue: [shapes bottom - otherTab height + 10] 254404 ifFalse: [self bottom-1])] 254405 ifFalse: [st top: self bottom-10. st show. tab top: st bottom-0. 254406 shapes top: st bottom-9. 254407 otherTab top: (shapes visible ifTrue: [shapes bottom - otherTab height + 10] 254408 ifFalse: [st bottom-0])]. 254409 self layoutChanged.! ! 254410 254411!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/1/97 12:09'! 254412tool 254413 ^ tool! ! 254414 254415!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 12:38'! 254416tool: actionButton action: aSelector cursor: aCursor evt: evt 254417 "Set the current tool and action for the paintBox. " 254418 254419 tool ifNotNil: [ 254420 tool == actionButton ifFalse: [ 254421 tool state: #off. 254422 action == #stamp: ifTrue: [self stampDeEmphasize]]]. 254423 tool := actionButton. "A ThreePhaseButtonMorph" 254424 "tool state: #on. already done" 254425 action := aSelector. "paint:" 254426 currentCursor := aCursor. 254427 self notifyWeakDependentsWith: {#action. evt. action}. 254428 self notifyWeakDependentsWith: {#currentCursor. evt. currentCursor}. 254429! ! 254430 254431!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:45'! 254432toss: cancelButton with: cancelSelector evt: evt 254433 "Reject the painting. Showing noPalette is done by the block submitted to the SketchEditorMorph" 254434 254435 | focus | 254436 owner ifNil: ["it happens" ^ self]. 254437 (focus := self focusMorph) 254438 ifNotNil: [focus cancelPainting: self evt: evt] 254439 ifNil: 254440 [self delete]. 254441 cancelButton state: #off. 254442! ! 254443 254444!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 11:15'! 254445undo: undoButton with: undoSelector evt: evt 254446 | ss | 254447 (ss := self focusMorph) 254448 ifNotNil: [ss undoPainting: self evt: evt] 254449 ifNil: [self notCurrentlyPainting]. 254450 undoButton state: #off.! ! 254451 254452 254453!PaintBoxMorph methodsFor: 'initialization' stamp: 'RAA 8/15/2000 16:47'! 254454addWeakDependent: anObject 254455 254456 weakDependents ifNil: [^weakDependents := WeakArray with: anObject]. 254457 weakDependents := weakDependents,{anObject} reject: [ :each | each isNil].! ! 254458 254459!PaintBoxMorph methodsFor: 'initialization' stamp: 'RAA 8/15/2000 14:59'! 254460beStatic 254461 254462 colorMemory ifNotNil: [colorMemory beStatic].! ! 254463 254464!PaintBoxMorph methodsFor: 'initialization' stamp: 'sw 5/23/2001 13:53'! 254465createButtons 254466 "Create buttons one at a time and let the user place them over the background. Later can move them again by turning on AuthorModeOwner in ThreePhaseButtonMorph. 254467 self createButtons. " 254468 254469 | rect button nib | 254470 #(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: pickup: "pickup: pickup: pickup:" stamp: "stamp: stamp: stamp:" undo: keep: toss: prevStamp: nextStamp:) do: [:sel | 254471 (self submorphNamed: sel) ifNil: 254472 [self inform: 'Rectangle for ',sel. 254473 rect := Rectangle fromUser. 254474 button := ThreePhaseButtonMorph new. 254475 button onImage: nil; bounds: rect. 254476 self addMorph: button. 254477 button actionSelector: #tool:action:cursor:evt:; arguments: (Array with: button with: sel with: nil). 254478 button actWhen: #buttonUp; target: self]]. 254479 #(brush1: brush2: brush3: brush4: brush5: brush6: ) doWithIndex: [:sel :ind | 254480 (self submorphNamed: sel) ifNil: 254481 [self inform: 'Rectangle for ',sel. 254482 rect := Rectangle fromUser. 254483 button := ThreePhaseButtonMorph new. 254484 button onImage: nil; bounds: rect. 254485 self addMorph: button. 254486 nib := Form dotOfSize: (#(1 2 3 6 11 26) at: ind). 254487 button actionSelector: #brush:action:nib:evt:; 254488 arguments: (Array with: button with: sel with: nib). 254489 button actWhen: #buttonUp; target: self]]. 254490 "stamp: Stamps are held in a ScrollingToolHolder. Pickups and stamps and brushes are id-ed by the button == with item from a list." 254491 254492 254493! ! 254494 254495!PaintBoxMorph methodsFor: 'initialization' stamp: 'PeterHugossonMiller 9/3/2009 10:13'! 254496fixupButtons 254497 | changes answer newSelector | 254498 changes := Dictionary new. 254499 changes 254500 at: #brush:action:nib: put: #brush:action:nib:evt:; 254501 at: #tool:action:cursor: put: #tool:action:cursor:evt:; 254502 at: #pickup:action:cursor: put: #pickup:action:cursor:evt:; 254503 at: #keep:with: put: #keep:with:evt:; 254504 at: #undo:with: put: #undo:with:evt:; 254505 at: #scrollStamps:action: put: #scrollStamps:action:evt:; 254506 at: #toss:with: put: #toss:with:evt:; 254507 at: #eyedropper:action:cursor: put: #eyedropper:action:cursor:evt:; 254508 at: #clear:with: put: #clear:with:evt:. 254509 answer := String new writeStream. 254510 self allMorphsDo: 254511 [:each | 254512 (each isKindOf: ThreePhaseButtonMorph) 254513 ifTrue: 254514 [answer nextPutAll: each actionSelector. 254515 (changes includesKey: each actionSelector) 254516 ifTrue: 254517 [each actionSelector: (newSelector := changes at: each actionSelector). 254518 answer nextPutAll: ' <-- ' , newSelector]. 254519 answer cr]]. 254520 ^answer contents 254521 "StringHolder new 254522 contents: answer contents; 254523 openLabel: 'button fixups'"! ! 254524 254525!PaintBoxMorph methodsFor: 'initialization' stamp: 'dgd 2/22/2003 19:03'! 254526init3 254527 "Just a record of how we loaded in the latest paintbox button images" 254528 254529 | bb rect lay pic16Bit aa blt on thin | 254530 self loadoffImage: 'etoy_default.gif'. 254531 self allMorphsDo: 254532 [:button | 254533 (button isKindOf: ThreePhaseButtonMorph) 254534 ifTrue: [button offImage: nil] 254535 ifFalse: [button position: button position + (100 @ 0)]]. 254536 (bb := self submorphNamed: #keep:) position: bb position + (100 @ 0). 254537 (bb := self submorphNamed: #toss:) position: bb position + (100 @ 0). 254538 (bb := self submorphNamed: #undo:) position: bb position + (100 @ 0). 254539 "Transparent is (Color r: 1.0 g: 0 b: 1.0)" 254540 self moveButtons. 254541 self loadOnImage: 'etoy_in.gif'. 254542 AllOnImage := nil. 254543 'save space'. 254544 self loadPressedImage: 'etoy_in.gif'. 254545 AllPressedImage := nil. 254546 'save space'. 254547 self loadCursors. 254548 254549 "position the stamp buttons" 254550 stampHolder stampButtons owner last delete. 254551 stampHolder pickupButtons last delete. 254552 stampHolder stampButtons: (stampHolder stampButtons copyFrom: 1 to: 3). 254553 stampHolder pickupButtons: (stampHolder pickupButtons copyFrom: 1 to: 3). 254554 "| rect |" 254555 stampHolder pickupButtons do: 254556 [:button | 254557 "PopUpMenu notify: 'Rectangle for ',sel." 254558 254559 rect := Rectangle fromUser. 254560 button bounds: rect "image is nil"]. 254561 "| rect lay |" 254562 stampHolder clear. 254563 stampHolder stampButtons do: 254564 [:button | 254565 button 254566 offImage: nil; 254567 pressedImage: nil. 254568 lay := button owner. 254569 "PopUpMenu notify: 'Rectangle for ',sel." 254570 rect := Rectangle fromUser. 254571 button image: (Form fromDisplay: (rect insetBy: 2)). 254572 lay borderWidth: 2. 254573 lay bounds: rect "image is nil"]. 254574 "| pic16Bit blt aa on |" 254575 pic16Bit := GIFReadWriter formFromFileNamed: 'etoy_in.gif'. "really 8" 254576 aa := Form extent: OriginalBounds extent depth: 8. 254577 blt := BitBlt current toForm: aa. 254578 blt 254579 sourceForm: pic16Bit; 254580 combinationRule: Form over; 254581 sourceRect: OriginalBounds; 254582 destOrigin: 0 @ 0; 254583 copyBits. 254584 "Collect all the images for the buttons in the on state" 254585 stampHolder pickupButtons do: 254586 [:button | 254587 on := ColorForm extent: button extent depth: 8. 254588 on colors: pic16Bit colors. 254589 on 254590 copy: (0 @ 0 extent: button extent) 254591 from: button topLeft - self topLeft 254592 in: aa 254593 rule: Form over. 254594 button 254595 image: on; 254596 pressedImage: on; 254597 offImage: nil]. 254598 self invalidRect: bounds. 254599 ((self submorphNamed: #erase:) arguments third) offset: 12 @ 35. 254600 ((self submorphNamed: #eyedropper:) arguments third) offset: 0 @ 0. 254601 ((self submorphNamed: #fill:) arguments third) offset: 10 @ 44. 254602 ((self submorphNamed: #paint:) arguments third) offset: 3 @ 3. "unused" 254603 ((self submorphNamed: #rect:) arguments third) offset: 6 @ 17. 254604 ((self submorphNamed: #ellipse:) arguments third) offset: 5 @ 4. 254605 ((self submorphNamed: #polygon:) arguments third) offset: 5 @ 4. 254606 ((self submorphNamed: #line:) arguments third) offset: 5 @ 17. 254607 ((self submorphNamed: #star:) arguments third) offset: 2 @ 5. 254608 thumbnail delete. 254609 thumbnail := nil. 254610 (submorphs select: [:e | e class == RectangleMorph]) first 254611 bounds: Rectangle fromUser. 254612 ((submorphs select: [:e | e class == RectangleMorph]) first) 254613 borderWidth: 1; 254614 borderColor: Color black. 254615 "| thin |" 254616 submorphs do: [:ss | ss class == ImageMorph ifTrue: [thin := ss "first"]]. 254617 colorMemoryThin := thin! ! 254618 254619!PaintBoxMorph methodsFor: 'initialization' stamp: 'tk 8/22/2000 11:56'! 254620init4 254621 "Just a record of how Ted loaded in the paintbox button images, Feb 98" 254622| bb im pp newImage pic24Bit picNewBit blt | 254623 254624"self loadoffImage: 'roundedPalette3.bmp'." 254625pic24Bit := GIFReadWriter formFromServerFile: 'updates/137roundedPalette3.bmp'. 254626picNewBit := Form extent: pic24Bit extent depth: 16. 254627pic24Bit displayOn: picNewBit. 254628OriginalBounds := picNewBit boundingBox. 254629AllOffImage := Form extent: OriginalBounds extent depth: 16. 254630blt := BitBlt current toForm: AllOffImage. 254631blt sourceForm: picNewBit; combinationRule: Form over; 254632 sourceRect: OriginalBounds; destOrigin: 0@0; copyBits. 254633 254634AllOffImage mapColor: Color transparent to: Color black. 254635self image: AllOffImage. 254636self invalidRect: bounds. 254637 254638self submorphsDo: [:button | button position: button position + (10@10)]. 254639(im := submorphs at: 28) class == ImageMorph ifTrue: [ 254640 im position: im position + (2@0)]. "color picker" 254641"exercise it once" 254642 254643(bb := self submorphNamed: #keep:) position: bb position + (0@25). 254644(bb := self submorphNamed: #toss:) position: bb position + (0@25). 254645(bb := self submorphNamed: #undo:) position: bb position + (0@-25). 254646(bb := self submorphNamed: #clear:) position: bb position + (0@-25). 254647(bb := self submorphNamed: #undo:) position: bb position + (0@-69). 254648(bb := self submorphNamed: #clear:) position: bb position + (0@-69). 254649self submorphsDo: [:button | 254650 button class == AlignmentMorph ifTrue: [ 254651 button position: button position + (0@25)]. 254652 (button printString includesSubString: 'stamp:') ifTrue: [ 254653 button position: button position + (0@25)]]. 254654(bb := self submorphNamed: #prevStamp:) position: bb position + (0@25). 254655(bb := self submorphNamed: #nextStamp:) position: bb position + (0@25). 254656 254657bb := self submorphNamed: #keep:. 254658newImage := bb pressedImage copy: (0@4 corner: (bb pressedImage boundingBox extent)). 254659bb onImage: newImage. bb pressedImage: newImage. bb extent: newImage extent. 254660bb position: bb position + (4@1). 254661 254662pp := (bb := self submorphNamed: #toss:) pressedImage. 254663newImage := pp copy: (0@4 corner: (bb pressedImage extent - (3@0))). 254664bb onImage: newImage. bb pressedImage: newImage. 254665bb extent: newImage extent. 254666bb position: bb position + (3@1). 254667 254668pp := (bb := self submorphNamed: #undo:) pressedImage. 254669newImage := pp copy: (0@0 corner: (bb pressedImage extent - (3@5))). 254670bb onImage: newImage. bb pressedImage: newImage. 254671bb extent: newImage extent. 254672bb position: bb position + (3@-1). 254673 254674pp := (bb := self submorphNamed: #clear:) pressedImage. 254675newImage := pp copy: (0@0 corner: (bb pressedImage extent - (0@5))). 254676bb onImage: newImage. bb pressedImage: newImage. 254677bb extent: newImage extent. 254678bb position: bb position + (3@-1). 254679 254680pic24Bit := GIFReadWriter formFromServerFile: 'updates/137pencil.bmp'. 254681picNewBit := Form extent: pic24Bit extent depth: 16. 254682pic24Bit displayOn: picNewBit. 254683newImage := picNewBit as8BitColorForm. 254684newImage transparentColor: (Color r: 0 g: 0 b: 0). 254685(bb := self submorphNamed: #erase:) pressedImage: newImage; onImage: newImage; 254686 extent: newImage extent. 254687 254688bb position: bb position + (-11@-1). 254689! ! 254690 254691!PaintBoxMorph methodsFor: 'initialization' stamp: 'tk 7/28/2000 23:26'! 254692initialize 254693 super initialize. 254694 colorMemory ifNotNil: [colorMemory on: #mouseDown send: #takeColorEvt:from: to: self].! ! 254695 254696!PaintBoxMorph methodsFor: 'initialization' stamp: 'jm 6/18/1999 18:58'! 254697loadColorChooser 254698 "Load Forms for ColorMemoryMorph." 254699 254700 | doc closedForm openForm | 254701 doc := Utilities objectStrmFromUpdates: 'colorPalClosed.obj'. 254702 closedForm := doc fileInObjectAndCode mapColor: Color transparent to: Color black. 254703 doc := Utilities objectStrmFromUpdates: 'colorPalOpen.obj'. 254704 openForm := doc fileInObjectAndCode mapColor: Color transparent to: Color black. 254705 254706 colorMemoryThin image: closedForm. 254707 colorMemoryThin position: self position + (0@140). 254708 254709 colorMemory delete. "delete old one" 254710 colorMemory := PaintBoxColorPicker new image: openForm. 254711! ! 254712 254713!PaintBoxMorph methodsFor: 'initialization' stamp: 'sw 5/23/2001 13:54'! 254714loadCursors 254715 "Display the form containing the cursors. Transparent is (Color r: 1.0 g: 0 b: 1.0). Grab the forms one at a time, and they are stored away. 254716 self loadCursors. " 254717 254718 | button transp cursor map | 254719 transp := Color r: 1.0 g: 0 b: 1.0. 254720 map := Color indexedColors copy. "just in case" 254721 1 to: 256 do: [:ind | (map at: ind) = transp ifTrue: 254722 [map at: ind put: Color transparent]]. 254723 254724 #(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: ) do: [:sel | 254725 self inform: 'Rectangle for ',sel. 254726 cursor := ColorForm fromUser. 254727 cursor colors: map. "share it" 254728 button := self submorphNamed: sel. 254729 button arguments at: 3 put: cursor]. 254730! ! 254731 254732!PaintBoxMorph methodsFor: 'initialization' stamp: 'yo 1/13/2005 12:20'! 254733loadJapanesePaintBoxBitmaps 254734" 254735 PaintBoxMorph new loadJapanesePaintBoxBitmaps. 254736" 254737 254738 | formTranslator form bb | 254739 self position: 0@0. 254740 formTranslator := NaturalLanguageFormTranslator localeID: (LocaleID isoString: 'ja'). 254741 form := Form fromFileNamed: 'offPaletteJapanese(children).form'. 254742 254743 #('keep:' 'undo:' 'clear:' 'toss:') with: #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:extName :label | 254744 bb := (self submorphs detect: [:e | e externalName = extName]) bounds. 254745 formTranslator name: label, '-off' form: (form copy: bb) 254746 ]. 254747 254748 254749 form := Form fromFileNamed: 'pressedPaletteJapanese(children).form'. 254750 #('keep:' 'undo:' 'clear:' 'toss:') with: #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:extName :label | 254751 bb := (self submorphs detect: [:e | e externalName = extName]) bounds. 254752 formTranslator name: label, '-pressed' form: (form copy: bb) 254753 ]. 254754! ! 254755 254756!PaintBoxMorph methodsFor: 'initialization' stamp: 'yo 11/4/2002 21:20'! 254757loadOffForm: pic16Bit 254758 "Prototype loadOffForm: (Smalltalk imageImports at: #offPaletteJapanese)" 254759 254760 | blt | 254761 OriginalBounds := pic16Bit boundingBox. 254762 AllOffImage := Form extent: OriginalBounds extent depth: 16. 254763 blt := BitBlt current toForm: AllOffImage. 254764 blt sourceForm: pic16Bit; 254765 combinationRule: Form over; 254766 sourceRect: OriginalBounds; 254767 destOrigin: 0 @ 0; 254768 copyBits. 254769 AllOffImage mapColor: Color blue to: Color transparent. 254770 self image: AllOffImage. 254771 AllOffImage := nil. 254772 self invalidRect: bounds 254773! ! 254774 254775!PaintBoxMorph methodsFor: 'initialization' stamp: 'ar 5/28/2000 12:10'! 254776loadOnImage: fileName 254777 "Read in and convert the image for the paintBox with the buttons 254778on. A .bmp 24-bit image. For each button, cut that chunk out and save it." 254779 " self loadOnImage: 'NoSh:=on.bmp'. 254780 AllOnImage := nil. 'save space'. " 254781 254782 | pic16Bit blt aa on type | 254783 type := 'gif'. " gif or bmp " 254784type = 'gif' ifTrue: [ 254785 pic16Bit "really 8" := GIFReadWriter formFromFileNamed: fileName. 254786 pic16Bit display. 254787 aa := AllOnImage := Form extent: OriginalBounds extent depth: 8. 254788 blt := BitBlt current toForm: aa. 254789 blt sourceForm: pic16Bit; combinationRule: Form over; 254790 sourceRect: OriginalBounds; destOrigin: 0@0; copyBits. 254791 ]. 254792type = 'bmp' ifTrue: [ 254793 pic16Bit := (Form fromBMPFileNamed: fileName) asFormOfDepth: 16. 254794 pic16Bit display. 254795 aa := AllOnImage := Form extent: OriginalBounds extent depth: 16. 254796 blt := BitBlt current toForm: aa. 254797 blt sourceForm: pic16Bit; combinationRule: Form over; 254798 sourceRect: OriginalBounds; destOrigin: 0@0; copyBits. 254799 aa mapColor: Color transparent to: Color black. 254800 ]. 254801 "Collect all the images for the buttons in the on state" 254802 self allMorphsDo: [:button | 254803 (button isKindOf: ThreePhaseButtonMorph) ifTrue: [ 254804 type = 'gif' ifTrue: [on := ColorForm extent: button extent depth: 8. 254805 on colors: pic16Bit colors] 254806 ifFalse: [on := Form extent: button extent depth: 16]. 254807 on copy: (0@0 extent: button extent) 254808 from: (button topLeft - self topLeft) in: aa rule: Form over. 254809 button onImage: on]]. 254810 self invalidRect: bounds. 254811 254812 ! ! 254813 254814!PaintBoxMorph methodsFor: 'initialization' stamp: 'yo 11/4/2002 21:20'! 254815loadPressedForm: pic16Bit 254816 "Prototype loadPressedForm: (Smalltalk imageImports at: #pressedPaletteJapanese)" 254817 254818 | blt on | 254819 AllPressedImage := AllPressedImage := Form extent: OriginalBounds extent depth: 16. 254820 blt := BitBlt current toForm: AllPressedImage. 254821 blt sourceForm: pic16Bit; 254822 combinationRule: Form over; 254823 sourceRect: OriginalBounds; 254824 destOrigin: 0 @ 0; 254825 copyBits. 254826 AllPressedImage mapColor: Color black to: Color transparent. 254827 self 254828 allMorphsDo: [:button | (button isKindOf: ThreePhaseButtonMorph) 254829 ifTrue: [on := Form extent: button extent depth: 16. 254830 on 254831 copy: (0 @ 0 extent: button extent) 254832 from: button topLeft - self topLeft 254833 in: AllPressedImage 254834 rule: Form over. 254835 button pressedImage: on]]. 254836 AllPressedImage := nil. 254837 self invalidRect: bounds 254838! ! 254839 254840!PaintBoxMorph methodsFor: 'initialization' stamp: 'ar 5/28/2000 12:10'! 254841loadPressedImage: fileName 254842 "Read in and convert the image for the paintBox with the buttons 254843on. A .bmp 24-bit image. For each button, cut that chunk out and save it." 254844 " self loadPressedImage: 'NoSh:=on.bmp'. 254845 AllPressedImage := nil. 'save space'. " 254846 254847 | pic16Bit blt aa on type | 254848 type := 'gif'. " gif or bmp " 254849type = 'gif' ifTrue: [ 254850 pic16Bit "really 8" := GIFReadWriter formFromFileNamed: fileName. 254851 pic16Bit display. 254852 aa := AllPressedImage := Form extent: OriginalBounds extent depth: 8. 254853 blt := BitBlt current toForm: aa. 254854 blt sourceForm: pic16Bit; combinationRule: Form over; 254855 sourceRect: OriginalBounds; destOrigin: 0@0; copyBits. 254856 ]. 254857type = 'bmp' ifTrue: [ 254858 pic16Bit := (Form fromBMPFileNamed: fileName) asFormOfDepth: 16. 254859 pic16Bit display. 254860 aa := AllPressedImage := Form extent: OriginalBounds extent depth: 16. 254861 blt := BitBlt current toForm: aa. 254862 blt sourceForm: pic16Bit; combinationRule: Form over; 254863 sourceRect: OriginalBounds; destOrigin: 0@0; copyBits. 254864 aa mapColor: Color transparent to: Color black. 254865 ]. 254866 "Collect all the images for the buttons in the on state" 254867 self allMorphsDo: [:button | 254868 (button isKindOf: ThreePhaseButtonMorph) ifTrue: [ 254869 type = 'gif' ifTrue: [on := ColorForm extent: button extent depth: 8. 254870 on colors: pic16Bit colors] 254871 ifFalse: [on := Form extent: button extent depth: 16]. 254872 on copy: (0@0 extent: button extent) 254873 from: (button topLeft - self topLeft) in: aa rule: Form over. 254874 button pressedImage: on]]. 254875 self invalidRect: bounds. 254876 254877 ! ! 254878 254879!PaintBoxMorph methodsFor: 'initialization' stamp: 'md 11/14/2003 16:52'! 254880loadoffImage: fileName 254881 "Read in and convert the background image for the paintBox. All 254882buttons off. A .bmp 24-bit image." 254883 " Prototype loadoffImage: 'roundedPalette3.bmp' " 254884 254885 | pic16Bit blt type getBounds | 254886 type := 'bmp'. " gif or bmp " 254887 getBounds := 'fromPic'. "fromUser = draw out rect of paintbox on image" 254888 "fromOB = just read in new bits, keep same size and place as last time." 254889 "fromPic = picture is just the PaintBox, use its bounds" 254890type = 'gif' ifTrue: [ 254891 pic16Bit "really 8" := GIFReadWriter formFromFileNamed: fileName. 254892 getBounds = 'fromUser' ifTrue: ["Just first time, collect the bounds" 254893 pic16Bit display. 254894 OriginalBounds := Rectangle fromUser]. 254895 getBounds = 'fromPic' ifTrue: [OriginalBounds := pic16Bit boundingBox]. 254896 ]. 254897 "Use OriginalBounds as it was last time" 254898type = 'bmp' ifTrue: [ 254899 pic16Bit := (Form fromBMPFileNamed: fileName) asFormOfDepth: 16. 254900 getBounds = 'fromUser' ifTrue: ["Just first time, collect the bounds" 254901 pic16Bit display. 254902 OriginalBounds := Rectangle fromUser]. 254903 "Use OriginalBounds as it was last time" 254904 (getBounds = 'fromPic') ifTrue: [OriginalBounds := pic16Bit boundingBox]. 254905 AllOffImage := Form extent: OriginalBounds extent depth: 16. 254906 ]. 254907 254908type = 'gif' ifTrue: [ 254909 AllOffImage := ColorForm extent: OriginalBounds extent depth: 8. 254910 AllOffImage colors: pic16Bit colors]. 254911 254912 blt := BitBlt current toForm: AllOffImage. 254913 blt sourceForm: pic16Bit; combinationRule: Form over; 254914 sourceRect: OriginalBounds; destOrigin: 0@0; copyBits. 254915 254916type = 'bmp' ifTrue: [AllOffImage mapColor: Color transparent to: Color black]. 254917 self image: AllOffImage. 254918 self invalidRect: bounds. 254919 254920 ! ! 254921 254922!PaintBoxMorph methodsFor: 'initialization' stamp: 'sw 5/23/2001 13:54'! 254923moveButtons 254924 "Move buttons one at a time and let the user place them over the background. Later can move them again by turning on AuthorModeOwner in ThreePhaseButtonMorph. 254925 self createButtons. " 254926 254927 | rect button | 254928 #(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: "pickup: pickup: pickup: pickup:" "stamp: stamp: stamp: stamp:" undo: keep: toss: prevStamp: nextStamp:) do: [:sel | 254929 self inform: 'Rectangle for ',sel. 254930 rect := Rectangle fromUser. 254931 button := self submorphNamed: sel. 254932 button bounds: rect. "image is nil"]. 254933 #(brush1: brush2: brush3: brush4: brush5: brush6: ) doWithIndex: [:sel :ind | 254934 self inform: 'Rectangle for ',sel. 254935 rect := Rectangle fromUser. 254936 button := self submorphNamed: sel. 254937 button bounds: rect. "image is nil"]. 254938 "stamp: Stamps are held in a ScrollingToolHolder. Pickups and stamps and brushes are id-ed by the button == with item from a list." 254939 254940 " 254941 " 254942! ! 254943 254944!PaintBoxMorph methodsFor: 'initialization' stamp: 'tk 8/22/97 15:57'! 254945noVeneer 254946 "For a palette with a background (off) image, clear that image. 254947But first, for each button, cut that chunk out and save it in the offImage 254948part." 254949 " self noVeneer. 254950 AllOffImage := nil. 'save space. irreversible'. " 254951 254952 | aa on | 254953 AllOffImage ifNil: [AllOffImage := image]. 254954 aa := AllOffImage. 254955 "Collect all the images for the buttons in the on state" 254956 self allMorphsDo: [:button | 254957 (button isKindOf: ThreePhaseButtonMorph) ifTrue: [ 254958 on := Form extent: button extent depth: 16. 254959 on copy: (0@0 extent: button extent) 254960 from: (button topLeft - self topLeft) in: 254961aa rule: Form over. 254962 button offImage: on]]. 254963 self image: (Form extent: AllOffImage extent depth: 1). 254964 self invalidRect: bounds. 254965 254966 254967 ! ! 254968 254969!PaintBoxMorph methodsFor: 'initialization' stamp: 'RAA 8/16/2000 11:12'! 254970notifyWeakDependentsWith: arguments 254971 254972 weakDependents ifNil: [^self]. 254973 weakDependents do: [ :each | 254974 each ifNotNil: [ 254975 each paintBoxChanged: arguments. 254976 each paintBoxChanged: {#changed. arguments second. true}. 254977 ]. 254978 ].! ! 254979 254980 254981!PaintBoxMorph methodsFor: 'other' stamp: 'dgd 8/30/2003 21:55'! 254982addCustomMenuItems: aCustomMenu hand: aHandMorph 254983 254984 "super addCustomMenuItems: aCustomMenu hand: aHandMorph." 254985 "don't want the ones from ImageMorph" 254986 aCustomMenu add: 'grab stamp from screen' translated action: #grabFromScreen:. 254987 254988! ! 254989 254990!PaintBoxMorph methodsFor: 'other' stamp: 'yo 1/13/2005 14:08'! 254991addGraphicLabels 254992 "translate button labels" 254993 254994 | formTranslator ext pos newForm | 254995 formTranslator := NaturalLanguageFormTranslator localeID: (Locale current localeID). 254996 254997 #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:label | 254998 (formTranslator translate: label, '-off') ifNil: [^ false]. 254999 (formTranslator translate: label, '-pressed') ifNil: [^ false]. 255000 ]. 255001 255002 #('keep:' 'undo:' 'clear:' 'toss:') with: #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:extName :label | 255003 | button | 255004 button := submorphs detect: [:m | m externalName = extName] ifNone: [nil]. 255005 button ifNotNil: [ 255006 button removeAllMorphs. 255007 ext := button extent. 255008 pos := button position. 255009 (newForm := formTranslator translate: label, '-off') ifNotNil: [ 255010 button offImage: newForm. 255011 255012 ]. 255013 (newForm := formTranslator translate: label, '-pressed') ifNotNil: [ 255014 button pressedImage: newForm. 255015 ]. 255016 button extent: ext. 255017 button position: pos. 255018 ]. 255019 ]. 255020 255021 ^ true. 255022! ! 255023 255024!PaintBoxMorph methodsFor: 'other' stamp: 'yo 1/13/2005 14:08'! 255025addLabels 255026 255027 Preferences useFormsInPaintBox ifFalse: [ 255028 self addTextualLabels. 255029 ] ifTrue: [ 255030 self addGraphicLabels ifFalse: [self addTextualLabels]. 255031 ]. 255032! ! 255033 255034!PaintBoxMorph methodsFor: 'other' stamp: 'yo 1/13/2005 11:06'! 255035addTextualLabels 255036 "translate button labels" 255037 255038 #('keep:' 'undo:' 'clear:' 'toss:') with: #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:extName :label | 255039 | button | 255040 button := submorphs detect: [:m | m externalName = extName] ifNone: [nil]. 255041 button ifNotNil: [ 255042 button removeAllMorphs. 255043 button addMorph: (TextMorph new 255044 contentsWrapped: (Text string: label translated 255045 attributes: { 255046 TextAlignment centered. 255047 TextEmphasis bold. 255048 TextFontReference toFont: 255049 (Preferences standardPaintBoxButtonFont)}); 255050 bounds: (button bounds translateBy: 0@3); 255051 lock)]]! ! 255052 255053!PaintBoxMorph methodsFor: 'other' stamp: 'tk 10/31/97 13:38'! 255054colorMemory 255055 255056 ^ colorMemory! ! 255057 255058!PaintBoxMorph methodsFor: 'other' stamp: 'di 10/14/97 10:15'! 255059colorMemory: aMorph 255060 255061 colorMemory := aMorph! ! 255062 255063!PaintBoxMorph methodsFor: 'other' stamp: 'tk 10/31/97 13:35'! 255064colorPatch 255065 ^ colorPatch! ! 255066 255067!PaintBoxMorph methodsFor: 'other' stamp: 'adrian_lienhard 7/19/2009 20:06'! 255068focusMorph 255069 "Note: For backward compatibility we search the world for a SketchEditorMorph if the current focus morph is nil" 255070 255071 ^focusMorph ifNil: [ 255072 Smalltalk at: #SketchEditorMorph ifPresent: [ :class | 255073 focusMorph := self world findA: class ] ]! ! 255074 255075!PaintBoxMorph methodsFor: 'other' stamp: 'ar 3/23/2000 14:20'! 255076focusMorph: newFocus 255077 "Set the new focus morph" 255078 focusMorph ifNotNil:[focusMorph paletteDetached: self]. "In case the morph is interested" 255079 focusMorph := newFocus. 255080 focusMorph ifNotNil:[focusMorph paletteAttached: self]. "In case the morph is interested"! ! 255081 255082!PaintBoxMorph methodsFor: 'other' stamp: 'tk 8/22/2000 11:57'! 255083maxBounds 255084 | rr | 255085 "fullBounds if all flop-out parts of the paintBox were showing." 255086 255087 rr := bounds merge: colorMemory bounds. 255088 rr := rr merge: (self submorphNamed: 'stamps') bounds. 255089 rr := rr origin corner: rr corner + (0@ (self submorphNamed: 'shapes') height 255090 + 10 "what is showing of (self submorphNamed: #toggleShapes) height"). 255091 ^ rr! ! 255092 255093!PaintBoxMorph methodsFor: 'other' stamp: 'tk 8/22/2000 23:48'! 255094offsetFromMaxBounds 255095 "location of normal PaintBox within maxBounds." 255096 255097 ^ self left - colorMemory left @ 0! ! 255098 255099!PaintBoxMorph methodsFor: 'other' stamp: 'tk 7/17/97 16:26'! 255100rotationTabForm 255101 ^ rotationTabForm! ! 255102 255103!PaintBoxMorph methodsFor: 'other' stamp: 'tk 7/17/97 16:26'! 255104scaleTabForm 255105 ^ scaleTabForm! ! 255106 255107 255108!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 7/8/2006 20:33'! 255109fixUpColorPicker 255110 | chart picker | 255111 chart := ColorChart ifNil:[Cursor wait showWhile:[ColorChart := (ColorPickerMorph colorPaletteForDepth: 16 extent: 120@89)]]. 255112 chart getCanvas frameRectangle: chart boundingBox color: Color black. 255113 picker := Form extent: (chart extent + (14@12)) depth: 16. 255114 picker fillWhite. 255115 "top" 255116 picker copy: (0@0 extent: picker width@6) 255117 from: (colorMemory image width - picker width)@0 255118 in: colorMemory image rule: Form over. 255119 "bottom" 255120 picker copy: (0@ (picker height-6) extent: picker width@6) 255121 from: (colorMemory image width - picker width)@(colorMemory image height - 7) 255122 in: colorMemory image rule: Form over. 255123 "left" 255124 picker copy: (0@6 corner: 8@(picker height - 6)) 255125 from: (colorMemory image boundingBox topLeft + (0@6)) 255126 in: colorMemory image rule: Form over. 255127 "right" 255128 picker copy: (picker width-6@6 corner: picker width@(picker height - 6)) 255129 from: (colorMemory image boundingBox topRight - (6@-6)) 255130 in: colorMemory image rule: Form over. 255131 chart displayOn: picker at: 8@6. 255132 picker getCanvas frameRectangle: picker boundingBox color: Color black. 255133 colorMemory image: picker. 255134! ! 255135 255136!PaintBoxMorph methodsFor: 'recent colors' stamp: 'PeterHugossonMiller 9/3/2009 10:13'! 255137fixUpRecentColors 255138 | inner outer border box form newImage canvas morph | 255139 self fixUpColorPicker. 255140 recentColors := Array new writeStream. 255141 form := image. 255142 newImage := Form extent: form extent + (0 @ 41) depth: form depth. 255143 form displayOn: newImage. 255144 newImage 255145 copy: (0 @ (form height - 10) 255146 extent: form width @ (newImage height - form height + 10)) 255147 from: 0 @ (form height - (newImage height - form height + 10)) 255148 in: form 255149 rule: Form over. 255150 canvas := newImage getCanvas. 255151 canvas 255152 line: 12 @ (form height - 10) 255153 to: 92 @ (form height - 10) 255154 width: 1 255155 color: Color black. 255156 canvas := canvas copyOffset: 12 @ (form height - 9). 255157 inner := Color 255158 r: 0.677 255159 g: 0.71 255160 b: 0.968. 255161 outer := inner darker darker. 255162 border := Color 255163 r: 0.194 255164 g: 0.258 255165 b: 0.194. 255166 0 to: 1 255167 do: 255168 [:y | 255169 0 to: 3 255170 do: 255171 [:x | 255172 box := (x * 20) @ (y * 20) extent: 20 @ 20. 255173 morph := BorderedMorph new 255174 bounds: ((box insetBy: 1) translateBy: canvas origin + bounds origin). 255175 morph 255176 borderWidth: 1; 255177 borderColor: border. 255178 morph color: Color white. 255179 morph 255180 on: #mouseDown 255181 send: #mouseDownRecent:with: 255182 to: self. 255183 morph 255184 on: #mouseMove 255185 send: #mouseStillDownRecent:with: 255186 to: self. 255187 morph 255188 on: #mouseUp 255189 send: #mouseUpRecent:with: 255190 to: self. 255191 self addMorphFront: morph. 255192 recentColors nextPut: morph. 255193 canvas fillRectangle: box color: Color white. 255194 canvas frameRectangle: (box insetBy: 1) color: border. 255195 canvas frameRectangle: box color: inner. 255196 box := box insetBy: 1. 255197 canvas 255198 line: box topRight 255199 to: box bottomRight 255200 width: 1 255201 color: outer. 255202 canvas 255203 line: box bottomLeft 255204 to: box bottomRight 255205 width: 1 255206 color: outer]]. 255207 recentColors := recentColors contents. 255208 (RecentColors isNil or: [RecentColors size ~= recentColors size]) 255209 ifTrue: [RecentColors := recentColors collect: [:each | each color]] 255210 ifFalse: 255211 [RecentColors 255212 keysAndValuesDo: [:idx :aColor | (recentColors at: idx) color: aColor]]. 255213 self image: newImage. 255214 self toggleStamps. 255215 self toggleStamps! ! 255216 255217!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 9/23/2000 19:54'! 255218mouseDownRecent: evt with: aMorph 255219 aMorph borderColor: Color white. 255220! ! 255221 255222!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 9/23/2000 20:01'! 255223mouseStillDownRecent: evt with: aMorph 255224 (aMorph containsPoint: evt cursorPoint) 255225 ifTrue:[aMorph borderColor: Color white] 255226 ifFalse:[aMorph borderColor: (Color r: 0.194 g: 0.258 b: 0.194)] 255227! ! 255228 255229!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 9/23/2000 19:59'! 255230mouseUpRecent: evt with: aMorph 255231 aMorph borderColor: (Color r: 0.194 g: 0.258 b: 0.194). 255232 (aMorph containsPoint: evt cursorPoint) ifTrue:[ 255233 self takeColor: aMorph color event: evt. 255234 ].! ! 255235 255236!PaintBoxMorph methodsFor: 'recent colors' stamp: 'dgd 2/21/2003 23:17'! 255237recentColor: aColor 255238 "Remember the color as one of our recent colors" 255239 255240 (recentColors anySatisfy: [:any | any color = aColor]) ifTrue: [^self]. "already remembered" 255241 recentColors size to: 2 255242 by: -1 255243 do: 255244 [:i | 255245 (recentColors at: i) color: (recentColors at: i - 1) color. 255246 RecentColors at: i put: (RecentColors at: i - 1)]. 255247 (recentColors first) color: aColor. 255248 RecentColors at: 1 put: aColor! ! 255249 255250 255251!PaintBoxMorph methodsFor: 'user interface' stamp: 'tk 7/2/97 08:10'! 255252mouseUpBalk: evt 255253 "A button I own got a mouseDown, but the user moved out before letting up. Prevent this for the current tool. Some tool must stay selected." 255254 255255 tool state: #on. "keep current one, even if user balked on it" 255256 currentBrush ifNotNil: [currentBrush state: #on].! ! 255257 255258"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 255259 255260PaintBoxMorph class 255261 instanceVariableNames: ''! 255262 255263!PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'tk 8/21/2000 12:52'! 255264fixUpPrototype 255265 "PaintBoxMorph fixUpPrototype" 255266self error: 'who uses this?'. 255267 Prototype eventHandler: nil! ! 255268 255269!PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'ar 7/8/2006 20:33'! 255270initializeColorChart 255271 "PaintBoxMorph initializeColorChart" 255272 ColorChart := (ColorPickerMorph colorPaletteForDepth: 32 extent: (360+10)@(180+10))! ! 255273 255274!PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'tk 10/12/97 11:01'! 255275prototype 255276 "Later we will be a subclass of Model, and it will have a general version of this" 255277 ^ Prototype! ! 255278 255279 255280!PaintBoxMorph class methodsFor: 'initialization' stamp: 'adrian_lienhard 7/19/2009 22:59'! 255281initialize 255282 "PaintBoxMorph initialize" 255283 255284 Prototype ifNotNil: [ 255285 Prototype eventHandler: nil. 255286 Prototype focusMorph: nil. 255287 Prototype stampHolder clear. "clear stamps" 255288 Prototype delete. "break link to world, if any" 255289 ]. 255290 AllOnImage := AllOffImage := AllPressedImage := nil. 255291 OriginalBounds := nil. 255292 255293! ! 255294 255295 255296!PaintBoxMorph class methodsFor: 'instance creation' stamp: 'bf 10/11/2004 13:37'! 255297new 255298 255299 | pb button dualUse formCanvas rect | 255300 pb := Prototype veryDeepCopy. 255301 "Assume that the PaintBox does not contain any scripted Players!!" 255302 pb stampHolder normalize. "Get the stamps to show" 255303 "Get my own copies of the brushes so I can modify them" 255304 #(brush1: brush2: brush3: brush4: brush5: brush6:) do: [:sel | 255305 button := pb submorphNamed: sel. 255306 button offImage: button offImage deepCopy. 255307 dualUse := button onImage == button pressedImage. "sometimes shared" 255308 button onImage: button onImage deepCopy. 255309 dualUse 255310 ifTrue: [button pressedImage: button onImage] 255311 ifFalse: [button pressedImage: button pressedImage deepCopy]. 255312 "force color maps for later mapping" 255313 button offImage. 255314 button onImage. 255315 button pressedImage. 255316 formCanvas := button onImage getCanvas. 255317 formCanvas := formCanvas 255318 copyOrigin: 0@0 255319 clipRect: (rect := 0@0 extent: button onImage extent). 255320 (#(brush1: brush3:) includes: sel) ifTrue: [ 255321 rect := rect origin corner: rect corner - (2@2)]. 255322 (#brush2: == sel) ifTrue: [ 255323 rect := rect origin corner: rect corner - (2@4)]. 255324 formCanvas frameAndFillRectangle: rect fillColor: Color transparent 255325 borderWidth: 2 borderColor: (Color r: 0.599 g: 0.8 b: 1.0). 255326 ]. 255327 pb showColor. 255328 pb fixUpRecentColors. 255329 pb addLabels. 255330 ^ pb! ! 255331 255332 255333!PaintBoxMorph class methodsFor: 'notification' stamp: 'ar 7/8/2006 20:33'! 255334localeChanged 255335 | caption | 255336 caption := ColorPickerMorph noColorCaption. 255337 caption displayOn: ColorChart at: ColorChart boundingBox topCenter - (caption width // 2 @ 0)! ! 255338BorderedMorph subclass: #PanelMorph 255339 instanceVariableNames: '' 255340 classVariableNames: '' 255341 poolDictionaries: '' 255342 category: 'Polymorph-Widgets'! 255343!PanelMorph commentStamp: 'gvc 5/18/2007 12:38' prior: 0! 255344A container morph that tracks the owner's pane colour unless an explicit fillStyle is specified. Additionally allows hooking of mouseOver events (no button down).! 255345 255346 255347!PanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 17:15'! 255348adoptPaneColor: paneColor 255349 "Change our color too." 255350 255351 super adoptPaneColor: paneColor. 255352 paneColor ifNil: [^self]. 255353 self 255354 valueOfProperty: #fillStyle 255355 ifAbsent: [self color: paneColor]. 255356 self borderStyle baseColor: paneColor darker! ! 255357 255358!PanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/26/2006 17:31'! 255359defaultBorderWidth 255360 "Answer the default border width for the receiver." 255361 255362 ^0! ! 255363 255364!PanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 10:36'! 255365defaultColor 255366 "Answer the default color for the receiver." 255367 255368 ^Color transparent! ! 255369 255370!PanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/20/2009 15:49'! 255371enabled: aBoolean 255372 "Pass on to submorphs." 255373 255374 self submorphsDo: [:m | 255375 (m respondsTo: #enabled:) ifTrue: [ 255376 m enabled: aBoolean]]! ! 255377 255378!PanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 17:07'! 255379handleMouseOver: anEvent 255380 "System level event handling." 255381 255382 (self handlesMouseOver: anEvent) ifTrue:[ 255383 anEvent wasHandled: true. 255384 self mouseOver: anEvent]! ! 255385 255386!PanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/12/2007 10:49'! 255387initialColorInSystemWindow: aSystemWindow 255388 "Answer the colour the receiver should be when added to a SystemWindow." 255389 255390 ^Color transparent! ! 255391 255392!PanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 12:33'! 255393initialize 255394 "Initialize the receiver." 255395 255396 super initialize. 255397 self 255398 clipSubmorphs: true; 255399 beSticky "stop being grabbed"! ! 255400 255401!PanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 17:26'! 255402mouseOver: anEvent 255403 "Handle a mouseOver event, meaning the mouse just moved within the receiver 255404 with no button pressed. The default response is to let my eventHandler, if any, handle it." 255405 255406 self eventHandler ifNotNil: 255407 [self eventHandler mouseOver: anEvent fromMorph: self]! ! 255408 255409!PanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 17:25'! 255410on: eventName send: selector to: recipient 255411 "Register a recipient for handling an event." 255412 255413 self eventHandler ifNil: [self eventHandler: EventHandlerPlus new]. 255414 self eventHandler on: eventName send: selector to: recipient! ! 255415 255416!PanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 17:26'! 255417on: eventName send: selector to: recipient withValue: value 255418 "Register a recipient for handling an event." 255419 255420 self eventHandler ifNil: [self eventHandler: EventHandlerPlus new]. 255421 self eventHandler on: eventName send: selector to: recipient withValue: value 255422! ! 255423CompositeStub subclass: #PanelStub 255424 instanceVariableNames: '' 255425 classVariableNames: '' 255426 poolDictionaries: '' 255427 category: 'ToolBuilder-SUnit'! 255428DisplayText subclass: #Paragraph 255429 instanceVariableNames: 'clippingRectangle compositionRectangle destinationForm rule mask marginTabsLevel lines lastLine' 255430 classVariableNames: '' 255431 poolDictionaries: 'TextConstants' 255432 category: 'ST80-Support'! 255433!Paragraph commentStamp: '<historical>' prior: 0! 255434I represent displayable text that has been decoraged with margin alignment, line leading, and tab settings.! 255435 255436 255437!Paragraph methodsFor: 'accessing'! 255438backgroundColor 255439 backColor == nil ifTrue: [^ Color white]. 255440 ^ backColor! ! 255441 255442!Paragraph methodsFor: 'accessing'! 255443clippingRectangle 255444 "Answer the rectangle, defined in absolute coordinates, whose 255445 intersection with the destinationForm is the area in which the characters 255446 are constrained to display." 255447 255448 ^clippingRectangle! ! 255449 255450!Paragraph methodsFor: 'accessing' stamp: 'di 10/5/97 15:33'! 255451clippingRectangle: clipRect 255452 clippingRectangle := clipRect! ! 255453 255454!Paragraph methodsFor: 'accessing'! 255455compositionRectangle 255456 "Answer the rectangle whose width is the dimension, modified by 255457 indents and tabsLevels, against which line wraparound is measured. The 255458 height of the compositionRectangle is reset each time recomposition is 255459 required." 255460 255461 ^compositionRectangle! ! 255462 255463!Paragraph methodsFor: 'accessing'! 255464compositionRectangle: compRectangle 255465 "Set the rectangle whose width is the dimension, modified by indents and 255466 tabsLevels, against which line wraparound is measured." 255467 255468 compositionRectangle := compRectangle. 255469 self composeAll! ! 255470 255471!Paragraph methodsFor: 'accessing'! 255472destinationForm 255473 "Answer the Form into which the characters are scanned." 255474 255475 ^destinationForm! ! 255476 255477!Paragraph methodsFor: 'accessing'! 255478fillColor 255479 "Answer the Form with which each character is combined by the scanner 255480 before applying the rule for display." 255481 255482 ^mask! ! 255483 255484!Paragraph methodsFor: 'accessing'! 255485fillColor: maskForm 255486 "Set the argument, maskForm, to be the form with which each character 255487 is combined by the scanner before applying the rule for display." 255488 255489 mask := maskForm! ! 255490 255491!Paragraph methodsFor: 'accessing'! 255492height 255493 "Answer the height of the composition rectangle." 255494 255495 ^compositionRectangle height! ! 255496 255497!Paragraph methodsFor: 'accessing'! 255498indentationOfLineIndex: lineIndex ifBlank: aBlock 255499 "Answer the number of leading tabs in the line at lineIndex. If there are 255500 no visible characters, pass the number of tabs to aBlock and return its value. 255501 If the line is word-wrap overflow, back up a line and recur." 255502 255503 | arrayIndex first last reader leadingTabs lastSeparator cr tab ch | 255504 cr := Character cr. 255505 tab := Character tab. 255506 arrayIndex := lineIndex. 255507 [first := (lines at: arrayIndex) first. 255508 first > 1 and: [(text string at: first - 1) ~~ cr]] whileTrue: "word wrap" 255509 [arrayIndex := arrayIndex - 1]. 255510 last := (lines at: lastLine) last. 255511 reader := ReadStream on: text string from: first to: last. 255512 leadingTabs := 0. 255513 [reader atEnd not and: [(ch := reader next) == tab]] 255514 whileTrue: [leadingTabs := leadingTabs + 1]. 255515 lastSeparator := first - 1 + leadingTabs. 255516 [reader atEnd not and: [ch isSeparator and: [ch ~~ cr]]] 255517 whileTrue: [lastSeparator := lastSeparator + 1. ch := reader next]. 255518 lastSeparator = last | (ch == cr) 255519 ifTrue: [^aBlock value: leadingTabs]. 255520 ^leadingTabs! ! 255521 255522!Paragraph methodsFor: 'accessing'! 255523mask 255524 "Answer the Form with which each character is combined by the scanner 255525 before applying the rule for display." 255526 255527 ^mask! ! 255528 255529!Paragraph methodsFor: 'accessing'! 255530numberOfLines 255531 "Answer the number of lines of text in the receiver." 255532 255533 ^lastLine! ! 255534 255535!Paragraph methodsFor: 'accessing' stamp: 'ar 5/18/2000 18:34'! 255536replaceFrom: start to: stop with: aText displaying: displayBoolean 255537 "Replace the receiver's text starting at position start, stopping at stop, by 255538 the characters in aText. It is expected that most requirements for 255539 modifications to the receiver will call this code. Certainly all cut's or 255540 paste's." 255541 255542 | compositionScanner obsoleteLines obsoleteLastLine firstLineIndex lastLineIndex 255543 startLine stopLine replacementRange visibleRectangle startIndex newLine done 255544 newStop obsoleteY newY moveRectangle | 255545 255546 text replaceFrom: start to: stop with: aText. "Update the text." 255547 lastLine = 0 ifTrue: 255548 ["if lines have never been set up, measure them and display 255549 all the lines falling in the visibleRectangle" 255550 self composeAll. 255551 displayBoolean ifTrue: [^ self displayLines: (1 to: lastLine)]]. 255552 255553 "save -- things get pretty mashed as we go along" 255554 obsoleteLines := lines copy. 255555 obsoleteLastLine := lastLine. 255556 255557 "find the starting and stopping lines" 255558 firstLineIndex := startLine := self lineIndexOfCharacterIndex: start. 255559 stopLine := self lineIndexOfCharacterIndex: stop. 255560 255561 "how many characters being inserted or deleted 255562 -- negative if aText size is < characterInterval size." 255563 replacementRange := aText size - (stop - start + 1). 255564 "Give ourselves plenty of elbow room." 255565 compositionRectangle := compositionRectangle withHeight: (textStyle lineGrid * 9999). 255566 "build a boundingBox of the actual screen space in question -- we'll need it later" 255567 visibleRectangle := (clippingRectangle intersect: compositionRectangle) 255568 intersect: destinationForm boundingBox. 255569 compositionScanner := CompositionScanner new forParagraph: self. "Initialize a scanner." 255570 255571 "If the starting line is not also the first line, then measuring must commence from line preceding the one in which characterInterval start appears. For example, deleting a line with only a carriage return may move characters following the deleted portion of text into the line preceding the deleted line." 255572 startIndex := (lines at: firstLineIndex) first. 255573 startLine > 1 255574 ifTrue: [newLine := compositionScanner composeLine: startLine - 1 255575 fromCharacterIndex: (lines at: startLine - 1) first 255576 inParagraph: self. 255577 (lines at: startLine - 1) = newLine 255578 ifFalse: ["start in line preceding the one with the starting character" 255579 startLine := startLine - 1. 255580 self lineAt: startLine put: newLine. 255581 startIndex := newLine last + 1]]. 255582 startIndex > text size ifTrue: 255583 ["nil lines after a deletion -- remeasure last line below" 255584 self trimLinesTo: (firstLineIndex - 1 max: 0). 255585 text size = 0 ifTrue: 255586 ["entire text deleted -- clear visibleRectangle and return." 255587 displayBoolean ifTrue: [destinationForm fill: visibleRectangle rule: rule fillColor: self backgroundColor]. 255588 self updateCompositionHeight. 255589 ^self]]. 255590 255591 "Now we really get to it." 255592 done := false. 255593 lastLineIndex := stopLine. 255594 [done or: [startIndex > text size]] 255595 whileFalse: 255596 [self lineAt: firstLineIndex put: 255597 (newLine := compositionScanner composeLine: firstLineIndex 255598 fromCharacterIndex: startIndex inParagraph: self). 255599 [(lastLineIndex > obsoleteLastLine 255600 or: ["no more old lines to compare with?" 255601 newLine last < 255602 (newStop := (obsoleteLines at: lastLineIndex) last + replacementRange)]) 255603 or: [done]] 255604 whileFalse: 255605 [newStop = newLine last 255606 ifTrue: ["got the match" 255607 "get source and dest y's for moving the unchanged lines" 255608 obsoleteY := self topAtLineIndex: lastLineIndex + 1 255609 using: obsoleteLines and: obsoleteLastLine. 255610 newY := self topAtLineIndex: firstLineIndex + 1. 255611 stopLine := firstLineIndex. 255612 done := true. 255613 "Fill in the new line vector with the old unchanged lines. 255614 Update their starting and stopping indices on the way." 255615 ((lastLineIndex := lastLineIndex + 1) to: obsoleteLastLine) do: 255616 [:upDatedIndex | 255617 self lineAt: (firstLineIndex := firstLineIndex + 1) 255618 put: ((obsoleteLines at: upDatedIndex) 255619 slide: replacementRange)]. 255620 "trim off obsolete lines, if any" 255621 self trimLinesTo: firstLineIndex] 255622 ifFalse: [lastLineIndex := lastLineIndex + 1]]. 255623 startIndex := newLine last + 1. 255624 firstLineIndex := firstLineIndex + 1]. 255625 255626 "Now the lines are up to date -- Whew!!. What remains is to move 255627 the 'unchanged' lines and display those which have changed." 255628 displayBoolean "Not much to do if not displaying" 255629 ifFalse: [^ self updateCompositionHeight]. 255630 startIndex > text size ifTrue: 255631 ["If at the end of previous lines simply display lines from the line in 255632 which the first character of the replacement occured through the 255633 end of the paragraph." 255634 self updateCompositionHeight. 255635 self displayLines: 255636 (startLine to: (stopLine := firstLineIndex min: lastLine)). 255637 destinationForm "Clear out area at the bottom" 255638 fill: ((visibleRectangle left @ (self topAtLineIndex: lastLine + 1) 255639 extent: visibleRectangle extent) 255640 intersect: visibleRectangle) 255641 rule: rule fillColor: self backgroundColor] 255642 ifFalse: 255643 [newY ~= obsoleteY ifTrue: 255644 ["Otherwise first move the unchanged lines within 255645 the visibleRectangle with a good old bitblt." 255646 moveRectangle := 255647 visibleRectangle left @ (obsoleteY max: visibleRectangle top) 255648 corner: visibleRectangle corner. 255649 destinationForm copyBits: moveRectangle from: destinationForm 255650 at: moveRectangle origin + (0 @ (newY-obsoleteY)) 255651 clippingBox: visibleRectangle 255652 rule: Form over fillColor: nil]. 255653 255654 "Then display the altered lines." 255655 self displayLines: (startLine to: stopLine). 255656 255657 newY < obsoleteY 255658 ifTrue: 255659 [(self topAtLineIndex: obsoleteLastLine+1 using: obsoleteLines and: obsoleteLastLine) > visibleRectangle bottom 255660 ifTrue: 255661 ["A deletion may have 'pulled' previously undisplayed lines 255662 into the visibleRectangle. If so, display them." 255663 self displayLines: 255664 ((self lineIndexOfTop: visibleRectangle bottom - (obsoleteY - newY)) 255665 to: (self lineIndexOfTop: visibleRectangle bottom))]. 255666 "Clear out obsolete material at the bottom of the visibleRectangle." 255667 destinationForm 255668 fill: ((visibleRectangle left @ ((self bottomAtLineIndex: lastLine) + 1) 255669 extent: visibleRectangle extent) 255670 intersect: visibleRectangle) "How about just corner: ??" 255671 rule: rule fillColor: self backgroundColor]. 255672 255673 (newY > obsoleteY and: [obsoleteY < visibleRectangle top]) 255674 ifTrue: 255675 ["An insertion may have 'pushed' previously undisplayed lines 255676 into the visibleRectangle. If so, display them." 255677 self displayLines: 255678 ((self lineIndexOfTop: visibleRectangle top) 255679 to: (self lineIndexOfTop: visibleRectangle top + (newY-obsoleteY)))]. 255680 255681 self updateCompositionHeight]! ! 255682 255683!Paragraph methodsFor: 'accessing'! 255684rule 255685 "Answer the rule according to which character display behaves. For 255686 example, rule may equal over, under, reverse." 255687 255688 ^rule! ! 255689 255690!Paragraph methodsFor: 'accessing'! 255691rule: ruleInteger 255692 "Set the rule according to which character display behaves." 255693 255694 rule := ruleInteger! ! 255695 255696!Paragraph methodsFor: 'accessing' stamp: 'sw 10/29/1999 18:11'! 255697stringAtLineNumber: aNumber 255698 (aNumber > lastLine or: [aNumber < 1]) ifTrue: [^ nil]. 255699 ^ (text string copyFrom: (lines at: aNumber) first to: (lines at: aNumber) last) copyWithout: Character cr! ! 255700 255701!Paragraph methodsFor: 'accessing'! 255702text: aText 255703 "Set the argument, aText, to be the text for the receiver." 255704 255705 text := aText. 255706 self composeAll! ! 255707 255708 255709!Paragraph methodsFor: 'alignment'! 255710centered 255711 "Set the alignment for the style with which the receiver displays its text 255712 so that text is centered in the composition rectangle." 255713 255714 textStyle alignment: Centered! ! 255715 255716!Paragraph methodsFor: 'alignment'! 255717justified 255718 "Set the alignment for the style with which the receiver displays its text 255719 so that the characters in each of text end on an even border in the 255720 composition rectangle." 255721 255722 textStyle alignment: Justified! ! 255723 255724!Paragraph methodsFor: 'alignment'! 255725leftFlush 255726 "Set the alignment for the style with which the receiver displays its text 255727 so that the characters in each of text begin on an even border in the 255728 composition rectangle. This is also known as ragged-right." 255729 255730 textStyle alignment: LeftFlush! ! 255731 255732!Paragraph methodsFor: 'alignment'! 255733rightFlush 255734 "Set the alignment for the style with which the receiver displays its text 255735 so that the characters in each of text end on an even border in the 255736 composition rectangle but the beginning of each line does not. This is 255737 also known as ragged-left." 255738 255739 textStyle alignment: RightFlush! ! 255740 255741!Paragraph methodsFor: 'alignment'! 255742toggleAlignment 255743 "Set the alignment for the style with which the receiver displays its text 255744 so that it moves from centered to justified to leftFlush to rightFlush and 255745 back to centered again." 255746 255747 textStyle alignment: textStyle alignment + 1! ! 255748 255749 255750!Paragraph methodsFor: 'character location' stamp: 'ar 5/18/2000 18:33'! 255751characterBlockAtPoint: aPoint 255752 "Answer a CharacterBlock for characters in the text at point aPoint. It is 255753 assumed that aPoint has been transformed into coordinates appropriate to 255754 the receiver's destinationForm rectangle and the compositionRectangle." 255755 255756 ^CharacterBlockScanner new characterBlockAtPoint: aPoint in: self! ! 255757 255758!Paragraph methodsFor: 'character location' stamp: 'ar 5/18/2000 18:33'! 255759characterBlockForIndex: targetIndex 255760 "Answer a CharacterBlock for character in the text at targetIndex. The 255761 coordinates in the CharacterBlock will be appropriate to the intersection 255762 of the destinationForm rectangle and the compositionRectangle." 255763 255764 ^CharacterBlockScanner new characterBlockForIndex: targetIndex in: self! ! 255765 255766!Paragraph methodsFor: 'character location' stamp: 'di 10/5/1998 12:59'! 255767defaultCharacterBlock 255768 ^ CharacterBlock new stringIndex: 1 text: text 255769 topLeft: compositionRectangle topLeft extent: 0 @ 0! ! 255770 255771 255772!Paragraph methodsFor: 'composition' stamp: 'yo 1/23/2003 22:47'! 255773composeAll 255774 "Compose a collection of characters into a collection of lines." 255775 255776 | startIndex stopIndex lineIndex maximumRightX compositionScanner | 255777 lines := Array new: 32. 255778 lastLine := 0. 255779 maximumRightX := 0. 255780 text size = 0 255781 ifTrue: 255782 [compositionRectangle := compositionRectangle withHeight: 0. 255783 ^maximumRightX]. 255784 startIndex := lineIndex := 1. 255785 stopIndex := text size. 255786 compositionScanner := MultiCompositionScanner new forParagraph: self. 255787 [startIndex > stopIndex] whileFalse: 255788 [self lineAt: lineIndex 255789 put: (compositionScanner composeLine: lineIndex 255790 fromCharacterIndex: startIndex 255791 inParagraph: self). 255792 maximumRightX := compositionScanner rightX max: maximumRightX. 255793 startIndex := (lines at: lineIndex) last + 1. 255794 lineIndex := lineIndex + 1]. 255795 self updateCompositionHeight. 255796 self trimLinesTo: lineIndex - 1. 255797 ^ maximumRightX! ! 255798 255799!Paragraph methodsFor: 'composition'! 255800wrappingBox: compositionRect clippingBox: clippingRect 255801 "Set the composition rectangle for the receiver so that the lines wrap 255802 within the rectangle, compositionRect, and the display of the text is 255803 clipped by the rectangle, clippingRect." 255804 255805 self compositionRectangle: compositionRect copy 255806 text: text 255807 style: textStyle 255808 offset: offset. 255809 clippingRectangle := clippingRect copy! ! 255810 255811 255812!Paragraph methodsFor: 'converting' stamp: 'yo 6/23/2003 19:05'! 255813asForm 255814 "Answer a Form made up of the bits that represent the receiver's displayable text." 255815 | theForm oldBackColor oldForeColor | 255816 textStyle isTTCStyle ifTrue: [ 255817 theForm := (Form extent: compositionRectangle extent depth: 32) 255818 offset: offset. 255819 ] ifFalse: [ 255820 theForm := (ColorForm extent: compositionRectangle extent) 255821 offset: offset; 255822 colors: (Array 255823 with: (backColor == nil ifTrue: [Color transparent] ifFalse: [backColor]) 255824 with: (foreColor == nil ifTrue: [Color black] ifFalse: [foreColor])). 255825 ]. 255826 oldBackColor := backColor. 255827 oldForeColor := foreColor. 255828 backColor := Color white. 255829 foreColor := Color black. 255830 self displayOn: theForm 255831 at: 0@0 255832 clippingBox: theForm boundingBox 255833 rule: Form over 255834 fillColor: nil. 255835 backColor := oldBackColor. 255836 foreColor := oldForeColor. 255837 ^ theForm 255838 255839"Example: 255840| p | 255841p := 'Abc' asParagraph. 255842p foregroundColor: Color red backgroundColor: Color black. 255843p asForm displayOn: Display at: 30@30 rule: Form over" 255844! ! 255845 255846!Paragraph methodsFor: 'converting'! 255847asString 255848 "Answer the string of characters of the receiver's text." 255849 255850 ^text string! ! 255851 255852!Paragraph methodsFor: 'converting'! 255853asText 255854 "Answer the receiver's text." 255855 255856 ^text! ! 255857 255858 255859!Paragraph methodsFor: 'display box access'! 255860boundingBox 255861 255862 ^offset extent: compositionRectangle extent! ! 255863 255864!Paragraph methodsFor: 'display box access'! 255865computeBoundingBox 255866 255867 ^offset extent: compositionRectangle extent! ! 255868 255869 255870!Paragraph methodsFor: 'displaying'! 255871displayOn: aDisplayMedium 255872 "Because Paragraphs cache so much information, computation is avoided 255873 and displayAt: 0@0 is not appropriate here." 255874 255875 self displayOn: aDisplayMedium 255876 at: compositionRectangle topLeft 255877 clippingBox: clippingRectangle 255878 rule: rule 255879 fillColor: mask! ! 255880 255881!Paragraph methodsFor: 'displaying'! 255882displayOn: aDisplayMedium at: aPoint 255883 "Use internal clippingRect; destination cliping is done during actual display." 255884 255885 self displayOn: aDisplayMedium at: aPoint 255886 clippingBox: (clippingRectangle translateBy: aPoint - compositionRectangle topLeft) 255887 rule: rule fillColor: mask! ! 255888 255889!Paragraph methodsFor: 'displaying'! 255890displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 255891 "Default display message when aDisplayPoint is in absolute screen 255892 coordinates." 255893 255894 rule := ruleInteger. 255895 mask := aForm. 255896 clippingRectangle := clipRectangle. 255897 compositionRectangle := aDisplayPoint extent: compositionRectangle extent. 255898 (lastLine == nil or: [lastLine < 1]) ifTrue: [self composeAll]. 255899 self displayOn: aDisplayMedium lines: (1 to: lastLine)! ! 255900 255901!Paragraph methodsFor: 'displaying'! 255902displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 255903 255904 self "Assumes offset has been set!!!!!!!!!!" 255905 displayOn: aDisplayMedium 255906 at: (offset 255907 + (displayTransformation applyTo: relativePoint) 255908 - alignmentPoint) rounded 255909 clippingBox: clipRectangle 255910 rule: ruleInteger 255911 fillColor: aForm. 255912 ! ! 255913 255914 255915!Paragraph methodsFor: 'indicating'! 255916flash 255917 "Complement twice the visible area in which the receiver displays." 255918 255919 Display flash: clippingRectangle! ! 255920 255921!Paragraph methodsFor: 'indicating'! 255922outline 255923 "Display a border around the visible area in which the receiver presents 255924 its text." 255925 255926 clippingRectangle bottom <= compositionRectangle bottom 255927 ifTrue: [Display 255928 border: (clippingRectangle intersect: compositionRectangle) 255929 width: 2] 255930 ifFalse: [Display 255931 border: (clippingRectangle intersect: destinationForm boundingBox) 255932 width: 2]. 255933 ! ! 255934 255935 255936!Paragraph methodsFor: 'scrolling'! 255937scrollBy: heightToMove 255938 ^ self scrollBy: heightToMove withSelectionFrom: nil to: nil! ! 255939 255940!Paragraph methodsFor: 'scrolling' stamp: 'hmm 9/16/2000 21:30'! 255941scrollBy: heightToMove withSelectionFrom: startBlock to: stopBlock 255942 "Translate the composition rectangle up (dy<0) by heightToMove. 255943 Repainting text as necessary, and selection if blocks not nil. 255944 Return true unless scrolling limits have been reached." 255945 | max min amount | 255946 max := 0 max: "cant scroll up more than dist to (top of) bottom line" 255947 compositionRectangle bottom - textStyle lineGrid - clippingRectangle top. 255948 min := 0 min: "cant scroll down more than top is above clipRect" 255949 compositionRectangle top - clippingRectangle top. 255950 amount := ((heightToMove truncateTo: textStyle lineGrid) min: max) max: min. 255951 amount ~= 0 255952 ifTrue: [destinationForm deferUpdatesIn: clippingRectangle while: [ 255953 self scrollUncheckedBy: amount 255954 withSelectionFrom: startBlock to: stopBlock]. 255955 ^ true] 255956 ifFalse: [^ false]! ! 255957 255958!Paragraph methodsFor: 'scrolling'! 255959scrollDelta 255960 "By comparing this before and after, you know if scrolling happened" 255961 ^ clippingRectangle top - compositionRectangle top! ! 255962 255963!Paragraph methodsFor: 'scrolling'! 255964scrollUncheckedBy: heightToMove withSelectionFrom: startBlock to: stopBlock 255965 "Scroll by the given amount. Copy bits where possible, display the rest. 255966 If selection blocks are not nil, then select the newly visible text as well." 255967 | savedClippingRectangle delta | 255968 delta := 0 @ (0 - heightToMove). 255969 compositionRectangle := compositionRectangle translateBy: delta. 255970 startBlock == nil ifFalse: 255971 [startBlock moveBy: delta. 255972 stopBlock moveBy: delta]. 255973 savedClippingRectangle := clippingRectangle. 255974 clippingRectangle := clippingRectangle intersect: Display boundingBox. 255975 heightToMove abs >= clippingRectangle height 255976 ifTrue: 255977 ["Entire visible region must be repainted" 255978 self displayLines: (1 to: lastLine) affectedRectangle: clippingRectangle] 255979 ifFalse: 255980 ["Copy bits where possible / display the rest" 255981 destinationForm 255982 copyBits: clippingRectangle from: destinationForm 255983 at: clippingRectangle topLeft + delta 255984 clippingBox: clippingRectangle 255985 rule: Form over fillColor: nil. 255986 "Set clippingRectangle to 'vacated' area for lines 'pulled' into view." 255987 clippingRectangle := heightToMove < 0 255988 ifTrue: "On the top" 255989 [clippingRectangle topLeft corner: clippingRectangle topRight + delta] 255990 ifFalse: "At the bottom" 255991 [clippingRectangle bottomLeft + delta corner: clippingRectangle bottomRight]. 255992 self displayLines: (1 to: lastLine) "Refresh vacated region" 255993 affectedRectangle: clippingRectangle]. 255994 startBlock == nil ifFalse: 255995 [self reverseFrom: startBlock to: stopBlock]. 255996 "And restore the clippingRectangle to its original value. " 255997 clippingRectangle := savedClippingRectangle! ! 255998 255999 256000!Paragraph methodsFor: 'selecting' stamp: 'ar 5/28/2000 12:10'! 256001caretFormForDepth: depth 256002 "Return a caret form for the given depth." 256003 "(Paragraph new caretFormForDepth: Display depth) displayOn: Display at: 0@0 rule: Form reverse" 256004 256005 | box f bb map | 256006 box := CaretForm boundingBox. 256007 f := Form extent: box extent depth: depth. 256008 map := (Color cachedColormapFrom: CaretForm depth to: depth) copy. 256009 map at: 1 put: (Color transparent pixelValueForDepth: depth). 256010 map at: 2 put: (Color quickHighLight: depth) first. "pixel value for reversing" 256011 bb := BitBlt current toForm: f. 256012 bb 256013 sourceForm: CaretForm; 256014 sourceRect: box; 256015 destOrigin: 0@0; 256016 colorMap: map; 256017 combinationRule: Form over; 256018 copyBits. 256019 ^ f! ! 256020 256021!Paragraph methodsFor: 'selecting' stamp: 'dvf 10/1/2003 13:28'! 256022clickAt: clickPoint for: model controller: aController 256023 "Give sensitive text a chance to fire. Display flash: (100@100 extent: 100@100)." 256024 | startBlock action range box boxes | 256025 action := false. 256026 startBlock := self characterBlockAtPoint: clickPoint. 256027 (text attributesAt: startBlock stringIndex forStyle: textStyle) 256028 do: [:att | att mayActOnClick ifTrue: 256029 [range := text rangeOf: att startingAt: startBlock stringIndex. 256030 boxes := self selectionRectsFrom: (self characterBlockForIndex: range first) 256031 to: (self characterBlockForIndex: range last+1). 256032 box := boxes detect: [:each | each containsPoint: clickPoint] 256033 ifNone: [^ action]. 256034 Utilities awaitMouseUpIn: box repeating: [] 256035 ifSucceed: [aController terminateAndInitializeAround: 256036 [(att actOnClickFor: model in: self at: clickPoint editor: aController) ifTrue: [action := true]]]]]. 256037 ^ action! ! 256038 256039!Paragraph methodsFor: 'selecting'! 256040extendSelectionAt: beginBlock endBlock: endBlock 256041 "Answer with an Array of two CharacterBlocks that represent the text 256042 selection that the user makes." 256043 256044 (self characterBlockAtPoint: Sensor cursorPoint) <= beginBlock 256045 ifTrue: [^self mouseMovedFrom: beginBlock 256046 pivotBlock: endBlock 256047 showingCaret: (beginBlock = endBlock)] 256048 ifFalse: [^self mouseMovedFrom: endBlock 256049 pivotBlock: beginBlock 256050 showingCaret: (beginBlock = endBlock)] 256051! ! 256052 256053!Paragraph methodsFor: 'selecting' stamp: 'th 9/19/2002 17:27'! 256054extendSelectionMark: markBlock pointBlock: pointBlock 256055 "Answer with an Array of two CharacterBlocks that represent the text 256056 selection that the user makes." 256057 true 256058 ifTrue:[^self mouseMovedFrom: pointBlock 256059 pivotBlock: markBlock 256060 showingCaret:(pointBlock = markBlock)] 256061 ifFalse: 256062 [ | beginBlock endBlock | 256063 beginBlock := markBlock min: pointBlock. 256064 endBlock := markBlock max: endBlock. 256065 256066 (self characterBlockAtPoint: Sensor cursorPoint) <= beginBlock 256067 ifTrue: [^self mouseMovedFrom: beginBlock 256068 pivotBlock: endBlock 256069 showingCaret: (beginBlock = endBlock)] 256070 ifFalse: [^self mouseMovedFrom: endBlock 256071 pivotBlock: beginBlock 256072 showingCaret: (beginBlock = endBlock)] 256073 ] 256074! ! 256075 256076!Paragraph methodsFor: 'selecting' stamp: 'jm 7/1/1999 12:31'! 256077hiliteRect: rect 256078 256079 | highlightColor | 256080 highlightColor := Color quickHighLight: destinationForm depth. 256081 rect ifNotNil: [ 256082 destinationForm 256083 fill: rect 256084 rule: Form reverse 256085 fillColor: highlightColor. 256086 "destinationForm 256087 fill: (rect translateBy: 1@1) 256088 rule: Form reverse 256089 fillColor: highlightColor" ]. 256090! ! 256091 256092!Paragraph methodsFor: 'selecting' stamp: 'jm 7/8/97 12:25'! 256093mouseMovedFrom: beginBlock pivotBlock: pivotBlock showingCaret: caretOn 256094 | startBlock stopBlock showingCaret | 256095 stopBlock := startBlock := beginBlock. 256096 showingCaret := caretOn. 256097 [Sensor redButtonPressed] 256098 whileTrue: 256099 [stopBlock := self characterBlockAtPoint: Sensor cursorPoint. 256100 stopBlock = startBlock 256101 ifFalse: 256102 [showingCaret 256103 ifTrue: 256104 [showingCaret := false. 256105 self reverseFrom: pivotBlock to: pivotBlock]. 256106 ((startBlock >= pivotBlock and: [stopBlock >= pivotBlock]) 256107 or: [startBlock <= pivotBlock and: [stopBlock <= pivotBlock]]) 256108 ifTrue: 256109 [self reverseFrom: startBlock to: stopBlock. 256110 startBlock := stopBlock] 256111 ifFalse: 256112 [self reverseFrom: startBlock to: pivotBlock. 256113 self reverseFrom: pivotBlock to: stopBlock. 256114 startBlock := stopBlock]. 256115 (clippingRectangle containsRect: stopBlock) ifFalse: 256116 [stopBlock top < clippingRectangle top 256117 ifTrue: [self scrollBy: stopBlock top - clippingRectangle top 256118 withSelectionFrom: pivotBlock to: stopBlock] 256119 ifFalse: [self scrollBy: stopBlock bottom + textStyle lineGrid - clippingRectangle bottom 256120 withSelectionFrom: pivotBlock to: stopBlock]]]]. 256121 pivotBlock = stopBlock ifTrue: 256122 [showingCaret ifFalse: "restore caret" 256123 [self reverseFrom: pivotBlock to: pivotBlock]]. 256124 ^ Array with: pivotBlock with: stopBlock! ! 256125 256126!Paragraph methodsFor: 'selecting'! 256127mouseSelect 256128 "Answer with an Array of two CharacterBlocks that represent the text 256129 selection that the user makes. Return quickly if the button is noticed up 256130 to make double-click more responsive." 256131 256132 | pivotBlock startBlock stopBlock origPoint stillDown | 256133 stillDown := Sensor redButtonPressed. 256134 pivotBlock := startBlock := stopBlock := 256135 self characterBlockAtPoint: (origPoint := Sensor cursorPoint). 256136 stillDown := stillDown and: [Sensor redButtonPressed]. 256137 self reverseFrom: startBlock to: startBlock. 256138 [stillDown and: [Sensor cursorPoint = origPoint]] whileTrue: 256139 [stillDown := Sensor redButtonPressed]. 256140 (stillDown and: [clippingRectangle containsPoint: Sensor cursorPoint]) 256141 ifFalse: [^Array with: pivotBlock with: stopBlock]. 256142 ^ self mouseMovedFrom: startBlock 256143 pivotBlock: pivotBlock 256144 showingCaret: true! ! 256145 256146!Paragraph methodsFor: 'selecting'! 256147mouseSelect: clickPoint 256148 "Track text selection and answer with an Array of two CharacterBlocks." 256149 | startBlock | 256150 startBlock := self characterBlockAtPoint: clickPoint. 256151 self reverseFrom: startBlock to: startBlock. 256152 ^ self mouseMovedFrom: startBlock 256153 pivotBlock: startBlock 256154 showingCaret: true! ! 256155 256156!Paragraph methodsFor: 'selecting'! 256157reverseFrom: characterBlock1 to: characterBlock2 256158 "Reverse area between the two character blocks given as arguments." 256159 | visibleRectangle initialRectangle interiorRectangle finalRectangle lineNo baseline caret | 256160 characterBlock1 = characterBlock2 ifTrue: 256161 [lineNo := self lineIndexOfCharacterIndex: characterBlock1 stringIndex. 256162 baseline := lineNo = 0 ifTrue: [textStyle baseline] 256163 ifFalse: [(lines at: lineNo) baseline]. 256164 caret := self caretFormForDepth: Display depth. 256165 ^ caret "Use a caret to indicate null selection" 256166 displayOn: destinationForm 256167 at: characterBlock1 topLeft + (-3 @ baseline) 256168 clippingBox: clippingRectangle 256169 rule: (false "Display depth>8" ifTrue: [9 "not-reverse"] 256170 ifFalse: [Form reverse]) 256171 fillColor: nil]. 256172 visibleRectangle := 256173 (clippingRectangle intersect: compositionRectangle) 256174 "intersect: destinationForm boundingBox" "not necessary". 256175 characterBlock1 top = characterBlock2 top 256176 ifTrue: [characterBlock1 left < characterBlock2 left 256177 ifTrue: 256178 [initialRectangle := 256179 (characterBlock1 topLeft corner: characterBlock2 bottomLeft) 256180 intersect: visibleRectangle] 256181 ifFalse: 256182 [initialRectangle := 256183 (characterBlock2 topLeft corner: characterBlock1 bottomLeft) 256184 intersect: visibleRectangle]] 256185 ifFalse: [characterBlock1 top < characterBlock2 top 256186 ifTrue: 256187 [initialRectangle := 256188 (characterBlock1 topLeft 256189 corner: visibleRectangle right @ characterBlock1 bottom) 256190 intersect: visibleRectangle. 256191 characterBlock1 bottom = characterBlock2 top 256192 ifTrue: 256193 [finalRectangle := 256194 (visibleRectangle left @ characterBlock2 top 256195 corner: characterBlock2 bottomLeft) 256196 intersect: visibleRectangle] 256197 ifFalse: 256198 [interiorRectangle := 256199 (visibleRectangle left @ characterBlock1 bottom 256200 corner: visibleRectangle right 256201 @ characterBlock2 top) 256202 intersect: visibleRectangle. 256203 finalRectangle := 256204 (visibleRectangle left @ characterBlock2 top 256205 corner: characterBlock2 bottomLeft) 256206 intersect: visibleRectangle]] 256207 ifFalse: 256208 [initialRectangle := 256209 (visibleRectangle left @ characterBlock1 top 256210 corner: characterBlock1 bottomLeft) 256211 intersect: visibleRectangle. 256212 characterBlock1 top = characterBlock2 bottom 256213 ifTrue: 256214 [finalRectangle := 256215 (characterBlock2 topLeft 256216 corner: visibleRectangle right 256217 @ characterBlock2 bottom) 256218 intersect: visibleRectangle] 256219 ifFalse: 256220 [interiorRectangle := 256221 (visibleRectangle left @ characterBlock2 bottom 256222 corner: visibleRectangle right @ characterBlock1 top) 256223 intersect: visibleRectangle. 256224 finalRectangle := 256225 (characterBlock2 topLeft 256226 corner: visibleRectangle right 256227 @ characterBlock2 bottom) 256228 intersect: visibleRectangle]]]. 256229 self hiliteRect: initialRectangle. 256230 self hiliteRect: interiorRectangle. 256231 self hiliteRect: finalRectangle.! ! 256232 256233!Paragraph methodsFor: 'selecting' stamp: 'di 12/1/97 04:43'! 256234selectionRectsFrom: characterBlock1 to: characterBlock2 256235 "Return an array of rectangles representing the area between the two character blocks given as arguments." 256236 | visibleRectangle initialRectangle interiorRectangle finalRectangle lineNo baseline | 256237 characterBlock1 = characterBlock2 ifTrue: 256238 [lineNo := self lineIndexOfCharacterIndex: characterBlock1 stringIndex. 256239 baseline := lineNo = 0 ifTrue: [textStyle baseline] 256240 ifFalse: [(lines at: lineNo) baseline]. 256241 ^ Array with: (characterBlock1 topLeft extent: 1 @ baseline)]. 256242 visibleRectangle := clippingRectangle intersect: compositionRectangle. 256243 characterBlock1 top = characterBlock2 top 256244 ifTrue: [characterBlock1 left < characterBlock2 left 256245 ifTrue: 256246 [initialRectangle := 256247 (characterBlock1 topLeft corner: characterBlock2 bottomLeft) 256248 intersect: visibleRectangle] 256249 ifFalse: 256250 [initialRectangle := 256251 (characterBlock2 topLeft corner: characterBlock1 bottomLeft) 256252 intersect: visibleRectangle]] 256253 ifFalse: [characterBlock1 top < characterBlock2 top 256254 ifTrue: 256255 [initialRectangle := 256256 (characterBlock1 topLeft 256257 corner: visibleRectangle right @ characterBlock1 bottom) 256258 intersect: visibleRectangle. 256259 characterBlock1 bottom = characterBlock2 top 256260 ifTrue: 256261 [finalRectangle := 256262 (visibleRectangle left @ characterBlock2 top 256263 corner: characterBlock2 bottomLeft) 256264 intersect: visibleRectangle] 256265 ifFalse: 256266 [interiorRectangle := 256267 (visibleRectangle left @ characterBlock1 bottom 256268 corner: visibleRectangle right 256269 @ characterBlock2 top) 256270 intersect: visibleRectangle. 256271 finalRectangle := 256272 (visibleRectangle left @ characterBlock2 top 256273 corner: characterBlock2 bottomLeft) 256274 intersect: visibleRectangle]] 256275 ifFalse: 256276 [initialRectangle := 256277 (visibleRectangle left @ characterBlock1 top 256278 corner: characterBlock1 bottomLeft) 256279 intersect: visibleRectangle. 256280 characterBlock1 top = characterBlock2 bottom 256281 ifTrue: 256282 [finalRectangle := 256283 (characterBlock2 topLeft 256284 corner: visibleRectangle right 256285 @ characterBlock2 bottom) 256286 intersect: visibleRectangle] 256287 ifFalse: 256288 [interiorRectangle := 256289 (visibleRectangle left @ characterBlock2 bottom 256290 corner: visibleRectangle right @ characterBlock1 top) 256291 intersect: visibleRectangle. 256292 finalRectangle := 256293 (characterBlock2 topLeft 256294 corner: visibleRectangle right 256295 @ characterBlock2 bottom) 256296 intersect: visibleRectangle]]]. 256297 ^ (Array with: initialRectangle with: interiorRectangle with: finalRectangle) 256298 select: [:rect | rect notNil]! ! 256299 256300 256301!Paragraph methodsFor: 'utilities'! 256302clearVisibleRectangle 256303 "Display the area in which the receiver presents its text so that the area 256304 is all one tone--in this case, all white." 256305 256306 destinationForm 256307 fill: clippingRectangle 256308 rule: rule 256309 fillColor: self backgroundColor! ! 256310 256311!Paragraph methodsFor: 'utilities'! 256312deepCopy 256313 "Don't want to copy the destForm (Display) or fonts in the TextStyle. 9/13/96 tk" 256314 256315 | new | 256316 new := self copy. 256317 new textStyle: textStyle copy. 256318 new destinationForm: destinationForm. 256319 new lines: lines copy. 256320 new text: text deepCopy. 256321 ^ new! ! 256322 256323!Paragraph methodsFor: 'utilities'! 256324destinationForm: destForm 256325 destinationForm := destForm! ! 256326 256327!Paragraph methodsFor: 'utilities'! 256328fit 256329 "Make the bounding rectangle of the receiver contain all the text without 256330 changing the width of the receiver's composition rectangle." 256331 256332 [(self lineIndexOfTop: clippingRectangle top) = 1] 256333 whileFalse: [self scrollBy: (0-1)*textStyle lineGrid]. 256334 self updateCompositionHeight. 256335 clippingRectangle := clippingRectangle withBottom: compositionRectangle bottom! ! 256336 256337!Paragraph methodsFor: 'utilities'! 256338lines: lineArray 256339 lines := lineArray! ! 256340 256341!Paragraph methodsFor: 'utilities'! 256342visibleRectangle 256343 "May be less than the clippingRectangle if text ends part way down. 256344 Also some fearful history includes Display intersection; 256345 it shouldn't be necessary" 256346 256347 ^ (clippingRectangle intersect: compositionRectangle) 256348 intersect: destinationForm boundingBox! ! 256349 256350 256351!Paragraph methodsFor: 'private'! 256352bottomAtLineIndex: lineIndex 256353 "Answer the bottom y of given line." 256354 | y | 256355 y := compositionRectangle top. 256356 lastLine = 0 ifTrue: [^ y + textStyle lineGrid]. 256357 1 to: (lineIndex min: lastLine) do: 256358 [:i | y := y + (lines at: i) lineHeight]. 256359 ^ y 256360! ! 256361 256362!Paragraph methodsFor: 'private' stamp: 'tk 9/30/96'! 256363compositionRectangle: compositionRect text: aText style: aTextStyle offset: aPoint 256364 256365 compositionRectangle := compositionRect copy. 256366 text := aText. 256367 textStyle := aTextStyle. 256368 rule := DefaultRule. 256369 mask := nil. "was DefaultMask " 256370 marginTabsLevel := 0. 256371 destinationForm := Display. 256372 offset := aPoint. 256373 ^self composeAll! ! 256374 256375!Paragraph methodsFor: 'private'! 256376compositionRectangleDelta 256377 "A handy number -- mostly for scrolling." 256378 256379 ^compositionRectangle top - clippingRectangle top! ! 256380 256381!Paragraph methodsFor: 'private'! 256382displayLines: linesInterval 256383 ^ self displayLines: linesInterval 256384 affectedRectangle: self visibleRectangle! ! 256385 256386!Paragraph methodsFor: 'private' stamp: 'yo 1/23/2003 22:48'! 256387displayLines: linesInterval affectedRectangle: affectedRectangle 256388 "This is the first level workhorse in the display portion of the TextForm routines. 256389 It checks to see which lines in the interval are actually visible, has the 256390 CharacterScanner display only those, clears out the areas in which display will 256391 occur, and clears any space remaining in the visibleRectangle following the space 256392 occupied by lastLine." 256393 256394 | lineGrid topY firstLineIndex lastLineIndex lastLineIndexBottom | 256395 256396 "Save some time by only displaying visible lines" 256397 firstLineIndex := self lineIndexOfTop: affectedRectangle top. 256398 firstLineIndex < linesInterval first ifTrue: [firstLineIndex := linesInterval first]. 256399 lastLineIndex := self lineIndexOfTop: affectedRectangle bottom - 1. 256400 lastLineIndex > linesInterval last ifTrue: 256401 [linesInterval last > lastLine 256402 ifTrue: [lastLineIndex := lastLine] 256403 ifFalse: [lastLineIndex := linesInterval last]]. 256404 lastLineIndexBottom := (self bottomAtLineIndex: lastLineIndex). 256405 ((Rectangle 256406 origin: affectedRectangle left @ (topY := self topAtLineIndex: firstLineIndex) 256407 corner: affectedRectangle right @ lastLineIndexBottom) 256408 intersects: affectedRectangle) 256409 ifTrue: [ " . . . (skip to clear-below if no lines displayed)" 256410 MultiDisplayScanner new 256411 displayLines: (firstLineIndex to: lastLineIndex) 256412 in: self clippedBy: affectedRectangle]. 256413 lastLineIndex = lastLine ifTrue: 256414 [destinationForm "Clear out white space below last line" 256415 fill: (affectedRectangle left @ (lastLineIndexBottom max: affectedRectangle top) 256416 corner: affectedRectangle bottomRight) 256417 rule: rule fillColor: self backgroundColor]! ! 256418 256419!Paragraph methodsFor: 'private'! 256420displayOn: aDisplayMedium lines: lineInterval 256421 256422 | saveDestinationForm | 256423 saveDestinationForm := destinationForm. 256424 destinationForm := aDisplayMedium. 256425 self displayLines: lineInterval. 256426 destinationForm := saveDestinationForm! ! 256427 256428!Paragraph methodsFor: 'private'! 256429leftMarginForCompositionForLine: lineIndex 256430 "Build the left margin for composition of a line. Depends upon 256431 marginTabsLevel and the indent." 256432 256433 | indent | 256434 lineIndex = 1 256435 ifTrue: [indent := textStyle firstIndent] 256436 ifFalse: [indent := textStyle restIndent]. 256437 ^indent + (textStyle leftMarginTabAt: marginTabsLevel)! ! 256438 256439!Paragraph methodsFor: 'private' stamp: 'ar 12/15/2001 23:29'! 256440leftMarginForDisplayForLine: lineIndex alignment: alignment 256441 "Build the left margin for display of a line. Depends upon 256442 leftMarginForComposition, compositionRectangle left and the alignment." 256443 256444 | pad | 256445 (alignment = LeftFlush or: [alignment = Justified]) 256446 ifTrue: 256447 [^compositionRectangle left 256448 + (self leftMarginForCompositionForLine: lineIndex)]. 256449 "When called from character location code and entire string has been cut, 256450 there are no valid lines, hence following nil check." 256451 (lineIndex <= lines size and: [(lines at: lineIndex) notNil]) 256452 ifTrue: 256453 [pad := (lines at: lineIndex) paddingWidth] 256454 ifFalse: 256455 [pad := 256456 compositionRectangle width - textStyle firstIndent - textStyle rightIndent]. 256457 alignment = Centered 256458 ifTrue: 256459 [^compositionRectangle left 256460 + (self leftMarginForCompositionForLine: lineIndex) + (pad // 2)]. 256461 alignment = RightFlush 256462 ifTrue: 256463 [^compositionRectangle left 256464 + (self leftMarginForCompositionForLine: lineIndex) + pad]. 256465 self error: ['no such alignment']! ! 256466 256467!Paragraph methodsFor: 'private'! 256468lineAt: indexInteger put: aTextLineInterval 256469 "Store a line, track last, and grow lines if necessary." 256470 indexInteger > lastLine ifTrue: [lastLine := indexInteger]. 256471 lastLine > lines size ifTrue: [lines := lines , (Array new: lines size)]. 256472 ^lines at: indexInteger put: aTextLineInterval! ! 256473 256474!Paragraph methodsFor: 'private'! 256475lineIndexOfCharacterIndex: characterIndex 256476 "Answer the line index for a given characterIndex." 256477 256478 1 to: lastLine do: 256479 [:lineIndex | 256480 (lines at: lineIndex) last >= characterIndex ifTrue: [^lineIndex]]. 256481 ^lastLine! ! 256482 256483!Paragraph methodsFor: 'private'! 256484lineIndexOfTop: top 256485 "Answer the line index at a given top y." 256486 | y line | 256487 lastLine = 0 ifTrue: [^ 1]. 256488 y := compositionRectangle top. 256489 1 to: lastLine do: 256490 [:i | line := lines at: i. 256491 (y := y + line lineHeight) > top ifTrue: [^ i]]. 256492 ^ lastLine 256493! ! 256494 256495!Paragraph methodsFor: 'private'! 256496lines 256497 256498 ^lines! ! 256499 256500!Paragraph methodsFor: 'private'! 256501moveBy: delta 256502 compositionRectangle := compositionRectangle translateBy: delta. 256503 clippingRectangle := clippingRectangle translateBy: delta. 256504! ! 256505 256506!Paragraph methodsFor: 'private'! 256507rightMarginForComposition 256508 "Build the right margin for a line. Depends upon compositionRectangle 256509 width, marginTabsLevel, and right indent." 256510 256511 ^compositionRectangle width 256512 - (textStyle rightMarginTabAt: marginTabsLevel) 256513 - textStyle rightIndent! ! 256514 256515!Paragraph methodsFor: 'private'! 256516rightMarginForDisplay 256517 "Build the right margin for a line. Depends upon compositionRectangle 256518 rightSide, marginTabsLevel, and right indent." 256519 256520 ^compositionRectangle right - 256521 textStyle rightIndent - (textStyle rightMarginTabAt: marginTabsLevel)! ! 256522 256523!Paragraph methodsFor: 'private'! 256524setWithText: aText style: aTextStyle 256525 "Set text and adjust bounding rectangles to fit." 256526 256527 | shrink compositionWidth unbounded | 256528 unbounded := Rectangle origin: 0 @ 0 extent: 9999@9999. 256529 compositionWidth := self 256530 setWithText: aText style: aTextStyle compositionRectangle: unbounded clippingRectangle: unbounded. 256531 compositionRectangle := compositionRectangle withWidth: compositionWidth. 256532 clippingRectangle := compositionRectangle copy. 256533 shrink := unbounded width - compositionWidth. 256534 "Shrink padding widths accordingly" 256535 1 to: lastLine do: 256536 [:i | (lines at: i) paddingWidth: (lines at: i) paddingWidth - shrink]! ! 256537 256538!Paragraph methodsFor: 'private'! 256539setWithText: aText style: aTextStyle compositionRectangle: compRect clippingRectangle: clipRect 256540 "Set text and using supplied parameters. Answer max composition width." 256541 256542 clippingRectangle := clipRect copy. 256543 ^self 256544 compositionRectangle: compRect 256545 text: aText 256546 style: aTextStyle 256547 offset: 0 @ 0! ! 256548 256549!Paragraph methodsFor: 'private'! 256550setWithText: aText style: aTextStyle compositionRectangle: compRect clippingRectangle: clipRect foreColor: cf backColor: cb 256551 "Set text and using supplied parameters. Answer max composition width." 256552 256553 clippingRectangle := clipRect copy. 256554 self foregroundColor: cf backgroundColor: cb. 256555 ^ self 256556 compositionRectangle: compRect 256557 text: aText 256558 style: aTextStyle 256559 offset: 0 @ 0! ! 256560 256561!Paragraph methodsFor: 'private'! 256562topAtLineIndex: lineIndex 256563 "Answer the top y of given line." 256564 | y | 256565 y := compositionRectangle top. 256566 lastLine = 0 ifTrue: [lineIndex > 0 ifTrue: [^ y + textStyle lineGrid]. ^ y]. 256567 1 to: (lineIndex-1 min: lastLine) do: 256568 [:i | y := y + (lines at: i) lineHeight]. 256569 ^ y 256570! ! 256571 256572!Paragraph methodsFor: 'private'! 256573topAtLineIndex: lineIndex using: otherLines and: otherLastLine 256574 "Answer the top y of given line." 256575 | y | 256576 y := compositionRectangle top. 256577 otherLastLine = 0 ifTrue: [^ y]. 256578 1 to: (lineIndex-1 min: otherLastLine) do: 256579 [:i | y := y + (otherLines at: i) lineHeight]. 256580 ^ y 256581! ! 256582 256583!Paragraph methodsFor: 'private'! 256584trimLinesTo: lastLineInteger 256585 256586 (lastLineInteger + 1 to: lastLine) do: [:i | lines at: i put: nil]. 256587 (lastLine := lastLineInteger) < (lines size // 2) 256588 ifTrue: [lines := lines copyFrom: 1 to: lines size - (lines size // 2)]! ! 256589 256590!Paragraph methodsFor: 'private'! 256591updateCompositionHeight 256592 "Mainly used to insure that intersections with compositionRectangle work." 256593 256594 compositionRectangle := compositionRectangle withHeight: 256595 (self bottomAtLineIndex: lastLine) - compositionRectangle top. 256596 (text size ~= 0 and: [(text at: text size) = CR]) 256597 ifTrue: [compositionRectangle := compositionRectangle withHeight: 256598 compositionRectangle height + (lines at: lastLine) lineHeight]! ! 256599 256600!Paragraph methodsFor: 'private' stamp: 'di 8/30/97 11:14'! 256601withClippingRectangle: clipRect do: aBlock 256602 | saveClip | 256603 saveClip := clippingRectangle. 256604 clippingRectangle := clipRect. 256605 aBlock value. 256606 clippingRectangle := saveClip! ! 256607 256608"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 256609 256610Paragraph class 256611 instanceVariableNames: ''! 256612 256613!Paragraph class methodsFor: 'examples' stamp: 'tk 9/30/96'! 256614example 256615 "This simple example illustrates how to display a few lines of text on the screen at the current cursor point. 256616 Fixed. " 256617 256618 | para point | 256619 point := Sensor waitButton. 256620 para := 'This is the first line of characters 256621and this is the second line.' asParagraph. 256622 para displayOn: Display at: point. 256623 256624 "Paragraph example"! ! 256625 256626 256627!Paragraph class methodsFor: 'instance creation'! 256628new 256629 "Do not allow an uninitialized view. Create with text that has no 256630 characters." 256631 256632 ^self withText: '' asText! ! 256633 256634!Paragraph class methodsFor: 'instance creation'! 256635withText: aText 256636 "Answer an instance of me with text set to aText and style set to the 256637 system's default text style." 256638 256639 ^self withText: aText style: DefaultTextStyle copy! ! 256640 256641!Paragraph class methodsFor: 'instance creation'! 256642withText: aText style: aTextStyle 256643 "Answer an instance of me with text set to aText and style set to 256644 aTextStyle." 256645 256646 ^super new setWithText: aText style: aTextStyle! ! 256647 256648!Paragraph class methodsFor: 'instance creation'! 256649withText: aText style: aTextStyle compositionRectangle: compRect clippingRectangle: clipRect foreColor: c1 backColor: c2 256650 "Answer an instance of me with text set to aText and style set to 256651 aTextStyle, composition rectangle is compRect and the clipping rectangle 256652 is clipRect." 256653 | para | 256654 para := super new. 256655 para setWithText: aText 256656 style: aTextStyle 256657 compositionRectangle: compRect 256658 clippingRectangle: clipRect 256659 foreColor: c1 backColor: c2. 256660 ^para! ! 256661Object subclass: #ParagraphEditor 256662 instanceVariableNames: 'model paragraph startBlock stopBlock beginTypeInBlock emphasisHere initialText selectionShowing otherInterval lastParentLocation' 256663 classVariableNames: 'ChangeText CmdActions FindText ShiftCmdActions UndoInterval UndoMessage UndoParagraph UndoSelection Undone' 256664 poolDictionaries: 'TextConstants' 256665 category: 'Kernel-ST80 Remnants'! 256666!ParagraphEditor commentStamp: '<historical>' prior: 0! 256667I am a Controller for editing a Paragraph. I am a kind of ScrollController, so that more text can be created for the Paragraph than can be viewed on the screen. Editing messages are sent by issuing commands from a yellow button menu or from keys on the keyboard. My instances keep control as long as the cursor is within the view when the red or yellow mouse button is pressed; they give up control if the blue button is pressed.! 256668 256669 256670!ParagraphEditor methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/5/2009 12:35'! 256671disabledCommandActions 256672 "Answer the command actions available when disabled." 256673 256674 ^#(#browseItHere: #compareToClipboard: #methodStringsContainingIt: #fileItIn: #cursorTopHome: 256675 #exploreIt: #doAgainMany: #selectCurrentTypeIn: #referencesToIt: #search: #methodNamesContainingIt: 256676 #offerMenuFromEsc: #cursorLeft: #cursorRight: #cursorUp: #cursorDown: #cursorPageUp: #cursorPageDown: 256677 #selectWord #browseItHere: #compareToClipboard: #duplicate: #methodStringsContainingIt: 256678 #selectAll: #browseIt: #copySelection: #doIt: #find: #findAgain: #setSearchString: #inspectIt: 256679 #doAgainOnce: #implementorsOfIt: #sendersOfIt: #spawnIt: #querySymbol: #tempCommand: #backWord:)! ! 256680 256681!ParagraphEditor methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/13/2009 12:38'! 256682handleDisabledKey: anEvent 256683 "Handle a key character when the text morph is disabled." 256684 256685 |ascii cmds cmd| 256686 ascii := anEvent keyValue. 256687 ascii < 256 ifFalse: [^self]. 256688 cmds := #(). cmd := nil. 256689 (anEvent commandKeyPressed or: [self class specialShiftCmdKeys includes: ascii]) ifTrue: [ 256690 cmd := anEvent shiftPressed 256691 ifTrue: [ShiftCmdActions at: ascii + 1] 256692 ifFalse: [CmdActions at: ascii + 1]. 256693 Preferences cmdKeysInText 256694 ifTrue: [cmds := self disabledCommandActions] 256695 ifFalse: [cmds := #(copySelection: selectAll:)]]. 256696 (cmds includes: cmd) ifTrue: [ 256697 self deselect. 256698 (cmd numArgs = 1 256699 ifTrue: [self perform: cmd with: String new readStream] 256700 ifFalse: [self perform: cmd with: String new readStream with: anEvent]) 256701 ifTrue: [self 256702 doneTyping; 256703 setEmphasisHere; 256704 selectAndScroll; 256705 updateMarker]]! ! 256706 256707 256708!ParagraphEditor methodsFor: '*tools' stamp: 'alain.plantec 6/11/2008 14:59'! 256709browseChangeSetsWithSelector 256710 "Determine which, if any, change sets have at least one change for the selected selector, independent of class" 256711 256712 | aSelector | 256713 self lineSelectAndEmptyCheck: [^ self]. 256714 (aSelector := self selectedSelector) == nil ifTrue: [^ self flash]. 256715 self terminateAndInitializeAround: [ChangeSorter browseChangeSetsWithSelector: aSelector]! ! 256716 256717!ParagraphEditor methodsFor: '*tools' stamp: 'alain.plantec 6/11/2008 14:59'! 256718browseItHere 256719 "Retarget the receiver's window to look at the selected class, if appropriate. 3/1/96 sw" 256720 | aSymbol foundClass b | 256721 (((b := model) isKindOf: Browser) and: [b couldBrowseAnyClass]) 256722 ifFalse: [^ self flash]. 256723 model okToChange ifFalse: [^ self flash]. 256724 self selectionInterval isEmpty ifTrue: [self selectWord]. 256725 (aSymbol := self selectedSymbol) isNil ifTrue: [^ self flash]. 256726 256727 self terminateAndInitializeAround: 256728 [foundClass := (Smalltalk at: aSymbol ifAbsent: [nil]). 256729 foundClass isNil ifTrue: [^ self flash]. 256730 (foundClass isKindOf: Class) 256731 ifTrue: 256732 [model systemCategoryListIndex: 256733 (model systemCategoryList indexOf: foundClass category). 256734 model classListIndex: (model classList indexOf: foundClass name)]]! ! 256735 256736!ParagraphEditor methodsFor: '*tools' stamp: 'alain.plantec 5/30/2008 14:03'! 256737debug: aCompiledMethod receiver: anObject in: evalContext 256738 256739 | selector guineaPig debugger context | 256740 selector := evalContext isNil ifTrue: [#DoIt] ifFalse: [#DoItIn:]. 256741 anObject class addSelectorSilently: selector withMethod: aCompiledMethod. 256742 guineaPig := evalContext isNil 256743 ifTrue: [[anObject DoIt] newProcess] 256744 ifFalse: [[anObject DoItIn: evalContext] newProcess]. 256745 context := guineaPig suspendedContext. 256746 debugger := Debugger new 256747 process: guineaPig 256748 controller: nil 256749 context: context 256750 isolationHead: nil. 256751 debugger openFullNoSuspendLabel: 'Debug it'. 256752 [debugger interruptedContext method == aCompiledMethod] 256753 whileFalse: [debugger send]. 256754 anObject class basicRemoveSelector: selector! ! 256755 256756!ParagraphEditor methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 256757debugIt 256758 256759 | method receiver context | 256760 (model respondsTo: #doItReceiver) 256761 ifTrue: 256762 [FakeClassPool adopt: model selectedClass. 256763 receiver := model doItReceiver. 256764 context := model doItContext] 256765 ifFalse: 256766 [receiver := context := nil]. 256767 self lineSelectAndEmptyCheck: [^self]. 256768 method := self compileSelectionFor: receiver in: context. 256769 method notNil ifTrue: 256770 [self debug: method receiver: receiver in: context]. 256771 FakeClassPool adopt: nil! ! 256772 256773 256774!ParagraphEditor methodsFor: 'accessing' stamp: 'tk 4/21/1998 09:55'! 256775initialText 256776 ^ initialText! ! 256777 256778!ParagraphEditor methodsFor: 'accessing'! 256779replace: oldInterval with: newText and: selectingBlock 256780 "Replace the text in oldInterval with newText and execute selectingBlock to establish the new selection. Create an undoAndReselect:redoAndReselect: undoer to allow perfect undoing." 256781 256782 | undoInterval | 256783 undoInterval := self selectionInterval. 256784 undoInterval = oldInterval ifFalse: [self selectInterval: oldInterval]. 256785 UndoSelection := self selection. 256786 self zapSelectionWith: newText. 256787 selectingBlock value. 256788 otherInterval := self selectionInterval. 256789 self undoer: #undoAndReselect:redoAndReselect: with: undoInterval with: otherInterval! ! 256790 256791!ParagraphEditor methodsFor: 'accessing'! 256792replaceSelectionWith: aText 256793 "Remember the selection text in UndoSelection. 256794 Deselect, and replace the selection text by aText. 256795 Remember the resulting selectionInterval in UndoInterval and PriorInterval. 256796 Set up undo to use UndoReplace." 256797 256798 beginTypeInBlock ~~ nil ifTrue: [^self zapSelectionWith: aText]. "called from old code" 256799 UndoSelection := self selection. 256800 self zapSelectionWith: aText. 256801 self undoer: #undoReplace! ! 256802 256803!ParagraphEditor methodsFor: 'accessing'! 256804setSearch: aString 256805 "Set the FindText and ChangeText to seek aString; except if already seeking aString, leave ChangeText alone so again will repeat last replacement." 256806 256807 FindText string = aString 256808 ifFalse: [FindText := ChangeText := aString asText]! ! 256809 256810!ParagraphEditor methodsFor: 'accessing'! 256811text 256812 "Answer the text of the paragraph being edited." 256813 256814 ^paragraph text! ! 256815 256816!ParagraphEditor methodsFor: 'accessing' stamp: 'jm 3/18/98 20:38'! 256817userHasEdited 256818 "Note that the user has edited my text. Here it is just a noop so that the Character Recognizer won't fail when used with a vanilla ParagrahEditor." 256819! ! 256820 256821 256822!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:22'! 256823hasCaret 256824 ^self markBlock = self pointBlock! ! 256825 256826!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:22'! 256827hasSelection 256828 ^self hasCaret not! ! 256829 256830!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 16:13'! 256831mark 256832 ^ self markBlock stringIndex! ! 256833 256834!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 10/21/2003 15:49'! 256835markBlock 256836 ^ stopBlock! ! 256837 256838!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 10/21/2003 15:49'! 256839markBlock: aCharacterBlock 256840 stopBlock := aCharacterBlock. 256841! ! 256842 256843!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 12:31'! 256844markIndex 256845 ^ self markBlock stringIndex! ! 256846 256847!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 10/21/2003 15:49'! 256848pointBlock 256849 ^ startBlock! ! 256850 256851!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 10/21/2003 15:49'! 256852pointBlock: aCharacterBlock 256853 startBlock := aCharacterBlock. 256854! ! 256855 256856!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 12:31'! 256857pointIndex 256858 ^ self pointBlock stringIndex! ! 256859 256860!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'yo 7/31/2004 16:27'! 256861selection 256862 "Answer the text in the paragraph that is currently selected." 256863 256864 | t | 256865 t := paragraph text copyFrom: self startIndex to: self stopIndex - 1. 256866 t string isOctetString ifTrue: [t asOctetStringText]. 256867 ^ t. 256868! ! 256869 256870!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:10'! 256871selectionAsStream 256872 "Answer a ReadStream on the text in the paragraph that is currently 256873 selected." 256874 256875 ^ReadWriteStream 256876 on: paragraph string 256877 from: self startIndex 256878 to: self stopIndex - 1! ! 256879 256880!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 16:18'! 256881selectionInterval 256882 "Answer the interval that is currently selected." 256883 256884 ^self startIndex to: self stopIndex - 1 ! ! 256885 256886!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 13:02'! 256887setMark: anIndex 256888 self markBlock: (paragraph characterBlockForIndex: anIndex) 256889! ! 256890 256891!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 13:02'! 256892setPoint: anIndex 256893 self pointBlock: (paragraph characterBlockForIndex: anIndex) 256894! ! 256895 256896!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 16:10'! 256897startBlock 256898 ^ self pointBlock min: self markBlock! ! 256899 256900!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 13:10'! 256901startBlock: aCharacterBlock 256902 self markBlock: aCharacterBlock! ! 256903 256904!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 14:27'! 256905startIndex 256906 ^ self startBlock stringIndex! ! 256907 256908!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 16:14'! 256909stopBlock 256910 ^ self pointBlock max: self markBlock! ! 256911 256912!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 13:10'! 256913stopBlock: aCharacterBlock 256914 self pointBlock: aCharacterBlock! ! 256915 256916!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 14:27'! 256917stopIndex 256918 ^ self stopBlock stringIndex! ! 256919 256920!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 16:23'! 256921unselect 256922 self markBlock: self pointBlock copy.! ! 256923 256924!ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:12'! 256925zapSelectionWith: aText 256926 "Deselect, and replace the selection text by aText. 256927 Remember the resulting selectionInterval in UndoInterval and otherInterval. 256928 Do not set up for undo." 256929 256930 | start stop | 256931 self deselect. 256932 start := self startIndex. 256933 stop := self stopIndex. 256934 (aText isEmpty and: [stop > start]) ifTrue: 256935 ["If deleting, then set emphasisHere from 1st character of the deletion" 256936 emphasisHere := (paragraph text attributesAt: start forStyle: paragraph textStyle) 256937 select: [:att | att mayBeExtended]]. 256938 (start = stop and: [aText size = 0]) ifFalse: 256939 [paragraph 256940 replaceFrom: start 256941 to: stop - 1 256942 with: aText 256943 displaying: true. 256944 self computeIntervalFrom: start to: start + aText size - 1. 256945 UndoInterval := otherInterval := self selectionInterval]! ! 256946 256947 256948!ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'dvf 7/28/2003 14:54'! 256949activateTextActions 256950 (paragraph text attributesAt: startBlock stringIndex) 256951 do: [:att | att actOnClickFor: model in: paragraph]! ! 256952 256953!ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'michael.rueger 2/23/2009 12:41'! 256954offerMenuFromEsc: aStream 256955 self yellowButtonActivity. 256956 ^true "tell the caller that the character was processed "! ! 256957 256958!ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'michael.rueger 2/23/2009 18:37'! 256959terminateAndInitializeAround: aBlock 256960 "1/12/96 sw" 256961 self controlTerminate. 256962 aBlock value. 256963 self controlInitialize! ! 256964 256965!ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:40'! 256966totalTextHeight 256967 256968 ^paragraph boundingBox height! ! 256969 256970!ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:33'! 256971visibleHeight 256972 256973 ^paragraph clippingRectangle height! ! 256974 256975 256976!ParagraphEditor methodsFor: 'controlling'! 256977controlInitialize 256978 256979 super controlInitialize. 256980 self recomputeInterval. 256981 self initializeSelection. 256982 beginTypeInBlock := nil! ! 256983 256984!ParagraphEditor methodsFor: 'controlling'! 256985controlTerminate 256986 256987 self closeTypeIn. "Must call to establish UndoInterval" 256988 super controlTerminate. 256989 self deselect! ! 256990 256991 256992!ParagraphEditor methodsFor: 'current selection'! 256993deselect 256994 "If the text selection is visible on the screen, reverse its highlight." 256995 256996 selectionShowing ifTrue: [self reverseSelection]! ! 256997 256998!ParagraphEditor methodsFor: 'current selection'! 256999initializeSelection 257000 "Do the initial activity when starting up the receiver. For example, in the 257001 ParagraphEditor highlight the current selection." 257002 257003 self select! ! 257004 257005!ParagraphEditor methodsFor: 'current selection' stamp: 'th 9/20/2002 11:41'! 257006recomputeInterval 257007 "The same characters are selected but their coordinates may have changed." 257008 257009 self computeIntervalFrom: self mark to: self pointIndex - 1! ! 257010 257011!ParagraphEditor methodsFor: 'current selection'! 257012recomputeSelection 257013 "Redetermine the selection according to the start and stop block indices; 257014 do not highlight." 257015 257016 self deselect; recomputeInterval! ! 257017 257018!ParagraphEditor methodsFor: 'current selection' stamp: 'BG 12/12/2003 12:50'! 257019reverseSelection 257020 "Reverse the valence of the current selection highlighting." 257021 selectionShowing := selectionShowing not. 257022 paragraph reverseFrom: self pointBlock to: self markBlock! ! 257023 257024!ParagraphEditor methodsFor: 'current selection'! 257025select 257026 "If the text selection is visible on the screen, highlight it." 257027 257028 selectionShowing ifFalse: [self reverseSelection]! ! 257029 257030!ParagraphEditor methodsFor: 'current selection' stamp: 'th 9/19/2002 18:47'! 257031selectAndScroll 257032 "Scroll until the selection is in the view and then highlight it." 257033 | lineHeight deltaY clippingRectangle endBlock | 257034 self select. 257035 endBlock := self stopBlock. 257036 lineHeight := paragraph textStyle lineGrid. 257037 clippingRectangle := paragraph clippingRectangle. 257038 deltaY := endBlock top - clippingRectangle top. 257039 deltaY >= 0 257040 ifTrue: [deltaY := endBlock bottom - clippingRectangle bottom max: 0]. 257041 "check if stopIndex below bottom of clippingRectangle" 257042 deltaY ~= 0 257043 ifTrue: [self scrollBy: (deltaY abs + lineHeight - 1 truncateTo: lineHeight) 257044 * deltaY sign]! ! 257045 257046!ParagraphEditor methodsFor: 'current selection' stamp: 'th 9/19/2002 18:48'! 257047selectAndScrollToTop 257048 "Scroll until the selection is in the view and then highlight it." 257049 | lineHeight deltaY clippingRectangle | 257050 self select. 257051 lineHeight := paragraph textStyle lineGrid. 257052 clippingRectangle := paragraph clippingRectangle. 257053 deltaY := self stopBlock top - clippingRectangle top. 257054 deltaY ~= 0 257055 ifTrue: [self scrollBy: (deltaY abs + lineHeight - 1 truncateTo: lineHeight) 257056 * deltaY sign]! ! 257057 257058 257059!ParagraphEditor methodsFor: 'displaying' stamp: 'alain.plantec 6/11/2008 15:04'! 257060display 257061 "Redisplay the paragraph." 257062 257063 | selectionState view | 257064 self haltOnce. 257065 selectionState := selectionShowing. 257066 self deselect. 257067 paragraph foregroundColor: view foregroundColor 257068 backgroundColor: view backgroundColor; 257069 displayOn: Display. 257070 selectionState ifTrue: [self select]! ! 257071 257072!ParagraphEditor methodsFor: 'displaying'! 257073flash 257074 "Causes the view of the paragraph to complement twice in succession." 257075 257076 paragraph flash! ! 257077 257078 257079!ParagraphEditor methodsFor: 'do-its' stamp: 'MikeRoberts 9/20/2009 12:26'! 257080compileSelectionFor: anObject in: evalContext 257081 257082 | methodNode method | 257083 methodNode := [Compiler new 257084 compileNoPattern: self selectionAsStream 257085 in: anObject class 257086 context: evalContext 257087 notifying: self 257088 ifFail: [^nil]] 257089 on: OutOfScopeNotification 257090 do: [:ex | ex resume: true]. 257091 method := methodNode generate: #(0 0 0 0). 257092 ^method copyWithTempsFromMethodNode: methodNode! ! 257093 257094!ParagraphEditor methodsFor: 'do-its' stamp: 'di 5/10/1998 21:38'! 257095doIt 257096 "Set the context to include pool vars of the model. Then evaluate." 257097 ^ self evaluateSelection. 257098! ! 257099 257100!ParagraphEditor methodsFor: 'do-its' stamp: 'gk 3/3/2004 17:15'! 257101evaluateSelection 257102 "Treat the current selection as an expression; evaluate it and return the result" 257103 | result rcvr ctxt | 257104 self lineSelectAndEmptyCheck: [^ '']. 257105 257106 (model respondsTo: #doItReceiver) 257107 ifTrue: [FakeClassPool adopt: model selectedClass. "Include model pool vars if any" 257108 rcvr := model doItReceiver. 257109 ctxt := model doItContext] 257110 ifFalse: [rcvr := ctxt := nil]. 257111 result := [ 257112 rcvr class evaluatorClass new 257113 evaluate: self selectionAsStream 257114 in: ctxt 257115 to: rcvr 257116 notifying: self 257117 ifFail: [FakeClassPool adopt: nil. ^ #failedDoit] 257118 logged: true. 257119 ] 257120 on: OutOfScopeNotification 257121 do: [ :ex | ex resume: true]. 257122 FakeClassPool adopt: nil. 257123 ^ result! ! 257124 257125!ParagraphEditor methodsFor: 'do-its' stamp: 'alain.plantec 6/11/2008 15:08'! 257126exploreIt 257127 | result | 257128 result := self evaluateSelection. 257129 ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) 257130 ifTrue: [self flash] 257131 ifFalse: [result explore]. 257132! ! 257133 257134!ParagraphEditor methodsFor: 'do-its' stamp: 'alain.plantec 6/11/2008 15:09'! 257135inspectIt 257136 "1/13/96 sw: minor fixup" 257137 | result | 257138 result := self evaluateSelection. 257139 ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) 257140 ifTrue: [self flash] 257141 ifFalse: [result inspect]. 257142! ! 257143 257144!ParagraphEditor methodsFor: 'do-its' stamp: 'alain.plantec 6/11/2008 15:25'! 257145objectsReferencingIt 257146 "Open a list inspector on all objects that reference the object that results when the current selection is evaluated. " 257147 | result | 257148 self terminateAndInitializeAround: [ 257149 result := self evaluateSelection. 257150 ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) 257151 ifTrue: [self flash] 257152 ifFalse: [self systemNavigation 257153 browseAllObjectReferencesTo: result 257154 except: #() 257155 ifNone: [:obj | self flash]]. 257156 ]! ! 257157 257158!ParagraphEditor methodsFor: 'do-its' stamp: 'alain.plantec 6/11/2008 15:12'! 257159printIt 257160 "Treat the current text selection as an expression; evaluate it. Insert the 257161 description of the result of evaluation after the selection and then make 257162 this description the new text selection." 257163 | result | 257164 result := self evaluateSelection. 257165 ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) 257166 ifTrue: [self flash] 257167 ifFalse: [self afterSelectionInsertAndSelect: result printString]! ! 257168 257169!ParagraphEditor methodsFor: 'do-its' stamp: 'ab 3/23/2005 16:49'! 257170tallyIt 257171 257172 ^ self tallySelection! ! 257173 257174!ParagraphEditor methodsFor: 'do-its' stamp: 'AdrianLienhard 8/26/2009 22:06'! 257175tallySelection 257176 "Treat the current selection as an expression; evaluate and tally it." 257177 | v receiver context compiledMethod | 257178 257179 (model respondsTo: #doItReceiver) 257180 ifTrue: 257181 [FakeClassPool adopt: model selectedClass. "Include model pool vars if any" 257182 receiver := model doItReceiver. 257183 context := model doItContext] 257184 ifFalse: 257185 [receiver := context := nil]. 257186 self lineSelectAndEmptyCheck: [ ^ self ]. 257187 257188 [ 257189 compiledMethod := self compileSelectionFor: receiver in: context. 257190 compiledMethod ifNil: [^ self]. 257191 MessageTally spyOn: [ 257192 v := compiledMethod valueWithReceiver: receiver arguments: #()]. 257193 ] 257194 on: OutOfScopeNotification 257195 do: [ :ex | ex resume: true]. 257196 FakeClassPool adopt: nil. 257197 257198 self inform: ('Result: ', (v printStringLimitedTo: 20)). 257199! ! 257200 257201 257202!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:20'! 257203align: characterStream 257204 "Triggered by Cmd-u; cycle through alignment alternatives. 8/11/96 sw" 257205 257206 self align. 257207 ^ true! ! 257208 257209!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:31'! 257210browseIt: characterStream 257211 "Triggered by Cmd-B; browse the thing represented by the current selection, if plausible. 1/18/96 sw" 257212 257213 self browseIt. 257214 ^ true! ! 257215 257216!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:31'! 257217browseItHere: characterStream 257218 "Triggered by Cmd-shift-B; browse the thing represented by the current selection, if plausible, in the receiver's own window. 3/1/96 sw" 257219 257220 self browseItHere. 257221 ^ true! ! 257222 257223!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:31'! 257224cancel: characterStream 257225 "Cancel unsubmitted changes. Flushes typeahead. 1/12/96 sw 257226 1/22/96 sw: put in control terminate/init" 257227 257228 self terminateAndInitializeAround: [self cancel]. 257229 ^ true! ! 257230 257231!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 13:48'! 257232changeEmphasis: characterStream keyEvent: keyEvent 257233 "Change the emphasis of the current selection or prepare to 257234 accept characters with the change in emphasis. Emphasis 257235 change amounts to a font change. Keeps typeahead." 257236 257237 | keyCode attribute oldAttributes index thisSel colors extras | 257238 257239 "control 0..9 -> 0..9" 257240 keyCode := ('0123456789-=' indexOf: keyEvent keyCharacter ifAbsent: [1]) - 1. 257241 257242 oldAttributes := paragraph text attributesAt: self pointIndex forStyle: paragraph textStyle. 257243 thisSel := self selection. 257244 257245 "Decipher keyCodes for Command 0-9..." 257246 (keyCode between: 1 and: 5) ifTrue: [ 257247 attribute := TextFontChange fontNumber: keyCode 257248 ]. 257249 257250 keyCode = 6 ifTrue: [ 257251 | labels lines | 257252 colors := #(#black #magenta #red #yellow #green #blue #cyan #white ). 257253 extras := (self class name = #TextMorphEditor and: [(self morph isKindOf: TextMorphForEditView) not]) 257254 ifTrue: ["not a system window" #()] 257255 ifFalse: [#('Link to comment of class' 'Link to definition of class' 'Link to hierarchy of class' 'Link to method' )]. 257256 257257 257258 labels := colors , #('choose color...' 'Do it' 'Print it' ) , extras , #('be a web URL link' 'Edit hidden info' 'Copy hidden info' ). 257259 lines := Array with: colors size + 1. 257260 index := UIManager default chooseFrom: labels lines: lines. 257261 index = 0 ifTrue: [ ^ true]. 257262 257263 index <= colors size ifTrue: [ 257264 attribute := TextColor color: (Color perform: (colors at: index)) 257265 ] 257266 ifFalse: [ 257267 index := index - colors size - 1. "Re-number!!!!!!" 257268 257269 index = 0 ifTrue: [ 257270 attribute := self chooseColor 257271 ]. 257272 257273 index = 1 ifTrue: [ 257274 attribute := TextDoIt new. 257275 thisSel := attribute analyze: self selection asString 257276 ]. 257277 257278 index = 2 ifTrue: [ 257279 attribute := TextPrintIt new. 257280 thisSel := attribute analyze: self selection asString 257281 ]. 257282 257283 extras size = 0 & (index > 2) ifTrue: [ 257284 index := index + 4 "skip those" 257285 ]. 257286 257287 index = 3 ifTrue: [ 257288 attribute := TextLink new. 257289 thisSel := attribute analyze: self selection asString with: 'Comment' 257290 ]. 257291 257292 index = 4 ifTrue: [ 257293 attribute := TextLink new. 257294 thisSel := attribute analyze: self selection asString with: 'Definition' 257295 ]. 257296 257297 index = 5 ifTrue: [ 257298 attribute := TextLink new. 257299 thisSel := attribute analyze: self selection asString with: 'Hierarchy' 257300 ]. 257301 257302 index = 6 ifTrue: [ 257303 attribute := TextLink new. 257304 thisSel := attribute analyze: self selection asString 257305 ]. 257306 257307 index = 7 ifTrue: [ 257308 attribute := TextURL new. 257309 thisSel := attribute analyze: self selection asString 257310 ]. 257311 257312 index = 8 ifTrue: [ 257313 "Edit hidden info" 257314 thisSel := self hiddenInfo. "includes selection" 257315 attribute := TextEmphasis normal 257316 ]. 257317 257318 index = 9 ifTrue: [ 257319 "Copy hidden info" 257320 self copyHiddenInfo. 257321 ^ true 257322 ]. 257323 257324 "no other action" 257325 thisSel 257326 ifNil: [ ^ true ] 257327 ] 257328 ]. 257329 257330 (keyCode between: 7 and: 11) ifTrue: [ 257331 keyEvent leftShiftDown ifTrue: [ 257332 keyCode = 10 ifTrue: [ 257333 attribute := TextKern kern: -1 257334 ]. 257335 keyCode = 11 ifTrue: [ 257336 attribute := TextKern kern: 1 257337 ] 257338 ] 257339 ifFalse: [ 257340 attribute := TextEmphasis perform: (#(#bold #italic #narrow #underlined #struckOut ) at: keyCode - 6). 257341 oldAttributes 257342 do: [:att | (att dominates: attribute) ifTrue: [attribute turnOff]] 257343 ] 257344 ]. 257345 257346 keyCode = 0 257347 ifTrue: [attribute := TextEmphasis normal]. 257348 257349 beginTypeInBlock ~~ nil ifTrue: [ 257350 "only change emphasisHere while typing" 257351 self insertTypeAhead: characterStream. 257352 emphasisHere := Text addAttribute: attribute toArray: oldAttributes. 257353 ^ true 257354 ]. 257355 257356 self 257357 replaceSelectionWith: (thisSel asText addAttribute: attribute). 257358 257359 ^ true 257360! ! 257361 257362!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:32'! 257363changeLfToCr: characterStream 257364 "Replace all LFs by CRs. 257365 Triggered by Cmd-U -- useful when getting code from FTP sites" 257366 | cr lf | 257367 cr := Character cr. lf := Character linefeed. 257368 self replaceSelectionWith: (Text fromString: 257369 (self selection string collect: [:c | c = lf ifTrue: [cr] ifFalse: [c]])). 257370 ^ true! ! 257371 257372!ParagraphEditor methodsFor: 'editing keys' stamp: 'tk 5/7/2001 09:11'! 257373chooseColor 257374 "Make a new Text Color Attribute, let the user pick a color, and return the attribute. This is the non-Morphic version." 257375 257376 ^ TextColor color: (Color fromUser)! ! 257377 257378!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:32'! 257379compareToClipboard: characterStream 257380 "Compare the receiver to the text on the clipboard. Flushes typeahead. 5/1/96 sw" 257381 257382 self terminateAndInitializeAround: [self compareToClipboard]. 257383 ^ true! ! 257384 257385!ParagraphEditor methodsFor: 'editing keys' stamp: 'tk 5/7/2001 08:47'! 257386copyHiddenInfo 257387 "In TextLinks, TextDoits, TextColor, and TextURLs, there is hidden 257388info. Copy that to the clipboard. You can paste it and see what it is. 257389Usually enclosed in <>." 257390 257391 ^ self clipboardTextPut: self hiddenInfo asText! ! 257392 257393!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:32'! 257394copySelection: characterStream 257395 "Copy the current text selection. Flushes typeahead." 257396 257397 self copySelection. 257398 ^true! ! 257399 257400!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:33'! 257401cut: characterStream 257402 "Cut out the current text selection. Flushes typeahead." 257403 257404 self cut. 257405 ^true! ! 257406 257407!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 3/23/2009 17:48'! 257408debugIt: characterStream 257409 "Triggered by Cmd-D; browse the thing represented by the current selection, if plausible" 257410 257411 self debugIt. 257412 ^ true! ! 257413 257414!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:33'! 257415doIt: characterStream 257416 "Called when user hits cmd-d. Select the current line, if relevant, then evaluate and execute. 2/1/96 sw. 257417 2/29/96 sw: don't call selectLine; it's done by doIt now" 257418 257419 self terminateAndInitializeAround: [self doIt]. 257420 ^ true! ! 257421 257422!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:33'! 257423duplicate: characterStream 257424 "Paste the current selection over the prior selection, if it is non-overlapping and 257425 legal. Flushes typeahead. Undoer & Redoer: undoAndReselect." 257426 257427 self closeTypeIn. 257428 (self hasSelection and: [self isDisjointFrom: otherInterval]) 257429 ifTrue: "Something to duplicate" 257430 [self replace: otherInterval with: self selection and: 257431 [self selectAt: self pointIndex]] 257432 ifFalse: 257433 [self flash]. 257434 ^true! ! 257435 257436!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 13:25'! 257437enclose: characterStream keyEvent: keyEvent 257438 "Insert or remove bracket characters around the current selection. 257439 Flushes typeahead." 257440 257441 | char left right startIndex stopIndex oldSelection which text | 257442 char := keyEvent keyCharacter. 257443 self closeTypeIn. 257444 startIndex := self startIndex. 257445 stopIndex := self stopIndex. 257446 oldSelection := self selection. 257447 which := '([<{"''' indexOf: char ifAbsent: [ ^true ]. 257448 left := '([<{"''' at: which. 257449 right := ')]>}"''' at: which. 257450 text := paragraph text. 257451 ((startIndex > 1 and: [stopIndex <= text size]) 257452 and: 257453 [(text at: startIndex-1) = left and: [(text at: stopIndex) = right]]) 257454 ifTrue: 257455 ["already enclosed; strip off brackets" 257456 self selectFrom: startIndex-1 to: stopIndex. 257457 self replaceSelectionWith: oldSelection] 257458 ifFalse: 257459 ["not enclosed; enclose by matching brackets" 257460 self replaceSelectionWith: 257461 (Text string: (String with: left), oldSelection string ,(String with: right) 257462 emphasis: emphasisHere). 257463 self selectFrom: startIndex+1 to: stopIndex]. 257464 ^true! ! 257465 257466!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:34'! 257467exchange: characterStream 257468 "Exchange the current and prior selections. Keeps typeahead." 257469 257470 self closeTypeIn: characterStream. 257471 self exchange. 257472 ^true! ! 257473 257474!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:34'! 257475exploreIt: characterStream 257476 "Explore the selection -- invoked via cmd-shift-I. If there is no current selection, use the current line." 257477 257478 self terminateAndInitializeAround: [self exploreIt]. 257479 ^ true! ! 257480 257481!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:34'! 257482fileItIn: characterStream 257483 "File in the selection; invoked via a keyboard shortcut, -- for now, cmd-shift-G." 257484 257485 self terminateAndInitializeAround: [self fileItIn]. 257486 ^ true! ! 257487 257488!ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/18/2002 16:31'! 257489hiddenInfo 257490 "In TextLinks, TextDoits, TextColor, and TextURLs, there is hidden info. Return the entire string that was used by Cmd-6 to create this text attribute. Usually enclosed in < >." 257491 257492 | attrList | 257493 attrList := paragraph text attributesAt: (self pointIndex + 257494self markIndex)//2 forStyle: paragraph textStyle. 257495 attrList do: [:attr | 257496 (attr isKindOf: TextAction) ifTrue: 257497 [^ self selection asString, '<', attr info, '>']]. 257498 "If none of the above" 257499 attrList do: [:attr | 257500 attr class == TextColor ifTrue: 257501 [^ self selection asString, '<', attr color printString, '>']]. 257502 ^ self selection asString, '[No hidden info]'! ! 257503 257504!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:36'! 257505implementorsOfIt: characterStream 257506 "Triggered by Cmd-m; browse implementors of the selector represented by the current selection, if plausible. 2/1/96 sw" 257507 257508 self implementorsOfIt. 257509 ^ true! ! 257510 257511!ParagraphEditor methodsFor: 'editing keys' stamp: 'stephane.ducasse 3/31/2009 21:16'! 257512inOutdent: characterStream delta: delta 257513 "Add/remove a tab at the front of every line occupied by the selection. Flushes typeahead. Derived from work by Larry Tesler back in December 1985. Now triggered by Cmd-L and Cmd-R. 2/29/96 sw" 257514 257515 | cr realStart realStop lines startLine stopLine start stop adjustStart indentation size numLines inStream newString outStream | 257516 257517cr := Character cr. 257518 257519 "Operate on entire lines, but remember the real selection for re-highlighting later" 257520 realStart := self startIndex. 257521 realStop := self stopIndex - 1. 257522 257523 "Special case a caret on a line of its own, including weird case at end of paragraph" 257524 (realStart > realStop and: 257525 [realStart < 2 or: [(paragraph string at: realStart - 1) == cr]]) 257526 ifTrue: 257527 [delta < 0 257528 ifTrue: 257529 [self flash] 257530 ifFalse: 257531 [self replaceSelectionWith: Character tab asSymbol asText. 257532 self selectAt: realStart + 1]. 257533 ^ true]. 257534 257535 lines := paragraph lines. 257536 startLine := paragraph lineIndexOfCharacterIndex: realStart. 257537 stopLine := paragraph lineIndexOfCharacterIndex: (realStart max: realStop). 257538 start := (lines at: startLine) first. 257539 stop := (lines at: stopLine) last. 257540 257541 "Pin the start of highlighting unless the selection starts a line" 257542 adjustStart := realStart > start. 257543 257544 "Find the indentation of the least-indented non-blank line; never outdent more" 257545 indentation := (startLine to: stopLine) inject: 1000 into: 257546 [:m :l | 257547 m min: (paragraph indentationOfLineIndex: l ifBlank: [:tabs | 1000])]. 257548 257549 size := stop + 1 - start. 257550 numLines := stopLine + 1 - startLine. 257551 inStream := ReadStream on: paragraph string from: start to: stop. 257552 257553 newString := WideString new: size + ((numLines * delta) max: 0). 257554 outStream := ReadWriteStream on: newString. 257555 257556 "This subroutine does the actual work" 257557 self indent: delta fromStream: inStream toStream: outStream. 257558 257559 "Adjust the range that will be highlighted later" 257560 adjustStart ifTrue: [realStart := (realStart + delta) max: start]. 257561 realStop := realStop + outStream position - size. 257562 257563 "Prepare for another iteration" 257564 indentation := indentation + delta. 257565 size := outStream position. 257566 inStream := outStream setFrom: 1 to: size. 257567 257568 outStream == nil 257569 ifTrue: "tried to outdent but some line(s) were already left flush" 257570 [self flash] 257571 ifFalse: 257572 [self selectInvisiblyFrom: start to: stop. 257573 size = newString size ifFalse: [newString := outStream contents]. 257574 self replaceSelectionWith: newString asText]. 257575 self selectFrom: realStart to: realStop. "highlight only the original range" 257576 ^ true! ! 257577 257578!ParagraphEditor methodsFor: 'editing keys'! 257579indent: characterStream 257580 "Add a tab at the front of every line occupied by the selection. Flushes typeahead. Invoked from keyboard via cmd-shift-R. 2/29/96 sw" 257581 257582 ^ self inOutdent: characterStream delta: 1! ! 257583 257584!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:37'! 257585inspectIt: characterStream 257586 "Inspect the selection -- invoked via cmd-i. If there is no current selection, use the current line. 1/17/96 sw 257587 2/29/96 sw: don't call selectLine; it's done by inspectIt now" 257588 257589self terminateAndInitializeAround: [self inspectIt]. 257590 ^ true! ! 257591 257592!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:37'! 257593makeCapitalized: characterStream 257594 "Force the current selection to be capitalized. Triggered by Cmd-Z." 257595 | prev | 257596prev := $-. "not a letter" 257597 self replaceSelectionWith: (Text fromString: 257598 (self selection string collect: 257599 [:c | prev := prev isLetter ifTrue: [c asLowercase] ifFalse: [c asUppercase]])). 257600 ^ true! ! 257601 257602!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:37'! 257603makeLowercase: characterStream 257604 "Force the current selection to lowercase. Triggered by Cmd-X." 257605 257606 self replaceSelectionWith: (Text fromString: (self selection string asLowercase)). 257607 ^ true! ! 257608 257609!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:37'! 257610makeUppercase: characterStream 257611 "Force the current selection to uppercase. Triggered by Cmd-Y." 257612 257613 self replaceSelectionWith: (Text fromString: (self selection string asUppercase)). 257614 ^ true! ! 257615 257616!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:37'! 257617methodNamesContainingIt: characterStream 257618 "Browse methods whose selectors containing the selection in their names" 257619 257620 self methodNamesContainingIt. 257621 ^ true! ! 257622 257623!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:37'! 257624methodStringsContainingIt: characterStream 257625 "Invoked from cmd-E -- open a browser on all methods holding string constants containing it. Flushes typeahead. " 257626 257627 self methodStringsContainingit. 257628 ^ true! ! 257629 257630!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:40'! 257631noop: characterStream 257632 "Unimplemented keyboard command; just ignore it." 257633 257634 ^ true 257635! ! 257636 257637!ParagraphEditor methodsFor: 'editing keys' stamp: 'alain.plantec 2/6/2009 17:17'! 257638offerFontMenu 257639 "Present a menu of available fonts, and if one is chosen, apply it to the current selection. 257640 Use only names of Fonts of this paragraph " 257641 257642 | aList reply | 257643 aList := paragraph textStyle fontNamesWithPointSizes. 257644 reply := UIManager default chooseFrom: aList values: aList. 257645 reply ~~ nil ifTrue: 257646 [self replaceSelectionWith: 257647 (Text string: self selection asString 257648 attribute: (TextFontChange fontNumber: (aList indexOf: reply)))] ! ! 257649 257650!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:40'! 257651offerFontMenu: characterStream 257652 "The user typed the command key that requests a font change; Offer the font menu. 5/27/96 sw 257653 Keeps typeahead. (?? should flush?)" 257654 257655 self closeTypeIn: characterStream. 257656 self offerFontMenu. 257657 ^ true! ! 257658 257659!ParagraphEditor methodsFor: 'editing keys'! 257660outdent: characterStream 257661 "Remove a tab from the front of every line occupied by the selection. Flushes typeahead. Invoked from keyboard via cmd-shift-L. 2/29/96 sw" 257662 257663 ^ self inOutdent: characterStream delta: -1! ! 257664 257665!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:41'! 257666paste: characterStream 257667 "Replace the current text selection by the text in the shared buffer. 257668 Keeps typeahead." 257669 257670 self closeTypeIn: characterStream. 257671 self paste. 257672 ^true! ! 257673 257674!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:41'! 257675pasteInitials: characterStream 257676 "Replace the current text selection by an authorship name/date stamp; invoked by cmd-shift-v, easy way to put an authorship stamp in the comments of an editor. 257677 Keeps typeahead." 257678 257679 self closeTypeIn: characterStream. 257680 self replace: self selectionInterval with: (Text fromString: Utilities changeStamp) and: [self selectAt: self stopIndex]. 257681 ^ true! ! 257682 257683!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:41'! 257684printIt: characterStream 257685 "Print the results of evaluting the selection -- invoked via cmd-p. If there is no current selection, use the current line. 1/17/96 sw 257686 2/29/96 sw: don't call selectLine now, since it's called by doIt" 257687 257688 self terminateAndInitializeAround: [self printIt]. 257689 ^ true! ! 257690 257691!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:41'! 257692referencesToIt: characterStream 257693 "Triggered by Cmd-N; browse references to the current selection" 257694 257695 self referencesToIt. 257696 ^ true! ! 257697 257698!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:41'! 257699save: characterStream 257700 "Submit the current text. Equivalent to 'accept' 1/18/96 sw 257701 Keeps typeahead." 257702 257703 self closeTypeIn: characterStream. 257704 self terminateAndInitializeAround: [self accept]. 257705 ^ true! ! 257706 257707!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:42'! 257708sendersOfIt: characterStream 257709 "Triggered by Cmd-n; browse implementors of the selector represented by the current selection, if plausible. 2/1/96 sw" 257710 257711 self sendersOfIt. 257712 ^ true! ! 257713 257714!ParagraphEditor methodsFor: 'editing keys' stamp: 'yo 5/27/2004 13:56'! 257715setEmphasis: emphasisSymbol 257716 "Change the emphasis of the current selection." 257717 257718 | oldAttributes attribute | 257719 oldAttributes := paragraph text attributesAt: self selectionInterval first forStyle: paragraph textStyle. 257720 257721 attribute := TextEmphasis perform: emphasisSymbol. 257722 (emphasisSymbol == #normal) 257723 ifFalse: [oldAttributes do: 257724 [:att | (att dominates: attribute) ifTrue: [attribute turnOff]]]. 257725 self replaceSelectionWith: (self selection addAttribute: attribute)! ! 257726 257727!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 13:22'! 257728shiftEnclose: characterStream keyEvent: keyEvent 257729 "Insert or remove bracket characters around the current selection. 257730 Flushes typeahead." 257731 257732 | char left right startIndex stopIndex oldSelection which text | 257733 char := keyEvent keyCharacter. 257734 char = $9 ifTrue: [ char := $( ]. 257735 char = $, ifTrue: [ char := $< ]. 257736 char = $[ ifTrue: [ char := ${ ]. 257737 char = $' ifTrue: [ char := $" ]. 257738 char asciiValue = 27 ifTrue: [ char := ${ ]. "ctrl-[" 257739 257740 self closeTypeIn. 257741 startIndex := self startIndex. 257742 stopIndex := self stopIndex. 257743 oldSelection := self selection. 257744 which := '([<{"''' indexOf: char ifAbsent: [1]. 257745 left := '([<{"''' at: which. 257746 right := ')]>}"''' at: which. 257747 text := paragraph text. 257748 ((startIndex > 1 and: [stopIndex <= text size]) 257749 and: 257750 [(text at: startIndex-1) = left and: [(text at: stopIndex) = right]]) 257751 ifTrue: 257752 ["already enclosed; strip off brackets" 257753 self selectFrom: startIndex-1 to: stopIndex. 257754 self replaceSelectionWith: oldSelection] 257755 ifFalse: 257756 ["not enclosed; enclose by matching brackets" 257757 self replaceSelectionWith: 257758 (Text string: (String with: left), oldSelection string ,(String with: right) 257759 emphasis: emphasisHere). 257760 self selectFrom: startIndex+1 to: stopIndex]. 257761 ^true! ! 257762 257763!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:42'! 257764swapChars: characterStream 257765 "Triggered byCmd-Y;. Swap two characters, either those straddling the insertion point, or the two that comprise the selection. Suggested by Ted Kaehler. " 257766 257767 | currentSelection aString chars | 257768 (chars := self selection) size == 0 257769 ifTrue: 257770 [currentSelection := self pointIndex. 257771 self selectMark: currentSelection - 1 point: currentSelection] 257772 ifFalse: 257773 [chars size == 2 257774 ifFalse: 257775 [self flash. ^ true] 257776 ifTrue: 257777 [currentSelection := self pointIndex - 1]]. 257778 aString := self selection string. 257779 self replaceSelectionWith: (Text string: aString reversed emphasis: emphasisHere). 257780 self selectAt: currentSelection + 1. 257781 ^ true! ! 257782 257783!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:43'! 257784tempCommand: characterStream 257785 "Experimental. Triggered by Cmd-t; put trial cmd-key commands here to see how they work, before hanging them on their own cmd accelerators." 257786 257787 self experimentalCommand. 257788 ^ true! ! 257789 257790!ParagraphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 12:43'! 257791undo: characterStream 257792 "Undo the last edit. Keeps typeahead, so undo twice is a full redo." 257793 257794 self closeTypeIn: characterStream. 257795 self undo. 257796 ^true! ! 257797 257798 257799!ParagraphEditor methodsFor: 'initialize-release'! 257800changeParagraph: aParagraph 257801 "Install aParagraph as the one to be edited by the receiver." 257802 257803 UndoParagraph == paragraph ifTrue: [UndoParagraph := nil]. 257804 paragraph := aParagraph. 257805 self resetState! ! 257806 257807!ParagraphEditor methodsFor: 'initialize-release' stamp: 'th 10/21/2003 15:49'! 257808resetState 257809 "Establish the initial conditions for editing the paragraph: place caret 257810 before first character, set the emphasis to that of the first character, 257811 and save the paragraph for purposes of canceling." 257812 257813 stopBlock := paragraph defaultCharacterBlock. 257814 self pointBlock: stopBlock copy. 257815 beginTypeInBlock := nil. 257816 UndoInterval := otherInterval := 1 to: 0. 257817 self setEmphasisHere. 257818 selectionShowing := false. 257819 initialText := paragraph text copy! ! 257820 257821!ParagraphEditor methodsFor: 'initialize-release' stamp: 'di 5/15/2000 13:51'! 257822stateArray 257823 ^ {ChangeText. 257824 FindText. 257825 UndoInterval. 257826 UndoMessage. 257827 UndoParagraph. 257828 UndoSelection. 257829 Undone. 257830 self selectionInterval. 257831 self startOfTyping. 257832 emphasisHere}! ! 257833 257834!ParagraphEditor methodsFor: 'initialize-release' stamp: 'di 10/5/1998 17:03'! 257835stateArrayPut: stateArray 257836 | sel | 257837 ChangeText := stateArray at: 1. 257838 FindText := stateArray at: 2. 257839 UndoInterval := stateArray at: 3. 257840 UndoMessage := stateArray at: 4. 257841 UndoParagraph := stateArray at: 5. 257842 UndoSelection := stateArray at: 6. 257843 Undone := stateArray at: 7. 257844 sel := stateArray at: 8. 257845 self selectFrom: sel first to: sel last. 257846 beginTypeInBlock := stateArray at: 9. 257847 emphasisHere := stateArray at: 10.! ! 257848 257849 257850!ParagraphEditor methodsFor: 'menu messages' stamp: 'jm 5/3/1998 19:19'! 257851accept 257852 "Save the current text of the text being edited as the current acceptable version for purposes of canceling." 257853 257854 initialText := paragraph text copy. 257855! ! 257856 257857!ParagraphEditor methodsFor: 'menu messages'! 257858again 257859 "Text substitution. If the left shift key is down, the substitution is made 257860 throughout the entire Paragraph. Otherwise, only the next possible 257861 substitution is made. 257862 Undoer & Redoer: #undoAgain:andReselect:typedKey:." 257863 257864 "If last command was also 'again', use same keys as before" 257865 self againOrSame: (UndoMessage sends: #undoAgain:andReselect:typedKey:)! ! 257866 257867!ParagraphEditor methodsFor: 'menu messages'! 257868align 257869 "Align text according to the next greater alignment value--cycling among 257870 left flush, right flush, center, justified. No effect on the undoability of the pre 257871 preceding command." 257872 257873 paragraph toggleAlignment. 257874 paragraph displayOn: Display. 257875 self recomputeInterval! ! 257876 257877!ParagraphEditor methodsFor: 'menu messages' stamp: 'alain.plantec 5/12/2009 13:43'! 257878browseIt 257879 "Launch a browser for the class indicated by the 257880 current selection. 257881 If multiple classes matching the selection exist, let 257882 the user choose among them." 257883 | aBrow aClass | 257884 self 257885 lineSelectAndEmptyCheck: [^ self]. 257886 aClass := SystemNavigation default 257887 classFromPattern: (self selection string copyWithout: Character cr) 257888 withCaption: 'choose a class to browse...'. 257889 aClass 257890 ifNil: [^ self flash]. 257891 self 257892 terminateAndInitializeAround: [aBrow := SystemBrowser default new. 257893 aBrow setClass: aClass selector: nil. 257894 aBrow class 257895 openBrowserView: (aBrow openEditString: nil) 257896 label: 'System Browser']! ! 257897 257898!ParagraphEditor methodsFor: 'menu messages' stamp: 'alain.plantec 6/11/2008 15:00'! 257899cancel 257900 "Restore the text of the paragraph to be the text saved since initialization 257901 or the last accept. Undoer & Redoer: undoAndReselect:redoAndReselect:. 257902 This used to call controlTerminate and controlInitialize but this seemed illogical. 257903 Sure enough, nobody overrode them who had cancel in the menu, and if 257904 anybody really cared they could override cancel." 257905 257906 UndoSelection := paragraph text. 257907 self undoer: #undoAndReselect:redoAndReselect: with: self selectionInterval with: (1 to: 0). 257908 self changeParagraph: (paragraph text: initialText). 257909 UndoParagraph := paragraph. 257910 otherInterval := UndoInterval := 1 to: initialText size. "so undo will replace all" 257911 paragraph displayOn: Display. 257912 self selectAt: 1. 257913 self scrollToTop 257914! ! 257915 257916!ParagraphEditor methodsFor: 'menu messages' stamp: 'alain.plantec 2/6/2009 17:12'! 257917changeAlignment 257918 | aList reply | 257919 aList := #(leftFlush centered justified rightFlush). 257920 reply := UIManager default chooseFrom: (aList collect: [:t | t translated]) values: aList. 257921 reply ifNil:[^self]. 257922 self setAlignment: reply. 257923 paragraph composeAll. 257924 self recomputeSelection. 257925 ^ true! ! 257926 257927!ParagraphEditor methodsFor: 'menu messages' stamp: 'alain.plantec 2/6/2009 17:14'! 257928changeEmphasis 257929 | aList reply | 257930 aList := #(normal bold italic narrow underlined struckOut). 257931 reply := UIManager default chooseFrom: (aList collect: [:t | t translated]) values: aList. 257932 reply ifNotNil: [ 257933 self setEmphasis: reply. 257934 paragraph composeAll. 257935 self recomputeSelection]. 257936 ^ true! ! 257937 257938!ParagraphEditor methodsFor: 'menu messages' stamp: 'alain.plantec 2/6/2009 17:15'! 257939changeEmphasisOrAlignment 257940 | aList reply | 257941 aList := #(normal bold italic narrow underlined struckOut leftFlush centered rightFlush justified). 257942 reply := UIManager default chooseFrom: (aList collect: [:t | t translated]) values: aList lines: #(6). 257943 reply ~~ nil ifTrue: 257944 [(#(leftFlush centered rightFlush justified) includes: reply) 257945 ifTrue: 257946 [paragraph perform: reply. 257947 self recomputeInterval] 257948 ifFalse: 257949 [self setEmphasis: reply. 257950 paragraph composeAll. 257951 self recomputeSelection. 257952 ]]. 257953 ^ true! ! 257954 257955!ParagraphEditor methodsFor: 'menu messages' stamp: 'alain.plantec 2/6/2009 17:16'! 257956changeStyle 257957 "Let user change styles for the current text pane 257958 Moved from experimentalCommand to its own method " 257959 257960 | aList reply style | 257961 aList := StrikeFont actualFamilyNames. 257962 aList addFirst: 'DefaultTextStyle'. 257963 reply := UIManager default chooseFrom: aList values: aList lines: #(1). 257964 reply ifNotNil: 257965 [(style := TextStyle named: reply) ifNil: [Beeper beep. ^ true]. 257966 paragraph textStyle: style copy. 257967 paragraph composeAll. 257968 self recomputeSelection. 257969 ]. 257970 ^ true! ! 257971 257972!ParagraphEditor methodsFor: 'menu messages' stamp: 'RAA 3/15/2001 12:10'! 257973changeStyleTo: aNewStyle 257974 257975 paragraph textStyle: aNewStyle. 257976 paragraph composeAll. 257977 self recomputeSelection. 257978! ! 257979 257980!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 9/27/1999 11:54'! 257981chooseAlignment 257982 self changeAlignment! ! 257983 257984!ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/15/2003 22:40'! 257985classCommentsContainingIt 257986 "Open a browser class comments which contain the current selection somewhere in them." 257987 257988 self lineSelectAndEmptyCheck: [^ self]. 257989 self terminateAndInitializeAround: [ 257990 self systemNavigation browseClassCommentsWithString: self selection string]! ! 257991 257992!ParagraphEditor methodsFor: 'menu messages' stamp: 'dvf 8/23/2003 11:51'! 257993classNamesContainingIt 257994 "Open a browser on classes whose names contain the selected string" 257995 257996 self lineSelectAndEmptyCheck: [^self]. 257997 self systemNavigation 257998 browseClassesWithNamesContaining: self selection string 257999 caseSensitive: Sensor leftShiftDown! ! 258000 258001!ParagraphEditor methodsFor: 'menu messages' stamp: 'ar 1/15/2001 18:37'! 258002clipboardText 258003 258004 ^ Clipboard clipboardText! ! 258005 258006!ParagraphEditor methodsFor: 'menu messages' stamp: 'ar 1/15/2001 18:38'! 258007clipboardText: text 258008 258009 ^ Clipboard clipboardText: text! ! 258010 258011!ParagraphEditor methodsFor: 'menu messages' stamp: 'ar 1/15/2001 18:38'! 258012clipboardTextPut: text 258013 258014 ^ Clipboard clipboardText: text! ! 258015 258016!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 11/23/1998 15:21'! 258017compareToClipboard 258018 "Check to see if whether the receiver's text is the same as the text currently on the clipboard, and inform the user." 258019 | s1 s2 | 258020 s1 := self clipboardText string. 258021 s2 := paragraph text string. 258022 s1 = s2 ifTrue: [^ self inform: 'Exact match']. 258023 258024 (StringHolder new textContents: 258025 (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2)) 258026 openLabel: 'Comparison to Clipboard Text'! ! 258027 258028!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 8/1/97 15:09'! 258029copySelection 258030 "Copy the current selection and store it in the paste buffer, unless a caret. Undoer & Redoer: undoCutCopy" 258031 258032 self lineSelectAndEmptyCheck: [^ self]. 258033 258034 "Simulate 'substitute: self selection' without locking the controller" 258035 UndoSelection := self selection. 258036 self undoer: #undoCutCopy: with: self clipboardText. 258037 UndoInterval := self selectionInterval. 258038 self clipboardTextPut: UndoSelection! ! 258039 258040!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 8/1/97 16:33'! 258041cut 258042 "Cut out the current selection and redisplay the paragraph if necessary. Undoer & Redoer: undoCutCopy:" 258043 258044 self lineSelectAndEmptyCheck: [^ self]. 258045 258046 self replaceSelectionWith: self nullText. 258047 self undoer: #undoCutCopy: with: self clipboardText. 258048 self clipboardTextPut: UndoSelection! ! 258049 258050!ParagraphEditor methodsFor: 'menu messages'! 258051exchange 258052 "See comment in exchangeWith:" 258053 258054 self exchangeWith: otherInterval! ! 258055 258056!ParagraphEditor methodsFor: 'menu messages' stamp: 'sma 5/28/2000 09:34'! 258057experimentalCommand 258058 "Use for experimental command-key implementation. Using this, 258059 you can try things out without forever needing to reinitialize the 258060 ParagraphEditor." 258061 258062 self prettyPrint. 258063 ^ true! ! 258064 258065!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 9/7/1999 08:41'! 258066fileItIn 258067 "Make a Stream on the text selection and fileIn it. 258068 1/24/96 sw: moved here from FileController; this function can be useful from any text window that shows stuff in chunk format" 258069 258070 | selection | 258071 selection := self selection. 258072 self terminateAndInitializeAround: 258073 [(ReadWriteStream on: selection string from: 1 to: selection size) fileIn]. 258074! ! 258075 258076!ParagraphEditor methodsFor: 'menu messages' stamp: 'DamienCassou 9/29/2009 13:05'! 258077find 258078 "Prompt the user for a string to search for, and search the receiver from the current selection onward for it. 1/26/96 sw" 258079 258080 | reply | 258081 reply := UIManager default request: 'Find what? ' translated initialAnswer: ''. 258082 reply isEmptyOrNil ifTrue: [^ self]. 258083 self setSearch: reply. 258084 ChangeText := FindText. "Implies no replacement to againOnce: method" 258085 self againOrSame: true 258086 258087! ! 258088 258089!ParagraphEditor methodsFor: 'menu messages'! 258090findAgain 258091 "Find the text-to-find again. 1/24/96 sw" 258092 258093 self againOrSame: true! ! 258094 258095!ParagraphEditor methodsFor: 'menu messages'! 258096fit 258097 "Make the bounding rectangle of the paragraph contain all the text while 258098 not changing the width of the view of the paragraph. No effect on undoability 258099 of the preceding command." 258100 258101 paragraph clearVisibleRectangle. 258102 paragraph fit. 258103 paragraph displayOn: Display; outline. 258104 self recomputeInterval! ! 258105 258106!ParagraphEditor methodsFor: 'menu messages' stamp: 'alain.plantec 6/11/2008 15:08'! 258107implementorsOfIt 258108 "Open an implementors browser on the selected selector" 258109 258110 | aSelector | 258111 self lineSelectAndEmptyCheck: [^ self]. 258112 (aSelector := self selectedSelector) == nil ifTrue: [^ self flash]. 258113 self terminateAndInitializeAround: [ self systemNavigation browseAllImplementorsOf: aSelector]! ! 258114 258115!ParagraphEditor methodsFor: 'menu messages' stamp: 'th 9/19/2002 18:12'! 258116lineSelectAndEmptyCheck: returnBlock 258117 "If the current selection is an insertion point, expand it to be the entire current line; if after that's done the selection is still empty, then evaluate the returnBlock, which will typically consist of '[^ self]' in the caller -- check senders of this method to understand this." 258118 258119 self selectLine. "if current selection is an insertion point, then first select the entire line in which occurs before proceeding" 258120 self hasSelection ifFalse: [self flash. ^ returnBlock value]! ! 258121 258122!ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 19:31'! 258123methodNamesContainingIt 258124 "Open a browser on methods names containing the selected string" 258125 258126 self lineSelectAndEmptyCheck: [^ self]. 258127 Cursor wait showWhile: 258128 [self terminateAndInitializeAround: [self systemNavigation browseMethodsWhoseNamesContain: self selection string withBlanksTrimmed]]. 258129 Cursor normal show! ! 258130 258131!ParagraphEditor methodsFor: 'menu messages' stamp: 'md 9/6/2005 18:45'! 258132methodSourceContainingIt 258133 "Open a browser on methods which contain the current selection in their source (case-sensitive full-text search of source). Slow!!" 258134 258135 self lineSelectAndEmptyCheck: [^ self]. 258136 self systemNavigation browseMethodsWithSourceString: self selection string! ! 258137 258138!ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 19:28'! 258139methodStringsContainingit 258140 "Open a browser on methods which contain the current selection as part of a string constant." 258141 258142 self lineSelectAndEmptyCheck: [^ self]. 258143 self terminateAndInitializeAround: [self systemNavigation browseMethodsWithString: self selection string]! ! 258144 258145!ParagraphEditor methodsFor: 'menu messages' stamp: 'th 9/20/2002 11:21'! 258146paste 258147 "Paste the text from the shared buffer over the current selection and 258148 redisplay if necessary. Undoer & Redoer: undoAndReselect." 258149 258150 self replace: self selectionInterval with: self clipboardText and: 258151 [self selectAt: self pointIndex]! ! 258152 258153!ParagraphEditor methodsFor: 'menu messages' stamp: 'ar 1/15/2001 18:36'! 258154pasteRecent 258155 "Paste an item chose from RecentClippings." 258156 258157 | clipping | 258158 (clipping := Clipboard chooseRecentClipping) ifNil: [^ self]. 258159 Clipboard clipboardText: clipping. 258160 ^ self paste! ! 258161 258162!ParagraphEditor methodsFor: 'menu messages' stamp: 'alain.plantec 5/18/2009 15:58'! 258163prettyPrint 258164 "Reformat the contents of the receiver's view (a Browser)." 258165 258166 | selectedClass newText | 258167 model selectedMessageCategoryName ifNil: [^ self flash]. 258168 selectedClass := model selectedClassOrMetaClass. 258169 newText := selectedClass prettyPrinterClass 258170 format: self text 258171 in: selectedClass 258172 notifying: self. 258173 newText ifNotNil: 258174 [self deselect; selectInvisiblyFrom: 1 to: paragraph text size. 258175 self replaceSelectionWith: (newText asText makeSelectorBoldIn: selectedClass). 258176 self selectAt: 1]! ! 258177 258178!ParagraphEditor methodsFor: 'menu messages' stamp: 'dew 3/7/2000 21:06'! 258179printerSetup 258180 258181 TextPrinter defaultTextPrinter inspect 258182! ! 258183 258184!ParagraphEditor methodsFor: 'menu messages' stamp: 'alain.plantec 6/11/2008 15:12'! 258185referencesToIt 258186 "Open a references browser on the selected symbol" 258187 258188 | aSymbol | 258189 self selectLine. 258190 ((aSymbol := self selectedSymbol) == nil or: 258191 [(Smalltalk includesKey: aSymbol) not]) 258192 ifTrue: [^ self flash]. 258193 258194 self terminateAndInitializeAround: [self systemNavigation browseAllCallsOn: (Smalltalk associationAt: self selectedSymbol)]! ! 258195 258196!ParagraphEditor methodsFor: 'menu messages' stamp: 'bf 10/13/1999 09:09'! 258197selectedSelector 258198 "Try to make a selector out of the current text selection" 258199 ^self selection string findSelector! ! 258200 258201!ParagraphEditor methodsFor: 'menu messages' stamp: 'yo 7/5/2004 16:38'! 258202selectedSymbol 258203 "Return the currently selected symbol, or nil if none. Spaces, tabs and returns are ignored" 258204 258205 | aString | 258206 self hasCaret ifTrue: [^ nil]. 258207 aString := self selection string. 258208 aString isOctetString ifTrue: [aString := aString asOctetString]. 258209 aString := aString copyWithoutAll: 258210 {Character space. Character cr. Character tab}. 258211 aString size == 0 ifTrue: [^ nil]. 258212 Symbol hasInterned: aString ifTrue: [:sym | ^ sym]. 258213 258214 ^ nil! ! 258215 258216!ParagraphEditor methodsFor: 'menu messages' stamp: 'alain.plantec 6/11/2008 15:13'! 258217sendersOfIt 258218 "Open a senders browser on the selected selector" 258219 258220 | aSelector | 258221 self lineSelectAndEmptyCheck: [^ self]. 258222 (aSelector := self selectedSelector) == nil ifTrue: [^ self flash]. 258223 self terminateAndInitializeAround: [self systemNavigation browseAllCallsOn: aSelector]! ! 258224 258225!ParagraphEditor methodsFor: 'menu messages' stamp: 'th 9/18/2002 17:28'! 258226setAlignment: aSymbol 258227 | attr interval | 258228 attr := TextAlignment perform: aSymbol. 258229 interval := self encompassLine: self selectionInterval. 258230 paragraph replaceFrom: interval first to: interval last with: 258231 ((paragraph text copyFrom: interval first to: interval last) addAttribute: attr) displaying: true. 258232! ! 258233 258234!ParagraphEditor methodsFor: 'menu messages' stamp: 'alain.plantec 6/11/2008 15:13'! 258235setSearchString 258236 "Make the current selection, if any, be the current search string." 258237 self hasCaret ifTrue: [self flash. ^ self]. 258238 self setSearch: self selection string! ! 258239 258240!ParagraphEditor methodsFor: 'menu messages' stamp: 'michael.rueger 2/23/2009 13:23'! 258241undo 258242 "Reset the state of the paragraph prior to the previous edit. 258243 If another ParagraphEditor instance did that edit, UndoInterval is invalid; 258244 just recover the contents of the undo-buffer at the start of the paragraph." 258245 258246 Sensor flushKeyboard. "a way to flush stuck keys" 258247 self closeTypeIn. 258248 258249 UndoParagraph == paragraph ifFalse: "Can't undo another paragraph's edit" 258250 [UndoMessage := Message selector: #undoReplace. 258251 UndoInterval := 1 to: 0. 258252 Undone := true]. 258253 UndoInterval ~= self selectionInterval ifTrue: "blink the actual target" 258254 [self selectInterval: UndoInterval; deselect]. 258255 258256 "Leave a signal of which phase is in progress" 258257 UndoParagraph := Undone ifTrue: [#redoing] ifFalse: [#undoing]. 258258 UndoMessage sentTo: self. 258259 UndoParagraph := paragraph! ! 258260 258261 258262!ParagraphEditor methodsFor: 'model access' stamp: 'michael.rueger 2/23/2009 18:31'! 258263model 258264 "Answer the receiver's model which is the same as the model of the 258265 receiver's view." 258266 258267 ^model! ! 258268 258269!ParagraphEditor methodsFor: 'model access' stamp: 'michael.rueger 2/23/2009 18:31'! 258270model: aModel 258271 "Controller|model: and Controller|view: are sent by View|controller: in 258272 order to coordinate the links between the model, view, and controller. In 258273 ordinary usage, the receiver is created and passed as the parameter to 258274 View|controller: so that the receiver's model and view links can be set 258275 up by the view." 258276 258277 model := aModel! ! 258278 258279 258280!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 14:37'! 258281adjustSelection: directionBlock 258282 "Helper function for Cursor movement. Always moves point thus allowing selections to shrink. " 258283 "See also expandSelection:" 258284 "Accepts a one argument Block that computes the new postion given an old one." 258285 | newPosition | 258286 newPosition := directionBlock value: self pointIndex. 258287 self selectMark: self markIndex point: newPosition. 258288 ^true.! ! 258289 258290!ParagraphEditor methodsFor: 'new selection' stamp: 'th 10/28/2003 12:11'! 258291afterSelectionInsertAndSelect: aString 258292 258293 self insertAndSelect: aString at: self stopIndex ! ! 258294 258295!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/17/2002 16:11'! 258296computeIntervalFrom: start to: stop 258297 "Select the designated characters, inclusive. Make no visual changes." 258298 258299 self setMark: start. 258300 self setPoint: stop + 1.! ! 258301 258302!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/6/1998 15:21'! 258303correctFrom: start to: stop with: aString 258304 "Make a correction in the model that the user has authorised from somewhere else in the system (such as from the compilier). The user's selection is not changed, only corrected." 258305 | wasShowing userSelection delta loc | 258306 aString = '#insert period' ifTrue: 258307 [loc := start. 258308 [(loc := loc-1)>0 and: [(paragraph text string at: loc) isSeparator]] 258309 whileTrue: [loc := loc-1]. 258310 ^ self correctFrom: loc+1 to: loc with: '.']. 258311 (wasShowing := selectionShowing) ifTrue: [ self reverseSelection ]. 258312 userSelection := self selectionInterval. 258313 258314 self selectInvisiblyFrom: start to: stop. 258315 self replaceSelectionWith: aString asText. 258316 258317 delta := aString size - (stop - start + 1). 258318 self selectInvisiblyFrom: 258319 userSelection first + (userSelection first > start ifFalse: [ 0 ] ifTrue: [ delta ]) 258320 to: userSelection last + (userSelection last > start ifFalse: [ 0 ] ifTrue: [ delta ]). 258321 wasShowing ifTrue: [ self reverseSelection ]. 258322! ! 258323 258324!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/19/2002 17:21'! 258325encompassLine: anInterval 258326 "Return an interval that encompasses the entire line" 258327 | string left right | 258328 string := paragraph text string. 258329 left := (string lastIndexOf: Character cr startingAt: anInterval first - 1 ifAbsent:[0]) + 1. 258330 right := (string indexOf: Character cr startingAt: anInterval last + 1 ifAbsent: [string size + 1]) - 1. 258331 ^left to: right! ! 258332 258333!ParagraphEditor methodsFor: 'new selection' stamp: 'di 12/17/1998 09:41'! 258334insertAndSelect: aString at: anInteger 258335 258336 self replace: (anInteger to: anInteger - 1) 258337 with: (Text string: (' ' , aString) 258338 attributes: emphasisHere) 258339 and: [self selectAndScroll]! ! 258340 258341!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/6/1998 15:25'! 258342nextTokenFrom: start direction: dir 258343 "simple token-finder for compiler automated corrections" 258344 | loc str | 258345 loc := start + dir. 258346 str := paragraph text string. 258347 [(loc between: 1 and: str size) and: [(str at: loc) isSeparator]] 258348 whileTrue: [loc := loc + dir]. 258349 ^ loc! ! 258350 258351!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/20/1998 08:31'! 258352notify: aString at: anInteger in: aStream 258353 "The compilation of text failed. The syntax error is noted as the argument, 258354 aString. Insert it in the text at starting character position anInteger." 258355 258356 self insertAndSelect: aString at: (anInteger max: 1)! ! 258357 258358!ParagraphEditor methodsFor: 'new selection'! 258359selectAt: characterIndex 258360 "Deselect, then place the caret before the character at characterIndex. 258361 Be sure it is in view." 258362 258363 self selectFrom: characterIndex to: characterIndex - 1! ! 258364 258365!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 16:50'! 258366selectFrom: start to: stop 258367 "Deselect, then select the specified characters inclusive. 258368 Be sure the selection is in view." 258369 258370 (start = self startIndex and: [stop + 1 = self stopIndex]) ifFalse: 258371 [self deselect. 258372 self selectInvisiblyFrom: start to: stop]. 258373 self selectAndScroll! ! 258374 258375!ParagraphEditor methodsFor: 'new selection'! 258376selectInterval: anInterval 258377 "Deselect, then select the specified characters inclusive. 258378 Be sure the selection is in view." 258379 258380 self selectFrom: anInterval first to: anInterval last! ! 258381 258382!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/9/1998 20:59'! 258383selectInvisiblyFrom: start to: stop 258384 "Select the designated characters, inclusive. Make no visual changes." 258385 258386 ^ self computeIntervalFrom: start to: stop! ! 258387 258388!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 14:17'! 258389selectInvisiblyMark: mark point: point 258390 "Select the designated characters, inclusive. Make no visual changes." 258391 258392 ^ self computeIntervalFrom: mark to: point! ! 258393 258394!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/19/2002 17:17'! 258395selectLine 258396 "Make the receiver's selection, if it currently consists of an insertion point only, encompass the current line." 258397 self hasSelection ifTrue:[^self]. 258398 self selectInterval: (self encompassLine: self selectionInterval)! ! 258399 258400!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 14:18'! 258401selectMark: mark point: point 258402 "Deselect, then select the specified characters inclusive. 258403 Be sure the selection is in view." 258404 258405 (mark = self markIndex and: [point + 1 = self pointIndex]) ifFalse: 258406 [self deselect. 258407 self selectInvisiblyMark: mark point: point]. 258408 self selectAndScroll! ! 258409 258410!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/19/2002 18:49'! 258411selectPrecedingIdentifier 258412 "Invisibly select the identifier that ends at the end of the selection, if any." 258413 258414 | string sep stop tok | 258415 tok := false. 258416 string := paragraph text string. 258417 stop := self stopIndex - 1. 258418 [stop > 0 and: [(string at: stop) isSeparator]] whileTrue: [stop := stop - 1]. 258419 sep := stop. 258420 [sep > 0 and: [(string at: sep) tokenish]] whileTrue: [tok := true. sep := sep - 1]. 258421 tok ifTrue: [self selectInvisiblyFrom: sep + 1 to: stop]! ! 258422 258423!ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 16:51'! 258424selectWord 258425 "Select delimited text or word--the result of double-clicking." 258426 258427 | openDelimiter closeDelimiter direction match level leftDelimiters rightDelimiters 258428 string here hereChar start stop | 258429 string := paragraph text string. 258430 here := self pointIndex. 258431 (here between: 2 and: string size) 258432 ifFalse: ["if at beginning or end, select entire string" 258433 ^self selectFrom: 1 to: string size]. 258434 leftDelimiters := '([{<''" 258435'. 258436 rightDelimiters := ')]}>''" 258437'. 258438 openDelimiter := string at: here - 1. 258439 match := leftDelimiters indexOf: openDelimiter. 258440 match > 0 258441 ifTrue: 258442 ["delimiter is on left -- match to the right" 258443 start := here. 258444 direction := 1. 258445 here := here - 1. 258446 closeDelimiter := rightDelimiters at: match] 258447 ifFalse: 258448 [openDelimiter := string at: here. 258449 match := rightDelimiters indexOf: openDelimiter. 258450 match > 0 258451 ifTrue: 258452 ["delimiter is on right -- match to the left" 258453 stop := here - 1. 258454 direction := -1. 258455 closeDelimiter := leftDelimiters at: match] 258456 ifFalse: ["no delimiters -- select a token" 258457 direction := -1]]. 258458 level := 1. 258459 [level > 0 and: [direction > 0 258460 ifTrue: [here < string size] 258461 ifFalse: [here > 1]]] 258462 whileTrue: 258463 [hereChar := string at: (here := here + direction). 258464 match = 0 258465 ifTrue: ["token scan goes left, then right" 258466 hereChar tokenish 258467 ifTrue: [here = 1 258468 ifTrue: 258469 [start := 1. 258470 "go right if hit string start" 258471 direction := 1]] 258472 ifFalse: [direction < 0 258473 ifTrue: 258474 [start := here + 1. 258475 "go right if hit non-token" 258476 direction := 1] 258477 ifFalse: [level := 0]]] 258478 ifFalse: ["bracket match just counts nesting level" 258479 hereChar = closeDelimiter 258480 ifTrue: [level := level - 1"leaving nest"] 258481 ifFalse: [hereChar = openDelimiter 258482 ifTrue: [level := level + 1"entering deeper nest"]]]]. 258483 258484 level > 0 ifTrue: ["in case ran off string end" here := here + direction]. 258485 direction > 0 258486 ifTrue: [self selectFrom: start to: here - 1] 258487 ifFalse: [self selectFrom: here + 1 to: stop]! ! 258488 258489 258490!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:51'! 258491comment 258492 "All key actions that are neither editing nor typing actions have to 258493 send closeTypeIn at first. See comment in openTypeIn closeTypeIn"! ! 258494 258495!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 11/18/2002 17:08'! 258496cursorDown: characterStream 258497 258498 "Private - Move cursor from position in current line to same position in 258499 next line. If next line too short, put at end. If shift key down, 258500 select." 258501 self closeTypeIn: characterStream. 258502 self 258503 moveCursor:[:position | self 258504 sameColumn: position 258505 newLine:[:line | line + 1] 258506 forward: true] 258507 forward: true 258508 specialBlock:[:dummy | dummy]. 258509 ^true! ! 258510 258511!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 10/28/2003 10:47'! 258512cursorEnd: characterStream 258513 258514 "Private - Move cursor end of current line." 258515 | string | 258516 self closeTypeIn: characterStream. 258517 string := paragraph text string. 258518 self 258519 moveCursor: 258520 [:position | Preferences wordStyleCursorMovement 258521 ifTrue:[| targetLine | 258522 targetLine := paragraph lines at:(paragraph lineIndexOfCharacterIndex: position). 258523 targetLine = paragraph lines last 258524 ifTrue:[targetLine last + 1] 258525 ifFalse:[targetLine last]] 258526 ifFalse:[ 258527 string 258528 indexOf: Character cr 258529 startingAt: position 258530 ifAbsent:[string size + 1]]] 258531 forward: true 258532 specialBlock:[:dummy | string size + 1]. 258533 ^true! ! 258534 258535!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 9/20/2002 12:14'! 258536cursorHome: characterStream 258537 258538 "Private - Move cursor from position in current line to beginning of 258539 current line. If control key is pressed put cursor at beginning of text" 258540 258541 | string | 258542 258543 string := paragraph text string. 258544 self 258545 moveCursor: [ :position | Preferences wordStyleCursorMovement 258546 ifTrue:[ 258547 (paragraph lines at:(paragraph lineIndexOfCharacterIndex: position)) first] 258548 ifFalse:[ 258549 (string 258550 lastIndexOf: Character cr 258551 startingAt: position - 1 258552 ifAbsent:[0]) + 1]] 258553 forward: false 258554 specialBlock: [:dummy | 1]. 258555 ^true! ! 258556 258557!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 9/19/2002 20:07'! 258558cursorLeft: characterStream 258559 "Private - Move cursor left one character if nothing selected, otherwise 258560 move cursor to beginning of selection. If the shift key is down, start 258561 selecting or extending current selection. Don't allow cursor past 258562 beginning of text" 258563 258564 self closeTypeIn: characterStream. 258565 self 258566 moveCursor:[:position | position - 1 max: 1] 258567 forward: false 258568 specialBlock:[:position | self previousWord: position]. 258569 ^ true! ! 258570 258571!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 11/18/2002 17:09'! 258572cursorPageDown: characterStream 258573 258574 self closeTypeIn: characterStream. 258575 self 258576 moveCursor: [:position | 258577 self 258578 sameColumn: position 258579 newLine:[:lineNo | lineNo + self pageHeight] 258580 forward: true] 258581 forward: true 258582 specialBlock:[:dummy | dummy]. 258583 ^true! ! 258584 258585!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 11/18/2002 17:09'! 258586cursorPageUp: characterStream 258587 258588 self closeTypeIn: characterStream. 258589 self 258590 moveCursor: [:position | 258591 self 258592 sameColumn: position 258593 newLine:[:lineNo | lineNo - self pageHeight] 258594 forward: false] 258595 forward: false 258596 specialBlock:[:dummy | dummy]. 258597 ^true! ! 258598 258599!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 9/19/2002 20:01'! 258600cursorRight: characterStream 258601 "Private - Move cursor right one character if nothing selected, 258602 otherwise move cursor to end of selection. If the shift key is down, 258603 start selecting characters or extending already selected characters. 258604 Don't allow cursor past end of text" 258605 258606 self closeTypeIn: characterStream. 258607 self 258608 moveCursor: [:position | position + 1] 258609 forward: true 258610 specialBlock:[:position | self nextWord: position]. 258611 ^ true! ! 258612 258613!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 11/18/2002 17:15'! 258614cursorUp: characterStream 258615 258616"Private - Move cursor from position in current line to same position in 258617prior line. If prior line too short, put at end" 258618 258619 self closeTypeIn: characterStream. 258620 self 258621 moveCursor: [:position | self 258622 sameColumn: position 258623 newLine:[:line | line - 1] 258624 forward: false] 258625 forward: false 258626 specialBlock:[:dummy | dummy]. 258627 ^true! ! 258628 258629!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'alain.plantec 5/30/2008 14:05'! 258630escapeToDesktop: characterStream 258631 "Pop up a morph to field keyboard input in the context of the desktop" 258632 258633 ActiveWorld putUpWorldMenuFromEscapeKey. 258634 ^ true! ! 258635 258636!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'dvf 12/8/2001 00:46'! 258637raiseContextMenu: characterStream 258638 "AFAIK, this is never called in morphic, because a subclass overrides it. Which is good, because a ParagraphEditor doesn't know about Morphic and thus duplicates the text-editing actions that really belong in the specific application, not the controller. So the context menu this would raise is likely to be out of date." 258639 self yellowButtonActivity. 258640 ^true! ! 258641 258642!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'michael.rueger 2/23/2009 12:42'! 258643selectCurrentTypeIn: characterStream 258644 "Select what would be replaced by an undo (e.g., the last typeIn)." 258645 258646 | prior | 258647 258648 self closeTypeIn: characterStream. 258649 prior := otherInterval. 258650 self closeTypeIn: characterStream. 258651 self selectInterval: UndoInterval. 258652 otherInterval := prior. 258653 ^ true! ! 258654 258655!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'michael.rueger 2/23/2009 12:42'! 258656selectWord: characterStream 258657 self closeTypeIn: characterStream. 258658 self selectWord. 258659 ^ true! ! 258660 258661!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'michael.rueger 2/23/2009 12:42'! 258662setSearchString: characterStream 258663 "Establish the current selection as the current search string." 258664 258665 | aString | 258666 self closeTypeIn: characterStream. 258667 self lineSelectAndEmptyCheck: [^ true]. 258668 aString := self selection string. 258669 aString size == 0 258670 ifTrue: 258671 [self flash] 258672 ifFalse: 258673 [self setSearch: aString]. 258674 ^ true! ! 258675 258676 258677!ParagraphEditor methodsFor: 'parenblinking' stamp: 'mir 8/3/2004 13:31'! 258678blinkParenAt: parenLocation 258679 self text 258680 addAttribute: TextEmphasis bold 258681 from: parenLocation 258682 to: parenLocation. 258683 lastParentLocation := parenLocation.! ! 258684 258685!ParagraphEditor methodsFor: 'parenblinking' stamp: 'michael.rueger 2/23/2009 13:31'! 258686blinkPrevParen: openDelimiter 258687 | closeDelimiter level string here hereChar | 258688 string := paragraph text string. 258689 here := startBlock stringIndex. 258690 closeDelimiter := '([{' at: (')]}' indexOf: openDelimiter). 258691 level := 1. 258692 [level > 0 and: [here > 2]] 258693 whileTrue: 258694 [hereChar := string at: (here := here - 1). 258695 hereChar = closeDelimiter 258696 ifTrue: 258697 [level := level - 1. 258698 level = 0 258699 ifTrue: [^ self blinkParenAt: here]] 258700 ifFalse: 258701 [hereChar = openDelimiter 258702 ifTrue: [level := level + 1]]].! ! 258703 258704!ParagraphEditor methodsFor: 'parenblinking' stamp: 'mir 8/3/2004 13:31'! 258705clearParens 258706 lastParentLocation ifNotNil: 258707 [self text string size >= lastParentLocation ifTrue: [ 258708 self text 258709 removeAttribute: TextEmphasis bold 258710 from: lastParentLocation 258711 to: lastParentLocation]] 258712! ! 258713 258714 258715!ParagraphEditor methodsFor: 'scrolling' stamp: 'BG 12/12/2003 15:31'! 258716scrollBy: heightToMove 258717 "Move the paragraph by heightToMove, and reset the text selection." 258718 ^ paragraph scrollBy: heightToMove withSelectionFrom: self pointBlock to: self markBlock! ! 258719 258720!ParagraphEditor methodsFor: 'scrolling'! 258721scrollToBottom 258722 "Scroll so that the tail end of the text is visible in the view. 5/6/96 sw" 258723 258724 self scrollView: (paragraph clippingRectangle bottom 258725 - paragraph compositionRectangle bottom)! ! 258726 258727!ParagraphEditor methodsFor: 'scrolling'! 258728scrollToTop 258729 "Scroll so that the paragraph is at the top of the view." 258730 258731 self scrollView: (paragraph clippingRectangle top 258732 - paragraph compositionRectangle top)! ! 258733 258734!ParagraphEditor methodsFor: 'scrolling'! 258735scrollView: anInteger 258736 "Paragraph scrolling uses opposite polarity" 258737 ^ self scrollBy: anInteger negated! ! 258738 258739!ParagraphEditor methodsFor: 'scrolling' stamp: 'alain.plantec 6/11/2008 15:45'! 258740updateMarker 258741 "A variation of computeMarkerRegion--only redisplay the marker in the scrollbar if an actual change has occurred in the positioning of the paragraph." 258742! ! 258743 258744 258745!ParagraphEditor methodsFor: 'typing support' stamp: 'yo 3/16/2004 13:05'! 258746backTo: startIndex 258747 "During typing, backspace to startIndex. Deleted characters fall into three 258748 clusters, from left to right in the text: (1) preexisting characters that were 258749 backed over; (2) newly typed characters that were backed over (excluding 258750 typeahead, which never even appears); (3) preexisting characters that 258751 were highlighted before typing began. If typing has not yet been opened, 258752 open it and watch for the first and third cluster. If typing has been opened, 258753 watch for the first and second cluster. Save characters from the first and third 258754 cluster in UndoSelection. Tally characters from the first cluster in UndoMessage's parameter. 258755 Delete all the clusters. Do not alter Undoer or UndoInterval (except via 258756 openTypeIn). The code is shorter than the comment." 258757 258758 | saveLimit newBackovers | 258759 saveLimit := beginTypeInBlock == nil 258760 ifTrue: [self openTypeIn. UndoSelection := self nullText. self stopIndex] 258761 ifFalse: [self startOfTyping]. 258762 self setMark: startIndex. 258763 startIndex < saveLimit ifTrue: 258764 [newBackovers := self startOfTyping - startIndex. 258765 beginTypeInBlock := self startIndex. 258766 UndoSelection replaceFrom: 1 to: 0 with: 258767 (paragraph text copyFrom: startIndex to: saveLimit - 1). 258768 UndoMessage argument: (UndoMessage argument ifNil: [1]) + newBackovers]. 258769 self zapSelectionWith: self nullText. 258770 self unselect! ! 258771 258772!ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/19/2002 17:40'! 258773closeTypeIn 258774 "See comment in openTypeIn. It is important to call closeTypeIn before executing 258775 any non-typing key, making a new selection, etc. It is called automatically for 258776 menu commands. 258777 Typing commands can call 'closeTypeIn: aCharacterStream' instead of this to 258778 save typeahead. Undoer & Redoer: undoAndReselect:redoAndReselect:." 258779 258780 | begin stop | 258781 beginTypeInBlock == nil ifFalse: 258782 [(UndoMessage sends: #noUndoer) ifTrue: "should always be true, but just in case..." 258783 [begin := self startOfTyping. 258784 stop := self stopIndex. 258785 self undoer: #undoAndReselect:redoAndReselect: 258786 with: (begin + UndoMessage argument to: begin + UndoSelection size - 1) 258787 with: (stop to: stop - 1). 258788 UndoInterval := begin to: stop - 1]. 258789 beginTypeInBlock := nil]! ! 258790 258791!ParagraphEditor methodsFor: 'typing support'! 258792closeTypeIn: characterStream 258793 "Call instead of closeTypeIn when you want typeahead to be inserted before the 258794 control character is executed, e.g., from Ctrl-V." 258795 258796 self insertTypeAhead: characterStream. 258797 self closeTypeIn! ! 258798 258799!ParagraphEditor methodsFor: 'typing support' stamp: 'michael.rueger 2/23/2009 13:24'! 258800dispatchOnEnterWith: typeAheadStream 258801 "Enter key hit. Treat is as an 'accept', viz a synonym for cmd-s. If cmd key is down, treat is as a synonym for print-it. " 258802 258803 self terminateAndInitializeAround: [ 258804 Sensor commandKeyPressed 258805 ifTrue: 258806 [self printIt.] 258807 ifFalse: 258808 [self closeTypeIn: typeAheadStream. 258809 self accept]. 258810 ]. 258811 ^ true! ! 258812 258813!ParagraphEditor methodsFor: 'typing support' stamp: 'michael.rueger 3/11/2009 10:58'! 258814dispatchOnKeyEvent: keyEvent with: typeAheadStream 258815 "Carry out the action associated with this character, if any. 258816 Type-ahead is passed so some routines can flush or use it." 258817 258818 | honorCommandKeys keyValue keyChar char action | 258819 self clearParens. 258820 keyValue := OSPlatform current virtualKey: keyEvent scanCode. 258821 keyValue := keyValue ifNil: [keyEvent keyValue]. 258822 "Work around bug in some VMs delivering negative key values" 258823 keyChar := (keyValue max: 0) asCharacter. 258824 char := keyEvent keyCharacter. 258825 258826 "mikki 1/3/2005 21:31 Preference for auto-indent on return added." 258827 keyChar = Character cr ifTrue: [ 258828 ^(Preferences autoIndent 258829 xor: keyEvent controlKeyPressed) 258830 ifTrue: [self crWithIndent: typeAheadStream] 258831 ifFalse: [self normalCharacter: typeAheadStream character: char]]. 258832 258833 ((honorCommandKeys := Preferences cmdKeysInText) 258834 and: [keyChar = Character enter]) 258835 ifTrue: [^ self dispatchOnEnterWith: typeAheadStream]. 258836 258837 keyValue < 256 ifTrue: [ "none of the following is safe if the character's asciiValue is out of the 0..255 range" 258838 258839 "Special keys overwrite crtl+key combinations - at least on Windows. To resolve this 258840 conflict, assume that keys other than cursor keys aren't used together with Crtl." 258841 ((self class specialShiftCmdKeys includes: keyValue) and: [keyValue < 27]) 258842 ifTrue: [ 258843 action := keyEvent controlKeyPressed 258844 ifTrue: [ShiftCmdActions at: keyValue + 1] 258845 ifFalse: [CmdActions at: keyValue + 1]. 258846 ^action numArgs = 1 258847 ifTrue: [self perform: action with: typeAheadStream] 258848 ifFalse: [self perform: action with: keyEvent with: typeAheadStream]]. 258849 258850 "backspace, and escape keys (ascii 8 and 27) are command keys" 258851 ((honorCommandKeys and: [keyEvent commandKeyPressed]) or: [self class specialShiftCmdKeys includes: keyValue]) 258852 ifTrue: [ 258853 action := keyEvent leftShiftDown 258854 ifTrue: [ShiftCmdActions at: keyValue + 1] 258855 ifFalse: [CmdActions at: keyValue + 1]. 258856 ^action numArgs = 1 258857 ifTrue: [self perform: action with: typeAheadStream] 258858 ifFalse: [self perform: action with: typeAheadStream with: keyEvent]]. 258859 258860 "the control key can be used to invoke shift-cmd shortcuts" 258861 (honorCommandKeys and: [keyEvent controlKeyPressed]) 258862 ifTrue: [ 258863 action := ShiftCmdActions at: keyValue + 1. 258864 ^action numArgs = 1 258865 ifTrue: [self perform: action with: typeAheadStream] 258866 ifFalse: [self perform: action with: typeAheadStream with: keyEvent]]. 258867 258868 "allow cut/copy/paste/selectAll regardless of cmdKeysInText preference. 258869 Useful when running a deployed/locked-down image (after disableProgrammerFacilities)." 258870 ((#(cut: copySelection: paste: selectAll:) includes: (CmdActions at: keyValue + 1)) 258871 and: [keyEvent commandKeyPressed]) 258872 ifTrue: [ 258873 action := CmdActions at: keyValue + 1. 258874 ^action numArgs = 1 258875 ifTrue: [self perform: action with: typeAheadStream] 258876 ifFalse: [self perform: action with: typeAheadStream with: keyEvent]]. 258877 ]. "end of range protection" 258878 258879 (')]}' includes: char) 258880 ifTrue: [self blinkPrevParen: char]. 258881 258882 ^self normalCharacter: typeAheadStream character: char! ! 258883 258884!ParagraphEditor methodsFor: 'typing support' stamp: 'di 6/14/1998 13:08'! 258885doneTyping 258886 beginTypeInBlock := nil! ! 258887 258888!ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/17/2002 16:23'! 258889insertTypeAhead: typeAhead 258890 typeAhead position = 0 ifFalse: 258891 [self zapSelectionWith: (Text string: typeAhead contents emphasis: emphasisHere). 258892 typeAhead reset. 258893 self unselect]! ! 258894 258895!ParagraphEditor methodsFor: 'typing support' stamp: 'PeterHugossonMiller 9/3/2009 10:14'! 258896keystroke: keyEvent 258897 "Key struck on the keyboard. Find out which one and, if special, carry 258898 out the associated special action. Otherwise, add the character to the 258899 stream of characters. Undoer & Redoer: see closeTypeIn." 258900 258901 | typeAhead | 258902 typeAhead := (String new: 128) writeStream. 258903 self deselect. 258904 (self dispatchOnKeyEvent: keyEvent with: typeAhead) 258905 ifTrue: [ 258906 self doneTyping. 258907 self setEmphasisHere. 258908 ^self selectAndScroll; updateMarker]. 258909 self openTypeIn. 258910 258911 self hasSelection ifTrue: "save highlighted characters" 258912 [UndoSelection := self selection]. 258913 self zapSelectionWith: 258914 (Text string: typeAhead contents emphasis: emphasisHere). 258915 typeAhead reset. 258916 self unselect. 258917 self selectAndScroll. 258918 self updateMarker! ! 258919 258920!ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/18/2002 16:48'! 258921openTypeIn 258922 "Set up UndoSelection to null text (to be added to by readKeyboard and backTo:), 258923 beginTypeInBlock to keep track of the leftmost backspace, and UndoParameter to tally 258924 how many deleted characters were backspaced over rather than 'cut'. 258925 You can't undo typing until after closeTypeIn." 258926 258927 beginTypeInBlock == nil ifTrue: 258928 [UndoSelection := self nullText. 258929 self undoer: #noUndoer with: 0. 258930 beginTypeInBlock := self startIndex]! ! 258931 258932!ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/18/2002 16:49'! 258933setEmphasisHere 258934 258935 emphasisHere := (paragraph text attributesAt: (self pointIndex - 1 max: 1) forStyle: paragraph textStyle) 258936 select: [:att | att mayBeExtended]! ! 258937 258938!ParagraphEditor methodsFor: 'typing support' stamp: 'alain.plantec 6/11/2008 15:11'! 258939simulatedKeystroke: char 258940 "Accept char as if it were struck on the keyboard. This version does not yet deal with command keys, and achieves update in the receiver's typically inactive window via the sledge-hammer of uncache-bits." 258941 258942 self deselect. 258943 self openTypeIn. 258944 self markBlock = self pointBlock ifFalse: [UndoSelection := self selection]. 258945 self zapSelectionWith: 258946 (Text string: char asString emphasis: emphasisHere). 258947 self userHasEdited. 258948 self unselect. 258949 self selectAndScroll. 258950 self updateMarker. 258951! ! 258952 258953!ParagraphEditor methodsFor: 'typing support' stamp: 'di 10/6/1998 08:45'! 258954startOfTyping 258955 "Compatibility during change from characterBlock to integer" 258956 beginTypeInBlock == nil ifTrue: [^ nil]. 258957 beginTypeInBlock isNumber ifTrue: [^ beginTypeInBlock]. 258958 "Last line for compatibility during change from CharacterBlock to Integer." 258959 ^ beginTypeInBlock stringIndex 258960 ! ! 258961 258962 258963!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:21'! 258964argAdvance: characterStream 258965 "Invoked by Ctrl-a. Useful after Ctrl-q. 258966 Search forward from the end of the selection for a colon followed by 258967 a space. Place the caret after the space. If none are found, place the 258968 caret at the end of the text. Does not affect the undoability of the 258969 previous command." 258970 258971 | start | 258972 self closeTypeIn: characterStream. 258973 start := paragraph text findString: ': ' startingAt: self stopIndex. 258974 start = 0 ifTrue: [start := paragraph text size + 1]. 258975 self selectAt: start + 2. 258976 ^true! ! 258977 258978!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:21'! 258979backWord: characterStream 258980 "If the selection is not a caret, delete it and leave it in the backspace buffer. 258981 Else if there is typeahead, delete it. 258982 Else, delete the word before the caret." 258983 258984 | startIndex | 258985 characterStream isEmpty 258986 ifTrue: 258987 [self hasCaret 258988 ifTrue: "a caret, delete at least one character" 258989 [startIndex := 1 max: self markIndex - 1. 258990 [startIndex > 1 and: 258991 [(paragraph text at: startIndex - 1) asCharacter tokenish]] 258992 whileTrue: 258993 [startIndex := startIndex - 1]] 258994 ifFalse: "a non-caret, just delete it" 258995 [startIndex := self markIndex]. 258996 self backTo: startIndex] 258997 ifFalse: 258998 [characterStream reset]. 258999 ^false! ! 259000 259001!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 18:15'! 259002backspace: characterStream 259003 "Backspace over the last character." 259004 259005 | startIndex | 259006 Sensor leftShiftDown ifTrue: [^ self backWord: characterStream]. 259007 characterStream isEmpty 259008 ifTrue: 259009 [startIndex := self markIndex + (self hasCaret ifTrue: [0] ifFalse: [1]). 259010 startIndex := 1 max: startIndex - 1. 259011 self backTo: startIndex] 259012 ifFalse: 259013 [characterStream skip: -1]. 259014 ^false! ! 259015 259016!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:32'! 259017changeStyle: characterStream 259018 "Put up the style-change menu" 259019 259020 self closeTypeIn: characterStream. 259021 self changeStyle. 259022 ^ true! ! 259023 259024!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:32'! 259025crWithIndent: characterStream 259026 "Replace the current text selection with CR followed by as many tabs 259027 as on the current line (+/- bracket count) -- initiated by Shift-Return." 259028 | char s i tabCount | 259029 s := paragraph string. 259030 i := self stopIndex. 259031 tabCount := 0. 259032 [(i := i-1) > 0 and: [(char := s at: i) ~= Character cr]] 259033 whileTrue: "Count tabs and brackets (but not a leading bracket)" 259034 [(char = Character tab and: [i < s size and: [(s at: i+1) ~= $[ ]]) ifTrue: [tabCount := tabCount + 1]. 259035 char = $[ ifTrue: [tabCount := tabCount + 1]. 259036 char = $] ifTrue: [tabCount := tabCount - 1]]. 259037 characterStream crtab: tabCount. "Now inject CR with tabCount tabs" 259038 ^ false! ! 259039 259040!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:32'! 259041cursorTopHome: characterStream 259042 "Put cursor at beginning of text -- invoked from cmd-H shortcut, useful for keyboards that have no home key." 259043 259044 self selectAt: 1. 259045 ^ true! ! 259046 259047!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:33'! 259048displayIfFalse: characterStream 259049 "Replace the current text selection with the text 'ifFalse:'--initiated by 259050 ctrl-f." 259051 259052 characterStream nextPutAll: 'ifFalse:'. 259053 ^false! ! 259054 259055!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:33'! 259056displayIfTrue: characterStream 259057 "Replace the current text selection with the text 'ifTrue:'--initiated by 259058 ctrl-t." 259059 259060 characterStream nextPutAll: 'ifTrue:'. 259061 ^false! ! 259062 259063!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:33'! 259064doAgainMany: characterStream 259065 "Do the previous thing again repeatedly. 1/26/96 sw" 259066 259067 self closeTypeIn: characterStream. 259068 self againOrSame: (UndoMessage sends: #undoAgain:andReselect:typedKey:) many: true. 259069 ^ true! ! 259070 259071!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:33'! 259072doAgainOnce: characterStream 259073 "Do the previous thing again once. 1/26/96 sw" 259074 259075 self closeTypeIn: characterStream. 259076 self again. 259077 ^ true! ! 259078 259079!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:34'! 259080find: characterStream 259081 "Prompt the user for what to find, then find it, searching from the current selection onward. 1/24/96 sw" 259082 259083 self closeTypeIn: characterStream. 259084 self find. 259085 ^ true! ! 259086 259087!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:34'! 259088findAgain: characterStream 259089 "Find the desired text again. 1/24/96 sw" 259090 259091 self closeTypeIn: characterStream. 259092 self findAgain. 259093 ^ true! ! 259094 259095!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 13:29'! 259096forwardDelete: characterStream keyEvent: keyEvent 259097 "Delete forward over the next character. 259098 Make Undo work on the whole type-in, not just the one char. 259099 wod 11/3/1998: If there was a selection use #zapSelectionWith: rather than #backspace: which was 'one off' in deleting the selection. Handling of things like undo or typeIn area were not fully considered." 259100 | startIndex usel upara uinterval ind stopIndex | 259101 startIndex := self mark. 259102 startIndex > paragraph text size 259103 ifTrue: [^ false]. 259104 self hasSelection ifTrue: 259105 ["there was a selection" 259106 self zapSelectionWith: self nullText. 259107 ^ false]. 259108 "Null selection - do the delete forward" 259109 beginTypeInBlock == nil "no previous typing. openTypeIn" 259110 ifTrue: [self openTypeIn. UndoSelection := self nullText]. 259111 uinterval := UndoInterval deepCopy. 259112 upara := UndoParagraph deepCopy. 259113 stopIndex := startIndex. 259114 (keyEvent keyValue = 127 and: [keyEvent leftShiftDown]) 259115 ifTrue: [stopIndex := (self nextWord: stopIndex) - 1]. 259116 self selectFrom: startIndex to: stopIndex. 259117 self replaceSelectionWith: self nullText. 259118 self selectFrom: startIndex to: startIndex-1. 259119 UndoParagraph := upara. UndoInterval := uinterval. 259120 UndoMessage selector == #noUndoer ifTrue: [ 259121 (UndoSelection isText) ifTrue: [ 259122 usel := UndoSelection. 259123 ind := startIndex. "UndoInterval startIndex" 259124 usel replaceFrom: usel size + 1 to: usel size with: 259125 (UndoParagraph text copyFrom: ind to: ind). 259126 UndoParagraph text replaceFrom: ind to: ind with: 259127self nullText]]. 259128 ^false! ! 259129 259130!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 13:20'! 259131normalCharacter: characterStream character: character 259132 "A nonspecial character is to be added to the stream of characters." 259133 259134 characterStream nextPut: character. 259135 ^false! ! 259136 259137!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:41'! 259138querySymbol: characterStream 259139 "Invoked by Ctrl-q to query the Symbol table and display alternate symbols. 259140 See comment in completeSymbol:lastOffering: for details." 259141 259142 self closeTypeIn: characterStream. "keep typeahead" 259143 self hasCaret 259144 ifTrue: "Ctrl-q typed when a caret" 259145 [self perform: #completeSymbol:lastOffering: withArguments: 259146 ((UndoParagraph == paragraph and: [UndoMessage sends: #undoQuery:lastOffering:]) 259147 ifTrue: [UndoMessage arguments] "repeated Ctrl-q" 259148 ifFalse: [Array with: nil with: nil])] "initial Ctrl-q" 259149 ifFalse: "Ctrl-q typed when statements were highlighted" 259150 [self flash]. 259151 ^true! ! 259152 259153!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:41'! 259154search: characterStream 259155 "Invoked by Ctrl-S. Same as 'again', but always uses the existing FindText 259156 and ChangeText regardless of the last edit." 259157 259158 self closeTypeIn: characterStream. 259159 self againOrSame: true. "true means use same keys" 259160 ^true! ! 259161 259162!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'sw 8/29/2000 14:58'! 259163selectAll 259164 "Make the selection be all the characters of the receiver" 259165 259166 self selectFrom: 1 to: paragraph text string size! ! 259167 259168!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'michael.rueger 2/23/2009 12:41'! 259169selectAll: characterStream 259170 "select everything, invoked by cmd-a. 1/17/96 sw" 259171 259172 self closeTypeIn: characterStream. 259173 self selectFrom: 1 to: paragraph text string size. 259174 ^ true! ! 259175 259176!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 9/19/2002 17:34'! 259177simulatedBackspace 259178 "Backspace over the last character, derived from hand-char recognition. 2/5/96 sw" 259179 259180 | startIndex | 259181 startIndex := self markIndex + (self hasSelection ifTrue: [1] ifFalse: [0]). 259182 259183 startIndex := 1 max: startIndex - 1. 259184 self backTo: startIndex. 259185 ^ false! ! 259186 259187 259188!ParagraphEditor methodsFor: 'undo support'! 259189isDoing 259190 "Call from a doer/undoer/redoer any time to see which it is." 259191 259192 ^(self isUndoing | self isRedoing) not! ! 259193 259194!ParagraphEditor methodsFor: 'undo support'! 259195isRedoing 259196 "Call from a doer/undoer/redoer any time to see which it is." 259197 259198 ^UndoParagraph == #redoing! ! 259199 259200!ParagraphEditor methodsFor: 'undo support'! 259201isUndoing 259202 "Call from a doer/undoer/redoer any time to see which it is." 259203 259204 ^UndoParagraph == #undoing! ! 259205 259206!ParagraphEditor methodsFor: 'undo support'! 259207noUndoer 259208 "The Undoer to use when the command can not be undone. Checked for 259209 specially by readKeyboard." 259210 259211 UndoMessage := Message selector: #noUndoer! ! 259212 259213!ParagraphEditor methodsFor: 'undo support'! 259214undoMessage: aMessage forRedo: aBoolean 259215 "Call this from an undoer/redoer to set up UndoMessage as the 259216 corresponding redoer/undoer. Also set up UndoParagraph, as well 259217 as the state variable Undone. It is assumed that UndoInterval has been 259218 established (generally by zapSelectionWith:) and that UndoSelection has been 259219 saved (generally by replaceSelectionWith: or replace:With:and:)." 259220 259221 self isDoing ifTrue: [UndoParagraph := paragraph]. 259222 UndoMessage := aMessage. 259223 Undone := aBoolean! ! 259224 259225!ParagraphEditor methodsFor: 'undo support'! 259226undoer: aSelector 259227 "See comment in undoMessage:. Use this version when aSelector has no arguments, and you are doing or redoing and want to prepare for undoing." 259228 259229 self undoMessage: (Message selector: aSelector) forRedo: false! ! 259230 259231!ParagraphEditor methodsFor: 'undo support'! 259232undoer: aSelector with: arg1 259233 "See comment in undoMessage:. Use this version when aSelector has one argument, and you are doing or redoing and want to prepare for undoing." 259234 259235 self undoMessage: (Message selector: aSelector argument: arg1) forRedo: false! ! 259236 259237!ParagraphEditor methodsFor: 'undo support'! 259238undoer: aSelector with: arg1 with: arg2 259239 "See comment in undoMessage:. Use this version when aSelector has two arguments, and you are doing or redoing and want to prepare for undoing." 259240 259241 self undoMessage: (Message selector: aSelector arguments: (Array with: arg1 with: arg2)) forRedo: false! ! 259242 259243!ParagraphEditor methodsFor: 'undo support'! 259244undoer: aSelector with: arg1 with: arg2 with: arg3 259245 "See comment in undoMessage:. Use this version when aSelector has three arguments, and you are doing or redoing and want to prepare for undoing." 259246 259247 self undoMessage: (Message selector: aSelector arguments: (Array with: arg1 with: arg2 with: arg3)) forRedo: false! ! 259248 259249 259250!ParagraphEditor methodsFor: 'undoers'! 259251undoAgain: indices andReselect: home typedKey: wasTypedKey 259252 "The last command was again. Undo it. Redoer: itself." 259253 259254 | findSize substText index subject | 259255 (self isRedoing & wasTypedKey) ifTrue: "redelete search key" 259256 [self selectInterval: home. 259257 self zapSelectionWith: self nullText]. 259258 259259 findSize := (self isRedoing ifTrue: [FindText] ifFalse: [ChangeText]) size. 259260 substText := self isUndoing ifTrue: [FindText] ifFalse: [ChangeText]. 259261 (self isUndoing ifTrue: [indices size to: 1 by: -1] ifFalse: [1 to: indices size]) do: 259262 [:i | 259263 index := indices at: i. 259264 (subject := index to: index + findSize - 1) = self selectionInterval ifFalse: 259265 [self selectInterval: subject]. 259266 FindText == ChangeText ifFalse: [self zapSelectionWith: substText]]. 259267 259268 self isUndoing 259269 ifTrue: "restore selection to where it was when 'again' was invoked" 259270 [wasTypedKey 259271 ifTrue: "search started by typing key at a caret; restore it" 259272 [self selectAt: home first. 259273 self zapSelectionWith: FindText. 259274 self selectAt: home last + 1] 259275 ifFalse: [self selectInterval: home]]. 259276 259277 self undoMessage: UndoMessage forRedo: self isUndoing! ! 259278 259279!ParagraphEditor methodsFor: 'undoers'! 259280undoAndReselect: undoHighlight redoAndReselect: redoHighlight 259281 "Undo typing, cancel, paste, and other operations that are like replaces 259282 but the selection is not the whole restored text after undo, redo, or both. 259283 undoHighlight is selected after this phase and redoHighlight after the next phase. 259284 Redoer: itself." 259285 259286 self replace: self selectionInterval with: UndoSelection and: 259287 [self selectInterval: undoHighlight]. 259288 self undoMessage: (UndoMessage argument: redoHighlight) forRedo: self isUndoing 259289! ! 259290 259291!ParagraphEditor methodsFor: 'undoers'! 259292undoCutCopy: oldPasteBuffer 259293 "Undo of a cut, copy, or any edit that changed CurrentSelection. Be sure 259294 undo-copy does not lock the model. Redoer: itself, so never isRedoing." 259295 259296 | recentCut | 259297 recentCut := self clipboardText. 259298 UndoSelection size = UndoInterval size 259299 ifFalse: [self replaceSelectionWith: UndoSelection]. 259300 self clipboardTextPut: oldPasteBuffer. 259301 self undoer: #undoCutCopy: with: recentCut! ! 259302 259303!ParagraphEditor methodsFor: 'undoers' stamp: 'th 9/19/2002 18:46'! 259304undoQuery: hintText lastOffering: selectorOrNil 259305 "Undo ctrl-q. selectorOrNil (if not nil) is the previously offered selector. 259306 hintText is the original hint. Redoer: completeSymbol." 259307 259308 self zapSelectionWith: UndoSelection. 259309 self undoMessage: (Message selector: #completeSymbol:lastOffering: arguments: UndoMessage arguments) forRedo: true. 259310 self selectAt: self stopIndex! ! 259311 259312!ParagraphEditor methodsFor: 'undoers'! 259313undoReplace 259314 "Undo of any command that replaced a selection by other text that it left 259315 highlighted, and that is undone and redone by simple reversal of the 259316 operation. This is the most common Undoer; call replaceSelectionWith: 259317 to get this setup. Redoer: itself, so never isRedoing." 259318 259319 self replaceSelectionWith: UndoSelection! ! 259320 259321 259322!ParagraphEditor methodsFor: 'watchIt' stamp: 'hfm 1/11/2009 11:38'! 259323compileSelectionAsBlock 259324 "Treat the current selection as an expression; evaluate it and return the result" 259325 259326 | stream result rcvr ctxt | 259327 self lineSelectAndEmptyCheck: [^ '']. 259328 259329 stream := ReadWriteStream on: (String new: (startBlock stringIndex) - (stopBlock stringIndex) + 2). 259330 stream nextPutAll: '[[ '. 259331 stream next: ((startBlock stringIndex) - (stopBlock stringIndex)) 259332 putAll: paragraph string 259333 startingAt: stopBlock stringIndex. 259334 stream nextPutAll: ' ] on: Error do: [ :ex | ex ]]'. 259335 stream reset. 259336 259337 (model respondsTo: #doItReceiver) 259338 ifTrue: [ FakeClassPool adopt: model selectedClass. "Include model pool vars if any" 259339 rcvr := model doItReceiver. 259340 ctxt := model doItContext] 259341 ifFalse: [rcvr := ctxt := nil]. 259342 result := [ 259343 rcvr class evaluatorClass new 259344 evaluate: stream 259345 in: ctxt 259346 to: rcvr 259347 notifying: self 259348 ifFail: [ FakeClassPool adopt: nil. 259349 ^ #failedDoit] 259350 ] 259351 on: OutOfScopeNotification 259352 do: [ :ex | ex resume: true]. 259353 FakeClassPool adopt: nil. 259354 ^ result! ! 259355 259356!ParagraphEditor methodsFor: 'watchIt' stamp: 'hfm 1/11/2009 10:35'! 259357watchIt 259358 259359 self inspectIt! ! 259360 259361 259362!ParagraphEditor methodsFor: 'private' stamp: 'th 9/19/2002 18:48'! 259363againOnce: indices 259364 "Find the next occurrence of FindText. If none, answer false. 259365 Append the start index of the occurrence to the stream indices, and, if 259366 ChangeText is not the same object as FindText, replace the occurrence by it. 259367 Note that the search is case-sensitive for replacements, otherwise not." 259368 259369 | where | 259370 where := paragraph text findString: FindText startingAt: self stopIndex 259371 caseSensitive: ((ChangeText ~~ FindText) or: [Preferences caseSensitiveFinds]). 259372 where = 0 ifTrue: [^ false]. 259373 self deselect; selectInvisiblyFrom: where to: where + FindText size - 1. 259374 ChangeText ~~ FindText ifTrue: [self zapSelectionWith: ChangeText]. 259375 indices nextPut: where. 259376 self selectAndScroll. 259377 ^ true! ! 259378 259379!ParagraphEditor methodsFor: 'private' stamp: 'michael.rueger 2/23/2009 13:23'! 259380againOrSame: useOldKeys 259381 "Subroutine of search: and again. If useOldKeys, use same FindText and ChangeText as before. 259382 1/26/96 sw: real worked moved to againOrSame:many:" 259383 259384 ^ self againOrSame: useOldKeys many: Sensor leftShiftDown! ! 259385 259386!ParagraphEditor methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 10:13'! 259387againOrSame: useOldKeys many: many 259388 "Subroutine of search: and again. If useOldKeys, use same FindText and ChangeText as before. If many is true, do it repeatedly. Created 1/26/96 sw by adding the many argument to #againOrSame." 259389 259390 | home indices wasTypedKey | 259391 259392 home := self selectionInterval. "what was selected when 'again' was invoked" 259393 259394 "If new keys are to be picked..." 259395 useOldKeys ifFalse: "Choose as FindText..." 259396 [FindText := UndoSelection. "... the last thing replaced." 259397 "If the last command was in another paragraph, ChangeText is set..." 259398 paragraph == UndoParagraph ifTrue: "... else set it now as follows." 259399 [UndoInterval ~= home ifTrue: [self selectInterval: UndoInterval]. "blink" 259400 ChangeText := ((UndoMessage sends: #undoCutCopy:) and: [self hasSelection]) 259401 ifTrue: [FindText] "== objects signal no model-locking by 'undo copy'" 259402 ifFalse: [self selection]]]. "otherwise, change text is last-replaced text" 259403 259404 (wasTypedKey := FindText size = 0) 259405 ifTrue: "just inserted at a caret" 259406 [home := self selectionInterval. 259407 self replaceSelectionWith: self nullText. "delete search key..." 259408 FindText := ChangeText] "... and search for it, without replacing" 259409 ifFalse: "Show where the search will start" 259410 [home last = self selectionInterval last ifFalse: 259411 [self selectInterval: home]]. 259412 259413 "Find and Change, recording start indices in the array" 259414 indices := (Array new: 20) writeStream. "an array to store change locs" 259415 [(self againOnce: indices) & many] whileTrue. "<-- this does the work" 259416 indices isEmpty ifTrue: "none found" 259417 [self flash. 259418 wasTypedKey ifFalse: [^self]]. 259419 259420 (many | wasTypedKey) ifFalse: "after undo, select this replacement" 259421 [home := self startIndex to: 259422 self startIndex + UndoSelection size - 1]. 259423 259424 self undoer: #undoAgain:andReselect:typedKey: with: indices contents with: home with: wasTypedKey! ! 259425 259426!ParagraphEditor methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 10:14'! 259427completeSymbol: hintText lastOffering: selectorOrNil 259428 "Invoked by Ctrl-q when there is only a caret. 259429 Do selector-completion, i.e., try to replace the preceding identifier by a 259430 selector that begins with those characters & has as many keywords as possible. 259431 Leave two spaces after each colon (only one after the last) as space for 259432 arguments. Put the caret after the space after the first keyword. If the 259433 user types Ctrl-q again immediately, choose a different selector. 259434 Undoer: #undoQuery:lastOffering:; Redoer: itself. 259435 If redoing, just redisplay the last offering, selector[OrNil]." 259436 259437 | firstTime input prior caret newStart sym kwds outStream | 259438 firstTime := self isRedoing 259439 ifTrue: [prior := sym := selectorOrNil. true] 259440 ifFalse: [hintText isNil]. 259441 firstTime 259442 ifTrue: "Initial Ctrl-q (or redo)" 259443 [caret := self startIndex. 259444 self selectPrecedingIdentifier. 259445 input := self selection] 259446 ifFalse: "Repeated Ctrl-q" 259447 [caret := UndoInterval first + hintText size. 259448 self selectInvisiblyFrom: UndoInterval first to: UndoInterval last. 259449 input := hintText. 259450 prior := selectorOrNil]. 259451 (input size ~= 0 and: [sym ~~ nil or: 259452 [(sym := Symbol thatStarts: input string skipping: prior) ~~ nil]]) 259453 ifTrue: "found something to offer" 259454 [newStart := self startIndex. 259455 outStream := (String new: 2 * sym size) writeStream. 259456 1 to: (kwds := sym keywords) size do: 259457 [:i | 259458 outStream nextPutAll: (kwds at: i). 259459 i = 1 ifTrue: [caret := newStart + outStream contents size + 1]. 259460 outStream nextPutAll: 259461 (i < kwds size ifTrue: [' '] ifFalse: [' '])]. 259462 UndoSelection := input. 259463 self deselect; zapSelectionWith: outStream contents asText. 259464 self undoer: #undoQuery:lastOffering: with: input with: sym] 259465 ifFalse: "no more matches" 259466 [firstTime ifFalse: "restore original text & set up for a redo" 259467 [UndoSelection := self selection. 259468 self deselect; zapSelectionWith: input. 259469 self undoer: #completeSymbol:lastOffering: with: input with: prior. 259470 Undone := true]. 259471 self flash]. 259472 self selectAt: caret! ! 259473 259474!ParagraphEditor methodsFor: 'private' stamp: 'alain.plantec 6/11/2008 15:06'! 259475exchangeWith: prior 259476 "If the prior selection is non-overlapping and legal, exchange the text of 259477 it with the current selection and leave the currently selected text selected 259478 in the location of the prior selection (or leave a caret after a non-caret if it was 259479 exchanged with a caret). If both selections are carets, flash & do nothing. 259480 Don't affect the paste buffer. Undoer: itself; Redoer: Undoer." 259481 259482 | start stop before selection priorSelection delta altInterval | 259483 start := self startIndex. 259484 stop := self stopIndex - 1. 259485 ((prior first <= prior last) | (start <= stop) "Something to exchange" and: 259486 [self isDisjointFrom: prior]) 259487 ifTrue: 259488 [before := prior last < start. 259489 selection := self selection. 259490 priorSelection := paragraph text copyFrom: prior first to: prior last. 259491 259492 delta := before ifTrue: [0] ifFalse: [priorSelection size - selection size]. 259493 self zapSelectionWith: priorSelection. 259494 self selectFrom: prior first + delta to: prior last + delta. 259495 259496 delta := before ifTrue: [stop - prior last] ifFalse: [start - prior first]. 259497 self zapSelectionWith: selection. 259498 altInterval := prior first + delta to: prior last + delta. 259499 self undoer: #exchangeWith: with: altInterval. 259500 "If one was a caret, make it otherInterval & leave the caret after the other" 259501 prior first > prior last ifTrue: [self selectAt: UndoInterval last + 1]. 259502 otherInterval := start > stop 259503 ifTrue: [self selectAt: altInterval last + 1. UndoInterval] 259504 ifFalse: [altInterval]] 259505 ifFalse: 259506 [self flash]! ! 259507 259508!ParagraphEditor methodsFor: 'private'! 259509indent: delta fromStream: inStream toStream: outStream 259510 "Append the contents of inStream to outStream, adding or deleting delta or -delta 259511 tabs at the beginning, and after every CR except a final CR. Do not add tabs 259512 to totally empty lines, and be sure nothing but tabs are removed from lines." 259513 259514 | ch skip cr tab prev atEnd | 259515 cr := Character cr. 259516 tab := Character tab. 259517 delta > 0 259518 ifTrue: "shift right" 259519 [prev := cr. 259520 [ch := (atEnd := inStream atEnd) ifTrue: [cr] ifFalse: [inStream next]. 259521 (prev == cr and: [ch ~~ cr]) ifTrue: 259522 [delta timesRepeat: [outStream nextPut: tab]]. 259523 atEnd] 259524 whileFalse: 259525 [outStream nextPut: ch. 259526 prev := ch]] 259527 ifFalse: "shift left" 259528 [skip := delta. "a negative number" 259529 [inStream atEnd] whileFalse: 259530 [((ch := inStream next) == tab and: [skip < 0]) ifFalse: 259531 [outStream nextPut: ch]. 259532 skip := ch == cr ifTrue: [delta] ifFalse: [skip + 1]]]! ! 259533 259534!ParagraphEditor methodsFor: 'private' stamp: 'cmm 4/9/2004 14:00'! 259535isDisjointFrom: anInterval 259536 "Answer true if anInterval is a caret not touching or within the current 259537 interval, or if anInterval is a non-caret that does not overlap the current 259538 selection." 259539 259540 | fudge | 259541 fudge := anInterval size = 0 ifTrue: [1] ifFalse: [0]. 259542 ^(anInterval last + fudge < self startIndex or: 259543 [anInterval first - fudge >= self stopIndex]) 259544! ! 259545 259546!ParagraphEditor methodsFor: 'private' stamp: 'th 11/24/2002 17:13'! 259547lines 259548 "Other than my member paragraph i compute lines based on logical 259549 line breaks, not optical (which may change due to line wrapping of the editor)" 259550 | lines string index lineIndex stringSize | 259551 string := paragraph text string. 259552 "Empty strings have no lines at all. Think of something." 259553 string isEmpty ifTrue:[^{#(1 0 0)}]. 259554 stringSize := string size. 259555 lines := OrderedCollection new: (string size // 15). 259556 index := 0. 259557 lineIndex := 0. 259558 string linesDo:[:line | 259559 lines addLast: (Array 259560 with: (index := index + 1) 259561 with: (lineIndex := lineIndex + 1) 259562 with: (index := index + line size min: stringSize))]. 259563 "Special workaround for last line empty." 259564 string last == Character cr 259565 "lines last last < stringSize" ifTrue:[lines addLast:{stringSize +1. lineIndex+1. stringSize}]. 259566 ^lines! ! 259567 259568!ParagraphEditor methodsFor: 'private' stamp: 'michael.rueger 2/23/2009 13:30'! 259569moveCursor: directionBlock forward: forward specialBlock: specialBlock 259570 "Private - Move cursor. 259571 directionBlock is a one argument Block that computes the new Position from a given one. 259572 specialBlock is a one argumentBlock that computes the new position from a given one under the alternate semantics. 259573 Note that directionBlock always is evaluated first." 259574 | shift indices newPosition | 259575 shift := Sensor leftShiftDown. 259576 indices := self setIndices: shift forward: forward. 259577 newPosition := directionBlock value: (indices at: #moving). 259578 (Sensor commandKeyPressed or:[Sensor controlKeyPressed]) 259579 ifTrue: [newPosition := specialBlock value: newPosition]. 259580 shift 259581 ifTrue: [self selectMark: (indices at: #fixed) point: newPosition - 1] 259582 ifFalse: [self selectAt: newPosition]! ! 259583 259584!ParagraphEditor methodsFor: 'private' stamp: 'sma 12/15/1999 11:32'! 259585nextWord: position 259586 | string index | 259587 string := paragraph text string. 259588 index := position. 259589 [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric]] 259590 whileTrue: [index := index + 1]. 259591 [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric not]] 259592 whileTrue: [index := index + 1]. 259593 ^ index! ! 259594 259595!ParagraphEditor methodsFor: 'private'! 259596nullText 259597 259598 ^Text string: '' emphasis: emphasisHere! ! 259599 259600!ParagraphEditor methodsFor: 'private' stamp: 'th 9/20/2002 11:09'! 259601pageHeight 259602 | howManyLines visibleHeight totalHeight ratio | 259603 howManyLines := paragraph numberOfLines. 259604 visibleHeight := self visibleHeight. 259605 totalHeight := self totalTextHeight. 259606 ratio := visibleHeight / totalHeight. 259607 ^(ratio * howManyLines) rounded - 2! ! 259608 259609!ParagraphEditor methodsFor: 'private' stamp: 'sma 12/15/1999 11:33'! 259610previousWord: position 259611 | string index | 259612 string := paragraph text string. 259613 index := position. 259614 [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric not]] 259615 whileTrue: [index := index - 1]. 259616 [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric]] 259617 whileTrue: [index := index - 1]. 259618 ^ index + 1! ! 259619 259620!ParagraphEditor methodsFor: 'private' stamp: 'BG 4/29/2004 11:19'! 259621sameColumn: start newLine: lineBlock forward: isForward 259622 "Private - Compute the index in my text 259623 with the line number derived from lineBlock," 259624 " a one argument block accepting the old line number. 259625 The position inside the line will be preserved as good as possible" 259626 "The boolean isForward is used in the border case to determine if 259627 we should move to the beginning or the end of the line." 259628 | wordStyle column currentLine offsetAtTargetLine targetEOL lines numberOfLines currentLineNumber targetLineNumber | 259629 wordStyle := Preferences wordStyleCursorMovement. 259630 wordStyle 259631 ifTrue: [ 259632 lines := paragraph lines. 259633 numberOfLines := paragraph numberOfLines. 259634 currentLineNumber := paragraph lineIndexOfCharacterIndex: start. 259635 currentLine := lines at: currentLineNumber] 259636 ifFalse: [ 259637 lines := self lines. 259638 numberOfLines := lines size. 259639 currentLine := lines 259640 detect:[:lineInterval | lineInterval last >= start] 259641 ifNone:[lines last]. 259642 currentLineNumber := currentLine second]. 259643 column := start - currentLine first. 259644 targetLineNumber := ((lineBlock value: currentLineNumber) max: 1) min: numberOfLines. 259645 offsetAtTargetLine := (lines at: targetLineNumber) first. 259646 targetEOL := (lines at: targetLineNumber) last + (targetLineNumber == numberOfLines ifTrue:[1]ifFalse:[0]). 259647 targetLineNumber == currentLineNumber 259648 "No movement or movement failed. Move to beginning or end of line." 259649 ifTrue:[^isForward 259650 ifTrue:[targetEOL] 259651 ifFalse:[offsetAtTargetLine]]. 259652 ^offsetAtTargetLine + column min: targetEOL.! ! 259653 259654!ParagraphEditor methodsFor: 'private' stamp: 'md 2/22/2006 21:17'! 259655setIndices: shiftPressed forward: forward 259656 "Little helper method that sets the moving and fixed indices according to some flags." 259657 | indices | 259658 indices := Dictionary new. 259659 shiftPressed ifTrue: [ 259660 indices at: #moving put: self pointIndex. 259661 indices at: #fixed put: self markIndex 259662 ] ifFalse: [ 259663 forward 259664 ifTrue:[ 259665 indices at: #moving put: self stopIndex. 259666 indices at: #fixed put: self startIndex. 259667 ] ifFalse: [ 259668 indices at: #moving put: self startIndex. 259669 indices at: #fixed put: self stopIndex. 259670 ] 259671 ]. 259672 ^indices! ! 259673 259674"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 259675 259676ParagraphEditor class 259677 instanceVariableNames: ''! 259678 259679!ParagraphEditor class methodsFor: 'class initialization' stamp: 'sw 5/27/2000 00:03'! 259680abandonChangeText 259681 "Call this to get out of the maddening situation in which the system keeps aggressively trying to do a replacement that you no longer wish to make, every time you make choose a new method in a list." 259682 ChangeText := FindText 259683 259684 "ParagraphEditor abandonChangeText" 259685! ! 259686 259687!ParagraphEditor class methodsFor: 'class initialization' stamp: 'michael.rueger 3/23/2009 17:51'! 259688initialize 259689 "Initialize the keyboard shortcut maps and the shared buffers 259690 for copying text across views and managing again and undo. 259691 Marked this method changed to trigger reinit" 259692 259693 "ParagraphEditor initialize" 259694 259695 UndoSelection := FindText := ChangeText := Text new. 259696 UndoMessage := Message selector: #halt. 259697 self initializeCmdKeyShortcuts. 259698 self initializeShiftCmdKeyShortcuts.! ! 259699 259700!ParagraphEditor class methodsFor: 'class initialization' stamp: 'al 9/20/2008 19:05'! 259701shiftedYellowButtonMenu 259702 "Answer the menu to be presented when the yellow button is pressed while the shift key is down" 259703 259704 ^ MenuMorph fromArray: { 259705 259706 {'browse it (b)' translated. #browseIt}. 259707 {'senders of it (n)' translated. #sendersOfIt}. 259708 {'implementors of it (m)' translated. #implementorsOfIt}. 259709 {'references to it (N)' translated. #referencesToIt}. 259710 #-. 259711 {'selectors containing it (W)' translated. #methodNamesContainingIt}. 259712 {'method strings with it (E)' translated. #methodStringsContainingit}. 259713 {'method source with it' translated. #methodSourceContainingIt}. 259714 {'class names containing it' translated. #classNamesContainingIt}. 259715 {'class comments with it' translated. #classCommentsContainingIt}. 259716 {'change sets with it' translated. #browseChangeSetsWithSelector}. 259717 " #-. 259718 {'pretty print' translated. #prettyPrint}. 259719 {'pretty print with color' translated. #prettyPrintWithColor}. 259720 {'file it in (G)' translated. #fileItIn}. 259721 #-. 259722 {'back...' translated. #yellowButtonActivity}. 259723 " 259724 } 259725! ! 259726 259727!ParagraphEditor class methodsFor: 'class initialization' stamp: 'AdrianLienhard 8/26/2009 22:02'! 259728yellowButtonExpertMenu 259729 ^ MenuMorph fromArray: { 259730 {'do it (d)' translated. #doIt}. 259731 {'print it (p)' translated. #printIt}. 259732 {'inspect it (i)' translated. #inspectIt}. 259733 {'explore it (I)' translated. #exploreIt}. 259734 {'debug it (D)' translated. #debugIt}. 259735 {'profile it' translated. #tallyIt}. 259736 {'watch it' translated. #watchIt}. 259737 259738 #-. 259739 {'find...(f)' translated. #find}. 259740 {'find again (g)' translated. #findAgain}. 259741 {'extended search...' translated. #shiftedTextPaneMenuRequest}. 259742 #-. 259743 {'do again (j)' translated. #again}. 259744 {'undo (z)' translated. #undo}. 259745 #-. 259746 {'copy (c)' translated. #copySelection}. 259747 {'cut (x)' translated. #cut}. 259748 {'paste (v)' translated. #paste}. 259749 {'paste...' translated. #pasteRecent}. 259750 #-. 259751 {'accept (s)' translated. #accept}. 259752 {'cancel (l)' translated. #cancel}. 259753 }. 259754! ! 259755 259756!ParagraphEditor class methodsFor: 'class initialization' stamp: 'marcus.denker 11/19/2008 13:49'! 259757yellowButtonMenu 259758 259759 ^self yellowButtonExpertMenu 259760! ! 259761 259762!ParagraphEditor class methodsFor: 'class initialization' stamp: 'stephane.ducasse 9/13/2008 16:40'! 259763yellowButtonNoviceMenu 259764 259765 ^ MenuMorph fromArray: { 259766 {'set font... (k)' translated. #offerFontMenu}. 259767 {'set style... (K)' translated. #changeStyle}. 259768 {'set alignment... (u)' translated. #chooseAlignment}. 259769 #-. 259770 {'find...(f)' translated. #find}. 259771 {'find again (g)' translated. #findAgain}. 259772 {'set search string (h)' translated. #setSearchString}. 259773 #-. 259774 {'do again (j)' translated. #again}. 259775 {'undo (z)' translated. #undo}. 259776 #-. 259777 {'copy (c)' translated. #copySelection}. 259778 {'cut (x)' translated. #cut}. 259779 {'paste (v)' translated. #paste}. 259780 {'paste...' translated. #pasteRecent}. 259781 #-. 259782 {'accept (s)' translated. #accept}. 259783 {'cancel (l)' translated. #cancel}. 259784 }. 259785! ! 259786 259787 259788!ParagraphEditor class methodsFor: 'instance creation' stamp: 'nk 9/3/2004 14:10'! 259789new 259790 "Answer a new instance of me with a null Paragraph to be edited." 259791 259792 | aParagraphEditor | 259793 aParagraphEditor := super new. 259794 aParagraphEditor changeParagraph: '' asParagraph. 259795 ^aParagraphEditor! ! 259796 259797!ParagraphEditor class methodsFor: 'instance creation'! 259798newParagraph: aParagraph 259799 "Answer an instance of me with aParagraph as the text to be edited." 259800 259801 | aParagraphEditor | 259802 aParagraphEditor := super new. 259803 aParagraphEditor initialize. 259804 aParagraphEditor changeParagraph: aParagraph. 259805 ^aParagraphEditor! ! 259806 259807 259808!ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'michael.rueger 2/23/2009 18:15'! 259809initializeCmdKeyShortcuts 259810 "Initialize the (unshifted) command-key (or alt-key) shortcut table." 259811 259812 "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest" 259813 259814 "ParagraphEditor initialize" 259815 259816 | cmdMap | 259817 259818 cmdMap := Array new: 256 withAll: #noop:. "use temp in case of a crash" 259819 259820 cmdMap at: 1 + 1 put: #cursorHome:. "home key" 259821 cmdMap at: 4 + 1 put: #cursorEnd:. "end key" 259822 cmdMap at: 8 + 1 put: #backspace:. "ctrl-H or delete key" 259823 cmdMap at: 11 + 1 put: #cursorPageUp:. "page up key" 259824 cmdMap at: 12 + 1 put: #cursorPageDown:. "page down key" 259825 cmdMap at: 13 + 1 put: #crWithIndent:. "cmd-Return" 259826 cmdMap at: 27 + 1 put: #offerMenuFromEsc:. "escape key" 259827 cmdMap at: 28 + 1 put: #cursorLeft:. "left arrow key" 259828 cmdMap at: 29 + 1 put: #cursorRight:. "right arrow key" 259829 cmdMap at: 30 + 1 put: #cursorUp:. "up arrow key" 259830 cmdMap at: 31 + 1 put: #cursorDown:. "down arrow key" 259831 cmdMap at: 32 + 1 put: #selectWord:. "space bar key" 259832 cmdMap at: 127 + 1 put: #forwardDelete:keyEvent:. "del key" 259833 259834 '0123456789-=' 259835 do: [:char | cmdMap at: char asciiValue + 1 put: #changeEmphasis:keyEvent:]. 259836 259837 '([{''"<' do: [:char | cmdMap at: char asciiValue + 1 put: #enclose:keyEvent:]. 259838 259839 cmdMap at: $, asciiValue + 1 put: #shiftEnclose:keyEvent:. 259840 259841 "triplet = {character. comment selector. novice appropiated}" 259842 #( 259843 ($a #selectAll: true) 259844 ($b #browseIt: false) 259845 ($c #copySelection: true) 259846 ($d #doIt: false) 259847 ($e #exchange: true) 259848 ($f #find: true) 259849 ($g #findAgain: true) 259850 ($h #setSearchString: true) 259851 ($i #inspectIt: false) 259852 ($j #doAgainOnce: true) 259853 ($l #cancel: true) 259854 ($m #implementorsOfIt: false) 259855 ($n #sendersOfIt: false) 259856 ($p #printIt: false) 259857 ($q #querySymbol: false) 259858 ($s #save: true) 259859 ($v #paste: true) 259860 ($w #backWord: true) 259861 ($x #cut: true) 259862 ($y #swapChars: true) 259863 ($z #undo: true) 259864 ) 259865 do: [:triplet | cmdMap at: triplet first asciiValue + 1 put: triplet second]. 259866 259867 CmdActions := cmdMap. 259868! ! 259869 259870!ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'CB 7/27/2009 14:50'! 259871initializeShiftCmdKeyShortcuts 259872 "Initialize the shift-command-key (or control-key) shortcut table." 259873 "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest" 259874 "wod 11/3/1998: Fix setting of cmdMap for shifted keys to actually use the 259875 capitalized versions of the letters. 259876 TPR 2/18/99: add the plain ascii values back in for those VMs that don't return the shifted values." 259877 259878 | cmdMap | 259879 259880 "shift-command and control shortcuts" 259881 cmdMap := Array new: 256 withAll: #noop:. "use temp in case of a crash" 259882 259883 cmdMap at: ( 1 + 1) put: #cursorHome:. "home key" 259884 cmdMap at: ( 4 + 1) put: #cursorEnd:. "end key" 259885 cmdMap at: ( 8 + 1) put: #forwardDelete:keyEvent:. "ctrl-H or delete key" 259886 cmdMap at: (11 + 1) put: #cursorPageUp:. "page up key" 259887 cmdMap at: (12 + 1) put: #cursorPageDown:. "page down key" 259888 cmdMap at: (13 + 1) put: #crWithIndent:. "ctrl-Return" 259889 cmdMap at: (27 + 1) put: #offerMenuFromEsc:. "escape key" 259890 cmdMap at: (28 + 1) put: #cursorLeft:. "left arrow key" 259891 cmdMap at: (29 + 1) put: #cursorRight:. "right arrow key" 259892 cmdMap at: (30 + 1) put: #cursorUp:. "up arrow key" 259893 cmdMap at: (31 + 1) put: #cursorDown:. "down arrow key" 259894 cmdMap at: (32 + 1) put: #selectWord:. "space bar key" 259895 cmdMap at: (45 + 1) put: #changeEmphasis:keyEvent:. "cmd-sh-minus" 259896 cmdMap at: (61 + 1) put: #changeEmphasis:keyEvent:. "cmd-sh-plus" 259897 cmdMap at: (127 + 1) put: #forwardDelete:keyEvent:. "del key" 259898 259899 "Note: Command key overrides shift key, so, for example, cmd-shift-9 produces $9 not $(" 259900 '9[,''' do: [ :char | cmdMap at: (char asciiValue + 1) put: #shiftEnclose:keyEvent: ]. "({< and double-quote" 259901 "Note: Must use cmd-9 or ctrl-9 to get '()' since cmd-shift-9 is a Mac FKey command." 259902 259903 "NB: sw 12/9/2001 commented out the idiosyncratic line just below, which was grabbing shift-esc in the text editor and hence which argued with the wish to have shift-esc be a universal gesture for escaping the local context and calling up the desktop menu." 259904 "cmdMap at: (27 + 1) put: #shiftEnclose:." "ctrl-[" 259905 259906 "'""''(' do: [ :char | cmdMap at: (char asciiValue + 1) put: #enclose:]." 259907 259908 "triplet = {character. comment selector. novice appropiated}" 259909 #( 259910 ($a argAdvance: false) 259911 ($b browseItHere: false) 259912 ($c compareToClipboard: false) 259913 ($d debugIt: false) 259914 ($e methodStringsContainingIt: false) 259915 ($f displayIfFalse: false) 259916 ($g fileItIn: false) 259917 ($h cursorTopHome: true) 259918 ($i exploreIt: false) 259919 ($j doAgainMany: true) 259920 ($k changeStyle: true) 259921 ($l outdent: true) 259922 ($m selectCurrentTypeIn: true) 259923 ($n referencesToIt: false) 259924 ($r indent: true) 259925 ($s search: true) 259926 ($t displayIfTrue: false) 259927 ($u changeLfToCr: false) 259928 ($v pasteInitials: false) 259929 ($w methodNamesContainingIt: false) 259930 ($x makeLowercase: true) 259931 ($y makeUppercase: true) 259932 ($z makeCapitalized: true) 259933 ) 259934 do: [:triplet | 259935 cmdMap at: (triplet first asciiValue + 1) put: triplet second. "plain keys" 259936 cmdMap at: (triplet first asciiValue - 32 + 1) put: triplet second. "shifted keys" 259937 cmdMap at: (triplet first asciiValue - 96 + 1) put: triplet second. "ctrl keys" 259938 ]. 259939 259940 ShiftCmdActions := cmdMap! ! 259941 259942!ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'sps 7/24/2003 17:25'! 259943multiRedoOverride 259944"Call this to set meta-r to perform the multilevel redo (or tweak the code below to have it bound to some other key sequence)." 259945 259946" 259947ParagraphEditor multiRedoOverride. 259948" 259949 CmdActions at: $r asciiValue + 1 put: #multiRedo: 259950! ! 259951 259952!ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'sbw 10/8/1999 21:42'! 259953specialShiftCmdKeys 259954 259955"Private - return array of key codes that represent single keys acting 259956as if shift-command were also being pressed" 259957 259958^#( 259959 1 "home" 259960 3 "enter" 259961 4 "end" 259962 8 "backspace" 259963 11 "page up" 259964 12 "page down" 259965 27 "escape" 259966 28 "left arrow" 259967 29 "right arrow" 259968 30 "up arrow" 259969 31 "down arrow" 259970 127 "delete" 259971 )! ! 259972Object subclass: #ParseNode 259973 instanceVariableNames: 'comment pc' 259974 classVariableNames: 'Bfp BtpLong CodeBases CodeLimits DblExtDoAll Dup EndMethod EndRemote Jmp JmpLimit JmpLong LdFalse LdInstLong LdInstType LdLitIndType LdLitType LdMinus1 LdNil LdSelf LdSuper LdTempType LdThisContext LdTrue LoadLong LongLongDoAll NodeFalse NodeNil NodeSelf NodeSuper NodeThisContext NodeTrue Pop Send SendLimit SendLong SendLong2 SendPlus SendType ShortStoP StdLiterals StdSelectors StdVariables Store StorePop' 259975 poolDictionaries: '' 259976 category: 'Compiler-ParseNodes'! 259977!ParseNode commentStamp: '<historical>' prior: 0! 259978This superclass of most compiler/decompiler classes declares common class variables, default messages, and the code emitters for jumps. Some of the class variables are initialized here; the rest are initialized in class VariableNode.! 259979 259980 259981!ParseNode methodsFor: 'code generation'! 259982emitBranchOn: 259983condition dist: dist pop: stack on: strm 259984 stack pop: 1. 259985 dist = 0 ifTrue: [^ strm nextPut: Pop]. 259986 condition 259987 ifTrue: [self emitLong: dist code: BtpLong on: strm] 259988 ifFalse: [self emitShortOrLong: dist code: Bfp on: strm]! ! 259989 259990!ParseNode methodsFor: 'code generation'! 259991emitForEffect: stack on: strm 259992 259993 self emitForValue: stack on: strm. 259994 strm nextPut: Pop. 259995 stack pop: 1! ! 259996 259997!ParseNode methodsFor: 'code generation'! 259998emitForReturn: stack on: strm 259999 260000 self emitForValue: stack on: strm. 260001 strm nextPut: EndMethod! ! 260002 260003!ParseNode methodsFor: 'code generation'! 260004emitJump: dist on: strm 260005 260006 dist = 0 ifFalse: [self emitShortOrLong: dist code: Jmp on: strm]! ! 260007 260008!ParseNode methodsFor: 'code generation'! 260009emitLong: dist code: longCode on: aStream 260010 "Force a two-byte jump." 260011 | code distance | 260012 code := longCode. 260013 distance := dist. 260014 distance < 0 260015 ifTrue: 260016 [distance := distance + 1024. 260017 code := code - 4] 260018 ifFalse: 260019 [distance > 1023 ifTrue: [distance := -1]]. 260020 distance < 0 260021 ifTrue: 260022 [self error: 'A block compiles more than 1K bytes of code'] 260023 ifFalse: 260024 [aStream nextPut: distance // 256 + code. 260025 aStream nextPut: distance \\ 256]! ! 260026 260027!ParseNode methodsFor: 'code generation'! 260028emitShortOrLong: dist code: shortCode on: strm 260029 (1 <= dist and: [dist <= JmpLimit]) 260030 ifTrue: [strm nextPut: shortCode + dist - 1] 260031 ifFalse: [self emitLong: dist code: shortCode + (JmpLong-Jmp) on: strm]! ! 260032 260033!ParseNode methodsFor: 'code generation' stamp: 'nk 7/10/2004 10:04'! 260034pc 260035 "Used by encoder source mapping." 260036 260037 ^pc ifNil: [ 0 ] 260038! ! 260039 260040!ParseNode methodsFor: 'code generation' stamp: 'eem 8/4/2008 13:57'! 260041pc: anInteger 260042 "Used by encoder source mapping." 260043 260044 pc := anInteger! ! 260045 260046!ParseNode methodsFor: 'code generation'! 260047sizeBranchOn: condition dist: dist 260048 dist = 0 ifTrue: [^1]. 260049 ^ condition 260050 ifTrue: [2] "Branch on true is always 2 bytes" 260051 ifFalse: [self sizeShortOrLong: dist]! ! 260052 260053!ParseNode methodsFor: 'code generation'! 260054sizeForEffect: encoder 260055 260056 ^(self sizeForValue: encoder) + 1! ! 260057 260058!ParseNode methodsFor: 'code generation'! 260059sizeForReturn: encoder 260060 260061 ^(self sizeForValue: encoder) + 1! ! 260062 260063!ParseNode methodsFor: 'code generation'! 260064sizeJump: dist 260065 260066 dist = 0 ifTrue: [^0]. 260067 ^self sizeShortOrLong: dist! ! 260068 260069!ParseNode methodsFor: 'code generation'! 260070sizeShortOrLong: dist 260071 260072 (1 <= dist and: [dist <= JmpLimit]) 260073 ifTrue: [^1]. 260074 ^2! ! 260075 260076 260077!ParseNode methodsFor: 'code generation (closures)' stamp: 'eem 7/20/2009 09:54'! 260078optimizedBlockHoistTempsInto: scopeBlock "<BlockNode>" 260079 "This is a No-op for all nodes except non-optimized BlockNodes." 260080 ^self! ! 260081 260082 260083!ParseNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 260084emitCodeForBlockValue: stack encoder: encoder 260085 "Generate code for evaluating the last statement in a block" 260086 ^self emitCodeForValue: stack encoder: encoder! ! 260087 260088!ParseNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:37'! 260089emitCodeForBranchOn: condition dist: dist pop: stack encoder: encoder 260090 stack pop: 1. 260091 dist = 0 ifTrue: [^encoder genPop]. 260092 condition 260093 ifTrue: [encoder genBranchPopTrue: dist] 260094 ifFalse: [encoder genBranchPopFalse: dist]! ! 260095 260096!ParseNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:38'! 260097emitCodeForEffect: stack encoder: encoder 260098 260099 self emitCodeForValue: stack encoder: encoder. 260100 encoder genPop. 260101 stack pop: 1! ! 260102 260103!ParseNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:39'! 260104emitCodeForJump: dist encoder: encoder 260105 260106 dist = 0 ifFalse: [encoder genJump: dist]! ! 260107 260108!ParseNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:38'! 260109emitCodeForReturn: stack encoder: encoder 260110 260111 self emitCodeForValue: stack encoder: encoder. 260112 encoder genReturnTop! ! 260113 260114!ParseNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:13'! 260115sizeCode: encoder forBranchOn: condition dist: dist 260116 dist = 0 ifTrue: [^encoder sizePop]. 260117 ^condition 260118 ifTrue: [encoder sizeBranchPopTrue: dist] 260119 ifFalse: [encoder sizeBranchPopFalse: dist]! ! 260120 260121!ParseNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/15/2008 09:52'! 260122sizeCode: encoder forJump: dist 260123 260124 ^dist = 0 ifTrue: [0] ifFalse: [encoder sizeJump: dist]! ! 260125 260126!ParseNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 260127sizeCodeForBlockValue: encoder 260128 "Answer the size for evaluating the last statement in a block" 260129 ^self sizeCodeForValue: encoder! ! 260130 260131!ParseNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:53'! 260132sizeCodeForEffect: encoder 260133 260134 ^(self sizeCodeForValue: encoder) + encoder sizePop! ! 260135 260136!ParseNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:57'! 260137sizeCodeForReturn: encoder 260138 260139 ^(self sizeCodeForValue: encoder) + encoder sizeReturnTop! ! 260140 260141 260142!ParseNode methodsFor: 'comment'! 260143comment 260144 260145 ^comment! ! 260146 260147!ParseNode methodsFor: 'comment'! 260148comment: newComment 260149 260150 comment := newComment! ! 260151 260152 260153!ParseNode methodsFor: 'converting'! 260154asReturnNode 260155 260156 ^ReturnNode new expr: self! ! 260157 260158 260159!ParseNode methodsFor: 'encoding'! 260160encodeSelector: selector 260161 260162 ^nil! ! 260163 260164 260165!ParseNode methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 10:15'! 260166nodePrintOn: aStrm indent: nn 260167 | var aaStrm myLine | 260168 "Show just the sub nodes and the code." 260169 260170 (aaStrm := aStrm) ifNil: [aaStrm := (String new: 500) writeStream]. 260171 nn timesRepeat: [aaStrm tab]. 260172 aaStrm nextPutAll: self class name; space. 260173 myLine := self printString copyWithout: Character cr. 260174 myLine := myLine copyFrom: 1 to: (myLine size min: 70). 260175 aaStrm nextPutAll: myLine; cr. 260176 1 to: self class instSize do: [:ii | 260177 var := self instVarAt: ii. 260178 (var respondsTo: #asReturnNode) ifTrue: [var nodePrintOn: aaStrm indent: nn+1]]. 260179 1 to: self class instSize do: [:ii | 260180 var := self instVarAt: ii. 260181 (var isKindOf: SequenceableCollection) ifTrue: [ 260182 var do: [:aNode | 260183 (aNode respondsTo: #asReturnNode) ifTrue: [ 260184 aNode nodePrintOn: aaStrm indent: nn+1]]]]. 260185 ^ aaStrm 260186! ! 260187 260188!ParseNode methodsFor: 'printing' stamp: 'eem 9/5/2009 11:27'! 260189printCommentOn: aStream indent: indent 260190 | thisComment | 260191 self comment == nil ifTrue: [^ self]. 260192 1 to: self comment size 260193 do: [:index | 260194 index > 1 ifTrue: [aStream crtab: indent]. 260195 aStream nextPut: $". 260196 thisComment := self comment at: index. 260197 self printSingleComment: thisComment 260198 on: aStream 260199 indent: indent. 260200 aStream nextPut: $"]! ! 260201 260202!ParseNode methodsFor: 'printing' stamp: 'eem 5/6/2008 15:18'! 260203printOn: aStream 260204 "Refer to the comment in Object|printOn:." 260205 260206 aStream nextPut: ${. 260207 self printOn: aStream indent: 0. 260208 aStream nextPut: $}.! ! 260209 260210!ParseNode methodsFor: 'printing'! 260211printOn: aStream indent: anInteger 260212 "If control gets here, avoid recursion loop." 260213 260214 super printOn: aStream! ! 260215 260216!ParseNode methodsFor: 'printing'! 260217printOn: aStream indent: level precedence: p 260218 260219 self printOn: aStream indent: level! ! 260220 260221!ParseNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:51'! 260222printWithClosureAnalysis 260223 260224 ^String streamContents: [:str| self printWithClosureAnalysisOn: str]! ! 260225 260226!ParseNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 260227printWithClosureAnalysisOn: aStream 260228 "Refer to the comment in Object|printOn:." 260229 260230 aStream nextPut: ${. 260231 self printWithClosureAnalysisOn: aStream indent: 0. 260232 aStream nextPut: $}.! ! 260233 260234!ParseNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 260235printWithClosureAnalysisOn: aStream indent: anInteger 260236 "If control gets here, avoid recursion loop." 260237 260238 super printWithClosureAnalysisOn: aStream! ! 260239 260240!ParseNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 260241printWithClosureAnalysisOn: aStream indent: level precedence: p 260242 260243 self printWithClosureAnalysisOn: aStream indent: level! ! 260244 260245!ParseNode methodsFor: 'printing' stamp: 'ms 8/1/2006 16:47'! 260246shortPrintOn: aStream 260247 self printOn: aStream indent: 0! ! 260248 260249 260250!ParseNode methodsFor: 'testing'! 260251assignmentCheck: encoder at: location 260252 "For messageNodes masquerading as variables for the debugger. 260253 For now we let this through - ie we allow stores ev 260254 into args. Should check against numArgs, though." 260255 ^ -1! ! 260256 260257!ParseNode methodsFor: 'testing'! 260258canBeSpecialArgument 260259 "Can I be an argument of (e.g.) ifTrue:?" 260260 260261 ^false! ! 260262 260263!ParseNode methodsFor: 'testing'! 260264canCascade 260265 260266 ^false! ! 260267 260268!ParseNode methodsFor: 'testing'! 260269isArg 260270 260271 ^false! ! 260272 260273!ParseNode methodsFor: 'testing' stamp: 'eem 6/16/2008 09:37'! 260274isAssignmentNode 260275 ^false! ! 260276 260277!ParseNode methodsFor: 'testing' stamp: 'eem 9/25/2008 12:11'! 260278isBlockNode 260279 ^false! ! 260280 260281!ParseNode methodsFor: 'testing'! 260282isComplex 260283 "Used for pretty printing to determine whether to start a new line" 260284 260285 ^false! ! 260286 260287!ParseNode methodsFor: 'testing'! 260288isConstantNumber "Overridden in LiteralNode" 260289 ^false! ! 260290 260291!ParseNode methodsFor: 'testing' stamp: 'md 1/20/2006 16:22'! 260292isDoIt 260293 "polymorphic with RBNodes; called by debugger" 260294 260295 ^ false! ! 260296 260297!ParseNode methodsFor: 'testing' stamp: 'eem 7/18/2008 16:22'! 260298isFutureNode 260299 ^false! ! 260300 260301!ParseNode methodsFor: 'testing' stamp: 'ls 1/29/2004 21:11'! 260302isJust: node 260303 ^false! ! 260304 260305!ParseNode methodsFor: 'testing' stamp: 'di 4/5/2000 11:14'! 260306isLiteral 260307 260308 ^ false! ! 260309 260310!ParseNode methodsFor: 'testing' stamp: 'md 7/27/2006 19:14'! 260311isMessage 260312 ^false! ! 260313 260314!ParseNode methodsFor: 'testing'! 260315isMessage: selSymbol receiver: rcvrPred arguments: argsPred 260316 "See comment in MessageNode." 260317 260318 ^false! ! 260319 260320!ParseNode methodsFor: 'testing' stamp: 'John M McIntosh 3/2/2009 19:58'! 260321isMessageNode 260322 ^false! ! 260323 260324!ParseNode methodsFor: 'testing'! 260325isReturnSelf 260326 260327 ^false! ! 260328 260329!ParseNode methodsFor: 'testing'! 260330isReturningIf 260331 260332 ^false! ! 260333 260334!ParseNode methodsFor: 'testing' stamp: 'tk 8/2/1999 18:39'! 260335isSelfPseudoVariable 260336 "Overridden in VariableNode." 260337 ^false! ! 260338 260339!ParseNode methodsFor: 'testing'! 260340isSpecialConstant 260341 ^ false! ! 260342 260343!ParseNode methodsFor: 'testing' stamp: 'di 10/12/1999 15:28'! 260344isTemp 260345 ^ false! ! 260346 260347!ParseNode methodsFor: 'testing'! 260348isUndefTemp 260349 ^ false! ! 260350 260351!ParseNode methodsFor: 'testing'! 260352isUnusedTemp 260353 ^ false! ! 260354 260355!ParseNode methodsFor: 'testing' stamp: 'ar 11/19/2002 14:58'! 260356isVariableNode 260357 ^false! ! 260358 260359!ParseNode methodsFor: 'testing'! 260360isVariableReference 260361 260362 ^false! ! 260363 260364!ParseNode methodsFor: 'testing'! 260365nowHasDef "Ignored in all but VariableNode"! ! 260366 260367!ParseNode methodsFor: 'testing'! 260368nowHasRef "Ignored in all but VariableNode"! ! 260369 260370!ParseNode methodsFor: 'testing'! 260371toDoIncrement: ignored 260372 "Only meant for Messages or Assignments - else return nil" 260373 ^ nil! ! 260374 260375 260376!ParseNode methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:36'! 260377accept: aVisitor 260378 ^self subclassResponsibility! ! 260379 260380!ParseNode methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:44'! 260381nodesDo: aBlock 260382 self accept: (ParseNodeEnumerator ofBlock: aBlock)! ! 260383 260384 260385!ParseNode methodsFor: 'private' stamp: 'ls 1/29/2004 21:17'! 260386ifNilReceiver 260387 "assuming this object is the receiver of an ifNil:, what object is being asked about?" 260388 ^self! ! 260389 260390!ParseNode methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 10:14'! 260391nextWordFrom: aStream setCharacter: aBlock 260392 | outStream char | 260393 outStream := (String new: 16) writeStream. 260394 [(aStream peekFor: Character space) 260395 or: [aStream peekFor: Character tab]] whileTrue. 260396 [aStream atEnd 260397 or: 260398 [char := aStream next. 260399 char = Character cr or: [char = Character space]]] 260400 whileFalse: [outStream nextPut: char]. 260401 aBlock value: char. 260402 ^ outStream contents! ! 260403 260404!ParseNode methodsFor: 'private' stamp: 'eem 5/14/2008 17:29'! 260405notYetImplemented 260406 self flag: 'remove eventually'. 260407 self error: 'Not yet implemented (', thisContext sender printString, ')'! ! 260408 260409!ParseNode methodsFor: 'private' stamp: 'PeterHugossonMiller 9/2/2009 16:11'! 260410printSingleComment: aString on: aStream indent: indent 260411 "Print the comment string, assuming it has been indented indent tabs. 260412 Break the string at word breaks, given the widths in the default 260413 font, at 450 points." 260414 260415 | readStream word position lineBreak font wordWidth tabWidth spaceWidth lastChar | 260416 readStream := aString readStream. 260417 font := TextStyle default defaultFont. 260418 tabWidth := TextConstants at: #DefaultTab. 260419 spaceWidth := font widthOf: Character space. 260420 position := indent * tabWidth. 260421 lineBreak := 450. 260422 [readStream atEnd] 260423 whileFalse: 260424 [word := self nextWordFrom: readStream setCharacter: [:lc | lastChar := lc]. 260425 wordWidth := word inject: 0 into: [:width :char | width + (font widthOf: char)]. 260426 position := position + wordWidth. 260427 position > lineBreak 260428 ifTrue: 260429 [aStream skip: -1; crtab: indent. 260430 position := indent * tabWidth + wordWidth + spaceWidth. 260431 lastChar = Character cr 260432 ifTrue: [[readStream peekFor: Character tab] whileTrue]. 260433 word isEmpty ifFalse: [aStream nextPutAll: word; space]] 260434 ifFalse: 260435 [aStream nextPutAll: word. 260436 readStream atEnd 260437 ifFalse: 260438 [position := position + spaceWidth. 260439 aStream space]. 260440 lastChar = Character cr 260441 ifTrue: 260442 [aStream skip: -1; crtab: indent. 260443 position := indent * tabWidth. 260444 [readStream peekFor: Character tab] whileTrue]]]! ! 260445 260446 260447!ParseNode methodsFor: 'tiles' stamp: 'RAA 8/24/1999 13:06'! 260448currentValueIn: aContext 260449 260450 ^nil! ! 260451 260452"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 260453 260454ParseNode class 260455 instanceVariableNames: ''! 260456 260457!ParseNode class methodsFor: 'accessing' stamp: 'ajh 8/12/2002 11:10'! 260458blockReturnCode 260459 260460 ^ EndRemote! ! 260461 260462!ParseNode class methodsFor: 'accessing' stamp: 'ajh 8/6/2002 12:04'! 260463popCode 260464 260465 ^ Pop! ! 260466 260467!ParseNode class methodsFor: 'accessing' stamp: 'eem 5/21/2008 13:18'! 260468pushNilCode 260469 260470 ^LdNil! ! 260471 260472!ParseNode class methodsFor: 'accessing' stamp: 'eem 8/4/2009 12:34'! 260473tempSortBlock 260474 "Answer a block that can sort a set of temporaries into a stable 260475 order so that different compilations produce the same results." 260476 ^[:t1 :t2| | be1 be2 bs1 bs2 | 260477 t1 index < t2 index "simple sort by index." 260478 or: [t1 index = t2 index "complex tie break" 260479 and: [t1 isRemote ~= t2 isRemote 260480 ifTrue: [t2 isRemote] "put direct temps before indirect temps" 260481 ifFalse: 260482 [((be1 := t1 definingScope blockExtent) isNil 260483 or: [(be2 := t2 definingScope blockExtent) isNil]) 260484 ifTrue: [t1 name < t2 name] "only have the name left to go on" 260485 ifFalse: "put temps from outer scopes before those from inner scopes" 260486 [(bs1 := be1 first) < (bs2 := be2 first) 260487 or: [bs1 = bs2 and: [t1 name < t2 name]]]]]]] "only have the name left to go on"! ! 260488 260489 260490!ParseNode class methodsFor: 'class initialization'! 260491initialize 260492 "ParseNode initialize. VariableNode initialize" 260493 LdInstType := 1. 260494 LdTempType := 2. 260495 LdLitType := 3. 260496 LdLitIndType := 4. 260497 SendType := 5. 260498 CodeBases := #(0 16 32 64 208 ). 260499 CodeLimits := #(16 16 32 32 16 ). 260500 LdSelf := 112. 260501 LdTrue := 113. 260502 LdFalse := 114. 260503 LdNil := 115. 260504 LdMinus1 := 116. 260505 LoadLong := 128. 260506 Store := 129. 260507 StorePop := 130. 260508 ShortStoP := 96. 260509 SendLong := 131. 260510 DblExtDoAll := 132. 260511 SendLong2 := 134. 260512 LdSuper := 133. 260513 Pop := 135. 260514 Dup := 136. 260515 LdThisContext := 137. 260516 EndMethod := 124. 260517 EndRemote := 125. 260518 Jmp := 144. 260519 Bfp := 152. 260520 JmpLimit := 8. 260521 JmpLong := 164. "code for jmp 0" 260522 BtpLong := 168. 260523 SendPlus := 176. 260524 Send := 208. 260525 SendLimit := 16! ! 260526ParseNodeVisitor subclass: #ParseNodeEnumerator 260527 instanceVariableNames: 'theBlock' 260528 classVariableNames: '' 260529 poolDictionaries: '' 260530 category: 'Compiler-Support'! 260531!ParseNodeEnumerator commentStamp: '<historical>' prior: 0! 260532self superclass selectors do: 260533 [:s| 260534 self compile: (String streamContents: 260535 [:str| | arg | 260536 arg := 'a', (s allButFirst: 5) allButLast. 260537 str nextPutAll: s, ' ', arg; crtab; 260538 nextPutAll: 'theBlock value: '; nextPutAll: arg; nextPut: $.; crtab; 260539 nextPutAll: '^super '; nextPutAll: s, ' ', arg])]! 260540 260541 260542!ParseNodeEnumerator methodsFor: 'initialize-release' stamp: 'eem 7/20/2009 19:44'! 260543ofBlock: aBlock 260544 theBlock := aBlock! ! 260545 260546 260547!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260548visitAssignmentNode: anAssignmentNode 260549 theBlock value: anAssignmentNode. 260550 ^super visitAssignmentNode: anAssignmentNode! ! 260551 260552!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260553visitBlockNode: aBlockNode 260554 theBlock value: aBlockNode. 260555 ^super visitBlockNode: aBlockNode! ! 260556 260557!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260558visitBraceNode: aBraceNode 260559 theBlock value: aBraceNode. 260560 ^super visitBraceNode: aBraceNode! ! 260561 260562!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260563visitCascadeNode: aCascadeNode 260564 theBlock value: aCascadeNode. 260565 ^super visitCascadeNode: aCascadeNode! ! 260566 260567!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260568visitCommentNode: aCommentNode 260569 theBlock value: aCommentNode. 260570 ^super visitCommentNode: aCommentNode! ! 260571 260572!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260573visitFieldNode: aFieldNode 260574 theBlock value: aFieldNode. 260575 ^super visitFieldNode: aFieldNode! ! 260576 260577!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260578visitFutureNode: aFutureNode 260579 theBlock value: aFutureNode. 260580 ^super visitFutureNode: aFutureNode! ! 260581 260582!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260583visitInstanceVariableNode: anInstanceVariableNode 260584 theBlock value: anInstanceVariableNode. 260585 ^super visitInstanceVariableNode: anInstanceVariableNode! ! 260586 260587!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260588visitLiteralNode: aLiteralNode 260589 theBlock value: aLiteralNode. 260590 ^super visitLiteralNode: aLiteralNode! ! 260591 260592!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260593visitLiteralVariableNode: aLiteralVariableNode 260594 theBlock value: aLiteralVariableNode. 260595 ^super visitLiteralVariableNode: aLiteralVariableNode! ! 260596 260597!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260598visitMessageNode: aMessageNode 260599 theBlock value: aMessageNode. 260600 ^super visitMessageNode: aMessageNode! ! 260601 260602!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260603visitMessageNodeInCascade: aMessageNodeInCascade 260604 theBlock value: aMessageNodeInCascade. 260605 ^super visitMessageNodeInCascade: aMessageNodeInCascade! ! 260606 260607!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260608visitMethodNode: aMethodNode 260609 theBlock value: aMethodNode. 260610 ^super visitMethodNode: aMethodNode! ! 260611 260612!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260613visitNewArrayNode: aNewArrayNode 260614 theBlock value: aNewArrayNode. 260615 ^super visitNewArrayNode: aNewArrayNode! ! 260616 260617!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260618visitRemoteTempVectorNode: aRemoteTempVectorNode 260619 theBlock value: aRemoteTempVectorNode. 260620 ^super visitRemoteTempVectorNode: aRemoteTempVectorNode! ! 260621 260622!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260623visitReturnNode: aReturnNode 260624 theBlock value: aReturnNode. 260625 ^super visitReturnNode: aReturnNode! ! 260626 260627!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260628visitSelectorNode: aSelectorNode 260629 theBlock value: aSelectorNode. 260630 ^super visitSelectorNode: aSelectorNode! ! 260631 260632!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260633visitTempVariableNode: aTempVariableNode 260634 theBlock value: aTempVariableNode. 260635 ^super visitTempVariableNode: aTempVariableNode! ! 260636 260637!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:41'! 260638visitVariableNode: aVariableNode 260639 theBlock value: aVariableNode. 260640 ^super visitVariableNode: aVariableNode! ! 260641 260642"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 260643 260644ParseNodeEnumerator class 260645 instanceVariableNames: ''! 260646 260647!ParseNodeEnumerator class methodsFor: 'instance creation' stamp: 'eem 7/20/2009 19:45'! 260648ofBlock: aBlock 260649 ^self new ofBlock: aBlock! ! 260650Object subclass: #ParseNodeVisitor 260651 instanceVariableNames: '' 260652 classVariableNames: '' 260653 poolDictionaries: '' 260654 category: 'Compiler-Support'! 260655!ParseNodeVisitor commentStamp: '<historical>' prior: 0! 260656I am an abstract superclass for ParseNode visitors that functions as a null visitor. Here's the code that defines my interface: 260657 260658(SystemNavigation default allImplementorsOf: #accept: localTo: ParseNode) do: 260659 [:methodReference| 260660 methodReference compiledMethod messages do: 260661 [:sel| 260662 ((sel beginsWith: 'visit') 260663 and: [sel numArgs = 1]) ifTrue: 260664 [ParseNodeVisitor 260665 compile: (String streamContents: 260666 [:str| 260667 str nextPutAll: sel; 260668 space; 260669 nextPut: $a. 260670 methodReference classSymbol first isVowel ifTrue: 260671 [str nextPut: $n]. 260672 str nextPutAll: methodReference classSymbol]) 260673 classified: 'visiting']]]! 260674]style[(245 14 245 11 89 11 32)i,cblack;,i,cblack;,i,cblack;,i! 260675 260676 260677!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:10'! 260678visitAssignmentNode: anAssignmentNode 260679 "N.B. since assigment happens after the value is evaluated the value is visited first." 260680 anAssignmentNode value accept: self. 260681 anAssignmentNode variable accept: self! ! 260682 260683!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:13'! 260684visitBlockNode: aBlockNode 260685 aBlockNode statements do: 260686 [:statement| statement accept: self]! ! 260687 260688!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:14'! 260689visitBraceNode: aBraceNode 260690 aBraceNode elements do: 260691 [:element| element accept: self]! ! 260692 260693!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 16:13'! 260694visitCascadeNode: aCascadeNode 260695 aCascadeNode receiver accept: self. 260696 aCascadeNode messages do: 260697 [:message| self visitMessageNodeInCascade: message]! ! 260698 260699!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! 260700visitCommentNode: aCommentNode! ! 260701 260702!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! 260703visitFieldNode: aFieldNode! ! 260704 260705!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 2/9/2009 10:04'! 260706visitFutureNode: aFutureNode 260707 aFutureNode receiver accept: self. 260708 (aFutureNode originalSelector isKindOf: SelectorNode) ifTrue: 260709 [aFutureNode originalSelector accept: self]! ! 260710 260711!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! 260712visitInstanceVariableNode: anInstanceVariableNode! ! 260713 260714!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! 260715visitLiteralNode: aLiteralNode! ! 260716 260717!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! 260718visitLiteralVariableNode: aLiteralVariableNode! ! 260719 260720!ParseNodeVisitor methodsFor: 'visiting' stamp: 'marcus.denker 6/11/2009 12:31'! 260721visitMessageNode: aMessageNode 260722 aMessageNode receiver accept: self. 260723 "receiver notNil ifTrue: ''receiver is nil for cascades'' 260724 [receiver accept: self]." 260725 aMessageNode selector accept: self. 260726 aMessageNode argumentsInEvaluationOrder do: 260727 [:argument| argument accept: self]! ! 260728 260729!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 2/9/2009 10:04'! 260730visitMessageNodeInCascade: aMessageNode 260731 "receiver is nil for cascades" 260732 aMessageNode selector accept: self. 260733 aMessageNode argumentsInEvaluationOrder do: 260734 [:argument| argument accept: self]! ! 260735 260736!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:53'! 260737visitMethodNode: aMethodNode 260738 aMethodNode block accept: self! ! 260739 260740!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! 260741visitNewArrayNode: aNewArrayNode! ! 260742 260743!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! 260744visitRemoteTempVectorNode: aRemoteTempVectorNode! ! 260745 260746!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:53'! 260747visitReturnNode: aReturnNode 260748 aReturnNode expr accept: self! ! 260749 260750!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! 260751visitSelectorNode: aSelectorNode! ! 260752 260753!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! 260754visitTempVariableNode: aTempVariableNode! ! 260755 260756!ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:32'! 260757visitVariableNode: aVariableNode! ! 260758Object subclass: #ParseStack 260759 instanceVariableNames: 'position length' 260760 classVariableNames: '' 260761 poolDictionaries: '' 260762 category: 'Compiler-Support'! 260763!ParseStack commentStamp: '<historical>' prior: 0! 260764I keep track of the current and high position of the stack that will be needed by code being compiled.! 260765 260766 260767!ParseStack methodsFor: 'accessing'! 260768pop: n 260769 260770 (position := position - n) < 0 260771 ifTrue: [self error: 'Parse stack underflow']! ! 260772 260773!ParseStack methodsFor: 'accessing' stamp: 'eem 9/12/2008 10:31'! 260774position: n 260775 (position := n) > length 260776 ifTrue: [length := position]! ! 260777 260778!ParseStack methodsFor: 'accessing'! 260779push: n 260780 260781 (position := position + n) > length 260782 ifTrue: [length := position]! ! 260783 260784!ParseStack methodsFor: 'accessing'! 260785size 260786 260787 ^length! ! 260788 260789 260790!ParseStack methodsFor: 'initialization'! 260791init 260792 260793 length := position := 0! ! 260794 260795 260796!ParseStack methodsFor: 'printing'! 260797printOn: aStream 260798 260799 super printOn: aStream. 260800 aStream nextPutAll: ' at '; print: position; nextPutAll: ' of '; print: length! ! 260801 260802 260803!ParseStack methodsFor: 'results'! 260804position 260805 260806 ^position! ! 260807Scanner subclass: #Parser 260808 instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category' 260809 classVariableNames: 'Warns' 260810 poolDictionaries: '' 260811 category: 'Compiler-Kernel'! 260812!Parser commentStamp: '<historical>' prior: 0! 260813I parse Smalltalk syntax and create a MethodNode that is the root of the parse tree. I look one token ahead.! 260814 260815 260816!Parser methodsFor: 'error correction' stamp: 'cwp 10/15/2007 23:00'! 260817canDeclareClassVariable 260818 ^encoder classEncoding ~~ UndefinedObject! ! 260819 260820!Parser methodsFor: 'error correction' stamp: 'cwp 10/17/2007 23:39/eem 9/5/2009 11:10 - => :='! 260821correctSelector: proposedKeyword wordIntervals: spots exprInterval: expInt ifAbort: abortAction 260822 "Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts." 260823 260824 | correctSelector userSelection | 260825 "If we can't ask the user, assume that the keyword will be defined later" 260826 self interactive ifFalse: [^proposedKeyword asSymbol]. 260827 260828 userSelection := requestor selectionInterval. 260829 requestor selectFrom: spots first first to: spots last last. 260830 requestor select. 260831 260832 correctSelector := UnknownSelector name: proposedKeyword. 260833 correctSelector ifNil: [^abortAction value]. 260834 260835 requestor deselect. 260836 requestor selectInvisiblyFrom: userSelection first to: userSelection last. 260837 260838 self substituteSelector: correctSelector keywords wordIntervals: spots. 260839 ^(proposedKeyword last ~~ $: 260840 and: [correctSelector last == $:]) 260841 ifTrue: [abortAction value] 260842 ifFalse: [correctSelector]! ! 260843 260844!Parser methodsFor: 'error correction' stamp: 'eem 9/5/2009 11:53'! 260845correctVariable: proposedVariable interval: spot 260846 "Correct the proposedVariable to a known variable, or declare it as a new 260847 variable if such action is requested. We support declaring lowercase 260848 variables as temps or inst-vars, and uppercase variables as Globals or 260849 ClassVars, depending on whether the context is nil (class=UndefinedObject). 260850 Spot is the interval within the test stream of the variable. 260851 rr 3/4/2004 10:26 : adds the option to define a new class. " 260852 260853 "Check if this is an i-var, that has been corrected already (ugly)" 260854 260855 "Display the pop-up menu" 260856 260857 | tempIvar binding userSelection action | 260858 (encoder classEncoding instVarNames includes: proposedVariable) ifTrue: 260859 [^InstanceVariableNode new 260860 name: proposedVariable 260861 index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)]. 260862 260863 "If we can't ask the user for correction, make it undeclared" 260864 self interactive ifFalse: [^encoder undeclared: proposedVariable]. 260865 260866 "First check to see if the requestor knows anything about the variable" 260867 tempIvar := proposedVariable first isLowercase. 260868 (tempIvar and: [(binding := requestor bindingOf: proposedVariable) notNil]) 260869 ifTrue: [^encoder global: binding name: proposedVariable]. 260870 userSelection := requestor selectionInterval. 260871 requestor selectFrom: spot first to: spot last. 260872 requestor select. 260873 260874 "Build the menu with alternatives" 260875 action := UndeclaredVariable 260876 signalFor: self 260877 name: proposedVariable 260878 inRange: spot. 260879 action ifNil: [^self fail]. 260880 260881 "Execute the selected action" 260882 requestor deselect. 260883 requestor selectInvisiblyFrom: userSelection first to: userSelection last. 260884 ^action value! ! 260885 260886!Parser methodsFor: 'error correction'! 260887declareClassVar: name 260888 | sym class | 260889 sym := name asSymbol. 260890 class := encoder classEncoding. 260891 class := class theNonMetaClass. "not the metaclass" 260892 class addClassVarName: name. 260893 ^ encoder global: (class classPool associationAt: sym) 260894 name: sym! ! 260895 260896!Parser methodsFor: 'error correction' stamp: 'eem 5/27/2009 09:27'! 260897declareGlobal: name 260898 | sym | 260899 sym := name asSymbol. 260900 ^encoder 260901 global: (encoder environment 260902 at: sym put: nil; 260903 associationAt: sym) 260904 name: sym! ! 260905 260906!Parser methodsFor: 'error correction' stamp: 'eem 8/21/2008 13:56'! 260907declareInstVar: name 260908 "Declare an instance variable. Since the variable will get added after any existing 260909 inst vars its index is the instSize." 260910 encoder classEncoding addInstVarName: name. 260911 ^InstanceVariableNode new name: name index: encoder classEncoding instSize 260912 ! ! 260913 260914!Parser methodsFor: 'error correction' stamp: 'RAA 6/5/2001 11:57'! 260915declareTempAndPaste: name 260916 | insertion delta theTextString characterBeforeMark | 260917 260918 theTextString := requestor text string. 260919 characterBeforeMark := theTextString at: tempsMark-1 ifAbsent: [$ ]. 260920 (theTextString at: tempsMark) = $| ifTrue: [ 260921 "Paste it before the second vertical bar" 260922 insertion := name, ' '. 260923 characterBeforeMark isSeparator ifFalse: [ insertion := ' ', insertion]. 260924 delta := 0. 260925 ] ifFalse: [ 260926 "No bars - insert some with CR, tab" 260927 insertion := '| ' , name , ' |',String cr. 260928 delta := 2. "the bar and CR" 260929 characterBeforeMark = Character tab ifTrue: [ 260930 insertion := insertion , String tab. 260931 delta := delta + 1. "the tab" 260932 ]. 260933 ]. 260934 tempsMark := tempsMark + 260935 (self substituteWord: insertion 260936 wordInterval: (tempsMark to: tempsMark-1) 260937 offset: 0) - delta. 260938 ^ encoder bindAndJuggle: name! ! 260939 260940!Parser methodsFor: 'error correction' stamp: 'DamienCassou 9/29/2009 13:05'! 260941defineClass: className 260942 "prompts the user to define a new class, 260943 asks for it's category, and lets the users edit further 260944 the definition" 260945 | sym cat def d2 | 260946 sym := className asSymbol. 260947 cat := UIManager default request: 'Enter class category : ' initialAnswer: self encoder classEncoding theNonMetaClass category. 260948 cat isEmptyOrNil 260949 ifTrue: [cat := 'Unknown']. 260950 def := 'Object subclass: #' , sym , ' 260951 instanceVariableNames: '''' 260952 classVariableNames: '''' 260953 poolDictionaries: '''' 260954 category: ''' , cat , ''''. 260955 d2 := UIManager default request: 'Edit class definition : ' initialAnswer: def. 260956 d2 260957 ifEmpty: [d2 := def]. 260958 Compiler evaluate: d2. 260959 ^ encoder 260960 global: (Smalltalk associationAt: sym) 260961 name: sym! ! 260962 260963!Parser methodsFor: 'error correction' stamp: 'cwp 10/15/2007 22:58'! 260964possibleVariablesFor: proposedVariable 260965 ^encoder possibleVariablesFor: proposedVariable! ! 260966 260967!Parser methodsFor: 'error correction' stamp: 'cwp 10/17/2007 22:38/eem 9/5/2009 11:10 - => :='! 260968queryUndefined 260969 | varStart varName | 260970 varName := parseNode key. 260971 varStart := self endOfLastToken + requestorOffset - varName size + 1. 260972 requestor selectFrom: varStart to: varStart + varName size - 1; select. 260973 (UndefinedVariable name: varName) ifFalse: [^ self fail]! ! 260974 260975!Parser methodsFor: 'error correction' stamp: 'StephaneDucasse 10/17/2009 11:46'! 260976removeUnusedTemps 260977 "Scan for unused temp names, and prompt the user about the prospect of removing each one found" 260978 260979 | str end start madeChanges | 260980 "I disabled this option. I keep the old code just in case - Hernan Wilkinson" 260981 self warns ifFalse: [ ^ self ]. 260982 260983 madeChanges := false. 260984 str := requestor text asString. 260985 ((tempsMark between: 1 and: str size) 260986 and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. 260987 encoder unusedTempNames do: 260988 [:temp | 260989 (UnusedVariable name: temp) ifTrue: 260990 [(encoder encodeVariable: temp) isUndefTemp 260991 ifTrue: 260992 [end := tempsMark. 260993 ["Beginning at right temp marker..." 260994 start := end - temp size + 1. 260995 end < temp size or: [temp = (str copyFrom: start to: end) 260996 and: [(str at: start-1) isSeparator & (str at: end+1) isSeparator]]] 260997 whileFalse: 260998 ["Search left for the unused temp" 260999 end := requestor nextTokenFrom: end direction: -1]. 261000 end < temp size ifFalse: 261001 [(str at: start-1) = $ ifTrue: [start := start-1]. 261002 requestor correctFrom: start to: end with: ''. 261003 str := str copyReplaceFrom: start to: end with: ''. 261004 madeChanges := true. 261005 tempsMark := tempsMark - (end-start+1)]] 261006 ifFalse: 261007 [self inform: 261008'You''ll first have to remove the\statement where it''s stored into' withCRs]]]. 261009 madeChanges ifTrue: [ReparseAfterSourceEditing signal]! ! 261010 261011!Parser methodsFor: 'error correction'! 261012substituteSelector: selectorParts wordIntervals: spots 261013 "Substitute the correctSelector into the (presuamed interactive) receiver." 261014 | offset | 261015 offset := 0. 261016 selectorParts with: spots do: 261017 [ :word :interval | 261018 offset := self substituteWord: word wordInterval: interval offset: offset ] 261019! ! 261020 261021!Parser methodsFor: 'error correction' stamp: 'eem 9/5/2009 14:41'! 261022substituteVariable: each atInterval: anInterval 261023 self 261024 substituteWord: each 261025 wordInterval: anInterval 261026 offset: 0. 261027 ^encoder encodeVariable: each! ! 261028 261029!Parser methodsFor: 'error correction'! 261030substituteWord: correctWord wordInterval: spot offset: o 261031 "Substitute the correctSelector into the (presuamed interactive) receiver." 261032 261033 requestor correctFrom: (spot first + o) 261034 to: (spot last + o) 261035 with: correctWord. 261036 261037 requestorOffset := requestorOffset + correctWord size - spot size. 261038 ^ o + correctWord size - spot size! ! 261039 261040 261041!Parser methodsFor: 'error handling' stamp: 'eem 5/14/2008 13:34'! 261042addWarning: aString 261043 "ignored by the default compiler."! ! 261044 261045!Parser methodsFor: 'error handling' stamp: 'hmm 7/18/2001 21:45'! 261046expected: aString 261047 "Notify a problem at token 'here'." 261048 261049 tokenType == #doIt ifTrue: [hereMark := hereMark + 1]. 261050 hereType == #doIt ifTrue: [hereMark := hereMark + 1]. 261051 ^ self notify: aString , ' expected' at: hereMark + requestorOffset! ! 261052 261053!Parser methodsFor: 'error handling'! 261054fail 261055 261056 | exitBlock | 261057 encoder == nil 261058 ifFalse: [encoder release. encoder := nil]. "break cycle" 261059 exitBlock := failBlock. 261060 failBlock := nil. 261061 ^exitBlock value! ! 261062 261063!Parser methodsFor: 'error handling' stamp: 'pavel.krivanek 11/21/2008 16:57'! 261064interactive 261065 261066 ^ UIManager default interactiveParserFor: requestor! ! 261067 261068!Parser methodsFor: 'error handling'! 261069notify: aString 261070 "Notify problem at token before 'here'." 261071 261072 ^self notify: aString at: prevMark + requestorOffset! ! 261073 261074!Parser methodsFor: 'error handling' stamp: 'eem 9/25/2008 12:41'! 261075notify: string at: location 261076 requestor isNil 261077 ifTrue: [(encoder == self or: [encoder isNil]) ifTrue: [^ self fail "failure setting up syntax error"]. 261078 SyntaxErrorNotification 261079 inClass: encoder classEncoding 261080 category: category 261081 withCode: 261082 (source contents 261083 copyReplaceFrom: location 261084 to: location - 1 261085 with: string , ' ->') 261086 doitFlag: doitFlag 261087 errorMessage: string 261088 location: location] 261089 ifFalse: [requestor 261090 notify: string , ' ->' 261091 at: location 261092 in: source]. 261093 ^self fail! ! 261094 261095!Parser methodsFor: 'error handling' stamp: 'di 2/9/1999 15:43'! 261096offEnd: aString 261097 "Notify a problem beyond 'here' (in lookAhead token). Don't be offEnded!!" 261098 261099 requestorOffset == nil 261100 ifTrue: [^ self notify: aString at: mark] 261101 ifFalse: [^ self notify: aString at: mark + requestorOffset] 261102! ! 261103 261104 261105!Parser methodsFor: 'expression types'! 261106argumentName 261107 261108 hereType == #word 261109 ifFalse: [^self expected: 'Argument name']. 261110 ^self advance! ! 261111 261112!Parser methodsFor: 'expression types' stamp: 'eem 6/2/2009 10:26'! 261113assignment: varNode 261114 " var ':=' expression => AssignmentNode." 261115 | loc start | 261116 (loc := varNode assignmentCheck: encoder at: prevMark + requestorOffset) >= 0 261117 ifTrue: [^self notify: 'Cannot store into' at: loc]. 261118 start := self startOfNextToken. 261119 self advance. 261120 self expression ifFalse: [^self expected: 'Expression']. 261121 parseNode := AssignmentNode new 261122 variable: varNode 261123 value: parseNode 261124 from: encoder 261125 sourceRange: (start to: self endOfLastToken). 261126 varNode nowHasDef. 261127 ^true! ! 261128 261129!Parser methodsFor: 'expression types' stamp: 'eem 7/20/2009 12:09'! 261130blockExpression 261131 "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." 261132 261133 | blockNode variableNodes temporaryBlockVariables start | 261134 blockNode := BlockNode new. 261135 variableNodes := OrderedCollection new. 261136 start := prevMark + requestorOffset. 261137 "Gather parameters." 261138 [self match: #colon] whileTrue: 261139 [variableNodes addLast: (encoder bindBlockArg: self argumentName within: blockNode)]. 261140 (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: 261141 [^self expected: 'Vertical bar']. 261142 261143 temporaryBlockVariables := self temporaryBlockVariablesFor: blockNode. 261144 self statements: variableNodes innerBlock: true blockNode: blockNode. 261145 blockNode temporaries: temporaryBlockVariables. 261146 261147 (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. 261148 261149 blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. 261150 261151 "The scope of the parameters and temporary block variables is no longer active." 261152 temporaryBlockVariables do: [:variable | variable scope: -1]. 261153 variableNodes do: [:variable | variable scope: -1]! ! 261154 261155!Parser methodsFor: 'expression types' stamp: 'di 3/8/2000 09:36'! 261156braceExpression 261157 " { elements } => BraceNode." 261158 261159 | elements locations loc more | 261160 elements := OrderedCollection new. 261161 locations := OrderedCollection new. 261162 self advance. 261163 more := hereType ~~ #rightBrace. 261164 [more] 261165 whileTrue: 261166 [loc := hereMark + requestorOffset. 261167 self expression 261168 ifTrue: 261169 [elements addLast: parseNode. 261170 locations addLast: loc] 261171 ifFalse: 261172 [^self expected: 'Variable or expression']. 261173 (self match: #period) 261174 ifTrue: [more := hereType ~~ #rightBrace] 261175 ifFalse: [more := false]]. 261176 parseNode := BraceNode new elements: elements sourceLocations: locations. 261177 (self match: #rightBrace) 261178 ifFalse: [^self expected: 'Period or right brace']. 261179 ^true! ! 261180 261181!Parser methodsFor: 'expression types'! 261182cascade 261183 " {; message} => CascadeNode." 261184 261185 | rcvr msgs | 261186 parseNode canCascade 261187 ifFalse: [^self expected: 'Cascading not']. 261188 rcvr := parseNode cascadeReceiver. 261189 msgs := OrderedCollection with: parseNode. 261190 [self match: #semicolon] 261191 whileTrue: 261192 [parseNode := rcvr. 261193 (self messagePart: 3 repeat: false) 261194 ifFalse: [^self expected: 'Cascade']. 261195 parseNode canCascade 261196 ifFalse: [^self expected: '<- No special messages']. 261197 parseNode cascadeReceiver. 261198 msgs addLast: parseNode]. 261199 parseNode := CascadeNode new receiver: rcvr messages: msgs! ! 261200 261201!Parser methodsFor: 'expression types' stamp: 'di 11/19/1999 07:43'! 261202expression 261203 261204 (hereType == #word and: [tokenType == #leftArrow]) 261205 ifTrue: [^ self assignment: self variable]. 261206 hereType == #leftBrace 261207 ifTrue: [self braceExpression] 261208 ifFalse: [self primaryExpression ifFalse: [^ false]]. 261209 (self messagePart: 3 repeat: true) 261210 ifTrue: [hereType == #semicolon ifTrue: [self cascade]]. 261211 ^ true! ! 261212 261213!Parser methodsFor: 'expression types' stamp: 'PeterHugossonMiller 9/3/2009 10:15'! 261214messagePart: level repeat: repeat 261215 261216 | start receiver selector args precedence words keywordStart | 261217 [receiver := parseNode. 261218 (hereType == #keyword and: [level >= 3]) 261219 ifTrue: 261220 [start := self startOfNextToken. 261221 selector := (String new: 32) writeStream. 261222 args := OrderedCollection new. 261223 words := OrderedCollection new. 261224 [hereType == #keyword] 261225 whileTrue: 261226 [keywordStart := self startOfNextToken + requestorOffset. 261227 selector nextPutAll: self advance. 261228 words addLast: (keywordStart to: self endOfLastToken + requestorOffset). 261229 self primaryExpression ifFalse: [^self expected: 'Argument']. 261230 self messagePart: 2 repeat: true. 261231 args addLast: parseNode]. 261232 (Symbol hasInterned: selector contents ifTrue: [ :sym | selector := sym]) 261233 ifFalse: [ selector := self correctSelector: selector contents 261234 wordIntervals: words 261235 exprInterval: (start to: self endOfLastToken) 261236 ifAbort: [ ^ self fail ] ]. 261237 precedence := 3] 261238 ifFalse: [((hereType == #binary or: [hereType == #verticalBar]) 261239 and: [level >= 2]) 261240 ifTrue: 261241 [start := self startOfNextToken. 261242 selector := self advance asOctetString asSymbol. 261243 self primaryExpression ifFalse: [^self expected: 'Argument']. 261244 self messagePart: 1 repeat: true. 261245 args := Array with: parseNode. 261246 precedence := 2] 261247 ifFalse: [hereType == #word 261248 ifTrue: 261249 [start := self startOfNextToken. 261250 selector := self advance. 261251 args := #(). 261252 words := OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). 261253 (Symbol hasInterned: selector ifTrue: [ :sym | selector := sym]) 261254 ifFalse: [ selector := self correctSelector: selector 261255 wordIntervals: words 261256 exprInterval: (start to: self endOfLastToken) 261257 ifAbort: [ ^ self fail ] ]. 261258 precedence := 1] 261259 ifFalse: [^args notNil]]]. 261260 parseNode := MessageNode new 261261 receiver: receiver 261262 selector: selector 261263 arguments: args 261264 precedence: precedence 261265 from: encoder 261266 sourceRange: (start to: self endOfLastToken). 261267 repeat] 261268 whileTrue: []. 261269 ^true! ! 261270 261271!Parser methodsFor: 'expression types' stamp: 'eem 12/1/2008 11:07'! 261272method: doit context: ctxt encoder: encoderToUse 261273 " pattern [ | temporaries ] block => MethodNode." 261274 261275 | sap blk prim temps messageComment methodNode | 261276 properties := AdditionalMethodState new. 261277 encoder := encoderToUse. 261278 sap := self pattern: doit inContext: ctxt. 261279 "sap={selector, arguments, precedence}" 261280 properties selector: (sap at: 1). 261281 encoder selector: (sap at: 1). 261282 (sap at: 2) do: [:argNode | argNode beMethodArg]. 261283 doit ifFalse: [self pragmaSequence]. 261284 temps := self temporaries. 261285 messageComment := currentComment. 261286 currentComment := nil. 261287 doit ifFalse: [self pragmaSequence]. 261288 prim := self pragmaPrimitives. 261289 self statements: #() innerBlock: doit. 261290 blk := parseNode. 261291 doit ifTrue: [blk returnLast] 261292 ifFalse: [blk returnSelfIfNoOther: encoder]. 261293 hereType == #doIt ifFalse: [^self expected: 'Nothing more']. 261294 self interactive ifTrue: [self removeUnusedTemps]. 261295 methodNode := self newMethodNode comment: messageComment. 261296 ^methodNode 261297 selector: (sap at: 1) 261298 arguments: (sap at: 2) 261299 precedence: (sap at: 3) 261300 temporaries: temps 261301 block: blk 261302 encoder: encoder 261303 primitive: prim 261304 properties: properties! ! 261305 261306!Parser methodsFor: 'expression types' stamp: 'eem 5/29/2008 09:36'! 261307newMethodNode 261308 ^self encoder methodNodeClass new! ! 261309 261310!Parser methodsFor: 'expression types' stamp: 'PeterHugossonMiller 9/3/2009 10:15'! 261311pattern: fromDoit inContext: ctxt 261312 " unarySelector | binarySelector arg | keyword arg {keyword arg} => 261313 {selector, arguments, precedence}." 261314 | args selector | 261315 doitFlag := fromDoit. 261316 fromDoit ifTrue: 261317 [^ctxt == nil 261318 ifTrue: [{#DoIt. {}. 1}] 261319 ifFalse: [{#DoItIn:. {encoder encodeVariable: encoder doItInContextName}. 3}]]. 261320 261321 hereType == #word ifTrue: [^ {self advance asSymbol. {}. 1}]. 261322 261323 (hereType == #binary or: [hereType == #verticalBar]) ifTrue: 261324 [selector := self advance asSymbol. 261325 args := Array with: (encoder bindArg: self argumentName). 261326 ^ {selector. args. 2}]. 261327 261328 hereType == #keyword ifTrue: 261329 [selector := (String new: 32) writeStream. 261330 args := OrderedCollection new. 261331 [hereType == #keyword] whileTrue:[ 261332 selector nextPutAll: self advance. 261333 args addLast: (encoder bindArg: self argumentName). 261334 ]. 261335 ^ {selector contents asSymbol. args. 3}]. 261336 hereType == #positionalMessage ifTrue:[ 261337 args := OrderedCollection new. 261338 selector := self advance. 261339 hereType == #rightParenthesis ifTrue:[self advance. ^{(selector,'/0') asSymbol. args. 1}]. 261340 [ 261341 args addLast: (encoder bindArg: self argumentName). 261342 hereType == #rightParenthesis ifTrue:[ 261343 self advance. 261344 selector := (selector,'/', args size printString) asSymbol. 261345 ^{selector. args. 1}]. 261346 here == #, ifFalse:[self expected: 'comma']. 261347 self advance. 261348 ] repeat. 261349 ]. 261350 ^self expected: 'Message pattern'! ! 261351 261352!Parser methodsFor: 'expression types' stamp: 'StephaneDucasse 10/17/2009 11:45'! 261353primaryExpression 261354 hereType == #word 261355 ifTrue: 261356 [parseNode := self variable. 261357 (parseNode isUndefTemp and: [self interactive]) 261358 ifTrue: [ self warns ifTrue: [self queryUndefined]]. 261359 parseNode nowHasRef. 261360 ^ true]. 261361 hereType == #leftBracket 261362 ifTrue: 261363 [self advance. 261364 self blockExpression. 261365 ^true]. 261366 hereType == #leftBrace 261367 ifTrue: 261368 [self braceExpression. 261369 ^true]. 261370 hereType == #leftParenthesis 261371 ifTrue: 261372 [self advance. 261373 self expression ifFalse: [^self expected: 'expression']. 261374 (self match: #rightParenthesis) 261375 ifFalse: [^self expected: 'right parenthesis']. 261376 ^true]. 261377 (hereType == #string or: [hereType == #number or: [hereType == #literal]]) 261378 ifTrue: 261379 [parseNode := encoder encodeLiteral: self advance. 261380 ^true]. 261381 (here == #- and: [tokenType == #number]) 261382 ifTrue: 261383 [self advance. 261384 parseNode := encoder encodeLiteral: self advance negated. 261385 ^true]. 261386 ^false! ! 261387 261388!Parser methodsFor: 'expression types' stamp: 'eem 5/30/2008 11:51'! 261389statements: argNodes innerBlock: inner 261390 261391 ^self statements: argNodes innerBlock: inner blockNode: BlockNode new! ! 261392 261393!Parser methodsFor: 'expression types' stamp: 'eem 8/4/2008 10:56'! 261394statements: argNodes innerBlock: inner blockNode: theBlockNode 261395 261396 | stmts returns start | 261397 "give initial comment to block, since others trail statements" 261398 theBlockNode comment: currentComment. 261399 stmts := OrderedCollection new. 261400 returns := false. 261401 hereType ~~ #rightBracket ifTrue: 261402 [[theBlockNode startOfLastStatement: (start := self startOfNextToken). 261403 (returns := self matchReturn) 261404 ifTrue: 261405 [self expression ifFalse: 261406 [^self expected: 'Expression to return']. 261407 self addComment. 261408 stmts addLast: (parseNode isReturningIf 261409 ifTrue: [parseNode] 261410 ifFalse: [ReturnNode new 261411 expr: parseNode 261412 encoder: encoder 261413 sourceRange: (start to: self endOfLastToken)])] 261414 ifFalse: 261415 [self expression 261416 ifTrue: 261417 [self addComment. 261418 stmts addLast: parseNode] 261419 ifFalse: 261420 [self addComment. 261421 stmts size = 0 ifTrue: 261422 [stmts addLast: 261423 (encoder encodeVariable: 261424 (inner ifTrue: ['nil'] ifFalse: ['self']))]]]. 261425 returns ifTrue: 261426 [self match: #period. 261427 (hereType == #rightBracket or: [hereType == #doIt]) ifFalse: 261428 [^self expected: 'End of block']]. 261429 returns not and: [self match: #period]] whileTrue]. 261430 theBlockNode 261431 arguments: argNodes 261432 statements: stmts 261433 returns: returns 261434 from: encoder. 261435 parseNode := theBlockNode. 261436 ^true! ! 261437 261438!Parser methodsFor: 'expression types' stamp: 'ar 1/4/2002 00:23'! 261439temporaries 261440 " [ '|' (variable)* '|' ]" 261441 | vars theActualText | 261442 (self match: #verticalBar) ifFalse: 261443 ["no temps" 261444 doitFlag ifTrue: [self interactive 261445 ifFalse: [tempsMark := 1] 261446 ifTrue: [tempsMark := requestor selectionInterval first]. 261447 ^ #()]. 261448 tempsMark := (prevEnd ifNil: [0]) + 1. 261449 tempsMark := hereMark "formerly --> prevMark + prevToken". 261450 261451 tempsMark > 0 ifTrue: 261452 [theActualText := source contents. 261453 [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] 261454 whileTrue: [tempsMark := tempsMark + 1]]. 261455 ^ #()]. 261456 vars := OrderedCollection new. 261457 [hereType == #word] 261458 whileTrue: [vars addLast: (encoder bindTemp: self advance)]. 261459 (self match: #verticalBar) ifTrue: 261460 [tempsMark := prevMark. 261461 ^ vars]. 261462 ^ self expected: 'Vertical bar' 261463! ! 261464 261465!Parser methodsFor: 'expression types' stamp: 'eem 5/13/2008 14:32'! 261466temporariesIn: methodSelector 261467 " [ '|' (variable)* '|' ]" 261468 | vars theActualText | 261469 (self match: #verticalBar) ifFalse: 261470 ["no temps" 261471 doitFlag ifTrue: [self interactive 261472 ifFalse: [tempsMark := 1] 261473 ifTrue: [tempsMark := requestor selectionInterval first]. 261474 ^ #()]. 261475 tempsMark := (prevEnd ifNil: [0]) + 1. 261476 tempsMark := hereMark "formerly --> prevMark + prevToken". 261477 261478 tempsMark > 0 ifTrue: 261479 [theActualText := source contents. 261480 [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] 261481 whileTrue: [tempsMark := tempsMark + 1]]. 261482 ^ #()]. 261483 vars := OrderedCollection new. 261484 [hereType == #word] 261485 whileTrue: [vars addLast: (encoder bindTemp: self advance in: methodSelector)]. 261486 (self match: #verticalBar) ifTrue: 261487 [tempsMark := prevMark. 261488 ^ vars]. 261489 ^ self expected: 'Vertical bar'! ! 261490 261491!Parser methodsFor: 'expression types' stamp: 'eem 5/30/2008 14:16'! 261492temporaryBlockVariablesFor: aBlockNode 261493 "Scan and answer temporary block variables." 261494 261495 | variables | 261496 (self match: #verticalBar) ifFalse: 261497 "There are't any temporary variables." 261498 [^#()]. 261499 261500 variables := OrderedCollection new. 261501 [hereType == #word] whileTrue: 261502 [variables addLast: (encoder bindBlockTemp: self advance within: aBlockNode)]. 261503 ^(self match: #verticalBar) 261504 ifTrue: [variables] 261505 ifFalse: [self expected: 'Vertical bar']! ! 261506 261507!Parser methodsFor: 'expression types' stamp: 'di 12/4/1999 21:04'! 261508variable 261509 261510 | varName varStart varEnd | 261511 varStart := self startOfNextToken + requestorOffset. 261512 varName := self advance. 261513 varEnd := self endOfLastToken + requestorOffset. 261514 ^ encoder encodeVariable: varName 261515 sourceRange: (varStart to: varEnd) 261516 ifUnknown: [self correctVariable: varName interval: (varStart to: varEnd)]! ! 261517 261518 261519!Parser methodsFor: 'pragmas' stamp: 'eem 11/29/2008 16:44'! 261520addPragma: aPragma 261521 properties := properties copyWith: aPragma! ! 261522 261523!Parser methodsFor: 'pragmas' stamp: 'lr 10/5/2006 09:47'! 261524pragmaLiteral 261525 "Read a pragma literal." 261526 261527 (hereType == #string or: [ hereType == #literal or: [ hereType == #number ] ]) 261528 ifTrue: [ ^ self advance ]. 261529 (here == $# and: [ tokenType == #word ]) 261530 ifTrue: [ ^ self advance ]. 261531 (here == #- and: [ tokenType == #number ]) 261532 ifTrue: [ ^ (self advance; advance) negated ]. 261533 (here = 'true' or: [ here = 'false' or: [ here = 'nil' ] ]) 261534 ifTrue: [ ^ Compiler evaluate: self advance ]. 261535 ^ self expected: 'Literal constant'! ! 261536 261537!Parser methodsFor: 'pragmas' stamp: 'eem 12/1/2008 11:39'! 261538pragmaLiteral: selectorSoFar 261539 "Read a pragma literal. As a nicety we allow a variable name (rather 261540 than a literal string) as the second argument to primitive:error:" 261541 261542 (hereType == #string or: [ hereType == #literal or: [ hereType == #number ] ]) 261543 ifTrue: [ ^ self advance ]. 261544 (here == $# and: [ tokenType == #word ]) 261545 ifTrue: [ ^ self advance ]. 261546 (here == #- and: [ tokenType == #number ]) 261547 ifTrue: [ ^ (self advance; advance) negated ]. 261548 (here = 'true' or: [ here = 'false' or: [ here = 'nil' ] ]) 261549 ifTrue: [ ^ Compiler evaluate: self advance ]. 261550 "This nicety allows one to supply a primitive error 261551 temp as a variable name, rather than a string." 261552 ((selectorSoFar beginsWith: 'primitive:') 261553 and: [(selectorSoFar endsWith: 'error:') 261554 and: [hereType == #word]]) ifTrue: 261555 [^self advance]. 261556 ^self expected: 'Literal constant'! ! 261557 261558!Parser methodsFor: 'pragmas' stamp: 'eem 12/1/2008 14:33'! 261559pragmaPrimitives 261560 | primitives | 261561 properties isEmpty ifTrue: 261562 [^0]. 261563 primitives := properties pragmas select: 261564 [:pragma| 261565 self class primitivePragmaSelectors includes: pragma keyword]. 261566 primitives isEmpty ifTrue: 261567 [^0]. 261568 primitives size > 1 ifTrue: 261569 [^self notify: 'Ambigous primitives']. 261570 ^self perform: primitives first keyword withArguments: primitives first arguments! ! 261571 261572!Parser methodsFor: 'pragmas' stamp: 'lr 10/5/2006 09:47'! 261573pragmaSequence 261574 "Parse a sequence of method pragmas." 261575 261576 [ true ] whileTrue: [ 261577 (self matchToken: #<) 261578 ifFalse: [ ^ self ]. 261579 self pragmaStatement. 261580 (self matchToken: #>) 261581 ifFalse: [ ^ self expected: '>' ] ]! ! 261582 261583!Parser methodsFor: 'pragmas' stamp: 'lr 8/19/2006 20:39'! 261584pragmaStatement 261585 "Read a single pragma statement. Parse all generic pragmas in the form of: <key1: val1 key2: val2 ...> and remember them, including primitives." 261586 261587 | selector arguments words index keyword | 261588 (hereType = #keyword or: [ hereType = #word or: [ hereType = #binary ] ]) 261589 ifFalse: [ ^ self expected: 'pragma declaration' ]. 261590 261591 " This is a ugly hack into the compiler of the FFI package. FFI should be changed to use propre pragmas that can be parsed with the code here. " 261592 (here = #apicall: or: [ here = #cdecl: ]) 261593 ifTrue: [ ^ self externalFunctionDeclaration ]. 261594 261595 selector := String new. 261596 arguments := OrderedCollection new. 261597 words := OrderedCollection new. 261598 [ hereType = #keyword or: [ (hereType = #word or: [ hereType = #binary ]) and: [ selector isEmpty ] ] ] whileTrue: [ 261599 index := self startOfNextToken + requestorOffset. 261600 selector := selector , self advance. 261601 words add: (index to: self endOfLastToken + requestorOffset). 261602 (selector last = $: or: [ selector first isLetter not ]) 261603 ifTrue: [ arguments add: self pragmaLiteral ] ]. 261604 selector numArgs ~= arguments size 261605 ifTrue: [ ^ self expected: 'pragma argument' ]. 261606 (Symbol hasInterned: selector 261607 ifTrue: [ :value | keyword := value]) 261608 ifFalse: [ 261609 keyword := self 261610 correctSelector: selector wordIntervals: words 261611 exprInterval: (words first first to: words last last) 261612 ifAbort: [ ^ self fail ] ]. 261613 self addPragma: (Pragma keyword: keyword arguments: arguments asArray). 261614 ^ true! ! 261615 261616 261617!Parser methodsFor: 'primitives'! 261618allocateLiteral: lit 261619 encoder litIndex: lit! ! 261620 261621!Parser methodsFor: 'primitives' stamp: 'eem 9/5/2009 14:47'! 261622externalFunctionDeclaration 261623 "Parse the function declaration for a call to an external library." 261624 | descriptorClass callType retType externalName args argType module fn | 261625 descriptorClass := Smalltalk at: #ExternalFunction ifAbsent:[nil]. 261626 descriptorClass == nil ifTrue:[^false]. 261627 callType := descriptorClass callingConventionFor: here. 261628 callType == nil ifTrue:[^false]. 261629 "Parse return type" 261630 self advance. 261631 retType := self externalType: descriptorClass. 261632 retType == nil ifTrue:[^self expected:'return type']. 261633 "Parse function name or index" 261634 externalName := here. 261635 (self match: #string) 261636 ifTrue:[externalName := externalName asSymbol] 261637 ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']]. 261638 (self matchToken: #'(') ifFalse:[^self expected:'argument list']. 261639 args := WriteStream on: Array new. 261640 [here == #')'] whileFalse:[ 261641 argType := self externalType: descriptorClass. 261642 argType == nil ifTrue:[^self expected:'argument']. 261643 argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]. 261644 ]. 261645 (self matchToken:#')') ifFalse:[^self expected:')']. 261646 (self matchToken: 'module:') ifTrue:[ 261647 module := here. 261648 (self match: #string) ifFalse:[^self expected: 'String']. 261649 module := module asSymbol]. 261650 Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn| 261651 fn := xfn name: externalName 261652 module: module 261653 callType: callType 261654 returnType: retType 261655 argumentTypes: args contents. 261656 self allocateLiteral: fn. 261657 ]. 261658 self addPragma: (Pragma keyword: #primitive: arguments: #(120)). 261659 ^true! ! 261660 261661!Parser methodsFor: 'primitives' stamp: 'ar 12/2/1999 16:49'! 261662externalType: descriptorClass 261663 "Parse an return an external type" 261664 | xType | 261665 xType := descriptorClass atomicTypeNamed: here. 261666 xType == nil ifTrue:["Look up from class scope" 261667 Symbol hasInterned: here ifTrue:[:sym| 261668 xType := descriptorClass structTypeNamed: sym]]. 261669 xType == nil ifTrue:[ 261670 "Raise an error if user is there" 261671 self interactive ifTrue:[^nil]. 261672 "otherwise go over it silently" 261673 xType := descriptorClass forceTypeNamed: here]. 261674 self advance. 261675 (self matchToken:#*) 261676 ifTrue:[^xType asPointerType] 261677 ifFalse:[^xType]! ! 261678 261679!Parser methodsFor: 'primitives' stamp: 'eem 12/1/2008 09:17'! 261680primitive: anIntegerOrString 261681 "Create indexed primitive." 261682 261683 ^self primitive: anIntegerOrString error: nil! ! 261684 261685!Parser methodsFor: 'primitives' stamp: 'eem 12/1/2008 09:21'! 261686primitive: anIntegerOrString error: errorCodeVariableOrNil 261687 "Create indexed primitive with optional error code." 261688 261689 ^anIntegerOrString isInteger 261690 ifTrue: 261691 [errorCodeVariableOrNil ifNotNil: 261692 [encoder floatTemp: (encoder bindTemp: errorCodeVariableOrNil) nowHasDef]. 261693 anIntegerOrString] 261694 ifFalse: 261695 [anIntegerOrString isString 261696 ifTrue: [self primitive: anIntegerOrString module: nil error: errorCodeVariableOrNil] 261697 ifFalse: [self expected: 'Indexed primitive']]! ! 261698 261699!Parser methodsFor: 'primitives' stamp: 'eem 12/1/2008 09:20'! 261700primitive: aNameString error: errorCodeVariableOrNil module: aModuleStringOrNil 261701 "Create named primitive with optional error code." 261702 261703 ^self primitive: aNameString module: aModuleStringOrNil error: errorCodeVariableOrNil! ! 261704 261705!Parser methodsFor: 'primitives' stamp: 'eem 12/1/2008 09:21'! 261706primitive: aNameString module: aModuleStringOrNil 261707 "Create named primitive." 261708 261709 ^self primitive: aNameString module: aModuleStringOrNil error: nil! ! 261710 261711!Parser methodsFor: 'primitives' stamp: 'eem 12/1/2008 09:18'! 261712primitive: aNameString module: aModuleStringOrNil error: errorCodeVariableOrNil 261713 "Create named primitive with optional error code." 261714 261715 (aNameString isString and: [ aModuleStringOrNil isNil or: [ aModuleStringOrNil isString ] ]) 261716 ifFalse: [ ^ self expected: 'Named primitive' ]. 261717 self allocateLiteral: (Array 261718 with: (aModuleStringOrNil isNil 261719 ifFalse: [ aModuleStringOrNil asSymbol ]) 261720 with: aNameString asSymbol 261721 with: 0 with: 0). 261722 errorCodeVariableOrNil ifNotNil: 261723 [encoder floatTemp: (encoder bindTemp: errorCodeVariableOrNil) nowHasDef]. 261724 ^117! ! 261725 261726 261727!Parser methodsFor: 'public access' stamp: 'eem 6/19/2008 09:38'! 261728encoder 261729 encoder isNil ifTrue: 261730 [encoder := EncoderForV3PlusClosures new]. 261731 ^encoder! ! 261732 261733!Parser methodsFor: 'public access' stamp: 'eem 5/14/2008 15:24'! 261734encoderClass: anEncoderClass 261735 encoder notNil ifTrue: 261736 [self error: 'encoder already set']. 261737 encoder := anEncoderClass new! ! 261738 261739!Parser methodsFor: 'public access' stamp: 'pavel.krivanek 3/12/2009 09:40'! 261740parse: sourceStreamOrString class: behavior 261741 261742 ^ self parse: sourceStreamOrString readStream class: behavior 261743 noPattern: false context: nil notifying: nil ifFail: [ self fail ]! ! 261744 261745!Parser methodsFor: 'public access' stamp: 'PeterHugossonMiller 9/2/2009 16:11'! 261746parse: sourceStream class: class category: aCategory noPattern: noPattern context: ctxt notifying: req ifFail: aBlock 261747 "Answer a MethodNode for the argument, sourceStream, that is the root of 261748 a parse tree. Parsing is done with respect to the argument, class, to find 261749 instance, class, and pool variables; and with respect to the argument, 261750 ctxt, to find temporary variables. Errors in parsing are reported to the 261751 argument, req, if not nil; otherwise aBlock is evaluated. The argument 261752 noPattern is a Boolean that is true if the the sourceStream does not 261753 contain a method header (i.e., for DoIts)." 261754 261755 | methNode repeatNeeded myStream s p | 261756 category := aCategory. 261757 myStream := sourceStream. 261758 [repeatNeeded := false. 261759 p := myStream position. 261760 s := myStream upToEnd. 261761 myStream position: p. 261762 self init: myStream notifying: req failBlock: [^ aBlock value]. 261763 doitFlag := noPattern. 261764 failBlock:= aBlock. 261765 [methNode := self 261766 method: noPattern 261767 context: ctxt 261768 encoder: (self encoder init: class context: ctxt notifying: self)] 261769 on: ReparseAfterSourceEditing 261770 do: [ :ex | 261771 repeatNeeded := true. 261772 myStream := requestor text string readStream]. 261773 repeatNeeded] whileTrue: 261774 [encoder := self encoder class new]. 261775 methNode sourceText: s. 261776 ^methNode 261777! ! 261778 261779!Parser methodsFor: 'public access' stamp: 'ar 9/27/2005 19:19'! 261780parse: sourceStream class: class noPattern: noPattern context: ctxt notifying: req ifFail: aBlock 261781 ^self parse: sourceStream class: class category: nil noPattern: noPattern context: ctxt notifying: req ifFail: aBlock ! ! 261782 261783!Parser methodsFor: 'public access' stamp: 'eem 5/6/2008 13:42'! 261784parseArgsAndTemps: aString notifying: req 261785 "Parse the argument, aString, notifying req if an error occurs. Otherwise, 261786 answer a two-element Array containing Arrays of strings (the argument 261787 names and temporary variable names)." 261788 261789 aString == nil ifTrue: [^#()]. 261790 doitFlag := false. "Don't really know if a doit or not!!" 261791 ^self initPattern: aString 261792 notifying: req 261793 return: [:pattern | (pattern at: 2) , (self temporariesIn: (pattern at: 1))]! ! 261794 261795!Parser methodsFor: 'public access'! 261796parseMethodComment: aString setPattern: aBlock 261797 "Answer the method comment for the argument, aString. Evaluate aBlock 261798 with the message pattern in the form #(selector, arguments, precedence)." 261799 261800 self 261801 initPattern: aString 261802 notifying: nil 261803 return: aBlock. 261804 currentComment==nil 261805 ifTrue: [^OrderedCollection new] 261806 ifFalse: [^currentComment]! ! 261807 261808!Parser methodsFor: 'public access' stamp: 'eem 8/20/2008 20:55'! 261809parseSelector: aString 261810 "Answer the message selector for the argument, aString, which should 261811 parse successfully up to the temporary declaration or the end of the 261812 method header." 261813 261814 self initScannerForTokenization. 261815 ^self 261816 initPattern: aString 261817 notifying: nil 261818 return: [:pattern | pattern at: 1]! ! 261819 261820!Parser methodsFor: 'public access' stamp: 'md 1/20/2006 16:31'! 261821parse: sourceStream class: class noPattern: noPattern notifying: req ifFail: aBlock 261822 261823 ^ self parse: sourceStream class: class noPattern: noPattern context: nil notifying: req ifFail: aBlock! ! 261824 261825 261826!Parser methodsFor: 'scanning' stamp: 'hmm 7/16/2001 20:12'! 261827advance 261828 | this | 261829 prevMark := hereMark. 261830 prevEnd := hereEnd. 261831 this := here. 261832 here := token. 261833 hereType := tokenType. 261834 hereMark := mark. 261835 hereEnd := source position - (source atEnd ifTrue: [hereChar == 30 asCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]). 261836 self scanToken. 261837 "Transcript show: 'here: ', here printString, ' mark: ', hereMark printString, ' end: ', hereEnd printString; cr." 261838 ^this! ! 261839 261840!Parser methodsFor: 'scanning' stamp: 'hmm 7/16/2001 19:23'! 261841endOfLastToken 261842 261843 ^ prevEnd ifNil: [mark]! ! 261844 261845!Parser methodsFor: 'scanning'! 261846match: type 261847 "Answer with true if next tokens type matches." 261848 261849 hereType == type 261850 ifTrue: 261851 [self advance. 261852 ^true]. 261853 ^false! ! 261854 261855!Parser methodsFor: 'scanning' stamp: 'di 6/7/2000 08:44'! 261856matchReturn 261857 261858 ^ self match: #upArrow! ! 261859 261860!Parser methodsFor: 'scanning'! 261861matchToken: thing 261862 "Matches the token, not its type." 261863 261864 here = thing ifTrue: [self advance. ^true]. 261865 ^false! ! 261866 261867!Parser methodsFor: 'scanning'! 261868startOfNextToken 261869 "Return starting position in source of next token." 261870 261871 hereType == #doIt ifTrue: [^source position + 1]. 261872 ^hereMark! ! 261873 261874 261875!Parser methodsFor: 'temps'! 261876bindArg: name 261877 261878 ^ self bindTemp: name! ! 261879 261880!Parser methodsFor: 'temps'! 261881bindTemp: name 261882 261883 ^name! ! 261884 261885!Parser methodsFor: 'temps' stamp: 'eem 5/13/2008 12:17'! 261886bindTemp: name in: methodSelector 261887 261888 ^name! ! 261889 261890 261891!Parser methodsFor: 'private'! 261892addComment 261893 261894 parseNode ~~ nil 261895 ifTrue: 261896 [parseNode comment: currentComment. 261897 currentComment := nil]! ! 261898 261899!Parser methodsFor: 'private'! 261900init: sourceStream notifying: req failBlock: aBlock 261901 261902 requestor := req. 261903 failBlock := aBlock. 261904 super scan: sourceStream. 261905 prevMark := hereMark := mark. 261906 requestorOffset := 0. 261907 self advance! ! 261908 261909!Parser methodsFor: 'private' stamp: 'PeterHugossonMiller 9/2/2009 16:11'! 261910initPattern: aString notifying: req return: aBlock 261911 261912 | result | 261913 self 261914 init: aString asString readStream 261915 notifying: req 261916 failBlock: [^nil]. 261917 encoder := self. 261918 result := aBlock value: (self pattern: false inContext: nil). 261919 encoder := failBlock := nil. "break cycles" 261920 ^result! ! 261921 261922!Parser methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 11:45'! 261923warns 261924 "self new warns" 261925 "return whether the parser will ask the user for correction" 261926 261927 "Implementation note: this is implemented as a lazy accessor to be robust against 261928 missed class initialization" 261929 261930 Warns ifNil: [Warns := false]. 261931 ^ Warns! ! 261932 261933"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 261934 261935Parser class 261936 instanceVariableNames: ''! 261937 261938 261939!Parser class methodsFor: 'accessing' stamp: 'StephaneDucasse 10/17/2009 11:43'! 261940doNotWarnUser 261941 "Do not ask the user for certain situation such as use of undefined variables" 261942 261943 Warns := false.! ! 261944 261945!Parser class methodsFor: 'accessing' stamp: 'StephaneDucasse 10/17/2009 11:43'! 261946initialize 261947 "self initialize" 261948 261949 self doNotWarnUser. 261950 Preferences 261951 addBooleanPreference: #allowUnderscoreAssignment 261952 category: #compiler 261953 default: false 261954 balloonHelp: 'If enabled, the compiler will accept _ (underscore) for assignment.\This provides backward compatibility with the pre-ANSI compiler.' withCRs. 261955 Preferences 261956 addBooleanPreference: #allowBlockArgumentAssignment 261957 category: #compiler 261958 default: false 261959 balloonHelp: 'If enabled, the compiler will allow assignment into block arguments.\This provides backward compatibility with the pre-closure compiler.' withCRs.! ! 261960 261961!Parser class methodsFor: 'accessing' stamp: 'eem 12/1/2008 14:32'! 261962primitivePragmaSelectors 261963 "Answer the selectors of pragmas that specify VM primitives. 261964 Needed for compile and decomple." 261965 ^#(primitive: 261966 primitive:error: 261967 primitive:error:module: 261968 primitive:module: 261969 primitive:module:error:)! ! 261970 261971!Parser class methodsFor: 'accessing' stamp: 'StephaneDucasse 10/17/2009 11:43'! 261972silent 261973 "Do not ask the user for certain situation such as use of undefined variables" 261974 261975 Warns := false.! ! 261976 261977!Parser class methodsFor: 'accessing' stamp: 'StephaneDucasse 10/17/2009 11:47'! 261978warnUser 261979 "Ask the user for certain situation such as use of undefined variables" 261980 261981 Warns := true. 261982 ! ! 261983Notification subclass: #ParserNotification 261984 instanceVariableNames: 'name' 261985 classVariableNames: '' 261986 poolDictionaries: '' 261987 category: 'Compiler-Exceptions'! 261988 261989!ParserNotification methodsFor: 'as yet unclassified' stamp: 'cwp 8/25/2009 20:04'! 261990defaultAction 261991 261992 self openMenuIn: 261993 [:labels :lines :caption | 261994 UIManager default chooseFrom: labels lines: lines title: caption]! ! 261995 261996!ParserNotification methodsFor: 'as yet unclassified' stamp: 'cwp 10/17/2007 21:36'! 261997openMenuIn: aBlock 261998 self subclassResponsibility! ! 261999 262000!ParserNotification methodsFor: 'as yet unclassified' stamp: 'cwp 10/17/2007 23:29/eem 9/5/2009 11:10 - => :='! 262001setName: aString 262002 name := aString! ! 262003 262004"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 262005 262006ParserNotification class 262007 instanceVariableNames: ''! 262008 262009!ParserNotification class methodsFor: 'as yet unclassified' stamp: 'cwp 10/17/2007 23:31'! 262010name: aString 262011 ^ (self new setName: aString) signal! ! 262012Object subclass: #Password 262013 instanceVariableNames: 'cache sequence' 262014 classVariableNames: '' 262015 poolDictionaries: '' 262016 category: 'Network-Kernel'! 262017!Password commentStamp: '<historical>' prior: 0! 262018"Hold a password. There are three ways to get the password. 262019 262020If there is no password (sequence == nil), ask the user for it. 262021 262022If the use supplied one during this session, return that. It is cleared at shutDown. 262023 262024If sequence is a number, get the server passwords off the disk. File 'sqk.info' must be in the same folder 'Squeak.sources' file. Decode the file. Return the password indexed by sequence."! 262025 262026 262027!Password methodsFor: 'accessing' stamp: 'tk 1/3/98 21:36'! 262028cache: anObject 262029 cache := anObject! ! 262030 262031!Password methodsFor: 'accessing' stamp: 'rbb 3/1/2005 11:06'! 262032passwordFor: serverDir 262033 "Returned the password from one of many sources. OK if send in a nil arg." 262034 262035 | sp msg | 262036 cache ifNotNil: [^ cache]. 262037 sequence ifNotNil: [ 262038 (sp := self serverPasswords) ifNotNil: [ 262039 sequence <= sp size ifTrue: [^ sp at: sequence]]]. 262040 msg := serverDir isRemoteDirectory 262041 ifTrue: [serverDir moniker] 262042 ifFalse: ['this directory']. 262043 (serverDir user = 'anonymous') & (serverDir typeWithDefault == #ftp) ifTrue: [ 262044 ^ cache := UIManager default request: 'Please let this anonymous ftp\server know your email address.\This is the polite thing to do.' withCRs 262045 initialAnswer: 'yourName@company.com']. 262046 262047 ^ cache := UIManager default requestPassword: 'Password for ', serverDir user, ' at ', msg, ':'. 262048 "Diff between empty string and abort?"! ! 262049 262050!Password methodsFor: 'accessing' stamp: 'mir 6/29/2001 01:01'! 262051sequence 262052 ^sequence! ! 262053 262054!Password methodsFor: 'accessing' stamp: 'tk 1/5/98 21:14'! 262055sequence: anNumber 262056 sequence := anNumber! ! 262057 262058 262059!Password methodsFor: 'as yet unclassified' stamp: 'tk 1/5/98 21:08'! 262060decode: string 262061 "Xor with secret number -- just so file won't have raw password in it" 262062 | kk rand | 262063 rand := Random new seed: 234237. 262064 kk := (ByteArray new: string size) collect: [:bb | (rand next * 255) asInteger]. 262065 1 to: kk size do: [:ii | 262066 kk at: ii put: ((kk at: ii) bitXor: (string at: ii) asciiValue)]. 262067 ^ kk asString! ! 262068 262069!Password methodsFor: 'as yet unclassified' stamp: 'tk 10/15/2002 14:39'! 262070serverPasswords 262071 "Get the server passwords off the disk and decode them. The file 'sqk.info' must be in some folder that Squeak thinks is special (vm folder, or default directory). (Note: This code works even if you are running with no system sources file.)" 262072 262073 | sfile | 262074 (sfile := FileDirectory lookInUsualPlaces: 'sqk.info') ifNil: [^ nil]. 262075 "If not there, Caller will ask user for password" 262076 "If you don't have this file, and you really do want to release an update, 262077 contact Ted Kaehler." 262078 ^ (self decode: (sfile contentsOfEntireFile)) findTokens: String cr 262079! ! 262080 262081"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 262082 262083Password class 262084 instanceVariableNames: ''! 262085 262086!Password class methodsFor: 'as yet unclassified' stamp: 'tk 6/24/1999 11:36'! 262087shutDown 262088 "Forget all cached passwords, so they won't stay in the image" 262089 262090 self allSubInstancesDo: [:each | each cache: nil].! ! 262091TextEntryDialogWindow subclass: #PasswordDialogWindow 262092 instanceVariableNames: '' 262093 classVariableNames: '' 262094 poolDictionaries: '' 262095 category: 'Polymorph-Widgets-Windows'! 262096 262097!PasswordDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 12/3/2008 14:36'! 262098newTextEditorMorph 262099 "Answer a new morph for the text entry using a password font." 262100 262101 |textEditor| 262102 textEditor := super newTextEditorMorph. 262103 textEditor font: (StrikeFont passwordFontSize: self theme textFont pointSize). 262104 ^textEditor! ! 262105BorderedMorph subclass: #PasteUpMorph 262106 instanceVariableNames: 'presenter model cursor padding backgroundMorph isPartsBin autoLineLayout indicateCursor resizeToFit wantsMouseOverHalos worldState griddingOn' 262107 classVariableNames: 'DisableDeferredUpdates MinCycleLapse' 262108 poolDictionaries: '' 262109 category: 'Morphic-Worlds'! 262110!PasteUpMorph commentStamp: 'alain.plantec 6/8/2009 23:45' prior: 0! 262111A morph whose submorphs comprise a paste-up of rectangular subparts which "show through". Anything called a 'Playfield' is a PasteUpMorph. 262112 262113Facilities commonly needed on pages of graphical presentations and on simulation playfields, such as the painting of new objects, turtle trails, gradient fills, background paintings, parts-bin behavior, collision-detection, etc., are (or will be) provided. 262114 262115A World, the entire Smalltalk screen, is a PasteUpMorph. A World responds true to isWorld. 262116 262117presenter A Presenter in charge of stopButton stepButton and goButton, 262118 mouseOverHalosEnabled soundsEnabled fenceEnabled coloredTilesEnabled. 262119model <not used> 262120cursor ?? 262121padding ?? 262122backgroundMorph A Form that covers the background. 262123turtleTrailsForm Moving submorphs may leave trails on this form. 262124turtlePen Draws the trails. 262125lastTurtlePositions A Dictionary of (aPlayer -> aPoint) so turtle trails can be drawn 262126 only once each step cycle. The point is the start of the current stroke. 262127isPartsBin If true, every object dragged out is copied. 262128autoLineLayout ?? 262129indicateCursor ?? 262130resizeToFit ?? 262131wantsMouseOverHalos If true, simply moving the cursor over a submorph brings up its halo. 262132worldState If I am also a World, keeps the hands, damageRecorder, stepList etc. 262133griddingOn If true, submorphs are on a grid 262134 262135! 262136 262137 262138!PasteUpMorph methodsFor: '*Morphic-Basic' stamp: 'adrian_lienhard 7/19/2009 20:50'! 262139morphToDropFrom: aMorph 262140 "Given a morph being carried by the hand, which the hand is about to drop, answer the actual morph to be deposited. Normally this would be just the morph itself, but several unusual cases arise, which this method is designed to service." 262141 262142 ^aMorph ! ! 262143 262144 262145!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 16:14'! 262146currentWindow 262147 "Answer the top window." 262148 262149 ^SystemWindow topWindow! ! 262150 262151!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/12/2007 17:06'! 262152handlerForMouseDown: anEvent 262153 "If we have a modal dialog then answer nil otherwise as usual.." 262154 262155 ^(self hasProperty: #submorphLockStates) 262156 ifFalse: [super handlerForMouseDown: anEvent]! ! 262157 262158!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 14:10'! 262159modalLockTo: aSystemWindow 262160 "Don't lock the world!! Lock the submorphs. 262161 The modal window gets opened afterwards so is OK." 262162 262163 |lockStates| 262164 lockStates := IdentityDictionary new. 262165 self submorphsDo: [:m | 262166 lockStates at: m put: m isLocked. 262167 m lock]. 262168 self 262169 setProperty: #submorphLockStates 262170 toValue: lockStates! ! 262171 262172!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/12/2007 17:01'! 262173modalUnlockFrom: aSystemWindow 262174 "Don't unlock the world!! Unlock the submorphs 262175 that were not originally locked." 262176 262177 |lockStates| 262178 lockStates := self 262179 valueOfProperty: #submorphLockStates 262180 ifAbsent: [^self]. 262181 self removeProperty: #submorphLockStates. 262182 lockStates keysAndValuesDo: [:m :locked | 262183 locked ifFalse: [m unlock]]! ! 262184 262185!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/29/2008 10:54'! 262186navigateVisibleWindowForward 262187 "Change the active window to the next visible and 262188 not collapsed window." 262189 262190 self nextVisibleWindow ifNotNilDo: [:m | m activate]! ! 262191 262192!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/20/2007 14:46'! 262193navigateWindowBackward 262194 "Change the active window to the previous window." 262195 262196 self previousWindow ifNotNilDo: [:m | 262197 m isCollapsed ifTrue: [m collapseOrExpand]. 262198 m activate]! ! 262199 262200!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/4/2007 12:59'! 262201navigateWindowForward 262202 "Change the active window to the next window." 262203 262204 self nextWindow ifNotNilDo: [:m | 262205 self currentWindow ifNotNilDo: [:w | w sendToBack]. 262206 m isCollapsed ifTrue: [m collapseOrExpand]. 262207 m activate]! ! 262208 262209!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:53'! 262210navigationKey: event 262211 "Check for active window navigation." 262212 262213 (event commandKeyPressed and: [event shiftPressed not]) ifTrue: [ 262214 (UITheme current openTasklist: event) ifTrue: [^true]. 262215 event keyCharacter = Character arrowLeft 262216 ifTrue: [self navigateWindowBackward. 262217 ^true]. 262218 event keyCharacter = Character arrowRight 262219 ifTrue: [self navigateWindowForward. 262220 ^true]]. 262221 ^false! ! 262222 262223!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/29/2008 10:59'! 262224nextVisibleWindow 262225 "Answer the next (visible) window to navigate to." 262226 262227 |sys| 262228 sys := self visibleSystemWindows. 262229 sys ifEmpty: [^nil]. 262230 ^sys after: self currentWindow ifAbsent: [sys first]! ! 262231 262232!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 16:18'! 262233nextWindow 262234 "Answer the next window to navigate to." 262235 262236 |sys| 262237 sys := self systemWindows. 262238 sys ifEmpty: [^nil]. 262239 ^sys after: self currentWindow ifAbsent: [sys first]! ! 262240 262241!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 12/11/2007 16:53'! 262242openModal: aSystemWindow 262243 "Open the given window locking the receiver until it is dismissed. 262244 Set the pane color to match the current theme. 262245 Answer the system window." 262246 262247 aSystemWindow 262248 setWindowColor: self theme windowColor. 262249 ^super openModal: aSystemWindow! ! 262250 262251!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 16:18'! 262252previousWindow 262253 "Answer the previous window to navigate to." 262254 262255 |sys| 262256 sys := self systemWindows. 262257 sys ifEmpty: [^nil]. 262258 ^sys before: self currentWindow ifAbsent: [sys last]! ! 262259 262260!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 14:36'! 262261systemWindows 262262 "Answer the system windows in the world." 262263 262264 ^self submorphsSatisfying: [:m | m isSystemWindow]! ! 262265 262266!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 11/13/2007 12:38'! 262267themeChanged 262268 "The theme has changed. 262269 Update the desktop wallpaper if appropriate." 262270 262271 (self theme desktopFillStyleFor: self) ifNotNilDo: [:fs | 262272 self fillStyle: fs]. 262273 super themeChanged! ! 262274 262275!PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/29/2008 11:00'! 262276visibleSystemWindows 262277 "Answer the visible system windows in the world." 262278 262279 ^self submorphsSatisfying: [:m | m isSystemWindow and: [m visible]]! ! 262280 262281 262282!PasteUpMorph methodsFor: '*Tools' stamp: 'adrian_lienhard 7/19/2009 19:55'! 262283defaultDesktopCommandKeyTriplets 262284 "Answer a list of triplets of the form 262285 <key> <receiver> <selector> [+ optional fourth element, a <description> for use in desktop-command-key-help] 262286that will provide the default desktop command key handlers. If the selector takes an argument, that argument will be the command-key event" 262287 262288 ^ { 262289 { $r. ActiveWorld. #restoreMorphicDisplay. 'Redraw the screen'}. 262290 { $z. self. #undoOrRedoCommand. 'Undo or redo the last undoable command'}. 262291 { $b. SystemBrowser. #defaultOpenBrowser. 'Open a new System Browser'}. 262292 { $k. StringHolder. #open. 'Open a new, blank Workspace'}. 262293 { $t. self. #findATranscript:. 'Make a System Transcript visible'}. 262294 { $C. self. #findAChangeSorter:. 'Make a Change Sorter visible'}. 262295 { $R. self. #openRecentSubmissionsBrowser:. 'Make a Recent Submissions browser visible'}. 262296 { $W. self. #findAMessageNamesWindow:. 'Make a MessageNames tool visible'}. 262297 { $Z. ChangeList. #browseRecentLog. 'Browse recently-logged changes'}. 262298 { $\. SystemWindow. #sendTopWindowToBack. 'Send the top window to the back'}. 262299 }. 262300! ! 262301 262302 262303!PasteUpMorph methodsFor: '*etoys-e-toy support' stamp: 'nk 10/13/2004 11:26'! 262304lastKeystroke 262305 "Answer the last keystroke fielded by the receiver" 262306 262307 ^ self valueOfProperty: #lastKeystroke ifAbsent: ['']! ! 262308 262309!PasteUpMorph methodsFor: '*etoys-e-toy support' stamp: 'nk 10/13/2004 11:27'! 262310lastKeystroke: aString 262311 "Remember the last keystroke fielded by the receiver" 262312 262313 ^ self setProperty: #lastKeystroke toValue: aString! ! 262314 262315 262316!PasteUpMorph methodsFor: '*morphic-windows' stamp: 'stephane.ducasse 9/25/2008 13:33'! 262317bringWindowsFullOnscreen 262318 "Make ever SystemWindow on the desktop be totally on-screen, whenever possible." 262319 262320 (self windowsSatisfying: [:w | true]) do: 262321 [:aWindow | 262322 aWindow right: (aWindow right min: bounds right). 262323 aWindow bottom: (aWindow bottom min: bounds bottom). 262324 aWindow left: (aWindow left max: bounds left). 262325 aWindow top: (aWindow top max: bounds top)]! ! 262326 262327!PasteUpMorph methodsFor: '*morphic-windows' stamp: 'alain.plantec 2/6/2009 17:17'! 262328closeUnchangedWindows 262329 "Present a menu of window titles for all windows with changes, 262330 and activate the one that gets chosen." 262331 (self confirm: 262332'Do you really want to close all windows 262333except those with unaccepted edits?' translated) 262334 ifFalse: [^ self]. 262335 262336 (self windowsSatisfying: [:w | w model canDiscardEdits]) 262337 do: [:w | w delete]! ! 262338 262339!PasteUpMorph methodsFor: '*morphic-windows' stamp: 'stephane.ducasse 9/25/2008 13:33'! 262340collapseAll 262341 "Collapse all windows" 262342 (self windowsSatisfying: [:w | w isCollapsed not]) 262343 reverseDo: [:w | w collapseOrExpand. self displayWorld]. 262344 self collapseNonWindows! ! 262345 262346!PasteUpMorph methodsFor: '*morphic-windows' stamp: 'stephane.ducasse 9/25/2008 13:33'! 262347expandAll 262348 "Expand all windows" 262349 (self windowsSatisfying: [:w | w isCollapsed]) 262350 reverseDo: [:w | w collapseOrExpand. self displayWorld]! ! 262351 262352!PasteUpMorph methodsFor: '*morphic-windows' stamp: 'stephane.ducasse 9/25/2008 13:34'! 262353findDirtyBrowsers: evt 262354 "Present a menu of window titles for browsers with changes, 262355 and activate the one that gets chosen." 262356 262357 | menu | 262358 menu := MenuMorph new. 262359 (self windowsSatisfying: [:w | (w model isKindOf: Browser) and: [w model canDiscardEdits not]]) 262360 do: 262361 [:w | 262362 menu 262363 add: w label 262364 target: w 262365 action: #activate]. 262366 menu submorphs notEmpty ifTrue: [menu popUpEvent: evt in: self]! ! 262367 262368!PasteUpMorph methodsFor: '*morphic-windows' stamp: 'stephane.ducasse 9/25/2008 13:34'! 262369findDirtyWindows: evt 262370 "Present a menu of window titles for all windows with changes, 262371 and activate the one that gets chosen." 262372 262373 | menu | 262374 menu := MenuMorph new. 262375 (self windowsSatisfying: [:w | w model canDiscardEdits not]) do: 262376 [:w | 262377 menu 262378 add: w label 262379 target: w 262380 action: #activate]. 262381 menu submorphs notEmpty ifTrue: [menu popUpEvent: evt in: self]! ! 262382 262383!PasteUpMorph methodsFor: '*morphic-windows' stamp: 'michael.rueger 3/9/2009 18:51'! 262384findWindow: evt 262385 "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." 262386 | menu expanded collapsed nakedMorphs | 262387 menu := MenuMorph new. 262388 expanded := self windowsSatisfying: [:w | w isCollapsed not]. 262389 collapsed := self windowsSatisfying: [:w | w isCollapsed]. 262390 nakedMorphs := self submorphsSatisfying: 262391 [:m | (m isSystemWindow not) and: 262392 [(m isFlapTab) not]]. 262393 (expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty)) ifTrue: [^ Beeper beep]. 262394 (expanded asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do: 262395 [:w | menu add: w label target: w action: #activateAndForceLabelToShow. 262396 w model canDiscardEdits ifFalse: [menu lastItem color: Color red]]. 262397 (expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty)) ifFalse: [menu addLine]. 262398 (collapsed asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do: 262399 [:w | menu add: w label target: w action: #collapseOrExpand. 262400 w model canDiscardEdits ifFalse: [menu lastItem color: Color red]]. 262401 nakedMorphs isEmpty ifFalse: [menu addLine]. 262402 (nakedMorphs asSortedCollection: [:w1 :w2 | w1 nameForFindWindowFeature caseInsensitiveLessOrEqual: w2 nameForFindWindowFeature]) do: 262403 [:w | menu add: w nameForFindWindowFeature target: w action: #comeToFrontAndAddHalo]. 262404 menu addTitle: 'find window' translated. 262405 262406 menu popUpEvent: evt in: self.! ! 262407 262408!PasteUpMorph methodsFor: '*morphic-windows' stamp: 'stephane.ducasse 9/25/2008 13:35'! 262409fullRepaintNeeded 262410 262411 worldState doFullRepaint. 262412 self windowsSatisfying: [:w | w makeMeVisible. false]. 262413 262414! ! 262415 262416!PasteUpMorph methodsFor: '*morphic-windows' stamp: 'stephane.ducasse 9/25/2008 13:28'! 262417windowsSatisfying: windowBlock 262418 262419 | windows s | 262420 windows := OrderedCollection new. 262421 self submorphs do: 262422 [:m | 262423 ((m isSystemWindow) and: [windowBlock value: m]) 262424 ifTrue: [windows addLast: m] 262425 ifFalse: [((m isKindOf: TransformationMorph) and: [m submorphs size = 1]) 262426 ifTrue: [s := m firstSubmorph. 262427 ((s isSystemWindow) and: [windowBlock value: s]) 262428 ifTrue: [windows addLast: s]]]]. 262429 ^ windows! ! 262430 262431 262432!PasteUpMorph methodsFor: '*services-base' stamp: 'rr 3/14/2006 20:30'! 262433openWorldMenu 262434 | menu | 262435 menu := (TheWorldMenu new adaptToWorld: self) buildWorldMenu. 262436 menu addTitle: Preferences desktopMenuTitle translated. 262437 menu openInHand! ! 262438 262439!PasteUpMorph methodsFor: '*services-base' stamp: 'rr 3/10/2006 14:25'! 262440requestor 262441 "returns the focused window's requestor" 262442 ^ Requestor default! ! 262443 262444!PasteUpMorph methodsFor: '*services-base' stamp: 'rr 3/10/2006 14:25'! 262445topRequestor 262446 "returns the focused window's requestor" 262447 ^ SystemWindow topWindow requestor! ! 262448 262449!PasteUpMorph methodsFor: '*services-base' stamp: 'adrian_lienhard 7/21/2009 19:14'! 262450worldMenu 262451 ^ TheWorldMenu new adaptToWorld: self! ! 262452 262453 262454!PasteUpMorph methodsFor: 'accessing' stamp: 'stephane.ducasse 5/21/2009 15:14'! 262455assureFlapWidth: requestedWidth 262456 | tab | 262457 self width: requestedWidth. 262458 tab := self flapTab ifNil:[^self]. 262459 tab flapShowing ifTrue:[tab hideFlap; showFlap].! ! 262460 262461!PasteUpMorph methodsFor: 'accessing' stamp: 'stephane.ducasse 5/21/2009 15:13'! 262462flapTab 262463 | ww | 262464 self isFlap ifFalse:[^nil]. 262465 ww := self world ifNil: [World]. 262466 ^ww flapTabs detect: [:any| any referent == self] ifNone:[nil]! ! 262467 262468!PasteUpMorph methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! 262469modalWindow: aMorph 262470 (self valueOfProperty: #modalWindow) 262471 ifNotNil: [:morph | morph doCancel]. 262472 self setProperty: #modalWindow toValue: aMorph. 262473 aMorph 262474 ifNotNil: [self 262475 when: #aboutToLeaveWorld 262476 send: #removeModalWindow 262477 to: self]! ! 262478 262479!PasteUpMorph methodsFor: 'accessing' stamp: 'sw 4/1/98 21:18'! 262480modelOrNil 262481 "Return the model object for this world, or nil if it doesn't have one." 262482 262483 ^ model 262484! ! 262485 262486!PasteUpMorph methodsFor: 'accessing' stamp: 'stephane.ducasse 5/21/2009 15:13'! 262487presenter 262488 "Normally only the world will have a presenter, but the architecture supports individual localized presenters as well" 262489 262490 ^ presenter ifNil: 262491 [self isWorldMorph 262492 ifTrue: [presenter := Presenter new associatedMorph: self] 262493 ifFalse: [super presenter]]! ! 262494 262495!PasteUpMorph methodsFor: 'accessing' stamp: 'tak 3/15/2005 17:31'! 262496removeModalWindow 262497 self modalWindow: nil! ! 262498 262499!PasteUpMorph methodsFor: 'accessing' stamp: 'stephane.ducasse 5/21/2009 15:11'! 262500selectedRect 262501 "Return a rectangle enclosing the morph at the current cursor. Note that the cursor may be a float and may be out of range, so pick the nearest morph. Assume there is at least one submorph." 262502 262503 | p | 262504 p := cursor asInteger. 262505 p > submorphs size ifTrue: [p := submorphs size]. 262506 p < 1 ifTrue: [p := 1]. 262507 ^ (submorphs at: p) fullBounds expandBy: 2. 262508! ! 262509 262510!PasteUpMorph methodsFor: 'accessing' stamp: 'ar 4/25/2001 17:15'! 262511useRoundedCorners 262512 "Somewhat special cased because we do have to fill Display for this" 262513 super useRoundedCorners. 262514 self == World ifTrue:[Display bits primFill: 0]. "done so that we *don't* get a flash"! ! 262515 262516 262517!PasteUpMorph methodsFor: 'alarms-scheduler' stamp: 'ar 9/11/2000 16:40'! 262518addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime 262519 "Add a new alarm with the given set of parameters" 262520 worldState addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime.! ! 262521 262522!PasteUpMorph methodsFor: 'alarms-scheduler' stamp: 'ar 9/11/2000 16:39'! 262523removeAlarm: aSelector for: aTarget 262524 "Remove the alarm with the given selector" 262525 worldState removeAlarm: aSelector for: aTarget! ! 262526 262527 262528!PasteUpMorph methodsFor: 'caching' stamp: 'HenrikSperreJohansen 9/10/2009 15:15'! 262529releaseCachedState 262530 super releaseCachedState. 262531 self removeModalWindow. 262532 self isWorldMorph ifTrue:[self cleanseStepList].! ! 262533 262534 262535!PasteUpMorph methodsFor: 'change reporting' stamp: 'ar 1/5/2002 17:06'! 262536invalidRect: damageRect from: aMorph 262537 "Clip damage reports to my bounds, since drawing is clipped to my bounds." 262538 262539 self == self outermostWorldMorph 262540 ifTrue: [worldState recordDamagedRect: (damageRect intersect: self bounds)] 262541 ifFalse: [super invalidRect: damageRect from: aMorph] 262542! ! 262543 262544 262545!PasteUpMorph methodsFor: 'classification' stamp: 'sw 1/29/98 21:50'! 262546isPlayfieldLike 262547 ^ true! ! 262548 262549!PasteUpMorph methodsFor: 'classification' stamp: 'di 7/27/1999 10:46'! 262550isWorldMorph 262551 262552 ^ worldState notNil! ! 262553 262554 262555!PasteUpMorph methodsFor: 'copying' stamp: 'tk 7/30/2001 09:26'! 262556veryDeepCopyWith: deepCopier 262557 "See storeDataOn:" 262558 262559 ^ self isWorldMorph 262560 ifTrue: [self] "never copy the World" 262561 ifFalse: [super veryDeepCopyWith: deepCopier]! ! 262562 262563 262564!PasteUpMorph methodsFor: 'cursor' stamp: 'tak 11/7/2004 18:33'! 262565cursorWrapped: aNumber 262566 "Set the cursor to the given number, modulo the number of items I 262567 contain. Fractional cursor values are allowed." 262568 | oldRect newRect offset | 262569 cursor = aNumber 262570 ifTrue: [^ self]. 262571 self hasSubmorphs 262572 ifFalse: [cursor := 1. 262573 ^ self]. 262574 oldRect := self selectedRect. 262575 offset := (self asNumber: aNumber) - 1 \\ submorphs size. 262576 cursor := offset + 1. 262577 newRect := self selectedRect. 262578 self indicateCursor 262579 ifTrue: [self invalidRect: oldRect; 262580 invalidRect: newRect]! ! 262581 262582!PasteUpMorph methodsFor: 'cursor' stamp: 'sw 9/8/2000 16:41'! 262583numberAtCursor 262584 "Answer the number represented by the object at my current cursor position" 262585 262586 | chosenMorph | 262587 submorphs isEmpty ifTrue: [^ 0]. 262588 chosenMorph := submorphs at: ((cursor truncated max: 1) min: submorphs size). 262589 ^ chosenMorph getNumericValue 262590! ! 262591 262592!PasteUpMorph methodsFor: 'cursor' stamp: 'sw 5/12/1998 10:55'! 262593rectifyCursor 262594 cursor := ((cursor truncated max: 1) min: submorphs size) 262595! ! 262596 262597!PasteUpMorph methodsFor: 'cursor' stamp: 'stephane.ducasse 11/28/2008 10:25'! 262598valueAtCursor 262599 "Answer the submorph of mine indexed by the value of my 'cursor' slot" 262600 262601 submorphs isEmpty ifTrue: [^ nil]. 262602 ^ (submorphs at: ((cursor truncated max: 1) min: submorphs size)) morphRepresented! ! 262603 262604!PasteUpMorph methodsFor: 'cursor' stamp: 'sw 5/12/1998 10:55'! 262605valueAtCursor: aMorph 262606 submorphs isEmpty ifTrue: [^ self]. 262607 self rectifyCursor. 262608 self replaceSubmorph: self valueAtCursor by: aMorph! ! 262609 262610 262611!PasteUpMorph methodsFor: 'debug and other' stamp: 'marcus.denker 11/18/2008 14:52'! 262612addViewingItemsTo: aMenu 262613 "Add viewing-related items to the given menu. If any are added, this method is also responsible for adding a line after them" 262614 262615 #( (viewingByIconString viewByIcon) 262616 "(viewingBySizeString viewBySize)" 262617 (viewingNonOverlappingString viewNonOverlapping)) do: 262618 [:pair | aMenu addUpdating: pair first target: self action: pair second]. 262619 aMenu addLine 262620! ! 262621 262622 262623!PasteUpMorph methodsFor: 'display' stamp: 'ar 9/7/2002 15:24'! 262624gradientFillColor: aColor 262625 "For backwards compatibility with GradientFillMorph" 262626 262627 self flag: #fixThis. 262628 self useGradientFill. 262629 self fillStyle colorRamp: {0.0 -> self fillStyle colorRamp first value. 1.0 -> aColor}. 262630 self changed! ! 262631 262632!PasteUpMorph methodsFor: 'display' stamp: 'ar 10/5/2000 18:52'! 262633setGradientColor: evt 262634 "For backwards compatibility with GradientFillMorph" 262635 262636 self flag: #fixThis. 262637 self changeColorTarget: self selector: #gradientFillColor: 262638 originalColor: (self fillStyle isGradientFill 262639 ifTrue: [self fillStyle colorRamp last value] 262640 ifFalse: [color]) 262641 hand: evt hand.! ! 262642 262643 262644!PasteUpMorph methodsFor: 'drawing' stamp: 'marcus.denker 8/24/2008 22:06'! 262645drawOn: aCanvas 262646 "Draw in order: 262647 - background color 262648 - grid, if any 262649 - background sketch, if any 262650 - Update and draw the turtleTrails form. See the comment in updateTrailsForm. 262651 - cursor box if any 262652 262653 Later (in drawSubmorphsOn:) I will skip drawing the background sketch." 262654 262655 "draw background fill" 262656 super drawOn: aCanvas. 262657 262658 "draw grid" 262659 (self griddingOn and: [self gridVisible]) 262660 ifTrue: 262661 [aCanvas fillRectangle: self bounds 262662 fillStyle: (self 262663 gridFormOrigin: self gridOrigin 262664 grid: self gridModulus 262665 background: nil 262666 line: Color lightGray)]. 262667 262668 "draw background sketch." 262669 backgroundMorph ifNotNil: [ 262670 self clipSubmorphs ifTrue: [ 262671 aCanvas clipBy: self clippingBounds 262672 during: [ :canvas | canvas fullDrawMorph: backgroundMorph ]] 262673 ifFalse: [ aCanvas fullDrawMorph: backgroundMorph ]]. 262674 262675 "draw cursor" 262676 (submorphs notEmpty and: [self indicateCursor]) 262677 ifTrue: 262678 [aCanvas 262679 frameRectangle: self selectedRect 262680 width: 2 262681 color: Color black]! ! 262682 262683 262684!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'stephane.ducasse 10/16/2008 17:31'! 262685acceptDroppingMorph: dropped event: evt 262686 "The supplied morph, known to be acceptable to the receiver, is now to be assimilated; the precipitating event is supplied" 262687 262688 | aMorph | 262689 aMorph := self morphToDropFrom: dropped. 262690 self isWorldMorph 262691 ifTrue:["Add the given morph to this world and start stepping it if it wants to be." 262692 self addMorphFront: aMorph. 262693 (aMorph fullBounds intersects: self viewBox) ifFalse: 262694 [Beeper beep. aMorph position: self bounds center]] 262695 ifFalse:[super acceptDroppingMorph: aMorph event: evt]. 262696 262697 aMorph submorphsDo: [:m | (m isKindOf: HaloMorph) ifTrue: [m delete]]. 262698 262699 self isPartsBin 262700 ifTrue: 262701 [aMorph isPartsDonor: true. 262702 aMorph stopSteppingSelfAndSubmorphs. 262703 aMorph suspendEventHandler] 262704 ifFalse: 262705 [self world startSteppingSubmorphsOf: aMorph]. 262706 262707 self showingListView ifTrue: 262708 [self sortSubmorphsBy: (self valueOfProperty: #sortOrder). 262709 self currentWorld abandonAllHalos]. 262710 262711 self bringTopmostsToFront. 262712! ! 262713 262714!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 6/18/1998 09:10'! 262715automaticPhraseExpansion 262716 ^ self hasProperty: #automaticPhraseExpansion! ! 262717 262718!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 2/4/2001 00:54'! 262719dropEnabled 262720 "Get this morph's ability to add and remove morphs via drag-n-drop." 262721 262722 ^ (self valueOfProperty: #dropEnabled) ~~ false 262723! ! 262724 262725!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 9/1/2000 05:37'! 262726justDroppedInto: aMorph event: anEvent 262727 "This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph" 262728 262729 super justDroppedInto: aMorph event: anEvent. 262730 self isPartsBin ifTrue: [self setPartsBinStatusTo: true] "gets some things right about the subtle case of dropping a parts bin" 262731! ! 262732 262733!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 7/6/1999 13:26'! 262734originAtCenter 262735 ^ self hasProperty: #originAtCenter! ! 262736 262737!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'stephane.ducasse 5/21/2009 15:15'! 262738positionNear: aPoint forExtent: anExtent adjustmentSuggestion: adjustmentPoint 262739 "Compute a plausible positioning for adding a subpart of size anExtent, somewhere near aPoint, using adjustmentPoint as the unit of adjustment" 262740 262741 | adjustedPosition | 262742 adjustedPosition := aPoint. 262743 [((self morphsAt: (adjustedPosition + (anExtent // 2))) size > 1) and: "that 1 is self here" 262744 [bounds containsPoint: adjustedPosition]] 262745 whileTrue: 262746 [adjustedPosition := adjustedPosition + adjustmentPoint]. 262747 262748 ^ adjustedPosition! ! 262749 262750!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:22'! 262751repelsMorph: aMorph event: ev 262752 (aMorph wantsToBeDroppedInto: self) ifFalse: [^ false]. 262753 self dropEnabled ifFalse: [^ true]. 262754 (self wantsDroppedMorph: aMorph event: ev) ifFalse: [^ true]. 262755 ^ super repelsMorph: aMorph event: ev "consults #repelling flag"! ! 262756 262757!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:22'! 262758wantsDroppedMorph: aMorph event: evt 262759 self isWorldMorph ifTrue:[^true]. "always" 262760 self visible ifFalse: [^ false]. "will be a call to #hidden again very soon" 262761 self dropEnabled ifFalse: [^ false]. 262762 ^ true! ! 262763 262764 262765!PasteUpMorph methodsFor: 'e-toy support' stamp: 'di 7/27/1999 10:24'! 262766cursor 262767 ^ cursor 262768! ! 262769 262770!PasteUpMorph methodsFor: 'e-toy support' stamp: 'sw 9/7/2000 11:43'! 262771cursor: aNumber 262772 "for backward compatibility" 262773 262774 self cursorWrapped: aNumber! ! 262775 262776 262777!PasteUpMorph methodsFor: 'event handling' stamp: 'mir 1/10/2002 17:35'! 262778dropFiles: anEvent 262779 "Handle a number of dropped files from the OS. 262780 TODO: 262781 - use a more general mechanism for figuring out what to do with the file (perhaps even offering a choice from a menu) 262782 - remember the resource location or (when in browser) even the actual file handle 262783 " 262784 | numFiles stream handler | 262785 numFiles := anEvent contents. 262786 1 to: numFiles do: [:i | 262787 stream := FileStream requestDropStream: i. 262788 handler := ExternalDropHandler lookupExternalDropHandler: stream. 262789 [handler ifNotNil: [handler handle: stream in: self dropEvent: anEvent]] 262790 ensure: [stream close]].! ! 262791 262792!PasteUpMorph methodsFor: 'event handling' stamp: 'dgd 8/28/2004 18:44'! 262793handlesKeyboard: evt 262794 ^self isWorldMorph or:[evt keyCharacter == Character tab and:[self tabAmongFields]]! ! 262795 262796!PasteUpMorph methodsFor: 'event handling' stamp: 'ar 10/3/2000 22:46'! 262797handlesMouseDown: evt 262798 ^true! ! 262799 262800!PasteUpMorph methodsFor: 'event handling' stamp: 'dgd 4/4/2006 14:42'! 262801keyStroke: anEvent 262802 "A keystroke has been made. Service event handlers and, if it's a keystroke presented to the world, dispatch it to #unfocusedKeystroke:" 262803 262804 | selected | 262805 super keyStroke: anEvent. "Give event handlers a chance" 262806 262807 selected := self selectedObject. 262808 selected isNil 262809 ifFalse:[ selected moveOrResizeFromKeystroke: anEvent ]. 262810 262811 (anEvent keyCharacter == Character tab) ifTrue: 262812 [self tabAmongFields 262813 ifTrue:[^ self tabHitWithEvent: anEvent]]. 262814 self isWorldMorph ifTrue: 262815 [self keystrokeInWorld: anEvent]! ! 262816 262817!PasteUpMorph methodsFor: 'event handling' stamp: 'ar 2/23/2001 16:44'! 262818morphToGrab: event 262819 "Return the morph to grab from a mouse down event. If none, return nil." 262820 self submorphsDo:[:m| 262821 ((m rejectsEvent: event) not and:[m fullContainsPoint: event cursorPoint]) ifTrue:[^m]. 262822 ]. 262823 ^nil! ! 262824 262825!PasteUpMorph methodsFor: 'event handling' stamp: 'marcus.denker 11/19/2008 13:51'! 262826mouseDown: evt 262827 "Handle a mouse down event." 262828 | grabbedMorph handHadHalos | 262829 262830 (Preferences generalizedYellowButtonMenu 262831 and: [evt yellowButtonPressed]) 262832 ifTrue: [^ self yellowButtonActivity: evt shiftPressed]. 262833 262834 grabbedMorph := self morphToGrab: evt. 262835 grabbedMorph ifNotNil:[ 262836 grabbedMorph isSticky ifTrue:[^self]. 262837 self isPartsBin ifFalse:[^evt hand grabMorph: grabbedMorph]. 262838 grabbedMorph := grabbedMorph partRepresented duplicate. 262839 grabbedMorph restoreSuspendedEventHandler. 262840 (grabbedMorph fullBounds containsPoint: evt position) 262841 ifFalse:[grabbedMorph position: evt position]. 262842 "Note: grabbedMorph is ownerless after duplicate so use #grabMorph:from: instead" 262843 ^ evt hand grabMorph: grabbedMorph from: self]. 262844 262845 (super handlesMouseDown: evt) 262846 ifTrue:[^super mouseDown: evt]. 262847 262848 handHadHalos := evt hand halo notNil. 262849 262850 evt hand removeHalo. "shake off halos" 262851 evt hand releaseKeyboardFocus. "shake of keyboard foci" 262852 262853 self submorphs 262854 select:[:each | each hasProperty: #morphHierarchy] 262855 thenDo:[:each | each delete]. 262856 262857 (evt shiftPressed not 262858 and:[ self isWorldMorph not ] 262859 and:[ self wantsEasySelection not ]) 262860 ifTrue:[ 262861 "explicitly ignore the event if we're not the world and we'll not select, 262862 so that we could be picked up if need be" 262863 evt wasHandled: false. 262864 ^ self. 262865 ]. 262866 262867 ( evt shiftPressed or: [ self wantsEasySelection ] ) ifTrue:[ 262868 "We'll select on drag, let's decide what to do on click" 262869 | clickSelector | 262870 262871 clickSelector := nil. 262872 262873 evt shiftPressed ifTrue:[ 262874 clickSelector := #findWindow:. 262875 ] 262876 ifFalse:[ 262877 self isWorldMorph ifTrue:[ 262878 clickSelector := handHadHalos 262879 ifTrue: [ #delayedInvokeWorldMenu: ] 262880 ifFalse: [ #invokeWorldMenu: ] 262881 ] 262882 ]. 262883 262884 evt hand 262885 waitForClicksOrDrag: self 262886 event: evt 262887 selectors: { clickSelector. nil. nil. #dragThroughOnDesktop: } 262888 threshold: 5. 262889 ] 262890 ifFalse:[ 262891 "We wont select, just bring world menu if I'm the world" 262892 self isWorldMorph ifTrue:[ 262893 handHadHalos 262894 ifTrue: [ self delayedInvokeWorldMenu: evt ] 262895 ifFalse: [ self invokeWorldMenu: evt ] 262896 ] 262897 ]. 262898! ! 262899 262900!PasteUpMorph methodsFor: 'event handling' stamp: 'ar 10/6/2000 00:04'! 262901mouseUp: evt 262902 self isWorldMorph ifTrue:[self removeAlarm: #invokeWorldMenu:]. 262903 super mouseUp: evt.! ! 262904 262905!PasteUpMorph methodsFor: 'event handling' stamp: 'ar 1/10/2001 21:29'! 262906wantsDropFiles: anEvent 262907 ^self isWorldMorph! ! 262908 262909!PasteUpMorph methodsFor: 'event handling' stamp: 'dgd 9/27/2004 13:55'! 262910wantsEasySelection 262911 "Answer if the receiver want easy selection mode" 262912 ^ Preferences easySelection! ! 262913 262914!PasteUpMorph methodsFor: 'event handling' stamp: 'sw 5/6/1998 17:07'! 262915wantsKeyboardFocusFor: aSubmorph 262916 aSubmorph inPartsBin ifTrue: [^ false]. 262917 aSubmorph wouldAcceptKeyboardFocus ifTrue: [ ^ true]. 262918 ^ super wantsKeyboardFocusFor: aSubmorph! ! 262919 262920 262921!PasteUpMorph methodsFor: 'events-processing' stamp: 'ar 4/5/2001 21:42'! 262922processEvent: anEvent using: defaultDispatcher 262923 "Reimplemented to install the receiver as the new ActiveWorld if it is one" 262924 | priorWorld result | 262925 self isWorldMorph ifFalse:[^super processEvent: anEvent using: defaultDispatcher]. 262926 priorWorld := ActiveWorld. 262927 ActiveWorld := self. 262928 result := super processEvent: anEvent using: defaultDispatcher. 262929 ActiveWorld := priorWorld. 262930 ^result! ! 262931 262932 262933!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 2/15/1999 20:37'! 262934accommodateFlap: aFlapTab 262935 "Shift submorphs over, if appropriate" 262936 | offset | 262937 aFlapTab slidesOtherObjects ifTrue: 262938 [offset := self offsetForAccommodating: aFlapTab referent extent onEdge: aFlapTab edgeToAdhereTo. 262939 self shiftSubmorphsBy: offset]! ! 262940 262941!PasteUpMorph methodsFor: 'flaps' stamp: 'dao 10/1/2004 12:56'! 262942addGlobalFlaps 262943 "Must make global flaps adapt to world. Do this even if not shown, so the old world will not be pointed at by the flaps." 262944 262945 | use thisWorld | 262946 use := Flaps sharedFlapsAllowed. 262947 Project current flapsSuppressed ifTrue: [use := false]. 262948 "Smalltalk isMorphic ifFalse: [use := false]." 262949 thisWorld := use 262950 ifTrue: [self] 262951 ifFalse: [PasteUpMorph new initForProject: "fake to be flap owner" 262952 WorldState new; 262953 bounds: (0@0 extent: 4000@4000); 262954 viewBox: (0@0 extent: 4000@4000)]. 262955 262956 Flaps globalFlapTabsIfAny do: [:aFlapTab | 262957 (Project current isFlapEnabled: aFlapTab) ifTrue: 262958 [(aFlapTab world == thisWorld) ifFalse: 262959 [thisWorld addMorphFront: aFlapTab. 262960 aFlapTab adaptToWorld: thisWorld]. "always do" 262961 use ifTrue: 262962 [aFlapTab spanWorld. 262963 aFlapTab adjustPositionAfterHidingFlap. 262964 aFlapTab flapShowing ifTrue: [aFlapTab showFlap]]]]! ! 262965 262966!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 6/17/1999 16:02'! 262967assureFlapTabsFitOnScreen 262968 self flapTabs do: 262969 [:m | m fitOnScreen]! ! 262970 262971!PasteUpMorph methodsFor: 'flaps' stamp: 'dgd 4/4/2006 13:58'! 262972bringTopmostsToFront 262973 submorphs 262974 select:[:m| m wantsToBeTopmost] 262975 thenDo:[:m| self addMorphInLayer: m].! ! 262976 262977!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 7/28/1999 15:42'! 262978correspondingFlapTab 262979 "If there is a flap tab whose referent is me, return it, else return nil" 262980 self currentWorld flapTabs do: 262981 [:aTab | aTab referent == self ifTrue: [^ aTab]]. 262982 ^ nil! ! 262983 262984!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 5/5/2001 00:27'! 262985deleteGlobalFlapArtifacts 262986 "Delete all flap-related detritus from the world" 262987 262988 | localFlaps | 262989 localFlaps := self localFlapTabs collect: [:m | m referent]. 262990 self submorphs do: 262991 [:m | 262992 ((m isFlapTab) and: [m isGlobalFlap]) ifTrue: [m delete]. 262993 m isFlap ifTrue:[(localFlaps includes: m) ifFalse: [m delete]]] 262994 262995"ActiveWorld deleteGlobalFlapArtifacts" 262996 262997! ! 262998 262999!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 4/17/2001 11:23'! 263000enableGlobalFlaps 263001 "Restore saved global flaps, or obtain brand-new system defaults if necessary" 263002 263003 Flaps globalFlapTabs. "If nil, creates new ones" 263004 self addGlobalFlaps "put them on screen"! ! 263005 263006!PasteUpMorph methodsFor: 'flaps' stamp: 'ar 9/28/2000 13:56'! 263007flapTabs 263008 ^ self submorphs select:[:m| m isFlapTab]! ! 263009 263010!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 4/17/2001 11:22'! 263011localFlapTabs 263012 "Answer a list of local flap tabs in the current project" 263013 263014 | globalList aList aFlapTab | 263015 globalList := Flaps globalFlapTabsIfAny. 263016 aList := OrderedCollection new. 263017 submorphs do: 263018 [:m | ((m isFlapTab) and: [(globalList includes: m) not]) 263019 ifTrue: 263020 [aList add: m] 263021 ifFalse: 263022 [((m isFlap) and: 263023 [(aFlapTab := m submorphs detect: [:n | n isFlapTab] ifNone: [nil]) notNil]) 263024 ifTrue: 263025 [aList add: aFlapTab]]]. 263026 ^ aList! ! 263027 263028!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 2/11/1999 10:53'! 263029offsetForAccommodating: anExtent onEdge: edgeSymbol 263030 "Answer a delta to be applied to my submorphs in order tfor anExtent to be slid inboard on the indicated edge" 263031 edgeSymbol == #left ifTrue: [^ anExtent x @ 0]. 263032 edgeSymbol == #right ifTrue: [^ anExtent x negated @ 0]. 263033 edgeSymbol == #top ifTrue: [^ 0 @ anExtent y]. 263034 edgeSymbol == #bottom ifTrue: [^ 0 @ anExtent y negated].! ! 263035 263036!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 6/25/1999 21:35'! 263037paintingFlapTab 263038 "If the receiver has a flap which has a paintbox, return it, else return nil" 263039 self flapTabs do: 263040 [:aTab | aTab referent submorphsDo: 263041 [:aMorph | (aMorph isKindOf: PaintBoxMorph) ifTrue: [^ aTab]]]. 263042 ^ nil! ! 263043 263044!PasteUpMorph methodsFor: 'flaps' stamp: 'RAA 1/9/2001 06:59'! 263045releaseViewers 263046 "In preparation for saving, make the flapTabs release their viewers." 263047 263048 self flapTabs do: [:ft | 263049 (ft respondsTo: #hibernate) ifTrue: [ft hibernate]]! ! 263050 263051!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 2/15/1999 20:36'! 263052removeAccommodationForFlap: aFlapTab 263053 "Shift submorphs over, if appropriate" 263054 | offset | 263055 aFlapTab slidesOtherObjects ifTrue: 263056 [offset := self offsetForAccommodating: aFlapTab referent extent onEdge: aFlapTab edgeToAdhereTo. 263057 self shiftSubmorphsBy: offset negated]! ! 263058 263059 263060!PasteUpMorph methodsFor: 'geometry' stamp: 'RAA 6/20/2000 12:42'! 263061extent: aPoint 263062 263063 super extent: aPoint. 263064 worldState ifNotNil: [ 263065 worldState viewBox ifNotNil: [ 263066 worldState canvas: nil. 263067 worldState viewBox: bounds 263068 ]. 263069 ].! ! 263070 263071!PasteUpMorph methodsFor: 'geometry' stamp: 'di 8/28/2000 23:13'! 263072gridPoint: ungriddedPoint 263073 263074 self griddingOn ifFalse: [^ ungriddedPoint]. 263075 ^ (ungriddedPoint - self position - self gridOrigin grid: self gridModulus) 263076 + self position + self gridOrigin! ! 263077 263078!PasteUpMorph methodsFor: 'geometry' stamp: 'RAA 6/1/2000 10:28'! 263079position: aPoint 263080 "Prevent moving a world (e.g. via HandMorph>>specialGesture:)" 263081 263082 "for now, let's allow it and see what happens" 263083 263084 self isWorldMorph ifFalse: [^super position: aPoint]. 263085 super position: aPoint. 263086 self viewBox ifNotNil: [self viewBox: (aPoint extent: self viewBox extent)]. 263087 263088! ! 263089 263090 263091!PasteUpMorph methodsFor: 'geometry testing' stamp: 'RAA 6/2/2000 10:22'! 263092fullContainsPoint: pt 263093 "The world clips its children" 263094 263095 worldState ifNil: [^super fullContainsPoint: pt]. 263096 ^bounds containsPoint: pt 263097 263098! ! 263099 263100 263101!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:15'! 263102griddingOn 263103 263104 ^ griddingOn ifNil: [false]! ! 263105 263106!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:48'! 263107griddingOnOff 263108 263109 griddingOn := self griddingOn not. 263110 self changed! ! 263111 263112!PasteUpMorph methodsFor: 'gridding' stamp: 'dgd 12/13/2003 19:30'! 263113griddingString 263114 "Answer a string to use in a menu offering the user the 263115 opportunity to start or stop using gridding" 263116 ^ (self griddingOn 263117 ifTrue: ['<yes>'] 263118 ifFalse: ['<no>']) 263119 , 'use gridding' translated! ! 263120 263121!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:29'! 263122gridModulus 263123 263124 ^ self gridSpec extent! ! 263125 263126!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:47'! 263127gridModulus: newModulus 263128 263129 self gridSpecPut: (self gridOrigin extent: newModulus). 263130 self changed! ! 263131 263132!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:28'! 263133gridOrigin 263134 263135 ^ self gridSpec origin! ! 263136 263137!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:29'! 263138gridOrigin: newOrigin 263139 263140 ^ self gridSpecPut: (newOrigin extent: self gridModulus)! ! 263141 263142!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:26'! 263143gridSpec 263144 "Gridding rectangle provides origin and modulus" 263145 263146 ^ self valueOfProperty: #gridSpec ifAbsent: [0@0 extent: 8@8]! ! 263147 263148!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:28'! 263149gridSpecPut: newSpec 263150 "Gridding rectangle provides origin and modulus" 263151 263152 ^ self setProperty: #gridSpec toValue: newSpec! ! 263153 263154!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:11'! 263155gridVisible 263156 263157 ^ self hasProperty: #gridVisible! ! 263158 263159!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:47'! 263160gridVisibleOnOff 263161 263162 self setProperty: #gridVisible toValue: self gridVisible not. 263163 self changed! ! 263164 263165!PasteUpMorph methodsFor: 'gridding' stamp: 'dgd 12/13/2003 19:30'! 263166gridVisibleString 263167 "Answer a string to be used in a menu offering the opportunity 263168 to show or hide the grid" 263169 ^ (self gridVisible 263170 ifTrue: ['<yes>'] 263171 ifFalse: ['<no>']) 263172 , 'show grid when gridding' translated! ! 263173 263174!PasteUpMorph methodsFor: 'gridding' stamp: 'DamienCassou 9/29/2009 13:06'! 263175setGridSpec 263176 "Gridding rectangle provides origin and modulus" 263177 | response result | 263178 response := UIManager default 263179 request: 'New grid origin (usually 0@0):' translated 263180 initialAnswer: self gridOrigin printString. 263181 response isEmpty ifTrue: [^ self]. 263182 result := [Compiler evaluate: response] ifError: [^ self]. 263183 (result isPoint and: [(result >= (0@0))]) 263184 ifTrue: [self gridOrigin: result] 263185 ifFalse: [self inform: ('Must be a Point with coordinates (for example 10@10)' translated )]. 263186 263187 response := UIManager default 263188 request: 'New grid spacing:' translated 263189 initialAnswer: self gridModulus printString. 263190 response isEmptyOrNil ifTrue: [^ self]. 263191 result := [Compiler evaluate: response] ifError: [^ self]. 263192 (result isPoint and: [(result > (0@0)) ]) 263193 ifTrue: [self gridModulus: result] 263194 ifFalse: [self inform: ('Must be a Point with coordinates (for example 10@10)' translated )]. 263195 263196! ! 263197 263198 263199!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'sw 1/10/2000 16:44'! 263200defersHaloOnClickTo: aSubMorph 263201 "If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true" 263202 ^ true 263203 ! ! 263204 263205!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'di 9/26/2000 21:39'! 263206wantsDirectionHandles 263207 263208 ^ super wantsDirectionHandles and: [self isWorldMorph not]! ! 263209 263210!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'ar 10/11/2000 18:22'! 263211wantsHaloFor: aSubMorph 263212 "Answer whether the receiver wishes for a mouse-over halo to be produced for aSubMorph" 263213 263214 ^ wantsMouseOverHalos == true and: 263215 [self visible and: 263216 [isPartsBin ~~ true and: 263217 [self dropEnabled and: 263218 [self isWorldMorph not or: [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]] 263219 263220 "The odd logic at the end of the above says... 263221 263222 * If we're an interior playfield, then if we're set up for mouseover halos, show em. 263223 * If we're a World that's set up for mouseover halos, only show 'em if the putative 263224 recipient is a SketchMorph. 263225 263226 This (old) logic was put in to suit a particular need in early e-toy days and seems rather strange now!!"! ! 263227 263228!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'yo 2/17/2005 14:45'! 263229wantsHaloFromClick 263230 (owner isSystemWindow) ifTrue: [^ false]. 263231 self paintBoxOrNil ifNotNil: [^ false]. 263232 ^ true. 263233! ! 263234 263235 263236!PasteUpMorph methodsFor: 'initialization' stamp: 'AlexandreBergel 7/30/2008 14:17'! 263237becomeActiveDuring: aBlock 263238 "Make the receiver the ActiveWorld during the evaluation of aBlock. 263239 Note that this method does deliberately *not* use #ensure: to prevent 263240 re-installation of the world on project switches." 263241 | priorWorld priorHand priorEvent | 263242 priorWorld := ActiveWorld. 263243 priorHand := ActiveHand. 263244 priorEvent := ActiveEvent. 263245 ActiveWorld := self. 263246 ActiveHand := self hands first. "default" 263247 ActiveEvent := nil. "not in event cycle" 263248 [aBlock value] 263249 on: Error 263250 do: [:ex | 263251 ActiveWorld := priorWorld. 263252 ActiveEvent := priorEvent. 263253 ActiveHand := priorHand. 263254 ex pass]! ! 263255 263256!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'! 263257defaultBorderColor 263258 "answer the default border color/fill style for the receiver" 263259 ^ Color 263260 r: 0.861 263261 g: 1.0 263262 b: 0.722! ! 263263 263264!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! 263265defaultBorderWidth 263266 "answer the default border width for the receiver" 263267 ^ 1! ! 263268 263269!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'! 263270defaultColor 263271 "answer the default color/fill style for the receiver" 263272 ^ Color 263273 r: 0.8 263274 g: 1.0 263275 b: 0.6! ! 263276 263277!PasteUpMorph methodsFor: 'initialization' stamp: 'stephane.ducasse 11/12/2008 10:28'! 263278initialize 263279"initialize the state of the receiver" 263280 super initialize. 263281"" 263282 cursor := 1. 263283 padding := 3. 263284 self enableDragNDrop. 263285 self clipSubmorphs: true! ! 263286 263287!PasteUpMorph methodsFor: 'initialization' stamp: 'ar 3/3/2001 15:30'! 263288newResourceLoaded 263289 "Some resource has just been loaded. Notify all morphs in case somebody wants to update accordingly." 263290 self allMorphsDo:[:m| m resourceJustLoaded ]. 263291 self fullRepaintNeeded.! ! 263292 263293 263294!PasteUpMorph methodsFor: 'interaction loop' stamp: 'ls 5/6/2003 16:51'! 263295doOneCycleNow 263296 "see the comment in doOneCycleNowFor:" 263297 worldState doOneCycleNowFor: self. 263298! ! 263299 263300 263301!PasteUpMorph methodsFor: 'layout' stamp: 'sw 3/24/1999 14:11'! 263302addCenteredAtBottom: aMorph offset: anOffset 263303 "Add aMorph beneath all other morphs currently in the receiver, centered horizontally, with the vertical offset from the bottom of the previous morph given by anOffset" 263304 | curBot | 263305 curBot := 0. 263306 submorphs do: [:m | curBot := curBot max: m bottom]. 263307 self addMorphBack: aMorph. 263308 aMorph position: ((self center x - (aMorph width // 2)) @ (curBot + anOffset))! ! 263309 263310!PasteUpMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 18:47'! 263311convertAlignment 263312 self clipSubmorphs: true. 263313 (autoLineLayout == true) ifTrue:[ 263314 self layoutPolicy: TableLayout new. 263315 self layoutInset: 8; cellInset: 4. 263316 self listDirection: #leftToRight; wrapDirection: #topToBottom. 263317 self minHeight: self height. 263318 ] ifFalse:[ 263319 self layoutPolicy: nil. 263320 self layoutInset: 0; cellInset: 0. 263321 ]. 263322 (resizeToFit == true) ifTrue:[ 263323 self vResizing: #shrinkWrap. 263324 ] ifFalse:[ 263325 self vResizing: #rigid. 263326 ].! ! 263327 263328!PasteUpMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 13:43'! 263329layoutChanged 263330 "The receiver's layout changed; inform above and below" 263331 super layoutChanged. 263332 (self valueOfProperty: #SqueakPage) ifNotNil: [ 263333 self setProperty: #pageDirty toValue: true]. 263334 "I am the morph of a SqueakPage, I have changed and 263335 need to be written out again" 263336! ! 263337 263338!PasteUpMorph methodsFor: 'layout' stamp: 'sw 8/3/1998 13:43'! 263339laySubpartsOutInOneRow 263340 | aPosition | 263341 aPosition := 0 @ padding. 263342 submorphs do: 263343 [:aMorph | 263344 aMorph position: (aPosition + (padding @ 0)). 263345 aPosition := aMorph topRight]! ! 263346 263347 263348!PasteUpMorph methodsFor: 'menu & halo' stamp: 'md 7/28/2009 14:46'! 263349addCustomMenuItems: menu hand: aHandMorph 263350 "Add morph-specific menu itemns to the menu for the hand" 263351 super addCustomMenuItems: menu hand: aHandMorph. 263352 263353 menu addLine. 263354 self isWorldMorph ifTrue: [ 263355 menu addLine. 263356 menu addUpdating: #showWorldMainDockingBarString action: #toggleShowWorldMainDockingBar. 263357 ]. 263358! ! 263359 263360!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 8/30/2003 21:18'! 263361addScalingMenuItems: menu hand: aHandMorph 263362 263363 | subMenu | 263364 263365 (subMenu := MenuMorph new) 263366 defaultTarget: self; 263367 add: 'show application view' translated action: #showApplicationView; 263368 add: 'show factory view' translated action: #showFactoryView; 263369 add: 'show whole world view' translated action: #showFullView; 263370 add: 'expand' translated action: #showExpandedView; 263371 add: 'reduce' translated action: #showReducedView; 263372 addLine; 263373 add: 'define application view' translated action: #defineApplicationView; 263374 add: 'define factory view' translated action: #defineFactoryView. 263375 menu 263376 add: 'world scale and clip...' translated 263377 subMenu: subMenu! ! 263378 263379!PasteUpMorph methodsFor: 'menu & halo' stamp: 'adrian_lienhard 7/19/2009 21:12'! 263380addWorldHaloMenuItemsTo: aMenu hand: aHandMorph 263381 "Add standard halo items to the menu, given that the receiver is a World" 263382 263383 | | 263384 self addFillStyleMenuItems: aMenu hand: aHandMorph. 263385 self addLayoutMenuItems: aMenu hand: aHandMorph. 263386 263387 aMenu addLine. 263388 self addWorldToggleItemsToHaloMenu: aMenu. 263389 aMenu addLine. 263390 self addExportMenuItems: aMenu hand: aHandMorph. 263391 self addMiscExtrasTo: aMenu. 263392 self addDebuggingItemsTo: aMenu hand: aHandMorph. 263393 263394 aMenu addLine. 263395 aMenu defaultTarget: aHandMorph. 263396! ! 263397 263398!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 4/20/2002 01:38'! 263399addWorldToggleItemsToHaloMenu: aMenu 263400 "Add toggle items for the world to the halo menu" 263401 263402 #( 263403 (hasDragAndDropEnabledString changeDragAndDrop 'whether I am open to having objects dropped into me') 263404 (roundedCornersString toggleCornerRounding 'whether the world should have rounded corners')) do: 263405 263406 [:trip | aMenu addUpdating: trip first action: trip second. 263407 aMenu balloonTextForLastItem: trip third]! ! 263408 263409!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:54'! 263410autoLineLayoutString 263411 "Answer the string to be shown in a menu to represent the 263412 auto-line-layout status" 263413 ^ (self autoLineLayout 263414 ifTrue: ['<on>'] 263415 ifFalse: ['<off>']) 263416 , 'auto-line-layout' translated! ! 263417 263418!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:31'! 263419defineApplicationView 263420 263421 | r | 263422 r := Rectangle fromUser. 263423 self 263424 setProperty: #applicationViewBounds 263425 toValue: ((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated ! ! 263426 263427!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:29'! 263428defineFactoryView 263429 263430 | r | 263431 r := Rectangle fromUser. 263432 self 263433 setProperty: #factoryViewBounds 263434 toValue: ((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated ! ! 263435 263436!PasteUpMorph methodsFor: 'menu & halo' stamp: 'ar 10/3/2000 17:02'! 263437deleteBalloonTarget: aMorph 263438 "Delete the balloon help targeting the given morph" 263439 self handsDo:[:h| h deleteBalloonTarget: aMorph].! ! 263440 263441!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:56'! 263442indicateCursorString 263443 "Answer the string to be shown in a menu to represent the 263444 whether-to-indicate-cursor status" 263445 ^ (self indicateCursor 263446 ifTrue: ['<on>'] 263447 ifFalse: ['<off>']) 263448 , 'indicate cursor' translated! ! 263449 263450!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:58'! 263451isOpenForDragNDropString 263452 "Answer the string to be shown in a menu to represent the 263453 open-to-drag-n-drop status" 263454 ^ (self dragNDropEnabled 263455 ifTrue: ['<on>'] 263456 ifFalse: ['<off>']) 263457 , 'open to drag & drop' translated! ! 263458 263459!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:57'! 263460isPartsBinString 263461 "Answer the string to be shown in a menu to represent the 263462 parts-bin status" 263463 ^ (self isPartsBin 263464 ifTrue: ['<on>'] 263465 ifFalse: ['<off>']), 'parts bin' translated! ! 263466 263467!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:58'! 263468mouseOverHalosString 263469 "Answer the string to be shown in a menu to represent the 263470 mouse-over-halos status" 263471 ^ (self wantsMouseOverHalos 263472 ifTrue: ['<on>'] 263473 ifFalse: ['<off>']) 263474 , 'mouse-over halos' translated! ! 263475 263476!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:00'! 263477originAtCenterString 263478 "Answer the string to be shown in a menu to represent the 263479 origin-at-center status" 263480 ^ ((self hasProperty: #originAtCenter) 263481 ifTrue: ['<on>'] 263482 ifFalse: ['<off>']), 'origin-at-center' translated! ! 263483 263484!PasteUpMorph methodsFor: 'menu & halo' stamp: 'adrian_lienhard 7/19/2009 20:52'! 263485playfieldOptionsMenu 263486 "Answer an auxiliary menu with options specific to playfields -- too many to be housed in the main menu" 263487 263488 | aMenu isWorld | 263489 isWorld := self isWorldMorph. 263490 aMenu := MenuMorph new defaultTarget: self. 263491 aMenu addStayUpItem. 263492 263493 aMenu add: 'round up strays' translated action: #roundUpStrays. 263494 aMenu balloonTextForLastItem: 'Bring back all objects whose current coordinates keep them from being visible, so that at least a portion of each of my interior objects can be seen.' translated. 263495 263496 263497 self griddingOn 263498 ifTrue: [aMenu add: 'turn gridding off' translated action: #griddingOnOff. 263499 aMenu add: (self gridVisible ifTrue: ['hide'] ifFalse: ['show']) translated, ' grid' translated 263500 action: #gridVisibleOnOff. 263501 aMenu add: 'set grid spacing...' translated action: #setGridSpec] 263502 ifFalse: [aMenu add: 'turn gridding on' translated action: #griddingOnOff]. 263503 aMenu addLine. 263504 263505 #( (autoLineLayoutString toggleAutoLineLayout 263506 'whether submorphs should automatically be laid out in lines') 263507 (indicateCursorString toggleIndicateCursor 263508 'whether the "current" submorph should be indicated with a dark black border') 263509 (isPartsBinString toggleIsPartsBin 263510 'whether dragging an object from the interior should produce a COPY of the object') 263511 (isOpenForDragNDropString toggleDragNDrop 263512 'whether objects can be dropped into and dragged out of me') 263513 (mouseOverHalosString toggleMouseOverHalos 263514 'whether objects should put up halos when the mouse is over them') 263515 (originAtCenterString toggleOriginAtCenter 263516 'whether the cartesian origin of the playfield should be at its lower-left corner or at the center of the playfield') 263517 ) do: 263518 263519 [:triplet | 263520 (isWorld and: [#(toggleAutoLineLayout toggleIndicateCursor toggleIsPartsBin) includes: triplet second]) ifFalse: 263521 [aMenu addUpdating: triplet first action: triplet second. 263522 aMenu balloonTextForLastItem: triplet third translated]]. 263523 263524 263525 ((isWorld not or: [self backgroundSketch notNil]) or: [presenter isNil]) 263526 ifTrue: 263527 [aMenu addLine]. 263528 263529 self backgroundSketch ifNotNil: 263530 [aMenu add: 'delete background painting' translated action: #deleteBackgroundPainting. 263531 aMenu balloonTextForLastItem: 'delete the graphic that forms the background for this me.' translated]. 263532 aMenu addLine. 263533 aMenu add: 'use standard texture' translated action: #setStandardTexture. 263534 aMenu balloonTextForLastItem: 'use a pale yellow-and-blue background texture here.' translated. 263535 aMenu add: 'make graph paper...' translated action: #makeGraphPaper. 263536 aMenu balloonTextForLastItem: 'Design your own graph paper and use it as the background texture here.' translated. 263537 aMenu addTitle: 'playfield options...' translated. 263538 263539 ^ aMenu 263540! ! 263541 263542!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/12/2000 09:14'! 263543presentPlayfieldMenu 263544 263545 self playfieldOptionsMenu popUpForHand: self activeHand in: self world! ! 263546 263547!PasteUpMorph methodsFor: 'menu & halo' stamp: 'adrian_lienhard 7/19/2009 20:53'! 263548presentViewMenu 263549 "Answer an auxiliary menu with options specific to viewing playfields -- this is put up from the provisional 'view' halo handle, on pasteup morphs only." 263550 263551 | aMenu isWorld | 263552 isWorld := self isWorldMorph. 263553 aMenu := MenuMorph new defaultTarget: self. 263554 aMenu addStayUpItem. 263555 self addViewingItemsTo: aMenu. 263556 263557 #( (indicateCursorString toggleIndicateCursor 263558 'whether the "current" submorph should be indicated with a dark black border') 263559 (resizeToFitString toggleResizeToFit 263560 'whether I should automatically strive exactly to fit my contents') 263561 (behaveLikeAHolderString toggleBehaveLikeAHolder 263562 'whether auto-line-layout, resize-to-fit, and indicate-cursor should be set to true; useful for animation control, etc.') 263563 (isPartsBinString toggleIsPartsBin 263564 'whether dragging an object from the interior should produce a COPY of the object') 263565 (isOpenForDragNDropString toggleDragNDrop 263566 'whether objects can be dropped into and dragged out of me') 263567 (mouseOverHalosString toggleMouseOverHalos 263568 'whether objects should put up halos when the mouse is over them') 263569 (originAtCenterString toggleOriginAtCenter 263570 'whether the cartesian origin of the playfield should be at its lower-left corner or at the center of the playfield') 263571 (griddingString griddingOnOff 263572 'whether gridding should be used in my interior') 263573 (gridVisibleString gridVisibleOnOff 263574 'whether the grid should be shown when gridding is on') 263575 263576 263577 ) do: 263578 263579 [:triplet | 263580 (isWorld and: [#(toggleAutoLineLayout toggleIndicateCursor toggleIsPartsBin) includes: triplet second]) ifFalse: 263581 [aMenu addUpdating: triplet first action: triplet second. 263582 aMenu balloonTextForLastItem: triplet third translated]]. 263583 263584 aMenu addLine. 263585 aMenu add: 'round up strays' translated action: #roundUpStrays. 263586 aMenu balloonTextForLastItem: 'Bring back all objects whose current coordinates keep them from being visible, so that at least a portion of each of my interior objects can be seen.' translated. 263587 aMenu add: 'shuffle contents' translated action: #shuffleSubmorphs. 263588 aMenu balloonTextForLastItem: 'Rearranges my contents in random order' translated. 263589 aMenu add: 'set grid spacing...' translated action: #setGridSpec. 263590 aMenu balloonTextForLastItem: 'Set the spacing to be used when gridding is on' translated. 263591 263592 self backgroundSketch ifNotNil: 263593 [aMenu add: 'delete background painting' translated action: #deleteBackgroundPainting. 263594 aMenu balloonTextForLastItem: 'delete the graphic that forms the background for this me.' translated]. 263595 aMenu addLine. 263596 aMenu add: 'use standard texture' translated action: #setStandardTexture. 263597 aMenu balloonTextForLastItem: 'use a pale yellow-and-blue background texture here.' translated. 263598 aMenu add: 'make graph paper...' translated action: #makeGraphPaper. 263599 aMenu balloonTextForLastItem: 'Design your own graph paper and use it as the background texture here.' translated. 263600 aMenu addTitle: ('viewing options for "{1}"' translated format: {self externalName}). 263601 263602 aMenu popUpForHand: self activeHand in: self world 263603! ! 263604 263605!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 4/23/2001 12:33'! 263606reformulateUpdatingMenus 263607 "Give any updating menu morphs in the receiver a fresh kiss of life" 263608 263609 (self submorphs select: [:m | m isKindOf: UpdatingMenuMorph]) do: 263610 [:m | m updateMenu] 263611 263612 "NB: to do the perfect job here one might well want to extend across allMorphs here, but the expense upon project entry is seemingly too high a price to pay at this point"! ! 263613 263614!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:33'! 263615showApplicationView 263616 263617 self transformToShow: (self valueOfProperty: #applicationViewBounds ifAbsent: [bounds]) 263618 ! ! 263619 263620!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:47'! 263621showExpandedView 263622 263623 owner "the transform" 263624 owner "the green border" 263625 bounds: Display boundingBox! ! 263626 263627!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:33'! 263628showFactoryView 263629 263630 self transformToShow: (self valueOfProperty: #factoryViewBounds ifAbsent: [bounds]) 263631 ! ! 263632 263633!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 7/13/2000 10:17'! 263634showFullView 263635 263636 self transformToShow: bounds 263637 ! ! 263638 263639!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:46'! 263640showReducedView 263641 263642 | r | 263643 r := Display extent // 4 extent: Display extent // 2. 263644 owner "the transform" 263645 owner "the green border" 263646 bounds: r! ! 263647 263648!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:00'! 263649showThumbnailString 263650 "Answer the string to be shown in a menu to represent the 263651 show-thumbnails status" 263652 ^ ((self hasProperty: #alwaysShowThumbnail) 263653 ifTrue: ['<on>'] 263654 ifFalse: ['<off>']), 'show thumbnails' translated! ! 263655 263656!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/20/2004 19:27'! 263657showWorldMainDockingBarString 263658 ^ self project showWorldMainDockingBarString! ! 263659 263660!PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/20/2004 19:27'! 263661toggleShowWorldMainDockingBar 263662 self project toggleShowWorldMainDockingBar! ! 263663 263664!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 19:10'! 263665transformToShow: aRectangle 263666 263667 owner changeWorldBoundsToShow: aRectangle 263668! ! 263669 263670 263671!PasteUpMorph methodsFor: 'misc' stamp: 'sw 7/6/1998 14:19'! 263672alwaysShowThumbnail 263673 ^ self hasProperty: #alwaysShowThumbnail! ! 263674 263675!PasteUpMorph methodsFor: 'misc' stamp: 'di 12/23/1998 14:44'! 263676cachedOrNewThumbnailFrom: newThumbnail 263677 "If I have a cached thumbnail, and it is of the desired extent, then ruturn it. 263678 Otherwise produce one in newThumbnail and return it (after caching). 263679 This code parallels what happens in page: to match resultant extent." 263680 | cachedThumbnail scale ext | 263681 scale := newThumbnail height / self fullBounds height. 263682 ext := (self fullBounds extent * scale) truncated. 263683 (cachedThumbnail := self valueOfProperty: #cachedThumbnail) ifNotNil: 263684 [cachedThumbnail extent = ext ifTrue: [^ cachedThumbnail]]. 263685 self setProperty: #cachedThumbnail toValue: (newThumbnail page: self). 263686 ^ newThumbnail! ! 263687 263688!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/8/1998 16:50'! 263689heightForThumbnails 263690 ^ self valueOfProperty: #heightForThumbnails ifAbsent: [50]! ! 263691 263692!PasteUpMorph methodsFor: 'misc' stamp: 'sw 11/18/2001 18:36'! 263693hideFlapsOtherThan: aFlapTab ifClingingTo: anEdgeSymbol 263694 "Hide flaps on the given edge unless they are the given one" 263695 263696 self flapTabs do: 263697 [:aTab | (aTab edgeToAdhereTo == anEdgeSymbol) 263698 ifTrue: 263699 [aTab == aFlapTab 263700 ifFalse: 263701 [aTab hideFlap]]]! ! 263702 263703!PasteUpMorph methodsFor: 'misc' stamp: 'dgd 8/30/2003 15:52'! 263704innocuousName 263705 ^ (self isFlap) 263706 ifTrue: 263707 ['flap' translated] 263708 ifFalse: 263709 [super innocuousName]! ! 263710 263711!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/8/1998 16:50'! 263712maxHeightToAvoidThumbnailing 263713 ^ self valueOfProperty: #maxHeightToAvoidThumbnailing ifAbsent: [80]! ! 263714 263715!PasteUpMorph methodsFor: 'misc' stamp: 'sw 11/13/1998 10:06'! 263716maximumThumbnailWidth 263717 ^ self valueOfProperty: #maximumThumbnailWidth ifAbsent: [200 min: (self width - 10)]! ! 263718 263719!PasteUpMorph methodsFor: 'misc' stamp: 'sw 8/16/2000 17:42'! 263720nameForCopyIfAlreadyNamed: aMorph 263721 "Answer a name to set for a copy of aMorph if aMorph itself is named, else nil" 263722 263723 | aName usedNames | 263724 ^ (aName := aMorph knownName) ifNotNil: 263725 [usedNames := self allKnownNames. 263726 Utilities keyLike: aName satisfying: [:f | (usedNames includes: f) not]]! ! 263727 263728!PasteUpMorph methodsFor: 'misc' stamp: 'sw 4/23/1998 18:50'! 263729padding: aNumber 263730 padding := aNumber! ! 263731 263732!PasteUpMorph methodsFor: 'misc' stamp: 'sw 1/1/1999 16:04'! 263733unhideHiddenObjects 263734 self allMorphsDo: 263735 [:m | m show]! ! 263736 263737 263738!PasteUpMorph methodsFor: 'model' stamp: 'dgd 2/22/2003 14:09'! 263739createCustomModel 263740 "Create a model object for this world if it does not yet have one. A model object is an initially empty subclass of MorphicModel. As the user names parts and adds behavior, instance variables and methods are added to this class." 263741 263742 model isNil ifFalse: [^self]. 263743 model := MorphicModel newSubclass new! ! 263744 263745!PasteUpMorph methodsFor: 'model' stamp: 'sw 4/1/98 21:18'! 263746model 263747 "Return the model object for this world. If the world has no model, then create one." 263748 263749 self createCustomModel. 263750 ^ model! ! 263751 263752!PasteUpMorph methodsFor: 'model' stamp: 'sw 4/1/98 21:17'! 263753setModel: aModelMorph 263754 "Set the model for this world. Methods for sensitized morphs will be compiled into the class for this model." 263755 263756 model := aModelMorph 263757! ! 263758 263759 263760!PasteUpMorph methodsFor: 'name' stamp: 'sw 6/17/2004 01:46'! 263761unusedMorphNameLike: stem 263762 "Answer a suitable name for a morph in this world, based on the stem provided" 263763 263764 | names | 263765 names := self allKnownNames. 263766 ^ Utilities keyLike: stem asString satisfying: 263767 [:aName | (names includes: aName) not]! ! 263768 263769 263770!PasteUpMorph methodsFor: 'objects from disk' stamp: 'adrian_lienhard 7/27/2009 20:03'! 263771fixUponLoad: aProject seg: anImageSegment 263772 "We are in an old project that is being loaded from disk. 263773Fix up conventions that have changed." 263774 263775 "Project loading obsolete. Remove dependency to sound system" 263776 " 263777 self isWorldMorph ifTrue: [ 263778 (self valueOfProperty: #soundAdditions) ifNotNil: 263779 [:additions | SampledSound 263780assimilateSoundsFrom: additions]]. 263781 " 263782 263783 ^ super fixUponLoad: aProject seg: anImageSegment! ! 263784 263785!PasteUpMorph methodsFor: 'objects from disk' stamp: 'DamienCassou 9/29/2009 13:06'! 263786saveOnFile 263787 "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out." 263788 263789 | aFileName fileStream ok | 263790 263791 self isWorldMorph ifTrue: [^self]. 263792 263793 aFileName := ('my {1}' translated format: {self class name}) asFileName. "do better?" 263794 aFileName := UIManager default request: 'File name? (".project" will be added to end)' translated 263795 initialAnswer: aFileName. 263796 aFileName isEmptyOrNil ifTrue: [^ Beeper beep]. 263797 self allMorphsDo: [:m | m prepareToBeSaved]. 263798 263799 ok := aFileName endsWith: '.project'. "don't double them" 263800 ok := ok | (aFileName endsWith: '.sp'). 263801 ok ifFalse: [aFileName := aFileName,'.project']. 263802 fileStream := FileStream newFileNamed: aFileName asFileName. 263803 fileStream fileOutClass: nil andObject: self. "Puts UniClass definitions out anyway"! ! 263804 263805 263806!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/9/2000 12:48'! 263807autoLineLayout 263808 | layout | 263809 layout := self layoutPolicy ifNil:[^false]. 263810 layout isTableLayout ifFalse:[^false]. 263811 self listDirection == #leftToRight ifFalse:[^false]. 263812 self wrapDirection == #topToBottom ifFalse:[^false]. 263813 ^true! ! 263814 263815!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/9/2000 15:07'! 263816autoLineLayout: aBoolean 263817 "Make the receiver be viewed with auto-line-layout, which means that its submorphs will be laid out left-to-right and then top-to-bottom in the manner of a word processor, or (if aBoolean is false,) cease applying auto-line-layout" 263818 263819 aBoolean ifTrue: 263820 [self viewingNormally ifTrue: [self saveBoundsOfSubmorphs]]. 263821 aBoolean ifTrue:[ 263822 self layoutPolicy: TableLayout new. 263823 self layoutInset: 8; cellInset: 4. 263824 self listDirection: #leftToRight; wrapDirection: #topToBottom. 263825 ] ifFalse:[ 263826 self layoutPolicy: nil. 263827 self layoutInset: 0; cellInset: 0. 263828 ]. 263829! ! 263830 263831!PasteUpMorph methodsFor: 'options' stamp: 'dgd 9/6/2003 17:55'! 263832becomeLikeAHolder 263833 (self autoLineLayout 263834 and: [self indicateCursor]) 263835 ifTrue: [^ self inform: 'This view is ALREADY 263836behaving like a holder, which 263837is to say, it is set to indicate the 263838cursor and to have auto-line-layout.' translated]. 263839 self behaveLikeHolder! ! 263840 263841!PasteUpMorph methodsFor: 'options' stamp: 'dgd 12/13/2003 19:30'! 263842behaveLikeAHolderString 263843 "Answer a string to be displayed in a menu to characterize 263844 whether the receiver is currently behaving like a holder" 263845 ^ (self behavingLikeAHolder 263846 ifTrue: ['<yes>'] 263847 ifFalse: ['<no>']) 263848 , 'behave like a holder' translated! ! 263849 263850!PasteUpMorph methodsFor: 'options' stamp: 'tk 10/30/2001 18:40'! 263851behaveLikeHolder 263852 263853 self vResizeToFit: true; autoLineLayout: true; indicateCursor: true! ! 263854 263855!PasteUpMorph methodsFor: 'options' stamp: 'tk 10/30/2001 18:40'! 263856behaveLikeHolder: aBoolean 263857 "Change the receiver's viewing properties such that they conform to what we commonly call a Holder, viz: resize-to-fit, do auto-line-layout, and indicate the 'cursor'" 263858 263859 self vResizeToFit: aBoolean; autoLineLayout: aBoolean; indicateCursor: aBoolean 263860 ! ! 263861 263862!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/17/2000 12:04'! 263863behavingLikeAHolder 263864 "Answer whether the receiver is currently behaving like a Holder" 263865 263866 ^ self resizeToFit and: [self indicateCursor and: [self autoLineLayout]]! ! 263867 263868!PasteUpMorph methodsFor: 'options' stamp: 'sw 4/1/98 16:58'! 263869indicateCursor 263870 ^ indicateCursor == true! ! 263871 263872!PasteUpMorph methodsFor: 'options' stamp: 'sw 4/1/98 16:59'! 263873indicateCursor: aBoolean 263874 indicateCursor := aBoolean! ! 263875 263876!PasteUpMorph methodsFor: 'options' stamp: 'sw 4/23/1998 16:49'! 263877isPartsBin: aBoolean 263878 isPartsBin := aBoolean! ! 263879 263880!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/9/2000 12:49'! 263881resizeToFit 263882 ^self vResizing == #shrinkWrap! ! 263883 263884!PasteUpMorph methodsFor: 'options' stamp: 'dgd 12/13/2003 19:30'! 263885resizeToFitString 263886 "Answer a string, to be used in a self-updating menu, to 263887 represent whether the receiver is currently using resize-to-fit 263888 or not" 263889 ^ (self resizeToFit 263890 ifTrue: ['<yes>'] 263891 ifFalse: ['<no>']) 263892 , 'resize to fit' translated! ! 263893 263894!PasteUpMorph methodsFor: 'options' stamp: 'panda 4/25/2000 15:42'! 263895setPartsBinStatusTo: aBoolean 263896 isPartsBin := aBoolean. 263897 aBoolean ifFalse: [self enableDragNDrop]. 263898 "but note that we no longer reset openToDragNDrop to false upon making it a parts bin again" 263899 isPartsBin 263900 ifTrue: 263901 [submorphs do: 263902 [:m | m isPartsDonor: true. 263903 m stopStepping. 263904 m suspendEventHandler]] 263905 ifFalse: 263906 [submorphs do: 263907 [:m | m isPartsDonor: false. 263908 m restoreSuspendedEventHandler]. 263909 self world ifNotNil: [self world startSteppingSubmorphsOf: self]]! ! 263910 263911!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/8/2000 22:37'! 263912toggleAutoLineLayout 263913 "Toggle the auto-line-layout setting" 263914 263915 self autoLineLayout: self autoLineLayout not. 263916 self autoLineLayout ifFalse: [self restoreBoundsOfSubmorphs].! ! 263917 263918!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/23/2000 19:04'! 263919toggleBehaveLikeAHolder 263920 "Toggle whether or not the receiver is currently behaving like a holder" 263921 263922 self behaveLikeHolder: (self behavingLikeAHolder not)! ! 263923 263924!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/8/2000 22:37'! 263925toggleIndicateCursor 263926 indicateCursor := self indicateCursor not. 263927 self changed.! ! 263928 263929!PasteUpMorph methodsFor: 'options' stamp: 'sw 9/30/1998 17:24'! 263930toggleIsPartsBin 263931 "Not entirely happy with the openToDragNDrop not being directly manipulable etc, but still living with it for now." 263932 self setPartsBinStatusTo: self isPartsBin not! ! 263933 263934!PasteUpMorph methodsFor: 'options' stamp: 'sw 1/27/2000 14:51'! 263935toggleMouseOverHalos 263936 wantsMouseOverHalos := self wantsMouseOverHalos not! ! 263937 263938!PasteUpMorph methodsFor: 'options' stamp: 'sw 7/6/1999 13:36'! 263939toggleOriginAtCenter 263940 | hasIt | 263941 hasIt := self hasProperty: #originAtCenter. 263942 hasIt 263943 ifTrue: 263944 [self removeProperty: #originAtCenter] 263945 ifFalse: 263946 [self setProperty: #originAtCenter toValue: true]! ! 263947 263948!PasteUpMorph methodsFor: 'options' stamp: 'tk 10/30/2001 18:41'! 263949toggleResizeToFit 263950 "Toggle whether the receiver is set to resize-to-fit" 263951 263952 self vResizeToFit: self resizeToFit not! ! 263953 263954!PasteUpMorph methodsFor: 'options' stamp: 'sw 6/5/1998 18:13'! 263955wantsMouseOverHalos 263956 ^ wantsMouseOverHalos == true! ! 263957 263958!PasteUpMorph methodsFor: 'options' stamp: 'sw 6/5/1998 18:13'! 263959wantsMouseOverHalos: aBoolean 263960 wantsMouseOverHalos := aBoolean! ! 263961 263962 263963!PasteUpMorph methodsFor: 'painting' stamp: 'bf 10/2/2002 18:36'! 263964backgroundForm 263965 263966 ^ self backgroundSketch 263967 ifNil: [Form extent: self extent depth: Display depth] 263968 ifNotNil: [backgroundMorph form]! ! 263969 263970!PasteUpMorph methodsFor: 'painting' stamp: 'bf 10/2/2002 17:07'! 263971backgroundSketch 263972 263973 backgroundMorph ifNil: [^ nil]. 263974 backgroundMorph owner == self ifFalse: 263975 [backgroundMorph := nil]. "has been deleted" 263976 ^ backgroundMorph! ! 263977 263978!PasteUpMorph methodsFor: 'painting' stamp: 'sw 6/16/1999 11:16'! 263979deleteBackgroundPainting 263980 backgroundMorph 263981 ifNotNil: 263982 [backgroundMorph delete. 263983 backgroundMorph := nil] 263984 ifNil: 263985 [self inform: 'There is presently no 263986background painting 263987to delete.']! ! 263988 263989!PasteUpMorph methodsFor: 'painting' stamp: 'Henrik Sperre Johansen 5/19/2009 21:59'! 263990drawSubmorphsOn: aCanvas 263991 "Display submorphs back to front, but skip my background sketch." 263992 263993 | drawBlock | 263994 submorphs isEmpty ifTrue: [^self]. 263995 drawBlock := [:canvas | submorphs reverseDo: [:m | m ~~ backgroundMorph ifTrue: [ canvas fullDrawMorph: m ]]]. 263996 self clipSubmorphs 263997 ifTrue: [aCanvas clipBy: (aCanvas clipRect intersect: self clippingBounds) during: drawBlock] 263998 ifFalse: [drawBlock value: aCanvas]! ! 263999 264000!PasteUpMorph methodsFor: 'painting' stamp: 'sw 9/22/1998 12:26'! 264001paintingBoundsAround: aPoint 264002 "Return a rectangle for painting centered on the given point. Both the argument point and the result rectangle are in world coordinates." 264003 264004 | paintExtent maxPaintArea myBnds | 264005 paintExtent := self reasonablePaintingExtent. 264006 maxPaintArea := paintExtent x * paintExtent y. 264007 myBnds := self boundsInWorld. 264008 (myBnds area <= maxPaintArea) ifTrue: [^ myBnds]. 264009 ^ (aPoint - (paintExtent // 2) extent: paintExtent) intersect: myBnds 264010! ! 264011 264012!PasteUpMorph methodsFor: 'painting' stamp: 'sd 11/9/2008 13:58'! 264013prepareToPaint 264014 "We're about to start painting. Do a few preparations that make the system more responsive." 264015 264016 ^ self prepareToPaint: false! ! 264017 264018!PasteUpMorph methodsFor: 'painting' stamp: 'sd 11/9/2008 14:36'! 264019prepareToPaint: stopRunningScripts 264020 "We're about to start painting. Do a few preparations that make the system more responsive." 264021 264022 self abandonAllHalos. "no more halos"! ! 264023 264024!PasteUpMorph methodsFor: 'painting' stamp: 'sw 9/29/1998 07:35'! 264025reasonablePaintingExtent 264026 ^ Preferences unlimitedPaintArea 264027 ifTrue: 264028 [3000 @ 3000] 264029 ifFalse: 264030 [Preferences defaultPaintingExtent]! ! 264031 264032 264033!PasteUpMorph methodsFor: 'parts bin' stamp: 'sw 8/2/2001 17:50'! 264034initializeToStandAlone 264035 "Answer an instance of the receiver suitable for placing in a parts bin for authors" 264036 264037 self initialize. 264038 self color: Color green muchLighter; extent: 100 @ 80; borderColor: (Color r: 0.645 g: 0.935 b: 0.161). 264039 self extent: 300 @ 240. 264040 self beSticky! ! 264041 264042!PasteUpMorph methodsFor: 'parts bin' stamp: 'sw 4/13/1998 18:15'! 264043isPartsBin 264044 ^ isPartsBin == true! ! 264045 264046 264047!PasteUpMorph methodsFor: 'printing' stamp: 'sw 10/18/2000 10:54'! 264048printOn: aStream 264049 "Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is" 264050 264051 super printOn: aStream. 264052 self isWorldMorph ifTrue: [aStream nextPutAll: ' [world]']! ! 264053 264054 264055!PasteUpMorph methodsFor: 'project' stamp: 'tk 9/3/1999 12:07'! 264056project 264057 "Find the project that owns me. Not efficient to call this." 264058 264059 ^ Project ofWorld: self! ! 264060 264061 264062!PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! 264063canvas 264064 264065 ^ worldState canvas! ! 264066 264067!PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! 264068firstHand 264069 264070 ^ worldState hands first! ! 264071 264072!PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! 264073hands 264074 264075 ^ worldState hands! ! 264076 264077!PasteUpMorph methodsFor: 'project state' stamp: 'nk 7/4/2003 16:47'! 264078handsDo: aBlock 264079 264080 ^ worldState ifNotNil: [ worldState handsDo: aBlock ]! ! 264081 264082!PasteUpMorph methodsFor: 'project state' stamp: 'nk 7/4/2003 16:46'! 264083handsReverseDo: aBlock 264084 264085 ^ worldState ifNotNil: [ worldState handsReverseDo: aBlock ]! ! 264086 264087!PasteUpMorph methodsFor: 'project state' stamp: 'sw 10/9/1999 22:51'! 264088isStepping: aMorph 264089 ^ worldState isStepping: aMorph! ! 264090 264091!PasteUpMorph methodsFor: 'project state' stamp: 'ar 10/22/2000 16:43'! 264092isStepping: aMorph selector: aSelector 264093 ^ worldState isStepping: aMorph selector: aSelector! ! 264094 264095!PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 06:45'! 264096listOfSteppingMorphs 264097 ^ worldState listOfSteppingMorphs 264098 264099"self currentWorld listOfSteppingMorphs"! ! 264100 264101!PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 09:56'! 264102stepListSize 264103 ^ worldState stepListSize 264104 264105"Transcript cr; show: self currentWorld stepListSize printString, ' items on steplist as of ', Date dateAndTimeNow printString"! ! 264106 264107!PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 09:56'! 264108stepListSummary 264109 ^ worldState stepListSummary 264110 264111"Transcript cr show: self currentWorld stepListSummary"! ! 264112 264113!PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 09:59'! 264114steppingMorphsNotInWorld 264115 | all | 264116 all := self allMorphs. 264117 ^ self listOfSteppingMorphs select: [:m | (all includes: m) not] 264118 264119 "self currentWorld steppingMorphsNotInWorld do: [:m | m delete]"! ! 264120 264121!PasteUpMorph methodsFor: 'project state' stamp: 'dgd 9/27/2004 11:45'! 264122viewBox 264123 "This tortured workaround arises from a situation encountered 264124 in which a PasteUpMorph was directliy lodged as a submorph 264125 of another PasteUpMorph of identical size, with the former 264126 bearing flaps but the latter being the world" 264127 ^ worldState 264128 ifNil: [super viewBox] 264129 ifNotNil: [worldState viewBox]! ! 264130 264131!PasteUpMorph methodsFor: 'project state' stamp: 'dgd 2/22/2003 14:12'! 264132viewBox: newViewBox 264133 "I am now displayed within newViewBox; react." 264134 264135 self isWorldMorph 264136 ifTrue: 264137 [(self viewBox isNil or: [self viewBox extent ~= newViewBox extent]) 264138 ifTrue: [worldState canvas: nil]. 264139 worldState viewBox: newViewBox]. 264140 super position: newViewBox topLeft. 264141 fullBounds := bounds := newViewBox. 264142 264143 "Paragraph problem workaround; clear selections to avoid screen 264144droppings." 264145 self flag: #arNote. "Probably unnecessary" 264146 self isWorldMorph 264147 ifTrue: 264148 [worldState handsDo: [:hand | hand releaseKeyboardFocus]. 264149 self fullRepaintNeeded]! ! 264150 264151 264152!PasteUpMorph methodsFor: 'scripting' stamp: 'ar 3/17/2001 20:12'! 264153adaptedToWorld: aWorld 264154 "If I refer to a world or a hand, return the corresponding items in the new world." 264155 self isWorldMorph ifTrue:[^aWorld].! ! 264156 264157!PasteUpMorph methodsFor: 'scripting' stamp: 'sw 2/18/2003 01:46'! 264158getCharacters 264159 "obtain a string value from the receiver" 264160 264161 ^ String streamContents: 264162 [:aStream | 264163 submorphs do: 264164 [:m | aStream nextPutAll: m getCharacters]]! ! 264165 264166 264167!PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 5/24/2000 11:10'! 264168cleanseStepList 264169 "Remove morphs from the step list that are not in this World. Often were in a flap that has moved on to another world." 264170 264171 worldState cleanseStepListForWorld: self! ! 264172 264173!PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 6/7/2000 10:12'! 264174runLocalStepMethods 264175 264176 worldState runLocalStepMethodsIn: self 264177! ! 264178 264179!PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 5/24/2000 10:27'! 264180runStepMethods 264181 264182 worldState runStepMethodsIn: self 264183! ! 264184 264185!PasteUpMorph methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:39'! 264186startStepping: aMorph 264187 "Add the given morph to the step list. Do nothing if it is already being stepped." 264188 ^self startStepping: aMorph at: Time millisecondClockValue selector: #stepAt: arguments: nil stepTime: nil! ! 264189 264190!PasteUpMorph methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:36'! 264191startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime 264192 worldState startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime.! ! 264193 264194!PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 5/24/2000 11:08'! 264195stopStepping: aMorph 264196 "Remove the given morph from the step list." 264197 264198 worldState stopStepping: aMorph 264199! ! 264200 264201!PasteUpMorph methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:40'! 264202stopStepping: aMorph selector: aSelector 264203 "Remove the given morph from the step list." 264204 264205 worldState stopStepping: aMorph selector: aSelector 264206! ! 264207 264208 264209!PasteUpMorph methodsFor: 'stepping and presenter' stamp: 'RAA 8/14/2000 11:50'! 264210step 264211 264212 (self isWorldMorph and: [owner notNil]) ifTrue: [ 264213 ^self runLocalStepMethods 264214 ]. 264215 super step! ! 264216 264217 264218!PasteUpMorph methodsFor: 'structure' stamp: 'di 7/27/1999 10:46'! 264219activeHand 264220 264221 ^ worldState ifNotNil: [worldState activeHand] ifNil: [super activeHand]! ! 264222 264223!PasteUpMorph methodsFor: 'structure' stamp: 'dgd 2/22/2003 14:12'! 264224world 264225 worldState isNil ifTrue: [^super world]. 264226 ^self! ! 264227 264228 264229!PasteUpMorph methodsFor: 'submorphs-accessing' stamp: 'RAA 5/24/2000 12:09'! 264230allMorphsDo: aBlock 264231 "Enumerate all morphs in the world, including those held in hands." 264232 264233 super allMorphsDo: aBlock. 264234 self isWorldMorph 264235 ifTrue: [worldState handsReverseDo: [:h | h allMorphsDo: aBlock]]. 264236! ! 264237 264238!PasteUpMorph methodsFor: 'submorphs-accessing' stamp: 'nk 7/4/2003 16:49'! 264239morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock 264240 "Include hands if the receiver is the World" 264241 self handsDo:[:m| 264242 m == someMorph ifTrue:["Try getting out quickly" 264243 owner ifNil:[^self]. 264244 ^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock]. 264245 "The hand only overlaps if it's not the hardware cursor" 264246 m needsToBeDrawn ifTrue:[ 264247 (m fullBoundsInWorld intersects: aRectangle) 264248 ifTrue:[aBlock value: m]]]. 264249 ^super morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock! ! 264250 264251 264252!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'di 7/15/1999 09:51'! 264253addAllMorphs: array 264254 264255 super addAllMorphs: array. 264256 self isWorldMorph 264257 ifTrue: [array do: [:m | self startSteppingSubmorphsOf: m]]. 264258! ! 264259 264260!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'RAA 12/16/2000 18:37'! 264261addMorphFront: aMorph 264262 264263 ^self addMorphInFrontOfLayer: aMorph 264264! ! 264265 264266 264267!PasteUpMorph methodsFor: 'testing' stamp: 'wiz 2/25/2006 00:09'! 264268isEasySelecting 264269"This is to isolate easySelection predicate. 264270Selectors in holders make no sense so we are limiting easy selection to the worldMorph. 264271It would also make sense in playfield so feel free to adjust this predicate. Selection can always be forced by using the shift before mouse down." 264272 264273^ self isWorldMorph and: [ Preferences easySelection ]! ! 264274 264275!PasteUpMorph methodsFor: 'testing' stamp: 'RAA 8/14/2000 11:50'! 264276stepTime 264277 264278 (self isWorldMorph and: [owner notNil]) ifTrue: [ 264279 ^1 264280 ]. 264281 ^super stepTime! ! 264282 264283 264284!PasteUpMorph methodsFor: 'thumbnail' stamp: 'dgd 9/22/2004 19:37'! 264285icon 264286 "Answer a form with an icon to represent the receiver" 264287 ^ self isWorldMorph 264288 ifTrue: [MenuIcons homeIcon] 264289 ifFalse: [MenuIcons projectIcon]! ! 264290 264291 264292!PasteUpMorph methodsFor: 'undo' stamp: 'RAA 9/21/2000 20:07'! 264293clearCommandHistory 264294 264295 worldState ifNotNil: [worldState clearCommandHistory]! ! 264296 264297!PasteUpMorph methodsFor: 'undo' stamp: 'ar 8/31/2000 23:16'! 264298commandHistory 264299 "Return the command history for the receiver" 264300 ^self isWorldMorph 264301 ifTrue:[worldState commandHistory] 264302 ifFalse:[super commandHistory]! ! 264303 264304!PasteUpMorph methodsFor: 'undo' stamp: 'adrian_lienhard 7/19/2009 17:35'! 264305onceAgainDismiss: aMorph 264306 "Occasioned by a redo of a dismiss-via-halo" 264307 264308 aMorph dismissMorph. 264309 Preferences preserveTrash ifTrue: 264310 [Preferences slideDismissalsToTrash 264311 ifTrue:[aMorph slideToTrash: nil]] 264312! ! 264313 264314!PasteUpMorph methodsFor: 'undo' stamp: 'marcus.denker 11/10/2008 10:04'! 264315reintroduceIntoWorld: aMorph 264316 "The given morph is being raised from the dead. Bring it back to life." 264317 264318 (aMorph valueOfProperty: #lastPosition) ifNotNil: 264319 [:pos | aMorph position: pos]. 264320 aMorph openInWorld; goHome 264321 264322 ! ! 264323 264324 264325!PasteUpMorph methodsFor: 'user interface' stamp: 'dgd 2/22/2003 14:11'! 264326modelWakeUp 264327 "I am the model of a SystemWindow, that has just been activated" 264328 264329 | aWindow | 264330 owner isNil ifTrue: [^self]. "Not in Morphic world" 264331 (owner isKindOf: TransformMorph) ifTrue: [^self viewBox: self fullBounds]. 264332 (aWindow := self containingWindow) ifNotNil: 264333 [self viewBox = aWindow panelRect 264334 ifFalse: [self viewBox: aWindow panelRect]]! ! 264335 264336 264337!PasteUpMorph methodsFor: 'viewer' stamp: 'sw 1/25/2000 13:34'! 264338defaultNameStemForInstances 264339 "Answer a basis for names of default instances of the receiver" 264340 ^ self isWorldMorph 264341 ifFalse: 264342 [super defaultNameStemForInstances] 264343 ifTrue: 264344 ['world']! ! 264345 264346 264347!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/5/2000 06:42'! 264348restoreBoundsOfSubmorphs 264349 "restores the saved xy-positions and extents" 264350 264351 submorphs do: 264352 [:aSubmorph | 264353 aSubmorph valueOfProperty: #savedExtent ifPresentDo: 264354 [:anExtent | aSubmorph extent: anExtent]. 264355 aSubmorph valueOfProperty: #savedPosition ifPresentDo: 264356 [:aPosition | aSubmorph position: aPosition]]! ! 264357 264358!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/18/2000 10:59'! 264359saveBoundsOfSubmorphs 264360 "store the current xy-positions and extents of submorphs for future use" 264361 264362 submorphs do: 264363 [:aSubmorph | 264364 aSubmorph setProperty: #savedExtent toValue: aSubmorph extent. 264365 aSubmorph setProperty: #savedPosition toValue: aSubmorph position]! ! 264366 264367!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/23/2000 19:01'! 264368showingListView 264369 "Answer whether the receiver is currently showing a list view" 264370 264371 ^ self hasProperty: #showingListView 264372! ! 264373 264374!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/12/2000 22:37'! 264375sortSubmorphsBy: sortOrderSymbol 264376 "Sort the receiver's submorphs by the criterion indicated in the provided symbol" 264377 self invalidRect: self fullBounds. 264378 submorphs := submorphs sortBy:[:a :b | (a perform: sortOrderSymbol) <= (b perform: sortOrderSymbol)]. 264379 self layoutChanged.! ! 264380 264381!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/9/2000 13:50'! 264382viewByIcon 264383 "The receiver has been being viewed in some constrained layout view; now restore it to its normal x-y-layout view" 264384 264385 | oldSubs | 264386 self showingListView 264387 ifTrue: 264388 [oldSubs := submorphs. 264389 self removeAllMorphs. 264390 self layoutPolicy: nil. 264391 oldSubs do: 264392 [:aSubmorph | 264393 self addMorphBack: aSubmorph objectRepresented]. 264394 self restoreBoundsOfSubmorphs. 264395 self removeProperty: #showingListView] 264396 ifFalse: 264397 [self autoLineLayout == true ifTrue: [self toggleAutoLineLayout]]! ! 264398 264399!PasteUpMorph methodsFor: 'viewing' stamp: 'dgd 9/6/2003 17:50'! 264400viewingByIconString 264401 "Answer a string to show in a menu representing whether the 264402 receiver is currently viewing its subparts by icon or not" 264403 ^ ((self showingListView 264404 or: [self autoLineLayout == true]) 264405 ifTrue: ['<no>'] 264406 ifFalse: ['<yes>']), 'view by icon' translated! ! 264407 264408!PasteUpMorph methodsFor: 'viewing' stamp: 'dgd 9/6/2003 17:50'! 264409viewingBySizeString 264410 "Answer a string to show in a menu representing whether the 264411 receiver is currently viewing its subparts by size or not" 264412 ^ ((self showingListView 264413 and: [(self 264414 valueOfProperty: #sortOrder 264415 ifAbsent: []) 264416 == #reportableSize]) 264417 ifTrue: ['<yes>'] 264418 ifFalse: ['<no>']), 'view by size' translated! ! 264419 264420!PasteUpMorph methodsFor: 'viewing' stamp: 'dgd 9/6/2003 17:51'! 264421viewingNonOverlappingString 264422 "Answer a string to show in a menu representing whether the 264423 receiver is currently viewing its subparts by 264424 non-overlapping-icon (aka auto-line-layout)" 264425 ^ ((self showingListView 264426 or: [self autoLineLayout ~~ true]) 264427 ifTrue: ['<no>'] 264428 ifFalse: ['<yes>']), 'view with line layout' translated! ! 264429 264430!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/8/2000 18:13'! 264431viewingNormally 264432 "Answer whether the receiver is being viewed normally, viz not in list-view or auto-line-layout" 264433 264434 ^ (self showingListView or: [self autoLineLayout == true]) not 264435! ! 264436 264437!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/8/2000 22:37'! 264438viewNonOverlapping 264439 "Make the receiver show its contents as full-size morphs laid out left-to-right and top-to-bottom to be non-overlapping." 264440 264441 self viewingNormally ifTrue: 264442 [self saveBoundsOfSubmorphs]. 264443 self showingListView ifTrue: 264444 [self viewByIcon. 264445 self removeProperty: #showingListView]. 264446 self autoLineLayout: true.! ! 264447 264448 264449!PasteUpMorph methodsFor: 'visual properties' stamp: 'bf 5/4/2000 15:27'! 264450canHaveFillStyles 264451 "Return true if the receiver can have general fill styles; not just colors. 264452 This method is for gradually converting old morphs." 264453 ^ true! ! 264454 264455 264456!PasteUpMorph methodsFor: 'wiw support' stamp: 'dgd 8/31/2004 16:25'! 264457addMorphInLayer: aMorph 264458 super addMorphInLayer: aMorph. 264459 aMorph wantsToBeTopmost ifFalse:[self bringTopmostsToFront].! ! 264460 264461!PasteUpMorph methodsFor: 'wiw support' stamp: 'RAA 10/3/2000 09:24'! 264462morphicLayerNumber 264463 264464 self isFlap ifTrue:[^26]. "As navigators" 264465 ^super morphicLayerNumber.! ! 264466 264467!PasteUpMorph methodsFor: 'wiw support' stamp: 'dao 10/1/2004 13:39'! 264468restartWorldCycleWithEvent: evt 264469 264470 "RAA 27 Nov 99 - redispatch that click picked up from our inner world" 264471 evt ifNotNil: [ 264472 self primaryHand handleEvent: (evt setHand: self primaryHand). 264473 ]. 264474 Project spawnNewProcessAndTerminateOld: true 264475! ! 264476 264477!PasteUpMorph methodsFor: 'wiw support' stamp: 'RAA 8/14/2000 12:10'! 264478shouldGetStepsFrom: aWorld 264479 264480 (self isWorldMorph and: [owner notNil]) ifTrue: [ 264481 ^self outermostWorldMorph == aWorld 264482 ]. 264483 ^super shouldGetStepsFrom: aWorld! ! 264484 264485!PasteUpMorph methodsFor: 'wiw support' stamp: 'RAA 11/14/1999 15:07'! 264486validateMouseEvent: evt 264487 264488 ! ! 264489 264490 264491!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 18:34'! 264492addUndoItemsTo: aWorldMenu 264493 "Add undo-related items to the given menu. Will add zero, one or two items, depending on the settings of the #useUndo and #infiniteUndo preferences" 264494 264495 Preferences useUndo ifFalse: [^ self]. 264496 Preferences infiniteUndo 264497 ifFalse: 264498 [aWorldMenu addUpdating: #undoOrRedoMenuWording target: self commandHistory action: #undoOrRedoCommand] 264499 ifTrue: 264500 [aWorldMenu addUpdating: #undoMenuWording target: self commandHistory action: #undoLastCommand. 264501 aWorldMenu addUpdating: #redoMenuWording target: self commandHistory action: #redoNextCommand. 264502 self flag: #deferred. "The following feature to be unblocked in due course" 264503 "aWorldMenu add: 'undo to...' target: self commandHistory action: #undoTo"]. 264504 aWorldMenu addLine! ! 264505 264506!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 18:27'! 264507buildWorldMenu: evt 264508 ^(TheWorldMenu new 264509 world: self 264510 project: (self project ifNil: [Project current]) "mvc??" 264511 hand: evt hand) buildWorldMenu.! ! 264512 264513!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:27'! 264514collapseNonWindows 264515 self allNonFlapRelatedSubmorphs do: 264516 [:m | m collapse]! ! 264517 264518!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 13:52'! 264519commandKeySelectors 264520 "Answer my command-key table" 264521 264522 | aDict | 264523 aDict := self valueOfProperty: #commandKeySelectors ifAbsentPut: [self initializeDesktopCommandKeySelectors]. 264524 ^ aDict! ! 264525 264526!PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 9/11/2004 20:45'! 264527delayedInvokeWorldMenu: evt 264528 self 264529 addAlarm: #invokeWorldMenu: 264530 with: evt 264531 after: 200! ! 264532 264533!PasteUpMorph methodsFor: 'world menu' stamp: 'alain.plantec 2/6/2009 17:17'! 264534deleteNonWindows 264535 (self confirm: 264536'Do you really want to discard all objects 264537that are not in windows?' translated) 264538 ifFalse: [^ self]. 264539 264540 self allNonFlapRelatedSubmorphs do: 264541 [:m | m delete]! ! 264542 264543!PasteUpMorph methodsFor: 'world menu' stamp: 'DamienCassou 9/23/2009 08:52'! 264544disconnectRemoteUser 264545 "Prompt for the initials of the remote user, then remove the remote hand with those initials, breaking its connection." 264546 264547 "select hand to remove" 264548 | initials handToRemove | 264549 initials := UIManager default request: 'Enter initials for remote user''s cursor?' translated. 264550 initials isEmptyOrNil ifTrue: [^ self]. "abort" 264551 handToRemove := nil. 264552 self handsDo: [:h | 264553 h userInitials = initials ifTrue: [handToRemove := h]]. 264554 handToRemove ifNil: [^ self]. "no hand with those initials" 264555 handToRemove withdrawFromWorld. 264556! ! 264557 264558!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 12:19'! 264559dispatchCommandKeyInWorld: aChar event: evt 264560 "Dispatch the desktop command key if possible. Answer whether handled" 264561 264562 | aMessageSend | 264563 aMessageSend := self commandKeySelectors at: aChar ifAbsent: [^ false]. 264564 aMessageSend selector numArgs = 0 264565 ifTrue: 264566 [aMessageSend value] 264567 ifFalse: 264568 [aMessageSend valueWithArguments: (Array with: evt)]. 264569 ^ true 264570! ! 264571 264572!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 19:11'! 264573drawingClass 264574 264575 ^ SketchMorph! ! 264576 264577!PasteUpMorph methodsFor: 'world menu' stamp: 'nk 1/6/2004 12:38'! 264578extractScreenRegion: poly andPutSketchInHand: hand 264579 "The user has specified a polygonal area of the Display. 264580 Now capture the pixels from that region, and put in the hand as a Sketch." 264581 | screenForm outline topLeft innerForm exterior | 264582 outline := poly shadowForm. 264583 topLeft := outline offset. 264584 exterior := (outline offset: 0@0) anyShapeFill reverse. 264585 screenForm := Form fromDisplay: (topLeft extent: outline extent). 264586 screenForm eraseShape: exterior. 264587 innerForm := screenForm trimBordersOfColor: Color transparent. 264588 innerForm isAllWhite ifFalse: 264589 [hand attachMorph: (self drawingClass withForm: innerForm)]! ! 264590 264591!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/23/2002 13:47'! 264592findAChangeSorter: evt 264593 "Locate a change sorter, open it, and bring it to the front. Create one if necessary" 264594 264595 self findAWindowSatisfying: 264596 [:aWindow | (aWindow model isMemberOf: ChangeSorter) or: 264597 [aWindow model isKindOf: DualChangeSorter]] orMakeOneUsing: [DualChangeSorter new morphicWindow]! ! 264598 264599!PasteUpMorph methodsFor: 'world menu' stamp: 'hfm 11/29/2008 20:05'! 264600findAFileList: evt 264601 "Locate a file list, open it, and bring it to the front. 264602 Create one if necessary, respecting the Preference." 264603 264604 self 264605 findAWindowSatisfying: [:aWindow | aWindow model isKindOf: FileList] 264606 orMakeOneUsing: [FileList prototypicalToolWindow] 264607! ! 264608 264609!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/23/2002 13:53'! 264610findAMessageNamesWindow: evt 264611 "Locate a MessageNames tool, open it, and bring it to the front. Create one if necessary" 264612 264613 self findAWindowSatisfying: 264614 [:aWindow | aWindow model isKindOf: MessageNames] orMakeOneUsing: [MessageNames new inMorphicWindowLabeled: 'Message Names']! ! 264615 264616!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/22/2002 08:54'! 264617findATranscript: evt 264618 "Locate a transcript, open it, and bring it to the front. Create one if necessary" 264619 264620 self findAWindowSatisfying: 264621 [:aWindow | aWindow model == Transcript] orMakeOneUsing: [Transcript openAsMorphLabel: 'Transcript']! ! 264622 264623!PasteUpMorph methodsFor: 'world menu' stamp: 'gm 2/16/2003 20:35'! 264624findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock 264625 "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock" 264626 264627 | aWindow | 264628 submorphs do: 264629 [:aMorph | 264630 (((aWindow := aMorph renderedMorph) isSystemWindow) 264631 and: [qualifyingBlock value: aWindow]) 264632 ifTrue: 264633 [aWindow isCollapsed ifTrue: [aWindow expand]. 264634 aWindow activateAndForceLabelToShow. 264635 ^self]]. 264636 "None found, so create one" 264637 makeBlock value openInWorld! ! 264638 264639!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 19:09'! 264640getWorldMenu: aSymbol 264641 ^(TheWorldMenu new 264642 world: self 264643 project: (self project ifNil: [Project current]) "mvc??" 264644 hand: self primaryHand) perform: aSymbol! ! 264645 264646!PasteUpMorph methodsFor: 'world menu' stamp: 'di 10/18/2001 03:33'! 264647grabDrawingFromScreen: evt 264648 "Allow the user to specify a rectangular area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand." 264649 | m | 264650 m := self drawingClass new form: Form fromUser. 264651 evt hand position: Sensor cursorPoint. "update hand pos after Sensor loop in fromUser" 264652 evt hand attachMorph: m.! ! 264653 264654!PasteUpMorph methodsFor: 'world menu' stamp: 'alain.plantec 2/6/2009 11:40'! 264655grabFloodFromScreen: evt 264656 "Allow the user to plant a flood seed on the Display, and create a new drawing morph from the resulting region. Attach the result to the hand." 264657 | screenForm exterior p1 box | 264658 Cursor crossHair showWhile: [p1 := Sensor waitButton]. 264659 box := Display floodFill: Color transparent at: p1. 264660 exterior := ((Display copy: box) makeBWForm: Color transparent) reverse. 264661 self world invalidRect: box; displayWorldSafely. 264662 (box area > (Display boundingBox area // 2)) 264663 ifTrue: [^ self inform: 'Sorry, the region was too big']. 264664 (exterior deepCopy reverse anyShapeFill reverse) "save interior bits" 264665 displayOn: exterior at: 0@0 rule: Form and. 264666 screenForm := Form fromDisplay: box. 264667 screenForm eraseShape: exterior. 264668 screenForm isAllWhite ifFalse: 264669 [evt hand attachMorph: (self drawingClass withForm: screenForm)]! ! 264670 264671!PasteUpMorph methodsFor: 'world menu' stamp: 'di 10/18/2001 02:58'! 264672grabLassoFromScreen: evt 264673 "Allow the user to specify a polygonal area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand." 264674 264675 self extractScreenRegion: (PolygonMorph fromHandFreehand: evt hand) 264676 andPutSketchInHand: evt hand 264677! ! 264678 264679!PasteUpMorph methodsFor: 'world menu' stamp: 'di 10/18/2001 01:13'! 264680grabRubberBandFromScreen: evt 264681 "Allow the user to specify a polygonal area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand." 264682 264683 self extractScreenRegion: (PolygonMorph fromHand: evt hand) 264684 andPutSketchInHand: evt hand! ! 264685 264686!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 13:52'! 264687initializeDesktopCommandKeySelectors 264688 "Provide the starting settings for desktop command key selectors. Answer the dictionary." 264689 264690 "ActiveWorld initializeDesktopCommandKeySelectors" 264691 | dict messageSend | 264692 dict := IdentityDictionary new. 264693 self defaultDesktopCommandKeyTriplets do: 264694 [:trip | 264695 messageSend := MessageSend receiver: trip second selector: trip third. 264696 dict at: trip first put: messageSend]. 264697 self setProperty: #commandKeySelectors toValue: dict. 264698 ^ dict 264699 264700! ! 264701 264702!PasteUpMorph methodsFor: 'world menu' stamp: 'stephane.ducasse 10/26/2008 15:35'! 264703invokeWorldMenu: evt 264704 "Put up the world menu, triggered by the passed-in event." 264705 264706 self putUpWorldMenu: evt! ! 264707 264708!PasteUpMorph methodsFor: 'world menu' stamp: 'tbn 11/4/2008 09:15'! 264709keyboardNavigationHandler 264710 "Answer the receiver's existing keyboardNavigationHandler, or nil if none." 264711 264712 | aHandler | 264713 aHandler := self valueOfProperty: #keyboardNavigationHandler ifAbsent: [^ nil]. 264714 (aHandler hasProperty: #moribund) ifTrue: "got clobbered in another project" 264715 [self removeProperty: #keyboardNavigationHandler. 264716 ^ nil]. 264717 ^ aHandler! ! 264718 264719!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/18/2003 23:10'! 264720keyboardNavigationHandler: aHandler 264721 "Set the receiver's keyboard navigation handler as indicated. A nil argument means to remove the handler" 264722 264723 aHandler 264724 ifNil: 264725 [self removeProperty: #keyboardNavigationHandler] 264726 ifNotNil: 264727 [self setProperty: #keyboardNavigationHandler toValue: aHandler]! ! 264728 264729!PasteUpMorph methodsFor: 'world menu' stamp: 'stephane.ducasse 10/26/2008 15:35'! 264730keystrokeInWorld: evt 264731 "A keystroke was hit when no keyboard focus was set, so it is sent here to the world instead." 264732 264733 | aChar isCmd ascii | 264734 aChar := evt keyCharacter. 264735 (ascii := aChar asciiValue) = 27 ifTrue: "escape key" 264736 [^ self putUpWorldMenuFromEscapeKey]. 264737 (evt controlKeyPressed not 264738 and: [(#(1 4 8 28 29 30 31 32) includes: ascii) "home, end, backspace, arrow keys, space" 264739 and: [self keyboardNavigationHandler notNil]]) 264740 ifTrue: [self keyboardNavigationHandler navigateFromKeystroke: aChar]. 264741 264742 isCmd := evt commandKeyPressed and: [Preferences cmdKeysInText]. 264743 264744 (isCmd and: [Preferences honorDesktopCmdKeys]) ifTrue: 264745 [^ self dispatchCommandKeyInWorld: aChar event: evt]. 264746 264747 "It was unhandled. Remember the keystroke." 264748 self lastKeystroke: evt keyString. 264749 self triggerEvent: #keyStroke! ! 264750 264751!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/23/2002 14:01'! 264752openRecentSubmissionsBrowser: evt 264753 "Locate a recent-submissions browser, open it, and bring it to the front. Create one if necessary. Only works in morphic" 264754 264755 self findAWindowSatisfying: 264756 [:aWindow | aWindow model isKindOf: RecentMessageSet] orMakeOneUsing: [Utilities recentSubmissionsWindow] 264757! ! 264758 264759!PasteUpMorph methodsFor: 'world menu' stamp: 'marcus.denker 11/19/2008 13:51'! 264760putUpWorldMenuFromEscapeKey 264761 self putUpWorldMenu: ActiveEvent! ! 264762 264763!PasteUpMorph methodsFor: 'world menu' stamp: 'marcus.denker 11/29/2008 23:25'! 264764putUpWorldMenu: evt 264765 "Put up a menu in response to a click on the desktop, triggered by evt." 264766 264767 | menu | 264768 self bringTopmostsToFront. 264769 "put up screen menu" 264770 menu := self buildWorldMenu: evt. 264771 menu addTitle: Preferences desktopMenuTitle translated. 264772 menu popUpEvent: evt in: self. 264773 ^ menu! ! 264774 264775!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/24/2000 14:40'! 264776reportLocalAddress 264777 "Report the local host address of this computer." 264778 264779 | addrString m s | 264780 Socket initializeNetwork. 264781 addrString := NetNameResolver localAddressString. 264782 m := RectangleMorph new 264783 color: (Color r: 0.6 g: 0.8 b: 0.6); 264784 extent: 118@36; 264785 borderWidth: 1. 264786 s := StringMorph contents: 'Local Host Address:'. 264787 s position: m position + (5@4). 264788 m addMorph: s. 264789 s := StringMorph contents: addrString. 264790 s position: m position + (5@19). 264791 m addMorph: s. 264792 self primaryHand attachMorph: m. 264793! ! 264794 264795!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 13:56'! 264796respondToCommand: aCharacter bySending: aSelector to: aReceiver 264797 "Respond to the command-key use of the given character by sending the given selector to the given receiver. If the selector is nil, retract any prior such setting" 264798 264799 aSelector 264800 ifNil: 264801 [self commandKeySelectors removeKey: aCharacter] 264802 ifNotNil: 264803 [self commandKeySelectors at: aCharacter put: (MessageSend receiver: aReceiver selector: aSelector)]! ! 264804 264805!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 12:25'! 264806undoOrRedoCommand 264807 "Undo or redo the last command recorded in the world" 264808 264809 ^ self commandHistory undoOrRedoCommand! ! 264810 264811 264812!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/28/2000 19:25'! 264813abandonAllHalos 264814 self flag: #arNote. "Remove the method" 264815 ^self deleteAllHalos! ! 264816 264817!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 22:29'! 264818activeHand: aHandMorph 264819 "temporarily retained for old main event loops" 264820 264821 worldState activeHand: aHandMorph. 264822 264823! ! 264824 264825!PasteUpMorph methodsFor: 'world state' stamp: 'ar 10/26/2000 14:52'! 264826addHand: aHandMorph 264827 "Add the given hand to the list of hands for this world." 264828 264829 aHandMorph owner ifNotNil:[aHandMorph owner removeHand: aHandMorph]. 264830 worldState addHand: aHandMorph. 264831 aHandMorph privateOwner: self. 264832! ! 264833 264834!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:09'! 264835addMorphsAndModel: aMorphOrList 264836 "Dump in submorphs, model, and stepList from aMorphOrList. Used to bring a world, paste-up, or other morph in from an object file." 264837 264838 aMorphOrList isMorph 264839 ifTrue: 264840 [aMorphOrList isWorldMorph 264841 ifFalse: 264842 ["one morph, put on hand" 264843 264844 "aMorphOrList installModelIn: self. a chance to install model pointers" 264845 264846 aMorphOrList privateOwner: nil. 264847 self firstHand attachMorph: aMorphOrList. 264848 self startSteppingSubmorphsOf: aMorphOrList] 264849 ifTrue: 264850 [model isNil 264851 ifTrue: [self setModel: aMorphOrList modelOrNil] 264852 ifFalse: 264853 [aMorphOrList modelOrNil ifNotNil: 264854 [aMorphOrList modelOrNil privateOwner: nil. 264855 self addMorph: aMorphOrList modelOrNil]]. 264856 aMorphOrList privateSubmorphs reverseDo: 264857 [:m | 264858 m privateOwner: nil. 264859 self addMorph: m. 264860 m changed]. 264861 (aMorphOrList instVarNamed: 'stepList') 264862 do: [:entry | entry first startSteppingIn: self]]] 264863 ifFalse: 264864 ["list, add them all" 264865 264866 aMorphOrList reverseDo: 264867 [:m | 264868 m privateOwner: nil. 264869 self addMorph: m. 264870 self startSteppingSubmorphsOf: m. "It may not want this!!" 264871 m changed]]! ! 264872 264873!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! 264874addMorph: aMorph centeredNear: aPoint 264875 "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." 264876 264877 | trialRect delta | 264878 trialRect := Rectangle center: aPoint extent: aMorph fullBounds extent. 264879 delta := trialRect amountToTranslateWithin: bounds. 264880 aMorph position: trialRect origin + delta. 264881 self addMorph: aMorph. 264882! ! 264883 264884!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 8/31/2004 16:23'! 264885allNonFlapRelatedSubmorphs 264886 "Answer all non-window submorphs that are not flap-related" 264887 264888 ^submorphs 264889 select: [:m | (m isSystemWindow) not and: [m wantsToBeTopmost not]]! ! 264890 264891!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 10:45'! 264892assuredCanvas 264893 264894 ^worldState assuredCanvas! ! 264895 264896!PasteUpMorph methodsFor: 'world state' stamp: 'tak 3/15/2005 17:31'! 264897assureNotPaintingElse: aBlock 264898 "If painting is already underway in the receiver, put up an informer to that effect and evalute aBlock" 264899 self removeModalWindow. 264900 self sketchEditorOrNil ifNotNil: 264901 [self inform: 'Sorry, you can only paint 264902one object at a time' translated. 264903 Cursor normal show. 264904 ^ aBlock value] 264905! ! 264906 264907!PasteUpMorph methodsFor: 'world state' stamp: 'ar 12/18/2000 01:16'! 264908assureNotPaintingEvent: evt 264909 "If painting is already underway 264910 in the receiver, put up an informer to that effect and evalute aBlock" 264911 | editor | 264912 (editor := self sketchEditorOrNil) ifNotNil:[ 264913 editor save: evt. 264914 Cursor normal show. 264915 ].! ! 264916 264917!PasteUpMorph methodsFor: 'world state' stamp: 'stephane.ducasse 11/12/2008 10:28'! 264918beWorldForProject: aProject 264919 264920 self privateOwner: nil. 264921 worldState := WorldState new. 264922 self addHand: HandMorph new. 264923 self setProperty: #optimumExtentFromAuthor toValue: Display extent. 264924 self startSteppingSubmorphsOf: self! ! 264925 264926!PasteUpMorph methodsFor: 'world state' stamp: 'alain.plantec 2/6/2009 11:39'! 264927checkCurrentHandForObjectToPaste 264928 264929 | response | 264930 self primaryHand pasteBuffer ifNil: [^self]. 264931 response := self confirm: ('Hand is holding a Morph in its paste buffer:' translated, '\') withCRs, 264932 self primaryHand pasteBuffer printString, 264933 ('\', 'Delete it ?' translated) withCRs. 264934 response = 1 ifTrue: [self primaryHand pasteBuffer: nil]. 264935! ! 264936 264937!PasteUpMorph methodsFor: 'world state' stamp: 'ar 3/17/2001 23:57'! 264938checkCurrentHandForObjectToPaste2 264939 264940 self primaryHand pasteBuffer ifNil: [^self]. 264941 self inform: 'Hand is holding a Morph in its paste buffer:\' withCRs, 264942 self primaryHand pasteBuffer printString. 264943 264944! ! 264945 264946!PasteUpMorph methodsFor: 'world state' stamp: 'bf 1/5/2000 19:25'! 264947chooseClickTarget 264948 Cursor crossHair showWhile: 264949 [Sensor waitButton]. 264950 Cursor down showWhile: 264951 [Sensor anyButtonPressed]. 264952 ^ (self morphsAt: Sensor cursorPoint) first! ! 264953 264954!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! 264955colorAt: aPoint belowMorph: aMorph 264956 "Return the color of the pixel immediately behind the given morph at the given point. 264957 NOTE: due to some bounds wobble in flexing, we take the middle of 3x3 rect." 264958 ^ (self patchAt: (aPoint-1 extent: 3) without: aMorph andNothingAbove: true) 264959 colorAt: 1@1 264960! ! 264961 264962!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 9/9/2004 22:47'! 264963deleteAllHalos 264964 264965 self haloMorphs 264966 do: [:each | (each target isKindOf: SelectionMorph) 264967 ifTrue: [each target delete]]. 264968 self hands 264969 do: [:each | each removeHalo]! ! 264970 264971!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/25/2000 15:43'! 264972displayWorld 264973 264974 self outermostWorldMorph privateOuterDisplayWorld 264975! ! 264976 264977!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 13:20'! 264978displayWorldAsTwoTone 264979 "Display the world in living black-and-white. (This is typically done to save space.)" 264980 264981 worldState displayWorldAsTwoTone: self submorphs: submorphs color: color 264982! ! 264983 264984!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:10'! 264985displayWorldNonIncrementally 264986 "Display the morph world non-incrementally. Used for testing." 264987 264988 (worldState canvas isNil or: 264989 [worldState canvas extent ~= self viewBox extent 264990 or: [worldState canvas form depth ~= Display depth]]) 264991 ifTrue: 264992 ["allocate a new offscreen canvas the size of the window" 264993 264994 worldState 264995 canvas: (Display defaultCanvasClass extent: self viewBox extent)]. 264996 worldState canvas fillColor: color. 264997 submorphs reverseDo: [:m | worldState canvas fullDrawMorph: m]. 264998 worldState handsReverseDo: [:h | worldState canvas fullDrawMorph: h]. 264999 worldState canvas form displayOn: Display at: self viewBox origin. 265000 self fullRepaintNeeded. "don't collect damage" 265001 Display forceDisplayUpdate! ! 265002 265003!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 12:23'! 265004displayWorldSafely 265005 265006 worldState displayWorldSafely: self. 265007! ! 265008 265009!PasteUpMorph methodsFor: 'world state' stamp: 'ls 5/6/2003 16:51'! 265010doOneCycle 265011 "see the comment in doOneCycleFor:" 265012 265013 worldState doOneCycleFor: self! ! 265014 265015!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 11:59'! 265016doOneSubCycle 265017 "Like doOneCycle, but preserves activeHand." 265018 265019 worldState doOneSubCycleFor: self! ! 265020 265021!PasteUpMorph methodsFor: 'world state' stamp: 'di 9/19/2000 22:17'! 265022dragThroughOnDesktop: evt 265023 "Draw out a selection rectangle" 265024 | selection | 265025 selection := SelectionMorph newBounds: (evt cursorPoint extent: 8@8). 265026 self addMorph: selection. 265027 ^ selection extendByHand: evt hand 265028! ! 265029 265030!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/11/2000 17:45'! 265031embeddedProjectDisplayMode 265032 265033 "#naked - the embedded project/world is just a pasteup in the outer p/w 265034 #window - the embedded p/w is in a system window in the outer p/w 265035 #frame - the embedded p/w is in a green frame and clipped 265036 #scaled - the embedded p/w is in a green frame and scaled to fit" 265037 265038 ^#scaled 265039! ! 265040 265041!PasteUpMorph methodsFor: 'world state' stamp: 'ar 12/19/2000 19:23'! 265042endDrawing: evt 265043 "If painting is already underway 265044 in the receiver, finish and save it." 265045 | editor | 265046 (editor := self sketchEditorOrNil) ifNotNil:[ 265047 editor save: evt. 265048 Cursor normal show. 265049 ].! ! 265050 265051!PasteUpMorph methodsFor: 'world state' stamp: 'dao 10/1/2004 13:14'! 265052exit 265053 265054 Project current exit 265055! ! 265056 265057!PasteUpMorph methodsFor: 'world state' stamp: 'ar 5/28/2000 12:10'! 265058flashRects: rectangleList color: aColor 265059 "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." 265060 "Details: Uses two reverses so that the display is restored to its original state. This is necessary when in deferred update mode." 265061 265062 | blt screenRect | 265063 blt := (BitBlt current toForm: Display) 265064 sourceForm: nil; 265065 sourceOrigin: 0@0; 265066 clipRect: self viewBox; 265067 combinationRule: Form reverse. 265068 rectangleList do: [:r | 265069 screenRect := r translateBy: self viewBox origin. 265070 blt destRect: screenRect; copyBits. 265071 Display forceToScreen: screenRect; forceDisplayUpdate. 265072 (Delay forMilliseconds: 15) wait. 265073 blt destRect: screenRect; copyBits. 265074 Display forceToScreen: screenRect; forceDisplayUpdate]. 265075! ! 265076 265077!PasteUpMorph methodsFor: 'world state' stamp: 'di 11/27/1999 10:11'! 265078goBack 265079 265080 Project returnToPreviousProject. 265081! ! 265082 265083!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/28/2000 18:00'! 265084haloMorphs 265085 ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! ! 265086 265087!PasteUpMorph methodsFor: 'world state' stamp: 'alain.plantec 5/30/2008 14:07'! 265088handleFatalDrawingError: errMsg 265089 "Handle a fatal drawing error." 265090 Display deferUpdates: false. "Just in case" 265091 self primitiveError: errMsg. 265092 265093 "Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"! ! 265094 265095!PasteUpMorph methodsFor: 'world state' stamp: 'stephane.ducasse 11/12/2008 10:28'! 265096initForProject: aWorldState 265097 265098 worldState := aWorldState. 265099 bounds := Display boundingBox. 265100 self color: Preferences defaultWorldColor. 265101 self addHand: HandMorph new. 265102 self setProperty: #optimumExtentFromAuthor toValue: Display extent. 265103 self wantsMouseOverHalos: Preferences mouseOverHalos. 265104 self borderWidth: 0. 265105 model := nil. 265106! ! 265107 265108!PasteUpMorph methodsFor: 'world state' stamp: 'stephane.ducasse 11/14/2008 21:26'! 265109install 265110 owner := nil. "since we may have been inside another world previously" 265111 ActiveWorld := self. 265112 ActiveHand := self hands first. "default" 265113 ActiveEvent := nil. 265114 submorphs do: [:ss | ss owner isNil ifTrue: [ss privateOwner: self]]. 265115 "Transcript that was in outPointers and then got deleted." 265116 self viewBox: Display boundingBox. 265117 Sensor flushAllButDandDEvents. 265118 worldState handsDo: [:h | h initForEvents]. 265119 self installFlaps. 265120 self borderWidth: 0. "default" 265121 (Preferences showSecurityStatus 265122 and: [SecurityManager default isInRestrictedMode]) 265123 ifTrue: 265124 [self 265125 borderWidth: 2; 265126 borderColor: Color red]. 265127 SystemWindow noteTopWindowIn: self. 265128 self displayWorldSafely! ! 265129 265130!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 8/31/2004 16:25'! 265131installFlaps 265132 "Get flaps installed within the bounds of the receiver" 265133 265134 Project current assureFlapIntegrity. 265135 self addGlobalFlaps. 265136 self localFlapTabs do: 265137 [:aFlapTab | aFlapTab adaptToWorld]. 265138 self assureFlapTabsFitOnScreen. 265139 self bringTopmostsToFront! ! 265140 265141!PasteUpMorph methodsFor: 'world state' stamp: 'nb 6/17/2003 12:25'! 265142nextPage 265143 "backstop for smart next-page buttons that look up the containment hierarchy until they find somone who is willing to field this command. If we get here, the 'next' button was not embedded in a book, so we can do nothing useful" 265144 265145 Beeper beep! ! 265146 265147!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/11/2000 15:09'! 265148optimumExtentFromAuthor 265149 265150 | opt | 265151 ^self 265152 valueOfProperty: #optimumExtentFromAuthor 265153 ifAbsent: [ 265154 opt := bounds extent. 265155 self setProperty: #optimumExtentFromAuthor toValue: opt. 265156 ^opt 265157 ] 265158 265159! ! 265160 265161!PasteUpMorph methodsFor: 'world state' stamp: 'wiz 12/4/2006 00:32'! 265162paintArea 265163 "What rectangle should the user be allowed to create a new painting in?? 265164 An area beside the paintBox. Allow playArea to override with its own 265165 bounds!! " 265166 | playfield paintBoxBounds | 265167 playfield := self 265168 submorphNamed: 'playfield' 265169 ifNone: []. 265170 playfield 265171 ifNotNil: [^ playfield bounds]. 265172 paintBoxBounds := self paintBox bounds. 265173 self firstHand targetPoint x < paintBoxBounds center x 265174 ifTrue: [^ bounds topLeft corner: paintBoxBounds left @ bounds bottom"paint on left side"] 265175 ifFalse: [^ paintBoxBounds right @ bounds top corner: bounds bottomRight]! ! 265176 265177!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 19:01'! 265178paintAreaFor: aSketchMorph 265179 "Answer the area to comprise the onion-skinned canvas for painting/repainting aSketchMorph" 265180 265181 | itsOwner | 265182 ((itsOwner := aSketchMorph owner) notNil and: [itsOwner isPlayfieldLike]) 265183 ifTrue: [^itsOwner bounds]. "handles every plausible situation" 265184 ^self paintArea! ! 265185 265186!PasteUpMorph methodsFor: 'world state' stamp: 'tk 8/21/2000 15:36'! 265187paintBox 265188 "Return the painting controls widget (PaintBoxMorph) to be used for painting in this world. If there is not already a PaintBox morph, or if it has been deleted from this world, create a new one." 265189 265190 | newPaintBox refPoint aPalette | 265191 self allMorphsDo: [:m | (m isKindOf: PaintBoxMorph) ifTrue: [^ m]]. 265192 refPoint := (aPalette := self standardPalette) 265193 ifNotNil: 265194 [aPalette showNoPalette. 265195 aPalette topRight + (0 @ 12)] 265196 ifNil: 265197 [self topRight]. 265198 newPaintBox := PaintBoxMorph new. 265199 newPaintBox position: (refPoint - (newPaintBox width @ 0)). 265200 self addMorph: newPaintBox. 265201 ^ newPaintBox 265202! ! 265203 265204!PasteUpMorph methodsFor: 'world state' stamp: 'sw 9/2/1999 12:01'! 265205paintBoxOrNil 265206 "Return the painting controls widget (PaintBoxMorph) to be used for painting in this world. If there is not already a PaintBox morph return nil" 265207 265208 self allMorphsDo: [:m | (m isKindOf: PaintBoxMorph) ifTrue: [^ m]]. 265209 ^ nil 265210! ! 265211 265212!PasteUpMorph methodsFor: 'world state' stamp: 'nk 7/7/2003 11:15'! 265213patchAt: patchRect without: stopMorph andNothingAbove: stopThere 265214 "Return a complete rendering of this patch of the display screen 265215 without stopMorph, and possibly without anything above it." 265216 265217 | c | 265218 c := ColorPatchCanvas 265219 extent: patchRect extent 265220 depth: Display depth 265221 origin: patchRect topLeft negated 265222 clipRect: (0@0 extent: patchRect extent). 265223 c stopMorph: stopMorph. 265224 c doStop: stopThere. 265225 265226 (self bounds containsRect: patchRect) ifFalse: 265227 ["Need to fill area outside bounds with black." 265228 c form fillColor: Color black]. 265229 (self bounds intersects: patchRect) ifFalse: 265230 ["Nothing within bounds to show." 265231 ^ c form]. 265232 self fullDrawOn: c. 265233 stopThere ifFalse: [ self world handsReverseDo: [:h | h drawSubmorphsOn: c]]. 265234 ^c form 265235! ! 265236 265237!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 10:38'! 265238pauseEventRecorder 265239 "Suspend any event recorder, and return it if found" 265240 265241 | er | 265242 worldState handsDo: [:h | (er := h pauseEventRecorderIn: self) ifNotNil: [^ er]]. 265243 ^ nil! ! 265244 265245!PasteUpMorph methodsFor: 'world state' stamp: 'nb 6/17/2003 12:25'! 265246previousPage 265247 "backstop for smartprev-page buttons that look up the containment hierarchy until they find somone who is willing to field this command. If we get here, the button was not embedded in a book, so we can do nothing useful" 265248 265249 Beeper beep! ! 265250 265251!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/25/2000 15:43'! 265252privateOuterDisplayWorld 265253 265254 worldState displayWorld: self submorphs: submorphs 265255! ! 265256 265257!PasteUpMorph methodsFor: 'world state' stamp: 'ar 10/5/2000 16:23'! 265258removeHand: aHandMorph 265259 "Remove the given hand from the list of hands for this world." 265260 265261 (worldState hands includes: aHandMorph) ifFalse: [^self]. 265262 aHandMorph dropMorphs. 265263 self invalidRect: aHandMorph fullBounds. 265264 worldState removeHand: aHandMorph. 265265! ! 265266 265267!PasteUpMorph methodsFor: 'world state' stamp: 'sw 2/7/2002 16:22'! 265268repositionFlapsAfterScreenSizeChange 265269 "Reposition flaps after screen size change" 265270 265271 (Flaps globalFlapTabsIfAny, ActiveWorld localFlapTabs) do: 265272 [:aFlapTab | 265273 aFlapTab applyEdgeFractionWithin: self bounds]. 265274 Flaps doAutomaticLayoutOfFlapsIfAppropriate! ! 265275 265276!PasteUpMorph methodsFor: 'world state' stamp: 'ar 3/18/2001 00:35'! 265277restoreDisplay 265278 265279 World restoreMorphicDisplay. "I don't actually expect this to be called"! ! 265280 265281!PasteUpMorph methodsFor: 'world state' stamp: 'md 2/12/2006 20:08'! 265282restoreFlapsDisplay 265283 "Restore the display of flaps" 265284 265285 (Flaps sharedFlapsAllowed and: [Project current flapsSuppressed not]) ifTrue: 265286 [Flaps globalFlapTabs do: 265287 [:aFlapTab | aFlapTab adaptToWorld]]. 265288 self localFlapTabs do: 265289 [:aFlapTab | aFlapTab adaptToWorld]. 265290 self assureFlapTabsFitOnScreen. 265291 self bringTopmostsToFront.! ! 265292 265293!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 9/5/2004 19:46'! 265294restoreMainDockingBarDisplay 265295 "Restore the display of docking bars" 265296 self dockingBars 265297 do: [:each | each updateBounds]! ! 265298 265299!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 4/3/2006 14:36'! 265300restoreMorphicDisplay 265301 265302 DisplayScreen startUp. 265303 265304 ThumbnailMorph recursionReset. 265305 265306 self 265307 extent: Display extent; 265308 viewBox: Display boundingBox; 265309 handsDo: [:h | h visible: true; showTemporaryCursor: nil]; 265310 restoreFlapsDisplay; 265311 restoreMainDockingBarDisplay; 265312 fullRepaintNeeded. 265313 265314 WorldState 265315 addDeferredUIMessage: [Cursor normal show]. 265316! ! 265317 265318!PasteUpMorph methodsFor: 'world state' stamp: 'StephaneDucasse 10/15/2009 18:00'! 265319saveAsWorld 265320 | worldName s | 265321 worldName := UIManager default 265322 request: 'Please give this world a name' translated 265323 initialAnswer: 'test'. 265324 worldName ifNil: [worldName := String new]. 265325 ((self class class includesSelector: worldName asSymbol) and: 265326 [(self confirm: 'OK to overwrite' translated, ' "' , worldName , '"?') not]) 265327 ifTrue: [^ self]. 265328 265329 s := (String new: 1000) writeStream. 265330 s nextPutAll: worldName; cr; tab; 265331 nextPutAll: '"' , self class name , ' ' , worldName, ' open"'; cr; cr; tab; 265332 nextPutAll: '^ '. 265333 self printConstructorOn: s indent: 0. 265334 s cr. 265335 265336 self class class 265337 compile: s contents 265338 classified: 'examples' 265339 notifying: nil.! ! 265340 265341!PasteUpMorph methodsFor: 'world state' stamp: 'adrian_lienhard 7/19/2009 20:19'! 265342sketchEditorOrNil 265343 "Return a SketchEditorMorph found in the world, if any, else nil" 265344 265345 265346 ^ Smalltalk at: #SketchEditorMorph ifPresent: [ :class | self findA: class ] 265347! ! 265348 265349!PasteUpMorph methodsFor: 'world state' stamp: 'stephane.ducasse 5/1/2009 22:11'! 265350sleep 265351 265352 worldState canvas ifNil: [^ self "already called (clean this up)"]. 265353 Cursor normal show. "restore the normal cursor" 265354 worldState canvas: nil. "free my canvas to save space" 265355 self fullReleaseCachedState. 265356! ! 265357 265358!PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:11'! 265359someHalo 265360 "Return some halo that's currently visible in the world" 265361 265362 | m | 265363 ^(m := self haloMorphs) notEmpty ifTrue: [m first] ifFalse: [nil]! ! 265364 265365!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! 265366specialNameInModelFor: aMorph 265367 ^ model ifNotNil: [model nameFor: aMorph] ifNil: [nil]! ! 265368 265369!PasteUpMorph methodsFor: 'world state' stamp: 'nb 6/17/2003 12:25'! 265370standardPlayerHit 265371 265372 self playSoundNamed: 'peaks'. 265373! ! 265374 265375!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/1/2000 19:01'! 265376startSteppingSubmorphsOf: aMorph 265377 265378 "Ensure that all submorphs of the given morph that want to be stepped are added to the step list. Typically used after adding a morph to the world." 265379 265380 aMorph allMorphsDo: [:m | 265381 m wantsSteps ifTrue: [m arrangeToStartSteppingIn: m world]. 265382 ] 265383 265384! ! 265385 265386 265387!PasteUpMorph methodsFor: 'private' stamp: 'ar 3/14/2000 23:20'! 265388privateFullMoveBy: delta 265389 "Private. Overridden to prevent drawing turtle trails when a playfield is moved" 265390 self setProperty: #turtleTrailsDelta toValue: delta. 265391 super privateFullMoveBy: delta. 265392 self removeProperty: #turtleTrailsDelta. 265393! ! 265394 265395!PasteUpMorph methodsFor: 'private' stamp: 'RAA 6/1/2000 14:23'! 265396privateMoveBy: delta 265397 265398 super privateMoveBy: delta. 265399 worldState ifNotNil: [ 265400 worldState viewBox ifNotNil: [ 265401 worldState viewBox: bounds 265402 ]. 265403 ].! ! 265404 265405!PasteUpMorph methodsFor: 'private' stamp: 'nk 7/8/2003 09:18'! 265406privateRemoveMorph: aMorph 265407 backgroundMorph == aMorph ifTrue: [ backgroundMorph := nil ]. 265408 ^super privateRemoveMorph: aMorph. 265409! ! 265410 265411"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 265412 265413PasteUpMorph class 265414 instanceVariableNames: ''! 265415 265416!PasteUpMorph class methodsFor: 'printing' stamp: 'sw 5/3/1998 14:25'! 265417defaultNameStemForInstances 265418 "Answer a basis for names of default instances of the receiver" 265419 ^ 'playfield'! ! 265420 265421 265422!PasteUpMorph class methodsFor: 'project' stamp: 'di 7/15/1999 09:51'! 265423MinCycleLapse: milliseconds 265424 "set the minimum amount of time that may transpire between two calls to doOneCycle" 265425 MinCycleLapse := milliseconds ifNotNil: [ milliseconds rounded ].! ! 265426 265427!PasteUpMorph class methodsFor: 'project' stamp: 'RAA 5/25/2000 15:26'! 265428disableDeferredUpdates 265429 265430 ^DisableDeferredUpdates ifNil: [DisableDeferredUpdates := false] 265431! ! 265432 265433!PasteUpMorph class methodsFor: 'project' stamp: 'di 7/15/1999 09:51'! 265434disableDeferredUpdates: aBoolean 265435 "If the argument is true, disable deferred screen updating." 265436 "Details: When deferred updating is used, Morphic performs double-buffered screen updates by telling the VM to de-couple the Display from the hardware display buffer, drawing directly into the Display, and then forcing the changed regions of the Display to be copied to the screen. This saves both time (an extra BitBlt is avoided) and space (an extra display buffer is avoided). However, on platforms on which the Display points directly to the hardware screen buffer, deferred updating can't be used (you'd see ugly flashing as the layers of the drawing were assembled). In this case, the drawing is composited into an offscreen FormCanvas and then copied to the hardware display buffer." 265437 265438 DisableDeferredUpdates := aBoolean. 265439! ! 265440 265441!PasteUpMorph class methodsFor: 'project' stamp: 'RAA 5/25/2000 15:15'! 265442newWorldForProject: projectOrNil 265443 "Return a new pasteUpMorph configured as a world (ie project notNil). 265444 projectOrNil is no longer used." 265445 265446 ^ self new initForProject: WorldState new! ! 265447 265448!PasteUpMorph class methodsFor: 'project' stamp: 'stephane.ducasse 8/6/2008 11:17'! 265449newWorldTesting 265450 265451 | world ex | 265452 265453 ex := 500@500. 265454 world := PasteUpMorph newWorldForProject: nil. 265455 world extent: ex; color: Color orange. 265456 world openInWorld. 265457 world viewBox: (0@0 extent: ex). 265458 Smalltalk at: #BouncingAtomsMorph 265459 ifPresent: [ :cl | cl new openInWorld: world]. 265460 265461! ! 265462 265463 265464!PasteUpMorph class methodsFor: 'scripting' stamp: 'sw 3/4/1999 15:05'! 265465authoringPrototype 265466 "Answer an instance of the receiver suitable for placing in a parts bin for authors" 265467 265468 | proto | 265469 proto := self new markAsPartsDonor. 265470 proto color: Color green muchLighter; extent: 100 @ 80; borderColor: (Color r: 0.645 g: 0.935 b: 0.161). 265471 proto extent: 300 @ 240. 265472 proto beSticky. 265473 ^ proto! ! 265474 265475 265476!PasteUpMorph class methodsFor: 'system startup' stamp: 'rww 10/1/2001 01:17'! 265477shutDown 265478 265479 World ifNotNil:[ 265480 World triggerEvent: #aboutToLeaveWorld. 265481 ].! ! 265482 265483!PasteUpMorph class methodsFor: 'system startup' stamp: 'rww 10/1/2001 01:17'! 265484startUp 265485 265486 World ifNotNil:[ 265487 World restoreMorphicDisplay. 265488 World triggerEvent: #aboutToEnterWorld. 265489 ].! ! 265490ClassTestCase subclass: #PasteUpMorphTest 265491 instanceVariableNames: '' 265492 classVariableNames: '' 265493 poolDictionaries: '' 265494 category: 'MorphicTests-Worlds'! 265495!PasteUpMorphTest commentStamp: '<historical>' prior: 0! 265496I am a TestCase for PasteUpMorph.! 265497 265498 265499!PasteUpMorphTest methodsFor: 'tests' stamp: 'tak 11/7/2004 18:29'! 265500testCursorWrapped 265501 "self debug: #testCursorWrapped" 265502 | holder | 265503 holder := PasteUpMorph new. 265504 self assert: holder cursor = 1. 265505 holder cursorWrapped: 2. 265506 self assert: holder cursor = 1. 265507 holder addMorph: Morph new; 265508 addMorph: Morph new; 265509 addMorph: Morph new. 265510 holder cursorWrapped: 3. 265511 self assert: holder cursor = 3. 265512 holder cursorWrapped: 5. 265513 self assert: holder cursor = 2. 265514 holder cursorWrapped: 0. 265515 self assert: holder cursor = 3. 265516 holder cursorWrapped: -1. 265517 self assert: holder cursor = 2.! ! 265518 265519!PasteUpMorphTest methodsFor: 'tests' stamp: 'tak 11/7/2004 18:34'! 265520testCursorWrappedWithFraction 265521 "self debug: #testCursorWrappedWithFraction" 265522 | holder | 265523 holder := PasteUpMorph new. 265524 holder addMorph: Morph new; 265525 addMorph: Morph new; 265526 addMorph: Morph new. 265527 holder cursorWrapped: 3.5. 265528 self assert: holder cursor = 3.5. 265529 holder cursorWrapped: 5.5. 265530 self assert: holder cursor = 2.5. 265531 holder cursorWrapped: 0.5. 265532 self assert: holder cursor = 3.5. 265533 holder cursorWrapped: -0.5. 265534 self assert: holder cursor = 2.5.! ! 265535 265536!PasteUpMorphTest methodsFor: 'tests' stamp: 'mjr 3/6/2003 11:34'! 265537testGridToGradient 265538 "A trivial test for checking that you can change from a grid to a 265539 gradient background. A recent [FIX] will make this pass." 265540 | pum | 265541 pum := PasteUpMorph new. 265542 pum setStandardTexture. 265543 "The following should fail without the fix" 265544 self 265545 shouldnt: [pum gradientFillColor: Color red] 265546 raise: MessageNotUnderstood! ! 265547DisplayObject subclass: #Path 265548 instanceVariableNames: 'form collectionOfPoints' 265549 classVariableNames: '' 265550 poolDictionaries: '' 265551 category: 'ST80-Paths'! 265552!Path commentStamp: '<historical>' prior: 0! 265553I am the abstract superclass of the Graphic spatial primitives. I represent an ordered sequence of Points. Spatial primitives are used to generate "trajectories" such as lines and circles.! 265554 265555 265556!Path methodsFor: 'accessing'! 265557at: index 265558 "Answer the point on the receiver's path at position index." 265559 265560 ^collectionOfPoints at: index! ! 265561 265562!Path methodsFor: 'accessing'! 265563at: index put: aPoint 265564 "Store the argument, aPoint, as the point on the receiver's path at position 265565 index." 265566 265567 ^collectionOfPoints at: index put: aPoint! ! 265568 265569!Path methodsFor: 'accessing'! 265570first 265571 "Answer the first point on the receiver's path; included to correspond to 265572 OrderedCollection protocol." 265573 265574 ^collectionOfPoints first! ! 265575 265576!Path methodsFor: 'accessing'! 265577firstPoint 265578 "Answer the first point on the receiver's path." 265579 265580 ^collectionOfPoints first! ! 265581 265582!Path methodsFor: 'accessing'! 265583firstPoint: aPoint 265584 "Replace the first element of the receiver with the new value aPoint. 265585 Answer the argument aPoint." 265586 265587 collectionOfPoints at: 1 put: aPoint. 265588 ^aPoint! ! 265589 265590!Path methodsFor: 'accessing'! 265591form 265592 "Answer the receiver's form, or, if form is nil, then answer a 1 x 1 black 265593 form (a black dot)." 265594 265595 | aForm | 265596 form == nil 265597 ifTrue: 265598 [aForm := Form extent: 1 @ 1. 265599 aForm fillBlack. 265600 ^aForm] 265601 ifFalse: 265602 [^form]! ! 265603 265604!Path methodsFor: 'accessing'! 265605form: aForm 265606 "Make the argument, aForm, be the receiver's form." 265607 265608 form := aForm! ! 265609 265610!Path methodsFor: 'accessing'! 265611last 265612 "Answer the last point on the receiver's path; included to correspond to 265613 OrderedCollection protocol." 265614 265615 ^collectionOfPoints last! ! 265616 265617!Path methodsFor: 'accessing'! 265618offset 265619 "There are basically two kinds of display objects in the system: those 265620 that, when asked to transform themselves, create a new object; and those 265621 that side effect themselves by maintaining a record of the transformation 265622 request (typically an offset). Path, like Rectangle and Point, is a display 265623 object of the first kind." 265624 265625 self shouldNotImplement! ! 265626 265627!Path methodsFor: 'accessing'! 265628secondPoint 265629 "Answer the second element of the receiver." 265630 265631 ^collectionOfPoints at: 2! ! 265632 265633!Path methodsFor: 'accessing'! 265634secondPoint: aPoint 265635 "Replace the second element of the receiver with the new value aPoint. 265636 Answer the argument aPoint." 265637 265638 collectionOfPoints at: 2 put: aPoint. 265639 ^aPoint! ! 265640 265641!Path methodsFor: 'accessing'! 265642size 265643 "Answer the length of the receiver." 265644 265645 ^collectionOfPoints size! ! 265646 265647!Path methodsFor: 'accessing'! 265648thirdPoint 265649 "Answer the third element of the receiver." 265650 265651 ^collectionOfPoints at: 3! ! 265652 265653!Path methodsFor: 'accessing'! 265654thirdPoint: aPoint 265655 "Replace the third element of the receiver with the new value aPoint. 265656 Answer the argument aPoint." 265657 265658 collectionOfPoints at: 3 put: aPoint. 265659 ^aPoint! ! 265660 265661 265662!Path methodsFor: 'adding'! 265663add: aPoint 265664 "Include aPoint as one of the receiver's elements." 265665 265666 collectionOfPoints add: aPoint! ! 265667 265668 265669!Path methodsFor: 'display box access'! 265670computeBoundingBox 265671 "Refer to the comment in DisplayObject|computeBoundingBox." 265672 265673 | box | 265674 box := Rectangle origin: (self at: 1) extent: 0 @ 0. 265675 collectionOfPoints do: 265676 [:aPoint | box := box merge: (Rectangle origin: aPoint extent: 0 @ 0)]. 265677 ^box! ! 265678 265679 265680!Path methodsFor: 'displaying'! 265681displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 265682 "Display this Path--offset by aPoint, clipped by clipRect and the form 265683 associated with this Path will be displayedr according to one of the sixteen 265684 functions of two logical variables (rule). Also the source form will be first 265685 anded with aForm as a mask. Does not effect the state of the Path" 265686 265687 collectionOfPoints do: 265688 [:element | 265689 self form 265690 displayOn: aDisplayMedium 265691 at: element + aDisplayPoint 265692 clippingBox: clipRectangle 265693 rule: ruleInteger 265694 fillColor: aForm]! ! 265695 265696!Path methodsFor: 'displaying'! 265697displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 265698 "Displays this path, translated and scaled by aTransformation. Get the 265699 scaled and translated Path." 265700 265701 | newPath transformedPath | 265702 transformedPath := displayTransformation applyTo: self. 265703 newPath := Path new. 265704 transformedPath do: [:point | newPath add: point]. 265705 newPath form: self form. 265706 newPath 265707 displayOn: aDisplayMedium 265708 at: 0 @ 0 265709 clippingBox: clipRectangle 265710 rule: ruleInteger 265711 fillColor: aForm! ! 265712 265713 265714!Path methodsFor: 'enumerating'! 265715collect: aBlock 265716 "Evaluate aBlock with each of the receiver's elements as the argument. 265717 Collect the resulting values into a path that is like the receiver. Answer 265718 the new path." 265719 265720 | newCollection | 265721 newCollection := collectionOfPoints collect: aBlock. 265722 newCollection form: self form. 265723 ^newCollection! ! 265724 265725!Path methodsFor: 'enumerating'! 265726select: aBlock 265727 "Evaluate aBlock with each of the receiver's elements as the argument. 265728 Collect into a new path like the receiver only those elements for which 265729 aBlock evaluates to true. Answer the new path." 265730 265731 | newCollection | 265732 newCollection := collectionOfPoints select: aBlock. 265733 newCollection form: self form. 265734 ^newCollection! ! 265735 265736 265737!Path methodsFor: 'removing' stamp: 'di 4/4/2000 12:33'! 265738removeAllSuchThat: aBlock 265739 "Evaluate aBlock for each element of the receiver. 265740 Remove each element for which aBlock evaluates to true." 265741 265742 collectionOfPoints removeAllSuchThat: aBlock. 265743! ! 265744 265745 265746!Path methodsFor: 'testing'! 265747isEmpty 265748 265749 ^collectionOfPoints isEmpty! ! 265750 265751 265752!Path methodsFor: 'transforming' stamp: 'jrm 9/1/1999 21:26'! 265753scaleBy: aPoint 265754 "Answers a new Path scaled by aPoint. Does not affect the current data in 265755 this Path." 265756 265757 | newPath | 265758 newPath := self species new: self size. 265759 newPath form: self form. 265760 collectionOfPoints do: [:element | newPath add: (element scaleBy: aPoint)]. 265761 ^newPath! ! 265762 265763!Path methodsFor: 'transforming' stamp: 'jrm 9/1/1999 21:28'! 265764translateBy: aPoint 265765 "Answers a new Path whose elements are translated by aPoint. Does not 265766 affect the elements of this Path." 265767 265768 | newPath | 265769 newPath := self species new: self size. 265770 newPath form: self form. 265771 collectionOfPoints do: [:element | newPath add: (element translateBy: aPoint)]. 265772 ^newPath! ! 265773 265774 265775!Path methodsFor: 'private'! 265776initializeCollectionOfPoints 265777 265778 collectionOfPoints := OrderedCollection new! ! 265779 265780!Path methodsFor: 'private'! 265781initializeCollectionOfPoints: anInteger 265782 265783 collectionOfPoints := OrderedCollection new: anInteger! ! 265784 265785"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 265786 265787Path class 265788 instanceVariableNames: ''! 265789 265790!Path class methodsFor: 'examples'! 265791example 265792 "Creates a Path from mousePoints and displays it several ways on the display screen. Messes up the display. For learning about class Path, just select the code below and execute it to create a path and see it redisplayed in another place on the screen. Each path displays using a different form. A path is indicated by pressing the red mouse button in a sequence; press any other mouse button to terminate. " 265793 265794 | aPath aForm pl fl flag | 265795 aForm := Form extent: 2 @ 40. "creates a form one inch long" 265796 aForm fillBlack. "turns it black" 265797 aPath := Path new. 265798 aPath form: aForm. "use the long black form for displaying" 265799 flag := true. 265800 [flag] 265801 whileTrue: 265802 [Sensor waitButton. 265803 Sensor redButtonPressed 265804 ifTrue: 265805 [aPath add: Sensor waitButton. 265806 Sensor waitNoButton. 265807 aForm displayOn: Display at: aPath last] 265808 ifFalse: [flag := false]]. 265809 Display fillWhite. 265810 aPath displayOn: Display. "the original path" 265811 pl := aPath translateBy: 0 @ 100. 265812 fl := Form extent: 40 @ 40. 265813 fl fillGray. 265814 pl form: fl. 265815 pl displayOn: Display. "the translated path" 265816 Sensor waitNoButton 265817 265818 "Path example"! ! 265819 265820 265821!Path class methodsFor: 'instance creation'! 265822new 265823 265824 ^self basicNew initializeCollectionOfPoints! ! 265825 265826!Path class methodsFor: 'instance creation'! 265827new: anInteger 265828 265829 ^self basicNew initializeCollectionOfPoints: anInteger! ! 265830Shape subclass: #PathShape 265831 instanceVariableNames: 'bounds vertices' 265832 classVariableNames: '' 265833 poolDictionaries: '' 265834 category: 'Polymorph-Geometry'! 265835 265836!PathShape methodsFor: 'accessing' stamp: 'gvc 10/31/2006 10:36'! 265837basicBounds 265838 "Answer the bounds of the receiver without lazy calculation." 265839 265840 ^bounds! ! 265841 265842!PathShape methodsFor: 'accessing' stamp: 'gvc 7/30/2009 13:40'! 265843bounds 265844 "Answer the bounds of the receiver." 265845 265846 ^bounds ifNil: [bounds := self calculatedBounds]! ! 265847 265848!PathShape methodsFor: 'accessing' stamp: 'gvc 10/31/2006 10:25'! 265849bounds: anObject 265850 "Set the value of bounds" 265851 265852 bounds := anObject! ! 265853 265854!PathShape methodsFor: 'accessing' stamp: 'gvc 10/31/2006 10:24'! 265855vertices 265856 "Answer the value of vertices" 265857 265858 ^ vertices! ! 265859 265860!PathShape methodsFor: 'accessing' stamp: 'gvc 10/31/2006 11:08'! 265861vertices: aCollection 265862 "Set the value of vertices." 265863 265864 vertices := aCollection asOrderedCollection. 265865 self bounds: nil! ! 265866 265867 265868!PathShape methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 10:40'! 265869addVertex: aPoint 265870 "Add a vertex to the path." 265871 265872 self vertices add: aPoint. 265873 self basicBounds ifNotNil: [ 265874 self bounds: (self bounds quickMergePoint: aPoint)] ! ! 265875 265876!PathShape methodsFor: 'as yet unclassified' stamp: 'gvc 6/25/2007 13:52'! 265877calculatedBounds 265878 "Answer the bounds of the receiver calculated from the 265879 receiver's vertices." 265880 265881 |tl br| 265882 self vertices ifEmpty: [^nil]. 265883 tl := br := self vertices first. 265884 self vertices allButFirstDo: [:v | 265885 tl := tl min: v. 265886 br := br max: v]. 265887 ^tl corner: br + 1! ! 265888 265889!PathShape methodsFor: 'as yet unclassified' stamp: 'gvc 6/25/2007 14:03'! 265890containsPoint: aPoint 265891 "Answer whether the receiver contains the given point." 265892 265893 (self basicContainsPoint: aPoint) ifFalse: [^false]. 265894 self segmentsDo: [:p1 :p2 | 265895 (aPoint onLineFrom: p1 to: p2 within: 0) ifTrue: [^true]]. 265896 ^false! ! 265897 265898!PathShape methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 10:35'! 265899initialize 265900 "Initialize the receiver." 265901 265902 super initialize. 265903 self 265904 vertices: OrderedCollection new! ! 265905 265906!PathShape methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 10:47'! 265907segmentsDo: aBlock 265908 "Evaluate the two-argument block with each vertex and its successor." 265909 265910 self vertices size < 2 ifTrue: [^self]. 265911 1 to: self vertices size - 1 do: [:i | 265912 aBlock 265913 value: (self vertices at: i) 265914 value: (self vertices at: i + 1)]! ! 265915 265916"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 265917 265918PathShape class 265919 instanceVariableNames: ''! 265920 265921!PathShape class methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 11:08'! 265922vertices: aCollection 265923 "Answer a new instance of the receiver with the 265924 given vertices." 265925 265926 ^self new 265927 vertices: aCollection! ! 265928BitBlt subclass: #Pen 265929 instanceVariableNames: 'location direction penDown' 265930 classVariableNames: '' 265931 poolDictionaries: '' 265932 category: 'Graphics-Primitives'! 265933!Pen commentStamp: '<historical>' prior: 0! 265934My instances can scribble on the screen or some other Form, drawing and printing at any angle. Since I am a BitBlt, the drawing can be done with an arbitary source Form. 265935! 265936 265937 265938!Pen methodsFor: 'accessing'! 265939direction 265940 "Answer the receiver's current direction. 0 is towards the top of the 265941 screen." 265942 265943 ^direction! ! 265944 265945!Pen methodsFor: 'accessing'! 265946location 265947 "Answer where the receiver is currently located." 265948 265949 ^location! ! 265950 265951 265952!Pen methodsFor: 'geometric designs' stamp: 'di 6/11/1998 22:01'! 265953dragon: n "Display restoreAfter: [Display fillWhite. Pen new dragon: 10]." 265954 "Display restoreAfter: [Display fillWhite. 1 to: 4 do: 265955 [:i | Pen new color: i; turn: 90*i; dragon: 10]]" 265956 "Draw a dragon curve of order n in the center of the screen." 265957 n = 0 265958 ifTrue: [self go: 5] 265959 ifFalse: [n > 0 265960 ifTrue: [self dragon: n - 1; turn: 90; dragon: 1 - n] 265961 ifFalse: [self dragon: -1 - n; turn: -90; dragon: 1 + n]] 265962! ! 265963 265964!Pen methodsFor: 'geometric designs' stamp: 'lr 7/4/2009 10:42'! 265965filberts: n side: s 265966 "Display restoreAfter: [Pen new filberts: 4 side: 5]" 265967 "Two Hilbert curve fragments form a Hilbert tile. Draw four interlocking 265968 tiles of order n and sides length s." 265969 | n2 | 265970 Display fillWhite. 265971 n2 := 1 bitShift: n - 1. 265972 self 265973 up; 265974 go: (0 - n2) * s; 265975 down. 265976 1 265977 to: 4 265978 do: 265979 [ :i | 265980 self 265981 fill: 265982 [ :p | 265983 p 265984 hilbert: n 265985 side: s. 265986 p go: s. 265987 p 265988 hilbert: n 265989 side: s. 265990 p go: s. 265991 p up. 265992 p go: (n2 - 1) * s. 265993 p turn: -90. 265994 p go: n2 * s. 265995 p turn: 180. 265996 p down ] 265997 color: (Color perform: (#(#yellow #red #green #blue ) at: i)) ]! ! 265998 265999!Pen methodsFor: 'geometric designs' stamp: 'lr 7/4/2009 10:42'! 266000hilbert: n side: s 266001 "Draw an nth level Hilbert curve with side length s in the center of the 266002 screen. Write directly into the display's bitmap only. A Hilbert curve is 266003 a space-filling curve." 266004 | a m | 266005 n = 0 ifTrue: [ ^ self turn: 180 ]. 266006 n > 0 266007 ifTrue: 266008 [ a := 90. 266009 m := n - 1 ] 266010 ifFalse: 266011 [ a := -90. 266012 m := n + 1 ]. 266013 self turn: a. 266014 self 266015 hilbert: 0 - m 266016 side: s. 266017 self 266018 turn: a; 266019 go: s. 266020 self 266021 hilbert: m 266022 side: s. 266023 self 266024 turn: 0 - a; 266025 go: s; 266026 turn: 0 - a. 266027 self 266028 hilbert: m 266029 side: s. 266030 self 266031 go: s; 266032 turn: a. 266033 self 266034 hilbert: 0 - m 266035 side: s. 266036 self turn: a 266037 " 266038 (Pen new) hilbert: 3 side: 8. 266039 (Pen new sourceForm: Cursor wait) combinationRule: Form under; 266040 hilbert: 3 side: 25. 266041 "! ! 266042 266043!Pen methodsFor: 'geometric designs' stamp: 'lr 7/4/2009 10:42'! 266044hilberts: n 266045 "Display restoreAfter: [Display fillWhite. Pen new hilberts: 5]" 266046 "Draws n levels of nested Hilbert curves" 266047 | s | 266048 self 266049 up; 266050 turn: 90; 266051 go: 128; 266052 down. 266053 1 266054 to: n 266055 do: 266056 [ :i | 266057 s := 256 bitShift: 0 - i. 266058 self defaultNib: (n - i) * 2 + 1. 266059 self color: i + 1. 266060 self 266061 up; 266062 go: (0 - s) / 2; 266063 turn: -90; 266064 go: s / 2; 266065 turn: 90; 266066 down. 266067 self 266068 hilbert: i 266069 side: s. 266070 self go: s. 266071 self 266072 hilbert: i 266073 side: s. 266074 self go: s ]! ! 266075 266076!Pen methodsFor: 'geometric designs' stamp: 'lr 7/4/2009 10:42'! 266077mandala: npoints 266078 "Display restoreAfter: [Pen new mandala: 30]" 266079 "On a circle of diameter d, place npoints number of points. Draw all possible connecting lines between the circumferential points." 266080 | l points d | 266081 Display fillWhite. 266082 d := Display height - 50. 266083 l := 3.14 * d / npoints. 266084 self 266085 home; 266086 up; 266087 turn: -90; 266088 go: d // 2; 266089 turn: 90; 266090 go: (0 - l) / 2; 266091 down. 266092 points := Array new: npoints. 266093 1 266094 to: npoints 266095 do: 266096 [ :i | 266097 points 266098 at: i 266099 put: location rounded. 266100 self 266101 go: l; 266102 turn: 360.0 / npoints ]. 266103 npoints // 2 266104 to: 1 266105 by: -1 266106 do: 266107 [ :i | 266108 self color: i. 266109 1 266110 to: npoints 266111 do: 266112 [ :j | 266113 self place: (points at: j). 266114 self goto: (points at: (j + i - 1) \\ npoints + 1) ] ]! ! 266115 266116!Pen methodsFor: 'geometric designs' stamp: 'jm 5/6/1998 22:26'! 266117spiral: n angle: a 266118 "Draw a double squiral (see Papert, MindStorms), where each design is made 266119 by moving the receiver a distance of n after turning the amount + or -a." 266120 266121 1 to: n do: 266122 [:i | 266123 self color: i * 2. 266124 self go: i; turn: a] 266125" 266126 Display restoreAfter: [ 266127 Display fillWhite. Pen new spiral: 200 angle: 89; home; spiral: 200 angle: -89]. 266128"! ! 266129 266130!Pen methodsFor: 'geometric designs' stamp: 'lr 7/4/2009 10:42'! 266131web 266132 "Display restoreAfter: [Pen new web]" 266133 "Draw pretty web-like patterns from the mouse movement on the screen. 266134 Press the mouse button to draw, option-click to exit. 266135 By Dan Ingalls and Mark Lentczner. " 266136 "self erase." 266137 | history newPoint ancientPoint lastPoint filter color | 266138 color := 1. 266139 [ true ] whileTrue: 266140 [ history := OrderedCollection new. 266141 Sensor waitButton. 266142 Sensor yellowButtonPressed ifTrue: [ ^ self ]. 266143 filter := lastPoint := Sensor cursorPoint. 266144 20 timesRepeat: [ history addLast: lastPoint ]. 266145 self color: (color := color + 1). 266146 [ Sensor redButtonPressed ] whileTrue: 266147 [ newPoint := Sensor cursorPoint. 266148 newPoint = lastPoint ifFalse: 266149 [ ancientPoint := history removeFirst. 266150 filter := (filter * 4 + newPoint) // 5. 266151 self place: filter. 266152 self goto: ancientPoint. 266153 lastPoint := newPoint. 266154 history addLast: filter ] ] ]! ! 266155 266156 266157!Pen methodsFor: 'initialization' stamp: 'jm 4/28/1998 04:02'! 266158defaultNib: widthInteger 266159 "Nib is the tip of a pen. This sets up the pen, with a nib of width widthInteger. You can also set the shape of the pen nib using: 266160 roundNib: widthInteger, or 266161 squareNib: widthInteger, or 266162 sourceForm: aForm" 266163"Example: 266164 | bic | 266165 bic _ Pen new sourceForm: Cursor normal. 266166 bic combinationRule: Form paint; turn: 90. 266167 10 timesRepeat: [bic down; go: 3; up; go: 10]." 266168 266169 self color: Color black. 266170 self squareNib: widthInteger. 266171! ! 266172 266173!Pen methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 266174roundNib: diameter 266175 "Makes this pen draw with a round dot of the given diameter." 266176 self sourceForm: (Form dotOfSize: diameter). 266177 combinationRule := Form paint! ! 266178 266179!Pen methodsFor: 'initialization' stamp: 'jm 4/28/1998 04:03'! 266180squareNib: widthInteger 266181 "Makes this pen draw with a square nib of the given width." 266182 266183 self sourceForm: (Form extent: widthInteger @widthInteger) fillBlack. 266184 self combinationRule: Form over. "a bit faster than paint mode" 266185! ! 266186 266187 266188!Pen methodsFor: 'operations' stamp: 'sw 10/5/2002 03:17'! 266189arrowHead 266190 "Put an arrowhead on the previous pen stroke" 266191 " | pen | pen _ Pen new. 20 timesRepeat: [pen turn: 360//20; go: 20; arrowHead]." 266192 266193 penDown ifTrue: 266194 [self arrowHeadFrom: (direction degreeCos @ direction degreeSin) * -40 + location 266195 to: location 266196 arrowSpec: (Preferences parameterAt: #arrowSpec ifAbsent: [5 @ 4])]! ! 266197 266198!Pen methodsFor: 'operations' stamp: 'sw 10/5/2002 02:29'! 266199arrowHeadForArrowSpec: anArrowSpec 266200 "Put an arrowhead on the previous pen stroke" 266201" 266202 | pen aPoint | 266203 aPoint _ Point fromUser. 266204 pen _ Pen new. 266205 20 timesRepeat: [pen turn: 360//20; go: 20; arrowHeadForArrowSpec: aPoint]. 266206" 266207 266208 266209 penDown ifTrue: 266210 [self arrowHeadFrom: (direction degreeCos @ direction degreeSin) * -40 + location 266211 to: location 266212 arrowSpec: anArrowSpec]! ! 266213 266214!Pen methodsFor: 'operations' stamp: 'lr 7/4/2009 10:42'! 266215arrowHeadFrom: prevPt to: newPt arrowSpec: anArrowSpec 266216 "Put an arrowhead on the pen stroke from oldPt to newPt" 266217 | pm af myColor finalPt delta | 266218 myColor := self color. 266219 delta := newPt - prevPt. 266220 delta r <= 2 ifTrue: 266221 [ "pixels" 266222 ^ self ]. 266223 finalPt := newPt + (Point 266224 r: sourceForm width 266225 degrees: delta degrees). "in same direction" 266226 pm := PolygonMorph 266227 vertices: (Array 266228 with: prevPt asIntegerPoint 266229 with: finalPt asIntegerPoint) 266230 color: myColor 266231 borderWidth: sourceForm width 266232 borderColor: myColor. "not used" 266233 pm 266234 makeOpen; 266235 makeForwardArrow. 266236 anArrowSpec ifNotNil: [ pm arrowSpec: anArrowSpec ]. 266237 af := pm arrowForms first. 266238 "render it onto the destForm" 266239 (FormCanvas on: destForm) 266240 stencil: af 266241 at: af offset + (1 @ 1) 266242 color: myColor "Display"! ! 266243 266244!Pen methodsFor: 'operations' stamp: 'lr 7/4/2009 10:42'! 266245color: aColorOrInteger 266246 "Set the pen to the given color or to a color chosen from a fixed set of colors." 266247 | count c | 266248 aColorOrInteger isInteger 266249 ifTrue: 266250 [ destForm depth = 1 ifTrue: [ ^ self fillColor: Color black ]. 266251 count := 19. "number of colors in color wheel" 266252 c := (Color red wheel: count) at: aColorOrInteger * 7 \\ count + 1 ] 266253 ifFalse: [ c := aColorOrInteger ]. "assume aColorOrInteger is a Color" 266254 self fillColor: c! ! 266255 266256!Pen methodsFor: 'operations' stamp: 'lr 7/4/2009 10:42'! 266257down 266258 "Set the state of the receiver's pen to down (drawing)." 266259 penDown := true! ! 266260 266261!Pen methodsFor: 'operations' stamp: 'lr 7/4/2009 10:42'! 266262fill: drawBlock color: color 266263 | region tileForm tilePen shape saveColor recorder | 266264 drawBlock value: (recorder := self as: PenPointRecorder). 266265 region := Rectangle encompassing: recorder points. 266266 tileForm := Form extent: region extent + 6. 266267 tilePen := Pen newOnForm: tileForm. 266268 tilePen 266269 location: location - (region origin - 3) 266270 direction: direction 266271 penDown: penDown. 266272 drawBlock value: tilePen. "Draw the shape in B/W" 266273 saveColor := halftoneForm. 266274 drawBlock value: self. 266275 halftoneForm := saveColor. 266276 shape := (tileForm findShapeAroundSeedBlock: [ :f | f borderWidth: 1 ]) reverse. 266277 shape 266278 copy: shape boundingBox 266279 from: tileForm 266280 to: 0 @ 0 266281 rule: Form erase. 266282 destForm 266283 fillShape: shape 266284 fillColor: color 266285 at: region origin - 3! ! 266286 266287!Pen methodsFor: 'operations'! 266288go: distance 266289 "Move the pen in its current direction a number of bits equal to the 266290 argument, distance. If the pen is down, a line will be drawn using the 266291 receiver's form source as the shape of the drawing brush." 266292 266293 self goto: (direction degreeCos @ direction degreeSin) * distance + location! ! 266294 266295!Pen methodsFor: 'operations' stamp: 'lr 7/4/2009 10:42'! 266296goto: aPoint 266297 "Move the receiver to position aPoint. If the pen is down, a line will be 266298 drawn from the current position to the new one using the receiver's 266299 form source as the shape of the drawing brush. The receiver's set 266300 direction does not change." 266301 | old | 266302 old := location. 266303 location := aPoint. 266304 penDown ifTrue: 266305 [ self 266306 drawFrom: old rounded 266307 to: location rounded 266308 266309 "NOTE: This should be changed so it does NOT draw the first point, so as 266310 not to overstrike at line junctions. At the same time, place should draw 266311 a single dot if the pen is down, as should down (put-pen-down) if it 266312 was not down before." ]! ! 266313 266314!Pen methodsFor: 'operations' stamp: 'lr 7/4/2009 10:42'! 266315home 266316 "Place the receiver at the center of its frame." 266317 location := destForm boundingBox center! ! 266318 266319!Pen methodsFor: 'operations' stamp: 'lr 7/4/2009 10:42'! 266320north 266321 "Set the receiver's direction to facing toward the top of the display screen." 266322 direction := 270! ! 266323 266324!Pen methodsFor: 'operations' stamp: 'lr 7/4/2009 10:42'! 266325place: aPoint 266326 "Set the receiver at position aPoint. No lines are drawn." 266327 location := aPoint! ! 266328 266329!Pen methodsFor: 'operations' stamp: 'lr 7/4/2009 10:42'! 266330print: str withFont: font 266331 "Print the given string in the given font at the current heading" 266332 | lineStart form charStart rowStart scale wasDown bb pix | 266333 scale := sourceForm width. 266334 wasDown := penDown. 266335 lineStart := location. 266336 str do: 266337 [ :char | 266338 char = Character cr 266339 ifTrue: 266340 [ self 266341 place: lineStart; 266342 up; 266343 turn: 90; 266344 go: font height * scale; 266345 turn: -90; 266346 down ] 266347 ifFalse: 266348 [ form := font characterFormAt: char. 266349 charStart := location. 266350 wasDown ifTrue: 266351 [ self 266352 up; 266353 turn: -90; 266354 go: font descent * scale; 266355 turn: 90; 266356 down. 266357 0 266358 to: form height - 1 266359 do: 266360 [ :y | 266361 rowStart := location. 266362 bb := BitBlt current bitPeekerFromForm: form. 266363 pix := RunArray newFrom: ((0 to: form width - 1) collect: [ :x | bb pixelAt: x @ y ]). 266364 pix runs 266365 with: pix values 266366 do: 266367 [ :run :value | 266368 value = 0 266369 ifTrue: 266370 [ self 266371 up; 266372 go: run * scale; 266373 down ] 266374 ifFalse: [ self go: run * scale ] ]. 266375 self 266376 place: rowStart; 266377 up; 266378 turn: 90; 266379 go: scale; 266380 turn: -90; 266381 down ] ]. 266382 self 266383 place: charStart; 266384 up; 266385 go: form width * scale; 266386 down ] ]. 266387 wasDown ifFalse: 266388 [ self up 266389 " 266390Display restoreAfter: 266391[Pen new squareNib: 2; color: Color red; turn: 45; 266392 print: 'The owl and the pussycat went to sea 266393in a beautiful pea green boat.' withFont: TextStyle defaultFont] 266394" ]! ! 266395 266396!Pen methodsFor: 'operations' stamp: 'sw 4/10/2003 22:37'! 266397putDotOfDiameter: aDiameter at: aPoint 266398 "Put a dot of the given size at the given point, using my colot" 266399 266400 (FormCanvas on: destForm) 266401 fillOval: (Rectangle center: aPoint extent: (aDiameter @ aDiameter)) 266402 color: self color! ! 266403 266404!Pen methodsFor: 'operations' stamp: 'lr 7/4/2009 10:42'! 266405turn: degrees 266406 "Change the direction that the receiver faces by an amount equal to the 266407 argument, degrees." 266408 direction := direction + degrees! ! 266409 266410!Pen methodsFor: 'operations' stamp: 'lr 7/4/2009 10:42'! 266411up 266412 "Set the state of the receiver's pen to up (no drawing)." 266413 penDown := false! ! 266414 266415 266416!Pen methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 266417location: aPoint direction: aFloat penDown: aBoolean 266418 location := aPoint. 266419 direction := aFloat. 266420 penDown := aBoolean! ! 266421 266422!Pen methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 266423sourceForm: aForm 266424 (aForm depth = 1 and: [ destForm depth > 1 ]) 266425 ifTrue: 266426 [ "Map 1-bit source to all ones for color mask" 266427 colorMap := Bitmap 266428 with: 0 266429 with: 4294967295 ] 266430 ifFalse: [ colorMap := nil ]. 266431 ^ super sourceForm: aForm! ! 266432 266433"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 266434 266435Pen class 266436 instanceVariableNames: ''! 266437 266438!Pen class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 266439example 266440 "Draw a spiral with a pen that is 2 pixels wide." 266441 "Display restoreAfter: [Pen example]" 266442 | bic | 266443 bic := self new. 266444 bic defaultNib: 2. 266445 bic color: Color blue. 266446 bic combinationRule: Form over. 266447 1 266448 to: 100 266449 do: 266450 [ :i | 266451 bic go: i * 4. 266452 bic turn: 89 ]! ! 266453 266454 266455!Pen class methodsFor: 'instance creation'! 266456new 266457 ^ self newOnForm: Display! ! 266458 266459!Pen class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 266460newOnForm: aForm 266461 | pen | 266462 pen := super new. 266463 pen setDestForm: aForm. 266464 pen sourceOrigin: 0 @ 0. 266465 pen home. 266466 pen defaultNib: 1. 266467 pen north. 266468 pen down. 266469 ^ pen! ! 266470 266471 266472!Pen class methodsFor: 'tablet drawing examples' stamp: 'lr 7/4/2009 10:42'! 266473feltTip: width cellSize: cellSize 266474 "Warning: This example potentially uses a large amount of memory--it creates a Form with cellSize squared bits for every Display pixel." 266475 "In this example, all drawing is done into a large, monochrome Form and then scaled down onto the Display using smoothing. The larger the cell size, the more possible shades of gray can be generated, and the smoother the resulting line appears. A cell size of 8 yields 64 possible grays, while a cell size of 16 gives 256 levels, which is about the maximum number of grays that the human visual system can distinguish. The width parameter determines the maximum line thickness. Requires the optional tablet support primitives which may not be supported on all platforms. Works best in full screen mode. Shift-mouse to exit." 266476 "Pen feltTip: 2.7 cellSize: 8" 266477 | tabletScale bitForm pen warp p srcR dstR nibSize startP r | 266478 tabletScale := self tabletScaleFactor. 266479 bitForm := Form 266480 extent: Display extent * cellSize 266481 depth: 1. 266482 pen := Pen newOnForm: bitForm. 266483 pen color: Color black. 266484 warp := (WarpBlt current toForm: Display) 266485 sourceForm: bitForm; 266486 colorMap: (bitForm colormapIfNeededFor: Display); 266487 cellSize: cellSize; 266488 combinationRule: Form over. 266489 Display fillColor: Color white. 266490 Display restoreAfter: 266491 [ [ Sensor shiftPressed and: [ Sensor anyButtonPressed ] ] whileFalse: 266492 [ p := (Sensor tabletPoint * cellSize * tabletScale) rounded. 266493 nibSize := (Sensor tabletPressure * (cellSize * width)) rounded. 266494 nibSize > 0 266495 ifTrue: 266496 [ pen squareNib: nibSize. 266497 startP := pen location. 266498 pen goto: p. 266499 r := startP rect: pen location. 266500 dstR := r origin // cellSize corner: (r corner + nibSize + (cellSize - 1)) // cellSize. 266501 srcR := dstR origin * cellSize corner: dstR corner * cellSize. 266502 warp 266503 copyQuad: srcR innerCorners 266504 toRect: dstR ] 266505 ifFalse: [ pen place: p ] ] ]! ! 266506 266507!Pen class methodsFor: 'tablet drawing examples' stamp: 'lr 7/4/2009 10:42'! 266508inkBrush 266509 "Similar to simplePressurePen, but this example uses the average of the recent pen pressure values. The effect is that of a Japanese ink brush that comes up gradually off the paper as the brush is lifted, causing end (and beginning) of each stroke to taper. Requires the optional tablet support primitives which may not be supported on all platforms. Works best in full screen mode. Shift-mouse to exit." 266510 "Pen inkBrush" 266511 | tabletScale historyMSecs pressureHistory pen now currentPressure sum averagePressure p | 266512 tabletScale := self tabletScaleFactor. 266513 historyMSecs := 120. 266514 pressureHistory := OrderedCollection new. 266515 pen := Pen newOnForm: Display. 266516 pen color: Color black. 266517 Display fillColor: Color white. 266518 Display restoreAfter: 266519 [ [ Sensor shiftPressed and: [ Sensor anyButtonPressed ] ] whileFalse: 266520 [ "compute the average pressure over last historyMSecs milliseconds" 266521 now := Time millisecondClockValue. 266522 currentPressure := (20.0 * Sensor tabletPressure) rounded. 266523 pressureHistory addLast: (Array 266524 with: now 266525 with: currentPressure). 266526 266527 [ pressureHistory size > 0 and: [ pressureHistory first first + historyMSecs < now ] ] whileTrue: [ pressureHistory removeFirst ]. "prune old entries" 266528 sum := pressureHistory 266529 inject: 0 266530 into: [ :t :e | t + e last ]. 266531 averagePressure := sum // pressureHistory size. 266532 p := (Sensor tabletPoint * tabletScale) rounded. 266533 averagePressure > 0 266534 ifTrue: 266535 [ pen roundNib: averagePressure. 266536 pen goto: p ] 266537 ifFalse: [ pen place: p ] ] ]! ! 266538 266539!Pen class methodsFor: 'tablet drawing examples' stamp: 'lr 7/4/2009 10:42'! 266540simplePressurePen 266541 "An example of using a pressure sensitive pen to control the thickness of the pen. This requires the optional tablet support primitives which may not be supported on all platforms. Works best in full screen mode. Shift-mouse to exit." 266542 "Pen simplePressurePen" 266543 | tabletScale pen pressure p | 266544 tabletScale := self tabletScaleFactor. 266545 pen := Pen newOnForm: Display. 266546 pen color: Color black. 266547 Display fillColor: Color white. 266548 Display restoreAfter: 266549 [ [ Sensor shiftPressed and: [ Sensor anyButtonPressed ] ] whileFalse: 266550 [ p := (Sensor tabletPoint * tabletScale) rounded. 266551 pressure := (15.0 * Sensor tabletPressure) rounded. 266552 pressure > 0 266553 ifTrue: 266554 [ pen roundNib: pressure. 266555 pen goto: p ] 266556 ifFalse: [ pen place: p ] ] ]! ! 266557 266558!Pen class methodsFor: 'tablet drawing examples' stamp: 'lr 7/4/2009 10:42'! 266559tabletScaleFactor 266560 "Answer a Point that scales tablet coordinates to Display coordinates, where the full extent of the tablet maps to the extent of the entire Display." 266561 | tabletExtent | 266562 tabletExtent := Sensor tabletExtent. 266563 ^ (Display width asFloat / tabletExtent x) @ (Display height asFloat / tabletExtent y)! ! 266564 266565!Pen class methodsFor: 'tablet drawing examples' stamp: 'lr 7/4/2009 10:42'! 266566testMouseTracking 266567 "A very simple example of drawing using the mouse. Compare the tracking speed of this example with that of testTabletTracking. Mouse down to draw a stroke, shift-mouse to exit." 266568 "Pen testMouseTracking" 266569 | pen p | 266570 pen := Pen newOnForm: Display. 266571 pen roundNib: 8. 266572 pen color: Color black. 266573 Display fillColor: Color white. 266574 Display restoreAfter: 266575 [ [ Sensor shiftPressed and: [ Sensor anyButtonPressed ] ] whileFalse: 266576 [ p := Sensor cursorPoint. 266577 Sensor anyButtonPressed 266578 ifTrue: [ pen goto: p ] 266579 ifFalse: 266580 [ pen color: Color random. 266581 pen place: p ] ] ]! ! 266582 266583!Pen class methodsFor: 'tablet drawing examples' stamp: 'lr 7/4/2009 10:42'! 266584testTabletTracking 266585 "A very simple example of drawing using the pen of a digitizing tablet such as a Wacom ArtZ tablet. This requires the optional tablet support primitives which may not be supported on all platforms. Compare the tracking speed of this example with that of testMouseTracking. On a Macintosh, the tablet primitives provide roughly 120 samples/second versus only 60 mouse samples/second, and the difference is noticable. Works best in full screen mode. Mouse down to draw a stroke, shift-mouse to exit." 266586 "Pen testTabletTracking" 266587 | tabletScale pen p | 266588 tabletScale := self tabletScaleFactor. 266589 pen := Pen newOnForm: Display. 266590 pen roundNib: 8. 266591 pen color: Color black. 266592 Display fillColor: Color white. 266593 Display restoreAfter: 266594 [ [ Sensor shiftPressed and: [ Sensor anyButtonPressed ] ] whileFalse: 266595 [ p := (Sensor tabletPoint * tabletScale) rounded. 266596 Sensor tabletPressure > 0 266597 ifTrue: [ pen goto: p ] 266598 ifFalse: 266599 [ pen color: Color random. 266600 pen place: p ] ] ]! ! 266601Pen subclass: #PenPointRecorder 266602 instanceVariableNames: 'points' 266603 classVariableNames: '' 266604 poolDictionaries: '' 266605 category: 'Graphics-Primitives'! 266606!PenPointRecorder commentStamp: '<historical>' prior: 0! 266607This class is a special kind of Pen that instead of actually drawing lines records the destination points for those lines. These points can later be accessed through my accessing method #points. 266608 266609This can be useful when determining the boundaries of a drawing session. 266610 266611Example: 266612 266613| pen | 266614pen _ PenPointRecorder new. 266615pen up; goto: 100@100; down; goto: 120@120. 266616Transcript cr; 266617 show: 'Bounding box for drawing: '; 266618 show: (Rectangle encompassing: pen points) 266619 266620Implementation note: Shouldn't we override #drawFrom:to:withFirstPoint: instead, and what about #drawLoopX:Y:? Aren't we missing those calls?! 266621 266622 266623!PenPointRecorder methodsFor: 'accessing' stamp: 'di 6/21/1998 09:35'! 266624points 266625 ^ points! ! 266626 266627 266628!PenPointRecorder methodsFor: 'line drawing' stamp: 'lr 7/4/2009 10:42'! 266629drawFrom: p1 to: p2 266630 "Overridden to skip drawing but track bounds of the region traversed." 266631 points ifNil: [ points := OrderedCollection with: p1 ]. 266632 points addLast: p2! ! 266633Notification subclass: #PickAFileToWriteNotification 266634 instanceVariableNames: '' 266635 classVariableNames: '' 266636 poolDictionaries: '' 266637 category: 'Exceptions-Kernel'! 266638PanelMorph subclass: #PlainGroupboxMorph 266639 instanceVariableNames: '' 266640 classVariableNames: '' 266641 poolDictionaries: '' 266642 category: 'Polymorph-Widgets'! 266643!PlainGroupboxMorph commentStamp: 'gvc 5/18/2007 12:36' prior: 0! 266644Groupbox without title with a vertical layout. Appears in a lighter colour than the owner's pane colour.! 266645 266646 266647!PlainGroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/17/2008 11:45'! 266648adoptPaneColor: paneColor 266649 "Change our color too." 266650 266651 super adoptPaneColor: (self theme subgroupColorFrom: paneColor). 266652 self borderStyle: (self theme plainGroupPanelBorderStyleFor: self)! ! 266653 266654!PlainGroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/17/2008 11:44'! 266655initialize 266656 "Initialize the receiver." 266657 266658 super initialize. 266659 self 266660 borderStyle: (self theme plainGroupPanelBorderStyleFor: self); 266661 changeTableLayout; 266662 layoutInset: (4@4 corner: 4@4); 266663 cellInset: 8; 266664 vResizing: #spaceFill; 266665 hResizing: #spaceFill! ! 266666 266667!PlainGroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2008 13:37'! 266668paneColorOrNil 266669 "Answer the window's pane color or nil otherwise." 266670 266671 ^super paneColorOrNil ifNotNilDo: [:c | self theme subgroupColorFrom: c]! ! 266672PluggableButtonSpec subclass: #PluggableActionButtonSpec 266673 instanceVariableNames: '' 266674 classVariableNames: '' 266675 poolDictionaries: '' 266676 category: 'ToolBuilder-Kernel'! 266677!PluggableActionButtonSpec commentStamp: 'ar 2/12/2005 23:12' prior: 0! 266678PluggableActionButtonSpec is intentded as a HINT for the builder that this widget will be used as push (action) button. Unless explicitly supported it will be automatically substituted by PluggableButton.! 266679 266680 266681!PluggableActionButtonSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'! 266682buildWith: builder 266683 ^builder buildPluggableActionButton: self! ! 266684AlignmentMorph subclass: #PluggableButtonMorph 266685 instanceVariableNames: 'model label getStateSelector actionSelector getLabelSelector getMenuSelector shortcutCharacter askBeforeChanging triggerOnMouseDown offColor onColor feedbackColor showSelectionFeedback allButtons arguments argumentsProvider argumentsSelector' 266686 classVariableNames: '' 266687 poolDictionaries: '' 266688 category: 'Morphic-Pluggable Widgets'! 266689!PluggableButtonMorph commentStamp: '<historical>' prior: 0! 266690A PluggableButtonMorph is a combination of an indicator for a boolean value stored in its model and an action button. The action of a button is often, but not always, to toggle the boolean value that it shows. Its pluggable selectors are: 266691 266692 getStateSelector fetch a boolean value from the model 266693 actionSelector invoke this button's action on the model 266694 getLabelSelector fetch this button's lable from the model 266695 getMenuSelector fetch a pop-up menu for this button from the model 266696 266697Any of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. For example, if getStateSelector is nil, then this button shows the state of a read-only boolean that is always false. 266698 266699The model informs its view(s) of changes by sending #changed: to itself with getStateSelector as a parameter. The view tells the model when the button is pressed by sending actionSelector. 266700 266701If the actionSelector takes one or more arguments, then the following are relevant: 266702 arguments A list of arguments to provide when the actionSelector is called. 266703 argumentsProvider The object that is sent the argumentSelector to obtain arguments, if dynamic 266704 argumentsSelector The message sent to the argumentProvider to obtain the arguments. 266705 266706Options: 266707 askBeforeChanging have model ask user before allowing a change that could lose edits 266708 triggerOnMouseDown do this button's action on mouse down (vs. up) transition 266709 shortcutCharacter a place to record an optional shortcut key 266710! 266711 266712 266713!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/23/2007 11:25'! 266714action 266715 "Answer the action selector." 266716 266717 ^self actionSelector! ! 266718 266719!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/23/2007 11:26'! 266720actionSelector: aSymbol 266721 "Set actionSelector to be the action defined by aSymbol. 266722 SimpleButtonMorph cross-compatibility" 266723 266724 actionSelector := aSymbol. 266725! ! 266726 266727!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 16:14'! 266728adoptColor: aColor 266729 "Go through paneColorChanged instead." 266730 266731 self paneColorChanged! ! 266732 266733!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/8/2006 12:21'! 266734adoptPaneColor: aColor 266735 266736 super adoptPaneColor: aColor. 266737 Preferences gradientButtonLook ifFalse:[^self]. 266738 aColor ifNil: [^self]. 266739 self adoptColor: self colorToUse! ! 266740 266741!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/23/2007 11:27'! 266742arguments 266743 "Answer the static arguments. 266744 SimpleButtonMorph cross-compatibility." 266745 266746 ^arguments! ! 266747 266748!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/12/2007 12:23'! 266749borderStyleToUse 266750 "Return the borderStyle to use for the receiver." 266751 266752 |state mo| 266753 Preferences gradientButtonLook ifFalse:[^super borderStyle]. 266754 state := self getModelState. 266755 mo := self containsMousePoint. 266756 ^(self enabled ifNil: [true]) 266757 ifTrue: [showSelectionFeedback 266758 ifTrue: [state 266759 ifTrue: [self selectedPressedBorderStyle] 266760 ifFalse: [self pressedBorderStyle]] 266761 ifFalse: [mo 266762 ifTrue: [state 266763 ifTrue: [self selectedMouseOverBorderStyle] 266764 ifFalse: [self mouseOverBorderStyle]] 266765 ifFalse: [state 266766 ifTrue: [self selectedBorderStyle] 266767 ifFalse: [self normalBorderStyle]]]] 266768 ifFalse: [state 266769 ifTrue: [self selectedDisabledBorderStyle] 266770 ifFalse: [self disabledBorderStyle]]! ! 266771 266772!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/15/2009 12:22'! 266773changed 266774 "Update the fillStyle here." 266775 266776 |lc pc bs| 266777 self borderWidth > 0 ifTrue: [ 266778 self setProperty: #borderStyle toValue: (bs := self borderStyleToUse). 266779 borderColor := bs style. 266780 borderWidth := bs width]. 266781 self setProperty: #fillStyle toValue: self fillStyleToUse.. 266782 self layoutInset: (self theme buttonLabelInsetFor: self). 266783 color := self fillStyle asColor. 266784 (self labelMorph respondsTo: #enabled:) 266785 ifTrue: [self labelMorph enabled: self enabled] 266786 ifFalse: [(self labelMorph isNil 266787 or: [label isMorph]) ifFalse: [ 266788 pc := self normalColor. 266789 lc := self enabled 266790 ifTrue: [pc contrastingColor] 266791 ifFalse: [pc contrastingColor muchDarker]. 266792 self labelMorph color: lc]]. 266793 super changed! ! 266794 266795!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/8/2006 13:29'! 266796color: aColor 266797 "Check to avoid repeats of the same color." 266798 266799 aColor ifNil: [^self]. 266800 ((self valueOfProperty: #lastColor) = aColor and: [ 266801 self getModelState = (self valueOfProperty: #lastState)]) 266802 ifTrue: [^self]. 266803 super color: aColor. 266804 Preferences gradientButtonLook ifTrue:[self adoptColor: aColor]! ! 266805 266806!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 14:08'! 266807colorToUse 266808 "Answer the color we should use." 266809 266810 |c| 266811 c := self getModelState 266812 ifTrue: [onColor 266813 ifNil: [self paneColor] 266814 ifNotNil: [onColor isTransparent 266815 ifTrue: [self paneColor] 266816 ifFalse: [onColor]]] 266817 ifFalse: [offColor 266818 ifNil: [self paneColor] 266819 ifNotNil: [offColor isTransparent 266820 ifTrue: [self paneColor] 266821 ifFalse: [offColor]]]. 266822 ^c! ! 266823 266824!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 14:08'! 266825containsMousePoint 266826 "Answer whether the mouse is in the receiver and our window is active. 266827 Not ideal, but no easy way of determining if a mouse over would be sent 266828 to the receiver." 266829 266830 |w| 266831 w := self ownerThatIsA: SystemWindow. 266832 (w notNil and: [w isActive not]) ifTrue: [^false]. 266833 ^self containsPoint: (self globalPointToLocal: Sensor peekMousePt)! ! 266834 266835!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/19/2007 13:04'! 266836contentHolder 266837 "Answer the alignment morph for extra control." 266838 266839 ^self submorphs first! ! 266840 266841!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/11/2009 16:42'! 266842cornerStyle: aSymbol 266843 "Adjust the layout inset." 266844 266845 super cornerStyle: aSymbol. 266846 self layoutInset: (self theme buttonLabelInsetFor: self)! ! 266847 266848!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:53'! 266849disabledBorderStyle 266850 "Return the disabled borderStyle of the receiver." 266851 266852 ^self theme buttonDisabledBorderStyleFor: self! ! 266853 266854!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:53'! 266855disabledFillStyle 266856 "Return the disabled fillStyle of the receiver." 266857 266858 ^self theme buttonDisabledFillStyleFor: self! ! 266859 266860!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/17/2007 15:19'! 266861drawSubmorphsOn: aCanvas 266862 "Display submorphs back to front. 266863 Draw the focus here since we are using inset bounds 266864 for the focus rectangle." 266865 266866 super drawSubmorphsOn: aCanvas. 266867 self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOn: aCanvas]! ! 266868 266869!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 12/5/2008 15:07'! 266870extent: aPoint 266871 "Set the receiver's extent to value provided. 266872 Update the gradient fills." 266873 266874 |answer| 266875 aPoint = self extent ifTrue: [^super extent: aPoint]. 266876 answer := super extent: aPoint. 266877 Preferences gradientButtonLook ifTrue: [ 266878 self fillStyle isOrientedFill 266879 ifTrue: [self fillStyle: self fillStyleToUse]]. 266880 ^answer! ! 266881 266882!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/14/2007 13:41'! 266883fillStyleToUse 266884 "Return the fillStyle to use for the receiver." 266885 266886 |fs state mo| 266887 fs := super fillStyle. 266888 Preferences gradientButtonLook ifFalse:[^fs]. 266889 state := self getModelState. 266890 mo := self containsMousePoint. 266891 fs := (self enabled ifNil: [true]) 266892 ifTrue: [showSelectionFeedback 266893 ifTrue: [state 266894 ifTrue: [self selectedPressedFillStyle] 266895 ifFalse: [self pressedFillStyle]] 266896 ifFalse: [mo 266897 ifTrue: [state 266898 ifTrue: [self selectedMouseOverFillStyle] 266899 ifFalse: [self mouseOverFillStyle]] 266900 ifFalse: [state 266901 ifTrue: [self selectedFillStyle] 266902 ifFalse: [self normalFillStyle]]]] 266903 ifFalse: [state 266904 ifTrue: [self selectedDisabledFillStyle] 266905 ifFalse: [self disabledFillStyle]]. 266906 ^fs! ! 266907 266908!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 12/4/2007 16:23'! 266909focusBounds 266910 "Answer the bounds for drawing the focus indication." 266911 266912 ^self theme buttonFocusBoundsFor: self! ! 266913 266914!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 15:00'! 266915focusColor 266916 "Answer the keyboard focus indication color." 266917 266918 ^self color contrastingColor! ! 266919 266920!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/9/2009 17:47'! 266921focusIndicatorCornerRadius 266922 "Answer the corner radius preferred for the focus indicator 266923 for the receiver for themes that support this." 266924 266925 ^self theme buttonFocusIndicatorCornerRadiusFor: self ! ! 266926 266927!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/13/2007 15:53'! 266928getMenuSelector: aSymbol 266929 "Set the menu selector." 266930 266931 getMenuSelector := aSymbol! ! 266932 266933!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 14:37'! 266934handlesKeyboard: evt 266935 "Answer true, we'll handle spacebar for pressing plus the usual 266936 tab navigation." 266937 266938 ^true! ! 266939 266940!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/20/2009 15:34'! 266941indicateModalChild 266942 "Flash the button border." 266943 266944 |fs c w d| 266945 fs := self fillStyle. 266946 c := self color alphaMixed: 0.5 with: Color black. 266947 w := self world. 266948 d := 0. 266949 2 timesRepeat: [ 266950 (Delay forDuration: d milliSeconds) wait. 266951 d := 200. 266952 self setProperty: #fillStyle toValue: c. 266953 color := c. 266954 self invalidRect: self bounds. 266955 w ifNotNil: [w displayWorldSafely]. 266956 (Delay forDuration: d milliSeconds) wait. 266957 self fillStyle: fs. 266958 w ifNotNil: [w displayWorldSafely]. 266959 self invalidRect: self bounds] 266960! ! 266961 266962!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/10/2007 12:13'! 266963isDefault 266964 "Answer whether the button is considered to be a default one." 266965 266966 ^self valueOfProperty: #isDefault ifAbsent: [false] ! ! 266967 266968!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/10/2007 12:17'! 266969isDefault: aBoolean 266970 "Set whether the button is to be considered default." 266971 266972 aBoolean 266973 ifTrue: [self setProperty: #isDefault toValue: true] 266974 ifFalse: [self removeProperty: #isDefault]. 266975 self changed! ! 266976 266977!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 15:17'! 266978keyStroke: event 266979 "Process spacebar for action and tab keys for navigation." 266980 266981 (self navigationKey: event) ifTrue: [^self]. 266982 event keyCharacter = Character space 266983 ifTrue: [self performAction]! ! 266984 266985!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/6/2007 14:36'! 266986keyboardFocusChange: aBoolean 266987 "The message is sent to a morph when its keyboard focus changes. 266988 Update for focus feedback." 266989 266990 self focusChanged! ! 266991 266992!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/7/2007 13:21'! 266993labelMorph 266994 "Answer the actual label morph." 266995 266996 self hasSubmorphs ifFalse: [^nil]. 266997 self firstSubmorph hasSubmorphs ifFalse: [^nil]. 266998 ^self firstSubmorph firstSubmorph! ! 266999 267000!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 12/9/2008 11:21'! 267001layoutBounds: aRectangle 267002 "Set the bounds for laying out children of the receiver. 267003 Update the fillstyle since it may depend on the bounds." 267004 267005 super layoutBounds: aRectangle. 267006 Preferences gradientButtonLook ifTrue: [ 267007 self fillStyle isOrientedFill 267008 ifTrue: [self fillStyle: self fillStyleToUse]]! ! 267009 267010!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 12/3/2008 17:23'! 267011minHeight 267012 "Consult the theme also." 267013 267014 ^super minHeight max: self theme buttonMinHeight! ! 267015 267016!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 12/3/2008 17:22'! 267017minWidth 267018 "Consult the theme also." 267019 267020 ^super minWidth max: self theme buttonMinWidth! ! 267021 267022!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/24/2007 13:34'! 267023model 267024 "Answer the receiver's model." 267025 267026 ^model! ! 267027 267028!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:53'! 267029mouseOverBorderStyle 267030 "Return the mouse over borderStyle of the receiver." 267031 267032 ^self theme buttonMouseOverBorderStyleFor: self! ! 267033 267034!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:53'! 267035mouseOverFillStyle 267036 "Return the mouse over fillStyle of the receiver." 267037 267038 ^self theme buttonMouseOverFillStyleFor: self! ! 267039 267040!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267041newLabel 267042 "Answer a new label for the receiver." 267043 267044 ^self theme buttonLabelFor: self! ! 267045 267046!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 14:40'! 267047newLabel: aFont 267048 "Answer a new label for the receiver with the given font." 267049 267050 ^self newLabel 267051 font: aFont! ! 267052 267053!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267054normalBorderStyle 267055 "Return the normal borderStyle of the receiver." 267056 267057 ^self theme buttonNormalBorderStyleFor: self! ! 267058 267059!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267060normalColor 267061 "Return the normal colour for the receiver." 267062 267063 ^self theme buttonColorFor: self! ! 267064 267065!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267066normalFillStyle 267067 "Return the normal fillStyle of the receiver." 267068 267069 ^self theme buttonNormalFillStyleFor: self! ! 267070 267071!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/25/2007 18:44'! 267072onColor 267073 "Answer the on color." 267074 267075 ^onColor 267076! ! 267077 267078!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/11/2009 16:08'! 267079paneColorChanged 267080 "Update the fillStyle here. 267081 Optimised to not send #changed if no changes." 267082 267083 |lc pc| 267084 self borderStyle: self borderStyleToUse. 267085 self fillStyle: self fillStyleToUse. 267086 (self labelMorph isNil 267087 or: [(self labelMorph respondsTo: #enabled:) 267088 or: [label isMorph]]) ifFalse: [ 267089 pc := self normalColor. 267090 lc := self enabled 267091 ifTrue: [pc contrastingColor] 267092 ifFalse: [pc contrastingColor muchDarker]. 267093 self labelMorph color: lc]! ! 267094 267095!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267096pressedBorderStyle 267097 "Return the pressed borderStyle of the receiver." 267098 267099 ^self theme buttonPressedBorderStyleFor: self! ! 267100 267101!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267102pressedFillStyle 267103 "Return the pressed fillStyle of the receiver." 267104 267105 ^self theme buttonPressedFillStyleFor: self! ! 267106 267107!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/11/2009 16:40'! 267108roundedCorners: anArray 267109 "Adjust the layout inset if necessary." 267110 267111 super roundedCorners: anArray. 267112 self layoutInset: (self theme buttonLabelInsetFor: self)! ! 267113 267114!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267115selectedBorderStyle 267116 "Return the selected borderStyle of the receiver." 267117 267118 ^self theme buttonSelectedBorderStyleFor: self! ! 267119 267120!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267121selectedDisabledBorderStyle 267122 "Return the selected disabled borderStyle of the receiver." 267123 267124 ^self theme buttonSelectedDisabledBorderStyleFor: self! ! 267125 267126!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267127selectedDisabledFillStyle 267128 "Return the selected disabled fillStyle of the receiver." 267129 267130 ^self theme buttonSelectedDisabledFillStyleFor: self! ! 267131 267132!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267133selectedFillStyle 267134 "Return the selected fillStyle of the receiver." 267135 267136 ^self theme buttonSelectedFillStyleFor: self! ! 267137 267138!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267139selectedMouseOverBorderStyle 267140 "Return the selected mouse over borderStyle of the receiver." 267141 267142 ^self theme buttonSelectedMouseOverBorderStyleFor: self! ! 267143 267144!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267145selectedMouseOverFillStyle 267146 "Return the selected mouse over fillStyle of the receiver." 267147 267148 ^self theme buttonSelectedMouseOverFillStyleFor: self! ! 267149 267150!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267151selectedPressedBorderStyle 267152 "Return the selected pressed borderStyle of the receiver." 267153 267154 ^self theme buttonSelectedPressedBorderStyleFor: self! ! 267155 267156!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! 267157selectedPressedFillStyle 267158 "Return the selected pressed fillStyle of the receiver." 267159 267160 ^self theme buttonSelectedPressedFillStyleFor: self! ! 267161 267162!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/8/2009 14:26'! 267163showSelectionFeedback 267164 "Answer whether the feedback should be shown for being pressed." 267165 267166 ^showSelectionFeedback! ! 267167 267168!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/15/2009 12:23'! 267169showSelectionFeedback: aBoolean 267170 "Set the feedback." 267171 267172 showSelectionFeedback := aBoolean! ! 267173 267174!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:30'! 267175takesKeyboardFocus 267176 "Answer whether the receiver can normally take keyboard focus." 267177 267178 ^true! ! 267179 267180!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/11/2009 12:14'! 267181themeChanged 267182 "Set the border style to thin gray in the case of going to StandardSqueak." 267183 267184 |labelColor| 267185 (self theme isKindOf: UIThemeStandardSqueak) 267186 ifTrue: [self borderStyle: BorderStyle thinGray]. 267187 self 267188 layoutInset: (self theme buttonLabelInsetFor: self); 267189 cornerStyle: (self theme buttonCornerStyleIn: self window). 267190 (self labelMorph isNil or: [self label isMorph or: [self labelMorph isTextMorph]]) ifFalse: [ 267191 labelColor := self labelMorph color. 267192 self label: self label font: self labelMorph font. 267193 self labelMorph color: labelColor]. 267194 super themeChanged! ! 267195 267196!PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/8/2007 13:43'! 267197wantsKeyboardFocusNavigation 267198 "Answer whether the receiver would like keyboard focus 267199 when navigated to by keyboard." 267200 267201 ^super wantsKeyboardFocusNavigation and: [ 267202 self valueOfProperty: #wantsKeyboardFocusNavigation ifAbsent: [true]]! ! 267203 267204 267205!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/16/2007 15:11'! 267206drawOn: aCanvas 267207 "Avoid the selection feedback." 267208 267209 super drawOn: aCanvas! ! 267210 267211!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/21/2009 14:59'! 267212getModelState 267213 "Answer the result of sending the receiver's model the getStateSelector message. 267214 If the selector expects arguments then supply as for the actionSelector." 267215 267216 ^getStateSelector isNil 267217 ifTrue: [false] 267218 ifFalse: [getStateSelector numArgs == 0 267219 ifTrue: [model perform: getStateSelector] 267220 ifFalse: [argumentsProvider ifNotNil: [ 267221 arguments := argumentsProvider perform: argumentsSelector]. 267222 model perform: getStateSelector withEnoughArguments: arguments]]! ! 267223 267224!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/8/2006 13:40'! 267225handlesMouseOver: evt 267226 267227 ^ true! ! 267228 267229!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/8/2006 13:41'! 267230handlesMouseOverDragging: evt 267231 267232 ^ true! ! 267233 267234!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/21/2009 14:57'! 267235initialize 267236 "Initialize the state of the receiver." 267237 267238 super initialize. 267239 self 267240 rubberBandCells: false; 267241 listDirection: #topToBottom; 267242 hResizing: #shrinkWrap; 267243 vResizing: #shrinkWrap; 267244 wrapCentering: #center; 267245 cellPositioning: #center. 267246 model := nil. 267247 label := nil. 267248 getStateSelector := nil. 267249 actionSelector := nil. 267250 getLabelSelector := nil. 267251 getMenuSelector := nil. 267252 shortcutCharacter := nil. 267253 askBeforeChanging := false. 267254 triggerOnMouseDown := false. 267255 onColor := nil. 267256 offColor := nil. 267257 feedbackColor := nil. 267258 showSelectionFeedback := false. 267259 allButtons := nil. 267260 arguments := #(). 267261 argumentsProvider := nil. 267262 argumentsSelector := nil. 267263 self 267264 layoutInset: (self theme buttonLabelInsetFor: self); 267265 borderStyle: BorderStyle thinGray; 267266 extent: 20@15; 267267 setProperty: #lastState toValue: false; 267268 cornerStyle: (self theme buttonCornerStyleIn: nil)! ! 267269 267270!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/16/2007 10:39'! 267271label: aStringOrTextOrMorph 267272 "Label this button with the given string or morph." 267273 267274 | r | 267275 self removeAllMorphs. 267276 "nest label in a row for centering" 267277 r := AlignmentMorph newRow 267278 borderWidth: 0; 267279 layoutInset: 0; 267280 color: Color transparent; 267281 hResizing: #shrinkWrap; 267282 vResizing: #spaceFill; 267283 wrapCentering: #center; 267284 listCentering: #center; 267285 cellPositioning: #center. 267286 aStringOrTextOrMorph isMorph 267287 ifTrue: [ 267288 label := aStringOrTextOrMorph. 267289 r addMorph: aStringOrTextOrMorph] 267290 ifFalse: [ 267291 label := aStringOrTextOrMorph. 267292 r addMorph: self newLabel]. 267293 self addMorph: r. 267294! ! 267295 267296!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/16/2007 15:27'! 267297label: aStringOrTextOrMorph font: aFont 267298 "Label this button with the given string or morph." 267299 267300 | r | 267301 self removeAllMorphs. 267302 "nest label in a row for centering" 267303 r := AlignmentMorph newRow 267304 borderWidth: 0; 267305 layoutInset: 0; 267306 color: Color transparent; 267307 hResizing: #shrinkWrap; 267308 vResizing: #spaceFill; 267309 wrapCentering: #center; 267310 listCentering: #center; 267311 cellPositioning: #center. 267312 aStringOrTextOrMorph isMorph 267313 ifTrue: [ 267314 label := aStringOrTextOrMorph. 267315 r addMorph: aStringOrTextOrMorph] 267316 ifFalse: [ 267317 label := aStringOrTextOrMorph. 267318 r addMorph: (self newLabel: aFont)]. 267319 self addMorph: r. 267320! ! 267321 267322!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/18/2007 10:59'! 267323mouseEnter: evt 267324 "Update the appearance." 267325 267326 Preferences gradientButtonLook 267327 ifTrue: [self changed] 267328 ifFalse: ["0.09375 is exact in floating point so no cumulative rounding error will occur" 267329 self color: (self color adjustBrightness: -0.09375)]. 267330 super mouseEnter: evt! ! 267331 267332!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/18/2007 11:00'! 267333mouseLeave: evt 267334 "Update the appearance." 267335 267336 Preferences gradientButtonLook 267337 ifTrue: [self changed] 267338 ifFalse: ["0.09375 is exact in floating point so no cumulative rounding error will occur" 267339 self color: (self color adjustBrightness: 0.09375). 267340 self update: nil]. 267341 super mouseLeave: evt! ! 267342 267343!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/2/2009 15:35'! 267344mouseUp: evt 267345 "Perform the button action if the mouse pointer is in a button in the group. 267346 Optimised feedback updates." 267347 267348 |all| 267349 all := allButtons copy. 267350 all ifNotNil: [all do: [:m | 267351 m showSelectionFeedback ifTrue: [ 267352 m showSelectionFeedback: false; changed; layoutChanged]]]. 267353 all ifNil: [^ self]. 267354 allButtons := nil. 267355 all do: [:m | 267356 (m containsPoint: evt cursorPoint) ifTrue: [m enabled ifTrue: [m performAction]]]. 267357 self showSelectionFeedback ifTrue: [self changed] 267358! ! 267359 267360!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/21/2009 12:59'! 267361on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel 267362 "Set up the pluggable parameters. 267363 Update label and state." 267364 267365 self model: anObject. 267366 getStateSelector := getStateSel. 267367 actionSelector := actionSel. 267368 getLabelSelector := labelSel. 267369 getMenuSelector := menuSel. 267370 self 267371 update: labelSel; 267372 update: getStateSel 267373! ! 267374 267375!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/2/2006 12:15'! 267376onColor: colorWhenOn offColor: colorWhenOff 267377 "Set the fill colors to be used when this button is on/off." 267378 267379 onColor := colorWhenOn. 267380 offColor := colorWhenOff. 267381 self update: #onOffColor 267382! ! 267383 267384!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/3/2009 17:40'! 267385update: aParameter 267386 267387 |state| 267388 getLabelSelector ifNotNil: [ 267389 aParameter == getLabelSelector ifTrue: [ 267390 (self labelMorph respondsTo: #font) 267391 ifTrue: [self label: (model perform: getLabelSelector) font: self labelMorph font] 267392 ifFalse: [self label: (model perform: getLabelSelector)]]]. 267393 state := self getModelState. 267394 (state ~= (self valueOfProperty: #lastState) or: [ 267395 getStateSelector isNil and: [aParameter == #onOffColor]]) 267396 ifTrue: [self color: self colorToUse. 267397 self setProperty: #lastState toValue: state]! ! 267398 267399!PluggableButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/8/2009 14:22'! 267400updateFeedbackForEvt: evt 267401 267402 | newState | 267403 newState := self containsPoint: evt cursorPoint. 267404 newState = showSelectionFeedback ifFalse: [ 267405 self showSelectionFeedback: newState. 267406 self changed; layoutChanged]. 267407! ! 267408 267409 267410!PluggableButtonMorph methodsFor: 'accessing'! 267411action: aSymbol 267412 "Set actionSelector to be the action defined by aSymbol." 267413 267414 actionSelector := aSymbol. 267415! ! 267416 267417!PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 12/28/2000 16:17'! 267418actionSelector 267419 "Answer the receiver's actionSelector" 267420 267421 ^ actionSelector! ! 267422 267423!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 18:53'! 267424askBeforeChanging 267425 267426 ^ askBeforeChanging 267427! ! 267428 267429!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/7/98 19:17'! 267430askBeforeChanging: aBoolean 267431 "If this preference is turned on, then give the model an opportunity to ask the user before accepting a change that might cause unaccepted edits to be lost." 267432 267433 askBeforeChanging := aBoolean. 267434! ! 267435 267436!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 17:47'! 267437feedbackColor: aColor 267438 "Set the color of this button's selection feedback border." 267439 267440 feedbackColor := aColor. 267441 self changed. 267442! ! 267443 267444!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 17:38'! 267445label 267446 "Answer the DisplayObject used as this button's label." 267447 267448 ^ label 267449! ! 267450 267451!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 16:52'! 267452model: anObject 267453 "Set my model and make me me a dependent of the given object." 267454 267455 model ifNotNil: [model removeDependent: self]. 267456 anObject ifNotNil: [anObject addDependent: self]. 267457 model := anObject. 267458! ! 267459 267460!PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 10/25/1999 14:36'! 267461offColor 267462 ^ offColor 267463! ! 267464 267465!PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 12/28/2000 16:19'! 267466offColor: colorWhenOff 267467 "Set the fill colors to be used when this button is off." 267468 267469 self onColor: onColor offColor: colorWhenOff 267470! ! 267471 267472!PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 2/17/2002 05:29'! 267473performAction 267474 "Inform the model that this button has been pressed. Sent by the controller when this button is pressed. If the button's actionSelector takes any arguments, they are obtained dynamically by sending the argumentSelector to the argumentsProvider" 267475 267476 askBeforeChanging ifTrue: [model okToChange ifFalse: [^ self]]. 267477 actionSelector ifNotNil: 267478 [actionSelector numArgs == 0 267479 ifTrue: 267480 [model perform: actionSelector] 267481 ifFalse: 267482 [argumentsProvider ifNotNil: 267483 [arguments := argumentsProvider perform: argumentsSelector]. 267484 model perform: actionSelector withArguments: arguments]]! ! 267485 267486!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 17:43'! 267487shortcutCharacter 267488 "Return the Character to be used as a shortcut to turn on this switch, or nil if this switch doesn't have a keyboard shortcut." 267489 267490 ^ shortcutCharacter 267491! ! 267492 267493!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 17:43'! 267494shortcutCharacter: aCharacter 267495 "Set the character to be used as a keyboard shortcut for turning on this switch." 267496 267497 shortcutCharacter := aCharacter. 267498! ! 267499 267500!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 19:26'! 267501triggerOnMouseDown 267502 267503 ^ triggerOnMouseDown 267504! ! 267505 267506!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/7/98 19:16'! 267507triggerOnMouseDown: aBoolean 267508 "If this preference is turned on, then trigger my action immediately when the mouse goes down." 267509 267510 triggerOnMouseDown := aBoolean. 267511! ! 267512 267513 267514!PluggableButtonMorph methodsFor: 'arguments' stamp: 'sw 2/17/2002 01:03'! 267515arguments: args 267516 "If the receiver takes argument(s) that are static, they can be filled by calling this. If its argument(s) are to be dynamically determined, then use an argumentProvider and argumentSelector instead" 267517 267518 arguments := args! ! 267519 267520!PluggableButtonMorph methodsFor: 'arguments' stamp: 'sw 2/17/2002 05:29'! 267521argumentsProvider: anObject argumentsSelector: aSelector 267522 "Set the argument provider and selector" 267523 267524 argumentsProvider := anObject. 267525 argumentsSelector := aSelector! ! 267526 267527 267528!PluggableButtonMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 16:53'! 267529veryDeepFixupWith: deepCopier 267530 "If fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 267531 267532super veryDeepFixupWith: deepCopier. 267533model := deepCopier references at: model ifAbsent: [model]. 267534! ! 267535 267536!PluggableButtonMorph methodsFor: 'copying' stamp: 'sw 2/17/2002 05:29'! 267537veryDeepInner: deepCopier 267538 "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." 267539 267540super veryDeepInner: deepCopier. 267541"model := model. Weakly copied" 267542label := label veryDeepCopyWith: deepCopier. 267543"getStateSelector := getStateSelector. a Symbol" 267544"actionSelector := actionSelector. a Symbol" 267545"getLabelSelector := getLabelSelector. a Symbol" 267546"getMenuSelector := getMenuSelector. a Symbol" 267547shortcutCharacter := shortcutCharacter veryDeepCopyWith: deepCopier. 267548askBeforeChanging := askBeforeChanging veryDeepCopyWith: deepCopier. 267549triggerOnMouseDown := triggerOnMouseDown veryDeepCopyWith: deepCopier. 267550offColor := offColor veryDeepCopyWith: deepCopier. 267551onColor := onColor veryDeepCopyWith: deepCopier. 267552feedbackColor := feedbackColor veryDeepCopyWith: deepCopier. 267553showSelectionFeedback := showSelectionFeedback veryDeepCopyWith: deepCopier. 267554allButtons := nil. "a cache" 267555arguments := arguments veryDeepCopyWith: deepCopier. 267556argumentsProvider := argumentsProvider veryDeepCopyWith: deepCopier. 267557argumentsSelector := argumentsSelector. " a Symbol" ! ! 267558 267559 267560!PluggableButtonMorph methodsFor: 'event handling' stamp: 'jm 5/4/1998 16:57'! 267561handlesMouseDown: evt 267562 267563 ^ true 267564! ! 267565 267566!PluggableButtonMorph methodsFor: 'event handling' stamp: 'jm 5/20/1998 11:49'! 267567mouseDown: evt 267568 "Details: If this button is triggered on mouse down or the event is the menu gesture, handle it immediately. Otherwise, make a list of buttons (including the receiver) for mouseMove feedback. This allows a simple radio-button effect among the button submorphs of a given morph." 267569 267570 allButtons := nil. 267571 evt yellowButtonPressed ifTrue: [^ self invokeMenu: evt]. 267572 triggerOnMouseDown 267573 ifTrue: [self performAction] 267574 ifFalse: [ 267575 allButtons := owner submorphs select: [:m | m class = self class]. 267576 self updateFeedbackForEvt: evt]. 267577! ! 267578 267579!PluggableButtonMorph methodsFor: 'event handling' stamp: 'jrp 7/3/2005 18:13'! 267580mouseLeaveDragging: evt 267581 267582 self mouseLeave: evt! ! 267583 267584!PluggableButtonMorph methodsFor: 'event handling' stamp: 'jm 5/4/1998 17:30'! 267585mouseMove: evt 267586 267587 allButtons ifNil: [^ self]. 267588 allButtons do: [:m | m updateFeedbackForEvt: evt]. 267589! ! 267590 267591 267592!PluggableButtonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:39'! 267593defaultBorderWidth 267594 "answer the default border width for the receiver" 267595 ^ 1! ! 267596 267597!PluggableButtonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'! 267598defaultColor 267599 "answer the default color/fill style for the receiver" 267600 ^ Color lightGreen! ! 267601 267602 267603!PluggableButtonMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 22:40'! 267604getMenu: shiftPressed 267605 "Answer the menu for this button, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." 267606 267607 | menu | 267608 getMenuSelector isNil ifTrue: [^nil]. 267609 menu := MenuMorph new defaultTarget: model. 267610 getMenuSelector numArgs = 1 267611 ifTrue: [^model perform: getMenuSelector with: menu]. 267612 getMenuSelector numArgs = 2 267613 ifTrue: 267614 [^model 267615 perform: getMenuSelector 267616 with: menu 267617 with: shiftPressed]. 267618 ^self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! ! 267619 267620!PluggableButtonMorph methodsFor: 'private' stamp: 'RAA 6/12/2000 09:04'! 267621invokeMenu: evt 267622 "Invoke my menu in response to the given event." 267623 | menu | 267624 menu := self getMenu: evt shiftPressed. 267625 menu ifNotNil: [menu popUpEvent: evt in: self world]! ! 267626 267627"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 267628 267629PluggableButtonMorph class 267630 instanceVariableNames: ''! 267631 267632!PluggableButtonMorph class methodsFor: 'instance creation'! 267633on: anObject 267634 267635 ^ self on: anObject getState: #isOn action: #switch 267636! ! 267637 267638!PluggableButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 15:28'! 267639on: anObject getState: getStateSel action: actionSel 267640 267641 ^ self new 267642 on: anObject 267643 getState: getStateSel 267644 action: actionSel 267645 label: nil 267646 menu: nil 267647! ! 267648 267649!PluggableButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 15:28'! 267650on: anObject getState: getStateSel action: actionSel label: labelSel 267651 267652 ^ self new 267653 on: anObject 267654 getState: getStateSel 267655 action: actionSel 267656 label: labelSel 267657 menu: nil 267658! ! 267659 267660!PluggableButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 15:29'! 267661on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel 267662 267663 ^ self new 267664 on: anObject 267665 getState: getStateSel 267666 action: actionSel 267667 label: labelSel 267668 menu: menuSel 267669! ! 267670PluggableButtonMorph subclass: #PluggableButtonMorphPlus 267671 instanceVariableNames: 'enabled action getColorSelector getEnabledSelector' 267672 classVariableNames: '' 267673 poolDictionaries: '' 267674 category: 'ToolBuilder-Morphic'! 267675!PluggableButtonMorphPlus commentStamp: 'ar 2/11/2005 21:53' prior: 0! 267676An extended version of PluggableButtonMorph supporting enablement, color and block/message actions.! 267677 267678 267679!PluggableButtonMorphPlus methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/2/2007 10:52'! 267680disable 267681 "Disable the button." 267682 267683 self enabled: false! ! 267684 267685!PluggableButtonMorphPlus methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/13/2009 18:05'! 267686drawSubmorphsOn: aCanvas 267687 "Display submorphs back to front. 267688 Whiten the whole thing if disabled." 267689 267690 super drawSubmorphsOn: aCanvas. 267691 (self enabled not and: [self label isMorph and: [(self label respondsTo: #enabled:) not]]) 267692 ifTrue: [aCanvas fillRectangle: self submorphBounds fillStyle: (Color white alpha: 0.5)]! ! 267693 267694!PluggableButtonMorphPlus methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/2/2007 10:52'! 267695enable 267696 "Enable the button." 267697 267698 self enabled: true! ! 267699 267700 267701!PluggableButtonMorphPlus methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/7/2007 12:17'! 267702enabled: aBoolean 267703 "Set the enabled state of the receiver." 267704 267705 enabled = aBoolean ifTrue: [^self]. 267706 enabled := aBoolean. 267707 (self labelMorph respondsTo: #enabled:) ifTrue: [ 267708 self labelMorph enabled: aBoolean]. 267709 self changed! ! 267710 267711!PluggableButtonMorphPlus methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/9/2007 16:18'! 267712initialize 267713 "initialize the receiver." 267714 267715 enabled := true. 267716 super initialize. 267717 self color: Color transparent! ! 267718 267719!PluggableButtonMorphPlus methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/2/2009 15:40'! 267720mouseMove: evt 267721 "Need to allow feedback for other buttons in the group." 267722 267723 ^super mouseMove: evt! ! 267724 267725!PluggableButtonMorphPlus methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/2/2009 15:36'! 267726mouseUp: evt 267727 "Must update all buttons even when disabled." 267728 267729 ^super mouseUp: evt 267730! ! 267731 267732!PluggableButtonMorphPlus methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/6/2006 13:39'! 267733update: aParameter 267734 "Update the receiver with any changes in the model." 267735 267736 aParameter ifNil: [^self]. 267737 super update: aParameter. 267738 aParameter == getEnabledSelector ifTrue: [ 267739 ^self enabled: (model perform: getEnabledSelector)]! ! 267740 267741 267742!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 20:53'! 267743action 267744 ^action! ! 267745 267746!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 20:55'! 267747action: anAction 267748 action := nil. 267749 anAction isSymbol ifTrue:[^super action: anAction]. 267750 action := anAction.! ! 267751 267752!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:52'! 267753enabled 267754 ^enabled! ! 267755 267756!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:36'! 267757getColorSelector 267758 ^getColorSelector! ! 267759 267760!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:36'! 267761getColorSelector: aSymbol 267762 getColorSelector := aSymbol. 267763 self update: getColorSelector.! ! 267764 267765!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:51'! 267766getEnabledSelector 267767 ^getEnabledSelector! ! 267768 267769!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'ar 6/21/2005 11:01'! 267770getEnabledSelector: aSymbol 267771 getEnabledSelector := aSymbol. 267772 self update: aSymbol.! ! 267773 267774!PluggableButtonMorphPlus methodsFor: 'accessing' stamp: 'stephaneducasse 2/3/2006 22:35'! 267775onColor: colorWhenOn offColor: colorWhenOff 267776 "Set the fill colors to be used when this button is on/off." 267777 267778 onColor := colorWhenOn. 267779 offColor := colorWhenOff. 267780 self update: getStateSelector.! ! 267781 267782 267783!PluggableButtonMorphPlus methodsFor: 'action' stamp: 'ar 2/11/2005 19:52'! 267784mouseDown: evt 267785 enabled ifFalse:[^self]. 267786 ^super mouseDown: evt! ! 267787 267788!PluggableButtonMorphPlus methodsFor: 'action' stamp: 'ar 2/11/2005 20:54'! 267789performAction 267790 enabled ifFalse:[^self]. 267791 action ifNotNil:[^action value]. 267792 ^super performAction! ! 267793 267794 267795!PluggableButtonMorphPlus methodsFor: 'initialization' stamp: 'ar 2/12/2005 14:23'! 267796beActionButton 267797 "Make me like an action button" 267798 self borderWidth: 2. 267799 self borderColor: #raised. 267800 self onColor: Color transparent offColor: Color transparent. 267801 self cornerStyle: #rounded.! ! 267802PluggableWidgetSpec subclass: #PluggableButtonSpec 267803 instanceVariableNames: 'action label state enabled color help' 267804 classVariableNames: '' 267805 poolDictionaries: '' 267806 category: 'ToolBuilder-Kernel'! 267807!PluggableButtonSpec commentStamp: 'ar 2/11/2005 21:57' prior: 0! 267808A button, both for firing as well as used in radio-button style (e.g., carrying a selection). 267809 267810Instance variables: 267811 action <Symbol> The action to perform when the button is fired. 267812 label <Symbol|String> The selector for retrieving the button's label or label directly. 267813 state <Symbol> The selector for retrieving the button's selection state. 267814 enabled <Symbo> The selector for retrieving the button's enabled state. 267815 color <Symbo> The selector for retrieving the button color. 267816 help <String> The balloon help for the button.! 267817 267818 267819!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:20'! 267820action 267821 "Answer the action to be performed by the receiver" 267822 ^action! ! 267823 267824!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:20'! 267825action: aSymbol 267826 "Indicate the action to be performed by the receiver" 267827 action := aSymbol! ! 267828 267829!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:50'! 267830color 267831 "Answer the selector for retrieving the button's color" 267832 ^color! ! 267833 267834!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:50'! 267835color: aSymbol 267836 "Indicate the selector for retrieving the button's color" 267837 color := aSymbol! ! 267838 267839!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 6/21/2005 10:41'! 267840enabled 267841 "Answer the selector for retrieving the button's enablement" 267842 ^enabled ifNil:[true]! ! 267843 267844!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/11/2005 14:39'! 267845enabled: aSymbol 267846 "Indicate the selector for retrieving the button's enablement" 267847 enabled := aSymbol! ! 267848 267849!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/10/2005 21:14'! 267850help 267851 "Answer the help text for this button" 267852 ^help! ! 267853 267854!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/10/2005 21:14'! 267855help: aString 267856 "Indicate the help text for this button" 267857 help := aString.! ! 267858 267859!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:18'! 267860label 267861 "Answer the label (or the selector for retrieving the label)" 267862 ^label! ! 267863 267864!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 19:44'! 267865label: aSymbol 267866 "Indicate the selector for retrieving the label" 267867 label := aSymbol.! ! 267868 267869!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:19'! 267870state 267871 "Answer the selector for retrieving the button's state" 267872 ^state! ! 267873 267874!PluggableButtonSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 19:44'! 267875state: aSymbol 267876 "Indicate the selector for retrieving the button's state" 267877 state := aSymbol.! ! 267878 267879 267880!PluggableButtonSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'! 267881buildWith: builder 267882 ^builder buildPluggableButton: self! ! 267883Canvas subclass: #PluggableCanvas 267884 instanceVariableNames: '' 267885 classVariableNames: '' 267886 poolDictionaries: '' 267887 category: 'Morphic-Support'! 267888!PluggableCanvas commentStamp: '<historical>' prior: 0! 267889An abstract canvas which modifies the behavior of an underlying canvas in some way. Subclasses should implement apply:, which takes a one argument block and an actual canvas to draw on. See apply: for the specific definition.! 267890 267891 267892!PluggableCanvas methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/21/2008 16:43'! 267893fillRectangle: aRectangle basicFillStyle: aFillStyle 267894 "Fill the given rectangle with the given, non-composite, fill style." 267895 267896 | pattern | 267897 267898 self shadowColor ifNotNil: [^self fillRectangle: aRectangle color: self shadowColor]. 267899 267900 (aFillStyle isKindOf: InfiniteForm) ifTrue: [ 267901 ^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle 267902 ]. 267903 267904 aFillStyle isSolidFill ifTrue:[ ^self fillRectangle: aRectangle color: aFillStyle asColor]. 267905 267906 "We have a very special case for filling with infinite forms" 267907 (aFillStyle isBitmapFill and:[aFillStyle origin = (0@0)]) ifTrue:[ 267908 pattern := aFillStyle form. 267909 (aFillStyle direction = (pattern width @ 0) 267910 and:[aFillStyle normal = (0@pattern height)]) ifTrue:[ 267911 "Can use an InfiniteForm" 267912 ^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)]. 267913 ]. 267914 "Use a BalloonCanvas instead" 267915 self balloonFillRectangle: aRectangle fillStyle: aFillStyle. 267916! ! 267917 267918 267919!PluggableCanvas methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/21/2008 16:43'! 267920fillRectangle: aRectangle fillStyle: aFillStyle 267921 "Fill the given rectangle. Double-dispatched via the fill style." 267922 267923 aFillStyle fillRectangle: aRectangle on: self! ! 267924 267925 267926!PluggableCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 20:02'! 267927clipRect 267928 | innerClipRect | 267929 self apply: [ :c | 267930 innerClipRect := c clipRect ]. 267931 ^innerClipRect! ! 267932 267933!PluggableCanvas methodsFor: 'accessing' stamp: 'ls 3/26/2000 13:57'! 267934contentsOfArea: aRectangle into: aForm 267935 self apply: [ :c | 267936 c contentsOfArea: aRectangle into: aForm ]. 267937 ^aForm! ! 267938 267939!PluggableCanvas methodsFor: 'accessing' stamp: 'RAA 8/13/2000 18:56'! 267940extent 267941 267942 self apply: [ :c | ^c extent ]. 267943! ! 267944 267945!PluggableCanvas methodsFor: 'accessing' stamp: 'RAA 8/13/2000 18:57'! 267946origin 267947 267948 self apply: [ :c | ^c origin ]. 267949! ! 267950 267951!PluggableCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:14'! 267952shadowColor: color 267953 self apply: [ :c | 267954 c shadowColor: color ]! ! 267955 267956 267957!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 11/6/2000 16:33'! 267958balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc 267959 267960 self apply: [ :c | 267961 c balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc 267962 ]! ! 267963 267964!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 7/28/2000 06:52'! 267965balloonFillRectangle: aRectangle fillStyle: aFillStyle 267966 267967 self apply: [ :c | c balloonFillRectangle: aRectangle fillStyle: aFillStyle ]! ! 267968 267969!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 8/25/2000 13:34'! 267970infiniteFillRectangle: aRectangle fillStyle: aFillStyle 267971 267972 self apply: [ :c | c infiniteFillRectangle: aRectangle fillStyle: aFillStyle ]! ! 267973 267974!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/25/2000 15:53'! 267975showAt: pt invalidRects: updateRects 267976 self apply: [ :c | 267977 c showAt: pt invalidRects: updateRects ]! ! 267978 267979 267980!PluggableCanvas methodsFor: 'drawing' stamp: 'ls 3/20/2000 20:31'! 267981line: pt1 to: pt2 brushForm: brush 267982 self apply: [ :c | 267983 c line: pt1 to: pt2 brushForm: brush ]! ! 267984 267985!PluggableCanvas methodsFor: 'drawing' stamp: 'ls 3/20/2000 20:31'! 267986line: pt1 to: pt2 width: w color: c 267987 self apply: [ :clippedCanvas | 267988 clippedCanvas line: pt1 to: pt2 width: w color: c ]! ! 267989 267990!PluggableCanvas methodsFor: 'drawing' stamp: 'ls 3/20/2000 20:33'! 267991paragraph: paragraph bounds: bounds color: color 267992 self apply: [ :c | 267993 c paragraph: paragraph bounds: bounds color: color ]! ! 267994 267995!PluggableCanvas methodsFor: 'drawing' stamp: 'ls 3/20/2000 20:34'! 267996render: anObject 267997 self apply: [ :c | 267998 c render: anObject ]! ! 267999 268000 268001!PluggableCanvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:46'! 268002roundCornersOf: aMorph in: bounds during: aBlock 268003 aMorph wantsRoundedCorners ifFalse:[^aBlock value]. 268004 (self seesNothingOutside: (CornerRounder rectWithinCornersOf: bounds)) 268005 ifTrue: ["Don't bother with corner logic if the region is inside them" 268006 ^ aBlock value]. 268007 CornerRounder roundCornersOf: aMorph on: self in: bounds 268008 displayBlock: aBlock 268009 borderWidth: aMorph borderWidthForRounding 268010 corners: aMorph roundedCorners! ! 268011 268012 268013!PluggableCanvas methodsFor: 'drawing-images' stamp: 'ls 3/20/2000 20:32'! 268014paintImage: aForm at: aPoint 268015 self apply: [ :c | 268016 c paintImage: aForm at: aPoint ]! ! 268017 268018!PluggableCanvas methodsFor: 'drawing-images' stamp: 'ls 3/20/2000 20:32'! 268019paintImage: aForm at: aPoint sourceRect: sourceRect 268020 self apply: [ :c | 268021 c paintImage: aForm at: aPoint sourceRect: sourceRect ]! ! 268022 268023!PluggableCanvas methodsFor: 'drawing-images' stamp: 'ls 3/20/2000 20:35'! 268024stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor 268025 self apply: [ :c | 268026 c stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor ]! ! 268027 268028 268029!PluggableCanvas methodsFor: 'drawing-ovals' stamp: 'ls 3/20/2000 20:03'! 268030fillOval: r color: c borderWidth: borderWidth borderColor: borderColor 268031 self apply: [ :clippedCanvas | 268032 clippedCanvas fillOval: r color: c borderWidth: borderWidth borderColor: borderColor ]! ! 268033 268034!PluggableCanvas methodsFor: 'drawing-ovals' stamp: 'RAA 11/6/2000 16:32'! 268035fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc 268036 "Fill the given oval." 268037 self shadowColor ifNotNil: 268038 [^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc]. 268039 (aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[ 268040 self flag: #fixThis. 268041 ^self fillOval: aRectangle color: aFillStyle borderWidth: bw borderColor: bc]. 268042 (aFillStyle isSolidFill) ifTrue:[ 268043 ^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc]. 268044 "Use a BalloonCanvas instead" 268045 self balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc! ! 268046 268047 268048!PluggableCanvas methodsFor: 'drawing-polygons' stamp: 'ls 3/20/2000 20:01'! 268049drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc 268050 self apply: [ :c | 268051 c drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc ]! ! 268052 268053 268054!PluggableCanvas methodsFor: 'drawing-rectangles' stamp: 'ls 3/20/2000 20:04'! 268055frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor 268056 self apply: [ :c | 268057 c frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor ]! ! 268058 268059 268060!PluggableCanvas methodsFor: 'drawing-support' stamp: 'ls 3/20/2000 19:59'! 268061clipBy: newClipRect during: aBlock 268062 self apply: [ :c | 268063 c clipBy: newClipRect during: aBlock ]! ! 268064 268065!PluggableCanvas methodsFor: 'drawing-support' stamp: 'ls 3/20/2000 20:35'! 268066transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize 268067 268068 self apply: [ :clippedCanvas | 268069 clippedCanvas transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize ]! ! 268070 268071!PluggableCanvas methodsFor: 'drawing-support' stamp: 'ls 3/20/2000 20:37'! 268072translateBy: delta during: aBlock 268073 self apply: [ :clippedCanvas | 268074 clippedCanvas translateBy: delta during: aBlock ]! ! 268075 268076 268077!PluggableCanvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:28'! 268078drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c 268079 self apply: [ :clippedCanvas | 268080 clippedCanvas drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]! ! 268081 268082!PluggableCanvas methodsFor: 'drawing-text' stamp: 'tween 3/10/2009 07:49'! 268083drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc 268084 self apply: [ :clippedCanvas | 268085 clippedCanvas drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc]! ! 268086 268087 268088!PluggableCanvas methodsFor: 'initialization' stamp: 'ls 3/20/2000 21:16'! 268089flush 268090 self apply: [ :c | 268091 c flush ]! ! 268092 268093 268094!PluggableCanvas methodsFor: 'other' stamp: 'ls 3/20/2000 21:16'! 268095flushDisplay 268096 self apply: [ :c | 268097 c flushDisplay ]! ! 268098 268099!PluggableCanvas methodsFor: 'other' stamp: 'RAA 7/20/2000 16:49'! 268100forceToScreen: rect 268101 268102 self apply: [ :c | 268103 c forceToScreen: rect ]! ! 268104 268105!PluggableCanvas methodsFor: 'other' stamp: 'ls 3/20/2000 20:37'! 268106translateBy: aPoint clippingTo: aRect during: aBlock 268107 self apply: [ :clippedCanvas | 268108 clippedCanvas translateBy: aPoint clippingTo: aRect during: aBlock ]! ! 268109 268110 268111!PluggableCanvas methodsFor: 'private' stamp: 'ls 3/20/2000 20:46'! 268112apply: aBlock 268113 "evaluate aBlock with a canvas to do a drawing command on. See implementors for examples"! ! 268114 268115!PluggableCanvas methodsFor: 'private' stamp: 'ls 3/20/2000 20:30'! 268116image: aForm at: aPoint sourceRect: sourceRect rule: rule 268117 self apply: [ :c | 268118 c image: aForm at: aPoint sourceRect: sourceRect rule: rule ]! ! 268119PluggableButtonSpec subclass: #PluggableCheckBoxSpec 268120 instanceVariableNames: '' 268121 classVariableNames: '' 268122 poolDictionaries: '' 268123 category: 'ToolBuilder-Kernel'! 268124!PluggableCheckBoxSpec commentStamp: 'ar 2/12/2005 23:13' prior: 0! 268125PluggableCheckBox is intended as a HINT for the builder that this widget will be used as check box. Unless explicitly supported it will be automatically substituted by PluggableButton.! 268126 268127 268128!PluggableCheckBoxSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'! 268129buildWith: builder 268130 ^builder buildPluggableCheckBox: self! ! 268131PluggableWidgetSpec subclass: #PluggableCompositeSpec 268132 instanceVariableNames: 'children layout' 268133 classVariableNames: '' 268134 poolDictionaries: '' 268135 category: 'ToolBuilder-Kernel'! 268136!PluggableCompositeSpec commentStamp: 'ar 2/11/2005 21:58' prior: 0! 268137A composite user interface element. 268138 268139Instance variables: 268140 children <Symbol|Collection> Symbol to retrieve children or children directly 268141 layout <Symbol> The layout for this composite. 268142! 268143 268144 268145!PluggableCompositeSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 19:19'! 268146children 268147 "Answer the selector to retrieve this panel's children" 268148 ^children! ! 268149 268150!PluggableCompositeSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 19:19'! 268151children: aSymbol 268152 "Indicate the selector to retrieve this panel's children" 268153 children := aSymbol! ! 268154 268155!PluggableCompositeSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:33'! 268156layout 268157 "Answer the symbol indicating the layout of the composite: 268158 #proportional (default): Use frames as appropriate. 268159 #horizontal: Arrange the elements horizontally 268160 #vertical: Arrange the elements vertically. 268161 " 268162 ^layout ifNil:[#proportional]! ! 268163 268164!PluggableCompositeSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:17'! 268165layout: aSymbol 268166 "Answer the symbol indicating the layout of the composite: 268167 #proportional (default): Use frames as appropriate. 268168 #horizontal: Arrange the elements horizontally 268169 #vertical: Arrange the elements vertically. 268170 " 268171 layout := aSymbol! ! 268172ModelDependentDialogWindow subclass: #PluggableDialogWindow 268173 instanceVariableNames: 'contentMorph buttons applyChangesSelector' 268174 classVariableNames: '' 268175 poolDictionaries: '' 268176 category: 'Polymorph-Widgets-Windows'! 268177!PluggableDialogWindow commentStamp: 'gvc 8/8/2007 14:08' prior: 0! 268178Pluggable form of dialog window supporting custom selector on model for applying changes along with configurable content and buttons.! 268179 268180 268181!PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/12/2007 12:56'! 268182applyChangesSelector 268183 "Answer the value of applyChangesSelector" 268184 268185 ^ applyChangesSelector! ! 268186 268187!PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/12/2007 12:56'! 268188applyChangesSelector: anObject 268189 "Set the value of applyChangesSelector" 268190 268191 applyChangesSelector := anObject! ! 268192 268193!PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/8/2007 14:02'! 268194buttons 268195 "Answer the value of buttons" 268196 268197 ^ buttons! ! 268198 268199!PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/8/2007 14:02'! 268200buttons: anObject 268201 "Set the value of buttons" 268202 268203 buttons := anObject! ! 268204 268205!PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/9/2007 13:34'! 268206contentMorph 268207 "Answer the value of contentMorph" 268208 268209 ^ contentMorph! ! 268210 268211!PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/9/2007 13:34'! 268212contentMorph: anObject 268213 "Set the value of contentMorph" 268214 268215 contentMorph := anObject! ! 268216 268217 268218!PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 2/12/2007 13:04'! 268219applyChanges 268220 "Apply the changes." 268221 268222 super applyChanges. 268223 self applyChangesSelector ifNotNilDo: [:s | 268224 self model perform: s withEnoughArguments: {self}]! ! 268225 268226!PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 14:03'! 268227initialize 268228 "Initialize the receiver." 268229 268230 super initialize. 268231 self 268232 buttons: super newButtons! ! 268233 268234!PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 14:02'! 268235newButtons 268236 "Answer the plugged buttons." 268237 268238 ^self buttons! ! 268239 268240!PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 2/9/2007 13:36'! 268241newContentMorph 268242 "Answer the plugged content." 268243 268244 ^self contentMorph! ! 268245 268246!PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 14:05'! 268247useDefaultOKButton 268248 "Set the buttons to be just an OK button. 268249 Only effective before the model is set." 268250 268251 self buttons: {self newOKButton isDefault: true}! ! 268252 268253!PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 14:06'! 268254useDefaultOKCancelButton 268255 "Set the buttons to be a default OK button and a cancel button. 268256 Only effective before the model is set." 268257 268258 self buttons: super newButtons! ! 268259 268260!PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 14:06'! 268261useOKDefaultCancelButton 268262 "Set the buttons to be an OK button and a default cancel button. 268263 Only effective before the model is set." 268264 268265 self buttons: {self newOKButton. self newCancelButton isDefault: true}! ! 268266Dictionary subclass: #PluggableDictionary 268267 instanceVariableNames: 'hashBlock equalBlock' 268268 classVariableNames: '' 268269 poolDictionaries: '' 268270 category: 'Collections-Unordered'! 268271!PluggableDictionary commentStamp: '<historical>' prior: 0! 268272Class PluggableDictionary allows the redefinition of hashing and equality by clients. This is in particular useful if the clients know about specific properties of the objects stored in the dictionary. See the class comment of PluggableSet for an example. 268273 268274Instance variables: 268275 hashBlock <BlockContext> A one argument block used for hashing the elements. 268276 equalBlock <BlockContext> A two argument block used for comparing the elements. 268277! 268278 268279 268280!PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'! 268281equalBlock 268282 "Return the block used for comparing the elements in the receiver." 268283 ^equalBlock! ! 268284 268285!PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/27/1998 23:55'! 268286equalBlock: aBlock 268287 "Set a new equality block. The block must accept two arguments and return true if the argumets are considered to be equal, false otherwise" 268288 equalBlock := aBlock.! ! 268289 268290!PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'! 268291hashBlock 268292 "Return the block used for hashing the elements in the receiver." 268293 ^hashBlock! ! 268294 268295!PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'! 268296hashBlock: aBlock 268297 "Set a new hash block. The block must accept one argument and must return the hash value of the given argument." 268298 hashBlock := aBlock.! ! 268299 268300!PluggableDictionary methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 21:08'! 268301keys 268302 "Answer a Set containing the receiver's keys." 268303 | aSet | 268304 aSet := PluggableSet new: self size. 268305 self equalBlock ifNotNil: [aSet equalBlock: self equalBlock]. 268306 self hashBlock ifNotNil: [aSet hashBlock: self hashBlock]. 268307 self keysDo: [:key | aSet add: key]. 268308 ^ aSet! ! 268309 268310 268311!PluggableDictionary methodsFor: 'copying' stamp: 'nice 6/16/2009 20:55'! 268312copyEmpty 268313 ^super copyEmpty 268314 hashBlock: hashBlock copy; 268315 equalBlock: equalBlock copy! ! 268316 268317 268318!PluggableDictionary methodsFor: 'private' stamp: 'dvf 6/11/2000 01:33'! 268319scanFor: anObject 268320 "Scan the key array for the first slot containing either a nil 268321(indicating 268322 an empty slot) or an element that matches anObject. Answer the index 268323 268324 of that slot or zero if no slot is found. This method will be 268325overridden 268326 in various subclasses that have different interpretations for matching 268327 268328 elements." 268329 | element start finish | 268330 start := (hashBlock ifNil: [anObject hash] 268331 ifNotNil: [hashBlock value: anObject]) 268332 \\ array size + 1. 268333 finish := array size. 268334 "Search from (hash mod size) to the end." 268335 start to: finish do: [:index | ((element := array at: index) == nil or: 268336[equalBlock ifNil: [element key = anObject] 268337 ifNotNil: [equalBlock value: element key value: anObject]]) 268338 ifTrue: [^ index]]. 268339 "Search from 1 to where we started." 268340 1 to: start - 1 do: [:index | ((element := array at: index) == nil or: 268341[equalBlock ifNil: [element key = anObject] 268342 ifNotNil: [equalBlock value: element key value: anObject]]) 268343 ifTrue: [^ index]]. 268344 ^ 0"No match AND no empty slot"! ! 268345 268346"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 268347 268348PluggableDictionary class 268349 instanceVariableNames: ''! 268350 268351!PluggableDictionary class methodsFor: 'as yet unclassified' stamp: 'dvf 2683526/10/2000 18:13'! 268353integerDictionary 268354 ^ self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! ! 268355DictionaryTest subclass: #PluggableDictionaryTest 268356 instanceVariableNames: '' 268357 classVariableNames: '' 268358 poolDictionaries: '' 268359 category: 'CollectionsTests-Unordered'! 268360 268361!PluggableDictionaryTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 12:35'! 268362classToBeTested 268363 268364^ PluggableDictionary! ! 268365 268366"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 268367 268368PluggableDictionaryTest class 268369 instanceVariableNames: ''! 268370 268371!PluggableDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 12:36'! 268372classToBeTested 268373 268374^ IdentitySet! ! 268375 268376!PluggableDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 13:28'! 268377shouldInheritSelectors 268378 268379^true! ! 268380PluggableMorphListMorph subclass: #PluggableIconListMorph 268381 instanceVariableNames: 'getIconSelector' 268382 classVariableNames: '' 268383 poolDictionaries: '' 268384 category: 'Polymorph-Widgets'! 268385!PluggableIconListMorph commentStamp: 'gvc 5/18/2007 12:31' prior: 0! 268386A type of PluggableListMorph that supports a single icon (Form) for items. Useful for lists with icons.! 268387 268388 268389!PluggableIconListMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2007 17:56'! 268390getIconSelector 268391 "Answer the value of getIconSelector" 268392 268393 ^ getIconSelector! ! 268394 268395!PluggableIconListMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2007 17:56'! 268396getIconSelector: anObject 268397 "Set the value of getIconSelector" 268398 268399 getIconSelector := anObject! ! 268400 268401 268402!PluggableIconListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/17/2008 12:38'! 268403getList 268404 "Answer the list to be displayed. Caches the returned list in the 'list' ivar" 268405 268406 getListSelector isNil ifTrue: [^#()]. 268407 list := model perform: getListSelector. 268408 list isNil ifTrue: [^ #()]. 268409 list := list collect: [ :item | self itemMorphFor: item]. 268410 ^list! ! 268411 268412!PluggableIconListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/8/2007 17:51'! 268413getListItem: index 268414 "get the index-th item in the displayed list" 268415 268416 getListElementSelector ifNotNil: [ 268417 ^self itemMorphFor: (model perform: getListElementSelector with: index)]. 268418 (list notNil and: [list size >= index]) ifTrue: [ ^list at: index ]. 268419 ^self getList at: index! ! 268420 268421!PluggableIconListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/8/2007 18:04'! 268422itemMorphFor: anObject 268423 "Answer a morph for the object with the appropriate icon." 268424 268425 |item icon| 268426 item := RectangleMorph new 268427 changeTableLayout; 268428 listDirection: #leftToRight; 268429 cellPositioning: #center; 268430 cellInset: 2; 268431 borderWidth: 0; 268432 color: Color transparent; 268433 hResizing: #shrinkWrap; 268434 vResizing: #shrinkWrap; 268435 extent: 20@16. 268436 icon := self getIconSelector ifNotNil: [self model perform: self getIconSelector withEnoughArguments: {anObject}]. 268437 icon ifNotNil: [ 268438 item addMorphBack: (ImageMorph new newForm: icon)]. 268439 item addMorphBack: (StringMorph contents: anObject asStringOrText). 268440 ^item! ! 268441PluggableTextSpec subclass: #PluggableInputFieldSpec 268442 instanceVariableNames: '' 268443 classVariableNames: '' 268444 poolDictionaries: '' 268445 category: 'ToolBuilder-Kernel'! 268446!PluggableInputFieldSpec commentStamp: 'ar 2/12/2005 23:13' prior: 0! 268447PluggableInputField is intended as a HINT for the builder that this widget will be used as a single line input field. Unless explicitly supported it will be automatically substituted by PluggableText.! 268448 268449 268450!PluggableInputFieldSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'! 268451buildWith: builder 268452 ^builder buildPluggableInputField: self! ! 268453ListItemWrapper subclass: #PluggableListItemWrapper 268454 instanceVariableNames: 'string getContentsSelector getStringSelector hasContentsSelector' 268455 classVariableNames: '' 268456 poolDictionaries: '' 268457 category: 'Morphic-Explorer'! 268458!PluggableListItemWrapper commentStamp: 'ar 10/14/2003 23:51' prior: 0! 268459luggableListItemWrapper makes it more easy for clients to use hierarchical lists. Rather than having to write a subclass of ListItemWrapper, a PluggableListItemWrapper can be used to provide the appropriate information straight from the model: 268460 string - an explicit string representation (contrary to the 'item' which contains any kind of object) 268461 getStringSelector - a message invoked to retrieve the sting representation of its item dynamically from its model (when a constant representation is undesirable) 268462 hasContentsSelector - a message invoked in the model to answer whether the item has any children or not. 268463 getContentsSelector - a message invoked in the model to retrieve the contents for its item. 268464 268465All callback selectors can have zero, one or two arguments with the item and the wrapper as first and second argument.! 268466 268467 268468!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'! 268469asString 268470 string ifNotNil:[^string]. 268471 getStringSelector ifNil:[^super asString]. 268472 ^self sendToModel: getStringSelector 268473! ! 268474 268475!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:48'! 268476contents 268477 getContentsSelector ifNil:[^#()]. 268478 ^self sendToModel: getContentsSelector.! ! 268479 268480!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! 268481getContentsSelector 268482 ^getContentsSelector! ! 268483 268484!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:50'! 268485getContentsSelector: aSymbol 268486 self validateSelector: aSymbol. 268487 getContentsSelector := aSymbol.! ! 268488 268489!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:48'! 268490getStringSelector 268491 ^getStringSelector! ! 268492 268493!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! 268494getStringSelector: aSymbol 268495 self validateSelector: aSymbol. 268496 getStringSelector := aSymbol.! ! 268497 268498!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:53'! 268499hasContents 268500 hasContentsSelector ifNil:[^super hasContents]. 268501 ^self sendToModel: hasContentsSelector 268502! ! 268503 268504!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! 268505hasContentsSelector 268506 ^hasContentsSelector! ! 268507 268508!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! 268509hasContentsSelector: aSymbol 268510 self validateSelector: aSymbol. 268511 hasContentsSelector := aSymbol.! ! 268512 268513!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:49'! 268514item 268515 ^item! ! 268516 268517!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:49'! 268518item: newItem 268519 item := newItem! ! 268520 268521!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'! 268522string 268523 ^string! ! 268524 268525!PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'! 268526string: aString 268527 string := aString! ! 268528 268529 268530!PluggableListItemWrapper methodsFor: 'printing' stamp: 'ar 10/11/2003 23:21'! 268531printOn: aStream 268532 super printOn: aStream. 268533 aStream nextPut:$(; nextPutAll: self asString; nextPut:$).! ! 268534 268535 268536!PluggableListItemWrapper methodsFor: 'private' stamp: 'ar 10/11/2003 21:47'! 268537sendToModel: aSelector 268538 aSelector numArgs = 0 268539 ifTrue:[^model perform: aSelector]. 268540 aSelector numArgs = 1 268541 ifTrue:[^model perform: aSelector with: item]. 268542 aSelector numArgs = 2 268543 ifTrue:[^model perform: aSelector with: item with: self].! ! 268544 268545!PluggableListItemWrapper methodsFor: 'private' stamp: 'ar 10/11/2003 21:50'! 268546validateSelector: aSymbol 268547 (aSymbol numArgs between: 0 and: 2) ifFalse:[^self error: 'Invalid pluggable selector'].! ! 268548ScrollPane subclass: #PluggableListMorph 268549 instanceVariableNames: 'list getListSelector getListSizeSelector getListElementSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector handlesBasicKeys potentialDropRow listMorph hScrollRangeCache' 268550 classVariableNames: '' 268551 poolDictionaries: '' 268552 category: 'Morphic-Pluggable Widgets'! 268553!PluggableListMorph commentStamp: '<historical>' prior: 0! 268554... 268555 268556When a PluggableListMorph is in focus, type in a letter (or several 268557letters quickly) to go to the next item that begins with that letter. 268558Special keys (up, down, home, etc.) are also supported.! 268559 268560 268561!PluggableListMorph methodsFor: '*FreeType-override' stamp: 'tween 9/8/2007 14:56'! 268562setListFont 268563 "set the font for the list" 268564 268565 Preferences 268566 chooseFontWithPrompt: 'Choose the font for this list' translated 268567 andSendTo: self 268568 withSelector: #font: 268569 highlightSelector: #font! ! 268570 268571 268572!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/7/2007 12:42'! 268573adoptPaneColor: paneColor 268574 "Pass on to the border too." 268575 268576 super adoptPaneColor: paneColor. 268577 paneColor ifNil: [^self]. 268578 self 268579 fillStyle: self fillStyleToUse; 268580 selectionColor: self selectionColor. 268581 self borderWidth > 0 ifTrue: [ 268582 self borderStyle: self borderStyleToUse]! ! 268583 268584!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/7/2007 12:42'! 268585borderStyleToUse 268586 "Answer the borderStyle that should be used for the receiver." 268587 268588 ^self enabled 268589 ifTrue: [self theme listNormalBorderStyleFor: self] 268590 ifFalse: [self theme listDisabledBorderStyleFor: self]! ! 268591 268592!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/2/2007 13:34'! 268593disable 268594 "Disable the receiver." 268595 268596 self enabled: false! ! 268597 268598!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/17/2007 15:22'! 268599drawSubmorphsOn: aCanvas 268600 "Display submorphs back to front. 268601 Draw the focus here since we are using inset bounds 268602 for the focus rectangle." 268603 268604 super drawSubmorphsOn: aCanvas. 268605 self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOn: aCanvas]! ! 268606 268607!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/2/2007 13:34'! 268608enable 268609 "Enable the receiver." 268610 268611 self enabled: true! ! 268612 268613!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/2/2007 13:34'! 268614enabled 268615 "Answer the enablement state of the receiver." 268616 268617 ^self valueOfProperty: #enabled ifAbsent: [true]! ! 268618 268619!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/2/2007 13:34'! 268620enabled: aBoolean 268621 "Set the enablement state of the receiver." 268622 268623 aBoolean = self enabled 268624 ifFalse: [self setProperty: #enabled toValue: aBoolean. 268625 self 268626 adoptPaneColor: self paneColor; 268627 changed]! ! 268628 268629!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/7/2007 12:39'! 268630fillStyleToUse 268631 "Answer the fillStyle that should be used for the receiver." 268632 268633 ^self enabled 268634 ifTrue: [self theme listNormalFillStyleFor: self] 268635 ifFalse: [self theme listDisabledFillStyleFor: self]! ! 268636 268637!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/1/2009 15:18'! 268638focusBounds 268639 "Answer the bounds for drawing the focus indication." 268640 268641 ^self theme listFocusBoundsFor: self! ! 268642 268643!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/7/2007 11:47'! 268644getEnabledSelector 268645 "Answer the value of getEnabledSelector" 268646 268647 ^self valueOfProperty: #getEnabledSelector! ! 268648 268649!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/7/2007 11:46'! 268650getEnabledSelector: aSymbol 268651 "Set the value of getEnabledSelector" 268652 268653 self setProperty: #getEnabledSelector toValue: aSymbol. 268654 self updateEnabled! ! 268655 268656!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/12/2006 14:52'! 268657handleFocusEvent: anEvent 268658 "Handle the given event. This message is sent if the receiver currently has the focus and is therefore receiving events directly from some hand." 268659 268660 self processEvent: anEvent. "give submorphs a chance" 268661 (anEvent isMouse and: [anEvent isMouseDown and: [(self fullContainsPoint: anEvent position) not]]) 268662 ifFalse: [^super handleFocusEvent: anEvent]. 268663 "click outside - pass to event handler" 268664 self eventHandler 268665 ifNotNil: [self eventHandler mouseDown: anEvent fromMorph: self]! ! 268666 268667!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/20/2006 10:24'! 268668mouseDownRow 268669 "Answer the mouse down row or nil if none." 268670 268671 ^self listMorph mouseDownRow! ! 268672 268673!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/20/2006 10:24'! 268674mouseDownRow: anIntegerOrNil 268675 "Set the mouse down row or nil if none." 268676 268677 self listMorph mouseDownRow: anIntegerOrNil! ! 268678 268679!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/3/2008 13:05'! 268680optimalExtent 268681 "Answer the extent of the list morph." 268682 268683 ^self listMorph extent + (self borderWidth * 2) + self scrollBarThickness! ! 268684 268685!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/12/2006 13:55'! 268686selectionColor 268687 "Answer the colour to use for selected items." 268688 268689 ^self valueOfProperty: #selectionColor ifAbsent: [] ! ! 268690 268691!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/7/2008 12:25'! 268692selectionColor: aColor 268693 "Set the colour for selected items." 268694 268695 |w| 268696 aColor 268697 ifNil: [self removeProperty: #selectionColor] 268698 ifNotNil: [self setProperty: #selectionColor toValue: aColor]. 268699 w := self ownerThatIsA: SystemWindow. 268700 self selectionColorToUse: ( 268701 (Preferences fadedBackgroundWindows not or: [w isNil or: [w isActive]]) 268702 ifTrue: [aColor] 268703 ifFalse: [self paneColor lighter])! ! 268704 268705!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/12/2006 14:36'! 268706selectionColorToUse 268707 "Answer the colour to use for selected items." 268708 268709 ^self valueOfProperty: #selectionColorToUse ifAbsent: [] ! ! 268710 268711!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 11:44'! 268712selectionColorToUse: aColor 268713 "Set the colour for selected items." 268714 268715 aColor = self selectionColorToUse ifTrue: [^self]. 268716 aColor 268717 ifNil: [self removeProperty: #selectionColorToUse] 268718 ifNotNil: [self setProperty: #selectionColorToUse toValue: aColor]. 268719 self listMorph selectionFrameChanged! ! 268720 268721!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/22/2007 14:48'! 268722themeChanged 268723 "Update the selection colour." 268724 268725 self selectionColor ifNotNil: [ 268726 self selectionColor: self theme selectionColor]. 268727 super themeChanged! ! 268728 268729!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/8/2009 13:25'! 268730updateEnabled 268731 "Update the enablement state." 268732 268733 self model ifNotNil: [ 268734 self getEnabledSelector ifNotNil: [ 268735 self enabled: (self model perform: self getEnabledSelector)]]! ! 268736 268737!PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/19/2006 15:24'! 268738vExtraScrollRange 268739 "Return the amount of extra blank space to include below the bottom of the scroll content." 268740 268741 ^8 268742! ! 268743 268744 268745!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'nes 7/4/2009 12:58'! 268746basicKeyPressed: aChar 268747 | nextSelection milliSeconds slowKeyStroke nextSelectionText oldSelection | 268748 nextSelection := oldSelection := self getCurrentSelectionIndex. 268749 milliSeconds := Time millisecondClockValue. 268750 slowKeyStroke := milliSeconds - lastKeystrokeTime > 500. 268751 lastKeystrokeTime := milliSeconds. 268752 slowKeyStroke 268753 ifTrue: ["forget previous keystrokes and search in following elements" 268754 lastKeystrokes := aChar asLowercase asString.] 268755 ifFalse: ["append quick keystrokes but don't move selection if it still matches" 268756 lastKeystrokes := lastKeystrokes , aChar asLowercase asString.]. 268757 "Get rid of blanks and style used in some lists" 268758 nextSelectionText := self getList 268759 detect: [:a | a asString withBlanksTrimmed asLowercase beginsWith: lastKeystrokes] 268760 ifNone: [^ self ]. 268761 "No change if model is locked" 268762 model okToChange ifFalse: [^ self]. 268763 nextSelection := self getList findFirst: [:a | a = nextSelectionText]. 268764 "The following line is a workaround around the behaviour of OBColumn>>selection:, 268765 which deselects when called twice with the same argument." 268766 oldSelection = nextSelection ifTrue: [^ self]. 268767 ^ self changeModelSelection: nextSelection! ! 268768 268769!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/19/2009 12:29'! 268770hTotalScrollRange 268771 "Return the entire scrolling range. 268772 Avoid using the hScrollRangeCache as it is not always correct." 268773 268774 ^super hTotalScrollRange! ! 268775 268776!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/19/2009 12:26'! 268777hUnadjustedScrollRange 268778 "Return the entire scrolling range." 268779 268780 ^self listMorph hUnadjustedScrollRange! ! 268781 268782!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/12/2006 14:23'! 268783handlesMouseOverDragging: evt 268784 "Yes, for mouse down highlight." 268785 268786 ^true! ! 268787 268788!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/11/2007 15:17'! 268789keyStroke: event 268790 "Process keys 268791 specialKeys are things like up, down, etc. ALWAYS HANDLED 268792 modifierKeys are regular characters either 1) accompanied with ctrl, 268793 cmd or 2) any character if the list doesn't want to handle basic 268794 keys (handlesBasicKeys returns false) 268795 basicKeys are any characters" 268796 | aChar aSpecialKey | 268797 (self scrollByKeyboard: event) ifTrue: [^self]. 268798 (self navigationKey: event) ifTrue: [^self]. 268799 aChar := event keyCharacter. 268800 aSpecialKey := aChar asciiValue. 268801 aSpecialKey < 32 ifTrue: [^ self specialKeyPressed: aSpecialKey]. 268802 (event anyModifierKeyPressed or: [self handlesBasicKeys not]) 268803 ifTrue: [^ self modifierKeyPressed: aChar]. 268804 ^ self basicKeyPressed: aChar! ! 268805 268806!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/6/2007 14:34'! 268807keyboardFocusChange: aBoolean 268808 "The message is sent to a morph when its keyboard focus changes. 268809 Update for focus feedback." 268810 268811 self focusChanged! ! 268812 268813!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'ls 5/17/2001 23:06'! 268814maximumSelection 268815 ^ self getListSize! ! 268816 268817!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/21/2007 14:39'! 268818mouseDown: evt 268819 "Changed to only take focus if wanted." 268820 268821 | selectors row | 268822 evt yellowButtonPressed "First check for option (menu) click" 268823 ifTrue: [^ self yellowButtonActivity: evt shiftPressed]. 268824 self enabled ifFalse: [^self]. 268825 self wantsKeyboardFocus 268826 ifTrue: [self takeKeyboardFocus]. 268827 row := self rowAtLocation: evt position. 268828 row = 0 ifTrue: [^super mouseDown: evt]. 268829 self mouseDownRow: row. 268830 selectors := Array 268831 with: #click: 268832 with: (doubleClickSelector ifNotNil:[#doubleClick:]) 268833 with: nil 268834 with: (self dragEnabled ifTrue:[#startDrag:] ifFalse:[nil]). 268835 evt hand waitForClicksOrDrag: self event: evt selectors: selectors threshold: 10 "pixels".! ! 268836 268837!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/21/2007 14:39'! 268838mouseEnter: event 268839 "Changed to take mouseClickForKeyboardFocus preference into account." 268840 268841 super mouseEnter: event. 268842 self wantsKeyboardFocus ifFalse: [^self]. 268843 Preferences mouseClickForKeyboardFocus 268844 ifFalse: [self takeKeyboardFocus]! ! 268845 268846!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/5/2007 15:47'! 268847mouseEnterDragging: evt 268848 "The mouse has entered with a button down. 268849 Workaround for apparent flaw in MouseOverHandler constantly 268850 sending this message when dragging. 268851 Do nothing if disabled." 268852 268853 |row oldPDR| 268854 self enabled ifFalse: [^self]. 268855 row := self rowAtLocation: evt position. 268856 (self dragEnabled or: [evt hand hasSubmorphs]) ifFalse: [ 268857 self listMorph mouseDownRow: row]. 268858 (evt hand hasSubmorphs and:[self dropEnabled]) ifFalse: ["no d&d" 268859 ^super mouseEnterDragging: evt]. 268860 potentialDropRow = row ifTrue: [^self]. 268861 oldPDR := potentialDropRow. 268862 potentialDropRow := row. 268863 evt hand newMouseFocus: self. 268864 "above is ugly but necessary for now" 268865 (self wantsDroppedMorph: evt hand firstSubmorph event: evt ) 268866 ifTrue: [self changed] 268867 ifFalse: [(oldPDR ifNil: [0]) > 0 268868 ifTrue: [self resetPotentialDropRow] 268869 ifFalse: [potentialDropRow := 0]]! ! 268870 268871!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/27/2006 16:49'! 268872mouseLeave: event 268873 268874 super mouseLeave: event! ! 268875 268876!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/12/2006 15:28'! 268877mouseLeaveDragging: anEvent 268878 "The mouse has left with a button down." 268879 268880 (self dragEnabled or: [anEvent hand hasSubmorphs]) ifFalse: [ 268881 self listMorph mouseDownRow: nil]. 268882 (self dropEnabled and: [anEvent hand hasSubmorphs]) ifFalse: ["no d&d" 268883 ^super mouseLeaveDragging: anEvent]. 268884 self resetPotentialDropRow. 268885 anEvent hand releaseMouseFocus: self. 268886 "above is ugly but necessary for now"! ! 268887 268888!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/5/2007 15:50'! 268889mouseMove: evt 268890 "The mouse has moved with a button down. 268891 Do nothing if disabled." 268892 268893 |row| 268894 self enabled ifFalse: [^self]. 268895 row := self rowAtLocation: evt position. 268896 evt hand hasSubmorphs ifFalse: [ 268897 (self containsPoint: evt position) 268898 ifTrue: [self mouseDownRow: row] 268899 ifFalse: [self mouseDownRow: nil]]. 268900 (self dropEnabled and:[evt hand hasSubmorphs]) 268901 ifFalse: [^self eventHandler ifNotNil: 268902 [self eventHandler mouseMove: evt fromMorph: self]]. 268903 (self containsPoint: evt position) 268904 ifTrue: [self mouseEnterDragging: evt] 268905 ifFalse: [self mouseLeaveDragging: evt]! ! 268906 268907!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/7/2007 12:45'! 268908mouseUp: event 268909 "The mouse came up within the list; take appropriate action" 268910 268911 | row mdr | 268912 row := self rowAtLocation: event position. 268913 event hand hasSubmorphs ifFalse: [ 268914 mdr := self mouseDownRow. 268915 self mouseDownRow: nil. 268916 mdr ifNil: [^self]]. 268917 (self enabled and: [model okToChange]) 268918 ifFalse: [^ self]. 268919 "No change if model is locked or receiver disabled" 268920 row == self selectionIndex 268921 ifTrue: [(autoDeselect ifNil: [true]) ifTrue:[row == 0 ifFalse: [self changeModelSelection: 0] ]] 268922 ifFalse: [self changeModelSelection: row]. 268923 Cursor normal show! ! 268924 268925!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/27/2009 11:58'! 268926resizeScrollBars 268927 "Fixed to not use deferred message that incorrectly 268928 sets scroll deltas/interval." 268929 268930 (self extent = self defaultExtent) 268931 ifFalse: [super resizeScrollBars]! ! 268932 268933!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/4/2006 15:02'! 268934selectionIndex: index 268935 "Called internally to select the index-th item." 268936 | row | 268937 self unhighlightSelection. 268938 row := index ifNil: [ 0 ]. 268939 row := row min: self maximumSelection. "make sure we don't select past the end" 268940 self listMorph selectedRow: row. 268941 self highlightSelection. 268942 self scrollSelectionIntoView.! ! 268943 268944!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/7/2007 12:48'! 268945specialKeyPressed: asciiValue 268946 "A special key with the given ascii-value was pressed; dispatch it" 268947 268948 | oldSelection nextSelection max howManyItemsShowing | 268949 asciiValue = 27 ifTrue: 268950 [" escape key" 268951 ^ ActiveEvent shiftPressed 268952 ifTrue: 268953 [ActiveWorld putUpWorldMenuFromEscapeKey] 268954 ifFalse: 268955 [self yellowButtonActivity: false]]. 268956 268957 max := self maximumSelection. 268958 max > 0 ifFalse: [^ self]. 268959 nextSelection := oldSelection := self getCurrentSelectionIndex. 268960 asciiValue = 31 ifTrue: 268961 [" down arrow" 268962 nextSelection := oldSelection + 1. 268963 nextSelection > max ifTrue: [nextSelection := 1]]. 268964 asciiValue = 30 ifTrue: 268965 [" up arrow" 268966 nextSelection := oldSelection - 1. 268967 nextSelection < 1 ifTrue: [nextSelection := max]]. 268968 asciiValue = 1 ifTrue: 268969 [" home" 268970 nextSelection := 1]. 268971 asciiValue = 4 ifTrue: 268972 [" end" 268973 nextSelection := max]. 268974 howManyItemsShowing := self numSelectionsInView. 268975 asciiValue = 11 ifTrue: 268976 [" page up" 268977 nextSelection := 1 max: oldSelection - howManyItemsShowing]. 268978 asciiValue = 12 ifTrue: 268979 [" page down" 268980 nextSelection := oldSelection + howManyItemsShowing min: max]. 268981 (self enabled and: [model okToChange]) ifFalse: [^ self]. 268982 "No change if model is locked" 268983 oldSelection = nextSelection ifTrue: [^ self flash]. 268984 ^ self changeModelSelection: nextSelection! ! 268985 268986!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/10/2008 12:24'! 268987startDrag: evt 268988 |row ddm draggedItem draggedItemMorph passenger | 268989 evt hand hasSubmorphs 268990 ifTrue: [^ self]. 268991 (self dragEnabled 268992 and: [model okToChange]) 268993 ifFalse: [^ self]. 268994 (row := self mouseDownRow) 268995 ifNil: [draggedItem := self selection] 268996 ifNotNil: [draggedItem := self getListItem: row]. 268997 draggedItem ifNil: [^ self]. 268998 draggedItemMorph := StringMorph contents: draggedItem asStringOrText. 268999 passenger := self model dragPassengerFor: draggedItemMorph inMorph: self. 269000 passenger 269001 ifNil: [^ self]. 269002 self mouseDownRow: nil. 269003 ddm := TransferMorph withPassenger: passenger from: self. 269004 ddm 269005 dragTransferType: (self model dragTransferTypeForMorph: self). 269006 [Preferences dragNDropWithAnimation 269007 ifTrue: [self model dragAnimationFor: draggedItemMorph transferMorph: ddm]. 269008 evt hand grabMorph: ddm] 269009 ensure: [Cursor normal show. 269010 evt hand releaseMouseFocus: self]! ! 269011 269012!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/11/2007 14:06'! 269013takesKeyboardFocus 269014 "Answer whether the receiver can normally take keyboard focus." 269015 269016 ^true! ! 269017 269018!PluggableListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/13/2007 11:35'! 269019verifyContents 269020 "Verify the contents of the receiver, reconstituting if necessary. Called whenever window is reactivated, to react to possible structural changes. Also called periodically in morphic if the smartUpdating preference is true" 269021 | newList existingSelection oldList | 269022 oldList := list ifNil: [ #() ]. 269023 newList := self getList. 269024 ((oldList == newList) "fastest" or: [oldList = newList]) ifTrue: [^ self]. 269025 existingSelection := oldList isEmpty 269026 ifTrue: [self listMorph selectedRow] 269027 ifFalse: [(self selectionIndex between: 1 and: newList size) 269028 ifTrue: [self selectionIndex] 269029 ifFalse: [nil]]. 269030 self updateList. 269031 existingSelection notNil 269032 ifTrue: 269033 [model noteSelectionIndex: existingSelection for: getListSelector. 269034 self selectionIndex: existingSelection] 269035 ifFalse: 269036 [self changeModelSelection: 0]! ! 269037 269038 269039!PluggableListMorph methodsFor: 'accessing' stamp: 'ar 3/17/2001 15:32'! 269040itemFromPoint: aPoint 269041 "Return the list element (morph) at the given point or nil if outside" 269042 | ptY | 269043 scroller hasSubmorphs ifFalse:[^nil]. 269044 (scroller fullBounds containsPoint: aPoint) ifFalse:[^nil]. 269045 ptY := (scroller firstSubmorph point: aPoint from: self) y. 269046 "note: following assumes that submorphs are vertical, non-overlapping, and ordered" 269047 scroller firstSubmorph top > ptY ifTrue:[^nil]. 269048 scroller lastSubmorph bottom < ptY ifTrue:[^nil]. 269049 "now use binary search" 269050 ^scroller 269051 findSubmorphBinary:[:item| 269052 (item top <= ptY and:[item bottom >= ptY]) 269053 ifTrue:[0] "found" 269054 ifFalse:[ (item top + item bottom // 2) > ptY ifTrue:[-1] ifFalse:[1]]]! ! 269055 269056!PluggableListMorph methodsFor: 'accessing' stamp: 'ls 5/17/2001 20:31'! 269057rowAtLocation: aPoint 269058 "Return the row at the given point or 0 if outside" 269059 | pointInListMorphCoords | 269060 pointInListMorphCoords := (self scroller transformFrom: self) transform: aPoint. 269061 ^self listMorph rowAtLocation: pointInListMorphCoords.! ! 269062 269063 269064!PluggableListMorph methodsFor: 'as yet unclassified' stamp: 'ls 2/5/2004 18:01'! 269065listMorph 269066 listMorph ifNil: [ 269067 "crate this lazily, in case the morph is legacy" 269068 listMorph := self listMorphClass new. 269069 listMorph listSource: self. 269070 listMorph width: self scroller width. 269071 listMorph color: self textColor ]. 269072 269073 listMorph owner ~~ self scroller ifTrue: [ 269074 "list morph needs to be installed. Again, it's done this way to accomodate legacy PluggableListMorphs" 269075 self scroller removeAllMorphs. 269076 self scroller addMorph: listMorph ]. 269077 269078 ^listMorph! ! 269079 269080!PluggableListMorph methodsFor: 'as yet unclassified' stamp: 'ls 5/17/2001 09:04'! 269081listMorphClass 269082 ^LazyListMorph! ! 269083 269084 269085!PluggableListMorph methodsFor: 'debug and other' stamp: 'bf 2/17/2006 17:25'! 269086userString 269087 ^list! ! 269088 269089 269090!PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 23:56'! 269091acceptDroppingMorph: aMorph event: evt 269092 "This message is sent when a morph is dropped onto a morph that has 269093 agreed to accept the dropped morph by responding 'true' to the 269094 wantsDroppedMorph:Event: message. The default implementation just 269095 adds the given morph to the receiver." 269096 "Here we let the model do its work." 269097 269098 self model 269099 acceptDroppingMorph: aMorph 269100 event: evt 269101 inMorph: self. 269102 self resetPotentialDropRow. 269103 evt hand releaseMouseFocus: self. 269104 Cursor normal show. 269105! ! 269106 269107!PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/23/2001 00:01'! 269108potentialDropItem 269109 "return the item that the most recent drop hovered over, or nil if there is no potential drop target" 269110 self potentialDropRow = 0 ifTrue: [ ^self ]. 269111 ^self getListItem: self potentialDropRow! ! 269112 269113!PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/23/2001 00:10'! 269114potentialDropRow 269115 "return the row of the item that the most recent drop hovered over, or 0 if there is no potential drop target" 269116 ^potentialDropRow ifNil: [ 0 ]. 269117! ! 269118 269119!PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/23/2001 00:01'! 269120resetPotentialDropRow 269121 potentialDropRow ifNotNil: [ 269122 potentialDropRow ~= 0 ifTrue: [ 269123 potentialDropRow := 0. 269124 self changed. ] ]! ! 269125 269126 269127!PluggableListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 20:53'! 269128highlightSelection! ! 269129 269130!PluggableListMorph methodsFor: 'drawing' stamp: 'sbw 12/1/2000 12:12'! 269131superDrawOn: aCanvas 269132 super drawOn: aCanvas. 269133! ! 269134 269135!PluggableListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 20:53'! 269136unhighlightSelection 269137! ! 269138 269139 269140!PluggableListMorph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 18:26'! 269141wantsDroppedMorph: aMorph event: anEvent 269142 ^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! ! 269143 269144 269145!PluggableListMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 22:57'! 269146handlesKeyboard: evt 269147 ^true! ! 269148 269149 269150!PluggableListMorph methodsFor: 'events' stamp: 'ls 5/16/2001 22:28'! 269151doubleClick: event 269152 | index | 269153 doubleClickSelector isNil ifTrue: [^super doubleClick: event]. 269154 index := self rowAtLocation: event position. 269155 index = 0 ifTrue: [^super doubleClick: event]. 269156 "selectedMorph ifNil: [self setSelectedMorph: aMorph]." 269157 ^ self model perform: doubleClickSelector! ! 269158 269159!PluggableListMorph methodsFor: 'events' stamp: 'ls 10/14/2001 13:08'! 269160handleBasicKeys: aBoolean 269161 "set whether the list morph should handle basic keys like arrow keys, or whether everything should be passed to the model" 269162 handlesBasicKeys := aBoolean! ! 269163 269164!PluggableListMorph methodsFor: 'events' stamp: 'ls 10/14/2001 13:09'! 269165handlesBasicKeys 269166 " if ya don't want the list to automatically handle non-modifier key 269167 (excluding shift key) input, return false" 269168 ^ handlesBasicKeys ifNil: [ true ]! ! 269169 269170 269171!PluggableListMorph methodsFor: 'events-processing' stamp: 'ar 3/17/2001 16:16'! 269172handleMouseMove: anEvent 269173 "Reimplemented because we really want #mouseMove when a morph is dragged around" 269174 anEvent wasHandled ifTrue:[^self]. "not interested" 269175 (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self]. 269176 anEvent wasHandled: true. 269177 self mouseMove: anEvent. 269178 (self handlesMouseStillDown: anEvent) ifTrue:[ 269179 "Step at the new location" 269180 self startStepping: #handleMouseStillDown: 269181 at: Time millisecondClockValue 269182 arguments: {anEvent copy resetHandlerFields} 269183 stepTime: 1]. 269184! ! 269185 269186 269187!PluggableListMorph methodsFor: 'geometry' stamp: 'sps 3/9/2004 15:33'! 269188extent: newExtent 269189 super extent: newExtent. 269190 269191 "Change listMorph's bounds to the new width. It is either the size 269192 of the widest list item, or the size of self, whatever is bigger" 269193 self listMorph width: ((self width max: listMorph hUnadjustedScrollRange) + 20). 269194! ! 269195 269196!PluggableListMorph methodsFor: 'geometry' stamp: 'ls 5/17/2001 21:01'! 269197scrollDeltaHeight 269198 "Return the increment in pixels which this pane should be scrolled." 269199 ^ self font height! ! 269200 269201!PluggableListMorph methodsFor: 'geometry' stamp: 'sps 3/9/2004 17:31'! 269202scrollDeltaWidth 269203"A guess -- assume that the width of a char is approx 1/2 the height of the font" 269204 ^ self scrollDeltaHeight // 2 269205 269206! ! 269207 269208 269209!PluggableListMorph methodsFor: 'initialization' stamp: 'di 4/10/98 16:20'! 269210autoDeselect: trueOrFalse 269211 "Enable/disable autoDeselect (see class comment)" 269212 autoDeselect := trueOrFalse.! ! 269213 269214!PluggableListMorph methodsFor: 'initialization' stamp: 'sw 1/12/2000 16:22'! 269215doubleClickSelector: aSymbol 269216 doubleClickSelector := aSymbol! ! 269217 269218!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:21'! 269219font 269220 269221 ^ self listMorph font 269222! ! 269223 269224!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:21'! 269225font: aFontOrNil 269226 self listMorph font: aFontOrNil. 269227! ! 269228 269229!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 8/19/2001 14:15'! 269230getListElementSelector: aSymbol 269231 "specify a selector that can be used to obtain a single element in the underlying list" 269232 getListElementSelector := aSymbol. 269233 list := nil. "this cache will not be updated if getListElementSelector has been specified, so go ahead and remove it"! ! 269234 269235!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 2/9/2002 01:03'! 269236getListSelector: sel 269237 "Set the receiver's getListSelector as indicated, and trigger a recomputation of the list" 269238 269239 getListSelector := sel. 269240 self changed. 269241 self updateList.! ! 269242 269243!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/22/2001 18:21'! 269244getListSizeSelector: aSymbol 269245 "specify a selector that can be used to specify the list's size" 269246 getListSizeSelector := aSymbol! ! 269247 269248!PluggableListMorph methodsFor: 'initialization' stamp: 'di 10/11/1999 08:45'! 269249initForKeystrokes 269250 lastKeystrokeTime := 0. 269251 lastKeystrokes := ''! ! 269252 269253!PluggableListMorph methodsFor: 'initialization' stamp: 'sw 1/18/2001 13:08'! 269254keystrokeActionSelector: keyActionSel 269255 "Set the keystroke action selector as specified" 269256 269257 keystrokeActionSelector := keyActionSel! ! 269258 269259!PluggableListMorph methodsFor: 'initialization' stamp: 'di 5/22/1998 00:32'! 269260listItemHeight 269261 "This should be cleaned up. The list should get spaced by this parameter." 269262 ^ 12! ! 269263 269264!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:31'! 269265on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel 269266 self model: anObject. 269267 getListSelector := getListSel. 269268 getIndexSelector := getSelectionSel. 269269 setIndexSelector := setSelectionSel. 269270 getMenuSelector := getMenuSel. 269271 keystrokeActionSelector := keyActionSel. 269272 autoDeselect := true. 269273 self borderWidth: 1. 269274 self updateList. 269275 self selectionIndex: self getCurrentSelectionIndex. 269276 self initForKeystrokes! ! 269277 269278!PluggableListMorph methodsFor: 'initialization' stamp: 'nk 5/16/2003 14:41'! 269279textColor 269280 "Answer my default text color." 269281 ^self valueOfProperty: #textColor ifAbsent: [ Color black ] 269282! ! 269283 269284!PluggableListMorph methodsFor: 'initialization' stamp: 'ls 2/5/2004 18:02'! 269285textColor: aColor 269286 "Set my default text color." 269287 self setProperty: #textColor toValue: aColor. 269288 self listMorph color: aColor.! ! 269289 269290!PluggableListMorph methodsFor: 'initialization' stamp: 'nk 5/16/2003 14:40'! 269291textHighlightColor 269292 "Answer my default text highlight color." 269293 ^self valueOfProperty: #textHighlightColor ifAbsent: [ Color red ]. 269294! ! 269295 269296!PluggableListMorph methodsFor: 'initialization' stamp: 'nk 5/16/2003 14:37'! 269297textHighlightColor: aColor 269298 "Set my default text highlight color." 269299 self setProperty: #textHighlightColor toValue: aColor. 269300! ! 269301 269302 269303!PluggableListMorph methodsFor: 'menu' stamp: 'tk 12/10/2001 20:33'! 269304getMenu: shiftKeyState 269305 "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." 269306 269307 | aMenu | 269308 aMenu := super getMenu: shiftKeyState. 269309 aMenu ifNotNil: [aMenu commandKeyHandler: self]. 269310 ^ aMenu! ! 269311 269312 269313!PluggableListMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:56'! 269314addCustomMenuItems: aMenu hand: aHandMorph 269315 "Add halo menu items to be handled by the invoking hand. The halo menu is invoked by clicking on the menu-handle of the receiver's halo." 269316 269317 super addCustomMenuItems: aMenu hand: aHandMorph. 269318 aMenu addLine. 269319 aMenu add: 'list font...' translated target: self action: #setListFont. 269320 aMenu add: 'copy list to clipboard' translated target: self action: #copyListToClipboard. 269321 aMenu add: 'copy selection to clipboard' translated target: self action: #copySelectionToClipboard! ! 269322 269323!PluggableListMorph methodsFor: 'menus' stamp: 'PeterHugossonMiller 9/3/2009 10:19'! 269324copyListToClipboard 269325 "Copy my items to the clipboard as a multi-line string" 269326 269327 | stream | 269328 stream := (String new: self getList size * 40) writeStream. 269329 list do: [:ea | stream nextPutAll: ea asString] separatedBy: [stream nextPut: Character cr]. 269330 Clipboard clipboardText: stream contents! ! 269331 269332!PluggableListMorph methodsFor: 'menus' stamp: 'sw 3/31/2002 02:38'! 269333copySelectionToClipboard 269334 "Copy my selected item to the clipboard as a string" 269335 269336 self selection 269337 ifNotNil: 269338 [Clipboard clipboardText: self selection asString] 269339 ifNil: 269340 [self flash]! ! 269341 269342 269343!PluggableListMorph methodsFor: 'model access' stamp: 'di 5/6/1998 21:18'! 269344changeModelSelection: anInteger 269345 "Change the model's selected item index to be anInteger." 269346 269347 setIndexSelector ifNotNil: 269348 [model perform: setIndexSelector with: anInteger].! ! 269349 269350!PluggableListMorph methodsFor: 'model access' stamp: 'sw 12/4/2001 20:51'! 269351commandKeyTypedIntoMenu: evt 269352 "The user typed a command-key into a menu which has me as its command-key handler" 269353 269354 ^ self modifierKeyPressed: evt keyCharacter! ! 269355 269356!PluggableListMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:05'! 269357getCurrentSelectionIndex 269358 "Answer the index of the current selection." 269359 269360 getIndexSelector isNil ifTrue: [^0]. 269361 ^model perform: getIndexSelector! ! 269362 269363!PluggableListMorph methodsFor: 'model access' stamp: 'ls 8/19/2001 14:16'! 269364getList 269365 "Answer the list to be displayed. Caches the returned list in the 'list' ivar" 269366 getListSelector == nil ifTrue: [^ #()]. 269367 list := model perform: getListSelector. 269368 list == nil ifTrue: [^ #()]. 269369 list := list collect: [ :item | item asStringOrText ]. 269370 ^ list! ! 269371 269372!PluggableListMorph methodsFor: 'model access' stamp: 'ls 7/1/2001 10:39'! 269373getListItem: index 269374 "get the index-th item in the displayed list" 269375 getListElementSelector ifNotNil: [ ^(model perform: getListElementSelector with: index) asStringOrText ]. 269376 list ifNotNil: [ ^list at: index ]. 269377 ^self getList at: index! ! 269378 269379!PluggableListMorph methodsFor: 'model access' stamp: 'ls 5/17/2001 22:04'! 269380getListSize 269381 "return the current number of items in the displayed list" 269382 getListSizeSelector ifNotNil: [ ^model perform: getListSizeSelector ]. 269383 ^self getList size! ! 269384 269385!PluggableListMorph methodsFor: 'model access' stamp: 'ls 6/10/2001 12:26'! 269386itemSelectedAmongMultiple: index 269387 "return whether the index-th row is selected. Always false in PluggableListMorph, but sometimes true in PluggableListMorphOfMany" 269388 ^false! ! 269389 269390!PluggableListMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:05'! 269391modifierKeyPressed: aChar 269392 | args | 269393 keystrokeActionSelector isNil ifTrue: [^nil]. 269394 args := keystrokeActionSelector numArgs. 269395 args = 1 ifTrue: [^model perform: keystrokeActionSelector with: aChar]. 269396 args = 2 269397 ifTrue: 269398 [^model 269399 perform: keystrokeActionSelector 269400 with: aChar 269401 with: self]. 269402 ^self error: 'keystrokeActionSelector must be a 1- or 2-keyword symbol'! ! 269403 269404 269405!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:19'! 269406doubleClick: event onItem: aMorph 269407 self removeObsoleteEventHandlers.! ! 269408 269409!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:19'! 269410mouseDown: event onItem: aMorph 269411 self removeObsoleteEventHandlers.! ! 269412 269413!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! 269414mouseEnterDragging: anEvent onItem: aMorph 269415 self removeObsoleteEventHandlers.! ! 269416 269417!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! 269418mouseLeaveDragging: anEvent onItem: aMorph 269419 self removeObsoleteEventHandlers.! ! 269420 269421!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! 269422mouseUp: event onItem: aMorph 269423 self removeObsoleteEventHandlers.! ! 269424 269425!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! 269426removeObsoleteEventHandlers 269427 scroller submorphs do:[:m| 269428 m eventHandler: nil; highlightForMouseDown: false; resetExtension].! ! 269429 269430!PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! 269431startDrag: evt onItem: itemMorph 269432 self removeObsoleteEventHandlers.! ! 269433 269434 269435!PluggableListMorph methodsFor: 'scroll cache' stamp: 'sps 4/3/2005 15:29'! 269436deriveHScrollRange 269437 269438 | unadjustedRange totalRange | 269439 (list isNil or: [list isEmpty]) 269440 ifTrue:[hScrollRangeCache := Array with: 0 with: 0 with: 0 with: 0 with: 0 ] 269441 ifFalse:[ 269442 unadjustedRange := self listMorph hUnadjustedScrollRange. 269443 totalRange := unadjustedRange + self hExtraScrollRange + self hMargin. 269444 hScrollRangeCache := Array 269445 with: totalRange 269446 with: unadjustedRange 269447 with: list size 269448 with: list first 269449 with: list last . 269450 ]. 269451! ! 269452 269453!PluggableListMorph methodsFor: 'scroll cache' stamp: 'sps 4/3/2005 15:29'! 269454resetHScrollRange 269455 269456 hScrollRangeCache := nil. 269457 self deriveHScrollRange. 269458! ! 269459 269460!PluggableListMorph methodsFor: 'scroll cache' stamp: 'sps 4/3/2005 15:29'! 269461resetHScrollRangeIfNecessary 269462 269463 hScrollRangeCache ifNil: [ ^self deriveHScrollRange ]. 269464 269465 (list isNil or: [list isEmpty]) 269466 ifTrue:[^hScrollRangeCache := Array with: 0 with: 0 with: 0 with: 0 with: 0]. 269467 269468"Make a guess as to whether the scroll ranges need updating based on whether the size, first item, or last item of the list has changed" 269469 ( 269470 (hScrollRangeCache third == list size) and: [ 269471 (hScrollRangeCache fourth == list first) and: [ 269472 (hScrollRangeCache fifth == list last) 269473 ]]) 269474 ifFalse:[self deriveHScrollRange]. 269475 269476! ! 269477 269478 269479!PluggableListMorph methodsFor: 'scrolling' stamp: 'sps 12/24/2002 18:31'! 269480hExtraScrollRange 269481 "Return the amount of extra blank space to include to the right of the scroll content." 269482 ^5 269483! ! 269484 269485!PluggableListMorph methodsFor: 'scrolling' stamp: 'adrian-lienhard 6/22/2009 00:00'! 269486numSelectionsInView 269487 "Answer the scroller's height based on the average number of submorphs." 269488 269489 "ugly hack, due to code smell. 269490 PluggableListMorph added another level of indirection, 269491 There is always only one submorph - a LazyListMorph which holds the actual list, 269492 but TransformMorph doesn't know that and we are left with a breach of interface." 269493 269494 ^scroller numberOfItemsPotentiallyInViewWith: scroller submorphs last getListSize.! ! 269495 269496!PluggableListMorph methodsFor: 'scrolling' stamp: 'sps 12/26/2002 13:36'! 269497vUnadjustedScrollRange 269498 "Return the height extent of the receiver's submorphs." 269499 (scroller submorphs size > 0) ifFalse:[ ^0 ]. 269500 ^(scroller submorphs last fullBounds bottom) 269501! ! 269502 269503 269504!PluggableListMorph methodsFor: 'selection' stamp: 'di 6/21/1998 22:19'! 269505getListSelector 269506 ^ getListSelector! ! 269507 269508!PluggableListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:20'! 269509minimumSelection 269510 ^ 1! ! 269511 269512!PluggableListMorph methodsFor: 'selection' stamp: 'ls 6/16/2001 14:15'! 269513scrollSelectionIntoView 269514 "make sure that the current selection is visible" 269515 | row | 269516 row := self getCurrentSelectionIndex. 269517 row = 0 ifTrue: [ ^ self ]. 269518 self scrollToShow: (self listMorph drawBoundsForRow: row)! ! 269519 269520!PluggableListMorph methodsFor: 'selection' stamp: 'ls 8/19/2001 14:20'! 269521selectedMorph 269522 "this doesn't work with the LargeLists patch!! Use #selectionIndex and #selection instead." 269523 ^self scroller submorphs at: self selectionIndex! ! 269524 269525!PluggableListMorph methodsFor: 'selection' stamp: 'nk 7/30/2004 17:53'! 269526selectedMorph: aMorph 269527 "this shouldn't be used any longer" 269528 269529 "self isThisEverCalled ." 269530 269531 Beeper beep. 269532 true ifTrue: [^self]! ! 269533 269534!PluggableListMorph methodsFor: 'selection' stamp: 'ls 8/19/2001 14:29'! 269535selection 269536 self selectionIndex = 0 ifTrue: [ ^nil ]. 269537 list ifNotNil: [ ^list at: self selectionIndex ]. 269538 ^ self getListItem: self selectionIndex! ! 269539 269540!PluggableListMorph methodsFor: 'selection' stamp: 'ls 6/22/2001 22:49'! 269541selection: item 269542 "Called from outside to request setting a new selection." 269543 269544 self selectionIndex: (self getList indexOf: item)! ! 269545 269546!PluggableListMorph methodsFor: 'selection' stamp: 'ls 6/22/2001 22:49'! 269547selectionIndex 269548 "return the index we have currently selected, or 0 if none" 269549 ^self listMorph selectedRow ifNil: [ 0 ]! ! 269550 269551!PluggableListMorph methodsFor: 'selection' stamp: 'sw 10/30/2000 11:16'! 269552setGetListSelector: sel 269553 "Set the the receiver's getListSelector as indicated. For access via scripting" 269554 269555 getListSelector := sel! ! 269556 269557!PluggableListMorph methodsFor: 'selection' stamp: 'di 5/6/1998 21:20'! 269558setSelectedMorph: aMorph 269559 self changeModelSelection: (scroller submorphs indexOf: aMorph)! ! 269560 269561 269562!PluggableListMorph methodsFor: 'submorphs-accessing' stamp: 'di 11/14/2001 13:57'! 269563allSubmorphNamesDo: nameBlock 269564 "Assume list morphs do not have named parts -- saves MUCH time" 269565 269566 ^ self! ! 269567 269568 269569!PluggableListMorph methodsFor: 'updating' stamp: 'ls 5/15/2001 22:31'! 269570update: aSymbol 269571 "Refer to the comment in View|update:." 269572 269573 aSymbol == getListSelector ifTrue: 269574 [self updateList. 269575 ^ self]. 269576 aSymbol == getIndexSelector ifTrue: 269577 [self selectionIndex: self getCurrentSelectionIndex. 269578 ^ self]. 269579! ! 269580 269581!PluggableListMorph methodsFor: 'updating' stamp: 'ls 6/22/2001 23:56'! 269582updateList 269583 | index | 269584 "the list has changed -- update from the model" 269585 self listMorph listChanged. 269586 self setScrollDeltas. 269587 scrollBar setValue: 0.0. 269588 index := self getCurrentSelectionIndex. 269589 self resetPotentialDropRow. 269590 self selectionIndex: index. 269591! ! 269592 269593"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 269594 269595PluggableListMorph class 269596 instanceVariableNames: ''! 269597 269598!PluggableListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:33'! 269599on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel 269600 "Create a 'pluggable' list view on the given model parameterized by the given message selectors." 269601 269602 ^ self new 269603 on: anObject 269604 list: getListSel 269605 selected: getSelectionSel 269606 changeSelected: setSelectionSel 269607 menu: nil 269608 keystroke: #arrowKey:from: "default"! ! 269609 269610!PluggableListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:33'! 269611on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel 269612 "Create a 'pluggable' list view on the given model parameterized by the given message selectors." 269613 269614 ^ self new 269615 on: anObject 269616 list: getListSel 269617 selected: getSelectionSel 269618 changeSelected: setSelectionSel 269619 menu: getMenuSel 269620 keystroke: #arrowKey:from: "default" 269621! ! 269622 269623!PluggableListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:33'! 269624on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel 269625 "Create a 'pluggable' list view on the given model parameterized by the given message selectors." 269626 269627 ^ self new 269628 on: anObject 269629 list: getListSel 269630 selected: getSelectionSel 269631 changeSelected: setSelectionSel 269632 menu: getMenuSel 269633 keystroke: keyActionSel 269634! ! 269635PluggableListMorph subclass: #PluggableListMorphByItem 269636 instanceVariableNames: 'itemList' 269637 classVariableNames: '' 269638 poolDictionaries: '' 269639 category: 'Morphic-Pluggable Widgets'! 269640 269641!PluggableListMorphByItem methodsFor: 'as yet unclassified' stamp: 'ls 8/19/2001 15:57'! 269642getList 269643 "cache the raw items in itemList" 269644 itemList := getListSelector ifNil: [ #() ] ifNotNil: [ model perform: getListSelector ]. 269645 ^super getList! ! 269646 269647 269648!PluggableListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 15:58'! 269649changeModelSelection: anInteger 269650 "Change the model's selected item to be the one at the given index." 269651 269652 | item | 269653 setIndexSelector ifNotNil: [ 269654 item := (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]). 269655 model perform: setIndexSelector with: item]. 269656 self update: getIndexSelector. 269657! ! 269658 269659!PluggableListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 14:51'! 269660getCurrentSelectionIndex 269661 "Answer the index of the current selection." 269662 | item | 269663 getIndexSelector == nil ifTrue: [^ 0]. 269664 item := model perform: getIndexSelector. 269665 ^ list findFirst: [ :x | x = item] 269666! ! 269667PluggableListMorphPlus subclass: #PluggableListMorphByItemPlus 269668 instanceVariableNames: 'itemList' 269669 classVariableNames: '' 269670 poolDictionaries: '' 269671 category: 'ToolBuilder-Morphic'! 269672!PluggableListMorphByItemPlus commentStamp: '<historical>' prior: 0! 269673Main comment stating the purpose of this class and relevant relationship to other classes. 269674 269675Possible useful expressions for doIt or printIt. 269676 269677Structure: 269678 instVar1 type -- comment about the purpose of instVar1 269679 instVar2 type -- comment about the purpose of instVar2 269680 269681Any further useful comments about the general approach of this implementation.! 269682 269683 269684!PluggableListMorphByItemPlus methodsFor: 'as yet unclassified' stamp: 'ar 7/15/2005 11:23'! 269685getList 269686 "cache the raw items in itemList" 269687 itemList := getListSelector ifNil: [ #() ] ifNotNil: [ model perform: getListSelector ]. 269688 ^super getList! ! 269689 269690 269691!PluggableListMorphByItemPlus methodsFor: 'model access' stamp: 'stephaneducasse 2/3/2006 22:35'! 269692changeModelSelection: anInteger 269693 "Change the model's selected item to be the one at the given index." 269694 269695 | item | 269696 setIndexSelector ifNotNil: [ 269697 item := (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]). 269698 model perform: setIndexSelector with: item]. 269699 self update: getIndexSelector. 269700! ! 269701 269702!PluggableListMorphByItemPlus methodsFor: 'model access' stamp: 'stephaneducasse 2/3/2006 22:35'! 269703getCurrentSelectionIndex 269704 "Answer the index of the current selection." 269705 | item | 269706 getIndexSelector == nil ifTrue: [^ 0]. 269707 item := model perform: getIndexSelector. 269708 ^ list findFirst: [ :x | x = item] 269709! ! 269710PluggableListMorph subclass: #PluggableListMorphOfMany 269711 instanceVariableNames: 'dragOnOrOff getSelectionListSelector setSelectionListSelector' 269712 classVariableNames: '' 269713 poolDictionaries: '' 269714 category: 'Morphic-Pluggable Widgets'! 269715!PluggableListMorphOfMany commentStamp: 'hpt 4/5/2004 11:21' prior: 0! 269716A variant of its superclass that allows multiple items to be selected simultaneously. There is still a distinguished element which is selected, but each other element in the list may be flagged on or off. 269717! 269718 269719 269720!PluggableListMorphOfMany methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/21/2007 14:39'! 269721mouseDown: event 269722 "Grab keyboard focus and set mouseDownRow." 269723 269724 | oldIndex oldVal row | 269725 event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed]. 269726 self wantsKeyboardFocus 269727 ifTrue: [self takeKeyboardFocus]. 269728 row := self rowAtLocation: event position. 269729 row = 0 ifTrue: [^super mouseDown: event]. 269730 self mouseDownRow: row. 269731 269732 model okToChange ifFalse: [^ self]. "No change if model is locked" 269733 269734 "Set meaning for subsequent dragging of selection" 269735 dragOnOrOff := (self listSelectionAt: row) not. 269736 oldIndex := self getCurrentSelectionIndex. 269737 oldIndex ~= 0 ifTrue: [oldVal := self listSelectionAt: oldIndex]. 269738 269739 "Set or clear new primary selection (listIndex)" 269740 dragOnOrOff 269741 ifTrue: [self changeModelSelection: row] 269742 ifFalse: [self changeModelSelection: 0]. 269743 269744 "Need to restore the old one, due to how model works, and set new one." 269745 oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. 269746 self listSelectionAt: row put: dragOnOrOff. 269747 "event hand releaseMouseFocus: aMorph." 269748 "aMorph changed"! ! 269749 269750!PluggableListMorphOfMany methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/16/2006 13:29'! 269751mouseUp: event 269752 "Reset the mouseDownRow." 269753 269754 dragOnOrOff := nil. "So improperly started drags will have not effect". 269755 event hand hasSubmorphs ifFalse: [ 269756 self mouseDownRow: nil]! ! 269757 269758 269759!PluggableListMorphOfMany methodsFor: 'drawing' stamp: 'tpr 10/4/2001 21:26'! 269760listSelectionAt: index 269761 getSelectionListSelector ifNil:[^false]. 269762 ^model perform: getSelectionListSelector with: index! ! 269763 269764!PluggableListMorphOfMany methodsFor: 'drawing' stamp: 'tpr 10/4/2001 21:27'! 269765listSelectionAt: index put: value 269766 setSelectionListSelector ifNil:[^false]. 269767 ^model perform: setSelectionListSelector with: index with: value! ! 269768 269769 269770!PluggableListMorphOfMany methodsFor: 'event handling' stamp: 'nk 10/14/2003 22:19'! 269771mouseMove: event 269772 "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" 269773 269774 | oldIndex oldVal row | 269775 event position y < self top 269776 ifTrue: 269777 [scrollBar scrollUp: 1. 269778 row := self rowAtLocation: scroller topLeft + (1 @ 1)] 269779 ifFalse: 269780 [row := event position y > self bottom 269781 ifTrue: 269782 [scrollBar scrollDown: 1. 269783 self rowAtLocation: scroller bottomLeft + (1 @ -1)] 269784 ifFalse: [ self rowAtLocation: event position]]. 269785 row = 0 ifTrue: [^super mouseDown: event]. 269786 269787 model okToChange ifFalse: [^self]. "No change if model is locked" 269788 269789 dragOnOrOff ifNil: 269790 ["Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" 269791 dragOnOrOff := (self listSelectionAt: row) not]. 269792 269793 "Set meaning for subsequent dragging of selection" 269794 oldIndex := self getCurrentSelectionIndex. 269795 oldIndex ~= 0 ifTrue: [oldVal := self listSelectionAt: oldIndex]. 269796 269797 "Set or clear new primary selection (listIndex)" 269798 dragOnOrOff 269799 ifTrue: [self changeModelSelection: row] 269800 ifFalse: [self changeModelSelection: 0]. 269801 269802 "Need to restore the old one, due to how model works, and set new one." 269803 oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. 269804 self listSelectionAt: row put: dragOnOrOff. 269805 row changed! ! 269806 269807 269808!PluggableListMorphOfMany methodsFor: 'initialization' stamp: 'tpr 10/4/2001 21:24'! 269809on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel 269810 "setup a whole load of pluggability options" 269811 getSelectionListSelector := getListSel. 269812 setSelectionListSelector := setListSel. 269813 super on: anObject list: listSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel 269814! ! 269815 269816 269817!PluggableListMorphOfMany methodsFor: 'model access' stamp: 'hpt 4/5/2004 11:00'! 269818itemSelectedAmongMultiple: index 269819 ^self listSelectionAt: index! ! 269820 269821 269822!PluggableListMorphOfMany methodsFor: 'updating' stamp: 'di 11/10/1998 14:44'! 269823update: aSymbol 269824 aSymbol == #allSelections ifTrue: 269825 [self selectionIndex: self getCurrentSelectionIndex. 269826 ^ self changed]. 269827 ^ super update: aSymbol! ! 269828 269829"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 269830 269831PluggableListMorphOfMany class 269832 instanceVariableNames: ''! 269833 269834!PluggableListMorphOfMany class methodsFor: 'instance creation' stamp: 'tpr 10/4/2001 21:54'! 269835on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel 269836 ^ self new 269837 on: anObject 269838 list: listSel 269839 primarySelection: getSelectionSel 269840 changePrimarySelection: setSelectionSel 269841 listSelection: getListSel 269842 changeListSelection: setListSel 269843 menu: getMenuSel 269844 keystroke: #arrowKey:from: "default"! ! 269845 269846!PluggableListMorphOfMany class methodsFor: 'instance creation' stamp: 'tpr 10/4/2001 21:52'! 269847on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel 269848 ^ self new 269849 on: anObject 269850 list: listSel 269851 primarySelection: getSelectionSel 269852 changePrimarySelection: setSelectionSel 269853 listSelection: getListSel 269854 changeListSelection: setListSel 269855 menu: getMenuSel 269856 keystroke: keyActionSel! ! 269857PluggableListMorph subclass: #PluggableListMorphPlus 269858 instanceVariableNames: 'dragItemSelector dropItemSelector wantsDropSelector' 269859 classVariableNames: '' 269860 poolDictionaries: '' 269861 category: 'ToolBuilder-Morphic'! 269862!PluggableListMorphPlus commentStamp: 'ar 7/15/2005 11:10' prior: 0! 269863Extensions for PluggableListMorph needed by ToolBuilder! 269864 269865 269866!PluggableListMorphPlus methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:24'! 269867dragItemSelector 269868 ^dragItemSelector! ! 269869 269870!PluggableListMorphPlus methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:26'! 269871dragItemSelector: aSymbol 269872 dragItemSelector := aSymbol. 269873 aSymbol ifNotNil:[self dragEnabled: true].! ! 269874 269875!PluggableListMorphPlus methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:25'! 269876dropItemSelector 269877 ^dropItemSelector! ! 269878 269879!PluggableListMorphPlus methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:25'! 269880dropItemSelector: aSymbol 269881 dropItemSelector := aSymbol. 269882 aSymbol ifNotNil:[self dropEnabled: true].! ! 269883 269884!PluggableListMorphPlus methodsFor: 'accessing' stamp: 'ar 7/15/2005 12:07'! 269885wantsDropSelector 269886 ^wantsDropSelector! ! 269887 269888!PluggableListMorphPlus methodsFor: 'accessing' stamp: 'ar 7/15/2005 12:07'! 269889wantsDropSelector: aSymbol 269890 wantsDropSelector := aSymbol! ! 269891 269892 269893!PluggableListMorphPlus methodsFor: 'drag and drop' stamp: 'ar 7/15/2005 11:28'! 269894acceptDroppingMorph: aMorph event: evt 269895 | item | 269896 dropItemSelector ifNil:[^self]. 269897 item := aMorph passenger. 269898 model perform: dropItemSelector with: item with: potentialDropRow. 269899 self resetPotentialDropRow. 269900 evt hand releaseMouseFocus: self. 269901 Cursor normal show. 269902! ! 269903 269904!PluggableListMorphPlus methodsFor: 'drag and drop' stamp: 'ar 7/15/2005 11:44'! 269905startDrag: evt 269906 | ddm draggedItem dragIndex | 269907 dragItemSelector ifNil:[^self]. 269908 evt hand hasSubmorphs ifTrue: [^ self]. 269909 [(self dragEnabled and: [model okToChange]) ifFalse: [^ self]. 269910 dragIndex := self rowAtLocation: evt position. 269911 dragIndex = 0 ifTrue:[^self]. 269912 draggedItem := model perform: dragItemSelector with: dragIndex. 269913 draggedItem ifNil:[^self]. 269914 ddm := TransferMorph withPassenger: draggedItem from: self. 269915 ddm dragTransferType: #dragTransferPlus. 269916 evt hand grabMorph: ddm] 269917 ensure: [Cursor normal show. 269918 evt hand releaseMouseFocus: self]! ! 269919 269920!PluggableListMorphPlus methodsFor: 'drag and drop' stamp: 'ar 7/15/2005 12:08'! 269921wantsDroppedMorph: aMorph event: anEvent 269922 aMorph dragTransferType == #dragTransferPlus ifFalse:[^false]. 269923 dropItemSelector ifNil:[^false]. 269924 wantsDropSelector ifNil:[^true]. 269925 ^(model perform: wantsDropSelector with: aMorph passenger) == true! ! 269926PluggableWidgetSpec subclass: #PluggableListSpec 269927 instanceVariableNames: 'list getIndex setIndex getSelected setSelected menu keyPress autoDeselect dragItem dropItem dropAccept' 269928 classVariableNames: '' 269929 poolDictionaries: '' 269930 category: 'ToolBuilder-Kernel'! 269931!PluggableListSpec commentStamp: 'ar 7/15/2005 11:54' prior: 0! 269932A single selection list element. 269933 269934Instance variables: 269935 list <Symbol> The selector to retrieve the list elements. 269936 getIndex <Symbol> The selector to retrieve the list selection index. 269937 setIndex <Symbol> The selector to set the list selection index. 269938 getSelected <Symbol> The selector to retrieve the list selection. 269939 setSelected <Symbol> The selector to set the list selection. 269940 menu <Symbol> The selector to offer (to retrieve?) the context menu. 269941 keyPress <Symbol> The selector to invoke for handling keyboard shortcuts. 269942 autoDeselect <Boolean> Whether the list should allow automatic deselection or not. 269943 dragItem <Symbol> Selector to initiate a drag action on an item 269944 dropItem <Symbol> Selector to initiate a drop action of an item 269945 dropAccept <Symbol> Selector to determine whether a drop would be accepted! 269946 269947 269948!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 16:42'! 269949autoDeselect 269950 "Answer whether this tree can be automatically deselected" 269951 ^autoDeselect ifNil:[true]! ! 269952 269953!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 16:41'! 269954autoDeselect: aBool 269955 "Indicate whether this tree can be automatically deselected" 269956 autoDeselect := aBool! ! 269957 269958!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:07'! 269959dragItem 269960 "Answer the selector for dragging an item" 269961 ^dragItem! ! 269962 269963!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:07'! 269964dragItem: aSymbol 269965 "Set the selector for dragging an item" 269966 dragItem := aSymbol! ! 269967 269968!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:54'! 269969dropAccept 269970 "Answer the selector to determine whether a drop would be accepted" 269971 ^dropAccept! ! 269972 269973!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:55'! 269974dropAccept: aSymbol 269975 "Answer the selector to determine whether a drop would be accepted" 269976 dropAccept := aSymbol.! ! 269977 269978!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:07'! 269979dropItem 269980 "Answer the selector for dropping an item" 269981 ^dropItem! ! 269982 269983!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 11:07'! 269984dropItem: aSymbol 269985 "Set the selector for dropping an item" 269986 dropItem := aSymbol! ! 269987 269988!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:21'! 269989getIndex 269990 "Answer the selector for retrieving the list's selection index" 269991 ^getIndex! ! 269992 269993!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:21'! 269994getIndex: aSymbol 269995 "Indicate the selector for retrieving the list's selection index" 269996 getIndex := aSymbol! ! 269997 269998!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/10/2005 22:33'! 269999getSelected 270000 "Answer the selector for retrieving the list selection" 270001 ^getSelected! ! 270002 270003!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/10/2005 22:33'! 270004getSelected: aSymbol 270005 "Indicate the selector for retrieving the list selection" 270006 getSelected := aSymbol! ! 270007 270008!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:23'! 270009keyPress 270010 "Answer the selector for invoking the list's keyPress handler" 270011 ^keyPress! ! 270012 270013!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:23'! 270014keyPress: aSymbol 270015 "Indicate the selector for invoking the list's keyPress handler" 270016 keyPress := aSymbol! ! 270017 270018!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:20'! 270019list 270020 "Answer the selector for retrieving the list contents" 270021 ^list! ! 270022 270023!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 19:24'! 270024list: aSymbol 270025 "Indicate the selector for retrieving the list contents" 270026 list := aSymbol.! ! 270027 270028!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:22'! 270029menu 270030 "Answer the selector for retrieving the list's menu" 270031 ^menu! ! 270032 270033!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:22'! 270034menu: aSymbol 270035 "Indicate the selector for retrieving the list's menu" 270036 menu := aSymbol! ! 270037 270038!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:21'! 270039setIndex 270040 "Answer the selector for setting the list's selection index" 270041 ^setIndex! ! 270042 270043!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:21'! 270044setIndex: aSymbol 270045 "Answer the selector for setting the list's selection index" 270046 setIndex := aSymbol! ! 270047 270048!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/10/2005 22:34'! 270049setSelected 270050 "Answer the selector for setting the list selection" 270051 ^setSelected! ! 270052 270053!PluggableListSpec methodsFor: 'accessing' stamp: 'ar 2/10/2005 22:33'! 270054setSelected: aSymbol 270055 "Indicate the selector for setting the list selection" 270056 setSelected := aSymbol! ! 270057 270058 270059!PluggableListSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'! 270060buildWith: builder 270061 ^builder buildPluggableList: self! ! 270062ToolBuilderSpec subclass: #PluggableMenuItemSpec 270063 instanceVariableNames: 'label action checked enabled separator subMenu help' 270064 classVariableNames: '' 270065 poolDictionaries: '' 270066 category: 'ToolBuilder-Kernel'! 270067 270068!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:23'! 270069action 270070 "Answer the action associated with the receiver" 270071 ^action! ! 270072 270073!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:23'! 270074action: aMessageSend 270075 "Answer the action associated with the receiver" 270076 action := aMessageSend! ! 270077 270078!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:28'! 270079checked 270080 "Answer whether the receiver is checked" 270081 ^checked ifNil:[false]! ! 270082 270083!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:21'! 270084checked: aBool 270085 "Indicate whether the receiver is checked" 270086 checked := aBool.! ! 270087 270088!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:28'! 270089enabled 270090 "Answer whether the receiver is enabled" 270091 ^enabled ifNil:[true]! ! 270092 270093!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:21'! 270094enabled: aBool 270095 "Indicate whether the receiver is enabled" 270096 enabled := aBool! ! 270097 270098!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:24'! 270099help 270100 "Answer the help text associated with the receiver" 270101 ^help! ! 270102 270103!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:24'! 270104help: aString 270105 "Answer the help text associated with the receiver" 270106 help := aString.! ! 270107 270108!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:20'! 270109label 270110 "Answer the receiver's label" 270111 ^label! ! 270112 270113!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:21'! 270114label: aString 270115 "Set the receiver's label" 270116 label := aString! ! 270117 270118!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:28'! 270119separator 270120 "Answer whether the receiver should be followed by a separator" 270121 ^separator ifNil:[false]! ! 270122 270123!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:22'! 270124separator: aBool 270125 "Indicate whether the receiver should be followed by a separator" 270126 separator := aBool.! ! 270127 270128!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:22'! 270129subMenu 270130 "Answer the receiver's subMenu" 270131 ^subMenu! ! 270132 270133!PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:22'! 270134subMenu: aMenuSpec 270135 "Answer the receiver's subMenu" 270136 subMenu := aMenuSpec! ! 270137 270138 270139!PluggableMenuItemSpec methodsFor: 'building' stamp: 'ar 2/28/2006 17:23'! 270140buildWith: builder 270141 ^ builder buildPluggableMenuItem: self! ! 270142ToolBuilderSpec subclass: #PluggableMenuSpec 270143 instanceVariableNames: 'label model items' 270144 classVariableNames: '' 270145 poolDictionaries: '' 270146 category: 'ToolBuilder-Kernel'! 270147 270148!PluggableMenuSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:27'! 270149items 270150 ^ items ifNil: [items := OrderedCollection new]! ! 270151 270152!PluggableMenuSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:12'! 270153label 270154 ^label! ! 270155 270156!PluggableMenuSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:12'! 270157label: aString 270158 label := aString.! ! 270159 270160!PluggableMenuSpec methodsFor: 'accessing' stamp: 'cwp 6/8/2005 23:36'! 270161model 270162 ^ model! ! 270163 270164!PluggableMenuSpec methodsFor: 'accessing' stamp: 'cwp 6/8/2005 23:36'! 270165model: anObject 270166 model := anObject! ! 270167 270168 270169!PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:26'! 270170add: aString action: aMessageSend 270171 | item | 270172 item := self addMenuItem. 270173 item label: aString. 270174 item action: aMessageSend. 270175 ^item! ! 270176 270177!PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:25'! 270178add: aString target: anObject selector: aSelector argumentList: anArray 270179 ^self add: aString action: (MessageSend 270180 receiver: anObject 270181 selector: aSelector 270182 arguments: anArray).! ! 270183 270184!PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:27'! 270185addMenuItem 270186 | item | 270187 item := self newMenuItem. 270188 self items add: item. 270189 ^item! ! 270190 270191!PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:25'! 270192addSeparator 270193 self items isEmpty ifTrue:[^nil]. 270194 self items last separator: true.! ! 270195 270196!PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 6/21/2005 10:45'! 270197buildWith: builder 270198 ^ builder buildPluggableMenu: self! ! 270199 270200!PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:27'! 270201newMenuItem 270202 ^PluggableMenuItemSpec new! ! 270203 270204"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 270205 270206PluggableMenuSpec class 270207 instanceVariableNames: ''! 270208 270209!PluggableMenuSpec class methodsFor: 'as yet unclassified' stamp: 'cwp 6/9/2005 00:22'! 270210withModel: aModel 270211 ^ self new model: aModel! ! 270212PluggableListMorph subclass: #PluggableMessageCategoryListMorph 270213 instanceVariableNames: 'getRawListSelector priorRawList' 270214 classVariableNames: '' 270215 poolDictionaries: '' 270216 category: 'Morphic-Pluggable Widgets'! 270217!PluggableMessageCategoryListMorph commentStamp: '<historical>' prior: 0! 270218A variant of PluggableListMorph designed specially for efficient handling of the --all-- feature in message-list panes. In order to be able *quickly* to check whether there has been an external change to the list, we cache the raw list for identity comparison (the actual list is a combination of the --all-- element and the the actual list).! 270219 270220 270221!PluggableMessageCategoryListMorph methodsFor: 'as yet unclassified' stamp: 'md 10/20/2004 15:32'! 270222on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel 270223 self model: anObject. 270224 getListSelector := getListSel. 270225 getIndexSelector := getSelectionSel. 270226 setIndexSelector := setSelectionSel. 270227 getMenuSelector := getMenuSel. 270228 keystrokeActionSelector := keyActionSel. 270229 autoDeselect := true. 270230 self borderWidth: 1. 270231 getRawListSelector := getRawSel. 270232 self updateList. 270233 self selectionIndex: self getCurrentSelectionIndex. 270234 self initForKeystrokes! ! 270235 270236 270237!PluggableMessageCategoryListMorph methodsFor: 'model access' stamp: 'ls 8/19/2001 15:35'! 270238getList 270239 "Differs from the generic in that here we obtain and cache the raw list, then cons it together with the special '-- all --' item to produce the list to be used in the browser. This special handling is done in order to avoid excessive and unnecessary reformulation of the list in the step method" 270240 270241 getRawListSelector == nil ifTrue: ["should not happen!!" priorRawList := nil. ^ #()]. 270242 model classListIndex = 0 ifTrue: [^ priorRawList := list := Array new]. 270243 priorRawList := model perform: getRawListSelector. 270244 list := (Array with: ClassOrganizer allCategory), priorRawList. 270245 ^list! ! 270246 270247 270248!PluggableMessageCategoryListMorph methodsFor: 'updating' stamp: 'ls 8/19/2001 14:26'! 270249verifyContents 270250 270251 | newList existingSelection anIndex newRawList | 270252 (model editSelection == #editComment) ifTrue: [^ self]. 270253 model classListIndex = 0 ifTrue: [^ self]. 270254 newRawList := model perform: getRawListSelector. 270255 newRawList == priorRawList ifTrue: [^ self]. "The usual case; very fast" 270256 priorRawList := newRawList. 270257 newList := (Array with: ClassOrganizer allCategory), priorRawList. 270258 list = newList ifTrue: [^ self]. 270259 self flash. "could get annoying, but hell" 270260 existingSelection := self selection. 270261 self updateList. 270262 (anIndex := newList indexOf: existingSelection ifAbsent: [nil]) 270263 ifNotNil: 270264 [model noteSelectionIndex: anIndex for: getListSelector. 270265 self selectionIndex: anIndex] 270266 ifNil: 270267 [self changeModelSelection: 0]! ! 270268 270269"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 270270 270271PluggableMessageCategoryListMorph class 270272 instanceVariableNames: ''! 270273 270274!PluggableMessageCategoryListMorph class methodsFor: 'as yet unclassified' stamp: 'md 11/14/2003 16:59'! 270275on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel 270276 ^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel! ! 270277PluggableListMorph subclass: #PluggableMorphListMorph 270278 instanceVariableNames: '' 270279 classVariableNames: '' 270280 poolDictionaries: '' 270281 category: 'Polymorph-Widgets'! 270282!PluggableMorphListMorph commentStamp: 'gvc 5/18/2007 12:30' prior: 0! 270283A type of PluggableListMorph that supports morphs for items. Useful for lists with icons etc.! 270284 270285 270286!PluggableMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 15:46'! 270287basicKeyPressed: aChar 270288 | oldSelection nextSelection max milliSeconds nextSelectionList nextSelectionText s| 270289 nextSelection := oldSelection := self getCurrentSelectionIndex. 270290 max := self maximumSelection. 270291 milliSeconds := Time millisecondClockValue. 270292 milliSeconds - lastKeystrokeTime > 300 ifTrue: ["just use the one current character for selecting" 270293 lastKeystrokes := '']. 270294 lastKeystrokes := lastKeystrokes , aChar asLowercase asString. 270295 lastKeystrokeTime := milliSeconds. 270296 nextSelectionList := OrderedCollection newFrom: (list copyFrom: oldSelection + 1 to: max). 270297 nextSelectionList addAll: (list copyFrom: 1 to: oldSelection). 270298 "Get rid of blanks and style used in some lists" 270299 nextSelectionText := nextSelectionList detect: [:a | 270300 s := a userString ifNil: [(a submorphs collect: [:m | m userString]) detect: [:us | us notNil] ifNone: ['']]. 270301 s withBlanksTrimmed asLowercase beginsWith: lastKeystrokes] 270302 ifNone: [^ self flash"match not found"]. 270303 model okToChange ifFalse: [^ self]. 270304 nextSelection := list findFirst: [:a | 270305 s := a userString ifNil: [(a submorphs collect: [:m | m userString]) detect: [:us | us notNil] ifNone: ['']]. 270306 a == nextSelectionText]. 270307 "No change if model is locked" 270308 oldSelection == nextSelection ifTrue: [^ self flash]. 270309 ^ self changeModelSelection: nextSelection! ! 270310 270311!PluggableMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 14:23'! 270312extent: newExtent 270313 "Change listMorph's bounds to the new width. It is either the size 270314 of the widest list item, or the size of self, whatever is bigger" 270315 270316 super extent: newExtent. 270317 self listMorph width: (self innerBounds width max: listMorph hUnadjustedScrollRange). 270318! ! 270319 270320!PluggableMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/17/2008 12:38'! 270321getList 270322 "Answer the list to be displayed. Caches the returned list in the 'list' ivar" 270323 270324 getListSelector isNil ifTrue: [^#()]. 270325 list := model perform: getListSelector. 270326 list isNil ifTrue: [^ #()]. 270327 ^list! ! 270328 270329!PluggableMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 14:26'! 270330getListItem: index 270331 "get the index-th item in the displayed list" 270332 270333 getListElementSelector ifNotNil: [ 270334 ^model perform: getListElementSelector with: index]. 270335 (list notNil and: [list size >= index]) ifTrue: [ ^list at: index ]. 270336 ^self getList at: index! ! 270337 270338!PluggableMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 14:24'! 270339hExtraScrollRange 270340 "Return the amount of extra blank space to include to the right of the scroll content." 270341 270342 ^12! ! 270343 270344!PluggableMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 09:50'! 270345listMorphClass 270346 "Answer the class to use for the list morph." 270347 270348 ^LazyMorphListMorph! ! 270349PluggableListMorph subclass: #PluggableMultiColumnListMorph 270350 instanceVariableNames: 'lists' 270351 classVariableNames: '' 270352 poolDictionaries: '' 270353 category: 'Morphic-Pluggable Widgets'! 270354!PluggableMultiColumnListMorph commentStamp: '<historical>' prior: 0! 270355This morph can be used to show a list having multiple columns, The columns are self width sized to make the largest entry in each list fit. In some cases the pane may then be too narrow. 270356 270357Use it like a regular PluggableListMorph except pass in an array of lists instead of a single list. 270358 270359There are base assumptions made here that each list in the array of lists is the same size. 270360 270361Also, the highlight color for the selection is easy to modify in the #highlightSelection method. I used blue 270362when testing just to see it work.! 270363 270364 270365!PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'ls 5/18/2001 10:32'! 270366getListRow: row 270367 "return the strings that should appear in the requested row" 270368 getListElementSelector ifNotNil: [ ^model perform: getListElementSelector with: row ]. 270369 ^self getList collect: [ :l | l at: row ]! ! 270370 270371!PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'ls 5/17/2001 23:03'! 270372getListSize 270373 | l | 270374 getListSizeSelector ifNotNil: [ ^model perform: getListSizeSelector ]. 270375 270376 l := self getList. 270377 l isEmpty ifTrue: [ ^ 0 ]. 270378 ^l first size! ! 270379 270380!PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'nk 4/5/2001 23:18'! 270381itemFromPoint: aPoint 270382 "Return the list element (morph) at the given point or nil if outside" 270383 | ptY | 270384 scroller hasSubmorphs ifFalse:[^nil]. 270385 (scroller fullBounds containsPoint: aPoint) ifFalse:[^nil]. 270386 ptY := (scroller firstSubmorph point: aPoint from: self) y. 270387 "note: following assumes that submorphs are vertical, non-overlapping, and ordered" 270388 scroller firstSubmorph top > ptY ifTrue:[^nil]. 270389 scroller lastSubmorph bottom < ptY ifTrue:[^nil]. 270390 "now use binary search" 270391 ^scroller submorphThat: [ :item | item top <= ptY and:[item bottom >= ptY] ] ifNone: []. 270392! ! 270393 270394!PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'ls 5/17/2001 20:01'! 270395listMorphClass 270396 ^MulticolumnLazyListMorph! ! 270397 270398 270399!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'sbw 12/2/2000 08:37'! 270400calculateColumnOffsetsFrom: maxWidths 270401 | offsets previous current | 270402 offsets := Array new: maxWidths size. 270403 1 270404 to: offsets size 270405 do: [:indx | offsets at: indx put: (maxWidths at: indx) 270406 + 10]. 270407 2 270408 to: offsets size 270409 do: [:indx | 270410 previous := offsets at: indx - 1. 270411 current := offsets at: indx. 270412 current := previous + current. 270413 offsets at: indx put: current]. 270414 ^offsets 270415! ! 270416 270417!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'sbw 12/2/2000 08:36'! 270418calculateColumnWidthsFrom: arrayOfMorphs 270419 | maxWidths | 270420 maxWidths := Array new: arrayOfMorphs size - 1. 270421 1 270422 to: maxWidths size 270423 do: [:idx | maxWidths at: idx put: 0]. 270424 1 270425 to: maxWidths size 270426 do: [:idx | (arrayOfMorphs at: idx) 270427 do: [:mitem | mitem width 270428 > (maxWidths at: idx) 270429 ifTrue: [maxWidths at: idx put: mitem width]]]. 270430 ^maxWidths! ! 270431 270432!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:22'! 270433createMorphicListsFrom: arrayOfLists 270434 | array | 270435 270436 array := Array new: arrayOfLists size. 270437 1 to: arrayOfLists size do: [:arrayIndex | 270438 array at: arrayIndex put: ( 270439 (arrayOfLists at: arrayIndex) collect: [:item | item isText 270440 ifTrue: [StringMorph 270441 contents: item 270442 font: self font 270443 emphasis: (item emphasisAt: 1)] 270444 ifFalse: [StringMorph contents: item font: self font]]) 270445 ]. 270446 ^array! ! 270447 270448!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'sbw 12/2/2000 08:38'! 270449layoutMorphicLists: arrayOfMorphs 270450 | maxWidths offsets locs h | 270451 maxWidths := self calculateColumnWidthsFrom: arrayOfMorphs. 270452 offsets := self calculateColumnOffsetsFrom: maxWidths. 270453 locs := Array new: arrayOfMorphs size. 270454 locs at: 1 put: 0 @ 0. 270455 2 270456 to: locs size 270457 do: [:indx | locs at: indx put: (offsets at: indx - 1) 270458 @ 0]. 270459 h := arrayOfMorphs first first height. 270460 1 270461 to: arrayOfMorphs size 270462 do: [:indx | (arrayOfMorphs at: indx) 270463 do: [:morphItem | 270464 morphItem 270465 bounds: ((locs at: indx) 270466 extent: 9999 @ h). 270467 locs at: indx put: (locs at: indx) 270468 + (0 @ h)]]! ! 270469 270470 270471!PluggableMultiColumnListMorph methodsFor: 'model access' stamp: 'ls 11/14/2002 13:13'! 270472basicKeyPressed: aChar 270473 "net supported for multi-column lists; which column should be used?!! The issue is that the base class implementation uses getList expecting a single collectino to come back instead of several of them" 270474 ^self! ! 270475 270476!PluggableMultiColumnListMorph methodsFor: 'model access' stamp: 'ls 7/12/2001 23:24'! 270477getList 270478 "fetch and answer the lists to be displayed" 270479 getListSelector == nil ifTrue: [^ #()]. 270480 list := model perform: getListSelector. 270481 list == nil ifTrue: [^ #()]. 270482 list := list collect: [ :column | column collect: [ :item | item asStringOrText ] ]. 270483 ^ list! ! 270484 270485 270486!PluggableMultiColumnListMorph methodsFor: 'selection' stamp: 'ls 5/16/2001 22:24'! 270487highlightSelection 270488^self! ! 270489 270490!PluggableMultiColumnListMorph methodsFor: 'selection' stamp: 'ls 5/16/2001 22:23'! 270491unhighlightSelection 270492^self! ! 270493PluggableMultiColumnListMorph subclass: #PluggableMultiColumnListMorphByItem 270494 instanceVariableNames: '' 270495 classVariableNames: '' 270496 poolDictionaries: '' 270497 category: 'Morphic-Pluggable Widgets'! 270498 270499!PluggableMultiColumnListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 14:57'! 270500changeModelSelection: anInteger 270501 "Change the model's selected item to be the one at the given index." 270502 | item | 270503 setIndexSelector 270504 ifNotNil: [item := anInteger = 0 270505 ifFalse: [list first at: anInteger]. 270506 model perform: setIndexSelector with: item]. 270507 self update: getIndexSelector! ! 270508 270509!PluggableMultiColumnListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 15:11'! 270510getCurrentSelectionIndex 270511 "Answer the index of the current selection." 270512 | item | 270513 getIndexSelector == nil 270514 ifTrue: [^ 0]. 270515 item := model perform: getIndexSelector. 270516 270517 ^ list first 270518 findFirst: [:x | x = item]! ! 270519PluggableListSpec subclass: #PluggableMultiSelectionListSpec 270520 instanceVariableNames: 'getSelectionList setSelectionList' 270521 classVariableNames: '' 270522 poolDictionaries: '' 270523 category: 'ToolBuilder-Kernel'! 270524!PluggableMultiSelectionListSpec commentStamp: 'ar 2/12/2005 13:31' prior: 0! 270525PluggableMultiSelectionListSpec specifies a list with multiple selection behavior. 270526 270527Instance variables: 270528 getSelectionList <Symbol> The message to retrieve the multiple selections. 270529 setSelectionList <Symbol> The message to indicate multiple selections.! 270530 270531 270532!PluggableMultiSelectionListSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 13:32'! 270533getSelectionList 270534 "Answer the message to retrieve the multiple selections" 270535 ^getSelectionList! ! 270536 270537!PluggableMultiSelectionListSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 13:32'! 270538getSelectionList: aSymbol 270539 "Indicate the message to retrieve the multiple selections" 270540 getSelectionList := aSymbol! ! 270541 270542!PluggableMultiSelectionListSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 13:32'! 270543setSelectionList 270544 "Answer the message to indicate multiple selections" 270545 ^setSelectionList! ! 270546 270547!PluggableMultiSelectionListSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 13:32'! 270548setSelectionList: aSymbol 270549 "Indicate the message to indicate multiple selections" 270550 setSelectionList := aSymbol! ! 270551 270552 270553!PluggableMultiSelectionListSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'! 270554buildWith: builder 270555 ^builder buildPluggableMultiSelectionList: self! ! 270556AlignmentMorph subclass: #PluggablePanelMorph 270557 instanceVariableNames: 'model getChildrenSelector' 270558 classVariableNames: '' 270559 poolDictionaries: '' 270560 category: 'ToolBuilder-Morphic'! 270561!PluggablePanelMorph commentStamp: 'ar 2/11/2005 20:13' prior: 0! 270562A pluggable panel morph which deals with changing children.! 270563 270564 270565!PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:47'! 270566getChildrenSelector 270567 ^getChildrenSelector! ! 270568 270569!PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:47'! 270570getChildrenSelector: aSymbol 270571 getChildrenSelector := aSymbol.! ! 270572 270573!PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:48'! 270574model 270575 ^model! ! 270576 270577!PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:48'! 270578model: aModel 270579 model ifNotNil:[model removeDependent: self]. 270580 model := aModel. 270581 model ifNotNil:[model addDependent: self].! ! 270582 270583 270584!PluggablePanelMorph methodsFor: 'update' stamp: 'marcus.denker 9/14/2008 18:59'! 270585update: what 270586 what ifNil: [^self]. 270587 what == getChildrenSelector ifTrue:[ 270588 self removeAllMorphs. 270589 self addAllMorphs: (model perform: getChildrenSelector). 270590 self submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. 270591 ].! ! 270592PluggableCompositeSpec subclass: #PluggablePanelSpec 270593 instanceVariableNames: '' 270594 classVariableNames: '' 270595 poolDictionaries: '' 270596 category: 'ToolBuilder-Kernel'! 270597!PluggablePanelSpec commentStamp: 'ar 2/11/2005 15:01' prior: 0! 270598A panel with a (possibly changing) set of child elements. Expects to see change/update notifications when the childrens change.! 270599 270600 270601!PluggablePanelSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'! 270602buildWith: builder 270603 ^builder buildPluggablePanel: self.! ! 270604PluggableButtonSpec subclass: #PluggableRadioButtonSpec 270605 instanceVariableNames: '' 270606 classVariableNames: '' 270607 poolDictionaries: '' 270608 category: 'ToolBuilder-Kernel'! 270609!PluggableRadioButtonSpec commentStamp: 'ar 2/12/2005 23:14' prior: 0! 270610PluggableRadioButton is intended as a HINT for the builder that this widget will be used as radio button. Unless explicitly supported it will be automatically substituted by PluggableButton.! 270611 270612 270613!PluggableRadioButtonSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'! 270614buildWith: builder 270615 ^builder buildPluggableRadioButton: self! ! 270616Set subclass: #PluggableSet 270617 instanceVariableNames: 'hashBlock equalBlock' 270618 classVariableNames: '' 270619 poolDictionaries: '' 270620 category: 'Collections-Unordered'! 270621!PluggableSet commentStamp: '<historical>' prior: 0! 270622PluggableSets allow the redefinition of hashing and equality by clients. This is in particular useful if the clients know about specific properties of the objects stored in the set which in turn can heavily improve the performance of sets and dictionaries. 270623 270624Instance variables: 270625 hashBlock <BlockContext> A one argument block used for hashing the elements. 270626 equalBlock <BlockContext> A two argument block used for comparing the elements. 270627 270628Example: Adding 1000 integer points in the range (0@0) to: (100@100) to a set. 270629 270630 | rnd set max pt | 270631 set _ Set new: 1000. 270632 rnd _ Random new. 270633 max _ 100. 270634 Time millisecondsToRun:[ 270635 1 to: 1000 do:[:i| 270636 pt _ (rnd next * max) truncated @ (rnd next * max) truncated. 270637 set add: pt. 270638 ]. 270639 ]. 270640 270641The above is way slow since the default hashing function of points leads to an awful lot of collisions in the set. And now the same, with a somewhat different hash function: 270642 270643 | rnd set max pt | 270644 set _ PluggableSet new: 1000. 270645 set hashBlock:[:item| (item x bitShift: 16) + item y]. 270646 rnd _ Random new. 270647 max _ 100. 270648 Time millisecondsToRun:[ 270649 1 to: 1000 do:[:i| 270650 pt _ (rnd next * max) truncated @ (rnd next * max) truncated. 270651 set add: pt. 270652 ]. 270653 ]. 270654! 270655 270656 270657!PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:43'! 270658equalBlock 270659 "Return the block used for comparing the elements in the receiver." 270660 ^equalBlock! ! 270661 270662!PluggableSet methodsFor: 'accessing' stamp: 'ar 11/27/1998 23:55'! 270663equalBlock: aBlock 270664 "Set a new equality block. The block must accept two arguments and return true if the argumets are considered equal, false otherwise" 270665 equalBlock := aBlock.! ! 270666 270667!PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:43'! 270668hashBlock 270669 "Return the block used for hashing the elements in the receiver." 270670 ^hashBlock! ! 270671 270672!PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 19:02'! 270673hashBlock: aBlock 270674 "Set a new hash block. The block must accept one argument and return the hash value of the given argument." 270675 hashBlock := aBlock.! ! 270676 270677 270678!PluggableSet methodsFor: 'copying' stamp: 'nice 6/16/2009 20:55'! 270679copyEmpty 270680 ^super copyEmpty 270681 hashBlock: hashBlock copy; 270682 equalBlock: equalBlock copy! ! 270683 270684 270685!PluggableSet methodsFor: 'private' stamp: 'dvf 6/11/2000 00:54'! 270686scanFor: anObject 270687 "Scan the key array for the first slot containing either a nil 270688(indicating 270689 an empty slot) or an element that matches anObject. Answer the index 270690 270691 of that slot or zero if no slot is found. This method will be 270692overridden 270693 in various subclasses that have different interpretations for matching 270694 270695 elements." 270696 | element start finish | 270697 start := (hashBlock ifNil: [anObject hash] 270698 ifNotNil: [hashBlock value: anObject]) 270699 \\ array size + 1. 270700 finish := array size. 270701 "Search from (hash mod size) to the end." 270702 start to: finish do: [:index | ((element := array at: index) == nil or: 270703[equalBlock ifNil: [element = anObject] 270704 ifNotNil: [equalBlock value: element value: anObject]]) 270705 ifTrue: [^ index]]. 270706 "Search from 1 to where we started." 270707 1 to: start - 1 do: [:index | ((element := array at: index) == nil or: 270708[equalBlock ifNil: [element = anObject] 270709 ifNotNil: [equalBlock value: element value: anObject]]) 270710 ifTrue: [^ index]]. 270711 ^ 0"No match AND no empty slot"! ! 270712 270713"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 270714 270715PluggableSet class 270716 instanceVariableNames: ''! 270717 270718!PluggableSet class methodsFor: 'as yet unclassified' stamp: 'dvf 2707196/10/2000 18:13'! 270720integerSet 270721 ^self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! ! 270722SetTest subclass: #PluggableSetTest 270723 instanceVariableNames: '' 270724 classVariableNames: '' 270725 poolDictionaries: '' 270726 category: 'CollectionsTests-Unordered'! 270727 270728!PluggableSetTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 12:34'! 270729classToBeTested 270730 270731^ PluggableSet! ! 270732 270733"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 270734 270735PluggableSetTest class 270736 instanceVariableNames: ''! 270737 270738!PluggableSetTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 12:34'! 270739classToBeTested 270740 270741^ IdentitySet! ! 270742Slider subclass: #PluggableSliderMorph 270743 instanceVariableNames: 'getValueSelector getEnabledSelector enabled min max quantum' 270744 classVariableNames: '' 270745 poolDictionaries: '' 270746 category: 'Polymorph-Widgets'! 270747!PluggableSliderMorph commentStamp: 'gvc 7/16/2007 13:57' prior: 0! 270748A pluggable slider (rather than one that auto-generates access selectors). Needs to be themed...! 270749 270750 270751!PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/3/2007 15:19'! 270752enabled 270753 "Answer the value of enabled" 270754 270755 ^ enabled! ! 270756 270757!PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/3/2007 15:21'! 270758enabled: anObject 270759 "Set the value of enabled" 270760 270761 enabled = anObject ifTrue: [^self]. 270762 enabled := anObject. 270763 self changed: #enabled. 270764 self 270765 adoptPaneColor: self paneColor; 270766 changed! ! 270767 270768!PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2009 13:03'! 270769getEnabledSelector 270770 "Answer the value of getEnabledSelector" 270771 270772 ^ getEnabledSelector! ! 270773 270774!PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/10/2009 13:32'! 270775getEnabledSelector: aSymbol 270776 "Set the value of getEnabledSelector" 270777 270778 getEnabledSelector := aSymbol. 270779 self updateEnabled! ! 270780 270781!PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 10:43'! 270782max 270783 "Answer the value of max" 270784 270785 ^ max! ! 270786 270787!PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 11:21'! 270788max: anObject 270789 "Set the value of max" 270790 270791 max := anObject. 270792 self setValue: self value! ! 270793 270794!PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 10:43'! 270795min 270796 "Answer the value of min" 270797 270798 ^ min! ! 270799 270800!PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 11:21'! 270801min: anObject 270802 "Set the value of min" 270803 270804 min := anObject. 270805 self setValue: self value! ! 270806 270807!PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 11:14'! 270808quantum 270809 "Answer the value of quantum" 270810 270811 ^ quantum! ! 270812 270813!PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 11:20'! 270814quantum: anObject 270815 "Set the value of quantum" 270816 270817 quantum := anObject. 270818 self setValue: self value! ! 270819 270820 270821!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:58'! 270822adoptPaneColor: paneColor 270823 "Pass on to the border too." 270824 270825 super adoptPaneColor: paneColor. 270826 paneColor ifNil: [^self]. 270827 self 270828 fillStyle: self fillStyleToUse; 270829 borderStyle: self borderStyleToUse; 270830 sliderColor: (self enabled 270831 ifTrue: [paneColor twiceDarker] 270832 ifFalse: [self paneColor twiceDarker paler])! ! 270833 270834!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/3/2007 15:25'! 270835borderStyleToUse 270836 "Answer the borderStyle that should be used for the receiver." 270837 270838 ^self enabled 270839 ifTrue: [self theme sliderNormalBorderStyleFor: self] 270840 ifFalse: [self theme sliderDisabledBorderStyleFor: self]! ! 270841 270842!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/20/2007 15:02'! 270843defaultColor 270844 "Answer the default color/fill style for the receiver." 270845 270846 ^Color white! ! 270847 270848!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/3/2007 15:19'! 270849disable 270850 "Disable the receiver." 270851 270852 self enabled: false! ! 270853 270854!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/3/2007 15:19'! 270855enable 270856 "Enable the receiver." 270857 270858 self enabled: true! ! 270859 270860!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/3/2007 15:24'! 270861fillStyleToUse 270862 "Answer the fillStyle that should be used for the receiver." 270863 270864 ^self enabled 270865 ifTrue: [self theme sliderNormalFillStyleFor: self] 270866 ifFalse: [self theme sliderDisabledFillStyleFor: self]! ! 270867 270868!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/20/2007 14:31'! 270869getValueSelector 270870 "Answer the value of getValueSelector" 270871 270872 ^ getValueSelector! ! 270873 270874!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/20/2007 14:31'! 270875getValueSelector: anObject 270876 "Set the value of getValueSelector" 270877 270878 getValueSelector := anObject! ! 270879 270880!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/20/2007 14:27'! 270881handlesMouseDown: evt 270882 "Answer true." 270883 270884 ^true! ! 270885 270886!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 13:14'! 270887initialize 270888 "Initialize the receiver." 270889 270890 min := 0. 270891 max := 1. 270892 super initialize. 270893 self enabled: true! ! 270894 270895!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/20/2007 15:00'! 270896initializeSlider 270897 "Make the slider raised." 270898 270899 super initializeSlider. 270900 slider borderStyle: (BorderStyle raised baseColor: slider color; width: 1)! ! 270901 270902!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/3/2007 15:14'! 270903layoutBounds: aRectangle 270904 "Set the bounds for laying out children of the receiver. 270905 Note: written so that #layoutBounds can be changed without touching this method" 270906 270907 super layoutBounds: aRectangle. 270908 self computeSlider! ! 270909 270910!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 15:32'! 270911minHeight 270912 "Answer the receiver's minimum height. 270913 Give it a bit of a chance..." 270914 270915 ^8 max: super minHeight! ! 270916 270917!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 10:35'! 270918mouseDown: anEvent 270919 "Set the value directly." 270920 270921 self enabled ifTrue: [ 270922 self 270923 scrollPoint: anEvent; 270924 computeSlider]. 270925 super mouseDown: anEvent. 270926 self enabled ifFalse: [^self]. 270927 anEvent hand newMouseFocus: slider event: anEvent. 270928 slider 270929 mouseEnter: anEvent copy; 270930 mouseDown: anEvent copy 270931! ! 270932 270933!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 10:36'! 270934mouseDownInSlider: event 270935 "Ignore if disabled." 270936 270937 self enabled ifFalse: [^self]. 270938 ^super mouseDownInSlider: event! ! 270939 270940!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/20/2007 14:29'! 270941on: anObject getValue: getSel setValue: setSel 270942 "Use the given selectors as the interface." 270943 270944 self 270945 model: anObject; 270946 getValueSelector: getSel; 270947 setValueSelector: setSel; 270948 updateValue! ! 270949 270950!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:16'! 270951scaledValue 270952 "Answer the scaled value." 270953 270954 |val| 270955 val := self value * (self max - self min) + self min. 270956 self quantum ifNotNilDo: [:q | 270957 val := val roundTo: q]. 270958 ^(val max: self min) min: self max! ! 270959 270960!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 14:17'! 270961scaledValue: newValue 270962 "Set the scaled value." 270963 270964 |val| 270965 val := newValue. 270966 self quantum ifNotNilDo: [:q | 270967 val := val roundTo: q]. 270968 self value: newValue - self min / (self max - self min)! ! 270969 270970!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 10:37'! 270971scrollAbsolute: event 270972 "Ignore if disabled." 270973 270974 self enabled ifFalse: [^self]. 270975 ^super scrollAbsolute: event! ! 270976 270977!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/20/2007 14:28'! 270978scrollPoint: event 270979 "Scroll to the event position." 270980 270981 | r p | 270982 r := self roomToMove. 270983 bounds isWide 270984 ifTrue: [r width = 0 ifTrue: [^ self]] 270985 ifFalse: [r height = 0 ifTrue: [^ self]]. 270986 p := event position - (self sliderThickness // 2) adhereTo: r. 270987 self descending 270988 ifFalse: 270989 [self setValue: (bounds isWide 270990 ifTrue: [(p x - r left) asFloat / r width] 270991 ifFalse: [(p y - r top) asFloat / r height])] 270992 ifTrue: 270993 [self setValue: (bounds isWide 270994 ifTrue: [(r right - p x) asFloat / r width] 270995 ifFalse: [(r bottom - p y) asFloat / r height])]! ! 270996 270997!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:00'! 270998setValue: newValue 270999 "Called internally for propagation to model." 271000 271001 |scaled| 271002 value := newValue. 271003 self scaledValue: (scaled := self scaledValue). 271004 self model ifNotNil: [ 271005 self setValueSelector ifNotNilDo: [:sel | 271006 self model perform: sel with: scaled]]! ! 271007 271008!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:18'! 271009setValueSelector 271010 "Answer the set selector." 271011 271012 ^setValueSelector! ! 271013 271014!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/20/2007 14:31'! 271015setValueSelector: aSymbol 271016 "Directly set the selector to make more flexible." 271017 271018 setValueSelector := aSymbol! ! 271019 271020!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/20/2007 14:57'! 271021sliderColor: newColor 271022 "Set the slider colour." 271023 271024 super sliderColor: newColor. 271025 slider ifNotNil: [slider borderStyle baseColor: newColor]! ! 271026 271027!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:05'! 271028update: aSymbol 271029 "Update the value." 271030 271031 super update: aSymbol. 271032 aSymbol == self getEnabledSelector ifTrue: [ 271033 ^self updateEnabled]. 271034 aSymbol = self getValueSelector ifTrue: [ 271035 ^self updateValue]! ! 271036 271037!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:06'! 271038updateEnabled 271039 "Update the enablement state." 271040 271041 self model ifNotNil: [ 271042 self getEnabledSelector ifNotNil: [ 271043 self enabled: (self model perform: self getEnabledSelector)]]! ! 271044 271045!PluggableSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:00'! 271046updateValue 271047 "Update the value." 271048 271049 self model ifNotNil: [ 271050 self getValueSelector ifNotNil: [ 271051 self scaledValue: (self model perform: self getValueSelector)]]! ! 271052 271053"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 271054 271055PluggableSliderMorph class 271056 instanceVariableNames: ''! 271057 271058!PluggableSliderMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:28'! 271059on: anObject getValue: getSel setValue: setSel 271060 "Answer a new instance of the receiver with 271061 the given selectors as the interface." 271062 271063 ^self new 271064 on: anObject 271065 getValue: getSel 271066 setValue: setSel! ! 271067 271068!PluggableSliderMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:27'! 271069on: anObject getValue: getSel setValue: setSel min: min max: max quantum: quantum 271070 "Answer a new instance of the receiver with 271071 the given selectors as the interface." 271072 271073 ^self new 271074 min: min; 271075 max: max; 271076 quantum: quantum; 271077 on: anObject 271078 getValue: getSel 271079 setValue: setSel! ! 271080StandardWindow subclass: #PluggableStandardWindow 271081 instanceVariableNames: 'getLabelSelector getChildrenSelector children closeWindowSelector' 271082 classVariableNames: '' 271083 poolDictionaries: '' 271084 category: 'Polymorph-ToolBuilder-Morphic'! 271085 271086!PluggableStandardWindow methodsFor: 'accessing' stamp: 'gvc 1/9/2007 13:31'! 271087addPaneMorph: aMorph 271088 self addMorph: aMorph fullFrame: aMorph layoutFrame! ! 271089 271090!PluggableStandardWindow methodsFor: 'accessing' stamp: 'gvc 1/9/2007 13:31'! 271091closeWindowSelector 271092 ^closeWindowSelector! ! 271093 271094!PluggableStandardWindow methodsFor: 'accessing' stamp: 'gvc 1/9/2007 13:31'! 271095closeWindowSelector: aSymbol 271096 closeWindowSelector := aSymbol! ! 271097 271098!PluggableStandardWindow methodsFor: 'accessing' stamp: 'gvc 1/9/2007 13:31'! 271099getChildrenSelector 271100 ^getChildrenSelector! ! 271101 271102!PluggableStandardWindow methodsFor: 'accessing' stamp: 'gvc 1/9/2007 13:31'! 271103getChildrenSelector: aSymbol 271104 getChildrenSelector := aSymbol! ! 271105 271106!PluggableStandardWindow methodsFor: 'accessing' stamp: 'gvc 1/9/2007 13:31'! 271107getLabelSelector 271108 ^getLabelSelector! ! 271109 271110!PluggableStandardWindow methodsFor: 'accessing' stamp: 'gvc 1/9/2007 13:31'! 271111getLabelSelector: aSymbol 271112 getLabelSelector := aSymbol. 271113 self update: aSymbol.! ! 271114 271115!PluggableStandardWindow methodsFor: 'accessing' stamp: 'gvc 1/9/2007 13:31'! 271116label 271117 ^label contents! ! 271118 271119!PluggableStandardWindow methodsFor: 'accessing' stamp: 'gvc 1/9/2007 13:31'! 271120label: aString 271121 self setLabel: aString.! ! 271122 271123 271124!PluggableStandardWindow methodsFor: 'initialization' stamp: 'gvc 7/30/2009 13:41'! 271125delete 271126 "Should be this way around since the window may not close 271127 for other reasons!!" 271128 271129 |m| 271130 m := model. 271131 super delete. 271132 closeWindowSelector ifNotNil:[m perform: closeWindowSelector]! ! 271133 271134 271135!PluggableStandardWindow methodsFor: 'updating' stamp: 'gvc 1/9/2007 13:31'! 271136update: what 271137 what ifNil:[^self]. 271138 what == getLabelSelector ifTrue:[self setLabel: (model perform: getLabelSelector)]. 271139 what == getChildrenSelector ifTrue:[ 271140 children ifNil:[children := #()]. 271141 self removeAllMorphsIn: children. 271142 children := model perform: getChildrenSelector. 271143 self addAllMorphs: children. 271144 children do:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. 271145 ]. 271146 ^super update: what! ! 271147SystemWindow subclass: #PluggableSystemWindow 271148 instanceVariableNames: 'getLabelSelector getChildrenSelector children closeWindowSelector' 271149 classVariableNames: '' 271150 poolDictionaries: '' 271151 category: 'ToolBuilder-Morphic'! 271152!PluggableSystemWindow commentStamp: 'ar 2/11/2005 20:14' prior: 0! 271153A pluggable system window. Fixes the issues with label retrieval and adds support for changing children.! 271154 271155 271156!PluggableSystemWindow methodsFor: 'accessing' stamp: 'md 8/31/2005 07:59'! 271157addPaneMorph: aMorph 271158 self addMorph: aMorph fullFrame: aMorph layoutFrame! ! 271159 271160!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 9/17/2005 21:05'! 271161closeWindowSelector 271162 ^closeWindowSelector! ! 271163 271164!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 9/17/2005 21:05'! 271165closeWindowSelector: aSymbol 271166 closeWindowSelector := aSymbol! ! 271167 271168!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:57'! 271169getChildrenSelector 271170 ^getChildrenSelector! ! 271171 271172!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:57'! 271173getChildrenSelector: aSymbol 271174 getChildrenSelector := aSymbol! ! 271175 271176!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:57'! 271177getLabelSelector 271178 ^getLabelSelector! ! 271179 271180!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/13/2005 13:53'! 271181getLabelSelector: aSymbol 271182 getLabelSelector := aSymbol. 271183 self update: aSymbol.! ! 271184 271185!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/13/2005 13:52'! 271186label 271187 ^label contents! ! 271188 271189!PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/13/2005 13:51'! 271190label: aString 271191 self setLabel: aString.! ! 271192 271193 271194!PluggableSystemWindow methodsFor: 'initialization' stamp: 'ar 9/17/2005 21:08'! 271195delete 271196 closeWindowSelector ifNotNil:[model perform: closeWindowSelector]. 271197 super delete. 271198! ! 271199 271200 271201!PluggableSystemWindow methodsFor: 'updating' stamp: 'ar 2/11/2005 20:15'! 271202update: what 271203 what ifNil:[^self]. 271204 what == getLabelSelector ifTrue:[self setLabel: (model perform: getLabelSelector)]. 271205 what == getChildrenSelector ifTrue:[ 271206 children ifNil:[children := #()]. 271207 self removeAllMorphsIn: children. 271208 children := model perform: getChildrenSelector. 271209 self addAllMorphs: children. 271210 children do:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. 271211 ]. 271212 ^super update: what! ! 271213Morph subclass: #PluggableTabBarMorph 271214 instanceVariableNames: 'target tabs activeTab' 271215 classVariableNames: '' 271216 poolDictionaries: '' 271217 category: 'Morphic-Pluggable Widgets'! 271218!PluggableTabBarMorph commentStamp: 'KLC 9/17/2004 11:26' prior: 0! 271219This morph manages a set of PluggableTabButtonMorphs. Each tab should be added in the left to right order that they should be displayed. Each tab will be evenly sized to fit the available space. This morph intercepts mouse clicks, figures out which tab was clicked, pops up the new tab as the active tab and triggers the registered event. See PluggableTabButtonMorph for information on what a tab can consist of. 271220 271221Example: 271222 271223(PluggableTabBarMorph on: nil) 271224 addTab: (Text fromString: 'Test') withAction: [Transcript show: 'Test'; cr]; 271225 addTab: (Text fromString: 'Another') withAction: [Transcript show: 'Another'; cr]; 271226 width: 200; 271227 openInHand 271228! 271229 271230 271231!PluggableTabBarMorph methodsFor: 'access' stamp: 'KLC 2/24/2004 15:26'! 271232addTab: aStringOrTextOrMorph withAction: aSymbolOrBlock 271233 "Add a new tab. The tab will be added onto the end of the list and displayed on the far right of previously added tabs. The first argument can be a simple String, a Text, or any Morph. The second argument is the action to be performed when the tab is selected. It can either be a symbol for a unary method on the target object or a block. Each tab is stored as an Association with the created tab as the key and the selector as the value." 271234 | tabMorph | 271235 tabMorph := PluggableTabButtonMorph on: nil label: [ aStringOrTextOrMorph]. 271236 tabMorph color: self color. 271237 self addMorphBack: tabMorph. 271238 self tabs ifEmpty: [ self activeTab: tabMorph ]. 271239 self tabs add: (Association key: tabMorph value: aSymbolOrBlock). 271240 self layoutChanged. 271241 self changed.! ! 271242 271243!PluggableTabBarMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 17:36'! 271244color: aFillStyle 271245 color := aFillStyle. 271246 self tabs do: [ :anAssociation | 271247 anAssociation key color: aFillStyle ] 271248! ! 271249 271250!PluggableTabBarMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 10:37'! 271251target: anObject 271252 target := anObject! ! 271253 271254 271255!PluggableTabBarMorph methodsFor: 'actions' stamp: 'KLC 2/2/2004 16:22'! 271256handlesMouseDown: anEvent 271257 ^ true! ! 271258 271259!PluggableTabBarMorph methodsFor: 'actions' stamp: 'KLC 2/2/2004 17:49'! 271260layoutChanged 271261 "Fix up our tabs bounds" 271262 | tabsCount | 271263 super layoutChanged. 271264 tabsCount := self tabs size. 271265 tabsCount isZero ifFalse: [ | tabInnerExtent count | 271266 tabInnerExtent := ((self width - 271267 ((self tabs first key outerGap + self tabs last key outerGap) // 2) 271268 - tabsCount) 271269 // tabsCount) 271270 @ (self height). 271271 count := 1. 271272 self tabs do: [ :anAssociation | | tab | 271273 tab := anAssociation key. 271274 tab innerExtent: tabInnerExtent. 271275 count = 1 271276 ifTrue: [tab position: self position] 271277 ifFalse: [ 271278 tab position: 271279 (self position translateBy: 271280 ((tabInnerExtent x + 1) * (count - 1))@0)]. 271281 count := count + 1 ] ]. 271282 self changed.! ! 271283 271284!PluggableTabBarMorph methodsFor: 'actions' stamp: 'KLC 2/24/2004 15:14'! 271285mouseDown: anEvent 271286 | xPosition newTab | 271287 xPosition := anEvent cursorPoint x. 271288 newTab := 271289 ((self tabs detect: [ :anAssociation | | tabBounds | 271290 tabBounds := anAssociation key bounds. 271291 (tabBounds left <= xPosition) and: [ tabBounds right >= xPosition]] 271292 ifNone: [nil]) 271293 key). 271294 newTab ifNil: [^ self]. 271295 newTab = activeTab ifFalse: [ self activeTab: newTab ] 271296! ! 271297 271298!PluggableTabBarMorph methodsFor: 'actions' stamp: 'tlk 7/17/2004 14:35'! 271299performActiveTabAction 271300 "Look up the Symbol or Block associated with the currently active tab, and perform it." 271301 271302 | tabActionAssoc aSymbolOrBlock | 271303 271304 tabActionAssoc := self tabs detect: [ :assoc | assoc key = self activeTab.] ifNone: [ Association new ]. 271305 aSymbolOrBlock := tabActionAssoc value. 271306 aSymbolOrBlock ifNil: [ ^ false ]. 271307 ^ aSymbolOrBlock isSymbol 271308 ifTrue: [ self target perform: aSymbolOrBlock ] 271309 ifFalse: [ aSymbolOrBlock value ]. 271310 ! ! 271311 271312 271313!PluggableTabBarMorph methodsFor: 'drawing' stamp: 'KLC 2/24/2004 15:10'! 271314drawOn: aCanvas 271315 self tabs size > 0 ifFalse: [^ self ]. 271316 self tabs do: [ :anAssociation | | tab | 271317 tab := anAssociation key. 271318 tab drawOn: aCanvas]! ! 271319 271320 271321!PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/2/2004 14:17'! 271322activeTab 271323 activeTab ifNil: [ 271324 self tabs size > 0 ifTrue: [ 271325 activeTab := self tabs first key. 271326 activeTab active: true]]. 271327 ^ activeTab ! ! 271328 271329!PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/24/2004 15:27'! 271330activeTab: aTabMorph 271331 self activeTab ifNotNil: [self activeTab toggle]. 271332 activeTab := aTabMorph. 271333 self activeTab toggle. 271334 aTabMorph delete. 271335 self addMorphFront: aTabMorph. 271336 self performActiveTabAction. 271337 self changed. 271338! ! 271339 271340!PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/2/2004 13:25'! 271341tabs 271342 tabs ifNil: [ tabs := OrderedCollection new ]. 271343 ^ tabs! ! 271344 271345!PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/2/2004 10:37'! 271346target 271347 ^ target! ! 271348 271349"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 271350 271351PluggableTabBarMorph class 271352 instanceVariableNames: ''! 271353 271354!PluggableTabBarMorph class methodsFor: 'instance creation' stamp: 'KLC 2/2/2004 10:38'! 271355on: anObject 271356 ^ super new target: anObject! ! 271357Morph subclass: #PluggableTabButtonMorph 271358 instanceVariableNames: 'active model textSelector arcLengths subMorph' 271359 classVariableNames: '' 271360 poolDictionaries: '' 271361 category: 'Morphic-Pluggable Widgets'! 271362!PluggableTabButtonMorph commentStamp: 'KLC 9/17/2004 11:27' prior: 0! 271363This is a specialized pluggable button morph that is meant to represent a tab in a set of tabs arranged horizontally. Each tab will overlap slightly when drawn. All but one tab will be drawn in left to right order in the specified color, but lighter. The active tab will be drawn last in the full color and slightly taller to indicate that it is selected. Clicking the active tab has no effect but clicking any other tab will change the active tab to the clicked tab. 271364 271365This morph does not itself accept any events. The parent tab set will grab the mouse clicks and handle notifying the appropriate tabs that they have been activated or deactivated. 271366 271367There is a single selector which provides the text for the button label and affects the width of the tab. When the width changes the tab will inform its parent that it has changed and that the layout needs to be updated. The model for the text selector of course should be the client for the tab set. 271368 271369The button label can be a String, Text, or Morph. Texts work better than plain Strings.! 271370 271371 271372!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:25'! 271373active 271374 active ifNil: [ active := false ]. 271375 ^ active! ! 271376 271377!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:26'! 271378active: aBoolean 271379 active := aBoolean. 271380 self changed.! ! 271381 271382!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 14:05'! 271383innerExtent: aPoint 271384 "Set the extent based on the primary visible part of the tab. In other words add twice the cornerRadius to this extent" 271385 self extent: (aPoint x + (self cornerRadius * 2)) @ (aPoint y)! ! 271386 271387!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! 271388model 271389 ^ model 271390! ! 271391 271392!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! 271393model: anObject 271394 model := anObject! ! 271395 271396!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 14:07'! 271397outerGap 271398 "The horizontal distance of the outer left and right edges of the tab excluding the inner visible part" 271399 ^ self cornerRadius * 2! ! 271400 271401!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! 271402textSelector 271403 ^ textSelector 271404! ! 271405 271406!PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! 271407textSelector: aSymbol 271408 textSelector := aSymbol! ! 271409 271410 271411!PluggableTabButtonMorph methodsFor: 'actions' stamp: 'KLC 1/23/2004 15:38'! 271412toggle 271413 self active: self active not! ! 271414 271415 271416!PluggableTabButtonMorph methodsFor: 'drawing' stamp: 'KLC 1/23/2004 15:49'! 271417drawOn: aCanvas 271418 self drawTabOn: aCanvas. 271419 self drawSubMorphOn: aCanvas! ! 271420 271421!PluggableTabButtonMorph methodsFor: 'drawing' stamp: 'KLC 9/17/2004 11:24'! 271422drawSubMorphOn: aCanvas 271423 | morphBounds | 271424 morphBounds := self bounds insetBy: (self cornerRadius + 3) @ (self topInactiveGap // 2 + 2). 271425 morphBounds := morphBounds translateBy: 0@(self topInactiveGap // 2 + 1). 271426 self active ifTrue: [ 271427 morphBounds := morphBounds translateBy: 0@((self topInactiveGap // 2 + 1) negated)]. 271428 self subMorph bounds height < (morphBounds height) 271429 ifTrue: [ 271430 morphBounds := morphBounds 271431 insetBy: 0@((morphBounds height - self subMorph bounds height) // 2)]. 271432 self subMorph bounds width < (morphBounds width) 271433 ifTrue: [ 271434 morphBounds := morphBounds 271435 insetBy: ((morphBounds width - self subMorph bounds width) // 2)@0]. 271436 271437 self subMorph bounds: morphBounds. 271438 aCanvas drawMorph: self subMorph! ! 271439 271440!PluggableTabButtonMorph methodsFor: 'drawing' stamp: 'KLC 2/2/2004 15:07'! 271441drawTabOn: aCanvas 271442 | top myColor cornerRadius myArcLengths myBounds | 271443 cornerRadius := self cornerRadius. 271444 myBounds := self bounds. 271445 self active 271446 ifTrue: [ top := myBounds top. 271447 myColor := self color ] 271448 ifFalse: [ top := myBounds top + self topInactiveGap. 271449 myColor := self color whiter whiter ]. 271450 aCanvas fillRectangle: 271451 ((myBounds left + cornerRadius) 271452 @ (top + cornerRadius) 271453 corner: (myBounds right - cornerRadius) 271454 @ self bottom) 271455 color: myColor. 271456 aCanvas fillRectangle: 271457 ((myBounds left + (cornerRadius * 2)) @ top 271458 corner: (myBounds right - (cornerRadius * 2)) 271459 @ (top + cornerRadius)) 271460 color: myColor. 271461 aCanvas fillOval: 271462 ((myBounds left + self cornerRadius) @ top 271463 corner: (myBounds left + (self cornerRadius * 3)) 271464 @ (top + (self cornerRadius * 2))) 271465 color: myColor. 271466 aCanvas fillOval: 271467 ((myBounds right - (self cornerRadius * 3)) @ top 271468 corner: (myBounds right - self cornerRadius) 271469 @ (top + (self cornerRadius * 2))) 271470 color: myColor. 271471 271472 myArcLengths := self arcLengths. 271473 1 to: myArcLengths size do: [ :i | | length | 271474 length := myArcLengths at: i. 271475 aCanvas line: (myBounds left + cornerRadius - i) @ (myBounds bottom - 1 ) 271476 to: (myBounds left + cornerRadius - i) @ (myBounds bottom - length - 1) 271477 color: myColor. 271478 aCanvas line: (myBounds right - cornerRadius + i - 1) @ (myBounds bottom - 1) 271479 to: (myBounds right - cornerRadius + i - 1) @ (myBounds bottom - length - 1) 271480 color: myColor] 271481 271482! ! 271483 271484 271485!PluggableTabButtonMorph methodsFor: 'precalculations' stamp: 'KLC 1/23/2004 14:46'! 271486calculateArcLengths 271487 | array radius | 271488 radius := self cornerRadius. 271489 array := Array new: radius. 271490 271491 1 to: radius do: [ :i | | x | 271492 x := i - 0.5. 271493 array at: i 271494 put: (radius - ((2 * x * radius) - (x * x)) sqrt) asInteger]. 271495 271496 self arcLengths: array! ! 271497 271498 271499!PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 2/2/2004 10:15'! 271500step 271501 self subMorph step. 271502 self changed. 271503! ! 271504 271505!PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 1/23/2004 17:31'! 271506stepTime 271507 ^ self subMorph stepTime 271508! ! 271509 271510!PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 1/23/2004 17:31'! 271511wantsSteps 271512 ^ self subMorph wantsSteps! ! 271513 271514 271515!PluggableTabButtonMorph methodsFor: 'updating' stamp: 'KLC 1/23/2004 17:02'! 271516update: aSelector 271517 self textSelector ifNotNil: [ 271518 aSelector = self textSelector 271519 ifTrue: [ | morph | 271520 (aSelector isSymbol and: [model notNil]) 271521 ifTrue: [ 271522 morph := 271523 (self model perform: aSelector) asMorph] 271524 ifFalse: [ morph := aSelector value asMorph]. 271525 self subMorph: morph]]. 271526 self changed! ! 271527 271528 271529!PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 14:36'! 271530arcLengths 271531 arcLengths ifNil: [ self calculateArcLengths ]. 271532 ^ arcLengths! ! 271533 271534!PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 14:37'! 271535arcLengths: anArrayOfIntegers 271536 arcLengths := anArrayOfIntegers 271537! ! 271538 271539!PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 11:30'! 271540cornerRadius 271541 ^ 5 271542! ! 271543 271544!PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 16:40'! 271545subMorph 271546 subMorph ifNil: [ self update: self textSelector ]. 271547 ^ subMorph! ! 271548 271549!PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 16:40'! 271550subMorph: aMorph 271551 subMorph := aMorph 271552! ! 271553 271554!PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 11:30'! 271555topInactiveGap 271556 ^ 5! ! 271557 271558"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 271559 271560PluggableTabButtonMorph class 271561 instanceVariableNames: ''! 271562 271563!PluggableTabButtonMorph class methodsFor: 'instance creation' stamp: 'KLC 1/22/2004 14:46'! 271564on: anObject label: getTextSelector 271565 | instance | 271566 instance := super new. 271567 instance model: anObject. 271568 instance textSelector: getTextSelector. 271569 ^ instance ! ! 271570TextAction subclass: #PluggableTextAttribute 271571 instanceVariableNames: 'evalBlock' 271572 classVariableNames: '' 271573 poolDictionaries: '' 271574 category: 'Collections-Text'! 271575!PluggableTextAttribute commentStamp: '<historical>' prior: 0! 271576An attribute which evaluates an arbitrary block when it is selected.! 271577 271578 271579!PluggableTextAttribute methodsFor: 'clicking' stamp: 'ls 6/21/2001 18:13'! 271580actOnClickFor: anObject 271581 evalBlock ifNil: [ ^self ]. 271582 evalBlock numArgs = 0 ifTrue: [ evalBlock value. ^true ]. 271583 evalBlock numArgs = 1 ifTrue: [ evalBlock value: anObject. ^true ]. 271584 self error: 'evalBlock should have 0 or 1 arguments'! ! 271585 271586 271587!PluggableTextAttribute methodsFor: 'initialization' stamp: 'ls 6/21/2001 18:06'! 271588evalBlock: aBlock 271589 evalBlock := aBlock! ! 271590 271591"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 271592 271593PluggableTextAttribute class 271594 instanceVariableNames: ''! 271595 271596!PluggableTextAttribute class methodsFor: 'instance creation' stamp: 'ls 6/21/2001 18:09'! 271597evalBlock: aBlock 271598 ^super new evalBlock: aBlock! ! 271599PluggableTextMorph subclass: #PluggableTextEditorMorph 271600 uses: TEnableOnHaloMenu 271601 instanceVariableNames: 'enabled getEnabledSelector highlights' 271602 classVariableNames: '' 271603 poolDictionaries: '' 271604 category: 'Polymorph-Widgets'! 271605!PluggableTextEditorMorph commentStamp: 'gvc 5/18/2007 12:29' prior: 0! 271606Multi-line text editor with support for accepting on both each change and/or when keyboard focus changes. Also supports custom selection colour and clickable highlights.! 271607 271608 271609!PluggableTextEditorMorph methodsFor: 'accessing' stamp: 'gvc 4/30/2007 11:44'! 271610enabled 271611 "Answer whether the receiver is enabled." 271612 271613 ^enabled! ! 271614 271615!PluggableTextEditorMorph methodsFor: 'accessing' stamp: 'gvc 4/30/2007 11:49'! 271616enabled: aBoolean 271617 "Set the value of enabled" 271618 271619 enabled = aBoolean ifTrue: [^self]. 271620 enabled := aBoolean. 271621 self changed: #enabled. 271622 self 271623 adoptPaneColor: self paneColor; 271624 changed! ! 271625 271626!PluggableTextEditorMorph methodsFor: 'accessing' stamp: 'gvc 9/5/2006 14:40'! 271627getEnabledSelector 271628 "Answer the value of getEnabledSelector" 271629 271630 ^ getEnabledSelector! ! 271631 271632!PluggableTextEditorMorph methodsFor: 'accessing' stamp: 'gvc 4/30/2007 15:01'! 271633getEnabledSelector: anObject 271634 "Set the value of getEnabledSelector" 271635 271636 getEnabledSelector := anObject. 271637 self updateEnabled! ! 271638 271639!PluggableTextEditorMorph methodsFor: 'accessing' stamp: 'gvc 10/25/2006 12:51'! 271640highlights 271641 "Answer the value of highlights" 271642 271643 ^ highlights! ! 271644 271645!PluggableTextEditorMorph methodsFor: 'accessing' stamp: 'gvc 10/25/2006 12:51'! 271646highlights: anObject 271647 "Set the value of highlights" 271648 271649 highlights := anObject! ! 271650 271651 271652!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:06'! 271653acceptOnFocusChange 271654 "Answer whether the editor accepts its contents when it loses the keyboard focus." 271655 271656 ^self valueOfProperty: #acceptOnFocusChange ifAbsent: [false]! ! 271657 271658!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:06'! 271659acceptOnFocusChange: aBoolean 271660 "Set whether the editor accepts its contents when it loses the keyboard focus." 271661 271662 self setProperty: #acceptOnFocusChange toValue: aBoolean. 271663 self textMorph ifNotNilDo: [:t | t acceptOnFocusChange: aBoolean]! ! 271664 271665!PluggableTextEditorMorph methodsFor: 'as yet unclassified'! 271666addToggleItemsToHaloMenu: aCustomMenu 271667 "Add toggle-items to the halo menu" 271668 271669 super addToggleItemsToHaloMenu: aCustomMenu. 271670 aCustomMenu 271671 addUpdating: #enabledString 271672 target: self 271673 action: #toggleEnabled! ! 271674 271675!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/8/2007 10:27'! 271676adoptPaneColor: paneColor 271677 "Use the theme for fillStyle and border." 271678 271679 super adoptPaneColor: paneColor. 271680 paneColor ifNil: [^self]. 271681 self fillStyle: self fillStyleToUse. 271682 self borderWidth > 0 ifTrue: [ 271683 self borderStyle: self borderStyleToUse]! ! 271684 271685!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 15:23'! 271686alwaysAccept: aBoolean 271687 "Set the always accept flag." 271688 271689 aBoolean 271690 ifTrue: [self setProperty: #alwaysAccept toValue: true] 271691 ifFalse: [self removeProperty: #alwaysAccept]! ! 271692 271693!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/5/2006 14:27'! 271694autoAccept 271695 "Answer whether the editor accepts its contents on each change." 271696 271697 ^self valueOfProperty: #autoAccept ifAbsent: [false]! ! 271698 271699!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/9/2006 14:07'! 271700autoAccept: aBoolean 271701 "Set whether the editor accepts its contents on each change. 271702 Only takes effect after the text is set." 271703 271704 self setProperty: #autoAccept toValue: aBoolean. 271705 self textMorph ifNotNilDo: [:t | t autoAccept: aBoolean]! ! 271706 271707!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 13:09'! 271708borderStyleToUse 271709 "Answer the borderStyle that should be used for the receiver." 271710 271711 ^self enabled 271712 ifTrue: [self theme textEditorNormalBorderStyleFor: self] 271713 ifFalse: [self theme textEditorDisabledBorderStyleFor: self]! ! 271714 271715!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 14:17'! 271716disable 271717 "Disable the receiver." 271718 271719 self enabled: false! ! 271720 271721!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 16:28'! 271722drawHighlightsOn: aCanvas 271723 "Draw the highlights." 271724 271725 |b o| 271726 b := self innerBounds. 271727 o := self scroller offset. 271728 aCanvas clipBy: self clippingBounds during: [:c | 271729 self highlights do: [:h | 271730 h 271731 drawOn: c 271732 in: b 271733 offset: o]]! ! 271734 271735!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:48'! 271736drawOn: aCanvas 271737 "Draw the highlights." 271738 271739 super drawOn: aCanvas. 271740 self drawHighlightsOn: aCanvas! ! 271741 271742!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 14:16'! 271743enable 271744 "Enable the receiver." 271745 271746 self enabled: true! ! 271747 271748!PluggableTextEditorMorph methodsFor: 'as yet unclassified'! 271749enabledString 271750 "Answer the string to be shown in a menu to represent the 271751 'enabled' status" 271752 271753 ^ (self enabled 271754 ifTrue: ['<on>'] 271755 ifFalse: ['<off>']), 'enabled' translated! ! 271756 271757!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 10:40'! 271758extent: newExtent 271759 "Update the gradient." 271760 271761 super extent: newExtent. 271762 (self fillStyle notNil and: [self fillStyle isSolidFill not]) 271763 ifTrue: [self fillStyle: self fillStyleToUse]! ! 271764 271765!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 13:04'! 271766fillStyleToUse 271767 "Answer the fillStyle that should be used for the receiver." 271768 271769 ^self enabled 271770 ifTrue: [self theme textEditorNormalFillStyleFor: self] 271771 ifFalse: [self theme textEditorDisabledFillStyleFor: self]! ! 271772 271773!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/23/2006 15:02'! 271774hScrollBarValue: scrollValue 271775 "Trigger an event too." 271776 271777 super hScrollBarValue: scrollValue. 271778 self triggerEvent: #hScroll with: scrollValue! ! 271779 271780!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 12:53'! 271781initialize 271782 "Initialize the receiver." 271783 271784 super initialize. 271785 enabled := true. 271786 highlights := OrderedCollection new! ! 271787 271788!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/30/2007 15:01'! 271789model: aModel 271790 "Update the enablement state too." 271791 271792 super model: aModel. 271793 self updateEnabled! ! 271794 271795!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 17:07'! 271796scrollBy: delta 271797 "Move the contents in the direction delta." 271798 271799 super scrollBy: delta. 271800 self triggerEvent: #hScroll with: self scrollValue x. 271801 self triggerEvent: #vScroll with: self scrollValue y 271802 ! ! 271803 271804!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/4/2007 10:31'! 271805scrollToTop 271806 "Scroll to the top." 271807 271808 self 271809 vScrollBarValue: 0; 271810 setScrollDeltas! ! 271811 271812!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:48'! 271813selectAll 271814 "Tell my textMorph's editor to select all" 271815 271816 self textMorph editor selectAll. 271817 selectionInterval := self textMorph editor selectionInterval! ! 271818 271819!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:52'! 271820selectFrom: start to: stop 271821 "Tell my textMorph's editor to select the given range." 271822 271823 self textMorph editor selectFrom: start to: stop. 271824 ^selectionInterval := self textMorph editor selectionInterval! ! 271825 271826!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 16:15'! 271827selectionColor 271828 "Answer the colour to use for the text selection." 271829 271830 ^self valueOfProperty: #selectionColor ifAbsent: [] ! ! 271831 271832!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 16:16'! 271833selectionColor: aColor 271834 "Set the colour to use for the text selection." 271835 271836 aColor 271837 ifNil: [self removeProperty: #selectionColor] 271838 ifNotNil: [self setProperty: #selectionColor toValue: aColor]. 271839 self textMorph ifNotNilDo: [:t | t selectionColor: aColor]! ! 271840 271841!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 16:18'! 271842setText: aText 271843 "Set the auto accept on the text morph." 271844 271845 self textMorph ifNil: [ 271846 super setText: aText. 271847 self textMorph 271848 autoAccept: self autoAccept; 271849 selectionColor: self selectionColor. 271850 ^self]. 271851 ^super setText: aText! ! 271852 271853!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/23/2006 14:52'! 271854textExtent 271855 "Answer the text morph extent." 271856 271857 ^(textMorph ifNil: [^0@0]) extent! ! 271858 271859!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/23/2006 14:50'! 271860textExtent: newExtent 271861 "If autoFit is on then override to false for the duration of the extent call." 271862 271863 textMorph ifNil: [^self]. 271864 textMorph overrideExtent: newExtent! ! 271865 271866!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/9/2006 14:07'! 271867textMorphClass 271868 "Answer the class used to create the receiver's textMorph" 271869 271870 ^TextMorphForEditorView! ! 271871 271872!PluggableTextEditorMorph methodsFor: 'as yet unclassified'! 271873toggleEnabled 271874 "Toggle the enabled state." 271875 271876 self enabled: self enabled not! ! 271877 271878!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:02'! 271879update: aSymbol 271880 "Refer to the comment in View|update:." 271881 271882 super update: aSymbol. 271883 aSymbol == self getEnabledSelector ifTrue: 271884 [self updateEnabled] 271885! ! 271886 271887!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 12:56'! 271888updateEnabled 271889 "Update the enablement state." 271890 271891 self model ifNotNil: [ 271892 self getEnabledSelector ifNotNil: [ 271893 self enabled: (self model perform: self getEnabledSelector)]]! ! 271894 271895!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/23/2006 15:01'! 271896vScrollBarValue: scrollValue 271897 "Trigger an event too." 271898 271899 super vScrollBarValue: scrollValue. 271900 self triggerEvent: #vScroll with: scrollValue! ! 271901 271902!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/20/2006 12:11'! 271903wrapFlag 271904 "Answer the wrap flag on the text morph." 271905 271906 ^(self textMorph ifNil: [self setText: '']) wrapFlag! ! 271907 271908!PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/20/2006 12:11'! 271909wrapFlag: aBoolean 271910 "Set the wrap flag on the text morph." 271911 271912 self textMorph ifNil: [self setText: '']. 271913 self textMorph wrapFlag: aBoolean! ! 271914 271915"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 271916 271917PluggableTextEditorMorph class 271918 uses: TEnableOnHaloMenu classTrait 271919 instanceVariableNames: ''! 271920PluggableTextEditorMorph subclass: #PluggableTextFieldMorph 271921 instanceVariableNames: 'converter' 271922 classVariableNames: '' 271923 poolDictionaries: '' 271924 category: 'Polymorph-Widgets'! 271925!PluggableTextFieldMorph commentStamp: 'gvc 5/18/2007 12:39' prior: 0! 271926Single-line text field editor with DialogWindow key integration (return for default, escape for cancel) and keyboard focus navigation (tab/shift-tab). Additionally supports pluggable converters to translate between an object and its string form and vice-versa.! 271927 271928 271929!PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 12:21'! 271930converter 271931 "Answer the value of converter" 271932 271933 ^ converter! ! 271934 271935!PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 12:21'! 271936converter: anObject 271937 "Set the value of converter" 271938 271939 converter := anObject! ! 271940 271941!PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 15:00'! 271942maxLength 271943 "Answer the maximum number of characters that may be typed." 271944 271945 ^self textMorph maxLength! ! 271946 271947!PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 14:59'! 271948maxLength: anInteger 271949 "Set the maximum number of characters that may be typed." 271950 271951 self textMorph maxLength: anInteger! ! 271952 271953 271954!PluggableTextFieldMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 12:47'! 271955acceptTextInModel 271956 "Inform the model that the receiver's textMorph's text should be accepted. 271957 Answer true if the model accepted ok, false otherwise" 271958 271959 | objectToAccept | 271960 objectToAccept := self converter isNil 271961 ifTrue: [textMorph asText] 271962 ifFalse: [self converter stringAsObject: textMorph asText asString]. 271963 ^setTextSelector isNil or: 271964 [setTextSelector numArgs = 2 271965 ifTrue: [model perform: setTextSelector with: objectToAccept with: self] 271966 ifFalse: [model perform: setTextSelector with: objectToAccept]] 271967! ! 271968 271969!PluggableTextFieldMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 13:08'! 271970borderStyleToUse 271971 "Answer the borderStyle that should be used for the receiver." 271972 271973 ^self enabled 271974 ifTrue: [self theme textFieldNormalBorderStyleFor: self] 271975 ifFalse: [self theme textFieldDisabledBorderStyleFor: self]! ! 271976 271977!PluggableTextFieldMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 12:22'! 271978convertTo: aClass 271979 "Set the converter object class." 271980 271981 self converter isNil 271982 ifTrue: [self converter: (ObjectStringConverter forClass: aClass)] 271983 ifFalse: [self converter objectClass: aClass]! ! 271984 271985!PluggableTextFieldMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 13:04'! 271986fillStyleToUse 271987 "Answer the fillStyle that should be used for the receiver." 271988 271989 ^self enabled 271990 ifTrue: [self theme textFieldNormalFillStyleFor: self] 271991 ifFalse: [self theme textFieldDisabledFillStyleFor: self]! ! 271992 271993!PluggableTextFieldMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 14:06'! 271994getSelection 271995 "Answer the model's selection interval. 271996 If not available keep the current selection." 271997 271998 getSelectionSelector isNil ifFalse: [^super getSelection]. 271999 ^selectionInterval ifNil: [super getSelection]! ! 272000 272001!PluggableTextFieldMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 12:55'! 272002getText 272003 "Retrieve the current model text. Set the converter to 272004 convert between the class of the returned object and string form." 272005 272006 | newObj | 272007 getTextSelector isNil ifTrue: [^super getText]. 272008 newObj := model perform: getTextSelector. 272009 newObj ifNil: [^Text new]. 272010 self converter isNil 272011 ifTrue: [self convertTo: newObj class]. 272012 ^(self converter objectAsString: newObj) shallowCopy! ! 272013 272014!PluggableTextFieldMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/29/2008 16:59'! 272015handlesMouseWheel: evt 272016 "Do I want to receive mouseWheel events?." 272017 272018 ^false! ! 272019 272020!PluggableTextFieldMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/4/2007 15:36'! 272021scrollByKeyboard: event 272022 "If event is ctrl+up/down then scroll and answer true. 272023 Just don't, really!!" 272024 272025 ^false! ! 272026 272027!PluggableTextFieldMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/4/2007 15:15'! 272028scrollSelectionIntoView: event 272029 "Scroll my text into view if necessary and return true, else return false. 272030 Redone here to deal with horizontal scrolling!!" 272031 272032 | selRects delta selRect rectToTest transform cpHere | 272033 selectionInterval := textMorph editor selectionInterval. 272034 selRects := textMorph paragraph selectionRects. 272035 selRects isEmpty ifTrue: [^ false]. 272036 rectToTest := selRects first merge: selRects last. 272037 transform := scroller transformFrom: self. 272038 (event notNil and: [event anyButtonPressed]) ifTrue: "Check for autoscroll" 272039 [cpHere := transform localPointToGlobal: event cursorPoint. 272040 cpHere y <= self top 272041 ifTrue: [rectToTest := selRects first topLeft extent: 2@2] 272042 ifFalse: [cpHere y >= self bottom 272043 ifTrue: [rectToTest := selRects last bottomRight extent: 2@2] 272044 ifFalse: [^ false]]]. 272045 selRect := transform localBoundsToGlobal: rectToTest. 272046 selRect height > bounds height 272047 ifTrue: [^ false]. "Would not fit, even if we tried to scroll" 272048 (delta := selRect amountToTranslateWithin: self innerBounds) ~= (0@0) ifTrue: 272049 ["Scroll end of selection into view if necessary" 272050 self scrollBy: delta truncated. 272051 ^ true]. 272052 ^ false! ! 272053 272054!PluggableTextFieldMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/9/2006 14:07'! 272055textMorphClass 272056 "Answer the class used to create the receiver's textMorph" 272057 272058 ^TextMorphForFieldView! ! 272059 272060!PluggableTextFieldMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/21/2007 10:51'! 272061update: aSymbol 272062 "Update the receiver based on the given aspect. 272063 Override to not accept an #appendText for a text field 272064 since if broadcast by a model it will append to ALL 272065 text fields/editors." 272066 272067 aSymbol == #appendEntry 272068 ifTrue: [^self]. 272069 ^super update: aSymbol! ! 272070ScrollPane subclass: #PluggableTextMorph 272071 instanceVariableNames: 'textMorph getTextSelector setTextSelector getSelectionSelector hasUnacceptedEdits askBeforeDiscardingEdits selectionInterval hasEditingConflicts' 272072 classVariableNames: '' 272073 poolDictionaries: '' 272074 category: 'Morphic-Pluggable Widgets'! 272075 272076!PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/1/2006 16:26'! 272077adoptPaneColor: paneColor 272078 "Pass on to the border too." 272079 272080 super adoptPaneColor: paneColor. 272081 paneColor ifNil: [^self]. 272082 self borderStyle baseColor: (self enabled ifTrue: [paneColor twiceDarker] ifFalse: [paneColor darker])! ! 272083 272084!PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/9/2008 16:09'! 272085appendText: aTextOrString 272086 "Append the given text to the receiver." 272087 272088 self handleEdit: [ 272089 self 272090 selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size; 272091 replaceSelectionWith: aTextOrString; 272092 selectFrom: textMorph asText size + 1 to: textMorph asText size; 272093 hasUnacceptedEdits: false; 272094 scrollSelectionIntoView; 272095 changed]! ! 272096 272097!PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/5/2007 12:24'! 272098drawSubmorphsOn: aCanvas 272099 "Display submorphs back to front. 272100 Draw the focus here since the drawOn: method is so horrible." 272101 272102 super drawSubmorphsOn: aCanvas. 272103 Preferences externalFocusForPluggableText ifTrue: [ 272104 self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOn: aCanvas]]! ! 272105 272106!PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/2/2009 12:17'! 272107focusBounds 272108 "Answer the bounds for drawing the focus indication 272109 (when externalFocusForPluggableText is enabled)." 272110 272111 ^self theme textFocusBoundsFor: self! ! 272112 272113!PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/7/2007 22:52'! 272114hasKeyboardFocus 272115 "Answer whether the receiver has keyboard focus." 272116 272117 ^super hasKeyboardFocus or: [(self textMorph ifNil: [^false]) hasKeyboardFocus]! ! 272118 272119!PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/21/2007 14:40'! 272120keyboardFocusChange: aBoolean 272121 "Pass on to text morph." 272122 272123 aBoolean ifTrue: [self textMorph takeKeyboardFocus]! ! 272124 272125!PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/19/2006 14:19'! 272126layoutBounds: aRectangle 272127 "Set the bounds for laying out children of the receiver. 272128 Note: written so that #layoutBounds can be changed without touching this method" 272129 272130 super layoutBounds: aRectangle. 272131 textMorph ifNotNil: 272132 [textMorph extent: (self innerBounds width-6)@self height]. 272133 self setScrollDeltas 272134! ! 272135 272136!PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/15/2007 11:03'! 272137minHeight 272138 "Implemented here since extent: overriden." 272139 272140 ^super minHeight max: 16! ! 272141 272142!PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/15/2007 11:03'! 272143minWidth 272144 "Implemented here since extent: overriden." 272145 272146 ^super minWidth max: 36! ! 272147 272148!PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/18/2007 11:07'! 272149navigationKey: event 272150 "Check for tab key activity and change focus as appropriate. 272151 Must override here rather than in #tabKey: otherwise 272152 the tab will get passed to the window and change the focus." 272153 272154 (event keyCharacter = Character tab and: [ 272155 (event anyModifierKeyPressed or: [event shiftPressed]) not]) ifTrue: [^false]. 272156 ^super navigationKey: event! ! 272157 272158!PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:29'! 272159takesKeyboardFocus 272160 "Answer whether the receiver can normally take keyboard focus." 272161 272162 ^true! ! 272163 272164!PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/27/2009 12:01'! 272165wantsKeyboardFocus 272166 "Answer whether the receiver would like keyboard focus 272167 in the general case (mouse action normally). Even if disabled 272168 we allow for text morphs since can potentially copy text." 272169 272170 ^self takesKeyboardFocus and: [ 272171 self visible and: [ 272172 self enabled or: [self valueOfProperty: #wantsKeyboardFocusWhenDisabled ifAbsent: [true]]]] 272173! ! 272174 272175 272176!PluggableTextMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 11/14/2008 11:02'! 272177accept 272178 "Inform the model of text to be accepted, and return true if OK." 272179 272180 | ok saveSelection saveScrollerOffset | 272181"sps 8/13/2001 22:41: save selection and scroll info" 272182 saveSelection := self selectionInterval copy. 272183 saveScrollerOffset := scroller offset copy. 272184 272185 (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) 272186 ifTrue: [^ self flash]. 272187 272188 self hasEditingConflicts ifTrue: 272189 [(self confirm: 272190'Caution!! This method may have been 272191changed elsewhere since you started 272192editing it here. Accept anyway?' translated) ifFalse: [^ self flash]]. 272193 ok := self acceptTextInModel. 272194 ok==true ifTrue: 272195 [self setText: self getText. 272196 self hasUnacceptedEdits: false. 272197 (model dependents detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [dep getTextSelector == #annotation]] ifNone: [nil]) ifNotNilDo: 272198 [:aPane | model changed: #annotation]]. 272199 272200 "sps 8/13/2001 22:41: restore selection and scroll info" 272201 ["During the step for the browser, updateCodePaneIfNeeded is called, and 272202 invariably resets the contents of the codeholding PluggableTextMorph 272203 at that time, resetting the cursor position and scroller in the process. 272204 The following line forces that update without waiting for the step, then restores the cursor and scrollbar" 272205 272206 ok ifTrue: "(don't bother if there was an error during compile)" 272207 [(model respondsTo: #updateCodePaneIfNeeded) 272208 ifTrue: [model updateCodePaneIfNeeded]. 272209 scroller offset: saveScrollerOffset. 272210 self setScrollDeltas. 272211 self selectFrom: saveSelection first to: saveSelection last]] 272212 272213 on: Error do: [] 272214! ! 272215 272216!PluggableTextMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/2/2009 12:04'! 272217drawOn: aCanvas 272218 "Indicate unaccepted edits, conflicts etc." 272219 272220 super drawOn: aCanvas. 272221 self wantsFrameAdornments ifTrue: [ 272222 self theme drawTextAdornmentsFor: self on: aCanvas]! ! 272223 272224!PluggableTextMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/13/2007 12:39'! 272225extent: newExtent 272226 "The inner bounds may have changed due to scrollbar visibility." 272227 272228 super extent: (newExtent max: 36@16). 272229 textMorph ifNotNil: 272230 [self innerBounds extent - 6 = textMorph extent 272231 ifFalse: [textMorph extent: self innerBounds extent - 6]]. 272232 self setScrollDeltas 272233! ! 272234 272235!PluggableTextMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/21/2007 14:40'! 272236mouseEnter: event 272237 "Changed to take mouseClickForKeyboardFocus preference into account." 272238 272239 super mouseEnter: event. 272240 self textMorph ifNil: [^self]. 272241 selectionInterval ifNotNil: 272242 [self textMorph editor selectInterval: selectionInterval; setEmphasisHere]. 272243 self textMorph selectionChanged. 272244 self wantsKeyboardFocus ifFalse: [^self]. 272245 Preferences mouseClickForKeyboardFocus 272246 ifFalse: [self textMorph takeKeyboardFocus]! ! 272247 272248!PluggableTextMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/13/2007 12:29'! 272249resetExtent 272250 "Reset the extent while maintaining the current selection. Needed when resizing while the editor is active (when inside the pane)." 272251 | tempSelection | 272252 textMorph notNil ifTrue: 272253 ["the current selection gets munged by resetting the extent, so store it" 272254 tempSelection := self selectionInterval. 272255 272256 "don't reset it if it's not active" 272257 tempSelection = (Interval from: 1 to: 0) 272258 ifTrue: [retractableScrollBar 272259 ifTrue:[ ^ self]]. 272260 super resetExtent. "adjust scroller" 272261 self extent: self extent. 272262 self setSelection: tempSelection]! ! 272263 272264!PluggableTextMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/28/2008 14:44'! 272265wantsFrameAdornments 272266 "Answer whether the receiver wishes to have red borders, etc., 272267 used to show editing state" 272268 "A 'long-term temporary workaround': a nonmodular, 272269 unsavory, but expedient way to get the desired effect, sorry. 272270 Clean up someday." 272271 ^ self 272272 valueOfProperty: #wantsFrameAdornments 272273 ifAbsent: [([Preferences showTextEditingState] on: Error do: [true]) "handle missing preference" 272274 ifTrue: [(#(annotation searchString infoViewContents ) includes: getTextSelector) not] 272275 ifFalse: [false]]! ! 272276 272277 272278!PluggableTextMorph methodsFor: '*etoys-model access' stamp: 'RAA 11/5/2000 14:10'! 272279eToyGetMainFont 272280 272281 ^ textMorph textStyle! ! 272282 272283 272284!PluggableTextMorph methodsFor: '*etoys-transcript' stamp: 'RAA 5/1/2002 18:17'! 272285appendTextEtoy: moreText 272286 "Append the text in the model's writeStream to the editable text. " 272287 272288 self handleEdit: [ 272289 self 272290 selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size; 272291 replaceSelectionWith: moreText; 272292 selectFrom: textMorph asText size + 1 to: textMorph asText size; 272293 hasUnacceptedEdits: false; 272294 scrollSelectionIntoView; 272295 changed 272296 ]! ! 272297 272298 272299!PluggableTextMorph methodsFor: '*services-base' stamp: 'rr 3/21/2004 12:29'! 272300textMorph 272301 ^ textMorph! ! 272302 272303 272304!PluggableTextMorph methodsFor: 'accessing' stamp: 'sr 4/25/2000 07:21'! 272305getTextSelector 272306 ^getTextSelector! ! 272307 272308!PluggableTextMorph methodsFor: 'accessing' stamp: 'jmv 5/10/2009 09:42'! 272309wrapFlag: aBoolean 272310 textMorph wrapFlag: aBoolean! ! 272311 272312 272313!PluggableTextMorph methodsFor: 'dependents access' stamp: 'di 4/20/1998 18:52'! 272314canDiscardEdits 272315 "Return true if this view either has no text changes or does not care." 272316 272317 ^ (hasUnacceptedEdits & askBeforeDiscardingEdits) not 272318! ! 272319 272320!PluggableTextMorph methodsFor: 'dependents access' stamp: 'di 4/20/1998 18:56'! 272321hasUnacceptedEdits 272322 "Return true if this view has unaccepted edits." 272323 272324 ^ hasUnacceptedEdits! ! 272325 272326 272327!PluggableTextMorph methodsFor: 'drawing' stamp: 'dgd 10/1/2004 12:32'! 272328wantsFrameAdornments: aBoolean 272329 self setProperty: #wantsFrameAdornments toValue: aBoolean! ! 272330 272331 272332!PluggableTextMorph methodsFor: 'dropping/grabbing' stamp: 'jcg 7/7/2000 11:13'! 272333wantsDroppedMorph: aMorph event: anEvent 272334 ^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! ! 272335 272336 272337!PluggableTextMorph methodsFor: 'editor access' stamp: 'di 11/2/1998 15:57'! 272338handleEdit: editBlock 272339 | result | 272340 textMorph editor selectFrom: selectionInterval first to: selectionInterval last; 272341 model: model. "For, eg, evaluateSelection" 272342 textMorph handleEdit: [result := editBlock value]. "Update selection after edit" 272343 self scrollSelectionIntoView. 272344 ^ result! ! 272345 272346!PluggableTextMorph methodsFor: 'editor access' stamp: 'di 5/22/1998 12:35'! 272347scrollSelectionIntoView 272348 "Scroll my text into view if necessary and return true, else return false" 272349 ^ self scrollSelectionIntoView: nil! ! 272350 272351!PluggableTextMorph methodsFor: 'editor access' stamp: 'sumim 12/12/2006 13:23'! 272352scrollSelectionIntoView: event 272353 "Scroll my text into view if necessary and return true, else return false" 272354 | selRects delta selRect rectToTest transform cpHere editor | 272355 editor := textMorph editor. 272356 selectionInterval := editor selectionInterval. 272357 selRects := textMorph paragraph selectionRects. 272358 selRects isEmpty ifTrue: [^ false]. 272359 rectToTest := selRects first merge: selRects last. 272360 transform := scroller transformFrom: self. 272361 (event notNil and: [event anyButtonPressed]) ifTrue: "Check for autoscroll" 272362 [cpHere := transform localPointToGlobal: event cursorPoint. 272363 cpHere y <= self top 272364 ifTrue: [rectToTest := selRects first topLeft extent: 2@2] 272365 ifFalse: [cpHere y >= self bottom 272366 ifTrue: [rectToTest := selRects last bottomRight extent: 2@2] 272367 ifFalse: [^ false]]]. 272368 selRect := transform localBoundsToGlobal: rectToTest. 272369 selRect height > bounds height 272370 ifTrue: [(editor pointIndex - editor markIndex) < 0 272371 ifTrue: [self scrollBy: 0@(self innerBounds top - selRect top)] 272372 ifFalse: [self scrollBy: 0@(self innerBounds bottom - selRect bottom)]. 272373 ^ true]. 272374 (delta := selRect amountToTranslateWithin: self innerBounds) y ~= 0 ifTrue: 272375 ["Scroll end of selection into view if necessary" 272376 self scrollBy: 0@delta y. 272377 ^ true]. 272378 ^ false 272379! ! 272380 272381!PluggableTextMorph methodsFor: 'editor access' stamp: 'sw 7/24/2001 02:21'! 272382selectAll 272383 "Tell my textMorph's editor to select all" 272384 272385 textMorph editor selectAll! ! 272386 272387!PluggableTextMorph methodsFor: 'editor access' stamp: 'sw 7/24/2001 02:24'! 272388setTextMorphToSelectAllOnMouseEnter 272389 "Tell my textMorph's editor to select all when the mouse enters" 272390 272391 textMorph on: #mouseEnter send: #selectAll to: textMorph! ! 272392 272393 272394!PluggableTextMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 23:21'! 272395handlesKeyboard: evt 272396 ^true! ! 272397 272398!PluggableTextMorph methodsFor: 'event handling' stamp: 'sw 12/12/2000 14:42'! 272399keyStroke: evt 272400 "A keystroke was hit while the receiver had keyboard focus. Pass the keywtroke on to my textMorph, and and also, if I have an event handler, pass it on to that handler" 272401 272402 textMorph keyStroke: evt. 272403 self eventHandler ifNotNil: 272404 [self eventHandler keyStroke: evt fromMorph: self]. 272405! ! 272406 272407!PluggableTextMorph methodsFor: 'event handling' stamp: 'sw 12/4/2001 12:42'! 272408mouseLeave: event 272409 "The mouse has left the area of the receiver" 272410 272411 textMorph ifNotNil: [selectionInterval := textMorph editor selectionInterval]. 272412 super mouseLeave: event. 272413 Preferences mouseOverForKeyboardFocus ifTrue: 272414 [event hand releaseKeyboardFocus: textMorph]! ! 272415 272416!PluggableTextMorph methodsFor: 'event handling' stamp: 'dvf 7/28/2003 14:50'! 272417onKeyStrokeSend: sel to: recipient 272418 textMorph on: #keyStroke send: sel to: recipient.! ! 272419 272420 272421!PluggableTextMorph methodsFor: 'geometry' stamp: 'JW 2/21/2001 22:15'! 272422extraScrollRange 272423 ^ self height // 4! ! 272424 272425!PluggableTextMorph methodsFor: 'geometry' stamp: 'dew 2/19/1999 17:08'! 272426scrollDeltaHeight 272427 "Return the increment in pixels which this pane should be scrolled." 272428 ^ scroller firstSubmorph defaultLineHeight 272429! ! 272430 272431 272432!PluggableTextMorph methodsFor: 'initialization' stamp: 'di 9/11/1998 15:46'! 272433acceptOnCR: trueOrFalse 272434 textMorph acceptOnCR: trueOrFalse! ! 272435 272436!PluggableTextMorph methodsFor: 'initialization' stamp: 'di 5/4/1998 15:55'! 272437editString: aString 272438 "Jam some text in. This is treated as clean text by default." 272439 272440 self setText: aString asText! ! 272441 272442!PluggableTextMorph methodsFor: 'initialization' stamp: 'bolot 11/2/1999 03:18'! 272443font: aFont 272444 textMorph beAllFont: aFont! ! 272445 272446!PluggableTextMorph methodsFor: 'initialization' stamp: 'nk 2/14/2004 18:19'! 272447initialize 272448 "initialize the state of the receiver" 272449 super initialize. 272450 hasUnacceptedEdits := false. 272451 hasEditingConflicts := false. 272452 askBeforeDiscardingEdits := true. 272453! ! 272454 272455!PluggableTextMorph methodsFor: 'initialization' stamp: 'di 4/9/98 16:25'! 272456on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel 272457 272458 self model: anObject. 272459 getTextSelector := getTextSel. 272460 setTextSelector := setTextSel. 272461 getSelectionSelector := getSelectionSel. 272462 getMenuSelector := getMenuSel. 272463 self borderWidth: 1. 272464 self setText: self getText. 272465 self setSelection: self getSelection.! ! 272466 272467 272468!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 6/22/1998 15:15'! 272469correctFrom: start to: stop with: aString 272470 ^ self handleEdit: [textMorph editor correctFrom: start to: stop with: aString]! ! 272471 272472!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'jcg 11/5/2000 22:25'! 272473correctSelectionWithString: aString 272474 | result newPosition | 272475 272476 "I can't tell if this is a hack or if it's the right thing to do." 272477 self setSelection: selectionInterval. 272478 272479 result := self correctFrom: selectionInterval first to: selectionInterval last with: aString. 272480 newPosition := selectionInterval first + aString size. 272481 self setSelection: (newPosition to: newPosition - 1). 272482 ^ result! ! 272483 272484!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 15:16'! 272485deselect 272486 ^ textMorph editor deselect! ! 272487 272488!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 15:26'! 272489nextTokenFrom: start direction: dir 272490 ^ textMorph editor nextTokenFrom: start direction: dir! ! 272491 272492!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/20/1998 08:32'! 272493notify: aString at: anInteger in: aStream 272494 ^ textMorph editor notify: aString at: anInteger in: aStream! ! 272495 272496!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 14:59'! 272497select 272498 ^ textMorph editor select! ! 272499 272500!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 14:58'! 272501selectFrom: start to: stop 272502 ^ textMorph editor selectFrom: start to: stop! ! 272503 272504!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 15:18'! 272505selectInvisiblyFrom: start to: stop 272506 ^ textMorph editor selectInvisiblyFrom: start to: stop! ! 272507 272508!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 14:56'! 272509selectionInterval 272510 ^ textMorph editor selectionInterval! ! 272511 272512 272513!PluggableTextMorph methodsFor: 'layout' stamp: 'jcg 7/7/2000 11:08'! 272514acceptDroppingMorph: aMorph event: evt 272515 "This message is sent when a morph is dropped onto a morph that has 272516 agreed to accept the dropped morph by responding 'true' to the 272517 wantsDroppedMorph:Event: message. The default implementation just 272518 adds the given morph to the receiver." 272519 "Here we let the model do its work." 272520 272521 self model 272522 acceptDroppingMorph: aMorph 272523 event: evt 272524 inMorph: self. 272525 272526! ! 272527 272528 272529!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tween 8/29/2004 20:25'! 272530acceptTextInModel 272531 "Inform the model that the receiver's textMorph's text should be accepted. 272532 Answer true if the model accepted ok, false otherwise" 272533 | textToAccept | 272534 272535 textToAccept := textMorph asText. 272536 ^setTextSelector isNil or: 272537 [setTextSelector numArgs = 2 272538 ifTrue: [model perform: setTextSelector with: textToAccept with: self] 272539 ifFalse: [model perform: setTextSelector with: textToAccept]] 272540! ! 272541 272542!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:41'! 272543again 272544 self handleEdit: [textMorph editor again]! ! 272545 272546!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 4/24/2001 12:24'! 272547browseChangeSetsWithSelector 272548 "Help the user track down which change sets mention a particular selector" 272549 272550 self handleEdit: [textMorph editor browseChangeSetsWithSelector]! ! 272551 272552!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:04'! 272553browseIt 272554 self handleEdit: [textMorph editor browseIt]! ! 272555 272556!PluggableTextMorph methodsFor: 'menu commands' stamp: 'marcus.denker 11/10/2008 10:04'! 272557cancel 272558 self setText: self getText. 272559 self setSelection: self getSelection. 272560 getTextSelector == #annotation ifFalse: 272561 [(model dependents detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [dep getTextSelector == #annotation]] ifNone: [nil]) ifNotNil: 272562 [:aPane | model changed: #annotation]]! ! 272563 272564!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:41'! 272565changeStyle 272566 self handleEdit: [textMorph editor changeStyle]! ! 272567 272568!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 9/27/1999 11:57'! 272569chooseAlignment 272570 self handleEdit: [textMorph editor changeAlignment]! ! 272571 272572!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 5/1/2001 21:37'! 272573classCommentsContainingIt 272574 self handleEdit: [textMorph editor classCommentsContainingIt]! ! 272575 272576!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 7/31/2002 01:48'! 272577classNamesContainingIt 272578 self handleEdit: [textMorph editor classNamesContainingIt]! ! 272579 272580!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:04'! 272581copySelection 272582 self handleEdit: [textMorph editor copySelection]! ! 272583 272584!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:41'! 272585cut 272586 self handleEdit: [textMorph editor cut]! ! 272587 272588!PluggableTextMorph methodsFor: 'menu commands' stamp: 'vb 7/29/2001 12:45'! 272589debugIt 272590 self handleEdit: [textMorph editor debugIt]! ! 272591 272592!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 22:04'! 272593doIt 272594 self handleEdit: [textMorph editor evaluateSelection]! ! 272595 272596!PluggableTextMorph methodsFor: 'menu commands' stamp: 'rhi 12/6/2001 11:06'! 272597exploreIt 272598 272599 | result | 272600 self handleEdit: [ 272601 result := textMorph editor evaluateSelection. 272602 ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) 272603 ifTrue: [self flash] 272604 ifFalse: [result explore]].! ! 272605 272606!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:02'! 272607fileItIn 272608 self handleEdit: [textMorph editor fileItIn]! ! 272609 272610!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:42'! 272611find 272612 self handleEdit: [textMorph editor find]! ! 272613 272614!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:42'! 272615findAgain 272616 self handleEdit: [textMorph editor findAgain]! ! 272617 272618!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:02'! 272619implementorsOfIt 272620 self handleEdit: [textMorph editor implementorsOfIt]! ! 272621 272622!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 22:07'! 272623inspectIt 272624 | result | 272625 self handleEdit: 272626 [result := textMorph editor evaluateSelection. 272627 ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) 272628 ifTrue: [self flash] 272629 ifFalse: [result inspect]]! ! 272630 272631!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:01'! 272632methodNamesContainingIt 272633 self handleEdit: [textMorph editor methodNamesContainingIt]! ! 272634 272635!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:01'! 272636methodSourceContainingIt 272637 self handleEdit: [textMorph editor methodSourceContainingIt]! ! 272638 272639!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:01'! 272640methodStringsContainingit 272641 self handleEdit: [textMorph editor methodStringsContainingit]! ! 272642 272643!PluggableTextMorph methodsFor: 'menu commands' stamp: 'ar 12/17/2001 13:00'! 272644offerFontMenu 272645 self handleEdit: [textMorph editor changeTextFont]! ! 272646 272647!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:44'! 272648paste 272649 self handleEdit: [textMorph editor paste]! ! 272650 272651!PluggableTextMorph methodsFor: 'menu commands' stamp: 'ar 1/15/2001 18:36'! 272652pasteRecent 272653 "Paste an item chosen from RecentClippings." 272654 272655 | clipping | 272656 (clipping := Clipboard chooseRecentClipping) ifNil: [^ self]. 272657 Clipboard clipboardText: clipping. 272658 ^ self handleEdit: [textMorph editor paste]! ! 272659 272660!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 11/7/1999 00:01'! 272661prettyPrint 272662 self handleEdit: [textMorph editor prettyPrint]! ! 272663 272664!PluggableTextMorph methodsFor: 'menu commands' stamp: 'dew 3/7/2000 21:10'! 272665printerSetup 272666 self handleEdit: [textMorph editor printerSetup]! ! 272667 272668!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:07'! 272669printIt 272670 | result oldEditor | 272671 272672 textMorph editor selectFrom: selectionInterval first to: selectionInterval last; 272673 model: model. "For, eg, evaluateSelection" 272674 textMorph handleEdit: [result := (oldEditor := textMorph editor) evaluateSelection]. 272675 ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) ifTrue: [^self flash]. 272676 selectionInterval := oldEditor selectionInterval. 272677 textMorph installEditorToReplace: oldEditor. 272678 textMorph handleEdit: [oldEditor afterSelectionInsertAndSelect: result printString]. 272679 selectionInterval := oldEditor selectionInterval. 272680 272681 textMorph editor selectFrom: selectionInterval first to: selectionInterval last. 272682 self scrollSelectionIntoView. 272683 272684! ! 272685 272686!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 15:59'! 272687referencesToIt 272688 self handleEdit: [textMorph editor referencesToIt]! ! 272689 272690!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 15:31'! 272691sendersOfIt 272692 self handleEdit: [textMorph editor sendersOfIt]! ! 272693 272694!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:09'! 272695setSearchString 272696 self handleEdit: [textMorph editor setSearchString]! ! 272697 272698!PluggableTextMorph methodsFor: 'menu commands' stamp: 'marcus.Denker 9/14/2008 10:55'! 272699showBytecodes 272700 model showBytecodes. 272701 272702! ! 272703 272704!PluggableTextMorph methodsFor: 'menu commands' stamp: 'ab 3/23/2005 16:50'! 272705tallyIt 272706 self handleEdit: [textMorph editor tallyIt]! ! 272707 272708!PluggableTextMorph methodsFor: 'menu commands' stamp: 'marcus.denker 11/10/2008 10:04'! 272709toggleAnnotationPaneSize 272710 272711 | handle origin aHand siblings newHeight lf prevBottom m ht | 272712 272713 self flag: #bob. "CRUDE HACK to enable changing the size of the annotations pane" 272714 272715 owner ifNil: [^self]. 272716 siblings := owner submorphs. 272717 siblings size > 3 ifTrue: [^self]. 272718 siblings size < 2 ifTrue: [^self]. 272719 272720 aHand := self primaryHand. 272721 origin := aHand position. 272722 handle := HandleMorph new 272723 forEachPointDo: [:newPoint | 272724 handle removeAllMorphs. 272725 newHeight := (newPoint - origin) y asInteger min: owner height - 50 max: 16. 272726 lf := siblings last layoutFrame. 272727 lf bottomOffset: newHeight. 272728 prevBottom := newHeight. 272729 siblings size - 1 to: 1 by: -1 do: [ :index | 272730 m := siblings at: index. 272731 lf := m layoutFrame. 272732 ht := lf bottomOffset - lf topOffset. 272733 lf topOffset: prevBottom. 272734 lf bottomOffset = 0 ifFalse: [ 272735 lf bottomOffset: (prevBottom + ht). 272736 ]. 272737 prevBottom := prevBottom + ht. 272738 ]. 272739 owner layoutChanged. 272740 272741 ] 272742 lastPointDo: 272743 [:newPoint | handle deleteBalloon. 272744 self halo ifNotNil: [:halo | halo addHandles]. 272745 ]. 272746 aHand attachMorph: handle. 272747 handle setProperty: #helpAtCenter toValue: true. 272748 handle showBalloon: 272749'Move cursor farther from 272750this point to increase pane. 272751Click when done.' hand: aHand. 272752 handle startStepping 272753 272754! ! 272755 272756!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:13'! 272757undo 272758 self handleEdit: [textMorph editor undo]! ! 272759 272760!PluggableTextMorph methodsFor: 'menu commands' stamp: 'dgd 10/1/2004 13:27'! 272761yellowButtonActivity 272762 "Called when the shifted-menu's 'more' item is chosen" 272763 self yellowButtonActivity: false! ! 272764 272765!PluggableTextMorph methodsFor: 'menu commands' stamp: 'dgd 10/1/2004 13:32'! 272766yellowButtonActivity: shiftKeyState 272767 "Called when the shifted-menu's 'more' item is chosen" 272768 | menu | 272769 (menu := self getMenu: shiftKeyState) 272770 ifNotNil: ["" 272771 menu setInvokingView: self. 272772 menu invokeModal]! ! 272773 272774 272775!PluggableTextMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:02'! 272776getSelection 272777 "Answer the model's selection interval." 272778 272779 getSelectionSelector isNil ifTrue: [^1 to: 0]. "null selection" 272780 ^model perform: getSelectionSelector! ! 272781 272782!PluggableTextMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:02'! 272783getText 272784 "Retrieve the current model text" 272785 272786 | newText | 272787 getTextSelector isNil ifTrue: [^Text new]. 272788 newText := model perform: getTextSelector. 272789 newText ifNil: [^Text new]. 272790 ^newText shallowCopy! ! 272791 272792!PluggableTextMorph methodsFor: 'model access' stamp: 'di 6/22/1998 01:32'! 272793selectionInterval: sel 272794 selectionInterval := sel! ! 272795 272796!PluggableTextMorph methodsFor: 'model access' stamp: 'wod 5/26/1998 17:03'! 272797setSelection: sel 272798 selectionInterval := sel. 272799 textMorph editor selectFrom: sel first to: sel last. 272800 self scrollSelectionIntoView ifFalse: [scroller changed].! ! 272801 272802!PluggableTextMorph methodsFor: 'model access' stamp: 'sw 2/6/2001 01:24'! 272803setTextColor: aColor 272804 "Set the color of my text to the given color" 272805 272806 textMorph color: aColor! ! 272807 272808!PluggableTextMorph methodsFor: 'model access' stamp: 'tween 8/29/2004 20:43'! 272809setText: aText 272810 scrollBar setValue: 0.0. 272811 textMorph 272812 ifNil: [textMorph := self textMorphClass new 272813 contents: aText wrappedTo: self innerBounds width-6. 272814 textMorph setEditView: self. 272815 scroller addMorph: textMorph] 272816 ifNotNil: [textMorph newContents: aText]. 272817 self hasUnacceptedEdits: false. 272818 self setScrollDeltas.! ! 272819 272820!PluggableTextMorph methodsFor: 'model access' stamp: 'di 4/20/1998 07:59'! 272821text 272822 ^ textMorph contents! ! 272823 272824 272825!PluggableTextMorph methodsFor: 'scroll bar events' stamp: 'rr 3/10/2004 09:30'! 272826scrollBarMenuButtonPressed: event 272827 "The menu button in the scrollbar was pressed; put up the menu" 272828 272829 | menu | 272830 (menu := self getMenu: event shiftPressed) ifNotNil: 272831 ["Set up to use perform:orSendTo: for model/view dispatch" 272832 menu setInvokingView: self. 272833 menu invokeModal]! ! 272834 272835 272836!PluggableTextMorph methodsFor: 'scrolling' stamp: 'sps 3/9/2004 15:55'! 272837hUnadjustedScrollRange 272838"Return the width of the widest item in the list" 272839 272840 textMorph ifNil: [ ^0 ]. 272841 textMorph isWrapped ifTrue:[ ^0 ]. 272842 272843 ^super hUnadjustedScrollRange 272844! ! 272845 272846 272847!PluggableTextMorph methodsFor: 'transcript' stamp: 'di 5/13/1998 14:29'! 272848appendEntry 272849 "Append the text in the model's writeStream to the editable text. " 272850 textMorph asText size > model characterLimit ifTrue: 272851 ["Knock off first half of text" 272852 self selectInvisiblyFrom: 1 to: textMorph asText size // 2. 272853 self replaceSelectionWith: Text new]. 272854 self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size. 272855 self replaceSelectionWith: model contents asText. 272856 self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size! ! 272857 272858!PluggableTextMorph methodsFor: 'transcript' stamp: 'sma 3/15/2000 21:40'! 272859bsText 272860 self changeText: (self text copyFrom: 1 to: (self text size - 1 max: 0))! ! 272861 272862!PluggableTextMorph methodsFor: 'transcript' stamp: 'di 5/8/1998 21:22'! 272863changeText: aText 272864 "The paragraph to be edited is changed to aText." 272865 self setText: aText! ! 272866 272867!PluggableTextMorph methodsFor: 'transcript' stamp: 'di 5/9/1998 21:40'! 272868replaceSelectionWith: aText 272869 ^ textMorph editor replaceSelectionWith: aText! ! 272870 272871 272872!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'di 4/20/1998 18:53'! 272873askBeforeDiscardingEdits: aBoolean 272874 "Set the flag that determines whether the user should be asked before discarding unaccepted edits." 272875 272876 askBeforeDiscardingEdits := aBoolean! ! 272877 272878!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'sw 10/10/1999 22:55'! 272879hasEditingConflicts 272880 "Return true if a conflicting edit to the same code (typically) is known to have occurred after the current contents started getting edited" 272881 272882 ^ hasEditingConflicts == true! ! 272883 272884!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'sw 10/10/1999 22:55'! 272885hasEditingConflicts: aBoolean 272886 272887 hasEditingConflicts := aBoolean! ! 272888 272889!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'sw 10/10/1999 23:06'! 272890hasUnacceptedEdits: aBoolean 272891 "Set the hasUnacceptedEdits flag to the given value. " 272892 aBoolean == hasUnacceptedEdits ifFalse: 272893 [hasUnacceptedEdits := aBoolean. 272894 self changed]. 272895 aBoolean ifFalse: [hasEditingConflicts := false]! ! 272896 272897!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'dgd 9/21/2003 17:40'! 272898promptForCancel 272899 "Ask if it is OK to cancel changes to text" 272900 (self confirm: 272901'Changes have not been saved. 272902Is it OK to cancel those changes?' translated) 272903 ifTrue: [model clearUserEditFlag]. 272904! ! 272905 272906 272907!PluggableTextMorph methodsFor: 'updating' stamp: 'sd 5/10/2008 11:01'! 272908update: aSymbol 272909 aSymbol ifNil: [^self]. 272910 aSymbol == #flash ifTrue: [^self flash]. 272911 aSymbol == getTextSelector 272912 ifTrue: 272913 [self setText: self getText. 272914 ^self setSelection: self getSelection]. 272915 aSymbol == getSelectionSelector 272916 ifTrue: [^self setSelection: self getSelection]. 272917 (aSymbol == #autoSelect and: [getSelectionSelector notNil]) 272918 ifTrue: 272919 [self handleEdit: 272920 [ParagraphEditor abandonChangeText. "no replacement!!" 272921 (textMorph editor) 272922 setSearch: model autoSelectString; 272923 againOrSame: true]]. 272924 aSymbol == #clearUserEdits ifTrue: [^self hasUnacceptedEdits: false]. 272925 aSymbol == #wantToChange 272926 ifTrue: 272927 [self canDiscardEdits ifFalse: [^self promptForCancel]. 272928 ^self]. 272929 aSymbol == #appendEntry 272930 ifTrue: 272931 [self handleEdit: [self appendEntry]. 272932 ^self ]. 272933 aSymbol == #clearText 272934 ifTrue: 272935 [self handleEdit: [self changeText: Text new]. 272936 ^self ]. 272937 aSymbol == #bs 272938 ifTrue: 272939 [self handleEdit: [self bsText]. 272940 ^self ]. 272941 aSymbol == #codeChangedElsewhere 272942 ifTrue: 272943 [self hasEditingConflicts: true. 272944 ^self changed]! ! 272945 272946 272947!PluggableTextMorph methodsFor: 'watchIt' stamp: 'torsten.bergmann 1/22/2009 11:52'! 272948watchIt 272949 272950 | result | 272951 272952 self handleEdit: 272953 [result := textMorph editor compileSelectionAsBlock. 272954 ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) 272955 ifTrue: [^self flash]]. 272956 (RectangleMorph new) 272957 layoutPolicy: TableLayout new; 272958 layoutInset: 10; 272959 listDirection: #topToBottom; 272960 hResizing: #shrinkWrap; 272961 vResizing: #shrinkWrap; 272962 addMorphBack: (StringMorph contents: textMorph editor selection); 272963 addMorphBack: ((UpdatingStringMorph on: result selector: #value) 272964 stepTime: 500; 272965 maximumWidth: nil; 272966 growable: true); 272967 color: Color white; 272968 borderColor: Color black; 272969 openInWindowLabeled: 'Watcher'.! ! 272970 272971 272972!PluggableTextMorph methodsFor: 'private' stamp: 'tween 8/29/2004 20:42'! 272973textMorphClass 272974 "Answer the class used to create the receiver's textMorph" 272975 272976 ^TextMorphForEditView! ! 272977 272978"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 272979 272980PluggableTextMorph class 272981 instanceVariableNames: ''! 272982 272983!PluggableTextMorph class methodsFor: 'as yet unclassified' stamp: 'di 4/7/98 16:03'! 272984on: anObject text: getTextSel accept: setTextSel 272985 272986 ^ self on: anObject 272987 text: getTextSel 272988 accept: setTextSel 272989 readSelection: nil 272990 menu: nil! ! 272991 272992!PluggableTextMorph class methodsFor: 'as yet unclassified' stamp: 'di 4/7/98 16:03'! 272993on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel 272994 272995 ^ self new on: anObject 272996 text: getTextSel 272997 accept: setTextSel 272998 readSelection: getSelectionSel 272999 menu: getMenuSel! ! 273000PluggableTextMorph subclass: #PluggableTextMorphPlus 273001 instanceVariableNames: 'getColorSelector acceptAction' 273002 classVariableNames: '' 273003 poolDictionaries: '' 273004 category: 'ToolBuilder-Morphic'! 273005!PluggableTextMorphPlus commentStamp: 'ar 2/11/2005 21:53' prior: 0! 273006A pluggable text morph with support for color.! 273007 273008 273009!PluggableTextMorphPlus methodsFor: 'accessing' stamp: 'ar 7/16/2005 19:01'! 273010acceptAction 273011 ^acceptAction! ! 273012 273013!PluggableTextMorphPlus methodsFor: 'accessing' stamp: 'ar 7/16/2005 19:01'! 273014acceptAction: anAction 273015 acceptAction := anAction! ! 273016 273017!PluggableTextMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:21'! 273018getColorSelector 273019 ^getColorSelector! ! 273020 273021!PluggableTextMorphPlus methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:21'! 273022getColorSelector: aSymbol 273023 getColorSelector := aSymbol. 273024 self update: getColorSelector.! ! 273025 273026 273027!PluggableTextMorphPlus methodsFor: 'updating' stamp: 'ar 7/16/2005 19:02'! 273028accept 273029 super accept. 273030 acceptAction ifNotNil:[acceptAction value: textMorph asText].! ! 273031 273032!PluggableTextMorphPlus methodsFor: 'updating' stamp: 'ar 2/11/2005 21:22'! 273033update: what 273034 what ifNil:[^self]. 273035 what == getColorSelector ifTrue:[self color: (model perform: getColorSelector)]. 273036 ^super update: what! ! 273037PluggableTextMorph subclass: #PluggableTextMorphWithModel 273038 instanceVariableNames: 'myContents' 273039 classVariableNames: '' 273040 poolDictionaries: '' 273041 category: 'Morphic-Pluggable Widgets'! 273042 273043!PluggableTextMorphWithModel methodsFor: 'contents' stamp: 'mjg 12/3/1999 11:57'! 273044getMyText 273045 ^myContents! ! 273046 273047!PluggableTextMorphWithModel methodsFor: 'contents' stamp: 'mjg 12/3/1999 11:59'! 273048setMyText: someText 273049 myContents := someText. 273050 ^true.! ! 273051 273052 273053!PluggableTextMorphWithModel methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:25'! 273054initialize 273055 "initialize the state of the receiver" 273056 super initialize. 273057 self 273058 on: self 273059 text: #getMyText 273060 accept: #setMyText: 273061 readSelection: nil 273062 menu: nil! ! 273063 273064 273065!PluggableTextMorphWithModel methodsFor: 'submorphs-add/remove' stamp: 'sw 10/26/2000 14:39'! 273066delete 273067 "Delete the receiver. Since I have myself as a dependent, I need to remove it. which is odd in itself. Also, the release of dependents will seemingly not be done if the *container* of the receiver is deleted rather than the receiver itself, a further problem" 273068 273069 self removeDependent: self. 273070 super delete! ! 273071 273072"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 273073 273074PluggableTextMorphWithModel class 273075 instanceVariableNames: ''! 273076 273077!PluggableTextMorphWithModel class methodsFor: 'scripting' stamp: 'sw 10/30/2000 11:14'! 273078authoringPrototype 273079 "Answer an instance of the receiver suitable for placing in a parts bin" 273080 273081 | proto | 273082 proto := super authoringPrototype. 273083 proto color: (Color r: 0.972 g: 0.972 b: 0.662). 273084 ^ proto! ! 273085PluggableWidgetSpec subclass: #PluggableTextSpec 273086 instanceVariableNames: 'getText setText selection menu color' 273087 classVariableNames: '' 273088 poolDictionaries: '' 273089 category: 'ToolBuilder-Kernel'! 273090!PluggableTextSpec commentStamp: 'ar 2/11/2005 21:58' prior: 0! 273091A text editor. 273092 273093Instance variables: 273094 getText <Symbol> The selector to retrieve the text. 273095 setText <Symbol> The selector to set the text. 273096 selection <Symbol> The selector to retrieve the text selection. 273097 menu <Symbol> The selector to offer (to retrieve?) the context menu. 273098 color <Symbol> The selector to retrieve the background color. 273099 273100! 273101 273102 273103!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:51'! 273104color 273105 "Answer the selector for retrieving the background color" 273106 ^color! ! 273107 273108!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/11/2005 21:51'! 273109color: aSymbol 273110 "Indicate the selector for retrieving the background color" 273111 color := aSymbol.! ! 273112 273113!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:23'! 273114getText 273115 "Answer the selector for retrieving the text" 273116 ^getText! ! 273117 273118!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:23'! 273119getText: aSymbol 273120 "Answer the selector for retrieving the text" 273121 getText := aSymbol! ! 273122 273123!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:25'! 273124menu 273125 "Answer the selector for retrieving the text's menu" 273126 ^menu! ! 273127 273128!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:26'! 273129menu: aSymbol 273130 "Indicate the selector for retrieving the text's menu" 273131 menu := aSymbol! ! 273132 273133!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:25'! 273134selection 273135 "Answer the selector for retrieving the text selection" 273136 ^selection! ! 273137 273138!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:25'! 273139selection: aSymbol 273140 "Indicate the selector for retrieving the text selection" 273141 selection := aSymbol! ! 273142 273143!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:24'! 273144setText 273145 "Answer the selector for setting the text" 273146 ^setText! ! 273147 273148!PluggableTextSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:24'! 273149setText: aSymbol 273150 "Answer the selector for setting the text" 273151 setText := aSymbol! ! 273152 273153 273154!PluggableTextSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'! 273155buildWith: builder 273156 ^builder buildPluggableText: self! ! 273157PluggablePanelMorph subclass: #PluggableThemedPanelMorph 273158 instanceVariableNames: '' 273159 classVariableNames: '' 273160 poolDictionaries: '' 273161 category: 'Polymorph-ToolBuilder-Morphic'! 273162 273163!PluggableThemedPanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/14/2007 15:12'! 273164adoptPaneColor: aColor 273165 "Set the pane color." 273166 273167 super adoptPaneColor: aColor. 273168 aColor ifNil: [^self]. 273169 self fillStyle: self normalFillStyle! ! 273170 273171!PluggableThemedPanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/14/2007 15:30'! 273172color: aColor 273173 "Set the pane color." 273174 273175 (self valueOfProperty: #fillStyle ifAbsent: []) ifNil: [ 273176 super color: aColor]! ! 273177 273178!PluggableThemedPanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 12:13'! 273179extent: aPoint 273180 "Update the bar fillStyle if appropriate." 273181 273182 super extent: aPoint. 273183 self fillStyle isOrientedFill ifTrue: [ 273184 self fillStyle: self normalFillStyle]! ! 273185 273186!PluggableThemedPanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/14/2007 15:09'! 273187initialize 273188 "Initialize the receiver." 273189 273190 super initialize. 273191 self 273192 layoutInset: 2; 273193 cellInset: 4! ! 273194 273195!PluggableThemedPanelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 14:29'! 273196normalFillStyle 273197 "Return the normal fillStyle of the receiver." 273198 273199 UITheme ifNil: [^self paneColor]. 273200 ^self theme buttonPanelNormalFillStyleFor: self! ! 273201ListItemWrapper subclass: #PluggableTreeItemNode 273202 instanceVariableNames: '' 273203 classVariableNames: '' 273204 poolDictionaries: '' 273205 category: 'ToolBuilder-Morphic'! 273206!PluggableTreeItemNode commentStamp: 'ar 2/12/2005 04:37' prior: 0! 273207Tree item for PluggableTreeMorph.! 273208 273209 273210!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'! 273211acceptDroppingObject: anotherItem 273212 ^model dropNode: anotherItem on: self! ! 273213 273214!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'! 273215asString 273216 ^model printNode: self! ! 273217 273218!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'! 273219balloonText 273220 ^model balloonTextForNode: self! ! 273221 273222!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:02'! 273223canBeDragged 273224 ^model isDraggableNode: self! ! 273225 273226!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:03'! 273227contents 273228 ^model contentsOfNode: self! ! 273229 273230!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'! 273231hasContents 273232 ^model hasNodeContents: self! ! 273233 273234!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:04'! 273235icon 273236 ^model iconOfNode: self! ! 273237 273238!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 01:00'! 273239item 273240 ^item! ! 273241 273242!PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'! 273243wantsDroppedObject: anotherItem 273244 ^model wantsDroppedNode: anotherItem on: self! ! 273245SimpleHierarchicalListMorph subclass: #PluggableTreeMorph 273246 instanceVariableNames: 'roots selectedWrapper getRootsSelector getChildrenSelector hasChildrenSelector getLabelSelector getIconSelector getSelectedPathSelector setSelectedSelector getHelpSelector dropItemSelector wantsDropSelector' 273247 classVariableNames: '' 273248 poolDictionaries: '' 273249 category: 'ToolBuilder-Morphic'! 273250!PluggableTreeMorph commentStamp: 'ar 2/12/2005 04:38' prior: 0! 273251A pluggable tree morph.! 273252 273253 273254!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! 273255dropItemSelector 273256 ^dropItemSelector! ! 273257 273258!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! 273259dropItemSelector: aSymbol 273260 dropItemSelector := aSymbol! ! 273261 273262!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! 273263getChildrenSelector 273264 ^getChildrenSelector! ! 273265 273266!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! 273267getChildrenSelector: aSymbol 273268 getChildrenSelector := aSymbol.! ! 273269 273270!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! 273271getHelpSelector 273272 ^getHelpSelector! ! 273273 273274!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! 273275getHelpSelector: aSymbol 273276 getHelpSelector := aSymbol! ! 273277 273278!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! 273279getIconSelector 273280 ^getIconSelector! ! 273281 273282!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! 273283getIconSelector: aSymbol 273284 getIconSelector := aSymbol! ! 273285 273286!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! 273287getLabelSelector 273288 ^getLabelSelector! ! 273289 273290!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! 273291getLabelSelector: aSymbol 273292 getLabelSelector := aSymbol! ! 273293 273294!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:57'! 273295getMenuSelector 273296 ^getMenuSelector! ! 273297 273298!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:57'! 273299getMenuSelector: aSymbol 273300 getMenuSelector := aSymbol! ! 273301 273302!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! 273303getRootsSelector 273304 ^getRootsSelector! ! 273305 273306!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! 273307getRootsSelector: aSelector 273308 getRootsSelector := aSelector. 273309 self update: getRootsSelector.! ! 273310 273311!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 03:33'! 273312getSelectedPathSelector 273313 ^getSelectedPathSelector! ! 273314 273315!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 03:33'! 273316getSelectedPathSelector: aSymbol 273317 getSelectedPathSelector := aSymbol.! ! 273318 273319!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! 273320hasChildrenSelector 273321 ^hasChildrenSelector! ! 273322 273323!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! 273324hasChildrenSelector: aSymbol 273325 hasChildrenSelector := aSymbol! ! 273326 273327!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:58'! 273328keystrokeActionSelector 273329 ^keystrokeActionSelector! ! 273330 273331!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:58'! 273332keystrokeActionSelector: aSymbol 273333 keystrokeActionSelector := aSymbol! ! 273334 273335!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:22'! 273336roots 273337 ^roots! ! 273338 273339!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 01:11'! 273340roots: anArray 273341 roots := anArray collect:[:item| PluggableTreeItemNode with: item model: self]. 273342 self list: roots.! ! 273343 273344!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! 273345setSelectedSelector 273346 ^setSelectedSelector! ! 273347 273348!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! 273349setSelectedSelector: aSymbol 273350 setSelectedSelector := aSymbol! ! 273351 273352!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! 273353wantsDropSelector 273354 ^wantsDropSelector! ! 273355 273356!PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:27'! 273357wantsDropSelector: aSymbol 273358 wantsDropSelector := aSymbol! ! 273359 273360 273361!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:19'! 273362balloonTextForNode: node 273363 getHelpSelector ifNil:[^nil]. 273364 ^model perform: getHelpSelector with: node item! ! 273365 273366!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 01:13'! 273367contentsOfNode: node 273368 | children | 273369 getChildrenSelector ifNil:[^#()]. 273370 children := model perform: getChildrenSelector with: node item. 273371 ^children collect:[:item| PluggableTreeItemNode with: item model: self]! ! 273372 273373!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:20'! 273374dropNode: srcNode on: dstNode 273375 dropItemSelector ifNil:[^nil]. 273376 model perform: dropItemSelector with: srcNode item with: dstNode item! ! 273377 273378!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:11'! 273379hasNodeContents: node 273380 hasChildrenSelector ifNil:[^node contents isEmpty not]. 273381 ^model perform: hasChildrenSelector with: node item! ! 273382 273383!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:20'! 273384iconOfNode: node 273385 getIconSelector ifNil:[^nil]. 273386 ^model perform: getIconSelector with: node item! ! 273387 273388!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:02'! 273389isDraggableNode: node 273390 ^true! ! 273391 273392!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:20'! 273393printNode: node 273394 getLabelSelector ifNil:[^node item printString]. 273395 ^model perform: getLabelSelector with: node item! ! 273396 273397!PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 7/15/2005 12:11'! 273398wantsDroppedNode: srcNode on: dstNode 273399 dropItemSelector ifNil:[^false]. 273400 wantsDropSelector ifNil:[^true]. 273401 ^(model perform: wantsDropSelector with: srcNode with: dstNode) == true! ! 273402 273403 273404!PluggableTreeMorph methodsFor: 'selection' stamp: 'ar 2/12/2005 01:20'! 273405setSelectedMorph: aMorph 273406 selectedWrapper := aMorph complexContents. 273407 self selection: selectedWrapper. 273408 setSelectedSelector ifNotNil:[ 273409 model 273410 perform: setSelectedSelector 273411 with: (selectedWrapper ifNotNil:[selectedWrapper item]). 273412 ].! ! 273413 273414 273415!PluggableTreeMorph methodsFor: 'updating' stamp: 'ar 2/12/2005 17:29'! 273416selectPath: path in: listItem 273417 path isEmpty ifTrue: [^self setSelectedMorph: nil]. 273418 listItem withSiblingsDo: [:each | 273419 (each complexContents item = path first) ifTrue: [ 273420 each isExpanded ifFalse: [ 273421 each toggleExpandedState. 273422 self adjustSubmorphPositions. 273423 ]. 273424 each changed. 273425 path size = 1 ifTrue: [ 273426 ^self setSelectedMorph: each 273427 ]. 273428 each firstChild ifNil: [^self setSelectedMorph: nil]. 273429 ^self selectPath: path allButFirst in: each firstChild 273430 ]. 273431 ]. 273432 ^self setSelectedMorph: nil 273433 273434! ! 273435 273436!PluggableTreeMorph methodsFor: 'updating' stamp: 'ar 2/12/2005 19:11'! 273437update: what 273438 what ifNil:[^self]. 273439 what == getRootsSelector ifTrue:[ 273440 self roots: (model perform: getRootsSelector) 273441 ]. 273442 what == getSelectedPathSelector ifTrue:[ 273443 ^self selectPath: (model perform: getSelectedPathSelector) 273444 in: (scroller submorphs at: 1 ifAbsent: [^self]) 273445 ]. 273446 ^super update: what! ! 273447PluggableWidgetSpec subclass: #PluggableTreeSpec 273448 instanceVariableNames: 'roots getSelectedPath setSelected getChildren hasChildren label icon help menu keyPress wantsDrop dropItem dropAccept autoDeselect' 273449 classVariableNames: '' 273450 poolDictionaries: '' 273451 category: 'ToolBuilder-Kernel'! 273452!PluggableTreeSpec commentStamp: 'ar 2/12/2005 16:40' prior: 0! 273453A pluggable tree widget. PluggableTrees are slightly different from lists in such that they ALWAYS store the actual objects and use the label selector to query for the label of the item. PluggableTrees also behave somewhat differently in such that they do not have a "getSelected" message but only a getSelectedPath message. The difference is that getSelectedPath is used to indicate by the model that the tree should select the appropriate path. This allows disambiguation of items. Because of this, implementations of PluggableTrees must always set their internal selection directly, e.g., rather than sending the model a setSelected message and wait for an update of the #getSelected the implementation must set the selection before sending the #setSelected message. If a client doesn't want this, it can always just signal a change of getSelectedPath to revert to whatever is needed. 273454 273455Instance variables: 273456 roots <Symbol> The message to retrieve the roots of the tree. 273457 getSelectedPath <Symbol> The message to retrieve the selected path in the tree. 273458 setSelected <Symbol> The message to set the selected item in the tree. 273459 getChildren <Symbol> The message to retrieve the children of an item 273460 hasChildren <Symbol> The message to query for children of an item 273461 label <Symbol> The message to query for the label of an item. 273462 icon <Symbol> The message to query for the icon of an item. 273463 help <Symbol> The message to query for the help of an item. 273464 menu <Symbol> The message to query for the tree's menu 273465 keyPress <Symbol> The message to process a keystroke. 273466 wantsDrop <Symbol> The message to query whether a drop might be accepted. 273467 dropItem <Symbol> The message to drop an item. 273468 autoDeselect <Boolean> Whether the tree should allow automatic deselection or not.! 273469 273470 273471!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 17:38'! 273472autoDeselect 273473 "Answer whether this tree can be automatically deselected" 273474 ^autoDeselect ifNil:[true]! ! 273475 273476!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 16:41'! 273477autoDeselect: aBool 273478 "Indicate whether this tree can be automatically deselected" 273479 autoDeselect := aBool! ! 273480 273481!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 12:09'! 273482dropAccept 273483 "Answer the selector for querying the receiver about accepting drops" 273484 ^dropAccept! ! 273485 273486!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 7/15/2005 12:09'! 273487dropAccept: aSymbol 273488 "Set the selector for querying the receiver about accepting drops" 273489 dropAccept := aSymbol! ! 273490 273491!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:35'! 273492dropItem 273493 "Answer the selector for invoking the tree's dragDrop handler" 273494 ^dropItem! ! 273495 273496!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:35'! 273497dropItem: aSymbol 273498 "Indicate the selector for invoking the tree's dragDrop handler" 273499 dropItem := aSymbol! ! 273500 273501!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:31'! 273502getChildren 273503 "Answer the message to get the children of this tree" 273504 ^getChildren! ! 273505 273506!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:31'! 273507getChildren: aSymbol 273508 "Indicate the message to retrieve the children of this tree" 273509 getChildren := aSymbol! ! 273510 273511!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 03:28'! 273512getSelectedPath 273513 "Answer the message to retrieve the selection of this tree" 273514 ^getSelectedPath! ! 273515 273516!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 03:28'! 273517getSelectedPath: aSymbol 273518 "Indicate the message to retrieve the selection of this tree" 273519 getSelectedPath := aSymbol! ! 273520 273521!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:31'! 273522hasChildren 273523 "Answer the message to get the existence of children in this tree" 273524 ^hasChildren! ! 273525 273526!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:31'! 273527hasChildren: aSymbol 273528 "Indicate the message to retrieve the existence children in this tree" 273529 hasChildren := aSymbol! ! 273530 273531!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:33'! 273532help 273533 "Answer the message to get the help texts of this tree" 273534 ^help! ! 273535 273536!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:33'! 273537help: aSymbol 273538 "Indicate the message to retrieve the help texts of this tree" 273539 help := aSymbol! ! 273540 273541!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:32'! 273542icon 273543 "Answer the message to get the icons of this tree" 273544 ^icon! ! 273545 273546!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:32'! 273547icon: aSymbol 273548 "Indicate the message to retrieve the icon of this tree" 273549 icon := aSymbol! ! 273550 273551!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:34'! 273552keyPress 273553 "Answer the selector for invoking the tree's keyPress handler" 273554 ^keyPress! ! 273555 273556!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:34'! 273557keyPress: aSymbol 273558 "Indicate the selector for invoking the tree's keyPress handler" 273559 keyPress := aSymbol! ! 273560 273561!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:32'! 273562label 273563 "Answer the message to get the labels of this tree" 273564 ^label! ! 273565 273566!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:32'! 273567label: aSymbol 273568 "Indicate the message to retrieve the labels of this tree" 273569 label := aSymbol! ! 273570 273571!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:33'! 273572menu 273573 "Answer the message to get the menus of this tree" 273574 ^menu! ! 273575 273576!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:33'! 273577menu: aSymbol 273578 "Indicate the message to retrieve the menus of this tree" 273579 menu := aSymbol! ! 273580 273581!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:29'! 273582roots 273583 "Answer the message to retrieve the roots of this tree" 273584 ^roots! ! 273585 273586!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:30'! 273587roots: aSymbol 273588 "Indicate the message to retrieve the roots of this tree" 273589 roots := aSymbol! ! 273590 273591!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:30'! 273592setSelected 273593 "Answer the message to set the selection of this tree" 273594 ^setSelected! ! 273595 273596!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:30'! 273597setSelected: aSymbol 273598 "Indicate the message to set the selection of this tree" 273599 setSelected := aSymbol! ! 273600 273601!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:35'! 273602wantsDrop 273603 "Answer the selector for invoking the tree's wantsDrop handler" 273604 ^wantsDrop! ! 273605 273606!PluggableTreeSpec methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:35'! 273607wantsDrop: aSymbol 273608 "Indicate the selector for invoking the tree's wantsDrop handler" 273609 wantsDrop := aSymbol! ! 273610 273611 273612!PluggableTreeSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'! 273613buildWith: builder 273614 ^builder buildPluggableTree: self! ! 273615ToolBuilderSpec subclass: #PluggableWidgetSpec 273616 instanceVariableNames: 'model frame' 273617 classVariableNames: '' 273618 poolDictionaries: '' 273619 category: 'ToolBuilder-Kernel'! 273620!PluggableWidgetSpec commentStamp: 'ar 2/9/2005 18:40' prior: 0! 273621The abstract superclass for all widgets. 273622 273623Instance variables: 273624 model <Object> The object the various requests should be directed to. 273625 frame <Rectangle> The associated layout frame for this object (if any). 273626! 273627 273628 273629!PluggableWidgetSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:26'! 273630frame 273631 "Answer the receiver's layout frame" 273632 ^frame! ! 273633 273634!PluggableWidgetSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:27'! 273635frame: aRectangle 273636 "Indicate the receiver's layout frame" 273637 frame := aRectangle! ! 273638 273639!PluggableWidgetSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:28'! 273640model 273641 "Answer the model for which this widget should be built" 273642 ^model! ! 273643 273644!PluggableWidgetSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:28'! 273645model: aModel 273646 "Indicate the model for which this widget should be built" 273647 model := aModel.! ! 273648PluggableCompositeSpec subclass: #PluggableWindowSpec 273649 instanceVariableNames: 'label extent closeAction' 273650 classVariableNames: '' 273651 poolDictionaries: '' 273652 category: 'ToolBuilder-Kernel'! 273653!PluggableWindowSpec commentStamp: '<historical>' prior: 0! 273654A common window. Expects to see change/update notifications when the label should change. 273655 273656Instance variables: 273657 label <String|Symbol> The selector under which to retrieve the label or the label directly 273658 extent <Point> The (initial) extent of the window. 273659 closeAction <Symbol> The action to perform when the window is closed.! 273660 273661 273662!PluggableWindowSpec methodsFor: 'accessing' stamp: 'ar 9/17/2005 21:00'! 273663closeAction 273664 "Answer the receiver's closeAction" 273665 ^closeAction! ! 273666 273667!PluggableWindowSpec methodsFor: 'accessing' stamp: 'ar 9/17/2005 21:00'! 273668closeAction: aSymbol 273669 "Answer the receiver's closeAction" 273670 closeAction := aSymbol.! ! 273671 273672!PluggableWindowSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:30'! 273673extent 273674 "Answer the window's (initial) extent" 273675 ^extent! ! 273676 273677!PluggableWindowSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:30'! 273678extent: aPoint 273679 "Indicate the window's (initial) extent" 273680 extent := aPoint! ! 273681 273682!PluggableWindowSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:29'! 273683label 273684 "Answer the selector for retrieving the window's label" 273685 ^label! ! 273686 273687!PluggableWindowSpec methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:30'! 273688label: aString 273689 "Indicate the selector for retrieving the window's label" 273690 label := aString! ! 273691 273692 273693!PluggableWindowSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:16'! 273694buildWith: builder 273695 ^builder buildPluggableWindow: self.! ! 273696HTTPDownloadRequest subclass: #PluginHTTPDownloadRequest 273697 instanceVariableNames: 'fileStream' 273698 classVariableNames: '' 273699 poolDictionaries: '' 273700 category: 'System-Download'! 273701!PluginHTTPDownloadRequest commentStamp: '<historical>' prior: 0! 273702HTTPBrowserRequest attempts to fetch the contents through a Webbrowser. This works transparently if Squeak is not running in the browser.! 273703 273704 273705!PluginHTTPDownloadRequest methodsFor: 'accessing' stamp: 'nk 8/30/2004 07:58'! 273706contentStream 273707 semaphore wait. 273708 fileStream 273709 ifNotNil: [^ fileStream]. 273710 ^ content 273711 ifNotNil: [content isString 273712 ifTrue: [self error: 'Error loading ' , self url printString] 273713 ifFalse: [content contentStream]]! ! 273714 273715!PluginHTTPDownloadRequest methodsFor: 'accessing' stamp: 'sd 1/30/2004 15:21'! 273716contents 273717 | | 273718 semaphore wait. 273719 (content isNil and:[fileStream notNil]) ifTrue:[ 273720" pos := fileStream position." 273721 fileStream position: 0. 273722 content := MIMEDocument content: fileStream upToEnd. 273723 fileStream close. 273724 ]. 273725 ^content! ! 273726 273727!PluginHTTPDownloadRequest methodsFor: 'accessing' stamp: 'ar 12/21/1999 16:36'! 273728maxAttempts 273729 "Return the number of attempts to retry before giving up" 273730 ^3! ! 273731 273732!PluginHTTPDownloadRequest methodsFor: 'accessing' stamp: 'sd 1/30/2004 15:21'! 273733signalAbort 273734 fileStream ifNotNil: [ 273735 fileStream close]. 273736 fileStream := nil. 273737 super signalAbort.! ! 273738 273739!PluginHTTPDownloadRequest methodsFor: 'accessing' stamp: 'mir 1/11/2000 11:36'! 273740startRetrieval 273741 | attempts | 273742 attempts := self maxAttempts. 273743 "Note: Only the first request may fail due to not running in a browser" 273744 url first = $/ 273745 ifTrue: [url := url copyFrom: 2 to: url size]. 273746 fileStream := FileStream requestURLStream: url ifError:[^super startRetrieval]. 273747 [fileStream == nil] whileTrue:[ 273748 attempts := attempts - 1. 273749 attempts = 0 ifTrue:[^self content:'Error downloading file']. 273750 fileStream := FileStream requestURLStream: url]. 273751 semaphore signal.! ! 273752Object subclass: #Point 273753 instanceVariableNames: 'x y' 273754 classVariableNames: '' 273755 poolDictionaries: '' 273756 category: 'Graphics-Primitives'! 273757!Point commentStamp: '<historical>' prior: 0! 273758I represent an x-y pair of numbers usually designating a location on the screen.! 273759 273760 273761!Point methodsFor: '*Polymorph-Geometry' stamp: 'gvc 10/31/2006 11:01'! 273762directionToLineFrom: p1 to: p2 273763 "Answer the direction of the line from the receiver 273764 position. 273765 < 0 => left (receiver to right) 273766 = => on line 273767 > 0 => right (receiver to left)." 273768 273769 ^((p2 x - p1 x) * (self y - p1 y)) - 273770 ((self x - p1 x) * (p2 y - p1 y))! ! 273771 273772 273773!Point methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/17/2008 13:36'! 273774angle 273775 "Answer the angle in radians between the vectors represented by 273776 the receiver and (1, 0) from the origin." 273777 273778 ^self y arcTan: self x! ! 273779 273780!Point methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/17/2008 13:36'! 273781angleWith: aPoint 273782 "Answer the angle in radians between the vectors represented by 273783 the receiver and aPoint from the origin." 273784 273785 |ar ap| 273786 ar := self angle. 273787 ap := aPoint angle. 273788 ^ap >= ar 273789 ifTrue: [ap - ar] 273790 ifFalse: [Float pi * 2 - ar + ap]! ! 273791 273792!Point methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/12/2006 10:12'! 273793max 273794 "Answer a number that is the maximum 273795 of the x and y of the receiver." 273796 273797 ^self x max: self y! ! 273798 273799!Point methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/12/2006 10:13'! 273800min 273801 "Answer a number that is the minimum 273802 of the x and y of the receiver." 273803 273804 ^self x min: self y! ! 273805 273806!Point methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/17/2008 13:36'! 273807reflectedAbout: aPoint 273808 "Answer a new point that is the reflection of the receiver about the given point." 273809 273810 ^(self - aPoint) negated + aPoint! ! 273811 273812 273813!Point methodsFor: '*morphic-extent functions' stamp: 'wiz 8/9/2005 02:44'! 273814guarded 273815"Return a positive nonzero extent." 273816self max: 1@1 .! ! 273817 273818!Point methodsFor: '*morphic-extent functions' stamp: 'wiz 9/14/2005 22:41'! 273819scaleTo: anExtent 273820"Return a Point scalefactor for shrinking a thumbnail of the receiver's extent to fit within anExtent" 273821" self and anExtent are expected to have positive nonZero x and y. " 273822| factor sX sY | 273823factor := 3.0 reciprocal . "EccentricityThreshhold reciprical" 273824sX := anExtent x / self x asFloat . 273825sY := anExtent y / self y asFloat . 273826sX = sY ifTrue: [ ^ sX @ sY ] . "Same aspect ratio" 273827^ sX < sY ifTrue: [ sX @ (sX max: sY * factor) ] 273828 ifFalse: [ (sY max: sX * factor ) @ sY ] ! ! 273829 273830 273831!Point methodsFor: '*morphic-truncation and roundoff' stamp: 'nice 2/5/2006 16:43'! 273832ceiling 273833 "Answer a Point that is the receiver's x and y ceiling. Answer the receiver if its coordinates are already integral." 273834 273835 (x isInteger and: [y isInteger]) ifTrue: [^ self]. 273836 ^ x ceiling @ y ceiling 273837! ! 273838 273839!Point methodsFor: '*morphic-truncation and roundoff' stamp: 'nice 2/5/2006 16:43'! 273840floor 273841 "Answer a Point that is the receiver's x and y floor. Answer the receiver if its coordinates are already integral." 273842 273843 (x isInteger and: [y isInteger]) ifTrue: [^ self]. 273844 ^ x floor @ y floor 273845! ! 273846 273847!Point methodsFor: '*morphic-truncation and roundoff' stamp: 'wiz 1/11/2006 18:32'! 273848isIntegerPoint 273849^ x isInteger and: [ y isInteger ] ! ! 273850 273851!Point methodsFor: '*morphic-truncation and roundoff' stamp: 'nice 2/5/2006 16:42'! 273852roundDownTo: grid 273853 "Answer a Point that is the receiver's x and y rounded to grid x and 273854 grid y by lower value (toward negative infinity)." 273855 273856 | gridPoint | 273857 gridPoint := grid asPoint. 273858 ^(x roundDownTo: gridPoint x) @ (y roundDownTo: gridPoint y)! ! 273859 273860!Point methodsFor: '*morphic-truncation and roundoff' stamp: 'nice 2/5/2006 16:41'! 273861roundUpTo: grid 273862 "Answer a Point that is the receiver's x and y rounded to grid x and 273863 grid y by upper value (toward infinity)." 273864 273865 | gridPoint | 273866 gridPoint := grid asPoint. 273867 ^(x roundUpTo: gridPoint x) @ (y roundUpTo: gridPoint y)! ! 273868 273869 273870!Point methodsFor: 'accessing'! 273871x 273872 "Answer the x coordinate." 273873 273874 ^x! ! 273875 273876!Point methodsFor: 'accessing'! 273877y 273878 "Answer the y coordinate." 273879 273880 ^y! ! 273881 273882 273883!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:01'! 273884* arg 273885 "Answer a Point that is the product of the receiver and arg." 273886 273887 arg isPoint ifTrue: [^ (x * arg x) @ (y * arg y)]. 273888 ^ arg adaptToPoint: self andSend: #*! ! 273889 273890!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:01'! 273891+ arg 273892 "Answer a Point that is the sum of the receiver and arg." 273893 273894 arg isPoint ifTrue: [^ (x + arg x) @ (y + arg y)]. 273895 ^ arg adaptToPoint: self andSend: #+! ! 273896 273897!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! 273898- arg 273899 "Answer a Point that is the difference of the receiver and arg." 273900 273901 arg isPoint ifTrue: [^ (x - arg x) @ (y - arg y)]. 273902 ^ arg adaptToPoint: self andSend: #-! ! 273903 273904!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! 273905/ arg 273906 "Answer a Point that is the quotient of the receiver and arg." 273907 273908 arg isPoint ifTrue: [^ (x / arg x) @ (y / arg y)]. 273909 ^ arg adaptToPoint: self andSend: #/! ! 273910 273911!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! 273912// arg 273913 "Answer a Point that is the quotient of the receiver and arg." 273914 273915 arg isPoint ifTrue: [^ (x // arg x) @ (y // arg y)]. 273916 ^ arg adaptToPoint: self andSend: #//! ! 273917 273918!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! 273919\\ arg 273920 "Answer a Point that is the mod of the receiver and arg." 273921 273922 arg isPoint ifTrue: [^ (x \\ arg x) @ (y \\ arg y)]. 273923 ^ arg adaptToPoint: self andSend: #\\! ! 273924 273925!Point methodsFor: 'arithmetic'! 273926abs 273927 "Answer a Point whose x and y are the absolute values of the receiver's x 273928 and y." 273929 273930 ^ x abs @ y abs! ! 273931 273932!Point methodsFor: 'arithmetic' stamp: 'TRee 6/3/2004 11:09'! 273933reciprocal 273934 " Answer a Point with coordinates that are the reciprocals of mine. " 273935 " Method was missing from release. " 273936 " 20040301 20:50:35 TRee(Squeak3.6-5429-tree07.38) " 273937 273938 ^ x reciprocal @ y reciprocal. 273939! ! 273940 273941 273942!Point methodsFor: 'comparing'! 273943< aPoint 273944 "Answer whether the receiver is above and to the left of aPoint." 273945 273946 ^x < aPoint x and: [y < aPoint y]! ! 273947 273948!Point methodsFor: 'comparing'! 273949<= aPoint 273950 "Answer whether the receiver is neither below nor to the right of aPoint." 273951 273952 ^x <= aPoint x and: [y <= aPoint y]! ! 273953 273954!Point methodsFor: 'comparing'! 273955= aPoint 273956 273957 self species = aPoint species 273958 ifTrue: [^x = aPoint 273959 "Refer to the comment in Object|=." x and: [y = aPoint y]] 273960 ifFalse: [^false]! ! 273961 273962!Point methodsFor: 'comparing'! 273963> aPoint 273964 "Answer whether the receiver is below and to the right of aPoint." 273965 273966 ^x > aPoint x and: [y > aPoint y]! ! 273967 273968!Point methodsFor: 'comparing'! 273969>= aPoint 273970 "Answer whether the receiver is neither above nor to the left of aPoint." 273971 273972 ^x >= aPoint x and: [y >= aPoint y]! ! 273973 273974!Point methodsFor: 'comparing' stamp: 'SqR 11/3/2000 17:08'! 273975hash 273976 "Hash is reimplemented because = is implemented." 273977 273978 ^(x hash hashMultiply + y hash) hashMultiply! ! 273979 273980!Point methodsFor: 'comparing'! 273981max: aPoint 273982 "Answer the lower right corner of the rectangle uniquely defined by the 273983 receiver and the argument, aPoint." 273984 273985 ^ (x max: aPoint x) @ (y max: aPoint y)! ! 273986 273987!Point methodsFor: 'comparing'! 273988min: aPoint 273989 "Answer the upper left corner of the rectangle uniquely defined by the 273990 receiver and the argument, aPoint." 273991 273992 ^ (x min: aPoint x) @ (y min: aPoint y)! ! 273993 273994!Point methodsFor: 'comparing'! 273995min: aMin max: aMax 273996 273997 ^ (self min: aMin) max: aMax! ! 273998 273999 274000!Point methodsFor: 'converting' stamp: 'di 11/6/1998 13:45'! 274001adaptToCollection: rcvr andSend: selector 274002 "If I am involved in arithmetic with a Collection, return a Collection of 274003 the results of each element combined with me in that expression." 274004 274005 ^ rcvr collect: [:element | element perform: selector with: self]! ! 274006 274007!Point methodsFor: 'converting' stamp: 'di 11/9/1998 12:44'! 274008adaptToNumber: rcvr andSend: selector 274009 "If I am involved in arithmetic with an Integer, convert it to a Point." 274010 ^ rcvr@rcvr perform: selector with: self! ! 274011 274012!Point methodsFor: 'converting' stamp: 'di 11/6/1998 13:47'! 274013adaptToString: rcvr andSend: selector 274014 "If I am involved in arithmetic with a String, convert it to a Number." 274015 ^ rcvr asNumber perform: selector with: self! ! 274016 274017!Point methodsFor: 'converting'! 274018asFloatPoint 274019 ^ x asFloat @ y asFloat! ! 274020 274021!Point methodsFor: 'converting'! 274022asIntegerPoint 274023 ^ x asInteger @ y asInteger! ! 274024 274025!Point methodsFor: 'converting' stamp: 'wiz 11/25/2004 12:48'! 274026asNonFractionalPoint 274027(x isFraction or: [y isFraction]) 274028 ifTrue:[^ x asFloat @ y asFloat]! ! 274029 274030!Point methodsFor: 'converting'! 274031asPoint 274032 "Answer the receiver itself." 274033 274034 ^self! ! 274035 274036!Point methodsFor: 'converting'! 274037corner: aPoint 274038 "Answer a Rectangle whose origin is the receiver and whose corner is 274039 aPoint. This is one of the infix ways of expressing the creation of a 274040 rectangle." 274041 274042 ^Rectangle origin: self corner: aPoint! ! 274043 274044!Point methodsFor: 'converting'! 274045extent: aPoint 274046 "Answer a Rectangle whose origin is the receiver and whose extent is 274047 aPoint. This is one of the infix ways of expressing the creation of a 274048 rectangle." 274049 274050 ^Rectangle origin: self extent: aPoint! ! 274051 274052!Point methodsFor: 'converting' stamp: 'di 11/6/1998 07:45'! 274053isPoint 274054 ^ true! ! 274055 274056!Point methodsFor: 'converting' stamp: 'di 12/3/97 19:00'! 274057rect: aPoint 274058 "Answer a Rectangle that encompasses the receiver and aPoint. 274059 This is the most general infix way to create a rectangle." 274060 274061 ^ Rectangle 274062 origin: (self min: aPoint) 274063 corner: (self max: aPoint)! ! 274064 274065 274066!Point methodsFor: 'copying'! 274067deepCopy 274068 "Implemented here for better performance." 274069 274070 ^x deepCopy @ y deepCopy! ! 274071 274072!Point methodsFor: 'copying' stamp: 'tk 8/19/1998 16:05'! 274073veryDeepCopyWith: deepCopier 274074 "Return self. I am immutable in the Morphic world. Do not record me."! ! 274075 274076 274077!Point methodsFor: 'geometry' stamp: 'laza 1/24/2000 03:44'! 274078isInsideCircle: a with: b with: c 274079 "Returns TRUE if self is inside the circle defined by the 274080 points a, b, c. See Guibas and Stolfi (1985) p.107" 274081 ^ (a dotProduct: a) 274082 * (b triangleArea: c with: self) - ((b dotProduct: b) 274083 * (a triangleArea: c with: self)) + ((c dotProduct: c) 274084 * (a triangleArea: b with: self)) - ((self dotProduct: self) 274085 * (a triangleArea: b with: c)) > 0.0! ! 274086 274087!Point methodsFor: 'geometry' stamp: 'lr 7/4/2009 10:42'! 274088sideOf: otherPoint 274089 "Returns #left, #right or #center if the otherPoint lies to the left, right 274090 or on the line given by the vector from 0@0 to self" 274091 | side | 274092 side := (self crossProduct: otherPoint) sign. 274093 ^ { #right. #center. #left } at: side + 2! ! 274094 274095!Point methodsFor: 'geometry' stamp: 'lr 7/4/2009 10:42'! 274096to: end1 intersects: start2 to: end2 274097 "Returns true if the linesegment from start1 (=self) to end1 intersects 274098 with the segment from start2 to end2, otherwise false." 274099 | start1 sideStart sideEnd | 274100 start1 := self. 274101 (((start1 = start2 or: [ end1 = end2 ]) or: [ start1 = end2 ]) or: [ start2 = end1 ]) ifTrue: [ ^ true ]. 274102 sideStart := start1 274103 to: end1 274104 sideOf: start2. 274105 sideEnd := start1 274106 to: end1 274107 sideOf: end2. 274108 sideStart = sideEnd ifTrue: [ ^ false ]. 274109 sideStart := start2 274110 to: end2 274111 sideOf: start1. 274112 sideEnd := start2 274113 to: end2 274114 sideOf: end1. 274115 sideStart = sideEnd ifTrue: [ ^ false ]. 274116 ^ true! ! 274117 274118!Point methodsFor: 'geometry' stamp: 'laza 1/5/2000 11:50'! 274119to: end sideOf: otherPoint 274120 "Returns #left, #right, #center if the otherPoint lies to the left, right or on the line given by the vector from self to end" 274121 ^ end - self sideOf: otherPoint - self! ! 274122 274123!Point methodsFor: 'geometry' stamp: 'laza 1/17/2000 15:47'! 274124triangleArea: b with: c 274125 "Returns twice the area of the oriented triangle (a, b, c), i.e., the 274126 area is positive if the triangle is oriented counterclockwise" 274127 ^ b x - self x * (c y - self y) - (b y - self y * (c x - self x))! ! 274128 274129 274130!Point methodsFor: 'interpolating' stamp: 'jsp 3/22/1999 16:31'! 274131interpolateTo: end at: amountDone 274132 "Interpolate between the instance and end after the specified amount has been done (0 - 1)." 274133 274134 ^ self + ((end - self) * amountDone).! ! 274135 274136 274137!Point methodsFor: 'point functions' stamp: 'FBS 1/5/2004 13:08'! 274138bearingToPoint: anotherPoint 274139 "Return the bearing, in degrees, from the receiver to anotherPoint. 274140 Adapted from Playground, where the ultimate provenance of the algorithm was a wild earlier method of Jay Fenton's which I never checked carefully, but the thing has always seemed to work" 274141 274142 | deltaX deltaY | 274143 deltaX := anotherPoint x - x. 274144 deltaY := anotherPoint y - y. 274145 274146 deltaX abs < 0.001 274147 ifTrue: 274148 [^ deltaY > 0 ifTrue: [180] ifFalse: [0]]. 274149 274150 ^ ((deltaX >= 0 ifTrue: [90] ifFalse: [270]) 274151 - ((deltaY / deltaX) arcTan negated radiansToDegrees)) rounded 274152! ! 274153 274154!Point methodsFor: 'point functions' stamp: 'ar 10/30/1998 03:05'! 274155crossProduct: aPoint 274156 "Answer a number that is the cross product of the receiver and the 274157 argument, aPoint." 274158 274159 ^ (x * aPoint y) - (y * aPoint x)! ! 274160 274161!Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! 274162dist: aPoint 274163 "Answer the distance between aPoint and the receiver." 274164 | dx dy | 274165 dx := aPoint x - x. 274166 dy := aPoint y - y. 274167 ^ (dx * dx + (dy * dy)) sqrt! ! 274168 274169!Point methodsFor: 'point functions' stamp: 'di 9/11/1998 16:22'! 274170dotProduct: aPoint 274171 "Answer a number that is the dot product of the receiver and the 274172 argument, aPoint. That is, the two points are multipled and the 274173 coordinates of the result summed." 274174 274175 ^ (x * aPoint x) + (y * aPoint y)! ! 274176 274177!Point methodsFor: 'point functions'! 274178eightNeighbors 274179 ^ (Array with: self + (1@0) 274180 with: self + (1@1) 274181 with: self + (0@1) 274182 with: self + (-1@1)) , 274183 (Array with: self + (-1@0) 274184 with: self + (-1@-1) 274185 with: self + (0@-1) 274186 with: self + (1@-1)) 274187! ! 274188 274189!Point methodsFor: 'point functions' stamp: 'di 6/11/97 16:08'! 274190flipBy: direction centerAt: c 274191 "Answer a Point which is flipped according to the direction about the point c. 274192 Direction must be #vertical or #horizontal." 274193 direction == #vertical ifTrue: [^ x @ (c y * 2 - y)]. 274194 direction == #horizontal ifTrue: [^ (c x * 2 - x) @ y]. 274195 self error: 'unrecognizable direction'! ! 274196 274197!Point methodsFor: 'point functions'! 274198fourNeighbors 274199 ^ Array with: self + (1@0) 274200 with: self + (0@1) 274201 with: self + (-1@0) 274202 with: self + (0@-1) 274203! ! 274204 274205!Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! 274206grid: aPoint 274207 "Answer a Point to the nearest rounded grid modules specified by aPoint." 274208 | newX newY | 274209 newX := x + (aPoint x // 2) truncateTo: aPoint x. 274210 newY := y + (aPoint y // 2) truncateTo: aPoint y. 274211 ^ newX @ newY! ! 274212 274213!Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! 274214insideTriangle: p1 with: p2 with: p3 274215 "Return true if the receiver is within the triangle defined by the three coordinates. 274216 Note: This method computes the barycentric coordinates for the receiver and tests those coordinates." 274217 | p0 b0 b1 b2 b3 | 274218 p0 := self. 274219 b0 := (p2 x - p1 x) * (p3 y - p1 y) - ((p3 x - p1 x) * (p2 y - p1 y)). 274220 b0 isZero ifTrue: [ ^ false ]. "degenerate" 274221 b0 := 1.0 / b0. 274222 b1 := ((p2 x - p0 x) * (p3 y - p0 y) - ((p3 x - p0 x) * (p2 y - p0 y))) * b0. 274223 b2 := ((p3 x - p0 x) * (p1 y - p0 y) - ((p1 x - p0 x) * (p3 y - p0 y))) * b0. 274224 b3 := ((p1 x - p0 x) * (p2 y - p0 y) - ((p2 x - p0 x) * (p1 y - p0 y))) * b0. 274225 b1 < 0.0 ifTrue: [ ^ false ]. 274226 b2 < 0.0 ifTrue: [ ^ false ]. 274227 b3 < 0.0 ifTrue: [ ^ false ]. 274228 ^ true! ! 274229 274230!Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! 274231nearestPointAlongLineFrom: p1 to: p2 274232 "Note this will give points beyond the endpoints. 274233 Streamlined by Gerardo Richarte 11/3/97" 274234 | x21 y21 t x1 y1 | 274235 p1 x = p2 x ifTrue: [ ^ p1 x @ y ]. 274236 p1 y = p2 y ifTrue: [ ^ x @ p1 y ]. 274237 x1 := p1 x asFloat. 274238 y1 := p1 y asFloat. 274239 x21 := p2 x asFloat - x1. 274240 y21 := p2 y asFloat - y1. 274241 t := ((y asFloat - y1) / x21 + ((x asFloat - x1) / y21)) / (x21 / y21 + (y21 / x21)). 274242 ^ (x1 + (t * x21)) @ (y1 + (t * y21)) 274243 " 274244 | old new | 274245 Pen new place: 200@100; goto: (old _ 500@300). 274246 Display reverse: (old extent: 10@10). 274247 [Sensor anyButtonPressed] whileFalse: 274248 [(new _ (Sensor cursorPoint nearestPointAlongLineFrom: 200@100 to: 500@300) ) 274249 = old ifFalse: 274250 [Display reverse: (old extent: 10@10). 274251 Display reverse: ((old _ new) extent: 10@10)]] 274252"! ! 274253 274254!Point methodsFor: 'point functions' stamp: 'di 12/1/97 12:40'! 274255nearestPointOnLineFrom: p1 to: p2 274256 "This will not give points beyond the endpoints" 274257 ^ (self nearestPointAlongLineFrom: p1 to: p2) 274258 adhereTo: (p1 rect: p2)! ! 274259 274260!Point methodsFor: 'point functions' stamp: 'Alexandre.Bergel 3/11/2009 10:28'! 274261normal 274262 "Answer a Point representing the unit vector rotated 90 deg clockwise." 274263 274264 | n | 274265 n := y negated @ x. 274266 ^n / (n x * n x + (n y * n y)) sqrt! ! 274267 274268!Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! 274269normalized 274270 "Optimized for speed -- ar 8/26/2001" 274271 | r | 274272 r := (x * x + (y * y)) sqrt. 274273 ^ (x / r) @ (y / r)! ! 274274 274275!Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! 274276octantOf: otherPoint 274277 "Return 1..8 indicating relative direction to otherPoint. 274278 1=ESE, 2=SSE, ... etc. clockwise to 8=ENE" 274279 "[Sensor anyButtonPressed] whileFalse: [(Display boundingBox center 274280 octantOf: Sensor cursorPoint) printString displayAt: 0@0]" 274281 | quad moreHoriz | 274282 (x = otherPoint x and: [ y > otherPoint y ]) ifTrue: [ ^ 6 ]. 274283 "special case" 274284 (y = otherPoint y and: [ x < otherPoint x ]) ifTrue: [ ^ 8 ]. 274285 quad := self quadrantOf: otherPoint. 274286 moreHoriz := (x - otherPoint x) abs >= (y - otherPoint y) abs. 274287 (quad even eqv: moreHoriz) 274288 ifTrue: [ ^ quad * 2 ] 274289 ifFalse: [ ^ quad * 2 - 1 ]! ! 274290 274291!Point methodsFor: 'point functions' stamp: 'di 12/1/97 12:12'! 274292onLineFrom: p1 to: p2 274293 ^ self onLineFrom: p1 to: p2 within: 2! ! 274294 274295!Point methodsFor: 'point functions' stamp: 'jm 2/24/98 08:34'! 274296onLineFrom: p1 to: p2 within: epsilon 274297 "Answer true if the receiver lies on the given line segment between p1 and p2 within a small epsilon." 274298 274299 "is this point within the box spanning p1 and p2 expanded by epsilon? (optimized)" 274300 p1 x < p2 x 274301 ifTrue: [ 274302 ((x < (p1 x - epsilon)) or: [x > (p2 x + epsilon)]) ifTrue: [^ false]] 274303 ifFalse: [ 274304 ((x < (p2 x - epsilon)) or: [x > (p1 x + epsilon)]) ifTrue: [^ false]]. 274305 p1 y < p2 y 274306 ifTrue: [ 274307 ((y < (p1 y - epsilon)) or: [y > (p2 y + epsilon)]) ifTrue: [^ false]] 274308 ifFalse: [ 274309 ((y < (p2 y - epsilon)) or: [y > (p1 y + epsilon)]) ifTrue: [^ false]]. 274310 274311 "it's in the box; is it on the line?" 274312 ^ (self dist: (self nearestPointAlongLineFrom: p1 to: p2)) <= epsilon! ! 274313 274314!Point methodsFor: 'point functions' stamp: '6/9/97 14:51 di'! 274315quadrantOf: otherPoint 274316 "Return 1..4 indicating relative direction to otherPoint. 274317 1 is downRight, 2=downLeft, 3=upLeft, 4=upRight" 274318 ^ x <= otherPoint x 274319 ifTrue: [y < otherPoint y ifTrue: [1] ifFalse: [4]] 274320 ifFalse: [y <= otherPoint y ifTrue: [2] ifFalse: [3]] 274321" 274322[Sensor anyButtonPressed] whileFalse: 274323 [(Display boundingBox center quadrantOf: Sensor cursorPoint) printString displayAt: 0@0] 274324"! ! 274325 274326!Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! 274327rotateBy: direction centerAt: c 274328 "Answer a Point which is rotated according to direction, about the point c. 274329 Direction must be one of #right (CW), #left (CCW) or #pi (180 degrees)." 274330 | offset | 274331 offset := self - c. 274332 direction == #right ifTrue: [ ^ offset y negated @ offset x + c ]. 274333 direction == #left ifTrue: [ ^ offset y @ offset x negated + c ]. 274334 direction == #pi ifTrue: [ ^ c - offset ]. 274335 self error: 'unrecognizable direction'! ! 274336 274337!Point methodsFor: 'point functions' stamp: 'ar 4/18/1999 05:17'! 274338sortsBefore: otherPoint 274339 "Return true if the receiver sorts before the other point" 274340 ^y = otherPoint y 274341 ifTrue:[x <= otherPoint x] 274342 ifFalse:[y <= otherPoint y]! ! 274343 274344!Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! 274345squaredDistanceTo: aPoint 274346 "Answer the distance between aPoint and the receiver." 274347 | delta | 274348 delta := aPoint - self. 274349 ^ delta dotProduct: delta! ! 274350 274351!Point methodsFor: 'point functions' stamp: 'ar 11/12/1998 01:44'! 274352transposed 274353 ^y@x! ! 274354 274355 274356!Point methodsFor: 'polar coordinates' stamp: 'lr 7/4/2009 10:42'! 274357degrees 274358 "Answer the angle the receiver makes with origin in degrees. right is 0; down is 90." 274359 | tan theta | 274360 x = 0 274361 ifTrue: 274362 [ y >= 0 274363 ifTrue: [ ^ 90.0 ] 274364 ifFalse: [ ^ 270.0 ] ] 274365 ifFalse: 274366 [ tan := y asFloat / x asFloat. 274367 theta := tan arcTan. 274368 x >= 0 274369 ifTrue: 274370 [ y >= 0 274371 ifTrue: [ ^ theta radiansToDegrees ] 274372 ifFalse: [ ^ 360.0 + theta radiansToDegrees ] ] 274373 ifFalse: [ ^ 180.0 + theta radiansToDegrees ] ]! ! 274374 274375!Point methodsFor: 'polar coordinates'! 274376r 274377 "Answer the receiver's radius in polar coordinate system." 274378 274379 ^(self dotProduct: self) sqrt! ! 274380 274381!Point methodsFor: 'polar coordinates' stamp: 'hk 11/10/2005 10:07'! 274382theta 274383 "Answer the angle the receiver makes with origin in radians. right is 0; 274384 down is 90. 274385 Corrected the constants from single precision to 64 Bit precision 274386 and changed the sends in case of overflow to constants HK 2005-07-23" 274387 274388 | tan theta | 274389 x = 0 274390 ifTrue: [y >= 0 274391 ifTrue: [^ 1.570796326794897 "90.0 degreesToRadians"] 274392 ifFalse: [^ 4.71238898038469 "270.0 degreesToRadians"]] 274393 ifFalse: 274394 [tan := y asFloat / x asFloat. 274395 theta := tan arcTan. 274396 x >= 0 274397 ifTrue: [y >= 0 274398 ifTrue: [^theta] 274399 ifFalse: [^"360.0 degreesToRadians" 6.283185307179586 + theta]] 274400 ifFalse: [^"180.0 degreesToRadians" 3.141592653589793 + theta]]! ! 274401 274402 274403!Point methodsFor: 'printing' stamp: 'sw 9/27/2001 17:26'! 274404basicType 274405 "Answer a symbol representing the inherent type of the receiver" 274406 274407 ^ #Point! ! 274408 274409!Point methodsFor: 'printing'! 274410printOn: aStream 274411 "The receiver prints on aStream in terms of infix notation." 274412 274413 x printOn: aStream. 274414 aStream nextPut: $@. 274415 y printOn: aStream! ! 274416 274417!Point methodsFor: 'printing' stamp: 'ar 7/8/2006 19:15'! 274418storeOn: aStream 274419 "x@y printed form is good for storing too" 274420 aStream nextPut: $(. 274421 self printOn: aStream. 274422 aStream nextPut: $). 274423! ! 274424 274425 274426!Point methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:48'! 274427isSelfEvaluating 274428 ^ self class == Point! ! 274429 274430 274431!Point methodsFor: 'testing' stamp: 'ar 10/29/2000 19:02'! 274432isZero 274433 ^x isZero and:[y isZero]! ! 274434 274435 274436!Point methodsFor: 'transforming' stamp: 'di 4/30/1998 11:16'! 274437adhereTo: aRectangle 274438 "If the receiver lies outside aRectangle, return the nearest point on the boundary of the rectangle, otherwise return self." 274439 274440 (aRectangle containsPoint: self) ifTrue: [^ self]. 274441 ^ ((x max: aRectangle left) min: aRectangle right) 274442 @ ((y max: aRectangle top) min: aRectangle bottom)! ! 274443 274444!Point methodsFor: 'transforming' stamp: 'ar 8/26/2001 22:14'! 274445negated 274446 "Answer a point whose x and y coordinates are the negatives of those of the receiver. 6/6/96 sw" 274447 "Optimized for speed -- ar 8/26/2001" 274448 ^ (0 - x) @ (0 - y)! ! 274449 274450!Point methodsFor: 'transforming' stamp: 'lr 7/4/2009 10:42'! 274451rotateBy: angle about: center 274452 "Even though Point.theta is measured CW, this rotates with the more conventional CCW interpretateion of angle." 274453 | p r theta | 274454 p := self - center. 274455 r := p r. 274456 theta := angle asFloat - p theta. 274457 ^ (center x asFloat + (r * theta cos)) @ (center y asFloat - (r * theta sin))! ! 274458 274459!Point methodsFor: 'transforming'! 274460scaleBy: factor 274461 "Answer a Point scaled by factor (an instance of Point)." 274462 274463 ^(factor x * x) @ (factor y * y)! ! 274464 274465!Point methodsFor: 'transforming' stamp: 'di 12/4/97 14:34'! 274466scaleFrom: rect1 to: rect2 274467 "Produce a point stretched according to the stretch from rect1 to rect2" 274468 ^ rect2 topLeft + (((x-rect1 left) * rect2 width // rect1 width) 274469 @ ((y-rect1 top) * rect2 height // rect1 height))! ! 274470 274471!Point methodsFor: 'transforming'! 274472translateBy: delta 274473 "Answer a Point translated by delta (an instance of Point)." 274474 274475 ^(delta x + x) @ (delta y + y)! ! 274476 274477 274478!Point methodsFor: 'truncation and round off' stamp: 'jm 6/3/1998 12:21'! 274479rounded 274480 "Answer a Point that is the receiver's x and y rounded. Answer the receiver if its coordinates are already integral." 274481 274482 (x isInteger and: [y isInteger]) ifTrue: [^ self]. 274483 ^ x rounded @ y rounded 274484! ! 274485 274486!Point methodsFor: 'truncation and round off' stamp: 'nice 2/5/2006 16:35'! 274487roundTo: grid 274488 "Answer a Point that is the receiver's x and y rounded to grid x and 274489 grid y." 274490 274491 | gridPoint | 274492 gridPoint := grid asPoint. 274493 ^(x roundTo: gridPoint x) @ (y roundTo: gridPoint y)! ! 274494 274495!Point methodsFor: 'truncation and round off' stamp: 'lr 7/4/2009 10:42'! 274496truncateTo: grid 274497 "Answer a Point that is the receiver's x and y truncated to grid x and 274498 grid y." 274499 | gridPoint | 274500 gridPoint := grid asPoint. 274501 ^ (x truncateTo: gridPoint x) @ (y truncateTo: gridPoint y)! ! 274502 274503!Point methodsFor: 'truncation and round off' stamp: 'jm 5/29/1998 15:53'! 274504truncated 274505 "Answer a Point whose x and y coordinates are integers. Answer the receiver if its coordinates are already integral." 274506 274507 (x isInteger and: [y isInteger]) ifTrue: [^ self]. 274508 ^ x truncated @ y truncated 274509! ! 274510 274511 274512!Point methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 274513bitShiftPoint: bits 274514 x := x bitShift: bits. 274515 y := y bitShift: bits! ! 274516 274517!Point methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 274518setR: rho degrees: degrees 274519 | radians | 274520 radians := degrees asFloat degreesToRadians. 274521 x := rho asFloat * radians cos. 274522 y := rho asFloat * radians sin! ! 274523 274524!Point methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 274525setX: xValue setY: yValue 274526 x := xValue. 274527 y := yValue! ! 274528 274529"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 274530 274531Point class 274532 instanceVariableNames: ''! 274533 274534!Point class methodsFor: 'instance creation' stamp: 'sw 9/20/97 15:34'! 274535fromUser 274536 Sensor waitNoButton. 274537 Cursor crossHair show. 274538 Sensor waitButton. 274539 Cursor normal show. 274540 ^ Sensor cursorPoint 274541 274542"Point fromUser"! ! 274543 274544!Point class methodsFor: 'instance creation' stamp: 'wiz 5/4/2006 00:04'! 274545fromUserWithCursor: aCursor 274546 Sensor waitNoButton. 274547 aCursor showWhile:[Sensor waitButton]. 274548 ^ Sensor cursorPoint 274549 274550"Point fromUserWithCursor: Cursor target"! ! 274551 274552!Point class methodsFor: 'instance creation' stamp: 'md 12/2/2004 23:44'! 274553r: rho degrees: degrees 274554 "Answer an instance of me with polar coordinates rho and theta." 274555 274556 ^self basicNew setR: rho degrees: degrees! ! 274557 274558!Point class methodsFor: 'instance creation' stamp: 'md 12/2/2004 23:44'! 274559x: xInteger y: yInteger 274560 "Answer an instance of me with coordinates xInteger and yInteger." 274561 274562 ^self basicNew setX: xInteger setY: yInteger! ! 274563IntegerArray variableWordSubclass: #PointArray 274564 instanceVariableNames: '' 274565 classVariableNames: '' 274566 poolDictionaries: '' 274567 category: 'Balloon-Collections'! 274568!PointArray commentStamp: '<historical>' prior: 0! 274569This class stores 32bit Integer points in place. It is used to pass data efficiently to the primitive level during high-bandwidth 2D graphics operations.! 274570 274571 274572!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:21'! 274573at: index 274574 "Return the element (e.g., point) at the given index" 274575 ^(super at: index * 2 - 1) @ (super at: index * 2)! ! 274576 274577!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:21'! 274578at: index put: aPoint 274579 "Store the argument aPoint at the given index" 274580 super at: index * 2 - 1 put: aPoint x asInteger. 274581 super at: index * 2 put: aPoint y asInteger. 274582 ^aPoint! ! 274583 274584!PointArray methodsFor: 'accessing' stamp: 'ar 11/10/1998 19:41'! 274585bounds 274586 | min max | 274587 min := max := self at: 1. 274588 self do:[:pt| 274589 min := min min: pt. 274590 max := max max: pt]. 274591 ^min corner: max 274592 ! ! 274593 274594!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! 274595defaultElement 274596 "Return the default element of the receiver" 274597 ^0@0! ! 274598 274599!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:21'! 274600size 274601 "Return the number of elements in the receiver" 274602 ^super size // 2! ! 274603 274604 274605!PointArray methodsFor: 'converting' stamp: 'NS 5/30/2001 20:54'! 274606asPointArray 274607 ^ self! ! 274608 274609"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 274610 274611PointArray class 274612 instanceVariableNames: ''! 274613 274614!PointArray class methodsFor: 'instance creation' stamp: 'ar 10/16/1998 00:04'! 274615new: n 274616 ^super new: n*2! ! 274617ClassTestCase subclass: #PointTest 274618 instanceVariableNames: '' 274619 classVariableNames: '' 274620 poolDictionaries: '' 274621 category: 'GraphicsTests-Primitives'! 274622!PointTest commentStamp: '<historical>' prior: 0! 274623This is the unit test for the class Point. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 274624 - http://www.c2.com/cgi/wiki?UnitTest 274625 - http://minnow.cc.gatech.edu/squeak/1547 274626 - the sunit class category! 274627 274628 274629!PointTest methodsFor: 'testing - testing' stamp: 'hk 11/10/2005 10:09'! 274630testTheta 274631 | result dir tan x y | 274632 self assert: ((0@1) theta - 90.0 degreesToRadians) abs < 1e-15. 274633 self assert: ((0@-1) theta - 270.0 degreesToRadians) abs < 1e-15. 274634 " See code of old and new theta" 274635 x := 1.0 . y := -1.0. 274636 tan := y / x . 274637 dir := tan arcTan. 274638 result := 360.0 degreesToRadians + dir. 274639 self assert: ((x@y) theta - result) abs < 1e-15. 274640 x := -1.0. "Don't reuse old results whenyou want numeric precision!!" 274641 tan := y / x . 274642 dir := tan arcTan. 274643 result := 180.0 degreesToRadians + dir. 274644 self assert: ((x@y) theta - result) abs < 1e-15. 274645 274646 ! ! 274647 274648 274649!PointTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 10:16'! 274650testBearingToPoint 274651 274652 self assert: (0@0 bearingToPoint: 0@0) = 0. 274653 self assert: (0@0 bearingToPoint: 0@-1) = 0. 274654 self assert: (0@0 bearingToPoint: 1@0) = 90. 274655 self assert: (0@0 bearingToPoint: 0@1) = 180. 274656 self assert: (0@0 bearingToPoint: -1@0) = 270. 274657 self assert: (0@0 bearingToPoint: 1@1) = 135. 274658 self assert: (0@0 bearingToPoint: 0.01@0) = 90. 274659 self assert: (0@0 bearingToPoint: -2@-3) = 326. 274660 self assert: (0@0 bearingToPoint: -0@0) = 0. 274661 274662 self assert: (-2@-3 bearingToPoint: 0@0) = 146.! ! 274663 274664!PointTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 10:16'! 274665testIsZero 274666 274667 self assert: (0@0) isZero. 274668 self deny: (0@1) isZero. 274669 self deny: (1@0) isZero. 274670 self deny: (1@1) isZero.! ! 274671ObjectExplorer subclass: #PointerExplorer 274672 instanceVariableNames: '' 274673 classVariableNames: '' 274674 poolDictionaries: '' 274675 category: 'Tools-Explorer'! 274676!PointerExplorer commentStamp: 'avi 8/21/2004 20:01' prior: 0! 274677A variant on the ObjectExlorer that works "backwards": like the ObjectExplorer, it shows a tree of objects, but expanding a node won't show the objects which that node references, but rather the objects that reference that node. Its main use is to track down memory leaks: if you want to know why a particular object is still alive, open a PointerExplorer on it and drill down until you find the root object that's referencing it. For example, find all the references to the symbol #zot with: 274678 274679PointerExplorer new openExplorerFor: #zot 274680 274681For the "name" of the object, the PointerExplorer shows each object's identityHash, to allow the user to identify when two similar objects are identical and notice cycles.! 274682 274683 274684!PointerExplorer methodsFor: 'accessing' stamp: 'ab 8/22/2003 18:51'! 274685getList 274686 ^Array with: (PointerExplorerWrapper with: rootObject name: rootObject identityHash asString model: self) 274687! ! 274688ObjectExplorerWrapper subclass: #PointerExplorerWrapper 274689 instanceVariableNames: '' 274690 classVariableNames: '' 274691 poolDictionaries: '' 274692 category: 'Tools-Explorer'! 274693!PointerExplorerWrapper commentStamp: 'avi 8/21/2004 19:58' prior: 0! 274694A subclass of ObjectExplorerWrapper for use with PointerExplorer. #contents is overridden to work backwards: it returns wrappers for the objects pointing to item rather than for the objects that item points to.! 274695 274696 274697!PointerExplorerWrapper methodsFor: 'accessing' stamp: 'Alexandre.Bergel 7/4/2009 11:10'! 274698contents 274699 | objects | 274700 objects := PointerFinder pointersTo: item except: (Array with: self with: model). 274701 ^(objects reject: [:ea | ea class = self class]) 274702 collect: [:ea| self class with: ea name: ea identityHash asString model: item]! ! 274703 274704 274705!PointerExplorerWrapper methodsFor: 'testing' stamp: 'ab 8/22/2003 18:39'! 274706hasContents 274707 ^true! ! 274708Model subclass: #PointerFinder 274709 instanceVariableNames: 'goal parents toDo toDoNext hasGemStone pointerList objectList parentsSize todoSize depth pointerListIndex' 274710 classVariableNames: '' 274711 poolDictionaries: '' 274712 category: 'Tools-Debugger'! 274713!PointerFinder commentStamp: '<historical>' prior: 0! 274714I can search for reasons why a certain object isn't garbage collected. I'm a quick port of a VisualWorks program written by Hans-Martin Mosner. Call me as shown below. I'll search for a path from a global variable to the given object, presenting it in a small morphic UI. 274715 274716Examples: 274717 PointerFinder on: self currentHand 274718 PointerFinder on: StandardSystemView someInstance 274719 274720Now, let's see why this image contains more HandMorphs as expected... 274721 274722HandMorph allInstancesDo: [:e | PointerFinder on: e]! 274723 274724 274725!PointerFinder methodsFor: 'application' stamp: 'bf 2/12/2006 15:38'! 274726buildList 274727 | list obj parent object key | 274728 list := OrderedCollection new. 274729 obj := goal. 274730 274731 [list addFirst: obj. 274732 obj := parents at: obj ifAbsent: []. 274733 obj == nil] whileFalse. 274734 list removeFirst. 274735 parent := Smalltalk. 274736 objectList := OrderedCollection new. 274737 pointerList := OrderedCollection new. 274738 [list isEmpty] 274739 whileFalse: 274740 [object := list removeFirst. 274741 key := nil. 274742 (parent isKindOf: Dictionary) 274743 ifTrue: [list size >= 2 274744 ifTrue: 274745 [key := parent keyAtValue: list second ifAbsent: []. 274746 key == nil 274747 ifFalse: 274748 [object := list removeFirst; removeFirst. 274749 pointerList add: key printString , ' -> ' , object class name]]]. 274750 key == nil 274751 ifTrue: 274752 [parent class == object ifTrue: [key := 'CLASS']. 274753 key == nil ifTrue: [1 to: parent class instSize do: [:i | key == nil ifTrue: [(parent instVarAt: i) 274754 == object ifTrue: [key := parent class allInstVarNames at: i]]]]. 274755 key == nil ifTrue: [1 to: parent basicSize do: [:i | key == nil ifTrue: [(parent basicAt: i) 274756 == object ifTrue: [key := i printString]]]]. 274757 key == nil ifTrue: [(parent isMorph and: [object isKindOf: Array]) ifTrue: [key := 'submorphs?']]. 274758 key == nil ifTrue: [(parent isCompiledMethod and: [object isVariableBinding]) ifTrue: [key := 'literals?']]. 274759 key == nil ifTrue: [key := '???']. 274760 pointerList add: key , ': ' , object class name]. 274761 objectList add: object. 274762 parent := object]! ! 274763 274764!PointerFinder methodsFor: 'application' stamp: 'bf 2/12/2006 15:29'! 274765follow: anObject from: parentObject 274766 anObject == goal 274767 ifTrue: 274768 [parents at: anObject put: parentObject. 274769 ^ true]. 274770 anObject isLiteral ifTrue: [^ false]. 274771 "Remove this after switching to new CompiledMethod format --bf 2/12/2006" 274772 (anObject class isPointers or: [anObject isCompiledMethod]) ifFalse: [^ false]. 274773 anObject class isWeak ifTrue: [^ false]. 274774 (parents includesKey: anObject) 274775 ifTrue: [^ false]. 274776 parents at: anObject put: parentObject. 274777 toDoNext add: anObject. 274778 ^ false! ! 274779 274780!PointerFinder methodsFor: 'application' stamp: 'bf 2/12/2006 15:33'! 274781followObject: anObject 274782 (self follow: anObject class from: anObject) 274783 ifTrue: [^ true]. 274784 "Remove this after switching to new CompiledMethod format --bf 2/12/2006" 274785 anObject isCompiledMethod ifTrue: [ 274786 1 to: anObject numLiterals do: 274787 [:i | 274788 (self follow: (anObject literalAt: i) from: anObject) 274789 ifTrue: [^ true]]. 274790 ^false]. 274791 1 to: anObject class instSize do: 274792 [:i | 274793 (self follow: (anObject instVarAt: i) from: anObject) 274794 ifTrue: [^ true]]. 274795 1 to: anObject basicSize do: 274796 [:i | 274797 (self follow: (anObject basicAt: i) from: anObject) 274798 ifTrue: [^ true]]. 274799 ^ false! ! 274800 274801!PointerFinder methodsFor: 'application' stamp: 'sd 11/20/2005 21:27'! 274802goal: anObject 274803 goal := anObject! ! 274804 274805!PointerFinder methodsFor: 'application' stamp: 'alain.plantec 5/28/2009 10:14'! 274806initialize 274807 super initialize. 274808 parents := IdentityDictionary new: 20000. 274809 parents at: Smalltalk put: nil. 274810 parents at: Processor put: nil. 274811 parents at: self put: nil. 274812 274813 toDo := OrderedCollection new: 5000. 274814 toDo add: Smalltalk. 274815 toDoNext := OrderedCollection new: 5000! ! 274816 274817!PointerFinder methodsFor: 'application' stamp: 'sma 6/7/2000 00:19'! 274818isLiteral 274819 "Horrible hack to omit other Pointer Finders from scanning." 274820 274821 ^ true! ! 274822 274823!PointerFinder methodsFor: 'application' stamp: 'sd 11/20/2005 21:27'! 274824search 274825 Smalltalk garbageCollect. 274826 274827 self initialize. 274828 274829 Cursor wait showWhile: [ 274830 [[toDo isEmpty or: [self followObject: toDo removeFirst]] whileFalse. 274831 toDo isEmpty and: [toDoNext isEmpty not]] 274832 whileTrue: 274833 [toDo := toDoNext. 274834 toDoNext := OrderedCollection new: 5000]]. 274835 274836 self buildList! ! 274837 274838!PointerFinder methodsFor: 'application' stamp: 'sma 6/6/2000 19:10'! 274839update 274840 ('done: ' , parents size asString , ' todo: ' , toDo size asString , ' ') displayAt: 0@0! ! 274841 274842 274843!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:23'! 274844arrowKey: key from: aController 274845 key = $i ifTrue: [^ self inspectObject]. 274846 ^ super arrowKey: key from: aController! ! 274847 274848!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:48'! 274849initialExtent 274850 ^ 300 @ 300! ! 274851 274852!PointerFinder methodsFor: 'morphic ui' stamp: 'nb 6/17/2003 12:25'! 274853inspectObject 274854 pointerListIndex = 0 ifTrue: [^ Beeper beep]. 274855 (objectList at: pointerListIndex) inspect! ! 274856 274857!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:09'! 274858menu: aMenu shifted: shifted 274859 ^ MenuMorph new 274860 defaultTarget: self; 274861 add: 'Inspect (i)' action: #inspectObject; 274862 balloonTextForLastItem: 'Live long and prosper!!'; 274863 addLine; 274864 add: 'Search again' action: #searchAgain; 274865 balloonTextForLastItem: 'Search again\for the same object' withCRs; 274866 yourself! ! 274867 274868!PointerFinder methodsFor: 'morphic ui' stamp: 'wiz 2/25/2006 20:18'! 274869open 274870 | window list | 274871 window := (SystemWindow labelled: 'Pointer Finder') 274872 model: self. 274873 list := PluggableListMorph new 274874 doubleClickSelector: #inspectObject; 274875 274876 on: self 274877 list: #pointerList 274878 selected: #pointerListIndex 274879 changeSelected: #pointerListIndex: 274880 menu: #menu:shifted: 274881 keystroke: #arrowKey:from:. 274882 "For doubleClick to work best disable autoDeselect" 274883 list autoDeselect: false. 274884 window addMorph: list frame: (0@0 extent: 1@1). 274885 list color: Color lightMagenta. 274886 window openInWorld! ! 274887 274888!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:15'! 274889perform: selector orSendTo: otherTarget 274890 selector == #inspectObject ifTrue: [^ self inspectObject]. 274891 selector == #searchAgain ifTrue: [^ self searchAgain]. 274892 ^ super perform: selector orSendTo: otherTarget! ! 274893 274894!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:49'! 274895pointerList 274896 ^ pointerList asArray! ! 274897 274898!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:27'! 274899pointerListIndex 274900 ^ pointerListIndex ifNil: [0]! ! 274901 274902!PointerFinder methodsFor: 'morphic ui' stamp: 'sd 11/20/2005 21:27'! 274903pointerListIndex: anInteger 274904 pointerListIndex := anInteger. 274905 self changed: #pointerListIndex! ! 274906 274907!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:16'! 274908searchAgain 274909 self pointerListIndex: 0. 274910 self search. 274911 self changed: #pointerList! ! 274912 274913 274914!PointerFinder methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:48'! 274915isSelfEvaluating 274916 ^ false! ! 274917 274918"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 274919 274920PointerFinder class 274921 instanceVariableNames: ''! 274922 274923!PointerFinder class methodsFor: 'instance creation' stamp: 'sma 6/6/2000 23:52'! 274924on: anObject 274925 ^ self new goal: anObject; search; open! ! 274926 274927 274928!PointerFinder class methodsFor: 'utilities' stamp: 'sd 9/24/2004 20:49'! 274929pointersTo: anObject 274930 "Find all occurrences in the system of pointers to the argument anObject." 274931 "(PointerFinder pointersTo: Browser) inspect." 274932 274933 ^ self pointersTo: anObject except: #() 274934! ! 274935 274936!PointerFinder class methodsFor: 'utilities' stamp: 'sd 11/20/2005 21:28'! 274937pointersTo: anObject except: objectsToExclude 274938 "Find all occurrences in the system of pointers to the argument anObject. 274939 Remove objects in the exclusion list from the results." 274940 274941 | results anObj | 274942 Smalltalk garbageCollect. 274943 "big collection shouldn't grow, so it's contents array is always the same" 274944 results := OrderedCollection new: 1000. 274945 274946 "allObjectsDo: is expanded inline to keep spurious 274947 method and block contexts out of the results" 274948 anObj := self someObject. 274949 [0 == anObj] whileFalse: [ 274950 anObj isInMemory ifTrue: [ 274951 (anObj pointsTo: anObject) ifTrue: [ 274952 "exclude the results collector and contexts in call chain" 274953 ((anObj ~~ results collector) and: 274954 [(anObj ~~ objectsToExclude) and: 274955 [(anObj ~~ thisContext) and: 274956 [(anObj ~~ thisContext sender) and: 274957 [anObj ~~ thisContext sender sender]]]]) 274958 ifTrue: [ results add: anObj ]. 274959 ]]. 274960 anObj := anObj nextObject. 274961 ]. 274962 objectsToExclude do: [ :obj | results removeAllSuchThat: [ :el | el == obj]]. 274963 274964 ^ results asArray 274965! ! 274966 274967!PointerFinder class methodsFor: 'utilities' stamp: 'sd 9/24/2004 20:48'! 274968pointersToItem: index of: anArray 274969 "Find all occurrences in the system of pointers to the given element of the given array. 274970 This is useful for tracing up a pointer chain from an inspector on the results of a previous call of pointersTo:. To find out who points to the second element of the results, one would evaluate: 274971 274972 PointerFinder pointersToItem: 2 of: self 274973 274974 in the inspector." 274975 274976 ^ self pointersTo: (anArray at: index) except: (Array with: anArray)! ! 274977TestCase subclass: #PointerFinderTest 274978 instanceVariableNames: '' 274979 classVariableNames: '' 274980 poolDictionaries: '' 274981 category: 'ToolsTest-PointerFinder'! 274982 274983!PointerFinderTest methodsFor: 'as yet unclassified' stamp: 'Alexandre.Bergel 7/4/2009 11:14'! 274984testBasic1 274985 274986 | myObject myArray | 274987 myObject := Object new. 274988 myArray := {myObject . myObject}. 274989 self assert: (PointerFinder pointersTo: myObject) asArray = {myArray}! ! 274990 274991!PointerFinderTest methodsFor: 'as yet unclassified' stamp: 'Alexandre.Bergel 7/4/2009 11:24'! 274992testCycle 274993 274994 | myObject myArray myArray2 pointingObjects | 274995 myObject := Object new. 274996 myArray := {myObject . myObject}. 274997 myArray2 := {myObject . myArray}. 274998 274999 pointingObjects := (PointerFinder pointersTo: myObject) asArray. 275000 self assert: pointingObjects size = 2. 275001 self assert: (pointingObjects includesAllOf: {myArray . myArray2}). 275002 275003 "PointerFinder loops in presence of cycles" 275004" myArray at: 1 put: myArray. 275005 pointingObjects := (PointerFinder pointersTo: myObject) asArray. 275006 self assert: pointingObjects = {myArray}. 275007"! ! 275008 275009!PointerFinderTest methodsFor: 'as yet unclassified' stamp: 'Alexandre.Bergel 7/4/2009 11:13'! 275010testNoPointingObject 275011 275012 | myObject | 275013 myObject := Object new. 275014 self assert: (PointerFinder pointersTo: myObject) isEmpty! ! 275015PathShape subclass: #Polygon 275016 instanceVariableNames: '' 275017 classVariableNames: '' 275018 poolDictionaries: '' 275019 category: 'Polymorph-Geometry'! 275020 275021!Polygon methodsFor: 'as yet unclassified' stamp: 'gvc 6/25/2007 14:43'! 275022containsPoint: aPoint 275023 "Answer whether the receiver contains the given point." 275024 275025 |wind| 275026 (self basicContainsPoint: aPoint) ifFalse: [^false]. 275027 wind := 0. 275028 self segmentsDo: [:p1 :p2 | 275029 p1 y <= aPoint y 275030 ifTrue: [p2 y = aPoint y 275031 ifTrue: [(aPoint directionToLineFrom: p1 to: p2) = 0 275032 ifTrue: [^true]] 275033 ifFalse: [(p2 y > aPoint y and: [(aPoint directionToLineFrom: p1 to: p2) > 0]) 275034 ifTrue: [wind := wind + 1]]] 275035 ifFalse: [p2 y = aPoint y 275036 ifTrue: [(aPoint directionToLineFrom: p1 to: p2) = 0 275037 ifTrue: [^true]]. 275038 (p2 y < aPoint y and: [(aPoint directionToLineFrom: p1 to: p2) < 0]) 275039 ifTrue: [wind := wind - 1]]]. 275040 ^wind ~= 0! ! 275041 275042!Polygon methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 10:52'! 275043segmentsDo: aBlock 275044 "Evaluate the two-argument block with each vertex and its successor." 275045 275046 self vertices size < 2 ifTrue: [^self]. 275047 super segmentsDo: aBlock. 275048 aBlock 275049 value: self vertices last 275050 value: self vertices first! ! 275051BorderedMorph subclass: #PolygonMorph 275052 instanceVariableNames: 'vertices closed filledForm arrows arrowForms smoothCurve curveState borderDashSpec handles borderForm' 275053 classVariableNames: '' 275054 poolDictionaries: '' 275055 category: 'Morphic-Basic'! 275056!PolygonMorph commentStamp: 'md 2/24/2006 20:34' prior: 0! 275057This class implements a morph which can behave as four different objects depending on the the following two facts: 275058- is it OPEN or CLOSED? 275059- is it SEGMENTED or SMOOTHED. 275060 2750611. The OPEN and SEGMENTED variant looks like polyline. 275062 2750632. The OPEN and SMOOTHED variant looks like spline (kind of curve) 275064 2750653. The CLOSED and SEGMENTED variant looks like polygon. This is actually what you get when you do 275066 PolygonMorph new openInWorld 275067You get a triangle. See below how to manipulate these objects... 275068 2750694. The CLOSED and SMOOTHED variant looks like blob (???) 275070 275071Prototypes of this morph can also be found in "Object Catalog". Several (different variants) of this object are among "Basic" morphs. 275072 275073Explore the assiciated morph-menu. It enables you 275074- to toggle showing of "handles". They make it possible to 275075 - reposition already existing vertices (by moving yellow handles) 275076 - create new vertices (by moving green handles) 275077 - delete already existing vertices (by dragging and dropping one yellow handle closely 275078 nearby the adjacent yellow handle 275079 Handles can be made visible/hidden by shift+leftclicking the morph. This way it is possible 275080 to quickly show handles, adjust vertices and then again hide handles. 275081- making closed polygon open, i.e. converting it to a curve (and vice versa) 275082- toggle smoothed/segmented line/outline 275083- set up custom dashing (for line, curves or borders of closed polygons 275084- set up custom arrow-heads (for lines resp. curves) 275085 275086------------------------------------------------------------------------------------------ 275087Implementation notes: 275088 275089This class combines the old Polygon and Curve classes. 275090 275091The 1-bit fillForm to make display and containment tests reasonably fast. However, this functionality is in the process of being supplanted by balloon capabilities, which should eventually provide anti-aliasing as well. 275092 275093wiz 7/18/2004 21:26 275094s have made some changes to this class to 275095 2750961) correct some bugs associated with one vertex polygons. 275097 2750982) prepare for some enhancements with new curves. 275099 2751003) add shaping items to menu.! 275101 275102 275103!PolygonMorph methodsFor: '*etoys-geometry etoy' stamp: 'di 9/24/2000 09:36'! 275104heading: newHeading 275105 "Set the receiver's heading (in eToy terms). 275106 Note that polygons never use flex shells." 275107 self rotationDegrees: newHeading.! ! 275108 275109 275110!PolygonMorph methodsFor: 'access' stamp: 'aoy 2/15/2003 20:51'! 275111borderColor: aColor 275112 275113 super borderColor: aColor. 275114 (borderColor isColor and: [borderColor isTranslucentColor]) 275115 == (aColor isColor and: [aColor isTranslucentColor]) 275116 ifFalse: 275117 ["Need to recompute fillForm and borderForm 275118 if translucency of border changes." 275119 275120 self releaseCachedState]! ! 275121 275122!PolygonMorph methodsFor: 'access' stamp: 'sw 8/25/2000 22:37'! 275123isClosed 275124 ^ closed! ! 275125 275126!PolygonMorph methodsFor: 'access' stamp: 'di 9/7/2000 16:18'! 275127isCurve 275128 ^ smoothCurve! ! 275129 275130!PolygonMorph methodsFor: 'access' stamp: 'jm 11/19/97 18:55'! 275131isOpen 275132 ^ closed not! ! 275133 275134!PolygonMorph methodsFor: 'access' stamp: 'sw 8/23/2000 16:16'! 275135makeOpenOrClosed 275136 "toggle the open/closed status of the receiver" 275137 closed ifTrue: [self makeOpen] ifFalse: [self makeClosed]! ! 275138 275139!PolygonMorph methodsFor: 'access' stamp: 'wiz 6/24/2004 22:50'! 275140midVertices 275141 "Return and array of midpoints for this line or closed curve" 275142 | midPts nextVertIx tweens | 275143 vertices size < 2 275144 ifTrue: [^ vertices]. 275145 midPts := OrderedCollection new. 275146 nextVertIx := 2. 275147 tweens := OrderedCollection new. 275148 tweens add: vertices first asIntegerPoint. 275149 "guarantee at least two points." 275150 self 275151 lineSegmentsDo: [:p1 :p2 | 275152 tweens addLast: p2 asIntegerPoint. 275153 p2 275154 = (vertices atWrap: nextVertIx) 275155 ifTrue: ["Found endPoint." 275156 midPts addLast: (tweens atWrap: tweens size + 1 // 2) 275157 + (tweens at: tweens size // 2 + 1) // 2. 275158 "wiz 6/19/2004 20:11 adjusted to handle 275159 one segment properly" 275160 tweens := OrderedCollection new. 275161 tweens add: p2 asIntegerPoint. 275162 "guarantee at least two points." 275163 nextVertIx := nextVertIx + 1]]. 275164 ^ midPts asArray! ! 275165 275166!PolygonMorph methodsFor: 'access' stamp: 'dgd 12/11/2003 13:14'! 275167openOrClosePhrase 275168 | curveName | 275169 curveName := (self isCurve 275170 ifTrue: ['curve'] 275171 ifFalse: ['polygon']) translated. 275172 ^ closed 275173 ifTrue: ['make open {1}' translated format: {curveName}] 275174 ifFalse: ['make closed {1}' translated format: {curveName}]! ! 275175 275176!PolygonMorph methodsFor: 'access' stamp: 'wiz 6/6/2004 21:56'! 275177smoothOrSegmentedPhrase 275178 | lineName | 275179 lineName := (closed 275180 ifTrue: ['outline'] 275181 ifFalse: ['line']) translated. 275182 275183 ^ self isCurve 275184 ifTrue: ['make segmented {1}' translated format: {lineName}] 275185 ifFalse: ['make smooth {1}' translated format: {lineName}].! ! 275186 275187!PolygonMorph methodsFor: 'access' stamp: 'sw 9/14/97 18:22'! 275188vertices 275189 ^ vertices! ! 275190 275191 275192!PolygonMorph methodsFor: 'accessing' stamp: 'nk 9/4/2004 17:23'! 275193borderWidth: anInteger 275194 275195 borderColor ifNil: [borderColor := Color black]. 275196 borderWidth := anInteger max: 0. 275197 self computeBounds! ! 275198 275199!PolygonMorph methodsFor: 'accessing' stamp: 'sw 11/24/1999 14:57'! 275200couldHaveRoundedCorners 275201 ^ false! ! 275202 275203 275204!PolygonMorph methodsFor: 'attachments' stamp: 'nk 8/14/2004 13:58'! 275205boundsSignatureHash 275206 ^(vertices - (self positionInWorld)) hash 275207! ! 275208 275209!PolygonMorph methodsFor: 'attachments' stamp: 'nk 2/25/2001 17:21'! 275210defaultAttachmentPointSpecs 275211 ^{ 275212 { #firstVertex } . 275213 { #midpoint } . 275214 { #lastVertex } 275215 }! ! 275216 275217!PolygonMorph methodsFor: 'attachments' stamp: 'nk 4/18/2001 11:43'! 275218endShapeColor: aColor 275219 self borderColor: aColor. 275220 self isClosed ifTrue: [ self color: aColor ].! ! 275221 275222!PolygonMorph methodsFor: 'attachments' stamp: 'nk 5/31/2003 10:56'! 275223endShapeWidth: aWidth 275224 | originalWidth originalVertices transform | 275225 originalWidth := self valueOfProperty: #originalWidth ifAbsentPut: [ self borderWidth isZero ifFalse: [ self borderWidth ] ifTrue: [ 2 ] ]. 275226 self borderWidth: aWidth. 275227 originalVertices := self valueOfProperty: #originalVertices ifAbsentPut: [ 275228 self vertices collect: [ :ea | (ea - (self referencePosition)) rotateBy: self heading degreesToRadians about: 0@0 ] 275229 ]. 275230 transform := MorphicTransform offset: 0@0 angle: self heading degreesToRadians scale: originalWidth / aWidth. 275231 self setVertices: (originalVertices collect: [ :ea | 275232 ((transform transform: ea) + self referencePosition) asIntegerPoint 275233 ]). 275234 self computeBounds.! ! 275235 275236!PolygonMorph methodsFor: 'attachments' stamp: 'nk 2/25/2001 17:19'! 275237firstVertex 275238 ^vertices first! ! 275239 275240!PolygonMorph methodsFor: 'attachments' stamp: 'nk 2/25/2001 17:19'! 275241lastVertex 275242 ^vertices last! ! 275243 275244!PolygonMorph methodsFor: 'attachments' stamp: 'nk 7/3/2003 14:43'! 275245midpoint 275246 "Answer the midpoint along my segments" 275247 | middle | 275248 middle := 0. 275249 self lineSegmentsDo: [ :a :b | middle := middle + (a dist: b) ]. 275250 middle < 2 ifTrue: [ ^ self center ]. 275251 middle := middle / 2. 275252 self lineSegmentsDo: [ :a :b | | dist | 275253 dist := (a dist: b). 275254 middle < dist 275255 ifTrue: [ ^(a + ((b - a) * (middle / dist))) asIntegerPoint ]. 275256 middle := middle - dist. 275257 ]. 275258 self error: 'can''t happen'! ! 275259 275260!PolygonMorph methodsFor: 'attachments' stamp: 'nk 4/23/2002 15:49'! 275261nudgeForLabel: aRectangle 275262 "Try to move the label off me. Prefer labels on the top and right." 275263 275264 | i flags nudge | 275265 (self bounds intersects: aRectangle) ifFalse: [^ 0@0 ]. 275266 flags := 0. 275267 nudge := 0@0. 275268 i := 1. 275269 aRectangle lineSegmentsDo: [ :rp1 :rp2 | | rectSeg int | 275270 rectSeg := LineSegment from: rp1 to: rp2. 275271 self straightLineSegmentsDo: [ :lp1 :lp2 | | polySeg | 275272 polySeg := LineSegment from: lp1 to: lp2. 275273 int := polySeg intersectionWith: rectSeg. 275274 int ifNotNil: [ flags := flags bitOr: i ]. 275275 ]. 275276 i := i * 2. 275277 ]. 275278 "Now flags has bitflags for which sides" 275279 nudge := flags caseOf: { 275280"no intersection" 275281 [ 0 ] -> [ 0@0 ]. 275282"2 adjacent sides only" 275283 [ 9 ] -> [ 1@1 ]. 275284 [ 3 ] -> [ -1@1 ]. 275285 [ 12 ] -> [ 1@-1 ]. 275286 [ 6 ] -> [ -1@-1 ]. 275287"2 opposite sides only" 275288 [ 10 ] -> [ 0@-1 ]. 275289 [ 5 ] -> [ 1@0 ]. 275290"only 1 side" 275291 [ 8 ] -> [ -1@0 ]. 275292 [ 1 ] -> [ 0@-1 ]. 275293 [ 2 ] -> [ 1@0 ]. 275294 [ 4 ] -> [ 0@1 ]. 275295"3 sides" 275296 [ 11 ] -> [ 0@1 ]. 275297 [ 13 ] -> [ 1@0 ]. 275298 [ 14 ] -> [ 0@-1 ]. 275299 [ 7 ] -> [ -1@0 ]. 275300 "all sides" 275301 [ 15 ] -> [ 1@-1 "move up and to the right" ]. 275302 }. 275303 ^nudge! ! 275304 275305!PolygonMorph methodsFor: 'attachments' stamp: 'nk 7/3/2003 14:42'! 275306totalLength 275307 "Answer the full length of my segments. Can take a long time if I'm curved." 275308 | length | 275309 length := 0. 275310 self lineSegmentsDo: [ :a :b | length := length + (a dist: b) ]. 275311 ^length.! ! 275312 275313 275314!PolygonMorph methodsFor: 'caching' stamp: 'di 11/13/97 15:16'! 275315loadCachedState 275316 "Prepare for fast response -- next page of a book?" 275317 self filledForm. 275318 self arrowForms! ! 275319 275320!PolygonMorph methodsFor: 'caching' stamp: 'di 9/4/2000 13:36'! 275321releaseCachedState 275322 super releaseCachedState. 275323 filledForm := nil. 275324 arrowForms := nil. 275325 borderForm := nil. 275326 curveState := nil. 275327 (self hasProperty: #flex) ifTrue: 275328 [self removeProperty: #unflexedVertices; 275329 removeProperty: #flex]. 275330! ! 275331 275332 275333!PolygonMorph methodsFor: 'dashes' stamp: 'dgd 2/22/2003 18:55'! 275334borderDashOffset 275335 borderDashSpec size < 4 ifTrue: [^0.0]. 275336 ^(borderDashSpec fourth) asFloat! ! 275337 275338!PolygonMorph methodsFor: 'dashes' stamp: 'nk 2/27/2001 12:11'! 275339dashedBorder 275340 ^borderDashSpec 275341 "A dash spec is a 3- or 5-element array with 275342 { length of normal border color. 275343 length of alternate border color. 275344 alternate border color. 275345 starting offset. 275346 amount to add to offset at each step } 275347 Starting offset is usually = 0, but changing it moves the dashes along the curve." 275348! ! 275349 275350!PolygonMorph methodsFor: 'dashes' stamp: 'di 9/9/2000 09:20'! 275351dashedBorder: dashSpec 275352 "A dash spec is a 3- or 5-element array with 275353 { length of normal border color. 275354 length of alternate border color. 275355 alternate border color. 275356 starting offset. 275357 amount to add to offset at each step } 275358 Starting offset is usually = 0, but changing it moves the dashes along the curve." 275359 275360 borderDashSpec := dashSpec. 275361 self changed! ! 275362 275363!PolygonMorph methodsFor: 'dashes' stamp: 'nk 4/5/2001 16:02'! 275364removeVertex: aVert 275365 "Make sure that I am not left with less than two vertices" 275366 | newVertices | 275367 vertices size < 2 ifTrue: [ ^self ]. 275368 newVertices := vertices copyWithout: aVert. 275369 newVertices size caseOf: { 275370 [1] -> [ newVertices := { newVertices first . newVertices first } ]. 275371 [0] -> [ newVertices := { aVert . aVert } ] 275372 } otherwise: []. 275373 self setVertices: newVertices 275374! ! 275375 275376!PolygonMorph methodsFor: 'dashes' stamp: 'nk 2/25/2001 17:05'! 275377vertexAt: n 275378 ^vertices at: (n min: vertices size).! ! 275379 275380 275381!PolygonMorph methodsFor: 'debug and other' stamp: 'wiz 5/1/2004 00:21'! 275382rotateTestFlip: aBool 275383 "Return one copy of me for each vertex using each vertex as 275384 the 275385 starting point. 275386 Vary to border color to destinguish the copies. 275387 This tests closed curves for their consistency. 275388 The flip boolean tests the reversed rotations." 275389 | len colors verts flip | 275390 verts := self vertices. 275391 flip := aBool == true 275392 ifTrue: [1] 275393 ifFalse: [0]. 275394 len := verts size. 275395 colors := Color wheel: len*2 . 275396 (1 to: len) 275397 do: [:i | | j | (self copy 275398 borderColor: (colors at: (j:=i * 2 - flip)); 275399 yourself) 275400 setVertices: (verts flipRotated: j); 275401 openInWorld]! ! 275402 275403 275404!PolygonMorph methodsFor: 'drawing' stamp: 'di 6/24/1998 14:36'! 275405areasRemainingToFill: aRectangle 275406 "Could be improved by quick check of inner rectangle" 275407 275408 ^ Array with: aRectangle! ! 275409 275410!PolygonMorph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 18:56'! 275411drawArrowOn: aCanvas at: endPoint from: priorPoint 275412 "Draw a triangle oriented along the line from priorPoint to 275413 endPoint. Answer the wingBase." 275414 275415 | pts spec wingBase | 275416 pts := self arrowBoundsAt: endPoint from: priorPoint. 275417 wingBase := pts size = 4 275418 ifTrue: [pts third] 275419 ifFalse: [(pts copyFrom: 2 to: 3) average]. 275420 spec := self valueOfProperty: #arrowSpec ifAbsent: [5 @ 4]. 275421 spec x sign = spec y sign 275422 ifTrue: [aCanvas drawPolygon: pts fillStyle: borderColor] 275423 ifFalse: 275424 [aCanvas 275425 drawPolygon: pts 275426 fillStyle: Color transparent 275427 borderWidth: (borderWidth + 1) // 2 275428 borderColor: borderColor]. 275429 ^wingBase! ! 275430 275431!PolygonMorph methodsFor: 'drawing' stamp: 'wiz 2/23/2006 19:19'! 275432drawArrowsOn: aCanvas 275433 "Answer (possibly modified) endpoints for border drawing" 275434 "ArrowForms are computed only upon demand" 275435 | array | 275436 275437 self hasArrows 275438 ifFalse: [^ #() ]. 275439 "Nothing to do" 275440 275441 array := Array with: vertices first with: vertices last. 275442 275443 "Prevent crashes for #raised or #inset borders" 275444 borderColor isColor 275445 ifFalse: [ ^array ]. 275446 275447 (arrows == #forward or: [arrows == #both]) 275448 ifTrue: [ array at: 2 put: (self 275449 drawArrowOn: aCanvas 275450 at: vertices last 275451 from: self nextToLastPoint) ]. 275452 275453 (arrows == #back or: [arrows == #both]) 275454 ifTrue: [ array at: 1 put: (self 275455 drawArrowOn: aCanvas 275456 at: vertices first 275457 from: self nextToFirstPoint) ]. 275458 275459 ^array! ! 275460 275461!PolygonMorph methodsFor: 'drawing' stamp: 'ar 11/26/2001 23:15'! 275462drawBorderOn: aCanvas 275463 self 275464 drawClippedBorderOn: aCanvas 275465 usingEnds: (Array with: vertices first with: vertices last)! ! 275466 275467!PolygonMorph methodsFor: 'drawing' stamp: 'wiz 6/22/2004 15:56'! 275468drawBorderOn: aCanvas usingEnds: anArray 275469 "Display my border on the canvas." 275470 "NOTE: Much of this code is also copied in 275471 drawDashedBorderOn: 275472 (should be factored)" 275473 | bigClipRect p1i p2i style | 275474 borderDashSpec 275475 ifNotNil: [^ self drawDashedBorderOn: aCanvas usingEnds: anArray]. 275476 style := self borderStyle. 275477 bigClipRect := aCanvas clipRect expandBy: self borderWidth + 1 // 2. 275478 self 275479 lineSegmentsDo: [:p1 :p2 | 275480 p1i := p1 asIntegerPoint. 275481 p2i := p2 asIntegerPoint. 275482 self hasArrows 275483 ifTrue: ["Shorten line ends so as not to interfere with tip 275484 of arrow." 275485 ((arrows == #back 275486 or: [arrows == #both]) 275487 and: [p1 = vertices first]) 275488 ifTrue: [p1i := anArray first asIntegerPoint]. 275489 ((arrows == #forward 275490 or: [arrows == #both]) 275491 and: [p2 = vertices last]) 275492 ifTrue: [p2i := anArray last asIntegerPoint]]. 275493 (closed 275494 or: ["bigClipRect intersects: (p1i rect: p2i) 275495 optimized:" 275496 ((p1i min: p2i) 275497 max: bigClipRect origin) 275498 <= ((p1i max: p2i) 275499 min: bigClipRect corner)]) 275500 ifTrue: [style 275501 drawLineFrom: p1i 275502 to: p2i 275503 on: aCanvas]]! ! 275504 275505!PolygonMorph methodsFor: 'drawing' stamp: 'ar 11/26/2001 23:15'! 275506drawClippedBorderOn: aCanvas usingEnds: anArray 275507 aCanvas clipBy: self bounds during:[:cc| self drawBorderOn: cc usingEnds: anArray].! ! 275508 275509!PolygonMorph methodsFor: 'drawing' stamp: 'nk 10/4/2000 12:23'! 275510drawDashedBorderOn: aCanvas 275511 self 275512 drawDashedBorderOn: aCanvas 275513 usingEnds: (Array with: vertices first with: vertices last)! ! 275514 275515!PolygonMorph methodsFor: 'drawing' stamp: 'wiz 6/22/2004 15:56'! 275516drawDashedBorderOn: aCanvas usingEnds: anArray 275517 "Display my border on the canvas. NOTE: mostly copied from 275518 drawBorderOn:" 275519 | lineColor bevel topLeftColor bottomRightColor bigClipRect p1i p2i segmentOffset | 275520 (borderColor isNil 275521 or: [borderColor isColor 275522 and: [borderColor isTransparent]]) 275523 ifTrue: [^ self]. 275524 lineColor := borderColor. 275525 bevel := false. 275526 "Border colors for bevelled effects depend on CW ordering of 275527 vertices" 275528 borderColor == #raised 275529 ifTrue: [topLeftColor := color lighter. 275530 bottomRightColor := color darker. 275531 bevel := true]. 275532 borderColor == #inset 275533 ifTrue: [topLeftColor := owner colorForInsets darker. 275534 bottomRightColor := owner colorForInsets lighter. 275535 bevel := true]. 275536 bigClipRect := aCanvas clipRect expandBy: self borderWidth + 1 // 2. 275537 segmentOffset := self borderDashOffset. 275538 self 275539 lineSegmentsDo: [:p1 :p2 | 275540 p1i := p1 asIntegerPoint. 275541 p2i := p2 asIntegerPoint. 275542 self hasArrows 275543 ifTrue: ["Shorten line ends so as not to interfere with tip 275544 of arrow." 275545 ((arrows == #back 275546 or: [arrows == #both]) 275547 and: [p1 = vertices first]) 275548 ifTrue: [p1i := anArray first asIntegerPoint]. 275549 ((arrows == #forward 275550 or: [arrows == #both]) 275551 and: [p2 = vertices last]) 275552 ifTrue: [p2i := anArray last asIntegerPoint]]. 275553 (closed 275554 or: ["bigClipRect intersects: (p1i rect: p2i) 275555 optimized:" 275556 ((p1i min: p2i) 275557 max: bigClipRect origin) 275558 <= ((p1i max: p2i) 275559 min: bigClipRect corner)]) 275560 ifTrue: [bevel 275561 ifTrue: [lineColor := (p1i quadrantOf: p2i) 275562 > 2 275563 ifTrue: [topLeftColor] 275564 ifFalse: [bottomRightColor]]. 275565 segmentOffset := aCanvas 275566 line: p1i 275567 to: p2i 275568 width: borderWidth 275569 color: lineColor 275570 dashLength: borderDashSpec first 275571 secondColor: borderDashSpec third 275572 secondDashLength: borderDashSpec second 275573 startingOffset: segmentOffset]]! ! 275574 275575!PolygonMorph methodsFor: 'drawing'! 275576drawOnFormCanvas: aCanvas 275577 "Display the receiver, a spline curve, approximated by straight line segments." 275578 275579 | | 275580 vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point']. 275581 closed & color isTransparent not 275582 ifTrue: [aCanvas stencil: self filledForm at: bounds topLeft - 1 color: color]. 275583 (borderColor isColor and: [borderColor isTranslucentColor]) 275584 ifTrue: [aCanvas stencil: self borderForm at: bounds topLeft 275585 color: borderColor] 275586 ifFalse: [self drawBorderOn: aCanvas]. 275587 self arrowForms do: 275588 [:f | aCanvas stencil: f at: f offset 275589 color: (borderColor isColor ifTrue: [borderColor] ifFalse: [color])]! ! 275590 275591!PolygonMorph methodsFor: 'drawing' stamp: 'ar 11/26/2001 23:15'! 275592drawOn: aCanvas 275593 "Display the receiver, a spline curve, approximated by straight 275594 line segments." 275595 | array | 275596 vertices size < 1 275597 ifTrue: [self error: 'a polygon must have at least one point']. 275598 closed ifTrue: 275599 [aCanvas drawPolygon: self getVertices fillStyle: self fillStyle. 275600 aCanvas isShadowDrawing ifTrue: [^ self]]. 275601 array := self drawArrowsOn: aCanvas. 275602 self drawClippedBorderOn: aCanvas usingEnds: array. 275603! ! 275604 275605 275606!PolygonMorph methodsFor: 'dropping/grabbing' stamp: 'di 9/8/2000 09:56'! 275607justDroppedInto: newOwner event: evt 275608 275609 | delta | 275610 (newOwner isKindOf: PasteUpMorph) ifTrue: 275611 ["Compensate for border width so that gridded drop 275612 is consistent with gridded drag of handles." 275613 delta := borderWidth+1//2. 275614 self position: (newOwner gridPoint: self position + delta) - delta]. 275615 ^ super justDroppedInto: newOwner event: evt! ! 275616 275617 275618!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 19:02'! 275619addHandles 275620 "Put moving handles at the vertices. Put adding handles at 275621 edge midpoints. 275622 Moving over adjacent vertex and dropping will delete a 275623 vertex. " 275624 | handle newVert tri | 275625 self removeHandles. 275626 handles := OrderedCollection new. 275627 tri := Array 275628 with: 0 @ -4 275629 with: 4 @ 3 275630 with: -3 @ 3. 275631 vertices 275632 withIndexDo: [:vertPt :vertIndex | 275633 handle := EllipseMorph 275634 newBounds: (Rectangle center: vertPt extent: 8 @ 8) 275635 color: (self handleColorAt: vertIndex) . 275636 handle 275637 on: #mouseMove 275638 send: #dragVertex:event:fromHandle: 275639 to: self 275640 withValue: vertIndex. 275641 handle 275642 on: #mouseUp 275643 send: #dropVertex:event:fromHandle: 275644 to: self 275645 withValue: vertIndex. 275646 handle 275647 on: #click 275648 send: #clickVertex:event:fromHandle: 275649 to: self 275650 withValue: vertIndex. 275651 self addMorph: handle. 275652 handles addLast: handle. 275653 (closed 275654 or: [1 = vertices size 275655 "Give a small polygon a chance to grow. 275656 -wiz"] 275657 or: [vertIndex < vertices size]) 275658 ifTrue: [newVert := PolygonMorph 275659 vertices: (tri 275660 collect: [:p | p + (vertPt 275661 + (vertices atWrap: vertIndex + 1) // 2)]) 275662 color: Color green 275663 borderWidth: 1 275664 borderColor: Color black. 275665 newVert 275666 on: #mouseDown 275667 send: #newVertex:event:fromHandle: 275668 to: self 275669 withValue: vertIndex. 275670 self addMorph: newVert. 275671 handles addLast: newVert]]. 275672 self isCurvy 275673 ifTrue: [self updateHandles; layoutChanged]. 275674 self changed! ! 275675 275676!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/7/2006 23:35'! 275677clickVertex: ix event: evt fromHandle: handle 275678 "Backstop for MixedCurveMorph"! ! 275679 275680!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:20'! 275681deleteVertexAt: anIndex 275682 "This acts as a backstop for MixedCurveMorph." 275683 self 275684 setVertices: (vertices 275685 copyReplaceFrom: anIndex 275686 to: anIndex 275687 with: Array new). 275688 ! ! 275689 275690!PolygonMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:30'! 275691dragVertex: ix event: evt fromHandle: handle 275692 | p | 275693 p := self isCurve 275694 ifTrue: [evt cursorPoint] 275695 ifFalse: [self griddedPoint: evt cursorPoint]. 275696 handle position: p - (handle extent//2). 275697 self verticesAt: ix put: p. 275698! ! 275699 275700!PolygonMorph methodsFor: 'editing' stamp: 'ar 3/18/2001 17:28'! 275701dragVertex: arg1 fromHandle: arg2 vertIndex: arg3 275702 "Reorder the arguments for existing event handlers" 275703 (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. 275704 ^self dragVertex: arg1 event: arg2 fromHandle: arg3! ! 275705 275706!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:35'! 275707dropVertex: ix event: evt fromHandle: handle 275708 "Leave vertex in new position. If dropped ontop another vertex delete this one. 275709 Check for too few vertices before deleting. The alternative 275710 is not pretty -wiz" 275711 | p | 275712 p := vertices at: ix. 275713 (vertices size >= 2 275714 and: ["check for too few vertices before deleting. The alternative 275715 is not pretty -wiz" 275716 ((vertices atWrap: ix - 1) 275717 dist: p) 275718 < 3 275719 or: [((vertices atWrap: ix + 1) 275720 dist: p) 275721 < 3]]) 275722 ifTrue: ["Drag a vertex onto its neighbor means delete" 275723 self deleteVertexAt: ix .]. 275724 evt shiftPressed 275725 ifTrue: [self removeHandles] 275726 ifFalse: [self addHandles 275727 "remove then add to recreate"]! ! 275728 275729!PolygonMorph methodsFor: 'editing' stamp: 'ar 3/18/2001 17:28'! 275730dropVertex: arg1 fromHandle: arg2 vertIndex: arg3 275731 "Reorder the arguments for existing event handlers" 275732 (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. 275733 ^self dropVertex: arg1 event: arg2 fromHandle: arg3! ! 275734 275735!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:37'! 275736handleColorAt: vertIndex 275737 "This is a backstop for MixedCurveMorph" 275738 275739^ Color yellow 275740! ! 275741 275742!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:19'! 275743insertVertexAt: anIndex put: aValue 275744 "This serves as a hook and a backstop for MixedCurveMorph." 275745 self setVertices: (vertices copyReplaceFrom: anIndex + 1 to: anIndex 275746 with: (Array with: aValue)).! ! 275747 275748!PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:25'! 275749newVertex: ix event: evt fromHandle: handle 275750 "Insert a new vertex and fix everything up!! Install the drag-handle of the new vertex as recipient of further mouse events." 275751 275752 | pt | 275753 "(self hasProperty: #noNewVertices) ifFalse: 275754 [pt := evt cursorPoint. 275755 self setVertices: (vertices copyReplaceFrom: ix + 1 to: ix with: (Array with: pt)). 275756 evt hand newMouseFocus: (handles at: ((ix + 1) * 2) - 1)]" 275757 "modified to remove now vestigial test. see PolygonMorph class>>arrowprototype" 275758 pt := evt cursorPoint. 275759 self insertVertexAt: ix put: pt . 275760 evt hand newMouseFocus: (handles at: ((ix + 1) * 2) - 1)! ! 275761 275762!PolygonMorph methodsFor: 'editing' stamp: 'ar 3/18/2001 17:28'! 275763newVertex: arg1 fromHandle: arg2 afterVert: arg3 275764 "Reorder the arguments for existing event handlers" 275765 (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. 275766 ^self newVertex: arg1 event: arg2 fromHandle: arg3! ! 275767 275768!PolygonMorph methodsFor: 'editing' stamp: 'wiz 6/24/2004 23:03'! 275769updateHandles 275770 | newVert oldVert | 275771 self isCurvy 275772 ifTrue: [handles first center: vertices first. 275773 handles last center: vertices last. 275774 self midVertices 275775 withIndexDo: [:midPt :vertIndex | (closed 275776 or: [vertIndex < vertices size]) 275777 ifTrue: [newVert := handles atWrap: vertIndex * 2. 275778 newVert position: midPt - (newVert extent // 2)]]] 275779 ifFalse: [vertices 275780 withIndexDo: [:vertPt :vertIndex | 275781 oldVert := handles at: vertIndex * 2 - 1. 275782 oldVert position: vertPt - (oldVert extent // 2). 275783 (closed 275784 or: [vertIndex < vertices size]) 275785 ifTrue: [newVert := handles at: vertIndex * 2. 275786 newVert position: vertPt 275787 + (vertices atWrap: vertIndex + 1) - newVert extent // 2 + (1 @ -1)]]]! ! 275788 275789!PolygonMorph methodsFor: 'editing' stamp: 'di 9/8/2000 10:39'! 275790verticesAt: ix put: newPoint 275791 vertices at: ix put: newPoint. 275792 self computeBounds! ! 275793 275794 275795!PolygonMorph methodsFor: 'event handling' stamp: 'di 8/20/2000 14:29'! 275796handlesMouseDown: evt 275797 275798 ^ (super handlesMouseDown: evt) or: [evt shiftPressed]! ! 275799 275800!PolygonMorph methodsFor: 'event handling' stamp: 'nk 8/8/2001 12:13'! 275801mouseDown: evt 275802 275803 ^ evt shiftPressed 275804 ifTrue: [((owner isKindOf: PolygonMorph) and: [owner includesHandle: self]) 275805 ifTrue: ["Prevent insertion handles from getting edited" 275806 ^ super mouseDown: evt]. 275807 self toggleHandles. 275808 handles ifNil: [^ self]. 275809 vertices withIndexDo: "Check for click-to-drag at handle site" 275810 [:vertPt :vertIndex | 275811 ((handles at: vertIndex*2-1 ifAbsent: [ ^self ]) containsPoint: evt cursorPoint) ifTrue: 275812 ["If clicked near a vertex, jump into drag-vertex action" 275813 evt hand newMouseFocus: (handles at: vertIndex*2-1)]]] 275814 ifFalse: [super mouseDown: evt]! ! 275815 275816 275817!PolygonMorph methodsFor: 'geometry' stamp: 'nk 2/15/2001 09:09'! 275818arrowsContainPoint: aPoint 275819 "Answer an Array of two Booleans that indicate whether the given point is inside either arrow" 275820 275821 | retval f | 275822 275823 retval := { false . false }. 275824 (super containsPoint: aPoint) ifFalse: [^ retval ]. 275825 (closed or: [arrows == #none or: [vertices size < 2]]) ifTrue: [^ retval]. 275826 275827 (arrows == #forward or: [arrows == #both]) ifTrue: [ "arrowForms first has end form" 275828 f := self arrowForms first. 275829 retval at: 2 put: ((f pixelValueAt: aPoint - f offset) > 0) 275830 ]. 275831 (arrows == #back or: [arrows == #both]) ifTrue: [ "arrowForms last has start form" 275832 f := self arrowForms last. 275833 retval at: 1 put: ((f pixelValueAt: aPoint - f offset) > 0) 275834 ]. 275835 ^retval.! ! 275836 275837!PolygonMorph methodsFor: 'geometry' stamp: 'nice 2/16/2008 02:30'! 275838bounds: newBounds 275839 "This method has to be reimplemented since self extent: will also change self bounds origin, 275840 super bounds would leave me in wrong position when container is growing. 275841 Always change extent first then position" 275842 275843 self extent: newBounds extent; position: newBounds topLeft 275844! ! 275845 275846!PolygonMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 14:14'! 275847closestPointTo: aPoint 275848 | curvePoint closestPoint dist minDist | 275849 closestPoint := minDist := nil. 275850 self lineSegmentsDo: 275851 [:p1 :p2 | 275852 curvePoint := aPoint nearestPointOnLineFrom: p1 to: p2. 275853 dist := curvePoint dist: aPoint. 275854 (closestPoint isNil or: [dist < minDist]) 275855 ifTrue: 275856 [closestPoint := curvePoint. 275857 minDist := dist]]. 275858 ^closestPoint! ! 275859 275860!PolygonMorph methodsFor: 'geometry' stamp: 'marcus.denker 9/14/2008 19:00'! 275861closestSegmentTo: aPoint 275862 "Answer the starting index of my (big) segment nearest to aPoint" 275863 | curvePoint closestPoint dist minDist vertexIndex closestVertexIndex | 275864 vertexIndex := 0. 275865 closestVertexIndex := 0. 275866 closestPoint := minDist := nil. 275867 self lineSegmentsDo: 275868 [:p1 :p2 | 275869 (p1 = (self vertices at: vertexIndex + 1)) 275870 ifTrue: [ vertexIndex := vertexIndex + 1 ]. 275871 curvePoint := aPoint nearestPointOnLineFrom: p1 to: p2. 275872 dist := curvePoint dist: aPoint. 275873 (closestPoint isNil or: [dist < minDist]) 275874 ifTrue: [closestPoint := curvePoint. 275875 minDist := dist. 275876 closestVertexIndex := vertexIndex. ]]. 275877 ^ closestVertexIndex! ! 275878 275879!PolygonMorph methodsFor: 'geometry' stamp: 'di 9/24/2000 08:44'! 275880extent: newExtent 275881 "Not really advisable, but we can preserve most of the geometry if we don't 275882 shrink things too small." 275883 | safeExtent center | 275884 center := self referencePosition. 275885 safeExtent := newExtent max: 20@20. 275886 self setVertices: (vertices collect: 275887 [:p | p - center * (safeExtent asFloatPoint / (bounds extent max: 1@1)) + center])! ! 275888 275889!PolygonMorph methodsFor: 'geometry' stamp: 'edc 3/20/2002 14:24'! 275890flipHAroundX: centerX 275891 "Flip me horizontally around the center. If centerX is nil, compute my center of gravity." 275892 275893 | cent | 275894 cent := centerX 275895 ifNil: [bounds center x 275896 "cent := 0. 275897 vertices do: [:each | cent := cent + each x]. 275898 cent asFloat / vertices size"] "average is the center" 275899 ifNotNil: [centerX]. 275900 self setVertices: (vertices collect: [:vv | 275901 ((vv x - cent) * -1 + cent) @ vv y]) reversed.! ! 275902 275903!PolygonMorph methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'! 275904flipVAroundY: centerY 275905 "Flip me vertically around the center. If centerY is nil, compute my center of gravity." 275906 275907 | cent | 275908 cent := centerY 275909 ifNil: [bounds center y 275910 "cent := 0. 275911 vertices do: [:each | cent := cent + each y]. 275912 cent asFloat / vertices size"] "average is the center" 275913 ifNotNil: [centerY]. 275914 self setVertices: (vertices collect: [:vv | 275915 vv x @ ((vv y - cent) * -1 + cent)]) reversed.! ! 275916 275917!PolygonMorph methodsFor: 'geometry' stamp: 'nk 3/30/2002 12:29'! 275918intersectionsWith: aRectangle 275919 "Answer a Set of points where the given Rectangle intersects with me. 275920 Ignores arrowForms." 275921 275922 | retval | 275923 retval := IdentitySet new: 4. 275924 (self bounds intersects: aRectangle) ifFalse: [^ retval]. 275925 275926 self lineSegmentsDo: [ :lp1 :lp2 | | polySeg | 275927 polySeg := LineSegment from: lp1 to: lp2. 275928 aRectangle lineSegmentsDo: [ :rp1 :rp2 | | rectSeg int | 275929 rectSeg := LineSegment from: rp1 to: rp2. 275930 int := polySeg intersectionWith: rectSeg. 275931 int ifNotNil: [ retval add: int ]. 275932 ]. 275933 ]. 275934 275935 ^retval 275936! ! 275937 275938!PolygonMorph methodsFor: 'geometry' stamp: 'nk 2/15/2001 15:45'! 275939intersectionWithLineSegmentFromCenterTo: aPoint 275940 ^self closestPointTo: aPoint! ! 275941 275942!PolygonMorph methodsFor: 'geometry' stamp: 'nk 4/27/2003 16:15'! 275943intersects: aRectangle 275944 "Answer whether any of my segments intersects aRectangle, which is in World coordinates." 275945 | rect | 275946 (super intersects: aRectangle) ifFalse: [ ^false ]. 275947 rect := self bounds: aRectangle in: self world. 275948 self 275949 lineSegmentsDo: [:p1 :p2 | (rect intersectsLineFrom: p1 to: p2) 275950 ifTrue: [^ true]]. 275951 ^ false! ! 275952 275953!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:38'! 275954isBordered 275955 ^false! ! 275956 275957!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:06'! 275958lineBorderColor 275959 ^self borderColor! ! 275960 275961!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:06'! 275962lineBorderColor: aColor 275963 self borderColor: aColor! ! 275964 275965!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:07'! 275966lineBorderWidth 275967 275968 ^self borderWidth! ! 275969 275970!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:46'! 275971lineBorderWidth: anInteger 275972 275973 self borderWidth: anInteger! ! 275974 275975!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 16:48'! 275976lineColor 275977 ^self borderColor! ! 275978 275979!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 16:48'! 275980lineColor: aColor 275981 self borderColor: aColor! ! 275982 275983!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 16:47'! 275984lineWidth 275985 275986 ^self borderWidth! ! 275987 275988!PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:48'! 275989lineWidth: anInteger 275990 275991 self borderWidth: (anInteger rounded max: 1)! ! 275992 275993!PolygonMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 18:57'! 275994mergeDropThird: mv in: hv from: shared 275995 "We are merging two polygons. In this case, they have at least three identical shared vertices. Make sure they are sequential in each, and drop the middle one from vertex lists mv, hv, and shared. First vertices on lists are identical already." 275996 275997 "know (mv first = hv first)" 275998 275999 | mdrop vv | 276000 (shared includes: (mv at: mv size - 2)) 276001 ifTrue: [(shared includes: mv last) ifTrue: [mdrop := mv last]] 276002 ifFalse: 276003 [(shared includes: mv last) 276004 ifTrue: [(shared includes: mv second) ifTrue: [mdrop := mv first]]]. 276005 (shared includes: (mv third)) 276006 ifTrue: [(shared includes: mv second) ifTrue: [mdrop := mv second]]. 276007 mdrop ifNil: [^nil]. 276008 mv remove: mdrop. 276009 hv remove: mdrop. 276010 shared remove: mdrop. 276011 [shared includes: mv first] whileFalse: 276012 ["rotate them" 276013 276014 vv := mv removeFirst. 276015 mv addLast: vv]. 276016 [mv first = hv first] whileFalse: 276017 ["rotate him until same shared vertex is first" 276018 276019 vv := hv removeFirst. 276020 hv addLast: vv]! ! 276021 276022!PolygonMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 18:56'! 276023merge: aPolygon 276024 "Expand myself to enclose the other polygon. (Later merge overlapping or disjoint in a smart way.) For now, the two polygons must share at least two vertices. Shared vertices must come one after the other in each polygon. Polygons must not overlap." 276025 276026 | shared mv vv hv xx | 276027 shared := vertices select: [:mine | aPolygon vertices includes: mine]. 276028 shared size < 2 ifTrue: [^nil]. "not sharing a segment" 276029 mv := vertices asOrderedCollection. 276030 [shared includes: mv first] whileFalse: 276031 ["rotate them" 276032 276033 vv := mv removeFirst. 276034 mv addLast: vv]. 276035 hv := aPolygon vertices asOrderedCollection. 276036 [mv first = hv first] whileFalse: 276037 ["rotate him until same shared vertex is first" 276038 276039 vv := hv removeFirst. 276040 hv addLast: vv]. 276041 [shared size > 2] whileTrue: 276042 [shared := shared asOrderedCollection. 276043 (self 276044 mergeDropThird: mv 276045 in: hv 276046 from: shared) ifNil: [^nil]]. 276047 "works by side effect on the lists" 276048 (mv second) = hv last 276049 ifTrue: 276050 [mv 276051 removeFirst; 276052 removeFirst. 276053 ^self setVertices: (hv , mv) asArray]. 276054 (hv second) = mv last 276055 ifTrue: 276056 [hv 276057 removeFirst; 276058 removeFirst. 276059 ^self setVertices: (mv , hv) asArray]. 276060 (mv second) = (hv second) 276061 ifTrue: 276062 [hv removeFirst. 276063 mv remove: (mv second). 276064 xx := mv removeFirst. 276065 ^self setVertices: (hv , (Array with: xx) , mv reversed) asArray]. 276066 mv last = hv last 276067 ifTrue: 276068 [mv removeLast. 276069 hv removeFirst. 276070 ^self setVertices: (mv , hv reversed) asArray]. 276071 ^nil! ! 276072 276073!PolygonMorph methodsFor: 'geometry' stamp: 'nk 4/27/2003 15:39'! 276074nextDuplicateVertexIndex 276075 vertices 276076 doWithIndex: [:vert :index | ((index between: 2 and: vertices size - 1) 276077 and: [| epsilon v1 v2 | 276078 v1 := vertices at: index - 1. 276079 v2 := vertices at: index + 1. 276080 epsilon := ((v1 x - v2 x) abs max: (v1 y - v2 y) abs) 276081 // 32 max: 1. 276082 vert 276083 onLineFrom: v1 276084 to: v2 276085 within: epsilon]) 276086 ifTrue: [^ index]]. 276087 ^ 0! ! 276088 276089!PolygonMorph methodsFor: 'geometry' stamp: 'nk 4/18/2002 16:58'! 276090reduceVertices 276091 "Reduces the vertices size, when 3 vertices are on the same line with a 276092 little epsilon. Based on code by Steffen Mueller" 276093 | dup | 276094 [ (dup := self nextDuplicateVertexIndex) > 0 ] whileTrue: [ 276095 self setVertices: (vertices copyWithoutIndex: dup) 276096 ]. 276097 ^vertices size.! ! 276098 276099!PolygonMorph methodsFor: 'geometry' stamp: 'nk 9/4/2004 11:57'! 276100scale: scaleFactor 276101 | flex center ratio | 276102 ratio := self scaleFactor / scaleFactor. 276103 self borderWidth: ((self borderWidth / ratio) rounded max: 0). 276104 center := self referencePosition. 276105 flex := (MorphicTransform offset: center negated) 276106 withScale: ratio. 276107 self 276108 setVertices: (vertices 276109 collect: [:v | (flex transform: v) 276110 - flex offset]). 276111 super scale: scaleFactor.! ! 276112 276113!PolygonMorph methodsFor: 'geometry' stamp: 'nk 3/6/2001 16:36'! 276114straighten 276115 self setVertices: { vertices first . vertices last }! ! 276116 276117!PolygonMorph methodsFor: 'geometry' stamp: 'ar 10/6/2000 15:40'! 276118transformedBy: aTransform 276119 self setVertices: (self vertices collect:[:v| aTransform localPointToGlobal: v])! ! 276120 276121 276122!PolygonMorph methodsFor: 'geometry etoy' stamp: 'di 9/24/2000 08:38'! 276123referencePosition 276124 "Return the current reference position of the receiver" 276125 ^ self valueOfProperty: #referencePosition ifAbsent: [super referencePosition] 276126! ! 276127 276128!PolygonMorph methodsFor: 'geometry etoy' stamp: 'di 9/24/2000 09:21'! 276129rotationCenter 276130 "Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." 276131 | refPos | 276132 refPos := self valueOfProperty: #referencePosition 276133 ifAbsent: [^ 0.5@0.5]. 276134 ^ (refPos - self bounds origin) / self bounds extent asFloatPoint! ! 276135 276136!PolygonMorph methodsFor: 'geometry etoy' stamp: 'di 9/24/2000 09:31'! 276137rotationCenter: aPointOrNil 276138 "Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." 276139 | box | 276140 aPointOrNil isNil 276141 ifTrue: [self removeProperty: #referencePosition] 276142 ifFalse: [box := self bounds. 276143 self setProperty: #referencePosition 276144 toValue: box origin + (aPointOrNil * box extent)] 276145! ! 276146 276147 276148!PolygonMorph methodsFor: 'geometry testing' stamp: 'di 8/20/2000 14:33'! 276149containsPoint: aPoint 276150 (super containsPoint: aPoint) ifFalse: [^ false]. 276151 276152 closed & color isTransparent not ifTrue: 276153 [^ (self filledForm pixelValueAt: aPoint - bounds topLeft + 1) > 0]. 276154 276155 self lineSegmentsDo: 276156 [:p1 :p2 | 276157 (aPoint onLineFrom: p1 to: p2 within: (3 max: borderWidth+1//2) asFloat) 276158 ifTrue: [^ true]]. 276159 276160 self arrowForms do: 276161 [:f | (f pixelValueAt: aPoint - f offset) > 0 ifTrue: [^ true]]. 276162 276163 ^ false! ! 276164 276165 276166!PolygonMorph methodsFor: 'halo control' stamp: 'di 9/24/2000 09:42'! 276167rotationDegrees: degrees 276168 | flex center | 276169 (center := self valueOfProperty: #referencePosition) ifNil: 276170 [self setProperty: #referencePosition toValue: (center := self bounds center)]. 276171 flex := (MorphicTransform offset: center negated) 276172 withAngle: (degrees - self forwardDirection) degreesToRadians. 276173 self setVertices: (vertices collect: [:v | (flex transform: v) - flex offset]). 276174 self forwardDirection: degrees. 276175 276176! ! 276177 276178 276179!PolygonMorph methodsFor: 'initialization' stamp: 'di 9/8/2000 09:44'! 276180beSmoothCurve 276181 276182 smoothCurve == true ifFalse: 276183 [smoothCurve := true. 276184 self computeBounds]! ! 276185 276186!PolygonMorph methodsFor: 'initialization' stamp: 'di 9/8/2000 09:45'! 276187beStraightSegments 276188 276189 smoothCurve == false ifFalse: 276190 [smoothCurve := false. 276191 self computeBounds]! ! 276192 276193!PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'! 276194defaultBorderColor 276195 "answer the default border color/fill style for the receiver" 276196 ^ Color 276197 r: 0.0 276198 g: 0.419 276199 b: 0.935! ! 276200 276201!PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'! 276202defaultColor 276203 "answer the default color/fill style for the receiver" 276204 ^ Color orange! ! 276205 276206!PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:10'! 276207initialize 276208"initialize the state of the receiver" 276209 super initialize. 276210"" 276211 vertices := Array 276212 with: 5 @ 0 276213 with: 20 @ 10 276214 with: 0 @ 20. 276215 closed := true. 276216 smoothCurve := false. 276217 arrows := #none. 276218 self computeBounds! ! 276219 276220!PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:09'! 276221vertices: verts color: aColor borderWidth: borderWidthInteger borderColor: anotherColor 276222 super initialize. 276223"" 276224 vertices := verts. 276225 color := aColor. 276226 borderWidth := borderWidthInteger. 276227 borderColor := anotherColor. 276228 closed := vertices size > 2. 276229 arrows := #none. 276230 self computeBounds! ! 276231 276232 276233!PolygonMorph methodsFor: 'menu' stamp: 'wiz 12/29/2004 14:42'! 276234addCustomMenuItems: aMenu hand: aHandMorph 276235 | | 276236 super addCustomMenuItems: aMenu hand: aHandMorph. 276237 aMenu 276238 addUpdating: #handlesShowingPhrase 276239 target: self 276240 action: #showOrHideHandles. 276241 vertices size > 2 276242 ifTrue: [ self addPolyLIneCurveMenuItems: aMenu hand: aHandMorph ]. 276243 aMenu add: 'specify dashed line' translated action: #specifyDashedLine. 276244 "aMenu add: 'use debug border' translated action: #showSegmentsBorderStyle." 276245 self isOpen 276246 ifTrue: [self addPolyArrowMenuItems: aMenu hand: aHandMorph] 276247 ifFalse: [self addPolyShapingMenuItems: aMenu hand: aHandMorph]! ! 276248 276249!PolygonMorph methodsFor: 'menu' stamp: 'wiz 12/29/2004 13:53'! 276250addPolyArrowMenuItems: aMenu hand: aHandMorph 276251aMenu addLine. 276252 aMenu 276253 addWithLabel: '---' 276254 enablement: [self isOpen 276255 and: [arrows ~~ #none]] 276256 action: #makeNoArrows. 276257 aMenu 276258 addWithLabel: '-->' 276259 enablement: [self isOpen 276260 and: [arrows ~~ #forward]] 276261 action: #makeForwardArrow. 276262 aMenu 276263 addWithLabel: '<--' 276264 enablement: [self isOpen 276265 and: [arrows ~~ #back]] 276266 action: #makeBackArrow. 276267 aMenu 276268 addWithLabel: '<->' 276269 enablement: [self isOpen 276270 and: [arrows ~~ #both]] 276271 action: #makeBothArrows. 276272 aMenu add: 'customize arrows' translated action: #customizeArrows:. 276273 (self hasProperty: #arrowSpec) 276274 ifTrue: [aMenu add: 'standard arrows' translated action: #standardArrows]! ! 276275 276276!PolygonMorph methodsFor: 'menu' stamp: 'wiz 4/1/2006 19:05'! 276277addPolyLIneCurveMenuItems: aMenu hand: aHandMorph 276278 276279 aMenu addLine; 276280 addUpdating: #openOrClosePhrase 276281 target: self 276282 action: #makeOpenOrClosed. 276283 276284 aMenu 276285 addUpdating: #smoothOrSegmentedPhrase 276286 target: self 276287 action: #toggleSmoothing.! ! 276288 276289!PolygonMorph methodsFor: 'menu' stamp: 'wiz 12/29/2004 13:50'! 276290addPolyShapingMenuItems: aMenu hand: aHandMorph 276291 aMenu addLine. 276292 aMenu 276293 addWithLabel: 'make inscribed diamondOval' 276294 enablement: [self isClosed ] 276295 action: #diamondOval. 276296 aMenu 276297 addWithLabel: 'make enclosing rectangleOval' 276298 enablement: [self isClosed ] 276299 action: #rectOval. 276300 ! ! 276301 276302!PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 19:23'! 276303arrowLength: aLength 276304 "Assumes that I have exactly two vertices" 276305 276306 | theta horizontalOffset verticalOffset newTip delta | 276307 delta := vertices second - vertices first. 276308 theta := delta theta. 276309 horizontalOffset := aLength * (theta cos). 276310 verticalOffset := aLength * (theta sin). 276311 newTip := vertices first + (horizontalOffset @ verticalOffset). 276312 self verticesAt: 2 put: newTip! ! 276313 276314!PolygonMorph methodsFor: 'menu' stamp: 'di 10/3/2000 09:09'! 276315arrowSpec: specPt 276316 "Specify a custom arrow for this line. 276317 specPt x abs gives the length of the arrow (point to base) in terms of borderWidth. 276318 If specPt x is negative, then the base of the arrow will be concave. 276319 specPt y abs gives the width of the arrow. 276320 The standard arrow is equivalent to arrowSpec: 5@4. 276321 See arrowBoundsAt:From: for details." 276322 276323 self setProperty: #arrowSpec toValue: specPt. 276324 self computeBounds! ! 276325 276326!PolygonMorph methodsFor: 'menu' stamp: 'nk 2/26/2001 20:11'! 276327arrows 276328 ^arrows! ! 276329 276330!PolygonMorph methodsFor: 'menu' stamp: 'marcus.denker 11/10/2008 10:04'! 276331customizeArrows: evt 276332 | handle origin aHand | 276333 aHand := evt ifNil: [self primaryHand] ifNotNil: [evt hand]. 276334 origin := aHand position. 276335 handle := HandleMorph new 276336 forEachPointDo: 276337 [:newPoint | handle removeAllMorphs. 276338 handle addMorph: 276339 (LineMorph from: origin to: newPoint color: Color black width: 1). 276340 self arrowSpec: (newPoint - origin) / 5.0] 276341 lastPointDo: 276342 [:newPoint | handle deleteBalloon. 276343 self halo ifNotNil: [:halo | halo addHandles].]. 276344 aHand attachMorph: handle. 276345 handle setProperty: #helpAtCenter toValue: true. 276346 handle showBalloon: 276347'Move cursor left and right 276348to change arrow length and style. 276349Move it up and down to change width. 276350Click when done.' hand: evt hand. 276351 handle startStepping! ! 276352 276353!PolygonMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:57'! 276354handlesShowingPhrase 276355 ^ (self showingHandles 276356 ifTrue: ['hide handles'] 276357 ifFalse: ['show handles']) translated! ! 276358 276359!PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'! 276360makeBackArrow 276361 arrows := #back. 276362 self computeBounds! ! 276363 276364!PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'! 276365makeBothArrows 276366 arrows := #both. 276367 self computeBounds! ! 276368 276369!PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:27'! 276370makeClosed 276371 closed := true. 276372 handles ifNotNil: [self removeHandles; addHandles]. 276373 self computeBounds! ! 276374 276375!PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'! 276376makeForwardArrow 276377 arrows := #forward. 276378 self computeBounds! ! 276379 276380!PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'! 276381makeNoArrows 276382 arrows := #none. 276383 self computeBounds! ! 276384 276385!PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:27'! 276386makeOpen 276387 closed := false. 276388 handles ifNotNil: [self removeHandles; addHandles]. 276389 self computeBounds! ! 276390 276391!PolygonMorph methodsFor: 'menu' stamp: 'di 9/7/2000 13:10'! 276392quickFill: ignored! ! 276393 276394!PolygonMorph methodsFor: 'menu' stamp: 'tk 9/2/97 16:04'! 276395removeHandles 276396 "tk 9/2/97 allow it to be called twice (when nil already)" 276397 276398 handles ifNotNil: [ 276399 handles do: [:h | h delete]. 276400 handles := nil].! ! 276401 276402!PolygonMorph methodsFor: 'menu' stamp: 'di 9/24/2000 09:25'! 276403setRotationCenterFrom: aPoint 276404 "Polygons store their referencePosition." 276405 self setProperty: #referencePosition toValue: aPoint! ! 276406 276407!PolygonMorph methodsFor: 'menu' stamp: 'sw 8/19/2000 15:17'! 276408showingHandles 276409 ^ handles notNil! ! 276410 276411!PolygonMorph methodsFor: 'menu' stamp: 'sw 8/19/2000 15:16'! 276412showOrHideHandles 276413 self showingHandles 276414 ifTrue: [self removeHandles] 276415 ifFalse: [self addHandles]! ! 276416 276417!PolygonMorph methodsFor: 'menu' stamp: 'DamienCassou 9/29/2009 13:06'! 276418specifyDashedLine 276419 276420 | executableSpec newSpec | 276421 executableSpec := UIManager default 276422 request: 276423'Enter a dash specification as 276424{ major dash length. minor dash length. minor dash color } 276425The major dash will have the normal border color. 276426A blank response will remove the dash specification. 276427[Note: You may give 5 items as, eg, {10. 5. Color white. 0. 3} 276428where the 4th ityem is zero, and the 5th is the number of pixels 276429by which the dashes will move in each step of animation]' translated 276430 initialAnswer: '{ 10. 5. Color red }'. 276431 executableSpec isEmptyOrNil ifTrue: 276432 [^ self stopStepping; dashedBorder: nil]. 276433 newSpec := [Compiler evaluate: executableSpec] ifError: 276434 [^ self stopStepping; dashedBorder: nil]. 276435 newSpec first isNumber & newSpec second isNumber & newSpec third isColor ifFalse: 276436 [^ self stopStepping; dashedBorder: nil]. 276437 newSpec size = 3 ifTrue: 276438 [^ self stopStepping; dashedBorder: newSpec]. 276439 (newSpec size = 5 and: [newSpec fourth isNumber & newSpec fifth isNumber]) ifTrue: 276440 [^ self dashedBorder: newSpec; startStepping]. 276441! ! 276442 276443!PolygonMorph methodsFor: 'menu' stamp: 'di 10/3/2000 07:12'! 276444standardArrows 276445 276446 self removeProperty: #arrowSpec. 276447 self computeBounds! ! 276448 276449!PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:31'! 276450toggleHandles 276451 276452 handles ifNil: [self addHandles] ifNotNil: [self removeHandles]. 276453 276454! ! 276455 276456!PolygonMorph methodsFor: 'menu' stamp: 'di 9/7/2000 15:43'! 276457toggleSmoothing 276458 276459 smoothCurve := smoothCurve not. 276460 handles ifNotNil: [self removeHandles; addHandles]. 276461 self computeBounds! ! 276462 276463!PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 18:06'! 276464unrotatedLength 276465 "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is" 276466 276467 vertices size == 2 ifTrue: 276468 [^ (vertices second - vertices first) r]. 276469 276470 ^ ((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) height! ! 276471 276472!PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 18:54'! 276473unrotatedLength: aLength 276474 "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is" 276475 276476 vertices size == 2 ifTrue: [^ self arrowLength: aLength]. 276477 276478 self setVertices: ((((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) height: aLength) rotationDegrees: 0) vertices! ! 276479 276480!PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 18:17'! 276481unrotatedWidth 276482 "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is" 276483 276484 vertices size == 2 ifTrue: [^ self borderWidth]. 276485 ^ ((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) width! ! 276486 276487!PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 18:18'! 276488unrotatedWidth: aWidth 276489 "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is" 276490 276491 self borderWidth: aWidth! ! 276492 276493 276494!PolygonMorph methodsFor: 'rotate scale and flex' stamp: 'di 11/28/2001 18:23'! 276495addFlexShellIfNecessary 276496 "When scaling or rotating from a halo, I can do this without a flex shell" 276497 276498 ^ self 276499! ! 276500 276501!PolygonMorph methodsFor: 'rotate scale and flex' stamp: 'di 9/24/2000 08:42'! 276502rotationDegrees 276503 276504 ^ self forwardDirection! ! 276505 276506 276507!PolygonMorph methodsFor: 'rounding' stamp: 'ka 12/4/2005 00:56'! 276508cornerStyle: aSymbol 276509 "Set the receiver's corner style. But, in this case, do *not*" 276510 276511 self removeProperty: #cornerStyle. 276512 self changed! ! 276513 276514 276515!PolygonMorph methodsFor: 'shaping' stamp: 'wiz 1/8/2005 19:27'! 276516diamondOval 276517 "Set my vertices to an array of edge midpoint vertices. 276518 Order of vertices is in the tradion of warpblt quads." 276519 | b r | 276520 b := self bounds. 276521 r := {b leftCenter. b bottomCenter. b rightCenter. b topCenter}. 276522 self setVertices: r! ! 276523 276524!PolygonMorph methodsFor: 'shaping' stamp: 'wiz 1/8/2005 19:20'! 276525rectOval 276526 "Set my vertices to an array of corner vertices. 276527 Order of vertices is in the tradion of warpblt quads." 276528 276529 self setVertices: self bounds corners.! ! 276530 276531 276532!PolygonMorph methodsFor: 'smoothing' stamp: 'wiz 1/7/2005 19:53'! 276533coefficients 276534 "Compute an array for the coefficients." 276535 | verts vertXs vertYs slopeXs slopeYs coefficients | 276536 curveState 276537 ifNotNil: [^ curveState at: 1]. 276538 verts := self vertices. 276539 verts size < 1 276540 ifTrue: [^ self]. 276541 "Less than three points handled as segments by our 276542 lineSegmentsDo:" 276543 (self isCurvier) 276544 ifFalse: [closed 276545 ifTrue: [verts := verts , verts first asOrderedCollection]]. 276546 coefficients := {vertXs := verts 276547 collect: [:p | p x asFloat]. slopeXs := self slopes: vertXs. vertXs changeInSlopes: slopeXs. vertXs changeOfChangesInSlopes: slopeXs. vertYs := verts 276548 collect: [:p | p y asFloat]. slopeYs := self slopes: vertYs. vertYs changeInSlopes: slopeYs. vertYs changeOfChangesInSlopes: slopeYs. Array new: verts size withAll: 12}. 276549 coefficients 276550 at: 9 276551 put: ((1 to: verts size) 276552 collect: [:i | (coefficients cubicPointPolynomialAt: i) bestSegments]). 276553 (self isCurvier) 276554 ifFalse: [closed 276555 ifTrue: [coefficients := coefficients 276556 collect: [:each | each allButLast]]]. 276557 curveState := {coefficients. nil. nil}. 276558 self computeNextToEndPoints. 276559 ^ coefficients! ! 276560 276561!PolygonMorph methodsFor: 'smoothing' stamp: 'dgd 2/22/2003 14:15'! 276562computeNextToEndPoints 276563 | pointAfterFirst pointBeforeLast | 276564 pointAfterFirst := nil. 276565 self lineSegmentsDo: 276566 [:p1 :p2 | 276567 pointAfterFirst isNil ifTrue: [pointAfterFirst := p2 asIntegerPoint]. 276568 pointBeforeLast := p1 asIntegerPoint]. 276569 curveState at: 2 put: pointAfterFirst. 276570 curveState at: 3 put: pointBeforeLast! ! 276571 276572!PolygonMorph methodsFor: 'smoothing' stamp: 'dgd 2/22/2003 14:16'! 276573derivs: a first: point1 second: point2 third: point3 276574 "Compute the first, second and third derivitives (in coeffs) from 276575 the Points in this Path (coeffs at: 1 and coeffs at: 5)." 276576 276577 | len v anArray | 276578 len := a size. 276579 len < 2 ifTrue: [^self]. 276580 len > 2 276581 ifTrue: 276582 [v := Array new: len. 276583 v at: 1 put: 4.0. 276584 anArray := Array new: len. 276585 anArray at: 1 put: 6.0 * (a first - (a second * 2.0) + (a third)). 276586 2 to: len - 2 276587 do: 276588 [:i | 276589 v at: i put: 4.0 - (1.0 / (v at: i - 1)). 276590 anArray at: i 276591 put: 6.0 * ((a at: i) - ((a at: i + 1) * 2.0) + (a at: i + 2)) 276592 - ((anArray at: i - 1) / (v at: i - 1))]. 276593 point2 at: len - 1 put: (anArray at: len - 2) / (v at: len - 2). 276594 len - 2 to: 2 276595 by: 0 - 1 276596 do: 276597 [:i | 276598 point2 at: i 276599 put: ((anArray at: i - 1) - (point2 at: i + 1)) / (v at: i - 1)]]. 276600 point2 at: 1 put: (point2 at: len put: 0.0). 276601 1 to: len - 1 276602 do: 276603 [:i | 276604 point1 at: i 276605 put: (a at: i + 1) - (a at: i) 276606 - (((point2 at: i) * 2.0 + (point2 at: i + 1)) / 6.0). 276607 point3 at: i put: (point2 at: i + 1) - (point2 at: i)]! ! 276608 276609!PolygonMorph methodsFor: 'smoothing' stamp: 'wiz 1/8/2005 19:24'! 276610lineSegmentsDo: endPointsBlock 276611 "Emit a sequence of segment endpoints into endPointsBlock." 276612 "Unlike the method this one replaces we expect the curve 276613 coefficents not the dirivatives" 276614 "Also unlike the replaced method the smooth closed curve 276615 does 276616 not need an extra vertex. 276617 We take care of the extra endpoint here. Just like for 276618 segmented curves." 276619 | n t x y x1 x2 x3 y1 y2 y3 beginPoint endPoint cs | 276620 vertices size < 1 276621 ifTrue: [^ self]. 276622 "test too few vertices first" 276623 self isCurvy 276624 ifFalse: [beginPoint := nil. 276625 "smoothCurve 276626 ifTrue: [cs := self coefficients]." 276627 "some things still depend on smoothCurves having 276628 curveState" 276629 vertices 276630 do: [:vert | 276631 beginPoint 276632 ifNotNil: [endPointsBlock value: beginPoint value: vert]. 276633 beginPoint := vert]. 276634 (closed 276635 or: [vertices size = 1]) 276636 ifTrue: [endPointsBlock value: beginPoint value: vertices first]. 276637 ^ self]. 276638 "For curves we include all the interpolated sub segments." 276639 "self assert: [(vertices size > 2 )]. " 276640 cs := self coefficients. 276641 beginPoint := (x := cs first first) @ (y := cs fifth first). 276642 (closed 276643 ifTrue: [1 to: cs first size] 276644 ifFalse: [1 to: cs first size - 1]) 276645 do: [:i | 276646 "taylor series coefficients" 276647 x1 := cs second at: i. 276648 y1 := cs sixth at: i. 276649 x2 := cs third at: i. 276650 y2 := cs seventh at: i. 276651 x3 := cs fourth at: i. 276652 y3 := cs eighth at: i. 276653 n := cs ninth at: i. 276654 "guess n 276655 n := 5 max: (x2 abs + y2 abs * 2.0 + (cs third atWrap: 276656 i 276657 + 1) abs + (cs seventh atWrap: i + 1) abs / 100.0) 276658 rounded." 276659 1 276660 to: n - 1 276661 do: [:j | 276662 t := j asFloat / n asFloat. 276663 endPoint := x3 * t + x2 * t + x1 * t + x @ (y3 * t + y2 * t + y1 * t + y). 276664 endPointsBlock value: beginPoint value: endPoint. 276665 beginPoint := endPoint]. 276666 endPoint := (x := cs first atWrap: i + 1) @ (y := cs fifth atWrap: i + 1). 276667 endPointsBlock value: beginPoint value: endPoint. 276668 beginPoint := endPoint]! ! 276669 276670!PolygonMorph methodsFor: 'smoothing' stamp: 'wiz 11/16/2004 19:54'! 276671nextToFirstPoint 276672 "For arrow direction" 276673 self isCurvy 276674 ifTrue: [curveState 276675 ifNil: [self coefficients]. 276676 ^ curveState second] 276677 ifFalse: [^ vertices second]! ! 276678 276679!PolygonMorph methodsFor: 'smoothing' stamp: 'wiz 11/16/2004 19:51'! 276680nextToLastPoint 276681 "For arrow direction" 276682 self isCurvy 276683 ifTrue: [curveState 276684 ifNil: [self coefficients]. 276685 ^ curveState third] 276686 ifFalse: [^ vertices at: vertices size - 1]! ! 276687 276688!PolygonMorph methodsFor: 'smoothing' stamp: 'wiz 1/7/2005 19:53'! 276689slopes: knots 276690 "Choose slopes according to state of polygon and preferences" 276691 self isCurvy 276692 ifFalse: [^ knots segmentedSlopes]. 276693 ^ (closed 276694 and: [self isCurvier]) 276695 ifTrue: [knots closedCubicSlopes] 276696 ifFalse: [knots naturalCubicSlopes]! ! 276697 276698!PolygonMorph methodsFor: 'smoothing' stamp: 'nk 4/23/2002 15:48'! 276699straightLineSegmentsDo: endPointsBlock 276700 "Emit a sequence of segment endpoints into endPointsBlock. 276701 Work the same way regardless of whether I'm curved." 276702 | beginPoint | 276703 beginPoint := nil. 276704 vertices do: 276705 [:vert | beginPoint ifNotNil: 276706 [endPointsBlock value: beginPoint 276707 value: vert]. 276708 beginPoint := vert]. 276709 (closed or: [vertices size = 1]) 276710 ifTrue: [endPointsBlock value: beginPoint 276711 value: vertices first].! ! 276712 276713 276714!PolygonMorph methodsFor: 'stepping and presenter' stamp: 'dgd 2/22/2003 18:58'! 276715step 276716 borderDashSpec ifNil: [^super step]. 276717 borderDashSpec size < 5 ifTrue: [^super step]. 276718 276719 "Only for dashed lines with creep" 276720 borderDashSpec at: 4 put: (borderDashSpec fourth) + borderDashSpec fifth. 276721 self changed. 276722 ^super step! ! 276723 276724 276725!PolygonMorph methodsFor: 'testing' stamp: 'wiz 7/18/2004 23:00'! 276726hasArrows 276727 "Are all the conditions meet for having arrows?" 276728 ^ (closed 276729 or: [arrows == #none 276730 or: [vertices size < 2]]) not! ! 276731 276732!PolygonMorph methodsFor: 'testing' stamp: 'wiz 1/7/2005 19:59'! 276733isCurvier 276734 "Test used by smoothing routines. If true use true closed curve splines for closed curves. If not mimic old stodgy curveMorph curves with one sharp bend.. Override this routine in classes where backward compatability is still needed." 276735 ^ (Preferences valueOfFlag: #Curvier)! ! 276736 276737!PolygonMorph methodsFor: 'testing' stamp: 'wiz 5/2/2004 22:03'! 276738isCurvy 276739 "Test for significant curves. 276740 Small smoothcurves in practice are straight." 276741 ^ smoothCurve 276742 and: [vertices size > 2]! ! 276743 276744!PolygonMorph methodsFor: 'testing' stamp: 'nk 10/13/2003 18:36'! 276745isLineMorph 276746 ^closed not! ! 276747 276748!PolygonMorph methodsFor: 'testing' stamp: 'di 9/9/2000 09:24'! 276749stepTime 276750 276751 ^ 100! ! 276752 276753!PolygonMorph methodsFor: 'testing' stamp: 'dgd 2/22/2003 18:58'! 276754wantsSteps 276755 super wantsSteps ifTrue: [^true]. 276756 276757 "For crawling ants effect of dashed line." 276758 borderDashSpec ifNil: [^false]. 276759 ^borderDashSpec size = 5 and: [(borderDashSpec fifth) > 0]! ! 276760 276761 276762!PolygonMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:18'! 276763canHaveFillStyles 276764 "Return true if the receiver can have general fill styles; not just colors. 276765 This method is for gradually converting old morphs." 276766 ^true! ! 276767 276768!PolygonMorph methodsFor: 'visual properties' stamp: 'di 9/19/2000 22:00'! 276769fillStyle 276770 276771 self isOpen 276772 ifTrue: [^ self borderColor "easy access to line color from halo"] 276773 ifFalse: [^ super fillStyle]! ! 276774 276775!PolygonMorph methodsFor: 'visual properties' stamp: 'wiz 1/7/2005 20:39'! 276776fillStyle: newColor 276777 276778 self isOpen 276779 ifTrue: [^ self borderColor: newColor asColor "easy access to line color from halo"] 276780 ifFalse: [^ super fillStyle: newColor]! ! 276781 276782 276783!PolygonMorph methodsFor: 'private' stamp: 'di 10/3/2000 09:02'! 276784arrowBoundsAt: endPoint from: priorPoint 276785 "Answer a triangle oriented along the line from priorPoint to endPoint." 276786 | d v angle wingBase arrowSpec length width | 276787 v := endPoint - priorPoint. 276788 angle := v degrees. 276789 d := borderWidth max: 1. 276790 arrowSpec := self valueOfProperty: #arrowSpec ifAbsent: [5@4]. 276791 length := arrowSpec x abs. width := arrowSpec y abs. 276792 wingBase := endPoint + (Point r: d * length degrees: angle + 180.0). 276793 arrowSpec x >= 0 276794 ifTrue: [^ { endPoint. 276795 wingBase + (Point r: d * width degrees: angle + 125.0). 276796 wingBase + (Point r: d * width degrees: angle - 125.0) }] 276797 ifFalse: ["Negative length means concave base." 276798 ^ { endPoint. 276799 wingBase + (Point r: d * width degrees: angle + 125.0). 276800 wingBase. 276801 wingBase + (Point r: d * width degrees: angle - 125.0) }]! ! 276802 276803!PolygonMorph methodsFor: 'private' stamp: 'wiz 6/22/2004 15:54'! 276804arrowForms 276805 "ArrowForms are computed only upon demand" 276806 arrowForms 276807 ifNotNil: [^ arrowForms]. 276808 arrowForms := Array new. 276809 self hasArrows 276810 ifFalse: [^ arrowForms]. 276811 (arrows == #forward 276812 or: [arrows == #both]) 276813 ifTrue: [arrowForms := arrowForms 276814 copyWith: (self computeArrowFormAt: vertices last from: self nextToLastPoint)]. 276815 (arrows == #back 276816 or: [arrows == #both]) 276817 ifTrue: [arrowForms := arrowForms 276818 copyWith: (self computeArrowFormAt: vertices first from: self nextToFirstPoint)]. 276819 ^ arrowForms! ! 276820 276821!PolygonMorph methodsFor: 'private' stamp: 'ar 5/25/2000 18:04'! 276822borderForm 276823 "A form must be created for drawing the border whenever the borderColor is translucent." 276824 276825 | borderCanvas | 276826 borderForm ifNotNil: [^ borderForm]. 276827 borderCanvas := (Display defaultCanvasClass extent: bounds extent depth: 1) 276828 shadowColor: Color black. 276829 borderCanvas translateBy: bounds topLeft negated 276830 during:[:tempCanvas| self drawBorderOn: tempCanvas]. 276831 borderForm := borderCanvas form. 276832 self arrowForms do: 276833 [:f | "Eliminate overlap between line and arrowheads if transparent." 276834 borderForm copy: f boundingBox from: f to: f offset - self position rule: Form erase]. 276835 ^ borderForm! ! 276836 276837!PolygonMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 18:56'! 276838computeArrowFormAt: endPoint from: priorPoint 276839 "Compute a triangle oriented along the line from priorPoint to 276840 endPoint. Then draw those lines in a form and return that 276841 form, with appropriate offset" 276842 276843 | p1 pts box arrowForm bb origin | 276844 pts := self arrowBoundsAt: endPoint from: priorPoint. 276845 box := ((pts first rect: pts last) encompass: (pts second)) expandBy: 1. 276846 arrowForm := Form extent: box extent asIntegerPoint. 276847 bb := (BitBlt current toForm: arrowForm) 276848 sourceForm: nil; 276849 fillColor: Color black; 276850 combinationRule: Form over; 276851 width: 1; 276852 height: 1. 276853 origin := box topLeft. 276854 p1 := pts last - origin. 276855 pts do: 276856 [:p | 276857 bb drawFrom: p1 to: p - origin. 276858 p1 := p - origin]. 276859 arrowForm convexShapeFill: Color black. 276860 ^arrowForm offset: box topLeft! ! 276861 276862!PolygonMorph methodsFor: 'private' stamp: 'wiz 2/12/2006 00:04'! 276863computeBounds 276864 | oldBounds delta excludeHandles | 276865 vertices ifNil: [^ self]. 276866 276867 self changed. 276868 oldBounds := bounds. 276869 self releaseCachedState. 276870 bounds := self curveBounds expanded. 276871 self arrowForms do: 276872 [:f | bounds := bounds merge: (f offset extent: f extent)]. 276873 handles ifNotNil: [self updateHandles]. 276874 276875 "since we are directly updating bounds, see if any ordinary submorphs exist and move them accordingly" 276876 (oldBounds notNil and: [(delta := bounds origin - oldBounds origin) ~= (0@0)]) ifTrue: [ 276877 excludeHandles := IdentitySet new. 276878 handles ifNotNil: [excludeHandles addAll: handles]. 276879 self submorphsDo: [ :each | 276880 (excludeHandles includes: each) ifFalse: [ 276881 each position: each position + delta 276882 ]. 276883 ]. 276884 ]. 276885 self layoutChanged. 276886 self changed. 276887! ! 276888 276889!PolygonMorph methodsFor: 'private' stamp: 'wiz 2/12/2006 02:58'! 276890curveBounds 276891 "Compute the bounds from actual curve traversal, with 276892 leeway for borderWidth. 276893 Also note the next-to-first and next-to-last points for arrow 276894 directions." 276895 "wiz - to avoid roundoff errors we return unrounded curvebounds." 276896 "we expect our receiver to take responsibility for approriate rounding adjustment." 276897 "hint: this is most likely 'self curveBounds expanded' " 276898 | pointAfterFirst pointBeforeLast oX oY cX cY | 276899 self isCurvy 276900 ifFalse: [^ (Rectangle encompassing: vertices) 276901 expandBy: borderWidth * 0.5 ]. 276902 curveState := nil. 276903 "Force recomputation" 276904 "curveBounds := vertices first corner: vertices last." 276905 pointAfterFirst := nil. 276906 self 276907 lineSegmentsDo: [:p1 :p2 | 276908 pointAfterFirst isNil 276909 ifTrue: [pointAfterFirst := p2 floor . 276910 oX := cX := p1 x. 276911 oY := cY := p1 y. ]. 276912 "curveBounds := curveBounds encompass: p2 ." 276913 oX:= oX min: p2 x. 276914 cX := cX max: p2 x. 276915 oY := oY min: p2 y. 276916 cY := cY max: p2 y. 276917 pointBeforeLast := p1 floor ]. 276918 curveState at: 2 put: pointAfterFirst. 276919 curveState at: 3 put: pointBeforeLast. 276920 ^ ( oX @ oY corner: cX @ cY ) expandBy: borderWidth * 0.5 ! ! 276921 276922!PolygonMorph methodsFor: 'private' stamp: 'di 9/7/2000 13:30'! 276923filledForm 276924 "Note: The filled form is actually 2 pixels bigger than bounds, and the point corresponding to this morphs' position is at 1@1 in the form. This is due to the details of the fillig routines, at least one of which requires an extra 1-pixel margin around the outside. Computation of the filled form is done only on demand." 276925 | bb origin | 276926 closed ifFalse: [^ filledForm := nil]. 276927 filledForm ifNotNil: [^ filledForm]. 276928 filledForm := Form extent: bounds extent+2. 276929 276930 "Draw the border..." 276931 bb := (BitBlt current toForm: filledForm) sourceForm: nil; fillColor: Color black; 276932 combinationRule: Form over; width: 1; height: 1. 276933 origin := bounds topLeft asIntegerPoint-1. 276934 self lineSegmentsDo: [:p1 :p2 | bb drawFrom: p1 asIntegerPoint-origin 276935 to: p2 asIntegerPoint-origin]. 276936 276937 "Fill it in..." 276938 filledForm convexShapeFill: Color black. 276939 276940 (borderColor isColor and: [borderColor isTranslucentColor]) ifTrue: 276941 ["If border is stored as a form, then erase any overlap now." 276942 filledForm copy: self borderForm boundingBox from: self borderForm 276943 to: 1@1 rule: Form erase]. 276944 276945 ^ filledForm! ! 276946 276947!PolygonMorph methodsFor: 'private' stamp: 'di 9/7/2000 16:17'! 276948getVertices 276949 276950 smoothCurve ifFalse: [^ vertices]. 276951 276952 "For curves, enumerate the full set of interpolated points" 276953 ^ Array streamContents: 276954 [:s | self lineSegmentsDo: [:pt1 :pt2 | s nextPut: pt1]]! ! 276955 276956!PolygonMorph methodsFor: 'private' stamp: 'di 8/31/2000 13:46'! 276957includesHandle: aMorph 276958 276959 handles ifNil: [^ false]. 276960 ^ handles includes: aMorph! ! 276961 276962!PolygonMorph methodsFor: 'private' stamp: 'di 11/21/97 21:29'! 276963lineSegments 276964 | lineSegments | 276965 lineSegments := OrderedCollection new. 276966 self lineSegmentsDo: [:p1 :p2 | lineSegments addLast: (Array with: p1 with: p2)]. 276967 ^ lineSegments! ! 276968 276969!PolygonMorph methodsFor: 'private' stamp: 'marcus.denker 11/10/2008 10:04'! 276970privateMoveBy: delta 276971 super privateMoveBy: delta. 276972 vertices := vertices collect: [:p | p + delta]. 276973 self arrowForms do: [:f | f offset: f offset + delta]. 276974 curveState := nil. "Force recomputation" 276975 (self valueOfProperty: #referencePosition) ifNotNil: 276976 [:oldPos | self setProperty: #referencePosition toValue: oldPos + delta]! ! 276977 276978!PolygonMorph methodsFor: 'private' stamp: 'di 9/8/2000 10:36'! 276979setVertices: newVertices 276980 vertices := newVertices. 276981 handles ifNotNil: [self removeHandles; addHandles]. 276982 self computeBounds! ! 276983 276984!PolygonMorph methodsFor: 'private' stamp: 'nk 3/27/2001 21:23'! 276985transformVerticesFrom: oldOwner to: newOwner 276986 | oldTransform newTransform world newVertices | 276987 world := self world. 276988 oldTransform := oldOwner 276989 ifNil: [ IdentityTransform new ] 276990 ifNotNil: [ oldOwner transformFrom: world ]. 276991 newTransform := newOwner 276992 ifNil: [ IdentityTransform new ] 276993 ifNotNil: [ newOwner transformFrom: world ]. 276994 newVertices := vertices collect: [ :ea | newTransform globalPointToLocal: 276995 (oldTransform localPointToGlobal: ea) ]. 276996 self setVertices: newVertices. 276997! ! 276998 276999"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 277000 277001PolygonMorph class 277002 instanceVariableNames: ''! 277003 277004!PolygonMorph class methodsFor: 'instance creation' stamp: 'wiz 7/13/2005 00:43'! 277005arrowPrototype 277006 "Answer an instance of the receiver that will serve as a prototypical arrow" 277007 277008 | aa | 277009 aa := self new. 277010 aa vertices: (Array with: 0@0 with: 40@40) 277011 color: Color black 277012 borderWidth: 2 277013 borderColor: Color black. 277014 "aa setProperty: #noNewVertices toValue: true." 277015 "Revert to expected behavior. Remove vestigial code." 277016 aa makeForwardArrow. "is already open" 277017 aa computeBounds. 277018 ^ aa! ! 277019 277020!PolygonMorph class methodsFor: 'instance creation' stamp: 'di 10/18/2001 03:56'! 277021fromHand: hand 277022 "Let the user draw a polygon, clicking at each vertex, and ending 277023 by clicking within 5 of the first point..." 277024 | p1 poly oldVerts pN opposite | 277025 Cursor crossHair showWhile: 277026 [[Sensor anyButtonPressed] whileFalse: 277027 [self currentWorld displayWorldSafely; runStepMethods]. 277028 p1 := Sensor cursorPoint]. 277029 opposite := (Display colorAt: p1) negated. 277030 opposite = Color transparent ifTrue: [opposite := Color red]. 277031 (poly := LineMorph from: p1 to: p1 color: opposite width: 2) openInWorld. 277032 oldVerts := {p1}. 277033 self currentWorld displayWorldSafely; runStepMethods. 277034 [true] whileTrue: 277035 [[Sensor anyButtonPressed] whileTrue: 277036 [pN := Sensor cursorPoint. 277037 poly setVertices: (oldVerts copyWith: pN). 277038 self currentWorld displayWorldSafely; runStepMethods]. 277039 (oldVerts size > 1 and: [(pN dist: p1) < 5]) ifTrue: 277040 [hand position: Sensor cursorPoint. "Done -- update hand pos" 277041 ^ (poly setVertices: (poly vertices copyWith: p1)) delete]. 277042 oldVerts := poly vertices. 277043 [Sensor anyButtonPressed] whileFalse: 277044 [pN := Sensor cursorPoint. 277045 poly setVertices: (oldVerts copyWith: pN). 277046 self currentWorld displayWorldSafely; runStepMethods]]. 277047! ! 277048 277049!PolygonMorph class methodsFor: 'instance creation' stamp: 'di 10/18/2001 04:42'! 277050fromHandFreehand: hand 277051 "Let the user draw a polygon, holding the mouse down, and ending 277052 by clicking within 5 of the first point..." 277053 | p1 poly pN opposite | 277054 Cursor crossHair showWhile: 277055 [[Sensor anyButtonPressed] whileFalse: 277056 [self currentWorld displayWorldSafely; runStepMethods]. 277057 p1 := Sensor cursorPoint]. 277058 opposite := (Display colorAt: p1) negated. 277059 opposite = Color transparent ifTrue: [opposite := Color red]. 277060 (poly := LineMorph from: p1 to: p1 color: opposite width: 2) openInWorld. 277061 self currentWorld displayWorldSafely; runStepMethods. 277062 [Sensor anyButtonPressed] whileTrue: 277063 [pN := Sensor cursorPoint. 277064 (pN dist: poly vertices last) > 3 ifTrue: 277065 [poly setVertices: (poly vertices copyWith: pN). 277066 self currentWorld displayWorldSafely; runStepMethods]]. 277067 hand position: Sensor cursorPoint. "Done -- update hand pos" 277068 ^ (poly setVertices: (poly vertices copyWith: p1)) delete! ! 277069 277070!PolygonMorph class methodsFor: 'instance creation' stamp: 'di 9/9/2000 11:41'! 277071shapeFromPen: penBlock color: c borderWidth: bw borderColor: bc 277072 "World addMorph: (PolygonMorph 277073 shapeFromPen: [:p | p hilbert: 4 side: 5. p go: 5. 277074 p hilbert: 4 side: 5. p go: 5] 277075 color: Color red borderWidth: 1 borderColor: Color black)" 277076 277077 | pen | 277078 penBlock value: (pen := PenPointRecorder new). 277079 ^ (self vertices: pen points asArray color: c borderWidth: bw borderColor: bc) 277080 quickFill: false! ! 277081 277082!PolygonMorph class methodsFor: 'instance creation' stamp: 'di 9/7/2000 17:05'! 277083vertices: verts color: c borderWidth: bw borderColor: bc 277084 ^ self basicNew beStraightSegments vertices: verts color: c borderWidth: bw borderColor: bc! ! 277085MorphTest subclass: #PolygonMorphTest 277086 instanceVariableNames: '' 277087 classVariableNames: '' 277088 poolDictionaries: '' 277089 category: 'MorphicTests-Basic'! 277090!PolygonMorphTest commentStamp: 'nice 2/16/2008 02:13' prior: 0! 277091This class holds tests for PolygonMorph! 277092 277093 277094!PolygonMorphTest methodsFor: 'bounds' stamp: 'nice 2/16/2008 02:31'! 277095testBoundsBug1035 277096 "This is a non regression test for http://bugs.squeak.org/view.php?id=1035 277097 PolygonMorph used to position badly when container bounds were growing" 277098 277099 | submorph aMorph | 277100 277101 submorph := (PolygonMorph 277102 vertices: {0@0. 100@0. 0@100} 277103 color: Color red borderWidth: 0 borderColor: Color transparent) 277104 color: Color red. 277105 277106 submorph bounds. "0@0 corner: 100@100" 277107 277108 aMorph := Morph new 277109 color: Color blue; 277110 layoutPolicy: ProportionalLayout new; 277111 addMorph: submorph 277112 fullFrame: (LayoutFrame fractions: (0.1 @ 0.1 corner: 0.9 @ 0.9)). 277113 277114 submorph bounds. "0@0 corner: 100@100 NOT YET UPDATED" 277115 aMorph fullBounds. "0@0 corner: 50@40. CORRECT" 277116 submorph bounds. "5@4 corner: 45@36 NOW UPDATED OK" 277117 277118 aMorph extent: 100@100. 277119 submorph bounds. "5@4 corner: 45@36 NOT YET UPDATED" 277120 aMorph fullBounds. "-10@-14 corner: 100@100 WRONG" 277121 submorph bounds. "-10@-14 corner: 70@66 NOW WRONG POSITION (BUT RIGHT EXTENT)" 277122 277123 self assert: aMorph fullBounds = (0 @ 0 extent: 100@100). 277124 self assert: submorph bounds = (10 @ 10 corner: 90@90). 277125! ! 277126StringMorph subclass: #PopUpChoiceMorph 277127 instanceVariableNames: 'target actionSelector arguments getItemsSelector getItemsArgs choiceArgs' 277128 classVariableNames: '' 277129 poolDictionaries: '' 277130 category: 'Morphic-Widgets'! 277131 277132!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'! 277133actionSelector 277134 277135 ^ actionSelector 277136! ! 277137 277138!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'! 277139actionSelector: aSymbolOrString 277140 277141 (nil = aSymbolOrString or: 277142 ['nil' = aSymbolOrString or: 277143 [aSymbolOrString isEmpty]]) 277144 ifTrue: [^ actionSelector := nil]. 277145 277146 actionSelector := aSymbolOrString asSymbol. 277147! ! 277148 277149!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'! 277150arguments 277151 277152 ^ arguments 277153! ! 277154 277155!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'! 277156arguments: aCollection 277157 277158 arguments := aCollection asArray copy. 277159! ! 277160 277161!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:33'! 277162getItemsArgs 277163 277164 ^ getItemsArgs 277165! ! 277166 277167!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:33'! 277168getItemsArgs: aCollection 277169 277170 getItemsArgs := aCollection asArray copy. 277171! ! 277172 277173!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:32'! 277174getItemsSelector 277175 277176 ^ getItemsSelector 277177! ! 277178 277179!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:32'! 277180getItemsSelector: aSymbolOrString 277181 277182 (nil = aSymbolOrString or: 277183 ['nil' = aSymbolOrString or: 277184 [aSymbolOrString isEmpty]]) 277185 ifTrue: [^ getItemsSelector := nil]. 277186 277187 getItemsSelector := aSymbolOrString asSymbol. 277188! ! 277189 277190!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'! 277191target 277192 277193 ^ target 277194! ! 277195 277196!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'! 277197target: anObject 277198 277199 target := anObject 277200! ! 277201 277202 277203!PopUpChoiceMorph methodsFor: 'copying' stamp: 'di 3/24/1999 09:57'! 277204veryDeepFixupWith: deepCopier 277205 "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 277206 277207super veryDeepFixupWith: deepCopier. 277208target := deepCopier references at: target ifAbsent: [target]. 277209arguments := arguments collect: [:each | 277210 deepCopier references at: each ifAbsent: [each]]. 277211getItemsArgs := getItemsArgs collect: [:each | 277212 deepCopier references at: each ifAbsent: [each]]. 277213choiceArgs ifNotNil: [choiceArgs := choiceArgs collect: [:each | 277214 deepCopier references at: each ifAbsent: [each]]].! ! 277215 277216!PopUpChoiceMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:43'! 277217veryDeepInner: deepCopier 277218 "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." 277219 277220super veryDeepInner: deepCopier. 277221"target := target. Weakly copied" 277222"actionSelector := actionSelector. a Symbol" 277223"arguments := arguments. All weakly copied" 277224"getItemsSelector := getItemsSelector. a Symbol" 277225"getItemsArgs := getItemsArgs. All weakly copied" 277226"choiceSelector := choiceSelector. a Symbol" 277227choiceArgs := choiceArgs. "All weakly copied" 277228 ! ! 277229 277230 277231!PopUpChoiceMorph methodsFor: 'event handling' stamp: 'jm 2/2/98 00:20'! 277232handlesMouseDown: evt 277233 277234 ^ true 277235! ! 277236 277237!PopUpChoiceMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:50'! 277238mouseDown: evt 277239 | items menu selectedItem | 277240 (target isNil or: [getItemsSelector isNil]) ifTrue: [^self]. 277241 items := target perform: getItemsSelector withArguments: getItemsArgs. 277242 menu := CustomMenu new. 277243 items do: [:item | menu add: item action: item]. 277244 selectedItem := menu startUp. 277245 selectedItem ifNil: [^self]. 277246 self contentsClipped: selectedItem. "Client can override this if necess" 277247 actionSelector ifNotNil: 277248 [target perform: actionSelector 277249 withArguments: (arguments copyWith: selectedItem)]! ! 277250 277251 277252!PopUpChoiceMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:44'! 277253initialize 277254"initialize the state of the receiver" 277255 super initialize. 277256"" 277257 self contents: 'PopUpChoice of Colors'. 277258 target := Color. 277259 actionSelector := nil. 277260 arguments := EmptyArray. 277261 getItemsSelector := #colorNames. 277262 getItemsArgs := EmptyArray! ! 277263Object subclass: #PopUpMenu 277264 instanceVariableNames: 'labelString font lineArray frame form marker selection' 277265 classVariableNames: 'CacheMenuForms MenuStyle' 277266 poolDictionaries: '' 277267 category: 'ST80-Menus'! 277268!PopUpMenu commentStamp: '<historical>' prior: 0! 277269I represent a list of items. My instances are presented on the display screen in a rectangular area. The user points to an item, pressing a mouse button; the item is highlighted. When the button is released, the highlighted item indicates the selection.! 277270 277271 277272!PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:44'! 277273center 277274 "Answer the point at the center of the receiver's rectangular area." 277275 277276 ^ frame center! ! 277277 277278!PopUpMenu methodsFor: 'accessing' stamp: 'alain.plantec 2/9/2009 14:53'! 277279frameHeight 277280 "Designed to avoid the entire frame computation (includes MVC form), 277281 since the menu may well end up being displayed in Morphic anyway." 277282 | nItems | 277283 frame ifNotNil: [^ frame height]. 277284 nItems := 1 + (labelString occurrencesOf: Character cr). 277285 ^ (nItems * MenuStyle lineGrid) + 4 "border width"! ! 277286 277287!PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 14:55'! 277288labelString 277289 ^ labelString! ! 277290 277291!PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 14:55'! 277292lineArray 277293 ^ lineArray! ! 277294 277295!PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 12:32'! 277296nItems 277297 ^ (labelString occurrencesOf: Character cr) + 1! ! 277298 277299 277300!PopUpMenu methodsFor: 'basic control sequence'! 277301startUp 277302 "Display and make a selection from the receiver as long as the button 277303 is pressed. Answer the current selection." 277304 277305 ^ self startUpWithCaption: nil! ! 277306 277307!PopUpMenu methodsFor: 'basic control sequence' stamp: 'ar 3/18/2001 00:55'! 277308startUpCenteredWithCaption: captionOrNil 277309 "Differs from startUpWithCaption: by appearing with cursor in the menu, 277310 and thus ready to act on mouseUp, without requiring user tweak to confirm" 277311 ^ self startUpWithCaption: captionOrNil at: (ActiveHand ifNil:[Sensor]) cursorPoint - (20@0)! ! 277312 277313!PopUpMenu methodsFor: 'basic control sequence' stamp: 'alain.plantec 2/9/2009 15:06'! 277314startUpSegmented: segmentHeight withCaption: captionOrNil at: location 277315 ^ self startUpSegmented: segmentHeight withCaption: captionOrNil at: location allowKeyboard: Preferences menuKeyboardControl! ! 277316 277317!PopUpMenu methodsFor: 'basic control sequence' stamp: 'alain.plantec 2/9/2009 15:07'! 277318startUpSegmented: segmentHeight withCaption: captionOrNil at: location allowKeyboard: aBoolean 277319 "This menu is too big to fit comfortably on the screen. 277320 Break it up into smaller chunks, and manage the relative indices. 277321 Inspired by a special-case solution by Reinier van Loon. The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)" 277322 277323 " Example: 277324 (PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; cr]. s skip: -1]) 277325 lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'. 277326 " 277327 | nLines nLinesPer allLabels from to subset subLines index | 277328 frame ifNil: [self computeForm]. 277329 allLabels := labelString findTokens: Character cr asString. 277330 nLines := allLabels size. 277331 lineArray ifNil: [lineArray := Array new]. 277332 nLinesPer := segmentHeight // marker height - 3. 277333 from := 1. 277334 [ true ] whileTrue: 277335 [to := (from + nLinesPer) min: nLines. 277336 subset := allLabels copyFrom: from to: to. 277337 subset add: (to = nLines ifTrue: ['start over...' translated] ifFalse: ['more...' translated]) 277338 before: subset first. 277339 subLines := lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1]. 277340 subLines := (Array with: 1) , subLines. 277341 index := (PopUpMenu labels: subset asStringWithCr lines: subLines) 277342 startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean. 277343 index ifNil: [^ 0]. 277344 index = 1 277345 ifTrue: [from := to + 1. 277346 from > nLines ifTrue: [ from := 1 ]] 277347 ifFalse: [index = 0 ifTrue: [^ 0]. 277348 ^ from + index - 2]]! ! 277349 277350!PopUpMenu methodsFor: 'basic control sequence' stamp: 'ar 3/18/2001 00:55'! 277351startUpWithCaption: captionOrNil 277352 "Display the menu, slightly offset from the cursor, 277353 so that a slight tweak is required to confirm any action." 277354 ^ self startUpWithCaption: captionOrNil at: (ActiveHand ifNil:[Sensor]) cursorPoint! ! 277355 277356!PopUpMenu methodsFor: 'basic control sequence' stamp: 'ar 12/27/2001 22:47'! 277357startUpWithCaption: captionOrNil at: location 277358 "Display the menu, with caption if supplied. Wait for the mouse button to go down, 277359 then track the selection as long as the button is pressed. When the button is released, 277360 answer the index of the current selection, or zero if the mouse is not released over 277361 any menu item. Location specifies the desired topLeft of the menu body rectangle." 277362 277363 ^ self startUpWithCaption: captionOrNil at: location allowKeyboard: Preferences menuKeyboardControl! ! 277364 277365!PopUpMenu methodsFor: 'basic control sequence' stamp: 'dgd 4/4/2006 14:47'! 277366startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean 277367 "Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released, 277368 Answer the index of the current selection, or zero if the mouse is not released over any menu item. Location specifies the desired topLeft of the menu body rectangle. The final argument indicates whether the menu should seize the keyboard focus in order to allow the user to navigate it via the keyboard." 277369 277370 ^ self 277371 startUpWithCaption: captionOrNil 277372 icon: nil 277373 at: location 277374 allowKeyboard: aBoolean! ! 277375 277376!PopUpMenu methodsFor: 'basic control sequence' stamp: 'dgd 10/12/2004 13:43'! 277377startUpWithCaption: captionOrNil icon: aForm 277378 "Display the menu, slightly offset from the cursor, 277379 so that a slight tweak is required to confirm any action." 277380 ^ self 277381 startUpWithCaption: captionOrNil 277382 icon: aForm 277383 at: (ActiveHand ifNil:[Sensor]) cursorPoint 277384! ! 277385 277386!PopUpMenu methodsFor: 'basic control sequence' stamp: 'dgd 10/12/2004 13:44'! 277387startUpWithCaption: captionOrNil icon: aForm at: location 277388 "Display the menu, with caption if supplied. Wait for the mouse button to go down, 277389 then track the selection as long as the button is pressed. When the button is released, 277390 answer the index of the current selection, or zero if the mouse is not released over 277391 any menu item. Location specifies the desired topLeft of the menu body rectangle." 277392 277393 ^ self 277394 startUpWithCaption: captionOrNil 277395 icon: aForm 277396 at: location 277397 allowKeyboard: Preferences menuKeyboardControl 277398! ! 277399 277400!PopUpMenu methodsFor: 'basic control sequence' stamp: 'alain.plantec 2/9/2009 13:46'! 277401startUpWithCaption: captionOrNil icon: aForm at: location allowKeyboard: aBoolean 277402 "Display the menu, with caption if supplied. Wait for the mouse button 277403 to go down, then track the selection as long as the button is pressed. 277404 When the button is released, 277405 Answer the index of the current selection, or zero if the mouse is not 277406 released over any menu item. Location specifies the desired topLeft of 277407 the menu body rectangle. The final argument indicates whether the 277408 menu should seize the keyboard focus in order to allow the user to 277409 navigate it via the keyboard." 277410 | maxHeight | 277411 (ProvideAnswerNotification signal: captionOrNil) 277412 ifNotNil: [:answer | ^ selection := answer 277413 ifTrue: [1] 277414 ifFalse: [2]]. 277415 maxHeight := Display height * 3 // 4. 277416 self frameHeight > maxHeight 277417 ifTrue: [^ self 277418 startUpSegmented: maxHeight 277419 withCaption: captionOrNil 277420 at: location 277421 allowKeyboard: aBoolean]. 277422 selection := Cursor normal 277423 showWhile: [| menuMorph | 277424 menuMorph := self menuMorphWithTitle: nil. 277425 (captionOrNil notNil 277426 or: [aForm notNil]) 277427 ifTrue: [menuMorph addTitle: captionOrNil icon: aForm]. 277428 MenuIcons decorateMenu: menuMorph. 277429 menuMorph 277430 invokeAt: location 277431 in: ActiveWorld 277432 allowKeyboard: aBoolean]. 277433 ^ selection! ! 277434 277435!PopUpMenu methodsFor: 'basic control sequence' stamp: 'sw 12/17/2001 17:01'! 277436startUpWithoutKeyboard 277437 "Display and make a selection from the receiver as long as the button is pressed. Answer the current selection. Do not allow keyboard input into the menu" 277438 277439 ^ self startUpWithCaption: nil at: ((ActiveHand ifNil:[Sensor]) cursorPoint) allowKeyboard: false! ! 277440 277441 277442!PopUpMenu methodsFor: 'displaying' stamp: 'alain.plantec 2/9/2009 15:09'! 277443displayAt: aPoint withCaption: captionOrNil during: aBlock 277444 "Display the receiver just to the right of aPoint while 277445 aBlock is evaluated. If the receiver is forced off 277446 screen, display it just to the right." 277447 | delta savedArea captionForm captionSave outerFrame captionText tFrame frameSaveLoc captionBox | 277448 marker 277449 ifNil: [self computeForm]. 277450 frame := frame align: marker leftCenter with: aPoint + (2 @ 0). 277451 outerFrame := frame. 277452 captionOrNil notNil 277453 ifTrue: [captionText := (DisplayText text: captionOrNil asText textStyle: MenuStyle copy centered) 277454 foregroundColor: Color black 277455 backgroundColor: Color white. 277456 tFrame := captionText boundingBox insetBy: -2. 277457 outerFrame := frame 277458 merge: (tFrame align: tFrame bottomCenter with: frame topCenter + (0 @ 2))]. 277459 delta := outerFrame amountToTranslateWithin: Display boundingBox. 277460 frame right > Display boundingBox right 277461 ifTrue: [delta := 0 - frame width @ delta y]. 277462 frame := frame translateBy: delta. 277463 captionOrNil notNil 277464 ifTrue: [captionForm := captionText form. 277465 captionBox := captionForm boundingBox expandBy: 4. 277466 captionBox := captionBox align: captionBox bottomCenter with: frame topCenter + (0 @ 2). 277467 captionSave := Form fromDisplay: captionBox. 277468 Display 277469 border: captionBox 277470 width: 4 277471 fillColor: Color white. 277472 Display 277473 border: captionBox 277474 width: 2 277475 fillColor: Color black. 277476 captionForm displayAt: captionBox topLeft + 4]. 277477 marker := marker align: marker leftCenter with: aPoint + delta + (2 @ 0). 277478 savedArea := Form fromDisplay: frame. 277479 self menuForm displayOn: Display at: (frameSaveLoc := frame topLeft). 277480 selection ~= 0 277481 ifTrue: [Display reverse: marker]. 277482 Cursor normal 277483 showWhile: [aBlock value]. 277484 savedArea displayOn: Display at: frameSaveLoc. 277485 captionOrNil notNil 277486 ifTrue: [captionSave displayOn: Display at: captionBox topLeft]! ! 277487 277488 277489!PopUpMenu methodsFor: 'marker adjustment' stamp: 'alain.plantec 2/9/2009 15:09'! 277490manageMarker 277491 "If the cursor is inside the receiver's frame, then highlight the marked 277492 item. Otherwise no item is to be marked." 277493 | pt | 277494 "Don't let pt get far from display box, so scrolling will go all the way" 277495 pt := Sensor cursorPoint adhereTo: (Display boundingBox expandBy: 1). 277496 (frame inside containsPoint: pt) 277497 ifTrue: ["Need to cache the form for reasonable scrolling performance" 277498 ((Display boundingBox insetBy: 0@3) containsPoint: pt) 277499 ifFalse: [pt := pt - (self scrollIntoView: pt)]. 277500 self markerOn: pt] 277501 ifFalse: [self markerOff]! ! 277502 277503!PopUpMenu methodsFor: 'marker adjustment' stamp: 'sma 5/28/2000 15:27'! 277504markerOff 277505 "No item is selected. Reverse the highlight if any item has been marked 277506 as selected." 277507 277508 self setSelection: 0! ! 277509 277510!PopUpMenu methodsFor: 'marker adjustment' stamp: 'alain.plantec 2/9/2009 15:10'! 277511markerOn: aPoint 277512 "The item whose bounding area contains aPoint should be marked as 277513 selected. Highlight its area and set the selection to its index." 277514 277515 selection = 0 | (marker containsPoint: aPoint) not 277516 ifTrue: [selection = 0 & (marker containsPoint: aPoint) 277517 ifTrue: [Display reverse: marker] 277518 ifFalse: 277519 [selection > 0 ifTrue: [Display reverse: marker]. 277520 marker := 277521 marker 277522 align: marker topLeft 277523 with: marker left @ (self markerTop: aPoint). 277524 Display reverse: marker]]. 277525 selection := marker top - frame top // marker height + 1! ! 277526 277527!PopUpMenu methodsFor: 'marker adjustment'! 277528markerTop: aPoint 277529 "Answer aPoint, gridded to lines in the receiver." 277530 277531 ^(aPoint y - frame inside top truncateTo: font height) + frame inside top! ! 277532 277533!PopUpMenu methodsFor: 'marker adjustment' stamp: 'alain.plantec 2/9/2009 15:10'! 277534scrollIntoView: cursorLoc 277535 | dy | 277536 dy := 0. 277537 cursorLoc y < 2 ifTrue: [dy := font height]. 277538 cursorLoc y > (Display height-3) ifTrue: [dy := font height negated]. 277539 dy = 0 ifTrue: [^ 0@0]. 277540 self markerOff. 277541 frame := frame translateBy: 0@dy. 277542 marker := marker translateBy: 0@dy. 277543 self menuForm displayOn: Display at: frame topLeft. 277544 ^ 0@dy! ! 277545 277546 277547!PopUpMenu methodsFor: 'selecting' stamp: 'sma 5/28/2000 12:27'! 277548selection 277549 "Answer the current selection." 277550 277551 ^ selection! ! 277552 277553!PopUpMenu methodsFor: 'selecting' stamp: 'alain.plantec 2/9/2009 15:10'! 277554setSelection: index 277555 | newSelection | 277556 selection = index ifTrue: [^ self]. 277557 newSelection := (0 max: index) min: frame height // marker height. 277558 selection > 0 ifTrue: [Display reverse: marker]. 277559 marker := marker translateBy: 0 @ (newSelection - selection * marker height). 277560 selection := newSelection. 277561 selection > 0 ifTrue: [Display reverse: marker]! ! 277562 277563 277564!PopUpMenu methodsFor: 'private' stamp: 'alain.plantec 2/9/2009 15:10'! 277565computeForm 277566 "Compute and answer a Form to be displayed for 277567 this menu." 277568 | borderInset paraForm menuForm inside | 277569 borderInset := 4 @ 4. 277570 paraForm := (DisplayText text: labelString asText textStyle: MenuStyle) form. 277571 menuForm := Form extent: paraForm extent + (borderInset * 2) depth: paraForm depth. 277572 menuForm 277573 fill: (0 @ 0 extent: menuForm extent) 277574 rule: Form over 277575 fillColor: Color white. 277576 menuForm borderWidth: 2. 277577 paraForm displayOn: menuForm at: borderInset. 277578 lineArray == nil 277579 ifFalse: [lineArray 277580 do: [:line | menuForm 277581 fillBlack: (4 @ (line * font height + borderInset y) extent: menuForm width - 8 @ 1)]]. 277582 frame := Quadrangle new. 277583 frame region: menuForm boundingBox. 277584 frame borderWidth: 4. 277585 inside := frame inside. 277586 marker := inside topLeft extent: inside width @ MenuStyle lineGrid. 277587 selection := 1. 277588 ^ form := menuForm! ! 277589 277590!PopUpMenu methodsFor: 'private' stamp: 'alain.plantec 2/9/2009 13:55'! 277591labels: aString font: aFont lines: anArray 277592 277593 labelString := aString. 277594 font := aFont. 277595 lineArray := anArray. 277596! ! 277597 277598!PopUpMenu methodsFor: 'private' stamp: 'alain.plantec 2/9/2009 15:11'! 277599menuForm 277600 "Answer a Form to be displayed for this menu." 277601 277602 ^ form ifNil: [self computeForm]. 277603! ! 277604 277605!PopUpMenu methodsFor: 'private' stamp: 'alain.plantec 2/9/2009 14:23'! 277606menuMorphWithTitle: titleStringOrNil 277607 "Answer a MenuMorph constructed from self 277608 The menu is build so that it is forced to return 277609 the current selection value when an item is selected" 277610 | menu items lines allSelections j emphasis | 277611 menu := MenuMorph new. 277612 titleStringOrNil isEmptyOrNil ifFalse: [menu addTitle: titleStringOrNil]. 277613 labelString := self labelString. 277614 items := self labelString asString findTokens: String cr. 277615 self labelString isText 277616 ifTrue: ["Pass along text emphasis if present" 277617 j := 1. 277618 items := items 277619 collect: [:item | 277620 j := self labelString asString findString: item startingAt: j. 277621 emphasis := TextEmphasis new emphasisCode: (self labelString emphasisAt: j). 277622 item asText addAttribute: emphasis]]. 277623 lines := self lineArray ifNil: [#()]. 277624 menu defaultTarget: menu. 277625 allSelections := (1 to: items size) asArray. 277626 1 277627 to: items size 277628 do: [:i | 277629 menu add: (items at: i) target: (allSelections at: i) selector: #yourself. 277630 (lines includes: i) 277631 ifTrue: [menu addLine]]. 277632 ^ menu! ! 277633 277634!PopUpMenu methodsFor: 'private' stamp: 'alain.plantec 2/9/2009 15:12'! 277635rescan 277636 "Cause my form to be recomputed after a font change." 277637 277638 labelString ifNil: [labelString := 'NoText!!']. 277639 self labels: labelString font: (MenuStyle fontAt: 1) lines: lineArray. 277640 frame := marker := form := nil. 277641 277642 "PopUpMenu allSubInstancesDo: [:m | m rescan]"! ! 277643 277644"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 277645 277646PopUpMenu class 277647 instanceVariableNames: ''! 277648 277649!PopUpMenu class methodsFor: 'dialogs' stamp: 'dgd 9/5/2003 18:24'! 277650confirm: queryString 277651 "Put up a yes/no menu with caption queryString. Answer true if the 277652 response is yes, false if no. This is a modal question--the user must 277653 respond yes or no." 277654 277655 "PopUpMenu confirm: 'Are you hungry?'" 277656 277657 ^ self confirm: queryString trueChoice: 'Yes' translated falseChoice: 'No' translated! ! 277658 277659!PopUpMenu class methodsFor: 'dialogs' stamp: 'dgd 10/12/2004 13:49'! 277660confirm: queryString orCancel: cancelBlock 277661 "Put up a yes/no/cancel menu with caption aString. Answer 277662 true if 277663 the response is yes, false if no. If cancel is chosen, evaluate 277664 cancelBlock. This is a modal question--the user must respond 277665 yes or no." 277666 "PopUpMenu confirm: 'Reboot universe' orCancel: 277667 [^'Nevermind'] " 277668 | menu choice | 277669 menu := PopUpMenu labelArray: {'Yes' translated. 'No' translated. 'Cancel' translated}. 277670 choice := menu startUpWithCaption: queryString icon: MenuIcons confirmIcon. 277671 choice = 1 277672 ifTrue: [^ true]. 277673 choice = 2 277674 ifTrue: [^ false]. 277675 ^ cancelBlock value! ! 277676 277677!PopUpMenu class methodsFor: 'dialogs' stamp: 'dgd 10/12/2004 13:49'! 277678confirm: queryString trueChoice: trueChoice falseChoice: falseChoice 277679 "Put up a yes/no menu with caption queryString. The actual 277680 wording 277681 for the two choices will be as provided in the trueChoice and 277682 falseChoice parameters. Answer true if the response is the 277683 true-choice, 277684 false if it's the false-choice. 277685 This is a modal question -- the user must respond one way or 277686 the other." 277687 "PopUpMenu 277688 confirm: 'Are you hungry?' 277689 trueChoice: 'yes, I''m famished' 277690 falseChoice: 'no, I just ate'" 277691 | menu choice | 277692 menu := PopUpMenu labelArray: {trueChoice. falseChoice}. 277693 [(choice := menu startUpWithCaption: queryString icon: MenuIcons confirmIcon) isNil] whileTrue. 277694 ^ choice = 1! ! 277695 277696!PopUpMenu class methodsFor: 'dialogs' stamp: 'dgd 10/12/2004 13:42'! 277697inform: aString 277698 "PopUpMenu inform: 'I like Squeak'" 277699 277700 (PopUpMenu labels: ' OK ' translated) 277701 startUpWithCaption: aString 277702 icon: MenuIcons confirmIcon 277703! ! 277704 277705!PopUpMenu class methodsFor: 'dialogs' stamp: 'sma 5/28/2000 15:57'! 277706notify: message 277707 "Deprecated. Use #inform: instead." 277708 277709 self inform: message! ! 277710 277711 277712!PopUpMenu class methodsFor: 'initialization' stamp: 'jla 4/2/2001 20:41'! 277713alignment 277714 277715 ^ MenuStyle alignment! ! 277716 277717!PopUpMenu class methodsFor: 'initialization' stamp: 'jla 4/2/2001 20:46'! 277718alignment: anAlignment 277719 277720 ^ MenuStyle alignment: anAlignment! ! 277721 277722!PopUpMenu class methodsFor: 'initialization' stamp: 'sw 12/6/1999 13:08'! 277723initialize "PopUpMenu initialize" 277724 (MenuStyle := TextStyle default copy) 277725 gridForFont: TextStyle default defaultFontIndex withLead: 0; 277726 centered. 277727 PopUpMenu allSubInstancesDo: [:m | m rescan]! ! 277728 277729!PopUpMenu class methodsFor: 'initialization' stamp: 'jla 4/2/2001 20:56'! 277730leftFlush 277731 277732 MenuStyle leftFlush! ! 277733 277734!PopUpMenu class methodsFor: 'initialization' stamp: 'nk 9/1/2004 10:27'! 277735setMenuFontTo: aFont 277736 "Set the menu font as indicated" 277737 277738 MenuStyle := TextStyle fontArray: { aFont }. 277739 MenuStyle 277740 gridForFont: 1 withLead: 0; 277741 centered. 277742 self allSubInstancesDo: [:m | m rescan]! ! 277743 277744 277745!PopUpMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 15:44'! 277746labelArray: labelArray 277747 "Answer an instance of me whose items are in labelArray." 277748 277749 ^ self labelArray: labelArray lines: nil! ! 277750 277751!PopUpMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 15:43'! 277752labelArray: labelArray lines: lineArray 277753 "Answer an instance of me whose items are in labelArray, with lines 277754 drawn after each item indexed by anArray. 2/1/96 sw" 277755 277756 labelArray isEmpty ifTrue: [self error: 'Menu must not be zero size']. 277757 ^ self 277758 labels: (String streamContents: 277759 [:stream | 277760 labelArray do: [:each | stream nextPutAll: each; cr]. 277761 stream skip: -1 "remove last CR"]) 277762 lines: lineArray 277763 277764"Example: 277765 (PopUpMenu labelArray: #('frog' 'and' 'toad') lines: #()) startUp"! ! 277766 277767!PopUpMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 15:36'! 277768labels: aString 277769 "Answer an instance of me whose items are in aString." 277770 277771 ^ self labels: aString lines: nil! ! 277772 277773!PopUpMenu class methodsFor: 'instance creation' stamp: 'sw 12/6/1999 17:55'! 277774labels: aString lines: anArray 277775 "Answer an instance of me whose items are in aString, with lines drawn 277776 after each item indexed by anArray." 277777 277778 ^ self new 277779 labels: aString 277780 font: MenuStyle defaultFont 277781 lines: anArray! ! 277782 277783!PopUpMenu class methodsFor: 'instance creation' stamp: 'nk 8/30/2004 07:59'! 277784withCaption: cap chooseFrom: labels 277785 "Simply put up a menu. Get the args in the right order with the caption 277786 first. labels may be either an array of items or a string with CRs in it. 277787 May use backslashes for returns." 277788 277789 ^ (labels isString 277790 ifTrue: [self labels: labels withCRs lines: nil] 277791 ifFalse: [self labelArray: labels lines: nil]) 277792 startUpWithCaption: cap withCRs! ! 277793ModelDependentDialogWindow subclass: #PopupChoiceDialogWindow 277794 instanceVariableNames: 'choice labels lines choicesMorph choiceMenus prefixFilter filterMorph' 277795 classVariableNames: '' 277796 poolDictionaries: '' 277797 category: 'Polymorph-Widgets-Windows'! 277798!PopupChoiceDialogWindow commentStamp: 'gvc 5/18/2007 12:26' prior: 0! 277799Presents a list of options in a popup format. If the list is long it will split into multiple columns. If very long, the columns will be scrollable. Maximum extent of the content area is half the display extent.! 277800 277801 277802!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:45'! 277803choice 277804 "Answer the value of choice" 277805 277806 ^ choice! ! 277807 277808!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:45'! 277809choice: anObject 277810 "Set the value of choice" 277811 277812 choice := anObject! ! 277813 277814!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/4/2008 15:43'! 277815choiceMenus 277816 "Answer the value of choiceMenus" 277817 277818 ^ choiceMenus! ! 277819 277820!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/4/2008 15:43'! 277821choiceMenus: anObject 277822 "Set the value of choiceMenus" 277823 277824 choiceMenus := anObject! ! 277825 277826!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/6/2009 13:13'! 277827choicesMorph 277828 "Answer the value of choicesMorph" 277829 277830 ^ choicesMorph! ! 277831 277832!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/6/2009 13:13'! 277833choicesMorph: anObject 277834 "Set the value of choicesMorph" 277835 277836 choicesMorph := anObject! ! 277837 277838!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/27/2008 15:24'! 277839filterMorph 277840 "Answer the value of filterMorph" 277841 277842 ^ filterMorph! ! 277843 277844!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/27/2008 15:24'! 277845filterMorph: anObject 277846 "Set the value of filterMorph" 277847 277848 filterMorph := anObject! ! 277849 277850!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:49'! 277851labels 277852 "Answer the value of labels" 277853 277854 ^ labels! ! 277855 277856!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:49'! 277857labels: anObject 277858 "Set the value of labels" 277859 277860 labels := anObject! ! 277861 277862!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:49'! 277863lines 277864 "Answer the value of lines" 277865 277866 ^ lines! ! 277867 277868!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:49'! 277869lines: anObject 277870 "Set the value of lines" 277871 277872 lines := anObject! ! 277873 277874!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/4/2008 15:48'! 277875prefixFilter 277876 "Answer the value of prefixFilter" 277877 277878 ^ prefixFilter! ! 277879 277880!PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 3/17/2008 17:37'! 277881prefixFilter: anObject 277882 "Set the value of prefixFilter" 277883 277884 |found| 277885 found := false. 277886 prefixFilter := anObject. 277887 self changed: #prefixFilter. 277888 (self choiceMenus ifNil: [^self]) do: [:embeddedMenu | 277889 embeddedMenu selectItem: nil event: nil]. "clear selection in other menus" 277890 self choiceMenus do: [:embeddedMenu | 277891 (embeddedMenu selectPrefix: self prefixFilter asLowercase) 277892 ifNotNilDo: [:menuItem | 277893 found ifFalse: [ 277894 embeddedMenu selectItem: menuItem event: nil. 277895 self activeHand newKeyboardFocus: embeddedMenu. 277896 found := true]]]! ! 277897 277898 277899!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 13:27'! 277900activate: evt 277901 "Backstop." 277902 ! ! 277903 277904!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/15/2007 16:00'! 277905choose: index 277906 "Set the given choice and ok." 277907 277908 self choice: (self model 277909 ifNil: [index] 277910 ifNotNil: [self model at: index]). 277911 self ok! ! 277912 277913!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 12:23'! 277914deleteIfPopUp: evt 277915 "For compatibility with MenuMorph."! ! 277916 277917!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 17:15'! 277918extent: aPoint 277919 "Make the choices area at least fill the scroll area." 277920 277921 |m| 277922 super extent: aPoint. 277923 m := self choicesMorph. 277924 m ifNotNil: [m width: (m width max: self scrollPane width)]! ! 277925 277926!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 12:44'! 277927handlesKeyboard: evt 277928 "True when either the filter morph doesn't have the focus and the key 277929 is a text key or backspace or no menus have the focus and is up or down arrow." 277930 277931 ^(super handlesKeyboard: evt) or: [ 277932 (self choiceMenus anySatisfy: [:m | m hasKeyboardFocus]) 277933 ifTrue: [evt keyCharacter = Character backspace 277934 or: [evt keyCharacter > Character space 277935 or: [evt keyCharacter = Character cr 277936 or: [evt keyCharacter = Character arrowLeft 277937 or: [evt keyCharacter = Character arrowRight]]]]] 277938 ifFalse: [evt keyCharacter = Character arrowUp 277939 or: [evt keyCharacter = Character arrowDown 277940 or: [self filterMorph hasKeyboardFocus not]]]]! ! 277941 277942!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 2/27/2008 15:42'! 277943initialize 277944 "Initialize the receiver." 277945 277946 super initialize. 277947 self 277948 labels: #(); 277949 lines: #(); 277950 prefixFilter: ''! ! 277951 277952!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 12:42'! 277953keyStroke: anEvent 277954 "Look for a matching item?" 277955 277956 (super keyStroke: anEvent) ifTrue: [^true]. 277957 anEvent keyCharacter = Character backspace 277958 ifTrue: [self prefixFilter ifNotEmpty: [self prefixFilter: self prefixFilter allButLast]]. 277959 anEvent keyCharacter = Character arrowUp ifTrue: [self selectLastEnabledItem. ^true]. 277960 anEvent keyCharacter = Character arrowDown ifTrue: [self selectFirstEnabledItem. ^true]. 277961 anEvent keyCharacter = Character arrowLeft ifTrue: [self switchToPreviousColumn. ^true]. 277962 anEvent keyCharacter = Character arrowRight ifTrue: [self switchToNextColumn. ^true]. 277963 (anEvent keyCharacter ~= Character cr and: [ 277964 anEvent keyCharacter < Character space]) ifTrue: [^false]. "ignore pageup/down etc." 277965 (anEvent keyCharacter = Character space or: [ 277966 anEvent keyCharacter = Character cr]) ifTrue: [ 277967 self choiceMenus do: [:embeddedMenu | 277968 embeddedMenu selectedItem ifNotNilDo: [:item | 277969 item invokeWithEvent: anEvent. 277970 ^true]]]. 277971 anEvent keyCharacter = Character backspace ifFalse: [ 277972 self prefixFilter: self prefixFilter, anEvent keyCharacter asString]. 277973 ^false! ! 277974 277975!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 12:21'! 277976newButtons 277977 "Answer new buttons as appropriate." 277978 277979 self filterMorph: self newFilterEntry. 277980 ^{self filterMorph. self newCancelButton}! ! 277981 277982!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 16:27'! 277983newChoiceButtonFor: index 277984 "Answer a new choice button." 277985 277986 ^(ToggleMenuItemMorph new 277987 contents: (self labels at: index) asString; 277988 target: self; 277989 selector: #choose:; 277990 arguments: {index}; 277991 getStateSelector: nil; 277992 enablementSelector: nil) 277993 cornerStyle: #square; 277994 hResizing: #spaceFill 277995 ! ! 277996 277997!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 2/6/2009 13:12'! 277998newChoicesMorph 277999 "Answer a row of columns of buttons and separators based on the model." 278000 278001 |answer morphs str maxLines| 278002 answer := self newRow 278003 cellPositioning: #topLeft; 278004 hResizing: #shrinkWrap; 278005 vResizing: #shrinkWrap. 278006 self labels ifEmpty: [^answer]. 278007 maxLines := Display height - 100 // 2 // (self newChoiceButtonFor: 1) height. 278008 morphs := OrderedCollection new. 278009 1 to: self labels size do: [:i | 278010 morphs add: (self newChoiceButtonFor: i). 278011 (self lines includes: i) ifTrue: [ 278012 morphs add: self newSeparator]]. 278013 str := morphs readStream. 278014 [str atEnd] whileFalse: [ 278015 answer 278016 addMorphBack: (self newMenuWith: (str next: maxLines)); 278017 addMorphBack: self newVerticalSeparator]. 278018 answer removeMorph: answer submorphs last. 278019 answer submorphs last 278020 hResizing: #spaceFill. 278021 self choiceMenus: (answer submorphs select: [:m| m isKindOf: MenuMorph]). 278022 ^answer! ! 278023 278024!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 2/6/2009 13:13'! 278025newContentMorph 278026 "Answer a new content morph." 278027 278028 |sp choices| 278029 self choicesMorph: (choices := self newChoicesMorph). 278030 sp := GeneralScrollPane new 278031 scrollTarget: choices; 278032 hResizing: #spaceFill; 278033 vResizing: #spaceFill. 278034 sp 278035 minWidth: (choices width min: Display width // 2) + sp scrollBarThickness; 278036 minHeight: (choices height min: Display height // 2). 278037 choices width > sp minWidth 278038 ifTrue: [sp minHeight: sp minHeight + sp scrollBarThickness]. 278039 sp 278040 updateScrollbars. 278041 ^self newGroupboxFor: sp! ! 278042 278043!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 2/27/2008 15:04'! 278044newFilterEntry 278045 "Answer a new filter entry field." 278046 278047 ^self 278048 newAutoAcceptTextEntryFor: self 278049 getText: #prefixFilter 278050 setText: #prefixFilter: 278051 getEnabled: nil 278052 help: 'Filters the options according to a prefix' translated! ! 278053 278054!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 14:24'! 278055newMenuWith: morphs 278056 "Answer menu with the given morphs." 278057 278058 ^(self newEmbeddedMenu addAllMorphs: morphs) 278059 borderWidth: 0; 278060 removeDropShadow; 278061 color: Color transparent; 278062 hResizing: #spaceFill; 278063 cornerStyle: #square; 278064 stayUp: true; 278065 beSticky; 278066 popUpOwner: (MenuItemMorph new privateOwner: self)! ! 278067 278068!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 13:03'! 278069rootMenu 278070 "Answer the root menu. Answer self." 278071 278072 ^self! ! 278073 278074!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 16:07'! 278075scrollPane 278076 "Answer the scroll pane." 278077 278078 ^self findDeeplyA: GeneralScrollPane! ! 278079 278080!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/20/2008 21:27'! 278081selectFirstEnabledItem 278082 "Select the first enabled item in any of the embedded menus" 278083 278084 |found| 278085 found := false. 278086 (self choiceMenus ifNil: [^self]) do: [:embeddedMenu | 278087 embeddedMenu selectItem: nil event: nil]. "clear selection in other menus" 278088 self choiceMenus do: [:embeddedMenu | 278089 (embeddedMenu selectPrefix: self prefixFilter) 278090 ifNotNilDo: [:menuItem | 278091 found ifFalse: [ 278092 embeddedMenu selectItem: menuItem event: nil. 278093 self activeHand newKeyboardFocus: embeddedMenu. 278094 found := true]]]! ! 278095 278096!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/20/2008 21:27'! 278097selectLastEnabledItem 278098 "Select the last enabled item in any of the embedded menus" 278099 278100 |found| 278101 found := false. 278102 (self choiceMenus ifNil: [^self]) do: [:embeddedMenu | 278103 embeddedMenu selectItem: nil event: nil]. "clear selection in other menus" 278104 self choiceMenus reverseDo: [:embeddedMenu | 278105 (embeddedMenu selectLastPrefix: self prefixFilter) 278106 ifNotNilDo: [:menuItem | 278107 found ifFalse: [ 278108 embeddedMenu selectItem: menuItem event: nil. 278109 self activeHand newKeyboardFocus: embeddedMenu. 278110 found := true]]]! ! 278111 278112!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 12:59'! 278113switchToNextColumn 278114 "Give the next embedded menu keyboard focus." 278115 278116 |menuWithFocus| 278117 (self choiceMenus isNil or: [self choiceMenus isEmpty]) ifTrue: [^self]. 278118 menuWithFocus := self choiceMenus 278119 detect: [:m | m hasKeyboardFocus] 278120 ifNone: []. 278121 menuWithFocus isNil 278122 ifFalse: [menuWithFocus navigateFocusForward]. 278123 menuWithFocus := self choiceMenus 278124 detect: [:m | m hasKeyboardFocus] 278125 ifNone: []. 278126 menuWithFocus isNil 278127 ifTrue: [self choiceMenus first takeKeyboardFocus]! ! 278128 278129!PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 12:58'! 278130switchToPreviousColumn 278131 "Give the previous embedded menu keyboard focus." 278132 278133 |menuWithFocus| 278134 (self choiceMenus isNil or: [self choiceMenus isEmpty]) ifTrue: [^self]. 278135 menuWithFocus := self choiceMenus 278136 detect: [:m | m hasKeyboardFocus] 278137 ifNone: []. 278138 menuWithFocus isNil 278139 ifFalse: [menuWithFocus navigateFocusBackward]. 278140 menuWithFocus := self choiceMenus 278141 detect: [:m | m hasKeyboardFocus] 278142 ifNone: []. 278143 menuWithFocus isNil 278144 ifTrue: [self choiceMenus last takeKeyboardFocus]! ! 278145 278146"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 278147 278148PopupChoiceDialogWindow class 278149 instanceVariableNames: ''! 278150 278151!PopupChoiceDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/21/2007 12:54'! 278152taskbarIcon 278153 "Answer the icon for the receiver in a task bar." 278154 278155 ^UITheme current smallQuestionIcon! ! 278156PopupChoiceDialogWindow subclass: #PopupChoiceDialogWindowWithMessage 278157 instanceVariableNames: 'textMorph iconMorph textFont message' 278158 classVariableNames: '' 278159 poolDictionaries: '' 278160 category: 'Polymorph-Widgets-Windows'! 278161 278162!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 09:36'! 278163icon 278164 "Answer an icon for the receiver." 278165 278166 ^self theme infoIcon! ! 278167 278168!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 09:35'! 278169iconMorph 278170 "Answer the value of iconMorph" 278171 278172 ^ iconMorph! ! 278173 278174!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 09:34'! 278175iconMorph: anObject 278176 "Set the value of iconMorph" 278177 278178 iconMorph := anObject! ! 278179 278180!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 10:08'! 278181message 278182 278183 ^ message! ! 278184 278185!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 10:08'! 278186message: aStringOrText 278187 278188 message := aStringOrText! ! 278189 278190!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'gvc 7/30/2009 14:07'! 278191text: aStringOrText 278192 "Set the text." 278193 278194 |t| 278195 t := aStringOrText isString 278196 ifTrue: [aStringOrText asText addAttribute: (TextFontReference toFont: self textFont); yourself] 278197 ifFalse: [aStringOrText]. 278198 t addAttribute: TextAlignment centered. 278199 self textMorph newContents: t! ! 278200 278201!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 09:41'! 278202textFont 278203 "Answer the text font." 278204 278205 ^textFont! ! 278206 278207!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 09:41'! 278208textFont: aFont 278209 "Set the text font." 278210 278211 textFont := aFont! ! 278212 278213!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 09:34'! 278214textMorph 278215 "Answer the value of textMorph" 278216 278217 ^ textMorph! ! 278218 278219!PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 09:34'! 278220textMorph: anObject 278221 "Set the value of textMorph" 278222 278223 textMorph := anObject! ! 278224 278225 278226!PopupChoiceDialogWindowWithMessage methodsFor: 'as yet unclassified' stamp: 'gvc 2/6/2009 13:41'! 278227initialExtent 278228 "Answer the initial extent for the receiver. 278229 Adjust the text if the text would be wider than 1/2 the display width." 278230 278231 |ext| 278232 ext := super initialExtent. 278233 self textMorph width > (Display width // 2) ifTrue: [ 278234 self textMorph 278235 wrapFlag: true; 278236 hResizing: #rigid; 278237 extent: Display width // 2 @ 0. 278238 ext := super initialExtent]. 278239 ^ext! ! 278240 278241!PopupChoiceDialogWindowWithMessage methodsFor: 'as yet unclassified' stamp: 'alain.plantec 2/6/2009 10:04'! 278242newContentMorph 278243 | top bottom | 278244 self textMorph: self newTextMorph. 278245 self text: self message. 278246 self iconMorph: self newIconMorph. 278247 top := self newRow: {self iconMorph. self textMorph}. 278248 bottom := super newContentMorph. 278249 ^ self newGroupboxFor: (self newColumn: {top. bottom}).! ! 278250 278251!PopupChoiceDialogWindowWithMessage methodsFor: 'as yet unclassified' stamp: 'alain.plantec 2/6/2009 09:36'! 278252newIconMorph 278253 "Answer an icon for the receiver." 278254 278255 ^ImageMorph new image: self icon! ! 278256 278257!PopupChoiceDialogWindowWithMessage methodsFor: 'as yet unclassified' stamp: 'alain.plantec 2/6/2009 09:32'! 278258newTextMorph 278259 "Answer a text morph." 278260 278261 ^self newText: ''! ! 278262Stream subclass: #PositionableStream 278263 instanceVariableNames: 'collection position readLimit' 278264 classVariableNames: '' 278265 poolDictionaries: '' 278266 category: 'Collections-Streams'! 278267!PositionableStream commentStamp: '<historical>' prior: 0! 278268I represent an accessor for a sequence of objects (a collection) that are externally named by indices so that the point of access can be repositioned. I am abstract in that I do not implement the messages next and nextPut: which are inherited from my superclass Stream.! 278269 278270 278271!PositionableStream methodsFor: '*Polymorph-EventEnhancements' stamp: 'PeterHugossonMiller 9/3/2009 10:51'! 278272upToAny: aCollection 278273 "Answer a subcollection from the current access position to the 278274 occurrence (if any, but not inclusive) of any objects in the given collection in the receiver. If 278275 any of these is not in the collection, answer the entire rest of the receiver." 278276 278277 | newStream element | 278278 newStream := (collection species new: 100) writeStream. 278279 [self atEnd or: [aCollection includes: (element := self next)]] 278280 whileFalse: [newStream nextPut: element]. 278281 ^newStream contents! ! 278282 278283 278284!PositionableStream methodsFor: '*packageinfo-base' stamp: 'nk 6/17/2003 07:45'! 278285untilEnd: aBlock displayingProgress: aString 278286 aString 278287 displayProgressAt: Sensor cursorPoint 278288 from: 0 to: self size 278289 during: 278290 [:bar | 278291 [self atEnd] whileFalse: 278292 [bar value: self position. 278293 aBlock value]].! ! 278294 278295 278296!PositionableStream methodsFor: 'accessing' stamp: 'pavel.krivanek 3/12/2009 11:01'! 278297back 278298 "Go back one element and return it." 278299 278300 self position = 0 ifTrue: [self positionError]. 278301 self skip: -1. 278302 ^ self peek! ! 278303 278304!PositionableStream methodsFor: 'accessing'! 278305contents 278306 "Answer with a copy of my collection from 1 to readLimit." 278307 278308 ^collection copyFrom: 1 to: readLimit! ! 278309 278310!PositionableStream methodsFor: 'accessing' stamp: 'sw 3/10/98 13:55'! 278311contentsOfEntireFile 278312 "For non-file streams" 278313 ^ self contents! ! 278314 278315!PositionableStream methodsFor: 'accessing' stamp: 'tk 9/23/2001 01:14'! 278316last 278317 "Return the final element in the receiver" 278318 278319 ^ collection at: position! ! 278320 278321!PositionableStream methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:50'! 278322nextDelimited: terminator 278323 "Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character. For example: 'this '' was a quote'. Start postioned before the initial terminator." 278324 278325 | out ch | 278326 out := (String new: 1000) writeStream. 278327 self atEnd ifTrue: [^ '']. 278328 self next == terminator ifFalse: [self skip: -1]. "absorb initial terminator" 278329 [(ch := self next) == nil] whileFalse: [ 278330 (ch == terminator) ifTrue: [ 278331 self peek == terminator ifTrue: [ 278332 self next. "skip doubled terminator" 278333 ] ifFalse: [ 278334 ^ out contents "terminator is not doubled; we're done!!" 278335 ]. 278336 ]. 278337 out nextPut: ch. 278338 ]. 278339 ^ out contents! ! 278340 278341!PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:53'! 278342nextInto: aCollection 278343 "Read the next elements of the receiver into aCollection. 278344 Return aCollection or a partial copy if less than aCollection 278345 size elements have been read." 278346 ^self next: aCollection size into: aCollection startingAt: 1.! ! 278347 278348!PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:59'! 278349nextInto: aCollection startingAt: startIndex 278350 "Read the next elements of the receiver into aCollection. 278351 Return aCollection or a partial copy if less than aCollection 278352 size elements have been read." 278353 ^self next: (aCollection size - startIndex+1) into: aCollection startingAt: startIndex.! ! 278354 278355!PositionableStream methodsFor: 'accessing' stamp: 'bf 11/24/1998 13:35'! 278356nextLine 278357 "Answer next line (may be empty), or nil if at end" 278358 278359 self atEnd ifTrue: [^nil]. 278360 ^self upTo: Character cr! ! 278361 278362!PositionableStream methodsFor: 'accessing' stamp: 'nk 3/18/2004 08:52'! 278363nextWordsInto: aBitmap 278364 "Fill the word based buffer from my collection. 278365 Stored on stream as Big Endian. Optimized for speed. 278366 Read in BigEndian, then restoreEndianness." 278367 | blt pos source byteSize | 278368 collection class isBytes 278369 ifFalse: [^ self next: aBitmap size into: aBitmap startingAt: 1]. 278370 278371 byteSize := aBitmap byteSize. 278372 "is the test on collection basicSize \\ 4 necessary?" 278373 ((self position bitAnd: 3) = 0 and: [ (collection basicSize bitAnd: 3) = 0]) 278374 ifTrue: [source := collection. 278375 pos := self position. 278376 self skip: byteSize] 278377 ifFalse: ["forced to copy it into a buffer" 278378 source := self next: byteSize. 278379 pos := 0]. 278380 278381 "Now use BitBlt to copy the bytes to the bitmap." 278382 blt := (BitBlt current 278383 toForm: (Form new hackBits: aBitmap)) 278384 sourceForm: (Form new hackBits: source). 278385 blt combinationRule: Form over. "store" 278386 blt sourceX: 0; 278387 sourceY: pos // 4; 278388 height: byteSize // 4; 278389 width: 4. 278390 blt destX: 0; 278391 destY: 0. 278392 blt copyBits. 278393 278394 "And do whatever the bitmap needs to do to convert from big-endian order." 278395 aBitmap restoreEndianness. 278396 278397 ^ aBitmap "May be WordArray, ColorArray, etc" 278398! ! 278399 278400!PositionableStream methodsFor: 'accessing' stamp: 'sw 3/10/98 13:55'! 278401next: anInteger 278402 "Answer the next anInteger elements of my collection. Must override 278403 because default uses self contents species, which might involve a large 278404 collection." 278405 278406 | newArray | 278407 newArray := collection species new: anInteger. 278408 1 to: anInteger do: [:index | newArray at: index put: self next]. 278409 ^newArray! ! 278410 278411!PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:58'! 278412next: n into: aCollection 278413 "Read n objects into the given collection. 278414 Return aCollection or a partial copy if less than 278415 n elements have been read." 278416 ^self next: n into: aCollection startingAt: 1! ! 278417 278418!PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:54'! 278419next: n into: aCollection startingAt: startIndex 278420 "Read n objects into the given collection. 278421 Return aCollection or a partial copy if less than 278422 n elements have been read." 278423 | obj | 278424 0 to: n-1 do:[:i| 278425 (obj := self next) == nil ifTrue:[^aCollection copyFrom: 1 to: startIndex+i-1]. 278426 aCollection at: startIndex+i put: obj]. 278427 ^aCollection! ! 278428 278429!PositionableStream methodsFor: 'accessing' stamp: 'ar 1/2/2000 15:32'! 278430next: anInteger putAll: aCollection 278431 "Store the next anInteger elements from the given collection." 278432 ^self next: anInteger putAll: aCollection startingAt: 1! ! 278433 278434!PositionableStream methodsFor: 'accessing' stamp: 'ar 8/12/2003 16:56'! 278435next: anInteger putAll: aCollection startingAt: startIndex 278436 "Store the next anInteger elements from the given collection." 278437 (startIndex = 1 and:[anInteger = aCollection size]) 278438 ifTrue:[^self nextPutAll: aCollection]. 278439 ^self nextPutAll: (aCollection copyFrom: startIndex to: startIndex+anInteger-1)! ! 278440 278441!PositionableStream methodsFor: 'accessing' stamp: 'pavel.krivanek 3/12/2009 11:01'! 278442oldBack 278443 "Go back one element and return it. Use indirect messages in case I am a StandardFileStream" 278444 "The method is a misconception about what a stream is. A stream contains a pointer *between* elements with past and future elements. This method considers that the pointer is *on* an element. Please consider unit tests which verifies #back and #oldBack behavior. (Damien Cassou - 1 August 2007)" 278445 self position = 0 ifTrue: [self positionError]. 278446 self position = 1 ifTrue: [self position: 0. ^ nil]. 278447 self skip: -2. 278448 ^ self next 278449! ! 278450 278451!PositionableStream methodsFor: 'accessing' stamp: 'damiencassou 11/23/2008 17:04'! 278452oldPeekBack 278453 "Return the element at the previous position, without changing position. Use indirect messages in case self is a StandardFileStream." 278454 "The method is a misconception about what a stream is. A stream contains a pointer *between* elements with past and future elements. This method considers that the pointer is *on* an element. Please consider unit tests which verifies #peekBack and #oldPeekBack behavior. (Damien Cassou - 1 August 2007)" 278455 | element | 278456 element := self oldBack. 278457 self skip: 1. 278458 ^ element 278459! ! 278460 278461!PositionableStream methodsFor: 'accessing'! 278462originalContents 278463 "Answer the receiver's actual contents collection, NOT a copy. 1/29/96 sw" 278464 278465 ^ collection! ! 278466 278467!PositionableStream methodsFor: 'accessing'! 278468peek 278469 "Answer what would be returned if the message next were sent to the 278470 receiver. If the receiver is at the end, answer nil." 278471 278472 | nextObject | 278473 self atEnd ifTrue: [^nil]. 278474 nextObject := self next. 278475 position := position - 1. 278476 ^nextObject! ! 278477 278478!PositionableStream methodsFor: 'accessing' stamp: 'ajh 1/18/2002 01:02'! 278479peekBack 278480 "Return the element at the previous position, without changing position. Use indirect messages in case self is a StandardFileStream." 278481 278482 | element | 278483 element := self back. 278484 self skip: 1. 278485 ^ element! ! 278486 278487!PositionableStream methodsFor: 'accessing'! 278488peekFor: anObject 278489 "Answer false and do not move over the next element if it is not equal to 278490 the argument, anObject, or if the receiver is at the end. Answer true 278491 and increment the position for accessing elements, if the next element is 278492 equal to anObject." 278493 278494 | nextObject | 278495 self atEnd ifTrue: [^false]. 278496 nextObject := self next. 278497 "peek for matching element" 278498 anObject = nextObject ifTrue: [^true]. 278499 "gobble it if found" 278500 position := position - 1. 278501 ^false! ! 278502 278503!PositionableStream methodsFor: 'accessing' stamp: 'tk 7/18/1999 17:10'! 278504upToAll: aCollection 278505 "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of aCollection. If aCollection is not in the stream, answer the entire rest of the stream." 278506 278507 | startPos endMatch result | 278508 startPos := self position. 278509 (self match: aCollection) 278510 ifTrue: [endMatch := self position. 278511 self position: startPos. 278512 result := self next: endMatch - startPos - aCollection size. 278513 self position: endMatch. 278514 ^ result] 278515 ifFalse: [self position: startPos. 278516 ^ self upToEnd]! ! 278517 278518!PositionableStream methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:51'! 278519upToEnd 278520 "Answer a subcollection from the current access position through the last element of the receiver." 278521 278522 | newStream | 278523 newStream := (collection species new: 100) writeStream. 278524 [self atEnd] whileFalse: [ newStream nextPut: self next ]. 278525 ^ newStream contents! ! 278526 278527!PositionableStream methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:51'! 278528upTo: anObject 278529 "Answer a subcollection from the current access position to the 278530 occurrence (if any, but not inclusive) of anObject in the receiver. If 278531 anObject is not in the collection, answer the entire rest of the receiver." 278532 | newStream element | 278533 newStream := (collection species new: 100) writeStream. 278534 [self atEnd or: [(element := self next) = anObject]] 278535 whileFalse: [newStream nextPut: element]. 278536 ^newStream contents! ! 278537 278538 278539!PositionableStream methodsFor: 'converting' stamp: 'tk 2/7/2000 11:08'! 278540asBinaryOrTextStream 278541 "Convert to a stream that can switch between bytes and characters" 278542 278543 ^ (RWBinaryOrTextStream with: self contentsOfEntireFile) reset! ! 278544 278545!PositionableStream methodsFor: 'converting' stamp: 'ar 1/2/2000 15:32'! 278546asZLibReadStream 278547 ^ZLibReadStream on: collection from: position+1 to: readLimit! ! 278548 278549 278550!PositionableStream methodsFor: 'data get/put' stamp: 'jm 10/5/2001 12:09'! 278551boolean 278552 "Answer the next boolean value from this (binary) stream." 278553 278554 ^ self next ~= 0 278555! ! 278556 278557!PositionableStream methodsFor: 'data get/put' stamp: 'jm 10/5/2001 12:11'! 278558boolean: aBoolean 278559 "Store the given boolean value on this (binary) stream." 278560 278561 self nextPut: (aBoolean ifTrue: [1] ifFalse: [0]). 278562! ! 278563 278564!PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 14:43'! 278565int16 278566 "Answer the next signed, 16-bit integer from this (binary) stream." 278567 278568 | n | 278569 n := self next. 278570 n := (n bitShift: 8) + (self next). 278571 n >= 16r8000 ifTrue: [n := n - 16r10000]. 278572 ^ n 278573! ! 278574 278575!PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 14:44'! 278576int16: anInteger 278577 "Store the given signed, 16-bit integer on this (binary) stream." 278578 278579 | n | 278580 (anInteger < -16r8000) | (anInteger >= 16r8000) 278581 ifTrue: [self error: 'outside 16-bit integer range']. 278582 278583 anInteger < 0 278584 ifTrue: [n := 16r10000 + anInteger] 278585 ifFalse: [n := anInteger]. 278586 self nextPut: (n digitAt: 2). 278587 self nextPut: (n digitAt: 1). 278588! ! 278589 278590!PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 15:15'! 278591int32 278592 "Answer the next signed, 32-bit integer from this (binary) stream." 278593 "Details: As a fast check for negative number, check the high bit of the first digit" 278594 278595 | n firstDigit | 278596 n := firstDigit := self next. 278597 n := (n bitShift: 8) + self next. 278598 n := (n bitShift: 8) + self next. 278599 n := (n bitShift: 8) + self next. 278600 firstDigit >= 128 ifTrue: [n := -16r100000000 + n]. "decode negative 32-bit integer" 278601 ^ n 278602! ! 278603 278604!PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 14:46'! 278605int32: anInteger 278606 "Store the given signed, 32-bit integer on this (binary) stream." 278607 278608 | n | 278609 (anInteger < -16r80000000) | (anInteger >= 16r80000000) 278610 ifTrue: [self error: 'outside 32-bit integer range']. 278611 278612 anInteger < 0 278613 ifTrue: [n := 16r100000000 + anInteger] 278614 ifFalse: [n := anInteger]. 278615 self nextPut: (n digitAt: 4). 278616 self nextPut: (n digitAt: 3). 278617 self nextPut: (n digitAt: 2). 278618 self nextPut: (n digitAt: 1). 278619! ! 278620 278621!PositionableStream methodsFor: 'data get/put' stamp: 'jm 9/5/2001 07:35'! 278622string 278623 "Answer the next string from this (binary) stream." 278624 278625 | size | 278626 size := self uint16. 278627 ^ (self next: size) asString 278628! ! 278629 278630!PositionableStream methodsFor: 'data get/put' stamp: 'jm 9/5/2001 12:09'! 278631string: aString 278632 "Store the given string on this (binary) stream. The string must contain 65535 or fewer characters." 278633 278634 aString size > 16rFFFF ifTrue: [self error: 'string too long for this format']. 278635 self uint16: aString size. 278636 self nextPutAll: aString asByteArray. 278637! ! 278638 278639!PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'! 278640uint16 278641 "Answer the next unsigned, 16-bit integer from this (binary) stream." 278642 278643 | n | 278644 n := self next. 278645 n := (n bitShift: 8) + (self next). 278646 ^ n 278647! ! 278648 278649!PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'! 278650uint16: anInteger 278651 "Store the given unsigned, 16-bit integer on this (binary) stream." 278652 278653 (anInteger < 0) | (anInteger >= 16r10000) 278654 ifTrue: [self error: 'outside unsigned 16-bit integer range']. 278655 278656 self nextPut: (anInteger digitAt: 2). 278657 self nextPut: (anInteger digitAt: 1). 278658! ! 278659 278660!PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 08:07'! 278661uint24 278662 "Answer the next unsigned, 24-bit integer from this (binary) stream." 278663 278664 | n | 278665 n := self next. 278666 n := (n bitShift: 8) + self next. 278667 n := (n bitShift: 8) + self next. 278668 ^ n 278669! ! 278670 278671!PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 08:07'! 278672uint24: anInteger 278673 "Store the given unsigned, 24-bit integer on this (binary) stream." 278674 278675 (anInteger < 0) | (anInteger >= 16r1000000) 278676 ifTrue: [self error: 'outside unsigned 24-bit integer range']. 278677 278678 self nextPut: (anInteger digitAt: 3). 278679 self nextPut: (anInteger digitAt: 2). 278680 self nextPut: (anInteger digitAt: 1). 278681! ! 278682 278683!PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'! 278684uint32 278685 "Answer the next unsigned, 32-bit integer from this (binary) stream." 278686 278687 | n | 278688 n := self next. 278689 n := (n bitShift: 8) + self next. 278690 n := (n bitShift: 8) + self next. 278691 n := (n bitShift: 8) + self next. 278692 ^ n 278693! ! 278694 278695!PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:52'! 278696uint32: anInteger 278697 "Store the given unsigned, 32-bit integer on this (binary) stream." 278698 278699 (anInteger < 0) | (anInteger >= 16r100000000) 278700 ifTrue: [self error: 'outside unsigned 32-bit integer range']. 278701 278702 self nextPut: (anInteger digitAt: 4). 278703 self nextPut: (anInteger digitAt: 3). 278704 self nextPut: (anInteger digitAt: 2). 278705 self nextPut: (anInteger digitAt: 1). 278706! ! 278707 278708 278709!PositionableStream methodsFor: 'fileIn/Out' stamp: 'PeterHugossonMiller 9/3/2009 10:20'! 278710backChunk 278711 "Answer the contents of the receiver back to the previous terminator character. Doubled terminators indicate an embedded terminator character." 278712 | terminator out ch | 278713 terminator := $!!. 278714 out := (String new: 1000) writeStream. 278715 [(ch := self back) == nil] whileFalse: [ 278716 (ch == terminator) ifTrue: [ 278717 self oldPeekBack == terminator ifTrue: [ 278718 self oldBack. "skip doubled terminator" 278719 ] ifFalse: [ 278720 ^ out contents reversed "we're done!!" 278721 ]. 278722 ]. 278723 out nextPut: ch. 278724 ]. 278725 ^ out contents reversed! ! 278726 278727 278728!PositionableStream methodsFor: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 10:43'! 278729basicNextChunk 278730 "Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character." 278731 | terminator out ch | 278732 terminator := $!!. 278733 out := (String new: 1000) writeStream. 278734 self skipSeparators. 278735 [(ch := self next) == nil] whileFalse: [ 278736 (ch == terminator) ifTrue: [ 278737 self peek == terminator ifTrue: [ 278738 self next. "skip doubled terminator" 278739 ] ifFalse: [ 278740 ^ out contents "terminator is not doubled; we're done!!" 278741 ]. 278742 ]. 278743 out nextPut: ch. 278744 ]. 278745 ^ out contents! ! 278746 278747!PositionableStream methodsFor: 'filein/out' stamp: 'sd 5/23/2003 14:40'! 278748checkForPreamble: chunk 278749 ((chunk beginsWith: '"Change Set:') and: [ChangeSet current preambleString == nil]) 278750 ifTrue: [ChangeSet current preambleString: chunk]. 278751 ((chunk beginsWith: '"Postscript:') and: [ChangeSet current postscriptString == nil]) 278752 ifTrue: [ChangeSet current postscriptString: chunk]. 278753 278754! ! 278755 278756!PositionableStream methodsFor: 'filein/out' stamp: 'di 2/3/98 14:44'! 278757copyMethodChunkFrom: aStream 278758 "Copy the next chunk from aStream (must be different from the receiver)." 278759 | chunk | 278760 chunk := aStream nextChunkText. 278761 chunk runs values size = 1 "Optimize for unembellished text" 278762 ifTrue: [self nextChunkPut: chunk asString] 278763 ifFalse: [self nextChunkPutWithStyle: chunk]! ! 278764 278765!PositionableStream methodsFor: 'filein/out' stamp: 'yo 10/15/2003 19:02'! 278766copyMethodChunkFrom: aStream at: pos 278767 "Copy the next chunk from aStream (must be different from the receiver)." 278768 | chunk | 278769 aStream position: pos. 278770 chunk := aStream nextChunkText. 278771 chunk runs values size = 1 "Optimize for unembellished text" 278772 ifTrue: [self nextChunkPut: chunk asString] 278773 ifFalse: [self nextChunkPutWithStyle: chunk]! ! 278774 278775!PositionableStream methodsFor: 'filein/out' stamp: 'SergeStinckwich 7/31/2009 15:25'! 278776copyPreamble: preamble from: aStream at: pos 278777 "Look for a changeStamp for this method by peeking backward. 278778 Write a method preamble, with that stamp if found." 278779 | terminator last50 stamp i | 278780 terminator := $!!. 278781 278782 "Look back to find stamp in old preamble, such as... 278783 Polygon methodsFor: 'private' stamp: 'di 6/25/97 21:42' prior: 34957598!! " 278784 aStream position: pos. 278785 aStream backChunk. "to beginning of method" 278786 last50 := aStream backChunk. "to get preamble" 278787 aStream position: pos. 278788 stamp := String new. 278789 (i := last50 278790 findLastOccurrenceOfString: 'stamp:' 278791 startingAt: 1) > 0 ifTrue: 278792 [ stamp := (last50 278793 copyFrom: i + 8 278794 to: last50 size) copyUpTo: $' ]. 278795 278796 "Write the new preamble, with old stamp if any." 278797 self 278798 cr; 278799 nextPut: terminator. 278800 self nextChunkPut: (String streamContents: 278801 [ :strm | 278802 strm nextPutAll: preamble. 278803 stamp size > 0 ifTrue: 278804 [ strm 278805 nextPutAll: ' stamp: '; 278806 print: stamp ] ]). 278807 self cr! ! 278808 278809!PositionableStream methodsFor: 'filein/out' stamp: 'ar 4/12/2005 17:34'! 278810decodeString: string andRuns: runsRaw 278811 278812 | strm runLength runValues newString index | 278813 strm := ReadStream on: runsRaw from: 1 to: runsRaw size. 278814 (strm peekFor: $( ) ifFalse: [^ nil]. 278815 runLength := OrderedCollection new. 278816 [strm skipSeparators. 278817 strm peekFor: $)] whileFalse: 278818 [runLength add: (Number readFrom: strm)]. 278819 278820 runValues := OrderedCollection new. 278821 [strm atEnd not] whileTrue: 278822 [runValues add: (Number readFrom: strm). 278823 strm next.]. 278824 278825 newString := WideString new: string size. 278826 index := 1. 278827 runLength with: runValues do: [:length :leadingChar | 278828 index to: index + length - 1 do: [:pos | 278829 newString at: pos put: (Character leadingChar: leadingChar code: (string at: pos) charCode). 278830 ]. 278831 index := index + length. 278832 ]. 278833 278834 ^ newString. 278835! ! 278836 278837!PositionableStream methodsFor: 'filein/out' stamp: 'tk 12/13/97 13:36'! 278838decodeStyle: runsObjData version: styleVersion 278839 "Decode the runs array from the ReferenceStream it is stored in." 278840 "Verify that the class mentioned have the same inst vars as we have now" 278841 278842 | structureInfo | 278843 styleVersion = RemoteString currentTextAttVersion ifTrue: [ 278844 "Matches our classes, no need for checking" 278845 ^ (ReferenceStream on: runsObjData) next]. 278846 structureInfo := RemoteString structureAt: styleVersion. "or nil" 278847 "See SmartRefStream instVarInfo: for dfn" 278848 ^ SmartRefStream read: runsObjData withClasses: structureInfo! ! 278849 278850!PositionableStream methodsFor: 'filein/out' stamp: 'mir 7/26/2000 13:28'! 278851fileIn 278852 "This is special for reading expressions from text that has been formatted 278853 with exclamation delimitors. The expressions are read and passed to the 278854 Compiler. Answer the result of compilation." 278855 278856 ^ self fileInAnnouncing: 'Reading ' , self name! ! 278857 278858!PositionableStream methodsFor: 'filein/out' stamp: 'NS 1/28/2004 11:22'! 278859fileInAnnouncing: announcement 278860 "This is special for reading expressions from text that has been formatted 278861 with exclamation delimitors. The expressions are read and passed to the 278862 Compiler. Answer the result of compilation. Put up a progress report with 278863 the given announcement as the title." 278864 278865 | val chunk | 278866 announcement 278867 displayProgressAt: Sensor cursorPoint 278868 from: 0 278869 to: self size 278870 during: 278871 [:bar | 278872 [self atEnd] whileFalse: 278873 [bar value: self position. 278874 self skipSeparators. 278875 278876 [val := (self peekFor: $!!) 278877 ifTrue: [(Compiler evaluate: self nextChunk logged: false) scanFrom: self] 278878 ifFalse: 278879 [chunk := self nextChunk. 278880 self checkForPreamble: chunk. 278881 Compiler evaluate: chunk logged: true]] 278882 on: InMidstOfFileinNotification 278883 do: [:ex | ex resume: true]. 278884 self skipStyleChunk]. 278885 self close]. 278886 "Note: The main purpose of this banner is to flush the changes file." 278887 SmalltalkImage current logChange: '----End fileIn of ' , self name , '----'. 278888 self flag: #ThisMethodShouldNotBeThere. "sd" 278889 Smalltalk forgetDoIts. 278890 ^val! ! 278891 278892!PositionableStream methodsFor: 'filein/out' stamp: 'NS 1/28/2004 11:21'! 278893fileInFor: client announcing: announcement 278894 "This is special for reading expressions from text that has been formatted 278895 with exclamation delimitors. The expressions are read and passed to the 278896 Compiler. Answer the result of compilation. Put up a progress report with 278897 the given announcement as the title. 278898 Does NOT handle preambles or postscripts specially." 278899 | val chunk | 278900 announcement displayProgressAt: Sensor cursorPoint 278901 from: 0 to: self size 278902 during: 278903 [:bar | 278904 [self atEnd] 278905 whileFalse: 278906 [bar value: self position. 278907 self skipSeparators. 278908 [ val := (self peekFor: $!!) ifTrue: [ 278909 (Compiler evaluate: self nextChunk for: client logged: false) scanFrom: self 278910 ] ifFalse: [ 278911 chunk := self nextChunk. 278912 self checkForPreamble: chunk. 278913 Compiler evaluate: chunk for: client logged: true ]. 278914 ] on: InMidstOfFileinNotification 278915 do: [ :ex | ex resume: true]. 278916 self atEnd ifFalse: [ self skipStyleChunk ]]. 278917 self close]. 278918 "Note: The main purpose of this banner is to flush the changes file." 278919 SmalltalkImage current logChange: '----End fileIn of ' , self name , '----'. 278920 Smalltalk forgetDoIts. 278921 ^ val! ! 278922 278923!PositionableStream methodsFor: 'filein/out' stamp: 'NorbertHartl 6/20/2008 21:55'! 278924fileInSilentlyAnnouncing: announcement 278925 "This is special for reading expressions from text that has been formatted 278926 with exclamation delimitors. The expressions are read and passed to the 278927 Compiler. Answer the result of compilation. Put up a progress report with 278928 the given announcement as the title." 278929 278930 | val chunk | 278931 [self atEnd] whileFalse: 278932 [self skipSeparators. 278933 278934 [val := (self peekFor: $!!) 278935 ifTrue: [(Compiler evaluate: self nextChunk logged: false) scanFrom: self] 278936 ifFalse: 278937 [chunk := self nextChunk. 278938 self checkForPreamble: chunk. 278939 Compiler evaluate: chunk logged: true]] 278940 on: InMidstOfFileinNotification 278941 do: [:ex | ex resume: true]. 278942 self skipStyleChunk]. 278943 self close. 278944 "Note: The main purpose of this banner is to flush the changes file." 278945 SmalltalkImage current logChange: '----End fileIn of ' , self name , '----'. 278946 self flag: #ThisMethodShouldNotBeThere. "sd" 278947 SystemNavigation new allBehaviorsDo: 278948 [:cl | 278949 cl 278950 removeSelectorSilently: #DoIt; 278951 removeSelectorSilently: #DoItIn:]. 278952 ^val! ! 278953 278954!PositionableStream methodsFor: 'filein/out'! 278955header 278956 "If the stream requires a standard header, override this message. See HtmlFileStream"! ! 278957 278958!PositionableStream methodsFor: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 10:43'! 278959nextChunk 278960 "Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character." 278961 | terminator out ch | 278962 terminator := $!!. 278963 out := (String new: 1000) writeStream. 278964 self skipSeparators. 278965 [(ch := self next) == nil] whileFalse: [ 278966 (ch == terminator) ifTrue: [ 278967 self peek == terminator ifTrue: [ 278968 self next. "skip doubled terminator" 278969 ] ifFalse: [ 278970 ^ self parseLangTagFor: out contents "terminator is not doubled; we're done!!" 278971 ]. 278972 ]. 278973 out nextPut: ch. 278974 ]. 278975 ^ self parseLangTagFor: out contents. 278976! ! 278977 278978!PositionableStream methodsFor: 'filein/out' stamp: 'sumim 11/20/2003 18:13'! 278979nextChunkText 278980 "Deliver the next chunk as a Text. Decode the following ]style[ chunk if present. Position at start of next real chunk." 278981 | string runsRaw strm runs peek pos | 278982 "Read the plain text" 278983 string := self nextChunk. 278984 278985 "Test for ]style[ tag" 278986 pos := self position. 278987 peek := self skipSeparatorsAndPeekNext. 278988 peek = $] ifFalse: [self position: pos. ^ string asText]. "no tag" 278989 (self upTo: $[) = ']style' ifFalse: [self position: pos. ^ string asText]. "different tag" 278990 278991 "Read and decode the style chunk" 278992 runsRaw := self basicNextChunk. "style encoding" 278993 strm := ReadStream on: runsRaw from: 1 to: runsRaw size. 278994 runs := RunArray scanFrom: strm. 278995 278996 ^ Text basicNew setString: string setRunsChecking: runs. 278997! ! 278998 278999!PositionableStream methodsFor: 'filein/out' stamp: 'sumim 11/20/2003 18:11'! 279000parseLangTagFor: aString 279001 279002 | string peek runsRaw pos | 279003 string := aString. 279004 "Test for ]lang[ tag" 279005 pos := self position. 279006 peek := self skipSeparatorsAndPeekNext. 279007 peek = $] ifFalse: [self position: pos. ^ string]. "no tag" 279008 (self upTo: $[) = ']lang' ifTrue: [ 279009 runsRaw := self basicNextChunk. 279010 string := self decodeString: aString andRuns: runsRaw 279011 ] ifFalse: [ 279012 self position: pos 279013 ]. 279014 ^ string. 279015! ! 279016 279017!PositionableStream methodsFor: 'filein/out' stamp: 'di 6/13/97 12:00'! 279018skipSeparators 279019 [self atEnd] 279020 whileFalse: 279021 [self next isSeparator ifFalse: [^ self position: self position-1]]! ! 279022 279023!PositionableStream methodsFor: 'filein/out' stamp: 'di 1/13/98 16:08'! 279024skipSeparatorsAndPeekNext 279025 "A special function to make nextChunk fast" 279026 | peek | 279027 [self atEnd] 279028 whileFalse: 279029 [(peek := self next) isSeparator 279030 ifFalse: [self position: self position-1. ^ peek]]! ! 279031 279032!PositionableStream methodsFor: 'filein/out' stamp: 'tk 12/29/97 12:37'! 279033skipStyleChunk 279034 "Get to the start of the next chunk that is not a style for the previous chunk" 279035 279036 | pos | 279037 pos := self position. 279038 self skipSeparators. 279039 self peek == $] 279040 ifTrue: [(self upTo: $[) = ']text' "old -- no longer needed" 279041 "now positioned past the open bracket" 279042 ifFalse: [self nextChunk]] "absorb ]style[ and its whole chunk" 279043 279044 ifFalse: [self position: pos] "leave untouched" 279045! ! 279046 279047!PositionableStream methodsFor: 'filein/out'! 279048trailer 279049 "If the stream requires a standard trailer, override this message. See HtmlFileStream"! ! 279050 279051!PositionableStream methodsFor: 'filein/out'! 279052unCommand 279053 "If this read stream is at a <, then skip up to just after the next >. For removing html commands." 279054 | char | 279055 [self peek = $<] whileTrue: ["begin a block" 279056 [self atEnd == false and: [self next ~= $>]] whileTrue. 279057 "absorb characters" 279058 ]. 279059 ! ! 279060 279061!PositionableStream methodsFor: 'filein/out'! 279062verbatim: aString 279063 "Do not attempt to translate the characters. Use to override nextPutAll:" 279064 ^ self nextPutAll: aString! ! 279065 279066 279067!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'! 279068nextInt32 279069 "Read a 32-bit signed integer from the next 4 bytes" 279070 | s | 279071 s := 0. 279072 1 to: 4 do: [:i | s := (s bitShift: 8) + self next]. 279073 (s bitAnd: 16r80000000) = 0 279074 ifTrue: [^ s] 279075 ifFalse: [^ -1 - s bitInvert32]! ! 279076 279077!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'! 279078nextInt32Put: int32 279079 "Write a signed integer to the next 4 bytes" 279080 | pos | 279081 pos := int32 < 0 279082 ifTrue: [(0-int32) bitInvert32 + 1] 279083 ifFalse: [int32]. 279084 1 to: 4 do: [:i | self nextPut: (pos digitAt: 5-i)]. 279085 ^ int32! ! 279086 279087!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'jm 4/9/98 21:36'! 279088nextLittleEndianNumber: n 279089 "Answer the next n bytes as a positive Integer or LargePositiveInteger, where the bytes are ordered from least significant to most significant." 279090 279091 | bytes s | 279092 bytes := self next: n. 279093 s := 0. 279094 n to: 1 by: -1 do: [:i | s := (s bitShift: 8) bitOr: (bytes at: i)]. 279095 ^ s 279096! ! 279097 279098!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'stephane.ducasse 4/13/2009 20:31'! 279099nextLittleEndianNumber: n put: value 279100 "Answer the next n bytes as a positive Integer or LargePositiveInteger, where the bytes are ordered from least significant to most significant." 279101 | bytes | 279102 bytes := ByteArray new: n. 279103 1 to: n do: [:i | bytes at: i put: (value digitAt: i)]. 279104 self nextPutAll: bytes! ! 279105 279106!PositionableStream methodsFor: 'nonhomogeneous accessing'! 279107nextNumber: n 279108 "Answer the next n bytes as a positive Integer or LargePositiveInteger." 279109 | s | 279110 s := 0. 279111 1 to: n do: 279112 [:i | s := (s bitShift: 8) bitOr: self next asInteger]. 279113 ^ s normalize! ! 279114 279115!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'! 279116nextNumber: n put: v 279117 "Append to the receiver the argument, v, which is a positive 279118 SmallInteger or a LargePositiveInteger, as the next n bytes. 279119 Possibly pad with leading zeros." 279120 279121 1 to: n do: [:i | self nextPut: (v digitAt: n+1-i)]. 279122 ^ v 279123! ! 279124 279125!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'yo 3/1/2005 06:03'! 279126nextString 279127 "Read a string from the receiver. The first byte is the length of the string, unless it is greater than 192, in which case the first four bytes encode the length. I expect to be in ascii mode when called (caller puts back to binary)." 279128 279129 | length aByteArray | 279130 279131 "read the length in binary mode" 279132 self binary. 279133 length := self next. "first byte." 279134 length >= 192 ifTrue: [length := length - 192. 279135 1 to: 3 do: [:ii | length := length * 256 + self next]]. 279136 aByteArray := ByteArray new: length. 279137 279138 self nextInto: aByteArray. 279139 ^aByteArray asString. 279140! ! 279141 279142!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'tk 6/8/1998 21:01'! 279143nextStringOld 279144 "Read a string from the receiver. The first byte is the length of the 279145 string, unless it is greater than 192, in which case the first *two* bytes 279146 encode the length. Max size 16K. " 279147 279148 | aString length | 279149 length := self next. "first byte." 279150 length >= 192 ifTrue: [length := (length - 192) * 256 + self next]. 279151 aString := String new: length. 279152 1 to: length do: [:ii | aString at: ii put: self next asCharacter]. 279153 ^aString! ! 279154 279155!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'yo 4/16/2001 17:56'! 279156nextStringPut: s 279157 "Append the string, s, to the receiver. Only used by DataStream. Max size of 64*256*256*256." 279158 279159 | length | 279160 (length := s size) < 192 279161 ifTrue: [self nextPut: length] 279162 ifFalse: 279163 [self nextPut: (length digitAt: 4)+192. 279164 self nextPut: (length digitAt: 3). 279165 self nextPut: (length digitAt: 2). 279166 self nextPut: (length digitAt: 1)]. 279167 self nextPutAll: s asByteArray. 279168 ^s! ! 279169 279170!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'! 279171nextWord 279172 "Answer the next two bytes from the receiver as an Integer." 279173 279174 | high low | 279175 high := self next. 279176 high==nil ifTrue: [^false]. 279177 low := self next. 279178 low==nil ifTrue: [^false]. 279179 ^(high asInteger bitShift: 8) + low asInteger! ! 279180 279181!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'! 279182nextWordPut: aWord 279183 "Append to the receiver an Integer as the next two bytes." 279184 279185 self nextPut: ((aWord bitShift: -8) bitAnd: 255). 279186 self nextPut: (aWord bitAnd: 255). 279187 ^aWord! ! 279188 279189 279190!PositionableStream methodsFor: 'positioning' stamp: 'damiencassou 5/30/2008 11:45'! 279191backUpTo: subCollection 279192 "Back up the position to he subCollection. Position must be somewhere within the stream initially. Leave it just after it. Return true if succeeded. No wildcards, and case does matter." 279193 "Example: 279194 | strm | strm := ReadStream on: 'zabc abdc'. 279195 strm setToEnd; backUpTo: 'abc'; position 279196" 279197 | pattern startMatch | 279198 pattern := subCollection reversed readStream. 279199 startMatch := nil. 279200 [ pattern atEnd ] whileFalse: 279201 [ self position = 0 ifTrue: [ ^ false ]. 279202 self skip: -1. 279203 self next = pattern next 279204 ifTrue: [ pattern position = 1 ifTrue: [ startMatch := self position ] ] 279205 ifFalse: 279206 [ pattern position: 0. 279207 startMatch ifNotNil: 279208 [ self position: startMatch - 1. 279209 startMatch := nil ] ]. 279210 self skip: -1 ]. 279211 self position: startMatch. 279212 ^ true! ! 279213 279214!PositionableStream methodsFor: 'positioning' stamp: 'damiencassou 5/30/2008 11:45'! 279215match: subCollection 279216 "Set the access position of the receiver to be past the next occurrence of the subCollection. Answer whether subCollection is found. No wildcards, and case does matter." 279217 | pattern startMatch | 279218 pattern := subCollection readStream. 279219 startMatch := nil. 279220 [ pattern atEnd ] whileFalse: 279221 [ self atEnd ifTrue: [ ^ false ]. 279222 self next = pattern next 279223 ifTrue: [ pattern position = 1 ifTrue: [ startMatch := self position ] ] 279224 ifFalse: 279225 [ pattern position: 0. 279226 startMatch ifNotNil: 279227 [ self position: startMatch. 279228 startMatch := nil ] ] ]. 279229 ^ true! ! 279230 279231!PositionableStream methodsFor: 'positioning' stamp: 'di 5/25/1998 15:16'! 279232padToNextLongPut: char 279233 "Make position be on long word boundary, writing the padding 279234 character, char, if necessary." 279235 [self position \\ 4 = 0] 279236 whileFalse: [self nextPut: char]! ! 279237 279238!PositionableStream methodsFor: 'positioning' stamp: 'di 2/15/98 14:41'! 279239padTo: nBytes put: aCharacter 279240 "Pad using the argument, aCharacter, to the next boundary of nBytes characters." 279241 | rem | 279242 rem := nBytes - (self position \\ nBytes). 279243 rem = nBytes ifTrue: [^ 0]. 279244 self next: rem put: aCharacter.! ! 279245 279246!PositionableStream methodsFor: 'positioning'! 279247position 279248 "Answer the current position of accessing the sequence of objects." 279249 279250 ^position! ! 279251 279252!PositionableStream methodsFor: 'positioning' stamp: 'mir 6/29/2004 17:35'! 279253positionOfSubCollection: subCollection 279254 "Return a position such that that element at the new position equals the first element of sub, and the next elements equal the rest of the elements of sub. Begin the search at the current position. 279255 If no such match is found, answer 0." 279256 279257 ^self positionOfSubCollection: subCollection ifAbsent: [0]! ! 279258 279259!PositionableStream methodsFor: 'positioning' stamp: 'damiencassou 5/30/2008 11:45'! 279260positionOfSubCollection: subCollection ifAbsent: exceptionBlock 279261 "Return a position such that that element at the new position equals the first element of sub, and the next elements equal the rest of the elements of sub. Begin the search at the current position. 279262 If no such match is found, answer the result of evaluating argument, exceptionBlock." 279263 | pattern startPosition currentPosition | 279264 pattern := subCollection readStream. 279265 startPosition := self position. 279266 [ pattern atEnd ] whileFalse: 279267 [ self atEnd ifTrue: [ ^ exceptionBlock value ]. 279268 self next = pattern next ifFalse: 279269 [ self position: self position - pattern position + 1. 279270 pattern reset ] ]. 279271 currentPosition := self position. 279272 self position: startPosition. 279273 ^ pattern atEnd 279274 ifTrue: [ currentPosition + 1 - subCollection size ] 279275 ifFalse: [ exceptionBlock value ]! ! 279276 279277!PositionableStream methodsFor: 'positioning' stamp: 'nice 3/10/2008 22:29'! 279278position: anInteger 279279 "Set the current position for accessing the objects to be anInteger, as long 279280 as anInteger is within the bounds of the receiver's contents. If it is not, 279281 create an error notification." 279282 279283 (anInteger >= 0 and: [anInteger <= readLimit]) 279284 ifTrue: [position := anInteger] 279285 ifFalse: [self positionError]! ! 279286 279287!PositionableStream methodsFor: 'positioning' stamp: 'mir 5/14/2003 18:45'! 279288pushBack: aString 279289 "Compatibility with SocketStreams" 279290 self skip: aString size negated! ! 279291 279292!PositionableStream methodsFor: 'positioning'! 279293reset 279294 "Set the receiver's position to the beginning of the sequence of objects." 279295 279296 position := 0! ! 279297 279298!PositionableStream methodsFor: 'positioning' stamp: 'sw 3/10/98 13:55'! 279299resetContents 279300 "Set the position and limits to 0." 279301 279302 position := 0. 279303 readLimit := 0! ! 279304 279305!PositionableStream methodsFor: 'positioning'! 279306setToEnd 279307 "Set the position of the receiver to the end of the sequence of objects." 279308 279309 position := readLimit! ! 279310 279311!PositionableStream methodsFor: 'positioning'! 279312skipTo: anObject 279313 "Set the access position of the receiver to be past the next occurrence of 279314 anObject. Answer whether anObject is found." 279315 279316 [self atEnd] 279317 whileFalse: [self next = anObject ifTrue: [^true]]. 279318 ^false! ! 279319 279320!PositionableStream methodsFor: 'positioning'! 279321skip: anInteger 279322 "Set the receiver's position to be the current position+anInteger. A 279323 subclass might choose to be more helpful and select the minimum of the 279324 receiver's size and position+anInteger, or the maximum of 1 and 279325 position+anInteger for the repositioning." 279326 279327 self position: position + anInteger! ! 279328 279329!PositionableStream methodsFor: 'positioning' stamp: 'tak 8/5/2005 10:34'! 279330untilEndWithFork: aBlock displayingProgress: aString 279331 | sem done result | 279332 sem := Semaphore new. 279333 done := false. 279334 [[result := aBlock value] 279335 ensure: [done := true. 279336 sem signal]] fork. 279337 self 279338 untilEnd: [done 279339 ifTrue: [^ result]. 279340 (Delay forSeconds: 0.2) wait] 279341 displayingProgress: aString. 279342 sem wait. 279343 ^ result! ! 279344 279345 279346!PositionableStream methodsFor: 'testing'! 279347atEnd 279348 "Primitive. Answer whether the receiver can access any more objects. 279349 Optional. See Object documentation whatIsAPrimitive." 279350 279351 <primitive: 67> 279352 ^position >= readLimit! ! 279353 279354!PositionableStream methodsFor: 'testing' stamp: 'ar 1/2/2000 17:24'! 279355isBinary 279356 "Return true if the receiver is a binary byte stream" 279357 ^collection class == ByteArray! ! 279358 279359!PositionableStream methodsFor: 'testing' stamp: 'damiencassou 5/15/2009 15:06'! 279360isEmpty 279361 "Answer whether the receiver's contents has no elements." 279362 279363 "Returns true if both the set of past and future sequence values of 279364the receiver are empty. Otherwise returns false" 279365 279366 ^ self atEnd and: [position = 0]! ! 279367 279368 279369!PositionableStream methodsFor: 'private'! 279370on: aCollection 279371 279372 collection := aCollection. 279373 readLimit := aCollection size. 279374 position := 0. 279375 self reset! ! 279376 279377!PositionableStream methodsFor: 'private'! 279378positionError 279379 "Since I am not necessarily writable, it is up to my subclasses to override 279380 position: if expanding the collection is preferrable to giving this error." 279381 279382 self error: 'Attempt to set the position of a PositionableStream out of bounds'! ! 279383 279384!PositionableStream methodsFor: 'private'! 279385setFrom: newStart to: newStop 279386 279387 position := newStart - 1. 279388 readLimit := newStop! ! 279389 279390"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 279391 279392PositionableStream class 279393 instanceVariableNames: ''! 279394 279395!PositionableStream class methodsFor: 'instance creation'! 279396on: aCollection 279397 "Answer an instance of me, streaming over the elements of aCollection." 279398 279399 ^self basicNew on: aCollection! ! 279400 279401!PositionableStream class methodsFor: 'instance creation'! 279402on: aCollection from: firstIndex to: lastIndex 279403 "Answer an instance of me, streaming over the elements of aCollection 279404 starting with the element at firstIndex and ending with the one at 279405 lastIndex." 279406 279407 ^self basicNew on: (aCollection copyFrom: firstIndex to: lastIndex)! ! 279408Object subclass: #Pragma 279409 instanceVariableNames: 'method keyword arguments' 279410 classVariableNames: '' 279411 poolDictionaries: '' 279412 category: 'Kernel-Methods'! 279413!Pragma commentStamp: '<historical>' prior: 0! 279414I represent an occurrence of a pragma in a compiled method. A pragma is a literal message pattern that occurs between angle brackets at the start of a method after any temporaries. A common example is the primitive pragma: 279415 <primitive: 123 errorCode: 'errorCode'> 279416but one can add one's own and use them as metadata attached to a method. Because pragmas are messages one can browsse senders and implementors and perform them. One can query a method for its pragmas by sendng it the pragmas message, which answers an Array of instances of me, one for each pragma in the method. 279417 279418I can provide information about the defining class, method, its selector, as well as the information about the pragma keyword and its arguments. See the two 'accessing' protocols for details. 'accessing-method' provides information about the method the pragma is found in, while 'accessing-pragma' is about the pragma itself. 279419 279420Instances are retrieved using one of the pragma search methods of the 'finding' protocol on the class side. 279421 279422To browse all methods with pragmas in the system evaluate 279423 SystemNavigation default browseAllSelect: [:m| m pragmas notEmpty] 279424and to browse all nonprimitive methods with pragmas evaluate 279425 SystemNavigation default browseAllSelect: [:m| m primitive isZero and: [m pragmas notEmpty]]! 279426 279427 279428!Pragma methodsFor: 'accessing-method' stamp: 'lr 1/20/2006 02:04'! 279429method 279430 "Answer the compiled-method containing the pragma." 279431 279432 ^ method! ! 279433 279434!Pragma methodsFor: 'accessing-method' stamp: 'lr 1/20/2006 02:08'! 279435methodClass 279436 "Answer the class of the method containing the pragma." 279437 279438 ^ method methodClass! ! 279439 279440!Pragma methodsFor: 'accessing-method' stamp: 'eem 12/1/2008 10:43'! 279441selector 279442 "Answer the selector of the method containing the pragma. 279443 Do not confuse this with the selector of the pragma's message pattern." 279444 279445 ^method selector! ! 279446 279447 279448!Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/20/2006 02:10'! 279449argumentAt: anInteger 279450 "Answer one of the arguments of the pragma." 279451 279452 ^ self arguments at: anInteger.! ! 279453 279454!Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/19/2006 20:54'! 279455arguments 279456 "Answer the arguments of the receiving pragma. For a pragma defined as <key1: val1 key2: val2> this will answer #(val1 val2)." 279457 279458 ^ arguments! ! 279459 279460!Pragma methodsFor: 'accessing-pragma' stamp: 'eem 12/1/2008 10:42'! 279461key 279462 "Answer the keyword of the pragma (the selector of its message pattern). 279463 This accessor provides polymorphism with Associations used for properties." 279464 ^keyword! ! 279465 279466!Pragma methodsFor: 'accessing-pragma' stamp: 'eem 12/1/2008 10:42'! 279467keyword 279468 "Answer the keyword of the pragma (the selector of its message pattern). 279469 For a pragma defined as <key1: val1 key2: val2> this will answer #key1:key2:." 279470 279471 ^ keyword! ! 279472 279473!Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/19/2006 20:55'! 279474message 279475 "Answer the message of the receiving pragma." 279476 279477 ^ Message selector: self keyword arguments: self arguments. ! ! 279478 279479!Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/20/2006 02:10'! 279480numArgs 279481 "Answer the number of arguments in the pragma." 279482 279483 ^ self arguments size.! ! 279484 279485 279486!Pragma methodsFor: 'comparing' stamp: 'eem 3/7/2009 11:54'! 279487analogousCodeTo: anObject 279488 ^self class == anObject class 279489 and: [keyword == anObject keyword 279490 and: [arguments = anObject arguments]]! ! 279491 279492 279493!Pragma methodsFor: 'initialization' stamp: 'lr 1/20/2006 00:53'! 279494setArguments: anArray 279495 arguments := anArray! ! 279496 279497!Pragma methodsFor: 'initialization' stamp: 'lr 1/20/2006 00:53'! 279498setKeyword: aSymbol 279499 keyword := aSymbol! ! 279500 279501!Pragma methodsFor: 'initialization' stamp: 'lr 1/19/2006 23:39'! 279502setMethod: aCompiledMethod 279503 method := aCompiledMethod! ! 279504 279505 279506!Pragma methodsFor: 'printing' stamp: 'lr 2/6/2006 19:56'! 279507printOn: aStream 279508 aStream nextPut: $<. 279509 self keyword precedence = 1 279510 ifTrue: [ aStream nextPutAll: self keyword ] 279511 ifFalse: [ 279512 self keyword keywords with: self arguments do: [ :key :arg | 279513 aStream nextPutAll: key; space; print: arg; space ]. 279514 aStream skip: -1 ]. 279515 aStream nextPut: $>.! ! 279516 279517 279518!Pragma methodsFor: 'processing' stamp: 'lr 3/19/2007 11:37'! 279519sendTo: anObject 279520 "Send the pragma keyword together with its arguments to anObject and answer the result." 279521 279522 ^ anObject perform: self keyword withArguments: self arguments! ! 279523 279524!Pragma methodsFor: 'processing' stamp: 'lr 3/19/2007 11:37'! 279525withArgumentsDo: aBlock 279526 "Pass the arguments of the receiving pragma into aBlock and answer the result." 279527 279528 ^ aBlock valueWithArguments: self arguments! ! 279529 279530 279531!Pragma methodsFor: 'testing' stamp: 'eem 11/29/2008 17:03'! 279532hasLiteralSuchThat: aBlock 279533 "Answer true if litBlock returns true for any literal in the receiver, even if embedded in further array structure. 279534 This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" 279535 ^(aBlock value: keyword) 279536 or: [arguments hasLiteralSuchThat: aBlock]! ! 279537 279538!Pragma methodsFor: 'testing' stamp: 'eem 11/29/2008 16:39'! 279539hasLiteral: aLiteral 279540 ^keyword == aLiteral 279541 or: [arguments hasLiteral: aLiteral]! ! 279542 279543"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 279544 279545Pragma class 279546 instanceVariableNames: ''! 279547 279548!Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 08:54'! 279549allNamed: aSymbol from: aSubClass to: aSuperClass 279550 "Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol." 279551 279552 ^ Array streamContents: [ :stream | 279553 aSubClass withAllSuperclassesDo: [ :class | 279554 self withPragmasIn: class do: [ :pragma | 279555 pragma keyword = aSymbol 279556 ifTrue: [ stream nextPut: pragma ] ]. 279557 aSuperClass = class 279558 ifTrue: [ ^ stream contents ] ] ].! ! 279559 279560!Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 18:16'! 279561allNamed: aSymbol from: aSubClass to: aSuperClass sortedByArgument: anInteger 279562 "Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol, sorted according to argument anInteger." 279563 279564 ^ self allNamed: aSymbol from: aSubClass to: aSuperClass sortedUsing: [ :a :b | (a argumentAt: anInteger) < (b argumentAt: anInteger) ].! ! 279565 279566!Pragma class methodsFor: 'finding' stamp: 'lr 1/19/2006 20:12'! 279567allNamed: aSymbol from: aSubClass to: aSuperClass sortedUsing: aSortBlock 279568 "Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol, sorted according to aSortBlock." 279569 279570 ^ (self allNamed: aSymbol from: aSubClass to: aSuperClass) sort: aSortBlock.! ! 279571 279572!Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 08:55'! 279573allNamed: aSymbol in: aClass 279574 "Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol." 279575 279576 ^ Array streamContents: [ :stream | 279577 self withPragmasIn: aClass do: [ :pragma | 279578 pragma keyword = aSymbol 279579 ifTrue: [ stream nextPut: pragma ] ] ].! ! 279580 279581!Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 18:16'! 279582allNamed: aSymbol in: aClass sortedByArgument: anInteger 279583 "Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol, sorted according to argument anInteger." 279584 279585 ^ self allNamed: aSymbol in: aClass sortedUsing: [ :a :b | (a argumentAt: anInteger) < (b argumentAt: anInteger) ].! ! 279586 279587!Pragma class methodsFor: 'finding' stamp: 'lr 1/19/2006 20:06'! 279588allNamed: aSymbol in: aClass sortedUsing: aSortBlock 279589 "Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol, sorted according to aSortBlock." 279590 279591 ^ (self allNamed: aSymbol in: aClass) sort: aSortBlock.! ! 279592 279593 279594!Pragma class methodsFor: 'private' stamp: 'lr 1/20/2006 00:34'! 279595keyword: aSymbol arguments: anArray 279596 ^ self new 279597 setKeyword: aSymbol; 279598 setArguments: anArray; 279599 yourself.! ! 279600 279601!Pragma class methodsFor: 'private' stamp: 'lr 1/20/2006 08:50'! 279602withPragmasIn: aClass do: aBlock 279603 aClass selectorsAndMethodsDo: [ :selector :method | method pragmas do: aBlock ].! ! 279604 279605 279606!Pragma class methodsFor: 'instance creation' stamp: 'eem 11/29/2008 14:00'! 279607for: aMethod selector: aSelector arguments: anArray 279608 ^self new 279609 setMethod: aMethod; 279610 setKeyword: aSelector; 279611 setArguments: anArray; 279612 yourself! ! 279613SystemWindow subclass: #PreDebugWindow 279614 instanceVariableNames: 'proceedButton debugButton' 279615 classVariableNames: '' 279616 poolDictionaries: '' 279617 category: 'Morphic-Windows'! 279618 279619!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/29/1999 07:37'! 279620adjustBookControls 279621 | inner | 279622 proceedButton ifNil: [^ self]. 279623 proceedButton align: proceedButton topLeft with: (inner := self innerBounds) topLeft + (35@-4). 279624 debugButton align: debugButton topRight with: inner topRight - (16@4).! ! 279625 279626!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'nk 2/12/2003 23:00'! 279627createMethod 279628 model createMethod! ! 279629 279630!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 10/15/1998 13:00'! 279631debug 279632 model debug! ! 279633 279634!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 10/15/1998 13:00'! 279635proceed 279636 model proceed! ! 279637 279638!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'yo 3/15/2005 13:07'! 279639setBalloonTextForCloseBox 279640 closeBox ifNotNil: 279641 [closeBox setBalloonText: 'abandon this execution by closing this window' translated]. 279642! ! 279643 279644!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'mir 11/10/2003 15:15'! 279645storeLog 279646 model storeLog! ! 279647 279648 279649!PreDebugWindow methodsFor: 'geometry' stamp: 'sw 11/4/1998 09:50'! 279650extent: newExtent 279651 super extent: (newExtent max: 100 @ 50). 279652 self adjustBookControls! ! 279653 279654 279655!PreDebugWindow methodsFor: 'initialization' stamp: 'aoy 2/15/2003 21:39'! 279656initialize 279657 | aFont proceedLabel debugLabel aWidth | 279658 super initialize. 279659 true 279660 ifFalse: 279661 ["Preferences optionalMorphicButtons" 279662 279663 (aWidth := self widthOfFullLabelText) > 280 ifTrue: [^self]. "No proceed/debug buttons if title too long" 279664 debugLabel := aWidth > 210 279665 ifTrue: 279666 ["Abbreviated buttons if title pretty long" 279667 279668 proceedLabel := 'p'. 279669 'd'] 279670 ifFalse: 279671 ["Full buttons if title short enough" 279672 279673 proceedLabel := 'proceed'. 279674 'debug']. 279675 aFont := Preferences standardButtonFont. 279676 self addMorph: (proceedButton := (SimpleButtonMorph new) 279677 borderWidth: 0; 279678 label: proceedLabel font: aFont; 279679 color: Color transparent; 279680 actionSelector: #proceed; 279681 target: self). 279682 proceedButton setBalloonText: 'continue execution'. 279683 self addMorph: (debugButton := (SimpleButtonMorph new) 279684 borderWidth: 0; 279685 label: debugLabel font: aFont; 279686 color: Color transparent; 279687 actionSelector: #debug; 279688 target: self). 279689 debugButton setBalloonText: 'bring up a debugger'. 279690 proceedButton submorphs first color: Color blue. 279691 debugButton submorphs first color: Color red]. 279692 self adjustBookControls! ! 279693 279694 279695!PreDebugWindow methodsFor: 'label' stamp: 'alain.plantec 5/30/2008 14:17'! 279696setLabelWidgetAllowance 279697 ^ labelWidgetAllowance := Preferences optionalButtons 279698 ifTrue: [super setLabelWidgetAllowance] 279699 ifFalse: [180]! ! 279700 279701"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 279702 279703PreDebugWindow class 279704 instanceVariableNames: ''! 279705 279706!PreDebugWindow class methodsFor: 'new-morph participation' stamp: 'sw 11/4/1998 09:20'! 279707includeInNewMorphMenu 279708 ^ false! ! 279709Object subclass: #Preference 279710 instanceVariableNames: 'name value defaultValue helpString localToProject categoryList changeInformee changeSelector viewRegistry' 279711 classVariableNames: '' 279712 poolDictionaries: '' 279713 category: 'System-Support'! 279714!Preference commentStamp: '<historical>' prior: 0! 279715Represents a true/false flag that is under user control and which can be interrogated by a call to Preferences 279716 viewRegistry the registry of the classes responsible for building my view 279717 name a symbol, the formal name of the preference. 279718 value a boolean, the current value 279719 defaultValue the default value of the preference 279720 helpString string or text, constituting the help message 279721 localToProject boolean, whether each project holds its own version 279722 categoryList list of categories under which to offer this 279723 changeInformee whom, if anyone, to inform if the value changes: 279724 changeSelector what selector to send to the changeInformee when the value changes! 279725 279726 279727!Preference methodsFor: 'change notification' stamp: 'michael.rueger 4/27/2009 18:00'! 279728changeInformee 279729 279730 ^changeInformee! ! 279731 279732!Preference methodsFor: 'change notification' stamp: 'sw 4/12/2001 01:39'! 279733changeInformee: informee changeSelector: aSelector 279734 "Set the changeInformee and changeSelector as specified" 279735 279736 changeInformee := informee. 279737 changeSelector := aSelector! ! 279738 279739!Preference methodsFor: 'change notification' stamp: 'sw 4/12/2001 00:03'! 279740notifyInformeeOfChange 279741 "If there is a changeInformee, notify her that I have changed value" 279742 279743 changeInformee ifNotNil: [changeInformee perform: changeSelector]! ! 279744 279745 279746!Preference methodsFor: 'debugging' stamp: 'sw 4/13/2001 00:05'! 279747printOn: aStream 279748 "Print a string decribing the receiver to the given stream" 279749 279750 super printOn: aStream. 279751 aStream nextPutAll: name storeString, ' ', value storeString! ! 279752 279753 279754!Preference methodsFor: 'initialization' stamp: 'sw 4/29/2001 23:51'! 279755categoryList: aList 279756 "Set the receiver's categoryList" 279757 279758 categoryList := aList! ! 279759 279760!Preference methodsFor: 'initialization' stamp: 'michael.rueger 4/27/2009 17:54'! 279761changeInformee: informee 279762 "Set the object to be informed when my value changes" 279763 279764 changeInformee := (informee == nil or: [informee == #nil]) 279765 ifTrue: [nil] 279766 ifFalse: [(informee isKindOf: Symbol) 279767 ifTrue: 279768 [Smalltalk at: informee] 279769 ifFalse: 279770 [informee]]! ! 279771 279772!Preference methodsFor: 'initialization' stamp: 'hpt 9/26/2004 15:59'! 279773name: aName defaultValue: aValue helpString: aString localToProject: projectBoolean categoryList: aList changeInformee: informee changeSelector: aChangeSelector viewRegistry: aViewRegistry 279774 "Initialize the preference from the given values. There is an extra tolerence here for the symbols #true, #false, and #nil, which are interpreted, when appropriate, as meaning true, false, and nil" 279775 279776 name := aName asSymbol. 279777 defaultValue := aValue. 279778 aValue = #true ifTrue: [defaultValue := true]. 279779 aValue = #false ifTrue: [defaultValue := false]. 279780 value := defaultValue. 279781 helpString := aString. 279782 localToProject := projectBoolean == true or: [projectBoolean = #true]. 279783 viewRegistry := aViewRegistry. 279784 categoryList := (aList ifNil: [OrderedCollection with: #unclassified]) collect: 279785 [:elem | elem asSymbol]. 279786 279787 changeInformee := (informee == nil or: [informee == #nil]) 279788 ifTrue: [nil] 279789 ifFalse: [(informee isKindOf: Symbol) 279790 ifTrue: 279791 [Smalltalk at: informee] 279792 ifFalse: 279793 [informee]]. 279794 changeSelector := aChangeSelector! ! 279795 279796 279797!Preference methodsFor: 'local to project' stamp: 'sw 4/10/2001 12:37'! 279798isProjectLocalString 279799 "Answer a string representing whether sym is a project-local preference or not" 279800 279801 | aStr | 279802 aStr := 'each project has its own setting'. 279803 ^ localToProject 279804 ifTrue: 279805 ['<yes>', aStr] 279806 ifFalse: 279807 ['<no>', aStr]! ! 279808 279809!Preference methodsFor: 'local to project' stamp: 'sw 4/10/2001 01:14'! 279810localToProject 279811 "Answer whether this preference is project-local" 279812 279813 ^ localToProject! ! 279814 279815!Preference methodsFor: 'local to project' stamp: 'alain.plantec 6/6/2009 14:23'! 279816toggleProjectLocalness 279817 "Toggle whether the preference should be held project-by-project or globally" 279818 279819 localToProject := localToProject not. 279820! ! 279821 279822 279823!Preference methodsFor: 'menu' stamp: 'sw 4/12/2001 23:42'! 279824categoryList 279825 "Answer the categoryList" 279826 279827 ^ categoryList! ! 279828 279829!Preference methodsFor: 'menu' stamp: 'sw 4/13/2001 00:01'! 279830copyName 279831 "Copy the name of the given preference to the clipboard" 279832 279833 Clipboard clipboardText: name asString asText! ! 279834 279835!Preference methodsFor: 'menu' stamp: 'sw 4/13/2001 00:04'! 279836helpString 279837 "Answer the help string provided for the receiver" 279838 279839 ^ helpString ifNil: ['no help available']! ! 279840 279841!Preference methodsFor: 'menu' stamp: 'sw 4/10/2001 15:02'! 279842name 279843 "Answer this preference's name" 279844 279845 ^ name! ! 279846 279847 279848!Preference methodsFor: 'testing' stamp: 'ar 9/27/2005 21:50'! 279849isObsolete 279850 ^(changeInformee class isObsolete or:[changeInformee isBehavior and:[changeInformee isObsolete]])! ! 279851 279852 279853!Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 16:58'! 279854representativeButtonWithColor: aColor inPanel: aPanel 279855 | view | 279856 view := self viewForPanel: aPanel. 279857 ^view ifNotNil: [view representativeButtonWithColor: aColor inPanel: aPanel]! ! 279858 279859!Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 15:42'! 279860viewClassForPanel: aPreferencePanel 279861 ^self viewRegistry viewClassFor: aPreferencePanel! ! 279862 279863!Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 16:58'! 279864viewForPanel: aPreferencePanel 279865 | viewClass | 279866 viewClass := self viewClassForPanel: aPreferencePanel. 279867 ^viewClass ifNotNil: [viewClass preference: self]! ! 279868 279869!Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 15:40'! 279870viewRegistry 279871 ^viewRegistry! ! 279872 279873!Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 15:40'! 279874viewRegistry: aRegistry 279875 viewRegistry := aRegistry! ! 279876 279877 279878!Preference methodsFor: 'value' stamp: 'sw 4/10/2001 15:01'! 279879defaultValue 279880 "Answer this preference's defaultValue" 279881 279882 ^ defaultValue! ! 279883 279884!Preference methodsFor: 'value' stamp: 'sw 4/18/2002 12:15'! 279885defaultValue: aValue 279886 "Set the receiver's defaultValue" 279887 279888 defaultValue := aValue.! ! 279889 279890!Preference methodsFor: 'value' stamp: 'sw 4/10/2001 15:35'! 279891preferenceValue 279892 "Answer the current value of the preference" 279893 279894 ^ value! ! 279895 279896!Preference methodsFor: 'value' stamp: 'sw 4/12/2001 23:28'! 279897preferenceValue: aValue 279898 "set the value as indicated, and invoke the change selector if appropriate" 279899 279900 | oldValue | 279901 oldValue := value. 279902 value := aValue. 279903 oldValue ~~ value ifTrue: 279904 [self notifyInformeeOfChange]! ! 279905 279906!Preference methodsFor: 'value' stamp: 'sw 4/12/2001 23:28'! 279907rawValue: aValue 279908 "set the value as indicated, with no side effects" 279909 279910 value := aValue! ! 279911 279912!Preference methodsFor: 'value' stamp: 'sw 4/12/2001 00:04'! 279913restoreDefaultValue 279914 "restore the default value to the preference" 279915 279916 value := defaultValue! ! 279917 279918!Preference methodsFor: 'value' stamp: 'hpt 9/26/2004 16:51'! 279919togglePreferenceValue 279920 "Toggle whether the value of the preference. Self must be a boolean preference." 279921 value := value not. 279922 self notifyInformeeOfChange! ! 279923Model subclass: #PreferenceBrowser 279924 instanceVariableNames: 'selectedCategoryIndex selectedPreference searchPattern searchResults lastExecutedSearch preferences title' 279925 classVariableNames: '' 279926 poolDictionaries: '' 279927 category: 'PreferenceBrowser'! 279928 279929!PreferenceBrowser methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/7/2007 20:45'! 279930initialExtent 279931 "Made a bit wider to line up prefs nicely." 279932 279933 ^580@440! ! 279934 279935 279936!PreferenceBrowser methodsFor: '*services-base' stamp: 'rr 10/1/2005 15:25'! 279937initializeForServices 279938 preferences := ServicePreferences. 279939 title := 'Services Browser'! ! 279940 279941 279942!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 17:59'! 279943allCategorySelected 279944 ^self selectedCategory = self allCategoryLabel! ! 279945 279946!PreferenceBrowser methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:05'! 279947allPreferences 279948 ^ preferences allPreferenceObjects asSortedCollection: 279949 [:pref1 :pref2 | 279950 pref1 viewRegistry viewOrder <pref2 viewRegistry viewOrder or: 279951 [pref1 viewRegistry viewOrder =pref2 viewRegistry viewOrder 279952 &(pref1 name <pref2 name)]]! ! 279953 279954!PreferenceBrowser methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:05'! 279955categoryList 279956 ^OrderedCollection new 279957 add: self allCategoryLabel; 279958 addAll: preferences categoryNames asSortedCollection; 279959 add: self searchResultsCategoryLabel; 279960 yourself. 279961 279962 ! ! 279963 279964!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 8/27/2005 23:35'! 279965lastExecutedSearch 279966 ^lastExecutedSearch! ! 279967 279968!PreferenceBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:39'! 279969lastExecutedSearch: aTextOrString 279970 ^lastExecutedSearch:= aTextOrString! ! 279971 279972!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 18:01'! 279973nonSpecialCategorySelected 279974 ^self allCategorySelected not & self searchResultsCategorySelected not! ! 279975 279976!PreferenceBrowser methodsFor: 'accessing' stamp: 'rr 10/11/2005 17:14'! 279977preferences 279978 ^ preferences! ! 279979 279980!PreferenceBrowser methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:05'! 279981preferencesInCategory: aCategory 279982 ^(preferences preferenceObjectsInCategory: aCategory)! ! 279983 279984!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 7/8/2006 17:50'! 279985searchFieldLegend 279986 ^''.! ! 279987 279988!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 8/27/2005 23:39'! 279989searchPattern 279990 ^searchPattern ifNil: [searchPattern := self searchFieldLegend]! ! 279991 279992!PreferenceBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:39'! 279993searchPattern: aStringOrText 279994 aStringOrText 279995 ifEmpty: [searchPattern := self searchFieldLegend] 279996 ifNotEmpty: [searchPattern := aStringOrText asString]. 279997 self changed: #searchPattern. 279998 ^true! ! 279999 280000!PreferenceBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:39'! 280001searchResults 280002 ^searchResults ifNil: [searchResults := #()]! ! 280003 280004!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 18:01'! 280005searchResultsCategorySelected 280006 ^self selectedCategory = self searchResultsCategoryLabel! ! 280007 280008!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/19/2004 00:01'! 280009selectedCategory 280010 ^self categoryList at: selectedCategoryIndex ifAbsent: []! ! 280011 280012!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 20:49'! 280013selectedCategoryIndex 280014 ^selectedCategoryIndex ifNil: [selectedCategoryIndex := 0].! ! 280015 280016!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 23:45'! 280017selectedCategoryIndex: anIndex 280018 anIndex = 0 280019 ifTrue: [^self]. 280020 self selectedPreference: nil. 280021 selectedCategoryIndex := anIndex. 280022 self changed: #selectedCategoryIndex.! ! 280023 280024!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/19/2004 03:27'! 280025selectedCategoryPreferences 280026 self allCategorySelected 280027 ifTrue: [^self allPreferences]. 280028 self searchResultsCategorySelected 280029 ifTrue: [^self searchResults]. 280030 ^self preferencesInCategory: self selectedCategory. 280031 ! ! 280032 280033!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/25/2004 17:09'! 280034selectedCategory: aCategorySymbol 280035 self selectedCategoryIndex: (self categoryList indexOf: aCategorySymbol ifAbsent: [0]).! ! 280036 280037!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 20:53'! 280038selectedPreference 280039 ^selectedPreference! ! 280040 280041!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 12/8/2004 15:22'! 280042selectedPreferenceHelpText 280043 self selectedPreference 280044 ifNil: [^'']. 280045 ^self selectedPreference helpString withBlanksTrimmed.! ! 280046 280047!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 21:17'! 280048selectedPreferenceIndex 280049 ^self selectedCategoryPreferences indexOf: self selectedPreference ifAbsent: [0]! ! 280050 280051!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/18/2004 23:41'! 280052selectedPreferenceIndex: anIndex 280053 anIndex = 0 280054 ifTrue: [^self]. 280055 self selectedPreference: (self selectedCategoryPreferences at: anIndex).! ! 280056 280057!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/19/2004 00:39'! 280058selectedPreference: aPreference 280059 selectedPreference := aPreference. 280060 self changed: #selectedPreference. 280061 self changed: #selectedPreferenceIndex. 280062 self changed: #selectedPreferenceHelpText.! ! 280063 280064!PreferenceBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:39'! 280065selectFirstPreferenceOrNil 280066 | prefs | 280067 self selectedCategory 280068 ifNil: [^self selectedPreference: nil]. 280069 prefs := self preferencesInCategory: self selectedCategory. 280070 prefs isEmpty 280071 ifTrue: [^self selectedPreference: nil]. 280072 self selectedPreference: prefs first.! ! 280073 280074!PreferenceBrowser methodsFor: 'accessing' stamp: 'hpt 9/19/2004 03:23'! 280075selectSearchResultsCategory 280076 self selectedCategoryIndex: (self categoryList indexOf: self searchResultsCategoryLabel)! ! 280077 280078 280079!PreferenceBrowser methodsFor: 'buttons callbacks' stamp: 'hpt 9/19/2004 03:21'! 280080searchSelected 280081 self searchPreferencesFor: self searchPattern.! ! 280082 280083 280084!PreferenceBrowser methodsFor: 'find' stamp: 'rr 10/1/2005 15:05'! 280085findCategoryFromPreference: prefSymbol 280086 "Find all categories in which the preference occurs" 280087 280088 | aMenu| 280089 aMenu := MenuMorph new defaultTarget: self. 280090 (preferences categoriesContainingPreference: prefSymbol) do: 280091 [:aCategory | aMenu add: aCategory target: self selector: #selectedCategory: argument: aCategory]. 280092 aMenu popUpInWorld! ! 280093 280094 280095!PreferenceBrowser methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:15'! 280096initialize 280097 super initialize. 280098 preferences := Preferences. 280099 title := 'Preference Browser'.! ! 280100 280101 280102!PreferenceBrowser methodsFor: 'preferences search' stamp: 'hpt 9/19/2004 12:01'! 280103defaultSelected 280104 Preferences chooseInitialSettings! ! 280105 280106!PreferenceBrowser methodsFor: 'preferences search' stamp: 'hpt 8/27/2005 13:18'! 280107helpSelected 280108 "Open up a workspace with explanatory info in it about the Preference Browser" 280109 Workspace new 280110 contents: self helpText; 280111 openLabel: self windowTitle.! ! 280112 280113!PreferenceBrowser methodsFor: 'preferences search' stamp: 'adrian_lienhard 7/18/2009 15:59'! 280114helpText 280115 ^(String streamContents: [:str | 280116 str nextPutAll: 280117'Many aspects of the system are goberned by the settings of various ''Preferences''. 280118 280119Click on any of the categories shown at the left list to see all the preferences in that category. Or type into the search box at the bottom of the window, then hit Search, and all Preferences matching whatever you typed in will appear in the ''search results'' category. A preference is considered to match your search if either its name matches the text *or* if anything in the preference''s help text does. 280120 280121To find out more about any particular Preference just select it and its help text will appear. 280122 280123Some preferences can be ''local'' instead of global. When a preference is set as global its value will apply to whatever project you are in. A local preference will only be valid in the project that you set it in. 280124 280125The ''Save'' button allow you to quickly save your current settings so it can later be restored with the ''Load'' button. 280126 280127To carry your settings to another image you might want to use the ''Save to disk'' and ''Load from disk'' buttons. The save to disk option will store all your settings in a ''my.prefs'' file in your Pharo''s current directory. 280128 280129Lastly, you can use the "theme..." button to set multiple preferences all at once; click on the "theme..." button and try the themes already provided with your Pharo image.']) translated! ! 280130 280131!PreferenceBrowser methodsFor: 'preferences search' stamp: 'rr 10/1/2005 15:05'! 280132loadFromDiskSelected 280133 preferences restorePreferencesFromDisk! ! 280134 280135!PreferenceBrowser methodsFor: 'preferences search' stamp: 'rr 10/1/2005 15:05'! 280136loadSelected 280137 preferences restorePersonalPreferences ! ! 280138 280139!PreferenceBrowser methodsFor: 'preferences search' stamp: 'rr 10/1/2005 15:05'! 280140saveSelected 280141 preferences savePersonalPreferences ! ! 280142 280143!PreferenceBrowser methodsFor: 'preferences search' stamp: 'rr 10/1/2005 15:05'! 280144saveToDiskSelected 280145 preferences storePreferencesToDisk! ! 280146 280147!PreferenceBrowser methodsFor: 'preferences search' stamp: 'hpt 8/27/2005 23:36'! 280148searchPreferencesFor: pattern 280149 | result | 280150 result := pattern asString asLowercase withBlanksTrimmed. 280151 result ifEmpty: [^self]. 280152 searchResults := self allPreferences select: [:aPreference | 280153 (aPreference name includesSubstring: result caseSensitive: false) or: 280154 [aPreference helpString includesSubstring: result caseSensitive: false]]. 280155 self selectSearchResultsCategory. 280156 self lastExecutedSearch: pattern. 280157! ! 280158 280159!PreferenceBrowser methodsFor: 'preferences search' stamp: 'rr 10/1/2005 15:06'! 280160themeSelected 280161 preferences offerThemesMenu! ! 280162 280163 280164!PreferenceBrowser methodsFor: 'stepping' stamp: 'hpt 8/27/2005 23:35'! 280165stepAt: millisecondClockValue in: aWindow 280166 super stepAt: millisecondClockValue in: aWindow. 280167 self searchPattern ~= self lastExecutedSearch 280168 ifTrue: [self searchPreferencesFor: self searchPattern].! ! 280169 280170!PreferenceBrowser methodsFor: 'stepping' stamp: 'hpt 8/27/2005 23:41'! 280171wantsStepsIn: aWindow 280172 ^true.! ! 280173 280174 280175!PreferenceBrowser methodsFor: 'user interface' stamp: 'hpt 9/19/2004 02:30'! 280176allCategoryLabel 280177 ^'-- all --' translated! ! 280178 280179!PreferenceBrowser methodsFor: 'user interface' stamp: 'hpt 9/19/2004 02:30'! 280180searchResultsCategoryLabel 280181 ^'-- search results --' translated! ! 280182 280183!PreferenceBrowser methodsFor: 'user interface' stamp: 'rr 1/8/2006 12:35'! 280184windowTitle 280185 ^ title translated! ! 280186 280187"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 280188 280189PreferenceBrowser class 280190 instanceVariableNames: ''! 280191 280192!PreferenceBrowser class methodsFor: '*services-base' stamp: 'rr 7/10/2006 15:27'! 280193openForServices 280194 "PreferenceBrowser openForServices" 280195 | browser | 280196 browser := self new. 280197 browser initializeForServices. 280198 (ServiceBrowserMorph withModel: browser) 280199 openInWorld. 280200 ^browser. ! ! 280201 280202 280203!PreferenceBrowser class methodsFor: 'initialization' stamp: 'hpt 9/19/2004 12:45'! 280204initialize 280205 self 280206 registerWindowColor; 280207 registerInOpenMenu; 280208 registerInFlaps! ! 280209 280210!PreferenceBrowser class methodsFor: 'initialization' stamp: 'hpt 9/19/2004 12:48'! 280211registerInFlaps 280212 Flaps 280213 registerQuad: 280214 { #PreferenceBrowser. 280215 #prototypicalToolWindow. 280216 'Preference Browser' translated. 280217 'A tool for expressing personal preferences for numerous options' translated } 280218 forFlapNamed: 'Tools' translated. 280219 Flaps replaceToolsFlap! ! 280220 280221!PreferenceBrowser class methodsFor: 'initialization' stamp: 'hpt 9/19/2004 12:40'! 280222registerInOpenMenu 280223 (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [ 280224 TheWorldMenu unregisterOpenCommand: 'Preference Browser'. 280225 TheWorldMenu registerOpenCommand: {'Preference Browser'. {self. #open}}]. 280226 ! ! 280227 280228!PreferenceBrowser class methodsFor: 'initialization' stamp: 'hpt 9/19/2004 12:39'! 280229registerWindowColor 280230 (Preferences windowColorFor: self name) = Color white 280231 ifTrue: [ Preferences setWindowColorFor: self name to: (Color colorFrom: self windowColorSpecification brightColor) ].! ! 280232 280233!PreferenceBrowser class methodsFor: 'initialization' stamp: 'hpt 9/19/2004 12:45'! 280234unload 280235 self 280236 unregisterFromOpenMenu; 280237 unregisterFromFlaps.! ! 280238 280239!PreferenceBrowser class methodsFor: 'initialization' stamp: 'hpt 9/19/2004 12:47'! 280240unregisterFromFlaps 280241 Flaps 280242 unregisterQuadsWithReceiver: self; 280243 replaceToolsFlap! ! 280244 280245!PreferenceBrowser class methodsFor: 'initialization' stamp: 'hpt 9/19/2004 12:44'! 280246unregisterFromOpenMenu 280247 (TheWorldMenu respondsTo: #registerOpenCommand:) 280248 ifTrue: [TheWorldMenu unregisterOpenCommand: 'Preference Browser']. 280249! ! 280250 280251 280252!PreferenceBrowser class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:39'! 280253open 280254 | browser | 280255 browser := self new. 280256 (PreferenceBrowserMorph withModel: browser) 280257 openInWorld. 280258 ^browser. ! ! 280259 280260!PreferenceBrowser class methodsFor: 'instance creation' stamp: 'hpt 9/19/2004 12:51'! 280261prototypicalToolWindow 280262 | window | 280263 window := PreferenceBrowserMorph withModel: self new. 280264 window applyModelExtent. 280265 ^window! ! 280266 280267 280268!PreferenceBrowser class methodsFor: 'window color' stamp: 'hpt 9/18/2004 15:46'! 280269windowColorSpecification 280270 "Answer a WindowColorSpec object that declares my preference" 280271 280272 ^ WindowColorSpec classSymbol: self name wording: 'Preference Browser' brightColor: #(0.645 1.0 1.0) pastelColor: #(0.886 1.0 1.0) helpMessage: 'A tool for expressing personal preferences for numerous options.'! ! 280273SystemWindow subclass: #PreferenceBrowserMorph 280274 instanceVariableNames: 'mainPanel defaultButton saveButton loadButton saveToDiskButton loadFromDiskButton themeButton helpButton preferenceList lastKeystrokeTime lastKeystrokes highlightedPreferenceButton' 280275 classVariableNames: '' 280276 poolDictionaries: '' 280277 category: 'PreferenceBrowser'! 280278 280279!PreferenceBrowserMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/27/2009 16:22'! 280280basicButton 280281 "Answer an initialised button for use in the button row." 280282 280283 ^(UITheme builder 280284 newButtonFor: self model 280285 action: nil 280286 label: '' 280287 help: nil) 280288 vResizing: #spaceFill; 280289 hResizing: #shrinkWrap! ! 280290 280291!PreferenceBrowserMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/2/2009 13:33'! 280292initializeWithModel: aPreferenceBrowser 280293 "Initialize the receiver based on the given model." 280294 280295 |buttonRow| 280296 lastKeystrokeTime := 0. 280297 lastKeystrokes := ''. 280298 self model: aPreferenceBrowser. 280299 buttonRow := self newButtonRow. 280300 self 280301 clipSubmorphs: true; 280302 setLabel: self model windowTitle; 280303 name: 'PreferenceBrowser'; 280304 addMorph: self rootPanel 280305 fullFrame: (LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@(buttonRow minExtent y) corner: 0@0)); 280306 addMorph: buttonRow 280307 fullFrame: (LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@ buttonRow minExtent y))! ! 280308 280309!PreferenceBrowserMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/2/2009 13:34'! 280310newButtonRow 280311 "Answer a new button row." 280312 280313 ^(UITheme builder newToolDockingBar addMorph: ( 280314 (UITheme builder newRow: { 280315 self defaultButton. 280316 self newSeparator. 280317 self saveButton. 280318 self loadButton. 280319 self themeButton. 280320 self newSeparator. 280321 self saveToDiskButton. 280322 self loadFromDiskButton. 280323 self newTransparentFiller. 280324 self newSeparator. 280325 self helpButton}) 280326 vResizing: #spaceFill)) 280327 layoutInset: 1! ! 280328 280329!PreferenceBrowserMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/2/2009 10:29'! 280330newCategoryListPanel 280331 "Answer a groupbox for the categories list." 280332 280333 ^(UITheme builder 280334 newGroupbox: 'Categories' translated 280335 for: (self newCategoryList 280336 cornerStyle: StandardWindow basicNew preferredCornerStyle)) 280337 hResizing: #shrinkWrap; 280338 cornerStyle: StandardWindow basicNew preferredCornerStyle! ! 280339 280340!PreferenceBrowserMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/2/2009 10:25'! 280341newPreferenceListPanel 280342 "Answer a groupbox for the preferences list." 280343 280344 ^(UITheme builder 280345 newGroupbox: 'Preferences' translated 280346 for: self preferenceList) 280347 cornerStyle: StandardWindow basicNew preferredCornerStyle! ! 280348 280349!PreferenceBrowserMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/27/2009 16:54'! 280350newSearchPanel 280351 "Answer the panel for searching of preferences." 280352 280353 ^UITheme builder newRow: { 280354 UITheme builder newLabel: 'Search preferences for:' translated. 280355 self newSearchTextField}! ! 280356 280357!PreferenceBrowserMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/27/2009 16:49'! 280358newSearchTextField 280359 "Answer a new text entry for searching of preferences." 280360 280361 ^UITheme builder 280362 newAutoAcceptTextEntryFor: self model 280363 getText: #searchPattern 280364 setText: #searchPattern: 280365 getEnabled: nil 280366 help: 'Filters the preferences according to a prefix' translated! ! 280367 280368!PreferenceBrowserMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/27/2009 16:29'! 280369newSeparator 280370 "Answer a new separator for the button row." 280371 280372 ^UITheme builder newToolbarHandle! ! 280373 280374!PreferenceBrowserMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/2/2009 10:28'! 280375preferenceList 280376 "Changed to take mouseClickForKeyboardFocus preference into account." 280377 280378 ^preferenceList ifNil: 280379 [preferenceList := ScrollPane new 280380 color: Color white; 280381 borderStyle: (BorderStyle inset width: 1); 280382 vResizing: #spaceFill; 280383 hResizing: #spaceFill; 280384 cornerStyle: StandardWindow basicNew preferredCornerStyle. 280385 Preferences mouseClickForKeyboardFocus 280386 ifFalse: [preferenceList scroller 280387 on: #mouseEnter send: #value: 280388 to: [:event | preferenceList scroller takeKeyboardFocus]]. 280389 preferenceList scroller 280390 on: #keyStroke send: #keyPressed: to: self. 280391 preferenceList]! ! 280392 280393!PreferenceBrowserMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/27/2009 16:33'! 280394rootPanel 280395 "Answer a new root panel for the main contents of the browser." 280396 280397 ^UITheme builder newPanel 280398 addMorphBack: self newSearchPanel; 280399 addMorphBack: self mainPanel; 280400 yourself! ! 280401 280402!PreferenceBrowserMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/31/2009 16:21'! 280403themeButton 280404 "Modified to make clear what the button actually does with respect to Polymorph." 280405 280406 ^themeButton ifNil: [ 280407 themeButton := self basicButton 280408 label: 'presets...' translated; 280409 actionSelector: #themeSelected; 280410 setBalloonText: 280411 'Numerous "Preferences" govern many things about the ', 280412 'way Squeak looks and behaves. Set individual preferences ', 280413 'using a "Preferences" panel. Set an entire group of many ', 280414 'Preferences all at the same time by pressing this "presets" ', 280415 'button and choosing a preset theme to install. Look in ', 280416 'category "themes" in Preferences class to see what each ', 280417 'theme does; add your own methods to the "themes" ', 280418 'category and they will show up in the list of theme choices.', 280419 String cr, 280420 'To change the appearance in a more fundamental way, ', 280421 'select a UI Theme in the "windows" category of this browser' translated].! ! 280422 280423!PreferenceBrowserMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/7/2007 20:34'! 280424updateSelectedCategoryPreferences 280425 Cursor wait showWhile: 280426 [self preferenceList 280427 hScrollBarValue: 0; 280428 vScrollBarValue: 0. 280429 self preferenceList scroller removeAllMorphs. 280430 self preferenceList scroller addMorphBack: self newPreferenceListInnerPanel. 280431 self preferenceList adoptPaneColor. 280432 self adjustPreferenceListItemsWidth]! ! 280433 280434 280435!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:12'! 280436basicKeyPressed: anEvent 280437 | aChar oldSelection nextSelection max milliSeconds nextSelectionList nextSelectionPref | 280438 aChar := anEvent keyCharacter. 280439 nextSelection := oldSelection := self selectedPreferenceIndex. 280440 max := self selectedCategoryPreferences size. 280441 milliSeconds := Time millisecondClockValue. 280442 milliSeconds - lastKeystrokeTime > 300 ifTrue: ["just use the one current character for selecting" 280443 lastKeystrokes := '']. 280444 lastKeystrokes := lastKeystrokes , aChar asLowercase asString. 280445 lastKeystrokeTime := milliSeconds. 280446 nextSelectionList := OrderedCollection newFrom: (self selectedCategoryPreferences copyFrom: oldSelection + 1 to: max). 280447 nextSelectionList addAll: (self selectedCategoryPreferences copyFrom: 1 to: oldSelection). 280448 "Get rid of blanks and style used in some lists" 280449 nextSelectionPref := nextSelectionList detect: [:a | a name withBlanksTrimmed asLowercase beginsWith: lastKeystrokes] 280450 ifNone: [^ self preferenceList flash"match not found"]. 280451 nextSelection := self selectedCategoryPreferences findFirst: [:a | a = nextSelectionPref]. 280452 "No change if model is locked" 280453 oldSelection == nextSelection ifTrue: [^ self preferenceList flash]. 280454 ^ self selectedPreferenceIndex: nextSelection! ! 280455 280456!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:16'! 280457downKeyPressed: anEvent 280458 self selectedPreferenceIndex: 280459 (self selectedPreferenceIndex + 1 280460 min: self selectedCategoryPreferences size)! ! 280461 280462!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:17'! 280463endKeyPressed: anEvent 280464 self selectedPreferenceIndex: self selectedCategoryPreferences size. 280465! ! 280466 280467!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:16'! 280468homeKeyPressed: anEvent 280469 self selectedPreferenceIndex: 1. 280470! ! 280471 280472!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:19'! 280473keyPressed: anEvent 280474 self selectedCategory 280475 ifNil: [^self]. 280476 anEvent keyValue = 30 280477 ifTrue: [^self upKeyPressed: anEvent]. 280478 anEvent keyValue = 31 280479 ifTrue: [^self downKeyPressed: anEvent]. 280480 anEvent keyValue = 1 280481 ifTrue: [^self homeKeyPressed: anEvent]. 280482 anEvent keyValue = 4 280483 ifTrue: [^self endKeyPressed: anEvent]. 280484 anEvent keyValue = 11 280485 ifTrue: [^self pageUpKeyPressed: anEvent]. 280486 anEvent keyValue = 12 280487 ifTrue: [^self pageDownKeyPressed: anEvent]. 280488 self basicKeyPressed: anEvent.! ! 280489 280490!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/26/2004 23:01'! 280491mouseDownOn: aPreferenceView event: anEvent 280492 anEvent hand newKeyboardFocus: self preferenceList scroller. 280493 anEvent yellowButtonPressed 280494 ifTrue: [aPreferenceView offerPreferenceNameMenu: self model]! ! 280495 280496!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:24'! 280497pageDownKeyPressed: anEvent 280498 self selectedPreferenceIndex: (self selectedPreferenceIndex + self preferencesShowing size min: self selectedCategoryPreferences size). 280499! ! 280500 280501!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:30'! 280502pageUpKeyPressed: anEvent 280503 self selectedPreferenceIndex: (self selectedPreferenceIndex - self preferencesShowing size max: 1). 280504! ! 280505 280506!PreferenceBrowserMorph methodsFor: 'event handling' stamp: 'hpt 9/19/2004 00:16'! 280507upKeyPressed: anEvent 280508 self selectedPreferenceIndex: 280509 (self selectedPreferenceIndex - 1 max: 1). 280510! ! 280511 280512 280513!PreferenceBrowserMorph methodsFor: 'geometry' stamp: 'hpt 9/18/2004 21:05'! 280514extent: aPoint 280515 super extent: aPoint. 280516 self fullBounds. 280517 self adjustPreferenceListItemsWidth.! ! 280518 280519 280520!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:05'! 280521selectedCategory 280522 ^self model selectedCategory! ! 280523 280524!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:05'! 280525selectedCategoryIndex 280526 ^self model selectedCategoryIndex! ! 280527 280528!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:05'! 280529selectedCategoryIndex: anIndex 280530 ^self model selectedCategoryIndex: anIndex! ! 280531 280532!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:05'! 280533selectedCategoryPreferences 280534 ^self model selectedCategoryPreferences! ! 280535 280536!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:05'! 280537selectedPreference 280538 ^self model selectedPreference! ! 280539 280540!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:10'! 280541selectedPreferenceIndex 280542 ^self model selectedPreferenceIndex! ! 280543 280544!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:10'! 280545selectedPreferenceIndex: anIndex 280546 ^self model selectedPreferenceIndex: anIndex! ! 280547 280548!PreferenceBrowserMorph methodsFor: 'model access' stamp: 'hpt 9/19/2004 00:06'! 280549selectedPreference: aPreference 280550 ^self model selectedPreference: aPreference! ! 280551 280552 280553!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 8/28/2005 00:04'! 280554buttonRowLayoutFrame 280555 ^LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@ (TextStyle defaultFont height * 2.5))! ! 280556 280557!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:55'! 280558defaultButton 280559 ^defaultButton ifNil: 280560 [defaultButton := self basicButton 280561 label: 'default' translated; 280562 actionSelector: #defaultSelected; 280563 setBalloonText: 280564 'Click here to reset all the preferences to their standard ', 280565 'default values.' translated]! ! 280566 280567!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:56'! 280568helpButton 280569 ^helpButton ifNil: 280570 [helpButton := self basicButton 280571 label: 'help' translated; 280572 setBalloonText: 280573 'Click here to get some hints on use of this Preferences ', 280574 'Panel' translated; 280575 actionSelector: #helpSelected]! ! 280576 280577!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:56'! 280578loadButton 280579 ^loadButton ifNil: 280580 [loadButton := self basicButton 280581 label: 'load' translated; 280582 actionSelector: #loadSelected; 280583 setBalloonText: 280584 'Click here to reset all the preferences to their values ', 280585 'in your Personal Preferences.' translated]! ! 280586 280587!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:56'! 280588loadFromDiskButton 280589 ^loadFromDiskButton ifNil: 280590 [loadFromDiskButton := self basicButton 280591 label: 'load from disk' translated; 280592 actionSelector: #loadFromDiskSelected; 280593 setBalloonText: 280594 'Click here to load all the preferences from ', 280595 'their saved values on disk.' translated]! ! 280596 280597!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:49'! 280598newTransparentFiller 280599 ^Morph new 280600 color: Color transparent; 280601 vResizing: #spaceFill; 280602 hResizing: #spaceFill; 280603 yourself.! ! 280604 280605!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:56'! 280606saveButton 280607 ^saveButton ifNil: 280608 [saveButton := self basicButton 280609 label: 'save' translated; 280610 actionSelector: #saveSelected; 280611 setBalloonText: 280612 'Click here to save the current constellation of Preferences ', 280613 'settings as your personal defaults; you can get them all ', 280614 'reinstalled with a single gesture by clicking the "Restore ', 280615 'my Personal Preferences".' translated]! ! 280616 280617!PreferenceBrowserMorph methodsFor: 'submorphs - buttons' stamp: 'hpt 9/18/2004 16:56'! 280618saveToDiskButton 280619 ^saveToDiskButton ifNil: 280620 [saveToDiskButton := self basicButton 280621 label: 'save to disk' translated; 280622 actionSelector: #saveToDiskSelected; 280623 setBalloonText: 280624 'Click here to save the current constellation of Preferences ', 280625 'settings to a file; you can get them all reinstalled with a ', 280626 'single gesture by clicking "Restore Settings From Disk".' 280627 translated]! ! 280628 280629 280630!PreferenceBrowserMorph methodsFor: 'submorphs - category list' stamp: 'hpt 9/18/2004 16:07'! 280631newCategoryList 280632 ^(PluggableListMorph 280633 on: self model 280634 list: #categoryList 280635 selected: #selectedCategoryIndex 280636 changeSelected: #selectedCategoryIndex:) 280637 color: Color white; 280638 borderInset; 280639 vResizing: #spaceFill; 280640 hResizing: #rigid; 280641 width: 150; 280642 yourself.! ! 280643 280644!PreferenceBrowserMorph methodsFor: 'submorphs - category list' stamp: 'hpt 9/19/2004 02:29'! 280645newCategoryListPanelLabel 280646 ^StringMorph contents: 'Categories' translated.! ! 280647 280648 280649!PreferenceBrowserMorph methodsFor: 'submorphs - main panel' stamp: 'hpt 9/19/2004 03:01'! 280650mainPanel 280651 ^mainPanel ifNil: 280652 [mainPanel := Morph new 280653 color: Color transparent; 280654 hResizing: #spaceFill; 280655 vResizing: #spaceFill; 280656 cellInset: 5; 280657 layoutPolicy: TableLayout new; 280658 listCentering: #topLeft; 280659 listDirection: #leftToRight; 280660 cellPositioning: #topLeft; 280661 clipSubmorphs: true; 280662 on: #mouseEnter send: #paneTransition: to: self; 280663 addMorphBack: self newCategoryListPanel; 280664 addMorphBack: self newPreferenceListPanel; 280665 yourself].! ! 280666 280667 280668!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 12/8/2004 17:20'! 280669newPreferenceButtonFor: aPreference 280670 | button | 280671 button := PBPreferenceButtonMorph preference: aPreference model: self model. 280672 button 280673 on: #mouseDown 280674 send: #value: 280675 to: 280676 [:anEvent | 280677 self 280678 selectedPreference: aPreference; 280679 mouseDownOn: button preferenceView event: anEvent]. 280680 ^button! ! 280681 280682!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 12/8/2004 17:20'! 280683newPreferenceListInnerPanel 280684 | panel maxWidth totalHeight | 280685 panel := (Morph new) 280686 color: Color transparent; 280687 layoutPolicy: TableLayout new; 280688 listDirection: #topToBottom; 280689 cellPositioning: #topLeft; 280690 yourself. 280691 self selectedCategoryPreferences 280692 do: [:aPref | panel addMorphBack: (self newPreferenceButtonFor: aPref)]. 280693 panel submorphs size = 0 ifTrue: [^panel]. 280694 maxWidth := (panel submorphs detectMax: [:m | m width]) width. 280695 panel width: maxWidth. 280696 totalHeight := (panel submorphs collect: [:ea | ea height]) inject: 0 280697 into: [:h :tot | h + tot]. 280698 panel height: totalHeight. 280699 panel fullBounds. 280700 ^panel! ! 280701 280702!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 9/19/2004 02:29'! 280703newPreferenceListPanelLabel 280704 ^StringMorph contents: 'Preferences' translated.! ! 280705 280706!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 9/18/2004 21:19'! 280707preferenceListInnerPanel 280708 ^self preferenceList scroller submorphs first! ! 280709 280710!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 9/19/2004 00:29'! 280711preferencesShowing 280712 | prefs | 280713 prefs := self preferenceListInnerPanel submorphs 280714 copyFrom: (self selectedPreferenceIndex max: 1) 280715 to: self selectedCategoryPreferences size. 280716 ^prefs reject: [:ea | (ea top - prefs first top) > self preferenceList scroller height].! ! 280717 280718!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 12/8/2004 15:50'! 280719selectedPreferenceButton 280720 ^(self preferenceListInnerPanel submorphs at: self selectedPreferenceIndex)! ! 280721 280722!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'hpt 12/8/2004 15:54'! 280723turnOffSelectedPreference 280724 highlightedPreferenceButton 280725 ifNil: [^self]. 280726 highlightedPreferenceButton highlightOff. 280727 highlightedPreferenceButton := nil.! ! 280728 280729!PreferenceBrowserMorph methodsFor: 'submorphs - preference list' stamp: 'marcus.denker 11/10/2008 10:04'! 280730turnOnSelectedPreference 280731 highlightedPreferenceButton 280732 ifNotNil: [:m | m highlightOff]. 280733 highlightedPreferenceButton := self selectedPreferenceButton 280734 highlightOn; 280735 yourself. 280736 self preferenceList scrollToShow: highlightedPreferenceButton bounds.! ! 280737 280738 280739!PreferenceBrowserMorph methodsFor: 'submorphs - root panel' stamp: 'stephaneducasse 2/4/2006 20:39'! 280740rootPanelLayoutFrame 280741 | frame | 280742 frame := self buttonRowLayoutFrame. 280743 ^LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@(frame bottomOffset) corner: 0@0)! ! 280744 280745 280746!PreferenceBrowserMorph methodsFor: 'submorphs - search panel' stamp: 'hpt 9/19/2004 02:55'! 280747newSearchButton 280748 ^self basicButton 280749 label: 'search' translated; 280750 actionSelector: #searchSelected; 280751 setBalloonText: 280752 'Type what you want to search for here, then hit ', 280753 'the "Search" button, or else hit RETURN or ENTER' translated.! ! 280754 280755 280756!PreferenceBrowserMorph methodsFor: 'updating' stamp: 'hpt 9/20/2004 23:31'! 280757adjustPreferenceListItemsWidth 280758 | panel | 280759 self preferenceList scroller submorphs 280760 ifEmpty: [^self]. 280761 panel := self preferenceListInnerPanel. 280762 panel width: self preferenceList width - (self preferenceList scrollBarThickness*2). 280763 panel submorphsDo: [:ea | ea hResizing: #rigid; width: panel width]. 280764 self preferenceList setScrollDeltas.! ! 280765 280766!PreferenceBrowserMorph methodsFor: 'updating' stamp: 'hpt 9/19/2004 00:08'! 280767updateSelectedPreference 280768 | index | 280769 self selectedCategory ifNotNil: [self turnOffSelectedPreference]. 280770 index := self selectedPreferenceIndex. 280771 index = 0 280772 ifTrue: [^self]. 280773 self turnOnSelectedPreference.! ! 280774 280775!PreferenceBrowserMorph methodsFor: 'updating' stamp: 'hpt 9/18/2004 21:16'! 280776update: aSymbol 280777 super update: aSymbol. 280778 aSymbol == #selectedPreference 280779 ifTrue: [self updateSelectedPreference]. 280780 aSymbol == #selectedCategoryIndex 280781 ifTrue: [self updateSelectedCategoryPreferences].! ! 280782 280783"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 280784 280785PreferenceBrowserMorph class 280786 instanceVariableNames: ''! 280787 280788!PreferenceBrowserMorph class methodsFor: '*services-base' stamp: 'rr 12/30/2005 18:43'! 280789updateBrowsers 280790 280791 (self allInstances select: [:e | e visible]) 280792 do: [:each | 280793 (each findDeepSubmorphThat:[:m | m isKindOf:PluggableListMorph] 280794 ifAbsent:[^ self]) verifyContents].! ! 280795 280796 280797!PreferenceBrowserMorph class methodsFor: 'instance creation' stamp: 'hpt 9/18/2004 15:31'! 280798withModel: aPreferenceBrowser 280799 ^self new initializeWithModel: aPreferenceBrowser; 280800 yourself.! ! 280801Object subclass: #PreferenceView 280802 instanceVariableNames: 'preference' 280803 classVariableNames: '' 280804 poolDictionaries: '' 280805 category: 'System-Support'! 280806!PreferenceView commentStamp: '<historical>' prior: 0! 280807My subclasses instances are responsible for building the visual representation of each kind of preference.! 280808 280809 280810!PreferenceView methodsFor: 'accessing' stamp: 'hpt 9/24/2004 22:25'! 280811preference 280812 ^preference! ! 280813 280814 280815!PreferenceView methodsFor: 'initialization' stamp: 'hpt 9/24/2004 22:25'! 280816initializeWithPreference: aPreference 280817 preference := aPreference! ! 280818 280819 280820!PreferenceView methodsFor: 'user interface' stamp: 'hpt 9/24/2004 22:56'! 280821representativeButtonWithColor: aColor inPanel: aPreferencesPanel 280822 self subclassResponsibility ! ! 280823 280824!PreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 16:14'! 280825tearOffButton 280826 "Hand the user a button the can control this" 280827 280828 | aButton | 280829 aButton := self representativeButtonWithColor: self preference defaultBackgroundColor inPanel: nil. 280830 aButton borderWidth: 1; borderColor: Color black; useRoundedCorners. 280831 aButton openInHand! ! 280832 280833"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 280834 280835PreferenceView class 280836 instanceVariableNames: 'registeredClasses'! 280837 280838!PreferenceView class methodsFor: 'instance creation' stamp: 'hpt 9/24/2004 22:25'! 280839preference: aPreference 280840 ^self new 280841 initializeWithPreference: aPreference; 280842 yourself! ! 280843 280844 280845!PreferenceView class methodsFor: 'view registry' stamp: 'hpt 9/26/2004 16:09'! 280846handlesPanel: aPreferencePanel 280847 self subclassResponsibility ! ! 280848Object subclass: #PreferenceViewRegistry 280849 instanceVariableNames: 'registeredClasses viewOrder' 280850 classVariableNames: '' 280851 poolDictionaries: '' 280852 category: 'System-Support'! 280853!PreferenceViewRegistry commentStamp: '<historical>' prior: 0! 280854PreferenceViewRegistry is much like the AppRegistry classes. Its purpose is to allow PreferenceBrowser implementers to register its own views for each kind of preference.! 280855 280856 280857!PreferenceViewRegistry methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:15'! 280858initialize 280859 super initialize. 280860 viewOrder := 1.! ! 280861 280862 280863!PreferenceViewRegistry methodsFor: 'view order' stamp: 'hpt 9/26/2004 16:22'! 280864viewOrder 280865 "answer the order in which the registered views should appear relative to the other views" 280866 ^viewOrder! ! 280867 280868!PreferenceViewRegistry methodsFor: 'view order' stamp: 'hpt 9/26/2004 16:22'! 280869viewOrder: aNumber 280870 viewOrder := aNumber! ! 280871 280872 280873!PreferenceViewRegistry methodsFor: 'view registry' stamp: 'hpt 9/26/2004 15:26'! 280874register: aProviderClass 280875 (self registeredClasses includes: aProviderClass) 280876 ifFalse: [self registeredClasses add: aProviderClass].! ! 280877 280878!PreferenceViewRegistry methodsFor: 'view registry' stamp: 'hpt 9/26/2004 15:26'! 280879registeredClasses 280880 ^registeredClasses ifNil: [registeredClasses := OrderedCollection new]! ! 280881 280882!PreferenceViewRegistry methodsFor: 'view registry' stamp: 'hpt 9/26/2004 15:26'! 280883unregister: aProviderClass 280884 self registeredClasses remove: aProviderClass ifAbsent: []! ! 280885 280886!PreferenceViewRegistry methodsFor: 'view registry' stamp: 'hpt 9/26/2004 15:26'! 280887viewClassFor: aPreferencePanel 280888 ^self registeredClasses 280889 detect: [:aViewClass| aViewClass handlesPanel: aPreferencePanel] 280890 ifNone: [].! ! 280891 280892"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 280893 280894PreferenceViewRegistry class 280895 instanceVariableNames: 'registries'! 280896 280897!PreferenceViewRegistry class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/12/2007 15:16'! 280898ofSoundThemePreferences 280899 "Answer the sound theme preference registry." 280900 280901 ^(self registryOf: #soundThemePreferences) 280902 viewOrder: 2; 280903 yourself! ! 280904 280905!PreferenceViewRegistry class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/22/2007 15:24'! 280906ofUIThemePreferences 280907 "Answer the ui theme preference registry." 280908 280909 ^(self registryOf: #uiThemePreferences) 280910 viewOrder: 2; 280911 yourself! ! 280912 280913 280914!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:23'! 280915ofBooleanPreferences 280916 ^(self registryOf: #booleanPreferences) 280917 viewOrder: 1; 280918 yourself.! ! 280919 280920!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:24'! 280921ofColorPreferences 280922 ^(self registryOf: #colorPreferences) 280923 viewOrder: 5; 280924 yourself.! ! 280925 280926!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:24'! 280927ofFontPreferences 280928 ^(self registryOf: #fontPreferences) 280929 viewOrder: 4; 280930 yourself.! ! 280931 280932!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:23'! 280933ofHaloThemePreferences 280934 ^(self registryOf: #haloThemePreferences) 280935 viewOrder: 2; 280936 yourself.! ! 280937 280938!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 12/9/2004 22:16'! 280939ofNumericPreferences 280940 ^(self registryOf: #numericPreferences) 280941 viewOrder: 3; 280942 yourself.! ! 280943 280944!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:23'! 280945ofTextPreferences 280946 ^(self registryOf: #textPreferences) 280947 viewOrder: 3; 280948 yourself.! ! 280949 280950!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 15:28'! 280951registries 280952 ^registries ifNil: [registries := Dictionary new]! ! 280953 280954!PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 15:33'! 280955registryOf: aSymbol 280956 ^self registries at: aSymbol ifAbsentPut: [self new]! ! 280957Object subclass: #Preferences 280958 instanceVariableNames: '' 280959 classVariableNames: 'DesktopColor DictionaryOfPreferences Parameters' 280960 poolDictionaries: '' 280961 category: 'System-Support'! 280962!Preferences commentStamp: '<historical>' prior: 0! 280963A general mechanism to store preference choices. The default setup treats any symbol as a potential boolean flag; flags unknown to the preference dictionary are always returned as false. 280964 280965 To open the control panel: Preferences openFactoredPanel 280966 To read how to use the panel (and how to make a preference be per-project): 280967 Preferences giveHelpWithPreferences 280968 280969All messages are on the class side. 280970 280971To query a a preference: 280972 Preferences logDebuggerStackToFile 280973or some people prefer the more verbose 280974 Preferences valueOfFlag: #logDebuggerStackToFile 280975 280976You can make up a new preference any time. Do not define a new message in Preferences class. Accessor methods are compiled automatically when you add a preference as illustrated below: 280977 280978To add a preference (e.g. in the Postscript of a fileout): 280979 Preferences addPreference: #samplePreference categories: #(general browsing) 280980 default: true balloonHelp: 'This is an example of a preference added by a do-it' 280981 projectLocal: false changeInformee: nil changeSelector: nil. 280982 280983To change a preference programatically: 280984 Preferences disable: #logDebuggerStackToFile. 280985Or to turn it on, 280986 Preferences enable: #logDebuggerStackToFile. 280987! 280988]style[(220 29 81 35 812)f1,f1dPreferences openFactoredPanel;;,f1,f1dPreferences giveHelpWithPreferences;;,f1! 280989 280990 280991!Preferences methodsFor: 'look in class' stamp: 'di 12/4/1999 15:11'! 280992seeClassSide 280993 "All the code for Preferences is on the class side"! ! 280994 280995"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 280996 280997Preferences class 280998 instanceVariableNames: ''! 280999 281000!Preferences class methodsFor: '*FreeType-addition' stamp: 'marcus.denker 11/27/2008 16:16'! 281001chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector highlightSelector: highlightSelector 281002 281003 FontChooser openWithWindowTitle: aPrompt 281004 for: aReceiver 281005 setSelector: aSelector 281006 getSelector: highlightSelector 281007 ! ! 281008 281009!Preferences class methodsFor: '*FreeType-addition' stamp: 'tween 8/4/2007 14:30'! 281010standardSystemFont 281011 "Answer the standard system font " 281012 281013 ^(TextConstants at: #DefaultTextStyle) defaultFont! ! 281014 281015 281016!Preferences class methodsFor: '*FreeType-override' stamp: 'tween 8/7/2007 01:59'! 281017chooseCodeFont 281018 "Not currently sent, but once protocols are sorted out so that we can disriminate on whether a text object being launched is for code or not, will be reincorporated" 281019 281020 self 281021 chooseFontWithPrompt: 'Code font...' translated 281022 andSendTo: self 281023 withSelector: #setCodeFontTo: 281024 highlightSelector: #standardCodeFont.! ! 281025 281026!Preferences class methodsFor: '*FreeType-override' stamp: 'tween 8/7/2007 02:00'! 281027chooseFlapsFont 281028 self 281029 chooseFontWithPrompt: 'Flaps font...' translated 281030 andSendTo: self 281031 withSelector: #setFlapsFontTo: 281032 highlightSelector: #standardFlapFont! ! 281033 281034!Preferences class methodsFor: '*FreeType-override' stamp: 'tween 8/7/2007 02:00'! 281035chooseHaloLabelFont 281036 "present a menu with the possible fonts for label in halo" 281037 self 281038 chooseFontWithPrompt: 'Halo Label font...' 281039 andSendTo: self 281040 withSelector: #setHaloLabelFontTo: 281041 highlightSelector: #standardHaloLabelFont! ! 281042 281043!Preferences class methodsFor: '*FreeType-override' stamp: 'tween 8/7/2007 02:01'! 281044chooseListFont 281045 self 281046 chooseFontWithPrompt: 'List font...' translated 281047 andSendTo: self 281048 withSelector: #setListFontTo: 281049 highlightSelector: #standardListFont! ! 281050 281051!Preferences class methodsFor: '*FreeType-override' stamp: 'tween 8/7/2007 02:01'! 281052chooseMenuFont 281053 self 281054 chooseFontWithPrompt: 'Menu font...' translated 281055 andSendTo: self 281056 withSelector: #setMenuFontTo: 281057 highlightSelector: #standardMenuFont! ! 281058 281059!Preferences class methodsFor: '*FreeType-override' stamp: 'tween 8/7/2007 02:01'! 281060chooseStandardButtonFont 281061 self 281062 chooseFontWithPrompt: 'Button font...' translated 281063 andSendTo: self 281064 withSelector: #setButtonFontTo: 281065 highlightSelector: #standardButtonFont 281066 281067! ! 281068 281069!Preferences class methodsFor: '*FreeType-override' stamp: 'tween 8/7/2007 02:01'! 281070chooseSystemFont 281071 self 281072 chooseFontWithPrompt: 'Default font...' translated 281073 andSendTo: self 281074 withSelector: #setSystemFontTo: 281075 highlightSelector: #standardSystemFont! ! 281076 281077!Preferences class methodsFor: '*FreeType-override' stamp: 'tween 8/7/2007 02:01'! 281078chooseWindowTitleFont 281079 self 281080 chooseFontWithPrompt: 'Window Title font...' translated 281081 andSendTo: self 281082 withSelector: #setWindowTitleFontTo: 281083 highlightSelector: #windowTitleFont! ! 281084 281085 281086!Preferences class methodsFor: '*Polymorph-Widgets' stamp: 'damiencassou 7/3/2009 13:13'! 281087disableProgrammerFacilitiesWithoutWarning 281088 "Warning: do not call this lightly!! It disables all access to menus, debuggers, halos. There is no guaranteed return from this, which is to say, you cannot necessarily reenable these things once they are disabled -- you can only use whatever the UI of the current project affords, and you cannot even snapshot -- you can only quit." 281089 281090 self disable: #cmdDotEnabled. "No user-interrupt-into-debugger" 281091 self disable: #editableStringMorphs. "turn off shift-click editing" 281092 ToolSet registeredClasses copy do: [:c | ToolSet unregister: c]. 281093 ToolSet default: nil. "unregister and make sure default is nil to really prevent debug windows" 281094 "also now takes care of low space watcher interrupts" 281095 self compileHardCodedPref: #cmdGesturesEnabled enable: false. "No halos, etc." 281096 self compileHardCodedPref: #cmdKeysInText enable: false. "No user commands invokable via cmd-key combos in text editor" 281097 self enable: #noviceMode. "No control-menu" 281098 self disable: #warnIfNoSourcesFile. 281099 self disable: #warnIfNoChangesFile! ! 281100 281101 281102!Preferences class methodsFor: '*Polymorph-Widgets-Override' stamp: 'damiencassou 7/3/2009 13:14'! 281103disableProgrammerFacilities 281104 "Warning: do not call this lightly!! It disables all access to menus, debuggers, halos. There is no guaranteed return from this, which is to say, you cannot necessarily reenable these things once they are disabled -- you can only use whatever the UI of the current project affords, and you cannot even snapshot -- you can only quit. 281105 281106 You can completely reverse the work of this method by calling the dual Preferences method enableProgrammerFacilities, provided you have left yourself leeway to bring about a call to that method. 281107(does not reverse the ToolSet registrations) 281108 281109 To set up a system that will come up in such a state, you have to request the snapshot in the same breath as you disable the programmer facilities. To do this, put the following line into the 'do' menu and then evaluate it from that 'do' menu: 281110 281111 Preferences disableProgrammerFacilities. 281112 281113You will be prompted for a new image name under which to save the resulting image." 281114 281115 Beeper beep. 281116 (self 281117 confirm: 'CAUTION!!!! 281118This is a drastic step!! 281119Do you really want to do this?') 281120 ifFalse: 281121 [Beeper beep. 281122 ^self inform: 'whew!!']. 281123 self disable: #cmdDotEnabled. "No user-interrupt-into-debugger" 281124 self disable: #editableStringMorphs. "turn off shift-click editing" 281125 ToolSet registeredClasses copy do: [:c | ToolSet unregister: c]. 281126 ToolSet default: nil. "unregister and make sure default is nil to really prevent debug windows" 281127 "also now takes care of low space watcher interrupts" 281128 self compileHardCodedPref: #cmdGesturesEnabled enable: false. "No halos, etc." 281129 self compileHardCodedPref: #cmdKeysInText enable: false. "No user commands invokable via cmd-key combos in text editor" 281130 self enable: #noviceMode. "No control-menu" 281131 self disable: #warnIfNoSourcesFile. 281132 self disable: #warnIfNoChangesFile. 281133 SmalltalkImage current saveAs! ! 281134 281135!Preferences class methodsFor: '*Polymorph-Widgets-Override' stamp: 'damiencassou 7/3/2009 13:14'! 281136enableProgrammerFacilities 281137 "Meant as a one-touch recovery from a #disableProgrammerFacilities call." 281138 "Preferences enableProgrammerFacilities" 281139 281140 self enable: #editableStringMorphs. 281141 self enable: #cmdDotEnabled. 281142 self compileHardCodedPref: #cmdGesturesEnabled enable: true. 281143 self compileHardCodedPref: #cmdKeysInText enable: true. 281144 self disable: #noviceMode. 281145 self enable: #warnIfNoSourcesFile. 281146 self enable: #warnIfNoChangesFile. 281147 ToolSet default: StandardToolSet ! ! 281148 281149 281150!Preferences class methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:14'! 281151dictionaryOfPreferences 281152 ^DictionaryOfPreferences! ! 281153 281154!Preferences class methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:14'! 281155dictionaryOfPreferences: anObject 281156 DictionaryOfPreferences := anObject! ! 281157 281158 281159!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:00'! 281160addBooleanPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString 281161 "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" 281162 281163 self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofBooleanPreferences ! ! 281164 281165!Preferences class methodsFor: 'add preferences' stamp: 'hpt 12/5/2004 13:28'! 281166addBooleanPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector 281167 "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean" 281168 281169 self addPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector viewRegistry: PreferenceViewRegistry ofBooleanPreferences ! ! 281170 281171!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:01'! 281172addBooleanPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString 281173 "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" 281174 281175 self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofBooleanPreferences ! ! 281176 281177!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:03'! 281178addColorPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString 281179 "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" 281180 281181 self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofColorPreferences ! ! 281182 281183!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:03'! 281184addColorPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString 281185 "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" 281186 281187 self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofColorPreferences ! ! 281188 281189!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:03'! 281190addFontPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString 281191 "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" 281192 281193 self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofFontPreferences ! ! 281194 281195!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:02'! 281196addFontPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString 281197 "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" 281198 281199 self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofFontPreferences ! ! 281200 281201!Preferences class methodsFor: 'add preferences' stamp: 'hpt 12/9/2004 22:15'! 281202addNumericPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString 281203 "Add an item repreesenting the given preference symbol to the system. " 281204 281205 self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofNumericPreferences ! ! 281206 281207!Preferences class methodsFor: 'add preferences' stamp: 'hpt 12/9/2004 22:15'! 281208addNumericPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString 281209 "Add an item repreesenting the given preference symbol to the system." 281210 281211 self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofNumericPreferences ! ! 281212 281213!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:05'! 281214addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString 281215 "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" 281216 self addBooleanPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString.! ! 281217 281218!Preferences class methodsFor: 'add preferences' stamp: 'hpt 12/5/2004 13:29'! 281219addPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector 281220 "Add an item representing the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" 281221 281222 self addBooleanPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector 281223! ! 281224 281225!Preferences class methodsFor: 'add preferences' stamp: 'rr 10/1/2005 15:14'! 281226addPreference: aName categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector viewRegistry: aViewRegistry 281227 "Add or replace a preference as indicated. Reuses the preexisting Preference object for this symbol, if there is one, so that UI artifacts that interact with it will remain valid." 281228 281229 | aPreference aPrefSymbol | 281230 aPrefSymbol := aName asSymbol. 281231 aPreference := self dictionaryOfPreferences at:aPrefSymbol 281232 ifAbsent:[Preference new]. 281233 aPreference 281234 name:aPrefSymbol 281235 defaultValue:aValue 281236 helpString:helpString 281237 localToProject:localBoolean 281238 categoryList:categoryList 281239 changeInformee:informeeSymbol 281240 changeSelector:aChangeSelector 281241 viewRegistry:aViewRegistry. 281242 self dictionaryOfPreferences at:aPrefSymbol put:aPreference. 281243 self compileAccessMethodForPreference:aPreference! ! 281244 281245!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:05'! 281246addPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString 281247 "Add the given preference, putting it in the given category, with the given default value, and with the given balloon help. It assumes boolean preference for backward compatibility" 281248 281249 self addBooleanPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString.! ! 281250 281251!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:02'! 281252addTextPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString 281253 "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" 281254 281255 self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofTextPreferences ! ! 281256 281257!Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:02'! 281258addTextPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString 281259 "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" 281260 281261 self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofTextPreferences ! ! 281262 281263 281264!Preferences class methodsFor: 'factored pref panel' stamp: 'sw 4/10/2001 14:29'! 281265categoriesContainingPreference: prefSymbol 281266 "Return a list of all categories in which the preference occurs" 281267 281268 ^ (self preferenceAt: prefSymbol ifAbsent: [^ #(unclassified)]) categoryList! ! 281269 281270 281271!Preferences class methodsFor: 'fonts' stamp: 'jmv 8/4/2009 15:09'! 281272aaFontsColormapDepth 281273 "Adjust balance between colored AA text quality (especially if subpixel AA is used) and space / performance. 281274 5 is optimal quality. Each colorMap takes 128kB of RAM, and takes several seconds to build. 281275 4 is a reasonable balance. Each colorMap takes 16kB of RAM and builds fast on a fast machine. 281276 3 is good for slow hardware or memory restrictions. Each colorMap takes 2 kb of RAM." 281277 ^self 281278 valueOfFlag: #aaFontsColormapDepth 281279 ifAbsent: [4]! ! 281280 281281!Preferences class methodsFor: 'fonts' stamp: 'bp 6/13/2004 17:20'! 281282chooseBalloonHelpFont 281283 281284 BalloonMorph chooseBalloonFont! ! 281285 281286!Preferences class methodsFor: 'fonts' stamp: 'dgd 11/3/2004 21:00'! 281287chooseEToysTitleFont 281288 "present a menu with the possible fonts for the eToys" 281289 self 281290 chooseFontWithPrompt: 'Choose the eToys title font' translated 281291 andSendTo: self 281292 withSelector: #setEToysTitleFontTo: 281293 highlight: self standardEToysTitleFont! ! 281294 281295!Preferences class methodsFor: 'fonts' stamp: 'laza 3/25/2004 23:11'! 281296chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector 281297 self chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector highlight: nil 281298! ! 281299 281300!Preferences class methodsFor: 'fonts' stamp: 'alain.plantec 5/30/2008 14:18'! 281301chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector highlight: currentFont 281302 TextStyle promptForFont: aPrompt andSendTo: aReceiver withSelector: aSelector highlight: currentFont! ! 281303 281304!Preferences class methodsFor: 'fonts' stamp: 'jmv 8/6/2009 10:37'! 281305fontConfigurationMenu 281306 | aMenu | 281307 aMenu := MenuMorph new defaultTarget: Preferences. 281308 aMenu addTitle: 'Standard System Fonts' translated. 281309 281310 aMenu addStayUpIcons. 281311 281312 aMenu add: 'default text font...' translated action: #chooseSystemFont. 281313 aMenu balloonTextForLastItem: 'Choose the default font to be used for code and in workspaces, transcripts, etc.' translated. 281314 aMenu lastItem font: Preferences standardDefaultTextFont. 281315 281316 aMenu add: 'list font...' translated action: #chooseListFont. 281317 aMenu lastItem font: Preferences standardListFont. 281318 aMenu balloonTextForLastItem: 'Choose the font to be used in list panes' translated. 281319 281320 aMenu add: 'flaps font...' translated action: #chooseFlapsFont. 281321 aMenu lastItem font: Preferences standardFlapFont. 281322 aMenu balloonTextForLastItem: 'Choose the font to be used on textual flap tabs' translated. 281323 281324 aMenu add: 'halo label font...' translated action: #chooseHaloLabelFont. 281325 aMenu lastItem font: Preferences standardHaloLabelFont. 281326 aMenu balloonTextForLastItem: 'Choose the font to be used on labels ih halo' translated. 281327 281328 aMenu add: 'menu font...' translated action: #chooseMenuFont. 281329 aMenu lastItem font: Preferences standardMenuFont. 281330 aMenu balloonTextForLastItem: 'Choose the font to be used in menus' translated. 281331 281332 aMenu add: 'window-title font...' translated action: #chooseWindowTitleFont. 281333 aMenu lastItem font: Preferences windowTitleFont. 281334 aMenu balloonTextForLastItem: 'Choose the font to be used in window titles.' translated. 281335 281336 aMenu add: 'balloon-help font...' translated action: #chooseBalloonHelpFont. 281337 aMenu lastItem font: Preferences standardBalloonHelpFont. 281338 aMenu balloonTextForLastItem: 'choose the font to be used when presenting balloon help.' translated. 281339 281340 aMenu add: 'code font...' translated action: #chooseCodeFont. 281341 aMenu lastItem font: Preferences standardCodeFont. 281342 aMenu balloonTextForLastItem: 'Choose the font to be used in code panes.' translated. 281343 281344 aMenu add: 'button font...' translated action: #chooseStandardButtonFont. 281345 aMenu lastItem font: Preferences standardButtonFont. 281346 aMenu balloonTextForLastItem: 'Choose the font to be used in buttons.' translated. 281347 281348 aMenu addLine. 281349 aMenu add: 'demo mode' translated action: #setDemoFonts. 281350 aMenu balloonTextForLastItem: 'Set Fonts usable for giving a presentation' translated. 281351 281352 aMenu addLine. 281353 aMenu add: 'restore default font choices' translated action: #restoreDefaultFonts. 281354 aMenu balloonTextForLastItem: 'Use the standard system font defaults' translated. 281355 281356 aMenu add: 'print default font choices' translated action: #printStandardSystemFonts. 281357 aMenu balloonTextForLastItem: 'Print the standard system font defaults to the Transcript' translated. 281358 281359 ^ aMenu! ! 281360 281361!Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 11:37'! 281362printStandardSystemFonts 281363 "self printStandardSystemFonts" 281364 281365 | string | 281366 string := String streamContents: [ :s | 281367 281368 #(standardDefaultTextFont standardListFont standardFlapFont 281369 standardEToysFont standardMenuFont windowTitleFont 281370 standardBalloonHelpFont standardCodeFont standardButtonFont) do: [:selector | 281371 | font | 281372 font := Preferences perform: selector. 281373 s 281374 nextPutAll: selector; space; 281375 nextPutAll: font familyName; space; 281376 nextPutAll: (AbstractFont emphasisStringFor: font emphasis); 281377 nextPutAll: ' points: '; 281378 print: font pointSize; 281379 nextPutAll: ' height: '; 281380 print: font height; 281381 cr 281382 ]]. 281383 281384 (StringHolder new) 281385 contents: string; 281386 openLabel: 'Current system font settings' translated. 281387! ! 281388 281389!Preferences class methodsFor: 'fonts' stamp: 'nk 7/18/2004 15:34'! 281390refreshFontSettings 281391 "Try to update all the current font settings to make things consistent." 281392 281393 self setFlapsFontTo: (self standardFlapFont); 281394 setEToysFontTo: (self standardEToysFont); 281395 setWindowTitleFontTo: (self windowTitleFont); 281396 setListFontTo: (self standardListFont); 281397 setMenuFontTo: (self standardMenuFont); 281398 setSystemFontTo: (TextStyle defaultFont); 281399 setCodeFontTo: (self standardCodeFont); 281400 setBalloonHelpFontTo: (BalloonMorph balloonFont). 281401 281402 SystemWindow allSubInstancesDo: [ :s | | rawLabel | 281403 rawLabel := s getRawLabel. 281404 rawLabel owner vResizing: #spaceFill. 281405 rawLabel font: rawLabel font. 281406 s setLabel: s label. 281407 s replaceBoxes ].! ! 281408 281409!Preferences class methodsFor: 'fonts' stamp: 'jmv 8/6/2009 10:38'! 281410restoreDefaultFonts 281411 "Since this is called from menus, we can take the opportunity to prompt for missing font styles." 281412 " 281413 Preferences restoreDefaultFonts 281414 " 281415 281416 Preferences setDefaultFonts: #( 281417 (setSystemFontTo: 'Bitmap DejaVu Sans' 9) 281418 (setCodeFontTo: 'Bitmap DejaVu Sans' 9) 281419 (setListFontTo: 'Bitmap DejaVu Sans' 9) 281420 (setMenuFontTo: 'Bitmap DejaVu Sans' 9) 281421 (setFlapsFontTo: 'Accuny' 15) 281422 (setEToysFontTo: 'Accuny' 12) 281423 (setEToysTitleFontTo: 'Accuny' 12) 281424 (setPaintBoxButtonFontTo: 'Accuny' 12) 281425 (setWindowTitleFontTo: 'Bitmap DejaVu Sans' 12) 281426 (setBalloonHelpFontTo: 'Accuny' 10) 281427 (setButtonFontTo: 'Accuny' 9))! ! 281428 281429!Preferences class methodsFor: 'fonts' stamp: 'bp 6/13/2004 17:46'! 281430setBalloonHelpFontTo: aFont 281431 281432 Smalltalk at: #BalloonMorph ifPresent: 281433 [:thatClass | thatClass setBalloonFontTo: aFont]! ! 281434 281435!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 22:06'! 281436setButtonFontTo: aFont 281437 Parameters at: #standardButtonFont put: aFont! ! 281438 281439!Preferences class methodsFor: 'fonts' stamp: 'sw 7/25/2004 17:26'! 281440setCodeFontTo: aFont 281441 "Establish the code font." 281442 281443 Parameters at: #standardCodeFont put: aFont! ! 281444 281445!Preferences class methodsFor: 'fonts' stamp: 'M 8/30/2009 13:21'! 281446setDefaultFonts: defaultFontsSpec 281447 "Since this is called from menus, we can take the opportunity to prompt for missing font styles." 281448 281449 | fontNames map emphases | 281450 fontNames := defaultFontsSpec collect: [:array | array second]. 281451 map := IdentityDictionary new. 281452 emphases := IdentityDictionary new. 281453 fontNames do: [:originalName | | decoded style response | 281454 decoded := TextStyle decodeStyleName: originalName. 281455 style := map at: originalName put: (TextStyle named: decoded second). 281456 emphases at: originalName put: decoded first. 281457 style ifNil: [ 281458 281459 map at: originalName put: (TextStyle default) ]]. 281460 281461 defaultFontsSpec do: [:triplet | self 281462 perform: triplet first 281463 with: (((map at: triplet second) fontOfPointSize: triplet third) emphasized: (emphases at: triplet second))]! ! 281464 281465!Preferences class methodsFor: 'fonts' stamp: 'damiencassou 8/8/2009 20:25'! 281466setDemoFonts 281467 "Preferences setDemoFonts" 281468 |size font codeFont titleFont| 281469 size := UIManager default request: 'Base font size?' initialAnswer: '14'. 281470 size isEmptyOrNil ifTrue: [^ self]. 281471 size := size asInteger. 281472 (size isNil or: [size <= 0]) ifTrue: [^ self]. 281473 font := LogicalFont familyName: 'DejaVu Sans' pointSize: size. 281474 codeFont := LogicalFont familyName: 'DejaVu Sans Mono' pointSize: size. 281475 titleFont := LogicalFont familyName: 'DejaVu Serif' pointSize: size. 281476 281477Preferences 281478 setListFontTo: font; 281479 setMenuFontTo: font; 281480 setCodeFontTo: codeFont; 281481 setButtonFontTo: font; 281482 setSystemFontTo: font; 281483 setWindowTitleFontTo: titleFont.! ! 281484 281485!Preferences class methodsFor: 'fonts' stamp: 'dgd 7/12/2003 11:52'! 281486setEToysFontTo: aFont 281487 "change the font used in eToys environment" 281488 Parameters at: #eToysFont put: aFont! ! 281489 281490!Preferences class methodsFor: 'fonts' stamp: 'dgd 11/3/2004 15:03'! 281491setEToysTitleFontTo: aFont 281492 "change the font used in eToys environment" 281493 Parameters at: #eToysTitleFont put: aFont! ! 281494 281495!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 18:15'! 281496setFlapsFontTo: aFont 281497 281498 Parameters at: #standardFlapFont put: aFont. 281499 FlapTab allSubInstancesDo: 281500 [:aFlapTab | aFlapTab reformatTextualTab]! ! 281501 281502!Preferences class methodsFor: 'fonts' stamp: 'mir 8/24/2004 12:34'! 281503setHaloLabelFontTo: aFont 281504 "change the font used in eToys environment" 281505 Parameters at: #haloLabelFont put: aFont! ! 281506 281507!Preferences class methodsFor: 'fonts' stamp: 'sw 4/17/2001 11:34'! 281508setListFontTo: aFont 281509 "Set the list font as indicated" 281510 281511 Parameters at: #standardListFont put: aFont. 281512 ListParagraph initialize. 281513 Flaps replaceToolsFlap! ! 281514 281515!Preferences class methodsFor: 'fonts' stamp: 'dgd 4/3/2006 14:21'! 281516setMenuFontTo: aFont 281517 "rbb 2/18/2005 12:54 - How should this be changed to work 281518 with the UIManager, if at all?" 281519 Parameters at: #standardMenuFont put: aFont. 281520 PopUpMenu setMenuFontTo: aFont. 281521 TheWorldMainDockingBar updateInstances.! ! 281522 281523!Preferences class methodsFor: 'fonts' stamp: 'yo 1/12/2005 22:43'! 281524setPaintBoxButtonFontTo: aFont 281525 "change the font used in the buttons in PaintBox." 281526 Parameters at: #paintBoxButtonFont put: aFont! ! 281527 281528!Preferences class methodsFor: 'fonts' stamp: 'sw 4/17/2001 11:34'! 281529setSystemFontTo: aFont 281530 "Establish the default text font and style" 281531 281532 | aStyle newDefaultStyle | 281533 aFont ifNil: [^ self]. 281534 aStyle := aFont textStyle ifNil: [^ self]. 281535 newDefaultStyle := aStyle copy. 281536 newDefaultStyle defaultFontIndex: (aStyle fontIndexOf: aFont). 281537 TextConstants at: #DefaultTextStyle put: newDefaultStyle. 281538 Flaps replaceToolsFlap. 281539 ScriptingSystem resetStandardPartsBin! ! 281540 281541!Preferences class methodsFor: 'fonts' stamp: 'alain.plantec 6/11/2008 14:07'! 281542setWindowTitleFontTo: aFont 281543 "Set the window-title font to be as indicated" 281544 281545 Parameters at: #windowTitleFont put: aFont. 281546 Flaps replaceToolsFlap! ! 281547 281548!Preferences class methodsFor: 'fonts' stamp: 'bp 6/13/2004 17:19'! 281549standardBalloonHelpFont 281550 ^BalloonMorph balloonFont! ! 281551 281552!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:13'! 281553standardButtonFont 281554 "Answer an attractive font to use for buttons" 281555 "Answer the font to be used for textual flap tab labels" 281556 ^ Parameters at: #standardButtonFont ifAbsent: 281557 [Parameters at: #standardButtonFont put: (StrikeFont familyName: #ComicBold size: 16)]! ! 281558 281559!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:58'! 281560standardCodeFont 281561 "Answer the font to be used in code" 281562 281563 ^ Parameters at: #standardCodeFont ifAbsent: 281564 [Parameters at: #standardCodeFont put: TextStyle defaultFont]! ! 281565 281566!Preferences class methodsFor: 'fonts' stamp: 'bp 6/13/2004 17:24'! 281567standardDefaultTextFont 281568 ^TextStyle defaultFont! ! 281569 281570!Preferences class methodsFor: 'fonts' stamp: 'nk 7/12/2003 08:50'! 281571standardEToysFont 281572 "Answer the font to be used in the eToys environment" 281573 ^ Parameters 281574 at: #eToysFont 281575 ifAbsent: [Parameters at: #eToysFont put: self standardButtonFont]! ! 281576 281577!Preferences class methodsFor: 'fonts' stamp: 'dgd 11/3/2004 15:02'! 281578standardEToysTitleFont 281579 "Answer the font to be used in the eToys environment" 281580 ^ Parameters 281581 at: #eToysTitleFont 281582 ifAbsent: [Parameters at: #eToysTitleFont put: self standardEToysFont]! ! 281583 281584!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:13'! 281585standardFlapFont 281586 "Answer the font to be used for textual flap tab labels" 281587 ^ Parameters at: #standardFlapFont ifAbsent: 281588 [Parameters at: #standardFlapFont put: self standardButtonFont]! ! 281589 281590!Preferences class methodsFor: 'fonts' stamp: 'mir 8/24/2004 12:34'! 281591standardHaloLabelFont 281592 "Answer the font to be used in the eToys environment" 281593 ^ Parameters 281594 at: #haloLabelFont 281595 ifAbsent: [Parameters at: #haloLabelFont put: TextStyle defaultFont]! ! 281596 281597!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:09'! 281598standardListFont 281599 "Answer the font to be used in lists" 281600 281601 ^ Parameters at: #standardListFont ifAbsent: 281602 [Parameters at: #standardListFont put: TextStyle defaultFont]! ! 281603 281604!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:58'! 281605standardMenuFont 281606 "Answer the font to be used in menus" 281607 281608 ^ Parameters at: #standardMenuFont ifAbsent: 281609 [Parameters at: #standardMenuFont put: TextStyle defaultFont]! ! 281610 281611!Preferences class methodsFor: 'fonts' stamp: 'yo 1/12/2005 22:40'! 281612standardPaintBoxButtonFont 281613 "Answer the font to be used in the eToys environment" 281614 ^ Parameters 281615 at: #paintBoxButtonFont 281616 ifAbsent: [Parameters at: #paintBoxButtonFont put: self standardButtonFont]! ! 281617 281618!Preferences class methodsFor: 'fonts' stamp: 'jmv 8/4/2009 15:09'! 281619subPixelRenderColorFonts 281620 ^ self 281621 valueOfFlag: #subPixelRenderColorFonts 281622 ifAbsent: [true]! ! 281623 281624!Preferences class methodsFor: 'fonts' stamp: 'jmv 8/4/2009 15:09'! 281625subPixelRenderFonts 281626 ^ self 281627 valueOfFlag: #subPixelRenderFonts 281628 ifAbsent: [true]! ! 281629 281630!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:10'! 281631windowTitleFont 281632 "Answer the standard font to use for window titles" 281633 ^ Parameters at: #windowTitleFont ifAbsent: 281634 [Parameters at: #windowTitleFont put: (StrikeFont familyName: #NewYork size: 15)]! ! 281635 281636!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 22:18'! 281637windowTitleStyle 281638 "Answer the standard style to use for window titles" 281639 ^ self windowTitleFont textStyle! ! 281640 281641 281642!Preferences class methodsFor: 'get/set' stamp: 'dgd 8/31/2003 18:07'! 281643automaticFlapLayoutString 281644 "Answer a string for the automaticFlapLayout menu item" 281645 ^ (self automaticFlapLayout 281646 ifTrue: ['<yes>'] 281647 ifFalse: ['<no>']) 281648 , 'automatic flap layout' translated! ! 281649 281650!Preferences class methodsFor: 'get/set' stamp: 'sw 1/19/2000 13:51'! 281651disableGently: preferenceNameSymbol 281652 "Unlike #disable:, this on does not reset the CategoryInfo cache" 281653 self setPreference: preferenceNameSymbol toValue: false! ! 281654 281655!Preferences class methodsFor: 'get/set' stamp: 'sw 4/12/2001 23:29'! 281656disable: aSymbol 281657 "Shorthand access to enabling a preference of the given name. If there is none in the image, conjure one up" 281658 281659 | aPreference | 281660 aPreference := self preferenceAt: aSymbol ifAbsent: 281661 [self addPreference: aSymbol category: 'unclassified' default: false balloonHelp: 'this preference was added idiosyncratically and has no help message.'. 281662 self preferenceAt: aSymbol]. 281663 aPreference preferenceValue: false! ! 281664 281665!Preferences class methodsFor: 'get/set' stamp: 'sw 11/11/1998 11:40'! 281666doesNotUnderstand: aMessage 281667 "Look up the message selector as a flag." 281668 aMessage arguments size > 0 ifTrue: [^ super doesNotUnderstand: aMessage]. 281669 ^ self valueOfFlag: aMessage selector 281670! ! 281671 281672!Preferences class methodsFor: 'get/set' stamp: 'sw 1/19/2000 13:53'! 281673enableGently: preferenceNameSymbol 281674 "Unlike #enable:, this one does not reset the CategoryInfo cache" 281675 self setPreference: preferenceNameSymbol toValue: true! ! 281676 281677!Preferences class methodsFor: 'get/set' stamp: 'sw 8/12/2000 01:26'! 281678enableOrDisable: preferenceNameSymbol asPer: aBoolean 281679 "either enable or disable the given Preference, depending on the value of aBoolean" 281680 281681 aBoolean ifTrue: [self enable: preferenceNameSymbol] ifFalse: [self disable: preferenceNameSymbol]! ! 281682 281683!Preferences class methodsFor: 'get/set' stamp: 'sw 7/13/2001 21:34'! 281684enableProjectNavigator 281685 "Answer whether the project-navigator menu item should be enabled" 281686 281687 ^ true! ! 281688 281689!Preferences class methodsFor: 'get/set' stamp: 'sw 4/12/2001 23:29'! 281690enable: aSymbol 281691 "Shorthand access to enabling a preference of the given name. If there is none in the image, conjure one up" 281692 281693 | aPreference | 281694 aPreference := self preferenceAt: aSymbol ifAbsent: 281695 [self addPreference: aSymbol category: 'unclassified' default: true balloonHelp: 'this preference was added idiosyncratically and has no help message.'. 281696 self preferenceAt: aSymbol]. 281697 aPreference preferenceValue: true! ! 281698 281699!Preferences class methodsFor: 'get/set' stamp: 'sw 4/12/2001 23:29'! 281700setPreference: prefSymbol toValue: aBoolean 281701 "Set the given preference to the given value, and answer that value" 281702 281703 ^ (self preferenceAt: prefSymbol ifAbsent: [^ aBoolean]) preferenceValue: aBoolean! ! 281704 281705!Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:50'! 281706togglePreference: prefSymbol 281707 "Toggle the given preference. prefSymbol must be of a boolean preference" 281708 (self preferenceAt: prefSymbol ifAbsent: [self error: 'unknown preference: ', prefSymbol]) togglePreferenceValue! ! 281709 281710!Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:49'! 281711valueOfFlag: aFlagName 281712 "Utility method for all the preferences that are boolean, and for backward compatibility" 281713 ^self valueOfPreference: aFlagName ifAbsent: [false].! ! 281714 281715!Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:48'! 281716valueOfFlag: aFlagName ifAbsent: booleanValuedBlock 281717 "the same as in #valueOfFlag:" 281718 ^self valueOfPreference: aFlagName ifAbsent: booleanValuedBlock.! ! 281719 281720!Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:49'! 281721valueOfPreference: aPreferenceSymbol 281722 "Answer the value of the given preference" 281723 ^self valueOfPreference: aPreferenceSymbol ifAbsent: []! ! 281724 281725!Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:49'! 281726valueOfPreference: aPreferenceSymbol ifAbsent: booleanValuedBlock 281727 "Answer the value of the given preference" 281728 ^ (self preferenceAt: aPreferenceSymbol ifAbsent: [^ booleanValuedBlock value]) preferenceValue! ! 281729 281730 281731!Preferences class methodsFor: 'halos' stamp: 'michael.rueger 3/9/2009 18:46'! 281732classicHaloSpecs 281733 "Non-iconic halos with traditional placements" 281734 281735 "Preferences installClassicHaloSpecs" 281736 "Preferences resetHaloSpecifications" " <- will result in the standard default halos being reinstalled" 281737 "NB: listed below in clockwise order" 281738 281739 ^ #( 281740 " selector horiz vert color info icon key 281741 --------- ------ ----------- ------------------------------- ---------------" 281742 (addMenuHandle: left top (red) none) 281743 (addDismissHandle: leftCenter top (red muchLighter) 'Halo-Dismiss') 281744 (addGrabHandle: center top (black) none) 281745 (addDragHandle: rightCenter top (brown) none) 281746 (addDupHandle: right top (green) none) 281747 (addDebugHandle: right topCenter (blue veryMuchLighter) none) 281748 (addRepaintHandle: right center (lightGray) none) 281749 (addGrowHandle: right bottom (yellow) none) 281750 (addScaleHandle: right bottom (lightOrange) none) 281751 (addFontEmphHandle: rightCenter bottom (lightBrown darker) none) 281752 (addFontStyleHandle: center bottom (lightRed) none) 281753 (addFontSizeHandle: leftCenter bottom (lightGreen) none) 281754 281755 (addRecolorHandle: right bottomCenter (magenta darker) none) 281756 281757 (addRotateHandle: left bottom (blue) none)) 281758 281759! ! 281760 281761!Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:34'! 281762classicHalosInForce 281763 ^ (self preferenceAt: #haloTheme) preferenceValue == #classicHaloSpecs! ! 281764 281765!Preferences class methodsFor: 'halos' stamp: 'michael.rueger 3/9/2009 18:46'! 281766customHaloSpecs 281767 "Intended for you to modify to suit your personal preference. What is implemented in the default here is just a skeleton; in comment at the bottom of this method are some useful lines you may wish to paste in to the main body here, possibly modifying positions, colors, etc.. 281768 Note that in this example, we include: 281769 Dismiss handle, at top-left 281770 Menu handle, at top-right 281771 Resize handle, at bottom-right 281772 Rotate handle, at bottom-left 281773 Drag handle, at top-center 281774 Recolor handle, at left-center. (this one is NOT part of the standard formulary -- 281775 it is included here to illustrate how to 281776 add non-standard halos) 281777 Note that the optional handles for specialized morphs, such as Sketch, Text, PasteUp, are also included" 281778 281779 ^ #( 281780 (addDismissHandle: left top (red muchLighter) 'Halo-Dismiss') 281781 (addMenuHandle: right top (red) 'Halo-Menu') 281782 (addDragHandle: center top (brown) 'Halo-Drag') 281783 (addGrowHandle: right bottom (yellow) 'Halo-Scale') 281784 (addScaleHandle: right bottom (lightOrange) 'Halo-Scale') 281785 281786 (addRecolorHandle: left center (green muchLighter lighter) 'Halo-Recolor') 281787 281788 (addRepaintHandle: right center (lightGray) 'Halo-Paint') 281789 (addFontSizeHandle: leftCenter bottom (lightGreen) 'Halo-FontSize') 281790 (addFontStyleHandle: center bottom (lightRed) 'Halo-FontStyle') 281791 (addFontEmphHandle: rightCenter bottom (lightBrown darker) 'Halo-FontEmph') 281792 (addRotateHandle: left bottom (blue) 'Halo-Rot') 281793 281794 (addDebugHandle: right topCenter (blue veryMuchLighter) 'Halo-Debug') 281795 ) 281796 281797 " Other useful handles... 281798 281799 selector horiz vert color info icon key 281800 --------- ------ ----------- ------------------------------- --------------- 281801 281802 (addTileHandle: left bottomCenter (lightBrown) 'Halo-Tile') 281803 (addViewHandle: left center (cyan) 'Halo-View') 281804 (addGrabHandle: center top (black) 'Halo-Grab') 281805 (addDragHandle: rightCenter top (brown) 'Halo-Drag') 281806 (addDupHandle: right top (green) 'Halo-Dup') 281807 (addHelpHandle: center bottom (lightBlue) 'Halo-Help') 281808 (addFewerHandlesHandle: left topCenter (paleBuff) 'Halo-FewerHandles') 281809 (addPaintBgdHandle: right center (lightGray) 'Halo-Paint') 281810 (addRepaintHandle: right center (lightGray) 'Halo-Paint') 281811 " 281812! ! 281813 281814!Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:34'! 281815customHalosInForce 281816 ^ (self preferenceAt: #haloTheme) preferenceValue == #customHaloSpecs! ! 281817 281818!Preferences class methodsFor: 'halos' stamp: 'ar 9/27/2005 20:32'! 281819editCustomHalos 281820 281821 ToolSet browse: Preferences class 281822 selector: #customHaloSpecs! ! 281823 281824!Preferences class methodsFor: 'halos' stamp: 'sw 10/30/2000 13:32'! 281825haloSpecifications 281826 "Answer a list of HaloSpecs that describe which halos are to be used, what they should look like, and where they should be situated" 281827 281828 ^ Parameters at: #HaloSpecs ifAbsent: 281829 [self installHaloTheme: #iconicHaloSpecifications. 281830 ^ Parameters at: #HaloSpecs] 281831 281832 "Preferences haloSpecifications" 281833 "Preferences resetHaloSpecifications" 281834! ! 281835 281836!Preferences class methodsFor: 'halos' stamp: 'michael.rueger 3/9/2009 18:46'! 281837haloSpecificationsForWorld 281838 | desired | 281839 "Answer a list of HaloSpecs that describe which halos are to be used on a world halo, what they should look like, and where they should be situated" 281840 "Preferences resetHaloSpecifications" 281841 281842 desired := #(addDebugHandle: addMenuHandle: addHelpHandle: addRecolorHandle:). 281843 ^ self haloSpecifications select: 281844 [:spec | desired includes: spec addHandleSelector]! ! 281845 281846!Preferences class methodsFor: 'halos'! 281847haloTheme 281848 ^ self 281849 valueOfFlag: #haloTheme 281850 ifAbsent: [#iconicHaloSpecifications]! ! 281851 281852!Preferences class methodsFor: 'halos' stamp: 'stephane.ducasse 3/19/2009 14:58'! 281853iconicHaloSpecifications 281854 "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" 281855 281856 "Preferences resetHaloSpecifications" 281857 281858 ^ #( 281859 " selector horiz vert color info icon key 281860 --------- ------ ----------- ------------------------------- ---------------" 281861 (addCollapseHandle: left topCenter (tan) 'Halo-Collapse') 281862 (addDebugHandle: right topCenter (blue veryMuchLighter) 'Halo-Debug') 281863 (addDismissHandle: left top (red muchLighter) 'Halo-Dismiss') 281864 (addRotateHandle: left bottom (blue) 'Halo-Rot') 281865 (addMenuHandle: leftCenter top (red) 'Halo-Menu') 281866 (addGrabHandle: center top (black) 'Halo-Grab') 281867 (addDragHandle: rightCenter top (brown) 'Halo-Drag') 281868 (addDupHandle: right top (green) 'Halo-Dup') 281869 (addHelpHandle: center bottom (lightBlue) 'Halo-Help') 281870 (addGrowHandle: right bottom (yellow) 'Halo-Scale') 281871 (addScaleHandle: right bottom (lightOrange) 'Halo-Scale') 281872 (addRepaintHandle: right center (lightGray) 'Halo-Paint') 281873 (addFontSizeHandle: leftCenter bottom (lightGreen) 'Halo-FontSize') 281874 (addFontStyleHandle: center bottom (lightRed) 'Halo-FontStyle') 281875 (addFontEmphHandle: rightCenter bottom (lightBrown darker) 'Halo-FontEmph') 281876 (addRecolorHandle: right bottomCenter (magenta darker) 'Halo-Recolor') 281877 (addChooseGraphicHandle: right bottomCenter (green muchLighter) 'Halo-ChooseGraphic') 281878 ) ! ! 281879 281880!Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:34'! 281881iconicHalosInForce 281882 ^ (self preferenceAt: #haloTheme) preferenceValue == #iconicHaloSpecifications! ! 281883 281884!Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:35'! 281885installClassicHaloSpecs 281886 "Install an alternative set of halos, rather more based on the old placements, and without icons, , and lacking the scripting-relating handles.." 281887 "Preferences installClassicHaloSpecs" 281888 "Preferences resetHaloSpecifications" " <- will result in the standard default halos being reinstalled" 281889 self installHaloTheme: #classicHaloSpecs! ! 281890 281891!Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:36'! 281892installCustomHaloSpecs 281893 "Install an alternative set of halos, as customized by the user" 281894 "Preferences installCustomHaloSpecs" 281895 self installHaloTheme: #customHaloSpecs! ! 281896 281897!Preferences class methodsFor: 'halos' stamp: 'sw 1/27/2000 16:45'! 281898installHaloSpecsFromArray: anArray 281899 281900 | aColor | 281901 ^ Parameters at: #HaloSpecs put: 281902 (anArray collect: 281903 [:quin | 281904 aColor := Color. 281905 quin fourth do: [:sel | aColor := aColor perform: sel]. 281906 HaloSpec new 281907 horizontalPlacement: quin second 281908 verticalPlacement: quin third 281909 color: aColor 281910 iconSymbol: quin fifth 281911 addHandleSelector: quin first])! ! 281912 281913!Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:35'! 281914installHaloTheme: themeSymbol 281915 self installHaloSpecsFromArray: (self perform: themeSymbol). 281916 (self preferenceAt: #haloTheme) preferenceValue: themeSymbol. 281917 ! ! 281918 281919!Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:36'! 281920installIconicHaloSpecs 281921 "Install an alternative set of halos, rather more based on the old placements, and without icons, , and lacking the scripting-relating handles.." 281922 "Preferences installIconicHaloSpecs" 281923 self installHaloTheme: #iconicHaloSpecifications! ! 281924 281925!Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:36'! 281926installSimpleHaloSpecs 281927 "Preferences installSimpleHaloSpecs" 281928 self installHaloTheme: #simpleFullHaloSpecifications! ! 281929 281930!Preferences class methodsFor: 'halos' stamp: 'sw 1/25/2000 20:10'! 281931resetHaloSpecifications 281932 "Preferences resetHaloSpecifications" 281933 281934 ^ Parameters removeKey: #HaloSpecs ifAbsent: []! ! 281935 281936!Preferences class methodsFor: 'halos' stamp: 'sw 11/6/2000 10:02'! 281937showChooseGraphicHaloHandle 281938 "Hard-coded; reimplement to change behavior. If this preference is set to true, then a choose-graphic halo handle may appear on the halo of SketchMorphs" 281939 281940 ^ false! ! 281941 281942!Preferences class methodsFor: 'halos' stamp: 'michael.rueger 3/9/2009 18:47'! 281943simpleFullHaloSpecifications 281944 "This method gives the specs for the 'full' handles variant when simple halos are in effect" 281945 281946 "Preferences resetHaloSpecifications" 281947 281948 ^ #( 281949 " selector horiz vert color info icon key 281950 --------- ------ ----------- ------------------------------- ---------------" 281951 (addDebugHandle: right topCenter (blue veryMuchLighter) 'Halo-Debug') 281952 (addDismissHandle: left top (red muchLighter) 'Halo-Dismiss') 281953 (addRotateHandle: left bottom (blue) 'Halo-Rot') 281954 (addMenuHandle: leftCenter top (red) 'Halo-Menu') 281955 (addGrabHandle: center top (black) 'Halo-Grab') 281956 (addDragHandle: rightCenter top (brown) 'Halo-Drag') 281957 (addDupHandle: right top (green) 'Halo-Dup') 281958 (addHelpHandle: center bottom (lightBlue) 'Halo-Help') 281959 (addGrowHandle: right bottom (yellow) 'Halo-Scale') 281960 (addScaleHandle: right bottom (lightOrange) 'Halo-Scale') 281961 (addFewerHandlesHandle: left topCenter (paleBuff) 'Halo-FewerHandles') 281962 (addRepaintHandle: right center (lightGray) 'Halo-Paint') 281963 (addFontSizeHandle: leftCenter bottom (lightGreen) 'Halo-FontSize') 281964 (addFontStyleHandle: center bottom (lightRed) 'Halo-FontStyle') 281965 (addFontEmphHandle: rightCenter bottom (lightBrown darker) 'Halo-FontEmph') 281966 (addRecolorHandle: right bottomCenter (magenta darker) 'Halo-Recolor') 281967 281968 ) ! ! 281969 281970 281971!Preferences class methodsFor: 'hard-coded prefs' stamp: 'ar 9/28/2005 15:04'! 281972browseToolClass 281973 "This method is used for returning the appropiate class for the #browserShowsPackagePane preference. Now that preference modifies the registry so here we query directly to the registry" 281974 ^ SystemBrowser default.! ! 281975 281976!Preferences class methodsFor: 'hard-coded prefs' stamp: 'programmatic 7/15/1999 09:55'! 281977cmdKeysInText 281978 "compiled programatically -- return hard-coded preference value" 281979 ^ true! ! 281980 281981!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 12/1/1999 13:04'! 281982debugMenuItemsInvokableFromScripts 281983 "If true, then items occurring in an object's debug menu will be included in the alternatives offered as arguments to a doMenuItem: tile in the scripting system" 281984 ^ false! ! 281985 281986!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 9/6/2000 05:26'! 281987desktopMenuTitle 281988 "Answer the title to be used for the 'meta menu'. For now, you can hard-code this, later someone should make this be a parameter the user can easily change. sw 9/6/2000" 281989 281990 ^ 'World' "This is what it has always been" 281991 281992 "^ 'Desktop' 281993 ^ 'Squeak' 281994 ^ 'Mike''s Control Panel'"! ! 281995 281996!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 8/11/2002 02:18'! 281997messengersInViewers 281998 "A coming technology..." 281999 282000 ^ false! ! 282001 282002!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 8/18/2000 13:26'! 282003metaMenuDisabled 282004 "If true, then click/cmd-click on the desktop will not bring up the World menu. Can be changed manually right here, and can be programattically changed via a call of the following form: 282005 282006 Preferences compileHardCodedPref: #metaMenuDisabled enable: true" 282007 282008 ^ false! ! 282009 282010!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 8/29/2000 15:01'! 282011preserveCommandExcursions 282012 "An architecture is in place for storing command excursions to which access is otherwise cut off by having taken a variant branch, but it is not accessible unless you hand-code this preference to true -- which I suggest you do only with fingers crossed." 282013 282014 ^ false! ! 282015 282016!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 11/15/2001 08:37'! 282017suppressWindowTitlesInInstanceBrowsers 282018 "Hard-coded for the moment: answer whether instance browsers should suppresss their window titles" 282019 282020 ^ false! ! 282021 282022!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 2/16/1999 11:24'! 282023useCategoryListsInViewers 282024 "Temporarily hard-coded pending viewer work underway" 282025 ^ false! ! 282026 282027 282028!Preferences class methodsFor: 'initialization' stamp: 'sw 4/10/2001 15:28'! 282029chooseInitialSettings 282030 "Restore the default choices for all of the standard Preferences." 282031 282032 self allPreferenceObjects do: 282033 [:aPreference | 282034 aPreference restoreDefaultValue]. 282035 Project current installProjectPreferences! ! 282036 282037!Preferences class methodsFor: 'initialization' stamp: 'NS 1/28/2004 14:43'! 282038compileAccessMethodForPreference: aPreference 282039 "Compile an accessor method for the given preference" 282040 282041 self class compileSilently: (aPreference name, ' 282042 ^ self valueOfFlag: #', aPreference name, ' ifAbsent: [', aPreference defaultValue storeString, ']') classified: 'standard queries'! ! 282043 282044!Preferences class methodsFor: 'initialization' stamp: 'rr 10/1/2005 15:14'! 282045initializeDictionaryOfPreferences 282046 "Initialize the DictionaryOfPreferences to be an empty IdentityDictionary" 282047 282048 "Preferences initializeDictionaryOfPreferences" 282049 282050 self dictionaryOfPreferences:IdentityDictionary new! ! 282051 282052!Preferences class methodsFor: 'initialization' stamp: 'tak 8/3/2005 21:17'! 282053localeChanged 282054 LocaleID current isoLanguage = 'ja' 282055 ifTrue: [Preferences enable: #useFormsInPaintBox] 282056 ifFalse: [Preferences disable: #useFormsInPaintBox]! ! 282057 282058!Preferences class methodsFor: 'initialization' stamp: 'ar 9/27/2005 21:49'! 282059removeObsolete 282060 "Remove obsolete preferences" 282061 Preference allInstancesDo:[:pref| 282062 pref isObsolete ifTrue:[self removePreference: pref]. 282063 ].! ! 282064 282065!Preferences class methodsFor: 'initialization' stamp: 'adrian-lienhard 6/4/2009 21:29'! 282066removePreference: aSymbol 282067 "Remove all memory of the given preference symbol." 282068 282069 self dictionaryOfPreferences removeKey: aSymbol ifAbsent: []! ! 282070 282071!Preferences class methodsFor: 'initialization' stamp: 'sw 4/21/2002 05:13'! 282072setPreferencesFrom: listOfPairs 282073 "Given a list of <preferenceName, value> pairs, set preference values. This method is tolerent of the value being supplied either a Boolean or else one of the symbols #true and #false. Also, a new-value of #noOpinion will result in that 'preference's value not being changed." 282074 282075 listOfPairs do: 282076 [:aPair | 282077 (aPair second == #noOpinion) ifFalse: 282078 [Preferences setPreference: aPair first toValue: ((aPair second == #true) or: [aPair second == true])]] 282079 282080" 282081Preferences setPreferencesFrom: #(( mouseOverForKeyboardFocus false)) 282082Preferences setPreferencesFrom: {{ #mouseOverForKeyboardFocus. true}} 282083"! ! 282084 282085 282086!Preferences class methodsFor: 'menu parameters' stamp: 'dgd 9/5/2004 16:17'! 282087defaultWorldColor 282088 ^ Parameters 282089 at: #defaultWorldColor 282090 ifAbsent: [ Color r: 0.937 g: 0.937 b: 0.937 ]. 282091! ! 282092 282093!Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:16'! 282094menuBorderColor 282095 Display depth <= 2 ifTrue: [^ Color black]. 282096 ^ Parameters at: #menuBorderColor! ! 282097 282098!Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:16'! 282099menuBorderWidth 282100 ^ Parameters at: #menuBorderWidth! ! 282101 282102!Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:17'! 282103menuColor 282104 Display depth <= 2 ifTrue: [^ Color white]. 282105 ^ Parameters at: #menuColor! ! 282106 282107!Preferences class methodsFor: 'menu parameters' stamp: 'dgd 3/23/2003 11:06'! 282108menuLineColor 282109 ^ Parameters 282110 at: #menuLineColor 282111 ifAbsentPut: [Preferences menuBorderColor lighter]! ! 282112 282113!Preferences class methodsFor: 'menu parameters' stamp: 'dgd 8/30/2004 20:59'! 282114menuSelectionColor 282115 ^ Parameters 282116 at: #menuSelectionColor 282117 ifAbsent: [nil]! ! 282118 282119!Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:19'! 282120menuTitleBorderColor 282121 Display depth <= 2 ifTrue: [^ Color black]. 282122 ^ Parameters at: #menuTitleBorderColor! ! 282123 282124!Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:16'! 282125menuTitleBorderWidth 282126 ^ Parameters at: #menuTitleBorderWidth! ! 282127 282128!Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:18'! 282129menuTitleColor 282130 Display depth = 1 ifTrue: [^ Color white]. 282131 Display depth = 2 ifTrue: [^ Color gray]. 282132 ^ Parameters at: #menuTitleColor! ! 282133 282134!Preferences class methodsFor: 'menu parameters' stamp: 'dgd 3/23/2003 11:11'! 282135restoreDefaultMenuParameters 282136 "Restore the four color choices of the original implementors of 282137 MorphicMenus" 282138 " 282139 Preferences restoreDefaultMenuParameters 282140 " 282141 Parameters 282142 at: #menuColor 282143 put: (Color 282144 r: 0.97 282145 g: 0.97 282146 b: 0.97). 282147 Parameters 282148 at: #menuBorderColor 282149 put: (Color 282150 r: 0.167 282151 g: 0.167 282152 b: 1.0). 282153 Parameters at: #menuBorderWidth put: 2. 282154 Parameters at: #menuTitleColor put: (Color 282155 r: 0.4 282156 g: 0.8 282157 b: 0.9) twiceDarker. 282158 Parameters 282159 at: #menuTitleBorderColor 282160 put: (Color 282161 r: 0.333 282162 g: 0.667 282163 b: 0.751). 282164 Parameters at: #menuTitleBorderWidth put: 1. 282165 Parameters 282166 at: #menuLineColor 282167 put: (Preferences menuBorderColor lighter)! ! 282168 282169 282170!Preferences class methodsFor: 'misc' stamp: 'sw 10/6/1999 15:20'! 282171addModelItemsToWindowMenu: aMenu 282172 aMenu addLine. 282173 aMenu add: 'restore default preference settings' target: self action: #chooseInitialSettings. 282174 aMenu add: 'restore default text highlighting' target: self action: #initializeTextHighlightingParameters! ! 282175 282176!Preferences class methodsFor: 'misc' stamp: 'dgd 9/7/2004 18:35'! 282177balloonHelpDelayTime 282178 "Answer the number of milliseconds before a balloon help 282179 should be put up on morphs." 282180 ^ Parameters 282181 at: #balloonHelpDelayTime 282182 ifAbsent: [800]! ! 282183 282184!Preferences class methodsFor: 'misc' stamp: 'ar 9/27/2005 21:07'! 282185browseThemes 282186 "Open up a message-category browser on the theme-defining methods" 282187 282188 | aBrowser | 282189 aBrowser := Browser new setClass: Preferences class selector: #outOfTheBox. 282190 aBrowser messageCategoryListIndex: ((Preferences class organization categories indexOf: 'themes' ifAbsent: [^ self inform: 'no themes found']) + 1). 282191 Browser openBrowserView: (aBrowser openMessageCatEditString: nil) 282192 label: 'Preference themes' 282193 282194 "Preferences browseThemes"! ! 282195 282196!Preferences class methodsFor: 'misc' stamp: 'alain.plantec 5/18/2009 15:23'! 282197defaultValueTableForCurrentRelease 282198 "Answer a table defining default values for all the preferences in the release. Returns a list of (pref-symbol, boolean-symbol) pairs" 282199 282200 ^ #( 282201 (abbreviatedBrowserButtons false) 282202 (allowCelesteTell true) 282203 (alternativeScrollbarLook true) 282204 (alternativeWindowLook true) 282205 (annotationPanes false) 282206 (areaFillsAreTolerant false) 282207 (areaFillsAreVeryTolerant false) 282208 (autoAccessors false) 282209 (automaticFlapLayout true) 282210 (automaticKeyGeneration false) 282211 (automaticPlatformSettings true) 282212 (automaticViewerPlacement true) 282213 (balloonHelpEnabled true) 282214 (batchPenTrails false) 282215 (browseWithDragNDrop false) 282216 (browseWithPrettyPrint false) 282217 (browserShowsPackagePane false) 282218 (canRecordWhilePlaying false) 282219 (capitalizedReferences true) 282220 (caseSensitiveFinds false) 282221 (cautionBeforeClosing false) 282222 (celesteHasStatusPane false) 282223 (celesteShowsAttachmentsFlag false) 282224 (changeSetVersionNumbers true) 282225 (checkForSlips true) 282226 (checkForUnsavedProjects true) 282227 (classicNavigatorEnabled false) 282228 (classicNewMorphMenu false) 282229 (clickOnLabelToEdit false) 282230 (cmdDotEnabled true) 282231 (collapseWindowsInPlace false) 282232 (compactViewerFlaps false) 282233 (compressFlashImages false) 282234 (conversionMethodsAtFileOut false) 282235 (cpuWatcherEnabled false) 282236 (debugHaloHandle true) 282237 (debugPrintSpaceLog false) 282238 (debugShowDamage false) 282239 (decorateBrowserButtons true) 282240 (diffsInChangeList true) 282241 (diffsWithPrettyPrint false) 282242 (dismissAllOnOptionClose false) 282243 (dragNDropWithAnimation false) 282244 (eToyFriendly false) 282245 (eToyLoginEnabled false) 282246 (enableLocalSave true) 282247 (extractFlashInHighQuality true) 282248 (extractFlashInHighestQuality false) 282249 (fastDragWindowForMorphic true) 282250 (fenceEnabled true) 282251 (fullScreenLeavesDeskMargins true) 282252 (haloTransitions false) 282253 (hiddenScrollBars false) 282254 (higherPerformance false) 282255 (honorDesktopCmdKeys true) 282256 (ignoreStyleIfOnlyBold true) 282257 (inboardScrollbars true) 282258 (includeSoundControlInNavigator false) 282259 (infiniteUndo false) 282260 (logDebuggerStackToFile true) 282261 (magicHalos false) 282262 (menuButtonInToolPane false) 282263 (menuColorFromWorld false) 282264 (menuKeyboardControl false) 282265 (modalColorPickers true) 282266 (mouseOverForKeyboardFocus false) 282267 (mouseOverHalos false) 282268 (mvcProjectsAllowed true) 282269 (navigatorOnLeftEdge true) 282270 (noviceMode false) 282271 (okToReinitializeFlaps true) 282272 (optionalButtons true) 282273 (passwordsOnPublish false) 282274 (personalizedWorldMenu true) 282275 (postscriptStoredAsEPS false) 282276 (preserveTrash true) 282277 (projectViewsInWindows true) 282278 (projectZoom true) 282279 (projectsSentToDisk false) 282280 (promptForUpdateServer true) 282281 (propertySheetFromHalo false) 282282 (readDocumentAtStartup true) 282283 (restartAlsoProceeds false) 282284 (reverseWindowStagger true) 282285 (roundedMenuCorners true) 282286 (roundedWindowCorners true) 282287 (scrollBarsNarrow false) 282288 (scrollBarsOnRight true) 282289 (scrollBarsWithoutMenuButton false) 282290 (securityChecksEnabled false) 282291 (selectiveHalos false) 282292 (showBoundsInHalo false) 282293 (showDirectionForSketches false) 282294 (showDirectionHandles false) 282295 (showFlapsWhenPublishing false) 282296 (showProjectNavigator false) 282297 (showSecurityStatus true) 282298 (showSharedFlaps true) 282299 (signProjectFiles true) 282300 (simpleMenus false) 282301 (slideDismissalsToTrash true) 282302 (smartUpdating true) 282303 (soundQuickStart false) 282304 (soundStopWhenDone false) 282305 (soundsEnabled true) 282306 (startInUntrustedDirectory false) 282307 (systemWindowEmbedOK false) 282308 (thoroughSenders true) 282309 (tileTranslucentDrag true) 282310 (timeStampsInMenuTitles true) 282311 (turnOffPowerManager false) 282312 (twentyFourHourFileStamps true) 282313 (twoSidedPoohTextures true) 282314 (typeCheckingInTileScripting true) 282315 (uniTilesClassic true) 282316 (uniqueNamesInHalos false) 282317 (universalTiles false) 282318 (unlimitedPaintArea false) 282319 (updateSavesFile false) 282320 (useButtonProprtiesToFire false) 282321 (useUndo true) 282322 (viewersInFlaps true) 282323 (warnAboutInsecureContent true) 282324 (warnIfNoChangesFile true) 282325 (warnIfNoSourcesFile true)) 282326 282327 282328" 282329Preferences defaultValueTableForCurrentRelease do: 282330 [:pair | (Preferences preferenceAt: pair first ifAbsent: [nil]) ifNotNilDo: 282331 [:pref | pref defaultValue: (pair last == true)]]. 282332Preferences chooseInitialSettings. 282333"! ! 282334 282335!Preferences class methodsFor: 'misc' stamp: 'ar 9/27/2005 20:46'! 282336giveHelpWithPreferences 282337 "Open up a workspace with explanatory info in it about Preferences" 282338 282339 | aString aHelpString | 282340 aString := String streamContents: [:aStream | 282341 aStream nextPutAll: 282342 282343'Many aspects of the system are governed by the settings of various "Preferences". 282344 282345Click on any of brown tabs at the top of the panel to see all the preferences in that category. 282346Or type in to the box above the Search button, then hit Search, and all Preferences matching whatever you typed in will appear in the "search results" category. A preference is considered to match your search if either its name matches the characters *or* if anything in the balloon help provided for the preferences matches the search text. 282347 282348To find out more about any particular Preference, hold the mouse over it for a moment and balloon help will appear. Also, a complete list of all the Preferences, with documentation for each, is included below. 282349 282350Preferences whose names are in shown in bold in the Preferences Panel are designated as being allowed to vary from project to project; those whose name are not in bold are "global", which is to say, they apply equally whatever project you are in. 282351 282352Click on the name of any preference to get a menu which allows you to *change* whether the preference should vary from project to project or should be global, and also allows you to browse all the senders of the preference, and to discover all the categories under which the preference has been classified, and to be handed a button that you can drop wherever you please that will control the preference. 282353 282354If you like all your current Preferences settings, you may wish to hit the "Save Current Settings as my Personal Preferences" button. Once you have done that, you can at any point in the future hit "Restore my Personal Preferences" and all your saved settings will get restored immediately. 282355 282356Also, you can use "themes" to set multiple preferences all at once; click on the "change theme..." button in the Squeak flap or in the Preferences panel, or seek out the themes item in the Appearance menu.' translated. 282357 282358 aStream cr; cr; nextPutAll: '-----------------------------------------------------------------'; 282359 cr; cr; nextPutAll: 'Alphabetical listing of all Preferences' translated; cr; cr. 282360 (Preferences allPreferenceObjects asSortedCollection: [:a :b | a name < b name]) do: 282361 [:pref | 282362 aStream nextPutAll: pref name; cr. 282363 aHelpString := pref helpString translated. 282364 (aHelpString beginsWith: pref name) ifTrue: 282365 [aHelpString := aHelpString copyFrom: (pref name size + 3) to: aHelpString size]. 282366 aHelpString := (aHelpString copyReplaceAll: String cr with: ' ') copyWithout: Character tab. 282367 aStream nextPutAll: aHelpString capitalized. 282368 (aHelpString last == $.) ifFalse: [aStream nextPut: $.]. 282369 aStream cr; cr]]. 282370 282371 UIManager default edit: aString label: 'About Preferences' translated 282372 282373"Preferences giveHelpWithPreferences"! ! 282374 282375!Preferences class methodsFor: 'misc' stamp: 'yo 7/2/2004 19:44'! 282376installTheme: aSymbol 282377 "Install the theme represented by aSymbol. The code that makes the theme-specific changes is lodged in a method of the same name as aSymbol, which must reside in category #themes in Preferences class" 282378 282379 self perform: aSymbol. 282380 self inform: ('Theme {1} is now installed. 282381Many of the changes will only be 282382noticeable in new windows that you 282383create from now on.' translated format: {aSymbol translated}).! ! 282384 282385!Preferences class methodsFor: 'misc' stamp: 'dgd 9/21/2003 13:51'! 282386menuColorString 282387 ^ ((self valueOfFlag: #menuColorFromWorld) 282388 ifTrue: ['stop menu-color-from-world'] 282389 ifFalse: ['start menu-color-from-world']) translated! ! 282390 282391!Preferences class methodsFor: 'misc' stamp: 'em 3/24/2005 14:11'! 282392offerThemesMenu 282393 "Put up a menu offering the user a choice of themes. Each theme is represented by a method in category #themes in Preferences class. The comment at the front of each method is used as the balloon help for the theme" 282394 282395 "Preferences offerThemesMenu" 282396 | selectors aMenu | 282397 selectors := self class allMethodsInCategory: #themes. 282398 selectors := selectors select: [:sel | sel numArgs = 0]. 282399 aMenu := MenuMorph new defaultTarget: self. 282400 aMenu addTitle: 'Choose a theme to install' translated. 282401 selectors do: 282402 [:sel | 282403 aMenu add: sel target: self selector: #installTheme: argument: sel. 282404 aMenu balloonTextForLastItem: (self class firstCommentAt: sel)]. 282405 aMenu addLine. 282406 aMenu add: 'browse themes' translated target: self action: #browseThemes. 282407 aMenu balloonTextForLastItem: 'Puts up a tool that will allow you to view and edit the code underlying all of the available themes' translated. 282408 aMenu popUpInWorld. 282409 "(Workspace new contents: 'here is an example of a new window with your new theme installed' translated) openLabel: 'Testing one two three'"! ! 282410 282411!Preferences class methodsFor: 'misc' stamp: 'sw 4/24/2001 12:02'! 282412okayToChangeProjectLocalnessOf: prefSymbol 282413 "Answer whether it would be okay to allow the user to switch the setting of whether or not the preference symbol is local to a project. Formerly useful and perhaps again will be, though to be sure this is a non-modular design." 282414 282415 ^ (#() includes: prefSymbol) not! ! 282416 282417!Preferences class methodsFor: 'misc' stamp: 'yo 2/10/2005 16:15'! 282418roundedCornersString 282419 ^ (((self valueOfFlag: #roundedWindowCorners) 282420 ifTrue: ['stop'] 282421 ifFalse: ['start']) , ' rounding window corners') translated! ! 282422 282423!Preferences class methodsFor: 'misc' stamp: 'sw 3/2/2004 22:11'! 282424setArrowheads 282425 "Let the user edit the size of arrowheads" 282426 282427 | aParameter result | 282428 aParameter := self parameterAt: #arrowSpec ifAbsent: [5 @ 4]. 282429 result := Morph obtainArrowheadFor: 'Default size of arrowheads on pen trails ' translated defaultValue: aParameter asString. 282430 result ifNotNil: 282431 [self setParameter: #arrowSpec to: result] 282432 ifNil: 282433 [Beeper beep]! ! 282434 282435!Preferences class methodsFor: 'misc' stamp: 'sw 1/4/2001 06:56'! 282436setFlag: prefSymbol toValue: aBoolean during: aBlock 282437 "Set the flag to the given value for the duration of aBlock" 282438 282439 | existing | 282440 existing := self valueOfFlag: prefSymbol. 282441 existing == aBoolean ifFalse: [self setPreference: prefSymbol toValue: aBoolean]. 282442 aBlock value. 282443 existing == aBoolean ifFalse: [self setPreference: prefSymbol toValue: existing]! ! 282444 282445!Preferences class methodsFor: 'misc' stamp: 'marcus.denker 9/19/2008 17:01'! 282446soundEnablingString 282447 ^ self soundsEnabled 282448 ifFalse: 282449 ['Turn sound on' translated] 282450 ifTrue: 282451 ['Turn sound off' translated]! ! 282452 282453!Preferences class methodsFor: 'misc' stamp: 'dgd 9/21/2003 13:46'! 282454staggerPolicyString 282455 "Answer the string to be shown in a menu to represent the 282456 stagger-policy status" 282457 ^ ((self valueOfFlag: #reverseWindowStagger) 282458 ifTrue: ['<yes>'] 282459 ifFalse: ['<no>']), 'stagger windows' translated! ! 282460 282461!Preferences class methodsFor: 'misc' stamp: 'dgd 9/1/2003 11:43'! 282462themeChoiceButtonOfColor: aColor font: aFont 282463 "Answer a button inviting the user to choose a theme" 282464 282465 | aButton | 282466 aButton := SimpleButtonMorph new target: self; actionSelector: #offerThemesMenu. 282467 aButton label: 'change theme...' translated font: aFont. 282468 aButton color: aColor. 282469 aButton setBalloonText: 'Numerous "Preferences" govern many things about the way Squeak looks and behaves. Set individual preferences using a "Preferences" panel. Set an entire "theme" of many Preferences all at the same time by pressing this "change theme" button and choosing a theme to install. Look in category "themes" in Preferences class to see what each theme does; add your own methods to the "themes" category and they will show up in the list of theme choices.' translated. 282470 ^ aButton! ! 282471 282472!Preferences class methodsFor: 'misc' stamp: 'sw 7/13/1999 16:51'! 282473toggleMenuColorPolicy 282474 self togglePreference: #menuColorFromWorld! ! 282475 282476!Preferences class methodsFor: 'misc' stamp: 'sw 7/13/1999 16:52'! 282477toggleRoundedCorners 282478 self togglePreference: #roundedWindowCorners! ! 282479 282480!Preferences class methodsFor: 'misc' stamp: 'ssa 2/9/2000 11:01'! 282481toggleSoundEnabling 282482 self togglePreference: #soundsEnabled! ! 282483 282484!Preferences class methodsFor: 'misc' stamp: 'sw 6/11/1999 20:49'! 282485toggleWindowPolicy 282486 self togglePreference: #reverseWindowStagger! ! 282487 282488!Preferences class methodsFor: 'misc' stamp: 'MiguelCoba 7/25/2009 02:19'! 282489wantsChangeSetLogging 282490 "Answer whether method changes in the receiver should be logged to current change set. This circumlocution avoids such logging for programmatically-compiled methods in Preferences, removing an annoyance" 282491 282492 ^ Author fullNamePerSe ~= 'programmatic'! ! 282493 282494 282495!Preferences class methodsFor: 'paintbox' stamp: 'yo 1/13/2005 11:05'! 282496useFormsInPaintBox: aBoolean 282497 282498 self setPreference: #useFormsInPaintBox toValue: aBoolean 282499! ! 282500 282501 282502!Preferences class methodsFor: 'parameters' stamp: 'sw 2/24/1999 12:26'! 282503acceptAnnotationsFrom: aSystemWindow 282504 "This intricate extraction is based on the precise structure of the annotation-request window. Kindly avert your eyes." 282505 | aList | 282506 aList := aSystemWindow paneMorphs first firstSubmorph submorphs collect: 282507 [:m | m contents asSymbol]. 282508 self defaultAnnotationRequests: aList 282509 ! ! 282510 282511!Preferences class methodsFor: 'parameters' stamp: 'alain.plantec 5/30/2008 14:17'! 282512annotationEditingWindow 282513 "Answer a window affording editing of annotations" 282514 | aPanel ins outs current aMorph aWindow aButton info pair standardHeight standardWidth | 282515 standardHeight := 180. 282516 standardWidth := (2 sqrt reciprocal * standardHeight) rounded. 282517 aPanel := AlignmentMorph newRow extent: 2 * standardWidth @ standardHeight. 282518 ins := AlignmentMorph newColumn extent: standardWidth @ standardHeight. 282519 ins color: Color green muchLighter. 282520 ins enableDrop: true; 282521 beSticky. 282522 outs := AlignmentMorph newColumn extent: standardWidth @ standardHeight. 282523 outs color: Color red muchLighter. 282524 outs enableDrop: true; 282525 beSticky. 282526 aPanel addMorph: outs; 282527 addMorphFront: ins. 282528 outs position: ins position + (standardWidth @ 0). 282529 current := self defaultAnnotationRequests. 282530 info := self annotationInfo. 282531 current 282532 do: [:sym | 282533 pair := info 282534 detect: [:aPair | aPair first == sym]. 282535 aMorph := StringMorph new contents: pair first. 282536 aMorph setBalloonText: pair last. 282537 aMorph enableDrag: true. 282538 aMorph 282539 on: #startDrag 282540 send: #startDrag:with: 282541 to: aMorph. 282542 ins addMorphBack: aMorph]. 282543 info 282544 do: [:aPair | (current includes: aPair first) 282545 ifFalse: [aMorph := StringMorph new contents: aPair first. 282546 aMorph setBalloonText: aPair last. 282547 aMorph enableDrag: true. 282548 aMorph 282549 on: #startDrag 282550 send: #startDrag:with: 282551 to: aMorph. 282552 outs addMorph: aMorph]]. 282553 aPanel layoutChanged. 282554 aWindow := SystemWindowWithButton new setLabel: 'Annotations'. 282555 aButton := SimpleButtonMorph new target: Preferences; 282556 actionSelector: #acceptAnnotationsFrom:; 282557 282558 arguments: (Array with: aWindow); 282559 label: 'apply'; 282560 borderWidth: 0; 282561 borderColor: Color transparent; 282562 color: Color transparent. 282563 aButton submorphs first color: Color blue. 282564 aButton setBalloonText: 'After moving all the annotations you want to the left (green) side, and all the ones you do NOT want to the right (pink) side, hit this "apply" button to have your choices take effect.'. 282565 aWindow buttonInTitle: aButton; 282566 adjustExtraButton. 282567 ^ aPanel wrappedInWindow: aWindow"Preferences annotationEditingWindow openInHand"! ! 282568 282569!Preferences class methodsFor: 'parameters' stamp: 'sw 7/12/2001 18:18'! 282570annotationInfo 282571 "Answer a list of pairs characterizing all the available kinds of annotations; in each pair, the first element is a symbol representing the info type, and the second element is a string providing the corresponding balloon help" 282572 282573 ^ #( 282574 282575 (timeStamp 'The time stamp of the last submission of the method.') 282576 (firstComment 'The first comment in the method, if any.') 282577 (masterComment 'The comment at the beginning of the supermost implementor of the method if any.') 282578 (documentation 'Comment at beginning of the method or, if it has none, comment at the beginning of a superclass''s implementation of the method') 282579 (messageCategory 'Which method category the method lies in') 282580 (sendersCount 'A report of how many senders there of the message.') 282581 (implementorsCount 'A report of how many implementors there are of the message.') 282582 (recentChangeSet 'The most recent change set bearing the method.') 282583 (allChangeSets 'A list of all change sets bearing the method.') 282584 (priorVersionsCount 'A report of how many previous versions there are of the method' ) 282585 (priorTimeStamp 'The time stamp of the penultimate submission of the method, if any'))! ! 282586 282587!Preferences class methodsFor: 'parameters' stamp: 'sw 2/15/1999 19:44'! 282588borderColorWhenRunning 282589 ^ Color green! ! 282590 282591!Preferences class methodsFor: 'parameters' stamp: 'sw 2/17/1999 00:40'! 282592defaultAnnotationRequests 282593 ^ Parameters at: #MethodAnnotations ifAbsent: 282594 [self setDefaultAnnotationInfo] 282595 "Preferences annotationInfo"! ! 282596 282597!Preferences class methodsFor: 'parameters' stamp: 'sw 2/8/1999 10:14'! 282598defaultAnnotationRequests: newList 282599 ^ Parameters at: #MethodAnnotations put: newList! ! 282600 282601!Preferences class methodsFor: 'parameters' stamp: 'on 5/10/2008 15:10'! 282602defaultAuthorName 282603 "Answer the author name to be planted, by default, in a changeset-preamble template. You can hard-code this to hold your name, thus saving you time when writing the preambles of subsequent changesets" 282604 282605 ^ Author fullName! ! 282606 282607!Preferences class methodsFor: 'parameters' stamp: 'sw 2/1/2000 14:05'! 282608defaultPaintingExtent 282609 "Answer the preferred size for the onion-skin paint area when launching a new painting within a paste-up morph. Feel free to change the parameters to suit your configuration." 282610 282611 ^ 800 @ 600! ! 282612 282613!Preferences class methodsFor: 'parameters' stamp: 'jhm 10/15/97 17:31'! 282614desktopColor 282615 "Answer the desktop color. Initialize it if necessary." 282616 282617 DesktopColor == nil ifTrue: [DesktopColor := Color gray]. 282618 ^ DesktopColor 282619! ! 282620 282621!Preferences class methodsFor: 'parameters' stamp: 'jhm 10/15/97 17:31'! 282622desktopColor: aColor 282623 "Record a new desktop color preference." 282624 282625 DesktopColor := aColor. 282626! ! 282627 282628!Preferences class methodsFor: 'parameters' stamp: 'sw 6/13/2001 19:40'! 282629editAnnotations 282630 "Put up a window that allows the user to edit annotation specifications" 282631 282632 | aWindow | 282633 self currentWorld addMorphCentered: (aWindow := self annotationEditingWindow). 282634 aWindow activateAndForceLabelToShow 282635 282636 "Preferences editAnnotations" 282637 282638! ! 282639 282640!Preferences class methodsFor: 'parameters' stamp: 'sw 5/16/2003 00:27'! 282641expungeParameter: aKey 282642 "If Parameters holds an entry under the given key, remove the entry. No senders in the current system, but called from the postscript of the change-set that defines it, and potentially useful otherwise." 282643 282644 Parameters removeKey: aKey ifAbsent: []! ! 282645 282646!Preferences class methodsFor: 'parameters' stamp: 'sw 9/7/1999 12:45'! 282647initializeParameters 282648 "Preferences initializeParameters" 282649 Parameters := IdentityDictionary new. 282650 self restoreDefaultMenuParameters. 282651 Parameters at: #maxBalloonHelpLineLength put: 28. 282652 self initializeTextHighlightingParameters! ! 282653 282654!Preferences class methodsFor: 'parameters' stamp: 'sw 1/24/2001 21:44'! 282655inspectParameters 282656 "Open up an inspector on the Parameters of Preferences. This is crude!!" 282657 282658 Parameters inspectWithLabel: 'Parameters'! ! 282659 282660!Preferences class methodsFor: 'parameters' stamp: 'sw 11/5/1998 16:49'! 282661maxBalloonHelpLineLength 282662 ^ Parameters at: #maxBalloonHelpLineLength! ! 282663 282664!Preferences class methodsFor: 'parameters' stamp: 'sw 1/27/2000 23:02'! 282665parameterAt: aKey 282666 ^ Parameters at: aKey ifAbsent: [nil]! ! 282667 282668!Preferences class methodsFor: 'parameters' stamp: 'sw 9/28/2001 08:52'! 282669parameterAt: aKey default: defaultValueBlock 282670 "Deprecated interface; no surviving senders in the released image, but clients probably still use" 282671 282672 ^ self parameterAt: aKey ifAbsentPut: defaultValueBlock! ! 282673 282674!Preferences class methodsFor: 'parameters' stamp: 'sw 9/28/2001 08:40'! 282675parameterAt: aKey ifAbsentPut: defaultValueBlock 282676 "Return the Parameter setting at the given key. If there is no entry for this key in the Parameters dictionary, create one with the value of defaultValueBlock as its value" 282677 282678 ^ Parameters at: aKey ifAbsentPut: defaultValueBlock! ! 282679 282680!Preferences class methodsFor: 'parameters' stamp: 'sw 2/7/2001 14:37'! 282681parameterAt: aKey ifAbsent: aBlock 282682 "Answer the parameter saved at the given key; if there is no such key in the Parameters dictionary, evaluate aBlock" 282683 282684 ^ Parameters at: aKey ifAbsent: [aBlock value]! ! 282685 282686!Preferences class methodsFor: 'parameters'! 282687scrollBarColor 282688 "Answer the preferred color for scroll bar elevators." 282689 282690 ^ Color gray! ! 282691 282692!Preferences class methodsFor: 'parameters'! 282693scrollBarWidth 282694 "Answer the preferred width for scroll bars." 282695 282696 ^ 8! ! 282697 282698!Preferences class methodsFor: 'parameters' stamp: 'sw 2/17/1999 00:41'! 282699setDefaultAnnotationInfo 282700 "Preferences setDefaultAnnotationInfo" 282701 ^ Parameters at: #MethodAnnotations put: #(timeStamp messageCategory implementorsCount allChangeSets)! ! 282702 282703!Preferences class methodsFor: 'parameters' stamp: 'stp 01/13/2000 13:29'! 282704setParameter: paramName to: paramValue 282705 "Set the given field in the parameters dictionary." 282706 282707 Parameters at: paramName put: paramValue! ! 282708 282709 282710!Preferences class methodsFor: 'personalization' stamp: 'NS 1/28/2004 14:43'! 282711compileHardCodedPref: prefName enable: aBoolean 282712 "Compile a method that returns a simple true or false (depending on the value of aBoolean) when Preferences is sent prefName as a message" 282713 282714 self class compileSilently: (prefName asString, ' 282715 "compiled programatically -- return hard-coded preference value" 282716 ^ ', aBoolean storeString) classified: 'hard-coded prefs'. 282717 282718"Preferences compileHardCodedPref: #testing enable: false"! ! 282719 282720!Preferences class methodsFor: 'personalization' stamp: 'marcus.denker 11/10/2008 10:04'! 282721loadPreferencesFrom: aFileName 282722 | stream params dict desktopColor | 282723 stream := ReferenceStream fileNamed: aFileName. 282724 params := stream next. 282725 self assert: (params isKindOf: IdentityDictionary). 282726 params removeKey: #PersonalDictionaryOfPreferences. 282727 dict := stream next. 282728 self assert: (dict isKindOf: IdentityDictionary). 282729 desktopColor := stream next. 282730 stream close. 282731 dict keysAndValuesDo: 282732 [:key :value | (self preferenceAt: key ifAbsent: [nil]) ifNotNil: 282733 [:pref | pref preferenceValue: value preferenceValue]]. 282734 282735 params keysAndValuesDo: [ :key :value | self setParameter: key to: value ]. 282736 282737 World fillStyle: desktopColor ! ! 282738 282739!Preferences class methodsFor: 'personalization' stamp: 'marcus.denker 11/10/2008 10:04'! 282740restorePersonalPreferences 282741 "Restore all the user's saved personal preference settings" 282742 282743 | savedPrefs | 282744 savedPrefs := self parameterAt: #PersonalDictionaryOfPreferences ifAbsent: [^ self inform: 'There are no personal preferences saved in this image yet']. 282745 282746 savedPrefs associationsDo: 282747 [:assoc | (self preferenceAt: assoc key ifAbsent: [nil]) ifNotNil: 282748 [:pref | pref preferenceValue: assoc value preferenceValue]]! ! 282749 282750!Preferences class methodsFor: 'personalization' stamp: 'nk 11/17/2002 12:07'! 282751restorePreferencesFromDisk 282752 (FileDirectory default fileExists: 'my.prefs') 282753 ifTrue: [ Cursor wait showWhile: [ 282754 [ self loadPreferencesFrom: 'my.prefs' ] on: Error do: [ :ex | self inform: 'there was an error restoring the preferences' ] 282755 ] ] 282756 ifFalse: [ self inform: 'you haven''t saved your preferences yet!!' ]. 282757 ! ! 282758 282759!Preferences class methodsFor: 'personalization' stamp: 'rr 10/1/2005 15:14'! 282760savePersonalPreferences 282761 "Save the current list of Preference settings as the user's personal choices" 282762 282763 self setParameter:#PersonalDictionaryOfPreferences 282764 to:self dictionaryOfPreferences deepCopy! ! 282765 282766!Preferences class methodsFor: 'personalization' stamp: 'alain.plantec 5/30/2008 14:25'! 282767storePreferencesIn: aFileName 282768 | stream | 282769 #(#Prevailing #PersonalPreferences ) do:[:ea | Parameters removeKey:ea ifAbsent:[]]. 282770 stream := ReferenceStream fileNamed:aFileName. 282771 stream nextPut:Parameters. 282772 stream nextPut:self dictionaryOfPreferences. 282773 stream nextPut:World fillStyle. 282774 stream close! ! 282775 282776!Preferences class methodsFor: 'personalization' stamp: 'nk 11/17/2002 12:08'! 282777storePreferencesToDisk 282778 Cursor wait showWhile: [ 282779 [ self storePreferencesIn: 'my.prefs' ] on: Error do: [ :ex | self inform: 'there was an error storing your preferences to disk' ]]! ! 282780 282781 282782!Preferences class methodsFor: 'preference-object access' stamp: 'rr 10/1/2005 15:14'! 282783allPreferenceObjects 282784 "Answer a list of all the Preference objects registered in the system" 282785 282786 ^ self dictionaryOfPreferences values! ! 282787 282788!Preferences class methodsFor: 'preference-object access' stamp: 'rr 10/1/2005 15:14'! 282789preferenceAt: aSymbol 282790 "Answer the Preference object at the given symbol, or nil if not there" 282791 282792 ^ self dictionaryOfPreferences at:aSymbol ifAbsent:[nil]! ! 282793 282794!Preferences class methodsFor: 'preference-object access' stamp: 'rr 10/1/2005 15:14'! 282795preferenceAt: aSymbol ifAbsent: aBlock 282796 "Answer the Preference object at the given symbol, or the value of aBlock if not present" 282797 282798 ^ self dictionaryOfPreferences at:aSymbol ifAbsent:[aBlock value]! ! 282799 282800 282801!Preferences class methodsFor: 'preferences panel' stamp: 'rr 10/1/2005 15:14'! 282802categoryNames 282803 | aSet | 282804 aSet := Set new. 282805 self dictionaryOfPreferences do: 282806 [:aPreference | 282807 aSet addAll:(aPreference categoryList 282808 collect:[:aCategory | aCategory asSymbol])]. 282809 ^ aSet! ! 282810 282811!Preferences class methodsFor: 'preferences panel' stamp: 'rr 10/1/2005 15:14'! 282812preferenceObjectsInCategory: aCategorySymbol 282813 "Answer a list of Preference objects that reside in the given category, in alphabetical order" 282814 282815 ^ (self dictionaryOfPreferences 282816 select:[:aPreference | aPreference categoryList includes:aCategorySymbol]) 282817 asSortedCollection: 282818 [:pref1 :pref2 | 282819 pref1 viewRegistry viewOrder <pref2 viewRegistry viewOrder or: 282820 [pref1 viewRegistry viewOrder =pref2 viewRegistry viewOrder 282821 &(pref1 name <pref2 name)]]! ! 282822 282823 282824!Preferences class methodsFor: 'reacting to change' stamp: 'sw 6/12/2001 20:17'! 282825annotationPanesChanged 282826 "The setting of the annotationPanes preference changed; react. Formerly, we replaced prototypes in flaps but this is no longer necessary"! ! 282827 282828!Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/12/2001 01:32'! 282829infiniteUndoChanged 282830 "The infiniteUndo preference changed; react" 282831 282832 self infiniteUndo ifFalse: 282833 [CommandHistory resetAllHistory]! ! 282834 282835!Preferences class methodsFor: 'reacting to change' stamp: 'mir 9/12/2001 15:15'! 282836mouseOverHalosChanged 282837 World wantsMouseOverHalos: self mouseOverHalos! ! 282838 282839!Preferences class methodsFor: 'reacting to change' stamp: 'sw 6/12/2001 20:18'! 282840optionalButtonsChanged 282841 "The setting of the optionalButtons preference changed; react. Formerly, we replaced prototypes in flaps but this is no longer necessary" 282842! ! 282843 282844!Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/12/2001 01:11'! 282845roundedWindowCornersChanged 282846 "The user changed the value of the roundedWindowCorners preference. React" 282847 282848 ActiveWorld fullRepaintNeeded! ! 282849 282850!Preferences class methodsFor: 'reacting to change' stamp: 'marcus.denker 11/26/2008 14:14'! 282851setNotificationParametersForStandardPreferences 282852 "Set up the notification parameters for the standard preferences that require need them. When adding new Preferences that require use of the notification mechanism, users declare the notifcation info as part of the call that adds the preference, or afterwards -- the two relevant methods for doing that are: 282853 Preferences.addPreference:categories:default:balloonHelp:projectLocal:changeInformee:changeSelector: and 282854 Preference changeInformee:changeSelector:" 282855 282856 "Preferences setNotificationParametersForStandardPreferences" 282857 282858 | aPreference | 282859 #( 282860 (annotationPanes annotationPanesChanged) 282861 (infiniteUndo infiniteUndoChanged) 282862 (optionalButtons optionalButtonsChanged) 282863 (roundedWindowCorners roundedWindowCornersChanged) 282864 (smartUpdating smartUpdatingChanged) 282865 (showSharedFlaps sharedFlapsSettingChanged) 282866 ) do: 282867 282868 [:pair | 282869 aPreference := self preferenceAt: pair first. 282870 aPreference changeInformee: self changeSelector: pair second]! ! 282871 282872!Preferences class methodsFor: 'reacting to change' stamp: 'alain.plantec 5/30/2008 14:24'! 282873sharedFlapsSettingChanged 282874 "The current value of the showSharedFlaps flag has changed; now react" 282875 self showSharedFlaps 282876 ifTrue: [self currentWorld addGlobalFlaps] 282877 ifFalse: ["viz. the new setting" 282878 Flaps globalFlapTabsIfAny 282879 do: [:aFlapTab | Flaps removeFlapTab: aFlapTab keepInList: true]]! ! 282880 282881!Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/12/2001 01:30'! 282882smartUpdatingChanged 282883 "The smartUpdating preference changed. React" 282884 282885 SystemWindow allSubInstancesDo: 282886 [:aWindow | aWindow amendSteppingStatus] 282887 282888 "NOTE: This makes this preference always behave like a global preference, which is problematical"! ! 282889 282890 282891!Preferences class methodsFor: 'scrollbar parameters' stamp: 'dgd 3/25/2003 19:58'! 282892fontFactor 282893 "answer the convertion factor for resizing element based on font 282894 size" 282895 | factor | 282896 factor := TextStyle defaultFont height / 12.0. 282897 ^ factor > 1.0 282898 ifTrue: [1 + (factor - 1.0 * 0.5)] 282899 ifFalse: [factor]! ! 282900 282901 282902!Preferences class methodsFor: 'standard queries'! 282903DPConflict 282904 ^ self 282905 valueOfFlag: #DPConflict 282906 ifAbsent: [true]! ! 282907 282908!Preferences class methodsFor: 'standard queries'! 282909DPDebugging 282910 ^ self 282911 valueOfFlag: #DPDebugging 282912 ifAbsent: [true]! ! 282913 282914!Preferences class methodsFor: 'standard queries'! 282915DPDuplicated 282916 ^ self 282917 valueOfFlag: #DPDuplicated 282918 ifAbsent: [true]! ! 282919 282920!Preferences class methodsFor: 'standard queries'! 282921DPLocal 282922 ^ self 282923 valueOfFlag: #DPLocal 282924 ifAbsent: [true]! ! 282925 282926!Preferences class methodsFor: 'standard queries'! 282927DPLong 282928 ^ self 282929 valueOfFlag: #DPLong 282930 ifAbsent: [true]! ! 282931 282932!Preferences class methodsFor: 'standard queries'! 282933DPOverride 282934 ^ self 282935 valueOfFlag: #DPOverride 282936 ifAbsent: [true]! ! 282937 282938!Preferences class methodsFor: 'standard queries'! 282939DPRecentlyModified 282940 ^ self 282941 valueOfFlag: #DPRecentlyModified 282942 ifAbsent: [true]! ! 282943 282944!Preferences class methodsFor: 'standard queries'! 282945DPRequired 282946 ^ self 282947 valueOfFlag: #DPRequired 282948 ifAbsent: [true]! ! 282949 282950!Preferences class methodsFor: 'standard queries'! 282951DPSuperSend 282952 ^ self 282953 valueOfFlag: #DPSuperSend 282954 ifAbsent: [true]! ! 282955 282956!Preferences class methodsFor: 'standard queries'! 282957DPSupplied 282958 ^ self 282959 valueOfFlag: #DPSupplied 282960 ifAbsent: [true]! ! 282961 282962!Preferences class methodsFor: 'standard queries'! 282963DPUncommented 282964 ^ self 282965 valueOfFlag: #DPUncommented 282966 ifAbsent: [true]! ! 282967 282968!Preferences class methodsFor: 'standard queries'! 282969FreeTypeCacheSize 282970 ^ self 282971 valueOfFlag: #FreeTypeCacheSize 282972 ifAbsent: [5000]! ! 282973 282974!Preferences class methodsFor: 'standard queries'! 282975GlyphContrast 282976 ^ self 282977 valueOfFlag: #GlyphContrast 282978 ifAbsent: [50]! ! 282979 282980!Preferences class methodsFor: 'standard queries'! 282981HintingFull 282982 ^ self 282983 valueOfFlag: #HintingFull 282984 ifAbsent: [false]! ! 282985 282986!Preferences class methodsFor: 'standard queries'! 282987HintingLight 282988 ^ self 282989 valueOfFlag: #HintingLight 282990 ifAbsent: [true]! ! 282991 282992!Preferences class methodsFor: 'standard queries'! 282993HintingNone 282994 ^ self 282995 valueOfFlag: #HintingNone 282996 ifAbsent: [false]! ! 282997 282998!Preferences class methodsFor: 'standard queries'! 282999HintingNormal 283000 ^ self 283001 valueOfFlag: #HintingNormal 283002 ifAbsent: [false]! ! 283003 283004!Preferences class methodsFor: 'standard queries'! 283005MonitorTypeCRT 283006 ^ self 283007 valueOfFlag: #MonitorTypeCRT 283008 ifAbsent: [false]! ! 283009 283010!Preferences class methodsFor: 'standard queries'! 283011MonitorTypeLCD 283012 ^ self 283013 valueOfFlag: #MonitorTypeLCD 283014 ifAbsent: [true]! ! 283015 283016!Preferences class methodsFor: 'standard queries' stamp: 'adrian-lienhard 6/4/2009 21:29'! 283017UpdateFontsAtImageStartup 283018 ^ self 283019 valueOfFlag: #UpdateFontsAtImageStartup 283020 ifAbsent: [false]! ! 283021 283022!Preferences class methodsFor: 'standard queries'! 283023allowBlockArgumentAssignment 283024 ^ self 283025 valueOfFlag: #allowBlockArgumentAssignment 283026 ifAbsent: [false]! ! 283027 283028!Preferences class methodsFor: 'standard queries'! 283029allowUnderscoreAssignment 283030 ^ self 283031 valueOfFlag: #allowUnderscoreAssignment 283032 ifAbsent: [false]! ! 283033 283034!Preferences class methodsFor: 'standard queries'! 283035allwaysShowVScrollBar 283036 ^ self 283037 valueOfFlag: #allwaysShowVScrollBar 283038 ifAbsent: [false]! ! 283039 283040!Preferences class methodsFor: 'standard queries'! 283041alternateHandlesLook 283042 ^ self 283043 valueOfFlag: #alternateHandlesLook 283044 ifAbsent: [true]! ! 283045 283046!Preferences class methodsFor: 'standard queries'! 283047alternativeButtonsInScrollBars 283048 ^ self 283049 valueOfFlag: #alternativeButtonsInScrollBars 283050 ifAbsent: [false]! ! 283051 283052!Preferences class methodsFor: 'standard queries'! 283053alwaysHideHScrollbar 283054 ^ self 283055 valueOfFlag: #alwaysHideHScrollbar 283056 ifAbsent: [false]! ! 283057 283058!Preferences class methodsFor: 'standard queries'! 283059alwaysShowConnectionVocabulary 283060 ^ self 283061 valueOfFlag: #alwaysShowConnectionVocabulary 283062 ifAbsent: [false]! ! 283063 283064!Preferences class methodsFor: 'standard queries'! 283065alwaysShowHScrollbar 283066 ^ self 283067 valueOfFlag: #alwaysShowHScrollbar 283068 ifAbsent: [false]! ! 283069 283070!Preferences class methodsFor: 'standard queries'! 283071alwaysShowVScrollbar 283072 ^ self 283073 valueOfFlag: #alwaysShowVScrollbar 283074 ifAbsent: [true]! ! 283075 283076!Preferences class methodsFor: 'standard queries'! 283077annotationPanes 283078 ^ self 283079 valueOfFlag: #annotationPanes 283080 ifAbsent: [false]! ! 283081 283082!Preferences class methodsFor: 'standard queries'! 283083areaFillsAreTolerant 283084 ^ self 283085 valueOfFlag: #areaFillsAreTolerant 283086 ifAbsent: [false]! ! 283087 283088!Preferences class methodsFor: 'standard queries'! 283089areaFillsAreVeryTolerant 283090 ^ self 283091 valueOfFlag: #areaFillsAreVeryTolerant 283092 ifAbsent: [false]! ! 283093 283094!Preferences class methodsFor: 'standard queries'! 283095autoFocusForColumns 283096 ^ self 283097 valueOfFlag: #autoFocusForColumns 283098 ifAbsent: [true]! ! 283099 283100!Preferences class methodsFor: 'standard queries'! 283101autoIndent 283102 ^ self 283103 valueOfFlag: #autoIndent 283104 ifAbsent: [true]! ! 283105 283106!Preferences class methodsFor: 'standard queries'! 283107automaticFlapLayout 283108 ^ self 283109 valueOfFlag: #automaticFlapLayout 283110 ifAbsent: [true]! ! 283111 283112!Preferences class methodsFor: 'standard queries'! 283113automaticKeyGeneration 283114 ^ self 283115 valueOfFlag: #automaticKeyGeneration 283116 ifAbsent: [false]! ! 283117 283118!Preferences class methodsFor: 'standard queries'! 283119automaticPlatformSettings 283120 ^ self 283121 valueOfFlag: #automaticPlatformSettings 283122 ifAbsent: [true]! ! 283123 283124!Preferences class methodsFor: 'standard queries'! 283125balloonHelpEnabled 283126 ^ self 283127 valueOfFlag: #balloonHelpEnabled 283128 ifAbsent: [true]! ! 283129 283130!Preferences class methodsFor: 'standard queries'! 283131beDynamic 283132 ^ self 283133 valueOfFlag: #beDynamic 283134 ifAbsent: [false]! ! 283135 283136!Preferences class methodsFor: 'standard queries'! 283137bigDisplay 283138 ^ self 283139 valueOfFlag: #bigDisplay 283140 ifAbsent: [false]! ! 283141 283142!Preferences class methodsFor: 'standard queries'! 283143biggerHandles 283144 ^ self 283145 valueOfFlag: #biggerHandles 283146 ifAbsent: [true]! ! 283147 283148!Preferences class methodsFor: 'standard queries'! 283149browserWindowColor 283150 ^ self 283151 valueOfFlag: #browserWindowColor 283152 ifAbsent: [Color 283153 r: 0.8 283154 g: 1.0 283155 b: 0.6]! ! 283156 283157!Preferences class methodsFor: 'standard queries'! 283158browseWithPrettyPrint 283159 ^ self 283160 valueOfFlag: #browseWithPrettyPrint 283161 ifAbsent: [false]! ! 283162 283163!Preferences class methodsFor: 'standard queries'! 283164Curvier 283165 ^ self 283166 valueOfFlag: #Curvier 283167 ifAbsent: [true]! ! 283168 283169!Preferences class methodsFor: 'standard queries'! 283170canRecordWhilePlaying 283171 ^ self 283172 valueOfFlag: #canRecordWhilePlaying 283173 ifAbsent: [false]! ! 283174 283175!Preferences class methodsFor: 'standard queries'! 283176caseSensitiveFinds 283177 ^ self 283178 valueOfFlag: #caseSensitiveFinds 283179 ifAbsent: [false]! ! 283180 283181!Preferences class methodsFor: 'standard queries'! 283182cautionBeforeClosing 283183 ^ self 283184 valueOfFlag: #cautionBeforeClosing 283185 ifAbsent: [false]! ! 283186 283187!Preferences class methodsFor: 'standard queries'! 283188changeListWindowColor 283189 ^ self 283190 valueOfFlag: #changeListWindowColor 283191 ifAbsent: [Color 283192 r: 0.8 283193 g: 1.0 283194 b: 1.0]! ! 283195 283196!Preferences class methodsFor: 'standard queries'! 283197changeSorterWindowColor 283198 ^ self 283199 valueOfFlag: #changeSorterWindowColor 283200 ifAbsent: [Color 283201 r: 0.8 283202 g: 1.0 283203 b: 1.0]! ! 283204 283205!Preferences class methodsFor: 'standard queries'! 283206chasingBrowsers 283207 ^ self 283208 valueOfFlag: #chasingBrowsers 283209 ifAbsent: [true]! ! 283210 283211!Preferences class methodsFor: 'standard queries'! 283212checkForSlips 283213 ^ self 283214 valueOfFlag: #checkForSlips 283215 ifAbsent: [true]! ! 283216 283217!Preferences class methodsFor: 'standard queries'! 283218checkForUnsavedProjects 283219 ^ self 283220 valueOfFlag: #checkForUnsavedProjects 283221 ifAbsent: [true]! ! 283222 283223!Preferences class methodsFor: 'standard queries'! 283224classCommentOnClassSelect 283225 ^ self 283226 valueOfFlag: #classCommentOnClassSelect 283227 ifAbsent: [false]! ! 283228 283229!Preferences class methodsFor: 'standard queries'! 283230classCommentVersionsBrowserWindowColor 283231 ^ self 283232 valueOfFlag: #classCommentVersionsBrowserWindowColor 283233 ifAbsent: [Color 283234 r: 0.769 283235 g: 0.653 283236 b: 1.0]! ! 283237 283238!Preferences class methodsFor: 'standard queries'! 283239cmdDotEnabled 283240 ^ self 283241 valueOfFlag: #cmdDotEnabled 283242 ifAbsent: [true]! ! 283243 283244!Preferences class methodsFor: 'standard queries' stamp: 'programmatic 7/15/1999 09:55'! 283245cmdGesturesEnabled 283246 "compiled programatically -- return hard-coded preference value" 283247 ^ true! ! 283248 283249!Preferences class methodsFor: 'standard queries'! 283250conversionMethodsAtFileOut 283251 ^ self 283252 valueOfFlag: #conversionMethodsAtFileOut 283253 ifAbsent: [false 283254 "Form literalScannedAs: 14 notifying: nil 14 283255 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm 283256 Form literalScannedAs: ##OneBitForm notifying: nil 283257 OneBitForm->a Form 283258 Form literalScannedAs: ##Form notifying: nil Form->Form 283259 Form literalScannedAs: ###Form notifying: nil nilE->Form clas 283260 "]! ! 283261 283262!Preferences class methodsFor: 'standard queries'! 283263cpuWatcherEnabled 283264 ^ self 283265 valueOfFlag: #cpuWatcherEnabled 283266 ifAbsent: [false]! ! 283267 283268!Preferences class methodsFor: 'standard queries'! 283269debuggerWindowColor 283270 ^ self 283271 valueOfFlag: #debuggerWindowColor 283272 ifAbsent: [Color 283273 r: 1.0 283274 g: 0.8 283275 b: 0.8]! ! 283276 283277!Preferences class methodsFor: 'standard queries'! 283278debugHaloHandle 283279 ^ self 283280 valueOfFlag: #debugHaloHandle 283281 ifAbsent: [true]! ! 283282 283283!Preferences class methodsFor: 'standard queries' stamp: 'mir 3/5/2004 19:22'! 283284debugLogTimestamp 283285 ^ self 283286 valueOfFlag: #debugLogTimestamp 283287 ifAbsent: [false]! ! 283288 283289!Preferences class methodsFor: 'standard queries'! 283290debugPrintSpaceLog 283291 ^ self 283292 valueOfFlag: #debugPrintSpaceLog 283293 ifAbsent: [false]! ! 283294 283295!Preferences class methodsFor: 'standard queries'! 283296debugShowDamage 283297 ^ self 283298 valueOfFlag: #debugShowDamage 283299 ifAbsent: [false]! ! 283300 283301!Preferences class methodsFor: 'standard queries'! 283302decorateBrowserButtons 283303 ^ self 283304 valueOfFlag: #decorateBrowserButtons 283305 ifAbsent: [false]! ! 283306 283307!Preferences class methodsFor: 'standard queries'! 283308defaultWindowColor 283309 ^ self 283310 valueOfFlag: #defaultWindowColor 283311 ifAbsent: [Color 283312 r: 1.0 283313 g: 1.0 283314 b: 1.0]! ! 283315 283316!Preferences class methodsFor: 'standard queries'! 283317diffsInChangeList 283318 ^ self 283319 valueOfFlag: #diffsInChangeList 283320 ifAbsent: [true]! ! 283321 283322!Preferences class methodsFor: 'standard queries'! 283323diffsWithPrettyPrint 283324 ^ self 283325 valueOfFlag: #diffsWithPrettyPrint 283326 ifAbsent: [false]! ! 283327 283328!Preferences class methodsFor: 'standard queries'! 283329dismissAllOnOptionClose 283330 ^ self 283331 valueOfFlag: #dismissAllOnOptionClose 283332 ifAbsent: [false]! ! 283333 283334!Preferences class methodsFor: 'standard queries'! 283335dualChangeSorterWindowColor 283336 ^ self 283337 valueOfFlag: #dualChangeSorterWindowColor 283338 ifAbsent: [Color 283339 r: 0.8 283340 g: 1.0 283341 b: 1.0]! ! 283342 283343!Preferences class methodsFor: 'standard queries'! 283344duplicateAllControlAndAltKeys 283345 ^ self 283346 valueOfFlag: #duplicateAllControlAndAltKeys 283347 ifAbsent: [true]! ! 283348 283349!Preferences class methodsFor: 'standard queries'! 283350duplicateControlAndAltKeys 283351 ^ self 283352 valueOfFlag: #duplicateControlAndAltKeys 283353 ifAbsent: [false]! ! 283354 283355!Preferences class methodsFor: 'standard queries'! 283356dynamicProtocolActivation 283357 ^ self 283358 valueOfFlag: #dynamicProtocolActivation 283359 ifAbsent: [true]! ! 283360 283361!Preferences class methodsFor: 'standard queries'! 283362easySelection 283363 ^ self 283364 valueOfFlag: #easySelection 283365 ifAbsent: [false]! ! 283366 283367!Preferences class methodsFor: 'standard queries'! 283368ecompletionCaseSensitive 283369 ^ self 283370 valueOfFlag: #ecompletionCaseSensitive 283371 ifAbsent: [true]! ! 283372 283373!Preferences class methodsFor: 'standard queries'! 283374ecompletionEnabled 283375 ^ self 283376 valueOfFlag: #ecompletionEnabled 283377 ifAbsent: [true]! ! 283378 283379!Preferences class methodsFor: 'standard queries'! 283380ecompletionSmartCharacters 283381 ^ self 283382 valueOfFlag: #ecompletionSmartCharacters 283383 ifAbsent: [true]! ! 283384 283385!Preferences class methodsFor: 'standard queries'! 283386editableStringMorphs 283387 ^ self 283388 valueOfFlag: #editableStringMorphs 283389 ifAbsent: [false]! ! 283390 283391!Preferences class methodsFor: 'standard queries'! 283392enableLocalSave 283393 ^ self 283394 valueOfFlag: #enableLocalSave 283395 ifAbsent: [true]! ! 283396 283397!Preferences class methodsFor: 'standard queries'! 283398expandedPublishing 283399 ^ self 283400 valueOfFlag: #expandedPublishing 283401 ifAbsent: [true]! ! 283402 283403!Preferences class methodsFor: 'standard queries'! 283404externalFocusForPluggableText 283405 ^ self 283406 valueOfFlag: #externalFocusForPluggableText 283407 ifAbsent: [true]! ! 283408 283409!Preferences class methodsFor: 'standard queries'! 283410extraDebuggerButtons 283411 ^ self 283412 valueOfFlag: #extraDebuggerButtons 283413 ifAbsent: [false]! ! 283414 283415!Preferences class methodsFor: 'standard queries'! 283416fadedBackgroundWindows 283417 ^ self 283418 valueOfFlag: #fadedBackgroundWindows 283419 ifAbsent: [true]! ! 283420 283421!Preferences class methodsFor: 'standard queries'! 283422fastDragWindowForMorphic 283423 ^ self 283424 valueOfFlag: #fastDragWindowForMorphic 283425 ifAbsent: [true]! ! 283426 283427!Preferences class methodsFor: 'standard queries'! 283428fenceSoundEnabled 283429 ^ self 283430 valueOfFlag: #fenceSoundEnabled 283431 ifAbsent: [true]! ! 283432 283433!Preferences class methodsFor: 'standard queries' stamp: 'mir 6/7/2002 17:10'! 283434fenceSoundEnabled: aBoolean 283435 self setPreference: #fenceSoundEnabled toValue: aBoolean! ! 283436 283437!Preferences class methodsFor: 'standard queries'! 283438fileContentsBrowserWindowColor 283439 ^ self 283440 valueOfFlag: #fileContentsBrowserWindowColor 283441 ifAbsent: [Color 283442 r: 0.8 283443 g: 0.8 283444 b: 0.5]! ! 283445 283446!Preferences class methodsFor: 'standard queries'! 283447fileListWindowColor 283448 ^ self 283449 valueOfFlag: #fileListWindowColor 283450 ifAbsent: [Color 283451 r: 1.0 283452 g: 0.8 283453 b: 1.0]! ! 283454 283455!Preferences class methodsFor: 'standard queries'! 283456fullScreenLeavesDeskMargins 283457 ^ self 283458 valueOfFlag: #fullScreenLeavesDeskMargins 283459 ifAbsent: [true]! ! 283460 283461!Preferences class methodsFor: 'standard queries'! 283462generalizedYellowButtonMenu 283463 ^ self 283464 valueOfFlag: #generalizedYellowButtonMenu 283465 ifAbsent: [true]! ! 283466 283467!Preferences class methodsFor: 'standard queries'! 283468gradientButtonLook 283469 ^ self 283470 valueOfFlag: #gradientButtonLook 283471 ifAbsent: [true]! ! 283472 283473!Preferences class methodsFor: 'standard queries'! 283474gradientMenu 283475 ^ self 283476 valueOfFlag: #gradientMenu 283477 ifAbsent: [true]! ! 283478 283479!Preferences class methodsFor: 'standard queries'! 283480gradientScrollBars 283481 ^ self 283482 valueOfFlag: #gradientScrollBars 283483 ifAbsent: [true]! ! 283484 283485!Preferences class methodsFor: 'standard queries'! 283486gradientScrollbarLook 283487 ^ self 283488 valueOfFlag: #gradientScrollbarLook 283489 ifAbsent: [true]! ! 283490 283491!Preferences class methodsFor: 'standard queries'! 283492haloEnclosesFullBounds 283493 ^ self 283494 valueOfFlag: #haloEnclosesFullBounds 283495 ifAbsent: [false]! ! 283496 283497!Preferences class methodsFor: 'standard queries'! 283498haloTransitions 283499 ^ self 283500 valueOfFlag: #haloTransitions 283501 ifAbsent: [false]! ! 283502 283503!Preferences class methodsFor: 'standard queries'! 283504hierarchyBrowserIsRB 283505 ^ self 283506 valueOfFlag: #hierarchyBrowserIsRB 283507 ifAbsent: [true]! ! 283508 283509!Preferences class methodsFor: 'standard queries'! 283510higherPerformance 283511 ^ self 283512 valueOfFlag: #higherPerformance 283513 ifAbsent: [false]! ! 283514 283515!Preferences class methodsFor: 'standard queries'! 283516honorDesktopCmdKeys 283517 ^ self 283518 valueOfFlag: #honorDesktopCmdKeys 283519 ifAbsent: [true]! ! 283520 283521!Preferences class methodsFor: 'standard queries'! 283522httpProxyPort 283523 ^ self 283524 valueOfFlag: #httpProxyPort 283525 ifAbsent: [80]! ! 283526 283527!Preferences class methodsFor: 'standard queries'! 283528httpProxyServer 283529 ^ self 283530 valueOfFlag: #httpProxyServer 283531 ifAbsent: ['']! ! 283532 283533!Preferences class methodsFor: 'standard queries'! 283534includeSoundControlInNavigator 283535 ^ self 283536 valueOfFlag: #includeSoundControlInNavigator 283537 ifAbsent: [false]! ! 283538 283539!Preferences class methodsFor: 'standard queries'! 283540infiniteUndo 283541 ^ self 283542 valueOfFlag: #infiniteUndo 283543 ifAbsent: [false]! ! 283544 283545!Preferences class methodsFor: 'standard queries'! 283546inlineServicesInMenu 283547 ^ self 283548 valueOfFlag: #inlineServicesInMenu 283549 ifAbsent: [true]! ! 283550 283551!Preferences class methodsFor: 'standard queries'! 283552instanceBrowserWindowColor 283553 ^ self 283554 valueOfFlag: #instanceBrowserWindowColor 283555 ifAbsent: [Color 283556 r: 0.806 283557 g: 1.0 283558 b: 1.0]! ! 283559 283560!Preferences class methodsFor: 'standard queries'! 283561keepTasklistOpen 283562 ^ self 283563 valueOfFlag: #keepTasklistOpen 283564 ifAbsent: [false]! ! 283565 283566!Preferences class methodsFor: 'standard queries'! 283567lexiconWindowColor 283568 ^ self 283569 valueOfFlag: #lexiconWindowColor 283570 ifAbsent: [Color 283571 r: 0.878 283572 g: 1.0 283573 b: 0.878]! ! 283574 283575!Preferences class methodsFor: 'standard queries'! 283576logDebuggerStackToFile 283577 ^ self 283578 valueOfFlag: #logDebuggerStackToFile 283579 ifAbsent: [true]! ! 283580 283581!Preferences class methodsFor: 'standard queries'! 283582magicHalos 283583 ^ self 283584 valueOfFlag: #magicHalos 283585 ifAbsent: [false 283586 "Form literalScannedAs: 14 notifying: nil 14 283587 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm 283588 Form literalScannedAs: ##OneBitForm notifying: nil 283589 OneBitForm->a Form 283590 Form literalScannedAs: ##Form notifying: nil Form->Form 283591 Form literalScannedAs: ###Form notifying: nil nilE->Form clas 283592 "]! ! 283593 283594!Preferences class methodsFor: 'standard queries'! 283595maintainHalos 283596 ^ self 283597 valueOfFlag: #maintainHalos 283598 ifAbsent: [true]! ! 283599 283600!Preferences class methodsFor: 'standard queries'! 283601menuAppearance3d 283602 ^ self 283603 valueOfFlag: #menuAppearance3d 283604 ifAbsent: [true]! ! 283605 283606!Preferences class methodsFor: 'standard queries'! 283607menuButtonInToolPane 283608 ^ self 283609 valueOfFlag: #menuButtonInToolPane 283610 ifAbsent: [false]! ! 283611 283612!Preferences class methodsFor: 'standard queries'! 283613menuColorFromWorld 283614 ^ self 283615 valueOfFlag: #menuColorFromWorld 283616 ifAbsent: [true 283617 "success"]! ! 283618 283619!Preferences class methodsFor: 'standard queries'! 283620menuKeyboardControl 283621 ^ self 283622 valueOfFlag: #menuKeyboardControl 283623 ifAbsent: [true]! ! 283624 283625!Preferences class methodsFor: 'standard queries'! 283626menuWithIcons 283627 ^ self 283628 valueOfFlag: #menuWithIcons 283629 ifAbsent: [true]! ! 283630 283631!Preferences class methodsFor: 'standard queries' stamp: 'damiencassou 8/8/2009 20:14'! 283632mercuryPanel 283633 ^ self 283634 valueOfFlag: #mercuryPanel 283635 ifAbsent: [true].! ! 283636 283637!Preferences class methodsFor: 'standard queries'! 283638messageListWindowColor 283639 ^ self 283640 valueOfFlag: #messageListWindowColor 283641 ifAbsent: [Color 283642 r: 0.8 283643 g: 1.0 283644 b: 1.0]! ! 283645 283646!Preferences class methodsFor: 'standard queries'! 283647messageNamesWindowColor 283648 ^ self 283649 valueOfFlag: #messageNamesWindowColor 283650 ifAbsent: [Color 283651 r: 0.645 283652 g: 1.0 283653 b: 0.452]! ! 283654 283655!Preferences class methodsFor: 'standard queries'! 283656methodFinderWindowColor 283657 ^ self 283658 valueOfFlag: #methodFinderWindowColor 283659 ifAbsent: [Color 283660 r: 0.4 283661 g: 1.0 283662 b: 1.0]! ! 283663 283664!Preferences class methodsFor: 'standard queries'! 283665modalColorPickers 283666 ^ self 283667 valueOfFlag: #modalColorPickers 283668 ifAbsent: [true]! ! 283669 283670!Preferences class methodsFor: 'standard queries'! 283671mouseClickForKeyboardFocus 283672 ^ self 283673 valueOfFlag: #mouseClickForKeyboardFocus 283674 ifAbsent: [false]! ! 283675 283676!Preferences class methodsFor: 'standard queries'! 283677mouseOverForKeyboardFocus 283678 ^ self 283679 valueOfFlag: #mouseOverForKeyboardFocus 283680 ifAbsent: [false]! ! 283681 283682!Preferences class methodsFor: 'standard queries'! 283683mouseOverHalos 283684 ^ self 283685 valueOfFlag: #mouseOverHalos 283686 ifAbsent: [false]! ! 283687 283688!Preferences class methodsFor: 'standard queries'! 283689multipleTextUndo 283690 ^ self 283691 valueOfFlag: #multipleTextUndo 283692 ifAbsent: [false]! ! 283693 283694!Preferences class methodsFor: 'standard queries'! 283695noWindowAnimationForClosing 283696 ^ self 283697 valueOfFlag: #noWindowAnimationForClosing 283698 ifAbsent: [false]! ! 283699 283700!Preferences class methodsFor: 'standard queries'! 283701oliveHandleForScriptedObjects 283702 ^ self 283703 valueOfFlag: #oliveHandleForScriptedObjects 283704 ifAbsent: [true]! ! 283705 283706!Preferences class methodsFor: 'standard queries'! 283707optionalButtons 283708 ^ self 283709 valueOfFlag: #optionalButtons 283710 ifAbsent: [false]! ! 283711 283712!Preferences class methodsFor: 'standard queries'! 283713packageBrowserWindowColor 283714 ^ self 283715 valueOfFlag: #packageBrowserWindowColor 283716 ifAbsent: [Color 283717 r: 1.0 283718 g: 1.0 283719 b: 0.6]! ! 283720 283721!Preferences class methodsFor: 'standard queries'! 283722passwordsOnPublish 283723 ^ self 283724 valueOfFlag: #passwordsOnPublish 283725 ifAbsent: [false]! ! 283726 283727!Preferences class methodsFor: 'standard queries'! 283728postscriptStoredAsEPS 283729 ^ self 283730 valueOfFlag: #postscriptStoredAsEPS 283731 ifAbsent: [false]! ! 283732 283733!Preferences class methodsFor: 'standard queries'! 283734preferenceBrowserWindowColor 283735 ^ self 283736 valueOfFlag: #preferenceBrowserWindowColor 283737 ifAbsent: [Color 283738 r: 0.645 283739 g: 1.0 283740 b: 1.0]! ! 283741 283742!Preferences class methodsFor: 'standard queries'! 283743preferencesPanelWindowColor 283744 ^ self 283745 valueOfFlag: #preferencesPanelWindowColor 283746 ifAbsent: [Color 283747 r: 0.645 283748 g: 1.0 283749 b: 1.0]! ! 283750 283751!Preferences class methodsFor: 'standard queries'! 283752preserveTrash 283753 ^ self 283754 valueOfFlag: #preserveTrash 283755 ifAbsent: [false]! ! 283756 283757!Preferences class methodsFor: 'standard queries'! 283758projectsSentToDisk 283759 ^ self 283760 valueOfFlag: #projectsSentToDisk 283761 ifAbsent: [false]! ! 283762 283763!Preferences class methodsFor: 'standard queries'! 283764projectViewsInWindows 283765 ^ self 283766 valueOfFlag: #projectViewsInWindows 283767 ifAbsent: [true]! ! 283768 283769!Preferences class methodsFor: 'standard queries'! 283770projectZoom 283771 ^ self 283772 valueOfFlag: #projectZoom 283773 ifAbsent: [true]! ! 283774 283775!Preferences class methodsFor: 'standard queries'! 283776promptForUpdateServer 283777 ^ self 283778 valueOfFlag: #promptForUpdateServer 283779 ifAbsent: [true]! ! 283780 283781!Preferences class methodsFor: 'standard queries'! 283782promptOnRefactoring 283783 ^ self 283784 valueOfFlag: #promptOnRefactoring 283785 ifAbsent: [true]! ! 283786 283787!Preferences class methodsFor: 'standard queries'! 283788purgeUndoOnQuit 283789 ^ self 283790 valueOfFlag: #purgeUndoOnQuit 283791 ifAbsent: [true]! ! 283792 283793!Preferences class methodsFor: 'standard queries'! 283794raiseDeprecatedWarnings 283795 ^ self 283796 valueOfFlag: #raiseDeprecatedWarnings 283797 ifAbsent: [true]! ! 283798 283799!Preferences class methodsFor: 'standard queries'! 283800readDocumentAtStartup 283801 ^ self 283802 valueOfFlag: #readDocumentAtStartup 283803 ifAbsent: [true]! ! 283804 283805!Preferences class methodsFor: 'standard queries'! 283806readOnlyMode 283807 ^ self 283808 valueOfFlag: #readOnlyMode 283809 ifAbsent: [false]! ! 283810 283811!Preferences class methodsFor: 'standard queries'! 283812restartAlsoProceeds 283813 ^ self 283814 valueOfFlag: #restartAlsoProceeds 283815 ifAbsent: [true]! ! 283816 283817!Preferences class methodsFor: 'standard queries'! 283818reverseWindowStagger 283819 ^ self 283820 valueOfFlag: #reverseWindowStagger 283821 ifAbsent: [true]! ! 283822 283823!Preferences class methodsFor: 'standard queries'! 283824roundedMenuCorners 283825 ^ self 283826 valueOfFlag: #roundedMenuCorners 283827 ifAbsent: [true]! ! 283828 283829!Preferences class methodsFor: 'standard queries'! 283830roundedWindowCorners 283831 ^ self 283832 valueOfFlag: #roundedWindowCorners 283833 ifAbsent: [true]! ! 283834 283835!Preferences class methodsFor: 'standard queries'! 283836rulesAccessSelector 283837 ^ self 283838 valueOfFlag: #rulesAccessSelector 283839 ifAbsent: ['defaultCategorizationRules']! ! 283840 283841!Preferences class methodsFor: 'standard queries'! 283842rulesGlobalName 283843 ^ self 283844 valueOfFlag: #rulesGlobalName 283845 ifAbsent: ['AutomaticMethodCategorizer']! ! 283846 283847!Preferences class methodsFor: 'standard queries'! 283848scrollBarsNarrow 283849 ^ self 283850 valueOfFlag: #scrollBarsNarrow 283851 ifAbsent: [false]! ! 283852 283853!Preferences class methodsFor: 'standard queries'! 283854scrollBarsOnRight 283855 ^ self 283856 valueOfFlag: #scrollBarsOnRight 283857 ifAbsent: [false]! ! 283858 283859!Preferences class methodsFor: 'standard queries'! 283860scrollBarsWithoutMenuButton 283861 ^ self 283862 valueOfFlag: #scrollBarsWithoutMenuButton 283863 ifAbsent: [false]! ! 283864 283865!Preferences class methodsFor: 'standard queries'! 283866securityChecksEnabled 283867 ^ self 283868 valueOfFlag: #securityChecksEnabled 283869 ifAbsent: [false]! ! 283870 283871!Preferences class methodsFor: 'standard queries'! 283872selectiveHalos 283873 ^ self 283874 valueOfFlag: #selectiveHalos 283875 ifAbsent: [true]! ! 283876 283877!Preferences class methodsFor: 'standard queries'! 283878serverMode 283879 ^ self 283880 valueOfFlag: #serverMode 283881 ifAbsent: [true]! ! 283882 283883!Preferences class methodsFor: 'standard queries'! 283884showBoundsInHalo 283885 ^ self 283886 valueOfFlag: #showBoundsInHalo 283887 ifAbsent: [false 283888 "keep scanning"]! ! 283889 283890!Preferences class methodsFor: 'standard queries'! 283891showDeprecationWarnings 283892 ^ self 283893 valueOfFlag: #showDeprecationWarnings 283894 ifAbsent: [true]! ! 283895 283896!Preferences class methodsFor: 'standard queries'! 283897showDirectionForSketches 283898 ^ self 283899 valueOfFlag: #showDirectionForSketches 283900 ifAbsent: [false]! ! 283901 283902!Preferences class methodsFor: 'standard queries'! 283903showDirectionHandles 283904 ^ self 283905 valueOfFlag: #showDirectionHandles 283906 ifAbsent: [false]! ! 283907 283908!Preferences class methodsFor: 'standard queries'! 283909showFlapsWhenPublishing 283910 ^ self 283911 valueOfFlag: #showFlapsWhenPublishing 283912 ifAbsent: [false]! ! 283913 283914!Preferences class methodsFor: 'standard queries'! 283915showSecurityStatus 283916 ^ self 283917 valueOfFlag: #showSecurityStatus 283918 ifAbsent: [true]! ! 283919 283920!Preferences class methodsFor: 'standard queries'! 283921showSharedFlaps 283922 ^ self 283923 valueOfFlag: #showSharedFlaps 283924 ifAbsent: [true]! ! 283925 283926!Preferences class methodsFor: 'standard queries'! 283927showSplitterHandles 283928 ^ self 283929 valueOfFlag: #showSplitterHandles 283930 ifAbsent: [true]! ! 283931 283932!Preferences class methodsFor: 'standard queries'! 283933showTextEditingState 283934 ^ self 283935 valueOfFlag: #showTextEditingState 283936 ifAbsent: [false]! ! 283937 283938!Preferences class methodsFor: 'standard queries'! 283939showWorldMainDockingBar 283940 ^ self 283941 valueOfFlag: #showWorldMainDockingBar 283942 ifAbsent: [true]! ! 283943 283944!Preferences class methodsFor: 'standard queries'! 283945showWorldTaskbar 283946 ^ self 283947 valueOfFlag: #showWorldTaskbar 283948 ifAbsent: [true]! ! 283949 283950!Preferences class methodsFor: 'standard queries'! 283951signProjectFiles 283952 ^ self 283953 valueOfFlag: #signProjectFiles 283954 ifAbsent: [true]! ! 283955 283956!Preferences class methodsFor: 'standard queries'! 283957slideDismissalsToTrash 283958 ^ self 283959 valueOfFlag: #slideDismissalsToTrash 283960 ifAbsent: [true]! ! 283961 283962!Preferences class methodsFor: 'standard queries'! 283963smartUpdating 283964 ^ self 283965 valueOfFlag: #smartUpdating 283966 ifAbsent: [true]! ! 283967 283968!Preferences class methodsFor: 'standard queries'! 283969soundQuickStart 283970 ^ self 283971 valueOfFlag: #soundQuickStart 283972 ifAbsent: [false]! ! 283973 283974!Preferences class methodsFor: 'standard queries'! 283975soundStopWhenDone 283976 ^ self 283977 valueOfFlag: #soundStopWhenDone 283978 ifAbsent: [false]! ! 283979 283980!Preferences class methodsFor: 'standard queries'! 283981soundTheme 283982 ^ self 283983 valueOfFlag: #soundTheme 283984 ifAbsent: [SoundTheme]! ! 283985 283986!Preferences class methodsFor: 'standard queries'! 283987soundsEnabled 283988 ^ self 283989 valueOfFlag: #soundsEnabled 283990 ifAbsent: [true]! ! 283991 283992!Preferences class methodsFor: 'standard queries' stamp: 'mir 11/10/2003 14:28'! 283993standaloneSecurityChecksEnabled 283994 ^ self 283995 valueOfFlag: #standaloneSecurityChecksEnabled 283996 ifAbsent: [false]! ! 283997 283998!Preferences class methodsFor: 'standard queries'! 283999startInUntrustedDirectory 284000 ^ self 284001 valueOfFlag: #startInUntrustedDirectory 284002 ifAbsent: [false]! ! 284003 284004!Preferences class methodsFor: 'standard queries'! 284005swapControlAndAltKeys 284006 ^ self 284007 valueOfFlag: #swapControlAndAltKeys 284008 ifAbsent: [false]! ! 284009 284010!Preferences class methodsFor: 'standard queries' stamp: 'adrian-lienhard 5/22/2009 10:41'! 284011swapMouseButtons 284012 ^ self 284013 valueOfFlag: #swapMouseButtons 284014 ifAbsent: [ 284015 OSPlatform current platformFamily ~= #Windows ]! ! 284016 284017!Preferences class methodsFor: 'standard queries'! 284018syntaxHighlightingAsYouType 284019 ^ self 284020 valueOfFlag: #syntaxHighlightingAsYouType 284021 ifAbsent: [true]! ! 284022 284023!Preferences class methodsFor: 'standard queries'! 284024syntaxHighlightingAsYouTypeAnsiAssignment 284025 ^ self 284026 valueOfFlag: #syntaxHighlightingAsYouTypeAnsiAssignment 284027 ifAbsent: [false]! ! 284028 284029!Preferences class methodsFor: 'standard queries'! 284030syntaxHighlightingAsYouTypeLeftArrowAssignment 284031 ^ self 284032 valueOfFlag: #syntaxHighlightingAsYouTypeLeftArrowAssignment 284033 ifAbsent: [false]! ! 284034 284035!Preferences class methodsFor: 'standard queries'! 284036systemWindowEmbedOK 284037 ^ self 284038 valueOfFlag: #systemWindowEmbedOK 284039 ifAbsent: [false]! ! 284040 284041!Preferences class methodsFor: 'standard queries'! 284042tabAmongFields 284043 ^ self 284044 valueOfFlag: #tabAmongFields 284045 ifAbsent: [true]! ! 284046 284047!Preferences class methodsFor: 'standard queries'! 284048testRunnerWindowColor 284049 ^ self 284050 valueOfFlag: #testRunnerWindowColor 284051 ifAbsent: [Color 284052 r: 0.65 284053 g: 0.753 284054 b: 0.976]! ! 284055 284056!Preferences class methodsFor: 'standard queries'! 284057tinyDisplay 284058 ^ self 284059 valueOfFlag: #tinyDisplay 284060 ifAbsent: [false]! ! 284061 284062!Preferences class methodsFor: 'standard queries'! 284063transcriptWindowColor 284064 ^ self 284065 valueOfFlag: #transcriptWindowColor 284066 ifAbsent: [Color 284067 r: 1.0 284068 g: 0.8 284069 b: 0.4]! ! 284070 284071!Preferences class methodsFor: 'standard queries'! 284072turnOffPowerManager 284073 ^ self 284074 valueOfFlag: #turnOffPowerManager 284075 ifAbsent: [false]! ! 284076 284077!Preferences class methodsFor: 'standard queries'! 284078uiTheme 284079 ^ self 284080 valueOfFlag: #uiTheme 284081 ifAbsent: [UIThemeStandardSqueak]! ! 284082 284083!Preferences class methodsFor: 'standard queries'! 284084uniqueNamesInHalos 284085 ^ self 284086 valueOfFlag: #uniqueNamesInHalos 284087 ifAbsent: [false]! ! 284088 284089!Preferences class methodsFor: 'standard queries'! 284090unlimitedPaintArea 284091 ^ self 284092 valueOfFlag: #unlimitedPaintArea 284093 ifAbsent: [false]! ! 284094 284095!Preferences class methodsFor: 'standard queries'! 284096updateFromServerAtStartup 284097 ^ self 284098 valueOfFlag: #updateFromServerAtStartup 284099 ifAbsent: [false]! ! 284100 284101!Preferences class methodsFor: 'standard queries'! 284102updateSavesFile 284103 ^ self 284104 valueOfFlag: #updateSavesFile 284105 ifAbsent: [false]! ! 284106 284107!Preferences class methodsFor: 'standard queries'! 284108upgradeIsMerge 284109 ^ self 284110 valueOfFlag: #upgradeIsMerge 284111 ifAbsent: [false]! ! 284112 284113!Preferences class methodsFor: 'standard queries'! 284114useFormsInPaintBox 284115 ^ self 284116 valueOfFlag: #useFormsInPaintBox 284117 ifAbsent: [false]! ! 284118 284119!Preferences class methodsFor: 'standard queries'! 284120useLocale 284121 ^ self 284122 valueOfFlag: #useLocale 284123 ifAbsent: [false]! ! 284124 284125!Preferences class methodsFor: 'standard queries'! 284126useNewDiffToolsForMC 284127 ^ self 284128 valueOfFlag: #useNewDiffToolsForMC 284129 ifAbsent: [true]! ! 284130 284131!Preferences class methodsFor: 'standard queries'! 284132useOnlyServicesInMenu 284133 ^ self 284134 valueOfFlag: #useOnlyServicesInMenu 284135 ifAbsent: [false]! ! 284136 284137!Preferences class methodsFor: 'standard queries'! 284138useRBASTForPrettyPrint 284139 ^ self 284140 valueOfFlag: #useRBASTForPrettyPrint 284141 ifAbsent: [false]! ! 284142 284143!Preferences class methodsFor: 'standard queries'! 284144useServicesInBrowserButtonBar 284145 ^ self 284146 valueOfFlag: #useServicesInBrowserButtonBar 284147 ifAbsent: [false]! ! 284148 284149!Preferences class methodsFor: 'standard queries'! 284150useSmartLabels 284151 ^ self 284152 valueOfFlag: #useSmartLabels 284153 ifAbsent: [false]! ! 284154 284155!Preferences class methodsFor: 'standard queries'! 284156useThemeSounds 284157 ^ self 284158 valueOfFlag: #useThemeSounds 284159 ifAbsent: [true]! ! 284160 284161!Preferences class methodsFor: 'standard queries'! 284162useUndo 284163 ^ self 284164 valueOfFlag: #useUndo 284165 ifAbsent: [true]! ! 284166 284167!Preferences class methodsFor: 'standard queries'! 284168versionsBrowserWindowColor 284169 ^ self 284170 valueOfFlag: #versionsBrowserWindowColor 284171 ifAbsent: [Color 284172 r: 0.869 284173 g: 0.753 284174 b: 1.0]! ! 284175 284176!Preferences class methodsFor: 'standard queries'! 284177visualExplorer 284178 ^ self 284179 valueOfFlag: #visualExplorer 284180 ifAbsent: [true]! ! 284181 284182!Preferences class methodsFor: 'standard queries'! 284183visualizations 284184 ^ self 284185 valueOfFlag: #visualizations 284186 ifAbsent: [true]! ! 284187 284188!Preferences class methodsFor: 'standard queries'! 284189warnAboutInsecureContent 284190 ^ self 284191 valueOfFlag: #warnAboutInsecureContent 284192 ifAbsent: [true]! ! 284193 284194!Preferences class methodsFor: 'standard queries'! 284195warnIfNoChangesFile 284196 ^ self 284197 valueOfFlag: #warnIfNoChangesFile 284198 ifAbsent: [true]! ! 284199 284200!Preferences class methodsFor: 'standard queries'! 284201warnIfNoSourcesFile 284202 ^ self 284203 valueOfFlag: #warnIfNoSourcesFile 284204 ifAbsent: [true]! ! 284205 284206!Preferences class methodsFor: 'standard queries'! 284207windowAnimation 284208 ^ self 284209 valueOfFlag: #windowAnimation 284210 ifAbsent: [true]! ! 284211 284212!Preferences class methodsFor: 'standard queries'! 284213windowAnimationDelay 284214 ^ self 284215 valueOfFlag: #windowAnimationDelay 284216 ifAbsent: [10]! ! 284217 284218!Preferences class methodsFor: 'standard queries'! 284219windowAnimationSteps 284220 ^ self 284221 valueOfFlag: #windowAnimationSteps 284222 ifAbsent: [15]! ! 284223 284224!Preferences class methodsFor: 'standard queries'! 284225windowsActiveOnFirstClick 284226 ^ self 284227 valueOfFlag: #windowsActiveOnFirstClick 284228 ifAbsent: [false]! ! 284229 284230!Preferences class methodsFor: 'standard queries'! 284231wordStyleCursorMovement 284232 ^ self 284233 valueOfFlag: #wordStyleCursorMovement 284234 ifAbsent: [true]! ! 284235 284236!Preferences class methodsFor: 'standard queries'! 284237workspaceWindowColor 284238 ^ self 284239 valueOfFlag: #workspaceWindowColor 284240 ifAbsent: [Color 284241 r: 1.0 284242 g: 1.0 284243 b: 0.8]! ! 284244 284245!Preferences class methodsFor: 'standard queries'! 284246worldTaskbarWindowPreview 284247 ^ self 284248 valueOfFlag: #worldTaskbarWindowPreview 284249 ifAbsent: [true]! ! 284250 284251 284252!Preferences class methodsFor: 'text highlighting' stamp: 'lr 7/12/2006 09:25'! 284253caretWidth 284254 ^ Parameters at: #caretWidth! ! 284255 284256!Preferences class methodsFor: 'text highlighting' stamp: 'lr 7/12/2006 09:25'! 284257caretWidth: anInteger 284258 ^ Parameters at: #caretWidth put: anInteger! ! 284259 284260!Preferences class methodsFor: 'text highlighting' stamp: 'lr 7/12/2006 09:42'! 284261initializeTextHighlightingParameters 284262 "Preferences initializeTextHighlightingParameters" 284263 284264 self 284265 caretWidth: 2; 284266 insertionPointColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.8 alpha: 0.8); 284267 textHighlightColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.8 alpha: 0.2)! ! 284268 284269!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:53'! 284270insertionPointColor 284271 ^ Parameters at: #insertionPointColor! ! 284272 284273!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:54'! 284274insertionPointColor: aColor 284275 Parameters at: #insertionPointColor put: aColor! ! 284276 284277!Preferences class methodsFor: 'text highlighting' stamp: 'dew 1/8/2002 01:07'! 284278keyboardFocusColor 284279 "Answer the keyboard focus color, initializing it if necessary" 284280 284281 ^ Parameters at: #keyboardFocusColor ifAbsentPut: [Color lightGray] 284282 284283" 284284Parameters removeKey: #keyboardFocusColor. 284285Preferences keyboardFocusColor 284286"! ! 284287 284288!Preferences class methodsFor: 'text highlighting' stamp: 'sw 12/7/2001 00:44'! 284289keyboardFocusColor: aColor 284290 "Set the keyboard focus color" 284291 284292 Parameters at: #keyboardFocusColor put: aColor! ! 284293 284294!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:53'! 284295textHighlightColor 284296 ^ Parameters at: #textHighlightColor! ! 284297 284298!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:54'! 284299textHighlightColor: aColor 284300 Parameters at: #textHighlightColor put: aColor! ! 284301 284302 284303!Preferences class methodsFor: 'themes' stamp: 'sw 4/21/2002 07:37'! 284304outOfTheBox 284305 "The default out-of-the-box preference settings for Squeak 3.2. The 'alternative' window-look and scrollbar-look are used. Button panes are used but not annotation panes. Scrollbars are on the right and do not flop out." 284306 284307 self setPreferencesFrom: self defaultValueTableForCurrentRelease! ! 284308 284309!Preferences class methodsFor: 'themes' stamp: 'sw 5/2/2002 10:45'! 284310personal 284311 "Settings saved (by sometime earlier having hit the 'Save Current Settings as my Personal Preferences' in a Preferences panel) as my personal preferences" 284312 284313 self restorePersonalPreferences! ! 284314 284315 284316!Preferences class methodsFor: 'window colors' stamp: 'hpt 12/6/2004 22:49'! 284317checkForWindowColors 284318 (self allPreferenceObjects noneSatisfy: [:aPref | aPref name endsWith: 'WindowColor']) 284319 ifTrue: [self installBrightWindowColors].! ! 284320 284321!Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 19:34'! 284322darkenStandardWindowPreferences 284323 "Make all window-color preferences one shade darker" 284324 284325 (self allPreferenceObjects 284326 select: [:aPref | (aPref name endsWith: 'WindowColor') 284327 and: [aPref preferenceValue isColor]]) 284328 do: [:aPref | aPref preferenceValue: aPref preferenceValue darker]. 284329 284330"Preferences darkenStandardWindowPreferences" 284331! ! 284332 284333!Preferences class methodsFor: 'window colors' stamp: 'sw 2/26/2002 13:56'! 284334installBrightWindowColors 284335 "Install the factory-provided default window colors for all tools" 284336 284337 "Preferences installBrightWindowColors" 284338 284339 self installWindowColorsVia: [:aSpec | aSpec brightColor]! ! 284340 284341!Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 23:17'! 284342installMissingWindowColors 284343 "Install the factory-provided bright window colors -- a one-time bootstrap" 284344 "Preferences installMissingWindowColors" 284345 | color | 284346 self windowColorTable do: 284347 [:aColorSpec | 284348 color := (Color colorFrom: aColorSpec brightColor). 284349 self setWindowColorFor: aColorSpec classSymbol to: color]! ! 284350 284351!Preferences class methodsFor: 'window colors' stamp: 'sw 2/26/2002 13:55'! 284352installPastelWindowColors 284353 "Install the factory-provided default pastel window colors for all tools" 284354 284355 "Preferences installBrightWindowColors" 284356 self installWindowColorsVia: [:aSpec | aSpec pastelColor]! ! 284357 284358!Preferences class methodsFor: 'window colors' stamp: 'sw 2/26/2002 12:55'! 284359installUniformWindowColors 284360 "Install the factory-provided uniform window colors for all tools" 284361 284362 "Preferences installUniformWindowColors" 284363 self installWindowColorsVia: [:aQuad | #white]! ! 284364 284365!Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 20:10'! 284366installWindowColorsVia: colorSpecBlock 284367 "Install windows colors using colorSpecBlock to deliver the color source for each element; the block is handed a WindowColorSpec object" 284368 "Preferences installBrightWindowColors" 284369 | color | 284370 self windowColorTable do: 284371 [:aColorSpec | 284372 color := (Color colorFrom: (colorSpecBlock value: aColorSpec)). 284373 self setWindowColorFor: aColorSpec classSymbol to: color] 284374! ! 284375 284376!Preferences class methodsFor: 'window colors' stamp: 'hpt 12/8/2004 19:35'! 284377lightenStandardWindowPreferences 284378 "Make all window-color preferences one shade darker" 284379 284380 (self allPreferenceObjects 284381 select: [:aPref | (aPref name endsWith: 'WindowColor') 284382 and: [aPref preferenceValue isColor]]) 284383 do: [:aPref | aPref preferenceValue: aPref preferenceValue lighter]. 284384 284385"Preferences lightenStandardWindowPreferences" 284386! ! 284387 284388!Preferences class methodsFor: 'window colors' stamp: 'sd 9/14/2006 20:12'! 284389setWindowColorFor: modelSymbol to: incomingColor 284390 | aColor aPrefSymbol aColorSpec | 284391 aColorSpec := WindowColorRegistry registeredWindowColorSpecFor: modelSymbol. 284392 aColorSpec ifNil: [^self]. 284393 aColor := incomingColor asNontranslucentColor. 284394 (aColor = ColorPickerMorph perniciousBorderColor or: [aColor = Color black]) 284395 ifTrue: [^ self]. 284396 aPrefSymbol := self windowColorPreferenceForClassNamed: aColorSpec classSymbol. 284397 self 284398 addPreference: aPrefSymbol 284399 categories: { #'window colors' } 284400 default: aColor 284401 balloonHelp: aColorSpec helpMessage translated 284402 projectLocal: false 284403 changeInformee: nil 284404 changeSelector: nil 284405 viewRegistry: (PreferenceViewRegistry registryOf: #windowColorPreferences)! ! 284406 284407!Preferences class methodsFor: 'window colors' stamp: 'sd 9/14/2006 20:13'! 284408windowColorFor: aModelClassName 284409 | classToCheck prefSymbol | 284410 self checkForWindowColors. 284411 classToCheck := Smalltalk at: aModelClassName. 284412 prefSymbol := self windowColorPreferenceForClassNamed: classToCheck name. 284413 [(classToCheck ~~ Object) and: [(self preferenceAt: prefSymbol) isNil]] 284414 whileTrue: 284415 [classToCheck := classToCheck superclass. 284416 prefSymbol := self windowColorPreferenceForClassNamed: classToCheck name]. 284417 ^self valueOfPreference: prefSymbol ifAbsent: [Color white].! ! 284418 284419!Preferences class methodsFor: 'window colors' stamp: 'sw 4/21/2002 02:55'! 284420windowColorHelp 284421 "Provide help for the window-color panel" 284422 284423 | helpString | 284424 helpString := 284425'The "Window Colors" panel lets you select colors for many kinds of standard Squeak windows. 284426 284427You can change your color preference for any particular tool by clicking on the color swatch and then selecting the desired color from the resulting color-picker. 284428 284429The three buttons entitled "Bright", "Pastel", and "White" let you revert to any of three different standard color schemes. 284430 284431The choices you make in the Window Colors panel only affect the colors of new windows that you open. 284432 284433You can make other tools have their colors governed by this panel by simply implementing #windowColorSpecification on the class side of the model -- consult implementors of that method to see examples of how to do this.'. 284434 284435 (StringHolder new contents: helpString) 284436 openLabel: 'About Window Colors' 284437 284438 "Preferences windowColorHelp"! ! 284439 284440!Preferences class methodsFor: 'window colors' stamp: 'hpt 10/9/2005 23:28'! 284441windowColorPreferenceForClassNamed: aClassName 284442 | aColorSpec wording | 284443 aColorSpec := WindowColorRegistry registeredWindowColorSpecFor: aClassName. 284444 wording := aColorSpec ifNil: [aClassName] ifNotNil: [aColorSpec wording]. 284445 ^(wording, 'WindowColor') asLegalSelector asSymbol.! ! 284446 284447!Preferences class methodsFor: 'window colors' stamp: 'hpt 10/9/2005 23:17'! 284448windowColorTable 284449 "Answer a list of WindowColorSpec objects, one for each tool to be represented in the window-color panel" 284450 ^ (WindowColorRegistry registeredWindowColorSpecs 284451 asSortedCollection: 284452 [:specOne :specTwo | specOne wording < specTwo wording]) asArray. 284453 284454"Preferences windowColorTable"! ! 284455Object subclass: #Presenter 284456 instanceVariableNames: 'associatedMorph standardPlayer standardPlayfield standardPalette playerList' 284457 classVariableNames: '' 284458 poolDictionaries: '' 284459 category: 'EToys-Scripting'! 284460!Presenter commentStamp: '<historical>' prior: 0! 284461Optionally associated with a PasteUpMorph, provides a local scope for the running of scripts. 284462 284463Once more valuable, may be again, but at present occupies primarily a historical niche. 284464 284465Maintains a playerList cache. 284466 284467Holds, optionally three 'standard items' -- standardPlayer standardPlayfield standardPalette -- originally providing idiomatic support of ongoing squeak-team internal work, but now extended to more general applicability. 284468 284469 ! 284470 284471 284472!Presenter methodsFor: 'access' stamp: 'sw 4/17/1998 20:07'! 284473associatedMorph 284474 ^ associatedMorph! ! 284475 284476!Presenter methodsFor: 'access' stamp: 'sw 4/17/1998 20:07'! 284477associatedMorph: aMorph 284478 associatedMorph := aMorph! ! 284479 284480!Presenter methodsFor: 'access' stamp: 'sw 4/22/1998 20:05'! 284481world 284482 ^ associatedMorph world! ! 284483 284484 284485!Presenter methodsFor: 'misc' stamp: 'HenrikSperreJohansen 9/10/2009 15:15'! 284486drawingJustCompleted: aSketchMorph 284487 "The user just finished drawing. Now maybe put up a viewer" 284488 284489 | aWorld | 284490 284491 aWorld := associatedMorph world. 284492 (aWorld hasProperty: #automaticFlapViewing) 284493 ifTrue: 284494 [^ aWorld presenter viewMorph: aSketchMorph]. 284495! ! 284496 284497!Presenter methodsFor: 'misc' stamp: 'sw 4/23/1998 18:47'! 284498tempCommand 284499 Transcript cr; show: '#tempCommand invoked for Presenter'! ! 284500 284501 284502 284503!Presenter methodsFor: 'printing' stamp: 'TorstenBergmann 8/19/2009 14:45'! 284504printOn: aStream 284505 super printOn: aStream. 284506 aStream nextPutAll: ' (', self identityHash printString, ')'! ! 284507 284508 284509!Presenter methodsFor: 'scripting' stamp: 'ar 3/17/2001 20:14'! 284510adaptedToWorld: aWorld 284511 "If I refer to a world or a hand, return the corresponding items in the new world." 284512 ^aWorld presenter! ! 284513 284514 284515 284516!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:17'! 284517allGoButtons 284518 "Answer a list of all script-controlling Go buttons within my scope" 284519 284520 ^ associatedMorph allMorphs select: 284521 [:aMorph | (aMorph isKindOf: ThreePhaseButtonMorph) and: 284522 [aMorph actionSelector == #goUp:with:]] 284523 284524 "ActiveWorld presenter allGoButtons"! ! 284525 284526!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:19'! 284527allStepButtons 284528 "Answer a list of all the script-controlling Step buttons within my scope" 284529 284530 ^ associatedMorph allMorphs select: 284531 [:aMorph | (aMorph isKindOf: ThreePhaseButtonMorph) and: 284532 [aMorph actionSelector == #stepStillDown:with:]] 284533 284534 "ActiveWorld presenter allStepButtons"! ! 284535 284536!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:18'! 284537allStopButtons 284538 "Answer a list of all script-controlling Stop buttons within my scope" 284539 284540 ^ associatedMorph allMorphs select: 284541 [:aMorph | (aMorph isKindOf: ThreePhaseButtonMorph) and: 284542 [aMorph actionSelector == #stopUp:with:]] 284543 284544 "ActiveWorld presenter allStopButtons"! ! 284545 284546!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:10'! 284547stepButtonState: newState 284548 "Get all step buttons in my scope to show the correct state" 284549 284550 self allStepButtons do: 284551 [:aButton | aButton state: newState]! ! 284552 284553!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:06'! 284554stepUp: evt with: aMorph 284555 "The step button came up; get things right" 284556 284557 self stepButtonState: #off! ! 284558 284559!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:08'! 284560stopButtonState: newState 284561 "Get all stop buttons in my scope to show the correct state" 284562 284563 self allStopButtons do: 284564 [:aButton | aButton state: newState]! ! 284565 284566!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 18:42'! 284567stopRunningScriptsFrom: ignored 284568 "Stop running scripts; get all script-control buttons to reflect this" 284569 284570 self stopRunningScripts! ! 284571 284572!Presenter methodsFor: 'stop-step-go buttons' stamp: 'HenrikSperreJohansen 9/10/2009 15:15'! 284573stopUp: dummy with: theButton 284574 self stopRunningScripts! ! 284575AppRegistry subclass: #PrettyPrinting 284576 instanceVariableNames: '' 284577 classVariableNames: '' 284578 poolDictionaries: '' 284579 category: 'System-Applications'! 284580 284581"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 284582 284583PrettyPrinting class 284584 instanceVariableNames: ''! 284585 284586!PrettyPrinting class methodsFor: 'class initialization' stamp: 'damiencassou 7/30/2009 10:55'! 284587initialize 284588 "I'm a registry as well as a default provider" 284589 self register: self! ! 284590 284591 284592!PrettyPrinting class methodsFor: 'pretty printing' stamp: 'damiencassou 7/30/2009 10:59'! 284593prettyPrinterClassFor: aBehavior 284594 |defaultPrinter| 284595 defaultPrinter := self default. 284596 ^ (defaultPrinter isNil or: [defaultPrinter = self]) 284597 ifTrue: [aBehavior compilerClass] 284598 ifFalse: [self default prettyPrinterClassFor: aBehavior]! ! 284599TextDiffBuilder subclass: #PrettyTextDiffBuilder 284600 instanceVariableNames: 'sourceClass' 284601 classVariableNames: '' 284602 poolDictionaries: '' 284603 category: 'System-FilePackage'! 284604 284605!PrettyTextDiffBuilder methodsFor: 'initialize' stamp: 'nk 10/29/2000 12:16'! 284606sourceClass: aClass 284607 sourceClass := aClass.! ! 284608 284609!PrettyTextDiffBuilder methodsFor: 'initialize' stamp: 'alain.plantec 5/18/2009 15:59'! 284610split: aString 284611 | formatted trimmed | 284612 trimmed := aString asString withBlanksTrimmed. 284613 trimmed isEmpty ifTrue: [ ^super split: '' ]. 284614 formatted := [ sourceClass prettyPrinterClass 284615 format: trimmed 284616 in: sourceClass 284617 notifying: nil] on: Error do: [ :ex | trimmed ]. 284618 ^ super split: formatted! ! 284619 284620"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 284621 284622PrettyTextDiffBuilder class 284623 instanceVariableNames: ''! 284624 284625!PrettyTextDiffBuilder class methodsFor: 'instance creation' stamp: 'nk 10/29/2000 12:35'! 284626from: srcString to: dstString inClass: srcClass 284627 ^ (self new sourceClass: srcClass) from: srcString to: dstString 284628 ! 284629]style[(6 9 5 9 10 8 6 4 18 8 8 9 5 9 3)f1b,f1cblack;b,f1b,f1cblack;b,f1b,f1cblack;b,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1! ! 284630Object subclass: #PrimCallControllerAbstract 284631 instanceVariableNames: 'treatedMethods logStream changeStatusOfFailedCallsFlag' 284632 classVariableNames: '' 284633 poolDictionaries: '' 284634 category: 'Tests-PrimCallController'! 284635!PrimCallControllerAbstract commentStamp: 'sr 6/16/2004 09:42' prior: 0! 284636A PrimCallController (PCC) serves for switching external prim calls (primitiveExternalCall) on and off: this is an abstract class, instantiate one of the subclasses PCCByLiterals and PCCByCompilation. 284637 284638External prim calls are used to access internal and external modules (plugins) as shown by 284639 SmalltalkImage current listLoadedModules. 284640 SmalltalkImage current listBuiltinModules. 284641Note: not loaded external modules (since they have not been called so far) are not shown by these methods. 284642 284643Highlight: dis/en-abling prims by a PCC works for both internal and external modules!! 284644 284645 284646To help you choosing the right subclass, some properties are listed in the following table: 284647 284648Functionality/Property | PCCByLiterals PCCByCompilation 284649------------------------------------------------------------------------------------------------------ 284650testing plugins | suited not suited 284651permanent disabling of external prim calls | no yes 284652------------------------------------------------------------------------------------------------------ 284653method changes visible in changeset | no yes 284654enabling survives snapshot/compilation | yes yes 284655disabling survives snapshot/compilation | no yes 284656speed disabling | fast medium 284657speed enabling | fast slow 284658CompiledMethod pointer valid after en/dis-abling | yes no 284659 284660Important: Be careful with mixing the use of different PCCs!! PCCByLiterals does not see prims disabled by PCCByCompilation and vice versa. For playing around you should start with PCCByLiterals; use PCCByCompilation only, if you know what you are doing!! 284661 284662In protocols 'ui controlling', 'ui logging' and 'ui querying' (please look into this class) are the most important user interface methods. Thereafter the methods in 'ui testing' could be of interest. 284663 284664 284665Useful expressions: 284666 284667Controlling: 284668 "Factorial example" 284669 | pcc tDisabled tEnabled tEnabled2 | 284670 pcc _ PCCByLiterals new logStream: Transcript. "logStream set here for more info" 284671 pcc disableCallsIntoModule: 'LargeIntegers'. 284672 tDisabled _ [1000 factorial] timeToRun. 284673 pcc enableDisabled. 284674 tEnabled _ [1000 factorial] timeToRun. 284675 tEnabled2 _ [1000 factorial] timeToRun. 284676 {tDisabled. tEnabled. tEnabled2} 284677Note: You shouldn't switch off module 'LargeIntegers' for a longer time, since this slows down your system. 284678 284679Querying: 284680 PCCByLiterals new methodsWithCall. "all calls" 284681 PCCByLiterals new methodsWithCall: 'prim1'. "call in all modules or without module" 284682 PCCByLiterals new methodsWithCallIntoModule: nil. "all calls without module" 284683 PCCByLiterals new methodsWithCallIntoModule: 'LargeIntegers'. "all calls into module 'LargeIntegers'" 284684 PCCByLiterals new 284685 methodsWithCallIntoModule: 'LargeIntegers' 284686 forClass: Integer. "all calls into module 'LargeIntegers' in class Integer" 284687 PCCByLiterals new 284688 methodsWithCallIntoModule: 'LargeIntegers' 284689 forClasses: Integer withAllSubclasses. "all calls into module 'LargeIntegers' in class Integer withAllSubclasses" 284690 284691 | pcc | (pcc _ PCCByLiterals new) methodsWithCall 284692 collect: [:mRef | {mRef. pcc extractCallModuleNames: mRef}]. 284693 284694 284695Structure: 284696 treatedMethods Dictionary of MethodReferences->#disabled/#enabled 284697 -- contains changed methods and how they are changed last 284698 logStream WriteStream -- shows info about changed methods ifNotNil 284699 changeStatusOfFailedCalls Boolean -- if status of failed calls should be changed, default is false! 284700]style[(165 13 5 16 339 26 792 10 84 8 120 31 82 4 118 19 17 18 2 452 29 37 18 15 56 1 18 26 35 2 18 26 79 26 122 26 170 79 1 320)f2FAccuny#12,f2LPCCByLiterals Comment;,f2FAccuny#12,f2LPCCByCompilation Comment;,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#15,f2FAccuny#12,f2,f2u,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2! 284701 284702 284703!PrimCallControllerAbstract methodsFor: 'accessing' stamp: 'sr 6/11/2004 04:52'! 284704changeStatusOfFailedCallsFlag 284705 ^changeStatusOfFailedCallsFlag! ! 284706 284707!PrimCallControllerAbstract methodsFor: 'accessing' stamp: 'sr 6/11/2004 04:12'! 284708logStream 284709 ^logStream! ! 284710 284711!PrimCallControllerAbstract methodsFor: 'accessing' stamp: 'sr 6/2/2004 05:27'! 284712treatedMethods 284713 ^treatedMethods! ! 284714 284715 284716!PrimCallControllerAbstract methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:15'! 284717initialize 284718 super initialize. 284719 treatedMethods := Dictionary new. 284720" logStream := Transcript." 284721 changeStatusOfFailedCallsFlag := false! ! 284722 284723 284724!PrimCallControllerAbstract methodsFor: 'logging' stamp: 'sr 6/11/2004 05:12'! 284725log: aString 284726 self logStream 284727 ifNotNil: [self logStream cr; show: '[' , self className , '] ' , aString]! ! 284728 284729 284730!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:39'! 284731changeStatusOfFailedCalls 284732 "En/dis-able not only dis/en-abled calls, but also failed ones. Using this 284733 feature can hide serious problems." 284734 changeStatusOfFailedCallsFlag := true! ! 284735 284736!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 01:15'! 284737disableCallIn: aMethodRef 284738 "Disables enabled external prim call." 284739 (self existsEnabledCallIn: aMethodRef) 284740 ifFalse: [self changeStatusOfFailedCallsFlag 284741 ifTrue: [(self existsFailedCallIn: aMethodRef) 284742 ifFalse: [^ self error: 'no enabled or failed prim call found']] 284743 ifFalse: [^ self error: 'no enabled prim call found']]. 284744 self privateDisableCallIn: aMethodRef. 284745 self treatedMethods at: aMethodRef put: #disabled. 284746 self logStream 284747 ifNotNil: [self log: 'Call ' , (self extractCallModuleNames: aMethodRef) printString , ' in ' , aMethodRef actualClass name , '>>' , aMethodRef methodSymbol , ' disabled.']! ! 284748 284749!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:30'! 284750disableCallInCompiledMethod: aCompiledMethod 284751 "Disables external prim call." 284752 self changeCallCompiledMethod: aCompiledMethod enable: false! ! 284753 284754!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:31'! 284755disableCallInMethod: selector class: classOrSymbol 284756 "Disables external prim call." 284757 self 284758 changeCallMethod: selector 284759 class: classOrSymbol 284760 enable: false! ! 284761 284762!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 01:35'! 284763disableCallsIntoModule: aModule 284764 "Disables enabled external prim calls in aModule." 284765 | methods | 284766 methods := self methodsWithEnabledCallIntoModule: aModule. 284767 self changeStatusOfFailedCallsFlag 284768 ifTrue: [methods 284769 addAll: (self methodsWithFailedCallIntoModule: aModule)]. 284770 methods isEmpty 284771 ifTrue: [^ self error: 'no enabled ' 284772 , (self changeStatusOfFailedCallsFlag ifTrue: ['or failed '] ifFalse: ['']) 284773 , 'prim calls for module ' , aModule , ' found']. 284774 methods 284775 do: [:mRef | self disableCallIn: mRef]! ! 284776 284777!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 02:01'! 284778disableCallsIntoModule: aModule forClasses: classes 284779 "Disables enabled external prim calls in aModule for classes." 284780 | methods | 284781 methods := self methodsWithEnabledCallIntoModule: aModule forClasses: classes. 284782 self changeStatusOfFailedCallsFlag 284783 ifTrue: [methods 284784 addAll: (self methodsWithFailedCallIntoModule: aModule forClasses: classes)]. 284785 methods isEmpty 284786 ifTrue: [^ self error: 'no enabled ' 284787 , (self changeStatusOfFailedCallsFlag ifTrue: ['or failed '] ifFalse: ['']) 284788 , 'prim calls for module ' , aModule , ' in given classes found']. 284789 methods 284790 do: [:mRef | self disableCallIn: mRef]! ! 284791 284792!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/11/2004 06:44'! 284793disableEnabled 284794 "Disables these external prim calls, which are formerly enabled by self." 284795 self treatedMethods 284796 keysAndValuesDo: [:mRef :status | status == #enabled 284797 ifTrue: [self disableCallIn: mRef]]! ! 284798 284799!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/14/2004 02:05'! 284800enableCallIn: aMethodRef 284801 "Enables disabled external prim call." 284802 (self existsDisabledCallIn: aMethodRef) 284803 ifTrue: [self privateEnableCallIn: aMethodRef] 284804 ifFalse: [self changeStatusOfFailedCallsFlag 284805 ifTrue: [(self existsFailedCallIn: aMethodRef) 284806 ifTrue: [self privateEnableViaLiteralIn: aMethodRef] 284807 ifFalse: [^ self error: 'no disabled or failed prim call found']] 284808 ifFalse: [^ self error: 'no disabled prim call found']]. 284809 self treatedMethods at: aMethodRef put: #enabled. 284810 self logStream 284811 ifNotNil: [self log: 'Call ' , (self extractCallModuleNames: aMethodRef) printString , ' in ' , aMethodRef actualClass name , '>>' , aMethodRef methodSymbol , ' enabled.']! ! 284812 284813!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:31'! 284814enableCallInCompiledMethod: aCompiledMethod 284815 "Enables disabled external prim call." 284816 self changeCallCompiledMethod: aCompiledMethod enable: true! ! 284817 284818!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:31'! 284819enableCallInMethod: selector class: classOrSymbol 284820 "Enables disabled external prim call." 284821 self 284822 changeCallMethod: selector 284823 class: classOrSymbol 284824 enable: true! ! 284825 284826!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 01:36'! 284827enableCallsIntoModule: aModule 284828 "Enables disabled external prim calls in aModule." 284829 | methods | 284830 methods := self methodsWithDisabledCallIntoModule: aModule. 284831 self changeStatusOfFailedCallsFlag 284832 ifTrue: [methods 284833 addAll: (self methodsWithFailedCallIntoModule: aModule)]. 284834 methods isEmpty 284835 ifTrue: [^ self error: 'no disabled ' 284836 , (self changeStatusOfFailedCallsFlag ifTrue: ['or failed '] ifFalse: ['']) 284837 , 'prim calls for module ' , aModule , ' found']. 284838 methods 284839 do: [:mRef | self enableCallIn: mRef]! ! 284840 284841!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 02:01'! 284842enableCallsIntoModule: aModule forClasses: classes 284843 "Enables disabled external prim calls in aModule for classes." 284844 | methods | 284845 methods := self methodsWithDisabledCallIntoModule: aModule forClasses: classes. 284846 self changeStatusOfFailedCallsFlag 284847 ifTrue: [methods 284848 addAll: (self methodsWithFailedCallIntoModule: aModule forClasses: classes)]. 284849 methods isEmpty 284850 ifTrue: [^ self error: 'no disabled ' 284851 , (self changeStatusOfFailedCallsFlag ifTrue: ['or failed '] ifFalse: ['']) 284852 , 'prim calls for module ' , aModule , ' in given classes found']. 284853 methods 284854 do: [:mRef | self enableCallIn: mRef]! ! 284855 284856!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/11/2004 06:42'! 284857enableDisabled 284858 "Enables these external prim calls, which are formerly disabled by self." 284859 self treatedMethods 284860 keysAndValuesDo: [:mRef :status | status == #disabled 284861 ifTrue: [self enableCallIn: mRef]]! ! 284862 284863!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:41'! 284864preserveStatusOfFailedCalls 284865 "Do not en/dis-able failed calls (default)." 284866 changeStatusOfFailedCallsFlag := false! ! 284867 284868!PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/11/2004 06:45'! 284869switchStored 284870 "Disables enabled and enables disabled (see corresponding method 284871 comments). " 284872 self treatedMethods 284873 keysAndValuesDo: [:mRef :status | status == #enabled 284874 ifTrue: [self disableCallIn: mRef] 284875 ifFalse: [self enableCallIn: mRef]]! ! 284876 284877 284878!PrimCallControllerAbstract methodsFor: 'ui logging' stamp: 'sr 6/11/2004 04:17'! 284879logStream: aStreamOrNil 284880 "If aStreamOrNil is notNil, there will be shown dis/en-abling prim call 284881 info; nil means no logging." 284882 logStream := aStreamOrNil! ! 284883 284884 284885!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/10/2004 21:15'! 284886extractCallModuleNames: aMethodRef 284887 "Returns prim call and module name as call->module Association." 284888 self subclassResponsibility! ! 284889 284890!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:27'! 284891methodsWithCall 284892 "Returns all methods containing external prim calls." 284893 self subclassResponsibility! ! 284894 284895!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 02:15'! 284896methodsWithCall: primName 284897 ^ self methodsWithCall: primName enabled: nil! ! 284898 284899!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 02:12'! 284900methodsWithCall: primName intoModule: moduleNameOrNil 284901 ^ self methodsWithCall: primName intoModule: moduleNameOrNil enabled: nil! ! 284902 284903!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 19:20'! 284904methodsWithCallIntoModule: moduleNameOrNil 284905 ^ self methodsWithCallIntoModule: moduleNameOrNil enabled: nil! ! 284906 284907!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 19:30'! 284908methodsWithCallIntoModule: moduleNameOrNil forClass: class 284909 ^ self methodsWithCallIntoModule: moduleNameOrNil forClasses: {class}! ! 284910 284911!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 19:30'! 284912methodsWithCallIntoModule: moduleNameOrNil forClasses: classes 284913 ^ self 284914 methodsWithCallIntoModule: moduleNameOrNil 284915 forClasses: classes 284916 enabled: nil! ! 284917 284918!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:36'! 284919methodsWithCompiledCall 284920 "Returns all methods containing compiled in external prim calls. 284921 If the by compilation subclass has disabled some, this method does *not* 284922 return all methods containing prim calls (use >>methodsWithCall in this 284923 case). " 284924 ^ (SystemNavigation new 284925 allMethodsSelect: [:method | method primitive = 117]) 284926 reject: [:method | method actualClass == ProtoObject]! ! 284927 284928!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:28'! 284929methodsWithDisabledCall 284930 "Returns all methods containing disabled external prim calls." 284931 self subclassResponsibility! ! 284932 284933!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:24'! 284934methodsWithDisabledCall: primName 284935 ^ self methodsWithCall: primName enabled: false! ! 284936 284937!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:25'! 284938methodsWithDisabledCall: primName intoModule: moduleNameOrNil 284939 ^ self methodsWithCall: primName intoModule: moduleNameOrNil enabled: false! ! 284940 284941!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:25'! 284942methodsWithDisabledCallIntoModule: moduleNameOrNil 284943 ^ self methodsWithCallIntoModule: moduleNameOrNil enabled: false! ! 284944 284945!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:24'! 284946methodsWithDisabledCallIntoModule: moduleNameOrNil forClass: class 284947 ^ self methodsWithDisabledCallIntoModule: moduleNameOrNil forClasses: {class}! ! 284948 284949!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:20'! 284950methodsWithDisabledCallIntoModule: moduleNameOrNil forClasses: classes 284951 ^ self 284952 methodsWithCallIntoModule: moduleNameOrNil 284953 forClasses: classes 284954 enabled: false! ! 284955 284956!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:28'! 284957methodsWithEnabledCall 284958 "Returns all methods containing enabled external prim calls." 284959 ^ self methodsWithCompiledCall 284960 select: [:mRef | (mRef compiledMethod literals first at: 4) 284961 >= 0]! ! 284962 284963!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:15'! 284964methodsWithEnabledCall: primName 284965 ^ self methodsWithCall: primName enabled: true! ! 284966 284967!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:16'! 284968methodsWithEnabledCall: primName intoModule: moduleNameOrNil 284969 ^ self methodsWithCall: primName intoModule: moduleNameOrNil enabled: true! ! 284970 284971!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:11'! 284972methodsWithEnabledCallIntoModule: moduleNameOrNil 284973 ^ self methodsWithCallIntoModule: moduleNameOrNil enabled: true! ! 284974 284975!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 05:46'! 284976methodsWithEnabledCallIntoModule: moduleNameOrNil forClass: class 284977 ^ self methodsWithEnabledCallIntoModule: moduleNameOrNil forClasses: {class}! ! 284978 284979!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:07'! 284980methodsWithEnabledCallIntoModule: moduleNameOrNil forClasses: classes 284981 ^ self 284982 methodsWithCallIntoModule: moduleNameOrNil 284983 forClasses: classes 284984 enabled: true! ! 284985 284986!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 20:47'! 284987methodsWithFailedCall 284988 "Returns all methods containing failed external prim calls." 284989 ^ self methodsWithCompiledCall select: self blockSelectFailedCall! ! 284990 284991!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 01:40'! 284992methodsWithFailedCallForClass: class 284993 ^ class selectors 284994 collect: [:sel | MethodReference new setStandardClass: class methodSymbol: sel] 284995 thenSelect: [:mRef | self existsFailedCallIn: mRef]! ! 284996 284997!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 01:44'! 284998methodsWithFailedCallForClasses: classes 284999 | result | 285000 result := OrderedCollection new. 285001 classes 285002 do: [:class | result 285003 addAll: (self methodsWithFailedCallForClass: class)]. 285004 ^ result! ! 285005 285006!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 19:58'! 285007methodsWithFailedCallIntoModule: moduleNameOrNil 285008 ^ self methodsWithFailedCall 285009 select: (self blockSelectModuleName: moduleNameOrNil)! ! 285010 285011!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 02:19'! 285012methodsWithFailedCallIntoModule: moduleNameOrNil forClass: class 285013 ^ self methodsWithFailedCallIntoModule: moduleNameOrNil forClasses: {class}! ! 285014 285015!PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 19:58'! 285016methodsWithFailedCallIntoModule: moduleNameOrNil forClasses: classes 285017 ^ (self methodsWithFailedCallForClasses: classes) 285018 select: (self blockSelectModuleName: moduleNameOrNil)! ! 285019 285020 285021!PrimCallControllerAbstract methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:31'! 285022existsCallIn: aMethodRef 285023 285024 self subclassResponsibility! ! 285025 285026!PrimCallControllerAbstract methodsFor: 'ui testing' stamp: 'sr 6/9/2004 02:12'! 285027existsDisabledCallIn: aMethodRef 285028 self subclassResponsibility! ! 285029 285030!PrimCallControllerAbstract methodsFor: 'ui testing' stamp: 'sr 6/11/2004 06:34'! 285031existsEnabledCallIn: aMethodRef 285032 ^ (self existsCompiledCallIn: aMethodRef) 285033 and: [(aMethodRef compiledMethod literals first at: 4) 285034 >= 0]! ! 285035 285036!PrimCallControllerAbstract methodsFor: 'ui testing' stamp: 'sr 6/15/2004 20:46'! 285037existsFailedCallIn: aMethodRef 285038 ^ (self existsCompiledCallIn: aMethodRef) 285039 and: [self blockSelectFailedCall value: aMethodRef]! ! 285040 285041 285042!PrimCallControllerAbstract methodsFor: 'private' stamp: 'sr 6/10/2004 21:32'! 285043extractCallModuleNamesFromLiterals: aMethodRef 285044 | firstLiteral | 285045 firstLiteral := aMethodRef compiledMethod literals first. 285046 ^ (firstLiteral at: 2) 285047 -> (firstLiteral at: 1)! ! 285048 285049 285050!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:49'! 285051blockSelectCallName: callName 285052 285053 ^ [:mRef | (self extractCallModuleNames: mRef) key = callName]! ! 285054 285055!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 20:45'! 285056blockSelectFailedCall 285057 "Precondition: mRef references compiledCall." 285058 ^ [:mRef | (mRef compiledMethod literals first at: 4) 285059 = -1]! ! 285060 285061!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:50'! 285062blockSelectModuleName: moduleNameOrNil 285063 285064 ^ [:mRef | (self extractCallModuleNames: mRef) value = moduleNameOrNil]! ! 285065 285066!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'md 2/16/2006 14:02'! 285067changeCallCompiledMethod: aCompiledMethod enable: enableFlag 285068 "Enables disabled or disables enabled external prim call by recompiling 285069 method with prim call taken from comment." 285070 | methodRef | 285071 methodRef := aCompiledMethod methodReference. 285072 enableFlag 285073 ifTrue: [self enableCallIn: methodRef] 285074 ifFalse: [self disableCallIn: methodRef]! ! 285075 285076!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 17:31'! 285077changeCallMethod: selector class: classOrSymbol enable: enableFlag 285078 "Enables disabled or disables enabled external prim call by recompiling 285079 method with prim call taken from comment." 285080 | methodRef | 285081 methodRef := MethodReference new 285082 setStandardClass: (classOrSymbol isSymbol 285083 ifTrue: [Smalltalk at: classOrSymbol] 285084 ifFalse: [classOrSymbol]) 285085 methodSymbol: selector. 285086 enableFlag 285087 ifTrue: [self enableCallIn: methodRef] 285088 ifFalse: [self disableCallIn: methodRef]! ! 285089 285090!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/11/2004 06:31'! 285091existsCompiledCallIn: aMethodRef 285092 "This just means that there is a compiled in external prim call: from the 285093 by compiler subclass point of view disabled prim calls not visible by 285094 this method are also prim calls." 285095 ^ aMethodRef compiledMethod primitive = 117! ! 285096 285097!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:59'! 285098methodsWithCall: callName enabled: enabledFlag 285099 ^ (self methodsWithCallEnabled: enabledFlag) 285100 select: (self blockSelectCallName: callName)! ! 285101 285102!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 20:24'! 285103methodsWithCall: callName intoModule: moduleNameOrNil enabled: enabledFlag 285104 ^ ((self methodsWithCallEnabled: enabledFlag) 285105 select: (self blockSelectCallName: callName)) 285106 select: (self blockSelectModuleName: moduleNameOrNil)! ! 285107 285108!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 19:17'! 285109methodsWithCallEnabled: enabledFlag 285110 ^ enabledFlag 285111 ifNil: [self methodsWithCall] 285112 ifNotNil: [enabledFlag 285113 ifTrue: [self methodsWithEnabledCall] 285114 ifFalse: [self methodsWithDisabledCall]]! ! 285115 285116!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 19:19'! 285117methodsWithCallForClass: class enabled: enabledFlag 285118 ^ class selectors 285119 collect: [:sel | MethodReference new setStandardClass: class methodSymbol: sel] 285120 thenSelect: (enabledFlag 285121 ifNil: [[:mRef | self existsCallIn: mRef]] 285122 ifNotNil: [enabledFlag 285123 ifTrue: [[:mRef | self existsEnabledCallIn: mRef]] 285124 ifFalse: [[:mRef | self existsDisabledCallIn: mRef]]])! ! 285125 285126!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/13/2004 20:00'! 285127methodsWithCallForClasses: classes enabled: enabledFlag 285128 | result | 285129 result := OrderedCollection new. 285130 classes 285131 do: [:class | result 285132 addAll: (self methodsWithCallForClass: class enabled: enabledFlag)]. 285133 ^ result! ! 285134 285135!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:55'! 285136methodsWithCallIntoModule: moduleNameOrNil enabled: enabledFlag 285137 ^ (self methodsWithCallEnabled: enabledFlag) 285138 select: (self blockSelectModuleName: moduleNameOrNil)! ! 285139 285140!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:57'! 285141methodsWithCallIntoModule: moduleNameOrNil forClasses: classes enabled: enabledFlag 285142 ^ (self methodsWithCallForClasses: classes enabled: enabledFlag) 285143 select: (self blockSelectModuleName: moduleNameOrNil)! ! 285144 285145!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 01:34'! 285146privateDisableCallIn: aMethodRefWithExternalCall 285147 "Disables enabled or failed external prim call." 285148 self subclassResponsibility! ! 285149 285150!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 01:33'! 285151privateEnableCallIn: aMethodRefWithExternalCall 285152 "Enables disabled external prim call." 285153 self subclassResponsibility! ! 285154 285155!PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 02:09'! 285156privateEnableViaLiteralIn: aMethodRef 285157 "Enables external prim call by filling function ref literal with zero for 285158 'non called'." 285159 aMethodRef compiledMethod literals first at: 4 put: 0. 285160 Object flushCache! ! 285161ClassTestCase subclass: #PrimCallControllerAbstractTest 285162 instanceVariableNames: 'pcc doNotMakeSlowTestsFlag' 285163 classVariableNames: '' 285164 poolDictionaries: '' 285165 category: 'Tests-PrimCallController'! 285166!PrimCallControllerAbstractTest commentStamp: 'sr 6/15/2004 19:20' prior: 0! 285167PrimCallController tests. 285168 285169Tests are here, but this class isAbstract and won't be tested. 285170Tests are done in the subclasses, which inherit the tests here. 285171 285172If you want to perform some more very slow tests, change doNotMakeSlowTestsFlag in >>setUp.! 285173 285174 285175!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:46'! 285176compiledMethodsToExampleModule 285177 ^ self methodSelectorsToExampleModule 285178 collect: [:sel | self class >> sel]! ! 285179 285180!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/14/2004 00:11'! 285181failedCallRef 285182 ^ MethodReference new setStandardClass: self class methodSymbol: self failedCallSelector! ! 285183 285184!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:46'! 285185methodRefsToExampleModule 285186 ^ self methodSelectorsToExampleModule 285187 collect: [:sym | MethodReference new setStandardClass: self class methodSymbol: sym]! ! 285188 285189!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 13:58'! 285190noExternalCallRef 285191 ^ MethodReference new setStandardClass: self class methodSymbol: self noExternalCallSelector! ! 285192 285193!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'! 285194numOfCallsExampleModule 285195 ^ self methodSelectorsToExampleModule size! ! 285196 285197!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/14/2004 23:34'! 285198singularCallRef 285199 ^ MethodReference new setStandardClass: self class methodSymbol: self singularCallSelector! ! 285200 285201!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:49'! 285202wrongCallRef 285203 ^ MethodReference new setStandardClass: self class methodSymbol: #nonExistingCall! ! 285204 285205!PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:49'! 285206wrongClassRef 285207 ^ MethodReference new setStandardClass: Integer methodSymbol: self methodSelectorsToExampleModule first! ! 285208 285209 285210!PrimCallControllerAbstractTest methodsFor: 'helper' stamp: 'sr 6/14/2004 22:56'! 285211avoidSlowTest 285212 285213 ^ doNotMakeSlowTestsFlag and: [pcc class = PCCByCompilation]! ! 285214 285215!PrimCallControllerAbstractTest methodsFor: 'helper' stamp: 'sr 6/7/2004 08:56'! 285216disabledCallRefs 285217 ^ self disabledCallSelectors 285218 collect: [:sel | MethodReference new setStandardClass: self class methodSymbol: sel]! ! 285219 285220!PrimCallControllerAbstractTest methodsFor: 'helper' stamp: 'sr 6/7/2004 08:57'! 285221enabledCallRefs 285222 ^ self enabledCallSelectors 285223 collect: [:sel | MethodReference new setStandardClass: self class methodSymbol: sel]! ! 285224 285225 285226!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 04:37'! 285227setUp 285228 super setUp. 285229 pcc := self classToBeTested new. 285230 "set failed call" 285231 (self class >> self failedCallSelector) literals first at: 4 put: -1. 285232 "set it to false for some very slow tests..." 285233 doNotMakeSlowTestsFlag := true! ! 285234 285235!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:54'! 285236testChangeFailedCallFailing 285237 pcc preserveStatusOfFailedCalls. 285238 self 285239 should: [pcc enableCallIn: self failedCallRef] 285240 raise: TestResult error. 285241 self 285242 should: [pcc disableCallIn: self failedCallRef] 285243 raise: TestResult error! ! 285244 285245!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 00:41'! 285246testChangeFailedCallSucceedingDisable 285247 pcc changeStatusOfFailedCalls. 285248 pcc disableCallIn: self failedCallRef. 285249 self 285250 assert: (pcc existsDisabledCallIn: self failedCallRef). 285251 "necessary for PCCByCompilation (to make it visible for initialization again)" 285252 pcc enableCallIn: self failedCallRef! ! 285253 285254!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 00:34'! 285255testChangeFailedCallSucceedingEnable 285256 pcc changeStatusOfFailedCalls. 285257 pcc enableCallIn: self failedCallRef. 285258 self 285259 assert: (pcc existsEnabledCallIn: self failedCallRef)! ! 285260 285261!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 02:43'! 285262testDisableCallsIntoModule 285263 "wrong module" 285264 self 285265 should: [pcc disableCallsIntoModule: 'totallyRandom4711'] 285266 raise: TestResult error. 285267 "precondition: all enabled" 285268 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285269 "disabling" 285270 pcc disableCallsIntoModule: self exampleModuleName. 285271 "now all disabled" 285272 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. 285273 "not enabled!!" 285274 self 285275 should: [pcc disableCallsIntoModule: self exampleModuleName] 285276 raise: TestResult error. 285277 "enabling" 285278 self methodRefsToExampleModule 285279 do: [:ref | pcc enableCallIn: ref]. 285280 "all enabled now" 285281 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285282 "not enabled!!" 285283 self 285284 should: [pcc disableCallsIntoModule: self failModuleName] 285285 raise: TestResult error. 285286 pcc changeStatusOfFailedCalls. 285287 pcc disableCallsIntoModule: self failModuleName. 285288 self assert: (pcc existsDisabledCallIn: self failedCallRef). 285289 "postcondition" 285290 pcc enableCallIn: self failedCallRef 285291! ! 285292 285293!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:24'! 285294testDisableCallsIntoModuleForClasses 285295 "wrong module" 285296 self 285297 should: [pcc disableCallsIntoModule: 'totallyRandom4711' forClasses: {self class}] 285298 raise: TestResult error. 285299 "precondition: all enabled" 285300 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285301 "disabling" 285302 pcc disableCallsIntoModule: self exampleModuleName forClasses: {self class}. 285303 "now all disabled" 285304 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. 285305 "not enabled!!" 285306 self 285307 should: [pcc disableCallsIntoModule: self exampleModuleName forClasses: {self class}] 285308 raise: TestResult error. 285309 "enabling" 285310 self methodRefsToExampleModule 285311 do: [:ref | pcc enableCallIn: ref]. 285312 "all enabled now" 285313 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285314 "not enabled!!" 285315 self 285316 should: [pcc disableCallsIntoModule: self failModuleName forClasses: {self class}] 285317 raise: TestResult error. 285318 pcc changeStatusOfFailedCalls. 285319 pcc disableCallsIntoModule: self failModuleName forClasses: {self class}. 285320 self assert: (pcc existsDisabledCallIn: self failedCallRef). 285321 "postcondition" 285322 pcc enableCallIn: self failedCallRef 285323! ! 285324 285325!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 02:43'! 285326testEnableCallsIntoModule 285327 self avoidSlowTest 285328 ifTrue: [^ self]. 285329 "wrong module" 285330 self 285331 should: [pcc enableCallsIntoModule: 'totallyRandom4711'] 285332 raise: TestResult error. 285333 "precondition: all enabled" 285334 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285335 "not disabled!!" 285336 self 285337 should: [pcc enableCallsIntoModule: self exampleModuleName] 285338 raise: TestResult error. 285339 "disabling" 285340 self methodRefsToExampleModule 285341 do: [:ref | pcc disableCallIn: ref]. 285342 "now all disabled" 285343 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. 285344 "enabling" 285345 "now this should work" 285346 pcc enableCallsIntoModule: self exampleModuleName. 285347 "all enabled now" 285348 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285349 "not disabled!!" 285350 self 285351 should: [pcc enableCallsIntoModule: self failModuleName] 285352 raise: TestResult error. 285353 pcc changeStatusOfFailedCalls. 285354 pcc enableCallsIntoModule: self failModuleName. 285355 self assert: (pcc existsEnabledCallIn: self failedCallRef) 285356! ! 285357 285358!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:43'! 285359testEnableCallsIntoModuleForClasses 285360 "wrong module" 285361 self 285362 should: [pcc enableCallsIntoModule: 'totallyRandom4711' forClasses: {self class}] 285363 raise: TestResult error. 285364 "precondition: all enabled" 285365 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285366 "not disabled!!" 285367 self 285368 should: [pcc enableCallsIntoModule: self exampleModuleName forClasses: {self class}] 285369 raise: TestResult error. 285370 "disabling" 285371 self methodRefsToExampleModule 285372 do: [:ref | pcc disableCallIn: ref]. 285373 "now all disabled" 285374 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. 285375 "enabling" 285376 "now this should work" 285377 pcc enableCallsIntoModule: self exampleModuleName forClasses: {self class}. 285378 "all enabled now" 285379 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285380 "not disabled!!" 285381 self 285382 should: [pcc enableCallsIntoModule: self failModuleName forClasses: {self class}] 285383 raise: TestResult error. 285384 pcc changeStatusOfFailedCalls. 285385 pcc enableCallsIntoModule: self failModuleName forClasses: {self class}. 285386 self assert: (pcc existsEnabledCallIn: self failedCallRef) 285387! ! 285388 285389!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:45'! 285390testEnableDisableCallIn 285391 | refs | 285392 refs := self methodRefsToExampleModule. 285393 "wrong call" 285394 self 285395 should: [pcc disableCallIn: self wrongCallRef] 285396 raise: TestResult error. 285397 "wrong class" 285398 self 285399 should: [pcc disableCallIn: self wrongClassRef] 285400 raise: TestResult error. 285401 "wrong call" 285402 self 285403 should: [pcc enableCallIn: self wrongCallRef] 285404 raise: TestResult error. 285405 "wrong class" 285406 self 285407 should: [pcc enableCallIn: self wrongClassRef] 285408 raise: TestResult error. 285409 "no external call" 285410 self 285411 should: [pcc enableCallIn: self noExternalCallRef] 285412 raise: TestResult error. 285413 "precondition: all enabled" 285414 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285415 "not disabled!!" 285416 self 285417 should: [refs 285418 do: [:ref1 | pcc enableCallIn: ref1]] 285419 raise: TestResult error. 285420 "disabling" 285421 refs 285422 do: [:ref2 | pcc disableCallIn: ref2]. 285423 "now all disabled" 285424 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. 285425 "not enabled!!" 285426 self 285427 should: [refs 285428 do: [:ref3 | pcc disableCallIn: ref3]] 285429 raise: TestResult error. 285430 "enabling" 285431 "now this should work" 285432 refs 285433 do: [:ref4 | pcc enableCallIn: ref4]. 285434 "all enabled now" 285435 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285436 "try caches" 285437 pcc disableEnabled. 285438 "all disabled" 285439 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. 285440 pcc enableDisabled. 285441 "all enabled" 285442 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule! ! 285443 285444!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 00:07'! 285445testEnableDisableCallInCompiledMethod 285446 "Note: >>compiledMethodsToExampleModule has to be called frequently, 285447 since the CMs are changing with a successful compile!!" 285448 "precondition: all enabled" 285449 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285450 "not disabled!!" 285451 self 285452 should: [self compiledMethodsToExampleModule 285453 do: [:cm1 | pcc enableCallInCompiledMethod: cm1]] 285454 raise: TestResult error. 285455 "disabling" 285456 self compiledMethodsToExampleModule 285457 do: [:cm2 | pcc disableCallInCompiledMethod: cm2]. 285458 "now all disabled" 285459 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. 285460 "not enabled!!" 285461 self 285462 should: [self compiledMethodsToExampleModule 285463 do: [:cm3 | pcc disableCallInCompiledMethod: cm3]] 285464 raise: TestResult error. 285465 "enabling" 285466 "now this should work" 285467 self compiledMethodsToExampleModule 285468 do: [:cm4 | pcc enableCallInCompiledMethod: cm4]. 285469 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285470 "try caches" 285471 pcc disableEnabled. 285472 "all disabled" 285473 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. 285474 pcc enableDisabled. 285475 "all enabled" 285476 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule! ! 285477 285478!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:57'! 285479testEnableDisableCallInMethodClass 285480 | sels | 285481 sels := self methodSelectorsToExampleModule. 285482 "wrong call" 285483 self 285484 should: [pcc disableCallInMethod: #nonExistingCall class: self class] 285485 raise: TestResult error. 285486 "wrong class" 285487 self 285488 should: [pcc disableCallInMethod: sels first class: Integer] 285489 raise: TestResult error. 285490 "wrong call" 285491 self 285492 should: [pcc enableCallInMethod: #nonExistingCall class: self class] 285493 raise: TestResult error. 285494 "wrong class" 285495 self 285496 should: [pcc enableCallInMethod: sels first class: Integer] 285497 raise: TestResult error. 285498 self 285499 should: [pcc enableCallInMethod: self noExternalCallSelector class: self class] 285500 raise: TestResult error. 285501 "precondition: all enabled" 285502 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285503 "not disabled!!" 285504 self 285505 should: [sels 285506 do: [:sel1 | pcc enableCallInMethod: sel1 class: self class]] 285507 raise: TestResult error. 285508 "disabling" 285509 sels 285510 do: [:sel2 | pcc disableCallInMethod: sel2 class: self class]. 285511 "now all disabled" 285512 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. 285513 "not enabled!!" 285514 self 285515 should: [sels 285516 do: [:sel3 | pcc disableCallInMethod: sel3 class: self class]] 285517 raise: TestResult error. 285518 "enabling" 285519 "now this should work" 285520 sels 285521 do: [:sel4 | pcc enableCallInMethod: sel4 class: self class]. 285522 "all enabled now" 285523 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285524 "try caches" 285525 pcc disableEnabled. 285526 "all disabled" 285527 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. 285528 pcc enableDisabled. 285529 "all enabled" 285530 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule! ! 285531 285532!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:46'! 285533testExistsCallIn 285534 self 285535 deny: (pcc existsCallIn: self noExternalCallRef). 285536 self enabledCallRefs , self disabledCallRefs , {self failedCallRef} 285537 do: [:callRef | self 285538 assert: (pcc existsCallIn: callRef)]! ! 285539 285540!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:47'! 285541testExistsDisabledCallIn 285542 self 285543 deny: (pcc existsDisabledCallIn: self noExternalCallRef). 285544 self 285545 deny: (pcc existsDisabledCallIn: self failedCallRef). 285546 self enabledCallRefs 285547 do: [:callRef | self 285548 deny: (pcc existsDisabledCallIn: callRef)]. 285549 self disabledCallRefs 285550 do: [:disabledRef | self 285551 assert: (pcc existsDisabledCallIn: disabledRef)]! ! 285552 285553!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:48'! 285554testExistsEnabledCallIn 285555 self 285556 deny: (pcc existsEnabledCallIn: self noExternalCallRef). 285557 self 285558 deny: (pcc existsEnabledCallIn: self failedCallRef). 285559 self enabledCallRefs 285560 do: [:callRef | self 285561 assert: (pcc existsEnabledCallIn: callRef)]. 285562 self disabledCallRefs 285563 do: [:disabledRef | self 285564 deny: (pcc existsEnabledCallIn: disabledRef)]! ! 285565 285566!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:49'! 285567testExistsFailedCallIn 285568 self 285569 deny: (pcc existsFailedCallIn: self noExternalCallRef). 285570 self enabledCallRefs , self disabledCallRefs 285571 do: [:callRef | self 285572 deny: (pcc existsFailedCallIn: callRef)]. 285573 self 285574 assert: (pcc existsFailedCallIn: self failedCallRef)! ! 285575 285576!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 23:25'! 285577testMethodsWithCallAndMethodsWithDisabledCall 285578 | methodRefs disabledMethodRefs enabledMethodRefs failedMethodRefs | 285579 self avoidSlowTest 285580 ifTrue: [^ self]. 285581 disabledMethodRefs := pcc methodsWithDisabledCall. 285582 self assert: disabledMethodRefs size > 0. 285583 enabledMethodRefs := pcc methodsWithEnabledCall. 285584 self assert: enabledMethodRefs size > 0. 285585 failedMethodRefs := pcc methodsWithFailedCall. 285586 self assert: failedMethodRefs size > 0. 285587 methodRefs := pcc methodsWithCall. 285588 self assert: methodRefs size = (disabledMethodRefs size + enabledMethodRefs size + failedMethodRefs size)! ! 285589 285590!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:54'! 285591testMethodsWithCallIntoModule 285592 | methodRefs | 285593 self avoidSlowTest ifTrue: [^ self]. 285594 "precondition: all enabled" 285595 pcc disableCallIn: self methodRefsToExampleModule first. 285596 methodRefs := pcc methodsWithCallIntoModule: self exampleModuleName. 285597 self assert: methodRefs size = self numOfCallsExampleModule. 285598 "postcondition" 285599 pcc enableCallIn: self methodRefsToExampleModule first! ! 285600 285601!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:32'! 285602testMethodsWithCallIntoModuleForClass 285603 "precondition: all enabled" 285604 | methodRefs | 285605 pcc disableCallIn: self methodRefsToExampleModule first. 285606 methodRefs := pcc methodsWithCallIntoModule: self exampleModuleName forClass: self class. 285607 self assert: methodRefs size = self numOfCallsExampleModule. 285608 "postcondition" 285609 pcc enableCallIn: self methodRefsToExampleModule first. 285610 methodRefs := pcc methodsWithCallIntoModule: nil forClass: self class. 285611 self 285612 assert: (methodRefs size = 2 285613 and: [| methodCoreStrings | 285614 methodCoreStrings := methodRefs 285615 collect: [:mRef | mRef methodSymbol allButFirst asString]. 285616 (methodCoreStrings includes: 'ExternalCallWithoutModule') 285617 and: [methodCoreStrings includes: 'DisabledExternalCallWithoutModule']])! ! 285618 285619!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:31'! 285620testMethodsWithCallIntoModuleForClasses 285621 "precondition: all enabled" 285622 | methodRefs | 285623 pcc disableCallIn: self methodRefsToExampleModule first. 285624 methodRefs := pcc methodsWithCallIntoModule: self exampleModuleName forClasses: {self class}. 285625 self assert: methodRefs size = self numOfCallsExampleModule. 285626 "postcondition" 285627 pcc enableCallIn: self methodRefsToExampleModule first. 285628 methodRefs := pcc methodsWithCallIntoModule: nil forClasses: {self class}. 285629 self 285630 assert: (methodRefs size = 2 285631 and: [| methodCoreStrings | 285632 methodCoreStrings := methodRefs 285633 collect: [:mRef | mRef methodSymbol allButFirst asString]. 285634 (methodCoreStrings includes: 'ExternalCallWithoutModule') 285635 and: [methodCoreStrings includes: 'DisabledExternalCallWithoutModule']])! ! 285636 285637!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:36'! 285638testMethodsWithCallX 285639 | methodRefs | 285640 self avoidSlowTest 285641 ifTrue: [^ self]. 285642 methodRefs := pcc methodsWithCall: self singularCallName. 285643 self assert: methodRefs size = 1! ! 285644 285645!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:34'! 285646testMethodsWithCallXIntoModule 285647 | methodRefs | 285648 self avoidSlowTest 285649 ifTrue: [^ self]. 285650 methodRefs := pcc methodsWithCall: self singularCallName intoModule: self moduleNameWithSingularCallName. 285651 self assert: methodRefs size = 1. 285652 methodRefs := pcc methodsWithCall: self singularCallName intoModule: self moduleNameNotWithSingularCallName. 285653 self assert: methodRefs isEmpty! ! 285654 285655!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 23:04'! 285656testMethodsWithDisabledCallIntoModule 285657 | methodRefs | 285658 self avoidSlowTest ifTrue: [^ self]. 285659 "precondition: all enabled" 285660 pcc disableCallIn: self methodRefsToExampleModule first. 285661 methodRefs := pcc methodsWithDisabledCallIntoModule: self exampleModuleName. 285662 self assert: methodRefs size = 1. 285663 "postcondition" 285664 pcc enableCallIn: self methodRefsToExampleModule first! ! 285665 285666!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:37'! 285667testMethodsWithDisabledCallIntoModuleForClass 285668 "precondition: all enabled" 285669 | methodRefs | 285670 self methodRefsToExampleModule 285671 do: [:ref | pcc disableCallIn: ref]. 285672 methodRefs := pcc methodsWithDisabledCallIntoModule: self exampleModuleName forClass: self class. 285673 self assert: methodRefs size = self numOfCallsExampleModule. 285674 "postcondition" 285675 self methodRefsToExampleModule 285676 do: [:ref | pcc enableCallIn: ref]. 285677 methodRefs := pcc methodsWithDisabledCallIntoModule: nil forClass: self class. 285678 self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'DisabledExternalCallWithoutModule')! ! 285679 285680!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:46'! 285681testMethodsWithDisabledCallIntoModuleForClasses 285682 "precondition: all enabled" 285683 | methodRefs | 285684 self methodRefsToExampleModule 285685 do: [:ref | pcc disableCallIn: ref]. 285686 methodRefs := pcc methodsWithDisabledCallIntoModule: self exampleModuleName forClasses: {self class}. 285687 self assert: methodRefs size = self numOfCallsExampleModule. 285688 "postcondition" 285689 self methodRefsToExampleModule 285690 do: [:ref | pcc enableCallIn: ref]. 285691 methodRefs := pcc methodsWithDisabledCallIntoModule: nil forClasses: {self class}. 285692 self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'DisabledExternalCallWithoutModule')! ! 285693 285694!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 23:38'! 285695testMethodsWithDisabledCallX 285696 | methodRefs | 285697 self avoidSlowTest 285698 ifTrue: [^ self]. 285699 "precondition: all enabled" 285700 pcc disableCallIn: self singularCallRef. 285701 methodRefs := pcc methodsWithDisabledCall: self singularCallName. 285702 self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self singularCallName). 285703 "postcondition" 285704 pcc enableCallIn: self singularCallRef! ! 285705 285706!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 23:42'! 285707testMethodsWithDisabledCallXIntoModule 285708 "precondition: all enabled" 285709 | methodRefs | 285710 self avoidSlowTest 285711 ifTrue: [^ self]. 285712 "precondition: all enabled" 285713 pcc disableCallIn: self singularCallRef. 285714 methodRefs := pcc methodsWithDisabledCall: self singularCallName intoModule: self moduleNameWithSingularCallName. 285715 self assert: methodRefs size = 1. 285716 methodRefs := pcc methodsWithDisabledCall: self singularCallName intoModule: self moduleNameNotWithSingularCallName. 285717 self assert: methodRefs isEmpty. 285718 "postcondition" 285719 pcc enableCallIn: self singularCallRef! ! 285720 285721!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 07:13'! 285722testMethodsWithEnabledCall 285723 | methodRefs | 285724 methodRefs := pcc methodsWithEnabledCall. 285725 self assert: methodRefs size > 0! ! 285726 285727!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 07:17'! 285728testMethodsWithEnabledCallIntoModule 285729 | methodRefs | 285730 methodRefs := pcc methodsWithEnabledCallIntoModule: self exampleModuleName. 285731 self assert: methodRefs size = self numOfCallsExampleModule! ! 285732 285733!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:43'! 285734testMethodsWithEnabledCallIntoModuleForClass 285735 "precondition: all enabled" 285736 | methodRefs | 285737 methodRefs := pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class. 285738 self assert: methodRefs size = self numOfCallsExampleModule. 285739 methodRefs := pcc methodsWithEnabledCallIntoModule: nil forClass: self class. 285740 self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'ExternalCallWithoutModule')! ! 285741 285742!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 07:12'! 285743testMethodsWithEnabledCallIntoModuleForClasses 285744 "precondition: all enabled" 285745 | methodRefs | 285746 methodRefs := pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClasses: {self class}. 285747 self assert: methodRefs size = self numOfCallsExampleModule. 285748 methodRefs := pcc methodsWithEnabledCallIntoModule: nil forClasses: {self class}. 285749 self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'ExternalCallWithoutModule')! ! 285750 285751!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:16'! 285752testMethodsWithEnabledCallX 285753 | methodRefs | 285754 methodRefs := pcc methodsWithEnabledCall: self singularCallName. 285755 self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self singularCallName)! ! 285756 285757!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 07:17'! 285758testMethodsWithEnabledCallXIntoModule 285759 "precondition: all enabled" 285760 | methodRefs | 285761 methodRefs := pcc methodsWithEnabledCall: self singularCallName intoModule: self moduleNameWithSingularCallName. 285762 self assert: methodRefs size = 1. 285763 methodRefs := pcc methodsWithEnabledCall: self singularCallName intoModule: self moduleNameNotWithSingularCallName. 285764 self assert: methodRefs isEmpty! ! 285765 285766!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:07'! 285767testMethodsWithFailedCall 285768 | methodRefs | 285769 methodRefs := pcc methodsWithFailedCall. 285770 self assert: methodRefs size >= 1 & ((methodRefs 285771 select: [:mRef | mRef methodSymbol = self failedCallSelector]) size = 1)! ! 285772 285773!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:11'! 285774testMethodsWithFailedCallForClass 285775 | methodRefs | 285776 methodRefs := pcc methodsWithFailedCallForClass: self class. 285777 self assert: methodRefs size = 1 & (methodRefs asArray first methodSymbol = self failedCallSelector)! ! 285778 285779!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 02:54'! 285780testMethodsWithFailedCallIntoModule 285781 | methodRefs | 285782 methodRefs := pcc methodsWithFailedCallIntoModule: self failModuleName. 285783 self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self failedCallSelector)! ! 285784 285785!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:13'! 285786testMethodsWithFailedCallIntoModuleForClass 285787 | methodRefs | 285788 methodRefs := pcc methodsWithFailedCallIntoModule: self failModuleName forClass: self class. 285789 self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self failedCallSelector)! ! 285790 285791!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:58'! 285792testSwitchPrimCallOffOn 285793 | res | 285794 pcc disableCallInMethod: self realExternalCallOrPrimitiveFailedSelector class: self class. 285795 self 285796 should: [self perform: self realExternalCallOrPrimitiveFailedSelector] 285797 raise: TestResult error. 285798 pcc enableCallInMethod: self realExternalCallOrPrimitiveFailedSelector class: self class. 285799 self 285800 shouldnt: [res := self perform: self realExternalCallOrPrimitiveFailedSelector] 285801 raise: TestResult error. 285802 self assert: res isString! ! 285803 285804!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:46'! 285805testSwitchStored 285806 | refs | 285807 "all enabled, precondition" 285808 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285809 refs := self methodRefsToExampleModule. 285810 "fill cache" 285811 refs 285812 do: [:ref | pcc disableCallIn: ref]. 285813 "enable one" 285814 pcc enableCallIn: refs first. 285815 self 285816 assert: (pcc existsEnabledCallIn: refs first). 285817 self 285818 assert: (pcc existsDisabledCallIn: refs second). 285819 "switching" 285820 pcc switchStored. 285821 "now the checks go vice versa" 285822 self 285823 assert: (pcc existsDisabledCallIn: refs first). 285824 self 285825 assert: (pcc existsEnabledCallIn: refs second). 285826 pcc enableCallIn: refs first. 285827 self 285828 assert: (pcc existsEnabledCallIn: refs first)! ! 285829 285830!PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:46'! 285831testTryCaches 285832 | refs | 285833 "all enabled, precondition" 285834 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285835 refs := self methodRefsToExampleModule. 285836 "fill cache" 285837 refs 285838 do: [:ref | pcc disableCallIn: ref]. 285839 "try caches" 285840 pcc enableDisabled. 285841 "all enabled" 285842 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. 285843 pcc disableEnabled. 285844 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. 285845 pcc enableDisabled. 285846 "all enabled, postcondition" 285847 self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule! ! 285848 285849"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 285850 285851PrimCallControllerAbstractTest class 285852 instanceVariableNames: ''! 285853 285854!PrimCallControllerAbstractTest class methodsFor: 'testing' stamp: 'sr 6/7/2004 11:59'! 285855isAbstract 285856 ^ true! ! 285857MessageDialogWindow subclass: #ProceedDialogWindow 285858 instanceVariableNames: '' 285859 classVariableNames: '' 285860 poolDictionaries: '' 285861 category: 'Polymorph-Widgets-Windows'! 285862!ProceedDialogWindow commentStamp: 'gvc 5/18/2007 12:22' prior: 0! 285863Yes/no dialog. Test result as to whether the dialog is cancelled (no) or not (yes).! 285864 285865 285866!ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 16:37'! 285867handlesKeyboard: evt 285868 "Return true if the receiver wishes to handle the given keyboard event" 285869 285870 (super handlesKeyboard: evt) ifTrue: [^true]. 285871 ^evt keyCharacter = $y or: [ 285872 evt keyCharacter = $n] 285873 ! ! 285874 285875!ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 10:30'! 285876icon 285877 "Answer an icon for the receiver." 285878 285879 ^self theme questionIcon! ! 285880 285881!ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 16:38'! 285882keyStroke: evt 285883 "Additionally check for y and n keys (aliases for ok and cancel)." 285884 285885 (super keyStroke: evt) ifTrue: [^true]. 285886 evt keyCharacter = $y ifTrue: [self yes. ^true]. 285887 evt keyCharacter = $n ifTrue: [self no. ^true]. 285888 ^false! ! 285889 285890!ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 13:50'! 285891newButtons 285892 "Answer new buttons as appropriate." 285893 285894 ^{self newOKButton. self newCancelButton isDefault: true}! ! 285895 285896!ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2007 17:34'! 285897no 285898 "Answer no." 285899 285900 self cancel! ! 285901 285902!ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2007 17:34'! 285903yes 285904 "Answer yes." 285905 285906 self ok! ! 285907 285908"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 285909 285910ProceedDialogWindow class 285911 instanceVariableNames: ''! 285912 285913!ProceedDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/21/2007 12:43'! 285914taskbarIcon 285915 "Answer the icon for the receiver in a task bar." 285916 285917 ^UITheme current smallQuestionIcon! ! 285918Link subclass: #Process 285919 instanceVariableNames: 'suspendedContext priority myList errorHandler name env' 285920 classVariableNames: '' 285921 poolDictionaries: '' 285922 category: 'Kernel-Processes'! 285923!Process commentStamp: '<historical>' prior: 0! 285924I represent an independent path of control in the system. This path of control may be stopped (by sending the message suspend) in such a way that it can later be restarted (by sending the message resume). When any one of several paths of control can be advanced, the single instance of ProcessorScheduler named Processor determines which one will actually be advanced partly using the value of priority. 285925 285926(If anyone ever makes a subclass of Process, be sure to use allSubInstances in anyProcessesAbove:.)! 285927 285928 285929!Process methodsFor: 'accessing' stamp: 'ajh 1/24/2003 14:53'! 285930calleeOf: aContext 285931 "Return the context whose sender is aContext. Return nil if aContext is on top. Raise error if aContext is not in process chain." 285932 285933 suspendedContext == aContext ifTrue: [^ nil]. 285934 ^ (suspendedContext findContextSuchThat: [:c | c sender == aContext]) 285935 ifNil: [self error: 'aContext not in process chain']! ! 285936 285937!Process methodsFor: 'accessing' stamp: 'ajh 1/27/2003 18:39'! 285938copyStack 285939 285940 ^ self copy install: suspendedContext copyStack! ! 285941 285942!Process methodsFor: 'accessing' stamp: 'ajh 1/24/2003 19:44'! 285943isActiveProcess 285944 285945 ^ self == Processor activeProcess! ! 285946 285947!Process methodsFor: 'accessing' stamp: 'dkh 4/25/2009 13:34'! 285948isSuspended 285949 ^myList isNil or: [ myList isEmpty ]! ! 285950 285951!Process methodsFor: 'accessing' stamp: 'bgf 12/31/2008 11:56'! 285952isTerminated 285953 285954 self isActiveProcess ifTrue: [^ false]. 285955 ^suspendedContext isNil 285956 or: ["If the suspendedContext is the bottomContext it is the block in Process>>newProcess. 285957 If so, and the pc is greater than the startpc, the bock has alrteady sent and returned 285958 from value and there is nothing more to do." 285959 suspendedContext isBottomContext 285960 and: [suspendedContext pc > suspendedContext startpc]]! ! 285961 285962!Process methodsFor: 'accessing' stamp: 'svp 12/5/2002 14:42'! 285963name 285964 285965 ^name ifNil: [ self hash asString forceTo: 5 paddingStartWith: $ ]! ! 285966 285967!Process methodsFor: 'accessing' stamp: 'svp 12/5/2002 14:42'! 285968name: aString 285969 285970 name := aString! ! 285971 285972!Process methodsFor: 'accessing' stamp: 'ar 12/7/2007 17:06'! 285973offList 285974 "OBSOLETE. Process>>suspend will atomically reset myList if the process is suspended. 285975 There should never be a need to send #offList but some older users may not be aware 285976 of the changed semantics to suspend and may try the old hickadidoo seen here: 285977 285978 (suspendingList := process suspendingList) == nil 285979 ifTrue: [process == Processor activeProcess ifTrue: [process suspend]] 285980 ifFalse: [suspendingList remove: process ifAbsent:[]. 285981 process offList]. 285982 285983 Usages like the above should be replaced by a simple 'process suspend' " 285984 myList := nil! ! 285985 285986!Process methodsFor: 'accessing'! 285987priority 285988 "Answer the priority of the receiver." 285989 285990 ^priority! ! 285991 285992!Process methodsFor: 'accessing' stamp: 'ar 7/8/2001 17:04'! 285993priority: anInteger 285994 "Set the receiver's priority to anInteger." 285995 (anInteger >= Processor lowestPriority and:[anInteger <= Processor highestPriority]) 285996 ifTrue: [priority := anInteger] 285997 ifFalse: [self error: 'Invalid priority: ', anInteger printString]! ! 285998 285999!Process methodsFor: 'accessing'! 286000suspendedContext 286001 "Answer the context the receiver has suspended." 286002 286003 ^suspendedContext! ! 286004 286005!Process methodsFor: 'accessing'! 286006suspendingList 286007 "Answer the list on which the receiver has been suspended." 286008 286009 ^myList! ! 286010 286011 286012!Process methodsFor: 'changing process state' stamp: 'tpr 2/14/2001 10:00'! 286013primitiveResume 286014 "Primitive. Allow the process that the receiver represents to continue. Put 286015 the receiver in line to become the activeProcess. Fail if the receiver is 286016 already waiting in a queue (in a Semaphore or ProcessScheduler). 286017 Essential. See Object documentation whatIsAPrimitive." 286018 286019 <primitive: 87> 286020 self primitiveFailed! ! 286021 286022!Process methodsFor: 'changing process state' stamp: 'tpr 2/14/2001 10:03'! 286023resume 286024 "Allow the process that the receiver represents to continue. Put 286025 the receiver in line to become the activeProcess. Check for a nil 286026 suspendedContext, which indicates a previously terminated Process that 286027 would cause a vm crash if the resume attempt were permitted" 286028 286029 suspendedContext ifNil: [^ self primitiveFailed]. 286030 ^ self primitiveResume! ! 286031 286032!Process methodsFor: 'changing process state' stamp: 'ajh 1/23/2003 23:02'! 286033run 286034 "Suspend current process and execute self instead" 286035 286036 | proc | 286037 proc := Processor activeProcess. 286038 [ proc suspend. 286039 self resume. 286040 ] forkAt: Processor highestPriority! ! 286041 286042!Process methodsFor: 'changing process state' stamp: 'ar 12/7/2007 17:10'! 286043suspend 286044 "Primitive. Stop the process that the receiver represents in such a way 286045 that it can be restarted at a later time (by sending the receiver the 286046 message resume). If the receiver represents the activeProcess, suspend it. 286047 Otherwise remove the receiver from the list of waiting processes. 286048 The return value of this method is the list the receiver was previously on (if any)." 286049 | oldList | 286050 <primitive: 88> 286051 "This is fallback code for VMs which only support the old primitiveSuspend which 286052 would not accept processes that are waiting to be run." 286053 myList ifNil:[^nil]. "this allows us to use suspend multiple times" 286054 oldList := myList. 286055 myList := nil. 286056 oldList remove: self ifAbsent:[]. 286057 ^oldList! ! 286058 286059!Process methodsFor: 'changing process state' stamp: 'ar 3/23/2009 20:04'! 286060terminate 286061 "Stop the process that the receiver represents forever. Unwind to execute pending ensure:/ifCurtailed: blocks before terminating." 286062 286063 | ctxt unwindBlock oldList | 286064 self isActiveProcess ifTrue: [ 286065 ctxt := thisContext. 286066 [ ctxt := ctxt findNextUnwindContextUpTo: nil. 286067 ctxt isNil 286068 ] whileFalse: [ 286069 unwindBlock := ctxt tempAt: 1. 286070 unwindBlock ifNotNil: [ 286071 ctxt tempAt: 1 put: nil. 286072 thisContext terminateTo: ctxt. 286073 unwindBlock value]. 286074 ]. 286075 thisContext terminateTo: nil. 286076 self suspend. 286077 ] ifFalse:[ 286078 myList ifNotNil:[oldList := self suspend]. 286079 suspendedContext ifNotNil:[ 286080 "Figure out if we are terminating the process while waiting in Semaphore>>critical: 286081 In this case, pop the suspendedContext so that we leave the ensure: block inside 286082 Semaphore>>critical: without signaling the semaphore." 286083 (oldList class == Semaphore and:[ 286084 suspendedContext method == (Semaphore compiledMethodAt: #critical:)]) ifTrue:[ 286085 suspendedContext := suspendedContext home. 286086 ]. 286087 ctxt := self popTo: suspendedContext bottomContext. 286088 ctxt == suspendedContext bottomContext ifFalse: [ 286089 self debug: ctxt title: 'Unwind error during termination']]. 286090 ]. 286091! ! 286092 286093 286094!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 16:14'! 286095activateReturn: aContext value: value 286096 "Activate 'aContext return: value', so execution will return to aContext's sender" 286097 286098 ^ suspendedContext := suspendedContext activateReturn: aContext value: value! ! 286099 286100!Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:13'! 286101complete: aContext 286102 "Run self until aContext is popped or an unhandled error is raised. Return self's new top context, unless an unhandled error was raised then return the signaler context (rather than open a debugger)." 286103 286104 | ctxt pair error | 286105 ctxt := suspendedContext. 286106 suspendedContext := nil. "disable this process while running its stack in active process below" 286107 pair := ctxt runUntilErrorOrReturnFrom: aContext. 286108 suspendedContext := pair first. 286109 error := pair second. 286110 error ifNotNil: [^ error signalerContext]. 286111 ^ suspendedContext! ! 286112 286113!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 10:16'! 286114completeStep: aContext 286115 "Resume self until aContext is on top, or if already on top, complete next step" 286116 286117 | callee | 286118 self suspendedContext == aContext ifFalse: [ 286119 ^ self complete: (self calleeOf: aContext)]. 286120 callee := self step. 286121 callee == aContext ifTrue: [^ callee]. 286122 aContext isDead ifTrue: [^ self suspendedContext]. "returned" 286123 ^ self complete: callee "finish send"! ! 286124 286125!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/23/2003 21:43'! 286126completeTo: aContext 286127 "Resume self until aContext is on top" 286128 286129 self suspendedContext == aContext ifTrue: [^ aContext]. 286130 ^ self complete: (self calleeOf: aContext)! ! 286131 286132!Process methodsFor: 'changing suspended state'! 286133install: aContext 286134 "Replace the suspendedContext with aContext." 286135 286136 self == Processor activeProcess 286137 ifTrue: [^self error: 'The active process cannot install contexts']. 286138 suspendedContext := aContext! ! 286139 286140!Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:26'! 286141popTo: aContext 286142 "Pop self down to aContext by remote returning from aContext's callee. Unwind blocks will be executed on the way. 286143 This is done by pushing a new context on top which executes 'aContext callee return' then resuming self until aContext is reached. This way any errors raised in an unwind block will get handled by senders in self and not by senders in the activeProcess. 286144 If an unwind block raises an error that is not handled then the popping stops at the error and the signalling context is returned, othewise aContext is returned." 286145 286146 | callee | 286147 self == Processor activeProcess 286148 ifTrue: [^ self error: 'The active process cannot pop contexts']. 286149 callee := (self calleeOf: aContext) ifNil: [^ aContext]. "aContext is on top" 286150 ^ self return: callee value: callee receiver! ! 286151 286152!Process methodsFor: 'changing suspended state' stamp: 'gk 12/18/2003 13:09'! 286153popTo: aContext value: aValue 286154 "Replace the suspendedContext with aContext, releasing all contexts 286155 between the currently suspendedContext and it." 286156 286157 | callee | 286158 self == Processor activeProcess 286159 ifTrue: [^ self error: 'The active process cannot pop contexts']. 286160 callee := (self calleeOf: aContext) ifNil: [^ self]. "aContext is on top" 286161 self return: callee value: aValue! ! 286162 286163!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/23/2003 20:40'! 286164restartTop 286165 "Rollback top context and replace with new method. Assumes self is suspended" 286166 286167 suspendedContext privRefresh! ! 286168 286169!Process methodsFor: 'changing suspended state' stamp: 'nk 7/10/2004 11:16'! 286170restartTopWith: method 286171 "Rollback top context and replace with new method. Assumes self is suspended" 286172 286173 method isQuick 286174 ifTrue: [ self popTo: suspendedContext sender ] 286175 ifFalse: [ suspendedContext privRefreshWith: method ]. 286176! ! 286177 286178!Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:26'! 286179return: aContext value: value 286180 "Pop thread down to aContext's sender. Execute any unwind blocks on the way. See #popTo: comment and #runUntilErrorOrReturnFrom: for more details." 286181 286182 suspendedContext == aContext ifTrue: [ 286183 ^ suspendedContext := aContext return: value from: aContext]. 286184 self activateReturn: aContext value: value. 286185 ^ self complete: aContext. 286186! ! 286187 286188!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 10:17'! 286189step 286190 286191 ^ suspendedContext := suspendedContext step! ! 286192 286193!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/31/2003 14:45'! 286194step: aContext 286195 "Resume self until aContext is on top, or if already on top, do next step" 286196 286197 ^ self suspendedContext == aContext 286198 ifTrue: [self step] 286199 ifFalse: [self complete: (self calleeOf: aContext)]! ! 286200 286201!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/23/2003 22:06'! 286202stepToCallee 286203 "Step until top context changes" 286204 286205 | ctxt | 286206 ctxt := suspendedContext. 286207 [ctxt == suspendedContext] whileTrue: [ 286208 suspendedContext := suspendedContext step]. 286209 ^ suspendedContext! ! 286210 286211!Process methodsFor: 'changing suspended state' stamp: 'ajh 7/18/2003 22:13'! 286212stepToHome: aContext 286213 "Resume self until the home of top context is aContext. Top context may be a block context." 286214 286215 | home ctxt | 286216 home := aContext home. 286217 [ ctxt := self step. 286218 home == ctxt home. 286219 ] whileFalse: [ 286220 home isDead ifTrue: [^ self suspendedContext]. 286221 ]. 286222 ^ self suspendedContext! ! 286223 286224!Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 10:17'! 286225stepToSendOrReturn 286226 286227 ^ suspendedContext := suspendedContext stepToSendOrReturn! ! 286228 286229 286230!Process methodsFor: 'debugging' stamp: 'nk 10/29/2000 13:43'! 286231debug 286232 self debugWithTitle: 'Debug'.! ! 286233 286234!Process methodsFor: 'debugging' stamp: 'ajh 7/20/2003 23:54'! 286235debug: context title: title 286236 "Open debugger on self with context shown on top" 286237 286238 self debug: context title: title full: false. 286239! ! 286240 286241!Process methodsFor: 'debugging' stamp: 'ar 9/27/2005 20:32'! 286242debug: context title: title full: bool 286243 "Open debugger on self with context shown on top" 286244 286245 | topCtxt | 286246 topCtxt := self isActiveProcess ifTrue: [thisContext] ifFalse: [self suspendedContext]. 286247 (topCtxt hasContext: context) ifFalse: [^ self error: 'context not in process']. 286248 ToolSet debug: self context: context label: title contents: nil fullView: bool. 286249! ! 286250 286251!Process methodsFor: 'debugging' stamp: 'ajh 7/20/2003 23:55'! 286252debugWithTitle: title 286253 "Open debugger on self" 286254 286255 | context | 286256 context := self isActiveProcess ifTrue: [thisContext] ifFalse: [self suspendedContext]. 286257 self debug: context title: title full: true. 286258! ! 286259 286260 286261!Process methodsFor: 'error handling'! 286262errorHandler 286263 ^ errorHandler! ! 286264 286265!Process methodsFor: 'error handling'! 286266errorHandler: aBlock 286267 errorHandler := aBlock! ! 286268 286269 286270!Process methodsFor: 'objects from disk' stamp: 'tk 9/28/2000 15:46'! 286271objectForDataStream: refStrm 286272 "I am not allowed to be written on an object file." 286273 286274 refStrm replace: self with: nil. 286275 ^ nil! ! 286276 286277 286278!Process methodsFor: 'printing' stamp: 'nk 10/28/2000 07:33'! 286279browserPrintString 286280 ^self browserPrintStringWith: suspendedContext! ! 286281 286282!Process methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 10:51'! 286283browserPrintStringWith: anObject 286284 | stream | 286285 stream := (String new: 100) writeStream. 286286 stream nextPut: $(. 286287 priority printOn: stream. 286288 self isSuspended 286289 ifTrue: [stream nextPut: $s]. 286290 stream nextPutAll: ') '. 286291 stream nextPutAll: self name. 286292 stream nextPut: $:. 286293 stream space. 286294 stream nextPutAll: anObject asString. 286295 ^ stream contents! ! 286296 286297!Process methodsFor: 'printing' stamp: 'ajh 10/2/2001 14:36'! 286298longPrintOn: stream 286299 286300 | ctxt | 286301 super printOn: stream. 286302 stream cr. 286303 ctxt := self suspendedContext. 286304 [ctxt == nil] whileFalse: [ 286305 stream space. 286306 ctxt printOn: stream. 286307 stream cr. 286308 ctxt := ctxt sender. 286309 ]. 286310! ! 286311 286312!Process methodsFor: 'printing'! 286313printOn: aStream 286314 286315 super printOn: aStream. 286316 aStream nextPutAll: ' in '. 286317 suspendedContext printOn: aStream! ! 286318 286319 286320!Process methodsFor: 'process specific' stamp: 'GiovanniCorriga 8/30/2009 15:42'! 286321environmentAt: key 286322 ^ self environmentAt: key ifAbsent: [self environmentKeyNotFound]! ! 286323 286324!Process methodsFor: 'process specific' stamp: 'mvl 3/13/2007 12:24'! 286325environmentAt: key ifAbsent: aBlock 286326 env ifNil: [ ^ aBlock value ]. 286327 ^env at: key ifAbsent: aBlock.! ! 286328 286329!Process methodsFor: 'process specific' stamp: 'GiovanniCorriga 8/30/2009 15:29'! 286330environmentAt: key put: value 286331 env ifNil: [ env := Dictionary new ]. 286332 ^ env at: key put: value.! ! 286333 286334!Process methodsFor: 'process specific' stamp: 'GiovanniCorriga 8/30/2009 15:43'! 286335environmentRemoveKey: key 286336 ^ self environmentRemoveKey: key ifAbsent: [self environmentKeyNotFound]! ! 286337 286338!Process methodsFor: 'process specific' stamp: 'GiovanniCorriga 8/30/2009 15:37'! 286339environmentRemoveKey: key ifAbsent: errorBlock 286340 env ifNil: [^ errorBlock value]. 286341 ^ env removeKey: key ifAbsent: errorBlock! ! 286342 286343 286344!Process methodsFor: 'signaling' stamp: 'svp 9/19/2003 18:41'! 286345pvtSignal: anException list: aList 286346 "Private. This method is used to signal an exception from another 286347 process...the receiver must be the active process. If the receiver 286348 was previously waiting on a Semaphore, then return the process 286349 to the waiting state after signaling the exception and if the Semaphore 286350 has not been signaled in the interim" 286351 286352 "Since this method is not called in a normal way, we need to take care 286353 that it doesn't directly return to the caller (because I believe that could 286354 have the potential to push an unwanted object on the caller's stack)." 286355 286356 | blocker | 286357 self isActiveProcess ifFalse: [^self]. 286358 anException signal. 286359 blocker := Semaphore new. 286360 [self suspend. 286361 suspendedContext := suspendedContext swapSender: nil. 286362 aList class == Semaphore 286363 ifTrue: 286364 [aList isSignaled 286365 ifTrue: 286366 [aList wait. "Consume the signal that would have restarted the receiver" 286367 self resume] 286368 ifFalse: 286369 ["Add us back to the Semaphore's list (and remain blocked)" 286370 myList := aList. 286371 aList add: self]] 286372 ifFalse: [self resume]] fork. 286373 blocker wait. 286374 286375 286376! ! 286377 286378!Process methodsFor: 'signaling' stamp: 'ar 12/7/2007 17:09'! 286379signalException: anException 286380 "Signal an exception in the receiver process...if the receiver is currently 286381 suspended, the exception will get signaled when the receiver is resumed. If 286382 the receiver is blocked on a Semaphore, it will be immediately re-awakened 286383 and the exception will be signaled; if the exception is resumed, then the receiver 286384 will return to a blocked state unless the blocking Semaphore has excess signals" 286385 | oldList | 286386 "If we are the active process, go ahead and signal the exception" 286387 self isActiveProcess ifTrue: [^anException signal]. 286388 286389 "Suspend myself first to ensure that I won't run away in the 286390 midst of the following modifications." 286391 myList ifNotNil:[oldList := self suspend]. 286392 286393 "Add a new method context to the stack that will signal the exception" 286394 suspendedContext := MethodContext 286395 sender: suspendedContext 286396 receiver: self 286397 method: (self class lookupSelector: #pvtSignal:list:) 286398 arguments: (Array with: anException with: oldList). 286399 286400 "If we are on a list to run, then suspend and restart the receiver 286401 (this lets the receiver run if it is currently blocked on a semaphore). If 286402 we are not on a list to be run (i.e. this process is suspended), then when the 286403 process is resumed, it will signal the exception" 286404 286405 oldList ifNotNil: [self resume]. 286406! ! 286407 286408 286409!Process methodsFor: 'private' stamp: 'GiovanniCorriga 8/30/2009 15:40'! 286410environmentKeyNotFound 286411 self error: 'Environment key not found'! ! 286412 286413!Process methodsFor: 'private'! 286414suspendedContext: aContext 286415 286416 suspendedContext := aContext! ! 286417 286418"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 286419 286420Process class 286421 instanceVariableNames: ''! 286422 286423!Process class methodsFor: 'instance creation'! 286424forContext: aContext priority: anInteger 286425 "Answer an instance of me that has suspended aContext at priority 286426 anInteger." 286427 286428 | newProcess | 286429 newProcess := self new. 286430 newProcess suspendedContext: aContext. 286431 newProcess priority: anInteger. 286432 ^newProcess! ! 286433Model subclass: #ProcessBrowser 286434 instanceVariableNames: 'selectedProcess selectedContext methodText processList processListIndex stackList stackListIndex sourceMap selectedClass selectedSelector searchString autoUpdateProcess deferredMessageRecipient lastUpdate startedCPUWatcher' 286435 classVariableNames: 'Browsers SuspendedProcesses WellKnownProcesses' 286436 poolDictionaries: '' 286437 category: 'Tools-Process Browser'! 286438!ProcessBrowser commentStamp: '<historical>' prior: 0! 286439Change Set: ProcessBrowser 286440Date: 14 March 2000 286441Author: Ned Konz 286442 286443email: ned@bike-nomad.com 286444 286445This is distributed under the Squeak License. 286446 286447Added 14 March: 286448 CPUWatcher integration 286449 automatically start and stop CPUWatcher 286450 added CPUWatcher to process list menu 286451 286452Added 29 October: 286453 MVC version 286454 2.8, 2.7 compatibility 286455 rearranged menus 286456 added pointer inspection and chasing 286457 added suspend/resume 286458 recognized more well-known processes 286459 misc. bug fixes 286460 286461Added 26 October: highlight pc in source code 286462Added 27 October: added 'signal semaphore' 286463added 'inspect receiver', 'explore receiver', 'message tally' to stack list menu 286464added 'find context', 'next context' to process list menu 286465added 'change priority' and 'debug' choices to process list menu 286466 28646727 October mods by Bob Arning: 286468 286469alters process display in Ned's ProcessBrowser to 286470- show process priority 286471- drop 'a Process in' that appears on each line 286472- show in priority order 286473- prettier names for known processes 286474- fix to Utilities to forget update downloading process when it ends (1 less dead 286475process) 286476- correct stack dump for the active process 286477! 286478 286479 286480!ProcessBrowser methodsFor: 'accessing'! 286481processList 286482 ^ processList! ! 286483 286484!ProcessBrowser methodsFor: 'accessing'! 286485processListIndex 286486 ^ processListIndex! ! 286487 286488!ProcessBrowser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 286489processListIndex: index 286490 processListIndex := index. 286491 selectedProcess := processList 286492 at: index 286493 ifAbsent: []. 286494 self updateStackList. 286495 self changed: #processListIndex.! ! 286496 286497!ProcessBrowser methodsFor: 'accessing' stamp: 'md 2/17/2006 09:32'! 286498selectedClass 286499 "Answer the class in which the currently selected context's method was 286500 found." 286501 ^ selectedClass 286502 ifNil: [selectedClass := selectedContext receiver 286503 ifNil: [selectedSelector := selectedContext method selector. 286504 selectedContext method methodClass] 286505 ifNotNil: [selectedContext methodClass]]! ! 286506 286507!ProcessBrowser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 286508selectedMethod 286509 ^ methodText ifNil: [methodText := selectedContext 286510 ifNil: [''] 286511 ifNotNil: [| pcRange | 286512 methodText := [ selectedContext sourceCode ] 286513 ifError: [ :err :rcvr | 'error getting method text' ]. 286514 pcRange := self pcRange. 286515 methodText asText 286516 addAttribute: TextColor red 286517 from: pcRange first 286518 to: pcRange last; 286519 286520 addAttribute: TextEmphasis bold 286521 from: pcRange first 286522 to: pcRange last]]! ! 286523 286524!ProcessBrowser methodsFor: 'accessing' stamp: 'md 2/17/2006 12:07'! 286525selectedSelector 286526 "Answer the class in which the currently selected context's method was 286527 found." 286528 ^ selectedSelector 286529 ifNil: [selectedSelector := selectedContext receiver 286530 ifNil: [selectedClass := selectedContext method methodClass 286531 selectedContext method selector] 286532 ifNotNil: [selectedContext selector]]! ! 286533 286534!ProcessBrowser methodsFor: 'accessing'! 286535stackList 286536 ^ stackList! ! 286537 286538!ProcessBrowser methodsFor: 'accessing'! 286539stackListIndex 286540 ^ stackListIndex! ! 286541 286542!ProcessBrowser methodsFor: 'accessing' stamp: 'eem 6/12/2008 12:41'! 286543stackListIndex: index 286544 stackListIndex := index. 286545 selectedContext := (stackList notNil 286546 and: [index > 0]) ifTrue: 286547 [stackList at: index ifAbsent: []]. 286548 selectedClass := nil. 286549 selectedSelector := nil. 286550 methodText := nil. 286551 self changed: #stackListIndex. 286552 self changed: #selectedMethod! ! 286553 286554!ProcessBrowser methodsFor: 'accessing' stamp: 'nk 10/28/2000 08:36'! 286555text 286556 ^methodText! ! 286557 286558 286559!ProcessBrowser methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:15'! 286560initialize 286561 super initialize. 286562 methodText := ''. 286563 stackListIndex := 0. 286564 searchString := ''. 286565 lastUpdate := 0. 286566 startedCPUWatcher := Preferences cpuWatcherEnabled and: [ self startCPUWatcher ]. 286567 self updateProcessList; processListIndex: 1! ! 286568 286569!ProcessBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 286570startCPUWatcher 286571 "Answers whether I started the CPUWatcher" 286572 286573 | pw | 286574 pw := Smalltalk at: #CPUWatcher ifAbsent: [ ^self ]. 286575 pw ifNotNil: [ 286576 pw isMonitoring ifFalse: [ 286577 pw startMonitoringPeriod: 5 rate: 100 threshold: 0.85. 286578 self setUpdateCallbackAfter: 7. 286579 ^true 286580 ] 286581 ]. 286582 ^false 286583! ! 286584 286585!ProcessBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 286586stopCPUWatcher 286587 | pw | 286588 pw := Smalltalk at: #CPUWatcher ifAbsent: [ ^self ]. 286589 pw ifNotNil: [ 286590 pw stopMonitoring. 286591 self updateProcessList. 286592 startedCPUWatcher := false. "so a manual restart won't be killed later" 286593 ] 286594! ! 286595 286596!ProcessBrowser methodsFor: 'initialization' stamp: 'nk 3/14/2001 08:03'! 286597windowIsClosing 286598 startedCPUWatcher ifTrue: [ CPUWatcher stopMonitoring ]! ! 286599 286600 286601!ProcessBrowser methodsFor: 'message handling' stamp: 'nk 10/28/2000 20:53'! 286602perform: selector orSendTo: otherTarget 286603 "Selector was just chosen from a menu by a user. If can respond, then 286604 perform it on myself. If not, send it to otherTarget, presumably the 286605 editPane from which the menu was invoked." 286606 (self respondsTo: selector) 286607 ifTrue: [^ self perform: selector] 286608 ifFalse: [^ super perform: selector orSendTo: otherTarget]! ! 286609 286610 286611!ProcessBrowser methodsFor: 'process actions' stamp: 'DamienCassou 9/29/2009 13:07'! 286612changePriority 286613 | str newPriority nameAndRules | 286614 nameAndRules := self nameAndRulesForSelectedProcess. 286615 nameAndRules third 286616 ifFalse: [self inform: 'Nope, won''t change priority of ' , nameAndRules first. 286617 ^ self]. 286618 str := UIManager default 286619 request: 'New priority' 286620 initialAnswer: selectedProcess priority asString. 286621 str ifNil: [str := String new]. 286622 newPriority := str asNumber asInteger. 286623 newPriority 286624 ifNil: [^ self]. 286625 (newPriority < 1 286626 or: [newPriority > Processor highestPriority]) 286627 ifTrue: [self inform: 'Bad priority'. 286628 ^ self]. 286629 self class setProcess: selectedProcess toPriority: newPriority. 286630 self updateProcessList! ! 286631 286632!ProcessBrowser methodsFor: 'process actions' stamp: 'sd 11/20/2005 21:27'! 286633chasePointers 286634 | saved | 286635 selectedProcess 286636 ifNil: [^ self]. 286637 saved := selectedProcess. 286638 [selectedProcess := nil. 286639 (Smalltalk includesKey: #PointerFinder) 286640 ifTrue: [PointerFinder on: saved] 286641 ifFalse: [self inspectPointers]] 286642 ensure: [selectedProcess := saved]! ! 286643 286644!ProcessBrowser methodsFor: 'process actions' stamp: 'sd 11/20/2005 21:27'! 286645debugProcess 286646 | nameAndRules | 286647 nameAndRules := self nameAndRulesForSelectedProcess. 286648 nameAndRules third 286649 ifFalse: [self inform: 'Nope, won''t debug ' , nameAndRules first. 286650 ^ self]. 286651 self class debugProcess: selectedProcess.! ! 286652 286653!ProcessBrowser methodsFor: 'process actions' stamp: 'Alexandre.Bergel 7/4/2009 11:10'! 286654inspectPointers 286655 | tc pointers | 286656 selectedProcess ifNil: [^self]. 286657 tc := thisContext. 286658 pointers := PointerFinder pointersTo: selectedProcess 286659 except: { 286660 self processList. 286661 tc. 286662 self}. 286663 pointers isEmpty ifTrue: [^self]. 286664 OrderedCollectionInspector 286665 openOn: pointers 286666 withEvalPane: false 286667 withLabel: 'Objects pointing to ' , selectedProcess browserPrintString! ! 286668 286669!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 3/8/2001 13:35'! 286670nameAndRulesFor: aProcess 286671 "Answer a nickname and two flags: allow-stop, and allow-debug" 286672 aProcess == autoUpdateProcess ifTrue: [ ^{'my auto-update process'. true. true} ]. 286673 ^self class nameAndRulesFor: aProcess 286674! ! 286675 286676!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/28/2000 20:31'! 286677nameAndRulesForSelectedProcess 286678 "Answer a nickname and two flags: allow-stop, and allow-debug" 286679 ^self nameAndRulesFor: selectedProcess! ! 286680 286681!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 3/8/2001 13:23'! 286682resumeProcess 286683 selectedProcess 286684 ifNil: [^ self]. 286685 self class resumeProcess: selectedProcess. 286686 self updateProcessList! ! 286687 286688!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 09:58'! 286689signalSemaphore 286690 (selectedProcess suspendingList isKindOf: Semaphore) 286691 ifFalse: [^ self]. 286692 [selectedProcess suspendingList signal] fork. 286693 (Delay forMilliseconds: 300) wait. 286694 "Hate to make the UI wait, but it's convenient..." 286695 self updateProcessList! ! 286696 286697!ProcessBrowser methodsFor: 'process actions' stamp: 'sd 11/20/2005 21:27'! 286698suspendProcess 286699 | nameAndRules | 286700 selectedProcess isSuspended 286701 ifTrue: [^ self]. 286702 nameAndRules := self nameAndRulesForSelectedProcess. 286703 nameAndRules second 286704 ifFalse: [self inform: 'Nope, won''t suspend ' , nameAndRules first. 286705 ^ self]. 286706 self class suspendProcess: selectedProcess. 286707 self updateProcessList! ! 286708 286709!ProcessBrowser methodsFor: 'process actions' stamp: 'sd 11/20/2005 21:27'! 286710terminateProcess 286711 | nameAndRules | 286712 nameAndRules := self nameAndRulesForSelectedProcess. 286713 nameAndRules second 286714 ifFalse: [self inform: 'Nope, won''t kill ' , nameAndRules first. 286715 ^ self]. 286716 self class terminateProcess: selectedProcess. 286717 self updateProcessList! ! 286718 286719!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 08:56'! 286720wasProcessSuspendedByProcessBrowser: aProcess 286721 ^self class suspendedProcesses includesKey: aProcess! ! 286722 286723 286724!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/27/2000 09:24'! 286725exploreProcess 286726 selectedProcess explore! ! 286727 286728!ProcessBrowser methodsFor: 'process list' stamp: 'DamienCassou 9/29/2009 13:07'! 286729findContext 286730 | initialProcessIndex initialStackIndex found | 286731 initialProcessIndex := self processListIndex. 286732 initialStackIndex := self stackListIndex. 286733 searchString := UIManager default 286734 request: 'Enter a string to search for in the process stack lists' 286735 initialAnswer: searchString. 286736 searchString isEmptyOrNil 286737 ifTrue: [^ false]. 286738 self processListIndex: 1. 286739 self stackListIndex: 1. 286740 found := self nextContext. 286741 found 286742 ifFalse: [self processListIndex: initialProcessIndex. 286743 self stackListIndex: initialStackIndex]. 286744 ^ found! ! 286745 286746!ProcessBrowser methodsFor: 'process list'! 286747inspectProcess 286748 selectedProcess inspect! ! 286749 286750!ProcessBrowser methodsFor: 'process list' stamp: 'sd 11/20/2005 21:27'! 286751nextContext 286752 | initialProcessIndex initialStackIndex found | 286753 searchString isEmpty ifTrue: [ ^false ]. 286754 initialProcessIndex := self processListIndex. 286755 initialStackIndex := self stackListIndex. 286756 found := false. 286757 initialProcessIndex 286758 to: self processList size 286759 do: [:pi | found 286760 ifFalse: [self processListIndex: pi. 286761 self stackNameList 286762 withIndexDo: [:name :si | (found not 286763 and: [pi ~= initialProcessIndex 286764 or: [si > initialStackIndex]]) 286765 ifTrue: [(name includesSubString: searchString) 286766 ifTrue: [self stackListIndex: si. 286767 found := true]]]]]. 286768 found 286769 ifFalse: [self processListIndex: initialProcessIndex. 286770 self stackListIndex: initialStackIndex]. 286771 ^ found! ! 286772 286773!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/28/2000 08:19'! 286774notify: errorString at: location in: aStream 286775 "A syntax error happened when I was trying to highlight my pc. 286776 Raise a signal so that it can be ignored." 286777 Warning signal: 'syntax error'! 286778]style[(8 11 5 8 5 7 3 107 2 7 23)f1b,f1cblack;b,f1b,f1cblack;b,f1b,f1cblack;b,f1,f1c141039000,f1,f1cblack;,f1! ! 286779 286780!ProcessBrowser methodsFor: 'process list' stamp: 'sd 11/20/2005 21:27'! 286781prettyNameForProcess: aProcess 286782 | nameAndRules | 286783 aProcess ifNil: [ ^'<nil>' ]. 286784 nameAndRules := self nameAndRulesFor: aProcess. 286785 ^ aProcess browserPrintStringWith: nameAndRules first! ! 286786 286787!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/29/2000 10:20'! 286788processListKey: aKey from: aView 286789 ^ aKey caseOf: { 286790 [$i] -> [self inspectProcess]. 286791 [$I] -> [self exploreProcess]. 286792 [$c] -> [self chasePointers]. 286793 [$P] -> [self inspectPointers]. 286794 [$t] -> [self terminateProcess]. 286795 [$r] -> [self resumeProcess]. 286796 [$s] -> [self suspendProcess]. 286797 [$d] -> [self debugProcess]. 286798 [$p] -> [self changePriority]. 286799 [$m] -> [self messageTally]. 286800 [$f] -> [self findContext]. 286801 [$g] -> [self nextContext]. 286802 [$a] -> [self toggleAutoUpdate]. 286803 [$u] -> [self updateProcessList]. 286804 [$S] -> [self signalSemaphore]. 286805 [$k] -> [self moreStack]} 286806 otherwise: [self arrowKey: aKey from: aView]! ! 286807 286808!ProcessBrowser methodsFor: 'process list' stamp: 'sd 11/20/2005 21:27'! 286809processListMenu: menu 286810 | pw | 286811 286812 selectedProcess 286813 ifNotNil: [| nameAndRules | 286814 nameAndRules := self nameAndRulesForSelectedProcess. 286815 menu addList: {{'inspect (i)'. #inspectProcess}. {'explore (I)'. #exploreProcess}. {'inspect Pointers (P)'. #inspectPointers}}. 286816 (Smalltalk includesKey: #PointerFinder) 286817 ifTrue: [ menu add: 'chase pointers (c)' action: #chasePointers. ]. 286818 nameAndRules second 286819 ifTrue: [menu add: 'terminate (t)' action: #terminateProcess. 286820 selectedProcess isSuspended 286821 ifTrue: [menu add: 'resume (r)' action: #resumeProcess] 286822 ifFalse: [menu add: 'suspend (s)' action: #suspendProcess]]. 286823 nameAndRules third 286824 ifTrue: [menu addList: {{'change priority (p)'. #changePriority}. {'debug (d)'. #debugProcess}}]. 286825 menu addList: {{'profile messages (m)'. #messageTally}}. 286826 (selectedProcess suspendingList isKindOf: Semaphore) 286827 ifTrue: [menu add: 'signal Semaphore (S)' action: #signalSemaphore]. 286828 menu add: 'full stack (k)' action: #moreStack. 286829 menu addLine]. 286830 286831 menu addList: {{'find context... (f)'. #findContext}. {'find again (g)'. #nextContext}}. 286832 menu addLine. 286833 286834 menu 286835 add: (self isAutoUpdating 286836 ifTrue: ['turn off auto-update (a)'] 286837 ifFalse: ['turn on auto-update (a)']) 286838 action: #toggleAutoUpdate. 286839 menu add: 'update list (u)' action: #updateProcessList. 286840 286841 pw := Smalltalk at: #CPUWatcher ifAbsent: []. 286842 pw ifNotNil: [ 286843 menu addLine. 286844 pw isMonitoring 286845 ifTrue: [ menu add: 'stop CPUWatcher' action: #stopCPUWatcher ] 286846 ifFalse: [ menu add: 'start CPUWatcher' action: #startCPUWatcher ] 286847 ]. 286848 286849 ^ menu! ! 286850 286851!ProcessBrowser methodsFor: 'process list' stamp: 'sd 11/20/2005 21:27'! 286852processNameList 286853 "since processList is a WeakArray, we have to strengthen the result" 286854 | pw tally | 286855 pw := Smalltalk at: #CPUWatcher ifAbsent: [ ]. 286856 tally := pw ifNotNil: [ pw current ifNotNil: [ pw current tally ] ]. 286857 ^ (processList asOrderedCollection 286858 copyWithout: nil) 286859 collect: [:each | | percent | 286860 percent := tally 286861 ifNotNil: [ ((((tally occurrencesOf: each) * 100.0 / tally size) roundTo: 1) 286862 asString padded: #left to: 2 with: $ ), '% ' ] 286863 ifNil: [ '' ]. 286864 percent, (self prettyNameForProcess: each) 286865 ] ! ! 286866 286867!ProcessBrowser methodsFor: 'process list' stamp: 'sd 11/20/2005 21:27'! 286868updateProcessList 286869 | oldSelectedProcess newIndex now | 286870 now := Time millisecondClockValue. 286871 now - lastUpdate < 500 286872 ifTrue: [^ self]. 286873 "Don't update too fast" 286874 lastUpdate := now. 286875 oldSelectedProcess := selectedProcess. 286876 processList := selectedProcess := selectedSelector := nil. 286877 Smalltalk garbageCollectMost. 286878 "lose defunct processes" 286879 286880 processList := Process allSubInstances 286881 reject: [:each | each isTerminated]. 286882 processList := processList 286883 sortBy: [:a :b | a priority >= b priority]. 286884 processList := WeakArray withAll: processList. 286885 newIndex := processList 286886 indexOf: oldSelectedProcess 286887 ifAbsent: [0]. 286888 self changed: #processNameList. 286889 self processListIndex: newIndex! ! 286890 286891 286892!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 16:49'! 286893browseContext 286894 selectedContext 286895 ifNil: [^ self]. 286896 Browser newOnClass: self selectedClass selector: self selectedSelector! 286897]style[(13 30 4 4 7 42 4 17)f1b,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1! ! 286898 286899!ProcessBrowser methodsFor: 'stack list' stamp: 'sd 11/20/2005 21:27'! 286900changeStackListTo: aCollection 286901 286902 stackList := aCollection. 286903 self changed: #stackNameList. 286904 self stackListIndex: 0! ! 286905 286906!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:28'! 286907exploreContext 286908 selectedContext explore! ! 286909 286910!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:41'! 286911exploreReceiver 286912 selectedContext ifNotNil: [ selectedContext receiver explore ]! ! 286913 286914!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 7/8/2000 20:23'! 286915inspectContext 286916 selectedContext inspect! ! 286917 286918!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:41'! 286919inspectReceiver 286920 selectedContext 286921 ifNotNil: [selectedContext receiver inspect]! ! 286922 286923!ProcessBrowser methodsFor: 'stack list' stamp: 'DamienCassou 9/29/2009 13:07'! 286924messageTally 286925 | secString secs | 286926 secString := UIManager default request: 'Profile for how many seconds?' initialAnswer: '4'. 286927 secString ifNil: [secString := String new]. 286928 secs := secString asNumber asInteger. 286929 (secs isNil 286930 or: [secs isZero]) 286931 ifTrue: [^ self]. 286932 [ TimeProfileBrowser spyOnProcess: selectedProcess forMilliseconds: secs * 1000 ] forkAt: selectedProcess priority + 1.! ! 286933 286934!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 12:13'! 286935moreStack 286936 self updateStackList: 2000! ! 286937 286938!ProcessBrowser methodsFor: 'stack list' stamp: 'eem 6/12/2008 12:44'! 286939pcRange 286940 "Answer the indices in the source code for the method corresponding to 286941 the selected context's program counter value." 286942 (selectedContext isNil or: [methodText isEmptyOrNil]) 286943 ifTrue: [^ 1 to: 0]. 286944 ^selectedContext debuggerMap 286945 rangeForPC: (selectedContext pc ifNotNil: [:pc| pc] ifNil: [selectedContext method endPC]) 286946 contextIsActiveContext: stackListIndex = 1! ! 286947 286948!ProcessBrowser methodsFor: 'stack list' stamp: 'sd 11/20/2005 21:27'! 286949stackListMenu: aMenu 286950 | menu | 286951 selectedContext 286952 ifNil: [^ aMenu]. 286953 menu := aMenu 286954 labels: 'inspect context (c) 286955explore context (C) 286956inspect receiver (i) 286957explore receiver (I) 286958browse (b)' 286959 lines: #(2 4 ) 286960 selections: #(#inspectContext #exploreContext #inspectReceiver #exploreReceiver #browseContext ). 286961 ^ menu! ! 286962 286963!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 16:18'! 286964stackNameList 286965 ^ stackList 286966 ifNil: [#()] 286967 ifNotNil: [stackList 286968 collect: [:each | each asString]]! ! 286969 286970!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 7/8/2000 20:24'! 286971updateStackList 286972 self updateStackList: 20! ! 286973 286974!ProcessBrowser methodsFor: 'stack list' stamp: 'sd 11/20/2005 21:27'! 286975updateStackList: depth 286976 | suspendedContext oldHighlight | 286977 selectedProcess 286978 ifNil: [^ self changeStackListTo: nil]. 286979 (stackList notNil and: [ stackListIndex > 0 ]) 286980 ifTrue: [oldHighlight := stackList at: stackListIndex]. 286981 selectedProcess == Processor activeProcess 286982 ifTrue: [self 286983 changeStackListTo: (thisContext stackOfSize: depth)] 286984 ifFalse: [suspendedContext := selectedProcess suspendedContext. 286985 suspendedContext 286986 ifNil: [self changeStackListTo: nil] 286987 ifNotNil: [self 286988 changeStackListTo: (suspendedContext stackOfSize: depth)]]. 286989 self 286990 stackListIndex: (stackList 286991 ifNil: [0] 286992 ifNotNil: [stackList indexOf: oldHighlight])! ! 286993 286994 286995!ProcessBrowser methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 20:38'! 286996buildWith: builder 286997 "Create a pluggable version of me, answer a window" 286998 | windowSpec listSpec textSpec | 286999 windowSpec := builder pluggableWindowSpec new. 287000 windowSpec model: self. 287001 windowSpec label: 'Process Browser'. 287002 windowSpec children: OrderedCollection new. 287003 287004 listSpec := builder pluggableListSpec new. 287005 listSpec 287006 model: self; 287007 list: #processNameList; 287008 getIndex: #processListIndex; 287009 setIndex: #processListIndex:; 287010 menu: #processListMenu:; 287011 keyPress: #processListKey:from:; 287012 frame: (0 @ 0 extent: 0.5 @ 0.5). 287013 windowSpec children add: listSpec. 287014 287015 listSpec := builder pluggableListSpec new. 287016 listSpec 287017 model: self; 287018 list: #stackNameList; 287019 getIndex: #stackListIndex; 287020 setIndex: #stackListIndex:; 287021 menu: #stackListMenu:; 287022 keyPress: #stackListKey:from:; 287023 frame: (0.5 @ 0.0 extent: 0.5 @ 0.5). 287024 windowSpec children add: listSpec. 287025 287026 textSpec := builder pluggableTextSpec new. 287027 textSpec 287028 model: self; 287029 getText: #selectedMethod; 287030 setText: nil; 287031 selection: nil; 287032 menu: nil; 287033 frame: (0 @ 0.5 corner: 1 @ 1). 287034 windowSpec children add: textSpec. 287035 287036 ^builder build: windowSpec! ! 287037 287038 287039!ProcessBrowser methodsFor: 'updating' stamp: 'nk 10/28/2000 21:48'! 287040isAutoUpdating 287041 ^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended not ]! ! 287042 287043!ProcessBrowser methodsFor: 'updating' stamp: 'nk 6/18/2003 07:20'! 287044isAutoUpdatingPaused 287045 ^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended ]! ! 287046 287047!ProcessBrowser methodsFor: 'updating' stamp: 'nk 6/18/2003 07:20'! 287048pauseAutoUpdate 287049 self isAutoUpdating 287050 ifTrue: [ autoUpdateProcess suspend ]. 287051 self updateProcessList! ! 287052 287053!ProcessBrowser methodsFor: 'updating' stamp: 'sd 11/20/2005 21:27'! 287054setUpdateCallbackAfter: seconds 287055 287056 deferredMessageRecipient ifNotNil: [ | d | 287057 d := Delay forSeconds: seconds. 287058 [ d wait. 287059 d := nil. 287060 deferredMessageRecipient addDeferredUIMessage: [self updateProcessList] 287061 ] fork 287062 ]! ! 287063 287064!ProcessBrowser methodsFor: 'updating' stamp: 'sd 11/20/2005 21:27'! 287065startAutoUpdate 287066 self isAutoUpdatingPaused ifTrue: [ ^autoUpdateProcess resume ]. 287067 self isAutoUpdating 287068 ifFalse: [| delay | 287069 delay := Delay forSeconds: 2. 287070 autoUpdateProcess := [[self hasView] 287071 whileTrue: [delay wait. 287072 deferredMessageRecipient ifNotNil: [ 287073 deferredMessageRecipient addDeferredUIMessage: [self updateProcessList]] 287074 ifNil: [ self updateProcessList ]]. 287075 autoUpdateProcess := nil] fork]. 287076 self updateProcessList! ! 287077 287078!ProcessBrowser methodsFor: 'updating' stamp: 'sd 11/20/2005 21:27'! 287079stopAutoUpdate 287080 autoUpdateProcess ifNotNil: [ 287081 autoUpdateProcess terminate. 287082 autoUpdateProcess := nil]. 287083 self updateProcessList! ! 287084 287085!ProcessBrowser methodsFor: 'updating' stamp: 'nk 10/28/2000 21:50'! 287086toggleAutoUpdate 287087 self isAutoUpdating 287088 ifTrue: [ self stopAutoUpdate ] 287089 ifFalse: [ self startAutoUpdate ]. 287090! ! 287091 287092 287093!ProcessBrowser methodsFor: 'views' stamp: 'sd 11/20/2005 21:27'! 287094asPrototypeInWindow 287095 "Create a pluggable version of me, answer a window" 287096 287097 | window aTextMorph | 287098 window := (SystemWindow labelled: 'later') model: self. 287099 window 287100 addMorph: ((PluggableListMorph 287101 on: self 287102 list: #processNameList 287103 selected: #processListIndex 287104 changeSelected: #processListIndex: 287105 menu: #processListMenu: 287106 keystroke: #processListKey:from:) 287107 enableDragNDrop: false) 287108 frame: (0 @ 0 extent: 0.5 @ 0.5). 287109 window 287110 addMorph: ((PluggableListMorph 287111 on: self 287112 list: #stackNameList 287113 selected: #stackListIndex 287114 changeSelected: #stackListIndex: 287115 menu: #stackListMenu: 287116 keystroke: #stackListKey:from:) 287117 enableDragNDrop: false) 287118 frame: (0.5 @ 0.0 extent: 0.5 @ 0.5). 287119 aTextMorph := PluggableTextMorph 287120 on: self 287121 text: #selectedMethod 287122 accept: nil 287123 readSelection: nil 287124 menu: nil. 287125 window 287126 addMorph: aTextMorph 287127 frame: (0 @ 0.5 corner: 1 @ 1). 287128 window setLabel: 'Process Browser'. 287129 ^ window! ! 287130 287131!ProcessBrowser methodsFor: 'views' stamp: 'nk 10/28/2000 11:44'! 287132hasView 287133 ^self dependents isEmptyOrNil not! ! 287134 287135!ProcessBrowser methodsFor: 'views' stamp: 'sd 11/20/2005 21:27'! 287136openAsMorph 287137 "Create a pluggable version of me, answer a window" 287138 | window aTextMorph | 287139 window := (SystemWindow labelled: 'later') 287140 model: self. 287141 287142 deferredMessageRecipient := WorldState. 287143 window 287144 addMorph: ((PluggableListMorph 287145 on: self 287146 list: #processNameList 287147 selected: #processListIndex 287148 changeSelected: #processListIndex: 287149 menu: #processListMenu: 287150 keystroke: #processListKey:from:) 287151 enableDragNDrop: false) 287152 frame: (0 @ 0 extent: 0.5 @ 0.5). 287153 window 287154 addMorph: ((PluggableListMorph 287155 on: self 287156 list: #stackNameList 287157 selected: #stackListIndex 287158 changeSelected: #stackListIndex: 287159 menu: #stackListMenu: 287160 keystroke: #stackListKey:from:) 287161 enableDragNDrop: false) 287162 frame: (0.5 @ 0.0 extent: 0.5 @ 0.5). 287163 aTextMorph := PluggableTextMorph 287164 on: self 287165 text: #selectedMethod 287166 accept: nil 287167 readSelection: nil 287168 menu: nil. 287169 aTextMorph askBeforeDiscardingEdits: false. 287170 window 287171 addMorph: aTextMorph 287172 frame: (0 @ 0.5 corner: 1 @ 1). 287173 window setUpdatablePanesFrom: #(#processNameList #stackNameList ). 287174 (window setLabel: 'Process Browser') openInWorld. 287175 startedCPUWatcher ifTrue: [ self setUpdateCallbackAfter: 7 ]. 287176 ^ window! ! 287177 287178!ProcessBrowser methodsFor: 'views' stamp: 'nk 10/28/2000 16:53'! 287179stackListKey: aKey from: aView 287180 ^ aKey caseOf: { 287181 [$c] -> [self inspectContext]. 287182 [$C] -> [self exploreContext]. 287183 [$i] -> [self inspectReceiver]. 287184 [$I] -> [self exploreReceiver]. 287185 [$b] -> [self browseContext]} 287186 otherwise: [self arrowKey: aKey from: aView]! ! 287187 287188"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 287189 287190ProcessBrowser class 287191 instanceVariableNames: ''! 287192 287193!ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'stephane.ducasse 8/5/2009 17:06'! 287194dumpPigStackOn: aStream andClose: aBoolean 287195 "Must run forked on its own process, so the monitored behavior is not affected too much" 287196 287197 | promise tally process depth stack suspendedContext | 287198 promise := Processor tallyCPUUsageFor: 1 every: 10. 287199 tally := promise value. 287200 "WorldState addDeferredUIMessage: [self dumpTallyOnTranscript: tally]." 287201 aStream nextPutAll: '====Al processes===='; cr. 287202 self dumpTally: tally on: aStream. 287203 aStream cr; nextPutAll: '====Process using most CPU===='; cr. 287204 process := tally sortedCounts first value. 287205 (100.0 * (tally occurrencesOf: process) / tally size) rounded printOn: aStream. 287206 aStream 287207 nextPutAll: ' % '; 287208 nextPutAll: (process browserPrintStringWith: (ProcessBrowser nameAndRulesFor: process) first); 287209 cr. 287210 depth := 20. 287211 stack := process == Processor activeProcess 287212 ifTrue: [thisContext stackOfSize: depth] 287213 ifFalse: [suspendedContext := process suspendedContext. 287214 suspendedContext 287215 ifNotNil: [suspendedContext stackOfSize: depth]]. 287216 stack 287217 ifNil: [ aStream nextPutAll: 'No context'; cr] 287218 ifNotNil: [ 287219 stack do: [ :c | 287220 c printOn: aStream. 287221 aStream cr]]. 287222 aBoolean ifTrue: [aStream close]! ! 287223 287224!ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'stephane.ducasse 8/5/2009 17:07'! 287225dumpTally: tally on: aStream 287226 "tally is from ProcessorScheduler>>tallyCPUUsageFor: 287227 Dumps lines with percentage of time, hash of process, and a friendly name" 287228 287229 tally sortedCounts do: [ :assoc | | procName | 287230 procName := (self nameAndRulesFor: assoc value) first. 287231 (((assoc key / tally size) * 100.0) roundTo: 1) printOn: aStream. 287232 aStream 287233 nextPutAll: '% '; 287234 print: assoc value identityHash; space; 287235 nextPutAll: procName; 287236 cr. 287237 ]! ! 287238 287239!ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'jmv 5/22/2009 12:30'! 287240dumpTallyOnTranscript: tally 287241 "tally is from ProcessorScheduler>>tallyCPUUsageFor: 287242 Dumps lines with percentage of time, hash of process, and a friendly name" 287243 287244 self dumpTally: tally on: Transcript. 287245 Transcript flush.! ! 287246 287247 287248!ProcessBrowser class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:32'! 287249shutDown 287250 Browsers do: [ :ea | ea isAutoUpdating ifTrue: [ ea pauseAutoUpdate ]]! ! 287251 287252!ProcessBrowser class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:32'! 287253startUp 287254 Browsers do: [ :ea | ea isAutoUpdatingPaused ifTrue: [ ea startAutoUpdate ]]! ! 287255 287256 287257!ProcessBrowser class methodsFor: 'cpu utilization' stamp: 'nk 3/8/2001 12:49'! 287258tallyCPUUsageFor: seconds 287259 "Compute CPU usage using a 10-msec sample for the given number of seconds, 287260 then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile" 287261 "ProcessBrowser tallyCPUUsageFor: 10" 287262 ^self tallyCPUUsageFor: seconds every: 10! ! 287263 287264!ProcessBrowser class methodsFor: 'cpu utilization' stamp: 'alain.plantec 6/1/2008 19:06'! 287265tallyCPUUsageFor: seconds every: msec 287266 "Compute CPU usage using a msec millisecond sample for the given number of seconds, 287267 then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile" 287268 "ProcessBrowser tallyCPUUsageFor: 10 every: 100" 287269 287270 | promise | 287271 promise := Processor tallyCPUUsageFor: seconds every: msec. 287272 287273 [ | tally | 287274 tally := promise value. 287275 WorldState addDeferredUIMessage: [ self dumpTallyOnTranscript: tally ]. 287276 ] fork.! ! 287277 287278 287279!ProcessBrowser class methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:28'! 287280initialize 287281 "ProcessBrowser initialize" 287282 Browsers ifNil: [ Browsers := WeakSet new ]. 287283 SuspendedProcesses ifNil: [ SuspendedProcesses := IdentityDictionary new ]. 287284 Smalltalk addToStartUpList: self. 287285 Smalltalk addToShutDownList: self. 287286 self registerInFlapsRegistry. 287287 self registerWellKnownProcesses! ! 287288 287289!ProcessBrowser class methodsFor: 'initialization' stamp: 'asm 4/11/2003 10:22'! 287290registerInFlapsRegistry 287291 "Register the receiver in the system's flaps registry" 287292 self environment 287293 at: #Flaps 287294 ifPresent: [:cl | cl registerQuad: #(ProcessBrowser prototypicalToolWindow 'Processes' 'A Process Browser shows you all the running processes') 287295 forFlapNamed: 'Tools'.]! ! 287296 287297!ProcessBrowser class methodsFor: 'initialization' stamp: 'alain.plantec 6/10/2008 20:28'! 287298registerWellKnownProcesses 287299 "Associate each well-known process with a nickname and two flags: allow-stop, and allow-debug. 287300 Additional processes may be added to this list as required" 287301 287302 WellKnownProcesses := OrderedCollection new. 287303 self registerWellKnownProcess: [] 287304 label: 'no process' 287305 allowStop: false 287306 allowDebug: false. 287307 self registerWellKnownProcess: [Smalltalk lowSpaceWatcherProcess] 287308 label: 'the low space watcher' 287309 allowStop: false 287310 allowDebug: false. 287311 self registerWellKnownProcess: [WeakArray runningFinalizationProcess] 287312 label: 'the WeakArray finalization process' 287313 allowStop: false 287314 allowDebug: false. 287315 self registerWellKnownProcess: [Processor activeProcess] 287316 label: 'the UI process' 287317 allowStop: false 287318 allowDebug: true. 287319 self registerWellKnownProcess: [Processor backgroundProcess] 287320 label: 'the idle process' 287321 allowStop: false 287322 allowDebug: false. 287323 self registerWellKnownProcess: [Sensor interruptWatcherProcess] 287324 label: 'the user interrupt watcher' 287325 allowStop: false 287326 allowDebug: false. 287327 self registerWellKnownProcess: [Sensor eventTicklerProcess] 287328 label: 'the event tickler' 287329 allowStop: false 287330 allowDebug: false. 287331 self registerWellKnownProcess: [Project uiProcess] 287332 label: 'the inactive Morphic UI process' 287333 allowStop: false 287334 allowDebug: false. 287335 self registerWellKnownProcess: 287336 [Smalltalk at: #SoundPlayer ifPresent: [:sp | sp playerProcess]] 287337 label: 'the Sound Player' 287338 allowStop: false 287339 allowDebug: false. 287340 self registerWellKnownProcess: 287341 [Smalltalk at: #CPUWatcher ifPresent: [:cw | cw currentWatcherProcess]] 287342 label: 'the CPUWatcher' 287343 allowStop: false 287344 allowDebug: false 287345! ! 287346 287347!ProcessBrowser class methodsFor: 'initialization' stamp: 'asm 4/11/2003 12:39'! 287348unload 287349 "Unload the receiver from global registries" 287350 287351 self environment at: #Flaps ifPresent: [:cl | 287352 cl unregisterQuadsWithReceiver: self] ! ! 287353 287354 287355!ProcessBrowser class methodsFor: 'instance creation' stamp: 'alain.plantec 6/1/2008 19:03'! 287356open 287357 "ProcessBrowser open" 287358 "Create and schedule a ProcessBrowser." 287359 Smalltalk garbageCollect. 287360 ^ self new openAsMorph! ! 287361 287362!ProcessBrowser class methodsFor: 'instance creation' stamp: 'sw 6/13/2001 01:04'! 287363prototypicalToolWindow 287364 "Answer a window representing a prototypical instance of the receiver" 287365 287366 ^ self new asPrototypeInWindow! ! 287367 287368 287369!ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 17:09'! 287370debugProcess: aProcess 287371 self resumeProcess: aProcess. 287372 aProcess debugWithTitle: 'Interrupted from the Process Browser'. 287373! ! 287374 287375!ProcessBrowser class methodsFor: 'process control' stamp: 'alain.plantec 5/30/2008 14:29'! 287376isUIProcess: aProcess 287377 ^ aProcess == Project uiProcess! ! 287378 287379!ProcessBrowser class methodsFor: 'process control' stamp: 'dtl 2/5/2005 01:21'! 287380nameAndRulesFor: aProcess 287381 "Answer a nickname and two flags: allow-stop, and allow-debug" 287382 ^ [aProcess caseOf: WellKnownProcesses 287383 otherwise: 287384 [(aProcess priority = Processor timingPriority 287385 and: [aProcess suspendedContext receiver == Delay]) 287386 ifTrue: [{'the timer interrupt watcher'. false. false}] 287387 ifFalse: [{aProcess suspendedContext asString. true. true}]]] 287388 ifError: [:err :rcvr | {aProcess suspendedContext asString. true. true}]! ! 287389 287390!ProcessBrowser class methodsFor: 'process control' stamp: 'dtl 2/5/2005 09:07'! 287391registerWellKnownProcess: aBlockForProcess label: nickname allowStop: allowStop allowDebug: allowDebug 287392 "Add an entry to the registry of well known processes. aBlockForProcess 287393 evaluates to a known process to be identified by nickname, and allowStop 287394 and allowDebug are flags controlling allowable actions for this process 287395 in the browser." 287396 287397 WellKnownProcesses add: aBlockForProcess->[{nickname . allowStop . allowDebug}]! ! 287398 287399!ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'! 287400resumeProcess: aProcess 287401 | priority | 287402 priority := self suspendedProcesses 287403 removeKey: aProcess 287404 ifAbsent: [aProcess priority]. 287405 aProcess priority: priority. 287406 aProcess suspendedContext ifNotNil: [ aProcess resume ] 287407! ! 287408 287409!ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'! 287410setProcess: aProcess toPriority: priority 287411 | oldPriority | 287412 oldPriority := self suspendedProcesses at: aProcess ifAbsent: [ ]. 287413 oldPriority ifNotNil: [ self suspendedProcesses at: aProcess put: priority ]. 287414 aProcess priority: priority. 287415 ^oldPriority! ! 287416 287417!ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'! 287418suspendProcess: aProcess 287419 | priority | 287420 priority := aProcess priority. 287421 self suspendedProcesses at: aProcess put: priority. 287422 "Need to take the priority down below the caller's 287423 so that it can keep control after signaling the Semaphore" 287424 (aProcess suspendingList isKindOf: Semaphore) 287425 ifTrue: [aProcess priority: Processor lowestPriority. 287426 aProcess suspendingList signal]. 287427 [aProcess suspend] 287428 on: Error 287429 do: [:ex | self suspendedProcesses removeKey: aProcess]. 287430 aProcess priority: priority. 287431! ! 287432 287433!ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'! 287434suspendedProcesses 287435 "Answer a collection of processes that my instances have suspended. 287436 This is so that they don't get garbage collected." 287437 ^ SuspendedProcesses 287438 ifNil: [SuspendedProcesses := IdentityDictionary new]! ! 287439 287440!ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 13:25'! 287441terminateProcess: aProcess 287442 aProcess ifNotNil: [ 287443 self suspendedProcesses 287444 removeKey: aProcess 287445 ifAbsent: []. 287446 aProcess terminate 287447 ]. 287448! ! 287449 287450!ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'! 287451unregisterWellKnownProcess: aProcess 287452 "Remove the first registry entry that matches aProcess. Use 287453 with caution if more than one registry entry may match aProcess." 287454 287455 "self unregisterWellKnownProcess: Smalltalk lowSpaceWatcherProcess" 287456 287457 | entry | 287458 entry := WellKnownProcesses 287459 detect: [:e | e key value == aProcess] 287460 ifNone: [^ self]. 287461 WellKnownProcesses remove: entry! ! 287462 287463!ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 13:26'! 287464wasProcessSuspendedByProcessBrowser: aProcess 287465 ^self suspendedProcesses includesKey: aProcess! ! 287466ProcessSpecificVariable subclass: #ProcessLocalVariable 287467 instanceVariableNames: '' 287468 classVariableNames: '' 287469 poolDictionaries: '' 287470 category: 'Kernel-Processes'! 287471!ProcessLocalVariable commentStamp: 'mvl 3/13/2007 12:28' prior: 0! 287472My subclasses have values specific to the active process. They can be read with #value and set with #value:! 287473 287474 287475"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 287476 287477ProcessLocalVariable class 287478 instanceVariableNames: ''! 287479 287480!ProcessLocalVariable class methodsFor: 'accessing' stamp: 'mvl 3/13/2007 14:27'! 287481value: anObject 287482 Processor activeProcess environmentAt: self put: anObject! ! 287483TestCase subclass: #ProcessSpecificTest 287484 instanceVariableNames: '' 287485 classVariableNames: '' 287486 poolDictionaries: '' 287487 category: 'KernelTests-Processes'! 287488!ProcessSpecificTest commentStamp: 'mvl 3/13/2007 13:52' prior: 0! 287489A ProcessSpecificTest is a test case for process local and dynamic variables. 287490! 287491 287492 287493!ProcessSpecificTest methodsFor: 'testing' stamp: 'mvl 3/13/2007 14:13'! 287494checkDynamic: value 287495 self assert: TestDynamicVariable value = value! ! 287496 287497!ProcessSpecificTest methodsFor: 'testing' stamp: 'mvl 3/13/2007 14:13'! 287498checkLocal: value 287499 self assert: TestLocalVariable value = value! ! 287500 287501!ProcessSpecificTest methodsFor: 'testing' stamp: 'mvl 3/13/2007 15:02'! 287502testDynamicVariable 287503 287504 | s1 s2 p1stopped p2stopped | 287505 s1 := Semaphore new. 287506 s2 := Semaphore new. 287507 p1stopped := p2stopped := false. 287508 [ 287509 TestDynamicVariable value: 1 during:[ 287510 self checkDynamic: 1. 287511 (Delay forMilliseconds: 30) wait. 287512 self checkDynamic: 1. 287513 TestDynamicVariable value: 3 during:[ 287514 (Delay forMilliseconds: 30) wait. 287515 self checkDynamic: 3 287516 ]. 287517 self checkDynamic: 1. 287518 ]. 287519 self checkDynamic: nil. 287520 p1stopped := true. 287521 s1 signal. 287522 ] fork. 287523 287524 [ 287525 TestDynamicVariable value: 2 during:[ 287526 self checkDynamic: 2. 287527 (Delay forMilliseconds: 30) wait. 287528 self checkDynamic: 2. 287529 ]. 287530 self checkDynamic: nil. 287531 p2stopped := true. 287532 s2 signal. 287533 ] fork. 287534 287535 "Set a maximum wait timeout so that the test case will complete 287536 even if the processes fail to signal us." 287537 s1 waitTimeoutSeconds: 2. 287538 s2 waitTimeoutSeconds: 2. 287539 self assert: p1stopped. 287540 self assert: p2stopped.! ! 287541 287542!ProcessSpecificTest methodsFor: 'testing' stamp: 'mvl 3/13/2007 15:03'! 287543testLocalVariable 287544 287545 | s1 s2 p1stopped p2stopped | 287546 s1 := Semaphore new. 287547 s2 := Semaphore new. 287548 p1stopped := p2stopped := false. 287549 [ 287550 self checkLocal: 0. 287551 TestLocalVariable value: 1. 287552 self checkLocal: 1. 287553 (Delay forMilliseconds: 30) wait. 287554 self checkLocal: 1. 287555 TestLocalVariable value: 2. 287556 self checkLocal: 2. 287557 p1stopped := true. 287558 s1 signal. 287559 ] fork. 287560 287561 [ 287562 (Delay forMilliseconds: 30) wait. 287563 self checkLocal: 0. 287564 TestLocalVariable value: 3. 287565 self checkLocal: 3. 287566 (Delay forMilliseconds: 30) wait. 287567 self checkLocal: 3. 287568 TestLocalVariable value: 4. 287569 self checkLocal: 4. 287570 p2stopped := true. 287571 s2 signal. 287572 ] fork. 287573 287574 "Set a maximum wait timeout so that the test case will complete 287575 even if the processes fail to signal us." 287576 s1 waitTimeoutMSecs: 5000. 287577 s2 waitTimeoutMSecs: 5000. 287578 self assert: p1stopped. 287579 self assert: p2stopped. 287580! ! 287581Object subclass: #ProcessSpecificVariable 287582 instanceVariableNames: '' 287583 classVariableNames: '' 287584 poolDictionaries: '' 287585 category: 'Kernel-Processes'! 287586!ProcessSpecificVariable commentStamp: 'mvl 3/13/2007 13:53' prior: 0! 287587My subclasses (not instances of them) keep state specific to the current process. 287588 287589There are two kinds of process-specific variables: process-local (state available 287590for read and write in all methods inside the process), and dynamic variables 287591(implementing dynamic scope).! 287592 287593 287594"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 287595 287596ProcessSpecificVariable class 287597 instanceVariableNames: 'hash'! 287598 287599!ProcessSpecificVariable class methodsFor: 'accessing' stamp: 'mvl 3/13/2007 14:32'! 287600default 287601 "Answer the default value for the variable. The default for the default value is nil." 287602 ^nil! ! 287603 287604!ProcessSpecificVariable class methodsFor: 'accessing' stamp: 'mvl 3/13/2007 15:13'! 287605hash 287606 hash ifNil:[hash := super hash]. 287607 ^hash! ! 287608 287609!ProcessSpecificVariable class methodsFor: 'accessing' stamp: 'mvl 3/13/2007 14:33'! 287610value 287611 "Answer the current value for this variable in the current context." 287612 ^Processor activeProcess environmentAt: self ifAbsent: [self default].! ! 287613 287614 287615!ProcessSpecificVariable class methodsFor: 'class initialization' stamp: 'mvl 3/13/2007 16:07'! 287616initialize 287617 "Add Process::env if it is missing" 287618 287619 (Process instVarNames includes: 'env') 287620 ifFalse: [ Process addInstVarName: 'env'].! ! 287621TestCase subclass: #ProcessTerminateBug 287622 instanceVariableNames: '' 287623 classVariableNames: '' 287624 poolDictionaries: '' 287625 category: 'Tests-Exceptions'! 287626 287627!ProcessTerminateBug methodsFor: 'tests' stamp: 'm 7/28/2003 19:10'! 287628testSchedulerTermination 287629 | process sema gotHere sema2 | 287630 gotHere := false. 287631 sema := Semaphore new. 287632 sema2 := Semaphore new. 287633 process := [ 287634 sema signal. 287635 sema2 wait. 287636 "will be suspended here" 287637 gotHere := true. "e.g., we must *never* get here" 287638 ] forkAt: Processor activeProcess priority. 287639 sema wait. "until process gets scheduled" 287640 process terminate. 287641 sema2 signal. 287642 Processor yield. "will give process a chance to continue and 287643horribly screw up" 287644 self assert: gotHere not. 287645! ! 287646 287647!ProcessTerminateBug methodsFor: 'tests' stamp: 'ar 7/27/2003 19:44'! 287648testUnwindFromActiveProcess 287649 | sema process | 287650 sema := Semaphore forMutualExclusion. 287651 self assert:(sema isSignaled). 287652 process := [ 287653 sema critical:[ 287654 self deny: sema isSignaled. 287655 Processor activeProcess terminate. 287656 ] 287657 ] forkAt: Processor userInterruptPriority. 287658 self assert: sema isSignaled.! ! 287659 287660!ProcessTerminateBug methodsFor: 'tests' stamp: 'ar 7/27/2003 19:49'! 287661testUnwindFromForeignProcess 287662 | sema process | 287663 sema := Semaphore forMutualExclusion. 287664 self assert: sema isSignaled. 287665 process := [ 287666 sema critical:[ 287667 self deny: sema isSignaled. 287668 sema wait. "deadlock" 287669 ] 287670 ] forkAt: Processor userInterruptPriority. 287671 self deny: sema isSignaled. 287672 "This is for illustration only - the BlockCannotReturn cannot 287673 be handled here (it's truncated already)" 287674 self shouldnt: [process terminate] raise: BlockCannotReturn. 287675 self assert: sema isSignaled. 287676 ! ! 287677TestCase subclass: #ProcessTest 287678 instanceVariableNames: '' 287679 classVariableNames: '' 287680 poolDictionaries: '' 287681 category: 'KernelTests-Processes'! 287682!ProcessTest commentStamp: 'GiovanniCorriga 8/30/2009 14:56' prior: 0! 287683A ProcessTest holds test cases for generic Process-related behaviour.! 287684 287685 287686!ProcessTest methodsFor: 'running' stamp: 'GiovanniCorriga 8/30/2009 15:53'! 287687tearDown 287688 Processor activeProcess environmentRemoveKey: #processTests ifAbsent: []! ! 287689 287690 287691!ProcessTest methodsFor: 'testing' stamp: 'GiovanniCorriga 8/30/2009 15:58'! 287692testEnvironmentAt 287693 Processor activeProcess environmentAt: #processTests put: 42. 287694 self assert: (Processor activeProcess environmentAt: #processTests) = 42. 287695 self should: [Processor activeProcess environmentAt: #foobar] raise: Error! ! 287696 287697!ProcessTest methodsFor: 'testing' stamp: 'GiovanniCorriga 8/30/2009 15:53'! 287698testEnvironmentAtPut 287699 self assert: (Processor activeProcess environmentAt: #processTests put: 42) = 42.! ! 287700 287701!ProcessTest methodsFor: 'testing' stamp: 'GiovanniCorriga 8/30/2009 16:03'! 287702testEnvironmentRemoveKey 287703 Processor activeProcess environmentAt: #processTests put: 42. 287704 Processor activeProcess environmentRemoveKey: #processTests. 287705 self assert: (Processor activeProcess environmentAt: #processTests ifAbsent: []) isNil. 287706 self should: [Processor activeProcess environmentAt: #processTests] raise: Error! ! 287707 287708!ProcessTest methodsFor: 'testing' stamp: 'NouryBouraqadi 10/1/2009 07:45'! 287709testIsSelfEvaluating 287710 self assert: Processor printString = 'Processor'! ! 287711Object subclass: #ProcessorScheduler 287712 instanceVariableNames: 'quiescentProcessLists activeProcess' 287713 classVariableNames: 'BackgroundProcess HighIOPriority LowIOPriority SystemBackgroundPriority SystemRockBottomPriority TimingPriority UserBackgroundPriority UserInterruptPriority UserSchedulingPriority' 287714 poolDictionaries: '' 287715 category: 'Kernel-Processes'! 287716!ProcessorScheduler commentStamp: '<historical>' prior: 0! 287717My single instance, named Processor, coordinates the use of the physical processor by all Processes requiring service.! 287718 287719 287720!ProcessorScheduler methodsFor: 'CPU usage tally' stamp: 'nk 3/8/2001 12:56'! 287721nextReadyProcess 287722 quiescentProcessLists reverseDo: [ :list | 287723 list isEmpty ifFalse: [ | proc | 287724 proc := list first. 287725 proc suspendedContext ifNotNil: [ ^proc ]]]. 287726 ^nil! ! 287727 287728!ProcessorScheduler methodsFor: 'CPU usage tally' stamp: 'nk 3/8/2001 12:48'! 287729tallyCPUUsageFor: seconds 287730 "Start a high-priority process that will tally the next ready process for the given 287731 number of seconds. Answer a Block that will return the tally (a Bag) after the task 287732 is complete" 287733 ^self tallyCPUUsageFor: seconds every: 10 287734! ! 287735 287736!ProcessorScheduler methodsFor: 'CPU usage tally' stamp: 'nk 3/17/2001 10:06'! 287737tallyCPUUsageFor: seconds every: msec 287738 "Start a high-priority process that will tally the next ready process for the given 287739 number of seconds. Answer a Block that will return the tally (a Bag) after the task 287740 is complete" 287741 | tally sem delay endDelay | 287742 tally := IdentityBag new: 200. 287743 delay := Delay forMilliseconds: msec truncated. 287744 endDelay := Delay forSeconds: seconds. 287745 endDelay schedule. 287746 sem := Semaphore new. 287747 [ 287748 [ endDelay isExpired ] whileFalse: [ 287749 delay wait. 287750 tally add: Processor nextReadyProcess 287751 ]. 287752 sem signal. 287753 ] forkAt: self highestPriority. 287754 287755 ^[ sem wait. tally ]! ! 287756 287757 287758!ProcessorScheduler methodsFor: 'accessing'! 287759activePriority 287760 "Answer the priority level of the currently running Process." 287761 287762 ^activeProcess priority! ! 287763 287764!ProcessorScheduler methodsFor: 'accessing'! 287765activeProcess 287766 "Answer the currently running Process." 287767 287768 ^activeProcess! ! 287769 287770!ProcessorScheduler methodsFor: 'accessing' stamp: 'nk 10/27/2000 16:27'! 287771backgroundProcess 287772 "Answer the background process" 287773 ^ BackgroundProcess! ! 287774 287775!ProcessorScheduler methodsFor: 'accessing'! 287776highestPriority 287777 "Answer the number of priority levels currently available for use." 287778 287779 ^quiescentProcessLists size! ! 287780 287781!ProcessorScheduler methodsFor: 'accessing'! 287782highestPriority: newHighestPriority 287783 "Change the number of priority levels currently available for use." 287784 287785 | continue newProcessLists | 287786 (quiescentProcessLists size > newHighestPriority 287787 and: [self anyProcessesAbove: newHighestPriority]) 287788 ifTrue: [self error: 'There are processes with priority higher than ' 287789 ,newHighestPriority printString]. 287790 newProcessLists := Array new: newHighestPriority. 287791 1 to: ((quiescentProcessLists size) min: (newProcessLists size)) do: 287792 [:priority | newProcessLists at: priority put: (quiescentProcessLists at: priority)]. 287793 quiescentProcessLists size to: newProcessLists size do: 287794 [:priority | newProcessLists at: priority put: LinkedList new]. 287795 quiescentProcessLists := newProcessLists! ! 287796 287797!ProcessorScheduler methodsFor: 'accessing' stamp: 'ar 8/22/2001 17:33'! 287798preemptedProcess 287799 "Return the process that the currently active process just preempted." 287800 | list | 287801 activeProcess priority to: 1 by: -1 do:[:priority| 287802 list := quiescentProcessLists at: priority. 287803 list isEmpty ifFalse:[^list last]. 287804 ]. 287805 ^nil 287806 287807 "Processor preemptedProcess"! ! 287808 287809!ProcessorScheduler methodsFor: 'accessing' stamp: 'ar 7/8/2001 16:21'! 287810waitingProcessesAt: aPriority 287811 "Return the list of processes at the given priority level." 287812 ^quiescentProcessLists at: aPriority! ! 287813 287814 287815!ProcessorScheduler methodsFor: 'objects from disk' stamp: 'tk 9/28/2000 15:46'! 287816objectForDataStream: refStrm 287817 | dp | 287818 "I am about to be written on an object file. Write a path to me in the other system instead." 287819 287820 dp := DiskProxy global: #Processor selector: #yourself args: #(). 287821 refStrm replace: self with: dp. 287822 ^ dp 287823! ! 287824 287825 287826!ProcessorScheduler methodsFor: 'priority names'! 287827highIOPriority 287828 "Answer the priority at which the most time critical input/output 287829 processes should run. An example is the process handling input from a 287830 network." 287831 287832 ^HighIOPriority! ! 287833 287834!ProcessorScheduler methodsFor: 'priority names'! 287835lowIOPriority 287836 "Answer the priority at which most input/output processes should run. 287837 Examples are the process handling input from the user (keyboard, 287838 pointing device, etc.) and the process distributing input from a network." 287839 287840 ^LowIOPriority! ! 287841 287842!ProcessorScheduler methodsFor: 'priority names' stamp: 'ar 7/8/2001 17:02'! 287843lowestPriority 287844 "Return the lowest priority that is allowed with the scheduler" 287845 ^SystemRockBottomPriority! ! 287846 287847!ProcessorScheduler methodsFor: 'priority names'! 287848systemBackgroundPriority 287849 "Answer the priority at which system background processes should run. 287850 Examples are an incremental garbage collector or status checker." 287851 287852 ^SystemBackgroundPriority! ! 287853 287854!ProcessorScheduler methodsFor: 'priority names'! 287855timingPriority 287856 "Answer the priority at which the system processes keeping track of real 287857 time should run." 287858 287859 ^TimingPriority! ! 287860 287861!ProcessorScheduler methodsFor: 'priority names'! 287862userBackgroundPriority 287863 "Answer the priority at which user background processes should run." 287864 287865 ^UserBackgroundPriority! ! 287866 287867!ProcessorScheduler methodsFor: 'priority names'! 287868userInterruptPriority 287869 "Answer the priority at which user processes desiring immediate service 287870 should run. Processes run at this level will preempt the window 287871 scheduler and should, therefore, not consume the processor forever." 287872 287873 ^UserInterruptPriority! ! 287874 287875!ProcessorScheduler methodsFor: 'priority names'! 287876userSchedulingPriority 287877 "Answer the priority at which the window scheduler should run." 287878 287879 ^UserSchedulingPriority! ! 287880 287881 287882!ProcessorScheduler methodsFor: 'process state change'! 287883suspendFirstAt: aPriority 287884 "Suspend the first Process that is waiting to run with priority aPriority." 287885 287886 ^self suspendFirstAt: aPriority 287887 ifNone: [self error: 'No Process to suspend']! ! 287888 287889!ProcessorScheduler methodsFor: 'process state change'! 287890suspendFirstAt: aPriority ifNone: noneBlock 287891 "Suspend the first Process that is waiting to run with priority aPriority. If 287892 no Process is waiting, evaluate the argument, noneBlock." 287893 287894 | aList | 287895 aList := quiescentProcessLists at: aPriority. 287896 aList isEmpty 287897 ifTrue: [^noneBlock value] 287898 ifFalse: [^aList first suspend]! ! 287899 287900!ProcessorScheduler methodsFor: 'process state change'! 287901terminateActive 287902 "Terminate the process that is currently running." 287903 287904 activeProcess terminate! ! 287905 287906!ProcessorScheduler methodsFor: 'process state change' stamp: 'tpr 4/28/2004 17:53'! 287907yield 287908 "Give other Processes at the current priority a chance to run." 287909 287910 | semaphore | 287911 287912 <primitive: 167> 287913 semaphore := Semaphore new. 287914 [semaphore signal] fork. 287915 semaphore wait! ! 287916 287917 287918!ProcessorScheduler methodsFor: 'removing'! 287919remove: aProcess ifAbsent: aBlock 287920 "Remove aProcess from the list on which it is waiting for the processor 287921 and answer aProcess. If it is not waiting, evaluate aBlock." 287922 287923 (quiescentProcessLists at: aProcess priority) 287924 remove: aProcess ifAbsent: aBlock. 287925 ^aProcess! ! 287926 287927 287928!ProcessorScheduler methodsFor: 'private' stamp: 'tk 6/24/1999 11:27'! 287929anyProcessesAbove: highestPriority 287930 "Do any instances of Process exist with higher priorities?" 287931 287932 ^(Process allInstances "allSubInstances" select: [:aProcess | 287933 aProcess priority > highestPriority]) isEmpty 287934 "If anyone ever makes a subclass of Process, be sure to use allSubInstances."! ! 287935 287936 287937!ProcessorScheduler methodsFor: 'self evaluating' stamp: 'NouryBouraqadi 10/1/2009 07:47'! 287938isSelfEvaluating 287939 ^self == Processor! ! 287940 287941 287942!ProcessorScheduler methodsFor: 'printing' stamp: 'NouryBouraqadi 10/1/2009 07:48'! 287943printOn: aStream 287944 self isSelfEvaluating ifFalse: [^super printOn: aStream]. 287945 aStream nextPutAll: #Processor! ! 287946 287947"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 287948 287949ProcessorScheduler class 287950 instanceVariableNames: ''! 287951 287952!ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/11/97 10:44'! 287953idleProcess 287954 "A default background process which is invisible." 287955 287956 [true] whileTrue: 287957 [self relinquishProcessorForMicroseconds: 1000]! ! 287958 287959!ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/3/97 11:17'! 287960relinquishProcessorForMicroseconds: anInteger 287961 "Platform specific. This primitive is used to return processor cycles to the host operating system when Squeak's idle process is running (i.e., when no other Squeak process is runnable). On some platforms, this primitive causes the entire Squeak application to sleep for approximately the given number of microseconds. No Squeak process can run while the Squeak application is sleeping, even if some external event makes it runnable. On the Macintosh, this primitive simply calls GetNextEvent() to give other applications a chance to run. On platforms without a host operating system, it does nothing. This primitive should not be used to add pauses to a Squeak process; use a Delay instead." 287962 287963 <primitive: 230> 287964 "don't fail if primitive is not implemented, just do nothing" 287965! ! 287966 287967!ProcessorScheduler class methodsFor: 'background process' stamp: 'di 2/4/1999 08:45'! 287968startUp 287969 "Install a background process of the lowest possible priority that is always runnable." 287970 "Details: The virtual machine requires that there is aways some runnable process that can be scheduled; this background process ensures that this is the case." 287971 287972 Smalltalk installLowSpaceWatcher. 287973 BackgroundProcess == nil ifFalse: [BackgroundProcess terminate]. 287974 BackgroundProcess := [self idleProcess] newProcess. 287975 BackgroundProcess priority: SystemRockBottomPriority. 287976 BackgroundProcess resume. 287977! ! 287978 287979!ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/11/97 10:32'! 287980sweepHandIdleProcess 287981 "A default background process which shows a sweeping circle of XOR-ed bits on the screen." 287982 287983 | sweepHand | 287984 sweepHand := Pen new. 287985 sweepHand defaultNib: 2. 287986 sweepHand combinationRule: 6. 287987 [true] whileTrue: [ 287988 2 timesRepeat: [ 287989 sweepHand north. 287990 36 timesRepeat: [ 287991 sweepHand place: Display boundingBox topRight + (-25@25). 287992 sweepHand go: 20. 287993 sweepHand turn: 10]]. 287994 self relinquishProcessorForMicroseconds: 10000]. 287995! ! 287996 287997 287998!ProcessorScheduler class methodsFor: 'class initialization' stamp: 'ar 7/8/2001 16:39'! 287999initialize 288000 288001 SystemRockBottomPriority := 10. 288002 SystemBackgroundPriority := 20. 288003 UserBackgroundPriority := 30. 288004 UserSchedulingPriority := 40. 288005 UserInterruptPriority := 50. 288006 LowIOPriority := 60. 288007 HighIOPriority := 70. 288008 TimingPriority := 80. 288009 288010 "ProcessorScheduler initialize."! ! 288011 288012 288013!ProcessorScheduler class methodsFor: 'instance creation'! 288014new 288015 "New instances of ProcessorScheduler should not be created." 288016 288017 self error: 288018'New ProcessSchedulers should not be created since 288019the integrity of the system depends on a unique scheduler'! ! 288020BorderedMorph subclass: #ProgressBarMorph 288021 instanceVariableNames: 'value progressColor lastValue' 288022 classVariableNames: '' 288023 poolDictionaries: '' 288024 category: 'Morphic-Widgets'! 288025 288026!ProgressBarMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 22:14'! 288027progressColor 288028 ^progressColor! ! 288029 288030!ProgressBarMorph methodsFor: 'accessing' stamp: 'sma 3/3/2000 18:52'! 288031progressColor: aColor 288032 progressColor = aColor 288033 ifFalse: 288034 [progressColor := aColor. 288035 self changed]! ! 288036 288037!ProgressBarMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 22:09'! 288038value 288039 ^value! ! 288040 288041!ProgressBarMorph methodsFor: 'accessing' stamp: 'sma 3/3/2000 18:53'! 288042value: aModel 288043 value ifNotNil: [value removeDependent: self]. 288044 value := aModel. 288045 value ifNotNil: [value addDependent: self]! ! 288046 288047 288048!ProgressBarMorph methodsFor: 'drawing' stamp: 'sma 3/3/2000 18:54'! 288049drawOn: aCanvas 288050 | width inner | 288051 super drawOn: aCanvas. 288052 inner := self innerBounds. 288053 width := (inner width * lastValue) truncated min: inner width. 288054 aCanvas fillRectangle: (inner origin extent: width @ inner height) color: progressColor.! ! 288055 288056 288057!ProgressBarMorph methodsFor: 'initialization' stamp: 'sma 3/3/2000 18:55'! 288058initialize 288059 super initialize. 288060 progressColor := Color green. 288061 self value: (ValueHolder new contents: 0.0). 288062 lastValue := 0.0! ! 288063 288064 288065!ProgressBarMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:43'! 288066addCustomMenuItems: aCustomMenu hand: aHandMorph 288067 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 288068 aCustomMenu addList: { 288069 {'progress color...' translated. #changeProgressColor:}. 288070 {'progress value...' translated. #changeProgressValue:}. 288071 }! ! 288072 288073!ProgressBarMorph methodsFor: 'menu' stamp: 'ar 10/5/2000 18:51'! 288074changeProgressColor: evt 288075 | aHand | 288076 aHand := evt ifNotNil: [evt hand] ifNil: [self primaryHand]. 288077 self changeColorTarget: self selector: #progressColor: originalColor: self progressColor hand: aHand.! ! 288078 288079!ProgressBarMorph methodsFor: 'menu' stamp: 'alain.plantec 2/6/2009 15:48'! 288080changeProgressValue: evt 288081 | answer | 288082 answer := UIManager default 288083 request: 'Enter new value (0 - 1.0)' translated 288084 initialAnswer: self value contents asString. 288085 answer isEmptyOrNil ifTrue: [^ self]. 288086 self value contents: answer asNumber! ! 288087 288088 288089!ProgressBarMorph methodsFor: 'updating' stamp: 'sma 3/3/2000 18:51'! 288090update: aSymbol 288091 aSymbol == #contents 288092 ifTrue: 288093 [lastValue := value contents. 288094 self changed]! ! 288095Exception subclass: #ProgressInitiationException 288096 instanceVariableNames: 'workBlock maxVal minVal aPoint progressTitle' 288097 classVariableNames: '' 288098 poolDictionaries: '' 288099 category: 'Exceptions-Kernel'! 288100!ProgressInitiationException commentStamp: '<historical>' prior: 0! 288101I provide a way to alter the behavior of the old-style progress notifier in String. See examples in: 288102 288103ProgressInitiationException testWithout. 288104ProgressInitiationException testWith. 288105! 288106 288107 288108!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'alain.plantec 6/1/2008 19:09'! 288109defaultAction 288110 | result progress | 288111 progress := SystemProgressMorph label: progressTitle min: minVal max: maxVal. 288112 [result := workBlock value: progress] ensure: [SystemProgressMorph close: progress]. 288113 self resume: result! ! 288114 288115!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'John M McIntosh 3/2/2009 20:43'! 288116defaultMorphicAction 288117 | t1 t2 | 288118 t1 := SystemProgressMorph 288119 label: progressTitle 288120 min: minVal 288121 max: maxVal. 288122 [t2 := workBlock value: t1] 288123 ensure: [SystemProgressMorph close: t1]. 288124 self resume: t2! ! 288125 288126!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'RAA 5/15/2000 11:43'! 288127display: argString at: argPoint from: argMinVal to: argMaxVal during: argWorkBlock 288128 288129 progressTitle := argString. 288130 aPoint := argPoint. 288131 minVal := argMinVal. 288132 maxVal := argMaxVal. 288133 workBlock := argWorkBlock. 288134 ^self signal! ! 288135 288136!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'RAA 5/15/2000 12:40'! 288137sendNotificationsTo: aNewBlock 288138 288139 self resume: ( 288140 workBlock value: [ :barVal | 288141 aNewBlock value: minVal value: maxVal value: barVal 288142 ] 288143 ) 288144! ! 288145 288146"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 288147 288148ProgressInitiationException class 288149 instanceVariableNames: ''! 288150 288151!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'RAA 5/15/2000 15:46'! 288152testInnermost 288153 288154 "test the progress code WITHOUT special handling" 288155 288156 ^'Now here''s some Real Progress' 288157 displayProgressAt: Sensor cursorPoint 288158 from: 0 288159 to: 10 288160 during: [ :bar | 288161 1 to: 10 do: [ :x | 288162 bar value: x. (Delay forMilliseconds: 500) wait. 288163 x = 5 ifTrue: [1/0]. "just to make life interesting" 288164 ]. 288165 'done' 288166 ]. 288167 288168! ! 288169 288170!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'RAA 5/15/2000 12:42'! 288171testWith 288172 288173 "test progress code WITH special handling of progress notifications" 288174 288175 ^[ self testWithAdditionalInfo ] 288176 on: ProgressInitiationException 288177 do: [ :ex | 288178 ex sendNotificationsTo: [ :min :max :curr | 288179 Transcript show: min printString,' ',max printString,' ',curr printString; cr 288180 ]. 288181 ]. 288182! ! 288183 288184!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'RAA 5/15/2000 12:04'! 288185testWithAdditionalInfo 288186 288187 ^{'starting'. self testWithout. 'really!!'}! ! 288188 288189!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'RAA 5/15/2000 15:45'! 288190testWithout 288191 288192 "test the progress code WITHOUT special handling" 288193 288194 ^[self testInnermost] 288195 on: ZeroDivide 288196 do: [ :ex | ex resume] 288197 288198! ! 288199 288200 288201!ProgressInitiationException class methodsFor: 'signalling' stamp: 'ajh 1/22/2003 23:51'! 288202display: aString at: aPoint from: minVal to: maxVal during: workBlock 288203 288204 ^ self new 288205 display: aString at: aPoint from: minVal to: maxVal during: workBlock! ! 288206RectangleMorph subclass: #ProgressMorph 288207 instanceVariableNames: 'labelMorph subLabelMorph progress' 288208 classVariableNames: '' 288209 poolDictionaries: '' 288210 category: 'Morphic-Widgets'! 288211 288212!ProgressMorph methodsFor: 'accessing' stamp: 'mir 2/14/2000 17:55'! 288213done 288214 ^self progress value contents! ! 288215 288216!ProgressMorph methodsFor: 'accessing'! 288217done: amountDone 288218 self progress value contents: ((amountDone min: 1.0) max: 0.0). 288219 self currentWorld displayWorld! ! 288220 288221!ProgressMorph methodsFor: 'accessing' stamp: 'sma 3/3/2000 19:05'! 288222incrDone: incrDone 288223 self done: self done + incrDone! ! 288224 288225!ProgressMorph methodsFor: 'accessing' stamp: 'mir 1/19/2000 13:28'! 288226label 288227 ^self labelMorph contents! ! 288228 288229!ProgressMorph methodsFor: 'accessing'! 288230label: aString 288231 self labelMorph contents: aString. 288232 self currentWorld displayWorld! ! 288233 288234!ProgressMorph methodsFor: 'accessing' stamp: 'mir 1/19/2000 13:25'! 288235progress 288236 ^progress ifNil: [self initProgressMorph]! ! 288237 288238!ProgressMorph methodsFor: 'accessing' stamp: 'mir 1/19/2000 13:27'! 288239subLabel 288240 ^self subLabelMorph contents! ! 288241 288242!ProgressMorph methodsFor: 'accessing'! 288243subLabel: aString 288244 self subLabelMorph contents: aString. 288245 self currentWorld displayWorld! ! 288246 288247 288248!ProgressMorph methodsFor: 'initialization' stamp: 'sma 3/3/2000 19:13'! 288249initLabelMorph 288250 ^ labelMorph := StringMorph contents: '' font: (self fontOfPointSize: 14)! ! 288251 288252!ProgressMorph methodsFor: 'initialization' stamp: 'dvf 9/17/2003 05:14'! 288253initProgressMorph 288254 progress := ProgressBarMorph new. 288255 progress borderWidth: 1. 288256 progress color: Color white. 288257 progress progressColor: Color gray. 288258 progress extent: 200 @ 15. 288259! ! 288260 288261!ProgressMorph methodsFor: 'initialization' stamp: 'sma 3/3/2000 19:13'! 288262initSubLabelMorph 288263 ^ subLabelMorph := StringMorph contents: '' font: (self fontOfPointSize: 12)! ! 288264 288265!ProgressMorph methodsFor: 'initialization' stamp: 'mir 1/19/2000 13:28'! 288266initialize 288267 super initialize. 288268 self setupMorphs! ! 288269 288270!ProgressMorph methodsFor: 'initialization' stamp: 'nk 4/21/2002 20:06'! 288271setupMorphs 288272 | | 288273 self initProgressMorph. 288274 self 288275 layoutPolicy: TableLayout new; 288276 listDirection: #topToBottom; 288277 cellPositioning: #topCenter; 288278 listCentering: #center; 288279 hResizing: #shrinkWrap; 288280 vResizing: #shrinkWrap; 288281 color: Color transparent. 288282 288283 self addMorphBack: self labelMorph. 288284 self addMorphBack: self subLabelMorph. 288285 self addMorphBack: self progress. 288286 288287 self borderWidth: 2. 288288 self borderColor: Color black. 288289 288290 self color: Color veryLightGray. 288291 self align: self fullBounds center with: Display boundingBox center 288292! ! 288293 288294 288295!ProgressMorph methodsFor: 'private' stamp: 'nk 7/12/2003 08:59'! 288296fontOfPointSize: size 288297 ^ (TextConstants at: Preferences standardEToysFont familyName ifAbsent: [TextStyle default]) fontOfPointSize: size! ! 288298 288299!ProgressMorph methodsFor: 'private' stamp: 'mir 1/19/2000 13:25'! 288300labelMorph 288301 ^labelMorph ifNil: [self initLabelMorph]! ! 288302 288303!ProgressMorph methodsFor: 'private' stamp: 'mir 1/19/2000 13:25'! 288304subLabelMorph 288305 ^subLabelMorph ifNil: [self initSubLabelMorph]! ! 288306 288307"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 288308 288309ProgressMorph class 288310 instanceVariableNames: ''! 288311 288312!ProgressMorph class methodsFor: 'example' stamp: 'sma 3/3/2000 19:07'! 288313example 288314 "ProgressMorph example" 288315 288316 | progress | 288317 progress := ProgressMorph label: 'Test progress'. 288318 progress subLabel: 'this is the subheading'. 288319 progress openInWorld. 288320 [10 timesRepeat: 288321 [(Delay forMilliseconds: 200) wait. 288322 progress incrDone: 0.1]. 288323 progress delete] fork! ! 288324 288325 288326!ProgressMorph class methodsFor: 'instance creation' stamp: 'mir 1/19/2000 13:07'! 288327label: aString 288328 ^self new label: aString! ! 288329Notification subclass: #ProgressNotification 288330 instanceVariableNames: 'amount done extra' 288331 classVariableNames: '' 288332 poolDictionaries: '' 288333 category: 'Exceptions-Kernel'! 288334!ProgressNotification commentStamp: '<historical>' prior: 0! 288335Used to signal progress without requiring a specific receiver to notify. Caller/callee convention could be to simply count the number of signals caught or to pass more substantive information with #signal:.! 288336 288337 288338!ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:11'! 288339amount 288340 ^amount! ! 288341 288342!ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! 288343amount: aNumber 288344 amount := aNumber! ! 288345 288346!ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:11'! 288347done 288348 ^done! ! 288349 288350!ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! 288351done: aNumber 288352 done := aNumber! ! 288353 288354!ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! 288355extraParam 288356 ^extra! ! 288357 288358!ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! 288359extraParam: anObject 288360 extra := anObject! ! 288361 288362"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 288363 288364ProgressNotification class 288365 instanceVariableNames: ''! 288366 288367!ProgressNotification class methodsFor: 'exceptioninstantiator' stamp: 'ajh 1/22/2003 23:51'! 288368signal: signalerText extra: extraParam 288369 "TFEI - Signal the occurrence of an exceptional condition with a specified textual description." 288370 288371 | ex | 288372 ex := self new. 288373 ex extraParam: extraParam. 288374 ^ex signal: signalerText! ! 288375Notification subclass: #ProgressTargetRequestNotification 288376 instanceVariableNames: '' 288377 classVariableNames: '' 288378 poolDictionaries: '' 288379 category: 'Exceptions-Kernel'! 288380!ProgressTargetRequestNotification commentStamp: '<historical>' prior: 0! 288381I am used to allow the ComplexProgressIndicator one last chance at finding an appropriate place to display. If I am unhandled, then the cursor location and a default rectangle are used.! 288382 288383 288384!ProgressTargetRequestNotification methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 12:25'! 288385defaultAction 288386 288387 self resume: nil! ! 288388Model subclass: #Project 288389 instanceVariableNames: 'world changeSet transcript parentProject previousProject displayDepth viewSize thumbnail nextProject guards projectParameters isolatedHead inForce version urlList environment lastDirectory lastSavedAtSeconds projectPreferenceFlagDictionary resourceManager' 288390 classVariableNames: 'AllProjects CurrentProject GoalFreePercent GoalNotMoreThan UIProcess' 288391 poolDictionaries: '' 288392 category: 'System-Support'! 288393!Project commentStamp: 'tk 12/2/2004 12:38' prior: 0! 288394A Project stores the state of a complete Squeak desktop, including 288395the windows, and the currently active changeSet. A project knows who 288396its parent project is. When you change projects, whether by entering 288397or exiting, the screen state of the project being exited is saved in 288398that project. 288399 288400A project is retained by its view in the parent world. It is 288401effectively named by the name of its changeSet, which can be changed 288402either by renaming in a changeSorter, or by editing the label of its 288403view from the parent project. 288404 288405As the site of major context switch, Projects are the locus of 288406swapping between the old MVC and the new Morphic worlds. The 288407distinction is based on whether the variable 'world' contains a 288408WorldMorph or a ControlManager. 288409 288410Saving and Loading 288411Projects may be stored on the disk in external format. (Project 288412named: 'xxx') exportSegment, or choose 'store project on file...'. 288413Projects may be loaded from a server and stored back. Storing on a 288414server never overwrites; it always makes a new version. A project 288415remembers the url of where it lives in urlList. The list is length 288416one, for now. The url may point to a local disk instead of a server. 288417All projects that the user looks at, are cached in the Squeaklet 288418folder. Sorted by server. The cache holds the most recent version 288419only. 288420 288421When a project is loaded into Squeak, its objects are converted to 288422the current version. There are three levels of conversion. First, 288423each object is converted from raw bits to an object in its old 288424format. Then it is sent some or all of these messages: 288425 comeFullyUpOnReload: smartRefStream Used to 288426re-discover an object that already exists in this image, such as a 288427resource, global variable, Character, or Symbol. (sent to objects in 288428outPointers) 288429 convertToCurrentVersion: varDict refStream: smartRefStrm 288430 fill in fields that have been added to a class since 288431the object was stored. Used to set the extra inst var to a default 288432value. Or, return a new object of a different class. (sent to 288433objects that changed instance variables) 288434 fixUponLoad: aProject refStream: smartRefStrm 288435 change the object due to conventions that have changed on the 288436project level. (sent to all objects in the incoming project) 288437 288438Here is the calling sequence for storing out a Project: 288439Project saveAs 288440Project storeOnServer 288441Project storeOnServerWithProgressInfo 288442Project storeOnServerInnards 288443Project exportSegmentFileName:directory: 288444Project exportSegmentWithChangeSet:fileName:directory: 288445ImageSegment writeForExportWithSources:inDirectory:changeSet: 288446--------- 288447Isolation (not used any more) 288448When you accept a method, the entire system feels the change, except 288449projects that are "isolated". In an isolated project, all new global 288450variables (including new classes) arestored in the project-local 288451environment, and all changes to preexisting classes are revoked when 288452you leave the project. When you enter another project, that 288453project's changes are invoked. Invocation and revocation are handled 288454efficiently by swapping pointers. To make a project be isolated, 288455choose 'isolate changes of this project' from the 'changes...' 288456section of the screen menu. You can use an isolated project for 288457making dangerous change to a system, and you can get out if it 288458crashes. A foreign application can have the separate environment it 288459wants. Also, you can freeze part of the system for a demo that you 288460don't want to disturb. An isolated project shares methods with all 288461subprojects inside it, unless they are isolated themselves. Each 288462isolated project is the head of a tree of projects with which it 288463shares all methods. 288464 288465You may 'assert' all changes ever made in the current project to take 288466effect above this project. This amounts to exporting all the globals 288467in the current environment, and zapping the revocation lists to that 288468the current state of the world will remain in force upon exit from 288469this project. 288470 288471[Later: A project may be 'frozen'. Asserts do not apply to it after 288472that. (Great for demos.) You should be informed when an assert was 288473blocked in a frozen project.] 288474 288475Class definitions are layered by the isolation mechanism. You are 288476only allowed to change the shape of a class in projects that lie 288477within its isolation scope. All versions of the methods are 288478recompiled, in all projects. If you remove an inst var that is in 288479use in an isolated project, it will become an Undeclared global. It 288480is best not to remove an inst var when it is being used in another 288481isolated project. [If we recompile them all, why can't we diagnose 288482the problem before allowing the change??] 288483 288484Senders and Implementors do not see versions of a method in isolated 288485projects. [again, we might want to make this possible at a cost]. 288486When you ask for versions of a method, you will not get the history 288487in other isolated projects. 288488 288489Moving methods and classes between changeSets, and merging changeSets 288490has no effect on which methods are in force. But, when you look at a 288491changeSet from a different isolated project, the methods will contain 288492code that is not in force. A changeSet is just a list of method 288493names, and does not keep separate copies of any code. 288494 288495When finer grained assertion is needed, use the method (aProject 288496assertClass: aClass from: thisProject warn: warnConflicts). 288497 288498How isolated changes work: The first time a class changes, store its 288499MethodDictionary object. Keep parallel arrays of associations to 288500Classes and MethodDictionaries. Traverse these and install them when 288501you enter an "ioslated project". When you leave, store this 288502project's own MethodDictionaries there. 288503 To do an assert, we must discover which methods changed here, 288504and which changed only in the project we are asserting into. There 288505is one copy of the 'virgin' method dictionaries in the system. It is 288506always being temporarily stored by the currently inForce isolated 288507project. 288508 288509isolatedHead - true for the top project, and for each isolated 288510project. false or nil for any subproject that shares all methods 288511with its parent project. 288512 288513inForce - true if my methods are installed now. false if I am 288514dormant. [is this equivalent to self == Project Current?] 288515 288516classArray - list of associations to classes 288517 288518methodDictArray - the method dictionaries of those classes before we 288519started changing methods. They hang onto the original 288520compiledMethods. (If this project is dormant, it contains the method 288521dictionaries of those classes as they will be here, in this project). 288522 288523orgArray - the class organizations of the classes in classArray. 288524 288525UsingIsolation (class variable) - No longer used. 288526 288527When you want to save a project in export format from within that 288528very project, it gets tricky. We set two flags in parentProject, 288529exit to it, and let parentProject write the project. 288530ProjectViewMorph in parentProject checks in its step method, does the 288531store, clears the flags, and reenters the subProject. 288532 288533! 288534 288535 288536!Project methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/14/2009 17:03'! 288537assureTaskbarPresenceMatchesPreference 288538 "Synchronize the state of the receiver's taskbar with the preference." 288539 288540 (self showWorldTaskbar) 288541 ifTrue: [self createTaskbarIfNecessary] 288542 ifFalse: [self removeTaskbar]! ! 288543 288544!Project methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/9/2007 10:54'! 288545createTaskbarIfNecessary 288546 "Private - create a new taskbar if not present." 288547 288548 |w| 288549 w := self world. 288550 w taskbars ifEmpty: [ 288551 TaskbarMorph new openInWorld: w. 288552 self moveCollapsedWindowsToTaskbar]! ! 288553 288554!Project methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/9/2007 10:54'! 288555moveCollapsedWindowsToTaskbar 288556 "Move collapsed windows to the taskbar." 288557 288558 (World systemWindows select: [:w | w isCollapsed]) do: [:w | 288559 w restore; minimize]! ! 288560 288561!Project methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/9/2007 10:53'! 288562removeTaskbar 288563 "Remove the receiver's taskbars." 288564 288565 self world taskbars do: [:each | each removeFromWorld]! ! 288566 288567!Project methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/9/2007 10:38'! 288568showWorldTaskbar 288569 "Answer whether the taskbar should exist in this project." 288570 288571 ^self projectPreferenceFlagDictionary 288572 at: #showWorldTaskbar 288573 ifAbsent: [Preferences showWorldTaskbar]! ! 288574 288575!Project methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/9/2007 10:44'! 288576showWorldTaskbar: aBoolean 288577 "Change the receiver to show the taskbar." 288578 288579 self projectPreferenceFlagDictionary at: #showWorldTaskbar put: aBoolean. 288580 self == Project current ifTrue: [ 288581 aBoolean == Preferences showWorldTaskbar 288582 ifFalse: [Preferences setPreference: #showWorldTaskbar toValue: aBoolean]]. 288583 self assureTaskbarPresenceMatchesPreference! ! 288584 288585 288586!Project methodsFor: 'accessing' stamp: 'sw 9/7/2000 06:56'! 288587addSubProjectNamesTo: aStream indentation: anIndentation 288588 "Add the names of the receiver and all its subprojects, and all *their* subprojects recursively, to aStream, indenting by the specified number of tab stops " 288589 288590 self isTopProject ifFalse: "circumvent an annoying cr at the top " 288591 [aStream cr]. 288592 aStream tab: anIndentation; nextPutAll: self name. 288593 self subProjects do: 288594 [:p | 288595 p addSubProjectNamesTo: aStream indentation: anIndentation + 1]! ! 288596 288597!Project methodsFor: 'accessing' stamp: 'tk 4/5/2000 16:29'! 288598changeSet 288599 ^ changeSet! ! 288600 288601!Project methodsFor: 'accessing' stamp: 'sw 10/27/2000 05:55'! 288602currentStack: aStack 288603 "Set the current stack as indicated; if the parameter supplied is nil, delete any prior memory of the CurrentStack" 288604 288605 aStack 288606 ifNil: 288607 [self removeParameter: #CurrentStack] 288608 ifNotNil: 288609 [self projectParameterAt: #CurrentStack put: aStack]! ! 288610 288611!Project methodsFor: 'accessing'! 288612displayDepth: newDepth 288613 displayDepth := newDepth! ! 288614 288615!Project methodsFor: 'accessing' stamp: 'alain.plantec 6/1/2008 19:17'! 288616findProjectView: projectDescription 288617 | pName dpName | 288618 "In this world, find the morph that holds onto the project described by projectDescription. projectDescription can be a project, or the name of a project. The project may be represented by a DiskProxy. The holder morph may be at any depth in the world. 288619 Need to fix this if Projects have subclasses, or if a class other than ProjectViewMorph can officially hold onto a project. (Buttons, links, etc) 288620 If parent is an MVC world, return the ProjectController." 288621 288622 self flag: #bob. "read the comment" 288623 288624 pName := (projectDescription isString) 288625 ifTrue: [projectDescription] 288626 ifFalse: [projectDescription name]. 288627 world allMorphsDo: [:pvm | 288628 pvm class == ProjectViewMorph ifTrue: [ 288629 (pvm project class == Project and: 288630 [pvm project name = pName]) ifTrue: [^ pvm]. 288631 288632 pvm project class == DiskProxy ifTrue: [ 288633 dpName := pvm project constructorArgs first. 288634 dpName := (dpName findTokens: '/') last. 288635 dpName := (Project parseProjectFileName: dpName unescapePercents) first. 288636 dpName = pName ifTrue: [^ pvm]]]]. 288637 ^ nil! ! 288638 288639!Project methodsFor: 'accessing' stamp: 'mir 6/22/2001 20:06'! 288640forgetExistingURL 288641 self resourceManager makeAllProjectResourcesLocalTo: self resourceUrl. 288642 urlList := nil! ! 288643 288644!Project methodsFor: 'accessing' stamp: 'RAA 6/3/2000 10:23'! 288645isCurrentProject 288646 288647 ^self == CurrentProject! ! 288648 288649!Project methodsFor: 'accessing' stamp: 'di 3/29/2000 15:37'! 288650isTopProject 288651 "Return true only if this is the top project (its own parent). 288652 Also include the test here for malformed project hierarchy." 288653 288654 parentProject == self ifTrue: [^ true]. 288655 parentProject == nil ifTrue: [self error: 'No project should have a nil parent']. 288656 ^ false! ! 288657 288658!Project methodsFor: 'accessing' stamp: 'tk 6/26/1998 22:17'! 288659labelString 288660 ^ changeSet name! ! 288661 288662!Project methodsFor: 'accessing' stamp: 'mir 6/7/2001 16:18'! 288663lastDirectory: aDirectoryOrNil 288664 lastDirectory := aDirectoryOrNil! ! 288665 288666!Project methodsFor: 'accessing' stamp: 'RAA 9/28/2000 18:33'! 288667lastSavedAtSeconds 288668 288669 ^lastSavedAtSeconds! ! 288670 288671!Project methodsFor: 'accessing' stamp: 'di 7/19/1999 15:06'! 288672name 288673 changeSet == nil ifTrue: [^ 'no name']. 288674 ^ changeSet name! ! 288675 288676!Project methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:52'! 288677nameAdjustedForDepth 288678 "Answer the name of the project, prepended with spaces reflecting the receiver's depth from the top project" 288679 " Project current nameAdjustedForDepth " 288680 288681 | stream | 288682 stream := String new writeStream. 288683 self depth timesRepeat: 288684 [2 timesRepeat: [stream nextPut: $ ]]. 288685 stream nextPutAll: self name. 288686 ^ stream contents! ! 288687 288688!Project methodsFor: 'accessing' stamp: 'sw 2/15/1999 12:12'! 288689nextProject 288690 ^ nextProject 288691! ! 288692 288693!Project methodsFor: 'accessing' stamp: 'di 3/6/98 10:22'! 288694parent 288695 ^ parentProject! ! 288696 288697!Project methodsFor: 'accessing' stamp: 'jm 5/20/1998 23:31'! 288698previousProject 288699 ^ previousProject 288700! ! 288701 288702!Project methodsFor: 'accessing'! 288703projectChangeSet 288704 ^ changeSet! ! 288705 288706!Project methodsFor: 'accessing'! 288707renameTo: newName 288708 | oldBase | 288709 newName = self name 288710 ifFalse: [ 288711 oldBase := self resourceDirectoryName. 288712 version := nil. 288713 self resourceManager adjustToRename: self resourceDirectoryName from: oldBase. 288714 self changeSet name: newName. 288715 ].! ! 288716 288717!Project methodsFor: 'accessing' stamp: 'di 4/14/1999 13:59'! 288718setParent: newParent 288719 288720 parentProject := newParent. 288721 nextProject := previousProject := nil.! ! 288722 288723!Project methodsFor: 'accessing' stamp: 'RAA 5/10/2001 14:57'! 288724setThumbnail: aForm 288725 288726 self flag: #bob. "no longer used??" 288727 thumbnail := aForm! ! 288728 288729!Project methodsFor: 'accessing' stamp: 'di 1/21/98 11:06'! 288730setViewSize: aPoint 288731 viewSize := aPoint! ! 288732 288733!Project methodsFor: 'accessing' stamp: 'mir 6/26/2001 17:09'! 288734storeNewPrimaryURL: aURLString 288735 | oldResourceUrl | 288736 oldResourceUrl := self resourceUrl. 288737 urlList isEmptyOrNil ifTrue: [urlList := Array new: 1]. 288738 urlList at: 1 put: aURLString. 288739 self lastDirectory: nil. 288740 self resourceManager adjustToNewServer: self resourceUrl from: oldResourceUrl 288741! ! 288742 288743!Project methodsFor: 'accessing' stamp: 'di 1/21/98 11:07'! 288744thumbnail 288745 ^ thumbnail! ! 288746 288747!Project methodsFor: 'accessing' stamp: 'tk 4/5/2000 13:57'! 288748urlList 288749 ^ urlList! ! 288750 288751!Project methodsFor: 'accessing' stamp: 'di 1/21/98 11:06'! 288752viewSize 288753 ^ viewSize! ! 288754 288755!Project methodsFor: 'accessing'! 288756world 288757 ^ world! ! 288758 288759 288760!Project methodsFor: 'active process' stamp: 'dgd 4/4/2006 16:41'! 288761depth 288762 "Return the depth of this project from the top. 288763 topProject = 0, next = 1, etc." 288764 "Project current depth." 288765 288766 | depth topProject project | 288767 depth := 0. 288768 topProject := Project topProject. 288769 project := self. 288770 288771 [project ~= topProject and:[project notNil]] 288772 whileTrue: 288773 [project := project parent. 288774 depth := depth + 1]. 288775 ^ depth! ! 288776 288777 288778!Project methodsFor: 'displaying' stamp: 'RAA 10/6/2000 15:57'! 288779createViewIfAppropriate 288780 288781 ProjectViewOpenNotification signal ifTrue: [ 288782 Preferences projectViewsInWindows ifTrue: [ 288783 (ProjectViewMorph newProjectViewInAWindowFor: self) openInWorld 288784 ] ifFalse: [ 288785 (ProjectViewMorph on: self) openInWorld "but where??" 288786 ]. 288787 ]. 288788! ! 288789 288790!Project methodsFor: 'displaying' stamp: 'pavel.krivanek 3/12/2009 09:24'! 288791displayZoom: entering 288792 "Show the project transition when entering a new project" 288793 | newDisplay vanishingPoint | 288794 288795 "Show animated zoom to new display" 288796 newDisplay := self imageForm. 288797 entering 288798 ifTrue: [vanishingPoint := Sensor cursorPoint] 288799 ifFalse: [vanishingPoint := self viewLocFor: CurrentProject]. 288800 Display zoomIn: entering orOutTo: newDisplay at: 0@0 288801 vanishingPoint: vanishingPoint.! ! 288802 288803!Project methodsFor: 'displaying' stamp: 'ar 6/2/1999 01:58'! 288804imageForm 288805 ^self imageFormOfSize: Display extent 288806 depth: (displayDepth ifNil:[Display depth])! ! 288807 288808!Project methodsFor: 'displaying' stamp: 'alain.plantec 6/19/2008 09:55'! 288809imageFormOfSize: extentPoint depth: d 288810 | newDisplay | 288811 newDisplay := DisplayScreen extent: extentPoint depth: d. 288812 Display 288813 replacedBy: newDisplay 288814 do: [Display getCanvas fullDrawMorph: world]. 288815 ^ newDisplay! ! 288816 288817!Project methodsFor: 'displaying' stamp: 'sw 1/12/2000 18:44'! 288818showZoom 288819 "Decide if user wants a zoom transition, and if there is enough memory to do it." 288820 288821 ^ Preferences projectZoom and: 288822 "Only show zoom if there is room for both displays plus a megabyte" 288823 [Smalltalk garbageCollectMost > 288824 (Display boundingBox area*displayDepth //8+1000000)]! ! 288825 288826 288827!Project methodsFor: 'docking bars support' stamp: 'dgd 9/20/2004 16:29'! 288828assureMainDockingBarPresenceMatchesPreference 288829 "Syncronize the state of the receiver's dockings with the 288830 preference" 288831 (self showWorldMainDockingBar) 288832 ifTrue: [self createOrUpdateMainDockingBar] 288833 ifFalse: [self removeMainDockingBar]! ! 288834 288835!Project methodsFor: 'docking bars support' stamp: 'dgd 9/6/2004 18:47'! 288836createOrUpdateMainDockingBar 288837 "Private - create a new main docking bar or update the current one" 288838 | w mainDockingBars | 288839 w := self world. 288840 mainDockingBars := w mainDockingBars. 288841 mainDockingBars isEmpty 288842 ifTrue: ["no docking bar, just create a new one" 288843 TheWorldMainDockingBar instance createDockingBar openInWorld: w. 288844 ^ self]. 288845 "" 288846 "update if nedeed" 288847 mainDockingBars 288848 do: [:each | TheWorldMainDockingBar instance updateIfNeeded: each]! ! 288849 288850!Project methodsFor: 'docking bars support' stamp: 'dgd 9/6/2004 18:46'! 288851removeMainDockingBar 288852 "Remove the receiver's main docking bars" 288853 self world mainDockingBars 288854 do: [:each | each delete]! ! 288855 288856!Project methodsFor: 'docking bars support' stamp: 'dgd 9/20/2004 16:30'! 288857showWorldMainDockingBar 288858 288859 ^ self projectPreferenceFlagDictionary 288860 at: #showWorldMainDockingBar 288861 ifAbsent: [Preferences showWorldMainDockingBar]! ! 288862 288863!Project methodsFor: 'docking bars support' stamp: 'dgd 9/20/2004 19:28'! 288864showWorldMainDockingBarString 288865 ^ (self showWorldMainDockingBar 288866 ifTrue: ['<yes>'] 288867 ifFalse: ['<no>']) 288868 , 'show main docking bar (M)' translated! ! 288869 288870!Project methodsFor: 'docking bars support' stamp: 'dgd 9/6/2004 18:47'! 288871showWorldMainDockingBar: aBoolean 288872 "Change ther receiver to show the main docking bar" 288873 self projectPreferenceFlagDictionary at: #showWorldMainDockingBar put: aBoolean. 288874 "" 288875 self == Project current 288876 ifTrue: ["" 288877 aBoolean == Preferences showWorldMainDockingBar 288878 ifFalse: [Preferences setPreference: #showWorldMainDockingBar toValue: aBoolean]]. 288879 "" 288880 self assureMainDockingBarPresenceMatchesPreference! ! 288881 288882!Project methodsFor: 'docking bars support' stamp: 'dgd 9/20/2004 16:31'! 288883toggleShowWorldMainDockingBar 288884 self showWorldMainDockingBar: self showWorldMainDockingBar not! ! 288885 288886 288887!Project methodsFor: 'file in/out' stamp: 'ar 10/11/2000 15:25'! 288888assureIntegerVersion 288889 "For converting the project versions" 288890 self currentVersionNumber. "Does it for us"! ! 288891 288892!Project methodsFor: 'file in/out' stamp: 'ar 10/11/2000 15:06'! 288893bumpVersion: versionNumber 288894 "Make a new version after the previous version number" 288895 versionNumber ifNil:[^0]. 288896 ^versionNumber + 1! ! 288897 288898!Project methodsFor: 'file in/out' stamp: 'ar 5/30/2001 23:34'! 288899compressFilesIn: tempDir to: localName in: localDirectory resources: collector 288900 "Compress all the files in tempDir making up a zip file in localDirectory named localName" 288901 | archive entry urlMap archiveName | 288902 urlMap := Dictionary new. 288903 collector locatorsDo:[:loc| 288904 "map local file names to urls" 288905 urlMap at: (tempDir localNameFor: loc localFileName) put: loc urlString. 288906 ResourceManager cacheResource: loc urlString inArchive: localName]. 288907 archive := ZipArchive new. 288908 tempDir fileNames do:[:fn| 288909 archiveName := urlMap at: fn ifAbsent:[fn]. 288910 entry := archive addFile: (tempDir fullNameFor: fn) as: archiveName. 288911 entry desiredCompressionMethod: ZipArchive compressionStored. 288912 ]. 288913 archive writeToFileNamed: (localDirectory fullNameFor: localName). 288914 archive close. 288915 tempDir fileNames do:[:fn| 288916 tempDir deleteFileNamed: fn ifAbsent:[]]. 288917 localDirectory deleteDirectory: tempDir localName.! ! 288918 288919!Project methodsFor: 'file in/out' stamp: 'RAA 6/3/2000 10:25'! 288920couldBeSwappedOut 288921 288922 self flag: #bob. "need a better test in multi-project world" 288923 ^self isCurrentProject not! ! 288924 288925!Project methodsFor: 'file in/out' stamp: 'ar 10/11/2000 15:25'! 288926currentVersionNumber 288927 288928 version ifNil: [^0]. 288929 version isInteger ifTrue:[^version]. 288930 version := Base64MimeConverter decodeInteger: version unescapePercents. 288931 ^version! ! 288932 288933!Project methodsFor: 'file in/out' stamp: 'rbb 2/18/2005 08:57'! 288934decideAboutCreatingBlank: otherProjectName 288935 288936 | resp | 288937 288938 "20 Oct - just do it" 288939 true "version isNil" ifFalse: [ "if saved, then maybe don't create" 288940 resp := (UIManager default chooseFrom: #('Yes, make it up' 'No, skip it') 288941 title: ('I cannot locate the project\', 288942 otherProjectName, 288943 '\Would you like me to create a new project\with that name?' 288944 ) withCRs). 288945 resp = 1 ifFalse: [^ nil] 288946 ]. 288947 ^Project openBlankProjectNamed: otherProjectName! ! 288948 288949!Project methodsFor: 'file in/out' stamp: 'tak 6/12/2005 14:56'! 288950doArmsLengthCommand: aCommand 288951 288952 "We are no longer the active project, so do it" 288953 288954 [self perform: aCommand] 288955 ensure: [self enter: #specialReturn. "re-enter me and forget the temp project"] 288956 288957! ! 288958 288959!Project methodsFor: 'file in/out' stamp: 'mir 6/25/2001 10:50'! 288960downloadUrl 288961 "^(self primaryServerIfNil: [^'']) downloadUrl" 288962 ^lastDirectory 288963 ifNil: [(self primaryServerIfNil: [^'']) downloadUrl] 288964 ifNotNil: [lastDirectory downloadUrl]! ! 288965 288966!Project methodsFor: 'file in/out' stamp: 'RAA 10/26/2000 14:12'! 288967ensureChangeSetNameUnique 288968 288969 | myName | 288970 288971 myName := self name. 288972 Project allProjects do: [:pp | 288973 pp == self ifFalse: [ 288974 (pp name = myName and: [pp projectChangeSet ~~ changeSet]) ifTrue: [ 288975 (pp parameterAt: #loadingNewerVersion ifAbsent: [false]) ifTrue: [ 288976 pp projectParameters at: #loadingNewerVersion put: false. 288977 ] ifFalse: [ 288978 changeSet ifNil: [^ changeSet := ChangeSet new]. 288979 ^changeSet name: (ChangeSet uniqueNameLike: myName) 288980 ]. 288981 ] 288982 ] 288983 ] 288984! ! 288985 288986!Project methodsFor: 'file in/out' stamp: 'mir 6/7/2001 14:41'! 288987fromMyServerLoad: otherProjectName 288988 | pair pr dirToUse | 288989 "If a newer version of me is on the server, load it." 288990 288991 (pr := Project named: otherProjectName) ifNotNil: ["it appeared" 288992 ^ pr enter 288993 ]. 288994 dirToUse := self primaryServerIfNil: [ 288995 lastDirectory ifNil: [ 288996 self inform: 'Current project does not know a server either.'. 288997 ^nil]. 288998 lastDirectory]. 288999 289000 pair := self class mostRecent: otherProjectName onServer: dirToUse. 289001 pair first ifNil: [^self decideAboutCreatingBlank: otherProjectName]. "nothing to load" 289002 ^ProjectLoading 289003 installRemoteNamed: pair first 289004 from: dirToUse 289005 named: otherProjectName 289006 in: self 289007 289008! ! 289009 289010!Project methodsFor: 'file in/out' stamp: 'RAA 9/21/2000 15:30'! 289011hasBadNameForStoring 289012 289013 ^Project isBadNameForStoring: self name 289014! ! 289015 289016!Project methodsFor: 'file in/out' stamp: 'yo 12/14/2004 18:54'! 289017htmlPagePrototype 289018 "Return the HTML page prototype" 289019^'<html> 289020<head> 289021<title>Squeak Project</title> 289022<meta http-equiv="Content-Type" content="text/html; charset=utf-8"> 289023</head> 289024 289025<body bgcolor="#FFFFFF"> 289026<EMBED 289027 type="application/x-squeak-source" 289028 ALIGN="CENTER" 289029 WIDTH="$$WIDTH$$" 289030 HEIGHT="$$HEIGHT$$" 289031 src="$$PROJECT$$" 289032 pluginspage="http://www.squeakland.org/plugin/detect/detectinstaller.html"> 289033 289034</EMBED> 289035 289036</body> 289037</html> 289038'! ! 289039 289040!Project methodsFor: 'file in/out' stamp: 'RAA 10/26/2000 16:58'! 289041objectForDataStream: refStrm 289042 | uu dp | 289043 "I am about to be written on an object file. Write a path to me in the other system instead." 289044 289045 "Use a copy with no parent, previous or next to reduce extra stuff copied" 289046 refStrm project == self ifTrue: [^ self copy setParent: nil]. 289047 289048 dp := (uu := self url) size > 0 ifTrue: [ 289049 DiskProxy global: #Project selector: #namedUrl: args: {uu}. 289050 ] ifFalse: [ 289051 DiskProxy global: #Project selector: #named: args: {self name} 289052 ]. 289053 refStrm replace: self with: dp. 289054 ^ dp 289055! ! 289056 289057!Project methodsFor: 'file in/out' stamp: 'mir 6/7/2001 14:39'! 289058primaryServer 289059 "Return my primary server, that is the one I was downloaded from or are about to be stored on." 289060 ^self primaryServerIfNil: [nil]! ! 289061 289062!Project methodsFor: 'file in/out' stamp: 'mir 6/7/2001 14:39'! 289063primaryServerIfNil: aBlock 289064 "Return my primary server, that is the one I was downloaded from or are about to be stored on. If none is set execute the exception block" 289065 | serverList | 289066 serverList := self serverList. 289067 ^serverList isEmptyOrNil 289068 ifTrue: [aBlock value] 289069 ifFalse: [serverList first]! ! 289070 289071!Project methodsFor: 'file in/out' stamp: 'ar 2/27/2001 13:44'! 289072projectExtension 289073 ^self class projectExtension! ! 289074 289075!Project methodsFor: 'file in/out' stamp: 'tk 10/26/1999 14:23'! 289076revert 289077 | | 289078 "Exit this project and do not save it. Warn user unless in dangerous projectRevertNoAsk mode. Exit to the parent project. Do a revert on a clone of the segment, to allow later reverts." 289079 289080 projectParameters ifNil: [^ self inform: 'nothing to revert to']. 289081 parentProject enter: false revert: true saveForRevert: false. 289082 "does not return!!" 289083! ! 289084 289085!Project methodsFor: 'file in/out' stamp: 'stephane.ducasse 10/26/2008 17:03'! 289086saveAs 289087 "Forget where stored before, and store. Will ask user where." 289088 289089 self forgetExistingURL.! ! 289090 289091!Project methodsFor: 'file in/out' stamp: 'yo 7/2/2004 19:50'! 289092saveForRevert 289093 "Exit to the parent project. Do a GC. Save the project in a segment. Record the ImageSegment object as the revertToMe in Project parameters" 289094 289095 self isTopProject ifTrue: [^ self inform: 'Can''t exit the top project' translated]. 289096 parentProject enter: false revert: false saveForRevert: true. 289097 "does not return!!" 289098 289099! ! 289100 289101!Project methodsFor: 'file in/out' stamp: 'mir 8/10/2001 17:49'! 289102serverList 289103 | servers server | 289104 "Take my list of server URLs and return a list of ServerDirectories to write on." 289105 289106 urlList isEmptyOrNil ifTrue: [^ nil]. 289107 servers := OrderedCollection new. 289108 urlList do: [:url | 289109 server := ServerDirectory serverForURL: url. 289110 server ifNotNil: [servers add: server]. 289111 server := ServerDirectory serverForURL: url asUrl downloadUrl. 289112 server ifNotNil: [servers add: server]]. 289113 ^servers isEmpty 289114 ifTrue: [nil] 289115 ifFalse: [servers]! ! 289116 289117!Project methodsFor: 'file in/out' stamp: 'yo 12/14/2004 18:18'! 289118storeAttributeKey: key value: value on: aStream 289119 289120 (key includes: $:) ifTrue: [self error: 'key should not contain :']. 289121 aStream nextPutAll: key. 289122 aStream nextPutAll: ': '. 289123 aStream nextPutAll: value. 289124 aStream cr. 289125! ! 289126 289127!Project methodsFor: 'file in/out' stamp: 'KR 12/16/2005 11:07'! 289128storeAttributesOn: aStream 289129 289130 | details | 289131 self storeAttributeKey: 'Squeak-Version' value: SystemVersion current version on: aStream. 289132 self storeAttributeKey: 'Squeak-LatestUpdate' value: SystemVersion current highestUpdate printString on: aStream. 289133 self storeAttributeKey: 'File-Name-Encoding' value: LanguageEnvironment defaultFileNameConverter class encodingNames first on: aStream. 289134 289135 details := self world valueOfProperty: #ProjectDetails ifAbsent: [Dictionary new]. 289136 details associationsDo: [:assoc | 289137 self storeAttributeKey: assoc key asString value: assoc value asString on: aStream.]. 289138! ! 289139 289140!Project methodsFor: 'file in/out' stamp: 'tk 8/21/1999 07:31'! 289141storeDataOn: aDataStream 289142 "Write me out. All references to other projects are weak references. They only go out if they are written for another reason." 289143 | cntInstVars cntIndexedVars localInstVars offset | 289144 289145 cntInstVars := self class instSize. 289146 cntIndexedVars := self basicSize. 289147 localInstVars := Project instVarNames. 289148 offset := Project superclass instSize. 289149 aDataStream 289150 beginInstance: self class 289151 size: cntInstVars + cntIndexedVars. 289152 1 to: cntInstVars do: 289153 [:ii | 289154 (ii between: offset+1 and: offset + localInstVars size) 289155 ifTrue: [(#('parentProject' 'previousProject' 'nextProject') includes: 289156 (localInstVars at: ii-offset)) 289157 ifTrue: [aDataStream nextPutWeak: (self instVarAt: ii)] 289158 "owner only written if in our tree" 289159 ifFalse: [aDataStream nextPut: (self instVarAt: ii)]] 289160 ifFalse: [aDataStream nextPut: (self instVarAt: ii)]]. 289161 289162 1 to: cntIndexedVars do: 289163 [:i | aDataStream nextPut: (self basicAt: i)]! ! 289164 289165!Project methodsFor: 'file in/out' stamp: 'yo 12/14/2004 19:01'! 289166storeHtmlPageIn: aFileDirectory 289167 "Prepare the HTML wrapper for the current project" 289168 | file page | 289169 file := aFileDirectory forceNewFileNamed: (self name, FileDirectory dot,'html'). 289170 file ifNil: [^self]. 289171 file converter: UTF8TextConverter new. 289172 page := self htmlPagePrototype. 289173 page := page copyReplaceAll: '$$PROJECT$$' with: self versionedFileName. 289174 page := page copyReplaceAll: '$$WIDTH$$' with: world bounds width printString. 289175 page := page copyReplaceAll: '$$HEIGHT$$' with: world bounds height printString. 289176 page := page copyReplaceAll: String cr with: String lf. "not sure if necessary..." 289177 file nextPutAll: page. 289178 file close.! ! 289179 289180!Project methodsFor: 'file in/out' stamp: 'KR 12/16/2005 10:07'! 289181storeManifestFileIn: aFileDirectory 289182 289183 | file | 289184 file := aFileDirectory forceNewFileNamed: (self name, FileDirectory dot,'manifest'). 289185 file ifNil: [^ self]. 289186 file converter: UTF8TextConverter new. 289187 self storeAttributesOn: file. 289188 file close. 289189! ! 289190 289191!Project methodsFor: 'file in/out' stamp: 'stephane.ducasse 4/14/2009 11:38'! 289192storeSegment 289193 "Store my project out on the disk as an ImageSegment. Keep the 289194 outPointers in memory. Name it <project name>.seg. *** Caller must be 289195 holding (Project alInstances) to keep subprojects from going out. ***" 289196 | is sizeHint | 289197 World == world 289198 ifTrue: [^ false]. 289199 "self inform: 'Can''t send the current world out'." 289200 world isInMemory 289201 ifFalse: [^ false]. 289202 "already done" 289203 world 289204 ifNil: [^ false]. 289205 world presenter 289206 ifNil: [^ false]. 289207 World checkCurrentHandForObjectToPaste. 289208 sizeHint := self projectParameters 289209 at: #segmentSize 289210 ifAbsent: [0]. 289211 is := ImageSegment new 289212 copyFromRootsLocalFileFor: (Array with: world presenter with: world) 289213 sizeHint: sizeHint. 289214 "world, and all Players" 289215 is state = #tooBig 289216 ifTrue: [^ false]. 289217 is segment size < 2000 289218 ifTrue: ["debugging" 289219 Transcript show: self name , ' only ' , is segment size printString , 'bytes in Segment.'; 289220 cr]. 289221 self projectParameters at: #segmentSize put: is segment size. 289222 is extract; writeToFile: self name. 289223 ^ true! ! 289224 289225!Project methodsFor: 'file in/out' stamp: 'stephane.ducasse 4/14/2009 11:36'! 289226storeSegmentNoFile 289227 "For testing. Make an ImageSegment. Keep the outPointers in memory. 289228 Also useful if you want to enumerate the objects in the segment 289229 afterwards (allObjectsDo:)" 289230 | is str | 289231 World == world 289232 ifTrue: [^ self]. 289233 "inform: 'Can''t send the current world out'." 289234 world isInMemory 289235 ifFalse: [^ self]. 289236 "already done" 289237 "Only Morphic projects for now" 289238 world 289239 ifNil: [^ self]. 289240 world presenter 289241 ifNil: [^ self]. 289242 "Do this on project enter" 289243 World flapTabs 289244 do: [:ft | ft referent adaptToWorld: World]. 289245 "Hack to keep the Menu flap from pointing at my project" 289246 "Preferences setPreference: #useGlobalFlaps toValue: false." 289247 "Utilities globalFlapTabsIfAny do: 289248 [:aFlapTab | Utilities removeFlapTab: aFlapTab keepInList: false]. 289249 Utilities clobberFlapTabList. " 289250 "project world deleteAllFlapArtifacts." 289251 "self currentWorld deleteAllFlapArtifacts. " 289252 World checkCurrentHandForObjectToPaste2. 289253 is := ImageSegment new 289254 copyFromRootsLocalFileFor: (Array with: world presenter with: world) 289255 sizeHint: 0. 289256 "world, and all Players" 289257 is segment size < 800 289258 ifTrue: ["debugging" 289259 Transcript show: self name , ' did not get enough objects'; 289260 cr. 289261 ^ Beeper beep]. 289262 false 289263 ifTrue: [str := String 289264 streamContents: [:strm | 289265 strm nextPutAll: 'Only a tiny part of the project got into the segment'. 289266 strm nextPutAll: '\These are pointed to from the outside:' withCRs. 289267 is outPointers 289268 do: [:out | 289269 out class == Presenter 289270 ifTrue: [strm cr. 289271 out printOn: strm. 289272 self systemNavigation 289273 browseAllObjectReferencesTo: out 289274 except: (Array with: is outPointers) 289275 ifNone: [:obj | obj]]. 289276 (is arrayOfRoots includes: out class) 289277 ifTrue: [strm cr. 289278 out printOn: strm. 289279 self systemNavigation 289280 browseAllObjectReferencesTo: out 289281 except: (Array with: is outPointers) 289282 ifNone: [:obj | obj]]]]. 289283 self inform: str. 289284 ^ is inspect]. 289285 is extract ! ! 289286 289287!Project methodsFor: 'file in/out' stamp: 'nk 7/30/2004 17:52'! 289288storeSomeSegment 289289 "Try all projects to see if any is ready to go out. Send at most three of them. 289290 Previous one has to wait for a garbage collection before it can go out." 289291 289292 | cnt pList start proj gain | 289293 cnt := 0. 289294 gain := 0. 289295 pList := Project allProjects. 289296 start := pList size atRandom. "start in a random place" 289297 start to: pList size + start 289298 do: 289299 [:ii | 289300 proj := pList atWrap: ii. 289301 proj storeSegment 289302 ifTrue: 289303 ["Yes, did send its morphs to the disk" 289304 289305 gain := gain + (proj projectParameters at: #segmentSize ifAbsent: [0]). "a guess" 289306 Beeper beep. 289307 (cnt := cnt + 1) >= 2 ifTrue: [^gain]]]. 289308 Beeper beep. 289309 ^gain! ! 289310 289311!Project methodsFor: 'file in/out' stamp: 'md 10/22/2003 17:54'! 289312storeToMakeRoom 289313 "Write out enough projects to fulfill the space goals. 289314 Include the size of the project about to come in." 289315 289316 | params memoryEnd goalFree cnt gain proj skip tried | 289317 GoalFreePercent ifNil: [GoalFreePercent := 33]. 289318 GoalNotMoreThan ifNil: [GoalNotMoreThan := 20000000]. 289319 params := SmalltalkImage current getVMParameters. 289320 memoryEnd := params at: 3. 289321" youngSpaceEnd := params at: 2. 289322 free := memoryEnd - youngSpaceEnd. 289323" 289324 goalFree := GoalFreePercent asFloat / 100.0 * memoryEnd. 289325 goalFree := goalFree min: GoalNotMoreThan. 289326 world isInMemory ifFalse: ["enough room to bring it in" 289327 goalFree := goalFree + (self projectParameters at: #segmentSize ifAbsent: [0])]. 289328 cnt := 30. 289329 gain := Smalltalk garbageCollectMost. 289330 "skip a random number of projects that are in memory" 289331 proj := self. skip := 6 atRandom. 289332 [proj := proj nextInstance ifNil: [Project someInstance]. 289333 proj world isInMemory ifTrue: [skip := skip - 1]. 289334 skip > 0] whileTrue. 289335 cnt := 0. tried := 0. 289336 289337 [gain > goalFree] whileFalse: [ 289338 proj := proj nextInstance ifNil: [Project someInstance]. 289339 proj storeSegment ifTrue: ["Yes, did send its morphs to the disk" 289340 gain := gain + (proj projectParameters at: #segmentSize 289341 ifAbsent: [20000]). "a guess" 289342 Beeper beep. 289343 (cnt := cnt + 1) > 5 ifTrue: [^ self]]. "put out 5 at most" 289344 (tried := tried + 1) > 23 ifTrue: [^ self]]. "don't get stuck in a loop"! ! 289345 289346!Project methodsFor: 'file in/out' stamp: 'mir 6/25/2001 10:55'! 289347url 289348 | firstURL | 289349 "compose my url on the server" 289350 289351 urlList isEmptyOrNil ifTrue: [^'']. 289352 firstURL := urlList first. 289353 firstURL isEmpty 289354 ifFalse: [ 289355 firstURL last == $/ 289356 ifFalse: [firstURL := firstURL, '/']]. 289357 ^ firstURL, self versionedFileName 289358! ! 289359 289360!Project methodsFor: 'file in/out' stamp: 'mir 6/21/2001 15:45'! 289361versionForFileName 289362 "Project current versionForFileName" 289363 ^self class versionForFileName: self currentVersionNumber! ! 289364 289365!Project methodsFor: 'file in/out' stamp: 'RAA 10/15/2000 19:10'! 289366versionFrom: aServerFile 289367 "Store the version of the file I actually came from. My stored version was recorded before I knew the latest version number on the server!!" 289368 | theName serverUrl | 289369 289370 self flag: #bob. "this may become unnecessary once we get the version before writing" 289371 self flag: #bob. "need to recognize swiki servers" 289372 289373 serverUrl := aServerFile directoryUrl. 289374 theName := aServerFile localName. 289375 version := (Project parseProjectFileName: theName) second. 289376 (serverUrl beginsWith: 'ftp:') ifTrue: ["update our server location" 289377 self storeNewPrimaryURL: serverUrl 289378 ]. 289379! ! 289380 289381!Project methodsFor: 'file in/out' stamp: 'mir 6/21/2001 15:43'! 289382versionedFileName 289383 "Project current versionedFileName" 289384 ^String streamContents:[:s| 289385 s nextPutAll: self name. 289386 s nextPutAll: FileDirectory dot. 289387 s nextPutAll: self versionForFileName. 289388 s nextPutAll: FileDirectory dot. 289389 s nextPutAll: self projectExtension. 289390 ] 289391! ! 289392 289393!Project methodsFor: 'file in/out' stamp: 'tak 6/24/2005 11:30'! 289394writeFileNamed: localFileName fromDirectory: localDirectory toServer: primaryServerDirectory 289395 289396 | local resp gifFileName f | 289397 289398 local := localDirectory oldFileNamed: localFileName. 289399 resp := primaryServerDirectory upLoadProject: local named: localFileName resourceUrl: self resourceUrl retry: false. 289400 local close. 289401 resp == true ifFalse: [ 289402 "abandon resources that would've been stored with the project" 289403 self resourceManager abandonResourcesThat: 289404 [:loc| loc urlString beginsWith: self resourceUrl]. 289405 self error: 'the primary server of this project seems to be down (', 289406 resp printString,')'. 289407 ^ self 289408 ]. 289409 289410 gifFileName := self name,'.gif'. 289411 localDirectory deleteFileNamed: gifFileName ifAbsent: []. 289412 local := localDirectory fileNamed: gifFileName. 289413 thumbnail ifNil: [ 289414 (thumbnail := Form extent: 100@80) fillColor: Color orange 289415 ] ifNotNil: [ 289416 thumbnail unhibernate. 289417 ]. 289418 f := thumbnail colorReduced. "minimize depth" 289419 f depth > 8 ifTrue: [ 289420 f := thumbnail asFormOfDepth: 8 289421 ]. 289422 GIFReadWriter putForm: f onStream: local. 289423 local close. 289424 289425 [local := StandardFileStream readOnlyFileNamed: (localDirectory fullNameFor: gifFileName). 289426 (primaryServerDirectory isKindOf: FileDirectory) 289427 ifTrue: [primaryServerDirectory deleteFileNamed: gifFileName ifAbsent: []]. 289428 resp := primaryServerDirectory putFile: local named: gifFileName retry: false. 289429 ] on: Error do: [:ex |]. 289430 local close. 289431 289432 primaryServerDirectory updateProjectInfoFor: self. 289433 primaryServerDirectory sleep. "if ftp, close the connection" 289434! ! 289435 289436 289437!Project methodsFor: 'flaps support' stamp: 'marcus.denker 11/26/2008 14:14'! 289438assureFlapIntegrity 289439 "Make certain that the items on the disabled-global-flap list are actually 289440 global flaps, and if not, get rid of them. Also, old (and damaging) 289441 parameters that held references to actual disabled flaps are cleansed" 289442 | disabledFlapIDs currentGlobalIDs oldList | 289443 disabledFlapIDs := self 289444 parameterAt: #disabledGlobalFlapIDs 289445 ifAbsent: [Set new]. 289446 currentGlobalIDs := Flaps globalFlapTabsIfAny 289447 collect: [:f | f flapID]. 289448 oldList := Project current 289449 projectParameterAt: #disabledGlobalFlaps 289450 ifAbsent: []. 289451 oldList 289452 ifNotNil: [disabledFlapIDs := oldList 289453 collect: [:aFlap | aFlap flapID]. 289454 disabledFlapIDs addAll: {'Scripting' translated. 'Stack Tools' translated. 'Painting' translated}]. 289455 disabledFlapIDs := disabledFlapIDs 289456 select: [:anID | currentGlobalIDs includes: anID]. 289457 self projectParameterAt: #disabledGlobalFlapIDs put: disabledFlapIDs asSet. 289458 projectParameters 289459 ifNotNil: [projectParameters 289460 removeKey: #disabledGlobalFlaps 289461 ifAbsent: []]! ! 289462 289463!Project methodsFor: 'flaps support' stamp: 'alain.plantec 6/1/2008 19:14'! 289464cleanseDisabledGlobalFlapIDsList 289465 "Make certain that the items on the disabled-global-flap list are actually 289466 global flaps, and if not, get rid of them" 289467 | disabledFlapIDs currentGlobalIDs oldList | 289468 disabledFlapIDs := self 289469 parameterAt: #disabledGlobalFlapIDs 289470 ifAbsent: [Set new]. 289471 currentGlobalIDs := Flaps globalFlapTabsIfAny 289472 collect: [:f | f flapID]. 289473 oldList := Project current 289474 projectParameterAt: #disabledGlobalFlaps 289475 ifAbsent: []. 289476 oldList 289477 ifNotNil: [disabledFlapIDs := oldList 289478 select: [:aFlap | aFlap flapID]]. 289479 disabledFlapIDs := disabledFlapIDs 289480 select: [:anID | currentGlobalIDs includes: anID]. 289481 self projectParameterAt: #disabledGlobalFlapIDs put: disabledFlapIDs. 289482 projectParameters 289483 ifNotNil: [projectParameters 289484 removeKey: #disabledGlobalFlaps 289485 ifAbsent: []]! ! 289486 289487!Project methodsFor: 'flaps support' stamp: 'sw 4/24/2001 11:03'! 289488flapsSuppressed 289489 "Answer whether flaps are suppressed in this project" 289490 289491 ^ self showSharedFlaps not! ! 289492 289493!Project methodsFor: 'flaps support' stamp: 'marcus.denker 11/26/2008 14:14'! 289494flapsSuppressed: aBoolean 289495 "Make the setting of the flag that governs whether global flaps are suppressed in the project be as indicated and add or remove the actual flaps" 289496 289497 self projectPreferenceFlagDictionary at: #showSharedFlaps put: aBoolean not. 289498 self == Project current "Typical case" 289499 ifTrue: 289500 [Preferences setPreference: #showSharedFlaps toValue: aBoolean not] 289501 ifFalse: "Anomalous case where this project is not the current one." 289502 [aBoolean 289503 ifTrue: 289504 [Flaps globalFlapTabsIfAny do: 289505 [:aFlapTab | Flaps removeFlapTab: aFlapTab keepInList: true]] 289506 289507 ifFalse: 289508 [self currentWorld addGlobalFlaps]].! ! 289509 289510!Project methodsFor: 'flaps support' stamp: 'sw 11/6/2000 11:20'! 289511globalFlapEnabledString: aFlapTab 289512 "Answer the string to be shown in a menu to represent the status of the givne flap regarding whether it it should be shown in this project." 289513 289514 ^ (self isFlapEnabled: aFlapTab) 289515 ifTrue: 289516 ['<on>', aFlapTab wording] 289517 ifFalse: 289518 ['<off>', aFlapTab wording]! ! 289519 289520!Project methodsFor: 'flaps support' stamp: 'sw 4/30/2001 20:42'! 289521globalFlapWithIDEnabledString: aFlapID 289522 "Answer the string to be shown in a menu to represent the status of the given flap regarding whether it it should be shown in this project." 289523 289524 | aFlapTab | 289525 aFlapTab := Flaps globalFlapTabWithID: aFlapID. 289526 ^ (self isFlapEnabled: aFlapTab) 289527 ifTrue: 289528 ['<on>', aFlapTab wording] 289529 ifFalse: 289530 ['<off>', aFlapTab wording]! ! 289531 289532!Project methodsFor: 'flaps support' stamp: 'sw 5/5/2001 00:37'! 289533isFlapEnabled: aFlapTab 289534 "Answer whether the given flap tab is enabled in this project" 289535 289536 ^ self isFlapIDEnabled: aFlapTab flapID! ! 289537 289538!Project methodsFor: 'flaps support' stamp: 'sw 4/17/2001 12:49'! 289539isFlapIDEnabled: aFlapID 289540 "Answer whether a flap of the given ID is enabled in this project" 289541 289542 | disabledFlapIDs | 289543 disabledFlapIDs := self parameterAt: #disabledGlobalFlapIDs ifAbsent: [^ true]. 289544 ^ (disabledFlapIDs includes: aFlapID) not! ! 289545 289546!Project methodsFor: 'flaps support' stamp: 'sw 4/24/2001 11:02'! 289547showSharedFlaps 289548 "Answer whether shared flaps are shown or suppressed in this project" 289549 289550 | result | 289551 result := Preferences showSharedFlaps. 289552 ^ self == Project current 289553 ifTrue: 289554 [result] 289555 ifFalse: 289556 [self projectPreferenceAt: #showSharedFlaps ifAbsent: [result]]! ! 289557 289558!Project methodsFor: 'flaps support' stamp: 'stephaneducasse 11/5/2005 20:57'! 289559suppressFlapsString 289560 ^ (self flapsSuppressed 289561 ifTrue: ['<no>'] 289562 ifFalse: ['<yes>']), 'show shared tabs (F)' translated! ! 289563 289564!Project methodsFor: 'flaps support' stamp: 'stephaneducasse 11/5/2005 20:58'! 289565toggleFlapsSuppressed 289566 "Project toggleFlapsSuppressed" 289567 289568 ^self flapsSuppressed: self flapsSuppressed not.! ! 289569 289570 289571!Project methodsFor: 'initialization' stamp: 'dgd 9/5/2004 16:27'! 289572backgroundColorForMorphicProject 289573 ^ Preferences defaultWorldColor! ! 289574 289575!Project methodsFor: 'initialization' stamp: 'alain.plantec 6/1/2008 19:14'! 289576defaultBackgroundColor 289577 ^ self backgroundColorForMorphicProject! ! 289578 289579!Project methodsFor: 'initialization' stamp: 'marcus.denker 11/19/2008 14:48'! 289580initMorphic 289581 "Written so that Morphic can still be removed. Note that #initialize is never actually called for a morphic project -- see the senders of this method." 289582 289583 changeSet := ChangeSet new. 289584 transcript := TranscriptStream new. 289585 displayDepth := Display depth. 289586 parentProject := CurrentProject. 289587 isolatedHead := false. 289588 world := PasteUpMorph newWorldForProject: self. 289589 Locale switchToID: CurrentProject localeID. 289590 self initializeProjectPreferences. "Do this *after* a world is installed so that the project will be recognized as a morphic one."! ! 289591 289592!Project methodsFor: 'initialization'! 289593initialExtent 289594 ^ (Display extent // 6) + (0@17)! ! 289595 289596!Project methodsFor: 'initialization' stamp: 'di 4/14/1999 13:55'! 289597initialProject 289598 self saveState. 289599 parentProject := self. 289600 previousProject := nextProject := nil! ! 289601 289602!Project methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:15'! 289603initialize 289604 "Initialize the project, seting the CurrentProject as my parentProject and initializing my project preferences from those of the CurrentProject" 289605 289606 super initialize. 289607 changeSet := ChangeSet new. 289608 transcript := TranscriptStream new. 289609 displayDepth := Display depth. 289610 parentProject := CurrentProject. 289611 isolatedHead := false. 289612 self initializeProjectPreferences 289613! ! 289614 289615!Project methodsFor: 'initialization' stamp: 'ar 5/16/2001 17:08'! 289616installNewDisplay: extent depth: depth 289617 "When entering a new project, install a new Display if necessary." 289618 ^Display setExtent: extent depth: depth! ! 289619 289620!Project methodsFor: 'initialization' stamp: 'di 7/19/1999 15:00'! 289621installPasteUpAsWorld: pasteUpMorph 289622 "(ProjectViewMorph newMorphicProjectOn: aPasteUpMorph) openInWorld." 289623 289624 world := pasteUpMorph beWorldForProject: self! ! 289625 289626!Project methodsFor: 'initialization' stamp: 'RAA 6/21/2000 22:59'! 289627setChangeSet: aChangeSet 289628 289629 isolatedHead == true ifTrue: [^ self]. "ChangeSet of an isolated project cannot be changed" 289630 changeSet := aChangeSet 289631! ! 289632 289633!Project methodsFor: 'initialization' stamp: 'alain.plantec 6/10/2008 18:53'! 289634setProjectHolder: aProject 289635 289636 self initialize. 289637! ! 289638 289639!Project methodsFor: 'initialization' stamp: 'RAA 10/13/2000 18:21'! 289640setServer 289641 "Mark me as a new project. See if a server is known, remember it." 289642 289643 self projectParameters at: #exportState put: #nacent. 289644 urlList isEmptyOrNil ifTrue: [urlList := parentProject urlList].! ! 289645 289646!Project methodsFor: 'initialization' stamp: 'di 6/10/1998 13:54'! 289647windowActiveOnFirstClick 289648 289649 ^ true! ! 289650 289651!Project methodsFor: 'initialization' stamp: 'KLC 12/19/2005 14:32'! 289652windowReqNewLabel: newLabel 289653 newLabel isEmpty ifTrue: [^ false]. 289654 newLabel = changeSet name ifTrue: [^ true]. 289655 (ChangeSet named: newLabel) == nil 289656 ifFalse: [self inform: 'Sorry that name is already used'. 289657 ^ false]. 289658 changeSet name: newLabel. 289659 ^ true! ! 289660 289661 289662!Project methodsFor: 'isolation layers' stamp: 'md 2/24/2006 15:41'! 289663beIsolated 289664 "Establish an isolation layer at this project. 289665 This requires clearing the current changeSet or installing a new one." 289666 289667 isolatedHead ifTrue: [^ self error: 'Already isolated']. 289668 self isCurrentProject ifFalse: 289669 [^ self inform: 'Must be in this project to isolate it'.]. 289670 changeSet isEmpty ifFalse: [changeSet := ChangeSet newChangeSet]. 289671 changeSet beIsolationSetFor: self. 289672 isolatedHead := true. 289673 inForce := true.! ! 289674 289675!Project methodsFor: 'isolation layers' stamp: 'di 4/1/2000 09:22'! 289676compileAll: newClass from: oldClass 289677 "Make sure that shadowed methods in isolation layers get recompiled. 289678 Traversal is done elsewhere. This simply handles the current project." 289679 289680 isolatedHead == true ifFalse: [^ self]. "only isolated projects need to act on this." 289681 289682 changeSet compileAll: newClass from: oldClass! ! 289683 289684!Project methodsFor: 'isolation layers' stamp: 'RAA 9/27/2000 18:53'! 289685compileAllIsolated: newClass from: oldClass 289686 "Whenever a recompile is needed in a class, look in other isolated projects for saved methods and recompile them also. 289687 At the time this method is called, the recompilation has already been done for the project now in force." 289688 289689 Project allProjects do: [:proj | proj compileAll: newClass from: oldClass]. 289690 289691! ! 289692 289693!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 16:04'! 289694invoke 289695 "Install all methods changed here into method dictionaries. 289696 Make my versions be the ones that will be called." 289697 289698 isolatedHead ifFalse: [^ self error: 'This isnt an isolation layer.']. 289699 inForce ifTrue: [^ self error: 'This layer is already in force.']. 289700 changeSet invoke. 289701 inForce := true.! ! 289702 289703!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 15:49'! 289704invokeFrom: otherProject 289705 "Revoke the changes in force for this project, and then invoke those in force for otherProject. This method shortens the process to the shortest path up then down through the isolation layers." 289706 289707 | pathUp pathDown | 289708 pathUp := otherProject layersToTop. "Full paths to top" 289709 pathDown := self layersToTop. 289710 289711 "Shorten paths to nearest common ancestor" 289712 [pathUp isEmpty not 289713 and: [pathDown isEmpty not 289714 and: [pathUp last == pathDown last]]] 289715 whileTrue: [pathUp removeLast. pathDown removeLast]. 289716 289717 "Now revoke changes up from otherProject and invoke down to self." 289718 pathUp do: [:p | p revoke]. 289719 pathDown reverseDo: [:p | p invoke]. 289720! ! 289721 289722!Project methodsFor: 'isolation layers' stamp: 'RAA 6/21/2000 23:01'! 289723isIsolated 289724 289725 ^ isolatedHead ifNil: [isolatedHead := false]! ! 289726 289727!Project methodsFor: 'isolation layers' stamp: 'di 4/4/2000 21:10'! 289728isolationHead 289729 "Go up the parent chain and find the nearest isolated project." 289730 289731 isolatedHead == true ifTrue: [^ self]. 289732 self isTopProject ifTrue: [^ nil]. 289733 ^ parentProject isolationHead! ! 289734 289735!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 17:00'! 289736isolationSet 289737 289738 "Return the changeSet for this isolation layer or nil" 289739 isolatedHead == true ifTrue: [^ changeSet]. 289740 self isTopProject ifTrue: [^ nil]. "At the top, but not isolated" 289741 ^ parentProject isolationSet 289742 289743! ! 289744 289745!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 15:40'! 289746layersToTop 289747 "Return an OrderedCollection of all the projects that are isolation layers from this one up to the top of the project hierarchy, inclusive." 289748 289749 | layers | 289750 self isTopProject 289751 ifTrue: [layers := OrderedCollection new] 289752 ifFalse: [layers := parentProject layersToTop]. 289753 isolatedHead ifTrue: [layers addFirst: self]. 289754 ^ layers 289755! ! 289756 289757!Project methodsFor: 'isolation layers' stamp: 'di 4/14/2000 09:01'! 289758propagateChanges 289759 "Assert these changes in the next higher isolation layer of the system." 289760 289761 isolatedHead ifFalse: [self error: 'You can only assert changes from isolated projects']. 289762 self halt: 'Not Yet Implemented'. 289763 289764"This will be done by installing a new changeSet for this project (initted for isolation). With the old changeSet no longer in place, no revert will happen when we leave, and those changes will have effectively propagated up a level. NOTE: for this to work in general, the changes here must be assimilated into the isolationSet for the next layer."! ! 289765 289766!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 16:06'! 289767revoke 289768 "Take back all methods changed here. 289769 Install the original method dictionaries and organizations. 289770 The orignal method versions will now be the ones used." 289771 289772 isolatedHead ifFalse: [^ self error: 'This isnt an isolation layer.']. 289773 inForce ifFalse: [^ self error: 'This layer should have been in force.']. 289774 changeSet revoke. 289775 inForce := false. 289776! ! 289777 289778 289779!Project methodsFor: 'language' stamp: 'marcus.denker 11/19/2008 13:43'! 289780chooseNaturalLanguage 289781 "Put up a menu allowing the user to choose the natural language for the project" 289782 289783 | aMenu availableLanguages | 289784 aMenu := MenuMorph new defaultTarget: self. 289785 aMenu addTitle: 'choose language' translated. 289786 aMenu lastItem setBalloonText: 'This controls the human language in which tiles should be viewed. It is potentially extensible to be a true localization mechanism, but initially it only works in the classic tile scripting system. Each project has its own private language choice' translated. 289787 aMenu addStayUpItem. 289788 289789 availableLanguages := NaturalLanguageTranslator availableLanguageLocaleIDs asSortedCollection:[:x :y | x displayName < y displayName]. 289790 289791 availableLanguages do: [:localeID | 289792 aMenu addUpdating: #stringForLanguageNameIs: target: Locale selector: #switchAndInstallFontToID: argumentList: {localeID}]. 289793 aMenu popUpInWorld 289794 289795"Project current chooseNaturalLanguage"! ! 289796 289797!Project methodsFor: 'language' stamp: 'tak 8/4/2005 16:30'! 289798localeChanged 289799 "Set the project's natural language as indicated" 289800 self projectParameterAt: #localeID put: LocaleID current. 289801 self updateLocaleDependents! ! 289802 289803!Project methodsFor: 'language' stamp: 'mir 9/1/2005 00:37'! 289804localeID 289805 "Answer the natural language for the project" 289806 289807 | prev | 289808 ^ self projectParameterAt: #localeID 289809 ifAbsentPut: [ 289810 (prev := self previousProject) 289811 ifNotNil: [prev projectParameterAt: #localeID ifAbsent: [LocaleID current]] 289812 ifNil: [LocaleID current]]! ! 289813 289814!Project methodsFor: 'language' stamp: 'dgd 10/7/2004 20:51'! 289815naturalLanguage 289816 "Answer the natural language for the project" 289817 ^ self localeID displayName! ! 289818 289819!Project methodsFor: 'language' stamp: 'adrian_lienhard 7/19/2009 22:27'! 289820setFlaps 289821 289822 | flapTabs flapIDs sharedFlapTabs | 289823 flapTabs := ActiveWorld flapTabs. 289824 flapIDs := flapTabs collect: [:tab | tab knownName]. 289825 flapTabs 289826 do: [:tab | tab isGlobalFlap 289827 ifTrue: [Flaps removeFlapTab: tab keepInList: false. 289828 tab currentWorld reformulateUpdatingMenus] 289829 ifFalse: [| referent | 289830 referent := tab referent. 289831 referent isInWorld 289832 ifTrue: [referent delete]. 289833 tab delete]]. 289834 sharedFlapTabs := Flaps classPool at: #SharedFlapTabs. 289835 flapIDs 289836 do: [:id | 289837 id = 'Squeak' translated 289838 ifTrue: [sharedFlapTabs add: Flaps newSqueakFlap]]. 289839 2 timesRepeat: [flapIDs do: [:id | Flaps enableDisableGlobalFlapWithID: id]]. 289840 ActiveWorld flapTabs 289841 do: [:flapTab | flapTab isCurrentlyTextual 289842 ifTrue: [flapTab changeTabText: flapTab knownName]]. 289843 Flaps positionNavigatorAndOtherFlapsAccordingToPreference. 289844 ! ! 289845 289846!Project methodsFor: 'language' stamp: 'yo 8/11/2003 16:46'! 289847setPaletteFor: aLanguageSymbol 289848 | prototype formKey form | 289849 prototype := PaintBoxMorph prototype. 289850 formKey := ('offPalette' , aLanguageSymbol) asSymbol. 289851 form := Imports default imports 289852 at: formKey 289853 ifAbsent: [Imports default imports 289854 at: #offPaletteEnglish 289855 ifAbsent: []]. 289856 form isNil ifFalse: [prototype loadOffForm: form]. 289857 formKey := ('pressedPalette' , aLanguageSymbol) asSymbol. 289858 form := Imports default imports 289859 at: formKey 289860 ifAbsent: [Imports default imports 289861 at: #pressedPaletteEnglish 289862 ifAbsent: []]. 289863 form isNil ifFalse: [prototype loadPressedForm: form]. 289864! ! 289865 289866!Project methodsFor: 'language' stamp: 'stephane.ducasse 4/14/2009 11:38'! 289867updateLocaleDependents 289868 "Set the project's natural language as indicated" 289869 289870"Probably, the whole method can be removed in the process of the EToys removal. For now comment this part out since rebuilding flaps does not work anymore." 289871 289872" ActiveWorld allTileScriptingElements do: [:viewerOrScriptor | 289873 viewerOrScriptor localeChanged]. 289874 289875 Flaps disableGlobalFlaps: false. 289876 Flaps enableGlobalFlaps. 289877 289878 (Project current isFlapIDEnabled: 'Navigator' translated) 289879 ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated]. 289880" 289881 MenuIcons initializeTranslations. 289882 289883 LanguageEnvironment localeChanged. 289884! ! 289885 289886 289887!Project methodsFor: 'menu messages' stamp: 'stephane.ducasse 1/30/2009 22:34'! 289888displayFontProgress 289889 "Display progress for fonts" 289890 ^ self 289891 ! ! 289892 289893!Project methodsFor: 'menu messages' stamp: 'RAA 5/16/2001 17:50'! 289894doWeWantToRename 289895 289896 | want | 289897 289898 self hasBadNameForStoring ifTrue: [^true]. 289899 (self name beginsWith: 'Unnamed') ifTrue: [^true]. 289900 want := world valueOfProperty: #SuperSwikiRename ifAbsent: [false]. 289901 world removeProperty: #SuperSwikiRename. 289902 ^want 289903 289904! ! 289905 289906!Project methodsFor: 'menu messages' stamp: 'tk 10/26/1999 14:25'! 289907enter 289908 "Enter the new project" 289909 self enter: (CurrentProject parent == self) revert: false saveForRevert: false.! ! 289910 289911!Project methodsFor: 'menu messages' stamp: 'pavel.krivanek 3/12/2009 09:04'! 289912enterAsActiveSubprojectWithin: enclosingWorld 289913 289914 "Install my ChangeSet, Transcript, and scheduled views as current globals. 289915 289916 If returningFlag is true, we will return to the project from whence the current project was entered; don't change its previousProject link in this case. 289917 If saveForRevert is true, save the ImageSegment of the project being left. 289918 If revertFlag is true, make stubs for the world of the project being left. 289919 If revertWithoutAsking is true in the project being left, then always revert." 289920 289921 "Experimental mods for initial multi-project work: 289922 1. assume in morphic (this eliminated need for <showZoom>) 289923 2. assume <saveForRevert> is false (usual case) - removed <old> 289924 3. assume <revertFlag> is false 289925 4. assume <revertWithoutAsking> is false - <forceRevert> now auto false <seg> n.u. 289926 5. no zooming 289927 6. assume <projectsSentToDisk> false - could be dangerous here 289928 7. assume no isolation problems (isolationHead ==) 289929 8. no closing scripts 289930 " 289931 289932 self isCurrentProject ifTrue: [^ self]. 289933 289934 "CurrentProject makeThumbnail." 289935 "--> Display bestGuessOfCurrentWorld triggerClosingScripts." 289936 CurrentProject displayDepth: Display depth. 289937 289938 displayDepth == nil ifTrue: [displayDepth := Display depth]. 289939 "Display newDepthNoRestore: displayDepth." 289940 289941 "(world hasProperty: #letTheMusicPlay) 289942 ifTrue: [world removeProperty: #letTheMusicPlay] 289943 ifFalse: [Smalltalk at: #ScorePlayer ifPresent: [:playerClass | 289944 playerClass allSubInstancesDo: [:player | player pause]]]." 289945 289946 "returningFlag 289947 ifTrue: [nextProject := CurrentProject] 289948 ifFalse: [previousProject := CurrentProject]." 289949 289950 "CurrentProject saveState." 289951 "CurrentProject := self." 289952 "Smalltalk newChanges: changeSet." 289953 "TranscriptStream newTranscript: transcript." 289954 "Sensor flushKeyboard." 289955 "recorderOrNil := Display pauseMorphicEventRecorder." 289956 289957 "Display changeMorphicWorldTo: world." "Signifies Morphic" 289958 "world 289959 installAsActiveSubprojectIn: enclosingWorld 289960 titled: self name. to remove alignmentBob1Morph shit" 289961 289962 "recorderOrNil ifNotNil: [recorderOrNil resumeIn: world]." 289963 289964 self removeParameter: #exportState. 289965 "self spawnNewProcessAndTerminateOld: true"! ! 289966 289967!Project methodsFor: 'menu messages' stamp: 'sw 11/10/1999 10:29'! 289968enter: returningFlag 289969 self enter: returningFlag revert: false saveForRevert: false! ! 289970 289971!Project methodsFor: 'menu messages' stamp: 'marcus.denker 6/11/2009 17:15'! 289972enter: returningFlag revert: revertFlag saveForRevert: saveForRevert 289973 "Install my ChangeSet, Transcript, and scheduled views as current 289974 globals. If returningFlag is true, we will return to the project from 289975 whence the current project was entered; don't change its 289976 previousProject link in this case. 289977 If saveForRevert is true, save the ImageSegment of the project being 289978 left. If revertFlag is true, make stubs for the world of the project being 289979 left. If revertWithoutAsking is true in the project being left, then 289980 always revert." 289981 | recorderOrNil old forceRevert response seg | 289982 (world isKindOf: StringMorph) 289983 ifTrue: [self inform: 'This project is not all here. I will try to load a complete version.' translated. 289984 ^ true]. 289985 self isCurrentProject 289986 ifTrue: [^ self]. 289987 CurrentProject world triggerEvent: #aboutToLeaveWorld. 289988 forceRevert := false. 289989 CurrentProject rawParameters 289990 ifNil: [revertFlag 289991 ifTrue: [^ self inform: 'nothing to revert to' translated]] 289992 ifNotNil: [saveForRevert 289993 ifFalse: [forceRevert := CurrentProject projectParameters 289994 at: #revertWithoutAsking 289995 ifAbsent: [false]]]. 289996 forceRevert not & revertFlag 289997 ifTrue: [response := self 289998 confirm: 'Are you sure you want to destroy this Project\ and revert to an older version?\\(From the parent project, click on this project''s thumbnail.)' translated withCRs. 289999 response 290000 ifFalse: [^ self]]. 290001 revertFlag | forceRevert 290002 ifTrue: [seg := CurrentProject projectParameters 290003 at: #revertToMe 290004 ifAbsent: [^ self inform: 'nothing to revert to' translated]] 290005 ifFalse: [ 290006 CurrentProject makeThumbnail. 290007 returningFlag == #specialReturn 290008 ifTrue: [ 290009 "this guy is irrelevant" 290010 Project forget: CurrentProject] 290011 ifFalse: []]. 290012 revertFlag | saveForRevert | forceRevert 290013 ifFalse: [(Preferences valueOfFlag: #projectsSentToDisk) 290014 ifTrue: [self storeToMakeRoom]]. 290015 CurrentProject abortResourceLoading. 290016 CurrentProject saveProjectPreferences. 290017 "Update the display depth and make a thumbnail of the current project" 290018 CurrentProject displayDepth: Display depth. 290019 old := CurrentProject. 290020 "for later" 290021 "Show the project transition. 290022 Note: The project zoom is run in the context of the old project, 290023 so that eventual errors can be handled accordingly" 290024 displayDepth == nil 290025 ifTrue: [displayDepth := Display depth]. 290026 self installNewDisplay: Display extent depth: displayDepth. 290027 (self showZoom) 290028 ifTrue: [self displayZoom: CurrentProject parent ~~ self]. 290029 (world isMorph 290030 and: [world hasProperty: #letTheMusicPlay]) 290031 ifTrue: [world removeProperty: #letTheMusicPlay] 290032 ifFalse: [Smalltalk 290033 at: #ScorePlayer 290034 ifPresentAndInMemory: [:playerClass | playerClass 290035 allSubInstancesDo: [:player | player pause]]]. 290036 returningFlag == #specialReturn 290037 ifTrue: [old removeChangeSetIfPossible. 290038 "keep this stuff from accumulating" 290039 nextProject := nil] 290040 ifFalse: [returningFlag 290041 ifTrue: [nextProject := CurrentProject] 290042 ifFalse: [previousProject := CurrentProject]]. 290043 CurrentProject saveState. 290044 CurrentProject isolationHead == self isolationHead 290045 ifFalse: [self invokeFrom: CurrentProject]. 290046 CurrentProject := self. 290047 self installProjectPreferences. 290048 ChangeSet newChanges: changeSet. 290049 TranscriptStream newTranscript: transcript. 290050 Sensor flushKeyboard. 290051 recorderOrNil := World pauseEventRecorder. 290052 World := world. 290053 "Signifies Morphic" 290054 world install. 290055 290056 "(revertFlag | saveForRevert | forceRevert) ifFalse: [ 290057 (Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [ 290058 self storeSomeSegment]]." 290059 recorderOrNil 290060 ifNotNil: [recorderOrNil resumeIn: world]. 290061 290062 saveForRevert 290063 ifTrue: [Smalltalk garbageCollect. 290064 "let go of pointers" 290065 old storeSegment. 290066 "result :=" 290067 old world isInMemory 290068 ifTrue: ['Can''t seem to write the project.'] 290069 ifFalse: [old projectParameters at: #revertToMe put: old world xxxSegment clone]. 290070 'Project written.']. 290071 "original is for coming back in and continuing." 290072 revertFlag | forceRevert 290073 ifTrue: [seg clone revert]. 290074 "non-cloned one is for reverting again later" 290075 self removeParameter: #exportState. 290076 "Complete the enter: by launching a new process" 290077 world triggerEvent: #aboutToEnterWorld. 290078 Project spawnNewProcessAndTerminateOld: true! ! 290079 290080!Project methodsFor: 'menu messages' stamp: 'stephane.ducasse 11/27/2008 22:35'! 290081enterForEmergencyRecovery 290082 "This version of enter invokes an absolute minimum of mechanism. 290083 An unrecoverable error has been detected in an isolated project. 290084 It is assumed that the old changeSet has already been revoked. 290085 No new process gets spawned here. This will happen in the debugger." 290086 self isCurrentProject 290087 ifTrue: [^ self]. 290088 CurrentProject saveState. 290089 CurrentProject := self. 290090 Display newDepthNoRestore: displayDepth. 290091 ChangeSet newChanges: changeSet. 290092 TranscriptStream newTranscript: transcript. 290093 World pauseEventRecorder. 290094 "Entering a Morphic project" 290095 World := world. 290096 world install. 290097 UIProcess := Processor activeProcess! ! 290098 290099!Project methodsFor: 'menu messages' stamp: 'yo 7/2/2004 19:46'! 290100exit 290101 "Leave the current project and return to the project in which this one was created." 290102 290103 self isTopProject ifTrue: [^ self inform: 'Can''t exit the top project' translated]. 290104 parentProject enter: false revert: false saveForRevert: false. 290105! ! 290106 290107!Project methodsFor: 'menu messages'! 290108fileOut 290109 changeSet fileOut! ! 290110 290111!Project methodsFor: 'menu messages' stamp: 'marcus.denker 12/3/2008 16:07'! 290112finalExitActions! ! 290113 290114!Project methodsFor: 'menu messages' stamp: 'sw 4/19/2001 12:58'! 290115installProjectPreferences 290116 "Install the settings of all preferences presently held individually by projects in the receiver's projectPreferenceFlagDictionary" 290117 290118 | localValue | 290119 Preferences allPreferenceObjects do: 290120 [:aPreference | 290121 aPreference localToProject ifTrue: 290122 [localValue := self projectPreferenceFlagDictionary at: aPreference name ifAbsent: [nil]. 290123 localValue ifNotNil: 290124 [aPreference rawValue: localValue]]]! ! 290125 290126!Project methodsFor: 'menu messages' stamp: 'marcus.denker 12/3/2008 16:05'! 290127makeThumbnail 290128 "Make a thumbnail image of this project from the Display." 290129 290130 world isMorph ifTrue: [world displayWorldSafely]. "clean pending damage" 290131 viewSize ifNil: [viewSize := Display extent // 8]. 290132 thumbnail := Form extent: viewSize depth: Display depth. 290133 (WarpBlt current toForm: thumbnail) 290134 sourceForm: Display; 290135 cellSize: 2; "installs a colormap" 290136 combinationRule: Form over; 290137 copyQuad: (Display boundingBox) innerCorners 290138 toRect: (0@0 extent: viewSize). 290139 ^thumbnail 290140! ! 290141 290142!Project methodsFor: 'menu messages' stamp: 'dgd 8/31/2003 19:37'! 290143navigatorFlapVisible 290144 "Answer whether a Navigator flap is visible" 290145 290146 ^ (Flaps sharedFlapsAllowed and: 290147 [self flapsSuppressed not]) and: 290148 [self isFlapIDEnabled: 'Navigator' translated]! ! 290149 290150!Project methodsFor: 'menu messages' stamp: 'sw 4/12/2001 22:29'! 290151saveProjectPreferences 290152 "Preserve the settings of all preferences presently held individually by projects in the receiver's projectPreferenceFlagDictionary" 290153 290154 Preferences allPreferenceObjects do: 290155 [:aPreference | 290156 aPreference localToProject ifTrue: 290157 [projectPreferenceFlagDictionary at: aPreference name put: aPreference preferenceValue]]! ! 290158 290159!Project methodsFor: 'menu messages' stamp: 'stephane.ducasse 5/1/2009 22:10'! 290160saveState 290161 "Save the current state in me prior to leaving this project" 290162 290163 changeSet := ChangeSet current. 290164 thumbnail ifNotNil: [thumbnail hibernate]. 290165 world := World. 290166 ActiveWorld := ActiveHand := ActiveEvent := nil. 290167 Sensor flushAllButDandDEvents. "Will be reinstalled by World>>install" 290168 transcript := Transcript. 290169! ! 290170 290171!Project methodsFor: 'menu messages' stamp: 'alain.plantec 6/19/2008 09:11'! 290172viewLocFor: exitedProject 290173 "Look for a view of the exitedProject, and return its center" 290174 world 290175 submorphsDo: [:v | (v isSystemWindow 290176 and: [v model == exitedProject]) 290177 ifTrue: [^ v center]]. 290178 ^ Sensor cursorPoint"default result"! ! 290179 290180 290181!Project methodsFor: 'obsolete' stamp: 'RAA 6/3/2000 19:01'! 290182obsolete 290183 290184 self flag: #obsolete. 290185 "instance variable 290186 exitFlag is no longer used 290187 activeProcess is on the way out 290188 "! ! 290189 290190 290191!Project methodsFor: 'printing' stamp: 'jm 5/21/1998 07:40'! 290192printOn: aStream 290193 290194 aStream nextPutAll: 'a Project(', self name, ')'. 290195! ! 290196 290197 290198!Project methodsFor: 'project parameters' stamp: 'sw 4/24/2001 11:58'! 290199initializeProjectParameters 290200 "Initialize the project parameters." 290201 290202 projectParameters := IdentityDictionary new. 290203 ^ projectParameters! ! 290204 290205!Project methodsFor: 'project parameters' stamp: 'marcus.denker 11/10/2008 10:04'! 290206initializeProjectPreferences 290207 "Initialize the project's preferences from currently-prevailing preferences that are currently being held in projects in this system" 290208 290209 projectPreferenceFlagDictionary := Project current projectPreferenceFlagDictionary deepCopy. "Project overrides in the new project start out being the same set of overrides in the calling project" 290210 290211 Preferences allPreferenceObjects do: "in case we missed some" 290212 [:aPreference | 290213 aPreference localToProject ifTrue: 290214 [(projectPreferenceFlagDictionary includesKey: aPreference name) ifFalse: 290215 [projectPreferenceFlagDictionary at: aPreference name put: aPreference preferenceValue]]]. 290216 290217 self flapsSuppressed: true. 290218 (Project current projectParameterAt: #disabledGlobalFlapIDs ifAbsent: [nil]) ifNotNil: 290219 [:idList | self projectParameterAt: #disabledGlobalFlapIDs put: idList copy] 290220! ! 290221 290222!Project methodsFor: 'project parameters' stamp: 'sw 2/16/2001 22:35'! 290223noteThatParameter: prefSymbol justChangedTo: aBoolean 290224 "Provides a hook so that a user's toggling of a project parameter might precipitate some immediate action" 290225 290226! ! 290227 290228!Project methodsFor: 'project parameters' stamp: 'ar 5/25/2000 23:23'! 290229parameterAt: aSymbol 290230 ^self parameterAt: aSymbol ifAbsent:[nil]! ! 290231 290232!Project methodsFor: 'project parameters' stamp: 'ar 5/25/2000 23:23'! 290233parameterAt: aSymbol ifAbsent: aBlock 290234 projectParameters ifNil:[^aBlock value]. 290235 ^projectParameters at: aSymbol ifAbsent: aBlock! ! 290236 290237!Project methodsFor: 'project parameters' stamp: 'sw 10/30/2000 11:14'! 290238projectParameterAt: aSymbol 290239 "Answer the project parameter stored at the given symbol, or nil if none" 290240 290241 ^ self projectParameters at: aSymbol ifAbsent: [nil]! ! 290242 290243!Project methodsFor: 'project parameters' stamp: 'sw 2/15/2001 14:32'! 290244projectParameterAt: aSymbol ifAbsent: aBlock 290245 "Answer the project parameter stored at the given symbol, or the result of evaluating the block" 290246 290247 ^ self projectParameters at: aSymbol ifAbsent: [aBlock value]! ! 290248 290249!Project methodsFor: 'project parameters' stamp: 'sw 9/28/2001 08:49'! 290250projectParameterAt: aKey ifAbsentPut: defaultValueBlock 290251 "Return the project parameter setting at the given key. If there is no entry for this key in the Parameters dictionary, create one with the value of defaultValueBlock as its value" 290252 290253 ^ self projectParameters at: aKey ifAbsentPut: defaultValueBlock! ! 290254 290255!Project methodsFor: 'project parameters' stamp: 'sw 2/17/2001 21:36'! 290256projectParameterAt: aSymbol put: aValue 290257 "Set the given project parameter to the given value" 290258 290259 self projectParameters at: aSymbol put: aValue. 290260 self noteThatParameter: aSymbol justChangedTo: aValue. 290261 ^ aValue! ! 290262 290263!Project methodsFor: 'project parameters' stamp: 'sw 4/22/1999 15:14'! 290264projectParameters 290265 ^ projectParameters ifNil: [self initializeProjectParameters]! ! 290266 290267!Project methodsFor: 'project parameters' stamp: 'sw 4/12/2001 23:36'! 290268projectPreferenceAt: aSymbol 290269 "Answer the project preference stored at the given symbol. If there is none in the local preference dictionary, it must be because it was only latterly declared to be a project-local preference, so obtain its initial value instead from the last-known global or default setting" 290270 290271 | aValue | 290272 ^ self projectPreferenceAt: aSymbol ifAbsent: 290273 [aValue := Preferences valueOfFlag: aSymbol. 290274 self projectPreferenceFlagDictionary at: aSymbol put: aValue. 290275 ^ aValue]! ! 290276 290277!Project methodsFor: 'project parameters' stamp: 'sw 2/16/2001 22:25'! 290278projectPreferenceAt: aSymbol ifAbsent: aBlock 290279 "Answer the project preference stored at the given symbol, or the result of evaluating the block" 290280 290281 ^ self projectPreferenceFlagDictionary at: aSymbol ifAbsent: [aBlock value]! ! 290282 290283!Project methodsFor: 'project parameters' stamp: 'sw 2/16/2001 22:23'! 290284projectPreferenceFlagDictionary 290285 "Answer the dictionary that holds the project preferences, creating it if necessary" 290286 290287 ^ projectPreferenceFlagDictionary ifNil: [projectPreferenceFlagDictionary := IdentityDictionary new]! ! 290288 290289!Project methodsFor: 'project parameters' stamp: 'tk 10/26/1999 13:55'! 290290rawParameters 290291 ^ projectParameters! ! 290292 290293!Project methodsFor: 'project parameters' stamp: 'ar 6/2/1999 05:29'! 290294removeParameter: aKey 290295 projectParameters ifNil:[^self]. 290296 projectParameters removeKey: aKey ifAbsent:[].! ! 290297 290298 290299!Project methodsFor: 'release' stamp: 'di 9/28/1999 23:46'! 290300addDependent: aMorph 290301 290302 "Projects do not keep track of their dependents, lest they point into other projects and thus foul up the tree structure for image segmentation." 290303 290304 ^ self "Ignore this request"! ! 290305 290306!Project methodsFor: 'release' stamp: 'sw 7/6/1998 11:16'! 290307canDiscardEdits 290308 "Don't regard a window of mine as one to be discarded as part of a 'closeUnchangedWindows' sweep" 290309 290310 ^ false! ! 290311 290312!Project methodsFor: 'release' stamp: 'RAA 5/10/2001 12:58'! 290313deletingProject: aProject 290314 "Clear my previousProject link if it points at the given Project, which is being deleted." 290315 290316 self flag: #bob. "zapping projects" 290317 290318 parentProject == aProject ifTrue: [ 290319 parentProject := parentProject parent 290320 ]. 290321 previousProject == aProject 290322 ifTrue: [previousProject := nil]. 290323 nextProject == aProject 290324 ifTrue: [nextProject := nil] 290325! ! 290326 290327!Project methodsFor: 'release' stamp: 'RAA 6/7/2000 09:24'! 290328release 290329 290330 self flag: #bob. "this can be trouble if Projects are reused before garbage collection" 290331 world == nil ifFalse: 290332 [world release. 290333 world := nil]. 290334 ^ super release! ! 290335 290336!Project methodsFor: 'release' stamp: 'alain.plantec 6/1/2008 19:49'! 290337subProjects 290338 "Answer a list of all the subprojects of the receiver. This is nastily 290339 idiosyncratic. " 290340 ^ world submorphs 290341 select: [:m | m isSystemWindow 290342 and: [m model isKindOf: Project]] 290343 thenCollect: [:m | m model]! ! 290344 290345 290346!Project methodsFor: 'resources' stamp: 'ar 3/2/2001 17:25'! 290347abortResourceLoading 290348 "Abort loading resources" 290349 resourceManager ifNil:[^self]. 290350 resourceManager stopDownload.! ! 290351 290352!Project methodsFor: 'resources' stamp: 'mir 6/21/2001 15:43'! 290353resourceDirectoryName 290354 "Project current resourceDirectoryName" 290355 ^String streamContents:[:s| 290356 s nextPutAll: self name. 290357 s nextPutAll: FileDirectory dot. 290358 s nextPutAll: self versionForFileName. 290359 ] 290360! ! 290361 290362!Project methodsFor: 'resources' stamp: 'ar 2/27/2001 17:02'! 290363resourceManager 290364 ^resourceManager ifNil:[resourceManager := ResourceManager new]! ! 290365 290366!Project methodsFor: 'resources' stamp: 'ar 2/27/2001 15:49'! 290367resourceManager: aResourceManager 290368 resourceManager := aResourceManager! ! 290369 290370!Project methodsFor: 'resources' stamp: 'mir 6/26/2001 17:34'! 290371resourceUrl 290372 "compose my base url for resources on the server" 290373 | firstURL | 290374" 290375 primaryServer := self primaryServerIfNil: [^'']. 290376 firstURL := primaryServer altUrl ifNil: [primaryServer url]." 290377 firstURL := self downloadUrl. 290378 firstURL isEmpty 290379 ifFalse: [firstURL last == $/ ifFalse: [firstURL := firstURL, '/']]. 290380 ^ firstURL, self resourceDirectoryName , '/' 290381! ! 290382 290383!Project methodsFor: 'resources' stamp: 'mir 6/18/2001 16:19'! 290384startResourceLoading 290385 "Abort loading resources" 290386 resourceManager ifNil:[^self]. 290387 resourceManager adjustToDownloadUrl: self resourceUrl. 290388 resourceManager startDownload! ! 290389 290390!Project methodsFor: 'resources' stamp: 'ar 3/2/2001 15:16'! 290391storeResourceList: collector in: fd 290392 "Store a list of all used resources in the given directory. Used for maintenance." 290393 | file rcName | 290394 rcName := self resourceDirectoryName,'.rc'. 290395 file := fd forceNewFileNamed: rcName. 290396 collector locatorsDo:[:loc| file nextPutAll: loc urlString; cr]. 290397 file close. 290398 file := fd readOnlyFileNamed: rcName. 290399 file compressFile. 290400 fd deleteFileNamed: rcName ifAbsent:[].! ! 290401 290402 290403!Project methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 08:07'! 290404isMorphic 290405 "Complexity is because #isMVC is lazily installed" 290406 self deprecated: 'MVC has been removed.'. 290407 ^ world isInMemory 290408 ifTrue: [world isMorph] 290409 ifFalse: [(self projectParameters at: #isMVC ifAbsent: [false]) not]! ! 290410 290411"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 290412 290413Project class 290414 instanceVariableNames: ''! 290415 290416!Project class methodsFor: 'constants'! 290417current 290418 "Answer the project that is currently being used." 290419 290420 ^CurrentProject! ! 290421 290422 290423!Project class methodsFor: 'initialization' stamp: 'RAA 6/3/2000 18:50'! 290424initialize 290425 "This is the Top Project." 290426 290427 CurrentProject ifNil: 290428 [CurrentProject := super new initialProject. 290429 Project spawnNewProcessAndTerminateOld: true]. 290430 290431 "Project initialize"! ! 290432 290433!Project class methodsFor: 'initialization' stamp: 'tak 8/3/2005 18:35'! 290434localeChanged 290435 self current localeChanged! ! 290436 290437!Project class methodsFor: 'initialization' stamp: 'RAA 12/17/2000 12:37'! 290438rebuildAllProjects 290439 "Project rebuildAllProjects" 290440 290441 AllProjects := nil. 290442 self allProjects.! ! 290443 290444 290445!Project class methodsFor: 'instance creation' stamp: 'RAA 11/16/2000 12:07'! 290446new 290447 290448 | new | 290449 290450 new := super new. 290451 new setProjectHolder: CurrentProject. 290452 self addingProject: new. 290453 ^new! ! 290454 290455!Project class methodsFor: 'instance creation' stamp: 'RAA 11/16/2000 12:07'! 290456newMorphic 290457 | new | 290458 "ProjectView open: Project newMorphic" 290459 290460 new := self basicNew. 290461 self addingProject: new. 290462 new initMorphic. 290463 ^new! ! 290464 290465!Project class methodsFor: 'instance creation' stamp: 'RAA 11/16/2000 12:08'! 290466newMorphicOn: aPasteUpOrNil 290467 290468 | newProject | 290469 290470 newProject := self basicNew initMorphic. 290471 self addingProject: newProject. 290472 aPasteUpOrNil ifNotNil: [newProject installPasteUpAsWorld: aPasteUpOrNil]. 290473 newProject createViewIfAppropriate. 290474 ^newProject 290475! ! 290476 290477!Project class methodsFor: 'instance creation' stamp: 'RAA 9/27/2000 13:41'! 290478uiProcess 290479 290480 ^ UIProcess! ! 290481 290482 290483!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 1/28/2001 08:39'! 290484isBadNameForStoring: aString 290485 290486 | badChars | 290487 290488 "will the name of this project cause problems when stored on an arbitrary file system?" 290489 badChars := #( $: $< $> $| $/ $\ $? $* $" $.) asSet. 290490 ^aString size > 24 or: [ 290491 aString anySatisfy: [ :each | 290492 each asciiValue < 32 or: [badChars includes: each] 290493 ] 290494 ] 290495! ! 290496 290497!Project class methodsFor: 'squeaklet on server' stamp: 'mir 8/8/2001 17:57'! 290498loaderUrl 290499 "Return a url that will allow to launch a project in a browser by composing a url like 290500 <loaderURL>?<projectURL>" 290501 290502 ^AbstractLauncher extractParameters at: 'LOADER_URL' ifAbsent: [nil].! ! 290503 290504!Project class methodsFor: 'squeaklet on server' stamp: 'lr 7/4/2009 10:42'! 290505mostRecent: projName onServer: aServerDirectory 290506 "Find the exact fileName of the most recent version of project with the stem name of projName. Names are of the form 'projName|mm.pr' where mm is a mime-encoded integer version number. 290507 File names may or may not be HTTP escaped, %20 on the server." 290508 | stem list max goodName triple num stem1 stem2 rawList nothingFound unEscName | 290509 self flag: #bob. "do we want to handle unversioned projects as well?" 290510 nothingFound := { nil. -1 }. 290511 aServerDirectory ifNil: [ ^ nothingFound ]. 290512 "23 sept 2000 - some old projects have periods in name so be more careful" 290513 unEscName := projName unescapePercents. 290514 triple := Project parseProjectFileName: unEscName. 290515 stem := triple first. 290516 rawList := aServerDirectory fileNames. 290517 rawList isString ifTrue: 290518 [ self inform: 'server is unavailable'. 290519 ^ nothingFound ]. 290520 list := rawList collect: [ :nnn | nnn unescapePercents ]. 290521 max := -1. 290522 goodName := nil. 290523 list withIndexDo: 290524 [ :aName :ind | 290525 (aName beginsWith: stem) ifTrue: 290526 [ num := (Project parseProjectFileName: aName) second. 290527 num > max ifTrue: 290528 [ max := num. 290529 goodName := rawList at: ind ] ] ]. 290530 max = -1 ifFalse: 290531 [ ^ Array 290532 with: goodName 290533 with: max ]. 290534 290535 "try with underbar for spaces on server" 290536 (stem includes: $ ) ifTrue: 290537 [ stem1 := stem 290538 copyReplaceAll: ' ' 290539 with: '_'. 290540 list withIndexDo: 290541 [ :aName :ind | 290542 (aName beginsWith: stem1) ifTrue: 290543 [ num := (Project parseProjectFileName: aName) second. 290544 num > max ifTrue: 290545 [ max := num. 290546 goodName := rawList at: ind ] ] ] ]. 290547 max = -1 ifFalse: 290548 [ ^ Array 290549 with: goodName 290550 with: max ]. 290551 290552 "try without the marker | " 290553 stem1 := stem allButLast , '.pr'. 290554 stem2 := stem1 290555 copyReplaceAll: ' ' 290556 with: '_'. "and with spaces replaced" 290557 list withIndexDo: 290558 [ :aName :ind | 290559 (aName beginsWith: stem1) | (aName beginsWith: stem2) ifTrue: 290560 [ (triple := aName findTokens: '.') size >= 2 ifTrue: 290561 [ max := 0. 290562 goodName := rawList at: ind ] ] ]. "no other versions" 290563 max = -1 ifFalse: 290564 [ ^ Array 290565 with: goodName 290566 with: max ]. 290567 ^ nothingFound "no matches"! ! 290568 290569!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 9/27/2000 14:11'! 290570namedUrl: urlString 290571 | projName | 290572 "Return project if in, else nil" 290573 290574 "Ted's fix for unreachable projects" 290575 290576 projName := (urlString findTokens: '/') last. 290577 projName := (Project parseProjectFileName: projName unescapePercents) first. 290578 ^ Project named: projName 290579! ! 290580 290581!Project class methodsFor: 'squeaklet on server' stamp: 'dao 10/1/2004 13:25'! 290582openBlankProjectNamed: projName 290583 290584 | proj projViewer | 290585 290586 proj := Project newMorphicOn: nil. 290587 proj changeSet name: projName. 290588 proj world addMorph: ( 290589 TextMorph new 290590 beAllFont: ((TextStyle default fontOfSize: 26) emphasized: 1); 290591 color: Color red; 290592 contents: 'Welcome to a new project - ',projName 290593 ). 290594 proj setParent: self current. 290595 projViewer := (CurrentProject findProjectView: projName) ifNil: [^proj]. 290596 (projViewer owner isSystemWindow) ifTrue: [ 290597 projViewer owner model: proj]. 290598 ^ projViewer project: proj! ! 290599 290600!Project class methodsFor: 'squeaklet on server' stamp: 'ar 10/11/2000 15:42'! 290601parseProjectFileName: aString 290602 "It was formerly possible to have periods in projct names and this messed up some parsing methods. Try to handle that more gracefully and allow for a change in scheme at a later time. 290603 ar 10/11/2000: Switch to a different version encoding scheme. The new scheme is 290604 baseName.NNN.ext 290605 where NNN is at least three digits wide and encodes the version in a human readable form. 290606 Examples: 290607 Project parseProjectFileName: 'My Project.007.pr'. 290608 Project parseProjectFileName: 'My.First.Project.042.prj'. 290609 Project parseProjectFileName: 'My Project.123456.p r o j e c t'. 290610 The 'dot' is determined on FileDirectory>>dot to compensate for platforms wishing to use something different from a period. Also allows parsing the former encoding of file using Base64 encoded versions of the form 290611 Project parseProjectFileName: 'aa.bb.cc|AQ.ss' 290612 " 290613 | suffix baseName version versionAndSuffix index tokens | 290614 "answer an array with: 290615 1 = basic project name 290616 2 = version string 290617 3 = suffix (pr)" 290618 290619 "First check for the old style versions" 290620 index := aString findLast:[:ch| ch = $|]. 290621 index = 0 ifFalse:["Old style version" 290622 baseName := aString copyFrom: 1 to: index-1. 290623 versionAndSuffix := aString copyFrom: index+1 to: aString size. 290624 (versionAndSuffix occurrencesOf: $.) = 0 ifTrue: [^ #('no suffix')]. 290625 version := versionAndSuffix copyUpTo: $.. 290626 suffix := versionAndSuffix copyFrom: version size+1 to: versionAndSuffix size. 290627 "Decode Base64 encoded version" 290628 version isEmpty 290629 ifTrue:[version := 0] 290630 ifFalse:[version := Base64MimeConverter decodeInteger: version unescapePercents]. 290631 ^{baseName. version. suffix}]. 290632 "New style versions" 290633 tokens := aString findTokens: FileDirectory dot. 290634 tokens size < 2 "Not even a single dot" 290635 ifTrue:[^{aString. 0. ''}]. 290636 tokens size < 3 ifTrue:["Only one dot" 290637 self flag: #arNote. "We could allow project file names of the form 'project.001' (e.g., no project extension) or '.001.pr' (without a base name) but I don't think its a good idea." 290638 ^{tokens first. 0. tokens last}]. 290639 suffix := tokens last. 290640 version := tokens at: tokens size - 1. 290641 (version anySatisfy:[:ch| ch isDigit not]) ifTrue:[ 290642 "Non-digit version??? I don't think so..." 290643 baseName := aString copyFrom: 1 to: aString size - suffix size - 1. 290644 ^{baseName. 0. suffix}]. 290645 baseName := aString copyFrom: 1 to: aString size - suffix size - version size - 2. 290646 version := version asInteger. 290647 ^{baseName. version. suffix}! ! 290648 290649!Project class methodsFor: 'squeaklet on server' stamp: 'ar 2/27/2001 13:43'! 290650projectExtension 290651 ^'pr'! ! 290652 290653!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 8/8/2000 10:42'! 290654spawnNewProcessIfThisIsUI: suspendedProcess 290655 290656 self uiProcess == suspendedProcess ifTrue: [ 290657 self spawnNewProcess. 290658 ^true 290659 ]. 290660 ^false "no new process was created" 290661! ! 290662 290663!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 2/19/2001 07:37'! 290664squeakletDirectory 290665 290666 | squeakletDirectoryName | 290667 squeakletDirectoryName := 'Squeaklets'. 290668 (FileDirectory default directoryExists: squeakletDirectoryName) ifFalse: [ 290669 FileDirectory default createDirectory: squeakletDirectoryName 290670 ]. 290671 ^FileDirectory default directoryNamed: squeakletDirectoryName! ! 290672 290673 290674!Project class methodsFor: 'utilities' stamp: 'di 6/13/1998 11:29'! 290675addItem: item toMenu: menu selection: action 290676 (menu isKindOf: MenuMorph) 290677 ifTrue: [menu add: item selector: #jumpToSelection: argument: action] 290678 ifFalse: [menu add: item action: action]! ! 290679 290680!Project class methodsFor: 'utilities' stamp: 'alain.plantec 6/1/2008 19:51'! 290681addItem: item toMenu: menu selection: action project: aProject 290682 | color | 290683 color := aProject world isInMemory 290684 ifTrue: [Color black] 290685 ifFalse: [Color brown]. 290686 (menu isKindOf: MenuMorph) 290687 ifTrue: [| thumbnail | 290688 menu 290689 add: item 290690 selector: #jumpToSelection: 290691 argument: action. 290692 menu lastItem color: color. 290693 thumbnail := aProject thumbnail. 290694 thumbnail isNil 290695 ifFalse: [menu lastItem 290696 icon: (thumbnail 290697 scaledIntoFormOfSize: (Preferences tinyDisplay 290698 ifTrue: [16] 290699 ifFalse: [28]))]] 290700 ifFalse: [menu add: item action: action]! ! 290701 290702!Project class methodsFor: 'utilities' stamp: 'RAA 11/16/2000 12:04'! 290703addingProject: newProject 290704 290705 (self allProjects includes: newProject) ifTrue: [^self]. 290706 AllProjects := self allProjects copyWith: newProject.! ! 290707 290708!Project class methodsFor: 'utilities' stamp: 'tk 10/26/1999 14:25'! 290709advanceToNextProject 290710 | nextProj | 290711 (nextProj := CurrentProject nextProject) ifNotNil: 290712 [nextProj enter: true revert: false saveForRevert: false] 290713! ! 290714 290715!Project class methodsFor: 'utilities' stamp: 'RAA 11/14/2000 19:14'! 290716allMorphicProjects 290717 290718 ^ self allProjects select: [:p | p world isMorph]! ! 290719 290720!Project class methodsFor: 'utilities' stamp: 'di 6/10/1999 11:30'! 290721allNames 290722 ^ (self allProjects collect: [:p | p name]) asSortedCollection: [:n1 :n2 | n1 asLowercase < n2 asLowercase]! ! 290723 290724!Project class methodsFor: 'utilities' stamp: 'di 6/10/1999 11:30'! 290725allNamesAndProjects 290726 ^ (self allProjects asSortedCollection: [:p1 :p2 | p1 name asLowercase < p2 name asLowercase]) collect: 290727 [:aProject | Array with: aProject name with: aProject]! ! 290728 290729!Project class methodsFor: 'utilities' stamp: 'RAA 11/13/2000 17:14'! 290730allProjects 290731 290732 ^AllProjects ifNil: [ 290733 Smalltalk garbageCollect. 290734 AllProjects := self allSubInstances select: [:p | p name notNil]. 290735 ].! ! 290736 290737!Project class methodsFor: 'utilities' stamp: 'alain.plantec 6/19/2008 09:58'! 290738canWeLoadAProjectNow 290739 ^true 290740! ! 290741 290742!Project class methodsFor: 'utilities' stamp: 'sw 9/12/2001 23:05'! 290743chooseNaturalLanguage 290744 "Have the current project choose a new natural language" 290745 290746 self current chooseNaturalLanguage! ! 290747 290748!Project class methodsFor: 'utilities' stamp: 'RAA 11/13/2000 17:26'! 290749deletingProject: outgoingProject 290750 290751 ImageSegment allSubInstancesDo: [:seg | 290752 seg ifOutPointer: outgoingProject thenAllObjectsDo: [:obj | 290753 (obj isKindOf: ProjectViewMorph) ifTrue: [ 290754 obj deletingProject: outgoingProject. obj abandon]. 290755 obj class == Project ifTrue: [obj deletingProject: outgoingProject]]]. 290756 Project allProjects do: [:p | p deletingProject: outgoingProject]. "ones that are in" 290757 ProjectViewMorph allSubInstancesDo: [:p | 290758 p deletingProject: outgoingProject. 290759 p project == outgoingProject ifTrue: [p abandon]]. 290760 290761 AllProjects := self allProjects copyWithout: outgoingProject.! ! 290762 290763!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 09:52'! 290764enter: aString 290765 "Enter the project with the given name" 290766 ^ ((self named: aString) ifNil: [^ CurrentProject]) enter! ! 290767 290768!Project class methodsFor: 'utilities' stamp: 'RAA 12/26/2000 12:42'! 290769forget: aProject 290770 290771 AllProjects := self allProjects reject: [ :x | x == aProject]. 290772! ! 290773 290774!Project class methodsFor: 'utilities' stamp: 'dtl 4/3/2005 14:02'! 290775interruptName: labelString 290776 "Create a Notifier on the active scheduling process with the given label." 290777 290778 ^ self interruptName: labelString preemptedProcess: nil 290779! ! 290780 290781!Project class methodsFor: 'utilities' stamp: 'nice 4/19/2009 16:25'! 290782interruptName: labelString preemptedProcess: theInterruptedProcess 290783 "Create a Notifier on the active scheduling process with the given label." 290784 | preemptedProcess projectProcess | 290785 ActiveHand ifNotNil:[ActiveHand interrupted]. 290786 ActiveWorld := World. "reinstall active globals" 290787 ActiveHand := World primaryHand. 290788 ActiveHand interrupted. "make sure this one's interrupted too" 290789 ActiveEvent := nil. 290790 290791 projectProcess := self uiProcess. "we still need the accessor for a while" 290792 preemptedProcess := theInterruptedProcess ifNil: [Processor preemptedProcess]. 290793 "Only debug preempted process if its priority is >= projectProcess' priority" 290794 preemptedProcess priority < projectProcess priority ifTrue:[ 290795 projectProcess suspend. 290796 preemptedProcess := projectProcess. 290797 ] ifFalse:[ 290798 preemptedProcess suspend offList. 290799 ]. 290800 Debugger openInterrupt: labelString onProcess: preemptedProcess 290801! ! 290802 290803!Project class methodsFor: 'utilities' stamp: 'jla 4/2/2001 15:57'! 290804jumpToSelection: selection 290805 "Enter the project corresponding to this menu selection." 290806 290807 "Project jumpToProject" 290808 | nBack prev pr | 290809 selection ifNil: [^ self]. 290810 (selection beginsWith: '%back') ifTrue: 290811 [nBack := (selection copyFrom: 6 to: selection size) asNumber. 290812 prev := CurrentProject previousProject. 290813 1 to: nBack-1 do: 290814 [:i | prev ifNotNil: [prev := prev previousProject]]. 290815 prev ifNotNil: [prev enter: true revert: false saveForRevert: false]]. 290816 selection = #parent ifTrue: 290817 [CurrentProject parent enter: false revert: false saveForRevert: false. 290818 ^ self]. 290819 (pr := Project namedWithDepth: selection) ifNil: [^ self]. 290820 pr enter: false revert: false saveForRevert: false! ! 290821 290822!Project class methodsFor: 'utilities' stamp: 'alain.plantec 6/1/2008 19:55'! 290823maybeForkInterrupt 290824 290825 Preferences cmdDotEnabled ifFalse: [^self]. 290826 [self interruptName: 'User Interrupt'] fork 290827! ! 290828 290829!Project class methodsFor: 'utilities' stamp: 'tk 3/10/2000 21:10'! 290830named: projName 290831 "Answer the project with the given name, or nil if there is no project of that given name." 290832 "(Project named: 'New Changes') enter" 290833 290834 ^ self allProjects 290835 detect: [:proj | proj name = projName] 290836 ifNone: [nil] 290837! ! 290838 290839!Project class methodsFor: 'utilities' stamp: 'RAA 11/11/2000 23:05'! 290840named: projName in: aListOfProjects 290841 "Answer the project with the given name, or nil if there is no project of that given name." 290842 "Use given collection for speed until we get faster #allProjects" 290843 290844 ^ aListOfProjects 290845 detect: [:proj | proj name = projName] 290846 ifNone: [nil] 290847! ! 290848 290849!Project class methodsFor: 'utilities' stamp: 'jla 4/2/2001 15:57'! 290850namedWithDepth: projName 290851 "Answer the project with the given name, or nil if there is no project of that given name." 290852 "(Project named: 'New Changes') enter" 290853 290854 ^ self allProjects 290855 detect: [:proj | 290856 proj name = projName or: 290857 [proj nameAdjustedForDepth = projName]] 290858 ifNone: [nil]! ! 290859 290860!Project class methodsFor: 'utilities' stamp: 'RAA 9/27/2000 19:00'! 290861ofWorld: aPasteUpMorph 290862 "Find the project of a world." 290863 290864 "Usually it is the current project" 290865 CurrentProject world == aPasteUpMorph ifTrue: [^ CurrentProject]. 290866 290867 "Inefficient enumeration if it is not..." 290868 ^ self allProjects detect: [:pr | 290869 pr world isInMemory 290870 ifTrue: [pr world == aPasteUpMorph] 290871 ifFalse: [false]] 290872 ifNone: [nil]! ! 290873 290874!Project class methodsFor: 'utilities' stamp: 'stephane.ducasse 3/22/2009 10:49'! 290875removeAll: projects 290876 "Project removeAll: (Project allSubInstances copyWithout: Project current)" 290877 290878 AllProjects := nil. 290879 Smalltalk garbageCollect. 290880 290881 projects do: [:project | 290882 Project deletingProject: project. 290883 StandardScriptingSystem removePlayersIn: project]. 290884 290885 Smalltalk garbageCollect. 290886 Smalltalk garbageCollect. 290887! ! 290888 290889!Project class methodsFor: 'utilities' stamp: 'mir 11/26/2004 15:22'! 290890removeAllButCurrent 290891 "Project removeAllButCurrent" 290892 290893 AllProjects := nil. 290894 Smalltalk garbageCollect. 290895 290896 self removeAll: (Project allSubInstances copyWithout: Project current). 290897 290898 AllProjects := nil. 290899 Smalltalk garbageCollect. 290900 290901 Smalltalk garbageCollect. 290902 Project rebuildAllProjects. 290903 ^AllProjects! ! 290904 290905!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 18:28'! 290906resumeProcess: aProcess 290907 "Adopt aProcess as the project process -- probably because of proceeding from a debugger" 290908 290909 UIProcess := aProcess. 290910 UIProcess resume! ! 290911 290912!Project class methodsFor: 'utilities' stamp: 'tk 10/26/1999 14:25'! 290913returnToPreviousProject 290914 "Return to the project from which this project was entered. Do nothing if the current project has no link to its previous project." 290915 290916 | prevProj | 290917 prevProj := CurrentProject previousProject. 290918 prevProj ifNotNil: [prevProj enter: true revert: false saveForRevert: false]. 290919! ! 290920 290921!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 18:49'! 290922spawnNewProcess 290923 290924 UIProcess := [ 290925 [World doOneCycle. Processor yield. false] whileFalse: []. 290926 ] newProcess priority: Processor userSchedulingPriority. 290927 UIProcess resume! ! 290928 290929!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 18:49'! 290930spawnNewProcessAndTerminateOld: terminate 290931 290932 self spawnNewProcess. 290933 terminate 290934 ifTrue: [Processor terminateActive] 290935 ifFalse: [Processor activeProcess suspend]! ! 290936 290937!Project class methodsFor: 'utilities' stamp: 'RAA 9/27/2000 18:52'! 290938storeAllInSegments 290939 "Write out all Projects in this Image. 290940 Project storeAllInSegments. " 290941 290942 | all ff ll | 290943all := Project allProjects. 290944Transcript show: 'Initial Space Left: ', (ff := Smalltalk garbageCollect) printString; cr. 290945all do: [:proj | 290946 Transcript show: proj name; cr. 290947 proj storeSegment "storeSegmentNoFile"]. 290948Transcript show: 'After writing all: ', (ll := Smalltalk garbageCollect) printString; cr. 290949Transcript show: 'Space gained: ', (ll - ff) printString; cr. 290950"some will come back in"! ! 290951 290952!Project class methodsFor: 'utilities' stamp: 'RAA 9/27/2000 19:00'! 290953topProject 290954 "Answer the top project. There is only one" 290955 290956 ^ self allProjects detect: [:p | p isTopProject]! ! 290957 290958!Project class methodsFor: 'utilities' stamp: 'mir 6/21/2001 15:44'! 290959versionForFileName: version 290960 "Project versionForFileName: 7" 290961 | v | 290962 ^String streamContents:[:s| 290963 v := version printString. 290964 v size < 3 ifTrue:[v := '0', v]. 290965 v size < 3 ifTrue:[v := '0', v]. 290966 s nextPutAll: v. 290967 ] 290968! ! 290969Notification subclass: #ProjectEntryNotification 290970 instanceVariableNames: 'projectToEnter' 290971 classVariableNames: '' 290972 poolDictionaries: '' 290973 category: 'Exceptions-Kernel'! 290974!ProjectEntryNotification commentStamp: '<historical>' prior: 0! 290975I provide a way to override the style of Project entry (which is buried deep in several different methods). My default is a normal full-screen enter.! 290976 290977 290978!ProjectEntryNotification methodsFor: 'as yet unclassified' stamp: 'RAA 6/6/2000 18:55'! 290979defaultAction 290980 290981 self resume: projectToEnter enter! ! 290982 290983!ProjectEntryNotification methodsFor: 'as yet unclassified' stamp: 'RAA 6/6/2000 19:02'! 290984projectToEnter 290985 290986 ^projectToEnter! ! 290987 290988!ProjectEntryNotification methodsFor: 'as yet unclassified' stamp: 'RAA 6/6/2000 18:53'! 290989projectToEnter: aProject 290990 290991 projectToEnter := aProject! ! 290992 290993"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 290994 290995ProjectEntryNotification class 290996 instanceVariableNames: ''! 290997 290998!ProjectEntryNotification class methodsFor: 'as yet unclassified' stamp: 'ajh 1/22/2003 23:52'! 290999signal: aProject 291000 291001 | ex | 291002 ex := self new. 291003 ex projectToEnter: aProject. 291004 ^ex signal: 'Entering ',aProject printString! ! 291005AbstractLauncher subclass: #ProjectLauncher 291006 instanceVariableNames: 'showSplash splashURL whichFlaps eToyAuthentificationServer' 291007 classVariableNames: 'SplashMorph' 291008 poolDictionaries: '' 291009 category: 'System-Download'! 291010 291011!ProjectLauncher methodsFor: 'initialization' stamp: 'mir 8/24/2001 20:25'! 291012initialize 291013 super initialize. 291014 showSplash := true. 291015 HTTPClient isRunningInBrowser 291016 ifTrue: [whichFlaps := 'etoy']! ! 291017 291018!ProjectLauncher methodsFor: 'initialization' stamp: 'mir 8/23/2002 14:52'! 291019setupFromParameters 291020 (self includesParameter: 'showSplash') 291021 ifTrue: [showSplash := (self parameterAt: 'showSplash') asUppercase = 'TRUE']. 291022 (self includesParameter: 'flaps') 291023 ifTrue: [whichFlaps := (self parameterAt: 'flaps')]. 291024! ! 291025 291026 291027!ProjectLauncher methodsFor: 'running' stamp: 'mir 4/3/2001 15:15'! 291028hideSplashMorph 291029 SplashMorph ifNil:[^self]. 291030 self showSplash 291031 ifFalse: [^self]. 291032 SplashMorph delete. 291033 World submorphs do:[:m| m visible: true]. "show all" 291034! ! 291035 291036!ProjectLauncher methodsFor: 'running' stamp: 'ar 3/16/2001 12:42'! 291037installProjectFrom: loader 291038 self showSplashMorph. 291039 [[[ 291040 loader installProject 291041 ] on: ProjectViewOpenNotification 291042 do:[:ex| ex resume: false] "no project view in plugin launcher" 291043 ] on: ProgressInitiationException "no 'reading aStream' nonsense" 291044 do:[:ex| ex sendNotificationsTo: [ :min :max :curr |]] 291045 ] on: ProjectEntryNotification "hide splash morph when entering project" 291046 do:[:ex| self hideSplashMorph. ex pass].! ! 291047 291048!ProjectLauncher methodsFor: 'running' stamp: 'mir 4/3/2001 15:15'! 291049showSplashMorph 291050 SplashMorph ifNil:[^self]. 291051 self showSplash 291052 ifFalse: [^self]. 291053 World submorphs do:[:m| m visible: false]. "hide all" 291054 World addMorphCentered: SplashMorph. 291055 World displayWorldSafely.! ! 291056 291057!ProjectLauncher methodsFor: 'running' stamp: 'StephaneDucasse 9/10/2009 20:20'! 291058startUp 291059 World ifNotNil: [World install]. 291060 "Author fullName: ''." 291061 ^self startUpAfterLogin.! ! 291062 291063!ProjectLauncher methodsFor: 'running' stamp: 'stephane.ducasse 10/27/2008 21:48'! 291064startUpAfterLogin 291065 | scriptName loader isUrl | 291066 Preferences readDocumentAtStartup ifTrue: [ 291067 HTTPClient isRunningInBrowser ifTrue:[ 291068 self setupFromParameters. 291069 scriptName := self parameterAt: 'src'. 291070 CodeLoader defaultBaseURL: (self parameterAt: 'Base'). 291071 ] ifFalse:[ 291072 scriptName := (SmalltalkImage current getSystemAttribute: 2) ifNil:['']. 291073 scriptName := scriptName convertFromSystemString. 291074 scriptName isEmpty ifFalse:[ 291075 "figure out if script name is a URL by itself" 291076 isUrl := (scriptName asLowercase beginsWith:'http://') or:[ 291077 (scriptName asLowercase beginsWith:'file://') or:[ 291078 (scriptName asLowercase beginsWith:'ftp://')]]. 291079 isUrl ifFalse:[scriptName := 'file:',scriptName]]. 291080 ]. ] 291081 ifFalse: [ scriptName := '' ]. 291082 291083 scriptName isEmptyOrNil 291084 ifTrue:[^ self]. 291085 loader := CodeLoader new. 291086 loader loadSourceFiles: (Array with: scriptName). 291087 loader installSourceFiles.! ! 291088 291089 291090!ProjectLauncher methodsFor: 'private' stamp: 'mir 4/3/2001 15:15'! 291091showSplash 291092 ^showSplash! ! 291093 291094"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 291095 291096ProjectLauncher class 291097 instanceVariableNames: ''! 291098 291099!ProjectLauncher class methodsFor: 'accessing' stamp: 'ar 3/15/2001 23:32'! 291100splashMorph 291101 ^SplashMorph! ! 291102 291103!ProjectLauncher class methodsFor: 'accessing' stamp: 'ar 3/15/2001 23:33'! 291104splashMorph: aMorph 291105 SplashMorph := aMorph.! ! 291106Object subclass: #ProjectLoading 291107 instanceVariableNames: '' 291108 classVariableNames: '' 291109 poolDictionaries: '' 291110 category: 'System-Support'! 291111 291112"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 291113 291114ProjectLoading class 291115 instanceVariableNames: ''! 291116 291117!ProjectLoading class methodsFor: 'accessing' stamp: 'ar 2/27/2001 14:33'! 291118projectStreamFromArchive: archive 291119 | ext prFiles entry unzipped | 291120 ext := FileDirectory dot, Project projectExtension. 291121 prFiles := archive members select:[:any| any fileName endsWith: ext]. 291122 prFiles isEmpty ifTrue:[^'']. 291123 entry := prFiles first. 291124 unzipped := RWBinaryOrTextStream on: (ByteArray new: entry uncompressedSize). 291125 entry extractTo: unzipped. 291126 ^unzipped reset! ! 291127 291128 291129!ProjectLoading class methodsFor: 'loading' stamp: 'RAA 2/20/2001 20:25'! 291130installRemoteNamed: remoteFileName from: aServer named: otherProjectName in: currentProject 291131 291132 | fileAndDir | 291133 291134 "Find the current ProjectViewMorph, fetch the project, install in ProjectViewMorph without changing size, and jump into new project." 291135 291136 ProgressNotification signal: '1:foundMostRecent'. 291137 fileAndDir := self bestAccessToFileName: remoteFileName andDirectory: aServer. 291138 ^self 291139 openName: remoteFileName 291140 stream: fileAndDir first 291141 fromDirectory: fileAndDir second 291142 withProjectView: (currentProject findProjectView: otherProjectName). 291143! ! 291144 291145!ProjectLoading class methodsFor: 'loading' stamp: 'RAA 2/19/2001 08:22'! 291146openFromFile: preStream fromDirectory: aDirectoryOrNil withProjectView: existingView 291147 291148 291149 self error: 'use #openFromFile:fromDirectory:withProjectView:' 291150! ! 291151 291152!ProjectLoading class methodsFor: 'loading' stamp: 'adrian_lienhard 7/19/2009 21:54'! 291153openName: aFileName stream: preStream fromDirectory: aDirectoryOrNil 291154withProjectView: existingView 291155 "Reconstitute a Morph from the selected file, presumed to be 291156represent a Morph saved via the SmartRefStream mechanism, and open it 291157in an appropriate Morphic world." 291158 291159 | morphOrList proj trusted localDir projStream archive mgr 291160projectsToBeDeleted baseChangeSet enterRestricted substituteFont 291161numberOfFontSubstitutes exceptions | 291162 (preStream isNil or: [preStream size = 0]) ifTrue: [ 291163 ProgressNotification signal: '9999 about to enter 291164project'. "the hard part is over" 291165 ^self inform: 291166'It looks like a problem occurred while 291167getting this project. It may be temporary, 291168so you may want to try again,' translated 291169 ]. 291170 ProgressNotification signal: '2:fileSizeDetermined 291171',preStream size printString. 291172 preStream isZipArchive 291173 ifTrue:[ archive := ZipArchive new readFrom: preStream. 291174 projStream := self 291175projectStreamFromArchive: archive] 291176 ifFalse:[projStream := preStream]. 291177 trusted := SecurityManager default positionToSecureContentsOf: 291178projStream. 291179 trusted ifFalse: 291180 [enterRestricted := (preStream isTypeHTTP or: 291181[aFileName isNil]) 291182 ifTrue: [Preferences securityChecksEnabled] 291183 ifFalse: [Preferences standaloneSecurityChecksEnabled]. 291184 enterRestricted 291185 ifTrue: [SecurityManager default enterRestrictedMode 291186 ifFalse: 291187 [preStream close. 291188 ^ self]]]. 291189 291190 localDir := Project squeakletDirectory. 291191 aFileName ifNotNil: [ 291192 (aDirectoryOrNil isNil or: [aDirectoryOrNil pathName 291193~= localDir pathName]) ifTrue: [ 291194 localDir deleteFileNamed: aFileName. 291195 (localDir fileNamed: aFileName) binary 291196 nextPutAll: preStream contents; 291197 close. 291198 ]. 291199 ]. 291200 morphOrList := projStream asUnZippedStream. 291201 preStream sleep. "if ftp, let the connection close" 291202 ProgressNotification signal: '3:unzipped'. 291203 ResourceCollector current: ResourceCollector new. 291204 baseChangeSet := ChangeSet current. 291205 self useTempChangeSet. "named zzTemp" 291206 "The actual reading happens here" 291207 substituteFont := Preferences standardEToysFont copy. 291208 numberOfFontSubstitutes := 0. 291209 exceptions := Set new. 291210 [[morphOrList := morphOrList fileInObjectAndCodeForProject] 291211 on: FontSubstitutionDuringLoading do: [ :ex | 291212 exceptions add: ex. 291213 numberOfFontSubstitutes := 291214numberOfFontSubstitutes + 1. 291215 ex resume: substituteFont ]] 291216 ensure: [ ChangeSet newChanges: baseChangeSet]. 291217 mgr := ResourceManager new initializeFrom: ResourceCollector current. 291218 mgr fixJISX0208Resource. 291219 mgr registerUnloadedResources. 291220 archive ifNotNil:[mgr preLoadFromArchive: archive cacheName: 291221aFileName]. 291222 (preStream respondsTo: #close) ifTrue:[preStream close]. 291223 ResourceCollector current: nil. 291224 ProgressNotification signal: '4:filedIn'. 291225 ProgressNotification signal: '9999 about to enter project'. 291226 "the hard part is over" 291227 (morphOrList isKindOf: ImageSegment) ifTrue: [ 291228 proj := morphOrList arrayOfRoots 291229 detect: [:mm | mm isKindOf: Project] 291230 ifNone: [^self inform: 'No project found in 291231this file']. 291232 proj projectParameters at: #substitutedFont put: ( 291233 numberOfFontSubstitutes > 0 291234 ifTrue: [substituteFont] 291235 ifFalse: [#none]). 291236 proj projectParameters at: #MultiSymbolInWrongPlace put: false. 291237 "Yoshiki did not put MultiSymbols into 291238outPointers in older images!!" 291239 morphOrList arrayOfRoots do: [:obj | 291240 obj fixUponLoad: proj seg: morphOrList "imageSegment"]. 291241 (proj projectParameters at: #MultiSymbolInWrongPlace) ifTrue: [ 291242 morphOrList arrayOfRoots do: [:obj | (obj 291243isKindOf: Set) ifTrue: [obj rehash]]]. 291244 291245 proj resourceManager: mgr. 291246 "proj versionFrom: preStream." 291247 proj lastDirectory: aDirectoryOrNil. 291248 proj setParent: Project current. 291249 projectsToBeDeleted := OrderedCollection new. 291250 existingView ifNil: [ 291251 proj createViewIfAppropriate. 291252 ] ifNotNil: [ 291253 (existingView project isKindOf: DiskProxy) ifFalse: [ 291254 existingView project changeSet name: 291255ChangeSet defaultName. 291256 projectsToBeDeleted add: existingView project. 291257 ]. 291258 (existingView owner isSystemWindow) ifTrue: [ 291259 existingView owner model: proj 291260 ]. 291261 existingView project: proj. 291262 ]. 291263 ChangeSet allChangeSets add: proj changeSet. 291264 Project current projectParameters 291265 at: #deleteWhenEnteringNewProject 291266 ifPresent: [ :ignored | 291267 projectsToBeDeleted add: Project current. 291268 Project current removeParameter: 291269#deleteWhenEnteringNewProject. 291270 ]. 291271 projectsToBeDeleted isEmpty ifFalse: [ 291272 proj projectParameters 291273 at: #projectsToBeDeleted 291274 put: projectsToBeDeleted. 291275 ]. 291276 ^ ProjectEntryNotification signal: proj 291277 ]. 291278 291279 Smalltalk at: #SqueakPage ifPresent: [ :class | 291280 (morphOrList isKindOf: class) ifTrue: [ 291281 morphOrList := morphOrList contentsMorph 291282 ] ]. 291283 (morphOrList isKindOf: PasteUpMorph) ifFalse: 291284 [^ self inform: 'This is not a PasteUpMorph or 291285exported Project.' translated]. 291286 (Project newMorphicOn: morphOrList) enter 291287! ! 291288 291289 291290!ProjectLoading class methodsFor: 'utilities' stamp: 'md 5/11/2008 11:43'! 291291bestAccessToFileName: aFileName andDirectory: aDirectoryOrUrlString 291292 "Answer an array with a stream and a directory. The directory can be nil." 291293 291294 | dir url | 291295 dir := Project squeakletDirectory. 291296 (dir fileExists: aFileName) ifTrue: [ 291297 ^{dir readOnlyFileNamed: aFileName. dir}]. 291298 291299 aDirectoryOrUrlString isString ifFalse: [ 291300 ^{aDirectoryOrUrlString readOnlyFileNamed: aFileName. aDirectoryOrUrlString}]. 291301 291302 url := Url absoluteFromFileNameOrUrlString: aDirectoryOrUrlString. 291303 291304 (url scheme = 'file') ifTrue: [ 291305 dir := FileDirectory on: url pathForDirectory. 291306 ^{dir readOnlyFileNamed: aFileName. dir}]. 291307 291308 ^{ServerFile new fullPath: aDirectoryOrUrlString. nil}! ! 291309 291310!ProjectLoading class methodsFor: 'utilities' stamp: 'ar 9/27/2005 20:10'! 291311useTempChangeSet 291312 "While reading the project in, use the temporary change set zzTemp" 291313 291314 | zz | 291315 zz := ChangeSet named: 'zzTemp'. 291316 zz ifNil: [zz := ChangeSet basicNewChangeSet: 'zzTemp']. 291317 ChangeSet newChanges: zz.! ! 291318ServerDirectory subclass: #ProjectSwikiServer 291319 instanceVariableNames: 'acceptsUploads' 291320 classVariableNames: '' 291321 poolDictionaries: '' 291322 category: 'Network-RemoteDirectory'! 291323 291324!ProjectSwikiServer methodsFor: 'accessing' stamp: 'mir 6/25/2001 12:40'! 291325acceptsUploads: aBoolean 291326 acceptsUploads := aBoolean! ! 291327 291328 291329!ProjectSwikiServer methodsFor: 'initialize' stamp: 'mir 4/20/2001 18:43'! 291330wakeUp! ! 291331 291332 291333!ProjectSwikiServer methodsFor: 'testing' stamp: 'mir 6/25/2001 12:40'! 291334acceptsUploads 291335 ^acceptsUploads == true! ! 291336 291337!ProjectSwikiServer methodsFor: 'testing' stamp: 'mir 4/16/2001 17:42'! 291338isProjectSwiki 291339 ^true! ! 291340ImageMorph subclass: #ProjectViewMorph 291341 instanceVariableNames: 'project lastProjectThumbnail' 291342 classVariableNames: '' 291343 poolDictionaries: '' 291344 category: 'Morphic-Windows'! 291345!ProjectViewMorph commentStamp: '<historical>' prior: 0! 291346I am a Morphic view of a project. I display a scaled version of the project's thumbnail, which itself is a scaled-down snapshot of the screen taken when the project was last exited. When I am displayed, I check to see if the project thumbnail has changed and, if so, I update my own view of that thumbnail. 291347! 291348 291349 291350!ProjectViewMorph methodsFor: 'accessing' stamp: 'RAA 2/12/2001 14:47'! 291351borderWidthForRounding 291352 291353 ^1! ! 291354 291355!ProjectViewMorph methodsFor: 'accessing' stamp: 'tk 8/30/1999 11:48'! 291356project 291357 ^project! ! 291358 291359!ProjectViewMorph methodsFor: 'accessing' stamp: 'di 6/6/2001 21:34'! 291360thumbnail 291361 ^ project ifNotNil: [project thumbnail]! ! 291362 291363 291364!ProjectViewMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 09:56'! 291365addProjectNameMorph 291366 291367 | m | 291368 291369 self removeAllMorphs. 291370 m := UpdatingStringMorph contents: self safeProjectName font: self fontForName. 291371 m target: self; getSelector: #safeProjectName; putSelector: #safeProjectName:. 291372 m useStringFormat; fitContents. 291373 self addMorphBack: m. 291374 self updateNamePosition. 291375 ^m 291376 291377! ! 291378 291379!ProjectViewMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 10:12'! 291380addProjectNameMorphFiller 291381 291382 | m | 291383 291384 self removeAllMorphs. 291385 m := AlignmentMorph newRow color: Color transparent. 291386 self addMorphBack: m. 291387 m 291388 on: #mouseDown send: #editTheName: to: self; 291389 on: #mouseUp send: #yourself to: self. 291390 self updateNamePosition. 291391 291392! ! 291393 291394!ProjectViewMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 10:41'! 291395editTheName: evt 291396 291397 self isTheRealProjectPresent ifFalse: [ 291398 ^self inform: 'The project is not present and may not be renamed now' 291399 ]. 291400 self addProjectNameMorph launchMiniEditor: evt.! ! 291401 291402 291403!ProjectViewMorph methodsFor: 'caching' stamp: 'RAA 10/27/2000 10:55'! 291404releaseCachedState 291405 291406 "see if we can reduce size of published file, but there may be problems" 291407 super releaseCachedState. 291408 lastProjectThumbnail := image. 291409! ! 291410 291411 291412!ProjectViewMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 08:56'! 291413veryDeepFixupWith: deepCopier 291414 "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 291415 291416super veryDeepFixupWith: deepCopier. 291417project := deepCopier references at: project ifAbsent: [project]. 291418lastProjectThumbnail := deepCopier references at: lastProjectThumbnail 291419 ifAbsent: [lastProjectThumbnail]. 291420! ! 291421 291422!ProjectViewMorph methodsFor: 'copying' stamp: 'fc 12/23/2004 16:24'! 291423veryDeepInner: deepCopier 291424 "Copy all of my instance variables. Some need to be not copied at all, but shared. See DeepCopier class comment." 291425 291426 super veryDeepInner: deepCopier. 291427 project := project. "Weakly copied" 291428 lastProjectThumbnail := lastProjectThumbnail veryDeepCopyWith: deepCopier. 291429! ! 291430 291431 291432!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 8/30/2000 19:10'! 291433colorAroundName 291434 291435 ^Color gray: 0.8! ! 291436 291437!ProjectViewMorph methodsFor: 'drawing' stamp: 'jmv 9/7/2009 00:35'! 291438drawOn: aCanvas 291439 291440 | font projectName nameForm rectForName | 291441 291442 self ensureImageReady. 291443 super drawOn: aCanvas. 291444 self isEditingName ifTrue: [^self]. 291445 291446 font := self fontForName. 291447 projectName := self safeProjectName. 291448 nameForm := (StringMorph contents: projectName font: font) imageForm. 291449 nameForm := nameForm scaledToSize: (self extent - (4@2) min: nameForm extent). 291450 rectForName := self bottomLeft + 291451 (self width - nameForm width // 2 @ (nameForm height + 2) negated) 291452 extent: nameForm extent. 291453 rectForName topLeft eightNeighbors do: [ :pt | 291454 aCanvas 291455 stencil: nameForm 291456 at: pt 291457 color: self colorAroundName. 291458 ]. 291459 aCanvas 291460 drawImage: nameForm 291461 at: rectForName topLeft 291462! ! 291463 291464!ProjectViewMorph methodsFor: 'drawing' stamp: 'raa 2/8/2001 10:40'! 291465ensureImageReady 291466 291467 self isTheRealProjectPresent ifFalse: [^self]. 291468 project thumbnail ifNil: [ 291469 image fill: image boundingBox rule: Form over 291470 fillColor: project defaultBackgroundColor. 291471 ^self 291472 ]. 291473 project thumbnail ~~ lastProjectThumbnail ifTrue: ["scale thumbnail to fit my bounds" 291474 lastProjectThumbnail := project thumbnail. 291475 self updateImageFrom: lastProjectThumbnail. 291476 project thumbnail ifNotNil: [project thumbnail hibernate]. 291477 image borderWidth: 1 291478 ]. 291479 291480 291481! ! 291482 291483!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 8/30/2000 19:11'! 291484fontForName 291485 291486 | pickem | 291487 pickem := 3. 291488 291489 pickem = 1 ifTrue: [ 291490 ^(((TextStyle named: #Helvetica) ifNil: [TextStyle default]) fontOfSize: 13) emphasized: 1. 291491 ]. 291492 pickem = 2 ifTrue: [ 291493 ^(((TextStyle named: #Palatino) ifNil: [TextStyle default]) fontOfSize: 12) emphasized: 1. 291494 ]. 291495 ^((TextStyle default) fontAt: 1) emphasized: 1 291496! ! 291497 291498!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/1/2000 22:45'! 291499isEditingName 291500 291501 | nameMorph | 291502 nameMorph := self findA: UpdatingStringMorph. 291503 nameMorph ifNil: [^false]. 291504 291505 ^nameMorph hasFocus 291506! ! 291507 291508!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/2/2000 10:38'! 291509isTheRealProjectPresent 291510 291511 project ifNil: [^ false]. 291512 project isInMemory ifFalse: [^ false]. 291513 project class == DiskProxy ifTrue: [^ false]. 291514 ^true 291515! ! 291516 291517!ProjectViewMorph methodsFor: 'drawing' stamp: 'gm 2/22/2003 13:14'! 291518safeProjectName 291519 | projectName args | 291520 projectName := self valueOfProperty: #SafeProjectName ifAbsent: ['???']. 291521 self isTheRealProjectPresent 291522 ifFalse: 291523 [project class == DiskProxy 291524 ifTrue: 291525 [args := project constructorArgs. 291526 ((args isKindOf: Array) 291527 and: [args size = 1 and: [args first isString]]) 291528 ifTrue: [^args first]] 291529 ifFalse: [^projectName]]. 291530 self setProperty: #SafeProjectName toValue: project name. 291531 ^project name! ! 291532 291533!ProjectViewMorph methodsFor: 'drawing' stamp: 'gm 2/16/2003 20:34'! 291534safeProjectName: aString 291535 self addProjectNameMorphFiller. 291536 self isTheRealProjectPresent ifFalse: [^self]. 291537 project renameTo: aString. 291538 self setProperty: #SafeProjectName toValue: project name. 291539 self updateNamePosition. 291540 (owner isSystemWindow) ifTrue: [owner setLabel: aString]! ! 291541 291542!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 1/26/2001 09:14'! 291543showBorderAs: aColor 291544 291545 "image border: image boundingBox width: 1 fillColor: aColor. 291546 currentBorderColor := aColor. 291547 self changed" 291548! ! 291549 291550!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 10/27/2000 10:50'! 291551updateImageFrom: sourceForm 291552 291553 (WarpBlt current toForm: image) 291554 sourceForm: sourceForm; 291555 cellSize: 2; "installs a colormap" 291556 combinationRule: Form over; 291557 copyQuad: (sourceForm boundingBox) innerCorners 291558 toRect: image boundingBox. 291559! ! 291560 291561!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/2/2000 10:11'! 291562updateNamePosition 291563 291564 | nameMorph shadowMorph nameFillerMorph | 291565 291566 (nameMorph := self findA: UpdatingStringMorph) ifNotNil: [ 291567 nameMorph position: 291568 (self left + (self width - nameMorph width // 2)) @ 291569 (self bottom - nameMorph height - 2). 291570 ]. 291571 (nameFillerMorph := self findA: AlignmentMorph) ifNotNil: [ 291572 nameFillerMorph 291573 position: self bottomLeft - (0@20); 291574 extent: self width@20. 291575 ]. 291576 (shadowMorph := self findA: ImageMorph) ifNotNil: [ 291577 shadowMorph delete "no longer used" 291578 ]. 291579 291580! ! 291581 291582 291583!ProjectViewMorph methodsFor: 'dropping/grabbing' stamp: 'alain.plantec 6/1/2008 19:58'! 291584wantsDroppedMorph: aMorph event: evt 291585 291586 self isTheRealProjectPresent ifFalse: [^false]. 291587 project world viewBox ifNil: [^false]. "uninitialized" 291588 ^true! ! 291589 291590 291591!ProjectViewMorph methodsFor: 'event handling' stamp: 'jm 5/4/1998 22:13'! 291592handlesMouseDown: evt 291593 291594 ^ true 291595! ! 291596 291597!ProjectViewMorph methodsFor: 'event handling' stamp: 'sw 9/22/1999 11:41'! 291598handlesMouseOver: evt 291599 ^ true! ! 291600 291601!ProjectViewMorph methodsFor: 'event handling' stamp: 'RAA 1/26/2001 09:03'! 291602handlesMouseOverDragging: evt 291603 291604 ^ true! ! 291605 291606!ProjectViewMorph methodsFor: 'event handling' stamp: 'stephane.ducasse 10/26/2008 17:19'! 291607mouseDown: evt 291608 291609 evt hand newMouseFocus: self. 291610 self removeProperty: #wasOpenedAsSubproject. 291611 self showMouseState: 2.! ! 291612 291613!ProjectViewMorph methodsFor: 'event handling' stamp: 'RAA 7/16/2000 14:14'! 291614mouseEnter: evt 291615 291616 self showMouseState: 1! ! 291617 291618!ProjectViewMorph methodsFor: 'event handling' stamp: 'RAA 7/16/2000 14:13'! 291619mouseLeave: evt 291620 291621 self showMouseState: 3. 291622! ! 291623 291624!ProjectViewMorph methodsFor: 'event handling' stamp: 'RAA 1/26/2001 09:03'! 291625mouseLeaveDragging: evt 291626 291627 self mouseLeave: evt 291628 291629! ! 291630 291631!ProjectViewMorph methodsFor: 'event handling' stamp: 'RAA 10/20/2000 10:12'! 291632wantsKeyboardFocusFor: aSubmorph 291633 291634 ^true! ! 291635 291636 291637!ProjectViewMorph methodsFor: 'events' stamp: 'md 10/22/2003 15:51'! 291638enter 291639 "Enter my project." 291640 291641 self world == self outermostWorldMorph ifFalse: [^Beeper beep]. "can't do this at the moment" 291642 project class == DiskProxy 291643 ifFalse: 291644 [(project world notNil and: 291645 [project world isMorph 291646 and: [project world hasOwner: self outermostWorldMorph]]) 291647 ifTrue: [^Beeper beep "project is open in a window already"]]. 291648 project class == DiskProxy 291649 ifTrue: 291650 ["When target is not in yet" 291651 291652 self enterWhenNotPresent. "will bring it in" 291653 project class == DiskProxy ifTrue: [^self inform: 'Project not found']]. 291654 (owner isSystemWindow) ifTrue: [project setViewSize: self extent]. 291655 self showMouseState: 3. 291656 project 291657 enter: false 291658 revert: false 291659 saveForRevert: false! ! 291660 291661!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 5/17/2000 11:38'! 291662enterWhenNotPresent 291663 291664 self withProgressDo: [ 291665 project enter: false revert: false saveForRevert: false. "will bring it in" 291666 ] 291667 291668! ! 291669 291670!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 7/12/2000 07:44'! 291671lastProjectThumbnail: aForm 291672 291673 lastProjectThumbnail := aForm! ! 291674 291675!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 11/2/2000 10:06'! 291676on: aProject 291677 291678 project := aProject. 291679 self addProjectNameMorphFiller. 291680 lastProjectThumbnail := nil. 291681 project thumbnail 291682 ifNil: [self extent: 100@80] "more like screen dimensions?" 291683 ifNotNil: [self extent: project thumbnail extent]. 291684! ! 291685 291686!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 11/2/2000 10:06'! 291687project: aProject 291688 291689 project := aProject. 291690 self addProjectNameMorphFiller.! ! 291691 291692!ProjectViewMorph methodsFor: 'events' stamp: 'kfr 10/9/2004 10:36'! 291693showMouseState: anInteger 291694 | aMorph | 291695 (owner isSystemWindow) 291696 ifTrue: [aMorph := owner] 291697 ifFalse: [aMorph := self]. 291698 anInteger = 1 291699 ifTrue: ["enter" 291700 aMorph 291701 addMouseActionIndicatorsWidth: 10 291702 color: (Color blue alpha: 0.3)]. 291703 anInteger = 2 291704 ifTrue: ["down" 291705 aMorph 291706 addMouseActionIndicatorsWidth: 15 291707 color: (Color blue alpha: 0.7)]. 291708 anInteger = 3 291709 ifTrue: ["leave" 291710 aMorph deleteAnyMouseActionIndicators]! ! 291711 291712 291713!ProjectViewMorph methodsFor: 'filein/out' stamp: 'tk 9/8/1999 17:51'! 291714storeSegment 291715 "Store my project out on the disk as an ImageSegment. Keep the outPointers in memory. Name it <project name>.seg" 291716 291717 project storeSegment 291718! ! 291719 291720 291721!ProjectViewMorph methodsFor: 'geometry' stamp: 'RAA 10/27/2000 11:08'! 291722extent: aPoint 291723 "Set my image form to the given extent." 291724 291725 | newExtent scaleP scale | 291726 291727 ((bounds extent = aPoint) and: [image depth = Display depth]) ifFalse: [ 291728 lastProjectThumbnail ifNil: [ lastProjectThumbnail := image ]. 291729 scaleP := aPoint / lastProjectThumbnail extent. 291730 scale := scaleP "scaleP x asFloat max: scaleP y asFloat". 291731 newExtent := (lastProjectThumbnail extent * scale) rounded. 291732 self image: (Form extent: newExtent depth: Display depth). 291733 self updateImageFrom: lastProjectThumbnail. 291734 ]. 291735 self updateNamePosition.! ! 291736 291737 291738!ProjectViewMorph methodsFor: 'initialization' stamp: 'RAA 1/26/2001 09:14'! 291739initialize 291740 super initialize. 291741 "currentBorderColor := Color gray." 291742 self addProjectNameMorphFiller.! ! 291743 291744 291745!ProjectViewMorph methodsFor: 'layout' stamp: 'stephane.ducasse 11/8/2008 15:13'! 291746acceptDroppingMorph: morphToDrop event: evt 291747 291748 | myCopy smallR | 291749 291750 (self isTheRealProjectPresent) ifFalse: [ 291751 ^morphToDrop rejectDropMorphEvent: evt. "can't handle it right now" 291752 ]. 291753 (morphToDrop isKindOf: NewHandleMorph) ifTrue: [ "don't send these" 291754 ^morphToDrop rejectDropMorphEvent: evt. 291755 ]. 291756 myCopy := morphToDrop veryDeepCopy. "gradient fills require doing this second" 291757 smallR := (morphToDrop bounds scaleBy: image height / Display height) rounded. 291758 smallR := smallR squishedWithin: image boundingBox. 291759 image getCanvas 291760 paintImage: (morphToDrop imageForm scaledToSize: smallR extent) 291761 at: smallR topLeft. 291762 myCopy openInWorld: project world 291763 291764! ! 291765 291766 291767!ProjectViewMorph methodsFor: 'objects from disk' stamp: 'RAA 10/27/2000 11:08'! 291768objectForDataStream: refStrm 291769 291770 | copy | 291771 291772 1 = 1 ifTrue: [^self]. "this didn't really work" 291773 291774 copy := self copy lastProjectThumbnail: nil. 291775 "refStrm replace: self with: copy." 291776 ^copy 291777! ! 291778 291779 291780!ProjectViewMorph methodsFor: 'rounding' stamp: 'gm 2/16/2003 20:34'! 291781wantsRoundedCorners 291782 ^Preferences roundedWindowCorners 291783 and: [(owner isSystemWindow) not]! ! 291784 291785"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 291786 291787ProjectViewMorph class 291788 instanceVariableNames: ''! 291789 291790!ProjectViewMorph class methodsFor: 'filein/out' stamp: 'sd 2/1/2002 22:01'! 291791services 291792 291793 ^ Array with: self serviceOpenProjectFromFile 291794 291795 ! ! 291796 291797 291798!ProjectViewMorph class methodsFor: 'initialization' stamp: 'GabrielOmarCotelli 6/4/2009 20:34'! 291799initialize 291800 291801 FileServices registerFileReader: self! ! 291802 291803 291804!ProjectViewMorph class methodsFor: 'initialize-release' stamp: 'GabrielOmarCotelli 6/4/2009 20:34'! 291805unload 291806 291807 FileServices unregisterFileReader: self ! ! 291808 291809 291810!ProjectViewMorph class methodsFor: 'instance creation' stamp: 'jm 5/14/1998 16:19'! 291811on: aProject 291812 291813 ^ self new on: aProject 291814! ! 291815 291816 291817!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 10/6/2000 15:46'! 291818newMorphicProject 291819 "Return an instance of me on a new Morphic project (in a SystemWindow)." 291820 291821 self flag: #bob. "No senders???" 291822 self halt. 291823 291824 "^self newMorphicProjectOn: nil"! ! 291825 291826!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 10/6/2000 15:45'! 291827newMorphicProjectOn: aPasteUpOrNil 291828 "Return an instance of me on a new Morphic project (in a SystemWindow)." 291829 291830 self flag: #bob. "No senders???" 291831 self halt. 291832 291833 "^self newProjectViewInAWindowFor: (Project newMorphicOn: aPasteUpOrNil)" 291834! ! 291835 291836!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'ar 8/31/2004 20:53'! 291837newProjectViewInAWindowFor: aProject 291838 "Return an instance of me on a new Morphic project (in a SystemWindow)." 291839 291840 | window proj | 291841 proj := self on: aProject. 291842 window := (SystemWindow labelled: aProject name) model: aProject. 291843 window 291844 addMorph: proj 291845 frame: (0@0 corner: 1.0@1.0). 291846 proj borderWidth: 0. 291847 ^ window 291848! ! 291849 291850 291851!ProjectViewMorph class methodsFor: 'scripting' stamp: 'dgd 8/26/2004 12:11'! 291852defaultNameStemForInstances 291853 ^ 'ProjectView'! ! 291854Notification subclass: #ProjectViewOpenNotification 291855 instanceVariableNames: '' 291856 classVariableNames: '' 291857 poolDictionaries: '' 291858 category: 'Exceptions-Kernel'! 291859!ProjectViewOpenNotification commentStamp: '<historical>' prior: 0! 291860ProjectViewOpenNotification is signalled to determine if a ProjectViewMorph is needed for a newly created project. The default answer is yes.! 291861 291862 291863!ProjectViewOpenNotification methodsFor: 'as yet unclassified' stamp: 'RAA 7/4/2000 16:24'! 291864defaultAction 291865 291866 self resume: true! ! 291867LayoutPolicy subclass: #ProportionalLayout 291868 instanceVariableNames: '' 291869 classVariableNames: '' 291870 poolDictionaries: '' 291871 category: 'Morphic-Layouts'! 291872!ProportionalLayout commentStamp: '<historical>' prior: 0! 291873I represent a layout that places all children of some morph in their given LayoutFrame.! 291874 291875 291876!ProportionalLayout methodsFor: 'layout' stamp: 'ar 10/29/2000 01:24'! 291877layout: aMorph in: newBounds 291878 "Compute the layout for the given morph based on the new bounds" 291879 aMorph submorphsDo:[:m| m layoutProportionallyIn: newBounds].! ! 291880 291881!ProportionalLayout methodsFor: 'layout' stamp: 'ar 2/5/2002 20:05'! 291882minExtentOf: aMorph in: newBounds 291883 "Return the minimal size aMorph's children would require given the new bounds" 291884 | min extent frame | 291885 min := 0@0. 291886 aMorph submorphsDo:[:m| 291887 "Map the minimal size of the child through the layout frame. 291888 Note: This is done here and not in the child because its specific 291889 for proportional layouts. Perhaps we'll generalize this for table 291890 layouts but I'm not sure how and when." 291891 extent := m minExtent. 291892 frame := m layoutFrame. 291893 frame ifNotNil:[extent := frame minExtentFrom: extent]. 291894 min := min max: extent]. 291895 ^min! ! 291896 291897 291898!ProportionalLayout methodsFor: 'testing' stamp: 'ar 10/29/2000 01:29'! 291899isProportionalLayout 291900 ^true! ! 291901AbstractResizerMorph subclass: #ProportionalSplitterMorph 291902 instanceVariableNames: 'leftOrTop rightOrBottom splitsTopAndBottom oldColor traceMorph' 291903 classVariableNames: '' 291904 poolDictionaries: '' 291905 category: 'Morphic-Windows'! 291906!ProportionalSplitterMorph commentStamp: 'jmv 1/29/2006 17:16' prior: 0! 291907I am the morph the user grabs to adjust pane splitters.! 291908 291909 291910!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/26/2007 10:22'! 291911adoptPaneColor: paneColor 291912 "Change our color too." 291913 291914 super adoptPaneColor: paneColor. 291915 self fillStyle: self normalFillStyle! ! 291916 291917!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2007 10:46'! 291918hasLeftOrTop: aMorph 291919 "Answer whether the reciver has the given morph 291920 as one of of its left or top morphs." 291921 291922 ^leftOrTop includes: aMorph! ! 291923 291924!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2007 10:46'! 291925hasRightOrBottom: aMorph 291926 "Answer whether the reciver has the given morph 291927 as one of of its right or bottom morphs." 291928 291929 ^rightOrBottom includes: aMorph! ! 291930 291931!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2007 10:40'! 291932hideLeftOrTop 291933 "Hide the receiver and all left or top morphs." 291934 291935 self hide. 291936 leftOrTop do: [:m | m hide]! ! 291937 291938!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2007 10:46'! 291939hideRightOrBottom 291940 "Hide the receiver and all right or bottom morphs." 291941 291942 self hide. 291943 rightOrBottom do: [:m | m hide]! ! 291944 291945!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 291946normalFillStyle 291947 "Return the normal fillStyle of the receiver." 291948 291949 ^self theme splitterNormalFillStyleFor: self! ! 291950 291951!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 11/10/2006 11:36'! 291952noteNewOwner: o 291953 "Update the fill style." 291954 291955 super noteNewOwner: o. 291956 WorldState addDeferredUIMessage: [self adoptPaneColor: self paneColor]! ! 291957 291958!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/14/2007 13:32'! 291959overlapsHorizontal: aSplitter 291960 "Answer whether the receiver overlaps the given spiltter 291961 in the horizontal plane." 291962 291963 ^aSplitter left <= self right and: [aSplitter right >= self left]! ! 291964 291965!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/14/2007 13:32'! 291966overlapsVertical: aSplitter 291967 "Answer whether the receiver overlaps the given spiltter 291968 in the vertical plane." 291969 291970 ^aSplitter top <= self bottom and: [aSplitter bottom >= self top]! ! 291971 291972!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 291973pressedFillStyle 291974 "Return the pressed fillStyle of the receiver." 291975 291976 ^self theme splitterPressedFillStyleFor: self! ! 291977 291978!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/26/2007 10:21'! 291979setGrabbedColor 291980 "Set the color of the receiver when it is grabbed." 291981 291982 self fillStyle: self pressedFillStyle! ! 291983 291984!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:32'! 291985shouldDraw 291986 "Answer whether the resizer should be drawn." 291987 291988 ^super shouldDraw or: [self class showSplitterHandles]! ! 291989 291990!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:36'! 291991shouldInvalidateOnMouseTransition 291992 "Answer whether the resizer should be invalidated 291993 when the mouse enters or leaves." 291994 291995 ^self class showSplitterHandles! ! 291996 291997!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2007 10:40'! 291998showLeftOrTop 291999 "Show the receiver and all left or top morphs." 292000 292001 self show. 292002 leftOrTop do: [:m | m show]! ! 292003 292004!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2007 10:47'! 292005showRightOrBottom 292006 "Show the receiver and all right or bottom morphs." 292007 292008 self show. 292009 rightOrBottom do: [:m | m show]! ! 292010 292011 292012!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/22/2007 14:29'! 292013bottomBoundary 292014 "Answer the bottom boundary position by calculating the minimum 292015 of the minimum heights of the bottom morphs." 292016 292017 |morphs| 292018 morphs := rightOrBottom reject: [:m | 292019 m layoutFrame bottomFraction ~= 1 and: [ 292020 m layoutFrame topFraction = m layoutFrame bottomFraction]]. 292021 morphs ifEmpty: [ 292022 ^(self splitterBelow 292023 ifNil: [self containingWindow panelRect bottom] 292024 ifNotNil: [self splitterBelow top]) - 25]. 292025 ^(morphs collect: [:m | 292026 m bottom - m minExtent y - 292027 (m layoutFrame topOffset ifNil: [0]) + 292028 (self layoutFrame bottomOffset ifNil: [0])]) min - self class splitterWidth! ! 292029 292030!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/20/2009 11:47'! 292031drawOn: aCanvas 292032 292033 | dotBounds size alphaCanvas dotSize | 292034 self shouldDraw ifFalse: [^self]. 292035 super drawOn: aCanvas. 292036 self class showSplitterHandles ifTrue: [ 292037 size := self splitsTopAndBottom 292038 ifTrue: [self handleSize transposed] 292039 ifFalse: [self handleSize]. 292040 dotSize := self splitsTopAndBottom 292041 ifTrue: [6 @ self class splitterWidth] 292042 ifFalse: [self class splitterWidth @ 6]. 292043 alphaCanvas := aCanvas asAlphaBlendingCanvas: 0.7. 292044 dotBounds := Rectangle center: self bounds center extent: size. 292045 alphaCanvas fillRectangle: dotBounds color: self handleColor. 292046 dotBounds := Rectangle center: self bounds center extent: dotSize. 292047 alphaCanvas fillRectangle: dotBounds color: self dotColor]! ! 292048 292049!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/25/2008 23:03'! 292050leftBoundary 292051 "Answer the left boundary position by calculating the minimum 292052 of the minimum widths of the left morphs." 292053 292054 |morphs| 292055 morphs := leftOrTop reject: [:m | 292056 m layoutFrame leftFraction ~= 0 and: [ 292057 m layoutFrame leftFraction = m layoutFrame rightFraction]]. 292058 morphs ifEmpty: [ 292059 ^(self splitterLeft 292060 ifNil: [self containingWindow panelRect left] 292061 ifNotNilDo: [:s | s left]) + 25]. 292062 ^(morphs collect: [:m | 292063 m left + m minExtent x + 292064 (self layoutFrame leftOffset ifNil: [0]) - 292065 (m layoutFrame rightOffset ifNil: [0])]) max! ! 292066 292067!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/15/2007 11:27'! 292068mouseDown: anEvent 292069 "A mouse button has been pressed. 292070 Update the color for feedback and store the mouse 292071 position and relative offset to the receiver." 292072 292073 |cp| 292074 (self class showSplitterHandles not 292075 and: [self bounds containsPoint: anEvent cursorPoint]) 292076 ifTrue: [oldColor := self color. 292077 self setGrabbedColor]. 292078 cp := anEvent cursorPoint. 292079 lastMouse := {cp. cp - self position}! ! 292080 292081!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/19/2008 15:31'! 292082mouseUp: anEvent 292083 "Change the cursor back to normal if necessary and change the color back to normal." 292084 292085 (self bounds containsPoint: anEvent cursorPoint) 292086 ifFalse: [anEvent hand showTemporaryCursor: nil]. 292087 self class fastSplitterResize 292088 ifTrue: [self updateFromEvent: anEvent]. 292089 traceMorph ifNotNil: [traceMorph delete. traceMorph := nil]. 292090 self adoptPaneColor: self paneColor. 292091 self triggerEvent: #mouseUp! ! 292092 292093!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/22/2007 14:29'! 292094rightBoundary 292095 "Answer the right boundary position by calculating the minimum 292096 of the minimum widths of the right morphs." 292097 292098 |morphs| 292099 morphs := rightOrBottom reject: [:m | 292100 m layoutFrame rightFraction ~= 1 and: [ 292101 m layoutFrame leftFraction = m layoutFrame rightFraction]]. 292102 morphs ifEmpty: [ 292103 ^(self splitterRight 292104 ifNil: [self containingWindow panelRect right] 292105 ifNotNilDo: [:s | s left]) + 25]. 292106 ^(morphs collect: [:m | 292107 m right - m minExtent x - 292108 (m layoutFrame leftOffset ifNil: [0]) + 292109 (self layoutFrame rightOffset ifNil: [0])]) min - self class splitterWidth! ! 292110 292111!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/17/2008 11:24'! 292112splitterAbove 292113 "Answer the splitter above the receiver that overlaps in its horizontal range." 292114 292115 |splitters| 292116 splitters := ((self siblingSplitters select: [:each | 292117 each top > self top and: [self overlapsHorizontal: each]]) asSortedCollection: [:a :b | a top < b top]). 292118 ^splitters ifNotEmpty: [splitters first]! ! 292119 292120!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/17/2008 11:25'! 292121splitterBelow 292122 "Answer the splitter below the receiver that overlaps in its horizontal range." 292123 292124 |splitters| 292125 splitters := ((self siblingSplitters select: [:each | 292126 each top < self top and: [self overlapsHorizontal: each]]) asSortedCollection: [:a :b | a top > b top]). 292127 ^splitters ifNotEmpty: [splitters first]! ! 292128 292129!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/17/2008 11:26'! 292130splitterLeft 292131 "Answer the splitter to the left of the receiver that overlaps in its vertical range." 292132 292133 |splitters| 292134 splitters := ((self siblingSplitters select: [:each | 292135 each left < self left and: [self overlapsVertical: each]]) asSortedCollection: [:a :b | a left > b left]). 292136 ^splitters ifNotEmpty: [splitters first]! ! 292137 292138!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/17/2008 11:27'! 292139splitterRight 292140 "Answer the splitter to the right of the receiver that overlaps in its vertical range." 292141 292142 |splitters| 292143 splitters := ((self siblingSplitters select: [:each | 292144 each left > self left and: [self overlapsVertical: each]]) asSortedCollection: [:a :b | a left < b left]). 292145 ^splitters ifNotEmpty: [splitters first]! ! 292146 292147!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2009 14:12'! 292148topBoundary 292149 "Answer the top boundary position by calculating the minimum 292150 of the minimum heights of the top morphs." 292151 292152 |morphs| 292153 morphs := leftOrTop reject: [:m | 292154 m layoutFrame topFraction ~= 0 and: [ 292155 m layoutFrame topFraction = m layoutFrame bottomFraction]]. 292156 morphs ifEmpty: [ 292157 ^(self splitterAbove 292158 ifNil: [self containingWindow panelRect top] 292159 ifNotNilDo: [:s | s top]) + 25]. 292160 ^(morphs collect: [:m | 292161 m top + m minExtent y + 292162 (self layoutFrame topOffset ifNil: [0]) - 292163 (m layoutFrame bottomOffset ifNil: [0])]) max! ! 292164 292165!ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/15/2007 12:39'! 292166updateFromEvent: anEvent 292167 "Update the splitter and attached morph positions from the mouse event. 292168 Take into account the mouse down offset." 292169 292170 |pNew pOld delta firstRight firstBottom secondLeft secondTop selfTop selfBottom selfLeft selfRight| 292171 pNew := anEvent cursorPoint - lastMouse second. 292172 pOld := lastMouse first - lastMouse second. 292173 delta := splitsTopAndBottom 292174 ifTrue: [0 @ ((self normalizedY: pNew y) - pOld y)] 292175 ifFalse: [(self normalizedX: pNew x) - pOld x @ 0]. 292176 lastMouse at: 1 put: (splitsTopAndBottom 292177 ifTrue: [pNew x @ (self normalizedY: pNew y) + lastMouse second] 292178 ifFalse: [(self normalizedX: pNew x) @ pNew y + lastMouse second]). 292179 leftOrTop do: [:each | 292180 firstRight := each layoutFrame rightOffset 292181 ifNil: [0]. 292182 firstBottom := each layoutFrame bottomOffset 292183 ifNil: [0]. 292184 each layoutFrame rightOffset: firstRight + delta x. 292185 each layoutFrame bottomOffset: firstBottom + delta y. 292186 (each layoutFrame leftFraction = each layoutFrame rightFraction and: [ 292187 each layoutFrame leftFraction ~= 0]) "manual splitter" 292188 ifTrue: [each layoutFrame leftOffset: (each layoutFrame leftOffset ifNil: [0]) + delta x]. 292189 (each layoutFrame topFraction = each layoutFrame bottomFraction and: [ 292190 each layoutFrame topFraction ~= 0]) "manual splitter" 292191 ifTrue: [each layoutFrame topOffset: (each layoutFrame topOffset ifNil: [0]) + delta y]]. 292192 rightOrBottom do: [:each | 292193 secondLeft := each layoutFrame leftOffset 292194 ifNil: [0]. 292195 secondTop := each layoutFrame topOffset 292196 ifNil: [0]. 292197 each layoutFrame leftOffset: secondLeft + delta x. 292198 each layoutFrame topOffset: secondTop + delta y. 292199 (each layoutFrame leftFraction = each layoutFrame rightFraction and: [ 292200 each layoutFrame rightFraction ~= 1]) "manual splitter" 292201 ifTrue: [each layoutFrame rightOffset: (each layoutFrame rightOffset ifNil: [0]) + delta x]. 292202 (each layoutFrame topFraction = each layoutFrame bottomFraction and: [ 292203 each layoutFrame bottomFraction ~= 1]) "manual splitter" 292204 ifTrue: [each layoutFrame bottomOffset: (each layoutFrame bottomOffset ifNil: [0]) + delta y]]. 292205 selfTop := self layoutFrame topOffset ifNil: [0]. 292206 selfBottom := self layoutFrame bottomOffset ifNil: [0]. 292207 selfLeft := self layoutFrame leftOffset ifNil: [0]. 292208 selfRight := self layoutFrame rightOffset ifNil: [0]. 292209 self layoutFrame topOffset: selfTop + delta y. 292210 self layoutFrame bottomOffset: selfBottom + delta y. 292211 self layoutFrame leftOffset: selfLeft + delta x. 292212 self layoutFrame rightOffset: selfRight + delta x. 292213 self owner layoutChanged! ! 292214 292215 292216!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'bvs 3/24/2004 16:57'! 292217addLeftOrTop: aMorph 292218 292219 leftOrTop add: aMorph! ! 292220 292221!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'bvs 3/24/2004 16:55'! 292222addRightOrBottom: aMorph 292223 292224 rightOrBottom add: aMorph. 292225 292226 ! ! 292227 292228!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'bvs 3/24/2004 16:39'! 292229beSplitsTopAndBottom 292230 292231 splitsTopAndBottom := true. 292232 ! ! 292233 292234!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'apl 7/8/2005 13:38'! 292235getOldColor 292236 ^ oldColor ifNil: [Color transparent]! ! 292237 292238!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/4/2005 10:50'! 292239handleRect 292240 292241 ^ Rectangle 292242 center: self bounds center 292243 extent: (self splitsTopAndBottom 292244 ifTrue: [self handleSize transposed] 292245 ifFalse: [self handleSize])! ! 292246 292247!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 8/6/2005 23:59'! 292248handleSize 292249 292250 ^ self class splitterWidth @ 30! ! 292251 292252!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:46'! 292253initialize 292254 292255 super initialize. 292256 292257 self hResizing: #spaceFill. 292258 self vResizing: #spaceFill. 292259 splitsTopAndBottom := false. 292260 292261 leftOrTop := OrderedCollection new. 292262 rightOrBottom := OrderedCollection new! ! 292263 292264!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/9/2005 17:44'! 292265isCursorOverHandle 292266 ^ self class showSplitterHandles not or: [self handleRect containsPoint: ActiveHand cursorPoint]! ! 292267 292268!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 23:11'! 292269mouseMove: anEvent 292270 anEvent hand temporaryCursor 292271 ifNil: [^ self]. 292272 self class fastSplitterResize 292273 ifFalse: [self updateFromEvent: anEvent] 292274 ifTrue: [traceMorph 292275 ifNil: [traceMorph := Morph newBounds: self bounds. 292276 traceMorph borderColor: Color lightGray. 292277 traceMorph borderWidth: 1. 292278 self owner addMorph: traceMorph]. 292279 splitsTopAndBottom 292280 ifTrue: [traceMorph position: traceMorph position x @ (self normalizedY: anEvent cursorPoint y)] 292281 ifFalse: [traceMorph position: (self normalizedX: anEvent cursorPoint x) @ traceMorph position y]]! ! 292282 292283!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 22:45'! 292284normalizedX: x 292285 292286 ^ (x max: self leftBoundary) min: self rightBoundary! ! 292287 292288!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 23:12'! 292289normalizedY: y 292290 292291 ^ (y max: self topBoundary) min: self bottomBoundary! ! 292292 292293!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'bvs 3/24/2004 16:39'! 292294resizeCursor 292295 292296 ^ Cursor resizeForEdge: (splitsTopAndBottom 292297 ifTrue: [#top] 292298 ifFalse: [#left]) 292299 ! ! 292300 292301!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'jrp 3/21/2006 20:20'! 292302siblingSplitters 292303 292304 ^ self owner submorphsSatisfying: [:each | (each isKindOf: self class) and: [self splitsTopAndBottom = each splitsTopAndBottom] and: [each ~= self]]! ! 292305 292306!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'bvs 3/24/2004 17:25'! 292307splitsTopAndBottom 292308 292309 ^ splitsTopAndBottom! ! 292310 292311!ProportionalSplitterMorph methodsFor: 'as yet unclassified' stamp: 'bvs 3/24/2004 16:39'! 292312wantsEveryMouseMove 292313 292314 ^ true! ! 292315 292316"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 292317 292318ProportionalSplitterMorph class 292319 instanceVariableNames: ''! 292320 292321!ProportionalSplitterMorph class methodsFor: 'as yet unclassified' stamp: 'jrp 8/6/2005 23:59'! 292322splitterWidth 292323 292324 ^ 4! ! 292325 292326 292327!ProportionalSplitterMorph class methodsFor: 'preferences' stamp: 'md 2/24/2006 22:47'! 292328fastSplitterResize 292329 292330 ^ Preferences fastDragWindowForMorphic.! ! 292331 292332!ProportionalSplitterMorph class methodsFor: 'preferences' stamp: 'jrp 7/9/2005 17:43'! 292333showSplitterHandles 292334 292335 ^ Preferences valueOfPreference: #showSplitterHandles ifAbsent: [true]! ! 292336ProtoObject subclass: #ProtoObject 292337 instanceVariableNames: '' 292338 classVariableNames: '' 292339 poolDictionaries: '' 292340 category: 'Kernel-Objects'. 292341ProtoObject superclass: nil! 292342!ProtoObject commentStamp: '<historical>' prior: 0! 292343ProtoObject establishes minimal behavior required of any object in Squeak, even objects that should balk at normal object behavior. Generally these are proxy objects designed to read themselves in from the disk, or to perform some wrapper behavior, before responding to a message. Current examples are ObjectOut and ImageSegmentRootStub, and one could argue that ObjectTracer should also inherit from this class. 292344 292345ProtoObject has no instance variables, nor should any be added.! 292346 292347 292348!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! 292349tryNamedPrimitive 292350 "This method is a template that the Smalltalk simulator uses to 292351 execute primitives. See Object documentation whatIsAPrimitive." 292352 <primitive:'' module:''> 292353 ^ ContextPart primitiveFailToken! ! 292354 292355!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! 292356tryNamedPrimitive: arg1 292357 "This method is a template that the Smalltalk simulator uses to 292358 execute primitives. See Object documentation whatIsAPrimitive." 292359 <primitive:'' module:''> 292360 ^ ContextPart primitiveFailToken! ! 292361 292362!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! 292363tryNamedPrimitive: arg1 with: arg2 292364 "This method is a template that the Smalltalk simulator uses to 292365 execute primitives. See Object documentation whatIsAPrimitive." 292366 <primitive:'' module:''> 292367 ^ ContextPart primitiveFailToken! ! 292368 292369!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! 292370tryNamedPrimitive: arg1 with: arg2 with: arg3 292371 "This method is a template that the Smalltalk simulator uses to 292372 execute primitives. See Object documentation whatIsAPrimitive." 292373 <primitive:'' module:''> 292374 ^ ContextPart primitiveFailToken! ! 292375 292376!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! 292377tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 292378 "This method is a template that the Smalltalk simulator uses to 292379 execute primitives. See Object documentation whatIsAPrimitive." 292380 <primitive:'' module:''> 292381 ^ ContextPart primitiveFailToken! ! 292382 292383!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! 292384tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 292385 "This method is a template that the Smalltalk simulator uses to 292386 execute primitives. See Object documentation whatIsAPrimitive." 292387 <primitive:'' module:''> 292388 ^ ContextPart primitiveFailToken! ! 292389 292390!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! 292391tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 292392 "This method is a template that the Smalltalk simulator uses to 292393 execute primitives. See Object documentation whatIsAPrimitive." 292394 <primitive:'' module:''> 292395 ^ ContextPart primitiveFailToken! ! 292396 292397!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! 292398tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 292399 "This method is a template that the Smalltalk simulator uses to 292400 execute primitives. See Object documentation whatIsAPrimitive." 292401 <primitive:'' module:''> 292402 ^ ContextPart primitiveFailToken! ! 292403 292404!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! 292405tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 with: arg8 292406 "This method is a template that the Smalltalk simulator uses to 292407 execute primitives. See Object documentation whatIsAPrimitive." 292408 <primitive:'' module:''> 292409 ^ ContextPart primitiveFailToken! ! 292410 292411!ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! 292412tryPrimitive: primIndex withArgs: argumentArray 292413 "This method is a template that the Smalltalk simulator uses to 292414 execute primitives. See Object documentation whatIsAPrimitive." 292415 292416 <primitive: 118> 292417 ^ ContextPart primitiveFailToken! ! 292418 292419 292420!ProtoObject methodsFor: 'closure-prims' stamp: 'md 1/20/2006 16:21'! 292421privGetInstVar: index 292422 "The compiler generates this message when accessing to instance variables of objects other than the receiver. Do not override or change this unless you also modify the compiler and recompile everything" 292423 292424 <primitive: 73> 292425 ^ self basicAt: index - self class instSize! ! 292426 292427!ProtoObject methodsFor: 'closure-prims' stamp: 'md 1/20/2006 16:21'! 292428privRemoteReturnTo: contextTag 292429 "Generated from compiler to return to the home of a block. self is the value return and contextTag is the tag of the home context. Do not override or change this unless you also modify the compiler and recompile everything" 292430 292431 contextTag return: self! ! 292432 292433!ProtoObject methodsFor: 'closure-prims' stamp: 'md 1/20/2006 16:21'! 292434privSetInHolder: valueHolder 292435 "The compiler generates this message to place values in global variables. Do not override or change this unless you also modify the compiler and recompile everything" 292436 292437 valueHolder value: self. 292438 ^ self! ! 292439 292440!ProtoObject methodsFor: 'closure-prims' stamp: 'md 1/20/2006 16:21'! 292441privSetInstVar: index put: value 292442 292443 <primitive: 74> 292444 ^ self basicAt: index - self class instSize put: value! ! 292445 292446!ProtoObject methodsFor: 'closure-prims' stamp: 'md 1/20/2006 16:21'! 292447privStoreIn: object instVar: index 292448 "The compiler generates this message when assigning to instance variables of objects that have been captured by a block closure. Do not override or change this unless you also modify the compiler and recompile everything" 292449 292450 object privSetInstVar: index put: self! ! 292451 292452 292453!ProtoObject methodsFor: 'comparing' stamp: 'G.C 10/23/2008 10:13'! 292454== anObject 292455 "Primitive. Answer whether the receiver and the argument are the same 292456 object (have the same object pointer). Do not redefine the message == in 292457 any other class!! Essential. No Lookup. Do not override in any subclass. 292458 See Object documentation whatIsAPrimitive." 292459 292460 <primitive: 110> 292461 self primitiveFailed! ! 292462 292463!ProtoObject methodsFor: 'comparing' stamp: 'md 11/24/1999 19:27'! 292464identityHash 292465 "Answer a SmallInteger whose value is related to the receiver's identity. 292466 This method must not be overridden, except by SmallInteger. 292467 Primitive. Fails if the receiver is a SmallInteger. Essential. 292468 See Object documentation whatIsAPrimitive. 292469 292470 Do not override." 292471 292472 <primitive: 75> 292473 self primitiveFailed! ! 292474 292475!ProtoObject methodsFor: 'comparing' stamp: 'md 11/24/1999 19:27'! 292476~~ anObject 292477 "Answer whether the receiver and the argument are not the same object 292478 (do not have the same object pointer)." 292479 292480 self == anObject 292481 ifTrue: [^ false] 292482 ifFalse: [^ true]! ! 292483 292484 292485!ProtoObject methodsFor: 'debugging' stamp: 'sw 10/26/2000 14:29'! 292486doOnlyOnce: aBlock 292487 "If the 'one-shot' mechanism is armed, evaluate aBlock once and disarm the one-shot mechanism. To rearm the mechanism, evaluate 'self rearmOneShot' manually." 292488 292489 (Smalltalk at: #OneShotArmed ifAbsent: [true]) 292490 ifTrue: 292491 [Smalltalk at: #OneShotArmed put: false. 292492 aBlock value]! ! 292493 292494!ProtoObject methodsFor: 'debugging' stamp: 'marcus.denker 8/25/2008 09:12'! 292495flag: aSymbol 292496 292497 "Send this message, with a relevant symbol as argument, to flag a message for subsequent retrieval. For example, you might put the following line in a number of messages: 292498 self flag: #returnHereUrgently 292499 Then, to retrieve all such messages, browse all senders of #returnHereUrgently."! ! 292500 292501!ProtoObject methodsFor: 'debugging' stamp: 'sw 10/26/2000 14:27'! 292502rearmOneShot 292503 "Call this manually to arm the one-shot mechanism; use the mechanism in code by calling 292504 self doOnlyOnce: <a block>" 292505 292506 Smalltalk at: #OneShotArmed put: true 292507 292508 "self rearmOneShot" 292509! ! 292510 292511!ProtoObject methodsFor: 'debugging' stamp: 'eem 4/8/2009 19:10'! 292512withArgs: argArray executeMethod: compiledMethod 292513 "Execute compiledMethod against the receiver and args in argArray" 292514 292515 <primitive: 188> 292516 self primitiveFailed! ! 292517 292518 292519!ProtoObject methodsFor: 'initialize-release' stamp: 'md 11/18/2003 10:33'! 292520initialize 292521 "Subclasses should redefine this method to perform initializations on instance creation"! ! 292522 292523 292524!ProtoObject methodsFor: 'method execution' stamp: 'marcus.denker 10/3/2008 16:46'! 292525executeMethod: compiledMethod 292526 "Execute compiledMethod against the receiver with no args" 292527 292528 <primitive: 189> 292529 ^ self withArgs: #() executeMethod: compiledMethod! ! 292530 292531!ProtoObject methodsFor: 'method execution' stamp: 'marcus.denker 10/3/2008 16:46'! 292532with: arg1 executeMethod: compiledMethod 292533 "Execute compiledMethod against the receiver and arg1" 292534 292535 <primitive: 189> 292536 ^ self withArgs: {arg1} executeMethod: compiledMethod! ! 292537 292538!ProtoObject methodsFor: 'method execution' stamp: 'marcus.denker 10/3/2008 16:46'! 292539with: arg1 with: arg2 executeMethod: compiledMethod 292540 "Execute compiledMethod against the receiver and arg1 & arg2" 292541 292542 <primitive: 189> 292543 ^ self withArgs: {arg1. arg2} executeMethod: compiledMethod! ! 292544 292545!ProtoObject methodsFor: 'method execution' stamp: 'marcus.denker 10/3/2008 16:46'! 292546with: arg1 with: arg2 with: arg3 executeMethod: compiledMethod 292547 "Execute compiledMethod against the receiver and arg1, arg2, & arg3" 292548 292549 <primitive: 189> 292550 ^ self withArgs: {arg1. arg2. arg3} executeMethod: compiledMethod! ! 292551 292552!ProtoObject methodsFor: 'method execution' stamp: 'marcus.denker 10/3/2008 16:46'! 292553with: arg1 with: arg2 with: arg3 with: arg4 executeMethod: compiledMethod 292554 "Execute compiledMethod against the receiver and arg1, arg2, arg3, & arg4" 292555 292556 <primitive: 189> 292557 ^ self withArgs: {arg1. arg2. arg3. arg4} executeMethod: compiledMethod! ! 292558 292559 292560!ProtoObject methodsFor: 'objects from disk' stamp: 'md 11/24/1999 20:03'! 292561rehash 292562 "Do nothing. Here so sending this to a Set does not have to do a time consuming respondsTo:"! ! 292563 292564 292565!ProtoObject methodsFor: 'system primitives' stamp: 'md 11/24/1999 19:30'! 292566become: otherObject 292567 "Primitive. Swap the object pointers of the receiver and the argument. 292568 All variables in the entire system that used to point to the 292569 receiver now point to the argument, and vice-versa. 292570 Fails if either object is a SmallInteger" 292571 292572 (Array with: self) 292573 elementsExchangeIdentityWith: 292574 (Array with: otherObject)! ! 292575 292576!ProtoObject methodsFor: 'system primitives' stamp: 'ajh 1/13/2002 17:02'! 292577cannotInterpret: aMessage 292578 "Handle the fact that there was an attempt to send the given message to the receiver but a null methodDictionary was encountered while looking up the message selector. Hopefully this is the result of encountering a stub for a swapped out class which induces this exception on purpose." 292579 292580"If this is the result of encountering a swap-out stub, then simulating the lookup in Smalltalk should suffice to install the class properly, and the message may be resent." 292581 292582 (self class lookupSelector: aMessage selector) == nil ifFalse: 292583 ["Simulated lookup succeeded -- resend the message." 292584 ^ aMessage sentTo: self]. 292585 292586 "Could not recover by simulated lookup -- it's an error" 292587 Error signal: 'MethodDictionary fault'. 292588 292589 "Try again in case an error handler fixed things" 292590 ^ aMessage sentTo: self! ! 292591 292592!ProtoObject methodsFor: 'system primitives' stamp: 'ajh 10/9/2001 17:20'! 292593doesNotUnderstand: aMessage 292594 292595 ^ MessageNotUnderstood new 292596 message: aMessage; 292597 receiver: self; 292598 signal! ! 292599 292600!ProtoObject methodsFor: 'system primitives' stamp: 'md 11/24/1999 19:58'! 292601nextInstance 292602 "Primitive. Answer the next instance after the receiver in the 292603 enumeration of all instances of this class. Fails if all instances have been 292604 enumerated. Essential. See Object documentation whatIsAPrimitive." 292605 292606 <primitive: 78> 292607 ^nil! ! 292608 292609!ProtoObject methodsFor: 'system primitives' stamp: 'md 11/24/1999 19:58'! 292610nextObject 292611 "Primitive. Answer the next object after the receiver in the 292612 enumeration of all objects. Return 0 when all objects have been 292613 enumerated." 292614 292615 <primitive: 139> 292616 self primitiveFailed.! ! 292617 292618 292619!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:23'! 292620ifNil: nilBlock 292621 "Return self, or evaluate the block if I'm == nil (q.v.)" 292622 292623 ^ self! ! 292624 292625!ProtoObject methodsFor: 'testing' stamp: 'vb 4/15/2007 10:54'! 292626ifNil: nilBlock ifNotNil: ifNotNilBlock 292627 "Evaluate the block, unless I'm == nil (q.v.)" 292628 292629 ^ ifNotNilBlock valueWithPossibleArgs: {self}! ! 292630 292631!ProtoObject methodsFor: 'testing' stamp: 'eem 5/23/2008 11:02'! 292632ifNotNil: ifNotNilBlock 292633 "Evaluate the block, unless I'm == nil (q.v.)" 292634 292635 ^ ifNotNilBlock valueWithPossibleArgs: {self}! ! 292636 292637!ProtoObject methodsFor: 'testing' stamp: 'vb 4/15/2007 10:55'! 292638ifNotNil: ifNotNilBlock ifNil: nilBlock 292639 "If I got here, I am not nil, so evaluate the block ifNotNilBlock" 292640 292641 ^ ifNotNilBlock valueWithPossibleArgs: {self}! ! 292642 292643!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:57'! 292644isInMemory 292645 "All normal objects are." 292646 ^ true! ! 292647 292648!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:26'! 292649isNil 292650 "Coerces nil to true and everything else to false." 292651 292652 ^false! ! 292653 292654!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:58'! 292655pointsTo: anObject 292656 "This method returns true if self contains a pointer to anObject, 292657 and returns false otherwise" 292658 <primitive: 132> 292659 1 to: self class instSize do: 292660 [:i | (self instVarAt: i) == anObject ifTrue: [^ true]]. 292661 1 to: self basicSize do: 292662 [:i | (self basicAt: i) == anObject ifTrue: [^ true]]. 292663 ^ false! ! 292664 292665"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 292666 292667ProtoObject class 292668 instanceVariableNames: ''! 292669 292670!ProtoObject class methodsFor: 'as yet unclassified' stamp: 'sw 5/5/2000 09:31'! 292671initializedInstance 292672 ^ nil! ! 292673ClassTestCase subclass: #ProtoObjectTest 292674 instanceVariableNames: '' 292675 classVariableNames: '' 292676 poolDictionaries: '' 292677 category: 'KernelTests-Objects'! 292678!ProtoObjectTest commentStamp: '<historical>' prior: 0! 292679This is the unit test for the class ProtoObject. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 292680 - http://www.c2.com/cgi/wiki?UnitTest 292681 - http://minnow.cc.gatech.edu/squeak/1547 292682 - the sunit class category! 292683 292684 292685!ProtoObjectTest methodsFor: 'testing - testing' stamp: 'sd 6/5/2005 09:05'! 292686testFlag 292687 292688 self shouldnt: [ProtoObject new flag: #hallo] raise: Error.! ! 292689 292690!ProtoObjectTest methodsFor: 'testing - testing' stamp: 'sd 6/5/2005 09:05'! 292691testIsNil 292692 292693 self assert: (ProtoObject new isNil = false).! ! 292694MessageSet subclass: #ProtocolBrowser 292695 instanceVariableNames: 'selectedClass selectedSelector' 292696 classVariableNames: 'TextMenu' 292697 poolDictionaries: '' 292698 category: 'Tools-Browser'! 292699!ProtocolBrowser commentStamp: '<historical>' prior: 0! 292700An instance of ProtocolBrowser shows the methods a class understands--inherited or implemented at this level--as a "flattened" list.! 292701 292702 292703!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:33'! 292704getList 292705 "Answer the receiver's message list." 292706 ^ messageList! ! 292707 292708!ProtocolBrowser methodsFor: 'accessing' stamp: 'sw 1/28/2001 21:01'! 292709growable 292710 "Answer whether the receiver is subject to manual additions and deletions" 292711 292712 ^ false! ! 292713 292714!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:33'! 292715list 292716 "Answer the receiver's message list." 292717 ^ messageList! ! 292718 292719!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'! 292720selector 292721 "Answer the receiver's selected selector." 292722 ^ selectedSelector! ! 292723 292724!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'! 292725selector: aString 292726 "Set the currently selected message selector to be aString." 292727 selectedSelector := aString. 292728 self changed: #selector! ! 292729 292730!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'! 292731setSelector: aString 292732 "Set the currently selected message selector to be aString." 292733 selectedSelector := aString! ! 292734 292735 292736!ProtocolBrowser methodsFor: 'class list' stamp: 'nk 4/10/2001 08:16'! 292737selectedClassOrMetaClass 292738 ^selectedClass! ! 292739 292740 292741!ProtocolBrowser methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! 292742initListFrom: selectorCollection highlighting: aClass 292743 "Make up the messageList with items from aClass in boldface." 292744 | defClass item | 292745 292746 messageList := OrderedCollection new. 292747 selectorCollection do: [ :selector | 292748 defClass := aClass whichClassIncludesSelector: selector. 292749 item := selector, ' (' , defClass name , ')'. 292750 defClass == aClass ifTrue: [item := item asText allBold]. 292751 messageList add: ( 292752 MethodReference new 292753 setClass: defClass 292754 methodSymbol: selector 292755 stringVersion: item 292756 ) 292757 ]. 292758 selectedClass := aClass.! ! 292759 292760!ProtocolBrowser methodsFor: 'private' stamp: 'di 7/13/97 16:26'! 292761on: aClass 292762 "Initialize with the entire protocol for the class, aClass." 292763 self initListFrom: aClass allSelectors asSortedCollection 292764 highlighting: aClass! ! 292765 292766!ProtocolBrowser methodsFor: 'private' stamp: 'di 11/26/1999 19:39'! 292767onSubProtocolOf: aClass 292768 "Initialize with the entire protocol for the class, aClass, 292769 but excluding those inherited from Object." 292770 | selectors | 292771 selectors := Set new. 292772 aClass withAllSuperclasses do: 292773 [:each | (each == Object or: [each == ProtoObject]) 292774 ifFalse: [selectors addAll: each selectors]]. 292775 self initListFrom: selectors asSortedCollection 292776 highlighting: aClass! ! 292777 292778!ProtocolBrowser methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! 292779setClassAndSelectorIn: csBlock 292780 "Decode strings of the form <selectorName> (<className> [class])" 292781 292782 | i classAndSelString selString sel | 292783 292784 sel := self selection ifNil: [^ csBlock value: nil value: nil]. 292785 (sel isKindOf: MethodReference) ifTrue: [ 292786 sel setClassAndSelectorIn: csBlock 292787 ] ifFalse: [ 292788 selString := sel asString. 292789 i := selString indexOf: $(. 292790 "Rearrange to <className> [class] <selectorName> , and use MessageSet" 292791 classAndSelString := (selString copyFrom: i + 1 to: selString size - 1) , ' ' , 292792 (selString copyFrom: 1 to: i - 1) withoutTrailingBlanks. 292793 MessageSet parse: classAndSelString toClassAndSelector: csBlock. 292794 ]. 292795! ! 292796 292797"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 292798 292799ProtocolBrowser class 292800 instanceVariableNames: ''! 292801 292802!ProtocolBrowser class methodsFor: 'instance creation' stamp: 'di 7/13/97 15:15'! 292803openFullProtocolForClass: aClass 292804 "Create and schedule a browser for the entire protocol of the class." 292805 "ProtocolBrowser openFullProtocolForClass: ProtocolBrowser." 292806 | aPBrowser label | 292807 aPBrowser := ProtocolBrowser new on: aClass. 292808 label := 'Entire protocol of: ', aClass name. 292809 self open: aPBrowser name: label! ! 292810 292811!ProtocolBrowser class methodsFor: 'instance creation' stamp: 'di 7/13/97 15:15'! 292812openSubProtocolForClass: aClass 292813 "Create and schedule a browser for the entire protocol of the class." 292814 "ProtocolBrowser openSubProtocolForClass: ProtocolBrowser." 292815 | aPBrowser label | 292816 aPBrowser := ProtocolBrowser new onSubProtocolOf: aClass. 292817 label := 'Sub-protocol of: ', aClass name. 292818 self open: aPBrowser name: label! ! 292819Object subclass: #ProtocolClient 292820 instanceVariableNames: 'stream connectInfo lastResponse pendingResponses progressObservers' 292821 classVariableNames: '' 292822 poolDictionaries: '' 292823 category: 'Network-Protocols'! 292824!ProtocolClient commentStamp: 'gk 12/13/2005 00:34' prior: 0! 292825ProtocolClient is the abstract super class for a variety of network protocol clients. 292826It uses a stream rather than the direct network access so it could also work for streams on serial connections etc. 292827 292828Structure: 292829 stream stream representing the connection to and from the server 292830 connectInfo information required for opening a connection 292831 lastResponse remembers the last response from the server. 292832 progressObservers any object understanding #show: can be registered as a progress observer (login, transfer, etc)! 292833 292834 292835!ProtocolClient methodsFor: 'accessing' stamp: 'mir 3/7/2002 14:55'! 292836logProgressToTranscript 292837 self progressObservers add: Transcript! ! 292838 292839!ProtocolClient methodsFor: 'accessing' stamp: 'mir 5/9/2003 15:52'! 292840messageText 292841 ^super messageText 292842 ifNil: [self response]! ! 292843 292844!ProtocolClient methodsFor: 'accessing' stamp: 'mir 5/9/2003 15:52'! 292845response 292846 ^self protocolInstance lastResponse! ! 292847 292848!ProtocolClient methodsFor: 'accessing' stamp: 'mir 2/22/2002 17:33'! 292849stream 292850 ^stream! ! 292851 292852!ProtocolClient methodsFor: 'accessing' stamp: 'mir 2/22/2002 17:33'! 292853stream: aStream 292854 stream := aStream! ! 292855 292856 292857!ProtocolClient methodsFor: 'actions' stamp: 'mir 3/7/2002 13:10'! 292858close 292859 self stream 292860 ifNotNil: [ 292861 self stream close. 292862 stream := nil]! ! 292863 292864!ProtocolClient methodsFor: 'actions' stamp: 'mir 3/7/2002 13:11'! 292865reopen 292866 self ensureConnection! ! 292867 292868 292869!ProtocolClient methodsFor: 'testing' stamp: 'mir 3/7/2002 14:33'! 292870isConnected 292871 ^stream notNil 292872 and: [stream isConnected]! ! 292873 292874 292875!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:35'! 292876connectionInfo 292877 connectInfo ifNil: [connectInfo := Dictionary new]. 292878 ^connectInfo! ! 292879 292880!ProtocolClient methodsFor: 'private' stamp: 'mir 2/25/2002 19:34'! 292881defaultPortNumber 292882 ^self class defaultPortNumber! ! 292883 292884!ProtocolClient methodsFor: 'private' stamp: 'md 8/14/2005 18:27'! 292885ensureConnection 292886 self isConnected 292887 ifTrue: [^self]. 292888 self stream 292889 ifNotNil: [self stream close]. 292890 292891 self stream: (SocketStream openConnectionToHost: self host port: self port). 292892 self checkResponse. 292893 self login! ! 292894 292895!ProtocolClient methodsFor: 'private' stamp: 'mir 4/7/2003 16:56'! 292896host 292897 ^self connectionInfo at: #host! ! 292898 292899!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:37'! 292900host: hostId 292901 ^self connectionInfo at: #host put: hostId! ! 292902 292903!ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 13:35'! 292904lastResponse 292905 ^lastResponse! ! 292906 292907!ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 13:35'! 292908lastResponse: aString 292909 lastResponse := aString. 292910! ! 292911 292912!ProtocolClient methodsFor: 'private' stamp: 'mir 2/25/2002 19:07'! 292913logFlag 292914 ^self class logFlag! ! 292915 292916!ProtocolClient methodsFor: 'private' stamp: 'mir 5/12/2003 18:10'! 292917logProgress: aString 292918 self progressObservers do: [:each | each show: aString]. 292919! ! 292920 292921!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:40'! 292922openOnHost: hostIP port: portNumber 292923 self host: hostIP. 292924 self port: portNumber. 292925 self ensureConnection! ! 292926 292927!ProtocolClient methodsFor: 'private' stamp: 'mir 4/7/2003 16:56'! 292928password 292929 ^self connectionInfo at: #password! ! 292930 292931!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:37'! 292932password: aString 292933 ^self connectionInfo at: #password put: aString! ! 292934 292935!ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:45'! 292936pendingResponses 292937 pendingResponses ifNil: [pendingResponses := OrderedCollection new]. 292938 ^pendingResponses! ! 292939 292940!ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:55'! 292941popResponse 292942 | pendingResponse | 292943 pendingResponse := self pendingResponses removeFirst. 292944 pendingResponses isEmpty 292945 ifTrue: [pendingResponses := nil]. 292946 ^pendingResponse! ! 292947 292948!ProtocolClient methodsFor: 'private' stamp: 'mir 4/7/2003 16:57'! 292949port 292950 ^self connectionInfo at: #port! ! 292951 292952!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:38'! 292953port: aPortNumber 292954 ^self connectionInfo at: #port put: aPortNumber! ! 292955 292956!ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 14:54'! 292957progressObservers 292958 progressObservers ifNil: [progressObservers := OrderedCollection new]. 292959 ^progressObservers! ! 292960 292961!ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:45'! 292962pushResponse: aResponse 292963 self pendingResponses add: aResponse! ! 292964 292965!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:35'! 292966resetConnectionInfo 292967 connectInfo := nil! ! 292968 292969!ProtocolClient methodsFor: 'private' stamp: 'mir 11/11/2002 16:19'! 292970user 292971 ^self connectionInfo at: #user ifAbsent: [nil]! ! 292972 292973!ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:39'! 292974user: aString 292975 ^self connectionInfo at: #user put: aString! ! 292976 292977 292978!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:52'! 292979checkForPendingError 292980 "If data is waiting, check it to catch any error reports. 292981 In case the response is not an error, push it back." 292982 292983 self stream isDataAvailable 292984 ifFalse: [^self]. 292985 self fetchNextResponse. 292986 self 292987 checkResponse: self lastResponse 292988 onError: [:response | (TelnetProtocolError protocolInstance: self) signal] 292989 onWarning: [:response | (TelnetProtocolError protocolInstance: self) signal]. 292990 "if we get here, it wasn't an error" 292991 self pushResponse: self lastResponse! ! 292992 292993!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 5/9/2003 18:47'! 292994checkResponse 292995 "Get the response from the server and check for errors." 292996 292997 self 292998 checkResponseOnError: [:response | (TelnetProtocolError protocolInstance: self) signal] 292999 onWarning: [:response | (TelnetProtocolError protocolInstance: self) signal]. 293000! ! 293001 293002!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:51'! 293003checkResponse: aResponse onError: errorBlock onWarning: warningBlock 293004 "Get the response from the server and check for errors. Invoke one of the blocks if an error or warning is encountered. See class comment for classification of error codes." 293005 293006 self responseIsError 293007 ifTrue: [errorBlock value: aResponse]. 293008 self responseIsWarning 293009 ifTrue: [warningBlock value: aResponse]. 293010! ! 293011 293012!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:54'! 293013checkResponseOnError: errorBlock onWarning: warningBlock 293014 "Get the response from the server and check for errors. Invoke one of the blocks if an error or warning is encountered. See class comment for classification of error codes." 293015 293016 self fetchPendingResponse. 293017 self checkResponse: self lastResponse onError: errorBlock onWarning: warningBlock! ! 293018 293019!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 3/7/2002 13:16'! 293020fetchNextResponse 293021 self lastResponse: self stream nextLine! ! 293022 293023!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:50'! 293024fetchPendingResponse 293025 ^pendingResponses 293026 ifNil: [self fetchNextResponse; lastResponse] 293027 ifNotNil: [self popResponse]! ! 293028 293029!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 5/12/2003 18:10'! 293030sendCommand: aString 293031 self stream sendCommand: aString. 293032! ! 293033 293034!ProtocolClient methodsFor: 'private protocol' stamp: 'mir 3/5/2002 14:31'! 293035sendStreamContents: aStream 293036 self stream sendStreamContents: aStream! ! 293037 293038 293039!ProtocolClient methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:42'! 293040responseIsError 293041 self subclassResponsibility! ! 293042 293043!ProtocolClient methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:42'! 293044responseIsWarning 293045 self subclassResponsibility! ! 293046 293047"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 293048 293049ProtocolClient class 293050 instanceVariableNames: ''! 293051 293052!ProtocolClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 16:00'! 293053defaultPortNumber 293054 self subclassResponsibility! ! 293055 293056!ProtocolClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 19:07'! 293057logFlag 293058 self subclassResponsibility! ! 293059 293060 293061!ProtocolClient class methodsFor: 'instance creation' stamp: 'mir 2/25/2002 15:59'! 293062openOnHost: hostIP port: portNumber 293063 ^self new openOnHost: hostIP port: portNumber! ! 293064 293065!ProtocolClient class methodsFor: 'instance creation' stamp: 'gk 3/2/2004 11:10'! 293066openOnHostNamed: hostName 293067 "If the hostname uses the colon syntax to express a certain portnumber 293068 we use that instead of the default port number." 293069 293070 | i | 293071 i := hostName indexOf: $:. 293072 i = 0 ifTrue: [ 293073 ^self openOnHostNamed: hostName port: self defaultPortNumber] 293074 ifFalse: [ 293075 | s p | 293076 s := hostName truncateTo: i - 1. 293077 p := (hostName copyFrom: i + 1 to: hostName size) asInteger. 293078 ^self openOnHostNamed: s port: p] 293079 ! ! 293080 293081!ProtocolClient class methodsFor: 'instance creation' stamp: 'mir 2/25/2002 15:58'! 293082openOnHostNamed: hostName port: portNumber 293083 | serverIP | 293084 serverIP := NetNameResolver addressForName: hostName timeout: 20. 293085 ^self openOnHost: serverIP port: portNumber 293086! ! 293087 293088 293089!ProtocolClient class methodsFor: 'retrieval' stamp: 'mir 3/5/2002 16:21'! 293090retrieveMIMEDocument: aURI 293091 self subclassResponsibility! ! 293092Error subclass: #ProtocolClientError 293093 instanceVariableNames: 'protocolInstance' 293094 classVariableNames: '' 293095 poolDictionaries: '' 293096 category: 'Network-Protocols'! 293097!ProtocolClientError commentStamp: 'mir 5/12/2003 18:05' prior: 0! 293098Abstract super class for protocol clients 293099 293100 protocolInstance reference to the protocol client throughing the exception. Exception handlers can access the client in order close, respond or whatever may be appropriate 293101! 293102 293103 293104!ProtocolClientError methodsFor: 'accessing' stamp: 'mir 5/16/2003 11:17'! 293105messageText 293106 ^super messageText 293107 ifNil: [self response]! ! 293108 293109!ProtocolClientError methodsFor: 'accessing' stamp: 'mir 10/30/2000 13:48'! 293110protocolInstance 293111 ^protocolInstance! ! 293112 293113!ProtocolClientError methodsFor: 'accessing' stamp: 'mir 10/30/2000 13:48'! 293114protocolInstance: aProtocolInstance 293115 protocolInstance := aProtocolInstance! ! 293116 293117!ProtocolClientError methodsFor: 'accessing' stamp: 'mir 5/16/2003 11:18'! 293118response 293119 ^self protocolInstance lastResponse! ! 293120 293121"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 293122 293123ProtocolClientError class 293124 instanceVariableNames: ''! 293125 293126!ProtocolClientError class methodsFor: 'instance creation' stamp: 'mir 10/30/2000 16:15'! 293127protocolInstance: aProtocolInstance 293128 ^self new protocolInstance: aProtocolInstance! ! 293129Object subclass: #PrototypeTester 293130 instanceVariableNames: 'prototype' 293131 classVariableNames: '' 293132 poolDictionaries: '' 293133 category: 'SUnit-Utilities'! 293134!PrototypeTester commentStamp: 'mjr 8/20/2003 13:09' prior: 0! 293135I am a simple holder of a prototype object and hand out copies when requested.! 293136 293137 293138!PrototypeTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! 293139prototype 293140 "Get a prototype" 293141 ^ prototype copy ! ! 293142 293143!PrototypeTester methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/3/2006 22:39'! 293144prototype: aPrototype 293145 "Set my prototype" 293146 prototype := aPrototype copy ! ! 293147 293148!PrototypeTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:57'! 293149result 293150 "Perform the test the default number of times" 293151 ^ self resultFor: self class defaultRuns ! ! 293152 293153"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 293154 293155PrototypeTester class 293156 instanceVariableNames: ''! 293157 293158!PrototypeTester class methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 13:08'! 293159defaultRuns 293160"the default number of times to test" 293161 ^ 50! ! 293162 293163!PrototypeTester class methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 13:08'! 293164with: aPrototype 293165 ^self new prototype:aPrototype! ! 293166Notification subclass: #ProvideAnswerNotification 293167 instanceVariableNames: '' 293168 classVariableNames: '' 293169 poolDictionaries: '' 293170 category: 'Exceptions-Kernel'! 293171CodeModelExtension subclass: #ProvidedSelectors 293172 instanceVariableNames: '' 293173 classVariableNames: '' 293174 poolDictionaries: '' 293175 category: 'Traits-Requires'! 293176 293177!ProvidedSelectors methodsFor: 'as yet unclassified' stamp: 'dvf 9/5/2005 14:20'! 293178isSelector: selector providedIn: aClass 293179 ^(self haveInterestsIn: aClass) 293180 ifFalse: [aClass classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false]] 293181 ifTrue: [(self for: aClass) includes: selector] 293182 ! ! 293183 293184!ProvidedSelectors methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 20:56'! 293185newCacheFor: aClass 293186 293187 | cache | 293188 aClass ifNil: [^IdentitySet new]. 293189 cache := self for: aClass superclass copy. 293190 aClass selectorsAndMethodsDo: [:s :m | 293191 m isProvided 293192 ifTrue: [cache add: s] 293193 ifFalse: [cache remove: s ifAbsent: []]]. 293194 ^cache! ! 293195 293196"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 293197 293198ProvidedSelectors class 293199 instanceVariableNames: ''! 293200Object subclass: #PseudoClass 293201 instanceVariableNames: 'name definition organization source metaClass' 293202 classVariableNames: '' 293203 poolDictionaries: '' 293204 category: 'System-FilePackage'! 293205!PseudoClass commentStamp: '<historical>' prior: 0! 293206I provide an inert model of a Class, used by FileContentsBrowser to manipulate filedout code. Instead of a method dictionary or selectors onto CompiledMethods, I have a dictionary ("source") of selectors onto ChangeRecords, which were, in the case of FileContentsBrowser, parsed from a source or change set file.! 293207 293208 293209!PseudoClass methodsFor: '*monticello' stamp: 'bf 7/25/2005 15:50'! 293210asClassDefinition 293211 ^ MCClassDefinition 293212 name: self name 293213 superclassName: self superclass name 293214 category: self category 293215 instVarNames: self instVarNames 293216 classVarNames: self classVarNames asSortedCollection 293217 poolDictionaryNames: self poolDictionaryNames 293218 classInstVarNames: self class instVarNames 293219 type: self typeOfClass 293220 comment: self organization classComment asString 293221 commentStamp: self organization commentStamp ! ! 293222 293223 293224!PseudoClass methodsFor: '*monticello-override' stamp: 'nk 2/18/2004 18:30'! 293225isMeta 293226 ^false! ! 293227 293228 293229!PseudoClass methodsFor: 'accessing' stamp: 'nk 4/29/2004 06:59'! 293230allCallsOn 293231 ^ (self realClass ifNil: [ ^#() ]) allCallsOn! ! 293232 293233!PseudoClass methodsFor: 'accessing' stamp: 'sma 6/16/1999 22:59'! 293234allInstVarNames 293235 ^#()! ! 293236 293237!PseudoClass methodsFor: 'accessing' stamp: 'nk 2/18/2004 18:32'! 293238allSuperclasses 293239 ^ (self realClass ifNil: [ ^#() ]) allSuperclasses! ! 293240 293241!PseudoClass methodsFor: 'accessing' stamp: 'sma 4/28/2000 17:24'! 293242compilerClass 293243 ^ (Smalltalk at: name ifAbsent: [^ Compiler]) compilerClass! ! 293244 293245!PseudoClass methodsFor: 'accessing'! 293246fullName 293247 ^self name! ! 293248 293249!PseudoClass methodsFor: 'accessing' stamp: 'nk 3/9/2004 10:24'! 293250instVarNames 293251 ^ #()! ! 293252 293253!PseudoClass methodsFor: 'accessing'! 293254name 293255 ^name! ! 293256 293257!PseudoClass methodsFor: 'accessing'! 293258name: anObject 293259 name := anObject! ! 293260 293261!PseudoClass methodsFor: 'accessing' stamp: 'NS 4/6/2004 15:46'! 293262organization 293263 organization ifNil: [organization := PseudoClassOrganizer defaultList: SortedCollection new]. 293264 293265 "Making sure that subject is set correctly. It should not be necessary." 293266 organization setSubject: self. 293267 ^ organization! ! 293268 293269!PseudoClass methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:00'! 293270prettyPrinterClass 293271 ^self class prettyPrinterClass! ! 293272 293273!PseudoClass methodsFor: 'accessing' stamp: 'nk 2/18/2004 18:32'! 293274realClass 293275 ^Smalltalk at: self name asSymbol ifAbsent: []! ! 293276 293277!PseudoClass methodsFor: 'accessing' stamp: 'NorbertHartl 6/20/2008 21:25'! 293278theMetaClass 293279 ^ self metaClass! ! 293280 293281!PseudoClass methodsFor: 'accessing' stamp: 'wod 5/19/1998 17:42'! 293282theNonMetaClass 293283 "Sent to a class or metaclass, always return the class" 293284 293285 ^self! ! 293286 293287 293288!PseudoClass methodsFor: 'categories'! 293289removeCategory: selector 293290 (self organization listAtCategoryNamed: selector) do:[:sel| 293291 self organization removeElement: sel. 293292 self sourceCode removeKey: sel. 293293 ]. 293294 self organization removeCategory: selector.! ! 293295 293296!PseudoClass methodsFor: 'categories'! 293297removedCategoryName 293298 ^'*** removed methods ***' asSymbol! ! 293299 293300!PseudoClass methodsFor: 'categories'! 293301whichCategoryIncludesSelector: aSelector 293302 "Answer the category of the argument, aSelector, in the organization of 293303 the receiver, or answer nil if the receiver does not inlcude this selector." 293304 293305 ^ self organization categoryOfElement: aSelector! ! 293306 293307 293308!PseudoClass methodsFor: 'class'! 293309classComment: aChangeRecord 293310 self organization classComment: aChangeRecord! ! 293311 293312!PseudoClass methodsFor: 'class' stamp: 'di 1/13/1999 12:00'! 293313classPool 293314 self exists ifFalse: [^ nil]. 293315 ^ self realClass classPool! ! 293316 293317!PseudoClass methodsFor: 'class' stamp: 'BJP 4/23/2001 13:50'! 293318comment 293319 | rStr | 293320 rStr := self organization commentRemoteStr. 293321 ^rStr isNil 293322 ifTrue:[self name,' has not been commented in this file'] 293323 ifFalse:[rStr string]! ! 293324 293325!PseudoClass methodsFor: 'class'! 293326comment: aString 293327 self commentString: aString.! ! 293328 293329!PseudoClass methodsFor: 'class' stamp: 'ar 2/5/2004 15:18'! 293330commentString 293331 ^self comment asString! ! 293332 293333!PseudoClass methodsFor: 'class'! 293334commentString: aString 293335 self classComment: aString asText. "Just wrap it"! ! 293336 293337!PseudoClass methodsFor: 'class' stamp: 'LC 10/8/2001 04:46'! 293338definition 293339 | link linkText defText | 293340 ^definition ifNil: 293341 [defText := Text fromString: 'There is no class definition for '. 293342 link := TextLink new. 293343 linkText := link analyze: self name with: 'Definition'. 293344 linkText := Text string: (linkText ifNil: ['']) attribute: link. 293345 defText append: linkText; append: ' in this file'].! ! 293346 293347!PseudoClass methodsFor: 'class'! 293348definition: aString 293349 definition := aString! ! 293350 293351!PseudoClass methodsFor: 'class'! 293352metaClass 293353 ^metaClass ifNil:[metaClass := PseudoMetaclass new name: (self name)].! ! 293354 293355!PseudoClass methodsFor: 'class' stamp: 'nk 2/18/2004 18:30'! 293356renameTo: aString 293357 293358 self hasDefinition ifTrue:[ 293359 self isMeta ifTrue:[ 293360 self definition: (self definition 293361 copyReplaceAll: name,' class' 293362 with: aString, ' class'). 293363 ] ifFalse:[ 293364 self definition: (self definition 293365 copyReplaceAll:'ubclass: #',name 293366 with:'ubclass: #', aString)]]. 293367 name := aString. 293368 metaClass ifNotNil:[metaClass renameTo: aString].! ! 293369 293370!PseudoClass methodsFor: 'class' stamp: 'di 1/13/1999 12:00'! 293371sharedPools 293372 self exists ifFalse: [^ nil]. 293373 ^ self realClass sharedPools! ! 293374 293375 293376!PseudoClass methodsFor: 'errors'! 293377classNotDefined 293378 ^self inform: self name,' is not defined in the system. 293379You have to define this class first.'.! ! 293380 293381 293382!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'mir 9/25/2008 15:04'! 293383fileOutDefinitionOn: aStream 293384 self hasDefinition ifFalse:[^self]. 293385 aStream nextChunkPut: self definition; cr. 293386 self hasComment ifTrue: [ 293387 aStream cr. 293388 self organization commentRemoteStr fileOutOn: aStream]! ! 293389 293390 293391!PseudoClass methodsFor: 'filein/fileout'! 293392fileIn 293393 "FileIn the receiver" 293394 self hasDefinition ifTrue:[self fileInDefinition]. 293395 self fileInMethods: self selectors. 293396 metaClass ifNotNil:[metaClass fileIn]. 293397 self needsInitialize ifTrue:[ 293398 self evaluate: self name,' initialize'. 293399 ].! ! 293400 293401!PseudoClass methodsFor: 'filein/fileout'! 293402fileInCategory: aCategory 293403 ^self fileInMethods: (self organization listAtCategoryNamed: aCategory)! ! 293404 293405!PseudoClass methodsFor: 'filein/fileout' stamp: 'ar 7/16/2005 14:06'! 293406fileInDefinition 293407 self hasDefinition ifFalse:[^self]. 293408 (self makeSureSuperClassExists: (definition copyUpTo: Character space)) ifFalse:[^self]. 293409 self hasDefinition ifTrue:[ 293410 Transcript cr; show:'Defining ', self name. 293411 self evaluate: self definition]. 293412 self exists ifFalse:[^self]. 293413 self hasComment ifTrue:[self realClass classComment: self comment].! ! 293414 293415!PseudoClass methodsFor: 'filein/fileout'! 293416fileInMethod: selector 293417 ^self fileInMethods: (Array with: selector)! ! 293418 293419!PseudoClass methodsFor: 'filein/fileout'! 293420fileInMethods 293421 ^self fileInMethods: self selectors! ! 293422 293423!PseudoClass methodsFor: 'filein/fileout'! 293424fileInMethods: aCollection 293425 "FileIn all methods with selectors taken from aCollection" 293426 | theClass cat | 293427 self exists ifFalse:[^self classNotDefined]. 293428 theClass := self realClass. 293429 aCollection do:[:sel| 293430 cat := self organization categoryOfElement: sel. 293431 cat = self removedCategoryName ifFalse:[ 293432 theClass 293433 compile: (self sourceCodeAt: sel) 293434 classified: cat 293435 withStamp: (self stampAt: sel) 293436 notifying: nil. 293437 ]. 293438 ].! ! 293439 293440!PseudoClass methodsFor: 'filein/fileout' stamp: 'PeterHugossonMiller 9/3/2009 10:52'! 293441fileOut 293442 | internalStream | 293443 internalStream := (String new: 1000) writeStream. 293444 self fileOutOn: internalStream. 293445 self needsInitialize ifTrue:[ 293446 internalStream cr; nextChunkPut: self name,' initialize'. 293447 ]. 293448 293449 FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true! ! 293450 293451!PseudoClass methodsFor: 'filein/fileout' stamp: 'PeterHugossonMiller 9/3/2009 10:52'! 293452fileOutCategory: categoryName 293453 293454 | internalStream | 293455 internalStream := (String new: 1000) writeStream. 293456 self fileOutMethods: (self organization listAtCategoryNamed: categoryName) 293457 on: internalStream. 293458 FileStream writeSourceCodeFrom: internalStream baseName: (self name, '-', categoryName) isSt: true! ! 293459 293460!PseudoClass methodsFor: 'filein/fileout' stamp: 'PeterHugossonMiller 9/3/2009 10:52'! 293461fileOutMethod: selector 293462 | internalStream | 293463 293464 internalStream := (String new: 1000) writeStream. 293465 293466 self fileOutMethods: (Array with: selector) on: internalStream. 293467 293468 FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true! ! 293469 293470!PseudoClass methodsFor: 'filein/fileout' stamp: 'ar 2/7/2004 01:04'! 293471fileOutMethods: aCollection on: aStream 293472 "FileOut all methods with selectors taken from aCollection" 293473 | cat categories | 293474 categories := Dictionary new. 293475 aCollection do:[:sel| 293476 cat := self organization categoryOfElement: sel. 293477 cat = self removedCategoryName ifFalse:[ 293478 (categories includesKey: cat) 293479 ifFalse:[categories at: cat put: Set new]. 293480 (categories at: cat) add: sel]. 293481 ]. 293482 categories associationsDo:[:assoc| 293483 cat := assoc key. 293484 assoc value do:[:sel| 293485 aStream cr. 293486 (self sourceCode at: sel) fileOutOn: aStream. 293487 ]. 293488 ].! ! 293489 293490!PseudoClass methodsFor: 'filein/fileout'! 293491fileOutMethodsOn: aStream 293492 ^self fileOutMethods: self selectors on: aStream.! ! 293493 293494!PseudoClass methodsFor: 'filein/fileout'! 293495fileOutOn: aStream 293496 "FileOut the receiver" 293497 self fileOutDefinitionOn: aStream. 293498 metaClass ifNotNil:[metaClass fileOutDefinitionOn: aStream]. 293499 self fileOutMethods: self selectors on: aStream. 293500 metaClass ifNotNil:[metaClass fileOutMethods: metaClass selectors on: aStream].! ! 293501 293502 293503!PseudoClass methodsFor: 'methods' stamp: 'sma 6/1/2000 14:54'! 293504addMethodChange: aChangeRecord 293505 | selector | 293506 selector := self parserClass new parseSelector: aChangeRecord string. 293507 self organization classify: selector under: aChangeRecord category. 293508 self sourceCodeAt: selector put: aChangeRecord! ! 293509 293510!PseudoClass methodsFor: 'methods'! 293511methodChange: aChangeRecord 293512 aChangeRecord isMetaClassChange ifTrue:[ 293513 ^self metaClass addMethodChange: aChangeRecord. 293514 ] ifFalse:[ 293515 ^self addMethodChange: aChangeRecord. 293516 ]. 293517! ! 293518 293519!PseudoClass methodsFor: 'methods'! 293520removeMethod: selector 293521 self organization removeElement: selector. 293522 self sourceCode removeKey: selector. 293523! ! 293524 293525!PseudoClass methodsFor: 'methods'! 293526removeSelector: aSelector 293527 | catName | 293528 catName := self removedCategoryName. 293529 self organization addCategory: catName before: self organization categories first. 293530 self organization classify: aSelector under: catName. 293531 self sourceCodeAt: aSelector put:'methodWasRemoved' asText.! ! 293532 293533!PseudoClass methodsFor: 'methods'! 293534selectors 293535 ^self sourceCode keys! ! 293536 293537!PseudoClass methodsFor: 'methods'! 293538sourceCode 293539 ^source ifNil:[source := Dictionary new]! ! 293540 293541!PseudoClass methodsFor: 'methods'! 293542sourceCodeAt: sel 293543 ^(self sourceCode at: sel) string! ! 293544 293545!PseudoClass methodsFor: 'methods'! 293546sourceCodeAt: sel put: object 293547 self sourceCode at: sel put: object! ! 293548 293549!PseudoClass methodsFor: 'methods'! 293550sourceCodeTemplate 293551 ^''! ! 293552 293553!PseudoClass methodsFor: 'methods' stamp: 'sw 6/10/2003 17:31'! 293554stampAt: selector 293555 "Answer the authoring time-stamp of the change" 293556 293557 | code | 293558 ^ ((code := self sourceCode at: selector) isKindOf: ChangeRecord) 293559 ifTrue: 293560 [code stamp] 293561 ifFalse: 293562 [code string]! ! 293563 293564 293565!PseudoClass methodsFor: 'printing' stamp: 'sma 6/17/1999 00:00'! 293566literalScannedAs: scannedLiteral notifying: requestor 293567 ^ scannedLiteral! ! 293568 293569!PseudoClass methodsFor: 'printing' stamp: 'ar 2/5/2004 16:04'! 293570printOn: aStream 293571 super printOn: aStream. 293572 aStream nextPut:$(; print: name; nextPut:$)! ! 293573 293574 293575!PseudoClass methodsFor: 'removing'! 293576removeAllUnmodified 293577 | stClass | 293578 self exists ifFalse:[^self]. 293579 self removeUnmodifiedMethods: self selectors. 293580 stClass := self realClass. 293581 (self hasDefinition and:[stClass definition = self definition]) ifTrue:[definition := nil]. 293582 (self hasComment and:[stClass comment asString = self commentString]) ifTrue:[ self classComment: nil]. 293583 metaClass isNil ifFalse:[metaClass removeAllUnmodified].! ! 293584 293585!PseudoClass methodsFor: 'removing'! 293586removeUnmodifiedMethods: aCollection 293587 | stClass | 293588 self exists ifFalse:[^self]. 293589 stClass := self realClass. 293590 aCollection do:[:sel| 293591 (self sourceCodeAt: sel) = (stClass sourceCodeAt: sel ifAbsent:['']) asString ifTrue:[ 293592 self removeMethod: sel. 293593 ]. 293594 ]. 293595 self organization removeEmptyCategories.! ! 293596 293597 293598!PseudoClass methodsFor: 'testing'! 293599exists 293600 ^(Smalltalk at: self name asSymbol ifAbsent:[^false]) isKindOf: Behavior! ! 293601 293602!PseudoClass methodsFor: 'testing' stamp: 'marcus.denker 7/29/2009 15:27'! 293603hasChanges 293604 293605 self sourceCode isEmpty ifFalse:[^true]. 293606 self organization hasComment ifTrue:[^true]. 293607 definition isNil ifFalse:[^true]. 293608 metaClass isNil ifFalse:[^metaClass hasChanges]. 293609 ^false! ! 293610 293611!PseudoClass methodsFor: 'testing'! 293612hasComment 293613 ^self organization commentRemoteStr notNil! ! 293614 293615!PseudoClass methodsFor: 'testing'! 293616hasDefinition 293617 ^definition notNil! ! 293618 293619!PseudoClass methodsFor: 'testing'! 293620hasMetaclass 293621 ^metaClass notNil! ! 293622 293623!PseudoClass methodsFor: 'testing' stamp: 'al 3/1/2006 22:26'! 293624isTrait 293625 ^false! ! 293626 293627!PseudoClass methodsFor: 'testing'! 293628nameExists 293629 ^Smalltalk includesKey: self name asSymbol! ! 293630 293631!PseudoClass methodsFor: 'testing'! 293632needsInitialize 293633 ^self hasMetaclass and:[ 293634 self metaClass selectors includes: #initialize]! ! 293635 293636 293637!PseudoClass methodsFor: 'testing method dictionary' stamp: 'marcus.denker 11/10/2008 10:04'! 293638bindingOf: varName 293639 self exists ifTrue:[ 293640 (self realClass bindingOf: varName) ifNotNil:[:binding| ^binding]. 293641 ]. 293642 ^Smalltalk bindingOf: varName asSymbol! ! 293643 293644 293645!PseudoClass methodsFor: 'private' stamp: 'nk 2/18/2004 18:33'! 293646allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level 293647 ^ (self realClass ifNil: [ ^self ]) allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level! ! 293648 293649!PseudoClass methodsFor: 'private'! 293650confirmRemovalOf: aString 293651 ^self confirm:'Remove ',aString,' ?'! ! 293652 293653!PseudoClass methodsFor: 'private'! 293654evaluate: aString 293655 ^Compiler evaluate: aString for: nil logged: true! ! 293656 293657!PseudoClass methodsFor: 'private'! 293658makeSureClassExists: aString 293659 | theClass | 293660 theClass := Smalltalk at: (aString asSymbol) ifAbsent:[nil]. 293661 theClass ifNotNil:[^true]. 293662 ^self confirm: aString,' does not exist in the system. Use nil instead?'.! ! 293663 293664!PseudoClass methodsFor: 'private'! 293665makeSureSuperClassExists: aString 293666 | theClass | 293667 theClass := Smalltalk at: (aString asSymbol) ifAbsent:[nil]. 293668 theClass ifNotNil:[^true]. 293669 ^self confirm: 'The super class ',aString,' does not exist in the system. Use nil instead?'.! ! 293670 293671!PseudoClass methodsFor: 'private' stamp: 'ajh 1/21/2003 13:03'! 293672parserClass 293673 293674 ^ Compiler parserClass! ! 293675BasicClassOrganizer subclass: #PseudoClassOrganizer 293676 instanceVariableNames: '' 293677 classVariableNames: '' 293678 poolDictionaries: '' 293679 category: 'System-FilePackage'! 293680 293681!PseudoClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/6/2004 12:27'! 293682setDefaultList: aCollection 293683 super setDefaultList: aCollection. 293684 self classComment: nil.! ! 293685 293686 293687!PseudoClassOrganizer methodsFor: 'comment accessing' stamp: 'NS 4/6/2004 16:44'! 293688classComment 293689 "Answer the comment associated with the object that refers to the receiver." 293690 classComment == nil ifTrue: [^'']. 293691 ^classComment! ! 293692 293693!PseudoClassOrganizer methodsFor: 'comment accessing' stamp: 'NS 4/6/2004 16:44'! 293694classComment: aChangeRecord 293695 classComment := aChangeRecord! ! 293696ProtoObject variableSubclass: #PseudoContext 293697 instanceVariableNames: 'fixed fields never accessed from smalltalk' 293698 classVariableNames: '' 293699 poolDictionaries: '' 293700 category: 'Kernel-Methods'. 293701PseudoContext superclass: nil! 293702!PseudoContext commentStamp: '<historical>' prior: 0! 293703I represent cached context state within the virtual machine. I have the same format as normal method and block contexts, but my fields are never referenced directly from Smalltalk. Whenever a message is sent to me I will magically transform myself into a real context which will respond to all the usual messages. 293704 I rely on the fact that block and method contexts have exactly the same number of fixed fields.! 293705 293706 293707!PseudoContext methodsFor: 'system primitives' stamp: 'ikp 10/20/97 15:36'! 293708nextObject 293709 "See Object>>nextObject." 293710 293711 <primitive: 139> 293712 self primitiveFailed.! ! 293713 293714 293715!PseudoContext methodsFor: 'testing' stamp: 'ikp 9/26/97 14:45'! 293716isPseudoContext 293717 ^true! ! 293718 293719"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 293720 293721PseudoContext class 293722 instanceVariableNames: ''! 293723 293724!PseudoContext class methodsFor: 'filing out' stamp: 'ikp 9/26/97 14:45'! 293725definition 293726 "Our superclass is really nil, but this causes problems when we try to become compact 293727 after filing in for the first time. Fake the superclass as Object, and repair the situation 293728 during class initialisation." 293729 | defn | 293730 defn := super definition. 293731 ^(defn beginsWith: 'nil ') 293732 ifTrue: ['Object' , (defn copyFrom: 4 to: defn size)] 293733 ifFalse: [defn].! ! 293734 293735 293736!PseudoContext class methodsFor: 'private' stamp: 'ikp 9/26/97 14:45'! 293737contextCacheDepth 293738 "Answer the number of entries in the context cache. This requires a little insider 293739 knowledge. Not intended for casual use, which is why it's private protocol." 293740 293741 ^self contextCacheDepth: thisContext yourself! ! 293742 293743!PseudoContext class methodsFor: 'private' stamp: 'ikp 9/26/97 14:45'! 293744contextCacheDepth: b 293745 ^b isPseudoContext 293746 ifTrue: [1 + (self contextCacheDepth: b)] 293747 ifFalse: [1]! ! 293748PseudoClass subclass: #PseudoMetaclass 293749 instanceVariableNames: '' 293750 classVariableNames: '' 293751 poolDictionaries: '' 293752 category: 'System-FilePackage'! 293753 293754!PseudoMetaclass methodsFor: '*monticello-override' stamp: 'nk 2/18/2004 18:30'! 293755isMeta 293756 ^true! ! 293757 293758 293759!PseudoMetaclass methodsFor: 'accessing'! 293760fullName 293761 ^self name,' class'! ! 293762 293763!PseudoMetaclass methodsFor: 'accessing'! 293764realClass 293765 ^super realClass class! ! 293766 293767!PseudoMetaclass methodsFor: 'accessing' stamp: 'FBS 3/4/2004 14:17'! 293768theNonMetaClass 293769 "Sent to a class or metaclass, always return the class" 293770 293771 ^self realClass theNonMetaClass! ! 293772TraitsTestCase subclass: #PureBehaviorTest 293773 instanceVariableNames: '' 293774 classVariableNames: '' 293775 poolDictionaries: '' 293776 category: 'Tests-Traits'! 293777 293778!PureBehaviorTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:33'! 293779testIsAliasSelector 293780 self deny: (self t1 isAliasSelector: #m11). 293781 self deny: (self t1 isAliasSelector: #foo). 293782 293783 "directly" 293784 self assert: (self t6 isAliasSelector: #m22Alias). 293785 self deny: (self t6 isAliasSelector: #m22). 293786 293787 "indirectly" 293788 self c1 setTraitCompositionFrom: self t6. 293789 self assert: (self c1 isAliasSelector: #m22Alias). 293790 self deny: (self c1 isAliasSelector: #m22)! ! 293791 293792!PureBehaviorTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:33'! 293793testIsLocalAliasSelector 293794 self deny: (self t1 isLocalAliasSelector: #m11). 293795 self deny: (self t1 isLocalAliasSelector: #foo). 293796 293797 "directly" 293798 self assert: (self t6 isLocalAliasSelector: #m22Alias). 293799 self deny: (self t6 isLocalAliasSelector: #m22). 293800 293801 "indirectly" 293802 self c1 setTraitComposition: self t6 asTraitComposition. 293803 self deny: (self c1 isLocalAliasSelector: #m22Alias). 293804 self deny: (self c1 isLocalAliasSelector: #m22)! ! 293805 293806!PureBehaviorTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'! 293807testLocalSelectors 293808 "self run: #testLocalSelectors" 293809 293810 self assert: self t3 localSelectors size = 3. 293811 self assert: (self t3 localSelectors includesAllOf: #(#m31 #m32 #m33 )). 293812 self assert: (self t3 includesLocalSelector: #m32). 293813 self deny: (self t3 includesLocalSelector: #inexistantSelector). 293814 self assert: self t5 localSelectors size = 3. 293815 self assert: (self t5 localSelectors includes: #m51). 293816 self assert: (self t5 includesLocalSelector: #m51). 293817 self deny: (self t5 includesLocalSelector: #m11). 293818 self t5 removeSelector: #m51. 293819 self deny: (self t3 includesLocalSelector: #m51). 293820 self deny: (self t5 includesLocalSelector: #m11). 293821 self assert: self t5 localSelectors size = 2. 293822 self t5 compile: 'm52 ^self'. 293823 self assert: self t5 localSelectors size = 2. 293824 self assert: (self t5 localSelectors includes: #m52). 293825 293826 "test that propagated methods do not get in as local methods" 293827 self t2 compile: 'local2 ^self'. 293828 self deny: (self t5 includesLocalSelector: #local2). 293829 self assert: self t5 localSelectors size = 2. 293830 self assert: (self t5 localSelectors includes: #m52). 293831 self assert: self c2 localSelectors size = 2. 293832 self assert: (self c2 localSelectors includesAllOf: #(#foo #bar ))! ! 293833 293834!PureBehaviorTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'! 293835testMethodCategoryReorganization 293836 "self run: #testMethodCategory" 293837 293838 self t1 compile: 'm1' classified: 'category1'. 293839 self assert: (self t5 organization categoryOfElement: #m1) = #category1. 293840 self assert: (self c2 organization categoryOfElement: #m1) = #category1. 293841 self t1 organization 293842 classify: #m1 293843 under: #category2 293844 suppressIfDefault: true. 293845 self assert: (self t5 organization categoryOfElement: #m1) = #category2. 293846 self assert: (self c2 organization categoryOfElement: #m1) = #category2! ! 293847 293848!PureBehaviorTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'! 293849testRemovingMethods 293850 "When removing a local method, assure that the method 293851 from the trait is installed instead and that the users are 293852 updated." 293853 293854 "self run: #testRemovingMethods" 293855 293856 "Classes" 293857 293858 self c2 compile: 'm12 ^0' classified: #xxx. 293859 self assert: (self c2 includesLocalSelector: #m12). 293860 self c2 removeSelector: #m12. 293861 self deny: (self c2 includesLocalSelector: #m12). 293862 self assert: (self c2 selectors includes: #m12). 293863 293864 "Traits" 293865 self t5 compile: 'm12 ^0' classified: #xxx. 293866 self assert: self c2 new m12 = 0. 293867 self t5 removeSelector: #m12. 293868 self deny: (self t5 includesLocalSelector: #m12). 293869 self assert: (self t5 selectors includes: #m12). 293870 self assert: self c2 new m12 = 12! ! 293871 293872!PureBehaviorTest methodsFor: 'testing' stamp: 'damiencassou 1/6/2009 10:59'! 293873testTraitsAccessor 293874 "self debug: #testTraitsAccessor" 293875 self assert: self c1 traits isEmpty. 293876 self assert: (self c2 traits hasEqualElements: (Array with: self t5))! ! 293877 293878!PureBehaviorTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:33'! 293879traitOrClassOfSelector 293880 "self run: #traitOrClassOfSelector" 293881 293882 "locally defined in trait or class" 293883 293884 self assert: (self t1 traitOrClassOfSelector: #m12) = self t1. 293885 self assert: (self c1 traitOrClassOfSelector: #foo) = self c1. 293886 293887 "not locally defined - simple" 293888 self assert: (self t4 traitOrClassOfSelector: #m21) = self t2. 293889 self assert: (self c2 traitOrClassOfSelector: #m51) = self t5. 293890 293891 "not locally defined - into nested traits" 293892 self assert: (self c2 traitOrClassOfSelector: #m22) = self t2. 293893 293894 "not locally defined - aliases" 293895 self assert: (self t6 traitOrClassOfSelector: #m22Alias) = self t2. 293896 293897 "class side" 293898 self assert: (self t2 classSide traitOrClassOfSelector: #m2ClassSide:) 293899 = self t2 classSide. 293900 self assert: (self t6 classSide traitOrClassOfSelector: #m2ClassSide:) 293901 = self t2 classSide! ! 293902 293903 293904!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'al 10/13/2006 13:52'! 293905testChangeSuperclass 293906 "self run: #testChangeSuperclass" 293907 293908 "Test that when the superclass of a class is changed the non-local methods 293909 of the class sending super are recompiled to correctly store the new superclass." 293910 293911 | aC2 newSuperclass | 293912 aC2 := self c2 new. 293913 293914 "C1 is current superclass of C2" 293915 self assert: aC2 m51. 293916 self assert: self c2 superclass == self c1. 293917 self deny: (self c2 localSelectors includes: #m51). 293918 293919 "change superclass of C2 from C1 to X" 293920 newSuperclass := self createClassNamed: #X superclass: Object uses: {}. 293921 newSuperclass 293922 subclass: self c2 name 293923 uses: self c2 traitComposition 293924 instanceVariableNames: '' 293925 classVariableNames: '' 293926 poolDictionaries: '' 293927 category: self c2 category. 293928 293929 self assert: self c2 superclass == newSuperclass. 293930 293931 newSuperclass compile: 'foo ^17'. 293932 self assert: aC2 m51 = 17. 293933 self deny: (self c2 localSelectors includes: #m51). 293934 293935 self c2 compile: 'm51 ^19'. 293936 self assert: aC2 m51 = 19.! ! 293937 293938!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'al 3/26/2006 12:24'! 293939testClassesWithTraits 293940 "self debug: #testClassesWithTraits" 293941 293942 self assert: (self c1 methodDict includesKey: #foo). 293943 self assert: (self c2 methodDict includesKey: #bar). 293944 self assert: (self c2 methodDict includesKey: #m51). 293945 self assert: (self c2 methodDict includesKey: #m12). 293946 self assert: (self c2 methodDict includesKey: #m13). 293947 self assert: (self c2 methodDict includesKey: #m21). 293948 self assert: (self c2 methodDict includesKey: #m22). 293949 293950 self deny: self c1 class hasTraitComposition. 293951 self assert: self c2 class hasTraitComposition. 293952 293953 self assert: (self c2 class traitComposition size = 1). 293954 self assert: (self c2 class traitComposition includesTrait: self t5 classTrait)! ! 293955 293956!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'adrian_lienhard 2/1/2009 16:43'! 293957testMethodClass 293958 "Test sharing of compiled methods between traits and their users. Methods are installed in exactly one behavior, however, the source pointers of methods are shared (unless sources or changes have been condensed). Verify that methodClass properties are set correctly." 293959 293960 "self debug: #testMethodClass" 293961 293962 | m1 m2 | 293963 m1 := self t5 >> #m51. 293964 m2 := self c2 >> #m51. 293965 293966 self assert: m1 methodClass == self t5. 293967 self assert: m2 methodClass == self c2. 293968 293969 self deny: m1 == m2. 293970 293971 self deny: m1 sourcePointer = m2 sourcePointer.! ! 293972 293973!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:21'! 293974testOwnMethodsTakePrecedenceOverTraitsMethods 293975 "First create a trait with no subtraits and then 293976 add subtrait t1 which implements m11 as well." 293977 293978 | trait | 293979 trait := self createTraitNamed: #T 293980 uses: { }. 293981 trait compile: 'm11 ^999'. 293982 self assert: trait methodDict size = 1. 293983 self assert: (trait methodDict at: #m11) decompileString = 'm11 293984 ^ 999'. 293985 Trait 293986 named: #T 293987 uses: self t1 293988 category: self class category. 293989 self assert: trait methodDict size = 3. 293990 self assert: (trait methodDict keys includesAllOf: #(#m11 #m12 #m13 )). 293991 self assert: (trait methodDict at: #m11) decompileString = 'm11 293992 ^ 999'. 293993 self assert: (trait methodDict at: #m12) decompileString = 'm12 293994 ^ 12'! ! 293995 293996!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:32'! 293997testPropagationOfChangesInTraits 293998 | aC2 | 293999 aC2 := self c2 new. 294000 self assert: self c2 methodDict size = 9. 294001 self t1 compile: 'zork ^false'. 294002 self assert: self c2 methodDict size = 10. 294003 self deny: aC2 zork. 294004 self t1 removeSelector: #m12. 294005 self assert: self c2 methodDict size = 9. 294006 self should: [aC2 m12] raise: MessageNotUnderstood. 294007 self assert: aC2 m21 = 21. 294008 self t2 compile: 'm21 ^99'. 294009 self assert: aC2 m21 = 99! ! 294010 294011!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:33'! 294012testPropagationOfChangesInTraitsToAliasMethods 294013 | anObject | 294014 anObject := (self 294015 createClassNamed: #AliasTestClass 294016 superclass: Object 294017 uses: self t6) new. 294018 self assert: anObject m22Alias = 22. 294019 294020 "test update alias method" 294021 self t2 compile: 'm22 ^17'. 294022 self assert: anObject m22Alias = 17. 294023 294024 "removing original method should also remove alias method" 294025 self t2 removeSelector: #m22. 294026 self should: [anObject m22Alias] raise: MessageNotUnderstood! ! 294027 294028!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:21'! 294029testPropagationOfChangesInTraitsToAliasMethodsWhenOriginalMethodIsExcluded 294030 "Assert that alias method is updated although 294031 the original method is excluded from this user." 294032 294033 | anObject | 294034 anObject := (self 294035 createClassNamed: #AliasTestClass 294036 superclass: Object 294037 uses: self t1 @ { (#aliasM11 -> #m11) } - { #m11 }) new. 294038 self assert: anObject aliasM11 = 11. 294039 self deny: (anObject class methodDict includesKey: #m11). 294040 self t1 compile: 'm11 ^17'. 294041 self assert: anObject aliasM11 = 17! ! 294042 294043!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:32'! 294044testPropagationWhenTraitCompositionModifications 294045 "Test that the propagation mechanism works when 294046 setting new traitCompositions." 294047 294048 self assert: self c2 methodDict size = 9. "2 + (3+(3+2))-1" 294049 294050 "removing methods" 294051 Trait 294052 named: #T5 294053 uses: self t1 + self t2 - { #m21. #m22 } 294054 category: self class category. 294055 self assert: self c2 methodDict size = 7. 294056 294057 "adding methods" 294058 Trait 294059 named: #T2 294060 uses: self t3 294061 category: self class category. 294062 self assert: self c2 methodDict size = 10. 294063 self assert: (self c2 methodDict keys includesAllOf: #(#m31 #m32 #m33 ))! ! 294064 294065!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'adrian_lienhard 1/31/2009 20:51'! 294066testSuperSends 294067 "self debug: #testSuperSends" 294068 294069 | aC2 | 294070 aC2 := self c2 new. 294071 self assert: aC2 m51. 294072 self deny: aC2 foo. 294073 self deny: aC2 bar! ! 294074 294075!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:33'! 294076testTraitCompositionModifications 294077 self assert: self t6 methodDict size = 6. 294078 self assert: (self t6 sourceCodeAt: #m22Alias) asString = 'm22Alias ^22'. 294079 self t6 setTraitComposition: self t2 asTraitComposition. 294080 self assert: self t6 methodDict size = 2. 294081 self deny: (self t6 methodDict includesKey: #m22Alias). 294082 self t6 294083 setTraitCompositionFrom: self t1 @ { (#m13Alias -> #m13) } - { #m11. #m12 } 294084 + self t2. 294085 self assert: self t6 methodDict size = 4. 294086 self 294087 assert: (self t6 methodDict keys includesAllOf: #(#m13 #m13Alias #m21 #m22 )). 294088 self 294089 assert: (self t6 sourceCodeAt: #m13Alias) asString = 'm13Alias ^self m12'! ! 294090 294091!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:31'! 294092testTraitCompositionWithCycles 294093 self should: [self t1 setTraitComposition: self t1 asTraitComposition] 294094 raise: Error. 294095 self t2 setTraitComposition: self t3 asTraitComposition. 294096 self should: [self t3 setTraitComposition: self t5 asTraitComposition] 294097 raise: Error! ! 294098 294099!PureBehaviorTest methodsFor: 'testing-applying trait composition' stamp: 'dvf 8/26/2005 14:32'! 294100testUpdateWhenLocalMethodRemoved 294101 | aC2 | 294102 aC2 := self c2 new. 294103 self t5 compile: 'foo ^123'. 294104 self deny: aC2 foo. 294105 self c2 removeSelector: #foo. 294106 self assert: aC2 foo = 123! ! 294107Rectangle subclass: #Quadrangle 294108 instanceVariableNames: 'borderWidth borderColor insideColor' 294109 classVariableNames: '' 294110 poolDictionaries: '' 294111 category: 'Graphics-Primitives'! 294112!Quadrangle commentStamp: '<historical>' prior: 0! 294113I represent a particular kind of Rectangle that has a border and inside color.! 294114 294115 294116!Quadrangle methodsFor: 'bordering'! 294117borderColor 294118 "Answer the form that is the borderColor of the receiver." 294119 294120 ^borderColor! ! 294121 294122!Quadrangle methodsFor: 'bordering' stamp: 'lr 7/4/2009 10:42'! 294123borderColor: aColor 294124 "Set the borderColor of the receiver to aColor, a Form." 294125 borderColor := aColor! ! 294126 294127!Quadrangle methodsFor: 'bordering'! 294128borderWidth 294129 "Answer the borderWidth of the receiver." 294130 294131 ^borderWidth! ! 294132 294133!Quadrangle methodsFor: 'bordering' stamp: 'lr 7/4/2009 10:42'! 294134borderWidth: anInteger 294135 "Set the borderWidth of the receiver to anInteger." 294136 borderWidth := anInteger! ! 294137 294138!Quadrangle methodsFor: 'bordering' stamp: 'lr 7/4/2009 10:42'! 294139borderWidthLeft: anInteger1 right: anInteger2 top: anInteger3 bottom: anInteger4 294140 "Set the border width of the receiver to a Rectangle that represents the 294141 left, right, top, and bottom border widths." 294142 borderWidth := anInteger1 @ anInteger3 corner: anInteger2 @ anInteger4! ! 294143 294144!Quadrangle methodsFor: 'bordering'! 294145inside 294146 "Answer a Rectangle that is the receiver inset by the borderWidth." 294147 294148 ^self insetBy: borderWidth! ! 294149 294150!Quadrangle methodsFor: 'bordering'! 294151insideColor 294152 "Answer the form that is the insideColor of the receiver." 294153 294154 ^insideColor! ! 294155 294156!Quadrangle methodsFor: 'bordering' stamp: 'lr 7/4/2009 10:42'! 294157insideColor: aColor 294158 "Set the insideColor of the receiver to aColor, a Form." 294159 insideColor := aColor! ! 294160 294161!Quadrangle methodsFor: 'bordering'! 294162region 294163 "Answer a Rectangle that defines the area of the receiver." 294164 294165 ^origin corner: corner! ! 294166 294167!Quadrangle methodsFor: 'bordering' stamp: 'lr 7/4/2009 10:42'! 294168region: aRectangle 294169 "Set the rectangular area of the receiver to aRectangle." 294170 origin := aRectangle origin. 294171 corner := aRectangle corner! ! 294172 294173!Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 18:30'! 294174setHeight: aNumber 294175 "Set the receiver's height" 294176 294177 self region: (origin extent: (self width @ aNumber))! ! 294178 294179!Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 17:54'! 294180setLeft: aNumber 294181 "Move the receiver so that its left edge is given by aNumber. An example of a setter to go with #left" 294182 294183 self region: ((aNumber @ origin y) extent: self extent)! ! 294184 294185!Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 18:19'! 294186setRight: aNumber 294187 "Move the receiver so that its right edge is given by aNumber. An example of a setter to go with #right" 294188 294189 self region: ((origin x + (aNumber - self right) @ origin y) extent: self extent)! ! 294190 294191!Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 18:26'! 294192setWidth: aNumber 294193 "Set the receiver's width" 294194 294195 self region: (origin extent: (aNumber @ self height))! ! 294196 294197 294198!Quadrangle methodsFor: 'displaying-display'! 294199display 294200 "Display the border and insideRegion of the receiver on the Display." 294201 294202 self displayOn: Display! ! 294203 294204!Quadrangle methodsFor: 'displaying-display'! 294205displayAlign: aPoint1 with: aPoint2 clippingBox: aRectangle 294206 "Display the border and region of the receiver on the Display so that its 294207 position at aPoint1 is aligned with position aPoint2. The displayed 294208 information should be clipped so that only information with the area 294209 determined by aRectangle is displayed." 294210 294211 self displayOn: Display align: aPoint1 with: aPoint2 clippingBox: aRectangle! ! 294212 294213!Quadrangle methodsFor: 'displaying-display'! 294214displayTransformation: aWindowingTransformation clippingBox: aRectangle 294215 "Display the border and region of the receiver on the Display so that it 294216 is scaled and translated with respect to aWindowingTransformation. The 294217 displayed information should be clipped so that only information with 294218 the area determined by aRectangle is displayed." 294219 294220 self displayOn: Display transformation: aWindowingTransformation clippingBox: aRectangle! ! 294221 294222 294223!Quadrangle methodsFor: 'displaying-generic'! 294224displayOn: aDisplayMedium 294225 "Display the border and insideRegion of the receiver." 294226 294227 borderWidth ~~ 0 294228 ifTrue: [aDisplayMedium 294229 border: self region 294230 widthRectangle: borderWidth 294231 rule: Form over 294232 fillColor: borderColor]. 294233 insideColor ~~ nil 294234 ifTrue: [aDisplayMedium fill: self inside fillColor: insideColor]! ! 294235 294236!Quadrangle methodsFor: 'displaying-generic' stamp: 'lr 7/4/2009 10:42'! 294237displayOn: aDisplayMedium align: aPoint1 with: aPoint2 clippingBox: aRectangle 294238 "Display the border and region of the receiver so that its position at 294239 aPoint1 is aligned with position aPoint2. The displayed information 294240 should be clipped so that only information with the area determined by 294241 aRectangle is displayed." 294242 | savedRegion | 294243 savedRegion := self region. 294244 self region: ((savedRegion 294245 align: aPoint1 294246 with: aPoint2) intersect: aRectangle). 294247 self displayOn: aDisplayMedium. 294248 self region: savedRegion! ! 294249 294250!Quadrangle methodsFor: 'displaying-generic' stamp: 'lr 7/4/2009 10:42'! 294251displayOn: aDisplayMedium transformation: aWindowingTransformation clippingBox: aRectangle 294252 "Display the border and region of the receiver so that it is scaled and 294253 translated with respect to aWindowingTransformation. The displayed 294254 information should be clipped so that only information with the area 294255 determined by aRectangle is displayed." 294256 | screenRectangle | 294257 screenRectangle := (aWindowingTransformation applyTo: self) intersect: aRectangle. 294258 borderWidth ~~ 0 & (insideColor ~~ nil) ifTrue: 294259 [ aDisplayMedium 294260 fill: screenRectangle 294261 fillColor: Color black. "borderColor" 294262 aDisplayMedium 294263 fill: (screenRectangle insetBy: borderWidth) 294264 fillColor: insideColor ]! ! 294265 294266!Quadrangle methodsFor: 'displaying-generic'! 294267displayOnPort: aPort at: p 294268 "Display the border and insideRegion of the receiver." 294269 294270 (insideColor == nil or: [borderWidth <= 0]) 294271 ifFalse: [aPort fill: (self region translateBy: p) 294272 fillColor: borderColor rule: Form over]. 294273 insideColor == nil 294274 ifFalse: [aPort fill: (self inside translateBy: p) 294275 fillColor: insideColor rule: Form over]! ! 294276 294277 294278!Quadrangle methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:16'! 294279initialize 294280 "Initialize the region to a null Rectangle, the borderWidth to 1, the 294281 borderColor to black, and the insideColor to white." 294282 294283 super initialize. 294284 origin := 0 @ 0. 294285 corner := 0 @ 0. 294286 borderWidth := 1. 294287 borderColor := Color black. 294288 insideColor := Color white. 294289! ! 294290 294291 294292!Quadrangle methodsFor: 'rectangle functions'! 294293intersect: aRectangle 294294 "Answer a new Quadrangle whose region is the intersection of the 294295 receiver's area and aRectangle. 294296 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality." 294297 294298 ^ self class 294299 region: (super intersect: aRectangle) 294300 borderWidth: borderWidth 294301 borderColor: borderColor 294302 insideColor: insideColor! ! 294303 294304 294305!Quadrangle methodsFor: 'transforming'! 294306align: aPoint1 with: aPoint2 294307 "Answer a new Quadrangle translated by aPoint2 - aPoint1. 294308 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality." 294309 294310 ^ self class 294311 region: (super translateBy: aPoint2 - aPoint1) 294312 borderWidth: borderWidth 294313 borderColor: borderColor 294314 insideColor: insideColor! ! 294315 294316!Quadrangle methodsFor: 'transforming'! 294317alignedTo: alignPointSelector 294318 "Return a copy with offset according to alignPointSelector which is one of... 294319 #(topLeft, topCenter, topRight, leftCenter, center, etc) 294320 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality." 294321 294322 ^ self class 294323 region: (super translateBy: (0@0) - (self perform: alignPointSelector)) 294324 borderWidth: borderWidth 294325 borderColor: borderColor 294326 insideColor: insideColor! ! 294327 294328!Quadrangle methodsFor: 'transforming'! 294329scaleBy: aPoint 294330 "Answer a new Quadrangle scaled by aPoint. 294331 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality." 294332 294333 ^ self class 294334 region: (super scaleBy: aPoint) 294335 borderWidth: borderWidth 294336 borderColor: borderColor 294337 insideColor: insideColor! ! 294338 294339!Quadrangle methodsFor: 'transforming'! 294340translateBy: aPoint 294341 "Answer a new Quadrangle translated by aPoint. 294342 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality." 294343 294344 ^ self class 294345 region: (super translateBy: aPoint) 294346 borderWidth: borderWidth 294347 borderColor: borderColor 294348 insideColor: insideColor! ! 294349 294350 294351!Quadrangle methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 294352setRegion: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2 294353 origin := aRectangle origin. 294354 corner := aRectangle corner. 294355 borderWidth := anInteger. 294356 borderColor := aMask1. 294357 insideColor := aMask2! ! 294358 294359"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 294360 294361Quadrangle class 294362 instanceVariableNames: ''! 294363 294364!Quadrangle class methodsFor: 'instance creation' stamp: 'fc 1/16/2005 21:20'! 294365origin: originPoint corner: cornerPoint 294366 "Override Rectangles origin:corner: in order to get initialized. 294367 294368 Answer an instance of me whose corners (top left and bottom right) are 294369 determined by the arguments." 294370 294371 ^self new setOrigin: originPoint corner: cornerPoint! ! 294372 294373!Quadrangle class methodsFor: 'instance creation'! 294374region: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2 294375 "Answer an instance of me with rectangle, border width and color, and 294376 inside color determined by the arguments." 294377 294378 ^super new 294379 setRegion: aRectangle 294380 borderWidth: anInteger 294381 borderColor: aMask1 294382 insideColor: aMask2! ! 294383ProceedDialogWindow subclass: #QuestionDialogWindow 294384 instanceVariableNames: 'answer' 294385 classVariableNames: '' 294386 poolDictionaries: '' 294387 category: 'Polymorph-Widgets-Windows'! 294388!QuestionDialogWindow commentStamp: 'gvc 5/18/2007 12:20' prior: 0! 294389A yes/no/cancel message dialog. Cancel (escape & return) is the default.! 294390 294391 294392!QuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 14:44'! 294393answer 294394 "Answer the value of answer" 294395 294396 ^ answer! ! 294397 294398!QuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 14:44'! 294399answer: anObject 294400 "Set the value of answer" 294401 294402 answer := anObject! ! 294403 294404!QuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 14:44'! 294405newButtons 294406 "Answer new buttons as appropriate." 294407 294408 ^{self newYesButton. self newNoButton. self newCancelButton isDefault: true}! ! 294409 294410!QuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2007 17:36'! 294411no 294412 "Answer no." 294413 294414 self 294415 answer: false; 294416 ok! ! 294417 294418!QuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 14:44'! 294419yes 294420 "Answer yes." 294421 294422 self 294423 answer: true; 294424 ok! ! 294425QuestionDialogWindow subclass: #QuestionWithoutCancelDialogWindow 294426 instanceVariableNames: '' 294427 classVariableNames: '' 294428 poolDictionaries: '' 294429 category: 'Polymorph-Widgets-Windows'! 294430!QuestionWithoutCancelDialogWindow commentStamp: 'gvc 5/18/2007 12:20' prior: 0! 294431A yes/no message dialog. Yes (return) is the default. Escape will answer no.! 294432 294433 294434!QuestionWithoutCancelDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 14:44'! 294435escapePressed 294436 "Default is to cancel." 294437 294438 self no! ! 294439 294440!QuestionWithoutCancelDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 14:45'! 294441newButtons 294442 "Answer new buttons as appropriate." 294443 294444 ^{self newYesButton isDefault: true. self newNoButton}! ! 294445Array variableSubclass: #QuickIntegerDictionary 294446 instanceVariableNames: '' 294447 classVariableNames: '' 294448 poolDictionaries: '' 294449 category: 'Traits-LocalSends'! 294450!QuickIntegerDictionary commentStamp: 'dvf 8/4/2005 11:06' prior: 0! 294451This implementation serves as a very quick dictionary under the assumption that the keys are small natural numbers.! 294452 294453 294454!QuickIntegerDictionary methodsFor: 'accessing' stamp: 'apb 8/30/2003 18:33'! 294455includesKey: anIntegerKey 294456 ^ (self at: anIntegerKey) notNil ! ! 294457 294458!QuickIntegerDictionary methodsFor: 'accessing' stamp: 'apb 8/30/2003 18:39'! 294459removeKey: anIntegerKey 294460 ^ self at: anIntegerKey put: nil.! ! 294461 294462"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 294463 294464QuickIntegerDictionary class 294465 instanceVariableNames: ''! 294466Array variableSubclass: #QuickStack 294467 instanceVariableNames: 'top' 294468 classVariableNames: '' 294469 poolDictionaries: '' 294470 category: 'Traits-LocalSends'! 294471!QuickStack commentStamp: 'apb 8/30/2003 10:55' prior: 0! 294472This class is a quick and dirty implementation of a stack, designed to be used in the 294473SendsInfo abstract interpreter. As opposed to using an OrderedCollection, this stack is quick because it can be emptied in a single assignment, and dirty because elements above the logical top of the stack (i.e., those that have been popped off) are not nil'ed out. For our application, these are important optimizations with no ill effects. 294474 294475QuickStacks will expand beyond their initial size if required, but we intend that the initial size will always be sufficient, so the efficiency of this feature is not important. 294476! 294477 294478 294479!QuickStack methodsFor: 'accessing' stamp: 'apb 8/30/2003 18:09'! 294480addLast: aValue 294481 top = self basicSize ifTrue: [self grow]. 294482 top := top + 1. 294483 ^ self at: top put: aValue! ! 294484 294485!QuickStack methodsFor: 'accessing' stamp: 'apb 9/7/2004 10:25'! 294486becomeEmpty 294487 top := 0! ! 294488 294489!QuickStack methodsFor: 'accessing' stamp: 'apb 8/30/2003 11:36'! 294490isEmpty 294491 ^ top = 0! ! 294492 294493!QuickStack methodsFor: 'accessing' stamp: 'apb 8/30/2003 11:43'! 294494removeLast 294495 | answer | 294496 answer := self at: top. 294497 top := top - 1. 294498 ^ answer! ! 294499 294500!QuickStack methodsFor: 'accessing' stamp: 'apb 8/31/2003 21:42'! 294501removeLast: n 294502 294503 top := top - n! ! 294504 294505!QuickStack methodsFor: 'accessing' stamp: 'apb 8/30/2003 11:36'! 294506size 294507 ^ top! ! 294508 294509 294510!QuickStack methodsFor: 'copying' stamp: 'apb 9/7/2004 10:37'! 294511copy 294512 "Answer a copy of a myself" 294513 | newSize | 294514 newSize := self basicSize. 294515 ^ (self class new: newSize) 294516 replaceFrom: 1 294517 to: top 294518 with: self 294519 startingAt: 1; 294520 setTop: top! ! 294521 294522 294523!QuickStack methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:16'! 294524initialize 294525 super initialize. 294526 top := 0! ! 294527 294528 294529!QuickStack methodsFor: 'private' stamp: 'apb 8/30/2003 17:56'! 294530grow 294531 | newStack | 294532 newStack := self class new: (self basicSize * 2). 294533 newStack replaceFrom: 1 to: top with: self startingAt: 1. 294534 newStack setTop: top. 294535 self becomeForward: newStack. 294536! ! 294537 294538!QuickStack methodsFor: 'private' stamp: 'apb 8/30/2003 11:55'! 294539setTop: t 294540 top := t! ! 294541 294542"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 294543 294544QuickStack class 294545 instanceVariableNames: ''! 294546 294547!QuickStack class methodsFor: 'instance creation' stamp: 'apb 8/30/2003 11:38'! 294548new 294549 ^ (super new: 16) initialize 294550 "Why 16? Because in performing an abstract interpretation of every 294551 method in every Class <= Object, the largest stack that was found 294552 to be necessary was 15"! ! 294553MimeConverter subclass: #QuotedPrintableMimeConverter 294554 instanceVariableNames: '' 294555 classVariableNames: '' 294556 poolDictionaries: '' 294557 category: 'Network-MIME'! 294558!QuotedPrintableMimeConverter commentStamp: '<historical>' prior: 0! 294559I do quoted printable MIME decoding as specified in RFC 2045 "MIME Part One: Format of Internet Message Bodies". 294560 294561Short version of RFC2045, Sect. 6.7: 294562 294563 (1) Any octet, except a CR or LF that is part of a CRLF line break of the canonical (standard) form of the data being encoded, may be represented by an "=" followed by a two digit hexadecimal representation of the octet's value. [...] 294564 294565 (2) Octets with decimal values of 33 through 60 inclusive, and 62 through 126, inclusive, MAY be represented as the US-ASCII characters which correspond to those octets [...]. 294566 294567 (3) Octets with values of 9 and 32 MAY be represented as US-ASCII TAB (HT) and SPACE characters, 294568 respectively, but MUST NOT be so represented at the end of an encoded line. [...] 294569 294570 (4) A line break in a text body, represented as a CRLF sequence in the text canonical form, must be represented by a (RFC 822) line break, which is also a CRLF sequence, in the Quoted-Printable encoding. [...] 294571 294572 (5) The Quoted-Printable encoding REQUIRES that encoded lines be no more than 76 characters long. If longer lines are to be encoded with the Quoted-Printable encoding, "soft" line breaks 294573 must be used. An equal sign as the last character on a encoded line indicates such a non-significant ("soft") line break in the encoded text. 294574 294575 294576--bf 11/27/1998 16:50! 294577 294578 294579!QuotedPrintableMimeConverter methodsFor: 'conversion' stamp: 'damiencassou 5/30/2008 11:45'! 294580mimeDecode 294581 "Do conversion reading from mimeStream writing to dataStream" 294582 | line s c1 v1 c2 v2 | 294583 [ (line := mimeStream nextLine) isNil ] whileFalse: 294584 [ line := line withoutTrailingBlanks. 294585 line size = 0 294586 ifTrue: [ dataStream cr ] 294587 ifFalse: 294588 [ s := line readStream. 294589 294590 [ dataStream nextPutAll: (s upTo: $=). 294591 s atEnd ] whileFalse: 294592 [ c1 := s next. 294593 v1 := c1 digitValue. 294594 ((v1 294595 between: 0 294596 and: 15) and: [ s atEnd not ]) 294597 ifFalse: 294598 [ dataStream 294599 nextPut: $=; 294600 nextPut: c1 ] 294601 ifTrue: 294602 [ c2 := s next. 294603 v2 := c2 digitValue. 294604 (v2 294605 between: 0 294606 and: 15) 294607 ifFalse: 294608 [ dataStream 294609 nextPut: $=; 294610 nextPut: c1; 294611 nextPut: c2 ] 294612 ifTrue: [ dataStream nextPut: (Character value: v1 * 16 + v2) ] ] ]. 294613 line last = $= ifFalse: [ dataStream cr ] ] ]. 294614 ^ dataStream! ! 294615QuotedPrintableMimeConverter subclass: #RFC2047MimeConverter 294616 instanceVariableNames: '' 294617 classVariableNames: '' 294618 poolDictionaries: '' 294619 category: 'Network-MIME'! 294620!RFC2047MimeConverter commentStamp: '<historical>' prior: 0! 294621I do quoted printable MIME decoding as specified in RFC 2047 ""MIME Part Three: Message Header Extensions for Non-ASCII Text". See String>>decodeMimeHeader! 294622 294623 294624!RFC2047MimeConverter methodsFor: 'conversion' stamp: 'sd 3/20/2008 22:23'! 294625mimeDecode 294626 "Do conversion reading from mimeStream writing to dataStream. See String>>decodeMimeHeader" 294627 294628 | c | 294629 [mimeStream atEnd] whileFalse: [ 294630 c := mimeStream next. 294631 c = $= 294632 ifTrue: [c := Character value: mimeStream next digitValue * 16 294633 + mimeStream next digitValue] 294634 ifFalse: [c = $_ ifTrue: [c := $ ]]. 294635 dataStream nextPut: c]. 294636 ^ dataStream! ! 294637 294638!RFC2047MimeConverter methodsFor: 'conversion' stamp: 'bf 3/10/2000 16:06'! 294639mimeEncode 294640 "Do conversion reading from dataStream writing to mimeStream. Break long lines and escape non-7bit chars." 294641 294642 | word pos wasGood isGood max | 294643 true ifTrue: [mimeStream nextPutAll: dataStream upToEnd]. 294644 pos := 0. 294645 max := 72. 294646 wasGood := true. 294647 [dataStream atEnd] whileFalse: [ 294648 word := self readWord. 294649 isGood := word allSatisfy: [:c | c asciiValue < 128]. 294650 wasGood & isGood ifTrue: [ 294651 pos + word size < max 294652 ifTrue: [dataStream nextPutAll: word. 294653 pos := pos + word size] 294654 ifFalse: [] 294655 ] 294656 ]. 294657 ^ mimeStream! ! 294658 294659 294660!RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/11/2000 23:16'! 294661encodeChar: aChar to: aStream 294662 294663 aChar = Character space 294664 ifTrue: [^ aStream nextPut: $_]. 294665 ((aChar asciiValue between: 32 and: 127) and: [('?=_' includes: aChar) not]) 294666 ifTrue: [^ aStream nextPut: aChar]. 294667 aStream nextPut: $=; 294668 nextPut: (Character digitValue: aChar asciiValue // 16); 294669 nextPut: (Character digitValue: aChar asciiValue \\ 16) 294670! ! 294671 294672!RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/11/2000 23:13'! 294673encodeWord: aString 294674 294675 (aString allSatisfy: [:c | c asciiValue < 128]) 294676 ifTrue: [^ aString]. 294677 ^ String streamContents: [:stream | 294678 stream nextPutAll: '=?iso-8859-1?Q?'. 294679 aString do: [:c | self encodeChar: c to: stream]. 294680 stream nextPutAll: '?=']! ! 294681 294682!RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/12/2000 14:36'! 294683isStructuredField: aString 294684 294685 | fName | 294686 fName := aString copyUpTo: $:. 294687 ('Resent' sameAs: (fName copyUpTo: $-)) 294688 ifTrue: [fName := fName copyFrom: 8 to: fName size]. 294689 ^#('Sender' 'From' 'Reply-To' 'To' 'cc' 'bcc') anySatisfy: [:each | fName sameAs: each]! ! 294690 294691!RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/11/2000 22:30'! 294692readWord 294693 294694 | strm | 294695 strm := WriteStream on: (String new: 20) 294696 dataStream skipSeparators. 294697 [dataStream atEnd] whileFalse: 294698 [ | c | 294699 c := dataStream next. 294700 strm nextPut: c. 294701 c isSeparator ifTrue: [^ strm contents]]. 294702 ^ strm contents! ! 294703ReadWriteStream subclass: #RWBinaryOrTextStream 294704 instanceVariableNames: 'isBinary' 294705 classVariableNames: '' 294706 poolDictionaries: '' 294707 category: 'Collections-Streams'! 294708!RWBinaryOrTextStream commentStamp: '<historical>' prior: 0! 294709A simulation of a FileStream, but living totally in memory. Hold the contents of a file or web page from the network. Can then fileIn like a normal FileStream. 294710 294711Need to be able to switch between binary and text, as a FileStream does, without recopying the whole collection. Convert to binary upon input and output. Always keep as text internally.! 294712 294713 294714!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 2/4/2000 09:15'! 294715asBinaryOrTextStream 294716 294717 ^ self! ! 294718 294719!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/25/97 13:22'! 294720ascii 294721 isBinary := false! ! 294722 294723!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/20/97 19:46'! 294724binary 294725 isBinary := true! ! 294726 294727!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/21/97 12:49'! 294728contents 294729 "Answer with a copy of my collection from 1 to readLimit." 294730 294731 | newArray | 294732 isBinary ifFalse: [^ super contents]. "String" 294733 readLimit := readLimit max: position. 294734 newArray := ByteArray new: readLimit. 294735 ^ newArray replaceFrom: 1 294736 to: readLimit 294737 with: collection 294738 startingAt: 1.! ! 294739 294740!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/20/97 19:47'! 294741isBinary 294742 ^ isBinary! ! 294743 294744!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 12/13/97 13:07'! 294745next 294746 294747 | byte | 294748 ^ isBinary 294749 ifTrue: [byte := super next. 294750 byte ifNil: [nil] ifNotNil: [byte asciiValue]] 294751 ifFalse: [super next]. 294752! ! 294753 294754!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 19:26'! 294755next: anInteger 294756 "Answer the next anInteger elements of my collection. Must override to get class right." 294757 294758 | newArray | 294759 newArray := (isBinary ifTrue: [ByteArray] ifFalse: [ByteString]) new: anInteger. 294760 ^ self nextInto: newArray! ! 294761 294762!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'ls 3/27/2000 22:24'! 294763next: n into: aCollection startingAt: startIndex 294764 "Read n objects into the given collection. 294765 Return aCollection or a partial copy if less than n elements have been read." 294766 "Overriden for efficiency" 294767 | max | 294768 max := (readLimit - position) min: n. 294769 aCollection 294770 replaceFrom: startIndex 294771 to: startIndex+max-1 294772 with: collection 294773 startingAt: position+1. 294774 position := position + max. 294775 max = n 294776 ifTrue:[^aCollection] 294777 ifFalse:[^aCollection copyFrom: 1 to: startIndex+max-1]! ! 294778 294779!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/20/97 07:38'! 294780nextPut: charOrByte 294781 294782 super nextPut: charOrByte asCharacter! ! 294783 294784!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 1/14/1999 20:16'! 294785padToEndWith: aChar 294786 "We don't have pages, so we are at the end, and don't need to pad."! ! 294787 294788!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/21/97 13:04'! 294789reset 294790 "Set the receiver's position to the beginning of the sequence of objects." 294791 294792 super reset. 294793 isBinary ifNil: [isBinary := false]. 294794 collection class == ByteArray ifTrue: ["Store as String and convert as needed." 294795 collection := collection asString. 294796 isBinary := true]. 294797! ! 294798 294799!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 10/1/1998 11:54'! 294800setFileTypeToObject 294801 "do nothing. We don't have a file type"! ! 294802 294803!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/20/97 19:47'! 294804text 294805 isBinary := false! ! 294806 294807!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'ar 4/10/2005 19:27'! 294808upToEnd 294809 "Must override to get class right." 294810 | newArray | 294811 newArray := (isBinary ifTrue: [ByteArray] ifFalse: [ByteString]) new: self size - self position. 294812 ^ self nextInto: newArray! ! 294813 294814 294815!RWBinaryOrTextStream methodsFor: 'writing' stamp: 'DamienCassou 9/7/2009 19:25'! 294816next: anInteger putAll: aCollection startingAt: startIndex 294817 "Optimized for ByteArrays" 294818 aCollection class == ByteArray 294819 ifTrue:[^super next: anInteger putAll: aCollection asString startingAt: startIndex]. 294820 ^super next: anInteger putAll: aCollection startingAt: startIndex! ! 294821 294822!RWBinaryOrTextStream methodsFor: 'writing' stamp: 'DamienCassou 9/7/2009 19:25'! 294823nextPutAll: aCollection 294824 "Optimized for ByteArrays" 294825 aCollection class == ByteArray 294826 ifTrue:[^super nextPutAll: aCollection asString]. 294827 ^super nextPutAll: aCollection! ! 294828 294829!RWBinaryOrTextStream methodsFor: 'writing' stamp: 'DamienCassou 9/7/2009 19:26'! 294830upTo: anObject 294831 "Answer a subcollection from the current access position to the 294832 occurrence (if any, but not inclusive) of anObject in the receiver. If 294833 anObject is not in the collection, answer the entire rest of the receiver." 294834 | newStream element species | 294835 species := isBinary ifTrue:[ByteArray] ifFalse:[String]. 294836 newStream := WriteStream on: (species new: 100). 294837 [self atEnd or: [(element := self next) = anObject]] 294838 whileFalse: [newStream nextPut: element]. 294839 ^newStream contents! ! 294840SimpleBorder subclass: #RaisedBorder 294841 instanceVariableNames: '' 294842 classVariableNames: '' 294843 poolDictionaries: '' 294844 category: 'Morphic-Borders'! 294845!RaisedBorder commentStamp: 'kfr 10/27/2003 09:32' prior: 0! 294846see BorderedMorph! 294847 294848 294849!RaisedBorder methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/31/2007 13:49'! 294850bottomRightColor 294851 "Changed from direct access to color since, if nil, 294852 self color is transparent." 294853 294854 ^width = 1 294855 ifTrue: [self color twiceDarker] 294856 ifFalse: [self color darker]! ! 294857 294858!RaisedBorder methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/31/2007 13:49'! 294859topLeftColor 294860 "Changed from direct access to color since, if nil, 294861 self color is transparent." 294862 294863 ^width = 1 294864 ifTrue: [self color twiceLighter] 294865 ifFalse: [self color lighter]! ! 294866 294867 294868!RaisedBorder methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:23'! 294869colorsAtCorners 294870 | c c14 c23 | 294871 c := self color. 294872 c14 := c lighter. c23 := c darker. 294873 ^Array with: c14 with: c23 with: c23 with: c14! ! 294874 294875!RaisedBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'! 294876style 294877 ^#raised! ! 294878 294879 294880!RaisedBorder methodsFor: 'color tracking' stamp: 'ar 8/25/2001 18:17'! 294881trackColorFrom: aMorph 294882 baseColor ifNil:[self color: aMorph raisedColor].! ! 294883Object subclass: #Random 294884 instanceVariableNames: 'seed a m q r' 294885 classVariableNames: '' 294886 poolDictionaries: '' 294887 category: 'Kernel-Numbers'! 294888!Random commentStamp: 'md 4/26/2003 16:32' prior: 0! 294889This Random Number Generator graciously contributed by David N. Smith. It is an adaptation of the Park-Miller RNG which uses Floats to avoid the need for LargeInteger arithmetic. 294890 294891If you just want a quick random integer, use: 294892 10 atRandom 294893Every integer interval can give a random number: 294894 (6 to: 12) atRandom 294895SequenceableCollections can give randomly selected elements: 294896 'pick one of these letters randomly' atRandom 294897SequenceableCollections also respond to shuffled, as in: 294898 ($A to: $Z) shuffled 294899 294900The correct way to use class Random is to store one in an instance or class variable: 294901 myGenerator _ Random new. 294902Then use it every time you need another number between 0.0 and 1.0 (excluding) 294903 myGenerator next 294904You can also generate a positive integer 294905 myGenerator nextInt: 10! 294906 294907 294908!Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:25'! 294909next 294910 "Answer a random Float in the interval [0 to 1)." 294911 294912 ^ (seed := self nextValue) / m! ! 294913 294914!Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:45'! 294915next: anInteger 294916 ^ self next: anInteger into: (Array new: anInteger)! ! 294917 294918!Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:46'! 294919next: anInteger into: anArray 294920 1 to: anInteger do: [:index | anArray at: index put: self next]. 294921 ^ anArray! ! 294922 294923!Random methodsFor: 'accessing' stamp: 'gvc 1/31/2007 13:52'! 294924nextInt: anInteger 294925 "Answer a random integer in the interval [1, anInteger]. 294926 Handle large numbers too (for cryptography)." 294927 294928 anInteger strictlyPositive ifFalse: [ self error: 'Range must be positive' ]. 294929 anInteger asFloat isInfinite 294930 ifTrue: [^(self next asFraction * anInteger) truncated + 1]. 294931 ^ (self next * anInteger) truncated + 1! ! 294932 294933 294934!Random methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:17'! 294935initialize 294936 " Set a reasonable Park-Miller starting seed " 294937 super initialize. 294938 [seed := (Time millisecondClockValue bitAnd: 16r3FFFFFFF) bitXor: self hash. 294939 seed = 0] whileTrue: ["Try again if ever get a seed = 0"]. 294940 294941 a := 16r000041A7 asFloat. " magic constant = 16807 " 294942 m := 16r7FFFFFFF asFloat. " magic constant = 2147483647 " 294943 q := (m quo: a) asFloat. 294944 r := (m \\ a) asFloat. 294945! ! 294946 294947!Random methodsFor: 'initialization' stamp: 'sma 5/12/2000 12:29'! 294948seed: anInteger 294949 seed := anInteger! ! 294950 294951 294952!Random methodsFor: 'private' stamp: 'sma 5/12/2000 12:28'! 294953nextValue 294954 "This method generates random instances of Integer in the interval 294955 0 to 16r7FFFFFFF. This method does NOT update the seed; repeated sends 294956 answer the same value. 294957 The algorithm is described in detail in 'Random Number Generators: 294958 Good Ones Are Hard to Find' by Stephen K. Park and Keith W. Miller 294959 (Comm. Asso. Comp. Mach., 31(10):1192--1201, 1988)." 294960 294961 | lo hi aLoRHi answer | 294962 hi := (seed quo: q) asFloat. 294963 lo := seed - (hi * q). " = seed rem: q" 294964 aLoRHi := (a * lo) - (r * hi). 294965 answer := (aLoRHi > 0.0) 294966 ifTrue: [aLoRHi] 294967 ifFalse: [aLoRHi + m]. 294968 ^ answer! ! 294969 294970!Random methodsFor: 'private' stamp: 'sma 5/12/2000 12:43'! 294971seed 294972 ^ seed! ! 294973 294974"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 294975 294976Random class 294977 instanceVariableNames: ''! 294978 294979!Random class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:51'! 294980seed: anInteger 294981 ^self new seed: anInteger! ! 294982 294983 294984!Random class methodsFor: 'testing'! 294985bucketTest: randy 294986 "Execute this: Random bucketTest: Random new" 294987 " A quick-and-dirty bucket test. Prints nbuckets values on the 294988Transcript. 294989 Each should be 'near' the value of ntries. Any run with any value 294990'far' from ntries 294991 indicates something is very wrong. Each run generates different 294992values. 294993 For a slightly better test, try values of nbuckets of 200-1000 or 294994more; go get coffee. 294995 This is a poor test; see Knuth. Some 'OK' runs: 294996 1000 1023 998 969 997 1018 1030 1019 1054 985 1003 294997 1011 987 982 980 982 974 968 1044 976 294998 1029 1011 1025 1016 997 1019 991 954 968 999 991 294999 978 1035 995 988 1038 1009 988 993 976 295000" 295001 | nbuckets buckets ntrys slot | 295002 nbuckets := 20. 295003 buckets := Array new: nbuckets. 295004 buckets atAllPut: 0. 295005 ntrys := 100. 295006 ntrys*nbuckets timesRepeat: [ 295007 slot := (randy next * nbuckets) floor + 1. 295008 buckets at: slot put: (buckets at: slot) + 1 ]. 295009 Transcript cr. 295010 1 to: nbuckets do: [ :nb | 295011 Transcript show: (buckets at: nb) printString, ' ' ]! ! 295012 295013!Random class methodsFor: 'testing'! 295014theItsCompletelyBrokenTest 295015 "Random theItsCompletelyBrokenTest" 295016 "The above should print as... 295017 (0.149243269650845 0.331633021743797 0.75619644800024 0.393701540023881 0.941783181364547 0.549929193942775 0.659962596213428 0.991354559078512 0.696074432551896 0.922987899707159 ) 295018 If they are not these values (accounting for precision of printing) then something is horribly wrong: DO NOT USE THIS CODE FOR ANYTHING. " 295019 | rng | 295020 rng := Random new. 295021 rng seed: 2345678901. 295022 ^ (1 to: 10) collect: [:i | rng next]! ! 295023ClassTestCase subclass: #RandomTest 295024 instanceVariableNames: 'gen' 295025 classVariableNames: '' 295026 poolDictionaries: '' 295027 category: 'KernelTests-Numbers'! 295028 295029!RandomTest methodsFor: 'setup' stamp: 'md 4/2/2003 12:32'! 295030setUp 295031 gen := Random seed: 112629.! ! 295032 295033 295034!RandomTest methodsFor: 'tests' stamp: 'md 4/2/2003 12:50'! 295035testNext 295036 295037 10000 timesRepeat: [ 295038 | next | 295039 next := gen next. 295040 self assert: (next >= 0). 295041 self assert: (next < 1). 295042 ].! ! 295043PositionableStream subclass: #ReadStream 295044 instanceVariableNames: '' 295045 classVariableNames: '' 295046 poolDictionaries: '' 295047 category: 'Collections-Streams'! 295048!ReadStream commentStamp: '<historical>' prior: 0! 295049I represent an accessor for a sequence of objects that can only read objects from the sequence.! 295050 295051 295052!ReadStream methodsFor: 'accessing'! 295053ascii! ! 295054 295055!ReadStream methodsFor: 'accessing'! 295056next 295057 "Primitive. Answer the next object in the Stream represented by the 295058 receiver. Fail if the collection of this stream is not an Array or a String. 295059 Fail if the stream is positioned at its end, or if the position is out of 295060 bounds in the collection. Optional. See Object documentation 295061 whatIsAPrimitive." 295062 295063 <primitive: 65> 295064 position >= readLimit 295065 ifTrue: [^nil] 295066 ifFalse: [^collection at: (position := position + 1)]! ! 295067 295068!ReadStream methodsFor: 'accessing' stamp: 'ls 8/16/1998 00:46'! 295069next: anInteger 295070 "Answer the next anInteger elements of my collection. overriden for efficiency" 295071 295072 | ans endPosition | 295073 295074 endPosition := position + anInteger min: readLimit. 295075 ans := collection copyFrom: position+1 to: endPosition. 295076 position := endPosition. 295077 ^ans 295078! ! 295079 295080!ReadStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:01'! 295081next: n into: aCollection startingAt: startIndex 295082 "Read n objects into the given collection. 295083 Return aCollection or a partial copy if less than 295084 n elements have been read." 295085 | max | 295086 max := (readLimit - position) min: n. 295087 aCollection 295088 replaceFrom: startIndex 295089 to: startIndex+max-1 295090 with: collection 295091 startingAt: position+1. 295092 position := position + max. 295093 max = n 295094 ifTrue:[^aCollection] 295095 ifFalse:[^aCollection copyFrom: 1 to: startIndex+max-1]! ! 295096 295097!ReadStream methodsFor: 'accessing'! 295098nextPut: anObject 295099 295100 self shouldNotImplement! ! 295101 295102!ReadStream methodsFor: 'accessing' stamp: 'ajh 9/5/2002 22:11'! 295103readStream 295104 "polymorphic with SequenceableCollection. Return self" 295105 295106 ^ self! ! 295107 295108!ReadStream methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:20'! 295109size 295110 "Compatibility with other streams (e.g., FileStream)" 295111 ^readLimit! ! 295112 295113!ReadStream methodsFor: 'accessing' stamp: 'ls 9/12/1998 00:59'! 295114upTo: anObject 295115 "fast version using indexOf:" 295116 | start end | 295117 295118 start := position+1. 295119 end := collection indexOf: anObject startingAt: start ifAbsent: [ 0 ]. 295120 295121 "not present--return rest of the collection" 295122 end = 0 ifTrue: [ ^self upToEnd ]. 295123 295124 "skip to the end and return the data passed over" 295125 position := end. 295126 ^collection copyFrom: start to: (end-1)! ! 295127 295128!ReadStream methodsFor: 'accessing' stamp: 'ls 9/12/1998 00:59'! 295129upToEnd 295130 | start | 295131 295132 start := position+1. 295133 position := collection size. 295134 ^collection copyFrom: start to: position! ! 295135 295136 295137!ReadStream methodsFor: 'file stream compatibility' stamp: 'nk 12/13/2002 12:00'! 295138localName 295139 ^'ReadStream'! ! 295140 295141 295142!ReadStream methodsFor: 'private'! 295143on: aCollection from: firstIndex to: lastIndex 295144 295145 | len | 295146 collection := aCollection. 295147 readLimit := lastIndex > (len := collection size) 295148 ifTrue: [len] 295149 ifFalse: [lastIndex]. 295150 position := firstIndex <= 1 295151 ifTrue: [0] 295152 ifFalse: [firstIndex - 1]! ! 295153 295154"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 295155 295156ReadStream class 295157 instanceVariableNames: ''! 295158 295159!ReadStream class methodsFor: 'instance creation'! 295160on: aCollection from: firstIndex to: lastIndex 295161 "Answer with a new instance streaming over a copy of aCollection from 295162 firstIndex to lastIndex." 295163 295164 ^self basicNew 295165 on: aCollection 295166 from: firstIndex 295167 to: lastIndex! ! 295168TestCase subclass: #ReadStreamTest 295169 instanceVariableNames: '' 295170 classVariableNames: '' 295171 poolDictionaries: '' 295172 category: 'CollectionsTests-Streams'! 295173!ReadStreamTest commentStamp: 'tlk 12/5/2004 14:36' prior: 0! 295174I am an SUnit test for ReadStream. 295175I have no test fixtures.! 295176 295177 295178!ReadStreamTest methodsFor: 'accessing - defaults' stamp: 'dc 2/27/2007 16:58'! 295179emptyStream 295180 ^ ReadStream on: String new.! ! 295181 295182!ReadStreamTest methodsFor: 'accessing - defaults' stamp: 'dc 2/27/2007 16:58'! 295183streamOnArray 295184 ^ ReadStream on: (Array with: 1 with: #(a b c) with: false).! ! 295185 295186!ReadStreamTest methodsFor: 'accessing - defaults' stamp: 'dc 2/27/2007 16:58'! 295187streamOnString 295188 ^ ReadStream on: 'abcde'.! ! 295189 295190 295191!ReadStreamTest methodsFor: 'tests' stamp: 'damiencassou 5/30/2008 14:26'! 295192streamOn: collection upToAll: subcollection 295193 ^ collection readStream upToAll: subcollection! ! 295194 295195!ReadStreamTest methodsFor: 'tests' stamp: 'damiencassou 5/30/2008 14:26'! 295196streamOn: collection upToAll: subcollection1 upToAll: subcollection2 295197 ^ collection readStream 295198 upToAll: subcollection1; 295199 upToAll: subcollection2! ! 295200 295201!ReadStreamTest methodsFor: 'tests' stamp: 'damiencassou 11/23/2008 16:53'! 295202testBack 295203 |stream| 295204 stream := 'abc' readStream. 295205 stream setToEnd. 295206 self assert: stream back = $c. 295207! ! 295208 295209!ReadStreamTest methodsFor: 'tests' stamp: 'damiencassou 11/23/2008 16:54'! 295210testBackOnPosition1 295211 "Test the new implementation of the method back." 295212 |stream| 295213 stream := 'abc' readStream. 295214 stream next. 295215 self assert: stream back = $a. 295216! ! 295217 295218!ReadStreamTest methodsFor: 'tests' stamp: 'damiencassou 11/23/2008 16:55'! 295219testOldBack 295220 "Test the old behavior of the method back. The method #oldBack is a misconception about what a stream is. A stream contains a pointer *between* elements with past and future elements. The method #oldBack considers that the pointer is *on* an element. (Damien Cassou - 1 August 2007)" 295221 |stream| 295222 stream := 'abc' readStream. 295223 stream setToEnd. 295224 self assert: stream oldBack = $b. 295225! ! 295226 295227!ReadStreamTest methodsFor: 'tests' stamp: 'damiencassou 11/23/2008 16:56'! 295228testOldBackOnPosition1 295229 "Test the old behavior of the method back. The method #oldBack is a misconception about what a stream is. A stream contains a pointer *between* elements with past and future elements. The method #oldBack considers that the pointer is *on* an element. (Damien Cassou - 1 August 2007)" 295230 |stream| 295231 stream := 'abc' readStream. 295232 stream next. 295233 self assert: stream oldBack = nil. 295234! ! 295235 295236!ReadStreamTest methodsFor: 'tests' stamp: 'damiencassou 11/23/2008 16:56'! 295237testOldPeekBack 295238 "Test the old behavior of the method peekBack. The method #oldBack is a misconception about what a stream is. A stream contains a pointer *between* elements with past and future elements. The method #oldBack considers that the pointer is *on* an element. (Damien Cassou - 1 August 2007)" 295239 |stream| 295240 stream := 'abc' readStream. 295241 stream setToEnd. 295242 self assert: stream oldPeekBack = $b. 295243! ! 295244 295245!ReadStreamTest methodsFor: 'tests' stamp: 'damiencassou 11/23/2008 16:57'! 295246testPeekBack 295247 "Test the new implementation of the method peekBack due to changing #back." 295248 |stream| 295249 stream := 'abc' readStream. 295250 stream setToEnd. 295251 self assert: stream peekBack = $c. 295252! ! 295253 295254!ReadStreamTest methodsFor: 'tests' stamp: 'tlk 12/5/2004 14:34'! 295255testPositionOfSubCollection 295256 295257 self assert: ('xyz' readStream positionOfSubCollection: 'q' ) = 0. 295258 self assert: ('xyz' readStream positionOfSubCollection: 'x' ) = 1. 295259 295260 self assert: ('xyz' readStream positionOfSubCollection: 'y' ) = 2. 295261 self assert: ('xyz' readStream positionOfSubCollection: 'z' ) = 3.! ! 295262 295263!ReadStreamTest methodsFor: 'tests' stamp: 'bp 10/29/2004 06:16'! 295264testUpToAll 295265 295266 self assert: (self streamOn: 'abcdefgh' upToAll: 'cd') = 'ab'. 295267 self assert: (self streamOn: 'abcdefgh' upToAll: 'cd' upToAll: 'gh') = 'ef'. 295268 295269 self assert: (self streamOn: '' upToAll: '') = ''. 295270 295271 self assert: (self streamOn: 'a' upToAll: '') = ''. 295272 self assert: (self streamOn: 'a' upToAll: 'a') = ''. 295273 self assert: (self streamOn: 'a' upToAll: 'b') = 'a'. 295274 295275 self assert: (self streamOn: 'ab' upToAll: '') = ''. 295276 self assert: (self streamOn: 'ab' upToAll: 'a') = ''. 295277 self assert: (self streamOn: 'ab' upToAll: 'b') = 'a'. 295278 self assert: (self streamOn: 'ab' upToAll: 'c') = 'ab'. 295279 self assert: (self streamOn: 'ab' upToAll: 'ab') = ''. 295280 295281 self assert: (self streamOn: 'abc' upToAll: '') = ''. 295282 self assert: (self streamOn: 'abc' upToAll: 'a') = ''. 295283 self assert: (self streamOn: 'abc' upToAll: 'b') = 'a'. 295284 self assert: (self streamOn: 'abc' upToAll: 'c') = 'ab'. 295285 self assert: (self streamOn: 'abc' upToAll: 'd') = 'abc'. 295286 self assert: (self streamOn: 'abc' upToAll: 'ab') = ''. 295287 self assert: (self streamOn: 'abc' upToAll: 'bc') = 'a'. 295288 self assert: (self streamOn: 'abc' upToAll: 'cd') = 'abc'. 295289! ! 295290 295291 295292!ReadStreamTest methodsFor: 'tests - testing' stamp: 'dc 2/27/2007 16:58'! 295293testIsEmpty 295294 | stream | 295295 self assert: self emptyStream isEmpty. 295296 295297 stream := self streamOnArray. 295298 self deny: stream isEmpty. 295299 stream skip: 3. 295300 self deny: stream isEmpty. 295301 295302 stream := self streamOnString. 295303 self deny: stream isEmpty. 295304 stream next;next;next. 295305 self deny: stream isEmpty. 295306 stream setToEnd. 295307 self deny: stream isEmpty.! ! 295308WriteStream subclass: #ReadWriteStream 295309 instanceVariableNames: '' 295310 classVariableNames: '' 295311 poolDictionaries: '' 295312 category: 'Collections-Streams'! 295313!ReadWriteStream commentStamp: '<historical>' prior: 0! 295314I represent an accessor for a sequence of objects. My instances can both read and store objects.! 295315 295316 295317!ReadWriteStream methodsFor: 'accessing'! 295318contents 295319 "Answer with a copy of my collection from 1 to readLimit." 295320 295321 readLimit := readLimit max: position. 295322 ^collection copyFrom: 1 to: readLimit! ! 295323 295324!ReadWriteStream methodsFor: 'accessing'! 295325name 295326 ^ 'a stream' "for fileIn compatibility"! ! 295327 295328!ReadWriteStream methodsFor: 'accessing'! 295329next 295330 "Primitive. Return the next object in the Stream represented by the 295331 receiver. Fail if the collection of this stream is not an Array or a String. 295332 Fail if the stream is positioned at its end, or if the position is out of 295333 bounds in the collection. Optional. See Object documentation 295334 whatIsAPrimitive." 295335 295336 <primitive: 65> 295337 "treat me as a FIFO" 295338 position >= readLimit 295339 ifTrue: [^nil] 295340 ifFalse: [^collection at: (position := position + 1)]! ! 295341 295342!ReadWriteStream methodsFor: 'accessing' stamp: 'ar 8/5/2003 02:23'! 295343next: anInteger 295344 "Answer the next anInteger elements of my collection. overriden for efficiency" 295345 295346 | ans endPosition | 295347 readLimit := readLimit max: position. 295348 295349 endPosition := position + anInteger min: readLimit. 295350 ans := collection copyFrom: position+1 to: endPosition. 295351 position := endPosition. 295352 ^ans 295353! ! 295354 295355 295356!ReadWriteStream methodsFor: 'converting' stamp: 'yo 7/16/2003 14:59'! 295357asUnZippedStream 295358 | isGZip outputStream first strm archive which | 295359 "Decompress this file if needed, and return a stream. No file is written. File extension may be .gz or anything else. Also works on archives (.zip, .gZip)." 295360 295361 strm := self binary. 295362 strm isZipArchive ifTrue: [ 295363 archive := ZipArchive new readFrom: strm. 295364 which := archive members detect: [:any | any fileName asLowercase endsWith: '.ttf'] 295365 ifNone: [nil]. 295366 which ifNil: [archive close. 295367 ^ self error: 'Can''t find .ttf file in archive']. 295368 strm := which contentStream. 295369 archive close]. 295370 295371 first := strm next. 295372 isGZip := (strm next * 256 + first) = (GZipConstants gzipMagic). 295373 strm skip: -2. 295374 isGZip 295375 ifTrue: [outputStream := (MultiByteBinaryOrTextStream with: 295376 (GZipReadStream on: strm) upToEnd) reset. 295377 strm close] 295378 ifFalse: [outputStream := strm]. 295379 ^ outputStream! ! 295380 295381!ReadWriteStream methodsFor: 'converting' stamp: 'ajh 9/14/2002 20:37'! 295382readStream 295383 "polymorphic with SequenceableCollection. Return self" 295384 295385 ^ self! ! 295386 295387 295388!ReadWriteStream methodsFor: 'filein/out' stamp: 'di 7/17/97 16:12'! 295389fileInObjectAndCode 295390 "This file may contain: 2953911) a fileIn of code 2953922) just an object in SmartReferenceStream format 2953933) both code and an object. 295394 File it in and return the object. Note that self must be a FileStream or RWBinaryOrTextStream. Maybe ReadWriteStream incorporate RWBinaryOrTextStream?" 295395 | refStream object | 295396 self text. 295397 self peek asciiValue = 4 295398 ifTrue: [ "pure object file" 295399 refStream := SmartRefStream on: self. 295400 object := refStream nextAndClose] 295401 ifFalse: [ "objects mixed with a fileIn" 295402 self fileIn. "reads code and objects, then closes the file" 295403 object := SmartRefStream scannedObject]. "set by side effect of one of the chunks" 295404 SmartRefStream scannedObject: nil. "clear scannedObject" 295405 ^ object! ! 295406 295407!ReadWriteStream methodsFor: 'filein/out'! 295408fileNameEndsWith: aString 295409 "See comment in FileStream fileNameEndsWith:" 295410 295411 ^false! ! 295412 295413!ReadWriteStream methodsFor: 'filein/out' stamp: 'RAA 4/6/2001 18:32'! 295414fileOutChangeSet: aChangeSetOrNil andObject: theObject 295415 "Write a file that has both the source code for the named class and an object as bits. Any instance-specific object will get its class written automatically." 295416 295417 "An experimental version to fileout a changeSet first so that a project can contain its own classes" 295418 295419 295420 self setFileTypeToObject. 295421 "Type and Creator not to be text, so can attach correctly to an email msg" 295422 self header; timeStamp. 295423 295424 aChangeSetOrNil ifNotNil: [ 295425 aChangeSetOrNil fileOutPreambleOn: self. 295426 aChangeSetOrNil fileOutOn: self. 295427 aChangeSetOrNil fileOutPostscriptOn: self. 295428 ]. 295429 self trailer. "Does nothing for normal files. HTML streams will have trouble with object data" 295430 295431 "Append the object's raw data" 295432 (SmartRefStream on: self) 295433 nextPut: theObject; "and all subobjects" 295434 close. "also closes me" 295435! ! 295436 295437!ReadWriteStream methodsFor: 'filein/out' stamp: 'sd 5/23/2003 14:41'! 295438fileOutChanges 295439 "Append to the receiver a description of all class changes." 295440 Cursor write showWhile: 295441 [self header; timeStamp. 295442 ChangeSet current fileOutOn: self. 295443 self trailer; close]! ! 295444 295445!ReadWriteStream methodsFor: 'filein/out' stamp: 'sd 4/24/2008 22:20'! 295446fileOutClass: extraClass andObject: theObject 295447 "Write a file that has both the source code for the named class and an object as bits. Any instance-specific object will get its class written automatically." 295448 295449 | class srefStream | 295450 self setFileTypeToObject. 295451 "Type and Creator not to be text, so can attach correctly to an email msg" 295452 self text. 295453 self header; timeStamp. 295454 295455 extraClass ifNotNil: [ 295456 class := extraClass. "A specific class the user wants written" 295457 class hasSharedPools ifTrue: 295458 [class shouldFileOutPools 295459 ifTrue: [class fileOutSharedPoolsOn: self]]. 295460 class fileOutOn: self moveSource: false toFile: 0]. 295461 self trailer. "Does nothing for normal files. HTML streams will have trouble with object data" 295462 self binary. 295463 295464 "Append the object's raw data" 295465 srefStream := SmartRefStream on: self. 295466 srefStream nextPut: theObject. "and all subobjects" 295467 srefStream close. "also closes me" 295468! ! 295469 295470!ReadWriteStream methodsFor: 'filein/out' stamp: 'sd 4/24/2008 22:20'! 295471fileOutClass: extraClass andObject: theObject blocking: anIdentDict 295472 "Write a file that has both the source code for the named class and an object as bits. Any instance-specific object will get its class written automatically. Accept a list of objects to map to nil or some other object (blockers). In addition to teh choices in each class's objectToStoreOnDataStream" 295473 295474 | class srefStream | 295475 self setFileTypeToObject. 295476 "Type and Creator not to be text, so can attach correctly to an email msg" 295477 self header; timeStamp. 295478 295479 extraClass ifNotNil: [ 295480 class := extraClass. "A specific class the user wants written" 295481 class hasSharedPools ifTrue: 295482 [class shouldFileOutPools 295483 ifTrue: [class fileOutSharedPoolsOn: self]]. 295484 class fileOutOn: self moveSource: false toFile: 0]. 295485 self trailer. "Does nothing for normal files. HTML streams will have trouble with object data" 295486 295487 "Append the object's raw data" 295488 srefStream := SmartRefStream on: self. 295489 srefStream blockers: anIdentDict. 295490 srefStream nextPut: theObject. "and all subobjects" 295491 srefStream close. "also closes me" 295492! ! 295493 295494 295495!ReadWriteStream methodsFor: 'testing' stamp: 'tk 11/29/2001 12:47'! 295496= other 295497 295498 (self class == ReadWriteStream and: [other class == ReadWriteStream]) ifFalse: [ 295499 ^ super = other]. "does an identity test. Don't read contents of FileStream" 295500 ^ self position = other position and: [self contents = other contents]! ! 295501 295502!ReadWriteStream methodsFor: 'testing' stamp: 'tk 12/2/2001 17:13'! 295503hash 295504 295505 self class == ReadWriteStream ifFalse: [^ super hash]. 295506 ^ (self position + readLimit + 53) hash! ! 295507 295508!ReadWriteStream methodsFor: 'testing' stamp: 'nk 8/21/2004 15:47'! 295509isZipArchive 295510 "Determine if this appears to be a valid Zip archive" 295511 | sig | 295512 self binary. 295513 sig := self next: 4. 295514 self position: self position - 4. "rewind" 295515 ^ZipArchive validSignatures includes: sig! ! 295516ClassTestCase subclass: #ReadWriteStreamTest 295517 instanceVariableNames: '' 295518 classVariableNames: '' 295519 poolDictionaries: '' 295520 category: 'CollectionsTests-Streams'! 295521!ReadWriteStreamTest commentStamp: '<historical>' prior: 0! 295522This is the unit test for the class ReadWriteStream. 295523Unit tests are a good way to exercise the 295524functionality of your system in a repeatable and 295525automatic manner. They are therefore recommended if 295526you plan to release anything. For more information, 295527see: 295528 - http://www.c2.com/cgi/wiki?UnitTest 295529 - http://minnow.cc.gatech.edu/squeak/1547 295530 - the sunit class category! 295531 295532 295533!ReadWriteStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:24'! 295534testConstructionUsingWith 295535 "Use the with: constructor." 295536 295537 | aStream | 295538 aStream := ReadWriteStream with: #(1 2). 295539 self assert: (aStream contents = #(1 2)) description: 'Ensure correct initialization.'! ! 295540 295541!ReadWriteStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:24'! 295542testNew 295543 295544 self should: [ReadWriteStream new] raise: Error.! ! 295545 295546 295547!ReadWriteStreamTest methodsFor: 'tests - testing' stamp: 'dc 2/27/2007 16:06'! 295548testIsEmpty 295549 | stream | 295550 stream := ReadWriteStream on: String new. 295551 self assert: stream isEmpty. 295552 stream nextPut: $a. 295553 self deny: stream isEmpty. 295554 stream reset. 295555 self deny: stream isEmpty. 295556 stream next. 295557 self deny: stream isEmpty.! ! 295558Object subclass: #RealEstateAgent 295559 instanceVariableNames: '' 295560 classVariableNames: 'ReverseStaggerOffset StaggerOffset StaggerOrigin StandardSize StandardWindowOrigins' 295561 poolDictionaries: '' 295562 category: 'System-Support'! 295563!RealEstateAgent commentStamp: '<historical>' prior: 0! 295564Responsible for real-estate management on the screen, which is to say, controlling where new windows appear, with what sizes, etc. 5/20/96 sw! 295565 295566 295567"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 295568 295569RealEstateAgent class 295570 instanceVariableNames: ''! 295571 295572!RealEstateAgent class methodsFor: 'accessing' stamp: 'alain.plantec 6/1/2008 20:02'! 295573maximumUsableArea 295574 295575 | allowedArea | 295576 allowedArea := Display usableArea. 295577 allowedArea := allowedArea intersect: ActiveWorld visibleClearArea. 295578 ^allowedArea! ! 295579 295580!RealEstateAgent class methodsFor: 'accessing' stamp: 'dgd 4/4/2006 16:42'! 295581maximumUsableAreaInWorld: aWorldOrNil 295582 295583 | allowedArea | 295584 allowedArea := Display usableArea. 295585 aWorldOrNil ifNotNil: [ 295586 allowedArea := allowedArea intersect: aWorldOrNil visibleClearArea. 295587 ]. 295588 ^allowedArea! ! 295589 295590!RealEstateAgent class methodsFor: 'accessing' stamp: 'RAA 5/25/2000 08:45'! 295591standardPositions 295592 295593 self error: 'please use #standardPositionsInWorld:'! ! 295594 295595!RealEstateAgent class methodsFor: 'accessing' stamp: 'RAA 5/25/2000 08:43'! 295596standardPositionsInWorld: aWorldOrNil 295597 "Return a list of standard window positions -- this may have one, two, or four of them, depending on the size and shape of the display screen. " 295598 295599 | anArea aList midX midY | 295600 295601 anArea := self maximumUsableAreaInWorld: aWorldOrNil. 295602 295603 midX := self scrollBarSetback + ((anArea width - self scrollBarSetback) // 2). 295604 midY := self screenTopSetback + ((anArea height - self screenTopSetback) // 2). 295605 aList := OrderedCollection with: (self scrollBarSetback @ self screenTopSetback). 295606 self windowColumnsDesired > 1 295607 ifTrue: 295608 [aList add: (midX @ self screenTopSetback)]. 295609 self windowRowsDesired > 1 295610 ifTrue: 295611 [aList add: (self scrollBarSetback @ (midY+self screenTopSetback)). 295612 self windowColumnsDesired > 1 ifTrue: 295613 [aList add: (midX @ (midY+self screenTopSetback))]]. 295614 ^ aList! ! 295615 295616 295617!RealEstateAgent class methodsFor: 'class initialization' stamp: 'al 9/21/2008 19:59'! 295618initialize 295619 "RealEstateAgent initialize" 295620 295621 StaggerOffset := 6 @ 20. 295622 ReverseStaggerOffset := -6 @ 20. 295623 StaggerOrigin := 200 @ 30. 295624 StandardSize := 750@500.! ! 295625 295626 295627!RealEstateAgent class methodsFor: 'framing' stamp: 'RAA 5/25/2000 08:17'! 295628initialFrameFor: aView 295629 "Find a plausible initial screen area for the supplied view. See called method." 295630 295631 self error: 'please use #initialFrameFor:world:'! ! 295632 295633!RealEstateAgent class methodsFor: 'framing' stamp: 'RAA 5/25/2000 08:18'! 295634initialFrameFor: aView initialExtent: initialExtent 295635 295636 self error: 'please use #initialFrameFor:initialExtent:world:'! ! 295637 295638!RealEstateAgent class methodsFor: 'framing' stamp: 'stephane.ducasse 9/25/2008 13:36'! 295639initialFrameFor: aView initialExtent: initialExtent world: aWorld 295640 "Find a plausible initial screen area for the supplied view, which should be a StandardSystemView, taking into account the 'reverseWindowStagger' Preference, the size needed, and other windows currently on the screen." 295641 295642 | allOrigins screenRight screenBottom putativeOrigin putativeFrame allowedArea staggerOrigin otherFrames | 295643 295644 Preferences reverseWindowStagger ifTrue: 295645 [^ self strictlyStaggeredInitialFrameFor: aView initialExtent: initialExtent world: aWorld]. 295646 295647 allowedArea := self maximumUsableAreaInWorld: aWorld. 295648 screenRight := allowedArea right. 295649 screenBottom := allowedArea bottom. 295650 295651 otherFrames := (aWorld windowsSatisfying: [:w | w isCollapsed not]) 295652 collect: [:w | w bounds]. 295653 295654 allOrigins := otherFrames collect: [:f | f origin]. 295655 (self standardPositionsInWorld: aWorld) do: "First see if one of the standard positions is free" 295656 [:aPosition | (allOrigins includes: aPosition) 295657 ifFalse: 295658 [^ (aPosition extent: initialExtent) translatedAndSquishedToBeWithin: allowedArea]]. 295659 295660 staggerOrigin := (self standardPositionsInWorld: aWorld) first. "Fallback: try offsetting from top left" 295661 putativeOrigin := staggerOrigin. 295662 295663 [putativeOrigin := putativeOrigin + StaggerOffset. 295664 putativeFrame := putativeOrigin extent: initialExtent. 295665 (putativeFrame bottom < screenBottom) and: 295666 [putativeFrame right < screenRight]] 295667 whileTrue: 295668 [(allOrigins includes: putativeOrigin) 295669 ifFalse: 295670 [^ (putativeOrigin extent: initialExtent) translatedAndSquishedToBeWithin: allowedArea]]. 295671 ^ (self scrollBarSetback @ self screenTopSetback extent: initialExtent) translatedAndSquishedToBeWithin: allowedArea! ! 295672 295673!RealEstateAgent class methodsFor: 'framing' stamp: 'RAA 5/25/2000 08:13'! 295674initialFrameFor: aView world: aWorld 295675 "Find a plausible initial screen area for the supplied view. See called method." 295676 295677 ^ self initialFrameFor: aView initialExtent: aView initialExtent world: aWorld! ! 295678 295679!RealEstateAgent class methodsFor: 'framing' stamp: 'RAA 5/25/2000 09:15'! 295680strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent 295681 295682 self error: 'please use #strictlyStaggeredInitialFrameFor:initialExtent:world:'! ! 295683 295684!RealEstateAgent class methodsFor: 'framing' stamp: 'stephane.ducasse 9/25/2008 13:37'! 295685strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld 295686 "This method implements a staggered window placement policy that I (di) like. 295687 Basically it provides for up to 4 windows, staggered from each of the 4 corners. 295688 The windows are staggered so that there will always be a corner visible." 295689 295690 | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | 295691 295692 allowedArea :=(self maximumUsableAreaInWorld: aWorld) 295693 insetBy: (self scrollBarSetback @ self screenTopSetback extent: 0@0). 295694 (Flaps sharedFlapsAllowed) ifTrue: 295695 [allowedArea := self reduceByFlaps: allowedArea]. 295696 "Number to be staggered at each corner (less on small screens)" 295697 maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. 295698 "Amount by which to stagger (less on small screens)" 295699 grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. 295700 initialFrame := 0@0 extent: ((initialExtent 295701 "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) 295702 min: 600@400")). 295703 otherFrames := (aWorld windowsSatisfying: [:w | w isCollapsed not]) 295704 collect: [:w | w bounds]. 295705 0 to: maxLevel do: 295706 [:level | 295707 1 to: 4 do: 295708 [:ci | cornerSel := #(topLeft topRight bottomRight bottomLeft) at: ci. 295709 corner := allowedArea perform: cornerSel. 295710 "The extra grid//2 in delta helps to keep title tabs distinct" 295711 delta := (maxLevel-level*grid+(grid//2)) @ (level*grid). 295712 1 to: ci-1 do: [:i | delta := delta rotateBy: #right centerAt: 0@0]. "slow way" 295713 putativeCorner := corner + delta. 295714 free := true. 295715 otherFrames do: 295716 [:w | 295717 free := free & ((w perform: cornerSel) ~= putativeCorner)]. 295718 free ifTrue: 295719 [^ (initialFrame align: (initialFrame perform: cornerSel) 295720 with: putativeCorner) 295721 translatedAndSquishedToBeWithin: allowedArea]]]. 295722 "If all else fails..." 295723 ^ (self scrollBarSetback @ self screenTopSetback extent: initialFrame extent) 295724 translatedAndSquishedToBeWithin: allowedArea! ! 295725 295726 295727!RealEstateAgent class methodsFor: 'settings' stamp: 'alain.plantec 6/1/2008 20:02'! 295728screenTopSetback 295729 ^ 0! ! 295730 295731!RealEstateAgent class methodsFor: 'settings' stamp: 'alain.plantec 6/1/2008 20:06'! 295732scrollBarSetback 295733 ^ 16-3 "width = 16; inset from border by 3" 295734! ! 295735 295736!RealEstateAgent class methodsFor: 'settings' stamp: 'RAA 11/21/1999 22:55'! 295737standardWindowExtent 295738 "Answer the standard default extent for new windows. " 295739 295740 | effectiveExtent width strips height grid allowedArea maxLevel | 295741 effectiveExtent := self maximumUsableArea extent 295742 - (self scrollBarSetback @ self screenTopSetback). 295743 Preferences reverseWindowStagger ifTrue: 295744 ["NOTE: following copied from strictlyStaggeredInitialFrameFor:" 295745 allowedArea := self maximumUsableArea insetBy: ( 295746 self scrollBarSetback @ self screenTopSetback extent: 0@0 295747 ). 295748 "Number to be staggered at each corner (less on small screens)" 295749 maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. 295750 "Amount by which to stagger (less on small screens)" 295751 grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. 295752 ^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: StandardSize "600@400"]. 295753 width := (strips := self windowColumnsDesired) > 1 295754 ifTrue: 295755 [effectiveExtent x // strips] 295756 ifFalse: 295757 [(3 * effectiveExtent x) // 4]. 295758 height := (strips := self windowRowsDesired) > 1 295759 ifTrue: 295760 [effectiveExtent y // strips] 295761 ifFalse: 295762 [(3 * effectiveExtent y) //4]. 295763 ^ width @ height 295764 295765"RealEstateAgent standardWindowExtent"! ! 295766 295767!RealEstateAgent class methodsFor: 'settings' stamp: 'RAA 11/21/1999 22:54'! 295768windowColumnsDesired 295769 "Answer how many separate vertical columns of windows are wanted. 5/22/96 sw" 295770 ^ Preferences reverseWindowStagger 295771 ifTrue: 295772 [1] 295773 ifFalse: 295774 [(self maximumUsableArea width > 640) 295775 ifTrue: 295776 [2] 295777 ifFalse: 295778 [1]]! ! 295779 295780!RealEstateAgent class methodsFor: 'settings' stamp: 'RAA 11/21/1999 22:54'! 295781windowRowsDesired 295782 "Answer how many separate horizontal rows of windows are wanted. 5/22/96 sw" 295783 ^ Preferences reverseWindowStagger 295784 ifTrue: 295785 [1] 295786 ifFalse: 295787 [(self maximumUsableArea height > 480) 295788 ifTrue: 295789 [2] 295790 ifFalse: 295791 [1]]! ! 295792 295793 295794!RealEstateAgent class methodsFor: 'utilities' stamp: 'stephane.ducasse 9/25/2008 13:36'! 295795assignCollapseFrameFor: aSSView 295796 "Offer up a location along the left edge of the screen for a collapsed 295797 SSView. Make sure it doesn't overlap any other collapsed frames." 295798 | grid otherFrames topLeft viewBox collapsedFrame extent newFrame verticalBorderDistance top | 295799 grid := 8. 295800 verticalBorderDistance := 8. 295801 otherFrames := ( aSSView world windowsSatisfying: [:w | w ~= aSSView]) 295802 collect: [:w | w collapsedFrame] 295803 thenSelect: [:rect | rect notNil]. 295804 viewBox := self reduceByFlaps: aSSView world viewBox. 295805 collapsedFrame := aSSView collapsedFrame. 295806 extent := collapsedFrame notNil 295807 ifTrue: [collapsedFrame extent] 295808 ifFalse: [aSSView getRawLabel width + aSSView labelWidgetAllowance @ (aSSView labelHeight + 2)]. 295809 collapsedFrame notNil 295810 ifTrue: [(otherFrames 295811 anySatisfy: [:f | collapsedFrame intersects: f]) 295812 ifFalse: ["non overlapping" 295813 ^ collapsedFrame]]. 295814 top := viewBox top + verticalBorderDistance. 295815 [topLeft := viewBox left @ top. 295816 newFrame := topLeft extent: extent. 295817 newFrame bottom <= (viewBox height - verticalBorderDistance)] 295818 whileTrue: [(otherFrames 295819 anySatisfy: [:w | newFrame intersects: w]) 295820 ifFalse: ["no overlap" 295821 ^ newFrame]. 295822 top := top + grid]. 295823 "If all else fails... (really to many wins here)" 295824 ^ 0 @ 0 extent: extent! ! 295825 295826!RealEstateAgent class methodsFor: 'utilities' stamp: 'stephane.ducasse 9/25/2008 13:36'! 295827assignCollapsePointFor: aSSView 295828 "Offer up a location along the left edge of the screen for a collapsed 295829 SSView. Make sure it doesn't overlap any other collapsed frames." 295830 | grid otherFrames y free topLeft viewBox | 295831 grid := 24. 295832 "should be mult of 8, since manual move is gridded by 8" 295833 otherFrames := ( aSSView world windowsSatisfying: [:w | true]) 295834 collect: [:w | w collapsedFrame] 295835 thenSelect: [:rect | rect notNil]. 295836 viewBox := self reduceByFlaps: aSSView world viewBox. 295837 y := viewBox top. 295838 [(y := y + grid) <= (viewBox height - grid)] 295839 whileTrue: [topLeft := viewBox left @ y. 295840 free := true. 295841 otherFrames 295842 do: [:w | free := free & (topLeft ~= w topLeft)]. 295843 free 295844 ifTrue: [^ topLeft]]. 295845 "If all else fails..." 295846 ^ 0 @ 0! ! 295847 295848!RealEstateAgent class methodsFor: 'utilities' stamp: 'dgd 8/31/2003 19:52'! 295849reduceByFlaps: aScreenRect 295850 "Return a rectangle that won't interfere with default shared flaps" 295851 295852 Flaps sharedFlapsAllowed ifFalse: [^ aScreenRect copy]. 295853 (Flaps globalFlapTabsIfAny allSatisfy: 295854 [:ft | ft flapID = 'Painting' translated or: [ft edgeToAdhereTo == #bottom]]) 295855 ifTrue: [^ aScreenRect withHeight: aScreenRect height - 18] 295856 ifFalse: [^ aScreenRect insetBy: 18]! ! 295857AbstractEvent subclass: #RecategorizedEvent 295858 instanceVariableNames: 'oldCategory' 295859 classVariableNames: '' 295860 poolDictionaries: '' 295861 category: 'System-Change Notification'! 295862 295863!RecategorizedEvent methodsFor: 'accessing' stamp: 'rw 7/1/2003 20:08'! 295864oldCategory 295865 295866 ^oldCategory! ! 295867 295868!RecategorizedEvent methodsFor: 'accessing' stamp: 'rw 7/1/2003 20:08'! 295869oldCategory: aCategoryName 295870 295871 oldCategory := aCategoryName! ! 295872 295873 295874!RecategorizedEvent methodsFor: 'printing' stamp: 'rw 7/2/2003 09:12'! 295875printEventKindOn: aStream 295876 295877 aStream nextPutAll: 'Recategorized'! ! 295878 295879 295880!RecategorizedEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 19:51'! 295881isRecategorized 295882 295883 ^true! ! 295884 295885"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 295886 295887RecategorizedEvent class 295888 instanceVariableNames: ''! 295889 295890!RecategorizedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:09'! 295891changeKind 295892 295893 ^#Recategorized! ! 295894 295895!RecategorizedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 11:20'! 295896supportedKinds 295897 295898 ^Array with: self classKind with: self methodKind! ! 295899 295900 295901!RecategorizedEvent class methodsFor: 'instance creation' stamp: 'rw 7/9/2003 14:21'! 295902class: aClass category: cat oldCategory: oldName 295903 295904 ^(self class: aClass category: cat) oldCategory: oldName! ! 295905 295906!RecategorizedEvent class methodsFor: 'instance creation' stamp: 'rw 7/31/2003 16:35'! 295907method: aMethod protocol: prot class: aClass oldProtocol: oldName 295908 295909 ^(self method: aMethod protocol: prot class: aClass) oldCategory: oldName! ! 295910MessageSet subclass: #RecentMessageSet 295911 instanceVariableNames: '' 295912 classVariableNames: '' 295913 poolDictionaries: '' 295914 category: 'Tools-Browser'! 295915!RecentMessageSet commentStamp: 'sw 8/1/2002 17:40' prior: 0! 295916RecentMessageSet is a message set that shows the most recently-submitted methods, in chronological order.! 295917 295918 295919!RecentMessageSet methodsFor: 'contents' stamp: 'sd 11/20/2005 21:27'! 295920contents: c notifying: n 295921 | result | 295922 result := super contents: c notifying: n. 295923 result == true ifTrue: 295924 [self reformulateList]. 295925 ^ result! ! 295926 295927 295928!RecentMessageSet methodsFor: 'message functions' stamp: 'md 4/30/2008 15:39'! 295929messageListMenu: aMenu shifted: shifted 295930 "Answer the message-list menu" 295931 295932 shifted ifTrue: [^ self shiftedMessageListMenu: aMenu]. 295933 aMenu addList:#( 295934 ('what to show...' offerWhatToShowMenu) 295935 - 295936 ('browse full (b)' browseMethodFull) 295937 ('browse hierarchy (h)' classHierarchy) 295938 ('browse method (O)' openSingleMessageBrowser) 295939 ('browse protocol (p)' browseFullProtocol) 295940 - 295941 ('fileOut (o)' fileOutMessage) 295942 ('copy selector (c)' copySelector) 295943 - 295944 ('senders of... (n)' browseSendersOfMessages) 295945 ('implementors of... (m)' browseMessages) 295946 ('inheritance (i)' methodHierarchy) 295947 ('versions (v)' browseVersions) 295948 - 295949 ('inst var refs...' browseInstVarRefs) 295950 ('inst var defs...' browseInstVarDefs) 295951 ('class var refs...' browseClassVarRefs) 295952 ('class variables' browseClassVariables) 295953 ('class refs (N)' browseClassRefs) 295954 - 295955 ('remove method (x)' removeMessage) 295956 ('remove from RecentSubmissions' removeFromRecentSubmissions) 295957 - 295958 ('more...' shiftedYellowButtonActivity)). 295959 ^ aMenu! ! 295960 295961!RecentMessageSet methodsFor: 'message functions' stamp: 'sd 11/20/2005 21:27'! 295962removeFromRecentSubmissions 295963 "Remove the currently-selected method from the RecentSubmissions list" 295964 295965 | aClass methodSym | 295966 ((aClass := self selectedClassOrMetaClass) notNil and: [(methodSym := self selectedMessageName) notNil]) 295967 ifTrue: 295968 [Utilities purgeFromRecentSubmissions: (MethodReference new setStandardClass: aClass methodSymbol: methodSym). 295969 self reformulateList]! ! 295970 295971 295972!RecentMessageSet methodsFor: 'message list' stamp: 'sw 7/28/2002 23:20'! 295973addExtraShiftedItemsTo: aMenu 295974 "The shifted selector-list menu is being built. Overridden here to defeat the presence of the items that add or change order, since RecentMessageSet defines methods & order explicitly based on external criteria" 295975 295976 aMenu add: 'set size of recent history...' action: #setRecentHistorySize! ! 295977 295978!RecentMessageSet methodsFor: 'message list' stamp: 'rbb 3/1/2005 11:11'! 295979setRecentHistorySize 295980 "Let the user specify the recent history size" 295981 295982 | aReply aNumber | 295983 aReply := UIManager default request: 'How many recent methods 295984should be maintained?' initialAnswer: Utilities numberOfRecentSubmissionsToStore asString. 295985 aReply isEmptyOrNil ifFalse: 295986 [aNumber := aReply asNumber rounded. 295987 (aNumber > 1 and: [aNumber <= 1000]) 295988 ifTrue: 295989 [Utilities numberOfRecentSubmissionsToStore: aNumber. 295990 self inform: 'Okay, ', aNumber asString, ' is the new size of the recent method history'] 295991 ifFalse: 295992 [self inform: 'Sorry, must be a number between 2 & 1000']] 295993 ! ! 295994 295995 295996!RecentMessageSet methodsFor: 'selection'! 295997maybeSetSelection 295998 "After a browser's message list is changed, this message is dispatched to the model, to give it a chance to refigure a selection" 295999 self messageListIndex: 1! ! 296000 296001 296002!RecentMessageSet methodsFor: 'update' stamp: 'sw 1/28/2001 20:59'! 296003growable 296004 "Answer whether the receiver can be changed by manual additions & deletions" 296005 296006 ^ false! ! 296007 296008!RecentMessageSet methodsFor: 'update' stamp: 'sd 11/20/2005 21:27'! 296009reformulateList 296010 | myList | 296011 "Reformulate the receiver's list. Exclude methods now deleted" 296012 296013 myList := Utilities recentMethodSubmissions reversed select: [ :each | each isValid]. 296014 self initializeMessageList: myList. 296015 self messageListIndex: (messageList size min: 1). "0 or 1" 296016 self changed: #messageList. 296017 self changed: #messageListIndex! ! 296018 296019!RecentMessageSet methodsFor: 'update' stamp: 'sd 11/20/2005 21:27'! 296020updateListsAndCodeIn: aWindow 296021 296022 | recentFromUtilities | 296023 "RAA 20 june 2000 - a recent change to how messages were displayed in the list caused them not to match what was stored in Utilities. This caused the recent submissions to be continuously updated. The hack below fixed that problem" 296024 296025 self flag: #mref. "in second pass, use simpler test" 296026 296027 self canDiscardEdits ifFalse: [^ self]. 296028 recentFromUtilities := Utilities mostRecentlySubmittedMessage,' '. 296029 (messageList first asStringOrText asString beginsWith: recentFromUtilities) 296030 ifFalse: 296031 [self reformulateList] 296032 ifTrue: 296033 [self updateCodePaneIfNeeded]! ! 296034Object subclass: #Rectangle 296035 instanceVariableNames: 'origin corner' 296036 classVariableNames: '' 296037 poolDictionaries: '' 296038 category: 'Graphics-Primitives'! 296039!Rectangle commentStamp: '<historical>' prior: 0! 296040I represent a rectangular area of the screen. Arithmetic functions take points as arguments and carry out scaling and translating operations to create new instances of me. Rectangle functions create new instances by determining intersections of rectangles with rectangles.! 296041 296042 296043!Rectangle methodsFor: '*Polymorph-Geometry' stamp: 'gvc 6/25/2007 14:00'! 296044quickMergePoint: aPoint 296045 "Answer the receiver if it encloses the given point or the expansion of the 296046 receiver to do so if it doesn't. " 296047 296048 | useRcvr minX maxX minY maxY | 296049 useRcvr := true. 296050 minX := aPoint x < origin x ifTrue: [useRcvr := false. aPoint x] ifFalse: [origin x]. 296051 maxX := aPoint x >= corner x ifTrue: [useRcvr := false. aPoint x + 1] ifFalse: [corner x]. 296052 minY := aPoint y < origin y ifTrue: [useRcvr := false. aPoint y] ifFalse: [origin y]. 296053 maxY := aPoint y >= corner y ifTrue: [useRcvr := false. aPoint y + 1] ifFalse: [corner y]. 296054 ^useRcvr 296055 ifTrue: [self] 296056 ifFalse: [minX@minY corner: maxX@maxY] 296057! ! 296058 296059 296060!Rectangle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/24/2007 12:51'! 296061interpolateTo: end at: amountDone 296062 "Interpolate between the instance and end after the specified amount has been done (0 - 1)." 296063 296064 ^(self origin interpolateTo: end origin at: amountDone) 296065 corner: (self corner interpolateTo: end corner at: amountDone)! ! 296066 296067!Rectangle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/7/2006 10:44'! 296068pointAtSideOrCorner: loc 296069 "Answer the point represented by the given location." 296070 296071 ^ self 296072 perform: (#(topLeft topCenter topRight rightCenter 296073 bottomRight bottomCenter bottomLeft leftCenter) 296074 at: (#(topLeft top topRight right 296075 bottomRight bottom bottomLeft left) indexOf: loc)) 296076 296077 ! ! 296078 296079!Rectangle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/13/2006 14:08'! 296080scaledAndCenteredIn: aRect 296081 "Answer a new rectangle that fits into aRectangle and is centered 296082 but with the same aspect ratio as the receiver." 296083 296084 ^self width / aRect width > (self height / aRect height) 296085 ifTrue: [aRect left @ (aRect leftCenter y - (self height * (aRect width / self width) / 2)) 296086 corner: aRect right @ (aRect rightCenter y + (self height * (aRect width / self width) / 2))] 296087 ifFalse: [aRect topCenter x - (self width * (aRect height / self height) / 2) @ aRect top 296088 corner: (aRect topCenter x + (self width * (aRect height / self height) / 2)) @ aRect bottom]! ! 296089 296090 296091!Rectangle methodsFor: '*morphic-truncation and roundoff' stamp: 'wiz 2/12/2006 15:58'! 296092ceiling 296093"Answer the integer rectange to the bottom right of receiver. 296094Return reciever if it already and integerRectange." 296095 296096self isIntegerRectangle ifTrue: [ ^ self ] . 296097 296098^origin ceiling corner: corner ceiling! ! 296099 296100!Rectangle methodsFor: '*morphic-truncation and roundoff' stamp: 'wiz 2/12/2006 01:37'! 296101compressTo: grid 296102 "Answer a Rectangle whose origin and corner are rounded to grid x and grid y. 296103 Rounding is done by upper value on origin and lower value on corner so that 296104 rounded rectangle is inside self." 296105 296106 ^Rectangle origin: (origin roundUpTo: grid) 296107 corner: (corner roundDownTo: grid)! ! 296108 296109!Rectangle methodsFor: '*morphic-truncation and roundoff' stamp: 'wiz 2/12/2006 01:37'! 296110compressed 296111 "Answer a Rectangle whose origin and corner are rounded to integers. 296112 Rounding is done by upper value on origin and lower value on corner so that 296113 rounded rectangle is inside self." 296114 296115 ^Rectangle origin: origin ceiling corner: corner floor! ! 296116 296117!Rectangle methodsFor: '*morphic-truncation and roundoff' stamp: 'nice 2/5/2006 16:51'! 296118expandTo: grid 296119 "Answer a Rectangle whose origin and corner are rounded to grid x and grid y. 296120 Rounding is done by upper value on origin and lower value on corner so that 296121 self is inside rounded rectangle." 296122 296123 ^Rectangle origin: (origin roundDownTo: grid) 296124 corner: (corner roundUpTo: grid)! ! 296125 296126!Rectangle methodsFor: '*morphic-truncation and roundoff' stamp: 'nice 2/5/2006 16:52'! 296127expanded 296128 "Answer a Rectangle whose origin and corner are rounded to integers. 296129 Rounding is done by upper value on origin and lower value on corner so that 296130 self is inside rounded rectangle." 296131 296132 ^Rectangle origin: origin floor corner: corner ceiling! ! 296133 296134!Rectangle methodsFor: '*morphic-truncation and roundoff' stamp: 'wiz 2/12/2006 15:56'! 296135floor 296136"Answer the integer rectange to the topleft of receiver. 296137Return reciever if it already and integerRectange." 296138 296139self isIntegerRectangle ifTrue: [ ^ self ] . 296140 296141^origin floor corner: corner floor! ! 296142 296143!Rectangle methodsFor: '*morphic-truncation and roundoff' stamp: 'wiz 1/11/2006 18:39'! 296144isIntegerRectangle 296145"Answer true if all component of receiver are integral." 296146 296147^origin isIntegerPoint and: [ corner isIntegerPoint ]! ! 296148 296149!Rectangle methodsFor: '*morphic-truncation and roundoff' stamp: 'nice 2/5/2006 16:53'! 296150roundTo: grid 296151 "Answer a Rectangle whose origin and corner are rounded to grid x and grid y." 296152 296153 ^Rectangle origin: (origin roundTo: grid) 296154 corner: (corner roundTo: grid)! ! 296155 296156 296157!Rectangle methodsFor: 'accessing' stamp: 'acg 2/23/2000 00:52'! 296158aboveCenter 296159 "Answer the point slightly above the center of the receiver." 296160 296161 ^self topLeft + self bottomRight // (2@3)! ! 296162 296163!Rectangle methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 296164area 296165 "Answer the receiver's area, the product of width and height." 296166 | w | 296167 (w := self width) <= 0 ifTrue: [ ^ 0 ]. 296168 ^ w * self height max: 0! ! 296169 296170!Rectangle methodsFor: 'accessing'! 296171bottom 296172 "Answer the position of the receiver's bottom horizontal line." 296173 296174 ^corner y! ! 296175 296176!Rectangle methodsFor: 'accessing' stamp: 'ar 10/26/2000 22:17'! 296177bottom: aNumber 296178 ^origin corner: corner x @ aNumber! ! 296179 296180!Rectangle methodsFor: 'accessing'! 296181bottomCenter 296182 "Answer the point at the center of the bottom horizontal line of the 296183 receiver." 296184 296185 ^self center x @ self bottom! ! 296186 296187!Rectangle methodsFor: 'accessing'! 296188bottomLeft 296189 "Answer the point at the left edge of the bottom horizontal line of the 296190 receiver." 296191 296192 ^origin x @ corner y! ! 296193 296194!Rectangle methodsFor: 'accessing'! 296195bottomRight 296196 "Answer the point at the right edge of the bottom horizontal line of the 296197 receiver." 296198 296199 ^corner! ! 296200 296201!Rectangle methodsFor: 'accessing'! 296202boundingBox 296203 ^ self! ! 296204 296205!Rectangle methodsFor: 'accessing'! 296206center 296207 "Answer the point at the center of the receiver." 296208 296209 ^self topLeft + self bottomRight // 2! ! 296210 296211!Rectangle methodsFor: 'accessing'! 296212corner 296213 "Answer the point at the bottom right corner of the receiver." 296214 296215 ^corner! ! 296216 296217!Rectangle methodsFor: 'accessing'! 296218corners 296219 "Return an array of corner points in the order of a quadrilateral spec for WarpBlt." 296220 296221 ^ Array 296222 with: self topLeft 296223 with: self bottomLeft 296224 with: self bottomRight 296225 with: self topRight 296226! ! 296227 296228!Rectangle methodsFor: 'accessing'! 296229extent 296230 "Answer with a rectangle with origin 0@0 and corner the receiver's 296231 width @ the receiver's height." 296232 296233 ^corner - origin! ! 296234 296235!Rectangle methodsFor: 'accessing'! 296236height 296237 "Answer the height of the receiver." 296238 296239 ^corner y - origin y! ! 296240 296241!Rectangle methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 296242innerCorners 296243 "Return an array of inner corner points, 296244 ie, the most extreme pixels included, 296245 in the order of a quadrilateral spec for WarpBlt" 296246 | r1 | 296247 r1 := self topLeft corner: self bottomRight - (1 @ 1). 296248 ^ Array 296249 with: r1 topLeft 296250 with: r1 bottomLeft 296251 with: r1 bottomRight 296252 with: r1 topRight! ! 296253 296254!Rectangle methodsFor: 'accessing'! 296255left 296256 "Answer the position of the receiver's left vertical line." 296257 296258 ^origin x! ! 296259 296260!Rectangle methodsFor: 'accessing' stamp: 'ar 10/26/2000 22:16'! 296261left: aNumber 296262 ^aNumber @ origin y corner: corner! ! 296263 296264!Rectangle methodsFor: 'accessing'! 296265leftCenter 296266 "Answer the point at the center of the receiver's left vertical line." 296267 296268 ^self left @ self center y! ! 296269 296270!Rectangle methodsFor: 'accessing'! 296271origin 296272 "Answer the point at the top left corner of the receiver." 296273 296274 ^origin! ! 296275 296276!Rectangle methodsFor: 'accessing'! 296277right 296278 "Answer the position of the receiver's right vertical line." 296279 296280 ^corner x! ! 296281 296282!Rectangle methodsFor: 'accessing' stamp: 'ar 10/26/2000 22:17'! 296283right: aNumber 296284 ^origin corner: aNumber @ corner y! ! 296285 296286!Rectangle methodsFor: 'accessing'! 296287rightCenter 296288 "Answer the point at the center of the receiver's right vertical line." 296289 296290 ^self right @ self center y! ! 296291 296292!Rectangle methodsFor: 'accessing'! 296293top 296294 "Answer the position of the receiver's top horizontal line." 296295 296296 ^origin y! ! 296297 296298!Rectangle methodsFor: 'accessing' stamp: 'ar 10/26/2000 22:17'! 296299top: aNumber 296300 ^origin x @ aNumber corner: corner! ! 296301 296302!Rectangle methodsFor: 'accessing'! 296303topCenter 296304 "Answer the point at the center of the receiver's top horizontal line." 296305 296306 ^self center x @ self top! ! 296307 296308!Rectangle methodsFor: 'accessing'! 296309topLeft 296310 "Answer the point at the top left corner of the receiver's top horizontal line." 296311 296312 ^origin 296313! ! 296314 296315!Rectangle methodsFor: 'accessing'! 296316topRight 296317 "Answer the point at the top right corner of the receiver's top horizontal 296318 line." 296319 296320 ^corner x @ origin y! ! 296321 296322!Rectangle methodsFor: 'accessing'! 296323width 296324 "Answer the width of the receiver." 296325 296326 ^corner x - origin x! ! 296327 296328 296329!Rectangle methodsFor: 'comparing'! 296330= aRectangle 296331 "Answer true if the receiver's species, origin and corner match aRectangle's." 296332 296333 self species = aRectangle species 296334 ifTrue: [^origin = aRectangle origin and: [corner = aRectangle corner]] 296335 ifFalse: [^false]! ! 296336 296337!Rectangle methodsFor: 'comparing'! 296338hash 296339 "Hash is reimplemented because = is implemented." 296340 296341 ^origin hash bitXor: corner hash! ! 296342 296343 296344!Rectangle methodsFor: 'fmp' stamp: 'lr 7/4/2009 10:42'! 296345deltaToEnsureInOrCentered: r extra: aNumber 296346 | dX dY halfXDiff halfYDiff | 296347 dX := dY := 0. 296348 halfXDiff := ((r width - self width) * aNumber) truncated. 296349 halfYDiff := ((r height - self height) * aNumber) truncated. 296350 self left < r left 296351 ifTrue: [ dX := self left - r left - halfXDiff ] 296352 ifFalse: 296353 [ self right > r right ifTrue: [ dX := self right - r right + halfXDiff ] ]. 296354 self top < r top 296355 ifTrue: [ dY := self top - r top - halfYDiff ] 296356 ifFalse: 296357 [ self bottom > r bottom ifTrue: [ dY := self bottom - r bottom + halfYDiff ] ]. 296358 ^ dX @ dY! ! 296359 296360 296361!Rectangle methodsFor: 'printing'! 296362printOn: aStream 296363 "Refer to the comment in Object|printOn:." 296364 296365 origin printOn: aStream. 296366 aStream nextPutAll: ' corner: '. 296367 corner printOn: aStream! ! 296368 296369!Rectangle methodsFor: 'printing' stamp: 'MPW 1/4/1901 08:18'! 296370propertyListOn: aStream 296371 " {x=a; y=b; width=c; height=d} " 296372 aStream print:'{ x='; write:origin x; 296373 print:' y='; write:origin y; 296374 print:' width='; write:self extent x; 296375 print:' height='; write:self extent y; 296376 print:'};'. 296377! ! 296378 296379!Rectangle methodsFor: 'printing'! 296380storeOn: aStream 296381 "printed form is good for storing too" 296382 self printOn: aStream! ! 296383 296384 296385!Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/22/1998 16:11'! 296386adjustTo: newRect along: side 296387 "Return a copy adjusted to fit a neighbor that has changed size." 296388 side = #left ifTrue: [^ self withRight: newRect left]. 296389 side = #right ifTrue: [^ self withLeft: newRect right]. 296390 side = #top ifTrue: [^ self withBottom: newRect top]. 296391 side = #bottom ifTrue: [^ self withTop: newRect bottom].! ! 296392 296393!Rectangle methodsFor: 'rectangle functions' stamp: 'ar 1/5/2002 18:04'! 296394allAreasOutsideList: aCollection do: aBlock 296395 "Enumerate aBlock with all areas of the receiver not overlapping 296396 any rectangle in the given collection" 296397 ^self allAreasOutsideList: aCollection startingAt: 1 do: aBlock! ! 296398 296399!Rectangle methodsFor: 'rectangle functions' stamp: 'lr 7/4/2009 10:42'! 296400allAreasOutsideList: aCollection startingAt: startIndex do: aBlock 296401 "Enumerate aBlock with all areas of the receiver not overlapping 296402 any rectangle in the given collection" 296403 | yOrigin yCorner aRectangle index rr | 296404 index := startIndex. 296405 296406 "Find the next intersecting rectangle from aCollection" 296407 296408 [ index <= aCollection size ifFalse: [ ^ aBlock value: self ]. 296409 aRectangle := aCollection at: index. 296410 origin <= aRectangle corner and: [ aRectangle origin <= corner ] ] whileFalse: [ index := index + 1 ]. 296411 296412 "aRectangle is intersecting; process it" 296413 aRectangle origin y > origin y 296414 ifTrue: 296415 [ rr := origin corner: corner x @ (yOrigin := aRectangle origin y). 296416 rr 296417 allAreasOutsideList: aCollection 296418 startingAt: index + 1 296419 do: aBlock ] 296420 ifFalse: [ yOrigin := origin y ]. 296421 aRectangle corner y < corner y 296422 ifTrue: 296423 [ rr := origin x @ (yCorner := aRectangle corner y) corner: corner. 296424 rr 296425 allAreasOutsideList: aCollection 296426 startingAt: index + 1 296427 do: aBlock ] 296428 ifFalse: [ yCorner := corner y ]. 296429 aRectangle origin x > origin x ifTrue: 296430 [ rr := origin x @ yOrigin corner: aRectangle origin x @ yCorner. 296431 rr 296432 allAreasOutsideList: aCollection 296433 startingAt: index + 1 296434 do: aBlock ]. 296435 aRectangle corner x < corner x ifTrue: 296436 [ rr := aRectangle corner x @ yOrigin corner: corner x @ yCorner. 296437 rr 296438 allAreasOutsideList: aCollection 296439 startingAt: index + 1 296440 do: aBlock ]! ! 296441 296442!Rectangle methodsFor: 'rectangle functions' stamp: 'lr 7/4/2009 10:42'! 296443amountToTranslateWithin: aRectangle 296444 "Answer a Point, delta, such that self + delta is forced within aRectangle." 296445 "Altered so as to prefer to keep self topLeft inside when all of self 296446 cannot be made to fit 7/27/96 di" 296447 | dx dy | 296448 dx := 0. 296449 dy := 0. 296450 self right > aRectangle right ifTrue: [ dx := aRectangle right - self right ]. 296451 self bottom > aRectangle bottom ifTrue: [ dy := aRectangle bottom - self bottom ]. 296452 self left + dx < aRectangle left ifTrue: [ dx := aRectangle left - self left ]. 296453 self top + dy < aRectangle top ifTrue: [ dy := aRectangle top - self top ]. 296454 ^ dx @ dy! ! 296455 296456!Rectangle methodsFor: 'rectangle functions' stamp: 'lr 7/4/2009 10:42'! 296457areasOutside: aRectangle 296458 "Answer an Array of Rectangles comprising the parts of the receiver not 296459 intersecting aRectangle." 296460 "Make sure the intersection is non-empty" 296461 | areas yOrigin yCorner | 296462 (self intersects: aRectangle) ifFalse: [ ^ Array with: self ]. 296463 areas := OrderedCollection new. 296464 aRectangle origin y > origin y 296465 ifTrue: 296466 [ areas addLast: (origin corner: corner x @ (yOrigin := aRectangle origin y)) ] 296467 ifFalse: [ yOrigin := origin y ]. 296468 aRectangle corner y < corner y 296469 ifTrue: 296470 [ areas addLast: (origin x @ (yCorner := aRectangle corner y) corner: corner) ] 296471 ifFalse: [ yCorner := corner y ]. 296472 aRectangle origin x > origin x ifTrue: 296473 [ areas addLast: (origin x @ yOrigin corner: aRectangle origin x @ yCorner) ]. 296474 aRectangle corner x < corner x ifTrue: 296475 [ areas addLast: (aRectangle corner x @ yOrigin corner: corner x @ yCorner) ]. 296476 ^ areas! ! 296477 296478!Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/21/1998 16:00'! 296479bordersOn: her along: herSide 296480 (herSide = #right and: [self left = her right]) 296481 | (herSide = #left and: [self right = her left]) 296482 ifTrue: 296483 [^ (self top max: her top) < (self bottom min: her bottom)]. 296484 (herSide = #bottom and: [self top = her bottom]) 296485 | (herSide = #top and: [self bottom = her top]) 296486 ifTrue: 296487 [^ (self left max: her left) < (self right min: her right)]. 296488 ^ false! ! 296489 296490!Rectangle methodsFor: 'rectangle functions'! 296491encompass: aPoint 296492 "Answer a Rectangle that contains both the receiver and aPoint. 5/30/96 sw" 296493 296494 ^ Rectangle 296495 origin: (origin min: aPoint) 296496 corner: (corner max: aPoint)! ! 296497 296498!Rectangle methodsFor: 'rectangle functions' stamp: 'md 10/4/2005 14:42'! 296499expandBy: delta 296500 "Answer a Rectangle that is outset from the receiver by delta. delta is a 296501 Rectangle, Point, or scalar." 296502 296503 (delta isRectangle) 296504 ifTrue: [^Rectangle 296505 origin: origin - delta origin 296506 corner: corner + delta corner] 296507 ifFalse: [^Rectangle 296508 origin: origin - delta 296509 corner: corner + delta]! ! 296510 296511!Rectangle methodsFor: 'rectangle functions' stamp: 'md 10/4/2005 14:42'! 296512extendBy: delta 296513 "Answer a Rectangle with the same origin as the receiver, but whose corner is offset by delta. delta is a 296514 Rectangle, Point, or scalar." 296515 296516 (delta isRectangle) 296517 ifTrue: [^Rectangle 296518 origin: origin 296519 corner: corner + delta corner] 296520 ifFalse: [^Rectangle 296521 origin: origin 296522 corner: corner + delta]! ! 296523 296524!Rectangle methodsFor: 'rectangle functions' stamp: 'lr 7/4/2009 10:42'! 296525forPoint: aPoint closestSideDistLen: sideDistLenBlock 296526 "Evaluate the block with my side (symbol) closest to aPoint, 296527 the approx distance of aPoint from that side, and 296528 the length of the side (or 0 if aPoint is beyond the side)" 296529 | side | 296530 side := self sideNearestTo: aPoint. 296531 side == #right ifTrue: 296532 [ ^ sideDistLenBlock 296533 value: side 296534 value: (self right - aPoint x) abs 296535 value: ((aPoint y 296536 between: self top 296537 and: self bottom) 296538 ifTrue: [ self height ] 296539 ifFalse: [ 0 ]) ]. 296540 side == #left ifTrue: 296541 [ ^ sideDistLenBlock 296542 value: side 296543 value: (self left - aPoint x) abs 296544 value: ((aPoint y 296545 between: self top 296546 and: self bottom) 296547 ifTrue: [ self height ] 296548 ifFalse: [ 0 ]) ]. 296549 side == #bottom ifTrue: 296550 [ ^ sideDistLenBlock 296551 value: side 296552 value: (self bottom - aPoint y) abs 296553 value: ((aPoint x 296554 between: self left 296555 and: self right) 296556 ifTrue: [ self width ] 296557 ifFalse: [ 0 ]) ]. 296558 side == #top ifTrue: 296559 [ ^ sideDistLenBlock 296560 value: side 296561 value: (self top - aPoint y) abs 296562 value: ((aPoint x 296563 between: self left 296564 and: self right) 296565 ifTrue: [ self width ] 296566 ifFalse: [ 0 ]) ]! ! 296567 296568!Rectangle methodsFor: 'rectangle functions' stamp: 'md 10/2/2005 21:51'! 296569insetBy: delta 296570 "Answer a Rectangle that is inset from the receiver by delta. delta is a 296571 Rectangle, Point, or scalar." 296572 296573 296574 (delta isRectangle) 296575 ifTrue: [^Rectangle 296576 origin: origin + delta origin 296577 corner: corner - delta corner] 296578 ifFalse: [^Rectangle 296579 origin: origin + delta 296580 corner: corner - delta]! ! 296581 296582!Rectangle methodsFor: 'rectangle functions'! 296583insetOriginBy: originDeltaPoint cornerBy: cornerDeltaPoint 296584 "Answer a Rectangle that is inset from the receiver by a given amount in 296585 the origin and corner." 296586 296587 ^Rectangle 296588 origin: origin + originDeltaPoint 296589 corner: corner - cornerDeltaPoint! ! 296590 296591!Rectangle methodsFor: 'rectangle functions' stamp: 'lr 7/4/2009 10:42'! 296592intersect: aRectangle 296593 "Answer a Rectangle that is the area in which the receiver overlaps with 296594 aRectangle. Optimized for speed; old code read: 296595 ^Rectangle 296596 origin: (origin max: aRectangle origin) 296597 corner: (corner min: aRectangle corner) 296598 " 296599 | aPoint left right top bottom | 296600 aPoint := aRectangle origin. 296601 aPoint x > origin x 296602 ifTrue: [ left := aPoint x ] 296603 ifFalse: [ left := origin x ]. 296604 aPoint y > origin y 296605 ifTrue: [ top := aPoint y ] 296606 ifFalse: [ top := origin y ]. 296607 aPoint := aRectangle corner. 296608 aPoint x < corner x 296609 ifTrue: [ right := aPoint x ] 296610 ifFalse: [ right := corner x ]. 296611 aPoint y < corner y 296612 ifTrue: [ bottom := aPoint y ] 296613 ifFalse: [ bottom := corner y ]. 296614 ^ Rectangle 296615 origin: left @ top 296616 corner: right @ bottom! ! 296617 296618!Rectangle methodsFor: 'rectangle functions'! 296619merge: aRectangle 296620 "Answer a Rectangle that contains both the receiver and aRectangle." 296621 296622 ^Rectangle 296623 origin: (origin min: aRectangle origin) 296624 corner: (corner max: aRectangle corner)! ! 296625 296626!Rectangle methodsFor: 'rectangle functions' stamp: 'md 10/4/2005 14:41'! 296627outsetBy: delta 296628 "Answer a Rectangle that is outset from the receiver by delta. delta is a 296629 Rectangle, Point, or scalar." 296630 296631 (delta isRectangle) 296632 ifTrue: [^Rectangle 296633 origin: origin - delta origin 296634 corner: corner + delta corner] 296635 ifFalse: [^Rectangle 296636 origin: origin - delta 296637 corner: corner + delta]! ! 296638 296639!Rectangle methodsFor: 'rectangle functions' stamp: 'lr 7/4/2009 10:42'! 296640pointNearestTo: aPoint 296641 "Return the point on my border closest to aPoint" 296642 | side | 296643 (self containsPoint: aPoint) 296644 ifTrue: 296645 [ side := self sideNearestTo: aPoint. 296646 side == #right ifTrue: [ ^ self right @ aPoint y ]. 296647 side == #left ifTrue: [ ^ self left @ aPoint y ]. 296648 side == #bottom ifTrue: [ ^ aPoint x @ self bottom ]. 296649 side == #top ifTrue: [ ^ aPoint x @ self top ] ] 296650 ifFalse: [ ^ aPoint adhereTo: self ]! ! 296651 296652!Rectangle methodsFor: 'rectangle functions' stamp: 'lr 7/4/2009 10:42'! 296653quickMerge: aRectangle 296654 "Answer the receiver if it encloses the given rectangle or the merge of the two rectangles if it doesn't. THis method is an optimization to reduce extra rectangle creations." 296655 | useRcvr rOrigin rCorner minX maxX minY maxY | 296656 useRcvr := true. 296657 rOrigin := aRectangle topLeft. 296658 rCorner := aRectangle bottomRight. 296659 minX := rOrigin x < origin x 296660 ifTrue: 296661 [ useRcvr := false. 296662 rOrigin x ] 296663 ifFalse: [ origin x ]. 296664 maxX := rCorner x > corner x 296665 ifTrue: 296666 [ useRcvr := false. 296667 rCorner x ] 296668 ifFalse: [ corner x ]. 296669 minY := rOrigin y < origin y 296670 ifTrue: 296671 [ useRcvr := false. 296672 rOrigin y ] 296673 ifFalse: [ origin y ]. 296674 maxY := rCorner y > corner y 296675 ifTrue: 296676 [ useRcvr := false. 296677 rCorner y ] 296678 ifFalse: [ corner y ]. 296679 useRcvr 296680 ifTrue: [ ^ self ] 296681 ifFalse: 296682 [ ^ Rectangle 296683 origin: minX @ minY 296684 corner: maxX @ maxY ]! ! 296685 296686!Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/20/97 23:01'! 296687rectanglesAt: y height: ht 296688 (y+ht) > self bottom ifTrue: [^ Array new]. 296689 ^ Array with: (origin x @ y corner: corner x @ (y+ht))! ! 296690 296691!Rectangle methodsFor: 'rectangle functions' stamp: 'lr 7/4/2009 10:42'! 296692sideNearestTo: aPoint 296693 | distToLeft distToRight distToTop distToBottom closest side | 296694 distToLeft := aPoint x - self left. 296695 distToRight := self right - aPoint x. 296696 distToTop := aPoint y - self top. 296697 distToBottom := self bottom - aPoint y. 296698 closest := distToLeft. 296699 side := #left. 296700 distToRight < closest ifTrue: 296701 [ closest := distToRight. 296702 side := #right ]. 296703 distToTop < closest ifTrue: 296704 [ closest := distToTop. 296705 side := #top ]. 296706 distToBottom < closest ifTrue: 296707 [ closest := distToBottom. 296708 side := #bottom ]. 296709 ^ side 296710 " 296711 | r | r _ Rectangle fromUser. 296712Display border: r width: 1. 296713[Sensor anyButtonPressed] whileFalse: 296714 [(r sideNearestTo: Sensor cursorPoint) , ' ' displayAt: 0@0] 296715"! ! 296716 296717!Rectangle methodsFor: 'rectangle functions'! 296718translatedToBeWithin: aRectangle 296719 "Answer a copy of the receiver that does not extend beyond aRectangle. 7/8/96 sw" 296720 296721 ^ self translateBy: (self amountToTranslateWithin: aRectangle)! ! 296722 296723!Rectangle methodsFor: 'rectangle functions'! 296724withBottom: y 296725 "Return a copy of me with a different bottom y" 296726 ^ origin x @ origin y corner: corner x @ y! ! 296727 296728!Rectangle methodsFor: 'rectangle functions'! 296729withHeight: height 296730 "Return a copy of me with a different height" 296731 ^ origin corner: corner x @ (origin y + height)! ! 296732 296733!Rectangle methodsFor: 'rectangle functions'! 296734withLeft: x 296735 "Return a copy of me with a different left x" 296736 ^ x @ origin y corner: corner x @ corner y! ! 296737 296738!Rectangle methodsFor: 'rectangle functions'! 296739withRight: x 296740 "Return a copy of me with a different right x" 296741 ^ origin x @ origin y corner: x @ corner y! ! 296742 296743!Rectangle methodsFor: 'rectangle functions'! 296744withSide: side setTo: value "return a copy with side set to value" 296745 ^ self perform: (#(withLeft: withRight: withTop: withBottom: ) 296746 at: (#(left right top bottom) indexOf: side)) 296747 with: value! ! 296748 296749!Rectangle methodsFor: 'rectangle functions' stamp: 'di 9/8/1999 21:25'! 296750withSideOrCorner: side setToPoint: newPoint 296751 "Return a copy with side set to newPoint" 296752 296753 ^ self withSideOrCorner: side setToPoint: newPoint minExtent: 0@0! ! 296754 296755!Rectangle methodsFor: 'rectangle functions' stamp: 'bf 9/10/1999 16:16'! 296756withSideOrCorner: side setToPoint: newPoint minExtent: minExtent 296757 "Return a copy with side set to newPoint" 296758 ^self withSideOrCorner: side setToPoint: newPoint minExtent: minExtent 296759 limit: ((#(left top) includes: side) ifTrue: [SmallInteger minVal] ifFalse: [SmallInteger maxVal])! ! 296760 296761!Rectangle methodsFor: 'rectangle functions' stamp: 'bf 9/10/1999 16:07'! 296762withSideOrCorner: side setToPoint: newPoint minExtent: minExtent limit: limit 296763 "Return a copy with side set to newPoint" 296764 side = #top ifTrue: [^ self withTop: (newPoint y min: corner y - minExtent y max: limit + minExtent y)]. 296765 side = #bottom ifTrue: [^ self withBottom: (newPoint y min: limit - minExtent y max: origin y + minExtent y)]. 296766 side = #left ifTrue: [^ self withLeft: (newPoint x min: corner x - minExtent x max: limit + minExtent x)]. 296767 side = #right ifTrue: [^ self withRight: (newPoint x min: limit - minExtent x max: origin x + minExtent x)]. 296768 side = #topLeft ifTrue: [^ (newPoint min: corner - minExtent) corner: self bottomRight]. 296769 side = #bottomRight ifTrue: [^ self topLeft corner: (newPoint max: origin + minExtent)]. 296770 side = #bottomLeft ifTrue: [^ self topRight rect: ((newPoint x min: corner x - minExtent x) @ (newPoint y max: origin y + minExtent y))]. 296771 side = #topRight ifTrue: [^ self bottomLeft rect: ((newPoint x max: origin x + minExtent x) @ (newPoint y min: corner y - minExtent y))].! ! 296772 296773!Rectangle methodsFor: 'rectangle functions'! 296774withTop: y 296775 "Return a copy of me with a different top y" 296776 ^ origin x @ y corner: corner x @ corner y! ! 296777 296778!Rectangle methodsFor: 'rectangle functions'! 296779withWidth: width 296780 "Return a copy of me with a different width" 296781 ^ origin corner: (origin x + width) @ corner y! ! 296782 296783 296784!Rectangle methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:49'! 296785isSelfEvaluating 296786 ^ self class == Rectangle! ! 296787 296788 296789!Rectangle methodsFor: 'testing'! 296790containsPoint: aPoint 296791 "Answer whether aPoint is within the receiver." 296792 296793 ^origin <= aPoint and: [aPoint < corner]! ! 296794 296795!Rectangle methodsFor: 'testing'! 296796containsRect: aRect 296797 "Answer whether aRect is within the receiver (OK to coincide)." 296798 296799 ^ aRect origin >= origin and: [aRect corner <= corner] 296800! ! 296801 296802!Rectangle methodsFor: 'testing'! 296803hasPositiveExtent 296804 ^ (corner x > origin x) and: [corner y > origin y]! ! 296805 296806!Rectangle methodsFor: 'testing' stamp: 'lr 7/4/2009 10:42'! 296807intersects: aRectangle 296808 "Answer whether aRectangle intersects the receiver anywhere." 296809 "Optimized; old code answered: 296810 (origin max: aRectangle origin) < (corner min: aRectangle corner)" 296811 | rOrigin rCorner | 296812 rOrigin := aRectangle origin. 296813 rCorner := aRectangle corner. 296814 rCorner x <= origin x ifTrue: [ ^ false ]. 296815 rCorner y <= origin y ifTrue: [ ^ false ]. 296816 rOrigin x >= corner x ifTrue: [ ^ false ]. 296817 rOrigin y >= corner y ifTrue: [ ^ false ]. 296818 ^ true! ! 296819 296820!Rectangle methodsFor: 'testing' stamp: 'md 10/2/2005 21:51'! 296821isRectangle 296822 ^true! ! 296823 296824!Rectangle methodsFor: 'testing'! 296825isTall 296826 ^ self height > self width! ! 296827 296828!Rectangle methodsFor: 'testing'! 296829isWide 296830 ^ self width > self height! ! 296831 296832!Rectangle methodsFor: 'testing' stamp: 'ar 10/29/2000 19:03'! 296833isZero 296834 ^origin isZero and:[corner isZero]! ! 296835 296836 296837!Rectangle methodsFor: 'transforming'! 296838align: aPoint1 with: aPoint2 296839 "Answer a Rectangle that is a translated by aPoint2 - aPoint1." 296840 296841 ^self translateBy: aPoint2 - aPoint1! ! 296842 296843!Rectangle methodsFor: 'transforming'! 296844centeredBeneath: aRectangle 296845 "Move the reciever so that its top center point coincides with the bottom center point of aRectangle. 5/20/96 sw:" 296846 296847 ^ self align: self topCenter with: aRectangle bottomCenter! ! 296848 296849!Rectangle methodsFor: 'transforming' stamp: 'di 6/11/97 16:24'! 296850flipBy: direction centerAt: aPoint 296851 "Return a copy flipped #vertical or #horizontal, about aPoint." 296852 ^ (origin flipBy: direction centerAt: aPoint) 296853 rect: (corner flipBy: direction centerAt: aPoint)! ! 296854 296855!Rectangle methodsFor: 'transforming' stamp: 'lr 7/4/2009 10:42'! 296856newRectButtonPressedDo: newRectBlock 296857 "Track the outline of a new rectangle until mouse button 296858 changes. newFrameBlock produces each new rectangle from the 296859 previous. Only tracks while mouse is down." 296860 | rect newRect buttonNow delay | 296861 delay := Delay forMilliseconds: 10. 296862 buttonNow := Sensor anyButtonPressed. 296863 rect := self. 296864 Display 296865 border: rect 296866 width: 2 296867 rule: Form reverse 296868 fillColor: Color gray. 296869 [ buttonNow ] whileTrue: 296870 [ delay wait. 296871 [ Sensor nextEvent isNil ] whileFalse. 296872 buttonNow := Sensor anyButtonPressed. 296873 newRect := newRectBlock value: rect. 296874 newRect = rect ifFalse: 296875 [ Display 296876 border: rect 296877 width: 2 296878 rule: Form reverse 296879 fillColor: Color gray. 296880 Display 296881 border: newRect 296882 width: 2 296883 rule: Form reverse 296884 fillColor: Color gray. 296885 rect := newRect ] ]. 296886 Display 296887 border: rect 296888 width: 2 296889 rule: Form reverse 296890 fillColor: Color gray. 296891 World activeHand 296892 newMouseFocus: nil; 296893 showTemporaryCursor: nil. 296894 ^ rect! ! 296895 296896!Rectangle methodsFor: 'transforming' stamp: 'lr 7/4/2009 10:42'! 296897newRectFrom: newRectBlock 296898 "Track the outline of a new rectangle until mouse button changes. 296899 newFrameBlock produces each new rectangle from the previous" 296900 | rect newRect buttonStart buttonNow delay | 296901 delay := Delay forMilliseconds: 10. 296902 buttonStart := buttonNow := Sensor anyButtonPressed. 296903 rect := self. 296904 Display 296905 border: rect 296906 width: 2 296907 rule: Form reverse 296908 fillColor: Color gray. 296909 [ buttonNow == buttonStart ] whileTrue: 296910 [ delay wait. 296911 [ Sensor nextEvent isNil ] whileFalse. 296912 buttonNow := Sensor anyButtonPressed. 296913 newRect := newRectBlock value: rect. 296914 newRect = rect ifFalse: 296915 [ Display 296916 border: rect 296917 width: 2 296918 rule: Form reverse 296919 fillColor: Color gray. 296920 Display 296921 border: newRect 296922 width: 2 296923 rule: Form reverse 296924 fillColor: Color gray. 296925 rect := newRect ] ]. 296926 Display 296927 border: rect 296928 width: 2 296929 rule: Form reverse 296930 fillColor: Color gray. 296931 World activeHand 296932 newMouseFocus: nil; 296933 showTemporaryCursor: nil. 296934 ^ rect! ! 296935 296936!Rectangle methodsFor: 'transforming' stamp: 'di 6/11/97 15:11'! 296937rotateBy: direction centerAt: aPoint 296938 "Return a copy rotated #right, #left, or #pi about aPoint" 296939 ^ (origin rotateBy: direction centerAt: aPoint) 296940 rect: (corner rotateBy: direction centerAt: aPoint)! ! 296941 296942!Rectangle methodsFor: 'transforming'! 296943scaleBy: scale 296944 "Answer a Rectangle scaled by scale, a Point or a scalar." 296945 296946 ^Rectangle origin: origin * scale corner: corner * scale! ! 296947 296948!Rectangle methodsFor: 'transforming'! 296949scaleFrom: rect1 to: rect2 296950 "Produce a rectangle stretched according to the stretch from rect1 to rect2" 296951 ^ (origin scaleFrom: rect1 to: rect2) 296952 corner: (corner scaleFrom: rect1 to: rect2)! ! 296953 296954!Rectangle methodsFor: 'transforming' stamp: 'sw 5/21/96'! 296955squishedWithin: aRectangle 296956 "Return an adjustment of the receiver that fits within aRectangle by reducing its size, not by changing its origin. " 296957 296958 ^ origin corner: (corner min: aRectangle bottomRight) 296959 296960"(50 @ 50 corner: 160 @ 100) squishedWithin: (20 @ 10 corner: 90 @ 85)" 296961! ! 296962 296963!Rectangle methodsFor: 'transforming'! 296964translateBy: factor 296965 "Answer a Rectangle translated by factor, a Point or a scalar." 296966 296967 ^Rectangle origin: origin + factor corner: corner + factor! ! 296968 296969!Rectangle methodsFor: 'transforming' stamp: 'nk 7/5/2003 08:31'! 296970translatedAndSquishedToBeWithin: aRectangle 296971 "Return an adjustment of the receiver that fits within aRectangle by 296972 - translating it to be within aRectangle if necessary, then 296973 - reducing its size, if necessary" 296974 296975 ^ (self translatedToBeWithin: aRectangle) squishedWithin: aRectangle! ! 296976 296977 296978!Rectangle methodsFor: 'truncation and round off'! 296979rounded 296980 "Answer a Rectangle whose origin and corner are rounded." 296981 296982 ^Rectangle origin: origin rounded corner: corner rounded! ! 296983 296984!Rectangle methodsFor: 'truncation and round off'! 296985truncateTo: grid 296986 "Answer a Rectangle whose origin and corner are truncated to grid x and grid y." 296987 296988 ^Rectangle origin: (origin truncateTo: grid) 296989 corner: (corner truncateTo: grid)! ! 296990 296991!Rectangle methodsFor: 'truncation and round off' stamp: 'jm 5/29/1998 15:53'! 296992truncated 296993 "Answer a Rectangle whose origin and corner have any fractional parts removed. Answer the receiver if its coordinates are already integral." 296994 296995 (origin x isInteger and: 296996 [origin y isInteger and: 296997 [corner x isInteger and: 296998 [corner y isInteger]]]) 296999 ifTrue: [^ self]. 297000 297001 ^ Rectangle origin: origin truncated corner: corner truncated 297002! ! 297003 297004 297005!Rectangle methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 297006setOrigin: topLeft corner: bottomRight 297007 origin := topLeft. 297008 corner := bottomRight! ! 297009 297010"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 297011 297012Rectangle class 297013 instanceVariableNames: ''! 297014 297015!Rectangle class methodsFor: 'instance creation' stamp: 'tk 3/9/97'! 297016center: centerPoint extent: extentPoint 297017 "Answer an instance of me whose center is centerPoint and width 297018 by height is extentPoint. " 297019 297020 ^self origin: centerPoint - (extentPoint//2) extent: extentPoint! ! 297021 297022!Rectangle class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 297023encompassing: listOfPoints 297024 "A number of callers of encompass: should use this method." 297025 | topLeft bottomRight | 297026 topLeft := bottomRight := nil. 297027 listOfPoints do: 297028 [ :p | 297029 topLeft == nil 297030 ifTrue: [ topLeft := bottomRight := p ] 297031 ifFalse: 297032 [ topLeft := topLeft min: p. 297033 bottomRight := bottomRight max: p ] ]. 297034 ^ topLeft corner: bottomRight! ! 297035 297036!Rectangle class methodsFor: 'instance creation'! 297037fromUser 297038 "Answer an instance of me that is determined by having the user 297039 designate the top left and bottom right corners. The gridding for user 297040 selection is 1@1." 297041 297042 ^self fromUser: 1 @ 1! ! 297043 297044!Rectangle class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 297045fromUser: gridPoint 297046 "Answer a Rectangle that is determined by having the user 297047 designate the top left and bottom right corners. 297048 The cursor reamins linked with the sensor, but 297049 the outline is kept gridded." 297050 | originRect | 297051 originRect := Cursor origin showWhile: 297052 [ ((Sensor cursorPoint grid: gridPoint) extent: 0 @ 0) newRectFrom: [ :f | (Sensor cursorPoint grid: gridPoint) extent: 0 @ 0 ] ]. 297053 ^ Cursor corner showWhile: 297054 [ originRect newRectFrom: [ :f | f origin corner: (Sensor cursorPoint grid: gridPoint) ] ]! ! 297055 297056!Rectangle class methodsFor: 'instance creation' stamp: 'md 12/3/2004 00:02'! 297057left: leftNumber right: rightNumber top: topNumber bottom: bottomNumber 297058 "Answer an instance of me whose left, right, top, and bottom coordinates 297059 are determined by the arguments." 297060 297061 ^ self basicNew setOrigin: leftNumber @ topNumber corner: rightNumber @ bottomNumber! ! 297062 297063!Rectangle class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 297064merging: listOfRects 297065 "A number of callers of merge: should use this method." 297066 | minX minY maxX maxY | 297067 listOfRects do: 297068 [ :r | 297069 minX 297070 ifNil: 297071 [ minX := r topLeft x. 297072 minY := r topLeft y. 297073 maxX := r bottomRight x. 297074 maxY := r bottomRight y ] 297075 ifNotNil: 297076 [ minX := minX min: r topLeft x. 297077 minY := minY min: r topLeft y. 297078 maxX := maxX max: r bottomRight x. 297079 maxY := maxY max: r bottomRight y ] ]. 297080 ^ minX @ minY corner: maxX @ maxY! ! 297081 297082!Rectangle class methodsFor: 'instance creation' stamp: 'md 12/3/2004 00:04'! 297083origin: originPoint corner: cornerPoint 297084 "Answer an instance of me whose corners (top left and bottom right) are 297085 determined by the arguments." 297086 297087 ^self basicNew setOrigin: originPoint corner: cornerPoint! ! 297088 297089!Rectangle class methodsFor: 'instance creation' stamp: 'md 12/3/2004 00:03'! 297090origin: originPoint extent: extentPoint 297091 "Answer an instance of me whose top left corner is originPoint and width 297092 by height is extentPoint." 297093 297094 ^self basicNew setOrigin: originPoint corner: originPoint + extentPoint! ! 297095 297096!Rectangle class methodsFor: 'instance creation'! 297097originFromUser: extentPoint 297098 "Answer an instance of me that is determined by having the user 297099 designate the top left corner. The width and height are determined by 297100 extentPoint. The gridding for user selection is 1@1." 297101 297102 ^self originFromUser: extentPoint grid: 1 @ 1! ! 297103 297104!Rectangle class methodsFor: 'instance creation'! 297105originFromUser: extentPoint grid: gridPoint 297106 "Answer an instance of me that is determined by having the user 297107 designate the top left corner. The width and height are determined by 297108 extentPoint. The gridding for user selection is scaleFactor. Assumes that 297109 the sender has determined an extent that is a proper multiple of 297110 scaleFactor." 297111 297112 ^ Cursor origin showWhile: 297113 [((Sensor cursorPoint grid: gridPoint) extent: extentPoint) newRectFrom: 297114 [:f | (Sensor cursorPoint grid: gridPoint) extent: extentPoint]]. 297115! ! 297116BorderedMorph subclass: #RectangleMorph 297117 instanceVariableNames: '' 297118 classVariableNames: '' 297119 poolDictionaries: '' 297120 category: 'Morphic-Basic'! 297121!RectangleMorph commentStamp: 'kfr 10/27/2003 11:12' prior: 0! 297122A subclass of BorderedMorph that supports different fillStyles. 297123 297124RectangleMorph diagonalPrototype openInWorld. 297125RectangleMorph gradientPrototype openInWorld.! 297126 297127 297128!RectangleMorph methodsFor: 'accessing' stamp: 'ar 6/23/2001 16:06'! 297129wantsToBeCachedByHand 297130 "Return true if the receiver wants to be cached by the hand when it is dragged around." 297131 self hasTranslucentColor ifTrue:[^false]. 297132 self bounds = self fullBounds ifTrue:[^true]. 297133 self submorphsDo:[:m| 297134 (self bounds containsRect: m fullBounds) ifFalse:[ 297135 m wantsToBeCachedByHand ifFalse:[^false]. 297136 ]. 297137 ]. 297138 ^true! ! 297139 297140 297141!RectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'! 297142defaultColor 297143 "answer the default color/fill style for the receiver" 297144 ^ Color 297145 r: 0.613 297146 g: 0.903 297147 b: 1.0! ! 297148 297149 297150!RectangleMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:13'! 297151canHaveFillStyles 297152 "Return true if the receiver can have general fill styles; not just colors. 297153 This method is for gradually converting old morphs." 297154 ^self class == RectangleMorph "no subclasses"! ! 297155 297156"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 297157 297158RectangleMorph class 297159 instanceVariableNames: ''! 297160 297161!RectangleMorph class methodsFor: 'as yet unclassified' stamp: 'nk 9/7/2004 11:44'! 297162roundRectPrototype 297163 ^ self authoringPrototype useRoundedCorners 297164 color: ((Color r: 1.0 g: 0.3 b: 0.6) alpha: 0.5); 297165 borderWidth: 1; 297166 setNameTo: 'RoundRect'! ! 297167 297168 297169!RectangleMorph class methodsFor: 'parts bin' stamp: 'tk 11/14/2001 20:09'! 297170diagonalPrototype 297171 297172 | rr | 297173 rr := self authoringPrototype. 297174 rr useGradientFill; borderWidth: 0. 297175 rr fillStyle direction: rr extent. 297176 ^ rr! ! 297177 297178!RectangleMorph class methodsFor: 'parts bin' stamp: 'tk 11/14/2001 20:09'! 297179gradientPrototype 297180 297181 | rr | 297182 rr := self authoringPrototype. 297183 rr useGradientFill; borderWidth: 0. 297184 ^ rr! ! 297185TestCase subclass: #RectangleTest 297186 instanceVariableNames: 'emptyRectangle rectangle1' 297187 classVariableNames: '' 297188 poolDictionaries: '' 297189 category: 'GraphicsTests-Primitives'! 297190 297191!RectangleTest methodsFor: 'setup-teardown' stamp: 'zz 10/16/2007 20:39'! 297192setUp 297193 emptyRectangle := 0 @ 0 corner: 0 @ 0. 297194 rectangle1 := 10@10 corner:20@20! ! 297195 297196 297197!RectangleTest methodsFor: 'tests' stamp: 'zz 10/23/2007 20:10'! 297198testARectangleContainsItsOrigin 297199 self 297200 assert: (rectangle1 containsPoint: rectangle1 origin)! ! 297201 297202!RectangleTest methodsFor: 'tests' stamp: 'zz 10/23/2007 20:11'! 297203testARectangleDoesNotContainItsCorner 297204 self 297205 deny: (rectangle1 containsPoint: rectangle1 corner)! ! 297206 297207!RectangleTest methodsFor: 'tests' stamp: 'zz 10/23/2007 20:12'! 297208testARectangleIntersectsWithItself 297209 self 297210 assert: (rectangle1 intersects: rectangle1)! ! 297211 297212!RectangleTest methodsFor: 'tests' stamp: 'zz 10/22/2007 09:14'! 297213testAnEmptyRectangleHasNoArea 297214 self assert: emptyRectangle area == 0! ! 297215 297216!RectangleTest methodsFor: 'tests' stamp: 'test 10/22/2007 21:37'! 297217testAreasOutside1 297218 297219 | frame rects visibleArea | 297220 frame := 0@0 extent: 300@300. 297221 rects := OrderedCollection new: 80. 297222 0 to: 3 do: [:i | 297223 0 to: 2 do: [:j | 297224 rects add: (i@j * 20 extent: 10@10) 297225 ] ]. 297226 297227 visibleArea := Array with: frame. 297228 rects do: [:aRectangle | | remnants | 297229 remnants := OrderedCollection new. 297230 visibleArea do: [:a | remnants addAll: (a areasOutside: aRectangle)]. 297231 visibleArea := remnants. 297232 ]. 297233 visibleArea := visibleArea asArray. 297234 self assert: (visibleArea allSatisfy: [:r | r area ~= 0]). 297235 1 to: visibleArea size do: [:index | 297236 index + 1 to: visibleArea size do: [:index2 | 297237 self deny: ((visibleArea at: index) intersects: (visibleArea at: index2)). 297238 ] ]. 297239 297240 1 to: rects size do: [:index | 297241 1 to: visibleArea size do: [:index2 | 297242 self deny: ((rects at: index) intersects: (visibleArea at: index2)). 297243 ] ]! ! 297244 297245!RectangleTest methodsFor: 'tests' stamp: 'zz 10/22/2007 09:07'! 297246testAreasOutside2 297247 | frame rects visibleArea | 297248 frame := 0@0 extent: 300@300. 297249 rects := OrderedCollection new: 80. 297250 rects add: (50@50 corner: 200 @ 200); 297251 add: (100@100 corner: 250@250). 297252 297253 visibleArea := Array with: frame. 297254 rects do: [:rect | | remnants | 297255 remnants := OrderedCollection new. 297256 visibleArea do: [:a | remnants addAll: (a areasOutside: rect)]. 297257 visibleArea := remnants. 297258 ]. 297259 visibleArea := visibleArea asArray. 297260 self assert: (visibleArea allSatisfy: [:r | r area ~= 0]). 297261 297262 1 to: visibleArea size do: [:idx | 297263 idx + 1 to: visibleArea size do: [:idx2 | 297264 self deny: ((visibleArea at: idx) intersects: (visibleArea at: idx2)). 297265 ] ]. 297266 297267 1 to: rects size do: [:idx | 297268 1 to: visibleArea size do: [:idx2 | 297269 self deny: ((rects at: idx) intersects: (visibleArea at: idx2)). 297270 ] ]. 297271 297272! ! 297273 297274!RectangleTest methodsFor: 'tests' stamp: 'zz 10/22/2007 09:15'! 297275testMergingDisjointRectangles 297276 297277 | aCollection merge | 297278 aCollection := OrderedCollection new. 297279 aCollection add: (Rectangle left: -10 right: 0 top: -10 bottom: 0). 297280 aCollection add: (Rectangle left: 0 right: 10 top: 0 bottom: 10). 297281 merge := Rectangle merging: aCollection. 297282 self assert: merge = (Rectangle left: -10 right: 10 top: -10 bottom: 10).! ! 297283 297284!RectangleTest methodsFor: 'tests' stamp: 'zz 10/16/2007 20:14'! 297285testMergingNestedRectanglesReturnTheContainer 297286 297287 | aCollection merge | 297288 aCollection := OrderedCollection new. 297289 aCollection add: (Rectangle left: 1 right: 10 top: 1 bottom: 10). 297290 aCollection add: (Rectangle left: 4 right: 5 top: 4 bottom: 5). 297291 merge := Rectangle merging: aCollection. 297292 self assert: merge = aCollection first.! ! 297293 297294!RectangleTest methodsFor: 'tests' stamp: 'zz 10/16/2007 20:00'! 297295testMergingOneRectangleReturnsThisRectangle 297296 | aCollection mergingRectangle | 297297 aCollection := OrderedCollection new. 297298 aCollection add: rectangle1. 297299 mergingRectangle := Rectangle merging: aCollection. 297300 self assert: mergingRectangle = aCollection first! ! 297301 297302!RectangleTest methodsFor: 'tests' stamp: 'zz 10/22/2007 09:12'! 297303testMergingOverlappingRectangles 297304 | aCollection merge | 297305 aCollection := OrderedCollection new. 297306 aCollection 297307 add: (Rectangle 297308 left: 5 297309 right: 10 297310 top: 0 297311 bottom: 15); 297312 297313 add: (Rectangle 297314 left: 0 297315 right: 15 297316 top: 5 297317 bottom: 10). 297318 merge := Rectangle merging: aCollection. 297319 self assert: merge 297320 = (Rectangle 297321 left: 0 297322 right: 15 297323 top: 0 297324 bottom: 15)! ! 297325 297326!RectangleTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:17'! 297327testMergingOverlappingRects 297328 297329 | coll merge | 297330 coll := OrderedCollection new. 297331 coll add: (Rectangle left: 5 right: 10 top: 0 bottom: 15). 297332 coll add: (Rectangle left: 0 right: 15 top: 5 bottom: 10). 297333 merge := Rectangle merging: coll. 297334 self assert: merge = (Rectangle left: 0 right: 15 top: 0 bottom: 15).! ! 297335 297336!RectangleTest methodsFor: 'tests' stamp: 'zz 10/22/2007 09:09'! 297337testMergingTwoRectangles 297338 297339 | coll merge | 297340 coll := OrderedCollection new. 297341 coll add: (Rectangle left: 1 right: 1 top: 1 bottom: 1). 297342 coll add: (Rectangle left: 10 right: 10 top: 10 bottom: 10). 297343 297344 merge := Rectangle merging: coll. 297345 self assert: merge = (Rectangle left: 1 right: 10 top: 1 bottom: 10).! ! 297346 297347!RectangleTest methodsFor: 'tests' stamp: 'zz 10/23/2007 20:13'! 297348testRectanglesWithSameOriginIntersect 297349 297350 | rect1 rect2 | 297351 rect1 := 10@10 corner: 20@30. 297352 rect2 := rect1 corner extent: 20@40. 297353 self deny: (rect1 intersects: rect2).! ! 297354 297355!RectangleTest methodsFor: 'tests' stamp: 'zz 10/23/2007 20:14'! 297356testTwoRectanglesWithAnAdjascentBorderDoNotIntersect 297357 297358 | rect1 rect2 | 297359 rect1 := 0@0 corner: 40@40. 297360 rect2 := 40@0 extent:40@40. 297361 self deny: (rect1 intersects: rect2); 297362 deny: (rect2 intersects: rect1).! ! 297363 297364!RectangleTest methodsFor: 'tests' stamp: 'zz 10/23/2007 20:15'! 297365testTwoRectanglesWithAnAdjascentCornerDoNotIntersect 297366 297367 | rect1 rect2 | 297368 rect1 := 0@0 corner: 40@40. 297369 rect2 := 40@40 corner: 50@50. 297370 self deny: (rect1 intersects: rect2); 297371 deny: (rect2 intersects: rect1).! ! 297372BorderedMorph subclass: #ReferenceMorph 297373 instanceVariableNames: 'referent isHighlighted' 297374 classVariableNames: '' 297375 poolDictionaries: '' 297376 category: 'Morphic-Worlds'! 297377!ReferenceMorph commentStamp: '<historical>' prior: 0! 297378Serves as a reference to any arbitrary morph; used, for example, as the tab in a tabbed palette The wrapper intercepts mouse events and fields them, passing them on to their referent morph.! 297379 297380 297381!ReferenceMorph methodsFor: 'accessing' stamp: 'sw 10/30/2000 11:11'! 297382borderWidth: aWidth 297383 "Set the receiver's border width as indicated, and trigger a fresh layout" 297384 297385 super borderWidth: aWidth. 297386 self layoutChanged! ! 297387 297388!ReferenceMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 13:20'! 297389highlight 297390 | str | 297391 isHighlighted := true. 297392 submorphs notEmpty 297393 ifTrue: 297394 [((str := submorphs first) isKindOf: StringMorph) 297395 ifTrue: [str color: self highlightColor] 297396 ifFalse: 297397 [self 297398 borderWidth: 1; 297399 borderColor: self highlightColor]]! ! 297400 297401!ReferenceMorph methodsFor: 'accessing' stamp: 'nk 6/12/2004 10:03'! 297402isCurrentlyGraphical 297403 "Answer whether the receiver is currently showing a graphical face" 297404 297405 | first | 297406 ^submorphs notEmpty and: 297407 [((first := submorphs first) isKindOf: ImageMorph) 297408 or: [first isSketchMorph]]! ! 297409 297410!ReferenceMorph methodsFor: 'accessing' stamp: 'sw 11/30/1998 12:47'! 297411morphToInstall 297412 ^ referent! ! 297413 297414!ReferenceMorph methodsFor: 'accessing' stamp: 'sw 12/3/1998 10:06'! 297415referent 297416 ^ referent! ! 297417 297418!ReferenceMorph methodsFor: 'accessing' stamp: 'de 11/30/1998 09:58'! 297419referent: m 297420 referent := m! ! 297421 297422!ReferenceMorph methodsFor: 'accessing' stamp: 'stephane.ducasse 11/28/2008 09:26'! 297423unHighlight 297424 | str | 297425 isHighlighted := false. 297426 self borderWidth: 0. 297427 submorphs notEmpty 297428 ifTrue: 297429 [ str := submorphs first. 297430 (str isKindOf: StringMorph) or: 297431 [ (str isKindOf: RectangleMorph) 297432 ifTrue: [str color: self regularColor]]]! ! 297433 297434 297435!ReferenceMorph methodsFor: 'button' stamp: 'sw 12/21/1998 14:13'! 297436doButtonAction 297437 self tabSelected! ! 297438 297439 297440!ReferenceMorph methodsFor: 'event handling' stamp: 'sw 11/30/1998 12:46'! 297441handlesMouseDown: evt 297442 ^ true 297443! ! 297444 297445!ReferenceMorph methodsFor: 'event handling' stamp: 'sw 3/7/1999 00:29'! 297446mouseDown: evt 297447 self setProperty: #oldColor toValue: color! ! 297448 297449!ReferenceMorph methodsFor: 'event handling' stamp: 'sw 10/24/2000 14:45'! 297450mouseMove: evt 297451 "The mouse moved while the butten was down in the receiver" 297452 297453 | aForm | 297454 aForm := self imageForm. 297455 (self containsPoint: evt cursorPoint) 297456 ifTrue: 297457 [aForm reverse displayOn: Display] 297458 ifFalse: 297459 [aForm displayOn: Display]! ! 297460 297461!ReferenceMorph methodsFor: 'event handling' stamp: 'sw 10/26/2000 14:41'! 297462mouseUp: evt 297463 "The mouse came up in the receiver; If the mouse is still within the receiver at this point, do the corresponding action" 297464 297465 | aColor | 297466 (aColor := self valueOfProperty: #oldColor) ifNotNil: [self color: aColor]. 297467 (self containsPoint: evt cursorPoint) 297468 ifTrue: [self doButtonAction]. 297469 super mouseUp: evt "send to evt handler if any" 297470! ! 297471 297472 297473!ReferenceMorph methodsFor: 'events' stamp: 'alain.plantec 6/6/2009 14:27'! 297474tabSelected 297475 "Called when the receiver is hit"! ! 297476 297477 297478!ReferenceMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:49'! 297479defaultBorderWidth 297480"answer the default border width for the receiver" 297481 ^ 0! ! 297482 297483!ReferenceMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:48'! 297484defaultColor 297485"answer the default color/fill style for the receiver" 297486 ^ Color transparent! ! 297487 297488!ReferenceMorph methodsFor: 'initialization' stamp: 'stephane.ducasse 2/14/2009 17:42'! 297489initialize 297490 "initialize the state of the receiver" 297491 297492 super initialize. 297493 isHighlighted := false. 297494 referent := nil! ! 297495 297496 297497!ReferenceMorph methodsFor: 'layout' stamp: 'sw 12/1/1998 13:20'! 297498layoutChanged 297499 self fitContents. 297500 super layoutChanged! ! 297501 297502 297503!ReferenceMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:59'! 297504addCustomMenuItems: aCustomMenu hand: aHandMorph 297505 "Add morph-specific items to the menu for the hand" 297506 297507 | sketch | 297508 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 297509 aCustomMenu addLine. 297510 self isCurrentlyTextual 297511 ifTrue: 297512 [aCustomMenu add: 'change label wording...' translated action: #changeTabText. 297513 aCustomMenu add: 'use graphical label' translated action: #useGraphicalTab] 297514 ifFalse: 297515 [aCustomMenu add: 'use textual label' translated action: #useTextualTab. 297516 aCustomMenu add: 'choose graphic...' translated action: #changeTabGraphic. 297517 (sketch := self findA: SketchMorph) ifNotNil: 297518 [aCustomMenu add: 'repaint' translated target: sketch action: #editDrawing]]! ! 297519 297520!ReferenceMorph methodsFor: 'menu' stamp: 'sw 12/16/1998 14:02'! 297521changeTabGraphic 297522 submorphs first chooseNewGraphicCoexisting: true! ! 297523 297524!ReferenceMorph methodsFor: 'menu' stamp: 'alain.plantec 2/6/2009 15:48'! 297525changeTabText 297526 | reply | 297527 reply := UIManager default 297528 request: 'new wording for this tab:' translated 297529 initialAnswer: submorphs first contents. 297530 reply isEmptyOrNil ifFalse: [submorphs first contents: reply]! ! 297531 297532!ReferenceMorph methodsFor: 'menu' stamp: 'sw 6/21/1999 11:43'! 297533existingWording 297534 ^ submorphs first contents asString! ! 297535 297536!ReferenceMorph methodsFor: 'menu' stamp: 'di 2/17/2000 20:32'! 297537graphicalMorphForTab 297538 | formToUse | 297539 formToUse := self valueOfProperty: #priorGraphic ifAbsent: [ScriptingSystem formAtKey: 'squeakyMouse']. 297540 ^ SketchMorph withForm: formToUse! ! 297541 297542!ReferenceMorph methodsFor: 'menu' stamp: 'gm 2/22/2003 12:51'! 297543isCurrentlyTextual 297544 | first | 297545 ^((first := submorphs first) isKindOf: StringMorph) 297546 or: [first isTextMorph]! ! 297547 297548!ReferenceMorph methodsFor: 'menu' stamp: 'sw 3/23/2000 10:47'! 297549preserveDetails 297550 "The receiver is being switched to use a different format. Preserve the existing details (e.g. wording if textual, grapheme if graphical) so that if the user reverts back to the current format, the details will be right" 297551 297552 self isCurrentlyTextual 297553 ifTrue: 297554 [self setProperty: #priorWording toValue: self existingWording. 297555 self setProperty: #priorColor toValue: color. 297556 self setProperty: #priorBorderWidth toValue: borderWidth] 297557 ifFalse: 297558 [self setProperty: #priorGraphic toValue: submorphs first form]! ! 297559 297560!ReferenceMorph methodsFor: 'menu' stamp: 'alain.plantec 6/6/2009 14:26'! 297561setLabelFontTo: aFont 297562 "Change the receiver's label font to be as indicated" 297563 297564 | aLabel oldLabel | 297565 aLabel := StringMorph contents: (oldLabel := self findA: StringMorph) contents font: aFont. 297566 self replaceSubmorph: oldLabel by: aLabel. 297567 aLabel position: self position. 297568 aLabel highlightColor: self highlightColor; regularColor: self regularColor. 297569 aLabel lock. 297570 self fitContents. 297571 self layoutChanged. 297572! ! 297573 297574!ReferenceMorph methodsFor: 'menu' stamp: 'alain.plantec 6/6/2009 14:27'! 297575useGraphicalTab 297576 | aGraphic | 297577 self preserveDetails. 297578 self color: Color transparent. 297579 aGraphic := self graphicalMorphForTab. 297580 self borderWidth: 0. 297581 self removeAllMorphs. 297582 self addMorphBack: aGraphic. 297583 aGraphic position: self position. 297584 aGraphic lock. 297585 self fitContents. 297586 self layoutChanged. 297587! ! 297588 297589!ReferenceMorph methodsFor: 'menu' stamp: 'alain.plantec 6/6/2009 14:27'! 297590useTextualTab 297591 "Use a textually-emblazoned tab" 297592 297593 | aLabel stringToUse font aColor | 297594 self preserveDetails. 297595 stringToUse := self valueOfProperty: #priorWording ifAbsent: [self externalName]. 297596 font := self valueOfProperty: #priorFont ifAbsent: [Preferences standardButtonFont]. 297597 aColor := self valueOfProperty: #priorColor ifAbsent: [Color green darker]. 297598 aLabel := StringMorph contents: stringToUse font: font. 297599 self replaceSubmorph: submorphs first by: aLabel. 297600 aLabel position: self position. 297601 self color: aColor. 297602 aLabel highlightColor: self highlightColor; regularColor: self regularColor. 297603 aLabel lock. 297604 self fitContents. 297605 self layoutChanged. 297606! ! 297607 297608 297609!ReferenceMorph methodsFor: 'misc' stamp: 'sw 2/11/1999 14:11'! 297610fitContents 297611 submorphs size == 1 ifTrue: 297612 [self extent: submorphs first extent + (2 * self borderWidth). 297613 submorphs first position: self position + self borderWidth]! ! 297614 297615!ReferenceMorph methodsFor: 'misc' stamp: 'stephane.ducasse 2/14/2009 17:42'! 297616isHighlighted 297617 ^ isHighlighted! ! 297618 297619!ReferenceMorph methodsFor: 'misc' stamp: 'sw 12/21/1998 15:50'! 297620morphToInstall: aMorph 297621 "Create a new tab consisting of a string holding the morph's name" 297622 | aLabel nameToUse | 297623 aLabel := StringMorph new contents: (nameToUse := aMorph externalName). 297624 self addMorph: aLabel. 297625 aLabel lock. 297626 self referent: aMorph. 297627 self setNameTo: nameToUse. 297628 self fitContents.! ! 297629 297630!ReferenceMorph methodsFor: 'misc' stamp: 'sw 1/11/2000 10:18'! 297631morphToInstall: aMorph font: aFont 297632 "Create a new tab consisting of a string holding the morph's name" 297633 | aLabel nameToUse | 297634 aLabel := StringMorph contents: (nameToUse := aMorph externalName) font: aFont. 297635 self addMorph: aLabel. 297636 aLabel lock. 297637 self referent: aMorph. 297638 self setNameTo: nameToUse. 297639 self fitContents.! ! 297640 297641 297642!ReferenceMorph methodsFor: 'naming' stamp: 'dgd 2/22/2003 13:21'! 297643setNameTo: aString 297644 super setNameTo: aString. 297645 (submorphs notEmpty and: [submorphs first isKindOf: StringMorph]) 297646 ifTrue: [submorphs first contents: aString]! ! 297647 297648 297649!ReferenceMorph methodsFor: 'submorphs-accessing' stamp: 'tk 3/8/2000 17:39'! 297650allNonSubmorphMorphs 297651 "we hold extra morphs" 297652 297653 ^ Array with: referent! ! 297654 297655"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 297656 297657ReferenceMorph class 297658 instanceVariableNames: ''! 297659 297660!ReferenceMorph class methodsFor: 'instance creation' stamp: 'sw 11/30/1998 14:12'! 297661forMorph: aMorph 297662 "Create a new tab consisting of a string holding the morph's name" 297663 ^ self new morphToInstall: aMorph! ! 297664 297665!ReferenceMorph class methodsFor: 'instance creation' stamp: 'sw 1/11/2000 10:19'! 297666forMorph: aMorph font: aFont 297667 "Create a new tab consisting of a string holding the morph's name" 297668 ^ self new morphToInstall: aMorph font: aFont! ! 297669 297670 297671!ReferenceMorph class methodsFor: 'printing' stamp: 'sw 11/30/1998 12:44'! 297672defaultNameStemForInstances 297673 ^ 'ref'! ! 297674DataStream subclass: #ReferenceStream 297675 instanceVariableNames: 'references objects currentReference fwdRefEnds blockers skipping insideASegment' 297676 classVariableNames: 'RefTypes' 297677 poolDictionaries: '' 297678 category: 'System-Object Storage'! 297679!ReferenceStream commentStamp: '<historical>' prior: 0! 297680This is a way of serializing a tree of objects into disk file. A ReferenceStream can store 297681one or more objects in a persistent form, including sharing and cycles. 297682 297683Here is the way to use DataStream and ReferenceStream: 297684 rr _ ReferenceStream fileNamed: 'test.obj'. 297685 rr nextPut: <your object>. 297686 rr close. 297687 297688To get it back: 297689 rr _ ReferenceStream fileNamed: 'test.obj'. 297690 <your object> _ rr next. 297691 rr close. 297692 297693ReferenceStreams can now write "weak" references. nextPutWeak: 297694writes a "weak" reference to an object, which refers to that object 297695*if* it also gets written to the stream by a normal nextPut:. 297696 297697A ReferenceStream should be treated as a read-stream *or* as a write-stream, *not* as a read/write-stream. The reference-remembering mechanism would probably do bad things if you tried to read and write from the same ReferenceStream. 297698 297699[TBD] Should we override "close" to do (self forgetReferences)? 297700 297701Instance variables 297702 references -- an IdentityDictionary mapping objects already written 297703 to their byteStream positions. If asked to write any object a 297704 second time, we just write a reference to its stream position. 297705 This handles shared objects and reference cycles between objects. 297706 To implement "weak references" (for Aliases), the references 297707 dictionary also maps objects not (yet?) written to a Collection 297708 of byteStream positions with hopeful weak-references to it. If 297709 asked to definitely write one of these objects, we'll fixup those 297710 weak references. 297711 objects -- an IdentityDictionary mapping relative byte stream positions to 297712 objects already read in. If asked to follow a reference, we 297713 return the object already read. 297714 This handles shared objects and reference cycles between objects. 297715 currentReference -- the current reference position. Positon relative to the 297716 start of object data in this file. (Allows user to cut and paste smalltalk 297717 code from the front of the file without effecting the reference values.) 297718 This variable is used to help install each new object in "objects" as soon 297719 as it's created, **before** we start reading its contents, in 297720 case any of its content objects reference it. 297721 fwdRefEnds -- A weak reference can be a forward reference, which 297722 requires advance-reading the referrent. When we later come to the 297723 object, we must get its value from "objects" and not re-read it so 297724 refs to it don't become refs to copies. fwdRefEnds remembers the 297725 ending byte stream position of advance-read objects. 297726 skipping -- true if <what?> 297727 insideASegment -- true if we are being used to collect objects that will be 297728 included in an ImageSegment. If so, UniClasses must be noted and traced. 297729 297730If the object is referenced before it is done being created, it might get created twice. Just store the object the moment it is created in the 'objects' dictionary. If at the end, comeFullyUpOnReload returns a different object, some refs will have the temporary object (this is an unlikely case). At the moment, no implementor of comeFullyUpOnReload returns a different object except DiskProxy, and that is OK. 297731! 297732 297733 297734!ReferenceStream methodsFor: 'reading' stamp: 'RAA 1/18/2001 11:52'! 297735beginReference: anObject 297736 "Remember anObject as the object we read at the position recorded by 297737 noteCurrentReference:. This must be done after instantiating anObject but 297738 before reading any of its contents that might (directly or indirectly) refer to 297739 it. (It's ok to do this redundantly, which is convenient for #next.) 297740 Answer the reference position." 297741 297742 objects at: currentReference ifAbsent: [ 297743 objects at: currentReference put: anObject. 297744 ^ currentReference]. 297745 (skipping includes: currentReference) ifFalse: [ 297746 "If reading just to skip it, don't record this copy." 297747 objects at: currentReference put: anObject 297748 ]. 297749 ^ currentReference "position relative to start of data portion of file"! ! 297750 297751!ReferenceStream methodsFor: 'reading' stamp: '6/9/97 08:26 tk'! 297752getCurrentReference 297753 "PRIVATE -- Return the currentReference posn. Always a relative position. So user can cut and paste the Smalltalk source code at the beginning of the file." 297754 297755 ^ currentReference "relative position"! ! 297756 297757!ReferenceStream methodsFor: 'reading' stamp: 'tk 4/8/1999 13:11'! 297758maybeBeginReference: internalObject 297759 "See if need to record a reference. In case in the file twice" 297760 297761 (self isAReferenceType: (self typeIDFor: internalObject)) 297762 ifTrue: [self beginReference: internalObject]. 297763 "save the final object and give it out next time." 297764 ^ internalObject! ! 297765 297766!ReferenceStream methodsFor: 'reading' stamp: 'RAA 1/18/2001 16:46'! 297767next 297768 "Answer the next object in the stream. If this object was already read, don't re-read it. File is positioned just before the object." 297769 | curPosn skipToPosn haveIt theObject wasSkipping | 297770 297771 haveIt := true. 297772 curPosn := byteStream position - basePos. 297773 theObject := objects at: curPosn ifAbsent: [haveIt := false]. 297774 "probe in objects is done twice when coming from objectAt:. This is OK." 297775 skipToPosn := fwdRefEnds at: curPosn ifAbsent: [nil]. 297776 haveIt ifFalse: [ ^ super next]. 297777 297778 skipToPosn ifNotNil: [ 297779 "Skip over the object and return the already-read-in value." 297780 byteStream position: skipToPosn + basePos "make absolute" 297781 ] ifNil: [ 297782 "File is not positioned correctly. Read object and throw it away." 297783 wasSkipping := skipping includes: curPosn. 297784 skipping add: curPosn. 297785 "fake :=" super next. 297786 wasSkipping ifFalse: [skipping remove: curPosn ifAbsent: []]. 297787 ]. 297788 ^ theObject 297789 ! ! 297790 297791!ReferenceStream methodsFor: 'reading' stamp: '6/9/97 09:00 tk'! 297792noteCurrentReference: typeID 297793 "PRIVATE -- If we support references for type typeID, remember 297794 the current byteStream position so beginReference: can add the 297795 next object to the 'objects' dictionary of reference positions, 297796 then return true. Else return false." 297797 | answer | 297798 297799 (answer := self isAReferenceType: typeID) 297800 ifTrue: [self setCurrentReference: (byteStream position - 1) - basePos "relative" 297801 "subtract 1 because we already read the object's type ID byte"]. 297802 ^ answer! ! 297803 297804!ReferenceStream methodsFor: 'reading' stamp: ' 6/9/97'! 297805objectAt: anInteger 297806 "PRIVATE -- Read & return the object at a given stream position. 297807 If we already read it, just get it from the objects dictionary. 297808 (Reading it again wouldn't work with cycles or sharing.) 297809 If not, go read it and put it in the objects dictionary. 297810 NOTE: This resolves a cross-reference in the ReferenceStream: 297811 1. A backward reference to an object already read (the normal case). 297812 2. A forward reference which is a sated weak reference (we record where 297813 the object ends so when we get to it normally we can fetch it from 297814 'objects' and skip over it). 297815 3. A backward reference to a 'non-reference type' per the long NOTE in 297816 nextPut: (we compensate here--seek back to re-read it and add the object 297817 to 'objects' to avoid seeking back to read it any more times). 297818 4. While reading a foward weak reference (case 2), we may recursively hit an 297819 ordinary backward reference to an object that we haven't yet read because 297820 we temporarily skipped ahead. Such a reference is forward in time so we 297821 treat it much like case 2. 297822 11/16-24/92 jhm: Handle forward refs. Cf. class comment and above NOTE. 297823 08:57 tk anInteger is a relative position" 297824 | savedPosn refPosn anObject | 297825 297826 ^ objects at: anInteger "relative position. case 1: It's in 'objects'" 297827 ifAbsent: "do like super objectAt:, but remember the fwd-ref-end position" 297828 [savedPosn := byteStream position. "absolute" 297829 refPosn := self getCurrentReference. "relative position" 297830 297831 byteStream position: anInteger + basePos. "was relative" 297832 anObject := self next. 297833 297834 (self isAReferenceType: (self typeIDFor: anObject)) 297835 ifTrue: [fwdRefEnds at: anInteger put: byteStream position - basePos] "cases 2, 4" 297836 ifFalse: [objects at: anInteger put: anObject]. "case 3" 297837 297838 self setCurrentReference: refPosn. "relative position" 297839 byteStream position: savedPosn. "absolute" 297840 anObject]! ! 297841 297842 297843!ReferenceStream methodsFor: 'statistics' stamp: 'ls 10/10/1999 13:27'! 297844statisticsOfRefs 297845 "Analyze the information in references, the objects being written out" 297846 297847 | parents n kids nm ownerBags tallies owners objParent | 297848 parents := IdentityDictionary new: references size * 2. 297849 n := 0. 297850 'Finding Owners...' 297851 displayProgressAt: Sensor cursorPoint 297852 from: 0 to: references size 297853 during: [:bar | 297854 references keysDo: 297855 [:parent | bar value: (n := n+1). 297856 kids := parent class isFixed 297857 ifTrue: [(1 to: parent class instSize) collect: [:i | parent 297858instVarAt: i]] 297859 ifFalse: [parent class isBits ifTrue: [Array new] 297860 ifFalse: [(1 to: parent basicSize) collect: [:i | parent basicAt: 297861i]]]. 297862 (kids select: [:x | references includesKey: x]) 297863 do: [:child | parents at: child put: parent]]]. 297864 ownerBags := Dictionary new. 297865 tallies := Bag new. 297866 n := 0. 297867 'Tallying Owners...' 297868 displayProgressAt: Sensor cursorPoint 297869 from: 0 to: references size 297870 during: [:bar | 297871 references keysDo: "For each class of obj, tally a bag of owner 297872classes" 297873 [:obj | bar value: (n := n+1). 297874 nm := obj class name. 297875 tallies add: nm. 297876 owners := ownerBags at: nm ifAbsent: [ownerBags at: nm put: Bag new]. 297877 (objParent := parents at: obj ifAbsent: [nil]) == nil 297878 ifFalse: [owners add: objParent class name]]]. 297879 ^ String streamContents: 297880 [:strm | tallies sortedCounts do: 297881 [:assn | n := assn key. nm := assn value. 297882 owners := ownerBags at: nm. 297883 strm cr; nextPutAll: nm; space; print: n. 297884 owners size > 0 ifTrue: 297885 [strm cr; tab; print: owners sortedCounts]]]! ! 297886 297887 297888!ReferenceStream methodsFor: 'writing' stamp: 'tk 10/2/2000 18:16'! 297889beginInstance: aClass size: anInteger 297890 "This is for use by storeDataOn: methods. Cf. Object>>storeDataOn:." 297891 "Addition of 1 seems to make extra work, since readInstance has to compensate. Here for historical reasons dating back to Kent Beck's original implementation in late 1988. 297892 In ReferenceStream, class is just 5 bytes for shared symbol. 297893 SmartRefStream puts out the names and number of class's instances variables for checking. 2978946/10/97 16:09 tk: See if we can put on a short header. Type = 16. " 297895 297896 | short ref | 297897 short := true. "All tests for object header that can be written in 4 bytes" 297898 anInteger <= 254 ifFalse: [short := false]. "one byte size" 297899 ref := references at: aClass name ifAbsent: [short := false. nil]. 297900 ref isInteger ifFalse: [short := false]. 297901 short ifTrue: [short := (ref < 65536) & (ref > 0) "& (ref ~= self vacantRef)"]. "vacantRef is big" 297902 short ifTrue: [ 297903 byteStream skip: -1. 297904 short := byteStream next = 9. 297905 byteStream skip: 0]. "ugly workaround" 297906 short 297907 ifTrue: ["passed all the tests!!" 297908 byteStream skip: -1; nextPut: 16; "type = short header" 297909 nextPut: anInteger + 1; "size is short" 297910 nextNumber: 2 put: ref] 297911 ifFalse: [ 297912 "default to normal longer object header" 297913 byteStream nextNumber: 4 put: anInteger + 1. 297914 self nextPut: aClass name]. 297915 insideASegment ifTrue: [ 297916 aClass isSystemDefined ifFalse: [self nextPut: aClass]]. 297917 "just record it to put it into roots"! ! 297918 297919!ReferenceStream methodsFor: 'writing' stamp: 'tk 3/15/98 19:54'! 297920blockers 297921 297922 ^ blockers! ! 297923 297924!ReferenceStream methodsFor: 'writing' stamp: 'tk 3/13/98 20:00'! 297925blockers: anIdentDict 297926 "maps objects -> nil if they should not be written. object -> anotherObject if they need substitution." 297927 297928 anIdentDict class == IdentityDictionary ifFalse: [self error: 'must be IdentityDictionary']. 297929 blockers := anIdentDict! ! 297930 297931!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/27/2000 11:37'! 297932insideASegment 297933 ^ insideASegment! ! 297934 297935!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/27/2000 11:36'! 297936insideASegment: aBoolean 297937 insideASegment := aBoolean! ! 297938 297939!ReferenceStream methodsFor: 'writing' stamp: 'tk 2/3/2000 21:21'! 297940isAReferenceType: typeID 297941 "Return true iff typeID is one of the classes that can be written as a reference to an instance elsewhere in the stream." 297942 297943 "too bad we can't put Booleans in an Array literal" 297944 ^ (RefTypes at: typeID) == 1 297945 "NOTE: If you get a bounds error here, the file probably has bad bits in it. The most common cause is a file unpacking program that puts linefeeds after carriage returns."! ! 297946 297947!ReferenceStream methodsFor: 'writing' stamp: 'jhm 11/15/92'! 297948nextPutWeak: anObject 297949 "Write a weak reference to anObject to the receiver stream. Answer anObject. 297950 If anObject is not a reference type of object, then just put it normally. 297951 A 'weak' reference means: If anObject gets written this stream via nextPut:, 297952 then its weak references will become normal references. Otherwise they'll 297953 read back as nil. -- " 297954 | typeID referencePosn | 297955 297956 "Is it a reference type of object? If not, just write it normally." 297957 typeID := self typeIDFor: anObject. 297958 (self isAReferenceType: typeID) ifFalse: [^ self nextPut: anObject]. 297959 297960 "Have we heard of and maybe even written anObject before?" 297961 referencePosn := references at: anObject ifAbsent: [ 297962 references at: anObject put: OrderedCollection new]. 297963 297964 "If referencePosn is an Integer, it's the stream position of anObject. 297965 Else it's a collection of hopeful weak-references to anObject." 297966 referencePosn isInteger ifFalse: 297967 [referencePosn add: byteStream position - basePos. "relative" 297968 referencePosn := self vacantRef]. 297969 self outputReference: referencePosn. "relative" 297970 297971 ^ anObject! ! 297972 297973!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/24/2000 09:18'! 297974objectIfBlocked: anObject 297975 "See if this object is blocked -- not written out and another object substituted." 297976 297977 ^ blockers at: anObject ifAbsent: [anObject]! ! 297978 297979!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/23/2000 08:41'! 297980project 297981 "Return the project we are writing or nil" 297982 297983 (topCall respondsTo: #isCurrentProject) ifTrue: [^ topCall]. 297984 (topCall respondsTo: #do:) ifTrue: [1 to: 5 do: [:ii | 297985 ((topCall at: ii) respondsTo: #isCurrentProject) ifTrue: [^ topCall at: ii]]]. 297986 ^ nil! ! 297987 297988!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/23/2000 08:40'! 297989projectChangeSet 297990 | pr | 297991 "The changeSet of the project we are writing" 297992 (pr := self project) ifNil: [^ nil]. 297993 ^ pr projectChangeSet! ! 297994 297995!ReferenceStream methodsFor: 'writing'! 297996references 297997 ^ references! ! 297998 297999!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/24/2000 16:44'! 298000replace: original with: proxy 298001 "We may wish to remember that in some field, the original object is being replaced by the proxy. For the hybred scheme that collects with a DummyStream and writes an ImageSegment, it needs to hold onto the originals so they will appear in outPointers, and be replaced." 298002 298003 blockers at: original put: proxy! ! 298004 298005!ReferenceStream methodsFor: 'writing' stamp: 'tk 8/18/1998 08:38'! 298006reset 298007 "PRIVATE -- Reset my internal state. 298008 11/15-17/92 jhm: Added transients and fwdRefEnds. 298009 7/11/93 sw: Give substantial initial sizes to avoid huge time spent growing. 298010 9/3/93 sw: monster version for Sasha" 298011 298012 super reset. 298013 references := IdentityDictionary new: 4096 * 5. 298014" objects := IdentityDictionary new: 4096 * 5. 298015 fwdRefEnds := IdentityDictionary new. 298016" 298017 blockers ifNil: [blockers := IdentityDictionary new]. 298018 ! ! 298019 298020!ReferenceStream methodsFor: 'writing' stamp: '6/9/97 08:24 tk'! 298021setCurrentReference: refPosn 298022 "PRIVATE -- Set currentReference to refPosn. Always a relative position." 298023 298024 currentReference := refPosn "relative position"! ! 298025 298026!ReferenceStream methodsFor: 'writing' stamp: 'RAA 1/18/2001 11:51'! 298027setStream: aStream 298028 "PRIVATE -- Initialization method." 298029 298030 super setStream: aStream. 298031 references := IdentityDictionary new: 4096 * 5. 298032 objects := IdentityDictionary new: 4096 * 5. 298033 fwdRefEnds := IdentityDictionary new. 298034 skipping := IdentitySet new. 298035 insideASegment := false. 298036 blockers ifNil: [blockers := IdentityDictionary new]. "keep blockers we just passed in" 298037! ! 298038 298039!ReferenceStream methodsFor: 'writing' stamp: 'RAA 1/18/2001 11:51'! 298040setStream: aStream reading: isReading 298041 "PRIVATE -- Initialization method." 298042 298043 super setStream: aStream reading: isReading. 298044 "isReading ifFalse: [ when we are sure" 298045 references := IdentityDictionary new: 4096 * 5. 298046 isReading ifTrue: [ 298047 objects := IdentityDictionary new: 4096 * 5. 298048 skipping := IdentitySet new. 298049 insideASegment := false. 298050 fwdRefEnds := IdentityDictionary new]. 298051 blockers ifNil: [blockers := IdentityDictionary new]. "keep blockers we just passed in" 298052! ! 298053 298054!ReferenceStream methodsFor: 'writing' stamp: 'tk 3/28/2000 22:19'! 298055tryToPutReference: anObject typeID: typeID 298056 "PRIVATE -- If we support references for type typeID, and if 298057 anObject already appears in my output stream, then put a 298058 reference to the place where anObject already appears. If we 298059 support references for typeID but didn't already put anObject, 298060 then associate the current stream position with anObject in 298061 case one wants to nextPut: it again. 298062 Return true after putting a reference; false if the object still 298063 needs to be put. 298064 : Added support for weak refs. Split out outputReference:. 298065 08:42 tk references stores relative file positions." 298066 | referencePosn nextPosn | 298067 298068 "Is it a reference type of object?" 298069 (self isAReferenceType: typeID) ifFalse: [^ false]. 298070 298071 "Have we heard of and maybe even written anObject before?" 298072 referencePosn := references at: anObject ifAbsent: 298073 ["Nope. Remember it and let the sender write it." 298074 references at: anObject put: (byteStream position - basePos). "relative" 298075 ^ false]. 298076 298077 "If referencePosn is an Integer, it's the stream position of anObject." 298078 referencePosn isInteger ifTrue: 298079 [self outputReference: referencePosn. "relative" 298080 ^ true]. 298081 298082 referencePosn == #none ifTrue: ["for DiskProxy" 298083 references at: anObject put: (byteStream position - basePos). "relative" 298084 ^ false]. 298085 298086 298087 "Else referencePosn is a collection of positions of weak-references to anObject. 298088 Make them full references since we're about to really write anObject." 298089 references at: anObject put: (nextPosn := byteStream position) - basePos. "store relative" 298090 referencePosn do: [:weakRefPosn | 298091 byteStream position: weakRefPosn + basePos. "make absolute" 298092 self outputReference: nextPosn - basePos]. "make relative" 298093 byteStream position: nextPosn. "absolute" 298094 ^ false! ! 298095 298096"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 298097 298098ReferenceStream class 298099 instanceVariableNames: ''! 298100 298101!ReferenceStream class methodsFor: 'accessing'! 298102refTypes: oc 298103 RefTypes := oc! ! 298104 298105!ReferenceStream class methodsFor: 'accessing' stamp: 'tk 5/26/1998 14:51'! 298106versionCode 298107 "Answer a number representing the 'version' of the ReferenceStream facility; this is stashed at the beginning of ReferenceStreams, as a secondary versioning mechanism (the primary one is the fileTypeCode). At present, it serves for information only, and is not checked for compatibility at reload time, but could in future be used to branch to variant code. " 298108 298109 " 1 = original version 1992" 298110 " 2 = HyperSqueak. PathFromHome used for Objs outside the tree. SqueakSupport SysLibrary for shared globals like Display and StrikeFonts. File has version number, class structure, then an IncomingObjects manager. 8/16/96 tk. 298111 Extended to SmartRefStream. class structure also keeps superclasse chain. Does analysis on structure to see when translation methods are needed. Embedable in file-ins. (factored out HyperSqueak support) Feb-May 97 tk" 298112 " 3 = Reference objects are byte offsets relative to the start of the object portion of the file. Rectangles with values -2048 to 2047 are encoded compactly." 298113 " 4 = If UniClasses (subclasses of Player) have class instance variables, append their values in the form (#Class43 (val1 val2 vla3)). An array of those. Can still read version 3." 298114 ^ 4! ! 298115 298116 298117!ReferenceStream class methodsFor: 'examples'! 298118example2 298119"Here is the way to use DataStream and ReferenceStream: 298120 rr := ReferenceStream fileNamed: ''test.obj''. 298121 rr nextPut: <your object>. 298122 rr close. 298123 298124To get it back: 298125 rr := ReferenceStream fileNamed: ''test.obj''. 298126 <your object> := rr next. 298127 rr close. 298128" 298129"An example and test of DataStream/ReferenceStream. 298130 11/19/92 jhm: Use self testWith:." 298131 "ReferenceStream example2" 298132 | input sharedPoint | 298133 298134 "Construct the test data." 298135 input := Array new: 9. 298136 input at: 1 put: nil. 298137 input at: 2 put: true. 298138 input at: 3 put: false. 298139 input at: 4 put: #(-4 -4.0 'four' four). 298140 input at: 5 put: (Form extent: 63 @ 50 depth: 8). 298141 (input at: 5) fillWithColor: Color lightOrange. 298142 input at: 6 put: 1024 @ -2048. 298143 input at: 7 put: input. "a cycle" 298144 input at: 8 put: (Array with: (sharedPoint := 0 @ -30000)). 298145 input at: 9 put: sharedPoint. 298146 298147 "Write it out, read it back, and return it for inspection." 298148 ^ self testWith: input 298149! ! 298150 298151 298152!ReferenceStream class methodsFor: 'instance creation' stamp: 'tk 4/19/2001 16:50'! 298153on: aStream 298154 "Open a new ReferenceStream on a place to put the raw data." 298155 298156 aStream class == ReadWriteStream ifTrue: [ 298157 self inform: 'Please consider using a RWBinaryOrTextStream 298158instead of a ReadWriteStream']. 298159 298160 ^ super on: aStream 298161! ! 298162RegexError subclass: #RegexCompilationError 298163 instanceVariableNames: '' 298164 classVariableNames: '' 298165 poolDictionaries: '' 298166 category: 'VB-Regex-Exceptions'! 298167Error subclass: #RegexError 298168 instanceVariableNames: '' 298169 classVariableNames: '' 298170 poolDictionaries: '' 298171 category: 'VB-Regex-Exceptions'! 298172RegexError subclass: #RegexMatchingError 298173 instanceVariableNames: '' 298174 classVariableNames: '' 298175 poolDictionaries: '' 298176 category: 'VB-Regex-Exceptions'! 298177RegexError subclass: #RegexSyntaxError 298178 instanceVariableNames: '' 298179 classVariableNames: '' 298180 poolDictionaries: '' 298181 category: 'VB-Regex-Exceptions'! 298182InstructionPrinter subclass: #RelativeInstructionPrinter 298183 instanceVariableNames: 'printCode labels labelling' 298184 classVariableNames: '' 298185 poolDictionaries: '' 298186 category: 'Kernel-Methods'! 298187 298188!RelativeInstructionPrinter methodsFor: 'initialize-release' stamp: 'eem 5/15/2008 10:56'! 298189printCode: aBoolean 298190 printCode := aBoolean! ! 298191 298192 298193!RelativeInstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/15/2008 11:29'! 298194jump: offset 298195 "Print the Unconditional Jump bytecode." 298196 298197 labelling 298198 ifTrue: 298199 [labels at: scanner pc + offset + 1 put: true. 298200 self print: 'jumpBy: ', offset printString, 298201 ' to: ', (scanner pc + offset - method initialPC) printString] 298202 ifFalse: 298203 [self print: 'jumpTo: ', (labels at: scanner pc + offset + 1)]! ! 298204 298205!RelativeInstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/15/2008 11:29'! 298206jump: offset if: condition 298207 "Print the Conditional Jump bytecode." 298208 298209 labelling 298210 ifTrue: 298211 [labels at: scanner pc + offset + 1 put: true. 298212 self print: 298213 (condition ifTrue: ['jumpTrueBy: '] ifFalse: ['jumpFalseBy: ']), offset printString, 298214 ' to: ', (labelling 298215 ifTrue: [(scanner pc + offset - method initialPC) printString] 298216 ifFalse: [labels at: scanner pc + offset])] 298217 ifFalse: 298218 [self print: 298219 (condition ifTrue: ['jumpTrueTo: '] ifFalse: ['jumpFalseTo: ']), (labels at: scanner pc + offset + 1)]! ! 298220 298221!RelativeInstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/16/2008 17:10'! 298222send: selector super: supered numArgs: numArgs 298223 "Print the Send Message With Selector, selector, bytecode. The argument, 298224 supered, indicates whether the receiver of the message is specified with 298225 'super' in the source method. The arguments of the message are found in 298226 the top numArguments locations on the stack and the receiver just 298227 below them." 298228 298229 self print: (supered 298230 ifTrue: ['superSend: '] 298231 ifFalse: ['send: ']) 298232 , selector storeString 298233 , (numArgs = 1 298234 ifTrue: [' (1 arg)'] 298235 ifFalse: [' (', numArgs printString, ' args)'])! ! 298236 298237 298238!RelativeInstructionPrinter methodsFor: 'printing' stamp: 'eem 5/29/2008 13:49'! 298239print: instruction 298240 "Append to the receiver a description of the bytecode, instruction." 298241 298242 stream tab: self indent. 298243 labelling 298244 ifTrue: [stream print: oldPC - method initialPC; space] 298245 ifFalse: [stream tab]. 298246 stream tab: (innerIndents at: oldPC). 298247 self printCode ifTrue: 298248 [stream nextPut: $<. 298249 oldPC to: scanner pc - 1 do: 298250 [:i | | code | 298251 code := (method at: i) radix: 16. 298252 stream 298253 nextPut: (code size < 2 ifTrue: [$0] ifFalse: [code at: 1]); 298254 nextPut: code last; 298255 space]. 298256 stream skip: -1; nextPut: $>; space]. 298257 stream nextPutAll: instruction. 298258 stream cr. 298259 labelling ifFalse: 298260 [(labels at: scanner pc + 1) ~~ false ifTrue: 298261 [stream nextPutAll: (labels at: scanner pc + 1); nextPut: $:; cr]]. 298262 oldPC := scanner pc! ! 298263 298264!RelativeInstructionPrinter methodsFor: 'printing' stamp: 'eem 5/15/2008 10:56'! 298265printCode 298266 ^printCode ~~ false! ! 298267 298268!RelativeInstructionPrinter methodsFor: 'printing' stamp: 'eem 5/21/2008 12:24'! 298269printInstructionsOn: aStream 298270 "Append to the stream, aStream, a description of each bytecode in the instruction stream." 298271 298272 | label | 298273 labelling := true. 298274 labels := Array new: method size + 1 withAll: false. 298275 super printInstructionsOn: (String new: 1024) writeStream. 298276 label := 0. 298277 labels withIndexDo: 298278 [:bool :index| 298279 bool ifTrue: [labels at: index put: 'L', (label := label + 1) printString]]. 298280 labelling := false. 298281 super printInstructionsOn: aStream! ! 298282 298283!RelativeInstructionPrinter methodsFor: 'printing' stamp: 'eem 5/15/2008 13:17'! 298284printInstructionsOn: aStream do: aBlock 298285 "Append to the stream, aStream, a description of each bytecode in the instruction stream. 298286 Evaluate aBlock with the receiver, the scanner and the stream after each instruction." 298287 298288 | label | 298289 labelling := true. 298290 labels := Array new: method size withAll: false. 298291 super printInstructionsOn: (String new: 1024) writeStream do: [:ig :no :re|]. 298292 label := 0. 298293 labels withIndexDo: 298294 [:bool :index| 298295 bool ifTrue: [labels at: index put: 'L', (label := label + 1) printString]]. 298296 labelling := false. 298297 super printInstructionsOn: aStream do: aBlock! ! 298298TestCase subclass: #ReleaseTest 298299 instanceVariableNames: '' 298300 classVariableNames: '' 298301 poolDictionaries: '' 298302 category: 'Tests-Release'! 298303 298304!ReleaseTest methodsFor: 'testing' stamp: 'al 6/29/2008 17:22'! 298305expectedFailures 298306 ^#(testUnimplementedNonPrimitiveCalls)! ! 298307 298308!ReleaseTest methodsFor: 'testing' stamp: 'oscar.nierstrasz 10/18/2009 12:14'! 298309testObsoleteClasses 298310 SmalltalkImage current fixObsoleteReferences. 298311 self assert: SystemNavigation default obsoleteClasses isEmpty! ! 298312 298313!ReleaseTest methodsFor: 'testing' stamp: 'marcus.denker 8/18/2008 21:40'! 298314testUndeclared 298315 Smalltalk cleanOutUndeclared. 298316 self assert: Undeclared isEmpty 298317 ! ! 298318 298319!ReleaseTest methodsFor: 'testing' stamp: 'al 6/29/2008 17:15'! 298320testUnimplementedNonPrimitiveCalls 298321 self assert: (SystemNavigation default allClassesWithUnimplementedCalls 298322 associationsSelect: [ :each | (each key inheritsFrom: TestCase) not ]) isEmpty.! ! 298323RWBinaryOrTextStream subclass: #RemoteFileStream 298324 instanceVariableNames: 'remoteFile localDataValid' 298325 classVariableNames: '' 298326 poolDictionaries: '' 298327 category: 'Network-RemoteDirectory'! 298328!RemoteFileStream commentStamp: '<historical>' prior: 0! 298329An in-memory stream that can be used to fileIn code from the network. Knows its ServerFile, and thus its name, path, etc. 298330 298331localDataValid -- false when have never read the file from the server. Set to true after reading, when my contents has the true data. When creating a remote file, set localDataValid to true so it will write to server.! 298332 298333 298334!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 12/3/2003 21:04'! 298335close 298336 "Write if we have data to write. FTP files are always binary to preserve the data exactly. The binary/text (ascii) flag is just for tell how the bits are delivered from a read." 298337 298338 remoteFile writable ifTrue: [ 298339 remoteFile putFile: (self as: RWBinaryOrTextStream) reset named: remoteFile fileName]! ! 298340 298341!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 1/13/2000 21:47'! 298342contentsOfEntireFile 298343 "Fetch the data off the server and store it in me. But not if I already have it." 298344 298345 readLimit := readLimit max: position. 298346 localDataValid ifTrue: [^ super contentsOfEntireFile]. 298347 collection size = 0 ifTrue: [self on: (String new: 2000)]. 298348 remoteFile getFileNamed: remoteFile fileName into: self. "sets localDataValid := true" 298349 ^ super contentsOfEntireFile! ! 298350 298351!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 1/13/2000 21:45'! 298352dataIsValid 298353 298354 localDataValid := true.! ! 298355 298356!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 09:19'! 298357directory 298358 ^ remoteFile! ! 298359 298360!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 3/13/2000 16:51'! 298361directoryUrl 298362 ^ remoteFile directoryUrl! ! 298363 298364!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 14:30'! 298365localName 298366 ^ remoteFile fileName! ! 298367 298368!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 1/13/2000 21:48'! 298369openReadOnly 298370 "If we have data, don't reread." 298371 298372 self readOnly. 298373 readLimit := readLimit max: position. 298374 localDataValid ifFalse: [remoteFile getFileNamed: remoteFile fileName into: self]. 298375 "sets localDataValid := true"! ! 298376 298377!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 11/24/1998 22:43'! 298378padToEndWith: aChar 298379 "On the Mac, files do not truncate, so pad it with a harmless character. But Remote FTP files always replace, so no need to pad." 298380 298381 self atEnd ifFalse: [self inform: 'Why is this stream not at its end?'].! ! 298382 298383!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 14:32'! 298384readOnly 298385 ^ remoteFile readOnly! ! 298386 298387!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 09:18'! 298388remoteFile 298389 ^ remoteFile! ! 298390 298391!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 1/13/2000 21:39'! 298392remoteFile: aServerFile 298393 remoteFile := aServerFile. 298394 localDataValid := false. "need to read from the server"! ! 298395 298396!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 9/11/2000 19:13'! 298397sleep 298398 "If we are done, then let the server know" 298399 298400 self close. 298401 remoteFile sleep.! ! 298402Object subclass: #RemoteString 298403 instanceVariableNames: 'sourceFileNumber filePositionHi' 298404 classVariableNames: 'CurrentTextAttStructure CurrentTextAttVersion TextAttributeStructureVersions' 298405 poolDictionaries: '' 298406 category: 'Files-System'! 298407!RemoteString commentStamp: '<historical>' prior: 0! 298408My instances provide an external file reference to a piece of text. It may be the sourceCode of a method, or the class comments of a class. 298409 298410The changes file or file-in file usually has a chunk that is just the source string of a method: 298411 298412max: aNumber 298413 ^ self > aNumber ifTrue: [self] ifFalse: [aNumber]!! 298414 298415I can return either a String or a Text. Some a chunk is followed by a second chunk (beginning with ]style[) containing style information. The encoding is like this: 298416 298417max: aNumber 298418 ^ self > aNumber ifTrue: [self] ifFalse: [aNumber]!! 298419]style[(14 50 312)f1,f1b,f1LInteger +;i!! 298420 298421Allowed TextAttributes are TextFontChange, TextEmphasis, TextColor, TextDoIt, TextKern, TextLink, TextURL. TextFontReference and TextAnchor are not supported. 298422 298423See PositionableStream nextChunkText and RunArray class scanFrom:.! 298424]style[(748 32 5 24 1)f1,f1LPositionableStream nextChunkText;,f1,f1LRunArray class scanFrom:;,f1! 298425 298426 298427!RemoteString methodsFor: 'accessing' stamp: 'gvc 9/26/2008 17:11'! 298428fileStream 298429 "Answer the file stream with position set at the beginning of my string. 298430 Answer a read only copy to avoid syntax errors when accessed via 298431 multiple processes." 298432 298433 | theFile | 298434 (sourceFileNumber == nil or: [(SourceFiles at: sourceFileNumber) == nil]) ifTrue: [^ nil]. 298435 theFile := (SourceFiles at: sourceFileNumber) readOnlyCopy. 298436 theFile position: filePositionHi. 298437 ^ theFile! ! 298438 298439!RemoteString methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! 298440last 298441 ^self string ifNotNil: [ :s | s last ]! ! 298442 298443!RemoteString methodsFor: 'accessing'! 298444position 298445 "Answer the location of the string on a file." 298446 298447 ^ filePositionHi! ! 298448 298449!RemoteString methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'! 298450setSourcePointer: aSourcePointer 298451 sourceFileNumber := SourceFiles fileIndexFromSourcePointer: aSourcePointer. 298452 filePositionHi := SourceFiles filePositionFromSourcePointer: aSourcePointer! ! 298453 298454!RemoteString methodsFor: 'accessing'! 298455sourceFileNumber 298456 "Answer the index of the file on which the string is stored." 298457 298458 ^sourceFileNumber! ! 298459 298460!RemoteString methodsFor: 'accessing' stamp: 'hmm 4/26/2000 20:47'! 298461sourcePointer 298462 sourceFileNumber ifNil: [^ 0]. 298463 ^SourceFiles sourcePointerFromFileIndex: sourceFileNumber andPosition: filePositionHi! ! 298464 298465!RemoteString methodsFor: 'accessing' stamp: 'nice 5/1/2009 18:25'! 298466string 298467 "Answer the receiver's string if remote files are enabled. 298468 Use a read only copy to avoid syntax errors when accessed via 298469 multiple processes." 298470 298471 | theFile | 298472 (sourceFileNumber == nil or: [(SourceFiles at: sourceFileNumber) == nil]) ifTrue: [^'']. 298473 theFile := (SourceFiles at: sourceFileNumber) readOnlyCopy. 298474 ^[theFile position: filePositionHi. 298475 theFile nextChunk] ensure: [theFile close]! ! 298476 298477!RemoteString methodsFor: 'accessing' stamp: 'nice 5/1/2009 18:26'! 298478text 298479 "Answer the receiver's string asText if remote files are enabled. 298480 Use a read only copy to avoid syntax errors when accessed via 298481 multiple processes." 298482 298483 | theFile | 298484 (sourceFileNumber == nil or: [(SourceFiles at: sourceFileNumber) == nil]) ifTrue: [^ nil]. 298485 theFile := (SourceFiles at: sourceFileNumber) readOnlyCopy. 298486 ^[theFile position: filePositionHi. 298487 theFile position > theFile size ifTrue: [ 298488 self error: 'RemoteString past end of file' ]. 298489 theFile nextChunkText] ensure: [theFile close]! ! 298490 298491 298492!RemoteString methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'! 298493checkSum: aString 298494 "Construct a checksum of the string. A three byte number represented as Base64 characters." 298495 298496| sum shift bytes ss bb | 298497sum := aString size. 298498shift := 0. 298499aString do: [:char | 298500 (shift := shift + 7) > 16 ifTrue: [shift := shift - 17]. 298501 "shift by 7 to keep a change of adjacent chars from xoring to same value" 298502 sum := sum bitXor: (char asInteger bitShift: shift)]. 298503bytes := ByteArray new: 3. 298504sum := sum + 16r10000000000. 2985051 to: 3 do: [:ind | bytes at: ind put: (sum digitAt: ind)]. 298506ss := ReadWriteStream on: (ByteArray new: 3). 298507ss nextPutAll: bytes. 298508bb := Base64MimeConverter mimeEncode: ss. 298509^ bb contents! ! 298510 298511!RemoteString methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:32'! 298512fileNumber: fileNumber position: position 298513 298514 sourceFileNumber := fileNumber. 298515 filePositionHi := position! ! 298516 298517!RemoteString methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'! 298518makeNewTextAttVersion 298519 "Create a new TextAttributes version because some inst var has changed. If no change, don't make a new one." 298520 "Don't delete this method even though it has no callers!!!!!!!!!!" 298521 298522| obj cls struct tag | 298523"Note that TextFontReference and TextAnchor are forbidden." 298524obj := #(RunArray TextDoIt TextLink TextURL TextColor TextEmphasis TextFontChange TextKern TextLinkToImplementors 3 'a string') collect: [:each | 298525 cls := Smalltalk at: each ifAbsent: [nil]. 298526 cls ifNil: [each] ifNotNil: [cls new]]. 298527struct := (SmartRefStream on: (RWBinaryOrTextStream on: String new)) instVarInfo: obj. 298528tag := self checkSum: struct printString. 298529TextAttributeStructureVersions ifNil: [TextAttributeStructureVersions := Dictionary new]. 298530(struct = CurrentTextAttStructure) & (tag = CurrentTextAttVersion) 298531 ifTrue: [^ false]. 298532CurrentTextAttStructure := struct. 298533CurrentTextAttVersion := tag. 298534TextAttributeStructureVersions at: tag put: struct. 298535^ true! ! 298536 298537!RemoteString methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:32'! 298538string: aString onFileNumber: fileNumber 298539 "Store this as my string if source files exist." 298540 | theFile | 298541 (SourceFiles at: fileNumber) == nil ifFalse: 298542 [theFile := SourceFiles at: fileNumber. 298543 theFile setToEnd; cr. 298544 self string: aString onFileNumber: fileNumber toFile: theFile]! ! 298545 298546!RemoteString methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'! 298547string: aStringOrText onFileNumber: fileNumber toFile: aFileStream 298548 "Store this as the receiver's text if source files exist. If aStringOrText is a Text, store a marker with the string part, and then store the runs of TextAttributes in the next chunk." 298549 298550 | position | 298551 position := aFileStream position. 298552 self fileNumber: fileNumber position: position. 298553 aFileStream nextChunkPutWithStyle: aStringOrText 298554 "^ self (important)"! ! 298555 298556"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 298557 298558RemoteString class 298559 instanceVariableNames: ''! 298560 298561!RemoteString class methodsFor: 'as yet unclassified' stamp: 'tk 12/12/97 11:46'! 298562currentTextAttVersion 298563 "The current configuration of the TextAttributes classes has a structures array describing the inst vars of the classes (SmartRefStream instVarInfo:). Return tag that indexes the TextAttributeStructureVersions dictionary (4 random characters)." 298564 298565 ^ CurrentTextAttVersion 298566 "Be sure to run makeNewTextAttVersion when any TextAttributes class changes inst vars"! ! 298567 298568!RemoteString class methodsFor: 'as yet unclassified' stamp: 'tk 12/11/97 10:35'! 298569initialize 298570 "Derive the current TextAttributes classes object structure" 298571 298572 self new makeNewTextAttVersion! ! 298573 298574!RemoteString class methodsFor: 'as yet unclassified'! 298575newFileNumber: sourceIndex position: anInteger 298576 "Answer an instance of me fora file indexed by sourceIndex, at the 298577 position anInteger. Assume that the string is already stored on the file 298578 and the instance will be used to access it." 298579 298580 ^self new fileNumber: sourceIndex position: anInteger! ! 298581 298582!RemoteString class methodsFor: 'as yet unclassified'! 298583newString: aString onFileNumber: sourceIndex 298584 "Answer an instance of me for string, aString, on file indexed by 298585 sourceIndex. Put the string on the file and create the remote reference." 298586 298587 ^self new string: aString onFileNumber: sourceIndex! ! 298588 298589!RemoteString class methodsFor: 'as yet unclassified'! 298590newString: aString onFileNumber: sourceIndex toFile: aFileStream 298591 "Answer an instance of me for string, aString, on file indexed by 298592 sourceIndex. Put the string on the file, aFileStream, and create the 298593 remote reference. Assume that the index corresponds properly to 298594 aFileStream." 298595 298596 ^self new string: aString onFileNumber: sourceIndex toFile: aFileStream! ! 298597 298598!RemoteString class methodsFor: 'as yet unclassified' stamp: 'tk 12/13/97 13:36'! 298599structureAt: styleVersion 298600 298601 ^ TextAttributeStructureVersions at: styleVersion ifAbsent: [nil]! ! 298602TempVariableNode subclass: #RemoteTempVectorNode 298603 instanceVariableNames: 'remoteTemps readNode writeNode' 298604 classVariableNames: '' 298605 poolDictionaries: '' 298606 category: 'Compiler-ParseNodes'! 298607!RemoteTempVectorNode commentStamp: '<historical>' prior: 0! 298608I am a node for a vector of remote temps, created to share temps between closures when those temps are written to in closures other than their defining ones.! 298609]style[(157)i! 298610 298611 298612!RemoteTempVectorNode methodsFor: 'accessing' stamp: 'eem 6/2/2008 16:47'! 298613remoteTemps 298614 ^remoteTemps! ! 298615 298616 298617!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 5/29/2008 16:19'! 298618addRemoteTemp: aTempVariableNode encoder: encoder 298619 remoteTemps isNil ifTrue: 298620 [remoteTemps := OrderedCollection new]. 298621 remoteTemps addLast: aTempVariableNode. 298622 aTempVariableNode referenceScopesAndIndicesDo: 298623 [:scopeBlock "<BlockNode>" :location "<Integer>"| 298624 self addReadWithin: scopeBlock at: location]. 298625 encoder supportsClosureOpcodes ifFalse: 298626 [encoder encodeLiteral: remoteTemps size. 298627 readNode := encoder encodeSelector: #at:. 298628 writeNode := encoder encodeSelector: #at:put:]! ! 298629 298630!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 5/24/2008 18:20'! 298631emitCodeForIndexOf: aTempVariableNode stack: stack encoder: encoder 298632 self assert: encoder supportsClosureOpcodes not. 298633 (encoder encodeLiteral: (remoteTemps indexOf: aTempVariableNode)) 298634 emitCodeForValue: stack encoder: encoder! ! 298635 298636!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 5/24/2008 18:19'! 298637emitCodeForLoadFor: aTempVariableNode stack: stack encoder: encoder 298638 encoder supportsClosureOpcodes ifTrue: 298639 [^self]. 298640 "Need to generate the first half of 298641 tempVector at: index put: expr 298642 i.e. the push of tempVector and index." 298643 super emitCodeForValue: stack encoder: encoder. 298644 self emitCodeForIndexOf: aTempVariableNode stack: stack encoder: encoder! ! 298645 298646!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 5/24/2008 23:02'! 298647emitCodeForStoreInto: aTempVariableNode stack: stack encoder: encoder 298648 encoder supportsClosureOpcodes 298649 ifTrue: 298650 [encoder 298651 genStoreRemoteTemp: (remoteTemps indexOf: aTempVariableNode) - 1 298652 inVectorAt: index] 298653 ifFalse: 298654 [writeNode 298655 emitCode: stack 298656 args: 2 298657 encoder: encoder 298658 super: false]! ! 298659 298660!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 5/24/2008 23:02'! 298661emitCodeForStorePopInto: aTempVariableNode stack: stack encoder: encoder 298662 encoder supportsClosureOpcodes 298663 ifTrue: 298664 [encoder 298665 genStorePopRemoteTemp: (remoteTemps indexOf: aTempVariableNode) - 1 298666 inVectorAt: index] 298667 ifFalse: 298668 [self emitCodeForStoreInto: aTempVariableNode stack: stack encoder: encoder. 298669 encoder genPop]. 298670 stack pop: 1! ! 298671 298672!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 5/24/2008 23:20'! 298673emitCodeForValueOf: aTempVariableNode stack: stack encoder: encoder 298674 encoder supportsClosureOpcodes 298675 ifTrue: 298676 [encoder 298677 genPushRemoteTemp: (remoteTemps indexOf: aTempVariableNode) - 1 298678 inVectorAt: index. 298679 stack push: 1] 298680 ifFalse: 298681 [self emitCodeForLoadFor: aTempVariableNode stack: stack encoder: encoder. 298682 readNode 298683 emitCode: stack 298684 args: 1 298685 encoder: encoder 298686 super: false]! ! 298687 298688!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 6/2/2008 16:50'! 298689isIndirectTempVector 298690 ^true! ! 298691 298692!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 9/25/2008 17:16'! 298693nodeToInitialize: encoder 298694 ^AssignmentNode new 298695 variable: self 298696 value: (encoder supportsClosureOpcodes 298697 ifTrue: [NewArrayNode new numElements: remoteTemps size] 298698 ifFalse: 298699 [MessageNode new 298700 receiver: (encoder encodeVariable: 'Array') 298701 selector: #new: 298702 arguments: (Array with: (encoder encodeLiteral: remoteTemps size)) 298703 precedence: 3 298704 from: encoder])! ! 298705 298706!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 5/20/2008 17:57'! 298707referenceScopesAndIndicesDo: aBinaryBlock 298708 self shouldNotImplement! ! 298709 298710!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 9/8/2008 10:47'! 298711scope 298712 "Answer scope of temporary variables. 298713 Currently only the following distinctions are made: 298714 0 outer level: args and user-declared temps 298715 1 block args and doLimiT temps 298716 -1 a block temp that is no longer active 298717 -2 a block temp that held limit of to:do: 298718 -3 an indirect temp vector" 298719 ^-3! ! 298720 298721!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 5/24/2008 18:20'! 298722sizeCodeForIndexOf: aTempVariableNode encoder: encoder 298723 self assert: encoder supportsClosureOpcodes not. 298724 ^(encoder encodeLiteral: (remoteTemps indexOf: aTempVariableNode)) sizeCodeForValue: encoder! ! 298725 298726!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 5/24/2008 18:19'! 298727sizeCodeForLoadFor: aTempVariableNode encoder: encoder 298728 encoder supportsClosureOpcodes ifTrue: 298729 [^0]. 298730 "Need to size the first half of 298731 tempVector at: index put: expr 298732 i.e. the push of tempVector and index." 298733 ^(super sizeCodeForValue: encoder) 298734 + (self sizeCodeForIndexOf: aTempVariableNode encoder: encoder)! ! 298735 298736!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 5/24/2008 18:24'! 298737sizeCodeForStoreInto: aTempVariableNode encoder: encoder 298738 encoder supportsClosureOpcodes ifTrue: 298739 [^encoder sizeStoreRemoteTemp: (remoteTemps indexOf: aTempVariableNode) - 1 inVectorAt: index]. 298740 ^writeNode sizeCode: encoder args: 2 super: false! ! 298741 298742!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 5/24/2008 18:23'! 298743sizeCodeForStorePopInto: aTempVariableNode encoder: encoder 298744 encoder supportsClosureOpcodes ifTrue: 298745 [^encoder sizeStorePopRemoteTemp: (remoteTemps indexOf: aTempVariableNode) - 1 inVectorAt: index]. 298746 ^(self sizeCodeForStoreInto: aTempVariableNode encoder: encoder) 298747 + encoder sizePop! ! 298748 298749!RemoteTempVectorNode methodsFor: 'code generation (closures)' stamp: 'eem 5/24/2008 18:23'! 298750sizeCodeForValueOf: aTempVariableNode encoder: encoder 298751 encoder supportsClosureOpcodes ifTrue: 298752 [^encoder sizePushRemoteTemp: (remoteTemps indexOf: aTempVariableNode) - 1 inVectorAt: index]. 298753 ^(self sizeCodeForValue: encoder) 298754 + (self sizeCodeForIndexOf: aTempVariableNode encoder: encoder) 298755 + (readNode sizeCode: encoder args: 1 super: false)! ! 298756 298757 298758!RemoteTempVectorNode methodsFor: 'decompiler' stamp: 'eem 9/25/2008 09:46'! 298759remoteTemps: anArray 298760 remoteTemps := anArray. 298761 anArray do: [:tempNode| tempNode remoteNode: self]! ! 298762 298763 298764!RemoteTempVectorNode methodsFor: 'printing' stamp: 'eem 7/23/2008 21:21'! 298765printDefinitionForClosureAnalysisOn: aStream 298766 | refs | 298767 aStream 298768 nextPut: ${; 298769 nextPutAll: key. 298770 definingScope ifNotNil: [definingScope blockExtent ifNotNil: [:be| aStream nextPutAll: ' d@'; print: be first]]. 298771 readingScopes notNil ifTrue: 298772 [refs := Set new. 298773 readingScopes do: [:elems| refs addAll: elems]. 298774 refs asSortedCollection do: [:read| aStream nextPutAll: ' r@'; print: read]]. 298775 remoteTemps 298776 do: [:rt| rt printDefinitionForClosureAnalysisOn: aStream] 298777 separatedBy: [aStream nextPut: $,; space]. 298778 aStream nextPut: $}! ! 298779 298780 298781!RemoteTempVectorNode methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:51'! 298782accept: aVisitor 298783 aVisitor visitRemoteTempVectorNode: self! ! 298784AbstractEvent subclass: #RemovedEvent 298785 instanceVariableNames: '' 298786 classVariableNames: '' 298787 poolDictionaries: '' 298788 category: 'System-Change Notification'! 298789 298790!RemovedEvent methodsFor: 'printing' stamp: 'rw 6/30/2003 09:31'! 298791printEventKindOn: aStream 298792 298793 aStream nextPutAll: 'Removed'! ! 298794 298795 298796!RemovedEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:35'! 298797isRemoved 298798 298799 ^true! ! 298800 298801"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 298802 298803RemovedEvent class 298804 instanceVariableNames: ''! 298805 298806!RemovedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:09'! 298807changeKind 298808 298809 ^#Removed! ! 298810 298811!RemovedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:28'! 298812supportedKinds 298813 "All the kinds of items that this event can take." 298814 298815 ^ Array with: self classKind with: self methodKind with: self categoryKind with: self protocolKind! ! 298816AbstractEvent subclass: #RenamedEvent 298817 instanceVariableNames: 'newName oldName' 298818 classVariableNames: '' 298819 poolDictionaries: '' 298820 category: 'System-Change Notification'! 298821 298822!RenamedEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 12:18'! 298823newName 298824 ^ newName! ! 298825 298826!RenamedEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 12:18'! 298827newName: aName 298828 298829 newName := aName! ! 298830 298831!RenamedEvent methodsFor: 'accessing' stamp: 'rw 7/1/2003 12:00'! 298832oldName 298833 298834 ^oldName! ! 298835 298836!RenamedEvent methodsFor: 'accessing' stamp: 'rw 7/1/2003 12:01'! 298837oldName: aName 298838 298839 oldName := aName! ! 298840 298841 298842!RenamedEvent methodsFor: 'printing' stamp: 'rw 7/1/2003 11:34'! 298843printEventKindOn: aStream 298844 298845 aStream nextPutAll: 'Renamed'! ! 298846 298847 298848!RenamedEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:34'! 298849isRenamed 298850 298851 ^true! ! 298852 298853"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 298854 298855RenamedEvent class 298856 instanceVariableNames: ''! 298857 298858!RenamedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:09'! 298859changeKind 298860 298861 ^#Renamed! ! 298862 298863!RenamedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:30'! 298864supportedKinds 298865 "All the kinds of items that this event can take." 298866 298867 ^ Array with: self classKind with: self categoryKind with: self protocolKind! ! 298868 298869 298870!RenamedEvent class methodsFor: 'instance creation' stamp: 'ab 2/10/2005 16:49'! 298871classCategoryRenamedFrom: anOldClassCategoryName to: aNewClassCategoryName 298872 298873 ^(self classCategory: anOldClassCategoryName) oldName: anOldClassCategoryName; newName: aNewClassCategoryName! ! 298874 298875!RenamedEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 12:19'! 298876class: aClass category: cat oldName: oldName newName: newName 298877 298878 ^(self class: aClass category: cat) oldName: oldName; newName: newName! ! 298879MorphicUIBugTest subclass: #RenderBugz 298880 instanceVariableNames: '' 298881 classVariableNames: '' 298882 poolDictionaries: '' 298883 category: 'Tests-Bugs'! 298884!RenderBugz commentStamp: 'wiz 5/15/2008 22:58' prior: 0! 298885A RenderBugz is an infinite recursion bug test for TransformationMorphs. 298886 298887In 3.9 (7067) and before, when TransformationMorph has no rendee there are several methods that will infinitely recurse until manually stopped or the image runs out of memory. 298888 298889So far the ones I've caught are the getters and setters for heading and forwardDirection. 298890 298891So there are tests for them here. 298892 298893Ideally there would be a way to run a test against a stopwatch to catch endless recursion. 298894Found it. Now incorperated. And the tests should be both save to run and cleanup after themselves even when they fail. 298895 298896So far we have not tested the normal cases of rendering working. 298897I will leave that as a separate task for another time. 298898 298899So this is an automatic test when the bugs are fixed and interactive (crash) tests when the bugs are present. 298900 298901Instance Variables 298902 298903 298904Revision notes. wiz 5/15/2008 22:58 298905 298906When running tests from the TestRunner browser the test would sporadically fail. 298907When they failed a transfomation morph would be left on the screen and not removed by the 298908ensureBlock. 298909 298910So I changed things to fall under MorphicUIBugTests because that had a cleanup mechansizm for left over morphs. 298911 298912I also added one routine to test for time and one parameter to determine the time limit. 298913To my surprise doubling or tripling the time limit still produced sporadic errors when the test is run repeatedly enough ( I am using a 400mz iMac. ) So now the parameter is set to 4. Things will probably fail there if tried long enough. At that point try 5 etc. 298914 298915I am reluctant to make the number larger than necessary. The tighter the test the more you know what is working. 298916 298917I also added a dummy test to check specifically for the timing bug. It fails on the same sporadic basis as the other test went the time parameter is short enough. This lends confidence to the theory that the timing difficulty is coming from outside the test. The sunit runner puts up a progress morph for each test. So the morphic display stuff is busy and probably also the GC. 298918! 298919 298920 298921!RenderBugz methodsFor: 'as yet unclassified' stamp: 'wiz 5/15/2008 22:44'! 298922long 298923"return time limit in milliseconds for tests" 298924^4! ! 298925 298926!RenderBugz methodsFor: 'as yet unclassified' stamp: 'wiz 5/14/2008 23:25'! 298927shouldntTakeLong: aBlock 298928"Check for infinite recursion. Test should finish in a reasonable time." 298929 298930^self should: aBlock 298931 notTakeMoreThanMilliseconds: self long . 298932! ! 298933 298934!RenderBugz methodsFor: 'as yet unclassified' stamp: 'wiz 5/15/2008 22:36'! 298935testForward 298936"If the bug exist there will be an infinte recursion." 298937"self new testForward" 298938"self run: #testForward" 298939 298940| t | 298941cases := { 298942t := TransformationMorph new openCenteredInWorld } . 298943 298944 self shouldntTakeLong: [self assert: ( t forwardDirection = 0.0 ) ] . 298945 298946^true 298947! ! 298948 298949!RenderBugz methodsFor: 'as yet unclassified' stamp: 'wiz 5/15/2008 22:34'! 298950testHeading 298951"If the bug exist there will be an infinte recursion." 298952"self new testHeading" 298953"self run: #testHeading" 298954 298955| t | 298956cases := { 298957t := TransformationMorph new openCenteredInWorld } . 298958 298959 self shouldntTakeLong: [ [self assert: ( t heading = 0.0 ) ] 298960 ensure: [ t delete ] ] . 298961 298962^true 298963! ! 298964 298965!RenderBugz methodsFor: 'as yet unclassified' stamp: 'wiz 5/15/2008 22:35'! 298966testSetForward 298967"If the bug exist there will be an infinte reccursion." 298968"self new testSetForward" 298969"self run: #testSetForward" 298970 298971| t | 298972cases := { 298973t := TransformationMorph new openCenteredInWorld } . 298974 298975 self shouldntTakeLong: [ t forwardDirection: 180.0 . 298976 self assert: ( t forwardDirection = 0.0 ) ] . 298977 298978"and without a rendee it should not change things." 298979 298980^true 298981! ! 298982 298983!RenderBugz methodsFor: 'as yet unclassified' stamp: 'wiz 5/15/2008 22:35'! 298984testSetHeading 298985"If the bug exist there will be an infinte recursion." 298986"self new testSetHeading" 298987"self run: #testSetHeading" 298988 298989| t | 298990cases := { 298991t := TransformationMorph new openCenteredInWorld } . 298992 298993 self shouldntTakeLong: [ t heading: 180 . 298994 self assert: ( t heading = 0.0 ) .] . 298995 298996^true 298997! ! 298998 298999!RenderBugz methodsFor: 'as yet unclassified' stamp: 'wiz 5/15/2008 22:33'! 299000testTestTime 299001"This is a control case. Should always pass. 299002If it does not something external to the tests are slowing things down 299003past the 1 millisecond mark." 299004 299005"self new testTestTime" 299006"self run: #testTestTime" 299007 299008| t | 299009 299010cases := { 299011t := TransformationMorph new openCenteredInWorld } . 299012 299013 self shouldntTakeLong: [ self assert: ( true ) ] . 299014^true 299015! ! 299016AbstractEvent subclass: #ReorganizedEvent 299017 instanceVariableNames: '' 299018 classVariableNames: '' 299019 poolDictionaries: '' 299020 category: 'System-Change Notification'! 299021 299022!ReorganizedEvent methodsFor: 'printing' stamp: 'NS 1/27/2004 12:44'! 299023printEventKindOn: aStream 299024 299025 aStream nextPutAll: 'Reorganized'! ! 299026 299027 299028!ReorganizedEvent methodsFor: 'testing' stamp: 'NS 1/27/2004 12:44'! 299029isReorganized 299030 ^ true! ! 299031 299032"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 299033 299034ReorganizedEvent class 299035 instanceVariableNames: ''! 299036 299037!ReorganizedEvent class methodsFor: 'accessing' stamp: 'NS 1/27/2004 12:46'! 299038changeKind 299039 299040 ^#Reorganized! ! 299041 299042!ReorganizedEvent class methodsFor: 'accessing' stamp: 'NS 1/27/2004 12:46'! 299043supportedKinds 299044 299045 ^Array with: self classKind! ! 299046Notification subclass: #ReparseAfterSourceEditing 299047 instanceVariableNames: '' 299048 classVariableNames: '' 299049 poolDictionaries: '' 299050 category: 'Compiler-Support'! 299051BasicRequestor subclass: #Requestor 299052 instanceVariableNames: '' 299053 classVariableNames: '' 299054 poolDictionaries: '' 299055 category: 'Services-Base-Requestors'! 299056!Requestor commentStamp: 'rr 7/10/2006 15:19' prior: 0! 299057I am an implementation of BasicRequestor with some requests already implemented.! 299058 299059 299060!Requestor methodsFor: 'requests' stamp: 'rr 8/2/2005 14:53'! 299061getClass 299062 ^Smalltalk at: self getSymbol! ! 299063 299064!Requestor methodsFor: 'requests' stamp: 'rr 5/31/2004 22:03'! 299065getClassCollection 299066 ^ self getSymbolCollection collect: [:className | Smalltalk at: className]! ! 299067 299068!Requestor methodsFor: 'requests' stamp: 'alain.plantec 2/6/2009 17:56'! 299069getMethodBody 299070 ^ UIManager default 299071 multiLineRequest: 'Please enter the full body of the method you want to define' translated 299072 centerAt: 0@0 299073 initialAnswer: '' 299074 answerHeight: 300. 299075! ! 299076 299077!Requestor methodsFor: 'requests' stamp: 'alain.plantec 2/6/2009 18:01'! 299078getSelection 299079 "Sorry to feedle with fillInTheBlankMorph innards, but I had to" 299080 | text | 299081 text := (MethodReference class: self getClass selector: self getSelector) sourceCode. 299082 ^ UIManager default 299083 multiLineRequest: 'Clean out the source code and accept' translated 299084 centerAt: 0@0 299085 initialAnswer: text 299086 answerHeight: 300. 299087! ! 299088 299089 299090!Requestor methodsFor: 'services requests' stamp: 'rr 1/9/2006 11:59'! 299091getSelector 299092 ^ self caption: 'enter selector'; getSymbol! ! 299093 299094"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 299095 299096Requestor class 299097 instanceVariableNames: ''! 299098 299099!Requestor class methodsFor: 'as yet unclassified' stamp: 'rr 3/23/2004 14:32'! 299100default 299101 "returns a default requestor" 299102 ^ self new! ! 299103CodeModelExtension subclass: #RequiredSelectors 299104 instanceVariableNames: 'dirty dirtyClasses newlyInterestingClasses' 299105 classVariableNames: '' 299106 poolDictionaries: '' 299107 category: 'Traits-Requires'! 299108 299109!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/18/2006 22:04'! 299110calculateForClass: aClass 299111 | rscc | 299112 self clearOut: aClass. 299113 rscc := RequiredSelectorsChangesCalculator onModificationOf: { aClass } 299114 withTargets: { aClass }. 299115 rscc doWork! ! 299116 299117!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/5/2005 14:21'! 299118for: aClass 299119 "Somewhat weird control flow, and populates the dictionary even with non-interesting things, which it probably shouldn't" 299120 perClassCache at: aClass ifAbsentPut: [RequirementsCache new]. 299121 (self haveInterestsIn: aClass) 299122 ifTrue: [self ensureClean] 299123 ifFalse: [self calculateForClass: aClass]. 299124 ^(perClassCache at: aClass) requirements! ! 299125 299126!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/6/2005 15:40'! 299127lostInterest: client inAll: classes 299128 ProvidedSelectors current 299129 lostInterest: self 299130 inAll: (classes gather: [:cl | cl withAllSuperclasses]). 299131 LocalSends current 299132 lostInterest: self 299133 inAll: (classes gather: [:cl | cl withAllSuperclasses]). 299134 super lostInterest: client inAll: classes 299135! ! 299136 299137!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/14/2005 15:32'! 299138lostOneInterestIn: aClass 299139 self lostInterest: nil in: aClass. 299140! ! 299141 299142!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/6/2005 15:33'! 299143newCacheFor: aClass 299144 ^RequirementsCache new! ! 299145 299146!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/14/2005 17:02'! 299147noteInterestOf: client inAll: classes 299148 | newlyInteresting | 299149 LocalSends current noteInterestOf: self 299150 inAll: (classes gather: [:cl | cl withAllSuperclasses]). 299151 ProvidedSelectors current noteInterestOf: self 299152 inAll: (classes gather: [:cl | cl withAllSuperclasses]). 299153 newlyInteresting := classes copyWithoutAll: self classesOfInterest. 299154 super noteInterestOf: client inAll: classes. 299155 newlyInteresting do: [:cl | self newlyInteresting: cl]! ! 299156 299157!RequiredSelectors methodsFor: 'access to cache' stamp: 'dvf 9/14/2005 16:50'! 299158registerLifelongInterestOf: client inAll: classes 299159 self noteInterestOf: client inAll: classes. 299160 classes do: [:cl | client toFinalizeSend: #lostOneInterestIn: to: self with: cl].! ! 299161 299162 299163!RequiredSelectors methodsFor: 'accessing' stamp: 'dvf 9/2/2005 14:22'! 299164dirtyClasses 299165 dirtyClasses ifNil: [dirtyClasses := WeakSet new]. 299166 ^dirtyClasses! ! 299167 299168!RequiredSelectors methodsFor: 'accessing' stamp: 'dvf 9/8/2005 18:46'! 299169newlyInterestingClasses 299170 newlyInterestingClasses ifNil: [newlyInterestingClasses := IdentitySet new]. 299171 ^newlyInterestingClasses! ! 299172 299173!RequiredSelectors methodsFor: 'accessing' stamp: 'dvf 9/8/2005 18:41'! 299174newlyInterestingClasses: anObject 299175 newlyInterestingClasses := anObject! ! 299176 299177 299178!RequiredSelectors methodsFor: 'as yet unclassified' stamp: 'dvf 9/5/2005 14:21'! 299179classesOfInterest 299180 ^interests asIdentitySet! ! 299181 299182!RequiredSelectors methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 14:22'! 299183dirtyWithChange: anEvent 299184 dirty := true. 299185 self dirtyClasses add: anEvent itemClass! ! 299186 299187!RequiredSelectors methodsFor: 'as yet unclassified' stamp: 'dvf 1/31/2006 23:38'! 299188ensureClean 299189 | rscc | 299190 dirty 299191 ifTrue: 299192 [rscc := RequiredSelectorsChangesCalculator 299193 onModificationOf: self dirtyClasses 299194 withTargets: self classesOfInterest. 299195 rscc doWork. 299196 dirtyClasses := nil]. 299197 dirty := false! ! 299198 299199!RequiredSelectors methodsFor: 'as yet unclassified' stamp: 'dvf 9/8/2005 20:05'! 299200newlyInteresting: aClass 299201 dirty := true. 299202 self dirtyClasses add: aClass! ! 299203 299204 299205!RequiredSelectors methodsFor: 'invalidation' stamp: 'dvf 1/31/2006 23:39'! 299206classChanged: modificationEvent 299207 self dirtyWithChange: modificationEvent! ! 299208 299209"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 299210 299211RequiredSelectors class 299212 instanceVariableNames: ''! 299213Object subclass: #RequiredSelectorsChangesCalculator 299214 instanceVariableNames: 'targetBehaviors classesToUpdate traitsToUpdate rootClasses modifiedBehaviors possiblyAffectedPerRoot originalSinsPerSelector targetClasses targetTraits' 299215 classVariableNames: '' 299216 poolDictionaries: '' 299217 category: 'Traits-Requires'! 299218!RequiredSelectorsChangesCalculator commentStamp: 'dvf 9/22/2005 14:20' prior: 0! 299219Nathanael implemented an efficient algorithm for updating the requirement status of a single selector for an inheritance subtree. However, the algorithm is not efficient enough to use as is for displaying abstractness of all the classes in a few class categories. 299220 299221To get to that performance level: 2992221. The RequiredSelectors class coordinates recalculation requests and tracks what classes have changed, and what classes are interesting. 2992232. The current class handles a such request, by running the algorithm only on classes and selectors that may potentially be requirements.! 299224 299225 299226!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 16:07'! 299227classesToUpdate 299228 ^classesToUpdate! ! 299229 299230!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 16:07'! 299231classesToUpdate: anObject 299232 classesToUpdate := anObject! ! 299233 299234!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 9/1/2005 20:44'! 299235modifiedBehaviors 299236 ^modifiedBehaviors! ! 299237 299238!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 9/1/2005 20:44'! 299239modifiedBehaviors: anObject 299240 modifiedBehaviors := anObject! ! 299241 299242!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 16:07'! 299243rootClasses 299244 ^rootClasses! ! 299245 299246!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 16:07'! 299247rootClasses: anObject 299248 rootClasses := anObject! ! 299249 299250!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 15:58'! 299251targetBehaviors 299252 ^targetBehaviors! ! 299253 299254!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 15:58'! 299255targetBehaviors: anObject 299256 targetBehaviors := anObject! ! 299257 299258!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 16:07'! 299259traitsToUpdate 299260 ^traitsToUpdate! ! 299261 299262!RequiredSelectorsChangesCalculator methodsFor: 'accessing' stamp: 'dvf 8/9/2005 16:07'! 299263traitsToUpdate: anObject 299264 traitsToUpdate := anObject! ! 299265 299266 299267!RequiredSelectorsChangesCalculator methodsFor: 'as yet unclassified' stamp: 'dvf 9/9/2005 19:25'! 299268addUpdatePathTo: aClass from: highRoot 299269 aClass withAllSuperclassesDo: [:sc | classesToUpdate add: sc. highRoot = sc ifTrue: [^self]]! ! 299270 299271!RequiredSelectorsChangesCalculator methodsFor: 'as yet unclassified' stamp: 'dvf 9/9/2005 18:49'! 299272sinsIn: aClass 299273 | negativeDefined selfSent sins | 299274 negativeDefined := IdentitySet new. 299275 aClass selectorsAndMethodsDo: [:s :m | m isProvided ifFalse: [negativeDefined add: s]]. 299276 selfSent := aClass sendCaches selfSenders ifNil: [^negativeDefined] ifNotNilDo: [:dict | dict keys]. 299277 sins := negativeDefined union: (selfSent copyWithoutAll: aClass providedSelectors). 299278 ^sins! ! 299279 299280 299281!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/9/2005 19:23'! 299282decideParameters 299283 "decide whos who" 299284 299285 targetClasses := IdentitySet new. 299286 targetTraits := IdentitySet new. 299287 self targetBehaviors 299288 do: [:b | b isTrait ifTrue: [targetTraits add: b] ifFalse: [targetClasses add: b]]. 299289 self findAffectedTraitsFrom: targetTraits. 299290 self findRootsAndRoutes. 299291 self findOriginalSins! ! 299292 299293!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/12/2005 20:27'! 299294doWork 299295 | requiredSelectorsByClass oldRequiredSelectorsByClass classWithOldRequirementsRecorded rootsHandledBySel rootsHandled | 299296 requiredSelectorsByClass := IdentityDictionary new. 299297 oldRequiredSelectorsByClass := IdentityDictionary new. 299298 classWithOldRequirementsRecorded := IdentitySet new. 299299 rootsHandledBySel := IdentityDictionary new. 299300 originalSinsPerSelector keysAndValuesDo: 299301 [:selector :sinners | 299302 rootsHandled := rootsHandledBySel at: selector put: IdentitySet new. 299303 rootClasses do: 299304 [:rc | 299305 (self shouldProcess: rc forSinsIn: sinners) 299306 ifTrue: 299307 [rootsHandled add: rc. 299308 self 299309 storeOldRequirementsUnder: rc 299310 into: oldRequiredSelectorsByClass 299311 ignoreSet: classWithOldRequirementsRecorded. 299312 self 299313 storeRequirementsUnder: rc 299314 for: selector 299315 in: requiredSelectorsByClass]]]. 299316 self 299317 removeRequirements: oldRequiredSelectorsByClass 299318 thatAreNotIn: requiredSelectorsByClass 299319 ifIn: rootsHandledBySel. 299320 self setFoundRequirements: requiredSelectorsByClass! ! 299321 299322!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'al 2/17/2006 08:54'! 299323findAffectedTraitsFrom: targetTraitsCollection 299324 traitsToUpdate := targetTraitsCollection 299325 select: [:t | modifiedBehaviors anySatisfy: [:mb | t traitCompositionIncludes: mb]]! ! 299326 299327!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/9/2005 20:48'! 299328findOriginalSins 299329 | sinnedSelectors sinners checkedClasses | 299330 checkedClasses := IdentitySet new. 299331 originalSinsPerSelector := IdentityDictionary new. 299332 rootClasses do: 299333 [:rootClass | 299334 rootClass withAllSuperclassesDo: [:superClass | 299335 (checkedClasses includes: superClass) ifFalse: [ 299336 checkedClasses add: superClass. 299337 sinnedSelectors := self sinsIn: superClass. 299338 sinnedSelectors do: 299339 [:sinSel | 299340 sinners := originalSinsPerSelector at: sinSel 299341 ifAbsentPut: [IdentitySet new]. 299342 sinners add: superClass]]]]! ! 299343 299344!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'marcus.denker 11/10/2008 10:04'! 299345findRootsAndRoutes 299346 "Based on the 299347 1. target classes (ones considered interesting by our clients) and the 299348 2. modifiedBehaviors (ones we are told might have changed), 299349 decide the 299350 A. rootClasses (superclasses of target classes that include methods from modifiedBehaviors) 299351 B. classesToUpdate (classes that may have been affected AND are on an inheritance path between a root class and a target class, will be updated by the algorithm. This includes the every target class that may have been affected). 299352 C. mapping from root classes to its classesToUpdate." 299353 299354 | highestSuperclassOfCurrentTarget modifiedClasses | 299355 classesToUpdate := IdentitySet new. 299356 rootClasses := IdentitySet new. 299357 modifiedClasses := (modifiedBehaviors gather: [:mb | mb classesComposedWithMe]) asIdentitySet. 299358 targetClasses do: [:currentTargetClass | 299359 highestSuperclassOfCurrentTarget := nil. 299360 currentTargetClass withAllSuperclassesDo: [:sc | 299361 (modifiedClasses includes: sc) ifTrue: 299362 [highestSuperclassOfCurrentTarget := sc. 299363 self noteRoot: sc possiblyAffected: currentTargetClass]]. 299364 highestSuperclassOfCurrentTarget ifNotNil: [:highestRoot | 299365 self addUpdatePathTo: currentTargetClass from: highestRoot]]! ! 299366 299367!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'alain.plantec 5/28/2009 10:17'! 299368initialize 299369 super initialize. 299370 possiblyAffectedPerRoot := IdentityDictionary new.! ! 299371 299372!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/12/2005 17:46'! 299373noteRoot: rootClass possiblyAffected: targetClass 299374 rootClasses add: rootClass. 299375 targetClass withAllSuperclassesDo: [:sc | 299376 (self possiblyAffectedForRoot: rootClass) add: sc. rootClass = sc ifTrue: [^self]] 299377! ! 299378 299379!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/8/2005 16:12'! 299380possiblyAffectedForRoot: rootClass 299381 ^possiblyAffectedPerRoot at: rootClass ifAbsentPut: [IdentitySet new].! ! 299382 299383!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/12/2005 20:15'! 299384removeRequirements: oldRequiredSelectorsByClass thatAreNotIn: requiredSelectorsByClass 299385 | cache newRequirements | 299386 oldRequiredSelectorsByClass keysAndValuesDo: 299387 [:class :requirements | 299388 newRequirements := requiredSelectorsByClass at: class 299389 ifAbsent: 299390 [#()]. 299391 cache := class requiredSelectorsCache. 299392 requirements 299393 do: [:sel | (newRequirements includes: sel) ifFalse: [cache removeRequirement: sel]]]! ! 299394 299395!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/12/2005 20:37'! 299396removeRequirements: oldRequiredSelectorsByClass thatAreNotIn: requiredSelectorsByClass ifIn: rootsHandledBySel 299397 | cache newRequirements unconfirmedRequirements roots affected | 299398 oldRequiredSelectorsByClass keysAndValuesDo: 299399 [:class :oldRequirements | 299400 newRequirements := requiredSelectorsByClass at: class 299401 ifAbsent: [#()]. 299402 cache := class requiredSelectorsCache. 299403 unconfirmedRequirements := oldRequirements copyWithoutAll: newRequirements. 299404 unconfirmedRequirements do: [:sel | 299405 roots := rootsHandledBySel at: sel ifAbsent: [#()]. 299406 (roots anySatisfy: [:rc | 299407 affected := possiblyAffectedPerRoot at: rc ifAbsent: #(). 299408 (affected includes: class)]) ifTrue: [cache removeRequirement: sel]]]! ! 299409 299410!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/9/2005 18:22'! 299411selectorsToUpdateIn: aClass 299412 ^originalSinsPerSelector keys 299413! ! 299414 299415!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/9/2005 23:25'! 299416setFoundRequirements: requiredSelectorsByClass 299417 | cache | 299418 requiredSelectorsByClass keysAndValuesDo: 299419 [:class :requirements | 299420 cache := class requiredSelectorsCache. 299421 requirements do: [:sel | cache addRequirement: sel]]. 299422 ^cache! ! 299423 299424!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/9/2005 23:36'! 299425shouldProcess: rc forSinsIn: sinners 299426 rc withAllSuperclassesDo: [:rootSuperClass | 299427 (sinners includes: rootSuperClass) ifTrue: [^true]. 299428 "theres a rootClass closer to the sin, we don't need to do it again." 299429 (rc ~= rootSuperClass and: [(rootClasses includes: rootSuperClass)]) ifTrue: [^false]]. 299430 ^false.! ! 299431 299432!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/12/2005 17:35'! 299433storeOldRequirementsUnder: rc into: oldRequiredSelectorsByClass ignoreSet: classWithOldRequirementsRecorded 299434 classesToUpdate do: 299435 [:someClass | 299436 (rc == someClass or: [(someClass inheritsFrom: rc)]) 299437 ifTrue: 299438 [(classWithOldRequirementsRecorded includes: someClass) 299439 ifFalse: 299440 [oldRequiredSelectorsByClass at: someClass put: someClass requirements]]]! ! 299441 299442!RequiredSelectorsChangesCalculator methodsFor: 'calculating' stamp: 'dvf 9/9/2005 23:27'! 299443storeRequirementsUnder: rc for: selector in: requiredSelectorsByClass 299444 | requiringClasses selectorsForClass | 299445 requiringClasses := rc updateRequiredStatusFor: selector 299446 inSubclasses: (self possiblyAffectedForRoot: rc). 299447 ^requiringClasses do: 299448 [:requiringClass | 299449 selectorsForClass := requiredSelectorsByClass at: requiringClass 299450 ifAbsentPut: [IdentitySet new]. 299451 selectorsForClass add: selector]! ! 299452 299453"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 299454 299455RequiredSelectorsChangesCalculator class 299456 instanceVariableNames: ''! 299457 299458!RequiredSelectorsChangesCalculator class methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 20:44'! 299459onModificationOf: behaviors withTargets: targetBehaviors 299460 | i | 299461 i := self new. 299462 i 299463 targetBehaviors: targetBehaviors; 299464 modifiedBehaviors: behaviors; 299465 decideParameters. 299466 ^i! ! 299467Object subclass: #RequirementsCache 299468 instanceVariableNames: 'requirements superRequirements' 299469 classVariableNames: '' 299470 poolDictionaries: '' 299471 category: 'Traits-LocalSends'! 299472 299473!RequirementsCache methodsFor: 'accessing' stamp: 'dvf 9/5/2005 11:37'! 299474newRequirementsObject 299475 ^ IdentitySet new.! ! 299476 299477!RequirementsCache methodsFor: 'accessing' stamp: 'dvf 9/5/2005 11:37'! 299478requirements 299479 ^ requirements isNil 299480 ifTrue: [self newRequirementsObject] 299481 ifFalse: [requirements].! ! 299482 299483!RequirementsCache methodsFor: 'accessing' stamp: 'dvf 9/5/2005 11:37'! 299484superRequirements 299485 "Answer the value of superRequirements" 299486 299487 ^ superRequirements isNil 299488 ifTrue: [IdentitySet new] 299489 ifFalse: [superRequirements].! ! 299490 299491 299492!RequirementsCache methodsFor: 'updates' stamp: 'dvf 9/5/2005 11:34'! 299493addRequirement: selector 299494 requirements ifNil: [requirements := self newRequirementsObject]. 299495 requirements add: selector.! ! 299496 299497!RequirementsCache methodsFor: 'updates' stamp: 'dvf 9/5/2005 11:37'! 299498removeRequirement: selector 299499 requirements ifNil: [^ self]. 299500 requirements remove: selector ifAbsent: [].! ! 299501 299502"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 299503 299504RequirementsCache class 299505 instanceVariableNames: ''! 299506RequiresTestCase subclass: #RequiresOriginalTestCase 299507 instanceVariableNames: '' 299508 classVariableNames: '' 299509 poolDictionaries: '' 299510 category: 'Tests-Traits'! 299511 299512"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 299513 299514RequiresOriginalTestCase class 299515 instanceVariableNames: ''! 299516 299517!RequiresOriginalTestCase class methodsFor: 'as yet unclassified' stamp: 'al 1/13/2006 00:02'! 299518updateRequiredStatusFor: selector in: aClass 299519 aClass updateRequiredStatusFor: selector inSubclasses: self systemNavigation allClassesAndTraits ! ! 299520TimeMeasuringTest subclass: #RequiresSpeedTestCase 299521 instanceVariableNames: 'displayedClasses focusedClasses interestingCategories' 299522 classVariableNames: '' 299523 poolDictionaries: '' 299524 category: 'Tests-Traits'! 299525!RequiresSpeedTestCase commentStamp: 'al 2/17/2006 08:50' prior: 0! 299526This class sets some performance requirements for the requirements algorithm. Subclasses set up and test different caching strategies. 299527 299528Test methods are prefixed with "performance" to exclude them from normal test runs.! 299529 299530 299531!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/8/2005 11:32'! 299532classesInCategories: currentCats 299533 ^currentCats gather: 299534 [:c | 299535 (SystemOrganization listAtCategoryNamed: c) 299536 collect: [:name | Smalltalk at: name]]! ! 299537 299538!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'adrian_lienhard 7/19/2009 18:17'! 299539decideInterestingClasses 299540 interestingCategories := { 299541 'Morphic-Basic'. 299542 'Morphic-Books'. 299543 'Morphic-Demo'. 299544 'System-Compression'. 299545 'System-Compiler' 299546 }. 299547 displayedClasses := self classesInCategories: interestingCategories. 299548 focusedClasses := { 299549 AlignmentMorph. 299550 GZipReadStream. 299551 CommentNode 299552 }! ! 299553 299554!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:46'! 299555performanceTestFileInScenario 299556 self prepareAllCaches. 299557 "decide the interesting sets" 299558 "set them up as such" 299559 "decide the classes and methods to be touched" 299560 self measure: 299561 ["touch the code as decided" 299562 "ask isAbsract of many classes" 299563 "ask requiredSelectors of a few"]. 299564 self assert: realTime < 1000 299565! ! 299566 299567!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:47'! 299568performanceTestFullRequires 299569 self prepareAllCaches. 299570 "note that we do not invalidate any caches" 299571 self measure: [AlignmentMorph requiredSelectors]. 299572 "assuming we want 5 browsers to update their requiredSelectors list in 0.1 second" 299573 self assert: realTime < 20! ! 299574 299575!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:45'! 299576performanceTestMethodChangeScenario 299577 RequiredSelectors doWithTemporaryInstance: [ 299578 LocalSends doWithTemporaryInstance: [ 299579 ProvidedSelectors doWithTemporaryInstance: [ 299580 self prepareAllCaches. 299581 self measure: 299582 [self touchObjectHalt. 299583 displayedClasses do: [:cl | cl hasRequiredSelectors]. 299584 focusedClasses do: [:cl | cl requiredSelectors]]. 299585 self assert: realTime < 200]]]! ! 299586 299587!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:47'! 299588performanceTestMorphMethodChangeScenario 299589 RequiredSelectors doWithTemporaryInstance: 299590 [LocalSends doWithTemporaryInstance: 299591 [ProvidedSelectors doWithTemporaryInstance: 299592 [self prepareAllCaches. 299593 self measure: 299594 [self touchMorphStep. 299595 displayedClasses do: [:cl | cl hasRequiredSelectors]. 299596 focusedClasses do: [:cl | cl requiredSelectors]]. 299597 self assert: realTime < 200]]]! ! 299598 299599!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:47'! 299600performanceTestParseNodeMethodChangeScenario 299601 RequiredSelectors doWithTemporaryInstance: 299602 [LocalSends doWithTemporaryInstance: 299603 [ProvidedSelectors doWithTemporaryInstance: 299604 [self prepareAllCaches. 299605 self measure: 299606 [self touchParseNodeComment. 299607 displayedClasses do: [:cl | cl hasRequiredSelectors]. 299608 focusedClasses do: [:cl | cl requiredSelectors]]. 299609 self assert: realTime < 100]]]! ! 299610 299611!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:47'! 299612performanceTestSwitchToMorphClassCategoryScenario 299613 "When changing in one browser the selected category, we add some interesting classes, remove some others, and calculate some values. So this is a pretty full life cycle test." 299614 | noLongerInteresting newInteresting | 299615 RequiredSelectors doWithTemporaryInstance: 299616 [LocalSends doWithTemporaryInstance: 299617 [ProvidedSelectors doWithTemporaryInstance: 299618 [self prepareAllCaches. 299619 noLongerInteresting := self classesInCategories: {'Morphic-Basic'}. 299620 newInteresting := self classesInCategories: {'Morphic-Kernel'}. 299621 self measure: 299622 [self noteInterestInClasses: newInteresting. 299623 self loseInterestInClasses: noLongerInteresting. 299624 newInteresting do: [:cl | cl hasRequiredSelectors]. 299625 self loseInterestInClasses: newInteresting. 299626 self noteInterestInClasses: noLongerInteresting.]. 299627 self assert: realTime < 500]]]! ! 299628 299629!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 13:01'! 299630prepareAllCaches 299631 self subclassResponsibility.! ! 299632 299633!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 17:55'! 299634setUp 299635 self decideInterestingClasses. 299636! ! 299637 299638!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 18:10'! 299639touchMorphStep 299640 Morph compile: (Morph sourceCodeAt: #step ifAbsent: []) asString! ! 299641 299642!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 15:27'! 299643touchObjectHalt 299644 ^Object compile: (Object sourceCodeAt: #halt ifAbsent: []) asString! ! 299645 299646!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 18:12'! 299647touchParseNodeComment 299648 ParseNode compile: (ParseNode sourceCodeAt: #comment ifAbsent: []) asString! ! 299649 299650!RequiresSpeedTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 14:58'! 299651workingCopyPredicate 299652 ^[:e | {'TraitsOmniBrowser'. 'Traits'} includes: e package name]! ! 299653 299654"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 299655 299656RequiresSpeedTestCase class 299657 instanceVariableNames: ''! 299658 299659!RequiresSpeedTestCase class methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 13:02'! 299660isAbstract 299661 ^self == RequiresSpeedTestCase ! ! 299662TraitsTestCase subclass: #RequiresTestCase 299663 instanceVariableNames: 't7 t8 t9 t10 t11 c9 c10 c11 c12 t13 c13 ta tb tc ca cb cc cd ce cf ch ci cg' 299664 classVariableNames: '' 299665 poolDictionaries: '' 299666 category: 'Tests-Traits'! 299667 299668!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/9/2005 15:09'! 299669for: ba classesComposedWith: aBehavior 299670 ^(ba includes: aBehavior) 299671 or: [(ba gather: [:c | c traitComposition allTraits]) includes: aBehavior]! ! 299672 299673!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 11:58'! 299674loseInterestsFor: behavior 299675 RequiredSelectors current lostInterest: self in: behavior. 299676 LocalSends current lostInterest: self in: behavior. 299677 ^ProvidedSelectors current lostInterest: self 299678 inAll: behavior withAllSuperclasses! ! 299679 299680!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 14:16'! 299681loseInterestsInAll 299682 ^self createdClassesAndTraits 299683 , TraitsResource current createdClassesAndTraits 299684 do: [:e | self loseInterestsFor: e]! ! 299685 299686!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 12:32'! 299687noteInterestsForAll 299688 self createdClassesAndTraits 299689 , TraitsResource current createdClassesAndTraits 299690 do: [:e | self noteInterestsFor: e]! ! 299691 299692!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 11:58'! 299693noteInterestsFor: behavior 299694 RequiredSelectors current noteInterestOf: self in: behavior. 299695 LocalSends current noteInterestOf: self in: behavior. 299696 ProvidedSelectors current noteInterestOf: self 299697 inAll: behavior withAllSuperclasses! ! 299698 299699!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/9/2005 17:27'! 299700requiredMethodsForTrait: aTrait 299701 ^aTrait requiredSelectors! ! 299702 299703!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/9/2005 17:28'! 299704requiredMethodsOfTrait: basicTrait inContextOf: composedTrait 299705 | interestingSelectors sss | 299706 interestingSelectors := (composedTrait traitComposition 299707 transformationOfTrait: basicTrait) allSelectors. 299708 sss := composedTrait selfSentSelectorsFromSelectors: interestingSelectors. 299709 ^sss copyWithoutAll: composedTrait allSelectors! ! 299710 299711!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/8/2005 17:45'! 299712selfSentSelectorsInTrait: aTrait 299713 ^self selfSentSelectorsInTrait: aTrait fromSelectors: aTrait allSelectors 299714! ! 299715 299716!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/9/2005 17:27'! 299717selfSentSelectorsInTrait: composedTrait fromSelectors: interestingSelectors 299718 ^composedTrait selfSentSelectorsFromSelectors: interestingSelectors 299719! ! 299720 299721!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 12:32'! 299722setUp 299723 super setUp. 299724 t7 := self createTraitNamed: #T7 299725 uses: { }. 299726 t7 compile: 'm13 ^self m12' classified: #cat3. 299727 t8 := self createTraitNamed: #T8 299728 uses: { (t7 - { #m13 }) }. 299729 t9 := self createTraitNamed: #T9 299730 uses: { }. 299731 t9 compile: 'm13 ^self m12' classified: #cat3. 299732 t9 compile: 'm12 ^3' classified: #cat3. 299733 t10 := self createTraitNamed: #T10 299734 uses: { (t9 - { #m12 }) }. 299735 299736 t11 := self createTraitNamed: #T11 299737 uses: { (t9 @ { (#m11 -> #m12) } - { #m12 }) }. 299738 299739 c9 := self 299740 createClassNamed: #C9 299741 superclass: ProtoObject 299742 uses: t7. 299743 299744 299745 c10 := self 299746 createClassNamed: #C10 299747 superclass: ProtoObject 299748 uses: t7. 299749 c10 compile: 'm12 ^3'. 299750 299751 c11 := self createClassNamed: #C11 299752 superclass: ProtoObject 299753 uses: {}. 299754 c11 compile: 'm12 ^3'. 299755 c12 := self createClassNamed: #C12 299756 superclass: c11 299757 uses: {t7}. 299758! ! 299759 299760!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/9/2005 16:34'! 299761setUpHierarchy 299762 ta := self createTraitNamed: #TA 299763 uses: { }. 299764 tb := self createTraitNamed: #TB 299765 uses: { }. 299766 tc := self createTraitNamed: #TC uses: tb. 299767 ca := self 299768 createClassNamed: #CA 299769 superclass: ProtoObject 299770 uses: { }. 299771 cb := self 299772 createClassNamed: #CB 299773 superclass: ca 299774 uses: ta + tb. 299775 cc := self 299776 createClassNamed: #CC 299777 superclass: cb 299778 uses: tb. 299779 cd := self 299780 createClassNamed: #CD 299781 superclass: cc 299782 uses: { }. 299783 ce := self 299784 createClassNamed: #CE 299785 superclass: cc 299786 uses: { }. 299787 cf := self 299788 createClassNamed: #CF 299789 superclass: cb 299790 uses: { }. 299791 cg := self 299792 createClassNamed: #CG 299793 superclass: cf 299794 uses: { }. 299795 ch := self 299796 createClassNamed: #CH 299797 superclass: ca 299798 uses: { ta }. 299799 ci := self 299800 createClassNamed: #CI 299801 superclass: ch 299802 uses: { }. 299803 299804 ca compile: 'mca ^self ssca'. 299805 cb compile: 'mca ^3'. 299806 cb compile: 'mcb super mca'. 299807 cc compile: 'mcb ^3'. 299808 cc compile: 'mcb ^self sscc'. 299809! ! 299810 299811!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/12/2005 16:41'! 299812testAffectedClassesAndTraits 299813 | rscc | 299814 self setUpHierarchy. 299815 rscc := RequiredSelectorsChangesCalculator onModificationOf: {tb} withTargets: {ta. cg. ci. cd. tc}. 299816 self assert: rscc rootClasses asSet = (Set withAll: {cc. cb}). 299817 self assert: rscc classesToUpdate asSet = (Set withAll: {cg. cd. cf. cc. cb}). 299818 self assert: rscc traitsToUpdate asSet = (Set withAll: {tc}). 299819 self assert: (#(sscc) copyWithoutAll: (rscc selectorsToUpdateIn: cc)) isEmpty. 299820 self assert: (#(ssca) copyWithoutAll: (rscc selectorsToUpdateIn: cb)) isEmpty.! ! 299821 299822!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/8/2005 16:45'! 299823testExclusionWithAliasing 299824 self assert: ((self requiredMethodsForTrait: t11) = (Set with: #m12)). 299825! ! 299826 299827!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/8/2005 16:34'! 299828testExlcusionInTraits 299829 self assert: ((self requiredMethodsForTrait: t8) = (Set new)). 299830 self assert: ((self requiredMethodsForTrait: t9) = (Set new)). 299831 self assert: ((self requiredMethodsForTrait: t10) = (Set with:#m12)). 299832! ! 299833 299834!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 12:33'! 299835testOneLevelRequires 299836 299837 [self noteInterestsForAll. 299838 self assert: self c3 localSelectors size = 1. 299839 self assert: (self c3 sendCaches selfSendersOf: #bla) = #(#foo ). 299840 self c3 requiredSelectors. 299841 self assert: self c3 requirements = (Set withAll: #(#bla ))] 299842 ensure: [self loseInterestsInAll]! ! 299843 299844!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/9/2005 11:02'! 299845testRequiresOfTraitInContextOfClass 299846 "a class providing nothing, leaves the requirements of the trait intact" 299847 self assert: (self requiredMethodsOfTrait: t7 inContextOf: c9) = (Set with: #m12). 299848 "a class can provide the Trait requirement" 299849 self assert: (self requiredMethodsOfTrait: t7 inContextOf: c10) = (Set new). 299850 "a class' superclass can provide the Trait requirement" 299851 self assert: (self requiredMethodsOfTrait: t7 inContextOf: c12) = (Set new). 299852! ! 299853 299854!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/8/2005 17:55'! 299855testSimpleCompositionContexts 299856 self assert: (self requiredMethodsOfTrait: t7 inContextOf: t8) = (Set new). 299857 self assert: (self requiredMethodsOfTrait: t9 inContextOf: t10) = (Set with: #m12). 299858 self assert: (self requiredMethodsOfTrait: t9 inContextOf: t11) = (Set with: #m12).! ! 299859 299860!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'noha 6/11/2008 18:45'! 299861testSins 299862 | caa cab cac cad | 299863 caa := self 299864 createClassNamed: #CAA 299865 superclass: ProtoObject 299866 uses: { }. 299867 ProtoObject removeSubclass: caa. 299868 caa superclass: nil. 299869 cab := self 299870 createClassNamed: #CAB 299871 superclass: caa 299872 uses: {}. 299873 cac := self 299874 createClassNamed: #CAC 299875 superclass: cab 299876 uses: {}. 299877 cad := self 299878 createClassNamed: #CAD 299879 superclass: cac 299880 uses: { }. 299881 299882 caa compile: 'ma self foo'. 299883 caa compile: 'md self explicitRequirement'. 299884 cac compile: 'mb self bar'. 299885 self noteInterestsFor: cad. 299886 self assert: (cad requiredSelectors = (Set withAll: #(foo bar md))). 299887 cab compile: 'mc ^3'. 299888 self assert: (cad requiredSelectors = (Set withAll: #(foo bar md))). 299889 self loseInterestsFor: cad.! ! 299890 299891!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/8/2005 16:33'! 299892testStandAloneTrait 299893 self assert: ((self requiredMethodsForTrait: t7) = (Set with: #m12)).! ! 299894 299895!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 14:31'! 299896testTwoLevelRequires 299897 [self noteInterestsForAll. 299898 self assert: self c4 localSelectors size = 1. 299899 self assert: self c5 localSelectors size = 1. 299900 self assert: (self c4 sendCaches selfSendersOf: #blew) = #(#foo ). 299901 self assert: (self c5 sendCaches selfSendersOf: #blah) = #(#foo ). 299902 self c4 requiredSelectors. 299903 self assert: self c4 requirements = (Set withAll: #(#blew )). 299904 self assert: self c5 requirements = (Set withAll: #(#blah ))] 299905 ensure: [self loseInterestsInAll ]! ! 299906 299907!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 12:35'! 299908testTwoLevelRequiresWithUnalignedSuperSends 299909 [self noteInterestsForAll. 299910 self updateRequiredStatusFor: #x in: self c6. 299911 self updateRequiredStatusFor: #blah in: self c8. 299912 self assert: self c6 requirements = (Set with: #x). 299913 self assert: self c7 requirements = (Set with: #x). 299914 self assert: self c8 requirements = (Set with: #blah).] 299915 ensure: [self loseInterestsInAll] 299916! ! 299917 299918!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 9/2/2005 12:35'! 299919testTwoLevelRequiresWithUnalignedSuperSendsStartLate 299920 [self noteInterestsForAll. 299921 self updateRequiredStatusFor: #x in: self c8. 299922 self updateRequiredStatusFor: #blah in: self c8. 299923 self assert: self c8 requirements = (Set with: #blah). 299924 self updateRequiredStatusFor: #x in: self c7. 299925 self updateRequiredStatusFor: #blah in: self c7. 299926 self assert: self c7 requirements = (Set with: #x)] 299927 ensure: [self loseInterestsInAll] 299928! ! 299929 299930!RequiresTestCase methodsFor: 'as yet unclassified' stamp: 'dvf 8/8/2005 14:46'! 299931updateRequiredStatusFor: selector in: aClass 299932 self class updateRequiredStatusFor: selector in: aClass 299933! ! 299934 299935"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 299936 299937RequiresTestCase class 299938 instanceVariableNames: ''! 299939 299940!RequiresTestCase class methodsFor: 'as yet unclassified' stamp: 'dvf 9/1/2005 16:47'! 299941isAbstract 299942 ^self == RequiresTestCase! ! 299943Object subclass: #ResourceCollector 299944 instanceVariableNames: 'stubMap originalMap locatorMap localDirectory baseUrl resourceDirectory internalStubs' 299945 classVariableNames: 'Current' 299946 poolDictionaries: '' 299947 category: 'System-Support'! 299948!ResourceCollector commentStamp: '<historical>' prior: 0! 299949The ResourceCollector collects resources that are encountered during project loading or publishing. It merely decouples the places where resources are held from the core object enumeration so that resources can be stored independently from what is enumerated for publishing.! 299950 299951 299952!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:32'! 299953baseUrl 299954 ^baseUrl! ! 299955 299956!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:39'! 299957baseUrl: aString 299958 baseUrl := aString. 299959 baseUrl isEmpty ifFalse:[ 299960 baseUrl last = $/ ifFalse:[baseUrl := baseUrl copyWith: $/]. 299961 ].! ! 299962 299963!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:23'! 299964localDirectory 299965 ^localDirectory! ! 299966 299967!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:24'! 299968localDirectory: aDirectory 299969 localDirectory := aDirectory! ! 299970 299971!ResourceCollector methodsFor: 'accessing' stamp: 'tk 6/28/2001 15:58'! 299972locatorMap 299973 "allow outsiders to store in it. For files that are not resources that do want to live in the resource directory locally and on the server. (.t files for example)" 299974 299975 ^locatorMap! ! 299976 299977!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 22:54'! 299978locators 299979 ^locatorMap values! ! 299980 299981!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:07'! 299982locatorsDo: aBlock 299983 ^locatorMap valuesDo: aBlock! ! 299984 299985!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 17:01'! 299986noteResource: aResourceStub replacing: anObject 299987 "Remember the fact that we need to load aResource which will replace anObject." 299988 stubMap at: aResourceStub put: anObject.! ! 299989 299990!ResourceCollector methodsFor: 'accessing' stamp: 'mir 10/29/2003 13:33'! 299991objectForDataStream: refStream fromForm: aForm 299992 "Return a replacement for aForm to be stored instead" 299993 | stub fName copy loc fullSize nameAndSize | 299994 299995 "First check if the form is one of the intrinsic Squeak forms" 299996 stub := internalStubs at: aForm ifAbsent:[nil]. 299997 stub ifNotNil:[ 299998 refStream replace: aForm with: stub. 299999 ^stub]. 300000 300001 "Now see if we have created the stub already 300002 (this may happen if for instance some form is shared)" 300003 stub := originalMap at: aForm ifAbsent:[nil]. 300004 stub ifNotNil:[^aForm]. 300005 aForm hibernate. 300006 aForm bits class == FormStub ifTrue:[^nil]. "something is wrong" 300007 "too small to be of interest" 300008 "(aForm bits byteSize < 4096) ifTrue:[^aForm]." 300009 "We'll turn off writing out forms until we figure out how to reliably deal with resources" 300010 true ifTrue: [^aForm]. 300011 300012 "Create our stub form" 300013 stub := FormStub 300014 extent: (aForm width min: 32) @ (aForm height min: 32) 300015 depth: (aForm depth min: 8). 300016 aForm displayScaledOn: stub. 300017 aForm hibernate. 300018 300019 "Create a copy of the original form which we use to store those bits" 300020 copy := Form extent: aForm extent depth: aForm depth bits: nil. 300021 copy setResourceBits: aForm bits. 300022 300023 "Get the locator for the form (if we have any)" 300024 loc := locatorMap at: aForm ifAbsent:[nil]. 300025 300026 "Store the resource file" 300027 nameAndSize := self writeResourceForm: copy locator: loc. 300028 fName := nameAndSize first. 300029 fullSize := nameAndSize second. 300030 300031 ProgressNotification signal: '2:resourceFound' extra: stub. 300032 stub hibernate. 300033 "See if we need to assign a new locator" 300034 (loc notNil and:[loc hasRemoteContents not]) ifTrue:[ 300035 "The locator describes some local resource. 300036 If we're preparing to upload the entire project to a 300037 remote server, make it a remote URL instead." 300038 " (baseUrl isEmpty not and:[baseUrl asUrl hasRemoteContents]) 300039 ifTrue:[loc urlString: baseUrl, fName]. 300040 " 300041 baseUrl isEmpty not 300042 ifTrue:[loc urlString: self resourceDirectory , fName]]. 300043 300044 loc ifNil:[ 300045 loc := ResourceLocator new urlString: self resourceDirectory , fName. 300046 locatorMap at: aForm put: loc]. 300047 loc localFileName: (localDirectory fullNameFor: fName). 300048 loc resourceFileSize: fullSize. 300049 stub locator: loc. 300050 300051 "Map old against stub form" 300052 aForm setResourceBits: stub. 300053 originalMap at: aForm put: copy. 300054 stubMap at: stub put: aForm. 300055 locatorMap at: aForm put: loc. 300056 "note: *must* force aForm in out pointers if 300057 in IS or else won't get #comeFullyUpOnReload:" 300058 refStream replace: aForm with: aForm. 300059 ^aForm! ! 300060 300061!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 22:59'! 300062removeLocator: loc 300063 locatorMap keys "copy" do:[:k| 300064 (locatorMap at: k) = loc ifTrue:[locatorMap removeKey: k]].! ! 300065 300066!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:21'! 300067replaceAll 300068 "Replace all resources by their originals. Done after the resource have been collected to get back to the original state." 300069 originalMap keysAndValuesDo:[:k :v| 300070 v ifNotNil:[k replaceByResource: v]. 300071 ].! ! 300072 300073!ResourceCollector methodsFor: 'accessing' stamp: 'mir 6/21/2001 14:51'! 300074resourceDirectory 300075 resourceDirectory ifNil: [resourceDirectory := self baseUrl copyFrom: 1 to: (self baseUrl lastIndexOf: $/)]. 300076 ^resourceDirectory! ! 300077 300078!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:08'! 300079resourceFileNames 300080 "Return a list of all the resource files created" 300081 ^locatorMap values asArray collect:[:loc| loc localFileName].! ! 300082 300083!ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 17:01'! 300084stubMap 300085 ^stubMap! ! 300086 300087 300088!ResourceCollector methodsFor: 'initialize' stamp: 'ar 2/27/2001 23:08'! 300089forgetObsolete 300090 "Forget obsolete locators, e.g., those that haven't been referenced and not been stored on a file." 300091 locatorMap keys "copy" do:[:k| 300092 (locatorMap at: k) localFileName ifNil:[locatorMap removeKey: k]].! ! 300093 300094!ResourceCollector methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 10:17'! 300095initialize 300096 | fd pvt | 300097 super initialize. 300098 originalMap := IdentityDictionary new. 300099 stubMap := IdentityDictionary new. 300100 locatorMap := IdentityDictionary new. 300101 internalStubs := IdentityDictionary new. 300102 fd := ScriptingSystem formDictionary. 300103 pvt := ScriptingSystem privateGraphics asSet. 300104 fd keysAndValuesDo:[:sel :form| 300105 (pvt includes: sel) ifFalse:[ 300106 internalStubs at: form put: 300107 (DiskProxy 300108 global: #ScriptingSystem 300109 selector: #formAtKey:extent:depth: 300110 args: {sel. form extent. form depth})]].! ! 300111 300112!ResourceCollector methodsFor: 'initialize' stamp: 'ar 2/27/2001 22:36'! 300113initializeFrom: aResourceManager 300114 "Initialize the receiver from aResourceManager." 300115 aResourceManager resourceMap keysAndValuesDo:[:loc :res| 300116 (res notNil) 300117 ifTrue:[locatorMap at: res put: loc. 300118 loc localFileName: nil]. 300119 ].! ! 300120 300121 300122!ResourceCollector methodsFor: 'objects from disk' stamp: 'ar 2/24/2001 22:37'! 300123objectForDataStream: refStream 300124 "This should never happen; when projects get written they must be decoupled from the resource collector. If you get the error message below something is seriously broken." 300125 self error:'Cannot write resource manager'! ! 300126 300127 300128!ResourceCollector methodsFor: 'resource writing' stamp: 'yo 11/13/2002 23:30'! 300129writeResourceForm: aForm fromLocator: aLocator 300130 "The given form has been externalized before. If it was reasonably compressed, use the bits of the original data - this allows us to recycle GIF, JPEG, PNG etc. data without using the internal compression (which is in most cases inferior). If necessary the data will be retrieved from its URL location. This retrieval is done only if the resouce comes from either 300131 * the local disk (in which case the file has never been published) 300132 * the browser cache (in which case we don't cache the resource locally) 300133 In any other case we will *not* attempt to retrieve it, because doing so can cause the system to connect to the network which is probably not what we want. It should be a rare case anyways; could only happen if one clears the squeak cache selectively." 300134 | fName fStream url data | 300135 "Try to be smart about the name of the file" 300136 fName := (aLocator urlString includes: $:) 300137 ifTrue: [ 300138 url := aLocator urlString asUrl. 300139 url path last] 300140 ifFalse: [aLocator urlString]. 300141 fName isEmptyOrNil ifFalse:[fName := fName asFileName]. 300142 (fName isEmptyOrNil or:[localDirectory isAFileNamed: fName]) ifTrue:[ 300143 "bad luck -- duplicate name" 300144 fName := localDirectory 300145 nextNameFor:'resource' 300146 extension: (FileDirectory extensionFor: aLocator urlString)]. 300147 "Let's see if we have cached it locally" 300148 ResourceManager 300149 lookupCachedResource: self baseUrl , aLocator urlString 300150 ifPresentDo:[:stream | data := stream upToEnd]. 300151 "Check if the cache entry is without qualifying baseUrl. Workaround for older versions." 300152 data ifNil:[ 300153 ResourceManager 300154 lookupCachedResource: aLocator urlString 300155 ifPresentDo:[:stream | data := stream upToEnd]]. 300156 data ifNil:[ 300157 "We don't have it cached locally. Retrieve it from its original location." 300158 ((url notNil and: [url hasRemoteContents]) and:[HTTPClient isRunningInBrowser not]) 300159 ifTrue:[^nil]. "see note above" 300160 (Url schemeNameForString: aLocator urlString) 300161 ifNil: [^nil]. 300162 data := HTTPLoader default retrieveContentsFor: aLocator urlString. 300163 data ifNil:[^nil]. 300164 data := data content. 300165 ]. 300166 "data size > aForm bits byteSize ifTrue:[^nil]." 300167 fStream := localDirectory newFileNamed: fName. 300168 fStream binary. 300169 fStream nextPutAll: data. 300170 fStream close. 300171 ^{fName. data size}! ! 300172 300173!ResourceCollector methodsFor: 'resource writing' stamp: 'ar 9/23/2002 03:34'! 300174writeResourceForm: aForm locator: aLocator 300175 "Store the given form on a file. Return an array with the name and the size of the file" 300176 | fName fStream fullSize result writerClass | 300177 aLocator ifNotNil:[ 300178 result := self writeResourceForm: aForm fromLocator: aLocator. 300179 result ifNotNil:[^result] 300180 "else fall through" 300181 ]. 300182 fName := localDirectory nextNameFor:'resource' extension:'form'. 300183 fStream := localDirectory newFileNamed: fName. 300184 fStream binary. 300185 aForm storeResourceOn: fStream. 300186false ifTrue:[ 300187 "What follows is a Really, REALLY bad idea. I leave it in as a reminder of what you should NOT do. 300188 PART I: Using JPEG or GIF compression on forms where we don't have the original data means loosing both quality and alpha information if present..." 300189 writerClass := ((Smalltalk includesKey: #JPEGReaderWriter2) 300190 and: [(Smalltalk at: #JPEGReaderWriter2) new isPluginPresent]) 300191 ifTrue: [(Smalltalk at: #JPEGReaderWriter2)] 300192 ifFalse: [GIFReadWriter]. 300193 writerClass putForm: aForm onStream: fStream. 300194 fStream open. 300195 fullSize := fStream size. 300196 fStream close. 300197]. 300198 300199 "Compress contents here" 300200true ifTrue:[ 300201 "...PART II: Using the builtin compression which combines RLE+ZIP is AT LEAST AS GOOD as PNG and how much more would you want???" 300202 fStream position: 0. 300203 fStream compressFile. 300204 localDirectory deleteFileNamed: fName. 300205 localDirectory rename: fName, FileDirectory dot, 'gz' toBe: fName. 300206 fStream := localDirectory readOnlyFileNamed: fName. 300207 fullSize := fStream size. 300208 fStream close. 300209]. 300210 ^{fName. fullSize}! ! 300211 300212"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 300213 300214ResourceCollector class 300215 instanceVariableNames: ''! 300216 300217!ResourceCollector class methodsFor: 'accessing' stamp: 'ar 2/24/2001 21:41'! 300218current 300219 ^Current! ! 300220 300221!ResourceCollector class methodsFor: 'accessing' stamp: 'ar 2/24/2001 21:41'! 300222current: aResourceManager 300223 Current := aResourceManager! ! 300224Object subclass: #ResourceLocator 300225 instanceVariableNames: 'urlString fileSize localFileName' 300226 classVariableNames: '' 300227 poolDictionaries: '' 300228 category: 'System-Support'! 300229!ResourceLocator commentStamp: '<historical>' prior: 0! 300230Describes where a resource can be found. 300231 300232Instance variables: 300233 urlString <String> The URL of the resource 300234 fileSize <Integer> The size of the resource 300235 localFileName <String> When non-nil, the place where this resource was/is stored.! 300236 300237 300238!ResourceLocator methodsFor: 'accessing'! 300239adjustToDownloadUrl: downloadUrl 300240 "Adjust to the fully qualified URL for this resource." 300241 self urlString: (ResourceLocator make: self urlString relativeTo: downloadUrl) unescapePercents! ! 300242 300243!ResourceLocator methodsFor: 'accessing' stamp: 'mir 6/19/2001 16:55'! 300244adjustToRename: newName from: oldName 300245 "Adjust to the fully qualified URL for this resource." 300246 self urlString: (self urlString copyReplaceAll: oldName with: newName)! ! 300247 300248!ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:00'! 300249localFileName 300250 ^localFileName! ! 300251 300252!ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:01'! 300253localFileName: aString 300254 localFileName := aString! ! 300255 300256!ResourceLocator methodsFor: 'accessing' stamp: 'ar 3/2/2001 18:13'! 300257resourceFileSize 300258 ^fileSize! ! 300259 300260!ResourceLocator methodsFor: 'accessing' stamp: 'ar 3/2/2001 18:13'! 300261resourceFileSize: aNumber 300262 fileSize := aNumber! ! 300263 300264!ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 19:57'! 300265urlString 300266 ^urlString! ! 300267 300268!ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 19:57'! 300269urlString: aString 300270 urlString := aString.! ! 300271 300272 300273!ResourceLocator methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:10'! 300274= aLocator 300275 300276 ^ self species == aLocator species and: [self urlString = aLocator urlString] 300277! ! 300278 300279!ResourceLocator methodsFor: 'comparing' stamp: 'ar 2/27/2001 20:02'! 300280hash 300281 ^urlString hash! ! 300282 300283!ResourceLocator methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:10'! 300284species 300285 ^ResourceLocator! ! 300286 300287 300288!ResourceLocator methodsFor: 'printing' stamp: 'ar 2/27/2001 20:02'! 300289printOn: aStream 300290 super printOn: aStream. 300291 aStream nextPut: $(; 300292 print: urlString; 300293 nextPut: $)! ! 300294 300295 300296!ResourceLocator methodsFor: 'testing' stamp: 'ar 2/27/2001 22:11'! 300297hasRemoteContents 300298 "Return true if we describe a resource which is non-local, e.g., on some remote server." 300299 (urlString indexOf: $:) = 0 ifTrue:[^false]. "no scheme" 300300 ^urlString asUrl hasRemoteContents! ! 300301 300302"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 300303 300304ResourceLocator class 300305 instanceVariableNames: ''! 300306 300307!ResourceLocator class methodsFor: 'utilities' stamp: 'fbs 2/2/2005 13:24'! 300308make: newURLString relativeTo: oldURLString 300309 "Local file refs are not handled well, so work around here" 300310 ^((oldURLString includesSubString: '://') not 300311 and: [(newURLString includesSubString: '://') not]) 300312 ifTrue: [oldURLString , (UnixFileDirectory localNameFor: newURLString)] 300313 ifFalse: [(newURLString asUrlRelativeTo: oldURLString asUrl) asString]! ! 300314Object subclass: #ResourceManager 300315 instanceVariableNames: 'resourceMap loaded unloaded stopSemaphore stopFlag loaderProcess' 300316 classVariableNames: 'CachedResources LocalizedExternalResources' 300317 poolDictionaries: '' 300318 category: 'System-Support'! 300319 300320!ResourceManager methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:50'! 300321addResource: anObject locator: aLocator 300322 resourceMap at: aLocator put: anObject. 300323 loaded add: aLocator.! ! 300324 300325!ResourceManager methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:56'! 300326addResource: anObject url: urlString 300327 ^self addResource: anObject locator: (ResourceLocator new urlString: urlString)! ! 300328 300329!ResourceManager methodsFor: 'accessing' stamp: 'mir 6/26/2001 17:33'! 300330adjustToDownloadUrl: downloadUrl 300331 "Adjust the resource manager to the current download location. A project might have been moved manually to a different location or server." 300332 300333 downloadUrl isEmptyOrNil ifTrue: [^self]. 300334 300335 self resourceMap 300336 keysDo:[:locator | locator adjustToDownloadUrl: downloadUrl]. 300337 self resourceMap rehash. 300338 unloaded rehash! ! 300339 300340!ResourceManager methodsFor: 'accessing'! 300341adjustToNewServer: newResourceUrl from: oldResourceUrl 300342 "Adjust the resource manager to the current download location. A project might have been moved manually to a different location or server." 300343 | urlMap oldUrl newUrl | 300344 newResourceUrl isEmptyOrNil ifTrue: [^self]. 300345 urlMap := Dictionary new. 300346 self resourceMap 300347 keysDo: [:locator | 300348 "Local file refs are not handled well, so work around here" 300349 oldUrl := ResourceLocator make: locator urlString relativeTo: oldResourceUrl. 300350 newUrl := ResourceLocator make: locator urlString relativeTo: newResourceUrl. 300351 oldUrl ~= newUrl 300352 ifTrue: [urlMap at: oldUrl asString unescapePercents put: newUrl asString unescapePercents]]. 300353 self resourceMap rehash. 300354 unloaded rehash. 300355 urlMap keysAndValuesDo: [:old :new | 300356 ResourceManager renameCachedResource: old to: new]! ! 300357 300358!ResourceManager methodsFor: 'accessing' stamp: 'mir 6/21/2001 16:02'! 300359adjustToRename: newName from: oldName 300360 "Adjust the resource manager to the current download location. A project might have been moved manually to a different location or server." 300361 | urlMap oldUrl | 300362 newName isEmptyOrNil ifTrue: [^self]. 300363 urlMap := Dictionary new. 300364 self resourceMap 300365 keysDo: [:locator | 300366 oldUrl := locator urlString. 300367 locator adjustToRename: newName from: oldName. 300368 urlMap at: oldUrl put: locator urlString]. 300369 self resourceMap rehash. 300370 unloaded rehash. 300371 urlMap keysAndValuesDo: [:old :new | 300372 ResourceManager renameCachedResource: old to: new]! ! 300373 300374!ResourceManager methodsFor: 'accessing' stamp: 'mir 8/21/2001 17:07'! 300375makeAllProjectResourcesLocalTo: resourceUrl 300376 "Change the urls in the resource locators so project specific resources are stored and referenced locally. Project specific resources are all those that are kept locally in any of the project's versions." 300377 300378 | locators locUrl locBase lastSlash projectBase localResource isExternal | 300379 "Construct the version neutral project base" 300380 resourceUrl isEmptyOrNil ifTrue: [^self]. 300381 projectBase := resourceUrl copyFrom: 1 to: (resourceUrl lastIndexOf: $.) - 1. 300382 locators := OrderedCollection new. 300383 self resourceMap 300384 keysAndValuesDo:[:loc :res | res ifNotNil: [locators add: loc]]. 300385 locators do: [:locator | 300386 locUrl := locator urlString. 300387 locUrl ifNotNil: [ 300388 lastSlash := locUrl lastIndexOf: $/. 300389 lastSlash > 0 300390 ifTrue: [ 300391 locBase := locUrl copyFrom: 1 to: lastSlash - 1. 300392 locBase := locBase copyFrom: 1 to: (((locBase lastIndexOf: $.) - 1) max: 0). 300393 isExternal := projectBase ~= locBase. 300394 (isExternal not 300395 or: [self localizeAllExternalResources]) 300396 ifTrue: [ 300397 localResource := locUrl copyFrom: lastSlash+1 to: locUrl size. 300398 "Update the cache entry to point to the new resource location" 300399 ResourceManager renameCachedResource: locUrl to: (resourceUrl , localResource) external: isExternal. 300400 locator urlString: localResource]]]]. 300401 self resourceMap rehash 300402! ! 300403 300404!ResourceManager methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:57'! 300405resourceMap 300406 ^resourceMap! ! 300407 300408 300409!ResourceManager methodsFor: 'backward-compatibility' stamp: 'nk 7/30/2004 21:46'! 300410convertMapNameForBackwardcompatibilityFrom: aString 300411 (SmalltalkImage current platformName = 'Mac OS' 300412 and: ['10*' match: SmalltalkImage current osVersion]) 300413 ifTrue: [^aString convertFromWithConverter: ShiftJISTextConverter new]. 300414 ^aString convertFromSystemString! ! 300415 300416 300417!ResourceManager methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 10:17'! 300418initialize 300419 "So resources may get garbage collected if possible" 300420 super initialize. 300421 self reset.! ! 300422 300423!ResourceManager methodsFor: 'initialize' stamp: 'mir 6/18/2001 22:49'! 300424initializeFrom: aCollector 300425 "Initialize the receiver from the given resource collector. None of the resources have been loaded yet, so make register all resources as unloaded." 300426 | newLoc | 300427 aCollector stubMap keysAndValuesDo:[:stub :res| 300428 newLoc := stub locator. 300429 resourceMap at: newLoc put: res. 300430 "unloaded add: newLoc." 300431 ].! ! 300432 300433!ResourceManager methodsFor: 'initialize' stamp: 'ar 2/27/2001 16:54'! 300434reset 300435 "Clean out everything" 300436 resourceMap := WeakValueDictionary new. 300437 loaded := Set new. 300438 unloaded := Set new.! ! 300439 300440 300441!ResourceManager methodsFor: 'loading' stamp: 'ar 5/30/2001 23:11'! 300442installResource: aResource from: aStream locator: loc 300443 | repl | 300444 aResource ifNil:[^false]. "it went away, so somebody might have deleted it" 300445 (aStream == nil or:[aStream size = 0]) ifTrue:[^false]. "error?!!" 300446 repl := aResource clone readResourceFrom: aStream asUnZippedStream. 300447 repl ifNotNil:[ 300448 aResource replaceByResource: repl. 300449 unloaded remove: loc. 300450 loaded add: loc. 300451 ^true 300452 ]. 300453 ^false! ! 300454 300455!ResourceManager methodsFor: 'loading' stamp: 'nk 4/17/2004 19:50'! 300456loadCachedResources 300457 "Load all the resources that we have cached locally" 300458 | resource | 300459 self class reloadCachedResources. 300460 self prioritizedUnloadedResources do:[:loc| 300461 self class lookupCachedResource: loc urlString ifPresentDo:[:stream| 300462 resource := resourceMap at: loc ifAbsent:[nil]. 300463 self installResource: resource 300464 from: stream 300465 locator: loc. 300466 (resource isForm) ifTrue:[ 300467 self formChangedReminder value. 300468 World displayWorldSafely]. 300469 ]. 300470 ].! ! 300471 300472!ResourceManager methodsFor: 'loading' stamp: 'nk 4/17/2004 19:50'! 300473loaderProcess 300474 | loader requests req locator resource stream | 300475 loader := HTTPLoader default. 300476 requests := Dictionary new. 300477 self prioritizedUnloadedResources do:[:loc| 300478 req := HTTPLoader httpRequestClass for: (self hackURL: loc urlString) in: loader. 300479 loader addRequest: req. 300480 requests at: req put: loc]. 300481 [stopFlag or:[requests isEmpty]] whileFalse:[ 300482 stopSemaphore waitTimeoutMSecs: 500. 300483 requests keys "need a copy" do:[:r| 300484 r isSemaphoreSignaled ifTrue:[ 300485 locator := requests at: r. 300486 requests removeKey: r. 300487 stream := r contentStream. 300488 resource := resourceMap at: locator ifAbsent:[nil]. 300489 self class cacheResource: locator urlString stream: stream. 300490 self installResource: resource 300491 from: stream 300492 locator: locator. 300493 (resource isForm) ifTrue:[ 300494 WorldState addDeferredUIMessage: self formChangedReminder] 300495ifFalse: [self halt]. 300496 ]. 300497 ]. 300498 ]. 300499 "Either done downloading or terminating process" 300500 stopFlag ifTrue:[loader abort]. 300501 loaderProcess := nil. 300502 stopSemaphore := nil.! ! 300503 300504!ResourceManager methodsFor: 'loading' stamp: 'tetha 3/6/2004 15:46'! 300505preLoadFromArchive: aZipArchive cacheName: aFileName 300506 "Load the resources from the given zip archive" 300507 | orig nameMap resMap loc stream | 300508 self class reloadCachedResources. 300509 resMap := Dictionary new. 300510 nameMap := Dictionary new. 300511 unloaded do:[:locator| 300512 locator localFileName: nil. 300513 nameMap at: locator urlString put: locator. 300514 resMap at: locator urlString put: (resourceMap at: locator)]. 300515 300516 aZipArchive members do:[:entry| 300517 stream := nil. 300518 orig := resMap at: (self convertMapNameForBackwardcompatibilityFrom: entry fileName ) ifAbsent:[nil]. 300519 loc := nameMap at: (self convertMapNameForBackwardcompatibilityFrom: entry fileName ) ifAbsent:[nil]. 300520 "note: orig and loc may be nil for non-resource members" 300521 (orig notNil and:[loc notNil]) ifTrue:[ 300522 stream := entry contentStream. 300523 self installResource: orig from: stream locator: loc. 300524 stream reset. 300525 aFileName 300526 ifNil:[self class cacheResource: loc urlString stream: stream] 300527 ifNotNil:[self class cacheResource: loc urlString inArchive: aFileName]]. 300528 ].! ! 300529 300530!ResourceManager methodsFor: 'loading' stamp: 'ar 3/2/2001 18:16'! 300531prioritizedUnloadedResources 300532 "Return an array of unloaded resource locators prioritized by some means" 300533 | list | 300534 list := unloaded asArray. 300535 ^list sort:[:l1 :l2| 300536 (l1 resourceFileSize ifNil:[SmallInteger maxVal]) <= 300537 (l2 resourceFileSize ifNil:[SmallInteger maxVal])]! ! 300538 300539!ResourceManager methodsFor: 'loading' stamp: 'mir 6/18/2001 22:49'! 300540registerUnloadedResources 300541 resourceMap keys do: [:newLoc | 300542 unloaded add: newLoc] 300543! ! 300544 300545!ResourceManager methodsFor: 'loading' stamp: 'ar 3/3/2001 18:01'! 300546startDownload 300547 "Start downloading unloaded resources" 300548 self stopDownload. 300549 unloaded isEmpty ifTrue:[^self]. 300550 self loadCachedResources. 300551 unloaded isEmpty ifTrue:[^self]. 300552 stopFlag := false. 300553 stopSemaphore := Semaphore new. 300554 loaderProcess := [self loaderProcess] newProcess. 300555 loaderProcess priority: Processor lowIOPriority. 300556 loaderProcess resume.! ! 300557 300558!ResourceManager methodsFor: 'loading' stamp: 'ar 3/2/2001 17:09'! 300559stopDownload 300560 "Stop downloading unloaded resources" 300561 loaderProcess ifNil:[^self]. 300562 stopFlag := true. 300563 stopSemaphore signal. 300564 [loaderProcess == nil] whileFalse:[(Delay forMilliseconds: 10) wait]. 300565 stopSemaphore := nil.! ! 300566 300567!ResourceManager methodsFor: 'loading' stamp: 'ar 2/27/2001 21:42'! 300568updateResourcesFrom: aCollector 300569 "We just assembled all the resources in a project. 300570 Include all that were newly found" 300571 self reset. "start clean" 300572 aCollector stubMap keysAndValuesDo:[:stub :res| 300573 "update all entries" 300574 resourceMap at: stub locator put: res. 300575 loaded add: stub locator. 300576 ].! ! 300577 300578 300579!ResourceManager methodsFor: 'private' stamp: 'ar 3/2/2001 19:25'! 300580abandonResourcesThat: matchBlock 300581 "Private. Forget resources that match the given argument block" 300582 resourceMap keys "need copy" do:[:loc| 300583 (matchBlock value: loc) ifTrue:[ 300584 resourceMap removeKey: loc ifAbsent:[]. 300585 loaded remove: loc ifAbsent:[]. 300586 unloaded remove: loc ifAbsent:[]. 300587 ]. 300588 ].! ! 300589 300590!ResourceManager methodsFor: 'private' stamp: 'yo 1/12/2004 22:54'! 300591fixJISX0208Resource 300592 300593 | keys value url | 300594 keys := resourceMap keys. 300595 300596 keys do: [:key | 300597 value := resourceMap at: key. 300598 url := key urlString copy. 300599 url isOctetString not ifTrue: [url mutateJISX0208StringToUnicode]. 300600 resourceMap removeKey: key. 300601 key urlString: url. 300602 resourceMap at: key put: value. 300603 ]. 300604! ! 300605 300606!ResourceManager methodsFor: 'private' stamp: 'ar 3/3/2001 15:30'! 300607formChangedReminder 300608 ^[World newResourceLoaded].! ! 300609 300610!ResourceManager methodsFor: 'private' stamp: 'ar 3/2/2001 17:22'! 300611hackURL: urlString 300612 (urlString findString: '/SuperSwikiProj/') > 0 300613 ifTrue:[^urlString copyReplaceAll: '/SuperSwikiProj/' with: '/uploads/'] 300614 ifFalse:[^urlString]! ! 300615 300616!ResourceManager methodsFor: 'private' stamp: 'mir 8/20/2001 17:12'! 300617localizeAllExternalResources 300618 "Should be a preference later." 300619 ^true! ! 300620 300621"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 300622 300623ResourceManager class 300624 instanceVariableNames: ''! 300625 300626!ResourceManager class methodsFor: 'resource caching' stamp: 'ar 5/30/2001 23:21'! 300627cacheResource: urlString inArchive: archiveName 300628 "Remember the given url as residing in the given archive" 300629 | fd file fullName | 300630 fullName := 'zip://', archiveName. 300631 ((self resourceCache at: urlString ifAbsent:[#()]) 300632 anySatisfy:[:cache| cache = fullName]) ifTrue:[^self]. "don't cache twice" 300633 fd := Project squeakletDirectory. 300634 "update cache" 300635 file := [fd oldFileNamed: self resourceCacheName] 300636 on: FileDoesNotExistException 300637 do:[:ex| fd forceNewFileNamed: self resourceCacheName]. 300638 file setToEnd. 300639 file nextPutAll: urlString; cr. 300640 file nextPutAll: fullName; cr. 300641 file close. 300642 self addCacheLocation: fullName for: urlString.! ! 300643 300644!ResourceManager class methodsFor: 'resource caching' stamp: 'yo 12/20/2003 02:12'! 300645cacheResource: urlString stream: aStream 300646 | fd localName file buf | 300647 HTTPClient shouldUsePluginAPI ifTrue:[^self]. "use browser cache" 300648 (self resourceCache at: urlString ifAbsent:[#()]) size > 0 300649 ifTrue:[^self]. "don't waste space" 300650 fd := Project squeakletDirectory. 300651 localName := fd nextNameFor: 'resource' extension:'cache'. 300652 file := fd forceNewFileNamed: localName. 300653 buf := ByteArray new: 10000. 300654 aStream binary. 300655 file binary. 300656 [aStream atEnd] whileFalse:[ 300657 buf := aStream next: buf size into: buf. 300658 file nextPutAll: buf. 300659 ]. 300660 file close. 300661 "update cache" 300662 file := [fd oldFileNamed: self resourceCacheName] 300663 on: FileDoesNotExistException 300664 do:[:ex| fd forceNewFileNamed: self resourceCacheName]. 300665 file setToEnd. 300666 file nextPutAll: urlString; cr. 300667 file nextPutAll: localName; cr. 300668 file close. 300669 self addCacheLocation: localName for: urlString. 300670 aStream position: 0. 300671! ! 300672 300673!ResourceManager class methodsFor: 'resource caching' stamp: 'AlexandreBergel 7/30/2008 13:40'! 300674lookupCachedResource: cachedUrlString ifPresentDo: streamBlock 300675 "See if we have cached the resource described by the given url and if so, evaluate streamBlock with the cached resource." 300676 | urlString candidates url stream | 300677 CachedResources ifNil:[^self]. 300678 300679 candidates := CachedResources at: cachedUrlString ifAbsent:[nil]. 300680 (self lookupCachedResource: cachedUrlString in: candidates ifPresentDo: streamBlock) 300681 ifTrue: [^self]. 300682 300683 urlString := self relocatedExternalResource: cachedUrlString. 300684 urlString ifNil: [^self]. 300685 candidates := CachedResources at: urlString ifAbsent:[nil]. 300686 candidates 300687 ifNil: [ 300688 (url := urlString asUrl) schemeName = 'file' 300689 ifTrue: [ 300690 stream := [FileStream readOnlyFileNamed: url pathForFile] 300691 on: FileDoesNotExistException do:[:ex| ex return: nil]. 300692 stream 300693 ifNotNil: [[streamBlock value: stream] ensure: [stream close]]]] 300694 ifNotNil: [self lookupCachedResource: urlString in: candidates ifPresentDo: streamBlock]! ! 300695 300696!ResourceManager class methodsFor: 'resource caching' stamp: 'mir 8/21/2001 18:31'! 300697lookupCachedResource: urlString in: candidates ifPresentDo: streamBlock 300698 "See if we have cached the resource described by the given url and if so, evaluate streamBlock with the cached resource." 300699 | sortedCandidates dir file | 300700 (candidates isNil or:[candidates size = 0]) 300701 ifTrue:[^false]. 300702 "First, try non-zip members (faster since no decompression is involved)" 300703 sortedCandidates := (candidates reject:[:each| each beginsWith: 'zip://']), 300704 (candidates select:[:each| each beginsWith: 'zip://']). 300705 dir := Project squeakletDirectory. 300706 sortedCandidates do:[:fileName| 300707 file := self loadResource: urlString fromCacheFileNamed: fileName in: dir. 300708 file ifNotNil:[ 300709 [streamBlock value: file] ensure:[file close]. 300710 ^true]]. 300711 ^false! ! 300712 300713!ResourceManager class methodsFor: 'resource caching' stamp: 'mir 6/21/2001 22:49'! 300714lookupOriginalResourceCacheEntry: resourceFileName for: resourceUrl 300715 "See if we have cached the resource described by the given url in an earlier version of the same project on the same server. In that case we don't need to upload it again but rather link to it." 300716 | candidates resourceBase resourceMatch matchingUrls | 300717 300718 CachedResources ifNil:[^nil]. 300719 300720 "Strip the version number from the resource url" 300721 resourceBase := resourceUrl copyFrom: 1 to: (resourceUrl lastIndexOf: $.) . 300722 "Now collect all urls that have the same resource base" 300723 resourceMatch := resourceBase , '*/' , resourceFileName. 300724 matchingUrls := self resourceCache keys 300725 select: [:entry | (resourceMatch match: entry) and: [(entry beginsWith: resourceUrl) not]]. 300726 matchingUrls isEmpty 300727 ifTrue: [^nil]. 300728 matchingUrls asSortedCollection do: [:entry | 300729 candidates := (self resourceCache at: entry). 300730 candidates isEmptyOrNil 300731 ifFalse: [candidates do: [:candidate | 300732 candidate = resourceFileName 300733 ifTrue: [^entry]]]]. 300734 ^nil! ! 300735 300736!ResourceManager class methodsFor: 'resource caching' stamp: 'dc 5/30/2008 10:17'! 300737reloadCachedResources 300738 "ResourceManager reloadCachedResources" 300739 "Reload cached resources from the disk" 300740 | fd files stream url localName storeBack archiveName | 300741 CachedResources := Dictionary new. 300742 LocalizedExternalResources := nil. 300743 fd := Project squeakletDirectory. 300744 files := fd fileNames asSet. 300745 stream := [ fd readOnlyFileNamed: self resourceCacheName ] 300746 on: FileDoesNotExistException 300747 do: [ :ex | fd forceNewFileNamed: self resourceCacheName ]. 300748 stream size < 50000 ifTrue: [ stream := stream contentsOfEntireFile readStream ]. 300749 storeBack := false. 300750 [ stream atEnd ] whileFalse: 300751 [ url := stream upTo: Character cr. 300752 localName := stream upTo: Character cr. 300753 (localName beginsWith: 'zip://') 300754 ifTrue: 300755 [ archiveName := localName 300756 copyFrom: 7 300757 to: localName size. 300758 (files includes: archiveName) 300759 ifTrue: 300760 [ self 300761 addCacheLocation: localName 300762 for: url ] 300763 ifFalse: [ storeBack := true ] ] 300764 ifFalse: 300765 [ (files includes: localName) 300766 ifTrue: 300767 [ self 300768 addCacheLocation: localName 300769 for: url ] 300770 ifFalse: [ storeBack := true ] ] ]. 300771 stream close. 300772 storeBack ifTrue: 300773 [ stream := fd forceNewFileNamed: self resourceCacheName. 300774 CachedResources keysAndValuesDo: 300775 [ :urlString :cacheLocs | 300776 cacheLocs do: 300777 [ :cacheLoc | 300778 stream 300779 nextPutAll: urlString; 300780 cr. 300781 stream 300782 nextPutAll: cacheLoc; 300783 cr ] ]. 300784 stream close ]! ! 300785 300786!ResourceManager class methodsFor: 'resource caching' stamp: 'mir 8/21/2001 17:24'! 300787renameCachedResource: urlString to: newUrlString 300788 "A project was renamed. Reflect this change by duplicating the cache entry to the new url." 300789 self renameCachedResource: urlString to: newUrlString external: true! ! 300790 300791!ResourceManager class methodsFor: 'resource caching' stamp: 'mir 12/3/2001 13:14'! 300792renameCachedResource: urlString to: newUrlString external: isExternal 300793 "A project was renamed. Reflect this change by duplicating the cache entry to the new url." 300794 | candidates | 300795 CachedResources 300796 ifNil:[ 300797 isExternal 300798 ifTrue: [self resourceCache "force init" ] 300799 ifFalse: [^self]]. 300800 candidates := CachedResources at: urlString ifAbsent:[nil]. 300801 (candidates isNil or:[candidates size = 0]) 300802 ifFalse: [ 300803 candidates do: [:candidate | 300804 self addCacheLocation: candidate for: newUrlString]]. 300805 isExternal 300806 ifTrue: [self relocatedExternalResource: urlString to: newUrlString]! ! 300807 300808!ResourceManager class methodsFor: 'resource caching' stamp: 'ar 8/23/2001 17:52'! 300809resourceCache 300810 ^CachedResources ifNil:[ 300811 CachedResources := Dictionary new. 300812 self reloadCachedResources. 300813 CachedResources].! ! 300814 300815!ResourceManager class methodsFor: 'resource caching' stamp: 'ar 3/3/2001 17:27'! 300816resourceCacheName 300817 ^'resourceCache.map'! ! 300818 300819 300820!ResourceManager class methodsFor: 'private-resources' stamp: 'mir 11/29/2001 16:19'! 300821addCacheLocation: aString for: urlString 300822 | locations | 300823 locations := CachedResources at: urlString ifAbsentPut: [#()]. 300824 (locations includes: aString) 300825 ifFalse: [CachedResources at: urlString put: ({aString} , locations)]! ! 300826 300827!ResourceManager class methodsFor: 'private-resources' stamp: 'AlexandreBergel 7/30/2008 13:39'! 300828loadResource: urlString fromCacheFileNamed: fileName in: dir 300829 | archiveName file archive | 300830 (fileName beginsWith: 'zip://') ifTrue:[ 300831 archiveName := fileName copyFrom: 7 to: fileName size. 300832 archive := [dir readOnlyFileNamed: archiveName] 300833 on: FileDoesNotExistException 300834 do:[:ex| ^ nil]. 300835 archive isZipArchive ifTrue:[ 300836 archive := ZipArchive new readFrom: archive. 300837 file := archive members detect: [:any| any fileName = urlString] ifNone: [nil]]. 300838 file ifNotNil:[file := file contentStream]. 300839 archive close. 300840 ] ifFalse:[ 300841 file := [dir readOnlyFileNamed: fileName] 300842 on: FileDoesNotExistException 300843 do:[:ex| ^ nil]. 300844 ]. 300845 ^file! ! 300846 300847!ResourceManager class methodsFor: 'private-resources' stamp: 'mir 8/21/2001 15:50'! 300848localizedExternalResources 300849 ^LocalizedExternalResources ifNil:[LocalizedExternalResources := Dictionary new]! ! 300850 300851!ResourceManager class methodsFor: 'private-resources' stamp: 'mir 8/21/2001 16:06'! 300852relocatedExternalResource: urlString 300853 ^self localizedExternalResources at: urlString ifAbsent: [nil]! ! 300854 300855!ResourceManager class methodsFor: 'private-resources' stamp: 'mir 8/21/2001 16:00'! 300856relocatedExternalResource: urlString to: newUrlString 300857 | originalURL | 300858 originalURL := (self localizedExternalResources includesKey: urlString) 300859 ifTrue: [self localizedExternalResources at: urlString] 300860 ifFalse: [urlString]. 300861 self localizedExternalResources at: newUrlString put: originalURL! ! 300862TestFailure subclass: #ResumableTestFailure 300863 instanceVariableNames: '' 300864 classVariableNames: '' 300865 poolDictionaries: '' 300866 category: 'SUnit-Kernel'! 300867!ResumableTestFailure commentStamp: '<historical>' prior: 0! 300868A ResumableTestFailure triggers a TestFailure, but lets execution of the TestCase continue. this is useful when iterating through collections, and #assert: ing on each element. in combination with methods like testcase>>#assert:description:, this lets you run through a whole collection and note which tests pass. 300869 300870here''s an example: 300871 300872 300873 300874 (1 to: 30) do: [ :each | 300875 self assert: each odd description: each printString, ' is even' resumable: true] 300876 300877for each element where #odd returns <false>, the element will be printed to the Transcript. ! 300878 300879 300880!ResumableTestFailure methodsFor: 'camp smalltalk'! 300881isResumable 300882 "Of course a ResumableTestFailure is resumable ;-)" 300883 300884 ^true! ! 300885 300886!ResumableTestFailure methodsFor: 'camp smalltalk'! 300887sunitExitWith: aValue 300888 self resume: aValue! ! 300889TestCase subclass: #ResumableTestFailureTestCase 300890 instanceVariableNames: '' 300891 classVariableNames: '' 300892 poolDictionaries: '' 300893 category: 'SUnit-Tests'! 300894 300895!ResumableTestFailureTestCase methodsFor: 'not categorized'! 300896errorTest 300897 1 zork 300898 ! ! 300899 300900!ResumableTestFailureTestCase methodsFor: 'not categorized'! 300901failureTest 300902 self 300903 assert: false description: 'You should see me' resumable: true; 300904 assert: false description: 'You should see me too' resumable: true; 300905 assert: false description: 'You should see me last' resumable: false; 300906 assert: false description: 'You should not see me' resumable: true 300907 ! ! 300908 300909!ResumableTestFailureTestCase methodsFor: 'not categorized'! 300910okTest 300911 self assert: true 300912 ! ! 300913 300914!ResumableTestFailureTestCase methodsFor: 'not categorized'! 300915regularTestFailureTest 300916 self assert: false description: 'You should see me' 300917 ! ! 300918 300919!ResumableTestFailureTestCase methodsFor: 'not categorized'! 300920resumableTestFailureTest 300921 self 300922 assert: false description: 'You should see me' resumable: true; 300923 assert: false description: 'You should see me too' resumable: true; 300924 assert: false description: 'You should see me last' resumable: false; 300925 assert: false description: 'You should not see me' resumable: true 300926 ! ! 300927 300928!ResumableTestFailureTestCase methodsFor: 'not categorized'! 300929testResumable 300930 | result suite | 300931 suite := TestSuite new. 300932 suite addTest: (self class selector: #errorTest). 300933 suite addTest: (self class selector: #regularTestFailureTest). 300934 suite addTest: (self class selector: #resumableTestFailureTest). 300935 suite addTest: (self class selector: #okTest). 300936 result := suite run. 300937 self assert: result failures size = 2; 300938 assert: result errors size = 1 300939 ! ! 300940 300941"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 300942 300943ResumableTestFailureTestCase class 300944 instanceVariableNames: ''! 300945 300946!ResumableTestFailureTestCase class methodsFor: 'history' stamp: 'simon.denier 11/22/2008 22:13'! 300947lastStoredRun 300948 ^ ((Dictionary new) add: (#passed->((Set new) add: #testResumable; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ! 300949ParseNode subclass: #ReturnNode 300950 instanceVariableNames: 'expr' 300951 classVariableNames: '' 300952 poolDictionaries: '' 300953 category: 'Compiler-ParseNodes'! 300954!ReturnNode commentStamp: '<historical>' prior: 0! 300955I represent an expression of the form ^expr.! 300956 300957 300958!ReturnNode methodsFor: 'code generation'! 300959code 300960 300961 ^expr code! ! 300962 300963!ReturnNode methodsFor: 'code generation'! 300964emitForReturn: stack on: strm 300965 300966 expr emitForReturn: stack on: strm. 300967 pc := strm position! ! 300968 300969!ReturnNode methodsFor: 'code generation'! 300970emitForValue: stack on: strm 300971 300972 expr emitForReturn: stack on: strm. 300973 pc := strm position! ! 300974 300975!ReturnNode methodsFor: 'code generation'! 300976sizeForReturn: encoder 300977 300978 ^expr sizeForReturn: encoder! ! 300979 300980!ReturnNode methodsFor: 'code generation'! 300981sizeForValue: encoder 300982 300983 ^expr sizeForReturn: encoder! ! 300984 300985 300986!ReturnNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2009 09:44'! 300987analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>" 300988 "Note we could do this: 300989 scopeBlock ~~ rootNode block ifTrue: 300990 [scopeBlock noteNonLocalReturn]. 300991 and pass up the flag in <BlockNode>>>analyseTempsWithin:rootNode: 300992 which may be fast but will also give less information the debugger. 300993 For now we consider clean blocks a premature optimization." 300994 self flag: 'consider clean blocks'. 300995 expr analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools! ! 300996 300997 300998!ReturnNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:40'! 300999emitCodeForReturn: stack encoder: encoder 301000 301001 expr emitCodeForReturn: stack encoder: encoder. 301002 pc := encoder methodStreamPosition! ! 301003 301004!ReturnNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:40'! 301005emitCodeForValue: stack encoder: encoder 301006 301007 expr emitCodeForReturn: stack encoder: encoder. 301008 pc := encoder methodStreamPosition! ! 301009 301010!ReturnNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 301011sizeCodeForReturn: encoder 301012 301013 ^expr sizeCodeForReturn: encoder! ! 301014 301015!ReturnNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 301016sizeCodeForValue: encoder 301017 301018 ^expr sizeCodeForReturn: encoder! ! 301019 301020 301021!ReturnNode methodsFor: 'converting'! 301022asReturnNode! ! 301023 301024 301025!ReturnNode methodsFor: 'initialize-release'! 301026expr: e 301027 301028 expr := e! ! 301029 301030!ReturnNode methodsFor: 'initialize-release'! 301031expr: e encoder: encoder sourceRange: range 301032 301033 expr := e. 301034 encoder noteSourceRange: range forNode: self! ! 301035 301036 301037!ReturnNode methodsFor: 'printing' stamp: 'yo 8/2/2004 17:21'! 301038expr 301039 301040 ^ expr. 301041! ! 301042 301043!ReturnNode methodsFor: 'printing' stamp: 'eem 5/6/2008 14:18'! 301044printOn: aStream indent: level 301045 301046 aStream nextPutAll: '^ '. "make this a preference??" 301047 expr printOn: aStream indent: level. 301048 expr printCommentOn: aStream indent: level! ! 301049 301050!ReturnNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:49'! 301051printWithClosureAnalysisOn: aStream indent: level 301052 301053 aStream nextPutAll: '^ '. "make this a preference??" 301054 expr printWithClosureAnalysisOn: aStream indent: level. 301055 expr printCommentOn: aStream indent: level! ! 301056 301057 301058!ReturnNode methodsFor: 'testing'! 301059isReturnSelf 301060 301061 ^expr == NodeSelf! ! 301062 301063!ReturnNode methodsFor: 'testing'! 301064isSpecialConstant 301065 301066 ^expr isSpecialConstant! ! 301067 301068!ReturnNode methodsFor: 'testing'! 301069isVariableReference 301070 301071 ^expr isVariableReference! ! 301072 301073 301074!ReturnNode methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:53'! 301075accept: aVisitor 301076 aVisitor visitReturnNode: self! ! 301077OSPlatform subclass: #RiscOSPlatform 301078 instanceVariableNames: '' 301079 classVariableNames: '' 301080 poolDictionaries: '' 301081 category: 'System-Platforms'! 301082 301083!RiscOSPlatform methodsFor: 'accessing' stamp: 'michael.rueger 2/25/2009 18:18'! 301084platformFamily 301085 ^#RiscOS! ! 301086 301087"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 301088 301089RiscOSPlatform class 301090 instanceVariableNames: ''! 301091 301092!RiscOSPlatform class methodsFor: 'private' stamp: 'michael.rueger 2/25/2009 18:22'! 301093isActivePlatform 301094 ^SmalltalkImage current platformName = 'RiscOS'! ! 301095SimpleButtonMorph subclass: #RolloverButtonMorph 301096 instanceVariableNames: '' 301097 classVariableNames: '' 301098 poolDictionaries: '' 301099 category: 'Morphic-Widgets'! 301100 301101!RolloverButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 20:52'! 301102handlesMouseOver: evt 301103 301104 ^ true! ! 301105 301106!RolloverButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 20:52'! 301107handlesMouseOverDragging: evt 301108 301109 ^ true! ! 301110 301111!RolloverButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 20:53'! 301112mouseEnter: evt 301113 301114 "0.09375 is exact in floating point so no cumulative rounding error will occur" 301115 self color: (self color adjustBrightness: -0.09375)! ! 301116 301117!RolloverButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 20:54'! 301118mouseLeave: evt 301119 301120 "0.09375 is exact in floating point so no cumulative rounding error will occur" 301121 self color: (self color adjustBrightness: 0.09375)! ! 301122 301123!RolloverButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 20:53'! 301124mouseLeaveDragging: evt 301125 301126 self mouseLeave: evt! ! 301127 301128!RolloverButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 22:29'! 301129mouseUp: evt 301130 super mouseUp: evt. 301131 (self containsPoint: evt cursorPoint) 301132 ifFalse: [self mouseLeave: evt . 301133 " In the case of a balk, 301134 we must also note that we have left 301135 after color has been restored." ]. 301136! ! 301137SimpleBorder subclass: #RoundedBorder 301138 instanceVariableNames: 'cornerRadius' 301139 classVariableNames: '' 301140 poolDictionaries: '' 301141 category: 'Polymorph-Widgets-Borders'! 301142!RoundedBorder commentStamp: 'gvc 9/23/2008 11:52' prior: 0! 301143Rounded corner border supporting radii of 1-4 pixels. Slower but more flexible than CornerRounder.! 301144 301145 301146!RoundedBorder methodsFor: 'accessing' stamp: 'gvc 3/14/2007 10:47'! 301147cornerRadius 301148 "Answer the value of cornerRadius" 301149 301150 ^ cornerRadius! ! 301151 301152!RoundedBorder methodsFor: 'accessing' stamp: 'gvc 3/14/2007 10:47'! 301153cornerRadius: anObject 301154 "Set the value of cornerRadius" 301155 301156 cornerRadius := anObject! ! 301157 301158 301159!RoundedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 2/9/2009 13:58'! 301160frameRectangle0: aRectangle on: aCanvas 301161 "Draw the border for a corner radius of 0." 301162 301163 aCanvas 301164 frameAndFillRectangle: aRectangle 301165 fillColor: Color transparent 301166 borderWidth: self width 301167 borderColor: self color! ! 301168 301169!RoundedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 2/21/2008 14:20'! 301170frameRectangle1: aRectangle on: aCanvas 301171 "Draw the border for a corner radius of 1." 301172 301173 |r| 301174 r := aRectangle insetBy: self width // 2. 301175 self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)]. 301176 aCanvas 301177 line: r topLeft + (1@0) to: r topRight - (1@0) width: self width color: self color; 301178 line: r topRight + (0@1) to: r bottomRight - (0@1) width: self width color: self color; 301179 line: r bottomRight - (1@0) to: r bottomLeft + (1@0) width: self width color: self color; 301180 line: r bottomLeft - (0@1) to: r topLeft + (0@1) width: self width color: self color! ! 301181 301182!RoundedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 2/21/2008 14:26'! 301183frameRectangle2: aRectangle on: aCanvas 301184 "Draw the border for a corner radius of 2." 301185 301186 |r| 301187 r := aRectangle insetBy: self width // 2. 301188 self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)]. 301189 aCanvas 301190 line: r topLeft + (2@0) to: r topRight - (2@0) width: self width color: self color; 301191 line: r topRight + (-1@1) to: r topRight + (-1@1) width: self width color: self color; 301192 line: r topRight + (0@2) to: r bottomRight - (0@2) width: self width color: self color; 301193 line: r bottomRight - (1@1) to: r bottomRight - (1@1) width: self width color: self color; 301194 line: r bottomRight - (2@0) to: r bottomLeft + (2@0) width: self width color: self color; 301195 line: r bottomLeft - (-1@1) to: r bottomLeft - (-1@1) width: self width color: self color; 301196 line: r bottomLeft - (0@2) to: r topLeft + (0@2) width: self width color: self color; 301197 line: r topLeft + (1@1) to: r topLeft + (1@1) width: self width color: self color! ! 301198 301199!RoundedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 2/21/2008 14:37'! 301200frameRectangle3: aRectangle on: aCanvas 301201 "Draw the border for a corner radius of 3." 301202 301203 |r| 301204 r := aRectangle insetBy: self width // 2. 301205 self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)]. 301206 aCanvas 301207 line: r topLeft + (3@0) to: r topRight - (3@0) width: self width color: self color; 301208 line: r topRight + (-2@1) to: r topRight + (-1@1) width: self width color: self color; 301209 line: r topRight + (-1@1) to: r topRight + (-1@2) width: self width color: self color; 301210 line: r topRight + (0@3) to: r bottomRight - (0@3) width: self width color: self color; 301211 line: r bottomRight - (1@2) to: r bottomRight - (1@1) width: self width color: self color; 301212 line: r bottomRight - (1@1) to: r bottomRight - (2@1) width: self width color: self color; 301213 line: r bottomRight - (3@0) to: r bottomLeft + (3@0) width: self width color: self color; 301214 line: r bottomLeft - (-2@1) to: r bottomLeft - (-1@1) width: self width color: self color; 301215 line: r bottomLeft - (-1@1) to: r bottomLeft - (-1@2) width: self width color: self color; 301216 line: r bottomLeft - (0@3) to: r topLeft + (0@3) width: self width color: self color; 301217 line: r topLeft + (1@2) to: r topLeft + (1@1) width: self width color: self color; 301218 line: r topLeft + (1@1) to: r topLeft + (2@1) width: self width color: self color! ! 301219 301220!RoundedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 2/21/2008 14:41'! 301221frameRectangle4: aRectangle on: aCanvas 301222 "Draw the border for a corner radius of 4." 301223 301224 |r| 301225 r := aRectangle insetBy: self width // 2. 301226 self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)]. 301227 aCanvas 301228 line: r topLeft + (4@0) to: r topRight - (4@0) width: self width color: self color; 301229 line: r topRight + (-3@1) to: r topRight + (-1@2) width: self width color: self color; 301230 line: r topRight + (-1@2) to: r topRight + (-1@3) width: self width color: self color; 301231 line: r topRight + (0@4) to: r bottomRight - (0@4) width: self width color: self color; 301232 line: r bottomRight - (1@3) to: r bottomRight - (1@2) width: self width color: self color; 301233 line: r bottomRight - (2@1) to: r bottomRight - (3@1) width: self width color: self color; 301234 line: r bottomRight - (4@0) to: r bottomLeft + (4@0) width: self width color: self color; 301235 line: r bottomLeft - (-3@1) to: r bottomLeft - (-2@1) width: self width color: self color; 301236 line: r bottomLeft - (-1@2) to: r bottomLeft - (-1@3) width: self width color: self color; 301237 line: r bottomLeft - (0@4) to: r topLeft + (0@4) width: self width color: self color; 301238 line: r topLeft + (1@3) to: r topLeft + (1@2) width: self width color: self color; 301239 line: r topLeft + (2@1) to: r topLeft + (3@1) width: self width color: self color! ! 301240 301241!RoundedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 1/9/2009 16:50'! 301242frameRectangle5: aRectangle on: aCanvas 301243 "Draw the border for a corner radius of 5." 301244 301245 |r| 301246 r := aRectangle insetBy: self width // 2. 301247 self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)]. 301248 aCanvas 301249 line: r topLeft + (5@0) to: r topRight - (5@0) width: self width color: self color; 301250 line: r topRight + (-4@1) to: r topRight + (-2@2) width: self width color: self color; 301251 line: r topRight + (-1@3) to: r topRight + (-1@4) width: self width color: self color; 301252 line: r topRight + (0@5) to: r bottomRight - (0@5) width: self width color: self color; 301253 line: r bottomRight - (1@4) to: r bottomRight - (2@2) width: self width color: self color; 301254 line: r bottomRight - (3@1) to: r bottomRight - (4@1) width: self width color: self color; 301255 line: r bottomRight - (5@0) to: r bottomLeft + (5@0) width: self width color: self color; 301256 line: r bottomLeft - (-4@1) to: r bottomLeft - (-3@1) width: self width color: self color; 301257 line: r bottomLeft - (-2@2) to: r bottomLeft - (-1@4) width: self width color: self color; 301258 line: r bottomLeft - (0@5) to: r topLeft + (0@5) width: self width color: self color; 301259 line: r topLeft + (1@4) to: r topLeft + (1@3) width: self width color: self color; 301260 line: r topLeft + (2@2) to: r topLeft + (4@1) width: self width color: self color! ! 301261 301262!RoundedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 2/9/2009 13:48'! 301263frameRectangle6: aRectangle on: aCanvas 301264 "Draw the border for a corner radius of 6." 301265 301266 |r| 301267 r := aRectangle insetBy: self width // 2. 301268 self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)]. 301269 aCanvas 301270 line: r topLeft + (6@0) to: r topRight - (6@0) width: self width color: self color; 301271 line: r topRight + (-5@1) to: r topRight + (-3@2) width: self width color: self color; 301272 line: r topRight + (-2@3) to: r topRight + (-2@3) width: self width color: self color; 301273 line: r topRight + (-1@4) to: r topRight + (-1@5) width: self width color: self color; 301274 line: r topRight + (0@6) to: r bottomRight - (0@6) width: self width color: self color; 301275 line: r bottomRight - (1@5) to: r bottomRight - (2@3) width: self width color: self color; 301276 line: r bottomRight - (3@2) to: r bottomRight - (4@1) width: self width color: self color; 301277 line: r bottomRight - (5@1) to: r bottomRight - (6@0) width: self width color: self color; 301278 line: r bottomRight - (7@0) to: r bottomLeft + (6@0) width: self width color: self color; 301279 line: r bottomLeft - (-5@1) to: r bottomLeft - (-4@1) width: self width color: self color; 301280 line: r bottomLeft - (-3@2) to: r bottomLeft - (-3@2) width: self width color: self color; 301281 line: r bottomLeft - (-2@3) to: r bottomLeft - (-1@5) width: self width color: self color; 301282 line: r bottomLeft - (0@6) to: r topLeft + (0@6) width: self width color: self color; 301283 line: r topLeft + (1@5) to: r topLeft + (1@4) width: self width color: self color; 301284 line: r topLeft + (2@3) to: r topLeft + (2@3) width: self width color: self color; 301285 line: r topLeft + (3@2) to: r topLeft + (5@1) width: self width color: self color! ! 301286 301287!RoundedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 1/9/2009 17:06'! 301288frameRectangle7: aRectangle on: aCanvas 301289 "Draw the border for a corner radius of 7." 301290 301291 |r| 301292 r := aRectangle insetBy: self width // 2. 301293 self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)]. 301294 aCanvas 301295 line: r topLeft + (7@0) to: r topRight - (7@0) width: self width color: self color; 301296 line: r topRight + (-6@1) to: r topRight + (-5@1) width: self width color: self color; 301297 line: r topRight + (-4@2) to: r topRight + (-2@4) width: self width color: self color; 301298 line: r topRight + (-1@5) to: r topRight + (-1@6) width: self width color: self color; 301299 line: r topRight + (0@7) to: r bottomRight - (0@7) width: self width color: self color; 301300 line: r bottomRight - (1@6) to: r bottomRight - (1@5) width: self width color: self color; 301301 line: r bottomRight - (2@4) to: r bottomRight - (4@2) width: self width color: self color; 301302 line: r bottomRight - (5@1) to: r bottomRight - (6@1) width: self width color: self color; 301303 line: r bottomRight - (7@0) to: r bottomLeft + (7@0) width: self width color: self color; 301304 line: r bottomLeft - (-6@1) to: r bottomLeft - (-5@1) width: self width color: self color; 301305 line: r bottomLeft - (-4@2) to: r bottomLeft - (-2@4) width: self width color: self color; 301306 line: r bottomLeft - (-1@5) to: r bottomLeft - (-1@6) width: self width color: self color; 301307 line: r bottomLeft - (0@7) to: r topLeft + (0@7) width: self width color: self color; 301308 line: r topLeft + (1@6) to: r topLeft + (1@5) width: self width color: self color; 301309 line: r topLeft + (2@4) to: r topLeft + (4@2) width: self width color: self color; 301310 line: r topLeft + (5@1) to: r topLeft + (6@1) width: self width color: self color! ! 301311 301312!RoundedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 1/9/2009 17:10'! 301313frameRectangle8: aRectangle on: aCanvas 301314 "Draw the border for a corner radius of 8." 301315 301316 |r| 301317 r := aRectangle insetBy: self width // 2. 301318 self width odd ifTrue: [r := r insetBy: (0@0 corner: 1@1)]. 301319 aCanvas 301320 line: r topLeft + (8@0) to: r topRight - (8@0) width: self width color: self color; 301321 line: r topRight + (-7@1) to: r topRight + (-6@1) width: self width color: self color; 301322 line: r topRight + (-5@2) to: r topRight + (-2@5) width: self width color: self color; 301323 line: r topRight + (-1@6) to: r topRight + (-1@7) width: self width color: self color; 301324 line: r topRight + (0@8) to: r bottomRight - (0@8) width: self width color: self color; 301325 line: r bottomRight - (1@7) to: r bottomRight - (1@6) width: self width color: self color; 301326 line: r bottomRight - (2@5) to: r bottomRight - (5@2) width: self width color: self color; 301327 line: r bottomRight - (6@1) to: r bottomRight - (7@1) width: self width color: self color; 301328 line: r bottomRight - (8@0) to: r bottomLeft + (8@0) width: self width color: self color; 301329 line: r bottomLeft - (-7@1) to: r bottomLeft - (-6@1) width: self width color: self color; 301330 line: r bottomLeft - (-5@2) to: r bottomLeft - (-2@5) width: self width color: self color; 301331 line: r bottomLeft - (-1@6) to: r bottomLeft - (-1@7) width: self width color: self color; 301332 line: r bottomLeft - (0@8) to: r topLeft + (0@8) width: self width color: self color; 301333 line: r topLeft + (1@7) to: r topLeft + (1@6) width: self width color: self color; 301334 line: r topLeft + (2@5) to: r topLeft + (5@2) width: self width color: self color; 301335 line: r topLeft + (6@1) to: r topLeft + (7@1) width: self width color: self color! ! 301336 301337!RoundedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 2/9/2009 13:58'! 301338frameRectangle: aRectangle on: aCanvas 301339 "Draw the border. Radius is the x/y offset not width 'around the corner'." 301340 301341 self cornerRadius = 0 ifTrue: [^self frameRectangle0: aRectangle on: aCanvas]. 301342 self cornerRadius = 1 ifTrue: [^self frameRectangle1: aRectangle on: aCanvas]. 301343 self cornerRadius = 2 ifTrue: [^self frameRectangle2: aRectangle on: aCanvas]. 301344 self cornerRadius = 3 ifTrue: [^self frameRectangle3: aRectangle on: aCanvas]. 301345 self cornerRadius = 4 ifTrue: [^self frameRectangle4: aRectangle on: aCanvas]. 301346 self cornerRadius = 5 ifTrue: [^self frameRectangle5: aRectangle on: aCanvas]. 301347 self cornerRadius = 6 ifTrue: [^self frameRectangle6: aRectangle on: aCanvas]. 301348 self cornerRadius = 7 ifTrue: [^self frameRectangle7: aRectangle on: aCanvas]. 301349 self cornerRadius = 8 ifTrue: [^self frameRectangle8: aRectangle on: aCanvas]. 301350 ^super frameRectangle: aRectangle on: aCanvas.! ! 301351 301352!RoundedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 3/14/2007 12:16'! 301353initialize 301354 "Initialize the receiver." 301355 301356 super initialize. 301357 self 301358 cornerRadius: 0! ! 301359LayoutPolicy subclass: #RowLayout 301360 instanceVariableNames: 'cachedMinExtent cachedMinExtents' 301361 classVariableNames: '' 301362 poolDictionaries: '' 301363 category: 'Polymorph-Widgets'! 301364!RowLayout commentStamp: 'gvc 5/31/2007 16:12' prior: 0! 301365A simple row layout.! 301366 301367 301368!RowLayout methodsFor: 'as yet unclassified' stamp: 'gvc 5/31/2007 17:20'! 301369flushLayoutCache 301370 "Flush any cached information associated with the receiver." 301371 301372 cachedMinExtent := nil! ! 301373 301374!RowLayout methodsFor: 'as yet unclassified' stamp: 'gvc 1/22/2009 14:49'! 301375layout: aMorph in: layoutBounds 301376 "Compute the layout for the given morph based on the new bounds. 301377 Supports submorph hResizing, vResizing, cellInset, cellPositioning 301378 (top, *center, bottom*) and listCentering." 301379 301380 |props spare fillCount extra x width height inset cell box pos vr newBounds minExt| 301381 aMorph submorphs ifEmpty: [^self]. 301382 props := aMorph assureTableProperties. 301383 minExt := aMorph minWidth@aMorph minHeight - aMorph extent + aMorph layoutBounds extent. 301384 newBounds := layoutBounds origin extent: (layoutBounds extent max: minExt). 301385 width := 0. 301386 width := (self minExtentOf: aMorph in: newBounds) x. 301387 spare := newBounds width - width max: 0. 301388 fillCount := 0. 301389 spare > 0 301390 ifTrue: [fillCount := aMorph submorphs inject: 0 into: [:tot :m | 301391 tot + (m hResizing == #spaceFill ifTrue: [1] ifFalse: [0])]. 301392 extra := fillCount = 0 301393 ifTrue: [0] 301394 ifFalse: [spare // fillCount]. 301395 spare := spare - (fillCount - 1 * extra)] 301396 ifFalse: [extra := 0]. 301397 x := fillCount > 0 301398 ifTrue: [newBounds left] 301399 ifFalse: [props listCentering == #center 301400 ifTrue: [newBounds center x - (width // 2)] 301401 ifFalse: [props listCentering == #bottomRight 301402 ifTrue: [newBounds right - width] 301403 ifFalse: [newBounds left]]]. 301404 height := newBounds height. 301405 inset := props cellInset isPoint ifTrue: [props cellInset x] ifFalse: [props cellInset]. 301406 aMorph submorphs with: cachedMinExtents do: [:m :ext | 301407 width := m hResizing == #spaceFill 301408 ifTrue: [fillCount := fillCount - 1. 301409 ext x + (fillCount > 0 301410 ifTrue: [spare] 301411 ifFalse: [extra])] 301412 ifFalse: [ext x]. 301413 cell := x@newBounds top extent: width@height. 301414 ((vr := m vResizing) == #shrinkWrap or: [m bounds ~= cell]) 301415 ifTrue: [((vr == #shrinkWrap) not and: [m extent = cell extent]) 301416 ifTrue: [m position: cell origin] 301417 ifFalse: [box := m bounds. 301418 m hResizing == #spaceFill 301419 ifTrue: [box := cell origin extent: cell width @ box height]. 301420 vr == #spaceFill 301421 ifTrue: [box := box origin extent: box width @ cell height]. 301422 vr == #shrinkWrap 301423 ifTrue:[box := box origin extent: box width @ ext y]. 301424 pos := props cellPositioning. 301425 box := box align: (box perform: pos) with: (cell perform: pos). 301426 m bounds: box]]. 301427 x := x + width + inset]! ! 301428 301429!RowLayout methodsFor: 'as yet unclassified' stamp: 'gvc 1/22/2009 14:46'! 301430minExtentOf: aMorph in: newBounds 301431 "Return the minimal size aMorph's children would require given the new bounds" 301432 301433 |extent min props| 301434 cachedMinExtent ifNotNil: [^cachedMinExtent]. 301435 aMorph submorphs ifEmpty: [^self]. 301436 extent := 0@0. 301437 cachedMinExtents := aMorph submorphs collect: [:m | 301438 min := m minExtent. 301439 extent := extent x + min x @ (extent y max: min y). 301440 min]. 301441 props := aMorph assureTableProperties. 301442 ^cachedMinExtent := extent + (aMorph submorphs size - 1 * 301443 (props cellInset isPoint ifTrue: [props cellInset x] ifFalse: [props cellInset]) @ 0)! ! 301444ArrayedCollection subclass: #RunArray 301445 instanceVariableNames: 'runs values lastIndex lastRun lastOffset' 301446 classVariableNames: '' 301447 poolDictionaries: '' 301448 category: 'Collections-Arrayed'! 301449!RunArray commentStamp: '<historical>' prior: 0! 301450My instances provide space-efficient storage of data which tends to be constant over long runs of the possible indices. Essentially repeated values are stored singly and then associated with a "run" length that denotes the number of consecutive occurrences of the value. 301451 301452My two important variables are 301453 runs An array of how many elements are in each run 301454 values An array of what the value is over those elements 301455 301456The variables lastIndex, lastRun and lastOffset cache the last access 301457so that streaming through RunArrays is not an N-squared process. 301458 301459Many complexities of access can be bypassed by using the method 301460 RunArray withStartStopAndValueDo:! 301461]style[(615 33)f1,f1LRunArray withStartStopAndValueDo:;! 301462 301463 301464!RunArray methodsFor: 'accessing' stamp: 'di 1/15/1999 00:04'! 301465= otherArray 301466 "Test if all my elements are equal to those of otherArray" 301467 301468 (otherArray isMemberOf: RunArray) ifFalse: [^ self hasEqualElements: otherArray]. 301469 301470 "Faster test between two RunArrays" 301471 ^ (runs hasEqualElements: otherArray runs) 301472 and: [values hasEqualElements: otherArray values]! ! 301473 301474!RunArray methodsFor: 'accessing'! 301475at: index 301476 301477 self at: index setRunOffsetAndValue: [:run :offset :value | ^value]! ! 301478 301479!RunArray methodsFor: 'accessing' stamp: 'nice 2/14/2007 21:59'! 301480at: index put: aValue 301481 "Set an element of the RunArray" 301482 | runIndex offsetInRun lastValue runLength runReplacement valueReplacement iStart iStop | 301483 index isInteger 301484 ifFalse: [self errorNonIntegerIndex]. 301485 (index >= 1 301486 and: [index <= self size]) 301487 ifFalse: [self errorSubscriptBounds: index]. 301488 self 301489 at: index 301490 setRunOffsetAndValue: [:run :offset :value | 301491 runIndex := run. 301492 offsetInRun := offset. 301493 lastValue := value]. 301494 aValue = lastValue 301495 ifTrue: [^ aValue]. 301496 runLength := runs at: runIndex. 301497 runReplacement := Array 301498 with: offsetInRun 301499 with: 1 301500 with: runLength - offsetInRun - 1. 301501 valueReplacement := Array 301502 with: lastValue 301503 with: aValue 301504 with: lastValue. 301505 iStart := offsetInRun = 0 301506 ifTrue: [2] 301507 ifFalse: [1]. 301508 iStop := offsetInRun = (runLength - 1) 301509 ifTrue: [2] 301510 ifFalse: [3]. 301511 self 301512 setRuns: (runs copyReplaceFrom: runIndex to: runIndex with: (runReplacement copyFrom: iStart to: iStop)) 301513 setValues: (values copyReplaceFrom: runIndex to: runIndex with: (valueReplacement copyFrom: iStart to: iStop)). 301514 self coalesce. 301515 ^ aValue! ! 301516 301517!RunArray methodsFor: 'accessing' stamp: 'ar 10/16/2001 18:56'! 301518first 301519 ^values at: 1! ! 301520 301521!RunArray methodsFor: 'accessing' stamp: 'ar 10/16/2001 18:56'! 301522last 301523 ^values at: values size! ! 301524 301525!RunArray methodsFor: 'accessing'! 301526runLengthAt: index 301527 "Answer the length remaining in run beginning at index." 301528 301529 self at: index 301530 setRunOffsetAndValue: [:run :offset :value | ^(runs at: run) - offset]! ! 301531 301532!RunArray methodsFor: 'accessing'! 301533size 301534 | size | 301535 size := 0. 301536 1 to: runs size do: [:i | size := size + (runs at: i)]. 301537 ^size! ! 301538 301539!RunArray methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 20:31'! 301540withStartStopAndValueDo: aBlock 301541 | start stop | 301542 start := 1. 301543 runs with: values do: 301544 [:len :val | stop := start + len - 1. 301545 aBlock value: start value: stop value: val. 301546 start := stop + 1] 301547 ! ! 301548 301549 301550!RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 18:47'! 301551addFirst: value 301552 "Add value as the first element of the receiver." 301553 lastIndex := nil. "flush access cache" 301554 (runs size=0 or: [values first ~= value]) 301555 ifTrue: 301556 [runs := {1}, runs. 301557 values := {value}, values] 301558 ifFalse: 301559 [runs at: 1 put: runs first+1]! ! 301560 301561!RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 20:25'! 301562addLast: value 301563 "Add value as the last element of the receiver." 301564 lastIndex := nil. "flush access cache" 301565 (runs size=0 or: [values last ~= value]) 301566 ifTrue: 301567 [runs := runs copyWith: 1. 301568 values := values copyWith: value] 301569 ifFalse: 301570 [runs at: runs size put: runs last+1]! ! 301571 301572!RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 18:47'! 301573addLast: value times: times 301574 "Add value as the last element of the receiver, the given number of times" 301575 times = 0 ifTrue: [ ^self ]. 301576 lastIndex := nil. "flush access cache" 301577 (runs size=0 or: [values last ~= value]) 301578 ifTrue: 301579 [runs := runs copyWith: times. 301580 values := values copyWith: value] 301581 ifFalse: 301582 [runs at: runs size put: runs last+times]! ! 301583 301584!RunArray methodsFor: 'adding' stamp: 'tk 1/28/98 09:28'! 301585coalesce 301586 "Try to combine adjacent runs" 301587 | ind | 301588 ind := 2. 301589 [ind > values size] whileFalse: [ 301590 (values at: ind-1) = (values at: ind) 301591 ifFalse: [ind := ind + 1] 301592 ifTrue: ["two are the same, combine them" 301593 values := values copyReplaceFrom: ind to: ind with: #(). 301594 runs at: ind-1 put: (runs at: ind-1) + (runs at: ind). 301595 runs := runs copyReplaceFrom: ind to: ind with: #(). 301596 "self error: 'needed to combine runs' "]]. 301597 ! ! 301598 301599!RunArray methodsFor: 'adding' stamp: 'BG 6/12/2003 11:07'! 301600rangeOf: attr startingAt: startPos 301601 "Answer an interval that gives the range of attr at index position startPos. An empty interval with start value startPos is returned when the attribute attr is not present at position startPos. self size > 0 is assumed, it is the responsibility of the caller to test for emptiness of self. 301602Note that an attribute may span several adjancent runs. " 301603 301604 self at: startPos 301605 setRunOffsetAndValue: 301606 [:run :offset :value | 301607 ^(value includes: attr) 301608 ifFalse: [startPos to: startPos - 1] 301609 ifTrue: 301610 [ | firstRelevantPosition lastRelevantPosition idxOfCandidateRun | 301611 lastRelevantPosition := startPos - offset + (runs at: run) - 1. 301612 firstRelevantPosition := startPos - offset. 301613 idxOfCandidateRun := run + 1. 301614 [idxOfCandidateRun <= runs size 301615 and: [(values at: idxOfCandidateRun) includes: attr]] 301616 whileTrue: 301617 [lastRelevantPosition := lastRelevantPosition + (runs at: idxOfCandidateRun). 301618 idxOfCandidateRun := idxOfCandidateRun + 1]. 301619 idxOfCandidateRun := run - 1. 301620 [idxOfCandidateRun >= 1 301621 and: [(values at: idxOfCandidateRun) includes: attr]] 301622 whileTrue: 301623 [firstRelevantPosition := firstRelevantPosition - (runs at: idxOfCandidateRun). 301624 idxOfCandidateRun := idxOfCandidateRun - 1]. 301625 301626 firstRelevantPosition to: lastRelevantPosition] 301627 ]! ! 301628 301629!RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 18:48'! 301630repeatLast: times ifEmpty: defaultBlock 301631 "add the last value back again, the given number of times. If we are empty, add (defaultBlock value)" 301632 times = 0 ifTrue: [^self ]. 301633 lastIndex := nil. "flush access cache" 301634 (runs size=0) 301635 ifTrue: 301636 [runs := runs copyWith: times. 301637 values := values copyWith: defaultBlock value] 301638 ifFalse: 301639 [runs at: runs size put: runs last+times] ! ! 301640 301641!RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 18:48'! 301642repeatLastIfEmpty: defaultBlock 301643 "add the last value back again. If we are empty, add (defaultBlock value)" 301644 lastIndex := nil. "flush access cache" 301645 (runs size=0) 301646 ifTrue:[ 301647 runs := runs copyWith: 1. 301648 values := values copyWith: defaultBlock value] 301649 ifFalse: 301650 [runs at: runs size put: runs last+1]! ! 301651 301652 301653!RunArray methodsFor: 'converting' stamp: 'BG 6/8/2003 15:17'! 301654reversed 301655 301656 ^self class runs: runs reversed values: values reversed! ! 301657 301658 301659!RunArray methodsFor: 'copying' stamp: 'ar 10/16/2001 18:57'! 301660, aRunArray 301661 "Answer a new RunArray that is a concatenation of the receiver and 301662 aRunArray." 301663 301664 | new newRuns | 301665 (aRunArray isMemberOf: RunArray) 301666 ifFalse: 301667 [new := self copy. 301668 "attempt to be sociable" 301669 aRunArray do: [:each | new addLast: each]. 301670 ^new]. 301671 runs size = 0 ifTrue: [^aRunArray copy]. 301672 aRunArray runs size = 0 ifTrue: [^self copy]. 301673 (values at: values size) ~= (aRunArray values at: 1) 301674 ifTrue: [^RunArray 301675 runs: runs , aRunArray runs 301676 values: values , aRunArray values]. 301677 newRuns := runs 301678 copyReplaceFrom: runs size 301679 to: runs size 301680 with: aRunArray runs. 301681 newRuns at: runs size put: (runs at: runs size) + (aRunArray runs at: 1). 301682 ^RunArray 301683 runs: newRuns 301684 values: 301685 (values 301686 copyReplaceFrom: values size 301687 to: values size 301688 with: aRunArray values)! ! 301689 301690!RunArray methodsFor: 'copying' stamp: 'ls 10/10/1999 13:15'! 301691copyFrom: start to: stop 301692 | newRuns run1 run2 offset1 offset2 | 301693 stop < start ifTrue: [^RunArray new]. 301694 self at: start setRunOffsetAndValue: [:r :o :value1 | run1 := r. offset1 301695:= o. value1]. 301696 self at: stop setRunOffsetAndValue: [:r :o :value2 | run2 := r. offset2 301697:= o. value2]. 301698 run1 = run2 301699 ifTrue: 301700 [newRuns := Array with: offset2 - offset1 + 1] 301701 ifFalse: 301702 [newRuns := runs copyFrom: run1 to: run2. 301703 newRuns at: 1 put: (newRuns at: 1) - offset1. 301704 newRuns at: newRuns size put: offset2 + 1]. 301705 ^RunArray runs: newRuns values: (values copyFrom: run1 to: run2)! ! 301706 301707!RunArray methodsFor: 'copying'! 301708copyReplaceFrom: start to: stop with: replacement 301709 301710 ^(self copyFrom: 1 to: start - 1) 301711 , replacement 301712 , (self copyFrom: stop + 1 to: self size)! ! 301713 301714 301715!RunArray methodsFor: 'enumerating' stamp: 'ar 12/27/1999 13:43'! 301716runsAndValuesDo: aBlock 301717 "Evaluate aBlock with run lengths and values from the receiver" 301718 ^runs with: values do: aBlock.! ! 301719 301720!RunArray methodsFor: 'enumerating' stamp: 'ar 12/17/2001 00:00'! 301721runsFrom: start to: stop do: aBlock 301722 "Evaluate aBlock with all existing runs in the range from start to stop" 301723 | run value index | 301724 start > stop ifTrue:[^self]. 301725 self at: start setRunOffsetAndValue:[:firstRun :offset :firstValue| 301726 run := firstRun. 301727 value := firstValue. 301728 index := start + (runs at: run) - offset. 301729 [aBlock value: value. 301730 index <= stop] whileTrue:[ 301731 run := run + 1. 301732 value := values at: run. 301733 index := index + (runs at: run)]]. 301734! ! 301735 301736 301737!RunArray methodsFor: 'printing' stamp: 'sma 6/1/2000 09:47'! 301738printOn: aStream 301739 self printNameOn: aStream. 301740 aStream 301741 nextPutAll: ' runs: '; 301742 print: runs; 301743 nextPutAll: ' values: '; 301744 print: values! ! 301745 301746!RunArray methodsFor: 'printing'! 301747storeOn: aStream 301748 301749 aStream nextPut: $(. 301750 aStream nextPutAll: self class name. 301751 aStream nextPutAll: ' runs: '. 301752 runs storeOn: aStream. 301753 aStream nextPutAll: ' values: '. 301754 values storeOn: aStream. 301755 aStream nextPut: $)! ! 301756 301757!RunArray methodsFor: 'printing'! 301758writeOn: aStream 301759 301760 aStream nextWordPut: runs size. 301761 1 to: runs size do: 301762 [:x | 301763 aStream nextWordPut: (runs at: x). 301764 aStream nextWordPut: (values at: x)]! ! 301765 301766!RunArray methodsFor: 'printing' stamp: 'tk 12/16/97 09:18'! 301767writeScanOn: strm 301768 "Write out the format used for text runs in source files. (14 50 312)f1,f1b,f1LInteger +;i" 301769 301770 strm nextPut: $(. 301771 runs do: [:rr | rr printOn: strm. strm space]. 301772 strm skip: -1; nextPut: $). 301773 values do: [:vv | 301774 vv do: [:att | att writeScanOn: strm]. 301775 strm nextPut: $,]. 301776 strm skip: -1. "trailing comma"! ! 301777 301778 301779!RunArray methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:49'! 301780isSelfEvaluating 301781 ^ self class == RunArray! ! 301782 301783 301784!RunArray methodsFor: 'private'! 301785at: index setRunOffsetAndValue: aBlock 301786 "Supply all run information to aBlock." 301787 "Tolerates index=0 and index=size+1 for copyReplace: " 301788 | run limit offset | 301789 limit := runs size. 301790 (lastIndex == nil or: [index < lastIndex]) 301791 ifTrue: "cache not loaded, or beyond index - start over" 301792 [run := 1. 301793 offset := index-1] 301794 ifFalse: "cache loaded and before index - start at cache" 301795 [run := lastRun. 301796 offset := lastOffset + (index-lastIndex)]. 301797 [run <= limit and: [offset >= (runs at: run)]] 301798 whileTrue: 301799 [offset := offset - (runs at: run). 301800 run := run + 1]. 301801 lastIndex := index. "Load cache for next access" 301802 lastRun := run. 301803 lastOffset := offset. 301804 run > limit 301805 ifTrue: 301806 ["adjustment for size+1" 301807 run := run - 1. 301808 offset := offset + (runs at: run)]. 301809 ^aBlock 301810 value: run "an index into runs and values" 301811 value: offset "zero-based offset from beginning of this run" 301812 value: (values at: run) "value for this run"! ! 301813 301814!RunArray methodsFor: 'private'! 301815mapValues: mapBlock 301816 "NOTE: only meaningful to an entire set of runs" 301817 values := values collect: [:val | mapBlock value: val]! ! 301818 301819!RunArray methodsFor: 'private'! 301820runs 301821 301822 ^runs! ! 301823 301824!RunArray methodsFor: 'private' stamp: 'ar 10/16/2001 18:47'! 301825setRuns: newRuns setValues: newValues 301826 lastIndex := nil. "flush access cache" 301827 runs := newRuns asArray. 301828 values := newValues asArray.! ! 301829 301830!RunArray methodsFor: 'private'! 301831values 301832 "Answer the values in the receiver." 301833 301834 ^values! ! 301835 301836"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 301837 301838RunArray class 301839 instanceVariableNames: ''! 301840 301841!RunArray class methodsFor: 'instance creation' stamp: 'ar 10/16/2001 19:03'! 301842new 301843 301844 ^self runs: Array new values: Array new! ! 301845 301846!RunArray class methodsFor: 'instance creation' stamp: 'dc 5/24/2007 10:53'! 301847new: aSize 301848 ^ self new: aSize withAll: nil! ! 301849 301850!RunArray class methodsFor: 'instance creation' stamp: 'ar 10/16/2001 19:04'! 301851new: size withAll: value 301852 "Answer a new instance of me, whose every element is equal to the 301853 argument, value." 301854 301855 size = 0 ifTrue: [^self new]. 301856 ^self runs: (Array with: size) values: (Array with: value)! ! 301857 301858!RunArray class methodsFor: 'instance creation'! 301859newFrom: aCollection 301860 "Answer an instance of me containing the same elements as aCollection." 301861 301862 | newCollection | 301863 newCollection := self new. 301864 aCollection do: [:x | newCollection addLast: x]. 301865 ^newCollection 301866 301867" RunArray newFrom: {1. 2. 2. 3} 301868 {1. $a. $a. 3} as: RunArray 301869 ({1. $a. $a. 3} as: RunArray) values 301870"! ! 301871 301872!RunArray class methodsFor: 'instance creation'! 301873readFrom: aStream 301874 "Answer an instance of me as described on the stream, aStream." 301875 301876 | size runs values | 301877 size := aStream nextWord. 301878 runs := Array new: size. 301879 values := Array new: size. 301880 1 to: size do: 301881 [:x | 301882 runs at: x put: aStream nextWord. 301883 values at: x put: aStream nextWord]. 301884 ^ self runs: runs values: values! ! 301885 301886!RunArray class methodsFor: 'instance creation'! 301887runs: newRuns values: newValues 301888 "Answer an instance of me with runs and values specified by the 301889 arguments." 301890 301891 | instance | 301892 instance := self basicNew. 301893 instance setRuns: newRuns setValues: newValues. 301894 ^instance! ! 301895 301896!RunArray class methodsFor: 'instance creation' stamp: 'stephane.ducasse 9/13/2008 16:37'! 301897scanFrom: strm 301898 "Read the style section of a fileOut or sources file. nextChunk has already been done. We need to return a RunArray of TextAttributes of various kinds. These are written by the implementors of writeScanOn:" 301899 | rr vv aa this | 301900 (strm peekFor: $( ) ifFalse: [^ nil]. 301901 rr := OrderedCollection new. 301902 [strm skipSeparators. 301903 strm peekFor: $)] whileFalse: 301904 [rr add: (Number readFrom: strm)]. 301905 vv := OrderedCollection new. "Value array" 301906 aa := OrderedCollection new. "Attributes list" 301907 [(this := strm next) == nil] whileFalse: [ 301908 this == $, ifTrue: [vv add: aa asArray. aa := OrderedCollection new]. 301909 this == $a ifTrue: [aa add: 301910 (TextAlignment new alignment: (Integer readFrom: strm))]. 301911 this == $f ifTrue: [aa add: 301912 (TextFontChange new fontNumber: (Integer readFrom: strm))]. 301913 this == $F ifTrue: [aa add: (TextFontReference toFont: 301914 (StrikeFont familyName: (strm upTo: $#) size: (Integer readFrom: strm)))]. 301915 this == $b ifTrue: [aa add: (TextEmphasis bold)]. 301916 this == $i ifTrue: [aa add: (TextEmphasis italic)]. 301917 this == $u ifTrue: [aa add: (TextEmphasis underlined)]. 301918 this == $= ifTrue: [aa add: (TextEmphasis struckOut)]. 301919 this == $n ifTrue: [aa add: (TextEmphasis normal)]. 301920 this == $- ifTrue: [aa add: (TextKern kern: -1)]. 301921 this == $+ ifTrue: [aa add: (TextKern kern: 1)]. 301922 this == $c ifTrue: [aa add: (TextColor scanFrom: strm)]. "color" 301923 this == $L ifTrue: [aa add: (TextLink scanFrom: strm)]. "L not look like 1" 301924 this == $R ifTrue: [aa add: (TextURL scanFrom: strm)]. 301925 "R capitalized so it can follow a number" 301926 this == $P ifTrue: [aa add: (TextPrintIt scanFrom: strm)]. 301927 this == $d ifTrue: [aa add: (TextDoIt scanFrom: strm)]. 301928 "space, cr do nothing" 301929 ]. 301930 aa size > 0 ifTrue: [vv add: aa asArray]. 301931 ^ self runs: rr asArray values: vv asArray 301932" 301933RunArray scanFrom: (ReadStream on: '(14 50 312)f1,f1b,f1LInteger +;i') 301934"! ! 301935TestCase subclass: #RunArrayTest 301936 instanceVariableNames: '' 301937 classVariableNames: '' 301938 poolDictionaries: '' 301939 category: 'CollectionsTests-Arrayed'! 301940 301941!RunArrayTest methodsFor: 'tests - accessing' stamp: 'dc 2/15/2007 10:25'! 301942testAt 301943 "self debug: #testAt" 301944 | array | 301945 array := RunArray new: 5 withAll: 2. 301946 self assert: (array at: 3) = 2. 301947 301948 array at: 3 put: 5. 301949 self assert: (array at: 3) = 5 301950! ! 301951 301952!RunArrayTest methodsFor: 'tests - accessing' stamp: 'dc 2/15/2007 10:26'! 301953testAtPut 301954 "self debug: #testAtPut" 301955 | array | 301956 array := RunArray new: 5 withAll: 2. 301957 301958 array at: 3 put: 5. 301959 self assert: array = #(2 2 5 2 2). 301960 301961 array at: 1 put: 1. 301962 self assert: array = #(1 2 5 2 2).! ! 301963 301964!RunArrayTest methodsFor: 'tests - accessing' stamp: 'dc 2/15/2007 10:29'! 301965testAtPut2 301966 "self debug: #testAtPut2" 301967 | array | 301968 array := RunArray new: 5 withAll: 2. 301969 301970 self should: [array at: 0 put: 5] raise: Error. 301971 self should: [array at: 6 put: 5] raise: Error. 301972 self should: [array at: $b put: 5] raise: Error.! ! 301973 301974!RunArrayTest methodsFor: 'tests - accessing' stamp: 'dc 2/12/2007 09:49'! 301975testFirst 301976 "self debug: #testFirst" 301977 | array | 301978 array := RunArray new: 5 withAll: 2. 301979 self assert: array first = 2. 301980 301981 array := #($a $b $c $d) as: RunArray. 301982 self assert: array first = $a.! ! 301983 301984!RunArrayTest methodsFor: 'tests - accessing' stamp: 'dc 2/12/2007 09:49'! 301985testLast 301986 "self debug: #testLast" 301987 | array | 301988 array := RunArray new: 5 withAll: 2. 301989 self assert: array last = 2. 301990 301991 array := #($a $b $c $d) as: RunArray. 301992 self assert: array last = $d.! ! 301993 301994!RunArrayTest methodsFor: 'tests - accessing' stamp: 'dc 2/12/2007 09:58'! 301995testRunLengthAt 301996 "self debug: #testRunLengthAt" 301997 | array | 301998 array := #($a $b $b $c $c $c $d $d) as: RunArray. 301999 self assert: (array runLengthAt: 1) = 1. 302000 self assert: (array runLengthAt: 2) = 2. 302001 self assert: (array runLengthAt: 3) = 1. 302002 self assert: (array runLengthAt: 4) = 3. 302003 self assert: (array runLengthAt: 5) = 2. 302004 self assert: (array runLengthAt: 6) = 1. 302005 self assert: (array runLengthAt: 7) = 2. 302006 self assert: (array runLengthAt: 8) = 1.! ! 302007 302008!RunArrayTest methodsFor: 'tests - accessing' stamp: 'dc 2/12/2007 10:12'! 302009testWithStartStopAndValueDo 302010 "self debug: #testWithStartStopAndValueDo" 302011 | array elements startStops | 302012 array := #($a $b $b $c $c $c $d $d) as: RunArray. 302013 elements := OrderedCollection new. 302014 startStops := OrderedCollection new. 302015 array withStartStopAndValueDo: [:start :stop :value | elements add: value. startStops add: start->stop]. 302016 302017 self assert: elements asArray = #($a $b $c $d). 302018 self assert: startStops asArray = {1->1 . 2->3 . 4->6 . 7->8}! ! 302019 302020 302021!RunArrayTest methodsFor: 'tests - instance creation' stamp: 'zz 7/2/2008 16:18'! 302022testANewRunArrayIsEmpty 302023 302024 | t | 302025 t := RunArray new. 302026 self assert:t isEmpty 302027! ! 302028 302029!RunArrayTest methodsFor: 'tests - instance creation' stamp: 'dc 2/12/2007 09:22'! 302030testNew 302031 "self debug: #testNew" 302032 | array | 302033 array := RunArray new. 302034 self assert: array size = 0.! ! 302035 302036!RunArrayTest methodsFor: 'tests - instance creation' stamp: 'dc 2/12/2007 09:24'! 302037testNewFrom 302038 "self debug: #testNewFrom" 302039 | array | 302040 array := RunArray newFrom: #($a $b $b $b $b $c $c $a). 302041 self assert: array size = 8. 302042 self assert: array = #($a $b $b $b $b $c $c $a).! ! 302043 302044!RunArrayTest methodsFor: 'tests - instance creation' stamp: 'dc 2/12/2007 09:15'! 302045testNewWithAll 302046 "self debug: #testNewWithAll" 302047 | array | 302048 array := RunArray new: 5 withAll: 2. 302049 self assert: array size = 5. 302050 self assert: array = #(2 2 2 2 2)! ! 302051 302052!RunArrayTest methodsFor: 'tests - instance creation' stamp: 'dc 5/24/2007 10:56'! 302053testNewWithSize 302054 |array| 302055 array := RunArray new: 5. 302056 self assert: array size = 5. 302057 1 to: 5 do: [:index | self assert: (array at: index) isNil]! ! 302058 302059!RunArrayTest methodsFor: 'tests - instance creation' stamp: 'dc 2/12/2007 09:30'! 302060testRunsValues 302061 "self debug: #testRunsValues" 302062 | array | 302063 array := RunArray runs: #(1 4 2 1) values: #($a $b $c $a). 302064 self assert: array size = 8. 302065 self assert: array = #($a $b $b $b $b $c $c $a).! ! 302066 302067!RunArrayTest methodsFor: 'tests - instance creation' stamp: 'damiencassou 5/30/2008 14:26'! 302068testScanFromANSICompatibility 302069 "self run: #testScanFromANSICompatibility" 302070 RunArray scanFrom: '()f1dNumber new;;' readStream. 302071 RunArray scanFrom: '()a1death;;' readStream. 302072 RunArray scanFrom: '()F1death;;' readStream! ! 302073LanguageEnvironment subclass: #RussianEnvironment 302074 instanceVariableNames: '' 302075 classVariableNames: '' 302076 poolDictionaries: '' 302077 category: 'Multilingual-Languages'! 302078 302079"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 302080 302081RussianEnvironment class 302082 instanceVariableNames: ''! 302083 302084!RussianEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 12/11/2007 11:21'! 302085leadingChar 302086 302087 ^ 15. 302088! ! 302089 302090!RussianEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 12/11/2007 11:22'! 302091supportedLanguages 302092 "Return the languages that this class supports. 302093 Any translations for those languages will use this class as their environment." 302094 302095 ^#('ru' )! ! 302096 302097!RussianEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 8/29/2008 14:11'! 302098systemConverterClass 302099 302100 ^ UTF8TextConverter! ! 302101Object subclass: #RxCharSetParser 302102 instanceVariableNames: 'source lookahead elements' 302103 classVariableNames: '' 302104 poolDictionaries: '' 302105 category: 'VB-Regex'! 302106!RxCharSetParser commentStamp: '<historical>' prior: 0! 302107-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 302108-- See `documentation' protocol of RxParser class for user's guide. 302109-- 302110I am a parser created to parse the insides of a character set ([...]) construct. I create and answer a collection of "elements", each being an instance of one of: RxsCharacter, RxsRange, or RxsPredicate. 302111Instance Variables: 302112 source <Stream> open on whatever is inside the square brackets we have to parse. 302113 lookahead <Character> The current lookahead character 302114 elements <Collection of: <RxsCharacter|RxsRange|RxsPredicate>> Parsing result! 302115 302116 302117!RxCharSetParser methodsFor: 'accessing'! 302118parse 302119 lookahead = $- ifTrue: 302120 [self addChar: $-. 302121 self match: $-]. 302122 [lookahead isNil] whileFalse: [self parseStep]. 302123 ^elements! ! 302124 302125 302126!RxCharSetParser methodsFor: 'initialize-release'! 302127initialize: aStream 302128 source := aStream. 302129 lookahead := aStream next. 302130 elements := OrderedCollection new! ! 302131 302132 302133!RxCharSetParser methodsFor: 'parsing'! 302134addChar: aChar 302135 elements add: (RxsCharacter with: aChar)! ! 302136 302137!RxCharSetParser methodsFor: 'parsing'! 302138addRangeFrom: firstChar to: lastChar 302139 firstChar asInteger > lastChar asInteger ifTrue: 302140 [RxParser signalSyntaxException: ' bad character range']. 302141 elements add: (RxsRange from: firstChar to: lastChar)! ! 302142 302143!RxCharSetParser methodsFor: 'parsing'! 302144match: aCharacter 302145 aCharacter = lookahead 302146 ifFalse: [RxParser signalSyntaxException: 'unexpected character: ', (String with: lookahead)]. 302147 ^source atEnd 302148 ifTrue: [lookahead := nil] 302149 ifFalse: [lookahead := source next]! ! 302150 302151!RxCharSetParser methodsFor: 'parsing'! 302152parseCharOrRange 302153 | firstChar | 302154 firstChar := lookahead. 302155 self match: firstChar. 302156 lookahead = $- ifTrue: 302157 [self match: $-. 302158 lookahead isNil 302159 ifTrue: [^self addChar: firstChar; addChar: $-] 302160 ifFalse: 302161 [self addRangeFrom: firstChar to: lookahead. 302162 ^self match: lookahead]]. 302163 self addChar: firstChar! ! 302164 302165!RxCharSetParser methodsFor: 'parsing'! 302166parseEscapeChar 302167 self match: $\. 302168 $- = lookahead 302169 ifTrue: [elements add: (RxsCharacter with: $-)] 302170 ifFalse: [elements add: (RxsPredicate forEscapedLetter: lookahead)]. 302171 self match: lookahead! ! 302172 302173!RxCharSetParser methodsFor: 'parsing'! 302174parseNamedSet 302175 | name | 302176 self match: $[; match: $:. 302177 name := (String with: lookahead), (source upTo: $:). 302178 lookahead := source next. 302179 self match: $]. 302180 elements add: (RxsPredicate forNamedClass: name)! ! 302181 302182!RxCharSetParser methodsFor: 'parsing'! 302183parseStep 302184 lookahead = $[ ifTrue: 302185 [source peek = $: 302186 ifTrue: [^self parseNamedSet] 302187 ifFalse: [^self parseCharOrRange]]. 302188 lookahead = $\ ifTrue: 302189 [^self parseEscapeChar]. 302190 lookahead = $- ifTrue: 302191 [RxParser signalSyntaxException: 'invalid range']. 302192 self parseCharOrRange! ! 302193 302194"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 302195 302196RxCharSetParser class 302197 instanceVariableNames: ''! 302198 302199!RxCharSetParser class methodsFor: 'instance creation'! 302200on: aStream 302201 ^self new initialize: aStream! ! 302202Object subclass: #RxMatchOptimizer 302203 instanceVariableNames: 'ignoreCase prefixes nonPrefixes conditions testBlock methodPredicates nonMethodPredicates predicates nonPredicates' 302204 classVariableNames: '' 302205 poolDictionaries: '' 302206 category: 'VB-Regex'! 302207!RxMatchOptimizer commentStamp: '<historical>' prior: 0! 302208-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 302209-- See `documentation' protocol of RxParser class for user's guide. 302210-- 302211A match start optimizer, handy for searching a string. Takes a regex syntax tree and sets itself up so that prefix characters or matcher states that cannot start a match are later recognized with #canStartMatch:in: method. 302212Used by RxMatcher, but can be used by other matchers (if implemented) as well.! 302213 302214 302215!RxMatchOptimizer methodsFor: 'accessing'! 302216canStartMatch: aCharacter in: aMatcher 302217 "Answer whether a match could commence at the given lookahead 302218 character, or in the current state of <aMatcher>. True answered 302219 by this method does not mean a match will definitly occur, while false 302220 answered by this method *does* guarantee a match will never occur." 302221 aCharacter isNil ifTrue: [^true]. 302222 ^testBlock == nil or: [testBlock value: aCharacter value: aMatcher]! ! 302223 302224!RxMatchOptimizer methodsFor: 'accessing' stamp: 'avi 11/30/2003 13:28'! 302225conditionTester 302226 "#any condition is filtered at the higher level; 302227 it cannot appear among the conditions here." 302228 | matchCondition | 302229 conditions isEmpty ifTrue: [^nil]. 302230 conditions size = 1 ifTrue: 302231 [matchCondition := conditions detect: [:ignored | true]. 302232 "Special case all of the possible conditions." 302233 #atBeginningOfLine = matchCondition ifTrue: [^[:c :matcher | matcher atBeginningOfLine]]. 302234 #atEndOfLine = matchCondition ifTrue: [^[:c :matcher | matcher atEndOfLine]]. 302235 #atBeginningOfWord = matchCondition ifTrue: [^[:c :matcher | matcher atBeginningOfWord]]. 302236 #atEndOfWord = matchCondition ifTrue: [^[:c :matcher | matcher atEndOfWord]]. 302237 #atWordBoundary = matchCondition ifTrue: [^[:c :matcher | matcher atWordBoundary]]. 302238 #notAtWordBoundary = matchCondition ifTrue: [^[:c :matcher | matcher notAtWordBoundary]]. 302239 RxParser signalCompilationException: 'invalid match condition']. 302240 "More than one condition. Capture them as an array in scope." 302241 matchCondition := conditions asArray. 302242 ^[:c :matcher | 302243 matchCondition anySatisfy: 302244 [:conditionSelector | 302245 matcher perform: conditionSelector]]! ! 302246 302247!RxMatchOptimizer methodsFor: 'accessing'! 302248methodPredicateTester 302249 | p selector | 302250 methodPredicates isEmpty ifTrue: [^nil]. 302251 p := self optimizeSet: methodPredicates. "also allows copying closures" 302252 ^p size = 1 302253 ifTrue: 302254 ["might be a pretty common case" 302255 selector := p first. 302256 [:char :matcher | 302257 RxParser doHandlingMessageNotUnderstood: 302258 [char perform: selector]]] 302259 ifFalse: 302260 [[:char :m | 302261 RxParser doHandlingMessageNotUnderstood: 302262 [p contains: [:sel | char perform: sel]]]]! ! 302263 302264!RxMatchOptimizer methodsFor: 'accessing'! 302265nonMethodPredicateTester 302266 | p selector | 302267 nonMethodPredicates isEmpty ifTrue: [^nil]. 302268 p := self optimizeSet: nonMethodPredicates. "also allows copying closures" 302269 ^p size = 1 302270 ifTrue: 302271 [selector := p first. 302272 [:char :matcher | 302273 RxParser doHandlingMessageNotUnderstood: 302274 [(char perform: selector) not]]] 302275 ifFalse: 302276 [[:char :m | 302277 RxParser doHandlingMessageNotUnderstood: 302278 [p contains: [:sel | (char perform: sel) not]]]]! ! 302279 302280 302281!RxMatchOptimizer methodsFor: 'double dispatch'! 302282syntaxAny 302283 "Any special char is among the prefixes." 302284 conditions add: #any! ! 302285 302286!RxMatchOptimizer methodsFor: 'double dispatch'! 302287syntaxBeginningOfLine 302288 "Beginning of line is among the prefixes." 302289 conditions add: #atBeginningOfLine! ! 302290 302291!RxMatchOptimizer methodsFor: 'double dispatch'! 302292syntaxBeginningOfWord 302293 "Beginning of line is among the prefixes." 302294 conditions add: #atBeginningOfWord! ! 302295 302296!RxMatchOptimizer methodsFor: 'double dispatch'! 302297syntaxBranch: branchNode 302298 "If the head piece of the branch is transparent (allows 0 matches), 302299 we must recurse down the branch. Otherwise, just the head atom 302300 is important." 302301 (branchNode piece isNullable and: [branchNode branch notNil]) 302302 ifTrue: [branchNode branch dispatchTo: self]. 302303 branchNode piece dispatchTo: self! ! 302304 302305!RxMatchOptimizer methodsFor: 'double dispatch'! 302306syntaxCharSet: charSetNode 302307 "All these (or none of these) characters is the prefix." 302308 charSetNode isNegated 302309 ifTrue: [nonPrefixes addAll: charSetNode enumerableSet] 302310 ifFalse: [prefixes addAll: charSetNode enumerableSet]. 302311 charSetNode hasPredicates ifTrue: 302312 [charSetNode isNegated 302313 ifTrue: [nonPredicates addAll: charSetNode predicates] 302314 ifFalse: [predicates addAll: charSetNode predicates]]! ! 302315 302316!RxMatchOptimizer methodsFor: 'double dispatch'! 302317syntaxCharacter: charNode 302318 "This character is the prefix, of one of them." 302319 prefixes add: charNode character! ! 302320 302321!RxMatchOptimizer methodsFor: 'double dispatch'! 302322syntaxEndOfLine 302323 "Beginning of line is among the prefixes." 302324 conditions add: #atEndOfLine! ! 302325 302326!RxMatchOptimizer methodsFor: 'double dispatch'! 302327syntaxEndOfWord 302328 conditions add: #atEndOfWord! ! 302329 302330!RxMatchOptimizer methodsFor: 'double dispatch'! 302331syntaxEpsilon 302332 "Empty string, terminate the recursion (do nothing)."! ! 302333 302334!RxMatchOptimizer methodsFor: 'double dispatch'! 302335syntaxMessagePredicate: messagePredicateNode 302336 messagePredicateNode negated 302337 ifTrue: [nonMethodPredicates add: messagePredicateNode selector] 302338 ifFalse: [methodPredicates add: messagePredicateNode selector]! ! 302339 302340!RxMatchOptimizer methodsFor: 'double dispatch'! 302341syntaxNonWordBoundary 302342 conditions add: #notAtWordBoundary! ! 302343 302344!RxMatchOptimizer methodsFor: 'double dispatch'! 302345syntaxPiece: pieceNode 302346 "Pass on to the atom." 302347 pieceNode atom dispatchTo: self! ! 302348 302349!RxMatchOptimizer methodsFor: 'double dispatch'! 302350syntaxPredicate: predicateNode 302351 predicates add: predicateNode predicate! ! 302352 302353!RxMatchOptimizer methodsFor: 'double dispatch'! 302354syntaxRegex: regexNode 302355 "All prefixes of the regex's branches should be combined. 302356 Therefore, just recurse." 302357 regexNode branch dispatchTo: self. 302358 regexNode regex notNil 302359 ifTrue: [regexNode regex dispatchTo: self]! ! 302360 302361!RxMatchOptimizer methodsFor: 'double dispatch'! 302362syntaxWordBoundary 302363 conditions add: #atWordBoundary! ! 302364 302365 302366!RxMatchOptimizer methodsFor: 'initialize-release'! 302367initialize: aRegex ignoreCase: aBoolean 302368 "Set `testMethod' variable to a can-match predicate block: 302369 two-argument block which accepts a lookahead character 302370 and a matcher (presumably built from aRegex) and answers 302371 a boolean indicating whether a match could start at the given 302372 lookahead. " 302373 ignoreCase := aBoolean. 302374 prefixes := Set new: 10. 302375 nonPrefixes := Set new: 10. 302376 conditions := Set new: 3. 302377 methodPredicates := Set new: 3. 302378 nonMethodPredicates := Set new: 3. 302379 predicates := Set new: 3. 302380 nonPredicates := Set new: 3. 302381 aRegex dispatchTo: self. "If the whole expression is nullable, 302382 end-of-line is an implicit can-match condition!!" 302383 aRegex isNullable ifTrue: [conditions add: #atEndOfLine]. 302384 testBlock := self determineTestMethod! ! 302385 302386 302387!RxMatchOptimizer methodsFor: 'private' stamp: 'avi 11/30/2003 13:27'! 302388determineTestMethod 302389 "Answer a block closure that will work as a can-match predicate. 302390 Answer nil if no viable optimization is possible (too many chars would 302391 be able to start a match)." 302392 | testers | 302393 (conditions includes: #any) ifTrue: [^nil]. 302394 testers := OrderedCollection new: 5. 302395 #(#prefixTester #nonPrefixTester #conditionTester #methodPredicateTester #nonMethodPredicateTester #predicateTester #nonPredicateTester) 302396 do: 302397 [:selector | 302398 | tester | 302399 tester := self perform: selector. 302400 tester notNil ifTrue: [testers add: tester]]. 302401 testers isEmpty ifTrue: [^nil]. 302402 testers size = 1 ifTrue: [^testers first]. 302403 testers := testers asArray. 302404 ^[:char :matcher | testers anySatisfy: [:t | t value: char value: matcher]]! ! 302405 302406!RxMatchOptimizer methodsFor: 'private'! 302407nonPredicateTester 302408 | p pred | 302409 nonPredicates isEmpty ifTrue: [^nil]. 302410 p := self optimizeSet: nonPredicates. "also allows copying closures" 302411 ^p size = 1 302412 ifTrue: 302413 [pred := p first. 302414 [:char :matcher | (pred value: char) not]] 302415 ifFalse: 302416 [[:char :m | p contains: [:some | (some value: char) not]]]! ! 302417 302418!RxMatchOptimizer methodsFor: 'private' stamp: 'stephane.ducasse 4/13/2009 20:32'! 302419nonPrefixTester 302420 | np nonPrefixChar | 302421 nonPrefixes isEmpty ifTrue: [^nil]. 302422 np := self optimizeSet: nonPrefixes. "also allows copying closures" 302423 ^np size = 1 "might be be pretty common case" 302424 ifTrue: 302425 [nonPrefixChar := np first. 302426 [:char :matcher | char ~= nonPrefixChar]] 302427 ifFalse: [[:char :matcher | (np includes: char) not]]! ! 302428 302429!RxMatchOptimizer methodsFor: 'private'! 302430optimizeSet: aSet 302431 "If a set is small, convert it to array to speed up lookup 302432 (Array has no hashing overhead, beats Set on small number 302433 of elements)." 302434 ^aSet size < 10 ifTrue: [aSet asArray] ifFalse: [aSet]! ! 302435 302436!RxMatchOptimizer methodsFor: 'private'! 302437predicateTester 302438 | p pred | 302439 predicates isEmpty ifTrue: [^nil]. 302440 p := self optimizeSet: predicates. "also allows copying closures" 302441 ^p size = 1 302442 ifTrue: 302443 [pred := p first. 302444 [:char :matcher | pred value: char]] 302445 ifFalse: 302446 [[:char :m | p contains: [:some | some value: char]]]! ! 302447 302448!RxMatchOptimizer methodsFor: 'private'! 302449prefixTester 302450 | p prefixChar | 302451 prefixes isEmpty ifTrue: [^nil]. 302452 p := self optimizeSet: prefixes. "also allows copying closures" 302453 ignoreCase ifTrue: [p := p collect: [:each | each asUppercase]]. 302454 ^p size = 1 "might be a pretty common case" 302455 ifTrue: 302456 [prefixChar := p first. 302457 ignoreCase 302458 ifTrue: [[:char :matcher | char sameAs: prefixChar]] 302459 ifFalse: [[:char :matcher | char = prefixChar]]] 302460 ifFalse: 302461 [ignoreCase 302462 ifTrue: [[:char :matcher | p includes: char asUppercase]] 302463 ifFalse: [[:char :matcher | p includes: char]]]! ! 302464Object subclass: #RxMatcher 302465 instanceVariableNames: 'matcher ignoreCase startOptimizer stream markerPositions markerCount lastResult lastChar' 302466 classVariableNames: 'Cr Lf' 302467 poolDictionaries: '' 302468 category: 'VB-Regex'! 302469!RxMatcher commentStamp: '<historical>' prior: 0! 302470-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 302471-- See `documentation' protocol of RxParser class for user's guide. 302472-- 302473This is a recursive regex matcher. Not strikingly efficient, but simple. Also, keeps track of matched subexpressions. The life cycle goes as follows: 3024741. Initialization. Accepts a syntax tree (presumably produced by RxParser) and compiles it into a matcher built of other classes in this category. 3024752. Matching. Accepts a stream or a string and returns a boolean indicating whether the whole stream or its prefix -- depending on the message sent -- matches the regex. 3024763. Subexpression query. After a successful match, and before any other match, the matcher may be queried about the range of specific stream (string) positions that matched to certain parenthesized subexpressions of the original expression. 302477Any number of queries may follow a successful match, and any number or matches may follow a successful initialization. 302478Note that `matcher' is actually a sort of a misnomer. The actual matcher is a web of Rxm* instances built by RxMatcher during initialization. RxMatcher is just the interface facade of this network. It is also a builder of it, and also provides a stream-like protocol to easily access the stream being matched. 302479Instance variables: 302480 matcher <RxmLink> The entry point into the actual matcher. 302481 stream <Stream> The stream currently being matched against. 302482 markerPositions <Array of: Integer> Positions of markers' matches. 302483 markerCount <Integer> Number of markers. 302484 lastResult <Boolean> Whether the latest match attempt succeeded or not. 302485 lastChar <Character | nil> character last seen in the matcher stream! 302486 302487 302488!RxMatcher methodsFor: '*splitjoin' stamp: 'onierstrasz 4/12/2009 20:16'! 302489split: aString 302490 | result lastPosition | 302491 result := OrderedCollection new. 302492 stream := aString readStream. 302493 lastPosition := stream position. 302494 [ self searchStream: stream ] whileTrue: 302495 [ result add: (aString copyFrom: lastPosition+1 to: (self subBeginning: 1)). 302496 self assert: lastPosition < stream position description: 'Regex cannot match null string'. 302497 lastPosition := stream position ]. 302498 result add: (aString copyFrom: lastPosition+1 to: aString size). 302499 ^ result! ! 302500 302501 302502!RxMatcher methodsFor: 'accessing'! 302503buildFrom: aSyntaxTreeRoot 302504 "Private - Entry point of matcher build process." 302505 markerCount := 0. "must go before #dispatchTo: !!" 302506 matcher := aSyntaxTreeRoot dispatchTo: self. 302507 matcher terminateWith: RxmTerminator new! ! 302508 302509!RxMatcher methodsFor: 'accessing'! 302510lastResult 302511 ^lastResult! ! 302512 302513!RxMatcher methodsFor: 'accessing'! 302514matches: aString 302515 "Match against a string." 302516 ^self matchesStream: aString readStream! ! 302517 302518!RxMatcher methodsFor: 'accessing'! 302519matchesPrefix: aString 302520 "Match against a string." 302521 ^self matchesStreamPrefix: aString readStream! ! 302522 302523!RxMatcher methodsFor: 'accessing'! 302524matchesStream: theStream 302525 "Match thyself against a positionable stream." 302526 ^(self matchesStreamPrefix: theStream) 302527 and: [stream atEnd]! ! 302528 302529!RxMatcher methodsFor: 'accessing'! 302530matchesStreamPrefix: theStream 302531 "Match thyself against a positionable stream." 302532 stream := theStream. 302533 lastChar := nil. 302534 ^self tryMatch! ! 302535 302536!RxMatcher methodsFor: 'accessing'! 302537search: aString 302538 "Search the string for occurrence of something matching myself. 302539 Answer a Boolean indicating success." 302540 ^self searchStream: aString readStream! ! 302541 302542!RxMatcher methodsFor: 'accessing'! 302543searchStream: aStream 302544 "Search the stream for occurrence of something matching myself. 302545 After the search has occurred, stop positioned after the end of the 302546 matched substring. Answer a Boolean indicating success." 302547 | position | 302548 stream := aStream. 302549 lastChar := nil. 302550 position := aStream position. 302551 [aStream atEnd] whileFalse: 302552 [self tryMatch ifTrue: [^true]. 302553 aStream position: position. 302554 lastChar := aStream next. 302555 position := aStream position]. 302556 "Try match at the very stream end too!!" 302557 self tryMatch ifTrue: [^true]. 302558 ^false! ! 302559 302560!RxMatcher methodsFor: 'accessing'! 302561subBeginning: subIndex 302562 ^markerPositions at: subIndex * 2 - 1! ! 302563 302564!RxMatcher methodsFor: 'accessing'! 302565subEnd: subIndex 302566 ^markerPositions at: subIndex * 2! ! 302567 302568!RxMatcher methodsFor: 'accessing'! 302569subexpression: subIndex 302570 | originalPosition start end reply | 302571 originalPosition := stream position. 302572 start := self subBeginning: subIndex. 302573 end := self subEnd: subIndex. 302574 (start isNil or: [end isNil]) ifTrue: [^String new]. 302575 reply := (String new: end - start) writeStream. 302576 stream position: start. 302577 start to: end - 1 do: [:ignored | reply nextPut: stream next]. 302578 stream position: originalPosition. 302579 ^reply contents! ! 302580 302581!RxMatcher methodsFor: 'accessing'! 302582subexpressionCount 302583 ^markerCount // 2! ! 302584 302585!RxMatcher methodsFor: 'accessing' stamp: 'damien.pollet 5/2/2009 23:51'! 302586subexpressions 302587 | result | 302588 result := Array new: self subexpressionCount. 302589 1 to: self subexpressionCount do: [:index | 302590 result 302591 at: index 302592 put: (self subexpression: index) ]. 302593 ^ result! ! 302594 302595 302596!RxMatcher methodsFor: 'double dispatch'! 302597syntaxAny 302598 "Double dispatch from the syntax tree. 302599 Create a matcher for any non-whitespace character." 302600 ^RxmPredicate new 302601 predicate: [:char | (Cr = char or: [Lf = char]) not]! ! 302602 302603!RxMatcher methodsFor: 'double dispatch'! 302604syntaxBeginningOfLine 302605 "Double dispatch from the syntax tree. 302606 Create a matcher for beginning-of-line condition." 302607 ^RxmSpecial new beBeginningOfLine! ! 302608 302609!RxMatcher methodsFor: 'double dispatch'! 302610syntaxBeginningOfWord 302611 "Double dispatch from the syntax tree. 302612 Create a matcher for beginning-of-word condition." 302613 ^RxmSpecial new beBeginningOfWord! ! 302614 302615!RxMatcher methodsFor: 'double dispatch' stamp: 'PeterHugossonMiller 9/3/2009 11:08'! 302616syntaxBranch: branchNode 302617 "Double dispatch from the syntax tree. 302618 Branch node is a link in a chain of concatenated pieces. 302619 First build the matcher for the rest of the chain, then make 302620 it for the current piece and hook the rest to it." 302621 | result next rest | 302622 branchNode branch isNil 302623 ifTrue: [^branchNode piece dispatchTo: self]. 302624 "Optimization: glue a sequence of individual characters into a single string to match." 302625 branchNode piece isAtomic ifTrue: 302626 [result := (String new: 40) writeStream. 302627 next := branchNode tryMergingInto: result. 302628 result := result contents. 302629 result size > 1 ifTrue: "worth merging" 302630 [rest := next notNil 302631 ifTrue: [next dispatchTo: self] 302632 ifFalse: [nil]. 302633 ^(RxmSubstring new substring: result ignoreCase: ignoreCase) 302634 pointTailTo: rest; 302635 yourself]]. 302636 "No optimization possible or worth it, just concatenate all. " 302637 ^(branchNode piece dispatchTo: self) 302638 pointTailTo: (branchNode branch dispatchTo: self); 302639 yourself! ! 302640 302641!RxMatcher methodsFor: 'double dispatch'! 302642syntaxCharSet: charSetNode 302643 "Double dispatch from the syntax tree. 302644 A character set is a few characters, and we either match any of them, 302645 or match any that is not one of them." 302646 ^RxmPredicate with: charSetNode predicate! ! 302647 302648!RxMatcher methodsFor: 'double dispatch'! 302649syntaxCharacter: charNode 302650 "Double dispatch from the syntax tree. 302651 We get here when no merging characters into strings was possible." 302652 | wanted | 302653 wanted := charNode character. 302654 ^RxmPredicate new predicate: 302655 (ignoreCase 302656 ifTrue: [[:char | char sameAs: wanted]] 302657 ifFalse: [[:char | char = wanted]])! ! 302658 302659!RxMatcher methodsFor: 'double dispatch'! 302660syntaxEndOfLine 302661 "Double dispatch from the syntax tree. 302662 Create a matcher for end-of-line condition." 302663 ^RxmSpecial new beEndOfLine! ! 302664 302665!RxMatcher methodsFor: 'double dispatch'! 302666syntaxEndOfWord 302667 "Double dispatch from the syntax tree. 302668 Create a matcher for end-of-word condition." 302669 ^RxmSpecial new beEndOfWord! ! 302670 302671!RxMatcher methodsFor: 'double dispatch'! 302672syntaxEpsilon 302673 "Double dispatch from the syntax tree. Match empty string. This is unlikely 302674 to happen in sane expressions, so we'll live without special epsilon-nodes." 302675 ^RxmSubstring new 302676 substring: String new 302677 ignoreCase: ignoreCase! ! 302678 302679!RxMatcher methodsFor: 'double dispatch'! 302680syntaxMessagePredicate: messagePredicateNode 302681 "Double dispatch from the syntax tree. 302682 Special link can handle predicates." 302683 ^messagePredicateNode negated 302684 ifTrue: [RxmPredicate new bePerformNot: messagePredicateNode selector] 302685 ifFalse: [RxmPredicate new bePerform: messagePredicateNode selector]! ! 302686 302687!RxMatcher methodsFor: 'double dispatch'! 302688syntaxNonWordBoundary 302689 "Double dispatch from the syntax tree. 302690 Create a matcher for the word boundary condition." 302691 ^RxmSpecial new beNotWordBoundary! ! 302692 302693!RxMatcher methodsFor: 'double dispatch'! 302694syntaxPiece: pieceNode 302695 "Double dispatch from the syntax tree. 302696 Piece is an atom repeated a few times. Take care of a special 302697 case when the atom is repeated just once." 302698 | atom | 302699 atom := pieceNode atom dispatchTo: self. 302700 ^pieceNode isSingular 302701 ifTrue: [atom] 302702 ifFalse: [pieceNode isStar 302703 ifTrue: [self makeStar: atom] 302704 ifFalse: [pieceNode isPlus 302705 ifTrue: [self makePlus: atom] 302706 ifFalse: [pieceNode isOptional 302707 ifTrue: [self makeOptional: atom] 302708 ifFalse: [RxParser signalCompilationException: 302709 'repetitions are not supported by RxMatcher']]]]! ! 302710 302711!RxMatcher methodsFor: 'double dispatch'! 302712syntaxPredicate: predicateNode 302713 "Double dispatch from the syntax tree. 302714 A character set is a few characters, and we either match any of them, 302715 or match any that is not one of them." 302716 ^RxmPredicate with: predicateNode predicate! ! 302717 302718!RxMatcher methodsFor: 'double dispatch'! 302719syntaxRegex: regexNode 302720 "Double dispatch from the syntax tree. 302721 Regex node is a chain of branches to be tried. Should compile this 302722 into a bundle of parallel branches, between two marker nodes." 302723 302724 | startIndex endIndex endNode alternatives | 302725 startIndex := self allocateMarker. 302726 endIndex := self allocateMarker. 302727 endNode := RxmMarker new index: endIndex. 302728 alternatives := self hookBranchOf: regexNode onto: endNode. 302729 ^(RxmMarker new index: startIndex) 302730 pointTailTo: alternatives; 302731 yourself! ! 302732 302733!RxMatcher methodsFor: 'double dispatch'! 302734syntaxWordBoundary 302735 "Double dispatch from the syntax tree. 302736 Create a matcher for the word boundary condition." 302737 ^RxmSpecial new beWordBoundary! ! 302738 302739 302740!RxMatcher methodsFor: 'initialize-release'! 302741initialize: syntaxTreeRoot ignoreCase: aBoolean 302742 "Compile thyself for the regex with the specified syntax tree. 302743 See comment and `building' protocol in this class and 302744 #dispatchTo: methods in syntax tree components for details 302745 on double-dispatch building. 302746 The argument is supposedly a RxsRegex." 302747 ignoreCase := aBoolean. 302748 self buildFrom: syntaxTreeRoot. 302749 startOptimizer := RxMatchOptimizer new initialize: syntaxTreeRoot ignoreCase: aBoolean! ! 302750 302751 302752!RxMatcher methodsFor: 'match enumeration'! 302753copy: aString replacingMatchesWith: replacementString 302754 "Copy <aString>, except for the matches. Replace each match with <aString>." 302755 | answer | 302756 answer := (String new: 40) writeStream. 302757 self 302758 copyStream: aString readStream 302759 to: answer 302760 replacingMatchesWith: replacementString. 302761 ^answer contents! ! 302762 302763!RxMatcher methodsFor: 'match enumeration'! 302764copy: aString translatingMatchesUsing: aBlock 302765 "Copy <aString>, except for the matches. For each match, evaluate <aBlock> passing the matched substring as the argument. Expect the block to answer a String, and replace the match with the answer." 302766 | answer | 302767 answer := (String new: 40) writeStream. 302768 self copyStream: aString readStream to: answer translatingMatchesUsing: aBlock. 302769 ^answer contents! ! 302770 302771!RxMatcher methodsFor: 'match enumeration'! 302772copyStream: aStream to: writeStream replacingMatchesWith: aString 302773 "Copy the contents of <aStream> on the <writeStream>, except for the matches. Replace each match with <aString>." 302774 | searchStart matchStart matchEnd | 302775 stream := aStream. 302776 lastChar := nil. 302777 [searchStart := aStream position. 302778 self proceedSearchingStream: aStream] whileTrue: 302779 [matchStart := self subBeginning: 1. 302780 matchEnd := self subEnd: 1. 302781 aStream position: searchStart. 302782 searchStart to: matchStart - 1 do: 302783 [:ignoredPos | writeStream nextPut: aStream next]. 302784 writeStream nextPutAll: aString. 302785 aStream position: matchEnd]. 302786 aStream position: searchStart. 302787 [aStream atEnd] whileFalse: [writeStream nextPut: aStream next]! ! 302788 302789!RxMatcher methodsFor: 'match enumeration'! 302790copyStream: aStream to: writeStream translatingMatchesUsing: aBlock 302791 "Copy the contents of <aStream> on the <writeStream>, except for the matches. For each match, evaluate <aBlock> passing the matched substring as the argument. Expect the block to answer a String, and write the answer to <writeStream> in place of the match." 302792 | searchStart matchStart matchEnd match | 302793 stream := aStream. 302794 lastChar := nil. 302795 [searchStart := aStream position. 302796 self proceedSearchingStream: aStream] whileTrue: 302797 [matchStart := self subBeginning: 1. 302798 matchEnd := self subEnd: 1. 302799 aStream position: searchStart. 302800 searchStart to: matchStart - 1 do: 302801 [:ignoredPos | writeStream nextPut: aStream next]. 302802 match := (String new: matchEnd - matchStart + 1) writeStream. 302803 matchStart to: matchEnd - 1 do: 302804 [:ignoredPos | match nextPut: aStream next]. 302805 writeStream nextPutAll: (aBlock value: match contents)]. 302806 aStream position: searchStart. 302807 [aStream atEnd] whileFalse: [writeStream nextPut: aStream next]! ! 302808 302809!RxMatcher methodsFor: 'match enumeration'! 302810matchesIn: aString 302811 "Search aString repeatedly for the matches of the receiver. Answer an OrderedCollection of all matches (substrings)." 302812 | result | 302813 result := OrderedCollection new. 302814 self 302815 matchesOnStream: aString readStream 302816 do: [:match | result add: match]. 302817 ^result! ! 302818 302819!RxMatcher methodsFor: 'match enumeration' stamp: 'damien.pollet 5/2/2009 23:59'! 302820matchesIn: aString collect: aBlock 302821 "Search aString repeatedly for the matches of the receiver. Evaluate aBlock for each match passing the matched substring as the argument, collect evaluation results in an OrderedCollection, and return it. The following example shows how to use this message to split a string into words." 302822 "'\w+' asRegex matchesIn: 'Now is the Time' collect: [:each | each asLowercase]" 302823 | result | 302824 result := OrderedCollection new. 302825 self 302826 matchesOnStream: aString readStream 302827 do: [:match | result add: (aBlock value: match)]. 302828 ^result! ! 302829 302830!RxMatcher methodsFor: 'match enumeration'! 302831matchesIn: aString do: aBlock 302832 "Search aString repeatedly for the matches of the receiver. 302833 Evaluate aBlock for each match passing the matched substring 302834 as the argument." 302835 self 302836 matchesOnStream: aString readStream 302837 do: aBlock! ! 302838 302839!RxMatcher methodsFor: 'match enumeration'! 302840matchesOnStream: aStream 302841 | result | 302842 result := OrderedCollection new. 302843 self 302844 matchesOnStream: aStream 302845 do: [:match | result add: match]. 302846 ^result! ! 302847 302848!RxMatcher methodsFor: 'match enumeration'! 302849matchesOnStream: aStream collect: aBlock 302850 | result | 302851 result := OrderedCollection new. 302852 self 302853 matchesOnStream: aStream 302854 do: [:match | result add: (aBlock value: match)]. 302855 ^result! ! 302856 302857!RxMatcher methodsFor: 'match enumeration'! 302858matchesOnStream: aStream do: aBlock 302859 [self searchStream: aStream] whileTrue: 302860 [aBlock value: (self subexpression: 1)]! ! 302861 302862!RxMatcher methodsFor: 'match enumeration' stamp: 'damien.pollet 5/3/2009 00:03'! 302863submatchesIn: aString 302864 "Search aString repeatedly for the matches of the receiver. Answer an OrderedCollection with an array of subexpressions per match." 302865 | result | 302866 result := OrderedCollection new. 302867 self 302868 submatchesOnStream: aString readStream 302869 do: [:subexprs | result add: subexprs]. 302870 ^result! ! 302871 302872!RxMatcher methodsFor: 'match enumeration' stamp: 'damien.pollet 5/3/2009 00:04'! 302873submatchesIn: aString collect: aBlock 302874 "Search aString repeatedly for the matches of the receiver. Evaluate aBlock for each match passing the collection of matched subexpressions as the argument, collecting evaluation results in an OrderedCollection." 302875 | result | 302876 result := OrderedCollection new. 302877 self 302878 submatchesOnStream: aString readStream 302879 do: [:subexprs | result add: (aBlock value: subexprs)]. 302880 ^result! ! 302881 302882!RxMatcher methodsFor: 'match enumeration' stamp: 'damien.pollet 5/3/2009 00:04'! 302883submatchesIn: aString do: aBlock 302884 "Search aString repeatedly for the matches of the receiver. 302885 Evaluate aBlock for each match passing the collection of matched subexpressions 302886 as the argument." 302887 self 302888 submatchesOnStream: aString readStream 302889 do: aBlock! ! 302890 302891!RxMatcher methodsFor: 'match enumeration' stamp: 'damien.pollet 5/2/2009 23:55'! 302892submatchesOnStream: aStream do: aBlock 302893 [self searchStream: aStream] whileTrue: 302894 [aBlock value: self subexpressions]! ! 302895 302896 302897!RxMatcher methodsFor: 'privileged'! 302898currentState 302899 "Answer an opaque object that can later be used to restore the 302900 matcher's state (for backtracking)." 302901 | origPosition origLastChar | 302902 origPosition := stream position. 302903 origLastChar := lastChar. 302904 ^ [stream position: origPosition. 302905 lastChar := origLastChar]! ! 302906 302907!RxMatcher methodsFor: 'privileged'! 302908markerPositionAt: anIndex 302909 ^markerPositions at: anIndex! ! 302910 302911!RxMatcher methodsFor: 'privileged'! 302912markerPositionAt: anIndex maybePut: position 302913 "Set position of the given marker, if not already set." 302914 (markerPositions at: anIndex) == nil 302915 ifTrue: [markerPositions at: anIndex put: position]! ! 302916 302917!RxMatcher methodsFor: 'privileged'! 302918restoreState: aBlock 302919 aBlock value! ! 302920 302921 302922!RxMatcher methodsFor: 'streaming'! 302923atEnd 302924 ^stream atEnd! ! 302925 302926!RxMatcher methodsFor: 'streaming'! 302927next 302928 lastChar := stream next. 302929 ^lastChar! ! 302930 302931!RxMatcher methodsFor: 'streaming'! 302932position 302933 ^stream position! ! 302934 302935 302936!RxMatcher methodsFor: 'testing'! 302937atBeginningOfLine 302938 ^self position = 0 or: [lastChar = Cr]! ! 302939 302940!RxMatcher methodsFor: 'testing'! 302941atBeginningOfWord 302942 ^(self isWordChar: lastChar) not 302943 and: [self isWordChar: stream peek]! ! 302944 302945!RxMatcher methodsFor: 'testing'! 302946atEndOfLine 302947 ^self atEnd or: [stream peek = Cr]! ! 302948 302949!RxMatcher methodsFor: 'testing'! 302950atEndOfWord 302951 ^(self isWordChar: lastChar) 302952 and: [(self isWordChar: stream peek) not]! ! 302953 302954!RxMatcher methodsFor: 'testing'! 302955atWordBoundary 302956 ^(self isWordChar: lastChar) 302957 xor: (self isWordChar: stream peek)! ! 302958 302959!RxMatcher methodsFor: 'testing'! 302960notAtWordBoundary 302961 ^self atWordBoundary not! ! 302962 302963!RxMatcher methodsFor: 'testing'! 302964supportsSubexpressions 302965 ^true! ! 302966 302967 302968!RxMatcher methodsFor: 'private'! 302969allocateMarker 302970 "Answer an integer to use as an index of the next marker." 302971 markerCount := markerCount + 1. 302972 ^markerCount! ! 302973 302974!RxMatcher methodsFor: 'private'! 302975hookBranchOf: regexNode onto: endMarker 302976 "Private - Recurse down the chain of regexes starting at 302977 regexNode, compiling their branches and hooking their tails 302978 to the endMarker node." 302979 | rest | 302980 rest := regexNode regex isNil 302981 ifTrue: [nil] 302982 ifFalse: [self hookBranchOf: regexNode regex onto: endMarker]. 302983 ^RxmBranch new 302984 next: ((regexNode branch dispatchTo: self) 302985 pointTailTo: endMarker; 302986 yourself); 302987 alternative: rest; 302988 yourself! ! 302989 302990!RxMatcher methodsFor: 'private'! 302991isWordChar: aCharacterOrNil 302992 "Answer whether the argument is a word constituent character: 302993 alphanumeric or :=." 302994 ^aCharacterOrNil ~~ nil 302995 and: [aCharacterOrNil isAlphaNumeric]! ! 302996 302997!RxMatcher methodsFor: 'private'! 302998makeOptional: aMatcher 302999 "Private - Wrap this matcher so that the result would match 0 or 1 303000 occurrences of the matcher." 303001 | dummy branch | 303002 dummy := RxmLink new. 303003 branch := (RxmBranch new beLoopback) 303004 next: aMatcher; 303005 alternative: dummy. 303006 aMatcher pointTailTo: dummy. 303007 ^branch! ! 303008 303009!RxMatcher methodsFor: 'private'! 303010makePlus: aMatcher 303011 "Private - Wrap this matcher so that the result would match 1 and more 303012 occurrences of the matcher." 303013 | loopback | 303014 loopback := (RxmBranch new beLoopback) 303015 next: aMatcher. 303016 aMatcher pointTailTo: loopback. 303017 ^aMatcher! ! 303018 303019!RxMatcher methodsFor: 'private'! 303020makeStar: aMatcher 303021 "Private - Wrap this matcher so that the result would match 0 and more 303022 occurrences of the matcher." 303023 | dummy detour loopback | 303024 dummy := RxmLink new. 303025 detour := RxmBranch new 303026 next: aMatcher; 303027 alternative: dummy. 303028 loopback := (RxmBranch new beLoopback) 303029 next: aMatcher; 303030 alternative: dummy. 303031 aMatcher pointTailTo: loopback. 303032 ^detour! ! 303033 303034!RxMatcher methodsFor: 'private'! 303035proceedSearchingStream: aStream 303036 | position | 303037 position := aStream position. 303038 [aStream atEnd] whileFalse: 303039 [self tryMatch ifTrue: [^true]. 303040 aStream position: position. 303041 lastChar := aStream next. 303042 position := aStream position]. 303043 "Try match at the very stream end too!!" 303044 self tryMatch ifTrue: [^true]. 303045 ^false! ! 303046 303047!RxMatcher methodsFor: 'private'! 303048tryMatch 303049 "Match thyself against the current stream." 303050 markerPositions := Array new: markerCount. 303051 startOptimizer == nil 303052 ifTrue: [lastResult := matcher matchAgainst: self] 303053 ifFalse: [lastResult := (startOptimizer canStartMatch: stream peek in: self) 303054 and: [matcher matchAgainst: self]]. 303055 ^lastResult! ! 303056 303057"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 303058 303059RxMatcher class 303060 instanceVariableNames: ''! 303061 303062!RxMatcher class methodsFor: 'class initialization' stamp: 'avi 11/30/2003 13:30'! 303063initialize 303064 "RxMatcher initialize" 303065 Cr := Character cr. 303066 Lf := Character lf.! ! 303067 303068 303069!RxMatcher class methodsFor: 'instance creation'! 303070for: aRegex 303071 "Create and answer a matcher that will match a regular expression 303072 specified by the syntax tree of which `aRegex' is a root." 303073 ^self for: aRegex ignoreCase: false! ! 303074 303075!RxMatcher class methodsFor: 'instance creation'! 303076for: aRegex ignoreCase: aBoolean 303077 "Create and answer a matcher that will match a regular expression 303078 specified by the syntax tree of which `aRegex' is a root." 303079 ^self new 303080 initialize: aRegex 303081 ignoreCase: aBoolean! ! 303082 303083!RxMatcher class methodsFor: 'instance creation'! 303084forString: aString 303085 "Create and answer a matcher that will match the regular expression 303086 `aString'." 303087 ^self for: (RxParser new parse: aString)! ! 303088 303089!RxMatcher class methodsFor: 'instance creation'! 303090forString: aString ignoreCase: aBoolean 303091 "Create and answer a matcher that will match the regular expression 303092 `aString'." 303093 ^self for: (RxParser new parse: aString) ignoreCase: aBoolean! ! 303094Object subclass: #RxParser 303095 instanceVariableNames: 'input lookahead' 303096 classVariableNames: 'BackslashConstants BackslashSpecials ExceptionObjects' 303097 poolDictionaries: '' 303098 category: 'VB-Regex'! 303099!RxParser commentStamp: '<historical>' prior: 0! 303100-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 303101-- See `documentation' protocol of RxParser class for user's guide. 303102-- 303103The regular expression parser. Translates a regular expression read from a stream into a parse tree. ('accessing' protocol). The tree can later be passed to a matcher initialization method. All other classes in this category implement the tree. Refer to their comments for any details. 303104Instance variables: 303105 input <Stream> A stream with the regular expression being parsed. 303106 lookahead <Character>! 303107 303108 303109!RxParser methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/2/2009 15:54'! 303110parse: aString 303111 "Parse input from a string <aString>. 303112 On success, answers an RxsRegex -- parse tree root. 303113 On error, raises `RxParser syntaxErrorSignal' with the current 303114 input stream position as the parameter." 303115 303116 ^self parseStream: aString readStream! ! 303117 303118!RxParser methodsFor: 'accessing'! 303119parseStream: aStream 303120 "Parse an input from a character stream <aStream>. 303121 On success, answers an RxsRegex -- parse tree root. 303122 On error, raises `RxParser syntaxErrorSignal' with the current 303123 input stream position as the parameter." 303124 | tree | 303125 input := aStream. 303126 lookahead := nil. 303127 self match: nil. 303128 tree := self regex. 303129 self match: #epsilon. 303130 ^tree! ! 303131 303132 303133!RxParser methodsFor: 'recursive descent'! 303134atom 303135 "An atom is one of a lot of possibilities, see below." 303136 | atom | 303137 (lookahead = #epsilon or: 303138 [lookahead = $| or: 303139 [lookahead = $) 303140 or: [lookahead = $* or: [lookahead = $+ or: [lookahead = $?]]]]]) 303141 ifTrue: [^RxsEpsilon new]. 303142 lookahead = $( ifTrue: 303143 ["<atom> ::= '(' <regex> ')' " 303144 self match: $(. 303145 atom := self regex. 303146 self match: $). 303147 ^atom]. 303148 lookahead = $[ ifTrue: 303149 ["<atom> ::= '[' <characterSet> ']' " 303150 self match: $[. 303151 atom := self characterSet. 303152 self match: $]. 303153 ^atom]. 303154 lookahead = $: ifTrue: 303155 ["<atom> ::= ':' <messagePredicate> ':' " 303156 self match: $:. 303157 atom := self messagePredicate. 303158 self match: $:. 303159 ^atom]. 303160 lookahead = $. ifTrue: 303161 ["any non-whitespace character" 303162 self next. 303163 ^RxsContextCondition new beAny]. 303164 lookahead = $^ ifTrue: 303165 ["beginning of line condition" 303166 self next. 303167 ^RxsContextCondition new beBeginningOfLine]. 303168 lookahead = $$ ifTrue: 303169 ["end of line condition" 303170 self next. 303171 ^RxsContextCondition new beEndOfLine]. 303172 lookahead = $\ ifTrue: 303173 ["<atom> ::= '\' <character>" 303174 self next. 303175 lookahead = #epsilon ifTrue: 303176 [self signalParseError: 'bad quotation']. 303177 (BackslashConstants includesKey: lookahead) ifTrue: 303178 [atom := RxsCharacter with: (BackslashConstants at: lookahead). 303179 self next. 303180 ^atom]. 303181 self ifSpecial: lookahead 303182 then: [:node | self next. ^node]]. 303183 "If passed through the above, the following is a regular character." 303184 atom := RxsCharacter with: lookahead. 303185 self next. 303186 ^atom! ! 303187 303188!RxParser methodsFor: 'recursive descent'! 303189branch 303190 "<branch> ::= e | <piece> <branch>" 303191 | piece branch | 303192 piece := self piece. 303193 (lookahead = #epsilon or: [lookahead = $| or: [lookahead = $) ]]) 303194 ifTrue: [branch := nil] 303195 ifFalse: [branch := self branch]. 303196 ^RxsBranch new 303197 initializePiece: piece 303198 branch: branch! ! 303199 303200!RxParser methodsFor: 'recursive descent'! 303201characterSet 303202 "Match a range of characters: something between `[' and `]'. 303203 Opening bracked has already been seen, and closing should 303204 not be consumed as well. Set spec is as usual for 303205 sets in regexes." 303206 | spec errorMessage | 303207 errorMessage := ' no terminating "]"'. 303208 spec := self inputUpTo: $] nestedOn: $[ errorMessage: errorMessage. 303209 (spec isEmpty or: [spec = '^']) ifTrue: "This ']' was literal." 303210 [self next. 303211 spec := spec, ']', (self inputUpTo: $] nestedOn: $[ errorMessage: errorMessage)]. 303212 ^self characterSetFrom: spec! ! 303213 303214!RxParser methodsFor: 'recursive descent'! 303215messagePredicate 303216 "Match a message predicate specification: a selector (presumably 303217 understood by a Character) enclosed in :'s ." 303218 | spec negated | 303219 spec := (self inputUpTo: $: errorMessage: ' no terminating ":"'). 303220 negated := false. 303221 spec first = $^ ifTrue: 303222 [negated := true. 303223 spec := spec copyFrom: 2 to: spec size]. 303224 ^RxsMessagePredicate new 303225 initializeSelector: spec asSymbol 303226 negated: negated! ! 303227 303228!RxParser methodsFor: 'recursive descent'! 303229piece 303230 "<piece> ::= <atom> | <atom>* | <atom>+ | <atom>?" 303231 | atom errorMessage | 303232 errorMessage := ' nullable closure'. 303233 atom := self atom. 303234 lookahead = $* ifTrue: 303235 [self next. 303236 atom isNullable ifTrue: [self signalParseError: errorMessage]. 303237 ^RxsPiece new initializeStarAtom: atom]. 303238 lookahead = $+ ifTrue: 303239 [self next. 303240 atom isNullable ifTrue: [self signalParseError: errorMessage]. 303241 ^RxsPiece new initializePlusAtom: atom]. 303242 lookahead = $? ifTrue: 303243 [self next. 303244 atom isNullable ifTrue: [self signalParseError: errorMessage]. 303245 ^RxsPiece new initializeOptionalAtom: atom]. 303246 ^RxsPiece new initializeAtom: atom! ! 303247 303248!RxParser methodsFor: 'recursive descent'! 303249regex 303250 "<regex> ::= e | <branch> `|' <regex>" 303251 | branch regex | 303252 branch := self branch. 303253 (lookahead = #epsilon or: [lookahead = $)]) 303254 ifTrue: [regex := nil] 303255 ifFalse: 303256 [self match: $|. 303257 regex := self regex]. 303258 ^RxsRegex new initializeBranch: branch regex: regex! ! 303259 303260 303261!RxParser methodsFor: 'private' stamp: 'PeterHugossonMiller 9/2/2009 15:53'! 303262characterSetFrom: setSpec 303263 "<setSpec> is what goes between the brackets in a charset regex 303264 (a String). Make a string containing all characters the spec specifies. 303265 Spec is never empty." 303266 | negated spec | 303267 spec := setSpec readStream. 303268 spec peek = $^ 303269 ifTrue: [negated := true. 303270 spec next] 303271 ifFalse: [negated := false]. 303272 ^RxsCharSet new 303273 initializeElements: (RxCharSetParser on: spec) parse 303274 negated: negated! ! 303275 303276!RxParser methodsFor: 'private'! 303277ifSpecial: aCharacter then: aBlock 303278 "If the character is such that it defines a special node when follows a $\, 303279 then create that node and evaluate aBlock with the node as the parameter. 303280 Otherwise just return." 303281 | classAndSelector | 303282 classAndSelector := BackslashSpecials at: aCharacter ifAbsent: [^self]. 303283 ^aBlock value: (classAndSelector key new perform: classAndSelector value)! ! 303284 303285!RxParser methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 11:08'! 303286inputUpTo: aCharacter errorMessage: aString 303287 "Accumulate input stream until <aCharacter> is encountered 303288 and answer the accumulated chars as String, not including 303289 <aCharacter>. Signal error if end of stream is encountered, 303290 passing <aString> as the error description." 303291 | accumulator | 303292 accumulator := (String new: 20) writeStream. 303293 [lookahead ~= aCharacter and: [lookahead ~= #epsilon]] 303294 whileTrue: 303295 [accumulator nextPut: lookahead. 303296 self next]. 303297 lookahead = #epsilon ifTrue: [self signalParseError: aString]. 303298 ^accumulator contents! ! 303299 303300!RxParser methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 11:08'! 303301inputUpTo: aCharacter nestedOn: anotherCharacter errorMessage: aString 303302 "Accumulate input stream until <aCharacter> is encountered 303303 and answer the accumulated chars as String, not including 303304 <aCharacter>. Signal error if end of stream is encountered, 303305 passing <aString> as the error description." 303306 | accumulator nestLevel | 303307 accumulator := (String new: 20) writeStream. 303308 nestLevel := 0. 303309 [lookahead ~= aCharacter or: [nestLevel > 0]] whileTrue: 303310 [#epsilon = lookahead ifTrue: [self signalParseError: aString]. 303311 accumulator nextPut: lookahead. 303312 lookahead = anotherCharacter ifTrue: [nestLevel := nestLevel + 1]. 303313 lookahead = aCharacter ifTrue: [nestLevel := nestLevel - 1]. 303314 self next]. 303315 ^accumulator contents! ! 303316 303317!RxParser methodsFor: 'private'! 303318match: aCharacter 303319 "<aCharacter> MUST match the current lookeahead. 303320 If this is the case, advance the input. Otherwise, blow up." 303321 aCharacter ~= lookahead 303322 ifTrue: [^self signalParseError]. "does not return" 303323 self next! ! 303324 303325!RxParser methodsFor: 'private'! 303326next 303327 "Advance the input storing the just read character 303328 as the lookahead." 303329 input atEnd 303330 ifTrue: [lookahead := #epsilon] 303331 ifFalse: [lookahead := input next]! ! 303332 303333!RxParser methodsFor: 'private'! 303334signalParseError 303335 self class signalSyntaxException: 'Regex syntax error'! ! 303336 303337!RxParser methodsFor: 'private'! 303338signalParseError: aString 303339 self class signalSyntaxException: aString! ! 303340 303341"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 303342 303343RxParser class 303344 instanceVariableNames: ''! 303345 303346!RxParser class methodsFor: 'DOCUMENTATION'! 303347a:x introduction:xx 303348" 303349A regular expression is a template specifying a class of strings. A 303350regular expression matcher is an tool that determines whether a string 303351belongs to a class specified by a regular expression. This is a 303352common task of a user input validation code, and the use of regular 303353expressions can GREATLY simplify and speed up development of such 303354code. As an example, here is how to verify that a string is a valid 303355hexadecimal number in Smalltalk notation, using this matcher package: 303356 aString matchesRegex: '16r[[:xdigit:]]+' 303357(Coding the same ``the hard way'' is an exercise to a curious reader). 303358This matcher is offered to the Smalltalk community in hope it will be 303359useful. It is free in terms of money, and to a large extent--in terms 303360of rights of use. Refer to `Boring Stuff' section for legalese. 303361The 'What's new in this release' section describes the functionality 303362introduced in 1.1 release. 303363The `Syntax' section explains the recognized syntax of regular 303364expressions. 303365The `Usage' section explains matcher capabilities that go beyond what 303366String>>matchesRegex: method offers. 303367The `Implementation notes' sections says a few words about what is 303368under the hood. 303369Happy hacking, 303370--Vassili Bykov 303371<vassili@objectpeople.com> <vassili@magma.ca> 303372August 6, 1996 303373April 4, 1999 303374" 303375 self error: 'comment only'! ! 303376 303377!RxParser class methodsFor: 'DOCUMENTATION'! 303378b:x whatsNewInThisRelease: xx 303379" 303380VERSION 1.1 (October 1999) 303381Regular expression syntax corrections and enhancements: 3033821. Backslash escapes similar to those in Perl are allowed in patterns: 303383 \w any word constituent character (equivalent to [a-zA-Z0-9:=]) 303384 \W any character but a word constituent (equivalent to [^a-xA-Z0-9:=] 303385 \d a digit (same as [0-9]) 303386 \D anything but a digit 303387 \s a whitespace character 303388 \S anything but a whitespace character 303389 \b an empty string at a word boundary 303390 \B an empty string not at a word boundary 303391 \< an empty string at the beginning of a word 303392 \> an empty string at the end of a word 303393For example, '\w+' is now a valid expression matching any word. 3033942. The following backslash escapes are also allowed in character sets 303395(between square brackets): 303396 \w, \W, \d, \D, \s, and \S. 3033973. The following grep(1)-compatible named character classes are 303398recognized in character sets as well: 303399 [:alnum:] 303400 [:alpha:] 303401 [:cntrl:] 303402 [:digit:] 303403 [:graph:] 303404 [:lower:] 303405 [:print:] 303406 [:punct:] 303407 [:space:] 303408 [:upper:] 303409 [:xdigit:] 303410For example, the following patterns are equivalent: 303411 '[[:alnum:]]+' '\w+' '[\w]+' '[a-zA-Z0-9:=]+' 3034124. Some non-printable characters can be represented in regular 303413expressions using a common backslash notation: 303414 \t tab (Character tab) 303415 \n newline (Character lf) 303416 \r carriage return (Character cr) 303417 \f form feed (Character newPage) 303418 \e escape (Character esc) 3034195. A dot is corectly interpreted as 'any character but a newline' 303420instead of 'anything but whitespace'. 3034216. Case-insensitive matching. The easiest access to it are new 303422messages CharacterArray understands: #asRegexIgnoringCase, 303423#matchesRegexIgnoringCase:, #prefixMatchesRegexIgnoringCase:. 3034247. The matcher (an instance of RxMatcher, the result of 303425String>>asRegex) now provides a collection-like interface to matches 303426in a particular string or on a particular stream, as well as 303427substitution protocol. The interface includes the following messages: 303428 matchesIn: aString 303429 matchesIn: aString collect: aBlock 303430 matchesIn: aString do: aBlock 303431 matchesOnStream: aStream 303432 matchesOnStream: aStream collect: aBlock 303433 matchesOnStream: aStream do: aBlock 303434 copy: aString translatingMatchesUsing: aBlock 303435 copy: aString replacingMatchesWith: replacementString 303436 copyStream: aStream to: writeStream translatingMatchesUsing: aBlock 303437 copyStream: aStream to: writeStream replacingMatchesWith: aString 303438Examples: 303439 '\w+' asRegex matchesIn: 'now is the time' 303440returns an OrderedCollection containing four strings: 'now', 'is', 303441'the', and 'time'. 303442 '\<t\w+' asRegexIgnoringCase 303443 copy: 'now is the Time' 303444 translatingMatchesUsing: [:match | match asUppercase] 303445returns 'now is THE TIME' (the regular expression matches words 303446beginning with either an uppercase or a lowercase T). 303447ACKNOWLEDGEMENTS 303448Since the first release of the matcher, thanks to the input from 303449several fellow Smalltalkers, I became convinced a native Smalltalk 303450regular expression matcher was worth the effort to keep it alive. For 303451the advice and encouragement that made this release possible, I want 303452to thank: 303453 Felix Hack 303454 Eliot Miranda 303455 Robb Shecter 303456 David N. Smith 303457 Francis Wolinski 303458and anyone whom I haven't yet met or heard from, but who agrees this 303459has not been a complete waste of time. 303460--Vassili Bykov 303461October 3, 1999 303462" 303463 self error: 'comment only'! ! 303464 303465!RxParser class methodsFor: 'DOCUMENTATION'! 303466c:x syntax:xx 303467" 303468[You can select and `print it' examples in this method. Just don't 303469forget to cancel the changes.] 303470The simplest regular expression is a single character. It matches 303471exactly that character. A sequence of characters matches a string with 303472exactly the same sequence of characters: 303473 'a' matchesRegex: 'a' -- true 303474 'foobar' matchesRegex: 'foobar' -- true 303475 'blorple' matchesRegex: 'foobar' -- false 303476The above paragraph introduced a primitive regular expression (a 303477character), and an operator (sequencing). Operators are applied to 303478regular expressions to produce more complex regular expressions. 303479Sequencing (placing expressions one after another) as an operator is, 303480in a certain sense, `invisible'--yet it is arguably the most common. 303481A more `visible' operator is Kleene closure, more often simply 303482referred to as `a star'. A regular expression followed by an asterisk 303483matches any number (including 0) of matches of the original 303484expression. For example: 303485 'ab' matchesRegex: 'a*b' -- true 303486 'aaaaab' matchesRegex: 'a*b' -- true 303487 'b' matchesRegex: 'a*b' -- true 303488 'aac' matchesRegex: 'a*b' -- false: b does not match 303489A star's precedence is higher than that of sequencing. A star applies 303490to the shortest possible subexpression that precedes it. For example, 303491'ab*' means `a followed by zero or more occurrences of b', not `zero 303492or more occurrences of ab': 303493 'abbb' matchesRegex: 'ab*' -- true 303494 'abab' matchesRegex: 'ab*' -- false 303495To actually make a regex matching `zero or more occurrences of ab', 303496`ab' is enclosed in parentheses: 303497 'abab' matchesRegex: '(ab)*' -- true 303498 'abcab' matchesRegex: '(ab)*' -- false: c spoils the fun 303499Two other operators similar to `*' are `+' and `?'. `+' (positive 303500closure, or simply `plus') matches one or more occurrences of the 303501original expression. `?' (`optional') matches zero or one, but never 303502more, occurrences. 303503 'ac' matchesRegex: 'ab*c' -- true 303504 'ac' matchesRegex: 'ab+c' -- false: need at least one b 303505 'abbc' matchesRegex: 'ab+c' -- true 303506 'abbc' matchesRegex: 'ab?c' -- false: too many b's 303507As we have seen, characters `*', `+', `?', `(', and `)' have special 303508meaning in regular expressions. If one of them is to be used 303509literally, it should be quoted: preceded with a backslash. (Thus, 303510backslash is also special character, and needs to be quoted for a 303511literal match--as well as any other special character described 303512further). 303513 'ab*' matchesRegex: 'ab*' -- false: star in the right string is special 303514 'ab*' matchesRegex: 'ab\*' -- true 303515 'a\c' matchesRegex: 'a\\c' -- true 303516The last operator is `|' meaning `or'. It is placed between two 303517regular expressions, and the resulting expression matches if one of 303518the expressions matches. It has the lowest possible precedence (lower 303519than sequencing). For example, `ab*|ba*' means `a followed by any 303520number of b's, or b followed by any number of a's': 303521 'abb' matchesRegex: 'ab*|ba*' -- true 303522 'baa' matchesRegex: 'ab*|ba*' -- true 303523 'baab' matchesRegex: 'ab*|ba*' -- false 303524A bit more complex example is the following expression, matching the 303525name of any of the Lisp-style `car', `cdr', `caar', `cadr', 303526... functions: 303527 c(a|d)+r 303528It is possible to write an expression matching an empty string, for 303529example: `a|'. However, it is an error to apply `*', `+', or `?' to 303530such expression: `(a|)*' is an invalid expression. 303531So far, we have used only characters as the 'smallest' components of 303532regular expressions. There are other, more `interesting', components. 303533A character set is a string of characters enclosed in square 303534brackets. It matches any single character if it appears between the 303535brackets. For example, `[01]' matches either `0' or `1': 303536 '0' matchesRegex: '[01]' -- true 303537 '3' matchesRegex: '[01]' -- false 303538 '11' matchesRegex: '[01]' -- false: a set matches only one character 303539Using plus operator, we can build the following binary number 303540recognizer: 303541 '10010100' matchesRegex: '[01]+' -- true 303542 '10001210' matchesRegex: '[01]+' -- false 303543If the first character after the opening bracket is `^', the set is 303544inverted: it matches any single character *not* appearing between the 303545brackets: 303546 '0' matchesRegex: '[^01]' -- false 303547 '3' matchesRegex: '[^01]' -- true 303548For convenience, a set may include ranges: pairs of characters 303549separated with `-'. This is equivalent to listing all characters 303550between them: `[0-9]' is the same as `[0123456789]'. 303551Special characters within a set are `^', `-', and `]' that closes the 303552set. Below are the examples of how to literally use them in a set: 303553 [01^] -- put the caret anywhere except the beginning 303554 [01-] -- put the dash as the last character 303555 []01] -- put the closing bracket as the first character 303556 [^]01] (thus, empty and universal sets cannot be specified) 303557Regular expressions can also include the following backquote escapes 303558to refer to popular classes of characters: 303559 \w any word constituent character (same as [a-zA-Z0-9:=]) 303560 \W any character but a word constituent 303561 \d a digit (same as [0-9]) 303562 \D anything but a digit 303563 \s a whitespace character 303564 \S anything but a whitespace character 303565These escapes are also allowed in character classes: '[\w+-]' means 303566'any character that is either a word constituent, or a plus, or a 303567minus'. 303568Character classes can also include the following grep(1)-compatible 303569elements to refer to: 303570 [:alnum:] any alphanumeric, i.e., a word constituent, character 303571 [:alpha:] any alphabetic character 303572 [:cntrl:] any control character. In this version, it means any character which code is < 32. 303573 [:digit:] any decimal digit. 303574 [:graph:] any graphical character. In this version, this mean any character with the code >= 32. 303575 [:lower:] any lowercase character 303576 [:print:] any printable character. In this version, this is the same as [:cntrl:] 303577 [:punct:] any punctuation character. 303578 [:space:] any whitespace character. 303579 [:upper:] any uppercase character. 303580 [:xdigit:] any hexadecimal character. 303581Note that these elements are components of the character classes, 303582i.e. they have to be enclosed in an extra set of square brackets to 303583form a valid regular expression. For example, a non-empty string of 303584digits would be represented as '[[:digit:]]+'. 303585The above primitive expressions and operators are common to many 303586implementations of regular expressions. The next primitive expression 303587is unique to this Smalltalk implementation. 303588A sequence of characters between colons is treated as a unary selector 303589which is supposed to be understood by Characters. A character matches 303590such an expression if it answers true to a message with that 303591selector. This allows a more readable and efficient way of specifying 303592character classes. For example, `[0-9]' is equivalent to `:isDigit:', 303593but the latter is more efficient. Analogously to character sets, 303594character classes can be negated: `:^isDigit:' matches a Character 303595that answers false to #isDigit, and is therefore equivalent to 303596`[^0-9]'. 303597As an example, so far we have seen the following equivalent ways to 303598write a regular expression that matches a non-empty string of digits: 303599 '[0-9]+' 303600 '\d+' 303601 '[\d]+' 303602 '[[:digit::]+' 303603 :isDigit:+' 303604The last group of special primitive expressions includes: 303605 . matching any character except a newline; 303606 ^ matching an empty string at the beginning of a line; 303607 $ matching an empty string at the end of a line. 303608 \b an empty string at a word boundary 303609 \B an empty string not at a word boundary 303610 \< an empty string at the beginning of a word 303611 \> an empty string at the end of a word 303612 'axyzb' matchesRegex: 'a.+b' -- true 303613 'ax zb' matchesRegex: 'a.+b' -- false (space is not matched by `.') 303614Again, all the above three characters are special and should be quoted 303615to be matched literally. 303616 EXAMPLES 303617As the introductions said, a great use for regular expressions is user 303618input validation. Following are a few examples of regular expressions 303619that might be handy in checking input entered by the user in an input 303620field. Try them out by entering something between the quotes and 303621print-iting. (Also, try to imagine Smalltalk code that each validation 303622would require if coded by hand). Most example expressions could have 303623been written in alternative ways. 303624Checking if aString may represent a nonnegative integer number: 303625 '' matchesRegex: ':isDigit:+' 303626or 303627 '' matchesRegex: '[0-9]+' 303628or 303629 '' matchesRegex: '\d+' 303630Checking if aString may represent an integer number with an optional 303631sign in front: 303632 '' matchesRegex: '(\+|-)?\d+' 303633Checking if aString is a fixed-point number, with at least one digit 303634is required after a dot: 303635 '' matchesRegex: '(\+|-)?\d+(\.\d+)?' 303636The same, but allow notation like `123.': 303637 '' matchesRegex: '(\+|-)?\d+(\.\d*)?' 303638Recognizer for a string that might be a name: one word with first 303639capital letter, no blanks, no digits. More traditional: 303640 '' matchesRegex: '[A-Z][A-Za-z]*' 303641more Smalltalkish: 303642 '' matchesRegex: ':isUppercase::isAlphabetic:*' 303643A date in format MMM DD, YYYY with any number of spaces in between, in 303644XX century: 303645 '' matchesRegex: '(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ]+(\d\d?)[ ]*,[ ]*19(\d\d)' 303646Note parentheses around some components of the expression above. As 303647`Usage' section shows, they will allow us to obtain the actual strings 303648that have matched them (i.e. month name, day number, and year number). 303649For dessert, coming back to numbers: here is a recognizer for a 303650general number format: anything like 999, or 999.999, or -999.999e+21. 303651 '' matchesRegex: '(\+|-)?\d+(\.\d*)?((e|E)(\+|-)?\d+)?' 303652" 303653 self error: 'comment only'! ! 303654 303655!RxParser class methodsFor: 'DOCUMENTATION' stamp: 'sd 1/14/2008 10:22'! 303656d:x usage:xx 303657" 303658The preceding section covered the syntax of regular expressions. It 303659used the simplest possible interface to the matcher: sending 303660#matchesRegex: message to the sample string, with regular expression 303661string as the argument. This section explains hairier ways of using 303662the matcher. 303663 PREFIX MATCHING AND CASE-INSENSITIVE MATCHING 303664A CharacterArray (an EsString in VA) also understands these messages: 303665 #prefixMatchesRegex: regexString 303666 #matchesRegexIgnoringCase: regexString 303667 #prefixMatchesRegexIgnoringCase: regexString 303668#prefixMatchesRegex: is just like #matchesRegex, except that the whole 303669receiver is not expected to match the regular expression passed as the 303670argument; matching just a prefix of it is enough. For example: 303671 'abcde' matchesRegex: '(a|b)+' -- false 303672 'abcde' prefixMatchesRegex: '(a|b)+' -- true 303673The last two messages are case-insensitive versions of matching. 303674 ENUMERATION INTERFACE 303675An application can be interested in all matches of a certain regular 303676expression within a String. The matches are accessible using a 303677protocol modelled after the familiar Collection-like enumeration 303678protocol: 303679 #regex: regexString matchesDo: aBlock 303680Evaluates a one-argument <aBlock> for every match of the regular 303681expression within the receiver string. 303682 #regex: regexString matchesCollect: aBlock 303683Evaluates a one-argument <aBlock> for every match of the regular 303684expression within the receiver string. Collects results of evaluations 303685and anwers them as a SequenceableCollection. 303686 #allRegexMatches: regexString 303687Returns a collection of all matches (substrings of the receiver 303688string) of the regular expression. It is an equivalent of <aString 303689regex: regexString matchesCollect: [:each | each]>. 303690 REPLACEMENT AND TRANSLATION 303691It is possible to replace all matches of a regular expression with a 303692certain string using the message: 303693 #copyWithRegex: regexString matchesReplacedWith: aString 303694For example: 303695 'ab cd ab' copyWithRegex: '(a|b)+' matchesReplacedWith: 'foo' 303696A more general substitution is match translation: 303697 #copyWithRegex: regexString matchesTranslatedUsing: aBlock 303698This message evaluates a block passing it each match of the regular 303699expression in the receiver string and answers a copy of the receiver 303700with the block results spliced into it in place of the respective 303701matches. For example: 303702 'ab cd ab' copyWithRegex: '(a|b)+' matchesTranslatedUsing: [:each | each asUppercase] 303703All messages of enumeration and replacement protocols perform a 303704case-sensitive match. Case-insensitive versions are not provided as 303705part of a CharacterArray protocol. Instead, they are accessible using 303706the lower-level matching interface. 303707 LOWER-LEVEL INTERFACE 303708Internally, #matchesRegex: works as follows: 3037091. A fresh instance of RxParser is created, and the regular expression 303710string is passed to it, yielding the expression's syntax tree. 3037112. The syntax tree is passed as an initialization parameter to an 303712instance of RxMatcher. The instance sets up some data structure that 303713will work as a recognizer for the regular expression described by the 303714tree. 3037153. The original string is passed to the matcher, and the matcher 303716checks for a match. 303717 THE MATCHER 303718If you repeatedly match a number of strings against the same regular 303719expression using one of the messages defined in CharacterArray, the 303720regular expression string is parsed and a matcher is created anew for 303721every match. You can avoid this overhead by building a matcher for 303722the regular expression, and then reusing the matcher over and over 303723again. You can, for example, create a matcher at a class or instance 303724initialization stage, and store it in a variable for future use. 303725You can create a matcher using one of the following methods: 303726 - Sending #forString:ignoreCase: message to RxMatcher class, with 303727the regular expression string and a Boolean indicating whether case is 303728ignored as arguments. 303729 - Sending #forString: message. It is equivalent to <... forString: 303730regexString ignoreCase: false>. 303731A more convenient way is using one of the two matcher-created messages 303732understood by CharacterArray. 303733 - <regexString asRegex> is equivalent to <RxMatcher forString: 303734regexString>. 303735 - <regexString asRegexIgnoringCase> is equivalent to <RxMatcher 303736forString: regexString ignoreCase: true>. 303737Here are four examples of creating a matcher: 303738 hexRecognizer := RxMatcher forString: '16r[0-9A-Fa-f]+' 303739 hexRecognizer := RxMatcher forString: '16r[0-9A-Fa-f]+' ignoreCase: false 303740 hexRecognizer := '16r[0-9A-Fa-f]+' asRegex 303741 hexRecognizer := '16r[0-9A-F]+' asRegexIgnoringCase 303742 MATCHING 303743The matcher understands these messages (all of them return true to 303744indicate successful match or search, and false otherwise): 303745matches: aString 303746 True if the whole target string (aString) matches. 303747matchesPrefix: aString 303748 True if some prefix of the string (not necessarily the whole 303749 string) matches. 303750search: aString 303751 Search the string for the first occurrence of a matching 303752 substring. (Note that the first two methods only try matching from 303753 the very beginning of the string). Using the above example with a 303754 matcher for `a+', this method would answer success given a string 303755 `baaa', while the previous two would fail. 303756matchesStream: aStream 303757matchesStreamPrefix: aStream 303758searchStream: aStream 303759 Respective analogs of the first three methods, taking input from a 303760 stream instead of a string. The stream must be positionable and 303761 peekable. 303762All these methods answer a boolean indicating success. The matcher 303763also stores the outcome of the last match attempt and can report it: 303764lastResult 303765 Answers a Boolean -- the outcome of the most recent match 303766 attempt. If no matches were attempted, the answer is unspecified. 303767 SUBEXPRESSION MATCHES 303768After a successful match attempt, you can query the specifics of which 303769part of the original string has matched which part of the whole 303770expression. 303771A subexpression is a parenthesized part of a regular expression, or 303772the whole expression. When a regular expression is compiled, its 303773subexpressions are assigned indices starting from 1, depth-first, 303774left-to-right. For example, `((ab)+(c|d))?ef' includes the following 303775subexpressions with these indices: 303776 1: ((ab)+(c|d))?ef 303777 2: (ab)+(c|d) 303778 3: ab 303779 4: c|d 303780After a successful match, the matcher can report what part of the 303781original string matched what subexpression. It understandards these 303782messages: 303783subexpressionCount 303784 Answers the total number of subexpressions: the highest value that 303785 can be used as a subexpression index with this matcher. This value 303786 is available immediately after initialization and never changes. 303787subexpression: anIndex 303788 An index must be a valid subexpression index, and this message 303789 must be sent only after a successful match attempt. The method 303790 answers a substring of the original string the corresponding 303791 subexpression has matched to. 303792subBeginning: anIndex 303793subEnd: anIndex 303794 Answer positions within the original string or stream where the 303795 match of a subexpression with the given index has started and 303796 ended, respectively. 303797This facility provides a convenient way of extracting parts of input 303798strings of complex format. For example, the following piece of code 303799uses the 'MMM DD, YYYY' date format recognizer example from the 303800`Syntax' section to convert a date to a three-element array with year, 303801month, and day strings (you can select and evaluate it right here): 303802 | matcher | 303803 matcher := RxMatcher forString: '(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ]+(:isDigit::isDigit:?)[ ]*,[ ]*19(:isDigit::isDigit:)'. 303804 (matcher matches: 'Aug 6, 1996') 303805 ifTrue: 303806 [Array 303807 with: (matcher subexpression: 4) 303808 with: (matcher subexpression: 2) 303809 with: (matcher subexpression: 3)] 303810 ifFalse: ['no match'] 303811(should answer ` #('96' 'Aug' '6')'). 303812 ENUMERATION AND REPLACEMENT 303813The enumeration and replacement protocols exposed in CharacterArray 303814are actually implemented by the mather. The following messages are 303815understood: 303816 #matchesIn: aString 303817 #matchesIn: aString do: aBlock 303818 #matchesIn: aString collect: aBlock 303819 #copy: aString replacingMatchesWith: replacementString 303820 #copy: aString translatingMatchesUsing: aBlock 303821 #matchesOnStream: aStream 303822 #matchesOnStream: aStream do: aBlock 303823 #matchesOnStream: aStream collect: aBlock 303824 #copy: sourceStream to: targetStream replacingMatchesWith: replacementString 303825 #copy: sourceStream to: targetStream translatingMatchesWith: aBlock 303826 ERROR HANDLING 303827Exception signaling objects (Signals in VisualWorks, Exceptions in VisualAge) are 303828accessible through RxParser class protocol. To handle possible errors, use 303829the protocol described below to obtain the exception objects and use the 303830protocol of the native Smalltalk implementation to handle them. 303831If a syntax error is detected while parsing expression, 303832RxParser>>syntaxErrorSignal is raised/signaled. 303833If an error is detected while building a matcher, 303834RxParser>>compilationErrorSignal is raised/signaled. 303835If an error is detected while matching (for example, if a bad selector 303836was specified using `:<selector>:' syntax, or because of the matcher's 303837internal error), RxParser>>matchErrorSignal is raised 303838RxParser>>regexErrorSignal is the parent of all three. Since any of 303839the three signals can be raised within a call to #matchesRegex:, it is 303840handy if you want to catch them all. For example: 303841VisualWorks: 303842 RxParser regexErrorSignal 303843 handle: [:ex | ex returnWith: nil] 303844 do: ['abc' matchesRegex: '))garbage['] 303845VisualAge: 303846 ['abc' matchesRegex: '))garbage['] 303847 when: RxParser regexErrorSignal 303848 do: [:signal | signal exitWith: nil] 303849" 303850 self error: 'comment only'! ! 303851 303852!RxParser class methodsFor: 'DOCUMENTATION'! 303853e:x implementationNotes:xx 303854" 303855 Version: 1.1 303856 Released: October 1999 303857 Mail to: Vassili Bykov <vassili@magma.ca>, <vassili@objectpeople.com> 303858 Flames to: /dev/null 303859 WHAT IS ADDED 303860The matcher includes classes in two categories: 303861 VB-Regex-Syntax 303862 VB-Regex-Matcher 303863and a few CharacterArray methods in `VB-regex' protocol. No system 303864classes or methods are modified. 303865 WHAT TO LOOK AT FIRST 303866String>>matchesRegex: -- in 90% cases this method is all you need to 303867access the package. 303868RxParser -- accepts a string or a stream of characters with a regular 303869expression, and produces a syntax tree corresponding to the 303870expression. The tree is made of instances of Rxs<whatever> classes. 303871RxMatcher -- accepts a syntax tree of a regular expression built by 303872the parser and compiles it into a matcher: a structure made of 303873instances of Rxm<whatever> classes. The RxMatcher instance can test 303874whether a string or a positionable stream of characters matches the 303875original regular expression, or search a string or a stream for 303876substrings matching the expression. After a match is found, the 303877matcher can report a specific string that matched the whole 303878expression, or any parenthesized subexpression of it. 303879All other classes support the above functionality and are used by 303880RxParser, RxMatcher, or both. 303881 CAVEATS 303882The matcher is similar in spirit, but NOT in the design--let alone the 303883code--to the original Henry Spencer's regular expression 303884implementation in C. The focus is on simplicity, not on efficiency. 303885I didn't optimize or profile anything. I may in future--or I may not: 303886I do this in my spare time and I don't promise anything. 303887The matcher passes H. Spencer's test suite (see 'test suite' 303888protocol), with quite a few extra tests added, so chances are good 303889there are not too many bugs. But watch out anyway. 303890 EXTENSIONS, FUTURE, ETC. 303891With the existing separation between the parser, the syntax tree, and 303892the matcher, it is easy to extend the system with other matchers based 303893on other algorithms. In fact, I have a DFA-based matcher right now, 303894but I don't feel it is good enough to include it here. I might add 303895automata-based matchers later, but again I don't promise anything. 303896 HOW TO REACH ME 303897As of today (October 3, 1999), you can contact me at 303898<vassili@objectpeople.com>. If this doesn't work, look around 303899comp.lang.smalltalk and comp.lang.lisp. 303900" 303901 self error: 'comment only'! ! 303902 303903!RxParser class methodsFor: 'DOCUMENTATION'! 303904f:x boringStuff: xx 303905" 303906The Regular Expression Matcher (``The Software'') 303907is Copyright (C) 1996, 1999 Vassili Bykov. 303908It is provided to the Smalltalk community in hope it will be useful. 3039091. This license applies to the package as a whole, as well as to any 303910 component of it. By performing any of the activities described 303911 below, you accept the terms of this agreement. 3039122. The software is provided free of charge, and ``as is'', in hope 303913 that it will be useful, with ABSOLUTELY NO WARRANTY. The entire 303914 risk and all responsibility for the use of the software is with 303915 you. Under no circumstances the author may be held responsible for 303916 loss of data, loss of profit, or any other damage resulting 303917 directly or indirectly from the use of the software, even if the 303918 damage is caused by defects in the software. 3039193. You may use this software in any applications you build. 3039204. You may distribute this software provided that the software 303921 documentation and copyright notices are included and intact. 3039225. You may create and distribute modified versions of the software, 303923 such as ports to other Smalltalk dialects or derived work, provided 303924 that: 303925 a. any modified version is expressly marked as such and is not 303926 misrepresented as the original software; 303927 b. credit is given to the original software in the source code and 303928 documentation of the derived work; 303929 c. the copyright notice at the top of this document accompanies 303930 copyright notices of any modified version. " 303931 self error: 'comment only'! ! 303932 303933 303934!RxParser class methodsFor: 'class initialization' stamp: 'avi 11/30/2003 13:26'! 303935initialize 303936 "self initialize" 303937 self 303938 initializeBackslashConstants; 303939 initializeBackslashSpecials! ! 303940 303941!RxParser class methodsFor: 'class initialization' stamp: 'avi 11/30/2003 13:27'! 303942initializeBackslashConstants 303943 "self initializeBackslashConstants" 303944 (BackslashConstants := Dictionary new) 303945 at: $e put: Character escape; 303946 at: $n put: Character lf; 303947 at: $r put: Character cr; 303948 at: $f put: Character newPage; 303949 at: $t put: Character tab! ! 303950 303951!RxParser class methodsFor: 'class initialization'! 303952initializeBackslashSpecials 303953 "Keys are characters that normally follow a \, the values are 303954 associations of classes and initialization selectors on the instance side 303955 of the classes." 303956 "self initializeBackslashSpecials" 303957 (BackslashSpecials := Dictionary new) 303958 at: $w put: (Association key: RxsPredicate value: #beWordConstituent); 303959 at: $W put: (Association key: RxsPredicate value: #beNotWordConstituent); 303960 at: $s put: (Association key: RxsPredicate value: #beSpace); 303961 at: $S put: (Association key: RxsPredicate value: #beNotSpace); 303962 at: $d put: (Association key: RxsPredicate value: #beDigit); 303963 at: $D put: (Association key: RxsPredicate value: #beNotDigit); 303964 at: $b put: (Association key: RxsContextCondition value: #beWordBoundary); 303965 at: $B put: (Association key: RxsContextCondition value: #beNonWordBoundary); 303966 at: $< put: (Association key: RxsContextCondition value: #beBeginningOfWord); 303967 at: $> put: (Association key: RxsContextCondition value: #beEndOfWord)! ! 303968 303969 303970!RxParser class methodsFor: 'exception signaling' stamp: 'avi 11/30/2003 13:24'! 303971doHandlingMessageNotUnderstood: aBlock 303972 "MNU should be trapped and resignaled as a match error in a few places in the matcher. 303973 This method factors out this dialect-dependent code to make porting easier." 303974 ^ aBlock 303975 on: MessageNotUnderstood 303976 do: [:ex | RxMatcher signalMatchException: 'invalid predicate selector']! ! 303977 303978!RxParser class methodsFor: 'exception signaling' stamp: 'avi 11/30/2003 13:25'! 303979signalCompilationException: errorString 303980 RegexCompilationError new signal: errorString! ! 303981 303982!RxParser class methodsFor: 'exception signaling' stamp: 'avi 11/30/2003 13:25'! 303983signalMatchException: errorString 303984 RegexMatchingError new signal: errorString! ! 303985 303986!RxParser class methodsFor: 'exception signaling' stamp: 'avi 11/30/2003 13:25'! 303987signalSyntaxException: errorString 303988 RegexSyntaxError new signal: errorString! ! 303989 303990 303991!RxParser class methodsFor: 'preferences'! 303992preferredMatcherClass 303993 "The matcher to use. For now just one is available, but in 303994 principle this determines the matchers built implicitly, 303995 such as by String>>asRegex, or String>>matchesRegex:. 303996 This might seem a bit strange place for this preference, but 303997 Parser is still more or less `central' thing in the whole package." 303998 ^RxMatcher! ! 303999 304000 304001!RxParser class methodsFor: 'test suite'! 304002compileRegex: regexSource into: matcherClass 304003 "Compile the regex and answer the matcher, or answer nil if compilation fails." 304004 | syntaxTree | 304005 syntaxTree := self safelyParse: regexSource. 304006 syntaxTree == nil ifTrue: [^nil]. 304007 ^matcherClass for: syntaxTree! ! 304008 304009!RxParser class methodsFor: 'test suite'! 304010runProtocolTestsForMatcher: matcherClass 304011 | matcher | 304012 Transcript show: 'Testing matcher protocol...'. 304013 matcher := matcherClass forString: '\w+'. 304014 (matcher matchesIn: 'now is the time') asArray = #('now' 'is' 'the' 'time') 304015 ifFalse: [self error: 'matchesIn: test failed']. 304016 (matcher copy: 'now is the time ' translatingMatchesUsing: [:s | s reverse]) 304017 = 'won si eht emit ' 304018 ifFalse: [self error: 'copy:translatingMatchesWith: test failed']. 304019 "See that the match context is preserved while copying stuff between matches:" 304020 ((matcherClass forString: '\<\d\D+') 304021 copy: '9aaa1bbb 8ccc' 304022 replacingMatchesWith: 'foo') = 'foo1bbb foo' 304023 ifFalse: [self error: 'test failed']. 304024 Transcript show: 'OK'; cr! ! 304025 304026!RxParser class methodsFor: 'test suite'! 304027runRegexTestsForMatcher: matcherClass 304028 "Run the whole suite of tests for the given matcher class. May blow up 304029 if anything goes wrong with the matcher or parser. Since this is a 304030 developer's tool, who cares?" 304031 "self runRegexTestsForMatcher: RxMatcher" 304032 | failures | 304033 failures := 0. 304034 Transcript cr. 304035 self testSuite do: [:clause | 304036 | rxSource matcher isOK | 304037 rxSource := clause first. 304038 Transcript show: 'Testing regex: '; show: rxSource printString; cr. 304039 matcher := self compileRegex: rxSource into: matcherClass. 304040 matcher == nil 304041 ifTrue: 304042 [(clause at: 2) isNil 304043 ifTrue: 304044 [Transcript tab; show: 'Compilation error as expected (ok)'; cr] 304045 ifFalse: 304046 [Transcript tab; 304047 show: 'Compilation error, UNEXPECTED -- FAILED'; cr. 304048 failures := failures + 1]] 304049 ifFalse: 304050 [(clause at: 2) == nil 304051 ifTrue: 304052 [Transcript tab; 304053 show: 'Compilation succeeded, should have failed -- FAILED!!'; 304054 cr. 304055 failures := failures + 1] 304056 ifFalse: 304057 [2 to: clause size by: 3 do: 304058 [:i | 304059 isOK := self 304060 test: matcher 304061 with: (clause at: i) 304062 expect: (clause at: i + 1) 304063 withSubexpressions: (clause at: i + 2). 304064 isOK ifFalse: [failures := failures + 1]. 304065 Transcript 304066 show: (isOK ifTrue: [' (ok).'] ifFalse: [' -- FAILED!!']); 304067 cr]]]]. 304068 failures = 0 304069 ifTrue: [Transcript show: 'PASSED ALL TESTS.'; cr] 304070 ifFalse: [Transcript show: failures printString, ' TESTS FAILED!!'; cr]! ! 304071 304072!RxParser class methodsFor: 'test suite'! 304073runTestsForMatcher: matcherClass 304074 "Run the whole suite of tests for the given matcher class. May blow up 304075 if something goes wrong with the matcher or the parser. Since this is a 304076 developer's tool, who cares?" 304077 "self runTestsForMatcher: RxMatcher" 304078 self 304079 runRegexTestsForMatcher: matcherClass; 304080 runProtocolTestsForMatcher: matcherClass! ! 304081 304082!RxParser class methodsFor: 'test suite' stamp: 'stephane.ducasse 4/13/2009 20:32'! 304083test: aMatcher with: testString expect: expected withSubexpressions: subexpr 304084 | got | 304085 Transcript tab; 304086 show: 'Matching: '; 304087 show: testString printString; 304088 show: ' expected: '; 304089 show: expected printString; 304090 show: ' got: '. 304091 got := aMatcher search: testString. 304092 Transcript show: got printString. 304093 got asString ~= expected asString 304094 ifTrue: [^false]. 304095 (subexpr ~= nil and: [aMatcher supportsSubexpressions]) 304096 ifFalse: 304097 [^true] 304098 ifTrue: 304099 [ | isOK | 304100 isOK := true. 304101 1 to: subexpr size by: 2 do: [:i | 304102 | sub subExpect subGot | 304103 sub := subexpr at: i. 304104 subExpect := subexpr at: i + 1. 304105 subGot := aMatcher subexpression: sub. 304106 Transcript cr; tab; tab; 304107 show: 'Subexpression: ', sub printString; 304108 show: ' expected: '; 304109 show: subExpect printString; 304110 show: ' got: '; 304111 show: subGot printString. 304112 subExpect ~= subGot 304113 ifTrue: 304114 [Transcript show: ' -- MISMATCH'. 304115 isOK := false]]. 304116 ^isOK]! ! 304117 304118!RxParser class methodsFor: 'test suite'! 304119testSuite 304120 "Answer an array of test clauses. Each clause is an array with a regex source 304121 string followed by sequence of 3-tuples. Each three-element 304122 group is one test to try against the regex, and includes: 1) test string; 304123 2) expected result; 3) expected subexpression as an array of (index, substring), 304124 or nil. 304125 The test suite is based on the one in Henry Spencer's regexp.c package." 304126 ^#( 304127 ('abc' 304128 'abc' true (1 'abc') 304129 'xbc' false nil 304130 'axc' false nil 304131 'abx' false nil 304132 'xabcy' true (1 'abc') 304133 'ababc' true (1 'abc')) 304134 ('ab*c' 304135 'abc' true (1 'abc')) 304136 ('ab*bc' 304137 'abc' true (1 'abc') 304138 'abbc' true (1 'abbc') 304139 'abbbbc' true (1 'abbbbc')) 304140 ('ab+bc' 304141 'abbc' true (1 'abbc') 304142 'abc' false nil 304143 'abq' false nil 304144 'abbbbc' true (1 'abbbbc')) 304145 ('ab?bc' 304146 'abbc' true (1 'abbc') 304147 'abc' true (1 'abc') 304148 'abbbbc' false nil 304149 'abc' true (1 'abc')) 304150 ('^abc$' 304151 'abc' true (1 'abc') 304152 'abcc' false nil 304153 'aabc' false nil) 304154 ('^abc' 304155 'abcc' true (1 'abc')) 304156 ('abc$' 304157 'aabc' true (1 'abc')) 304158 ('^' 304159 'abc' true nil) 304160 ('$' 304161 'abc' true nil) 304162 ('a.c' 304163 'abc' true (1 'abc') 304164 'axc' true (1 'axc')) 304165 ('a.*c' 304166 'axyzc' true (1 'axyzc') 304167 'axy zc' true (1 'axy zc') "testing that a dot matches a space" 304168 'axy 304169 zc' false nil "testing that a dot does not match a newline" 304170 'axyzd' false nil) 304171 ('.a.*' 304172 '1234abc' true (1 '4abc') 304173 'abcd' false nil) 304174 ('a\w+c' 304175 ' abbbbc ' true (1 'abbbbc') 304176 'abb bc' false nil) 304177 ('\w+' 304178 ' foobar quux' true (1 'foobar') 304179 ' ~!!@#$%^&*()-+=\|/?.>,<' false nil) 304180 ('a\W+c' 304181 'a c' true (1 'a c') 304182 'a bc' false nil) 304183 ('\W+' 304184 'foo!!@#$bar' true (1 '!!@#$') 304185 'foobar' false nil) 304186 ('a\s*c' 304187 'a c' true (1 'a c') 304188 'a bc' false nil) 304189 ('\s+' 304190 'abc3457 sd' true (1 ' ') 304191 '1234$^*^&asdfb' false nil) 304192 ('a\S*c' 304193 'aqwertyc' true (1 'aqwertyc') 304194 'ab c' false nil) 304195 ('\S+' 304196 ' asdf ' true (1 'asdf') 304197 ' 304198 ' false nil) 304199 ('a\d+c' 304200 'a0123456789c' true (1 'a0123456789c') 304201 'a12b34c' false nil) 304202 ('\d+' 304203 'foo@#$%123ASD #$$%^&' true (1 '123') 304204 'foo!!@#$asdfl;' false nil) 304205 ('a\D+c' 304206 'aqwertyc' true (1 'aqwertyc') 304207 'aqw6ertc' false nil) 304208 ('\D+' 304209 '1234 abc 456' true (1 ' abc ') 304210 '1234567890' false nil) 304211 ('(f|o)+\b' 304212 'foo' true (1 'foo') 304213 ' foo ' true (1 'foo')) 304214 ('\ba\w+' "a word beginning with an A" 304215 'land ancient' true (1 'ancient') 304216 'antique vase' true (1 'antique') 304217 'goofy foobar' false nil) 304218 ('(f|o)+\B' 304219 'quuxfoobar' true (1 'foo') 304220 'quuxfoo ' true (1 'fo')) 304221 ('\Ba\w+' "a word with an A in the middle, match at A and further" 304222 'land ancient' true (1 'and') 304223 'antique vase' true (1 'ase') 304224 'smalltalk shall overcome' true (1 'alltalk') 304225 'foonix is better' false nil) 304226 ('fooa\>.*' 304227 'fooa ' true nil 304228 'fooa123' false nil 304229 'fooa bar' true nil 304230 'fooa' true nil 304231 'fooargh' false nil) 304232 ('\>.+abc' 304233 ' abcde fg' false nil 304234 'foo abcde' true (1 ' abc') 304235 'abcde' false nil) 304236 ('\<foo.*' 304237 'foo' true nil 304238 'foobar' true nil 304239 'qfoobarq foonix' true (1 'foonix') 304240 ' foo' true nil 304241 ' 12foo' false nil 304242 'barfoo' false nil) 304243 ('.+\<foo' 304244 'foo' false nil 304245 'ab foo' true (1 'ab foo') 304246 'abfoo' false nil) 304247 ('a[bc]d' 304248 'abc' false nil 304249 'abd' true (1 'abd')) 304250 ('a[b-d]e' 304251 'abd' false nil 304252 'ace' true (1 'ace')) 304253 ('a[b-d]' 304254 'aac' true (1 'ac')) 304255 ('a[-b]' 304256 'a-' true (1 'a-')) 304257 ('a[b-]' 304258 'a-' true (1 'a-')) 304259 ('a[a-b-c]' nil) 304260 ('[k]' 304261 'ab' false nil) 304262 ('a[b-a]' nil) 304263 ('a[]b' nil) 304264 ('a[' nil) 304265 ('a]' 304266 'a]' true (1 'a]')) 304267 ('a[]]b' 304268 'a]b' true (1 'a]b')) 304269 ('a[^bc]d' 304270 'aed' true (1 'aed') 304271 'abd' false nil) 304272 ('a[^-b]c' 304273 'adc' true (1 'adc') 304274 'a-c' false nil) 304275 ('a[^]b]c' 304276 'a]c' false nil 304277 'adc' true (1 'adc')) 304278 ('[\de]+' 304279 '01234' true (1 '01234') 304280 '0123e456' true (1 '0123e456') 304281 '0123e45g78' true (1 '0123e45')) 304282 ('[e\d]+' "reversal of the above, should be the same" 304283 '01234' true (1 '01234') 304284 '0123e456' true (1 '0123e456') 304285 '0123e45g78' true (1 '0123e45')) 304286 ('[\D]+' 304287 '123abc45def78' true (1 'abc')) 304288 ('[[:digit:]e]+' 304289 '01234' true (1 '01234') 304290 '0123e456' true (1 '0123e456') 304291 '0123e45g78' true (1 '0123e45')) 304292 ('[\s]+' 304293 '2 spaces' true (1 ' ')) 304294 ('[\S]+' 304295 ' word12!!@#$ ' true (1 'word12!!@#$')) 304296 ('[\w]+' 304297 ' foo123bar 45' true (1 'foo123bar')) 304298 ('[\W]+' 304299 'fii234!!@#$34f' true (1 '!!@#$')) 304300 ('[^[:alnum:]]+' 304301 'fii234!!@#$34f' true (1 '!!@#$')) 304302 ('[%&[:alnum:]]+' 304303 'foo%3' true (1 'foo%3') 304304 'foo34&rt4$57a' true (1 'foo34&rt4') 304305 '!!@#$' false nil) 304306 ('[[:alpha:]]+' 304307 ' 123foo3 ' true (1 'foo') 304308 '123foo' true (1 'foo') 304309 'foo1b' true (1 'foo')) 304310 ('[[:cntrl:]]+' 304311 ' a 1234asdf' false nil) 304312 ('[[:lower:]]+' 304313 'UPPERlower1234' true (1 'lower') 304314 'lowerUPPER' true (1 'lower')) 304315 ('[[:upper:]]+' 304316 'UPPERlower1234' true (1 'UPPER') 304317 'lowerUPPER ' true (1 'UPPER')) 304318 ('[[:space:]]+' 304319 '2 spaces' true (1 ' ')) 304320 ('[^[:space:]]+' 304321 ' word12!!@#$ ' true (1 'word12!!@#$')) 304322 ('[[:graph:]]+' 304323 'abc' true (1 'abc')) 304324 ('[[:print:]]+' 304325 'abc' true (1 'abc')) 304326 ('[^[:punct:]]+' 304327 '!!hello,world!!' true (1 'hello')) 304328 ('[[:xdigit:]]+' 304329 ' x10FCD ' true (1 '10FCD') 304330 ' hgfedcba0123456789ABCDEFGH ' 304331 true (1 'fedcba0123456789ABCDEF')) 304332 ('ab|cd' 304333 'abc' true (1 'ab') 304334 'abcd' true (1 'ab')) 304335 ('()ef' 304336 'def' true (1 'ef' 2 '')) 304337 ('()*' nil) 304338 ('*a' nil) 304339 ('^*' nil) 304340 ('$*' nil) 304341 ('(*)b' nil) 304342 ('$b' 'b' false nil) 304343 ('a\' nil) 304344 ('a\(b' 304345 'a(b' true (1 'a(b')) 304346 ('a\(*b' 304347 'ab' true (1 'ab') 304348 'a((b' true (1 'a((b')) 304349 ('a\\b' 304350 'a\b' true (1 'a\b')) 304351 ('abc)' nil) 304352 ('(abc' nil) 304353 ('((a))' 304354 'abc' true (1 'a' 2 'a' 3 'a')) 304355 ('(a)b(c)' 304356 'abc' true (1 'abc' 2 'a' 3 'c')) 304357 ('a+b+c' 304358 'aabbabc' true (1 'abc')) 304359 ('a**' nil) 304360 ('a*?' nil) 304361 ('(a*)*' nil) 304362 ('(a*)+' nil) 304363 ('(a|)*' nil) 304364 ('(a*|b)*' nil) 304365 ('(a+|b)*' 304366 'ab' true (1 'ab' 2 'b')) 304367 ('(a+|b)+' 304368 'ab' true (1 'ab' 2 'b')) 304369 ('(a+|b)?' 304370 'ab' true (1 'a' 2 'a')) 304371 ('[^ab]*' 304372 'cde' true (1 'cde')) 304373 ('(^)*' nil) 304374 ('(ab|)*' nil) 304375 (')(' nil) 304376 ('' 'abc' true (1 '')) 304377 ('abc' '' false nil) 304378 ('a*' 304379 '' true '') 304380 ('abcd' 304381 'abcd' true (1 'abcd')) 304382 ('a(bc)d' 304383 'abcd' true (1 'abcd' 2 'bc')) 304384 ('([abc])*d' 304385 'abbbcd' true (1 'abbbcd' 2 'c')) 304386 ('([abc])*bcd' 304387 'abcd' true (1 'abcd' 2 'a')) 304388 ('a|b|c|d|e' 'e' true (1 'e')) 304389 ('(a|b|c|d|e)f' 'ef' true (1 'ef' 2 'e')) 304390 " ((a*|b))* - c - -" 304391 ('abcd*efg' 'abcdefg' true (1 'abcdefg')) 304392 ('ab*' 304393 'xabyabbbz' true (1 'ab') 304394 'xayabbbz' true (1 'a')) 304395 ('(ab|cd)e' 'abcde' true (1 'cde' 2 'cd')) 304396 ('[abhgefdc]ij' 'hij' true (1 'hij')) 304397 ('^(ab|cd)e' 'abcde' false nil) 304398 ('(abc|)def' 'abcdef' true nil) 304399 ('(a|b)c*d' 'abcd' true (1 'bcd' 2 'b')) 304400 ('(ab|ab*)bc' 'abc' true (1 'abc' 2 'a')) 304401 ('a([bc]*)c*' 'abc' true (1 'abc' 2 'bc')) 304402 ('a([bc]*)(c*d)' 'abcd' true (1 'abcd' 2 'bc' 3 'd')) 304403 ('a([bc]+)(c*d)' 'abcd' true (1 'abcd' 2 'bc' 3 'd')) 304404 ('a([bc]*)(c+d)' 'abcd' true (1 'abcd' 2 'b' 3 'cd')) 304405 ('a[bcd]*dcdcde' 'adcdcde' true (1 'adcdcde')) 304406 ('a[bcd]+dcdcde' 'adcdcde' false nil) 304407 ('(ab|a)b*c' 'abc' true (1 'abc')) 304408 ('((a)(b)c)(d)' 'abcd' true (1 'abcd' 3 'a' 4 'b' 5 'd')) 304409 ('[ -~]*' 'abc' true (1 'abc')) 304410 ('[ -~ -~]*' 'abc' true (1 'abc')) 304411 ('[ -~ -~ -~]*' 'abc' true (1 'abc')) 304412 ('[ -~ -~ -~ -~]*' 'abc' true (1 'abc')) 304413 ('[ -~ -~ -~ -~ -~]*' 'abc' true (1 'abc')) 304414 ('[ -~ -~ -~ -~ -~ -~]*' 'abc' true (1 'abc')) 304415 ('[ -~ -~ -~ -~ -~ -~ -~]*' 'abc' true (1 'abc')) 304416 ('[a-zA-Z_][a-zA-Z0-9_]*' 'alpha' true (1 'alpha')) 304417 ('^a(bc+|b[eh])g|.h$' 'abh' true (1 'bh' 2 '')) 304418 ('(bc+d$|ef*g.|h?i(j|k))' 304419 'effgz' true (1 'effgz' 2 'effgz' 3 '') 304420 'ij' true (1 'ij' 2 'ij' 3 'j') 304421 'effg' false nil 304422 'bcdd' false nil 304423 'reffgz' true (1 'effgz' 2 'effgz' 3 '')) 304424 ('(((((((((a)))))))))' 'a' true (1 'a')) 304425 ('multiple words of text' 304426 'uh-uh' false nil 304427 'multiple words of text, yeah' true (1 'multiple words of text')) 304428 ('(.*)c(.*)' 'abcde' true (1 'abcde' 2 'ab' 3 'de')) 304429 ('\((.*), (.*)\)' '(a, b)' true (2 'a' 3 'b')))! ! 304430 304431 304432!RxParser class methodsFor: 'utilities'! 304433parse: aString 304434 "Parse the argument and return the result (the parse tree). 304435 In case of a syntax error, the corresponding exception is signaled." 304436 ^self new parse: aString! ! 304437 304438!RxParser class methodsFor: 'utilities' stamp: 'avi 11/30/2003 13:23'! 304439safelyParse: aString 304440 "Parse the argument and return the result (the parse tree). 304441 In case of a syntax error, return nil. 304442 Exception handling here is dialect-dependent." 304443 ^ [self new parse: aString] on: RegexSyntaxError do: [:ex | nil]! ! 304444TestCase subclass: #RxParserTest 304445 instanceVariableNames: '' 304446 classVariableNames: '' 304447 poolDictionaries: '' 304448 category: 'Tests-VB-Regex'! 304449 304450!RxParserTest methodsFor: 'tests' stamp: 'sd 9/5/2006 00:11'! 304451DoesNotWorktestBackQuotesEscape 304452 "self debug: #testBackQuotesEscape" 304453 304454 "Regular expressions can also include the following backquote escapes 304455to refer to popular classes of characters: 304456 \w any word constituent character (same as [a-zA-Z0-9:=]) 304457 \W any character but a word constituent 304458 \d a digit (same as [0-9]) 304459 \D anything but a digit 304460 \s a whitespace character 304461 \S anything but a whitespace character 304462These escapes are also allowed in character classes: '[\w+-]' means 304463'any character that is either a word constituent, or a plus, or a 304464minus'." 304465 304466 self assert: ('one word' matchesRegex: '\w'). 304467 304468 self assert: ('one' matchesRegex: '\w'). 304469 ! ! 304470 304471!RxParserTest methodsFor: 'tests' stamp: 'sd 9/3/2006 19:47'! 304472test 304473 "self debug: #test" 304474 304475 304476 self assert: ('\<t\w+' asRegexIgnoringCase 304477 copy: 'now is the Time' 304478 translatingMatchesUsing: [:match | match asUppercase]) = 'now is THE TIME'. 304479 304480 "the regular expression matches words beginning with either an uppercase or a lowercase T".! ! 304481 304482!RxParserTest methodsFor: 'tests' stamp: 'sd 9/4/2006 16:24'! 304483testCadrMatching 304484 "self debug: #testCadrMatching" 304485 304486 "A bit more complex example is the following expression, matching the 304487name of any of the Lisp-style `car', `cdr', `caar', `cadr', 304488... functions:" 304489 304490 self assert: ( 'car' matchesRegex: 'c(a|d)+r'). 304491 self assert: ( 'cdr' matchesRegex: 'c(a|d)+r'). 304492 self assert: ( 'caar' matchesRegex: 'c(a|d)+r'). 304493 self assert: ( 'cadr' matchesRegex: 'c(a|d)+r'). 304494 self assert: ( 'caddar' matchesRegex: 'c(a|d)+r').! ! 304495 304496!RxParserTest methodsFor: 'tests' stamp: 'sd 9/4/2006 16:49'! 304497testCharacterSet 304498 "self debug: #testCharacterSet" 304499 304500 "So far, we have used only characters as the 'smallest' components of 304501regular expressions. There are other, more `interesting', components. 304502A character set is a string of characters enclosed in square 304503brackets. It matches any single character if it appears between the 304504brackets. For example, `[01]' matches either `0' or `1':" 304505 304506 self assert: ('0' matchesRegex: '[01]'). 304507 self deny: ('3' matchesRegex: '[01]'). 304508 self deny: ('11' matchesRegex: '[01]'). "-- false: a set matches only one character" 304509 self deny: ('01' matchesRegex: '[01]'). 304510! ! 304511 304512!RxParserTest methodsFor: 'tests' stamp: 'sd 9/4/2006 17:39'! 304513testCharacterSetBinaryNumber 304514 "self debug: #testCharacterSetBinaryNumber" 304515 304516 "Using plus operator, we can build the following binary number 304517recognizer:" 304518 self assert: ('10010100' matchesRegex: '[01]+'). 304519 self deny: ('10001210' matchesRegex: '[01]+') ! ! 304520 304521!RxParserTest methodsFor: 'tests' stamp: 'sd 9/5/2006 00:01'! 304522testCharacterSetInversion 304523 "self debug: #testCharacterSetInversion" 304524 304525 "If the first character after the opening bracket is `^', the set is 304526inverted: it matches any single character *not* appearing between the 304527brackets:" 304528 304529 self deny: ('0' matchesRegex: '[^01]'). 304530 "0 appears in 01 so there is no match" 304531 304532 self assert: ('3' matchesRegex: '[^01]'). 304533 "3 is not in 01 so it matches" 304534 304535 304536 self deny: ('30' matchesRegex: '[^01]'). 304537 self deny: ('33333333333333333333333330' matchesRegex: '[^01]'). 304538 "there is one zero so it does not match"! ! 304539 304540!RxParserTest methodsFor: 'tests' stamp: 'sd 9/4/2006 23:20'! 304541testCharacterSetRange 304542 "self debug: #testCharacterSetRange" 304543 304544 "For convenience, a set may include ranges: pairs of characters 304545separated with `-'. This is equivalent to listing all characters 304546between them: `[0-9]' is the same as `[0123456789]'. " 304547 304548 self assert: ('0' matchesRegex: '[0-9]'). 304549 self assert: ('9' matchesRegex: '[0-9]'). 304550 self deny: ('a' matchesRegex: '[0-9]'). 304551 self deny: ('01' matchesRegex: '[0-9]'). 304552 self assert: ('01442128629839374565' matchesRegex: '[0-9]+'). 304553 ! ! 304554 304555!RxParserTest methodsFor: 'tests' stamp: 'marcus.denker 10/22/2008 10:47'! 304556testMatchesInwW 304557 "self debug: #testMatchesInwW" 304558 304559 "1. Backslash escapes similar to those in Perl are allowed in patterns: 304560 \w any word constituent character (equivalent to [a-zA-Z0-9:=]) 304561 \W any character but a word constituent (equivalent to [^a-xA-Z0-9:=]" 304562 304563 self assert: ('\w+' asRegex matchesIn: 'now is the time') asArray = #('now' 'is' 'the' 'time'). 304564 self assert: ('\W+' asRegex matchesIn: 'now is the time') asArray = #(' ' ' ' ' '). 304565 304566 "why do we get that" 304567 self assert: ('\w' asRegex matchesIn: 'now') asArray = #('n' 'o' 'w').! ! 304568 304569!RxParserTest methodsFor: 'tests' stamp: 'sd 9/4/2006 16:38'! 304570testOrOperator 304571 "self debug: #testOrOperator" 304572 304573 "The last operator is `|' meaning `or'. It is placed between two 304574regular expressions, and the resulting expression matches if one of 304575the expressions matches. It has the lowest possible precedence (lower 304576than sequencing). For example, `ab*|ba*' means `a followed by any 304577number of b's, or b followed by any number of a's':" 304578 304579 self assert: ('abb' matchesRegex: 'ab*|ba*'). 304580 self assert: ('baa' matchesRegex: 'ab*|ba*'). 304581 self deny: ('baab' matchesRegex: 'ab*|ba*'). 304582 304583 304584 "It is possible to write an expression matching an empty string, for 304585example: `a|'. However, it is an error to apply `*', `+', or `?' to 304586such expression: `(a|)*' is an invalid expression." 304587 304588 self should: ['(a|)*' asRegex] raise: Error. 304589! ! 304590 304591!RxParserTest methodsFor: 'tests' stamp: 'sd 9/4/2006 16:17'! 304592testQuotingOperators 304593 "self debug: #testQuotingOperators" 304594 304595 "As we have seen, characters `*', `+', `?', `(', and `)' have special 304596meaning in regular expressions. If one of them is to be used 304597literally, it should be quoted: preceded with a backslash. (Thus, 304598backslash is also special character, and needs to be quoted for a 304599literal match--as well as any other special character described 304600further)." 304601 304602 self deny: ('ab*' matchesRegex: 'ab*'). " -- false: star in the right string is special" 304603 self assert: ('ab*' matchesRegex: 'ab\*'). 304604 self assert: ('a\c' matchesRegex: 'a\\c'). ! ! 304605 304606!RxParserTest methodsFor: 'tests' stamp: 'sd 9/3/2006 19:50'! 304607testSimpleMatchesRegex 304608 "self debug: #testSimpleMatchesRegex" 304609 304610 "The simplest regular expression is a single character. It matches 304611exactly that character. A sequence of characters matches a string with 304612exactly the same sequence of characters:" 304613 304614 self assert: ('a' matchesRegex: 'a'). 304615 self assert: ('foobar' matchesRegex: 'foobar') . 304616 self deny: ('blorple' matchesRegex: 'foobar')! ! 304617 304618!RxParserTest methodsFor: 'tests' stamp: 'sd 9/3/2006 21:41'! 304619testSimpleMatchesRegexWithStar 304620 "self debug: #testSimpleMatchesRegexWithStar" 304621 304622 "The above paragraph in testSimpleMatchesRegex introduced a primitive regular expression (a 304623character), and an operator (sequencing). Operators are applied to 304624regular expressions to produce more complex regular expressions. 304625Sequencing (placing expressions one after another) as an operator is, 304626in a certain sense, `invisible'--yet it is arguably the most common. 304627A more `visible' operator is Kleene closure, more often simply 304628referred to as `a star'. A regular expression followed by an asterisk 304629matches any number (including 0) of matches of the original 304630expression. For example:" 304631 304632 self assert: ('ab' matchesRegex: 'a*b'). 304633 self assert: ('aaaaab' matchesRegex: 'a*b'). 304634 self assert: ('b' matchesRegex: 'a*b'). 304635 self deny: ('aac' matchesRegex: 'a*b'). ! ! 304636 304637!RxParserTest methodsFor: 'tests' stamp: 'sd 9/4/2006 23:38'! 304638testSpecialCharacterInSetRange 304639 "self debug: #testSpecialCharacterInSetRange" 304640 304641 "Special characters within a set are `^', `-', and `]' that closes the 304642set. Below are the examples of how to literally use them in a set: 304643 [01^] -- put the caret anywhere except the beginning 304644 [01-] -- put the dash as the last character 304645 []01] -- put the closing bracket as the first character 304646 [^]01] (thus, empty and universal sets cannot be specified)" 304647 304648 self assert: ('0' matchesRegex: '[01^]'). 304649 self assert: ('1' matchesRegex: '[01^]'). 304650 self assert: ('^' matchesRegex: '[01^]'). 304651 304652 self deny: ('0' matchesRegex: '[^01]'). 304653 self deny: ('1' matchesRegex: '[^01]'). 304654 304655 "[^abc] means that everything except abc is matche" 304656 self assert: ('^' matchesRegex: '[^01]'). 304657 ! ! 304658 304659!RxParserTest methodsFor: 'tests' stamp: 'sd 9/4/2006 16:26'! 304660testStarPlusQuestionMark 304661 "self debug: #testStarPlusQuestionMark" 304662 304663 "Two other operators similar to `*' are `+' and `?'. `+' (positive 304664closure, or simply `plus') matches one or more occurrences of the 304665original expression. `?' (`optional') matches zero or one, but never 304666more, occurrences." 304667 304668 self assert: ('ac' matchesRegex: 'ab*c'). 304669 self deny: ('ac' matchesRegex: 'ab+c'). "-- false: need at least one b" 304670 self assert: ('abbc' matchesRegex: 'ab+c'). 304671 self assert: ('abbbbbbc' matchesRegex: 'ab+c'). 304672 self deny: ('abbc' matchesRegex: 'ab?c') "-- false: too many b's"! ! 304673 304674!RxParserTest methodsFor: 'tests' stamp: 'sd 9/3/2006 22:57'! 304675testStarPrecedence 304676 "self debug: #testStarPrecedence" 304677 304678 "A star's precedence is higher than that of sequencing. A star applies 304679to the shortest possible subexpression that precedes it. For example, 304680'ab*' means `a followed by zero or more occurrences of b', not `zero 304681or more occurrences of ab':" 304682 304683 self assert: ('abbb' matchesRegex: 'ab*'). 304684 self deny: ('abab' matchesRegex: 'ab*'). 304685 304686 "To actually make a regex matching `zero or more occurrences of ab', 304687`ab' is enclosed in parentheses:" 304688 self assert: ('abab' matchesRegex: '(ab)*'). 304689 self deny: ('abcab' matchesRegex: '(ab)*')! ! 304690 304691!RxParserTest methodsFor: 'tests' stamp: 'sd 9/3/2006 19:47'! 304692testTranslatingMatchesUsing 304693 "self debug: #testTranslatingMatchesUsing" 304694 304695 304696 self assert: ('\<t\w+' asRegexIgnoringCase 304697 copy: 'now is the Time' 304698 translatingMatchesUsing: [:match | match asUppercase]) = 'now is THE TIME'. 304699 304700 "the regular expression matches words beginning with either an uppercase or a lowercase T".! ! 304701 304702!RxParserTest methodsFor: 'tests' stamp: 'sd 9/4/2006 23:29'! 304703toDotestSpecialCharacterInSetRange 304704 "self debug: #testSpecialCharacterInSetRange" 304705 304706 "Special characters within a set are `^', `-', and `]' that closes the 304707set. Below are the examples of how to literally use them in a set: 304708 [01^] -- put the caret anywhere except the beginning 304709 [01-] -- put the dash as the last character 304710 []01] -- put the closing bracket as the first character 304711 [^]01] (thus, empty and universal sets cannot be specified)" 304712 304713 self assert: ('0' matchesRegex: '[01^]'). 304714 304715 self assert: ('0' matchesRegex: '[0-9]'). 304716 ! ! 304717RxmLink subclass: #RxmBranch 304718 instanceVariableNames: 'loopback alternative' 304719 classVariableNames: '' 304720 poolDictionaries: '' 304721 category: 'VB-Regex'! 304722!RxmBranch commentStamp: '<historical>' prior: 0! 304723-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 304724-- See `documentation' protocol of RxParser class for user's guide. 304725-- 304726This is a branch of a matching process. Either `next' chain should match, or `alternative', if not nil, should match. Since this is also used to build loopbacks to match repetitions, `loopback' variable indicates whether the instance is a loopback: it affects the matcher-building operations (which of the paths through the branch is to consider as the primary when we have to find the "tail" of a matcher construct). 304727Instance variables 304728 alternative <RxmLink> to match if `next' fails to match. 304729 loopback <Boolean>! 304730 304731 304732!RxmBranch methodsFor: 'building'! 304733pointTailTo: aNode 304734 "See superclass for explanations." 304735 loopback 304736 ifTrue: [alternative == nil 304737 ifTrue: [alternative := aNode] 304738 ifFalse: [alternative pointTailTo: aNode]] 304739 ifFalse: [super pointTailTo: aNode]! ! 304740 304741!RxmBranch methodsFor: 'building'! 304742terminateWith: aNode 304743 "See superclass for explanations." 304744 loopback 304745 ifTrue: [alternative == nil 304746 ifTrue: [alternative := aNode] 304747 ifFalse: [alternative terminateWith: aNode]] 304748 ifFalse: [super terminateWith: aNode]! ! 304749 304750 304751!RxmBranch methodsFor: 'initialize-release'! 304752alternative: aBranch 304753 "See class comment for instance variable description." 304754 alternative := aBranch! ! 304755 304756!RxmBranch methodsFor: 'initialize-release'! 304757beLoopback 304758 "See class comment for instance variable description." 304759 loopback := true! ! 304760 304761!RxmBranch methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 10:18'! 304762initialize 304763 "See class comment for instance variable description." 304764 super initialize. 304765 loopback := false! ! 304766 304767 304768!RxmBranch methodsFor: 'matching'! 304769matchAgainst: aMatcher 304770 "Match either `next' or `alternative'. Fail if the alternative is nil." 304771 ^(next matchAgainst: aMatcher) 304772 or: [alternative notNil 304773 and: [alternative matchAgainst: aMatcher]]! ! 304774Object subclass: #RxmLink 304775 instanceVariableNames: 'next' 304776 classVariableNames: '' 304777 poolDictionaries: '' 304778 category: 'VB-Regex'! 304779!RxmLink commentStamp: '<historical>' prior: 0! 304780-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 304781-- See `documentation' protocol of RxParser class for user's guide. 304782-- 304783A matcher is built of a number of links interconnected into some intricate structure. Regardless of fancy stuff, any link (except for the terminator) has the next one. Any link can match against a stream of characters, recursively propagating the match to the next link. Any link supports a number of matcher-building messages. This superclass does all of the above. 304784The class is not necessarily abstract. It may double as an empty string matcher: it recursively propagates the match to the next link, thus always matching nothing successfully. 304785Principal method: 304786 matchAgainst: aMatcher 304787 Any subclass will reimplement this to test the state of the matcher, most 304788 probably reading one or more characters from the matcher's stream, and 304789 either decide it has matched and answer true, leaving matcher stream 304790 positioned at the end of match, or answer false and restore the matcher 304791 stream position to whatever it was before the matching attempt. 304792Instance variables: 304793 next <RxmLink | RxmTerminator> The next link in the structure.! 304794 304795 304796!RxmLink methodsFor: 'building'! 304797pointTailTo: anRxmLink 304798 "Propagate this message along the chain of links. 304799 Point `next' reference of the last link to <anRxmLink>. 304800 If the chain is already terminated, blow up." 304801 next == nil 304802 ifTrue: [next := anRxmLink] 304803 ifFalse: [next pointTailTo: anRxmLink]! ! 304804 304805!RxmLink methodsFor: 'building'! 304806terminateWith: aTerminator 304807 "Propagate this message along the chain of links, and 304808 make aTerminator the `next' link of the last link in the chain. 304809 If the chain is already reminated with the same terminator, 304810 do not blow up." 304811 next == nil 304812 ifTrue: [next := aTerminator] 304813 ifFalse: [next terminateWith: aTerminator]! ! 304814 304815 304816!RxmLink methodsFor: 'initialize-release'! 304817next: aLink 304818 "Set the next link, either an RxmLink or an RxmTerminator." 304819 next := aLink! ! 304820 304821 304822!RxmLink methodsFor: 'matching'! 304823matchAgainst: aMatcher 304824 "If a link does not match the contents of the matcher's stream, 304825 answer false. Otherwise, let the next matcher in the chain match." 304826 ^next matchAgainst: aMatcher! ! 304827 304828!RxmLink methodsFor: 'matching'! 304829next 304830 304831 ^next! ! 304832 304833"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 304834 304835RxmLink class 304836 instanceVariableNames: ''! 304837 304838!RxmLink class methodsFor: 'instance creation'! 304839new 304840 ^super new initialize! ! 304841RxmLink subclass: #RxmMarker 304842 instanceVariableNames: 'index' 304843 classVariableNames: '' 304844 poolDictionaries: '' 304845 category: 'VB-Regex'! 304846!RxmMarker commentStamp: '<historical>' prior: 0! 304847-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 304848-- See `documentation' protocol of RxParser class for user's guide. 304849-- 304850A marker is used to remember positions of match of certain points of a regular expression. The marker receives an identifying key from the Matcher and uses that key to report positions of successful matches to the Matcher. 304851Instance variables: 304852 index <Object> Something that makes sense for the Matcher. Received from the latter during initalization and later passed to it to identify the receiver.! 304853 304854 304855!RxmMarker methodsFor: 'initialize-release'! 304856index: anIndex 304857 "An index is a key that makes sense for the matcher. 304858 This key can be passed to marker position getters and 304859 setters to access position for this marker in the current 304860 matching session." 304861 index := anIndex! ! 304862 304863 304864!RxmMarker methodsFor: 'matching'! 304865matchAgainst: aMatcher 304866 "If the rest of the link chain matches successfully, report the 304867 position of the stream *before* the match started to the matcher." 304868 | startPosition | 304869 startPosition := aMatcher position. 304870 (next matchAgainst: aMatcher) 304871 ifTrue: 304872 [aMatcher markerPositionAt: index maybePut: startPosition. 304873 ^true]. 304874 ^false! ! 304875RxmLink subclass: #RxmPredicate 304876 instanceVariableNames: 'predicate' 304877 classVariableNames: '' 304878 poolDictionaries: '' 304879 category: 'VB-Regex'! 304880!RxmPredicate commentStamp: '<historical>' prior: 0! 304881-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 304882-- See `documentation' protocol of RxParser class for user's guide. 304883-- 304884Instance holds onto a one-argument block and matches exactly one character if the block evaluates to true when passed the character as the argument. 304885Instance variables: 304886 predicate <BlockClosure>! 304887 304888 304889!RxmPredicate methodsFor: 'initialize-release'! 304890bePerform: aSelector 304891 "Match any single character that answers true to this message." 304892 self predicate: 304893 [:char | 304894 RxParser doHandlingMessageNotUnderstood: [char perform: aSelector]]! ! 304895 304896!RxmPredicate methodsFor: 'initialize-release'! 304897bePerformNot: aSelector 304898 "Match any single character that answers false to this message." 304899 self predicate: 304900 [:char | 304901 RxParser doHandlingMessageNotUnderstood: [(char perform: aSelector) not]]! ! 304902 304903!RxmPredicate methodsFor: 'initialize-release'! 304904predicate: aBlock 304905 "This link will match any single character for which <aBlock> 304906 evaluates to true." 304907 aBlock numArgs ~= 1 ifTrue: [self error: 'bad predicate block']. 304908 predicate := aBlock. 304909 ^self! ! 304910 304911 304912!RxmPredicate methodsFor: 'matching'! 304913matchAgainst: aMatcher 304914 "Match if the predicate block evaluates to true when given the 304915 current stream character as the argument." 304916 | original | 304917 original := aMatcher currentState. 304918 (aMatcher atEnd not 304919 and: [(predicate value: aMatcher next) 304920 and: [next matchAgainst: aMatcher]]) 304921 ifTrue: [^true] 304922 ifFalse: 304923 [aMatcher restoreState: original. 304924 ^false]! ! 304925 304926"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 304927 304928RxmPredicate class 304929 instanceVariableNames: ''! 304930 304931!RxmPredicate class methodsFor: 'instance creation'! 304932with: unaryBlock 304933 ^self new predicate: unaryBlock! ! 304934RxmLink subclass: #RxmSpecial 304935 instanceVariableNames: 'matchSelector' 304936 classVariableNames: '' 304937 poolDictionaries: '' 304938 category: 'VB-Regex'! 304939!RxmSpecial commentStamp: '<historical>' prior: 0! 304940-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 304941-- See `documentation' protocol of RxParser class for user's guide. 304942-- 304943A special node that matches a specific matcher state rather than any input character. 304944The state is either at-beginning-of-line or at-end-of-line.! 304945 304946 304947!RxmSpecial methodsFor: 'initialize-release'! 304948beBeginningOfLine 304949 matchSelector := #atBeginningOfLine! ! 304950 304951!RxmSpecial methodsFor: 'initialize-release'! 304952beBeginningOfWord 304953 matchSelector := #atBeginningOfWord! ! 304954 304955!RxmSpecial methodsFor: 'initialize-release'! 304956beEndOfLine 304957 matchSelector := #atEndOfLine! ! 304958 304959!RxmSpecial methodsFor: 'initialize-release'! 304960beEndOfWord 304961 matchSelector := #atEndOfWord! ! 304962 304963!RxmSpecial methodsFor: 'initialize-release'! 304964beNotWordBoundary 304965 matchSelector := #notAtWordBoundary! ! 304966 304967!RxmSpecial methodsFor: 'initialize-release'! 304968beWordBoundary 304969 matchSelector := #atWordBoundary! ! 304970 304971 304972!RxmSpecial methodsFor: 'matching'! 304973matchAgainst: aMatcher 304974 "Match without consuming any input, if the matcher is 304975 in appropriate state." 304976 ^(aMatcher perform: matchSelector) 304977 and: [next matchAgainst: aMatcher]! ! 304978RxmLink subclass: #RxmSubstring 304979 instanceVariableNames: 'sample compare' 304980 classVariableNames: '' 304981 poolDictionaries: '' 304982 category: 'VB-Regex'! 304983!RxmSubstring commentStamp: '<historical>' prior: 0! 304984-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 304985-- See `documentation' protocol of RxParser class for user's guide. 304986-- 304987Instance holds onto a string and matches exactly this string, and exactly once. 304988Instance variables: 304989 string <String>! 304990 304991 304992!RxmSubstring methodsFor: 'initialize-release'! 304993beCaseInsensitive 304994 compare := [:char1 :char2 | char1 sameAs: char2]! ! 304995 304996!RxmSubstring methodsFor: 'initialize-release'! 304997beCaseSensitive 304998 compare := [:char1 :char2 | char1 = char2]! ! 304999 305000!RxmSubstring methodsFor: 'initialize-release'! 305001character: aCharacter ignoreCase: aBoolean 305002 "Match exactly this character." 305003 sample := String with: aCharacter. 305004 aBoolean ifTrue: [self beCaseInsensitive]! ! 305005 305006!RxmSubstring methodsFor: 'initialize-release'! 305007initialize 305008 super initialize. 305009 self beCaseSensitive! ! 305010 305011!RxmSubstring methodsFor: 'initialize-release'! 305012substring: aString ignoreCase: aBoolean 305013 "Match exactly this string." 305014 sample := aString. 305015 aBoolean ifTrue: [self beCaseInsensitive]! ! 305016 305017 305018!RxmSubstring methodsFor: 'matching'! 305019matchAgainst: aMatcher 305020 "Match if my sample stream is exactly the current prefix 305021 of the matcher stream's contents." 305022 | originalState sampleStream mismatch | 305023 originalState := aMatcher currentState. 305024 sampleStream := self sampleStream. 305025 mismatch := false. 305026 [sampleStream atEnd 305027 or: [aMatcher atEnd 305028 or: [mismatch := (compare value: sampleStream next value: aMatcher next) not]]] whileFalse. 305029 (mismatch not and: [sampleStream atEnd and: [next matchAgainst: aMatcher]]) 305030 ifTrue: [^true] 305031 ifFalse: 305032 [aMatcher restoreState: originalState. 305033 ^false]! ! 305034 305035 305036!RxmSubstring methodsFor: 'private'! 305037sampleStream 305038 ^sample readStream! ! 305039Object subclass: #RxmTerminator 305040 instanceVariableNames: '' 305041 classVariableNames: '' 305042 poolDictionaries: '' 305043 category: 'VB-Regex'! 305044!RxmTerminator commentStamp: '<historical>' prior: 0! 305045-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 305046-- See `documentation' protocol of RxParser class for user's guide. 305047-- 305048Instances of this class are used to terminate matcher's chains. When a match reaches this (an instance receives #matchAgainst: message), the match is considered to succeed. Instances also support building protocol of RxmLinks, with some restrictions.! 305049 305050 305051!RxmTerminator methodsFor: 'building'! 305052pointTailTo: anRxmLink 305053 "Branch tails are never redirected by the build algorithm. 305054 Healthy terminators should never receive this." 305055 RxParser signalCompilationException: 305056 'internal matcher build error - redirecting terminator tail'! ! 305057 305058!RxmTerminator methodsFor: 'building'! 305059terminateWith: aTerminator 305060 "Branch terminators are never supposed to change. 305061 Make sure this is the case." 305062 aTerminator ~~ self 305063 ifTrue: [RxParser signalCompilationException: 305064 'internal matcher build error - wrong terminator']! ! 305065 305066 305067!RxmTerminator methodsFor: 'matching'! 305068matchAgainst: aStream 305069 "If got here, the match is successful." 305070 ^true! ! 305071RxsNode subclass: #RxsBranch 305072 instanceVariableNames: 'piece branch' 305073 classVariableNames: '' 305074 poolDictionaries: '' 305075 category: 'VB-Regex'! 305076!RxsBranch commentStamp: '<historical>' prior: 0! 305077-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 305078-- See `documentation' protocol of RxParser class for user's guide. 305079-- 305080A Branch is a Piece followed by a Branch or an empty string. 305081Instance variables: 305082 piece <RxsPiece> 305083 branch <RxsBranch|RxsEpsilon>! 305084 305085 305086!RxsBranch methodsFor: 'accessing'! 305087branch 305088 ^branch! ! 305089 305090!RxsBranch methodsFor: 'accessing'! 305091dispatchTo: aMatcher 305092 "Inform the matcher of the kind of the node, and it 305093 will do whatever it has to." 305094 ^aMatcher syntaxBranch: self! ! 305095 305096!RxsBranch methodsFor: 'accessing'! 305097piece 305098 ^piece! ! 305099 305100 305101!RxsBranch methodsFor: 'initialize-release'! 305102initializePiece: aPiece branch: aBranch 305103 "See class comment for instance variables description." 305104 piece := aPiece. 305105 branch := aBranch! ! 305106 305107 305108!RxsBranch methodsFor: 'optimization'! 305109tryMergingInto: aStream 305110 "Concatenation of a few simple characters can be optimized 305111 to be a plain substring match. Answer the node to resume 305112 syntax tree traversal at. Epsilon node used to terminate the branch 305113 will implement this to answer nil, thus indicating that the branch 305114 has ended." 305115 piece isAtomic ifFalse: [^self]. 305116 aStream nextPut: piece character. 305117 ^branch isNil 305118 ifTrue: [branch] 305119 ifFalse: [branch tryMergingInto: aStream]! ! 305120 305121 305122!RxsBranch methodsFor: 'testing'! 305123isNullable 305124 ^piece isNullable and: [branch isNil or: [branch isNullable]]! ! 305125RxsNode subclass: #RxsCharSet 305126 instanceVariableNames: 'negated elements' 305127 classVariableNames: '' 305128 poolDictionaries: '' 305129 category: 'VB-Regex'! 305130!RxsCharSet commentStamp: '<historical>' prior: 0! 305131-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 305132-- See `documentation' protocol of RxParser class for user's guide. 305133-- 305134A character set corresponds to a [...] construct in the regular expression. 305135Instance variables: 305136 elements <OrderedCollection> An element can be one of: RxsCharacter, RxsRange, or RxsPredicate. 305137 negated <Boolean>! 305138 305139 305140!RxsCharSet methodsFor: 'accessing'! 305141dispatchTo: aMatcher 305142 "Inform the matcher of the kind of the node, and it 305143 will do whatever it has to." 305144 ^aMatcher syntaxCharSet: self! ! 305145 305146!RxsCharSet methodsFor: 'accessing' stamp: 'avi 11/30/2003 13:28'! 305147hasPredicates 305148 ^elements anySatisfy: [:some | some isEnumerable not]! ! 305149 305150!RxsCharSet methodsFor: 'accessing'! 305151predicate 305152 | predicate enumerable | 305153 enumerable := self enumerablePartPredicate. 305154 ^self hasPredicates 305155 ifFalse: [enumerable] 305156 ifTrue: 305157 [predicate := self predicatePartPredicate. 305158 negated 305159 ifTrue: [[:char | (enumerable value: char) and: [predicate value: char]]] 305160 ifFalse: [[:char | (enumerable value: char) or: [predicate value: char]]]]! ! 305161 305162!RxsCharSet methodsFor: 'accessing'! 305163predicates 305164 ^(elements reject: [:some | some isEnumerable]) 305165 collect: [:each | each predicate]! ! 305166 305167 305168!RxsCharSet methodsFor: 'initialize-release'! 305169initializeElements: aCollection negated: aBoolean 305170 "See class comment for instance variables description." 305171 elements := aCollection. 305172 negated := aBoolean! ! 305173 305174 305175!RxsCharSet methodsFor: 'privileged'! 305176enumerablePartPredicate 305177 | enumeration | 305178 enumeration := self optimalSet. 305179 ^negated 305180 ifTrue: [[:char | (enumeration includes: char) not]] 305181 ifFalse: [[:char | enumeration includes: char]]! ! 305182 305183!RxsCharSet methodsFor: 'privileged'! 305184enumerableSet 305185 "Answer a collection of characters that make up the portion of me 305186 that can be enumerated." 305187 | set | 305188 set := Set new. 305189 elements do: 305190 [:each | 305191 each isEnumerable ifTrue: [each enumerateTo: set]]. 305192 ^set! ! 305193 305194!RxsCharSet methodsFor: 'privileged' stamp: 'avi 11/30/2003 13:28'! 305195optimalSet 305196 "Assuming the client with search the `set' using #includes:, 305197 answer a collection with the contents of `set', of the class 305198 that will provide the fastest lookup. Strings are faster than 305199 Sets for short strings." 305200 | set | 305201 set := self enumerableSet. 305202 ^set size < 10 305203 ifTrue: [String withAll: set asArray] 305204 ifFalse: [set]! ! 305205 305206!RxsCharSet methodsFor: 'privileged'! 305207predicatePartPredicate 305208 "Answer a predicate that tests all of my elements that cannot be 305209 enumerated." 305210 | predicates | 305211 predicates := elements reject: [:some | some isEnumerable]. 305212 predicates isEmpty 305213 ifTrue: [^[:char | negated]]. 305214 predicates size = 1 305215 ifTrue: [^negated 305216 ifTrue: [predicates first predicateNegation] 305217 ifFalse: [predicates first predicate]]. 305218 predicates := predicates collect: [:each | each predicate]. 305219 ^negated 305220 ifFalse: 305221 [[:char | predicates contains: [:some | some value: char]]] 305222 ifTrue: 305223 [[:char | (predicates contains: [:some | some value: char]) not]]! ! 305224 305225 305226!RxsCharSet methodsFor: 'testing'! 305227isEnumerable 305228 elements detect: [:some | some isEnumerable not] ifNone: [^true]. 305229 ^false! ! 305230 305231!RxsCharSet methodsFor: 'testing'! 305232isNegated 305233 ^negated! ! 305234RxsNode subclass: #RxsCharacter 305235 instanceVariableNames: 'character' 305236 classVariableNames: '' 305237 poolDictionaries: '' 305238 category: 'VB-Regex'! 305239!RxsCharacter commentStamp: '<historical>' prior: 0! 305240-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 305241-- See `documentation' protocol of RxParser class for user's guide. 305242-- 305243A character is a literal character that appears either in the expression itself or in a character set within an expression. 305244Instance variables: 305245 character <Character>! 305246 305247 305248!RxsCharacter methodsFor: 'accessing'! 305249character 305250 ^character! ! 305251 305252!RxsCharacter methodsFor: 'accessing'! 305253dispatchTo: aMatcher 305254 "Inform the matcher of the kind of the node, and it 305255 will do whatever it has to." 305256 ^aMatcher syntaxCharacter: self! ! 305257 305258!RxsCharacter methodsFor: 'accessing'! 305259enumerateTo: aCollection 305260 aCollection add: character! ! 305261 305262 305263!RxsCharacter methodsFor: 'initialize-release'! 305264initializeCharacter: aCharacter 305265 "See class comment for instance variable description." 305266 character := aCharacter! ! 305267 305268 305269!RxsCharacter methodsFor: 'testing'! 305270isAtomic 305271 "A character is always atomic." 305272 ^true! ! 305273 305274!RxsCharacter methodsFor: 'testing'! 305275isEnumerable 305276 ^true! ! 305277 305278!RxsCharacter methodsFor: 'testing'! 305279isNullable 305280 ^false! ! 305281 305282"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 305283 305284RxsCharacter class 305285 instanceVariableNames: ''! 305286 305287!RxsCharacter class methodsFor: 'instance creation'! 305288with: aCharacter 305289 ^self new initializeCharacter: aCharacter! ! 305290RxsNode subclass: #RxsContextCondition 305291 instanceVariableNames: 'kind' 305292 classVariableNames: '' 305293 poolDictionaries: '' 305294 category: 'VB-Regex'! 305295!RxsContextCondition commentStamp: '<historical>' prior: 0! 305296-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 305297-- See `documentation' protocol of RxParser class for user's guide. 305298-- 305299One of a few special nodes more often representing special state of the match rather than a predicate on a character. The ugly exception is the #any condition which *is* a predicate on a character. 305300Instance variables: 305301 kind <Selector>! 305302 305303 305304!RxsContextCondition methodsFor: 'accessing'! 305305dispatchTo: aBuilder 305306 ^aBuilder perform: kind! ! 305307 305308 305309!RxsContextCondition methodsFor: 'initialize-release'! 305310beAny 305311 "Matches anything but a newline." 305312 kind := #syntaxAny! ! 305313 305314!RxsContextCondition methodsFor: 'initialize-release'! 305315beBeginningOfLine 305316 "Matches empty string at the beginning of a line." 305317 kind := #syntaxBeginningOfLine! ! 305318 305319!RxsContextCondition methodsFor: 'initialize-release'! 305320beBeginningOfWord 305321 "Matches empty string at the beginning of a word." 305322 kind := #syntaxBeginningOfWord! ! 305323 305324!RxsContextCondition methodsFor: 'initialize-release'! 305325beEndOfLine 305326 "Matches empty string at the end of a line." 305327 kind := #syntaxEndOfLine! ! 305328 305329!RxsContextCondition methodsFor: 'initialize-release'! 305330beEndOfWord 305331 "Matches empty string at the end of a word." 305332 kind := #syntaxEndOfWord! ! 305333 305334!RxsContextCondition methodsFor: 'initialize-release'! 305335beNonWordBoundary 305336 "Analog of \B." 305337 kind := #syntaxNonWordBoundary! ! 305338 305339!RxsContextCondition methodsFor: 'initialize-release'! 305340beWordBoundary 305341 "Analog of \w (alphanumeric plus :=)." 305342 kind := #syntaxWordBoundary! ! 305343 305344 305345!RxsContextCondition methodsFor: 'testing'! 305346isNullable 305347 ^#syntaxAny ~~ kind! ! 305348RxsNode subclass: #RxsEpsilon 305349 instanceVariableNames: '' 305350 classVariableNames: '' 305351 poolDictionaries: '' 305352 category: 'VB-Regex'! 305353!RxsEpsilon commentStamp: '<historical>' prior: 0! 305354-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 305355-- See `documentation' protocol of RxParser class for user's guide. 305356-- 305357This is an empty string. It terminates some of the recursive constructs.! 305358 305359 305360!RxsEpsilon methodsFor: 'building'! 305361dispatchTo: aBuilder 305362 "Inform the matcher of the kind of the node, and it 305363 will do whatever it has to." 305364 ^aBuilder syntaxEpsilon! ! 305365 305366 305367!RxsEpsilon methodsFor: 'testing'! 305368isNullable 305369 "See comment in the superclass." 305370 ^true! ! 305371RxsNode subclass: #RxsMessagePredicate 305372 instanceVariableNames: 'selector negated' 305373 classVariableNames: '' 305374 poolDictionaries: '' 305375 category: 'VB-Regex'! 305376!RxsMessagePredicate commentStamp: '<historical>' prior: 0! 305377-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 305378-- See `documentation' protocol of RxParser class for user's guide. 305379-- 305380A message predicate represents a condition on a character that is tested (at the match time) by sending a unary message to the character expecting a Boolean answer. 305381Instance variables: 305382 selector <Symbol>! 305383 305384 305385!RxsMessagePredicate methodsFor: 'accessing'! 305386dispatchTo: aBuilder 305387 "Inform the matcher of the kind of the node, and it 305388 will do whatever it has to." 305389 ^aBuilder syntaxMessagePredicate: self! ! 305390 305391!RxsMessagePredicate methodsFor: 'accessing'! 305392negated 305393 ^negated! ! 305394 305395!RxsMessagePredicate methodsFor: 'accessing'! 305396selector 305397 ^selector! ! 305398 305399 305400!RxsMessagePredicate methodsFor: 'initialize-release'! 305401initializeSelector: aSelector 305402 "The selector must be a one-argument message understood by Character." 305403 selector := aSelector! ! 305404 305405!RxsMessagePredicate methodsFor: 'initialize-release'! 305406initializeSelector: aSelector negated: aBoolean 305407 "The selector must be a one-argument message understood by Character." 305408 selector := aSelector. 305409 negated := aBoolean! ! 305410Object subclass: #RxsNode 305411 instanceVariableNames: '' 305412 classVariableNames: '' 305413 poolDictionaries: '' 305414 category: 'VB-Regex'! 305415!RxsNode commentStamp: '<historical>' prior: 0! 305416-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 305417-- See `documentation' protocol of RxParser class for user's guide. 305418-- 305419A generic syntax tree node, provides some common responses to the standard tests, as well as tree structure printing -- handy for debugging.! 305420 305421 305422!RxsNode methodsFor: 'constants'! 305423indentCharacter 305424 "Normally, #printOn:withIndent: method in subclasses 305425 print several characters returned by this method to indicate 305426 the tree structure." 305427 ^$+! ! 305428 305429 305430!RxsNode methodsFor: 'testing'! 305431isAtomic 305432 "Answer whether the node is atomic, i.e. matches exactly one 305433 constant predefined normal character. A matcher may decide to 305434 optimize matching of a sequence of atomic nodes by glueing them 305435 together in a string." 305436 ^false "tentatively"! ! 305437 305438!RxsNode methodsFor: 'testing'! 305439isNullable 305440 "True if the node can match an empty sequence of characters." 305441 ^false "for most nodes"! ! 305442RxsNode subclass: #RxsPiece 305443 instanceVariableNames: 'atom min max' 305444 classVariableNames: '' 305445 poolDictionaries: '' 305446 category: 'VB-Regex'! 305447!RxsPiece commentStamp: '<historical>' prior: 0! 305448-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 305449-- See `documentation' protocol of RxParser class for user's guide. 305450-- 305451A piece is an atom, possibly optional or repeated a number of times. 305452Instance variables: 305453 atom <RxsCharacter|RxsCharSet|RxsPredicate|RxsRegex|RxsSpecial> 305454 min <Integer> 305455 max <Integer|nil> nil means infinity! 305456 305457 305458!RxsPiece methodsFor: 'accessing'! 305459atom 305460 ^atom! ! 305461 305462!RxsPiece methodsFor: 'accessing'! 305463character 305464 "If this node is atomic, answer the character it 305465 represents. It is the caller's responsibility to make sure this 305466 node is indeed atomic before using this." 305467 ^atom character! ! 305468 305469!RxsPiece methodsFor: 'accessing'! 305470dispatchTo: aMatcher 305471 "Inform the matcher of the kind of the node, and it 305472 will do whatever it has to." 305473 ^aMatcher syntaxPiece: self! ! 305474 305475!RxsPiece methodsFor: 'accessing'! 305476max 305477 "The value answered may be nil, indicating infinity." 305478 ^max! ! 305479 305480!RxsPiece methodsFor: 'accessing'! 305481min 305482 ^min! ! 305483 305484 305485!RxsPiece methodsFor: 'initialize-release'! 305486initializeAtom: anAtom 305487 "This piece is exactly one occurrence of the specified RxsAtom." 305488 self initializeAtom: anAtom min: 1 max: 1! ! 305489 305490!RxsPiece methodsFor: 'initialize-release'! 305491initializeAtom: anAtom min: minOccurrences max: maxOccurrences 305492 "This piece is from <minOccurrences> to <maxOccurrences> 305493 occurrences of the specified RxsAtom." 305494 atom := anAtom. 305495 min := minOccurrences. 305496 max := maxOccurrences! ! 305497 305498!RxsPiece methodsFor: 'initialize-release'! 305499initializeOptionalAtom: anAtom 305500 "This piece is 0 or 1 occurrences of the specified RxsAtom." 305501 self initializeAtom: anAtom min: 0 max: 1! ! 305502 305503!RxsPiece methodsFor: 'initialize-release'! 305504initializePlusAtom: anAtom 305505 "This piece is one or more occurrences of the specified RxsAtom." 305506 self initializeAtom: anAtom min: 1 max: nil! ! 305507 305508!RxsPiece methodsFor: 'initialize-release'! 305509initializeStarAtom: anAtom 305510 "This piece is any number of occurrences of the atom." 305511 self initializeAtom: anAtom min: 0 max: nil! ! 305512 305513 305514!RxsPiece methodsFor: 'testing'! 305515isAtomic 305516 "A piece is atomic if only it contains exactly one atom 305517 which is atomic (sic)." 305518 ^self isSingular and: [atom isAtomic]! ! 305519 305520!RxsPiece methodsFor: 'testing'! 305521isNullable 305522 "A piece is nullable if it allows 0 matches. 305523 This is often handy to know for optimization." 305524 ^min = 0 or: [atom isNullable]! ! 305525 305526!RxsPiece methodsFor: 'testing'! 305527isOptional 305528 ^min = 0 and: [max = 1]! ! 305529 305530!RxsPiece methodsFor: 'testing'! 305531isPlus 305532 ^min = 1 and: [max == nil]! ! 305533 305534!RxsPiece methodsFor: 'testing'! 305535isSingular 305536 "A piece with a range is 1 to 1 needs can be compiled 305537 as a simple match." 305538 ^min = 1 and: [max = 1]! ! 305539 305540!RxsPiece methodsFor: 'testing'! 305541isStar 305542 ^min = 0 and: [max == nil]! ! 305543RxsNode subclass: #RxsPredicate 305544 instanceVariableNames: 'predicate negation' 305545 classVariableNames: 'EscapedLetterSelectors NamedClassSelectors' 305546 poolDictionaries: '' 305547 category: 'VB-Regex'! 305548!RxsPredicate commentStamp: '<historical>' prior: 0! 305549-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 305550-- See `documentation' protocol of RxParser class for user's guide. 305551-- 305552This represents a character that satisfies a certain predicate. 305553Instance Variables: 305554 predicate <BlockClosure> A one-argument block. If it evaluates to the value defined by <negated> when it is passed a character, the predicate is considered to match. 305555 negation <BlockClosure> A one-argument block that is a negation of <predicate>.! 305556 305557 305558!RxsPredicate methodsFor: 'accessing'! 305559dispatchTo: anObject 305560 ^anObject syntaxPredicate: self! ! 305561 305562!RxsPredicate methodsFor: 'accessing'! 305563negated 305564 ^self copy negate! ! 305565 305566!RxsPredicate methodsFor: 'accessing'! 305567predicate 305568 ^predicate! ! 305569 305570!RxsPredicate methodsFor: 'accessing'! 305571predicateNegation 305572 ^negation! ! 305573 305574!RxsPredicate methodsFor: 'accessing'! 305575value: aCharacter 305576 ^predicate value: aCharacter! ! 305577 305578 305579!RxsPredicate methodsFor: 'initialize-release'! 305580beAlphaNumeric 305581 predicate := [:char | char isAlphaNumeric]. 305582 negation := [:char | char isAlphaNumeric not]! ! 305583 305584!RxsPredicate methodsFor: 'initialize-release'! 305585beAlphabetic 305586 predicate := [:char | char isAlphabetic]. 305587 negation := [:char | char isAlphabetic not]! ! 305588 305589!RxsPredicate methodsFor: 'initialize-release'! 305590beAny 305591 | cr lf | 305592 cr := Character cr. 305593 lf := Character lf. 305594 predicate := [:char | char ~= lf and: [char ~= cr]]. 305595 negation := [:char | char = lf or: [char = cr]]! ! 305596 305597!RxsPredicate methodsFor: 'initialize-release'! 305598beControl 305599 predicate := [:char | char asInteger < 32]. 305600 negation := [:char | char asInteger >= 32]! ! 305601 305602!RxsPredicate methodsFor: 'initialize-release'! 305603beDigit 305604 predicate := [:char | char isDigit]. 305605 negation := [:char | char isDigit not]! ! 305606 305607!RxsPredicate methodsFor: 'initialize-release'! 305608beGraphics 305609 self 305610 beControl; 305611 negate! ! 305612 305613!RxsPredicate methodsFor: 'initialize-release'! 305614beHexDigit 305615 | hexLetters | 305616 hexLetters := 'abcdefABCDEF'. 305617 predicate := [:char | char isDigit or: [hexLetters includes: char]]. 305618 negation := [:char | char isDigit not and: [(hexLetters includes: char) not]]! ! 305619 305620!RxsPredicate methodsFor: 'initialize-release'! 305621beLowercase 305622 predicate := [:char | char isLowercase]. 305623 negation := [:char | char isLowercase not]! ! 305624 305625!RxsPredicate methodsFor: 'initialize-release'! 305626beNotDigit 305627 self 305628 beDigit; 305629 negate! ! 305630 305631!RxsPredicate methodsFor: 'initialize-release'! 305632beNotSpace 305633 self 305634 beSpace; 305635 negate! ! 305636 305637!RxsPredicate methodsFor: 'initialize-release'! 305638beNotWordConstituent 305639 self 305640 beWordConstituent; 305641 negate! ! 305642 305643!RxsPredicate methodsFor: 'initialize-release'! 305644bePrintable 305645 self 305646 beControl; 305647 negate! ! 305648 305649!RxsPredicate methodsFor: 'initialize-release'! 305650bePunctuation 305651 | punctuationChars | 305652 punctuationChars := #($. $, $!! $; $: $" $' $- $( $) $`). 305653 predicate := [:char | punctuationChars includes: char]. 305654 negation := [:char | (punctuationChars includes: char) not]! ! 305655 305656!RxsPredicate methodsFor: 'initialize-release'! 305657beSpace 305658 predicate := [:char | char isSeparator]. 305659 negation := [:char | char isSeparator not]! ! 305660 305661!RxsPredicate methodsFor: 'initialize-release'! 305662beUppercase 305663 predicate := [:char | char isUppercase]. 305664 negation := [:char | char isUppercase not]! ! 305665 305666!RxsPredicate methodsFor: 'initialize-release'! 305667beWordConstituent 305668 predicate := [:char | char isAlphaNumeric]. 305669 negation := [:char | char isAlphaNumeric not]! ! 305670 305671 305672!RxsPredicate methodsFor: 'testing'! 305673isAtomic 305674 "A predicate is a single character but the character is not known in advance." 305675 ^false! ! 305676 305677!RxsPredicate methodsFor: 'testing'! 305678isEnumerable 305679 ^false! ! 305680 305681 305682!RxsPredicate methodsFor: 'private'! 305683negate 305684 | tmp | 305685 tmp := predicate. 305686 predicate := negation. 305687 negation := tmp! ! 305688 305689"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 305690 305691RxsPredicate class 305692 instanceVariableNames: ''! 305693 305694!RxsPredicate class methodsFor: 'class initialization'! 305695initialize 305696 "self initialize" 305697 self 305698 initializeNamedClassSelectors; 305699 initializeEscapedLetterSelectors! ! 305700 305701!RxsPredicate class methodsFor: 'class initialization'! 305702initializeEscapedLetterSelectors 305703 "self initializeEscapedLetterSelectors" 305704 (EscapedLetterSelectors := Dictionary new) 305705 at: $w put: #beWordConstituent; 305706 at: $W put: #beNotWordConstituent; 305707 at: $d put: #beDigit; 305708 at: $D put: #beNotDigit; 305709 at: $s put: #beSpace; 305710 at: $S put: #beNotSpace! ! 305711 305712!RxsPredicate class methodsFor: 'class initialization'! 305713initializeNamedClassSelectors 305714 "self initializeNamedClassSelectors" 305715 (NamedClassSelectors := Dictionary new) 305716 at: 'alnum' put: #beAlphaNumeric; 305717 at: 'alpha' put: #beAlphabetic; 305718 at: 'cntrl' put: #beControl; 305719 at: 'digit' put: #beDigit; 305720 at: 'graph' put: #beGraphics; 305721 at: 'lower' put: #beLowercase; 305722 at: 'print' put: #bePrintable; 305723 at: 'punct' put: #bePunctuation; 305724 at: 'space' put: #beSpace; 305725 at: 'upper' put: #beUppercase; 305726 at: 'xdigit' put: #beHexDigit! ! 305727 305728 305729!RxsPredicate class methodsFor: 'instance creation'! 305730forEscapedLetter: aCharacter 305731 ^self new perform: 305732 (EscapedLetterSelectors 305733 at: aCharacter 305734 ifAbsent: [RxParser signalSyntaxException: 'bad backslash escape'])! ! 305735 305736!RxsPredicate class methodsFor: 'instance creation'! 305737forNamedClass: aString 305738 ^self new perform: 305739 (NamedClassSelectors 305740 at: aString 305741 ifAbsent: [RxParser signalSyntaxException: 'bad character class name'])! ! 305742RxsNode subclass: #RxsRange 305743 instanceVariableNames: 'first last' 305744 classVariableNames: '' 305745 poolDictionaries: '' 305746 category: 'VB-Regex'! 305747!RxsRange commentStamp: '<historical>' prior: 0! 305748-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 305749-- See `documentation' protocol of RxParser class for user's guide. 305750-- 305751I represent a range of characters as appear in character classes such as 305752 [a-ZA-Z0-9]. 305753I appear in a syntax tree only as an element of RxsCharSet. 305754Instance Variables: 305755 first <Character> 305756 last <Character>! 305757 305758 305759!RxsRange methodsFor: 'accessing'! 305760enumerateTo: aCollection 305761 "Add all of the elements I represent to the collection." 305762 first asInteger to: last asInteger do: 305763 [:charCode | 305764 aCollection add: charCode asCharacter]! ! 305765 305766 305767!RxsRange methodsFor: 'initialize-release'! 305768initializeFirst: aCharacter last: anotherCharacter 305769 first := aCharacter. 305770 last := anotherCharacter! ! 305771 305772 305773!RxsRange methodsFor: 'testing'! 305774isEnumerable 305775 ^true! ! 305776 305777"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 305778 305779RxsRange class 305780 instanceVariableNames: ''! 305781 305782!RxsRange class methodsFor: 'instance creation'! 305783from: aCharacter to: anotherCharacter 305784 ^self new initializeFirst: aCharacter last: anotherCharacter! ! 305785RxsNode subclass: #RxsRegex 305786 instanceVariableNames: 'branch regex' 305787 classVariableNames: '' 305788 poolDictionaries: '' 305789 category: 'VB-Regex'! 305790!RxsRegex commentStamp: '<historical>' prior: 0! 305791-- Regular Expression Matcher v 1.1 (C) 1996, 1999 Vassili Bykov 305792-- See `documentation' protocol of RxParser class for user's guide. 305793-- 305794The body of a parenthesized thing, or a top-level expression, also an atom. 305795Instance variables: 305796 branch <RxsBranch> 305797 regex <RxsRegex | RxsEpsilon>! 305798 305799 305800!RxsRegex methodsFor: 'accessing'! 305801branch 305802 ^branch! ! 305803 305804!RxsRegex methodsFor: 'accessing'! 305805dispatchTo: aMatcher 305806 "Inform the matcher of the kind of the node, and it 305807 will do whatever it has to." 305808 ^aMatcher syntaxRegex: self! ! 305809 305810!RxsRegex methodsFor: 'accessing'! 305811regex 305812 ^regex! ! 305813 305814 305815!RxsRegex methodsFor: 'initialize-release'! 305816initializeBranch: aBranch regex: aRegex 305817 "See class comment for instance variable description." 305818 branch := aBranch. 305819 regex := aRegex! ! 305820 305821 305822!RxsRegex methodsFor: 'testing'! 305823isNullable 305824 ^branch isNullable or: [regex notNil and: [regex isNullable]]! ! 305825Model subclass: #SARInstaller 305826 instanceVariableNames: 'zip directory fileName installed' 305827 classVariableNames: '' 305828 poolDictionaries: '' 305829 category: 'System-Support'! 305830!SARInstaller commentStamp: 'nk 7/5/2003 21:12' prior: 0! 305831I am an object that handles the loading of SAR (Squeak ARchive) files. 305832 305833A SAR file is a Zip file that follows certain simple conventions: 305834 305835* it may have a member named "install/preamble". 305836 305837This member, if present, will be filed in as Smalltalk source code at the beginning of installation. 305838Typically, the code in the preamble will make whatever installation preparations are necessary, 305839and will then call methods in the "client services" method category to extract or install other zip members. 305840 305841* It may have a member named "install/postscript". 305842 305843This member, if present, will be filed in as Smalltalk source code at the end of installation. 305844Typically, the code in the postscript will set up the operating environment, 305845and will perhaps put objects in flaps, open projects or README files, or launch samples. 305846 305847Within the code in the preamble and postscript, "self" is set to the instance of the SARInstaller. 305848 305849If neither an "install/preamble" nor an "install/postscript" file is present, 305850all the members will be installed after prompting the user, 305851based on a best guess of the member file types that is based on member filename extensions. 305852 305853This is new behavior.! 305854 305855 305856!SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'! 305857directory 305858 ^directory! ! 305859 305860!SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'! 305861directory: anObject 305862 directory := anObject! ! 305863 305864!SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'! 305865fileName 305866 ^fileName! ! 305867 305868!SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'! 305869fileName: anObject 305870 fileName := anObject! ! 305871 305872!SARInstaller methodsFor: 'accessing' stamp: 'nk 7/5/2003 23:01'! 305873installedMemberNames 305874 "Answer the names of the zip members that have been installed already." 305875 ^self installedMembers collect: [ :ea | ea fileName ]! ! 305876 305877!SARInstaller methodsFor: 'accessing' stamp: 'nk 7/10/2003 16:53'! 305878installedMembers 305879 "Answer the zip members that have been installed already." 305880 ^installed ifNil: [ installed := OrderedCollection new ]! ! 305881 305882!SARInstaller methodsFor: 'accessing' stamp: 'nk 7/5/2003 21:57'! 305883memberNames 305884 ^self zip memberNames! ! 305885 305886!SARInstaller methodsFor: 'accessing' stamp: 'nk 7/5/2003 23:00'! 305887uninstalledMemberNames 305888 "Answer the names of the zip members that have not yet been installed." 305889 ^self uninstalledMembers collect: [ :ea | ea fileName ]! ! 305890 305891!SARInstaller methodsFor: 'accessing' stamp: 'nk 7/10/2003 16:55'! 305892uninstalledMembers 305893 "Answer the zip members that haven't been installed or extracted yet." 305894 ^zip members copyWithoutAll: self installedMembers! ! 305895 305896!SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'! 305897zip 305898 ^zip! ! 305899 305900!SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'! 305901zip: anObject 305902 ^zip := anObject! ! 305903 305904 305905!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:25'! 305906extractMember: aMemberOrName 305907 "Extract aMemberOrName to a file using its filename" 305908 (self zip extractMember: aMemberOrName) 305909 ifNil: [ self errorNoSuchMember: aMemberOrName ] 305910 ifNotNil: [ self installed: aMemberOrName ].! ! 305911 305912!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:25'! 305913extractMember: aMemberOrName toFileNamed: aFileName 305914 "Extract aMemberOrName to a specified filename" 305915 (self zip extractMember: aMemberOrName toFileNamed: aFileName) 305916 ifNil: [ self errorNoSuchMember: aMemberOrName ] 305917 ifNotNil: [ self installed: aMemberOrName ].! ! 305918 305919!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:40'! 305920extractMemberWithoutPath: aMemberOrName 305921 "Extract aMemberOrName to its own filename, but ignore any directory paths, using my directory instead." 305922 self extractMemberWithoutPath: aMemberOrName inDirectory: self directory. 305923! ! 305924 305925!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:40'! 305926extractMemberWithoutPath: aMemberOrName inDirectory: aDirectory 305927 "Extract aMemberOrName to its own filename, but ignore any directory paths, using aDirectory instead" 305928 | member | 305929 member := self memberNamed: aMemberOrName. 305930 member ifNil: [ ^self errorNoSuchMember: aMemberOrName ]. 305931 self zip extractMemberWithoutPath: member inDirectory: aDirectory. 305932 self installed: member.! ! 305933 305934!SARInstaller methodsFor: 'client services' stamp: 'yo 8/17/2004 10:01'! 305935fileInMemberNamed: csName 305936 "This is to be used from preamble/postscript code to file in zip members as ChangeSets." 305937 | cs | 305938 cs := self memberNamed: csName. 305939 cs ifNil: [ ^self errorNoSuchMember: csName ]. 305940 self class fileIntoChangeSetNamed: csName fromStream: cs contentStream text setConverterForCode. 305941 self installed: cs. 305942! ! 305943 305944!SARInstaller methodsFor: 'client services' stamp: 'ar 9/27/2005 20:10'! 305945fileInMonticelloPackageNamed: memberName 305946 "This is to be used from preamble/postscript code to file in zip 305947 members as Monticello packages (.mc)." 305948 305949 | member file mcPackagePanel mcRevisionInfo mcSnapshot mcFilePackageManager mcPackage info snapshot newCS mcBootstrap | 305950 305951 mcPackagePanel := Smalltalk at: #MCPackagePanel ifAbsent: [ ]. 305952 mcRevisionInfo := Smalltalk at: #MCRevisionInfo ifAbsent: [ ]. 305953 mcSnapshot := Smalltalk at: #MCSnapshot ifAbsent: [ ]. 305954 mcFilePackageManager := Smalltalk at: #MCFilePackageManager ifAbsent: [ ]. 305955 mcPackage := Smalltalk at: #MCPackage ifAbsent: [ ]. 305956 member := self memberNamed: memberName. 305957 member ifNil: [ ^self errorNoSuchMember: memberName ]. 305958 305959 "We are missing MCInstaller, Monticello and/or MonticelloCVS. 305960 If the bootstrap is present, use it. Otherwise interact with the user." 305961 ({ mcPackagePanel. mcRevisionInfo. mcSnapshot. mcFilePackageManager. mcPackage } includes: nil) 305962 ifTrue: [ 305963 mcBootstrap := self getMCBootstrapLoaderClass. 305964 mcBootstrap ifNotNil: [ ^self fileInMCVersion: member withBootstrap: mcBootstrap ]. 305965 305966 (self confirm: ('Monticello support is not installed, but must be to load member named ', memberName, '. 305967Load it from SqueakMap?')) 305968 ifTrue: [ self class loadMonticello; loadMonticelloCVS. 305969 ^self fileInMonticelloPackageNamed: memberName ] 305970 ifFalse: [ ^false ] ]. 305971 305972 member extractToFileNamed: member localFileName inDirectory: self directory. 305973 file := (Smalltalk at: #MCFile) 305974 name: member localFileName 305975 directory: self directory. 305976 305977 self class withCurrentChangeSetNamed: file name do: [ :cs | 305978 newCS := cs. 305979 file readStreamDo: [ :stream | 305980 info := mcRevisionInfo readFrom: stream nextChunk. 305981 snapshot := mcSnapshot fromStream: stream ]. 305982 snapshot install. 305983 (mcFilePackageManager forPackage: 305984 (mcPackage named: info packageName)) 305985 file: file 305986 ]. 305987 305988 newCS isEmpty ifTrue: [ ChangeSet removeChangeSet: newCS ]. 305989 305990 mcPackagePanel allSubInstancesDo: [ :ea | ea refresh ]. 305991 World doOneCycle. 305992 305993 self installed: member. 305994! ! 305995 305996!SARInstaller methodsFor: 'client services' stamp: 'ar 9/27/2005 20:10'! 305997fileInMonticelloVersionNamed: memberName 305998 "This is to be used from preamble/postscript code to file in zip 305999 members as Monticello version (.mcv) files." 306000 306001 | member newCS mcMcvReader | 306002 mcMcvReader := Smalltalk at: #MCMcvReader ifAbsent: []. 306003 member := self memberNamed: memberName. 306004 member ifNil: [^self errorNoSuchMember: memberName]. 306005 306006 "If we don't have Monticello, offer to get it." 306007 mcMcvReader ifNil: [ 306008 (self confirm: 'Monticello is not installed, but must be to load member named ', memberName , '. 306009Load it from SqueakMap?') 306010 ifTrue: [ self class loadMonticello. 306011 ^self fileInMonticelloVersionNamed: memberName] 306012 ifFalse: [^false]]. 306013 306014 self class withCurrentChangeSetNamed: member localFileName 306015 do: 306016 [:cs | 306017 newCS := cs. 306018 (mcMcvReader versionFromStream: member contentStream ascii) load ]. 306019 newCS isEmpty ifTrue: [ChangeSet removeChangeSet: newCS]. 306020 World doOneCycle. 306021 self installed: member! ! 306022 306023!SARInstaller methodsFor: 'client services' stamp: 'ar 9/27/2005 20:10'! 306024fileInMonticelloZipVersionNamed: memberName 306025 "This is to be used from preamble/postscript code to file in zip 306026 members as Monticello version (.mcz) files." 306027 306028 | member mczInstaller newCS mcMczReader | 306029 mcMczReader := Smalltalk at: #MCMczReader ifAbsent: []. 306030 mczInstaller := Smalltalk at: #MczInstaller ifAbsent: []. 306031 member := self memberNamed: memberName. 306032 member ifNil: [^self errorNoSuchMember: memberName]. 306033 306034 "If we don't have Monticello, but have the bootstrap, use it silently." 306035 mcMczReader ifNil: [ 306036 mczInstaller ifNotNil: [ ^mczInstaller installStream: member contentStream ]. 306037 (self confirm: 'Monticello is not installed, but must be to load member named ', memberName , '. 306038Load it from SqueakMap?') 306039 ifTrue: [ self class loadMonticello. 306040 ^self fileInMonticelloZipVersionNamed: memberName] 306041 ifFalse: [^false]]. 306042 306043 self class withCurrentChangeSetNamed: member localFileName 306044 do: 306045 [:cs | 306046 newCS := cs. 306047 (mcMczReader versionFromStream: member contentStream) load ]. 306048 newCS isEmpty ifTrue: [ChangeSet removeChangeSet: newCS]. 306049 World doOneCycle. 306050 self installed: member! ! 306051 306052!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:27'! 306053fileInMorphsNamed: memberName addToWorld: aBoolean 306054 "This will load the Morph (or Morphs) from the given member. 306055 Answers a Morph, or a list of Morphs, or nil if no such member or error. 306056 If aBoolean is true, also adds them and their models to the World." 306057 306058 | member morphOrList | 306059 member := self memberNamed: memberName. 306060 member ifNil: [ ^self errorNoSuchMember: memberName ]. 306061 self installed: member. 306062 306063 morphOrList := member contentStream fileInObjectAndCode. 306064 morphOrList ifNil: [ ^nil ]. 306065 aBoolean ifTrue: [ ActiveWorld addMorphsAndModel: morphOrList ]. 306066 306067 ^morphOrList 306068! ! 306069 306070!SARInstaller methodsFor: 'client services' stamp: 'yo 8/17/2004 10:05'! 306071fileInPackageNamed: memberName 306072 "This is to be used from preamble/postscript code to file in zip 306073 members as DVS packages." 306074 | member current new baseName imagePackageLoader packageInfo streamPackageLoader packageManager | 306075 member := self zip memberNamed: memberName. 306076 member ifNil: [ ^self errorNoSuchMember: memberName ]. 306077 306078 imagePackageLoader := Smalltalk at: #ImagePackageLoader ifAbsent: []. 306079 streamPackageLoader := Smalltalk at: #StreamPackageLoader ifAbsent: []. 306080 packageInfo := Smalltalk at: #PackageInfo ifAbsent: []. 306081 packageManager := Smalltalk at: #FilePackageManager ifAbsent: []. 306082 306083 "If DVS isn't present, do a simple file-in" 306084 (packageInfo isNil or: [imagePackageLoader isNil or: [streamPackageLoader isNil]]) 306085 ifTrue: [ ^ self fileInMemberNamed: memberName ]. 306086 306087 baseName := memberName copyReplaceAll: '.st' with: '' asTokens: false. 306088 (packageManager allManagers anySatisfy: [ :pm | pm packageName = baseName ]) 306089 ifTrue: [ 306090 current := imagePackageLoader new package: (packageInfo named: baseName). 306091 new := streamPackageLoader new stream: member contentStream ascii. 306092 (new changesFromBase: current) fileIn ] 306093 ifFalse: [ self class fileIntoChangeSetNamed: baseName fromStream: member contentStream ascii setConverterForCode. ]. 306094 306095 packageManager registerPackage: baseName. 306096 306097 self installed: member.! ! 306098 306099!SARInstaller methodsFor: 'client services' stamp: 'nk 9/26/2003 17:17'! 306100fileInTrueTypeFontNamed: memberOrName 306101 306102 | member description | 306103 member := self memberNamed: memberOrName. 306104 member ifNil: [^self errorNoSuchMember: memberOrName]. 306105 306106 description := TTFontDescription addFromTTStream: member contentStream. 306107 TTCFont newTextStyleFromTT: description. 306108 306109 World doOneCycle. 306110 self installed: member! ! 306111 306112!SARInstaller methodsFor: 'client services' stamp: 'marcus.denker 11/10/2008 10:04'! 306113getMCBootstrapLoaderClass 306114 ^Smalltalk at: #MCBootstrapLoader 306115 ifAbsent: 306116 [(self memberNamed: 'MCBootstrapLoader.st') 306117 ifNotNil: [:m | self fileInMemberNamed: m. 306118 Smalltalk at: #MCBootstrapLoader ifAbsent: []]]! ! 306119 306120!SARInstaller methodsFor: 'client services' stamp: 'nk 10/14/2003 15:40'! 306121importImage: memberOrName 306122 | member form | 306123 member := self memberNamed: memberOrName. 306124 member ifNil: [ ^self errorNoSuchMember: memberOrName ]. 306125 form := ImageReadWriter formFromStream: member contentStream binary. 306126 form ifNil: [ ^self ]. 306127 Imports default importImage: form named: (FileDirectory localNameFor: member fileName) sansPeriodSuffix. 306128 self installed: member.! ! 306129 306130!SARInstaller methodsFor: 'client services' stamp: 'stephane.ducasse 7/10/2009 17:30'! 306131installMember: memberOrName 306132 | memberName extension isGraphic stream member | 306133 member := self memberNamed: memberOrName. 306134 member ifNil: [ ^false ]. 306135 memberName := member fileName. 306136 extension := (FileDirectory extensionFor: memberName) asLowercase. 306137 extension caseOf: { 306138 [ FileStream st ] -> [ self fileInPackageNamed: memberName ]. 306139 [ FileStream cs ] -> [ self fileInMemberNamed: memberName ]. 306140" [ FileStream multiSt ] -> [ self fileInMemberNamedAsUTF8: memberName ]. 306141 [ FileStream multiCs ] -> [ self fileInMemberNamedAsUTF8: memberName ]. 306142" 306143 [ 'mc' ] -> [ self fileInMonticelloPackageNamed: memberName ]. 306144 [ 'mcv' ] -> [ self fileInMonticelloVersionNamed: memberName ]. 306145 [ 'mcz' ] -> [ self fileInMonticelloZipVersionNamed: memberName ]. 306146 [ 'morph' ] -> [ self fileInMorphsNamed: member addToWorld: true ]. 306147 [ 'ttf' ] -> [ self fileInTrueTypeFontNamed: memberName ]. 306148 [ 'translation' ] -> [ self fileInMemberNamed: memberName ]. 306149 } otherwise: [ 306150 ('t*xt' match: extension) ifTrue: [ self openTextFile: memberName ] 306151 ifFalse: [ stream := member contentStream. 306152 isGraphic := ImageReadWriter understandsImageFormat: stream. 306153 stream reset. 306154 isGraphic 306155 ifTrue: [ self openGraphicsFile: member ] 306156 ifFalse: [ "now what?" ^false ]] 306157 ]. 306158 ^true 306159! ! 306160 306161!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 10:02'! 306162memberNameForProjectNamed: projectName 306163 "Answer my member name for the given project, or nil. 306164 Ignores version numbers and suffixes, and also unescapes percents in filenames." 306165 306166 ^self zip memberNames detect: [ :memberName | | triple | 306167 triple := Project parseProjectFileName: memberName unescapePercents. 306168 triple first asLowercase = projectName asLowercase 306169 ] ifNone: [ nil ].! ! 306170 306171!SARInstaller methodsFor: 'client services' stamp: 'nk 10/14/2003 18:58'! 306172memberNamed: aString 306173 ^(zip member: aString) 306174 ifNil: [ | matching | 306175 matching := zip membersMatching: aString. 306176 matching isEmpty ifFalse: [ matching last ]].! ! 306177 306178!SARInstaller methodsFor: 'client services' stamp: 'nk 10/27/2002 10:34'! 306179membersMatching: aString 306180 ^self zip membersMatching: aString! ! 306181 306182!SARInstaller methodsFor: 'client services' stamp: 'nk 6/12/2004 10:03'! 306183openGraphicsFile: memberOrName 306184 | member morph | 306185 member := self memberNamed: memberOrName. 306186 member ifNil: [ ^self errorNoSuchMember: memberOrName ]. 306187 morph := (World drawingClass fromStream: member contentStream binary). 306188 morph ifNotNil: [ morph openInWorld ]. 306189 self installed: member.! ! 306190 306191!SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:28'! 306192openTextFile: memberOrName 306193 "Open a text window on the given member" 306194 | member | 306195 member := self memberNamed: memberOrName. 306196 member ifNil: [ ^self errorNoSuchMember: memberOrName ]. 306197 StringHolder new 306198 acceptContents: member contents; 306199 openLabel: member fileName. 306200 self installed: member.! ! 306201 306202!SARInstaller methodsFor: 'client services' stamp: 'nk 10/27/2002 10:36'! 306203prependedDataSize 306204 ^self zip prependedDataSize! ! 306205 306206!SARInstaller methodsFor: 'client services' stamp: 'nk 10/27/2002 10:35'! 306207zipFileComment 306208 ^self zip zipFileComment! ! 306209 306210 306211!SARInstaller methodsFor: 'filein' stamp: 'ar 9/27/2005 20:10'! 306212fileIn 306213 "File in to a change set named like my file" 306214 | stream newCS | 306215 stream := directory readOnlyFileNamed: fileName. 306216 self class withCurrentChangeSetNamed: fileName 306217 do: [:cs | newCS := cs. self fileInFrom: stream]. 306218 newCS isEmpty ifTrue: [ ChangeSet removeChangeSet: newCS ]! ! 306219 306220!SARInstaller methodsFor: 'filein' stamp: 'yo 8/17/2004 00:33'! 306221fileInFrom: stream 306222 "The zip has been saved already by the download. 306223 Read the zip into my instvar, then file in the correct members" 306224 306225 | preamble postscript | 306226 306227 [ 306228 stream position: 0. 306229 zip := ZipArchive new readFrom: stream. 306230 306231 preamble := zip memberNamed: 'install/preamble'. 306232 preamble ifNotNil: [ 306233 preamble contentStream text setConverterForCode fileInFor: self announcing: 'Preamble'. 306234 self class currentChangeSet preambleString: preamble contents. 306235 ]. 306236 306237 postscript := zip memberNamed: 'install/postscript'. 306238 postscript ifNotNil: [ 306239 postscript contentStream text setConverterForCode fileInFor: self announcing: 'Postscript'. 306240 self class currentChangeSet postscriptString: postscript contents. 306241 ]. 306242 306243 preamble isNil & postscript isNil ifTrue: [ 306244 (self confirm: 'No install/preamble or install/postscript member were found. 306245 Install all the members automatically?') ifTrue: [ self installAllMembers ] 306246 ]. 306247 306248 ] ensure: [ stream close ]. 306249 306250! ! 306251 306252!SARInstaller methodsFor: 'filein' stamp: 'nk 7/27/2003 14:02'! 306253fileIntoChangeSetNamed: aString fromStream: stream 306254 "Not recommended for new code" 306255 ^self class fileIntoChangeSetNamed: aString fromStream: stream! ! 306256 306257!SARInstaller methodsFor: 'filein' stamp: 'nk 10/12/2003 20:41'! 306258installAllMembers 306259 "Try to install all the members, in order, based on their filenames and/or contents." 306260 | uninstalled | 306261 uninstalled := OrderedCollection new. 306262 zip members do: [ :member | self installMember: member ]. 306263 uninstalled := self uninstalledMembers. 306264 uninstalled isEmpty ifTrue: [ ^self ]. 306265 uninstalled inspect.! ! 306266 306267 306268!SARInstaller methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:19'! 306269initialize 306270 super initialize. 306271 installed := OrderedCollection new.! ! 306272 306273 306274!SARInstaller methodsFor: 'private' stamp: 'nk 10/13/2003 12:56'! 306275errorNoSuchMember: aMemberName 306276 (self confirm: 'No member named ', aMemberName, '. Do you want to stop loading?') 306277 == true ifTrue: [ self error: 'aborted' ].! ! 306278 306279!SARInstaller methodsFor: 'private' stamp: 'ar 9/27/2005 20:10'! 306280fileInMCVersion: member withBootstrap: mcBootstrap 306281 "This will use the MCBootstrapLoader to load a (non-compressed) Monticello file (.mc or .mcv)" 306282 | newCS | 306283 self class withCurrentChangeSetNamed: member localFileName 306284 do: [ :cs | 306285 newCS := cs. 306286 mcBootstrap loadStream: member contentStream ascii ]. 306287 306288 newCS isEmpty ifTrue: [ ChangeSet removeChangeSet: newCS ]. 306289 306290 World doOneCycle. 306291 306292 self installed: member.! ! 306293 306294!SARInstaller methodsFor: 'private' stamp: 'nk 7/10/2003 16:55'! 306295installed: aMemberOrName 306296 self installedMembers add: (self zip member: aMemberOrName)! ! 306297 306298"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 306299 306300SARInstaller class 306301 instanceVariableNames: ''! 306302 306303!SARInstaller class methodsFor: 'change set utilities' stamp: 'nk 10/27/2002 12:44'! 306304basicNewChangeSet: newName 306305 Smalltalk at: #ChangeSorter ifPresentAndInMemory: [ :cs | ^cs basicNewChangeSet: newName ]. 306306 (self changeSetNamed: newName) ifNotNil: [ self inform: 'Sorry that name is already used'. ^nil ]. 306307 ^ChangeSet basicNewNamed: newName.! ! 306308 306309!SARInstaller class methodsFor: 'change set utilities' stamp: 'nk 10/27/2002 12:44'! 306310changeSetNamed: newName 306311 Smalltalk at: #ChangeSorter ifPresentAndInMemory: [ :cs | ^cs changeSetNamed: newName ]. 306312 ^ChangeSet allInstances detect: [ :cs | cs name = newName ] ifNone: [ nil ].! ! 306313 306314!SARInstaller class methodsFor: 'change set utilities' stamp: 'nk 7/5/2003 22:49'! 306315currentChangeSet 306316 "Answer the current change set, in a way that should work in 3.5 as well" 306317 306318 "SARInstaller currentChangeSet" 306319 306320 ^[ ChangeSet current ] 306321 on: MessageNotUnderstood 306322 do: [ :ex | ex return: Smalltalk changes ]! ! 306323 306324!SARInstaller class methodsFor: 'change set utilities' stamp: 'yo 8/17/2004 10:04'! 306325fileIntoChangeSetNamed: aString fromStream: stream 306326 "We let the user confirm filing into an existing ChangeSet 306327 or specify another ChangeSet name if 306328 the name derived from the filename already exists. 306329 Duplicated from SMSimpleInstaller. 306330 Should be a class-side method." 306331 306332 ^self withCurrentChangeSetNamed: aString 306333 do: [ :cs | | newName | 306334 newName := cs name. 306335 stream setConverterForCode. 306336 stream 306337 fileInAnnouncing: 'Loading ' , newName , ' into change set ''' , newName, ''''. 306338 stream close]! ! 306339 306340!SARInstaller class methodsFor: 'change set utilities' stamp: 'nk 7/5/2003 22:51'! 306341newChanges: aChangeSet 306342 "Change the current change set, in a way that should work in 3.5 as well" 306343 "SARInstaller newChanges: SARInstaller currentChangeSet" 306344 306345 ^[ ChangeSet newChanges: aChangeSet ] 306346 on: MessageNotUnderstood 306347 do: [ :ex | ex return: (Smalltalk newChanges: aChangeSet) ]! ! 306348 306349!SARInstaller class methodsFor: 'change set utilities' stamp: 'DamienCassou 9/29/2009 13:08'! 306350withCurrentChangeSetNamed: aString do: aOneArgumentBlock 306351 "Evaluate the one-argument block aOneArgumentBlock while the named change set is active. 306352 We let the user confirm operating on an existing ChangeSet 306353 or specify another ChangeSet name if 306354 the name derived from the filename already exists. 306355 Duplicated from SMSimpleInstaller. 306356 Returns change set." 306357 306358 | changeSet newName oldChanges | 306359 newName := aString. 306360 changeSet := self changeSetNamed: newName. 306361 changeSet ifNotNil: 306362 [newName := UIManager default 306363 request: 'ChangeSet already present, just confirm to overwrite or enter a new name:' 306364 initialAnswer: newName. 306365 newName isEmptyOrNil ifTrue: [self error: 'Cancelled by user']. 306366 changeSet := self changeSetNamed: newName]. 306367 changeSet ifNil: [changeSet := self basicNewChangeSet: newName]. 306368 changeSet 306369 ifNil: [self error: 'User did not specify a valid ChangeSet name']. 306370 oldChanges := self currentChangeSet. 306371 306372 [ self newChanges: changeSet. 306373 aOneArgumentBlock value: changeSet] 306374 ensure: [ self newChanges: oldChanges]. 306375 ^changeSet! ! 306376 306377 306378!SARInstaller class methodsFor: 'initialization' stamp: 'nk 11/13/2002 07:33'! 306379fileReaderServicesForFile: fullName suffix: suffix 306380 306381 ^(suffix = 'sar') | (suffix = '*') 306382 ifTrue: [Array with: self serviceFileInSAR] 306383 ifFalse: [#()] 306384! ! 306385 306386!SARInstaller class methodsFor: 'initialization' stamp: 'nk 7/5/2003 22:22'! 306387initialize 306388 "SARInstaller initialize" 306389 (FileList respondsTo: #registerFileReader:) 306390 ifTrue: [ FileList registerFileReader: self ]! ! 306391 306392!SARInstaller class methodsFor: 'initialization' stamp: 'nk 7/5/2003 21:05'! 306393installSAR: relativeOrFullName 306394 FileDirectory splitName: (FileDirectory default fullNameFor: relativeOrFullName) 306395 to: [ :dir :fileName | (self directory: (FileDirectory on: dir) fileName: fileName) fileIn ]! ! 306396 306397!SARInstaller class methodsFor: 'initialization' stamp: 'nk 11/13/2002 07:35'! 306398serviceFileInSAR 306399 "Answer a service for opening a changelist browser on a file" 306400 306401 ^ SimpleServiceEntry 306402 provider: self 306403 label: 'install SAR' 306404 selector: #installSAR: 306405 description: 'install this Squeak ARchive into the image.' 306406 buttonLabel: 'install'! ! 306407 306408!SARInstaller class methodsFor: 'initialization' stamp: 'nk 11/21/2002 09:46'! 306409services 306410 ^Array with: self serviceFileInSAR 306411! ! 306412 306413!SARInstaller class methodsFor: 'initialization' stamp: 'nk 7/5/2003 22:22'! 306414unload 306415 306416 (FileList respondsTo: #unregisterFileReader:) 306417 ifTrue: [ FileList unregisterFileReader: self ]! ! 306418 306419 306420!SARInstaller class methodsFor: 'instance creation' stamp: 'nk 10/27/2002 10:29'! 306421directory: dir fileName: fn 306422 ^(self new) directory: dir; fileName: fn; yourself.! ! 306423 306424 306425!SARInstaller class methodsFor: 'package format support' stamp: 'ar 9/27/2005 20:11'! 306426ensurePackageWithId: anIdString 306427 306428 self squeakMapDo: [ :sm | | card newCS | 306429 self withCurrentChangeSetNamed: 'updates' do: [ :cs | 306430 newCS := cs. 306431 card := sm cardWithId: anIdString. 306432 (card isNil or: [ card isInstalled not or: [ card isOld ]]) 306433 ifTrue: [ sm installPackageWithId: anIdString ] 306434 ]. 306435 newCS isEmpty ifTrue: [ ChangeSet removeChangeSet: newCS ] 306436 ].! ! 306437 306438!SARInstaller class methodsFor: 'package format support' stamp: 'nk 7/25/2003 14:05'! 306439loadDVS 306440 "Load the DVS support from SqueakMap" 306441 306442 self ensurePackageWithId: '100d59d0-bf81-4e74-a4fe-5a2fd0c6b4ec'! ! 306443 306444!SARInstaller class methodsFor: 'package format support' stamp: 'nk 9/9/2003 12:08'! 306445loadMonticello 306446 "Load Monticello support (MCInstaller and Monticello) from SqueakMap" 306447 306448 self ensurePackageWithId: 'af9d090d-2896-4a4e-82d0-c61cf2fdf40e'. 306449 self ensurePackageWithId: '66236497-7026-45f5-bcf6-ad00ba7a8a4e'.! ! 306450 306451!SARInstaller class methodsFor: 'package format support' stamp: 'nk 7/25/2003 14:39'! 306452loadMonticelloCVS 306453 "Load MonticelloCVS support from SqueakMap" 306454 306455 self ensurePackageWithId: '2be9f7e2-1de2-4eb6-89bd-ec9b60593a93'. 306456! ! 306457 306458!SARInstaller class methodsFor: 'package format support' stamp: 'nk 7/25/2003 08:27'! 306459squeakMapDo: aBlock 306460 "If SqueakMap is installed, evaluate aBlock with the default map. 306461 Otherwise, offer to install SqueakMap and continue." 306462 306463 Smalltalk at: #SMSqueakMap ifPresent: [ :smClass | ^aBlock value: smClass default ]. 306464 306465 (self confirm: 'SqueakMap is not installed in this image. 306466Would you like to load it from the network?') 306467 ifTrue: [ TheWorldMenu loadSqueakMap. 306468 ^self squeakMapDo: aBlock ]. 306469 306470 ^nil! ! 306471 306472 306473!SARInstaller class methodsFor: 'squeakmap' stamp: 'marcus.denker 11/10/2008 10:04'! 306474cardForSqueakMap: aSqueakMap 306475 "Answer the current card or a new card." 306476 306477 (aSqueakMap cardWithId: self squeakMapPackageID) 306478 ifNotNil: [ :card | 306479 (card installedVersion = self squeakMapPackageVersion) ifTrue: [ ^card ] 306480 ]. 306481 306482 ^self newCardForSqueakMap: aSqueakMap 306483! ! 306484 306485!SARInstaller class methodsFor: 'squeakmap' stamp: 'nk 7/21/2003 17:17'! 306486newCardForSqueakMap: aSqueakMap 306487 "Answer a new card." 306488 306489 ^(aSqueakMap newCardWithId: self squeakMapPackageID) 306490 created: 3236292323 306491 updated:3236292323 306492 name: 'SARInstaller for 3.6' 306493 currentVersion:'16' 306494 summary: 'Lets you load SAR (Squeak ARchive) files from SqueakMap and the File List. For 3.6 and later images.' 306495 description:'Support for installing SAR (Squeak ARchive) packages from SqueakMap and the File List. 306496For 3.6 and later images. 306497 306498SMSARInstaller will use this if it''s present to load SAR packages. 306499 306500Use SARBuilder for making these packages easily.' 306501 url: 'http://bike-nomad.com/squeak/' 306502 downloadUrl:'http://bike-nomad.com/squeak/SARInstallerFor36-nk.16.cs.gz' 306503 author: 'Ned Konz <ned@bike-nomad.com>' 306504 maintainer:'Ned Konz <ned@bike-nomad.com>' 306505 registrator:'Ned Konz <ned@bike-nomad.com>' 306506 password:240495131608326995113451940367316491071470713347 306507 categories: #('6ba57b6e-946a-4009-beaa-0ac93c08c5d1' '94277ca9-4d8f-4f0e-a0cb-57f4b48f1c8a' 'a71a6233-c7a5-4146-b5e3-30f28e4d3f6b' '8209da9b-8d6e-40dd-b23a-eb7e05d4677b' ); 306508 modulePath: '' 306509 moduleVersion:'' 306510 moduleTag:'' 306511 versionComment:'v16: same as v16 of SARInstaller for 3.4 but doesn''t include any classes other than SARInstaller. 306512 306513To be loaded into 3.6 images only. Will de-register the 3.4 version if it''s registered. 306514 306515Added a default (DWIM) mode in which SAR files that are missing both a preamble and postscript have all their members loaded in a default manner. 306516 306517Changed the behavior of #extractMemberWithoutPath: to use the same directory as the SAR itself. 306518 306519Added #extractMemberWithoutPath:inDirectory: 306520 306521Moved several change set methods to the class side. 306522 306523Made change set methods work with 3.5 or 3.6a/b 306524 306525Now supports the following file types: 306526 306527Projects (with or without construction of a ViewMorph) 306528Genie gesture dictionaries 306529Change sets 306530DVS packages 306531Monticello packages 306532Graphics files (loaded as SketchMorphs) 306533Text files (loaded as text editor windows) 306534Morph(s) in files 306535 306536Now keeps track of installed members.'! ! 306537 306538!SARInstaller class methodsFor: 'squeakmap' stamp: 'nk 7/21/2003 17:16'! 306539squeakMapPackageID 306540 ^'75c970ab-dca7-48ee-af42-5a013912c880'! ! 306541 306542!SARInstaller class methodsFor: 'squeakmap' stamp: 'nk 7/21/2003 17:18'! 306543squeakMapPackageVersion 306544 ^'16'! ! 306545HashFunction subclass: #SHA1 306546 instanceVariableNames: 'totalA totalB totalC totalD totalE totals' 306547 classVariableNames: 'K1 K2 K3 K4' 306548 poolDictionaries: '' 306549 category: 'System-Hashing-SHA1'! 306550!SHA1 commentStamp: '<historical>' prior: 0! 306551This class implements the Secure Hash Algorithm (SHA) described in the U.S. government's Secure Hash Standard (SHS). This standard is described in FIPS PUB 180-1, "SECURE HASH STANDARD", April 17, 1995. 306552 306553The Secure Hash Algorithm is also described on p. 442 of 'Applied Cryptography: Protocols, Algorithms, and Source Code in C' by Bruce Scheier, Wiley, 1996. 306554 306555See the comment in class DigitalSignatureAlgorithm for details on its use. 306556 306557Implementation notes: 306558The secure hash standard was created with 32-bit hardware in mind. All arithmetic in the hash computation must be done modulo 2^32. This implementation uses ThirtyTwoBitRegister objects to simulate hardware registers; this implementation is about six times faster than using LargePositiveIntegers (measured on a Macintosh G3 Powerbook). Implementing a primitive to process each 64-byte buffer would probably speed up the computation by a factor of 20 or more. 306559! 306560 306561 306562!SHA1 methodsFor: 'accessing' stamp: 'StephaneDucasse 10/17/2009 17:15'! 306563hashInteger: aPositiveInteger 306564 "Hash the given positive integer. The integer to be hashed should have 512 or fewer bits. This entry point is used in key generation." 306565 | buffer dstIndex | 306566 self initializeTotals. 306567 306568 "pad integer with zeros" 306569 aPositiveInteger highBit <= 512 ifFalse: [ self error: 'integer cannot exceed 512 bits' ]. 306570 buffer := ByteArray new: 64. 306571 dstIndex := 0. 306572 aPositiveInteger digitLength 306573 to: 1 306574 by: -1 306575 do: 306576 [ :i | 306577 buffer 306578 at: (dstIndex := dstIndex + 1) 306579 put: (aPositiveInteger digitAt: i) ]. 306580 306581 "process that one block" 306582 self processBuffer: buffer. 306583 ^ self finalHash! ! 306584 306585!SHA1 methodsFor: 'accessing' stamp: 'StephaneDucasse 10/17/2009 17:15'! 306586hashInteger: aPositiveInteger seed: seedInteger 306587 "Hash the given positive integer. The integer to be hashed should have 512 or fewer bits. This entry point is used in the production of random numbers" 306588 "Initialize totalA through totalE to their seed values." 306589 | buffer dstIndex | 306590 totalA := ThirtyTwoBitRegister new load: ((seedInteger bitShift: -128) bitAnd: 4294967295). 306591 totalB := ThirtyTwoBitRegister new load: ((seedInteger bitShift: -96) bitAnd: 4294967295). 306592 totalC := ThirtyTwoBitRegister new load: ((seedInteger bitShift: -64) bitAnd: 4294967295). 306593 totalD := ThirtyTwoBitRegister new load: ((seedInteger bitShift: -32) bitAnd: 4294967295). 306594 totalE := ThirtyTwoBitRegister new load: (seedInteger bitAnd: 4294967295). 306595 self initializeTotalsArray. 306596 306597 "pad integer with zeros" 306598 buffer := ByteArray new: 64. 306599 dstIndex := 0. 306600 aPositiveInteger digitLength 306601 to: 1 306602 by: -1 306603 do: 306604 [ :i | 306605 buffer 306606 at: (dstIndex := dstIndex + 1) 306607 put: (aPositiveInteger digitAt: i) ]. 306608 306609 "process that one block" 306610 self processBuffer: buffer. 306611 ^ self finalHash! ! 306612 306613!SHA1 methodsFor: 'accessing' stamp: 'StephaneDucasse 10/17/2009 17:15'! 306614hashStream: aPositionableStream 306615 "Hash the contents of the given stream from the current position to the end using the Secure Hash Algorithm. The SHA algorithm is defined in FIPS PUB 180-1. It is also described on p. 442 of 'Applied Cryptography: Protocols, Algorithms, and Source Code in C' by Bruce Scheier, Wiley, 1996." 306616 "SecureHashAlgorithm new hashStream: (ReadStream on: 'foo')" 306617 | startPosition buf bitLength | 306618 self initializeTotals. 306619 aPositionableStream atEnd ifTrue: [ self error: 'empty stream' ]. 306620 startPosition := aPositionableStream position. 306621 [ aPositionableStream atEnd ] whileFalse: 306622 [ buf := aPositionableStream next: 64. 306623 (aPositionableStream atEnd not and: [ buf size = 64 ]) 306624 ifTrue: [ self processBuffer: buf ] 306625 ifFalse: 306626 [ bitLength := (aPositionableStream position - startPosition) * 8. 306627 self 306628 processFinalBuffer: buf 306629 bitLength: bitLength ] ]. 306630 ^ self finalHash asByteArrayOfSize: 20! ! 306631 306632 306633!SHA1 methodsFor: 'primitives' stamp: 'jm 12/21/1999 20:11'! 306634primExpandBlock: aByteArray into: wordBitmap 306635 "Expand the given 64-byte buffer into the given Bitmap of length 80." 306636 306637 <primitive: 'primitiveExpandBlock' module: 'DSAPrims'> 306638 ^ self primitiveFailed 306639! ! 306640 306641!SHA1 methodsFor: 'primitives' stamp: 'jm 12/21/1999 22:58'! 306642primHasSecureHashPrimitive 306643 "Answer true if this platform has primitive support for the Secure Hash Algorithm." 306644 306645 <primitive: 'primitiveHasSecureHashPrimitive' module: 'DSAPrims'> 306646 ^ false 306647! ! 306648 306649!SHA1 methodsFor: 'primitives' stamp: 'jm 12/21/1999 20:13'! 306650primHashBlock: blockBitmap using: workingTotalsBitmap 306651 "Hash the given block (a Bitmap) of 80 32-bit words, using the given workingTotals." 306652 306653 <primitive: 'primitiveHashBlock' module: 'DSAPrims'> 306654 ^ self primitiveFailed 306655! ! 306656 306657 306658!SHA1 methodsFor: 'private' stamp: 'jm 12/7/1999 23:25'! 306659constantForStep: i 306660 "Answer the constant for the i-th step of the block hash loop. We number our steps 1-80, versus the 0-79 of the standard." 306661 306662 i <= 20 ifTrue: [^ K1]. 306663 i <= 40 ifTrue: [^ K2]. 306664 i <= 60 ifTrue: [^ K3]. 306665 ^ K4 306666! ! 306667 306668!SHA1 methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! 306669expandedBlock: aByteArray 306670 "Convert the given 64 byte buffer into 80 32-bit registers and answer the result." 306671 | out src v | 306672 out := Array new: 80. 306673 src := 1. 306674 1 306675 to: 16 306676 do: 306677 [ :i | 306678 out 306679 at: i 306680 put: (ThirtyTwoBitRegister new 306681 loadFrom: aByteArray 306682 at: src). 306683 src := src + 4 ]. 306684 17 306685 to: 80 306686 do: 306687 [ :i | 306688 v := (out at: i - 3) copy. 306689 v 306690 bitXor: (out at: i - 8); 306691 bitXor: (out at: i - 14); 306692 bitXor: (out at: i - 16); 306693 leftRotateBy: 1. 306694 out 306695 at: i 306696 put: v ]. 306697 ^ out! ! 306698 306699!SHA1 methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! 306700finalHash 306701 "Concatenate the final totals to build the 160-bit integer result." 306702 "Details: If the primitives are supported, the results are in the totals array. Otherwise, they are in the instance variables totalA through totalE." 306703 | r | 306704 totals ifNil: 306705 [ "compute final hash when not using primitives" 306706 ^ (totalA asInteger bitShift: 128) + (totalB asInteger bitShift: 96) + (totalC asInteger bitShift: 64) + (totalD asInteger bitShift: 32) + totalE asInteger ]. 306707 306708 "compute final hash when using primitives" 306709 r := 0. 306710 1 306711 to: 5 306712 do: [ :i | r := r bitOr: ((totals at: i) bitShift: 32 * (5 - i)) ]. 306713 ^ r! ! 306714 306715!SHA1 methodsFor: 'private' stamp: 'jm 12/7/1999 22:15'! 306716hashFunction: i of: x with: y with: z 306717 "Compute the hash function for the i-th step of the block hash loop. We number our steps 1-80, versus the 0-79 of the standard." 306718 "Details: There are four functions, one for each 20 iterations. The second and fourth are the same." 306719 306720 i <= 20 ifTrue: [^ x copy bitAnd: y; bitOr: (x copy bitInvert; bitAnd: z)]. 306721 i <= 40 ifTrue: [^ x copy bitXor: y; bitXor: z]. 306722 i <= 60 ifTrue: [^ x copy bitAnd: y; bitOr: (x copy bitAnd: z); bitOr: (y copy bitAnd: z)]. 306723 ^ x copy bitXor: y; bitXor: z 306724! ! 306725 306726!SHA1 methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! 306727initializeTotals 306728 "Initialize totalA through totalE to their seed values." 306729 "total registers for use when primitives are absent" 306730 totalA := ThirtyTwoBitRegister new load: 1732584193. 306731 totalB := ThirtyTwoBitRegister new load: 4023233417. 306732 totalC := ThirtyTwoBitRegister new load: 2562383102. 306733 totalD := ThirtyTwoBitRegister new load: 271733878. 306734 totalE := ThirtyTwoBitRegister new load: 3285377520. 306735 self initializeTotalsArray! ! 306736 306737!SHA1 methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! 306738initializeTotalsArray 306739 "Initialize the totals array from the registers for use with the primitives." 306740 totals := Bitmap new: 5. 306741 totals 306742 at: 1 306743 put: totalA asInteger. 306744 totals 306745 at: 2 306746 put: totalB asInteger. 306747 totals 306748 at: 3 306749 put: totalC asInteger. 306750 totals 306751 at: 4 306752 put: totalD asInteger. 306753 totals 306754 at: 5 306755 put: totalE asInteger! ! 306756 306757!SHA1 methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! 306758processBuffer: aByteArray 306759 "Process given 64-byte buffer, accumulating the results in totalA through totalE." 306760 | a b c d e w tmp | 306761 self primHasSecureHashPrimitive 306762 ifTrue: [ ^ self processBufferUsingPrimitives: aByteArray ] 306763 ifFalse: [ totals := nil ]. 306764 306765 "initialize registers a through e from the current totals" 306766 a := totalA copy. 306767 b := totalB copy. 306768 c := totalC copy. 306769 d := totalD copy. 306770 e := totalE copy. 306771 306772 "expand and process the buffer" 306773 w := self expandedBlock: aByteArray. 306774 1 306775 to: 80 306776 do: 306777 [ :i | 306778 tmp := (a copy leftRotateBy: 5) 306779 += (self 306780 hashFunction: i 306781 of: b 306782 with: c 306783 with: d); 306784 += e; 306785 += (w at: i); 306786 += (self constantForStep: i). 306787 e := d. 306788 d := c. 306789 c := b copy leftRotateBy: 30. 306790 b := a. 306791 a := tmp ]. 306792 306793 "add a through e into total accumulators" 306794 totalA += a. 306795 totalB += b. 306796 totalC += c. 306797 totalD += d. 306798 totalE += e! ! 306799 306800!SHA1 methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! 306801processBufferUsingPrimitives: aByteArray 306802 "Process given 64-byte buffer using the primitives, accumulating the results in totals." 306803 "expand and process the buffer" 306804 | w | 306805 w := Bitmap new: 80. 306806 self 306807 primExpandBlock: aByteArray 306808 into: w. 306809 self 306810 primHashBlock: w 306811 using: totals! ! 306812 306813!SHA1 methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! 306814processFinalBuffer: buffer bitLength: bitLength 306815 "Process given buffer, whose length may be <= 64 bytes, accumulating the results in totalA through totalE. Also process the final padding bits and length." 306816 | out | 306817 out := ByteArray new: 64. 306818 out 306819 replaceFrom: 1 306820 to: buffer size 306821 with: buffer 306822 startingAt: 1. 306823 buffer size < 56 ifTrue: 306824 [ "padding and length fit in last data block" 306825 out 306826 at: buffer size + 1 306827 put: 128. "trailing one bit" 306828 self 306829 storeLength: bitLength 306830 in: out. "end with length" 306831 self processBuffer: out. 306832 ^ self ]. 306833 306834 "process the final data block" 306835 buffer size < 64 ifTrue: 306836 [ out 306837 at: buffer size + 1 306838 put: 128 ]. "trailing one bit" 306839 self processBuffer: out. 306840 306841 "process one additional block of padding ending with the length" 306842 out := ByteArray new: 64. "filled with zeros" 306843 buffer size = 64 ifTrue: 306844 [ "add trailing one bit that didn't fit in final data block" 306845 out 306846 at: 1 306847 put: 128 ]. 306848 self 306849 storeLength: bitLength 306850 in: out. 306851 self processBuffer: out! ! 306852 306853!SHA1 methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! 306854storeLength: bitLength in: aByteArray 306855 "Fill in the final 8 bytes of the given ByteArray with a 64-bit big-endian representation of the original message length in bits." 306856 | n i | 306857 n := bitLength. 306858 i := aByteArray size. 306859 [ n > 0 ] whileTrue: 306860 [ aByteArray 306861 at: i 306862 put: (n bitAnd: 255). 306863 n := n bitShift: -8. 306864 i := i - 1 ]! ! 306865 306866"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 306867 306868SHA1 class 306869 instanceVariableNames: ''! 306870 306871!SHA1 class methodsFor: 'accessing' stamp: 'rww 9/22/2006 19:25'! 306872blockSize 306873 ^ 64! ! 306874 306875!SHA1 class methodsFor: 'accessing' stamp: 'len 8/15/2002 01:45'! 306876hashSize 306877 ^ 20! ! 306878 306879 306880!SHA1 class methodsFor: 'class initialization' stamp: 'StephaneDucasse 10/17/2009 17:15'! 306881initialize 306882 "SecureHashAlgorithm initialize" 306883 "For the curious, here's where these constants come from: 306884 #(2 3 5 10) collect: [:x | ((x sqrt / 4.0) * (2.0 raisedTo: 32)) truncated hex]" 306885 K1 := ThirtyTwoBitRegister new load: 1518500249. 306886 K2 := ThirtyTwoBitRegister new load: 1859775393. 306887 K3 := ThirtyTwoBitRegister new load: 2400959708. 306888 K4 := ThirtyTwoBitRegister new load: 3395469782! ! 306889TelnetProtocolClient subclass: #SMTPClient 306890 instanceVariableNames: '' 306891 classVariableNames: '' 306892 poolDictionaries: '' 306893 category: 'Network-Protocols'! 306894!SMTPClient commentStamp: 'mir 2/21/2002 16:57' prior: 0! 306895This class implements the SMTP (mail sending) protocol specified in RFC 821. 306896 306897HELO <SP> <domain> <CRLF> 306898 306899MAIL <SP> FROM:<reverse-path> <CRLF> 306900 306901RCPT <SP> TO:<forward-path> <CRLF> 306902 306903DATA <CRLF> 306904 306905RSET <CRLF> 306906 306907SEND <SP> FROM:<reverse-path> <CRLF> 306908 306909SOML <SP> FROM:<reverse-path> <CRLF> 306910 306911SAML <SP> FROM:<reverse-path> <CRLF> 306912 306913VRFY <SP> <string> <CRLF> 306914 306915EXPN <SP> <string> <CRLF> 306916 306917HELP [<SP> <string>] <CRLF> 306918 306919NOOP <CRLF> 306920 306921QUIT <CRLF> 306922 306923TURN <CRLF> 306924 306925! 306926 306927 306928!SMTPClient methodsFor: 'public protocol' stamp: 'mir 2/21/2002 15:43'! 306929mailFrom: sender to: recipientList text: messageText 306930 "deliver this mail to a list of users. NOTE: the recipient list should be a collection of simple internet style addresses -- no '<>' or '()' stuff" 306931 306932 self mailFrom: sender. 306933 recipientList do: [ :recipient | 306934 self recipient: recipient ]. 306935 self data: messageText. 306936! ! 306937 306938!SMTPClient methodsFor: 'public protocol' stamp: 'gk 8/4/2006 15:14'! 306939useHelo 306940 "If client use HELO instead of EHLO. HELO is the old protocol and 306941 an old server may require it instead of EHLO." 306942 306943 ^self connectionInfo at: #useHelo ifAbsent: [false]! ! 306944 306945!SMTPClient methodsFor: 'public protocol' stamp: 'gk 8/4/2006 15:14'! 306946useHelo: aBoolean 306947 "Tell client to use HELO instead of EHLO. HELO is the old protocol and 306948 an old server may require it instead of EHLO." 306949 306950 ^self connectionInfo at: #useHelo put: aBoolean! ! 306951 306952 306953!SMTPClient methodsFor: 'utility' stamp: 'PeterHugossonMiller 9/3/2009 11:09'! 306954encodeString: aString 306955 | str dec | 306956 str := String new: (aString size * 4 / 3 + 3) ceiling. 306957 dec := Base64MimeConverter new. 306958 dec 306959 mimeStream: str writeStream; 306960 dataStream: aString readStream; 306961 mimeEncode. 306962 ^ str! ! 306963 306964 306965!SMTPClient methodsFor: 'private protocol' stamp: 'mir 2/22/2002 16:42'! 306966data: messageData 306967 "send the data of a message" 306968 "DATA <CRLF>" 306969 306970 | cookedLine | 306971 306972 "inform the server we are sending the message data" 306973 self sendCommand: 'DATA'. 306974 self checkResponse. 306975 306976 "process the data one line at a time" 306977 messageData linesDo: [ :messageLine | 306978 cookedLine := messageLine. 306979 (cookedLine beginsWith: '.') ifTrue: [ 306980 "lines beginning with a dot must have the dot doubled" 306981 cookedLine := '.', cookedLine ]. 306982 self sendCommand: cookedLine ]. 306983 306984 "inform the server the entire message text has arrived" 306985 self sendCommand: '.'. 306986 self checkResponse.! ! 306987 306988!SMTPClient methodsFor: 'private protocol' stamp: 'gk 8/4/2006 15:15'! 306989initiateSession 306990 "EHLO <SP> <domain> <CRLF>" 306991 306992 self sendCommand: (self useHelo ifTrue:['HELO '] ifFalse: ['EHLO ']) , NetNameResolver localHostName. 306993 self checkResponse. 306994! ! 306995 306996!SMTPClient methodsFor: 'private protocol' stamp: 'gk 8/31/2006 09:24'! 306997login 306998 self user ifNil: [^self]. 306999 self initiateSession. 307000 self sendCommand: 'AUTH LOGIN ' , (self encodeString: self user). 307001 [self checkResponse] 307002 on: TelnetProtocolError 307003 do: [ :ex | ex isCommandUnrecognized ifTrue: [^ self] ifFalse: [ex pass]]. 307004 self sendCommand: (self encodeString: self password). 307005 self checkResponse! ! 307006 307007!SMTPClient methodsFor: 'private protocol' stamp: 'fbs 3/23/2004 17:16'! 307008mailFrom: fromAddress 307009 " MAIL <SP> FROM:<reverse-path> <CRLF>" 307010 307011 | address | 307012 address := (MailAddressParser addressesIn: fromAddress) first. 307013 307014 self sendCommand: 'MAIL FROM: <', address, '>'. 307015 self checkResponse.! ! 307016 307017!SMTPClient methodsFor: 'private protocol' stamp: 'mir 2/21/2002 17:52'! 307018quit 307019 "send a QUIT command. This is polite to do, and indeed some servers might drop messages that don't have an associated QUIT" 307020 "QUIT <CRLF>" 307021 307022 self sendCommand: 'QUIT'. 307023 self checkResponse.! ! 307024 307025!SMTPClient methodsFor: 'private protocol' stamp: 'mir 2/21/2002 17:52'! 307026recipient: aRecipient 307027 "specify a recipient for the message. aRecipient should be a bare email address" 307028 "RCPT <SP> TO:<forward-path> <CRLF>" 307029 307030 self sendCommand: 'RCPT TO: <', aRecipient, '>'. 307031 self checkResponse.! ! 307032 307033"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 307034 307035SMTPClient class 307036 instanceVariableNames: ''! 307037 307038!SMTPClient class methodsFor: 'accessing' stamp: 'mir 2/21/2002 17:22'! 307039defaultPortNumber 307040 ^25! ! 307041 307042!SMTPClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 19:07'! 307043logFlag 307044 ^#smtp! ! 307045 307046 307047!SMTPClient class methodsFor: 'example' stamp: 'adrian_lienhard 7/18/2009 16:00'! 307048example 307049 "SMTPClient example" 307050 307051 self deliverMailFrom: 'm.rueger@acm.org' to: #('m.rueger@acm.org') text: 307052'From: test 307053To: "not listed" 307054Subject: this is a test 307055 307056Hello from Pharo!! 307057' usingServer: 'smtp.concentric.net'! ! 307058 307059!SMTPClient class methodsFor: 'example' stamp: 'adrian_lienhard 7/18/2009 16:00'! 307060example2 307061 "SMTPClient example2" 307062 307063 self deliverMailFrom: 'm.rueger@acm.org' to: #('m.rueger@acm.org') text: 307064'Subject: this is a test 307065 307066Hello from Pharo!! 307067' usingServer: 'smtp.concentric.net'! ! 307068 307069 307070!SMTPClient class methodsFor: 'sending mail' stamp: 'mir 2/22/2002 12:30'! 307071deliverMailFrom: fromAddress to: recipientList text: messageText usingServer: serverName 307072 "Deliver a single email to a list of users and then close the connection. For delivering multiple messages, it is best to create a single connection and send all mail over it. NOTE: the recipient list should be a collection of simple internet style addresses -- no '<>' or '()' stuff" 307073 307074 | smtpClient | 307075 smtpClient := self openOnHostNamed: serverName. 307076 [smtpClient mailFrom: fromAddress to: recipientList text: messageText. 307077 smtpClient quit] 307078 ensure: [smtpClient close] 307079! ! 307080TestCase subclass: #SMTPClientTest 307081 instanceVariableNames: 'smtp socket' 307082 classVariableNames: '' 307083 poolDictionaries: '' 307084 category: 'NetworkTests-Protocols'! 307085 307086!SMTPClientTest methodsFor: 'running' stamp: 'fbs 3/22/2004 13:11'! 307087setUp 307088 socket := MockSocketStream on: ''. 307089 smtp := SMTPClient new. 307090 smtp stream: socket.! ! 307091 307092 307093!SMTPClientTest methodsFor: 'testing' stamp: 'fbs 3/23/2004 17:15'! 307094testMailFrom 307095 smtp mailFrom: 'frank@angband.za.org'. 307096 self assert: socket outStream contents = ('MAIL FROM: <frank@angband.za.org>', String crlf). 307097 307098 socket resetOutStream. 307099 smtp mailFrom: '<frank@angband.za.org>'. 307100 self assert: socket outStream contents = ('MAIL FROM: <frank@angband.za.org>', String crlf). 307101 307102 socket resetOutStream. 307103 smtp mailFrom: 'Frank <frank@angband.za.org>'. 307104 self assert: socket outStream contents = ('MAIL FROM: <frank@angband.za.org>', String crlf).! ! 307105TestCase subclass: #SUnitExtensionsTest 307106 instanceVariableNames: 'stream' 307107 classVariableNames: '' 307108 poolDictionaries: '' 307109 category: 'SUnit-Tests'! 307110 307111!SUnitExtensionsTest methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 11:09'! 307112stream 307113 stream isNil ifTrue: [stream := String new writeStream]. 307114 ^stream! ! 307115 307116 307117!SUnitExtensionsTest methodsFor: 'as yet unclassified' stamp: 'md 4/2/2006 14:02'! 307118testExceptionWithMatchingString 307119 self should: [ Object obsolete ] raise: Error whoseDescriptionIncludes: 'NOT obsolete' description: 'tested obsoleting Object'! ! 307120 307121!SUnitExtensionsTest methodsFor: 'as yet unclassified' stamp: 'md 4/2/2006 14:02'! 307122testExceptionWithoutMatchingString 307123 self should: [ Object obsolete ] raise: Error whoseDescriptionDoesNotInclude: 'Zero' description: 'tested obsoleting Object'! ! 307124 307125!SUnitExtensionsTest methodsFor: 'as yet unclassified' stamp: 'md 4/2/2006 14:02'! 307126testNoExceptionWithMatchingString 307127 self shouldnt: [ Object obsolete ] raise: Error whoseDescriptionIncludes: 'Zero' description: 'tested obsoleting Object'! ! 307128 307129!SUnitExtensionsTest methodsFor: 'as yet unclassified' stamp: 'md 4/2/2006 14:02'! 307130testNoExceptionWithNoMatchingString 307131 self shouldnt: [ Object obsolete ] raise: Error whoseDescriptionDoesNotInclude: 'NOT' description: 'tested obsoleting Object'! ! 307132 307133 307134!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'mx 3/20/2006 23:47'! 307135assertionFailedInRaiseWithExceptionDoTest 307136 307137 self 307138 should: [ Error signal ] 307139 raise: Error 307140 withExceptionDo: [ :anException | self assert: false ]! ! 307141 307142!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'mx 3/20/2006 23:47'! 307143differentExceptionInShouldRaiseWithExceptionDoTest 307144 307145 [ self 307146 should: [ Error signal ] 307147 raise: Halt 307148 withExceptionDo: [ :anException | self assert: false description: 'should:raise:withExceptionDo: handled an exception that should not handle'] ] 307149 on: Error 307150 do: [ :anException | anException return: nil ]! ! 307151 307152!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'mx 3/20/2006 23:47'! 307153errorInRaiseWithExceptionDoTest 307154 307155 self 307156 should: [ Error signal ] 307157 raise: Error 307158 withExceptionDo: [ :anException | Error signal: 'A forced error' ]! ! 307159 307160!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'md 8/2/2006 11:04'! 307161invalidShouldNotTakeMoreThan 307162 307163 self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThan: 50 milliSeconds.! ! 307164 307165!SUnitExtensionsTest methodsFor: 'real tests'! 307166invalidShouldNotTakeMoreThanMilliseconds 307167 307168 self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThanMilliseconds: 50! ! 307169 307170!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'mx 3/20/2006 23:47'! 307171noExceptionInShouldRaiseWithExceptionDoTest 307172 307173 self 307174 should: [ ] 307175 raise: Error 307176 withExceptionDo: [ :anException | Error signal: 'Should not get here' ]! ! 307177 307178!SUnitExtensionsTest methodsFor: 'real tests'! 307179shouldFixTest 307180 307181 self shouldFix: [ Error signal: 'any kind of error' ] 307182! ! 307183 307184!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'mx 3/20/2006 23:47'! 307185shouldRaiseWithExceptionDoTest 307186 307187 self 307188 should: [ Error signal: '1' ] 307189 raise: Error 307190 withExceptionDo: [ :anException | self assert: anException messageText = '1' ]! ! 307191 307192!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'mx 3/20/2006 23:47'! 307193shouldRaiseWithSignalDoTest 307194 307195 self 307196 should: [ Error signal: '1' ] 307197 raise: Error 307198 withExceptionDo: [ :anException | self assert: anException messageText = '1' ]! ! 307199 307200!SUnitExtensionsTest methodsFor: 'real tests' stamp: 'md 8/2/2006 11:05'! 307201validShouldNotTakeMoreThan 307202 307203 self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThan: 200 milliSeconds.! ! 307204 307205!SUnitExtensionsTest methodsFor: 'real tests'! 307206validShouldNotTakeMoreThanMilliseconds 307207 307208 self should: [(Delay forMilliseconds: 100) wait] notTakeMoreThanMilliseconds: 200! ! 307209 307210 307211!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 23:39'! 307212testAssertionFailedInRaiseWithExceptionDo 307213 307214 | testCase testResult | 307215 307216 testCase := self class selector: #assertionFailedInRaiseWithExceptionDoTest. 307217 testResult := testCase run. 307218 307219 self assert: (testResult failures includes: testCase). 307220 self assert: testResult failures size=1. 307221 self assert: testResult passed isEmpty. 307222 self assert: testResult errors isEmpty. 307223 307224 ! ! 307225 307226!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 21:15'! 307227testAutoAssertFalse 307228 | booleanCondition | 307229 self assert: self isLogging. 307230 self should: [ self assert: 1 = 2 description: 'self assert: 1 = 2' ] raise: TestResult failure. 307231 booleanCondition := (self stream contents subStrings: {Character cr}) last = 'self assert: 1 = 2'. 307232 self assert: booleanCondition! ! 307233 307234!SUnitExtensionsTest methodsFor: 'test'! 307235testAutoAssertTrue 307236 self assert: 1 = 1. 307237 self assert: true! ! 307238 307239!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 21:16'! 307240testAutoDenyFalse 307241 | booleanCondition | 307242 self assert: self isLogging. 307243 self should: [ self deny: 1 = 1 description: 'self deny: 1 = 1'.] raise: TestResult failure. 307244 booleanCondition := (self stream contents subStrings: {Character cr}) last = 'self deny: 1 = 1'. 307245 self assert: booleanCondition! ! 307246 307247!SUnitExtensionsTest methodsFor: 'test'! 307248testAutoDenyTrue 307249 self deny: 1 = 2. 307250 self deny: false! ! 307251 307252!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 23:40'! 307253testDifferentExceptionInShouldRaiseWithExceptionDo 307254 307255 | testCase testResult | 307256 307257 testCase := self class selector: #differentExceptionInShouldRaiseWithExceptionDoTest. 307258 testResult := testCase run. 307259 307260 self assert: (testResult passed includes: testCase). 307261 self assert: testResult errors isEmpty. 307262 self assert: testResult failures isEmpty. 307263 self assert: testResult passed size=1! ! 307264 307265!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 23:40'! 307266testErrorInRaiseWithExceptionDo 307267 307268 | testCase testResult | 307269 307270 testCase := self class selector: #errorInRaiseWithExceptionDoTest. 307271 testResult := testCase run. 307272 307273 self assert: (testResult errors includes: testCase). 307274 self assert: testResult errors size=1. 307275 self assert: testResult failures isEmpty. 307276 self assert: testResult passed isEmpty. 307277 307278 ! ! 307279 307280!SUnitExtensionsTest methodsFor: 'test' stamp: 'md 8/2/2006 11:06'! 307281testInvalidShouldNotTakeMoreThan 307282 307283 | testCase testResult | 307284 307285 testCase := self class selector: #invalidShouldNotTakeMoreThan. 307286 testResult := testCase run. 307287 307288 self assert: testResult passed isEmpty. 307289 self assert: testResult failures size = 1. 307290 self assert: (testResult failures includes: testCase). 307291 self assert: testResult errors isEmpty 307292 307293! ! 307294 307295!SUnitExtensionsTest methodsFor: 'test'! 307296testInvalidShouldNotTakeMoreThanMilliseconds 307297 307298 | testCase testResult | 307299 307300 testCase := self class selector: #invalidShouldNotTakeMoreThanMilliseconds. 307301 testResult := testCase run. 307302 307303 self assert: testResult passed isEmpty. 307304 self assert: testResult failures size = 1. 307305 self assert: (testResult failures includes: testCase). 307306 self assert: testResult errors isEmpty 307307 307308! ! 307309 307310!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 23:40'! 307311testNoExceptionInShouldRaiseWithExceptionDo 307312 307313 | testCase testResult | 307314 307315 testCase := self class selector: #noExceptionInShouldRaiseWithExceptionDoTest. 307316 testResult := testCase run. 307317 307318 self assert: (testResult failures includes: testCase). 307319 self assert: testResult failures size=1. 307320 self assert: testResult passed isEmpty. 307321 self assert: testResult errors isEmpty. 307322 307323 ! ! 307324 307325!SUnitExtensionsTest methodsFor: 'test'! 307326testShouldFix 307327 307328 | testCase testResult | 307329 307330 testCase := self class selector: #shouldFixTest. 307331 testResult := testCase run. 307332 307333 self assert: (testResult passed includes: testCase). 307334 self assert: testResult passed size=1. 307335 self assert: testResult failures isEmpty. 307336 self assert: testResult errors isEmpty. 307337 307338 ! ! 307339 307340!SUnitExtensionsTest methodsFor: 'test' stamp: 'mx 3/20/2006 23:40'! 307341testShouldRaiseWithExceptionDo 307342 307343 | testCase testResult | 307344 307345 testCase := self class selector: #shouldRaiseWithExceptionDoTest. 307346 testResult := testCase run. 307347 307348 self assert: (testResult passed includes: testCase). 307349 self assert: testResult passed size=1. 307350 self assert: testResult failures isEmpty. 307351 self assert: testResult errors isEmpty. 307352 307353 ! ! 307354 307355!SUnitExtensionsTest methodsFor: 'test' stamp: 'md 8/2/2006 11:06'! 307356testValidShouldNotTakeMoreThan 307357 | testCase testResult | 307358 307359 testCase := self class selector: #validShouldNotTakeMoreThan. 307360 testResult := testCase run. 307361 307362 self assert: (testResult passed includes: testCase). 307363 self assert: testResult passed size = 1. 307364 self assert: testResult failures isEmpty. 307365 self assert: testResult errors isEmpty 307366 307367! ! 307368 307369!SUnitExtensionsTest methodsFor: 'test'! 307370testValidShouldNotTakeMoreThanMilliseconds 307371 307372 | testCase testResult | 307373 307374 testCase := self class selector: #validShouldNotTakeMoreThanMilliseconds. 307375 testResult := testCase run. 307376 307377 self assert: (testResult passed includes: testCase). 307378 self assert: testResult passed size = 1. 307379 self assert: testResult failures isEmpty. 307380 self assert: testResult errors isEmpty 307381 307382! ! 307383 307384 307385!SUnitExtensionsTest methodsFor: 'test support'! 307386failureLog 307387 ^self stream! ! 307388 307389 307390!SUnitExtensionsTest methodsFor: 'testing'! 307391isLogging 307392 ^true! ! 307393 307394"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 307395 307396SUnitExtensionsTest class 307397 instanceVariableNames: ''! 307398 307399!SUnitExtensionsTest class methodsFor: 'history' stamp: 'simon.denier 11/22/2008 22:13'! 307400lastStoredRun 307401 ^ ((Dictionary new) add: (#passed->((Set new) add: #testNoExceptionWithMatchingString; add: #testNoExceptionWithNoMatchingString; add: #testExceptionWithMatchingString; add: #testExceptionWithoutMatchingString; add: #testValidShouldNotTakeMoreThan; add: #testInvalidShouldNotTakeMoreThanMilliseconds; add: #testDifferentExceptionInShouldRaiseWithExceptionDo; add: #testShouldRaiseWithExceptionDo; add: #testShouldFix; add: #testAssertionFailedInRaiseWithExceptionDo; add: #testAutoDenyFalse; add: #testAutoDenyTrue; add: #testAutoAssertFalse; add: #testAutoAssertTrue; add: #testValidShouldNotTakeMoreThanMilliseconds; add: #testErrorInRaiseWithExceptionDo; add: #testNoExceptionInShouldRaiseWithExceptionDo; add: #testInvalidShouldNotTakeMoreThan; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ! 307402TestCase subclass: #SUnitTest 307403 instanceVariableNames: 'hasRun hasSetup hasRanOnce' 307404 classVariableNames: '' 307405 poolDictionaries: '' 307406 category: 'SUnit-Tests'! 307407!SUnitTest commentStamp: '<historical>' prior: 0! 307408This is both an example of writing tests and a self test for the SUnit. The tests 307409here are pretty strange, since you want to make sure things blow up. You should 307410not generally have to write tests this complicated in structure, although they 307411will be far more complicated in terms of your own objects- more assertions, more 307412complicated setup. Kent says: "Never forget, however, that if the tests are hard 307413to write, something is probably wrong with the design".! 307414 307415 307416!SUnitTest methodsFor: 'accessing'! 307417hasRun 307418 ^hasRun 307419 ! ! 307420 307421!SUnitTest methodsFor: 'accessing'! 307422hasSetup 307423 ^hasSetup 307424 ! ! 307425 307426 307427!SUnitTest methodsFor: 'running'! 307428setUp 307429 hasSetup := true 307430 ! ! 307431 307432 307433!SUnitTest methodsFor: 'testing' stamp: 'md 2/22/2006 14:17'! 307434errorShouldntRaise 307435 self 307436 shouldnt: [self someMessageThatIsntUnderstood] 307437 raise: Notification new 307438 ! ! 307439 307440!SUnitTest methodsFor: 'testing'! 307441testAssert 307442 self assert: true. 307443 self deny: false 307444 ! ! 307445 307446!SUnitTest methodsFor: 'testing'! 307447testDefects 307448 | result suite error failure | 307449 suite := TestSuite new. 307450 suite addTest: (error := self class selector: #error). 307451 suite addTest: (failure := self class selector: #fail). 307452 result := suite run. 307453 self assert: result defects asArray = (Array with: error with: failure). 307454 self 307455 assertForTestResult: result 307456 runCount: 2 307457 passed: 0 307458 failed: 1 307459 errors: 1 307460 ! ! 307461 307462!SUnitTest methodsFor: 'testing'! 307463testDialectLocalizedException 307464 307465 self 307466 should: [TestResult signalFailureWith: 'Foo'] 307467 raise: TestResult failure. 307468 self 307469 should: [TestResult signalErrorWith: 'Foo'] 307470 raise: TestResult error. 307471 307472 ! ! 307473 307474!SUnitTest methodsFor: 'testing'! 307475testError 307476 307477 | case result | 307478 307479 case := self class selector: #error. 307480 result := case run. 307481 self 307482 assertForTestResult: result 307483 runCount: 1 307484 passed: 0 307485 failed: 0 307486 errors: 1. 307487 307488 case := self class selector: #errorShouldntRaise. 307489 result := case run. 307490 self 307491 assertForTestResult: result 307492 runCount: 1 307493 passed: 0 307494 failed: 0 307495 errors: 1 307496 ! ! 307497 307498!SUnitTest methodsFor: 'testing'! 307499testException 307500 307501 self 307502 should: [self error: 'foo'] 307503 raise: TestResult error 307504 ! ! 307505 307506!SUnitTest methodsFor: 'testing'! 307507testFail 307508 307509 | case result | 307510 307511 case := self class selector: #fail. 307512 result := case run. 307513 307514 self 307515 assertForTestResult: result 307516 runCount: 1 307517 passed: 0 307518 failed: 1 307519 errors: 0 307520 ! ! 307521 307522!SUnitTest methodsFor: 'testing'! 307523testIsNotRerunOnDebug 307524 307525 | case | 307526 307527 case := self class selector: #testRanOnlyOnce. 307528 case run. 307529 case debug 307530 ! ! 307531 307532!SUnitTest methodsFor: 'testing'! 307533testRanOnlyOnce 307534 307535 self assert: hasRanOnce ~= true. 307536 hasRanOnce := true 307537 ! ! 307538 307539!SUnitTest methodsFor: 'testing'! 307540testResult 307541 307542 | case result | 307543 307544 case := self class selector: #noop. 307545 result := case run. 307546 307547 self 307548 assertForTestResult: result 307549 runCount: 1 307550 passed: 1 307551 failed: 0 307552 errors: 0 307553 ! ! 307554 307555!SUnitTest methodsFor: 'testing' stamp: 'md 2/22/2006 14:16'! 307556testRunning 307557 307558 (Delay forSeconds: 2) wait 307559 ! ! 307560 307561!SUnitTest methodsFor: 'testing' stamp: 'md 2/22/2006 14:19'! 307562testSelectorWithArg: anObject 307563 "should not result in error"! ! 307564 307565!SUnitTest methodsFor: 'testing'! 307566testShould 307567 307568 self 307569 should: [true]; 307570 shouldnt: [false] 307571 ! ! 307572 307573!SUnitTest methodsFor: 'testing'! 307574testSuite 307575 307576 | suite result | 307577 307578 suite := TestSuite new. 307579 suite 307580 addTest: (self class selector: #noop); 307581 addTest: (self class selector: #fail); 307582 addTest: (self class selector: #error). 307583 307584 result := suite run. 307585 307586 self 307587 assertForTestResult: result 307588 runCount: 3 307589 passed: 1 307590 failed: 1 307591 errors: 1 307592 ! ! 307593 307594!SUnitTest methodsFor: 'testing' stamp: 'DF 3/17/2006 01:30'! 307595testWithExceptionDo 307596 307597 self 307598 should: [self error: 'foo'] 307599 raise: TestResult error 307600 withExceptionDo: [:exception | 307601 self assert: (exception description includesSubString: 'foo') 307602 ] 307603 ! ! 307604 307605 307606!SUnitTest methodsFor: 'private'! 307607assertForTestResult: aResult runCount: aRunCount passed: aPassedCount failed: aFailureCount errors: anErrorCount 307608 307609 self 307610 assert: aResult runCount = aRunCount; 307611 assert: aResult passedCount = aPassedCount; 307612 assert: aResult failureCount = aFailureCount; 307613 assert: aResult errorCount = anErrorCount 307614 ! ! 307615 307616!SUnitTest methodsFor: 'private'! 307617error 307618 3 zork 307619 ! ! 307620 307621!SUnitTest methodsFor: 'private'! 307622fail 307623 self assert: false 307624 ! ! 307625 307626!SUnitTest methodsFor: 'private'! 307627noop 307628 ! ! 307629 307630!SUnitTest methodsFor: 'private'! 307631setRun 307632 hasRun := true 307633 ! ! 307634 307635"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 307636 307637SUnitTest class 307638 instanceVariableNames: ''! 307639 307640!SUnitTest class methodsFor: 'history' stamp: 'AdrianLienhard 10/19/2009 10:49'! 307641lastStoredRun 307642 ^ ((Dictionary new) add: (#passed->((Set new) add: #testWithExceptionDo; add: #testAssert; add: #testRanOnlyOnce; add: #testDialectLocalizedException; add: #testFail; add: #testDefects; add: #testIsNotRerunOnDebug; add: #testResult; add: #testRunning; add: #testError; add: #testException; add: #testShould; add: #testSuite; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ! 307643ToolBuilder subclass: #SUnitToolBuilder 307644 instanceVariableNames: 'widgets' 307645 classVariableNames: '' 307646 poolDictionaries: '' 307647 category: 'ToolBuilder-SUnit'! 307648!SUnitToolBuilder commentStamp: 'cwp 6/7/2005 00:53' prior: 0! 307649I create a set of "stub" widgets that are useful for testing. Instead of drawing themselves in some GUI, they simulate graphical widgets for testing purposes. Through my widgets, unit tests can simulate user actions and make assertions about the state of the display. 307650 307651See TestRunnerPlusTest for examples.! 307652 307653 307654!SUnitToolBuilder methodsFor: 'building' stamp: 'ar 7/14/2005 22:33'! 307655buildPluggableButton: aSpec 307656 | w | 307657 w := ButtonStub fromSpec: aSpec. 307658 self register: w id: aSpec name. 307659 ^w! ! 307660 307661!SUnitToolBuilder methodsFor: 'building' stamp: 'ar 7/14/2005 22:33'! 307662buildPluggableList: aSpec 307663 | w | 307664 w := ListStub fromSpec: aSpec. 307665 self register: w id: aSpec name. 307666 ^w! ! 307667 307668!SUnitToolBuilder methodsFor: 'building' stamp: 'cwp 6/8/2005 23:34'! 307669buildPluggableMenu: aSpec 307670 ^ MenuStub fromSpec: aSpec! ! 307671 307672!SUnitToolBuilder methodsFor: 'building' stamp: 'ar 7/14/2005 22:33'! 307673buildPluggablePanel: aSpec 307674 | w | 307675 w := PanelStub fromSpec: aSpec. 307676 self register: w id: aSpec name. 307677 ^w! ! 307678 307679!SUnitToolBuilder methodsFor: 'building' stamp: 'ar 7/14/2005 22:33'! 307680buildPluggableText: aSpec 307681 | w | 307682 w := TextStub fromSpec: aSpec. 307683 self register: w id: aSpec name. 307684 ^w! ! 307685 307686!SUnitToolBuilder methodsFor: 'building' stamp: 'ar 7/14/2005 22:33'! 307687buildPluggableTree: aSpec 307688 | w | 307689 w := TreeStub fromSpec: aSpec. 307690 self register: w id: aSpec name. 307691 ^w! ! 307692 307693!SUnitToolBuilder methodsFor: 'building' stamp: 'stephaneducasse 2/3/2006 22:32'! 307694buildPluggableWindow: aSpec 307695 | window children | 307696 window := WindowStub fromSpec: aSpec. 307697 children := aSpec children. 307698 children isSymbol 307699 ifFalse: [window children: (children collect: [:ea | ea buildWith: self])]. 307700 self register: window id: aSpec name. 307701 ^ window! ! 307702 307703 307704!SUnitToolBuilder methodsFor: 'opening' stamp: 'cwp 7/14/2006 10:53'! 307705close: aWidget 307706 aWidget close! ! 307707 307708!SUnitToolBuilder methodsFor: 'opening' stamp: 'cwp 7/14/2006 10:48'! 307709open: anObject 307710 ^ self build: anObject! ! 307711 307712 307713!SUnitToolBuilder methodsFor: 'private' stamp: 'ar 7/14/2005 22:32'! 307714register: widget id: id 307715 id ifNil:[^self]. 307716 widgets ifNil:[widgets := Dictionary new]. 307717 widgets at: id put: widget.! ! 307718 307719!SUnitToolBuilder methodsFor: 'private' stamp: 'ar 7/14/2005 22:32'! 307720widgetAt: id ifAbsent: aBlock 307721 widgets ifNil:[^aBlock value]. 307722 ^widgets at: id ifAbsent: aBlock! ! 307723ToolBuilderTests subclass: #SUnitToolBuilderTests 307724 instanceVariableNames: '' 307725 classVariableNames: '' 307726 poolDictionaries: '' 307727 category: 'Tests-ToolBuilder'! 307728 307729!SUnitToolBuilderTests methodsFor: 'running' stamp: 'cwp 4/22/2005 21:14'! 307730setUp 307731 super setUp. 307732 builder := SUnitToolBuilder new.! ! 307733 307734 307735!SUnitToolBuilderTests methodsFor: 'support' stamp: 'cwp 4/22/2005 22:47'! 307736acceptWidgetText 307737 widget accept: 'Some text'! ! 307738 307739!SUnitToolBuilderTests methodsFor: 'support' stamp: 'cwp 7/14/2006 11:09'! 307740buttonWidgetEnabled 307741 ^ widget isEnabled! ! 307742 307743!SUnitToolBuilderTests methodsFor: 'support' stamp: 'cwp 5/27/2005 08:22'! 307744changeListWidget 307745 widget clickItemAt: widget selectedIndex + 1! ! 307746 307747!SUnitToolBuilderTests methodsFor: 'support' stamp: 'cwp 4/22/2005 21:37'! 307748fireButtonWidget 307749 widget click! ! 307750 307751!SUnitToolBuilderTests methodsFor: 'support' stamp: 'cwp 6/9/2005 00:07'! 307752fireMenuItemWidget 307753 widget click: 'Menu Item'! ! 307754 307755!SUnitToolBuilderTests methodsFor: 'support' stamp: 'cwp 4/22/2005 22:44'! 307756widgetColor 307757 ^ widget color! ! 307758 307759 307760!SUnitToolBuilderTests methodsFor: 'tests' stamp: 'cwp 5/26/2005 08:40'! 307761testListCached 307762 307763 self makeItemList. 307764 queries := Bag new. 307765 self changed: #getList. 307766 widget list. 307767 widget list. 307768 self assert: queries size = 1! ! 307769 307770!SUnitToolBuilderTests methodsFor: 'tests' stamp: 'cwp 5/27/2005 08:23'! 307771testListSelectionCached 307772 307773 self makeItemList. 307774 queries := Bag new. 307775 self changed: #getListSelection. 307776 widget selectedIndex. 307777 widget selectedIndex. 307778 self assert: queries size = 1! ! 307779 307780!SUnitToolBuilderTests methodsFor: 'tests' stamp: 'cwp 5/30/2005 23:09'! 307781testTextCached 307782 307783 self makeText. 307784 queries := Bag new. 307785 self changed: #getText. 307786 widget text. 307787 widget text. 307788 self assert: queries size = 1! ! 307789Morph subclass: #SVColorSelectorMorph 307790 instanceVariableNames: 'selectedColor locationMorph' 307791 classVariableNames: '' 307792 poolDictionaries: '' 307793 category: 'Polymorph-Widgets'! 307794!SVColorSelectorMorph commentStamp: 'gvc 8/8/2007 14:36' prior: 0! 307795A colour selector that displays an area with saturation on the x axis and volume on the y axis. Provides interactive selection of colour by mouse. For the moment it is event rather than model based. 307796Setting the color will specify the hue and setting the selectedColor will specify the saturation and volume (may have a different hue to that displayed if not in sync).! 307797 307798 307799!SVColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/20/2006 13:37'! 307800locationMorph 307801 "Answer the value of locationMorph" 307802 307803 ^ locationMorph! ! 307804 307805!SVColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/20/2006 13:37'! 307806locationMorph: anObject 307807 "Set the value of locationMorph" 307808 307809 locationMorph := anObject! ! 307810 307811!SVColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 15:08'! 307812selectedColor 307813 "Answer the value of selectedColor" 307814 307815 ^selectedColor ifNil: [self color]! ! 307816 307817!SVColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/21/2006 14:01'! 307818selectedColor: aColor 307819 "Set the value of selectedColor." 307820 307821 selectedColor := aColor. 307822 self locationMorph visible ifTrue: [self updateSelectedLocation]. 307823 self triggerEvent: #colorSelected with: aColor! ! 307824 307825 307826!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 11:54'! 307827adoptPaneColor: paneColor 307828 "Pass on to the border too." 307829 307830 super adoptPaneColor: paneColor. 307831 self borderStyle baseColor: paneColor twiceDarker! ! 307832 307833!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 14:15'! 307834basicColor: aColor 307835 "Set the gradient colors." 307836 307837 super color: aColor asNontranslucentColor. 307838 self 307839 fillStyle: self gradient! ! 307840 307841!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 15:13'! 307842blackGradient 307843 "Answer the black gradient. Top to bottom, transparent to black." 307844 307845 ^(InterpolatedGradientFillStyle colors: {Color black alpha: 0. Color black}) 307846 origin: self innerBounds topLeft; 307847 direction: 0@self innerBounds height! ! 307848 307849!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 11:36'! 307850blackGradientMorph 307851 "Answer the black gradient morph." 307852 307853 ^Morph new 307854 hResizing: #spaceFill; 307855 vResizing: #spaceFill; 307856 fillStyle: self blackGradient! ! 307857 307858!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 15:19'! 307859borderWidth: anInteger 307860 "Update the gradients after setting." 307861 307862 super borderWidth: anInteger. 307863 self updateGradients! ! 307864 307865!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 14:15'! 307866color: aColor 307867 "Set the gradient colors." 307868 307869 self 307870 basicColor: aColor; 307871 selectedColor: (Color h: aColor hue s: self selectedColor saturation v: self selectedColor brightness)! ! 307872 307873!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 10:42'! 307874colorAt: aPoint 307875 "Answer the color in the world at the given point." 307876 307877 ^self isInWorld 307878 ifTrue: [(Display colorAt: aPoint) asNontranslucentColor ] 307879 ifFalse: [Color black]! ! 307880 307881!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 10:33'! 307882extent: p 307883 "Update the gradient directions." 307884 307885 super extent: p. 307886 self updateGradients! ! 307887 307888!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 10:49'! 307889fillStyle: fillStyle 307890 "If it is a color then override with gradient." 307891 307892 fillStyle isColor 307893 ifTrue: [self color: fillStyle] 307894 ifFalse: [super fillStyle: fillStyle]! ! 307895 307896!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:52'! 307897gradient 307898 "Answer the base gradient." 307899 307900 |b| 307901 b := self innerBounds. 307902 ^(GradientFillStyle colors: {Color white. self color}) 307903 origin: b topLeft; 307904 direction: (b width@0)! ! 307905 307906!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/20/2006 12:50'! 307907handlesMouseDown: evt 307908 "Yes for down and move.." 307909 307910 ^true! ! 307911 307912!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 16:33'! 307913handlesMouseOverDragging: evt 307914 "Yes, make the location morph visible when leaving." 307915 307916 ^true! ! 307917 307918!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 11:25'! 307919hideLocation 307920 "Hide the location morph and update the display." 307921 307922 self locationMorph visible: false. 307923 World displayWorldSafely.! ! 307924 307925!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 10:22'! 307926initialize 307927 "Initialize the receiver." 307928 307929 super initialize. 307930 self locationMorph: self newLocationMorph. 307931 self 307932 clipSubmorphs: true; 307933 color: Color blue; 307934 borderStyle: (BorderStyle inset width: 1); 307935 addMorphBack: self locationMorph; 307936 addMorphBack: self blackGradientMorph! ! 307937 307938!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2006 12:23'! 307939layoutBounds: aRectangle 307940 "Set the bounds for laying out children of the receiver. 307941 Note: written so that #layoutBounds can be changed without touching this method" 307942 307943 super layoutBounds: aRectangle. 307944 self updateGradients! ! 307945 307946!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 14:04'! 307947mouseDown: evt 307948 "Handle a mouse down event. Select the color at the mouse position." 307949 307950 evt redButtonPressed 307951 ifFalse: [^super mouseDown: evt]. 307952 evt hand showTemporaryCursor: (Cursor crossHair copy offset: -9@-9). 307953 self hideLocation. 307954 self selectColorAt: evt position. 307955 ^super mouseDown: evt! ! 307956 307957!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 11:56'! 307958mouseEnterDragging: evt 307959 "Make the location morph invisible when entering." 307960 307961 self hideLocation. 307962 evt hand showTemporaryCursor: (Cursor crossHair copy offset: -9@-9).! ! 307963 307964!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 11:56'! 307965mouseLeaveDragging: evt 307966 "Make the location morph visible when leaving." 307967 307968 evt hand showTemporaryCursor: nil. 307969 self showLocation! ! 307970 307971!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 12:11'! 307972mouseMove: evt 307973 "Handle a mouse move event. Select the color at the mouse position." 307974 307975 evt redButtonPressed 307976 ifFalse: [^super mouseMove: evt]. 307977 self selectColorAt: evt position. 307978 ^super mouseMove: evt! ! 307979 307980!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 12:12'! 307981mouseUp: evt 307982 "Handle a up event. Show the location morph again." 307983 307984 evt hand showTemporaryCursor: nil. 307985 self updateSelectedLocation. 307986 self locationMorph visible: true! ! 307987 307988!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 12:16'! 307989newLocationMorph 307990 "Answer a new morph indicating the location of the selected color." 307991 307992 ^ImageMorph new 307993 image: Cursor crossHair withMask asCursorForm! ! 307994 307995!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 12:12'! 307996selectColorAt: aPoint 307997 "Set the color at the given position." 307998 307999 |b p| 308000 b := self innerBounds. 308001 p := (b containsPoint: aPoint) 308002 ifTrue: [aPoint] 308003 ifFalse: [b pointNearestTo: aPoint]. 308004 p := p - b topLeft / b extent. 308005 self selectedColor: (Color 308006 h: self color hue 308007 s: p x 308008 v: 1.0 - p y)! ! 308009 308010!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 15:25'! 308011selectedLocation 308012 "Answer the location within the receiver of the selected colour 308013 relative to the receiver's top left." 308014 308015 |b c x y| 308016 b := self innerBounds. 308017 c := self selectedColor. 308018 x := c saturation * (b width - 1). 308019 y := 1 - c brightness * (b height - 1). 308020 ^(x truncated @ y truncated) + b topLeft! ! 308021 308022!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 11:26'! 308023showLocation 308024 "Show the location morph and update the display." 308025 308026 self locationMorph visible: true. 308027 World displayWorldSafely.! ! 308028 308029!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:52'! 308030updateGradients 308031 "Update the gradient directions." 308032 308033 |bgm b| 308034 b := self innerBounds. 308035 bgm := self submorphs last. 308036 bgm bounds: b. 308037 bgm fillStyle 308038 origin: b topLeft; 308039 direction: 0@b height. 308040 self fillStyle 308041 origin: b topLeft; 308042 direction: (b width@0). 308043 self updateSelectedLocation! ! 308044 308045!SVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 12:17'! 308046updateSelectedLocation 308047 "Position the location morph to indicate the selected colour." 308048 308049 self locationMorph 308050 position: (self selectedLocation - (self locationMorph extent // 2 + (self locationMorph extent \\ 2)))! ! 308051Fraction subclass: #ScaledDecimal 308052 instanceVariableNames: 'scale' 308053 classVariableNames: '' 308054 poolDictionaries: '' 308055 category: 'Kernel-Numbers'! 308056!ScaledDecimal commentStamp: 'nice 5/16/2009 20:45' prior: 0! 308057ScaledDecimal implement a special kind of Fraction that prints in decimal notation. 308058It uses a limited number of digits (scale) after the decimal separation dot and round the result. 308059Note that a ScaledDecimal does not printOn: exactly, however it will storeOn: exactly because the full precision fraction is kept in memory. 308060 308061This is mostly usefull with denominators being powers of 10.! 308062 308063 308064!ScaledDecimal methodsFor: 'accessing' stamp: 'nice 5/16/2009 20:56'! 308065scale 308066 ^scale! ! 308067 308068 308069!ScaledDecimal methodsFor: 'arithmetic' stamp: 'nice 5/17/2009 00:20'! 308070* aNumber 308071 aNumber class = self class ifTrue: [^self asFraction * aNumber asFraction asScaledDecimal: (scale max: aNumber scale)]. 308072 ^self coerce: self asFraction * aNumber! ! 308073 308074!ScaledDecimal methodsFor: 'arithmetic' stamp: 'nice 5/17/2009 00:21'! 308075+ aNumber 308076 aNumber class = self class ifTrue: [^self asFraction + aNumber asFraction asScaledDecimal: (scale max: aNumber scale)]. 308077 ^self coerce: self asFraction + aNumber! ! 308078 308079!ScaledDecimal methodsFor: 'arithmetic' stamp: 'nice 5/17/2009 00:21'! 308080- aNumber 308081 aNumber class = self class ifTrue: [^self asFraction - aNumber asFraction asScaledDecimal: (scale max: aNumber scale)]. 308082 ^self coerce: self asFraction - aNumber! ! 308083 308084!ScaledDecimal methodsFor: 'arithmetic' stamp: 'nice 5/17/2009 00:21'! 308085/ aNumber 308086 aNumber class = self class ifTrue: [^self asFraction / aNumber asFraction asScaledDecimal: (scale max: aNumber scale)]. 308087 ^self coerce: self asFraction / aNumber! ! 308088 308089!ScaledDecimal methodsFor: 'arithmetic' stamp: 'nice 5/16/2009 21:01'! 308090negated 308091 ^self class newFromNumber: super negated scale: scale! ! 308092 308093!ScaledDecimal methodsFor: 'arithmetic' stamp: 'nice 5/16/2009 21:01'! 308094reciprocal 308095 ^self class newFromNumber: super reciprocal scale: scale! ! 308096 308097!ScaledDecimal methodsFor: 'arithmetic' stamp: 'nice 5/16/2009 21:01'! 308098squared 308099 ^self class newFromNumber: super squared scale: scale! ! 308100 308101 308102!ScaledDecimal methodsFor: 'comparing' stamp: 'nice 5/17/2009 00:25'! 308103< aNumber 308104 aNumber class = self class ifTrue: [^self asFraction < aNumber asFraction]. 308105 ^self asFraction < aNumber! ! 308106 308107!ScaledDecimal methodsFor: 'comparing' stamp: 'nice 5/17/2009 00:25'! 308108= aNumber 308109 aNumber class = self class ifTrue: [^self asFraction = aNumber asFraction]. 308110 ^self asFraction = aNumber! ! 308111 308112!ScaledDecimal methodsFor: 'comparing' stamp: 'nice 8/28/2008 19:18'! 308113literalEqual: other 308114 "Testing equality is not enough. 308115 It is also necessary to test number of decimal places (scale). 308116 Otherwise we cannot compile both literals 0.5s1 and 0.50s2 in the same method" 308117 308118 ^(super literalEqual: other) and: [self scale = other scale]! ! 308119 308120 308121!ScaledDecimal methodsFor: 'converting' stamp: 'nice 5/16/2009 23:53'! 308122adaptToFraction: rcvr andSend: selector 308123 "If I am involved in arithmetic with a Fraction, convert it to a ScaledDecimal." 308124 308125 ^(rcvr asScaledDecimal: scale) perform: selector with: self! ! 308126 308127!ScaledDecimal methodsFor: 'converting' stamp: 'nice 5/16/2009 23:42'! 308128adaptToInteger: rcvr andSend: selector 308129 "If I am involved in arithmetic with an Integer, convert it to a ScaledDecimal." 308130 308131 ^(rcvr asScaledDecimal: scale) perform: selector with: self! ! 308132 308133!ScaledDecimal methodsFor: 'converting' stamp: 'nice 5/17/2009 00:19'! 308134asFraction 308135 "Convert the receiver to a Fraction. 308136 Avoid using numerator / denominator to save a useless and costly gcd: computation" 308137 308138 ^denominator = 1 308139 ifTrue: [numerator] 308140 ifFalse: [Fraction numerator: numerator denominator: denominator]! ! 308141 308142 308143!ScaledDecimal methodsFor: 'mathematical functions' stamp: 'nice 5/16/2009 21:06'! 308144raisedTo: aNumber 308145 ^self coerce: (super raisedTo: aNumber)! ! 308146 308147!ScaledDecimal methodsFor: 'mathematical functions' stamp: 'nice 5/16/2009 21:15'! 308148raisedToInteger: aNumber 308149 ^self class newFromNumber: (super raisedToInteger: aNumber) scale: scale! ! 308150 308151 308152!ScaledDecimal methodsFor: 'printing' stamp: 'nice 5/16/2009 22:31'! 308153printOn: aStream 308154 "Append an approximated representation of the receiver on aStream. 308155 Use prescribed number of digits after decimal point (the scale) using a rounding operation if not exact" 308156 308157 | fractionPart | 308158 scale = 0 308159 ifTrue: [self rounded printOn: aStream] 308160 ifFalse: [self integerPart printOn: aStream. 308161 aStream nextPut: $.. 308162 fractionPart := (self abs fractionPart * (10 raisedToInteger: scale)) rounded. 308163 aStream nextPutAll: (String new: scale - (fractionPart numberOfDigitsInBase: 10) withAll: $0). 308164 fractionPart printOn: aStream]. 308165 308166 "Append a scale specification so that the number can be recognized as a ScaledDecimal" 308167 aStream nextPut: $s; print: scale.! ! 308168 308169!ScaledDecimal methodsFor: 'printing' stamp: 'nice 5/16/2009 21:31'! 308170printOn: aStream base: base 308171 base = 10 ifFalse: [self error: 'ScaledDecimals should be printed only in base 10']. 308172 ^self printOn: aStream! ! 308173 308174!ScaledDecimal methodsFor: 'printing' stamp: 'nice 5/16/2009 21:09'! 308175storeOn: aStream 308176 "ScaledDecimal sometimes have more digits than they print (potentially an infinity). 308177 In this case, do not use printOn: because it would loose some extra digits." 308178 308179 self isLiteral 308180 ifTrue: [self printOn: aStream] 308181 ifFalse: [aStream 308182 nextPut: $(; 308183 store: numerator; 308184 nextPut: $/; 308185 store: denominator; 308186 nextPut: $s; 308187 store: scale; 308188 nextPut: $)]! ! 308189 308190 308191!ScaledDecimal methodsFor: 'testing' stamp: 'nice 5/17/2009 00:01'! 308192isFraction 308193 "Though kind of Fraction, pretend we are not a Fraction to let coercion works correctly" 308194 308195 ^false! ! 308196 308197!ScaledDecimal methodsFor: 'testing' stamp: 'nice 5/16/2009 21:11'! 308198isLiteral 308199 "Answer if this number could be a well behaved literal. 308200 Well, it would only if evaluating back to self. 308201 This is not the case of all ScaledDecimals. 308202 Some have an infinite precision and would need an infinite number of digits to print literally. 308203 Try for example (3.00s2 reciprocal)." 308204 308205 ^denominator = 1 "first test trivial case before engaging arithmetic" 308206 or: ["Exactly we should test: 308207 (numerator * (10 raisedTo; scale)) \\ denominator = 0. 308208 But since we can assume fraction is reduced already this will be simply:" 308209 (10 raisedTo: scale) \\ denominator = 0]! ! 308210 308211 308212!ScaledDecimal methodsFor: 'private' stamp: 'nice 5/17/2009 00:21'! 308213coerce: aNumber 308214 "Note: this quick hack could be replaced by double dispatching" 308215 308216 aNumber class = self class ifTrue: [^self class newFromNumber: aNumber scale: (scale max: aNumber scale)]. 308217 (aNumber isFraction or: [aNumber isInteger]) ifTrue: [^self class newFromNumber: aNumber scale: scale]. 308218 ^aNumber! ! 308219 308220!ScaledDecimal methodsFor: 'private' stamp: 'nice 5/16/2009 20:54'! 308221setNumerator: n denominator: d scale: s 308222 308223 self setNumerator: n denominator: d. 308224 scale := s! ! 308225 308226"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 308227 308228ScaledDecimal class 308229 instanceVariableNames: ''! 308230 308231!ScaledDecimal class methodsFor: 'instance creation' stamp: 'nice 5/16/2009 22:23'! 308232newFromNumber: aNumber scale: anInteger 308233 | aFraction | 308234 aFraction := aNumber asFraction. 308235 ^aFraction isFraction 308236 ifTrue: [self new setNumerator: aFraction numerator denominator: aFraction denominator scale: anInteger] 308237 ifFalse: [self new setNumerator: aFraction denominator: 1 scale: anInteger]! ! 308238 308239!ScaledDecimal class methodsFor: 'instance creation' stamp: 'nice 5/16/2009 22:36'! 308240readFrom: stringOrStream 308241 "Answer a decimal number as described on stringOrStream. 308242 The number may not include a leading radix specification, as in 16rFADE, 308243 nor an exponent like 1.0e-3 308244 It might have a scale specification at end or not like 10.3s2 308245 If not, number of digits after decimal point will be used as scale" 308246 308247 ^(SqNumberParser on: stringOrStream) nextScaledDecimal! ! 308248ClassTestCase subclass: #ScaledDecimalTest 308249 instanceVariableNames: '' 308250 classVariableNames: '' 308251 poolDictionaries: '' 308252 category: 'KernelTests-Numbers'! 308253!ScaledDecimalTest commentStamp: '<historical>' prior: 0! 308254I provide a test suite for ScaledDecimal values. Examine my tests to see how SmallIntegers should behave, and see how to use them.! 308255 308256 308257!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 12:22'! 308258testAsNumber 308259 "Ensure no loss of precision" 308260 308261 | sd | 308262 sd := '1.40s2' asNumber. 308263 self assert: ScaledDecimal == sd class. 308264 self assert: sd scale == 2. 308265 self assert: '1.40s2' = sd printString. 308266! ! 308267 308268!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 15:51'! 308269testAsNumberNegatedWithoutDecimalPoint 308270 308271 | sd | 308272 sd := '-123s0' asNumber. 308273 self assert: ScaledDecimal == sd class. 308274 self assert: sd scale == 0. 308275 self assert: '-123s0' = sd printString. 308276! ! 308277 308278!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 15:51'! 308279testAsNumberNegatedWithoutDecimalPoint2 308280 308281 | sd | 308282 sd := '-123s2' asNumber. 308283 self assert: ScaledDecimal == sd class. 308284 self assert: sd scale == 2. 308285 self assert: '-123.00s2' = sd printString. 308286! ! 308287 308288!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 12:21'! 308289testAsNumberWithExtendedScale 308290 308291 | sd | 308292 sd := '123s2' asNumber. 308293 self assert: ScaledDecimal == sd class. 308294 self assert: sd scale == 2. 308295 self assert: '123.00s2' = sd printString. 308296! ! 308297 308298!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 15:49'! 308299testAsNumberWithoutDecimalPoint 308300 308301 | sd | 308302 sd := '123s0' asNumber. 308303 self assert: ScaledDecimal == sd class. 308304 self assert: sd scale == 0. 308305 self assert: '123s0' = sd printString. 308306! ! 308307 308308!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 15:51'! 308309testAsNumberWithoutDecimalPoint2 308310 308311 | sd | 308312 sd := '123s2' asNumber. 308313 self assert: ScaledDecimal == sd class. 308314 self assert: sd scale == 2. 308315 self assert: '123.00s2' = sd printString. 308316! ! 308317 308318!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 12:28'! 308319testAsNumberWithRadix 308320 308321 | sd | 308322 sd := '10r-22.2s5' asNumber. 308323 self assert: ScaledDecimal == sd class. 308324 self assert: sd scale == 5. 308325 self assert: '-22.20000s5' = sd printString. 308326! ! 308327 308328!ScaledDecimalTest methodsFor: 'tests' stamp: 'nice 6/11/2009 03:54'! 308329testAsNumberWithSuperfluousDecimalPoint 308330 308331 | sd | 308332 sd := '123.s2' asNumber. 308333 self deny: ScaledDecimal == sd class description: 'It used to, but this syntax is not valid Smalltalk'. 308334" self assert: sd scale == 2. 308335 self assert: '123.00s2' = sd printString." 308336 308337! ! 308338 308339!ScaledDecimalTest methodsFor: 'tests' stamp: 'nice 5/16/2009 23:48'! 308340testCoercion 308341 #( #* #+ #- #/) do: [:op | 308342 self assert: (1.0s1 perform: op with: 2) class = ScaledDecimal. 308343 self assert: (1.0s1 perform: op with: 1/2) class = ScaledDecimal. 308344 self deny: (1.0s1 perform: op with: 1.0) class = ScaledDecimal. 308345 308346 self assert: (1 perform: op with: 2.0s1) class = ScaledDecimal. 308347 self assert: (1/2 perform: op with: 2.0s1) class = ScaledDecimal. 308348 self deny: (1.0 perform: op with: 1.0s1) class = ScaledDecimal]! ! 308349 308350!ScaledDecimalTest methodsFor: 'tests' stamp: 'nice 5/16/2009 22:33'! 308351testConvertFromFloat 308352 308353 | aFloat sd f2 diff | 308354 aFloat := 11/13 asFloat. 308355 sd := aFloat asScaledDecimal: 2. 308356 self assert: 2 == sd scale. 308357 self assert: '0.85s2' = sd printString. 308358 f2 := sd asFloat. 308359 diff := f2 - aFloat. 308360 self assert: diff < 1.0e-9. "actually, f = f2, but this is not a requirement" 308361! ! 308362 308363!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 12:24'! 308364testConvertFromFraction 308365 308366 | sd | 308367 sd := (13 / 11) asScaledDecimal: 6. 308368 self assert: ScaledDecimal == sd class. 308369 self assert: ('1.181818s6' = sd printString). 308370 self assert: 6 == sd scale 308371! ! 308372 308373!ScaledDecimalTest methodsFor: 'tests' stamp: 'nice 12/3/2007 20:35'! 308374testIsLiteral 308375 "This test is related to http://bugs.squeak.org/view.php?id=6796" 308376 308377 self assert: 1.00s2 isLiteral description: 'every literal obviously isLiteral'. 308378 308379 "Note that (1 / 3.00s2) is not a well behaved literal, 308380 because it does not re-evaluate to self... 308381 Every literal should be evaluated as self (see isSelfEvaluating). 308382 There is currently no way to print it as a literal. 308383 So i propose it shall not answer true." 308384 self deny: (1/3.00s2) isLiteral description: 'this number cannot represent itself as a literal'.! ! 308385 308386!ScaledDecimalTest methodsFor: 'tests' stamp: 'dtl 9/18/2004 13:38'! 308387testLiteral 308388 308389 | sd | 308390 sd := 1.40s2. 308391 self assert: ScaledDecimal == sd class. 308392 self assert: sd scale == 2. 308393 self assert: '1.40s2' = sd printString! ! 308394 308395!ScaledDecimalTest methodsFor: 'tests' stamp: 'nice 5/17/2009 00:38'! 308396testOneRaisedToInteger 308397 "One might be handled specially" 308398 308399 self assert: (1.0s1 raisedToInteger: -1) scale = 1. 308400 self assert: (1.0s1 raisedToInteger: -1) = 1. 308401 self assert: (1.0s1 raisedToInteger: 0) scale = 1. 308402 self assert: (1.0s1 raisedToInteger: 0) = 1. 308403 self assert: (1.0s1 raisedToInteger: 1) scale = 1. 308404 self assert: (1.0s1 raisedToInteger: 1) = 1. 308405 self assert: (1.0s1 raisedToInteger: 2) scale = 1. 308406 self assert: (1.0s1 raisedToInteger: 2) = 1.! ! 308407 308408!ScaledDecimalTest methodsFor: 'tests' stamp: 'nice 5/16/2009 22:28'! 308409testPrintString 308410 "The printed representation of a ScaledDecimal is rounded. 308411 Note that old implementation was truncated." 308412 308413 | sd | 308414 sd := (13 / 11) asScaledDecimal: 6. 308415 self assert: ('1.181818s6' = sd printString). 308416 sd := (13 / 11) asScaledDecimal: 5. 308417 self assert: ('1.18182s5' = sd printString). 308418 sd := (13 / 11) asScaledDecimal: 5. 308419 self deny: ('1.18181s5' = sd printString) 308420! ! 308421 308422!ScaledDecimalTest methodsFor: 'tests' stamp: 'nice 5/17/2009 00:35'! 308423testRaisedToInteger 308424 "Raising to integer should preserve class and scale" 308425 308426 self assert: (3.0s1 raisedToInteger: -1) scale = 1. 308427 self assert: (3.0s1 raisedToInteger: -1) = (1/3). 308428 self assert: (3.0s1 raisedToInteger: 0) scale = 1. 308429 self assert: (3.0s1 raisedToInteger: 0) = 1. 308430 self assert: (3.0s1 raisedToInteger: 1) scale = 1. 308431 self assert: (3.0s1 raisedToInteger: 1) = 3. 308432 self assert: (3.0s1 raisedToInteger: 2) scale = 1. 308433 self assert: (3.0s1 raisedToInteger: 2) = 9.! ! 308434 308435!ScaledDecimalTest methodsFor: 'tests' stamp: 'nice 11/22/2007 22:42'! 308436testReadFrom 308437 "This is related to http://bugs.squeak.org/view.php?id=6779" 308438 308439 self should: [(ScaledDecimal readFrom: '5.3') isKindOf: ScaledDecimal] 308440 description: 'Reading a ScaledDecimal should answer a ScaledDecimal'. 308441 self should: [((ScaledDecimal readFrom: '5.3') asScaledDecimal: 1) = (53/10 asScaledDecimal: 1)] 308442 description: 'ScaledDecimal readFrom: should not use Float intermediate because it would introduce round off errors'.! ! 308443 308444!ScaledDecimalTest methodsFor: 'tests' stamp: 'nice 5/17/2009 00:31'! 308445testScaleExtension 308446 "The scale is extended to the larger one in case of arithmetic operation" 308447 308448 #( #* #+ #- #/) do: [:op | 308449 self assert: (2.5s1 perform: op with: 1.000s3) scale = 3. 308450 self assert: (3.5000s4 perform: op with: 1.0s1) scale = 4.]! ! 308451 308452!ScaledDecimalTest methodsFor: 'tests' stamp: 'nice 5/12/2007 00:34'! 308453testStoreOn 308454 "this is http://bugs.squeak.org/view.php?id=4378" 308455 308456 "Both results should be 1. 308457 ScaledDecimal representations are exact 308458 (though only scale digits or fractional part are printed)" 308459 308460 self assert: 308461 (Compiler evaluate: (0.5s1 squared storeString)) * 4 308462 = (0.5s1 squared * 4)! ! 308463 308464!ScaledDecimalTest methodsFor: 'tests' stamp: 'nice 5/17/2009 00:40'! 308465testZeroRaisedToInteger 308466 "Zero might be handle specially" 308467 308468 self should: [0.0s1 raisedToInteger: -1] raise: Error. 308469 self assert: (0.0s1 raisedToInteger: 0) = 1. 308470 self assert: (0.0s1 raisedToInteger: 0) scale = 1. 308471 self assert: (0.0s1 raisedToInteger: 1) = 0. 308472 self assert: (0.0s1 raisedToInteger: 1) scale = 1. 308473 self assert: (0.0s1 raisedToInteger: 2) = 0. 308474 self assert: (0.0s1 raisedToInteger: 2) scale = 1.! ! 308475Object subclass: #Scanner 308476 instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable' 308477 classVariableNames: 'TypeTable' 308478 poolDictionaries: '' 308479 category: 'Compiler-Kernel'! 308480!Scanner commentStamp: '<historical>' prior: 0! 308481I scan a string or text, picking out Smalltalk syntactic tokens. I look one character ahead. I put each token found into the instance variable, token, and its type (a Symbol) into the variable, tokenType. At the end of the input stream, I pretend to see an endless sequence of special characters called doits.! 308482 308483 308484!Scanner methodsFor: 'error handling' stamp: 'yo 8/28/2002 17:43'! 308485errorMultibyteCharacter 308486 308487 self error: 'multi-byte character is found at unexpected place'. 308488! ! 308489 308490!Scanner methodsFor: 'error handling'! 308491notify: string 308492 "Refer to the comment in Object|notify:." 308493 self error: string! ! 308494 308495!Scanner methodsFor: 'error handling'! 308496offEnd: aString 308497 "Parser overrides this" 308498 308499 ^self notify: aString! ! 308500 308501 308502!Scanner methodsFor: 'expression types'! 308503advance 308504 308505 | prevToken | 308506 prevToken := token. 308507 self scanToken. 308508 ^prevToken! ! 308509 308510!Scanner methodsFor: 'expression types' stamp: 'di 4/23/2000 22:15'! 308511checkpoint 308512 "Return a copy of all changeable state. See revertToCheckpoint:" 308513 308514 ^ {self clone. source clone. currentComment copy}! ! 308515 308516!Scanner methodsFor: 'expression types'! 308517nextLiteral 308518 "Same as advance, but -4 comes back as a number instead of two tokens" 308519 308520 | prevToken | 308521 prevToken := self advance. 308522 (prevToken == #- and: [token isKindOf: Number]) 308523 ifTrue: 308524 [^self advance negated]. 308525 ^prevToken! ! 308526 308527!Scanner methodsFor: 'expression types' stamp: 'eem 5/13/2008 12:44'! 308528scanAllTokenPositionsInto: aBlock 308529 "Evaluate aBlock with the start and end positions of all separate non-white-space tokens, including comments." 308530 308531 | lastMark | 308532 lastMark := 1. 308533 [currentComment notNil ifTrue: 308534 [currentComment do: 308535 [:cmnt| | idx | 308536 idx := source originalContents indexOfSubCollection: cmnt startingAt: lastMark. 308537 (idx > 0 and: [idx < mark]) ifTrue: 308538 [aBlock value: idx - 1 value: (lastMark := idx + cmnt size)]]. 308539 currentComment := nil]. 308540 mark notNil ifTrue: 308541 [(token == #- 308542 and: [(typeTable at: hereChar charCode) = #xDigit]) ifTrue: 308543 [| savedMark | 308544 savedMark := mark. 308545 self scanToken. 308546 token := token negated. 308547 mark := savedMark]. 308548 "Compensate for the fact that the parser uses two character lookahead. Normally we must 308549 remove the extra two chaacters. But this mustn't happen for the last token at the end of stream." 308550 aBlock 308551 value: mark 308552 value: (source atEnd 308553 ifTrue: [tokenType := #doIt. "to cause an immediate ^self" source position] 308554 ifFalse: [source position - 2])]. 308555 (tokenType = #rightParenthesis 308556 or: [tokenType == #doIt]) ifTrue: 308557 [^self]. 308558 tokenType = #leftParenthesis 308559 ifTrue: 308560 [self scanToken; scanAllTokenPositionsInto: aBlock] 308561 ifFalse: 308562 [(tokenType = #word or: [tokenType = #keyword or: [tokenType = #colon]]) 308563 ifTrue: 308564 [self scanLitWord. 308565 token = #true ifTrue: [token := true]. 308566 token = #false ifTrue: [token := false]. 308567 token = #nil ifTrue: [token := nil]] 308568 ifFalse: 308569 [(token == #- 308570 and: [(typeTable at: hereChar charCode) = #xDigit]) 308571 ifTrue: 308572 [self scanToken. 308573 token := token negated]]]. 308574 self scanToken. 308575 true] whileTrue! ! 308576 308577!Scanner methodsFor: 'expression types' stamp: 'PeterHugossonMiller 9/3/2009 11:10'! 308578scanLitByte 308579 | stream | 308580 stream := (ByteArray new: 16) writeStream. 308581 [ tokenType = #rightBracket or: [ tokenType = #doIt ] ] whileFalse: [ 308582 tokenType = #word 308583 ifTrue: [ self scanLitWord ]. 308584 (token isInteger and: [ token between: 0 and: 255 ]) 308585 ifFalse: [ ^ self offEnd: '8-bit integer or right bracket expected' ]. 308586 stream nextPut: token. 308587 self scanToken ]. 308588 token := stream contents! ! 308589 308590!Scanner methodsFor: 'expression types' stamp: 'PeterHugossonMiller 9/3/2009 11:11'! 308591scanLitVec 308592 | s | 308593 s := (Array new: 16) writeStream. 308594 [tokenType = #rightParenthesis or: [tokenType = #doIt]] whileFalse: 308595 [tokenType = #leftParenthesis 308596 ifTrue: 308597 [self scanToken; scanLitVec] 308598 ifFalse: 308599 [(tokenType = #word or: [tokenType = #keyword or: [tokenType = #colon]]) 308600 ifTrue: 308601 [self scanLitWord. 308602 token = #true ifTrue: [token := true]. 308603 token = #false ifTrue: [token := false]. 308604 token = #nil ifTrue: [token := nil]] 308605 ifFalse: 308606 [(token == #- 308607 and: [(self typeTableAt: hereChar) = #xDigit]) ifTrue: 308608 [self scanToken. 308609 token := token negated]]]. 308610 s nextPut: token. 308611 self scanToken]. 308612 token := s contents! ! 308613 308614!Scanner methodsFor: 'expression types' stamp: 'ar 5/10/2005 12:24'! 308615scanLitWord 308616 "Accumulate keywords and asSymbol the result." 308617 308618 | t | 308619 [(self typeTableAt: hereChar) = #xLetter] 308620 whileTrue: 308621 [t := token. 308622 self xLetter. 308623 token := t , token]. 308624 token := token asSymbol! ! 308625 308626!Scanner methodsFor: 'expression types' stamp: 'PeterHugossonMiller 9/3/2009 11:11'! 308627scanStringStruct 308628 308629 | s | 308630 s := (Array new: 16) writeStream. 308631 [tokenType = #rightParenthesis or: [tokenType = #doIt]] 308632 whileFalse: 308633 [tokenType = #leftParenthesis 308634 ifTrue: 308635 [self scanToken; scanStringStruct] 308636 ifFalse: 308637 [tokenType = #word ifFalse: 308638 [^self error: 'only words and parens allowed']]. 308639 s nextPut: token. 308640 self scanToken]. 308641 token := s contents! ! 308642 308643!Scanner methodsFor: 'expression types' stamp: 'ar 5/10/2005 12:24'! 308644scanToken 308645 308646 [(tokenType := self typeTableAt: hereChar) == #xDelimiter] 308647 whileTrue: [self step]. "Skip delimiters fast, there almost always is one." 308648 mark := source position - 1. 308649 (tokenType at: 1) = $x "x as first letter" 308650 ifTrue: [self perform: tokenType "means perform to compute token & type"] 308651 ifFalse: [token := self step asSymbol "else just unique the first char"]. 308652 ^token! ! 308653 308654!Scanner methodsFor: 'expression types'! 308655step 308656 308657 | c | 308658 c := hereChar. 308659 hereChar := aheadChar. 308660 source atEnd 308661 ifTrue: [aheadChar := 30 asCharacter "doit"] 308662 ifFalse: [aheadChar := source next]. 308663 ^c! ! 308664 308665 308666!Scanner methodsFor: 'initialization' stamp: 'PeterHugossonMiller 9/3/2009 11:09'! 308667initScanner 308668 308669 buffer := (String new: 40) writeStream. 308670 typeTable := TypeTable! ! 308671 308672!Scanner methodsFor: 'initialization'! 308673scan: inputStream 308674 "Bind the input stream, fill the character buffers and first token buffer." 308675 308676 source := inputStream. 308677 self step. 308678 self step. 308679 self scanToken! ! 308680 308681 308682!Scanner methodsFor: 'multi-character scans' stamp: 'ar 5/10/2005 12:23'! 308683typeTableAt: aCharacter 308684 ^typeTable at: aCharacter charCode ifAbsent:[#xLetter]! ! 308685 308686!Scanner methodsFor: 'multi-character scans' stamp: 'eem 5/13/2008 13:00'! 308687xBinary 308688 308689 tokenType := #binary. 308690 token := String with: self step. 308691 [hereChar ~~ $- and: [(self typeTableAt: hereChar) == #xBinary]] whileTrue: 308692 [token := token, (String with: self step)]. 308693 token := token asSymbol! ! 308694 308695!Scanner methodsFor: 'multi-character scans' stamp: 'nice 4/14/2009 19:34'! 308696xColon 308697 "Allow := for assignment" 308698 308699 aheadChar = $= ifTrue: 308700 [self step. 308701 tokenType := #leftArrow. 308702 self step. 308703 ^ token := #':=']. 308704 "Otherwise, just do what normal scan of colon would do" 308705 tokenType := #colon. 308706 ^ token := self step asSymbol! ! 308707 308708!Scanner methodsFor: 'multi-character scans'! 308709xDelimiter 308710 "Ignore blanks, etc." 308711 308712 self scanToken! ! 308713 308714!Scanner methodsFor: 'multi-character scans' stamp: 'tao 4/23/98 12:55'! 308715xDigit 308716 "Form a number." 308717 308718 tokenType := #number. 308719 (aheadChar = 30 asCharacter and: [source atEnd 308720 and: [source skip: -1. source next ~= 30 asCharacter]]) 308721 ifTrue: [source skip: -1 "Read off the end last time"] 308722 ifFalse: [source skip: -2]. 308723 token := [Number readFrom: source] ifError: [:err :rcvr | self offEnd: err]. 308724 self step; step! ! 308725 308726!Scanner methodsFor: 'multi-character scans'! 308727xDollar 308728 "Form a Character literal." 308729 308730 self step. "pass over $" 308731 token := self step. 308732 tokenType := #number "really should be Char, but rest of compiler doesn't know"! ! 308733 308734!Scanner methodsFor: 'multi-character scans' stamp: 'PeterHugossonMiller 9/3/2009 11:11'! 308735xDoubleQuote 308736 "Collect a comment." 308737 "wod 1/10/98: Allow 'empty' comments by testing the first character 308738for $"" rather than blindly adding it to the comment being collected." 308739 | aStream stopChar | 308740 stopChar := 30 asCharacter. 308741 aStream := (String new: 200) writeStream. 308742 self step. 308743 [hereChar == $"] 308744 whileFalse: 308745 [(hereChar == stopChar and: [source atEnd]) 308746 ifTrue: [^self offEnd: 'Unmatched comment quote']. 308747 aStream nextPut: self step.]. 308748 self step. 308749 currentComment == nil 308750 ifTrue: [currentComment := OrderedCollection with: aStream 308751contents] 308752 ifFalse: [currentComment add: aStream contents]. 308753 self scanToken! ! 308754 308755!Scanner methodsFor: 'multi-character scans' stamp: 'ar 4/5/2006 01:31'! 308756xIllegal 308757 "An illegal character was encountered" 308758 self notify: 'Illegal character' at: mark! ! 308759 308760!Scanner methodsFor: 'multi-character scans' stamp: 'eem 5/13/2008 13:05'! 308761xLetter 308762 "Form a word or keyword." 308763 308764 | type | 308765 buffer reset. 308766 [(type := self typeTableAt: hereChar) == #xLetter or: [type == #xDigit]] 308767 whileTrue: 308768 ["open code step for speed" 308769 buffer nextPut: hereChar. 308770 hereChar := aheadChar. 308771 aheadChar := source atEnd 308772 ifTrue: [30 asCharacter "doit"] 308773 ifFalse: [source next]]. 308774 tokenType := (type == #colon or: [type == #xColon and: [aheadChar ~~ $=]]) 308775 ifTrue: 308776 [buffer nextPut: self step. 308777 "Allow any number of embedded colons in literal symbols" 308778 [(self typeTableAt: hereChar) == #xColon] whileTrue: 308779 [buffer nextPut: self step]. 308780 #keyword] 308781 ifFalse: 308782 [type == #leftParenthesis 308783 ifTrue: 308784 [buffer nextPut: self step; nextPut: $). 308785 #positionalMessage] 308786 ifFalse:[#word]]. 308787 token := buffer contents! ! 308788 308789!Scanner methodsFor: 'multi-character scans' stamp: 'lr 1/29/2009 20:16'! 308790xLitQuote 308791 "Symbols and vectors: #(1 (4 5) 2 3) #ifTrue:ifFalse: #'abc'." 308792 | start | 308793 start := mark. 308794 self step. 308795 "litQuote" 308796 self scanToken. 308797 tokenType = #leftParenthesis 308798 ifTrue: [self scanToken; scanLitVec. 308799 mark := start + 1. 308800 tokenType == #doIt 308801 ifTrue: [self offEnd: 'Unmatched parenthesis']] 308802 ifFalse: [tokenType = #leftBracket 308803 ifTrue: [self scanToken; scanLitByte. 308804 mark := start + 1. 308805 tokenType == #doIt 308806 ifTrue: [self offEnd: 'Unmatched bracket']] 308807 ifFalse: [(#(#word #keyword #colon ) includes: tokenType) 308808 ifTrue: [self scanLitWord] 308809 ifFalse: [tokenType == #literal 308810 ifTrue: [token isSymbol 308811 ifTrue: ["##word" 308812 token := token 308813 "May want to move toward ANSI 308814 here "]] 308815 ifFalse: [tokenType == #string 308816 ifTrue: [token := token asSymbol]]]]]. 308817 mark := start. 308818 tokenType := #literal 308819 "#(Pen) 308820 #Pen 308821 #'Pen' 308822 ##Pen 308823 ###Pe 308824 "! ! 308825 308826!Scanner methodsFor: 'multi-character scans' stamp: 'ar 3/26/2004 15:45'! 308827xSingleQuote 308828 "String." 308829 308830 self step. 308831 buffer reset. 308832 [hereChar = $' 308833 and: [aheadChar = $' 308834 ifTrue: [self step. false] 308835 ifFalse: [true]]] 308836 whileFalse: 308837 [buffer nextPut: self step. 308838 (hereChar = 30 asCharacter and: [source atEnd]) 308839 ifTrue: [^self offEnd: 'Unmatched string quote']]. 308840 self step. 308841 token := buffer contents. 308842 tokenType := #string! ! 308843 308844!Scanner methodsFor: 'multi-character scans' stamp: 'ar 4/5/2006 01:31'! 308845xUnderscore 308846 Preferences allowUnderscoreAssignment ifFalse:[^self xIllegal]. 308847 self step. 308848 tokenType := #leftArrow. 308849 ^token := #':='! ! 308850 308851!Scanner methodsFor: 'multi-character scans' stamp: 'eem 5/8/2008 17:01'! 308852xUnderscoreForTokenization 308853 self step. 308854 tokenType := #leftArrow. 308855 ^token := #'_'! ! 308856 308857 308858!Scanner methodsFor: 'public access' stamp: 'PeterHugossonMiller 9/3/2009 15:31'! 308859scanFieldNames: stringOrArray 308860 "Answer an Array of Strings that are the identifiers in the input string, 308861 stringOrArray. If passed an Array, just answer with that Array, i.e., 308862 assume it has already been scanned." 308863 308864 | strm | 308865 (stringOrArray isMemberOf: Array) 308866 ifTrue: [^stringOrArray]. 308867 self scan: stringOrArray asString readStream. 308868 strm := (Array new: 10) writeStream. 308869 [tokenType = #doIt] 308870 whileFalse: 308871 [tokenType = #word ifTrue: [strm nextPut: token]. 308872 self scanToken]. 308873 ^strm contents 308874 308875 "Scanner new scanFieldNames: 'abc def ghi' ('abc' 'def' 'ghi' )"! ! 308876 308877!Scanner methodsFor: 'public access' stamp: 'PeterHugossonMiller 9/2/2009 15:55'! 308878scanMessageParts: sourceString 308879 "Return an array of the form (comment keyword comment arg comment keyword comment arg comment) for the message pattern of this method. Courtesy of Ted Kaehler, June 1999" 308880 308881 | coll nonKeywords | 308882 coll := OrderedCollection new. 308883 self scan: sourceString asString readStream. 308884 nonKeywords := 0. 308885 [tokenType = #doIt] whileFalse: 308886 [(currentComment == nil or: [currentComment isEmpty]) 308887 ifTrue: [coll addLast: nil] 308888 ifFalse: [coll addLast: currentComment removeFirst. 308889 [currentComment isEmpty] whileFalse: 308890 [coll at: coll size put: (coll last, ' ', currentComment removeFirst)]]. 308891 (token numArgs < 1 or: [(token = #|) & (coll size > 1)]) 308892 ifTrue: [(nonKeywords := nonKeywords + 1) > 1 ifTrue: [^ coll]] 308893 "done with header" 308894 ifFalse: [nonKeywords := 0]. 308895 coll addLast: token. 308896 self scanToken]. 308897 (currentComment == nil or: [currentComment isEmpty]) 308898 ifTrue: [coll addLast: nil] 308899 ifFalse: [coll addLast: currentComment removeFirst. 308900 [currentComment isEmpty] whileFalse: [ 308901 coll at: coll size put: (coll last, ' ', currentComment removeFirst)]]. 308902 ^ coll! ! 308903 308904!Scanner methodsFor: 'public access' stamp: 'PeterHugossonMiller 9/2/2009 15:56'! 308905scanStringStruct: textOrString 308906 "The input is a string whose elements are identifiers and parenthesized 308907 groups of identifiers. Answer an array reflecting that structure, representing 308908 each identifier by an uninterned string." 308909 308910 self scan: textOrString asString readStream. 308911 self scanStringStruct. 308912 ^token 308913 308914 "Scanner new scanStringStruct: 'a b (c d) (e f g)'"! ! 308915 308916!Scanner methodsFor: 'public access' stamp: 'eem 8/20/2008 20:55'! 308917scanTokenPositionsIn: textOrString into: aBlock 308918 "Evaluate aBlock with the start and end positions of all separate non-white-space tokens, including comments, in textOrString." 308919 308920 self initScannerForTokenization. 308921 source := (ReadStream on: textOrString asString). 308922 self step. 308923 self step. 308924 self scanAllTokenPositionsInto: aBlock 308925 308926 "| code | 308927 code := ' #( 1 2 #( 3 4 )) 16r123 123 123.0 ', (Scanner sourceCodeAt: #scanTokenPositionsIn:into:). 308928 Scanner new scanTokenPositionsIn: code into: [:start :end| Transcript cr; nextPut: $_; nextPutAll: (code copyFrom: start to: end); nextPut: $_; endEntry]" 308929 308930 "CodeDiffBuilder buildDisplayPatchFrom: (Scanner sourceCodeAt: #scanTokenPositionsIn:into:) to: ((Scanner sourceCodeAt: #scanTokenPositionsIn:into:) copyReplaceAll: (String with: Character cr) with: '')" 308931 308932 "CodeDiffBuilder buildDisplayPatchFrom: 'colorTable ^colorTable ifNil: [colorTable _ ST80ColorTable]' to:'colorTable ^colorTable ifNil: [colorTable _ ST80ColorTable]'"! ! 308933 308934!Scanner methodsFor: 'public access' stamp: 'PeterHugossonMiller 9/2/2009 15:56'! 308935scanTokens: textOrString 308936 "Answer an Array that has been tokenized as though the input text, 308937 textOrString, had appeared between the array delimitors #( and ) in a 308938 Smalltalk literal expression." 308939 308940 self scan: textOrString asString readStream. 308941 self scanLitVec. 308942 ^token 308943 308944 "Scanner new scanTokens: 'identifier keyword: 8r31 ''string'' .'"! ! 308945 308946!Scanner methodsFor: 'public access' stamp: 'eem 6/11/2009 14:28'! 308947typedScanTokens: textOrString 308948 "Answer an Array that has been tokenized with literals mapped to literals, 308949 special characters mapped to symbols and variable names and keywords 308950 to strings. This methiod accepts _ (underscore) as an assignment token 308951 irrespective of whether the system prefers := as the assignment token." 308952 | s | 308953 self initScannerForTokenization. 308954 self scan: (ReadStream on: textOrString asString). 308955 s := WriteStream on: (Array new: 16). 308956 [tokenType = #doIt] whileFalse: 308957 [(token == #- 308958 and: [(self typeTableAt: hereChar) = #xDigit]) ifTrue: 308959 [self scanToken. 308960 token := token negated]. 308961 s nextPut: token. 308962 self scanToken]. 308963 ^s contents 308964 308965 "Scanner new typedScanTokens: (Scanner sourceCodeAt: #typedScanTokens:)"! ! 308966 308967 308968!Scanner methodsFor: 'initialize-release' stamp: 'eem 8/20/2008 20:57'! 308969initScannerForTokenization 308970 "Use a version of typeTable that doesn't raise xIllegal when enocuntering an _" 308971 | underscoreIndex | 308972 underscoreIndex := typeTable indexOf: #xUnderscore ifAbsent: [^self]. 308973 typeTable := typeTable copy. 308974 typeTable at: underscoreIndex put: #xUnderscoreForTokenization! ! 308975 308976"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 308977 308978Scanner class 308979 instanceVariableNames: ''! 308980 308981!Scanner class methodsFor: 'initialization' stamp: 'sd 3/20/2008 22:23'! 308982initialize 308983 | newTable | 308984 newTable := Array new: 256 withAll: #xBinary. "default" 308985 newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space" 308986 newTable atAll: ($0 asciiValue to: $9 asciiValue) put: #xDigit. 308987 308988 1 to: 255 308989 do: [:index | 308990 (Character value: index) isLetter 308991 ifTrue: [newTable at: index put: #xLetter]]. 308992 308993 newTable at: 30 put: #doIt. 308994 newTable at: $" asciiValue put: #xDoubleQuote. 308995 newTable at: $# asciiValue put: #xLitQuote. 308996 newTable at: $$ asciiValue put: #xDollar. 308997 newTable at: $' asciiValue put: #xSingleQuote. 308998 newTable at: $: asciiValue put: #xColon. 308999 newTable at: $( asciiValue put: #leftParenthesis. 309000 newTable at: $) asciiValue put: #rightParenthesis. 309001 newTable at: $. asciiValue put: #period. 309002 newTable at: $; asciiValue put: #semicolon. 309003 newTable at: $[ asciiValue put: #leftBracket. 309004 newTable at: $] asciiValue put: #rightBracket. 309005 newTable at: ${ asciiValue put: #leftBrace. 309006 newTable at: $} asciiValue put: #rightBrace. 309007 newTable at: $^ asciiValue put: #upArrow. 309008 newTable at: $_ asciiValue put: #leftArrow. 309009 newTable at: $| asciiValue put: #verticalBar. 309010 TypeTable := newTable "bon voyage!!" 309011 309012 "Scanner initialize"! ! 309013 309014 309015!Scanner class methodsFor: 'instance creation' stamp: 'ar 1/30/2005 11:50'! 309016new 309017 309018 ^self basicNew initScanner! ! 309019 309020 309021!Scanner class methodsFor: 'testing' stamp: 'sd 3/30/2005 22:00'! 309022inviolateInstanceVariableNames 309023 "Answer a list of instance variable names not to be used. (Place holder for real list)" 309024 ^ #('thisContext' 'self')! ! 309025 309026!Scanner class methodsFor: 'testing' stamp: 'sd 3/30/2005 22:00'! 309027isLegalInstVarName: aString 309028 "Answer whether aString is a legal instance variable name." 309029 309030 ^ ((self isLiteralSymbol: aString) and: [(aString includes: $:) not]) and: 309031 [(self inviolateInstanceVariableNames includes: aString) not]! ! 309032 309033!Scanner class methodsFor: 'testing' stamp: 'nice 10/10/2008 20:08'! 309034isLiteralSymbol: aSymbol 309035 "Test whether a symbol can be stored as # followed by its characters. 309036 Symbols created internally with asSymbol may not have this property, 309037 e.g. '3' asSymbol." 309038 309039 | i ascii type next last | 309040 i := aSymbol size. 309041 i = 0 ifTrue: [^ false]. 309042 309043 "TypeTable should have been origined at 0 rather than 1 ..." 309044 ascii := (aSymbol at: 1) asciiValue. 309045 type := TypeTable at: ascii ifAbsent: [^false]. 309046 type == #xLetter ifTrue: [ 309047 next := last := nil. 309048 [i > 1] 309049 whileTrue: 309050 [ascii := (aSymbol at: i) asciiValue. 309051 type := TypeTable at: ascii ifAbsent: [^false]. 309052 (type == #xLetter or: [type == #xDigit or: [type == #xColon 309053 and: [ 309054 next == nil 309055 ifTrue: [last := #xColon. true] 309056 ifFalse: [last == #xColon and: [next ~~ #xDigit and: [next ~~ #xColon]]]]]]) 309057 ifFalse: [^ false]. 309058 next := type. 309059 i := i - 1]. 309060 ^ true]. 309061 type == #xBinary ifTrue: [^i = 1]. "Here we could extend to 309062 ^(2 to: i) allSatisfy: [:j | 309063 ascii := (aSymbol at: j) asciiValue. 309064 (TypeTable at: ascii ifAbsent: []) == #xBinary]" 309065 type == #verticalBar ifTrue: [^i = 1]. 309066 ^false! ! 309067 309068!Scanner class methodsFor: 'testing' stamp: 'fbs 2/13/2006 22:33'! 309069wellFormedInstanceVariableNameFrom: aString 309070 "Answer a legal instance variable name, derived from aString" 309071 309072 | cleansedString | 309073 cleansedString := aString select: [:ch | ch isDigit or: [ch isLetter]]. 309074 (cleansedString isEmpty or: [cleansedString first isDigit]) 309075 ifTrue: [cleansedString := 'a', cleansedString] 309076 ifFalse: [cleansedString := cleansedString withFirstCharacterDownshifted]. 309077 309078 [self isLegalInstVarName: cleansedString] whileFalse: 309079 [cleansedString := cleansedString, 'x']. 309080 ^ cleansedString 309081 309082"Scanner wellFormedInstanceVariableNameFrom: '234 xx\ Uml /ler42342380-4'"! ! 309083TestCase subclass: #ScannerTest 309084 instanceVariableNames: '' 309085 classVariableNames: '' 309086 poolDictionaries: '' 309087 category: 'Tests-Compiler'! 309088 309089!ScannerTest methodsFor: 'testing' stamp: 'nice 10/10/2008 20:42'! 309090testLiteralSymbols 309091 309092 self assert: ('*+-/\~=<>&@%,|' allSatisfy: [:char | Scanner isLiteralSymbol: (Symbol with: char)]) 309093 description: 'single letter binary symbols can be printed without string quotes'. 309094 309095 self assert: (#('x' 'x:' 'x:y:' 'from:to:by:' 'yourself') allSatisfy: [:str | Scanner isLiteralSymbol: str asSymbol]) 309096 description: 'valid ascii selector symbols can be printed without string quotes'. 309097 309098 ((32 to: 126) collect: [:ascii | Character value: ascii]) , 309099 #(':x:yourself' '::' 'x:yourself' '123' 'x0:1:2:' 'x.y.z' '1abc' 'a1b0c2' ' x' 'x ' '+x-y' '||' '--' '++' '+-' '+/-' '-/+' '<|>' '#x' '()' '[]' '{}' '') 309100 do: [:str | 309101 self assert: (Compiler evaluate: str asSymbol printString) = str asSymbol 309102 description: 'in all case, a Symbol must be printed in an interpretable fashion']! ! 309103Timespan subclass: #Schedule 309104 instanceVariableNames: 'schedule' 309105 classVariableNames: '' 309106 poolDictionaries: '' 309107 category: 'Kernel-Chronology'! 309108!Schedule commentStamp: 'brp 5/13/2003 09:48' prior: 0! 309109I represent a powerful class for implementing recurring schedules.! 309110 309111 309112!Schedule methodsFor: 'enumerating' stamp: 'stephane.ducasse 8/7/2009 23:27'! 309113between: aStart and: anEnd do: aBlock 309114 "from Cuis 99" 309115 309116 | element end i startDate | 309117 end := self end min: anEnd. 309118 309119 element := self start. 309120 "Performance optimization. Avoid going through unnecesary days if easy." 309121 startDate := aStart asDate. 309122 (startDate > element asDate and: [ self everyDayAtSameTimes ]) ifTrue: [ 309123 element := DateAndTime date: startDate time: element asTime ]. 309124 309125 i := 1. 309126 [ element < aStart ] whileTrue: [ 309127 element := element + (schedule at: i). 309128 i := i + 1. 309129 i > schedule size ifTrue: [i := 1]]. 309130 i := 1. 309131 [ element <= end ] whileTrue: [ 309132 aBlock value: element. 309133 element := element + (schedule at: i). 309134 i := i + 1. 309135 i > schedule size ifTrue: [i := 1]] 309136. 309137! ! 309138 309139!Schedule methodsFor: 'enumerating' stamp: 'brp 5/13/2003 09:50'! 309140dateAndTimes 309141 309142 | dateAndTimes | 309143 dateAndTimes := OrderedCollection new. 309144 self scheduleDo: [ :e | dateAndTimes add: e ]. 309145 ^ dateAndTimes asArray.! ! 309146 309147!Schedule methodsFor: 'enumerating' stamp: 'brp 5/13/2003 09:50'! 309148schedule 309149 ^ schedule ! ! 309150 309151!Schedule methodsFor: 'enumerating' stamp: 'brp 5/13/2003 09:50'! 309152schedule: anArrayOfDurations 309153 309154 schedule := anArrayOfDurations 309155! ! 309156 309157!Schedule methodsFor: 'enumerating' stamp: 'brp 5/13/2003 09:51'! 309158scheduleDo: aBlock 309159 309160 self between: (self start) and: (self end) do: aBlock. ! ! 309161 309162 309163!Schedule methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:38'! 309164includes: aDateAndTime 309165 309166 | dt | 309167 dt := aDateAndTime asDateAndTime. 309168 self scheduleDo: [ :e | e = dt ifTrue: [^true] ]. 309169 ^ false. 309170! ! 309171 309172 309173!Schedule methodsFor: 'private' stamp: 'stephane.ducasse 8/7/2009 23:28'! 309174everyDayAtSameTimes 309175 "Answer false if unknown" 309176 309177 | count | 309178 count := (Duration days: 1) / self scheduleDuration. 309179 ^ count >= 1 and: [ count isInteger ]! ! 309180 309181!Schedule methodsFor: 'private' stamp: 'stephane.ducasse 8/7/2009 23:27'! 309182scheduleDuration 309183 ^ schedule sum! ! 309184 309185"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 309186 309187Schedule class 309188 instanceVariableNames: ''! 309189ClassTestCase subclass: #ScheduleTest 309190 instanceVariableNames: 'firstEvent aSchedule restoredTimeZone' 309191 classVariableNames: '' 309192 poolDictionaries: '' 309193 category: 'KernelTests-Chronology'! 309194 309195!ScheduleTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 16:03'! 309196classToBeTested 309197 309198 ^ Schedule 309199 309200! ! 309201 309202!ScheduleTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 16:03'! 309203selectorsToBeIgnored 309204 309205 | private | 309206 private := #( #printOn: ). 309207 309208 ^ super selectorsToBeIgnored, private 309209! ! 309210 309211 309212!ScheduleTest methodsFor: 'Tests' stamp: 'brp 9/25/2003 16:08'! 309213testFromDateAndTime 309214 309215 | oc1 oc2 | 309216 oc1 := OrderedCollection new. 309217 DateAndTime today to: DateAndTime tomorrow by: 10 hours do: [ :dt | oc1 add: dt ]. 309218 309219 oc2 := { DateAndTime today. 309220 (DateAndTime today + 10 hours). 309221 (DateAndTime today + 20 hours) }. 309222 309223 self assert: (oc1 asArray = oc2)! ! 309224 309225!ScheduleTest methodsFor: 'Tests' stamp: 'nk 3/30/2004 10:34'! 309226testMonotonicity 309227 309228 | t1 t2 t3 t4 | 309229 t1 := DateAndTime now. 309230 t2 := DateAndTime now. 309231 t3 := DateAndTime now. 309232 t4 := DateAndTime now. 309233 309234 self 309235 assert: ( t1 <= t2); 309236 assert: ( t2 <= t3); 309237 assert: ( t3 <= t4). 309238! ! 309239 309240 309241!ScheduleTest methodsFor: 'running' stamp: 'brp 9/26/2004 19:30'! 309242setUp 309243 "Schedule is a type of Timespan representing repeated occurences of the same event. 309244 The beginning of the schedule is the first occurrence of the event. 309245 A schedule maintains an array of Durations. 309246 Each durations specify the offset to the next scheduled each. 309247 The duration of each occurence of the event is not specified. 309248 Nor are any other attributes such as name" 309249 309250 restoredTimeZone := DateAndTime localTimeZone. 309251 DateAndTime localTimeZone: (TimeZone timeZones detect: [:tz | tz abbreviation = 'GMT']). 309252 309253 "Create aSchedule with an event scheduled for 8:30pm every Saturday 309254 and Sunday for the year 2003. " 309255 "Create the first event occurring on the first Saturday at 8:30 pm: 1/4/03" 309256 firstEvent := DateAndTime year: 2003 month: 1 day: 4 hour: 20 minute: 30. 309257 309258 "Create a schedule for one year starting with the first event" 309259 aSchedule := Schedule starting: firstEvent duration: 52 weeks. 309260 309261 "Schedule the recurring events by scheduling the time in between each one. 309262 One day for Sat-Sun. 6 days for Sun-Sat" 309263 aSchedule schedule: { Duration days: 1. Duration days: 6 }. 309264! ! 309265 309266!ScheduleTest methodsFor: 'running' stamp: 'brp 9/26/2004 19:30'! 309267tearDown 309268 309269 DateAndTime localTimeZone: restoredTimeZone. 309270! ! 309271 309272 309273!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'! 309274testBetweenAndDoDisjointWithSchedule 309275 | count | 309276 count := 0. 309277 aSchedule 309278 between: (DateAndTime 309279 year: 2004 309280 month: 4 309281 day: 1) 309282 and: (DateAndTime 309283 year: 2004 309284 month: 4 309285 day: 30) 309286 do: [:each | count := count + 1]. 309287 self assert: count = 0! ! 309288 309289!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'! 309290testBetweenAndDoIncludedInSchedule 309291 | count | 309292 count := 0. 309293 aSchedule 309294 between: (DateAndTime 309295 year: 2003 309296 month: 4 309297 day: 1) 309298 and: (DateAndTime 309299 year: 2003 309300 month: 4 309301 day: 30) 309302 do: [:each | count := count + 1]. 309303 self assert: count = 8! ! 309304 309305!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'! 309306testBetweenAndDoOverlappingSchedule 309307 | count | 309308 count := 0. 309309 aSchedule 309310 between: (DateAndTime 309311 year: 2002 309312 month: 12 309313 day: 1) 309314 and: (DateAndTime 309315 year: 2003 309316 month: 1 309317 day: 31) 309318 do: [:each | count := count + 1]. 309319 self assert: count = 8! ! 309320 309321!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'! 309322testDateAndTimes 309323 | answer | 309324 self assert: aSchedule dateAndTimes size = 104. 309325 self assert: aSchedule dateAndTimes first = firstEvent. 309326 answer := true. 309327 aSchedule dateAndTimes do: [:each | (each dayOfWeekName = 'Saturday' 309328 or: [each dayOfWeekName = 'Sunday']) ifFalse: [^false]]. 309329 self assert: answer 309330! ! 309331 309332!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'! 309333testExampleFromSwikiPage 309334 "It is often neccessary to schedule repeated events, like airline flight schedules, TV programmes, and file backups. 309335 Schedule is a Timespan which maintains an array of Durations. 309336 The durations specify the offset to the next scheduled DateAndTime. " 309337 "Consider a TV programme scheduled for 8:30pm every Saturday and Sunday for the current year. " 309338 "Find the first Saturday and set its time to 20h30" 309339 | sat shows | 309340 sat := Year current asMonth dates detect: [ :d | d dayOfWeekName = #Saturday ]. 309341 sat := sat start + (Duration hours: 20.5). 309342 "Create a schedule" 309343 shows := Schedule starting: sat ending: Year current end. 309344 shows schedule: { Duration days: 1. Duration days: 6 }. 309345 "To inspect:" 309346 shows dateAndTimes. 309347 shows dateAndTimes collect: [ :dt | dt dayOfWeekName ]. 309348 309349! ! 309350 309351!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'! 309352testIncludes 309353 self assert: (aSchedule includes: (DateAndTime year: 2003 month: 6 day: 15 hour: 20 minute: 30 second: 0 offset: 0 hours)) 309354 309355! ! 309356 309357!ScheduleTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:44'! 309358testSchedule 309359 self assert: aSchedule schedule size = 2. 309360 self assert: aSchedule schedule first = 1 days. 309361 self assert: aSchedule schedule second = 6 days. 309362! ! 309363Object subclass: #ScriptLoader 309364 instanceVariableNames: 'repository inboxRepository repository39 repositorySqueakTrunk repository310 repositoryTaskForces repositoryMC repositoryTreated' 309365 classVariableNames: 'CurrentMajorVersionNumber CurrentScriptVersionNumber CurrentUpdateVersionNumber LogStream PackagesBeforeLastLoad Repository' 309366 poolDictionaries: '' 309367 category: 'ScriptLoader'! 309368!ScriptLoader commentStamp: 'StephaneDucasse 10/18/2009 17:22' prior: 0! 309369Pharo Process Description 309370 309371To change the release stream 309372 ScriptLoader toPharoOne 309373 ScriptLoader toPharoOneDotOne 309374 309375--- 309376In the idea that more people will be able to integrate 309377 309378 309379Here is the pharo process. 309380An enhancement 309381 - should be added to the bug tracker 309382 - announced to the mailing-list 309383 - asked for feedback 309384 - results should be added to the BT entry 309385 309386Fixed tag means ready for integration 309387Closed tag means integrated 309388 309389A bug detected 309390 - discuss via the mailing-list 309391 - should be added to the bug tracker 309392 - fix are considered as enh (see point above) 309393 309394When a fix is fixed it should be either post as cs to the BT entry or in the PharoInbox 309395as a Slice (a slice is an emtpy package that has as requirement other package composing the fix). 309396 309397We have three project: 309398 Pharo 309399 PharoInbox 309400 PharoTreatedInbox 309401 309402A fix goes either from inbox to treatedInbox or to Pharo. 309403If a fix does not work it is moved to the TreatedInbox. 309404If a fix works it is integrated as follow - it will be moved from the Inbox to the TreatedInbox 309405and integrated and published in the Pharo project 309406 309407+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 309408Now the integration works as 4 steps which can be steered by the following 309409ScriptLoader releaseMenu 309410 3094111.) Start up a recent and clean image 309412 ScriptLoader new prepareNewUpdate 309413 309414 This step will 309415 - load the latest updates 309416 - load the latest ScriptLoader package from the Pharo repository. 309417 Indeed when we work on improving the ScriptLoader it is useful to always have the last one 309418 and new versions can be available on the server but not part of the latest updates. 309419 - check that the update.list (which contains the cs to load the packages) is in sync 309420 with the image current version. 309421 scp -p LOGIN@scm.gforge.inria.fr:/home/groups/pharo/htdocs/updates/updates.list . 309422 - snapshot the package version to detect dirty or changed but non dirty packages. 309423 3094242.) Apply changes 309425 309426 ScriptLoader new doneApplyingChanges 309427 309428 This step will 309429 - create an update method with can trigger to load of the packages and some pre/post action 309430 - create a script method with describes all the package versions and it used by the update 309431 - save all the packages that are different (except some filtered packages) 309432 into a local folder named package-to-be-tested. 309433 309434 3094353.) Verify changes 309436 ==> in a ***new*** image (in the current folder) execute: 309437 ScriptLoader new verifyNewUpdate 309438 309439 This step will 309440 - load in any order (so may break) the package previously saved 309441 in the packages to be tested. 309442 309443 3094444.) If there are problems go to 2.) to fix them, else: 309445 ScriptLoader new publishChanges 309446 309447 This step will 309448 - generate a new cs whose purpose is to load the given version of the scriptloader and trigger the 309449 correct update method. 309450 - add the name of the cs file to the end of the updates.list file local to the disc 309451 - copy all the package from the local directory to the Pharo 309452 309453 After the updates.list and the cs file should be manually uploaded to the ftp (see below) 309454 scp "$1" LOGIN@scm.gforge.inria.fr:/home/groups/pharo/htdocs/updates/pharo1.0 309455 309456 309457 309458 309459CurrentMajorVersionNumber should contains a string '1.0', '1.1'.... 309460This string will determine on which folder on the server the updates.list should be loaded. 309461 i.e., updates/pharo1.0, updates/pharo1.1 .... 309462 309463! 309464 309465 309466!ScriptLoader methodsFor: 'accessing' stamp: 'lr 7/10/2009 18:05'! 309467gofer 309468 ^ Smalltalk at: #Gofer ifAbsent: [ self installGofer; gofer ]! ! 309469 309470!ScriptLoader methodsFor: 'accessing' stamp: 'adrian_lienhard 3/16/2009 21:30'! 309471inboxRepository 309472 ^ inboxRepository ifNil: [ 309473 inboxRepository := (MCHttpRepository new 309474 location: 'http://www.squeaksource.com/PharoInbox/'; 309475 user: ''; 309476 password: '')] 309477 ! ! 309478 309479!ScriptLoader methodsFor: 'accessing' stamp: 'dc 3/30/2008 19:50'! 309480installer 309481 ^ Smalltalk 309482 at: #Installer 309483 ifAbsent: 309484 [ self installingInstaller. 309485 Smalltalk at: #Installer ]! ! 309486 309487!ScriptLoader methodsFor: 'accessing' stamp: 'adrian_lienhard 3/16/2009 21:41'! 309488repository 309489 ^ repository ifNil: [ 309490 repository := MCHttpRepository new 309491 location: 'http://www.squeaksource.com/Pharo'; 309492 user: ''; 309493 password: '']! ! 309494 309495!ScriptLoader methodsFor: 'accessing' stamp: 'StephaneDucasse 9/13/2009 15:48'! 309496repository310 309497 ^ repository310 ifNil: [ 309498 repository310 := MCHttpRepository new 309499 location: 'http://source.squeakfoundation.org/310'; 309500 user: ''; 309501 password: '']! ! 309502 309503!ScriptLoader methodsFor: 'accessing' stamp: 'StephaneDucasse 9/10/2009 20:49'! 309504repository39 309505 ^ repository39 ifNil: [ 309506 repository39 := MCHttpRepository new 309507 location: 'http://source.squeakfoundation.org/39a'; 309508 user: ''; 309509 password: '']! ! 309510 309511!ScriptLoader methodsFor: 'accessing' stamp: 'adrian_lienhard 3/16/2009 21:42'! 309512repository: aRepository 309513 repository := aRepository! ! 309514 309515!ScriptLoader methodsFor: 'accessing' stamp: 'StephaneDucasse 9/14/2009 10:32'! 309516repositoryMC 309517 ^ repositoryMC ifNil: [ 309518 repositoryMC := MCHttpRepository new 309519 location: 'http://source.wiresong.ca/mc'; 309520 user: ''; 309521 password: '']! ! 309522 309523!ScriptLoader methodsFor: 'accessing' stamp: 'StephaneDucasse 9/10/2009 20:49'! 309524repositorySqueakTrunk 309525 ^ repositorySqueakTrunk ifNil: [ 309526 repositorySqueakTrunk := MCHttpRepository new 309527 location: 'http://source.squeakfoundation.org/trunk'; 309528 user: ''; 309529 password: '']! ! 309530 309531!ScriptLoader methodsFor: 'accessing' stamp: 'StephaneDucasse 9/13/2009 15:59'! 309532repositoryTaskForces 309533 ^ repositoryTaskForces ifNil: [ 309534 repositoryTaskForces := MCHttpRepository new 309535 location: 'http://www.squeaksource.com/PharoTaskForces'; 309536 user: ''; 309537 password: '']! ! 309538 309539!ScriptLoader methodsFor: 'accessing' stamp: 'StephaneDucasse 9/26/2009 07:47'! 309540repositoryTreated 309541 ^ repositoryTreated ifNil: [ 309542 repositoryTreated := MCHttpRepository new 309543 location: 'http://www.squeaksource.com/PharoTreatedInbox'; 309544 user: ''; 309545 password: '']! ! 309546 309547!ScriptLoader methodsFor: 'accessing' stamp: 'dc 3/30/2008 19:53'! 309548universalInstaller 309549 (Smalltalk at: #UUniverse ifAbsent: [self installingUniverse]). 309550 ^ self installer! ! 309551 309552 309553!ScriptLoader methodsFor: 'cleaning' stamp: 'sd 7/15/2006 20:45'! 309554cleanUpChanges 309555 "Clean up the change sets" 309556 "self new cleanUpChanges" 309557 309558 | projectChangeSetNames | 309559 "Delete all changesets except those currently used by existing projects." 309560 projectChangeSetNames := Project allSubInstances collect: [:proj | proj changeSet name]. 309561 ChangeSet removeChangeSetsNamedSuchThat: 309562 [:cs | (projectChangeSetNames includes: cs) not]. 309563! ! 309564 309565!ScriptLoader methodsFor: 'cleaning' stamp: 'adrian.lienhard 8/13/2009 21:05'! 309566cleanUpForProduction 309567 | oldDicts newDicts | 309568 309569 "trim MC ancestory information" 309570 MCVersionInfo allInstances do: [ :each | each instVarNamed: 'ancestors' put: nil ]. 309571 309572 "delete logo" 309573 (World submorphs detect: [:m | m class = SketchMorph]) delete. 309574 309575 "delete ScriptLoader log" 309576 ScriptLoader resetLogStream. 309577 309578 "unload all test packages" 309579 #(Tests CollectionsTests CompilerTests FreeTypeTests GraphicsTests KernelTests MorphicTests MultilingualTests NetworkTests ToolsTest) 309580 do: [ :each | (MCPackage named: each) unload ]. 309581 309582 "unload SUnit" 309583 Smalltalk at: #TestCase ifPresent: [ :class | 309584 SystemChangeNotifier uniqueInstance noMoreNotificationsFor: class ]. 309585 #(SUnitGUI SUnit) do: [ :each | (MCPackage named: each) unload ]. 309586 AppRegistry removeObsolete. 309587 TheWorldMenu removeObsolete. 309588 309589 "shrink method dictionaries." 309590 Smalltalk garbageCollect. 309591 oldDicts := MethodDictionary allInstances. 309592 newDicts := Array new: oldDicts size. 309593 oldDicts withIndexDo: [:d :index | newDicts at: index put: d rehashWithoutBecome ]. 309594 oldDicts elementsExchangeIdentityWith: newDicts. 309595 oldDicts := newDicts := nil. 309596 309597 3 timesRepeat: [ 309598 Smalltalk garbageCollect. 309599 Symbol compactSymbolTable ]! ! 309600 309601!ScriptLoader methodsFor: 'cleaning' stamp: 'marcus.denker 9/4/2009 14:58'! 309602cleanUpForRelease 309603 "self new cleanUpForRelease" 309604 309605 Author fullName: 'Mr.Cleaner'. 309606 DataStream initialize. 309607 Smalltalk cleanUpUndoCommands. 309608 GradientFillStyle initPixelRampCache. 309609 NaturalLanguageFormTranslator classPool at: #CachedTranslations put: nil. 309610 NaturalLanguageTranslator resetCaches. 309611 FreeTypeCache clearCurrent. 309612 PaintBoxMorph classPool at: #ColorChart put: nil. 309613 PaintBoxMorph classPool at: #Prototype put: nil. 309614 ImageMorph classPool at: #DefaultForm put: (Form extent: 1@1 depth: 1). 309615 Utilities classPool at: #ScrapsBook put: nil. 309616 Project allInstancesDo: [ :each | each setThumbnail: nil ]. 309617 ScriptingSystem stripGraphicsForExternalRelease. 309618 Smalltalk forgetDoIts. 309619 ListParagraph initialize. 309620 PopUpMenu initialize. 309621 Behavior flushObsoleteSubclasses. 309622 CommandHistory resetAllHistory. 309623 CommandHistory allInstancesDo: #initialize. 309624 ChangeSorter removeChangeSetsNamedSuchThat: [ :each | true ]. 309625 ChangeSet resetCurrentToNewUnnamedChangeSet. 309626 MethodChangeRecord allInstancesDo: [ :x | x noteNewMethod: nil ]. 309627 RequiredSelectors initialize. 309628 ProvidedSelectors initialize. 309629 LocalSends initialize. 309630 SendCaches initializeAllInstances. 309631 Utilities cleanseOtherworldlySteppers. 309632 Smalltalk organization removeEmptyCategories. 309633 Browser initialize. 309634 SystemBrowser removeObsolete. 309635 TheWorldMenu removeObsolete. 309636 AppRegistry removeObsolete. 309637 FileServices removeObsolete. 309638 MCFileBasedRepository flushAllCaches. 309639 MCMethodDefinition shutDown. 309640 MCDefinition clearInstances. 309641 ChangeSorter initializeChangeSetCategories. 309642 NaturalLanguageTranslator resetCaches. 309643 NaturalLanguageTranslator classPool at: #AllKnownPhrases put: nil. 309644 Smalltalk at: #TTFontDescription ifPresent: [ :c | c clearDefault; clearDescriptions ]. 309645 ExternalDropHandler resetRegisteredHandlers. 309646 Undeclared removeUnreferencedKeys. 309647 Smalltalk flushClassNameCache. 309648 ScrollBar initializeImagesCache. 309649 FreeTypeFontProvider current initialize. 309650 NaturalLanguageTranslator classPool at: #AllKnownPhrases put: nil. 309651 StandardScriptingSystem classPool at: #HelpStrings put: IdentityDictionary new. 309652 FreeTypeFontProvider current initialize. 309653 SystemNavigation default allObjectsDo: [ :each | 309654 (each respondsTo: #releaseCachedState) ifTrue: [ each releaseCachedState ] ]. 309655 3 timesRepeat: [ Smalltalk garbageCollect. Symbol compactSymbolTable ]. 309656 Set rehashAllSets. 309657 "Remove empty categories, which are not in MC packages, because MC does 309658 not do this (this script does not make packages dirty)" 309659 Smalltalk organization removeEmptyCategories. 309660 Smalltalk allClassesAndTraitsDo: [ :class | 309661 [ :each | each removeEmptyCategories; sortCategories. 309662 ] value: class organization; value: class class organization ]. 309663 self cleanUpChanges. 309664 Smalltalk garbageCollect. 309665 Author reset.! ! 309666 309667!ScriptLoader methodsFor: 'cleaning' stamp: 'marcus.denker 11/30/2008 00:40'! 309668cleanUpMethods 309669 "Make sure that all methods in use are restarted" 309670 309671 WeakArray restartFinalizationProcess. 309672 MethodChangeRecord allInstancesDo:[:x| x noteNewMethod: nil]. 309673 Delay startTimerInterruptWatcher. 309674 WorldState allInstancesDo:[:ws| ws convertAlarms; convertStepList]. 309675 ExternalDropHandler initialize. 309676 ScrollBar initializeImagesCache. 309677 GradientFillStyle initPixelRampCache. 309678 ProcessBrowser initialize. 309679 Smalltalk garbageCollect. 309680 309681 self assert: (CompiledMethod allInstances 309682 reject:[:cm| cm hasNewPropertyFormat]) isEmpty.! ! 309683 309684!ScriptLoader methodsFor: 'cleaning' stamp: 'marcus.denker 9/23/2008 18:47'! 309685fixObsoleteReferences 309686 "self new fixObsoleteReferences" 309687 309688 | informee obsoleteBindings obsName realName realClass | 309689 Preference allInstances do: [:each | 309690 informee := each instVarNamed: #changeInformee. 309691 ((informee isKindOf: Behavior) 309692 and: [informee isObsolete]) 309693 ifTrue: [ 309694 Transcript show: each name; cr. 309695 each instVarNamed: #changeInformee put: (Smalltalk at: (informee name copyReplaceAll: 'AnObsolete' with: '') asSymbol)]]. 309696 309697 CompiledMethod allInstances do: [:method | 309698 obsoleteBindings := method literals select: [:literal | 309699 literal isVariableBinding 309700 and: [literal value isBehavior] 309701 and: [literal value isObsolete]]. 309702 obsoleteBindings do: [:binding | 309703 obsName := binding value name. 309704 Transcript show: obsName; cr. 309705 realName := obsName copyReplaceAll: 'AnObsolete' with: ''. 309706 realClass := Smalltalk at: realName asSymbol ifAbsent: [UndefinedObject]. 309707 binding key: binding key value: realClass]]. 309708 309709 309710 Behavior flushObsoleteSubclasses. 309711 Smalltalk garbageCollect; garbageCollect. 309712 SystemNavigation default obsoleteBehaviors size > 0 309713 ifTrue: [SystemNavigation default obsoleteBehaviors inspect]! ! 309714 309715!ScriptLoader methodsFor: 'cleaning' stamp: 'md 8/2/2006 18:12'! 309716flushCaches 309717 309718 MCFileBasedRepository flushAllCaches. 309719 MCDefinition clearInstances. 309720 Smalltalk garbageCollect. 309721 309722 "Initialization required for tests: strange why this is not a teardwon method" 309723 SendCaches initializeAllInstances.! ! 309724 309725 309726!ScriptLoader methodsFor: 'fixing stream' stamp: 'alain.plantec 2/6/2009 15:49'! 309727installVersionInfo 309728 "self new installVersionInfo" 309729 309730 | highestUpdate newVersion | 309731 highestUpdate := SystemVersion current highestUpdate. 309732 (self confirm: 'Reset highest update (' , highestUpdate printString , ')?') 309733 ifTrue: [SystemVersion current highestUpdate: 0]. 309734 309735 newVersion := UIManager default request: 'New version designation:' translated initialAnswer: '3.9' , highestUpdate printString. 309736 SystemVersion newVersion: newVersion. 309737 309738! ! 309739 309740!ScriptLoader methodsFor: 'fixing stream' stamp: 'stephane.ducasse 2/6/2009 17:36'! 309741unloadPackageNamed: aString 309742 "self new workingCopyFromPackageName: 'CollectionExtensions' " 309743 309744 ^ (self workingCopyFromPackageName: aString) unload 309745 ! ! 309746 309747!ScriptLoader methodsFor: 'fixing stream' stamp: 'sd 3/24/2008 17:31'! 309748workingCopyFromPackageName: aString 309749 "self new workingCopyFromPackageName: '39Deprecated' " 309750 309751 |pa| 309752 pa := MCPackage named: aString. 309753 ^ pa workingCopy 309754 ! ! 309755 309756 309757!ScriptLoader methodsFor: 'generate scripts/methods' stamp: 'stephane.ducasse 6/14/2008 15:32'! 309758compileNewUpdateMethod 309759 "Use me to create a new update method with the next update number" 309760 "self new compileNewUpdateMethod" 309761 309762 309763 self class compile: 309764 (self generateNewUpdateMethod) 309765 classified: 'pharo - updates'! ! 309766 309767!ScriptLoader methodsFor: 'generate scripts/methods' stamp: 'stephane.ducasse 6/14/2008 15:38'! 309768compileScriptMethodWithCurrentPackages: aNumber 309769 "ScriptLoader new compileScriptMethodWithCurrentPackages: 9999" 309770 309771 self class compile: 309772 (self generateScriptTemplateWithCurrentPackages: aNumber) 309773 classified: 'pharo - scripts'! ! 309774 309775!ScriptLoader methodsFor: 'generate scripts/methods' stamp: 'adrian lienhard 11/7/2008 22:08'! 309776currentScriptVersionNumber 309777 ^ CurrentScriptVersionNumber! ! 309778 309779!ScriptLoader methodsFor: 'generate scripts/methods' stamp: 'DamienCassou 9/8/2009 14:41'! 309780currentUpdateVersionNumber 309781 ^ CurrentUpdateVersionNumber ifNil: [SystemVersion current highestUpdate]! ! 309782 309783!ScriptLoader methodsFor: 'generate scripts/methods' stamp: 'stephane.ducasse 8/14/2008 16:06'! 309784generateCS: packageInfo fromUpdate: updateNumber on: st 309785 309786 st nextPutAll: 309787'"Postscript: 309788Leave the line above, and replace the rest of this comment by a useful one. 309789Executable statements should follow this comment, and should 309790be separated by periods, with no exclamation points (!!!!). 309791Be sure to put any further comments in double-quotes, like this one." 309792 309793|repository| 309794repository := MCHttpRepository 309795 location: ''http://www.squeaksource.com/Pharo/'' 309796 user: '''' 309797 password: ''''. 309798(repository loadVersionFromFileNamed:' . 309799 st nextPut: $' ; nextPutAll: packageInfo, '.mcz'') load.'; cr. 309800 st nextPutAll: 'ScriptLoader new update', (updateNumber) asString; nextPutAll: '.' ; cr. 309801 st nextPutAll: '!!'. 309802 ^ st contents 309803! ! 309804 309805!ScriptLoader methodsFor: 'generate scripts/methods' stamp: 'DamienCassou 8/30/2009 14:48'! 309806generateNewUpdateMethod 309807 "ScriptLoader new generateNewUpdateMethod" 309808 309809 | str mthName preamble postscript | 309810 str := ReadWriteStream on: (String new: 1000). 309811 mthName := 'update', self currentUpdateVersionNumber asString. 309812 str nextPutAll: mthName ; cr ; tab. 309813 str nextPutAll: '"self new ', mthName, '"'; crtab. 309814 preamble := UIManager default 309815 multiLineRequest: 'Preamble expression' 309816 centerAt: Sensor cursorPoint 309817 initialAnswer: '' 309818 answerHeight: 100. 309819 preamble isEmptyOrNil ifFalse: [str nextPutAll: preamble; ensureEndsWith: $.; crtab]. 309820 309821 str nextPutAll: 'self withUpdateLog: ' ; nextPut: $'; nextPutAll: self commentForCurrentUpdate ; nextPut: $'; nextPut: $. . 309822 str crtab. 309823 str nextPutAll: 'self script' , self currentScriptVersionNumber asString, '.'. 309824 str crtab. 309825 postscript := UIManager default 309826 multiLineRequest: 'Postscript expression' 309827 centerAt: Sensor cursorPoint 309828 initialAnswer: '' 309829 answerHeight: 100. 309830 postscript isEmptyOrNil ifFalse: [str nextPutAll: postscript; ensureEndsWith: $.; crtab]. 309831 str nextPutAll: 'self flushCaches.'; cr. 309832 309833 ^ str contents! ! 309834 309835!ScriptLoader methodsFor: 'generate scripts/methods' stamp: 'stephane.ducasse 3/21/2009 14:41'! 309836generateScriptTemplateWithAllCurrentPackages 309837 "ScriptLoader new generateScriptTemplateWithAllCurrentPackages" 309838 309839 | str | 309840 str := ReadWriteStream on: (String new: 1000). 309841 str nextPutAll: 'scriptXXX' ; cr ; cr ; tab. 309842 str nextPutAll: '| names|'; cr. 309843 str nextPutAll: 'names := '. 309844 str nextPut: $'. 309845 self currentVersionsToBeSaved do: 309846 [:each | 309847 str nextPutAll: each ; nextPutAll: '.mcz'] 309848 separatedBy: [str nextPut: Character cr]. 309849 str nextPut: $'; nextPut: Character cr. 309850 str nextPutAll: 'findTokens: String lf , String cr. 309851 309852 self loadTogether: names merge: false.'. 309853 ^ str contents! ! 309854 309855!ScriptLoader methodsFor: 'generate scripts/methods' stamp: 'stephane.ducasse 3/21/2009 18:07'! 309856generateScriptTemplateWithCurrentPackages: aNumber 309857 "ScriptLoader new generateScriptTemplateWithCurrentPackages" 309858 309859 | str withoutScriptLoader | 309860 str := ReadWriteStream on: (String new: 1000). 309861 str nextPutAll: 'script', aNumber asString ; cr ; cr ; tab. 309862 str nextPutAll: '| names |'; cr. 309863 str nextPutAll: 'names := '. 309864 str nextPut: $'. 309865 withoutScriptLoader := self currentVersionsToBeSaved. 309866 withoutScriptLoader 309867 do: [ :each | str nextPutAll: each ; nextPutAll: '.mcz'] 309868 separatedBy: [str nextPut: Character cr]. 309869 str nextPut: $'; nextPut: Character cr. 309870 str nextPutAll: 'findTokens: String lf , String cr. 309871 309872 self loadTogether: names merge: false.'. 309873 ^ str contents! ! 309874 309875!ScriptLoader methodsFor: 'generate scripts/methods' stamp: 'al 11/1/2008 18:15'! 309876getLatestScriptNumber 309877 "self new getLatestScriptNumber" 309878 309879 | upfroms | 309880 upfroms := self class selectors select: [:each | 'script*' match: each ]. 309881 upfroms := upfroms collect: [:each | (each asString allButFirst: 6)]. 309882 upfroms := upfroms reject: [:each | '*Log*' match: each ]. 309883 upfroms := upfroms reject: [:each | '*XXX*' match: each ]. 309884 upfroms := upfroms collect: [:each | each asNumber]. 309885 ^ upfroms asSortedCollection last 309886 ! ! 309887 309888!ScriptLoader methodsFor: 'generate scripts/methods' stamp: 'StephaneDucasse 10/17/2009 12:33'! 309889getLatestUpdateNumber 309890 "self new getLatestUpdateNumber" 309891 309892 | upfroms | 309893 upfroms := self class selectors select: [:each | 'update*' match: each ]. 309894 upfroms := upfroms collect: [:each | [(each asString last: 5) asNumber] on: Error do: [0]]. 309895 ^ upfroms asSortedCollection last! ! 309896 309897!ScriptLoader methodsFor: 'generate scripts/methods' stamp: 'adrian lienhard 11/7/2008 22:07'! 309898setUpdateAndScriptVersionNumbers 309899 CurrentUpdateVersionNumber := self getLatestUpdateNumber + 1. 309900 CurrentScriptVersionNumber := self getLatestScriptNumber + 1.! ! 309901 309902!ScriptLoader methodsFor: 'generate scripts/methods' stamp: 'sd 7/8/2006 18:20'! 309903writeCS: extensionAndNumber forUpdate: updateNumber 309904 "ScriptLoader new writeCS: '-sd.210' forUpdate: 7037" 309905 309906 self writeCS: extensionAndNumber forUpdate: updateNumber withName: 'changeMe'! ! 309907 309908!ScriptLoader methodsFor: 'generate scripts/methods' stamp: 'md 8/2/2006 18:06'! 309909writeCS: extensionAndNumber forUpdate: updateNumber withName: aSt 309910 "ScriptLoader new writeCS: '-md.2929' forUpdate: 7049 withName: 'cleanUpMethods'" 309911 309912 | str | 309913 str := FileDirectory default forceNewFileNamed: updateNumber asString, 'update', aSt, '.cs'. 309914 self generateCS: extensionAndNumber fromUpdate: updateNumber on: str. 309915 str close.! ! 309916 309917 309918!ScriptLoader methodsFor: 'initialize' stamp: 'stephane.ducasse 3/18/2009 21:13'! 309919initialize 309920 super initialize. 309921 PackagesBeforeLastLoad ifNil: [ PackagesBeforeLastLoad := Set new ]! ! 309922 309923 309924!ScriptLoader methodsFor: 'load primitives' stamp: 'al 12/8/2005 21:18'! 309925loadOneAfterTheOther: aCollection merge: aBoolean 309926 | loader | 309927 (self newerVersionsIn: aCollection) 309928 do: [:fn | 309929 loader := aBoolean 309930 ifTrue: [ MCVersionMerger new ] 309931 ifFalse: [ MCVersionLoader new]. 309932 loader addVersion: (self repository loadVersionFromFileNamed: fn). 309933 aBoolean 309934 ifTrue: [[loader merge] on: MCMergeResolutionRequest do: [:request | 309935 request merger conflicts isEmpty 309936 ifTrue: [request resume: true] 309937 ifFalse: [request pass]]] 309938 ifFalse: [loader load]] 309939 displayingProgress: 'Loading versions...'. 309940 309941 309942! ! 309943 309944!ScriptLoader methodsFor: 'load primitives' stamp: 'adrian_lienhard 2/21/2009 13:40'! 309945loadOneAfterTheOther: aCollection merge: aBoolean silently: anotherBoolean 309946 anotherBoolean 309947 ifTrue: [ 309948 [ self loadOneAfterTheOther: aCollection merge: aBoolean ] 309949 on: ProgressInitiationException do: [:e | e sendNotificationsTo: [ :min :max :curr ] ] ] 309950 ifFalse: [ 309951 self loadOneAfterTheOther: aCollection merge: aBoolean ]! ! 309952 309953!ScriptLoader methodsFor: 'load primitives' stamp: 'michael.rueger 1/13/2009 15:26'! 309954loadTogether: aCollection merge: aBoolean 309955 | loader | 309956 loader := aBoolean 309957 ifTrue: [ MCVersionMerger new ] 309958 ifFalse: [ MCVersionLoader new]. 309959 (self newerVersionsIn: aCollection) 309960 do: [:fn | loader addVersion: (self loadVersionFromFileNamed: fn)] 309961 displayingProgress: 'Adding versions...'. 309962 aBoolean 309963 ifTrue: [[loader merge] on: MCMergeResolutionRequest do: [:request | 309964 request merger conflicts isEmpty 309965 ifTrue: [request resume: true] 309966 ifFalse: [request pass]]] 309967 ifFalse: [loader hasVersions ifTrue: [loader load]] 309968 309969! ! 309970 309971!ScriptLoader methodsFor: 'load primitives' stamp: 'al 5/10/2008 12:41'! 309972loadTogether: aCollection merge: aBoolean silently: anotherBoolean 309973 anotherBoolean 309974 ifTrue: [ 309975 [ self loadTogether: aCollection merge: aBoolean ] 309976 on: ProgressInitiationException do: [:e | e sendNotificationsTo: [ :min :max :curr ] ] ] 309977 ifFalse: [ 309978 self loadTogether: aCollection merge: aBoolean ]! ! 309979 309980!ScriptLoader methodsFor: 'load primitives' stamp: 'al 10/13/2005 21:44'! 309981newerVersionsIn: aCollection 309982 ^aCollection reject: [:each | 309983 MCWorkingCopy allManagers anySatisfy: [:workingcopy | 309984 workingcopy ancestry ancestorString , '.mcz' = each]].! ! 309985 309986 309987!ScriptLoader methodsFor: 'log' stamp: 'sd 4/4/2008 14:47'! 309988log: aString 309989 309990 self logStream cr; nextPutAll: aString ; cr.! ! 309991 309992!ScriptLoader methodsFor: 'log' stamp: 'sd 3/15/2008 18:30'! 309993logContents 309994 309995 ^ self logStream contents! ! 309996 309997!ScriptLoader methodsFor: 'log' stamp: 'adrian_lienhard 3/16/2009 21:30'! 309998logStream 309999 ^ LogStream ifNil: [ 310000 LogStream := ReadWriteStream on: (String new: 1000)]! ! 310001 310002!ScriptLoader methodsFor: 'log' stamp: 'sd 3/24/2008 16:46'! 310003withUdpateLog: aString 310004 310005 "self deprecated" 310006 self flag: #toRemove. 310007 self withUpdateLog: aString! ! 310008 310009!ScriptLoader methodsFor: 'log' stamp: 'sd 3/24/2008 16:45'! 310010withUpdateLog: aString 310011 310012 self logStream nextPutAll: ' ------------------------------------------------------' ; cr. 310013 self logStream nextPutAll: thisContext sender selector asString. 310014 self logStream cr; nextPutAll: aString ; cr.! ! 310015 310016 310017!ScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 9/26/2009 07:46'! 310018addExtraRepositories 310019 310020 "self new addExtraRepositories" 310021 310022 self addRepository39ToAllPackages. 310023 self addRepository310ToAllPackages. 310024 self addRepositoryTaskForcesToAllPackages. 310025 self addRepositorySqueakTrunkToAllPackages. 310026 self addRepositoryMCToAllPackages. 310027 self addRepositoryTreatedToAllPackages.! ! 310028 310029!ScriptLoader methodsFor: 'mc related utils' stamp: 'sd 3/15/2008 18:10'! 310030addHomeRepositoryToAllPackages 310031 "self new removeAllRepositories: #('http://www.squeaksource.com/Sapphire/' 'http://www.squeaksource.com/SapphireInbox/')" 310032 "self new addHomeRepositoryToAllPackages" 310033 310034 MCWorkingCopy allManagers do: [:each | 310035 each repositoryGroup 310036 addRepository: self repository; 310037 addRepository: self inboxRepository]. 310038 310039 ! ! 310040 310041!ScriptLoader methodsFor: 'mc related utils' stamp: 'sd 3/15/2008 17:40'! 310042addHomeRepositoryToPackageNamed: aString 310043 310044 |pa| 310045 pa := MCPackage named: aString. 310046 pa workingCopy repositoryGroup addRepository: self repository. 310047 ! ! 310048 310049!ScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 10/18/2009 16:11'! 310050addPackage: aString 310051 "to be tested" 310052 310053 | workingCopy | 310054 PackageInfo registerPackageName: aString. 310055 workingCopy := MCWorkingCopy forPackage: (MCPackage new name: aString)! ! 310056 310057!ScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 9/13/2009 15:48'! 310058addRepository310ToAllPackages 310059 "self new addRepository310ToAllPackages" 310060 310061 MCWorkingCopy allManagers do: [:each | 310062 each repositoryGroup 310063 addRepository: self repository310 310064 ]. 310065 310066 ! ! 310067 310068!ScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 9/6/2009 17:38'! 310069addRepository39ToAllPackages 310070 "self new removeAllRepositories: #('http://www.squeaksource.com/Sapphire/' 'http://www.squeaksource.com/SapphireInbox/')" 310071 "self new addRepository39ToAllPackages" 310072 310073 MCWorkingCopy allManagers do: [:each | 310074 each repositoryGroup 310075 addRepository: self repository39 310076 ]. 310077 310078 ! ! 310079 310080!ScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 9/14/2009 10:31'! 310081addRepositoryMCToAllPackages 310082 310083 "self new addRepositoryMCToAllPackages" 310084 310085 MCWorkingCopy allManagers do: [:each | 310086 each repositoryGroup 310087 addRepository: self repositoryMC 310088 ]. 310089 310090 ! ! 310091 310092!ScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 9/10/2009 20:47'! 310093addRepositorySqueakTrunkToAllPackages 310094 "self new removeAllRepositories: #('http://www.squeaksource.com/Sapphire/' 'http://www.squeaksource.com/SapphireInbox/')" 310095 "self new addRepositorySqueakTrunkToAllPackages" 310096 310097 MCWorkingCopy allManagers do: [:each | 310098 each repositoryGroup 310099 addRepository: self repositorySqueakTrunk 310100 ]. 310101 310102 ! ! 310103 310104!ScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 9/13/2009 15:59'! 310105addRepositoryTaskForcesToAllPackages 310106 "self new addRepositoryTaskForcesToAllPackages" 310107 310108 MCWorkingCopy allManagers do: [:each | 310109 each repositoryGroup 310110 addRepository: self repositoryTaskForces 310111 ]. 310112 310113 ! ! 310114 310115!ScriptLoader methodsFor: 'mc related utils' stamp: 'sd 10/31/2005 18:01'! 310116addRepositoryToPackageNamed: aString 310117 310118 |pa| 310119 pa := MCPackage named: aString. 310120 pa workingCopy repositoryGroup addRepository: self repository. 310121 ! ! 310122 310123!ScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 9/26/2009 07:46'! 310124addRepositoryTreatedToAllPackages 310125 "self new addRepositoryTreatedToAllPackages" 310126 310127 MCWorkingCopy allManagers do: [:each | 310128 each repositoryGroup 310129 addRepository: self repositoryTreated 310130 ]. 310131 310132 ! ! 310133 310134!ScriptLoader methodsFor: 'mc related utils' stamp: 'stephane.ducasse 6/30/2008 15:15'! 310135allCurrentDirtyPackages 310136 "ScriptLoader new allCurrentDirtyPackages" 310137 "return all the current dirty packages even the ones that we do not want to save" 310138 310139 310140 ^ self allCurrentPackages select: [:each | each needsSaving]. 310141 310142 ! ! 310143 310144!ScriptLoader methodsFor: 'mc related utils' stamp: 'stephane.ducasse 6/30/2008 15:15'! 310145allCurrentPackages 310146 "ScriptLoader new allCurrentPackages" 310147 310148 | copies | 310149 copies := MCWorkingCopy allManagers asSortedCollection: 310150 [ :a :b | a package name <= b package name ]. 310151 ^ copies! ! 310152 310153!ScriptLoader methodsFor: 'mc related utils' stamp: 'adrianLienhard 11/1/2008 22:50'! 310154allCurrentVersions 310155 "self new allCurrentVersions" 310156 310157 | copies names | 310158 copies := MCWorkingCopy allManagers asSortedCollection: 310159 [ :a :b | a package name <= b package name ]. 310160 names := copies collect: 310161 [:ea | ea ancestry ancestorString ]. 310162 ^ names reject: #isEmpty! ! 310163 310164!ScriptLoader methodsFor: 'mc related utils' stamp: 'stephane.ducasse 3/18/2009 21:13'! 310165currentChangedPackages 310166 "self new currentChangedPackages" 310167 310168 ^ self currentPackages select: [:each | 310169 each needsSaving or: [ 310170 (PackagesBeforeLastLoad includes: each ancestry ancestorString) not ] ]! ! 310171 310172!ScriptLoader methodsFor: 'mc related utils' stamp: 'al 11/1/2008 19:49'! 310173currentPackages 310174 "self new currentPackages" 310175 310176 310177 | copies | 310178 copies := MCWorkingCopy allManagers asSortedCollection: 310179 [ :a :b | a package name <= b package name ]. 310180 ^ copies reject: [:each | 310181 self packagesNotToSavePatternNames 310182 anySatisfy: [:p | p match: each package name]]. 310183 ! ! 310184 310185!ScriptLoader methodsFor: 'mc related utils' stamp: 'sd 5/29/2006 20:52'! 310186currentVersions 310187 "ScriptLoader new currentVersions" 310188 310189 | copies | 310190 copies := MCWorkingCopy allManagers asSortedCollection: 310191 [ :a :b | a package name <= b package name ]. 310192 ^ copies collect: 310193 [:ea | ea ancestry ancestorString ]! ! 310194 310195!ScriptLoader methodsFor: 'mc related utils' stamp: 'al 11/1/2008 19:49'! 310196currentVersionsToBeSaved 310197 "self new currentVersionsToBeSaved" 310198 310199 ^ self allCurrentVersions reject: [ :each | 310200 self packagesNotToSavePatternNames 310201 anySatisfy: [ :p | p match: each ] ]! ! 310202 310203!ScriptLoader methodsFor: 'mc related utils' stamp: 'stephane.ducasse 1/13/2009 10:46'! 310204deletePackage: aString 310205 310206 | toRemove | 310207 toRemove := (MCWorkingCopy allManagers asSortedCollection: 310208 [ :a :b | a package name <= b package name ]) detect: [:each | each package name = aString]. 310209 MCWorkingCopy registry removeKey: toRemove package.! ! 310210 310211!ScriptLoader methodsFor: 'mc related utils' stamp: 'sd 3/15/2008 14:46'! 310212installRepository: aString for: packageName 310213 310214 (MCWorkingCopy allManagers select: [:each | each package name = packageName]) 310215 first repositoryGroup 310216 addRepository: (MCHttpRepository new location: aString ; user: '' ; password: '') 310217 ! ! 310218 310219!ScriptLoader methodsFor: 'mc related utils' stamp: 'stephane.ducasse 8/14/2008 16:03'! 310220latestScriptLoaderPackageIdentificationString 310221 "ScriptLoader new latestScriptLoaderPackageIdentificationString" 310222 310223 ^ self allCurrentVersions detect: [:each | 'ScriptLoader*' match: each ] 310224 ! ! 310225 310226!ScriptLoader methodsFor: 'mc related utils' stamp: 'sd 3/15/2008 17:32'! 310227removeAllRepositories: aColl 310228 "self new removeAllRepositories: 310229 #('http://source.squeakfoundation.org/inbox/' 310230 'http://source.squeakfoundation.org/39a/' 310231 'http://source.squeakfoundation.org/Balloon/' 310232 'http://source.squeakfoundation.org/Compression/' 310233 'http://source.squeakfoundation.org/Graphics/' 310234 'http://source.wiresong.ca/mc/')" 310235 310236 310237 MCWorkingCopy allManagers do: [:each | 310238 aColl 310239 do: [:location | 310240 each repositoryGroup removeHTTPRepositoryLocationNamed: location]]. 310241 ! ! 310242 310243!ScriptLoader methodsFor: 'mc related utils' stamp: 'stephane.ducasse 5/16/2008 22:11'! 310244sapphireToPharoRepository 310245 "self new sapphireToPharoRepository" 310246 self removeAllRepositories: #('http://www.squeaksource.com/Sapphire/' 'http://www.squeaksource.com/SapphireInbox/'). 310247 self addHomeRepositoryToAllPackages.! ! 310248 310249!ScriptLoader methodsFor: 'mc related utils' stamp: 'adrianLienhard 11/2/2008 00:31'! 310250saveInToReloadCachePackage: aWorkingCopy with: aMessageString 310251 self 310252 savePackage: aWorkingCopy 310253 in: self class defaultMCWaitingFolder 310254 with: aMessageString! ! 310255 310256!ScriptLoader methodsFor: 'mc related utils' stamp: 'adrianLienhard 11/1/2008 23:48'! 310257savePackage: aWorkingCopy in: aRepository with: aMessageString 310258 " | sc | 310259 sc := self new. 310260 sc savePackage: (self new workingCopyFromPackageName: 'ScriptLoader') 310261 in: MCCacheRepository default 310262 with: 'this is test to automate dirty package saving in cache'" 310263 310264 aRepository storeVersion: (aWorkingCopy 310265 newVersionWithName: aWorkingCopy uniqueVersionName 310266 message: aMessageString)! ! 310267 310268!ScriptLoader methodsFor: 'mc related utils' stamp: 'stephane.ducasse 1/13/2009 10:58'! 310269unloadPackage: aString 310270 "self new unloadPackage: 'Sixx'" 310271 | toRemove | 310272 toRemove := (MCWorkingCopy allManagers asSortedCollection: 310273 [ :a :b | a package name <= b package name ]) detect: [:each | each package name = aString]. 310274 toRemove unload.! ! 310275 310276!ScriptLoader methodsFor: 'mc related utils' stamp: 'sd 7/15/2006 20:39'! 310277unloadPackages 310278 "ScriptLoader new unloadPackages" 310279 310280 | copies namesOfpackagesToUnload | 310281 namesOfpackagesToUnload := self packagesToUnload. 310282 copies := MCWorkingCopy allManagers asSortedCollection: 310283 [ :a :b | a package name <= b package name ]. 310284 (copies select: [:each | namesOfpackagesToUnload anySatisfy: [:ea | ea match: each package name ]]) 310285 do: [:z | z unload].! ! 310286 310287!ScriptLoader methodsFor: 'mc related utils' stamp: 'al 11/1/2008 18:19'! 310288waitingFolderMCZFiles 310289 ^ self class defaultMCWaitingFolder allFileNames 310290 reject: [:each | each = '.DS_Store']! ! 310291 310292 310293 310294!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'StephaneDucasse 10/17/2009 18:05'! 310295script553 310296 310297 | names | 310298names := 'Announcements-adrian_lienhard.22.mcz 310299Balloon-MarcusDenker.33.mcz 310300Collections-Abstract-StephaneDucasse.28.mcz 310301Collections-Arrayed-MarcusDenker.21.mcz 310302Collections-Sequenceable-StephaneDucasse.37.mcz 310303Collections-SkipLists-adrian_lienhard.6.mcz 310304Collections-Stack-stephane_ducasse.3.mcz 310305Collections-Streams-StephaneDucasse.28.mcz 310306Collections-Strings-MarcusDenker.42.mcz 310307Collections-Support-StephaneDucasse.10.mcz 310308Collections-Text-StephaneDucasse.14.mcz 310309Collections-Unordered-StephaneDucasse.38.mcz 310310Collections-Weak-StephaneDucasse.13.mcz 310311CollectionsTests-MarcusDenker.393.mcz 310312Compiler-StephaneDucasse.137.mcz 310313CompilerTests-AdrianLienhard.25.mcz 310314Compression-StephaneDucasse.37.mcz 310315EToys-StephaneDucasse.114.mcz 310316Exceptions-StephaneDucasse.38.mcz 310317Files-StephaneDucasse.ducasse.84.mcz 310318FixUnderscores-stephane_ducasse.17.mcz 310319FreeType-StephaneDucasse.463.mcz 310320FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 310321FreeTypeTests-tween.1.mcz 310322Graphics-StephaneDucasse.135.mcz 310323GraphicsTests-StephaneDucasse.20.mcz 310324HostMenus-StephaneDucasse.31.mcz 310325Kernel-StephaneDucasse.432.mcz 310326KernelTests-StephaneDucasse.157.mcz 310327Monticello-StephaneDucasse.400.mcz 310328MonticelloConfigurations-stephane_ducasse.54.mcz 310329MonticelloGUI-StephaneDucasse.17.mcz 310330Morphic-StephaneDucasse.386.mcz 310331MorphicTests-StephaneDucasse.20.mcz 310332Multilingual-StephaneDucasse.85.mcz 310333MultilingualTests-marcus_denker.denker.5.mcz 310334Network-Kernel-StephaneDucasse.19.mcz 310335Network-MIME-marcus_denker.9.mcz 310336Network-MailSending-StephaneDucasse.4.mcz 310337Network-Protocols-StephaneDucasse.16.mcz 310338Network-RFC822-StephaneDucasse.4.mcz 310339Network-RemoteDirectory-StephaneDucasse.16.mcz 310340Network-URI-StephaneDucasse.8.mcz 310341Network-UUID-StephaneDucasse.6.mcz 310342Network-Url-StephaneDucasse.15.mcz 310343NetworkTests-StephaneDucasse.16.mcz 310344PackageInfo-StephaneDucasse.34.mcz 310345PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 310346Polymorph-EventEnhancements-StephaneDucasse.6.mcz 310347Polymorph-Geometry-stephane_ducasse.5.mcz 310348Polymorph-ToolBuilder-StephaneDucasse.15.mcz 310349Polymorph-Tools-Diff-StephaneDucasse.30.mcz 310350Polymorph-Widgets-StephaneDucasse.103.mcz 310351PreferenceBrowser-StephaneDucasse.45.mcz 310352ST80-StephaneDucasse.81.mcz 310353SUnit-StephaneDucasse.77.mcz 310354SUnitGUI-stephane_ducasse.41.mcz 310355Services-Base-StephaneDucasse.55.mcz 310356SplitJoin-adrian_lienhard.37.mcz 310357System-Applications-marcus_denker.8.mcz 310358System-Change Notification-marcus_denker.9.mcz 310359System-Changes-MarcusDenker.15.mcz 310360System-Clipboard-StephaneDucasse.9.mcz 310361System-Digital Signatures-StephaneDucasse.5.mcz 310362System-Download-MikeRoberts.11.mcz 310363System-FilePackage-StephaneDucasse.12.mcz 310364System-FileRegistry-stephane_ducasse.6.mcz 310365System-Finalization-adrian_lienhard.10.mcz 310366System-Hashing-StephaneDucasse.4.mcz 310367System-Localization-adrian_lienhard.18.mcz 310368System-Object Events-sd.2.mcz 310369System-Object Storage-StephaneDucasse.32.mcz 310370System-Platforms-stephane_ducasse.4.mcz 310371System-Pools-sd.2.mcz 310372System-Serial Port-StephaneDucasse.8.mcz 310373System-Support-StephaneDucasse.94.mcz 310374System-Tools-StephaneDucasse.12.mcz 310375Tests-AdrianLienhard.24.mcz 310376ToolBuilder-Kernel-adrian_lienhard.31.mcz 310377ToolBuilder-Morphic-adrian_lienhard.44.mcz 310378ToolBuilder-SUnit-adrian_lienhard.24.mcz 310379Tools-StephaneDucasse.217.mcz 310380ToolsTest-stephane_ducasse.denker.5.mcz 310381Traits-AdrianLienhard.318.mcz 310382TrueType-MarcusDenker.14.mcz 310383VB-Regex-StephaneDucasse.33.mcz' 310384findTokens: String lf , String cr. 310385 310386 self loadTogether: names merge: false.! ! 310387 310388!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'AdrianLienhard 10/18/2009 17:09'! 310389script554 310390 310391 | names | 310392names := 'Announcements-adrian_lienhard.22.mcz 310393Balloon-MarcusDenker.33.mcz 310394Collections-Abstract-StephaneDucasse.28.mcz 310395Collections-Arrayed-MarcusDenker.21.mcz 310396Collections-Sequenceable-StephaneDucasse.37.mcz 310397Collections-SkipLists-adrian_lienhard.6.mcz 310398Collections-Stack-stephane_ducasse.3.mcz 310399Collections-Streams-StephaneDucasse.28.mcz 310400Collections-Strings-MarcusDenker.42.mcz 310401Collections-Support-StephaneDucasse.10.mcz 310402Collections-Text-StephaneDucasse.14.mcz 310403Collections-Unordered-StephaneDucasse.38.mcz 310404Collections-Weak-StephaneDucasse.13.mcz 310405CollectionsTests-MarcusDenker.393.mcz 310406Compiler-AdrianLienhard.139.mcz 310407CompilerTests-AdrianLienhard.25.mcz 310408Compression-StephaneDucasse.37.mcz 310409EToys-StephaneDucasse.114.mcz 310410Exceptions-StephaneDucasse.38.mcz 310411Files-StephaneDucasse.ducasse.84.mcz 310412FixUnderscores-stephane_ducasse.17.mcz 310413FreeType-StephaneDucasse.463.mcz 310414FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 310415FreeTypeTests-tween.1.mcz 310416Graphics-StephaneDucasse.135.mcz 310417GraphicsTests-StephaneDucasse.20.mcz 310418HostMenus-StephaneDucasse.31.mcz 310419Kernel-AdrianLienhard.434.mcz 310420KernelTests-AdrianLienhard.159.mcz 310421Monticello-StephaneDucasse.400.mcz 310422MonticelloConfigurations-stephane_ducasse.54.mcz 310423MonticelloGUI-StephaneDucasse.17.mcz 310424Morphic-StephaneDucasse.386.mcz 310425MorphicTests-StephaneDucasse.20.mcz 310426Multilingual-StephaneDucasse.85.mcz 310427MultilingualTests-marcus_denker.denker.5.mcz 310428Network-Kernel-StephaneDucasse.19.mcz 310429Network-MIME-marcus_denker.9.mcz 310430Network-MailSending-StephaneDucasse.4.mcz 310431Network-Protocols-StephaneDucasse.16.mcz 310432Network-RFC822-StephaneDucasse.4.mcz 310433Network-RemoteDirectory-StephaneDucasse.16.mcz 310434Network-URI-StephaneDucasse.8.mcz 310435Network-UUID-StephaneDucasse.6.mcz 310436Network-Url-StephaneDucasse.15.mcz 310437NetworkTests-StephaneDucasse.16.mcz 310438PackageInfo-StephaneDucasse.34.mcz 310439PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 310440Polymorph-EventEnhancements-StephaneDucasse.6.mcz 310441Polymorph-Geometry-stephane_ducasse.5.mcz 310442Polymorph-ToolBuilder-StephaneDucasse.15.mcz 310443Polymorph-Tools-Diff-StephaneDucasse.30.mcz 310444Polymorph-Widgets-StephaneDucasse.103.mcz 310445PreferenceBrowser-StephaneDucasse.45.mcz 310446ST80-StephaneDucasse.81.mcz 310447SUnit-StephaneDucasse.77.mcz 310448SUnitGUI-stephane_ducasse.41.mcz 310449Services-Base-StephaneDucasse.55.mcz 310450SplitJoin-adrian_lienhard.37.mcz 310451System-Applications-marcus_denker.8.mcz 310452System-Change Notification-marcus_denker.9.mcz 310453System-Changes-MarcusDenker.15.mcz 310454System-Clipboard-StephaneDucasse.9.mcz 310455System-Digital Signatures-StephaneDucasse.5.mcz 310456System-Download-MikeRoberts.11.mcz 310457System-FilePackage-StephaneDucasse.12.mcz 310458System-FileRegistry-stephane_ducasse.6.mcz 310459System-Finalization-adrian_lienhard.10.mcz 310460System-Hashing-StephaneDucasse.4.mcz 310461System-Localization-adrian_lienhard.18.mcz 310462System-Object Events-sd.2.mcz 310463System-Object Storage-StephaneDucasse.32.mcz 310464System-Platforms-stephane_ducasse.4.mcz 310465System-Pools-sd.2.mcz 310466System-Serial Port-StephaneDucasse.8.mcz 310467System-Support-AdrianLienhard.97.mcz 310468System-Tools-StephaneDucasse.12.mcz 310469Tests-AdrianLienhard.30.mcz 310470ToolBuilder-Kernel-adrian_lienhard.31.mcz 310471ToolBuilder-Morphic-adrian_lienhard.44.mcz 310472ToolBuilder-SUnit-adrian_lienhard.24.mcz 310473Tools-AdrianLienhard.219.mcz 310474ToolsTest-stephane_ducasse.denker.5.mcz 310475Traits-AdrianLienhard.321.mcz 310476TrueType-MarcusDenker.14.mcz 310477VB-Regex-StephaneDucasse.33.mcz' 310478findTokens: String lf , String cr. 310479 310480 self loadTogether: names merge: false.! ! 310481 310482!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'StephaneDucasse 10/18/2009 18:08'! 310483script555 310484 310485 | names | 310486names := 'Announcements-adrian_lienhard.22.mcz 310487Balloon-MarcusDenker.33.mcz 310488Collections-Abstract-StephaneDucasse.28.mcz 310489Collections-Arrayed-MarcusDenker.21.mcz 310490Collections-Sequenceable-StephaneDucasse.37.mcz 310491Collections-SkipLists-adrian_lienhard.6.mcz 310492Collections-Stack-stephane_ducasse.3.mcz 310493Collections-Streams-StephaneDucasse.28.mcz 310494Collections-Strings-MarcusDenker.42.mcz 310495Collections-Support-StephaneDucasse.10.mcz 310496Collections-Text-StephaneDucasse.14.mcz 310497Collections-Unordered-StephaneDucasse.38.mcz 310498Collections-Weak-StephaneDucasse.13.mcz 310499CollectionsTests-MarcusDenker.393.mcz 310500Compiler-AdrianLienhard.139.mcz 310501CompilerTests-AdrianLienhard.25.mcz 310502Compression-StephaneDucasse.37.mcz 310503EToys-StephaneDucasse.114.mcz 310504Exceptions-StephaneDucasse.38.mcz 310505Files-StephaneDucasse.ducasse.84.mcz 310506FixUnderscores-stephane_ducasse.17.mcz 310507FreeType-StephaneDucasse.463.mcz 310508FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 310509FreeTypeTests-tween.1.mcz 310510Graphics-StephaneDucasse.135.mcz 310511GraphicsTests-StephaneDucasse.20.mcz 310512HostMenus-StephaneDucasse.31.mcz 310513Kernel-AdrianLienhard.434.mcz 310514KernelTests-AdrianLienhard.159.mcz 310515Monticello-StephaneDucasse.400.mcz 310516MonticelloConfigurations-stephane_ducasse.54.mcz 310517MonticelloGUI-StephaneDucasse.17.mcz 310518Morphic-StephaneDucasse.386.mcz 310519MorphicTests-StephaneDucasse.20.mcz 310520Multilingual-StephaneDucasse.85.mcz 310521MultilingualTests-marcus_denker.denker.5.mcz 310522Network-Kernel-StephaneDucasse.19.mcz 310523Network-MIME-marcus_denker.9.mcz 310524Network-MailSending-StephaneDucasse.4.mcz 310525Network-Protocols-StephaneDucasse.16.mcz 310526Network-RFC822-StephaneDucasse.4.mcz 310527Network-RemoteDirectory-StephaneDucasse.16.mcz 310528Network-URI-StephaneDucasse.8.mcz 310529Network-UUID-StephaneDucasse.6.mcz 310530Network-Url-StephaneDucasse.15.mcz 310531NetworkTests-StephaneDucasse.16.mcz 310532PackageInfo-StephaneDucasse.34.mcz 310533PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 310534Polymorph-EventEnhancements-StephaneDucasse.6.mcz 310535Polymorph-Geometry-stephane_ducasse.5.mcz 310536Polymorph-ToolBuilder-StephaneDucasse.15.mcz 310537Polymorph-Tools-Diff-StephaneDucasse.30.mcz 310538Polymorph-Widgets-StephaneDucasse.103.mcz 310539PreferenceBrowser-StephaneDucasse.45.mcz 310540ST80-StephaneDucasse.81.mcz 310541SUnit-StephaneDucasse.77.mcz 310542SUnitGUI-stephane_ducasse.41.mcz 310543Services-Base-StephaneDucasse.55.mcz 310544SplitJoin-adrian_lienhard.37.mcz 310545System-Applications-marcus_denker.8.mcz 310546System-Change Notification-marcus_denker.9.mcz 310547System-Changes-MarcusDenker.15.mcz 310548System-Clipboard-StephaneDucasse.9.mcz 310549System-Digital Signatures-StephaneDucasse.5.mcz 310550System-Download-MikeRoberts.11.mcz 310551System-FilePackage-StephaneDucasse.12.mcz 310552System-FileRegistry-stephane_ducasse.6.mcz 310553System-Finalization-adrian_lienhard.10.mcz 310554System-Hashing-StephaneDucasse.4.mcz 310555System-Localization-adrian_lienhard.18.mcz 310556System-Object Events-sd.2.mcz 310557System-Object Storage-StephaneDucasse.32.mcz 310558System-Platforms-stephane_ducasse.4.mcz 310559System-Pools-sd.2.mcz 310560System-Serial Port-StephaneDucasse.8.mcz 310561System-Support-StephaneDucasse.99.mcz 310562System-Tools-StephaneDucasse.12.mcz 310563Tests-AdrianLienhard.30.mcz 310564ToolBuilder-Kernel-adrian_lienhard.31.mcz 310565ToolBuilder-Morphic-adrian_lienhard.44.mcz 310566ToolBuilder-SUnit-adrian_lienhard.24.mcz 310567Tools-AdrianLienhard.219.mcz 310568ToolsTest-stephane_ducasse.denker.5.mcz 310569Traits-AdrianLienhard.321.mcz 310570TrueType-MarcusDenker.14.mcz 310571VB-Regex-StephaneDucasse.33.mcz' 310572findTokens: String lf , String cr. 310573 310574 self loadTogether: names merge: false.! ! 310575 310576!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'StephaneDucasse 10/18/2009 18:14'! 310577script556 310578 310579 | names | 310580names := 'Announcements-adrian_lienhard.22.mcz 310581Balloon-MarcusDenker.33.mcz 310582Collections-Abstract-StephaneDucasse.28.mcz 310583Collections-Arrayed-MarcusDenker.21.mcz 310584Collections-Sequenceable-StephaneDucasse.37.mcz 310585Collections-SkipLists-adrian_lienhard.6.mcz 310586Collections-Stack-stephane_ducasse.3.mcz 310587Collections-Streams-StephaneDucasse.28.mcz 310588Collections-Strings-MarcusDenker.42.mcz 310589Collections-Support-StephaneDucasse.10.mcz 310590Collections-Text-StephaneDucasse.14.mcz 310591Collections-Unordered-StephaneDucasse.38.mcz 310592Collections-Weak-StephaneDucasse.13.mcz 310593CollectionsTests-MarcusDenker.393.mcz 310594Compiler-AdrianLienhard.139.mcz 310595CompilerTests-AdrianLienhard.25.mcz 310596Compression-StephaneDucasse.37.mcz 310597EToys-StephaneDucasse.114.mcz 310598Exceptions-StephaneDucasse.38.mcz 310599Files-StephaneDucasse.ducasse.84.mcz 310600FixUnderscores-stephane_ducasse.17.mcz 310601FreeType-StephaneDucasse.463.mcz 310602FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 310603FreeTypeTests-tween.1.mcz 310604Graphics-StephaneDucasse.135.mcz 310605GraphicsTests-StephaneDucasse.20.mcz 310606HostMenus-StephaneDucasse.31.mcz 310607Kernel-AdrianLienhard.434.mcz 310608KernelTests-AdrianLienhard.159.mcz 310609Monticello-StephaneDucasse.400.mcz 310610MonticelloConfigurations-stephane_ducasse.54.mcz 310611MonticelloGUI-StephaneDucasse.17.mcz 310612Morphic-StephaneDucasse.386.mcz 310613MorphicTests-StephaneDucasse.20.mcz 310614Multilingual-StephaneDucasse.85.mcz 310615MultilingualTests-marcus_denker.denker.5.mcz 310616Network-Kernel-StephaneDucasse.19.mcz 310617Network-MIME-marcus_denker.9.mcz 310618Network-MailSending-StephaneDucasse.4.mcz 310619Network-Protocols-StephaneDucasse.16.mcz 310620Network-RFC822-StephaneDucasse.4.mcz 310621Network-RemoteDirectory-StephaneDucasse.16.mcz 310622Network-URI-StephaneDucasse.8.mcz 310623Network-UUID-StephaneDucasse.6.mcz 310624Network-Url-StephaneDucasse.15.mcz 310625NetworkTests-StephaneDucasse.16.mcz 310626PackageInfo-StephaneDucasse.34.mcz 310627PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 310628Polymorph-EventEnhancements-StephaneDucasse.6.mcz 310629Polymorph-Geometry-stephane_ducasse.5.mcz 310630Polymorph-ToolBuilder-StephaneDucasse.15.mcz 310631Polymorph-Tools-Diff-StephaneDucasse.30.mcz 310632Polymorph-Widgets-StephaneDucasse.103.mcz 310633PreferenceBrowser-StephaneDucasse.45.mcz 310634ST80-StephaneDucasse.81.mcz 310635SUnit-StephaneDucasse.77.mcz 310636SUnitGUI-stephane_ducasse.41.mcz 310637Services-Base-StephaneDucasse.55.mcz 310638SplitJoin-adrian_lienhard.37.mcz 310639System-Applications-marcus_denker.8.mcz 310640System-Change Notification-marcus_denker.9.mcz 310641System-Changes-MarcusDenker.15.mcz 310642System-Clipboard-StephaneDucasse.9.mcz 310643System-Digital Signatures-StephaneDucasse.5.mcz 310644System-Download-MikeRoberts.11.mcz 310645System-FilePackage-StephaneDucasse.12.mcz 310646System-FileRegistry-stephane_ducasse.6.mcz 310647System-Finalization-adrian_lienhard.10.mcz 310648System-Hashing-StephaneDucasse.4.mcz 310649System-Localization-adrian_lienhard.18.mcz 310650System-Object Events-sd.2.mcz 310651System-Object Storage-StephaneDucasse.32.mcz 310652System-Platforms-stephane_ducasse.4.mcz 310653System-Pools-sd.2.mcz 310654System-Serial Port-StephaneDucasse.8.mcz 310655System-Support-StephaneDucasse.99.mcz 310656System-Tools-StephaneDucasse.12.mcz 310657Tests-AdrianLienhard.30.mcz 310658ToolBuilder-Kernel-adrian_lienhard.31.mcz 310659ToolBuilder-Morphic-adrian_lienhard.44.mcz 310660ToolBuilder-SUnit-adrian_lienhard.24.mcz 310661Tools-StephaneDucasse.220.mcz 310662ToolsTest-stephane_ducasse.denker.5.mcz 310663Traits-AdrianLienhard.321.mcz 310664TrueType-MarcusDenker.14.mcz 310665VB-Regex-StephaneDucasse.33.mcz' 310666findTokens: String lf , String cr. 310667 310668 self loadTogether: names merge: false.! ! 310669 310670!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'StephaneDucasse 10/18/2009 18:49'! 310671script557 310672 310673 | names | 310674names := 'Announcements-adrian_lienhard.22.mcz 310675Balloon-MarcusDenker.33.mcz 310676Collections-Abstract-StephaneDucasse.28.mcz 310677Collections-Arrayed-MarcusDenker.21.mcz 310678Collections-Sequenceable-StephaneDucasse.37.mcz 310679Collections-SkipLists-adrian_lienhard.6.mcz 310680Collections-Stack-stephane_ducasse.3.mcz 310681Collections-Streams-StephaneDucasse.28.mcz 310682Collections-Strings-MarcusDenker.42.mcz 310683Collections-Support-StephaneDucasse.10.mcz 310684Collections-Text-StephaneDucasse.14.mcz 310685Collections-Unordered-StephaneDucasse.38.mcz 310686Collections-Weak-StephaneDucasse.13.mcz 310687CollectionsTests-MarcusDenker.393.mcz 310688Compiler-AdrianLienhard.139.mcz 310689CompilerTests-AdrianLienhard.25.mcz 310690Compression-StephaneDucasse.37.mcz 310691EToys-StephaneDucasse.114.mcz 310692Exceptions-StephaneDucasse.38.mcz 310693Files-StephaneDucasse.ducasse.84.mcz 310694FixUnderscores-stephane_ducasse.17.mcz 310695FreeType-StephaneDucasse.463.mcz 310696FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 310697FreeTypeTests-tween.1.mcz 310698Graphics-StephaneDucasse.135.mcz 310699GraphicsTests-StephaneDucasse.20.mcz 310700HostMenus-StephaneDucasse.31.mcz 310701Kernel-AdrianLienhard.434.mcz 310702KernelTests-AdrianLienhard.159.mcz 310703Monticello-StephaneDucasse.400.mcz 310704MonticelloConfigurations-stephane_ducasse.54.mcz 310705MonticelloGUI-StephaneDucasse.17.mcz 310706Morphic-StephaneDucasse.386.mcz 310707MorphicTests-StephaneDucasse.20.mcz 310708Multilingual-StephaneDucasse.85.mcz 310709MultilingualTests-marcus_denker.denker.5.mcz 310710Network-Kernel-StephaneDucasse.19.mcz 310711Network-MIME-marcus_denker.9.mcz 310712Network-MailSending-StephaneDucasse.4.mcz 310713Network-Protocols-StephaneDucasse.16.mcz 310714Network-RFC822-StephaneDucasse.4.mcz 310715Network-RemoteDirectory-StephaneDucasse.16.mcz 310716Network-URI-StephaneDucasse.8.mcz 310717Network-UUID-StephaneDucasse.6.mcz 310718Network-Url-StephaneDucasse.15.mcz 310719NetworkTests-StephaneDucasse.16.mcz 310720PackageInfo-StephaneDucasse.34.mcz 310721PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 310722Polymorph-EventEnhancements-StephaneDucasse.6.mcz 310723Polymorph-Geometry-stephane_ducasse.5.mcz 310724Polymorph-ToolBuilder-StephaneDucasse.15.mcz 310725Polymorph-Tools-Diff-StephaneDucasse.30.mcz 310726Polymorph-Widgets-StephaneDucasse.103.mcz 310727PreferenceBrowser-StephaneDucasse.45.mcz 310728ST80-StephaneDucasse.81.mcz 310729SUnit-StephaneDucasse.77.mcz 310730SUnitGUI-stephane_ducasse.41.mcz 310731Services-Base-StephaneDucasse.55.mcz 310732SplitJoin-adrian_lienhard.37.mcz 310733System-Applications-marcus_denker.8.mcz 310734System-Change Notification-marcus_denker.9.mcz 310735System-Changes-MarcusDenker.15.mcz 310736System-Clipboard-StephaneDucasse.9.mcz 310737System-Digital Signatures-StephaneDucasse.5.mcz 310738System-Download-MikeRoberts.11.mcz 310739System-FilePackage-StephaneDucasse.12.mcz 310740System-FileRegistry-stephane_ducasse.6.mcz 310741System-Finalization-adrian_lienhard.10.mcz 310742System-Hashing-StephaneDucasse.4.mcz 310743System-Localization-adrian_lienhard.18.mcz 310744System-Object Events-sd.2.mcz 310745System-Object Storage-StephaneDucasse.32.mcz 310746System-Platforms-stephane_ducasse.4.mcz 310747System-Pools-sd.2.mcz 310748System-Serial Port-StephaneDucasse.8.mcz 310749System-Support-StephaneDucasse.102.mcz 310750System-Tools-StephaneDucasse.12.mcz 310751Tests-AdrianLienhard.30.mcz 310752ToolBuilder-Kernel-adrian_lienhard.31.mcz 310753ToolBuilder-Morphic-adrian_lienhard.44.mcz 310754ToolBuilder-SUnit-adrian_lienhard.24.mcz 310755Tools-AdrianLienhard.219.mcz 310756ToolsTest-stephane_ducasse.denker.5.mcz 310757Traits-AdrianLienhard.321.mcz 310758TrueType-MarcusDenker.14.mcz 310759VB-Regex-StephaneDucasse.33.mcz' 310760findTokens: String lf , String cr. 310761 310762 self loadTogether: names merge: false.! ! 310763 310764!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'StephaneDucasse 10/18/2009 18:52'! 310765script558 310766 310767 | names | 310768names := 'Announcements-adrian_lienhard.22.mcz 310769Balloon-MarcusDenker.33.mcz 310770Collections-Abstract-StephaneDucasse.28.mcz 310771Collections-Arrayed-MarcusDenker.21.mcz 310772Collections-Sequenceable-StephaneDucasse.37.mcz 310773Collections-SkipLists-adrian_lienhard.6.mcz 310774Collections-Stack-stephane_ducasse.3.mcz 310775Collections-Streams-StephaneDucasse.28.mcz 310776Collections-Strings-MarcusDenker.42.mcz 310777Collections-Support-StephaneDucasse.10.mcz 310778Collections-Text-StephaneDucasse.14.mcz 310779Collections-Unordered-StephaneDucasse.38.mcz 310780Collections-Weak-StephaneDucasse.13.mcz 310781CollectionsTests-MarcusDenker.393.mcz 310782Compiler-AdrianLienhard.139.mcz 310783CompilerTests-AdrianLienhard.25.mcz 310784Compression-StephaneDucasse.37.mcz 310785EToys-StephaneDucasse.114.mcz 310786Exceptions-StephaneDucasse.38.mcz 310787Files-StephaneDucasse.ducasse.84.mcz 310788FixUnderscores-stephane_ducasse.17.mcz 310789FreeType-StephaneDucasse.463.mcz 310790FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 310791FreeTypeTests-tween.1.mcz 310792Graphics-StephaneDucasse.135.mcz 310793GraphicsTests-StephaneDucasse.20.mcz 310794HostMenus-StephaneDucasse.31.mcz 310795Kernel-AdrianLienhard.434.mcz 310796KernelTests-AdrianLienhard.159.mcz 310797Monticello-StephaneDucasse.400.mcz 310798MonticelloConfigurations-stephane_ducasse.54.mcz 310799MonticelloGUI-StephaneDucasse.17.mcz 310800Morphic-StephaneDucasse.386.mcz 310801MorphicTests-StephaneDucasse.20.mcz 310802Multilingual-StephaneDucasse.85.mcz 310803MultilingualTests-marcus_denker.denker.5.mcz 310804Network-Kernel-StephaneDucasse.19.mcz 310805Network-MIME-marcus_denker.9.mcz 310806Network-MailSending-StephaneDucasse.4.mcz 310807Network-Protocols-StephaneDucasse.16.mcz 310808Network-RFC822-StephaneDucasse.4.mcz 310809Network-RemoteDirectory-StephaneDucasse.16.mcz 310810Network-URI-StephaneDucasse.8.mcz 310811Network-UUID-StephaneDucasse.6.mcz 310812Network-Url-StephaneDucasse.15.mcz 310813NetworkTests-StephaneDucasse.16.mcz 310814PackageInfo-StephaneDucasse.34.mcz 310815PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 310816Polymorph-EventEnhancements-StephaneDucasse.6.mcz 310817Polymorph-Geometry-stephane_ducasse.5.mcz 310818Polymorph-ToolBuilder-StephaneDucasse.15.mcz 310819Polymorph-Tools-Diff-StephaneDucasse.30.mcz 310820Polymorph-Widgets-StephaneDucasse.103.mcz 310821PreferenceBrowser-StephaneDucasse.45.mcz 310822ST80-StephaneDucasse.81.mcz 310823SUnit-StephaneDucasse.77.mcz 310824SUnitGUI-stephane_ducasse.41.mcz 310825Services-Base-StephaneDucasse.55.mcz 310826SplitJoin-adrian_lienhard.37.mcz 310827System-Applications-marcus_denker.8.mcz 310828System-Change Notification-marcus_denker.9.mcz 310829System-Changes-MarcusDenker.15.mcz 310830System-Clipboard-StephaneDucasse.9.mcz 310831System-Digital Signatures-StephaneDucasse.5.mcz 310832System-Download-MikeRoberts.11.mcz 310833System-FilePackage-StephaneDucasse.12.mcz 310834System-FileRegistry-stephane_ducasse.6.mcz 310835System-Finalization-adrian_lienhard.10.mcz 310836System-Hashing-StephaneDucasse.4.mcz 310837System-Localization-adrian_lienhard.18.mcz 310838System-Object Events-sd.2.mcz 310839System-Object Storage-StephaneDucasse.32.mcz 310840System-Platforms-stephane_ducasse.4.mcz 310841System-Pools-sd.2.mcz 310842System-Serial Port-StephaneDucasse.8.mcz 310843System-Support-StephaneDucasse.102.mcz 310844System-Tools-StephaneDucasse.12.mcz 310845Tests-AdrianLienhard.30.mcz 310846ToolBuilder-Kernel-adrian_lienhard.31.mcz 310847ToolBuilder-Morphic-adrian_lienhard.44.mcz 310848ToolBuilder-SUnit-adrian_lienhard.24.mcz 310849Tools-StephaneDucasse.221.mcz 310850ToolsTest-stephane_ducasse.denker.5.mcz 310851Traits-AdrianLienhard.321.mcz 310852TrueType-MarcusDenker.14.mcz 310853VB-Regex-StephaneDucasse.33.mcz' 310854findTokens: String lf , String cr. 310855 310856 self loadTogether: names merge: false.! ! 310857 310858!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'AdrianLienhard 10/18/2009 19:08'! 310859script559 310860 310861 | names | 310862names := 'Announcements-adrian_lienhard.22.mcz 310863Balloon-MarcusDenker.33.mcz 310864Collections-Abstract-StephaneDucasse.28.mcz 310865Collections-Arrayed-MarcusDenker.21.mcz 310866Collections-Sequenceable-StephaneDucasse.37.mcz 310867Collections-SkipLists-adrian_lienhard.6.mcz 310868Collections-Stack-stephane_ducasse.3.mcz 310869Collections-Streams-StephaneDucasse.28.mcz 310870Collections-Strings-MarcusDenker.42.mcz 310871Collections-Support-StephaneDucasse.10.mcz 310872Collections-Text-StephaneDucasse.14.mcz 310873Collections-Unordered-StephaneDucasse.38.mcz 310874Collections-Weak-StephaneDucasse.13.mcz 310875CollectionsTests-MarcusDenker.393.mcz 310876Compiler-AdrianLienhard.139.mcz 310877CompilerTests-AdrianLienhard.25.mcz 310878Compression-StephaneDucasse.37.mcz 310879EToys-StephaneDucasse.114.mcz 310880Exceptions-StephaneDucasse.38.mcz 310881Files-StephaneDucasse.ducasse.84.mcz 310882FixUnderscores-stephane_ducasse.17.mcz 310883FreeType-StephaneDucasse.463.mcz 310884FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 310885FreeTypeTests-tween.1.mcz 310886Graphics-StephaneDucasse.135.mcz 310887GraphicsTests-StephaneDucasse.20.mcz 310888HostMenus-StephaneDucasse.31.mcz 310889Kernel-AdrianLienhard.434.mcz 310890KernelTests-AdrianLienhard.160.mcz 310891Monticello-StephaneDucasse.400.mcz 310892MonticelloConfigurations-stephane_ducasse.54.mcz 310893MonticelloGUI-StephaneDucasse.17.mcz 310894Morphic-StephaneDucasse.386.mcz 310895MorphicTests-StephaneDucasse.20.mcz 310896Multilingual-StephaneDucasse.85.mcz 310897MultilingualTests-marcus_denker.denker.5.mcz 310898Network-Kernel-StephaneDucasse.19.mcz 310899Network-MIME-marcus_denker.9.mcz 310900Network-MailSending-StephaneDucasse.4.mcz 310901Network-Protocols-StephaneDucasse.16.mcz 310902Network-RFC822-StephaneDucasse.4.mcz 310903Network-RemoteDirectory-StephaneDucasse.16.mcz 310904Network-URI-StephaneDucasse.8.mcz 310905Network-UUID-StephaneDucasse.6.mcz 310906Network-Url-StephaneDucasse.15.mcz 310907NetworkTests-StephaneDucasse.16.mcz 310908PackageInfo-StephaneDucasse.34.mcz 310909PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 310910Polymorph-EventEnhancements-StephaneDucasse.6.mcz 310911Polymorph-Geometry-stephane_ducasse.5.mcz 310912Polymorph-ToolBuilder-StephaneDucasse.15.mcz 310913Polymorph-Tools-Diff-StephaneDucasse.30.mcz 310914Polymorph-Widgets-StephaneDucasse.103.mcz 310915PreferenceBrowser-StephaneDucasse.45.mcz 310916ST80-StephaneDucasse.81.mcz 310917SUnit-AdrianLienhard.79.mcz 310918SUnitGUI-stephane_ducasse.41.mcz 310919Services-Base-StephaneDucasse.55.mcz 310920SplitJoin-adrian_lienhard.37.mcz 310921System-Applications-marcus_denker.8.mcz 310922System-Change Notification-marcus_denker.9.mcz 310923System-Changes-MarcusDenker.15.mcz 310924System-Clipboard-StephaneDucasse.9.mcz 310925System-Digital Signatures-StephaneDucasse.5.mcz 310926System-Download-MikeRoberts.11.mcz 310927System-FilePackage-StephaneDucasse.12.mcz 310928System-FileRegistry-stephane_ducasse.6.mcz 310929System-Finalization-adrian_lienhard.10.mcz 310930System-Hashing-StephaneDucasse.4.mcz 310931System-Localization-adrian_lienhard.18.mcz 310932System-Object Events-sd.2.mcz 310933System-Object Storage-StephaneDucasse.32.mcz 310934System-Platforms-stephane_ducasse.4.mcz 310935System-Pools-sd.2.mcz 310936System-Serial Port-StephaneDucasse.8.mcz 310937System-Support-AdrianLienhard.103.mcz 310938System-Tools-StephaneDucasse.12.mcz 310939Tests-AdrianLienhard.31.mcz 310940ToolBuilder-Kernel-adrian_lienhard.31.mcz 310941ToolBuilder-Morphic-adrian_lienhard.44.mcz 310942ToolBuilder-SUnit-adrian_lienhard.24.mcz 310943Tools-StephaneDucasse.221.mcz 310944ToolsTest-stephane_ducasse.denker.5.mcz 310945Traits-AdrianLienhard.321.mcz 310946TrueType-MarcusDenker.14.mcz 310947VB-Regex-StephaneDucasse.33.mcz' 310948findTokens: String lf , String cr. 310949 310950 self loadTogether: names merge: false.! ! 310951 310952!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'AdrianLienhard 10/19/2009 09:51'! 310953script560 310954 310955 | names | 310956names := 'Announcements-adrian_lienhard.22.mcz 310957Balloon-MarcusDenker.33.mcz 310958Collections-Abstract-StephaneDucasse.28.mcz 310959Collections-Arrayed-MarcusDenker.21.mcz 310960Collections-Sequenceable-StephaneDucasse.37.mcz 310961Collections-SkipLists-adrian_lienhard.6.mcz 310962Collections-Stack-stephane_ducasse.3.mcz 310963Collections-Streams-StephaneDucasse.28.mcz 310964Collections-Strings-MarcusDenker.42.mcz 310965Collections-Support-StephaneDucasse.10.mcz 310966Collections-Text-StephaneDucasse.14.mcz 310967Collections-Unordered-StephaneDucasse.38.mcz 310968Collections-Weak-StephaneDucasse.13.mcz 310969CollectionsTests-MarcusDenker.393.mcz 310970Compiler-AdrianLienhard.139.mcz 310971CompilerTests-AdrianLienhard.25.mcz 310972Compression-StephaneDucasse.37.mcz 310973EToys-StephaneDucasse.114.mcz 310974Exceptions-StephaneDucasse.38.mcz 310975Files-StephaneDucasse.ducasse.84.mcz 310976FixUnderscores-stephane_ducasse.17.mcz 310977FreeType-StephaneDucasse.463.mcz 310978FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 310979FreeTypeTests-tween.1.mcz 310980Graphics-StephaneDucasse.135.mcz 310981GraphicsTests-StephaneDucasse.20.mcz 310982HostMenus-StephaneDucasse.31.mcz 310983Kernel-AdrianLienhard.435.mcz 310984KernelTests-AdrianLienhard.161.mcz 310985Monticello-StephaneDucasse.400.mcz 310986MonticelloConfigurations-stephane_ducasse.54.mcz 310987MonticelloGUI-AdrianLienhard.18.mcz 310988Morphic-StephaneDucasse.386.mcz 310989MorphicTests-StephaneDucasse.20.mcz 310990Multilingual-StephaneDucasse.85.mcz 310991MultilingualTests-marcus_denker.denker.5.mcz 310992Network-Kernel-StephaneDucasse.19.mcz 310993Network-MIME-marcus_denker.9.mcz 310994Network-MailSending-StephaneDucasse.4.mcz 310995Network-Protocols-StephaneDucasse.16.mcz 310996Network-RFC822-StephaneDucasse.4.mcz 310997Network-RemoteDirectory-StephaneDucasse.16.mcz 310998Network-URI-StephaneDucasse.8.mcz 310999Network-UUID-StephaneDucasse.6.mcz 311000Network-Url-StephaneDucasse.15.mcz 311001NetworkTests-StephaneDucasse.16.mcz 311002PackageInfo-StephaneDucasse.34.mcz 311003PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 311004Polymorph-EventEnhancements-StephaneDucasse.6.mcz 311005Polymorph-Geometry-stephane_ducasse.5.mcz 311006Polymorph-ToolBuilder-StephaneDucasse.15.mcz 311007Polymorph-Tools-Diff-StephaneDucasse.30.mcz 311008Polymorph-Widgets-StephaneDucasse.103.mcz 311009PreferenceBrowser-StephaneDucasse.45.mcz 311010ST80-StephaneDucasse.81.mcz 311011SUnit-AdrianLienhard.79.mcz 311012SUnitGUI-AdrianLienhard.42.mcz 311013Services-Base-StephaneDucasse.55.mcz 311014SplitJoin-adrian_lienhard.37.mcz 311015System-Applications-marcus_denker.8.mcz 311016System-Change Notification-marcus_denker.9.mcz 311017System-Changes-MarcusDenker.15.mcz 311018System-Clipboard-StephaneDucasse.9.mcz 311019System-Digital Signatures-StephaneDucasse.5.mcz 311020System-Download-MikeRoberts.11.mcz 311021System-FilePackage-StephaneDucasse.12.mcz 311022System-FileRegistry-stephane_ducasse.6.mcz 311023System-Finalization-adrian_lienhard.10.mcz 311024System-Hashing-StephaneDucasse.4.mcz 311025System-Localization-adrian_lienhard.18.mcz 311026System-Object Events-sd.2.mcz 311027System-Object Storage-StephaneDucasse.32.mcz 311028System-Platforms-stephane_ducasse.4.mcz 311029System-Pools-sd.2.mcz 311030System-Serial Port-StephaneDucasse.8.mcz 311031System-Support-AdrianLienhard.103.mcz 311032System-Tools-StephaneDucasse.12.mcz 311033Tests-AdrianLienhard.32.mcz 311034ToolBuilder-Kernel-adrian_lienhard.31.mcz 311035ToolBuilder-Morphic-adrian_lienhard.44.mcz 311036ToolBuilder-SUnit-adrian_lienhard.24.mcz 311037Tools-StephaneDucasse.221.mcz 311038ToolsTest-stephane_ducasse.denker.5.mcz 311039Traits-AdrianLienhard.321.mcz 311040TrueType-MarcusDenker.14.mcz 311041VB-Regex-StephaneDucasse.33.mcz' 311042findTokens: String lf , String cr. 311043 311044 self loadTogether: names merge: false.! ! 311045 311046!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'AdrianLienhard 10/19/2009 10:55'! 311047script561 311048 311049 | names | 311050names := 'Announcements-adrian_lienhard.22.mcz 311051Balloon-MarcusDenker.33.mcz 311052Collections-Abstract-StephaneDucasse.28.mcz 311053Collections-Arrayed-MarcusDenker.21.mcz 311054Collections-Sequenceable-StephaneDucasse.37.mcz 311055Collections-SkipLists-adrian_lienhard.6.mcz 311056Collections-Stack-stephane_ducasse.3.mcz 311057Collections-Streams-StephaneDucasse.28.mcz 311058Collections-Strings-MarcusDenker.42.mcz 311059Collections-Support-StephaneDucasse.10.mcz 311060Collections-Text-StephaneDucasse.14.mcz 311061Collections-Unordered-StephaneDucasse.38.mcz 311062Collections-Weak-StephaneDucasse.13.mcz 311063CollectionsTests-MarcusDenker.393.mcz 311064Compiler-AdrianLienhard.139.mcz 311065CompilerTests-AdrianLienhard.25.mcz 311066Compression-StephaneDucasse.37.mcz 311067EToys-StephaneDucasse.114.mcz 311068Exceptions-StephaneDucasse.38.mcz 311069Files-StephaneDucasse.ducasse.84.mcz 311070FixUnderscores-stephane_ducasse.17.mcz 311071FreeType-StephaneDucasse.463.mcz 311072FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 311073FreeTypeTests-tween.1.mcz 311074Graphics-StephaneDucasse.135.mcz 311075GraphicsTests-StephaneDucasse.20.mcz 311076HostMenus-StephaneDucasse.31.mcz 311077Kernel-AdrianLienhard.435.mcz 311078KernelTests-AdrianLienhard.161.mcz 311079Monticello-StephaneDucasse.400.mcz 311080MonticelloConfigurations-stephane_ducasse.54.mcz 311081MonticelloGUI-AdrianLienhard.18.mcz 311082Morphic-StephaneDucasse.386.mcz 311083MorphicTests-StephaneDucasse.20.mcz 311084Multilingual-StephaneDucasse.85.mcz 311085MultilingualTests-marcus_denker.denker.5.mcz 311086Network-Kernel-StephaneDucasse.19.mcz 311087Network-MIME-marcus_denker.9.mcz 311088Network-MailSending-StephaneDucasse.4.mcz 311089Network-Protocols-StephaneDucasse.16.mcz 311090Network-RFC822-StephaneDucasse.4.mcz 311091Network-RemoteDirectory-StephaneDucasse.16.mcz 311092Network-URI-StephaneDucasse.8.mcz 311093Network-UUID-StephaneDucasse.6.mcz 311094Network-Url-StephaneDucasse.15.mcz 311095NetworkTests-StephaneDucasse.16.mcz 311096PackageInfo-StephaneDucasse.34.mcz 311097PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 311098Polymorph-EventEnhancements-StephaneDucasse.6.mcz 311099Polymorph-Geometry-stephane_ducasse.5.mcz 311100Polymorph-ToolBuilder-StephaneDucasse.15.mcz 311101Polymorph-Tools-Diff-StephaneDucasse.30.mcz 311102Polymorph-Widgets-StephaneDucasse.103.mcz 311103PreferenceBrowser-StephaneDucasse.45.mcz 311104ST80-StephaneDucasse.81.mcz 311105SUnit-AdrianLienhard.80.mcz 311106SUnitGUI-AdrianLienhard.42.mcz 311107Services-Base-StephaneDucasse.55.mcz 311108SplitJoin-adrian_lienhard.37.mcz 311109System-Applications-marcus_denker.8.mcz 311110System-Change Notification-marcus_denker.9.mcz 311111System-Changes-MarcusDenker.15.mcz 311112System-Clipboard-StephaneDucasse.9.mcz 311113System-Digital Signatures-StephaneDucasse.5.mcz 311114System-Download-MikeRoberts.11.mcz 311115System-FilePackage-StephaneDucasse.12.mcz 311116System-FileRegistry-stephane_ducasse.6.mcz 311117System-Finalization-adrian_lienhard.10.mcz 311118System-Hashing-StephaneDucasse.4.mcz 311119System-Localization-adrian_lienhard.18.mcz 311120System-Object Events-sd.2.mcz 311121System-Object Storage-StephaneDucasse.32.mcz 311122System-Platforms-stephane_ducasse.4.mcz 311123System-Pools-sd.2.mcz 311124System-Serial Port-StephaneDucasse.8.mcz 311125System-Support-AdrianLienhard.103.mcz 311126System-Tools-StephaneDucasse.12.mcz 311127Tests-AdrianLienhard.32.mcz 311128ToolBuilder-Kernel-adrian_lienhard.31.mcz 311129ToolBuilder-Morphic-adrian_lienhard.44.mcz 311130ToolBuilder-SUnit-adrian_lienhard.24.mcz 311131Tools-StephaneDucasse.221.mcz 311132ToolsTest-stephane_ducasse.denker.5.mcz 311133Traits-AdrianLienhard.321.mcz 311134TrueType-MarcusDenker.14.mcz 311135VB-Regex-StephaneDucasse.33.mcz' 311136findTokens: String lf , String cr. 311137 311138 self loadTogether: names merge: false.! ! 311139 311140!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'AdrianLienhard 10/19/2009 12:09'! 311141script562 311142 311143 | names | 311144names := 'Announcements-adrian_lienhard.22.mcz 311145Balloon-MarcusDenker.33.mcz 311146Collections-Abstract-StephaneDucasse.28.mcz 311147Collections-Arrayed-MarcusDenker.21.mcz 311148Collections-Sequenceable-StephaneDucasse.37.mcz 311149Collections-SkipLists-adrian_lienhard.6.mcz 311150Collections-Stack-stephane_ducasse.3.mcz 311151Collections-Streams-StephaneDucasse.28.mcz 311152Collections-Strings-MarcusDenker.42.mcz 311153Collections-Support-StephaneDucasse.10.mcz 311154Collections-Text-StephaneDucasse.14.mcz 311155Collections-Unordered-StephaneDucasse.38.mcz 311156Collections-Weak-StephaneDucasse.13.mcz 311157CollectionsTests-MarcusDenker.393.mcz 311158Compiler-AdrianLienhard.139.mcz 311159CompilerTests-AdrianLienhard.25.mcz 311160Compression-StephaneDucasse.37.mcz 311161EToys-StephaneDucasse.114.mcz 311162Exceptions-StephaneDucasse.38.mcz 311163Files-StephaneDucasse.ducasse.84.mcz 311164FixUnderscores-stephane_ducasse.17.mcz 311165FreeType-StephaneDucasse.463.mcz 311166FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 311167FreeTypeTests-tween.1.mcz 311168Gofer-AdrianLienhard.72.mcz 311169Graphics-StephaneDucasse.135.mcz 311170GraphicsTests-StephaneDucasse.20.mcz 311171HostMenus-StephaneDucasse.31.mcz 311172Kernel-AdrianLienhard.435.mcz 311173KernelTests-AdrianLienhard.161.mcz 311174Monticello-StephaneDucasse.400.mcz 311175MonticelloConfigurations-stephane_ducasse.54.mcz 311176MonticelloGUI-AdrianLienhard.18.mcz 311177Morphic-StephaneDucasse.386.mcz 311178MorphicTests-StephaneDucasse.20.mcz 311179Multilingual-StephaneDucasse.85.mcz 311180MultilingualTests-marcus_denker.denker.5.mcz 311181Network-Kernel-StephaneDucasse.19.mcz 311182Network-MIME-marcus_denker.9.mcz 311183Network-MailSending-StephaneDucasse.4.mcz 311184Network-Protocols-StephaneDucasse.16.mcz 311185Network-RFC822-StephaneDucasse.4.mcz 311186Network-RemoteDirectory-StephaneDucasse.16.mcz 311187Network-URI-StephaneDucasse.8.mcz 311188Network-UUID-StephaneDucasse.6.mcz 311189Network-Url-StephaneDucasse.15.mcz 311190NetworkTests-StephaneDucasse.16.mcz 311191PackageInfo-StephaneDucasse.34.mcz 311192PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 311193Polymorph-EventEnhancements-StephaneDucasse.6.mcz 311194Polymorph-Geometry-stephane_ducasse.5.mcz 311195Polymorph-ToolBuilder-StephaneDucasse.15.mcz 311196Polymorph-Tools-Diff-StephaneDucasse.30.mcz 311197Polymorph-Widgets-StephaneDucasse.103.mcz 311198PreferenceBrowser-StephaneDucasse.45.mcz 311199ST80-StephaneDucasse.81.mcz 311200SUnit-AdrianLienhard.82.mcz 311201SUnitGUI-AdrianLienhard.42.mcz 311202Services-Base-StephaneDucasse.55.mcz 311203SplitJoin-adrian_lienhard.37.mcz 311204System-Applications-marcus_denker.8.mcz 311205System-Change Notification-marcus_denker.9.mcz 311206System-Changes-MarcusDenker.15.mcz 311207System-Clipboard-StephaneDucasse.9.mcz 311208System-Digital Signatures-StephaneDucasse.5.mcz 311209System-Download-MikeRoberts.11.mcz 311210System-FilePackage-StephaneDucasse.12.mcz 311211System-FileRegistry-stephane_ducasse.6.mcz 311212System-Finalization-adrian_lienhard.10.mcz 311213System-Hashing-StephaneDucasse.4.mcz 311214System-Localization-adrian_lienhard.18.mcz 311215System-Object Events-sd.2.mcz 311216System-Object Storage-StephaneDucasse.32.mcz 311217System-Platforms-stephane_ducasse.4.mcz 311218System-Pools-sd.2.mcz 311219System-Serial Port-StephaneDucasse.8.mcz 311220System-Support-AdrianLienhard.103.mcz 311221System-Tools-StephaneDucasse.12.mcz 311222Tests-AdrianLienhard.32.mcz 311223ToolBuilder-Kernel-adrian_lienhard.31.mcz 311224ToolBuilder-Morphic-adrian_lienhard.44.mcz 311225ToolBuilder-SUnit-adrian_lienhard.24.mcz 311226Tools-StephaneDucasse.221.mcz 311227ToolsTest-stephane_ducasse.denker.5.mcz 311228Traits-AdrianLienhard.321.mcz 311229TrueType-MarcusDenker.14.mcz 311230VB-Regex-StephaneDucasse.33.mcz' 311231findTokens: String lf , String cr. 311232 311233 self loadTogether: names merge: false.! ! 311234 311235!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'AdrianLienhard 10/19/2009 13:48'! 311236script563 311237 311238 | names | 311239names := 'Announcements-adrian_lienhard.22.mcz 311240Balloon-MarcusDenker.33.mcz 311241Collections-Abstract-StephaneDucasse.28.mcz 311242Collections-Arrayed-MarcusDenker.21.mcz 311243Collections-Sequenceable-StephaneDucasse.37.mcz 311244Collections-SkipLists-adrian_lienhard.6.mcz 311245Collections-Stack-stephane_ducasse.3.mcz 311246Collections-Streams-StephaneDucasse.28.mcz 311247Collections-Strings-MarcusDenker.42.mcz 311248Collections-Support-StephaneDucasse.10.mcz 311249Collections-Text-StephaneDucasse.14.mcz 311250Collections-Unordered-StephaneDucasse.38.mcz 311251Collections-Weak-StephaneDucasse.13.mcz 311252CollectionsTests-MarcusDenker.393.mcz 311253Compiler-AdrianLienhard.139.mcz 311254CompilerTests-AdrianLienhard.25.mcz 311255Compression-StephaneDucasse.37.mcz 311256EToys-StephaneDucasse.114.mcz 311257Exceptions-StephaneDucasse.38.mcz 311258Files-StephaneDucasse.ducasse.84.mcz 311259FixUnderscores-stephane_ducasse.17.mcz 311260FreeType-StephaneDucasse.463.mcz 311261FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 311262FreeTypeTests-tween.1.mcz 311263Gofer-AdrianLienhard.72.mcz 311264Graphics-StephaneDucasse.135.mcz 311265GraphicsTests-StephaneDucasse.20.mcz 311266HostMenus-StephaneDucasse.31.mcz 311267Kernel-AdrianLienhard.435.mcz 311268KernelTests-AdrianLienhard.161.mcz 311269Monticello-StephaneDucasse.400.mcz 311270MonticelloConfigurations-stephane_ducasse.54.mcz 311271MonticelloGUI-AdrianLienhard.18.mcz 311272Morphic-StephaneDucasse.386.mcz 311273MorphicTests-StephaneDucasse.20.mcz 311274Multilingual-StephaneDucasse.85.mcz 311275MultilingualTests-marcus_denker.denker.5.mcz 311276Network-Kernel-StephaneDucasse.19.mcz 311277Network-MIME-marcus_denker.9.mcz 311278Network-MailSending-StephaneDucasse.4.mcz 311279Network-Protocols-StephaneDucasse.16.mcz 311280Network-RFC822-StephaneDucasse.4.mcz 311281Network-RemoteDirectory-StephaneDucasse.16.mcz 311282Network-URI-StephaneDucasse.8.mcz 311283Network-UUID-StephaneDucasse.6.mcz 311284Network-Url-StephaneDucasse.15.mcz 311285NetworkTests-StephaneDucasse.16.mcz 311286PackageInfo-StephaneDucasse.34.mcz 311287PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 311288Polymorph-EventEnhancements-StephaneDucasse.6.mcz 311289Polymorph-Geometry-stephane_ducasse.5.mcz 311290Polymorph-ToolBuilder-StephaneDucasse.15.mcz 311291Polymorph-Tools-Diff-StephaneDucasse.30.mcz 311292Polymorph-Widgets-StephaneDucasse.103.mcz 311293PreferenceBrowser-StephaneDucasse.45.mcz 311294ST80-StephaneDucasse.81.mcz 311295SUnit-AdrianLienhard.82.mcz 311296SUnitGUI-AdrianLienhard.42.mcz 311297Services-Base-StephaneDucasse.55.mcz 311298SplitJoin-adrian_lienhard.37.mcz 311299System-Applications-marcus_denker.8.mcz 311300System-Change Notification-marcus_denker.9.mcz 311301System-Changes-MarcusDenker.15.mcz 311302System-Clipboard-StephaneDucasse.9.mcz 311303System-Digital Signatures-StephaneDucasse.5.mcz 311304System-Download-MikeRoberts.11.mcz 311305System-FilePackage-StephaneDucasse.12.mcz 311306System-FileRegistry-stephane_ducasse.6.mcz 311307System-Finalization-adrian_lienhard.10.mcz 311308System-Hashing-StephaneDucasse.4.mcz 311309System-Localization-adrian_lienhard.18.mcz 311310System-Object Events-sd.2.mcz 311311System-Object Storage-StephaneDucasse.32.mcz 311312System-Platforms-stephane_ducasse.4.mcz 311313System-Pools-sd.2.mcz 311314System-Serial Port-StephaneDucasse.8.mcz 311315System-Support-AdrianLienhard.103.mcz 311316System-Tools-StephaneDucasse.12.mcz 311317Tests-AdrianLienhard.33.mcz 311318ToolBuilder-Kernel-adrian_lienhard.31.mcz 311319ToolBuilder-Morphic-adrian_lienhard.44.mcz 311320ToolBuilder-SUnit-adrian_lienhard.24.mcz 311321Tools-StephaneDucasse.221.mcz 311322ToolsTest-stephane_ducasse.denker.5.mcz 311323Traits-AdrianLienhard.321.mcz 311324TrueType-MarcusDenker.14.mcz 311325VB-Regex-StephaneDucasse.33.mcz' 311326findTokens: String lf , String cr. 311327 311328 self loadTogether: names merge: false.! ! 311329 311330!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'AdrianLienhard 10/19/2009 14:19'! 311331script564 311332 311333 | names | 311334names := 'Announcements-adrian_lienhard.22.mcz 311335Balloon-MarcusDenker.33.mcz 311336Collections-Abstract-StephaneDucasse.28.mcz 311337Collections-Arrayed-MarcusDenker.21.mcz 311338Collections-Sequenceable-StephaneDucasse.37.mcz 311339Collections-SkipLists-adrian_lienhard.6.mcz 311340Collections-Stack-stephane_ducasse.3.mcz 311341Collections-Streams-StephaneDucasse.28.mcz 311342Collections-Strings-MarcusDenker.42.mcz 311343Collections-Support-StephaneDucasse.10.mcz 311344Collections-Text-StephaneDucasse.14.mcz 311345Collections-Unordered-StephaneDucasse.38.mcz 311346Collections-Weak-StephaneDucasse.13.mcz 311347CollectionsTests-MarcusDenker.393.mcz 311348Compiler-AdrianLienhard.139.mcz 311349CompilerTests-AdrianLienhard.25.mcz 311350Compression-StephaneDucasse.37.mcz 311351EToys-StephaneDucasse.114.mcz 311352Exceptions-StephaneDucasse.38.mcz 311353Files-StephaneDucasse.ducasse.84.mcz 311354FixUnderscores-stephane_ducasse.17.mcz 311355FreeType-StephaneDucasse.463.mcz 311356FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 311357FreeTypeTests-tween.1.mcz 311358Gofer-AdrianLienhard.72.mcz 311359Graphics-StephaneDucasse.135.mcz 311360GraphicsTests-StephaneDucasse.20.mcz 311361HostMenus-StephaneDucasse.31.mcz 311362Kernel-AdrianLienhard.435.mcz 311363KernelTests-AdrianLienhard.161.mcz 311364Monticello-StephaneDucasse.400.mcz 311365MonticelloConfigurations-stephane_ducasse.54.mcz 311366MonticelloGUI-AdrianLienhard.18.mcz 311367Morphic-StephaneDucasse.386.mcz 311368MorphicTests-StephaneDucasse.20.mcz 311369Multilingual-StephaneDucasse.85.mcz 311370MultilingualTests-marcus_denker.denker.5.mcz 311371Network-Kernel-StephaneDucasse.19.mcz 311372Network-MIME-marcus_denker.9.mcz 311373Network-MailSending-StephaneDucasse.4.mcz 311374Network-Protocols-StephaneDucasse.16.mcz 311375Network-RFC822-StephaneDucasse.4.mcz 311376Network-RemoteDirectory-StephaneDucasse.16.mcz 311377Network-URI-StephaneDucasse.8.mcz 311378Network-UUID-StephaneDucasse.6.mcz 311379Network-Url-StephaneDucasse.15.mcz 311380NetworkTests-StephaneDucasse.16.mcz 311381PackageInfo-StephaneDucasse.34.mcz 311382PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 311383Polymorph-EventEnhancements-StephaneDucasse.6.mcz 311384Polymorph-Geometry-stephane_ducasse.5.mcz 311385Polymorph-ToolBuilder-StephaneDucasse.15.mcz 311386Polymorph-Tools-Diff-StephaneDucasse.30.mcz 311387Polymorph-Widgets-StephaneDucasse.103.mcz 311388PreferenceBrowser-StephaneDucasse.45.mcz 311389ST80-StephaneDucasse.81.mcz 311390SUnit-AdrianLienhard.82.mcz 311391SUnitGUI-AdrianLienhard.42.mcz 311392Services-Base-StephaneDucasse.55.mcz 311393SplitJoin-adrian_lienhard.37.mcz 311394System-Applications-marcus_denker.8.mcz 311395System-Change Notification-marcus_denker.9.mcz 311396System-Changes-MarcusDenker.15.mcz 311397System-Clipboard-StephaneDucasse.9.mcz 311398System-Digital Signatures-StephaneDucasse.5.mcz 311399System-Download-MikeRoberts.11.mcz 311400System-FilePackage-StephaneDucasse.12.mcz 311401System-FileRegistry-stephane_ducasse.6.mcz 311402System-Finalization-adrian_lienhard.10.mcz 311403System-Hashing-StephaneDucasse.4.mcz 311404System-Localization-adrian_lienhard.18.mcz 311405System-Object Events-sd.2.mcz 311406System-Object Storage-StephaneDucasse.32.mcz 311407System-Platforms-stephane_ducasse.4.mcz 311408System-Pools-sd.2.mcz 311409System-Serial Port-StephaneDucasse.8.mcz 311410System-Support-AdrianLienhard.103.mcz 311411System-Tools-StephaneDucasse.12.mcz 311412Tests-AdrianLienhard.34.mcz 311413ToolBuilder-Kernel-adrian_lienhard.31.mcz 311414ToolBuilder-Morphic-adrian_lienhard.44.mcz 311415ToolBuilder-SUnit-adrian_lienhard.24.mcz 311416Tools-StephaneDucasse.221.mcz 311417ToolsTest-stephane_ducasse.denker.5.mcz 311418Traits-AdrianLienhard.321.mcz 311419TrueType-MarcusDenker.14.mcz 311420VB-Regex-StephaneDucasse.33.mcz' 311421findTokens: String lf , String cr. 311422 311423 self loadTogether: names merge: false.! ! 311424 311425!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'AdrianLienhard 10/19/2009 14:33'! 311426script565 311427 311428 | names | 311429names := 'Announcements-adrian_lienhard.22.mcz 311430Balloon-MarcusDenker.33.mcz 311431Collections-Abstract-StephaneDucasse.28.mcz 311432Collections-Arrayed-MarcusDenker.21.mcz 311433Collections-Sequenceable-StephaneDucasse.37.mcz 311434Collections-SkipLists-adrian_lienhard.6.mcz 311435Collections-Stack-stephane_ducasse.3.mcz 311436Collections-Streams-StephaneDucasse.28.mcz 311437Collections-Strings-MarcusDenker.42.mcz 311438Collections-Support-StephaneDucasse.10.mcz 311439Collections-Text-StephaneDucasse.14.mcz 311440Collections-Unordered-StephaneDucasse.38.mcz 311441Collections-Weak-StephaneDucasse.13.mcz 311442CollectionsTests-MarcusDenker.393.mcz 311443Compiler-AdrianLienhard.139.mcz 311444CompilerTests-AdrianLienhard.25.mcz 311445Compression-StephaneDucasse.37.mcz 311446EToys-StephaneDucasse.114.mcz 311447Exceptions-StephaneDucasse.38.mcz 311448Files-StephaneDucasse.ducasse.84.mcz 311449FixUnderscores-stephane_ducasse.17.mcz 311450FreeType-StephaneDucasse.463.mcz 311451FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 311452FreeTypeTests-tween.1.mcz 311453Gofer-AdrianLienhard.72.mcz 311454Graphics-StephaneDucasse.135.mcz 311455GraphicsTests-StephaneDucasse.20.mcz 311456HostMenus-StephaneDucasse.31.mcz 311457Kernel-AdrianLienhard.435.mcz 311458KernelTests-AdrianLienhard.161.mcz 311459Monticello-StephaneDucasse.400.mcz 311460MonticelloConfigurations-stephane_ducasse.54.mcz 311461MonticelloGUI-AdrianLienhard.18.mcz 311462Morphic-StephaneDucasse.386.mcz 311463MorphicTests-StephaneDucasse.20.mcz 311464Multilingual-StephaneDucasse.85.mcz 311465MultilingualTests-marcus_denker.denker.5.mcz 311466Network-Kernel-StephaneDucasse.19.mcz 311467Network-MIME-marcus_denker.9.mcz 311468Network-MailSending-StephaneDucasse.4.mcz 311469Network-Protocols-StephaneDucasse.16.mcz 311470Network-RFC822-StephaneDucasse.4.mcz 311471Network-RemoteDirectory-StephaneDucasse.16.mcz 311472Network-URI-StephaneDucasse.8.mcz 311473Network-UUID-StephaneDucasse.6.mcz 311474Network-Url-StephaneDucasse.15.mcz 311475NetworkTests-StephaneDucasse.16.mcz 311476PackageInfo-StephaneDucasse.34.mcz 311477PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 311478Polymorph-EventEnhancements-StephaneDucasse.6.mcz 311479Polymorph-Geometry-stephane_ducasse.5.mcz 311480Polymorph-ToolBuilder-StephaneDucasse.15.mcz 311481Polymorph-Tools-Diff-StephaneDucasse.30.mcz 311482Polymorph-Widgets-StephaneDucasse.103.mcz 311483PreferenceBrowser-StephaneDucasse.45.mcz 311484ST80-StephaneDucasse.81.mcz 311485SUnit-AdrianLienhard.82.mcz 311486SUnitGUI-AdrianLienhard.42.mcz 311487Services-Base-StephaneDucasse.55.mcz 311488SplitJoin-adrian_lienhard.37.mcz 311489System-Applications-marcus_denker.8.mcz 311490System-Change Notification-marcus_denker.9.mcz 311491System-Changes-MarcusDenker.15.mcz 311492System-Clipboard-StephaneDucasse.9.mcz 311493System-Digital Signatures-StephaneDucasse.5.mcz 311494System-Download-MikeRoberts.11.mcz 311495System-FilePackage-StephaneDucasse.12.mcz 311496System-FileRegistry-stephane_ducasse.6.mcz 311497System-Finalization-adrian_lienhard.10.mcz 311498System-Hashing-StephaneDucasse.4.mcz 311499System-Localization-adrian_lienhard.18.mcz 311500System-Object Events-sd.2.mcz 311501System-Object Storage-StephaneDucasse.32.mcz 311502System-Platforms-stephane_ducasse.4.mcz 311503System-Pools-sd.2.mcz 311504System-Serial Port-StephaneDucasse.8.mcz 311505System-Support-AdrianLienhard.103.mcz 311506System-Tools-StephaneDucasse.12.mcz 311507Tests-AdrianLienhard.35.mcz 311508ToolBuilder-Kernel-adrian_lienhard.31.mcz 311509ToolBuilder-Morphic-adrian_lienhard.44.mcz 311510ToolBuilder-SUnit-adrian_lienhard.24.mcz 311511Tools-StephaneDucasse.221.mcz 311512ToolsTest-stephane_ducasse.denker.5.mcz 311513Traits-AdrianLienhard.321.mcz 311514TrueType-MarcusDenker.14.mcz 311515VB-Regex-StephaneDucasse.33.mcz' 311516findTokens: String lf , String cr. 311517 311518 self loadTogether: names merge: false.! ! 311519 311520!ScriptLoader methodsFor: 'pharo - scripts' stamp: 'AdrianLienhard 10/19/2009 15:16'! 311521script566 311522 311523 | names | 311524names := 'Announcements-adrian_lienhard.22.mcz 311525Balloon-MarcusDenker.33.mcz 311526Collections-Abstract-StephaneDucasse.28.mcz 311527Collections-Arrayed-MarcusDenker.21.mcz 311528Collections-Sequenceable-StephaneDucasse.37.mcz 311529Collections-SkipLists-adrian_lienhard.6.mcz 311530Collections-Stack-stephane_ducasse.3.mcz 311531Collections-Streams-StephaneDucasse.28.mcz 311532Collections-Strings-MarcusDenker.42.mcz 311533Collections-Support-StephaneDucasse.10.mcz 311534Collections-Text-StephaneDucasse.14.mcz 311535Collections-Unordered-StephaneDucasse.38.mcz 311536Collections-Weak-StephaneDucasse.13.mcz 311537CollectionsTests-MarcusDenker.393.mcz 311538Compiler-AdrianLienhard.139.mcz 311539CompilerTests-AdrianLienhard.25.mcz 311540Compression-StephaneDucasse.37.mcz 311541EToys-StephaneDucasse.114.mcz 311542Exceptions-StephaneDucasse.38.mcz 311543Files-StephaneDucasse.ducasse.84.mcz 311544FixUnderscores-stephane_ducasse.17.mcz 311545FreeType-StephaneDucasse.463.mcz 311546FreeTypeSubPixelAntiAliasing-stephane_ducasse.18.mcz 311547FreeTypeTests-tween.1.mcz 311548Gofer-AdrianLienhard.72.mcz 311549Graphics-StephaneDucasse.135.mcz 311550GraphicsTests-StephaneDucasse.20.mcz 311551HostMenus-StephaneDucasse.31.mcz 311552Kernel-AdrianLienhard.435.mcz 311553KernelTests-AdrianLienhard.161.mcz 311554Monticello-StephaneDucasse.400.mcz 311555MonticelloConfigurations-stephane_ducasse.54.mcz 311556MonticelloGUI-AdrianLienhard.18.mcz 311557Morphic-StephaneDucasse.386.mcz 311558MorphicTests-StephaneDucasse.20.mcz 311559Multilingual-StephaneDucasse.85.mcz 311560MultilingualTests-marcus_denker.denker.5.mcz 311561Network-Kernel-StephaneDucasse.19.mcz 311562Network-MIME-marcus_denker.9.mcz 311563Network-MailSending-StephaneDucasse.4.mcz 311564Network-Protocols-StephaneDucasse.16.mcz 311565Network-RFC822-StephaneDucasse.4.mcz 311566Network-RemoteDirectory-StephaneDucasse.16.mcz 311567Network-URI-StephaneDucasse.8.mcz 311568Network-UUID-StephaneDucasse.6.mcz 311569Network-Url-StephaneDucasse.15.mcz 311570NetworkTests-StephaneDucasse.16.mcz 311571PackageInfo-StephaneDucasse.34.mcz 311572PinesoftEnhancementsForFreetype-marcus_denker.4.mcz 311573Polymorph-EventEnhancements-StephaneDucasse.6.mcz 311574Polymorph-Geometry-stephane_ducasse.5.mcz 311575Polymorph-ToolBuilder-StephaneDucasse.15.mcz 311576Polymorph-Tools-Diff-StephaneDucasse.30.mcz 311577Polymorph-Widgets-StephaneDucasse.103.mcz 311578PreferenceBrowser-StephaneDucasse.45.mcz 311579ST80-StephaneDucasse.81.mcz 311580SUnit-AdrianLienhard.82.mcz 311581SUnitGUI-AdrianLienhard.42.mcz 311582Services-Base-StephaneDucasse.55.mcz 311583SplitJoin-adrian_lienhard.37.mcz 311584System-Applications-marcus_denker.8.mcz 311585System-Change Notification-marcus_denker.9.mcz 311586System-Changes-MarcusDenker.15.mcz 311587System-Clipboard-StephaneDucasse.9.mcz 311588System-Digital Signatures-StephaneDucasse.5.mcz 311589System-Download-MikeRoberts.11.mcz 311590System-FilePackage-StephaneDucasse.12.mcz 311591System-FileRegistry-stephane_ducasse.6.mcz 311592System-Finalization-adrian_lienhard.10.mcz 311593System-Hashing-StephaneDucasse.4.mcz 311594System-Localization-adrian_lienhard.18.mcz 311595System-Object Events-sd.2.mcz 311596System-Object Storage-StephaneDucasse.32.mcz 311597System-Platforms-stephane_ducasse.4.mcz 311598System-Pools-sd.2.mcz 311599System-Serial Port-StephaneDucasse.8.mcz 311600System-Support-AdrianLienhard.103.mcz 311601System-Tools-StephaneDucasse.12.mcz 311602Tests-AdrianLienhard.35.mcz 311603ToolBuilder-Kernel-adrian_lienhard.31.mcz 311604ToolBuilder-Morphic-adrian_lienhard.44.mcz 311605ToolBuilder-SUnit-adrian_lienhard.24.mcz 311606Tools-StephaneDucasse.221.mcz 311607ToolsTest-stephane_ducasse.denker.5.mcz 311608Traits-AdrianLienhard.321.mcz 311609TrueType-MarcusDenker.14.mcz 311610VB-Regex-StephaneDucasse.33.mcz' 311611findTokens: String lf , String cr. 311612 311613 self loadTogether: names merge: false.! ! 311614 311615 311616!ScriptLoader methodsFor: 'pharo - updates' stamp: 'StephaneDucasse 10/17/2009 18:07'! 311617update10477 311618 "self new update10477" 311619 self withUpdateLog: '- Issue 1224: Avoiding uncessary pop up when compiling a method 311620- Issue 1044: MethodContext allInstances loops forever'. 311621 self script553. 311622 self flushCaches. 311623! ! 311624 311625!ScriptLoader methodsFor: 'pharo - updates' stamp: 'AdrianLienhard 10/18/2009 17:10'! 311626update10478 311627 "self new update10478" 311628 self withUpdateLog: 'Issue 1310: Make all tests green (work in progress) 311629Issue 818: MethodContext tempNames wrong implementation or usage for Closure 311630Issue 1270: ClassBuilder wrong class format validation 311631Issue 1317: Add MethodHighlightingTests back 311632Tests for ImageSegment (including support for analyzing a segment)'. 311633 self script554. 311634 self flushCaches. 311635! ! 311636 311637!ScriptLoader methodsFor: 'pharo - updates' stamp: 'StephaneDucasse 10/18/2009 18:49'! 311638update10479 311639 "self new update10479" 311640 self withUpdateLog: '- simple try to publish in pharo1.0 folder (third try)'. 311641 self script557. 311642 self flushCaches. 311643! ! 311644 311645!ScriptLoader methodsFor: 'pharo - updates' stamp: 'StephaneDucasse 10/18/2009 18:52'! 311646update10480 311647 "self new update10480" 311648 self withUpdateLog: '- simple transcript improvements'. 311649 self script558. 311650 self flushCaches. 311651! ! 311652 311653!ScriptLoader methodsFor: 'pharo - updates' stamp: 'AdrianLienhard 10/18/2009 19:09'! 311654update10481 311655 "self new update10481" 311656 self withUpdateLog: '- Issue 1327: TestRunner should set dummy author when running tests 311657- Issue 1310: Make all tests green (work in progress)'. 311658 self script559. 311659 self flushCaches. 311660! ! 311661 311662!ScriptLoader methodsFor: 'pharo - updates' stamp: 'AdrianLienhard 10/19/2009 09:52'! 311663update10482 311664 "self new update10482" 311665 self withUpdateLog: 'Issue 1310: Make all tests green (done now?) 311666Issue 1319: [squeak trunk] Fix MNU #empty while Debugging 311667Issue 1320: [squeak trunk] Sort the conflicts. This is required when merging a distant version, like Pharo for example... 311668Issue 1327: TestRunner should set dummy author when running tests'. 311669 self script560. 311670 self flushCaches. 311671! ! 311672 311673!ScriptLoader methodsFor: 'pharo - updates' stamp: 'AdrianLienhard 10/19/2009 10:55'! 311674update10483 311675 "self new update10483" 311676 self withUpdateLog: 'Issue 1330: Better performance for tests'. 311677 self script561. 311678 self flushCaches. 311679! ! 311680 311681!ScriptLoader methodsFor: 'pharo - updates' stamp: 'AdrianLienhard 10/19/2009 12:09'! 311682update10484 311683 "self new update10484" 311684 self withUpdateLog: 'Issue 1330: Better performance for tests (fix) 311685Add Gofer to core'. 311686 self script562. 311687 311688self addHomeRepositoryToAllPackages. 311689 self flushCaches. 311690! ! 311691 311692!ScriptLoader methodsFor: 'pharo - updates' stamp: 'AdrianLienhard 10/19/2009 13:48'! 311693update10485 311694 "self new update10485" 311695 self withUpdateLog: 'Fix remaining failing test (sideeffect of loading Gofer)'. 311696 self script563. 311697 self flushCaches. 311698! ! 311699 311700!ScriptLoader methodsFor: 'pharo - updates' stamp: 'AdrianLienhard 10/19/2009 14:19'! 311701update10486 311702 "self new update10486" 311703 self withUpdateLog: '- Mantis 0006347: [FIX] testFinalizationOfEquals fails'. 311704 self script564. 311705 self flushCaches. 311706! ! 311707 311708!ScriptLoader methodsFor: 'pharo - updates' stamp: 'AdrianLienhard 10/19/2009 14:34'! 311709update10487 311710 "self new update10487" 311711 self withUpdateLog: '- expected failure testFinalizationOfEquals'. 311712 self script565. 311713 self flushCaches. 311714! ! 311715 311716!ScriptLoader methodsFor: 'pharo - updates' stamp: 'AdrianLienhard 10/19/2009 15:16'! 311717update10488 311718 "self new update10488" 311719 self withUpdateLog: 'Condense sources'. 311720 self script566. 311721 Smalltalk condenseSources. 311722 self flushCaches. 311723! ! 311724 311725 311726!ScriptLoader methodsFor: 'public' stamp: 'DamienCassou 10/6/2009 10:04'! 311727CSForLastUpdate: aString 311728 "ScriptLoader new CSForLastUpdate: 'cleanUpMethods'" 311729 311730 | str updateNumber filename| 311731 updateNumber := self getLatestUpdateNumber. 311732 filename := updateNumber asString, '-Pha-', aString, '.cs'. 311733 str := FileDirectory default 311734 forceNewFileNamed: filename. 311735 self 311736 generateCS: self latestScriptLoaderPackageIdentificationString 311737 fromUpdate: updateNumber on: str. 311738 str close. 311739 ^ filename! ! 311740 311741!ScriptLoader methodsFor: 'public' stamp: 'DamienCassou 10/6/2009 10:04'! 311742CSForLastUpdateAndPatchUpdatesList: aString 311743 "ScriptLoader new CSForLastUpdateAndPatchUpdatesList: 'cleanUpMethods'" 311744 | filename | 311745 filename := self CSForLastUpdate: aString. 311746 self updateUpdatesList: aString. 311747 ^ filename! ! 311748 311749!ScriptLoader methodsFor: 'public' stamp: 'AdrianLienhard 10/19/2009 15:16'! 311750commentForCurrentUpdate 311751 ^'Condense sources'! ! 311752 311753!ScriptLoader methodsFor: 'public' stamp: 'stephane.ducasse 8/22/2008 20:06'! 311754copyDiffPackagesToPharo 311755 "Copy the clean packages that may have been loaded by a slice but are not yet in pharo repository" 311756 "self new copyDiffPackagesToPharo" 311757 "self new diffPackages" 311758 311759 311760 | s man r | 311761 s := Set new. 311762 man := MCWorkingCopy allManagers. 311763 Transcript show: '=========================================================================';cr. 311764 Transcript show: self diffPackages ;cr. 311765 self diffPackages do: 311766 [:packName | 311767 r := man select: [:package | packName, '*' match: package ancestry ancestorString]. 311768 r isEmpty ifFalse: [s add: r first]]. 311769 s do: [:wc | 311770 self repository storeVersion: wc newVersion.]. 311771 311772 ! ! 311773 311774!ScriptLoader methodsFor: 'public' stamp: 'al 11/1/2008 19:26'! 311775copyPackagesFromWaitingFolderToHomeRepository 311776 "self defaultMCWaitingFolder allFileNames" 311777 "self new copyPackageFromWaitingFolderToHomeRepository" 311778 311779 | version | 311780 self waitingFolderMCZFiles do: [:name | 311781 version := self class defaultMCWaitingFolder versionFromFileNamed: name. 311782 self repository storeVersion: version]! ! 311783 311784!ScriptLoader methodsFor: 'public' stamp: 'stephane.ducasse 3/18/2009 21:13'! 311785diffPackages 311786 "return a list of packages that are new. They can be dirty or not." 311787 "self new diffPackages" 311788 311789 | diff | 311790 diff := Set new. 311791 self currentVersionsToBeSaved do: [:each | 311792 (PackagesBeforeLastLoad includes: each) ifFalse: [diff add: each]]. 311793 ^ diff 311794 ! ! 311795 311796!ScriptLoader methodsFor: 'public' stamp: 'stephane.ducasse 7/4/2009 12:27'! 311797generateCompleteFixList 311798 "generateCompleteFixList" 311799 | stream | 311800 stream := (FileStream newFileNamed: 'changes-log.txt'). 311801 [ stream nextPutAll: ScriptLoader new logStream contents ] ensure: [ stream close ]! ! 311802 311803!ScriptLoader methodsFor: 'public' stamp: 'adrianLienhard 11/1/2008 23:05'! 311804generateScriptAndUpdateMethodForNewVersion 311805 "Use me to generate the script and update method" 311806 "self new generateScriptAndUpdateMethodForNewVersion" 311807 311808 self compileScriptMethodWithCurrentPackages: self currentScriptVersionNumber. 311809 self compileNewUpdateMethod.! ! 311810 311811!ScriptLoader methodsFor: 'public' stamp: 'AlexandreBergel 10/23/2008 15:30'! 311812loadLatestScriptloader 311813 "self new loadLatestScriptloader" 311814 311815 self class loadLatestPackage: 'ScriptLoader' fromSqueaksource: 'Pharo' ! ! 311816 311817!ScriptLoader methodsFor: 'public' stamp: 'al 11/1/2008 19:24'! 311818loadPackageFromWaitingFolder 311819 "self defaultMCWaitingFolder allFileNames" 311820 "self new loadPackageFromWaitingFolder" 311821 311822 | version | 311823 self waitingFolderMCZFiles do: [:name | 311824 version := self class defaultMCWaitingFolder versionFromFileNamed: name. 311825 version load]! ! 311826 311827!ScriptLoader methodsFor: 'public' stamp: 'stephane.ducasse 8/14/2008 14:23'! 311828mergePackageFromWaitingFolder 311829 "self defaultMCWaitingFolder allFileNames" 311830 "self new loadPackageFromWaitingFolder" 311831 311832 | version | 311833 self waitingFolderMCZFiles 311834 do: [ :name | 311835 version := self class defaultMCWaitingFolder versionFromFileNamed: name. 311836 version merge. 311837 ]! ! 311838 311839!ScriptLoader methodsFor: 'public' stamp: 'al 11/1/2008 18:33'! 311840saveChangedPackagesIntoWaitingFolder 311841 self currentChangedPackages do: [:each | 311842 self 311843 saveInToReloadCachePackage: each 311844 with: self commentForCurrentUpdate]! ! 311845 311846!ScriptLoader methodsFor: 'public' stamp: 'stephane.ducasse 8/22/2008 19:58'! 311847saveLatestScriptLoaderToHome 311848 "self new saveLatestScriptLoaderToHome" 311849 311850 | man r | 311851 man := MCWorkingCopy allManagers. 311852 r := man select: [:each | 'ScriptLoader*' match: each package name]. 311853 self repository storeVersion: r first newVersion.! ! 311854 311855!ScriptLoader methodsFor: 'public' stamp: 'adrian_lienhard 11/2/2008 01:32'! 311856saveLatestScriptLoaderToWaitingFolder 311857 "self new saveLatestScriptLoaderToWaitingFolder" 311858 311859 | man r | 311860 man := MCWorkingCopy allManagers. 311861 r := man select: [:each | 'ScriptLoader*' match: each package name]. 311862 self 311863 saveInToReloadCachePackage: r first 311864 with: self commentForCurrentUpdate! ! 311865 311866!ScriptLoader methodsFor: 'public' stamp: 'adrianLienhard 11/1/2008 23:09'! 311867updateUpdatesList: aString 311868 "ScriptLoader new updateUpdatesList: 'cleanUpMethods'" 311869 311870 | str | 311871 str := FileDirectory default oldFileNamed: 'updates.list'. 311872 [ str 311873 setToEnd; 311874 cr; 311875 nextPutAll: self currentUpdateVersionNumber asString; 311876 nextPutAll: '-Pha-', aString, '.cs' ] 311877 ensure: [ str close ]! ! 311878 311879 311880!ScriptLoader methodsFor: 'public - update' stamp: 'd 8/8/2009 11:46'! 311881checkImageIsUptodate 311882 | stream last number | 311883 stream := FileDirectory default oldFileNamed: 'updates.list'. 311884 stream contents linesDo: [ :each | last := each ]. 311885 stream close. 311886 number := (last copyUpTo: $-) asNumber. 311887 ^ number = self getLatestUpdateNumber ! ! 311888 311889!ScriptLoader methodsFor: 'public - update' stamp: 'DamienCassou 9/26/2009 12:31'! 311890doneApplyingChanges 311891 | comment | 311892 comment := UIManager default 311893 multiLineRequest: 'Comment for this update.' 311894 centerAt: Sensor cursorPoint 311895 initialAnswer: self commentForCurrentUpdate 311896 answerHeight: 200. 311897 comment ifNil: [^ self]. 311898 self class 311899 compile: ('commentForCurrentUpdate', String cr, ' ^''' , comment, '''') 311900 classified: 'public'. 311901 311902 self class waitingCacheFolder deleteLocalFiles. 311903 self saveChangedPackagesIntoWaitingFolder. 311904 self generateScriptAndUpdateMethodForNewVersion. 311905 self saveLatestScriptLoaderToWaitingFolder. 311906 311907 self inform: 'Update prepared and ready to be verified.'! ! 311908 311909!ScriptLoader methodsFor: 'public - update' stamp: 'StephaneDucasse 9/8/2009 21:52'! 311910launchUpdate 311911 311912 Utilities updateFromServer! ! 311913 311914!ScriptLoader methodsFor: 'public - update' stamp: 'StephaneDucasse 9/8/2009 21:52'! 311915prepareNewUpdate 311916 self launchUpdate. 311917 self loadLatestScriptloader. 311918 self markPackagesBeforeNewCodeIsLoaded. 311919 self inform: 'Download update.list file using the script ./getUpdatesList and proceed when done'. 311920 self checkImageIsUptodate ifFalse: [ 311921 ^ self inform: 'Your update.list and your image are not in sync!! Please use a fresh image and download the latest update.list and start over.' ]. 311922 self setUpdateAndScriptVersionNumbers. 311923 self saveAsNewImageWithCurrentReleaseName. 311924 self inform: 'The new version number is ' , self currentUpdateVersionNumber asString , '. Ready to apply changes now.', String cr, 'You are now running in image ', (FileDirectory baseNameFor: (FileDirectory default localNameFor: SmalltalkImage current imageName)).! ! 311925 311926!ScriptLoader methodsFor: 'public - update' stamp: 'DamienCassou 10/6/2009 10:07'! 311927publishChanges 311928 | username password changescriptname changesetFilename| 311929 username := UIManager default request: 'Pharo repository login'. 311930 password := UIManager default requestPassword: 'Pharo repository password'. 311931 self setToRepositoriesPassword: password to: username. 311932 311933 changescriptname := UIManager default request: 'Changeset name (no space)' initialAnswer: 'WhatAsChanged'. 311934 changesetFilename := self CSForLastUpdateAndPatchUpdatesList: changescriptname. 311935 self copyPackagesFromWaitingFolderToHomeRepository. 311936 self announceOnMailingList. 311937 self inform: 'All packages have been uploaded to the Pharo repository. 311938Remaining manual steps: 3119391) ./upFiles ',changesetFilename,' 3119402) ./upFiles updates.list 3119413) Announce new update on mailing list'! ! 311942 311943!ScriptLoader methodsFor: 'public - update' stamp: 'adrian.lienhard 8/12/2009 22:45'! 311944verifyNewUpdate 311945 self repository: self class defaultMCWaitingFolder. 311946 self class loadLatestPackage: 'ScriptLoader' fromRepository: self repository. 311947 self perform: ('update', self getLatestUpdateNumber asString) asSymbol. 311948 311949 (self confirm: 'Completed loading the new update. Run all test now?') 311950 ifTrue: [ 311951 Author fullName: 'tester'. 311952 Smalltalk at: #TestRunner ifPresent: [ :class | 311953 class open model runAll ] ]! ! 311954 311955 311956!ScriptLoader methodsFor: 'utils' stamp: 'lr 7/10/2009 18:07'! 311957installGofer 311958 "self new installGofer" 311959 311960 self class loadLatestPackage: 'Gofer' from: 'http://source.lukas-renggli.ch/flair'! ! 311961 311962!ScriptLoader methodsFor: 'utils' stamp: 'damiencassou 11/27/2008 16:36'! 311963installingInstaller 311964 "self new installingInstaller" 311965 311966 | mc files fileToLoad version | 311967 mc := Smalltalk at: #MCHttpRepository ifPresent: [:repoClass | repoClass location: 'www.squeaksource.com/Installer' user: 'squeak' password: 'squeak']. 311968 files := mc readableFileNames asSortedCollection: [:a :b | [(a findBetweenSubStrs: #($.)) allButLast last asInteger > (b findBetweenSubStrs: #($.)) allButLast last asInteger] on: Error do: [:ex | false]]. 311969 fileToLoad := files detect: [ :aFile | aFile beginsWith: 'Installer-Core' ] ifNone: [ nil ]. 311970 version := mc versionFromFileNamed: fileToLoad. 311971 version workingCopy repositoryGroup addRepository: mc. 311972 mc creationTemplate: mc asCreationTemplate. 311973 version load. 311974 311975 ^ (Smalltalk at: #Installer)! ! 311976 311977!ScriptLoader methodsFor: 'utils' stamp: 'dc 9/28/2008 18:19'! 311978installingRBEngine 311979 311980 "| `@temps | 311981``@.BeforeStatements. 311982`f := ImporterFacade forVisualWorks. 311983`f inModel: `@m. 311984`f importingContext importMaximum. 311985`f importNameSpaceFromBinding: `@n. 311986``@.AfterStatements 311987 311988-> 311989 311990| `@temps | 311991``@.BeforeStatements. 311992ImporterFacade importNameSpaceFromVWBinding: `@n inModel: `@m. 311993``@.AfterStatements" 311994 311995 (self universalInstaller) universe install: 'Refactoring Core'! ! 311996 311997!ScriptLoader methodsFor: 'utils' stamp: 'dc 3/30/2008 19:51'! 311998installingUniverse 311999 self installer ss 312000 project: 'XMLSupport'; 312001 install: 'XML-Parser'. 312002 self installer ss 312003 project: 'universes'; 312004 install: 'Universes'! ! 312005 312006!ScriptLoader methodsFor: 'utils' stamp: 'sd 2/4/2008 16:09'! 312007openWindow: contents label: aLabel 312008 312009 StringHolder new 312010 contents: contents ; 312011 openLabel: aLabel! ! 312012 312013!ScriptLoader methodsFor: 'utils' stamp: 'StephaneDucasse 10/18/2009 16:06'! 312014removeScriptMethods 312015 "self new removeScriptMethods" 312016 312017 ((ScriptLoader organization listAtCategoryNamed: 'pharo - scripts') 312018 asSortedCollection allButLast) 312019 do: [:each | ScriptLoader removeSelector: each].! ! 312020 312021!ScriptLoader methodsFor: 'utils' stamp: 'StephaneDucasse 10/18/2009 16:04'! 312022removeUpdateMethods 312023 312024 312025 ((ScriptLoader organization listAtCategoryNamed: 'pharo - updates') 312026 asSortedCollection allButLast) 312027 do: [:each | ScriptLoader removeSelector: each].! ! 312028 312029 312030!ScriptLoader methodsFor: 'private' stamp: 'DamienCassou 9/8/2009 14:48'! 312031announceOnMailingList 312032 " 312033 self new announceOnMailingList" 312034 |title| 312035 title := '[update] #', self currentUpdateVersionNumber asString. 312036UIManager default 312037 edit: title, String cr, self currentUpdateVersionNumber asString, ' 312038----- 312039 312040', self commentForCurrentUpdate 312041 label: title.! ! 312042 312043!ScriptLoader methodsFor: 'private' stamp: 'michael.rueger 1/13/2009 16:34'! 312044buildConfigurationMapFor: packageNames 312045 312046 | configurationMap version depArray | 312047 configurationMap := MCConfiguration new. 312048 configurationMap repositories 312049 add: self repository; 312050 add: self inboxRepository. 312051 312052 packageNames do: [:packageName | 312053 version := self loadVersionFromFileNamed: packageName. 312054 depArray := { version package name. version info name. version info id asString. }. 312055 configurationMap dependencies add: (MCConfiguration dependencyFromArray: depArray)]. 312056 ^configurationMap! ! 312057 312058!ScriptLoader methodsFor: 'private' stamp: 'michael.rueger 1/13/2009 15:25'! 312059loadVersionFromFileNamed: fn 312060 | version | 312061 version := self repository loadVersionFromFileNamed: fn. 312062 ^version 312063 ifNil: [self inboxRepository loadVersionFromFileNamed: fn]! ! 312064 312065!ScriptLoader methodsFor: 'private' stamp: 'stephane.ducasse 3/18/2009 21:13'! 312066markPackagesBeforeNewCodeIsLoaded 312067 "Use this method to keep a log of all the packages that were loaded before loading new code. This will help the system to perform a diff and know after what to publish." 312068 312069 "self new markPackagesBeforeNewCodeIsLoaded" 312070 312071 PackagesBeforeLastLoad := self currentVersionsToBeSaved! ! 312072 312073!ScriptLoader methodsFor: 'private' stamp: 'adrian_lienhard 11/2/2008 01:27'! 312074packagesNotToSavePatternNames 312075 ^ #( 'ScriptLoader*' 312076 '*AST*' 312077 '*RefactoringEngine*' 312078 '*Installer*' 312079 'SLICE*' 312080 '*OB-*' 312081 'OmniBrowser*' 312082 ).! ! 312083 312084!ScriptLoader methodsFor: 'private' stamp: 'stephane.ducasse 3/18/2009 21:13'! 312085resetPackagesBeforeLastLoad 312086 PackagesBeforeLastLoad := Set new! ! 312087 312088!ScriptLoader methodsFor: 'private' stamp: 'DamienCassou 9/8/2009 14:42'! 312089saveAsNewImageWithCurrentReleaseName 312090 |name| 312091 name := FileDirectory default 312092 nextNameFor: ('releasePharo-', self currentUpdateVersionNumber asString) 312093 extension: FileDirectory imageSuffix. 312094 name isEmptyOrNil ifFalse: [SmalltalkImage current saveAs: name].! ! 312095 312096!ScriptLoader methodsFor: 'private' stamp: 'adrian_lienhard 3/16/2009 21:43'! 312097setToRepositoriesPassword: aPassword to: aUser 312098 "self new setToRepositoriesPassword: '' to: ''" 312099 312100 MCRepositoryGroup instVarNamed: 'default' put: nil. 312101 self removeAllRepositories: {self repository locationWithTrailingSlash . self inboxRepository locationWithTrailingSlash}. 312102 self repository password: aPassword. 312103 self repository user: aUser. 312104 self inboxRepository password: aPassword. 312105 self inboxRepository user: aUser. 312106 self addHomeRepositoryToAllPackages! ! 312107 312108"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 312109 312110ScriptLoader class 312111 instanceVariableNames: ''! 312112 312113!ScriptLoader class methodsFor: 'loadscripts' stamp: 'stephane.ducasse 7/20/2009 11:31'! 312114gofer 312115 ^ Smalltalk at: #Gofer ifAbsent: [ self new installGofer; gofer ]! ! 312116 312117!ScriptLoader class methodsFor: 'loadscripts' stamp: 'StephaneDucasse 10/18/2009 17:20'! 312118initialize 312119 312120 CurrentMajorVersionNumber := 1.0! ! 312121 312122!ScriptLoader class methodsFor: 'loadscripts' stamp: 'stephane.ducasse 7/7/2009 18:34'! 312123loadFFI 312124 self new installer monticello http: 'source.squeakfoundation.org'; 312125 project: 'FFI'; 312126 install: 'FFI-Kernel'; 312127 install: 'FFI-Tests'; 312128 install: 'FFI-Examples'. 312129 (Smalltalk at: #ExternalType) initialize. 312130 (Smalltalk at: #ExternalStructure) compileAllFields. 312131 Smalltalk recreateSpecialObjectsArray.! ! 312132 312133!ScriptLoader class methodsFor: 'loadscripts' stamp: 'TorstenBergmann 9/8/2009 10:26'! 312134loadSeaside30 312135 "self loadSeaside30" 312136 312137 | instClass installer| 312138 self loadComanche. 312139 312140 instClass := self environment at: #Installer ifAbsent: [self new installingInstaller]. 312141 312142 installer := instClass ss project: 'Seaside30'. 312143 installer 312144 answer: 'Load Seaside.*' with: true; 312145 answer: '.*SqueakSource User.*' with: ''; 312146 answer: '.*SqueakSource Password.*' with: ''; 312147 answer: 'Run tests*' with: false; 312148 install: 'LoadOrderTest'. 312149 312150 "Set up to development environment (enables seaside web toolbar) " 312151 (self environment at: #WAAdmin) applicationDefaults 312152 addParent: (self environment at: #WADevelopmentConfiguration) instance. 312153 312154 (self environment at: #WASqueakServerAdaptorBrowser) open! ! 312155 312156 312157!ScriptLoader class methodsFor: 'public' stamp: 'StephaneDucasse 10/18/2009 17:15'! 312158currentMajorVersionNumber 312159 312160 ^ CurrentMajorVersionNumber ! ! 312161 312162!ScriptLoader class methodsFor: 'public' stamp: 'StephaneDucasse 10/18/2009 17:12'! 312163currentMajorVersionNumber: aNumber 312164 312165 CurrentMajorVersionNumber := aNumber! ! 312166 312167!ScriptLoader class methodsFor: 'public' stamp: 'damiencassou 7/2/2009 21:37'! 312168releaseMenu 312169 "self releaseMenu" 312170 |symbol| 312171 symbol := UIManager default 312172 chooseFrom: #('1- Prepare new update' 312173 '2- Done applying changes' 312174 '3- Verify new update (other image, same folder)' 312175 '4- Publish changes') 312176 values: #(prepareNewUpdate doneApplyingChanges verifyNewUpdate publishChanges). 312177 symbol ifNotNil: [ScriptLoader new perform: symbol]! ! 312178 312179!ScriptLoader class methodsFor: 'public' stamp: 'adrian-lienhard 6/6/2009 11:46'! 312180resetLogStream 312181 LogStream := nil! ! 312182 312183!ScriptLoader class methodsFor: 'public' stamp: 'StephaneDucasse 10/18/2009 17:14'! 312184toPharoOne 312185 312186 self currentMajorVersionNumber: 1.0! ! 312187 312188!ScriptLoader class methodsFor: 'public' stamp: 'StephaneDucasse 10/18/2009 17:14'! 312189toPharoOneDotOne 312190 312191 self currentMajorVersionNumber: 1.1! ! 312192 312193 312194!ScriptLoader class methodsFor: 'private' stamp: 'adrian_lienhard 3/16/2009 21:32'! 312195defaultMCWaitingFolder 312196 "self defaultMCWaitingFolder" 312197 312198 ^ MCDirectoryRepository new directory: self waitingCacheFolder! ! 312199 312200!ScriptLoader class methodsFor: 'private' stamp: 'al 11/1/2008 20:03'! 312201loadLatestPackage: aString from: aPath 312202 | repository | 312203 312204 repository := MCHttpRepository 312205 location: aPath 312206 user: '' 312207 password: ''. 312208 self loadLatestPackage: aString fromRepository: repository! ! 312209 312210!ScriptLoader class methodsFor: 'private' stamp: 'stephane.ducasse 4/13/2009 21:09'! 312211loadLatestPackage: aString fromRepository: aRepository 312212 | versionsBlock versions tries version | 312213 312214 versionsBlock := [ (aRepository allVersionNames select: [ :each | 312215 each beginsWith: aString ]) 312216 asSortedCollection: [ :a :b | 312217 (a copyAfterLast: $.) asNumber <= (b copyAfterLast: $.) asNumber]]. 312218 versions := versionsBlock value. 312219 tries := 0. 312220 [ versions isEmpty and: [ tries < 3 ] ] whileTrue: [ 312221 versions := versionsBlock value. 312222 tries := tries + 1 ]. 312223 versions isEmpty ifTrue: [ self error: 'problems when accessing squeaksource' ]. 312224 312225 aRepository versionReaderForFileNamed: (versions last , '.mcz') do: [:reader | 312226 version := reader version. 312227 version load. 312228 version workingCopy repositoryGroup addRepository: aRepository]! ! 312229 312230!ScriptLoader class methodsFor: 'private' stamp: 'AlexandreBergel 10/23/2008 15:31'! 312231loadLatestPackage: aString fromSqueaksource: aDirectoryName 312232 " self loadLatestPackage: 'ScriptLoader' fromSqueaksource: 'Pharo' " 312233 312234 self loadLatestPackage: aString from: 'http://www.squeaksource.com/', aDirectoryName 312235 ! ! 312236 312237!ScriptLoader class methodsFor: 'private' stamp: 'sd 3/24/2008 20:59'! 312238packageToBeTestedFolderName 312239 312240 ^ 'packages-to-be-tested'! ! 312241 312242!ScriptLoader class methodsFor: 'private' stamp: 'adrian-lienhard 6/6/2009 11:47'! 312243waitingCacheFolder 312244 ^ (FileDirectory default directoryNamed: self packageToBeTestedFolderName) 312245 assureExistence; 312246 yourself 312247 312248 ! ! 312249TestCase subclass: #ScriptLoaderTest 312250 instanceVariableNames: '' 312251 classVariableNames: '' 312252 poolDictionaries: '' 312253 category: 'Tests-ScriptLoader'! 312254 312255!ScriptLoaderTest methodsFor: 'testing' stamp: 'adrian_lienhard 3/16/2009 22:44'! 312256testAllCurrentPackagesContainScriptLoader 312257 "self debug: #testAllCurrentPackagesContainScriptLoader" 312258 312259 | p | 312260 p := ScriptLoader new allCurrentPackages collect: [:each | each package name]. 312261 self assert: (p anySatisfy: [ :pa | 'ScriptLoader*' match: pa])! ! 312262 312263!ScriptLoaderTest methodsFor: 'testing' stamp: 'stephane.ducasse 6/30/2008 16:00'! 312264testAllCurrentVersionsContainsScriptLoader 312265 "self debug: #testAllCurrentVersionsContainsScriptLoader" 312266 312267 | p | 312268 p := ScriptLoader new allCurrentVersions. 312269 self assert: (p anySatisfy: [ :pa | 'ScriptLoader*' match: pa])! ! 312270 312271!ScriptLoaderTest methodsFor: 'testing' stamp: 'stephane.ducasse 6/30/2008 16:00'! 312272testCurrentPackagesDoesNotContainScriptLoader 312273 "self debug: #testCurrentPackagesDoesNotContainScriptLoader" 312274 312275 312276 | p | 312277 p := ScriptLoader new currentPackages collect: [:each | each package name]. 312278 self deny: (p anySatisfy: [ :pa | 'ScriptLoader*' match: pa])! ! 312279 312280!ScriptLoaderTest methodsFor: 'testing' stamp: 'adrian_lienhard 3/16/2009 21:34'! 312281testMarkPackageBeforeLoad 312282 "self debug: #testMarkPackageBeforeLoad" 312283 312284 312285 | s | 312286 s := ScriptLoader new. 312287 s resetPackagesBeforeLastLoad. 312288 self assert: s diffPackages size = s currentVersionsToBeSaved size. 312289 self assert: s = s. 312290 312291 s markPackagesBeforeNewCodeIsLoaded. 312292 self assert: s diffPackages isEmpty! ! 312293Slider subclass: #ScrollBar 312294 instanceVariableNames: 'menuButton upButton downButton pagingArea scrollDelta pageDelta interval menuSelector timeOfMouseDown timeOfLastScroll nextPageDirection currentScrollDelay' 312295 classVariableNames: 'ArrowImagesCache BoxesImagesCache UpArrow UpArrow8Bit' 312296 poolDictionaries: '' 312297 category: 'Morphic-Windows'! 312298!ScrollBar commentStamp: '<historical>' prior: 0! 312299Inspired by an oiginal design of Hans-Martin Mosner, this ScrollBar is intended to exercise the handling of input events in Morphic. With sufficient flexibility in this area, all particular behavior can be concentrated in this single class with no need to specialize any other morphs to achieve button, slider and menu-button behavior. 312300 312301Once we have this working, put in logic for horizontal operation as well. 312302 312303CachedImages was added to reduce the number of forms created and thrown away. This will be helpful for Nebraska and others as well.! 312304 312305 312306!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/5/2009 12:26'! 312307adoptGradientColor: aColor 312308 "Adopt the given pane color." 312309 312310 |c fs bfs bs bbs| 312311 aColor ifNil:[^self]. 312312 c := aColor. 312313 fs := self normalThumbFillStyle. 312314 bfs := self normalButtonFillStyle. 312315 bs := self normalThumbBorderStyle. 312316 bbs := self normalButtonBorderStyle. 312317 sliderColor := c. 312318 downButton 312319 fillStyle: bfs; 312320 borderStyle: bbs. 312321 upButton 312322 fillStyle: bfs clone; 312323 borderStyle: bbs. 312324 slider 312325 fillStyle: fs; 312326 borderStyle: bs. 312327 menuButton ifNotNilDo: [:mb | 312328 mb 312329 fillStyle: bfs clone; 312330 borderStyle: bbs]. 312331 self updateMenuButtonImage. 312332 self updateUpButtonImage. 312333 self updateDownButtonImage! ! 312334 312335!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 15:20'! 312336menuButtonMouseEnter: event 312337 "The mouse has entered the menu button." 312338 312339 super menuButtonMouseEnter: event. 312340 Preferences gradientScrollbarLook ifFalse:[^self]. 312341 menuButton 312342 fillStyle: self mouseOverButtonFillStyle; 312343 borderStyle: self mouseOverButtonBorderStyle; 312344 changed! ! 312345 312346!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 15:25'! 312347menuButtonMouseLeave: event 312348 "The mouse has left the menu button." 312349 312350 super menuButtonMouseLeave: event. 312351 Preferences gradientScrollbarLook ifFalse:[^self]. 312352 menuButton 312353 fillStyle: self normalButtonFillStyle; 312354 borderStyle: self normalButtonBorderStyle; 312355 changed! ! 312356 312357!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 15:20'! 312358mouseEnterDownButton: event 312359 "The mouse has entered the down button." 312360 312361 downButton 312362 fillStyle: self mouseOverButtonFillStyle; 312363 borderStyle: self mouseOverButtonBorderStyle; 312364 changed! ! 312365 312366!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/4/2007 15:38'! 312367mouseEnterPagingArea: event 312368 "The mouse has entered the paging area." 312369 312370 pagingArea 312371 fillStyle: self mouseOverFillStyle; 312372 borderStyle: self mouseOverBorderStyle; 312373 changed. 312374 slider 312375 fillStyle: self mouseOverPagingAreaThumbFillStyle; 312376 borderStyle: self mouseOverPagingAreaThumbBorderStyle; 312377 changed. 312378 menuButton ifNotNil: [ 312379 menuButton 312380 fillStyle: self mouseOverPagingAreaButtonFillStyle; 312381 borderStyle: self mouseOverPagingAreaButtonBorderStyle; 312382 changed]. 312383 upButton 312384 fillStyle: self mouseOverPagingAreaButtonFillStyle; 312385 borderStyle: self mouseOverPagingAreaButtonBorderStyle; 312386 changed. 312387 downButton 312388 fillStyle: self mouseOverPagingAreaButtonFillStyle; 312389 borderStyle: self mouseOverPagingAreaButtonBorderStyle; 312390 changed! ! 312391 312392!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/4/2007 15:11'! 312393mouseEnterThumb: event 312394 "The mouse has entered the thumb." 312395 312396 slider 312397 fillStyle: self mouseOverThumbFillStyle; 312398 borderStyle: self mouseOverThumbBorderStyle; 312399 changed. 312400 menuButton ifNotNil: [ 312401 menuButton 312402 fillStyle: self mouseOverThumbButtonFillStyle; 312403 borderStyle: self mouseOverThumbButtonBorderStyle; 312404 changed]. 312405 upButton 312406 fillStyle: self mouseOverThumbButtonFillStyle; 312407 borderStyle: self mouseOverThumbButtonBorderStyle; 312408 changed. 312409 downButton 312410 fillStyle: self mouseOverThumbButtonFillStyle; 312411 borderStyle: self mouseOverThumbButtonBorderStyle; 312412 changed! ! 312413 312414!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 15:20'! 312415mouseEnterUpButton: event 312416 "The mouse has entered the up button." 312417 312418 upButton 312419 fillStyle: self mouseOverButtonFillStyle; 312420 borderStyle: self mouseOverButtonBorderStyle; 312421 changed! ! 312422 312423!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 15:23'! 312424mouseLeaveDownButton: event 312425 "The mouse has left the down button." 312426 312427 downButton 312428 fillStyle: self normalButtonFillStyle; 312429 borderStyle: self normalButtonBorderStyle; 312430 changed! ! 312431 312432!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/4/2007 15:45'! 312433mouseLeavePagingArea: event 312434 "The mouse has left the paging area." 312435 312436 pagingArea 312437 fillStyle: self normalFillStyle; 312438 borderStyle: self normalBorderStyle; 312439 changed. 312440 slider 312441 fillStyle: self normalThumbFillStyle; 312442 borderStyle: self normalThumbBorderStyle; 312443 changed. 312444 menuButton ifNotNil: [ 312445 menuButton 312446 fillStyle: self normalButtonFillStyle; 312447 borderStyle: self normalButtonBorderStyle; 312448 changed]. 312449 upButton 312450 fillStyle: self normalButtonFillStyle; 312451 borderStyle: self normalButtonBorderStyle; 312452 changed. 312453 downButton 312454 fillStyle: self normalButtonFillStyle; 312455 borderStyle: self normalButtonBorderStyle; 312456 changed! ! 312457 312458!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/4/2007 16:08'! 312459mouseLeaveThumb: event 312460 "The mouse has left the thumb." 312461 312462 slider 312463 fillStyle: self normalThumbFillStyle; 312464 borderStyle: self normalThumbBorderStyle; 312465 changed. 312466 menuButton ifNotNil: [ 312467 (self containsPoint: event position) 312468 ifTrue: [menuButton 312469 fillStyle: self mouseOverPagingAreaButtonFillStyle; 312470 borderStyle: self mouseOverPagingAreaButtonBorderStyle] 312471 ifFalse: [menuButton 312472 fillStyle: self normalButtonFillStyle; 312473 borderStyle: self normalButtonBorderStyle]]. 312474 (self containsPoint: event position) 312475 ifTrue: [upButton 312476 fillStyle: self mouseOverPagingAreaButtonFillStyle; 312477 borderStyle: self mouseOverPagingAreaButtonBorderStyle] 312478 ifFalse: [upButton 312479 fillStyle: self normalButtonFillStyle; 312480 borderStyle: self normalButtonBorderStyle]. 312481 (self containsPoint: event position) 312482 ifTrue: [downButton 312483 fillStyle: self mouseOverPagingAreaButtonFillStyle; 312484 borderStyle: self mouseOverPagingAreaButtonBorderStyle] 312485 ifFalse: [downButton 312486 fillStyle: self normalButtonFillStyle; 312487 borderStyle: self normalButtonBorderStyle]! ! 312488 312489!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 15:24'! 312490mouseLeaveUpButton: event 312491 "The mouse has left the up button." 312492 312493 upButton 312494 fillStyle: self normalButtonFillStyle; 312495 borderStyle: self normalButtonBorderStyle; 312496 changed! ! 312497 312498!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 312499mouseOverBorderStyle 312500 "Return the mouse over borderStyle for the receiver." 312501 312502 ^self theme scrollbarMouseOverBorderStyleFor: self! ! 312503 312504!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 312505mouseOverButtonBorderStyle 312506 "Return the mouse over button borderStyle for the receiver." 312507 312508 ^self theme scrollbarMouseOverButtonBorderStyleFor: self! ! 312509 312510!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 312511mouseOverButtonFillStyle 312512 "Return the mouse over button fillStyle for the receiver." 312513 312514 ^self theme scrollbarMouseOverButtonFillStyleFor: self! ! 312515 312516!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 312517mouseOverFillStyle 312518 "Return the mouse over fillStyle for the receiver." 312519 312520 ^self theme scrollbarMouseOverFillStyleFor: self! ! 312521 312522!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 312523mouseOverPagingAreaButtonBorderStyle 312524 "Return the button borderStyle for the receiver when the mouse 312525 is over the paging area." 312526 312527 ^self theme scrollbarMouseOverBarButtonBorderStyleFor: self! ! 312528 312529!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 312530mouseOverPagingAreaButtonFillStyle 312531 "Return the button fillStyle for the receiver when the mouse 312532 is over the paging area." 312533 312534 ^self theme scrollbarMouseOverBarButtonFillStyleFor: self! ! 312535 312536!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 312537mouseOverPagingAreaThumbBorderStyle 312538 "Return the thumb borderStyle for the receiver when the mouse 312539 is over the paging area." 312540 312541 ^self theme scrollbarMouseOverBarThumbBorderStyleFor: self! ! 312542 312543!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 312544mouseOverPagingAreaThumbFillStyle 312545 "Return the thumb fillStyle for the receiver when the mouse 312546 is over the paging area." 312547 312548 ^self theme scrollbarMouseOverBarThumbFillStyleFor: self! ! 312549 312550!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 312551mouseOverThumbBorderStyle 312552 "Return the mouse over thumb borderStyle for the receiver." 312553 312554 ^self theme scrollbarMouseOverThumbBorderStyleFor: self! ! 312555 312556!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 312557mouseOverThumbButtonBorderStyle 312558 "Return the button borderStyle for the receiver when the mouse 312559 is over the thumb." 312560 312561 ^self theme scrollbarMouseOverThumbButtonBorderStyleFor: self! ! 312562 312563!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 312564mouseOverThumbButtonFillStyle 312565 "Return the mouse over thumb fillStyle for the receiver." 312566 312567 ^self theme scrollbarMouseOverThumbButtonFillStyleFor: self! ! 312568 312569!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! 312570mouseOverThumbFillStyle 312571 "Return the mouse over thumb fillStyle for the receiver." 312572 312573 ^self theme scrollbarMouseOverThumbFillStyleFor: self! ! 312574 312575!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/4/2007 15:17'! 312576mouseUpInSlider: event 312577 "The mouse button has been released." 312578 312579 Preferences gradientScrollbarLook ifFalse:[^super mouseUpInSlider: event]. 312580 sliderShadow hide. 312581 (slider containsPoint: event position) 312582 ifTrue: [slider 312583 fillStyle: self mouseOverThumbFillStyle; 312584 borderStyle: self mouseOverThumbBorderStyle] 312585 ifFalse: [self mouseLeaveThumb: event]. 312586 slider changed! ! 312587 312588!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:56'! 312589normalBorderStyle 312590 "Return the normal borderStyle for the receiver." 312591 312592 ^self theme scrollbarNormalBorderStyleFor: self! ! 312593 312594!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:56'! 312595normalButtonBorderStyle 312596 "Return the normal button borderStyle for the receiver." 312597 312598 ^self theme scrollbarNormalButtonBorderStyleFor: self! ! 312599 312600!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:56'! 312601normalButtonFillStyle 312602 "Return the normal button fillStyle for the receiver." 312603 312604 ^self theme scrollbarNormalButtonFillStyleFor: self! ! 312605 312606!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:56'! 312607normalFillStyle 312608 "Return the normal fillStyle for the receiver." 312609 312610 ^self theme scrollbarNormalFillStyleFor: self! ! 312611 312612!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:56'! 312613normalThumbBorderStyle 312614 "Return the normal thumb borderStyle for the receiver." 312615 312616 ^self theme scrollbarNormalThumbBorderStyleFor: self! ! 312617 312618!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:56'! 312619normalThumbFillStyle 312620 "Return the normal thumb fillStyle for the receiver." 312621 312622 ^self theme scrollbarNormalThumbFillStyleFor: self! ! 312623 312624!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:56'! 312625pressedBorderStyle 312626 "Return the pressed borderStyle for the receiver." 312627 312628 ^self theme scrollbarPressedBorderStyleFor: self! ! 312629 312630!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:56'! 312631pressedButtonBorderStyle 312632 "Return the pressed button borderStyle for the receiver." 312633 312634 ^self theme scrollbarPressedButtonBorderStyleFor: self! ! 312635 312636!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:56'! 312637pressedButtonFillStyle 312638 "Return the pressed button fillStyle for the receiver." 312639 312640 ^self theme scrollbarPressedButtonFillStyleFor: self! ! 312641 312642!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:56'! 312643pressedFillStyle 312644 "Return the pressed fillStyle for the receiver." 312645 312646 ^self theme scrollbarPressedFillStyleFor: self! ! 312647 312648!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:56'! 312649pressedThumbBorderStyle 312650 "Return the pressed thumb borderStyle for the receiver." 312651 312652 ^self theme scrollbarPressedThumbBorderStyleFor: self! ! 312653 312654!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:56'! 312655pressedThumbFillStyle 312656 "Return the pressed thumb fillStyle for the receiver." 312657 312658 ^self theme scrollbarPressedThumbFillStyleFor: self! ! 312659 312660!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/6/2006 12:32'! 312661scrollAbsolute: event 312662 "Just don't if it is not the red button and we are drawing gradients." 312663 312664 Preferences gradientScrollbarLook ifFalse:[^super scrollAbsolute: event]. 312665 event redButtonPressed ifFalse: [^self]. 312666 ^super scrollAbsolute: event! ! 312667 312668!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 14:14'! 312669setValueSelector: aSymbol 312670 "Directly set the selector to make more flexible." 312671 312672 setValueSelector := aSymbol! ! 312673 312674!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/26/2008 18:15'! 312675slider 312676 "Answer the slider." 312677 312678 ^slider! ! 312679 312680!ScrollBar methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/24/2007 15:18'! 312681themeChanged 312682 "Update the rounding of buttons, slider and paging area." 312683 312684 pagingArea cornerStyle: (self theme scrollbarPagingAreaCornerStyleIn: self window). 312685 slider cornerStyle: (self theme scrollbarThumbCornerStyleIn: self window). 312686 upButton cornerStyle: (self theme scrollbarButtonCornerStyleIn: self window). 312687 downButton cornerStyle: (self theme scrollbarButtonCornerStyleIn: self window). 312688 super themeChanged! ! 312689 312690 312691!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/23/2007 15:23'! 312692finishedScrolling 312693 "Scrolling has finished (button or paging area)." 312694 312695 |bcu bcd| 312696 bcu := upButton borderStyle baseColor. 312697 bcd := downButton borderStyle baseColor. 312698 self stopStepping. 312699 self scrollBarAction: nil. 312700 self roundedScrollbarLook 312701 ifTrue:[upButton borderStyle: 312702 (BorderStyle complexRaised width: upButton borderWidth; baseColor: bcu). 312703 downButton borderStyle: 312704 (BorderStyle complexRaised width: downButton borderWidth; baseColor: bcd)] 312705 ifFalse:[upButton borderRaised. 312706 upButton borderStyle baseColor: bcu. 312707 downButton borderRaised. 312708 downButton borderStyle baseColor: bcd]. 312709 Preferences gradientScrollbarLook ifFalse: [^self]. 312710 pagingArea 312711 fillStyle: self normalFillStyle; 312712 borderStyle: self normalBorderStyle! ! 312713 312714!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/4/2007 16:12'! 312715finishedScrolling: event 312716 "Scrolling has finished for a button." 312717 312718 self finishedScrolling. 312719 (self containsPoint: event position) 312720 ifTrue: [pagingArea 312721 fillStyle: self mouseOverFillStyle; 312722 borderStyle: self mouseOverBorderStyle] 312723 ifFalse: [pagingArea 312724 fillStyle: self normalFillStyle; 312725 borderStyle: self normalBorderStyle]. 312726 (upButton containsPoint: event position) 312727 ifTrue: [upButton 312728 fillStyle: self mouseOverButtonFillStyle; 312729 borderStyle: self mouseOverButtonBorderStyle] 312730 ifFalse: [(self containsPoint: event position) 312731 ifTrue: [upButton 312732 fillStyle: self mouseOverPagingAreaButtonFillStyle; 312733 borderStyle: self mouseOverPagingAreaButtonBorderStyle] 312734 ifFalse: [upButton 312735 fillStyle: self normalButtonFillStyle; 312736 borderStyle: self normalButtonBorderStyle]]. 312737 (downButton containsPoint: event position) 312738 ifTrue: [downButton 312739 fillStyle: self mouseOverButtonFillStyle; 312740 borderStyle: self mouseOverButtonBorderStyle] 312741 ifFalse: [(self containsPoint: event position) 312742 ifTrue: [downButton 312743 fillStyle: self mouseOverPagingAreaButtonFillStyle; 312744 borderStyle: self mouseOverPagingAreaButtonBorderStyle] 312745 ifFalse: [downButton 312746 fillStyle: self normalButtonFillStyle; 312747 borderStyle: self normalButtonBorderStyle]]! ! 312748 312749!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/24/2007 15:15'! 312750initializeDownButton 312751 "initialize the receiver's downButton" 312752 312753 downButton := RectangleMorph 312754 newBounds: (self innerBounds bottomRight - self buttonExtent 312755 extent: self buttonExtent) 312756 color: self thumbColor. 312757 downButton 312758 on: #mouseDown 312759 send: #scrollDownInit 312760 to: self. 312761 downButton 312762 on: #mouseUp 312763 send: #finishedScrolling 312764 to: self. 312765 self updateDownButtonImage. 312766 self roundedScrollbarLook 312767 ifTrue: 312768 [downButton color: Color veryLightGray. 312769 downButton borderStyle: (BorderStyle complexRaised width: 3)] 312770 ifFalse: [downButton setBorderWidth: 1 borderColor: Color lightGray]. 312771 312772 Preferences gradientScrollbarLook ifFalse:[^self addMorph: downButton]. 312773 downButton cornerStyle: (self theme scrollbarButtonCornerStyleIn: self window). 312774 downButton on: #mouseUp send: #finishedScrolling: to: self. 312775 downButton on: #mouseEnter send: #mouseEnterDownButton: to: self. 312776 downButton on: #mouseLeave send: #mouseLeaveDownButton: to: self. 312777 self addMorph: downButton! ! 312778 312779!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 12/1/2008 11:32'! 312780initializeMenuButton 312781"initialize the receiver's menuButton" 312782 "Preferences disable: #scrollBarsWithoutMenuButton" 312783 "Preferences enable: #scrollBarsWithoutMenuButton" 312784 (Preferences valueOfFlag: #scrollBarsWithoutMenuButton) 312785 ifTrue: [menuButton := nil. ^self]. 312786 menuButton := self roundedScrollbarLook 312787 ifTrue: [RectangleMorph 312788 newBounds: ((bounds isWide 312789 ifTrue: [upButton bounds topRight] 312790 ifFalse: [upButton bounds bottomLeft]) 312791 extent: self buttonExtent)] 312792 ifFalse: [RectangleMorph 312793 newBounds: (self innerBounds topLeft extent: self buttonExtent) 312794 color: self thumbColor]. 312795 menuButton 312796 on: #mouseEnter 312797 send: #menuButtonMouseEnter: 312798 to: self. 312799 menuButton 312800 on: #mouseDown 312801 send: #menuButtonMouseDown: 312802 to: self. 312803 menuButton 312804 on: #mouseLeave 312805 send: #menuButtonMouseLeave: 312806 to: self. 312807 "menuButton 312808 addMorphCentered: (RectangleMorph 312809 newBounds: (0 @ 0 extent: 4 @ 2) 312810 color: Color black)." 312811 self updateMenuButtonImage. 312812 self roundedScrollbarLook 312813 ifTrue: [menuButton color: Color veryLightGray. 312814 menuButton 312815 borderStyle: (BorderStyle complexRaised width: 3)] 312816 ifFalse: [menuButton setBorderWidth: 1 borderColor: Color lightGray]. 312817 self addMorph: menuButton! ! 312818 312819!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/24/2007 15:07'! 312820initializePagingArea 312821 "Initialize the receiver's pagingArea." 312822 312823 pagingArea := RectangleMorph 312824 newBounds: self totalSliderArea 312825 color: (Color 312826 r: 0.6 312827 g: 0.6 312828 b: 0.8). 312829 pagingArea borderWidth: 0. 312830 pagingArea 312831 on: #mouseDown 312832 send: #scrollPageInit: 312833 to: self. 312834 pagingArea 312835 on: #mouseUp 312836 send: #finishedScrolling 312837 to: self. 312838 self addMorph: pagingArea. 312839 self roundedScrollbarLook 312840 ifTrue: [pagingArea 312841 color: (Color gray: 0.9)]. 312842 Preferences gradientScrollbarLook ifFalse:[^self]. 312843 pagingArea cornerStyle: (self theme scrollbarPagingAreaCornerStyleIn: self window). 312844 pagingArea on: #mouseUp send: #finishedScrolling: to: self. 312845 self on: #mouseEnter send: #mouseEnterPagingArea: to: self. 312846 self on: #mouseLeave send: #mouseLeavePagingArea: to: self! ! 312847 312848!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/24/2007 15:07'! 312849initializeSlider 312850 "Initialize the receiver's slider." 312851 312852 self roundedScrollbarLook 312853 ifTrue: [self initializeUpButton; initializeMenuButton; initializeDownButton; initializePagingArea] 312854 ifFalse: [self initializeMenuButton; initializeUpButton; initializeDownButton; initializePagingArea]. 312855 super initializeSlider. 312856 self roundedScrollbarLook 312857 ifTrue: [slider cornerStyle: #rounded. 312858 slider 312859 borderStyle: (BorderStyle complexRaised width: 3). 312860 sliderShadow cornerStyle: #rounded]. 312861 self sliderColor: self sliderColor. 312862 Preferences gradientScrollbarLook ifFalse: [^self]. 312863 slider cornerStyle: (self theme scrollbarThumbCornerStyleIn: self window). 312864 slider on: #mouseEnter send: #mouseEnterThumb: to: self. 312865 slider on: #mouseLeave send: #mouseLeaveThumb: to: self! ! 312866 312867!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/24/2007 15:15'! 312868initializeUpButton 312869"initialize the receiver's upButton" 312870 upButton := self roundedScrollbarLook 312871 ifTrue: [RectangleMorph 312872 newBounds: (self innerBounds topLeft extent: self buttonExtent)] 312873 ifFalse: [RectangleMorph 312874 newBounds: ((menuButton 312875 ifNil: [self innerBounds topLeft] 312876 ifNotNil: [bounds isWide 312877 ifTrue: [menuButton bounds topRight] 312878 ifFalse: [menuButton bounds bottomLeft]]) 312879 extent: self buttonExtent)]. 312880 upButton color: self thumbColor. 312881 upButton 312882 on: #mouseDown 312883 send: #scrollUpInit 312884 to: self. 312885 upButton 312886 on: #mouseUp 312887 send: #finishedScrolling 312888 to: self. 312889 self updateUpButtonImage. 312890 self roundedScrollbarLook 312891 ifTrue: [upButton color: Color veryLightGray. 312892 upButton 312893 borderStyle: (BorderStyle complexRaised width: 3)] 312894 ifFalse: [upButton setBorderWidth: 1 borderColor: Color lightGray]. 312895 312896 Preferences gradientScrollbarLook ifFalse: [^self addMorph: upButton]. 312897 upButton cornerStyle: (self theme scrollbarButtonCornerStyleIn: self window). 312898 upButton on: #mouseUp send: #finishedScrolling: to: self. 312899 upButton on: #mouseEnter send: #mouseEnterUpButton: to: self. 312900 upButton on: #mouseLeave send: #mouseLeaveUpButton: to: self. 312901 self addMorph: upButton! ! 312902 312903!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/26/2008 19:13'! 312904interval: d 312905 "Supply an optional floating fraction so slider can expand to indicate range. 312906 Update the fill style for the tumb (may have extent-based elements)." 312907 312908 |oldExtent| 312909 oldExtent := slider extent. 312910 interval := d min: 1.0. 312911 self expandSlider. 312912 self computeSlider. 312913 slider extent = oldExtent 312914 ifFalse: [slider fillStyle: self normalThumbFillStyle]! ! 312915 312916!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/30/2007 11:22'! 312917menuButtonMouseDown: event 312918 "The menu button has been clicked." 312919 312920 event hand showTemporaryCursor: nil. 312921 self use: menuSelector orMakeModelSelectorFor: 'MenuButtonPressed:' 312922 in: [:sel | menuSelector := sel. model perform: sel with: event]. 312923 Preferences gradientScrollbarLook ifFalse: [^self]. 312924 self menuButtonMouseLeave: event! ! 312925 312926!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/22/2008 21:18'! 312927mouseDownInSlider: event 312928 "The mouse has been pressed in the slider area." 312929 312930 interval = 1.0 ifTrue: 312931 ["make the entire scrollable area visible if a full scrollbar is clicked on" 312932 self setValue: 0. 312933 self model hideOrShowScrollBar]. 312934 Preferences gradientScrollbarLook ifFalse:[^super mouseDownInSlider: event]. 312935 event redButtonPressed ifFalse: [^self]. 312936 slider fillStyle: self pressedThumbFillStyle. 312937 slider borderStyle: self pressedThumbBorderStyle. 312938 self theme useScrollbarThumbShadow ifTrue: [ 312939 sliderShadow 312940 color: self sliderShadowColor; 312941 cornerStyle: slider cornerStyle; 312942 bounds: slider bounds; 312943 show]! ! 312944 312945!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 11/23/2007 18:30'! 312946scrollDownInit 312947 "Initialize a scroll down (from button) operation. 312948 Fixed to perform immediately with deferred 312949 stepping for subsequent hold of button." 312950 312951 |bc| 312952 bc := downButton borderStyle baseColor. 312953 downButton borderInset. 312954 downButton borderStyle baseColor: bc. 312955 self resetTimer. 312956 self scrollBarAction: #doScrollDown. 312957 self doScrollDown. 312958 self 312959 startStepping: #stepAt: 312960 at: Time millisecondClockValue + self stepTime 312961 arguments: nil stepTime: nil. 312962 Preferences gradientScrollbarLook ifFalse: [^self]. 312963 downButton fillStyle: self pressedButtonFillStyle. 312964 downButton borderStyle: self pressedButtonBorderStyle! ! 312965 312966!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 11/22/2007 18:26'! 312967scrollPageInit: evt 312968 "Scroll initiated by the paging area." 312969 312970 self resetTimer. 312971 self setNextDirectionFromEvent: evt. 312972 self scrollBarAction: #doScrollByPage. 312973 self doScrollByPage. "do the first one now since morph stepping is rather variable in its timing 312974 and the user may release before actually actioned...." 312975 Preferences gradientScrollbarLook ifFalse: [ 312976 ^self startStepping: #stepAt: at: Time millisecondClockValue + self stepTime arguments: nil stepTime: nil]. 312977 pagingArea 312978 fillStyle: self pressedFillStyle; 312979 borderStyle: self pressedBorderStyle. 312980 self startStepping: #stepAt: at: Time millisecondClockValue + self stepTime arguments: nil stepTime: nil! ! 312981 312982!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 11/23/2007 18:30'! 312983scrollUpInit 312984 "Initialize a scroll up (from button) operation. 312985 Fixed to perform immediately with deferred 312986 stepping for subsequent hold of button." 312987 312988 |bc| 312989 bc := upButton borderStyle baseColor. 312990 upButton borderInset. 312991 upButton borderStyle baseColor: bc. 312992 self resetTimer. 312993 self scrollBarAction: #doScrollUp. 312994 self doScrollUp. 312995 self 312996 startStepping: #stepAt: 312997 at: Time millisecondClockValue + self stepTime 312998 arguments: nil stepTime: nil. 312999 Preferences gradientScrollbarLook ifFalse: [^self]. 313000 upButton fillStyle: self pressedButtonFillStyle. 313001 upButton borderStyle: self pressedButtonBorderStyle! ! 313002 313003!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/7/2006 11:59'! 313004setValue: newValue 313005 "Using roundTo: instead of truncateTo: ensures that scrollUp will scroll the same distance as scrollDown. 313006 Fix for >= 1.0 since, when close the roundTo may round down and not allow the value to reach 313007 the full range." 313008 313009 newValue >= 1.0 313010 ifTrue: [^super setValue: 1.0]. 313011 ^ super setValue: (newValue roundTo: scrollDelta)! ! 313012 313013!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/5/2009 12:26'! 313014sliderColor: aColor 313015 "Change the color of the scrollbar to go with aColor." 313016 | buttonColor | 313017 super sliderColor: aColor. 313018 self setProperty: #lastPaneColor toValue: aColor. 313019 buttonColor := self thumbColor. 313020 menuButton 313021 ifNotNil: [menuButton color: buttonColor]. 313022 upButton color: buttonColor. 313023 downButton color: buttonColor. 313024 slider color: buttonColor slightlyLighter. 313025 313026 Preferences gradientScrollbarLook ifFalse: [ 313027 self class updateScrollBarButtonsAspect: {menuButton. upButton. downButton} color: buttonColor. 313028 self updateMenuButtonImage. 313029 self updateUpButtonImage. 313030 self updateDownButtonImage]. 313031 313032 pagingArea 313033 fillStyle: self normalFillStyle; 313034 borderStyle: self normalBorderStyle. 313035 (self theme scrollbarPagingAreaCornerStyleIn: self window) = #rounded 313036 ifTrue: [self fillStyle: self normalButtonFillStyle] 313037 ifFalse: [self fillStyle: self normalFillStyle]. 313038 self borderWidth: 0. 313039 Preferences gradientScrollbarLook ifTrue: [^self adoptGradientColor: aColor]! ! 313040 313041!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/7/2008 11:46'! 313042sliderThickness 313043 "Answer the minimum width/height of the scrollbar thumb. Refer to the theme." 313044 313045 ^self theme scrollbarMinimumThumbThickness! ! 313046 313047!ScrollBar methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/26/2007 14:06'! 313048thumbColor 313049 "Problem: Part of the ScrollBar/Slider code uses 'slider' to mean the entire scrollbar/slider widget, and part of it uses 'slider' to mean only the draggable 'thumb'. This should be cleaned up so that 'thumb' is used instead of 'slider' where appropriate. For now, the meaning of thumbColor is clear, at least." 313050 313051 ^self class imageColorFor: self! ! 313052 313053 313054!ScrollBar methodsFor: 'access' stamp: 'md 2/24/2006 16:27'! 313055adoptPaneColor: aColor 313056 "Adopt the given pane color" 313057 aColor ifNil:[^self]. 313058 self sliderColor: aColor.! ! 313059 313060!ScrollBar methodsFor: 'access' stamp: 'dew 2/15/1999 18:25'! 313061pagingArea 313062 ^pagingArea! ! 313063 313064!ScrollBar methodsFor: 'access' stamp: 'md 2/24/2006 21:26'! 313065roundedScrollbarLook 313066 "Rounded look currently only shows up in flop-out mode" 313067 ^false and: [ 313068 self class alwaysShowFlatScrollbarForAlternativeLook not] 313069! ! 313070 313071!ScrollBar methodsFor: 'access'! 313072scrollDelta 313073 ^ scrollDelta! ! 313074 313075!ScrollBar methodsFor: 'access'! 313076scrollDelta: d1 pageDelta: d2 313077 "Supply optional increments for better scrolling of, eg, text" 313078 scrollDelta := d1. 313079 pageDelta := d2.! ! 313080 313081!ScrollBar methodsFor: 'access' stamp: 'dew 3/4/2002 01:17'! 313082sliderShadowColor 313083 ^ self roundedScrollbarLook 313084 ifTrue: [self sliderColor darker] 313085 ifFalse: [super sliderShadowColor] 313086! ! 313087 313088 313089!ScrollBar methodsFor: 'geometry' stamp: 'dew 7/16/2004 19:33'! 313090buttonExtent 313091 | size | 313092 size := Preferences scrollBarsNarrow 313093 ifTrue: [11] 313094 ifFalse: [15]. 313095 ^ bounds isWide 313096 ifTrue: [size @ self innerBounds height] 313097 ifFalse: [self innerBounds width @ size]! ! 313098 313099!ScrollBar methodsFor: 'geometry' stamp: 'dew 2/27/1999 18:22'! 313100expandSlider 313101 "Compute the new size of the slider (use the old sliderThickness as a minimum)." 313102 | r | 313103 r := self totalSliderArea. 313104 slider extent: (bounds isWide 313105 ifTrue: [((r width * interval) asInteger max: self sliderThickness) @ slider height] 313106 ifFalse: [slider width @ ((r height * interval) asInteger max: self sliderThickness)])! ! 313107 313108!ScrollBar methodsFor: 'geometry' stamp: 'dgd 3/26/2003 09:13'! 313109extent: p 313110 p x > p y 313111 ifTrue: [super 313112 extent: (p max: 42 @ 8)] 313113 ifFalse: [super 313114 extent: (p max: 8 @ 42)]. 313115 ! ! 313116 313117!ScrollBar methodsFor: 'geometry' stamp: 'dew 2/21/1999 03:08'! 313118sliderExtent 313119 "The sliderExtent is now stored in the slider itself, not hardcoded as it is in the superclass." 313120 ^slider extent! ! 313121 313122!ScrollBar methodsFor: 'geometry' stamp: 'hpt 4/3/2003 19:18'! 313123totalSliderArea 313124 | upperBoundsButton | 313125 upperBoundsButton := menuButton ifNil: [upButton]. 313126 bounds isWide 313127 ifTrue: [ 313128 upButton right > upperBoundsButton right 313129 ifTrue: [upperBoundsButton := upButton]. 313130 ^upperBoundsButton bounds topRight corner: downButton bounds bottomLeft] 313131 ifFalse:[ 313132 upButton bottom > upperBoundsButton bottom 313133 ifTrue: [upperBoundsButton := upButton]. 313134 ^upperBoundsButton bounds bottomLeft corner: downButton bounds topRight]. 313135! ! 313136 313137 313138!ScrollBar methodsFor: 'initialize' stamp: 'dgd 3/28/2003 19:13'! 313139downImage 313140 "answer a form to be used in the down button" 313141 ^ self class 313142 arrowOfDirection: (bounds isWide 313143 ifTrue: [#right] 313144 ifFalse: [#bottom]) 313145 size: (self buttonExtent x min: self buttonExtent y) 313146 color: self thumbColor! ! 313147 313148!ScrollBar methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 10:20'! 313149initialize 313150 super initialize. 313151 scrollDelta := 0.02. 313152 pageDelta := 0.2. 313153 self roundedScrollbarLook ifTrue:[ 313154 self borderStyle: ((BorderStyle complexFramed width: 2) "baseColor: Color gray")].! ! 313155 313156!ScrollBar methodsFor: 'initialize' stamp: 'dew 3/4/2002 01:13'! 313157initializeEmbedded: aBool 313158 "aBool == true => inboard scrollbar 313159 aBool == false => flop-out scrollbar" 313160 self roundedScrollbarLook ifFalse:[^self]. 313161 aBool ifTrue:[ 313162 self borderStyle: (BorderStyle inset width: 2). 313163 self cornerStyle: #square. 313164 ] ifFalse:[ 313165 self borderStyle: (BorderStyle width: 1 color: Color black). 313166 self cornerStyle: #rounded. 313167 ]. 313168 self removeAllMorphs. 313169 self initializeSlider.! ! 313170 313171!ScrollBar methodsFor: 'initialize' stamp: 'dgd 3/28/2003 19:13'! 313172menuImage 313173 "answer a form to be used in the menu button" 313174 ^ self class 313175 boxOfSize: (self buttonExtent x min: self buttonExtent y) 313176 color: self thumbColor! ! 313177 313178!ScrollBar methodsFor: 'initialize' stamp: 'RAA 7/28/2000 10:12'! 313179upArrow8Bit 313180 313181 "convert to 8-bit and convert white to transparent to avoid gratuitous conversion every time we put one in an ImageMorph" 313182 313183 ^UpArrow8Bit ifNil: [ 313184 UpArrow8Bit := (ColorForm mappingWhiteToTransparentFrom: UpArrow) asFormOfDepth: 8 313185 ]! ! 313186 313187!ScrollBar methodsFor: 'initialize' stamp: 'dgd 3/28/2003 19:13'! 313188upImage 313189 "answer a form to be used in the up button" 313190 ^ self class 313191 arrowOfDirection: (bounds isWide 313192 ifTrue: [#left] 313193 ifFalse: [#top]) 313194 size: (self buttonExtent x min: self buttonExtent y) 313195 color: self thumbColor! ! 313196 313197!ScrollBar methodsFor: 'initialize' stamp: 'dgd 3/28/2003 10:24'! 313198updateDownButtonImage 313199 "update the receiver's downButton. put a new image inside" 313200 downButton removeAllMorphs. 313201 downButton 313202 addMorphCentered: (ImageMorph new image: self downImage)! ! 313203 313204!ScrollBar methodsFor: 'initialize' stamp: 'sd 11/8/2003 16:01'! 313205updateMenuButtonImage 313206 "update the receiver's menuButton. put a new image inside" 313207menuButton isNil ifTrue:[^ self]. 313208 313209 menuButton removeAllMorphs. 313210 menuButton 313211 addMorphCentered: (ImageMorph new image: self menuImage)! ! 313212 313213!ScrollBar methodsFor: 'initialize' stamp: 'dgd 3/28/2003 19:13'! 313214updateUpButtonImage 313215"update the receiver's upButton. put a new image inside" 313216 upButton removeAllMorphs. 313217 upButton 313218 addMorphCentered: (ImageMorph new image: self upImage)! ! 313219 313220 313221!ScrollBar methodsFor: 'scroll timing' stamp: 'di 8/17/1998 09:22'! 313222resetTimer 313223 timeOfMouseDown := Time millisecondClockValue. 313224 timeOfLastScroll := timeOfMouseDown - 1000 max: 0. 313225 nextPageDirection := nil. 313226 currentScrollDelay := nil! ! 313227 313228!ScrollBar methodsFor: 'scroll timing' stamp: 'dgd 2/21/2003 23:05'! 313229waitForDelay1: delay1 delay2: delay2 313230 "Return true if an appropriate delay has passed since the last scroll operation. 313231 The delay decreases exponentially from delay1 to delay2." 313232 313233 | now scrollDelay | 313234 timeOfLastScroll isNil ifTrue: [self resetTimer]. "Only needed for old instances" 313235 now := Time millisecondClockValue. 313236 (scrollDelay := currentScrollDelay) isNil 313237 ifTrue: [scrollDelay := delay1 "initial delay"]. 313238 currentScrollDelay := scrollDelay * 9 // 10 max: delay2. "decrease the delay" 313239 timeOfLastScroll := now. 313240 ^true! ! 313241 313242 313243!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:13'! 313244doScrollByPage 313245 "Scroll automatically while mouse is down" 313246 (self waitForDelay1: 300 delay2: 100) ifFalse: [^ self]. 313247 nextPageDirection 313248 ifTrue: [self setValue: (value + pageDelta min: 1.0)] 313249 ifFalse: [self setValue: (value - pageDelta max: 0.0)] 313250! ! 313251 313252!ScrollBar methodsFor: 'scrolling' stamp: 'di 4/22/2001 18:28'! 313253doScrollDown 313254 "Scroll automatically while mouse is down" 313255 (self waitForDelay1: 200 delay2: 40) ifFalse: [^ self]. 313256 self setValue: (value + scrollDelta + 0.000001 min: 1.0)! ! 313257 313258!ScrollBar methodsFor: 'scrolling' stamp: 'di 4/22/2001 18:28'! 313259doScrollUp 313260 "Scroll automatically while mouse is down" 313261 (self waitForDelay1: 200 delay2: 40) ifFalse: [^ self]. 313262 self setValue: (value - scrollDelta - 0.000001 max: 0.0)! ! 313263 313264!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 14:56'! 313265scrollBarAction 313266 ^self valueOfProperty: #scrollBarAction! ! 313267 313268!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 14:56'! 313269scrollBarAction: aSymbol 313270 self setProperty: #scrollBarAction toValue: aSymbol! ! 313271 313272!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:12'! 313273scrollDown 313274 self flag: #obsolete. 313275 downButton eventHandler: nil. 313276 downButton on: #mouseDown send: #scrollDownInit to: self. 313277 downButton on: #mouseUp send: #finishedScrolling to: self. 313278 ^self scrollDownInit! ! 313279 313280!ScrollBar methodsFor: 'scrolling' stamp: 'bf 4/14/1999 12:03'! 313281scrollDown: count 313282 self setValue: (value + (scrollDelta * count) + 0.000001 min: 1.0)! ! 313283 313284!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:11'! 313285scrollUp 313286 self flag: #obsolete. 313287 upButton eventHandler: nil. 313288 upButton on: #mouseDown send: #scrollUpInit to: self. 313289 upButton on: #mouseUp send: #finishedScrolling to: self. 313290 ^self scrollUpInit! ! 313291 313292!ScrollBar methodsFor: 'scrolling' stamp: 'bf 4/14/1999 12:03'! 313293scrollUp: count 313294 self setValue: (value - (scrollDelta * count) - 0.000001 max: 0.0)! ! 313295 313296!ScrollBar methodsFor: 'scrolling' stamp: 'RAA 12/29/2000 11:56'! 313297setNextDirectionFromEvent: event 313298 313299 nextPageDirection := bounds isWide ifTrue: [ 313300 event cursorPoint x >= slider center x 313301 ] 313302 ifFalse: [ 313303 event cursorPoint y >= slider center y 313304 ] 313305 313306! ! 313307 313308 313309!ScrollBar methodsFor: 'stepping and presenter' stamp: 'ar 10/7/2000 15:02'! 313310step 313311 | action | 313312 action := self scrollBarAction. 313313 action ifNotNil:[self perform: action].! ! 313314 313315 313316!ScrollBar methodsFor: 'testing' stamp: 'di 4/22/2001 18:30'! 313317stepTime 313318 ^ currentScrollDelay ifNil: [300]! ! 313319 313320!ScrollBar methodsFor: 'testing' stamp: 'ar 10/7/2000 15:02'! 313321wantsSteps 313322 ^self scrollBarAction notNil! ! 313323 313324"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 313325 313326ScrollBar class 313327 instanceVariableNames: ''! 313328 313329!ScrollBar class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/11/2007 16:04'! 313330basicCreateArrowOfDirection: aSymbolDirection size: finalSizeInteger color: aColor 313331 "PRIVATE - create an arrow with aSymbolDirectionDirection, 313332 finalSizeInteger and aColor. 313333 aSymbolDirectionDirection = #top, #bottom. #left or #right . 313334 Try with: 313335 (ScrollBar createNewArrowOfDirection: #top size: 32 color: Color 313336 lightGreen) asMorph openInHand. 313337 Fixed to work with translucent colours." 313338 313339 |form resizeFactor arrow resizedForm | 313340 resizeFactor := 4. 313341 form := Form 313342 extent: finalSizeInteger asPoint * resizeFactor 313343 depth: Display depth. 313344 form fillColor: Color transparent. 313345 arrow := (self createArrowOfDirection: aSymbolDirection in: form boundingBox) 313346 borderWidth: 1; 313347 borderColor: aColor lighter. 313348 self 313349 updateScrollBarButtonAspect: arrow 313350 color: (aColor alphaMixed: 0.7 with: Color black). 313351 arrow fullDrawOn: form getCanvas. 313352 resizedForm := form 313353 magnify: form boundingBox 313354 by: 1 / resizeFactor 313355 smoothing: 4. 313356 ^resizedForm trimBordersOfColor: Color transparent! ! 313357 313358!ScrollBar class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:57'! 313359imageColorFor: aScrollbar 313360 "Return the (button) image colour for the given scrollbar." 313361 313362 ^UITheme current scrollbarImageColorFor: aScrollbar! ! 313363 313364 313365!ScrollBar class methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/30/2006 09:43'! 313366createArrowOfDirection: aSymbol in: aRectangle 313367 "PRIVATE - create an arrow bounded in aRectangle" 313368 313369 | arrow vertices | 313370 vertices := Preferences alternativeButtonsInScrollBars 313371 ifTrue: [self verticesForComplexArrow: aRectangle] 313372 ifFalse: [self verticesForSimpleArrow: aRectangle]. 313373 "" 313374 arrow := PolygonMorph 313375 vertices: vertices 313376 color: Color transparent 313377 borderWidth: 0 313378 borderColor: Color black. 313379 "" 313380 arrow bounds: (arrow bounds insetBy: (aRectangle width / 6) rounded). 313381 "" 313382 aSymbol == #right 313383 ifTrue: [arrow rotationDegrees: arrow rotationDegrees + 90]. 313384 aSymbol == #bottom 313385 ifTrue: [arrow rotationDegrees: arrow rotationDegrees + 180]. 313386 aSymbol == #left 313387 ifTrue: [arrow rotationDegrees: arrow rotationDegrees + 270]. 313388 "" 313389 ^arrow! ! 313390 313391!ScrollBar class methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/2/2008 14:06'! 313392createArrowOfDirection: aSymbolDirection size: finalSizeInteger color: aColor 313393 "Defer to current UITheme if available." 313394 313395 ^UITheme current 313396 scrollbarArrowOfDirection: aSymbolDirection 313397 size: finalSizeInteger 313398 color: aColor! ! 313399 313400!ScrollBar class methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/30/2006 10:05'! 313401verticesForComplexArrow: aRectangle 313402 "PRIVATE - answer a collection of vertices to draw a complex arrow" 313403 313404 |r vertices aux b c| 313405 r := aRectangle origin extent: aRectangle width asPoint. 313406 aux := (r width / 5) rounded. 313407 b := (aux * aux * 2) sqrt. 313408 c := (b * b * 2) sqrt rounded. 313409 vertices := OrderedCollection new. 313410 vertices add: r bottomLeft - (0 @ aux). 313411 vertices add: r topCenter + (0 @ aux). 313412 vertices add: r bottomRight - (0 @ aux). 313413 vertices add: r bottomRight - (aux @ 0). 313414 vertices add: r topCenter + (0 @ (aux + c)). 313415 vertices add: r bottomLeft + (aux @ 0). 313416 ^vertices! ! 313417 313418!ScrollBar class methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/26/2007 13:53'! 313419verticesForSimpleArrow: aRectangle 313420 "PRIVATE - answer a collection of vertices to draw a simple arrow" 313421 | vertices | 313422 vertices := OrderedCollection new. 313423 "" 313424 vertices add: aRectangle bottomLeft. 313425 vertices add: aRectangle center x @ (aRectangle top + (aRectangle width / 8)). 313426 vertices add: aRectangle bottomRight. 313427 vertices add: aRectangle bottomRight + (0@0.01). 313428 "" 313429 ^ vertices! ! 313430 313431 313432!ScrollBar class methodsFor: 'as yet unclassified' stamp: 'dew 3/23/2002 01:30'! 313433alwaysShowFlatScrollbarForAlternativeLook 313434 "Set this value to true, if you want to see the flat scrollbar look in flop-out mode as well as inboard. Otherwise the flop-out scrollbar will be rounded and inboard will be flat." 313435 ^ false! ! 313436 313437 313438!ScrollBar class methodsFor: 'coloring morphs' stamp: 'dgd 3/28/2003 20:29'! 313439updateScrollBarButtonAspect: aMorph color: aColor 313440 "update aMorph with aColor" 313441 | fill direction | 313442 aMorph isNil 313443 ifTrue: [^ self]. 313444 "" 313445aMorph color: aColor. 313446 Preferences gradientScrollBars 313447 ifFalse: [^ self]. 313448 "" 313449 fill := GradientFillStyle ramp: {0.0 -> aColor twiceLighter twiceLighter. 1.0 -> aColor twiceDarker}. 313450 "" 313451 direction := ((aMorph width min: aMorph height) 313452 + ((aMorph width - aMorph height) abs * 0.3)) rounded. 313453 "" 313454 fill origin: aMorph topLeft + (direction // 8). 313455 fill direction: direction @ direction. 313456 fill radial: true. 313457 "" 313458 aMorph fillStyle: fill! ! 313459 313460!ScrollBar class methodsFor: 'coloring morphs' stamp: 'dgd 3/28/2003 20:29'! 313461updateScrollBarButtonsAspect: aCollection color: aColor 313462 "update aCollection of morphs with aColor" 313463 313464 313465 aCollection 313466 do: [:each | self updateScrollBarButtonAspect: each color: aColor]! ! 313467 313468 313469!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 10:22'! 313470arrowOfDirection: aSymbol size: finalSizeInteger color: aColor 313471 "answer a form with an arrow based on the parameters" 313472 ^ ArrowImagesCache at: {aSymbol. finalSizeInteger. aColor}! ! 313473 313474!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 10:22'! 313475boxOfSize: finalSizeInteger color: aColor 313476 "answer a form with an box based on the parameters" 313477 ^ BoxesImagesCache at: {finalSizeInteger. aColor}! ! 313478 313479!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 20:54'! 313480changesInPreferences 313481 "the related preferences changed" 313482 self initializeImagesCache 313483 " ScrollBar allInstances do: [:each | each removeAllMorphs; initializeSlider] "! ! 313484 313485!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 10:29'! 313486createBoxIn: aRectangle 313487 "PRIVATE - create an box bounded in aRectangle" 313488 | box | 313489 box := RectangleMorph new. 313490 box extent: (aRectangle scaleBy: 1 / 2) extent rounded; 313491 borderWidth: 0. 313492 "" 313493 ^ box! ! 313494 313495!ScrollBar class methodsFor: 'images' stamp: 'dgd 3/28/2003 19:32'! 313496createBoxOfSize: finalSizeInteger color: aColor 313497 "PRIVATE - create a box with finalSizeInteger and aColor 313498 313499 Try with: 313500 (ScrollBar createBoxOfSize: 32 color: Color lightGreen) asMorph 313501 openInHand. 313502 " 313503 | resizeFactor outerBox innerBox resizedForm | 313504 resizeFactor := 4. 313505 outerBox := RectangleMorph new. 313506 outerBox extent: finalSizeInteger asPoint * resizeFactor; 313507 borderWidth: 0; 313508 color: aColor. 313509 "" 313510 innerBox := self createBoxIn: outerBox bounds. 313511 self updateScrollBarButtonAspect: innerBox color: aColor muchDarker. 313512 outerBox addMorphCentered: innerBox. 313513 "" 313514 resizedForm := outerBox imageForm 313515 magnify: outerBox imageForm boundingBox 313516 by: 1 / resizeFactor 313517 smoothing: 4. 313518 "" 313519 ^ (resizedForm replaceColor: aColor withColor: Color transparent) 313520 trimBordersOfColor: Color transparent! ! 313521 313522 313523!ScrollBar class methodsFor: 'images - samples' stamp: 'sd 11/8/2003 16:02'! 313524arrowSamples 313525 "create a set of arrow with different sizes, colors and directions" 313526 " 313527 ScrollBar arrowSamples. 313528 " 313529 | column | 313530 column := AlignmentMorph newColumn vResizing: #shrinkWrap; 313531 hResizing: #shrinkWrap; 313532 layoutInset: 1; 313533 borderColor: Color black; 313534 borderWidth: 0; 313535 wrapCentering: #center; 313536 cellPositioning: #center; 313537 color: Color white; 313538 yourself. 313539 313540 self sampleSizes 313541 do: [:size | 313542 | row | 313543 row := AlignmentMorph newRow color: Color transparent; 313544 vResizing: #shrinkWrap; 313545 cellInset: 2 @ 0 yourself. 313546 313547 self sampleColors 313548 do: [:color | 313549 #(#top #right #bottom #left ) 313550 do: [:direction | 313551 row addMorphBack: (ScrollBar 313552 arrowOfDirection: direction 313553 size: size 313554 color: color) asMorph]]. 313555 313556 column addMorphBack: row]. 313557 313558 column openInHand! ! 313559 313560!ScrollBar class methodsFor: 'images - samples' stamp: 'dgd 3/28/2003 10:18'! 313561boxSamples 313562 "create a set of box with different sizes and colors" 313563 " 313564 ScrollBar boxSamples. 313565 " 313566 | column | 313567 column := AlignmentMorph newColumn vResizing: #shrinkWrap; 313568 hResizing: #shrinkWrap; 313569 layoutInset: 1; 313570 borderColor: Color black; 313571 borderWidth: 0; 313572 wrapCentering: #center; 313573 cellPositioning: #center; 313574 color: Color white; 313575 yourself. 313576 "" 313577 self sampleSizes 313578 do: [:size | 313579 | row | 313580 row := AlignmentMorph newRow color: Color transparent; 313581 vResizing: #shrinkWrap; 313582 cellInset: 2 @ 0 yourself. 313583 "" 313584 self sampleColors 313585 do: [:color | 313586 row addMorphBack: (ScrollBar boxOfSize: size color: color) asMorph]. 313587 "" 313588 column addMorphBack: row]. 313589 "" 313590 "" 313591 column openInHand! ! 313592 313593!ScrollBar class methodsFor: 'images - samples' stamp: 'dgd 3/28/2003 10:18'! 313594sampleColors 313595 "private" 313596 ^ (Color lightCyan wheel: 5)! ! 313597 313598!ScrollBar class methodsFor: 'images - samples' stamp: 'dgd 3/28/2003 10:17'! 313599sampleSizes 313600 313601"private" 313602 ^ #(10 12 14 16 18 32 64 )! ! 313603 313604 313605!ScrollBar class methodsFor: 'initialization' stamp: 'dgd 3/28/2003 10:13'! 313606createArrowImagesCache 313607 "creates the cache to store the arrow forms" 313608 ^ LRUCache 313609 size: 40 313610 factory: [:key | "" 313611 self 313612 createArrowOfDirection: key first 313613 size: key second 313614 color: key third]! ! 313615 313616!ScrollBar class methodsFor: 'initialization' stamp: 'dgd 3/28/2003 10:13'! 313617createBoxImagesCache 313618 "creates the cache to store the arrow forms" 313619 ^ LRUCache 313620 size: 20 313621 factory: [:key | self createBoxOfSize: key first color: key second]! ! 313622 313623!ScrollBar class methodsFor: 'initialization' stamp: 'dgd 3/27/2003 10:05'! 313624initialize 313625 "ScrollBar initialize" 313626 UpArrow := Form 313627 extent: 6 @ 3 313628 fromArray: #(805306368 2013265920 4227858432 ) 313629 offset: 0 @ 0. 313630 "" 313631 self initializeImagesCache! ! 313632 313633!ScrollBar class methodsFor: 'initialization' stamp: 'md 3/23/2006 15:55'! 313634initializeImagesCache 313635 "initialize the receiver's ImagesCache. 313636 313637 normally this method is not evaluated more than in the class 313638 initializazion. " 313639 313640 " 313641 ScrollBar initializeImagesCache. 313642 " 313643 313644 ArrowImagesCache := self createArrowImagesCache. 313645 BoxesImagesCache := self createBoxImagesCache! ! 313646MorphicModel subclass: #ScrollPane 313647 instanceVariableNames: 'scrollBar scroller retractableScrollBar scrollBarOnLeft getMenuSelector getMenuTitleSelector hasFocus hScrollBar' 313648 classVariableNames: '' 313649 poolDictionaries: '' 313650 category: 'Morphic-Windows'! 313651!ScrollPane commentStamp: 'mk 8/9/2005 10:34' prior: 0! 313652The scroller (a transform) of a scrollPane is driven by the scrollBar. The scroll values vary from 0.0, meaning zero offset to 1.0 meaning sufficient offset such that the bottom of the scrollable material appears 3/4 of the way down the pane. The total distance to achieve this range is called the totalScrollRange. 313653 313654Basic clue about utilization of the ScrollPane class is given in: 313655 ScrollPane example1. 313656 ScrollPane example2.! 313657 313658 313659!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/26/2006 15:30'! 313660getMenuSelector: aSymbol 313661 "Set the menu selector." 313662 313663 getMenuSelector := aSymbol! ! 313664 313665!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/26/2006 15:30'! 313666getMenuTitleSelector: aSymbol 313667 "Set the menu titleselector." 313668 313669 getMenuTitleSelector := aSymbol! ! 313670 313671!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/24/2006 12:00'! 313672hScrollValue: scrollValue 313673 "Set the horizontal scroll value via the scrollbar itself." 313674 313675 hScrollBar setValue: scrollValue! ! 313676 313677!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/28/2008 16:04'! 313678handlesMouseWheel: evt 313679 "Do I want to receive mouseWheel events?." 313680 313681 ^true! ! 313682 313683!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/15/2007 11:18'! 313684minHeight 313685 "Answer the minimum height." 313686 313687 |noVPlease noHPlease minH| 313688 noVPlease := self valueOfProperty: #noVScrollBarPlease ifAbsent: [false]. 313689 noHPlease := self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]. 313690 noVPlease 313691 ifTrue: [noHPlease 313692 ifTrue: [minH := 1] 313693 ifFalse:[minH := self scrollBarThickness]] 313694 ifFalse: [noHPlease 313695 ifTrue:[minH := self scrollBarThickness * 3] 313696 ifFalse: [minH := self scrollBarThickness * 4 + 2]]. 313697 ^minH max: super minHeight! ! 313698 313699!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/15/2007 11:14'! 313700minWidth 313701 "Answer the minimum width." 313702 313703 |noVPlease noHPlease minW| 313704 noVPlease := self valueOfProperty: #noVScrollBarPlease ifAbsent: [false]. 313705 noHPlease := self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]. 313706 minW := noVPlease 313707 ifTrue: [noHPlease 313708 ifTrue: [1] 313709 ifFalse: [self scrollBarThickness * 3]] 313710 ifFalse: [noHPlease 313711 ifTrue: [self scrollBarThickness + 20] 313712 ifFalse: [self scrollBarThickness * 3 + 2]]. 313713 ^minW max: super minWidth! ! 313714 313715!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/28/2008 16:04'! 313716mouseWheel: event 313717 "Handle a mouseWheel event." 313718 313719 event direction = #up ifTrue: [ 313720 scrollBar scrollUp: 3]. 313721 event direction = #down ifTrue: [ 313722 scrollBar scrollDown: 3]! ! 313723 313724!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/6/2006 10:28'! 313725scrollValue 313726 "Answer the values of the scrollbars as a point." 313727 313728 ^hScrollBar value @ scrollBar value! ! 313729 313730!ScrollPane methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/24/2006 12:00'! 313731vScrollValue: scrollValue 313732 "Set the vertical scroll value via the scrollbar itself." 313733 313734 scrollBar setValue: scrollValue! ! 313735 313736 313737!ScrollPane methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/27/2009 16:44'! 313738adoptPaneColor: paneColor 313739 "Match the pane colour." 313740 313741 super adoptPaneColor: paneColor. 313742 scrollBar adoptPaneColor: paneColor. 313743 hScrollBar adoptPaneColor: paneColor. 313744 paneColor ifNil: [^self]. 313745 self borderWidth > 0 ifTrue: [ 313746 self borderStyle: self borderStyleToUse]! ! 313747 313748!ScrollPane methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/27/2009 11:57'! 313749borderStyle: aBorderStyle 313750 "Optimised when no change." 313751 313752 self borderStyle = aBorderStyle ifTrue: [^self]. 313753 super borderStyle: aBorderStyle. 313754 self setScrollDeltas! ! 313755 313756!ScrollPane methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/27/2009 16:43'! 313757borderStyleToUse 313758 "Answer the borderStyle that should be used for the receiver." 313759 313760 ^self enabled 313761 ifTrue: [self theme scrollPaneNormalBorderStyleFor: self] 313762 ifFalse: [self theme scrollPaneDisabledBorderStyleFor: self]! ! 313763 313764!ScrollPane methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/30/2006 09:20'! 313765hideOrShowScrollBar 313766 "Hide or show the scrollbar depending on if the pane is scrolled/scrollable." 313767 313768 "Don't do anything with the retractable scrollbar unless we have focus" 313769 retractableScrollBar & self hasFocus not ifTrue: [^self]. 313770 "Don't show it if we were told not to." 313771 (self valueOfProperty: #noScrollBarPlease ifAbsent: [false]) ifTrue: [^self]. 313772 313773 self vIsScrollbarNeeded not & self isScrolledFromTop not ifTrue: [self vHideScrollBar]. 313774 self vIsScrollbarNeeded | self isScrolledFromTop ifTrue: [self vShowScrollBar]. 313775! ! 313776 313777!ScrollPane methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/3/2008 13:09'! 313778scrollBarThickness 313779 "Includes border" 313780 313781 | result | 313782 result := self theme scrollbarThickness. 313783 self flatColoredScrollBarLook 313784 ifFalse: [result := result + 2]. 313785 ^ result! ! 313786 313787 313788!ScrollPane methodsFor: 'access' stamp: 'md 2/24/2006 16:25'! 313789flatColoredScrollBarLook 313790 "Currently only show the flat (not rounded) + colored-to-match-window scrollbar look when inboard." 313791 ^ retractableScrollBar not or: [ScrollBar alwaysShowFlatScrollbarForAlternativeLook] 313792! ! 313793 313794!ScrollPane methodsFor: 'access' stamp: 'dew 10/17/1999 19:40'! 313795hasFocus 313796 "hasFocus is currently set by mouse enter/leave events. 313797 This inst var should probably be moved up to a higher superclass." 313798 313799 ^ hasFocus ifNil: [false]! ! 313800 313801!ScrollPane methodsFor: 'access' stamp: 'sps 3/10/2004 11:32'! 313802hMargin 313803"pixels of whitespace at to the left of the scroller when the hScrollBar offset is 0" 313804 ^3 313805! ! 313806 313807!ScrollPane methodsFor: 'access' stamp: 'LC 6/12/2000 09:28'! 313808retractableScrollBar 313809 ^ retractableScrollBar! ! 313810 313811!ScrollPane methodsFor: 'access' stamp: 'LC 6/12/2000 09:28'! 313812scrollBarOnLeft 313813 ^ scrollBarOnLeft! ! 313814 313815!ScrollPane methodsFor: 'access'! 313816scroller 313817 ^ scroller! ! 313818 313819!ScrollPane methodsFor: 'access' stamp: 'ar 5/19/1999 18:06'! 313820scroller: aTransformMorph 313821 scroller ifNotNil:[scroller delete]. 313822 scroller := aTransformMorph. 313823 self addMorph: scroller. 313824 self resizeScroller.! ! 313825 313826 313827!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:23'! 313828alwaysShowHScrollBar: bool 313829 self setProperty: #hScrollBarAlways toValue: bool. 313830 self hHideOrShowScrollBar. 313831! ! 313832 313833!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:25'! 313834alwaysShowScrollBars: bool 313835 "Get rid of scroll bar for short panes that don't want it shown." 313836 313837 self 313838 alwaysShowHScrollBar: bool; 313839 alwaysShowVScrollBar: bool. 313840! ! 313841 313842!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:23'! 313843alwaysShowVScrollBar: bool 313844 313845 self setProperty: #vScrollBarAlways toValue: bool. 313846 self vHideOrShowScrollBar. 313847! ! 313848 313849!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:23'! 313850hideHScrollBarIndefinitely: bool 313851 "Get rid of scroll bar for short panes that don't want it shown." 313852 313853 self setProperty: #noHScrollBarPlease toValue: bool. 313854 self hHideOrShowScrollBar. 313855! ! 313856 313857!ScrollPane methodsFor: 'access options' stamp: 'nk 4/28/2004 10:08'! 313858hideScrollBarsIndefinitely 313859 self hideScrollBarsIndefinitely: true 313860! ! 313861 313862!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:21'! 313863hideScrollBarsIndefinitely: bool 313864 "Get rid of scroll bar for short panes that don't want it shown." 313865 313866 self hideVScrollBarIndefinitely: bool. 313867 self hideHScrollBarIndefinitely: bool. 313868! ! 313869 313870!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:23'! 313871hideVScrollBarIndefinitely: bool 313872 "Get rid of scroll bar for short panes that don't want it shown." 313873 313874 self setProperty: #noVScrollBarPlease toValue: bool. 313875 self vHideOrShowScrollBar. 313876! ! 313877 313878!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:22'! 313879showHScrollBarOnlyWhenNeeded: bool 313880 "Get rid of scroll bar for short panes that don't want it shown." 313881 313882 self setProperty: #noHScrollBarPlease toValue: bool. 313883 self setProperty: #hScrollBarAlways toValue: bool. 313884 313885 self hHideOrShowScrollBar. 313886! ! 313887 313888!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:29'! 313889showScrollBarsOnlyWhenNeeded: bool 313890 313891 self showHScrollBarOnlyWhenNeeded: bool. 313892 self showVScrollBarOnlyWhenNeeded: bool. 313893! ! 313894 313895!ScrollPane methodsFor: 'access options' stamp: 'sps 4/4/2004 12:25'! 313896showVScrollBarOnlyWhenNeeded: bool 313897 "Get rid of scroll bar for short panes that don't want it shown." 313898 313899 self setProperty: #noVScrollBarPlease toValue: bool. 313900 self setProperty: #vScrollBarAlways toValue: bool. 313901 self vHideOrShowScrollBar. 313902! ! 313903 313904 313905!ScrollPane methodsFor: 'accessing' stamp: 'dgd 10/1/2004 12:52'! 313906borderWidth: aNumber 313907 super borderWidth: aNumber. 313908 self setScrollDeltas! ! 313909 313910!ScrollPane methodsFor: 'accessing' stamp: 'nk 3/8/2004 11:07'! 313911numSelectionsInView 313912 "Answer the scroller's height based on the average number of submorphs." 313913 313914 ^scroller numberOfItemsPotentiallyInView! ! 313915 313916 313917!ScrollPane methodsFor: 'event handling' stamp: 'sps 3/10/2004 10:23'! 313918handlesMouseDown: evt 313919 ^ true 313920! ! 313921 313922!ScrollPane methodsFor: 'event handling' stamp: 'marcus.denker 8/24/2008 22:05'! 313923handlesMouseOver: evt 313924 "Could just ^ true, but this ensures that scroll bars won't flop out 313925 if you mouse-over appendages such as connecting pins." 313926 "self flag: #arNote." "I have no idea how the code below could've ever worked. If the receiver does not handle mouse over events then it should not receive any #mouseLeave if the mouse leaves the receiver for real. This is because 'evt cursorPoint' describes the *end* point of the movement and considering that the code would return false if the move ends outside the receiver the scroll bars should never pop back in again. Which is exactly what happens with the new event logic if you don't just ^true. I'm leaving the code in for reference - perhaps somebody can make sense from it; I sure cannot." 313927 ^true 313928" 313929 | cp | 313930 cp := evt cursorPoint. 313931 (bounds containsPoint: cp) 313932 ifTrue: [^ true] 313933 ifFalse: [self submorphsDo: 313934 [:m | (m containsPoint: cp) ifTrue: 313935 [m == scrollBar 313936 ifTrue: [^ true] 313937 ifFalse: [^ false]]]. 313938 ^ false] 313939"! ! 313940 313941!ScrollPane methodsFor: 'event handling' stamp: 'md 2/13/2006 11:53'! 313942keyStroke: evt 313943 "If pane is not empty, pass the event to the last submorph, 313944 assuming it is the most appropriate recipient (!!)" 313945 313946 (self scrollByKeyboard: evt) ifTrue: [^self]. 313947 scroller submorphs last keyStroke: evt! ! 313948 313949!ScrollPane methodsFor: 'event handling' stamp: 'md 2/13/2006 11:53'! 313950mouseDown: evt 313951 evt yellowButtonPressed "First check for option (menu) click" 313952 ifTrue: [^ self yellowButtonActivity: evt shiftPressed]. 313953 "If pane is not empty, pass the event to the last submorph, 313954 assuming it is the most appropriate recipient (!!)" 313955 scroller hasSubmorphs ifTrue: 313956 [scroller submorphs last mouseDown: (evt transformedBy: (scroller transformFrom: self))]! ! 313957 313958!ScrollPane methodsFor: 'event handling' stamp: 'sps 3/9/2004 17:51'! 313959mouseEnter: event 313960 hasFocus := true. 313961 (owner isSystemWindow) ifTrue: [owner paneTransition: event]. 313962 retractableScrollBar ifTrue:[ self hideOrShowScrollBars ]. 313963! ! 313964 313965!ScrollPane methodsFor: 'event handling' stamp: 'sps 3/9/2004 17:52'! 313966mouseLeave: event 313967 hasFocus := false. 313968 retractableScrollBar ifTrue: [self hideScrollBars]. 313969 (owner isSystemWindow) ifTrue: [owner paneTransition: event] 313970! ! 313971 313972!ScrollPane methodsFor: 'event handling' stamp: 'md 2/13/2006 11:53'! 313973mouseMove: evt 313974 "If pane is not empty, pass the event to the last submorph, 313975 assuming it is the most appropriate recipient (!!)." 313976 scroller hasSubmorphs ifTrue: 313977 [scroller submorphs last mouseMove: (evt transformedBy: (scroller transformFrom: self))]! ! 313978 313979!ScrollPane methodsFor: 'event handling' stamp: 'md 2/13/2006 11:53'! 313980mouseUp: evt 313981 "If pane is not empty, pass the event to the last submorph, 313982 assuming it is the most appropriate recipient (!!)" 313983 scroller hasSubmorphs ifTrue: 313984 [scroller submorphs last mouseUp: (evt transformedBy: (scroller transformFrom: self))]! ! 313985 313986!ScrollPane methodsFor: 'event handling' stamp: 'th 12/11/1999 17:21'! 313987scrollByKeyboard: event 313988 "If event is ctrl+up/down then scroll and answer true" 313989 (event controlKeyPressed or:[event commandKeyPressed]) ifFalse: [^ false]. 313990 event keyValue = 30 313991 ifTrue: 313992 [scrollBar scrollUp: 3. 313993 ^ true]. 313994 event keyValue = 31 313995 ifTrue: 313996 [scrollBar scrollDown: 3. 313997 ^ true]. 313998 ^ false! ! 313999 314000 314001!ScrollPane methodsFor: 'geometry' stamp: 'sps 5/3/2004 13:49'! 314002extent: newExtent 314003 314004 | oldW oldH wasHShowing wasVShowing noVPlease noHPlease minH minW | 314005 314006 oldW := self width. 314007 oldH := self height. 314008 wasHShowing := self hIsScrollbarShowing. 314009 wasVShowing := self vIsScrollbarShowing. 314010 314011 "Figure out the minimum width and height for this pane so that scrollbars will appear" 314012 noVPlease := self valueOfProperty: #noVScrollBarPlease ifAbsent: [false]. 314013 noHPlease := self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]. 314014 minH := self scrollBarThickness + 16. 314015 minW := self scrollBarThickness + 20. 314016 noVPlease ifTrue:[ 314017 noHPlease 314018 ifTrue:[minH := 1. minW := 1 ] 314019 ifFalse:[minH := self scrollBarThickness ]. 314020 ] ifFalse:[ 314021 noHPlease 314022 ifTrue:[minH := self scrollBarThickness + 5]. 314023 ]. 314024 super extent: (newExtent max: (minW@minH)). 314025 314026 "Now reset widget sizes" 314027 self resizeScrollBars; resizeScroller; hideOrShowScrollBars. 314028 314029 "Now resetScrollDeltas where appropriate, first the vScrollBar..." 314030 ((self height ~~ oldH) or: [ wasHShowing ~~ self hIsScrollbarShowing]) ifTrue: 314031 [(retractableScrollBar or: [ self vIsScrollbarShowing ]) ifTrue: 314032 [ self vSetScrollDelta ]]. 314033 314034 "...then the hScrollBar" 314035 ((self width ~~ oldW) or: [wasVShowing ~~ self vIsScrollbarShowing]) ifTrue: 314036 [(retractableScrollBar or: [ self hIsScrollbarShowing ]) ifTrue: 314037 [ self hSetScrollDelta ]]. 314038 314039! ! 314040 314041!ScrollPane methodsFor: 'geometry' stamp: 'JW 2/21/2001 22:06'! 314042extraScrollRange 314043 "Return the amount of extra blank space to include below the bottom of the scroll content." 314044 "The classic behavior would be ^bounds height - (bounds height * 3 // 4)" 314045 ^ self scrollDeltaHeight! ! 314046 314047!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/24/2002 00:13'! 314048hExtraScrollRange 314049 "Return the amount of extra blank space to include below the bottom of the scroll content." 314050 ^ self scrollDeltaWidth 314051! ! 314052 314053!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 13:17'! 314054hLeftoverScrollRange 314055 "Return the entire scrolling range minus the currently viewed area." 314056 | w | 314057 scroller hasSubmorphs ifFalse:[^0]. 314058 w := bounds width. 314059 self vIsScrollbarShowing ifTrue:[ w := w - self scrollBarThickness ]. 314060 ^ (self hTotalScrollRange - w roundTo: self scrollDeltaHeight) max: 0 314061! ! 314062 314063!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/27/2002 01:30'! 314064hResizeScrollBar 314065 314066 | topLeft h border | 314067 314068"TEMPORARY: IF OLD SCROLLPANES LYING AROUND THAT DON'T HAVE A hScrollBar, INIT THEM" 314069 hScrollBar ifNil: [ self hInitScrollBarTEMPORARY]. 314070 314071 (self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]) ifTrue: [^self]. 314072 bounds ifNil: [ self fullBounds ]. 314073 314074 h := self scrollBarThickness. 314075 border := borderWidth. 314076 314077 topLeft := retractableScrollBar 314078 ifTrue: [bounds bottomLeft + (border @ border negated)] 314079 ifFalse: [bounds bottomLeft + (border @ (h + border) negated)]. 314080 314081 hScrollBar bounds: (topLeft extent: self hScrollBarWidth@ h) 314082! ! 314083 314084!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/25/2002 16:16'! 314085hScrollBarWidth 314086"Return the width of the horizontal scrollbar" 314087 314088 314089 | w | 314090 314091 w := bounds width - (2 * borderWidth). 314092 314093 (retractableScrollBar not and: [self vIsScrollbarNeeded]) 314094 ifTrue: [w := w - self scrollBarThickness ]. 314095 314096 ^w 314097! ! 314098 314099!ScrollPane methodsFor: 'geometry' stamp: 'dew 3/23/2004 23:23'! 314100hSetScrollDelta 314101 "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range." 314102 | range delta | 314103 314104 scroller hasSubmorphs ifFalse:[scrollBar interval: 1.0. ^self]. 314105 314106 delta := self scrollDeltaWidth. 314107 range := self hLeftoverScrollRange. 314108 range = 0 ifTrue: [ hScrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; setValue: 0. ^self]. 314109 314110 "Set up for one line (for arrow scrolling), or a full pane less one line (for paging)." 314111 314112 hScrollBar 314113 scrollDelta: (delta / range) asFloat 314114 pageDelta: ((self innerBounds width - delta) / range) asFloat. 314115 hScrollBar interval: ((self innerBounds width) / self hTotalScrollRange) asFloat. 314116 hScrollBar setValue: ((scroller offset x / range) min: 1.0) asFloat. 314117! ! 314118 314119!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 11:51'! 314120hTotalScrollRange 314121 "Return the entire scrolling range." 314122 ^ self hUnadjustedScrollRange + self hExtraScrollRange + self hMargin 314123! ! 314124 314125!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/24/2002 16:07'! 314126hUnadjustedScrollRange 314127 "Return the width extent of the receiver's submorphs." 314128 314129 | submorphBounds | 314130 submorphBounds := scroller localSubmorphBounds ifNil: [^ 0]. 314131 ^ submorphBounds right 314132! ! 314133 314134!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/24/2002 16:18'! 314135innerBounds 314136 | inner | 314137 inner := super innerBounds. 314138 retractableScrollBar | (submorphs includes: scrollBar) not ifFalse:[ 314139 inner := (scrollBarOnLeft 314140 ifTrue: [scrollBar right @ inner top corner: inner bottomRight] 314141 ifFalse: [inner topLeft corner: scrollBar left @ inner bottom]) 314142 ]. 314143 (retractableScrollBar | self hIsScrollbarShowing not) 314144 ifTrue: [^ inner] 314145 ifFalse: [^ inner topLeft corner: (inner bottomRight - (0@self scrollBarThickness))]. 314146! ! 314147 314148!ScrollPane methodsFor: 'geometry' stamp: 'dew 10/17/1999 19:41'! 314149resetExtent 314150 "Reset the extent. (may be overridden by subclasses which need to do more than this)" 314151 self resizeScroller! ! 314152 314153!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/25/2002 16:34'! 314154resizeScrollBars 314155 self vResizeScrollBar; hResizeScrollBar 314156! ! 314157 314158!ScrollPane methodsFor: 'geometry' stamp: 'di 11/11/1998 09:48'! 314159resizeScroller 314160 314161 scroller bounds: self innerBounds! ! 314162 314163!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 13:26'! 314164scrollDeltaHeight 314165 "Return the increment in pixels which this pane should be scrolled (normally a subclass responsibility)." 314166 ^ 10 314167! ! 314168 314169!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/9/2004 17:29'! 314170scrollDeltaWidth 314171 "Return the increment in pixels which this pane should be scrolled (normally a subclass responsibility)." 314172 314173 ^10 314174! ! 314175 314176!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 11:46'! 314177setScrollDeltas 314178 "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range." 314179 314180 scroller hasSubmorphs ifFalse: 314181 [scrollBar interval: 1.0. 314182 hScrollBar interval: 1.0. 314183 ^ self]. 314184 314185"NOTE: fullbounds commented out now -- trying to find a case where this expensive step is necessary -- perhaps there is a less expensive way to handle that case." 314186 "scroller fullBounds." "force recompute so that leftoverScrollRange will be up-to-date" 314187 self hideOrShowScrollBars. 314188 314189 (retractableScrollBar or: [ self vIsScrollbarShowing ]) ifTrue:[ self vSetScrollDelta ]. 314190 (retractableScrollBar or: [ self hIsScrollbarShowing ]) ifTrue:[ self hSetScrollDelta ]. 314191! ! 314192 314193!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/25/2002 14:40'! 314194vExtraScrollRange 314195 "Return the amount of extra blank space to include below the bottom of the scroll content." 314196 "The classic behavior would be ^bounds height - (bounds height * 3 // 4)" 314197 ^ self scrollDeltaHeight 314198! ! 314199 314200!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 13:14'! 314201vLeftoverScrollRange 314202 "Return the entire scrolling range minus the currently viewed area." 314203 | h | 314204 314205 scroller hasSubmorphs ifFalse:[^0]. 314206 h := self vScrollBarHeight. 314207 ^ (self vTotalScrollRange - h roundTo: self scrollDeltaHeight) max: 0 314208! ! 314209 314210!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 13:12'! 314211vResizeScrollBar 314212 | w topLeft borderHeight innerWidth | 314213 w := self scrollBarThickness. 314214 innerWidth := self flatColoredScrollBarLook 314215 ifTrue: 314216 [borderHeight := borderWidth. 314217 0] 314218 ifFalse: 314219 [borderHeight := 0. 314220 1]. 314221 topLeft := scrollBarOnLeft 314222 ifTrue: 314223 [retractableScrollBar 314224 ifTrue: [bounds topLeft - ((w - borderWidth) @ (0 - borderHeight))] 314225 ifFalse: [bounds topLeft + ((borderWidth - innerWidth) @ borderHeight)]] 314226 ifFalse: 314227 [retractableScrollBar 314228 ifTrue: [bounds topRight - (borderWidth @ (0 - borderHeight))] 314229 ifFalse: 314230 [bounds topRight - ((w + borderWidth - innerWidth) @ (0 - borderHeight))]]. 314231 314232 scrollBar 314233 bounds: (topLeft extent: w @ self vScrollBarHeight) 314234 314235! ! 314236 314237!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/25/2002 16:14'! 314238vScrollBarHeight 314239 | h | 314240 314241 h := bounds height - (2 * borderWidth). 314242 (retractableScrollBar not and: [self hIsScrollbarNeeded]) 314243 ifTrue:[ h := h - self scrollBarThickness. ]. 314244 314245 ^h 314246! ! 314247 314248!ScrollPane methodsFor: 'geometry' stamp: 'dew 3/23/2004 23:25'! 314249vSetScrollDelta 314250 "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range." 314251 | range delta | 314252 314253 scroller hasSubmorphs ifFalse:[scrollBar interval: 1.0. ^self]. 314254 314255 delta := self scrollDeltaHeight. 314256 range := self vLeftoverScrollRange. 314257 range = 0 ifTrue: [^ scrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; setValue: 0]. 314258 314259 "Set up for one line (for arrow scrolling), or a full pane less one line (for paging)." 314260 scrollBar scrollDelta: (delta / range) asFloat 314261 pageDelta: ((self innerBounds height - delta) / range) asFloat. 314262 scrollBar interval: ((self innerBounds height) / self vTotalScrollRange) asFloat. 314263 scrollBar setValue: (scroller offset y / range min: 1.0) asFloat. 314264! ! 314265 314266!ScrollPane methodsFor: 'geometry' stamp: 'sps 3/10/2004 11:06'! 314267vTotalScrollRange 314268 "Return the entire scrolling range." 314269 ^ self vUnadjustedScrollRange + self vExtraScrollRange 314270! ! 314271 314272!ScrollPane methodsFor: 'geometry' stamp: 'sps 12/25/2002 14:43'! 314273vUnadjustedScrollRange 314274 "Return the height extent of the receiver's submorphs." 314275 | submorphBounds | 314276 submorphBounds := scroller localSubmorphBounds ifNil: [^ 0]. 314277 ^ submorphBounds bottom 314278! ! 314279 314280 314281!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'! 314282containsPoint: aPoint 314283 314284 (super containsPoint: aPoint) ifTrue: [^ true]. 314285 314286 "Also include v scrollbar when it is extended..." 314287 ((retractableScrollBar and: [submorphs includes: scrollBar]) and: 314288 [scrollBar containsPoint: aPoint]) 314289 ifTrue:[ ^true ]. 314290 314291 "Also include hScrollbar when it is extended..." 314292 ^(retractableScrollBar and: [self hIsScrollbarShowing]) and: 314293 [hScrollBar containsPoint: aPoint] 314294! ! 314295 314296!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 13:46'! 314297hIsScrollable 314298 314299 "If the contents of the pane are too small to scroll, return false." 314300 ^ self hLeftoverScrollRange > 0 314301 314302! ! 314303 314304!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'! 314305hIsScrollbarShowing 314306 "Return true if a horz scroll bar is currently showing" 314307 314308 ^submorphs includes: hScrollBar 314309! ! 314310 314311!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'! 314312hIsScrolled 314313 "If the scroller is not set to x = 0, then the pane has been h-scrolled." 314314 ^scroller offset x > 0 314315! ! 314316 314317!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'! 314318isAScrollbarShowing 314319 "Return true if a either retractable scroll bar is currently showing" 314320 retractableScrollBar ifFalse:[^true]. 314321 ^self hIsScrollbarShowing or: [self vIsScrollbarShowing] 314322! ! 314323 314324!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'! 314325isScrolledFromTop 314326 "Have the contents of the pane been scrolled, so that the top of the contents are not visible?" 314327 ^scroller offset y > 0 314328! ! 314329 314330!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'! 314331scrollBarFills: aRectangle 314332 "Return true if a flop-out scrollbar fills the rectangle" 314333 314334 retractableScrollBar ifFalse:[^false]. 314335 314336 ((submorphs includes: scrollBar) and: [scrollBar bounds containsRect: aRectangle]) 314337 ifTrue:[ ^true ]. 314338 ^((submorphs includes: hScrollBar) and: [hScrollBar bounds containsRect: aRectangle]) 314339! ! 314340 314341!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 13:23'! 314342vIsScrollable 314343"Return whether the verticle scrollbar is scrollable" 314344 314345 "If the contents of the pane are too small to scroll, return false." 314346 ^ self vLeftoverScrollRange > 0 314347 "treat a single line as non-scrollable" 314348 and: [self vTotalScrollRange > (self scrollDeltaHeight * 3/2)] 314349! ! 314350 314351!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:22'! 314352vIsScrollbarShowing 314353 "Return true if a retractable scroll bar is currently showing" 314354 314355 ^submorphs includes: scrollBar 314356! ! 314357 314358!ScrollPane methodsFor: 'geometry testing' stamp: 'sps 3/10/2004 10:23'! 314359vIsScrolled 314360 "If the scroller is not set to y = 0, then the pane has been scrolled." 314361 ^scroller offset y > 0 314362! ! 314363 314364 314365!ScrollPane methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'! 314366defaultBorderColor 314367 "answer the default border color/fill style for the receiver" 314368 ^ Color black! ! 314369 314370!ScrollPane methodsFor: 'initialization' stamp: 'sps 4/3/2005 15:21'! 314371defaultExtent 314372 ^150@120 314373! ! 314374 314375!ScrollPane methodsFor: 'initialization' stamp: 'sps 3/9/2004 18:02'! 314376hInitScrollBarTEMPORARY 314377"This is called lazily before the hScrollBar is accessed in a couple of places. It is provided to transition old ScrollPanes lying around that do not have an hScrollBar. Once it has been in the image for awhile, and all ScrollPanes have an hScrollBar, this method and it's references can be removed. " 314378 314379 "Temporary method for filein of changeset" 314380 hScrollBar ifNil: 314381 [hScrollBar := ScrollBar new model: self slotName: 'hScrollBar'. 314382 hScrollBar borderWidth: 1; borderColor: Color black. 314383 self 314384 resizeScrollBars; 314385 setScrollDeltas; 314386 hideOrShowScrollBars]. 314387! ! 314388 314389!ScrollPane methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:20'! 314390initialize 314391 314392 "initialize the state of the receiver" 314393 super initialize. 314394 "" 314395 self initializePreferences. 314396 hasFocus := false. 314397 self initializeScrollBars. 314398 "" 314399 self extent: self defaultExtent. 314400 self hideOrShowScrollBars. 314401 314402 314403! ! 314404 314405!ScrollPane methodsFor: 'initialization' stamp: 'md 2/24/2006 21:26'! 314406initializePreferences 314407 "initialize the receiver's Preferences" 314408 retractableScrollBar := false. 314409 scrollBarOnLeft := (Preferences valueOfFlag: #scrollBarsOnRight) not. 314410 314411 314412! ! 314413 314414!ScrollPane methodsFor: 'initialization' stamp: 'sps 4/4/2004 12:18'! 314415initializeScrollBars 314416"initialize the receiver's scrollBar" 314417 314418 (scrollBar := ScrollBar new model: self slotName: 'vScrollBar') 314419 borderWidth: 1; 314420 borderColor: Color black. 314421 (hScrollBar := ScrollBar new model: self slotName: 'hScrollBar') 314422 borderWidth: 1; 314423 borderColor: Color black. 314424 314425 "" 314426 scroller := TransformMorph new color: Color transparent. 314427 scroller offset: -3 @ 0. 314428 self addMorph: scroller. 314429 "" 314430 scrollBar initializeEmbedded: retractableScrollBar not. 314431 hScrollBar initializeEmbedded: retractableScrollBar not. 314432 retractableScrollBar ifFalse: 314433 [self 314434 addMorph: scrollBar; 314435 addMorph: hScrollBar]. 314436 314437 Preferences alwaysShowVScrollbar ifTrue: 314438 [ self alwaysShowVScrollBar: true ]. 314439 314440 Preferences alwaysHideHScrollbar 314441 ifTrue:[self hideHScrollBarIndefinitely: true ] 314442 ifFalse: 314443 [Preferences alwaysShowHScrollbar ifTrue: 314444 [ self alwaysShowHScrollBar: true ]]. 314445! ! 314446 314447 314448!ScrollPane methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:06'! 314449addCustomMenuItems: aCustomMenu hand: aHandMorph 314450 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 314451 retractableScrollBar 314452 ifTrue: [aCustomMenu add: 'make scrollbar inboard' translated action: #retractableOrNot] 314453 ifFalse: [aCustomMenu add: 'make scrollbar retractable' translated action: #retractableOrNot]. 314454 scrollBarOnLeft 314455 ifTrue: [aCustomMenu add: 'scroll bar on right' translated action: #leftOrRight] 314456 ifFalse: [aCustomMenu add: 'scroll bar on left' translated action: #leftOrRight]! ! 314457 314458!ScrollPane methodsFor: 'menu' stamp: 'sw 9/23/1998 08:47'! 314459getMenu: shiftKeyState 314460 "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." 314461 | menu aMenu aTitle | 314462 getMenuSelector == nil ifTrue: [^ nil]. 314463 menu := MenuMorph new defaultTarget: model. 314464 aTitle := getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector]. 314465 getMenuSelector numArgs = 1 ifTrue: 314466 [aMenu := model perform: getMenuSelector with: menu. 314467 aTitle ifNotNil: [aMenu addTitle: aTitle]. 314468 ^ aMenu]. 314469 getMenuSelector numArgs = 2 ifTrue: 314470 [aMenu := model perform: getMenuSelector with: menu with: shiftKeyState. 314471 aTitle ifNotNil: [aMenu addTitle: aTitle]. 314472 ^ aMenu]. 314473 ^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! ! 314474 314475!ScrollPane methodsFor: 'menu' stamp: 'di 11/14/97 09:09'! 314476leftOrRight "Change scroll bar location" 314477 scrollBarOnLeft := scrollBarOnLeft not. 314478 self extent: self extent! ! 314479 314480!ScrollPane methodsFor: 'menu' stamp: 'sw 8/18/1998 12:38'! 314481menuTitleSelector: aSelector 314482 getMenuTitleSelector := aSelector! ! 314483 314484!ScrollPane methodsFor: 'menu' stamp: 'sps 3/9/2004 17:47'! 314485retractableOrNot 314486 "Change scroll bar operation" 314487 314488 retractableScrollBar := retractableScrollBar not. 314489 retractableScrollBar 314490 ifTrue: [self removeMorph: scrollBar] 314491 ifFalse: [(submorphs includes: scrollBar) 314492 ifFalse: 314493 [self privateAddMorph: scrollBar atIndex: 1. 314494 self privateAddMorph: hScrollBar atIndex: 1]]. 314495 self extent: self extent. 314496! ! 314497 314498!ScrollPane methodsFor: 'menu' stamp: 'sw 11/5/1998 14:14'! 314499retractable: aBoolean 314500 retractableScrollBar == aBoolean ifFalse: [self retractableOrNot "toggles it"]! ! 314501 314502!ScrollPane methodsFor: 'menu' stamp: 'sw 1/13/98 21:27'! 314503scrollBarOnLeft: aBoolean 314504 scrollBarOnLeft := aBoolean. 314505 self extent: self extent! ! 314506 314507!ScrollPane methodsFor: 'menu' stamp: 'dgd 9/18/2004 18:29'! 314508wantsYellowButtonMenu 314509 "Answer true if the receiver wants a yellow button menu" 314510 ^ getMenuSelector notNil! ! 314511 314512 314513!ScrollPane methodsFor: 'scroll bar events' stamp: 'sps 12/27/2002 00:13'! 314514hScrollBarMenuButtonPressed: event 314515 ^ self scrollBarMenuButtonPressed: event 314516! ! 314517 314518!ScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:31'! 314519scrollBarMenuButtonPressed: event 314520 ^ self yellowButtonActivity: event shiftPressed! ! 314521 314522!ScrollPane methodsFor: 'scroll bar events' stamp: 'sw 3/22/2001 12:03'! 314523shiftedTextPaneMenuRequest 314524 "The more... button was hit from the text-pane menu" 314525 314526 ^ self yellowButtonActivity: true! ! 314527 314528!ScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:31'! 314529shiftedYellowButtonActivity 314530 ^ self yellowButtonActivity: true! ! 314531 314532!ScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:32'! 314533unshiftedYellowButtonActivity 314534 ^ self yellowButtonActivity: false! ! 314535 314536!ScrollPane methodsFor: 'scroll bar events' stamp: 'sps 12/27/2002 00:13'! 314537vScrollBarMenuButtonPressed: event 314538 ^ self scrollBarMenuButtonPressed: event 314539! ! 314540 314541!ScrollPane methodsFor: 'scroll bar events' stamp: 'RAA 6/12/2000 09:02'! 314542yellowButtonActivity: shiftKeyState 314543 | menu | 314544 (menu := self getMenu: shiftKeyState) ifNotNil: 314545 [menu setInvokingView: self. 314546 menu popUpEvent: self activeHand lastEvent in: self world]! ! 314547 314548 314549!ScrollPane methodsFor: 'scrolling' stamp: 'sps 12/25/2002 01:10'! 314550hHideOrShowScrollBar 314551 "Hide or show the scrollbar depending on if the pane is scrolled/scrollable." 314552 314553 self hIsScrollbarNeeded 314554 ifTrue:[ self hShowScrollBar ] 314555 ifFalse: [ self hHideScrollBar ]. 314556! ! 314557 314558!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 12:08'! 314559hHideScrollBar 314560 self hIsScrollbarShowing ifFalse: [^scroller offset: (self hMargin negated@scroller offset y)]. 314561 self removeMorph: hScrollBar. 314562 scroller offset: (self hMargin negated@scroller offset y). 314563 retractableScrollBar ifFalse: [self resetExtent]. 314564 314565! ! 314566 314567!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 13:33'! 314568hIsScrollbarNeeded 314569"Return whether the horz scrollbar is needed" 314570 314571 "Don't do anything with the retractable scrollbar unless we have focus" 314572 retractableScrollBar & self hasFocus not ifTrue: [^false]. 314573 314574 "Don't show it if we were told not to." 314575 (self valueOfProperty: #noHScrollBarPlease ifAbsent: [false]) ifTrue: [^false]. 314576 314577 "Always show it if we were told to" 314578 (self valueOfProperty: #hScrollBarAlways ifAbsent: [false]) ifTrue: [^true]. 314579 314580 ^self hIsScrollable 314581! ! 314582 314583!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 12:07'! 314584hideOrShowScrollBars 314585 314586 | wasHShowing wasVShowing | 314587 314588 wasVShowing := self vIsScrollbarShowing. 314589 wasHShowing := self hIsScrollbarShowing. 314590 314591 self 314592 vHideOrShowScrollBar; 314593 hHideOrShowScrollBar; 314594 resizeScrollBars. 314595 314596 (wasVShowing and: [self vIsScrollbarShowing not]) ifTrue: 314597 ["Make sure the delta is 0" 314598 (scroller offset y == 0) 314599 ifFalse:[ scroller offset: (scroller offset x@0) ]]. 314600 314601 (wasHShowing and: [self hIsScrollbarShowing not]) ifTrue: 314602 [(scroller offset x <= 0) 314603 ifFalse:[ scroller offset: (self hMargin negated@scroller offset y)]]. 314604! ! 314605 314606!ScrollPane methodsFor: 'scrolling' stamp: 'sps 12/25/2002 16:30'! 314607hideScrollBars 314608 self 314609 vHideScrollBar; 314610 hHideScrollBar 314611! ! 314612 314613!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 11:50'! 314614hScrollBarValue: scrollValue 314615 314616 | x | 314617 self hIsScrollbarShowing ifFalse: 314618 [^scroller offset: (0 - self hMargin)@scroller offset y]. 314619 ((x := self hLeftoverScrollRange * scrollValue) <= 0) 314620 ifTrue:[x := 0 - self hMargin]. 314621 scroller offset: (x@scroller offset y) 314622! ! 314623 314624!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 13:42'! 314625hShowScrollBar 314626 314627 self hIsScrollbarShowing ifTrue: [^self]. 314628 self hResizeScrollBar. 314629 self privateAddMorph: hScrollBar atIndex: 1. 314630 retractableScrollBar ifFalse: [self resetExtent]. 314631! ! 314632 314633!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 11:09'! 314634scrollBy: delta 314635 "Move the contents in the direction delta." 314636 314637 | newYoffset r newXoffset | 314638 314639 "Set the offset on the scroller" 314640 newYoffset := scroller offset y - delta y max: 0. 314641 newXoffset := scroller offset x - delta x max: -3. 314642 314643 scroller offset: newXoffset@ newYoffset. 314644 314645 "Update the scrollBars" 314646 (r := self vLeftoverScrollRange) = 0 314647 ifTrue: [scrollBar value: 0.0] 314648 ifFalse: [scrollBar value: newYoffset asFloat / r]. 314649 (r := self hLeftoverScrollRange) = 0 314650 ifTrue: [hScrollBar value: -3.0] 314651 ifFalse: [hScrollBar value: newXoffset asFloat / r] 314652! ! 314653 314654!ScrollPane methodsFor: 'scrolling' stamp: 'kfr 11/14/2004 10:29'! 314655scrollToShow: aRectangle 314656 "scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space" 314657 | range | 314658 ((aRectangle top - scroller offset y) >= 0 and: [ 314659 (aRectangle bottom - scroller offset y) <= (self innerBounds height) ]) 314660 ifTrue:[ "already visible"^self ]. 314661 314662 range := self vLeftoverScrollRange. 314663 scrollBar value: (range > 0 314664 ifTrue: [((aRectangle top) / self vLeftoverScrollRange) 314665 truncateTo: scrollBar scrollDelta] 314666 ifFalse: [0]). 314667 scroller offset: -3 @ (range * scrollBar value).! ! 314668 314669!ScrollPane methodsFor: 'scrolling' stamp: 'sps 12/25/2002 16:35'! 314670showScrollBars 314671 self vShowScrollBar; hShowScrollBar 314672! ! 314673 314674!ScrollPane methodsFor: 'scrolling' stamp: 'sps 12/25/2002 16:31'! 314675vHideOrShowScrollBar 314676 314677 self vIsScrollbarNeeded 314678 ifTrue:[ self vShowScrollBar ] 314679 ifFalse:[ self vHideScrollBar ]. 314680! ! 314681 314682!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 12:07'! 314683vHideScrollBar 314684 self vIsScrollbarShowing ifFalse: [^self]. 314685 self removeMorph: scrollBar. 314686 retractableScrollBar ifFalse: [self resetExtent]. 314687 314688! ! 314689 314690!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 10:26'! 314691vIsScrollbarNeeded 314692"Return whether the verticle scrollbar is needed" 314693 314694 "Don't do anything with the retractable scrollbar unless we have focus" 314695 retractableScrollBar & self hasFocus not ifTrue: [^false]. 314696 314697 "Don't show it if we were told not to." 314698 (self valueOfProperty: #noVScrollBarPlease ifAbsent: [false]) ifTrue: [^false]. 314699 314700 "Always show it if we were told to" 314701 (self valueOfProperty: #vScrollBarAlways ifAbsent: [false]) ifTrue: [^true]. 314702 314703 ^self vIsScrollable 314704! ! 314705 314706!ScrollPane methodsFor: 'scrolling' stamp: 'sps 12/25/2002 16:32'! 314707vScrollBarValue: scrollValue 314708 scroller hasSubmorphs ifFalse: [^ self]. 314709 scroller offset: (scroller offset x @ (self vLeftoverScrollRange * scrollValue) rounded) 314710! ! 314711 314712!ScrollPane methodsFor: 'scrolling' stamp: 'sps 3/10/2004 13:22'! 314713vShowScrollBar 314714 314715 self vIsScrollbarShowing ifTrue: [^ self]. 314716 self vResizeScrollBar. 314717 self privateAddMorph: scrollBar atIndex: 1. 314718 retractableScrollBar ifFalse: [self resetExtent] 314719! ! 314720 314721"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 314722 314723ScrollPane class 314724 instanceVariableNames: ''! 314725 314726!ScrollPane class methodsFor: 'examples' stamp: 'mk 8/9/2005 10:28'! 314727example1 314728 | window scrollPane pasteUpMorph | 314729 window := SystemWindow new. 314730 scrollPane := ScrollPane new. 314731 pasteUpMorph := PasteUpMorph new. 314732 pasteUpMorph extent: 1000@1000. 314733 scrollPane scroller addMorph: pasteUpMorph. 314734 window addMorph: scrollPane frame: (0@0 corner: 1@1). 314735 window openInWorld.! ! 314736 314737!ScrollPane class methodsFor: 'examples' stamp: 'mk 8/9/2005 10:29'! 314738example2 314739 | window scrollPane pasteUpMorph point textMorph | 314740 window := SystemWindow new. 314741 scrollPane := ScrollPane new. 314742 pasteUpMorph := PasteUpMorph new. 314743 pasteUpMorph extent: 1000@1000. 314744 scrollPane scroller addMorph: pasteUpMorph. 314745 window addMorph: scrollPane frame: (0@0 corner: 1@1). 314746 0 to: 1000 by: 100 do: 314747 [:x | 0 to: 1000 by: 100 do: 314748 [:y | 314749 point := x@y. 314750 textMorph := TextMorph new contents: point asString. 314751 textMorph position: point. 314752 pasteUpMorph addMorph: textMorph 314753 ] 314754 ]. 314755 window openInWorld.! ! 314756 314757 314758!ScrollPane class methodsFor: 'new-morph participation' stamp: 'di 2/21/98 11:02'! 314759includeInNewMorphMenu 314760 "OK to instantiate" 314761 ^ true! ! 314762Object subclass: #SecureHashAlgorithm 314763 instanceVariableNames: 'totalA totalB totalC totalD totalE totals' 314764 classVariableNames: 'K1 K2 K3 K4' 314765 poolDictionaries: '' 314766 category: 'System-Digital Signatures'! 314767!SecureHashAlgorithm commentStamp: '<historical>' prior: 0! 314768This class implements the Secure Hash Algorithm (SHA) described in the U.S. government's Secure Hash Standard (SHS). This standard is described in FIPS PUB 180-1, "SECURE HASH STANDARD", April 17, 1995. 314769 314770The Secure Hash Algorithm is also described on p. 442 of 'Applied Cryptography: Protocols, Algorithms, and Source Code in C' by Bruce Scheier, Wiley, 1996. 314771 314772See the comment in class DigitalSignatureAlgorithm for details on its use. 314773 314774Implementation notes: 314775The secure hash standard was created with 32-bit hardware in mind. All arithmetic in the hash computation must be done modulo 2^32. This implementation uses ThirtyTwoBitRegister objects to simulate hardware registers; this implementation is about six times faster than using LargePositiveIntegers (measured on a Macintosh G3 Powerbook). Implementing a primitive to process each 64-byte buffer would probably speed up the computation by a factor of 20 or more. 314776! 314777 314778 314779!SecureHashAlgorithm methodsFor: 'primitives' stamp: 'jm 12/21/1999 20:11'! 314780primExpandBlock: aByteArray into: wordBitmap 314781 "Expand the given 64-byte buffer into the given Bitmap of length 80." 314782 314783 <primitive: 'primitiveExpandBlock' module: 'DSAPrims'> 314784 ^ self primitiveFailed 314785! ! 314786 314787!SecureHashAlgorithm methodsFor: 'primitives' stamp: 'jm 12/21/1999 22:58'! 314788primHasSecureHashPrimitive 314789 "Answer true if this platform has primitive support for the Secure Hash Algorithm." 314790 314791 <primitive: 'primitiveHasSecureHashPrimitive' module: 'DSAPrims'> 314792 ^ false 314793! ! 314794 314795!SecureHashAlgorithm methodsFor: 'primitives' stamp: 'jm 12/21/1999 20:13'! 314796primHashBlock: blockBitmap using: workingTotalsBitmap 314797 "Hash the given block (a Bitmap) of 80 32-bit words, using the given workingTotals." 314798 314799 <primitive: 'primitiveHashBlock' module: 'DSAPrims'> 314800 ^ self primitiveFailed 314801! ! 314802 314803 314804!SecureHashAlgorithm methodsFor: 'public' stamp: 'jm 12/14/1999 11:56'! 314805hashInteger: aPositiveInteger 314806 "Hash the given positive integer. The integer to be hashed should have 512 or fewer bits. This entry point is used in key generation." 314807 314808 | buffer dstIndex | 314809 self initializeTotals. 314810 314811 "pad integer with zeros" 314812 aPositiveInteger highBit <= 512 314813 ifFalse: [self error: 'integer cannot exceed 512 bits']. 314814 buffer := ByteArray new: 64. 314815 dstIndex := 0. 314816 aPositiveInteger digitLength to: 1 by: -1 do: [:i | 314817 buffer at: (dstIndex := dstIndex + 1) put: (aPositiveInteger digitAt: i)]. 314818 314819 "process that one block" 314820 self processBuffer: buffer. 314821 314822 ^ self finalHash 314823! ! 314824 314825!SecureHashAlgorithm methodsFor: 'public' stamp: 'md 11/14/2003 17:17'! 314826hashInteger: aPositiveInteger seed: seedInteger 314827 "Hash the given positive integer. The integer to be hashed should have 512 or fewer bits. This entry point is used in the production of random numbers" 314828 314829 | buffer dstIndex | 314830 "Initialize totalA through totalE to their seed values." 314831 totalA := ThirtyTwoBitRegister new 314832 load: ((seedInteger bitShift: -128) bitAnd: 16rFFFFFFFF). 314833 totalB := ThirtyTwoBitRegister new 314834 load: ((seedInteger bitShift: -96) bitAnd: 16rFFFFFFFF). 314835 totalC := ThirtyTwoBitRegister new 314836 load: ((seedInteger bitShift: -64) bitAnd: 16rFFFFFFFF). 314837 totalD := ThirtyTwoBitRegister new 314838 load: ((seedInteger bitShift: -32) bitAnd: 16rFFFFFFFF). 314839 totalE := ThirtyTwoBitRegister new 314840 load: (seedInteger bitAnd: 16rFFFFFFFF). 314841 self initializeTotalsArray. 314842 314843 "pad integer with zeros" 314844 buffer := ByteArray new: 64. 314845 dstIndex := 0. 314846 aPositiveInteger digitLength to: 1 by: -1 do: [:i | 314847 buffer at: (dstIndex := dstIndex + 1) put: (aPositiveInteger digitAt: i)]. 314848 314849 "process that one block" 314850 self processBuffer: buffer. 314851 314852 ^ self finalHash 314853! ! 314854 314855!SecureHashAlgorithm methodsFor: 'public' stamp: 'dc 5/30/2008 10:17'! 314856hashMessage: aStringOrByteArray 314857 "Hash the given message using the Secure Hash Algorithm." 314858 ^ self hashStream: aStringOrByteArray asByteArray readStream! ! 314859 314860!SecureHashAlgorithm methodsFor: 'public' stamp: 'jm 12/14/1999 11:41'! 314861hashStream: aPositionableStream 314862 "Hash the contents of the given stream from the current position to the end using the Secure Hash Algorithm. The SHA algorithm is defined in FIPS PUB 180-1. It is also described on p. 442 of 'Applied Cryptography: Protocols, Algorithms, and Source Code in C' by Bruce Scheier, Wiley, 1996." 314863 "SecureHashAlgorithm new hashStream: (ReadStream on: 'foo')" 314864 314865 | startPosition buf bitLength | 314866 self initializeTotals. 314867 314868 aPositionableStream atEnd ifTrue: [self error: 'empty stream']. 314869 314870 startPosition := aPositionableStream position. 314871 [aPositionableStream atEnd] whileFalse: [ 314872 buf := aPositionableStream next: 64. 314873 (aPositionableStream atEnd not and: [buf size = 64]) 314874 ifTrue: [self processBuffer: buf] 314875 ifFalse: [ 314876 bitLength := (aPositionableStream position - startPosition) * 8. 314877 self processFinalBuffer: buf bitLength: bitLength]]. 314878 314879 ^ self finalHash 314880! ! 314881 314882 314883!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/7/1999 23:25'! 314884constantForStep: i 314885 "Answer the constant for the i-th step of the block hash loop. We number our steps 1-80, versus the 0-79 of the standard." 314886 314887 i <= 20 ifTrue: [^ K1]. 314888 i <= 40 ifTrue: [^ K2]. 314889 i <= 60 ifTrue: [^ K3]. 314890 ^ K4 314891! ! 314892 314893!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 20:06'! 314894expandedBlock: aByteArray 314895 "Convert the given 64 byte buffer into 80 32-bit registers and answer the result." 314896 | out src v | 314897 out := Array new: 80. 314898 src := 1. 314899 1 to: 16 do: [:i | 314900 out at: i put: (ThirtyTwoBitRegister new loadFrom: aByteArray at: src). 314901 src := src + 4]. 314902 314903 17 to: 80 do: [:i | 314904 v := (out at: i - 3) copy. 314905 v bitXor: (out at: i - 8); 314906 bitXor: (out at: i - 14); 314907 bitXor: (out at: i - 16); 314908 leftRotateBy: 1. 314909 out at: i put: v]. 314910 ^ out 314911! ! 314912 314913!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 20:02'! 314914finalHash 314915 "Concatenate the final totals to build the 160-bit integer result." 314916 "Details: If the primitives are supported, the results are in the totals array. Otherwise, they are in the instance variables totalA through totalE." 314917 314918 | r | 314919 totals ifNil: [ "compute final hash when not using primitives" 314920 ^ (totalA asInteger bitShift: 128) + 314921 (totalB asInteger bitShift: 96) + 314922 (totalC asInteger bitShift: 64) + 314923 (totalD asInteger bitShift: 32) + 314924 (totalE asInteger)]. 314925 314926 "compute final hash when using primitives" 314927 r := 0. 314928 1 to: 5 do: [:i | 314929 r := r bitOr: ((totals at: i) bitShift: (32 * (5 - i)))]. 314930 ^ r 314931! ! 314932 314933!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/7/1999 22:15'! 314934hashFunction: i of: x with: y with: z 314935 "Compute the hash function for the i-th step of the block hash loop. We number our steps 1-80, versus the 0-79 of the standard." 314936 "Details: There are four functions, one for each 20 iterations. The second and fourth are the same." 314937 314938 i <= 20 ifTrue: [^ x copy bitAnd: y; bitOr: (x copy bitInvert; bitAnd: z)]. 314939 i <= 40 ifTrue: [^ x copy bitXor: y; bitXor: z]. 314940 i <= 60 ifTrue: [^ x copy bitAnd: y; bitOr: (x copy bitAnd: z); bitOr: (y copy bitAnd: z)]. 314941 ^ x copy bitXor: y; bitXor: z 314942! ! 314943 314944!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 19:38'! 314945initializeTotals 314946 "Initialize totalA through totalE to their seed values." 314947 314948 "total registers for use when primitives are absent" 314949 totalA := ThirtyTwoBitRegister new load: 16r67452301. 314950 totalB := ThirtyTwoBitRegister new load: 16rEFCDAB89. 314951 totalC := ThirtyTwoBitRegister new load: 16r98BADCFE. 314952 totalD := ThirtyTwoBitRegister new load: 16r10325476. 314953 totalE := ThirtyTwoBitRegister new load: 16rC3D2E1F0. 314954 self initializeTotalsArray. 314955! ! 314956 314957!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 19:38'! 314958initializeTotalsArray 314959 "Initialize the totals array from the registers for use with the primitives." 314960 314961 totals := Bitmap new: 5. 314962 totals at: 1 put: totalA asInteger. 314963 totals at: 2 put: totalB asInteger. 314964 totals at: 3 put: totalC asInteger. 314965 totals at: 4 put: totalD asInteger. 314966 totals at: 5 put: totalE asInteger. 314967! ! 314968 314969!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 19:43'! 314970processBuffer: aByteArray 314971 "Process given 64-byte buffer, accumulating the results in totalA through totalE." 314972 314973 | a b c d e w tmp | 314974 self primHasSecureHashPrimitive 314975 ifTrue: [^ self processBufferUsingPrimitives: aByteArray] 314976 ifFalse: [totals := nil]. 314977 314978 "initialize registers a through e from the current totals" 314979 a := totalA copy. 314980 b := totalB copy. 314981 c := totalC copy. 314982 d := totalD copy. 314983 e := totalE copy. 314984 314985 "expand and process the buffer" 314986 w := self expandedBlock: aByteArray. 314987 1 to: 80 do: [:i | 314988 tmp := (a copy leftRotateBy: 5) 314989 += (self hashFunction: i of: b with: c with: d); 314990 += e; 314991 += (w at: i); 314992 += (self constantForStep: i). 314993 e := d. 314994 d := c. 314995 c := b copy leftRotateBy: 30. 314996 b := a. 314997 a := tmp]. 314998 314999 "add a through e into total accumulators" 315000 totalA += a. 315001 totalB += b. 315002 totalC += c. 315003 totalD += d. 315004 totalE += e. 315005! ! 315006 315007!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 23:32'! 315008processBufferUsingPrimitives: aByteArray 315009 "Process given 64-byte buffer using the primitives, accumulating the results in totals." 315010 315011 | w | 315012 "expand and process the buffer" 315013 w := Bitmap new: 80. 315014 self primExpandBlock: aByteArray into: w. 315015 self primHashBlock: w using: totals. 315016! ! 315017 315018!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/14/1999 11:40'! 315019processFinalBuffer: buffer bitLength: bitLength 315020 "Process given buffer, whose length may be <= 64 bytes, accumulating the results in totalA through totalE. Also process the final padding bits and length." 315021 315022 | out | 315023 out := ByteArray new: 64. 315024 out replaceFrom: 1 to: buffer size with: buffer startingAt: 1. 315025 buffer size < 56 ifTrue: [ "padding and length fit in last data block" 315026 out at: buffer size + 1 put: 128. "trailing one bit" 315027 self storeLength: bitLength in: out. "end with length" 315028 self processBuffer: out. 315029 ^ self]. 315030 315031 "process the final data block" 315032 buffer size < 64 ifTrue: [ 315033 out at: buffer size + 1 put: 128]. "trailing one bit" 315034 self processBuffer: out. 315035 315036 "process one additional block of padding ending with the length" 315037 out := ByteArray new: 64. "filled with zeros" 315038 buffer size = 64 ifTrue: [ 315039 "add trailing one bit that didn't fit in final data block" 315040 out at: 1 put: 128]. 315041 self storeLength: bitLength in: out. 315042 self processBuffer: out. 315043! ! 315044 315045!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/14/1999 11:10'! 315046storeLength: bitLength in: aByteArray 315047 "Fill in the final 8 bytes of the given ByteArray with a 64-bit big-endian representation of the original message length in bits." 315048 315049 | n i | 315050 n := bitLength. 315051 i := aByteArray size. 315052 [n > 0] whileTrue: [ 315053 aByteArray at: i put: (n bitAnd: 16rFF). 315054 n := n bitShift: -8. 315055 i := i - 1]. 315056! ! 315057 315058"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 315059 315060SecureHashAlgorithm class 315061 instanceVariableNames: ''! 315062 315063!SecureHashAlgorithm class methodsFor: 'initialization' stamp: 'jm 12/7/1999 23:25'! 315064initialize 315065 "SecureHashAlgorithm initialize" 315066 "For the curious, here's where these constants come from: 315067 #(2 3 5 10) collect: [:x | ((x sqrt / 4.0) * (2.0 raisedTo: 32)) truncated hex]" 315068 315069 K1 := ThirtyTwoBitRegister new load: 16r5A827999. 315070 K2 := ThirtyTwoBitRegister new load: 16r6ED9EBA1. 315071 K3 := ThirtyTwoBitRegister new load: 16r8F1BBCDC. 315072 K4 := ThirtyTwoBitRegister new load: 16rCA62C1D6. 315073! ! 315074ClassTestCase subclass: #SecureHashAlgorithmTest 315075 instanceVariableNames: 'hash' 315076 classVariableNames: '' 315077 poolDictionaries: '' 315078 category: 'Tests-Digital Signatures'! 315079!SecureHashAlgorithmTest commentStamp: '<historical>' prior: 0! 315080This is the unit test for the class SecureHashAlgorithm. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 315081 - http://www.c2.com/cgi/wiki?UnitTest 315082 - http://minnow.cc.gatech.edu/squeak/1547 315083 - the sunit class category! 315084 315085 315086!SecureHashAlgorithmTest methodsFor: 'testing - examples' stamp: 'md 4/21/2003 12:23'! 315087testExample1 315088 315089 "This is the first example from the specification document (FIPS PUB 180-1)" 315090 315091 hash := SecureHashAlgorithm new hashMessage: 'abc'. 315092 self assert: (hash = 16rA9993E364706816ABA3E25717850C26C9CD0D89D). 315093 ! ! 315094 315095!SecureHashAlgorithmTest methodsFor: 'testing - examples' stamp: 'md 4/21/2003 12:23'! 315096testExample2 315097 315098 "This is the second example from the specification document (FIPS PUB 180-1)" 315099 315100 hash := SecureHashAlgorithm new hashMessage: 315101 'abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq'. 315102 self assert: (hash = 16r84983E441C3BD26EBAAE4AA1F95129E5E54670F1).! ! 315103 315104!SecureHashAlgorithmTest methodsFor: 'testing - examples' stamp: 'md 4/21/2003 12:25'! 315105testExample3 315106 315107 "This is the third example from the specification document (FIPS PUB 180-1). 315108 This example may take several minutes." 315109 315110 hash := SecureHashAlgorithm new hashMessage: (String new: 1000000 withAll: $a). 315111 self assert: (hash = 16r34AA973CD4C4DAA4F61EEB2BDBAD27316534016F).! ! 315112Object subclass: #SecurityManager 315113 instanceVariableNames: 'privateKeyPair trustedKeys keysFileName' 315114 classVariableNames: 'Default' 315115 poolDictionaries: '' 315116 category: 'System-Support'! 315117 315118!SecurityManager methodsFor: 'accessing' stamp: 'ar 2/6/2001 16:19'! 315119addTrustedKey: aPublicKey 315120 "Add a public key to the list of trusted keys" 315121 trustedKeys := (trustedKeys copyWithout: aPublicKey) copyWith: aPublicKey.! ! 315122 315123!SecurityManager methodsFor: 'accessing' stamp: 'ar 2/6/2001 16:17'! 315124keysFileName 315125 ^keysFileName! ! 315126 315127!SecurityManager methodsFor: 'accessing' stamp: 'ar 2/6/2001 16:17'! 315128keysFileName: aFileName 315129 keysFileName := aFileName! ! 315130 315131!SecurityManager methodsFor: 'accessing' stamp: 'tak 3/15/2005 00:45'! 315132primSecureUserDirectory 315133 <primitive: 'primitiveGetSecureUserDirectory' module: 'SecurityPlugin'> 315134 ^ nil! ! 315135 315136!SecurityManager methodsFor: 'accessing' stamp: 'tak 3/15/2005 00:46'! 315137secureUserDirectory 315138 "SecurityManager default secureUserDirectory" 315139 | dir | 315140 dir := self primSecureUserDirectory. 315141 ^ dir 315142 ifNil: [FileDirectory default pathName] 315143 ifNotNil: [(FilePath pathName: dir isEncoded: true) asSqueakPathName]! ! 315144 315145!SecurityManager methodsFor: 'accessing' stamp: 'ar 2/6/2001 16:20'! 315146signingKey 315147 "Return the key used for signing projects" 315148 ^privateKeyPair ifNotNil:[privateKeyPair first]! ! 315149 315150!SecurityManager methodsFor: 'accessing' stamp: 'ar 2/6/2001 16:42'! 315151trustedKeys 315152 "Return an array of trusted public keys for verifying some project" 315153 privateKeyPair ifNil:[^trustedKeys]. 315154 ^{privateKeyPair second}, trustedKeys! ! 315155 315156!SecurityManager methodsFor: 'accessing' stamp: 'tak 12/17/2004 14:19'! 315157untrustedUserDirectory 315158 "SecurityManager default untrustedUserDirectory" 315159 | dir | 315160 dir := self primUntrustedUserDirectory. 315161 ^ dir 315162 ifNil: [FileDirectory default pathName] 315163 ifNotNil: [(FilePath pathName: dir isEncoded: true) asSqueakPathName]! ! 315164 315165 315166!SecurityManager methodsFor: 'filein/out' stamp: 'AlexandreBergel 7/30/2008 13:41'! 315167loadSecurityKeys 315168 "SecurityManager default loadSecurityKeys" 315169 "Load the keys file for the current user" 315170 | fd loc file keys | 315171 self isInRestrictedMode ifTrue: [ ^ self ]. "no point in even trying" 315172 loc := self secureUserDirectory. "where to get it from" 315173 loc last = FileDirectory pathNameDelimiter ifFalse:[ 315174 loc := loc copyWith: FileDirectory pathNameDelimiter. 315175 ]. 315176 315177 fd := FileDirectory on: loc. 315178 file := [fd readOnlyFileNamed: keysFileName] 315179 on: FileDoesNotExistException 315180 do:[:ex| ^ self "no keys file"]. 315181 315182 keys := Object readFrom: file. 315183 privateKeyPair := keys first. 315184 trustedKeys := keys last. 315185 file close.! ! 315186 315187 315188!SecurityManager methodsFor: 'initialization' stamp: 'ar 2/6/2001 16:24'! 315189flushSecurityKey: aKey 315190 "Flush a security key" 315191 | n | 315192 n := aKey first. 315193 1 to: n basicSize do:[:i| n basicAt: i put: 0]. 315194 n := aKey second. 315195 1 to: n basicSize do:[:i| n basicAt: i put: 0]. 315196! ! 315197 315198!SecurityManager methodsFor: 'initialization' stamp: 'ar 2/6/2001 16:23'! 315199flushSecurityKeys 315200 "Flush all keys" 315201 privateKeyPair ifNotNil:[ 315202 self flushSecurityKey: privateKeyPair first. 315203 self flushSecurityKey: privateKeyPair last. 315204 ]. 315205 privateKeyPair := nil. 315206 trustedKeys do:[:key| self flushSecurityKey: key]. 315207 trustedKeys := #().! ! 315208 315209!SecurityManager methodsFor: 'initialization' stamp: 'adrian_lienhard 7/18/2009 16:01'! 315210initialize 315211 super initialize. 315212 privateKeyPair := nil. 315213 trustedKeys := #(). 315214 keysFileName := 'Pharo.keys'.! ! 315215 315216!SecurityManager methodsFor: 'initialization' stamp: 'ar 2/6/2001 16:22'! 315217shutDown 315218 "Flush existing keys" 315219 self flushSecurityKeys.! ! 315220 315221!SecurityManager methodsFor: 'initialization' stamp: 'ar 2/6/2001 18:28'! 315222startUp 315223 "Attempt to load existing keys" 315224 self loadSecurityKeys. 315225 (privateKeyPair == nil 315226 and:[self isInRestrictedMode not 315227 and:[Preferences automaticKeyGeneration]]) ifTrue:[ 315228 self generateKeyPairInBackground. 315229 ].! ! 315230 315231 315232!SecurityManager methodsFor: 'nil' stamp: 'sw 1/25/2002 12:41'! 315233storeSecurityKeys 315234 "Store the keys file for the current user" 315235 "SecurityManager default storeSecurityKeys" 315236 315237 | fd loc file | 315238 self isInRestrictedMode ifTrue:[^self]. "no point in even trying" 315239 loc := self secureUserDirectory. "where to put it" 315240 loc last = FileDirectory pathNameDelimiter ifFalse: 315241 [loc := loc copyWith: FileDirectory pathNameDelimiter]. 315242 fd := FileDirectory on: loc. 315243 fd assureExistence. 315244 fd deleteFileNamed: self keysFileName ifAbsent:[]. 315245 file := fd newFileNamed: self keysFileName. 315246 {privateKeyPair. trustedKeys} storeOn: file. 315247 file close! ! 315248 315249 315250!SecurityManager methodsFor: 'security operations' stamp: 'ar 2/6/2001 16:14'! 315251disableFileAccess 315252 "SecurityManager default disableFileAccess" 315253 "Primitive. Disable unlimited access to files. 315254 Cannot be revoked from the image." 315255 <primitive: 'primitiveDisableFileAccess' module: 'FilePlugin'> 315256 ^self primitiveFailed! ! 315257 315258!SecurityManager methodsFor: 'security operations' stamp: 'ar 2/6/2001 16:15'! 315259disableImageWrite 315260 "SecurityManager default disableImageWrite" 315261 "Primitive. Disable writing to an image file. 315262 Cannot be revoked from the image." 315263 <primitive: 'primitiveDisableImageWrite' module: 'SecurityPlugin'> 315264 ^self primitiveFailed! ! 315265 315266!SecurityManager methodsFor: 'security operations' stamp: 'ar 2/6/2001 16:15'! 315267disableSocketAccess 315268 "SecurityManage default disableSocketAccess" 315269 "Primitive. Disable access to sockets. 315270 Cannot be revoked from the image." 315271 <primitive: 'primitiveDisableSocketAccess' module: 'SocketPlugin'> 315272 ^self primitiveFailed! ! 315273 315274!SecurityManager methodsFor: 'security operations' stamp: 'rbb 2/18/2005 14:27'! 315275enterRestrictedMode 315276 "Some insecure contents was encountered. Close all doors and proceed." 315277 self isInRestrictedMode ifTrue:[^true]. 315278 Preferences securityChecksEnabled ifFalse:[^true]. "it's been your choice..." 315279 Preferences warnAboutInsecureContent ifTrue:[ 315280 ( UIManager default chooseFrom: #('Load it anyways' 'Do not load it') 315281 title: 315282'You are about to load some insecure content. 315283If you continue, access to files as well as 315284some other capabilities will be limited.') 315285 = 1 ifFalse:[ 315286 "user doesn't really want it" 315287 ^false. 315288 ]. 315289 ]. 315290 "here goes the actual restriction" 315291 self flushSecurityKeys. 315292 self disableFileAccess. 315293 self disableImageWrite. 315294 "self disableSocketAccess." 315295 FileDirectory setDefaultDirectory: self untrustedUserDirectory. 315296 ^true 315297! ! 315298 315299!SecurityManager methodsFor: 'security operations' stamp: 'sd 1/30/2004 15:22'! 315300fileInObjectAndCode: aStream 315301 | trusted | 315302 trusted := self positionToSecureContentsOf: aStream. 315303 trusted ifFalse:[self enterRestrictedMode ifFalse:[ 315304 aStream close. 315305 ^nil]]. 315306 ^aStream fileInObjectAndCode! ! 315307 315308!SecurityManager methodsFor: 'security operations' stamp: 'RAA 3/2/2002 14:33'! 315309positionToSecureContentsOf: aStream 315310 | bytes trusted part1 part2 sig hash dsa okay pos | 315311 aStream binary. 315312 pos := aStream position. 315313 bytes := aStream next: 4. 315314 bytes = 'SPRJ' asByteArray ifFalse:[ 315315 "was not signed" 315316 aStream position: pos. 315317 ^false]. 315318 part1 := (aStream nextInto: (LargePositiveInteger basicNew: 20)) normalize. 315319 part2 := (aStream nextInto: (LargePositiveInteger basicNew: 20)) normalize. 315320 sig := Array with: part1 with: part2. 315321 hash := SecureHashAlgorithm new hashStream: aStream. 315322 dsa := DigitalSignatureAlgorithm new. 315323 trusted := self trustedKeys. 315324 okay := (trusted detect:[:key| dsa verifySignature: sig ofMessageHash: hash publicKey: key] 315325 ifNone:[nil]) notNil. 315326 aStream position: pos+44. 315327 ^okay! ! 315328 315329!SecurityManager methodsFor: 'security operations' stamp: 'dc 5/30/2008 10:17'! 315330signFile: fileName directory: fileDirectory 315331 "Sign the given project in the directory" 315332 | bytes file dsa hash sig key | 315333 Preferences signProjectFiles ifFalse: [ ^ self ]. "signing turned off" 315334 key := self signingKey. 315335 key ifNil: [ ^ self ]. 315336 file := FileStream readOnlyFileNamed: (fileDirectory fullNameFor: fileName). 315337 bytes := file 315338 binary; 315339 contentsOfEntireFile. 315340 fileDirectory 315341 deleteFileNamed: fileName 315342 ifAbsent: [ ]. 315343 dsa := DigitalSignatureAlgorithm new. 315344 dsa initRandom: Time millisecondClockValue + Date today julianDayNumber. 315345 hash := SecureHashAlgorithm new hashStream: bytes readStream. 315346 sig := dsa 315347 computeSignatureForMessageHash: hash 315348 privateKey: key. 315349 file := FileStream newFileNamed: (fileDirectory fullNameFor: fileName). 315350 file binary. 315351 "store a header identifying the signed file first" 315352 file nextPutAll: 'SPRJ' asByteArray. 315353 "now the signature" 315354 file 315355 nextPutAll: (sig first withAtLeastNDigits: 20); 315356 nextPutAll: (sig last withAtLeastNDigits: 20). 315357 "now the contents" 315358 file nextPutAll: bytes. 315359 file close! ! 315360 315361 315362!SecurityManager methodsFor: 'testing' stamp: 'ar 2/6/2001 16:14'! 315363canWriteImage 315364 "SecurityManager default canWriteImage" 315365 "Primitive. Return true if the right to write an image hasn't been revoked." 315366 <primitive: 'primitiveCanWriteImage' module: 'SecurityPlugin'> 315367 ^true "assume so unless otherwise proven"! ! 315368 315369!SecurityManager methodsFor: 'testing' stamp: 'ar 2/6/2001 16:16'! 315370hasFileAccess 315371 "SecurityManager default hasFileAccess" 315372 "Return true if the right to access arbitrary files hasn't been revoked" 315373 <primitive: 'primitiveHasFileAccess' module: 'FilePlugin'> 315374 ^true "assume so unless otherwise proven"! ! 315375 315376!SecurityManager methodsFor: 'testing' stamp: 'ar 2/6/2001 16:16'! 315377hasSocketAccess 315378 "SecurityManager default hasSocketAccess" 315379 "Return true if the right to access sockets hasn't been revoked" 315380 <primitive: 'primitiveHasSocketAccess' module: 'SocketPlugin'> 315381 ^true "assume so unless otherwise proven"! ! 315382 315383!SecurityManager methodsFor: 'testing' stamp: 'ar 2/6/2001 16:13'! 315384isInRestrictedMode 315385 "Return true if we're in restricted mode" 315386 ^(self canWriteImage 315387 or:[self hasFileAccess 315388 "or:[self hasSocketAccess]"]) not! ! 315389 315390 315391!SecurityManager methodsFor: 'private' stamp: 'adrian_lienhard 7/18/2009 16:01'! 315392generateKeyPairInBackground 315393 "SecurityManager default generateKeyPairInBackground" 315394 "Silently generate a key set on the local machine while running in the background." 315395 | guesstimate startTime | 315396 guesstimate := [ 10 benchmark ] timeToRun * 150. 315397 startTime := Time millisecondClockValue. 315398 privateKeyPair := nil. 315399 [ self generateLocalKeyPair ] fork. 315400 UIManager default informUserDuring: 315401 [ :bar | 315402 [ privateKeyPair == nil ] whileTrue: 315403 [ bar value: 'Initializing security system (' , ((Time millisecondClockValue - startTime) * 100 // guesstimate) printString , '%)'. 315404 (Delay forSeconds: 1) wait ] ]! ! 315405 315406!SecurityManager methodsFor: 'private' stamp: 'sd 9/30/2003 13:58'! 315407generateLocalKeyPair 315408 "SecurityManager default generateLocalKeyPair" 315409 "Generate a key set on the local machine." 315410 | dsa | 315411 dsa := DigitalSignatureAlgorithm new. 315412 dsa initRandomFromString: 315413 Time millisecondClockValue printString, 315414 Date today printString, 315415 SmalltalkImage current platformName printString. 315416 privateKeyPair := dsa generateKeySet. 315417 self storeSecurityKeys.! ! 315418 315419!SecurityManager methodsFor: 'private' stamp: 'tak 12/17/2004 14:15'! 315420primUntrustedUserDirectory 315421 "Primitive. Return the untrusted user directory that is the root directory for files that are visible even in restricted mode." 315422 <primitive: 'primitiveGetUntrustedUserDirectory' module: 'SecurityPlugin'> 315423 ^ nil! ! 315424 315425!SecurityManager methodsFor: 'private' stamp: 'mir 11/10/2003 16:14'! 315426printStateOn: stream 315427 "Print the current state of myself onto stream. 315428 Used to gather information in the debug log." 315429 315430 stream 315431 nextPutAll: 'SecurityManager state:'; cr; 315432 nextPutAll: 'Restricted: '; nextPutAll: self isInRestrictedMode asString; cr; 315433 nextPutAll: 'FileAccess: '; nextPutAll: self hasFileAccess asString; cr; 315434 nextPutAll: 'SocketAccess: '; nextPutAll: self hasSocketAccess asString; cr; 315435 nextPutAll: 'Working Dir '; nextPutAll: FileDirectory default pathName asString; cr; 315436 nextPutAll: 'Trusted Dir '; nextPutAll: self secureUserDirectory asString; cr; 315437 nextPutAll: 'Untrusted Dir '; nextPutAll: self untrustedUserDirectory asString; cr; 315438 cr! ! 315439 315440"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 315441 315442SecurityManager class 315443 instanceVariableNames: ''! 315444 315445!SecurityManager class methodsFor: 'accessing' stamp: 'nk 7/30/2004 21:50'! 315446default 315447 ^Default ifNil: [Default := self new]! ! 315448 315449 315450!SecurityManager class methodsFor: 'initialization' stamp: 'nk 7/30/2004 21:50'! 315451initialize 315452 "SecurityManager initialize" 315453 315454 "Order: ExternalSettings, SecurityManager, AutoStart" 315455 315456 Default := self new. 315457 Smalltalk addToStartUpList: self after: ExternalSettings. 315458 Smalltalk addToShutDownList: self! ! 315459 315460!SecurityManager class methodsFor: 'initialization' stamp: 'ar 2/6/2001 16:46'! 315461shutDown 315462 self default shutDown.! ! 315463 315464!SecurityManager class methodsFor: 'initialization' stamp: 'ar 2/6/2001 17:12'! 315465startUp 315466 self default startUp.! ! 315467CompositionScanner subclass: #SegmentScanner 315468 instanceVariableNames: '' 315469 classVariableNames: '' 315470 poolDictionaries: 'TextConstants' 315471 category: 'Graphics-Text'! 315472 315473!SegmentScanner methodsFor: 'as yet unclassified' stamp: 'lr 7/4/2009 10:42'! 315474setFont 315475 super setFont. 315476 "Make a local copy of stop conditions so we don't modify the default" 315477 stopConditions == DefaultStopConditions ifTrue: [ stopConditions := stopConditions copy ]. 315478 stopConditions 315479 at: Space asciiValue + 1 315480 put: nil! ! 315481ImageMorph subclass: #SelectedObjectThumbnail 315482 instanceVariableNames: 'noSelectedThumbnail noSelectedBalloonText' 315483 classVariableNames: '' 315484 poolDictionaries: '' 315485 category: 'Morphic-Widgets'! 315486 315487!SelectedObjectThumbnail methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 11/14/2006 14:13'! 315488step 315489 "Update the image to be a thumbnail of the morph under the hand. 315490 Optimized to not constantly update." 315491 315492 | current | 315493 current := self selectedObject. 315494 current == (self valueOfProperty: #currentSelectedObject) 315495 ifTrue: [^self]. 315496 self setProperty: #currentSelectedObject toValue: current. 315497 self setBalloonText: (current isNil 315498 ifTrue: [noSelectedBalloonText] 315499 ifFalse: [current externalName]). 315500 "" 315501 self makeThumbnailFrom: current! ! 315502 315503 315504!SelectedObjectThumbnail methodsFor: 'accessing' stamp: 'dgd 9/10/2004 19:28'! 315505noSelectedBalloonText: aString 315506 "Set the balloon text to be used when no object is selected" 315507 noSelectedBalloonText := aString! ! 315508 315509!SelectedObjectThumbnail methodsFor: 'accessing' stamp: 'dgd 9/10/2004 19:27'! 315510noSelectedThumbnail: aForm 315511 "Set the form to be used when no object is selected" 315512 noSelectedThumbnail := aForm! ! 315513 315514 315515!SelectedObjectThumbnail methodsFor: 'initialization' stamp: 'dgd 9/10/2004 19:00'! 315516initialize 315517 "Initialize the receiver" 315518 super initialize. 315519 "" 315520 self 315521 image: (Form extent:32@32). 315522 self color: Color transparent! ! 315523 315524!SelectedObjectThumbnail methodsFor: 'initialization' stamp: 'dgd 9/10/2004 19:29'! 315525initializeExtent: aPoint noSelectedThumbnail: aForm noSelectedBalloonText: aString 315526 self 315527 image: (Form extent: aPoint). 315528"" 315529 noSelectedThumbnail := aForm. 315530 noSelectedBalloonText := aString! ! 315531 315532 315533!SelectedObjectThumbnail methodsFor: 'stepping and presenter' stamp: 'dgd 9/10/2004 18:36'! 315534stepTime 315535 ^ 125! ! 315536 315537 315538!SelectedObjectThumbnail methodsFor: 'private' stamp: 'dgd 9/10/2004 18:43'! 315539makeEmptyThumbnail 315540 315541^ self makeThumbnailOfColor: Color veryLightGray. 315542! ! 315543 315544!SelectedObjectThumbnail methodsFor: 'private' stamp: 'dgd 9/10/2004 18:43'! 315545makeErrorThumbnail 315546 ^ self makeThumbnailOfColor: Color red! ! 315547 315548!SelectedObjectThumbnail methodsFor: 'private' stamp: 'dgd 9/13/2004 12:57'! 315549makeThumbnailFrom: aMorphOrNil 315550 | thumbnail | 315551 thumbnail := aMorphOrNil isNil 315552 ifTrue: [noSelectedThumbnail 315553 ifNil: [self makeEmptyThumbnail]] 315554 ifFalse: [aMorphOrNil iconOrThumbnail]. 315555 "" 315556 self 315557 image: (thumbnail scaledIntoFormOfSize: self extent)! ! 315558 315559!SelectedObjectThumbnail methodsFor: 'private' stamp: 'dgd 9/10/2004 18:43'! 315560makeThumbnailOfColor: aColor 315561 | form | 315562 form := Form extent: self extent depth: 32. 315563 form getCanvas fillColor: aColor. 315564 self image: form! ! 315565 315566"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 315567 315568SelectedObjectThumbnail class 315569 instanceVariableNames: ''! 315570 315571!SelectedObjectThumbnail class methodsFor: 'instance creation' stamp: 'dgd 9/10/2004 19:31'! 315572extent: aPoint noSelectedThumbnail: aForm noSelectedBalloonText: aString 315573 ^ self new 315574 initializeExtent: aPoint 315575 noSelectedThumbnail: aForm 315576 noSelectedBalloonText: aString ! ! 315577PopUpMenu subclass: #SelectionMenu 315578 instanceVariableNames: 'selections' 315579 classVariableNames: '' 315580 poolDictionaries: '' 315581 category: 'ST80-Menus'! 315582 315583!SelectionMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:38'! 315584selections 315585 ^ selections! ! 315586 315587!SelectionMenu methodsFor: 'accessing' stamp: 'alain.plantec 2/9/2009 14:44'! 315588selections: selectionArray 315589 selections := selectionArray! ! 315590 315591 315592!SelectionMenu methodsFor: 'invocation' stamp: 'alain.plantec 2/9/2009 14:43'! 315593invokeOn: targetObject 315594 "Pop up this menu and return the result of sending 315595 to the target object the selector corresponding to 315596 the menu item selected by the user. Return 315597 nil if no item is selected. 315598 Example: 315599 ((SelectionMenu 315600 labels: 'sin\cos\neg' withCRs 315601 lines: #() 315602 selections: #(sin cos negated)) invokeOn: 0.7) 315603 " 315604 ^ self startUp 315605 ifNotNil: [:sel | targetObject perform: sel]! ! 315606 315607!SelectionMenu methodsFor: 'invocation' stamp: 'alain.plantec 2/9/2009 14:46'! 315608invokeOn: targetObject orSendTo: anObject 315609 "Pop up the receiver, obtaining a selector; return 315610 the result of having the target object perform the 315611 selector. If it dos not understand the selector, give 315612 the alternate object a chance" 315613 ^ self startUp 315614 ifNotNil: [:aSelector | (targetObject respondsTo: aSelector) 315615 ifTrue: [targetObject perform: aSelector] 315616 ifFalse: [anObject perform: aSelector]]! ! 315617 315618!SelectionMenu methodsFor: 'invocation' stamp: 'alain.plantec 2/9/2009 15:25'! 315619startUpWithCaption: captionOrNil icon: aForm at: location allowKeyboard: aBoolean 315620 "Overridden to return value returned by 315621 manageMarker. The boolean parameter indicates 315622 whether the menu should be given keyboard focus" 315623 | index | 315624 index := super 315625 startUpWithCaption: captionOrNil 315626 icon: aForm 315627 at: location 315628 allowKeyboard: aBoolean. 315629 ^ index 315630 ifNotNil: [(selections isNil 315631 or: [(index between: 1 and: selections size) not]) 315632 ifFalse: [selections at: index]]! ! 315633 315634"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 315635 315636SelectionMenu class 315637 instanceVariableNames: ''! 315638 315639!SelectionMenu class methodsFor: 'instance creation' stamp: 'alain.plantec 2/9/2009 15:20'! 315640fromArray: anArray 315641 "Construct a menu from anArray. The elements of anArray must be either: 315642 * A pair of the form: <label> <selector> or 315643 * The 'dash' (or 'minus sign') symbol 315644 315645 Refer to the example at the bottom of the method 315646 315647 Example: 315648 ((SelectionMenu fromArray: 315649 {{Text string: 'first label' emphasis: (Array with: TextEmphasis bold). #moja}. 315650 {'second label'. #mbili}. 315651 #-. 315652 {'third label'. #tatu}. 315653 #-. 315654 {'fourth label'. #nne}. 315655 {'fifth label'. #tano}}) startUp) 315656 " 315657 | labelList lines selections anIndex | 315658 labelList := OrderedCollection new. 315659 lines := OrderedCollection new. 315660 selections := OrderedCollection new. 315661 anIndex := 0. 315662 anArray do: 315663 [:anElement | 315664 anElement size == 1 315665 ifTrue: 315666 [(anElement == #-) ifFalse: [self error: 'badly-formed menu constructor']. 315667 lines add: anIndex] 315668 ifFalse: 315669 [anElement size == 2 ifFalse: [self error: 'badly-formed menu constructor']. 315670 anIndex := anIndex + 1. 315671 labelList add: anElement first. 315672 selections add: anElement second]]. 315673 ^ self labelList: labelList lines: lines selections: selections 315674 315675! ! 315676 315677!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'! 315678labelList: labelList 315679 ^ self labelArray: labelList! ! 315680 315681!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'! 315682labelList: labelList lines: lines 315683 ^ self labelArray: lines lines: lines! ! 315684 315685!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'! 315686labelList: labelList lines: lines selections: selections 315687 ^ (self labelArray: labelList lines: lines) selections: selections! ! 315688 315689!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'! 315690labelList: labelList selections: selections 315691 ^ self 315692 labelList: labelList 315693 lines: #() 315694 selections: selections! ! 315695 315696!SelectionMenu class methodsFor: 'instance creation' stamp: 'alain.plantec 2/9/2009 14:51'! 315697labels: labels lines: linesArray 315698 "Answer an instance of me whose items are in labels, with lines drawn 315699 after each item indexed by linesArray. Labels can be either a string 315700 with embedded CRs, or a collection of strings." 315701 315702 ^ (labels isString) 315703 ifTrue: [super labels: labels lines: linesArray] 315704 ifFalse: [super labelArray: labels lines: linesArray]! ! 315705 315706!SelectionMenu class methodsFor: 'instance creation' stamp: 'alain.plantec 2/9/2009 14:52'! 315707labels: labels lines: linesArray selections: selectionsArray 315708 "Answer an instance of me whose items are in labels, with lines drawn 315709 after each item indexed by linesArray. Labels can be either a string 315710 with embedded CRs, or a collection of strings. Record the given array of 315711 selections corresponding to the items in labels." 315712 315713 | labelString | 315714 (labels isString) 315715 ifTrue: [labelString := labels] 315716 ifFalse: [labelString := String streamContents: 315717 [:s | 315718 labels do: [:l | s nextPutAll: l; cr]. 315719 s skip: -1]]. 315720 ^ (self labels: labelString lines: linesArray) selections: selectionsArray 315721! ! 315722 315723!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:10'! 315724labels: labels selections: selectionsArray 315725 "Answer an instance of me whose items are in labels, recording 315726 the given array of selections corresponding to the items in labels." 315727 315728 ^ self 315729 labels: labels 315730 lines: #() 315731 selections: selectionsArray! ! 315732 315733!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:10'! 315734selections: selectionsArray 315735 "Answer an instance of me whose labels and selections are identical." 315736 315737 ^ self selections: selectionsArray lines: nil! ! 315738 315739!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:10'! 315740selections: selectionsArray lines: linesArray 315741 "Answer an instance of me whose labels and selections are identical." 315742 315743 ^ self 315744 labelList: (selectionsArray collect: [:each | each asString]) 315745 lines: linesArray 315746 selections: selectionsArray! ! 315747BorderedMorph subclass: #SelectionMorph 315748 instanceVariableNames: 'selectedItems slippage dupLoc dupDelta itemsAlreadySelected otherSelection undoProperties' 315749 classVariableNames: '' 315750 poolDictionaries: '' 315751 category: 'Morphic-Support'! 315752!SelectionMorph commentStamp: '<historical>' prior: 0! 315753A selectionMorph supports the selection of multiple objects in a morphic world or pasteUp. 315754 315755Structure: 315756 selectedItems an OrderedCollection of Morphs 315757 These are the morphs that have been selected 315758 slippage a Point 315759 Keeps track of actual movement between the 315760 steps of gridded movement 315761 dupLoc a Point 315762 Notes the position when first duplicate request occurs from halo 315763 dupDelta a Point 315764 Holds the final delta of the first duplicate plus subsequent moves. 315765! 315766 315767 315768!SelectionMorph methodsFor: 'accessing' stamp: 'nk 9/4/2004 17:33'! 315769borderColor: aColor 315770 315771 | bordered | 315772 bordered := selectedItems. 315773 undoProperties ifNil: [undoProperties := bordered collect: [:m | m borderColor]]. 315774 bordered do: [:m | m borderColor: aColor]! ! 315775 315776!SelectionMorph methodsFor: 'accessing' stamp: 'di 9/19/2000 18:25'! 315777borderWidth: aWidth 315778 315779 | bordered | 315780 bordered := selectedItems select: [:m | m isKindOf: BorderedMorph]. 315781 undoProperties ifNil: [undoProperties := bordered collect: [:m | m borderWidth]]. 315782 bordered do: [:m | m borderWidth: aWidth]! ! 315783 315784!SelectionMorph methodsFor: 'accessing' stamp: 'dgd 9/11/2004 21:57'! 315785wantsToBeTopmost 315786 "Answer if the receiver want to be one of the topmost objects in 315787 its owner" 315788 ^ true! ! 315789 315790 315791!SelectionMorph methodsFor: 'drawing' stamp: 'ar 9/1/2000 14:25'! 315792drawOn: aCanvas 315793 315794 | canvas form1 form2 box | 315795 super drawOn: aCanvas. 315796 box := self bounds. 315797 selectedItems do: [:m | box := box merge: m fullBounds]. 315798 box := box expandBy: 1. 315799 canvas := Display defaultCanvasClass extent: box extent depth: 8. 315800 canvas translateBy: box topLeft negated 315801 during: [:tempCanvas | selectedItems do: [:m | tempCanvas fullDrawMorph: m]]. 315802 form1 := (Form extent: box extent) copyBits: (0@0 extent: box extent) from: canvas form at: 0@0 colorMap: (Color maskingMap: 8). 315803 form2 := Form extent: box extent. 315804 (0@0) fourNeighbors do: [:d | form1 displayOn: form2 at: d rule: Form under]. 315805 form1 displayOn: form2 at: 0@0 rule: Form erase. 315806 aCanvas stencil: form2 315807 at: box topLeft 315808 sourceRect: form2 boundingBox 315809 color: self borderColor 315810! ! 315811 315812 315813!SelectionMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/10/2000 15:02'! 315814aboutToBeGrabbedBy: aHand 315815 slippage := 0@0. 315816 ^ super aboutToBeGrabbedBy: aHand 315817! ! 315818 315819!SelectionMorph methodsFor: 'dropping/grabbing' stamp: 'stephane.ducasse 4/13/2009 21:09'! 315820justDroppedInto: newOwner event: evt 315821 315822 selectedItems isEmpty ifTrue: 315823 ["Hand just clicked down to draw out a new selection" 315824 ^ self extendByHand: evt hand]. 315825 dupLoc ifNotNil: [dupDelta := self position - dupLoc]. 315826 selectedItems reverseDo: [:m | 315827 WorldState addDeferredUIMessage: 315828 [m referencePosition: (newOwner localPointToGlobal: m referencePosition). 315829 newOwner handleDropMorph: 315830 (DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)]]. 315831 evt wasHandled: true! ! 315832 315833!SelectionMorph methodsFor: 'dropping/grabbing' stamp: 'nk 6/26/2002 08:23'! 315834slideToTrash: evt 315835 self delete. 315836 selectedItems do: [:m | m slideToTrash: evt]! ! 315837 315838 315839!SelectionMorph methodsFor: 'geometry' stamp: 'jcg 2/14/2001 08:58'! 315840bounds: newBounds 315841 "Make sure position: gets called before extent:; Andreas' optimization for growing/shrinking in ChangeSet 3119 screwed up selection of morphs from underlying pasteup." 315842 315843 selectedItems := OrderedCollection new. "Avoid repostioning items during super position:" 315844 self position: newBounds topLeft; extent: newBounds extent 315845! ! 315846 315847!SelectionMorph methodsFor: 'geometry' stamp: 'di 8/31/2000 18:39'! 315848extent: newExtent 315849 315850 super extent: newExtent. 315851 self selectSubmorphsOf: self pasteUpMorph! ! 315852 315853 315854!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:53'! 315855addCustomMenuItems: aMenu hand: aHandMorph 315856 "Add custom menu items to the menu" 315857 315858 super addCustomMenuItems: aMenu hand: aHandMorph. 315859 aMenu addLine. 315860 aMenu add: 'add or remove items' translated target: self selector: #addOrRemoveItems: argument: aHandMorph. 315861 aMenu addList: { 315862 #-. 315863 {'place into a row' translated. #organizeIntoRow}. 315864 {'place into a column' translated. #organizeIntoColumn}. 315865 #-. 315866 {'align left edges' translated. #alignLeftEdges}. 315867 {'align top edges' translated. #alignTopEdges}. 315868 {'align right edges' translated. #alignRightEdges}. 315869 {'align bottom edges' translated. #alignBottomEdges}. 315870 #-. 315871 {'align centers vertically' translated. #alignCentersVertically}. 315872 {'align centers horizontally' translated. #alignCentersHorizontally}. 315873 }. 315874 315875 self selectedItems size > 2 315876 ifTrue:[ 315877 aMenu addList: { 315878 #-. 315879 {'distribute vertically' translated. #distributeVertically}. 315880 {'distribute horizontally' translated. #distributeHorizontally}. 315881 }. 315882 ]. 315883! ! 315884 315885!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 10/26/2004 14:53'! 315886addOrRemoveItems: handOrEvent 315887 "Make a new selection extending the current one." 315888 315889 | hand | 315890 hand := (handOrEvent isMorphicEvent) 315891 ifFalse: [handOrEvent] 315892 ifTrue: [handOrEvent hand]. 315893 hand 315894 addMorphBack: ((self class 315895 newBounds: (hand lastEvent cursorPoint extent: 16 @ 16)) 315896 setOtherSelection: self). 315897! ! 315898 315899!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:40'! 315900alignBottomEdges 315901 "Make the bottom coordinate of all my elements be the same" 315902 315903 | maxBottom | 315904 maxBottom := (selectedItems collect: [:itm | itm bottom]) max. 315905 selectedItems do: 315906 [:itm | itm bottom: maxBottom]. 315907 315908 self changed 315909! ! 315910 315911!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:41'! 315912alignCentersHorizontally 315913 "Make every morph in the selection have the same vertical center as the topmost item." 315914 315915 | minLeft leftMost | 315916 selectedItems size > 1 ifFalse: [^ self]. 315917 minLeft := (selectedItems collect: [:itm | itm left]) min. 315918 leftMost := selectedItems detect: [:m | m left = minLeft]. 315919 selectedItems do: 315920 [:itm | itm center: (itm center x @ leftMost center y)]. 315921 315922 self changed 315923! ! 315924 315925!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:41'! 315926alignCentersVertically 315927 "Make every morph in the selection have the same horizontal center as the topmost item." 315928 315929 | minTop topMost | 315930 selectedItems size > 1 ifFalse: [^ self]. 315931 minTop := (selectedItems collect: [:itm | itm top]) min. 315932 topMost := selectedItems detect: [:m | m top = minTop]. 315933 selectedItems do: 315934 [:itm | itm center: (topMost center x @ itm center y)]. 315935 315936 self changed 315937! ! 315938 315939!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:41'! 315940alignLeftEdges 315941 "Make the left coordinate of all my elements be the same" 315942 315943 | minLeft | 315944 minLeft := (selectedItems collect: [:itm | itm left]) min. 315945 selectedItems do: 315946 [:itm | itm left: minLeft]. 315947 315948 self changed 315949! ! 315950 315951!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:41'! 315952alignRightEdges 315953 "Make the right coordinate of all my elements be the same" 315954 315955 | maxRight | 315956 maxRight := (selectedItems collect: [:itm | itm right]) max. 315957 selectedItems do: 315958 [:itm | itm right: maxRight]. 315959 315960 self changed 315961! ! 315962 315963!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:50'! 315964alignTopEdges 315965 "Make the top coordinate of all my elements be the same" 315966 315967 | minTop | 315968 minTop := (selectedItems collect: [:itm | itm top]) min. 315969 selectedItems do: 315970 [:itm | itm top: minTop]. 315971 315972 self changed 315973! ! 315974 315975!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:50'! 315976distributeHorizontally 315977 "Distribute the empty vertical space in a democratic way." 315978 | minLeft maxRight totalWidth currentLeft space | 315979 315980 self selectedItems size > 2 315981 ifFalse: [^ self]. 315982 315983 minLeft := self selectedItems anyOne left. 315984 maxRight := self selectedItems anyOne right. 315985 totalWidth := 0. 315986 self selectedItems 315987 do: [:each | 315988 minLeft := minLeft min: each left. 315989 maxRight := maxRight max: each right. 315990 totalWidth := totalWidth + each width]. 315991 315992 currentLeft := minLeft. 315993 space := (maxRight - minLeft - totalWidth / (self selectedItems size - 1)) rounded. 315994 (self selectedItems 315995 asSortedCollection: [:x :y | x left <= y left]) 315996 do: [:each | 315997 each left: currentLeft. 315998 currentLeft := currentLeft + each width + space]. 315999 316000 self changed 316001! ! 316002 316003!SelectionMorph methodsFor: 'halo commands' stamp: 'dgd 9/20/2004 13:51'! 316004distributeVertically 316005 "Distribute the empty vertical space in a democratic way." 316006 | minTop maxBottom totalHeight currentTop space | 316007 self selectedItems size > 2 316008 ifFalse: [^ self]. 316009 316010 minTop := self selectedItems anyOne top. 316011 maxBottom := self selectedItems anyOne bottom. 316012 totalHeight := 0. 316013 self selectedItems 316014 do: [:each | 316015 minTop := minTop min: each top. 316016 maxBottom := maxBottom max: each bottom. 316017 totalHeight := totalHeight + each height]. 316018 316019 currentTop := minTop. 316020 space := (maxBottom - minTop - totalHeight / (self selectedItems size - 1)) rounded. 316021 (self selectedItems asSortedCollection:[:x :y | x top <= y top]) 316022 do: [:each | 316023 each top: currentTop. 316024 currentTop := currentTop + each height + space]. 316025 316026 self changed 316027! ! 316028 316029!SelectionMorph methodsFor: 'halo commands' stamp: 'md 11/14/2003 17:18'! 316030doDup: evt fromHalo: halo handle: dupHandle 316031 316032 selectedItems := self duplicateMorphCollection: selectedItems. 316033 selectedItems do: [:m | self owner addMorph: m]. 316034 dupDelta isNil 316035 ifTrue: ["First duplicate operation -- note starting location" 316036 dupLoc := self position. 316037 evt hand grabMorph: self. 316038 halo removeAllHandlesBut: dupHandle] 316039 ifFalse: ["Subsequent duplicate does not grab, but only moves me and my morphs" 316040 dupLoc := nil. 316041 self position: self position + dupDelta] 316042! ! 316043 316044!SelectionMorph methodsFor: 'halo commands' stamp: 'stephane.ducasse 11/8/2008 15:08'! 316045duplicate 316046 "Make a duplicate of the receiver and havbe the hand grab it" 316047 316048 selectedItems := self duplicateMorphCollection: selectedItems. 316049 selectedItems reverseDo: [:m | (owner ifNil: [ActiveWorld]) addMorph: m]. 316050 dupLoc := self position. 316051 ActiveHand grabMorph: self. 316052 ! ! 316053 316054!SelectionMorph methodsFor: 'halo commands' stamp: 'tb 8/10/2003 14:47'! 316055organizeIntoColumn 316056 "Place my objects in a column-enforcing container" 316057 316058 ((AlignmentMorph inAColumn: (selectedItems asSortedCollection: [:x :y | x top < y top])) setNameTo: 'Column'; color: Color orange muchLighter; enableDragNDrop: true; yourself) openInHand 316059! ! 316060 316061!SelectionMorph methodsFor: 'halo commands' stamp: 'tb 8/10/2003 14:48'! 316062organizeIntoRow 316063 "Place my objects in a row-enforcing container" 316064 316065 ((AlignmentMorph inARow: (selectedItems asSortedCollection: [:x :y | x left < y left])) setNameTo: 'Row'; color: Color orange muchLighter; enableDragNDrop: true; yourself) openInHand 316066! ! 316067 316068 316069!SelectionMorph methodsFor: 'halos and balloon help' stamp: 'di 8/31/2000 22:29'! 316070addHandlesTo: aHaloMorph box: box 316071 | onlyThese | 316072 aHaloMorph haloBox: box. 316073 onlyThese := #(addDismissHandle: addMenuHandle: addGrabHandle: addDragHandle: addDupHandle: addHelpHandle: addGrowHandle: addFontSizeHandle: addFontStyleHandle: addFontEmphHandle: addRecolorHandle:). 316074 Preferences haloSpecifications do: 316075 [:aSpec | (onlyThese includes: aSpec addHandleSelector) ifTrue: 316076 [aHaloMorph perform: aSpec addHandleSelector with: aSpec]]. 316077 aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box! ! 316078 316079!SelectionMorph methodsFor: 'halos and balloon help' stamp: 'di 8/31/2000 22:59'! 316080addOptionalHandlesTo: aHalo box: box 316081 aHalo addHandleAt: box leftCenter color: Color blue icon: nil 316082 on: #mouseUp send: #addOrRemoveItems: to: self.! ! 316083 316084!SelectionMorph methodsFor: 'halos and balloon help' stamp: 'di 8/31/2000 22:59'! 316085balloonHelpTextForHandle: aHandle 316086 aHandle eventHandler firstMouseSelector == #addOrRemoveItems: 316087 ifTrue: [^'Add items to, or remove them from, this selection.']. 316088 ^ super balloonHelpTextForHandle: aHandle! ! 316089 316090!SelectionMorph methodsFor: 'halos and balloon help' stamp: 'dgd 9/11/2004 18:29'! 316091hasHalo: aBool 316092 super hasHalo: aBool. 316093 aBool 316094 ifFalse: [ (self hasProperty: #deleting) ifFalse: [self delete] ] 316095! ! 316096 316097 316098!SelectionMorph methodsFor: 'initialization' stamp: 'dgd 9/20/2004 13:57'! 316099defaultBorderColor 316100 "answer the default border color/fill style for the receiver" 316101 ^ (Preferences menuSelectionColor ifNil: [Color blue]) twiceDarker alpha: 0.75! ! 316102 316103!SelectionMorph methodsFor: 'initialization' stamp: 'dgd 9/20/2004 14:00'! 316104defaultColor 316105 "answer the default color/fill style for the receiver" 316106 ^ (Preferences menuSelectionColor ifNil: [Color blue]) alpha: 0.08 316107! ! 316108 316109!SelectionMorph methodsFor: 'initialization' stamp: 'dgd 9/11/2004 21:07'! 316110extendByHand: aHand 316111 "Assumes selection has just been created and added to some pasteUp or world" 316112 | startPoint handle | 316113 316114 startPoint := self position. 316115 316116 handle := NewHandleMorph new followHand: aHand 316117 forEachPointDo: [:newPoint | 316118 | localPt | 316119 localPt := (self transformFrom: self world) globalPointToLocal: newPoint. 316120 self bounds: (startPoint rect: localPt) 316121 ] 316122 lastPointDo: [:newPoint | 316123 selectedItems isEmpty 316124 ifTrue: [self delete] 316125 ifFalse: [ 316126 selectedItems size = 1 316127 ifTrue:[self delete. selectedItems anyOne addHalo] 316128 ifFalse:[self doneExtending] 316129 ] 316130 ]. 316131 316132 aHand attachMorph: handle. 316133 handle startStepping.! ! 316134 316135!SelectionMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:23'! 316136initialize 316137 "initialize the state of the receiver" 316138 super initialize. 316139 "" 316140 316141 selectedItems := OrderedCollection new. 316142 itemsAlreadySelected := OrderedCollection new. 316143 slippage := 0 @ 0! ! 316144 316145 316146!SelectionMorph methodsFor: 'menus' stamp: 'di 8/31/2000 20:50'! 316147maybeAddCollapseItemTo: aMenu 316148 "... don't "! ! 316149 316150 316151!SelectionMorph methodsFor: 'submorphs-add/remove' stamp: 'dgd 9/11/2004 18:27'! 316152delete 316153 self setProperty: #deleting toValue: true. 316154 super delete. 316155 ! ! 316156 316157!SelectionMorph methodsFor: 'submorphs-add/remove' stamp: 'di 8/23/2000 17:06'! 316158dismissViaHalo 316159 316160 super dismissViaHalo. 316161 selectedItems do: [:m | m dismissViaHalo]! ! 316162 316163 316164!SelectionMorph methodsFor: 'undo' stamp: 'di 8/31/2000 00:24'! 316165borderColorForItems: colorCollection 316166 316167 (selectedItems select: [:m | m isKindOf: BorderedMorph]) 316168 with: colorCollection 316169 do: [:m :c | m borderColor: c]! ! 316170 316171!SelectionMorph methodsFor: 'undo' stamp: 'di 8/31/2000 00:26'! 316172borderWidthForItems: widthCollection 316173 316174 (selectedItems select: [:m | m isKindOf: BorderedMorph]) 316175 with: widthCollection 316176 do: [:m :c | m borderWidth: c]! ! 316177 316178!SelectionMorph methodsFor: 'undo' stamp: 'di 9/19/2000 21:53'! 316179fillStyleForItems: fillStyleCollection 316180 316181 selectedItems with: fillStyleCollection do: [:m :c | m fillStyle: c]! ! 316182 316183!SelectionMorph methodsFor: 'undo' stamp: 'di 9/19/2000 21:52'! 316184refineUndoTarget: target selector: selector arguments: arguments in: refineBlock 316185 "Any morph can override this method to refine its undo specification" 316186 selector == #fillStyle: ifTrue: 316187 [refineBlock value: target value: #fillStyleForItems: value: {undoProperties}. 316188 ^ undoProperties := nil]. 316189 selector == #borderColor: ifTrue: 316190 [refineBlock value: target value: #borderColorForItems: value: {undoProperties}. 316191 ^ undoProperties := nil]. 316192 selector == #borderWidth: ifTrue: 316193 [refineBlock value: target value: #borderWidthForItems: value: {undoProperties}. 316194 ^ undoProperties := nil]. 316195 selector == #undoMove:redo:owner:bounds:predecessor: ifTrue: 316196 ["This is the biggy. Need to gather parameters for all selected items" 316197 refineBlock value: target 316198 value: #undoMove:redo:owner:bounds:predecessor: 316199 value: {arguments first. 316200 arguments second. 316201 selectedItems collect: [:m | m owner]. 316202 selectedItems collect: [:m | m bounds]. 316203 selectedItems collect: [:m | m owner morphPreceding: m]}]. 316204 refineBlock value: target value: selector value: arguments! ! 316205 316206!SelectionMorph methodsFor: 'undo' stamp: 'jm 2/25/2003 16:27'! 316207undoMove: cmd redo: redo owner: oldOwners bounds: oldBoundses predecessor: oldPredecessors 316208 "Handle undo and redo of move commands in morphic" 316209 316210 | item | 316211 redo 316212 ifFalse: 316213 ["undo sets up the redo state first" 316214 316215 cmd 316216 redoTarget: self 316217 selector: #undoMove:redo:owner:bounds:predecessor: 316218 arguments: { 316219 cmd. 316220 true. 316221 selectedItems collect: [:m | m owner]. 316222 selectedItems collect: [:m | m bounds]. 316223 selectedItems collect: [:m | m owner morphPreceding: m]}]. 316224 1 to: selectedItems size do: 316225 [:i | 316226 item := selectedItems at: i. 316227 (oldOwners at: i) ifNotNil: 316228 [(oldPredecessors at: i) ifNil: [(oldOwners at: i) addMorphFront: item] 316229 ifNotNil: [(oldOwners at: i) addMorph: item after: (oldPredecessors at: i)]]. 316230 item bounds: (oldBoundses at: i). 316231 item isSystemWindow ifTrue: [item activate]]! ! 316232 316233 316234!SelectionMorph methodsFor: 'viewer' stamp: 'dgd 8/29/2004 12:34'! 316235externalName 316236 ^ 'Selected {1} objects' translated format:{self selectedItems size}! ! 316237 316238 316239!SelectionMorph methodsFor: 'visual properties' stamp: 'di 9/19/2000 21:53'! 316240fillStyle: aColor 316241 undoProperties ifNil: [undoProperties := selectedItems collect: [:m | m fillStyle]]. 316242 selectedItems do: [:m | m fillStyle: aColor]! ! 316243 316244 316245!SelectionMorph methodsFor: 'wiw support' stamp: 'dgd 9/11/2004 21:58'! 316246morphicLayerNumber 316247 "helpful for insuring some morphs always appear in front of or 316248 behind others. smaller numbers are in front" 316249 ^ 8! ! 316250 316251 316252!SelectionMorph methodsFor: 'private' stamp: 'dgd 9/20/2004 14:01'! 316253doneExtending 316254 316255 otherSelection ifNotNil: 316256 [selectedItems := otherSelection selectedItems , selectedItems. 316257 otherSelection delete. 316258 self setOtherSelection: nil]. 316259 self changed. 316260 self layoutChanged. 316261 super privateBounds: 316262 ((Rectangle merging: (selectedItems collect: [:m | m fullBounds])) 316263 expandBy: 8). 316264 self changed. 316265 self addHalo.! ! 316266 316267!SelectionMorph methodsFor: 'private' stamp: 'nk 8/14/2003 08:12'! 316268privateFullMoveBy: delta 316269 316270 | griddedDelta griddingMorph | 316271 selectedItems isEmpty ifTrue: [^ super privateFullMoveBy: delta]. 316272 griddingMorph := self pasteUpMorph. 316273 griddingMorph ifNil: [^ super privateFullMoveBy: delta]. 316274 griddedDelta := (griddingMorph gridPoint: self position + delta + slippage) - 316275 (griddingMorph gridPoint: self position). 316276 slippage := slippage + (delta - griddedDelta). "keep track of how we lag the true movement." 316277 griddedDelta = (0@0) ifTrue: [^ self]. 316278 super privateFullMoveBy: griddedDelta. 316279 selectedItems do: 316280 [:m | m position: (m position + griddedDelta) ] 316281! ! 316282 316283!SelectionMorph methodsFor: 'private' stamp: 'di 8/31/2000 21:36'! 316284selectedItems 316285 316286 ^ selectedItems! ! 316287 316288!SelectionMorph methodsFor: 'private' stamp: 'di 8/31/2000 22:12'! 316289selectSubmorphsOf: aMorph 316290 316291 | newItems removals | 316292 newItems := aMorph submorphs select: 316293 [:m | (bounds containsRect: m fullBounds) 316294 and: [m~~self 316295 and: [(m isKindOf: HaloMorph) not]]]. 316296 otherSelection ifNil: [^ selectedItems := newItems]. 316297 316298 removals := newItems intersection: itemsAlreadySelected. 316299 otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals). 316300 selectedItems := (newItems copyWithoutAll: removals). 316301! ! 316302 316303!SelectionMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 23:18'! 316304setOtherSelection: otherOrNil 316305 otherSelection := otherOrNil. 316306 otherOrNil isNil 316307 ifTrue: [super borderColor: Color blue] 316308 ifFalse: 316309 [itemsAlreadySelected := otherSelection selectedItems. 316310 super borderColor: Color green]! ! 316311 316312!SelectionMorph methodsFor: 'private' stamp: 'di 8/31/2000 21:45'! 316313setSelectedItems: items 316314 316315 selectedItems := items. 316316 self changed! ! 316317 316318"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 316319 316320SelectionMorph class 316321 instanceVariableNames: ''! 316322 316323!SelectionMorph class methodsFor: 'scripting' stamp: 'dgd 8/26/2004 12:11'! 316324defaultNameStemForInstances 316325 ^ 'Selection'! ! 316326StringHolder subclass: #SelectorBrowser 316327 instanceVariableNames: 'selectorIndex selectorList classListIndex classList' 316328 classVariableNames: '' 316329 poolDictionaries: '' 316330 category: 'Tools-Browser'! 316331 316332!SelectorBrowser methodsFor: 'default' stamp: 'al 9/21/2008 19:51'! 316333initialExtent 316334 316335 ^ 400@300 316336! ! 316337 316338 316339!SelectorBrowser methodsFor: 'opening' stamp: 'sd 11/20/2005 21:27'! 316340morphicWindow 316341 "Create a Browser that lets you type part of a selector, shows a list of selectors, shows the classes of the one you chose, and spawns a full browser on it. Answer the window 316342 SelectorBrowser new open " 316343 316344 | window typeInView selectorListView classListView | 316345 window := (SystemWindow labelled: 'later') model: self. 316346 window setStripeColorsFrom: self defaultBackgroundColor. 316347 selectorIndex := classListIndex := 0. 316348 316349 typeInView := PluggableTextMorph on: self 316350 text: #contents accept: #contents:notifying: 316351 readSelection: #contentsSelection menu: #codePaneMenu:shifted:. 316352 typeInView acceptOnCR: true. 316353 typeInView hideScrollBarsIndefinitely. 316354 window addMorph: typeInView frame: (0@0 corner: 0.5@0.14). 316355 316356 selectorListView := PluggableListMorph on: self 316357 list: #messageList 316358 selected: #messageListIndex 316359 changeSelected: #messageListIndex: 316360 menu: #selectorMenu: 316361 keystroke: #messageListKey:from:. 316362 selectorListView menuTitleSelector: #selectorMenuTitle. 316363 window addMorph: selectorListView frame: (0@0.14 corner: 0.5@0.6). 316364 316365 classListView := PluggableListMorph on: self 316366 list: #classList 316367 selected: #classListIndex 316368 changeSelected: #classListIndex: 316369 menu: nil 316370 keystroke: #arrowKey:from:. 316371 classListView menuTitleSelector: #classListSelectorTitle. 316372 window addMorph: classListView frame: (0.5@0 corner: 1@0.6). 316373 window addMorph: ((PluggableTextMorph on: self text: #byExample 316374 accept: #byExample: 316375 readSelection: #contentsSelection menu: #codePaneMenu:shifted:) 316376 askBeforeDiscardingEdits: false) 316377 frame: (0@0.6 corner: 1@1). 316378 316379 window setLabel: 'Method Finder'. 316380 ^ window! ! 316381 316382!SelectorBrowser methodsFor: 'opening' stamp: 'alain.plantec 6/1/2008 20:13'! 316383open 316384 "Create a Browser that lets you type part of a selector, shows a list of selectors, 316385 shows the classes of the one you chose, and spwns a full browser on it. 316386 SelectorBrowser new open 316387 " 316388 ^ self openAsMorph! ! 316389 316390!SelectorBrowser methodsFor: 'opening' stamp: 'di 11/4/1999 13:55'! 316391openAsMorph 316392 "Create a Browser that lets you type part of a selector, shows a list of selectors, shows the classes of the one you chose, and spwns a full browser on it. 316393 SelectorBrowser new open " 316394 ^ self morphicWindow openInWorld! ! 316395 316396 316397!SelectorBrowser methodsFor: 'ui' stamp: 'tk 12/1/2000 10:38'! 316398byExample 316399 "The comment in the bottom pane" 316400 316401 false ifTrue: [MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10)]. 316402 "to keep the method methodFor: from being removed from the system" 316403 316404 ^ 'Type a fragment of a selector in the top pane. Accept it. 316405 316406Or, use an example to find a method in the system. Type receiver, args, and answer in the top pane with periods between the items. 3. 4. 7 316407 316408Or, in this pane, use examples to find a method in the system. Select the line of code and choose "print it". 316409 316410 MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10). 316411This will discover (data1 + data2). 316412 316413You supply inputs and answers and the system will find the method. Each inner array is a list of inputs. It contains the receiver and zero or more arguments. For Booleans and any computed arguments, use brace notation. 316414 316415 MethodFinder methodFor: { {1. 3}. true. {20. 10}. false}. 316416This will discover the expressions (data1 < data2), (data2 > data1), and many others. 316417 316418 MethodFinder methodFor: { {''29 Apr 1999'' asDate}. ''Thursday''. 316419 {''30 Apr 1999'' asDate}. ''Friday'' }. 316420This will discover the expression (data1 weekday) 316421 316422Receiver and arguments do not have to be in the right order. 316423See MethodFinder.verify for more examples.'! ! 316424 316425!SelectorBrowser methodsFor: 'ui' stamp: 'tk 3/29/1999 22:12'! 316426byExample: newText 316427 "Don't save it" 316428 ^ true! ! 316429 316430!SelectorBrowser methodsFor: 'ui' stamp: 'tk 8/26/1998 14:20'! 316431classList 316432 ^ classList! ! 316433 316434!SelectorBrowser methodsFor: 'ui' stamp: 'tk 8/26/1998 14:23'! 316435classListIndex 316436 ^ classListIndex! ! 316437 316438!SelectorBrowser methodsFor: 'ui' stamp: 'alain.plantec 6/11/2008 13:45'! 316439classListIndex: anInteger 316440 classListIndex := anInteger. 316441 classListIndex > 0 316442 ifTrue: [Browser fullOnClass: self selectedClass selector: self selectedMessageName]! ! 316443 316444!SelectorBrowser methodsFor: 'ui' stamp: 'tk 8/26/1998 14:33'! 316445classListSelectorTitle 316446 ^ 'Class List Menu'! ! 316447 316448!SelectorBrowser methodsFor: 'ui' stamp: 'sd 11/20/2005 21:27'! 316449contents: aString notifying: aController 316450 "Take what the user typed and find all selectors containing it" 316451 316452 | tokens raw sorted | 316453 contents := aString. 316454 classList := #(). classListIndex := 0. 316455 selectorIndex := 0. 316456 tokens := contents asString findTokens: ' .'. 316457 selectorList := Cursor wait showWhile: [ 316458 tokens size = 1 316459 ifTrue: [raw := (Symbol selectorsContaining: contents asString). 316460 sorted := raw as: SortedCollection. 316461 sorted sortBlock: [:x :y | x asLowercase <= y asLowercase]. 316462 sorted asArray] 316463 ifFalse: [self quickList]]. "find selectors from a single example of data" 316464 self changed: #messageList. 316465 self changed: #classList. 316466 ^ true! ! 316467 316468!SelectorBrowser methodsFor: 'ui' stamp: 'tk 1/8/2001 18:21'! 316469listFromResult: resultOC 316470 "ResultOC is of the form #('(data1 op data2)' '(...)'). Answer a sorted array." 316471 316472 (resultOC first beginsWith: 'no single method') ifTrue: [^ #()]. 316473 ^ resultOC sortBy: [:a :b | 316474 (a copyFrom: 6 to: a size) < (b copyFrom: 6 to: b size)]. 316475 316476! ! 316477 316478!SelectorBrowser methodsFor: 'ui' stamp: 'damiencassou 5/30/2008 16:29'! 316479markMatchingClasses 316480 "If an example is used, mark classes matching the example instance with an asterisk." 316481 | unmarkedClassList firstPartOfSelector receiverString receiver | 316482 self flag: #mref. "allows for old-fashioned style" 316483 316484 "Only 'example' queries can be marked." 316485 (contents asString includes: $.) ifFalse: [ ^ self ]. 316486 unmarkedClassList := classList copy. 316487 316488 "Get the receiver object of the selected statement in the message list." 316489 firstPartOfSelector := (Scanner new scanTokens: (selectorList at: selectorIndex)) second. 316490 receiverString := (selectorList at: selectorIndex) readStream upToAll: firstPartOfSelector. 316491 receiver := Compiler evaluate: receiverString. 316492 unmarkedClassList do: 316493 [ :classAndMethod | 316494 | class | 316495 (classAndMethod isKindOf: MethodReference) 316496 ifTrue: 316497 [ (receiver isKindOf: classAndMethod actualClass) ifTrue: [ classAndMethod stringVersion: '*' , classAndMethod stringVersion ] ] 316498 ifFalse: 316499 [ class := Compiler evaluate: (classAndMethod readStream upToAll: firstPartOfSelector). 316500 (receiver isKindOf: class) ifTrue: 316501 [ classList add: '*' , classAndMethod. 316502 classList remove: classAndMethod ] ] ]! ! 316503 316504!SelectorBrowser methodsFor: 'ui' stamp: 'tk 8/26/1998 14:19'! 316505messageList 316506 "Find all the selectors containing what the user typed in." 316507 316508 ^ selectorList! ! 316509 316510!SelectorBrowser methodsFor: 'ui' stamp: 'tk 8/26/1998 10:58'! 316511messageListIndex 316512 "Answer the index of the selected message selector." 316513 316514 ^ selectorIndex! ! 316515 316516!SelectorBrowser methodsFor: 'ui' stamp: 'sd 11/20/2005 21:27'! 316517messageListIndex: anInteger 316518 "Set the selected message selector to be the one indexed by anInteger. 316519 Find all classes it is in." 316520 selectorIndex := anInteger. 316521 selectorIndex = 0 316522 ifTrue: [^ self]. 316523 classList := self systemNavigation allImplementorsOf: self selectedMessageName. 316524 self markMatchingClasses. 316525 classListIndex := 0. 316526 self changed: #messageListIndex. 316527 "update my selection" 316528 self changed: #classList! ! 316529 316530!SelectorBrowser methodsFor: 'ui' stamp: 'sma 2/6/2000 11:42'! 316531messageListKey: aChar from: view 316532 "Respond to a command key. Handle (m) and (n) here, 316533 else defer to the StringHolder behaviour." 316534 316535 aChar == $m ifTrue: [^ self implementors]. 316536 aChar == $n ifTrue: [^ self senders]. 316537 super messageListKey: aChar from: view 316538! ! 316539 316540!SelectorBrowser methodsFor: 'ui' stamp: 'ms 8/1/2006 16:48'! 316541quickList 316542 "Compute the selectors for the single example of receiver and args, in the very top pane" 316543 316544 | data result resultArray newExp dataStrings mf dataObjects aa statements | 316545 data := contents asString. 316546 "delete t 316547 railing period. This should be fixed in the Parser!!" 316548 [data last isSeparator] whileTrue: [data := data allButLast]. 316549 data last = $. ifTrue: [data := data allButLast]. "Eval" 316550 mf := MethodFinder new. 316551 data := mf cleanInputs: data. "remove common mistakes" 316552 dataObjects := Compiler evaluate: '{', data, '}'. "#( data1 data2 result )" 316553 statements := (Compiler new parse: 'zort ' , data in: Object notifying: nil) 316554 body statements select: [:each | (each isKindOf: ReturnNode) not]. 316555 dataStrings := statements collect: 316556 [:node | String streamContents: 316557 [:strm | (node isMessage) ifTrue: [strm nextPut: $(]. 316558 node shortPrintOn: strm. 316559 (node isMessage) ifTrue: [strm nextPut: $)].]]. 316560 dataObjects size < 2 ifTrue: [self inform: 'If you are giving an example of receiver, \args, and result, please put periods between the parts.\Otherwise just type one selector fragment' withCRs. ^#()]. 316561 dataObjects := Array with: dataObjects allButLast with: dataObjects last. "#( (data1 316562 data2) result )" 316563 result := mf load: dataObjects; findMessage. 316564 (result first beginsWith: 'no single method') ifFalse: [ 316565 aa := self testObjects: dataObjects strings: dataStrings. 316566 dataObjects := aa second. dataStrings := aa third]. 316567 resultArray := self listFromResult: result. 316568 resultArray isEmpty ifTrue: [self inform: result first]. 316569 316570 dataStrings size = (dataObjects first size + 1) ifTrue: 316571 [resultArray := resultArray collect: [:expression | 316572 newExp := expression. 316573 dataObjects first withIndexDo: [:lit :i | 316574 newExp := newExp copyReplaceAll: 'data', i printString 316575 with: (dataStrings at: i)]. 316576 newExp, ' --> ', dataStrings last]]. 316577 316578 ^ resultArray! ! 316579 316580!SelectorBrowser methodsFor: 'ui' stamp: 'alain.plantec 6/1/2008 20:14'! 316581searchResult: anExternalSearchResult 316582 316583 self contents: ''. 316584 classList := #(). classListIndex := 0. 316585 selectorIndex := 0. 316586 selectorList := self listFromResult: anExternalSearchResult. 316587 self changed: #messageList. 316588 self changed: #classList. 316589 self changed: #contents. 316590! ! 316591 316592!SelectorBrowser methodsFor: 'ui' stamp: 'sd 11/20/2005 21:27'! 316593selectedClass 316594 "Answer the currently selected class." 316595 316596 | pairString | 316597 316598 self flag: #mref. "allows for old-fashioned style" 316599 316600 classListIndex = 0 ifTrue: [^nil]. 316601 pairString := classList at: classListIndex. 316602 (pairString isKindOf: MethodReference) ifTrue: [ 316603 ^pairString actualClass 316604 ]. 316605 (pairString includes: $*) ifTrue: [pairString := pairString allButFirst]. 316606 MessageSet 316607 parse: pairString 316608 toClassAndSelector: [:cls :sel | ^ cls].! ! 316609 316610!SelectorBrowser methodsFor: 'ui' stamp: 'tk 8/27/1998 17:48'! 316611selectedClassName 316612 "Answer the name of the currently selected class." 316613 316614 classListIndex = 0 ifTrue: [^nil]. 316615 ^ self selectedClass name! ! 316616 316617!SelectorBrowser methodsFor: 'ui' stamp: 'sd 11/20/2005 21:27'! 316618selectedMessageName 316619 "Answer the name of the currently selected message." 316620 316621 | example tokens | 316622 selectorIndex = 0 ifTrue: [^nil]. 316623 example := selectorList at: selectorIndex. 316624 tokens := Scanner new scanTokens: example. 316625 tokens size = 1 ifTrue: [^ tokens first]. 316626 tokens first == #'^' ifTrue: [^ nil]. 316627 (tokens second includes: $:) ifTrue: [^ example findSelector]. 316628 Symbol hasInterned: tokens second ifTrue: [:aSymbol | ^ aSymbol]. 316629 ^ nil! ! 316630 316631!SelectorBrowser methodsFor: 'ui' stamp: 'alain.plantec 6/1/2008 20:15'! 316632selectorList: anExternalList 316633 316634 self contents: ''. 316635 classList := #(). classListIndex := 0. 316636 selectorIndex := 0. 316637 selectorList := anExternalList. 316638 self changed: #messageList. 316639 self changed: #classList. 316640 self changed: #contents. 316641 316642! ! 316643 316644!SelectorBrowser methodsFor: 'ui' stamp: 'adrian-lienhard 5/17/2009 21:48'! 316645selectorMenu: aMenu 316646 ^ aMenu labels: 'senders (n) 316647implementors (m) 316648copy selector to clipboard' 316649 lines: #() 316650 selections: #(senders implementors copyName)! ! 316651 316652!SelectorBrowser methodsFor: 'ui' stamp: 'sw 9/2/1998 16:37'! 316653selectorMenuTitle 316654 ^ self selectedMessageName ifNil: ['<no selection>']! ! 316655 316656!SelectorBrowser methodsFor: 'ui' stamp: 'sd 11/20/2005 21:27'! 316657testObjects: dataObjects strings: dataStrings 316658 | dataObjs dataStrs selectors classes didUnmodifiedAnswer answerMod do ds result ddo dds | 316659 "Try to make substitutions in the user's inputs and search for the selector again. 3166601 no change to answer. 3166612 answer Array -> OrderedCollection. 3166622 answer Character -> String 3166634 answer Symbol or String of len 1 -> Character 316664 For each of these, try straight, and try converting args: 316665Character -> String 316666Symbol or String of len 1 -> Character 316667 Return array with result, dataObjects, dataStrings. Don't ever do a find on the same set of data twice." 316668 316669dataObjs := dataObjects. dataStrs := dataStrings. 316670selectors := {#asString. #first. #asOrderedCollection}. 316671classes := {Character. String. Array}. 316672didUnmodifiedAnswer := false. 316673selectors withIndexDo: [:ansSel :ansInd | "Modify the answer object" 316674 answerMod := false. 316675 do := dataObjs copyTwoLevel. ds := dataStrs copy. 316676 (dataObjs last isKindOf: (classes at: ansInd)) ifTrue: [ 316677 ((ansSel ~~ #first) or: [dataObjs last size = 1]) ifTrue: [ 316678 do at: do size put: (do last perform: ansSel). "asString" 316679 ds at: ds size put: ds last, ' ', ansSel. 316680 result := MethodFinder new load: do; findMessage. 316681 (result first beginsWith: 'no single method') ifFalse: [ 316682 "found a selector!!" 316683 ^ Array with: result first with: do with: ds]. 316684 answerMod := true]]. 316685 316686 selectors allButLast withIndexDo: [:argSel :argInd | "Modify an argument object" 316687 "for args, no reason to do Array -> OrderedCollection. Identical protocol." 316688 didUnmodifiedAnswer not | answerMod ifTrue: [ 316689 ddo := do copyTwoLevel. dds := ds copy. 316690 dataObjs first withIndexDo: [:arg :ind | 316691 (arg isKindOf: (classes at: argInd)) ifTrue: [ 316692 ((argSel ~~ #first) or: [arg size = 1]) ifTrue: [ 316693 ddo first at: ind put: ((ddo first at: ind) perform: argSel). "asString" 316694 dds at: ind put: (dds at: ind), ' ', argSel. 316695 result := MethodFinder new load: ddo; findMessage. 316696 (result first beginsWith: 'no single method') ifFalse: [ 316697 "found a selector!!" 316698 ^ Array with: result first with: ddo with: dds] . 316699 didUnmodifiedAnswer not & answerMod not ifTrue: [ 316700 didUnmodifiedAnswer := true]. 316701 ]]]]]. 316702 ]. 316703^ Array with: 'no single method does that function' with: dataObjs with: dataStrs! ! 316704 316705 316706!SelectorBrowser methodsFor: 'utils' stamp: 'sd 11/20/2005 21:27'! 316707implementors 316708 | aSelector | 316709 (aSelector := self selectedMessageName) ifNotNil: 316710 [self systemNavigation browseAllImplementorsOf: aSelector]! ! 316711 316712!SelectorBrowser methodsFor: 'utils' stamp: 'sd 11/20/2005 21:27'! 316713senders 316714 | aSelector | 316715 (aSelector := self selectedMessageName) ifNotNil: 316716 [self systemNavigation browseAllCallsOn: aSelector]! ! 316717 316718"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 316719 316720SelectorBrowser class 316721 instanceVariableNames: ''! 316722 316723!SelectorBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 316724prototypicalToolWindow 316725 "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" 316726 316727 | aWindow | 316728 aWindow := self new morphicWindow. 316729 aWindow setLabel: 'Selector Browser'. 316730 aWindow applyModelExtent. 316731 ^ aWindow! ! 316732 316733 316734!SelectorBrowser class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:43'! 316735windowColorSpecification 316736 "Answer a WindowColorSpec object that declares my preference" 316737 316738 ^ WindowColorSpec classSymbol: self name wording: 'Method Finder' brightColor: #lightCyan pastelColor: #palePeach helpMessage: 'A tool for finding methods by giving sample arguments and values.'! ! 316739LeafNode subclass: #SelectorNode 316740 instanceVariableNames: '' 316741 classVariableNames: '' 316742 poolDictionaries: '' 316743 category: 'Compiler-ParseNodes'! 316744!SelectorNode commentStamp: '<historical>' prior: 0! 316745I am a parse tree leaf representing a selector.! 316746 316747 316748!SelectorNode methodsFor: 'code generation'! 316749emit: stack args: nArgs on: strm 316750 316751 self emit: stack 316752 args: nArgs 316753 on: strm 316754 super: false! ! 316755 316756!SelectorNode methodsFor: 'code generation'! 316757emit: stack args: nArgs on: aStream super: supered 316758 | index | 316759 stack pop: nArgs. 316760 (supered not and: [code - Send < SendLimit and: [nArgs < 3]]) ifTrue: 316761 ["short send" 316762 code < Send 316763 ifTrue: [^ aStream nextPut: code "special"] 316764 ifFalse: [^ aStream nextPut: nArgs * 16 + code]]. 316765 index := code < 256 ifTrue: [code - Send] ifFalse: [code \\ 256]. 316766 (index <= 31 and: [nArgs <= 7]) ifTrue: 316767 ["extended (2-byte) send [131 and 133]" 316768 aStream nextPut: SendLong + (supered ifTrue: [2] ifFalse: [0]). 316769 ^ aStream nextPut: nArgs * 32 + index]. 316770 (supered not and: [index <= 63 and: [nArgs <= 3]]) ifTrue: 316771 ["new extended (2-byte) send [134]" 316772 aStream nextPut: SendLong2. 316773 ^ aStream nextPut: nArgs * 64 + index]. 316774 "long (3-byte) send" 316775 aStream nextPut: DblExtDoAll. 316776 aStream nextPut: nArgs + (supered ifTrue: [32] ifFalse: [0]). 316777 aStream nextPut: index! ! 316778 316779!SelectorNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:08'! 316780reserve: encoder 316781 "If this is a yet unused literal of type -code, reserve it." 316782 316783 code < 0 ifTrue: [code := self code: (index := encoder sharableLitIndex: key) type: 0 - code]! ! 316784 316785!SelectorNode methodsFor: 'code generation' stamp: 'di 1/7/2000 12:32'! 316786size: encoder args: nArgs super: supered 316787 | index | 316788 self reserve: encoder. 316789 (supered not and: [code - Send < SendLimit and: [nArgs < 3]]) 316790 ifTrue: [^1]. "short send" 316791 (supered and: [code < Send]) ifTrue: 316792 ["super special:" 316793 code := self code: (encoder sharableLitIndex: key) type: 5]. 316794 index := code < 256 ifTrue: [code - Send] ifFalse: [code \\ 256]. 316795 (index <= 31 and: [nArgs <= 7]) 316796 ifTrue: [^ 2]. "medium send" 316797 (supered not and: [index <= 63 and: [nArgs <= 3]]) 316798 ifTrue: [^ 2]. "new medium send" 316799 ^ 3 "long send"! ! 316800 316801 316802!SelectorNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 316803emitCode: stack args: nArgs encoder: encoder 316804 316805 self emitCode: stack 316806 args: nArgs 316807 encoder: encoder 316808 super: false! ! 316809 316810!SelectorNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:47'! 316811emitCode: stack args: nArgs encoder: encoder super: supered 316812 stack pop: nArgs. 316813 ^supered 316814 ifTrue: 316815 [encoder genSendSuper: index numArgs: nArgs] 316816 ifFalse: 316817 [encoder 316818 genSend: (code < Send ifTrue: [code negated] ifFalse: [index]) 316819 numArgs: nArgs]! ! 316820 316821!SelectorNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 316822emitCodeForEffect: stack encoder: encoder 316823 316824 self shouldNotImplement! ! 316825 316826!SelectorNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 316827emitCodeForValue: stack encoder: encoder 316828 316829 self shouldNotImplement! ! 316830 316831!SelectorNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:15'! 316832sizeCode: encoder args: nArgs super: supered 316833 self reserve: encoder. 316834 ^supered 316835 ifTrue: 316836 [code < Send "i.e. its a special selector" ifTrue: 316837 [code := self code: (index := encoder sharableLitIndex: key) type: 5]. 316838 encoder sizeSendSuper: index numArgs: nArgs] 316839 ifFalse: 316840 [self flag: #yuck. "special selector sends cause this problem" 316841 encoder 316842 sizeSend: (code < Send ifTrue: [code negated] ifFalse: [index]) 316843 numArgs: nArgs]! ! 316844 316845!SelectorNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 316846sizeCodeForEffect: encoder 316847 316848 self shouldNotImplement! ! 316849 316850!SelectorNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 316851sizeCodeForValue: encoder 316852 316853 self shouldNotImplement! ! 316854 316855 316856!SelectorNode methodsFor: 'inappropriate'! 316857emitForEffect: stack on: strm 316858 316859 self shouldNotImplement! ! 316860 316861!SelectorNode methodsFor: 'inappropriate'! 316862emitForValue: stack on: strm 316863 316864 self shouldNotImplement! ! 316865 316866!SelectorNode methodsFor: 'inappropriate'! 316867sizeForEffect: encoder 316868 316869 self shouldNotImplement! ! 316870 316871!SelectorNode methodsFor: 'inappropriate'! 316872sizeForValue: encoder 316873 316874 self shouldNotImplement! ! 316875 316876 316877!SelectorNode methodsFor: 'initialize-release' stamp: 'eem 5/14/2008 09:30'! 316878name: literal key: object index: i type: type 316879 "For compatibility with Encoder>>name:key:class:type:set:" 316880 ^self key: object index: i type: type! ! 316881 316882 316883!SelectorNode methodsFor: 'printing' stamp: 'eem 9/25/2008 14:56'! 316884key: aSelector 316885 "This is for printing of FFI selectors." 316886 key := aSelector! ! 316887 316888!SelectorNode methodsFor: 'printing' stamp: 'eem 9/25/2008 15:01'! 316889printAsFFICallWithArguments: aSequence on: aStream indent: level 316890 aStream nextPutAll: (key copyUpTo: $)). 316891 aSequence 316892 do: [:arg| arg printOn: aStream indent: level] 316893 separatedBy: [aStream nextPutAll: ', ']. 316894 aStream nextPut: $)! ! 316895 316896!SelectorNode methodsFor: 'printing' stamp: 'eem 5/6/2008 14:50'! 316897printOn: aStream indent: level 316898 aStream nextPutAll: (key == nil 316899 ifTrue: ['<key==nil>'] 316900 ifFalse: [key])! ! 316901 316902!SelectorNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 316903printWithClosureAnalysisOn: aStream indent: level 316904 aStream nextPutAll: (key == nil 316905 ifTrue: ['<key==nil>'] 316906 ifFalse: [key])! ! 316907 316908 316909!SelectorNode methodsFor: 'testing' stamp: 'eem 9/25/2008 15:18'! 316910isForFFICall 316911 ^key includesSubString: '()/'! ! 316912 316913!SelectorNode methodsFor: 'testing'! 316914isPvtSelector 316915 "Answer if this selector node is a private message selector." 316916 316917 ^key isPvtSelector! ! 316918 316919 316920!SelectorNode methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:48'! 316921accept: aVisitor 316922 aVisitor visitSelectorNode: self! ! 316923TestCase subclass: #SelfEvaluatingObjectTest 316924 instanceVariableNames: '' 316925 classVariableNames: '' 316926 poolDictionaries: '' 316927 category: 'KernelTests-Objects'! 316928 316929!SelfEvaluatingObjectTest methodsFor: 'tests' stamp: 'AdrianLienhard 10/11/2009 13:40'! 316930testArray 316931 "self run: #testArray" 316932 316933 self assertCode: '#(1 2 3)' print: '#(1 2 3)'. 316934 self assertCode: '{1 . 2 . 3}' print: '#(1 2 3)'. 316935 self assertCode: '{1 + 0 . 2 . 3}' print: '#(1 2 3)'. 316936 self assertCode: '{1 + 0 . 1 @ 2 . 3}' print: '{1. 1@2. 3}'. 316937 self assertCode: '{2@3}' print: '{2@3}'. 316938 self assertCode: '{Object new}' print: 'an Array(an Object)'. 316939 self assertCode: '{Rectangle new . Object new}' print: 'an Array(nil corner: nil an Object)'. 316940 self assertCode: '{10@10 corner: 20@20 . 100@100 corner: 200@200}' print: '{10@10 corner: 20@20. 100@100 corner: 200@200}'! ! 316941 316942!SelfEvaluatingObjectTest methodsFor: 'tests' stamp: 'sd 7/31/2005 22:04'! 316943testObjects 316944 "self debug: #testObjects" 316945 316946 self assert: 10 isSelfEvaluating. 316947 self assert: $a isSelfEvaluating. 316948 self assert: 3.14157 isSelfEvaluating. 316949 self assert: #(1 2 3) isSelfEvaluating. 316950 self assert: #abc isSelfEvaluating. 316951 self assert: 'abc' isSelfEvaluating. 316952 316953 self assert: Object isSelfEvaluating. 316954 self assert: Object new isSelfEvaluating not. 316955 316956 self assert: (Array with: 10) isSelfEvaluating. 316957 self assert: (Array with: Object new) isSelfEvaluating not. 316958 316959 self assert: true isSelfEvaluating. 316960 self assert: false isSelfEvaluating. 316961 316962 self assert: nil isSelfEvaluating. 316963 316964 self assert: (1 to: 10) isSelfEvaluating. 316965 self assert: (1->2) isSelfEvaluating. 316966 self assert: Color red isSelfEvaluating. 316967 self assert: RunArray new isSelfEvaluating.! ! 316968 316969 316970!SelfEvaluatingObjectTest methodsFor: 'utilities' stamp: 'sd 7/31/2005 21:43'! 316971assertCode: code print: aString 316972 self assert: (self compile: code) printString = aString! ! 316973 316974!SelfEvaluatingObjectTest methodsFor: 'utilities' stamp: 'sd 7/31/2005 21:42'! 316975compile: aString 316976 ^ Compiler evaluate: aString! ! 316977LinkedList subclass: #Semaphore 316978 instanceVariableNames: 'excessSignals' 316979 classVariableNames: '' 316980 poolDictionaries: '' 316981 category: 'Kernel-Processes'! 316982!Semaphore commentStamp: '<historical>' prior: 0! 316983I provide synchronized communication of a single bit of information (a "signal") between Processes. A signal is sent by sending the message signal and received by sending the message wait. If no signal has been sent when a wait message is sent, the sending Process will be suspended until a signal is sent.! 316984 316985 316986!Semaphore methodsFor: 'communication'! 316987signal 316988 "Primitive. Send a signal through the receiver. If one or more processes 316989 have been suspended trying to receive a signal, allow the first one to 316990 proceed. If no process is waiting, remember the excess signal. Essential. 316991 See Object documentation whatIsAPrimitive." 316992 316993 <primitive: 85> 316994 self primitiveFailed 316995 316996 "self isEmpty 316997 ifTrue: [excessSignals := excessSignals+1] 316998 ifFalse: [Processor resume: self removeFirstLink]" 316999 317000! ! 317001 317002!Semaphore methodsFor: 'communication'! 317003wait 317004 "Primitive. The active Process must receive a signal through the receiver 317005 before proceeding. If no signal has been sent, the active Process will be 317006 suspended until one is sent. Essential. See Object documentation 317007 whatIsAPrimitive." 317008 317009 <primitive: 86> 317010 self primitiveFailed 317011 317012 "excessSignals>0 317013 ifTrue: [excessSignals := excessSignals-1] 317014 ifFalse: [self addLastLink: Processor activeProcess suspend]" 317015! ! 317016 317017!Semaphore methodsFor: 'communication' stamp: 'ar 3/27/2009 22:38'! 317018waitTimeoutMSecs: anInteger 317019 "Wait on this semaphore for up to the given number of milliseconds, then timeout. 317020 Return true if the deadline expired, false otherwise." 317021 | d | 317022 d := DelayWaitTimeout new setDelay: (anInteger max: 0) forSemaphore: self. 317023 ^d wait! ! 317024 317025!Semaphore methodsFor: 'communication' stamp: 'ar 3/27/2009 22:37'! 317026waitTimeoutSeconds: anInteger 317027 "Wait on this semaphore for up to the given number of seconds, then timeout. 317028 Return true if the deadline expired, false otherwise." 317029 ^self waitTimeoutMSecs: anInteger * 1000. 317030! ! 317031 317032 317033!Semaphore methodsFor: 'comparing' stamp: 'sma 4/22/2000 18:48'! 317034= anObject 317035 ^ self == anObject! ! 317036 317037!Semaphore methodsFor: 'comparing' stamp: 'sma 4/22/2000 18:48'! 317038hash 317039 ^ self identityHash! ! 317040 317041 317042!Semaphore methodsFor: 'initialize-release'! 317043initSignals 317044 "Consume any excess signals the receiver may have accumulated." 317045 317046 excessSignals := 0.! ! 317047 317048!Semaphore methodsFor: 'initialize-release' stamp: 'jf 12/2/2003 18:53'! 317049resumeProcess: aProcess 317050 "Remove the given process from the list of waiting processes (if it's there) and resume it. This is used when a process asked for its wait to be timed out." 317051 317052 | process | 317053 process := self remove: aProcess ifAbsent: [nil]. 317054 process ifNotNil: [process resume].! ! 317055 317056!Semaphore methodsFor: 'initialize-release'! 317057terminateProcess 317058 "Terminate the process waiting on this semaphore, if any." 317059 317060 self isEmpty ifFalse: [ self removeFirst terminate ].! ! 317061 317062 317063!Semaphore methodsFor: 'mutual exclusion' stamp: 'ar 10/5/2007 17:59'! 317064critical: mutuallyExcludedBlock 317065 "Evaluate mutuallyExcludedBlock only if the receiver is not currently in 317066 the process of running the critical: message. If the receiver is, evaluate 317067 mutuallyExcludedBlock after the other critical: message is finished." 317068 | blockValue caught | 317069 caught := false. 317070 [ 317071 caught := true. 317072 self wait. 317073 blockValue := mutuallyExcludedBlock value 317074 ] ensure: [caught ifTrue: [self signal]]. 317075 ^blockValue 317076! ! 317077 317078!Semaphore methodsFor: 'mutual exclusion' stamp: 'ar 10/5/2007 18:33'! 317079critical: mutuallyExcludedBlock ifCurtailed: terminationBlock 317080 "Evaluate mutuallyExcludedBlock only if the receiver is not currently in 317081 the process of running the critical: message. If the receiver is, evaluate 317082 mutuallyExcludedBlock after the other critical: message is finished." 317083 ^self critical:[[mutuallyExcludedBlock value] ifCurtailed: terminationBlock] 317084! ! 317085 317086!Semaphore methodsFor: 'mutual exclusion' stamp: 'ar 10/5/2007 17:59'! 317087critical: mutuallyExcludedBlock ifError: errorBlock 317088 "Evaluate mutuallyExcludedBlock only if the receiver is not currently in 317089 the process of running the critical: message. If the receiver is, evaluate 317090 mutuallyExcludedBlock after the other critical: message is finished." 317091 | blockValue hasError errMsg errRcvr | 317092 hasError := false. 317093 self critical:[ 317094 blockValue := [mutuallyExcludedBlock value] ifError:[:msg :rcvr| 317095 hasError := true. 317096 errMsg := msg. 317097 errRcvr := rcvr 317098 ]. 317099 ]. 317100 hasError ifTrue:[ ^errorBlock value: errMsg value: errRcvr]. 317101 ^blockValue! ! 317102 317103!Semaphore methodsFor: 'mutual exclusion' stamp: 'ar 10/5/2007 18:34'! 317104critical: mutuallyExcludedBlock ifLocked: alternativeBlock 317105 "Evaluate mutuallyExcludedBlock only if the receiver is not currently in 317106 the process of running the critical: message. If the receiver is, evaluate 317107 mutuallyExcludedBlock after the other critical: message is finished." 317108 excessSignals == 0 ifTrue:[ 317109 "If we come here, then the semaphore was locked when the test executed. 317110 Evaluate the alternative block and answer its result." 317111 ^alternativeBlock value 317112 ]. 317113 ^self critical: mutuallyExcludedBlock! ! 317114 317115 317116!Semaphore methodsFor: 'testing' stamp: 'ar 3/2/2001 16:51'! 317117isSignaled 317118 "Return true if this semaphore is currently signaled" 317119 ^excessSignals > 0! ! 317120 317121"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 317122 317123Semaphore class 317124 instanceVariableNames: ''! 317125 317126!Semaphore class methodsFor: 'instance creation'! 317127forMutualExclusion 317128 "Answer an instance of me that contains a single signal. This new 317129 instance can now be used for mutual exclusion (see the critical: message 317130 to Semaphore)." 317131 317132 ^self new signal! ! 317133 317134!Semaphore class methodsFor: 'instance creation'! 317135new 317136 "Answer a new instance of Semaphore that contains no signals." 317137 317138 ^self basicNew initSignals! ! 317139ClassTestCase subclass: #SemaphoreTest 317140 instanceVariableNames: '' 317141 classVariableNames: '' 317142 poolDictionaries: '' 317143 category: 'KernelTests-Processes'! 317144!SemaphoreTest commentStamp: 'tlk 5/5/2006 13:32' prior: 0! 317145A SemaphoreTest is sunit test for simple and multiEx semaphores 317146 317147Instance Variables none; does not have common test fixture accross all tests (because its testing differenct sorts of semaphores (could refactor into muliple testcases if there were more test conditions. 317148! 317149 317150 317151!SemaphoreTest methodsFor: 'testing' stamp: 'tlk 5/5/2006 13:27'! 317152testCritical 317153 | lock | 317154 lock := Semaphore forMutualExclusion. 317155 [lock critical: [self criticalError]] forkAt: Processor userInterruptPriority. 317156 self assert: lock isSignaled! ! 317157 317158!SemaphoreTest methodsFor: 'testing' stamp: 'tlk 5/5/2006 13:28'! 317159testCriticalIfError 317160 | lock | 317161 lock := Semaphore forMutualExclusion. 317162 [lock critical: [self criticalError ifError:[]]] forkAt: Processor userInterruptPriority. 317163 self assert: lock isSignaled! ! 317164 317165!SemaphoreTest methodsFor: 'testing' stamp: 'ar 10/5/2007 18:09'! 317166testSemaAfterCriticalWait "self run: #testSemaAfterCriticalWait" 317167 "This tests whether a semaphore that has just left the wait in Semaphore>>critical: 317168 leaves it with signaling the associated semaphore." 317169 | s p | 317170 s := Semaphore new. 317171 p := [s critical:[]] forkAt: Processor activePriority-1. 317172 "wait until p entered the critical section" 317173 [p suspendingList == s] whileFalse:[(Delay forMilliseconds: 10) wait]. 317174 "Now that p entered it, signal the semaphore. p now 'owns' the semaphore 317175 but since we are running at higher priority than p it will not get to do 317176 anything." 317177 s signal. 317178 p terminate. 317179 self assert:[(s instVarNamed: #excessSignals) = 1]! ! 317180 317181!SemaphoreTest methodsFor: 'testing' stamp: 'ar 10/5/2007 18:06'! 317182testSemaInCriticalWait "self run: #testSemaInCriticalWait" 317183 "This tests whether a semaphore that has entered the wait in Semaphore>>critical: 317184 leaves it without signaling the associated semaphore." 317185 | s p | 317186 s := Semaphore new. 317187 p := [s critical:[]] fork. 317188 Processor yield. 317189 self assert:[p suspendingList == s]. 317190 p terminate. 317191 self assert:[(s instVarNamed: #excessSignals) = 0]! ! 317192 317193!SemaphoreTest methodsFor: 'testing' stamp: 'jf 12/2/2003 19:31'! 317194testWaitAndWaitTimeoutTogether 317195 | semaphore value waitProcess waitTimeoutProcess | 317196 semaphore := Semaphore new. 317197 317198 waitProcess := [semaphore wait. value := #wait] fork. 317199 317200 waitTimeoutProcess := [semaphore waitTimeoutMSecs: 50. value := #waitTimeout] fork. 317201 317202 "Wait for the timeout to happen" 317203 (Delay forMilliseconds: 100) wait. 317204 317205 "The waitTimeoutProcess should already have timed out. This should release the waitProcess" 317206 semaphore signal. 317207 317208 [waitProcess isTerminated and: [waitTimeoutProcess isTerminated]] 317209 whileFalse: [(Delay forMilliseconds: 100) wait]. 317210 317211 self assert: value = #wait. 317212 ! ! 317213 317214!SemaphoreTest methodsFor: 'testing' stamp: 'ar 3/23/2009 17:01'! 317215testWaitTimeoutMSecs 317216 "Ensure that waitTimeoutMSecs behaves properly" 317217 317218 "Ensure that a timed out waitTimeoutMSecs: returns true from the wait" 317219 self assert: (Semaphore new waitTimeoutMSecs: 50) == true. 317220 317221 "Ensure that a signaled waitTimeoutMSecs: returns false from the wait" 317222 self assert: (Semaphore new signal waitTimeoutMSecs: 50) == false. 317223! ! 317224 317225 317226!SemaphoreTest methodsFor: 'tests not working' stamp: 'stephane.ducasse 5/25/2008 17:59'! 317227waitAndWaitTimeoutTogether 317228 "self run: #testWaitAndWaitTimeoutTogether" 317229 | semaphore value waitProcess waitTimeoutProcess | 317230 self halt: 'WatchOut Hang the image'. 317231 317232 semaphore := Semaphore new. 317233 317234 waitProcess := [semaphore wait. value := #wait] fork. 317235 317236 waitTimeoutProcess := [semaphore waitTimeoutMSecs: 50. value := #waitTimeout] fork. 317237 317238 "Wait for the timeout to happen" 317239 (Delay forMilliseconds: 100) wait. 317240 317241 "The waitTimeoutProcess should already have timed out. This should release the waitProcess" 317242 semaphore signal. 317243 317244 [waitProcess isTerminated and: [waitTimeoutProcess isTerminated]] 317245 whileFalse: [(Delay forMilliseconds: 100) wait]. 317246 317247 self assert: value = #wait. 317248 ! ! 317249 317250 317251!SemaphoreTest methodsFor: 'private' stamp: 'tlk 5/5/2006 13:26'! 317252criticalError 317253 Processor activeProcess terminate! ! 317254 317255"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 317256 317257SemaphoreTest class 317258 instanceVariableNames: ''! 317259TimeMeasuringTest subclass: #SendCachePerformanceTest 317260 instanceVariableNames: '' 317261 classVariableNames: '' 317262 poolDictionaries: '' 317263 category: 'Tests-Traits'! 317264 317265!SendCachePerformanceTest methodsFor: 'as yet unclassified' stamp: 'al 2/17/2006 08:42'! 317266performanceTestBaseline 317267 LocalSends current for: Morph. 317268 self assert: [LocalSends current for: Morph] timeToRun < 1. 317269 Morph clearSendCaches. 317270 self measure: [LocalSends current for: Morph]. 317271 self assert: realTime < 100. 317272 self assert: [LocalSends current for: Morph] timeToRun < 1! ! 317273Object subclass: #SendCaches 317274 instanceVariableNames: 'selfSenders superSenders classSenders' 317275 classVariableNames: '' 317276 poolDictionaries: '' 317277 category: 'Traits-LocalSends'! 317278!SendCaches commentStamp: 'NS 5/27/2005 15:13' prior: 0! 317279Instances of this class are used to keep track of selectors that are sent to self, sent to super, and sent to the class-side in any of the methods of a certain class. It also keeps track of the requirements of a class. 317280 317281It's important to understand that this class just serves as storage for these sets of selectors. It does not contain any logic to actually compute them. In particular, it cannot compute the requirements.! 317282 317283 317284!SendCaches methodsFor: 'accessing' stamp: 'apb 3/2/2006 23:28'! 317285classSendersOf: selector 317286 ^ classSenders at: selector ifAbsent: [#()].! ! 317287 317288!SendCaches methodsFor: 'accessing' stamp: 'alain.plantec 5/28/2009 10:21'! 317289initialize 317290 super initialize. 317291 selfSenders := IdentityDictionary new. 317292 superSenders := IdentityDictionary new. 317293 classSenders := IdentityDictionary new.! ! 317294 317295!SendCaches methodsFor: 'accessing' stamp: 'dvf 8/8/2005 11:20'! 317296selfSenders 317297 ^selfSenders! ! 317298 317299!SendCaches methodsFor: 'accessing' stamp: 'dvf 8/8/2005 11:20'! 317300selfSenders: anObject 317301 ^selfSenders := anObject! ! 317302 317303!SendCaches methodsFor: 'accessing' stamp: 'dvf 8/8/2005 11:24'! 317304superSenders 317305 ^superSenders! ! 317306 317307!SendCaches methodsFor: 'accessing' stamp: 'dvf 8/8/2005 11:24'! 317308superSenders: anObject 317309 ^superSenders := anObject! ! 317310 317311 317312!SendCaches methodsFor: 'accessing-specific' stamp: 'NS 5/24/2005 20:58'! 317313allSentSelectorsAndSendersDo: aBlock 317314 self selfSentSelectorsAndSendersDo: aBlock. 317315 self superSentSelectorsAndSendersDo: aBlock. 317316 self classSentSelectorsAndSendersDo: aBlock.! ! 317317 317318!SendCaches methodsFor: 'accessing-specific' stamp: 'apb 3/2/2006 23:29'! 317319classSentSelectorsAndSendersDo: aBlock 317320 classSenders keysAndValuesDo: aBlock! ! 317321 317322!SendCaches methodsFor: 'accessing-specific' stamp: 'apb 3/2/2006 23:25'! 317323selfSendersOf: selector 317324 ^ selfSenders at: selector ifAbsent: [#()].! ! 317325 317326!SendCaches methodsFor: 'accessing-specific' stamp: 'apb 3/2/2006 23:26'! 317327selfSentSelectorsAndSendersDo: aBlock 317328 selfSenders keysAndValuesDo: aBlock! ! 317329 317330!SendCaches methodsFor: 'accessing-specific' stamp: 'apb 3/2/2006 23:28'! 317331superSendersOf: selector 317332 ^ superSenders at: selector ifAbsent: [#()].! ! 317333 317334!SendCaches methodsFor: 'accessing-specific' stamp: 'apb 3/2/2006 23:27'! 317335superSentSelectorsAndSendersDo: aBlock 317336 superSenders keysAndValuesDo: aBlock! ! 317337 317338 317339!SendCaches methodsFor: 'fixup' stamp: 'apb 3/2/2006 23:16'! 317340printOn: aStream 317341 super printOn: aStream. 317342 aStream nextPut: $[. 317343 selfSenders printOn: aStream. 317344 aStream nextPut: $|. 317345 superSenders printOn: aStream. 317346 aStream nextPut: $|. 317347 classSenders printOn: aStream. 317348 aStream nextPut: $]! ! 317349 317350!SendCaches methodsFor: 'fixup' stamp: 'apb 3/2/2006 23:18'! 317351properlyInitialize 317352 selfSenders isEmptyOrNil ifTrue: [selfSenders := IdentityDictionary new]. 317353 superSenders isEmptyOrNil ifTrue: [superSenders := IdentityDictionary new]. 317354 classSenders isEmptyOrNil ifTrue: [classSenders := IdentityDictionary new]. 317355 317356! ! 317357 317358 317359!SendCaches methodsFor: 'updates' stamp: 'apb 3/2/2006 23:29'! 317360addClassSender: sendingSelector of: sentSelector 317361 | senders | 317362 senders := classSenders at: sentSelector ifAbsent: [#()]. 317363 classSenders at: sentSelector put: (senders copyWith: sendingSelector).! ! 317364 317365!SendCaches methodsFor: 'updates' stamp: 'apb 3/2/2006 23:27'! 317366addSelfSender: sendingSelector of: sentSelector 317367 | senders | 317368 senders := selfSenders at: sentSelector ifAbsent: [#()]. 317369 selfSenders at: sentSelector put: (senders copyWith: sendingSelector).! ! 317370 317371!SendCaches methodsFor: 'updates' stamp: 'apb 3/2/2006 23:28'! 317372addSuperSender: sendingSelector of: sentSelector 317373 | senders | 317374 senders := superSenders at: sentSelector ifAbsent: [#()]. 317375 superSenders at: sentSelector put: (senders copyWith: sendingSelector).! ! 317376 317377"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 317378 317379SendCaches class 317380 instanceVariableNames: ''! 317381 317382!SendCaches class methodsFor: 'fixup' stamp: 'stephane.ducasse 4/13/2009 20:32'! 317383initializeAllInstances 317384 self allSubInstancesDo: [ :each | each properlyInitialize ]! ! 317385InstructionStream subclass: #SendInfo 317386 instanceVariableNames: 'stack savedStacks selfSentSelectors superSentSelectors classSentSelectors isStartOfBlock numBlockArgs nr1 nr2 nr3 nr4 nr5' 317387 classVariableNames: '' 317388 poolDictionaries: '' 317389 category: 'Traits-LocalSends'! 317390!SendInfo commentStamp: '<historical>' prior: 0! 317391SendInfo objects perform an abstract interpretation of a compiled method to ascertain the messages that are self-sent, super-sent and class-sent. 317392 317393The idea is to simulate the execution of the instruction stream in the compiled method, keeping track of whether the values on the stack are self or some other value. IN one place we have to keep track of the small integers that are on the stack, becuase they determine how many elements are to be popped off of the stack. 317394 317395Everything is fairly straighforward except for jumps. 317396 317397Conditional forward jumps, as generated by ifTrue: and ifFalse:, are fairly easy. At the site of the conditional jump, we copy the stack, and use one copy on each path. When the paths eventually merge, the stacks should be the same size (if they aren't it's a compiler error!!). We build a new stack that has #self on it every place where either of the old stacks had #self. Thus, expressions like 317398 317399 (aBoolean ifTrue: self ifFalse: other) foo: 3 317400 317401that might send foo: 3 to self are recognized. 317402 317403For unconditional jumps, we save the stack for use at the join point, and continue execution at the instruciton after the jump with an empty stack, which will be immediately overwritten by the stack that comes with the arriving execution. 317404 317405The bottlenecks in this algorithm turned out to be detecting join points and simulating the stack. Using an OrderedCollection for a stack caused a lot of redundant work, especially when emptying the stack. Using a dictionary to detect join points turned out to be very slow, because of the possibility of having to scan through the hash table. 317406 317407QuickIntegerDictionary and QuickStack provide the same core functionality, but in much more efficient forms. 317408 317409 317410Use SendInfo as follows: 317411 317412 (SendInfo on: aCompiledMethod) collectSends 317413 317414aSendInfo is both an InstructionStream and an InstructionStream client. 317415 317416Structure: 317417 stack -- the simulated execution stack 317418 savedStacks -- The dictionary on which the extra stacks waiting to be merged in are saved. 317419 317420 sentSelectors -- an Identity Set accumulating the set of sent selectors. 317421 superSentSelectors -- an Identity Set accumulating the set of super sent selectors. 317422 317423 classSentSelectors -- an Identity Set accumulating the set of selectors sent to self class. 317424 isStartOfBlock -- a flag indicating that we have found the start of a block, and that the next jump will skip over it. 317425 numBlockArgs -- 317426nr1' 'nr2' 'nr3' 'nr4') 317427! 317428 317429 317430!SendInfo methodsFor: 'accessing' stamp: 'NS 5/23/2005 11:04'! 317431classSentSelectors 317432 ^ classSentSelectors ifNil: [#()] ifNotNil: [classSentSelectors].! ! 317433 317434!SendInfo methodsFor: 'accessing' stamp: 'apb 8/28/2003 16:52'! 317435home 317436 "Answer the context in which the receiver was defined." 317437 317438 ^ sender! ! 317439 317440!SendInfo methodsFor: 'accessing' stamp: 'NS 5/23/2005 11:03'! 317441selfSentSelectors 317442 ^ selfSentSelectors ifNil: [#()] ifNotNil: [selfSentSelectors].! ! 317443 317444!SendInfo methodsFor: 'accessing' stamp: 'NS 5/23/2005 11:04'! 317445superSentSelectors 317446 ^ superSentSelectors ifNil: [#()] ifNotNil: [superSentSelectors].! ! 317447 317448 317449!SendInfo methodsFor: 'initialization' stamp: 'apb 8/28/2003 17:32'! 317450collectSends 317451 | end | 317452 end := self method endPC. 317453 [pc <= end] 317454 whileTrue: [self interpretNextInstructionFor: self]! ! 317455 317456!SendInfo methodsFor: 'initialization' stamp: 'NS 2/15/2005 15:58'! 317457method: method pc: initialPC 317458 super method: method pc: initialPC. 317459 self prepareState.! ! 317460 317461!SendInfo methodsFor: 'initialization' stamp: 'NS 5/23/2005 11:12'! 317462prepareState 317463 | nrsArray | 317464 self newEmptyStack. 317465 savedStacks := QuickIntegerDictionary new: (sender endPC). 317466 isStartOfBlock := false. 317467 nrsArray := self class neverRequiredSelectors. 317468 self assert:[nrsArray size = 5] because: 'Size of neverRequiredSelectors has been changed; re-optimize (by hand) #tallySelfSendsFor:'. 317469 nr1 := nrsArray at: 1. 317470 nr2 := nrsArray at: 2. 317471 nr3 := nrsArray at: 3. 317472 nr4 := nrsArray at: 4. 317473 nr5 := nrsArray at: 5.! ! 317474 317475 317476!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 13:40'! 317477blockReturnTop 317478 "Return from a block with Top Of Stack as result. 317479 The following instruction will be branched to from somewhere, and will 317480 therefore trigger a stackMerge, so it is important that the stack be emptied." 317481 317482 self pop. 317483 self emptyStack.! ! 317484 317485!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 19:28'! 317486doDup 317487 "Simulate the action of a 'duplicate top of stack' bytecode." 317488 317489 self push: self top! ! 317490 317491!SendInfo methodsFor: 'instruction decoding' stamp: 'NS 5/23/2005 11:14'! 317492doPop 317493 317494 stack isEmpty ifFalse: [self pop]! ! 317495 317496!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/31/2003 12:41'! 317497interpretNextInstructionFor: client 317498 self atMergePoint 317499 ifTrue: [self mergeStacks]. 317500 super interpretNextInstructionFor: client! ! 317501 317502!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 9/7/2004 10:42'! 317503jump: distance 317504 "Simulate the action of a 'unconditional jump' bytecode whose 317505 offset is the argument, distance." 317506 distance < 0 317507 ifTrue: [^ self]. 317508 distance = 0 317509 ifTrue: [self error: 'bad compiler!!']. 317510 savedStacks at: (self pc + distance) put: stack. 317511 "We empty the stack to signify that execution cannot 'fall through' to the 317512 next statement. Note that since we just stored the current stack, not a copy, in 317513 the savedStacks dictionary, here we need to allocate a new stack." 317514 self newEmptyStack. 317515 isStartOfBlock 317516 ifTrue: [isStartOfBlock := false. 317517 numBlockArgs timesRepeat: [self push: #stuff]]! ! 317518 317519!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/31/2003 21:50'! 317520jump: distance if: aBooleanConstant 317521 "Simulate the action of a 'conditional jump' bytecode whose offset is 317522 distance, and whose condition is aBooleanConstant." 317523 317524 | destination | 317525 distance < 0 ifTrue:[^ self]. 317526 distance = 0 ifTrue:[self error: 'bad compiler!!']. 317527 destination := self pc + distance. 317528 "remove the condition from the stack." 317529 self pop. 317530 savedStacks at: destination put: stack copy. 317531! ! 317532 317533!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/31/2003 21:25'! 317534methodReturnConstant: aConstant 317535 "Simulate the action of a 'return receiver' bytecode. This corresponds to 317536 the source expression '^aConstant'." 317537 317538 self push: aConstant. 317539 self emptyStack! ! 317540 317541!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/31/2003 21:25'! 317542methodReturnReceiver 317543 "Simulate the action of a 'return receiver' bytecode. This corresponds to 317544 the source expression '^self'." 317545 317546 self push: #self. 317547 self emptyStack ! ! 317548 317549!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/31/2003 21:25'! 317550methodReturnTop 317551 "Simulate the action of a 'return receiver' bytecode. This corresponds to 317552 the source expression '^ <result of the last evaluation>'." 317553 317554 self emptyStack ! ! 317555 317556!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 15:37'! 317557popIntoLiteralVariable: value 317558 "Simulate the action of bytecode that removes the top of the stack and 317559 stores it into a literal variable of my method." 317560 317561 self pop! ! 317562 317563!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 14:51'! 317564popIntoReceiverVariable: offset 317565 "Simulate the action of bytecode that removes the top of the stack and 317566 stores it into an instance variable of my receiver." 317567 317568 self pop! ! 317569 317570!SendInfo methodsFor: 'instruction decoding' stamp: 'eem 7/21/2008 15:47'! 317571popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 317572 "Simulate the action of bytecode that removes the top of the stack and stores 317573 it into an offset in one of my local variables being used as a remote temp vector." 317574 317575 self pop! ! 317576 317577!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 14:51'! 317578popIntoTemporaryVariable: offset 317579 "Simulate the action of bytecode that removes the top of the stack and 317580 stores it into an instance variable of my receiver." 317581 317582 self pop! ! 317583 317584!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 15:53'! 317585pushActiveContext 317586 "Simulate the action of bytecode that pushes the active context on the 317587 top of its own stack." 317588 317589 self push: #block.! ! 317590 317591!SendInfo methodsFor: 'instruction decoding' stamp: 'eem 7/21/2008 15:41'! 317592pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize 317593 "Simulate the action of a 'closure copy' bytecode whose result is the 317594 new BlockClosure for the following code" 317595 self pop: numCopied. 317596 self push: #block. 317597 savedStacks at: (self pc + blockSize) put: stack. 317598 "We empty the stack to signify that execution cannot 'fall through' to the 317599 next statement. Note that since we just stored the current stack, not a copy, in 317600 the savedStacks dictionary, here we need to allocate a new stack." 317601 self newEmptyStack. 317602 numCopied + numArgs timesRepeat: [self push: #stuff]! ! 317603 317604!SendInfo methodsFor: 'instruction decoding' stamp: 'eem 7/21/2008 15:49'! 317605pushConsArrayWithElements: arraySize 317606 self pop: arraySize. 317607 self push: #stuff! ! 317608 317609!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 01:57'! 317610pushConstant: value 317611 317612 self push: value! ! 317613 317614!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 14:49'! 317615pushLiteralVariable: value 317616 317617 self push: #stuff! ! 317618 317619!SendInfo methodsFor: 'instruction decoding' stamp: 'eem 7/21/2008 15:49'! 317620pushNewArrayOfSize: arraySize 317621 self push: #stuff! ! 317622 317623!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 17:55'! 317624pushReceiver 317625 self push: #self.! ! 317626 317627!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 07:50'! 317628pushReceiverVariable: anOffset 317629 "Push the value of one of the receiver's instance variables." 317630 317631 self push: #stuff.! ! 317632 317633!SendInfo methodsFor: 'instruction decoding' stamp: 'eem 7/21/2008 15:46'! 317634pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 317635 "Simulate the action of bytecode that pushes the value at remoteTempIndex 317636 in one of my local variables being used as a remote temp vector." 317637 self push: #stuff! ! 317638 317639!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 14:47'! 317640pushTemporaryVariable: offset 317641 "Simulate the action of bytecode that pushes the contents of the 317642 temporary variable whose index is the argument, index, on the top of 317643 the stack." 317644 317645 self push: #stuff! ! 317646 317647!SendInfo methodsFor: 'instruction decoding' stamp: 'NS 5/23/2005 11:01'! 317648send: selector super: superFlag numArgs: numArgs 317649 "Simulate the action of bytecodes that send a message with 317650 selector. superFlag, tells whether the receiver of the 317651 message was 'super' in the source. The arguments 317652 of the message are found in the top numArgs locations on the 317653 stack and the receiver just below them." 317654 | stackTop | 317655 selector == #blockCopy: 317656 ifTrue: ["self assert: [numArgs = 1]." 317657 isStartOfBlock := true. 317658 numBlockArgs := self pop. 317659 ^ self]. 317660 self pop: numArgs. 317661 stackTop := self pop. 317662 superFlag 317663 ifTrue: [self addSuperSentSelector: selector] 317664 ifFalse: [stackTop == #self 317665 ifTrue: [self tallySelfSendsFor: selector]. 317666 stackTop == #class 317667 ifTrue: [self addClassSentSelector: selector]]. 317668 self 317669 push: ((selector == #class and: [stackTop == #self]) 317670 ifTrue: [#class] 317671 ifFalse: [#stuff])! ! 317672 317673!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 15:39'! 317674storeIntoLiteralVariable: value 317675 "Simulate the action of bytecode that stores the top of the stack into a 317676 literal variable of my method." 317677! ! 317678 317679!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/29/2003 15:34'! 317680storeIntoReceiverVariable: offset 317681 "Simulate the action of bytecode that stores the top of the stack into an 317682 instance variable of my receiver." 317683! ! 317684 317685!SendInfo methodsFor: 'instruction decoding' stamp: 'eem 7/21/2008 15:47'! 317686storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex 317687 "Simulate the action of bytecode that stores the top of the stack at 317688 an offset in one of my local variables being used as a remote temp vector."! ! 317689 317690!SendInfo methodsFor: 'instruction decoding' stamp: 'apb 8/28/2003 19:48'! 317691storeIntoTemporaryVariable: offset 317692 "Simulate the action of bytecode that stores the top of the stack into one 317693 of my temporary variables." 317694! ! 317695 317696 317697!SendInfo methodsFor: 'printing' stamp: 'NS 5/23/2005 10:57'! 317698printOn: aStream 317699 aStream nextPut: $[. 317700 aStream print: self selfSentSelectors asArray. 317701 aStream space. 317702 aStream print: self superSentSelectors asArray. 317703 aStream space. 317704 aStream print: self classSentSelectors asArray. 317705 aStream nextPut: $].! ! 317706 317707 317708!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/29/2003 02:13'! 317709atMergePoint 317710 ^ savedStacks includesKey: pc! ! 317711 317712!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/28/2003 16:44'! 317713blockReturn 317714 "we could empty the stack, but what's the point?"! ! 317715 317716!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 9/7/2004 10:24'! 317717emptyStack 317718 stack becomeEmpty! ! 317719 317720!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/31/2003 21:30'! 317721mergeStacks 317722 | otherStack | 317723 otherStack := savedStacks at: pc. 317724 savedStacks removeKey: pc. 317725 stack isEmpty ifTrue: [ 317726 "This happens at the end of a block, or a short circuit conditional. 317727 In these cases, it is not possible for execution to 'fall through' to 317728 the merge point. In other words, this is not a real merge point at all, 317729 and we just continue execution with the saved stack." 317730 ^ stack := otherStack ]. 317731 "self assert: [stack size = otherStack size]. This assertion was true for every 317732 method in every subclass of Object, so I think that we can safely omit it!!" 317733 1 to: stack size 317734 do: [:i | ((stack at: i) ~~ #self 317735 and: [(otherStack at: i) == #self]) 317736 ifTrue: [stack at: i put: #self]]! ! 317737 317738!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 9/7/2004 10:41'! 317739newEmptyStack 317740 stack := QuickStack new! ! 317741 317742!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/28/2003 17:41'! 317743pop 317744 ^ stack removeLast! ! 317745 317746!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/31/2003 21:43'! 317747pop: n 317748 stack removeLast: n! ! 317749 317750!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/30/2003 11:38'! 317751push: aValue 317752 stack addLast: aValue.! ! 317753 317754!SendInfo methodsFor: 'stack manipulation' stamp: 'apb 8/28/2003 19:28'! 317755top 317756 ^ stack last! ! 317757 317758 317759!SendInfo methodsFor: 'private' stamp: 'NS 5/23/2005 11:01'! 317760addClassSentSelector: aSymbol 317761 classSentSelectors ifNil: [classSentSelectors := IdentitySet new]. 317762 classSentSelectors add: aSymbol.! ! 317763 317764!SendInfo methodsFor: 'private' stamp: 'NS 5/23/2005 11:15'! 317765addSelfSentSelector: aSymbol 317766 selfSentSelectors ifNil: [selfSentSelectors := IdentitySet new]. 317767 selfSentSelectors add: aSymbol.! ! 317768 317769!SendInfo methodsFor: 'private' stamp: 'NS 5/23/2005 11:15'! 317770addSuperSentSelector: aSymbol 317771 superSentSelectors ifNil: [superSentSelectors := IdentitySet new]. 317772 superSentSelectors add: aSymbol.! ! 317773 317774!SendInfo methodsFor: 'private' stamp: 'apb 8/30/2003 10:36'! 317775assert: aBlock because: aMessage 317776 "Throw an assertion error if aBlock does not evaluates to true." 317777 317778 aBlock value ifFalse: [AssertionFailure signal: aMessage]! ! 317779 317780!SendInfo methodsFor: 'private' stamp: 'NS 5/23/2005 10:59'! 317781tallySelfSendsFor: selector 317782 "Logically, we do the following test: 317783 (self neverRequiredSelectors includes: selector) ifTrue: [^ self]. 317784 However, since this test alone was reponsible for 2.8% of the execution time, 317785 we replace it with the following:" 317786 selector == nr1 ifTrue:[^ self]. 317787 selector == nr2 ifTrue:[^ self]. 317788 selector == nr3 ifTrue:[^ self]. 317789 selector == nr4 ifTrue:[^ self]. 317790 selector == nr5 ifTrue:[^ self]. 317791 selector == #class ifTrue:[^ self]. 317792 self addSelfSentSelector: selector.! ! 317793 317794"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 317795 317796SendInfo class 317797 instanceVariableNames: ''! 317798 317799!SendInfo class methodsFor: 'accessing' stamp: 'NS 5/23/2005 10:53'! 317800neverRequiredSelectors 317801 | nrs | 317802 nrs := Array new: 5. 317803 nrs at: 1 put: CompiledMethod conflictMarker. 317804 nrs at: 2 put: CompiledMethod disabledMarker. 317805 nrs at: 3 put: CompiledMethod explicitRequirementMarker. 317806 nrs at: 4 put: CompiledMethod implicitRequirementMarker. 317807 nrs at: 5 put: CompiledMethod subclassResponsibilityMarker. 317808 ^ nrs. 317809! ! 317810TestCase subclass: #SendsInfoTest 317811 instanceVariableNames: 'state' 317812 classVariableNames: '' 317813 poolDictionaries: '' 317814 category: 'Tests-Traits'! 317815 317816!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/2/2006 22:28'! 317817assert: levelSymbol sendsIn: aSelector are: anArrayOfSelectors 317818 317819! ! 317820 317821!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/2/2006 22:39'! 317822assert: alevel sendsIn: aSendInfo for: aSelector are: aCollectionOfSelectors 317823 | detectedSends message | 317824 detectedSends := aSendInfo perform: (alevel, 'SentSelectors') asSymbol. 317825 message := alevel, ' sends wrong for ', aSelector. 317826 self assert: ((detectedSends isEmpty and: [aCollectionOfSelectors isEmpty]) or: 317827 [detectedSends = (aCollectionOfSelectors asIdentitySet)]) description: message! ! 317828 317829!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/2/2006 22:29'! 317830assert: aSelector sends: sendsCollection supersends: superCollection classSends: classCollection 317831 | theMethod info | 317832 theMethod := self class >> aSelector. 317833 info := (SendInfo on: theMethod) collectSends. 317834 self assert: #self sendsIn: info for: aSelector are: sendsCollection. 317835 self assert: #super sendsIn: info for: aSelector are: superCollection. 317836 self assert: #class sendsIn: info for: aSelector are: classCollection. 317837! ! 317838 317839!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/3/2006 01:03'! 317840branch 317841 "This method is never run. It is here just so that the sends in it can be 317842 tallied by the SendInfo interpreter." 317843 (state 317844 ifNil: [self] 317845 ifNotNil: [state]) clip. 317846 (state isNil 317847 ifTrue: [self] 317848 ifFalse: [state]) truncate. 317849! ! 317850 317851!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/3/2006 00:36'! 317852classBranch 317853 self 317854 shouldnt: [state isNil 317855 ifTrue: [self tell] 317856 ifFalse: [self class tell]] 317857 raise: MessageNotUnderstood! ! 317858 317859!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/2/2006 23:55'! 317860clip 317861 "This method is never run. It is here just so that the sends in it can be 317862 tallied by the SendInfo interpreter." 317863 | temp | 317864 self printString. 317865 temp := self. 317866 temp error: 4 + 5! ! 317867 317868!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/2/2006 23:55'! 317869clipRect: aRectangle 317870 "This method is never run. It is here just so that the sends in it can be 317871 tallied by the SendInfo interpreter." 317872 super clipRect: aRectangle. 317873 (state notNil 317874 and: [self bitBlt notNil]) 317875 ifTrue: [state bitBlt clipRect: aRectangle]! ! 317876 317877!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/2/2006 23:55'! 317878pseudoCopy 317879 "This method is never run. It is here just so that the sends in it can be 317880 tallied by the SendInfo interpreter." 317881 | array | 317882 array := self class new: self basicSize. 317883 self 317884 instVarsWithIndexDo: [:each :i | array at: i put: each]. 317885 ^ array! ! 317886 317887!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/3/2006 00:30'! 317888superBranch 317889 self 317890 should: [state isNil 317891 ifTrue: [super tell] 317892 ifFalse: [self tell]] 317893 raise: MessageNotUnderstood! ! 317894 317895!SendsInfoTest methodsFor: 'test subjects' stamp: 'apb 3/3/2006 00:14'! 317896tell 317897 "this method should not be defined in super"! ! 317898 317899 317900!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/3/2006 00:10'! 317901testBranch 317902 self assert: #branch sends: #(clip truncate) supersends: #() classSends: #()! ! 317903 317904!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/3/2006 00:39'! 317905testClassBranch 317906 self assert: #classBranch sends: #(tell shouldnt:raise:) supersends: #() classSends: #(tell). 317907 self classBranch.! ! 317908 317909!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/2/2006 22:18'! 317910testClip 317911 self assert: #clip sends: #(printString) supersends: #() classSends: #()! ! 317912 317913!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/3/2006 00:03'! 317914testClipRect 317915 self assert: #clipRect: sends: #(bitBlt) supersends: #(clipRect:) classSends: #() 317916! ! 317917 317918!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/2/2006 23:38'! 317919testPseudoCopy 317920 self assert: #pseudoCopy sends: #(instVarsWithIndexDo: basicSize) supersends: #() classSends: #(#new:)! ! 317921 317922!SendsInfoTest methodsFor: 'tests' stamp: 'apb 3/3/2006 00:33'! 317923testSuperBranch 317924 self assert: #superBranch sends: #(tell should:raise:) supersends: #(tell) classSends: #(). 317925 self superBranch.! ! 317926PanelMorph subclass: #SeparatorMorph 317927 instanceVariableNames: '' 317928 classVariableNames: '' 317929 poolDictionaries: '' 317930 category: 'Polymorph-Widgets'! 317931!SeparatorMorph commentStamp: 'gvc 6/4/2007 14:13' prior: 0! 317932Simple themed separator morph.! 317933 317934 317935!SeparatorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/4/2007 14:21'! 317936adoptPaneColor: paneColor 317937 "Change our fill too." 317938 317939 super adoptPaneColor: paneColor. 317940 paneColor ifNil: [^self]. 317941 self fillStyle: (self theme separatorFillStyleFor: self)! ! 317942Collection subclass: #SequenceableCollection 317943 instanceVariableNames: '' 317944 classVariableNames: '' 317945 poolDictionaries: '' 317946 category: 'Collections-Abstract'! 317947!SequenceableCollection commentStamp: '<historical>' prior: 0! 317948I am an abstract superclass for collections that have a well-defined order associated with their elements. Thus each element is externally-named by integers referred to as indices.! 317949 317950 317951!SequenceableCollection methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/31/2006 15:13'! 317952aggregateRuns: aBlock 317953 "Answer a new collection of the same species as the 317954 receiver with elements being collections (of the receiver 317955 species) containing those elements of the receiver 317956 for which the given block consecutively evaluates to 317957 the same object." 317958 317959 |str r eStr t| 317960 str := Array new writeStream. 317961 r := nil. 317962 eStr := Array new writeStream. 317963 self do: [:e | 317964 (t := aBlock value: e) = r 317965 ifTrue: [eStr nextPut: e] 317966 ifFalse: [r := t. 317967 eStr isEmpty 317968 ifFalse: [str nextPut: (eStr contents as: self species). 317969 eStr reset]. 317970 eStr nextPut: e]]. 317971 eStr isEmpty ifFalse: [str nextPut: (eStr contents as: self species)]. 317972 ^str contents as: self species 317973 ! ! 317974 317975 317976!SequenceableCollection methodsFor: '*kernel-extensions' stamp: 'kph 9/27/2007 21:18'! 317977putOn: aStream 317978 317979 self do: [ :each | each putOn: aStream ]! ! 317980 317981 317982!SequenceableCollection methodsFor: '*morphic-fliprotate' stamp: 'wiz 4/7/2004 09:31'! 317983flipRotated: flipIndex 317984 "Answer a copy of the receiver with element order indicated by 317985 flipIndex." 317986 "Examples:" 317987 "'frog' flipRotated: 1" 317988 "[ :c | (1 to: c size * 2) collect: 317989 [ :i | c flipRotated: i ] 317990 ] value: 'frog'." 317991 "Lsb of flipIndex indicates whether list is reversed" 317992 "The flipIndex // 2 gives how much to rotate by after reversing" 317993 "A good way to think of this is a piece of pie in a pie plate being flip 317994 over its leading edge successively." 317995 "flipIndex > 2 * n are allowed to make it possible to store an array of 317996 indexes in an integer." 317997 | n result src twist | 317998 n := self size. 317999 flipIndex \\ (n * 2) = 0 318000 ifTrue: [^ self]. 318001 "allow for doing nothing" 318002 result := self species new: n. 318003 twist := flipIndex // 2 \\ n. 318004 src := 0. 318005 (flipIndex even 318006 ifTrue: [1 + twist to: n + twist] 318007 ifFalse: [n - 1 - twist to: twist negated by: -1]) 318008 do: [:i | result 318009 at: (src := src + 1) 318010 put: (self atWrap: i)]. 318011 ^ result! ! 318012 318013 318014!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 7/18/2004 23:12'! 318015asCubic 318016 "Convert this point array to a Cubic object" 318017 self 318018 assert: [self size = 4]. 318019 self 318020 assert: [self 318021 allSatisfy: [:each | each isPoint]]. 318022 ^ Cubic withAll: self! ! 318023 318024!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'NorbertHartl 6/20/2008 21:46'! 318025assertSlopesWith: knots from: start to: end 318026 " 318027 We trust everything has been checked. 318028 The following assertions should hold at this point: " 318029 318030 318031 | slope | 318032 self assert: [ self size = knots size ] . 318033 "Sizes must be consistent." 318034 self assert: [ end > start]. 318035 "There must be at least one slope to clamp." 318036 self assert: [ 0 < start and: [start <= knots size] ]. 318037 "The clamped slope may be the last one." 318038 self assert: [ end <= knots size + start ] . 318039 "We can wrap. There may be only one known slope." 318040 "xxx self assert: [ end = knots size + start ifTrue: [ (self at: start) notNil ] ] . xxx" 318041 "xxx If we overlap slope must be known. xxx" 318042 { start . end } 318043 do: [ :index | slope := (self at: index ). 318044 self assert: [ slope isNil 318045 or: [ slope isNumber 318046 or: [ slope isPoint ] ] ] ] . 318047 "And a known and reasonalble value or nil." 318048 ^true 318049 ! ! 318050 318051!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 1/30/2005 21:04'! 318052changeInSlopes: slopes 318053 "A message to knots of a spline. Returns an array with the 3rd cubic coeff." 318054 "The last nth item is correct iff this is a closed cubic. 318055 Presumably that is the only time we care. 318056 We always return the same sized array as self." 318057 | n slopeChanges | 318058 n := self size. 318059 n = slopes size 318060 ifFalse: [^ self error: 'vertices and slopes differ in number']. 318061 slopeChanges := Array new: n. 318062 (1 to: n) 318063 do: [:i | slopeChanges at: i put: (self atWrap: i + 1) 318064 - (self at: i) * 3 - ((slopes at: i) 318065 * 2) 318066 - (slopes atWrap: i + 1)]. 318067 318068 ^ slopeChanges! ! 318069 318070!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 1/30/2005 21:04'! 318071changeOfChangesInSlopes: slopes 318072 "A message to knots of a spline. Returns an array with the 4rd 318073 cubic coeff." 318074 "The last nth item is correct iff this is a closed cubic. 318075 Presumably that is the only time we care. 318076 We always return the same sized array as self." 318077 | n changes | 318078 n := self size. 318079 n = slopes size 318080 ifFalse: [^ self error: 'vertices and slopes differ in number']. 318081 changes := Array new: n. 318082 (1 to: n) 318083 do: [:i | changes at: i put: (self at: i) 318084 - (self atWrap: i + 1) * 2 318085 + (slopes at: i) 318086 + (slopes atWrap: i + 1)]. 318087 318088 ^ changes! ! 318089 318090!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 1/30/2005 22:03'! 318091closedCubicSlopes 318092 "Sent to knots returns the slopes of a closed cubic spline. 318093 From the same set of java sources as naturalCubic. This is a squeak 318094 transliteration of the java code." 318095 "from java code NatCubicClosed extends NatCubic 318096 solves for the set of equations for all knots: 318097 b1+4*b2+b3=3*(a3-a1) 318098 where a1 is (knots atWrap: index + 1) etc. 318099 and the b's are the slopes . 318100 318101 by decomposing the matrix into upper triangular and lower matrices 318102 and then back sustitution. See Spath 'Spline Algorithms for Curves 318103 and Surfaces' pp 19--21. The D[i] are the derivatives at the knots. 318104 " 318105 318106 | v w x y z n1 D F G H | 318107 n1 := self size. 318108 n1 < 3 318109 ifTrue: [self error: 'Less than 3 points makes a poor curve']. 318110 v := Array new: n1. 318111 w := Array new: n1. 318112 y := Array new: n1. 318113 318114 D := Array new: n1. 318115 x := self. 318116 z := 1.0 / 4.0. 318117 v at: 2 put: z. 318118 w at: 2 put: z. 318119 y at: 1 put: z * 3.0 * ((x at: 2) 318120 - (x at: n1)). 318121 H := 4.0. 318122 F := 3 * ((x at: 1) 318123 - (x at: n1 - 1)). 318124 G := 1. 318125 (2 to: n1 - 1) 318126 do: [:k | 318127 z := 1.0 / (4.0 318128 - (v at: k)). 318129 v at: k + 1 put: z. 318130 w at: k + 1 put: z negated 318131 * (w at: k). 318132 y at: k put: z * (3.0 * ((x at: k + 1) 318133 - (x at: k - 1)) 318134 - (y at: k - 1)). 318135 H := H - (G 318136 * (w at: k)). 318137 F := F - (G 318138 * (y at: k - 1)). 318139 G := (v at: k) negated * G]. 318140 H := H - (G + 1 * ((v at: n1) 318141 + (w at: n1))). 318142 y at: n1 put: F - (G + 1 318143 * (y at: n1 - 1)). 318144 D at: n1 put: (y at: n1) 318145 / H. 318146 D at: n1 - 1 put: (y at: n1 - 1) 318147 - ((v at: n1) 318148 + (w at: n1) 318149 * (D at: n1)). 318150 (1 to: n1 - 2) 318151 reverseDo: [:k | D at: k put: (y at: k) 318152 - ((v at: k + 1) 318153 * (D at: k + 1)) - ((w at: k + 1) 318154 * (D at: n1))]. 318155^ D . 318156 318157! ! 318158 318159!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 2/18/2006 12:54'! 318160closedCubicSlopes: clampedSlopes 318161 "Sent to knots returns a copy of clampedSlopes with the values of the undefined (nil) slopes filled in. 318162 " 318163 " clampedSlopes must be the same size as knots)" 318164 318165 "/* Between known slopes we solve the equation for knots with end conditions: 318166 4*b1+b2 = 3(a2 - a0) - b0 318167 bN2+4*bN1 = 3*(aN-aN2) - bN 318168 and inbetween: 318169 b2+4*b3+b4=3*(a4-a2) 318170 where a2 is (knots atWrap: index + 1) etc. 318171 and the b's are the slopes . 318172 N is the last index (knots size) 318173 N1 is N-1. 318174 318175 by using row operations to convert the matrix to upper 318176 triangular and then back substitution. 318177 " 318178 | slopes tripleKnots list | 318179 (list := clampedSlopes closedFillinList) = { 0 to: self size } ifTrue: [ ^ self closedCubicSlopes ] . 318180 "Special case all unknown." 318181 318182 tripleKnots := self * 3.0 . 318183 " Premultiply and convert numbers or point coords to Floats " 318184 slopes := clampedSlopes copy. "slopes contents will be modified." 318185 318186 list do: [ :r | slopes slopesWith: tripleKnots from: r first to: r last ] . 318187 318188 ^ slopes! ! 318189 318190!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 2/17/2006 01:42'! 318191closedFillinList 318192 "Answers a list of ranges between which values are undertermined. 318193 Reciever is a list that combines known values and nil entries for 318194 undetermined values. 318195 Answer a list of ranges. Each range starts and ends with a known 318196 value. 318197 The range inbetween the known values are nil. The ranges start and 318198 ends may overlap. 318199 Each nil element in the list appears in exactly one range. 318200 If the list starts or ends with nil the last range will wrap around to the 318201 next known value. There may be only one known value in the list but 318202 there must be atleast one know value. 318203 318204 (self allsatisfy: [ :e | e isNil ] ) ifTrue: [ self error: 'list must contain at 318205 least one known value' ] 318206 " 318207 | changes n | 318208 changes := self nilTransitions . 318209 changes isEmpty ifTrue: [ ^ { 0 to: self size } "Special case. All unknowns." ] . 318210 318211 changes = #(1) ifTrue: [ ^ #() "Special case. no unknowns." ] . 318212 changes = { n := self size } ifTrue: [ ^ { n to: n + n } ] . 318213 "Special case. Only last element known." 318214 318215 changes size even ifTrue: 318216 [changes add: self size 318217 + (changes at: 1)] 318218 ifFalse: [ 318219 changes first = 1 ifFalse: [ changes add: self size + 1; 318220 add: self size + changes first ] 318221 318222 ]. 318223 ^ changes allButFirst pairsCollect: [ :s :e | ( s - 1 to: e ) ] . 318224 318225 ! ! 318226 318227!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 7/18/2004 23:18'! 318228cubicPointPolynomialAt: vIndex 318229 "From curve information assemble a 4-array of points representing the coefficents for curve segment between to points. Beginning point is first point in array endpoint is the pointSum of the array. Meant to be sent to newcurves idea of curve coefficents." 318230 ^ ((1 to: 4) 318231 collect: [:i | ((self at: i) 318232 at: vIndex) 318233 @ ((self at: 4 + i) 318234 at: vIndex)]) asCubic! ! 318235 318236!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 2/12/2006 23:21'! 318237naturalCubicSlopes 318238 "Sent to knots returns the slopes of a natural cubic curve fit. 318239 This is a direct squeak 318240 transliteration of the java code." 318241 " public class NatCubic extends ControlCurve 318242 318243 /* We solve the equation for knots with end conditions: 318244 2*b1+b2 = 3(a1 - a0) 318245 bN1+2*bN = 3*(aN-aN1) 318246 and inbetween: 318247 b2+4*b3+b4=3*(a4-a2) 318248 where a2 is (knots atWrap: index + 1) etc. 318249 and the b's are the slopes . 318250 N is the last index (knots size) 318251 N1 is N-1. 318252 318253 by using row operations to convert the matrix to upper 318254 triangular 318255 and then back sustitution. The D[i] are the derivatives at the 318256 knots. 318257 " 318258 | x gamma delta D n1 | 318259 n1 := self size. 318260 n1 < 3 318261 ifTrue: [self error: 'Less than 3 points makes a poor curve']. 318262 x := self. 318263 gamma := Array new: n1. 318264 delta := Array new: n1. 318265 318266 D := Array new: n1. 318267 gamma at: 1 put: 1.0 / 2.0. 318268 (2 to: n1 - 1) 318269 do: [:i | gamma at: i put: 1.0 / (4.0 318270 - (gamma at: i - 1))]. 318271 gamma at: n1 put: 1.0 / (2.0 318272 - (gamma at: n1 - 1)). 318273 delta at: 1 put: 3.0 * ((x at: 2) 318274 - (x at: 1)) 318275 * (gamma at: 1). 318276 (2 to: n1 - 1) 318277 do: [:i | delta at: i put: 3.0 * ((x at: i + 1) 318278 - (x at: i - 1)) 318279 - (delta at: i - 1) 318280 * (gamma at: i)]. 318281 delta at: n1 put: 3.0 * ((x at: n1) 318282 - (x at: n1 - 1)) 318283 - (delta at: n1 - 1) 318284 * (gamma at: n1). 318285 D 318286 at: n1 318287 put: (delta at: n1). 318288 (1 to: n1 - 1) 318289 reverseDo: [:i | D at: i put: (delta at: i) 318290 - ((gamma at: i) 318291 * (D at: i + 1))]. 318292 ^ D! ! 318293 318294!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 2/18/2006 12:55'! 318295naturalCubicSlopes: clampedSlopes 318296 "Sent to knots returns a copy of clampedSlopes with the values of the undefined (nil) slopes filled in. 318297 " 318298 " clampedSlopes must be the same size as knots)" 318299 318300 "/* Between known slopes we solve the equation for knots with end conditions: 318301 4*b1+b2 = 3(a2 - a0) - b0 318302 bN2+4*bN1 = 3*(aN-aN2) - bN 318303 and inbetween: 318304 b2+4*b3+b4=3*(a4-a2) 318305 where a2 is (knots atWrap: index + 1) etc. 318306 and the b's are the slopes . 318307 N is the last index (knots size) 318308 N1 is N-1. 318309 318310 by using row operations to convert the matrix to upper 318311 triangular and then back substitution. 318312 " 318313 | slopes tripleKnots | 318314 tripleKnots := self * 3.0 . 318315 " Premultiply and convert numbers or point coords to Floats " 318316 slopes := clampedSlopes copy. "slopes will be modified." 318317 clampedSlopes naturalFillinList do: [ :r | slopes slopesWith: tripleKnots from: r first to: r last ] . 318318 318319 ^ slopes! ! 318320 318321!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 2/9/2006 00:46'! 318322naturalFillinList 318323 "Return a list of fillin ranges to be used to calculate natural or clamped slopes. 318324 Note that this list is slightly different in mission from the closedFillinList" 318325 "Answers a list of ranges between which value are undertermined. 318326 Reciever is a list that combines known values and nil entries for 318327 undetermined values. 318328 Answer a list of ranges. Each range starts and ends with a known value. 318329 With the exception of the first and last slopes on the list which may be unknown. 318330 If no slopes are known then the only range is the whole list. 318331 If all slopes are known then the fillin list is empty. 318332 The range inbetween the known values are nil. The ranges start and 318333 ends may overlap if the slope at the overlap is known. 318334 Each nil element in the list appears in exactly one range. 318335 " 318336 | changes | 318337 changes := self nilTransitions . 318338 changes isEmpty ifTrue: [ ^ { 1 to: self size } "Special case all unknown." ] . 318339 318340 changes = #(1) ifTrue: [ ^ #() "Special case. no unknowns." ] . 318341 318342 changes size even 318343 ifTrue: [changes add: self size ] . "Last slope is unknown" 318344 changes first = 1 318345 ifTrue: [ ^ changes allButFirst pairsCollect: [ :s :e | ( s - 1 to: e ) ] ] . 318346 318347 "Otherwise first slope is unknown." 318348 318349 318350 ^ { 1 to: changes first } , 318351 (changes allButFirst pairsCollect: [ :s :e | ( ( s - 1) to: e ) ]) 318352 318353 ! ! 318354 318355!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 1/29/2006 20:51'! 318356nilTransitions 318357 "Return an OrderedCollection of transition indexes. 318358 Indexes represent where the list elements transitions 318359 from nil to nonNil 318360 or from nonNil to nil. 318361 1 is an index in the list iff the first element is nonNil. " 318362 318363 | changes nilSkip | 318364 318365 changes := OrderedCollection new. 318366 nilSkip := true . 318367 318368 (1 to: self size) 318369 do: [:i | (self atWrap: i) isNil == nilSkip 318370 ifFalse: [changes add: i. 318371 nilSkip := nilSkip not]]. 318372 318373 ^ changes ! ! 318374 318375!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 5/2/2004 22:43'! 318376segmentedSlopes 318377 "For a collection of floats. Returns the slopes for straight 318378 segments between vertices." 318379 "last slope closes the polygon. Always return same size as 318380 self. " 318381 ^ self 318382 collectWithIndex: [:x :i | (self atWrap: i + 1) 318383 - x]! ! 318384 318385!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 2/18/2006 12:54'! 318386slopesWith: tripleKnots from: start to: end 318387 "Sent to modifiable list of slopes. Fills in the slope values between start 318388 and end. Start and end slopes can be either clamped or nil. 318389 If nil the natural slope for that value will be filled in. 318390 We expect that the parameters meets the assertions in 318391 self assertSlopesWith: knots from: start to: end." 318392 " 318393 318394 /* We solve the equation for knots with end conditions either known or unknown: 318395 4*b1+b2 = 3*(a2 - a0) - b0 b0 known 318396 Or 318397 2*b0+b1 = 3*(a1 - a0) . b0 == nil 318398 318399 bN2+4*bN1 = 3*(aN-aN2)-bN bN known 318400 Or 318401 bN1+2*bN = 3*(aN-aN1) bN == nil 318402 . 318403 b0, bN are starting and ending slopes. 318404 318405 We now handle the special closed cubic case where a0 == aN ( i.e. N = knots size ) 318406 and b0 == bN == nil . 318407 318408 318409 318410 318411 and inbetween: 318412 b2+4*b3+b4=3*(a4-a2) 318413 where a2 is (knots atWrap: index + 1) etc. 318414 and the b's are the slopes . 318415 by using row operations to convert the matrix to upper 318416 triangular and then back substitution. 318417 " 318418 | gamma delta n range isOpenRange | 318419 n := self size. 318420 gamma := Array new: n. 318421 delta := Array new: n. 318422 isOpenRange := end < (start + self size) . 318423 (self at: start) 318424 ifNotNil: [ 318425 gamma at: start put: 0.0. 318426 delta 318427 at: start 318428 put: (self at: start). 318429 range := ( start + 1 to: end - 1 ) . 318430 ] " clamped initial conditions" 318431 ifNil: [ 318432 isOpenRange 318433 ifTrue: 318434 [gamma at: start put: 2.0 reciprocal. 318435 delta 318436 at: start 318437 put: ((tripleKnots atWrap: start + 1) 318438 - tripleKnots at: start ) * (gamma at: start) . 318439 range := ( start to: end - 1 ) . ] "natural initial conditions " 318440 ifFalse: 318441 [ gamma at: start put: 4.0 reciprocal. 318442 delta 318443 at: start 318444 put: ((tripleKnots atWrap: start + 1) 318445 - tripleKnots atWrap: start - 1 ) * (gamma at: start) . 318446 range := ( start + 1 to: end - 1 ) . 318447 ] "closed initial conditions " 318448 ] . 318449 (start + 1 to: end - 1) 318450 do: [:i | gamma atWrap: i put: 1.0 / (4.0 318451 - (gamma atWrap: i - 1))]. 318452 (start + 1 to: end - 1) 318453 do: [:i | delta atWrap: i put: ((tripleKnots atWrap: i + 1) 318454 - (tripleKnots atWrap: i - 1)) 318455 - (delta atWrap: i - 1) 318456 * (gamma atWrap: i)]. 318457 (self atWrap: end) 318458 ifNil: [ isOpenRange 318459 ifTrue: [ 318460 gamma atWrap: end put: 1.0 / (2.0 318461 - (gamma atWrap: end - 1 )). 318462 delta 318463 atWrap: end 318464 put: ((tripleKnots atWrap: end ) 318465 - tripleKnots atWrap: end - 1 ) 318466 - (delta at: end - 1 ) * (gamma atWrap: end)] "natural end conditions" 318467 ifFalse: [ 318468 gamma atWrap: end put: 1.0 / (4.0 318469 - (gamma atWrap: end - 1 )). 318470 delta 318471 atWrap: end 318472 put: ((tripleKnots atWrap: end + 1 ) 318473 - tripleKnots atWrap: end - 1 ) 318474 - (delta at: end - 1 ) * (gamma atWrap: end)] "closed end conditions" 318475 . 318476 self atWrap: end put: (delta atWrap: end ) . 318477 ] 318478 ifNotNil: [ 318479 gamma atWrap: end put: 0.0 . 318480 delta 318481 atWrap: end 318482 put: (self atWrap: end) . 318483 318484 ] "clamped end conditions" . 318485 318486 range 318487 reverseDo: [:i | self atWrap: i put: 318488 (delta atWrap: i) 318489 - ((gamma atWrap: i) 318490 * (self atWrap: i + 1)) ] . 318491 " reciever now contains the filled in slopes." 318492 ^ self ! ! 318493 318494!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 2/16/2006 20:08'! 318495transitions 318496 "Sent to a list of boolean values. 318497 Return an OrderedCollection of transition indexes. 318498 Indexes represent where the list elements transitions 318499 from true to false 318500 or from false to true. 318501 1 is an index in the list iff the first element is false. " 318502 318503 | changes boolSkip | 318504 318505 changes := OrderedCollection new. 318506 boolSkip := true . 318507 318508 self 318509 withIndexDo: [:truth :i | truth == boolSkip 318510 ifFalse: [changes add: i. 318511 boolSkip := boolSkip not]]. 318512 318513 ^ changes ! ! 318514 318515!SequenceableCollection methodsFor: '*morphic-newcurves-cubic support' stamp: 'wiz 2/16/2006 20:09'! 318516transitions: aSelectBlock 318517 "Sent to a list. Select block returns a boolean 318518 Return an OrderedCollection of transition indexes. 318519 Indexes represent where the list elements transitions 318520 from true to false 318521 or from false to true. 318522 1 is an index in the list iff the first element tests false. " 318523 318524 | changes boolSkip | 318525 318526 changes := OrderedCollection new. 318527 boolSkip := true . 318528 318529 self withIndexDo: 318530 [:e :i | (aSelectBlock value: e ) == boolSkip 318531 ifFalse: [changes add: i. 318532 boolSkip := boolSkip not]]. 318533 318534 ^ changes ! ! 318535 318536 318537!SequenceableCollection methodsFor: '*splitjoin' stamp: 'onierstrasz 4/12/2009 19:58'! 318538appendTo: aCollection 318539 "double dispatch for join:" 318540 ^ aCollection addAllLast: self! ! 318541 318542!SequenceableCollection methodsFor: '*splitjoin' stamp: 'onierstrasz 4/12/2009 20:19'! 318543join: aCollection 318544 "NB: this implementation only works for Array, since WriteStreams only work for Arrays and Strings. (!!) 318545 Overridden in OrderedCollection and SortedCollection." 318546 ^ self class 318547 streamContents: [:stream | aCollection 318548 do: [:each | each joinTo: stream] 318549 separatedBy: [stream nextPutAll: self]]! ! 318550 318551!SequenceableCollection methodsFor: '*splitjoin' stamp: 'onierstrasz 4/12/2009 19:58'! 318552joinTo: stream 318553 "double dispatch for join:" 318554 ^ stream nextPutAll: self! ! 318555 318556!SequenceableCollection methodsFor: '*splitjoin' stamp: 'onierstrasz 4/10/2009 22:53'! 318557joinUsing: joiner 318558 "joiner - character, string or sequenceable collection 318559 returns collection of the same collection class as 'joiner', or a String" 318560 ^ joiner join: self! ! 318561 318562!SequenceableCollection methodsFor: '*splitjoin' stamp: 'onierstrasz 4/10/2009 22:54'! 318563joinUsing: joiner last: last 318564 "#(1 2 3 4) joinUsing: ', ' last: 'and'. => '1, 2, 3 and 4" 318565 ^ last join: (Array 318566 with: (joiner join: self allButLast) 318567 with: self last)! ! 318568 318569!SequenceableCollection methodsFor: '*splitjoin' stamp: 'onierstrasz 4/12/2009 20:57'! 318570split: aSequencableCollection 318571 | result position oldPosition | 318572 result := OrderedCollection new. 318573 position := 1. 318574 oldPosition := position. 318575 position := aSequencableCollection indexOfSubCollection: self startingAt: position. 318576 [ position > 0 ] whileTrue: [ 318577 result add: (aSequencableCollection copyFrom: oldPosition to: position - 1). 318578 position := position + self size. 318579 oldPosition := position. 318580 position := aSequencableCollection indexOfSubCollection: self startingAt: position. 318581 ]. 318582 result add: (aSequencableCollection copyFrom: oldPosition to: aSequencableCollection size). 318583 ^ result 318584 318585! ! 318586 318587!SequenceableCollection methodsFor: '*splitjoin' stamp: 'onierstrasz 4/12/2009 20:20'! 318588splitOn: splitter 318589 "splitter - can be a subsequence, a Block or a Regex (String receiver only). 318590 Any other object used as a splitter is treated as an Array containing that object." 318591 ^ splitter split: self! ! 318592 318593 318594!SequenceableCollection methodsFor: '*traits' stamp: 'apb 8/22/2005 17:07'! 318595asTraitComposition 318596 "For convenience the composition {T1. T2 ...} is the same as T1 + T2 + ..." 318597 ^self isEmpty 318598 ifFalse: [ 318599 self size = 1 318600 ifTrue: [self first asTraitComposition] 318601 ifFalse: [ 318602 self copyWithoutFirst 318603 inject: self first 318604 into: [:left :right | left + right]]] 318605 ifTrue: [ 318606 TraitComposition new]! ! 318607 318608 318609!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 18:00'! 318610after: target 318611 "Answer the element after target. Raise an error if target is not 318612 in the receiver, or if there are no elements after it." 318613 318614 ^ self after: target ifAbsent: [self errorNotFound: target]! ! 318615 318616!SequenceableCollection methodsFor: 'accessing' stamp: 'ac 7/5/2004 22:35'! 318617after: target ifAbsent: exceptionBlock 318618 "Answer the element after target. Answer the result of evaluation 318619 the exceptionBlock if target is not in the receiver, or if there are 318620 no elements after it." 318621 318622 | index | 318623 index := self indexOf: target. 318624 ^ (index == 0 or: [index = self size]) 318625 ifTrue: [exceptionBlock value] 318626 ifFalse: [self at: index + 1]! ! 318627 318628!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:34'! 318629allButFirst 318630 "Answer a copy of the receiver containing all but the first 318631 element. Raise an error if there are not enough elements." 318632 318633 ^ self allButFirst: 1! ! 318634 318635!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:35'! 318636allButFirst: n 318637 "Answer a copy of the receiver containing all but the first n 318638 elements. Raise an error if there are not enough elements." 318639 318640 ^ self copyFrom: n + 1 to: self size! ! 318641 318642!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:35'! 318643allButLast 318644 "Answer a copy of the receiver containing all but the last 318645 element. Raise an error if there are not enough elements." 318646 318647 ^ self allButLast: 1! ! 318648 318649!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:35'! 318650allButLast: n 318651 "Answer a copy of the receiver containing all but the last n 318652 elements. Raise an error if there are not enough elements." 318653 318654 ^ self copyFrom: 1 to: self size - n! ! 318655 318656!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:33'! 318657anyOne 318658 ^ self first! ! 318659 318660!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:45'! 318661atAllPut: anObject 318662 "Put anObject at every one of the receiver's indices." 318663 318664 | size | 318665 (size := self size) > 26 "first method faster from 27 accesses and on" 318666 ifTrue: [self from: 1 to: size put: anObject] 318667 ifFalse: [1 to: size do: [:index | self at: index put: anObject]]! ! 318668 318669!SequenceableCollection methodsFor: 'accessing' stamp: 'apb 11/4/2000 22:51'! 318670atAll: indexArray 318671 "Answer a new collection like the receiver which contains all elements 318672 of the receiver at the indices of indexArray." 318673 "#('one' 'two' 'three' 'four') atAll: #(3 2 4)" 318674 318675 | newCollection | 318676 newCollection := self species ofSize: indexArray size. 318677 1 to: indexArray size do: 318678 [:index | 318679 newCollection at: index put: (self at: (indexArray at: index))]. 318680 ^ newCollection! ! 318681 318682!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:18'! 318683atAll: indexArray putAll: valueArray 318684 "Store the elements of valueArray into the slots 318685 of this collection selected by indexArray." 318686 318687 indexArray with: valueArray do: [:index :value | self at: index put: value]. 318688 ^ valueArray! ! 318689 318690!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:17'! 318691atAll: aCollection put: anObject 318692 "Put anObject at every index specified by the elements of aCollection." 318693 318694 aCollection do: [:index | self at: index put: anObject]. 318695 ^ anObject! ! 318696 318697!SequenceableCollection methodsFor: 'accessing' stamp: 'nk 6/12/2004 17:06'! 318698atLast: indexFromEnd 318699 "Return element at indexFromEnd from the last position. 318700 atLast: 1, returns the last element" 318701 318702 ^ self atLast: indexFromEnd ifAbsent: [self error: 'index out of range']! ! 318703 318704!SequenceableCollection methodsFor: 'accessing' stamp: 'ajh 6/27/2002 17:52'! 318705atLast: indexFromEnd ifAbsent: block 318706 "Return element at indexFromEnd from the last position. 318707 atLast: 1 ifAbsent: [] returns the last element" 318708 318709 ^ self at: self size + 1 - indexFromEnd ifAbsent: block! ! 318710 318711!SequenceableCollection methodsFor: 'accessing' stamp: 'ajh 6/27/2002 18:10'! 318712atLast: indexFromEnd put: obj 318713 "Set the element at indexFromEnd from the last position. 318714 atLast: 1 put: obj, sets the last element" 318715 318716 ^ self at: self size + 1 - indexFromEnd put: obj! ! 318717 318718!SequenceableCollection methodsFor: 'accessing' stamp: 'di 11/6/1998 14:32'! 318719atPin: index 318720 "Return the index'th element of me if possible. 318721 Return the first or last element if index is out of bounds." 318722 318723 index < 1 ifTrue: [^ self first]. 318724 index > self size ifTrue: [^ self last]. 318725 ^ self at: index! ! 318726 318727!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:50'! 318728atRandom: aGenerator 318729 "Answer a random element of the receiver. Uses aGenerator which 318730 should be kept by the user in a variable and used every time. Use 318731 this instead of #atRandom for better uniformity of random numbers 318732 because only you use the generator. Causes an error if self has no 318733 elements." 318734 318735 ^ self at: (aGenerator nextInt: self size)! ! 318736 318737!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 13:51'! 318738atWrap: index 318739 "Answer the index'th element of the receiver. If index is out of bounds, 318740 let it wrap around from the end to the beginning until it is in bounds." 318741 318742 ^ self at: index - 1 \\ self size + 1! ! 318743 318744!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 13:52'! 318745atWrap: index put: value 318746 "Store value into the index'th element of the receiver. If index is out 318747 of bounds, let it wrap around from the end to the beginning until it 318748 is in bounds. Answer value." 318749 318750 ^ self at: index - 1 \\ self size + 1 put: value! ! 318751 318752!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:11'! 318753at: index ifAbsent: exceptionBlock 318754 "Answer the element at my position index. If I do not contain an element 318755 at index, answer the result of evaluating the argument, exceptionBlock." 318756 318757 (index between: 1 and: self size) ifTrue: [^ self at: index]. 318758 ^ exceptionBlock value! ! 318759 318760!SequenceableCollection methodsFor: 'accessing' stamp: 'raok 11/22/2002 12:34'! 318761at: index incrementBy: value 318762 ^self at: index put: (self at: index) + value! ! 318763 318764!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 18:04'! 318765before: target 318766 "Answer the receiver's element immediately before target. Raise an 318767 error if target is not an element of the receiver, or if there are no 318768 elements before it (i.e. it is the first element)." 318769 318770 ^ self before: target ifAbsent: [self errorNotFound: target]! ! 318771 318772!SequenceableCollection methodsFor: 'accessing' stamp: 'ac 7/5/2004 22:36'! 318773before: target ifAbsent: exceptionBlock 318774 "Answer the receiver's element immediately before target. Answer 318775 the result of evaluating the exceptionBlock if target is not an element 318776 of the receiver, or if there are no elements before it." 318777 318778 | index | 318779 index := self indexOf: target. 318780 ^ (index == 0 or: [index == 1]) 318781 ifTrue: [exceptionBlock value] 318782 ifFalse: [self at: index - 1]! ! 318783 318784!SequenceableCollection methodsFor: 'accessing' stamp: 'yo 8/27/2008 23:17'! 318785customizeExplorerContents 318786 318787 ^ true. 318788! ! 318789 318790!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:21'! 318791eighth 318792 "Answer the eighth element of the receiver. 318793 Raise an error if there are not enough elements." 318794 318795 ^ self at: 8! ! 318796 318797!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:21'! 318798fifth 318799 "Answer the fifth element of the receiver. 318800 Raise an error if there are not enough elements." 318801 318802 ^ self at: 5! ! 318803 318804!SequenceableCollection methodsFor: 'accessing' stamp: 'md 1/19/2006 09:57'! 318805first 318806 "Answer the first element of the receiver" 318807 318808 ^ self at: 1! ! 318809 318810!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:31'! 318811first: n 318812 "Answer the first n elements of the receiver. 318813 Raise an error if there are not enough elements." 318814 318815 ^ self copyFrom: 1 to: n! ! 318816 318817!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:21'! 318818fourth 318819 "Answer the fourth element of the receiver. 318820 Raise an error if there are not enough elements." 318821 318822 ^ self at: 4! ! 318823 318824!SequenceableCollection methodsFor: 'accessing' stamp: 'SqR 10/30/2000 22:06'! 318825from: startIndex to: endIndex put: anObject 318826 "Put anObject in all indexes between startIndex 318827 and endIndex. Very fast. Faster than to:do: for 318828 more than 26 positions. Answer anObject" 318829 318830 | written toWrite thisWrite | 318831 318832 startIndex > endIndex ifTrue: [^self]. 318833 self at: startIndex put: anObject. 318834 written := 1. 318835 toWrite := endIndex - startIndex + 1. 318836 [written < toWrite] whileTrue: 318837 [ 318838 thisWrite := written min: toWrite - written. 318839 self 318840 replaceFrom: startIndex + written 318841 to: startIndex + written + thisWrite - 1 318842 with: self startingAt: startIndex. 318843 written := written + thisWrite 318844 ]. 318845 ^anObject! ! 318846 318847!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 8/14/1998 21:20'! 318848identityIndexOf: anElement 318849 "Answer the index of anElement within the receiver. If the receiver does 318850 not contain anElement, answer 0." 318851 318852 ^self identityIndexOf: anElement ifAbsent: [0]! ! 318853 318854!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 8/14/1998 21:21'! 318855identityIndexOf: anElement ifAbsent: exceptionBlock 318856 "Answer the index of anElement within the receiver. If the receiver does 318857 not contain anElement, answer the result of evaluating the argument, 318858 exceptionBlock." 318859 1 to: self size do: 318860 [:i | (self at: i) == anElement ifTrue: [^ i]]. 318861 ^ exceptionBlock value! ! 318862 318863!SequenceableCollection methodsFor: 'accessing'! 318864indexOfSubCollection: aSubCollection startingAt: anIndex 318865 "Answer the index of the receiver's first element, such that that element 318866 equals the first element of aSubCollection, and the next elements equal 318867 the rest of the elements of aSubCollection. Begin the search at element 318868 anIndex of the receiver. If no such match is found, answer 0." 318869 318870 ^self 318871 indexOfSubCollection: aSubCollection 318872 startingAt: anIndex 318873 ifAbsent: [0]! ! 318874 318875!SequenceableCollection methodsFor: 'accessing'! 318876indexOfSubCollection: sub startingAt: start ifAbsent: exceptionBlock 318877 "Answer the index of the receiver's first element, such that that element 318878 equals the first element of sub, and the next elements equal 318879 the rest of the elements of sub. Begin the search at element 318880 start of the receiver. If no such match is found, answer the result of 318881 evaluating argument, exceptionBlock." 318882 | first index | 318883 sub isEmpty ifTrue: [^ exceptionBlock value]. 318884 first := sub first. 318885 start to: self size - sub size + 1 do: 318886 [:startIndex | 318887 (self at: startIndex) = first ifTrue: 318888 [index := 1. 318889 [(self at: startIndex+index-1) = (sub at: index)] 318890 whileTrue: 318891 [index = sub size ifTrue: [^startIndex]. 318892 index := index+1]]]. 318893 ^ exceptionBlock value! ! 318894 318895!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:46'! 318896indexOf: anElement 318897 "Answer the index of the first occurence of anElement within the 318898 receiver. If the receiver does not contain anElement, answer 0." 318899 318900 ^ self indexOf: anElement ifAbsent: [0]! ! 318901 318902!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:47'! 318903indexOf: anElement ifAbsent: exceptionBlock 318904 "Answer the index of the first occurence of anElement within the 318905 receiver. If the receiver does not contain anElement, answer the 318906 result of evaluating the argument, exceptionBlock." 318907 318908 ^ self indexOf: anElement startingAt: 1 ifAbsent: exceptionBlock! ! 318909 318910!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:47'! 318911indexOf: anElement startingAt: start ifAbsent: exceptionBlock 318912 "Answer the index of the first occurence of anElement after start 318913 within the receiver. If the receiver does not contain anElement, 318914 answer the result of evaluating the argument, exceptionBlock." 318915 318916 start to: self size do: 318917 [:index | 318918 (self at: index) = anElement ifTrue: [^ index]]. 318919 ^ exceptionBlock value! ! 318920 318921!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:43'! 318922integerAt: index 318923 "Return the integer at the given index" 318924 ^self at: index! ! 318925 318926!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:43'! 318927integerAt: index put: value 318928 "Return the integer at the given index" 318929 ^self at: index put: value! ! 318930 318931!SequenceableCollection methodsFor: 'accessing' stamp: 'md 1/19/2006 09:56'! 318932last 318933 "Answer the last element of the receiver" 318934 318935 ^ self at: self size! ! 318936 318937!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 12/16/2001 01:06'! 318938lastIndexOf: anElement 318939 "Answer the index of the last occurence of anElement within the 318940 receiver. If the receiver does not contain anElement, answer 0." 318941 318942 ^ self lastIndexOf: anElement startingAt: self size ifAbsent: [0]! ! 318943 318944!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 12/16/2001 01:06'! 318945lastIndexOf: anElement ifAbsent: exceptionBlock 318946 "Answer the index of the last occurence of anElement within the 318947 receiver. If the receiver does not contain anElement, answer the 318948 result of evaluating the argument, exceptionBlock." 318949 ^self lastIndexOf: anElement startingAt: self size ifAbsent: exceptionBlock! ! 318950 318951!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 12/16/2001 01:05'! 318952lastIndexOf: anElement startingAt: lastIndex ifAbsent: exceptionBlock 318953 "Answer the index of the last occurence of anElement within the 318954 receiver. If the receiver does not contain anElement, answer the 318955 result of evaluating the argument, exceptionBlock." 318956 318957 lastIndex to: 1 by: -1 do: 318958 [:index | 318959 (self at: index) = anElement ifTrue: [^ index]]. 318960 ^ exceptionBlock value! ! 318961 318962!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:30'! 318963last: n 318964 "Answer the last n elements of the receiver. 318965 Raise an error if there are not enough elements." 318966 318967 | size | 318968 size := self size. 318969 ^ self copyFrom: size - n + 1 to: size! ! 318970 318971!SequenceableCollection methodsFor: 'accessing' stamp: 'md 1/19/2006 09:56'! 318972middle 318973 "Answer the middle element of the receiver." 318974 ^ self at: self size // 2 + 1! ! 318975 318976!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:21'! 318977ninth 318978 "Answer the ninth element of the receiver. 318979 Raise an error if there are not enough elements." 318980 318981 ^ self at: 9! ! 318982 318983!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 1/20/98 16:22'! 318984replaceAll: oldObject with: newObject 318985 "Replace all occurences of oldObject with newObject" 318986 | index | 318987 index := self 318988 indexOf: oldObject 318989 startingAt: 1 318990 ifAbsent: [0]. 318991 [index = 0] 318992 whileFalse: 318993 [self at: index put: newObject. 318994 index := self 318995 indexOf: oldObject 318996 startingAt: index + 1 318997 ifAbsent: [0]]! ! 318998 318999!SequenceableCollection methodsFor: 'accessing'! 319000replaceFrom: start to: stop with: replacement 319001 "This destructively replaces elements from start to stop in the receiver. 319002 Answer the receiver itself. Use copyReplaceFrom:to:with: for 319003 insertion/deletion which may alter the size of the result." 319004 319005 replacement size = (stop - start + 1) 319006 ifFalse: [self error: 'Size of replacement doesnt match']. 319007 ^self replaceFrom: start to: stop with: replacement startingAt: 1! ! 319008 319009!SequenceableCollection methodsFor: 'accessing'! 319010replaceFrom: start to: stop with: replacement startingAt: repStart 319011 "This destructively replaces elements from start to stop in the receiver 319012 starting at index, repStart, in the sequenceable collection, 319013 replacementCollection. Answer the receiver. No range checks are 319014 performed." 319015 319016 | index repOff | 319017 repOff := repStart - start. 319018 index := start - 1. 319019 [(index := index + 1) <= stop] 319020 whileTrue: [self at: index put: (replacement at: repOff + index)]! ! 319021 319022!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:21'! 319023second 319024 "Answer the second element of the receiver. 319025 Raise an error if there are not enough elements." 319026 319027 ^ self at: 2! ! 319028 319029!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:21'! 319030seventh 319031 "Answer the seventh element of the receiver. 319032 Raise an error if there are not enough elements." 319033 319034 ^ self at: 7! ! 319035 319036!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:22'! 319037sixth 319038 "Answer the sixth element of the receiver. 319039 Raise an error if there are not enough elements." 319040 319041 ^ self at: 6! ! 319042 319043!SequenceableCollection methodsFor: 'accessing'! 319044swap: oneIndex with: anotherIndex 319045 "Move the element at oneIndex to anotherIndex, and vice-versa." 319046 319047 | element | 319048 element := self at: oneIndex. 319049 self at: oneIndex put: (self at: anotherIndex). 319050 self at: anotherIndex put: element! ! 319051 319052!SequenceableCollection methodsFor: 'accessing' stamp: 'JMM 10/30/2005 09:22'! 319053third 319054 "Answer the third element of the receiver. 319055 Raise an error if there are not enough elements." 319056 319057 ^ self at: 3! ! 319058 319059 319060!SequenceableCollection methodsFor: 'comparing' stamp: 'tk 12/6/2000 11:39'! 319061hasEqualElements: otherCollection 319062 "Answer whether the receiver's size is the same as otherCollection's 319063 size, and each of the receiver's elements equal the corresponding 319064 element of otherCollection. 319065 This should probably replace the current definition of #= ." 319066 319067 | size | 319068 (otherCollection isKindOf: SequenceableCollection) ifFalse: [^ false]. 319069 (size := self size) = otherCollection size ifFalse: [^ false]. 319070 1 to: size do: 319071 [:index | 319072 (self at: index) = (otherCollection at: index) ifFalse: [^ false]]. 319073 ^ true! ! 319074 319075!SequenceableCollection methodsFor: 'comparing' stamp: 'SqR 8/3/2000 13:39'! 319076hash 319077 | hash | 319078 319079 hash := self species hash. 319080 1 to: self size do: [:i | hash := (hash + (self at: i) hash) hashMultiply]. 319081 ^hash! ! 319082 319083!SequenceableCollection methodsFor: 'comparing' stamp: 'sma 5/12/2000 14:04'! 319084= otherCollection 319085 "Answer true if the receiver is equivalent to the otherCollection. 319086 First test for identity, then rule out different species and sizes of 319087 collections. As a last resort, examine each element of the receiver 319088 and the otherCollection." 319089 319090 self == otherCollection ifTrue: [^ true]. 319091 self species == otherCollection species ifFalse: [^ false]. 319092 ^ self hasEqualElements: otherCollection! ! 319093 319094 319095!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:32'! 319096asArray 319097 "Answer an Array whose elements are the elements of the receiver." 319098 319099 ^ Array withAll: self! ! 319100 319101!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:36'! 319102asByteArray 319103 "Answer a ByteArray whose elements are the elements of the receiver." 319104 319105 ^ ByteArray withAll: self! ! 319106 319107!SequenceableCollection methodsFor: 'converting' stamp: 'ar 3/3/2001 20:06'! 319108asColorArray 319109 ^ColorArray withAll: self! ! 319110 319111!SequenceableCollection methodsFor: 'converting' stamp: 'ar 9/14/1998 23:47'! 319112asFloatArray 319113 "Answer a FloatArray whose elements are the elements of the receiver, in 319114 the same order." 319115 319116 | floatArray | 319117 floatArray := FloatArray new: self size. 319118 1 to: self size do:[:i| floatArray at: i put: (self at: i) asFloat ]. 319119 ^floatArray! ! 319120 319121!SequenceableCollection methodsFor: 'converting' stamp: 'ar 10/10/1998 16:19'! 319122asIntegerArray 319123 "Answer an IntegerArray whose elements are the elements of the receiver, in 319124 the same order." 319125 319126 | intArray | 319127 intArray := IntegerArray new: self size. 319128 1 to: self size do:[:i| intArray at: i put: (self at: i)]. 319129 ^intArray! ! 319130 319131!SequenceableCollection methodsFor: 'converting' stamp: 'NS 5/30/2001 20:56'! 319132asPointArray 319133 "Answer an PointArray whose elements are the elements of the receiver, in 319134 the same order." 319135 319136 | pointArray | 319137 pointArray := PointArray new: self size. 319138 1 to: self size do:[:i| pointArray at: i put: (self at: i)]. 319139 ^pointArray! ! 319140 319141!SequenceableCollection methodsFor: 'converting' stamp: 'PeterHugossonMiller 9/3/2009 11:11'! 319142asStringWithCr 319143 "Convert to a string with returns between items. Elements are 319144usually strings. 319145 Useful for labels for PopUpMenus." 319146 | labelStream | 319147 labelStream := (String new: 200) writeStream. 319148 self do: [:each | 319149 each isString 319150 ifTrue: [labelStream nextPutAll: each; cr] 319151 ifFalse: [each printOn: labelStream. labelStream cr]]. 319152 self size > 0 ifTrue: [labelStream skip: -1]. 319153 ^ labelStream contents! ! 319154 319155!SequenceableCollection methodsFor: 'converting' stamp: 'ar 10/10/1998 16:20'! 319156asWordArray 319157 "Answer a WordArray whose elements are the elements of the receiver, in 319158 the same order." 319159 319160 | wordArray | 319161 wordArray := WordArray new: self size. 319162 1 to: self size do:[:i| wordArray at: i put: (self at: i)]. 319163 ^wordArray! ! 319164 319165!SequenceableCollection methodsFor: 'converting' stamp: 'raok 6/23/2003 12:51'! 319166concatenation 319167 |result index| 319168 319169 result := Array new: (self inject: 0 into: [:sum :each | sum + each size]). 319170 index := 0. 319171 self do: [:each | each do: [:item | result at: (index := index+1) put: item]]. 319172 ^result! ! 319173 319174!SequenceableCollection methodsFor: 'converting' stamp: 'di 11/6/1998 09:35'! 319175isSequenceable 319176 ^ true! ! 319177 319178!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 12:51'! 319179readStream 319180 ^ ReadStream on: self! ! 319181 319182!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:56'! 319183reverse 319184 ^ self reversed! ! 319185 319186!SequenceableCollection methodsFor: 'converting' stamp: 'jm 4/27/98 04:09'! 319187reversed 319188 "Answer a copy of the receiver with element order reversed." 319189 "Example: 'frog' reversed" 319190 319191 | n result src | 319192 n := self size. 319193 result := self species new: n. 319194 src := n + 1. 319195 1 to: n do: [:i | result at: i put: (self at: (src := src - 1))]. 319196 ^ result 319197! ! 319198 319199!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 12:52'! 319200writeStream 319201 ^ WriteStream on: self! ! 319202 319203!SequenceableCollection methodsFor: 'converting' stamp: 'TAG 11/6/1998 15:55'! 319204@ aCollection 319205 ^ self with: aCollection collect: [:a :b | a @ b]! ! 319206 319207 319208!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:05'! 319209copyAfterLast: anElement 319210 "Answer a copy of the receiver from after the last occurence 319211 of anElement up to the end. If no such element exists, answer 319212 an empty copy." 319213 319214 ^ self allButFirst: (self lastIndexOf: anElement ifAbsent: [^ self copyEmpty])! ! 319215 319216!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:05'! 319217copyAfter: anElement 319218 "Answer a copy of the receiver from after the first occurence 319219 of anElement up to the end. If no such element exists, answer 319220 an empty copy." 319221 319222 ^ self allButFirst: (self indexOf: anElement ifAbsent: [^ self copyEmpty])! ! 319223 319224!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:07'! 319225copyEmpty 319226 ^ self species new: 0! ! 319227 319228!SequenceableCollection methodsFor: 'copying'! 319229copyFrom: start to: stop 319230 "Answer a copy of a subset of the receiver, starting from element at 319231 index start until element at index stop." 319232 319233 | newSize | 319234 newSize := stop - start + 1. 319235 ^(self species new: newSize) 319236 replaceFrom: 1 319237 to: newSize 319238 with: self 319239 startingAt: start! ! 319240 319241!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:06'! 319242copyLast: num 319243 "Deprecated. Use #last:" 319244 319245 ^ self last: num! ! 319246 319247!SequenceableCollection methodsFor: 'copying'! 319248copyReplaceAll: oldSubstring with: newSubstring 319249 "Default is not to do token matching. 319250 See also String copyReplaceTokens:with:" 319251 ^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: false 319252 "'How now brown cow?' copyReplaceAll: 'ow' with: 'ello'" 319253 "'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Pile'"! ! 319254 319255!SequenceableCollection methodsFor: 'copying' stamp: 'ar 10/16/2001 19:03'! 319256copyReplaceFrom: start to: stop with: replacementCollection 319257 "Answer a copy of the receiver satisfying the following conditions: If 319258 stop is less than start, then this is an insertion; stop should be exactly 319259 start-1, start = 1 means insert before the first character, start = size+1 319260 means append after last character. Otherwise, this is a replacement; start 319261 and stop have to be within the receiver's bounds." 319262 319263 | newSequenceableCollection newSize endReplacement | 319264 newSize := self size - (stop - start + 1) + replacementCollection size. 319265 endReplacement := start - 1 + replacementCollection size. 319266 newSequenceableCollection := self species new: newSize. 319267 start > 1 ifTrue:[ 319268 newSequenceableCollection 319269 replaceFrom: 1 319270 to: start - 1 319271 with: self 319272 startingAt: 1]. 319273 start <= endReplacement ifTrue:[ 319274 newSequenceableCollection 319275 replaceFrom: start 319276 to: endReplacement 319277 with: replacementCollection 319278 startingAt: 1]. 319279 endReplacement < newSize ifTrue:[ 319280 newSequenceableCollection 319281 replaceFrom: endReplacement + 1 319282 to: newSize 319283 with: self 319284 startingAt: stop + 1]. 319285 ^newSequenceableCollection! ! 319286 319287!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:02'! 319288copyUpToLast: anElement 319289 "Answer a copy of the receiver from index 1 to the last occurrence of 319290 anElement, not including anElement." 319291 319292 ^ self first: (self lastIndexOf: anElement ifAbsent: [^ self copy]) - 1! ! 319293 319294!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:00'! 319295copyUpTo: anElement 319296 "Answer all elements up to but not including anObject. If there 319297 is no such object, answer a copy of the receiver." 319298 319299 ^ self first: (self indexOf: anElement ifAbsent: [^ self copy]) - 1! ! 319300 319301!SequenceableCollection methodsFor: 'copying' stamp: 'ajh 9/27/2002 12:09'! 319302copyWithFirst: newElement 319303 "Answer a copy of the receiver that is 1 bigger than the receiver with newElement as the first element." 319304 319305 | newIC | 319306 newIC := self species ofSize: self size + 1. 319307 newIC 319308 replaceFrom: 2 319309 to: self size + 1 319310 with: self 319311 startingAt: 1. 319312 newIC at: 1 put: newElement. 319313 ^ newIC! ! 319314 319315!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 15:38'! 319316copyWithoutFirst 319317 "Deprecatd. Return a copy of the receiver which doesn't include 319318 the first element." 319319 319320 ^ self allButFirst! ! 319321 319322!SequenceableCollection methodsFor: 'copying' stamp: 'rhi 12/6/2001 14:04'! 319323copyWithoutIndex: index 319324 "Return a copy containing all elements except the index-th." 319325 319326 | copy | 319327 copy := self species ofSize: self size - 1. 319328 copy replaceFrom: 1 to: index-1 with: self startingAt: 1. 319329 copy replaceFrom: index to: copy size with: self startingAt: index+1. 319330 ^ copy! ! 319331 319332!SequenceableCollection methodsFor: 'copying'! 319333copyWith: newElement 319334 "Answer a copy of the receiver that is 1 bigger than the receiver and has 319335 newElement at the last element." 319336 319337 | newIC | 319338 newIC := self species new: self size + 1. 319339 newIC 319340 replaceFrom: 1 319341 to: self size 319342 with: self 319343 startingAt: 1. 319344 newIC at: newIC size put: newElement. 319345 ^newIC! ! 319346 319347!SequenceableCollection methodsFor: 'copying' stamp: 'nice 2/26/2009 11:48'! 319348forceTo: length paddingStartWith: elem 319349 "Force the length of the collection to length, padding 319350 the beginning of the result if necessary with elem. 319351 Note that this makes a copy." 319352 | newCollection padLen | 319353 newCollection := self species ofSize: length. 319354 padLen := length - self size max: 0. 319355 newCollection 319356 from: 1 319357 to: padLen 319358 put: elem. 319359 newCollection 319360 replaceFrom: padLen + 1 319361 to: ((padLen + self size) min: length) 319362 with: self 319363 startingAt: 1. 319364 ^ newCollection! ! 319365 319366!SequenceableCollection methodsFor: 'copying' stamp: 'nice 2/24/2009 11:33'! 319367forceTo: length paddingWith: elem 319368 "Force the length of the collection to length, padding 319369 if necessary with elem. Note that this makes a copy." 319370 319371 | newCollection | 319372 newCollection := self species new: length withAll: elem. 319373 newCollection replaceFrom: 1 to: (self size min: length) with: self startingAt: 1. 319374 ^ newCollection! ! 319375 319376!SequenceableCollection methodsFor: 'copying' stamp: 'nice 2/26/2009 11:26'! 319377grownBy: length 319378 "Answer a copy of receiver collection with size grown by length" 319379 319380 | newCollection | 319381 newCollection := self species ofSize: self size + length. 319382 newCollection replaceFrom: 1 to: self size with: self startingAt: 1. 319383 ^ newCollection! ! 319384 319385!SequenceableCollection methodsFor: 'copying'! 319386shallowCopy 319387 319388 ^self copyFrom: 1 to: self size! ! 319389 319390!SequenceableCollection methodsFor: 'copying' stamp: 'sma 5/12/2000 12:36'! 319391shuffled 319392 ^ self shuffledBy: Collection randomForPicking 319393 319394"Examples: 319395 ($A to: $Z) shuffled 319396"! ! 319397 319398!SequenceableCollection methodsFor: 'copying' stamp: 'djp 10/23/1999 22:12'! 319399shuffledBy: aRandom 319400 | copy | 319401 copy := self shallowCopy. 319402 copy size to: 1 by: -1 do: 319403 [:i | copy swap: i with: ((1 to: i) atRandom: aRandom)]. 319404 ^ copy! ! 319405 319406!SequenceableCollection methodsFor: 'copying' stamp: 'sma 4/28/2000 18:34'! 319407sortBy: aBlock 319408 "Create a copy that is sorted. Sort criteria is the block that accepts two arguments. 319409 When the block is true, the first arg goes first ([:a :b | a > b] sorts in descending 319410 order)." 319411 319412 ^ (self asSortedCollection: aBlock) asOrderedCollection! ! 319413 319414!SequenceableCollection methodsFor: 'copying' stamp: 'md 7/14/2006 12:11'! 319415, otherCollection 319416 "Concatenate two Strings or Collections." 319417 319418 ^ self copyReplaceFrom: self size + 1 319419 to: self size 319420 with: otherCollection 319421" 319422#(2 4 6 8) , #(who do we appreciate) 319423((2989 storeStringBase: 16) copyFrom: 4 to: 6) , ' boy!!' 319424"! ! 319425 319426 319427!SequenceableCollection methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 08:09'! 319428startsWith: aSequenceableCollection 319429 319430 self deprecated: 'Use ''beginsWith:'' instead.'. 319431 ^ self beginsWith: aSequenceableCollection.! ! 319432 319433!SequenceableCollection methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 08:09'! 319434upTo: anObject 319435 319436 self deprecated: 'Use ''copyUpTo:'' instead.'. 319437 ^ self copyUpTo: anObject! ! 319438 319439 319440!SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 8/6/2002 15:03'! 319441allButFirstDo: block 319442 319443 2 to: self size do: 319444 [:index | block value: (self at: index)]! ! 319445 319446!SequenceableCollection methodsFor: 'enumerating' stamp: 'ajh 8/6/2002 15:01'! 319447allButLastDo: block 319448 319449 1 to: self size - 1 do: 319450 [:index | block value: (self at: index)]! ! 319451 319452!SequenceableCollection methodsFor: 'enumerating' stamp: 'tk 7/30/97 12:41'! 319453asDigitsToPower: anInteger do: aBlock 319454 "Repeatedly value aBlock with a single Array. Adjust the collection 319455 so that aBlock is presented all (self size raisedTo: anInteger) possible 319456 combinations of the receiver's elements taken as digits of an anInteger long number." 319457 "(0 to: 1) asDigitsToPower: 4 do: [:each | Transcript cr; show: each printString]" 319458 319459 | aCollection | 319460 aCollection := Array new: anInteger. 319461 self asDigitsAt: 1 in: aCollection do: aBlock! ! 319462 319463!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:44'! 319464collectWithIndex: elementAndIndexBlock 319465 "Use the new version with consistent naming" 319466 ^ self withIndexCollect: elementAndIndexBlock! ! 319467 319468!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:46'! 319469collect: aBlock 319470 "Evaluate aBlock with each of the receiver's elements as the argument. 319471 Collect the resulting values into a collection like the receiver. Answer 319472 the new collection." 319473 319474 | newCollection | 319475 newCollection := self species new: self size. 319476 1 to: self size do: 319477 [:index | 319478 newCollection at: index put: (aBlock value: (self at: index))]. 319479 ^ newCollection! ! 319480 319481!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 6/1/2000 11:47'! 319482collect: aBlock from: firstIndex to: lastIndex 319483 "Refer to the comment in Collection|collect:." 319484 319485 | size result j | 319486 size := lastIndex - firstIndex + 1. 319487 result := self species new: size. 319488 j := firstIndex. 319489 1 to: size do: [:i | result at: i put: (aBlock value: (self at: j)). j := j + 1]. 319490 ^ result! ! 319491 319492!SequenceableCollection methodsFor: 'enumerating' stamp: 'tk 7/30/97 12:52'! 319493combinations: kk atATimeDo: aBlock 319494 "Take the items in the receiver, kk at a time, and evaluate the block for each combination. Hand in an array of elements of self as the block argument. Each combination only occurs once, and order of the elements does not matter. There are (self size take: kk) combinations." 319495 " 'abcde' combinations: 3 atATimeDo: [:each | Transcript cr; show: each printString]" 319496 319497 | aCollection | 319498 aCollection := Array new: kk. 319499 self combinationsAt: 1 in: aCollection after: 0 do: aBlock! ! 319500 319501!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:43'! 319502doWithIndex: elementAndIndexBlock 319503 "Use the new version with consistent naming" 319504 ^ self withIndexDo: elementAndIndexBlock! ! 319505 319506!SequenceableCollection methodsFor: 'enumerating'! 319507do: aBlock 319508 "Refer to the comment in Collection|do:." 319509 1 to: self size do: 319510 [:index | aBlock value: (self at: index)]! ! 319511 319512!SequenceableCollection methodsFor: 'enumerating' stamp: 'ab 9/17/2002 01:02'! 319513do: aBlock displayingProgress: aString 319514 aString 319515 displayProgressAt: Sensor cursorPoint 319516 from: 0 to: self size 319517 during: 319518 [:bar | 319519 self withIndexDo: 319520 [:each :i | 319521 bar value: i. 319522 aBlock value: each]]! ! 319523 319524!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:56'! 319525do: elementBlock separatedBy: separatorBlock 319526 "Evaluate the elementBlock for all elements in the receiver, 319527 and evaluate the separatorBlock between." 319528 319529 1 to: self size do: 319530 [:index | 319531 index = 1 ifFalse: [separatorBlock value]. 319532 elementBlock value: (self at: index)]! ! 319533 319534!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 5/1/1999 05:01'! 319535do: aBlock without: anItem 319536 "Enumerate all elements in the receiver. 319537 Execute aBlock for those elements that are not equal to the given item" 319538 "Refer to the comment in Collection|do:." 319539 1 to: self size do: 319540 [:index | anItem = (self at: index) ifFalse:[aBlock value: (self at: index)]]! ! 319541 319542!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:54'! 319543findBinaryIndex: aBlock 319544 "Search for an element in the receiver using binary search. 319545 The argument aBlock is a one-element block returning 319546 0 - if the element is the one searched for 319547 <0 - if the search should continue in the first half 319548 >0 - if the search should continue in the second half 319549 If no matching element is found, raise an error. 319550 Examples: 319551 #(1 3 5 7 11 15 23) findBinaryIndex:[:arg| 11 - arg] 319552 " 319553 ^self findBinaryIndex: aBlock ifNone: [self errorNotFound: aBlock]! ! 319554 319555!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:54'! 319556findBinaryIndex: aBlock ifNone: exceptionBlock 319557 "Search for an element in the receiver using binary search. 319558 The argument aBlock is a one-element block returning 319559 0 - if the element is the one searched for 319560 <0 - if the search should continue in the first half 319561 >0 - if the search should continue in the second half 319562 If no matching element is found, evaluate exceptionBlock." 319563 | index low high test | 319564 low := 1. 319565 high := self size. 319566 [index := high + low // 2. 319567 low > high] whileFalse:[ 319568 test := aBlock value: (self at: index). 319569 test = 0 319570 ifTrue:[^index] 319571 ifFalse:[test > 0 319572 ifTrue: [low := index + 1] 319573 ifFalse: [high := index - 1]]]. 319574 ^exceptionBlock value! ! 319575 319576!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:53'! 319577findBinary: aBlock 319578 "Search for an element in the receiver using binary search. 319579 The argument aBlock is a one-element block returning 319580 0 - if the element is the one searched for 319581 <0 - if the search should continue in the first half 319582 >0 - if the search should continue in the second half 319583 If no matching element is found, raise an error. 319584 Examples: 319585 #(1 3 5 7 11 15 23) findBinary:[:arg| 11 - arg] 319586 " 319587 ^self findBinary: aBlock ifNone: [self errorNotFound: aBlock]! ! 319588 319589!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:52'! 319590findBinary: aBlock ifNone: exceptionBlock 319591 "Search for an element in the receiver using binary search. 319592 The argument aBlock is a one-element block returning 319593 0 - if the element is the one searched for 319594 <0 - if the search should continue in the first half 319595 >0 - if the search should continue in the second half 319596 If no matching element is found, evaluate exceptionBlock." 319597 | index low high test item | 319598 low := 1. 319599 high := self size. 319600 [index := high + low // 2. 319601 low > high] whileFalse:[ 319602 test := aBlock value: (item := self at: index). 319603 test = 0 319604 ifTrue:[^item] 319605 ifFalse:[test > 0 319606 ifTrue: [low := index + 1] 319607 ifFalse: [high := index - 1]]]. 319608 ^exceptionBlock value! ! 319609 319610!SequenceableCollection methodsFor: 'enumerating'! 319611findFirst: aBlock 319612 "Return the index of my first element for which aBlock evaluates as true." 319613 319614 | index | 319615 index := 0. 319616 [(index := index + 1) <= self size] whileTrue: 319617 [(aBlock value: (self at: index)) ifTrue: [^index]]. 319618 ^ 0! ! 319619 319620!SequenceableCollection methodsFor: 'enumerating'! 319621findLast: aBlock 319622 "Return the index of my last element for which aBlock evaluates as true." 319623 319624 | index | 319625 index := self size + 1. 319626 [(index := index - 1) >= 1] whileTrue: 319627 [(aBlock value: (self at: index)) ifTrue: [^index]]. 319628 ^ 0! ! 319629 319630!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 18:11'! 319631from: start to: stop do: aBlock 319632 "Evaluate aBlock for all elements between start and stop (inclusive)." 319633 319634 start to: stop do: [:index | aBlock value: (self at: index)]! ! 319635 319636!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 12/30/2003 15:39'! 319637groupsOf: n atATimeCollect: aBlock 319638 "Evaluate aBlock with my elements taken n at a time. Ignore any 319639 leftovers at the end. 319640 Allows use of a flattened 319641 array for things that naturally group into groups of n. 319642 If aBlock has a single argument, pass it an array of n items, 319643 otherwise, pass the items as separate arguments. 319644 See also pairsDo:" 319645 | passArray args | 319646 passArray := aBlock numArgs = 1. 319647 ^(n 319648 to: self size 319649 by: n) 319650 collect: [:index | 319651 args := (self copyFrom: index - n + 1 to: index) asArray. 319652 passArray 319653 ifTrue: [aBlock value: args] 319654 ifFalse: [aBlock valueWithArguments: args]]! ! 319655 319656!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 12/30/2003 15:37'! 319657groupsOf: n atATimeDo: aBlock 319658 "Evaluate aBlock with my elements taken n at a time. Ignore any leftovers at the end. 319659 Allows use of a flattened 319660 array for things that naturally group into groups of n. 319661 If aBlock has a single argument, pass it an array of n items, 319662 otherwise, pass the items as separate arguments. 319663 See also pairsDo:" 319664 | passArray args | 319665 passArray := (aBlock numArgs = 1). 319666 n 319667 to: self size 319668 by: n 319669 do: [:index | 319670 args := (self copyFrom: index - n + 1 to: index) asArray. 319671 passArray ifTrue: [ aBlock value: args ] 319672 ifFalse: [ aBlock valueWithArguments: args ]].! ! 319673 319674!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 18:13'! 319675keysAndValuesDo: aBlock 319676 "Enumerate the receiver with all the keys (aka indices) and values." 319677 319678 1 to: self size do: [:index | aBlock value: index value: (self at: index)]! ! 319679 319680!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 8/23/2003 10:42'! 319681nextToLast 319682 ^self at: self size - 1! ! 319683 319684!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 7/17/2003 17:55'! 319685overlappingPairsCollect: aBlock 319686 "Answer the result of evaluating aBlock with all of the overlapping pairs of my elements." 319687 | retval | 319688 retval := self species new: self size - 1. 319689 1 to: self size - 1 319690 do: [:i | retval at: i put: (aBlock value: (self at: i) value: (self at: i + 1)) ]. 319691 ^retval! ! 319692 319693!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 7/17/2003 17:55'! 319694overlappingPairsDo: aBlock 319695 "Emit overlapping pairs of my elements into aBlock" 319696 319697 1 to: self size - 1 319698 do: [:i | aBlock value: (self at: i) value: (self at: i + 1)]! ! 319699 319700!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 7/17/2003 17:54'! 319701overlappingPairsWithIndexDo: aBlock 319702 "Emit overlapping pairs of my elements into aBlock, along with an index." 319703 319704 1 to: self size - 1 319705 do: [:i | aBlock value: (self at: i) value: (self at: i + 1) value: i ]! ! 319706 319707!SequenceableCollection methodsFor: 'enumerating' stamp: 'nk 3/30/2002 12:45'! 319708paddedWith: otherCollection do: twoArgBlock 319709 "Evaluate twoArgBlock with corresponding elements from this collection and otherCollection. 319710 Missing elements from either will be passed as nil." 319711 1 to: (self size max: otherCollection size) do: 319712 [:index | twoArgBlock value: (self at: index ifAbsent: []) 319713 value: (otherCollection at: index ifAbsent: [])]! ! 319714 319715!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 11/12/1998 15:01'! 319716pairsCollect: aBlock 319717 "Evaluate aBlock with my elements taken two at a time, and return an Array with the results" 319718 319719 ^ (1 to: self size // 2) collect: 319720 [:index | aBlock value: (self at: 2 * index - 1) value: (self at: 2 * index)] 319721" 319722#(1 'fred' 2 'charlie' 3 'elmer') pairsCollect: 319723 [:a :b | b, ' is number ', a printString] 319724"! ! 319725 319726!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 11/12/1998 15:01'! 319727pairsDo: aBlock 319728 "Evaluate aBlock with my elements taken two at a time. If there's an odd number of items, ignore the last one. Allows use of a flattened array for things that naturally group into pairs. See also pairsCollect:" 319729 319730 1 to: self size // 2 do: 319731 [:index | aBlock value: (self at: 2 * index - 1) value: (self at: 2 * index)] 319732" 319733#(1 'fred' 2 'charlie' 3 'elmer') pairsDo: 319734 [:a :b | Transcript cr; show: b, ' is number ', a printString] 319735"! ! 319736 319737!SequenceableCollection methodsFor: 'enumerating' stamp: 'ward 7/28/97 09:41'! 319738permutationsDo: aBlock 319739 "Repeatly value aBlock with a single copy of the receiver. Reorder the copy 319740 so that aBlock is presented all (self size factorial) possible permutations." 319741 "(1 to: 4) permutationsDo: [:each | Transcript cr; show: each printString]" 319742 319743 self shallowCopy permutationsStartingAt: 1 do: aBlock! ! 319744 319745!SequenceableCollection methodsFor: 'enumerating' stamp: 'tk 12/27/2000 09:53'! 319746polynomialEval: thisX 319747 | sum valToPower | 319748 "Treat myself as the coeficients of a polynomial in X. Evaluate it with thisX. First element is the constant and last is the coeficient for the highest power." 319749 " #(1 2 3) polynomialEval: 2 " "is 3*X^2 + 2*X + 1 with X = 2" 319750 319751 sum := self first. 319752 valToPower := thisX. 319753 2 to: self size do: [:ind | 319754 sum := sum + ((self at: ind) * valToPower). 319755 valToPower := valToPower * thisX]. 319756 ^ sum! ! 319757 319758!SequenceableCollection methodsFor: 'enumerating'! 319759reverseDo: aBlock 319760 "Evaluate aBlock with each of the receiver's elements as the argument, 319761 starting with the last element and taking each in sequence up to the 319762 first. For SequenceableCollections, this is the reverse of the enumeration 319763 for do:." 319764 319765 self size to: 1 by: -1 do: [:index | aBlock value: (self at: index)]! ! 319766 319767!SequenceableCollection methodsFor: 'enumerating'! 319768reverseWith: aSequenceableCollection do: aBlock 319769 "Evaluate aBlock with each of the receiver's elements, in reverse order, 319770 along with the 319771 corresponding element, also in reverse order, from 319772 aSequencableCollection. " 319773 319774 self size ~= aSequenceableCollection size ifTrue: [^ self errorNoMatch]. 319775 self size 319776 to: 1 319777 by: -1 319778 do: [:index | aBlock value: (self at: index) 319779 value: (aSequenceableCollection at: index)]! ! 319780 319781!SequenceableCollection methodsFor: 'enumerating' stamp: 'PeterHugossonMiller 9/3/2009 11:20'! 319782select: aBlock 319783 "Refer to the comment in Collection|select:." 319784 | aStream | 319785 aStream := (self species new: self size) writeStream. 319786 1 to: self size do: 319787 [:index | 319788 (aBlock value: (self at: index)) 319789 ifTrue: [aStream nextPut: (self at: index)]]. 319790 ^ aStream contents! ! 319791 319792!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 5/17/1998 13:34'! 319793withIndexCollect: elementAndIndexBlock 319794 "Just like with:collect: except that the iteration index supplies the second argument to the block." 319795 | result | 319796 result := self species new: self size. 319797 1 to: self size do: 319798 [:index | result at: index put: 319799 (elementAndIndexBlock 319800 value: (self at: index) 319801 value: index)]. 319802 ^ result! ! 319803 319804!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:35'! 319805withIndexDo: elementAndIndexBlock 319806 "Just like with:do: except that the iteration index supplies the second argument to the block." 319807 1 to: self size do: 319808 [:index | 319809 elementAndIndexBlock 319810 value: (self at: index) 319811 value: index]! ! 319812 319813!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 8/31/1999 13:13'! 319814with: otherCollection collect: twoArgBlock 319815 "Collect and return the result of evaluating twoArgBlock with corresponding elements from this collection and otherCollection." 319816 | result | 319817 otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size']. 319818 result := self species new: self size. 319819 1 to: self size do: 319820 [:index | result at: index put: 319821 (twoArgBlock 319822 value: (self at: index) 319823 value: (otherCollection at: index))]. 319824 ^ result! ! 319825 319826!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 8/3/1999 15:26'! 319827with: otherCollection do: twoArgBlock 319828 "Evaluate twoArgBlock with corresponding elements from this collection and otherCollection." 319829 otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size']. 319830 1 to: self size do: 319831 [:index | 319832 twoArgBlock value: (self at: index) 319833 value: (otherCollection at: index)]! ! 319834 319835 319836!SequenceableCollection methodsFor: 'removing'! 319837remove: oldObject ifAbsent: anExceptionBlock 319838 "SequencableCollections cannot implement removing." 319839 319840 self shouldNotImplement! ! 319841 319842 319843!SequenceableCollection methodsFor: 'testing' stamp: 'bp 2/23/2004 21:47'! 319844beginsWith: aSequenceableCollection 319845 319846 (aSequenceableCollection isEmpty or: [self size < aSequenceableCollection size]) ifTrue: [^false]. 319847 aSequenceableCollection withIndexDo: [:each :index | (self at: index) ~= each ifTrue: [^false]]. 319848 ^true! ! 319849 319850!SequenceableCollection methodsFor: 'testing' stamp: 'bp 2/23/2004 21:48'! 319851endsWith: aSequenceableCollection 319852 319853 | start | 319854 (aSequenceableCollection isEmpty or: [self size < aSequenceableCollection size]) ifTrue: [^false]. 319855 start := self size - aSequenceableCollection size. 319856 aSequenceableCollection withIndexDo: [:each :index | (self at: start + index) ~= each ifTrue: [^false]]. 319857 ^true! ! 319858 319859!SequenceableCollection methodsFor: 'testing' stamp: 'sma 5/12/2000 14:08'! 319860includes: anObject 319861 "Answer whether anObject is one of the receiver's elements." 319862 319863 ^ (self indexOf: anObject) ~= 0! ! 319864 319865 319866!SequenceableCollection methodsFor: 'private' stamp: 'tk 7/30/97 12:42'! 319867asDigitsAt: anInteger in: aCollection do: aBlock 319868 "(0 to: 1) asDigitsToPower: 4 do: [:each | Transcript cr; show: each printString]" 319869 319870 self do: 319871 [:each | 319872 aCollection at: anInteger put: each. 319873 anInteger = aCollection size 319874 ifTrue: [aBlock value: aCollection] 319875 ifFalse: [self asDigitsAt: anInteger + 1 in: aCollection do: aBlock]].! ! 319876 319877!SequenceableCollection methodsFor: 'private' stamp: 'sma 5/12/2000 13:57'! 319878checkedAt: index 319879 index > self size ifTrue: [self error: 'not enough elements']. 319880 ^ self at: index! ! 319881 319882!SequenceableCollection methodsFor: 'private' stamp: 'tk 7/30/97 12:42'! 319883combinationsAt: jj in: aCollection after: nn do: aBlock 319884 "Choose k of N items and put in aCollection. jj-1 already chosen. Indexes of items are in numerical order, to avoid the same combo being used twice. In this slot, we are allowed to use items in self indexed by nn+1 to self size. nn is the index used for position jj-1." 319885 "(1 to: 6) combinationsSize: 3 do: [:each | Transcript cr; show: each printString]" 319886 319887nn+1 to: self size do: [:index | 319888 aCollection at: jj put: (self at: index). 319889 jj = aCollection size 319890 ifTrue: [aBlock value: aCollection] 319891 ifFalse: [self combinationsAt: jj + 1 in: aCollection after: index do: aBlock]].! ! 319892 319893!SequenceableCollection methodsFor: 'private' stamp: 'yo 9/2/2002 18:22'! 319894copyReplaceAll: oldSubstring with: newSubstring asTokens: ifTokens 319895 "Answer a copy of the receiver in which all occurrences of 319896 oldSubstring have been replaced by newSubstring. 319897 ifTokens (valid for Strings only) specifies that the characters 319898 surrounding the recplacement must not be alphanumeric. 319899 Bruce Simth, must be incremented by 1 and not 319900 newSubstring if ifTokens is true. See example below. " 319901 319902 | aString startSearch currentIndex endIndex | 319903 (ifTokens and: [(self isString) not]) 319904 ifTrue: [(self isKindOf: Text) ifFalse: [ 319905 self error: 'Token replacement only valid for Strings']]. 319906 aString := self. 319907 startSearch := 1. 319908 [(currentIndex := aString indexOfSubCollection: oldSubstring startingAt: startSearch) 319909 > 0] 319910 whileTrue: 319911 [endIndex := currentIndex + oldSubstring size - 1. 319912 (ifTokens not 319913 or: [(currentIndex = 1 319914 or: [(aString at: currentIndex-1) isAlphaNumeric not]) 319915 and: [endIndex = aString size 319916 or: [(aString at: endIndex+1) isAlphaNumeric not]]]) 319917 ifTrue: [aString := aString 319918 copyReplaceFrom: currentIndex 319919 to: endIndex 319920 with: newSubstring. 319921 startSearch := currentIndex + newSubstring size] 319922 ifFalse: [ 319923 ifTokens 319924 ifTrue: [startSearch := currentIndex + 1] 319925 ifFalse: [startSearch := currentIndex + newSubstring size]]]. 319926 ^ aString 319927 319928"Test case: 319929 'test te string' copyReplaceAll: 'te' with: 'longone' asTokens: true " 319930! ! 319931 319932!SequenceableCollection methodsFor: 'private' stamp: 'sma 5/12/2000 18:06'! 319933errorFirstObject: anObject 319934 self error: 'specified object is first object'! ! 319935 319936!SequenceableCollection methodsFor: 'private' stamp: 'sma 5/12/2000 18:03'! 319937errorLastObject: anObject 319938 self error: 'specified object is last object'! ! 319939 319940!SequenceableCollection methodsFor: 'private'! 319941errorOutOfBounds 319942 319943 self error: 'indices are out of bounds'! ! 319944 319945!SequenceableCollection methodsFor: 'private' stamp: 'ward 7/28/97 09:38'! 319946permutationsStartingAt: anInteger do: aBlock 319947 "#(1 2 3 4) permutationsDo: [:each | Transcript cr; show: each printString]" 319948 319949 anInteger > self size ifTrue: [^self]. 319950 anInteger = self size ifTrue: [^aBlock value: self]. 319951 anInteger to: self size do: 319952 [:i | self swap: anInteger with: i. 319953 self permutationsStartingAt: anInteger + 1 do: aBlock. 319954 self swap: anInteger with: i]! ! 319955 319956"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 319957 319958SequenceableCollection class 319959 instanceVariableNames: ''! 319960 319961!SequenceableCollection class methodsFor: 'stream creation' stamp: 'PeterHugossonMiller 9/3/2009 11:20'! 319962streamContents: blockWithArg 319963 | stream | 319964 stream := (self new: 100) writeStream. 319965 blockWithArg value: stream. 319966 ^stream contents! ! 319967 319968!SequenceableCollection class methodsFor: 'stream creation' stamp: 'di 6/20/97 09:07'! 319969streamContents: blockWithArg limitedTo: sizeLimit 319970 | stream | 319971 stream := LimitedWriteStream on: (self new: (100 min: sizeLimit)). 319972 stream setLimit: sizeLimit limitBlock: [^ stream contents]. 319973 blockWithArg value: stream. 319974 ^ stream contents 319975" 319976String streamContents: [:s | 1000 timesRepeat: [s nextPutAll: 'Junk']] limitedTo: 25 319977 'JunkJunkJunkJunkJunkJunkJ' 319978"! ! 319979Object subclass: #SerialPort 319980 instanceVariableNames: 'port baudRate stopBitsType parityType dataBits outputFlowControlType inputFlowControlType xOnByte xOffByte' 319981 classVariableNames: '' 319982 poolDictionaries: '' 319983 category: 'System-Serial Port'! 319984!SerialPort commentStamp: '<historical>' prior: 0! 319985This class supports a simple interface to the serial ports of the underlying platform, if it supports serial ports. The mapping of port numbers to hardware ports is platform specific, but typically follows platform ordering conventions. For example, on the Macintosh, port 0 is the modem port and port 1 is the printer port, since in the programmers documentation these ports are referred to as ports A and B. 319986! 319987 319988 319989!SerialPort methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:21'! 319990initialize 319991 "Default port settings." 319992 319993 super initialize. 319994 port := nil. "set when opened" 319995 baudRate := 9600. "9600 baud" 319996 stopBitsType := 1. "one stop bit" 319997 parityType := 0. "no parity" 319998 dataBits := 8. "8 bits" 319999 outputFlowControlType := 0. "none" 320000 inputFlowControlType := 0. "none" 320001 xOnByte := 19. "ctrl-S" 320002 xOffByte := 24. "ctrl-X" 320003! ! 320004 320005 320006!SerialPort methodsFor: 'input/output' stamp: 'yo 2/2/2001 15:13'! 320007nextPutAll: aStringOrByteArray 320008 "Send the given bytes out this serial port. The port must be open." 320009 320010 ^ self primWritePort: port 320011 from: aStringOrByteArray 320012 startingAt: 1 320013 count: aStringOrByteArray size. 320014! ! 320015 320016!SerialPort methodsFor: 'input/output' stamp: 'jm 5/18/1998 15:44'! 320017readByteArray 320018 "Answer a ByteArray read from this serial port. Answer an empty ByteArray if no data is available. The port must be open." 320019 320020 | buf count | 320021 buf := ByteArray new: 1000. 320022 count := self primReadPort: port into: buf startingAt: 1 count: buf size. 320023 ^ buf copyFrom: 1 to: count 320024! ! 320025 320026!SerialPort methodsFor: 'input/output' stamp: 'jm 5/18/1998 15:46'! 320027readInto: aStringOrByteArray startingAt: index 320028 "Read data into the given String or ByteArray object starting at the given index, and answer the number of bytes read. Does not go past the end of the given String or ByteArray." 320029 320030 ^ self primReadPort: port 320031 into: aStringOrByteArray 320032 startingAt: index 320033 count: (aStringOrByteArray size - index) + 1. 320034! ! 320035 320036!SerialPort methodsFor: 'input/output' stamp: 'jm 5/18/1998 15:43'! 320037readString 320038 "Answer a String read from this serial port. Answer the empty String if no data is available. The port must be open." 320039 320040 | buf count | 320041 buf := String new: 1000. 320042 count := self primReadPort: port into: buf startingAt: 1 count: buf size. 320043 ^ buf copyFrom: 1 to: count 320044! ! 320045 320046 320047!SerialPort methodsFor: 'nil' stamp: 'jm 5/18/1998 15:37'! 320048openPort: portNumber 320049 "Open the given serial port, using the settings specified by my instance variables." 320050 320051 self close. 320052 self primClosePort: portNumber. 320053 self primOpenPort: portNumber 320054 baudRate: baudRate 320055 stopBitsType: stopBitsType 320056 parityType: parityType 320057 dataBits: dataBits 320058 inFlowControlType: inputFlowControlType 320059 outFlowControlType: outputFlowControlType 320060 xOnByte: xOnByte 320061 xOffByte: xOffByte. 320062 port := portNumber. 320063! ! 320064 320065 320066!SerialPort methodsFor: 'open/close' stamp: 'jm 5/18/1998 15:40'! 320067close 320068 "Close the serial port. Do nothing if the port is not open." 320069 320070 port ifNotNil: [self primClosePort: port]. 320071 port := nil. 320072! ! 320073 320074 320075!SerialPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 320076primClosePort: portNumber 320077 320078 <primitive: 'primitiveSerialPortClose' module: 'SerialPlugin'> 320079 ^ nil "(DNS)" 320080 "self primitiveFailed." 320081! ! 320082 320083!SerialPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 320084primOpenPort: portNumber baudRate: baud stopBitsType: stop 320085 parityType: parity dataBits: numDataBits 320086 inFlowControlType: inFlowCtrl outFlowControlType: outFlowCtrl 320087 xOnByte: xOn xOffByte: xOff 320088 320089 <primitive: 'primitiveSerialPortOpen' module: 'SerialPlugin'> 320090 ^ nil "(DNS)" 320091! ! 320092 320093!SerialPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 320094primReadPort: portNumber into: byteArray startingAt: startIndex count: count 320095 320096 <primitive: 'primitiveSerialPortRead' module: 'SerialPlugin'> 320097 self primitiveFailed. 320098! ! 320099 320100!SerialPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 320101primWritePort: portNumber from: byteArray startingAt: startIndex count: count 320102 320103 <primitive: 'primitiveSerialPortWrite' module: 'SerialPlugin'> 320104 self primitiveFailed. 320105! ! 320106 320107 320108!SerialPort methodsFor: 'printing' stamp: 'jm 5/1/1998 18:02'! 320109printOn: aStream 320110 320111 aStream 320112 nextPutAll: 'SerialPort('; 320113 nextPutAll: 320114 (port ifNil: ['closed'] ifNotNil: ['#', port printString]); 320115 nextPutAll: ', '; 320116 print: baudRate; nextPutAll: ' baud, '; 320117 print: dataBits; nextPutAll: ' bits, '; 320118 nextPutAll: (#('1.5' '1' '2') at: stopBitsType + 1); nextPutAll: ' stopbits, '; 320119 nextPutAll: (#('no' 'odd' 'even') at: parityType + 1); nextPutAll: ' parity)'. 320120! ! 320121 320122 320123!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'! 320124baudRate 320125 320126 ^ baudRate 320127! ! 320128 320129!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:29'! 320130baudRate: anInteger 320131 "Set the baud rate for this serial port." 320132 320133 baudRate := anInteger. 320134! ! 320135 320136!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'! 320137dataBits 320138 320139 ^ dataBits 320140! ! 320141 320142!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:29'! 320143dataBits: anInteger 320144 "Set the number of data bits for this serial port to 5, 6, 7, or 8." 320145 320146 dataBits := anInteger. 320147! ! 320148 320149!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:21'! 320150inputFlowControlType 320151 320152 ^ inputFlowControlType 320153! ! 320154 320155!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:38'! 320156inputFlowControlType: anInteger 320157 "Set the type of input flow control, where: 320158 0 - none 320159 1 - XOn/XOff 320160 2 - hardware handshaking" 320161 320162 inputFlowControlType := anInteger. 320163! ! 320164 320165!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'! 320166outputFlowControlType 320167 320168 ^ outputFlowControlType 320169! ! 320170 320171!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:38'! 320172outputFlowControlType: anInteger 320173 "Set the type of output flow control, where: 320174 0 - none 320175 1 - XOn/XOff 320176 2 - hardware handshaking" 320177 320178 outputFlowControlType := anInteger. 320179! ! 320180 320181!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'! 320182parityType 320183 320184 ^ parityType 320185! ! 320186 320187!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:29'! 320188parityType: anInteger 320189 "Set the parity type for this serial port, where: 320190 0 - no parity 320191 1 - odd parity 320192 2 - even parity" 320193 320194 parityType := anInteger. 320195! ! 320196 320197!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'! 320198stopBitsType 320199 320200 ^ stopBitsType 320201! ! 320202 320203!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 18:02'! 320204stopBitsType: anInteger 320205 "Set the stop bits type for this serial port, where: 320206 0 - 1.5 stop bits 320207 1 - one stop bit 320208 2 - two stop bits" 320209 320210 stopBitsType := anInteger. 320211! ! 320212 320213!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:20'! 320214xOffByte 320215 320216 ^ xOffByte 320217! ! 320218 320219!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:28'! 320220xOffByte: anInteger 320221 "Set the value of the XOff byte to be used if XOn/XOff flow control is enabled." 320222 320223 xOffByte := anInteger. 320224! ! 320225 320226!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:20'! 320227xOnByte 320228 320229 ^ xOnByte 320230! ! 320231 320232!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:28'! 320233xOnByte: anInteger 320234 "Set the value of the XOn byte to be used if XOn/XOff flow control is enabled." 320235 320236 xOnByte := anInteger. 320237! ! 320238Object subclass: #ServerDirectory 320239 instanceVariableNames: 'server directory type user passwordHolder group moniker altURL urlObject client loaderUrl keepAlive encodingName' 320240 classVariableNames: 'Servers' 320241 poolDictionaries: '' 320242 category: 'Network-RemoteDirectory'! 320243!ServerDirectory commentStamp: '<historical>' prior: 0! 320244Holds all the information needed to read or write on a directory of an internet server. I am used for FTP and HTTP (and STMP? NNTP?). The password policy is: unless it is a public password (like annomyous), clear all passwords before any snapshot. There is a way to store passwords on the disk. 320245 320246server 'www.disney.com' or '123.34.56.08' or the ServerDirectory above me 320247 (if I am a subdirectory sharing the info in a master directory) 320248directory 'ftp/pubs/' name of my directory within the server or superdirectory. 320249 (for file://, directory is converted to local delimiters.) 320250type #ftp what you can do in this directory 320251user 'Jones45' 320252password an instance of Password. 320253group an Association ('group name' -> an array of ServerDirectorys) 320254 If this first one is down, try the next one. Store on all of them. I am in the list. 320255moniker 'Main Squeak Directory' Description of this directory. 320256altURL When a FTP server holds some web pages, the altURL of those pages is often 320257 different from the FTP directory. Put the altURL here. If the directory is 320258 'public_html/Squeak/', the altURL might be 'www.webPage.com/~kaehler2/ 320259 Squeak/'. 320260urlObject An instance of a subclass of Url. It is very good at parsing complex urls. 320261 Relative references. file:// uses this. Use this in the future instead of 320262 server and directory inst vars. 320263socket nil or an FTPSocket. Only non-nil if the connection is being kept open 320264 for multiple stores or retrievals. 320265loaderUrl a partial url that is ised to invoke squeak in a browser and load a project. 320266 320267A normal call on some command like (aServer getFileNamed: 'foo') does not set 'socket'. Socket being nil tells it to close the connection and destroy the socket after this one transcation. If the caller stores into 'socket', then the same command does NOT close the 320268connection. 320269 Call 'openKeepFTP' or 'openGroup' to store into socket and keep the connection open. It is up to the user to call 'quit' or 'closeGroup' later. 320270 320271DD openKeepFTP. 320272Transcript cr; show: ((DD getFileNamed: '1198misc-tkKG.cs') next: 100). 320273Transcript cr; show: ((DD getFileNamed: '1192multFinder-tkKF.cs') next: 100). 320274DD quit.! 320275 320276 320277!ServerDirectory methodsFor: 'accessing' stamp: 'mir 6/25/2001 12:43'! 320278acceptsUploads: aBoolean 320279 "Do nothing yet"! ! 320280 320281!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/14/1999 21:01'! 320282altUrl 320283 "When a ftp server also has http access, use this to store the http url" 320284 ^ altURL! ! 320285 320286!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/14/1999 20:56'! 320287altUrl: aString 320288 altURL := aString! ! 320289 320290!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/18/1998 23:24'! 320291bareDirectory 320292 320293 ^ directory first == $/ 320294 ifTrue: [directory copyFrom: 2 to: directory size] 320295 ifFalse: [directory]! ! 320296 320297!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/19/1998 18:54'! 320298copy 320299 320300 | new | 320301 new := self clone. 320302 new urlObject: urlObject copy. 320303 ^ new! ! 320304 320305!ServerDirectory methodsFor: 'accessing' stamp: 'yo 8/28/2008 00:29'! 320306dirPathFor: fullName 320307 "Return the directory part the given name." 320308 self 320309 splitName: fullName 320310 to: [:dirPath :localName | ^ dirPath]! ! 320311 320312!ServerDirectory methodsFor: 'accessing' stamp: 'tk 11/24/1998 15:00'! 320313directory 320314 "String of part of url that is the directory. Has slashes as separators" 320315 320316 urlObject ifNotNil: [^ urlObject pathDirString]. 320317 ^ directory! ! 320318 320319!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/3/98 21:36'! 320320directory: anObject 320321 directory := anObject! ! 320322 320323!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 10/17/2000 14:57'! 320324directoryObject 320325 320326 ^self! ! 320327 320328!ServerDirectory methodsFor: 'accessing' stamp: 'mir 6/25/2001 10:45'! 320329downloadUrl 320330 "The url under which files will be accessible." 320331 ^(self altUrl 320332 ifNil: [self realUrl] 320333 ifNotNil: [self altUrl]) , '/'! ! 320334 320335!ServerDirectory methodsFor: 'accessing' stamp: 'KR 2/1/2006 12:46'! 320336encodingName 320337 ^encodingName.! ! 320338 320339!ServerDirectory methodsFor: 'accessing' stamp: 'KR 1/30/2006 22:15'! 320340encodingName: aName 320341 encodingName := aName! ! 320342 320343!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 9/14/2000 13:26'! 320344fullPath: serverAndDirectory 320345 "Parse and save a full path. Convention: if ftp://user@server/dir, then dir is relative to user's directory. dir has no slash at beginning. If ftp://server/dir, then dir is absolute to top of machine, give dir a slash at the beginning." 320346 320347 | start bare sz userAndServer both slash score match best sd | 320348 bare := serverAndDirectory. 320349 sz := serverAndDirectory size. 320350 bare size > 0 ifTrue: [ 320351 start := (bare copyFrom: 1 to: (8 min: sz)) asLowercase. 320352 ((start beginsWith: 'ftp:') or: [start beginsWith: 'nil:']) "fix bad urls" 320353 ifTrue: [type := #ftp. 320354 bare := bare copyFrom: (7 min: sz) to: bare size]. 320355 (start beginsWith: 'http:') 320356 ifTrue: [type := #http. 320357 bare := bare copyFrom: (8 min: sz) to: serverAndDirectory size]. 320358 ((start beginsWith: 'file:') or: [type == #file]) 320359 ifTrue: [type := #file. 320360 urlObject := FileUrl absoluteFromText: serverAndDirectory. 320361 ^ self]]. 320362 userAndServer := bare copyUpTo: self pathNameDelimiter. 320363 both := userAndServer findTokens: '@'. 320364 slash := both size. "absolute = 1, relative = 2" 320365 server := both last. 320366 both size > 1 ifTrue: [user := both at: 1]. 320367 bare size > (userAndServer size + 1) 320368 ifTrue: [directory := bare copyFrom: userAndServer size + slash to: bare size] 320369 ifFalse: [directory := '']. 320370 320371 "If this server is already known, copy in its userName and password" 320372 type == #ftp ifFalse: [^ self]. 320373 score := -1. 320374 ServerDirectory serverNames do: [:name | 320375 sd := ServerDirectory serverNamed: name. 320376 server = sd server ifTrue: [ 320377 match := directory asLowercase charactersExactlyMatching: sd directory asLowercase. 320378 match > score ifTrue: [score := match. best := sd]]]. 320379 best ifNil: [ 320380 self fromUser 320381 ] ifNotNil: [ 320382 user := best user. 320383 altURL := best altUrl. 320384 loaderUrl := best loaderUrl. 320385 self password: best password 320386 ]. 320387! ! 320388 320389!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 6/23/2000 09:40'! 320390isTypeFTP 320391 320392 ^self typeWithDefault == #ftp! ! 320393 320394!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 6/23/2000 09:41'! 320395isTypeFile 320396 320397 ^self typeWithDefault == #file! ! 320398 320399!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 6/23/2000 09:46'! 320400isTypeHTTP 320401 320402 ^self typeWithDefault == #http! ! 320403 320404!ServerDirectory methodsFor: 'accessing' stamp: 'mir 12/8/2003 14:18'! 320405keepAlive: aBoolean 320406 keepAlive := aBoolean! ! 320407 320408!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 9/14/2000 13:22'! 320409loaderUrl 320410 320411 ^loaderUrl! ! 320412 320413!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 9/14/2000 13:24'! 320414loaderUrl: aString 320415 320416 loaderUrl := aString! ! 320417 320418!ServerDirectory methodsFor: 'accessing' stamp: 'fbs 2/2/2005 13:24'! 320419moniker 320420 "a plain language name for this directory" 320421 320422 moniker ifNotNil: [^ moniker]. 320423 directory ifNotNil: [^ self server]. 320424 urlObject ifNotNil: [^ urlObject asString]. 320425 ^ ''! ! 320426 320427!ServerDirectory methodsFor: 'accessing' stamp: 'tk 5/20/1998 12:26'! 320428moniker: nickName 320429 "a plain language name for this directory" 320430 320431 moniker := nickName! ! 320432 320433!ServerDirectory methodsFor: 'accessing' stamp: 'tk 2/14/1999 20:44'! 320434password 320435 320436 passwordHolder ifNil: [passwordHolder := Password new]. 320437 ^ passwordHolder passwordFor: self "may ask the user"! ! 320438 320439!ServerDirectory methodsFor: 'accessing' stamp: 'ar 4/10/2005 18:52'! 320440password: pp 320441 320442 passwordHolder := Password new. 320443 pp isString 320444 ifTrue: [passwordHolder cache: pp. ^ self]. 320445 pp isInteger 320446 ifTrue: [passwordHolder sequence: pp] 320447 ifFalse: [passwordHolder := pp].! ! 320448 320449!ServerDirectory methodsFor: 'accessing' stamp: 'mir 6/29/2001 01:04'! 320450passwordSequence 320451 320452 ^passwordHolder 320453 ifNotNil: [passwordHolder sequence]! ! 320454 320455!ServerDirectory methodsFor: 'accessing' stamp: 'mir 6/29/2001 01:16'! 320456passwordSequence: aNumber 320457 320458 passwordHolder ifNil: [passwordHolder := Password new]. 320459 passwordHolder sequence: aNumber! ! 320460 320461!ServerDirectory methodsFor: 'accessing' stamp: 'tk 5/23/1998 09:41'! 320462printOn: aStrm 320463 aStrm nextPutAll: self class name; nextPut: $<. 320464 aStrm nextPutAll: self moniker. 320465 aStrm nextPut: $>. 320466! ! 320467 320468!ServerDirectory methodsFor: 'accessing' stamp: 'fbs 2/2/2005 13:24'! 320469realUrl 320470 "a fully expanded version of the url we represent. Prefix the path with http: or ftp: or file:" 320471 320472 self isTypeFile ifTrue: [ 320473 self fileNameRelativeTo: self. 320474 ^ urlObject asString 320475 ]. 320476 ^ self typeWithDefault asString, '://', self pathName 320477 ! ! 320478 320479!ServerDirectory methodsFor: 'accessing' stamp: 'tk 11/24/1998 18:18'! 320480server 320481 ^ server! ! 320482 320483!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/3/98 21:36'! 320484server: anObject 320485 server := anObject! ! 320486 320487!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/18/1998 23:22'! 320488slashDirectory 320489 320490 ^ directory first == $/ 320491 ifTrue: [directory] 320492 ifFalse: ['/', directory]! ! 320493 320494!ServerDirectory methodsFor: 'accessing' stamp: 'tk 2/14/1999 21:44'! 320495type: aSymbol 320496 type := aSymbol! ! 320497 320498!ServerDirectory methodsFor: 'accessing' stamp: 'mir 6/25/2001 17:16'! 320499typeForPrefs 320500 320501 ^self typeWithDefault! ! 320502 320503!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 6/23/2000 09:30'! 320504typeWithDefault 320505 320506 ^ type ifNil: [type := #ftp]! ! 320507 320508!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/25/1999 15:12'! 320509url 320510 "This was mis-named at the beginning. Eventually convert over to altUrl and use this for the real url." 320511 ^ self realUrl! ! 320512 320513!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/5/1998 17:20'! 320514url: aString 320515 altURL := aString! ! 320516 320517!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/6/1998 00:44'! 320518urlObject 320519 ^ urlObject! ! 320520 320521!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/8/1998 11:56'! 320522urlObject: aUrl 320523 320524 urlObject := aUrl! ! 320525 320526!ServerDirectory methodsFor: 'accessing' stamp: 'tk 11/24/1998 22:16'! 320527user 320528 ^ user! ! 320529 320530!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/3/98 21:36'! 320531user: anObject 320532 user := anObject! ! 320533 320534 320535!ServerDirectory methodsFor: 'dis/connect' stamp: 'rbb 2/18/2005 14:41'! 320536openFTPClient 320537 320538 | loginSuccessful what | 320539 client 320540 ifNotNil: [client isConnected 320541 ifTrue: [^client] 320542 ifFalse: [client := nil]]. 320543 client := FTPClient openOnHostNamed: server. 320544 loginSuccessful := false. 320545 [loginSuccessful] 320546 whileFalse: [ 320547 [loginSuccessful := true. 320548 client loginUser: self user password: self password] 320549 on: LoginFailedException 320550 do: [:ex | 320551 passwordHolder := nil. 320552 what := UIManager default 320553 chooseFrom: #('enter password' 'give up') 320554 title: 'Would you like to try another password?'. 320555 what = 1 ifFalse: [self error: 'Login failed.'. ^nil]. 320556 loginSuccessful := false]]. 320557 client changeDirectoryTo: directory. 320558 ^client! ! 320559 320560!ServerDirectory methodsFor: 'dis/connect' stamp: 'mir 12/8/2003 12:53'! 320561quit 320562 "break the connection" 320563 320564 self keepAlive 320565 ifFalse: [self quitClient]! ! 320566 320567!ServerDirectory methodsFor: 'dis/connect' stamp: 'mir 12/8/2003 12:53'! 320568quitClient 320569 "break the connection" 320570 320571 client ifNotNil: [client quit]. 320572 client := nil! ! 320573 320574 320575!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:08'! 320576asServerFileNamed: aName 320577 320578 | rFile | 320579 rFile := self as: ServerFile. 320580 (aName includes: self pathNameDelimiter) 320581 ifTrue: [rFile fullPath: aName] 320582 "sets server, directory(path), fileName. If relative, merge with self." 320583 ifFalse: [rFile fileName: aName]. "JUST a single NAME, already have the rest" 320584 "Mac files that include / in name, must encode it as %2F " 320585 ^rFile 320586! ! 320587 320588!ServerDirectory methodsFor: 'file directory' stamp: 'tpr 4/28/2004 17:32'! 320589assureExistence 320590 "Make sure the current directory exists. If necessary, create all parts inbetween" 320591 320592 self exists ifFalse: [ 320593 self isRoot ifFalse: [ 320594 self containingDirectory assureExistenceOfPath: self localName]]! ! 320595 320596!ServerDirectory methodsFor: 'file directory' stamp: 'tpr 4/28/2004 17:31'! 320597assureExistenceOfPath: localPath 320598 "Make sure the local directory exists. If necessary, create all parts inbetween" 320599 320600 localPath = (String with: self pathNameDelimiter) ifTrue: [^self]. 320601 self assureExistence. 320602 (self localPathExists: localPath) ifFalse: [ 320603 self createDirectory: localPath].! ! 320604 320605!ServerDirectory methodsFor: 'file directory' stamp: 'yo 8/28/2008 00:29'! 320606containingDirectory 320607 320608 ^ self copy directory: (self dirPathFor: directory). 320609 320610! ! 320611 320612!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:16'! 320613createDirectory: localName 320614 "Create a new sub directory within the current one" 320615 320616 self isTypeFile ifTrue: [ 320617 ^FileDirectory createDirectory: localName 320618 ]. 320619 320620 client := self openFTPClient. 320621 [client makeDirectory: localName] 320622 ensure: [self quit]. 320623! ! 320624 320625!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:17'! 320626deleteDirectory: localName 320627 "Delete the sub directory within the current one. Call needs to ask user to confirm." 320628 320629 self isTypeFile ifTrue: [ 320630 ^FileDirectory deleteFileNamed: localName 320631 ]. 320632 "Is this the right command???" 320633 320634 client := self openFTPClient. 320635 [client deleteDirectory: localName] 320636 ensure: [self quit]. 320637! ! 320638 320639!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:17'! 320640deleteFileNamed: fullName 320641 "Detete a remote file. fullName is directory path, and does include name of the server. Or it can just be a fileName." 320642 | file | 320643 file := self asServerFileNamed: fullName. 320644 file isTypeFile ifTrue: [ 320645 ^ (FileDirectory forFileName: (file fileNameRelativeTo: self)) 320646 deleteFileNamed: file fileName 320647 ]. 320648 320649 client := self openFTPClient. 320650 [client deleteFileNamed: fullName] 320651 ensure: [self quit]. 320652! ! 320653 320654!ServerDirectory methodsFor: 'file directory' stamp: 'tak 9/25/2008 15:13'! 320655directoryNamed: localFileName 320656 "Return a copy of me pointing at this directory below me" 320657 | new newPath newAltUrl | 320658 new := self copy. 320659 urlObject ifNotNil: [ 320660 new urlObject path: new urlObject path copy. 320661 new urlObject path removeLast; addLast: localFileName; addLast: ''. 320662 ^ new]. 320663 "sbw. When working from an FTP server, the first time we access 320664 a subdirectory the <directory> variable is empty. In that case we 320665 cannot begin with a leading path delimiter since that leads us to 320666 the wrong place." 320667 newPath := directory isEmpty 320668 ifTrue: [localFileName] 320669 ifFalse: [directory , self pathNameDelimiter asString , localFileName]. 320670 self altUrl ifNotNil: [ 320671 newAltUrl := self altUrl, self pathNameDelimiter asString , localFileName]. 320672 new directory: newPath; altUrl: newAltUrl. 320673 ^ new! ! 320674 320675!ServerDirectory methodsFor: 'file directory' stamp: 'tk 2/22/2000 19:51'! 320676directoryNames 320677 "Return a collection of names for the subdirectories of this directory." 320678 "(ServerDirectory serverNamed: 'UIUCArchive') directoryNames" 320679 320680 ^ (self entries select: [:entry | entry at: 4]) 320681 collect: [:entry | entry first] 320682! ! 320683 320684!ServerDirectory methodsFor: 'file directory' stamp: 'mir 5/13/2003 10:44'! 320685entries 320686 "Return a collection of directory entries for the files and directories in this directory. Each entry is a five-element array: (<name> <creationTime> <modificationTime> <dirFlag> <fileSize>)." 320687 | dir ftpEntries | 320688 "We start with ftp directory entries of the form... 320689d--------- 1 owner group 0 Apr 27 22:01 blasttest 320690---------- 1 owner group 93812 Jul 21 1997 COMMAND.COM 320691 1 2 3 4 5 6 7 8 9 -- token index" 320692 self isTypeFile ifTrue: [ 320693 urlObject isAbsolute ifFalse: [urlObject default]. 320694 ^ (FileDirectory on: urlObject pathForDirectory) entries 320695 ]. 320696 320697 dir := self getDirectory. 320698 (dir respondsTo: #contentsOfEntireFile) ifFalse: [^ #()]. 320699 ftpEntries := dir contentsOfEntireFile findTokens: String crlf. 320700"ftpEntries inspect." 320701 ^ ftpEntries 320702 collect:[:ftpEntry | self class parseFTPEntry: ftpEntry] 320703 thenSelect: [:entry | entry notNil]! ! 320704 320705!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:17'! 320706exists 320707 "It is difficult to tell if a directory exists. This is ugly, but it works for writable directories. http: will fall back on ftp for this" 320708 320709 | probe success | 320710 success := false. 320711 self isTypeFile ifTrue: [ 320712 self entries size > 0 ifTrue: [^ true]. 320713 probe := self newFileNamed: 'withNoName23'. 320714 probe ifNotNil: [ 320715 probe close. 320716 probe directory deleteFileNamed: probe localName]. 320717 ^success := probe notNil]. 320718 [client := self openFTPClient. 320719 [client pwd] 320720 ensure: [self quit]. 320721 success := true] 320722 on: Error 320723 do: [:ex | ]. 320724 ^success! ! 320725 320726!ServerDirectory methodsFor: 'file directory' stamp: 'tk 11/20/1998 12:28'! 320727fileAndDirectoryNames 320728 "FileDirectory default fileAndDirectoryNames" 320729 320730 ^ self entries collect: [:entry | entry first] 320731! ! 320732 320733!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:31'! 320734fileNamed: fullName 320735 "Create a RemoteFileStream for writing. If the file exists, do not complain. fullName is directory path, and does include name of the server. Or it can just be a fileName. Only write the data upon close." 320736 320737 | file remoteStrm | 320738 file := self asServerFileNamed: fullName. 320739 file readWrite. 320740 file isTypeFile ifTrue: [ 320741 ^ FileStream fileNamed: (file fileNameRelativeTo: self) 320742 ]. 320743 320744 remoteStrm := RemoteFileStream on: (String new: 2000). 320745 remoteStrm remoteFile: file. 320746 ^ remoteStrm "no actual writing till close" 320747! ! 320748 320749!ServerDirectory methodsFor: 'file directory' stamp: 'tak 9/25/2008 15:12'! 320750fullNameFor: aFileName 320751 "Convention: 320752 If it is an absolute path, directory stored with a leading slash, and url has no user@. 320753 If relative path, directory stored with no leading slash, and url begins user@. 320754 Should we include ftp:// on the front?" 320755 320756 urlObject ifNotNil: [^ urlObject pathString, aFileName]. 320757 (aFileName includes: self pathNameDelimiter) 320758 ifTrue: [^ aFileName]. 320759 self isTypeHTTP ifTrue: [^ self downloadUrl, aFileName]. 320760 directory isEmpty ifTrue: [^ server, self pathNameDelimiter asString, aFileName]. 320761 ^ (directory first == $/ ifTrue: [''] ifFalse: [user,'@']), 320762 server, self slashDirectory, 320763 self pathNameDelimiter asString, aFileName! ! 320764 320765!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 6/23/2000 09:47'! 320766getOnly: nnn from: fileNameOnServer 320767 | file ff resp | 320768 "Use FTP to just capture the first nnn characters of the file. Break the connection after that. Goes faster for long files. Return the contents, not a stream." 320769 320770 self isTypeFile ifTrue: [ 320771 file := self as: ServerFile. 320772 file fileName: fileNameOnServer. 320773 ff := FileStream oldFileOrNoneNamed: (file fileNameRelativeTo: self). 320774 ^ ff next: nnn]. 320775 self isTypeHTTP ifTrue: [ 320776 resp := HTTPSocket httpGet: (self fullNameFor: fileNameOnServer) 320777 accept: 'application/octet-stream'. 320778 "For now, get the whole file. This branch not used often." 320779 ^ resp truncateTo: nnn]. 320780 320781 ^ self getOnlyBuffer: (String new: nnn) from: fileNameOnServer! ! 320782 320783!ServerDirectory methodsFor: 'file directory' stamp: 'tk 11/20/1998 12:28'! 320784includesKey: localName 320785 "Answer true if this directory includes a file or directory of the given name. Note that the name should be a local file name, in contrast with fileExists:, which takes either local or full-qualified file names." 320786 320787 ^ self fileAndDirectoryNames includes: localName 320788! ! 320789 320790!ServerDirectory methodsFor: 'file directory' stamp: 'bf 9/25/2008 15:11'! 320791localName 320792 320793 directory isEmpty ifTrue: [self error: 'no directory']. 320794 ^ self localNameFor: directory.! ! 320795 320796!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/28/2000 13:46'! 320797localNameFor: fullName 320798 "Return the local part the given name." 320799 320800 self 320801 splitName: fullName 320802 to: [:dirPath :localName | ^ localName] 320803! ! 320804 320805!ServerDirectory methodsFor: 'file directory' stamp: 'mir 9/25/2008 15:11'! 320806localPathExists: localPath 320807 320808 ^ self directoryNames includes: localPath! ! 320809 320810!ServerDirectory methodsFor: 'file directory' stamp: 'mir 8/24/2001 12:01'! 320811matchingEntries: criteria 320812 "Ignore the filter criteria for now" 320813 ^self entries! ! 320814 320815!ServerDirectory methodsFor: 'file directory' stamp: 'rbb 3/1/2005 11:12'! 320816newFileNamed: fullName 320817 "Create a RemoteFileStream. If the file exists, and complain. fullName is directory path, and does include name of the server. Or it can just be a fileName. Only write the data upon close." 320818 320819 | file remoteStrm selection | 320820 320821 file := self asServerFileNamed: fullName. 320822 file readWrite. 320823 file isTypeFile ifTrue: [ 320824 ^ FileStream newFileNamed: (file fileNameRelativeTo: self)]. 320825 file exists 320826 ifTrue: [ 320827 selection := UIManager default 320828 chooseFrom: #('overwrite that file' 'choose another name' 'cancel') 320829 title: (file fullNameFor: file fileName) , ' 320830already exists.'] 320831 ifFalse: [selection := 1]. 320832 320833 selection = 1 ifTrue: 320834 [remoteStrm := RemoteFileStream on: (String new: 2000). 320835 remoteStrm remoteFile: file. 320836 remoteStrm dataIsValid. "empty stream is the real contents!!" 320837 ^ remoteStrm]. "no actual writing till close" 320838 selection = 2 ifTrue: [ 320839 ^ self newFileNamed: 320840 (UIManager default request: 'Enter a new file name' 320841 initialAnswer: file fileName)]. 320842 ^ nil "cancel"! ! 320843 320844!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:10'! 320845oldFileNamed: aName 320846 "If the file exists, answer a read-only RemoteFileStream on it. aName is directory path, and does include name of the server. Or it can just be a fileName. For now, pre-read the file." 320847 320848 | rFile | 320849 320850 rFile := self asServerFileNamed: aName. 320851 rFile readOnly. 320852 rFile isTypeFile ifTrue: [ 320853 ^ FileStream oldFileNamed: (rFile fileNameRelativeTo: self)]. 320854 320855 ^self streamOnBeginningOf: rFile 320856! ! 320857 320858!ServerDirectory methodsFor: 'file directory' stamp: 'di 3/9/2001 01:25'! 320859oldFileOrNoneNamed: fullName 320860 "If the file exists, answer a read-only RemoteFileStream on it. If it doesn't, answer nil. fullName is directory path, and does include name of the server. Or just a simple fileName. Do prefetch the data." 320861 320862 | file | 320863 ^ Cursor wait showWhile: 320864 [file := self asServerFileNamed: fullName. 320865 file readOnly. 320866 "file exists ifFalse: [^ nil]." "on the server" 320867 file isTypeFile 320868 ifTrue: [FileStream oldFileOrNoneNamed: (file fileNameRelativeTo: self)] 320869 ifFalse: [self streamOnBeginningOf: file]]! ! 320870 320871!ServerDirectory methodsFor: 'file directory' stamp: 'tk 9/19/1998 18:59'! 320872on: fullName 320873 "Answer another ServerDirectory on the partial path name. fullName is directory path, and does include the name of the server." 320874 320875 | new | 320876 new := self copy. 320877 new fullPath: fullName. "sets server, directory(path)" 320878 ^ new! ! 320879 320880!ServerDirectory methodsFor: 'file directory' stamp: 'tk 1/14/1999 20:54'! 320881pathName 320882 "Path name as used in reading the file. with slashes for ftp, with local file delimiter (:) for a file: url" 320883 320884 urlObject ifNotNil: [^ urlObject pathForFile]. 320885 directory size = 0 ifTrue: [^ server]. 320886 ^ (directory at: 1) = self pathNameDelimiter 320887 ifTrue: [server, directory] 320888 ifFalse: [user, '@', server, self pathNameDelimiter asString, directory]! ! 320889 320890!ServerDirectory methodsFor: 'file directory' stamp: 'tk 9/3/1998 12:34'! 320891pathNameDelimiter 320892 "the separator that is used in URLs" 320893 320894 ^ $/! ! 320895 320896!ServerDirectory methodsFor: 'file directory' stamp: 'tk 9/8/1998 12:12'! 320897pathParts 320898 "Return the path from the root of the file system to this directory as an array of directory names. On a remote server." 320899 320900 urlObject ifNotNil: [^ (urlObject path copy) removeLast; yourself]. 320901 ^ (OrderedCollection with: server) addAll: 320902 (directory findTokens: self pathNameDelimiter asString); 320903 yourself. 320904! ! 320905 320906!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:08'! 320907readOnlyFileNamed: aName 320908 "If the file exists, answer a read-only RemoteFileStream on it. aName is directory path, and does include name of the server. Or it can just be a fileName. For now, pre-read the file." 320909 320910 | rFile | 320911 320912 rFile := self asServerFileNamed: aName. 320913 rFile readOnly. 320914 rFile isTypeFile ifTrue: [ 320915 ^ FileStream oldFileNamed: (rFile fileNameRelativeTo: self)]. 320916 320917 ^self streamOnBeginningOf: rFile! ! 320918 320919!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:17'! 320920rename: fullName toBe: newName 320921 "Rename a remote file. fullName is just be a fileName, or can be directory path that includes name of the server. newName is just a fileName" 320922 | file | 320923 320924 file := self asServerFileNamed: fullName. 320925 file isTypeFile ifTrue: [ 320926 (FileDirectory forFileName: (file fileNameRelativeTo: self)) 320927 rename: file fileName toBe: newName 320928 ]. 320929 320930 client := self openFTPClient. 320931 [client renameFileNamed: fullName to: newName] 320932 ensure: [self quit]. 320933 ! ! 320934 320935!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 6/23/2000 09:45'! 320936serverDelimiter 320937 "the separator that is used in the place where the file actually is. ftp server or local disk." 320938 320939 ^ self isTypeFile 320940 ifTrue: [FileDirectory default pathNameDelimiter] 320941 ifFalse: [$/] "for ftp, http"! ! 320942 320943!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/28/2000 13:46'! 320944splitName: fullName to: pathAndNameBlock 320945 "Take the file name and convert it to the path name of a directory and a local file name within that directory. FileName must be of the form: <dirPath><delimiter><localName>, where <dirPath><delimiter> is optional. The <dirPath> part may contain delimiters." 320946 320947 | delimiter i dirName localName | 320948 delimiter := self pathNameDelimiter. 320949 (i := fullName findLast: [:c | c = delimiter]) = 0 320950 ifTrue: 320951 [dirName := String new. 320952 localName := fullName] 320953 ifFalse: 320954 [dirName := fullName copyFrom: 1 to: (i - 1 max: 1). 320955 localName := fullName copyFrom: i + 1 to: fullName size]. 320956 320957 ^ pathAndNameBlock value: dirName value: localName! ! 320958 320959!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:03'! 320960streamOnBeginningOf: serverFile 320961 320962 | remoteStrm | 320963 remoteStrm := RemoteFileStream on: (String new: 2000). 320964 remoteStrm remoteFile: serverFile. 320965 serverFile getFileNamed: serverFile fileName into: remoteStrm. "prefetch data" 320966 ^ remoteStrm! ! 320967 320968 320969!ServerDirectory methodsFor: 'file-in/out' stamp: 'KR 2/1/2006 12:40'! 320970storeServerEntryOn: stream 320971 320972 stream 320973 nextPutAll: 'name:'; tab; nextPutAll: (ServerDirectory nameForServer: self); cr; 320974 nextPutAll: 'directory:'; tab; nextPutAll: self directory; cr; 320975 nextPutAll: 'type:'; tab; nextPutAll: self typeForPrefs; cr; 320976 nextPutAll: 'server:'; tab; nextPutAll: self server; cr. 320977 group 320978 ifNotNil: [stream nextPutAll: 'group:'; tab; nextPutAll: self groupName; cr]. 320979 self user 320980 ifNotNil: [stream nextPutAll: 'user:'; tab; nextPutAll: self user; cr]. 320981 self passwordSequence 320982 ifNotNil: [stream nextPutAll: 'passwdseq:'; tab; nextPutAll: self passwordSequence asString; cr]. 320983 self altUrl 320984 ifNotNil: [stream nextPutAll: 'url:'; tab; nextPutAll: self altUrl; cr]. 320985 self loaderUrl 320986 ifNotNil: [stream nextPutAll: 'loaderUrl:'; tab; nextPutAll: self loaderUrl; cr]. 320987 self acceptsUploads 320988 ifTrue: [stream nextPutAll: 'acceptsUploads:'; tab; nextPutAll: 'true'; cr]. 320989 self encodingName 320990 ifNotNil: [stream nextPutAll: 'encodingName:'; tab; nextPutAll: self encodingName; cr].! ! 320991 320992 320993!ServerDirectory methodsFor: 'initialize' stamp: 'tk 11/26/1998 09:50'! 320994fromUser 320995 "Ask the user for all data on a new server. Save it in a named server." ! ! 320996 320997 320998!ServerDirectory methodsFor: 'multi-action sessions' stamp: 'mir 11/19/2002 17:51'! 320999reset 321000 ! ! 321001 321002!ServerDirectory methodsFor: 'multi-action sessions' stamp: 'mir 12/8/2003 12:54'! 321003sleep 321004 "If still connected, break the connection" 321005 321006 self quitClient. 321007 self keepAlive: false! ! 321008 321009!ServerDirectory methodsFor: 'multi-action sessions' stamp: 'mir 12/8/2003 12:55'! 321010wakeUp 321011 "Start a multi-action session: Open for FTP and keep the connection open" 321012 321013 self isTypeFTP 321014 ifTrue: [client := self openFTPClient]. 321015 self keepAlive: true 321016! ! 321017 321018 321019!ServerDirectory methodsFor: 'nil' stamp: 'RAA 6/23/2000 09:46'! 321020fileNames 321021 "Return a collection of names for the files (but not directories) in this directory." 321022 "(ServerDirectory serverNamed: 'UIUCArchive') fileNames" 321023 321024 self isTypeFTP | self isTypeFile ifFalse: [ 321025 ^ self error: 'To see a directory, use file:// or ftp://' 321026 ]. 321027 ^ (self entries select: [:entry | (entry at: 4) not]) 321028 collect: [:entry | entry first] 321029! ! 321030 321031 321032!ServerDirectory methodsFor: 'server groups' stamp: 'mir 6/26/2001 11:56'! 321033closeGroup 321034 "Close connection with all servers in the group." 321035 321036 self serversInGroup do: [:aDir | aDir quit]. 321037! ! 321038 321039!ServerDirectory methodsFor: 'server groups' stamp: 'mir 6/26/2001 12:25'! 321040convertGroupName 321041 group 321042 ifNotNil: [self groupName: self groupName]! ! 321043 321044!ServerDirectory methodsFor: 'server groups' stamp: 'nk 8/30/2004 08:00'! 321045groupName 321046 321047 ^group 321048 ifNil: [self moniker] 321049 ifNotNil: [ 321050 (group isString) 321051 ifTrue: [group] 321052 ifFalse: [group key]]! ! 321053 321054!ServerDirectory methodsFor: 'server groups' stamp: 'mir 6/26/2001 12:13'! 321055groupName: groupName 321056 group := groupName! ! 321057 321058!ServerDirectory methodsFor: 'server groups' stamp: 'mir 6/26/2001 11:57'! 321059openGroup 321060 "Open all servers in the group. Don't forget to close later." 321061 321062 self serversInGroup do: [:aDir | aDir wakeUp]. 321063! ! 321064 321065!ServerDirectory methodsFor: 'server groups' stamp: 'mir 6/26/2001 11:56'! 321066serversInGroup 321067 ^self groupName 321068 ifNil: [Array with: self] 321069 ifNotNil: [self class serversInGroupNamed: self groupName]! ! 321070 321071 321072!ServerDirectory methodsFor: 'squeaklets' stamp: 'RAA 2/2/2001 08:29'! 321073directoryWrapperClass 321074 321075 ^FileDirectoryWrapper! ! 321076 321077!ServerDirectory methodsFor: 'squeaklets' stamp: 'stephane.ducasse 7/3/2009 21:34'! 321078moveAllButYoungest: young in: versions to: repository 321079 | all fName aVers bVers | 321080 "Specialized to files with names of the form 'aName_vvv.ext'. Where vvv is a mime-encoded base 64 version number. Versions is an array of file names tokenized into three parts (aName vvv ext). Move the files by renaming them on the server." 321081 321082 versions size <= young ifTrue: [^ self]. 321083 all := SortedCollection sortBlock: [:aa :bb | 321084 aVers := Base64MimeConverter decodeInteger: aa second unescapePercents. 321085 bVers := Base64MimeConverter decodeInteger: bb second unescapePercents. 321086 aVers < bVers]. 321087 all addAll: versions. 321088 young timesRepeat: [all removeLast]. "ones we keep" 321089 all do: [:vv | 321090 fName := vv first, '_', vv second, '.', vv third. 321091 repository rename: self fullName,fName toBe: fName]. 321092! ! 321093 321094!ServerDirectory methodsFor: 'squeaklets' stamp: 'yo 7/2/2004 21:18'! 321095upLoadProject: projectName members: archiveMembers retry: aBool 321096 | dir okay m dirName idx | 321097 m := archiveMembers detect:[:any| any fileName includes: $/] ifNone:[nil]. 321098 m == nil ifFalse:[ 321099 dirName := m fileName copyUpTo: $/. 321100 self createDirectory: dirName. 321101 dir := self directoryNamed: dirName]. 321102 archiveMembers do:[:entry| 321103 ProgressNotification signal: '4:uploadingFile' 321104 extra: ('(uploading {1}...)' translated format: {entry fileName}). 321105 idx := entry fileName indexOf: $/. 321106 okay := (idx > 0 321107 ifTrue:[ 321108 dir putFile: entry contentStream 321109 named: (entry fileName copyFrom: idx+1 to: entry fileName size) 321110 retry: aBool] 321111 ifFalse:[ 321112 self putFile: entry contentStream 321113 named: entry fileName 321114 retry: aBool]). 321115 (okay == false 321116 or: [okay isString]) 321117 ifTrue: [ 321118 self inform: ('Upload for {1} did not succeed ({2}).' translated format: {entry fileName printString. okay}). 321119 ^false]. 321120 ]. 321121 ProgressNotification signal: '4:uploadingFile' extra:''. 321122 ^true! ! 321123 321124!ServerDirectory methodsFor: 'squeaklets' stamp: 'ar 3/2/2001 19:08'! 321125upLoadProject: projectFile named: fileNameOnServer resourceUrl: resUrl retry: aBool 321126 "Upload the given project file. If it's an archive, upload only the files that are local to the project." 321127 | archive members upload prefix | 321128 self isTypeFile ifTrue:[ 321129 ^(FileDirectory on: urlObject pathForDirectory) 321130 upLoadProject: projectFile named: fileNameOnServer resourceUrl: resUrl retry: aBool]. 321131 projectFile isZipArchive 321132 ifFalse:[^self putFile: projectFile named: fileNameOnServer retry: aBool]. 321133 projectFile binary. 321134 archive := ZipArchive new readFrom: projectFile. 321135 resUrl last = $/ 321136 ifTrue:[prefix := resUrl copyFrom: 1 to: resUrl size-1] "remove last slash" 321137 ifFalse:[prefix := resUrl]. 321138 prefix := prefix copyFrom: 1 to: (prefix lastIndexOf: $/). 321139 members := archive members select:[:entry| 321140 "figure out where it's coming from" 321141 upload := false. 321142 (entry fileName indexOf: $:) = 0 ifTrue:[ 321143 upload := true. "one of the core files, e.g., project itself, resource map, meta info" 321144 ] ifFalse:[ 321145 (entry fileName asLowercase beginsWith: resUrl asLowercase) ifTrue:[ 321146 upload := true. 321147 entry fileName: (entry fileName copyFrom: prefix size+1 to: entry fileName size). 321148 ]. 321149 ]. 321150 upload]. 321151 members := members asArray sort:[:m1 :m2| m1 compressedSize < m2 compressedSize]. 321152 ^self upLoadProject: fileNameOnServer members: members retry: aBool.! ! 321153 321154!ServerDirectory methodsFor: 'squeaklets' stamp: 'RAA 10/12/2000 17:17'! 321155updateProjectInfoFor: aProject 321156 321157 "only swiki servers for now"! ! 321158 321159!ServerDirectory methodsFor: 'squeaklets' stamp: 'dgd 12/23/2003 16:21'! 321160writeProject: aProject inFileNamed: fileNameString fromDirectory: localDirectory 321161 "write aProject (a file version can be found in the file named fileNameString in localDirectory)" 321162 aProject 321163 writeFileNamed: fileNameString 321164 fromDirectory: localDirectory 321165 toServer: self! ! 321166 321167 321168!ServerDirectory methodsFor: 'testing' stamp: 'mir 6/25/2001 12:52'! 321169acceptsUploads 321170 ^true! ! 321171 321172!ServerDirectory methodsFor: 'testing' stamp: 'mir 4/16/2001 17:41'! 321173isProjectSwiki 321174 ^false! ! 321175 321176!ServerDirectory methodsFor: 'testing' stamp: 'dgd 12/27/2003 10:47'! 321177isRemoteDirectory 321178 "answer whatever the receiver is a remote directory" 321179 ^ true! ! 321180 321181!ServerDirectory methodsFor: 'testing' stamp: 'yo 8/28/2008 00:22'! 321182isRoot 321183 ^ directory = '/'! ! 321184 321185!ServerDirectory methodsFor: 'testing' stamp: 'mir 11/14/2001 16:25'! 321186isSearchable 321187 ^false! ! 321188 321189!ServerDirectory methodsFor: 'testing' stamp: 'mir 12/8/2003 12:28'! 321190keepAlive 321191 keepAlive ifNil: [keepAlive := false]. 321192 ^keepAlive! ! 321193 321194 321195!ServerDirectory methodsFor: 'up/download' stamp: 'mir 9/25/2008 15:11'! 321196fileExists: fileName 321197 "Does the file exist on this server directory? fileName must be simple with no / or references to other directories." 321198 321199 | stream | 321200 self isTypeFile ifTrue: [^ self fileNames includes: fileName]. 321201 self isTypeHTTP ifTrue: [ 321202 "http" 321203 stream := self readOnlyFileNamed: fileName. 321204 ^stream contents notEmpty]. 321205 "ftp" 321206 ^ self entries anySatisfy: [:entry | entry name = fileName]! ! 321207 321208!ServerDirectory methodsFor: 'up/download' stamp: 'damiencassou 5/30/2008 15:52'! 321209getDirectory 321210 "Return a stream with a listing of the current server directory. (Later -- Use a proxy server if one has been registered.)" 321211 | listing | 321212 client := self openFTPClient. 321213 [ listing := client getDirectory ] ensure: [ self quit ]. 321214 ^ listing readStream! ! 321215 321216!ServerDirectory methodsFor: 'up/download' stamp: 'damiencassou 5/30/2008 15:52'! 321217getFileList 321218 "Return a stream with a list of files in the current server directory. (Later -- Use a proxy server if one has been registered.)" 321219 | listing | 321220 client := self openFTPClient. 321221 [ listing := client getFileList ] ensure: [ self quit ]. 321222 ^ listing readStream! ! 321223 321224!ServerDirectory methodsFor: 'up/download' stamp: 'mir 12/8/2003 14:17'! 321225getFileNamed: fileNameOnServer 321226 "Just FTP a file from a server. Return contents. 321227 (Later -- Use a proxy server if one has been registered.)" 321228 321229 | result | 321230 client := self openFTPClient. 321231 [result := client getFileNamed: fileNameOnServer] 321232 ensure: [self quit]. 321233 ^result! ! 321234 321235!ServerDirectory methodsFor: 'up/download' stamp: 'tak 9/25/2008 15:12'! 321236getFileNamed: fileNameOnServer into: dataStream 321237 321238 ^ self getFileNamed: fileNameOnServer into: dataStream 321239 httpRequest: 'Pragma: no-cache', String crlf! ! 321240 321241!ServerDirectory methodsFor: 'up/download' stamp: 'ar 4/10/2005 18:52'! 321242getFileNamed: fileNameOnServer into: dataStream httpRequest: requestString 321243 "Just FTP a file from a server. Return a stream. (Later -- Use a proxy server if one has been registered.)" 321244 321245 | resp | 321246 self isTypeFile ifTrue: [ 321247 dataStream nextPutAll: 321248 (resp := FileStream oldFileNamed: server,(self serverDelimiter asString), 321249 self bareDirectory, (self serverDelimiter asString), 321250 fileNameOnServer) contentsOfEntireFile. 321251 dataStream dataIsValid. 321252 ^ resp]. 321253 self isTypeHTTP ifTrue: [ 321254 resp := HTTPSocket httpGet: (self fullNameFor: fileNameOnServer) 321255 args: nil accept: 'application/octet-stream' request: requestString. 321256 resp isString ifTrue: [^ dataStream]. "error, no data" 321257 dataStream copyFrom: resp. 321258 dataStream dataIsValid. 321259 ^ dataStream]. 321260 321261 client := self openFTPClient. "Open passive. Do everything up to RETR or STOR" 321262 [client getFileNamed: fileNameOnServer into: dataStream] 321263 ensure: [self quit]. 321264 321265 dataStream dataIsValid. 321266! ! 321267 321268!ServerDirectory methodsFor: 'up/download' stamp: 'PeterHugossonMiller 9/3/2009 11:20'! 321269getOnlyBuffer: buffer from: fileNameOnServer 321270 "Open ftp, fill the buffer, and close the connection. Only first part of a very long file." 321271 321272 | dataStream | 321273 client := self openFTPClient. 321274 dataStream := buffer writeStream. 321275 [client getPartial: buffer size fileNamed: fileNameOnServer into: dataStream] 321276 ensure: [self quit]. 321277 ^buffer! ! 321278 321279!ServerDirectory methodsFor: 'up/download' stamp: 'mir 12/8/2003 16:39'! 321280putFile: fileStream named: fileNameOnServer 321281 "Just FTP a local fileStream to the server. (Later -- Use a proxy server if one has been registered.)" 321282 321283 client := self openFTPClient. 321284 client binary. 321285 [client putFileStreamContents: fileStream as: fileNameOnServer] 321286 ensure: [self quit]! ! 321287 321288!ServerDirectory methodsFor: 'up/download' stamp: 'nk 8/30/2004 08:00'! 321289putFile: fileStream named: fileNameOnServer retry: aBool 321290 "ar 11/24/1998 Do the usual putFile:named: operation but retry if some error occurs and aBool is set. Added due to having severe transmission problems on shell.webpage.com." 321291 | resp | 321292 self isTypeFile ifTrue: [ 321293 ^ (FileDirectory on: urlObject pathForDirectory) 321294 putFile: fileStream named: fileNameOnServer]. 321295 321296 [[resp := self putFile: fileStream named: fileNameOnServer] 321297 ifError:[:err :rcvr| resp := '5xx ',err]. "Report as error" 321298 aBool and:[((resp isString) and: [resp size > 0]) and:[resp first ~= $2]]] whileTrue:[ 321299 (self confirm:('Error storing ',fileNameOnServer,' on the server.\(',resp,',)\Retry operation?') withCRs) ifFalse:[^resp]. 321300 ]. 321301 ^resp! ! 321302 321303!ServerDirectory methodsFor: 'up/download' stamp: 'di 3/14/2001 15:34'! 321304putFileSavingOldVersion: fileStream named: fileNameOnServer 321305 321306 | tempName oldName | 321307 "Put a copy of this file out after saving the prior version. 321308 Nothing happens to the old version until the new vers is successfully stored." 321309 tempName := fileNameOnServer , '.beingWritten'. 321310 oldName := fileNameOnServer , '.prior'. 321311 self putFile: fileStream named: tempName retry: true. 321312 (self includesKey: oldName) ifTrue: [self deleteFileNamed: oldName]. 321313 self rename: fileNameOnServer toBe: oldName. 321314 self rename: tempName toBe: fileNameOnServer. 321315! ! 321316 321317 321318!ServerDirectory methodsFor: 'updates' stamp: 'tk 1/7/2001 11:58'! 321319checkNames: list 321320 "Look at these names for update and see if they are OK" 321321 321322list do: [:local | 321323 (local count: [:char | char == $.]) > 1 ifTrue: [ 321324 self inform: 'File name ',local,' 321325may not have more than one period'. 321326 ^ false]. 321327 local size > 26 ifTrue: ["allows for 5 digit update numbers" 321328 self inform: 'File name ',local,' 321329is too long. Please rename it.'. 321330 ^ false]. 321331 (local at: 1) isDigit ifTrue: [ 321332 self inform: 'File name ',local,' 321333may not begin with a number'. 321334 ^ false]. 321335 (local findDelimiters: '%/* ' startingAt: 1) <= local size ifTrue: [ 321336 self inform: 'File name ',local,' 321337may not contain % / * or space'. 321338 ^ false]]. 321339^ true 321340! ! 321341 321342!ServerDirectory methodsFor: 'updates' stamp: 'rbb 2/18/2005 14:40'! 321343checkServersWithPrefix: prefix andParseListInto: listBlock 321344 "Check that all servers are up and have the latest Updates.list. 321345 Warn user when can't write to a server that can still be read. 321346 The contents of updates.list is parsed into {{vers. {fileNames*}}*}, 321347 and returned via the listBlock." 321348 321349 | serverList updateLists listContents maxSize outOfDateServers | 321350 serverList := self serversInGroup. 321351 serverList isEmpty 321352 ifTrue: [^Array new]. 321353 321354 updateLists := Dictionary new. 321355 serverList do: [:updateServer | 321356 [listContents := updateServer getFileNamed: prefix , 'updates.list'. 321357 updateLists at: updateServer put: listContents] 321358 on: Error 321359 do: [:ex | 321360 UIManager default chooseFrom: #('Cancel entire update') 321361 title: 'Server ', updateServer moniker, 321362 ' is unavailable.\Please consider phoning the administator.\' withCRs, listContents. 321363 ^Array new]]. 321364 321365 maxSize := (updateLists collect: [:each | each size]) max. 321366 outOfDateServers := updateLists keys select: [:updateServer | 321367 (updateLists at: updateServer) size < maxSize]. 321368 321369 outOfDateServers do: [:updateServer | 321370 (self outOfDate: updateServer) ifTrue: [^Array new]]. 321371 321372 listBlock value: (Utilities parseListContents: listContents). 321373 321374 serverList removeAll: outOfDateServers. 321375 ^serverList 321376 321377! ! 321378 321379!ServerDirectory methodsFor: 'updates' stamp: 'damiencassou 5/30/2008 15:52'! 321380copyUpdatesNumbered: selectList toVersion: otherVersion 321381 "Into the section of updates.list corresponding to otherVersion, 321382 copy all the fileNames from this version matching the selectList." 321383 " 321384 (ServerDirectory serverInGroupNamed: 'Disney Internal Updates*') 321385 copyUpdatesNumbered: #(4411 4412) to version: 'Squeak3.1beta'. 321386" 321387 | myServers updateStrm seq indexPrefix listContents version versIndex lastNum otherVersIndex additions outOfOrder | 321388 self openGroup. 321389 indexPrefix := (self groupName includes: $*) 321390 ifTrue: 321391 [ (self groupName findTokens: ' ') first "special for internal updates" ] 321392 ifFalse: [ '' ]. "normal" 321393 myServers := self 321394 checkServersWithPrefix: indexPrefix 321395 andParseListInto: [ :x | listContents := x ]. 321396 myServers size = 0 ifTrue: 321397 [ self closeGroup. 321398 ^ self ]. 321399 version := SystemVersion current version. 321400 versIndex := (listContents collect: [ :pair | pair first ]) indexOf: version. 321401 versIndex = 0 ifTrue: 321402 [ self inform: 'There is no section in updates.list for your version'. 321403 self closeGroup. 321404 ^ nil ]. "abort" 321405 otherVersIndex := (listContents collect: [ :pair | pair first ]) indexOf: otherVersion. 321406 otherVersIndex = 0 ifTrue: 321407 [ self inform: 'There is no section in updates.list for the target version'. 321408 self closeGroup. 321409 ^ nil ]. "abort" 321410 versIndex < listContents size ifTrue: 321411 [ (self confirm: 'This system, ' , version , ' is not the latest version.\OK to copy updates from that old version?' withCRs) ifFalse: 321412 [ self closeGroup. 321413 ^ nil ] ]. "abort" 321414 321415 "Append all fileNames in my list that are not in the export list" 321416 additions := OrderedCollection new. 321417 outOfOrder := OrderedCollection new. 321418 lastNum := (listContents at: otherVersIndex) last isEmpty 321419 ifTrue: [ 0 "no checking if the current list is empty" ] 321420 ifFalse: [ (listContents at: otherVersIndex) last last initialIntegerOrNil ]. 321421 (listContents at: versIndex) last do: 321422 [ :fileName | 321423 seq := fileName initialIntegerOrNil. 321424 (selectList includes: seq) ifTrue: 321425 [ seq > lastNum 321426 ifTrue: [ additions addLast: fileName ] 321427 ifFalse: [ outOfOrder addLast: seq ] ] ]. 321428 outOfOrder isEmpty ifFalse: 321429 [ UIManager default inform: 'Updates numbered ' , outOfOrder asArray printString , ' are out of order.\ The last update in ' withCRs , otherVersion , ' is ' , lastNum printString , '.\No update will take place.' withCRs. 321430 self closeGroup. 321431 ^ nil ]. "abort" 321432 321433 "Save old copy of updates.list on local disk" 321434 FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'. 321435 Utilities 321436 writeList: listContents 321437 toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk'). 321438 321439 "Write a new copy of updates.list on all servers..." 321440 listContents 321441 at: otherVersIndex 321442 put: { 321443 otherVersion. 321444 ((listContents at: otherVersIndex) last , additions) 321445 }. 321446 updateStrm := (String streamContents: 321447 [ :s | 321448 Utilities 321449 writeList: listContents 321450 toStream: s ]) readStream. 321451 myServers do: 321452 [ :aServer | 321453 updateStrm reset. 321454 aServer 321455 putFile: updateStrm 321456 named: indexPrefix , 'updates.list' 321457 retry: true. 321458 Transcript 321459 show: 'Update succeeded on server ' , aServer moniker; 321460 cr ]. 321461 self closeGroup. 321462 Transcript 321463 cr; 321464 show: 'Be sure to test your new update!!'; 321465 cr! ! 321466 321467!ServerDirectory methodsFor: 'updates' stamp: 'damiencassou 5/30/2008 15:52'! 321468exportUpdatesExcept: skipList 321469 "Into the section of updates.list corresponding to this version, 321470 copy all the fileNames in the named updates.list for this group 321471 that are more recently numbered." 321472 " 321473 (ServerDirectory serverInGroupNamed: 'Disney Internal Updates*') 321474 exportUpdatesExcept: #(3959). 321475" 321476 | myServers updateStrm response seq indexPrefix listContents version versIndex lastNum expContents expVersIndex additions | 321477 self openGroup. 321478 indexPrefix := (self groupName includes: $*) 321479 ifTrue: 321480 [ (self groupName findTokens: ' ') first "special for internal updates" ] 321481 ifFalse: [ '' ]. "normal" 321482 myServers := self 321483 checkServersWithPrefix: indexPrefix 321484 andParseListInto: [ :x | listContents := x ]. 321485 myServers size = 0 ifTrue: 321486 [ self closeGroup. 321487 ^ self ]. 321488 version := SystemVersion current version. 321489 versIndex := (listContents collect: [ :pair | pair first ]) indexOf: version. 321490 versIndex = 0 ifTrue: 321491 [ self inform: 'There is no section in updates.list for your version'. 321492 self closeGroup. 321493 ^ nil ]. "abort" 321494 versIndex < listContents size ifTrue: 321495 [ response := UIManager default 321496 chooseFrom: #( 321497 'Make update from an older version' 321498 'Cancel update' 321499 ) 321500 title: 'This system, ' , SystemVersion current version , ' is not the latest version'. 321501 response = 1 ifFalse: 321502 [ self closeGroup. 321503 ^ nil ] ]. "abort" 321504 321505 "Get the old export updates.list." 321506 expContents := Utilities parseListContents: (myServers first getFileNamed: 'updates.list'). 321507 expVersIndex := (expContents collect: [ :pair | pair first ]) indexOf: version. 321508 expVersIndex = 0 ifTrue: 321509 [ self inform: 'There is no section in updates.list for your version'. 321510 self closeGroup. 321511 ^ nil ]. "abort" 321512 lastNum := (expContents at: expVersIndex) last isEmpty 321513 ifTrue: [ 0 "no checking if the current list is empty" ] 321514 ifFalse: [ (expContents at: expVersIndex) last last initialIntegerOrNil ]. 321515 321516 "Save old copy of updates.list on local disk" 321517 FileDirectory default deleteFileNamed: 'updates.list.bk'. 321518 Utilities 321519 writeList: expContents 321520 toStream: (FileStream fileNamed: 'updates.list.bk'). 321521 321522 "Append all fileNames in my list that are not in the export list" 321523 additions := OrderedCollection new. 321524 (listContents at: versIndex) last do: 321525 [ :fileName | 321526 seq := fileName initialIntegerOrNil. 321527 (seq > lastNum and: [ (skipList includes: seq) not ]) ifTrue: [ additions addLast: fileName ] ]. 321528 expContents 321529 at: expVersIndex 321530 put: { 321531 version. 321532 ((expContents at: expVersIndex) last , additions) 321533 }. 321534 (self confirm: 'Do you really want to export ' , additions size printString , ' recent updates?') ifFalse: 321535 [ self closeGroup. 321536 ^ nil ]. "abort" 321537 321538 "Write a new copy of updates.list on all servers..." 321539 updateStrm := (String streamContents: 321540 [ :s | 321541 Utilities 321542 writeList: expContents 321543 toStream: s ]) readStream. 321544 myServers do: 321545 [ :aServer | 321546 updateStrm reset. 321547 aServer 321548 putFile: updateStrm 321549 named: 'updates.list' 321550 retry: true. 321551 Transcript 321552 show: 'Update succeeded on server ' , aServer moniker; 321553 cr ]. 321554 self closeGroup. 321555 Transcript 321556 cr; 321557 show: 'Be sure to test your new update!!'; 321558 cr! ! 321559 321560!ServerDirectory methodsFor: 'updates' stamp: 'rbb 2/18/2005 14:39'! 321561outOfDate: aServer 321562 "Inform the user that this server does not have a current version of 'Updates.list' Return true if the user does not want any updates to happen." 321563 321564| response | 321565response := UIManager default chooseFrom: #('Install on others' 'Cancel entire update') 321566 title: 'The server ', aServer moniker, ' is not up to date. 321567Please store the missing updates maually.'. 321568^ response ~= 1! ! 321569 321570!ServerDirectory methodsFor: 'updates' stamp: 'damiencassou 5/30/2008 15:52'! 321571putUpdate: fileStrm 321572 "Put this file out as an Update on the servers of my group. Each version of the system may have its own set of update files, or they may all share the same files. 'updates.list' holds the master list. Each update is a fileIn whose name begins with a number. See Utilities class readServerUpdatesThrough:saveLocally:updateImage:. 321573 When two sets of updates are stored on the same directory, one of them has a * in its 321574serverUrls description. When that is true, the first word of the description is put on 321575the front of 'updates.list', and that index file is used." 321576 | myServers updateStrm newName response localName seq indexPrefix listContents version versIndex lastNum stripped | 321577 localName := fileStrm localName. 321578 fileStrm size = 0 ifTrue: [ ^ self inform: 'That file has zero bytes!! May have a new name.' ]. 321579 (fileStrm contentsOfEntireFile includes: Character linefeed) ifTrue: 321580 [ self notifyWithLabel: 'That file contains linefeeds. Proceed if... 321581you know that this is okay (e.g. the file contains raw binary data).' ]. 321582 fileStrm reset. 321583 (self checkNames: { localName }) ifFalse: [ ^ nil ]. "illegal characters" 321584 response := UIManager default 321585 chooseFrom: #('Install update' 'Cancel update' ) 321586 title: 'Do you really want to broadcast the file ' , localName , '\to every Squeak user who updates from ' withCRs , self groupName , '?'. 321587 response = 1 ifFalse: [ ^ nil ]. "abort" 321588 self openGroup. 321589 indexPrefix := (self groupName includes: $*) 321590 ifTrue: 321591 [ (self groupName findTokens: ' ') first "special for internal updates" ] 321592 ifFalse: [ '' ]. "normal" 321593 myServers := self 321594 checkServersWithPrefix: indexPrefix 321595 andParseListInto: [ :x | listContents := x ]. 321596 myServers size = 0 ifTrue: 321597 [ self closeGroup. 321598 ^ self ]. 321599 version := SystemVersion current version. 321600 versIndex := (listContents collect: [ :pair | pair first ]) indexOf: version. 321601 versIndex = 0 ifTrue: 321602 [ self inform: 'There is no section in updates.list for your version'. 321603 self closeGroup. 321604 ^ nil ]. "abort" 321605 321606 "A few affirmations..." 321607 versIndex < listContents size ifTrue: 321608 [ (self confirm: 'This system, ' , version , ' is not the latest version.\Make update for an older version?' withCRs) ifFalse: 321609 [ self closeGroup. 321610 ^ nil ] ]. "abort" 321611 (listContents at: versIndex) last isEmpty ifTrue: 321612 [ (self confirm: 'Please confirm that you mean to issue the first update for ' , version , '\(otherwise something is wrong).' withCRs) ifFalse: 321613 [ self closeGroup. 321614 ^ nil ] ]. 321615 321616 "We now determine next update number to be max of entire index" 321617 lastNum := listContents 321618 inject: 0 321619 into: 321620 [ :max :pair | 321621 pair last isEmpty 321622 ifTrue: [ max ] 321623 ifFalse: [ max max: pair last last initialIntegerOrNil ] ]. 321624 321625 "Save old copy of updates.list on local disk" 321626 FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'. 321627 Utilities 321628 writeList: listContents 321629 toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk'). 321630 321631 "append name to updates with new sequence number" 321632 seq := (lastNum + 1) printString 321633 padded: #left 321634 to: 4 321635 with: $0. 321636 "strip off any old seq number" 321637 stripped := localName 321638 copyFrom: (localName findFirst: [ :c | c isDigit not ]) 321639 to: localName size. 321640 newName := seq , stripped. 321641 listContents 321642 at: versIndex 321643 put: { 321644 version. 321645 ((listContents at: versIndex) last copyWith: newName) 321646 }. 321647 321648 "Write a new copy on all servers..." 321649 updateStrm := (String streamContents: 321650 [ :s | 321651 Utilities 321652 writeList: listContents 321653 toStream: s ]) readStream. 321654 myServers do: 321655 [ :aServer | 321656 fileStrm reset. "reopen" 321657 aServer 321658 putFile: fileStrm 321659 named: newName 321660 retry: true. 321661 updateStrm reset. 321662 aServer 321663 putFile: updateStrm 321664 named: indexPrefix , 'updates.list' 321665 retry: true. 321666 Transcript 321667 show: 'Update succeeded on server ' , aServer moniker; 321668 cr ]. 321669 self closeGroup. 321670 Transcript 321671 cr; 321672 show: 'Be sure to test your new update!!'; 321673 cr. 321674 "rename the file locally (may fail)" 321675 fileStrm directory 321676 rename: localName 321677 toBe: newName! ! 321678 321679!ServerDirectory methodsFor: 'updates' stamp: 'DamienCassou 9/29/2009 13:09'! 321680putUpdateMulti: list fromDirectory: updateDirectory 321681 "Put these files out as an Update on the servers of my group. List is an array of local file names with or without number prefixes. Each version of the system has its own set of update files. 'updates.list' holds the master list. Each update is a fileIn whose name begins with a number. See Utilities class absorbUpdatesFromServer." 321682 | myServers updateStrm lastNum response newNames file numStr indexPrefix listContents version versIndex seq stripped | 321683 (self checkNames: (list collect: 321684 [ :each | 321685 "Check the names without their numbers" 321686 each 321687 copyFrom: (each findFirst: [ :c | c isDigit not ]) 321688 to: each size ])) ifFalse: [ ^ nil ]. 321689 response := UIManager default 321690 chooseFrom: #('Install update' 'Cancel update' ) 321691 title: 'Do you really want to broadcast ' , list size printString , ' updates' , '\to every Squeak user who updates from ' withCRs , self groupName , '?'. 321692 response = 1 ifFalse: [ ^ nil ]. "abort" 321693 self openGroup. 321694 indexPrefix := (self groupName includes: $*) 321695 ifTrue: 321696 [ (self groupName findTokens: ' ') first "special for internal updates" ] 321697 ifFalse: [ '' ]. "normal" 321698 myServers := self 321699 checkServersWithPrefix: indexPrefix 321700 andParseListInto: [ :x | listContents := x ]. 321701 myServers size = 0 ifTrue: 321702 [ self closeGroup. 321703 ^ self ]. 321704 version := SystemVersion current version. 321705 versIndex := (listContents collect: [ :pair | pair first ]) indexOf: version. 321706 versIndex = 0 ifTrue: 321707 [ self inform: 'There is no section in updates.list for your version'. 321708 self closeGroup. 321709 ^ nil ]. "abort" 321710 lastNum := (listContents at: versIndex) last last initialIntegerOrNil. 321711 versIndex < listContents size ifTrue: 321712 [ response := UIManager default 321713 chooseFrom: #( 321714 'Make update for an older version' 321715 'Cancel update' 321716 ) 321717 title: 'This system, ' , SystemVersion current version , ' is not the latest version'. 321718 response = 1 ifFalse: 321719 [ self closeGroup. 321720 ^ nil ]. 321721 numStr := UIManager default 321722 request: 'Please confirm or change the starting update number' 321723 initialAnswer: (lastNum + 1) printString. 321724 numStr ifNil: [numStr := String new]. 321725 lastNum := numStr asNumber - 1 ]. "abort" 321726 "Save old copy of updates.list on local disk" 321727 FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'. 321728 Utilities 321729 writeList: listContents 321730 toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk'). 321731 321732 "Append names to updates with new sequence numbers" 321733 newNames := list 321734 with: (lastNum + 1 to: lastNum + list size) 321735 collect: 321736 [ :each :num | 321737 seq := num printString 321738 padded: #left 321739 to: 4 321740 with: $0. 321741 "strip off any old seq number" 321742 stripped := each 321743 copyFrom: (each findFirst: [ :c | c isDigit not ]) 321744 to: each size. 321745 seq , stripped ]. 321746 listContents 321747 at: versIndex 321748 put: { 321749 version. 321750 ((listContents at: versIndex) second , newNames) 321751 }. 321752 321753 "Write a new copy on all servers..." 321754 updateStrm := (String streamContents: 321755 [ :s | 321756 Utilities 321757 writeList: listContents 321758 toStream: s ]) readStream. 321759 myServers do: 321760 [ :aServer | 321761 list doWithIndex: 321762 [ :local :ind | 321763 file := updateDirectory oldFileNamed: local. 321764 aServer 321765 putFile: file 321766 named: (newNames at: ind) 321767 retry: true. 321768 file close ]. 321769 updateStrm reset. 321770 aServer 321771 putFile: updateStrm 321772 named: indexPrefix , 'updates.list' 321773 retry: true. 321774 Transcript 321775 show: 'Update succeeded on server ' , aServer moniker; 321776 cr ]. 321777 self closeGroup. 321778 Transcript 321779 cr; 321780 show: 'Be sure to test your new update!!'; 321781 cr. 321782 "rename the file locally" 321783 list 321784 with: newNames 321785 do: 321786 [ :local :newName | 321787 updateDirectory 321788 rename: local 321789 toBe: newName ]! ! 321790 321791!ServerDirectory methodsFor: 'updates' stamp: 'alain.plantec 2/10/2009 18:25'! 321792updateInstallVersion: newVersion 321793 "For each server group, ask whether we want to put the new version marker (eg 'Squeak2.3') at the end of the file. Current version of Squeak must be the old one when this is done. 321794 ServerDirectory new updateInstallVersion: 'Squeak9.9test' 321795" 321796 | myServers updateStrm names choice indexPrefix listContents version versIndex | 321797 321798 [ names := ServerDirectory groupNames asSortedArray. 321799 choice := UIManager default chooseFrom: names values: names. 321800 choice == nil ] whileFalse: 321801 [ indexPrefix := (choice endsWith: '*') 321802 ifTrue: [ (choice findTokens: ' ') first "special for internal updates" ] 321803 ifFalse: [ '' ]. "normal" 321804 myServers := (ServerDirectory serverInGroupNamed: choice) 321805 checkServersWithPrefix: indexPrefix 321806 andParseListInto: [ :x | listContents := x ]. 321807 myServers size = 0 ifTrue: [ ^ self ]. 321808 version := SystemVersion current version. 321809 versIndex := (listContents collect: [ :pair | pair first ]) indexOf: version. 321810 versIndex = 0 ifTrue: 321811 [ ^ self inform: 'There is no section in updates.list for your version' ]. "abort" 321812 321813 "Append new version to updates following my version" 321814 listContents := listContents 321815 copyReplaceFrom: versIndex + 1 321816 to: versIndex 321817 with: { { newVersion. { } } }. 321818 updateStrm := (String streamContents: 321819 [ :s | 321820 Utilities 321821 writeList: listContents 321822 toStream: s ]) readStream. 321823 myServers do: 321824 [ :aServer | 321825 updateStrm reset. 321826 aServer 321827 putFile: updateStrm 321828 named: indexPrefix , 'updates.list'. 321829 Transcript 321830 cr; 321831 show: indexPrefix , 'updates.list written on server ' , aServer moniker ]. 321832 self closeGroup ]! ! 321833 321834"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 321835 321836ServerDirectory class 321837 instanceVariableNames: ''! 321838 321839!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:46'! 321840addServer: server named: nameString 321841 self servers at: nameString put: server! ! 321842 321843!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:45'! 321844nameForServer: aServer 321845 ^self servers keyAtValue: aServer! ! 321846 321847!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 11/14/2001 16:26'! 321848projectServers 321849 "ServerDirectory projectServers" 321850 321851 | projectServers projectServer | 321852 projectServers := OrderedCollection new. 321853 self serverNames do: [ :n | 321854 projectServer := ServerDirectory serverNamed: n. 321855 (projectServer isProjectSwiki and: [projectServer isSearchable]) 321856 ifTrue: [projectServers add: projectServer]]. 321857 ^projectServers! ! 321858 321859!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:47'! 321860removeServerNamed: nameString 321861 self 321862 removeServerNamed: nameString 321863 ifAbsent: [self error: 'Server "' , nameString asString , '" not found']! ! 321864 321865!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:46'! 321866removeServerNamed: nameString ifAbsent: aBlock 321867 self servers removeKey: nameString ifAbsent: [aBlock value]! ! 321868 321869!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:45'! 321870resetServers 321871 Servers := nil! ! 321872 321873!ServerDirectory class methodsFor: 'available servers' stamp: 'gk 10/21/2005 10:29'! 321874serverForURL: aURLString 321875 | serversForURL server urlPath serverPath relPath | 321876 serversForURL := self servers values select: [:each | 321877 (aURLString beginsWith: each downloadUrl) 321878 or: [(aURLString beginsWith: each realUrl) 321879 or: [aURLString , '/' beginsWith: each downloadUrl]]]. 321880 serversForURL isEmpty 321881 ifTrue: [^nil]. 321882 server := serversForURL first. 321883 urlPath := aURLString asUrl path. 321884 (urlPath isEmpty not 321885 and: [urlPath last isEmpty]) 321886 ifTrue: [urlPath removeLast]. 321887 serverPath := server downloadUrl asUrl path. 321888 (serverPath isEmpty not 321889 and: [serverPath last isEmpty]) 321890 ifTrue: [serverPath removeLast]. 321891 urlPath size < serverPath size 321892 ifTrue: [^nil]. 321893 relPath := String new. 321894 serverPath size +1 to: urlPath size do: [:i | relPath := relPath , '/' , (urlPath at: i)]. 321895 ^relPath isEmpty 321896 ifTrue: [server] 321897 ifFalse: [server directoryNamed: (relPath copyFrom: 2 to: relPath size)]! ! 321898 321899!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 14:06'! 321900serverNamed: nameString 321901 ^self serverNamed: nameString ifAbsent: [self error: 'Server name not found']! ! 321902 321903!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:44'! 321904serverNamed: nameString ifAbsent: aBlock 321905 ^self servers at: nameString asString ifAbsent: [aBlock value]! ! 321906 321907!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:48'! 321908serverNames 321909 ^self servers keys asSortedArray! ! 321910 321911!ServerDirectory class methodsFor: 'available servers' stamp: 'mir 6/26/2001 09:45'! 321912servers 321913 Servers ifNil: [Servers := Dictionary new]. 321914 ^Servers! ! 321915 321916 321917!ServerDirectory class methodsFor: 'initialization' stamp: 'mir 6/25/2001 18:46'! 321918initialize 321919 "ServerDirectory initialize" 321920 "ServerDirectory resetLocalProjectDirectories. 321921 Servers := Dictionary new." 321922 321923 ExternalSettings registerClient: self! ! 321924 321925 321926!ServerDirectory class methodsFor: 'misc' stamp: 'tk 12/29/1998 22:46'! 321927defaultStemUrl 321928 "For writing on an FTP directory. Users should insert their own server url here." 321929"ftp://jumbo.rd.wdi.disney.com/raid1/people/dani/Books/Grp/Grp" 321930" ServerDirectory defaultStemUrl " 321931 321932| rand dir | 321933rand := String new: 4. 3219341 to: rand size do: [:ii | 321935 rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)]. 321936dir := self serverNamed: 'DaniOnJumbo'. 321937^ 'ftp://', dir server, dir slashDirectory, '/BK', rand! ! 321938 321939!ServerDirectory class methodsFor: 'misc' stamp: 'tk 9/8/1998 11:57'! 321940newFrom: aSimilarObject 321941 "Must copy the urlObject, so they won't be shared" 321942 321943 | inst | 321944 inst := super newFrom: aSimilarObject. 321945 inst urlObject: aSimilarObject urlObject copy. 321946 ^ inst! ! 321947 321948!ServerDirectory class methodsFor: 'misc' stamp: 'tak 9/25/2008 15:10'! 321949on: pathString 321950 321951 ^ self new on: pathString! ! 321952 321953!ServerDirectory class methodsFor: 'misc' stamp: 'kfr 7/18/2003 11:18'! 321954parseFTPEntry: ftpEntry 321955 | tokens longy dateInSeconds thisYear thisMonth | 321956 thisYear := Date today year. 321957 thisMonth := Date today monthIndex. 321958 tokens := ftpEntry findTokens: ' '. 321959 321960 tokens size = 8 ifTrue: 321961 [((tokens at: 6) size ~= 3 and: [(tokens at: 5) size = 3]) ifTrue: 321962 ["Fix for case that group is blank (relies on month being 3 chars)" 321963 tokens := tokens copyReplaceFrom: 4 to: 3 with: {'blank'}]]. 321964 tokens size >= 9 ifFalse:[^nil]. 321965 321966 ((tokens at: 6) size ~= 3 and: [(tokens at: 5) size = 3]) ifTrue: 321967 ["Fix for case that group is blank (relies on month being 3 chars)" 321968 tokens := tokens copyReplaceFrom: 4 to: 3 with: {'blank'}]. 321969 321970 tokens size > 9 ifTrue: 321971 [longy := tokens at: 9. 321972 10 to: tokens size do: [:i | longy := longy , ' ' , (tokens at: i)]. 321973 tokens at: 9 put: longy]. 321974 dateInSeconds := self 321975 secondsForDay: (tokens at: 7) 321976 month: (tokens at: 6) 321977 yearOrTime: (tokens at: 8) 321978 thisMonth: thisMonth 321979 thisYear: thisYear. 321980 321981 ^DirectoryEntry name: (tokens last) "file name" 321982 creationTime: dateInSeconds "creation date" 321983 modificationTime: dateInSeconds "modification time" 321984 isDirectory:( (tokens first first) = $d or: [tokens first first =$l]) "is-a-directory flag" 321985 fileSize: tokens fifth asNumber "file size" 321986! ! 321987 321988!ServerDirectory class methodsFor: 'misc' stamp: 'damiencassou 5/30/2008 15:52'! 321989secondsForDay: dayToken month: monthToken yearOrTime: ytToken thisMonth: thisMonth thisYear: thisYear 321990 | ftpDay ftpMonth pickAYear jDateToday trialJulianDate | 321991 ftpDay := dayToken asNumber. 321992 ftpMonth := Date indexOfMonth: monthToken. 321993 (ytToken includes: $:) ifFalse: 321994 [ ^ (Date 321995 newDay: ftpDay 321996 month: ftpMonth 321997 year: ytToken asNumber) asSeconds ]. 321998 jDateToday := Date today dayOfYear. 321999 trialJulianDate := (Date 322000 newDay: ftpDay 322001 month: ftpMonth 322002 year: thisYear) dayOfYear. 322003 322004 "Date has no year if within six months (do we need to check the day, too?)" 322005 322006 "Well it appear to be pickier than that... it isn't just 6 months or 6 months and the day of the month, put perhaps the julian date AND the time as well. I don't know what the precise standard is, but this seems to produce better results" 322007 pickAYear := jDateToday - trialJulianDate > 182 322008 ifTrue: [ thisYear + 1 "his clock could be ahead of ours??" ] 322009 ifFalse: 322010 [ pickAYear := trialJulianDate - jDateToday > 182 322011 ifTrue: [ thisYear - 1 ] 322012 ifFalse: [ thisYear ] ]. 322013 ^ (Date 322014 newDay: ftpDay 322015 month: ftpMonth 322016 year: pickAYear) asSeconds + (Time readFrom: ytToken readStream) asSeconds! ! 322017 322018 322019!ServerDirectory class methodsFor: 'server groups' stamp: 'mir 6/26/2001 12:26'! 322020convertGroupNames 322021 "ServerDirectory convertGroupNames" 322022 self servers do: [:each | each convertGroupName]! ! 322023 322024!ServerDirectory class methodsFor: 'server groups' stamp: 'mir 6/26/2001 12:11'! 322025groupNames 322026 "Return the names of all registered groups of servers, including individual servers not in any group." 322027 "ServerDirectory groupNames" 322028 | names | 322029 names := Set new. 322030 self servers do: [:server | 322031 names add: server groupName]. 322032 ^names asSortedArray 322033! ! 322034 322035!ServerDirectory class methodsFor: 'server groups' stamp: 'mir 6/26/2001 12:06'! 322036serverInGroupNamed: groupName 322037 "Return the first (available) server in the group of this name." 322038 322039 | servers | 322040 servers := self serversInGroupNamed: groupName. 322041 servers isEmpty 322042 ifTrue: [self error: 'No server found in group "' , groupName asString , '".']. 322043 ^servers first! ! 322044 322045!ServerDirectory class methodsFor: 'server groups' stamp: 'mir 6/26/2001 11:55'! 322046serversInGroupNamed: nameString 322047 "Return the servers in the group of this name." 322048 "ServerDirectory serversInGroupNamed: 'Squeak Public Updates' " 322049 322050 ^self servers values select: [:server | 322051 nameString = server groupName]. 322052! ! 322053 322054 322055!ServerDirectory class methodsFor: 'server prefs' stamp: 'sd 9/30/2003 13:58'! 322056determineLocalServerDirectory: directoryName 322057 "This is part of a workaround for Mac file name oddities regarding relative file names. 322058 The real fix should be in fullNameFor: but that seems to break other parts of the system." 322059 322060 | dirName | 322061 dirName := directoryName. 322062 (SmalltalkImage current platformName = 'Mac OS' 322063 and: [directoryName beginsWith: ':']) 322064 ifTrue: [ 322065 dirName := (FileDirectory default pathName endsWith: directoryName) 322066 ifTrue: [FileDirectory default pathName] 322067 ifFalse: [(FileDirectory default pathName , directoryName) replaceAll: '::' with: ':']]. 322068 ^FileDirectory default directoryNamed: dirName! ! 322069 322070!ServerDirectory class methodsFor: 'server prefs' stamp: 'stephane.ducasse 10/26/2008 17:09'! 322071fetchExternalSettingsIn: aDirectory 322072 "Scan for server configuration files" 322073 "ServerDirectory fetchExternalSettingsIn: (FileDirectory default directoryNamed: 'prefs')" 322074 322075 | serverConfDir stream | 322076 (aDirectory directoryExists: self serverConfDirectoryName) 322077 ifFalse: [^self]. 322078 serverConfDir := aDirectory directoryNamed: self serverConfDirectoryName. 322079 serverConfDir fileNames do: [:fileName | 322080 stream := serverConfDir readOnlyFileNamed: fileName. 322081 stream 322082 ifNotNil: [ 322083 [self parseServerEntryFrom: stream] ifError: [:err :rcvr | ]. 322084 stream close]]! ! 322085 322086!ServerDirectory class methodsFor: 'server prefs' stamp: 'stephane.ducasse 10/26/2008 17:14'! 322087parseServerEntryFrom: stream 322088 322089 | server type directory entries serverName | 322090 self flag: #etoyCleaningLeftToDo. 322091 entries := ExternalSettings parseServerEntryArgsFrom: stream. 322092 322093 serverName := entries at: 'name' ifAbsent: [^nil]. 322094 directory := entries at: 'directory' ifAbsent: [^nil]. 322095 type := entries at: 'type' ifAbsent: [^nil]. 322096 type = 'file' 322097 ifTrue: [ 322098 server := self determineLocalServerDirectory: directory. 322099 entries at: 'userListUrl' ifPresent:[:value | 322100 " I do not know what is userListUrl so I just comment that for etoy removal- stephane.ducasse." 322101 "server eToyUserListUrl: value" ]. 322102 entries at: 'baseFolderSpec' ifPresent:[:value | 322103 " I do not know what is userListUrl so I just comment that for etoy removal- stephane.ducasse." 322104 "server eToyBaseFolderSpec: value"]. 322105 ^ true]. 322106 type = 'http' 322107 ifTrue: [server := HTTPServerDirectory new type: #ftp]. 322108 type = 'ftp' 322109 ifTrue: [server := ServerDirectory new type: #ftp]. 322110 322111 server directory: directory. 322112 entries at: 'server' ifPresent: [:value | server server: value]. 322113 entries at: 'user' ifPresent: [:value | server user: value]. 322114 entries at: 'group' ifPresent: [:value | server groupName: value]. 322115 entries at: 'passwdseq' ifPresent: [:value | server passwordSequence: value asNumber]. 322116 entries at: 'url' ifPresent: [:value | server altUrl: value]. 322117 entries at: 'loaderUrl' ifPresent: [:value | server loaderUrl: value]. 322118 entries at: 'acceptsUploads' ifPresent: [:value | server acceptsUploads: value asLowercase = 'true']. 322119 entries at: 'userListUrl' ifPresent:[:value | server eToyUserListUrl: value]. 322120 entries at: 'encodingName' ifPresent:[:value | server encodingName: value]. 322121 ServerDirectory addServer: server named: serverName. 322122! ! 322123 322124!ServerDirectory class methodsFor: 'server prefs' stamp: 'stephane.ducasse 10/26/2008 17:09'! 322125releaseExternalSettings 322126 "Release for server configurations" 322127 "ServerDirectory releaseExternalSettings" 322128 322129 Preferences externalServerDefsOnly 322130 ifTrue: [ Servers := Dictionary new]! ! 322131 322132!ServerDirectory class methodsFor: 'server prefs' stamp: 'mir 5/24/2001 17:08'! 322133serverConfDirectoryName 322134 ^'knownServers'! ! 322135 322136!ServerDirectory class methodsFor: 'server prefs' stamp: 'stephane.ducasse 10/26/2008 17:13'! 322137storeCurrentServersIn: aDirectory 322138 322139 | file | 322140 self servers do: [:each | 322141 file := aDirectory fileNamed: (ServerDirectory nameForServer: each). 322142 each storeServerEntryOn: file. 322143 file close]. 322144 ! ! 322145ServerDirectory subclass: #ServerFile 322146 instanceVariableNames: 'fileName rwmode' 322147 classVariableNames: '' 322148 poolDictionaries: '' 322149 category: 'Network-RemoteDirectory'! 322150!ServerFile commentStamp: '<historical>' prior: 0! 322151Represents the non-data part of a file on a server on the internet. I am owned by a RemoteFileStream, who has the data. 322152 322153Since FileStream is a Stream and I am not, use this to always get a stream: 322154 xxx isStream ifFalse: [^ xxx asStream]. 322155 322156! 322157 322158 322159!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 2/23/2000 19:16'! 322160asStream 322161 "Return a RemoteFileStream (subclass of RWBinaryOrTextStream) on the contents of the remote file I represent. For reading only. This method is probably misnamed. Maybe call it makeStream" 322162 322163 ^ self readOnlyFileNamed: self fileName! ! 322164 322165!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 3/13/2000 16:53'! 322166directoryUrl 322167 | ru | 322168 "A url to the directory this file is in" 322169 322170 ru := self realUrl. 322171 ^ ru copyFrom: 1 to: (ru size - fileName size)! ! 322172 322173!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 13:12'! 322174exists 322175 "Return true if the file exists on the server already" 322176 322177 ^ self fileExists: fileName! ! 322178 322179!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 11/24/1998 15:01'! 322180fileName 322181 "should this be local or as in a url?" 322182 322183 urlObject ifNotNil: [^ urlObject path last]. "path last encodeForHTTP ?" 322184 ^ fileName! ! 322185 322186!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 11/24/1998 14:45'! 322187fileName: aString 322188 322189urlObject ~~ nil "type == #file" 322190 ifTrue: [urlObject path at: urlObject path size put: aString] 322191 ifFalse: [fileName := aString]! ! 322192 322193!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 11/23/1998 17:24'! 322194fileNameRelativeTo: aServerDir 322195 "Produce an absolute fileName from me and an absolute directory" 322196 urlObject isAbsolute ifFalse: [ 322197 (aServerDir urlObject ~~ nil and: [aServerDir urlObject isAbsolute]) 322198 ifTrue: [urlObject 322199 privateInitializeFromText: urlObject pathString 322200 relativeTo: aServerDir urlObject] 322201 ifFalse: [urlObject default]]. "relative to Squeak directory" 322202 ^ urlObject pathForDirectory, self fileName! ! 322203 322204!ServerFile methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:45'! 322205fullPath: serverAndDirectory 322206 "Parse and save a full path. Separate out fileName at the end." 322207 322208 | delim ii | 322209 super fullPath: serverAndDirectory. "set server and directory" 322210 self isTypeFile ifTrue: [ 322211 fileName := ''. 322212 ^ self 322213 ]. 322214 delim := self pathNameDelimiter. 322215 ii := directory findLast: [:c | c = delim]. 322216 ii = 0 322217 ifTrue: [self error: 'expecting directory and fileName'] 322218 ifFalse: [fileName := directory copyFrom: ii+1 to: directory size. 322219 directory := (directory copyFrom: 1 to: directory size - fileName size - 1)].! ! 322220 322221!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 4/13/2000 17:12'! 322222localName 322223 322224 ^ self fileName! ! 322225 322226!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 5/18/1998 16:42'! 322227readOnly 322228 "Set the receiver to be read-only" 322229 322230 rwmode := false! ! 322231 322232!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 13:35'! 322233readWrite 322234 "Set the receiver to be writable" 322235 322236 rwmode := true! ! 322237 322238!ServerFile methodsFor: 'as yet unclassified' stamp: 'fbs 2/2/2005 13:27'! 322239realUrl 322240 "a fully expanded version of the url we represent. Prefix the path with http: or ftp: or file:" 322241 322242 self isTypeFile ifTrue: [ 322243 self fileNameRelativeTo: self. 322244 ^ urlObject asString 322245 ]. 322246 ^ self typeWithDefault asString, '://', self pathName, '/', fileName "note difference!!" 322247 ! ! 322248 322249!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 13:35'! 322250writable 322251 ^ rwmode! ! 322252Object subclass: #ServiceAction 322253 instanceVariableNames: 'condition action requestor label shortLabel description id provider enabled' 322254 classVariableNames: '' 322255 poolDictionaries: '' 322256 category: 'Services-Base'! 322257!ServiceAction commentStamp: 'rr 7/10/2006 14:58' prior: 0! 322258ServiceAction are executable objects in various contexts. 322259They can be displayed as buttons or menu items or bounded to keyboard shortcuts. 322260 322261ServiceActions are defined in methods in an instance of a ServiceProvider class (in the 'services' method category), using the following template: 322262 322263serviceIdentifierAndMethodName 322264 ^ ServiceAction 322265 text: 'Menu item text' 322266 button: 'Button text' 322267 description: 'Longer text that appears in help balloons' 322268 action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"] 322269 322270or, alternatively: 322271 322272serviceIdentifierAndMethodName 322273 ^ ServiceAction 322274 text: 'Menu item text' 322275 button: 'Button text' 322276 description: 'Longer text that appears in help balloons' 322277 action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"] 322278 condition: [:r | "second block returning true if the service can be used at the time being, false otherwise. Data can still be fetched from the requestor instance"] 322279 322280The method name in which the service is defined becomes its identifier. To build the hierarchy of services and to assign them to shortcuts, you will need to type this names in the relevant fields of the Services Browser. 322281 322282Services are arranged in a hierarchy. and bound to keyboard shortcuts using the ServicesBrowser. 322283! 322284 322285 322286!ServiceAction methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 21:09'! 322287action: aBlock 322288 action := aBlock! ! 322289 322290!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/8/2006 09:10'! 322291buttonLabel 322292 ^ shortLabel 322293 ifNil: [self text] 322294 ifNotNil: [shortLabel ifEmpty: [self text] ifNotEmpty: [shortLabel]]! ! 322295 322296!ServiceAction methodsFor: 'accessing' stamp: 'rr 7/5/2005 17:34'! 322297buttonLabel: anObject 322298 shortLabel := anObject! ! 322299 322300!ServiceAction methodsFor: 'accessing' stamp: 'rr 10/23/2005 14:33'! 322301categories 322302 ^ ServiceRegistry current categories select: [:e | e services includes: self]! ! 322303 322304!ServiceAction methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 21:10'! 322305condition: aBlock 322306 condition := aBlock! ! 322307 322308!ServiceAction methodsFor: 'accessing' stamp: 'rr 1/9/2006 16:47'! 322309description 322310 322311 ^ description ifNil: [self text] ifNotNil: [description]! ! 322312 322313!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/17/2004 16:49'! 322314description: anObject 322315 description := anObject select: [:each | (each = Character cr) not] 322316 thenCollect: [:each | each = Character tab ifTrue: [Character space] 322317 ifFalse: [each]].! ! 322318 322319!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/2/2005 17:14'! 322320id 322321 ^id! ! 322322 322323!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/2/2005 17:15'! 322324id: aSymbol 322325 id := aSymbol! ! 322326 322327!ServiceAction methodsFor: 'accessing' stamp: 'rr 1/12/2006 17:55'! 322328menuLabel 322329 | l sh | 322330 l := self text. 322331 l size > 50 ifTrue: [l := (l first: 47), '...']. 322332 sh := self shortcut. 322333 sh := (sh isNil or: [sh isEmpty]) ifTrue: [''] ifFalse: [' (', sh, ')']. 322334 ^ l capitalized, sh! ! 322335 322336!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/14/2006 09:45'! 322337menuLabelNumbered: i 322338 | l sh str | 322339 l := self text. 322340 l size > 50 322341 ifTrue: [l := (l first: 47) 322342 , '...']. 322343 sh := self shortcut. 322344 sh := (sh isNil 322345 or: [sh isEmpty]) 322346 ifTrue: [''] 322347 ifFalse: [' (' , sh , ')']. 322348 str := i isZero ifTrue: [''] ifFalse: [i asString, '. ']. 322349 ^ str, l capitalized , sh! ! 322350 322351!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/8/2006 08:22'! 322352provider 322353 ^ provider 322354 ifNil: [nil] 322355 ifNotNil: [provider new]! ! 322356 322357!ServiceAction methodsFor: 'accessing' stamp: 'rr 1/12/2006 17:58'! 322358provider: p 322359 provider := p! ! 322360 322361!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/16/2004 20:59'! 322362requestor 322363 ^requestor! ! 322364 322365!ServiceAction methodsFor: 'accessing' stamp: 'rr 3/16/2004 20:59'! 322366requestor: anObject 322367 requestor := anObject! ! 322368 322369!ServiceAction methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 21:10'! 322370text 322371 ^label isBlock ifTrue: [label value: requestor] ifFalse: [label]! ! 322372 322373!ServiceAction methodsFor: 'accessing' stamp: 'rr 1/9/2006 14:52'! 322374text: aString 322375 label := aString! ! 322376 322377 322378!ServiceAction methodsFor: 'executing' stamp: 'rr 11/14/2005 11:11'! 322379condExecuteWith: aRequestor 322380 self requestor: aRequestor. 322381 self executeCondition 322382 ifTrue: [self execute] 322383 ifFalse: [Beeper beep]! ! 322384 322385!ServiceAction methodsFor: 'executing' stamp: 'rr 3/10/2006 14:26'! 322386execute 322387 ^ action clone valueWithRequestor: World topRequestor! ! 322388 322389!ServiceAction methodsFor: 'executing' stamp: 'rr 3/10/2006 14:26'! 322390executeCondition 322391 ^ [condition clone valueWithRequestor: World topRequestor] 322392 on: Error 322393 do: [false]! ! 322394 322395!ServiceAction methodsFor: 'executing' stamp: 'rr 1/22/2006 12:55'! 322396perform: selector orSendTo: otherTarget 322397 ^ self perform: selector! ! 322398 322399 322400!ServiceAction methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:21'! 322401initialize 322402 super initialize. 322403 self 322404 action: []. 322405 self 322406 condition: [true]. 322407 self text: 'no op'. 322408 self requestor: Requestor new. 322409 self id: #none. 322410 enabled := true! ! 322411 322412 322413!ServiceAction methodsFor: 'preferences' stamp: 'rr 1/12/2006 17:52'! 322414addPreference: name category: cat selector: sel 322415 322416 ServicePreferences 322417 addPreference: name 322418 categories: {cat asSymbol. self providerCategory} 322419 default: '' 322420 balloonHelp:self description 322421 projectLocal:false 322422 changeInformee: self id -> sel 322423 changeSelector: #serviceUpdate 322424 viewRegistry: PreferenceViewRegistry ofTextPreferences! ! 322425 322426!ServiceAction methodsFor: 'preferences' stamp: 'rr 3/10/2006 16:08'! 322427insertPreferences 322428 ServicePreferences 322429 addPreference: self id 322430 categories: (Array with: self providerCategory) 322431 default: true 322432 balloonHelp: self description 322433 projectLocal: false 322434 changeInformee: self id -> #updateEnable 322435 changeSelector: #serviceUpdate 322436 viewRegistry: PreferenceViewRegistry ofBooleanPreferences! ! 322437 322438!ServiceAction methodsFor: 'preferences' stamp: 'rr 1/9/2006 14:08'! 322439preferences 322440 ^ {ServicePreferences preferenceAt: self shortcutPreference} select: [:e | e notNil]! ! 322441 322442!ServiceAction methodsFor: 'preferences' stamp: 'rr 3/10/2006 16:00'! 322443providerCategory 322444 ^ provider name! ! 322445 322446!ServiceAction methodsFor: 'preferences' stamp: 'rr 1/9/2006 16:49'! 322447shortcut 322448 ^ ServicePreferences valueOfPreference: self shortcutPreference! ! 322449 322450!ServiceAction methodsFor: 'preferences' stamp: 'rr 12/30/2005 19:24'! 322451shortcutPreference 322452 ^ ('Shortcut for ', self id, ':') asSymbol! ! 322453 322454!ServiceAction methodsFor: 'preferences' stamp: 'rr 3/10/2006 16:10'! 322455updateEnable 322456 enabled := ServicePreferences 322457 valueOfPreference: self id 322458 ifAbsent: [true]! ! 322459 322460 322461!ServiceAction methodsFor: 'testing' stamp: 'rr 3/2/2005 11:12'! 322462isCategory 322463 ^ false! ! 322464 322465!ServiceAction methodsFor: 'testing' stamp: 'rr 3/10/2006 10:46'! 322466isEnabled 322467 ^ enabled! ! 322468 322469 322470!ServiceAction methodsFor: 'updating' stamp: 'rr 1/12/2006 18:16'! 322471updateShortcut 322472 (self systemNavigation allImplementorsOf: #processService:newShortcut:) 322473 do: [:ref | | cls | 322474 cls := ref actualClass. 322475 cls isMeta ifTrue: [cls soleInstance processService: self newShortcut: self shortcut]]. 322476 ServiceRegistry ifInteractiveDo: [self provider savePreferencesFor: self]! ! 322477 322478"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 322479 322480ServiceAction class 322481 instanceVariableNames: ''! 322482 322483!ServiceAction class methodsFor: 'initialization' stamp: 'rr 8/19/2005 14:31'! 322484initialize 322485 #( 322486 (inlineServicesInMenu true 'Inline the services the squeak menus') 322487 (useOnlyServicesInMenu false 'Use only services and not regular menu items') 322488 (useServicesInBrowserButtonBar false 'Use a service-based button bar')) 322489 do: [:tr | 322490 Preferences 322491 addPreference: tr first 322492 categories: #(#services) 322493 default: tr second 322494 balloonHelp: tr third] 322495 ! ! 322496 322497 322498!ServiceAction class methodsFor: 'instance creation' stamp: 'rr 3/2/2005 17:20'! 322499id: aSymbol text: aStringOrBlock button: buttonString description: aString action: aBlock 322500 ^ self id: aSymbol 322501 text: aStringOrBlock 322502 button: buttonString 322503 description: aString 322504 action: aBlock 322505 condition: [:r | true]! ! 322506 322507!ServiceAction class methodsFor: 'instance creation' stamp: 'rr 1/9/2006 15:11'! 322508id: aSymbol text: aStringOrBlock button: buttonString description: aString action: aBlock condition: cBlock 322509 ^ (self new) 322510 id: aSymbol; 322511 text: aStringOrBlock; 322512 buttonLabel: buttonString; 322513 description: aString; 322514 action: aBlock; 322515 condition: cBlock; 322516 yourself! ! 322517 322518!ServiceAction class methodsFor: 'instance creation' stamp: 'rr 5/24/2005 17:23'! 322519text: aStringOrBlock button: buttonString description: aString action: aBlock 322520 "use when id can be automatically generated" 322521 ^ self id: nil 322522 text: aStringOrBlock 322523 button: buttonString 322524 description: aString 322525 action: aBlock 322526 condition: [:r | true]! ! 322527 322528!ServiceAction class methodsFor: 'instance creation' stamp: 'rr 5/24/2005 17:26'! 322529text: aStringOrBlock button: buttonString description: aString action: aBlock condition: cBlock 322530 "use when id can be generated" 322531 ^ self 322532 id: nil 322533 text: aStringOrBlock 322534 button: buttonString 322535 description: aString 322536 action: aBlock 322537 condition: cBlock! ! 322538 322539!ServiceAction class methodsFor: 'instance creation' stamp: 'rr 5/24/2005 17:24'! 322540text: textString description: aString action: aBlock 322541 "use when id can be generated" 322542 ^ self id: nil text: textString button: textString description: aString action: aBlock! ! 322543PreferenceBrowserMorph subclass: #ServiceBrowserMorph 322544 instanceVariableNames: '' 322545 classVariableNames: '' 322546 poolDictionaries: '' 322547 category: 'Services-Base-GUI'! 322548!ServiceBrowserMorph commentStamp: 'rr 7/10/2006 15:28' prior: 0! 322549I subclass the PreferenceBrowserMorph to adapt the interface to services. So far the changes are minimal.! 322550 322551 322552!ServiceBrowserMorph methodsFor: 'as yet unclassified' stamp: 'rr 7/10/2006 15:26'! 322553newButtonRow 322554 ^BorderedMorph new 322555 color: Color transparent; 322556 cellInset: 2; 322557 layoutInset: 2; 322558 layoutPolicy: TableLayout new; 322559 listDirection: #leftToRight; 322560 listCentering: #topLeft; 322561 cellPositioning: #topLeft; 322562 on: #mouseEnter send: #paneTransition: to: self; 322563 on: #mouseLeave send: #paneTransition: to: self; 322564 "addMorphBack: self defaultButton; 322565 addMorphBack: self newSeparator; 322566 addMorphBack: self saveButton; 322567 addMorphBack: self loadButton; 322568 addMorphBack: self newSeparator; 322569 addMorphBack: self saveToDiskButton; 322570 addMorphBack: self loadFromDiskButton; 322571 addMorphBack: self newSeparator; 322572 addMorphBack: self newTransparentFiller; 322573 addMorphBack: self helpButton;" 322574 yourself.! ! 322575 322576"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 322577 322578ServiceBrowserMorph class 322579 instanceVariableNames: ''! 322580Warning subclass: #ServiceCancelled 322581 instanceVariableNames: '' 322582 classVariableNames: '' 322583 poolDictionaries: '' 322584 category: 'Services-Base'! 322585!ServiceCancelled commentStamp: 'rr 4/1/2004 18:24' prior: 0! 322586Exception raised when a service is cancelled, to inform the user.! 322587 322588 322589!ServiceCancelled methodsFor: 'as yet unclassified' stamp: 'rr 3/10/2006 17:04'! 322590defaultAction 322591 Transcript cr; show: 'service has been cancelled'! ! 322592 322593!ServiceCancelled methodsFor: 'as yet unclassified' stamp: 'rr 3/14/2004 19:14'! 322594messageText 322595 ^ 'Service has been cancelled'! ! 322596ServiceAction subclass: #ServiceCategory 322597 instanceVariableNames: 'services' 322598 classVariableNames: '' 322599 poolDictionaries: '' 322600 category: 'Services-Base'! 322601!ServiceCategory commentStamp: 'rr 7/10/2006 15:06' prior: 0! 322602I represent a category of services that can be added to a menu. 322603I can be displayed as a menu or button bar containing my services. 322604I am also a subclass of ServiceAction, so I can form a subcategory of another service category. 322605 322606Like services, I am created in methods of a ServiceProvider, in the 'services' method protocol. 322607The template to create a service category is the following: 322608 322609methodNameAndServiceCategoryId 322610 ^ ServiceCategory 322611 text: 'Menu text' 322612 button: 'Button text' 322613 description: 'Longer descriptive text appearing in help balloons' 322614 322615To put services in a service category, you have to use the Service Browser, located in the word menu, under the 'Preferences and Services' menu item. 322616In it, you can look up for the name of your category, and enter service identifiers as children 322617of the category in the associatedd text field, separating them with spaces.! 322618 322619 322620!ServiceCategory methodsFor: 'accessing' stamp: 'rr 3/10/2006 10:47'! 322621enabledServices 322622 ^ services 322623 select: [:e | e isEnabled]! ! 322624 322625!ServiceCategory methodsFor: 'accessing' stamp: 'rr 4/11/2005 17:22'! 322626requestor: aRequestor 322627 super requestor: aRequestor. 322628 self services do: [:s | s requestor: aRequestor]! ! 322629 322630!ServiceCategory methodsFor: 'accessing' stamp: 'rr 3/25/2004 20:43'! 322631services 322632 ^services! ! 322633 322634 322635!ServiceCategory methodsFor: 'executing' stamp: 'rr 10/14/2005 17:15'! 322636execute 322637 "displays the subservices as a submenu" 322638 ServiceGui openMenuFor: self! ! 322639 322640 322641!ServiceCategory methodsFor: 'initialization' stamp: 'rr 1/4/2006 16:12'! 322642initialize 322643 322644 services := OrderedCollection new. 322645 super initialize. 322646 322647! ! 322648 322649 322650!ServiceCategory methodsFor: 'preferences' stamp: 'rr 12/30/2005 19:24'! 322651childrenPreferences 322652 ^ ('Items in ', self id, ':') asSymbol! ! 322653 322654!ServiceCategory methodsFor: 'preferences' stamp: 'rr 1/16/2006 07:32'! 322655externalPreferences 322656 | p | 322657 p := ServicePreferences valueOfPreference: self childrenPreferences ifAbsent: ['']. 322658 ^ (p findTokens: ' ') collect: [:e | e service]! ! 322659 322660!ServiceCategory methodsFor: 'preferences' stamp: 'rr 3/10/2006 09:51'! 322661insertPreferences 322662 super insertPreferences. 322663 ServicePreferences 322664 addPreference: self childrenPreferences 322665 categories: { 322666 ('-- menu contents --' asSymbol). 322667 (self providerCategory)} 322668 default: '' 322669 balloonHelp: self description 322670 projectLocal: false 322671 changeInformee: self id -> #updateChildren 322672 changeSelector: #serviceUpdate 322673 viewRegistry: PreferenceViewRegistry ofTextPreferences! ! 322674 322675!ServiceCategory methodsFor: 'preferences' stamp: 'rr 1/19/2006 10:09'! 322676newChildren 322677 | s | 322678 s := ServicePreferences valueOfPreference: self childrenPreferences. 322679 ^ (s findTokens: ' ') collect: [:str | str serviceOrNil]! ! 322680 322681!ServiceCategory methodsFor: 'preferences' stamp: 'rr 1/19/2006 10:13'! 322682newChildrenValid 322683 | s | 322684 s := ServicePreferences valueOfPreference: self childrenPreferences. 322685 ^ (s findTokens: ' ') allSatisfy: [:str | 322686 str serviceOrNil 322687 ifNil: [ServiceRegistry ifInteractiveDo: 322688 [self inform: str, ' is not a valid service name']. 322689 false] 322690 ifNotNil: [true]]! ! 322691 322692!ServiceCategory methodsFor: 'preferences' stamp: 'rr 1/12/2006 18:10'! 322693prefServices 322694 | s | 322695 s := ServicePreferences valueOfPreference: self childrenPreferences. 322696 ^ (s findTokens: ' ') collect: [:str | str service]! ! 322697 322698!ServiceCategory methodsFor: 'preferences' stamp: 'marcus.denker 11/10/2008 10:04'! 322699replaceChildren 322700 ServiceRegistry ifInteractiveDo: [services 322701 do: [:s | s provider 322702 ifNotNil: [:p | p class removeSelector: (self id , s id) asSymbol]]]. 322703 services := self newChildren. 322704 services 322705 do: [:e | 322706 (ServicePreferences preferenceAt: e shortcutPreference) 322707 ifNotNil: [:p | p categoryList: {'-- keyboard shortcuts --'. self id asString}]. 322708 ServiceRegistry 322709 ifInteractiveDo: [self provider savePreferencesFor: self]]! ! 322710 322711!ServiceCategory methodsFor: 'preferences' stamp: 'rr 3/12/2006 15:13'! 322712updateChildren 322713 322714 self newChildrenValid 322715 ifTrue: [self replaceChildren]. 322716 "PreferenceBrowserMorph updateBrowsers." 322717 ServiceGui updateBar: self! ! 322718 322719 322720!ServiceCategory methodsFor: 'testing' stamp: 'rr 3/21/2004 18:25'! 322721isCategory 322722 ^ true! ! 322723 322724"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 322725 322726ServiceCategory class 322727 instanceVariableNames: ''! 322728 322729!ServiceCategory class methodsFor: 'instance creation' stamp: 'rr 5/24/2005 17:29'! 322730text: aStringOrBlock button: buttonString description: aString 322731 "use when id can be generated" 322732 ^ self id: nil text: aStringOrBlock button: buttonString description: aString action: [] ! ! 322733Object subclass: #ServiceGui 322734 instanceVariableNames: 'menu bar service n' 322735 classVariableNames: '' 322736 poolDictionaries: '' 322737 category: 'Services-Base-GUI'! 322738!ServiceGui commentStamp: 'rr 7/10/2006 15:29' prior: 0! 322739I abstract all the UI-related behaviors for the services framework. 322740In the future I could be changed to be compatible with ToolBuilder! 322741 322742 322743!ServiceGui methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/23/2009 13:22'! 322744styleBar: aBar 322745 aBar setNameTo: 'button bar'. 322746 aBar beSticky; 322747 hResizing: #spaceFill; 322748 wrapCentering: #center; 322749 cellPositioning: #leftCenter; 322750 clipSubmorphs: true; 322751 cellInset: 1; 322752 layoutInset: 0; 322753 color: Color transparent.! ! 322754 322755 322756!ServiceGui methodsFor: 'accessing' stamp: 'rr 7/5/2005 18:16'! 322757bar 322758 ^ bar! ! 322759 322760!ServiceGui methodsFor: 'accessing' stamp: 'rr 7/5/2005 18:50'! 322761menu 322762 ^ menu last! ! 322763 322764 322765!ServiceGui methodsFor: 'building' stamp: 'rr 7/8/2005 16:28'! 322766buildButtonBar 322767 bar := self buttonBarFor: service. 322768 self class registerBar: bar for: service. 322769 ^ bar! ! 322770 322771!ServiceGui methodsFor: 'building' stamp: 'rr 3/10/2006 16:39'! 322772inlineInMenu: aMenu 322773 ^ self class inlineServices 322774 ifTrue: [self inlineInMenu: aMenu for: service] 322775 ifFalse: [aMenu]! ! 322776 322777 322778!ServiceGui methodsFor: 'initialization' stamp: 'rr 3/8/2006 10:00'! 322779for: caller id: id 322780 service := id service. 322781 caller ifNotNil: [service requestor: caller requestor]! ! 322782 322783!ServiceGui methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:21'! 322784initialize 322785 super initialize. 322786 menu := OrderedCollection new. 322787 bar := AlignmentMorph newRow. 322788 n := OrderedCollection with: 0! ! 322789 322790 322791!ServiceGui methodsFor: 'serviceactions' stamp: 'rr 7/5/2005 18:59'! 322792buttonForAction: aService 322793 "see getstate for availability?" 322794 322795 | aButton | 322796 aButton := PluggableButtonMorph 322797 on: aService 322798 getState: nil 322799 action: #execute. 322800 self styleButton: aButton. 322801 aButton 322802 label: aService buttonLabel; 322803 setBalloonText: aService description. 322804 ^aButton! ! 322805 322806!ServiceGui methodsFor: 'serviceactions' stamp: 'rr 3/13/2006 23:16'! 322807menuItemForAction: aServiceAction 322808 "Returns a menuItem triggering self" 322809 self menu 322810 add: (aServiceAction menuLabelNumbered: self n) 322811 target: aServiceAction 322812 selector: #execute. 322813 self menu lastItem isEnabled: aServiceAction executeCondition. 322814 self menu balloonTextForLastItem: aServiceAction description! ! 322815 322816 322817!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/10/2006 10:47'! 322818buttonBarFor: aServiceCategory 322819 self styleBar: self bar. 322820 aServiceCategory enabledServices 322821 do: [:each | self bar 322822 addMorphBack: (self buttonFor: each)]. 322823 ^ self bar! ! 322824 322825!ServiceGui methodsFor: 'servicecategory' stamp: 'stephane.ducasse 4/13/2009 21:10'! 322826buttonForCategory: aService 322827 "see getstate for availability?" 322828 322829 | aButton | 322830 aButton := PluggableButtonMorph 322831 on: [:button | aService requestor: button requestor. 322832 self class openMenuFor: aService] 322833 getState: nil 322834 action: #value:. 322835 aButton arguments: (Array with: aButton). 322836 self styleButton: aButton. 322837 aButton 322838 label: aService buttonLabel. 322839 ^aButton! ! 322840 322841!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/10/2006 10:47'! 322842inlineInMenu: aMenu for: aServiceCategory 322843 menu addLast: aMenu. 322844 aServiceCategory enabledServices 322845 do: [:each | self menuItemFor: each]. 322846 ^ self popMenu! ! 322847 322848!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/10/2006 15:35'! 322849menuFor: aServiceCategory 322850 | submenu | 322851 submenu := self subMenuFor: aServiceCategory. 322852 ^ submenu 322853 addTitle: (aServiceCategory menuLabel)! ! 322854 322855!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/13/2006 23:16'! 322856menuItemForCategory: aServiceCategory 322857 "Returns a menuItem triggering self" 322858 | submenu | 322859 submenu := self subMenuFor: aServiceCategory. 322860 self menu add: (aServiceCategory menuLabelNumbered: self n) subMenu: submenu! ! 322861 322862!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/13/2006 23:15'! 322863n 322864 ^ n last! ! 322865 322866!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/13/2006 23:15'! 322867n: nn 322868 n removeLast. 322869 n addLast: nn! ! 322870 322871!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/13/2006 23:15'! 322872popMenu 322873 | aMenu | 322874 aMenu := menu removeLast. 322875 n removeLast. 322876 self styleMenu: aMenu. 322877 ^ aMenu! ! 322878 322879!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/13/2006 23:14'! 322880pushMenu 322881 menu addLast: MenuMorph new. 322882 n addLast: 0! ! 322883 322884!ServiceGui methodsFor: 'servicecategory' stamp: 'rr 3/13/2006 23:16'! 322885subMenuFor: aServiceCategory 322886 self pushMenu. 322887 aServiceCategory enabledServices 322888 ifEmpty: [self menuItemFor: ServiceAction new]. 322889 aServiceCategory enabledServices 322890 doWithIndex: [:each :i | self n: i. self menuItemFor: each]. 322891 ^ self popMenu! ! 322892 322893 322894!ServiceGui methodsFor: 'services' stamp: 'rr 7/6/2005 14:47'! 322895buttonFor: aService 322896 ^ aService isCategory ifTrue: [self buttonForCategory: aService] 322897 ifFalse: [self buttonForAction: aService]! ! 322898 322899!ServiceGui methodsFor: 'services' stamp: 'rr 1/7/2006 11:43'! 322900menuItemFor: aService 322901 [aService isCategory ifTrue: [self menuItemForCategory: aService] 322902 ifFalse: [self menuItemForAction: aService]] 322903 on: Error 322904 do: [:er | (self confirm: 'menuItemFor: error. debug?') ifTrue: [er signal]]! ! 322905 322906 322907!ServiceGui methodsFor: 'styling' stamp: 'rr 3/8/2006 14:29'! 322908styleButton: aButton 322909 aButton color: Color transparent; 322910 onColor: Color transparent offColor: Color transparent; 322911 322912 borderStyle: (BorderStyle width: 1 color: Color gray); 322913 askBeforeChanging: true; 322914 clipSubmorphs: true; 322915 hResizing: #spaceFill; 322916 vResizing: #spaceFill. 322917 ^ self! ! 322918 322919!ServiceGui methodsFor: 'styling' stamp: 'rr 3/12/2006 11:20'! 322920styleMenu: aMenu 322921 "gradient, etc ..?" 322922 "aMenu color: Color white; 322923 322924 borderStyle: (BorderStyle width: 1 color: Color gray); 322925 clipSubmorphs: true; 322926 addDropShadow; 322927 322928 shadowColor: (TranslucentColor 322929 r: 0.0 322930 g: 0.0 322931 b: 0.0 322932 alpha: 0.666); 322933 shadowOffset: 1 @ 1"! ! 322934 322935"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 322936 322937ServiceGui class 322938 instanceVariableNames: 'bars'! 322939 322940!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/10/2006 10:13'! 322941browserButtonRow: aBrowser 322942 ^ (self new for: aBrowser id: #browserButtonBar) buildButtonBar ! ! 322943 322944!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/9/2006 19:00'! 322945browser: b classCategoryMenu: aMenu 322946 ^ (self new for:b id:#browserClassCategoryMenu) inlineInMenu:aMenu! ! 322947 322948!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/9/2006 19:00'! 322949browser: b classMenu: aMenu 322950 ^ (self new for:b id:#browserClassMenu) inlineInMenu:aMenu! ! 322951 322952!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/9/2006 19:02'! 322953browser: b codePaneMenu: aMenu 322954 322955 ^(self new for: b id: #browserCodePaneMenu) inlineInMenu: aMenu! ! 322956 322957!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/9/2006 19:00'! 322958browser: b messageCategoryMenu: aMenu 322959 ^ (self new for:b id:#browserMethodCategoryMenu) inlineInMenu:aMenu! ! 322960 322961!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/9/2006 19:01'! 322962browser: b messageListMenu: aMenu 322963 ^ (self new for:b id:#browserMethodMenu) inlineInMenu:aMenu! ! 322964 322965!ServiceGui class methodsFor: 'hooks' stamp: 'rr 3/10/2006 16:42'! 322966browserButtonRow: aBrowser inlinedIn: row 322967 | bar | 322968 self buttonBarServices 322969 ifTrue: [bar := (self new for: aBrowser id: #browserButtonBar) buildButtonBar. 322970 row addMorphBack: bar]. 322971 ^ row! ! 322972 322973!ServiceGui class methodsFor: 'hooks' stamp: 'rr 1/9/2006 19:08'! 322974updateMenu: aMenu forModel: aModel selector: selector 322975 ('codePane*' match: selector) ifTrue: [ 322976 (self new for: aModel id: #codeSelectionRefactorings) inlineInMenu: aMenu]. 322977 ^ aMenu 322978 ! ! 322979 322980!ServiceGui class methodsFor: 'hooks' stamp: 'rr 8/19/2005 14:50'! 322981worldMenu: aMenu 322982 ^ (self new for: aMenu id: #world) inlineInMenu: aMenu! ! 322983 322984 322985!ServiceGui class methodsFor: 'opening menus' stamp: 'rr 7/6/2005 16:09'! 322986openMenuFor: aServiceCategory 322987 (self new menuFor: aServiceCategory) invokeModal! ! 322988 322989 322990!ServiceGui class methodsFor: 'preferences' stamp: 'rr 3/10/2006 16:38'! 322991buttonBarServices 322992 ^ ServicePreferences valueOfPreference: #useServicesInBrowserButtonBar ! ! 322993 322994!ServiceGui class methodsFor: 'preferences' stamp: 'rr 3/10/2006 16:37'! 322995inlineServices 322996 ^ ServicePreferences valueOfPreference: #inlineServicesInMenu ! ! 322997 322998!ServiceGui class methodsFor: 'preferences' stamp: 'rr 3/10/2006 16:38'! 322999onlyServices 323000 ^ ServicePreferences valueOfPreference: #useOnlyServicesInMenu! ! 323001 323002 323003!ServiceGui class methodsFor: 'registering button bars' stamp: 'rr 8/24/2005 12:01'! 323004bars 323005 ^ bars! ! 323006 323007!ServiceGui class methodsFor: 'registering button bars' stamp: 'rr 3/10/2006 16:49'! 323008initialize 323009 bars := OrderedCollection new. 323010 (TheWorldMenu respondsTo: #registerOpenCommand:) 323011 ifTrue: [TheWorldMenu unregisterOpenCommand: 'Services Browser'. 323012 TheWorldMenu registerOpenCommand: {'Services Browser'. {PreferenceBrowser. #openForServices}}]! ! 323013 323014!ServiceGui class methodsFor: 'registering button bars' stamp: 'rr 8/4/2005 15:02'! 323015registerBar: aBar for: service 323016 323017 self bars removeAllSuchThat: [:a | a value isNil]. 323018 self bars add: (WeakValueAssociation key: service value: aBar).! ! 323019 323020!ServiceGui class methodsFor: 'registering button bars' stamp: 'rr 1/12/2006 17:41'! 323021updateBars 323022 | cat newBar bar oldCat | 323023 self bars do: [:assoc | 323024 (bar := assoc value) ifNotNil: [ 323025 oldCat := assoc key. 323026 cat := oldCat id service. 323027 cat requestor: oldCat requestor. 323028 newBar := self new buttonBarFor: cat. 323029 bar removeAllMorphs. 323030 newBar submorphsDo: [:m | bar addMorphBack: m]]. 323031 ]! ! 323032 323033!ServiceGui class methodsFor: 'registering button bars' stamp: 'rr 1/10/2006 10:24'! 323034updateBar: cat 323035 | newBar | 323036 self bars 323037 select: [:assoc | (assoc key id = cat id) & assoc value notNil] 323038 thenDo: [:assoc | 323039 cat requestor: assoc key requestor. 323040 newBar := self new buttonBarFor: cat. 323041 assoc value removeAllMorphs. 323042 newBar submorphsDo: [:m | assoc value addMorphBack: m]]! ! 323043Preferences subclass: #ServicePreferences 323044 instanceVariableNames: '' 323045 classVariableNames: 'ServiceDictionaryOfPreferences' 323046 poolDictionaries: '' 323047 category: 'Services-Base-GUI'! 323048!ServicePreferences commentStamp: 'rr 7/10/2006 15:36' prior: 0! 323049I store the preferences related to the servicse framework. The preferences are editable via the Services Browser, based on Hernan Tylim's Preference Browser. 323050 323051The main preference categories for services are: 323052 323053-- keyboard shortcuts -- : several text preferences, one per keyboard shortcuts. To edit them, enter a service identifier (equal to the method name under which it is defined in its ServiceProvider), and accept with alt-s or enter 323054 323055-- menu contents -- : All the service categories in the image have a text preference under here. To edit it, enter the services identifiers you wish to put in this category, separating them with a single space character. The order is important: it defines the order of the items in menus. 323056 323057-- settings -- : general boolean preferences. 323058 323059Then there is a preference category for each provider in the image. Under each, you will find: 323060A boolean preference for each service in the image. If it is false, the service will not appear in menus. 323061The text preference for each service category defined by the service provider. This is the same as the one appearing in the menu contents preference category.! 323062 323063 323064"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 323065 323066ServicePreferences class 323067 instanceVariableNames: ''! 323068 323069!ServicePreferences class methodsFor: 'accessing' stamp: 'rr 10/11/2005 15:10'! 323070compileAccessMethodForPreference: aPreference 323071 "do nothing"! ! 323072 323073!ServicePreferences class methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:18'! 323074dictionaryOfPreferences 323075 ServiceDictionaryOfPreferences 323076 ifNil: [ServiceDictionaryOfPreferences := IdentityDictionary new]. 323077 ^ ServiceDictionaryOfPreferences ! ! 323078 323079!ServicePreferences class methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:18'! 323080dictionaryOfPreferences: aDictionary 323081 ServiceDictionaryOfPreferences := aDictionary! ! 323082 323083!ServicePreferences class methodsFor: 'accessing' stamp: 'rr 10/1/2005 15:22'! 323084wipe 323085 self dictionaryOfPreferences: nil! ! 323086 323087 323088!ServicePreferences class methodsFor: 'replaying' stamp: 'rr 3/12/2006 15:10'! 323089replayPreferences: preferences 323090 | s v | 323091 s := SortedCollection new 323092 sortBlock: [:a :b | a last < b last]. 323093 s addAll: preferences; 323094 reSort. 323095 s 323096 do: [:e | 323097 v := self valueOfPreference: e first ifAbsent: ''. 323098 self setPreference: e first toValue: (v 323099 ifEmpty: [''] 323100 ifNotEmpty: [v , ' ']) 323101 , e second]! ! 323102Object subclass: #ServiceProvider 323103 instanceVariableNames: '' 323104 classVariableNames: '' 323105 poolDictionaries: '' 323106 category: 'Services-Base'! 323107!ServiceProvider commentStamp: 'rr 7/10/2006 15:08' prior: 0! 323108A ServiceProvider references services that are relevant to a given application. 323109 323110Each application that wishes to use the Services framework must subclass a ServiceProvider. 323111This class must define a 'services' method category. 323112Each method implemented in this category will be automatically called by the framework. 323113Each of these method should be a unary message (taking no argument), and return a fully initialised instance of ServiceAction or ServiceCategory. There are three possible patterns: 323114 3231151) 323116 323117serviceIdentifierAndMethodName 323118 ^ ServiceAction 323119 text: 'Menu item text' 323120 button: 'Button text' 323121 description: 'Longer text that appears in help balloons' 323122 action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"] 323123 323124 3231252) 323126 323127serviceIdentifierAndMethodName 323128 ^ ServiceAction 323129 text: 'Menu item text' 323130 button: 'Button text' 323131 description: 'Longer text that appears in help balloons' 323132 action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"] 323133 condition: [:r | "second block returning true if the service can be used at the time being, false otherwise. Data can still be fetched from the requestor instance"] 323134 3231353) 323136 323137methodNameAndServiceCategoryId 323138 ^ ServiceCategory 323139 text: 'Menu text' 323140 button: 'Button text' 323141 description: 'Longer descriptive text appearing in help balloons' 323142 323143 323144The organisation of services into categories, and the services bound to keyboard shortcuts are 323145specified using the Services Browser (see the comment on the class ServicesPreferences for more details). When editing preferences, they are saved as methods on the ServiceProvider, all defined 323146in the 'saved preferences' method category. Each of thesse methods stores preferences that the provider can replay. 323147! 323148 323149 323150!ServiceProvider methodsFor: 'accessing' stamp: 'rr 8/2/2005 17:33'! 323151performAndSetId: aSymbol 323152 | service | 323153 service := self perform: aSymbol. 323154 service id: aSymbol. 323155 ^service! ! 323156 323157!ServiceProvider methodsFor: 'accessing' stamp: 'rr 1/9/2006 14:23'! 323158registeredServices 323159 323160 ^ self services collect: [:each | self performAndSetId: each]! ! 323161 323162!ServiceProvider methodsFor: 'accessing' stamp: 'rr 1/9/2006 14:23'! 323163services 323164 ^ self class organization listAtCategoryNamed: #services! ! 323165 323166 323167!ServiceProvider methodsFor: 'persistence' stamp: 'rr 1/10/2006 09:22'! 323168replayPreferences 323169 ServicePreferences replayPreferences: self savedPreferences! ! 323170 323171!ServiceProvider methodsFor: 'persistence' stamp: 'rr 1/11/2006 16:11'! 323172savedPreferences 323173 ^ (self class organization listAtCategoryNamed: #'saved preferences') 323174 collect: [:e | self perform: e]! ! 323175 323176!ServiceProvider methodsFor: 'persistence' stamp: 'rr 3/10/2006 15:04'! 323177savePreferencesFor: aService 323178 | strm | 323179 "pref := ServicePreferences preferenceAt: aService shortcutPreference. 323180 strm := WriteStream with: ''. 323181 strm nextPutAll: aService id; 323182 nextPutAll: 'shortcut'; 323183 cr; 323184 tab; 323185 nextPutAll: '^ '; 323186 nextPutAll: {pref name. pref preferenceValue. 1000} storeString. 323187 self class compileSilently: strm contents classified: 'saved preferences'." 323188 aService isCategory 323189 ifTrue: [aService externalPreferences 323190 doWithIndex: [:e :i | 323191 strm := WriteStream with: aService id asString. 323192 strm nextPutAll: e id asString; 323193 cr; 323194 tab; 323195 nextPutAll: '^ '; 323196 nextPutAll: {aService childrenPreferences. e id. i} storeString. 323197 e provider class compileSilently: strm contents classified: 'saved preferences']]! ! 323198 323199"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 323200 323201ServiceProvider class 323202 instanceVariableNames: ''! 323203 323204!ServiceProvider class methodsFor: 'accessing' stamp: 'rr 1/9/2006 14:20'! 323205registeredProviders 323206 ^ self allSubclasses collect: [:each | each new]! ! 323207 323208 323209!ServiceProvider class methodsFor: 'provider creation' stamp: 'rr 1/10/2006 10:41'! 323210newProviderFor: packageName 323211 | cls clsName | 323212 clsName := ((packageName copyWithout: $-) , 'ServiceProvider') asSymbol. 323213 cls := self subclass: clsName 323214 instanceVariableNames: '' 323215 classVariableNames: '' 323216 poolDictionaries: '' 323217 category: packageName. 323218 cls class compile: 'initialize 323219 ServiceRegistry buildProvider: self new' classified: 'initialization'. 323220 ^ cls! ! 323221Object subclass: #ServiceRegistry 323222 instanceVariableNames: 'services interactive' 323223 classVariableNames: 'Current' 323224 poolDictionaries: '' 323225 category: 'Services-Base'! 323226!ServiceRegistry commentStamp: 'rr 7/10/2006 15:10' prior: 0! 323227The ServiceRegistry is the repository in which services are stored. They are stored in 323228a dictionary, and keyed by their identifier (which is the name of the method they were defined in). 323229 323230The registry handles the intialization, building and referencing processes as well.! 323231 323232 323233!ServiceRegistry methodsFor: 'accessing' stamp: 'rr 3/2/2005 11:19'! 323234categories 323235 ^ self serviceCollection select: [:s | s isCategory]! ! 323236 323237!ServiceRegistry methodsFor: 'accessing' stamp: 'rr 10/20/2005 18:45'! 323238isInteractive 323239 ^ interactive! ! 323240 323241!ServiceRegistry methodsFor: 'accessing' stamp: 'rr 3/2/2005 11:18'! 323242serviceCollection 323243 ^ services asArray! ! 323244 323245!ServiceRegistry methodsFor: 'accessing' stamp: 'rr 3/2/2005 11:26'! 323246services 323247 ^ self serviceCollection reject: [:s | s isCategory]! ! 323248 323249!ServiceRegistry methodsFor: 'accessing' stamp: 'rr 1/16/2006 07:36'! 323250serviceWithId: aSymbol 323251 ^ services at: aSymbol 323252 ifAbsent: [nil]! ! 323253 323254 323255!ServiceRegistry methodsFor: 'building' stamp: 'rr 1/11/2006 16:37'! 323256addService: aService provider: p 323257 services at:aService id put:aService. 323258 aService provider: p. 323259 aService insertPreferences 323260! ! 323261 323262!ServiceRegistry methodsFor: 'building' stamp: 'rr 1/10/2006 12:10'! 323263beNotInteractiveDuring: aBlock 323264 interactive := false. 323265 aBlock value. 323266 interactive := true! ! 323267 323268!ServiceRegistry methodsFor: 'building' stamp: 'rr 5/17/2006 16:02'! 323269build 323270 "ServicePreferences wipe." 323271 | pr | 323272 self 323273 beNotInteractiveDuring: [ServiceProvider registeredProviders 323274 do: [:p | p registeredServices 323275 do: [:each | self addService: each provider: p class]]. 323276 pr := ServiceProvider registeredProviders 323277 gather: [:p | p savedPreferences]. 323278 ServicePreferences replayPreferences: pr. 323279 ]. 323280 ServiceGui updateBars. 323281 ServiceShortcuts setPreferences! ! 323282 323283!ServiceRegistry methodsFor: 'building' stamp: 'rr 1/11/2006 16:38'! 323284buildProvider: p 323285 self beNotInteractiveDuring: [ 323286 p registeredServices do: [:each | self addService: each provider: p class]. 323287 p replayPreferences] 323288 ! ! 323289 323290 323291!ServiceRegistry methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:21'! 323292initialize 323293 super initialize. 323294 services := Dictionary new. 323295 interactive := true! ! 323296 323297"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 323298 323299ServiceRegistry class 323300 instanceVariableNames: ''! 323301 323302!ServiceRegistry class methodsFor: 'as yet unclassified' stamp: 'rr 1/10/2006 13:00'! 323303current 323304 ^ Current ifNil: [Current := self new]! ! 323305 323306!ServiceRegistry class methodsFor: 'as yet unclassified' stamp: 'rr 1/12/2006 12:48'! 323307ifInteractiveDo: aBlock 323308 self current isInteractive ifTrue: [aBlock value]! ! 323309 323310!ServiceRegistry class methodsFor: 'as yet unclassified' stamp: 'rr 1/10/2006 13:01'! 323311initialize 323312 323313 self rebuild. 323314 SystemChangeNotifier uniqueInstance 323315 notify: self 323316 ofSystemChangesOfItem: #method 323317 using: #methodChanged: 323318 ! ! 323319 323320!ServiceRegistry class methodsFor: 'as yet unclassified' stamp: 'rr 1/12/2006 12:35'! 323321methodChanged: event 323322 | cls | 323323 self ifInteractiveDo: [ 323324 cls := event itemClass. 323325 ((event changeKind = #removed) not & (cls inheritsFrom: ServiceProvider) and: [cls new services includes: event itemSelector]) 323326 ifTrue: [[self current addService: (cls new performAndSetId: event itemSelector) 323327 provider: cls] 323328 on: Error do: [self inform: 'Service format seems to be incorrect']]]! ! 323329 323330!ServiceRegistry class methodsFor: 'as yet unclassified' stamp: 'rr 3/12/2006 15:19'! 323331rebuild 323332 | old | 323333 old := Current. 323334 [Current := self new. 323335 Current build] 323336 on: Error 323337 do: [:err | (self confirm: 'An error occured during build. 323338 Debug it?') 323339 ifTrue: [err signal]. 323340 Current := old]! ! 323341Object subclass: #ServiceShortcuts 323342 instanceVariableNames: '' 323343 classVariableNames: '' 323344 poolDictionaries: '' 323345 category: 'Services-Base'! 323346!ServiceShortcuts commentStamp: 'rr 7/10/2006 15:14' prior: 0! 323347A data structures implementing a simple form of keyboard shortucts is defined on the class side. 323348 323349Available keyboard shortcuts are: 323350 323351command-0 to command-9 (command is also called alt on some systems). 323352control-0 to control-0 323353command-control-0 to command-control-9 (command is also alt) 323354control-command-left arrow 323355control-command-up arrow 323356control-command-right arrow 323357control-command-down arrow 323358 323359Using the Services Browser (see class ServicePreferences), these shortcuts can be bound to service identifiers.! 323360 323361 323362"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 323363 323364ServiceShortcuts class 323365 instanceVariableNames: 'map'! 323366 323367!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 323368arrowShortcut: str event: event 323369 | key s | 323370 key := event keyCharacter caseOf: { 323371 [Character arrowDown] -> ['down']. 323372 [Character arrowUp] -> ['up']. 323373 [Character arrowLeft] -> ['left']. 323374 [Character arrowRight] -> ['right']}. 323375 s := self map 323376 at: str , key 323377 ifAbsent: [^ self]. 323378 s serviceOrNil 323379 ifNotNil: [:sv | sv execute. 323380 event wasHandled: true]! ! 323381 323382!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'nice 2/27/2008 21:49'! 323383changeShortcut: shortcut to: aString 323384 aString isBlock ifTrue: [^self map at: shortcut put: aString]. 323385 (aString beginsWith: '[') ifTrue: [^self map at: shortcut put: aString]. 323386 aString isEmpty ifTrue: [self map removeKey: shortcut ifAbsent: []] 323387 ifFalse: [self map at: shortcut put: aString]! ! 323388 323389!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'rr 3/10/2006 14:20'! 323390handleKeystroke: event 323391 [event isKeystroke 323392 ifTrue: [self process: event]] 323393 on: Error 323394 do: [:e | (self confirm: 'shortcut error. debug?') ifTrue: [e signal]]! ! 323395 323396!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'stephane.ducasse 4/13/2009 21:10'! 323397insertPrefShortcut: short 323398 ServicePreferences 323399 addPreference: short 323400 categories: #('-- keyboard shortcuts --' ) 323401 default: '' 323402 balloonHelp: 'enter a service id to bind it to this shortcut' 323403 projectLocal: false 323404 changeInformee: [self 323405 changeShortcut: short 323406 to: (ServicePreferences valueOfPreference: short)] 323407 changeSelector: #value 323408 viewRegistry: PreferenceViewRegistry ofTextPreferences! ! 323409 323410!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'rr 3/9/2006 16:31'! 323411map 323412 ^ map ifNil: [map := Dictionary new]! ! 323413 323414!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'rr 3/11/2006 19:04'! 323415process: event 323416 event keyCharacter isDigit 323417 ifTrue: [event commandKeyPressed & event controlKeyPressed 323418 ifTrue: [^ self shortcut: 'ctrl-cmd-' event: event]. 323419 event commandKeyPressed 323420 ifTrue: [^ self shortcut: 'cmd-' event: event]. 323421 event controlKeyPressed 323422 ifTrue: [^ self shortcut: 'ctrl-' event: event]]. 323423 ({Character arrowUp. Character arrowDown. Character arrowLeft. Character arrowRight} includes: event keyCharacter) 323424 ifTrue: [event commandKeyPressed & event controlKeyPressed 323425 ifTrue: [^ self arrowShortcut: 'ctrl-cmd-' event: event]. 323426 ]! ! 323427 323428!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'rr 3/11/2006 19:05'! 323429setPreferences 323430 | mm | 323431 mm := self map copy. 323432 (0 to: 9) 323433 do: [:i | #('ctrl-' 'cmd-' 'ctrl-cmd-' ) 323434 do: [:str | 323435 | short | 323436 short := (str , i asString) asSymbol. 323437 self insertPrefShortcut: short]]. 323438 #(#up #down #left #right ) 323439 do: [:s | 323440 self insertPrefShortcut: ('ctrl-cmd-' , s) asSymbol.]. 323441 mm 323442 keysAndValuesDo: [:k :v | ServicePreferences setPreference: k toValue: v]. 323443 ((Array new: 3) at: 1 put: ((Array new: 3) at: 1 put: #inlineServicesInMenu; 323444 at: 2 put: true; 323445 at: 3 put: 'Inline the services the squeak menus'; 323446 yourself); 323447 at: 2 put: ((Array new: 3) at: 1 put: #useOnlyServicesInMenu; 323448 at: 2 put: false; 323449 at: 3 put: 'Use only services and not regular menu items'; 323450 yourself); 323451 at: 3 put: ((Array new: 3) at: 1 put: #useServicesInBrowserButtonBar; 323452 at: 2 put: true; 323453 at: 3 put: 'Use a service-based button bar'; 323454 yourself); 323455 yourself) 323456 do: [:tr | ServicePreferences 323457 addPreference: tr first 323458 categories: #('-- settings --' ) 323459 default: tr second 323460 balloonHelp: tr third]! ! 323461 323462!ServiceShortcuts class methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! 323463shortcut: str event: event 323464 | s | 323465 Transcript cr. 323466 s := self map 323467 at: str , event keyCharacter asString 323468 ifAbsent: [^ self]. 323469 (s beginsWith: '[') ifTrue: [^ (Compiler evaluateUnloggedForSelf: s) value]. 323470 s serviceOrNil 323471 ifNotNil: [:sv | sv execute. 323472 event wasHandled: true]! ! 323473Collection subclass: #Set 323474 instanceVariableNames: 'tally array' 323475 classVariableNames: '' 323476 poolDictionaries: '' 323477 category: 'Collections-Unordered'! 323478!Set commentStamp: '<historical>' prior: 0! 323479I represent a set of objects without duplicates. I can hold anything that responds to 323480#hash and #=, except for nil. My instances will automatically grow, if necessary, 323481Note that I rely on #=, not #==. If you want a set using #==, use IdentitySet. 323482 323483Instance structure: 323484 323485 array An array whose non-nil elements are the elements of the set, 323486 and whose nil elements are empty slots. There is always at least one nil. 323487 In fact I try to keep my "load" at 75% or less so that hashing will work well. 323488 323489 tally The number of elements in the set. The array size is always greater than this. 323490 323491The core operation is #findElementOrNil:, which either finds the position where an 323492object is stored in array, if it is present, or finds a suitable position holding nil, if 323493its argument is not present in array,! 323494 323495 323496!Set methodsFor: '*tools-inspector' stamp: 'ar 9/27/2005 18:33'! 323497inspectorClass 323498 "Answer the class of the inspector to be used on the receiver. Called by inspect; 323499 use basicInspect to get a normal (less useful) type of inspector." 323500 323501 ^ SetInspector! ! 323502 323503 323504!Set methodsFor: 'accessing' stamp: 'md 7/31/2005 08:56'! 323505atRandom: aGenerator 323506 "Answer a random element of the receiver. Uses aGenerator which 323507 should be kept by the user in a variable and used every time. Use 323508 this instead of #atRandom for better uniformity of random numbers because 323509 only you use the generator. Causes an error if self has no elements." 323510 | rand | 323511 323512 self emptyCheck. 323513 rand := aGenerator nextInt: self size. 323514 self doWithIndex:[:each :ind | 323515 ind == rand ifTrue:[^each]]. 323516 ^ self errorEmptyCollection 323517! ! 323518 323519!Set methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:40'! 323520capacity 323521 "Answer the current capacity of the receiver." 323522 323523 ^ array size! ! 323524 323525!Set methodsFor: 'accessing' stamp: 'SqR 8/23/2000 13:51'! 323526like: anObject 323527 "Answer an object in the receiver that is equal to anObject, 323528 nil if no such object is found. Relies heavily on hash properties" 323529 323530 | index | 323531 323532 ^(index := self scanFor: anObject) = 0 323533 ifFalse: [array at: index]! ! 323534 323535!Set methodsFor: 'accessing'! 323536size 323537 ^ tally! ! 323538 323539!Set methodsFor: 'accessing' stamp: 'sma 5/12/2000 14:34'! 323540someElement 323541 "Deprecated. Use anyOne." 323542 323543 ^ self anyOne! ! 323544 323545 323546!Set methodsFor: 'adding' stamp: 'sma 5/12/2000 17:28'! 323547add: newObject 323548 "Include newObject as one of the receiver's elements, but only if 323549 not already present. Answer newObject." 323550 323551 | index | 323552 newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element']. 323553 index := self findElementOrNil: newObject. 323554 (array at: index) ifNil: [self atNewIndex: index put: newObject]. 323555 ^ newObject! ! 323556 323557!Set methodsFor: 'adding' stamp: 'sma 5/12/2000 17:29'! 323558add: newObject withOccurrences: anInteger 323559 ^ self add: newObject! ! 323560 323561 323562!Set methodsFor: 'converting' stamp: 'ar 11/20/1998 16:34'! 323563asSet 323564 ^self! ! 323565 323566 323567!Set methodsFor: 'copying' stamp: 'sma 5/12/2000 14:54'! 323568copy 323569 ^ self shallowCopy withArray: array shallowCopy! ! 323570 323571!Set methodsFor: 'copying' stamp: 'nice 5/22/2008 14:56'! 323572copyEmpty 323573 "Answer an empty copy of this collection" 323574 323575 "Note: this code could be moved to super" 323576 323577 ^self species new! ! 323578 323579 323580!Set methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:49'! 323581collect: aBlock 323582 "Evaluate aBlock with each of the receiver's elements as the argument. 323583 Collect the resulting values into a collection like the receiver. Answer 323584 the new collection." 323585 323586 | newSet | 323587 newSet := Set new: self size. 323588 array do: [:each | each ifNotNil: [newSet add: (aBlock value: each)]]. 323589 ^ newSet! ! 323590 323591!Set methodsFor: 'enumerating' stamp: 'sma 5/12/2000 14:36'! 323592do: aBlock 323593 tally = 0 ifTrue: [^ self]. 323594 1 to: array size do: 323595 [:index | 323596 | each | 323597 (each := array at: index) ifNotNil: [aBlock value: each]]! ! 323598 323599!Set methodsFor: 'enumerating'! 323600doWithIndex: aBlock2 323601 "Support Set enumeration with a counter, even though not ordered" 323602 | index | 323603 index := 0. 323604 self do: [:item | aBlock2 value: item value: (index := index+1)]! ! 323605 323606!Set methodsFor: 'enumerating' stamp: 'nice 5/22/2008 14:56'! 323607select: aBlock 323608 "Use copyEmpty instead of self species new to give subclasses a chance to initialize additional inst vars." 323609 323610 "Note: this code could be moved to super" 323611 323612 | newCollection | 323613 newCollection := self copyEmpty. 323614 self do: [:each | (aBlock value: each) ifTrue: [newCollection add: each]]. 323615 ^newCollection! ! 323616 323617!Set methodsFor: 'enumerating' stamp: 'jcg 6/7/2003 02:01'! 323618union: aCollection 323619 "Answer the set theoretic union of the receiver and aCollection, using the receiver's notion of equality and not side effecting the receiver at all." 323620 323621 ^ self copy addAll: aCollection; yourself 323622 323623! ! 323624 323625 323626!Set methodsFor: 'explorer' stamp: 'yo 8/27/2008 23:09'! 323627hasContentsInExplorer 323628 323629 ^self notEmpty! ! 323630 323631 323632!Set methodsFor: 'objects from disk' stamp: 'tk 4/8/1999 13:05'! 323633comeFullyUpOnReload: smartRefStream 323634 "Symbols have new hashes in this image." 323635 323636 self rehash. 323637 "^ self" 323638! ! 323639 323640 323641!Set methodsFor: 'removing' stamp: 'sma 5/12/2000 14:45'! 323642copyWithout: oldElement 323643 "Answer a copy of the receiver that does not contain any 323644 elements equal to oldElement." 323645 323646 ^ self copy 323647 remove: oldElement ifAbsent: []; 323648 yourself! ! 323649 323650!Set methodsFor: 'removing'! 323651remove: oldObject ifAbsent: aBlock 323652 323653 | index | 323654 index := self findElementOrNil: oldObject. 323655 (array at: index) == nil ifTrue: [ ^ aBlock value ]. 323656 array at: index put: nil. 323657 tally := tally - 1. 323658 self fixCollisionsFrom: index. 323659 ^ oldObject! ! 323660 323661!Set methodsFor: 'removing' stamp: 'nice 12/30/2008 18:46'! 323662removeAll 323663 "remove all elements from this collection. 323664 Preserve the capacity" 323665 323666 self initialize: self capacity! ! 323667 323668 323669!Set methodsFor: 'testing' stamp: 'tk 11/8/2001 15:35'! 323670= aSet 323671 self == aSet ifTrue: [^ true]. "stop recursion" 323672 (aSet isKindOf: Set) ifFalse: [^ false]. 323673 self size = aSet size ifFalse: [^ false]. 323674 self do: [:each | (aSet includes: each) ifFalse: [^ false]]. 323675 ^ true! ! 323676 323677!Set methodsFor: 'testing'! 323678includes: anObject 323679 ^ (array at: (self findElementOrNil: anObject)) ~~ nil! ! 323680 323681!Set methodsFor: 'testing' stamp: 'sma 5/12/2000 14:46'! 323682occurrencesOf: anObject 323683 ^ (self includes: anObject) ifTrue: [1] ifFalse: [0]! ! 323684 323685 323686!Set methodsFor: 'private'! 323687array 323688 ^ array! ! 323689 323690!Set methodsFor: 'private'! 323691atNewIndex: index put: anObject 323692 array at: index put: anObject. 323693 tally := tally + 1. 323694 self fullCheck! ! 323695 323696!Set methodsFor: 'private' stamp: 'SqR 8/23/2000 14:39'! 323697findElementOrNil: anObject 323698 "Answer the index of a first slot containing either a nil (indicating an empty slot) or an element that matches the given object. Answer the index of that slot or zero. Fail if neither a match nor an empty slot is found." 323699 323700 | index | 323701 323702 index := self scanFor: anObject. 323703 index > 0 ifTrue: [^index]. 323704 323705 "Bad scene. Neither have we found a matching element 323706 nor even an empty slot. No hashed set is ever supposed to get 323707 completely full." 323708 self error: 'There is no free space in this set!!'.! ! 323709 323710!Set methodsFor: 'private' stamp: 'SqR 8/23/2000 14:28'! 323711fixCollisionsFrom: index 323712 "The element at index has been removed and replaced by nil. 323713 This method moves forward from there, relocating any entries 323714 that had been placed below due to collisions with this one" 323715 323716 | length oldIndex newIndex element | 323717 323718 oldIndex := index. 323719 length := array size. 323720 [oldIndex = length 323721 ifTrue: [oldIndex := 1] 323722 ifFalse: [oldIndex := oldIndex + 1]. 323723 (element := self keyAt: oldIndex) == nil] 323724 whileFalse: 323725 [newIndex := self findElementOrNil: element. 323726 oldIndex = newIndex ifFalse: [self swap: oldIndex with: newIndex]]! ! 323727 323728!Set methodsFor: 'private' stamp: 'di 11/4/97 20:11'! 323729fullCheck 323730 "Keep array at least 1/4 free for decent hash behavior" 323731 array size - tally < (array size // 4 max: 1) 323732 ifTrue: [self grow]! ! 323733 323734!Set methodsFor: 'private'! 323735grow 323736 "Grow the elements array and reinsert the old elements" 323737 | oldElements | 323738 oldElements := array. 323739 array := Array new: array size + self growSize. 323740 tally := 0. 323741 oldElements do: 323742 [:each | each == nil ifFalse: [self noCheckAdd: each]]! ! 323743 323744!Set methodsFor: 'private'! 323745growSize 323746 ^ array size max: 2! ! 323747 323748!Set methodsFor: 'private' stamp: 'nice 4/4/2006 22:09'! 323749initialize: n 323750 "Initialize array to an array size of n" 323751 array := Array new: n. 323752 tally := 0! ! 323753 323754!Set methodsFor: 'private'! 323755keyAt: index 323756 "May be overridden by subclasses so that fixCollisions will work" 323757 ^ array at: index! ! 323758 323759!Set methodsFor: 'private'! 323760noCheckAdd: anObject 323761 array at: (self findElementOrNil: anObject) put: anObject. 323762 tally := tally + 1! ! 323763 323764!Set methodsFor: 'private'! 323765rehash 323766 | newSelf | 323767 newSelf := self species new: self size. 323768 self do: [:each | newSelf noCheckAdd: each]. 323769 array := newSelf array! ! 323770 323771!Set methodsFor: 'private' stamp: 'md 10/5/2005 15:44'! 323772scanFor: anObject 323773 "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 323774 | element start finish | 323775 finish := array size. 323776 start := (anObject hash \\ finish) + 1. 323777 323778 "Search from (hash mod size) to the end." 323779 start to: finish do: 323780 [:index | ((element := array at: index) == nil or: [element = anObject]) 323781 ifTrue: [^ index ]]. 323782 323783 "Search from 1 to where we started." 323784 1 to: start-1 do: 323785 [:index | ((element := array at: index) == nil or: [element = anObject]) 323786 ifTrue: [^ index ]]. 323787 323788 ^ 0 "No match AND no empty slot"! ! 323789 323790!Set methodsFor: 'private'! 323791swap: oneIndex with: otherIndex 323792 "May be overridden by subclasses so that fixCollisions will work" 323793 323794 array swap: oneIndex with: otherIndex 323795! ! 323796 323797!Set methodsFor: 'private'! 323798withArray: anArray 323799 "private -- for use only in copy" 323800 array := anArray! ! 323801 323802"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 323803 323804Set class 323805 instanceVariableNames: ''! 323806 323807!Set class methodsFor: 'initialization' stamp: 'SqR 8/3/2000 13:19'! 323808quickRehashAllSets "Set rehashAllSets" 323809 | insts | 323810 self withAllSubclassesDo: 323811 [:c | 323812 insts := c allInstances. 323813 (insts isEmpty or: [c = MethodDictionary]) ifFalse: 323814 ['Rehashing instances of ' , c name 323815 displayProgressAt: Sensor cursorPoint 323816 from: 1 to: insts size 323817 during: [:bar | 1 to: insts size do: [:x | bar value: x. (insts at: x) rehash]] 323818 ] 323819 ]! ! 323820 323821!Set class methodsFor: 'initialization' stamp: 'adrian-lienhard 6/21/2009 23:56'! 323822rehashAllSets 323823 "Set rehashAllSets" 323824 323825 self allSubInstances do: #rehash! ! 323826 323827 323828!Set class methodsFor: 'instance creation' stamp: 'adrian-lienhard 6/22/2009 00:02'! 323829new 323830 ^ self basicNew 323831 initialize: 5; 323832 yourself! ! 323833 323834!Set class methodsFor: 'instance creation' stamp: 'nice 3/11/2008 21:27'! 323835new: nElements 323836 "Create a Set large enough to hold nElements without growing" 323837 ^ self basicNew initialize: (self sizeFor: nElements)! ! 323838 323839!Set class methodsFor: 'instance creation'! 323840newFrom: aCollection 323841 "Answer an instance of me containing the same elements as aCollection." 323842 | newCollection | 323843 newCollection := self new: aCollection size. 323844 newCollection addAll: aCollection. 323845 ^ newCollection 323846" 323847 Set newFrom: {1. 2. 3} 323848 {1. 2. 3} as: Set 323849"! ! 323850 323851!Set class methodsFor: 'instance creation'! 323852sizeFor: nElements 323853 "Large enough size to hold nElements with some slop (see fullCheck)" 323854 nElements <= 0 ifTrue: [^ 1]. 323855 ^ nElements+1*4//3! ! 323856Inspector subclass: #SetInspector 323857 instanceVariableNames: '' 323858 classVariableNames: '' 323859 poolDictionaries: '' 323860 category: 'Tools-Inspector'! 323861!SetInspector commentStamp: '<historical>' prior: 0! 323862A verison of the Inspector specialized for inspecting Sets. It displays the elements of the set like elements of an array. Note that the indices, being phyical locations in the hash table, are not meaningful outside of the set.! 323863 323864 323865!SetInspector methodsFor: 'accessing' stamp: 'PHK 6/29/2004 14:50'! 323866fieldList 323867 object 323868 ifNil: [^ Set new]. 323869 ^ self baseFieldList 323870 , (object array 323871 withIndexCollect: [:each :i | each ifNotNil: [i printString]]) 323872 select: [:each | each notNil]! ! 323873 323874 323875!SetInspector methodsFor: 'menu' stamp: 'PHK 6/30/2004 12:16'! 323876fieldListMenu: aMenu 323877 323878 ^ aMenu labels: 323879'inspect 323880copy name 323881objects pointing to this value 323882refresh view 323883remove 323884basic inspect' 323885 lines: #( 5 8) 323886 selections: #(inspectSelection copyName objectReferencesToSelection update removeSelection inspectBasic) 323887! ! 323888 323889!SetInspector methodsFor: 'menu' stamp: 'sd 11/20/2005 21:27'! 323890removeSelection 323891 (selectionIndex <= object class instSize) ifTrue: [^ self changed: #flash]. 323892 object remove: self selection. 323893 selectionIndex := 0. 323894 contents := ''. 323895 self changed: #inspectObject. 323896 self changed: #fieldList. 323897 self changed: #selection. 323898 self changed: #selectionIndex.! ! 323899 323900 323901!SetInspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'! 323902copyName 323903 "Copy the name of the current variable, so the user can paste it into the 323904 window below and work with is. If collection, do (xxx at: 1)." 323905 | sel | 323906 self selectionIndex <= (2 + object class instSize) 323907 ifTrue: [super copyName] 323908 ifFalse: [sel := '(self array at: ' 323909 , (String streamContents: 323910 [:strm | self arrayIndexForSelection storeOn: strm]) , ')'. 323911 Clipboard clipboardText: sel asText]! ! 323912 323913 323914!SetInspector methodsFor: 'selecting' stamp: 'PHK 6/29/2004 15:33'! 323915arrayIndexForSelection 323916 ^ (self fieldList at: selectionIndex) asInteger! ! 323917 323918!SetInspector methodsFor: 'selecting' stamp: 'PHK 6/29/2004 15:38'! 323919replaceSelectionValue: anObject 323920 ^ object array at: self arrayIndexForSelection put: anObject! ! 323921 323922!SetInspector methodsFor: 'selecting' stamp: 'PHK 6/29/2004 15:35'! 323923selection 323924 selectionIndex = 0 ifTrue: [^ '']. 323925 selectionIndex = 1 ifTrue: [^ object]. 323926 selectionIndex = 2 ifTrue: [^ object longPrintString]. 323927 (selectionIndex - 2) <= object class instSize 323928 ifTrue: [^ object instVarAt: selectionIndex - 2]. 323929 323930 ^ object array at: self arrayIndexForSelection! ! 323931CollectionRootTest subclass: #SetTest 323932 uses: TAddForUniquenessTest + TIncludesWithIdentityCheckTest + TCloneTest + TCopyTest + TSetArithmetic + TRemoveTest + TCreationWithTest - {#testOfSize} + TGrowableTest + TStructuralEqualityTest + TSizeTest + TPrintTest + TAsStringCommaAndDelimiterTest + TConvertTest + TConvertAsSortedTest + TConcatenationEqualElementsRemovedTest + TOccurrencesTest 323933 instanceVariableNames: 'full empty collection result emptyButAllocatedWith20 elementNotIn collectionOfFloat collectionIncluded nonEmpty1element withoutEqualElements collection5Elements' 323934 classVariableNames: '' 323935 poolDictionaries: '' 323936 category: 'CollectionsTests-Unordered'! 323937!SetTest commentStamp: '<historical>' prior: 0! 323938This is the unit test for the class Set. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 323939 - http://www.c2.com/cgi/wiki?UnitTest 323940 - http://minnow.cc.gatech.edu/squeak/1547 323941 - the sunit class category! 323942 323943 323944!SetTest methodsFor: 'ambiguous' stamp: 'delaunay 4/20/2009 16:42'! 323945elementNotIn 323946 ^elementNotIn ! ! 323947 323948 323949!SetTest methodsFor: 'initialize' stamp: 'delaunay 5/14/2009 14:16'! 323950setUp 323951 empty := self classToBeTested new. 323952 full := self classToBeTested with: 1 with: 2 with: 3 with: 4. 323953 collectionIncluded := self classToBeTested with: 2 with: 3 . 323954 collection := self classToBeTested new. 323955 collection add: 1; add: -2; add: 3. 323956 result := self classToBeTested new add: SmallInteger ; yourself. 323957 emptyButAllocatedWith20 := self classToBeTested new: 20. 323958 elementNotIn := 99. 323959 collectionOfFloat := self classToBeTested with: 2.5 with: 4.6 with: 4.2. 323960 nonEmpty1element := self classToBeTested with: 32. 323961 withoutEqualElements := self classToBeTested with: 4 with: 5 with: 2. 323962 collection5Elements := self classToBeTested with: 1 with: 2 with: 3 with: 4 with: 5.! ! 323963 323964 323965!SetTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:00'! 323966anotherElementOrAssociationIn 323967 " return an element (or an association for Dictionary ) present in 'collection' " 323968 ^ self collection anyOne! ! 323969 323970!SetTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:01'! 323971anotherElementOrAssociationNotIn 323972 " return an element (or an association for Dictionary )not present in 'collection' " 323973 ^ elementNotIn ! ! 323974 323975!SetTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 11:12'! 323976classToBeTested 323977^ Set.! ! 323978 323979!SetTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/6/2008 17:08'! 323980collection 323981 323982 ^ collection! ! 323983 323984!SetTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 16:54'! 323985collectionInForIncluding 323986 ^ collectionIncluded ! ! 323987 323988!SetTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:16'! 323989collectionMoreThan5Elements 323990" return a collection including at least 5 elements" 323991 323992 ^ collection5Elements ! ! 323993 323994!SetTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 11:14'! 323995collectionNotIncluded 323996 ^ self classToBeTested with: elementNotIn. ! ! 323997 323998!SetTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 16:42'! 323999collectionOfFloat 324000 ^ collectionOfFloat ! ! 324001 324002!SetTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! 324003collectionWithCopyNonIdentical 324004 " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" 324005 ^ collectionOfFloat! ! 324006 324007!SetTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/8/2008 15:42'! 324008collectionWithElement 324009 ^ full! ! 324010 324011!SetTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 16:54'! 324012collectionWithElementsToRemove 324013 ^ collectionIncluded ! ! 324014 324015!SetTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:28'! 324016collectionWithSortableElements 324017" return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" 324018 ^collectionOfFloat ! ! 324019 324020!SetTest methodsFor: 'requirements' stamp: 'delaunay 5/12/2009 15:20'! 324021collectionWithoutElement 324022 " return a collection that does not include 'element' " 324023 ^ collection ! ! 324024 324025!SetTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:04'! 324026collectionWithoutEqualElements 324027" return a collection without equal elements" 324028 ^ withoutEqualElements ! ! 324029 324030!SetTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:44'! 324031collectionWithoutNilElements 324032" return a collection that doesn't includes a nil element and that doesn't includes equal elements'" 324033 ^ collection ! ! 324034 324035!SetTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/8/2008 15:42'! 324036element 324037 ^ 4! ! 324038 324039!SetTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 16:40'! 324040elementInForIncludesTest 324041" return an element included in nonEmpty " 324042 ^ self nonEmpty anyOne! ! 324043 324044!SetTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:54'! 324045firstCollection 324046" return a collection that will be the first part of the concatenation" 324047 ^ nonEmpty1element ! ! 324048 324049!SetTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:05'! 324050integerCollectionWithoutEqualElements 324051" return a collection of integer without equal elements" 324052 ^ withoutEqualElements ! ! 324053 324054!SetTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:01'! 324055nonEmpty1Element 324056" return a collection of size 1 including one element" 324057 ^ nonEmpty1element ! ! 324058 324059!SetTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:28'! 324060nonEmptyWithoutEqualElements 324061" return a collection without equal elements " 324062 ^ withoutEqualElements ! ! 324063 324064!SetTest methodsFor: 'requirements' stamp: 'damiencassou 1/20/2009 13:25'! 324065otherCollection 324066 "Returns a collection that does not include what is returned by #element." 324067 ^ result! ! 324068 324069!SetTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/6/2008 17:08'! 324070result 324071 324072 ^ result! ! 324073 324074!SetTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:44'! 324075resultForCollectElementsClass 324076" return the retsult expected by collecting the class of each element of collectionWithoutNilElements" 324077 ^ result! ! 324078 324079!SetTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:54'! 324080secondCollection 324081" return a collection that will be the second part of the concatenation" 324082 ^ collection ! ! 324083 324084 324085!SetTest methodsFor: 'some tests' stamp: 'stephane.ducasse 5/20/2009 18:06'! 324086testAddWithOccurences 324087 324088 empty add: 2 withOccurrences: 3. 324089 self assert: (empty includes: 2). 324090 self assert: ((empty occurrencesOf: 2) = 1).! ! 324091 324092!SetTest methodsFor: 'some tests' stamp: 'stephane.ducasse 10/6/2008 19:34'! 324093testAsSet 324094 "could be moved in Array or Collection" 324095 324096 | newFull | 324097 newFull := #(1 2 3 ) asSet. 324098 newFull add: 4. 324099 self assert: (newFull = full).! ! 324100 324101!SetTest methodsFor: 'some tests' stamp: 'GL 2/28/2006 09:25'! 324102testAtRandom 324103 | rand | 324104 rand := Random new. 324105 full add: 3. 324106 full add: 2. 324107 full add: 4. 324108 full add: 1. 324109 self assert: (full includes: (full atRandom: rand)). 324110 ! ! 324111 324112!SetTest methodsFor: 'some tests' stamp: 'stephane.ducasse 10/6/2008 16:56'! 324113testCollect2 324114 | newFull result | 324115 newFull := Set withAll: (1 to: 10). 324116 result := newFull collect: [:each | each >= 1 ifTrue: [each] ifFalse: ['no']]. 324117 self assert: (result = newFull). 324118 result := newFull collect: [:each | each >= 5 ifTrue: [each] ifFalse: ['no']]. 324119 self assert: (result = ((Set withAll: (5 to: 10)) add: 'no'; yourself)).! ! 324120 324121!SetTest methodsFor: 'some tests' stamp: 'stephane.ducasse 5/20/2009 18:05'! 324122testCopy 324123 | newFull | 324124 full add: 3. 324125 full add: 2. 324126 newFull := full copy. 324127 self assert: (full size = newFull size). 324128 self assert: ((full select: [:each | (newFull includes: each) not]) isEmpty). 324129 self assert: ((newFull select: [:each | (full includes: each) not]) isEmpty).! ! 324130 324131!SetTest methodsFor: 'some tests' stamp: 'stephane.ducasse 5/20/2009 18:05'! 324132testCopyWithout 324133 | newFull | 324134 full add: 3. 324135 full add: 2. 324136 newFull := full copyWithout: 3. 324137 self assert: (newFull size = (full size - 1)). 324138 self deny: (newFull includes: 3). 324139 self assert: ((newFull select: [:each | (full includes: each) not]) isEmpty). 324140 self assert: ((full select: [:each | (newFull includes: each) not]) = (Set with: 3)). 324141 ! ! 324142 324143!SetTest methodsFor: 'some tests' stamp: 'stephane.ducasse 10/6/2008 16:56'! 324144testDo2 324145 | newFull result | 324146 newFull := Set withAll: (1 to: 5). 324147 result := 0. 324148 newFull do: [:each | result := (result + each)]. 324149 self assert: (result = 15).! ! 324150 324151!SetTest methodsFor: 'some tests' stamp: 'stephane.ducasse 5/20/2009 18:07'! 324152testIntersection 324153 | newFull col | 324154 full add: 3; add: 2. 324155 col := full intersection: full. 324156 self assert: (full = col). 324157 324158 newFull := Set with: 8 with: 9 with: #z. 324159 col := newFull intersection: full. 324160 self assert: (col isEmpty). 324161 324162 newFull add: 5; add: #abc; add: 7. 324163 col := newFull intersection: full. 324164 self assert: ((full select: [:each | (newFull includes: each)]) = col). 324165 324166 324167 ! ! 324168 324169!SetTest methodsFor: 'some tests' stamp: 'stephane.ducasse 10/6/2008 19:35'! 324170testLike 324171 self assert: ((full like: 3) = 3). 324172 self assert: ((full like: 8) isNil).! ! 324173 324174!SetTest methodsFor: 'some tests' stamp: 'stephane.ducasse 10/6/2008 19:39'! 324175testRemoveIfAbsent 324176 | result1 result2 | 324177 result1 := true. 324178 result2 := true. 324179 full remove: 8 ifAbsent: [ result1 := false ]. 324180 self assert: (result1 = false). 324181 full remove: 4 ifAbsent: [ result2 := false ]. 324182 self assert: (result2 = true). 324183 324184 324185 ! ! 324186 324187!SetTest methodsFor: 'some tests' stamp: 'stephane.ducasse 10/6/2008 19:34'! 324188testSize2 324189 self assert: (empty size = 0). 324190 self assert: (full size = 4). 324191 empty add: 2. 324192 empty add: 1. 324193 full add: 2. 324194 self assert: (empty size = 2). 324195 self assert: (full size = 4). 324196 empty remove: 2. 324197 self assert: (empty size = 1).! ! 324198 324199!SetTest methodsFor: 'some tests' stamp: 'stephane.ducasse 5/20/2009 18:05'! 324200testUnion 324201 | newFull col newCol | 324202 full add: 3. 324203 full add: 2. 324204 col := full union: full. 324205 self assert: (full = col). 324206 324207 newFull := Set with: 8 with: 9 with: #z. 324208 col := newFull union: full. 324209 self assert: (col size = (full size + newFull size)). 324210 self assert: ((col select: [:each | (full includes: each) not]) = newFull). 324211 self assert: ((col select: [:each | (newFull includes: each) not]) = full). 324212 324213 full add: 9. 324214 col := newFull union: full. 324215 newCol := newFull copy. 324216 newCol remove: 9. 324217 self assert: (col size = (full size + newFull size - 1)). 324218 self assert: ((col select: [:each | (full includes: each) not]) = newCol). 324219 newCol := full copy. 324220 newCol remove: 9. 324221 self assert: ((col select: [:each | (newFull includes: each) not]) = newCol). 324222 324223 324224 ! ! 324225 324226 324227!SetTest methodsFor: 'sunit original tests' stamp: 'stephane.ducasse 5/20/2009 18:05'! 324228testAdd 324229 empty add: 5. 324230 self assert: (empty includes: 5).! ! 324231 324232!SetTest methodsFor: 'sunit original tests' stamp: 'stephane.ducasse 5/20/2009 18:05'! 324233testGrow 324234 empty addAll: (1 to: 100). 324235 self assert: (empty size = 100). 324236 ! ! 324237 324238!SetTest methodsFor: 'sunit original tests' stamp: 'stephane.ducasse 5/20/2009 18:04'! 324239testIllegal 324240 self should: [empty at: 5] raise: TestResult error. 324241 self should: [empty at: 5 put: #abc] raise: TestResult error. 324242 ! ! 324243 324244!SetTest methodsFor: 'sunit original tests' stamp: 'stephane.ducasse 10/6/2008 19:35'! 324245testIncludes 324246 self assert: (full includes: 4). 324247 self assert: (full includes: 3). 324248 self deny: (full includes: 6). 324249 ! ! 324250 324251!SetTest methodsFor: 'sunit original tests' stamp: 'stephane.ducasse 10/6/2008 19:39'! 324252testOccurrences 324253 self assert: ((empty occurrencesOf: 0) = 0). 324254 self assert: ((full occurrencesOf: 4) = 1). 324255 full add: 4. 324256 self assert: ((full occurrencesOf: 4) = 1).! ! 324257 324258!SetTest methodsFor: 'sunit original tests' stamp: 'stephane.ducasse 10/6/2008 19:34'! 324259testRemove 324260 full remove: 4. 324261 self assert: (full includes: 3). 324262 self deny: (full includes: 4).! ! 324263 324264 324265!SetTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! 324266elementToAdd 324267 ^ 42! ! 324268 324269 324270!SetTest methodsFor: 'test - creation' stamp: 'stephane.ducasse 12/9/2008 21:14'! 324271collectionClass 324272 324273 ^ Set! ! 324274 324275!SetTest methodsFor: 'test - creation'! 324276testWith 324277 "self debug: #testWith" 324278 324279 | aCol element | 324280 element := self collectionMoreThan5Elements anyOne. 324281 aCol := self collectionClass with: element. 324282 self assert: (aCol includes: element).! ! 324283 324284!SetTest methodsFor: 'test - creation'! 324285testWithAll 324286 "self debug: #testWithAll" 324287 324288 | aCol collection | 324289 collection := self collectionMoreThan5Elements asOrderedCollection . 324290 aCol := self collectionClass withAll: collection . 324291 324292 collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. 324293 324294 self assert: (aCol size = collection size ).! ! 324295 324296!SetTest methodsFor: 'test - creation'! 324297testWithWith 324298 "self debug: #testWithWith" 324299 324300 | aCol collection element1 element2 | 324301 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . 324302 element1 := collection at: 1. 324303 element2 := collection at:2. 324304 324305 aCol := self collectionClass with: element1 with: element2 . 324306 self assert: (aCol occurrencesOf: element1 ) == ( collection occurrencesOf: element1). 324307 self assert: (aCol occurrencesOf: element2 ) == ( collection occurrencesOf: element2). 324308 324309 ! ! 324310 324311!SetTest methodsFor: 'test - creation'! 324312testWithWithWith 324313 "self debug: #testWithWithWith" 324314 324315 | aCol collection | 324316 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . 324317 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 324318 324319 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 324320 324321!SetTest methodsFor: 'test - creation'! 324322testWithWithWithWith 324323 "self debug: #testWithWithWithWith" 324324 324325 | aCol collection | 324326 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. 324327 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 324328 324329 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 324330 324331!SetTest methodsFor: 'test - creation'! 324332testWithWithWithWithWith 324333 "self debug: #testWithWithWithWithWith" 324334 324335 | aCol collection | 324336 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . 324337 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 324338 324339 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 324340 324341 324342!SetTest methodsFor: 'test - equality'! 324343testEqualSign 324344 "self debug: #testEqualSign" 324345 324346 self deny: (self empty = self nonEmpty).! ! 324347 324348!SetTest methodsFor: 'test - equality'! 324349testEqualSignIsTrueForNonIdenticalButEqualCollections 324350 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 324351 324352 self assert: (self empty = self empty copy). 324353 self assert: (self empty copy = self empty). 324354 self assert: (self empty copy = self empty copy). 324355 324356 self assert: (self nonEmpty = self nonEmpty copy). 324357 self assert: (self nonEmpty copy = self nonEmpty). 324358 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 324359 324360!SetTest methodsFor: 'test - equality'! 324361testEqualSignOfIdenticalCollectionObjects 324362 "self debug: #testEqualSignOfIdenticalCollectionObjects" 324363 324364 self assert: (self empty = self empty). 324365 self assert: (self nonEmpty = self nonEmpty). 324366 ! ! 324367 324368 324369!SetTest methodsFor: 'test - iterate' stamp: 'luc.fabresse 11/29/2008 23:09'! 324370expectedSizeAfterReject 324371 ^1! ! 324372 324373!SetTest methodsFor: 'test - iterate' stamp: 'stephane.ducasse 10/6/2008 19:40'! 324374selectedNumber 324375 324376 ^ 2 324377 ! ! 324378 324379!SetTest methodsFor: 'test - iterate' stamp: 'stephane.ducasse 10/6/2008 17:39'! 324380speciesClass 324381 324382 ^ Set! ! 324383 324384!SetTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/30/2009 18:04'! 324385testDoWithoutNoDuplicates 324386 "self debug: #testDoWithoutNoDuplicates" 324387 | res | 324388 res := self speciesClass new. 324389 self collection do: [:each | res add: each] without: -2. 324390 self assert: res size = self doWithoutNumber.! ! 324391 324392 324393!SetTest methodsFor: 'tests - adding uniquely'! 324394testAddAlreadyThereDoesNotCount 324395 324396 | added oldSize | 324397 oldSize := self collectionWithElement size. 324398 self assert: (self collectionWithElement includes: self element). 324399 324400 added := self collectionWithElement add: self element. 324401 324402 self assert: added = self element. 324403 self assert: (self collectionWithElement includes: self element). 324404 self assert: self collectionWithElement size = oldSize.! ! 324405 324406!SetTest methodsFor: 'tests - adding uniquely' stamp: 'delaunay 5/12/2009 15:18'! 324407testAddNewElementIncrementsSize 324408 | added oldSize | 324409 oldSize := self collectionWithoutElement size. 324410 self deny: (self collectionWithoutElement includes: self element). 324411 added := self collectionWithoutElement add: self element. 324412 self assert: added = self element. 324413 self assert: (self collectionWithoutElement includes: self element). 324414 self assert: self collectionWithoutElement size = (oldSize + 1)! ! 324415 324416!SetTest methodsFor: 'tests - adding uniquely'! 324417testTAddIfNotPresentWithElementAlreadyIn 324418 324419 | added oldSize | 324420 oldSize := self collectionWithElement size. 324421 self assert: (self collectionWithElement includes: self element). 324422 324423 added := self collectionWithElement addIfNotPresent: self element. 324424 324425 self assert: added = self element. 324426 self assert: (self collectionWithElement includes: self element). 324427 self assert: self collectionWithElement size = oldSize.! ! 324428 324429!SetTest methodsFor: 'tests - adding uniquely' stamp: 'delaunay 5/12/2009 15:18'! 324430testTAddIfNotPresentWithNewElement 324431 | added oldSize | 324432 oldSize := self collectionWithoutElement size. 324433 self deny: (self collectionWithoutElement includes: self element). 324434 added := self collectionWithoutElement addIfNotPresent: self element. 324435 self assert: added = self element. 324436 self assert: (self collectionWithoutElement includes: self element). 324437 self assert: self collectionWithoutElement size = (oldSize + 1)! ! 324438 324439 324440!SetTest methodsFor: 'tests - as sorted collection'! 324441testAsSortedArray 324442 | result collection | 324443 collection := self collectionWithSortableElements . 324444 result := collection asSortedArray. 324445 self assert: (result class includesBehavior: Array). 324446 self assert: result isSorted. 324447 self assert: result size = collection size! ! 324448 324449!SetTest methodsFor: 'tests - as sorted collection'! 324450testAsSortedCollection 324451 324452 | aCollection result | 324453 aCollection := self collectionWithSortableElements . 324454 result := aCollection asSortedCollection. 324455 324456 self assert: (result class includesBehavior: SortedCollection). 324457 result do: 324458 [ :each | 324459 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 324460 324461 self assert: result size = aCollection size.! ! 324462 324463!SetTest methodsFor: 'tests - as sorted collection'! 324464testAsSortedCollectionWithSortBlock 324465 | result tmp | 324466 result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. 324467 self assert: (result class includesBehavior: SortedCollection). 324468 result do: 324469 [ :each | 324470 self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 324471 self assert: result size = self collectionWithSortableElements size. 324472 tmp:=result at: 1. 324473 result do: [:each| self assert: tmp>=each. tmp:=each]. 324474 ! ! 324475 324476 324477!SetTest methodsFor: 'tests - as string comma delimiter sequenceable'! 324478testAsCommaStringEmpty 324479 324480 self assert: self empty asCommaString = ''. 324481 self assert: self empty asCommaStringAnd = ''. 324482 324483! ! 324484 324485!SetTest methodsFor: 'tests - as string comma delimiter sequenceable'! 324486testAsCommaStringMore 324487 324488 | result resultAnd index allElementsAsString tmp | 324489 result:= self nonEmpty asCommaString . 324490 resultAnd:= self nonEmpty asCommaStringAnd . 324491 tmp :=OrderedCollection new. 324492 self nonEmpty do: [ :each | tmp add: each asString]. 324493 324494 "verifying result :" 324495 index := 1. 324496 allElementsAsString := (result findBetweenSubStrs: ', ' ). 324497 allElementsAsString do: 324498 [:each | 324499 self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). 324500 ]. 324501 324502 "verifying esultAnd :" 324503 allElementsAsString:=(resultAnd findBetweenSubStrs: ', ' ). 324504 1 to: allElementsAsString size do: 324505 [:i | 324506 i<(allElementsAsString size-1 ) | i= allElementsAsString size 324507 ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. 324508 i=(allElementsAsString size-1) 324509 ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. 324510 ].! ! 324511 324512!SetTest methodsFor: 'tests - as string comma delimiter sequenceable'! 324513testAsCommaStringOne 324514 324515 self nonEmpty1Element do: 324516 [:each | 324517 self assert: each asString =self nonEmpty1Element asCommaString. 324518 self assert: each asString=self nonEmpty1Element asCommaStringAnd.]. 324519 324520 ! ! 324521 324522!SetTest methodsFor: 'tests - as string comma delimiter sequenceable'! 324523testAsStringOnDelimiterEmpty 324524 324525 | delim emptyStream | 324526 delim := ', '. 324527 emptyStream := ReadWriteStream on: ''. 324528 self empty asStringOn: emptyStream delimiter: delim. 324529 self assert: emptyStream contents = ''. 324530! ! 324531 324532!SetTest methodsFor: 'tests - as string comma delimiter sequenceable'! 324533testAsStringOnDelimiterLastEmpty 324534 324535 | delim emptyStream | 324536 delim := ', '. 324537 emptyStream := ReadWriteStream on: ''. 324538 self empty asStringOn: emptyStream delimiter: delim last:'and'. 324539 self assert: emptyStream contents = ''. 324540! ! 324541 324542!SetTest methodsFor: 'tests - as string comma delimiter sequenceable'! 324543testAsStringOnDelimiterLastMore 324544 324545 | delim multiItemStream result last allElementsAsString tmp | 324546 324547 delim := ', '. 324548 last := 'and'. 324549 result:=''. 324550 tmp := self nonEmpty collect: [:each | each asString]. 324551 multiItemStream := ReadWriteStream on:result. 324552 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 324553 324554 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 324555 1 to: allElementsAsString size do: 324556 [:i | 324557 i<(allElementsAsString size-1 ) | i= allElementsAsString size 324558 ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. 324559 i=(allElementsAsString size-1) 324560 ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. 324561 ]. 324562! ! 324563 324564!SetTest methodsFor: 'tests - as string comma delimiter sequenceable'! 324565testAsStringOnDelimiterLastOne 324566 324567 | delim oneItemStream result | 324568 324569 delim := ', '. 324570 result:=''. 324571 oneItemStream := ReadWriteStream on: result. 324572 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 324573 oneItemStream do: 324574 [:each1 | 324575 self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] 324576 ]. 324577 324578 324579! ! 324580 324581!SetTest methodsFor: 'tests - as string comma delimiter sequenceable'! 324582testAsStringOnDelimiterMore 324583 324584 | delim multiItemStream result allElementsAsString tmp | 324585 324586 324587 delim := ', '. 324588 result:=''. 324589 tmp:= self nonEmpty collect:[:each | each asString]. 324590 multiItemStream := ReadWriteStream on:result. 324591 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 324592 324593 allElementsAsString := (result findBetweenSubStrs: ', ' ). 324594 allElementsAsString do: 324595 [:each | 324596 self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). 324597 ].! ! 324598 324599!SetTest methodsFor: 'tests - as string comma delimiter sequenceable'! 324600testAsStringOnDelimiterOne 324601 324602 | delim oneItemStream result | 324603 324604 delim := ', '. 324605 result:=''. 324606 oneItemStream := ReadWriteStream on: result. 324607 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 324608 oneItemStream do: 324609 [:each1 | 324610 self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] 324611 ]. 324612 324613! ! 324614 324615 324616!SetTest methodsFor: 'tests - concatenation'! 324617testConcatenation 324618 324619| collection1 collection2 result | 324620collection1 := self firstCollection . 324621collection2 := self secondCollection . 324622result := collection1 , collection2. 324623 324624collection1 do:[ :each | self assert: (result includes: each)]. 324625collection2 do:[ :each | self assert: (result includes: each)]. 324626! ! 324627 324628!SetTest methodsFor: 'tests - concatenation'! 324629testConcatenationWithDuplicate 324630 324631 324632| collection1 collection2 result | 324633collection1 := self firstCollection . 324634collection2 := self firstCollection . 324635result := collection1 , collection2. 324636 324637collection1 do:[ :each | self assert: (result includes: each)]. 324638self assert: result size = collection1 size.! ! 324639 324640!SetTest methodsFor: 'tests - concatenation'! 324641testConcatenationWithEmpty 324642 | result | 324643 result := self firstCollection , self empty. 324644 self assert: result = self firstCollection! ! 324645 324646 324647!SetTest methodsFor: 'tests - converting'! 324648assertNoDuplicates: aCollection whenConvertedTo: aClass 324649 | result | 324650 result := self collectionWithEqualElements asIdentitySet. 324651 self assert: (result class includesBehavior: IdentitySet). 324652 self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! 324653 324654!SetTest methodsFor: 'tests - converting'! 324655assertNonDuplicatedContents: aCollection whenConvertedTo: aClass 324656 | result | 324657 result := aCollection perform: ('as' , aClass name) asSymbol. 324658 self assert: (result class includesBehavior: aClass). 324659 result do: 324660 [ :each | 324661 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 324662 ^ result! ! 324663 324664!SetTest methodsFor: 'tests - converting'! 324665assertSameContents: aCollection whenConvertedTo: aClass 324666 | result | 324667 result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. 324668 self assert: result size = aCollection size! ! 324669 324670!SetTest methodsFor: 'tests - converting'! 324671testAsArray 324672 "self debug: #testAsArray3" 324673 self 324674 assertSameContents: self collectionWithoutEqualElements 324675 whenConvertedTo: Array! ! 324676 324677!SetTest methodsFor: 'tests - converting'! 324678testAsBag 324679 324680 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! 324681 324682!SetTest methodsFor: 'tests - converting'! 324683testAsByteArray 324684| res | 324685self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 324686 self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . 324687 324688 res := true. 324689 self integerCollectionWithoutEqualElements 324690 detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] 324691 ifNone: [ res := false ]. 324692 self assert: res = false. 324693 324694 324695 self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! 324696 324697!SetTest methodsFor: 'tests - converting'! 324698testAsIdentitySet 324699 "test with a collection without equal elements :" 324700 self 324701 assertSameContents: self collectionWithoutEqualElements 324702 whenConvertedTo: IdentitySet. 324703! ! 324704 324705!SetTest methodsFor: 'tests - converting'! 324706testAsOrderedCollection 324707 324708 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! 324709 324710 324711!SetTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 324712testCopyEmptyWith 324713 "self debug: #testCopyWith" 324714 | res | 324715 res := self empty copyWith: self elementToAdd. 324716 self assert: res size = (self empty size + 1). 324717 self assert: (res includes: self elementToAdd)! ! 324718 324719!SetTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 324720testCopyEmptyWithout 324721 "self debug: #testCopyEmptyWithout" 324722 | res | 324723 res := self empty copyWithout: self elementToAdd. 324724 self assert: res size = self empty size. 324725 self deny: (res includes: self elementToAdd)! ! 324726 324727!SetTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 324728testCopyEmptyWithoutAll 324729 "self debug: #testCopyEmptyWithoutAll" 324730 | res | 324731 res := self empty copyWithoutAll: self collectionWithElementsToRemove. 324732 self assert: res size = self empty size. 324733 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! 324734 324735!SetTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 324736testCopyNonEmptyWith 324737 "self debug: #testCopyNonEmptyWith" 324738 | res | 324739 res := self nonEmpty copyWith: self elementToAdd. 324740 "here we do not test the size since for a non empty set we would get a problem. 324741 Then in addition copy is not about duplicate management. The element should 324742 be in at the end." 324743 self assert: (res includes: self elementToAdd). 324744 self nonEmpty do: [ :each | res includes: each ]! ! 324745 324746!SetTest methodsFor: 'tests - copy'! 324747testCopyNonEmptyWithout 324748 "self debug: #testCopyNonEmptyWithout" 324749 324750 | res anElementOfTheCollection | 324751 anElementOfTheCollection := self nonEmpty anyOne. 324752 res := (self nonEmpty copyWithout: anElementOfTheCollection). 324753 "here we do not test the size since for a non empty set we would get a problem. 324754 Then in addition copy is not about duplicate management. The element should 324755 be in at the end." 324756 self deny: (res includes: anElementOfTheCollection). 324757 self nonEmpty do: 324758 [:each | (each = anElementOfTheCollection) 324759 ifFalse: [self assert: (res includes: each)]]. 324760 324761! ! 324762 324763!SetTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 324764testCopyNonEmptyWithoutAll 324765 "self debug: #testCopyNonEmptyWithoutAll" 324766 | res | 324767 res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. 324768 "here we do not test the size since for a non empty set we would get a problem. 324769 Then in addition copy is not about duplicate management. The element should 324770 be in at the end." 324771 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]. 324772 self nonEmpty do: 324773 [ :each | 324774 (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! 324775 324776!SetTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! 324777testCopyNonEmptyWithoutAllNotIncluded 324778 ! ! 324779 324780!SetTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 324781testCopyNonEmptyWithoutNotIncluded 324782 "self debug: #testCopyNonEmptyWithoutNotIncluded" 324783 | res | 324784 res := self nonEmpty copyWithout: self elementToAdd. 324785 "here we do not test the size since for a non empty set we would get a problem. 324786 Then in addition copy is not about duplicate management. The element should 324787 be in at the end." 324788 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 324789 324790 324791!SetTest methodsFor: 'tests - copy - clone'! 324792testCopyCreatesNewObject 324793 "self debug: #testCopyCreatesNewObject" 324794 324795 | copy | 324796 copy := self nonEmpty copy. 324797 self deny: self nonEmpty == copy. 324798 ! ! 324799 324800!SetTest methodsFor: 'tests - copy - clone'! 324801testCopyEmpty 324802 "self debug: #testCopyEmpty" 324803 324804 | copy | 324805 copy := self empty copy. 324806 self assert: copy isEmpty.! ! 324807 324808!SetTest methodsFor: 'tests - copy - clone'! 324809testCopyNonEmpty 324810 "self debug: #testCopyNonEmpty" 324811 324812 | copy | 324813 copy := self nonEmpty copy. 324814 self deny: copy isEmpty. 324815 self assert: copy size = self nonEmpty size. 324816 self nonEmpty do: 324817 [:each | copy includes: each]! ! 324818 324819 324820!SetTest methodsFor: 'tests - empty' stamp: 'stephane.ducasse 10/5/2008 13:11'! 324821empty 324822 324823 ^ empty! ! 324824 324825!SetTest methodsFor: 'tests - empty' stamp: 'stephane.ducasse 10/5/2008 13:11'! 324826nonEmpty 324827 324828 ^ full! ! 324829 324830 324831!SetTest methodsFor: 'tests - fixture'! 324832test0CopyTest 324833 self shouldnt: [ self empty ]raise: Error. 324834 self assert: self empty size = 0. 324835 self shouldnt: [ self nonEmpty ]raise: Error. 324836 self assert: (self nonEmpty size = 0) not. 324837 self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. 324838 self assert: (self collectionWithElementsToRemove size = 0) not. 324839 self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. 324840 324841 self shouldnt: [ self elementToAdd ]raise: Error. 324842 self deny: (self nonEmpty includes: self elementToAdd ). 324843 self shouldnt: [ self collectionNotIncluded ]raise: Error. 324844 self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! 324845 324846!SetTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/12/2009 15:18'! 324847test0FixtureAddForUniquenessTest 324848 self 324849 shouldnt: [ self element ] 324850 raise: Error. 324851 self 324852 shouldnt: [ self collectionWithElement ] 324853 raise: Error. 324854 self assert: (self collectionWithElement includes: self element). 324855 self 324856 shouldnt: [ self collectionWithoutElement ] 324857 raise: Error. 324858 self assert: (self collectionWithElement includes: self element)! ! 324859 324860!SetTest methodsFor: 'tests - fixture'! 324861test0FixtureAsStringCommaAndDelimiterTest 324862 324863 self shouldnt: [self nonEmpty] raise:Error . 324864 self deny: self nonEmpty isEmpty. 324865 324866 self shouldnt: [self empty] raise:Error . 324867 self assert: self empty isEmpty. 324868 324869 self shouldnt: [self nonEmpty1Element ] raise:Error . 324870 self assert: self nonEmpty1Element size=1.! ! 324871 324872!SetTest methodsFor: 'tests - fixture'! 324873test0FixtureCloneTest 324874 324875self shouldnt: [ self nonEmpty ] raise: Error. 324876self deny: self nonEmpty isEmpty. 324877 324878self shouldnt: [ self empty ] raise: Error. 324879self assert: self empty isEmpty. 324880 324881! ! 324882 324883!SetTest methodsFor: 'tests - fixture'! 324884test0FixtureConcatenationTest 324885 self shouldnt: [ self firstCollection ]raise: Error. 324886 self deny: self firstCollection isEmpty. 324887 324888 self shouldnt: [ self firstCollection ]raise: Error. 324889 self deny: self firstCollection isEmpty. 324890 324891 self shouldnt: [ self empty ]raise: Error. 324892 self assert: self empty isEmpty! ! 324893 324894!SetTest methodsFor: 'tests - fixture'! 324895test0FixtureConverAsSortedTest 324896 324897 self shouldnt: [self collectionWithSortableElements ] raise: Error. 324898 self deny: self collectionWithSortableElements isEmpty .! ! 324899 324900!SetTest methodsFor: 'tests - fixture'! 324901test0FixtureCreationWithTest 324902 324903self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. 324904self assert: self collectionMoreThan5Elements size >= 5.! ! 324905 324906!SetTest methodsFor: 'tests - fixture'! 324907test0FixtureIncludeTest 324908 | elementIn | 324909 self shouldnt: [ self nonEmpty ]raise: Error. 324910 self deny: self nonEmpty isEmpty. 324911 324912 self shouldnt: [ self elementNotIn ]raise: Error. 324913 324914 elementIn := true. 324915 self nonEmpty detect: 324916 [ :each | each = self elementNotIn ] 324917 ifNone: [ elementIn := false ]. 324918 self assert: elementIn = false. 324919 324920 self shouldnt: [ self anotherElementNotIn ]raise: Error. 324921 324922 elementIn := true. 324923 self nonEmpty detect: 324924 [ :each | each = self anotherElementNotIn ] 324925 ifNone: [ elementIn := false ]. 324926 self assert: elementIn = false. 324927 324928 self shouldnt: [ self empty ] raise: Error. 324929 self assert: self empty isEmpty. 324930 324931! ! 324932 324933!SetTest methodsFor: 'tests - fixture'! 324934test0FixtureIncludeWithIdentityTest 324935 | element | 324936 self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. 324937 element := self collectionWithCopyNonIdentical anyOne. 324938 self deny: element == element copy. 324939! ! 324940 324941!SetTest methodsFor: 'tests - fixture'! 324942test0FixtureOccurrencesTest 324943 | tmp | 324944 self shouldnt: [self empty ]raise: Error. 324945 self assert: self empty isEmpty. 324946 324947 self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. 324948 self deny: self collectionWithoutEqualElements isEmpty. 324949 324950 tmp := OrderedCollection new. 324951 self collectionWithoutEqualElements do: [ 324952 :each | 324953 self deny: (tmp includes: each). 324954 tmp add: each. 324955 ]. 324956 324957 324958 self shouldnt: [ self elementNotInForOccurrences ] raise: Error. 324959 self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! 324960 324961!SetTest methodsFor: 'tests - fixture'! 324962test0FixturePrintTest 324963 324964 self shouldnt: [self nonEmpty ] raise: Error. 324965 self deny: self nonEmpty isEmpty.! ! 324966 324967!SetTest methodsFor: 'tests - fixture'! 324968test0FixtureRequirementsOfTGrowableTest 324969 self shouldnt: [self empty] raise: Exception. 324970 self shouldnt: [self nonEmpty] raise: Exception. 324971 self shouldnt: [self element] raise: Exception. 324972 self shouldnt: [self elementNotIn] raise: Exception. 324973 self assert: self empty isEmpty. 324974 self deny: self nonEmpty isEmpty. 324975 self assert: (self nonEmpty includes: self element). 324976 self deny: (self nonEmpty includes: self elementNotIn).! ! 324977 324978!SetTest methodsFor: 'tests - fixture'! 324979test0FixtureSetAritmeticTest 324980 self 324981 shouldnt: [ self collection ] 324982 raise: Error. 324983 self deny: self collection isEmpty. 324984 self 324985 shouldnt: [ self nonEmpty ] 324986 raise: Error. 324987 self deny: self nonEmpty isEmpty. 324988 self 324989 shouldnt: [ self anotherElementOrAssociationNotIn ] 324990 raise: Error. 324991 self collection isDictionary 324992 ifTrue: 324993 [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] 324994 ifFalse: 324995 [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. 324996 self 324997 shouldnt: [ self collectionClass ] 324998 raise: Error! ! 324999 325000!SetTest methodsFor: 'tests - fixture'! 325001test0FixtureTConvertTest 325002 "a collection of number without equal elements:" 325003 | res | 325004 self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. 325005 325006 res := true. 325007 self collectionWithoutEqualElements 325008 detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] 325009 ifNone: [ res := false ]. 325010 self assert: res = false. 325011 325012 325013! ! 325014 325015!SetTest methodsFor: 'tests - fixture'! 325016test0FixtureTRemoveTest 325017 | duplicate | 325018 self shouldnt: [ self empty ]raise: Error. 325019 self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. 325020 self deny: self nonEmptyWithoutEqualElements isEmpty. 325021 duplicate := true. 325022 self nonEmptyWithoutEqualElements detect: 325023 [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] 325024 ifNone: [duplicate := false]. 325025 self assert: duplicate = false. 325026 325027 325028 self shouldnt: [ self elementNotIn ] raise: Error. 325029 self assert: self empty isEmpty. 325030 self deny: self nonEmptyWithoutEqualElements isEmpty. 325031 self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! 325032 325033!SetTest methodsFor: 'tests - fixture'! 325034test0TSizeTest 325035 self shouldnt: [self empty] raise: Error. 325036 self shouldnt: [self sizeCollection] raise: Error. 325037 self assert: self empty isEmpty. 325038 self deny: self sizeCollection isEmpty.! ! 325039 325040!SetTest methodsFor: 'tests - fixture'! 325041test0TStructuralEqualityTest 325042 self shouldnt: [self empty] raise: Error. 325043 self shouldnt: [self nonEmpty] raise: Error. 325044 self assert: self empty isEmpty. 325045 self deny: self nonEmpty isEmpty.! ! 325046 325047 325048!SetTest methodsFor: 'tests - growable' stamp: 'damiencassou 1/20/2009 10:44'! 325049testAddEmptyGrows 325050 "self debug: #testAddEmptyGrows" 325051 325052 | oldSize | 325053 oldSize := self empty size. 325054 self empty add: self element. 325055 self assert: self empty size = (oldSize + 1).! ! 325056 325057!SetTest methodsFor: 'tests - growable' stamp: 'delaunay 4/2/2009 11:53'! 325058testAddNonEmptyGrowsWhenNewElement 325059 "self debug: #testAddNonEmptyGrowsWhenNewElement" 325060 | oldSize | 325061 oldSize := self nonEmpty size. 325062 self deny: (self nonEmpty includes: self elementNotInForOccurrences). 325063 self nonEmpty add: self elementNotInForOccurrences. 325064 self assert: self nonEmpty size > oldSize! ! 325065 325066 325067!SetTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:58'! 325068anotherElementNotIn 325069 ^ 42! ! 325070 325071!SetTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 325072elementNotInForOccurrences 325073 ^ 666! ! 325074 325075!SetTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! 325076testIdentityIncludes 325077 " test the comportement in presence of elements 'includes' but not 'identityIncludes' " 325078 " can not be used by collections that can't include elements for wich copy doesn't return another instance " 325079 | collection element | 325080 self 325081 shouldnt: [ self collectionWithCopyNonIdentical ] 325082 raise: Error. 325083 collection := self collectionWithCopyNonIdentical. 325084 element := collection anyOne copy. 325085 "self assert: (collection includes: element)." 325086 self deny: (collection identityIncludes: element)! ! 325087 325088!SetTest methodsFor: 'tests - includes'! 325089testIdentityIncludesNonSpecificComportement 325090 " test the same comportement than 'includes: ' " 325091 | collection | 325092 collection := self nonEmpty . 325093 325094 self deny: (collection identityIncludes: self elementNotIn ). 325095 self assert:(collection identityIncludes: collection anyOne) 325096! ! 325097 325098!SetTest methodsFor: 'tests - includes'! 325099testIncludesAllOfAllThere 325100 "self debug: #testIncludesAllOfAllThere'" 325101 self assert: (self empty includesAllOf: self empty). 325102 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 325103 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 325104 325105!SetTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 325106testIncludesAllOfNoneThere 325107 "self debug: #testIncludesAllOfNoneThere'" 325108 self deny: (self empty includesAllOf: self collection). 325109 self deny: (self nonEmpty includesAllOf: { 325110 (self elementNotIn). 325111 (self anotherElementNotIn) 325112 })! ! 325113 325114!SetTest methodsFor: 'tests - includes'! 325115testIncludesAnyOfAllThere 325116 "self debug: #testIncludesAnyOfAllThere'" 325117 self deny: (self nonEmpty includesAnyOf: self empty). 325118 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 325119 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 325120 325121!SetTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 325122testIncludesAnyOfNoneThere 325123 "self debug: #testIncludesAnyOfNoneThere'" 325124 self deny: (self nonEmpty includesAnyOf: self empty). 325125 self deny: (self nonEmpty includesAnyOf: { 325126 (self elementNotIn). 325127 (self anotherElementNotIn) 325128 })! ! 325129 325130!SetTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 325131testIncludesElementIsNotThere 325132 "self debug: #testIncludesElementIsNotThere" 325133 self deny: (self nonEmpty includes: self elementNotInForOccurrences). 325134 self assert: (self nonEmpty includes: self nonEmpty anyOne). 325135 self deny: (self empty includes: self elementNotInForOccurrences)! ! 325136 325137!SetTest methodsFor: 'tests - includes'! 325138testIncludesElementIsThere 325139 "self debug: #testIncludesElementIsThere" 325140 325141 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 325142 325143!SetTest methodsFor: 'tests - includes' stamp: 'delaunay 4/9/2009 10:44'! 325144testIncludesSubstringAnywhere 325145 "self debug: #testIncludesSubstringAnywher'" 325146 self assert: (self empty includesAllOf: self empty). 325147 self assert: (self nonEmpty includesAllOf: { (self nonEmpty anyOne) }). 325148 self assert: (self nonEmpty includesAllOf: self nonEmpty)! ! 325149 325150 325151!SetTest methodsFor: 'tests - occurrencesOf'! 325152testOccurrencesOf 325153 | collection | 325154 collection := self collectionWithoutEqualElements . 325155 325156 collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! 325157 325158!SetTest methodsFor: 'tests - occurrencesOf'! 325159testOccurrencesOfEmpty 325160 | result | 325161 result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). 325162 self assert: result = 0! ! 325163 325164!SetTest methodsFor: 'tests - occurrencesOf'! 325165testOccurrencesOfNotIn 325166 | result | 325167 result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. 325168 self assert: result = 0! ! 325169 325170 325171!SetTest methodsFor: 'tests - printing'! 325172testPrintElementsOn 325173 325174 | aStream result allElementsAsString tmp | 325175 result:=''. 325176 aStream:= ReadWriteStream on: result. 325177 tmp:= OrderedCollection new. 325178 self nonEmpty do: [:each | tmp add: each asString]. 325179 325180 self nonEmpty printElementsOn: aStream . 325181 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 325182 1 to: allElementsAsString size do: 325183 [:i | 325184 self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)). 325185 ].! ! 325186 325187!SetTest methodsFor: 'tests - printing'! 325188testPrintNameOn 325189 325190 | aStream result | 325191 result:=''. 325192 aStream:= ReadWriteStream on: result. 325193 325194 self nonEmpty printNameOn: aStream . 325195 Transcript show: result asString. 325196 self nonEmpty class name first isVowel 325197 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 325198 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 325199 325200!SetTest methodsFor: 'tests - printing'! 325201testPrintOn 325202 | aStream result allElementsAsString tmp | 325203 result:=''. 325204 aStream:= ReadWriteStream on: result. 325205 tmp:= OrderedCollection new. 325206 self nonEmpty do: [:each | tmp add: each asString]. 325207 325208 self nonEmpty printOn: aStream . 325209 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 325210 1 to: allElementsAsString size do: 325211 [:i | 325212 i=1 325213 ifTrue:[ 325214 self accessCollection class name first isVowel 325215 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 325216 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 325217 i=2 325218 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 325219 i>2 325220 ifTrue:[self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)).]. 325221 ].! ! 325222 325223!SetTest methodsFor: 'tests - printing'! 325224testPrintOnDelimiter 325225 | aStream result allElementsAsString tmp | 325226 result:=''. 325227 aStream:= ReadWriteStream on: result. 325228 tmp:= OrderedCollection new. 325229 self nonEmpty do: [:each | tmp add: each asString]. 325230 325231 325232 325233 self nonEmpty printOn: aStream delimiter: ', ' . 325234 325235 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 325236 1 to: allElementsAsString size do: 325237 [:i | 325238 self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)) 325239 ].! ! 325240 325241!SetTest methodsFor: 'tests - printing'! 325242testPrintOnDelimiterLast 325243 325244 | aStream result allElementsAsString tmp | 325245 result:=''. 325246 aStream:= ReadWriteStream on: result. 325247 tmp:= OrderedCollection new. 325248 self nonEmpty do: [:each | tmp add: each asString]. 325249 325250 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 325251 325252 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 325253 1 to: allElementsAsString size do: 325254 [:i | 325255 i<(allElementsAsString size-1 ) 325256 ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. 325257 i=(allElementsAsString size-1) 325258 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 325259 i=(allElementsAsString size) 325260 ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. 325261 ].! ! 325262 325263!SetTest methodsFor: 'tests - printing'! 325264testStoreOn 325265" for the moment work only for collection that include simple elements such that Integer" 325266 325267"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 325268string := ''. 325269str := ReadWriteStream on: string. 325270elementsAsStringExpected := OrderedCollection new. 325271elementsAsStringObtained := OrderedCollection new. 325272self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 325273 325274self nonEmpty storeOn: str. 325275result := str contents . 325276cuttedResult := ( result findBetweenSubStrs: ';' ). 325277 325278index := 1. 325279 325280cuttedResult do: 325281 [ :each | 325282 index = 1 325283 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 325284 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 325285 elementsAsStringObtained add: tmp. 325286 index := index + 1. ] 325287 ifFalse: [ 325288 index < cuttedResult size 325289 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 325290 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 325291 elementsAsStringObtained add: tmp. 325292 index := index + 1.] 325293 ifFalse: [self assert: ( each = ' yourself)' ) ]. 325294 ] 325295 325296 ]. 325297 325298 325299 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 325300 325301! ! 325302 325303 325304!SetTest methodsFor: 'tests - remove'! 325305testRemoveAllError 325306 "self debug: #testRemoveElementThatExists" 325307 | el res subCollection | 325308 el := self elementNotIn. 325309 subCollection := self nonEmptyWithoutEqualElements copyWith: el. 325310 self 325311 should: [ res := self nonEmptyWithoutEqualElements removeAll: subCollection ] 325312 raise: Error! ! 325313 325314!SetTest methodsFor: 'tests - remove'! 325315testRemoveAllFoundIn 325316 "self debug: #testRemoveElementThatExists" 325317 | el res subCollection | 325318 el := self nonEmptyWithoutEqualElements anyOne. 325319 subCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. 325320 self 325321 shouldnt: 325322 [ res := self nonEmptyWithoutEqualElements removeAllFoundIn: subCollection ] 325323 raise: Error. 325324 self assert: self nonEmptyWithoutEqualElements size = 1. 325325 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 325326 325327!SetTest methodsFor: 'tests - remove'! 325328testRemoveAllSuchThat 325329 "self debug: #testRemoveElementThatExists" 325330 | el subCollection | 325331 el := self nonEmptyWithoutEqualElements anyOne. 325332 subCollection := self nonEmptyWithoutEqualElements copyWithout: el. 325333 self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | subCollection includes: each ]. 325334 self assert: self nonEmptyWithoutEqualElements size = 1. 325335 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 325336 325337!SetTest methodsFor: 'tests - remove'! 325338testRemoveElementFromEmpty 325339 "self debug: #testRemoveElementFromEmpty" 325340 self 325341 should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] 325342 raise: Error! ! 325343 325344!SetTest methodsFor: 'tests - remove'! 325345testRemoveElementReallyRemovesElement 325346 "self debug: #testRemoveElementReallyRemovesElement" 325347 | size | 325348 size := self nonEmptyWithoutEqualElements size. 325349 self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. 325350 self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! 325351 325352!SetTest methodsFor: 'tests - remove'! 325353testRemoveElementThatExists 325354 "self debug: #testRemoveElementThatExists" 325355 | el res | 325356 el := self nonEmptyWithoutEqualElements anyOne. 325357 self 325358 shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] 325359 raise: Error. 325360 self assert: res == el! ! 325361 325362 325363!SetTest methodsFor: 'tests - set arithmetic'! 325364containsAll: union of: one andOf: another 325365 325366 self assert: (one allSatisfy: [:each | union includes: each]). 325367 self assert: (another allSatisfy: [:each | union includes: each])! ! 325368 325369!SetTest methodsFor: 'tests - set arithmetic'! 325370numberOfSimilarElementsInIntersection 325371 ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! 325372 325373!SetTest methodsFor: 'tests - set arithmetic'! 325374testDifference 325375 "Answer the set theoretic difference of two collections." 325376 "self debug: #testDifference" 325377 325378 self assert: (self collection difference: self collection) isEmpty. 325379 self assert: (self empty difference: self collection) isEmpty. 325380 self assert: (self collection difference: self empty) = self collection 325381! ! 325382 325383!SetTest methodsFor: 'tests - set arithmetic'! 325384testDifferenceWithNonNullIntersection 325385 "Answer the set theoretic difference of two collections." 325386 "self debug: #testDifferenceWithNonNullIntersection" 325387 " #(1 2 3) difference: #(2 4) 325388 -> #(1 3)" 325389 | res overlapping | 325390 overlapping := self collectionClass 325391 with: self anotherElementOrAssociationNotIn 325392 with: self anotherElementOrAssociationIn. 325393 res := self collection difference: overlapping. 325394 self deny: (res includes: self anotherElementOrAssociationIn). 325395 overlapping do: [ :each | self deny: (res includes: each) ]! ! 325396 325397!SetTest methodsFor: 'tests - set arithmetic'! 325398testDifferenceWithSeparateCollection 325399 "Answer the set theoretic difference of two collections." 325400 "self debug: #testDifferenceWithSeparateCollection" 325401 | res separateCol | 325402 separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. 325403 res := self collection difference: separateCol. 325404 self deny: (res includes: self anotherElementOrAssociationNotIn). 325405 self assert: res = self collection. 325406 res := separateCol difference: self collection. 325407 self deny: (res includes: self collection anyOne). 325408 self assert: res = separateCol! ! 325409 325410!SetTest methodsFor: 'tests - set arithmetic'! 325411testIntersectionBasic 325412 "self debug: #testIntersectionBasic" 325413 | inter | 325414 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 325415 self deny: inter isEmpty. 325416 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 325417 325418!SetTest methodsFor: 'tests - set arithmetic'! 325419testIntersectionEmpty 325420 "self debug: #testIntersectionEmpty" 325421 325422 | inter | 325423 inter := self empty intersection: self empty. 325424 self assert: inter isEmpty. 325425 inter := self empty intersection: self collection . 325426 self assert: inter = self empty. 325427 ! ! 325428 325429!SetTest methodsFor: 'tests - set arithmetic'! 325430testIntersectionItself 325431 "self debug: #testIntersectionItself" 325432 325433 self assert: (self collection intersection: self collection) = self collection. 325434 ! ! 325435 325436!SetTest methodsFor: 'tests - set arithmetic'! 325437testIntersectionTwoSimilarElementsInIntersection 325438 "self debug: #testIntersectionBasic" 325439 | inter | 325440 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 325441 self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. 325442 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 325443 325444!SetTest methodsFor: 'tests - set arithmetic'! 325445testUnionOfEmpties 325446 "self debug: #testUnionOfEmpties" 325447 325448 self assert: (self empty union: self empty) isEmpty. 325449 325450 ! ! 325451 325452 325453!SetTest methodsFor: 'tests - size capacity' stamp: 'stephane.ducasse 10/6/2008 17:09'! 325454emptyButAllocatedWith20 325455 325456 ^ emptyButAllocatedWith20! ! 325457 325458!SetTest methodsFor: 'tests - size capacity' stamp: 'stephane.ducasse 10/6/2008 19:33'! 325459sizeCollection 325460 325461 ^ full! ! 325462 325463!SetTest methodsFor: 'tests - size capacity'! 325464testSize 325465 325466 | size | 325467 self assert: self empty size = 0. 325468 size := 0. 325469 self sizeCollection do: [ :each | size := size + 1]. 325470 325471 self assert: self sizeCollection size = size.! ! 325472 325473 325474!SetTest methodsFor: 'tests' stamp: 'nice 9/14/2009 21:08'! 325475testRemoveAll 325476 "Allows one to remove all elements of a collection" 325477 325478 | c1 c2 s2 | 325479 c1 := full. 325480 c2 := c1 copy. 325481 s2 := c2 size. 325482 325483 c1 removeAll. 325484 325485 self assert: c1 size = 0. 325486 self assert: c2 size = s2 description: 'the copy has not been modified'.! ! 325487 325488"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 325489 325490SetTest class 325491 uses: TAddForUniquenessTest classTrait + TCloneTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TRemoveTest classTrait + TCreationWithTest classTrait + TGrowableTest classTrait + TStructuralEqualityTest classTrait + TSizeTest classTrait + TPrintTest classTrait + TAsStringCommaAndDelimiterTest classTrait + TConvertTest classTrait + TConvertAsSortedTest classTrait + TIncludesWithIdentityCheckTest classTrait + TConcatenationEqualElementsRemovedTest classTrait + TOccurrencesTest classTrait 325492 instanceVariableNames: ''! 325493ColorMappingCanvas subclass: #ShadowDrawingCanvas 325494 instanceVariableNames: 'shadowColor' 325495 classVariableNames: '' 325496 poolDictionaries: '' 325497 category: 'Morphic-Support'! 325498 325499!ShadowDrawingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:14'! 325500shadowColor 325501 ^shadowColor! ! 325502 325503!ShadowDrawingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:14'! 325504shadowColor: aColor 325505 shadowColor := aColor! ! 325506 325507 325508!ShadowDrawingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:14'! 325509on: aCanvas 325510 myCanvas := aCanvas. 325511 shadowColor := Color black.! ! 325512 325513 325514!ShadowDrawingCanvas methodsFor: 'testing' stamp: 'ar 8/8/2001 14:16'! 325515isShadowDrawing 325516 ^true! ! 325517 325518 325519!ShadowDrawingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:13'! 325520image: aForm at: aPoint sourceRect: sourceRect rule: rule 325521 "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle." 325522 rule = Form paint ifTrue:[ 325523 ^myCanvas 325524 stencil: aForm 325525 at: aPoint 325526 sourceRect: sourceRect 325527 color: shadowColor 325528 ] ifFalse:[ 325529 ^myCanvas 325530 fillRectangle: (sourceRect translateBy: aPoint) 325531 color: shadowColor 325532 ].! ! 325533 325534!ShadowDrawingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:14'! 325535mapColor: aColor 325536 aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..." 325537 ^aColor isTransparent 325538 ifTrue:[aColor] 325539 ifFalse:[shadowColor]! ! 325540Object subclass: #Shape 325541 instanceVariableNames: '' 325542 classVariableNames: '' 325543 poolDictionaries: '' 325544 category: 'Polymorph-Geometry'! 325545 325546!Shape methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 10:48'! 325547basicContainsPoint: aPoint 325548 "Answer whether the receiver contains the given point." 325549 325550 ^self bounds containsPoint: aPoint! ! 325551 325552!Shape methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 10:25'! 325553bounds 325554 "Answer a rectangle that encloses the receiver." 325555 325556 self subclassResponsibility! ! 325557 325558!Shape methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 10:48'! 325559containsPoint: aPoint 325560 "Answer whether the receiver contains the given point." 325561 325562 ^self basicContainsPoint: aPoint! ! 325563Object subclass: #SharedPool 325564 instanceVariableNames: '' 325565 classVariableNames: '' 325566 poolDictionaries: '' 325567 category: 'System-Pools'! 325568!SharedPool commentStamp: '<historical>' prior: 0! 325569A shared pool represents a set of bindings which are accessible to all classes which import the pool in its 'pool dictionaries'. SharedPool is NOT a dictionary but rather a name space. Bindings are represented by 'class variables' - as long as we have no better way to represent them at least.! 325570 325571 325572"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 325573 325574SharedPool class 325575 instanceVariableNames: ''! 325576 325577!SharedPool class methodsFor: 'enumerating' stamp: 'tpr 12/14/2004 12:34'! 325578keysDo: aBlock 325579"A hopefully temporary fix for an issue arising from miss-spelled variable names in code being compiled. The correction code (see Class>possibleVariablesFor:continuedFrom: assumes that sharedPools are Dictionaries. The proper fix would involve making sure all pools are actually subclasses of SharedPool, which they are not currently." 325580 self bindingsDo:[:b| 325581 aBlock value: b key]! ! 325582 325583 325584!SharedPool class methodsFor: 'name lookup' stamp: 'ar 5/18/2003 17:46'! 325585bindingOf: varName 325586 "Answer the binding of some variable resolved in the scope of the receiver" 325587 | aSymbol binding | 325588 aSymbol := varName asSymbol. 325589 325590 "First look in classVar dictionary." 325591 binding := self classPool bindingOf: aSymbol. 325592 binding ifNotNil:[^binding]. 325593 325594 "Next look in shared pools." 325595 self sharedPools do:[:pool | 325596 binding := pool bindingOf: aSymbol. 325597 binding ifNotNil:[^binding]. 325598 ]. 325599 325600 "subclassing and environment are not preserved" 325601 ^nil! ! 325602 325603!SharedPool class methodsFor: 'name lookup' stamp: 'ar 5/18/2003 20:33'! 325604bindingsDo: aBlock 325605 ^self classPool bindingsDo: aBlock! ! 325606 325607!SharedPool class methodsFor: 'name lookup' stamp: 'ar 5/18/2003 18:14'! 325608classBindingOf: varName 325609 "For initialization messages grant the regular scope" 325610 ^super bindingOf: varName! ! 325611 325612!SharedPool class methodsFor: 'name lookup' stamp: 'tween 9/13/2004 10:10'! 325613hasBindingThatBeginsWith: aString 325614 "Answer true if the receiver has a binding that begins with aString, false otherwise" 325615 325616 "First look in classVar dictionary." 325617 (self classPool hasBindingThatBeginsWith: aString) ifTrue:[^true]. 325618 "Next look in shared pools." 325619 self sharedPools do:[:pool | 325620 (pool hasBindingThatBeginsWith: aString) ifTrue: [^true]]. 325621 ^false! ! 325622 325623!SharedPool class methodsFor: 'name lookup' stamp: 'tpr 5/29/2003 18:12'! 325624includesKey: aName 325625 "does this pool include aName" 325626 ^(self bindingOf: aName) notNil! ! 325627Object subclass: #SharedQueue 325628 instanceVariableNames: 'contentsArray readPosition writePosition accessProtect readSynch' 325629 classVariableNames: '' 325630 poolDictionaries: '' 325631 category: 'Collections-Sequenceable'! 325632!SharedQueue commentStamp: '<historical>' prior: 0! 325633I provide synchronized communication of arbitrary objects between Processes. An object is sent by sending the message nextPut: and received by sending the message next. If no object has been sent when a next message is sent, the Process requesting the object will be suspended until one is sent.! 325634 325635 325636!SharedQueue methodsFor: 'accessing' stamp: 'nice 4/20/2009 22:36'! 325637findFirst: aBlock 325638 "Answer the next object that satisfies aBlock, skipping any intermediate objects. 325639 If no object is found, answer <nil>. 325640 NOTA BENE: aBlock MUST NOT contain a non-local return (^)." 325641 325642 | value readPos | 325643 accessProtect critical: [ 325644 value := nil. 325645 readPos := readPosition. 325646 [readPos < writePosition 325647 and: [value isNil]] 325648 whileTrue: [ 325649 value := contentsArray at: readPos. 325650 readPos := readPos + 1. 325651 (aBlock value: value) 325652 ifFalse: [value := nil]]. 325653 readPosition >= writePosition ifTrue: [readSynch initSignals]. 325654 ]. 325655 ^value! ! 325656 325657!SharedQueue methodsFor: 'accessing' stamp: 'bf 2/11/2006 15:17'! 325658flush 325659 "Throw out all pending contents" 325660 accessProtect critical: [ 325661 "nil out flushed slots --bf 02/11/2006" 325662 contentsArray from: readPosition to: writePosition-1 put: nil. 325663 readPosition := 1. 325664 writePosition := 1. 325665 "Reset the read synchronization semaphore" 325666 readSynch initSignals].! ! 325667 325668!SharedQueue methodsFor: 'accessing' stamp: 'NS 6/18/2002 11:15'! 325669flushAllSuchThat: aBlock 325670 "Remove from the queue all objects that satisfy aBlock." 325671 | value newReadPos | 325672 accessProtect critical: [ 325673 newReadPos := writePosition. 325674 writePosition-1 to: readPosition by: -1 do: 325675 [:i | value := contentsArray at: i. 325676 contentsArray at: i put: nil. 325677 (aBlock value: value) ifTrue: [ 325678 "We take an element out of the queue, and therefore, we need to decrement 325679 the readSynch signals" 325680 readSynch wait. 325681 ] ifFalse: [ 325682 newReadPos := newReadPos - 1. 325683 contentsArray at: newReadPos put: value]]. 325684 readPosition := newReadPos]. 325685 ^value 325686! ! 325687 325688!SharedQueue methodsFor: 'accessing'! 325689next 325690 "Answer the object that was sent through the receiver first and has not 325691 yet been received by anyone. If no object has been sent, suspend the 325692 requesting process until one is." 325693 325694 | value | 325695 readSynch wait. 325696 accessProtect 325697 critical: [readPosition = writePosition 325698 ifTrue: 325699 [self error: 'Error in SharedQueue synchronization'. 325700 value := nil] 325701 ifFalse: 325702 [value := contentsArray at: readPosition. 325703 contentsArray at: readPosition put: nil. 325704 readPosition := readPosition + 1]]. 325705 ^value! ! 325706 325707!SharedQueue methodsFor: 'accessing' stamp: 'RAA 12/14/2000 10:25'! 325708nextOrNil 325709 "Answer the object that was sent through the receiver first and has not 325710 yet been received by anyone. If no object has been sent, answer <nil>." 325711 325712 | value | 325713 325714 accessProtect critical: [ 325715 readPosition >= writePosition ifTrue: [ 325716 value := nil 325717 ] ifFalse: [ 325718 value := contentsArray at: readPosition. 325719 contentsArray at: readPosition put: nil. 325720 readPosition := readPosition + 1 325721 ]. 325722 readPosition >= writePosition ifTrue: [readSynch initSignals]. 325723 ]. 325724 ^value! ! 325725 325726!SharedQueue methodsFor: 'accessing' stamp: 'di 10/1/2001 20:58'! 325727nextOrNilSuchThat: aBlock 325728 "Answer the next object that satisfies aBlock, skipping any intermediate objects. 325729 If no object has been sent, answer <nil> and leave me intact. 325730 NOTA BENE: aBlock MUST NOT contain a non-local return (^)." 325731 325732 | value readPos | 325733 accessProtect critical: [ 325734 value := nil. 325735 readPos := readPosition. 325736 [readPos < writePosition and: [value isNil]] whileTrue: [ 325737 value := contentsArray at: readPos. 325738 readPos := readPos + 1. 325739 (aBlock value: value) ifTrue: [ 325740 readPosition to: readPos - 1 do: [ :j | 325741 contentsArray at: j put: nil. 325742 ]. 325743 readPosition := readPos. 325744 ] ifFalse: [ 325745 value := nil. 325746 ]. 325747 ]. 325748 readPosition >= writePosition ifTrue: [readSynch initSignals]. 325749 ]. 325750 ^value 325751"=== 325752q := SharedQueue new. 3257531 to: 10 do: [ :i | q nextPut: i]. 325754c := OrderedCollection new. 325755[ 325756 v := q nextOrNilSuchThat: [ :e | e odd]. 325757 v notNil 325758] whileTrue: [ 325759 c add: {v. q size} 325760]. 325761{c. q} explore 325762==="! ! 325763 325764!SharedQueue methodsFor: 'accessing'! 325765nextPut: value 325766 "Send value through the receiver. If a Process has been suspended 325767 waiting to receive a value through the receiver, allow it to proceed." 325768 325769 accessProtect 325770 critical: [writePosition > contentsArray size 325771 ifTrue: [self makeRoomAtEnd]. 325772 contentsArray at: writePosition put: value. 325773 writePosition := writePosition + 1]. 325774 readSynch signal. 325775 ^value! ! 325776 325777!SharedQueue methodsFor: 'accessing' stamp: 'tpr 1/5/2005 18:22'! 325778peek 325779 "Answer the object that was sent through the receiver first and has not 325780 yet been received by anyone but do not remove it from the receiver. If 325781 no object has been sent, return nil" 325782 325783 | value | 325784 accessProtect 325785 critical: [readPosition >= writePosition 325786 ifTrue: [readPosition := 1. 325787 writePosition := 1. 325788 value := nil] 325789 ifFalse: [value := contentsArray at: readPosition]]. 325790 ^value! ! 325791 325792!SharedQueue methodsFor: 'accessing'! 325793size 325794 "Answer the number of objects that have been sent through the 325795 receiver and not yet received by anyone." 325796 325797 ^writePosition - readPosition! ! 325798 325799 325800!SharedQueue methodsFor: 'testing'! 325801isEmpty 325802 "Answer whether any objects have been sent through the receiver and 325803 not yet received by anyone." 325804 325805 ^readPosition = writePosition! ! 325806 325807 325808!SharedQueue methodsFor: 'private' stamp: 'nice 4/4/2006 22:09'! 325809initialize: size 325810 325811 contentsArray := Array new: size. 325812 readPosition := 1. 325813 writePosition := 1. 325814 accessProtect := Semaphore forMutualExclusion. 325815 readSynch := Semaphore new! ! 325816 325817!SharedQueue methodsFor: 'private' stamp: 'bf 10/25/2005 15:33'! 325818makeRoomAtEnd 325819 | contentsSize | 325820 readPosition = 1 325821 ifTrue: [contentsArray := contentsArray , (Array new: 10)] 325822 ifFalse: 325823 [contentsSize := writePosition - readPosition. 325824 "BLT direction ok for this. Lots faster!!!!!!!!!!!! SqR!!!! 4/10/2000 10:47" 325825 contentsArray 325826 replaceFrom: 1 325827 to: contentsSize 325828 with: contentsArray 325829 startingAt: readPosition. 325830 "nil out remainder --bf 10/25/2005" 325831 contentsArray 325832 from: contentsSize+1 325833 to: contentsArray size 325834 put: nil. 325835 readPosition := 1. 325836 writePosition := contentsSize + 1]! ! 325837 325838"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 325839 325840SharedQueue class 325841 instanceVariableNames: ''! 325842 325843!SharedQueue class methodsFor: 'instance creation'! 325844new 325845 "Answer a new instance of SharedQueue that has 10 elements." 325846 325847 ^self new: 10! ! 325848 325849!SharedQueue class methodsFor: 'instance creation' stamp: 'nice 4/4/2006 22:10'! 325850new: anInteger 325851 ^super new initialize: anInteger! ! 325852Stream subclass: #SharedQueue2 325853 instanceVariableNames: 'monitor items' 325854 classVariableNames: '' 325855 poolDictionaries: '' 325856 category: 'Collections-Sequenceable'! 325857!SharedQueue2 commentStamp: 'ls 6/25/2005 13:48' prior: 0! 325858An implementation of a shared queue based on class Monitor. Clients may may place items on the queue using nextPut: or remove them using methods like next or nextOrNil. Items are removed in first-in first-out (FIFO) order. It is safe for multiple threads to access the same shared queue, which is why this is a "shared" queue. 325859 325860[monitor] is used to synchronize access from multiple threads. 325861 325862[items] is an ordered collection holding the items that are in the queue. New items are added at the end, and old items are removed from the beginning. 325863 325864All methods must hold the monitor while they run. 325865! 325866 325867 325868!SharedQueue2 methodsFor: 'accessing' stamp: 'ls 6/25/2005 14:00'! 325869next 325870 ^monitor critical: [ 325871 monitor waitUntil: [ items isEmpty not ]. 325872 items removeFirst ] 325873! ! 325874 325875!SharedQueue2 methodsFor: 'accessing' stamp: 'ls 6/25/2005 14:00'! 325876nextOrNil 325877 ^monitor critical: [ 325878 items isEmpty ifTrue: [ nil ] ifFalse: [ items removeFirst ] ]! ! 325879 325880!SharedQueue2 methodsFor: 'accessing' stamp: 'ls 6/25/2005 14:16'! 325881nextOrNilSuchThat: aBlock 325882 "Answer the next object that satisfies aBlock, skipping any intermediate objects. 325883 If no such object has been queued, answer <nil> and leave me intact." 325884 325885 | index | 325886 ^monitor critical: [ 325887 index := items findFirst: aBlock. 325888 index = 0 ifTrue: [ 325889 nil ] 325890 ifFalse: [ 325891 items removeAt: index ] ]. 325892! ! 325893 325894!SharedQueue2 methodsFor: 'accessing' stamp: 'ls 6/25/2005 13:58'! 325895nextPut: item 325896 monitor critical: [ 325897 items addLast: item. 325898 monitor signalAll. ] 325899! ! 325900 325901!SharedQueue2 methodsFor: 'accessing' stamp: 'ls 6/25/2005 14:00'! 325902peek 325903 "Answer the object that was sent through the receiver first and has not 325904 yet been received by anyone but do not remove it from the receiver. If 325905 no object has been sent, return nil" 325906 ^monitor critical: [ 325907 items isEmpty ifTrue: [ nil ] ifFalse: [ items first ] ] 325908! ! 325909 325910 325911!SharedQueue2 methodsFor: 'initializing' stamp: 'alain.plantec 5/28/2009 10:22'! 325912initialize 325913 super initialize. 325914 monitor := Monitor new. 325915 items := OrderedCollection new. 325916! ! 325917 325918 325919!SharedQueue2 methodsFor: 'printing' stamp: 'ls 6/25/2005 13:56'! 325920printOn: aStream 325921 monitor critical: [ 325922 aStream 325923 nextPutAll: self class name; 325924 nextPutAll: ' with '; 325925 print: items size; 325926 nextPutAll: ' items' ].! ! 325927 325928 325929!SharedQueue2 methodsFor: 'size' stamp: 'ls 6/25/2005 14:03'! 325930isEmpty 325931 ^monitor critical: [ items isEmpty ]! ! 325932 325933!SharedQueue2 methodsFor: 'size' stamp: 'ls 6/25/2005 14:04'! 325934size 325935 ^monitor critical: [ items size ]! ! 325936 325937"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 325938 325939SharedQueue2 class 325940 instanceVariableNames: ''! 325941 325942!SharedQueue2 class methodsFor: 'instance creation' stamp: 'ls 6/25/2005 13:53'! 325943new 325944 ^self basicNew initialize! ! 325945TestCase subclass: #SharedQueue2Test 325946 instanceVariableNames: '' 325947 classVariableNames: '' 325948 poolDictionaries: '' 325949 category: 'CollectionsTests-Sequenceable'! 325950 325951!SharedQueue2Test methodsFor: 'testing' stamp: 'ls 6/25/2005 13:49'! 325952testBasics 325953 | q | 325954 q := SharedQueue2 new. 325955 325956 self should: [ q nextOrNil = nil ]. 325957 325958 q nextPut: 5. 325959 self should: [ q nextOrNil = 5 ]. 325960 self should: [ q nextOrNil = nil ]. 325961 325962! ! 325963 325964!SharedQueue2Test methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:10'! 325965testContention1 325966 "here is a test case that breaks the standard SharedQueue from Squeak 3.8" 325967 325968 | q r1 r2 | 325969 q := SharedQueue2 new. 325970 q nextPut: 5. 325971 q nextPut: 10. 325972 325973 self should: [ q nextOrNil = 5 ]. 325974 325975 [ r1 := q next ] fork. 325976 [ r2 := q next ] fork. 325977 Processor yield. "let the above two threads block" 325978 325979 q nextPut: 10. 325980 Processor yield. 325981 325982 self should: [ r1 = 10 ]. 325983 self should: [ r2 = 10 ]. 325984 self should: [ q nextOrNil = nil ]. 325985! ! 325986 325987!SharedQueue2Test methodsFor: 'testing' stamp: 'ls 6/25/2005 14:15'! 325988testNextOrNilSuchThat 325989 | q item | 325990 q := SharedQueue2 new. 325991 q nextPut: 5. 325992 q nextPut: 6. 325993 325994 item := q nextOrNilSuchThat: [ :x | x even ]. 325995 self should: [ item = 6 ]. 325996 325997 self should: [ q nextOrNil = 5 ]. 325998 self should: [ q nextOrNil = nil ]. 325999! ! 326000TextConverter subclass: #ShiftJISTextConverter 326001 instanceVariableNames: '' 326002 classVariableNames: '' 326003 poolDictionaries: '' 326004 category: 'Multilingual-TextConversion'! 326005!ShiftJISTextConverter commentStamp: '<historical>' prior: 0! 326006Text converter for Shift-JIS. Mac and Windows in Japanese mode use this encoding.! 326007 326008 326009!ShiftJISTextConverter methodsFor: 'conversion' stamp: 'ar 4/9/2005 22:31'! 326010nextFromStream: aStream 326011 | character1 character2 value1 value2 char1Value result | 326012 aStream isBinary ifTrue: [^ aStream basicNext]. 326013 character1 := aStream basicNext. 326014 character1 isNil ifTrue: [^ nil]. 326015 char1Value := character1 asciiValue. 326016 (char1Value < 16r81) ifTrue: [^ character1]. 326017 (char1Value > 16rA0 and: [char1Value < 16rE0]) ifTrue: [^ self katakanaValue: char1Value]. 326018 326019 character2 := aStream basicNext. 326020 character2 = nil ifTrue: [^ nil "self errorMalformedInput"]. 326021 value1 := character1 asciiValue. 326022 character1 asciiValue >= 224 ifTrue: [value1 := value1 - 64]. 326023 value1 := value1 - 129 bitShift: 1. 326024 value2 := character2 asciiValue. 326025 character2 asciiValue >= 128 ifTrue: [value2 := value2 - 1]. 326026 character2 asciiValue >= 158 ifTrue: [ 326027 value1 := value1 + 1. 326028 value2 := value2 - 158 326029 ] ifFalse: [value2 := value2 - 64]. 326030 result := Character leadingChar: self leadingChar code: value1 * 94 + value2. 326031 ^ self toUnicode: result 326032! ! 326033 326034!ShiftJISTextConverter methodsFor: 'conversion' stamp: 'ar 4/12/2005 14:10'! 326035nextPut: aCharacter toStream: aStream 326036 | value leadingChar aChar | 326037 aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream]. 326038 aCharacter isTraditionalDomestic ifTrue: [ 326039 aChar := aCharacter. 326040 value := aCharacter charCode. 326041 ] ifFalse: [ 326042 value := aCharacter charCode. 326043 (16rFF61 <= value and: [value <= 16rFF9F]) ifTrue: [ 326044 aStream basicNextPut: (self sjisKatakanaFor: value). 326045 ^ aStream 326046 ]. 326047 aChar := JISX0208 charFromUnicode: value. 326048 aChar ifNil: [^ aStream]. 326049 value := aChar charCode. 326050 ]. 326051 leadingChar := aChar leadingChar. 326052 leadingChar = 0 ifTrue: [ 326053 aStream basicNextPut: (Character value: value). 326054 ^ aStream. 326055 ]. 326056 leadingChar == self leadingChar ifTrue: [ 326057 | upper lower | 326058 upper := value // 94 + 33. 326059 lower := value \\ 94 + 33. 326060 upper \\ 2 == 1 ifTrue: [ 326061 upper := upper + 1 / 2 + 112. 326062 lower := lower + 31 326063 ] ifFalse: [ 326064 upper := upper / 2 + 112. 326065 lower := lower + 125 326066 ]. 326067 upper >= 160 ifTrue: [upper := upper + 64]. 326068 lower >= 127 ifTrue: [lower := lower + 1]. 326069 aStream basicNextPut: (Character value: upper). 326070 aStream basicNextPut: (Character value: lower). 326071 ^ aStream 326072 ]. 326073! ! 326074 326075 326076!ShiftJISTextConverter methodsFor: 'friend' stamp: 'yo 10/23/2002 15:28'! 326077leadingChar 326078 326079 ^ JISX0208 leadingChar 326080! ! 326081 326082 326083!ShiftJISTextConverter methodsFor: 'private' stamp: 'ar 4/9/2005 22:31'! 326084katakanaValue: code 326085 326086 ^ Character leadingChar: JapaneseEnvironment leadingChar code: (#( 326087 16rFFFD 16rFF61 16rFF62 16rFF63 16rFF64 16rFF65 16rFF66 16rFF67 326088 16rFF68 16rFF69 16rFF6A 16rFF6B 16rFF6C 16rFF6D 16rFF6E 16rFF6F 326089 16rFF70 16rFF71 16rFF72 16rFF73 16rFF74 16rFF75 16rFF76 16rFF77 326090 16rFF78 16rFF79 16rFF7A 16rFF7B 16rFF7C 16rFF7D 16rFF7E 16rFF7F 326091 16rFF80 16rFF81 16rFF82 16rFF83 16rFF84 16rFF85 16rFF86 16rFF87 326092 16rFF88 16rFF89 16rFF8A 16rFF8B 16rFF8C 16rFF8D 16rFF8E 16rFF8F 326093 16rFF90 16rFF91 16rFF92 16rFF93 16rFF94 16rFF95 16rFF96 16rFF97 326094 16rFF98 16rFF99 16rFF9A 16rFF9B 16rFF9C 16rFF9D 16rFF9E 16rFF9F 326095) at: (code - 16r9F)). 326096! ! 326097 326098!ShiftJISTextConverter methodsFor: 'private' stamp: 'yo 3/1/2004 22:05'! 326099sjisKatakanaFor: value 326100 326101 ^ Character value: (#( 326102 16rA0 16rA1 16rA2 16rA3 16rA4 16rA5 16rA6 16rA7 326103 16rA8 16rA9 16rAA 16rAB 16rAC 16rAD 16rAE 16rAF 326104 16rB0 16rB1 16rB2 16rB3 16rB4 16rB5 16rB6 16rB7 326105 16rB8 16rB9 16rBA 16rBB 16rBC 16rBD 16rBE 16rBF 326106 16rC0 16rC1 16rC2 16rC3 16rC4 16rC5 16rC6 16rC7 326107 16rC8 16rC9 16rCA 16rCB 16rCC 16rCD 16rCE 16rCF 326108 16rD0 16rD1 16rD2 16rD3 16rD4 16rD5 16rD6 16rD7 326109 16rD8 16rD9 16rDA 16rDB 16rDC 16rDD 16rDE 16rDF 326110 ) at: value - 16rFF5F). 326111 326112! ! 326113 326114!ShiftJISTextConverter methodsFor: 'private' stamp: 'ar 4/9/2005 22:31'! 326115toUnicode: aChar 326116 326117 ^ Character leadingChar: JapaneseEnvironment leadingChar code: aChar asUnicode. 326118! ! 326119 326120"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 326121 326122ShiftJISTextConverter class 326123 instanceVariableNames: ''! 326124 326125!ShiftJISTextConverter class methodsFor: 'utilities' stamp: 'yo 12/25/2003 21:33'! 326126encodingNames 326127 326128 ^ #('shift-jis' 'shift_jis' 'sjis') copy 326129! ! 326130ArrayedCollection variableWordSubclass: #ShortIntegerArray 326131 instanceVariableNames: '' 326132 classVariableNames: 'LastSaveOrder' 326133 poolDictionaries: '' 326134 category: 'Balloon-Collections'! 326135!ShortIntegerArray commentStamp: '<historical>' prior: 0! 326136ShortIntegerArray is an array for efficiently representing integers in the 16bit range.! 326137 326138 326139!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'! 326140at: index 326141 "Return the 16-bit integer value at the given index of the receiver." 326142 326143 <primitive: 143> 326144 index isInteger ifTrue: [self errorSubscriptBounds: index]. 326145 index isNumber ifTrue: [^ self at: index truncated]. 326146 self errorNonIntegerIndex. 326147! ! 326148 326149!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'! 326150at: index put: value 326151 "Store the given 16-bit integer at the given index in the receiver." 326152 326153 <primitive: 144> 326154 index isInteger 326155 ifTrue: [ 326156 (index >= 1 and: [index <= self size]) 326157 ifTrue: [self errorImproperStore] 326158 ifFalse: [self errorSubscriptBounds: index]]. 326159 index isNumber ifTrue: [^ self at: index truncated put: value]. 326160 self errorNonIntegerIndex. 326161! ! 326162 326163!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'! 326164defaultElement 326165 ^0! ! 326166 326167!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'! 326168size 326169 ^super size * 2! ! 326170 326171 326172!ShortIntegerArray methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:11'! 326173bytesPerBasicElement 326174 ^4! ! 326175 326176!ShortIntegerArray methodsFor: 'objects from disk' stamp: 'nk 3/7/2004 13:54'! 326177bytesPerElement 326178 ^2! ! 326179 326180!ShortIntegerArray methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 18:41'! 326181restoreEndianness 326182 "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian. 326183 Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap." 326184 326185 | hack blt | 326186 SmalltalkImage current isLittleEndian ifTrue: [ 326187 "The implementation is a hack, but fast for large ranges" 326188 hack := Form new hackBits: self. 326189 blt := (BitBlt toForm: hack) sourceForm: hack. 326190 blt combinationRule: Form reverse. "XOR" 326191 blt sourceY: 0; destY: 0; height: hack height; width: 1. 326192 blt sourceX: 0; destX: 1; copyBits. "Exchange bytes 0 and 1" 326193 blt sourceX: 1; destX: 0; copyBits. 326194 blt sourceX: 0; destX: 1; copyBits. 326195 blt sourceX: 2; destX: 3; copyBits. "Exchange bytes 2 and 3" 326196 blt sourceX: 3; destX: 2; copyBits. 326197 blt sourceX: 2; destX: 3; copyBits 326198 ]. 326199! ! 326200 326201!ShortIntegerArray methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 18:55'! 326202writeOn: aStream 326203 326204 aStream nextInt32Put: self basicSize. 326205 326206 1 to: self basicSize do: [ :i | | w | 326207 w := self basicAt: i. 326208 SmalltalkImage current isLittleEndian 326209 ifFalse: [ aStream nextNumber: 4 put: w ] 326210 ifTrue: [ aStream 326211 nextPut: (w digitAt: 2); 326212 nextPut: (w digitAt: 1); 326213 nextPut: (w digitAt: 4); 326214 nextPut: (w digitAt: 3) ]].! ! 326215 326216 326217!ShortIntegerArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:35'! 326218pvtAt: index 326219 "Private -- for swapping only" 326220 <primitive: 143> 326221 index isInteger ifTrue: [self errorSubscriptBounds: index]. 326222 index isNumber ifTrue: [^ self at: index truncated]. 326223 self errorNonIntegerIndex. 326224! ! 326225 326226!ShortIntegerArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:35'! 326227pvtAt: index put: value 326228 "Private -- for swapping only" 326229 <primitive: 144> 326230 index isInteger 326231 ifTrue: [ 326232 (index >= 1 and: [index <= self size]) 326233 ifTrue: [self errorImproperStore] 326234 ifFalse: [self errorSubscriptBounds: index]]. 326235 index isNumber ifTrue: [^ self at: index truncated put: value]. 326236 self errorNonIntegerIndex. 326237! ! 326238 326239!ShortIntegerArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:37'! 326240swapShortObjects 326241 "Private -- swap all the short quantities in the receiver" 326242 | tmp | 326243 1 to: self basicSize do:[:i| 326244 tmp := (self pvtAt: i * 2). 326245 self pvtAt: i * 2 put: (self pvtAt: i * 2 - 1). 326246 self pvtAt: i * 2 - 1 put: tmp. 326247 ]! ! 326248 326249"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 326250 326251ShortIntegerArray class 326252 instanceVariableNames: ''! 326253 326254!ShortIntegerArray class methodsFor: 'initialization' stamp: 'bf 1/7/2005 16:39'! 326255initialize 326256 "ShortIntegerArray initialize" 326257 Smalltalk addToStartUpList: self after: Delay. 326258 LastSaveOrder := self new: 2. 326259 LastSaveOrder at: 1 put: 42. 326260 LastSaveOrder at: 2 put: 13.! ! 326261 326262!ShortIntegerArray class methodsFor: 'initialization' stamp: 'ar 1/15/1999 17:33'! 326263startUp 326264 "Check if the word order has changed from the last save" 326265 ((LastSaveOrder at: 1) = 42 and:[(LastSaveOrder at: 2) = 13]) 326266 ifTrue:[^self]. "Okay" 326267 ((LastSaveOrder at: 2) = 42 and:[(LastSaveOrder at: 1) = 13]) 326268 ifTrue:[^self swapShortObjects]. "Reverse guys" 326269 ^self error:'This must never happen'! ! 326270 326271!ShortIntegerArray class methodsFor: 'initialization' stamp: 'sd 9/30/2003 13:46'! 326272startUpFrom: anImageSegment 326273 "In this case, do we need to swap word halves when reading this segement?" 326274 326275 ^ (SmalltalkImage current endianness) ~~ (anImageSegment endianness) 326276 ifTrue: [Message selector: #swapShortObjects] "will be run on each instance" 326277 ifFalse: [nil]. 326278! ! 326279 326280!ShortIntegerArray class methodsFor: 'initialization' stamp: 'ar 1/15/1999 17:40'! 326281swapShortObjects 326282 self allSubInstancesDo:[:inst| inst swapShortObjects]! ! 326283 326284 326285!ShortIntegerArray class methodsFor: 'instance creation' stamp: 'ar 1/15/1999 17:28'! 326286new: n 326287 ^super new: n + 1 // 2! ! 326288ShortIntegerArray variableWordSubclass: #ShortPointArray 326289 instanceVariableNames: '' 326290 classVariableNames: '' 326291 poolDictionaries: '' 326292 category: 'Balloon-Collections'! 326293!ShortPointArray commentStamp: '<historical>' prior: 0! 326294This class stores points that are in short integer range (e.g., -32767 <= value <= 32768). It is used to pass data efficiently to the primitive level during high-bandwidth 2D graphics operations.! 326295 326296 326297!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'! 326298at: index 326299 "Return the element (e.g., point) at the given index" 326300 ^(super at: index * 2 - 1) @ (super at: index * 2)! ! 326301 326302!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'! 326303at: index put: aPoint 326304 "Store the argument aPoint at the given index" 326305 super at: index * 2 - 1 put: aPoint x asInteger. 326306 super at: index * 2 put: aPoint y asInteger. 326307 ^aPoint! ! 326308 326309!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/10/1998 19:41'! 326310bounds 326311 | min max | 326312 min := max := self at: 1. 326313 self do:[:pt| 326314 min := min min: pt. 326315 max := max max: pt]. 326316 ^min corner: max 326317 ! ! 326318 326319!ShortPointArray methodsFor: 'accessing' stamp: 'yo 3/6/2004 12:56'! 326320bytesPerElement 326321 326322 ^ 4. 326323 ! ! 326324 326325!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'! 326326defaultElement 326327 "Return the default element of the receiver" 326328 ^0@0! ! 326329 326330!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'! 326331size 326332 ^self basicSize! ! 326333 326334"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 326335 326336ShortPointArray class 326337 instanceVariableNames: ''! 326338 326339!ShortPointArray class methodsFor: 'instance creation' stamp: 'ar 1/15/1999 17:40'! 326340new: n 326341 ^super new: n * 2! ! 326342ArrayedCollection variableWordSubclass: #ShortRunArray 326343 instanceVariableNames: '' 326344 classVariableNames: 'LastSaveOrder' 326345 poolDictionaries: '' 326346 category: 'Balloon-Collections'! 326347!ShortRunArray commentStamp: '<historical>' prior: 0! 326348This class is run-length encoded representation of short integer (e.g., 16bit signed integer values)! 326349 326350 326351!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:26'! 326352at: index 326353 "Return the short value at the given index" 326354 | rlIndex | 326355 index < 1 ifTrue:[^self errorSubscriptBounds: index]. 326356 rlIndex := index. 326357 self lengthsAndValuesDo:[:runLength :runValue| 326358 rlIndex <= runLength ifTrue:[^runValue]. 326359 rlIndex := rlIndex - runLength]. 326360 "Not found. Must be out of range" 326361 ^self errorSubscriptBounds: index! ! 326362 326363!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:18'! 326364at: index put: value 326365 "ShortRunArrays are read-only" 326366 ^self shouldNotImplement.! ! 326367 326368!ShortRunArray methodsFor: 'accessing' stamp: 'yo 3/6/2004 14:19'! 326369bytesPerElement 326370 326371 ^ 4 326372! ! 326373 326374!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:39'! 326375compressionRatio 326376 "Return the compression ratio. 326377 The compression ratio is computed based 326378 on how much space would be needed to 326379 store the receiver in a ShortIntegerArray" 326380 ^(self size asFloat * 0.5) "Would need only half of the amount in ShortIntegerArray" 326381 / (self runSize max: 1)! ! 326382 326383!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:21'! 326384lengthAtRun: index 326385 "Return the length of the run starting at the given index" 326386 ^(self basicAt: index) bitShift: -16! ! 326387 326388!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:28'! 326389runSize 326390 "Return the number of runs in the receiver" 326391 ^self basicSize! ! 326392 326393!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:28'! 326394size 326395 "Return the number of elements stored in the receiver" 326396 | n | 326397 n := 0. 326398 "Note: The following loop is open-coded for speed" 326399 1 to: self basicSize do:[:i| 326400 n := n + ((self basicAt: i) bitShift: -16). 326401 ]. 326402 ^n! ! 326403 326404!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:29'! 326405species 326406 "Answer the preferred class for reconstructing the receiver." 326407 ^ShortIntegerArray! ! 326408 326409!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:22'! 326410valueAtRun: index 326411 "Return the value of the run starting at the given index" 326412 | uShort | 326413 uShort := (self basicAt: index) bitAnd: 16rFFFF. 326414 ^(uShort bitAnd: 16r7FFF) - (uShort bitAnd: 16r8000)! ! 326415 326416 326417!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 11/3/1998 17:31'! 326418do: aBlock 326419 "Evaluate aBlock with all elements of the receiver" 326420 self lengthsAndValuesDo:[:runLength :runValue| 326421 "Use to:do: instead of timesRepeat: for compiler optimization" 326422 1 to: runLength do:[:i| 326423 aBlock value: runValue. 326424 ]. 326425 ].! ! 326426 326427!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 12/27/1999 13:44'! 326428lengthsAndValuesDo: aBlock 326429 "Evaluate aBlock with the length and value of each run in the receiver" 326430 ^self runsAndValuesDo: aBlock! ! 326431 326432!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 12/27/1999 13:44'! 326433runsAndValuesDo: aBlock 326434 "Evaluate aBlock with the length and value of each run in the receiver" 326435 | basicValue length value | 326436 1 to: self basicSize do:[:i| 326437 basicValue := self basicAt: i. 326438 length := basicValue bitShift: -16. 326439 value := basicValue bitAnd: 16rFFFF. 326440 value := (value bitAnd: 16r7FFF) - (value bitAnd: 16r8000). 326441 aBlock value: length value: value. 326442 ].! ! 326443 326444!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 11/3/1998 21:05'! 326445valuesCollect: aBlock 326446 "Evaluate aBlock with each of the receiver's values as the argument. 326447 Collect the resulting values into a collection like the receiver. Answer 326448 the new collection." 326449 | newArray newValue | 326450 newArray := self class basicNew: self basicSize. 326451 1 to: self runSize do:[:i| 326452 newValue := aBlock value: (self valueAtRun: i). 326453 newArray setRunAt: i toLength: (self lengthAtRun: i) value: newValue. 326454 ]. 326455 ^newArray! ! 326456 326457!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 11/15/1998 17:22'! 326458valuesDo: aBlock 326459 self lengthsAndValuesDo:[:runLength :runValue| aBlock value: runValue]! ! 326460 326461 326462!ShortRunArray methodsFor: 'objects from disk' stamp: 'yo 3/6/2004 15:10'! 326463restoreEndianness 326464 "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian. 326465 Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap." 326466 326467 | w b1 b2 b3 b4 | 326468 SmalltalkImage current isLittleEndian ifTrue: [ 326469 1 to: self basicSize do: [:i | 326470 w := self basicAt: i. 326471 b1 := w digitAt: 1. 326472 b2 := w digitAt: 2. 326473 b3 := w digitAt: 3. 326474 b4 := w digitAt: 4. 326475 w := (b1 << 24) + (b2 << 16) + (b3 << 8) + b4. 326476 self basicAt: i put: w. 326477 ] 326478 ]. 326479 326480! ! 326481 326482 326483!ShortRunArray methodsFor: 'printing' stamp: 'ar 11/3/1998 17:41'! 326484printOn: aStream 326485 aStream nextPutAll: self class name; nextPutAll:' ( '. 326486 self lengthsAndValuesDo:[:runLength :runValue | 326487 aStream 326488 nextPutAll:' ('; 326489 print: runLength; 326490 space; 326491 print: runValue; 326492 nextPut:$). 326493 ]. 326494 aStream nextPutAll:' )'.! ! 326495 326496 326497!ShortRunArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:47'! 326498pvtAt: index 326499 "Private -- for swapping only" 326500 <primitive: 143> 326501 index isInteger ifTrue: [self errorSubscriptBounds: index]. 326502 index isNumber ifTrue: [^ self at: index truncated]. 326503 self errorNonIntegerIndex. 326504! ! 326505 326506!ShortRunArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:47'! 326507pvtAt: index put: value 326508 "Private -- for swapping only" 326509 <primitive: 144> 326510 index isInteger 326511 ifTrue: [ 326512 (index >= 1 and: [index <= self size]) 326513 ifTrue: [self errorImproperStore] 326514 ifFalse: [self errorSubscriptBounds: index]]. 326515 index isNumber ifTrue: [^ self at: index truncated put: value]. 326516 self errorNonIntegerIndex. 326517! ! 326518 326519!ShortRunArray methodsFor: 'private' stamp: 'ar 11/3/1998 21:02'! 326520setRunAt: i toLength: runLength value: value 326521 (value < -16r7FFF or:[value > 16r8000]) ifTrue:[^self errorImproperStore]. 326522 (runLength < 0 or:[runLength > 16rFFFF]) ifTrue:[^self errorImproperStore]. 326523 self basicAt: i put: (runLength bitShift: 16) + 326524 ((value bitAnd: 16r7FFF) - (value bitAnd: -16r8000)).! ! 326525 326526!ShortRunArray methodsFor: 'private' stamp: 'ar 11/3/1998 21:00'! 326527setRuns: runArray values: valueArray 326528 | runLength value | 326529 1 to: runArray size do:[:i| 326530 runLength := runArray at: i. 326531 value := valueArray at: i. 326532 self setRunAt: i toLength: runLength value: value. 326533 ].! ! 326534 326535!ShortRunArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:48'! 326536swapRuns 326537 "Private -- swap length/value pairs in the receiver" 326538 | tmp | 326539 1 to: self basicSize do:[:i| 326540 tmp := (self pvtAt: i * 2). 326541 self pvtAt: i * 2 put: (self pvtAt: i * 2 - 1). 326542 self pvtAt: i * 2 - 1 put: tmp. 326543 ]! ! 326544 326545"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 326546 326547ShortRunArray class 326548 instanceVariableNames: ''! 326549 326550!ShortRunArray class methodsFor: 'initialization' stamp: 'bf 1/7/2005 16:40'! 326551initialize 326552 "ShortRunArray initialize" 326553 Smalltalk addToStartUpList: self after: Delay. 326554 LastSaveOrder := #(42 42 42) as: self.! ! 326555 326556!ShortRunArray class methodsFor: 'initialization' stamp: 'ar 1/15/1999 17:46'! 326557startUp 326558 "Check if the word order has changed from the last save" 326559 ((LastSaveOrder valueAtRun: 1) = 42 and:[(LastSaveOrder lengthAtRun: 1) = 3]) 326560 ifTrue:[^self]. "Okay" 326561 ((LastSaveOrder lengthAtRun: 1) = 42 and:[(LastSaveOrder valueAtRun: 1) = 3]) 326562 ifTrue:[^self swapRuns]. "Reverse guys" 326563 ^self error:'This must never happen'! ! 326564 326565!ShortRunArray class methodsFor: 'initialization' stamp: 'nk 2/22/2005 15:29'! 326566startUpFrom: anImageSegment 326567 "In this case, do we need to swap word halves when reading this segement?" 326568 326569 ^SmalltalkImage current endianness ~~ anImageSegment endianness 326570 ifTrue: [Message selector: #swapRuns "will be run on each instance"] 326571 ifFalse: [nil]! ! 326572 326573!ShortRunArray class methodsFor: 'initialization' stamp: 'ar 1/15/1999 17:47'! 326574swapRuns 326575 self allSubInstancesDo:[:inst| inst swapRuns]! ! 326576 326577 326578!ShortRunArray class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 17:12'! 326579new: n 326580 "ShortRunArrays must be created with either 326581 someCollection as: ShortRunArray 326582 or by using 326583 ShortRunArray runs: runCollection values: valueCollection. 326584 " 326585 ^self shouldNotImplement! ! 326586 326587!ShortRunArray class methodsFor: 'instance creation' stamp: 'PeterHugossonMiller 9/3/2009 11:21'! 326588newFrom: aCollection 326589 "Compress aCollection into a ShortRunArray" 326590 | lastValue lastRun runs values | 326591 aCollection isEmpty ifTrue:[^self runs:#() values: #()]. 326592 runs := (WordArray new: 100) writeStream. 326593 values := (ShortIntegerArray new: 100) writeStream. 326594 lastValue := aCollection first. 326595 lastRun := 0. 326596 aCollection do:[:item| 326597 (item = lastValue and:[lastRun < 16r8000]) ifTrue:[ 326598 lastRun := lastRun + 1. 326599 ] ifFalse:[ 326600 runs nextPut: lastRun. 326601 values nextPut: lastValue. 326602 lastRun := 1. 326603 lastValue := item. 326604 ]. 326605 ]. 326606 runs nextPut: lastRun. 326607 values nextPut: lastValue. 326608 ^self runs: runs contents values: values contents! ! 326609 326610!ShortRunArray class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 17:12'! 326611runs: runCollection values: valueCollection 326612 ^(self basicNew: runCollection size) setRuns: runCollection values: valueCollection! ! 326613BalloonMorph subclass: #SimpleBalloonMorph 326614 instanceVariableNames: '' 326615 classVariableNames: '' 326616 poolDictionaries: '' 326617 category: 'Polymorph-Widgets'! 326618 326619!SimpleBalloonMorph methodsFor: 'initialization' stamp: 'gvc 1/30/2009 15:25'! 326620defaultBorderWidth 326621 "Answer the default border width for the receiver." 326622 326623 ^1! ! 326624 326625 326626!SimpleBalloonMorph methodsFor: 'initialize-release' stamp: 'gvc 1/30/2009 15:09'! 326627initialize 326628 "Initialize the the receiver." 326629 326630 super initialize. 326631 self beStraightSegments! ! 326632 326633"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 326634 326635SimpleBalloonMorph class 326636 instanceVariableNames: ''! 326637 326638!SimpleBalloonMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 1/30/2009 15:11'! 326639getVertices: bounds 326640 "Construct vertices for a balloon up and to left of anchor." 326641 326642 ^(bounds expandBy: 3) corners atAll: #(1 4 3 2)! ! 326643BorderStyle subclass: #SimpleBorder 326644 instanceVariableNames: 'baseColor color width' 326645 classVariableNames: '' 326646 poolDictionaries: '' 326647 category: 'Morphic-Borders'! 326648!SimpleBorder commentStamp: 'kfr 10/27/2003 10:17' prior: 0! 326649see BorderedMorph! 326650 326651 326652!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:19'! 326653baseColor 326654 ^baseColor ifNil:[Color transparent]! ! 326655 326656!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:23'! 326657baseColor: aColor 326658 | cc | 326659 cc := aColor isTransparent ifTrue:[nil] ifFalse:[aColor]. 326660 baseColor = cc ifTrue:[^self]. 326661 baseColor := cc. 326662 self releaseCachedState. 326663 self color: cc. 326664! ! 326665 326666!SimpleBorder methodsFor: 'accessing' stamp: 'gvc 1/31/2007 13:50'! 326667bottomRightColor 326668 "Changed from direct access to color since, if nil, 326669 self color is transparent." 326670 326671 ^self color! ! 326672 326673!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:19'! 326674color 326675 ^color ifNil:[Color transparent]! ! 326676 326677!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:10'! 326678color: aColor 326679 color = aColor ifTrue:[^self]. 326680 color := aColor. 326681 self releaseCachedState.! ! 326682 326683!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:52'! 326684style 326685 ^#simple! ! 326686 326687!SimpleBorder methodsFor: 'accessing' stamp: 'gvc 1/31/2007 13:50'! 326688topLeftColor 326689 "Changed from direct access to color since, if nil, 326690 self color is transparent." 326691 326692 ^self color! ! 326693 326694!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:35'! 326695width 326696 ^width! ! 326697 326698!SimpleBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:10'! 326699width: aNumber 326700 width = aNumber ifTrue:[^self]. 326701 width := aNumber truncated max: (width isPoint ifTrue:[0@0] ifFalse:[0]). 326702 self releaseCachedState.! ! 326703 326704 326705!SimpleBorder methodsFor: 'drawing' stamp: 'aoy 2/17/2003 01:14'! 326706drawLineFrom: startPoint to: stopPoint on: aCanvas 326707 | lineColor | 326708 lineColor := (stopPoint truncated quadrantOf: startPoint truncated) > 2 326709 ifTrue: [self topLeftColor] 326710 ifFalse: [self bottomRightColor]. 326711 aCanvas 326712 line: startPoint 326713 to: stopPoint 326714 width: self width 326715 color: lineColor! ! 326716 326717!SimpleBorder methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:27'! 326718frameRectangle: aRectangle on: aCanvas 326719 aCanvas frameAndFillRectangle: aRectangle 326720 fillColor: Color transparent 326721 borderWidth: self width 326722 topLeftColor: self topLeftColor 326723 bottomRightColor: self bottomRightColor.! ! 326724 326725 326726!SimpleBorder methodsFor: 'initialize' stamp: 'sd 11/25/2008 14:47'! 326727initialize 326728 326729 super initialize. 326730 color := Color transparent 326731 ! ! 326732RectangleMorph subclass: #SimpleButtonMorph 326733 instanceVariableNames: 'target actionSelector arguments actWhen oldColor mouseDownTime' 326734 classVariableNames: '' 326735 poolDictionaries: '' 326736 category: 'Morphic-Widgets'! 326737!SimpleButtonMorph commentStamp: 'efc 3/7/2003 17:46' prior: 0! 326738I am labeled, rectangular morph which allows the user to click me. I can be configured to send my "target" the message "actionSelector" with "arguments" when I am clicked. I may have a label, implemented as a StringMorph. 326739 326740Example: 326741 326742 SimpleButtonMorph new 326743 target: Smalltalk; 326744 label: 'Beep!!'; 326745 actionSelector: #beep; 326746 openInWorld 326747 326748Structure: 326749instance var Type Description 326750target Object The Object to notify upon a click 326751actionSelector Symbol The message to send to Target (#messageName) 326752arguments Array Arguments to send with #actionSelection (optional) 326753actWhen Symbol When to take action: may be #buttonUp (default), #buttonDown, 326754 #whilePressed, or #startDrag 326755oldColor Color Used to restore color after click 326756 326757Another example: a button which quits the image without saving it. 326758 326759 SimpleButtonMorph new 326760 target: Smalltalk; 326761 label: 'quit'; 326762 actionSelector: #snapshot:andQuit:; 326763 arguments: (Array with: false with: true); 326764 openInWorld 326765 326766! 326767]style[(209 11 13 101 13 31 12 6 54 6 61 5 65 6 114 5 107 158 2)f1,f1LStringMorph Comment;,f1,f1d SimpleButtonMorph new 326768 target: Smalltalk; 326769 label: 'Beep!!'; 326770 actionSelector: #beep; 326771 openInWorld;;,f1,f1i,f1,f1LObject Comment;,f1,f1LSymbol Comment;,f1,f1LArray Comment;,f1,f1LSymbol Comment;,f1,f1LColor Comment;,f1,f1d SimpleButtonMorph new 326772 target: Smalltalk; 326773 label: 'quit'; 326774 actionSelector: #snapshot:andQuit:; 326775 arguments: (Array with: false with: true); 326776 openInWorld;;,f1! 326777 326778 326779!SimpleButtonMorph methodsFor: 'accessing'! 326780actionSelector 326781 326782 ^ actionSelector 326783! ! 326784 326785!SimpleButtonMorph methodsFor: 'accessing'! 326786actionSelector: aSymbolOrString 326787 326788 (nil = aSymbolOrString or: 326789 ['nil' = aSymbolOrString or: 326790 [aSymbolOrString isEmpty]]) 326791 ifTrue: [^ actionSelector := nil]. 326792 326793 actionSelector := aSymbolOrString asSymbol. 326794! ! 326795 326796!SimpleButtonMorph methodsFor: 'accessing'! 326797arguments 326798 326799 ^ arguments 326800! ! 326801 326802!SimpleButtonMorph methodsFor: 'accessing'! 326803arguments: aCollection 326804 326805 arguments := aCollection asArray copy. 326806! ! 326807 326808!SimpleButtonMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 22:57'! 326809fitContents 326810 | aMorph aCenter | 326811 aCenter := self center. 326812 submorphs isEmpty ifTrue: [^self]. 326813 aMorph := submorphs first. 326814 self extent: aMorph extent + (borderWidth + 6). 326815 self center: aCenter. 326816 aMorph position: aCenter - (aMorph extent // 2)! ! 326817 326818!SimpleButtonMorph methodsFor: 'accessing'! 326819label 326820 326821 | s | 326822 s := ''. 326823 self allMorphsDo: [:m | (m isKindOf: StringMorph) ifTrue: [s := m contents]]. 326824 ^ s! ! 326825 326826!SimpleButtonMorph methodsFor: 'accessing' stamp: 'sw 12/7/1999 18:11'! 326827label: aString 326828 326829 | oldLabel m | 326830 (oldLabel := self findA: StringMorph) 326831 ifNotNil: [oldLabel delete]. 326832 m := StringMorph contents: aString font: TextStyle defaultFont. 326833 self extent: m extent + (borderWidth + 6). 326834 m position: self center - (m extent // 2). 326835 self addMorph: m. 326836 m lock! ! 326837 326838!SimpleButtonMorph methodsFor: 'accessing' stamp: 'sw 12/10/1999 09:06'! 326839label: aString font: aFont 326840 326841 | oldLabel m | 326842 (oldLabel := self findA: StringMorph) 326843 ifNotNil: [oldLabel delete]. 326844 m := StringMorph contents: aString font: (aFont ifNil: [Preferences standardButtonFont]). 326845 self extent: (m width + 6) @ (m height + 6). 326846 m position: self center - (m extent // 2). 326847 self addMorph: m. 326848 m lock 326849! ! 326850 326851!SimpleButtonMorph methodsFor: 'accessing' stamp: 'sw 6/11/1999 18:40'! 326852labelString: aString 326853 326854 | existingLabel | 326855 (existingLabel := self findA: StringMorph) 326856 ifNil: 326857 [self label: aString] 326858 ifNotNil: 326859 [existingLabel contents: aString. 326860 self fitContents] 326861! ! 326862 326863!SimpleButtonMorph methodsFor: 'accessing'! 326864target 326865 326866 ^ target 326867! ! 326868 326869!SimpleButtonMorph methodsFor: 'accessing'! 326870target: anObject 326871 326872 target := anObject 326873! ! 326874 326875 326876!SimpleButtonMorph methodsFor: 'button' stamp: 'dgd 2/22/2003 18:53'! 326877doButtonAction 326878 "Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments." 326879 326880 (target notNil and: [actionSelector notNil]) 326881 ifTrue: 326882 [Cursor normal 326883 showWhile: [target perform: actionSelector withArguments: arguments]]. 326884 actWhen == #startDrag ifTrue: [oldColor ifNotNil: [self color: oldColor]]! ! 326885 326886 326887!SimpleButtonMorph methodsFor: 'copying' stamp: 'sw 2/15/98 03:49'! 326888recolor: c 326889 self color: c. 326890 oldColor := c! ! 326891 326892!SimpleButtonMorph methodsFor: 'copying' stamp: 'tk 1/6/1999 17:55'! 326893veryDeepFixupWith: deepCopier 326894 "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 326895 326896super veryDeepFixupWith: deepCopier. 326897target := deepCopier references at: target ifAbsent: [target]. 326898arguments := arguments collect: [:each | 326899 deepCopier references at: each ifAbsent: [each]]. 326900! ! 326901 326902!SimpleButtonMorph methodsFor: 'copying' stamp: 'nk 1/23/2004 17:14'! 326903veryDeepInner: deepCopier 326904 "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." 326905 326906super veryDeepInner: deepCopier. 326907"target := target. Weakly copied" 326908"actionSelector := actionSelector. a Symbol" 326909"arguments := arguments. All weakly copied" 326910actWhen := actWhen veryDeepCopyWith: deepCopier. 326911oldColor := oldColor veryDeepCopyWith: deepCopier. 326912mouseDownTime := nil.! ! 326913 326914 326915!SimpleButtonMorph methodsFor: 'event handling' stamp: 'sw 8/16/97 22:10'! 326916handlesMouseDown: evt 326917 ^ self isPartsDonor not 326918! ! 326919 326920!SimpleButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:15'! 326921handlesMouseStillDown: evt 326922 ^actWhen == #whilePressed! ! 326923 326924!SimpleButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 21:36'! 326925mouseDown: evt 326926 326927 super mouseDown: evt. 326928 evt yellowButtonPressed ifTrue: [ ^self ] . 326929 mouseDownTime := Time millisecondClockValue. 326930 oldColor := self fillStyle. 326931 actWhen == #buttonDown 326932 ifTrue: [ self doButtonAction] 326933 ifFalse: [ self updateVisualState: evt ]. 326934 self mouseStillDown: evt.! ! 326935 326936!SimpleButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:10'! 326937mouseMove: evt 326938 actWhen == #buttonDown ifTrue: [^ self]. 326939 self updateVisualState: evt.! ! 326940 326941!SimpleButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:15'! 326942mouseStillDown: evt 326943 actWhen == #whilePressed ifFalse:[^self]. 326944 (self containsPoint: evt cursorPoint) ifTrue:[self doButtonAction].! ! 326945 326946!SimpleButtonMorph methodsFor: 'event handling' stamp: 'wiz 5/18/2006 03:33'! 326947mouseUp: evt 326948 super mouseUp: evt. 326949 oldColor ifNotNil: 326950 ["if oldColor nil, it signals that mouse had not gone DOWN 326951 inside me, e.g. because of a cmd-drag; in this case we want 326952 to avoid triggering the action!!" 326953 self color: oldColor. 326954 oldColor := nil. 326955 (self containsPoint: evt cursorPoint) 326956 ifTrue: [ actWhen == #buttonUp 326957 ifTrue: [self doButtonAction] ] 326958 ifFalse: [ self mouseLeave: evt "This is a balk. Note that we have left." ]] 326959 326960! ! 326961 326962 326963!SimpleButtonMorph methodsFor: 'events-processing' stamp: 'nk 1/11/2004 13:25'! 326964mouseStillDownStepRate 326965 "Answer how often I want the #handleMouseStillDown: stepped" 326966 ^200! ! 326967 326968 326969!SimpleButtonMorph methodsFor: 'geometry' stamp: '6/7/97 10:53 di'! 326970extent: newExtent 326971 | label | 326972 super extent: newExtent. 326973 submorphs size = 1 ifTrue: 326974 ["keep the label centered" 326975 "NOTE: may want to test more that it IS a label..." 326976 label := self firstSubmorph. 326977 label position: self center - (label extent // 2)]! ! 326978 326979 326980!SimpleButtonMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:38'! 326981defaultLabel 326982 ^ 'Flash'. 326983! ! 326984 326985!SimpleButtonMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:40'! 326986initialize 326987 super initialize. 326988 326989 self borderWidth: 1. 326990 self color: (Color r: 0.4 g: 0.8 b: 0.6). 326991 self borderColor: self color darker. 326992 self borderStyle: BorderStyle thinGray. 326993 target := nil. 326994 actionSelector := #flash. 326995 arguments := EmptyArray. 326996 actWhen := #buttonUp. 326997 self setDefaultLabel ! ! 326998 326999!SimpleButtonMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:39'! 327000setDefaultLabel 327001 self label: self defaultLabel 327002! ! 327003 327004 327005!SimpleButtonMorph methodsFor: 'menu' stamp: 'stephane.ducasse 4/14/2009 10:17'! 327006addCustomMenuItems: aCustomMenu hand: aHandMorph 327007 327008 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 327009 self addLabelItemsTo: aCustomMenu hand: aHandMorph. 327010 aCustomMenu add: 'change action selector' translated action: #setActionSelector. 327011 aCustomMenu add: 'change arguments' translated action: #setArguments. 327012 aCustomMenu add: 'change when to act' translated action: #setActWhen. 327013 self addTargetingMenuItems: aCustomMenu hand: aHandMorph. 327014! ! 327015 327016!SimpleButtonMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:06'! 327017addLabelItemsTo: aCustomMenu hand: aHandMorph 327018 aCustomMenu add: 'change label' translated action: #setLabel! ! 327019 327020!SimpleButtonMorph methodsFor: 'menu' stamp: 'wiz 1/16/2006 20:10'! 327021addTargetingMenuItems: aCustomMenu hand: aHandMorph 327022 "Add targeting menu items" 327023 aCustomMenu addLine. 327024 327025 aCustomMenu add: 'set target' translated action: #targetWith:. 327026 aCustomMenu add: 'sight target' translated action: #sightTargets:. 327027 target 327028 ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]! ! 327029 327030!SimpleButtonMorph methodsFor: 'menu' stamp: 'wiz 1/16/2006 20:05'! 327031clearTarget 327032 327033 target := nil. 327034! ! 327035 327036!SimpleButtonMorph methodsFor: 'menu' stamp: 'alain.plantec 2/6/2009 17:23'! 327037setActWhen 327038 | selections | 327039 selections := #(#buttonDown #buttonUp #whilePressed #startDrag ). 327040 actWhen := UIManager default 327041 chooseFrom: (selections 327042 collect: [:t | t translated]) 327043 values: selections 327044 title: 'Choose one of the following conditions' translated! ! 327045 327046!SimpleButtonMorph methodsFor: 'menu' stamp: 'DamienCassou 9/29/2009 13:09'! 327047setActionSelector 327048 327049 | newSel | 327050 newSel := UIManager default 327051 request: 327052'Please type the selector to be sent to 327053the target when this button is pressed' translated 327054 initialAnswer: actionSelector. 327055 newSel isEmptyOrNil ifFalse: [self actionSelector: newSel]. 327056! ! 327057 327058!SimpleButtonMorph methodsFor: 'menu' stamp: 'DamienCassou 9/29/2009 13:10'! 327059setArguments 327060 327061 | s newArgs newArgsArray | 327062 s := WriteStream on: ''. 327063 arguments do: [:arg | arg printOn: s. s nextPutAll: '. ']. 327064 newArgs := UIManager default 327065 request: 327066'Please type the arguments to be sent to the target 327067when this button is pressed separated by periods' translated 327068 initialAnswer: s contents. 327069 newArgs isEmptyOrNil ifFalse: [ 327070 newArgsArray := Compiler evaluate: '{', newArgs, '}' for: self logged: false. 327071 self arguments: newArgsArray]. 327072! ! 327073 327074!SimpleButtonMorph methodsFor: 'menu' stamp: 'DamienCassou 9/29/2009 13:10'! 327075setLabel 327076 327077 | newLabel | 327078 newLabel := UIManager default 327079 request: 'Please enter a new label for this button' translated 327080 initialAnswer: self label. 327081 newLabel isEmptyOrNil ifFalse: [self labelString: newLabel]. 327082! ! 327083 327084!SimpleButtonMorph methodsFor: 'menu' stamp: 'DamienCassou 9/29/2009 13:10'! 327085setTarget 327086 327087 | newLabel | 327088 newLabel := UIManager default request: 'Enter an expression that create the target' translated initialAnswer: 'World'. 327089 newLabel isEmptyOrNil 327090 ifFalse: [self target: (Compiler evaluate: newLabel)]! ! 327091 327092!SimpleButtonMorph methodsFor: 'menu' stamp: 'wiz 12/4/2006 00:32'! 327093setTarget: evt 327094 | rootMorphs | 327095 rootMorphs := self world rootMorphsAt: evt hand targetPoint. 327096 target := rootMorphs size > 1 327097 ifTrue: [rootMorphs second]! ! 327098 327099 327100!SimpleButtonMorph methodsFor: 'submorphs-add/remove' stamp: 'sw 10/8/2000 08:14'! 327101actWhen 327102 "acceptable symbols: #buttonDown, #buttonUp, and #whilePressed" 327103 327104 ^ actWhen! ! 327105 327106!SimpleButtonMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 6/13/2004 13:46'! 327107actWhen: condition 327108 "Accepts symbols: #buttonDown, #buttonUp, and #whilePressed, #startDrag" 327109 actWhen := condition. 327110 actWhen == #startDrag 327111 ifFalse: [self on: #startDrag send: nil to: nil ] 327112 ifTrue:[self on: #startDrag send: #doButtonAction to: self].! ! 327113 327114 327115!SimpleButtonMorph methodsFor: 'visual properties' stamp: 'yo 8/27/2008 23:58'! 327116updateVisualState: evt 327117 327118 oldColor ifNotNil: [ 327119 self color: 327120 ((self containsPoint: evt cursorPoint) 327121 ifTrue: [oldColor mixed: 0.5 with: Color white] 327122 ifFalse: [oldColor])] 327123! ! 327124 327125"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 327126 327127SimpleButtonMorph class 327128 instanceVariableNames: ''! 327129 327130!SimpleButtonMorph class methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:44'! 327131newWithLabel: labelString 327132 327133 ^ self new label: labelString 327134! ! 327135 327136 327137!SimpleButtonMorph class methodsFor: 'printing' stamp: 'apb 5/3/2006 14:37'! 327138defaultNameStemForInstances 327139 ^ self = SimpleButtonMorph 327140 ifTrue: ['Button'] 327141 ifFalse: [^ super defaultNameStemForInstances]! ! 327142 327143 327144!SimpleButtonMorph class methodsFor: 'scripting' stamp: 'sw 5/6/1998 14:07'! 327145authoringPrototype 327146 ^ super authoringPrototype label: 'Button'! ! 327147ScrollPane subclass: #SimpleHierarchicalListMorph 327148 instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect columns sortingSelector getSelectionSelector setSelectionSelector potentialDropMorph lineColor' 327149 classVariableNames: '' 327150 poolDictionaries: '' 327151 category: 'Morphic-Explorer'! 327152!SimpleHierarchicalListMorph commentStamp: 'ls 3/1/2004 12:15' prior: 0! 327153Display a hierarchical list of items. Each item should be wrapped with a ListItemWrapper. 327154 327155For a simple example, look at submorphsExample. For beefier examples, look at ObjectExplorer or FileList2.! 327156 327157 327158!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 12:12'! 327159adoptPaneColor: paneColor 327160 "Pass on to the border too." 327161 327162 super adoptPaneColor: paneColor. 327163 paneColor ifNil: [^self]. 327164 self selectionColor: self selectionColor. 327165 self borderStyle baseColor: paneColor twiceDarker! ! 327166 327167!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/17/2007 15:20'! 327168drawSubmorphsOn: aCanvas 327169 "Display submorphs back to front. 327170 Draw the focus here since we are using inset bounds 327171 for the focus rectangle." 327172 327173 super drawSubmorphsOn: aCanvas. 327174 self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOn: aCanvas]! ! 327175 327176!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/24/2007 10:30'! 327177expandedForm 327178 "Answer the form to use for expanded items." 327179 327180 ^self theme treeExpandedForm! ! 327181 327182!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/6/2007 14:36'! 327183keyboardFocusChange: aBoolean 327184 "The message is sent to a morph when its keyboard focus changes. 327185 Update for focus feedback." 327186 327187 self focusChanged! ! 327188 327189!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/11/2006 10:40'! 327190mouseDownHighlightColor 327191 "Answer a good color to use for drawing the mouse down highlight. 327192 Used the line color if not transparent, otherwise a contrasting color in the 327193 same way as the line color is determined. 327194 Fall back to black if all my owners are transparent." 327195 327196 |c colored | 327197 c := self lineColor. 327198 c isTransparent ifFalse: [^c]. 327199 colored := self color isTransparent 327200 ifTrue: [self firstOwnerSuchThat: [:o | o isWorldOrHandMorph not and: [o color isTransparent not]]] 327201 ifFalse: [self]. 327202 colored ifNil: [^Color black]. 327203 ^colored color luminance > 0.5 327204 ifTrue: [Color black] 327205 ifFalse: [Color white] 327206! ! 327207 327208!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/24/2007 10:31'! 327209notExpandedForm 327210 "Answer the form to use for unexpanded items." 327211 327212 ^self theme treeUnexpandedForm! ! 327213 327214!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/13/2006 11:26'! 327215selectionColor 327216 "Answer the colour to use for selected items." 327217 327218 ^self valueOfProperty: #selectionColor ifAbsent: [] ! ! 327219 327220!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/7/2008 12:27'! 327221selectionColor: aColor 327222 "Set the colour for selected items." 327223 327224 |w| 327225 aColor 327226 ifNil: [self removeProperty: #selectionColor] 327227 ifNotNil: [self setProperty: #selectionColor toValue: aColor]. 327228 w := self ownerThatIsA: SystemWindow. 327229 self selectionColorToUse: ( 327230 (Preferences fadedBackgroundWindows not or: [w isNil or: [w isActive]]) 327231 ifTrue: [aColor] 327232 ifFalse: [self paneColor lighter])! ! 327233 327234!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/13/2006 11:27'! 327235selectionColorToUse 327236 "Answer the colour to use for selected items." 327237 327238 ^self valueOfProperty: #selectionColorToUse ifAbsent: [] ! ! 327239 327240!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 12:14'! 327241selectionColorToUse: aColor 327242 "Set the colour for selected items." 327243 327244 aColor = self selectionColorToUse ifTrue: [^self]. 327245 aColor 327246 ifNil: [self removeProperty: #selectionColorToUse] 327247 ifNotNil: [self setProperty: #selectionColorToUse toValue: aColor]. 327248 self selectionFrameChanged! ! 327249 327250!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 12:11'! 327251selectionFrame 327252 "Answer the frame of the selected morph in the receiver or nil if none." 327253 327254 ^selectedMorph 327255 ifNotNil: [selectedMorph bounds: selectedMorph selectionFrame in: self]! ! 327256 327257!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 12:11'! 327258selectionFrameChanged 327259 "Invalidate frame of the current selection if any." 327260 327261 selectedMorph ifNil: [ ^self ]. 327262 self invalidRect: self selectionFrame! ! 327263 327264!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 14:06'! 327265takesKeyboardFocus 327266 "Answer whether the receiver can normally take keyboard focus." 327267 327268 ^true! ! 327269 327270!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/22/2007 14:50'! 327271themeChanged 327272 "Update the selection colour." 327273 327274 self selectionColor ifNotNil: [ 327275 self selectionColor: self theme selectionColor]. 327276 super themeChanged! ! 327277 327278 327279!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/15/2007 15:58'! 327280adjustSubmorphPositions 327281 "Fixed to not require setting item widths to 9999." 327282 327283 | p h | 327284 p := 0@0. 327285 scroller submorphsDo: [ :each | 327286 h := each height. 327287 each privateBounds: (p extent: each width@h). 327288 p := p + (0@h) 327289 ]. 327290 self 327291 changed; 327292 layoutChanged; 327293 setScrollDeltas. 327294! ! 327295 327296!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2009 13:54'! 327297drawLinesOn: aCanvas 327298 "Draw the lines for the submorphs. 327299 Modified for performance." 327300 327301 | lColor last| 327302 lColor := self lineColor. 327303 aCanvas 327304 transformBy: scroller transform 327305 clippingTo: scroller innerBounds 327306 during: [:clippedCanvas | 327307 scroller submorphs do: [ :submorph | 327308 ((submorph isExpanded and: [ 327309 (submorph nextSibling notNil and: [ 327310 clippedCanvas isVisible: (submorph fullBounds topLeft 327311 corner: submorph nextSibling fullBounds bottomRight)]) or: [ 327312 submorph nextSibling isNil and: [(last := submorph lastChild) notNil and: [ 327313 clippedCanvas isVisible: (submorph fullBounds topLeft 327314 corner: last fullBounds bottomRight)]]]]) or: [ 327315 (clippedCanvas isVisible: submorph fullBounds) or: [ 327316 (submorph nextSibling notNil and: [ 327317 clippedCanvas isVisible: submorph nextSibling fullBounds])]]) ifTrue:[ 327318 submorph drawLinesOn: clippedCanvas lineColor: lColor]]] 327319 smoothing: scroller smoothing 327320! ! 327321 327322!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/24/2007 12:11'! 327323drawOn: aCanvas 327324 "Draw the selection and lines." 327325 327326 super drawOn: aCanvas. 327327 selectedMorph ifNotNil: 327328 [aCanvas clipBy: self innerBounds during: [:c | 327329 c 327330 fillRectangle: self selectionFrame 327331 color: (self selectionColorToUse ifNil: [Preferences textHighlightColor])]]. 327332 self drawLinesOn: aCanvas! ! 327333 327334!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/28/2007 13:55'! 327335expandAll 327336 "Expand all of the roots!!" 327337 327338 self roots do: [:m | 327339 self expandAll: m]. 327340 self adjustSubmorphPositions! ! 327341 327342!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/15/2007 16:00'! 327343hUnadjustedScrollRange 327344 "Return the width of the widest item in the list. 327345 Use super now since actual item widths are correct." 327346 327347 ^super hUnadjustedScrollRange 327348! ! 327349 327350!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/12/2009 13:26'! 327351keyStroke: event 327352 "Process potential command keys. 327353 Fix for command key required (like PluggableListMorph)." 327354 327355 | args aCharacter | 327356 (self navigationKey: event) ifTrue: [^true]. 327357 (self scrollByKeyboard: event) ifTrue: [^self]. 327358 aCharacter := event keyValue asCharacter. 327359 "since ctrl-a, for instance, will have keyCharacter of 0 ascii with keyboard event and not $a as before Unicode refactoring" 327360 (self arrowKey: aCharacter) ifTrue: [^true]. 327361 keystrokeActionSelector isNil ifTrue: [^false]. 327362 event anyModifierKeyPressed ifFalse: [^false]. 327363 (args := keystrokeActionSelector numArgs) = 1 327364 ifTrue: [^model perform: keystrokeActionSelector with: aCharacter]. 327365 args = 2 327366 ifTrue: 327367 [^model 327368 perform: keystrokeActionSelector 327369 with: aCharacter 327370 with: self]. 327371 ^self 327372 error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'! ! 327373 327374!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/11/2006 10:34'! 327375lineColor 327376 "Answer a good color to use for drawing the lines that connect members of the hierarchy view. 327377 Used the cached color, or derive it if necessary by finding the receiver or the first owner (up to my root) that is not transparent, then picking a contrasting color. 327378 Fall back to black if all my owners are transparent." 327379 327380 | colored | 327381 lineColor ifNotNil: [^lineColor ]. 327382 colored := self color isTransparent 327383 ifTrue: [self firstOwnerSuchThat: [:o | o isWorldOrHandMorph not and: [o color isTransparent not]]] 327384 ifFalse: [self]. 327385 colored ifNil: [^Color black]. 327386 ^colored color luminance > 0.5 327387 ifTrue: [Color black] 327388 ifFalse: [Color white] 327389 327390! ! 327391 327392!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/21/2007 14:41'! 327393mouseDown: evt 327394 "Changed to take keybaord focus." 327395 327396 | aMorph selectors | 327397 self wantsKeyboardFocus 327398 ifTrue: [self takeKeyboardFocus]. 327399 aMorph := self itemFromPoint: evt position. 327400 (aMorph notNil and:[aMorph inToggleArea: (aMorph point: evt position from: self)]) 327401 ifTrue:[^self toggleExpandedState: aMorph event: evt]. 327402 evt yellowButtonPressed "First check for option (menu) click" 327403 ifTrue: [^ self yellowButtonActivity: evt shiftPressed]. 327404 aMorph ifNil:[^super mouseDown: evt]. 327405 aMorph highlightForMouseDown. 327406 selectors := Array 327407 with: #click: 327408 with: nil 327409 with: nil 327410 with: (self dragEnabled ifTrue:[#startDrag:] ifFalse:[nil]). 327411 evt hand waitForClicksOrDrag: self event: evt selectors: selectors threshold: 10 "pixels".! ! 327412 327413!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/21/2007 14:41'! 327414mouseEnter: event 327415 "Changed to take mouseClickForKeyboardFocus preference into account." 327416 327417 super mouseEnter: event. 327418 self wantsKeyboardFocus ifFalse: [^self]. 327419 Preferences mouseClickForKeyboardFocus 327420 ifFalse: [self takeKeyboardFocus]! ! 327421 327422!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/12/2006 15:29'! 327423mouseMove: evt 327424 327425 |aMorph| 327426 aMorph := self itemFromPoint: evt position. 327427 evt hand hasSubmorphs ifFalse: [ 327428 (aMorph isNil or: [aMorph highlightedForMouseDown not]) 327429 ifTrue: [scroller submorphsDo: [:m | 327430 m highlightedForMouseDown ifTrue: [m highlightForMouseDown: false]]. 327431 aMorph ifNotNil: [aMorph highlightForMouseDown]]]. 327432 (self dropEnabled and:[evt hand hasSubmorphs]) 327433 ifFalse:[^super mouseMove: evt]. 327434 potentialDropMorph ifNotNil:[ 327435 (potentialDropMorph containsPoint: (potentialDropMorph point: evt position from: self)) 327436 ifTrue:[^self]. 327437 ]. 327438 self mouseLeaveDragging: evt. 327439 (self containsPoint: evt position) 327440 ifTrue:[self mouseEnterDragging: evt].! ! 327441 327442!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/24/2006 09:59'! 327443mouseUp: event 327444 "Fixed up highlight problems." 327445 327446 | aMorph wasHigh| 327447 aMorph := self itemFromPoint: event position. 327448 wasHigh := aMorph notNil ifTrue: [aMorph highlightedForMouseDown] ifFalse: [false]. 327449 scroller submorphsDo: [:m | 327450 m highlightedForMouseDown ifTrue: [m highlightForMouseDown: false]]. 327451 aMorph ifNil: [^self]. 327452 wasHigh ifFalse: [^self]. 327453 model okToChange ifFalse: [^self]. 327454 "No change if model is locked" 327455 ((autoDeselect isNil or: [autoDeselect]) and: [aMorph == selectedMorph]) 327456 ifTrue: [self setSelectedMorph: nil] 327457 ifFalse: [self setSelectedMorph: aMorph]. 327458 Cursor normal show! ! 327459 327460!SimpleHierarchicalListMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 11/15/2007 14:27'! 327461update: aSymbol 327462 aSymbol == getSelectionSelector 327463 ifTrue: 327464 [self selection: self getCurrentSelectionItem. 327465 ^self]. 327466 aSymbol == getListSelector 327467 ifTrue: 327468 [self list: self getList. 327469 ^self]. 327470 ((aSymbol isKindOf: Array) 327471 and: [aSymbol size > 1 and: [aSymbol first == getListSelector and: [ 327472 aSymbol second == #openPath]]]) "allow directed path opening where multiple trees exist" 327473 ifTrue: 327474 [^(scroller submorphs at: 1 ifAbsent: [^self]) 327475 openPath: (aSymbol allButFirst: 2)]. 327476 ((aSymbol isKindOf: Array) 327477 and: [aSymbol size > 1 and: [aSymbol first == getListSelector and: [ 327478 aSymbol second == #openItemPath]]]) "allow directed path opening where multiple trees exist" 327479 ifTrue: 327480 [^(scroller submorphs at: 1 ifAbsent: [^self]) 327481 openItemPath: (aSymbol allButFirst: 2)]. 327482 ((aSymbol isKindOf: Array) 327483 and: [aSymbol notEmpty and: [aSymbol first == #openPath]]) 327484 ifTrue: 327485 [^(scroller submorphs at: 1 ifAbsent: [^self]) 327486 openPath: aSymbol allButFirst]. 327487 ((aSymbol isKindOf: Array) 327488 and: [aSymbol size = 2 and: [aSymbol first = getListSelector and: [ 327489 aSymbol second == #expandRoots]]]) 327490 ifTrue: 327491 [^self expandRoots]. 327492 ((aSymbol isKindOf: Array) 327493 and: [aSymbol notEmpty and: [aSymbol first = getListSelector and: [ 327494 aSymbol second == #expandAll]]]) 327495 ifTrue: 327496 [^self expandAll]! ! 327497 327498 327499!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'RAA 7/24/1998 22:52'! 327500columns 327501 327502 ^columns! ! 327503 327504!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'RAA 7/18/1998 23:18'! 327505columns: anArray 327506 327507 columns := anArray! ! 327508 327509!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'sps 12/28/2002 02:27'! 327510lineColor: aColor 327511 ^lineColor := aColor 327512! ! 327513 327514!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:23'! 327515roots 327516 "Answer the receiver's roots" 327517 ^ scroller submorphs 327518 select: [:each | each indentLevel isZero]! ! 327519 327520!SimpleHierarchicalListMorph methodsFor: 'accessing' stamp: 'RAA 7/20/1998 12:09'! 327521sortingSelector: s 327522 327523 sortingSelector := s! ! 327524 327525 327526!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'RAA 8/3/1999 09:44'! 327527highlightSelection 327528 327529 selectedMorph ifNotNil: [selectedMorph highlight]! ! 327530 327531!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'RAA 8/3/1999 09:44'! 327532unhighlightSelection 327533 selectedMorph ifNotNil: [selectedMorph unhighlight]! ! 327534 327535 327536!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'nk 6/15/2003 11:49'! 327537acceptDroppingMorph: aMorph event: evt 327538 327539 self model 327540 acceptDroppingMorph: aMorph 327541 event: evt 327542 inMorph: self. 327543 self resetPotentialDropMorph. 327544 evt hand releaseMouseFocus: self. 327545 Cursor normal show. 327546! ! 327547 327548!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 17:39'! 327549potentialDropMorph 327550 ^potentialDropMorph! ! 327551 327552!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'mir 5/8/2000 15:37'! 327553potentialDropMorph: aMorph 327554 potentialDropMorph := aMorph. 327555 aMorph highlightForDrop! ! 327556 327557!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'mir 5/8/2000 15:38'! 327558resetPotentialDropMorph 327559 potentialDropMorph ifNotNil: [ 327560 potentialDropMorph resetHighlightForDrop. 327561 potentialDropMorph := nil] 327562! ! 327563 327564!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 17:38'! 327565wantsDroppedMorph: aMorph event: anEvent 327566 ^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! ! 327567 327568 327569!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 22:58'! 327570handlesKeyboard: evt 327571 ^true! ! 327572 327573!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'ar 3/17/2001 17:27'! 327574handlesMouseOverDragging: evt 327575 ^self dropEnabled! ! 327576 327577!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'ar 3/17/2001 17:25'! 327578itemFromPoint: aPoint 327579 "Return the list element (morph) at the given point or nil if outside" 327580 | ptY | 327581 scroller hasSubmorphs ifFalse:[^nil]. 327582 (scroller fullBounds containsPoint: aPoint) ifFalse:[^nil]. 327583 ptY := (scroller firstSubmorph point: aPoint from: self) y. 327584 "note: following assumes that submorphs are vertical, non-overlapping, and ordered" 327585 scroller firstSubmorph top > ptY ifTrue:[^nil]. 327586 scroller lastSubmorph bottom < ptY ifTrue:[^nil]. 327587 "now use binary search" 327588 ^scroller 327589 findSubmorphBinary:[:item| 327590 (item top <= ptY and:[item bottom >= ptY]) 327591 ifTrue:[0] "found" 327592 ifFalse:[ (item top + item bottom // 2) > ptY ifTrue:[-1] ifFalse:[1]]]! ! 327593 327594!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'ar 3/17/2001 17:26'! 327595mouseEnterDragging: evt 327596 | aMorph | 327597 (evt hand hasSubmorphs and:[self dropEnabled]) ifFalse: ["no d&d" 327598 ^super mouseEnterDragging: evt]. 327599 (self wantsDroppedMorph: evt hand firstSubmorph event: evt ) 327600 ifTrue:[ 327601 aMorph := self itemFromPoint: evt position. 327602 aMorph ifNotNil:[self potentialDropMorph: aMorph]. 327603 evt hand newMouseFocus: self. 327604 "above is ugly but necessary for now" 327605 ].! ! 327606 327607!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'ar 3/17/2001 17:27'! 327608mouseLeaveDragging: anEvent 327609 (self dropEnabled and:[anEvent hand hasSubmorphs]) ifFalse: ["no d&d" 327610 ^ super mouseLeaveDragging: anEvent]. 327611 self resetPotentialDropMorph. 327612 anEvent hand releaseMouseFocus: self. 327613 "above is ugly but necessary for now" 327614! ! 327615 327616!SimpleHierarchicalListMorph methodsFor: 'event handling' stamp: 'marcus.denker 9/23/2008 22:13'! 327617startDrag: evt 327618 | ddm itemMorph passenger | 327619 self dragEnabled 327620 ifTrue: [itemMorph := scroller submorphs 327621 detect: [:any | any highlightedForMouseDown] 327622 ifNone: []]. 327623 (itemMorph isNil 327624 or: [evt hand hasSubmorphs]) 327625 ifTrue: [^ self]. 327626 itemMorph highlightForMouseDown: false. 327627 itemMorph ~= self selectedMorph 327628 ifTrue: [self setSelectedMorph: itemMorph]. 327629 passenger := self model dragPassengerFor: itemMorph inMorph: self. 327630 passenger 327631 ifNotNil: [ddm := TransferMorph withPassenger: passenger from: self. 327632 ddm 327633 dragTransferType: (self model dragTransferTypeForMorph: self). 327634 evt hand grabMorph: ddm]. 327635 evt hand releaseMouseFocus: self! ! 327636 327637 327638!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'dgd 9/26/2004 18:24'! 327639expandRoots 327640 "Expand all the receiver's roots" 327641 self roots 327642 do: [:each | 327643 (each canExpand and: [each isExpanded not]) 327644 ifTrue: [each toggleExpandedState]]. 327645 self adjustSubmorphPositions! ! 327646 327647!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'ar 3/17/2001 17:39'! 327648expand: aMorph to: level 327649 | allChildren | 327650 aMorph toggleExpandedState. 327651 allChildren := OrderedCollection new: 10. 327652 aMorph recursiveAddTo: allChildren. 327653 allChildren do: [:each | 327654 ((each canExpand 327655 and: [each isExpanded not]) 327656 and: [level > 0]) 327657 ifTrue: [self expand: each to: level-1]].! ! 327658 327659!SimpleHierarchicalListMorph methodsFor: 'events'! 327660expandAll: aMorph 327661 | allChildren | 327662 aMorph toggleExpandedState. 327663 allChildren := OrderedCollection new: 10. 327664 aMorph recursiveAddTo: allChildren. 327665 allChildren do: [:each | 327666 (each canExpand and: [each isExpanded not]) 327667 ifTrue: [self expandAll: each]]. 327668! ! 327669 327670!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'ar 3/17/2001 17:39'! 327671expandAll: aMorph except: aBlock 327672 | allChildren | 327673 (aBlock value: aMorph complexContents) 327674 ifFalse: [^self]. 327675 aMorph toggleExpandedState. 327676 allChildren := OrderedCollection new: 10. 327677 aMorph recursiveAddTo: allChildren. 327678 allChildren do: [:each | 327679 (each canExpand 327680 and: [each isExpanded not]) 327681 ifTrue: [self expandAll: each except: aBlock]].! ! 327682 327683!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'ar 3/17/2001 17:39'! 327684toggleExpandedState: aMorph event: event 327685 | oldState | 327686 "self setSelectedMorph: aMorph." 327687 event yellowButtonPressed ifTrue: [ 327688 oldState := aMorph isExpanded. 327689 scroller submorphs copy do: [ :each | 327690 (each canExpand and: [each isExpanded = oldState]) ifTrue: [ 327691 each toggleExpandedState. 327692 ]. 327693 ]. 327694 ] ifFalse: [ 327695 aMorph toggleExpandedState. 327696 ]. 327697 self adjustSubmorphPositions. 327698 ! ! 327699 327700 327701!SimpleHierarchicalListMorph methodsFor: 'events-processing' stamp: 'ar 3/17/2001 17:26'! 327702handleMouseMove: anEvent 327703 "Reimplemented because we really want #mouseMove when a morph is dragged around" 327704 anEvent wasHandled ifTrue:[^self]. "not interested" 327705 (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self]. 327706 anEvent wasHandled: true. 327707 self mouseMove: anEvent. 327708 (self handlesMouseStillDown: anEvent) ifTrue:[ 327709 "Step at the new location" 327710 self startStepping: #handleMouseStillDown: 327711 at: Time millisecondClockValue 327712 arguments: {anEvent copy resetHandlerFields} 327713 stepTime: 1]. 327714! ! 327715 327716 327717!SimpleHierarchicalListMorph methodsFor: 'geometry' stamp: 'nk 7/11/2004 20:07'! 327718extent: newExtent 327719 bounds extent = newExtent ifTrue: [^ self]. 327720 super extent: newExtent. 327721 self setScrollDeltas ! ! 327722 327723!SimpleHierarchicalListMorph methodsFor: 'geometry' stamp: 'dew 11/5/2000 00:15'! 327724scrollDeltaHeight 327725 ^ scroller firstSubmorph height! ! 327726 327727!SimpleHierarchicalListMorph methodsFor: 'geometry' stamp: 'sps 3/9/2004 17:31'! 327728scrollDeltaWidth 327729"A guess -- assume that the width of a char is approx 1/2 the height of the font" 327730 ^ self scrollDeltaHeight // 2 327731 327732 327733! ! 327734 327735 327736!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'di 4/10/98 16:20'! 327737autoDeselect: trueOrFalse 327738 "Enable/disable autoDeselect (see class comment)" 327739 autoDeselect := trueOrFalse.! ! 327740 327741!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'RAA 3/30/1999 22:29'! 327742currentlyExpanded 327743 327744 ^(scroller submorphs select: [ :each | each isExpanded]) collect: [ :each | 327745 each complexContents 327746 ]. 327747 ! ! 327748 327749!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'RAA 7/29/2000 22:15'! 327750indentingItemClass 327751 327752 ^IndentingListItemMorph! ! 327753 327754!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:26'! 327755initialize 327756 "initialize the state of the receiver" 327757 super initialize. 327758 self 327759 on: #mouseMove 327760 send: #mouseStillDown:onItem: 327761 to: self! ! 327762 327763!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'ar 3/17/2001 17:39'! 327764list: aCollection 327765 327766 | wereExpanded morphList | 327767 wereExpanded := self currentlyExpanded. 327768 scroller removeAllMorphs. 327769 (aCollection isNil or: [aCollection isEmpty]) ifTrue: [^ self selectedMorph: nil]. 327770 morphList := OrderedCollection new. 327771 self 327772 addMorphsTo: morphList 327773 from: aCollection 327774 allowSorting: false 327775 withExpandedItems: wereExpanded 327776 atLevel: 0. 327777 self insertNewMorphs: morphList.! ! 327778 327779!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'di 5/22/1998 00:32'! 327780listItemHeight 327781 "This should be cleaned up. The list should get spaced by this parameter." 327782 ^ 12! ! 327783 327784!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'RAA 8/1/1998 00:19'! 327785on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel 327786 327787 self model: anObject. 327788 getListSelector := getListSel. 327789 getSelectionSelector := getSelectionSel. 327790 setSelectionSelector := setSelectionSel. 327791 getMenuSelector := getMenuSel. 327792 keystrokeActionSelector := keyActionSel. 327793 autoDeselect := true. 327794 self borderWidth: 1. 327795 self list: self getList.! ! 327796 327797 327798!SimpleHierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'ar 10/14/2003 23:38'! 327799arrowKey: aChar 327800 "Handle a keyboard navigation character. Answer true if handled, false if not." 327801 | keyEvent | 327802 keyEvent := aChar asciiValue. 327803 keyEvent == 31 ifTrue:["down" 327804 self setSelectionIndex: self getSelectionIndex+1. 327805 ^true]. 327806 keyEvent == 30 ifTrue:["up" 327807 self setSelectionIndex: (self getSelectionIndex-1 max: 1). 327808 ^true]. 327809 keyEvent == 1 ifTrue: ["home" 327810 self setSelectionIndex: 1. 327811 ^true]. 327812 keyEvent == 4 ifTrue: ["end" 327813 self setSelectionIndex: scroller submorphs size. 327814 ^true]. 327815 keyEvent == 11 ifTrue: ["page up" 327816 self setSelectionIndex: (self getSelectionIndex - self numSelectionsInView max: 1). 327817 ^true]. 327818 keyEvent == 12 ifTrue: ["page down" 327819 self setSelectionIndex: self getSelectionIndex + self numSelectionsInView. 327820 ^true]. 327821 keyEvent == 29 ifTrue:["right" 327822 selectedMorph ifNotNil:[ 327823 (selectedMorph canExpand and:[selectedMorph isExpanded not]) 327824 ifTrue:[self toggleExpandedState: selectedMorph] 327825 ifFalse:[self setSelectionIndex: self getSelectionIndex+1]. 327826 ]. 327827 ^true]. 327828 keyEvent == 28 ifTrue:["left" 327829 selectedMorph ifNotNil:[ 327830 (selectedMorph isExpanded) 327831 ifTrue:[self toggleExpandedState: selectedMorph] 327832 ifFalse:[self setSelectionIndex: (self getSelectionIndex-1 max: 1)]. 327833 ]. 327834 ^true]. 327835 ^false! ! 327836 327837!SimpleHierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'ar 10/14/2003 23:38'! 327838getSelectionIndex 327839 ^scroller submorphs indexOf: selectedMorph! ! 327840 327841!SimpleHierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'ar 10/14/2003 23:39'! 327842setSelectionIndex: idx 327843 "Called internally to select the index-th item." 327844 | theMorph index | 327845 idx ifNil: [^ self]. 327846 index := idx min: scroller submorphs size max: 0. 327847 theMorph := index = 0 ifTrue: [nil] ifFalse: [scroller submorphs at: index]. 327848 self setSelectedMorph: theMorph.! ! 327849 327850!SimpleHierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'ar 10/14/2003 23:39'! 327851toggleExpandedState: aMorph 327852 aMorph toggleExpandedState. 327853 self adjustSubmorphPositions. 327854! ! 327855 327856 327857!SimpleHierarchicalListMorph methodsFor: 'model access' stamp: 'RAA 8/1/1998 00:10'! 327858getList 327859 "Answer the list to be displayed." 327860 327861 ^(model perform: (getListSelector ifNil: [^#()])) ifNil: [#()] 327862 327863! ! 327864 327865 327866!SimpleHierarchicalListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:40'! 327867mouseDown: event onItem: aMorph 327868 self removeObsoleteEventHandlers. 327869! ! 327870 327871!SimpleHierarchicalListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:40'! 327872mouseEnterDragging: anEvent onItem: aMorph 327873 self removeObsoleteEventHandlers.! ! 327874 327875!SimpleHierarchicalListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:39'! 327876mouseLeaveDragging: anEvent onItem: aMorph 327877 self removeObsoleteEventHandlers.! ! 327878 327879!SimpleHierarchicalListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:38'! 327880removeObsoleteEventHandlers 327881 scroller submorphs do:[:m| 327882 m eventHandler: nil; highlightForMouseDown: false; resetExtension].! ! 327883 327884!SimpleHierarchicalListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:39'! 327885startDrag: evt onItem: itemMorph 327886 self removeObsoleteEventHandlers.! ! 327887 327888 327889!SimpleHierarchicalListMorph methodsFor: 'scrolling' stamp: 'sps 12/24/2002 18:31'! 327890hExtraScrollRange 327891 "Return the amount of extra blank space to include below the bottom of the scroll content." 327892 ^5 327893! ! 327894 327895!SimpleHierarchicalListMorph methodsFor: 'scrolling' stamp: 'sps 12/26/2002 13:37'! 327896vUnadjustedScrollRange 327897"Return the width of the widest item in the list" 327898 327899 (scroller submorphs size > 0) ifFalse:[ ^0 ]. 327900 ^scroller submorphs last fullBounds bottom 327901! ! 327902 327903 327904!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 8/1/1998 00:19'! 327905getCurrentSelectionItem 327906 327907 ^model perform: (getSelectionSelector ifNil: [^nil]) 327908 ! ! 327909 327910!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 7/31/1998 00:25'! 327911maximumSelection 327912 327913 ^ scroller submorphs size 327914! ! 327915 327916!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:20'! 327917minimumSelection 327918 ^ 1! ! 327919 327920!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'panda 4/25/2000 18:56'! 327921selectedMorph 327922 ^selectedMorph! ! 327923 327924!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 8/1/1998 00:13'! 327925selectedMorph: aMorph 327926 327927 self unhighlightSelection. 327928 selectedMorph := aMorph. 327929 self highlightSelection! ! 327930 327931!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 8/31/1999 08:36'! 327932selection: item 327933 "Called from outside to request setting a new selection. 327934 Assumes scroller submorphs is exactly our list. 327935 Note: MAY NOT work right if list includes repeated items" 327936 327937 | i | 327938 item ifNil: [^self selectionIndex: 0]. 327939 i := scroller submorphs findFirst: [:m | m complexContents == item]. 327940 i > 0 ifTrue: [^self selectionIndex: i]. 327941 i := scroller submorphs findFirst: [:m | m withoutListWrapper = item withoutListWrapper]. 327942 self selectionIndex: i! ! 327943 327944!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'nk 4/28/2004 10:26'! 327945selectionIndex: idx 327946 "Called internally to select the index-th item." 327947 | theMorph range index | 327948 idx ifNil: [^ self]. 327949 index := idx min: scroller submorphs size max: 0. 327950 (theMorph := index = 0 ifTrue: [nil] ifFalse: [scroller submorphs at: index]) 327951 ifNotNil: 327952 [((theMorph bounds top - scroller offset y) >= 0 327953 and: [(theMorph bounds bottom - scroller offset y) <= bounds height]) ifFalse: 327954 ["Scroll into view -- should be elsewhere" 327955 range := self vTotalScrollRange. 327956 scrollBar value: (range > 0 327957 ifTrue: [((index-1 * theMorph height) / self vTotalScrollRange) 327958 truncateTo: scrollBar scrollDelta] 327959 ifFalse: [0]). 327960 scroller offset: -3 @ (range * scrollBar value)]]. 327961 self selectedMorph: theMorph! ! 327962 327963!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 3/31/1999 12:15'! 327964selectionOneOf: aListOfItems 327965 "Set the selection to the first item in the list which is represented by one of my submorphs" 327966 327967 | index | 327968 aListOfItems do: [ :item | 327969 index := scroller submorphs findFirst: [:m | 327970 m withoutListWrapper = item withoutListWrapper 327971 ]. 327972 index > 0 ifTrue: [^self selectionIndex: index]. 327973 ]. 327974 self selectionIndex: 0.! ! 327975 327976!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 3/31/1999 21:28'! 327977setSelectedMorph: aMorph 327978 327979 model 327980 perform: (setSelectionSelector ifNil: [^self]) 327981 with: aMorph complexContents "leave last wrapper in place" 327982 327983 ! ! 327984 327985 327986!SimpleHierarchicalListMorph methodsFor: 'private' stamp: 'RAA 7/30/2000 19:49'! 327987addMorphsTo: morphList from: aCollection allowSorting: sortBoolean withExpandedItems: expandedItems atLevel: newIndent 327988 327989 | priorMorph newCollection firstAddition | 327990 priorMorph := nil. 327991 newCollection := (sortBoolean and: [sortingSelector notNil]) ifTrue: [ 327992 (aCollection asSortedCollection: [ :a :b | 327993 (a perform: sortingSelector) <= (b perform: sortingSelector)]) asOrderedCollection 327994 ] ifFalse: [ 327995 aCollection 327996 ]. 327997 firstAddition := nil. 327998 newCollection do: [:item | 327999 priorMorph := self indentingItemClass basicNew 328000 initWithContents: item 328001 prior: priorMorph 328002 forList: self 328003 indentLevel: newIndent. 328004 firstAddition ifNil: [firstAddition := priorMorph]. 328005 morphList add: priorMorph. 328006 ((item hasEquivalentIn: expandedItems) or: [priorMorph isExpanded]) ifTrue: [ 328007 priorMorph isExpanded: true. 328008 priorMorph 328009 addChildrenForList: self 328010 addingTo: morphList 328011 withExpandedItems: expandedItems. 328012 ]. 328013 ]. 328014 ^firstAddition 328015 328016! ! 328017 328018!SimpleHierarchicalListMorph methodsFor: 'private' stamp: 'RAA 7/30/2000 19:15'! 328019addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean 328020 328021 | priorMorph morphList newCollection | 328022 priorMorph := nil. 328023 newCollection := (sortBoolean and: [sortingSelector notNil]) ifTrue: [ 328024 (aCollection asSortedCollection: [ :a :b | 328025 (a perform: sortingSelector) <= (b perform: sortingSelector)]) asOrderedCollection 328026 ] ifFalse: [ 328027 aCollection 328028 ]. 328029 morphList := OrderedCollection new. 328030 newCollection do: [:item | 328031 priorMorph := self indentingItemClass basicNew 328032 initWithContents: item 328033 prior: priorMorph 328034 forList: self 328035 indentLevel: parentMorph indentLevel + 1. 328036 morphList add: priorMorph. 328037 ]. 328038 scroller addAllMorphs: morphList after: parentMorph. 328039 ^morphList 328040 328041! ! 328042 328043!SimpleHierarchicalListMorph methodsFor: 'private' stamp: 'RAA 4/2/1999 15:33'! 328044insertNewMorphs: morphList 328045 328046 scroller addAllMorphs: morphList. 328047 self adjustSubmorphPositions. 328048 self selection: self getCurrentSelectionItem. 328049 self setScrollDeltas. 328050! ! 328051 328052!SimpleHierarchicalListMorph methodsFor: 'private' stamp: 'RAA 8/2/1999 12:42'! 328053noteRemovalOfAll: aCollection 328054 328055 scroller removeAllMorphsIn: aCollection. 328056 (aCollection includes: selectedMorph) ifTrue: [self setSelectedMorph: nil].! ! 328057 328058"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 328059 328060SimpleHierarchicalListMorph class 328061 instanceVariableNames: 'expandedForm notExpandedForm'! 328062 328063!SimpleHierarchicalListMorph class methodsFor: 'examples' stamp: 'ls 3/1/2004 17:32'! 328064submorphsExample 328065 "display a hierarchical list of the World plus its submorphs plus its submorphs' submorphs etc." 328066 "[SimpleHierarchicalListMorph submorphsExample]" 328067 | morph | 328068 morph := 328069 SimpleHierarchicalListMorph 328070 on: [ Array with: (MorphWithSubmorphsWrapper with: World) ] 328071 list: #value 328072 selected: nil 328073 changeSelected: nil 328074 menu: nil 328075 keystroke: nil. 328076 328077 morph openInWindow! ! 328078 328079 328080!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: 'nk 3/8/2004 10:05'! 328081expandedForm 328082 328083 expandedForm ifNotNil: [ expandedForm depth ~= Display depth ifTrue: [ expandedForm := nil ]]. 328084 328085 ^expandedForm ifNil: [expandedForm := 328086 (Form 328087 extent: 10@9 328088 depth: 8 328089 fromArray: #( 4294967295 4294967295 4294901760 4294967295 4294967295 4294901760 4278255873 16843009 16842752 4294902089 1229539657 33488896 4294967041 1229539585 4294901760 4294967295 21561855 4294901760 4294967295 4278321151 4294901760 4294967295 4294967295 4294901760 4294967295 4294967295 4294901760) 328090 offset: 0@0) 328091 asFormOfDepth: Display depth; 328092 replaceColor: Color white withColor: Color transparent; 328093 yourself 328094 ]. 328095! ! 328096 328097!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: 'nk 3/8/2004 10:06'! 328098notExpandedForm 328099 328100 notExpandedForm ifNotNil: [ notExpandedForm depth ~= Display depth ifTrue: [ notExpandedForm := nil ]]. 328101 328102 ^notExpandedForm ifNil: [notExpandedForm := 328103 (Form 328104 extent: 10@9 328105 depth: 8 328106 fromArray: #( 4294967041 4294967295 4294901760 4294967041 33554431 4294901760 4294967041 1224867839 4294901760 4294967041 1229521407 4294901760 4294967041 1229539585 4294901760 4294967041 1229521407 4294901760 4294967041 1224867839 4294901760 4294967041 33554431 4294901760 4294967041 4294967295 4294901760) 328107 offset: 0@0) 328108 asFormOfDepth: Display depth; 328109 replaceColor: Color white withColor: Color transparent; 328110 yourself 328111 ]. 328112! ! 328113 328114!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:34'! 328115on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel 328116 "Create a 'pluggable' list view on the given model parameterized by the given message selectors." 328117 328118 ^ self new 328119 on: anObject 328120 list: getListSel 328121 selected: getSelectionSel 328122 changeSelected: setSelectionSel 328123 menu: nil 328124 keystroke: #arrowKey:from: "default"! ! 328125 328126!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:34'! 328127on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel 328128 "Create a 'pluggable' list view on the given model parameterized by the given message selectors." 328129 328130 ^ self new 328131 on: anObject 328132 list: getListSel 328133 selected: getSelectionSel 328134 changeSelected: setSelectionSel 328135 menu: getMenuSel 328136 keystroke: #arrowKey:from: "default" 328137! ! 328138 328139!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:34'! 328140on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel 328141 "Create a 'pluggable' list view on the given model parameterized by the given message selectors." 328142 328143 ^ self new 328144 on: anObject 328145 list: getListSel 328146 selected: getSelectionSel 328147 changeSelected: setSelectionSel 328148 menu: getMenuSel 328149 keystroke: keyActionSel 328150! ! 328151Model subclass: #SimpleServiceEntry 328152 instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel' 328153 classVariableNames: '' 328154 poolDictionaries: '' 328155 category: 'System-FileRegistry'! 328156!SimpleServiceEntry commentStamp: '<historical>' prior: 0! 328157I represent a service 328158 328159provider : the service provider 328160label : to be display in a menu 328161selector : to do the service 328162useLineAfter 328163stateSelector : a secondary selector (to be able to query state of the provider for example) 328164description : a description for balloon for example 328165argumentGetter : a selector to get additional arguments with (if selector requres them) 328166buttonLabel : a short label 328167 328168The entire client interface (provided by FileList and other users of the registry) 328169is this (browse #getArgumentsFrom: and the 328170senders of #argumentGetter:): 328171 328172fullName (returns a String with the full filename) 328173dirAndFileName (returns {directory. fileName}) 328174readOnlyStream (returns an open read-only stream) 328175! 328176 328177 328178!SimpleServiceEntry methodsFor: 'accessing' stamp: 'RAA 2/2/2002 08:14'! 328179argumentGetter: aBlock 328180 328181 argumentGetter := aBlock! ! 328182 328183!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sw 2/15/2002 17:53'! 328184buttonLabel 328185 "Answer the label to be emblazoned on a button representing the service in a file list, for example" 328186 328187 ^ buttonLabel ifNil: [label]! ! 328188 328189!SimpleServiceEntry methodsFor: 'accessing' stamp: 'dgd 9/1/2003 12:16'! 328190buttonLabel: aString 328191 "Set the receiver's buttonLabel, to be used on a button in a 328192 tool-pane; this is split out so that a more abbreviated wording 328193 can be deployed if desired" 328194 buttonLabel := aString translated! ! 328195 328196!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sd 1/31/2002 21:03'! 328197description 328198 "may be used for balloon or other" 328199 328200 ^ description 328201! ! 328202 328203!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sd 1/31/2002 21:03'! 328204description: aString 328205 "may be used for balloon or other" 328206 328207 description := aString 328208! ! 328209 328210!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sd 1/31/2002 21:10'! 328211extraSelector 328212 "normally should not be used directly" 328213 328214 ^stateSelector! ! 328215 328216!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sd 1/31/2002 21:11'! 328217extraSelector: aSymbol 328218 328219 stateSelector := aSymbol! ! 328220 328221!SimpleServiceEntry methodsFor: 'accessing' stamp: 'tak 9/25/2008 16:09'! 328222label 328223 ^label! ! 328224 328225!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sd 1/31/2002 21:38'! 328226provider 328227 328228 ^ provider! ! 328229 328230!SimpleServiceEntry methodsFor: 'accessing' stamp: 'dgd 9/1/2003 12:12'! 328231provider: anObject label: aString selector: aSymbol 328232 "basic initialization message" 328233 provider := anObject. 328234 label := aString translated. 328235 selector := aSymbol. 328236 stateSelector := #none. 328237 description := ''! ! 328238 328239!SimpleServiceEntry methodsFor: 'accessing' stamp: 'sd 1/31/2002 21:09'! 328240selector 328241 "normally should not be used directly" 328242 328243 ^selector! ! 328244 328245 328246!SimpleServiceEntry methodsFor: 'extra' stamp: 'nk 6/8/2004 16:42'! 328247performExtraFor: anObject 328248 "carry out the extra service I provide" 328249 "the stateSelector can be used to ask state of the provider to be reflected in button or other" 328250 328251 ^stateSelector numArgs = 0 328252 ifTrue: [provider perform: stateSelector] 328253 ifFalse: [provider perform: stateSelector with: (self getArgumentsFrom: anObject) ] 328254! ! 328255 328256!SimpleServiceEntry methodsFor: 'extra' stamp: 'sd 1/31/2002 21:08'! 328257requestExtraSelector 328258 "send me this message to ask me to perform secondary service" 328259 328260 ^#performExtraFor: 328261! ! 328262 328263 328264!SimpleServiceEntry methodsFor: 'performing service' stamp: 'jrp 7/30/2005 22:35'! 328265buttonToTriggerIn: aFileList 328266 "Answer a button that will trigger the receiver service in a file list" 328267 328268 | aButton | 328269 aButton := PluggableButtonMorph 328270 on: self 328271 getState: nil 328272 action: #performServiceFor:. 328273 aButton 328274 arguments: { aFileList }. 328275 328276 aButton 328277 color: Color transparent; 328278 hResizing: #spaceFill; 328279 vResizing: #spaceFill; 328280 label: self buttonLabel; 328281 askBeforeChanging: true; 328282 onColor: Color white offColor: Color white. 328283 aButton setBalloonText: self description. 328284 328285 ^ aButton! ! 328286 328287!SimpleServiceEntry methodsFor: 'performing service' stamp: 'RAA 2/2/2002 08:31'! 328288getArgumentsFrom: aProvider 328289 328290 argumentGetter ifNil: [^aProvider fullName]. 328291 ^argumentGetter value: aProvider! ! 328292 328293!SimpleServiceEntry methodsFor: 'performing service' stamp: 'nk 8/31/2004 19:30'! 328294performServiceFor: anObject 328295 "carry out the service I provide" 328296 328297 ^selector numArgs = 0 328298 ifTrue: [provider perform: selector] 328299 ifFalse: [ 328300 selector numArgs = 1 328301 ifTrue: [ provider perform: selector with: (self getArgumentsFrom: anObject) ] 328302 ifFalse: [ provider perform: selector withArguments: (self getArgumentsFrom: anObject) ]]! ! 328303 328304!SimpleServiceEntry methodsFor: 'performing service' stamp: 'dgd 9/1/2003 12:13'! 328305provider: anObject label: aString selector: aSymbol description: anotherString 328306 "basic initialization message" 328307 self 328308 provider: anObject 328309 label: aString 328310 selector: aSymbol. 328311 stateSelector := #none. 328312 description := anotherString translated! ! 328313 328314 328315!SimpleServiceEntry methodsFor: 'printing' stamp: 'nk 10/14/2003 10:04'! 328316printOn: aStream 328317 328318 aStream nextPutAll: self class name; nextPutAll: ': ('. 328319 self provider notNil 328320 ifTrue: [aStream nextPutAll: provider printString]. 328321 aStream nextPutAll: ' --- '. 328322 self selector notNil 328323 ifTrue: [aStream nextPutAll: selector asString]. 328324 aStream nextPut: $) 328325 328326! ! 328327 328328 328329!SimpleServiceEntry methodsFor: 'services menu' stamp: 'yo 8/22/2008 21:40'! 328330addServiceFor: served toMenu: aMenu 328331 aMenu add: self label 328332 target: self 328333 selector: #performServiceFor: "self requestSelector " 328334 argument: served. 328335 self useLineAfter ifTrue: [ aMenu addLine ].! ! 328336 328337!SimpleServiceEntry methodsFor: 'services menu' stamp: 'tak 9/25/2008 15:10'! 328338useLineAfter 328339 328340 ^ useLineAfter == true! ! 328341 328342!SimpleServiceEntry methodsFor: 'services menu' stamp: 'tak 9/25/2008 15:10'! 328343useLineAfter: aBoolean 328344 328345 useLineAfter := aBoolean 328346! ! 328347 328348 328349!SimpleServiceEntry methodsFor: 'toolbuilder' stamp: 'ar 2/12/2005 14:34'! 328350buildWith: builder in: aModel 328351 "Answer a button spec that will trigger the receiver service in aModel" 328352 | buttonSpec | 328353 buttonSpec := builder pluggableActionButtonSpec new. 328354 buttonSpec 328355 model: self; 328356 label: self buttonLabel; 328357 help: self description; 328358 action: (MessageSend receiver: aModel selector: #executeService: argument: self). 328359 ^builder build: buttonSpec! ! 328360 328361"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 328362 328363SimpleServiceEntry class 328364 instanceVariableNames: ''! 328365 328366!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'yo 8/22/2008 20:58'! 328367provider: anObject label: aString selector: aSymbol 328368 328369 ^self provider: anObject label: aString selector: aSymbol description: ''. 328370! ! 328371 328372!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'sd 1/31/2002 22:05'! 328373provider: anObject label: aString selector: aSymbol description: anotherString 328374 328375 ^self new provider: anObject label: aString selector: aSymbol description: anotherString! ! 328376 328377!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'sw 2/17/2002 02:48'! 328378provider: anObject label: aString selector: aSymbol description: anotherString buttonLabel: aLabel 328379 "Answer a new service object with the given initializations. This variant allows a custom button label to be provided, in order to preserve precious horizontal real-estate in the button pane, while still allowing more descriptive wordings in the popup menu" 328380 328381 ^ self new provider: anObject label: aString selector: aSymbol description: anotherString; buttonLabel: aLabel; yourself! ! 328382SimpleButtonMorph subclass: #SimpleSwitchMorph 328383 instanceVariableNames: 'onColor offColor' 328384 classVariableNames: '' 328385 poolDictionaries: '' 328386 category: 'Morphic-Widgets'! 328387!SimpleSwitchMorph commentStamp: 'apb 5/3/2006 16:04' prior: 0! 328388I represent a switch that can be either on or off. I chnage my state in response to a mouse click. When clicked, I also send my actionSelector to my target, just like a SimpleButtonMorph.! 328389 328390 328391!SimpleSwitchMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:42'! 328392defaultLabel 328393 ^ 'Toggle'. 328394! ! 328395 328396!SimpleSwitchMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:42'! 328397initialize 328398 super initialize. 328399 self borderWidth: 3. 328400 self extent: self extent + 2. 328401 onColor := Color r: 1.0 g: 0.6 b: 0.6. 328402 offColor := Color lightGray. 328403 color := offColor. 328404! ! 328405 328406 328407!SimpleSwitchMorph methodsFor: 'button' stamp: 'dgd 2/22/2003 18:40'! 328408doButtonAction 328409 "Perform the action of this button. The last argument of the message sent to the target is the new state of this switch." 328410 328411 | newState | 328412 (target notNil and: [actionSelector notNil]) 328413 ifTrue: 328414 [newState := color = onColor. 328415 target perform: actionSelector 328416 withArguments: (arguments copyWith: newState)]! ! 328417 328418 328419!SimpleSwitchMorph methodsFor: 'switching' stamp: 'apb 5/3/2006 15:45'! 328420isOff 328421 ^ color ~= onColor! ! 328422 328423!SimpleSwitchMorph methodsFor: 'switching' stamp: 'apb 5/3/2006 15:45'! 328424isOn 328425 ^ color = onColor! ! 328426 328427!SimpleSwitchMorph methodsFor: 'switching' stamp: 'jm 1/29/98 20:18'! 328428offColor 328429 328430 ^ offColor 328431! ! 328432 328433!SimpleSwitchMorph methodsFor: 'switching' stamp: 'jm 1/29/98 20:18'! 328434offColor: aColor 328435 328436 offColor := aColor. 328437! ! 328438 328439!SimpleSwitchMorph methodsFor: 'switching' stamp: 'jm 1/29/98 20:18'! 328440onColor 328441 328442 ^ onColor 328443! ! 328444 328445!SimpleSwitchMorph methodsFor: 'switching' stamp: 'jm 1/29/98 20:18'! 328446onColor: aColor 328447 328448 onColor := aColor. 328449! ! 328450 328451!SimpleSwitchMorph methodsFor: 'switching' stamp: 'apb 5/3/2006 15:46'! 328452setSwitchState: aBoolean 328453 328454 aBoolean 328455 ifTrue: [self turnOn] 328456 ifFalse: [self turnOff]. 328457! ! 328458 328459!SimpleSwitchMorph methodsFor: 'switching' stamp: 'apb 5/3/2006 16:11'! 328460toggleState 328461 self isOn 328462 ifTrue: [self turnOff] 328463 ifFalse: [self turnOn]! ! 328464 328465!SimpleSwitchMorph methodsFor: 'switching' stamp: 'apb 5/3/2006 15:44'! 328466turnOff 328467 self borderColor: #raised. 328468 self color: offColor! ! 328469 328470!SimpleSwitchMorph methodsFor: 'switching' stamp: 'apb 5/3/2006 15:44'! 328471turnOn 328472 self borderColor: #inset. 328473 self color: onColor! ! 328474 328475 328476!SimpleSwitchMorph methodsFor: 'event handling' stamp: 'ar 6/4/2001 00:39'! 328477mouseDown: evt 328478 328479 oldColor := self fillStyle.! ! 328480 328481!SimpleSwitchMorph methodsFor: 'event handling' stamp: 'jm 1/30/98 13:55'! 328482mouseMove: evt 328483 328484 (self containsPoint: evt cursorPoint) 328485 ifTrue: [self setSwitchState: (oldColor = offColor)] 328486 ifFalse: [self setSwitchState: (oldColor = onColor)]. 328487! ! 328488 328489!SimpleSwitchMorph methodsFor: 'event handling' stamp: 'jm 1/30/98 13:58'! 328490mouseUp: evt 328491 328492 (self containsPoint: evt cursorPoint) 328493 ifTrue: [ "toggle and do action" 328494 self setSwitchState: (oldColor = offColor). 328495 self doButtonAction] 328496 ifFalse: [ "restore old appearance" 328497 self setSwitchState: (oldColor = onColor)]. 328498! ! 328499TestCase subclass: #SimpleSwitchMorphTest 328500 instanceVariableNames: 'testSwitch' 328501 classVariableNames: '' 328502 poolDictionaries: '' 328503 category: 'MorphicTests-Widgets'! 328504!SimpleSwitchMorphTest commentStamp: '<historical>' prior: 0! 328505I test the behavior of SimpleSwitchMorph! 328506 328507 328508!SimpleSwitchMorphTest methodsFor: 'initialize' stamp: 'StephaneDucasse 9/6/2009 16:47'! 328509setUp 328510 328511 testSwitch := SimpleSwitchMorph new! ! 328512 328513 328514!SimpleSwitchMorphTest methodsFor: 'tests' stamp: 'apb 5/3/2006 16:17'! 328515testName 328516 328517 self assert: testSwitch externalName = 'SimpleSwitch'! ! 328518 328519!SimpleSwitchMorphTest methodsFor: 'tests' stamp: 'apb 5/3/2006 16:11'! 328520testState 328521 self assert: testSwitch isOff. 328522 self deny: testSwitch isOn. 328523 testSwitch toggleState. 328524 self assert: testSwitch isOn. 328525 self deny: testSwitch isOff! ! 328526 328527!SimpleSwitchMorphTest methodsFor: 'tests' stamp: 'apb 5/3/2006 16:14'! 328528testSwitching 328529 328530 testSwitch setSwitchState: false. 328531 self assert: testSwitch isOff. 328532 self assert: testSwitch color = testSwitch offColor. 328533 testSwitch setSwitchState: true. 328534 self assert: testSwitch isOn. 328535 self assert: testSwitch color = testSwitch onColor.! ! 328536TestResource subclass: #SimpleTestResource 328537 instanceVariableNames: 'runningState hasRun hasSetup hasRanOnce' 328538 classVariableNames: '' 328539 poolDictionaries: '' 328540 category: 'SUnit-Tests'! 328541 328542!SimpleTestResource methodsFor: 'accessing'! 328543runningState 328544 328545 ^runningState 328546 ! ! 328547 328548!SimpleTestResource methodsFor: 'accessing'! 328549runningState: aSymbol 328550 328551 runningState := aSymbol 328552 ! ! 328553 328554 328555!SimpleTestResource methodsFor: 'running'! 328556setRun 328557 hasRun := true 328558 ! ! 328559 328560!SimpleTestResource methodsFor: 'running'! 328561setUp 328562 328563 self runningState: self startedStateSymbol. 328564 hasSetup := true 328565 ! ! 328566 328567!SimpleTestResource methodsFor: 'running'! 328568startedStateSymbol 328569 328570 ^#started 328571 ! ! 328572 328573!SimpleTestResource methodsFor: 'running'! 328574stoppedStateSymbol 328575 328576 ^#stopped 328577 ! ! 328578 328579!SimpleTestResource methodsFor: 'running'! 328580tearDown 328581 328582 self runningState: self stoppedStateSymbol 328583 ! ! 328584 328585 328586!SimpleTestResource methodsFor: 'testing'! 328587hasRun 328588 ^hasRun 328589 ! ! 328590 328591!SimpleTestResource methodsFor: 'testing'! 328592hasSetup 328593 ^hasSetup 328594 ! ! 328595 328596!SimpleTestResource methodsFor: 'testing'! 328597isAvailable 328598 328599 ^self runningState == self startedStateSymbol 328600 ! ! 328601TestCase subclass: #SimpleTestResourceTestCase 328602 instanceVariableNames: 'resource' 328603 classVariableNames: '' 328604 poolDictionaries: '' 328605 category: 'SUnit-Tests'! 328606 328607!SimpleTestResourceTestCase methodsFor: 'not categorized'! 328608dummy 328609 self assert: true 328610 ! ! 328611 328612!SimpleTestResourceTestCase methodsFor: 'not categorized'! 328613error 328614 'foo' odd 328615 ! ! 328616 328617!SimpleTestResourceTestCase methodsFor: 'not categorized'! 328618fail 328619 self assert: false 328620 ! ! 328621 328622!SimpleTestResourceTestCase methodsFor: 'not categorized'! 328623setRun 328624 resource setRun 328625 ! ! 328626 328627!SimpleTestResourceTestCase methodsFor: 'not categorized'! 328628setUp 328629 resource := SimpleTestResource current 328630 ! ! 328631 328632!SimpleTestResourceTestCase methodsFor: 'not categorized'! 328633testResourceInitRelease 328634 | result suite error failure | 328635 suite := TestSuite new. 328636 suite addTest: (error := self class selector: #error). 328637 suite addTest: (failure := self class selector: #fail). 328638 suite addTest: (self class selector: #dummy). 328639 result := suite run. 328640 self assert: resource hasSetup 328641 ! ! 328642 328643!SimpleTestResourceTestCase methodsFor: 'not categorized'! 328644testResourcesCollection 328645 | collection | 328646 collection := self resources. 328647 self assert: collection size = 1 328648 ! ! 328649 328650"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 328651 328652SimpleTestResourceTestCase class 328653 instanceVariableNames: ''! 328654 328655!SimpleTestResourceTestCase class methodsFor: 'history' stamp: 'AdrianLienhard 10/19/2009 10:49'! 328656lastStoredRun 328657 ^ ((Dictionary new) add: (#passed->((Set new) add: #testResourceInitRelease; add: #testResourcesCollection; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ! 328658 328659 328660!SimpleTestResourceTestCase class methodsFor: 'not categorized'! 328661resources 328662 ^Set new add: SimpleTestResource; yourself 328663 ! ! 328664LanguageEnvironment subclass: #SimplifiedChineseEnvironment 328665 instanceVariableNames: '' 328666 classVariableNames: '' 328667 poolDictionaries: '' 328668 category: 'Multilingual-Languages'! 328669!SimplifiedChineseEnvironment commentStamp: '<historical>' prior: 0! 328670This class provides the Simplified Chinese support (Used mainly in Mainland China). Unfortunately, we haven't tested this yet, but as soon as we find somebody who understand the language, probably we can make it work in two days or so, as we have done for Czech support.! 328671 328672 328673"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 328674 328675SimplifiedChineseEnvironment class 328676 instanceVariableNames: ''! 328677 328678!SimplifiedChineseEnvironment class methodsFor: 'language methods' stamp: 'yo 3/16/2004 14:55'! 328679traditionalCharsetClass 328680 328681 ^ GB2312 328682! ! 328683 328684 328685!SimplifiedChineseEnvironment class methodsFor: 'public query' stamp: 'nk 7/30/2004 21:46'! 328686defaultEncodingName 328687 | platformName osVersion | 328688 platformName := SmalltalkImage current platformName. 328689 osVersion := SmalltalkImage current getSystemAttribute: 1002. 328690 (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8' copy]. 328691 (#('Win32' 'Mac OS' 'ZaurusOS') includes: platformName) 328692 ifTrue: [^'gb2312' copy]. 328693 (#('unix') includes: platformName) ifTrue: [^'euc-cn' copy]. 328694 ^'mac-roman'! ! 328695 328696 328697!SimplifiedChineseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 18:22'! 328698supportedLanguages 328699 "Return the languages that this class supports. 328700 Any translations for those languages will use this class as their environment." 328701 328702 ^#('zh' )! ! 328703Morph subclass: #SketchEditorMorph 328704 instanceVariableNames: 'hostView palette ticksToDwell rotationCenter registrationPoint newPicBlock emptyPicBlock paintingForm dimForm formCanvas rotationButton scaleButton cumRot cumMag undoBuffer enclosingPasteUpMorph forEachHand' 328705 classVariableNames: 'SketchTimes' 328706 poolDictionaries: '' 328707 category: 'Morphic-Basic'! 328708!SketchEditorMorph commentStamp: '<historical>' prior: 0! 328709Inst vars (converting to morphic events) 328710hostView -- SketchMorph we are working on. 328711stampForm -- Stamp is stored here. 328712canvasRectangle -- later use bounds 328713palette -- the PaintBox interface Morph 328714dirty -- not used 328715currentColor 328716ticksToDwell rotationCenter registrationPoint 328717newPicBlock -- do this after painting 328718action -- selector of painting action 328719paintingForm -- our copy 328720composite -- now paintArea origin. world relative. stop using it. 328721dimForm -- SketchMorph of the dimmed background. Opaque. 328722 installed behind the editor morph. 328723buff 328724brush -- 1-bit Form of the brush, 328725paintingFormPen 328726formCanvas -- Aim it at paintingForm to allow it to draw ovals, rectangles, lines, etc. 328727picToComp dimToComp compToDisplay -- used to composite -- obsolete 328728picToBuff brushToBuff buffToBuff buffToPic 328729rotationButton scaleButton -- submorphs, handles to do these actions. 328730strokeOrigin -- During Pickup, origin of rect. 328731cumRot cumMag -- cumulative for multiple operations from same original 328732undoBuffer 328733lastEvent 328734currentNib -- 1 bit deep form. 328735 328736 328737For now, we do not carry the SketchMorph's registration point, rotation center, or ticksToDwell. 328738 328739New -- using transform morphs to rotate the finished player. How get it rotated back and the rotationDegrees to be right? We cancel out rotationDegrees, so how remember it? 328740 328741Registration point convention: 328742In a GraphicFrame, reg point is relative to this image's origin. 328743During painting, it is relative to canvasRectangle origin, and thus us absolute within the canvas. To convert back, subract newBox origin. 328744 328745Be sure to convert back and forth correctly. In deliverPainting. initializeFromFrame:inView: ! 328746 328747 328748!SketchEditorMorph methodsFor: 'access' stamp: 'sw 9/2/1999 11:03'! 328749enclosingPasteUpMorph 328750 ^ enclosingPasteUpMorph! ! 328751 328752!SketchEditorMorph methodsFor: 'access'! 328753hostView 328754 ^ hostView! ! 328755 328756!SketchEditorMorph methodsFor: 'access'! 328757painting 328758 ^ paintingForm! ! 328759 328760!SketchEditorMorph methodsFor: 'access'! 328761palette 328762 ^palette! ! 328763 328764!SketchEditorMorph methodsFor: 'access'! 328765registrationPoint 328766 ^ registrationPoint! ! 328767 328768!SketchEditorMorph methodsFor: 'access'! 328769registrationPoint: aPoint 328770 registrationPoint := aPoint! ! 328771 328772!SketchEditorMorph methodsFor: 'access' stamp: 'dgd 2/21/2003 23:07'! 328773ticksToDwell 328774 ticksToDwell isNil ifTrue: [ticksToDwell := 1]. 328775 ^ticksToDwell! ! 328776 328777!SketchEditorMorph methodsFor: 'access'! 328778ticksToDwell: t 328779 ticksToDwell := t! ! 328780 328781 328782!SketchEditorMorph methodsFor: 'accessing' stamp: 'ar 9/22/2000 20:35'! 328783forwardDirection 328784 "The direction object will go when issued a sent forward:. Up is 328785zero. Clockwise like a compass. From the arrow control." 328786 ^ hostView forwardDirection! ! 328787 328788 328789!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 10/21/97 16:32'! 328790clear 328791 "wipe out all the paint" 328792 328793 self polyFreeze. "end polygon mode" 328794 paintingForm fillWithColor: Color transparent. 328795 self invalidRect: bounds.! ! 328796 328797!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'sw 4/21/2004 13:23'! 328798ellipse: evt 328799 "Draw an ellipse from the center. " 328800 328801 | rect oldRect ww ext oldExt cColor sOrigin priorEvt | 328802 328803 sOrigin := self get: #strokeOrigin for: evt. 328804 cColor := self getColorFor: evt. 328805 ext := (sOrigin - evt cursorPoint) abs * 2. 328806 evt shiftPressed ifTrue: [ext := self shiftConstrainPoint: ext]. 328807 rect := Rectangle center: sOrigin extent: ext. 328808 ww := (self getNibFor: evt) width. 328809 (priorEvt := self get: #lastEvent for: evt) ifNotNil: [ 328810 oldExt := (sOrigin - priorEvt cursorPoint) abs + ww * 2. 328811 priorEvt shiftPressed ifTrue: [oldExt := self shiftConstrainPoint: oldExt]. 328812 (oldExt < ext) ifFalse: ["Last draw sticks out, must erase the area" 328813 oldRect := Rectangle center: sOrigin extent: oldExt. 328814 self restoreRect: oldRect]]. 328815 cColor == Color transparent 328816 ifFalse: 328817 [formCanvas fillOval: rect color: Color transparent borderWidth: ww borderColor: cColor] 328818 ifTrue: 328819 [formCanvas fillOval: rect color: cColor borderWidth: ww borderColor: Color black]. 328820 328821 self invalidRect: rect. 328822 328823! ! 328824 328825!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 7/2/97 09:02'! 328826erase: evt 328827 "Pen is set up to draw transparent squares" 328828 self paint: evt 328829! ! 328830 328831!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/16/2000 11:30'! 328832erasePrep: evt 328833 "Transparent paint, square brush. Be careful not to let this be undone by asking palette for brush and color." 328834 328835 | size pfPen myBrush | 328836 328837 pfPen := self get: #paintingFormPen for: evt. 328838 size := (self getNibFor: evt) width. 328839 self set: #brush for: evt to: (myBrush := Form extent: size@size depth: 1). 328840 myBrush offset: (0@0) - (myBrush extent // 2). 328841 myBrush fillWithColor: Color black. 328842 pfPen sourceForm: myBrush. 328843 "transparent" 328844 pfPen combinationRule: Form erase1bitShape. 328845 pfPen color: Color black. 328846! ! 328847 328848!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 12/19/2000 19:53'! 328849fill: evt 328850 "Find the area that is the same color as where you clicked. Fill it with 328851 the current paint color." 328852 | box | 328853 evt isMouseUp 328854 ifFalse: [^ self]. 328855 "Only fill upon mouseUp" 328856 "would like to only invalidate the area changed, but can't find out what it is." 328857 Cursor execute 328858 showWhile: [ 328859 box := paintingForm 328860 floodFill: (self getColorFor: evt) 328861 at: evt cursorPoint - bounds origin. 328862 self render: (box translateBy: bounds origin)]! ! 328863 328864!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 20:06'! 328865flipHoriz: evt 328866 "Flip the image" 328867 | temp myBuff | 328868 328869 myBuff := self get: #buff for: evt. 328870 temp := myBuff deepCopy flipBy: #horizontal centerAt: myBuff center. 328871 temp offset: 0 @ 0. 328872 paintingForm fillWithColor: Color transparent. 328873 temp displayOn: paintingForm at: paintingForm center - myBuff center + myBuff offset. 328874 rotationButton position: evt cursorPoint x - 6 @ rotationButton position y. 328875 self render: bounds! ! 328876 328877!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 20:06'! 328878flipVert: evt 328879 "Flip the image" 328880 | temp myBuff | 328881 328882 myBuff := self get: #buff for: evt. 328883 temp := myBuff deepCopy flipBy: #vertical centerAt: myBuff center. 328884 temp offset: 0 @ 0. 328885 paintingForm fillWithColor: Color transparent. 328886 temp displayOn: paintingForm at: paintingForm center - myBuff center + myBuff offset. 328887 rotationButton position: evt cursorPoint x - 6 @ rotationButton position y. 328888 self render: bounds! ! 328889 328890!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'aoy 2/15/2003 21:46'! 328891forward: evt direction: button 328892 "Move the forward direction arrow of this painting. When the user 328893says forward:, the object moves in the direction of the arrow. evt may be 328894an Event (from the user moving the arrow), or an initial number ofdegrees." 328895 328896 | center dir ww ff | 328897 center := bounds center. "+ (rotationButton width - 6 @ 0)" 328898 dir := evt isNumber 328899 ifTrue: 328900 [Point r: 100 degrees: evt - 90.0 328901 "convert to 0 on X axis"] 328902 ifFalse: [evt cursorPoint - center]. 328903 ww := (bounds height min: bounds width) // 2 - 7. 328904 button 328905 setVertices: (Array with: center + (Point r: ww degrees: dir degrees) 328906 with: center + (Point r: ww - 15 degrees: dir degrees)). 328907 (ff := self valueOfProperty: #fwdToggle) 328908 position: center + (Point r: ww - 7 degrees: dir degrees + 6.5) 328909 - (ff extent // 2). 328910 self showDirType! ! 328911 328912!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/16/2000 11:54'! 328913line: evt 328914 "Draw a line on the paintingForm using formCanvas aimed at it." 328915 | rect oldRect ww now diff cor cColor sOrigin priorEvt | 328916 sOrigin := self get: #strokeOrigin for: evt. 328917 rect := sOrigin rect: (now := evt cursorPoint). 328918 evt shiftPressed 328919 ifTrue: [diff := evt cursorPoint - sOrigin. 328920 now := sOrigin 328921 + (Point r: diff r degrees: diff degrees + 22.5 // 45 * 45). 328922 rect := sOrigin rect: now]. 328923 ww := (self getNibFor: evt) width. 328924 (priorEvt := self get: #lastEvent for: evt) 328925 ifNotNil: [oldRect := sOrigin rect: priorEvt cursorPoint. 328926 priorEvt shiftPressed 328927 ifTrue: [diff := priorEvt cursorPoint - sOrigin. 328928 cor := sOrigin 328929 + (Point r: diff r degrees: diff degrees + 22.5 // 45 * 45). 328930 oldRect := sOrigin rect: cor]. 328931 oldRect := oldRect expandBy: ww @ ww. 328932 "Last draw will always stick out, must erase the area" 328933 self restoreRect: oldRect]. 328934 cColor := self getColorFor: evt. 328935 formCanvas 328936 line: sOrigin 328937 to: now 328938 width: ww 328939 color: cColor. 328940 self invalidRect: rect! ! 328941 328942!SketchEditorMorph methodsFor: 'actions & preps'! 328943notes 328944 " 328945Singleton costumes. 328946Registration points 328947"! ! 328948 328949!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/16/2000 11:22'! 328950paint: evt 328951 "While the mouse is down, lay down paint, but only within window bounds. 328952 11/28/96 sw: no longer stop painting when pen strays out of window; once it comes back in, resume painting rather than waiting for a mouse up" 328953 328954 | mousePoint startRect endRect startToEnd pfPen myBrush | 328955 328956 pfPen := self get: #paintingFormPen for: evt. 328957 myBrush := self getBrushFor: evt. 328958 mousePoint := evt cursorPoint. 328959 startRect := pfPen location + myBrush offset extent: myBrush extent. 328960 pfPen goto: mousePoint - bounds origin. 328961 endRect := pfPen location + myBrush offset extent: myBrush extent. 328962 "self render: (startRect merge: endRect). Show the user what happened" 328963 startToEnd := startRect merge: endRect. 328964 self invalidRect: (startToEnd translateBy: bounds origin). 328965! ! 328966 328967!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'dgd 2/21/2003 23:06'! 328968pickup: evt 328969 "Grab a part of the picture (or screen) and store it in a known place. Note where we started. Use a rubberband rectangle to show what is being selected." 328970 328971 | rect oldRect sOrigin priorEvt | 328972 sOrigin := self get: #strokeOrigin for: evt. 328973 rect := sOrigin rect: evt cursorPoint + (14 @ 14). 328974 (priorEvt := self get: #lastEvent for: evt) isNil 328975 ifFalse: 328976 ["Last draw will stick out, must erase the area" 328977 328978 oldRect := sOrigin rect: priorEvt cursorPoint + (14 @ 14). 328979 self restoreRect: (oldRect insetBy: -2)]. 328980 formCanvas 328981 frameAndFillRectangle: (rect insetBy: -2) 328982 fillColor: Color transparent 328983 borderWidth: 2 328984 borderColor: Color gray. 328985 self invalidRect: (rect insetBy: -2)! ! 328986 328987!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'dgd 2/21/2003 23:06'! 328988pickupMouseUp: evt 328989 "Grab a part of the picture (or screen) and store it in a known place. Like Copy on the Mac menu. Then switch to the stamp tool." 328990 328991 | rr pForm ii oldRect sOrigin priorEvt | 328992 sOrigin := self get: #strokeOrigin for: evt. 328993 (priorEvt := self get: #lastEvent for: evt) isNil 328994 ifFalse: 328995 ["Last draw will stick out, must erase the area" 328996 328997 oldRect := sOrigin rect: priorEvt cursorPoint + (14 @ 14). 328998 self restoreRect: (oldRect insetBy: -2)]. 328999 self primaryHand showTemporaryCursor: nil. "later get rid of this" 329000 rr := sOrigin rect: evt cursorPoint + (14 @ 14). 329001 ii := rr translateBy: 0 @ 0 - bounds origin. 329002 (rr intersects: bounds) 329003 ifTrue: 329004 [pForm := paintingForm copy: ii. 329005 pForm isAllWhite 329006 ifFalse: 329007 ["means transparent" 329008 329009 "normal case. Can be transparent in parts" 329010 329011 ] 329012 ifTrue: 329013 [pForm := nil 329014 "Get an un-dimmed picture of other objects on the playfield" 329015 "don't know how yet"]]. 329016 pForm ifNil: [pForm := Form fromDisplay: rr]. "Anywhere on the screen" 329017 palette pickupForm: pForm evt: evt. 329018 evt hand showTemporaryCursor: (self getCursorFor: evt)! ! 329019 329020!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:40'! 329021polyEdit: evt 329022 "Add handles and let user drag'em around" 329023 | poly | 329024 poly := self valueOfProperty: #polygon. 329025 poly ifNil:[^self]. 329026 poly addHandles. 329027 self polyEditing: true. 329028 self setProperty: #polyCursor toValue: palette plainCursor. 329029 palette plainCursor: Cursor normal event: evt.! ! 329030 329031!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:28'! 329032polyEditing 329033 ^self valueOfProperty: #polyEditing ifAbsent:[false]! ! 329034 329035!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:28'! 329036polyEditing: aBool 329037 aBool 329038 ifTrue:[self setProperty: #polyEditing toValue: aBool] 329039 ifFalse:[self removeProperty: #polyEditing]! ! 329040 329041!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:29'! 329042polyFreeze 329043 "A live polygon is on the painting. Draw it into the painting and 329044delete it." 329045 329046 | poly | 329047 self polyEditing ifFalse:[^self]. 329048 (poly := self valueOfProperty: #polygon) ifNil: [^ self]. 329049 poly drawOn: formCanvas. 329050 poly delete. 329051 self setProperty: #polygon toValue: nil. 329052 self polyEditing: false.! ! 329053 329054!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'sw 7/5/2004 03:20'! 329055polyNew: evt 329056 "Create a new polygon. Add it to the sketch, and let the user drag 329057its vertices around!! Freeze it into the painting when the user chooses 329058another tool." 329059 329060 | poly cColor | 329061 self polyEditing ifTrue:[ 329062 self polyFreeze. 329063 (self hasProperty: #polyCursor) 329064 ifTrue:[palette plainCursor: (self valueOfProperty: #polyCursor) event: evt. 329065 self removeProperty: #polyCursor]. 329066 ^self]. 329067 cColor := self getColorFor: evt. 329068 self polyFreeze. "any old one we were working on" 329069 poly := PolygonMorph new "addHandles". 329070 poly referencePosition: poly bounds origin. 329071 poly align: poly bounds center with: evt cursorPoint. 329072 poly borderWidth: (self getNibFor: evt) width. 329073 poly borderColor: (cColor isTransparent ifTrue: [Color black] ifFalse: [cColor]). 329074 poly color: Color transparent. 329075 self addMorph: poly. 329076 poly changed. 329077 self setProperty: #polygon toValue: poly.! ! 329078 329079!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:22'! 329080polygon: evt 329081 | poly | 329082 poly := self valueOfProperty: #polygon. 329083 poly ifNil:[^self]. 329084 evt cursorPoint > poly bounds origin ifTrue:[ 329085 poly extent: ((evt cursorPoint - poly bounds origin) max: 5@5)].! ! 329086 329087!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'sw 7/25/2004 03:16'! 329088rect: evt 329089 "While moving corner, just write on the canvas. When done, write on the paintingForm" 329090 329091 | rect oldRect now diff cor cColor sOrigin priorEvt | 329092 sOrigin := self get: #strokeOrigin for: evt. 329093 rect := sOrigin rect: (now := evt cursorPoint). 329094 cColor := self getColorFor: evt. 329095 evt shiftPressed 329096 ifTrue: [diff := evt cursorPoint - sOrigin. 329097 now := sOrigin 329098 + (Point r: (diff x abs min: diff y abs) 329099 * 2 degrees: diff degrees // 90 * 90 + 45). 329100 rect := sOrigin rect: now]. 329101 (priorEvt := self get: #lastEvent for: evt) isNil 329102 ifFalse: [oldRect := sOrigin rect: priorEvt cursorPoint. 329103 priorEvt shiftPressed 329104 ifTrue: [diff := priorEvt cursorPoint - sOrigin. 329105 cor := sOrigin 329106 + (Point r: (diff x abs min: diff y abs) 329107 * 2 degrees: diff degrees // 90 * 90 + 45). 329108 oldRect := sOrigin rect: cor]. 329109 self restoreRect: oldRect]. "Last draw will stick out, must erase the area" 329110 329111 cColor == Color transparent 329112 ifTrue: [formCanvas 329113 frameAndFillRectangle: rect 329114 fillColor: Color transparent 329115 borderWidth: (self getNibFor: evt) width 329116 borderColor: Color black] 329117 ifFalse: [formCanvas 329118 frameAndFillRectangle: rect 329119 fillColor: Color transparent 329120 borderWidth: (self getNibFor: evt) width 329121 borderColor: cColor]. 329122 self invalidRect: rect! ! 329123 329124!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 17:13'! 329125render: damageRect 329126 "Compose the damaged area again and store on the display. damageRect is relative to paintingForm origin. 3/19/97 tk" 329127 329128 self invalidRect: damageRect. "Now in same coords as self bounds" 329129! ! 329130 329131!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 6/16/97 15:38'! 329132replaceOnly: initialMousePoint 329133 "Paint replacing only one color!! Call this each stroke. Also works for replacing all but one color. " 329134 329135! ! 329136 329137!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 2/12/2000 18:35'! 329138restoreRect: oldRect 329139 "Restore the given rectangular area of the painting Form from the undo buffer." 329140 329141 formCanvas drawImage: undoBuffer 329142 at: oldRect origin 329143 sourceRect: (oldRect translateBy: self topLeft negated). 329144 self invalidRect: oldRect. 329145! ! 329146 329147!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 20:07'! 329148rotateBy: evt 329149 "Left-right is rotation. 3/26/97 tk Slider at top of window. 4/3/97 tk" 329150 | pt temp amt smooth myBuff | 329151 329152 myBuff := self get: #buff for: evt. 329153 evt cursorPoint x - self left < 20 329154 ifTrue: [^ self flipHoriz: evt]. 329155 "at left end flip horizontal" 329156 evt cursorPoint x - self right > -20 329157 ifTrue: [^ self flipVert: evt]. 329158 "at right end flip vertical" 329159 pt := evt cursorPoint - bounds center. 329160 smooth := 2. 329161 "paintingForm depth > 8 ifTrue: [2] ifFalse: [1]." 329162 "Could go back to 1 for speed" 329163 amt := pt x abs < 12 329164 ifTrue: ["detent" 329165 0] 329166 ifFalse: [pt x - (12 * pt x abs // pt x)]. 329167 amt := amt * 1.8. 329168 temp := myBuff 329169 rotateBy: amt 329170 magnify: cumMag 329171 smoothing: smooth. 329172 temp displayOn: paintingForm at: paintingForm center - temp center + myBuff offset. 329173 rotationButton position: evt cursorPoint x - 6 @ rotationButton position y. 329174 self render: bounds. 329175 cumRot := amt! ! 329176 329177!SketchEditorMorph methodsFor: 'actions & preps' stamp: '6/13/97 17:55 '! 329178rotateDone: evt 329179 "MouseUp, snap box back to center." 329180 329181" 329182self render: rotationButton bounds. 329183rotationButton position: (canvasRectangle width // 2 + composite x) @ rotationButton position y. 329184self render: rotationButton bounds. 329185" "Not snap back..."! ! 329186 329187!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/29/2000 10:01'! 329188rotateScalePrep: evt 329189 "Make a source that is the paintingForm. Work from that. 3/26/97 tk" 329190 329191 | newBox myBuff | 329192 329193 (self getActionFor: evt) == #scaleOrRotate ifTrue: [^ self]. "Already doing it" 329194 paintingForm width > 120 329195 ifTrue: [newBox := paintingForm rectangleEnclosingPixelsNotOfColor: Color transparent. 329196 "minimum size" 329197 newBox := newBox insetBy: 329198 ((18 - newBox width max: 0)//2) @ ((18 - newBox height max: 0)//2) * -1] 329199 ifFalse: [newBox := paintingForm boundingBox]. 329200 newBox := newBox expandBy: 1. 329201 self set: #buff for: evt to: (myBuff := Form extent: newBox extent depth: paintingForm depth). 329202 myBuff offset: newBox center - paintingForm center. 329203 myBuff copyBits: newBox from: paintingForm at: 0@0 329204 clippingBox: myBuff boundingBox rule: Form over fillColor: nil. 329205 "Could just run up owner chain asking colorUsed, but may not be embedded" 329206 cumRot := 0.0. cumMag := 1.0. "start over" 329207 self set: #changed for: evt to: true. 329208 self set: #action for: evt to: #scaleOrRotate. 329209 "Only changed by mouseDown with tool in paint area"! ! 329210 329211!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 20:06'! 329212scaleBy: evt 329213 "up-down is scale. 3/26/97 tk Now a slider on the right." 329214 | pt temp cy oldRect amt myBuff | 329215 329216 myBuff := self get: #buff for: evt. 329217 pt := evt cursorPoint - bounds center. 329218 cy := bounds height * 0.5. 329219 oldRect := myBuff boundingBox expandBy: myBuff extent * cumMag / 2. 329220 amt := pt y abs < 12 329221 ifTrue: ["detent" 329222 1.0] 329223 ifFalse: [pt y - (12 * pt y abs // pt x)]. 329224 amt := amt asFloat / cy + 1.0. 329225 temp := myBuff 329226 rotateBy: cumRot 329227 magnify: amt 329228 smoothing: 2. 329229 cumMag > amt 329230 ifTrue: ["shrinking" 329231 oldRect := oldRect translateBy: paintingForm center - oldRect center + myBuff offset. 329232 paintingForm 329233 fill: (oldRect expandBy: 1 @ 1) 329234 rule: Form over 329235 fillColor: Color transparent]. 329236 temp displayOn: paintingForm at: paintingForm center - temp center + myBuff offset. 329237 scaleButton position: scaleButton position x @ (evt cursorPoint y - 6). 329238 self render: bounds. 329239 cumMag := amt! ! 329240 329241!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 2/15/2001 07:18'! 329242shiftConstrainPoint: aPoint 329243 329244 "answer a point with x and y equal for shift-constrained drawing" 329245 329246 ^aPoint max: aPoint transposed! ! 329247 329248!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 9/3/97 21:11'! 329249showDirType 329250 "Display the proper symbol for this direction type. rotationStyle 329251is one of #(normal leftRight upDown none)." 329252 329253| rr poly | 329254rr := self rotationStyle. 329255poly := self valueOfProperty: #fwdButton. 329256rr == #normal ifTrue: [^ poly makeBackArrow]. 329257rr == #leftRight ifTrue: [ 329258 poly makeBothArrows. 329259 ^ poly setVertices: (Array with: poly center - (7@0) with: poly 329260center + (7@0))]. 329261rr == #upDown ifTrue: [ 329262 poly makeBothArrows. 329263 ^ poly setVertices: (Array with: poly center - (0@7) with: poly 329264center + (0@7))]. 329265rr == #none ifTrue: [ 329266 poly makeNoArrows. 329267 ^ poly setVertices: (Array with: poly center - (7@0) with: poly 329268center + (7@0) 329269 with: poly center with: poly center - (0@7) with: poly 329270center + (0@7))]. 329271! ! 329272 329273!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 17:43'! 329274stamp: evt 329275 "plop one copy of the user's chosen Form down." 329276 329277 "Check depths" 329278 | pt sForm | 329279 329280 sForm := self get: #stampForm for: evt. 329281 pt := evt cursorPoint - (sForm extent // 2). 329282 sForm displayOn: paintingForm 329283 at: pt - bounds origin 329284 clippingBox: paintingForm boundingBox 329285 rule: Form paint 329286 fillColor: nil. 329287 self render: (pt extent: sForm extent). 329288! ! 329289 329290!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'sw 7/5/2004 03:10'! 329291star: evt 329292 "Draw an star from the center." 329293 | poly ext ww rect oldExt oldRect oldR verts pt cColor sOrigin priorEvt | 329294 sOrigin := self get: #strokeOrigin for: evt. 329295 cColor := self getColorFor: evt. 329296 ww := (self getNibFor: evt) width. 329297 ext := (pt := sOrigin - evt cursorPoint) r + ww * 2. 329298 rect := Rectangle center: sOrigin extent: ext. 329299 (priorEvt := self get: #lastEvent for: evt) 329300 ifNotNil: [oldExt := (sOrigin - priorEvt cursorPoint) r + ww * 2. 329301 "Last draw sticks out, must erase the area" 329302 oldRect := Rectangle center: sOrigin extent: oldExt. 329303 self restoreRect: oldRect]. 329304 ext := pt r. 329305 oldR := ext. 329306 verts := (0 to: 350 by: 36) 329307 collect: [:angle | (Point r: (oldR := oldR = ext 329308 ifTrue: [ext * 5 // 12] 329309 ifFalse: [ext]) degrees: angle + pt degrees) 329310 + sOrigin]. 329311 poly := PolygonMorph new addHandles. 329312 poly borderColor: (cColor isTransparent ifTrue: [Color black] ifFalse: [cColor]). 329313 poly borderWidth: (self getNibFor: evt) width. 329314 poly fillStyle: Color transparent. 329315 329316 "can't handle thick brushes" 329317 self invalidRect: rect. 329318 "self addMorph: poly." 329319 poly privateOwner: self. 329320 poly 329321 bounds: (sOrigin extent: ext). 329322 poly setVertices: verts. 329323 poly drawOn: formCanvas. 329324 "poly delete." 329325 self invalidRect: rect! ! 329326 329327!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 9/3/97 21:17'! 329328toggleDirType: evt in: handle 329329 "Toggle from 'rotate' to 'to and fro' to 'up and down' to 'none' 329330for the kind of rotation the object does. An actor's rotationStyle is one 329331of #(normal leftRight upDown none)." 329332 329333| rr ii | 329334"Clear the indicator" 329335 329336"Find new style, store it, install the indicator" 329337rr := self rotationStyle. 329338ii := #(normal leftRight upDown none) indexOf: rr. 329339self setProperty: #rotationStyle toValue: 329340 (#(leftRight upDown none normal) at: ii). 329341ii = 4 ifTrue: ["normal" self forward: self forwardDirection 329342 direction: (self valueOfProperty: #fwdButton)] 329343 ifFalse: [self showDirType.].! ! 329344 329345 329346!SketchEditorMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:24'! 329347veryDeepFixupWith: deepCopier 329348 "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 329349 329350super veryDeepFixupWith: deepCopier. 329351hostView := deepCopier references at: hostView ifAbsent: [hostView]. 329352enclosingPasteUpMorph := deepCopier references at: enclosingPasteUpMorph 329353 ifAbsent: [enclosingPasteUpMorph].! ! 329354 329355!SketchEditorMorph methodsFor: 'copying' stamp: 'RAA 8/16/2000 12:29'! 329356veryDeepInner: deepCopier 329357 "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." 329358 329359super veryDeepInner: deepCopier. 329360"hostView := hostView. Weakly copied" 329361 "stampForm := stampForm veryDeepCopyWith: deepCopier." 329362 "canvasRectangle := canvasRectangle veryDeepCopyWith: deepCopier." 329363palette := palette veryDeepCopyWith: deepCopier. 329364 "currentColor := currentColor veryDeepCopyWith: deepCopier." 329365ticksToDwell := ticksToDwell veryDeepCopyWith: deepCopier. 329366rotationCenter := rotationCenter veryDeepCopyWith: deepCopier. 329367registrationPoint := registrationPoint veryDeepCopyWith: deepCopier. 329368newPicBlock := newPicBlock veryDeepCopyWith: deepCopier. 329369emptyPicBlock := emptyPicBlock veryDeepCopyWith: deepCopier. 329370 "action := action veryDeepCopyWith: deepCopier." 329371paintingForm := paintingForm veryDeepCopyWith: deepCopier. 329372dimForm := dimForm veryDeepCopyWith: deepCopier. 329373 "buff := buff veryDeepCopyWith: deepCopier." 329374 "brush := brush veryDeepCopyWith: deepCopier." 329375 "paintingFormPen := paintingFormPen veryDeepCopyWith: deepCopier." 329376formCanvas := formCanvas veryDeepCopyWith: deepCopier. 329377 "picToBuff := picToBuff veryDeepCopyWith: deepCopier." 329378 "brushToBuff := brushToBuff veryDeepCopyWith: deepCopier." 329379 "buffToBuff := buffToBuff veryDeepCopyWith: deepCopier." 329380 "buffToPic := buffToPic veryDeepCopyWith: deepCopier." 329381rotationButton := rotationButton veryDeepCopyWith: deepCopier. 329382scaleButton := scaleButton veryDeepCopyWith: deepCopier. 329383 "strokeOrigin := strokeOrigin veryDeepCopyWith: deepCopier." 329384cumRot := cumRot veryDeepCopyWith: deepCopier. 329385cumMag := cumMag veryDeepCopyWith: deepCopier. 329386undoBuffer := undoBuffer veryDeepCopyWith: deepCopier. 329387 "lastEvent := lastEvent veryDeepCopyWith: deepCopier." 329388 "currentNib := currentNib veryDeepCopyWith: deepCopier." 329389enclosingPasteUpMorph := enclosingPasteUpMorph. "weakly copied" 329390forEachHand := nil. "hmm..." ! ! 329391 329392 329393!SketchEditorMorph methodsFor: 'drawing' stamp: 'RAA 8/31/2000 13:49'! 329394drawOn: aCanvas 329395 "Put the painting on the display" 329396 329397 color isTransparent ifFalse: [ 329398 aCanvas fillRectangle: bounds color: color 329399 ]. 329400 paintingForm ifNotNil: [ 329401 aCanvas paintImage: paintingForm at: bounds origin]. 329402 329403 ! ! 329404 329405 329406!SketchEditorMorph methodsFor: 'e-toy support' stamp: 'tk 9/3/97 17:12'! 329407rotationStyle 329408 329409^ (self valueOfProperty: #rotationStyle) ifNil: [#normal]! ! 329410 329411 329412!SketchEditorMorph methodsFor: 'event handling' stamp: 'jm 7/28/97 11:49'! 329413handlesMouseDown: evt 329414 329415 ^ true 329416! ! 329417 329418!SketchEditorMorph methodsFor: 'event handling'! 329419handlesMouseOver: evt 329420 ^true! ! 329421 329422!SketchEditorMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:51'! 329423handlesMouseOverDragging: evt 329424 ^true! ! 329425 329426!SketchEditorMorph methodsFor: 'event handling' stamp: 'sw 7/5/2004 03:23'! 329427mouseEnter: evt 329428 "Set the cursor. Reread colors if embedded editable polygon needs it." 329429 329430 | poly cColor | 329431 super mouseEnter: evt. 329432 (self get: #action for: evt) == #scaleOrRotate ifTrue: [ 329433 self set: #action for: evt to: (self get: #priorAction for: evt). 329434 ]. "scale and rotate are not real modes. If we enter with one, wear the previous tool." 329435 evt hand showTemporaryCursor: (self getCursorFor: evt). 329436 palette getSpecial == #polygon: ifFalse: [^self]. 329437 (poly := self valueOfProperty: #polygon) ifNil: [^ self]. 329438 cColor := self getColorFor: evt. 329439 poly borderColor: cColor; borderWidth: (self getNibFor: evt) width. 329440 poly changed.! ! 329441 329442!SketchEditorMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 08:07'! 329443mouseEnterDragging: evt 329444 "Test button state elsewhere if at all" 329445 ^ self mouseEnter: evt! ! 329446 329447!SketchEditorMorph methodsFor: 'event handling' stamp: 'jm 5/22/1998 10:15'! 329448mouseLeave: evt 329449 "Revert to the normal hand cursor." 329450 329451 super mouseLeave: evt. 329452 evt hand showTemporaryCursor: nil. "back to normal" 329453 "If this is modified to close down the SketchEditorMorph in any way, watch out for how it is called when entering a rotationButton and a scaleButton." 329454! ! 329455 329456!SketchEditorMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 08:08'! 329457mouseLeaveDragging: evt 329458 "Test button state elsewhere if at all" 329459 ^ self mouseLeave: evt! ! 329460 329461!SketchEditorMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 18:45'! 329462mouseMove: evt 329463 "In the middle of drawing a stroke. 6/11/97 19:51 tk" 329464 329465 | pt priorEvt | 329466 WorldState canSurrenderToOS: false. "we want maximum responsiveness" 329467 pt := evt cursorPoint. 329468 priorEvt := self get: #lastEvent for: evt. 329469 (priorEvt notNil and: [pt = priorEvt cursorPoint]) ifTrue: [^self]. 329470 self perform: (self getActionFor: evt) with: evt. 329471 "Each action must do invalidRect:" 329472 self 329473 set: #lastEvent 329474 for: evt 329475 to: evt. 329476 false 329477 ifTrue: 329478 ["So senders will find the things performed here" 329479 329480 self 329481 paint: nil; 329482 fill: nil; 329483 erase: nil; 329484 pickup: nil; 329485 stamp: nil. 329486 self 329487 rect: nil; 329488 ellipse: nil; 329489 polygon: nil; 329490 line: nil; 329491 star: nil]! ! 329492 329493!SketchEditorMorph methodsFor: 'event handling' stamp: 'ar 12/19/2000 00:20'! 329494mouseUp: evt 329495 | myAction | 329496 "Do nothing except those that work on mouseUp." 329497 329498 myAction := self getActionFor: evt. 329499 myAction == #fill: ifTrue: [ 329500 self perform: myAction with: evt. 329501 "Each action must do invalidRect:" 329502 ]. 329503 myAction == #pickup: ifTrue: [ 329504 self pickupMouseUp: evt]. 329505 myAction == #polygon: ifTrue: [self polyEdit: evt]. "a mode lets you drag vertices" 329506 self set: #lastEvent for: evt to: nil. 329507! ! 329508 329509 329510!SketchEditorMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'! 329511defaultColor 329512 "answer the default color/fill style for the receiver" 329513 ^ Color white alpha: 0.5! ! 329514 329515!SketchEditorMorph methodsFor: 'initialization' stamp: 'ar 6/2/2001 16:54'! 329516initializeFor: aSketchMorph inBounds: boundsToUse pasteUpMorph: aPasteUpMorph 329517 | aPaintBox newPaintBoxBounds worldBounds requiredWidth newOrigin aPosition aPal aTab paintBoxFullBounds | 329518 (aTab := self world paintingFlapTab) ifNotNil: 329519 [aTab showFlap. 329520 ^ self initializeFor: aSketchMorph inBounds: boundsToUse pasteUpMorph: aPasteUpMorph paintBoxPosition: nil]. 329521 329522 aPaintBox := self world paintBox. 329523 worldBounds := self world bounds. 329524 requiredWidth := aPaintBox width. 329525 329526 aPosition := (aPal := aPasteUpMorph standardPalette) 329527 ifNotNil: 329528 [aPal showNoPalette. 329529 aPal topRight + (aPaintBox width negated @ 0 "aPal tabsMorph height")] 329530 ifNil: 329531 [boundsToUse topRight]. 329532 329533 newOrigin := ((aPosition x + requiredWidth <= worldBounds right) or: [Preferences unlimitedPaintArea]) 329534 ifTrue: "will fit to right of aPasteUpMorph" 329535 [aPosition] 329536 ifFalse: "won't fit to right, try left" 329537 [boundsToUse topLeft - (requiredWidth @ 0)]. 329538 paintBoxFullBounds := aPaintBox maxBounds. 329539 paintBoxFullBounds := (newOrigin - aPaintBox offsetFromMaxBounds) extent: 329540 paintBoxFullBounds extent. 329541 newPaintBoxBounds := paintBoxFullBounds translatedToBeWithin: worldBounds. 329542 329543 329544 self initializeFor: aSketchMorph inBounds: boundsToUse 329545 pasteUpMorph: aPasteUpMorph 329546 paintBoxPosition: newPaintBoxBounds origin + aPaintBox offsetFromMaxBounds.! ! 329547 329548!SketchEditorMorph methodsFor: 'initialization' stamp: 'yo 7/16/2003 15:10'! 329549initializeFor: aSketchMorph inBounds: boundsToUse pasteUpMorph: aPasteUpMorph paintBoxPosition: aPosition 329550 "NB: if aPosition is nil, then it's assumed that the paintbox is obtained from a flap or some such, so do nothing special regarding a palette in this case. The palette needs already to be in the world for this to work." 329551 | w | 329552 (w := aPasteUpMorph world) addMorphInLayer: self. "in back of palette" 329553 enclosingPasteUpMorph := aPasteUpMorph. 329554 hostView := aSketchMorph. "may be ownerless" 329555 self bounds: boundsToUse. 329556 palette := w paintBox focusMorph: self. 329557 palette beStatic. "give Nebraska whatever help we can" 329558 palette fixupButtons. 329559 palette addWeakDependent: self. 329560 aPosition ifNotNil: 329561 [w addMorphFront: palette. "bring to front" 329562 palette position: aPosition]. 329563 paintingForm := Form extent: bounds extent depth: w assuredCanvas depth. 329564 self dimTheWindow. 329565 self addRotationScaleHandles. 329566 aSketchMorph ifNotNil: 329567 [ 329568 aSketchMorph form 329569 displayOn: paintingForm 329570 at: (hostView boundsInWorld origin - bounds origin - hostView form offset) 329571 clippingBox: (0@0 extent: paintingForm extent) 329572 rule: Form over 329573 fillColor: nil. "assume they are the same depth". 329574 undoBuffer := paintingForm deepCopy. 329575 rotationCenter := aSketchMorph rotationCenter]! ! 329576 329577 329578!SketchEditorMorph methodsFor: 'morphic' stamp: 'yo 11/17/2002 21:32'! 329579mouseDown: evt 329580 "Start a new stroke. Check if any palette setting have changed. 6/11/97 20:30 tk" 329581 | cur pfPen myAction | 329582 "verify that we are in a good state" 329583 self verifyState: evt. "includes prepareToPaint and #scalingOrRotate" 329584 pfPen := self get: #paintingFormPen for: evt. 329585 paintingForm extent = undoBuffer extent ifTrue: [ 329586 paintingForm displayOn: undoBuffer at: 0@0 rule: Form over. 329587 ] ifFalse: [ 329588 undoBuffer := paintingForm deepCopy. "know we will draw something" 329589 ]. 329590 pfPen place: (evt cursorPoint - bounds origin). 329591 myAction := self getActionFor: evt. 329592 myAction == #paint: ifTrue:[ 329593 palette recentColor: (self getColorFor: evt)]. 329594 self set: #strokeOrigin for: evt to: evt cursorPoint. 329595 "origin point for pickup: rect: ellispe: polygon: line: star:. Always take it." 329596 myAction == #pickup: ifTrue: [ 329597 cur := Cursor corner clone. 329598 cur offset: 0@0 "cur offset abs". 329599 evt hand showTemporaryCursor: cur]. 329600 myAction == #polygon: ifTrue: [self polyNew: evt]. "a mode lets you drag vertices" 329601 self mouseMove: evt.! ! 329602 329603 329604!SketchEditorMorph methodsFor: 'nebraska support' stamp: 'RAA 8/15/2000 15:13'! 329605get: aSymbol for: anEventOrHand 329606 329607 | valuesForHand | 329608 329609 valuesForHand := self valuesForHand: anEventOrHand. 329610 ^valuesForHand at: aSymbol ifAbsent: [nil]. 329611 329612! ! 329613 329614!SketchEditorMorph methodsFor: 'nebraska support' stamp: 'RAA 8/16/2000 11:14'! 329615getActionFor: anEventOrHand 329616 329617 ^(self get: #action for: anEventOrHand) ifNil: [ 329618 self set: #action for: anEventOrHand to: palette action 329619 ]. 329620 329621! ! 329622 329623!SketchEditorMorph methodsFor: 'nebraska support' stamp: 'RAA 8/15/2000 17:56'! 329624getBrushFor: anEventOrHand 329625 329626 ^(self get: #brush for: anEventOrHand) ifNil: [ 329627 self set: #brush for: anEventOrHand to: palette getNib 329628 ]. 329629 329630! ! 329631 329632!SketchEditorMorph methodsFor: 'nebraska support' stamp: 'RAA 8/16/2000 11:20'! 329633getColorFor: anEventOrHand 329634 329635 ^(self get: #currentColor for: anEventOrHand) ifNil: [ 329636 self set: #currentColor for: anEventOrHand to: palette getColor 329637 ]. 329638 329639! ! 329640 329641!SketchEditorMorph methodsFor: 'nebraska support' stamp: 'RAA 8/16/2000 13:40'! 329642getCursorFor: anEventOrHand 329643 329644 | plainCursor | 329645 plainCursor := (self get: #currentCursor for: anEventOrHand) ifNil: [ 329646 self set: #currentCursor for: anEventOrHand to: palette plainCursor 329647 ]. 329648 ^palette 329649 cursorFor: (self getActionFor: anEventOrHand) 329650 oldCursor: plainCursor 329651 currentNib: (self getNibFor: anEventOrHand) 329652 color: (self getColorFor: anEventOrHand) 329653 329654! ! 329655 329656!SketchEditorMorph methodsFor: 'nebraska support' stamp: 'RAA 8/15/2000 17:16'! 329657getNibFor: anEventOrHand 329658 329659 ^(self get: #currentNib for: anEventOrHand) ifNil: [ 329660 self set: #currentNib for: anEventOrHand to: palette getNib 329661 ]. 329662 329663! ! 329664 329665!SketchEditorMorph methodsFor: 'nebraska support' stamp: 'ar 10/10/2000 17:30'! 329666set: aSymbol for: anEventOrHand to: anObject 329667 329668 | valuesForHand | 329669 329670 valuesForHand := self valuesForHand: anEventOrHand. 329671 aSymbol == #action ifTrue: [ 329672 valuesForHand at: #priorAction put: (valuesForHand at: #action ifAbsent: [#paint:]). 329673 (anObject ~~ #polygon: and:[self polyEditing]) ifTrue:[self polyFreeze]. 329674 ]. 329675 valuesForHand at: aSymbol put: anObject. 329676 ^anObject 329677 329678! ! 329679 329680!SketchEditorMorph methodsFor: 'nebraska support' stamp: 'RAA 8/15/2000 15:12'! 329681valuesForHand: anEventOrHand 329682 329683 | hand valuesForHand | 329684 forEachHand ifNil: [forEachHand := IdentityDictionary new]. 329685 hand := (anEventOrHand isKindOf: HandMorph) 329686 ifTrue: [anEventOrHand] ifFalse: [anEventOrHand hand]. 329687 valuesForHand := forEachHand at: hand ifAbsentPut: [Dictionary new]. 329688 ^valuesForHand 329689 329690! ! 329691 329692!SketchEditorMorph methodsFor: 'nebraska support' stamp: 'gm 2/22/2003 12:59'! 329693valuesForHandIfPresent: anEventOrHand 329694 | hand | 329695 forEachHand ifNil: [forEachHand := IdentityDictionary new]. 329696 hand := (anEventOrHand isHandMorph) 329697 ifTrue: [anEventOrHand] 329698 ifFalse: [anEventOrHand hand]. 329699 ^forEachHand at: hand ifAbsent: [nil]! ! 329700 329701 329702!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/16/2000 01:47'! 329703cancelPainting: aPaintBoxMorph evt: evt 329704 "Undo the operation after user issued #cancel in aPaintBoxMorph" 329705 ^self cancel: evt! ! 329706 329707!SketchEditorMorph methodsFor: 'palette handling' stamp: 'ar 3/23/2000 14:25'! 329708clearPainting: aPaintBoxMorph 329709 "Clear the image after user issued #clear in aPaintBoxMorph" 329710 ^self clear! ! 329711 329712!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/31/2000 14:03'! 329713dimTheWindow 329714 329715 "Updated to use TranslucentColor by kfr 10/5 00" 329716 "Do not call twice!! Installs a morph with an 'onion-skinned' copy of the pixels behind me." 329717 329718 "create an 'onion-skinned' version of the stuff on the screen" 329719 owner outermostMorphThat: [:morph | morph resumeAfterDrawError. false]. 329720 329721 "an experiment for Nebraska to see if opaque background speeds things up" 329722 329723"----- now using the color variable to control background 329724 bgColor := false ifTrue: [TranslucentColor r:1.0 g:1.0 b:1.0 alpha:0.5] ifFalse: [Color white]. 329725 dimForm := (RectangleMorph new color: bgColor; bounds: self bounds; borderWidth: 0). 329726 dimForm position: self position. 329727 owner 329728 privateAddMorph: dimForm 329729 atIndex: (owner submorphs indexOf: self) + 1. 329730-----" 329731! ! 329732 329733!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/15/2000 18:02'! 329734paintBoxChanged: arguments 329735 329736 self set: arguments first for: arguments second to: arguments third. 329737! ! 329738 329739!SketchEditorMorph methodsFor: 'palette handling' stamp: 'ar 3/23/2000 14:37'! 329740paletteAttached: aPaintBoxMorph 329741 "A new palette has been attached to the receiver. 329742 Don't know what to do here..."! ! 329743 329744!SketchEditorMorph methodsFor: 'palette handling' stamp: 'ar 3/23/2000 14:33'! 329745paletteDetached: aPaintBoxMorph 329746 "The palette has been detached to the receiver. 329747 Don't know what to do here...."! ! 329748 329749!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/16/2000 01:48'! 329750savePainting: aPaintBoxMorph evt: evt 329751 "Save the image after user issued #keep in aPaintBoxMorph" 329752 ^self save: evt! ! 329753 329754!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/16/2000 11:17'! 329755undoPainting: aPaintBoxMorph evt: evt 329756 "Undo the operation after user issued #undo in aPaintBoxMorph" 329757 ^self undo: evt! ! 329758 329759 329760!SketchEditorMorph methodsFor: 'start & finish' stamp: 'dgd 9/19/2003 14:50'! 329761addRotationScaleHandles 329762 329763 "Rotation and scaling handles" 329764 329765 rotationButton := SketchMorph withForm: (palette rotationTabForm). 329766 rotationButton position: bounds topCenter - (6@0). 329767 rotationButton on: #mouseDown send: #rotateScalePrep: to: self. 329768 rotationButton on: #mouseMove send: #rotateBy: to: self. 329769 rotationButton on: #mouseUp send: #rotateDone: to: self. 329770 rotationButton on: #mouseEnter send: #mouseLeave: to: self. 329771 "Put cursor back" 329772 rotationButton on: #mouseLeave send: #mouseEnter: to: self. 329773 self addMorph: rotationButton. 329774 rotationButton setBalloonText: 'Drag me sideways to 329775rotate your 329776picture.' translated. 329777 329778 scaleButton := SketchMorph withForm: (palette scaleTabForm). 329779 scaleButton position: bounds rightCenter - ((scaleButton width)@6). 329780 scaleButton on: #mouseDown send: #rotateScalePrep: to: self. 329781 scaleButton on: #mouseMove send: #scaleBy: to: self. 329782 scaleButton on: #mouseEnter send: #mouseLeave: to: self. 329783 "Put cursor back" 329784 scaleButton on: #mouseLeave send: #mouseEnter: to: self. 329785 self addMorph: scaleButton. 329786 scaleButton setBalloonText: 'Drag me up and down to change 329787the size 329788of your picture.' translated. 329789 329790"REMOVED: 329791 fwdButton := PolygonMorph new. 329792 pt := bounds topCenter. 329793 fwdButton borderWidth: 2; makeOpen; makeBackArrow; borderColor: 329794(Color r: 0 g: 0.8 b: 0). 329795 fwdButton removeHandles; setVertices: (Array with: pt+(0@7) with: 329796pt+(0@22)). 329797 fwdButton on: #mouseMove send: #forward:direction: to: self. 329798 fwdButton on: #mouseEnter send: #mouseLeave: to: self. 329799 fwdButton on: #mouseLeave send: #mouseEnter: to: self. 329800 self setProperty: #fwdButton toValue: fwdButton. 329801 self addMorph: fwdButton. 329802 fwdButton setBalloonText: 'Drag me around to point 329803in the direction 329804I go forward.' translated. 329805 329806 toggle := EllipseMorph 329807 newBounds: (Rectangle center: fwdButton vertices last + 329808(-4@4) extent: 8@8) 329809 color: Color gray. 329810 toggle on: #mouseUp send: #toggleDirType:in: to: self. 329811 toggle on: #mouseEnter send: #mouseLeave: to: self. 329812 toggle on: #mouseLeave send: #mouseEnter: to: self. 329813 self setProperty: #fwdToggle toValue: toggle. 329814 fwdButton addMorph: toggle. 329815 toggle setBalloonText: 'When your object turns, 329816how should its 329817picture change? 329818It can rotate, face left or right, 329819face up or down, or not 329820change.' translated. 329821 " 329822 self setProperty: #rotationStyle toValue: hostView rotationStyle. 329823" self forward: hostView setupAngle direction: fwdButton. " 329824 "Set to its current value" 329825 329826! ! 329827 329828!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 10/28/97 15:31'! 329829afterNewPicDo: goodBlock ifNoBits: badBlock 329830 "If the user said 'Save' at the end of drawing, do this block to save the picture. 329831goodBlock takes 2 args, the painted form and the bounding rectangle of its bits. 329832badBlock takes no args. " 329833 329834 newPicBlock := goodBlock. 329835 emptyPicBlock := badBlock.! ! 329836 329837!SketchEditorMorph methodsFor: 'start & finish' stamp: 'RAA 8/16/2000 01:46'! 329838cancel: evt 329839 "Palette is telling us that the use wants to end the painting session. " 329840 329841 Cursor blank show. 329842 self deliverPainting: #cancel evt: evt.! ! 329843 329844!SketchEditorMorph methodsFor: 'start & finish' stamp: 'stephane.ducasse 11/8/2008 15:01'! 329845cancelOutOfPainting 329846 "The user requested to back out of a painting session without saving" 329847 329848 self deleteSelfAndSubordinates. 329849 emptyPicBlock ifNotNil: [emptyPicBlock value]. "note no args to block!!" 329850 hostView ifNotNil: [hostView changed]. 329851 ^ nil! ! 329852 329853!SketchEditorMorph methodsFor: 'start & finish' stamp: 'sw 9/2/1999 12:54'! 329854deleteSelfAndSubordinates 329855 "Delete the receiver and, if it has one, its subordinate dimForm" 329856 self delete. 329857 dimForm ifNotNil: [dimForm delete]! ! 329858 329859!SketchEditorMorph methodsFor: 'start & finish' stamp: 'stephane.ducasse 2/14/2009 17:49'! 329860deliverPainting: result evt: evt 329861 "Done painting. May come from resume, or from original call. Execute user's post painting instructions in the block. Always use this standard one. 4/21/97 tk" 329862 329863 <lint: 'Unnecessary "= true"' rationale: 'Property can be nil I imagine' author: 'stephane.ducasse'> 329864 329865 | newBox newForm | 329866 palette ifNotNil: "nil happens" [palette setAction: #paint: evt: evt]. "Get out of odd modes" 329867 "rot := palette getRotations." "rotate with heading, or turn to and fro" 329868 "palette setRotation: #normal." 329869 result == #cancel ifTrue: [ 329870 ^ (self confirm: 'Do you really want to throw away 329871what you just painted?' translated ) 329872 ifTrue: [self cancelOutOfPainting] 329873 ifFalse: [nil]]. "cancelled out of cancelling." 329874 329875 "hostView rotationStyle: rot." "rotate with heading, or turn to and fro" 329876 newBox := paintingForm rectangleEnclosingPixelsNotOfColor: Color transparent. 329877 registrationPoint ifNotNil: 329878 [registrationPoint := registrationPoint - newBox origin]. "relative to newForm origin" 329879 newForm := Form extent: newBox extent depth: paintingForm depth. 329880 newForm copyBits: newBox from: paintingForm at: 0@0 329881 clippingBox: newForm boundingBox rule: Form over fillColor: nil. 329882 newForm isAllWhite ifTrue: [ 329883 (self valueOfProperty: #background) == true 329884 ifFalse: [^ self cancelOutOfPainting]]. 329885 329886 newForm fixAlpha. "so alpha channel stays intact for 32bpp" 329887 329888 self delete. "so won't find me again" 329889 dimForm ifNotNil: [dimForm delete]. 329890 newPicBlock value: newForm value: (newBox copy translateBy: bounds origin). 329891 329892 329893! ! 329894 329895!SketchEditorMorph methodsFor: 'start & finish' stamp: 'RAA 8/16/2000 11:28'! 329896prepareToPaint: evt 329897 "Figure out what the current brush, fill, etc is. Return an action to take every mouseMove. Set up instance variable and pens. Prep for normal painting is inlined here. tk 6/14/97 21:11" 329898 329899 | specialMode pfPen cColor cNib myBrush | 329900 "Install the brush, color, (replace mode), and cursor." 329901 specialMode := self getActionFor: evt. 329902 cColor := self getColorFor: evt. 329903 cNib := self getNibFor: evt. 329904 self set: #brush for: evt to: (myBrush := cNib). 329905 self set: #paintingFormPen for: evt to: (pfPen := Pen newOnForm: paintingForm). 329906 self set: #stampForm for: evt to: nil. "let go of stamp" 329907 formCanvas := paintingForm getCanvas. "remember to change when undo" 329908 formCanvas := formCanvas 329909 copyOrigin: self topLeft negated 329910 clipRect: (0@0 extent: bounds extent). 329911 329912 specialMode == #paint: ifTrue: [ 329913 "get it to one bit depth. For speed, instead of going through a colorMap every time ." 329914 self set: #brush for: evt to: (myBrush := Form extent: myBrush extent depth: 1). 329915 myBrush offset: (0@0) - (myBrush extent // 2). 329916 cNib displayOn: myBrush at: (0@0 - cNib offset). 329917 329918 pfPen sourceForm: myBrush. 329919 pfPen combinationRule: Form paint. 329920 pfPen color: cColor. 329921 cColor isTransparent ifTrue: [ 329922 pfPen combinationRule: Form erase1bitShape. 329923 pfPen color: Color black]. 329924 ^ #paint:]. 329925 329926 specialMode == #erase: ifTrue: [ 329927 self erasePrep: evt. 329928 ^ #erase:]. 329929 specialMode == #stamp: ifTrue: [ 329930 self set: #stampForm for: evt to: palette stampForm. "keep it" 329931 ^ #stamp:]. 329932 329933 (self respondsTo: specialMode) 329934 ifTrue: [^ specialMode] "fill: areaFill: pickup: (in mouseUp:) 329935 rect: ellipse: line: polygon: star:" 329936 ifFalse: ["Don't recognise the command" 329937 palette setAction: #paint: evt: evt. "set it to Paint" 329938 ^ self prepareToPaint: evt].! ! 329939 329940!SketchEditorMorph methodsFor: 'start & finish' stamp: 'RAA 8/16/2000 11:14'! 329941save: evt 329942 "Palette is telling us that the use wants to end the painting session. " 329943 329944 Cursor blank show. 329945 (self getActionFor: evt) == #polygon: ifTrue: [self polyFreeze]. "end polygon mode" 329946 ^ self deliverPainting: #okay evt: evt.! ! 329947 329948!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 4/3/97'! 329949setRotations: num 329950 "Tell the palette what number of rotations (or background) to show. " 329951 329952 | key | 329953 key := 'ItTurns'. "default and value for num > 1" 329954 num == 1 ifTrue: [key := 'JustAsIs']. 329955 num == 18 ifTrue: [key := 'ItTurns']. 329956 num == 99 ifTrue: [key := 'ToAndFro']. 329957 num == #Background ifTrue: [key := 'Background']. 329958 num == #Repeated ifTrue: [key := 'Repeated']. 329959 palette setRotations: (palette contentsAtKey: key).! ! 329960 329961!SketchEditorMorph methodsFor: 'start & finish' stamp: 'nk 7/30/2004 17:55'! 329962undo: evt 329963 "revert to a previous state. " 329964 329965 | temp poly pen | 329966 self flag: #bob. "what is undo in multihand environment?" 329967 undoBuffer ifNil: [^Beeper beep]. "nothing to go back to" 329968 (poly := self valueOfProperty: #polygon) ifNotNil: 329969 [poly delete. 329970 self setProperty: #polygon toValue: nil. 329971 ^self]. 329972 temp := paintingForm. 329973 paintingForm := undoBuffer. 329974 undoBuffer := temp. "can get back to what you had by undoing again" 329975 pen := self get: #paintingFormPen for: evt. 329976 pen ifNil: [^Beeper beep]. 329977 pen setDestForm: paintingForm. 329978 formCanvas := paintingForm getCanvas. "used for lines, ovals, etc." 329979 formCanvas := formCanvas copyOrigin: self topLeft negated 329980 clipRect: (0 @ 0 extent: bounds extent). 329981 self render: bounds! ! 329982 329983!SketchEditorMorph methodsFor: 'start & finish' stamp: 'stephane.ducasse 2/14/2009 18:04'! 329984verifyState: evt 329985 329986 <lint: 'Unnecessary "= true"' rationale: 'Quite ugly...' author: 'stephane.ducasse'> 329987 | myAction | 329988 "We are sure we will make a mark now. Make sure the palette has not changed state while we were away. If so, end this action and start another one. 6/11/97 19:52 tk action, currentColor, brush" 329989 329990 "Install the brush, color, (replace mode), and cursor." 329991 palette isInWorld ifFalse: 329992 [self world addMorphFront: palette]. "It happens. might want to position it also" 329993 myAction := self getActionFor: evt. 329994 (self get: #changed for: evt) == false ifFalse: [ 329995 self set: #changed for: evt to: false. 329996 self invalidRect: rotationButton bounds. "snap these back" 329997 rotationButton position: bounds topCenter - (6@0). "later adjust by button width?" 329998 self invalidRect: rotationButton bounds. 329999 self invalidRect: scaleButton bounds. 330000 scaleButton position: bounds rightCenter - ((scaleButton width)@6). 330001 self invalidRect: scaleButton bounds. 330002 myAction == #polygon: ifFalse: [self polyFreeze]. "end polygon mode" 330003 ^ self set: #action for: evt to: (self prepareToPaint: evt)]. 330004 330005! ! 330006 330007 330008!SketchEditorMorph methodsFor: 'wiw support' stamp: 'tk 8/6/2002 20:19'! 330009morphicLayerNumber 330010 "Place the painting behind the paint palette" 330011 330012 ^ 28! ! 330013 330014"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 330015 330016SketchEditorMorph class 330017 instanceVariableNames: ''! 330018 330019!SketchEditorMorph class methodsFor: 'new-morph participation' stamp: 'di 6/22/97 09:07'! 330020includeInNewMorphMenu 330021 "Not to be instantiated from the menu" 330022 ^ false! ! 330023Morph subclass: #SketchMorph 330024 instanceVariableNames: 'originalForm rotationStyle scalePoint framesToDwell rotatedForm' 330025 classVariableNames: '' 330026 poolDictionaries: '' 330027 category: 'Morphic-Basic'! 330028!SketchMorph commentStamp: '<historical>' prior: 0! 330029The morph that results when the user draws a color bitmap using the PaintBox (SketchEditorMorph and PaintBoxMorph). 330030 330031forwardDirection is the angle at which the object will go forward. When the rotationStyle is not #normal, then forwardDirection is any angle, while the rotation is highly restricted. If flexed, this is remembered by the Transform morph. For non-normal rotationStyle, it is rotationDegrees. 330032 330033setupAngle (a property) is where the user put the green arrow to indicate which direction on the picture is forward. When #normal, draw the morph initially at (0.0 - setupAngle). The enclosing TransformationMorph then rotates it to the true angle. 330034 330035rotationDegrees In a #normal object, rotationDegrees is constant an equal to setupAngle. 330036 For non-normal, it is the direction the object is going. 330037 330038When repainting, set it back to its original state. The green arrow is set to setupAngle, and the sketch is shown as drawn originally (rotationDegrees = 0). 330039 330040rotationStyle = normal (turns), leftRight, upDown, fixed. 330041When leftRight upDown or fixed, bit map has severe restrictions. 330042! 330043 330044 330045!SketchMorph methodsFor: '*etoys-accessing' stamp: 'RAA 3/15/2001 09:11'! 330046wearCostume: anotherMorph 330047 330048 self form: anotherMorph form. 330049! ! 330050 330051 330052!SketchMorph methodsFor: '*etoys-geometry etoy' stamp: 'ar 9/22/2000 21:19'! 330053heading: newHeading 330054 "If not rotating normally, change forward direction rather than heading" 330055 rotationStyle == #normal ifTrue:[^super heading: newHeading]. 330056 self isFlexed 330057 ifTrue:[self forwardDirection: newHeading - owner rotationDegrees] 330058 ifFalse:[self forwardDirection: newHeading]. 330059 self layoutChanged! ! 330060 330061 330062!SketchMorph methodsFor: 'accessing'! 330063form 330064 330065 ^ originalForm 330066! ! 330067 330068!SketchMorph methodsFor: 'accessing' stamp: 'sw 12/13/2001 12:10'! 330069form: aForm 330070 "Set the receiver's form" 330071 330072 | oldForm topRenderer | 330073 oldForm := originalForm. 330074 (self hasProperty: #baseGraphic) ifFalse: [self setProperty: #baseGraphic toValue: aForm]. 330075 originalForm := aForm. 330076 self rotationCenter: 0.5@0.5. 330077 self layoutChanged. 330078 topRenderer := self topRendererOrSelf. 330079 330080 oldForm ifNotNil: [topRenderer position: topRenderer position + (oldForm extent - aForm extent // 2)]. 330081! ! 330082 330083!SketchMorph methodsFor: 'accessing'! 330084framesToDwell 330085 330086 ^ framesToDwell 330087! ! 330088 330089!SketchMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:06'! 330090framesToDwell: anInteger 330091 330092 framesToDwell := anInteger. 330093! ! 330094 330095!SketchMorph methodsFor: 'accessing' stamp: 'sw 12/12/2001 10:49'! 330096nominalForm: aForm 330097 "Ascribe the blank nominal form" 330098 330099 originalForm := aForm. 330100 self rotationCenter: 0.5@0.5. 330101 self layoutChanged 330102! ! 330103 330104!SketchMorph methodsFor: 'accessing' stamp: 'sw 9/9/1998 13:15'! 330105originalForm: aForm 330106 originalForm := aForm! ! 330107 330108!SketchMorph methodsFor: 'accessing'! 330109rotatedForm 330110 330111 rotatedForm ifNil: [self layoutChanged]. 330112 ^ rotatedForm 330113! ! 330114 330115!SketchMorph methodsFor: 'accessing' stamp: 'gm 2/22/2003 13:14'! 330116scaleFactor 330117 "Answer the number representing my scaleFactor, assuming the receiver to be unflexed (if flexed, the renderer's scaleFactor is called instead" 330118 330119 | qty | 330120 ((qty := self scalePoint) isPoint) ifTrue: [^1.0]. 330121 ^qty! ! 330122 330123!SketchMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:06'! 330124scalePoint 330125 330126 scalePoint ifNil: [scalePoint := 1.0@1.0]. 330127 ^ scalePoint 330128! ! 330129 330130!SketchMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:06'! 330131scalePoint: aPoint 330132 330133 scalePoint := aPoint. 330134 self layoutChanged. 330135! ! 330136 330137!SketchMorph methodsFor: 'accessing' stamp: 'marcus.denker 2/23/2009 10:56'! 330138setNewFormFrom: formOrNil 330139 "Set the receiver's form as indicated. If nil is provided, then a default form will be used, possibly retrieved from the receiver's defaultValue property" 330140 330141 | defaultImage | 330142 formOrNil ifNotNil: [^ self form: formOrNil]. 330143 defaultImage := ScriptingSystem squeakyMouseForm. 330144 self form: defaultImage 330145! ! 330146 330147!SketchMorph methodsFor: 'accessing' stamp: 'ar 11/16/2002 19:22'! 330148useInterpolation 330149 ^(self valueOfProperty: #useInterpolation ifAbsent:[false]) 330150 and:[Smalltalk includesKey: #B3DRenderEngine]! ! 330151 330152!SketchMorph methodsFor: 'accessing' stamp: 'nk 1/24/2004 23:46'! 330153useInterpolation: aBool 330154 (aBool == true and: [ Smalltalk includesKey: #B3DRenderEngine ]) 330155 ifTrue:[self setProperty: #useInterpolation toValue: aBool] 330156 ifFalse:[self removeProperty: #useInterpolation]. 330157 self layoutChanged. "to regenerate the form" 330158! ! 330159 330160!SketchMorph methodsFor: 'accessing' stamp: 'nk 6/12/2004 09:32'! 330161wantsSimpleSketchMorphHandles 330162 "Answer true if my halo's simple handles should include the simple sketch morph handles." 330163 ^self isMemberOf: SketchMorph! ! 330164 330165 330166!SketchMorph methodsFor: 'caching' stamp: 'di 3/2/98 14:14'! 330167releaseCachedState 330168 "Clear cache of rotated, scaled Form." 330169 330170 super releaseCachedState. 330171 rotatedForm := nil. 330172 originalForm hibernate! ! 330173 330174 330175!SketchMorph methodsFor: 'drawing' stamp: 'Henrik Sperre Johansen 3/15/2009 00:00'! 330176areasRemainingToFill: aRectangle 330177 "Figuring out which parts of a Sketch are not translucent can be tricky to 330178 do... (Colors used can be transparent (see canBeEnlargedWithB3D) 330179 - Source Form can be depth 32 with alpha bits, etc. 330180 It's not certain whether the calculation to find areas remaining outside 330181 opaque parts will be of significant value (i.e. they probably will be merged 330182 when creating damage rects for Morphs beneath anyways), therefore handle 330183 it like we always have to redraw content beneath... At least for now" 330184 ^ Array with: aRectangle! ! 330185 330186!SketchMorph methodsFor: 'drawing' stamp: 'RAA 12/17/2000 12:53'! 330187canBeEnlargedWithB3D 330188 330189 | answer | 330190 330191 ^self 330192 valueOfProperty: #canBeEnlargedWithB3D 330193 ifAbsent: [ 330194 answer := self rotatedForm colorsUsed allSatisfy: [ :c | c isTranslucent not]. 330195 self setProperty: #canBeEnlargedWithB3D toValue: answer. 330196 answer 330197 ]! ! 330198 330199!SketchMorph methodsFor: 'drawing' stamp: 'RAA 12/17/2000 14:24'! 330200drawHighResolutionOn: aCanvas in: aRectangle 330201 330202 | r finalClipRect scale sourceOrigin sourceExtent sourceRect biggerSource biggerDestExtent interForm offsetInBigger | 330203 330204 r := aRectangle translateBy: aCanvas origin. 330205 finalClipRect := r intersect: (aCanvas clipRect translateBy: aCanvas origin). 330206 self canBeEnlargedWithB3D ifTrue: [ 330207 (WarpBlt toForm: aCanvas form) 330208 clipRect: finalClipRect; 330209 sourceForm: originalForm; 330210 cellSize: 2; "installs a colormap" 330211 combinationRule: Form paint; 330212 330213 copyQuad: originalForm boundingBox innerCorners 330214 toRect: r. 330215 ^self 330216 ]. 330217 scale := aRectangle extent / originalForm extent. 330218 sourceOrigin := originalForm offset + (aCanvas clipRect origin - aRectangle origin / scale). 330219 sourceExtent := aCanvas clipRect extent / scale. 330220 sourceRect := sourceOrigin rounded extent: sourceExtent rounded. 330221 biggerSource := sourceRect expandBy: 1. 330222 biggerDestExtent := (biggerSource extent * scale) rounded. 330223 offsetInBigger := (sourceOrigin - biggerSource origin * scale) rounded. 330224 330225 interForm := Form extent: biggerDestExtent depth: aCanvas depth. 330226 (originalForm copy: biggerSource) 330227 displayInterpolatedIn: interForm boundingBox 330228 on: interForm. 330229 aCanvas 330230 drawImage: interForm 330231 at: aCanvas clipRect origin 330232 sourceRect: (offsetInBigger extent: aCanvas clipRect extent). 330233 330234 330235! ! 330236 330237!SketchMorph methodsFor: 'drawing' stamp: 'ar 7/28/2005 16:51'! 330238drawInterpolatedImage: aForm on: aCanvas 330239 "Draw the given form onto the canvas using the Balloon 3D engine" 330240 | engine | 330241 engine := Smalltalk at: #B3DRenderEngine 330242 ifPresent:[:b3d | b3d defaultForPlatformOn: aCanvas form]. 330243 engine == nil ifTrue:[ 330244 self useInterpolation: false. 330245 ^self generateRotatedForm]. 330246 "Setup the engine" 330247 engine viewport: aCanvas form boundingBox. 330248 "Install the material to be used (using a plain white emission color)" 330249 engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white). 330250 "Install the texture" 330251 engine texture: aForm. 330252 "Draw the mesh" 330253 engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect). 330254 "and finish" 330255 engine finish.! ! 330256 330257!SketchMorph methodsFor: 'drawing' stamp: 'tk 10/9/2002 09:15'! 330258drawOn: aCanvas 330259 aCanvas translucentImage: self rotatedForm at: bounds origin 330260! ! 330261 330262!SketchMorph methodsFor: 'drawing' stamp: 'nk 8/18/2004 19:07'! 330263generateInterpolatedForm 330264 "Draw the given form onto the canvas using the Balloon 3D engine" 330265 | aCanvas extent | 330266 extent := (originalForm extent * scalePoint) asIntegerPoint. 330267 rotatedForm := Form extent: extent asIntegerPoint depth: originalForm depth. 330268 aCanvas := rotatedForm getCanvas. 330269 ^self drawInterpolatedImage: originalForm on: aCanvas! ! 330270 330271!SketchMorph methodsFor: 'drawing' stamp: 'gm 2/28/2003 00:27'! 330272generateRotatedForm 330273 "Compute my rotatedForm and offsetWhenRotated." 330274 330275 | scalePt smoothPix pair | 330276 scalePoint ifNil: [scalePoint := 1 @ 1]. 330277 scalePt := scalePoint x abs @ scalePoint y abs. 330278 rotationStyle == #none ifTrue: [scalePt := 1 @ 1]. 330279 smoothPix := (scalePt x < 1.0 or: [scalePt y < 1.0]) 330280 ifTrue: [2] 330281 ifFalse: [1]. 330282 rotationStyle = #leftRight 330283 ifTrue: 330284 [self heading asSmallAngleDegrees < 0.0 330285 ifTrue: [scalePt := scalePt x negated @ scalePt y]]. 330286 rotationStyle = #upDown 330287 ifTrue: 330288 [self heading asSmallAngleDegrees abs > 90.0 330289 ifTrue: [scalePt := scalePt x @ scalePt y negated]]. 330290 rotatedForm := scalePt = (1 @ 1) 330291 ifTrue: [originalForm] 330292 ifFalse: 330293 ["ar 11/19/2001: I am uncertain what happens in the case of rotationStyle ~~ normal" 330294 330295 (rotationStyle == #normal and: [self useInterpolation]) 330296 ifTrue: [^self generateInterpolatedForm]. 330297 pair := WarpBlt current 330298 rotate: originalForm 330299 degrees: 0 330300 center: originalForm boundingBox center 330301 scaleBy: scalePt 330302 smoothing: smoothPix. 330303 pair first]! ! 330304 330305 330306!SketchMorph methodsFor: 'e-toy support' stamp: 'sw 12/12/2001 13:10'! 330307baseGraphic 330308 "Answer my base graphic" 330309 330310 ^ self valueOfProperty: #baseGraphic ifAbsent: 330311 [self setProperty: #baseGraphic toValue: originalForm. 330312 ^ originalForm]! ! 330313 330314!SketchMorph methodsFor: 'e-toy support' stamp: 'sw 12/12/2001 13:15'! 330315baseGraphic: aForm 330316 "Remember the given form as the receiver's base graphic" 330317 330318 ^ self setProperty: #baseGraphic toValue: aForm! ! 330319 330320!SketchMorph methodsFor: 'e-toy support' stamp: 'mga 11/18/2003 09:54'! 330321flipHorizontal 330322 330323 self form: (self form flipBy: #horizontal centerAt: self form center)! ! 330324 330325!SketchMorph methodsFor: 'e-toy support' stamp: 'mga 11/18/2003 09:54'! 330326flipVertical 330327 330328 self form: (self form flipBy: #vertical centerAt: self form center)! ! 330329 330330!SketchMorph methodsFor: 'e-toy support'! 330331rotationStyle 330332 330333 ^ rotationStyle 330334! ! 330335 330336!SketchMorph methodsFor: 'e-toy support' stamp: 'jm 7/24/97 15:06'! 330337rotationStyle: aSymbol 330338 "Set my rotation style to #normal, #leftRight, #upDown, or #none. Styles mean: 330339 #normal -- continuous 360 degree rotation 330340 #leftRight -- quantize angle to left or right facing 330341 #upDown -- quantize angle to up or down facing 330342 #none -- do not rotate" 330343 330344 rotationStyle := aSymbol. 330345 self layoutChanged. 330346! ! 330347 330348!SketchMorph methodsFor: 'e-toy support' stamp: 'dgd 8/29/2004 11:05'! 330349wantsRecolorHandle 330350 "Answer whether the receiver would like a recolor handle to be 330351 put up for it. We'd want to disable this but for the moment 330352 that would cut off access to the button part of the properties 330353 sheet. So this remains a loose end." 330354 ^ false! ! 330355 330356 330357!SketchMorph methodsFor: 'geometry' stamp: 'nk 1/10/2004 14:51'! 330358extent: newExtent 330359 "Change my scale to fit myself into the given extent. 330360 Avoid extents where X or Y is zero." 330361 (newExtent y = 0 or: [ newExtent x = 0 ]) ifTrue: [ ^self ]. 330362 self extent = newExtent ifTrue:[^self]. 330363 scalePoint := newExtent asFloatPoint / (originalForm extent max: 1@1). 330364 self layoutChanged. 330365! ! 330366 330367!SketchMorph methodsFor: 'geometry' stamp: 'nk 6/21/2003 14:00'! 330368firstIntersectionWithLineFrom: start to: end 330369 | intersections last | 330370 intersections := self fullBounds extrapolatedIntersectionsWithLineFrom: start to: end. 330371 intersections size = 1 ifTrue: [ ^intersections anyOne ]. 330372 intersections isEmpty ifTrue: [ ^nil ]. 330373 intersections := intersections asSortedCollection: [ :a :b | (start dist: a) < (start dist: b) ]. 330374 last := intersections first rounded. 330375 last pointsTo: intersections last rounded do: [ :pt | 330376 (self rotatedForm isTransparentAt: (pt - bounds origin)) ifFalse: [ ^last ]. 330377 last := pt. 330378 ]. 330379 ^intersections first rounded! ! 330380 330381 330382!SketchMorph methodsFor: 'geometry etoy' stamp: 'ar 9/22/2000 22:31'! 330383forwardDirection: degrees 330384 "If not rotating normally, update my rotatedForm" 330385 super forwardDirection: degrees. 330386 rotationStyle == #normal ifFalse:[self layoutChanged].! ! 330387 330388 330389!SketchMorph methodsFor: 'geometry testing'! 330390containsPoint: aPoint 330391 330392 ^ (self bounds containsPoint: aPoint) and: 330393 [(self rotatedForm isTransparentAt: aPoint - bounds origin) not] 330394! ! 330395 330396 330397!SketchMorph methodsFor: 'halos and balloon help' stamp: 'sw 7/3/1999 20:06'! 330398isLikelyRecipientForMouseOverHalos 330399 ^ true! ! 330400 330401!SketchMorph methodsFor: 'halos and balloon help' stamp: 'ar 11/29/2001 19:51'! 330402wantsDirectionHandles 330403 ^self valueOfProperty: #wantsDirectionHandles ifAbsent:[ 330404 Preferences showDirectionHandles or:[Preferences showDirectionForSketches]]! ! 330405 330406!SketchMorph methodsFor: 'halos and balloon help' stamp: 'ar 11/29/2001 19:52'! 330407wantsDirectionHandles: aBool 330408 aBool == (Preferences showDirectionHandles or:[Preferences showDirectionForSketches]) 330409 ifTrue:[self removeProperty: #wantsDirectionHandles] 330410 ifFalse:[self setProperty: #wantsDirectionHandles toValue: aBool].! ! 330411 330412 330413!SketchMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:49'! 330414defaultForm 330415 ^ (ScriptingSystem formAtKey: 'Painting') deepCopy! ! 330416 330417!SketchMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:02'! 330418initialize 330419 "initialize the state of the receiver" 330420 super initialize. 330421 self initializeAllButForm. 330422 self initializeForm: self defaultForm! ! 330423 330424!SketchMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:03'! 330425initializeAllButForm 330426 self rotationCenter: 0.5@0.5. "relative to the top-left corner of the Form" 330427 rotationStyle := #normal. "styles: #normal, #leftRight, #upDown, or #none" 330428 scalePoint := 1.0@1.0. 330429 framesToDwell := 1. 330430! ! 330431 330432!SketchMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:03'! 330433initializeForm: aForm 330434 originalForm := aForm. 330435 rotatedForm := originalForm. "cached rotation of originalForm" 330436 self extent: originalForm extent. 330437! ! 330438 330439!SketchMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:03'! 330440initializeWithForm: aForm 330441 super initialize. 330442 self initializeAllButForm. 330443 self initializeForm: aForm. 330444! ! 330445 330446 330447!SketchMorph methodsFor: 'layout' stamp: 'ar 9/22/2000 14:00'! 330448layoutChanged 330449 "Update rotatedForm and compute new bounds." 330450 self changed. 330451 self generateRotatedForm. 330452 bounds := bounds origin extent: rotatedForm extent. 330453 super layoutChanged. 330454 self changed. 330455! ! 330456 330457 330458!SketchMorph methodsFor: 'menu' stamp: 'DamienCassou 9/29/2009 13:11'! 330459addBorderToShape: evt 330460 | str borderWidth borderedForm r | 330461 str := UIManager default 330462 request: 'Please enter the desired border width' translated 330463 initialAnswer: '0'. 330464 str ifNil: [str := String new]. 330465 borderWidth := Integer readFrom: str readStream. 330466 (borderWidth 330467 between: 1 330468 and: 10) ifFalse: [ ^ self ]. 330469 330470 "Take care of growing appropriately. Does this lose the reg point?" 330471 borderedForm := originalForm 330472 shapeBorder: Color black 330473 width: borderWidth. 330474 r := borderedForm rectangleEnclosingPixelsNotOfColor: Color transparent. 330475 self form: (borderedForm copy: r)! ! 330476 330477!SketchMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:16'! 330478addCustomMenuItems: aCustomMenu hand: aHandMorph 330479 "Add custom menu items" 330480 330481 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 330482 aCustomMenu add: 'restore base graphic' translated target: self action: #restoreBaseGraphicFromMenu. 330483 aCustomMenu add: 'call this my base graphic' translated target: self action: #callThisBaseGraphic. 330484 aCustomMenu add: 'choose new graphic...' translated target: self action: #chooseNewGraphic. 330485 aCustomMenu addLine. 330486 aCustomMenu add: 'set as background' translated target: rotatedForm action: #setAsBackground. 330487 self addPaintingItemsTo: aCustomMenu hand: aHandMorph! ! 330488 330489!SketchMorph methodsFor: 'menu' stamp: 'yo 3/15/2005 12:04'! 330490callThisBaseGraphic 330491 "Set my baseGraphic to be the current form" 330492 330493 | aGraphic | 330494 self isInWorld ifFalse: [^ self inform: 330495 330496'oops, this menu is a for a morph that 330497has been replaced, probably because a 330498"look like" script was run. Please dismiss 330499the menu and get a new one!!. Sorry!!' translated]. 330500 330501 ((aGraphic := self valueOfProperty: #baseGraphic) 330502 notNil and: [aGraphic ~= originalForm]) 330503 ifTrue: 330504 [self setProperty: #baseGraphic toValue: originalForm] 330505 ifFalse: 330506 [self inform: 'this already *was* your baseGraphic' translated]! ! 330507 330508!SketchMorph methodsFor: 'menu' stamp: 'tk 7/6/1998 15:31'! 330509editDrawing 330510 self flag: #deferred. "Don't allow this if the user is already in paint mode, because it creates a very strange situation." 330511 "costumee ifNotNil: [self forwardDirection: costumee direction]." "how say this?" 330512 self editDrawingIn: self pasteUpMorph forBackground: false 330513! ! 330514 330515!SketchMorph methodsFor: 'menu' stamp: 'sw 1/25/2006 21:41'! 330516editDrawingIn: aPasteUpMorph forBackground: forBackground 330517 "Edit an existing sketch." 330518 330519 | w bnds sketchEditor pal aPaintTab aWorld aPaintBox tfx rotCenter | 330520 self world assureNotPaintingElse: [^self]. 330521 w := aPasteUpMorph world. 330522 w prepareToPaint. 330523 w displayWorld. 330524 self visible: false. 330525 bnds := forBackground 330526 ifTrue: [aPasteUpMorph boundsInWorld] 330527 ifFalse: 330528 [bnds := self boundsInWorld expandBy: 60 @ 60. 330529 (aPasteUpMorph paintingBoundsAround: bnds center) merge: bnds]. 330530 sketchEditor := SketchEditorMorph new. 330531 forBackground 330532 ifTrue: [sketchEditor setProperty: #background toValue: true]. 330533 w addMorphFront: sketchEditor. 330534 sketchEditor 330535 initializeFor: self 330536 inBounds: bnds 330537 pasteUpMorph: aPasteUpMorph. 330538 rotCenter := self rotationCenter. 330539 330540 sketchEditor afterNewPicDo: 330541 [:aForm :aRect | 330542 self visible: true. 330543 self form: aForm. 330544 tfx := aPasteUpMorph transformFrom: aPasteUpMorph world. 330545 self topRendererOrSelf position: (tfx globalPointToLocal: aRect origin). 330546 self rotationStyle: sketchEditor rotationStyle. 330547 self forwardDirection: sketchEditor forwardDirection. 330548 (rotCenter notNil and: [(rotCenter = (0.5 @ 0.5)) not]) ifTrue: 330549 [self rotationCenter: rotCenter]. 330550 (aPaintTab := (aWorld := self world) paintingFlapTab) 330551 ifNotNil: [aPaintTab hideFlap] 330552 ifNil: [(aPaintBox := aWorld paintBox) ifNotNil: [aPaintBox delete]]. 330553 self presenter drawingJustCompleted: self. 330554 330555 forBackground ifTrue: [self goBehind "shouldn't be necessary"]] 330556 ifNoBits: 330557 ["If no bits drawn. Must keep old pic. Can't have no picture" 330558 330559 self visible: true. 330560 aWorld := self currentWorld. 330561 "sometimes by now I'm no longer in a world myself, but we still need 330562 to get ahold of the world so that we can deal with the palette" 330563 ((pal := aPasteUpMorph standardPalette) notNil and: [pal isInWorld]) 330564 ifTrue: 330565 [(aPaintBox := aWorld paintBox) ifNotNil: [aPaintBox delete]. 330566 pal viewMorph: self] 330567 ifFalse: 330568 [(aPaintTab := (aWorld := self world) paintingFlapTab) 330569 ifNotNil: [aPaintTab hideFlap] 330570 ifNil: [(aPaintBox := aWorld paintBox) ifNotNil: [aPaintBox delete]]]]! ! 330571 330572!SketchMorph methodsFor: 'menu' stamp: 'ar 10/5/2000 18:53'! 330573erasePixelsOfColor: evt 330574 "Let the user specifiy a color such that all pixels of that color should be erased; then do the erasure" 330575 330576 | c r | 330577 self changeColorTarget: self selector: #rememberedColor: originalColor: nil hand: evt hand. "color to erase" 330578 c := self rememberedColor ifNil: [Color red]. 330579 originalForm mapColor: c to: Color transparent. 330580 r := originalForm rectangleEnclosingPixelsNotOfColor: Color transparent. 330581 self form: (originalForm copy: r). 330582 330583! ! 330584 330585!SketchMorph methodsFor: 'menu' stamp: 'wiz 12/4/2006 00:32'! 330586insertIntoMovie: evt 330587 330588 | movies aTarget | 330589 movies := 330590 (self world rootMorphsAt: evt hand targetPoint) 330591 select: [:m | ((m isKindOf: MovieMorph) or: 330592 [m isSketchMorph]) and: [m ~= self]]. 330593 movies isEmpty ifTrue: [^ self]. 330594 aTarget := movies first. 330595 (aTarget isSketchMorph) ifTrue: [ 330596 aTarget := aTarget replaceSelfWithMovie]. 330597 aTarget insertFrames: (Array with: self). 330598 self delete. 330599! ! 330600 330601!SketchMorph methodsFor: 'menu' stamp: 'yo 2/12/2005 19:08'! 330602recolorPixelsOfColor: evt 330603 "Let the user select a color to be remapped, and then a color to map that color to, then carry it out." 330604 330605 | c d newForm map newC | 330606 self inform: 'choose the color you want to replace' translated. 330607 self changeColorTarget: self selector: #rememberedColor: originalColor: nil hand: evt hand. "color to replace" 330608 c := self rememberedColor ifNil: [Color red]. 330609 self inform: 'now choose the color you want to replace it with' translated. 330610 self changeColorTarget: self selector: #rememberedColor: originalColor: c hand: evt hand. "new color" 330611 newC := self rememberedColor ifNil: [Color blue]. 330612 d := originalForm depth. 330613 newForm := Form extent: originalForm extent depth: d. 330614 map := (Color cachedColormapFrom: d to: d) copy. 330615 map at: (c indexInMap: map) put: (newC pixelValueForDepth: d). 330616 newForm copyBits: newForm boundingBox 330617 from: originalForm at: 0@0 330618 colorMap: map. 330619 self form: newForm. 330620! ! 330621 330622!SketchMorph methodsFor: 'menu' stamp: 'DamienCassou 9/29/2009 13:11'! 330623reduceColorPalette: evt 330624 "Let the user ask for a reduced number of colors in this sketch" 330625 | str nColors | 330626 str := UIManager default 330627 request: 'Please enter a number greater than one. 330628(note: this cannot be undone, so answer zero 330629to abort if you need to make a backup first)' translated 330630 initialAnswer: '256'. 330631 str ifNil: [str := String new]. 330632 nColors := Integer readFrom: str readStream. 330633 (nColors 330634 between: 2 330635 and: 256) ifFalse: [ ^ self ]. 330636 originalForm := originalForm copyWithColorsReducedTo: nColors. 330637 rotatedForm := nil. 330638 self changed! ! 330639 330640!SketchMorph methodsFor: 'menu' stamp: 'sw 12/12/2001 13:14'! 330641restoreBaseGraphic 330642 "Restore the receiver's base graphic" 330643 330644 | aGraphic | 330645 ((aGraphic := self baseGraphic) notNil and: 330646 [aGraphic ~= originalForm]) 330647 ifTrue: 330648 [self form: aGraphic]! ! 330649 330650!SketchMorph methodsFor: 'menu' stamp: 'yo 3/15/2005 13:57'! 330651restoreBaseGraphicFromMenu 330652 "Restore the base graphic -- invoked from a menu, so give interactive feedback if appropriate" 330653 330654 self isInWorld ifFalse: [^ self inform: 330655 330656'oops, this menu is a for a morph that 330657has been replaced, probably because a 330658"look like" script was run. Please dismiss 330659the menu and get a new one!!. Sorry!!' translated]. 330660 330661 self baseGraphic = originalForm ifTrue: [^ self inform: 'This object is *already* showing its baseGraphic' translated]. 330662 self restoreBaseGraphic! ! 330663 330664!SketchMorph methodsFor: 'menu' stamp: 'alain.plantec 2/6/2009 17:25'! 330665setRotationStyle 330666 | selections labels sel reply | 330667 selections := #(normal leftRight upDown none). 330668 labels := #('rotate smoothly' 'left-right flip only' 'top-down flip only' 'don''t rotate'). 330669 sel := labels at: (selections indexOf: self rotationStyle ifAbsent:[1]). 330670 labels := labels collect:[:lbl| sel = lbl ifTrue:['<on>', lbl translated] ifFalse:['<off>', lbl translated]]. 330671 reply := UIManager default chooseFrom: labels values: labels. 330672 reply ifNotNil: [self rotationStyle: reply]. 330673! ! 330674 330675!SketchMorph methodsFor: 'menu' stamp: 'ar 11/19/2001 22:38'! 330676toggleInterpolation 330677 ^self useInterpolation: self useInterpolation not! ! 330678 330679!SketchMorph methodsFor: 'menu' stamp: 'dgd 9/6/2003 18:27'! 330680useInterpolationString 330681 ^ (self useInterpolation 330682 ifTrue: ['<yes>'] 330683 ifFalse: ['<no>']) 330684 , 'smooth image' translated! ! 330685 330686 330687!SketchMorph methodsFor: 'menus' stamp: 'ar 6/18/1999 06:40'! 330688addFillStyleMenuItems: aMenu hand: aHand 330689 "Do nothing here - we do not allow changing the fill style of a SketchMorph yet."! ! 330690 330691!SketchMorph methodsFor: 'menus' stamp: 'marcus.denker 11/19/2008 13:37'! 330692addToggleItemsToHaloMenu: aCustomMenu 330693 "Add toggle-items to the halo menu" 330694 super addToggleItemsToHaloMenu: aCustomMenu. 330695 aCustomMenu addUpdating: #useInterpolationString target: self action: #toggleInterpolation! ! 330696 330697!SketchMorph methodsFor: 'menus' stamp: 'nk 3/27/2001 17:57'! 330698changePixelsOfColor: c toColor: newColor 330699 330700 | r | 330701 originalForm mapColor: c to: newColor. 330702 r := originalForm rectangleEnclosingPixelsNotOfColor: Color transparent. 330703 self form: (originalForm copy: r). 330704 330705! ! 330706 330707!SketchMorph methodsFor: 'menus' stamp: 'RAA 11/14/2000 13:44'! 330708collapse 330709 330710 | priorPosition w collapsedVersion a | 330711 330712 (w := self world) ifNil: [^self]. 330713 collapsedVersion := (self imageForm scaledToSize: 50@50) asMorph. 330714 collapsedVersion setProperty: #uncollapsedMorph toValue: self. 330715 collapsedVersion on: #mouseUp send: #uncollapseSketch to: collapsedVersion. 330716 collapsedVersion setBalloonText: 'A collapsed version of ',self name. 330717 330718 self delete. 330719 w addMorphFront: ( 330720 a := AlignmentMorph newRow 330721 hResizing: #shrinkWrap; 330722 vResizing: #shrinkWrap; 330723 borderWidth: 4; 330724 borderColor: Color white; 330725 addMorph: collapsedVersion 330726 ). 330727 collapsedVersion setProperty: #collapsedMorphCarrier toValue: a. 330728 330729 (priorPosition := self valueOfProperty: #collapsedPosition ifAbsent: [nil]) 330730 ifNotNil: 330731 [a position: priorPosition]. 330732! ! 330733 330734 330735!SketchMorph methodsFor: 'other' stamp: 'sw 12/1/1998 18:16'! 330736newForm: aForm 330737 self originalForm: aForm. 330738 self layoutChanged! ! 330739 330740!SketchMorph methodsFor: 'other' stamp: 'jm 7/24/97 15:06'! 330741replaceSelfWithMovie 330742 "Replace this SketchMorph in its owner with a MovieMorph containing this sketch as its only frame. This allows a SketchMorph to be turned into a MovieMorph by just insering additional frames." 330743 330744 | o movie | 330745 self changed. 330746 o := self owner. 330747 movie := MovieMorph new position: self referencePosition. 330748 movie insertFrames: (Array with: self). 330749 o ifNil: [^ movie]. 330750 o addMorphFront: movie. 330751 ^ movie 330752! ! 330753 330754 330755!SketchMorph methodsFor: 'pen support' stamp: 'jm 4/22/1998 17:14'! 330756clearExtent: aPoint fillColor: aColor 330757 "Make this sketch have the given pixel dimensions and fill it with given color. Its previous contents are replaced." 330758 330759 self form: 330760 ((Form extent: aPoint depth: Display depth) fillColor: aColor). 330761! ! 330762 330763!SketchMorph methodsFor: 'pen support' stamp: 'jm 4/22/1998 09:26'! 330764penOnMyForm 330765 "Support for experiments with drawing under program control. To get started, make a new SketchMorph in a morphic world. In an inspector, give it the desired pixel dimensions with clearExtent:fillColor:. Then use this method to get a pen to which you can send normal pen commands. Reveal the resulting drawing with revealPenStrokes." 330766 330767 ^ Pen newOnForm: originalForm 330768! ! 330769 330770!SketchMorph methodsFor: 'pen support' stamp: 'jm 4/22/1998 09:08'! 330771revealPenStrokes 330772 "This message must be sent after a sequence of pen strokes to make the resulting changes visible." 330773 330774 rotatedForm := nil. 330775 self changed. 330776! ! 330777 330778 330779!SketchMorph methodsFor: 'testing' stamp: 'tk 11/1/2001 12:42'! 330780basicType 330781 "Answer a symbol representing the inherent type I hold" 330782 330783 "Number String Boolean player collection sound color etc" 330784 ^ #Image! ! 330785 330786"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 330787 330788SketchMorph class 330789 instanceVariableNames: ''! 330790 330791!SketchMorph class methodsFor: 'instance creation' stamp: 'ar 3/4/2001 20:59'! 330792fromFile: aFileName 330793 ^self fromStream: (FileStream readOnlyFileNamed: aFileName)! ! 330794 330795!SketchMorph class methodsFor: 'instance creation' stamp: 'ar 3/4/2001 21:00'! 330796fromStream: aStream 330797 ^self withForm: (ImageReadWriter formFromStream: aStream)! ! 330798 330799!SketchMorph class methodsFor: 'instance creation' stamp: 'nk 11/9/2003 08:11'! 330800openEditor 330801 "Create a new SketchMorph and open a SketchMorphEditor on it. 330802 Answers the painted SketchMorph." 330803 "SketchMorph openEditor" 330804 | newSketch | 330805 newSketch := (self 330806 withForm: (Form extent: 100 @ 100 depth: Display depth)) center: self currentWorld center; 330807 openInWorld; 330808 editDrawing. 330809 ^ newSketch! ! 330810 330811!SketchMorph class methodsFor: 'instance creation' stamp: 'alain.plantec 5/28/2009 10:55'! 330812withForm: aForm 330813 "Note: 'SketchMorph withForm: zz' is MUCH faster 330814 than 'SketchMorph new form: zz'." 330815 330816 ^ self basicNew initializeWithForm: aForm! ! 330817 330818 330819!SketchMorph class methodsFor: 'new-morph participation' stamp: 'sw 9/28/1998 17:15'! 330820includeInNewMorphMenu 330821 "Not to be instantiated from the menu" 330822 ^ false! ! 330823 330824 330825!SketchMorph class methodsFor: 'scripting' stamp: 'dgd 8/26/2004 12:11'! 330826defaultNameStemForInstances 330827 ^ 'Sketch'! ! 330828 330829 330830!SketchMorph class methodsFor: 'testing' stamp: 'nk 6/12/2004 09:16'! 330831isSketchMorphClass 330832 ^true! ! 330833MorphicModel subclass: #Slider 330834 instanceVariableNames: 'slider value setValueSelector sliderShadow sliderColor descending' 330835 classVariableNames: '' 330836 poolDictionaries: '' 330837 category: 'Morphic-Windows'! 330838 330839!Slider methodsFor: 'access' stamp: 'sw 3/10/2000 13:05'! 330840descending 330841 ^ descending == true! ! 330842 330843!Slider methodsFor: 'access' stamp: 'sw 3/12/2000 11:57'! 330844descending: aBoolean 330845 descending := aBoolean. 330846 self value: value! ! 330847 330848!Slider methodsFor: 'access' stamp: 'dew 2/15/1999 18:24'! 330849pagingArea 330850 ^self! ! 330851 330852!Slider methodsFor: 'access' stamp: 'dew 3/23/2002 01:38'! 330853sliderColor 330854 "color scheme for the whole slider widget" 330855 sliderColor ifNil: [^ (color alphaMixed: 0.7 with: Color white) slightlyLighter]. 330856 ^ sliderColor! ! 330857 330858!Slider methodsFor: 'access' stamp: 'sw 3/7/2000 15:39'! 330859sliderColor: newColor 330860 330861 sliderColor := newColor. 330862 slider ifNotNil: [slider color: sliderColor]! ! 330863 330864!Slider methodsFor: 'access' stamp: 'dew 3/4/2002 00:50'! 330865sliderShadowColor 330866 ^ self sliderColor alphaMixed: 0.2 with: self pagingArea color! ! 330867 330868!Slider methodsFor: 'access' stamp: 'dew 1/21/2002 01:31'! 330869thumbColor 330870 "Color of the draggable 'thumb'" 330871 ^ self sliderColor! ! 330872 330873!Slider methodsFor: 'access'! 330874value 330875 ^ value! ! 330876 330877 330878!Slider methodsFor: 'geometry' stamp: 'sw 3/10/2000 13:44'! 330879computeSlider 330880 | r | 330881 r := self roomToMove. 330882 self descending 330883 ifFalse: 330884 [slider position: (bounds isWide 330885 ifTrue: [r topLeft + ((r width * value) asInteger @ 0)] 330886 ifFalse: [r topLeft + (0 @ (r height * value) asInteger)])] 330887 ifTrue: 330888 [slider position: (bounds isWide 330889 ifTrue: [r bottomRight - ((r width * value) asInteger @ 0)] 330890 ifFalse: [r bottomRight - ((0 @ (r height * value) asInteger))])]. 330891 slider extent: self sliderExtent! ! 330892 330893!Slider methodsFor: 'geometry' stamp: 'dew 2/21/1999 03:08'! 330894extent: newExtent 330895 newExtent = bounds extent ifTrue: [^ self]. 330896 bounds isWide 330897 ifTrue: [super extent: (newExtent x max: self sliderThickness * 2) @ newExtent y] 330898 ifFalse: [super extent: newExtent x @ (newExtent y max: self sliderThickness * 2)]. 330899 self removeAllMorphs; initializeSlider! ! 330900 330901!Slider methodsFor: 'geometry'! 330902roomToMove 330903 ^ self totalSliderArea insetBy: (0@0 extent: self sliderExtent)! ! 330904 330905!Slider methodsFor: 'geometry'! 330906sliderExtent 330907 ^ bounds isWide 330908 ifTrue: [self sliderThickness @ self innerBounds height] 330909 ifFalse: [self innerBounds width @ self sliderThickness]! ! 330910 330911!Slider methodsFor: 'geometry' stamp: 'ar 12/18/2001 21:19'! 330912sliderThickness 330913 ^ 7! ! 330914 330915!Slider methodsFor: 'geometry'! 330916totalSliderArea 330917 ^ self innerBounds! ! 330918 330919 330920!Slider methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'! 330921defaultBorderColor 330922 "answer the default border color/fill style for the receiver" 330923 ^ #inset! ! 330924 330925!Slider methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:39'! 330926defaultBorderWidth 330927 "answer the default border width for the receiver" 330928 ^ 1! ! 330929 330930!Slider methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:07'! 330931defaultBounds 330932"answer the default bounds for the receiver" 330933 ^ 0 @ 0 corner: 16 @ 100! ! 330934 330935!Slider methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'! 330936defaultColor 330937 "answer the default color/fill style for the receiver" 330938 ^ Color lightGray! ! 330939 330940!Slider methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:30'! 330941initialize 330942 "initialize the state of the receiver" 330943 super initialize. 330944 "" 330945 value := 0.0. 330946 descending := false. 330947 self initializeSlider! ! 330948 330949!Slider methodsFor: 'initialization' stamp: 'jrp 8/3/2005 10:13'! 330950initializeSlider 330951 slider := RectangleMorph newBounds: self totalSliderArea color: self thumbColor. 330952 sliderShadow := RectangleMorph newBounds: self totalSliderArea 330953 color: self pagingArea color. 330954 slider on: #mouseMove send: #scrollAbsolute: to: self. 330955 slider on: #mouseDown send: #mouseDownInSlider: to: self. 330956 slider on: #mouseUp send: #mouseUpInSlider: to: self. 330957 slider setBorderWidth: 1 borderColor: Color lightGray.. 330958 sliderShadow setBorderWidth: 1 borderColor: #inset. 330959 "(the shadow must have the pagingArea as its owner to highlight properly)" 330960 self pagingArea addMorph: sliderShadow. 330961 sliderShadow hide. 330962 self addMorph: slider. 330963 self computeSlider. 330964! ! 330965 330966 330967!Slider methodsFor: 'model access'! 330968setValue: newValue 330969 "Called internally for propagation to model" 330970 self value: newValue. 330971 self use: setValueSelector orMakeModelSelectorFor: 'Value:' 330972 in: [:sel | setValueSelector := sel. model perform: sel with: value]! ! 330973 330974!Slider methodsFor: 'model access'! 330975value: newValue 330976 "Drive the slider position externally..." 330977 value := newValue min: 1.0 max: 0.0. 330978 self computeSlider! ! 330979 330980 330981!Slider methodsFor: 'other events' stamp: 'sd 11/8/2003 16:02'! 330982mouseDownInSlider: event 330983 330984 slider borderStyle style == #raised 330985 ifTrue: [slider borderColor: #inset]. 330986 330987 sliderShadow color: self sliderShadowColor. 330988 sliderShadow cornerStyle: slider cornerStyle. 330989 sliderShadow bounds: slider bounds. 330990 sliderShadow show! ! 330991 330992!Slider methodsFor: 'other events' stamp: 'sd 11/8/2003 16:02'! 330993mouseUpInSlider: event 330994 330995 slider borderStyle style == #inset 330996 ifTrue: [slider borderColor: #raised]. 330997 330998 sliderShadow hide! ! 330999 331000 331001!Slider methodsFor: 'scrolling' stamp: 'sw 3/10/2000 13:37'! 331002scrollAbsolute: event 331003 | r p | 331004 r := self roomToMove. 331005 bounds isWide 331006 ifTrue: [r width = 0 ifTrue: [^ self]] 331007 ifFalse: [r height = 0 ifTrue: [^ self]]. 331008 p := event targetPoint adhereTo: r. 331009 self descending 331010 ifFalse: 331011 [self setValue: (bounds isWide 331012 ifTrue: [(p x - r left) asFloat / r width] 331013 ifFalse: [(p y - r top) asFloat / r height])] 331014 ifTrue: 331015 [self setValue: (bounds isWide 331016 ifTrue: [(r right - p x) asFloat / r width] 331017 ifFalse: [(r bottom - p y) asFloat / r height])]! ! 331018 331019"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 331020 331021Slider class 331022 instanceVariableNames: ''! 331023 331024!Slider class methodsFor: 'new-morph participation' stamp: 'di 2/21/98 11:03'! 331025includeInNewMorphMenu 331026 "OK to instantiate" 331027 ^ true! ! 331028Collection subclass: #SmallDictionary 331029 instanceVariableNames: 'keys values size' 331030 classVariableNames: '' 331031 poolDictionaries: '' 331032 category: 'Collections-Unordered'! 331033!SmallDictionary commentStamp: '<historical>' prior: 0! 331034RBSmallDictionary is a special dictionary optimized for small collections. In addition to the normal dictionary protocol, it also supports an #empty message which "empties" the collection but may hang on to the original elements (so it could collect garbage). Without #empty we would either need to create a new dictionary or explicitly remove everything from the dictionary. Both of these take more time and #empty. 331035 331036Instance Variables: 331037keys <Array of: Object> array of keys (we don't use Associations for our key value pairs) 331038size <Integer> the size of the dictionary 331039values <Array of: Object> array of our values 331040! 331041 331042 331043!SmallDictionary methodsFor: 'accessing' stamp: 'nice 12/30/2008 18:55'! 331044capacity 331045 ^keys size! ! 331046 331047!SmallDictionary methodsFor: 'accessing'! 331048empty 331049 size := 0! ! 331050 331051!SmallDictionary methodsFor: 'accessing'! 331052size 331053 ^size! ! 331054 331055 331056!SmallDictionary methodsFor: 'accessing - associations' stamp: 'cyrille.delaunay 7/20/2009 13:16'! 331057associationAt: key 331058 ^ self associationAt: key ifAbsent: [self errorKeyNotFound]! ! 331059 331060!SmallDictionary methodsFor: 'accessing - associations' stamp: 'cyrille.delaunay 7/20/2009 13:16'! 331061associationAt: key ifAbsent: aBlock 331062 "Answer the association with the given key. 331063 If key is not found, return the result of evaluating aBlock." 331064 331065 | index value | 331066 index := keys indexOf: key. 331067 index == 0 ifTrue: [ ^ aBlock value]. 331068 331069 value := values at: index. 331070 ^ key->value.! ! 331071 331072!SmallDictionary methodsFor: 'accessing - associations' stamp: 'cyrille.delaunay 7/20/2009 13:17'! 331073associationDeclareAt: aKey 331074 "Return an existing association, or create and return a new one. Needed as a single message by ImageSegment.prepareToBeSaved." 331075 331076 ^ self associationAt: aKey ifAbsent: [| existing | 331077 (Undeclared includesKey: aKey) 331078 ifTrue: 331079 [existing := Undeclared associationAt: aKey. 331080 Undeclared removeKey: aKey. 331081 self add: existing] 331082 ifFalse: 331083 [self add: aKey -> false]].! ! 331084 331085!SmallDictionary methodsFor: 'accessing - associations' stamp: 'PeterHugossonMiller 9/3/2009 11:22'! 331086associations 331087 "Answer a Collection containing the receiver's associations." 331088 | out | 331089 out := (Array new: self size) writeStream. 331090 self associationsDo: [:value | out nextPut: value]. 331091 ^ out contents! ! 331092 331093 331094!SmallDictionary methodsFor: 'accessing - keys' stamp: 'cyrille.delaunay 7/20/2009 13:17'! 331095keyAtIdentityValue: value 331096 "Answer the key that is the external name for the argument, value. If 331097 there is none, answer nil. 331098 Note: There can be multiple keys with the same value. Only one is returned." 331099 331100 ^self keyAtIdentityValue: value ifAbsent: [self errorValueNotFound]! ! 331101 331102!SmallDictionary methodsFor: 'accessing - keys' stamp: 'cyrille.delaunay 7/20/2009 13:17'! 331103keyAtIdentityValue: value ifAbsent: exceptionBlock 331104 "Answer the key that is the external name for the argument, value. If 331105 there is none, answer the result of evaluating exceptionBlock. 331106 Note: There can be multiple keys with the same value. Only one is returned." 331107 331108 | index | 331109 index := (values identityIndexOf: value). 331110 index == 0 331111 ifTrue: [ ^ exceptionBlock value]. 331112 ^ keys at: index. 331113! ! 331114 331115!SmallDictionary methodsFor: 'accessing - keys' stamp: 'cyrille.delaunay 7/20/2009 13:17'! 331116keyAtValue: value 331117 "Answer the key that is the external name for the argument, value. If 331118 there is none, answer nil." 331119 331120 ^self keyAtValue: value ifAbsent: [self errorValueNotFound]! ! 331121 331122!SmallDictionary methodsFor: 'accessing - keys' stamp: 'cyrille.delaunay 7/20/2009 13:17'! 331123keyAtValue: value ifAbsent: exceptionBlock 331124 "Answer the key that is the external name for the argument, value. If 331125 there is none, answer the result of evaluating exceptionBlock. 331126 : Use =, not ==, so stings like 'this' can be found. Note that MethodDictionary continues to use == so it will be fast." 331127 331128 | index | 331129 index := (values indexOf: value). 331130 index == 0 331131 ifTrue: [ ^ exceptionBlock value]. 331132 331133 ^ keys at: index. 331134 331135! ! 331136 331137!SmallDictionary methodsFor: 'accessing - keys' stamp: 'cyrille.delaunay 7/20/2009 13:17'! 331138keys 331139 "Answer a Set containing the receiver's keys." 331140 331141" ^ keys copyFrom: 1 to: size." 331142 | aSet | 331143 aSet := Set new: self size. 331144 self keysDo: [:key | aSet add: key]. 331145 ^ aSet 331146! ! 331147 331148!SmallDictionary methodsFor: 'accessing - keys' stamp: 'cyrille.delaunay 7/20/2009 13:18'! 331149keysSortedSafely 331150 "Answer a SortedCollection containing the receiver's keys." 331151 | sortedKeys | 331152 sortedKeys := SortedCollection new: self size. 331153 sortedKeys sortBlock: 331154 [:x :y | "Should really be use <obj, string, num> compareSafely..." 331155 ((x isString and: [y isString]) 331156 or: [x isNumber and: [y isNumber]]) 331157 ifTrue: [x < y] 331158 ifFalse: [x class == y class 331159 ifTrue: [x printString < y printString] 331160 ifFalse: [x class name < y class name]]]. 331161 self keysDo: [:each | sortedKeys addLast: each]. 331162 ^ sortedKeys reSort! ! 331163 331164!SmallDictionary methodsFor: 'accessing - keys' stamp: 'cyrille.delaunay 7/20/2009 13:18'! 331165unreferencedKeys 331166 "TextConstants unreferencedKeys" 331167 331168 | n | 331169 ^'Scanning for references . . .' 331170 displayProgressAt: Sensor cursorPoint 331171 from: 0 331172 to: self size 331173 during: 331174 [:bar | 331175 n := 0. 331176 self keys select: 331177 [:key | 331178 bar value: (n := n + 1). 331179 (self systemNavigation allCallsOn: (self associationAt: key)) isEmpty]]! ! 331180 331181 331182!SmallDictionary methodsFor: 'accessing - values' stamp: 'cyrille.delaunay 7/20/2009 13:18'! 331183at: key 331184 "Answer the value associated with the key." 331185 331186 ^ self at: key ifAbsent: [self errorKeyNotFound]! ! 331187 331188!SmallDictionary methodsFor: 'accessing - values' stamp: 'cyrille.delaunay 7/20/2009 13:47'! 331189at: key ifAbsent: aBlock 331190 "Answer the value associated with the key or, if key isn't found, 331191 answer the result of evaluating aBlock." 331192 331193 | index | 331194 index := self findIndexForKey: key. 331195 index == 0 ifTrue: [^ aBlock value]. 331196 331197 ^ values at: index. 331198 331199 "| assoc | 331200 assoc := array at: (self findElementOrNil: key). 331201 assoc ifNil: [^ aBlock value]. 331202 ^ assoc value"! ! 331203 331204!SmallDictionary methodsFor: 'accessing - values' stamp: 'cyrille.delaunay 7/20/2009 13:47'! 331205at: key ifAbsentPut: aBlock 331206 "Return the value at the given key. 331207 If key is not included in the receiver store the result 331208 of evaluating aBlock as new value." 331209 331210 | index | 331211 index := self findIndexForKey: key. 331212 index == 0 331213 ifFalse: [ 331214 ^ values at: index. 331215 ] 331216 ifTrue: [ 331217 ^ self privateAt: key put: aBlock value. 331218 ]! ! 331219 331220!SmallDictionary methodsFor: 'accessing - values' stamp: 'cyrille.delaunay 7/20/2009 13:19'! 331221at: key ifPresent: aBlock 331222 "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil." 331223 331224 | v | 331225 v := self at: key ifAbsent: [^ nil]. 331226 ^ aBlock value: v 331227! ! 331228 331229!SmallDictionary methodsFor: 'accessing - values' stamp: 'cyrille.delaunay 7/20/2009 13:19'! 331230at: key ifPresentAndInMemory: aBlock 331231 "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil." 331232 331233 | v | 331234 v := self at: key ifAbsent: [^ nil]. 331235 v isInMemory ifFalse: [^ nil]. 331236 ^ aBlock value: v 331237! ! 331238 331239!SmallDictionary methodsFor: 'accessing - values' stamp: 'PeterHugossonMiller 9/3/2009 11:22'! 331240values 331241 "Answer a Collection containing the receiver's values." 331242 "^ values copyFrom: 1 to: size." 331243 331244| out | 331245 out := (Array new: self size) writeStream. 331246 self valuesDo: [:value | out nextPut: value]. 331247 ^ out contents! ! 331248 331249 331250!SmallDictionary methodsFor: 'adding'! 331251add: anAssociation 331252 self at: anAssociation key put: anAssociation value. 331253 ^anAssociation! ! 331254 331255!SmallDictionary methodsFor: 'adding' stamp: 'cyrille.delaunay 7/20/2009 13:19'! 331256addAll: aKeyedCollection 331257 aKeyedCollection == self 331258 ifFalse: [ 331259 aKeyedCollection keysAndValuesDo: [:key :value | self at: key put: value]]. 331260 ^aKeyedCollection! ! 331261 331262!SmallDictionary methodsFor: 'adding' stamp: 'cyrille.delaunay 7/20/2009 13:19'! 331263declare: key from: aDictionary 331264 "Add key to the receiver. If key already exists, do nothing. If aDictionary 331265 includes key, then remove it from aDictionary and use its association as 331266 the element of the receiver." 331267 331268 (self includesKey: key) ifTrue: [^ self]. 331269 (aDictionary includesKey: key) 331270 ifTrue: 331271 [self add: (aDictionary associationAt: key). 331272 aDictionary removeKey: key] 331273 ifFalse: 331274 [self add: key -> nil]! ! 331275 331276 331277!SmallDictionary methodsFor: 'comparing' stamp: 'cyrille.delaunay 7/20/2009 13:20'! 331278= aDictionary 331279 "Two dictionaries are equal if 331280 (a) they are the same 'kind' of thing. 331281 (b) they have the same set of keys. 331282 (c) for each (common) key, they have the same value" 331283 331284 self == aDictionary ifTrue: [ ^ true ]. 331285 (aDictionary isDictionary) ifFalse: [^false]. 331286 self size = aDictionary size ifFalse: [^false]. 331287 self associationsDo: [:assoc| 331288 (aDictionary at: assoc key ifAbsent: [^false]) = assoc value 331289 ifFalse: [^false]]. 331290 ^true 331291! ! 331292 331293 331294!SmallDictionary methodsFor: 'copying' stamp: 'cyrille.delaunay 7/20/2009 13:20'! 331295copy 331296 ^ self shallowCopy postCopy.! ! 331297 331298!SmallDictionary methodsFor: 'copying'! 331299postCopy 331300 keys := keys copy. 331301 values := values copy! ! 331302 331303 331304!SmallDictionary methodsFor: 'enumerating - assoctiations'! 331305associationsDo: aBlock 331306 self keysAndValuesDo: [:key :value | aBlock value: key -> value]! ! 331307 331308!SmallDictionary methodsFor: 'enumerating - assoctiations' stamp: 'cyrille.delaunay 7/20/2009 13:20'! 331309associationsSelect: aBlock 331310 "Evaluate aBlock with each of my associations as the argument. Collect 331311 into a new dictionary, only those associations for which aBlock evaluates 331312 to true." 331313 331314 | newCollection | 331315 newCollection := self species new. 331316 self associationsDo: 331317 [:each | 331318 (aBlock value: each) ifTrue: [newCollection add: each]]. 331319 ^newCollection! ! 331320 331321 331322!SmallDictionary methodsFor: 'enumerating - keys' stamp: 'cyrille.delaunay 7/20/2009 13:21'! 331323keysDo: aBlock 331324 1 to: size do: [:i | aBlock value: (keys at: i)]! ! 331325 331326 331327!SmallDictionary methodsFor: 'enumerating - keys and values' stamp: 'cyrille.delaunay 7/20/2009 13:21'! 331328keysAndValuesDo: aBlock 331329 1 to: size do: [:i | aBlock value: (keys at: i) value: (values at: i)]! ! 331330 331331 331332!SmallDictionary methodsFor: 'enumerating - values' stamp: 'cyrille.delaunay 7/20/2009 13:21'! 331333collect: aBlock 331334 "Evaluate aBlock with each of my values as the argument. Collect the 331335 resulting values into a collection that is like me. Answer with the new 331336 collection." 331337 | newCollection | 331338 newCollection := self species new. 331339 self associationsDo:[:each | 331340 newCollection at: each key put: (aBlock value: each value). 331341 ]. 331342 ^newCollection! ! 331343 331344!SmallDictionary methodsFor: 'enumerating - values' stamp: 'cyrille.delaunay 7/20/2009 13:21'! 331345do: aBlock 331346 331347 ^ self valuesDo: aBlock.! ! 331348 331349!SmallDictionary methodsFor: 'enumerating - values' stamp: 'cyrille.delaunay 7/20/2009 13:21'! 331350select: aBlock 331351 "Evaluate aBlock with each of my values as the argument. Collect into a 331352 new dictionary, only those associations for which aBlock evaluates to 331353 true." 331354 331355 | newCollection | 331356 newCollection := self species new. 331357 self associationsDo: 331358 [:each | 331359 (aBlock value: each value) ifTrue: [newCollection add: each]]. 331360 ^newCollection! ! 331361 331362!SmallDictionary methodsFor: 'enumerating - values' stamp: 'cyrille.delaunay 7/20/2009 13:21'! 331363valuesDo: aBlock 331364 "Evaluate aBlock for each of the receiver's values." 331365 3313661 to: size do: [:i | aBlock value: (values at: i)]! ! 331367 331368 331369!SmallDictionary methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:04'! 331370initialize 331371 super initialize. 331372 keys := Array new: 2. 331373 values := Array new: 2. 331374 size := 0! ! 331375 331376 331377!SmallDictionary methodsFor: 'printing' stamp: 'cyrille.delaunay 7/20/2009 13:23'! 331378flattenOnStream: aStream 331379" seems to not be the best solution to do that. 331380 Imagine if the class Stream should have a method #writeSomething for each object existing in Pharo. 331381 Objects themeself have the information on how to be print . Not the stream. " 331382 ^aStream writeDictionary:self.! ! 331383 331384!SmallDictionary methodsFor: 'printing' stamp: 'pmm 7/4/2009 13:04'! 331385printElementsOn: aStream 331386 | noneYet | 331387 aStream nextPut: $(. 331388 noneYet := true. 331389 self associationsDo: [ :each | 331390 noneYet 331391 ifTrue: [ noneYet := false ] 331392 ifFalse: [ aStream space ]. 331393 aStream print: each]. 331394 aStream nextPut: $)! ! 331395 331396!SmallDictionary methodsFor: 'printing' stamp: 'pmm 7/4/2009 12:37'! 331397storeOn: aStream 331398 | noneYet | 331399 aStream nextPutAll: '(('. 331400 aStream nextPutAll: self class name. 331401 aStream nextPutAll: ' new)'. 331402 noneYet := true. 331403 self associationsDo: [ :each | 331404 noneYet 331405 ifTrue: [ noneYet := false ] 331406 ifFalse: [ aStream nextPut: $; ]. 331407 aStream nextPutAll: ' add: '. 331408 aStream store: each]. 331409 noneYet ifFalse: [ aStream nextPutAll: '; yourself']. 331410 aStream nextPut: $)! ! 331411 331412 331413!SmallDictionary methodsFor: 'putting' stamp: 'cyrille.delaunay 7/20/2009 13:47'! 331414at: key put: value 331415 "Set the value at key to be anObject. If key is not found, create a 331416 new entry for key and set is value to anObject. Answer anObject." 331417 331418 | index | 331419 index := self findIndexForKey: key. 331420 index == 0 331421 ifFalse: [ 331422 ^ values at: index put: value] 331423 ifTrue: [ 331424 ^ self privateAt: key put: value 331425 ]. 331426 ! ! 331427 331428 331429!SmallDictionary methodsFor: 'removing - keys' stamp: 'cyrille.delaunay 7/20/2009 13:23'! 331430remove:anAssociation 331431 331432 self removeKey:anAssociation key.! ! 331433 331434!SmallDictionary methodsFor: 'removing - keys' stamp: 'cyrille.delaunay 7/20/2009 13:23'! 331435remove: oldObject ifAbsent: anExceptionBlock 331436 self removeKey: oldObject key ifAbsent: anExceptionBlock. 331437 ^oldObject! ! 331438 331439!SmallDictionary methodsFor: 'removing - keys' stamp: 'cyrille.delaunay 7/20/2009 13:24'! 331440removeKey: key 331441 "Remove key from the receiver. 331442 If key is not in the receiver, notify an error." 331443 331444 ^ self removeKey: key ifAbsent: [self errorKeyNotFound]! ! 331445 331446!SmallDictionary methodsFor: 'removing - keys' stamp: 'cyrille.delaunay 7/20/2009 13:48'! 331447removeKey: key ifAbsent: aBlock 331448 "Remove key (and its associated value) from the receiver. If key is not in 331449 the receiver, answer the result of evaluating aBlock. Otherwise, answer 331450 the value externally named by key." 331451 331452 | index value | 331453 index := self findIndexForKey: key. 331454 index == 0 ifTrue: [^aBlock value]. 331455 331456 value := values at: index. 331457 index to: size - 1 331458 do: 331459 [:i | 331460 keys at: i put: (keys at: i + 1). 331461 values at: i put: (values at: i + 1)]. 331462 keys at: size put: nil. 331463 values at: size put: nil. 331464 size := size - 1. 331465 ^value! ! 331466 331467!SmallDictionary methodsFor: 'removing - keys' stamp: 'cyrille.delaunay 7/20/2009 13:24'! 331468removeUnreferencedKeys "Undeclared removeUnreferencedKeys" 331469 331470 ^ self unreferencedKeys do: [:key | self removeKey: key].! ! 331471 331472 331473!SmallDictionary methodsFor: 'removing - keys and values' stamp: 'cyrille.delaunay 7/20/2009 13:24'! 331474keysAndValuesRemove: keyValueBlock 331475 "Removes all entries for which keyValueBlock returns true." 331476 "When removing many items, you must not do it while iterating over the dictionary, since it may be changing. This method takes care of tallying the removals in a first pass, and then performing all the deletions afterward. Many places in the sytem could be simplified by using this method." 331477 331478 | removals | 331479 removals := OrderedCollection new. 331480 self keysAndValuesDo: 331481 [:key :value | (keyValueBlock value: key value: value) 331482 ifTrue: [removals add: key]]. 331483 removals do: 331484 [:aKey | self removeKey: aKey]! ! 331485 331486 331487!SmallDictionary methodsFor: 'testing' stamp: 'cyrille.delaunay 7/20/2009 13:24'! 331488hasBindingThatBeginsWith: aString 331489 "Answer true if the receiver has a key that begins with aString, false otherwise" 331490 331491 self keysDo:[:each | 331492 (each beginsWith: aString) 331493 ifTrue:[^true]]. 331494 ^false! ! 331495 331496!SmallDictionary methodsFor: 'testing' stamp: 'cyrille.delaunay 7/20/2009 13:24'! 331497isDictionary 331498 ^true! ! 331499 331500 331501!SmallDictionary methodsFor: 'testing - associaitons' stamp: 'cyrille.delaunay 7/20/2009 13:25'! 331502includesAssociation: anAssociation 331503 ^ (self 331504 associationAt: anAssociation key 331505 ifAbsent: [ ^ false ]) value = anAssociation value 331506! ! 331507 331508 331509!SmallDictionary methodsFor: 'testing - keys' stamp: 'cyrille.delaunay 7/20/2009 13:48'! 331510includesKey: key 331511 "Answer whether the receiver has a key equal to the argument, key." 331512 331513 ^ ((self findIndexForKey: key) = 0) not! ! 331514 331515 331516!SmallDictionary methodsFor: 'testing - values' stamp: 'cyrille.delaunay 7/20/2009 13:25'! 331517includes: aValue 331518 self do: [:each | aValue = each ifTrue: [^true]]. 331519 ^false! ! 331520 331521!SmallDictionary methodsFor: 'testing - values' stamp: 'cyrille.delaunay 7/20/2009 13:25'! 331522includesIdentity: aValue 331523 "Answer whether aValue is one of the values of the receiver. Contrast #includes: in which there is only an equality check, here there is an identity check" 331524 331525 self do: [:each | aValue == each ifTrue: [^ true]]. 331526 ^ false! ! 331527 331528!SmallDictionary methodsFor: 'testing - values' stamp: 'cyrille.delaunay 7/20/2009 13:25'! 331529keyForIdentity: aValue 331530 "If aValue is one of the values of the receive, return its key, else return nil. Contrast #keyAtValue: in which there is only an equality check, here there is an identity check" 331531 331532 self keysAndValuesDo: [:key :value | value == aValue ifTrue: [^ key]]. 331533 ^ nil! ! 331534 331535!SmallDictionary methodsFor: 'testing - values' stamp: 'cyrille.delaunay 7/20/2009 13:25'! 331536occurrencesOf: aValue 331537 "Answer how many of the receiver's elements are equal to anObject." 331538 331539 | count | 331540 count := 0. 331541 self do: [:each | aValue = each ifTrue: [count := count + 1]]. 331542 ^count! ! 331543 331544 331545!SmallDictionary methodsFor: 'user interface' stamp: 'cyrille.delaunay 7/20/2009 13:25'! 331546customizeExplorerContents 331547 331548 ^ true. 331549! ! 331550 331551!SmallDictionary methodsFor: 'user interface' stamp: 'cyrille.delaunay 7/20/2009 13:26'! 331552explorerContentsWithIndexCollect: twoArgBlock 331553 331554 | sortedKeys | 331555 sortedKeys := self keys asSortedCollection: [:x :y | 331556 ((x isString and: [y isString]) 331557 or: [x isNumber and: [y isNumber]]) 331558 ifTrue: [x < y] 331559 ifFalse: [x class == y class 331560 ifTrue: [x printString < y printString] 331561 ifFalse: [x class name < y class name]]]. 331562 ^ sortedKeys collect: [:k | twoArgBlock value: (self at: k) value: k]. 331563! ! 331564 331565 331566!SmallDictionary methodsFor: 'private' stamp: 'pmm 7/4/2009 13:46'! 331567errorKeyNotFound 331568 331569 self error: 'key not found'! ! 331570 331571!SmallDictionary methodsFor: 'private' stamp: 'pmm 7/4/2009 13:46'! 331572errorValueNotFound 331573 331574 self error: 'value not found'! ! 331575 331576!SmallDictionary methodsFor: 'private' stamp: 'cyrille.delaunay 7/20/2009 13:30'! 331577findIndexForKey: aKey 331578 ^ keys indexOf: aKey.! ! 331579 331580!SmallDictionary methodsFor: 'private' stamp: 'marcus.denker 9/18/2008 11:17'! 331581rehash 331582 "we don't use hashing, nothing to be done"! ! 331583 331584!SmallDictionary methodsFor: 'private' stamp: 'cyrille.delaunay 7/20/2009 13:54'! 331585scanFor: anObject 331586 "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 331587 | element start finish | 331588 finish := keys size. 331589 start := (anObject hash \\ finish) + 1. 331590 331591 "Search from (hash mod size) to the end." 331592 start to: finish do: 331593 [:index | ((element := keys at: index) == nil or: [element = anObject]) 331594 ifTrue: [^ index ]]. 331595 331596 "Search from 1 to where we started." 331597 1 to: start-1 do: 331598 [:index | ((element := keys at: index) == nil or: [element = anObject]) 331599 ifTrue: [^ index ]]. 331600 331601 ^ 0 "No match AND no empty slot"! ! 331602 331603 331604!SmallDictionary methodsFor: 'private - growing' stamp: 'cyrille.delaunay 7/20/2009 13:26'! 331605growKeysAndValues 331606 self growTo: size * 2! ! 331607 331608!SmallDictionary methodsFor: 'private - growing' stamp: 'cyrille.delaunay 7/20/2009 13:26'! 331609growTo: aSize 331610 | newKeys newValues | 331611 newKeys := Array new: aSize. 331612 newValues := Array new: aSize. 331613 1 to: size 331614 do: 331615 [:i | 331616 newKeys at: i put: (keys at: i). 331617 newValues at: i put: (values at: i)]. 331618 keys := newKeys. 331619 values := newValues! ! 331620 331621!SmallDictionary methodsFor: 'private - growing' stamp: 'cyrille.delaunay 7/20/2009 13:26'! 331622privateAt: key put: value 331623 size == keys size ifTrue: [self growKeysAndValues]. 331624 size := size + 1. 331625 keys at: size put: key. 331626 ^values at: size put: value! ! 331627 331628"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 331629 331630SmallDictionary class 331631 instanceVariableNames: ''! 331632 331633!SmallDictionary class methodsFor: 'instance creation'! 331634new 331635 ^self basicNew initialize! ! 331636 331637!SmallDictionary class methodsFor: 'instance creation'! 331638new: aSize 331639 "Ignore the size" 331640 331641 ^self basicNew initialize! ! 331642DictionaryTest subclass: #SmallDictionaryTest 331643 instanceVariableNames: '' 331644 classVariableNames: '' 331645 poolDictionaries: '' 331646 category: 'CollectionsTests-Unordered'! 331647 331648!SmallDictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 13:43'! 331649classToBeTested 331650 331651 ^ SmallDictionary! ! 331652 331653 331654!SmallDictionaryTest methodsFor: 'test - printing' stamp: 'sd 7/21/2009 10:17'! 331655testStoreOn 331656 "self debug: #testStoreOn" 331657 331658 self assert: self nonEmptyDict storeString = ('((', self nonEmptyDict class printString , ' new) add: (#a->1); add: (#b->30); add: (#c->1); add: (#d->-2); yourself)')! ! 331659 331660"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 331661 331662SmallDictionaryTest class 331663 instanceVariableNames: ''! 331664 331665!SmallDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 7/1/2009 16:22'! 331666shouldInheritSelectors 331667 331668^true! ! 331669SmallDictionary subclass: #SmallIdentityDictionary 331670 instanceVariableNames: '' 331671 classVariableNames: '' 331672 poolDictionaries: '' 331673 category: 'Collections-Unordered'! 331674!SmallIdentityDictionary commentStamp: 'sd 7/21/2009 10:12' prior: 0! 331675I'm a SmallDictionary (this means faster than default one when dealing with limited number of items) 331676but I check my key based on identity.! 331677 331678 331679!SmallIdentityDictionary methodsFor: 'private' stamp: 'cyrille.delaunay 7/20/2009 13:30'! 331680findIndexForKey: aKey 331681 ^ keys identityIndexOf: aKey! ! 331682SmallDictionaryTest subclass: #SmallIdentityDictionaryTest 331683 instanceVariableNames: '' 331684 classVariableNames: '' 331685 poolDictionaries: '' 331686 category: 'CollectionsTests-Unordered'! 331687 331688!SmallIdentityDictionaryTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 7/1/2009 16:23'! 331689classToBeTested 331690 331691^ SmallIdentityDictionary! ! 331692 331693"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 331694 331695SmallIdentityDictionaryTest class 331696 instanceVariableNames: ''! 331697 331698!SmallIdentityDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 7/1/2009 16:22'! 331699shouldInheritSelectors 331700 331701^true! ! 331702Integer subclass: #SmallInteger 331703 instanceVariableNames: '' 331704 classVariableNames: '' 331705 poolDictionaries: '' 331706 category: 'Kernel-Numbers'! 331707!SmallInteger commentStamp: '<historical>' prior: 0! 331708My instances are 31-bit numbers, stored in twos complement form. The allowable range is approximately +- 1 billion (see SmallInteger minVal, maxVal).! 331709 331710 331711!SmallInteger methodsFor: 'arithmetic' stamp: 'di 2/1/1999 21:29'! 331712* aNumber 331713 "Primitive. Multiply the receiver by the argument and answer with the 331714 result if it is a SmallInteger. Fail if the argument or the result is not a 331715 SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." 331716 331717 <primitive: 9> 331718 ^ super * aNumber! ! 331719 331720!SmallInteger methodsFor: 'arithmetic' stamp: 'di 2/1/1999 21:31'! 331721+ aNumber 331722 "Primitive. Add the receiver to the argument and answer with the result 331723 if it is a SmallInteger. Fail if the argument or the result is not a 331724 SmallInteger Essential No Lookup. See Object documentation whatIsAPrimitive." 331725 331726 <primitive: 1> 331727 ^ super + aNumber! ! 331728 331729!SmallInteger methodsFor: 'arithmetic'! 331730- aNumber 331731 "Primitive. Subtract the argument from the receiver and answer with the 331732 result if it is a SmallInteger. Fail if the argument or the result is not a 331733 SmallInteger. Essential. No Lookup. See Object documentation 331734 whatIsAPrimitive." 331735 331736 <primitive: 2> 331737 ^super - aNumber! ! 331738 331739!SmallInteger methodsFor: 'arithmetic' stamp: 'tak 9/25/2008 15:14'! 331740/ aNumber 331741 "Primitive. This primitive (for /) divides the receiver by the argument 331742 and returns the result if the division is exact. Fail if the result is not a 331743 whole integer. Fail if the argument is 0 or is not a SmallInteger. Optional. 331744 No Lookup. See Object documentation whatIsAPrimitive." 331745 331746 <primitive: 10> 331747 aNumber isZero ifTrue: [^(ZeroDivide dividend: self) signal]. 331748 ^(aNumber isMemberOf: SmallInteger) 331749 ifTrue: [(Fraction numerator: self denominator: aNumber) reduced] 331750 ifFalse: [super / aNumber]! ! 331751 331752!SmallInteger methodsFor: 'arithmetic' stamp: 'tk 11/30/2001 11:55'! 331753// aNumber 331754 "Primitive. Divide the receiver by the argument and answer with the 331755 result. Round the result down towards negative infinity to make it a 331756 whole integer. Fail if the argument is 0 or is not a SmallInteger. 331757 Essential. No Lookup. See Object documentation whatIsAPrimitive. " 331758 331759 <primitive: 12> 331760 ^ super // aNumber "Do with quo: if primitive fails"! ! 331761 331762!SmallInteger methodsFor: 'arithmetic' stamp: 'tk 11/30/2001 11:53'! 331763\\ aNumber 331764 "Primitive. Take the receiver modulo the argument. The result is the 331765 remainder rounded towards negative infinity, of the receiver divided by 331766 the argument Fail if the argument is 0 or is not a SmallInteger. Optional. 331767 No Lookup. See Object documentation whatIsAPrimitive." 331768 331769 <primitive: 11> 331770 ^ super \\ aNumber "will use // to compute it if primitive fails"! ! 331771 331772!SmallInteger methodsFor: 'arithmetic' stamp: 'LC 4/22/1998 14:21'! 331773gcd: anInteger 331774 "See SmallInteger (Integer) | gcd:" 331775 | n m | 331776 n := self. 331777 m := anInteger. 331778 [n = 0] 331779 whileFalse: 331780 [n := m \\ (m := n)]. 331781 ^ m abs! ! 331782 331783!SmallInteger methodsFor: 'arithmetic' stamp: 'sr 5/28/2000 04:41'! 331784quo: aNumber 331785 "Primitive. Divide the receiver by the argument and answer with the 331786 result. Round the result down towards zero to make it a whole integer. 331787 Fail if the argument is 0 or is not a SmallInteger. Optional. See Object 331788 documentation whatIsAPrimitive." 331789 <primitive: 13> 331790 aNumber = 0 ifTrue: [^ (ZeroDivide dividend: self) signal]. 331791 (aNumber isMemberOf: SmallInteger) 331792 ifFalse: [^ super quo: aNumber]. 331793 (aNumber == -1 and: [self == self class minVal]) 331794 ifTrue: ["result is aLargeInteger" ^ self negated]. 331795 self primitiveFailed! ! 331796 331797 331798!SmallInteger methodsFor: 'bit manipulation' stamp: 'bf 9/25/2008 15:18'! 331799bitAnd: arg 331800 "Primitive. Answer an Integer whose bits are the logical OR of the 331801 receiver's bits and those of the argument, arg. 331802 Numbers are interpreted as having 2's-complement representation. 331803 Essential. See Object documentation whatIsAPrimitive." 331804 331805 <primitive: 14> 331806 self >= 0 ifTrue: [^ arg bitAnd: self]. 331807 ^ (self bitInvert bitOr: arg bitInvert) bitInvert.! ! 331808 331809!SmallInteger methodsFor: 'bit manipulation' stamp: 'di 4/30/1998 10:33'! 331810bitOr: arg 331811 "Primitive. Answer an Integer whose bits are the logical OR of the 331812 receiver's bits and those of the argument, arg. 331813 Numbers are interpreted as having 2's-complement representation. 331814 Essential. See Object documentation whatIsAPrimitive." 331815 331816 <primitive: 15> 331817 self >= 0 ifTrue: [^ arg bitOr: self]. 331818 ^ arg < 0 331819 ifTrue: [(self bitInvert bitAnd: arg bitInvert) bitInvert] 331820 ifFalse: [(self bitInvert bitClear: arg) bitInvert]! ! 331821 331822!SmallInteger methodsFor: 'bit manipulation' stamp: 'mir 9/25/2008 15:18'! 331823bitShift: arg 331824 "Primitive. Answer an Integer whose value is the receiver's value shifted 331825 left by the number of bits indicated by the argument. Negative arguments 331826 shift right. The receiver is interpreted as having 2's-complement representation. 331827 Essential. See Object documentation whatIsAPrimitive." 331828 331829 <primitive: 17> 331830 self >= 0 ifTrue: [^ super bitShift: arg]. 331831 ^ arg >= 0 331832 ifTrue: [(self negated bitShift: arg) negated] 331833 ifFalse: [(self bitInvert bitShift: arg) bitInvert].! ! 331834 331835!SmallInteger methodsFor: 'bit manipulation' stamp: 'mir 9/25/2008 15:18'! 331836bitXor: arg 331837 "Primitive. Answer an Integer whose bits are the logical XOR of the 331838 receiver's bits and those of the argument, arg. 331839 Numbers are interpreted as having 2's-complement representation. 331840 Essential. See Object documentation whatIsAPrimitive." 331841 331842 <primitive: 16> 331843 self >= 0 ifTrue: [^ arg bitXor: self]. 331844 ^ arg < 0 331845 ifTrue: [self bitInvert bitXor: arg bitInvert] 331846 ifFalse: [(self bitInvert bitXor: arg) bitInvert].! ! 331847 331848!SmallInteger methodsFor: 'bit manipulation' stamp: 'SqR 8/3/2000 13:29'! 331849hashMultiply 331850 | low | 331851 331852 low := self bitAnd: 16383. 331853 ^(16r260D * low + ((16r260D * (self bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) 331854 bitAnd: 16r0FFFFFFF! ! 331855 331856!SmallInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:07'! 331857highBit 331858 "Answer the index of the high order bit of the receiver, or zero if the 331859 receiver is zero. Raise an error if the receiver is negative, since 331860 negative integers are defined to have an infinite number of leading 1's 331861 in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to 331862 get the highest bit of the magnitude." 331863 self < 0 ifTrue: [^ self error: 'highBit is not defined for negative integers']. 331864 ^ self highBitOfPositiveReceiver! ! 331865 331866!SmallInteger methodsFor: 'bit manipulation' stamp: 'nice 7/8/2008 02:39'! 331867highBitOfMagnitude 331868 "Answer the index of the high order bit of the receiver, or zero if the 331869 receiver is zero. This method is used for negative SmallIntegers as well, 331870 since Squeak's LargeIntegers are sign/magnitude." 331871 331872 self < 0 ifTrue: [ 331873 "Beware: do not use highBitOfPositiveReceiver 331874 because self negated is not necessarily a SmallInteger 331875 (see SmallInteger minVal)" 331876 ^self negated highBitOfMagnitude]. 331877 331878 "Implementation note: this method could be as well inlined here." 331879 ^self highBitOfPositiveReceiver! ! 331880 331881!SmallInteger methodsFor: 'bit manipulation' stamp: 'nice 7/8/2008 01:40'! 331882lowBit 331883 " Answer the index of the low order one bit. 331884 2r00101000 lowBit (Answers: 4) 331885 2r-00101000 lowBit (Answers: 4) 331886 First we skip bits in groups of 4, then single bits. 331887 While not optimal, this is a good tradeoff; long 331888 integer #lowBit always invokes us with bytes." 331889 | n result last4 | 331890 n := self. 331891 n = 0 ifTrue: [ ^ 0 ]. 331892 result := 0. 331893 [(last4 := n bitAnd: 16rF) = 0] 331894 whileTrue: [ 331895 result := result + 4. 331896 n := n bitShift: -4 ]. 331897 331898 "The low bits table can be obtained with: 331899 (1 to: 4) inject: #[1] into: [:lowBits :rank | (lowBits copy at: 1 put: lowBits first + 1; yourself) , lowBits]." 331900 ^result + ( #[5 1 2 1 3 1 2 1 4 1 2 1 3 1 2 1] at: (last4)+1)! ! 331901 331902 331903!SmallInteger methodsFor: 'comparing'! 331904< aNumber 331905 "Primitive. Compare the receiver with the argument and answer with 331906 true if the receiver is less than the argument. Otherwise answer false. 331907 Fail if the argument is not a SmallInteger. Essential. No Lookup. See 331908 Object documentation whatIsAPrimitive." 331909 331910 <primitive: 3> 331911 ^super < aNumber! ! 331912 331913!SmallInteger methodsFor: 'comparing'! 331914<= aNumber 331915 "Primitive. Compare the receiver with the argument and answer true if 331916 the receiver is less than or equal to the argument. Otherwise answer 331917 false. Fail if the argument is not a SmallInteger. Optional. No Lookup. 331918 See Object documentation whatIsAPrimitive. " 331919 331920 <primitive: 5> 331921 ^super <= aNumber! ! 331922 331923!SmallInteger methodsFor: 'comparing'! 331924= aNumber 331925 "Primitive. Compare the receiver with the argument and answer true if 331926 the receiver is equal to the argument. Otherwise answer false. Fail if the 331927 argument is not a SmallInteger. Essential. No Lookup. See Object 331928 documentation whatIsAPrimitive. " 331929 331930 <primitive: 7> 331931 ^super = aNumber! ! 331932 331933!SmallInteger methodsFor: 'comparing'! 331934> aNumber 331935 "Primitive. Compare the receiver with the argument and answer true if 331936 the receiver is greater than the argument. Otherwise answer false. Fail if 331937 the argument is not a SmallInteger. Essential. No Lookup. See Object 331938 documentation whatIsAPrimitive." 331939 331940 <primitive: 4> 331941 ^super > aNumber! ! 331942 331943!SmallInteger methodsFor: 'comparing'! 331944>= aNumber 331945 "Primitive. Compare the receiver with the argument and answer true if 331946 the receiver is greater than or equal to the argument. Otherwise answer 331947 false. Fail if the argument is not a SmallInteger. Optional. No Lookup. 331948 See Object documentation whatIsAPrimitive." 331949 331950 <primitive: 6> 331951 ^super >= aNumber! ! 331952 331953!SmallInteger methodsFor: 'comparing'! 331954hash 331955 331956 ^self! ! 331957 331958!SmallInteger methodsFor: 'comparing'! 331959identityHash 331960 331961 ^self! ! 331962 331963!SmallInteger methodsFor: 'comparing'! 331964~= aNumber 331965 "Primitive. Compare the receiver with the argument and answer true if 331966 the receiver is not equal to the argument. Otherwise answer false. Fail if 331967 the argument is not a SmallInteger. Essential. No Lookup. See Object 331968 documentation whatIsAPrimitive." 331969 331970 <primitive: 8> 331971 ^super ~= aNumber! ! 331972 331973 331974!SmallInteger methodsFor: 'converting' stamp: 'ajh 7/25/2001 22:34'! 331975as31BitSmallInt 331976 "Polymorphic with LargePositiveInteger (see comment there). 331977 Return self since all SmallIntegers are 31 bits" 331978 331979 ^ self! ! 331980 331981!SmallInteger methodsFor: 'converting'! 331982asFloat 331983 "Primitive. Answer a Float that represents the value of the receiver. 331984 Essential. See Object documentation whatIsAPrimitive." 331985 331986 <primitive: 40> 331987 self primitiveFailed! ! 331988 331989 331990!SmallInteger methodsFor: 'copying' stamp: 'tk 6/26/1998 11:34'! 331991clone 331992! ! 331993 331994!SmallInteger methodsFor: 'copying'! 331995deepCopy! ! 331996 331997!SmallInteger methodsFor: 'copying'! 331998shallowCopy! ! 331999 332000!SmallInteger methodsFor: 'copying' stamp: 'tk 8/19/1998 16:04'! 332001veryDeepCopyWith: deepCopier 332002 "Return self. I can't be copied. Do not record me."! ! 332003 332004 332005!SmallInteger methodsFor: 'printing' stamp: 'gk 5/25/2007 15:10'! 332006decimalDigitLength 332007 "Answer the number of digits printed out in base 10. 332008 Note that this only works for positive SmallIntegers." 332009 332010 ^ self < 10000 332011 ifTrue: [self < 100 332012 ifTrue: [self < 10 332013 ifTrue: [1] 332014 ifFalse: [2]] 332015 ifFalse: [self < 1000 332016 ifTrue: [3] 332017 ifFalse: [4]]] 332018 ifFalse: [self < 1000000 332019 ifTrue: [self < 100000 332020 ifTrue: [5] 332021 ifFalse: [6]] 332022 ifFalse: [self < 100000000 332023 ifTrue: [self < 10000000 332024 ifTrue: [7] 332025 ifFalse: [8]] 332026 ifFalse: [self < 1000000000 332027 ifTrue: [9] 332028 ifFalse: [10]]]]! ! 332029 332030!SmallInteger methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:15'! 332031destinationBuffer:digitLength 332032 ^ LargePositiveInteger new: digitLength.! ! 332033 332034!SmallInteger methodsFor: 'printing' stamp: 'nice 2/15/2008 22:22'! 332035numberOfDigitsInBase: b 332036 "Return how many digits are necessary to print this number in base b. 332037 Mostly same as super but an optimized version for base 10 case" 332038 332039 b = 10 ifFalse: [^super numberOfDigitsInBase: b]. 332040 self < 0 ifTrue: [^self negated numberOfDigitsInBase: b]. 332041 ^self decimalDigitLength! ! 332042 332043!SmallInteger methodsFor: 'printing' stamp: 'nice 2/15/2008 21:43'! 332044printOn: aStream base: b 332045 "Append a representation of this number in base b on aStream." 332046 332047 self < 0 332048 ifTrue: [aStream nextPut: $-. 332049 aStream nextPutAll: (self negated printStringBase: b). 332050 ^self]. 332051 332052 "allocating a String seems faster than streaming for SmallInteger" 332053 aStream nextPutAll: (self printStringBase: b)! ! 332054 332055!SmallInteger methodsFor: 'printing' stamp: 'nice 2/15/2008 21:42'! 332056printOn: aStream base: b nDigits: n 332057 "Append a representation of this number in base b on aStream using nDigits. 332058 self must be positive." 332059 332060 "allocating a String seems faster than streaming for SmallInteger" 332061 aStream nextPutAll: (self printStringBase: b nDigits: n)! ! 332062 332063!SmallInteger methodsFor: 'printing' stamp: 'gk 5/25/2007 15:08'! 332064printString 332065 "Highly optimized version for base 10 332066 and that we know it is a SmallInteger." 332067 332068 | integer next result len | 332069 self = 0 ifTrue: [^'0']. 332070 self < 0 ifTrue: [^'-', self negated printString]. 332071 len := self decimalDigitLength. 332072 result := String new: len. 332073 integer := self. 332074 len to: 1 by: -1 do: [:i | 332075 next := integer // 10. 332076 result byteAt: i put: 48 + (integer - (next * 10)). 332077 integer := next]. 332078 ^result! ! 332079 332080!SmallInteger methodsFor: 'printing' stamp: 'nice 7/6/2008 00:48'! 332081printStringBase: b 332082 "Return a String representation of this number in base b. 332083 For SmallIntegers, it is more efficient to print directly in a String, 332084 rather than using a Stream like super." 332085 332086 self < 0 332087 ifTrue: [^ '-' 332088 , (self negated printStringBase: b)]. 332089 self < b 332090 ifTrue: [^ String 332091 with: (Character digitValue: self)]. 332092 ^ self printStringBase: b nDigits: (self numberOfDigitsInBase: b)! ! 332093 332094!SmallInteger methodsFor: 'printing' stamp: 'nice 2/15/2008 21:39'! 332095printStringBase: b nDigits: n 332096 "Return a string representation of this number in base b with n digits (left padded with 0). 332097 Should be invoked with: 0 <= self < (b raisedToInteger: n)." 332098 332099 | integer next result | 332100 result := String new: n. 332101 integer := self. 332102 n to: 1 by: -1 do: [:i | 332103 next := integer // b. 332104 result byteAt: i put: (Character digitValue: (integer - (next * b))). 332105 integer := next]. 332106 ^result! ! 332107 332108!SmallInteger methodsFor: 'printing' stamp: 'RAA 8/24/2001 13:59'! 332109threeDigitName 332110 332111 | units answer | 332112 332113 self = 0 ifTrue: [^'']. 332114 units := #('one' 'two' 'three' 'four' 'five' 'six' 'seven' 'eight' 'nine' 'ten' 332115 'eleven' 'twelve' 'thirteen' 'fourteen' 'fifteen' 'sixteen' 'seventeen' 332116 'eighteen' 'nineteen'). 332117 self > 99 ifTrue: [ 332118 answer := (units at: self // 100),' hundred'. 332119 (self \\ 100) = 0 ifFalse: [ 332120 answer := answer,' ',(self \\ 100) threeDigitName 332121 ]. 332122 ^answer 332123 ]. 332124 self < 20 ifTrue: [ 332125 ^units at: self 332126 ]. 332127 answer := #('twenty' 'thirty' 'forty' 'fifty' 'sixty' 'seventy' 'eighty' 'ninety') 332128 at: self // 10 - 1. 332129 (self \\ 10) = 0 ifFalse: [ 332130 answer := answer,'-',(units at: self \\ 10) 332131 ]. 332132 ^answer! ! 332133 332134 332135!SmallInteger methodsFor: 'system primitives'! 332136asOop 332137 "Answer an object pointer as an integer, return negative number for SmallInteger" 332138 332139 ^ self! ! 332140 332141!SmallInteger methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:28'! 332142digitAt: n 332143 "Answer the value of an indexable field in the receiver. LargePositiveInteger uses bytes of base two number, and each is a 'digit' base 256. Fail if the argument (the index) is not an Integer or is out of bounds." 332144 n>4 ifTrue: [^ 0]. 332145 self < 0 332146 ifTrue: 332147 [self = SmallInteger minVal ifTrue: 332148 ["Can't negate minVal -- treat specially" 332149 ^ #(0 0 0 64) at: n]. 332150 ^ ((0-self) bitShift: (1-n)*8) bitAnd: 16rFF] 332151 ifFalse: [^ (self bitShift: (1-n)*8) bitAnd: 16rFF]! ! 332152 332153!SmallInteger methodsFor: 'system primitives' stamp: 'md 6/5/2003 10:42'! 332154digitAt: n put: value 332155 "Fails. The digits of a small integer can not be modified." 332156 332157 self error: 'You can''t store in a SmallInteger'! ! 332158 332159!SmallInteger methodsFor: 'system primitives'! 332160digitLength 332161 "Answer the number of indexable fields in the receiver. This value is the 332162 same as the largest legal subscript. Included so that a SmallInteger can 332163 behave like a LargePositiveInteger or LargeNegativeInteger." 332164 332165 (self < 16r100 and: [self > -16r100]) ifTrue: [^ 1]. 332166 (self < 16r10000 and: [self > -16r10000]) ifTrue: [^ 2]. 332167 (self < 16r1000000 and: [self > -16r1000000]) ifTrue: [^ 3]. 332168 ^ 4! ! 332169 332170!SmallInteger methodsFor: 'system primitives'! 332171instVarAt: i 332172 "Small integer has to be specially handled." 332173 332174 i = 1 ifTrue: [^self]. 332175 self error: 'argument too big for small integer instVarAt:'! ! 332176 332177!SmallInteger methodsFor: 'system primitives' stamp: 'tk 5/14/1999 20:54'! 332178nextInstance 332179 "SmallIntegers can't be enumerated this way. There are a finite number of them from from (SmallInteger minVal) to (SmallInteger maxVal), but you'll have to enumerate them yourself with: 332180 (SmallInteger minVal) to: (SmallInteger maxVal) do: [:integer | <your code here>]. 332181 " 332182 332183 self shouldNotImplement ! ! 332184 332185!SmallInteger methodsFor: 'system primitives' stamp: 'je 10/22/2002 12:10'! 332186nextObject 332187 "SmallIntegers are immediate objects, and, as such, do not have successors in object memory." 332188 332189 self shouldNotImplement ! ! 332190 332191 332192!SmallInteger methodsFor: 'testing'! 332193even 332194 332195 ^(self bitAnd: 1) = 0! ! 332196 332197!SmallInteger methodsFor: 'testing' stamp: 'nice 8/31/2008 00:07'! 332198isLarge 332199 ^false! ! 332200 332201!SmallInteger methodsFor: 'testing'! 332202odd 332203 332204 ^(self bitAnd: 1) = 1! ! 332205 332206 332207!SmallInteger methodsFor: 'private'! 332208fromString: str radix: radix 332209 332210 | maxdigit c val | 332211 maxdigit := 332212 radix + (radix > 10 332213 ifTrue: [55 - 1] 332214 ifFalse: [48 - 1]). 332215 val := 0. 332216 1 to: str size do: 332217 [:i | 332218 c := str at: i. 332219 (c < 48 ifFalse: [c > maxdigit]) 332220 ifTrue: [^false]. 332221 val := val * radix + (c <= 57 332222 ifTrue: [c - 48] 332223 ifFalse: 332224 [c < 65 ifTrue: [^false]. 332225 c - 55])]. 332226 ^val! ! 332227 332228!SmallInteger methodsFor: 'private' stamp: 'nice 7/8/2008 01:15'! 332229highBitOfPositiveReceiver 332230 | shifted bitNo | 332231 "Answer the index of the high order bit of the receiver, or zero if the 332232 receiver is zero. Receiver has to be positive!!" 332233 shifted := self. 332234 bitNo := 0. 332235 [shifted < 65536] 332236 whileFalse: 332237 [shifted := shifted bitShift: -16. 332238 bitNo := bitNo + 16]. 332239 shifted < 256 332240 ifFalse: 332241 [shifted := shifted bitShift: -8. 332242 bitNo := bitNo + 8]. 332243 shifted < 16 332244 ifFalse: 332245 [shifted := shifted bitShift: -4. 332246 bitNo := bitNo + 4]. 332247 332248 "The high bits table can be obtained with: 332249 (1 to: 4) inject: #[0] into: [:highBits :rank | highBits , (highBits collect: [:e | rank])]." 332250 ^bitNo + ( #[0 1 2 2 3 3 3 3 4 4 4 4 4 4 4 4] at: shifted+1)! ! 332251 332252"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 332253 332254SmallInteger class 332255 instanceVariableNames: ''! 332256 332257!SmallInteger class methodsFor: 'constants'! 332258maxVal 332259 "Answer the maximum value for a SmallInteger." 332260 ^ 16r3FFFFFFF! ! 332261 332262!SmallInteger class methodsFor: 'constants'! 332263minVal 332264 "Answer the minimum value for a SmallInteger." 332265 ^ -16r40000000! ! 332266 332267 332268!SmallInteger class methodsFor: 'documentation'! 332269guideToDivision 332270 "Handy guide to the kinds of Integer division: 332271 / exact division, returns a fraction if result is not a whole integer. 332272 // returns an Integer, rounded towards negative infinity. 332273 \\ is modulo rounded towards negative infinity. 332274 quo: truncated division, rounded towards zero."! ! 332275 332276 332277!SmallInteger class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 14:17'! 332278basicNew 332279 332280 self error: 'SmallIntegers can only be created by performing arithmetic'! ! 332281 332282!SmallInteger class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 14:18'! 332283new 332284 332285 self basicNew "generates an error"! ! 332286 332287 332288!SmallInteger class methodsFor: 'plugin generation' stamp: 'acg 9/20/1999 11:20'! 332289ccgCanConvertFrom: anObject 332290 332291 ^anObject class == self! ! 332292ClassTestCase subclass: #SmallIntegerTest 332293 instanceVariableNames: '' 332294 classVariableNames: '' 332295 poolDictionaries: '' 332296 category: 'KernelTests-Numbers'! 332297!SmallIntegerTest commentStamp: 'fbs 3/8/2004 22:13' prior: 0! 332298I provide a test suite for SmallInteger values. Examine my tests to see how SmallIntegers should behave, and see how to use them.! 332299 332300 332301!SmallIntegerTest methodsFor: 'testing - Class Methods' stamp: 'sd 6/5/2005 08:59'! 332302testBasicNew 332303 332304 self should: [SmallInteger basicNew] raise: TestResult error. ! ! 332305 332306!SmallIntegerTest methodsFor: 'testing - Class Methods' stamp: 'sd 6/5/2005 08:59'! 332307testMaxVal 332308 332309 self assert: (SmallInteger maxVal = 16r3FFFFFFF).! ! 332310 332311!SmallIntegerTest methodsFor: 'testing - Class Methods' stamp: 'sd 6/5/2005 08:59'! 332312testMinVal 332313 332314 self assert: (SmallInteger minVal = -16r40000000).! ! 332315 332316!SmallIntegerTest methodsFor: 'testing - Class Methods' stamp: 'sd 6/5/2005 08:59'! 332317testNew 332318 332319 self should: [SmallInteger new] raise: TestResult error. ! ! 332320 332321 332322!SmallIntegerTest methodsFor: 'testing - arithmetic' stamp: 'sd 6/5/2005 08:59'! 332323testDivide 332324 332325 self assert: 2 / 1 = 2. 332326 self assert: (3 / 2) isFraction. 332327 self assert: 4 / 2 = 2. 332328 self should: [ 1 / 0 ] raise: ZeroDivide.! ! 332329 332330 332331!SmallIntegerTest methodsFor: 'testing - printing' stamp: 'fbs 12/8/2005 12:58'! 332332testPrintPaddedWith 332333 332334self assert: (123 printPaddedWith: $0 to: 10 base: 2) = '0001111011'. 332335self assert: (123 printPaddedWith: $0 to: 10 base: 8) = '0000000173'. 332336self assert: (123 printPaddedWith: $0 to: 10 base: 10) = '0000000123'. 332337self assert: (123 printPaddedWith: $0 to: 10 base: 16) = '000000007B'.! ! 332338 332339!SmallIntegerTest methodsFor: 'testing - printing' stamp: 'al 7/21/2008 21:48'! 332340testPrintString 332341 self assert: 1 printString = '1'. 332342 self assert: -1 printString = '-1'. 332343 self assert: SmallInteger minVal printString = '-1073741824'. 332344 self assert: SmallInteger maxVal printString = '1073741823'. 332345 self assert: 12345 printString = '12345'. 332346 self assert: -54321 printString = '-54321'. 332347 332348 self assert: 0 decimalDigitLength = 1. 332349 self assert: 4 decimalDigitLength = 1. 332350 self assert: 12 decimalDigitLength = 2. 332351 self assert: 123 decimalDigitLength = 3. 332352 self assert: 1234 decimalDigitLength = 4. 332353 self assert: 56789 decimalDigitLength = 5. 332354 self assert: 657483 decimalDigitLength = 6. 332355 self assert: 6571483 decimalDigitLength = 7. 332356 self assert: 65174383 decimalDigitLength = 8. 332357 self assert: 625744831 decimalDigitLength = 9. 332358 self assert: 1000001111 decimalDigitLength = 10. 332359 self assert: SmallInteger maxVal decimalDigitLength = 10.! ! 332360Object subclass: #SmalltalkImage 332361 instanceVariableNames: '' 332362 classVariableNames: 'EndianCache LastImageName LastQuitLogPosition LastStats SourceFileVersionString StartupStamp' 332363 poolDictionaries: '' 332364 category: 'System-Support'! 332365!SmalltalkImage commentStamp: 'sd 7/2/2003 21:50' prior: 0! 332366I represent the SmalltalkImage and partly the VM. Using my current instance you can 332367 - get the value of some VM parameters, system arguments, vm profiling, 332368 endianess status, external objects,.... 332369 332370 - save the image, manage sources 332371 332372As you will notice browsing my code I'm a fat class having still too much responsibility. 332373But this is life. sd-2 July 2003 332374 332375PS: if someone wants to split me go ahead.! 332376 332377 332378!SmalltalkImage methodsFor: 'endian' stamp: 'yo 2/18/2004 18:24'! 332379calcEndianness 332380 | bytes word blt | 332381 "What endian-ness is the current hardware? The String '1234' will be stored into a machine word. On BigEndian machines (the Mac), $1 will be the high byte if the word. On LittleEndian machines (the PC), $4 will be the high byte." 332382 "SmalltalkImage current endianness" 332383 332384 bytes := ByteArray withAll: #(0 0 0 0). "(1 2 3 4) or (4 3 2 1)" 332385 word := WordArray with: 16r01020304. 332386 blt := (BitBlt toForm: (Form new hackBits: bytes)) 332387 sourceForm: (Form new hackBits: word). 332388 blt combinationRule: Form over. "store" 332389 blt sourceY: 0; destY: 0; height: 1; width: 4. 332390 blt sourceX: 0; destX: 0. 332391 blt copyBits. "paste the word into the bytes" 332392 bytes first = 1 ifTrue: [^ #big]. 332393 bytes first = 4 ifTrue: [^ #little]. 332394 self error: 'Ted is confused'.! ! 332395 332396!SmalltalkImage methodsFor: 'endian' stamp: 'yo 2/18/2004 18:24'! 332397endianness 332398 332399 EndianCache ifNil: [EndianCache := self calcEndianness]. 332400 ^ EndianCache. 332401! ! 332402 332403!SmalltalkImage methodsFor: 'endian' stamp: 'sd 6/27/2003 23:25'! 332404isBigEndian 332405 ^self endianness == #big! ! 332406 332407!SmalltalkImage methodsFor: 'endian' stamp: 'sd 6/27/2003 23:25'! 332408isLittleEndian 332409 ^self endianness == #little! ! 332410 332411 332412!SmalltalkImage methodsFor: 'external' stamp: 'sd 6/28/2003 18:23'! 332413exitToDebugger 332414 "Primitive. Enter the machine language debugger, if one exists. Essential. 332415 See Object documentation whatIsAPrimitive. This primitive is to access the 332416 debugger when debugging the vm or a plugging in C" 332417 332418 <primitive: 114> 332419 self primitiveFailed! ! 332420 332421!SmalltalkImage methodsFor: 'external' stamp: 'sd 6/28/2003 17:38'! 332422unbindExternalPrimitives 332423 "Primitive. Force all external primitives to be looked up again afterwards. Since external primitives that have not found are bound for fast failure this method will force the lookup of all primitives again so that after adding some plugin the primitives may be found." 332424 <primitive: 570> 332425 "Do nothing if the primitive fails for compatibility with older VMs" 332426! ! 332427 332428 332429!SmalltalkImage methodsFor: 'housekeeping' stamp: 'yo 7/25/2003 17:50'! 332430reconstructChanges2 332431 "Move all the changes and its histories onto another sources file." 332432 "SmalltalkImage reconstructChanges2" 332433 332434 | f oldChanges classCount | 332435 f := FileStream fileNamed: 'ST80.temp'. 332436 f header; timeStamp. 332437 (SourceFiles at: 2) converter: MacRomanTextConverter new. 332438'Recoding Changes File...' 332439 displayProgressAt: Sensor cursorPoint 332440 from: 0 to: Smalltalk classNames size 332441 during: 332442 [:bar | classCount := 0. 332443 Smalltalk allClassesDo: 332444 [:class | bar value: (classCount := classCount + 1). 332445 class moveChangesWithVersionsTo: f. 332446 class putClassCommentToCondensedChangesFile: f. 332447 class class moveChangesWithVersionsTo: f]]. 332448 self lastQuitLogPosition: f position. 332449 f trailer; close. 332450 oldChanges := SourceFiles at: 2. 332451 oldChanges close. 332452 FileDirectory default 332453 deleteFileNamed: oldChanges name , '.old'; 332454 rename: oldChanges name toBe: oldChanges name , '.old'; 332455 rename: f name toBe: oldChanges name. 332456 Smalltalk setMacFileInfoOn: oldChanges name. 332457 SourceFiles at: 2 332458 put: (FileStream oldFileNamed: oldChanges name)! ! 332459 332460 332461!SmalltalkImage methodsFor: 'image cleanup' stamp: 'oscar.nierstrasz 10/18/2009 12:15'! 332462fixObsoleteReferences 332463 "SmalltalkImage current fixObsoleteReferences. 332464 SystemNavigation default obsoleteBehaviors size > 0 332465 ifTrue: [ SystemNavigation default obsoleteBehaviors inspect. 332466 self error:'Still have obsolete behaviors. See inspector']" 332467 332468 | informee obsoleteBindings obsName realName realClass | 332469 332470 Smalltalk garbageCollect; garbageCollect. 332471 332472 Preference allInstances do: [:each | 332473 informee := each instVarNamed: #changeInformee. 332474 ((informee isKindOf: Behavior) 332475 and: [informee isObsolete]) 332476 ifTrue: [ 332477 Transcript show: 'Preference: '; show: each name; cr. 332478 each instVarNamed: #changeInformee put: (Smalltalk at: (informee name copyReplaceAll: 'AnObsolete' with: '') asSymbol)]]. 332479 332480 CompiledMethod allInstances do: [:method | 332481 obsoleteBindings := method literals select: [:literal | 332482 literal isVariableBinding 332483 and: [literal value isBehavior] 332484 and: [literal value isObsolete]]. 332485 obsoleteBindings do: [:binding | 332486 obsName := binding value name. 332487 Transcript show: 'Binding: '; show: obsName; cr. 332488 realName := obsName copyReplaceAll: 'AnObsolete' with: ''. 332489 realClass := Smalltalk at: realName asSymbol ifAbsent: [UndefinedObject]. 332490 binding key: binding key value: realClass]]. 332491 332492 332493 Behavior flushObsoleteSubclasses. 332494 Smalltalk garbageCollect; garbageCollect. 332495 332496 332497 332498! ! 332499 332500 332501!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:24'! 332502changeImageNameTo: aString 332503 332504 self imageName: aString asSqueakPathName. 332505 LastImageName := self imageName! ! 332506 332507!SmalltalkImage methodsFor: 'image, changes names' stamp: 'bf 1/12/2006 19:43'! 332508changesName 332509 "Answer the name for the changes file corresponding to the image file name." 332510 "Smalltalk changesName" 332511 332512 | imName | 332513 imName := FileDirectory baseNameFor: self imageName. 332514 ^ imName, FileDirectory dot, 'changes'! ! 332515 332516!SmalltalkImage methodsFor: 'image, changes names' stamp: 'em 3/31/2005 11:48'! 332517currentChangeSetString 332518 "SmalltalkImage current currentChangeSetString" 332519 ^ 'Current Change Set: ' translated, ChangeSet current name! ! 332520 332521!SmalltalkImage methodsFor: 'image, changes names' stamp: 'nice 5/11/2009 23:30'! 332522fullNameForChangesNamed: aName 332523 | imgName | 332524 imgName := self fullNameForImageNamed: aName. 332525 ^FileDirectory fileName: (FileDirectory baseNameFor: imgName) extension: FileDirectory changeSuffix.! ! 332526 332527!SmalltalkImage methodsFor: 'image, changes names' stamp: 'nice 5/11/2009 23:33'! 332528fullNameForImageNamed: aName 332529 | imgDir | 332530 imgDir := FileDirectory on: self imagePath. 332531 ^FileDirectory fileName: (imgDir fullNameFor: aName) extension: FileDirectory imageSuffix.! ! 332532 332533!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:24'! 332534imageName 332535 "Answer the full path name for the current image." 332536 "SmalltalkImage current imageName" 332537 332538 | str | 332539 str := self primImageName. 332540 ^ (FilePath pathName: str isEncoded: true) asSqueakPathName. 332541! ! 332542 332543!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 2/24/2005 18:34'! 332544imageName: newName 332545 "Set the the full path name for the current image. All further snapshots will use this." 332546 332547 | encoded | 332548 encoded := (FilePath pathName: newName isEncoded: false) asVmPathName. 332549 self primImageName: encoded. 332550! ! 332551 332552!SmalltalkImage methodsFor: 'image, changes names' stamp: 'sd 11/16/2003 13:57'! 332553imagePath 332554 "Answer the path for the directory containing the image file." 332555 "SmalltalkImage current imagePath" 332556 332557 ^ FileDirectory dirPathFor: self imageName 332558! ! 332559 332560!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:23'! 332561primImageName 332562 "Answer the full path name for the current image." 332563 "SmalltalkImage current imageName" 332564 332565 <primitive: 121> 332566 self primitiveFailed! ! 332567 332568!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:30'! 332569primImageName: newName 332570 "Set the the full path name for the current image. All further snapshots will use this." 332571 332572 <primitive: 121> 332573 ^ self primitiveFailed! ! 332574 332575!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:35'! 332576primVmPath 332577 "Answer the path for the directory containing the Smalltalk virtual machine. Return the empty string if this primitive is not implemented." 332578 "SmalltalkImage current vmPath" 332579 332580 <primitive: 142> 332581 ^ ''! ! 332582 332583!SmalltalkImage methodsFor: 'image, changes names' stamp: 'sd 9/24/2003 12:43'! 332584sourceFileVersionString 332585 332586 ^ SourceFileVersionString! ! 332587 332588!SmalltalkImage methodsFor: 'image, changes names' stamp: 'sd 9/24/2003 12:44'! 332589sourcesName 332590 "Answer the full path to the version-stable source code" 332591 ^ self vmPath , SourceFileVersionString , FileDirectory dot , 'sources'! ! 332592 332593!SmalltalkImage methodsFor: 'image, changes names' stamp: 'yo 7/2/2004 13:36'! 332594vmPath 332595 "Answer the path for the directory containing the Smalltalk virtual machine. Return the empty string if this primitive is not implemented." 332596 "SmalltalkImage current vmPath" 332597 332598 ^ (FilePath pathName: (self primVmPath) isEncoded: true) asSqueakPathName. 332599! ! 332600 332601 332602!SmalltalkImage methodsFor: 'modules' stamp: 'dvf 6/30/2005 12:11'! 332603forgetModule: aString 332604 "Primitive. If the module named aString is loaded, unloaded. If not, and it is marked an unloadable, unmark it so the VM will try to load it again next time. See comment for #unloadModule:." 332605 <primitive: 571> 332606 ^self primitiveFailed! ! 332607 332608!SmalltalkImage methodsFor: 'modules' stamp: 'sd 6/27/2003 23:47'! 332609listBuiltinModule: index 332610 "Return the name of the n-th builtin module. 332611 This list is not sorted!!" 332612 <primitive: 572> 332613 ^self primitiveFailed! ! 332614 332615!SmalltalkImage methodsFor: 'modules' stamp: 'PeterHugossonMiller 9/3/2009 11:22'! 332616listBuiltinModules 332617 "SmalltalkImage current listBuiltinModules" 332618 "Return a list of all builtin modules (e.g., plugins). Builtin plugins are those that are compiled with the VM directly, as opposed to plugins residing in an external shared library. The list will include all builtin plugins regardless of whether they are currently loaded 332619 or not. Note that the list returned is not sorted!!" 332620 332621 | modules index name | 332622 modules := Array new writeStream. 332623 index := 1. 332624 [true] whileTrue:[ 332625 name := self listBuiltinModule: index. 332626 name ifNil:[^modules contents]. 332627 modules nextPut: name. 332628 index := index + 1. 332629 ].! ! 332630 332631!SmalltalkImage methodsFor: 'modules' stamp: 'sd 6/27/2003 23:48'! 332632listLoadedModule: index 332633 "Return the name of the n-th loaded module. 332634 This list is not sorted!!" 332635 <primitive: 573> 332636 ^self primitiveFailed! ! 332637 332638!SmalltalkImage methodsFor: 'modules' stamp: 'PeterHugossonMiller 9/3/2009 11:22'! 332639listLoadedModules 332640 "SmalltalkImage current listLoadedModules" 332641 "Return a list of all currently loaded modules (e.g., plugins). Loaded modules are those that currently in use (e.g., active). The list returned will contain all currently active modules regardless of whether they're builtin (that is compiled with the VM) or external (e.g., residing in some external shared library). Note that the returned list is not sorted!!" 332642 | modules index name | 332643 modules := Array new writeStream. 332644 index := 1. 332645 [true] whileTrue:[ 332646 name := self listLoadedModule: index. 332647 name ifNil:[^modules contents]. 332648 modules nextPut: name. 332649 index := index + 1. 332650 ].! ! 332651 332652!SmalltalkImage methodsFor: 'modules' stamp: 'sd 6/27/2003 23:49'! 332653unloadModule: aString 332654 "Primitive. Unload the given module. 332655 This primitive is intended for development only since some 332656 platform do not implement unloading of DLL's accordingly. 332657 Also, the mechanism for unloading may not be supported 332658 on all platforms." 332659 <primitive: 571> 332660 ^self primitiveFailed! ! 332661 332662 332663!SmalltalkImage methodsFor: 'preferences' stamp: 'laza 12/6/2004 13:55'! 332664setPlatformPreferences 332665 "Set some platform specific preferences on system startup" 332666 | platform specs | 332667 Preferences automaticPlatformSettings ifFalse:[^self]. 332668 platform := self platformName. 332669 specs := #( 332670 (soundStopWhenDone false) 332671 (soundQuickStart false) 332672 ). 332673 platform = 'Win32' ifTrue:[ 332674 specs := #( 332675 (soundStopWhenDone true) 332676 (soundQuickStart false) 332677 )]. 332678 platform = 'Mac OS' ifTrue:[ 332679 specs := #( 332680 (soundStopWhenDone false) 332681 (soundQuickStart true) 332682 )]. 332683 specs do:[:tuple| 332684 Preferences setPreference: tuple first toValue: (tuple last == true). 332685 ]. 332686! ! 332687 332688 332689!SmalltalkImage methodsFor: 'quit' stamp: 'sd 6/28/2003 17:32'! 332690quitPrimitive 332691 "Primitive. Exit to another operating system on the host machine, if one 332692 exists. All state changes in the object space since the last snapshot are lost. 332693 Essential. See Object documentation whatIsAPrimitive." 332694 332695 <primitive: 113> 332696 self primitiveFailed! ! 332697 332698 332699!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'DamienCassou 9/29/2009 13:11'! 332700getFileNameFromUser 332701 332702 | newName | 332703 newName := UIManager default 332704 request: 'New File Name?' translated 332705 initialAnswer: (FileDirectory localNameFor: self imageName). 332706 newName isEmptyOrNil ifTrue: [^nil]. 332707 ((FileDirectory default fileOrDirectoryExists: (self fullNameForImageNamed: newName)) or: 332708 [FileDirectory default fileOrDirectoryExists: (self fullNameForChangesNamed: newName)]) ifTrue: [ 332709 (self confirm: ('{1} already exists. Overwrite?' translated format: {newName})) ifFalse: [^nil]]. 332710 ^newName 332711! ! 332712 332713!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'bf 1/12/2006 19:20'! 332714recordStartupStamp 332715 332716 StartupStamp := '----STARTUP----', Time dateAndTimeNow printString, ' as ', self imageName. 332717! ! 332718 332719!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'sd 11/16/2003 14:12'! 332720saveSession 332721 self snapshot: true andQuit: false! ! 332722 332723!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'sd 11/16/2003 14:20'! 332724shutDown 332725 332726 ^ self closeSourceFiles! ! 332727 332728!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'sd 11/16/2003 14:12'! 332729snapshot: save andQuit: quit 332730 ^self snapshot: save andQuit: quit embedded: false! ! 332731 332732!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'pavel.krivanek 11/21/2008 16:38'! 332733snapshot: save andQuit: quit embedded: embeddedFlag 332734 "Mark the changes file and close all files as part of #processShutdownList. 332735 If save is true, save the current state of this Smalltalk in the image file. 332736 If quit is true, then exit to the outer OS shell. 332737 The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." 332738 | resuming msg | 332739 Object flushDependents. 332740 Object flushEvents. 332741 332742 (SourceFiles at: 2) ifNotNil:[ 332743 msg := String streamContents: [ :s | 332744 s nextPutAll: '----'; 332745 nextPutAll: (save ifTrue: [ quit ifTrue: [ 'QUIT' ] ifFalse: [ 'SNAPSHOT' ] ] 332746 ifFalse: [quit ifTrue: [ 'QUIT/NOSAVE' ] ifFalse: [ 'NOP' ]]); 332747 nextPutAll: '----'; 332748 print: Date dateAndTimeNow; space; 332749 nextPutAll: (FileDirectory default localNameFor: self imageName); 332750 nextPutAll: ' priorSource: '; 332751 print: LastQuitLogPosition ]. 332752 self assureStartupStampLogged. 332753 save ifTrue: [ LastQuitLogPosition := (SourceFiles at: 2) setToEnd; position ]. 332754 self logChange: msg. 332755 Transcript cr; show: msg 332756 ]. 332757 332758 Smalltalk processShutDownList: quit. 332759 Cursor write show. 332760 save ifTrue: [resuming := embeddedFlag 332761 ifTrue: [self snapshotEmbeddedPrimitive] 332762 ifFalse: [self snapshotPrimitive]. "<-- PC frozen here on image file" 332763 resuming == false "guard against failure" ifTrue: 332764 ["Time to reclaim segment files is immediately after a save" 332765 Smalltalk at: #ImageSegment 332766 ifPresent: [:theClass | theClass reclaimObsoleteSegmentFiles]]] 332767 ifFalse: [resuming := false]. 332768 quit & (resuming == false) ifTrue: [self quitPrimitive]. 332769 Cursor normal show. 332770 Smalltalk setGCParameters. 332771 resuming == true ifTrue: [Smalltalk clearExternalObjects]. 332772 Smalltalk processStartUpList: resuming == true. 332773 resuming == true ifTrue:[ 332774 self setPlatformPreferences. 332775 self recordStartupStamp]. 332776 332777 UIManager default onSnapshot. 332778 332779 "Now it's time to raise an error" 332780 resuming == nil ifTrue: [self error:'Failed to write image file (disk full?)']. 332781 ^ resuming! ! 332782 332783!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'sd 11/16/2003 13:58'! 332784snapshotEmbeddedPrimitive 332785 <primitive: 247> 332786 ^nil "indicates error writing embedded image file"! ! 332787 332788!SmalltalkImage methodsFor: 'snapshot and quit' stamp: 'sd 11/16/2003 13:59'! 332789snapshotPrimitive 332790 "Primitive. Write the current state of the object memory on a file in the 332791 same format as the Smalltalk-80 release. The file can later be resumed, 332792 returning you to this exact state. Return normally after writing the file. 332793 Essential. See Object documentation whatIsAPrimitive." 332794 332795 <primitive: 97> 332796 ^nil "indicates error writing image file"! ! 332797 332798 332799!SmalltalkImage methodsFor: 'sources, change log' stamp: 'ar 4/10/2005 18:02'! 332800logChange: aStringOrText 332801 "Write the argument, aString, onto the changes file." 332802 | aString changesFile | 332803 (SourceFiles isNil or: [(SourceFiles at: 2) == nil]) ifTrue: [^ self]. 332804 self assureStartupStampLogged. 332805 332806 aString := aStringOrText asString. 332807 (aString findFirst: [:char | char isSeparator not]) = 0 332808 ifTrue: [^ self]. "null doits confuse replay" 332809 (changesFile := SourceFiles at: 2). 332810 changesFile isReadOnly ifTrue:[^self]. 332811 changesFile setToEnd; cr; cr. 332812 changesFile nextChunkPut: aString. 332813 "If want style changes in DoIt, use nextChunkPutWithStyle:, and allow Texts to get here" 332814 self forceChangesToDisk.! ! 332815 332816 332817!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'alain.plantec 5/12/2009 12:24'! 332818aboutThisSystem 332819 "Identify software version" 332820 | text dialog width | 332821 text := SmalltalkImage current systemInformationString withCRs. 332822 width := 0. 332823 text linesDo: [:l | width := width max: (UITheme current textFont widthOfStringOrText: l)]. 332824 dialog := LongMessageDialogWindow new entryText: text. 332825 dialog open. 332826 dialog width: (width + 120 min: Display width - 50)! ! 332827 332828!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'NS 1/16/2004 15:34'! 332829assureStartupStampLogged 332830 "If there is a startup stamp not yet actually logged to disk, do it now." 332831 | changesFile | 332832 StartupStamp ifNil: [^ self]. 332833 (SourceFiles isNil or: [(changesFile := SourceFiles at: 2) == nil]) ifTrue: [^ self]. 332834 changesFile isReadOnly ifTrue:[^self]. 332835 changesFile setToEnd; cr; cr. 332836 changesFile nextChunkPut: StartupStamp asString; cr. 332837 StartupStamp := nil. 332838 self forceChangesToDisk.! ! 332839 332840!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'sd 11/16/2003 13:12'! 332841closeSourceFiles 332842 "Shut down the source files if appropriate. 1/29/96 sw: changed so that the closing and nilification only take place if the entry was a FileStream, thus allowing stringified sources to remain in the saved image file" 332843 332844 1 to: 2 do: [:i | 332845 ((SourceFiles at: i) isKindOf: FileStream) 332846 ifTrue: 332847 [(SourceFiles at: i) close. 332848 SourceFiles at: i put: nil]]! ! 332849 332850!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'nk 7/29/2004 10:03'! 332851datedVersion 332852 "Answer the version of this release." 332853 332854 ^SystemVersion current datedVersion! ! 332855 332856!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'NS 1/27/2004 15:55'! 332857event: anEvent 332858 "Hook for SystemChangeNotifier" 332859 332860 (anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [ 332861 anEvent item acceptsLoggingOfCompilation 332862 ifTrue: [self logChange: 'Smalltalk removeClassNamed: #' , anEvent item name]. 332863 ]. 332864 anEvent isDoIt 332865 ifTrue: [self logChange: anEvent item]. 332866 (anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue: [ 332867 anEvent itemClass acceptsLoggingOfCompilation 332868 ifTrue: [self logChange: anEvent itemClass name , ' removeSelector: #' , anEvent itemSelector]].! ! 332869 332870!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'NS 1/16/2004 15:35'! 332871forceChangesToDisk 332872 "Ensure that the changes file has been fully written to disk by closing and re-opening it. This makes the system more robust in the face of a power failure or hard-reboot." 332873 332874 | changesFile | 332875 changesFile := SourceFiles at: 2. 332876 (changesFile isKindOf: FileStream) ifTrue: [ 332877 changesFile flush. 332878 SecurityManager default hasFileAccess ifTrue:[ 332879 changesFile close. 332880 changesFile open: changesFile name forWrite: true]. 332881 changesFile setToEnd. 332882 ]. 332883! ! 332884 332885!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'sd 11/16/2003 14:02'! 332886lastQuitLogPosition 332887 ^ LastQuitLogPosition! ! 332888 332889!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'sd 11/16/2003 14:03'! 332890lastQuitLogPosition: aNumber 332891 "should be only use to ensure the transition from SystemDictionary to SmalltalkImage, then be removed" 332892 332893 LastQuitLogPosition := aNumber! ! 332894 332895!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'al 10/12/2008 21:04'! 332896lastUpdateString 332897 "SmalltalkImage current lastUpdateString" 332898 ^'Latest update: #' translated, SystemVersion current highestUpdate printString! ! 332899 332900!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'al 10/12/2008 21:03'! 332901licenseString 332902 ^ 'LICENSE 332903 332904Licensed under the MIT License with parts under the Apache License. 332905 332906Copyright (c) Pharo Project, and Contributors Copyright (c) 1996-2008 Viewpoints 332907Research Institute, and Contributors Copyright (c) 1996 Apple Computer, Inc. 332908 332909Permission is hereby granted, free of charge, to any person obtaining a copy of this 332910software and associated documentation files (the "Software"), to deal in the Software 332911without restriction, including without limitation the rights to use, copy, modify, merge, 332912publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons 332913to whom the Software is furnished to do so, subject to the following conditions: The 332914above copyright notice and this permission notice shall be included in all copies or 332915substantial portions of the Software. 332916 332917THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 332918IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 332919FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS 332920OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 332921WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 332922CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 332923 332924You may obtain a copy of the Apache License at 332925http://www.apache.org/licenses/LICENSE-2.0'! ! 332926 332927!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'MiguelCoba 7/25/2009 02:13'! 332928openSourceFiles 332929 332930 self imageName = LastImageName ifFalse: 332931 ["Reset the author full name to blank when the image gets moved" 332932 LastImageName := self imageName. 332933 Author fullName: '']. 332934 FileDirectory 332935 openSources: self sourcesName 332936 andChanges: self changesName 332937 forImage: LastImageName. 332938 StandardSourceFileArray install! ! 332939 332940!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'kph 1/29/2007 00:52'! 332941saveAs 332942 332943 "Put up the 'saveAs' prompt, obtain a name, and save the image under that new name." 332944 332945 self saveAs: self getFileNameFromUser! ! 332946 332947!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'nice 5/12/2009 00:13'! 332948saveAs: newName 332949 newName ifNil: [ ^ self ]. 332950 (SourceFiles at: 2) ifNotNil: 332951 [self closeSourceFiles; "so copying the changes file will always work" 332952 saveChangesInFileNamed: (self fullNameForChangesNamed: newName)]. 332953 ^self saveImageInFileNamed: (self fullNameForImageNamed: newName)! ! 332954 332955!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'DamienCassou 9/29/2009 13:11'! 332956saveAsEmbeddedImage 332957 "Save the current state of the system as an embedded image" 332958 332959 | dir newName newImageName newImageSegDir oldImageSegDir haveSegs | 332960 dir := FileDirectory default. 332961 newName := UIManager default request: 'Select existing VM file' 332962 initialAnswer: (FileDirectory localNameFor: ''). 332963 newName isEmptyOrNil ifTrue: [^Smalltalk]. 332964 newName := FileDirectory baseNameFor: newName asFileName. 332965 newImageName := newName. 332966 (dir includesKey: newImageName) 332967 ifFalse: 332968 [^self 332969 inform: 'Unable to find name ' , newName , ' Please choose another name.']. 332970 haveSegs := false. 332971 Smalltalk at: #ImageSegment 332972 ifPresent: 332973 [:theClass | 332974 (haveSegs := theClass instanceCount ~= 0) 332975 ifTrue: [oldImageSegDir := theClass segmentDirectory]]. 332976 self logChange: '----SAVEAS (EMBEDDED) ' , newName , '----' 332977 , Date dateAndTimeNow printString. 332978 self imageName: (dir fullNameFor: newImageName) asSqueakPathName. 332979 LastImageName := self imageName. 332980 self closeSourceFiles. 332981 haveSegs 332982 ifTrue: 332983 [Smalltalk at: #ImageSegment 332984 ifPresent: 332985 [:theClass | 332986 newImageSegDir := theClass segmentDirectory. "create the folder" 332987 oldImageSegDir fileNames do: 332988 [:theName | 332989 "copy all segment files" 332990 332991 newImageSegDir 332992 copyFileNamed: oldImageSegDir pathName , FileDirectory slash , theName 332993 toFileNamed: theName]]]. 332994 self 332995 snapshot: true 332996 andQuit: true 332997 embedded: true! ! 332998 332999!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'stephane.ducasse 3/1/2009 08:48'! 333000saveAsNewVersion 333001 "Save the image/changes using the next available version number." 333002 "SmalltalkImage current saveAsNewVersion" 333003 333004 | newName changesName aName anIndex | 333005 aName := FileDirectory baseNameFor: (FileDirectory default localNameFor: self imageName). 333006 anIndex := aName lastIndexOf: FileDirectory extensionDelimiter ifAbsent: [nil]. 333007 (anIndex notNil and: [(aName copyFrom: anIndex + 1 to: aName size) isAllDigits]) 333008 ifTrue: 333009 [aName := aName copyFrom: 1 to: anIndex - 1]. 333010 333011 newName := FileDirectory default nextNameFor: aName extension: FileDirectory imageSuffix. 333012 changesName := self fullNameForChangesNamed: newName. 333013 333014 "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" 333015 (FileDirectory default fileOrDirectoryExists: changesName) 333016 ifTrue: 333017 [^ self inform: 333018'There is already .changes file of the desired name, 333019', newName, ' 333020curiously already present, even though there is 333021no corresponding .image file. Please remedy 333022manually and then repeat your request.']. 333023 333024 ^self saveAs: newName 333025 333026 333027! ! 333028 333029!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'tpr 12/15/2003 16:01'! 333030saveChangesInFileNamed: aString 333031 | fullChangesName | 333032 fullChangesName := (FileDirectory default fullNameFor: aString). 333033 (FileDirectory default directoryNamed:(FileDirectory dirPathFor: fullChangesName )) assureExistence. 333034 FileDirectory default 333035 copyFileWithoutOverwriteConfirmationNamed: SmalltalkImage current changesName 333036 toFileNamed: fullChangesName. 333037 Smalltalk setMacFileInfoOn: fullChangesName.! ! 333038 333039!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'mtf 6/9/2008 21:29'! 333040saveImageInFileNamed: aString 333041 | fullImageName | 333042 fullImageName := (FileDirectory default fullNameFor: aString). 333043 (FileDirectory default directoryNamed:(FileDirectory dirPathFor: fullImageName )) assureExistence. 333044 ^self 333045 changeImageNameTo: fullImageName; 333046 closeSourceFiles; 333047 openSourceFiles; "so SNAPSHOT appears in new changes file" 333048 saveImageSegments; 333049 snapshot: true andQuit: false! ! 333050 333051!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'sd 11/16/2003 13:29'! 333052saveImageSegments 333053 333054 | haveSegs oldImageSegDir newImageSegDir | 333055 haveSegs := false. 333056 Smalltalk at: #ImageSegment ifPresent: [:theClass | 333057 (haveSegs := theClass instanceCount ~= 0) ifTrue: [ 333058 oldImageSegDir := theClass segmentDirectory]]. 333059 haveSegs ifTrue: [ 333060 Smalltalk at: #ImageSegment ifPresent: [:theClass | 333061 newImageSegDir := theClass segmentDirectory. "create the folder" 333062 oldImageSegDir fileNames do: [:theName | "copy all segment files" 333063 | imageSegmentName | 333064 imageSegmentName := oldImageSegDir pathName, FileDirectory slash, theName. 333065 newImageSegDir 333066 copyFileWithoutOverwriteConfirmationNamed: imageSegmentName 333067 toFileNamed: theName]]]. 333068! ! 333069 333070!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'al 10/12/2008 21:05'! 333071systemInformationString 333072 ^ String cr, SystemVersion current version, String cr, self lastUpdateString, String cr, String cr, String cr, self licenseString! ! 333073 333074!SmalltalkImage methodsFor: 'sources, changes log' stamp: 'nk 7/29/2004 10:09'! 333075timeStamp: aStream 333076 "Writes system version and current time on stream aStream." 333077 333078 | dateTime | 333079 dateTime := Time dateAndTimeNow. 333080 aStream nextPutAll: 'From ', SmalltalkImage current datedVersion, ' [', SmalltalkImage current lastUpdateString, '] on ', (dateTime at: 1) printString, 333081 ' at ', (dateTime at: 2) printString! ! 333082 333083 333084!SmalltalkImage methodsFor: 'system attribute' stamp: 'sd 9/24/2003 11:40'! 333085extractParameters 333086 333087 | pName value index globals | 333088 globals := Dictionary new. 333089 index := 3. "Muss bei 3 starten, da 2 documentName ist" 333090 [pName := self getSystemAttribute: index. 333091 pName isEmptyOrNil] whileFalse:[ 333092 index := index + 1. 333093 value := self getSystemAttribute: index. 333094 value ifNil: [value := '']. 333095 globals at: pName asUppercase put: value. 333096 index := index + 1]. 333097 ^globals! ! 333098 333099!SmalltalkImage methodsFor: 'system attribute' stamp: 'md 10/26/2003 13:08'! 333100getSystemAttribute: attributeID 333101 "Optional. Answer the string for the system attribute with the given 333102 integer ID. Answer nil if the given attribute is not defined on this 333103 platform. On platforms that support invoking programs from command 333104 lines (e.g., Unix), this mechanism can be used to pass command line 333105 arguments to programs written in Squeak. 333106 333107 By convention, the first command line argument that is not a VM 333108 configuration option is considered a 'document' to be filed in. Such a 333109 document can add methods and classes, can contain a serialized object, 333110 can include code to be executed, or any combination of these. 333111 333112 Currently defined attributes include: 333113 -1000...-1 - command line arguments that specify VM options 333114 0 - the full path name for currently executing VM 333115 (or, on some platforms, just the path name of the VM's directory) 333116 1 - full path name of this image 333117 2 - a Squeak document to open, if any 333118 3...1000 - command line arguments for Squeak programs 333119 1001 - this platform's operating system 333120 1002 - operating system version 333121 1003 - this platform's processor type 333122 1004 - vm version" 333123 333124 <primitive: 149> 333125 ^ nil! ! 333126 333127!SmalltalkImage methodsFor: 'system attribute' stamp: 'dtl 8/5/2006 09:48'! 333128osVersion 333129 "Return the version number string of the platform we're running on" 333130 "SmalltalkImage current osVersion" 333131 333132 ^(self getSystemAttribute: 1002) asString! ! 333133 333134!SmalltalkImage methodsFor: 'system attribute' stamp: 'sd 6/27/2003 23:38'! 333135platformName 333136 "Return the name of the platform we're running on" 333137 333138 ^self getSystemAttribute: 1001! ! 333139 333140!SmalltalkImage methodsFor: 'system attribute' stamp: 'sd 6/27/2003 23:43'! 333141platformSubtype 333142 "Return the subType of the platform we're running on" 333143 333144 ^self getSystemAttribute: 1003! ! 333145 333146!SmalltalkImage methodsFor: 'system attribute' stamp: 'dtl 8/5/2006 09:47'! 333147vmVersion 333148 "Return a string identifying the interpreter version" 333149 "SmalltalkImage current vmVersion" 333150 333151 ^self getSystemAttribute: 1004! ! 333152 333153 333154!SmalltalkImage methodsFor: 'testing' stamp: 'Gwenael.Casaccio 2/2/2009 10:50'! 333155hasDisplay 333156 333157 | arg i | 333158 i := -1. 333159 [(arg := SmalltalkImage current getSystemAttribute: i) isNil] 333160 whileFalse: [(#('-nodisplay' '-headless') includes: arg) ifTrue: [^ false]. 333161 i := i - 1]. 333162 ^ true! ! 333163 333164 333165!SmalltalkImage methodsFor: 'utilities' stamp: 'sd 1/16/2004 20:54'! 333166stripMethods: tripletList messageCode: messageString 333167 "Used to 'cap' methods that need to be protected for proprietary reasons, etc.; call this with a list of triplets of symbols of the form (<class name> <#instance or #class> <selector name>), and with a string to be produced as part of the error msg if any of the methods affected is reached" 333168 333169 | aClass sel keywords codeString | 333170 tripletList do: 333171 [:triplet | 333172 (aClass := (Smalltalk at: triplet first ifAbsent: [nil])) notNil ifTrue: 333173 [triplet second == #class ifTrue: 333174 [aClass := aClass class]. 333175 sel := triplet third. 333176 keywords := sel keywords. 333177 (keywords size == 1 and: [keywords first asSymbol isKeyword not]) 333178 ifTrue: 333179 [codeString := keywords first asString] 333180 ifFalse: 333181 [codeString := ''. 333182 keywords withIndexDo: 333183 [:kwd :index | 333184 codeString := codeString, ' ', (keywords at: index), ' ', 333185 'arg', index printString]]. 333186 codeString := codeString, ' 333187 self codeStrippedOut: ', (messageString surroundedBySingleQuotes). 333188 333189 aClass compile: codeString classified: 'stripped']]! ! 333190 333191 333192!SmalltalkImage methodsFor: 'vm parameters' stamp: 'sd 6/27/2003 23:27'! 333193extraVMMemory 333194 "Answer the current setting of the 'extraVMMemory' VM parameter. See the comment in extraVMMemory: for details." 333195 333196 ^ self vmParameterAt: 23 333197! ! 333198 333199!SmalltalkImage methodsFor: 'vm parameters' stamp: 'sd 6/27/2003 23:27'! 333200extraVMMemory: extraBytesToReserve 333201 "Request that the given amount of extra memory be reserved for use by the virtual machine to leave extra C heap space available for things like plugins, network and file buffers, and so on. This request is stored when the image is saved and honored when the image is next started up. Answer the previous value of this parameter." 333202 333203 extraBytesToReserve < 0 333204 ifTrue: [self error: 'VM memory reservation must be non-negative']. 333205 ^ self vmParameterAt: 23 put: extraBytesToReserve 333206! ! 333207 333208!SmalltalkImage methodsFor: 'vm parameters' stamp: 'sd 6/27/2003 23:47'! 333209getVMParameters 333210 "Answer an Array containing the current values of the VM's internal 333211 parameter/metric registers. Each value is stored in the array at the 333212 index corresponding to its VM register. (See #vmParameterAt: and 333213 #vmParameterAt:put:.)" 333214 "SmalltalkImage current getVMParameters" 333215 333216 <primitive: 254> 333217 self primitiveFailed! ! 333218 333219!SmalltalkImage methodsFor: 'vm parameters' stamp: 'tpr 4/27/2005 11:03'! 333220vmParameterAt: parameterIndex 333221 "parameterIndex is a positive integer corresponding to one of the VM's internal 333222 parameter/metric registers. Answer with the current value of that register. 333223 Fail if parameterIndex has no corresponding register. 333224 VM parameters are numbered as follows: 333225 1 end of old-space (0-based, read-only) 333226 2 end of young-space (read-only) 333227 3 end of memory (read-only) 333228 4 allocationCount (read-only) 333229 5 allocations between GCs (read-write) 333230 6 survivor count tenuring threshold (read-write) 333231 7 full GCs since startup (read-only) 333232 8 total milliseconds in full GCs since startup (read-only) 333233 9 incremental GCs since startup (read-only) 333234 10 total milliseconds in incremental GCs since startup (read-only) 333235 11 tenures of surving objects since startup (read-only) 333236 12-20 specific to the translating VM 333237 21 root table size (read-only) 333238 22 root table overflows since startup (read-only) 333239 23 bytes of extra memory to reserve for VM buffers, plugins, etc. 333240 333241 24 memory threshold above which shrinking object memory (rw) 333242 25 memory headroom when growing object memory (rw) 333243 26 interruptChecksEveryNms - force an ioProcessEvents every N milliseconds, in case the image is not calling getNextEvent often (rw) 333244 27 number of times mark loop iterated for current IGC/FGC (read-only) includes ALL marking 333245 28 number of times sweep loop iterated for current IGC/FGC (read-only) 333246 29 number of times make forward loop iterated for current IGC/FGC (read-only) 333247 30 number of times compact move loop iterated for current IGC/FGC (read-only) 333248 31 number of grow memory requests (read-only) 333249 32 number of shrink memory requests (read-only) 333250 33 number of root table entries used for current IGC/FGC (read-only) 333251 34 number of allocations done before current IGC/FGC (read-only) 333252 35 number of survivor objects after current IGC/FGC (read-only) 333253 36 millisecond clock when current IGC/FGC completed (read-only) 333254 37 number of marked objects for Roots of the world, not including Root Table entries for current IGC/FGC (read-only) 333255 38 milliseconds taken by current IGC (read-only) 333256 39 Number of finalization signals for Weak Objects pending when current IGC/FGC completed (read-only) 333257 40 VM word size - 4 or 8 (read-only)" 333258 333259 <primitive: 254> 333260 self primitiveFailed! ! 333261 333262!SmalltalkImage methodsFor: 'vm parameters' stamp: 'sd 6/27/2003 23:27'! 333263vmParameterAt: parameterIndex put: newValue 333264 "parameterIndex is a positive integer corresponding to one of the VM's internal 333265 parameter/metric registers. Store newValue (a positive integer) into that 333266 register and answer with the previous value that was stored there. 333267 Fail if newValue is out of range, if parameterIndex has no corresponding 333268 register, or if the corresponding register is read-only." 333269 333270 <primitive: 254> 333271 self primitiveFailed! ! 333272 333273 333274!SmalltalkImage methodsFor: 'vm statistics' stamp: 'stephane.ducasse 8/5/2009 17:44'! 333275reportCPUandRAM 333276 "Write several text files with useful analysis for profiling purposes. 333277 Overwrites any existing report. 333278 SmalltalkImage current reportCPUandRAM 333279 " 333280 333281 | stream tally | 333282 "VM statistics (Memory use and GC, mainly)" 333283 stream := FileStream forceNewFileNamed: 'Log-MemoryStats.txt'. 333284 [ stream nextPutAll: self vmStatisticsReportString ] 333285 ensure: [ stream close ]. 333286 333287 "Process list" 333288 stream := FileStream forceNewFileNamed: 'Log-ProcessList.txt'. 333289 [ 333290 ProcessBrowser new processNameList 333291 do: [ :each | 333292 stream nextPutAll: each; cr ] 333293 ] ensure: [ stream close ]. 333294 333295"Fork all these, so they run in sequence, as the system is back running" 333296[ 333297 "Process taking most CPU" 333298 stream := FileStream forceNewFileNamed: 'Log-ThePig.txt'. 333299 ProcessBrowser dumpPigStackOn: stream andClose: true. 333300 333301 "Tally of all processes" 333302 stream := FileStream forceNewFileNamed: 'Log-FullTally.txt'. 333303 [ 333304 tally := MessageTally new. 333305 tally spyAllEvery: 1 on: [ (Delay forMilliseconds: 1000) wait ]. 333306 tally report: stream ] ensure: [ stream close ]. 333307 333308 "Memory Analysis" 333309 stream := FileStream forceNewFileNamed: 'Log-MemoryAnalysis.txt'. 333310 [ SpaceTally new printSpaceAnalysis: 1 on: stream ] 333311 ensure: [ stream close ] 333312 333313] forkNamed: 'CPU usage analysis'! ! 333314 333315!SmalltalkImage methodsFor: 'vm statistics' stamp: 'sd 7/2/2003 21:45'! 333316textMarkerForShortReport 333317 333318 ^ 'Since last view '! ! 333319 333320!SmalltalkImage methodsFor: 'vm statistics' stamp: 'PeterHugossonMiller 9/3/2009 11:22'! 333321vmStatisticsReportString 333322 "StringHolderView open: (StringHolder new contents: 333323 SmalltalkImage current vmStatisticsReportString) label: 'VM Statistics'" 333324 333325 | params oldSpaceEnd youngSpaceEnd memoryEnd fullGCs fullGCTime incrGCs incrGCTime tenureCount mcMisses mcHits icHits upTime sendCount upTime2 fullGCs2 fullGCTime2 incrGCs2 incrGCTime2 tenureCount2 str | 333326 params := self getVMParameters. 333327 oldSpaceEnd := params at: 1. 333328 youngSpaceEnd := params at: 2. 333329 memoryEnd := params at: 3. 333330 fullGCs := params at: 7. 333331 fullGCTime := params at: 8. 333332 incrGCs := params at: 9. 333333 incrGCTime := params at: 10. 333334 tenureCount := params at: 11. 333335 mcMisses := params at: 15. 333336 mcHits := params at: 16. 333337 icHits := params at: 17. 333338 upTime := Time millisecondClockValue. 333339 sendCount := mcMisses + mcHits + icHits. 333340 333341 str := (String new: 1000) writeStream. 333342 str nextPutAll: 'uptime '; 333343 print: (upTime / 1000 / 60 // 60); nextPut: $h; 333344 print: (upTime / 1000 / 60 \\ 60) asInteger; nextPut: $m; 333345 print: (upTime / 1000 \\ 60) asInteger; nextPut: $s; cr. 333346 333347 str nextPutAll: 'memory '; 333348 nextPutAll: memoryEnd asStringWithCommas; nextPutAll: ' bytes'; cr. 333349 str nextPutAll: ' old '; 333350 nextPutAll: oldSpaceEnd asStringWithCommas; nextPutAll: ' bytes ('; 333351 print: ((oldSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr. 333352 str nextPutAll: ' young '; 333353 nextPutAll: (youngSpaceEnd - oldSpaceEnd) asStringWithCommas; nextPutAll: ' bytes ('; 333354 print: ((youngSpaceEnd - oldSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr. 333355 str nextPutAll: ' used '; 333356 nextPutAll: youngSpaceEnd asStringWithCommas; nextPutAll: ' bytes ('; 333357 print: ((youngSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr. 333358 str nextPutAll: ' free '; 333359 nextPutAll: (memoryEnd - youngSpaceEnd) asStringWithCommas; nextPutAll: ' bytes ('; 333360 print: ((memoryEnd - youngSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr. 333361 333362 str nextPutAll: 'GCs '; 333363 nextPutAll: (fullGCs + incrGCs) asStringWithCommas. 333364 fullGCs + incrGCs > 0 ifTrue: [ 333365 str 333366 nextPutAll: ' ('; 333367 print: ((upTime / (fullGCs + incrGCs)) roundTo: 1); 333368 nextPutAll: 'ms between GCs)' 333369 ]. 333370 str cr. 333371 str nextPutAll: ' full '; 333372 print: fullGCs; nextPutAll: ' totalling '; nextPutAll: fullGCTime asStringWithCommas; nextPutAll: 'ms ('; 333373 print: ((fullGCTime / upTime * 100) roundTo: 1.0); 333374 nextPutAll: '% uptime)'. 333375 fullGCs = 0 ifFalse: 333376 [str nextPutAll: ', avg '; print: ((fullGCTime / fullGCs) roundTo: 1.0); nextPutAll: 'ms']. 333377 str cr. 333378 str nextPutAll: ' incr '; 333379 print: incrGCs; nextPutAll: ' totalling '; nextPutAll: incrGCTime asStringWithCommas; nextPutAll: 'ms ('; 333380 print: ((incrGCTime / upTime * 100) roundTo: 1.0); 333381 nextPutAll: '% uptime), avg '; print: ((incrGCTime / incrGCs) roundTo: 1.0); nextPutAll: 'ms'; cr. 333382 str nextPutAll: ' tenures '; 333383 nextPutAll: tenureCount asStringWithCommas. 333384 tenureCount = 0 ifFalse: 333385 [str nextPutAll: ' (avg '; print: (incrGCs / tenureCount) asInteger; nextPutAll: ' GCs/tenure)']. 333386 str cr. 333387 333388LastStats ifNil: [LastStats := Array new: 6] 333389ifNotNil: [ 333390 upTime2 := upTime - (LastStats at: 1). 333391 fullGCs2 := fullGCs - (LastStats at: 2). 333392 fullGCTime2 := fullGCTime - (LastStats at: 3). 333393 incrGCs2 := incrGCs - (LastStats at: 4). 333394 incrGCTime2 := incrGCTime - (LastStats at: 5). 333395 tenureCount2 := tenureCount - (LastStats at: 6). 333396 333397 str nextPutAll: self textMarkerForShortReport ; 333398 nextPutAll: (fullGCs2 + incrGCs2) asStringWithCommas. 333399 fullGCs2 + incrGCs2 > 0 ifTrue: [ 333400 str 333401 nextPutAll: ' ('; 333402 print: ((upTime2 / (fullGCs2 + incrGCs2)) roundTo: 1); 333403 nextPutAll: 'ms between GCs)'. 333404 ]. 333405 str cr. 333406 str nextPutAll: ' uptime '; print: ((upTime2 / 1000.0) roundTo: 0.1); nextPutAll: 's'; cr. 333407 str nextPutAll: ' full '; 333408 print: fullGCs2; nextPutAll: ' totalling '; nextPutAll: fullGCTime2 asStringWithCommas; nextPutAll: 'ms ('; 333409 print: ((fullGCTime2 / upTime2 * 100) roundTo: 1.0); 333410 nextPutAll: '% uptime)'. 333411 fullGCs2 = 0 ifFalse: 333412 [str nextPutAll: ', avg '; print: ((fullGCTime2 / fullGCs2) roundTo: 1.0); nextPutAll: 'ms']. 333413 str cr. 333414 str nextPutAll: ' incr '; 333415 print: incrGCs2; nextPutAll: ' totalling '; nextPutAll: incrGCTime2 asStringWithCommas; nextPutAll: 'ms ('; 333416 print: ((incrGCTime2 / upTime2 * 100) roundTo: 1.0); 333417 nextPutAll: '% uptime), avg '. 333418 incrGCs2 > 0 ifTrue: [ 333419 str print: ((incrGCTime2 / incrGCs2) roundTo: 1.0); nextPutAll: 'ms' 333420 ]. 333421 str cr. 333422 str nextPutAll: ' tenures '; 333423 nextPutAll: tenureCount2 asStringWithCommas. 333424 tenureCount2 = 0 ifFalse: 333425 [str nextPutAll: ' (avg '; print: (incrGCs2 / tenureCount2) asInteger; nextPutAll: ' GCs/tenure)']. 333426 str cr. 333427]. 333428 LastStats at: 1 put: upTime. 333429 LastStats at: 2 put: fullGCs. 333430 LastStats at: 3 put: fullGCTime. 333431 LastStats at: 4 put: incrGCs. 333432 LastStats at: 5 put: incrGCTime. 333433 LastStats at: 6 put: tenureCount. 333434 333435 sendCount > 0 ifTrue: [ 333436 str nextPutAll: 'sends '; 333437 nextPutAll: sendCount asStringWithCommas; cr. 333438 str nextPutAll: ' full '; 333439 nextPutAll: mcMisses asStringWithCommas; 333440 nextPutAll: ' ('; print: ((mcMisses / sendCount * 100) roundTo: 0.1); nextPutAll: '%)'; cr. 333441 str nextPutAll: ' m-cache '; 333442 nextPutAll: mcHits asStringWithCommas; 333443 nextPutAll: ' ('; print: ((mcHits / sendCount * 100) roundTo: 0.1); nextPutAll: '%)'; cr. 333444 str nextPutAll: ' i-cache '; 333445 nextPutAll: icHits asStringWithCommas; 333446 nextPutAll: ' ('; print: ((icHits / sendCount * 100) roundTo: 0.1); nextPutAll: '%)'; cr]. 333447 333448 333449 ^ str contents 333450! ! 333451 333452!SmalltalkImage methodsFor: 'vm statistics' stamp: 'dc 5/30/2008 10:17'! 333453vmStatisticsShortString 333454 "Convenience item for access to recent statistics only" 333455 "StringHolderView open: (StringHolder new contents: SmalltalkImage current vmStatisticsShortString) 333456 label: 'VM Recent Statistics'" 333457 ^ self vmStatisticsReportString readStream 333458 upToAll: 'Since'; 333459 upTo: Character cr; 333460 upToEnd! ! 333461 333462 333463!SmalltalkImage methodsFor: 'private source file' stamp: 'sd 9/24/2003 12:42'! 333464sourceFileVersionString: aString 333465 333466 SourceFileVersionString := aString! ! 333467 333468"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 333469 333470SmalltalkImage class 333471 instanceVariableNames: 'current'! 333472 333473!SmalltalkImage class methodsFor: 'initialization' stamp: 'yo 2/18/2004 18:26'! 333474initialize 333475" 333476 self initialize 333477" 333478 Smalltalk addToStartUpList: SmalltalkImage. 333479 SmalltalkImage startUp. 333480! ! 333481 333482!SmalltalkImage class methodsFor: 'initialization' stamp: 'yo 2/18/2004 18:25'! 333483startUp 333484 333485 EndianCache := nil. 333486! ! 333487 333488 333489!SmalltalkImage class methodsFor: 'instance creation' stamp: 'sd 9/30/2003 14:28'! 333490current 333491 "Note that this could be implemented differently to avoid the test" 333492 333493 current isNil 333494 ifTrue: [current := self basicNew]. 333495 ^ current! ! 333496 333497!SmalltalkImage class methodsFor: 'instance creation' stamp: 'sd 9/30/2003 13:39'! 333498new 333499 333500 self error: 'Use current'.! ! 333501TestCase subclass: #SmalltalkImageTest 333502 instanceVariableNames: '' 333503 classVariableNames: '' 333504 poolDictionaries: '' 333505 category: 'Tests-System'! 333506 333507!SmalltalkImageTest methodsFor: 'testing' stamp: 'nice 5/11/2009 23:47'! 333508testImageName 333509 "Non regression test for http://bugs.squeak.org/view.php?id=7351" 333510 | shortImgName fullImgName fullChgName | 333511 shortImgName := 'Squeak3.10.2-7179-basic'. 333512 fullImgName := SmalltalkImage current fullNameForImageNamed: shortImgName. 333513 fullChgName := SmalltalkImage current fullNameForChangesNamed: shortImgName. 333514 FileDirectory splitName: fullImgName to: [:path :name | 333515 self assert: path = SmalltalkImage current imagePath. 333516 self assert: name = 'Squeak3.10.2-7179-basic.image'.]. 333517 FileDirectory splitName: fullChgName to: [:path :name | 333518 self assert: path = SmalltalkImage current imagePath. 333519 self assert: name = 'Squeak3.10.2-7179-basic.changes'.].! ! 333520ReferenceStream subclass: #SmartRefStream 333521 instanceVariableNames: 'structures steady reshaped renamed renamedConv superclasses progressBar objCount classInstVars' 333522 classVariableNames: 'ScannedObject' 333523 poolDictionaries: '' 333524 category: 'System-Object Storage'! 333525!SmartRefStream commentStamp: '<historical>' prior: 0! 333526Ordinary ReferenceStreams assume that the names and order of instance variables is exactly the same when an object file is written and read. 333527 SmartRefStream allows object files to be read even after instance variables have changed or the entire class has been renamed. 333528 333529When an object file is written, no one knows how the classes will change in the future. Therefore, all conversion must be done when the file is read. The key is to store enough information in the file about the names of the instance variables of all outgoing classes. 333530 333531SmartRefStream works best with only one tree of objects per file. You can nextPut: more than once, but each object tree gets its own class structure description, which is big. 333532 333533Conversion of old objects is done by a method in each class called (convertToCurrentVersion: varDict refStream: smartRefStrm). At fileOut time, ChangeSet>>checkForConversionMethods creates a prototype of this method (if Preference #conversionMethodsAtFileOut is true). The programmer must edit this method to (1) test if the incoming object needs conversion, (2) put non-nil values into any new inst vars that need them, and (3) save the data of any inst vars that are being deleted. 333534 333535Determining which old version is represented by the incoming object can be done in several ways: noticing that a current inst var is nil when it should have data, noticing that there is an older inst var name in the variable dictionary (varDict), checking kinds of objects in one or more inst vars, or retrieving the classVersion of the incoming object from the ref stream. 333536 333537If a class is renamed, a method goes into SmartRefStream telling the new name. The conversion method of the new class must be prepared to accept instances of the old class also. If no inst var names have changed, the conversion method does nothing. 333538 333539An example: 333540 Suppose we change the representation of class Rectangle from ('origin' 'corner') to ('origin' 'extent'). Suppose lots of Rectangle instances are already out on files (in .pr project files, especially). 333541 The programmer changes the class definition, modifies all the methods, and filesOut. A series of dialogs appear, asking if instances Rectangle might be in an object file, if 'extent' needs to be non-nil (yes), and if the info in 'corner' needs to be preserved (yes). This method appears: 333542 333543Rectangle >> convertToCurrentVersion: varDict refStream: smartRefStrm 333544 "These variables are automatically stored into the new instance: #('origin'). 333545 Test for this particular conversion. Get values using expressions like (varDict at: 'foo')." 333546 333547 "New variables: #('extent'). If a non-nil value is needed, please assign it." 333548 "These are going away #('corner'). Possibly store their info in some other variable?" 333549 "Move your code above the ^ super... Delete extra comments." 333550 ^ super convertToCurrentVersion: varDict refStream: smartRefStrm 333551 333552The programmer modifies it to be: 333553 333554Rectangle >> convertToCurrentVersion: varDict refStream: smartRefStrm 333555 333556(varDict includesKey: 'extent') ifFalse: ["old version!!" 333557 "Create the new extent, and preserve the info from the old corner" 333558 extent _ (varDict at: 'corner') - origin. 333559 ]. 333560^ super convertToCurrentVersion: varDict refStream: smartRefStrm 333561 333562 This conversion method stays in the system and is ready to convert the old format of Rectangle whenever one is encountered in an object file. Note that the subclasses of Rectangle, (B3DViewport, CharacterBlock, and Quadrangle) do not need conversion methods. Their instances will be converted by the code in Rectangle. 333563 333564 Files written by SmartRefStream are in standard fileout format. You can mix raw objects with code to be filed in. The file starts out in the normal fileOut format. Definitions of new classes on the front. 333565 333566structures Dictionary of (#Rectangle -> #(<classVersionInteger> 'origin' 'corner')). Inst 333567 var names are strings. 333568steady Set of Classes who have the same structure now as on the incoming file. 333569 Includes classes with same inst vars except for new ones added on the end. 333570reshaped Dictionary of Classes who have a different structure now from the incoming file. 333571 Includes those with same inst vars but new version number. 333572 (old class name -> method selector to fill in data for version to version) 333573renamed Dictionary of Classes who have a different name. Make an instance of the new 333574 class, and send it the conversion call. 333575 (old class name symbol -> new class name). 333576renamedConv Dictionary of conversion selector for Classes who have a different name. 333577 (old class name symbol -> conversion selector). 333578topCall Tells if next or nextPut: are working on the top object in the tree. 333579 nil if outside, the top object if deep inside. 333580 333581See DataStream.typeIDFor: for where the tangle of objects is clipped, so the whole system will not be written on the file. 333582 333583No object that is written on the file is ever a class. All class definitions are filed in. A class may be stored inside an ImageSegment that itself is stored in a SmartRefStream. 333584 333585UniClasses are classes for the instance specific behavior of just one instance. Subclasses of Player are an example. When a UniClass is read in, and a class of the same name already exists, the incoming one is renamed. ObjectScanner converts the filed-in code. 333586 333587Values in instance variables of UniClasses are stored in the array that tells the class structure. It is the fourth of the four top level objects. #(version (class-structure) the-object ((#Player25 scripts slotInfo costumeDictionary) (#Player26 scripts slotInfo costumeDictionary))). 333588 333589There is a separate subclass for doing veryDeepCopy (in memory). Currently, any object for which objectToStoreOnDataStream return an object other than self, does this: The new object (a DiskProxy) is traced. When it comes time to go through the fields of the old object, they are not found as keys in references (DiskProxies are there instead). So the old field value is left in the new object. That is OK for StrikeFont, Class, MetaClass, DisplayScreen. But the DiskProxies are evaluated, which takes a lot of time. 333590 333591Some metaclasses are put into the structures table. This is for when a block has a receiver that is a class. See checkFatalReshape:. 333592 333593ImageSegments: 333594 A ReferenceStream is used to enumerate objects to put inside an ImageSegment. If an instance of a UniClass is seen, the class is put in also. 333595 A SmartRefStream is used to store the ImageSegment. Roots are nil, and the segment is a wordArray. We are encoding the outPointers. Structures contains all classes from both places. Must filter out UniClasses for some things, and do include them for putting source code at end of file. Do not write any class inst vars in file. 333596 333597--Ted Kaehler and Bob Arning. 333598! 333599 333600 333601!SmartRefStream methodsFor: 'accessing' stamp: 'tk 5/19/1999 15:47'! 333602structures: anObject 333603 structures := anObject! ! 333604 333605!SmartRefStream methodsFor: 'accessing' stamp: 'tk 5/19/1999 15:47'! 333606superclasses: anObject 333607 superclasses := anObject! ! 333608 333609 333610!SmartRefStream methodsFor: 'class changed shape' stamp: 'tk 1/7/97'! 333611catalogValues: instVarList size: varsOnDisk 333612 "Create a dictionary of (name -> value) for the inst vars of this reshaped object. Indexed vars as (1 -> val) etc. " 333613 333614 | dict sz | 333615 dict := Dictionary new. 333616 2 to: instVarList size do: [:ind | 333617 dict at: (instVarList at: ind) put: self next]. 333618 sz := varsOnDisk - (instVarList size - 1). 333619 1 to: sz do: [:ii | 333620 dict at: ii put: self next]. 333621 "Total number read MUST be equal to varsOnDisk!!" 333622 sz > 0 ifTrue: [dict at: #SizeOfVariablePart put: sz]. 333623 ^ dict! ! 333624 333625!SmartRefStream methodsFor: 'class changed shape' stamp: 'ar 9/27/2005 22:41'! 333626conversionMethodsFor: classList 333627 | oldStruct newStruct list | 333628 "Each of these needs a conversion method. Hard part is the comment in it. Return a MessageSet." 333629 333630 list := OrderedCollection new. 333631 classList do: [:cls | 333632 oldStruct := structures at: cls name ifAbsent: [#()]. 333633 newStruct := (Array with: cls classVersion), (cls allInstVarNames). 333634 self writeConversionMethodIn: cls fromInstVars: oldStruct to: newStruct 333635 renamedFrom: nil. 333636 list add: cls name, ' convertToCurrentVersion:refStream:'. 333637 ]. 333638 333639 ^list.! ! 333640 333641!SmartRefStream methodsFor: 'class changed shape' stamp: 'tk 5/26/97'! 333642storeInstVarsIn: anObject from: dict 333643 "For instance variables with the same names, store them in the new instance. Values in variable-length part also. This is NOT the normal inst var transfer!! See Object.readDataFrom:size:. This is for when inst var names have changed and some additional conversion is needed. Here we handle the unchanged vars. " 333644 333645 (anObject class allInstVarNames) doWithIndex: [:varName :index | 333646 (dict includesKey: varName) ifTrue: [ 333647 anObject instVarAt: index put: (dict at: varName)]]. 333648 "variable part" 333649 (dict includesKey: #SizeOfVariablePart) ifFalse: [^ anObject]. 333650 1 to: (dict at: #SizeOfVariablePart) do: [:index | 333651 anObject basicAt: index put: (dict at: index)]. 333652 ^ anObject! ! 333653 333654!SmartRefStream methodsFor: 'class changed shape' stamp: 'PeterHugossonMiller 9/3/2009 11:23'! 333655writeClassRename: newName was: oldName 333656 "Write a method that tells which modern class to map instances to." 333657 | oldVer sel code | 333658 333659 oldVer := self versionSymbol: (structures at: oldName). 333660 sel := oldName asString. 333661 sel at: 1 put: (sel at: 1) asLowercase. 333662 sel := sel, oldVer. "i.e. #rectangleoc4" 333663 333664 code := (String new: 500) writeStream. 333665 code nextPutAll: sel; cr. 333666 code cr; tab; nextPutAll: '^ ', newName. "Return new class" 333667 333668 self class compile: code contents classified: 'conversion'. 333669 333670! ! 333671 333672!SmartRefStream methodsFor: 'class changed shape' stamp: 'DamienCassou 9/23/2009 08:53'! 333673writeClassRenameMethod: sel was: oldName fromInstVars: oldList 333674 "The class coming is unknown. Ask the user for the existing class it maps to. If got one, write a method, and restart the obj fileIn. If none, write a dummy method and get the user to complete it later. " 333675 333676| tell choice newName answ code | 333677 333678 self flag: #bobconv. 333679 333680 333681tell := 'Reading an instance of ', oldName, '. 333682Which modern class should it translate to?'. 333683answ := (UIManager default 333684 chooseFrom: #('Let me type the name now' 'Let me think about it' 333685'Let me find a conversion file on the disk') 333686 title: tell). 333687 333688answ = 1 ifTrue: [ 333689 tell := 'Name of the modern class {1} should translate to:' translated format: {oldName}. 333690 choice := UIManager default request: tell. "class name" 333691 choice isEmptyOrNil 333692 ifTrue: [answ := 'conversion method needed'] 333693 ifFalse: [newName := choice. 333694 answ := Smalltalk at: newName asSymbol 333695 ifAbsent: ['conversion method needed']. 333696 answ isString ifFalse: [renamed at: oldName asSymbol put: answ name]]]. 333697(answ = 3) | (answ = 0) ifTrue: [self close. 333698 ^ 'conversion method needed']. 333699answ = 2 ifTrue: [answ := 'conversion method needed']. 333700answ = 'conversion method needed' ifTrue: [ 333701 self close. 333702 newName := 'PutNewClassHere']. 333703 333704code := WriteStream on: (String new: 500). 333705code nextPutAll: sel; cr. 333706code cr; tab; nextPutAll: '^ ', newName. "Return new class" 333707 333708self class compile: code contents classified: 'conversion'. 333709 333710newName = 'PutNewClassHere' ifTrue: [ 333711 self inform: 'Please complete the following method and 333712then read-in the object file again.'. 333713 SystemNavigation default browseAllImplementorsOf: sel asSymbol]. 333714 333715 "The class version number only needs to change under one specific circumstance. That is when the first letters of the instance variables have stayed the same, but their meaning has changed. A conversion method is needed, but this system does not know it. 333716 If this is true for class Foo, define classVersion in Foo class. 333717 Beware of previous object fileouts already written after the change in meaning, but before bumping the version number. They have the old (wrong) version number, say 2. If this is true, your method must be able to test the data and successfully read files that say version 2 but are really 3." 333718 333719 ^ answ! ! 333720 333721!SmartRefStream methodsFor: 'class changed shape' stamp: 'PeterHugossonMiller 9/3/2009 11:23'! 333722writeConversionMethod: sel class: newClass was: oldName fromInstVars: oldList to: newList 333723 "The method convertToCurrentVersion:refStream: was not found in newClass. Write a default conversion method for the author to modify." 333724 333725 | code newOthers oldOthers copied | 333726 333727 code := (String new: 500) writeStream. 333728 code nextPutAll: 'convertToCurrentVersion: varDict refStream: smartRefStrm'; cr; tab. 333729 newOthers := newList asOrderedCollection "copy". 333730 oldOthers := oldList asOrderedCollection "copy". 333731 copied := OrderedCollection new. 333732 newList do: [:instVar | 333733 (oldList includes: instVar) ifTrue: [ 333734 instVar isInteger ifFalse: [copied add: instVar]. 333735 newOthers remove: instVar. 333736 oldOthers remove: instVar]]. 333737 code nextPutAll: '"These variables are automatically stored into the new instance '. 333738 code nextPutAll: copied asArray printString; nextPut: $. . 333739 code cr; tab; nextPutAll: 'This method is for additional changes.'; 333740 nextPutAll: ' Use statements like (foo := varDict at: ''foo'')."'; cr; cr; tab. 333741 (newOthers size = 0) & (oldOthers size = 0) ifTrue: [^ self]. 333742 "Instance variables are the same. Only the order changed. No conversion needed." 333743 (newOthers size > 0) ifTrue: [code nextPutAll: '"New variables: ', newOthers asArray printString, ' If a non-nil value is needed, please assign it."\' withCRs]. 333744 (oldOthers size > 0) ifTrue: [code nextPutAll: ' "These are going away ', oldOthers asArray printString, '. Possibly store their info in some other variable?"']. 333745 333746 code cr; tab. 333747 code nextPutAll: '^ super convertToCurrentVersion: varDict refStream: smartRefStrm'. 333748 newClass compile: code contents classified: 'object fileIn'. 333749 333750 333751 "If you write a conversion method beware that the class may need a version number change. This only happens when two conversion methods in the same class have the same selector name. (A) The inst var lists of the new and old versions intials as some older set of new and old inst var lists. or (B) Twice in a row, the class needs a conversion method, but the inst vars stay the same the whole time. (For an internal format change.) 333752 If either is the case, fileouts already written with the old (wrong) version number, say 2. Your method must be able to read files that say version 2 but are really 3, until you expunge the erroneous version 2 files from the universe." 333753 333754 ! ! 333755 333756!SmartRefStream methodsFor: 'class changed shape' stamp: 'PeterHugossonMiller 9/3/2009 11:23'! 333757writeConversionMethodIn: newClass fromInstVars: oldList to: newList renamedFrom: oldName 333758 "The method convertToCurrentVersion:refStream: was not found in newClass. Write a default conversion method for the author to modify. If method exists, append new info into the end." 333759 333760 | code newOthers oldOthers copied newCode | 333761 333762 newOthers := newList asOrderedCollection "copy". 333763 oldOthers := oldList asOrderedCollection "copy". 333764 copied := OrderedCollection new. 333765 newList do: [:instVar | 333766 (oldList includes: instVar) ifTrue: [ 333767 instVar isInteger ifFalse: [copied add: instVar]. 333768 newOthers remove: instVar. 333769 oldOthers remove: instVar]]. 333770 code := (String new: 500) writeStream. 333771 code cr; cr; tab; nextPutAll: '"From ', SystemVersion current version, ' [', SmalltalkImage current lastUpdateString; 333772 nextPutAll: '] on ', Date today printString, '"'; cr. 333773 code tab; nextPutAll: '"These variables are automatically stored into the new instance: '. 333774 code nextPutAll: copied asArray printString; nextPut: $.; cr. 333775 code tab; nextPutAll: 'Test for this particular conversion.'; 333776 nextPutAll: ' Get values using expressions like (varDict at: ''foo'')."'; cr; cr. 333777 (newOthers size = 0) & (oldOthers size = 0) & (oldName == nil) ifTrue: [^ self]. 333778 "Instance variables are the same. Only the order changed. No conversion needed." 333779 (newOthers size > 0) ifTrue: [ 333780 code tab; nextPutAll: '"New variables: ', newOthers asArray printString, 333781 '. If a non-nil value is needed, please assign it."'; cr]. 333782 (oldOthers size > 0) ifTrue: [ 333783 code tab; nextPutAll: '"These are going away ', oldOthers asArray printString, 333784 '. Possibly store their info in some other variable?"'; cr]. 333785 oldName ifNotNil: [ 333786 code tab; nextPutAll: '"Test for instances of class ', oldName, '.'; cr. 333787 code tab; nextPutAll: 'Instance vars with the same name have been moved here."'; cr. 333788 ]. 333789 code tab; nextPutAll: '"Move your code above the ^ super... Delete extra comments."'; cr. 333790 333791 (newClass includesSelector: #convertToCurrentVersion:refStream:) 333792 ifTrue: ["append to old methods" 333793 newCode := (newClass sourceCodeAt: #convertToCurrentVersion:refStream:), 333794 code contents] 333795 ifFalse: ["new method" 333796 newCode := 'convertToCurrentVersion: varDict refStream: smartRefStrm', 333797 code contents, 333798 ' ^ super convertToCurrentVersion: varDict refStream: smartRefStrm']. 333799 newClass compile: newCode classified: 'object fileIn'. 333800 333801 333802 "If you write a conversion method beware that the class may need a version number change. This only happens when two conversion methods in the same class have the same selector name. (A) The inst var lists of the new and old versions intials as some older set of new and old inst var lists. or (B) Twice in a row, the class needs a conversion method, but the inst vars stay the same the whole time. (For an internal format change.) 333803 If either is the case, fileouts already written with the old (wrong) version number, say 2. Your method must be able to read files that say version 2 but are really 3, until you expunge the erroneous version 2 files from the universe." 333804 333805 ! ! 333806 333807 333808!SmartRefStream methodsFor: 'conversion' stamp: 'ar 4/10/2005 15:44'! 333809abstractStringx0 333810 333811 ^ String! ! 333812 333813!SmartRefStream methodsFor: 'conversion' stamp: 'di 5/22/1998 15:03'! 333814clippingMorphbosfcep0 333815 ^ PasteUpMorph! ! 333816 333817!SmartRefStream methodsFor: 'conversion' stamp: 'tk 11/3/2000 18:47'! 333818dropShadowMorphbosfces0 333819 333820 ^ Morph ! ! 333821 333822!SmartRefStream methodsFor: 'conversion' stamp: 'di 5/21/1998 19:24'! 333823layoutMorphbosfcepbbochvimol0 333824 ^ AlignmentMorph! ! 333825 333826!SmartRefStream methodsFor: 'conversion' stamp: 'tk 5/12/1998 16:18'! 333827layoutMorphbosfcepcbbochvimol0 333828 ^ AlignmentMorph! ! 333829 333830!SmartRefStream methodsFor: 'conversion' stamp: 'ar 10/26/2000 01:55'! 333831morphicEventtcbks0 333832 ^ MorphicEvent! ! 333833 333834!SmartRefStream methodsFor: 'conversion' stamp: 'ar 10/26/2000 00:48'! 333835morphicSoundEventtcbkss0 333836 ^ MorphicUnknownEvent! ! 333837 333838!SmartRefStream methodsFor: 'conversion' stamp: 'ar 4/12/2005 17:38'! 333839multiStringx0 333840 333841 ^ WideString! ! 333842 333843!SmartRefStream methodsFor: 'conversion' stamp: 'ar 4/12/2005 17:38'! 333844multiSymbolx0 333845 333846 ^ WideSymbol! ! 333847 333848!SmartRefStream methodsFor: 'conversion' stamp: 'ar 7/8/2001 17:11'! 333849myMorphbosfce0 333850 333851 reshaped at: #MyMorph put: #convertbosfce0:bosfce0:. 333852 "Be sure to define that conversion method in class Morph" 333853 ^ Morph! ! 333854 333855!SmartRefStream methodsFor: 'conversion' stamp: 'RAA 10/26/2000 09:43'! 333856newMorphicEventts0 333857 333858 ^ MorphicEvent! ! 333859 333860!SmartRefStream methodsFor: 'conversion' stamp: 'tk 1/14/1999 13:16'! 333861transparentColorrcc0 333862 ^ TranslucentColor! ! 333863 333864!SmartRefStream methodsFor: 'conversion' stamp: 'di 8/16/2000 16:37'! 333865worldMorphbosfcebbfgccpmcpbttloiairfidcuwhavcdsll0 333866 ^ 'PutNewClassHere' " <-- Replace this by a class name (no string quotes)"! ! 333867 333868 333869!SmartRefStream methodsFor: 'import image segment' stamp: 'tk 33387011/26/2004 05:53'! 333871applyConversionMethodsTo: objectIn className: className varMap: varMap 333872 "Modify the object's instance vars to have the proper values 333873 for its new shape. Mostly, fill in defaut values of new inst vars. 333874 Can substitute an object of a different class. (Beware: if 333875 substituted, varMap will not be correct when the new object is asked 333876 to convert.)" 333877 | anObject prevObject | 333878 333879 self flag: #bobconv. 333880 333881 anObject := objectIn. 333882 [ 333883 prevObject := anObject. 333884 anObject := anObject convertToCurrentVersion: varMap 333885 refStream: self. 333886 prevObject == anObject 333887 ] whileFalse. 333888 ^anObject 333889 ! ! 333890 333891!SmartRefStream methodsFor: 'import image segment' stamp: 'RAA 12/20/2000 11:08'! 333892checkFatalReshape: setOfClasses 333893 | suspects oldInstVars newInstVars bad className | 333894 "Inform the user if any of these classes were reshaped. A block has a method from the old system whose receiver is of this class. The method's inst var references might be wrong. OK if inst vars were only added." 333895 333896 self flag: #bobconv. 333897 333898 setOfClasses isEmpty ifTrue: [^ self]. 333899 suspects := OrderedCollection new. 333900 setOfClasses do: [:aClass | 333901 className := renamed keyAtValue: aClass name ifAbsent: [aClass name]. 333902 oldInstVars := (structures at: className ifAbsent: [#(0)]) allButFirst. "should be there" 333903 newInstVars := aClass allInstVarNames. 333904 oldInstVars size > newInstVars size ifTrue: [bad := true]. 333905 oldInstVars size = newInstVars size ifTrue: [ 333906 bad := oldInstVars ~= newInstVars]. 333907 oldInstVars size < newInstVars size ifTrue: [ 333908 bad := oldInstVars ~= (newInstVars copyFrom: 1 to: oldInstVars size)]. 333909 bad ifTrue: [suspects add: aClass]]. 333910 333911 suspects isEmpty ifFalse: [ 333912 self inform: ('Imported foreign methods will run on instances of:\', 333913 suspects asArray printString, 333914 '\whose shape has changed. Errors may occur.') withCRs].! ! 333915 333916!SmartRefStream methodsFor: 'import image segment' stamp: 'RAA 12/20/2000 11:06'! 333917convert1: misShapenInst to: goodClass allVarMaps: allVarMaps 333918 "Go through the normal instance conversion process and return a modern object." 333919 333920 | className oldInstVars anObject varMap | 333921 333922 self flag: #bobconv. 333923 333924 goodClass isVariable ifTrue: [ 333925 goodClass error: 'shape change for variable class not implemented yet' 333926 ]. 333927 (misShapenInst class name beginsWith: 'Fake37') ifFalse: [self error: 'why mapping?']. 333928 className := (misShapenInst class name allButFirst: 6) asSymbol. 333929 oldInstVars := structures at: className. 333930 anObject := goodClass basicNew. 333931 333932 varMap := Dictionary new. "later, indexed vars as (1 -> val) etc." 333933 2 to: oldInstVars size do: [:ind | 333934 varMap at: (oldInstVars at: ind) put: (misShapenInst instVarAt: ind-1)]. 333935 varMap at: #ClassName put: className. "original" 333936 varMap at: #NewClassName put: goodClass name. "new" 333937 self storeInstVarsIn: anObject from: varMap. "ones with the same names" 333938 allVarMaps at: misShapenInst put: varMap. 333939 ^ anObject 333940! ! 333941 333942!SmartRefStream methodsFor: 'import image segment' stamp: 'RAA 12/20/2000 17:15'! 333943convert2: partiallyCorrectInst allVarMaps: allVarMaps 333944 "Go through the normal instance conversion process and return a modern object." 333945 333946 | className varMap | 333947 333948 self flag: #bobconv. 333949 333950 varMap := allVarMaps at: partiallyCorrectInst. 333951 className := varMap at: #ClassName. "original" 333952 ^self applyConversionMethodsTo: partiallyCorrectInst className: className varMap: varMap. 333953 333954! ! 333955 333956!SmartRefStream methodsFor: 'import image segment' stamp: 'ar 4/12/2005 18:06'! 333957mapClass: newClass origName: originalName 333958 "See if instances changed shape. If so, make a fake class for the old shape and return it. Remember the original class name." 333959 333960 | newName oldInstVars fakeClass | 333961 newClass isMeta ifTrue: [^ newClass]. 333962 newName := newClass name. 333963 (steady includes: newClass) & (newName == originalName) ifTrue: [^ newClass]. 333964 "instances in the segment have the right shape" 333965 oldInstVars := structures at: originalName ifAbsent: [ 333966 self error: 'class is not in structures list']. "Missing in object file" 333967 333968 "Allow mapping from old to new string names" 333969 (newName == #ByteString and:[originalName == #String]) ifTrue:[^newClass]. 333970 (newName == #WideString and:[originalName == #MultiString]) ifTrue:[^newClass]. 333971 (newName == #WideSymbol and:[originalName == #MultiSymbol]) ifTrue:[^newClass]. 333972 333973 fakeClass := Object subclass: ('Fake37', originalName) asSymbol 333974 instanceVariableNames: oldInstVars allButFirst 333975 classVariableNames: '' 333976 poolDictionaries: '' 333977 category: 'Obsolete'. 333978 ChangeSet current removeClassChanges: fakeClass name. "reduce clutter" 333979 ^ fakeClass 333980! ! 333981 333982!SmartRefStream methodsFor: 'import image segment' stamp: 'RAA 12/20/2000 11:09'! 333983reshapedClassesIn: outPointers 333984 "Look for classes in the outPointer array that have changed shape. Make a fake class for the old shape. Return a dictionary mapping Fake classes to Real classes. Substitute fake classes for real ones in outPointers." 333985 333986 | mapFakeClassesToReal fakeCls originalName | 333987 333988 self flag: #bobconv. 333989 333990 333991 mapFakeClassesToReal := IdentityDictionary new. 333992 outPointers withIndexDo: [:outp :ind | 333993 outp isBehavior ifTrue: [ 333994 originalName := renamedConv at: ind ifAbsent: [outp name]. 333995 "in DiskProxy>>comeFullyUpOnReload: we saved the name at the index" 333996 fakeCls := self mapClass: outp origName: originalName. 333997 fakeCls == outp ifFalse: [ 333998 mapFakeClassesToReal at: fakeCls put: outp. 333999 outPointers at: ind put: fakeCls]]]. 334000 ^ mapFakeClassesToReal! ! 334001 334002 334003!SmartRefStream methodsFor: 'read write' stamp: 'sd 4/24/2008 22:21'! 334004appendClassDefns 334005 "Make this a fileOut format file. For each UniClass mentioned, prepend its source code to the file. Class name conflicts during reading will be resolved then. Assume instVarInfo: has already been done." 334006 334007byteStream ascii. 334008byteStream position = 0 ifTrue: [ 334009 byteStream setFileTypeToObject. 334010 "Type and Creator not to be text, so can attach correctly to an email msg" 334011 byteStream header; timeStamp]. 334012 334013byteStream cr; nextPutAll: '!!ObjectScanner new initialize!!'; cr; cr. 334014self uniClasesDo: [:class | class 334015 class hasSharedPools ifTrue: "This never happens" 334016 [class shouldFileOutPools 334017 ifTrue: [class fileOutSharedPoolsOn: self]]. 334018 class fileOutOn: byteStream moveSource: false toFile: 0]. 334019 "UniClasses are filed out normally, no special format." 334020 334021 byteStream trailer. "Does nothing for normal files. 334022 HTML streams will have trouble with object data" 334023 334024 "Append the object's raw data" 334025 byteStream cr; cr; nextPutAll: '!!self smartRefStream!!'. 334026 byteStream binary. "get ready for objects" 334027! ! 334028 334029!SmartRefStream methodsFor: 'read write' stamp: 'tk 6/19/2000 21:22'! 334030checkCrLf 334031 | save isCrLf cc prev loneLf | 334032 "Watch for a file that has had all of its Cr's converted to CrLf's. Some unpacking programs like Stuffit 5.0 do this by default!!" 334033 334034 save := byteStream position. 334035 isCrLf := false. loneLf := false. 334036 cc := 0. 334037 350 timesRepeat: [ 334038 prev := cc. 334039 (cc := byteStream next) = 16r0A "Lf" ifTrue: [ 334040 prev = 16r0D "Cr" ifTrue: [isCrLf := true] ifFalse: [loneLf := true]]. 334041 ]. 334042 isCrLf & (loneLf not) ifTrue: [ 334043 self inform: 'Carriage Returns in this file were converted to CrLfs 334044by an evil unpacking utility. Please set the preferences in 334045StuffIt Expander to "do not convert file formats"']. 334046 byteStream position: save. 334047! ! 334048 334049!SmartRefStream methodsFor: 'read write' stamp: 'mir 9/12/2002 10:59'! 334050initKnownRenames 334051 renamed 334052 at: #FlasherMorph put: #Flasher; 334053 yourself! ! 334054 334055!SmartRefStream methodsFor: 'read write' stamp: 'ar 4/10/2005 19:27'! 334056initShapeDicts 334057 "Initialize me. " 334058 334059 self flag: #bobconv. 334060 334061 "These must stay constant. When structures read in, then things can change." 334062 steady := {Array. Dictionary. Association. ByteString. SmallInteger} asSet. 334063 334064 renamed ifNil: [ 334065 renamed := Dictionary new. "(old class name symbol -> new class name)" 334066 renamedConv := Dictionary new "(oldClassNameSymbol -> conversionSelectorInNewClass)" 334067 ]. 334068 self initKnownRenames! ! 334069 334070!SmartRefStream methodsFor: 'read write' stamp: 'tk 3/7/2001 18:17'! 334071instVarInfo: anObject 334072 "Return the object to write on the outgoing file that contains the structure of each class we are about to write out. Must be an Array whose first element is 'class structure'. Its second element is a Dictionary of pairs of the form #Rectangle -> #(<classVersion> 'origin' 'corner'). " 334073 334074 "Make a pass through the objects, not writing, but recording the classes. Construct a database of their inst vars and any version info (classVersion)." 334075 334076 | dummy refs cls newSupers | 334077 structures := Dictionary new. 334078 superclasses := Dictionary new. 334079 dummy := ReferenceStream on: (DummyStream on: nil). 334080 "Write to a fake Stream, not a file" 334081 "Collect all objects" 334082 dummy rootObject: anObject. "inform him about the root" 334083 dummy nextPut: anObject. 334084 refs := dummy references. 334085 objCount := refs size. "for progress bar" 334086 "Note that Dictionary must not change its implementation!! If it does, how do we read this reading information?" 334087 (refs includesKey: #AnImageSegment) 334088 ifFalse: [ 334089 self uniClassInstVarsRefs: dummy. "catalog the extra objects in UniClass inst vars" 334090 refs keysDo: [:each | 334091 cls := each class. 334092 "cls isObsolete ifTrue: [self error: 'Trying to write ', cls name]." 334093 (cls class ~~ Metaclass) & (cls isObsolete not) ifTrue: [ 334094 structures at: cls name put: false]]] 334095 ifTrue: [self recordImageSegment: refs]. 334096 "Save work by only computing inst vars once for each class" 334097 newSupers := Set new. 334098 structures at: #Point put: false. "writeRectangle: does not put out class pointer" 334099 structures at: #Rectangle put: false. 334100 structures at: #LargePositiveInteger put: false. "used in slow case of WordArray" 334101 structures keysDo: [:nm | 334102 cls := (nm endsWith: ' class') 334103 ifFalse: [Smalltalk at: nm] 334104 ifTrue: [(Smalltalk at: nm substrings first asSymbol) class]. 334105 cls allSuperclasses do: [:aSuper | 334106 structures at: aSuper name ifAbsent: [newSupers add: aSuper name]]]. 334107 "Don't modify structures during iteration" 334108 newSupers do: [:nm | structures at: nm put: 3]. "Get all superclasses into list" 334109 structures keysDo: [:nm | "Nothing added to classes during loop" 334110 cls := (nm endsWith: ' class') 334111 ifFalse: [Smalltalk at: nm] 334112 ifTrue: [(Smalltalk at: nm substrings first asSymbol) class]. 334113 structures at: nm put: 334114 ((Array with: cls classVersion), (cls allInstVarNames)). 334115 superclasses at: nm ifAbsent: [ 334116 superclasses at: nm put: cls superclass name]]. 334117 (refs includesKey: #AnImageSegment) 334118 ifTrue: [classInstVars := #()] 334119 ifFalse: [self saveClassInstVars]. "of UniClassses" 334120 ^ (Array with: 'class structure' with: structures with: 'superclasses' with: superclasses)! ! 334121 334122!SmartRefStream methodsFor: 'read write' stamp: 'ar 4/10/2005 18:52'! 334123mapClass: incoming 334124 "See if the old class named nm exists. If so, return it. If not, map it to a new class, and save the mapping in renamed. " 334125 334126 | cls oldVer sel nm | 334127 334128 self flag: #bobconv. 334129 334130 334131 nm := renamed at: incoming ifAbsent: [incoming]. "allow pre-mapping around collisions" 334132 (nm endsWith: ' class') 334133 ifFalse: [cls := Smalltalk at: nm ifAbsent: [nil]. 334134 cls ifNotNil: [^ cls]] "Known class. It will know how to translate the instance." 334135 ifTrue: [cls := Smalltalk at: nm substrings first asSymbol ifAbsent: [nil]. 334136 cls ifNotNil: [^ cls class]]. "Known class. It will know how to translate the instance." 334137 oldVer := self versionSymbol: (structures at: nm). 334138 sel := nm asString. 334139 sel at: 1 put: (sel at: 1) asLowercase. 334140 sel := sel, oldVer. "i.e. #rectangleoc4" 334141 Symbol hasInterned: sel ifTrue: [:symb | 334142 (self class canUnderstand: sel asSymbol) ifTrue: [ 334143 reshaped ifNil: [reshaped := Dictionary new]. 334144 cls := self perform: sel asSymbol]]. "This class will take responsibility" 334145 cls ifNil: [cls := self writeClassRenameMethod: sel was: nm 334146 fromInstVars: (structures at: nm). 334147 cls isString ifTrue: [cls := nil]]. 334148 cls ifNotNil: [renamed at: nm put: cls name]. 334149 ^ cls 334150! ! 334151 334152!SmartRefStream methodsFor: 'read write' stamp: 'tk 5/26/1998 15:09'! 334153moreObjects 334154 "Return true if there appears to be another object following this one on the file." 334155 334156 | byte | 334157 byteStream atEnd ifTrue: [^ false]. "off end of file" 334158 (byte := byteStream peek) ifNil: [^ false]. "off end of file" 334159 byte = 33 "$!! asciiValue" ifTrue: [^ false]. 334160 byte = 0 ifTrue: [^ false]. 334161 ^ byte <= RefTypes size "between 1 and 16"! ! 334162 334163!SmartRefStream methodsFor: 'read write' stamp: 'marcus.denker 2/8/2009 22:18'! 334164next 334165 "Really write three objects: (version, class structure, object). But only when called from the outside. " 334166 334167 | version ss object | 334168 ^ topCall == nil 334169 ifTrue: 334170 [topCall := #marked. 334171 version := super next. 334172 version class == SmallInteger ifFalse: [^ version]. 334173 "version number, else just a regular object, not in our format, " 334174 self checkCrLf. 334175 ss := super next. 334176 ss class == Array ifFalse: [^ ss]. "just a regular object" 334177 (ss at: 1) = 'class structure' ifFalse: [^ ss]. 334178 structures := ss at: 2. 334179 superclasses := (ss size > 3 and: [(ss at: 3) = 'superclasses']) 334180 ifTrue: [ss at: 4] "class name -> superclass name" 334181 ifFalse: [Dictionary new]. 334182 (self verifyStructure = 'conversion method needed') ifTrue: [^ nil]. 334183 object := super next. "all the action here" 334184 topCall := nil. "reset it" 334185 object] 334186 ifFalse: 334187 [super next] 334188! ! 334189 334190!SmartRefStream methodsFor: 'read write' stamp: 'tk 3/5/2002 09:52'! 334191nextAndClose 334192 "Speedy way to grab one object. Only use when we are inside an object binary file. If used for the start of a SmartRefStream mixed code-and-object file, tell the user and then do the right thing." 334193 334194 | obj | 334195 byteStream peek = ReferenceStream versionCode "4" ifFalse: [ 334196 "OK it is a fileIn afterall..." 334197 self inform: 'Should be using fileInObjectAndCode'. 334198 byteStream ascii. 334199 byteStream fileIn. 334200 obj := SmartRefStream scannedObject. 334201 SmartRefStream scannedObject: nil. 334202 ^ obj]. 334203 334204 obj := self next. 334205 self close. 334206 ^ obj! ! 334207 334208!SmartRefStream methodsFor: 'read write' stamp: 'md 2/24/2006 19:52'! 334209nextPut: anObject 334210 "Really write three objects: (version, class structure, object). But only when called from the outside. If any instance-specific classes are present, prepend their source code. byteStream will be in fileOut format. 334211 You can see an analysis of which objects are written out by doing: 334212 (SmartRefStream statsOfSubObjects: anObject) 334213 (SmartRefStream tallyOfSubObjects: anObject) 334214 (SmartRefStream subObjects: anObject ofClass: aClass)" 334215 334216| info | 334217topCall == nil 334218 ifTrue: 334219 [topCall := anObject. 334220 'Please wait while objects are counted' 334221 displayProgressAt: Sensor cursorPoint 334222 from: 0 to: 10 334223 during: [:bar | info := self instVarInfo: anObject]. 334224 self appendClassDefns. "For instance-specific classes" 334225 'Writing an object file' displayProgressAt: Sensor cursorPoint 334226 from: 0 to: objCount*4 "estimate" 334227 during: [:bar | 334228 objCount := 0. 334229 progressBar := bar. 334230 self setStream: byteStream reading: false. 334231 "set basePos, but keep any class renames" 334232 super nextPut: ReferenceStream versionCode. 334233 super nextPut: info. 334234 super nextPut: anObject. "<- the real writing" 334235 classInstVars size > 0 ifTrue: [super nextPut: classInstVars]]. 334236 "Note: the terminator, $!!, is not doubled inside object data" 334237 "references is an IDict of every object that got written" 334238 byteStream ascii. 334239 byteStream nextPutAll: '!!'; cr; cr. 334240 byteStream padToEndWith: $ . "really want to truncate file, but can't" 334241 topCall := progressBar := nil] "reset it" 334242 ifFalse: 334243 [super nextPut: anObject. 334244 progressBar ifNotNil: [progressBar value: (objCount := objCount + 1)]]. 334245 "return the argument - added by kwl" 334246 ^ anObject 334247! ! 334248 334249!SmartRefStream methodsFor: 'read write' stamp: 'tk 6/23/1998 11:00'! 334250nextPutObjOnly: anObject 334251 "Really write three objects: (version, class structure, object). But only when called from the outside. Not in fileOut format. No class definitions will be written for instance-specific classes. Error if find one. (Use nextPut: instead)" 334252 334253 | info | 334254 topCall == nil 334255 ifTrue: 334256 [topCall := anObject. 334257 super nextPut: ReferenceStream versionCode. 334258 'Please wait while objects are counted' displayProgressAt: Sensor cursorPoint 334259 from: 0 to: 10 334260 during: [:bar | 334261 info := self instVarInfo: anObject]. 334262 self uniClasesDo: [:cls | cls error: 'Class defn not written out. Proceed?']. 334263 'Writing an object file' displayProgressAt: Sensor cursorPoint 334264 from: 0 to: objCount*4 "estimate" 334265 during: [:bar | 334266 objCount := 0. 334267 progressBar := bar. 334268 super nextPut: info. 334269 super nextPut: anObject. "<- the real writing" 334270 "Class inst vars not written here!!"]. 334271 "references is an IDict of every object that got written 334272 (in case you want to take statistics)" 334273 "Transcript cr; show: structures keys printString." "debug" 334274 topCall := progressBar := nil] "reset it" 334275 ifFalse: 334276 [super nextPut: anObject. 334277 progressBar ifNotNil: [progressBar value: (objCount := objCount + 1)]].! ! 334278 334279!SmartRefStream methodsFor: 'read write' stamp: 'tk 6/23/1998 11:13'! 334280noHeader 334281 "Signal that we've already dealt with the version and structure array, and are now reading objects." 334282 334283 topCall := #marked. 334284! ! 334285 334286!SmartRefStream methodsFor: 'read write' stamp: 'tk 11/3/2000 17:59'! 334287readInstance 334288 "Read the contents of an arbitrary instance. 334289 ASSUMES: readDataFrom:size: sends me beginReference: after it 334290 instantiates the new object but before reading nested objects. 334291 NOTE: We must restore the current reference position after 334292 recursive calls to next. 334293Three cases for files from older versions of the system: 3342941) Class has not changed shape, read it straight. 3342952) Class has changed instance variables (or needs fixup). Call a particular method to do it. 3342963) There is a new class instead. Find it, call a particular method to read. 334297 All classes used to construct the structures dictionary *itself* need to be in 'steady' and they must not change!! See setStream:" 334298 | instSize className refPosn | 334299 334300 instSize := (byteStream nextNumber: 4) - 1. 334301 refPosn := self getCurrentReference. 334302 className := self next asSymbol. 334303 ^ self readInstanceSize: instSize clsname: className refPosn: refPosn 334304! ! 334305 334306!SmartRefStream methodsFor: 'read write' stamp: 'yo 1/21/2006 19:27'! 334307readInstanceSize: instSize clsname: className refPosn: refPosn 334308 "The common code to read the contents of an arbitrary instance. 334309 ASSUMES: readDataFrom:size: sends me beginReference: after it 334310 instantiates the new object but before reading nested objects. 334311 NOTE: We must restore the current reference position after 334312 recursive calls to next. 334313Three cases for files from older versions of the system: 3343141) Class has not changed shape, read it straight. 3343152) Class has changed instance variables (or needs fixup). Call a particular method to do it. 3343163) There is a new class instead. Find it, call a particular method to read. 334317 All classes used to construct the structures dictionary *itself* need to be in 'steady' and they must not change!! See setStream:" 334318 | anObject newName newClass dict oldInstVars isMultiSymbol | 334319 334320 self flag: #bobconv. 334321 334322 self setCurrentReference: refPosn. "remember pos before readDataFrom:size:" 334323 newName := renamed at: className ifAbsent: [className]. 334324 isMultiSymbol := newName = #MultiSymbol or: [newName = #WideSymbol]. 334325 "isMultiSymbol ifTrue: [self halt]." 334326 newClass := Smalltalk at: newName asSymbol. 334327 (steady includes: newClass) & (newName == className) ifTrue: [ 334328 anObject := newClass isVariable "Create it here" 334329 ifFalse: [newClass basicNew] 334330 ifTrue: [newClass basicNew: instSize - (newClass instSize)]. 334331 334332 anObject := anObject readDataFrom: self size: instSize. 334333 self setCurrentReference: refPosn. "before returning to next" 334334 isMultiSymbol ifTrue: [^ Symbol intern: anObject asString]. 334335 ^ anObject]. 334336 oldInstVars := structures at: className ifAbsent: [ 334337 self error: 'class is not in structures list']. "Missing in object file" 334338 anObject := newClass createFrom: self size: instSize version: oldInstVars. 334339 "only create the instance" 334340 self beginReference: anObject. 334341 dict := self catalogValues: oldInstVars size: instSize. 334342 "indexed vars as (1 -> val) etc." 334343 dict at: #ClassName put: className. "so conversion method can know it" 334344 334345 "Give each superclass a chance to make its changes" 334346 self storeInstVarsIn: anObject from: dict. "ones with the same names" 334347 334348 anObject := self applyConversionMethodsTo: anObject className: className varMap: dict. 334349 334350 self setCurrentReference: refPosn. "before returning to next" 334351 isMultiSymbol ifTrue: [^ Symbol intern: anObject asString]. 334352 ^ anObject! ! 334353 334354!SmartRefStream methodsFor: 'read write' stamp: 'tk 11/3/2000 18:04'! 334355readShortInst 334356 "Instance has just one byte of size. Class symbol is encoded in two bytes of file position. See readInstance." 334357 | instSize className refPosn | 334358 334359 instSize := (byteStream next) - 1. "one byte of size" 334360 refPosn := self getCurrentReference. 334361 className := self readShortRef. "class symbol in two bytes of file pos" 334362 ^ self readInstanceSize: instSize clsname: className refPosn: refPosn 334363! ! 334364 334365!SmartRefStream methodsFor: 'read write' stamp: 'ar 7/25/2005 21:30'! 334366readWordLike 334367 | refPosn newClass anObject className | 334368 "Can be used by any class that is bits and not bytes (WordArray, Bitmap, SoundBuffer, etc)." 334369 334370 refPosn := self getCurrentReference. 334371 className := self next asSymbol. 334372 className := renamed at: className ifAbsent: [className]. 334373 newClass := Smalltalk at: className. 334374 anObject := newClass newFromStream: byteStream. 334375 "Size is number of long words." 334376 self setCurrentReference: refPosn. "before returning to next" 334377 ^ anObject 334378! ! 334379 334380!SmartRefStream methodsFor: 'read write' stamp: 'tk 10/10/2000 13:36'! 334381recordImageSegment: refs 334382 "Besides the objects being written out, record the structure of instances inside the image segment we are writing out." 334383 334384 | cls list | 334385 "Do not record Player class inst vars. They are in the segement." 334386 refs keysDo: [:each | 334387 cls := each class. 334388 cls isObsolete ifTrue: [self error: 'Trying to write ', cls name]. 334389 cls class == Metaclass 334390 ifFalse: [structures at: cls name put: false. 334391 (each isKindOf: ImageSegment) ifTrue: [ 334392 each outPointers do: [:out | 334393 (out isKindOf: Class) ifTrue: [ 334394 structures at: out theNonMetaClass name put: false]. 334395 out class == DiskProxy ifTrue: [ 334396 out simpleGlobalOrNil ifNotNil: [ 334397 (out simpleGlobalOrNil isKindOf: Class) ifTrue: [ 334398 structures at: out simpleGlobalOrNil name put: false]]]]. 334399 "each arrayOfRoots do: [:rr | (rr isKindOf: Class) ifTrue: [ 334400 structures at: rr theNonMetaClass name put: false]]." 334401 "all classes in roots are local to seg"]]]. 334402 list := refs at: #BlockReceiverClasses ifAbsent: [^ self]. 334403 list do: [:meta | structures at: meta name put: false]. 334404 "Just the metaclasses whose instances are block receivers. Otherwise metaclasses are not allowed."! ! 334405 334406!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 11:08'! 334407renamed 334408 334409 self flag: #bobconv. 334410 334411 334412 ^ renamed! ! 334413 334414!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 11:10'! 334415renamedConv 334416 self flag: #bobconv. 334417 334418 334419 ^ renamedConv! ! 334420 334421!SmartRefStream methodsFor: 'read write' stamp: 'tk 3/6/2000 18:17'! 334422saveClassInstVars 334423 "Install the values of the instance variables of UniClasses. 334424classInstVars is an array of arrays (#Player3 (Player3 class's inst var 334425scripts) (Player3 class's inst var slotInfo) ...) " 334426 334427 | normal mySize list clsPoolIndex | 334428 classInstVars := OrderedCollection new: 100. 334429 normal := Object class instSize. 334430 clsPoolIndex := Object class allInstVarNames indexOf: 'classPool'. 334431 self uniClasesDo: [:aUniClass | 334432 list := OrderedCollection new. 334433 mySize := aUniClass class instSize. 334434 mySize = normal ifFalse: 334435 [list add: aUniClass name. "a symbol" 334436 list add: 'Update to read classPool'. "new 334437convention for saving the classPool" 334438 list add: (aUniClass instVarAt: clsPoolIndex) 334439"classPool". 334440 "write actual value of nil 334441instead of Dictionary()" 334442 normal + 1 to: mySize do: [:ii | 334443 list addLast: (aUniClass instVarAt: ii)]. 334444 classInstVars add: list asArray]]. 334445 classInstVars := classInstVars asArray. 334446 ! ! 334447 334448!SmartRefStream methodsFor: 'read write' stamp: 'tk 8/18/1998 09:02'! 334449scanFrom: aByteStream 334450 "During a code fileIn, we need to read in an object, and stash it in ScannedObject. " 334451 334452 self setStream: aByteStream reading: true. 334453 ScannedObject := self next. 334454 byteStream ascii. 334455 byteStream next == $!! ifFalse: [ 334456 byteStream close. 334457 self error: 'Object did not end correctly']. 334458 "caller will close the byteStream" 334459 "HandMorph.readMorphFile will retrieve the ScannedObject"! ! 334460 334461!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 16:57'! 334462setStream: aStream 334463 "Initialize me. " 334464 334465 self flag: #bobconv. 334466 334467 super setStream: aStream. 334468 self initShapeDicts. 334469 334470! ! 334471 334472!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 16:57'! 334473setStream: aStream reading: isReading 334474 "Initialize me. " 334475 334476 self flag: #bobconv. 334477 334478 super setStream: aStream reading: isReading. 334479 isReading ifFalse: [^ false]. 334480 self initShapeDicts. 334481 334482! ! 334483 334484!SmartRefStream methodsFor: 'read write'! 334485structures 334486 ^ structures! ! 334487 334488!SmartRefStream methodsFor: 'read write' stamp: 'tk 9/28/97 11:17'! 334489superclasses 334490 ^superclasses! ! 334491 334492!SmartRefStream methodsFor: 'read write' stamp: 'tk 3/6/2000 17:15'! 334493uniClasesDo: aBlock 334494 "Examine structures and execute the block with each instance-specific class" 334495 334496 | cls | 334497 structures keysDo: [:clsName | 334498 (clsName endsWith: ' class') ifFalse: [ 334499 (cls := Smalltalk at: clsName) isSystemDefined ifFalse: [ 334500 aBlock value: cls]]]! ! 334501 334502!SmartRefStream methodsFor: 'read write' stamp: 'tk 1/18/2001 15:54'! 334503uniClassInstVarsRefs: dummy 334504 "If some of the objects seen so far are instances UniClasses, check the UniClasses for extra class inst vars, and send them to the steam also. The new objects get added to (dummy references), where they will be noticed by the caller. They will wind up in the structures array and will be written on the disk by class. 334505 Return all classes seen." 334506| uniClasses normal more aUniClass mySize allClasses | 334507 334508"Note: Any classes used in the structure of classInstVars must be written out also!!" 334509uniClasses := Set new. 334510allClasses := IdentitySet new. 334511normal := Object class instSize. 334512more := true. 334513[more] whileTrue: [ 334514 more := false. 334515 dummy references keysDo: [:each | "any faster way to do this?" 334516 (aUniClass := each class) isSystemDefined ifFalse: [ 334517 (uniClasses includes: aUniClass name) ifFalse: [ 334518 mySize := aUniClass class instSize. 334519 normal+1 to: mySize do: [:ii | 334520 more := true. 334521 dummy nextPut: (aUniClass instVarAt: ii)]. 334522 uniClasses add: aUniClass name]]. 334523 each class class isMeta ifFalse: ["it is a class" allClasses add: each]]]. 334524"References dictionary is modified as the loop proceeds, but we will catch any we missed on the next cycle." 334525 334526^ allClasses! ! 334527 334528!SmartRefStream methodsFor: 'read write' stamp: 'ar 4/10/2005 18:52'! 334529verifyStructure 334530 "Compare the incoming inst var name lists with the existing classes. Prepare tables that will help to restructure those who need it (renamed, reshaped, steady). If all superclasses are recorded in the file, only compare inst vars of this class, not of superclasses. They will get their turn. " 334531 334532 334533 | newClass newList oldList converting | 334534 334535 self flag: #bobconv. 334536 334537 converting := OrderedCollection new. 334538 structures keysDo: [:nm "an old className (symbol)" | 334539 "For missing classes, there needs to be a method in SmartRefStream like 334540 #rectangleoc2 that returns the new class." 334541 newClass := self mapClass: nm. "does (renamed at: nm put: newClass name)" 334542 newClass isString ifTrue: [^ newClass]. "error, fileIn needed" 334543 newList := (Array with: newClass classVersion), (newClass allInstVarNames). 334544 oldList := structures at: nm. 334545 newList = oldList 334546 ifTrue: [steady add: newClass] "read it in as written" 334547 ifFalse: [converting add: newClass name] 334548 ]. 334549 false & converting isEmpty not ifTrue: ["debug" 334550 self inform: 'These classes are being converted from existing methods:\' withCRs, 334551 converting asArray printString]. 334552! ! 334553 334554!SmartRefStream methodsFor: 'read write' stamp: 'tk 1/7/97'! 334555versionSymbol: instVarList 334556 "Create the symbolic code (like a version number) for this class in some older version. First initials of all the inst vars, followed by the class version number. Returns a string, caller makes it into a compound selector. " 334557 334558 | str | 334559 str := instVarList size = 1 ifFalse: [''] ifTrue: ['x']. "at least one letter" 334560 2 to: instVarList size do: [:ind | 334561 str := str, (instVarList at: ind) first asString]. 334562 str := str, instVarList first printString. "the number" 334563 ^ str 334564 334565" | list | list := (Array with: Paragraph classVersion), (Paragraph alistInstVarNames). 334566(SmartRefStream on: (DummyStream on: nil)) versionSymbol: list 334567"! ! 334568 334569"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 334570 334571SmartRefStream class 334572 instanceVariableNames: ''! 334573 334574!SmartRefStream class methodsFor: 'accessing' stamp: 'tk 5/20/97'! 334575scannedObject 334576 "The most recently read in object. Watch out for read-in that is interrupted and resumed. May want to make this a dictionary? " 334577 334578 ^ ScannedObject! ! 334579 334580!SmartRefStream class methodsFor: 'accessing' stamp: 'tk 5/20/97'! 334581scannedObject: objOrNil 334582 "Used to free up the last object stashed here. " 334583 334584 ScannedObject := objOrNil! ! 334585 334586!SmartRefStream class methodsFor: 'accessing' stamp: 'tk 3/11/98 09:45'! 334587subObjects: anObject ofClass: aClass 334588 "Return a collection of all instances of aClass that would be written out with anObject. Does not actually write on the disk. Inspect the result and ask for 'references to this object'." 334589 334590 | dummy coll | 334591 dummy := ReferenceStream on: (DummyStream on: nil). 334592 "Write to a fake Stream, not a file" 334593 "Collect all objects" 334594 dummy rootObject: anObject. "inform him about the root" 334595 dummy nextPut: anObject. 334596 coll := OrderedCollection new. 334597 dummy references keysDo: [:each | 334598 each class == aClass ifTrue: [coll add: each]]. 334599 ^ coll! ! 334600 334601 334602!SmartRefStream class methodsFor: 'i/o' stamp: 'RAA 7/9/2000 05:48'! 334603objectFromStreamedRepresentation: someBytes 334604 334605 | file | 334606 334607 file := RWBinaryOrTextStream with: someBytes. 334608 file reset. 334609 ^file fileInObjectAndCode! ! 334610 334611!SmartRefStream class methodsFor: 'i/o' stamp: 'tk 12/9/97 21:31'! 334612read: aByteStream withClasses: structureArray 334613 "Read an object off the stream, but first check structureArray against the current system." 334614 334615 | me | 334616 me := self on: aByteStream. 334617 me noHeader. 334618 me structures: (structureArray at: 2). 334619 me superclasses: (structureArray at: 4). 334620 (me verifyStructure = 'conversion method needed') ifTrue: [^ nil]. 334621 ^ super next 334622! ! 334623 334624!SmartRefStream class methodsFor: 'i/o' stamp: 'tk 5/20/97'! 334625scanFrom: aByteStream 334626 "During a code fileIn, we need to read in an object, and stash it in ScannedObject. " 334627 334628 | me | 334629 me := self on: aByteStream. 334630 ScannedObject := me next. 334631 aByteStream ascii. 334632 aByteStream next == $!! ifFalse: [ 334633 aByteStream close. 334634 self error: 'Object did not end correctly']. 334635 "caller will close the byteStream" 334636 "HandMorph.readMorphFile will retrieve the ScannedObject"! ! 334637 334638 334639!SmartRefStream class methodsFor: 'initialization' stamp: 'dvf 8/23/2003 12:18'! 334640cleanUpCategories 334641 | list valid removed newList newVers | 334642 "Look for all conversion methods that can't be used any longer. Delete them." 334643 " SmartRefStream cleanUpCategories " 334644 334645 "Two part selectors that begin with convert and end with a digit." 334646 "convertasossfe0: varDict asossfeu0: smartRefStrm" 334647 list := Symbol selectorsContaining: 'convert'. 334648 list := list select: [:symb | (symb beginsWith: 'convert') & (symb allButLast last isDigit) 334649 ifTrue: [(symb numArgs = 2)] 334650 ifFalse: [false]]. 334651 valid := 0. removed := 0. 334652 list do: [:symb | 334653 (self systemNavigation allClassesImplementing: symb) do: [:newClass | 334654 newList := (Array with: newClass classVersion), (newClass allInstVarNames). 334655 newVers := self new versionSymbol: newList. 334656 (symb endsWith: (':',newVers,':')) 334657 ifFalse: [ 334658 "method is useless because can't convert to current shape" 334659 newClass removeSelector: symb. "get rid of it" 334660 removed := removed + 1] 334661 ifTrue: [valid := valid + 1]]]. 334662 Transcript cr; show: 'Removed: '; print: removed; 334663 show: ' Kept: '; print: valid; show: ' '.! ! 334664 334665 334666!SmartRefStream class methodsFor: 'utilities' stamp: 'tk 5/4/1998 17:34'! 334667statsOfSubObjects: anObject 334668 "Open a window with statistics on what objects would be written out with anObject. Does not actually write on the disk. Stats in the form: 334669 ScriptEditorMorph 51 334670 SortedCollection (21->LayoutMorph 15->SimpleButtonMorph 9->Array 4->CompoundTileMorph 2->StringMorph )" 334671 334672 | dummy printOut | 334673 dummy := ReferenceStream on: (DummyStream on: nil). 334674 "Write to a fake Stream, not a file" 334675 "Collect all objects" 334676 dummy rootObject: anObject. "inform him about the root" 334677 dummy nextPut: anObject. 334678 "(dummy references) is the raw data" 334679 printOut := dummy statisticsOfRefs. 334680 (StringHolder new contents: printOut) 334681 openLabel: 'ReferenceStream statistics'.! ! 334682 334683!SmartRefStream class methodsFor: 'utilities' stamp: 'RAA 7/9/2000 05:35'! 334684streamedRepresentationOf: anObject 334685 334686 | file | 334687 file := (RWBinaryOrTextStream on: (ByteArray new: 5000)). 334688 file binary. 334689 (self on: file) nextPut: anObject. 334690 file close. 334691 ^file contents! ! 334692 334693!SmartRefStream class methodsFor: 'utilities' stamp: 'tk 5/4/1998 17:34'! 334694tallyOfSubObjects: anObject 334695 "Open a window with statistics on what objects would be written out with anObject. Does not actually write on the disk. Stats are simply the number of instances of each class: 334696 1450->Point 835->Rectangle 549->Array 300->String" 334697 334698 | dummy bag | 334699 dummy := ReferenceStream on: (DummyStream on: nil). 334700 "Write to a fake Stream, not a file" 334701 "Collect all objects" 334702 dummy rootObject: anObject. "inform him about the root" 334703 dummy nextPut: anObject. 334704 bag := Bag new. 334705 dummy references keysDo: [:key | bag add: key class name]. 334706 "(bag sortedCounts) is the SortedCollection" 334707 (StringHolder new contents: bag sortedCounts printString) 334708 openLabel: 'ReferenceStream statistics'.! ! 334709Object subclass: #Socket 334710 instanceVariableNames: 'semaphore socketHandle readSemaphore writeSemaphore primitiveOnlySupportsOneSemaphore' 334711 classVariableNames: 'Connected DeadServer InvalidSocket OtherEndClosed Registry RegistryThreshold TCPSocketType ThisEndClosed UDPSocketType Unconnected WaitingForConnection' 334712 poolDictionaries: '' 334713 category: 'Network-Kernel'! 334714!Socket commentStamp: 'gk 12/13/2005 00:43' prior: 0! 334715A Socket represents a network connection point. Current sockets are designed to support the TCP/IP and UDP protocols. Sockets are the lowest level of networking object in Squeak and are not normally used directly. SocketStream is a higher level object wrapping a Socket in a stream like protocol. 334716 334717ProtocolClient and subclasses are in turn wrappers around a SocketStream to provide support for specific network protocols such as POP, NNTP, HTTP, and FTP.! 334718 334719 334720!Socket methodsFor: 'accessing' stamp: 'ar 4/30/1999 04:25'! 334721address 334722 "Shortcut" 334723 ^self localAddress! ! 334724 334725!Socket methodsFor: 'accessing' stamp: 'MU 11/26/2003 16:53'! 334726localAddress 334727 self isWaitingForConnection 334728 ifFalse: [[self waitForConnectionFor: Socket standardTimeout] 334729 on: ConnectionTimedOut 334730 do: [:ex | ^ ByteArray new: 4]]. 334731 ^ self primSocketLocalAddress: socketHandle! ! 334732 334733!Socket methodsFor: 'accessing' stamp: 'MU 11/26/2003 16:53'! 334734localPort 334735 self isWaitingForConnection 334736 ifFalse: [[self waitForConnectionFor: Socket standardTimeout] 334737 on: ConnectionTimedOut 334738 do: [:ex | ^ 0]]. 334739 ^ self primSocketLocalPort: socketHandle! ! 334740 334741!Socket methodsFor: 'accessing' stamp: 'mir 6/17/2007 19:56'! 334742peerName 334743 "Return the name of the host I'm connected to, or nil if its name isn't known to the domain name server or the request times out." 334744 "Note: Slow. Calls the domain name server, taking up to 20 seconds to time out. Even when sucessful, delays of up to 13 seconds have been observed during periods of high network load." 334745 334746 ^self remoteSocketAddress hostName! ! 334747 334748!Socket methodsFor: 'accessing' stamp: 'ar 4/30/1999 04:25'! 334749port 334750 "Shortcut" 334751 ^self localPort! ! 334752 334753!Socket methodsFor: 'accessing' stamp: 'JMM 6/5/2000 10:12'! 334754primitiveOnlySupportsOneSemaphore 334755 ^primitiveOnlySupportsOneSemaphore! ! 334756 334757!Socket methodsFor: 'accessing' stamp: 'JMM 5/22/2000 22:49'! 334758readSemaphore 334759 primitiveOnlySupportsOneSemaphore ifTrue: [^semaphore]. 334760 ^readSemaphore! ! 334761 334762!Socket methodsFor: 'accessing' stamp: 'mu 9/30/2007 04:38'! 334763remoteAddress 334764 334765 ^ self primSocketRemoteAddress: socketHandle! ! 334766 334767!Socket methodsFor: 'accessing' stamp: 'jm 9/17/97 14:34'! 334768remotePort 334769 334770 ^ self primSocketRemotePort: socketHandle 334771! ! 334772 334773!Socket methodsFor: 'accessing' stamp: 'JMM 5/9/2000 15:32'! 334774semaphore 334775 ^semaphore! ! 334776 334777!Socket methodsFor: 'accessing' stamp: 'ar 7/16/1999 17:22'! 334778socketHandle 334779 ^socketHandle! ! 334780 334781!Socket methodsFor: 'accessing' stamp: 'JMM 5/22/2000 22:49'! 334782writeSemaphore 334783 primitiveOnlySupportsOneSemaphore ifTrue: [^semaphore]. 334784 ^writeSemaphore! ! 334785 334786 334787!Socket methodsFor: 'connection open/close' stamp: 'bolot 7/16/1999 14:36'! 334788accept 334789 "Accept a connection from the receiver socket. 334790 Return a new socket that is connected to the client" 334791 ^Socket acceptFrom: self.! ! 334792 334793!Socket methodsFor: 'connection open/close' stamp: 'jm 9/11/97 20:29'! 334794close 334795 "Close this connection gracefully. For TCP, this sends a close request, but the stream remains open until the other side also closes it." 334796 334797 self primSocketCloseConnection: socketHandle. "close this end" 334798! ! 334799 334800!Socket methodsFor: 'connection open/close' stamp: 'jm 11/4/97 07:15'! 334801closeAndDestroy 334802 "First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)." 334803 334804 self closeAndDestroy: 20. 334805 334806! ! 334807 334808!Socket methodsFor: 'connection open/close' stamp: 'marcus.denker 9/14/2008 21:20'! 334809closeAndDestroy: timeoutSeconds 334810 "First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)." 334811 334812 socketHandle ifNotNil: [ 334813 self isConnected ifTrue: [ 334814 self close. "close this end" 334815 (self waitForDisconnectionFor: timeoutSeconds) ifFalse: [ 334816 "The other end didn't close so we just abort the connection" 334817 self primSocketAbortConnection: socketHandle]]. 334818 self destroy]. 334819! ! 334820 334821!Socket methodsFor: 'connection open/close' stamp: 'michael.rueger 3/30/2009 13:48'! 334822connectNonBlockingTo: hostAddress port: port 334823 "Initiate a connection to the given port at the given host address. This operation will return immediately; follow it with waitForConnectionUntil: to wait until the connection is established." 334824 334825 | status | 334826 self initializeNetwork. 334827 status := self primSocketConnectionStatus: socketHandle. 334828 (status == Unconnected) 334829 ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before opening a new connection']. 334830 334831 NetNameResolver useOldNetwork 334832 ifTrue: [self primSocket: socketHandle connectTo: hostAddress port: port] 334833 ifFalse: [ 334834 hostAddress port: port. 334835 self connectNonBlockingTo: hostAddress]! ! 334836 334837!Socket methodsFor: 'connection open/close' stamp: 'mir 6/26/2007 18:52'! 334838connectTo: hostAddress port: port 334839 "Initiate a connection to the given port at the given host address. 334840 Waits until the connection is established or time outs." 334841 334842 NetNameResolver useOldNetwork 334843 ifTrue: [self connectTo: hostAddress port: port waitForConnectionFor: Socket standardTimeout] 334844 ifFalse: [ 334845 hostAddress port: port. 334846 self connectTo: hostAddress]! ! 334847 334848!Socket methodsFor: 'connection open/close' stamp: 'norbert_hartl 6/12/2009 08:32'! 334849connectTo: hostAddress port: port waitForConnectionFor: timeout 334850 "Initiate a connection to the given port at the given host 334851 address. Waits until the connection is established or time outs." 334852 self connectNonBlockingTo: hostAddress port: port. 334853 self 334854 waitForConnectionFor: timeout 334855 ifTimedOut: [ConnectionTimedOut signal: 'Cannot connect to ' 334856 , hostAddress hostNumber , ':' , port asString]! ! 334857 334858!Socket methodsFor: 'connection open/close' stamp: 'mir 5/8/2003 16:03'! 334859connectToHostNamed: hostName port: portNumber 334860 | serverIP | 334861 serverIP := NetNameResolver addressForName: hostName timeout: 20. 334862 ^self connectTo: serverIP port: portNumber 334863! ! 334864 334865!Socket methodsFor: 'connection open/close' stamp: 'jm 3/10/98 11:56'! 334866disconnect 334867 "Break this connection, no matter what state it is in. Data that has been sent but not received will be lost." 334868 334869 self primSocketAbortConnection: socketHandle. 334870! ! 334871 334872!Socket methodsFor: 'connection open/close' stamp: 'mir 2/22/2002 16:25'! 334873listenOn: port 334874 "Listen for a connection on the given port. This operation will return immediately; follow it with waitForConnectionUntil: to wait until a connection is established." 334875 334876 | status | 334877 status := self primSocketConnectionStatus: socketHandle. 334878 (status == Unconnected) 334879 ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before listening for a new connection']. 334880 334881 self primSocket: socketHandle listenOn: port. 334882! ! 334883 334884!Socket methodsFor: 'connection open/close' stamp: 'mir 2/22/2002 16:25'! 334885listenOn: portNumber backlogSize: backlog 334886 "Listen for a connection on the given port. 334887 If this method succeeds, #accept may be used to establish a new connection" 334888 | status | 334889 status := self primSocketConnectionStatus: socketHandle. 334890 (status == Unconnected) 334891 ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before listening for a new connection']. 334892 self primSocket: socketHandle listenOn: portNumber backlogSize: backlog. 334893! ! 334894 334895!Socket methodsFor: 'connection open/close' stamp: 'ikp 9/1/2003 20:32'! 334896listenOn: portNumber backlogSize: backlog interface: ifAddr 334897 "Listen for a connection on the given port. 334898 If this method succeeds, #accept may be used to establish a new connection" 334899 | status | 334900 status := self primSocketConnectionStatus: socketHandle. 334901 (status == Unconnected) 334902 ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before listening for a new connection']. 334903 self primSocket: socketHandle listenOn: portNumber backlogSize: backlog interface: ifAddr. 334904! ! 334905 334906 334907!Socket methodsFor: 'datagrams' stamp: 'JMM 6/7/2000 14:58'! 334908receiveDataInto: aStringOrByteArray fromHost: hostAddress port: portNumber 334909 | datagram | 334910 "Receive a UDP packet from the given hostAddress/portNumber, storing the data in the given buffer, and return the number of bytes received. Note the given buffer may be only partially filled by the received data." 334911 334912 primitiveOnlySupportsOneSemaphore ifTrue: 334913 [self setPeer: hostAddress port: portNumber. 334914 ^self receiveDataInto: aStringOrByteArray]. 334915 [true] whileTrue: 334916 [datagram := self receiveUDPDataInto: aStringOrByteArray. 334917 ((datagram at: 2) = hostAddress and: [(datagram at: 3) = portNumber]) 334918 ifTrue: [^datagram at: 1] 334919 ifFalse: [^0]]! ! 334920 334921!Socket methodsFor: 'datagrams' stamp: 'JMM 6/3/2000 21:54'! 334922receiveUDPDataInto: aStringOrByteArray 334923 "Receive UDP data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data. What is returned is an array, the first element is the bytes read, the second the sending bytearray address, the third the senders port, the fourth, true if more of the datagram awaits reading" 334924 334925 ^ self primSocket: socketHandle 334926 receiveUDPDataInto: aStringOrByteArray 334927 startingAt: 1 334928 count: aStringOrByteArray size 334929! ! 334930 334931!Socket methodsFor: 'datagrams' stamp: 'JMM 5/25/2000 00:05'! 334932sendData: aStringOrByteArray toHost: hostAddress port: portNumber 334933 "Send a UDP packet containing the given data to the specified host/port." 334934 334935 primitiveOnlySupportsOneSemaphore ifTrue: 334936 [self setPeer: hostAddress port: portNumber. 334937 ^self sendData: aStringOrByteArray]. 334938 ^self sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber! ! 334939 334940!Socket methodsFor: 'datagrams' stamp: 'mir 5/15/2003 18:34'! 334941sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber 334942 "Send a UDP packet containing the given data to the specified host/port." 334943 | bytesToSend bytesSent count | 334944 334945 bytesToSend := aStringOrByteArray size. 334946 bytesSent := 0. 334947 [bytesSent < bytesToSend] whileTrue: [ 334948 (self waitForSendDoneFor: 20) 334949 ifFalse: [ConnectionTimedOut signal: 'send data timeout; data not sent']. 334950 count := self primSocket: socketHandle 334951 sendUDPData: aStringOrByteArray 334952 toHost: hostAddress 334953 port: portNumber 334954 startIndex: bytesSent + 1 334955 count: bytesToSend - bytesSent. 334956 bytesSent := bytesSent + count]. 334957 334958 ^ bytesSent 334959! ! 334960 334961!Socket methodsFor: 'datagrams' stamp: 'ar 4/30/1999 04:29'! 334962setPeer: hostAddress port: port 334963 "Set the default send/recv address." 334964 334965 self primSocket: socketHandle connectTo: hostAddress port: port. 334966! ! 334967 334968!Socket methodsFor: 'datagrams' stamp: 'ar 4/30/1999 04:29'! 334969setPort: port 334970 "Associate a local port number with a UDP socket. Not applicable to TCP sockets." 334971 334972 self primSocket: socketHandle setPort: port. 334973! ! 334974 334975 334976!Socket methodsFor: 'deprecated-ROLL OVER BUG' stamp: 'dc 10/21/2008 07:47'! 334977waitForAcceptUntil: deadLine 334978 "Wait and accept an incoming connection" 334979 self waitForConnectionUntil: deadLine. 334980 ^self isConnected 334981 ifTrue:[self accept] 334982 ifFalse:[nil]! ! 334983 334984!Socket methodsFor: 'deprecated-ROLL OVER BUG' stamp: 'mir 6/17/2007 21:18'! 334985waitForConnectionUntil: deadline 334986 "Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not." 334987 334988 | status | 334989 status := self primSocketConnectionStatus: socketHandle. 334990 [(status = WaitingForConnection) and: [Time millisecondClockValue < deadline]] 334991 whileTrue: [ 334992 semaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue). 334993 status := self primSocketConnectionStatus: socketHandle]. 334994 334995 ^ status = Connected 334996! ! 334997 334998!Socket methodsFor: 'deprecated-ROLL OVER BUG' stamp: 'dc 10/21/2008 08:47'! 334999waitForConnectionUntil: deadline ifTimedOut: timeoutBlock 335000 "Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not." 335001 335002 | status | 335003 status := self primSocketConnectionStatus: socketHandle. 335004 [(status = WaitingForConnection) and: [Time millisecondClockValue < deadline]] 335005 whileTrue: [ 335006 semaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue). 335007 status := self primSocketConnectionStatus: socketHandle]. 335008 335009 status = Connected ifFalse: [^timeoutBlock value]. 335010 ^ true 335011! ! 335012 335013!Socket methodsFor: 'deprecated-ROLL OVER BUG' stamp: 'dc 10/21/2008 08:05'! 335014waitForDataUntil: deadline 335015 "Wait up until the given deadline for data to arrive. Return true if data arrives by the deadline, false if not." 335016 self waitForDataUntil: deadline ifClosed: [^ false] ifTimedOut: [^ false]. 335017 ^ true! ! 335018 335019!Socket methodsFor: 'deprecated-ROLL OVER BUG' stamp: 'dc 10/21/2008 08:08'! 335020waitForDataUntil: deadline ifClosed: closedBlock ifTimedOut: timedOutBlock 335021 "Wait for the given nr of seconds for data to arrive." 335022 [Time millisecondClockValue < deadline] 335023 whileTrue: [(self primSocketReceiveDataAvailable: socketHandle) ifTrue: [^self]. 335024 self isConnected ifFalse: [^closedBlock value]. 335025 self readSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue)]. 335026 (self primSocketReceiveDataAvailable: socketHandle) 335027 ifFalse: [self isConnected 335028 ifTrue: [^timedOutBlock value] 335029 ifFalse: [^closedBlock value]]! ! 335030 335031!Socket methodsFor: 'deprecated-ROLL OVER BUG' stamp: 'dc 10/21/2008 08:03'! 335032waitForDisconnectionUntil: deadline 335033 "Wait for the given nr of seconds for the connection to be broken. 335034 Return true if it is broken by the deadline, false if not. 335035 The client should know the connection is really going to be closed 335036 (e.g., because he has called 'close' to send a close request to the other end) 335037 before calling this method." 335038 | status | 335039 status := self primSocketConnectionStatus: socketHandle. 335040 [((status == Connected) or: [(status == ThisEndClosed)]) and: 335041 [Time millisecondClockValue < deadline]] whileTrue: [ 335042 self discardReceivedData. 335043 self readSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue). 335044 status := self primSocketConnectionStatus: socketHandle]. 335045 335046 ^ status ~= Connected! ! 335047 335048!Socket methodsFor: 'deprecated-ROLL OVER BUG' stamp: 'dc 10/21/2008 08:01'! 335049waitForSendDoneUntil: deadline 335050 "Wait up until the given deadline for the current send operation to complete. Return true if it completes by the deadline, false if not." 335051 | sendDone | 335052 [self isConnected & (sendDone := self primSocketSendDone: socketHandle) not 335053 "Connection end and final data can happen fast, so test in this order" 335054 and: [Time millisecondClockValue < deadline]] whileTrue: [ 335055 self writeSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue)]. 335056 335057 ^ sendDone! ! 335058 335059 335060!Socket methodsFor: 'finalization' stamp: 'JMM 5/22/2000 22:52'! 335061finalize 335062 self primSocketDestroyGently: socketHandle. 335063 Smalltalk unregisterExternalObject: semaphore. 335064 Smalltalk unregisterExternalObject: readSemaphore. 335065 Smalltalk unregisterExternalObject: writeSemaphore. 335066! ! 335067 335068 335069!Socket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 22:47'! 335070acceptFrom: aSocket 335071 "Initialize a new socket handle from an accept call" 335072 | semaIndex readSemaIndex writeSemaIndex | 335073 335074 primitiveOnlySupportsOneSemaphore := false. 335075 semaphore := Semaphore new. 335076 readSemaphore := Semaphore new. 335077 writeSemaphore := Semaphore new. 335078 semaIndex := Smalltalk registerExternalObject: semaphore. 335079 readSemaIndex := Smalltalk registerExternalObject: readSemaphore. 335080 writeSemaIndex := Smalltalk registerExternalObject: writeSemaphore. 335081 socketHandle := self primAcceptFrom: aSocket socketHandle 335082 receiveBufferSize: 8000 335083 sendBufSize: 8000 335084 semaIndex: semaIndex 335085 readSemaIndex: readSemaIndex 335086 writeSemaIndex: writeSemaIndex. 335087 socketHandle = nil ifTrue: [ "socket creation failed" 335088 Smalltalk unregisterExternalObject: semaphore. 335089 Smalltalk unregisterExternalObject: readSemaphore. 335090 Smalltalk unregisterExternalObject: writeSemaphore. 335091 readSemaphore := writeSemaphore := semaphore := nil 335092 ] ifFalse:[self register]. 335093! ! 335094 335095!Socket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 22:54'! 335096destroy 335097 "Destroy this socket. Its connection, if any, is aborted and its resources are freed. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)." 335098 335099 socketHandle = nil ifFalse: 335100 [self isValid ifTrue: [self primSocketDestroy: socketHandle]. 335101 Smalltalk unregisterExternalObject: semaphore. 335102 Smalltalk unregisterExternalObject: readSemaphore. 335103 Smalltalk unregisterExternalObject: writeSemaphore. 335104 socketHandle := nil. 335105 readSemaphore := writeSemaphore := semaphore := nil. 335106 self unregister]. 335107! ! 335108 335109!Socket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 23:04'! 335110initialize: socketType 335111 "Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil." 335112 | semaIndex readSemaIndex writeSemaIndex | 335113 335114 primitiveOnlySupportsOneSemaphore := false. 335115 semaphore := Semaphore new. 335116 readSemaphore := Semaphore new. 335117 writeSemaphore := Semaphore new. 335118 semaIndex := Smalltalk registerExternalObject: semaphore. 335119 readSemaIndex := Smalltalk registerExternalObject: readSemaphore. 335120 writeSemaIndex := Smalltalk registerExternalObject: writeSemaphore. 335121 socketHandle := 335122 self primSocketCreateNetwork: 0 335123 type: socketType 335124 receiveBufferSize: 8000 335125 sendBufSize: 8000 335126 semaIndex: semaIndex 335127 readSemaIndex: readSemaIndex 335128 writeSemaIndex: writeSemaIndex. 335129 335130 socketHandle = nil ifTrue: [ "socket creation failed" 335131 Smalltalk unregisterExternalObject: semaphore. 335132 Smalltalk unregisterExternalObject: readSemaphore. 335133 Smalltalk unregisterExternalObject: writeSemaphore. 335134 readSemaphore := writeSemaphore := semaphore := nil 335135 ] ifFalse:[self register]. 335136! ! 335137 335138!Socket methodsFor: 'initialize-destroy' stamp: 'mir 6/26/2007 18:44'! 335139initialize: socketType family: family 335140 "Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil." 335141 | semaIndex readSemaIndex writeSemaIndex | 335142 335143 NetNameResolver useOldNetwork ifTrue: [^self initialize: socketType]. 335144 primitiveOnlySupportsOneSemaphore := false. 335145 semaphore := Semaphore new. 335146 readSemaphore := Semaphore new. 335147 writeSemaphore := Semaphore new. 335148 semaIndex := Smalltalk registerExternalObject: semaphore. 335149 readSemaIndex := Smalltalk registerExternalObject: readSemaphore. 335150 writeSemaIndex := Smalltalk registerExternalObject: writeSemaphore. 335151 socketHandle := 335152 self primSocketCreateNetwork: family 335153 type: socketType 335154 receiveBufferSize: 8000 335155 sendBufSize: 8000 335156 semaIndex: semaIndex 335157 readSemaIndex: readSemaIndex 335158 writeSemaIndex: writeSemaIndex. 335159 335160 socketHandle = nil ifTrue: [ "socket creation failed" 335161 Smalltalk unregisterExternalObject: semaphore. 335162 Smalltalk unregisterExternalObject: readSemaphore. 335163 Smalltalk unregisterExternalObject: writeSemaphore. 335164 readSemaphore := writeSemaphore := semaphore := nil 335165 ] ifFalse:[self register]. 335166! ! 335167 335168!Socket methodsFor: 'initialize-destroy' stamp: 'mir 2/22/2002 15:48'! 335169initializeNetwork 335170 self class initializeNetwork! ! 335171 335172 335173!Socket methodsFor: 'ipv6' stamp: 'ikp 6/9/2007 09:35'! 335174bindTo: aSocketAddress 335175 335176 | status | 335177 self initializeNetwork. 335178 status := self primSocketConnectionStatus: socketHandle. 335179 (status == Unconnected) 335180 ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected when binding it to an address']. 335181 335182 self primSocket: socketHandle bindTo: aSocketAddress. 335183! ! 335184 335185!Socket methodsFor: 'ipv6' stamp: 'ikp 6/8/2007 22:11'! 335186connectNonBlockingTo: aSocketAddress 335187 335188 | status | 335189 self initializeNetwork. 335190 status := self primSocketConnectionStatus: socketHandle. 335191 (status == Unconnected) 335192 ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before opening a new connection']. 335193 335194 self primSocket: socketHandle connectTo: aSocketAddress. 335195! ! 335196 335197!Socket methodsFor: 'ipv6' stamp: 'ikp 6/8/2007 22:09'! 335198connectTo: aSocketAddress 335199 335200 self connectTo: aSocketAddress waitForConnectionFor: Socket standardTimeout! ! 335201 335202!Socket methodsFor: 'ipv6' stamp: 'ikp 6/8/2007 22:10'! 335203connectTo: aSocketAddress waitForConnectionFor: timeout 335204 335205 self connectNonBlockingTo: aSocketAddress. 335206 self 335207 waitForConnectionFor: timeout 335208 ifTimedOut: [ConnectionTimedOut signal: 'Cannot connect to ', aSocketAddress printString]! ! 335209 335210!Socket methodsFor: 'ipv6' stamp: 'ikp 6/9/2007 09:39'! 335211listenWithBacklog: backlogSize 335212 335213 | status | 335214 self initializeNetwork. 335215 status := self primSocketConnectionStatus: socketHandle. 335216 (status == Unconnected) 335217 ifFalse: [InvalidSocketStatusException signal: 'Socket status must Unconnected before it can listen for connections']. 335218 335219 self primSocket: socketHandle listenWithBacklog: backlogSize. 335220! ! 335221 335222!Socket methodsFor: 'ipv6' stamp: 'ikp 6/9/2007 10:28'! 335223localSocketAddress 335224 335225 | size addr | 335226 size := self primSocketLocalAddressSize: socketHandle. 335227 addr := SocketAddress new: size. 335228 self primSocket: socketHandle localAddressResult: addr. 335229 ^addr! ! 335230 335231!Socket methodsFor: 'ipv6' stamp: 'ikp 6/9/2007 10:28'! 335232remoteSocketAddress 335233 335234 | size addr | 335235 size := self primSocketRemoteAddressSize: socketHandle. 335236 addr := SocketAddress new: size. 335237 self primSocket: socketHandle remoteAddressResult: addr. 335238 ^addr! ! 335239 335240 335241!Socket methodsFor: 'other' stamp: 'mir 2/22/2002 16:25'! 335242getOption: aName 335243 "Get options on this socket, see Unix man pages for values for 335244 sockets, IP, TCP, UDP. IE SO:=KEEPALIVE 335245 returns an array, element one is an status number (0 ok, -1 read only option) 335246 element two is the resulting of the requested option" 335247 335248 (socketHandle == nil or: [self isValid not]) 335249 ifTrue: [InvalidSocketStatusException signal: 'Socket status must valid before getting an option']. 335250 ^self primSocket: socketHandle getOption: aName 335251 335252"| foo options | 335253Socket initializeNetwork. 335254foo := Socket newTCP. 335255foo connectTo: (NetNameResolver addressFromString: '192.168.1.1') port: 80. 335256foo waitForConnectionUntil: (Socket standardDeadline). 335257 335258options := { 335259'SO:=DEBUG'. 'SO:=REUSEADDR'. 'SO:=REUSEPORT'. 'SO:=DONTROUTE'. 335260'SO:=BROADCAST'. 'SO:=SNDBUF'. 'SO:=RCVBUF'. 'SO:=KEEPALIVE'. 335261'SO:=OOBINLINE'. 'SO:=PRIORITY'. 'SO:=LINGER'. 'SO:=RCVLOWAT'. 335262'SO:=SNDLOWAT'. 'IP:=TTL'. 'IP:=HDRINCL'. 'IP:=RCVOPTS'. 335263'IP:=RCVDSTADDR'. 'IP:=MULTICAST:=IF'. 'IP:=MULTICAST:=TTL'. 335264'IP:=MULTICAST:=LOOP'. 'UDP:=CHECKSUM'. 'TCP:=MAXSEG'. 335265'TCP:=NODELAY'. 'TCP:=ABORT:=THRESHOLD'. 'TCP:=CONN:=NOTIFY:=THRESHOLD'. 335266'TCP:=CONN:=ABORT:=THRESHOLD'. 'TCP:=NOTIFY:=THRESHOLD'. 335267'TCP:=URGENT:=PTR:=TYPE'}. 335268 3352691 to: options size do: [:i | | fum | 335270 fum :=foo getOption: (options at: i). 335271 Transcript show: (options at: i),fum printString;cr]. 335272 335273foo := Socket newUDP. 335274foo setPeer: (NetNameResolver addressFromString: '192.168.1.9') port: 7. 335275foo waitForConnectionUntil: (Socket standardDeadline). 335276 3352771 to: options size do: [:i | | fum | 335278 fum :=foo getOption: (options at: i). 335279 Transcript show: (options at: i),fum printString;cr]. 335280"! ! 335281 335282!Socket methodsFor: 'other' stamp: 'mir 2/22/2002 16:30'! 335283setOption: aName value: aValue 335284 | value | 335285 "setup options on this socket, see Unix man pages for values for 335286 sockets, IP, TCP, UDP. IE SO:=KEEPALIVE 335287 returns an array, element one is the error number 335288 element two is the resulting of the negotiated value. 335289 See getOption for list of keys" 335290 335291 (socketHandle == nil or: [self isValid not]) 335292 ifTrue: [InvalidSocketStatusException signal: 'Socket status must valid before setting an option']. 335293 value := aValue asString. 335294 aValue == true ifTrue: [value := '1']. 335295 aValue == false ifTrue: [value := '0']. 335296 ^ self primSocket: socketHandle setOption: aName value: value! ! 335297 335298 335299!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335300primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex 335301 "Create and return a new socket handle based on accepting the connection from the given listening socket" 335302 <primitive: 'primitiveSocketAccept' module: 'SocketPlugin'> 335303 ^self primitiveFailed! ! 335304 335305!Socket methodsFor: 'primitives' stamp: 'JMM 5/22/2000 22:55'! 335306primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema 335307 "Create and return a new socket handle based on accepting the connection from the given listening socket" 335308 <primitive: 'primitiveSocketAccept3Semaphores' module: 'SocketPlugin'> 335309 primitiveOnlySupportsOneSemaphore := true. 335310 ^self primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex ! ! 335311 335312!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335313primSocket: socketID connectTo: hostAddress port: port 335314 "Attempt to establish a connection to the given port of the given host. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed." 335315 335316 <primitive: 'primitiveSocketConnectToPort' module: 'SocketPlugin'> 335317 self primitiveFailed 335318! ! 335319 335320!Socket methodsFor: 'primitives' stamp: 'JMM 5/25/2000 21:48'! 335321primSocket: socketID getOption: aString 335322 "Get some option information on this socket. Refer to the UNIX 335323 man pages for valid SO, TCP, IP, UDP options. In case of doubt 335324 refer to the source code. 335325 TCP:=NODELAY, SO:=KEEPALIVE are valid options for example 335326 returns an array containing the error code and the option value" 335327 335328 <primitive: 'primitiveSocketGetOptions' module: 'SocketPlugin'> 335329 self primitiveFailed 335330! ! 335331 335332!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335333primSocket: socketID listenOn: port 335334 "Listen for a connection on the given port. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed." 335335 335336 <primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'> 335337 self primitiveFailed 335338! ! 335339 335340!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335341primSocket: aHandle listenOn: portNumber backlogSize: backlog 335342 "Primitive. Set up the socket to listen on the given port. 335343 Will be used in conjunction with #accept only." 335344 <primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'> 335345 self destroy. "Accept not supported so clean up"! ! 335346 335347!Socket methodsFor: 'primitives' stamp: 'ikp 9/1/2003 20:33'! 335348primSocket: aHandle listenOn: portNumber backlogSize: backlog interface: ifAddr 335349 "Primitive. Set up the socket to listen on the given port. 335350 Will be used in conjunction with #accept only." 335351 <primitive: 'primitiveSocketListenOnPortBacklogInterface' module: 'SocketPlugin'> 335352 self destroy. "Accept not supported so clean up"! ! 335353 335354!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335355primSocket: socketID receiveDataInto: aStringOrByteArray startingAt: startIndex count: count 335356 "Receive data from the given socket into the given array starting at the given index. Return the number of bytes read or zero if no data is available." 335357 335358 <primitive: 'primitiveSocketReceiveDataBufCount' module: 'SocketPlugin'> 335359 self primitiveFailed 335360! ! 335361 335362!Socket methodsFor: 'primitives' stamp: 'JMM 5/24/2000 17:19'! 335363primSocket: socketID receiveUDPDataInto: aStringOrByteArray startingAt: startIndex count: count 335364 "Receive data from the given socket into the given array starting at the given index. 335365 Return an Array containing the amount read, the host address byte array, the host port, and the more flag" 335366 335367 <primitive: 'primitiveSocketReceiveUDPDataBufCount' module: 'SocketPlugin'> 335368 self primitiveFailed 335369! ! 335370 335371!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335372primSocket: socketID sendData: aStringOrByteArray startIndex: startIndex count: count 335373 "Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed." 335374 "Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created." 335375 335376 <primitive: 'primitiveSocketSendDataBufCount' module: 'SocketPlugin'> 335377 self primitiveFailed 335378! ! 335379 335380!Socket methodsFor: 'primitives' stamp: 'JMM 5/25/2000 00:08'! 335381primSocket: socketID sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber startIndex: startIndex count: count 335382 "Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed." 335383 "Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created." 335384 335385 <primitive: 'primitiveSocketSendUDPDataBufCount' module: 'SocketPlugin'> 335386 self primitiveFailed 335387 335388! ! 335389 335390!Socket methodsFor: 'primitives' stamp: 'ar 7/18/2000 11:42'! 335391primSocket: socketID setOption: aString value: aStringValue 335392 "Set some option information on this socket. Refer to the UNIX 335393 man pages for valid SO, TCP, IP, UDP options. In case of doubt 335394 refer to the source code. 335395 TCP:=NODELAY, SO:=KEEPALIVE are valid options for example 335396 returns an array containing the error code and the negotiated value" 335397 335398 <primitive: 'primitiveSocketSetOptions' module: 'SocketPlugin'> 335399 ^nil! ! 335400 335401!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335402primSocket: socketID setPort: port 335403 "Set the local port associated with a UDP socket. 335404 Note: this primitive is overloaded. The primitive will not fail on a TCP socket, but 335405 the effects will not be what was desired. Best solution would be to split Socket into 335406 two subclasses, TCPSocket and UDPSocket." 335407 335408 <primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'> 335409 self primitiveFailed 335410! ! 335411 335412!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335413primSocketAbortConnection: socketID 335414 "Terminate the connection on the given port immediately without going through the normal close sequence. This is an asynchronous call; query the socket status to discover if and when the connection is actually terminated." 335415 335416 <primitive: 'primitiveSocketAbortConnection' module: 'SocketPlugin'> 335417 self primitiveFailed 335418! ! 335419 335420!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335421primSocketCloseConnection: socketID 335422 "Close the connection on the given port. The remote end is informed that this end has closed and will do no further sends. This is an asynchronous call; query the socket status to discover if and when the connection is actually closed." 335423 335424 <primitive: 'primitiveSocketCloseConnection' module: 'SocketPlugin'> 335425 self primitiveFailed 335426! ! 335427 335428!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335429primSocketConnectionStatus: socketID 335430 "Return an integer reflecting the connection status of this socket. For a list of possible values, see the comment in the 'initialize' method of this class. If the primitive fails, return a status indicating that the socket handle is no longer valid, perhaps because the Squeak image was saved and restored since the socket was created. (Sockets do not survive snapshots.)" 335431 335432 <primitive: 'primitiveSocketConnectionStatus' module: 'SocketPlugin'> 335433 ^ InvalidSocket 335434! ! 335435 335436!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335437primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex 335438 "Return a new socket handle for a socket of the given type and buffer sizes. Return nil if socket creation fails. 335439 The netType parameter is platform dependent and can be used to encode both the protocol type (IP, Xerox XNS, etc.) and/or the physical network interface to use if this host is connected to multiple networks. A zero netType means to use IP protocols and the primary (or only) network interface. 335440 The socketType parameter specifies: 335441 0 reliable stream socket (TCP if the protocol is IP) 335442 1 unreliable datagram socket (UDP if the protocol is IP) 335443 The buffer size parameters allow performance to be tuned to the application. For example, a larger receive buffer should be used when the application expects to be receiving large amounts of data, especially from a host that is far away. These values are considered requests only; the underlying implementation will ensure that the buffer sizes actually used are within allowable bounds. Note that memory may be limited, so an application that keeps many sockets open should use smaller buffer sizes. Note the macintosh implementation ignores this buffer size. Also see setOption to get/set socket buffer sizes which allows you to set/get the current buffer sizes for reading and writing. 335444 If semaIndex is > 0, it is taken to be the index of a Semaphore in the external objects array to be associated with this socket. This semaphore will be signalled when the socket status changes, such as when data arrives or a send completes. All processes waiting on the semaphore will be awoken for each such event; each process must then query the socket state to figure out if the conditions they are waiting for have been met. For example, a process waiting to send some data can see if the last send has completed." 335445 335446 <primitive: 'primitiveSocketCreate' module: 'SocketPlugin'> 335447 ^ nil "socket creation failed" 335448! ! 335449 335450!Socket methodsFor: 'primitives' stamp: 'JMM 5/22/2000 22:48'! 335451primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema 335452 "See comment in primSocketCreateNetwork: with one semaIndex. However you should know that some implementations 335453 ignore the buffer size and this interface supports three semaphores, one for open/close/listen and the other two for 335454 reading and writing" 335455 335456 <primitive: 'primitiveSocketCreate3Semaphores' module: 'SocketPlugin'> 335457 primitiveOnlySupportsOneSemaphore := true. 335458 ^ self primSocketCreateNetwork: netType 335459 type: socketType 335460 receiveBufferSize: rcvBufSize 335461 sendBufSize: sendBufSize 335462 semaIndex: semaIndex! ! 335463 335464!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335465primSocketDestroy: socketID 335466 "Release the resources associated with this socket. If a connection is open, it is aborted." 335467 335468 <primitive: 'primitiveSocketDestroy' module: 'SocketPlugin'> 335469 self primitiveFailed 335470! ! 335471 335472!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335473primSocketDestroyGently: socketID 335474 "Release the resources associated with this socket. If a connection is open, it is aborted. 335475 Do not fail if the receiver is already closed." 335476 335477 <primitive: 'primitiveSocketDestroy' module: 'SocketPlugin'> 335478! ! 335479 335480!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335481primSocketError: socketID 335482 "Return an integer encoding the most recent error on this socket. Zero means no error." 335483 335484 <primitive: 'primitiveSocketError' module: 'SocketPlugin'> 335485 self primitiveFailed 335486! ! 335487 335488!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335489primSocketLocalAddress: socketID 335490 "Return the local host address for this socket." 335491 335492 <primitive: 'primitiveSocketLocalAddress' module: 'SocketPlugin'> 335493 self primitiveFailed 335494! ! 335495 335496!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335497primSocketLocalPort: socketID 335498 "Return the local port for this socket, or zero if no port has yet been assigned." 335499 335500 <primitive: 'primitiveSocketLocalPort' module: 'SocketPlugin'> 335501 self primitiveFailed 335502! ! 335503 335504!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335505primSocketReceiveDataAvailable: socketID 335506 "Return true if data may be available for reading from the current socket." 335507 335508 <primitive: 'primitiveSocketReceiveDataAvailable' module: 'SocketPlugin'> 335509 self primitiveFailed 335510! ! 335511 335512!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335513primSocketRemoteAddress: socketID 335514 "Return the remote host address for this socket, or zero if no connection has been made." 335515 335516 <primitive: 'primitiveSocketRemoteAddress' module: 'SocketPlugin'> 335517 self primitiveFailed 335518! ! 335519 335520!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335521primSocketRemotePort: socketID 335522 "Return the remote port for this socket, or zero if no connection has been made." 335523 335524 <primitive: 'primitiveSocketRemotePort' module: 'SocketPlugin'> 335525 self primitiveFailed 335526! ! 335527 335528!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 335529primSocketSendDone: socketID 335530 "Return true if there is no send in progress on the current socket." 335531 335532 <primitive: 'primitiveSocketSendDone' module: 'SocketPlugin'> 335533 self primitiveFailed 335534! ! 335535 335536 335537!Socket methodsFor: 'primitives-ipv6' stamp: 'ikp 6/9/2007 09:36'! 335538primSocket: socketID bindTo: socketAddress 335539 335540 <primitive: 'primitiveSocketBindTo' module: 'SocketPlugin'> 335541 self primitiveFailed 335542! ! 335543 335544!Socket methodsFor: 'primitives-ipv6' stamp: 'ikp 6/8/2007 22:08'! 335545primSocket: socketID connectTo: socketAddress 335546 335547 <primitive: 'primitiveSocketConnectTo' module: 'SocketPlugin'> 335548 self primitiveFailed 335549! ! 335550 335551!Socket methodsFor: 'primitives-ipv6' stamp: 'ikp 6/9/2007 09:39'! 335552primSocket: socketID listenWithBacklog: backlogSize 335553 335554 <primitive: 'primitiveSocketListenWithBacklog' module: 'SocketPlugin'> 335555 self primitiveFailed 335556! ! 335557 335558!Socket methodsFor: 'primitives-ipv6' stamp: 'ikp 6/9/2007 10:23'! 335559primSocket: socketID localAddressResult: socketAddress 335560 335561 <primitive: 'primitiveSocketLocalAddressResult' module: 'SocketPlugin'> 335562 self primitiveFailed 335563! ! 335564 335565!Socket methodsFor: 'primitives-ipv6' stamp: 'ikp 6/9/2007 10:23'! 335566primSocket: socketID remoteAddressResult: socketAddress 335567 335568 <primitive: 'primitiveSocketRemoteAddressResult' module: 'SocketPlugin'> 335569 self primitiveFailed 335570! ! 335571 335572!Socket methodsFor: 'primitives-ipv6' stamp: 'ikp 6/9/2007 10:24'! 335573primSocketLocalAddressSize: handle 335574 335575 <primitive: 'primitiveSocketLocalAddressSize' module: 'SocketPlugin'> 335576 self primitiveFailed 335577! ! 335578 335579!Socket methodsFor: 'primitives-ipv6' stamp: 'ikp 6/9/2007 10:24'! 335580primSocketRemoteAddressSize: handle 335581 335582 <primitive: 'primitiveSocketRemoteAddressSize' module: 'SocketPlugin'> 335583 self primitiveFailed 335584! ! 335585 335586 335587!Socket methodsFor: 'printing' stamp: 'jm 11/23/1998 11:57'! 335588printOn: aStream 335589 335590 super printOn: aStream. 335591 aStream nextPutAll: '[', self statusString, ']'. 335592! ! 335593 335594 335595!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:52'! 335596dataAvailable 335597 "Return true if this socket has unread received data." 335598 335599 socketHandle == nil ifTrue: [^ false]. 335600 ^ self primSocketReceiveDataAvailable: socketHandle 335601! ! 335602 335603!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:52'! 335604isConnected 335605 "Return true if this socket is connected." 335606 335607 socketHandle == nil ifTrue: [^ false]. 335608 ^ (self primSocketConnectionStatus: socketHandle) == Connected 335609! ! 335610 335611!Socket methodsFor: 'queries' stamp: 'JMM 5/5/2000 12:15'! 335612isOtherEndClosed 335613 "Return true if this socket had the other end closed." 335614 335615 socketHandle == nil ifTrue: [^ false]. 335616 ^ (self primSocketConnectionStatus: socketHandle) == OtherEndClosed 335617! ! 335618 335619!Socket methodsFor: 'queries' stamp: 'JMM 5/5/2000 12:17'! 335620isThisEndClosed 335621 "Return true if this socket had the this end closed." 335622 335623 socketHandle == nil ifTrue: [^ false]. 335624 ^ (self primSocketConnectionStatus: socketHandle) == ThisEndClosed 335625! ! 335626 335627!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'! 335628isUnconnected 335629 "Return true if this socket's state is Unconnected." 335630 335631 socketHandle == nil ifTrue: [^ false]. 335632 ^ (self primSocketConnectionStatus: socketHandle) == Unconnected 335633! ! 335634 335635!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'! 335636isUnconnectedOrInvalid 335637 "Return true if this socket is completely disconnected or is invalid." 335638 335639 | status | 335640 socketHandle == nil ifTrue: [^ true]. 335641 status := self primSocketConnectionStatus: socketHandle. 335642 ^ (status = Unconnected) | (status = InvalidSocket) 335643! ! 335644 335645!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:51'! 335646isValid 335647 "Return true if this socket contains a valid, non-nil socket handle." 335648 335649 | status | 335650 socketHandle == nil ifTrue: [^ false]. 335651 status := self primSocketConnectionStatus: socketHandle. 335652 ^ status ~= InvalidSocket 335653! ! 335654 335655!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'! 335656isWaitingForConnection 335657 "Return true if this socket is waiting for a connection." 335658 335659 socketHandle == nil ifTrue: [^ false]. 335660 ^ (self primSocketConnectionStatus: socketHandle) == WaitingForConnection 335661! ! 335662 335663!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'! 335664sendDone 335665 "Return true if the most recent send operation on this socket has completed." 335666 335667 socketHandle == nil ifTrue: [^ false]. 335668 ^ self primSocketSendDone: socketHandle 335669! ! 335670 335671!Socket methodsFor: 'queries' stamp: 'JMM 5/8/2000 23:24'! 335672socketError 335673 ^self primSocketError: socketHandle! ! 335674 335675!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:56'! 335676statusString 335677 "Return a string describing the status of this socket." 335678 335679 | status | 335680 socketHandle == nil ifTrue: [^ 'destroyed']. 335681 status := self primSocketConnectionStatus: socketHandle. 335682 status = InvalidSocket ifTrue: [^ 'invalidSocketHandle']. 335683 status = Unconnected ifTrue: [^ 'unconnected']. 335684 status = WaitingForConnection ifTrue: [^ 'waitingForConnection']. 335685 status = Connected ifTrue: [^ 'connected']. 335686 status = OtherEndClosed ifTrue: [^ 'otherEndClosedButNotThisEnd']. 335687 status = ThisEndClosed ifTrue: [^ 'thisEndClosedButNotOtherEnd']. 335688 ^ 'unknown socket status' 335689! ! 335690 335691 335692!Socket methodsFor: 'receiving' stamp: 'gk 12/14/2005 10:02'! 335693discardReceivedData 335694 "Discard any data received up until now, and return the number of bytes discarded." 335695 335696 | buf totalBytesDiscarded | 335697 buf := String new: 10000. 335698 totalBytesDiscarded := 0. 335699 [self isConnected] whileTrue: [ 335700 totalBytesDiscarded := 335701 totalBytesDiscarded + (self receiveDataInto: buf)]. 335702 ^ totalBytesDiscarded 335703! ! 335704 335705!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 13:52'! 335706receiveAvailableData 335707 "Receive all available data (if any). Do not wait." 335708 335709 | buffer bytesRead | 335710 buffer := String new: 2000. 335711 bytesRead := self receiveAvailableDataInto: buffer. 335712 ^buffer copyFrom: 1 to: bytesRead! ! 335713 335714!Socket methodsFor: 'receiving' stamp: 'yo 10/10/2005 18:47'! 335715receiveAvailableDataIntoBuffer: buffer 335716 "Receive all available data (if any). Do not wait." 335717 335718 | bytesRead | 335719 bytesRead := self receiveAvailableDataInto: buffer. 335720 ^buffer copyFrom: 1 to: bytesRead! ! 335721 335722!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 13:52'! 335723receiveAvailableDataInto: buffer 335724 "Receive all available data into the given buffer and return the number of bytes received. 335725 Note the given buffer may be only partially filled by the received data. 335726 Do not wait for data." 335727 335728 ^self receiveAvailableDataInto: buffer startingAt: 1! ! 335729 335730!Socket methodsFor: 'receiving' stamp: 'mu 8/9/2003 18:04'! 335731receiveAvailableDataInto: buffer startingAt: startIndex 335732 "Receive all available data into the given buffer and return the number of bytes received. 335733 Note the given buffer may be only partially filled by the received data. 335734 Do not wait for data." 335735 335736 | bufferPos bytesRead | 335737 bufferPos := startIndex. 335738 [self dataAvailable 335739 and: [bufferPos-1 < buffer size]] 335740 whileTrue: [ 335741 bytesRead := self receiveSomeDataInto: buffer startingAt: bufferPos. 335742 bufferPos := bufferPos + bytesRead]. 335743 ^bufferPos - startIndex! ! 335744 335745!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 16:05'! 335746receiveData 335747 "Receive data into the given buffer and return the number of bytes received. 335748 Note the given buffer may be only partially filled by the received data. 335749 Waits for data once. 335750 Either returns data or signals a time out or connection close." 335751 335752 | buffer bytesRead | 335753 buffer := String new: 2000. 335754 bytesRead := self receiveDataInto: buffer. 335755 ^buffer copyFrom: 1 to: bytesRead! ! 335756 335757!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 16:05'! 335758receiveDataInto: aStringOrByteArray 335759 "Receive data into the given buffer and return the number of bytes received. 335760 Note the given buffer may be only partially filled by the received data. 335761 Waits for data once. 335762 Either returns data or signals a time out or connection close." 335763 335764 ^self receiveDataInto: aStringOrByteArray startingAt: 1! ! 335765 335766!Socket methodsFor: 'receiving' stamp: 'svp 9/23/2003 00:12'! 335767receiveDataInto: aStringOrByteArray startingAt: aNumber 335768 "Receive data into the given buffer and return the number of bytes received. 335769 Note the given buffer may be only partially filled by the received data. 335770 Waits for data once. The answer may be zero (indicating that no data was 335771 available before the socket closed)." 335772 335773 | bytesRead closed | 335774 bytesRead := 0. 335775 closed := false. 335776 [closed not and: [bytesRead == 0]] 335777 whileTrue: [ 335778 self waitForDataIfClosed: [closed := true]. 335779 bytesRead := self primSocket: socketHandle 335780 receiveDataInto: aStringOrByteArray 335781 startingAt: aNumber 335782 count: aStringOrByteArray size-aNumber+1]. 335783 ^bytesRead 335784! ! 335785 335786!Socket methodsFor: 'receiving' stamp: 'gk 2/9/2005 12:33'! 335787receiveDataSignallingClosedInto: aStringOrByteArray startingAt: aNumber 335788 "Receive data into the given buffer and return the number of bytes received. 335789 Note the given buffer may be only partially filled by the received data. 335790 Waits for data until something is read or the socket is closed, upon which 335791 we signal." 335792 335793 | bytesRead | 335794 bytesRead := 0. 335795 [bytesRead == 0] 335796 whileTrue: [ 335797 self waitForData. 335798 bytesRead := self primSocket: socketHandle 335799 receiveDataInto: aStringOrByteArray 335800 startingAt: aNumber 335801 count: aStringOrByteArray size-aNumber+1]. 335802 ^bytesRead 335803! ! 335804 335805!Socket methodsFor: 'receiving' stamp: 'gk 2/9/2005 12:24'! 335806receiveDataSignallingTimeout: timeout into: aStringOrByteArray startingAt: aNumber 335807 "Receive data into the given buffer and return the number of bytes received. 335808 Note the given buffer may be only partially filled by the received data. 335809 Wait for data once for the specified nr of seconds. This method will 335810 throw exceptions on timeout or the socket closing." 335811 335812 self waitForDataFor: timeout. 335813 ^self primSocket: socketHandle 335814 receiveDataInto: aStringOrByteArray 335815 startingAt: aNumber 335816 count: aStringOrByteArray size-aNumber+1 335817! ! 335818 335819!Socket methodsFor: 'receiving' stamp: 'svp 9/23/2003 00:03'! 335820receiveDataTimeout: timeout 335821 "Receive data into the given buffer and return the number of bytes received. 335822 Note the given buffer may be only partially filled by the received data. 335823 Waits for data once." 335824 335825 | buffer bytesRead | 335826 buffer := String new: 2000. 335827 bytesRead := self receiveDataTimeout: timeout into: buffer. 335828 ^buffer copyFrom: 1 to: bytesRead! ! 335829 335830!Socket methodsFor: 'receiving' stamp: 'svp 9/23/2003 00:01'! 335831receiveDataTimeout: timeout into: aStringOrByteArray 335832 "Receive data into the given buffer and return the number of bytes received. 335833 Note the given buffer may be only partially filled by the received data. 335834 Waits for data once." 335835 335836 ^self receiveDataTimeout: timeout into: aStringOrByteArray startingAt: 1! ! 335837 335838!Socket methodsFor: 'receiving' stamp: 'svp 9/22/2003 23:58'! 335839receiveDataTimeout: timeout into: aStringOrByteArray startingAt: aNumber 335840 "Receive data into the given buffer and return the number of bytes received. 335841 Note the given buffer may be only partially filled by the received data. 335842 Wait for data once for the specified nr of seconds. The answer may be 335843 zero (indicating that there was no data available within the given timeout)." 335844 335845 self waitForDataFor: timeout ifClosed: [] ifTimedOut: []. 335846 ^self primSocket: socketHandle 335847 receiveDataInto: aStringOrByteArray 335848 startingAt: aNumber 335849 count: aStringOrByteArray size-aNumber+1 335850! ! 335851 335852!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 16:18'! 335853receiveDataWithTimeout 335854 "Receive data into the given buffer and return the number of bytes received. 335855 Note the given buffer may be only partially filled by the received data. 335856 Waits for data once. 335857 Either returns data or signals a time out or connection close." 335858 335859 | buffer bytesRead | 335860 buffer := String new: 2000. 335861 bytesRead := self receiveDataWithTimeoutInto: buffer. 335862 ^buffer copyFrom: 1 to: bytesRead! ! 335863 335864!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 16:18'! 335865receiveDataWithTimeoutInto: aStringOrByteArray 335866 "Receive data into the given buffer and return the number of bytes received. 335867 Note the given buffer may be only partially filled by the received data. 335868 Waits for data once. 335869 Either returns data or signals a time out or connection close." 335870 335871 ^self receiveDataWithTimeoutInto: aStringOrByteArray startingAt: 1! ! 335872 335873!Socket methodsFor: 'receiving' stamp: 'svp 9/23/2003 00:01'! 335874receiveDataWithTimeoutInto: aStringOrByteArray startingAt: aNumber 335875 "Receive data into the given buffer and return the number of bytes received. 335876 Note the given buffer may be only partially filled by the received data. 335877 Waits for data once." 335878 335879 ^self receiveDataTimeout: Socket standardTimeout into: aStringOrByteArray startingAt: aNumber 335880! ! 335881 335882!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 13:46'! 335883receiveSomeData 335884 "Receive currently available data (if any). Do not wait." 335885 335886 | buffer bytesRead | 335887 buffer := String new: 2000. 335888 bytesRead := self receiveSomeDataInto: buffer. 335889 ^buffer copyFrom: 1 to: bytesRead! ! 335890 335891!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 13:46'! 335892receiveSomeDataInto: aStringOrByteArray 335893 "Receive data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data." 335894 335895 ^self receiveSomeDataInto: aStringOrByteArray startingAt: 1! ! 335896 335897!Socket methodsFor: 'receiving' stamp: 'mir 5/15/2003 13:46'! 335898receiveSomeDataInto: aStringOrByteArray startingAt: aNumber 335899 "Receive data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data." 335900 335901 ^ self primSocket: socketHandle 335902 receiveDataInto: aStringOrByteArray 335903 startingAt: aNumber 335904 count: aStringOrByteArray size-aNumber+1 335905! ! 335906 335907 335908!Socket methodsFor: 'registry' stamp: 'ar 3/21/98 17:40'! 335909register 335910 ^self class register: self! ! 335911 335912!Socket methodsFor: 'registry' stamp: 'ar 3/21/98 17:41'! 335913unregister 335914 ^self class unregister: self! ! 335915 335916 335917!Socket methodsFor: 'sending' stamp: 'dc 10/21/2008 08:28'! 335918sendCommand: commandString 335919 "Send the given command as a single line followed by a <CR><LF> terminator." 335920 335921 self sendData: commandString, String crlf.! ! 335922 335923!Socket methodsFor: 'sending' stamp: 'mir 5/15/2003 18:33'! 335924sendData: aStringOrByteArray 335925 "Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent." 335926 335927 "An experimental version use on slow lines: Longer timeout and smaller writes to try to avoid spurious timeouts." 335928 335929 | bytesSent bytesToSend count | 335930 bytesToSend := aStringOrByteArray size. 335931 bytesSent := 0. 335932 [bytesSent < bytesToSend] whileTrue: [ 335933 (self waitForSendDoneFor: 60) 335934 ifFalse: [ConnectionTimedOut signal: 'send data timeout; data not sent']. 335935 count := self primSocket: socketHandle 335936 sendData: aStringOrByteArray 335937 startIndex: bytesSent + 1 335938 count: (bytesToSend - bytesSent min: 5000). 335939 bytesSent := bytesSent + count]. 335940 335941 ^ bytesSent 335942! ! 335943 335944!Socket methodsFor: 'sending' stamp: 'ar 7/20/1999 17:23'! 335945sendData: buffer count: n 335946 "Send the amount of data from the given buffer" 335947 | sent | 335948 sent := 0. 335949 [sent < n] whileTrue:[ 335950 sent := sent + (self sendSomeData: buffer startIndex: sent+1 count: (n-sent))].! ! 335951 335952!Socket methodsFor: 'sending' stamp: 'ls 1/5/1999 15:05'! 335953sendSomeData: aStringOrByteArray 335954 "Send as much of the given data as possible and answer the number of bytes actually sent." 335955 "Note: This operation may have to be repeated multiple times to send a large amount of data." 335956 335957 ^ self 335958 sendSomeData: aStringOrByteArray 335959 startIndex: 1 335960 count: aStringOrByteArray size! ! 335961 335962!Socket methodsFor: 'sending' stamp: 'ls 3/3/1999 18:59'! 335963sendSomeData: aStringOrByteArray startIndex: startIndex 335964 "Send as much of the given data as possible starting at the given index. Answer the number of bytes actually sent." 335965 "Note: This operation may have to be repeated multiple times to send a large amount of data." 335966 335967 ^ self 335968 sendSomeData: aStringOrByteArray 335969 startIndex: startIndex 335970 count: (aStringOrByteArray size - startIndex + 1)! ! 335971 335972!Socket methodsFor: 'sending' stamp: 'mir 5/15/2003 18:34'! 335973sendSomeData: aStringOrByteArray startIndex: startIndex count: count 335974 "Send up to count bytes of the given data starting at the given index. Answer the number of bytes actually sent." 335975 "Note: This operation may have to be repeated multiple times to send a large amount of data." 335976 335977 | bytesSent | 335978 (self waitForSendDoneFor: 20) 335979 ifTrue: [ 335980 bytesSent := self primSocket: socketHandle 335981 sendData: aStringOrByteArray 335982 startIndex: startIndex 335983 count: count] 335984 ifFalse: [ConnectionTimedOut signal: 'send data timeout; data not sent']. 335985 ^ bytesSent 335986! ! 335987 335988!Socket methodsFor: 'sending' stamp: 'mir 2/19/2002 18:33'! 335989sendStreamContents: stream 335990 "Send the data in the stream. Close the stream. 335991 Usefull for directly sending contents of a file without reading into memory first." 335992 335993 self sendStreamContents: stream checkBlock: [true]! ! 335994 335995!Socket methodsFor: 'sending' stamp: 'mir 2/19/2002 18:31'! 335996sendStreamContents: stream checkBlock: checkBlock 335997 "Send the data in the stream. Close the stream after you are done. After each block of data evaluate checkBlock and abort if it returns false. 335998 Usefull for directly sending contents of a file without reading into memory first." 335999 336000 | chunkSize buffer | 336001 chunkSize := 5000. 336002 buffer := ByteArray new: chunkSize. 336003 stream binary. 336004 [[stream atEnd and: [checkBlock value]] 336005 whileFalse: [ 336006 buffer := stream next: chunkSize into: buffer. 336007 self sendData: buffer]] 336008 ensure: [stream close]! ! 336009 336010 336011!Socket methodsFor: 'waiting' stamp: 'dc 10/21/2008 08:19'! 336012waitForAcceptFor: timeout 336013 "Wait and accept an incoming connection. Return nil if it falis" 336014 self waitForConnectionFor: timeout ifTimedOut: [^ nil]. 336015 ^ self isConnected 336016 ifTrue:[self accept] 336017 ! ! 336018 336019!Socket methodsFor: 'waiting' stamp: 'mu 9/30/2007 04:04'! 336020waitForAcceptFor: timeout ifTimedOut: timeoutBlock 336021 "Wait and accept an incoming connection" 336022 self waitForConnectionFor: timeout ifTimedOut: [^timeoutBlock value]. 336023 ^self accept! ! 336024 336025!Socket methodsFor: 'waiting' stamp: 'mu 8/19/2003 02:57'! 336026waitForConnectionFor: timeout 336027 "Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not." 336028 336029 ^self 336030 waitForConnectionFor: timeout 336031 ifTimedOut: [ConnectionTimedOut signal: 'Failed to connect in ', timeout asString, ' seconds'] 336032! ! 336033 336034!Socket methodsFor: 'waiting' stamp: 'nice 4/28/2009 21:26'! 336035waitForConnectionFor: timeout ifTimedOut: timeoutBlock 336036 "Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not." 336037 336038 | startTime msecsDelta msecsEllapsed status | 336039 startTime := Time millisecondClockValue. 336040 msecsDelta := (timeout * 1000) truncated. 336041 status := self primSocketConnectionStatus: socketHandle. 336042 [(status = WaitingForConnection) and: [(msecsEllapsed := Time millisecondsSince: startTime) < msecsDelta]] 336043 whileTrue: [ 336044 semaphore waitTimeoutMSecs: msecsDelta - msecsEllapsed. 336045 status := self primSocketConnectionStatus: socketHandle]. 336046 336047 status = Connected ifFalse: [^timeoutBlock value]. 336048 ^ true! ! 336049 336050!Socket methodsFor: 'waiting' stamp: 'svp 9/23/2003 00:09'! 336051waitForData 336052 "Wait for data to arrive. This method will block until 336053 data is available or the socket is closed. If the socket is closed 336054 a ConnectionClosed exception will be signaled." 336055 336056 ^self waitForDataIfClosed: 336057 [ConnectionClosed signal: 'Connection close while waiting for data.']! ! 336058 336059!Socket methodsFor: 'waiting' stamp: 'svp 7/27/2003 00:18'! 336060waitForDataFor: timeout 336061 "Wait for the given nr of seconds for data to arrive. 336062 Signal a time out or connection close exception if either happens before data becomes available." 336063 336064 ^self 336065 waitForDataFor: timeout 336066 ifClosed: [ConnectionClosed signal: 'Connection closed while waiting for data.'] 336067 ifTimedOut: [ConnectionTimedOut signal: 'Data receive timed out.'] 336068! ! 336069 336070!Socket methodsFor: 'waiting' stamp: 'nice 4/29/2009 21:25'! 336071waitForDataFor: timeout ifClosed: closedBlock ifTimedOut: timedOutBlock 336072 "Wait for the given nr of seconds for data to arrive." 336073 336074 | startTime msecsDelta | 336075 startTime := Time millisecondClockValue. 336076 msecsDelta := (timeout * 1000) truncated. 336077 [(Time millisecondsSince: startTime) < msecsDelta] whileTrue: [ 336078 (self primSocketReceiveDataAvailable: socketHandle) 336079 ifTrue: [^self]. 336080 self isConnected 336081 ifFalse: [^closedBlock value]. 336082 self readSemaphore waitTimeoutMSecs: 336083 (msecsDelta - (Time millisecondsSince: startTime) max: 0). 336084 ]. 336085 336086 (self primSocketReceiveDataAvailable: socketHandle) 336087 ifFalse: [ 336088 self isConnected 336089 ifTrue: [^timedOutBlock value] 336090 ifFalse: [^closedBlock value]].! ! 336091 336092!Socket methodsFor: 'waiting' stamp: 'svp 9/23/2003 00:08'! 336093waitForDataIfClosed: closedBlock 336094 "Wait indefinitely for data to arrive. This method will block until 336095 data is available or the socket is closed." 336096 336097 [true] 336098 whileTrue: [ 336099 (self primSocketReceiveDataAvailable: socketHandle) 336100 ifTrue: [^self]. 336101 self isConnected 336102 ifFalse: [^closedBlock value]. 336103 self readSemaphore wait]. 336104! ! 336105 336106!Socket methodsFor: 'waiting' stamp: 'nice 4/28/2009 21:20'! 336107waitForDisconnectionFor: timeout 336108 "Wait for the given nr of seconds for the connection to be broken. 336109 Return true if it is broken by the deadline, false if not. 336110 The client should know the connection is really going to be closed 336111 (e.g., because he has called 'close' to send a close request to the other end) 336112 before calling this method." 336113 336114 | startTime msecsDelta status | 336115 startTime := Time millisecondClockValue. 336116 msecsDelta := (timeout * 1000) truncated. 336117 status := self primSocketConnectionStatus: socketHandle. 336118 [((status == Connected) or: [(status == ThisEndClosed)]) and: 336119 [(Time millisecondsSince: startTime) < msecsDelta]] whileTrue: [ 336120 self discardReceivedData. 336121 self readSemaphore waitTimeoutMSecs: 336122 (msecsDelta - (Time millisecondsSince: startTime) max: 0). 336123 status := self primSocketConnectionStatus: socketHandle]. 336124 ^ status ~= Connected! ! 336125 336126!Socket methodsFor: 'waiting' stamp: 'nice 4/28/2009 21:18'! 336127waitForSendDoneFor: timeout 336128 "Wait up until the given deadline for the current send operation to complete. Return true if it completes by the deadline, false if not." 336129 336130 | startTime msecsDelta msecsEllapsed sendDone | 336131 startTime := Time millisecondClockValue. 336132 msecsDelta := (timeout * 1000) truncated. 336133 [self isConnected & (sendDone := self primSocketSendDone: socketHandle) not 336134 "Connection end and final data can happen fast, so test in this order" 336135 and: [(msecsEllapsed := Time millisecondsSince: startTime) < msecsDelta]] whileTrue: [ 336136 self writeSemaphore waitTimeoutMSecs: msecsDelta - msecsEllapsed]. 336137 336138 ^ sendDone! ! 336139 336140"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 336141 336142Socket class 336143 instanceVariableNames: ''! 336144 336145!Socket class methodsFor: 'class initialization' stamp: 'ar 12/12/2001 19:12'! 336146initialize 336147 "Socket initialize" 336148 336149 "Socket Types" 336150 TCPSocketType := 0. 336151 UDPSocketType := 1. 336152 336153 "Socket Status Values" 336154 InvalidSocket := -1. 336155 Unconnected := 0. 336156 WaitingForConnection := 1. 336157 Connected := 2. 336158 OtherEndClosed := 3. 336159 ThisEndClosed := 4. 336160 336161 RegistryThreshold := 100. "# of sockets"! ! 336162 336163 336164!Socket class methodsFor: 'deprecated-ROLL OVER PROBLEM' stamp: 'mir 5/15/2003 18:28'! 336165deadlineSecs: secs 336166 "Return a deadline time the given number of seconds from now." 336167 336168 ^ Time millisecondClockValue + (secs * 1000) truncated 336169! ! 336170 336171!Socket class methodsFor: 'deprecated-ROLL OVER PROBLEM' stamp: 'mir 5/15/2003 16:17'! 336172standardDeadline 336173 "Return a default deadline time some seconds into the future." 336174 336175 ^ self deadlineSecs: self standardTimeout 336176! ! 336177 336178 336179!Socket class methodsFor: 'examples' stamp: 'DamienCassou 9/29/2009 13:12'! 336180timeTest 336181 "Socket timeTest" 336182 336183 | serverName serverAddr s | 336184 Transcript show: 'initializing network ... '. 336185 self initializeNetwork. 336186 Transcript 336187 show: 'ok'; 336188 cr. 336189 serverName := FillInTheBlank request: 'What is your time server?' 336190 initialAnswer: 'localhost'. 336191 serverName isEmptyOrNil 336192 ifTrue: 336193 [^Transcript 336194 show: 'never mind'; 336195 cr]. 336196 serverAddr := NetNameResolver addressForName: serverName timeout: 10. 336197 serverAddr = nil 336198 ifTrue: [self error: 'Could not find the address for ' , serverName]. 336199 s := self new. 336200 Transcript 336201 show: '---------- Connecting ----------'; 336202 cr. 336203 s connectTo: serverAddr port: 13. "13 is the 'daytime' port number" 336204 s waitForConnectionFor: 1. 336205 Transcript show: 'the time server reports: ' , s receiveData. 336206 s closeAndDestroy. 336207 Transcript 336208 show: '---------- Connection Closed ----------'; 336209 cr! ! 336210 336211!Socket class methodsFor: 'examples' stamp: 'DamienCassou 9/29/2009 13:12'! 336212timeTestUDP 336213 "Socket timeTestUDP" 336214 336215 | serverName serverAddr s | 336216 Transcript show: 'initializing network ... '. 336217 self initializeNetwork. 336218 Transcript 336219 show: 'ok'; 336220 cr. 336221 serverName := FillInTheBlank request: 'What is your time server?' 336222 initialAnswer: 'localhost'. 336223 serverName isEmptyOrNil 336224 ifTrue: 336225 [^Transcript 336226 show: 'never mind'; 336227 cr]. 336228 serverAddr := NetNameResolver addressForName: serverName timeout: 10. 336229 serverAddr = nil 336230 ifTrue: [self error: 'Could not find the address for ' , serverName]. 336231 s := self newUDP. "a 'random' port number will be allocated by the system" 336232 "Send a packet to the daytime port and it will reply with the current date." 336233 Transcript 336234 show: '---------- Sending datagram from port ' , s port printString 336235 , ' ----------'; 336236 cr. 336237 s 336238 sendData: '!!' 336239 toHost: serverAddr 336240 port: 13. "13 is the daytime service" 336241 Transcript show: 'the time server reports: ' , s receiveData. 336242 s closeAndDestroy. 336243 Transcript 336244 show: '---------- Socket closed ----------'; 336245 cr! ! 336246 336247 336248!Socket class methodsFor: 'instance creation' stamp: 'ls 9/24/1999 09:45'! 336249acceptFrom: aSocket 336250 ^[ super new acceptFrom: aSocket ] 336251 repeatWithGCIf: [ :sock | sock isValid not ]! ! 336252 336253!Socket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:15'! 336254createIfFail: failBlock 336255 "Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket." 336256 "Note: The default creates a TCP socket" 336257 ^self tcpCreateIfFail: failBlock! ! 336258 336259!Socket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:13'! 336260new 336261 "Return a new, unconnected Socket. Note that since socket creation may fail, it is safer to use the method createIfFail: to handle such failures gracefully; this method is primarily for backward compatibility and may be disallowed in a future release." 336262 "Note: The default creates a TCP socket - this is also backward compatibility." 336263 ^self newTCP! ! 336264 336265!Socket class methodsFor: 'instance creation' stamp: 'mir 1/5/2007 18:27'! 336266newTCP 336267 "Create a socket and initialise it for TCP" 336268 ^self newTCP: SocketAddressInformation addressFamilyINET4! ! 336269 336270!Socket class methodsFor: 'instance creation' stamp: 'ikp 6/8/2007 23:02'! 336271newTCP: family 336272 "Create a socket and initialise it for TCP" 336273 self initializeNetwork. 336274 ^[ super new initialize: TCPSocketType family: family ] 336275 repeatWithGCIf: [ :socket | socket isValid not ]! ! 336276 336277!Socket class methodsFor: 'instance creation' stamp: 'mir 1/5/2007 18:27'! 336278newUDP 336279 "Create a socket and initialise it for UDP" 336280 ^self newUDP: SocketAddressInformation addressFamilyINET4! ! 336281 336282!Socket class methodsFor: 'instance creation' stamp: 'mir 6/17/2007 21:20'! 336283newUDP: family 336284 "Create a socket and initialise it for UDP" 336285 self initializeNetwork. 336286 ^[ super new initialize: UDPSocketType family: family ] 336287 repeatWithGCIf: [ :socket | socket isValid not ]! ! 336288 336289!Socket class methodsFor: 'instance creation' stamp: 'michael.rueger 3/30/2009 13:48'! 336290tcpCreateIfFail: failBlock 336291 "Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket." 336292 336293 | sock | 336294 self initializeNetwork. 336295 sock := self newTCP. 336296 sock isValid ifFalse: [^ failBlock value]. 336297 ^ sock 336298! ! 336299 336300!Socket class methodsFor: 'instance creation' stamp: 'michael.rueger 3/30/2009 13:48'! 336301udpCreateIfFail: failBlock 336302 "Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket." 336303 336304 | sock | 336305 self initializeNetwork. 336306 sock := self newUDP. 336307 sock isValid ifFalse: [^ failBlock value]. 336308 ^ sock 336309! ! 336310 336311 336312!Socket class methodsFor: 'network initialization' stamp: 'mir 2/22/2002 15:01'! 336313initializeNetwork 336314 "Initialize the network drivers and the NetNameResolver. Do nothing if the network is already initialized." 336315 "Note: The network must be re-initialized every time Squeak starts up, so applications that persist across snapshots should be prepared to re-initialize the network as needed. Such applications should call 'Socket initializeNetwork' before every network transaction. " 336316 336317 NetNameResolver initializeNetwork! ! 336318 336319!Socket class methodsFor: 'network initialization' stamp: 'mir 2/22/2002 14:59'! 336320primInitializeNetwork: resolverSemaIndex 336321 "Initialize the network drivers on platforms that need it, such as the Macintosh, and return nil if network initialization failed or the reciever if it succeeds. Since mobile computers may not always be connected to a network, this method should NOT be called automatically at startup time; rather, it should be called when first starting a networking application. It is a noop if the network driver has already been initialized. If non-zero, resolverSemaIndex is the index of a VM semaphore to be associated with the network name resolver. This semaphore will be signalled when the resolver status changes, such as when a name lookup query is completed." 336322 "Note: some platforms (e.g., Mac) only allow only one name lookup query at a time, so a manager process should be used to serialize resolver lookup requests." 336323 336324 <primitive: 'primitiveInitializeNetwork' module: 'SocketPlugin'> 336325 ^ nil "return nil if primitive fails" 336326! ! 336327 336328 336329!Socket class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:40'! 336330register: anObject 336331 WeakArray isFinalizationSupported ifFalse:[^anObject]. 336332 self registry add: anObject! ! 336333 336334!Socket class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:40'! 336335registry 336336 WeakArray isFinalizationSupported ifFalse:[^nil]. 336337 ^Registry isNil 336338 ifTrue:[Registry := WeakRegistry new] 336339 ifFalse:[Registry].! ! 336340 336341!Socket class methodsFor: 'registry' stamp: 'ar 12/12/2001 19:12'! 336342registryThreshold 336343 "Return the registry threshold above which socket creation may fail due to too many already open sockets. If the threshold is reached, a full GC will be issued if the creation of a socket fails." 336344 ^RegistryThreshold! ! 336345 336346!Socket class methodsFor: 'registry' stamp: 'ar 12/12/2001 19:12'! 336347registryThreshold: aNumber 336348 "Return the registry threshold above which socket creation may fail due to too many already open sockets. If the threshold is reached, a full GC will be issued if the creation of a socket fails." 336349 RegistryThreshold := aNumber! ! 336350 336351!Socket class methodsFor: 'registry' stamp: 'ar 10/7/1998 15:22'! 336352unregister: anObject 336353 WeakArray isFinalizationSupported ifFalse:[^anObject]. 336354 self registry remove: anObject ifAbsent:[]! ! 336355 336356 336357!Socket class methodsFor: 'tests' stamp: 'gk 12/15/2005 01:18'! 336358loopbackTest 336359 "Send data from one socket to another on the local machine. 336360 Tests most of the socket primitives." 336361 336362 "100 timesRepeat: [Socket loopbackTest]" 336363 336364 | sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived t extraBytes packetsSent packetsRead | 336365 Transcript 336366 cr; 336367 show: 'starting loopback test'; 336368 cr. 336369 Transcript 336370 show: '---------- Connecting ----------'; 336371 cr. 336372 self initializeNetwork. 336373 sock1 := self new. 336374 sock2 := self new. 336375 sock1 listenOn: 54321. 336376 sock2 connectTo: NetNameResolver localHostAddress port: 54321. 336377 sock1 waitForConnectionFor: self standardTimeout. 336378 sock2 waitForConnectionFor: self standardTimeout. 336379 sock1 isConnected ifFalse: [self error: 'sock1 not connected']. 336380 sock2 isConnected ifFalse: [self error: 'sock2 not connected']. 336381 Transcript 336382 show: 'connection established'; 336383 cr. 336384 bytesToSend := 5000000. 336385 sendBuf := String new: 5000 withAll: $x. 336386 receiveBuf := String new: 50000. 336387 done := false. 336388 packetsSent := packetsRead := bytesSent := bytesReceived := 0. 336389 t := Time millisecondsToRun: 336390 [[done] whileFalse: 336391 [(sock1 sendDone and: [bytesSent < bytesToSend]) 336392 ifTrue: 336393 [packetsSent := packetsSent + 1. 336394 bytesSent := bytesSent + (sock1 sendSomeData: sendBuf)]. 336395 sock2 dataAvailable 336396 ifTrue: 336397 [packetsRead := packetsRead + 1. 336398 bytesReceived := bytesReceived + (sock2 receiveDataInto: receiveBuf)]. 336399 done := bytesSent >= bytesToSend and: [bytesReceived = bytesSent]]]. 336400 Transcript 336401 show: 'closing connection'; 336402 cr. 336403 sock1 waitForSendDoneFor: self standardTimeout. 336404 sock1 close. 336405 sock2 waitForDisconnectionFor: self standardTimeout. 336406 extraBytes := sock2 discardReceivedData. 336407 extraBytes > 0 336408 ifTrue: 336409 [Transcript 336410 show: ' *** received ' , extraBytes size printString , ' extra bytes ***'; 336411 cr]. 336412 sock2 close. 336413 sock1 waitForDisconnectionFor: self standardTimeout. 336414 sock1 isUnconnectedOrInvalid ifFalse: [self error: 'sock1 not closed']. 336415 sock2 isUnconnectedOrInvalid ifFalse: [self error: 'sock2 not closed']. 336416 Transcript 336417 show: '---------- Connection Closed ----------'; 336418 cr. 336419 sock1 destroy. 336420 sock2 destroy. 336421 Transcript 336422 show: 'loopback test done; time = ' , t printString; 336423 cr. 336424 Transcript 336425 show: (bytesToSend asFloat / t roundTo: 0.01) printString 336426 , '* 1000 bytes/sec'; 336427 cr. 336428 Transcript endEntry! ! 336429 336430!Socket class methodsFor: 'tests' stamp: 'gk 12/15/2005 01:03'! 336431newAcceptCheck 336432 "Check if the platform has support for the BSD style accept()." 336433 336434 "Socket newAcceptCheck" 336435 336436 | socket | 336437 self initializeNetwork. 336438 socket := self newTCP. 336439 socket listenOn: 44444 backlogSize: 4. 336440 socket isValid ifTrue: [ 336441 self inform: 'Everything looks OK for the BSD style accept()' 336442 ] ifFalse: [ 336443 self inform: 'It appears that you DO NOT have support for the BSD style accept()']. 336444 socket destroy! ! 336445 336446!Socket class methodsFor: 'tests' stamp: 'gk 12/15/2005 01:10'! 336447sendTest 336448 "Send data to the 'discard' socket of the given host. 336449 Tests the speed of one-way data transfers across the 336450 network to the given host. Note that most hosts 336451 do not run a discard server." 336452 336453 "Socket sendTest" 336454 336455 | sock bytesToSend sendBuf bytesSent t serverName serverAddr | 336456 Transcript cr; show: 'starting send test'; cr. 336457 self initializeNetwork. 336458 serverName := UIManager default request: 'What is the destination server?' initialAnswer: 'create.ucsb.edu'. 336459 serverAddr := NetNameResolver addressForName: serverName timeout: 10. 336460 serverAddr = nil 336461 ifTrue: [^self inform: 'Could not find an address for ' , serverName]. 336462 sock := self new. 336463 Transcript show: '---------- Connecting ----------';cr. 336464 sock connectTo: serverAddr port: 9. 336465 sock isConnected ifFalse: [ 336466 sock destroy. 336467 ^self inform: 'could not connect']. 336468 Transcript show: 'connection established; sending data'; cr. 336469 bytesToSend := 1000000. 336470 sendBuf := String new: 64 * 1024 withAll: $x. 336471 bytesSent := 0. 336472 t := Time millisecondsToRun: 336473 [[bytesSent < bytesToSend] whileTrue: 336474 [sock sendDone 336475 ifTrue: [bytesSent := bytesSent + (sock sendSomeData: sendBuf)]]]. 336476 sock waitForSendDoneFor: self standardTimeout. 336477 sock destroy. 336478 Transcript show: '---------- Connection Closed ----------'; cr; 336479 show: 'send test done; time = ' , t printString; cr; 336480 show: (bytesToSend asFloat / t roundTo: 0.01) printString, ' * 1000 bytes/sec';cr;endEntry! ! 336481 336482 336483!Socket class methodsFor: 'utilities' stamp: 'tk 4/9/98 15:54'! 336484deadServer 336485 336486 ^ DeadServer! ! 336487 336488!Socket class methodsFor: 'utilities' stamp: 'tk 4/9/98 15:56'! 336489deadServer: aStringOrNil 336490 "Keep the machine name of the most recently encoutered non-responding machine. Next time the user can move it to the last in a list of servers to try." 336491 336492 DeadServer := aStringOrNil! ! 336493 336494!Socket class methodsFor: 'utilities' stamp: 'jm 1/14/1999 12:13'! 336495nameForWellKnownTCPPort: portNum 336496 "Answer the name for the given well-known TCP port number. Answer a string containing the port number if it isn't well-known." 336497 336498 | portList entry | 336499 portList := #( 336500 (7 'echo') (9 'discard') (13 'time') (19 'characterGenerator') 336501 (21 'ftp') (23 'telnet') (25 'smtp') 336502 (80 'http') (110 'pop3') (119 'nntp')). 336503 entry := portList detect: [:pair | pair first = portNum] ifNone: [^ 'port-', portNum printString]. 336504 ^ entry last 336505! ! 336506 336507!Socket class methodsFor: 'utilities' stamp: 'mir 5/15/2003 18:30'! 336508ping: hostName 336509 "Ping the given host. Useful for checking network connectivity. The host must be running a TCP echo server." 336510 "Socket ping: 'squeak.cs.uiuc.edu'" 336511 336512 | tcpPort sock serverAddr startTime echoTime | 336513 tcpPort := 7. "7 = echo port, 13 = time port, 19 = character generator port" 336514 336515 serverAddr := NetNameResolver addressForName: hostName timeout: 10. 336516 serverAddr = nil ifTrue: [ 336517 ^ self inform: 'Could not find an address for ', hostName]. 336518 336519 sock := Socket new. 336520 sock connectNonBlockingTo: serverAddr port: tcpPort. 336521 [sock waitForConnectionFor: 10] 336522 on: ConnectionTimedOut 336523 do: [:ex | 336524 (self confirm: 'Continue to wait for connection to ', hostName, '?') 336525 ifTrue: [ex retry] 336526 ifFalse: [ 336527 sock destroy. 336528 ^ self]]. 336529 336530 sock sendData: 'echo!!'. 336531 startTime := Time millisecondClockValue. 336532 [sock waitForDataFor: 15] 336533 on: ConnectionTimedOut 336534 do: [:ex | (self confirm: 'Packet sent but no echo yet; keep waiting?') 336535 ifTrue: [ex retry]]. 336536 echoTime := Time millisecondClockValue - startTime. 336537 336538 sock destroy. 336539 self inform: hostName, ' responded in ', echoTime printString, ' milliseconds'. 336540! ! 336541 336542!Socket class methodsFor: 'utilities' stamp: 'nice 4/28/2009 21:50'! 336543pingPorts: portList on: hostName timeOutSecs: timeOutSecs 336544 "Attempt to connect to each of the given sockets on the given host. Wait at most timeOutSecs for the connections to be established. Answer an array of strings indicating the available ports." 336545 "Socket pingPorts: #(7 13 19 21 23 25 80 110 119) on: 'squeak.cs.uiuc.edu' timeOutSecs: 15" 336546 336547 | serverAddr sockets sock startTime timeoutMsecs done unconnectedCount connectedCount waitingCount result | 336548 serverAddr := NetNameResolver addressForName: hostName timeout: 10. 336549 serverAddr = nil ifTrue: [ 336550 self inform: 'Could not find an address for ', hostName. 336551 ^ #()]. 336552 336553 sockets := portList collect: [:portNum | 336554 sock := Socket new. 336555 sock connectTo: serverAddr port: portNum]. 336556 336557 startTime := Time millisecondClockValue. 336558 timeoutMsecs := (1000 * timeOutSecs) truncated. 336559 done := false. 336560 [done] whileFalse: [ 336561 unconnectedCount := 0. 336562 connectedCount := 0. 336563 waitingCount := 0. 336564 sockets do: [:s | 336565 s isUnconnectedOrInvalid 336566 ifTrue: [unconnectedCount := unconnectedCount + 1] 336567 ifFalse: [ 336568 s isConnected ifTrue: [connectedCount := connectedCount + 1]. 336569 s isWaitingForConnection ifTrue: [waitingCount := waitingCount + 1]]]. 336570 waitingCount = 0 ifTrue: [done := true]. 336571 connectedCount = sockets size ifTrue: [done := true]. 336572 (Time millisecondsSince: startTime) >= timeoutMsecs ifTrue: [done := true]]. 336573 336574 result := (sockets select: [:s | s isConnected]) 336575 collect: [:s | self nameForWellKnownTCPPort: s remotePort]. 336576 sockets do: [:s | s destroy]. 336577 ^ result 336578! ! 336579 336580!Socket class methodsFor: 'utilities' stamp: 'jm 1/14/1999 17:25'! 336581pingPortsOn: hostName 336582 "Attempt to connect to a set of well-known sockets on the given host, and answer the names of the available ports." 336583 "Socket pingPortsOn: 'www.disney.com'" 336584 336585 ^ Socket 336586 pingPorts: #(7 13 19 21 23 25 80 110 119) 336587 on: hostName 336588 timeOutSecs: 20 336589! ! 336590 336591!Socket class methodsFor: 'utilities' stamp: 'mir 5/15/2003 16:16'! 336592standardTimeout 336593 336594 ^45 336595! ! 336596 336597!Socket class methodsFor: 'utilities' stamp: 'ar 4/30/1999 04:21'! 336598wildcardAddress 336599 "Answer a don't-care address for use with UDP sockets." 336600 336601 ^ByteArray new: 4 "0.0.0.0"! ! 336602 336603!Socket class methodsFor: 'utilities' stamp: 'ar 4/30/1999 04:21'! 336604wildcardPort 336605 "Answer a don't-care port for use with UDP sockets. (The system will allocate an 336606 unused port number to the socket.)" 336607 336608 ^0! ! 336609ByteArray variableByteSubclass: #SocketAddress 336610 instanceVariableNames: '' 336611 classVariableNames: '' 336612 poolDictionaries: '' 336613 category: 'Network-Kernel'! 336614!SocketAddress commentStamp: '<historical>' prior: 0! 336615I represent a socket (network) address consisting of a host internet address and a port number. My contents are opaque and cannot be interpreted directly. See the accessing protocol for methods that retrieve the information I contain.! 336616 336617 336618!SocketAddress methodsFor: 'accessing' stamp: 'ikp 6/8/2007 18:41'! 336619hostName 336620 336621 | size name | 336622 NetNameResolver primGetNameInfo: self flags: 0. 336623 size := NetNameResolver primGetNameInfoHostSize. 336624 name := String new: size. 336625 NetNameResolver primGetNameInfoHostResult: name. 336626 ^name! ! 336627 336628!SocketAddress methodsFor: 'accessing' stamp: 'ikp 6/8/2007 18:41'! 336629hostNumber 336630 336631 | size name | 336632 NetNameResolver primGetNameInfo: self flags: 1. 336633 size := NetNameResolver primGetNameInfoHostSize. 336634 name := String new: size. 336635 NetNameResolver primGetNameInfoHostResult: name. 336636 ^name! ! 336637 336638!SocketAddress methodsFor: 'accessing' stamp: 'ikp 6/8/2007 18:41'! 336639serviceName 336640 336641 | size name | 336642 NetNameResolver primGetNameInfo: self flags: 0. 336643 size := NetNameResolver primGetNameInfoServiceSize. 336644 name := String new: size. 336645 NetNameResolver primGetNameInfoServiceResult: name. 336646 ^name! ! 336647 336648!SocketAddress methodsFor: 'accessing' stamp: 'ikp 6/8/2007 18:41'! 336649serviceNumber 336650 336651 | size name | 336652 NetNameResolver primGetNameInfo: self flags: 1. 336653 size := NetNameResolver primGetNameInfoServiceSize. 336654 name := String new: size. 336655 NetNameResolver primGetNameInfoServiceResult: name. 336656 ^name! ! 336657 336658 336659!SocketAddress methodsFor: 'converting' stamp: 'mir 6/17/2007 23:13'! 336660asSocketAddress 336661! ! 336662 336663 336664!SocketAddress methodsFor: 'primitives' stamp: 'ikp 6/9/2007 08:21'! 336665port 336666 336667 <primitive: 'primitiveSocketAddressGetPort' module: 'SocketPlugin'> 336668 self primitiveFailed 336669! ! 336670 336671!SocketAddress methodsFor: 'primitives' stamp: 'ikp 6/9/2007 08:21'! 336672port: anInteger 336673 336674 <primitive: 'primitiveSocketAddressSetPort' module: 'SocketPlugin'> 336675 self primitiveFailed 336676! ! 336677 336678 336679!SocketAddress methodsFor: 'printing' stamp: 'ikp 6/8/2007 22:43'! 336680printOn: aStream 336681 336682 aStream 336683 nextPutAll: self hostNumber; 336684 nextPut: $(; nextPutAll: self hostName; nextPut: $); 336685 nextPut: $,; 336686 nextPutAll: self serviceNumber; 336687 nextPut: $(; nextPutAll: self serviceName; nextPut: $)! ! 336688 336689"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 336690 336691SocketAddress class 336692 instanceVariableNames: ''! 336693 336694!SocketAddress class methodsFor: 'accessing' stamp: 'ikp 6/9/2007 10:04'! 336695loopback4 336696 336697 ^self loopbacks4 first! ! 336698 336699!SocketAddress class methodsFor: 'accessing' stamp: 'ikp 6/9/2007 10:04'! 336700loopback6 336701 336702 ^self loopbacks6 first! ! 336703 336704!SocketAddress class methodsFor: 'accessing' stamp: 'ikp 6/9/2007 10:02'! 336705loopbacks 336706 336707 ^SocketAddressInformation forHost: '' service: '0' 336708 flags: 0 336709 addressFamily: 0 336710 socketType: 0 336711 protocol: 0! ! 336712 336713!SocketAddress class methodsFor: 'accessing' stamp: 'ikp 6/11/2007 10:35'! 336714loopbacks4 336715 336716 ^SocketAddressInformation forHost: 'localhost' service: '' 336717 flags: 0 336718 addressFamily: SocketAddressInformation addressFamilyINET4 336719 socketType: 0 336720 protocol: 0! ! 336721 336722!SocketAddress class methodsFor: 'accessing' stamp: 'ikp 6/9/2007 10:02'! 336723loopbacks6 336724 336725 ^SocketAddressInformation forHost: '' service: '0' 336726 flags: 0 336727 addressFamily: SocketAddressInformation addressFamilyINET6 336728 socketType: 0 336729 protocol: 0! ! 336730 336731!SocketAddress class methodsFor: 'accessing' stamp: 'ikp 6/9/2007 10:04'! 336732wildcard4 336733 336734 ^self wildcards4 first! ! 336735 336736!SocketAddress class methodsFor: 'accessing' stamp: 'ikp 6/9/2007 10:04'! 336737wildcard6 336738 336739 ^self wildcards6 first! ! 336740 336741!SocketAddress class methodsFor: 'accessing' stamp: 'ikp 6/9/2007 10:03'! 336742wildcards 336743 336744 ^SocketAddressInformation forHost: '' service: '0' 336745 flags: SocketAddressInformation passiveFlag 336746 addressFamily: 0 336747 socketType: 0 336748 protocol: 0! ! 336749 336750!SocketAddress class methodsFor: 'accessing' stamp: 'ikp 6/11/2007 10:40'! 336751wildcards4 336752 336753 ^SocketAddressInformation forHost: '' service: '0' 336754 flags: SocketAddressInformation passiveFlag 336755 addressFamily: SocketAddressInformation addressFamilyINET4 336756 socketType: SocketAddressInformation socketTypeStream 336757 protocol: 0! ! 336758 336759!SocketAddress class methodsFor: 'accessing' stamp: 'ikp 6/9/2007 10:03'! 336760wildcards6 336761 336762 ^SocketAddressInformation forHost: '' service: '0' 336763 flags: SocketAddressInformation passiveFlag 336764 addressFamily: SocketAddressInformation addressFamilyINET6 336765 socketType: 0 336766 protocol: 0! ! 336767 336768 336769!SocketAddress class methodsFor: 'instance creation' stamp: 'mir 6/26/2007 18:33'! 336770fromOldByteAddress: byteArray 336771 ^self newFrom: byteArray! ! 336772Object subclass: #SocketAddressInformation 336773 instanceVariableNames: 'socketAddress addressFamily socketType protocol' 336774 classVariableNames: 'AddressFamilyINET4 AddressFamilyINET6 AddressFamilyLocal AddressFamilyUnspecified NumericFlag PassiveFlag ProtocolTCP ProtocolUDP ProtocolUnspecified SocketTypeDGram SocketTypeStream SocketTypeUnspecified' 336775 poolDictionaries: '' 336776 category: 'Network-Kernel'! 336777!SocketAddressInformation commentStamp: '<historical>' prior: 0! 336778I represent a local or remote network service. 336779 336780Instance Variables 336781 addressFamily: <SmallInteger> the address family (unix, inet4, inet6, ...) in which the service address is available. 336782 protocol: <SmallInteger> the protocol (tcp, udp, ...) that the service uses. 336783 socketAddress: <SocketAddress> the socket address at which the service can be contacted or created. 336784 socketType: <SmallInteger> the type (stream, dgram) of the socket that should be created for communication with the service. 336785! 336786 336787 336788!SocketAddressInformation methodsFor: 'accessing' stamp: 'ikp 6/8/2007 18:20'! 336789addressFamilyName 336790 336791 ^#(unspecified local inet4 inet6) at: addressFamily + 1! ! 336792 336793!SocketAddressInformation methodsFor: 'accessing' stamp: 'ikp 6/8/2007 18:20'! 336794protocolName 336795 336796 ^#(unspecified tcp udp) at: socketType + 1! ! 336797 336798!SocketAddressInformation methodsFor: 'accessing' stamp: 'ikp 6/9/2007 08:35'! 336799socketAddress 336800 336801 ^socketAddress! ! 336802 336803!SocketAddressInformation methodsFor: 'accessing' stamp: 'ikp 6/8/2007 18:20'! 336804socketTypeName 336805 336806 ^#(unspecified stream dgram) at: socketType + 1! ! 336807 336808 336809!SocketAddressInformation methodsFor: 'circuit setup' stamp: 'ikp 6/8/2007 23:04'! 336810connect 336811 336812 | sock | 336813 socketType == SocketTypeStream ifFalse: [^nil]. 336814 sock := Socket newTCP: addressFamily. 336815 sock connectTo: socketAddress. 336816 sock waitForConnectionFor: Socket standardTimeout 336817 ifTimedOut: [ConnectionTimedOut signal: 'Cannot connect to ', self printString]. 336818 ^sock! ! 336819 336820!SocketAddressInformation methodsFor: 'circuit setup' stamp: 'ikp 6/9/2007 09:52'! 336821listenWithBacklog: backlog 336822 336823 | sock | 336824 (socketType == SocketTypeStream and: [protocol == ProtocolTCP]) ifFalse: [self error: 'cannot listen']. 336825 sock := Socket newTCP: addressFamily. 336826 sock bindTo: socketAddress. 336827 sock listenWithBacklog: 5. 336828 ^sock! ! 336829 336830 336831!SocketAddressInformation methodsFor: 'initialize-release' stamp: 'ikp 6/8/2007 18:11'! 336832initSocketAddress: aSocketAddress family: familyInteger type: typeInteger protocol: protocolInteger 336833 336834 socketAddress := aSocketAddress. 336835 addressFamily := familyInteger. 336836 socketType := typeInteger. 336837 protocol := protocolInteger.! ! 336838 336839 336840!SocketAddressInformation methodsFor: 'printing' stamp: 'ikp 6/8/2007 21:54'! 336841printOn: aStream 336842 336843 aStream 336844 print: socketAddress; 336845 nextPut: $-; nextPutAll: self addressFamilyName; 336846 nextPut: $-; nextPutAll: self socketTypeName; 336847 nextPut: $-; nextPutAll: self protocolName! ! 336848 336849"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 336850 336851SocketAddressInformation class 336852 instanceVariableNames: ''! 336853 336854!SocketAddressInformation class methodsFor: 'accessing' stamp: 'ikp 6/8/2007 22:02'! 336855addressFamilyINET4 336856 336857 ^AddressFamilyINET4! ! 336858 336859!SocketAddressInformation class methodsFor: 'accessing' stamp: 'ikp 6/8/2007 22:02'! 336860addressFamilyINET6 336861 336862 ^AddressFamilyINET6! ! 336863 336864!SocketAddressInformation class methodsFor: 'accessing' stamp: 'ikp 6/8/2007 22:02'! 336865addressFamilyLocal 336866 336867 ^AddressFamilyLocal! ! 336868 336869!SocketAddressInformation class methodsFor: 'accessing' stamp: 'ikp 6/8/2007 22:01'! 336870addressFamilyUnspecified 336871 336872 ^AddressFamilyUnspecified! ! 336873 336874!SocketAddressInformation class methodsFor: 'accessing' stamp: 'ikp 6/9/2007 09:13'! 336875numericFlag 336876 336877 ^NumericFlag! ! 336878 336879!SocketAddressInformation class methodsFor: 'accessing' stamp: 'ikp 6/9/2007 09:12'! 336880passiveFlag 336881 336882 ^PassiveFlag! ! 336883 336884!SocketAddressInformation class methodsFor: 'accessing' stamp: 'ikp 6/8/2007 22:02'! 336885protocolTCP 336886 336887 ^ProtocolTCP! ! 336888 336889!SocketAddressInformation class methodsFor: 'accessing' stamp: 'ikp 6/8/2007 22:02'! 336890protocolUDP 336891 336892 ^ProtocolUDP! ! 336893 336894!SocketAddressInformation class methodsFor: 'accessing' stamp: 'ikp 6/8/2007 22:02'! 336895protocolUnspecified 336896 336897 ^ProtocolUnspecified! ! 336898 336899!SocketAddressInformation class methodsFor: 'accessing' stamp: 'ikp 6/8/2007 22:02'! 336900socketTypeDGram 336901 336902 ^SocketTypeDGram! ! 336903 336904!SocketAddressInformation class methodsFor: 'accessing' stamp: 'ikp 6/8/2007 22:02'! 336905socketTypeStream 336906 336907 ^SocketTypeStream! ! 336908 336909!SocketAddressInformation class methodsFor: 'accessing' stamp: 'ikp 6/8/2007 22:02'! 336910socketTypeUnspecified 336911 336912 ^SocketTypeUnspecified! ! 336913 336914 336915!SocketAddressInformation class methodsFor: 'class initialization' stamp: 'ikp 6/9/2007 09:12'! 336916initialize "SocketAddressInformation initialize" 336917 336918 NumericFlag := 1. 336919 PassiveFlag := 2. 336920 AddressFamilyUnspecified := 0. 336921 AddressFamilyLocal := 1. 336922 AddressFamilyINET4 := 2. 336923 AddressFamilyINET6 := 3. 336924 SocketTypeUnspecified := 0. 336925 SocketTypeStream := 1. 336926 SocketTypeDGram := 2. 336927 ProtocolUnspecified := 0. 336928 ProtocolTCP := 1. 336929 ProtocolUDP := 2.! ! 336930 336931 336932!SocketAddressInformation class methodsFor: 'instance creation' stamp: 'ikp 6/8/2007 23:07'! 336933forHost: hostName service: servName flags: flags addressFamily: family socketType: type protocol: protocol 336934 336935 | result addr | 336936 NetNameResolver initializeNetwork. 336937 NetNameResolver primGetAddressInfoHost: hostName service: servName flags: flags family: family type: type protocol: protocol. 336938 result := OrderedCollection new. 336939 [(addr := NetNameResolver nextSocketAddressInformation) notNil] whileTrue: [result add: addr]. 336940 ^result! ! 336941 336942!SocketAddressInformation class methodsFor: 'instance creation' stamp: 'ikp 6/8/2007 18:11'! 336943withSocketAddress: socketAddress family: family type: type protocol: protocol 336944 336945 ^self new initSocketAddress: socketAddress family: family type: type protocol: protocol! ! 336946Object subclass: #SocketStream 336947 instanceVariableNames: 'recentlyRead socket inBuffer outBuffer inNextToWrite outNextToWrite lastRead timeout autoFlush bufferSize binary shouldSignal' 336948 classVariableNames: '' 336949 poolDictionaries: '' 336950 category: 'Network-Kernel'! 336951!SocketStream commentStamp: 'md 7/14/2006 16:32' prior: 0! 336952SocketStream is a wrapper for class Socket making it easy to write networking code by giving the programmer a stream-like protocol. A Socket is a two way communication link with two logically separate channels - input and output. The Socket class is the lowest level in Squeak for network communication and using it directly can be difficult and bug prone. 336953 336954A SocketStream can be in binary or ascii mode, ascii is the default which means you are transmitting and receiving Strings. Most Internet protocols are in clear text ascii, like for example HTTP. Another setting is what timeout you want to use - default is the standardTimeout from Socket. More settings can be found in the method category 'configuration'. 336955 336956Simplest example of connecting, sending/receiving and closing: 336957 336958| stream result | 336959stream := SocketStream openConnectionToHostNamed: 'www.squeak.org' port: 80. 336960[[stream nextPutAll: 'GET / HTTP/1.0'; crlf; crlf; flush. 336961result := stream upToEnd. "Give us all data until the socket is closed." 336962Transcript show: result; cr.] 336963 ensure: [stream close]] 336964 on: ConnectionTimedOut 336965 do: [:ex | Transcript show: ex asString;cr. ex resume] 336966 336967There are two important things to note above: 336968 - The methods in category "stream in" can signal two exceptions (unless turned off with #shouldSignal:): 336969 ConnectionClosed and ConnectionTimedOut 336970 - We close the stream using #ensure:, that is to make sure it isn't left opened. 336971 - We use #on:do: to catch any signal. In this case we do not need to catch ConnectionClosed since #upToEnd does that for us intrinsically. 336972 336973---------------- 336974SocketStream (below called SS) is a reimplementation of 'Old'-SocketStream (below called OSS) - the class that originates from the original Comanche implementation but now is included in standard Squeak. SS has the same protocol as OSS and is meant to replace it. SS is faster, more flexible, is better documented and adds a few features: 336975 3369761. #shouldSignal:, which decides if SS should signal low level Socket exceptions (true) or if it should swallow them like original OSS did. Default is true. The only reason I added this is for backwards compatibility - not signalling causes problems - see bug 4 below. 336977 3369782. #nextAllInBuffer, #nextInBuffer:, #skip:, #receiveData:, #nextPutAllFlush: and #recentlyRead are new additions to the public protocol. 336979 336980 336981It also fixes various bugs: 336982 3369831. #isDataAvailable could theoretically answer false, when there actually is some in the buffer in OSS. If #receiveDataIfAvailable reads the last byte then the following "socket dataAvailable" would answer false. So the last byte would be sitting in the inStream missed. 336984 3369852. #upToAll: in OSS has several problems, for example - #positionOfSubCollection:ifAbsent: which was introduced answers one position too low. This was compensated in upToAll:, but only in the pushBack: call, not the actual result being returned which was cut short 1 byte. Amusingly this makes KomHttpServer not use "Keep-Alive" since the last $e in 'Alive' was cut short. :) 336986 3369873. SS doesn't inherit from PositionableStream since that just breaks various inherited messages, like for example #skip:. OSS should IMHO be changed to inherit from Object - or of course, replaced in full with SS. :) 336988 3369894. Since SocketStream by default signals closes and timeouts the SocketStreamTest now passes. The reason for SocketStream to fail is that while it does timeout on a low level (#SocketStream>>receiveData doesn't hang forever) - the callers of #receiveData sometimes loop - like in #next:, and thus eliminates the timeout. SS warns about some methods (in their method comments) not honouring timeouts if shouldSignal is false, I really don't know what they should do in that case: 336990 #next:, #upTo:, #upToAll: and #upToEnd (and #receiveData:) 336991 336992 336993The primary reason for the SS implementation is optimal performance. The main differences in implementation with the old OSS are: 336994 3369951. SS uses two buffers directly (inBuffer and outBuffer) with pointers marking start and stop within the buffer. OSS instead uses two regular streams, a ReadStream and a WriteStream. Using internal buffers makes it possible to avoid copying and reallocation in various ways, it also makes SS be able to have specialized growing/buffer moving behaviour. 336996 3369972. #upTo:, #upToAll: and #peekForAll: uses selectged String messages that in turn uses fast primitives for searching. OSS used other messages that fell back on byte per byte reading. 336998 3369993. #receiveData in OSS creates a temporary buffer stream for each call!! During a long read operation, like say #upToAll: (which for example is used when uploading files using HTTP POST forms), this is devastating - especially since the default size is only 2000 bytes - and leads to a very high number of low level read operations on the Socket, typically 100 times more calls than with OSS. The buffer in OSS is held in an instvar (not recreated for each call), is larger from the start and above all - grows dynamically by doubling. OSS can also avoid a grow/reallocation by doing a "move down" if data has been read from the SS as it comes in and through that making room in the lower part of the inBuffer. The net result is that upToAll: for large files is about 10 times faster. 337000 3370014. The implementation of upTo: and upToAll: tries to avoid doing unnecessary find operations in the buffer and is greedy by default, which means it favors reading more data - if available - before searching for the stop sequence. If we had #findString:startingAt:stoppingAt: this wouldn't have to be greedy and we wouldn't be needlessly scanning dead buffer area. VM hackers? Also, while you are at it - make it work for ByteArrays too. :) 337002 337003 337004SS can not be run unbuffered, since that seems unneeded. The option to autoFlush is still available, with it set to true SocketStream (just like OSS) will flush on its own on each nextPut:/nextPutAll:, otherwise flushing it will have to be done manually but is done on close. 337005 337006The first performance tests shows that, as noted above, receiving large amounts of data using #upToAll: is greatly improved - factor of 10. Serving HTTP with small payloads seemed at first not be faster at all - but this is due to the high overhead of Socket connect/close and other things. Increasing payloads show a difference and especially with keep alive on - where the new SS roughly doubles the throughput!!! 337007 337008 337009!SocketStream methodsFor: 'configuration' stamp: 'gk 2/9/2005 22:37'! 337010ascii 337011 "Tell the SocketStream to send data 337012 as Strings instead of ByteArrays. 337013 This is default." 337014 337015 binary := false. 337016 self resetBuffers! ! 337017 337018!SocketStream methodsFor: 'configuration' stamp: 'gk 2/9/2005 22:26'! 337019autoFlush 337020 "If autoFlush is enabled data will be sent through 337021 the socket (flushed) when the bufferSize is reached 337022 or the SocketStream is closed. Otherwise the user 337023 will have to send #flush manually. 337024 Close will always flush. Default is false." 337025 337026 ^autoFlush! ! 337027 337028!SocketStream methodsFor: 'configuration' stamp: 'gk 2/9/2005 22:27'! 337029autoFlush: aBoolean 337030 "If autoFlush is enabled data will be sent through 337031 the socket (flushed) when the bufferSize is reached 337032 or the SocketStream is closed. Otherwise the user 337033 will have to send #flush manually. 337034 Close will always flush. Default is false." 337035 337036 autoFlush := aBoolean! ! 337037 337038!SocketStream methodsFor: 'configuration' stamp: 'gk 2/9/2005 22:37'! 337039binary 337040 "Tell the SocketStream to send data 337041 as ByteArrays instead of Strings. 337042 Default is ascii." 337043 337044 binary := true. 337045 self resetBuffers! ! 337046 337047!SocketStream methodsFor: 'configuration' stamp: 'gk 2/9/2005 22:28'! 337048bufferSize 337049 "Default buffer size is 4kb. 337050 increased from earlier 2000 bytes." 337051 337052 ^bufferSize! ! 337053 337054!SocketStream methodsFor: 'configuration' stamp: 'gk 2/9/2005 22:28'! 337055bufferSize: anInt 337056 "Default buffer size is 4kb. 337057 increased from earlier 2000 bytes." 337058 337059 bufferSize := anInt! ! 337060 337061!SocketStream methodsFor: 'configuration' stamp: 'gk 2/10/2005 17:58'! 337062inBufferSize 337063 "Answers the current size of data in the inBuffer." 337064 337065 ^inNextToWrite - lastRead - 1! ! 337066 337067!SocketStream methodsFor: 'configuration' stamp: 'gk 2/10/2005 17:59'! 337068noTimeout 337069 "Do not use timeout." 337070 337071 timeout := 0! ! 337072 337073!SocketStream methodsFor: 'configuration' stamp: 'gk 2/10/2005 17:59'! 337074outBufferSize 337075 "Answers the current size of data in the outBuffer." 337076 337077 ^outNextToWrite - 1! ! 337078 337079!SocketStream methodsFor: 'configuration' stamp: 'gk 2/10/2005 18:00'! 337080shouldSignal 337081 "If shouldSignal is enabled the Socket Exceptions 337082 ConnectionClosed and ConnectionTimedOut 337083 will not be swallowed. Default is true. 337084 For more info, see #shouldSignal:" 337085 337086 ^shouldSignal! ! 337087 337088!SocketStream methodsFor: 'configuration' stamp: 'gk 2/10/2005 18:03'! 337089shouldSignal: aBoolean 337090 "If shouldSignal is enabled the Socket Exceptions 337091 ConnectionClosed and ConnectionTimedOut will not be swallowed. 337092 Default is true. And please - don't set it to false - it is better to 337093 use an exception handler (see below) and several methods 337094 in this class will not honour timeouts (says so in their method comments). 337095 Also, it is quite hard to understand what for example #upToEnd 337096 should return to indicate a timeout. 337097 337098 Wrap your use of SocketStream with a handler like: 337099 337100 [stuff := mySocketStream next: 10] 337101 on: ConnectionClosed, ConnectionTimedOut 337102 do: [:ex | 337103 Transcript show: 'Oops!! Did not get my ten bytes!!;cr] 337104 " 337105 337106 shouldSignal := aBoolean! ! 337107 337108!SocketStream methodsFor: 'configuration' stamp: 'gk 2/3/2005 20:35'! 337109socket 337110 ^socket! ! 337111 337112!SocketStream methodsFor: 'configuration' stamp: 'gk 2/3/2005 20:35'! 337113socket: aSocket 337114 socket := aSocket! ! 337115 337116!SocketStream methodsFor: 'configuration' stamp: 'gk 2/7/2005 08:41'! 337117timeout 337118 "Lazily initialized unless it has been set explicitly." 337119 337120 timeout ifNil: [timeout := Socket standardTimeout]. 337121 ^timeout! ! 337122 337123!SocketStream methodsFor: 'configuration' stamp: 'gk 2/3/2005 20:35'! 337124timeout: seconds 337125 timeout := seconds! ! 337126 337127 337128!SocketStream methodsFor: 'control' stamp: 'gk 2/24/2005 11:55'! 337129close 337130 "Flush any data still not sent 337131 and take care of the socket." 337132 337133 self flush. 337134 socket closeAndDestroy: 30! ! 337135 337136!SocketStream methodsFor: 'control' stamp: 'gk 9/9/2005 09:33'! 337137flush 337138 "If the other end is connected and we have something 337139 to send, then we send it and reset the outBuffer." 337140 337141 ((outNextToWrite > 1) and: [socket isOtherEndClosed not]) 337142 ifTrue: [ 337143 [socket sendData: outBuffer count: outNextToWrite - 1] 337144 on: ConnectionTimedOut 337145 do: [:ex | shouldSignal ifFalse: ["swallow"]]. 337146 outNextToWrite := 1]! ! 337147 337148!SocketStream methodsFor: 'control' stamp: 'gk 4/14/2005 09:49'! 337149receiveData: nBytes 337150 "Keep reading the socket until we have nBytes 337151 in the inBuffer or we reach the end. This method 337152 does not return data, but can be used to make sure 337153 data has been read into the buffer from the Socket 337154 before actually reading it from the FastSocketStream. 337155 Mainly used internally. We could also adjust the buffer 337156 to the expected amount of data and avoiding several 337157 incremental grow operations. 337158 337159 NOTE: This method doesn't honor timeouts if shouldSignal 337160 is false!! And frankly, I am not sure how to handle that 337161 case or if I care - I think we should always signal." 337162 337163 [self atEnd not and: [nBytes > self inBufferSize]] 337164 whileTrue: [self receiveData]! ! 337165 337166!SocketStream methodsFor: 'control' stamp: 'gk 2/9/2005 23:08'! 337167recentlyRead 337168 "Return the number of bytes read 337169 during the last socket operation." 337170 337171 ^recentlyRead! ! 337172 337173 337174!SocketStream methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 11:05'! 337175initialize 337176 super initialize. 337177 autoFlush := true. 337178 shouldSignal := true. 337179 recentlyRead := 0. 337180 bufferSize := 4096. 337181 self ascii! ! 337182 337183 337184!SocketStream methodsFor: 'printing' stamp: 'gk 2/25/2005 14:19'! 337185debug 337186 "Display debug info." 337187 337188 | data | 337189 data := self inBufferSize. 337190 ^String streamContents: [:s | 337191 s 337192 nextPutAll: 'Buffer size: ', inBuffer size asString;cr; 337193 nextPutAll: 'InBuffer data size: ', data asString; cr; 337194 nextPutAll: 'In data (20):', (inBuffer copyFrom: lastRead + 1 to: lastRead + (data min: 20)); cr; 337195 nextPutAll: 'OutBuffer data size: ', (outNextToWrite - 1) asString; cr; 337196 nextPutAll: 'Out data (20):', (outBuffer copyFrom: 1 to: ((outNextToWrite - 1) min: 20)); cr]! ! 337197 337198!SocketStream methodsFor: 'printing' stamp: 'md 7/14/2006 12:28'! 337199print: anObject 337200 anObject printOn: self! ! 337201 337202!SocketStream methodsFor: 'printing' stamp: 'gk 2/10/2005 11:44'! 337203printOn: aStream 337204 "Display buffer sizes." 337205 337206 aStream nextPutAll: self class name. 337207 inBuffer ifNotNil: [ 337208 aStream nextPutAll: '[inbuf:', 337209 (inBuffer size / 1024) rounded asString, 'kb/outbuf:', 337210 (outBuffer size / 1024) rounded asString, 'kb]']! ! 337211 337212 337213!SocketStream methodsFor: 'stream in' stamp: 'gk 2/7/2005 13:33'! 337214next 337215 "Return next byte, if inBuffer is empty 337216 we recieve some more data and try again." 337217 337218 self atEnd ifTrue: [^nil]. 337219 self isInBufferEmpty ifTrue: 337220 [self receiveData. 337221 self atEnd ifTrue: [^nil]]. 337222 lastRead := lastRead + 1. 337223 ^inBuffer at: lastRead! ! 337224 337225!SocketStream methodsFor: 'stream in' stamp: 'gk 2/7/2005 21:26'! 337226nextAllInBuffer 337227 "Return all data currently in the inBuffer," 337228 337229 ^self nextInBuffer: inNextToWrite - lastRead - 1! ! 337230 337231!SocketStream methodsFor: 'stream in' stamp: 'gk 2/7/2005 12:51'! 337232nextInBuffer: anInteger 337233 "Answer anInteger bytes of data at most, 337234 but only from the inBuffer." 337235 337236 | start amount | 337237 amount := anInteger min: (inNextToWrite - lastRead - 1). 337238 start := lastRead + 1. 337239 lastRead := lastRead + amount. 337240 ^inBuffer copyFrom: start to: lastRead! ! 337241 337242!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:17'! 337243next: anInteger 337244 "Answer anInteger bytes of data. 337245 337246 NOTE: This method doesn't honor timeouts if shouldSignal is false!!" 337247 337248 | start | 337249 self receiveData: anInteger. 337250 start := lastRead + 1. 337251 lastRead := (lastRead + anInteger) min: inNextToWrite - 1. 337252 ^inBuffer copyFrom: start to: lastRead! ! 337253 337254!SocketStream methodsFor: 'stream in' stamp: 'gk 2/7/2005 13:47'! 337255nextAvailable 337256 "Answer all the data currently available, 337257 in buffer or in socket." 337258 337259 self isInBufferEmpty ifFalse: [^self nextAllInBuffer]. 337260 self isDataAvailable ifTrue: [self receiveData]. 337261 ^self nextAllInBuffer! ! 337262 337263!SocketStream methodsFor: 'stream in' stamp: 'gk 2/7/2005 13:02'! 337264nextAvailable: howMany 337265 "Answer all the data currently available, 337266 in buffer or in socket - but limited to <howMany>." 337267 337268 self isInBufferEmpty ifFalse: [^self nextInBuffer: howMany]. 337269 self isDataAvailable ifTrue: [self receiveData]. 337270 ^self nextInBuffer: howMany! ! 337271 337272!SocketStream methodsFor: 'stream in' stamp: 'gk 2/3/2005 20:35'! 337273nextLine 337274 ^self nextLineCrLf! ! 337275 337276!SocketStream methodsFor: 'stream in' stamp: 'gk 2/24/2005 12:01'! 337277nextLineCrLf 337278 ^self upToAll: String crlf! ! 337279 337280!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:16'! 337281nextLineLf 337282 | nextLine | 337283 nextLine := self upToAll: String lf. 337284 ^nextLine! ! 337285 337286!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:09'! 337287peek 337288 "Return next byte, if inBuffer is empty 337289 we recieve some more data and try again. 337290 Do not consume the byte." 337291 337292 self atEnd ifTrue: [^nil]. 337293 self isInBufferEmpty ifTrue: 337294 [self receiveData. 337295 self atEnd ifTrue: [^nil]]. 337296 ^inBuffer at: lastRead! ! 337297 337298!SocketStream methodsFor: 'stream in' stamp: 'gk 2/7/2005 14:04'! 337299peekFor: aCharacterOrByte 337300 "Read and return next character or byte 337301 if it is equal to the argument. 337302 Otherwise return false." 337303 337304 | nextObject | 337305 self atEnd ifTrue: [^false]. 337306 self isInBufferEmpty ifTrue: 337307 [self receiveData. 337308 self atEnd ifTrue: [^false]]. 337309 nextObject := inBuffer at: lastRead. 337310 nextObject = aCharacterOrByte ifTrue: [ 337311 lastRead := lastRead + 1. 337312 ^true]. 337313 ^false 337314! ! 337315 337316!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:16'! 337317peekForAll: aString 337318 "Answer whether or not the next string of characters in the receiver 337319 matches aString. If a match is made, advance over that string in the receiver and 337320 answer true. If no match, then leave the receiver alone and answer false. 337321 We use findString:startingAt: to avoid copying. 337322 337323 NOTE: This method doesn't honor timeouts if shouldSignal is false!!" 337324 337325 | sz start | 337326 sz := aString size. 337327 self receiveData: sz. 337328 (inNextToWrite - lastRead - 1) < sz ifTrue: [^false]. 337329 start := lastRead + 1. 337330 (inBuffer findString: aString startingAt: start) = start 337331 ifFalse: [^false]. 337332 lastRead := lastRead + sz. 337333 ^true! ! 337334 337335!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:16'! 337336peek: anInteger 337337 "Answer anInteger bytes of data. 337338 Do not consume data. 337339 337340 NOTE: This method doesn't honor timeouts if shouldSignal is false!!" 337341 337342 | start | 337343 self receiveData: anInteger. 337344 start := lastRead + 1. 337345 ^inBuffer copyFrom: start to: ((lastRead + anInteger) min: inNextToWrite - 1).! ! 337346 337347!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:15'! 337348skip: anInteger 337349 "Skip a number of bytes. 337350 This is faster than #next: since it does not 337351 have to copy and return a new String or ByteArray. 337352 337353 NOTE: This method doesn't honor timeouts if shouldSignal is false!!" 337354 337355 self receiveData: anInteger. 337356 lastRead := (lastRead + anInteger) min: inNextToWrite - 1! ! 337357 337358!SocketStream methodsFor: 'stream in' stamp: 'gk 9/9/2005 02:57'! 337359upTo: aCharacterOrByte 337360 "Return data up to, but not including given character or byte. 337361 337362 NOTE: Does not honour timeouts if shouldSignal is false!! 337363 337364 This method looks a bit complicated, and this is mainly because there is no fast search method 337365 in String that takes a stoppingAt: argument. This means we need to ignore getting hits in the 337366 dead buffer area above inNextToWrite. 337367 Another measure is that this implementation is greedy and will load data into the buffer 337368 until there is nothing more available, or it has loaded 100kb - and not until then we search the buffer. 337369 337370 A totally non greedy variant would search on every loop." 337371 337372 | index result lastRecentlyRead searchedSoFar | 337373 searchedSoFar := 0. 337374 lastRecentlyRead := 0. 337375 index := 0. 337376 [self atEnd not and: [ 337377 ((lastRecentlyRead = 0 and: [self isInBufferEmpty not]) or: [self inBufferSize > 100000]) ifTrue: [ 337378 "Data begins at lastRead + 1, we add searchedSoFar as offset." 337379 index := inBuffer indexOf: aCharacterOrByte startingAt: lastRead + searchedSoFar + 1. 337380 searchedSoFar := self inBufferSize. 337381 (index > 0 and: [(index + 1) > inNextToWrite]) ifTrue: [ 337382 "Oops, hit in dead buffer area. 337383 This is probably due to old data, so we ignore it. 337384 No point in cleaning the dead area to avoid hits - it will still search it." 337385 index := 0]]. 337386 index = 0]] 337387 whileTrue: [ 337388 recentlyRead = 0 337389 ifTrue: ["blocking call for now, we don't want to poll" 337390 self receiveData] 337391 ifFalse: [ 337392 self receiveAvailableData]. 337393 lastRecentlyRead := recentlyRead]. 337394 index > 0 337395 ifTrue: ["found it" 337396 result := self nextInBuffer: index - lastRead - 1. 337397 self skip: 1. 337398 ^ result] 337399 ifFalse: ["atEnd" 337400 ^ self nextAllInBuffer]! ! 337401 337402!SocketStream methodsFor: 'stream in' stamp: 'gk 9/9/2005 02:55'! 337403upToAll: aStringOrByteArray 337404 "Answer a subcollection from the current access position to the occurrence (if any, but not 337405 inclusive) of aStringOrByteArray. If aCollection is not in the stream, answer the entire rest of 337406 the stream. 337407 337408 NOTE: Does not honour timeouts if shouldSignal is false!! 337409 337410 This method looks a bit complicated, and this is mainly because there is no fast search method 337411 in String that takes a stoppingAt: argument. This means we need to ignore getting hits in the 337412 dead buffer area above inNextToWrite. 337413 Another measure is that this implementation is greedy and will load data into the buffer 337414 until there is nothing more available, or it has loaded 100kb - and not until then we search the buffer. 337415 337416 A totally non greedy variant would search on every loop." 337417 337418 | index sz result lastRecentlyRead searchedSoFar | 337419 sz := aStringOrByteArray size. 337420 searchedSoFar := 0. 337421 lastRecentlyRead := 0. 337422 index := 0. 337423 [self atEnd not and: [ 337424 ((lastRecentlyRead = 0 and: [self isInBufferEmpty not]) or: [self inBufferSize > 100000]) ifTrue: [ 337425 "Data begins at lastRead + 1, we add searchedSoFar as offset and backs up sz - 1 337426 so that we can catch any borderline hits." 337427 index := inBuffer indexOfSubCollection: aStringOrByteArray 337428 startingAt: lastRead + searchedSoFar - sz + 2. 337429 searchedSoFar := self inBufferSize. 337430 (index > 0 and: [(index + sz) > inNextToWrite]) ifTrue: [ 337431 "Oops, hit partially or completely in dead buffer area. 337432 This is probably due to old data, so we ignore it. 337433 No point in cleaning the dead area to avoid hits - it will still search it." 337434 index := 0]]. 337435 index = 0]] 337436 whileTrue: [ 337437 recentlyRead = 0 337438 ifTrue: ["blocking call for now, we don't want to poll" 337439 self receiveData] 337440 ifFalse: [ 337441 self receiveAvailableData]. 337442 lastRecentlyRead := recentlyRead]. 337443 index > 0 337444 ifTrue: ["found it" 337445 result := self nextInBuffer: index - lastRead - 1. 337446 self skip: sz. 337447 ^ result] 337448 ifFalse: ["atEnd" 337449 ^ self nextAllInBuffer]! ! 337450 337451!SocketStream methodsFor: 'stream in' stamp: 'gk 2/15/2005 14:14'! 337452upToEnd 337453 "Answer all data coming in on the socket until the socket 337454 is closed by the other end, or we get a timeout. 337455 This means this method catches ConnectionClosed by itself. 337456 337457 NOTE: Does not honour timeouts if shouldSignal is false!!" 337458 337459 [[self atEnd] whileFalse: [self receiveData]] 337460 on: ConnectionClosed 337461 do: [:ex | "swallow it"]. 337462 ^self nextAllInBuffer! ! 337463 337464 337465!SocketStream methodsFor: 'stream out' stamp: 'gk 2/3/2005 20:35'! 337466cr 337467 self nextPutAll: String cr! ! 337468 337469!SocketStream methodsFor: 'stream out' stamp: 'gk 2/3/2005 20:35'! 337470crlf 337471 self nextPutAll: String crlf! ! 337472 337473!SocketStream methodsFor: 'stream out' stamp: 'gk 2/10/2005 11:14'! 337474nextPutAllFlush: aCollection 337475 "Put a String or a ByteArray onto the stream. 337476 You can use this if you have very large data - it avoids 337477 copying into the buffer (and avoids buffer growing) 337478 and also flushes any other pending data first." 337479 337480 | toPut | 337481 toPut := binary ifTrue: [aCollection asByteArray] ifFalse: [aCollection asString]. 337482 self flush. "first flush pending stuff, then directly send" 337483 socket isOtherEndClosed ifFalse: [ 337484 [socket sendData: toPut count: toPut size] 337485 on: ConnectionTimedOut 337486 do: [:ex | shouldSignal ifFalse: ["swallow"]]]! ! 337487 337488!SocketStream methodsFor: 'stream out' stamp: 'md 2/24/2006 19:51'! 337489nextPut: char 337490 "Put a single Character or byte onto the stream." 337491 337492 | toPut | 337493 toPut := binary ifTrue: [char asInteger] ifFalse: [char asCharacter]. 337494 self adjustOutBuffer: 1. 337495 outBuffer at: outNextToWrite put: toPut. 337496 outNextToWrite := outNextToWrite + 1. 337497 self checkFlush. 337498 "return the argument - added by kwl" 337499 ^ char! ! 337500 337501!SocketStream methodsFor: 'stream out' stamp: 'gk 2/7/2005 22:51'! 337502nextPutAll: aCollection 337503 "Put a String or a ByteArray onto the stream. 337504 Currently a large collection will allocate a large buffer." 337505 337506 | toPut | 337507 toPut := binary ifTrue: [aCollection asByteArray] ifFalse: [aCollection asString]. 337508 self adjustOutBuffer: toPut size. 337509 outBuffer replaceFrom: outNextToWrite to: outNextToWrite + toPut size - 1 with: toPut startingAt: 1. 337510 outNextToWrite := outNextToWrite + toPut size. 337511 self checkFlush! ! 337512 337513!SocketStream methodsFor: 'stream out' stamp: 'gk 9/9/2005 09:32'! 337514sendCommand: aString 337515 "Sends a String ending it with CR LF and then flush 337516 causing it to block until sent." 337517 337518 self nextPutAll: aString, String crlf; flush! ! 337519 337520!SocketStream methodsFor: 'stream out' stamp: 'gk 2/3/2005 20:35'! 337521space 337522 self nextPut: Character space! ! 337523 337524 337525!SocketStream methodsFor: 'testing' stamp: 'gk 2/25/2005 14:23'! 337526atEnd 337527 "There is nothing more to read when 337528 there is no more data in our inBuffer, the socket 337529 is disconnected and there is none available on the socket. 337530 Note that we need to check isConnected before isDataAvailable, 337531 otherwise data may sneak in in the meantime. But we check the 337532 buffer first, because it is faster." 337533 337534 self isInBufferEmpty ifFalse: [^false]. 337535 ^self isConnected not 337536 and: [self isDataAvailable not]! ! 337537 337538!SocketStream methodsFor: 'testing' stamp: 'mir 4/22/2007 23:51'! 337539ifStale: aBlock 337540 self isConnected 337541 ifFalse: aBlock! ! 337542 337543!SocketStream methodsFor: 'testing' stamp: 'gk 2/3/2005 20:35'! 337544isBinary 337545 ^binary! ! 337546 337547!SocketStream methodsFor: 'testing' stamp: 'gk 2/7/2005 12:24'! 337548isConnected 337549 "The stream is connected if the socket is." 337550 337551 ^socket isConnected! ! 337552 337553!SocketStream methodsFor: 'testing' stamp: 'gk 2/24/2005 12:23'! 337554isDataAvailable 337555 "It the inbuffer is empty, we check the socket for data. 337556 If it claims to have data available to read, we try to read 337557 some once and recursively call this method again. 337558 If something really was available it is now in the inBuffer. 337559 This is because there has been spurious 337560 dataAvailable when there really is no data to get." 337561 337562 self isInBufferEmpty ifFalse: [^true]. 337563 ^socket dataAvailable 337564 ifFalse: [false] 337565 ifTrue: [self receiveDataIfAvailable; isDataAvailable]! ! 337566 337567!SocketStream methodsFor: 'testing' stamp: 'gk 2/7/2005 13:02'! 337568isEmpty 337569 "Test if there are more data to read." 337570 337571 ^self isInBufferEmpty and: [self isDataAvailable not]! ! 337572 337573!SocketStream methodsFor: 'testing' stamp: 'gk 2/7/2005 13:02'! 337574isInBufferEmpty 337575 "Any data in the buffer?" 337576 337577 ^lastRead + 1 = inNextToWrite! ! 337578 337579!SocketStream methodsFor: 'testing' stamp: 'gk 2/7/2005 08:59'! 337580isOtherEndConnected 337581 ^socket isOtherEndClosed not! ! 337582 337583!SocketStream methodsFor: 'testing' stamp: 'mir 4/25/2007 16:42'! 337584isStream 337585 ^true! ! 337586 337587!SocketStream methodsFor: 'testing' stamp: 'gk 2/3/2005 20:35'! 337588shouldTimeout 337589 ^self timeout > 0! ! 337590 337591 337592!SocketStream methodsFor: 'private' stamp: 'kph 11/6/2008 16:43'! 337593<< items 337594 337595 items putOn: self. 337596 337597 ^ self! ! 337598 337599!SocketStream methodsFor: 'private' stamp: 'gk 2/9/2005 22:44'! 337600adjustInBuffer: bytesRead 337601 "Adjust markers and possibly grow inBuffer or move data down. 337602 Currently grows through doubling when less than 1024 bytes are left. 337603 Never shrinks. Returns the position in the buffer where any new 337604 data can be found." 337605 337606 | old | 337607 bytesRead = 0 ifTrue: [^inNextToWrite]. 337608 old := inNextToWrite. 337609 inNextToWrite := inNextToWrite + bytesRead. 337610 (inBuffer size - inNextToWrite) < 1024 337611 ifTrue: [ 337612 "Hit the roof, move data down (if enough has been read) or do we grow?" 337613 (lastRead > 512) 337614 ifTrue: [^old - self moveInBufferDown] 337615 ifFalse: [self growInBuffer]]. 337616 ^old! ! 337617 337618!SocketStream methodsFor: 'private' stamp: 'gk 2/9/2005 22:42'! 337619adjustOutBuffer: bytesToWrite 337620 "Possibly grow outBuffer to accommodate the new data. 337621 Currently grows through doubling when less 337622 than 1024 bytes are left. If bytesToWrite is even 337623 larger we double that instead. Never shrinks." 337624 337625 (outBuffer size - outNextToWrite - bytesToWrite) < 1024 ifTrue: [ 337626 outBuffer := (self streamBuffer: ((outBuffer size max: bytesToWrite) * 2)) 337627 replaceFrom: 1 to: outBuffer size with: outBuffer startingAt: 1]! ! 337628 337629!SocketStream methodsFor: 'private' stamp: 'gk 2/7/2005 13:09'! 337630checkFlush 337631 "If autoFlush is true we flush if 337632 we have reached the bufferSize 337633 of data in the outBuffer." 337634 337635 (autoFlush and: [outNextToWrite > bufferSize]) 337636 ifTrue: [self flush]! ! 337637 337638!SocketStream methodsFor: 'private' stamp: 'gk 2/7/2005 23:05'! 337639growInBuffer 337640 "Grows through doubling." 337641 337642 self resizeInBuffer: inBuffer size * 2! ! 337643 337644!SocketStream methodsFor: 'private' stamp: 'gk 2/8/2005 22:15'! 337645moveInBufferDown 337646 "Move down contents of inBuffer to the start. 337647 Return distance moved." 337648 337649 | sz distanceMoved | 337650 sz := inNextToWrite - lastRead - 1. 337651 inBuffer replaceFrom: 1 to: sz with: inBuffer startingAt: lastRead + 1. 337652 distanceMoved := lastRead. 337653 lastRead := 0. 337654 inNextToWrite := sz + 1. 337655 ^distanceMoved 337656! ! 337657 337658!SocketStream methodsFor: 'private' stamp: 'gk 2/9/2005 22:36'! 337659resetBuffers 337660 "Recreate the buffers with default start sizes." 337661 337662 inBuffer := self streamBuffer: bufferSize. 337663 lastRead := 0. 337664 inNextToWrite := 1. 337665 outBuffer := self streamBuffer: bufferSize. 337666 outNextToWrite := 1! ! 337667 337668!SocketStream methodsFor: 'private' stamp: 'gk 9/9/2005 02:29'! 337669resizeInBuffer: newSize 337670 "Resize the inBuffer by recreating it. 337671 This also has the effect of getting rid of 337672 dead data above inNextToWrite. 337673 <newSize> must >= inBuffer size!!" 337674 337675 inBuffer := (self streamBuffer: newSize) 337676 replaceFrom: 1 to: inNextToWrite - 1 with: inBuffer startingAt: 1! ! 337677 337678!SocketStream methodsFor: 'private' stamp: 'gk 2/9/2005 22:35'! 337679streamBuffer: size 337680 "Create a buffer of the correct class and given size." 337681 337682 ^(self isBinary 337683 ifTrue: [ByteArray] 337684 ifFalse: [String]) new: size! ! 337685 337686 337687!SocketStream methodsFor: 'private-socket' stamp: 'gk 2/25/2005 14:20'! 337688receiveAvailableData 337689 "Receive available data (as much as fits in the inBuffer) 337690 but not waiting for more to arrive. 337691 Return the position in the buffer where the 337692 new data starts, regardless if anything 337693 was read, see #adjustInBuffer." 337694 337695 recentlyRead := socket receiveAvailableDataInto: inBuffer startingAt: inNextToWrite. 337696 ^self adjustInBuffer: recentlyRead! ! 337697 337698!SocketStream methodsFor: 'private-socket' stamp: 'gk 2/25/2005 14:20'! 337699receiveData 337700 "Receive data with timeout if it has been set. 337701 If shouldSignal is false we use the Socket methods 337702 that swallow those Exceptions, if it is true the 337703 caller will have to handle those Exceptions. 337704 Return the position in the buffer where the 337705 new data starts, regardless if anything 337706 was read, see #adjustInBuffer." 337707 337708 recentlyRead := shouldSignal ifTrue: [ 337709 self shouldTimeout ifTrue: [ 337710 socket receiveDataSignallingTimeout: timeout 337711 into: inBuffer startingAt: inNextToWrite] 337712 ifFalse: [ 337713 socket receiveDataSignallingClosedInto: inBuffer 337714 startingAt: inNextToWrite]] 337715 ifFalse: [ 337716 self shouldTimeout ifTrue: [ 337717 "This case is tricky, if it times out and is swallowed 337718 how does other methods calling this method repeatedly 337719 get to know that? And what should they do?" 337720 socket receiveDataTimeout: timeout 337721 into: inBuffer startingAt: inNextToWrite] 337722 ifFalse: [ 337723 socket receiveDataInto: inBuffer 337724 startingAt: inNextToWrite]]. 337725 ^self adjustInBuffer: recentlyRead! ! 337726 337727!SocketStream methodsFor: 'private-socket' stamp: 'gk 2/9/2005 22:53'! 337728receiveDataIfAvailable 337729 "Only used to check that there really is data to read 337730 from the socket after it signals dataAvailable. 337731 It has been known to signal true and then still 337732 not have anything to read. See also isDataAvailable. 337733 Return the position in the buffer where the 337734 new data starts, regardless if anything 337735 was read, see #adjustInBuffer." 337736 337737 recentlyRead := socket receiveSomeDataInto: inBuffer startingAt: inNextToWrite. 337738 ^self adjustInBuffer: recentlyRead! ! 337739 337740"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 337741 337742SocketStream class 337743 instanceVariableNames: ''! 337744 337745!SocketStream class methodsFor: 'example' stamp: 'md 8/14/2005 18:25'! 337746finger: userName 337747 "SocketStream finger: 'stp'" 337748 337749 | addr s | 337750 addr := NetNameResolver promptUserForHostAddress. 337751 s := SocketStream openConnectionToHost: addr port: 79. "finger port number" 337752 Transcript show: '---------- Connecting ----------'; cr. 337753 s sendCommand: userName. 337754 Transcript show: s getLine. 337755 s close. 337756 Transcript show: '---------- Connection Closed ----------'; cr; endEntry. 337757! ! 337758 337759 337760!SocketStream class methodsFor: 'instance creation' stamp: 'gk 2/3/2005 22:19'! 337761on: socket 337762 "Create a socket stream on a connected server socket." 337763 337764 ^self basicNew initialize socket: socket! ! 337765 337766!SocketStream class methodsFor: 'instance creation' stamp: 'gk 2/3/2005 20:35'! 337767openConnectionToHost: hostIP port: portNumber 337768 | socket | 337769 socket := Socket new. 337770 socket connectTo: hostIP port: portNumber. 337771 ^self on: socket! ! 337772 337773!SocketStream class methodsFor: 'instance creation' stamp: 'gk 2/3/2005 20:35'! 337774openConnectionToHostNamed: hostName port: portNumber 337775 | hostIP | 337776 hostIP := NetNameResolver addressForName: hostName timeout: 20. 337777 ^self openConnectionToHost: hostIP port: portNumber! ! 337778Socket subclass: #SocksSocket 337779 instanceVariableNames: 'vers method socksIP socksPort dstPort dstIP dstName' 337780 classVariableNames: 'DefaultSocksVersion' 337781 poolDictionaries: '' 337782 category: 'Network-Kernel'! 337783!SocksSocket commentStamp: '<historical>' prior: 0! 337784This class implements the socks 4 and partially socks 5 connection protocol. 337785For backward compatibility the socks protocol is disabled by default, so subclasses still work. 337786For further documentation check out: 337787 337788Socks4: http://spiderman.socks.nec.com/protocol/socks4.protocol 337789 337790Socks5: http://spiderman.socks.nec.com/rfc/rfc1928.txt! 337791 337792 337793!SocksSocket methodsFor: 'connection open/close' stamp: 'nice 4/28/2009 21:40'! 337794connectTo: hostAddress port: port 337795 self initializeNetwork. 337796 self shouldUseSocks 337797 ifFalse: [^super connectTo: hostAddress port: port]. 337798 super connectTo: socksIP port: socksPort. 337799 self waitForConnectionFor: Socket standardTimeout. 337800 dstIP := hostAddress. 337801 dstPort := port. 337802 vers == 4 337803 ifTrue: [self connectSocks4] 337804 ifFalse: [self connectSocks5] 337805 ! ! 337806 337807!SocksSocket methodsFor: 'connection open/close' stamp: 'nice 4/28/2009 21:41'! 337808connectToHostNamed: hostName port: port 337809 super connectTo: socksIP port: socksPort. 337810 self waitForConnectionFor: Socket standardTimeout. 337811 dstName := hostName. 337812 dstPort := port. 337813 vers == 4 337814 ifTrue: [self connectSocks4] 337815 ifFalse: [self connectSocks5] 337816 ! ! 337817 337818 337819!SocksSocket methodsFor: 'initialize' stamp: 'mir 9/26/2000 00:05'! 337820socks4 337821 vers := 4. 337822 method := nil. 337823 socksIP := self class defaultSocksHostAddress. 337824 socksPort := self class defaultSocksPort! ! 337825 337826!SocksSocket methodsFor: 'initialize' stamp: 'mir 9/26/2000 00:05'! 337827socks5 337828 vers := 5. 337829 method := self class noAutorizationMethod. 337830 socksIP := self class defaultSocksHostAddress. 337831 socksPort := self class defaultSocksPort! ! 337832 337833 337834!SocksSocket methodsFor: 'methods' stamp: 'mir 3/6/2000 13:24'! 337835noAutorizationMethod 337836 ^0! ! 337837 337838 337839!SocksSocket methodsFor: 'socks4' stamp: 'mir 3/6/2000 15:07'! 337840connectSocks4 337841 self 337842 sendSocks4ConnectionRequestUserId: ''; 337843 waitForSocks4ConnectionReply. 337844! ! 337845 337846!SocksSocket methodsFor: 'socks4' stamp: 'PeterHugossonMiller 9/3/2009 11:24'! 337847sendSocks4ConnectionRequestUserId: userId 337848 "The client connects to the SOCKS server and sends a CONNECT request when 337849it wants to establish a connection to an application server. The client 337850includes in the request packet the IP address and the port number of the 337851destination host, and userid, in the following format. 337852 337853 +----+----+----+----+----+----+----+----+----+----+....+----+ 337854 | VN | CD | DSTPORT | DSTIP | USERID |NULL| 337855 +----+----+----+----+----+----+----+----+----+----+....+----+ 337856 1 1 2 4 variable 1 337857 " 337858 337859 | requestString | 337860 requestString := ByteArray new writeStream. 337861 dstIP 337862 ifNil: [dstIP := NetNameResolver addressForName: dstName]. 337863 requestString 337864 nextPut: 4; 337865 nextPut: self connectCommandCode; 337866 nextWordPut: dstPort; 337867 nextPutAll: self dstIP; 337868 nextPutAll: userId asByteArray; 337869 nextPut: 0. 337870 self sendData: requestString contents! ! 337871 337872!SocksSocket methodsFor: 'socks4' stamp: 'mir 3/6/2000 15:11'! 337873waitForSocks4ConnectionReply 337874 337875 | response | 337876 response := self waitForReply: 8 for: self defaultTimeOutDuration. 337877 337878 (response at: 2) = self requestGrantedCode 337879 ifFalse: [^self socksError: 'Connection failed: ' , (response at: 2) printString].! ! 337880 337881 337882!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 17:42'! 337883connectSocks5 337884 self 337885 socks5MethodSelection; 337886 sendSocks5ConnectionRequest; 337887 socks5RequestReply 337888! ! 337889 337890!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 17:29'! 337891hostIP6Code 337892 ^4! ! 337893 337894!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 15:20'! 337895hostIPCode 337896 ^1! ! 337897 337898!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 15:15'! 337899qualifiedHostNameCode 337900 ^3! ! 337901 337902!SocksSocket methodsFor: 'socks5' stamp: 'PeterHugossonMiller 9/3/2009 11:24'! 337903sendSocks5ConnectionRequest 337904 "Once the method-dependent subnegotiation has completed, the client 337905 sends the request details." 337906 337907 | requestString | 337908 requestString := ByteArray new writeStream. 337909 requestString 337910 nextPut: 5; 337911 nextPut: self connectCommandCode; 337912 nextPut: 0. "Reserved slot" 337913 dstName isNil 337914 ifTrue: [ 337915 requestString 337916 nextPutAll: self hostIPCode; 337917 nextPutAll: dstIP] 337918 ifFalse: [ 337919 requestString 337920 nextPut: self qualifiedHostNameCode; 337921 nextPut: dstName size; 337922 nextPutAll: dstName asByteArray]. 337923 requestString nextWordPut: dstPort. 337924 self sendData: requestString contents! ! 337925 337926!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 17:35'! 337927skipQualifiedHostName 337928 337929 | startTime response bytesRead | 337930 startTime := Time millisecondClockValue. 337931 response := ByteArray new: 1. 337932 337933 [(bytesRead := self receiveDataInto: response) < 1 337934 and: [(Time millisecondClockValue - startTime) < self defaultTimeOutDuration]] whileTrue. 337935 337936 bytesRead < 1 337937 ifTrue: [self socksError: 'Time out reading data']. 337938 337939 self waitForReply: (response at: 1) + 2 for: self defaultTimeOutDuration! ! 337940 337941!SocksSocket methodsFor: 'socks5' stamp: 'PeterHugossonMiller 9/3/2009 11:24'! 337942socks5MethodSelection 337943 "The client connects to the server, and sends a version 337944 identifier/method selection message. 337945 The server selects from one of the methods given in METHODS, and 337946 sends a METHOD selection message." 337947 337948 | requestString response | 337949 requestString := ByteArray new writeStream. 337950 requestString 337951 nextPut: 5; 337952 nextPut: 1; 337953 nextPut: 0. 337954 self sendData: requestString contents. 337955 337956 response := self waitForReply: 2 for: self defaultTimeOutDuration. 337957 (response at: 2) == 16rFF 337958 ifTrue: [self socksError: 'No acceptable methods.'] 337959 ifFalse: [method := response at: 2]! ! 337960 337961!SocksSocket methodsFor: 'socks5' stamp: 'mir 3/6/2000 17:28'! 337962socks5RequestReply 337963 337964 | response | 337965 response := self waitForReply: 4 for: self defaultTimeOutDuration. 337966 "Skip rest for now." 337967 (response at: 4) = self hostIPCode 337968 ifTrue: [self waitForReply: 6 for: self defaultTimeOutDuration]. 337969 (response at: 4) = self qualifiedHostNameCode 337970 ifTrue: [self skipQualifiedHostName]. 337971 (response at: 4) = self hostIP6Code 337972 ifTrue: [self waitForReply: 18 for: self defaultTimeOutDuration]. 337973 (response at: 2) ~= 0 337974 ifTrue: [^self socksError: 'Connection failed: ', (response at: 2) printString]. 337975! ! 337976 337977 337978!SocksSocket methodsFor: 'private' stamp: 'mir 3/6/2000 13:34'! 337979connectCommandCode 337980 ^1! ! 337981 337982!SocksSocket methodsFor: 'private' stamp: 'mir 3/6/2000 15:07'! 337983defaultTimeOutDuration 337984 ^20000! ! 337985 337986!SocksSocket methodsFor: 'private' stamp: 'mir 3/6/2000 15:29'! 337987dstIP 337988 ^dstIP! ! 337989 337990!SocksSocket methodsFor: 'private' stamp: 'mir 2/22/2002 16:23'! 337991dstPort 337992 ^dstPort! ! 337993 337994!SocksSocket methodsFor: 'private' stamp: 'mir 3/6/2000 14:03'! 337995requestGrantedCode 337996 ^90! ! 337997 337998!SocksSocket methodsFor: 'private' stamp: 'mir 9/26/2000 11:23'! 337999shouldUseSocks 338000 ^vers notNil! ! 338001 338002!SocksSocket methodsFor: 'private' stamp: 'mir 3/6/2000 15:11'! 338003socksError: errorString 338004 self close; destroy. 338005 self error: errorString! ! 338006 338007!SocksSocket methodsFor: 'private' stamp: 'len 12/14/2002 11:39'! 338008waitForReply: replySize for: timeOutDuration 338009 | startTime response delay bytesRead | 338010 startTime := Time millisecondClockValue. 338011 response := ByteArray new: replySize. 338012 bytesRead := 0. 338013 delay := Delay forMilliseconds: 500. 338014 [bytesRead < replySize 338015 and: [(Time millisecondClockValue - startTime) < timeOutDuration]] whileTrue: [ 338016 bytesRead := bytesRead + (self receiveDataInto: response). 338017 delay wait. 338018 Transcript show: '.']. 338019 bytesRead < replySize 338020 ifTrue: [self close; destroy. 338021 ^ (ConnectionRefused host: self dstIP port: self dstPort) signal]. 338022 ^response! ! 338023 338024"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 338025 338026SocksSocket class 338027 instanceVariableNames: ''! 338028 338029!SocksSocket class methodsFor: 'accessing' stamp: 'nk 7/6/2003 07:30'! 338030defaultSocksHostAddress 338031 338032 ^NetNameResolver addressForName: HTTPSocket httpProxyServer! ! 338033 338034!SocksSocket class methodsFor: 'accessing' stamp: 'nk 7/6/2003 07:30'! 338035defaultSocksPort 338036 ^HTTPSocket httpProxyPort! ! 338037 338038!SocksSocket class methodsFor: 'accessing' stamp: 'mir 9/26/2000 00:06'! 338039defaultSocksVersion 338040 "nil means no socks" 338041 ^DefaultSocksVersion! ! 338042 338043!SocksSocket class methodsFor: 'accessing' stamp: 'mir 9/26/2000 00:07'! 338044defaultSocksVersion: anInteger 338045 "nil means no socks" 338046 DefaultSocksVersion := anInteger! ! 338047FillStyle subclass: #SolidFillStyle 338048 instanceVariableNames: 'color pixelValue32' 338049 classVariableNames: '' 338050 poolDictionaries: '' 338051 category: 'Balloon-Fills'! 338052!SolidFillStyle commentStamp: '<historical>' prior: 0! 338053SolidFillStyle is a fill which represents a color for the BalloonEngine. 338054 338055Instance variables: 338056 color <Color> The color to use. 338057 pixelValue32 <Integer> The cached pixel value to use.! 338058 338059 338060!SolidFillStyle methodsFor: 'accessing' stamp: 'ar 1/14/1999 15:24'! 338061color: aColor 338062 color := aColor. 338063 pixelValue32 := aColor scaledPixelValue32! ! 338064 338065!SolidFillStyle methodsFor: 'accessing' stamp: 'ar 11/9/1998 03:29'! 338066display 338067 ^color display! ! 338068 338069!SolidFillStyle methodsFor: 'accessing' stamp: 'ar 1/14/1999 15:25'! 338070scaledPixelValue32 338071 "Return the alpha scaled pixel value for depth 32" 338072 ^pixelValue32! ! 338073 338074 338075!SolidFillStyle methodsFor: 'converting' stamp: 'ar 11/9/1998 13:55'! 338076asColor 338077 ^color! ! 338078 338079 338080!SolidFillStyle methodsFor: 'printing' stamp: 'ar 11/17/1998 00:29'! 338081printOn: aStream 338082 super printOn: aStream. 338083 aStream nextPut:$(; print: color; nextPut:$).! ! 338084 338085 338086!SolidFillStyle methodsFor: 'testing' stamp: 'ar 11/8/1998 18:34'! 338087isSolidFill 338088 ^true! ! 338089 338090!SolidFillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:30'! 338091isTranslucent 338092 ^color isTranslucent! ! 338093 338094!SolidFillStyle methodsFor: 'testing' stamp: 'ar 10/26/2000 19:25'! 338095isTransparent 338096 ^color isTransparent! ! 338097 338098"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 338099 338100SolidFillStyle class 338101 instanceVariableNames: ''! 338102 338103!SolidFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/8/1998 18:31'! 338104color: aColor 338105 ^self new color: aColor! ! 338106OrderedCollection subclass: #SortedCollection 338107 instanceVariableNames: 'sortBlock' 338108 classVariableNames: '' 338109 poolDictionaries: '' 338110 category: 'Collections-Sequenceable'! 338111!SortedCollection commentStamp: '<historical>' prior: 0! 338112I represent a collection of objects ordered by some property of the objects themselves. The ordering is specified in a BlockContext.! 338113 338114 338115!SortedCollection methodsFor: '*splitjoin' stamp: 'onierstrasz 4/12/2009 19:57'! 338116join: aCollection 338117 "Curiously addAllLast: does not trigger a reSort, so we must do it here." 338118 ^ (super join: aCollection) reSort; yourself 338119! ! 338120 338121 338122!SortedCollection methodsFor: 'accessing' stamp: 'sma 4/28/2000 17:47'! 338123at: anInteger put: anObject 338124 self shouldNotImplement! ! 338125 338126!SortedCollection methodsFor: 'accessing' stamp: 'tk 3/28/1999 22:55'! 338127median 338128 "Return the middle element, or as close as we can get." 338129 338130 ^ self at: self size + 1 // 2! ! 338131 338132!SortedCollection methodsFor: 'accessing'! 338133sortBlock 338134 "Answer the blockContext which is the criterion for sorting elements of 338135 the receiver." 338136 338137 ^sortBlock! ! 338138 338139!SortedCollection methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 21:11'! 338140sortBlock: aBlock 338141 "Make the argument, aBlock, be the criterion for ordering elements of the 338142 receiver." 338143 338144 sortBlock := aBlock. 338145 "sortBlocks with side effects may not work right" 338146 self size > 0 ifTrue: [self reSort]! ! 338147 338148 338149!SortedCollection methodsFor: 'adding' stamp: 'go 4/27/2000 13:19'! 338150add: newObject 338151 ^ super insert: newObject before: (self indexForInserting: newObject)! ! 338152 338153!SortedCollection methodsFor: 'adding' stamp: 'sma 4/28/2000 18:35'! 338154addAll: aCollection 338155 aCollection size > (self size // 3) 338156 ifTrue: 338157 [aCollection do: [:each | self addLast: each]. 338158 self reSort] 338159 ifFalse: [aCollection do: [:each | self add: each]]. 338160 ^ aCollection! ! 338161 338162!SortedCollection methodsFor: 'adding' stamp: 'go 4/26/2000 17:26'! 338163addFirst: newObject 338164 self shouldNotImplement! ! 338165 338166!SortedCollection methodsFor: 'adding' stamp: 'MPH 10/23/2000 13:31'! 338167copyEmpty 338168 "Answer a copy of the receiver without any of the receiver's elements." 338169 338170 ^self species sortBlock: sortBlock! ! 338171 338172 338173!SortedCollection methodsFor: 'comparing'! 338174= aSortedCollection 338175 "Answer true if my and aSortedCollection's species are the same, 338176 and if our blocks are the same, and if our elements are the same." 338177 338178 self species = aSortedCollection species ifFalse: [^ false]. 338179 sortBlock = aSortedCollection sortBlock 338180 ifTrue: [^ super = aSortedCollection] 338181 ifFalse: [^ false]! ! 338182 338183 338184!SortedCollection methodsFor: 'copying'! 338185copy 338186 338187 | newCollection | 338188 newCollection := self species sortBlock: sortBlock. 338189 newCollection addAll: self. 338190 ^newCollection! ! 338191 338192 338193!SortedCollection methodsFor: 'enumerating' stamp: 'sma 2/5/2000 15:22'! 338194collect: aBlock 338195 "Evaluate aBlock with each of my elements as the argument. Collect the 338196 resulting values into an OrderedCollection. Answer the new collection. 338197 Override the superclass in order to produce an OrderedCollection instead 338198 of a SortedCollection." 338199 338200 | newCollection | 338201 newCollection := OrderedCollection new: self size. 338202 self do: [:each | newCollection addLast: (aBlock value: each)]. 338203 ^ newCollection! ! 338204 338205 338206!SortedCollection methodsFor: 'private' stamp: 'stp 04/23/1999 05:32'! 338207defaultSort: i to: j 338208 "Sort elements i through j of self to be nondescending according to 338209 sortBlock." "Assume the default sort block ([:x :y | x <= y])." 338210 338211 | di dij dj tt ij k l n | 338212 "The prefix d means the data at that index." 338213 (n := j + 1 - i) <= 1 ifTrue: [^self]. "Nothing to sort." 338214 "Sort di,dj." 338215 di := array at: i. 338216 dj := array at: j. 338217 (di <= dj) "i.e., should di precede dj?" 338218 ifFalse: 338219 [array swap: i with: j. 338220 tt := di. 338221 di := dj. 338222 dj := tt]. 338223 n > 2 338224 ifTrue: "More than two elements." 338225 [ij := (i + j) // 2. "ij is the midpoint of i and j." 338226 dij := array at: ij. "Sort di,dij,dj. Make dij be their median." 338227 (di <= dij) "i.e. should di precede dij?" 338228 ifTrue: 338229 [(dij <= dj) "i.e., should dij precede dj?" 338230 ifFalse: 338231 [array swap: j with: ij. 338232 dij := dj]] 338233 ifFalse: "i.e. di should come after dij" 338234 [array swap: i with: ij. 338235 dij := di]. 338236 n > 3 338237 ifTrue: "More than three elements." 338238 ["Find k>i and l<j such that dk,dij,dl are in reverse order. 338239 Swap k and l. Repeat this procedure until k and l pass each other." 338240 k := i. 338241 l := j. 338242 [[l := l - 1. k <= l and: [dij <= (array at: l)]] 338243 whileTrue. "i.e. while dl succeeds dij" 338244 [k := k + 1. k <= l and: [(array at: k) <= dij]] 338245 whileTrue. "i.e. while dij succeeds dk" 338246 k <= l] 338247 whileTrue: 338248 [array swap: k with: l]. 338249 "Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk 338250 through dj. Sort those two segments." 338251 self defaultSort: i to: l. 338252 self defaultSort: k to: j]]! ! 338253 338254!SortedCollection methodsFor: 'private' stamp: 'stp 04/23/1999 05:36'! 338255indexForInserting: newObject 338256 338257 | index low high | 338258 low := firstIndex. 338259 high := lastIndex. 338260 sortBlock isNil 338261 ifTrue: [[index := high + low // 2. low > high] 338262 whileFalse: 338263 [((array at: index) <= newObject) 338264 ifTrue: [low := index + 1] 338265 ifFalse: [high := index - 1]]] 338266 ifFalse: [[index := high + low // 2. low > high] 338267 whileFalse: 338268 [(sortBlock value: (array at: index) value: newObject) 338269 ifTrue: [low := index + 1] 338270 ifFalse: [high := index - 1]]]. 338271 ^low! ! 338272 338273!SortedCollection methodsFor: 'private' stamp: 'go 4/26/2000 17:17'! 338274insert: anObject before: spot 338275 self shouldNotImplement! ! 338276 338277!SortedCollection methodsFor: 'private' stamp: 'sma 4/28/2000 17:46'! 338278reSort 338279 self sort: firstIndex to: lastIndex! ! 338280 338281!SortedCollection methodsFor: 'private' stamp: 'stp 04/23/1999 05:33'! 338282sort: i to: j 338283 "Sort elements i through j of self to be nondescending according to 338284 sortBlock." 338285 338286 | di dij dj tt ij k l n | 338287 sortBlock ifNil: [^self defaultSort: i to: j]. 338288 "The prefix d means the data at that index." 338289 (n := j + 1 - i) <= 1 ifTrue: [^self]. "Nothing to sort." 338290 "Sort di,dj." 338291 di := array at: i. 338292 dj := array at: j. 338293 (sortBlock value: di value: dj) "i.e., should di precede dj?" 338294 ifFalse: 338295 [array swap: i with: j. 338296 tt := di. 338297 di := dj. 338298 dj := tt]. 338299 n > 2 338300 ifTrue: "More than two elements." 338301 [ij := (i + j) // 2. "ij is the midpoint of i and j." 338302 dij := array at: ij. "Sort di,dij,dj. Make dij be their median." 338303 (sortBlock value: di value: dij) "i.e. should di precede dij?" 338304 ifTrue: 338305 [(sortBlock value: dij value: dj) "i.e., should dij precede dj?" 338306 ifFalse: 338307 [array swap: j with: ij. 338308 dij := dj]] 338309 ifFalse: "i.e. di should come after dij" 338310 [array swap: i with: ij. 338311 dij := di]. 338312 n > 3 338313 ifTrue: "More than three elements." 338314 ["Find k>i and l<j such that dk,dij,dl are in reverse order. 338315 Swap k and l. Repeat this procedure until k and l pass each other." 338316 k := i. 338317 l := j. 338318 [[l := l - 1. k <= l and: [sortBlock value: dij value: (array at: l)]] 338319 whileTrue. "i.e. while dl succeeds dij" 338320 [k := k + 1. k <= l and: [sortBlock value: (array at: k) value: dij]] 338321 whileTrue. "i.e. while dij succeeds dk" 338322 k <= l] 338323 whileTrue: 338324 [array swap: k with: l]. 338325 "Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk 338326 through dj. Sort those two segments." 338327 self sort: i to: l. 338328 self sort: k to: j]]! ! 338329 338330"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 338331 338332SortedCollection class 338333 instanceVariableNames: ''! 338334 338335!SortedCollection class methodsFor: 'instance creation' stamp: 'stp 04/23/1999 05:34'! 338336new: anInteger 338337 "The default sorting function is a <= comparison on elements." 338338 338339 ^(super new: anInteger) "sortBlock: [:x :y | x <= y]" "nil sortBlock OK"! ! 338340 338341!SortedCollection class methodsFor: 'instance creation'! 338342sortBlock: aBlock 338343 "Answer an instance of me such that its elements are sorted according to 338344 the criterion specified in aBlock." 338345 338346 ^(super new: 10) sortBlock: aBlock! ! 338347CollectionRootTest subclass: #SortedCollectionTest 338348 uses: TEmptyTest + TIterateSequencedReadableTest + TPrintOnSequencedTest + TAsStringCommaAndDelimiterSequenceableTest + TIncludesWithIdentityCheckTest + TSequencedElementAccessTest - {#testAtAll} + TSubCollectionAccess + TIndexAccessForMultipliness + TRemoveTest + TConvertTest + TConvertAsSetForMultiplinessIdentityTest + TAddTest + TBeginsEndsWith + TCopySequenceableSameContents - {#testShuffled} + TSetArithmetic + TRemoveByIndexTest + TCopyPartOfSequenceable + TCopyPartOfSequenceableForMultipliness + TCopySequenceableWithOrWithoutSpecificElements - {#testForceToPaddingStartWith. #testForceToPaddingWith. #testCopyWithFirst. #testCopyWithoutIndex} + TCopySequenceableWithReplacementForSorted + TCopyTest + TConvertAsSortedTest + TSequencedStructuralEqualityTest + TCreationWithTest + TOccurrencesForMultiplinessTest 338349 instanceVariableNames: 'nonEmpty elementExistsTwice empty collection result nonEmpty1Element collectionOfFloat accessCollection elementNoteIn oldSubcollection floatCollectionSameEndAndBegining withoutEqualElements collectionOfFloatWithDuplicate collectionIncluded collectionNotIncluded collectionWithoutNil duplicateFloat nonEmpty5Elements' 338350 classVariableNames: '' 338351 poolDictionaries: '' 338352 category: 'CollectionsTests-Unordered'! 338353 338354!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:27'! 338355testAdd 338356 "self run: #testAdd" 338357 "self debug: #testAdd" 338358 338359 | collection | 338360 collection := #(10 9 8 7 5 4 4 2) asSortedCollection. 338361 self assert: collection first = 2. 338362 self assert: collection last = 10. 338363 self assert: (collection size = 8). 338364 collection add:1. 338365 self assert: (collection size = 9). 338366 collection add: 6. 338367 self assert: ((collection at: 5) = 5). 338368 self assert: (collection size = 10). 338369 collection add: 3. 338370 ! ! 338371 338372!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:30'! 338373testAddAll 338374 "self run: #testAddAll" 338375 "self debug: #testAddAll" 338376 338377 | sorted2 sorted| 338378 sorted2 := SortedCollection new. 338379 sorted2 add: 'brochet'; add:'truitelle'. 338380 sorted := SortedCollection new. 338381 sorted addAll: sorted2. 338382 self assert: (sorted hasEqualElements: sorted2). 338383 ! ! 338384 338385!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:32'! 338386testAddAll2 338387 "self run: #testAddAll2" 338388 "self debug: #testAddAll2" 338389 338390 | sorted2 sorted| 338391 sorted2 := SortedCollection new. 338392 sorted2 add: 'brochet'; add:'truitelle'. 338393 sorted := SortedCollection new. 338394 sorted add: 'perche'. 338395 sorted addAll: sorted2. 338396 self assert: (sorted size = (sorted2 size + 1)). 338397 sorted2 do: 338398 [ :each | self assert: (sorted includes: each)] 338399 ! ! 338400 338401!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:33'! 338402testCollect 338403 "self run: #testCollect" 338404 338405 |result aSortedCollection| 338406 aSortedCollection := SortedCollection new. 338407 result := OrderedCollection new. 338408 result add:true ; add: true ; add: true ;add: false ; add: false. 338409 aSortedCollection := (1 to: 5) asSortedCollection. 338410 self assert: (result = (aSortedCollection collect: [:each | each < 4])). 338411 ! ! 338412 338413!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:39'! 338414testCopy 338415 "self run: #testCopy" 338416 "self debug: #testCopy" 338417 338418 |aSortedCollection copySorted| 338419 aSortedCollection := SortedCollection new. 338420 aSortedCollection sortBlock: [:a :b | a < b]. 338421 aSortedCollection add: 'truite' ; add: 'brochet'. 338422 self assert: aSortedCollection first = 'brochet'. 338423 338424 copySorted := aSortedCollection copy. 338425 338426 self assert: (copySorted hasEqualElements: aSortedCollection). 338427 self assert: (copySorted species = aSortedCollection species). 338428 self assert: (copySorted sortBlock = aSortedCollection sortBlock). 338429 self assert: copySorted first = 'brochet'.! ! 338430 338431!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:30'! 338432testCreation 338433 "self run: #testCreation" 338434 "self debug: #testCreation" 338435 338436 | collection | 338437 collection := #(10 9 3 6 1 8 7 5 4 2) asSortedCollection. 338438 self assert: collection = (1 to: 10) asSortedCollection. 338439 ! ! 338440 338441!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:42'! 338442testEquals 338443 "self run: #testEquals" 338444 "self debug: #testEquals" 338445 338446 |aSortedCollection| 338447 aSortedCollection := SortedCollection new. 338448 aSortedCollection add:'truite' ; add: 'brochet'. 338449 self assert: aSortedCollection copy = aSortedCollection.! ! 338450 338451!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:43'! 338452testMedian 338453 "self run: #testMedian" 338454 "self debug: #testMedian" 338455 338456 |aSortedCollection| 338457 aSortedCollection := (1 to: 10) asSortedCollection. 338458 self assert: aSortedCollection median=5. 338459 338460 aSortedCollection := SortedCollection new. 338461 aSortedCollection add:'truite' ; add:'porcinet' ; add:'carpe'. 338462 self assert: (aSortedCollection median = 'porcinet'). 338463 ! ! 338464 338465!SortedCollectionTest methodsFor: 'basic' stamp: 'nice 9/14/2009 21:02'! 338466testRemoveAll 338467 "Allows one to remove all elements of a collection" 338468 338469 | c1 c2 s2 | 338470 c1 := #(10 9 8 7 5 4 4 2) asSortedCollection: [:a :b | a >= b]. 338471 c2 := c1 copy. 338472 s2 := c2 size. 338473 338474 c1 removeAll. 338475 338476 self assert: c1 size = 0. 338477 self assert: c2 size = s2 description: 'the copy has not been modified'. 338478 338479 c1 add: 13; add: 14. 338480 self assert: (c1 first = 14 and: [c1 second = 13]) description: 'the sortBlock has been preserved'.! ! 338481 338482!SortedCollectionTest methodsFor: 'basic' stamp: 'DM 3/16/2006 11:38'! 338483testSortBlock 338484 "self run: #testSortBlock" 338485 "self debug: #testSortBlock" 338486 338487 |aSortedCollection| 338488 aSortedCollection := SortedCollection new. 338489 aSortedCollection sortBlock: [:a :b | a < b]. 338490 aSortedCollection add: 'truite' ; add: 'brochet' ; add: 'tortue'. 338491 self assert: aSortedCollection first = 'brochet'. 338492 338493 aSortedCollection := SortedCollection new. 338494 aSortedCollection sortBlock: [:a :b | a >b]. 338495 aSortedCollection add: 'truite' ; add: 'brochet' ; add: 'tortue'. 338496 self assert: aSortedCollection first = 'truite'. 338497 338498 338499 ! ! 338500 338501!SortedCollectionTest methodsFor: 'basic' stamp: 'nice 5/22/2008 09:59'! 338502testSpeciesLooseSortBlock 338503 "This is a non regression test for http://bugs.squeak.org/view.php?id=6535" 338504 338505 | numbers reverseOrder firstThree | 338506 numbers := #(1 2 3 4 5). 338507 reverseOrder := SortedCollection sortBlock: [:x :y | x > y]. 338508 reverseOrder addAll: numbers. 338509 338510 "The elements are inverted" 338511 self assert: [reverseOrder asArray = #(5 4 3 2 1)]. 338512 338513 "Copy the first 3 elements" 338514 firstThree := reverseOrder copyFrom: 1 to: 3. 338515 338516 "It appears to work" 338517 self assert: [firstThree asArray = #(5 4 3)]. 338518 338519 "but we have lost the sort block" 338520 firstThree add: 1. 338521 338522 " firstThree is now #(1 5 4 3)!! " 338523 self assert: [firstThree asArray = #(5 4 3 1)] "fails"! ! 338524 338525 338526!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:32'! 338527accessCollection 338528" return a collection of size 5 " 338529 ^accessCollection ! ! 338530 338531!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 14:33'! 338532anotherElementNotIn 338533" return an element different of 'elementNotIn' not included in 'nonEmpty' " 338534 ^666! ! 338535 338536!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:00'! 338537anotherElementOrAssociationIn 338538 " return an element (or an association for Dictionary ) present in 'collection' " 338539 ^ self collection anyOne! ! 338540 338541!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:00'! 338542anotherElementOrAssociationNotIn 338543 " return an element (or an association for Dictionary )not present in 'collection' " 338544 ^ elementNoteIn ! ! 338545 338546!SortedCollectionTest methodsFor: 'requirements' stamp: 'stephane.ducasse 12/20/2008 22:24'! 338547collection 338548 338549 ^ collection! ! 338550 338551!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 16:30'! 338552collectionClass 338553" return the class to be used to create instances of the class tested" 338554 ^ SortedCollection! ! 338555 338556!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:21'! 338557collectionMoreThan1NoDuplicates 338558 " return a collection of size 5 without equal elements" 338559 ^ withoutEqualElements ! ! 338560 338561!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:18'! 338562collectionMoreThan5Elements 338563" return a collection including at least 5 elements" 338564 338565 ^ nonEmpty5Elements ! ! 338566 338567!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 14:55'! 338568collectionNotIncluded 338569" return a collection for wich each element is not included in 'nonEmpty' " 338570 ^ collectionNotIncluded ! ! 338571 338572!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:31'! 338573collectionOfFloat 338574" return a collection only includiing Float elements " 338575 ^ collectionOfFloat ! ! 338576 338577!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 13:46'! 338578collectionOfSize5 338579" return a collection of size 5" 338580^ accessCollection ! ! 338581 338582!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:48'! 338583collectionWith1TimeSubcollection 338584" return a collection including 'oldSubCollection' only one time " 338585 ^ (SortedCollection new add: elementNoteIn ; yourself) , self oldSubCollection ! ! 338586 338587!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:48'! 338588collectionWith2TimeSubcollection 338589" return a collection including 'oldSubCollection' two or many time " 338590 ^ (SortedCollection new add: elementNoteIn ; yourself) , self oldSubCollection , self oldSubCollection ! ! 338591 338592!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 10:23'! 338593collectionWith5Elements 338594" return a collection of size 5 including 5 elements" 338595^ accessCollection ! ! 338596 338597!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:49'! 338598collectionWithCopy 338599 "return a collection of type 'self collectionWIithoutEqualsElements clas' containing no elements equals ( with identity equality) 338600 but 2 elements only equals with classic equality" 338601 | result collection | 338602 collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. 338603 collection add: collection first copy. 338604 result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. 338605 ^ result! ! 338606 338607!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! 338608collectionWithCopyNonIdentical 338609 " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" 338610 ^ collectionOfFloat! ! 338611 338612!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 15:10'! 338613collectionWithElement 338614 "Returns a collection that already includes what is returned by #element." 338615 ^ SortedCollection new add: self element ; add: 5 ; add: 2; yourself.! ! 338616 338617!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 14:55'! 338618collectionWithElementsToRemove 338619" return a collection of elements included in 'nonEmpty' " 338620 ^ collectionIncluded ! ! 338621 338622!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:48'! 338623collectionWithEqualElements 338624" return a collecition including atLeast two elements equal" 338625 338626^ collectionOfFloatWithDuplicate ! ! 338627 338628!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:50'! 338629collectionWithIdentical 338630 "return a collection of type : 'self collectionWIithoutEqualsElements class containing two elements equals ( with identity equality)" 338631 | result collection element | 338632 collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. 338633 element := collection first. 338634 collection add: element. 338635 result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. 338636 ^ result! ! 338637 338638!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:14'! 338639collectionWithNonIdentitySameAtEndAndBegining 338640 " return a collection with elements at end and begining equals only with classic equality (they are not the same object). 338641(others elements of the collection are not equal to those elements)" 338642 ^ floatCollectionSameEndAndBegining ! ! 338643 338644!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 11:12'! 338645collectionWithSameAtEndAndBegining 338646" return a collection with elements at end and begining equals . 338647(others elements of the collection are not equal to those elements)" 338648 ^ floatCollectionSameEndAndBegining ! ! 338649 338650!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:29'! 338651collectionWithSortableElements 338652" return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" 338653 ^ collectionOfFloat ! ! 338654 338655!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 14:47'! 338656collectionWithoutEqualElements 338657" return a collection without equal elements" 338658 ^ withoutEqualElements ! ! 338659 338660!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 10:47'! 338661collectionWithoutEqualsElements 338662 338663" return a collection not including equal elements " 338664 ^withoutEqualElements ! ! 338665 338666!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:43'! 338667collectionWithoutNilElements 338668" return a collection that doesn't includes a nil element and that doesn't includes equal elements'" 338669 ^ collectionWithoutNil ! ! 338670 338671!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 15:09'! 338672element 338673 "Returns an object that can be added to the collection returned by #collection." 338674 ^ 88! ! 338675 338676!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:33'! 338677elementInCollectionOfFloat 338678" return an element included in 'collectionOfFloat' " 338679 ^ collectionOfFloat anyOne! ! 338680 338681!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:38'! 338682elementInForElementAccessing 338683" return an element inculded in 'accessCollection '" 338684 ^ self accessCollection anyOne! ! 338685 338686!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 14:34'! 338687elementInForIncludesTest 338688" return an element included in nonEmpty " 338689 ^ nonEmpty anyOne ! ! 338690 338691!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:22'! 338692elementInForIndexAccessing 338693" return an element included in 'accessCollection' " 338694 ^ self collectionMoreThan1NoDuplicates anyOne! ! 338695 338696!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 14:34'! 338697elementNotIn 338698"return an element not included in 'nonEmpty' " 338699 338700 ^ elementNoteIn ! ! 338701 338702!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:39'! 338703elementNotInForElementAccessing 338704" return an element not included in 'accessCollection' " 338705 ^ elementNoteIn ! ! 338706 338707!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:34'! 338708elementNotInForIndexAccessing 338709" return an element not included in 'accessCollection' " 338710 ^ elementNoteIn ! ! 338711 338712!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 11:53'! 338713elementNotInForOccurrences 338714 ^ 666! ! 338715 338716!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 14:55'! 338717elementToAdd 338718" return an element of type 'nonEmpy' elements'type'" 338719 ^ 5! ! 338720 338721!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:50'! 338722elementTwiceInForOccurrences 338723" return an element included exactly two time in # collectionWithEqualElements" 338724^ duplicateFloat ! ! 338725 338726!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:46'! 338727elementsCopyNonIdenticalWithoutEqualElements 338728 " return a collection that does niot incllude equal elements ( classic equality )" 338729 ^ collectionOfFloat! ! 338730 338731!SortedCollectionTest methodsFor: 'requirements' stamp: 'stephane.ducasse 12/20/2008 22:17'! 338732empty 338733 338734 ^ empty! ! 338735 338736!SortedCollectionTest methodsFor: 'requirements' stamp: 'stephane.ducasse 12/20/2008 22:24'! 338737expectedSizeAfterReject 338738 ^1! ! 338739 338740!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 13:41'! 338741floatCollectionWithSameAtEndAndBegining 338742" return a collection with elements at end and begining equals only with classic equality (they are not the same object). 338743(others elements of the collection are not equal to those elements)" 338744 ^ floatCollectionSameEndAndBegining ! ! 338745 338746!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 10:48'! 338747indexInForCollectionWithoutDuplicates 338748" return an index between 'collectionWithoutEqualsElements' bounds" 338749 ^ 2! ! 338750 338751!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 11:58'! 338752indexInNonEmpty 338753" return an index between bounds of 'nonEmpty' " 338754 338755 ^ 2! ! 338756 338757!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 16:01'! 338758integerCollection 338759" return a collection only including SmallInteger elements" 338760 ^ accessCollection ! ! 338761 338762!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 14:47'! 338763integerCollectionWithoutEqualElements 338764" return a collection of integer without equal elements" 338765 ^ withoutEqualElements ! ! 338766 338767!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:50'! 338768moreThan3Elements 338769 " return a collection including atLeast 3 elements" 338770 ^ accessCollection ! ! 338771 338772!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:50'! 338773moreThan4Elements 338774 338775" return a collection including at leat 4 elements" 338776 ^ accessCollection ! ! 338777 338778!SortedCollectionTest methodsFor: 'requirements' stamp: 'stephane.ducasse 12/20/2008 22:17'! 338779nonEmpty 338780 338781 ^ nonEmpty! ! 338782 338783!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:27'! 338784nonEmpty1Element 338785" return a collection of size 1 including one element" 338786 ^ nonEmpty1Element ! ! 338787 338788!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 14:07'! 338789nonEmptyMoreThan1Element 338790" return a collection of integer with more than one element" 338791 ^withoutEqualElements 338792 .! ! 338793 338794!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:28'! 338795nonEmptyWithoutEqualElements 338796" return a collection without equal elements " 338797 ^ withoutEqualElements ! ! 338798 338799!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:51'! 338800oldSubCollection 338801" return a subCollection included in collectionWith1TimeSubcollection . 338802ex : subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)" 338803 ^ oldSubcollection ! ! 338804 338805!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 15:11'! 338806otherCollection 338807 "Returns a collection that does not include what is returned by #element." 338808 ^ SortedCollection new add: 7 ; add: 5 ; add: 2; yourself.! ! 338809 338810!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:43'! 338811replacementCollection 338812" return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection' " 338813 ^ collection ! ! 338814 338815!SortedCollectionTest methodsFor: 'requirements' stamp: 'stephane.ducasse 12/20/2008 22:29'! 338816result 338817 338818 ^ result! ! 338819 338820!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:41'! 338821resultForCollectElementsClass 338822" return the retsult expected by collecting the class of each element of collectionWithoutNilElements" 338823 ^result ! ! 338824 338825!SortedCollectionTest methodsFor: 'requirements' stamp: 'damienpollet 1/14/2009 16:34'! 338826sizeCollection 338827 ^ collection! ! 338828 338829!SortedCollectionTest methodsFor: 'requirements' stamp: 'stephane.ducasse 12/20/2008 22:23'! 338830speciesClass 338831 338832 ^ SortedCollection! ! 338833 338834!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 10:49'! 338835subCollectionNotIn 338836" return a collection for which at least one element is not included in 'accessCollection' " 338837 ^ SortedCollection new add: elementNoteIn ; add: elementNoteIn ; yourself.! ! 338838 338839!SortedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:11'! 338840withEqualElements 338841 " return a collection of float including equal elements (classic equality)" 338842 ^ collectionOfFloatWithDuplicate! ! 338843 338844 338845!SortedCollectionTest methodsFor: 'setup' stamp: 'delaunay 5/14/2009 12:18'! 338846setUp 338847 338848 nonEmpty := SortedCollection new. 338849 elementExistsTwice := 12332312321. 338850 nonEmpty add: 2. 338851 nonEmpty add: elementExistsTwice. 338852 nonEmpty add: elementExistsTwice. 338853 collectionIncluded := SortedCollection new add: 2; add: elementExistsTwice ;yourself. 338854 collectionNotIncluded := SortedCollection new add: 312; add: 313 ;yourself. 338855 empty := SortedCollection new. 338856 collection := SortedCollection new. 338857 collection add: 1. 338858 collection add: -2. 338859 collection add: 3. 338860 collection add: 1. 338861 collectionWithoutNil := SortedCollection new add: 1;add: 2 ;add:4 ;add:5;yourself. 338862 result := OrderedCollection new. "SortedCollection sortBlock: [:a :b | a name < b name]." 338863 result add: SmallInteger. 338864 result add: SmallInteger. 338865 result add: SmallInteger. 338866 result add: SmallInteger. 338867 nonEmpty1Element := SortedCollection new add:5; yourself. 338868 collectionOfFloat := SortedCollection new add:1.2 ; add: 5.6 ; add:4.4 ; add: 1.9 ; yourself. 338869 duplicateFloat := 1.2. 338870 collectionOfFloatWithDuplicate := SortedCollection new add: duplicateFloat ; add: 5.6 ; add:4.4 ; add: duplicateFloat ; yourself. 338871 accessCollection := SortedCollection new add:1 ; add: 5 ; add:4 ; add: 2 ; add:7 ; yourself. 338872 elementNoteIn := 999. 338873 oldSubcollection := SortedCollection new add: 2 ; add: 2 ; add: 2 ; yourself. 338874 floatCollectionSameEndAndBegining := SortedCollection new add: 1.5 ; add: 1.5 copy ; yourself. 338875 withoutEqualElements := SortedCollection new add: 1 ; add: 8 copy ; add: 4;yourself. 338876 nonEmpty5Elements := SortedCollection new add: 1 ; add: 8 copy ; add: 4; add: 4; add: 4;yourself.! ! 338877 338878 338879!SortedCollectionTest methodsFor: 'test - creation'! 338880testOfSize 338881 "self debug: #testOfSize" 338882 338883 | aCol | 338884 aCol := self collectionClass ofSize: 3. 338885 self assert: (aCol size = 3). 338886! ! 338887 338888!SortedCollectionTest methodsFor: 'test - creation'! 338889testWith 338890 "self debug: #testWith" 338891 338892 | aCol element | 338893 element := self collectionMoreThan5Elements anyOne. 338894 aCol := self collectionClass with: element. 338895 self assert: (aCol includes: element).! ! 338896 338897!SortedCollectionTest methodsFor: 'test - creation'! 338898testWithAll 338899 "self debug: #testWithAll" 338900 338901 | aCol collection | 338902 collection := self collectionMoreThan5Elements asOrderedCollection . 338903 aCol := self collectionClass withAll: collection . 338904 338905 collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. 338906 338907 self assert: (aCol size = collection size ).! ! 338908 338909!SortedCollectionTest methodsFor: 'test - creation'! 338910testWithWith 338911 "self debug: #testWithWith" 338912 338913 | aCol collection element1 element2 | 338914 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . 338915 element1 := collection at: 1. 338916 element2 := collection at:2. 338917 338918 aCol := self collectionClass with: element1 with: element2 . 338919 self assert: (aCol occurrencesOf: element1 ) == ( collection occurrencesOf: element1). 338920 self assert: (aCol occurrencesOf: element2 ) == ( collection occurrencesOf: element2). 338921 338922 ! ! 338923 338924!SortedCollectionTest methodsFor: 'test - creation'! 338925testWithWithWith 338926 "self debug: #testWithWithWith" 338927 338928 | aCol collection | 338929 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . 338930 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 338931 338932 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 338933 338934!SortedCollectionTest methodsFor: 'test - creation'! 338935testWithWithWithWith 338936 "self debug: #testWithWithWithWith" 338937 338938 | aCol collection | 338939 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. 338940 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 338941 338942 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 338943 338944!SortedCollectionTest methodsFor: 'test - creation'! 338945testWithWithWithWithWith 338946 "self debug: #testWithWithWithWithWith" 338947 338948 | aCol collection | 338949 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . 338950 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 338951 338952 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 338953 338954 338955!SortedCollectionTest methodsFor: 'test - equality'! 338956testEqualSign 338957 "self debug: #testEqualSign" 338958 338959 self deny: (self empty = self nonEmpty).! ! 338960 338961!SortedCollectionTest methodsFor: 'test - equality'! 338962testEqualSignIsTrueForNonIdenticalButEqualCollections 338963 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 338964 338965 self assert: (self empty = self empty copy). 338966 self assert: (self empty copy = self empty). 338967 self assert: (self empty copy = self empty copy). 338968 338969 self assert: (self nonEmpty = self nonEmpty copy). 338970 self assert: (self nonEmpty copy = self nonEmpty). 338971 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 338972 338973!SortedCollectionTest methodsFor: 'test - equality'! 338974testEqualSignOfIdenticalCollectionObjects 338975 "self debug: #testEqualSignOfIdenticalCollectionObjects" 338976 338977 self assert: (self empty = self empty). 338978 self assert: (self nonEmpty = self nonEmpty). 338979 ! ! 338980 338981 338982!SortedCollectionTest methodsFor: 'test - iterate' stamp: 'ab 12/26/2008 18:03'! 338983testDo2 338984 338985 | res | 338986 res := self speciesClass sortBlock: [:a :b | a name < b name].. 338987 self collection do: [:each | res add: each class]. 338988 self assert: res asArray = self result asArray. 338989! ! 338990 338991 338992!SortedCollectionTest methodsFor: 'tests - adding'! 338993testTAdd 338994 | added collection | 338995 collection :=self otherCollection . 338996 added := collection add: self element. 338997 338998 self assert: added == self element. "test for identiy because #add: has not reason to copy its parameter." 338999 self assert: (collection includes: self element) . 339000 self assert: (self collectionWithElement includes: self element). 339001 339002 ! ! 339003 339004!SortedCollectionTest methodsFor: 'tests - adding'! 339005testTAddAll 339006 | added collection toBeAdded | 339007 collection := self collectionWithElement . 339008 toBeAdded := self otherCollection . 339009 added := collection addAll: toBeAdded . 339010 self assert: added == toBeAdded . "test for identiy because #addAll: has not reason to copy its parameter." 339011 self assert: (collection includesAllOf: toBeAdded )! ! 339012 339013!SortedCollectionTest methodsFor: 'tests - adding'! 339014testTAddIfNotPresentWithElementAlreadyIn 339015 339016 | added oldSize collection element | 339017 collection := self collectionWithElement . 339018 oldSize := collection size. 339019 element := self element . 339020 self assert: (collection includes: element ). 339021 339022 added := collection addIfNotPresent: element . 339023 339024 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 339025 self assert: collection size = oldSize! ! 339026 339027!SortedCollectionTest methodsFor: 'tests - adding'! 339028testTAddIfNotPresentWithNewElement 339029 339030 | added oldSize collection element | 339031 collection := self otherCollection . 339032 oldSize := collection size. 339033 element := self element . 339034 self deny: (collection includes: element ). 339035 339036 added := collection addIfNotPresent: element . 339037 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 339038 self assert: (collection size = (oldSize + 1)). 339039 339040 ! ! 339041 339042!SortedCollectionTest methodsFor: 'tests - adding'! 339043testTAddTwice 339044 | added oldSize collection element | 339045 collection := self collectionWithElement . 339046 element := self element . 339047 oldSize := collection size. 339048 added := collection 339049 add: element ; 339050 add: element . 339051 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 339052 self assert: (collection includes: element ). 339053 self assert: collection size = (oldSize + 2)! ! 339054 339055!SortedCollectionTest methodsFor: 'tests - adding'! 339056testTAddWithOccurences 339057 | added oldSize collection element | 339058 collection := self collectionWithElement . 339059 element := self element . 339060 oldSize := collection size. 339061 added := collection add: element withOccurrences: 5. 339062 339063 self assert: added == element. "test for identiy because #add: has not reason to copy its parameter." 339064 self assert: (collection includes: element). 339065 self assert: collection size = (oldSize + 5)! ! 339066 339067!SortedCollectionTest methodsFor: 'tests - adding'! 339068testTWrite 339069 | added collection element | 339070 collection := self otherCollection . 339071 element := self element . 339072 added := collection write: element . 339073 339074 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 339075 self assert: (collection includes: element ) . 339076 self assert: (collection includes: element ). 339077 339078 ! ! 339079 339080!SortedCollectionTest methodsFor: 'tests - adding'! 339081testTWriteTwice 339082 | added oldSize collection element | 339083 collection := self collectionWithElement . 339084 element := self element . 339085 oldSize := collection size. 339086 added := collection 339087 write: element ; 339088 write: element . 339089 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 339090 self assert: (collection includes: element ). 339091 self assert: collection size = (oldSize + 2)! ! 339092 339093 339094!SortedCollectionTest methodsFor: 'tests - as identity set'! 339095testAsIdentitySetWithIdentityEqualsElements 339096 | result | 339097 result := self collectionWithIdentical asIdentitySet. 339098 " Only one element should have been removed as two elements are equals with Identity equality" 339099 self assert: result size = (self collectionWithIdentical size - 1). 339100 self collectionWithIdentical do: 339101 [ :each | 339102 (self collectionWithIdentical occurrencesOf: each) > 1 339103 ifTrue: 339104 [ "the two elements equals only with classic equality shouldn't 'have been removed" 339105 self assert: (result asOrderedCollection occurrencesOf: each) = 1 339106 " the other elements are still here" ] 339107 ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ]. 339108 self assert: result class = IdentitySet! ! 339109 339110!SortedCollectionTest methodsFor: 'tests - as identity set'! 339111testAsIdentitySetWithoutIdentityEqualsElements 339112 | result collection | 339113 collection := self collectionWithCopy. 339114 result := collection asIdentitySet. 339115 " no elements should have been removed as no elements are equels with Identity equality" 339116 self assert: result size = collection size. 339117 collection do: 339118 [ :each | 339119 (collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ]. 339120 self assert: result class = IdentitySet! ! 339121 339122 339123!SortedCollectionTest methodsFor: 'tests - as set tests'! 339124testAsIdentitySetWithEqualsElements 339125 | result collection | 339126 collection := self withEqualElements . 339127 result := collection asIdentitySet. 339128 collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 339129 self assert: result class = IdentitySet.! ! 339130 339131!SortedCollectionTest methodsFor: 'tests - as set tests'! 339132testAsSetWithEqualsElements 339133 | result | 339134 result := self withEqualElements asSet. 339135 self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 339136 self assert: result class = Set! ! 339137 339138 339139!SortedCollectionTest methodsFor: 'tests - as sorted collection'! 339140testAsSortedArray 339141 | result collection | 339142 collection := self collectionWithSortableElements . 339143 result := collection asSortedArray. 339144 self assert: (result class includesBehavior: Array). 339145 self assert: result isSorted. 339146 self assert: result size = collection size! ! 339147 339148!SortedCollectionTest methodsFor: 'tests - as sorted collection'! 339149testAsSortedCollection 339150 339151 | aCollection result | 339152 aCollection := self collectionWithSortableElements . 339153 result := aCollection asSortedCollection. 339154 339155 self assert: (result class includesBehavior: SortedCollection). 339156 result do: 339157 [ :each | 339158 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 339159 339160 self assert: result size = aCollection size.! ! 339161 339162!SortedCollectionTest methodsFor: 'tests - as sorted collection'! 339163testAsSortedCollectionWithSortBlock 339164 | result tmp | 339165 result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. 339166 self assert: (result class includesBehavior: SortedCollection). 339167 result do: 339168 [ :each | 339169 self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 339170 self assert: result size = self collectionWithSortableElements size. 339171 tmp:=result at: 1. 339172 result do: [:each| self assert: tmp>=each. tmp:=each]. 339173 ! ! 339174 339175 339176!SortedCollectionTest methodsFor: 'tests - begins ends with'! 339177testsBeginsWith 339178 339179 self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty size)). 339180 self assert: (self nonEmpty beginsWith:(self nonEmpty )). 339181 self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 339182 339183!SortedCollectionTest methodsFor: 'tests - begins ends with'! 339184testsBeginsWithEmpty 339185 339186 self deny: (self nonEmpty beginsWith:(self empty)). 339187 self deny: (self empty beginsWith:(self nonEmpty )). 339188! ! 339189 339190!SortedCollectionTest methodsFor: 'tests - begins ends with'! 339191testsEndsWith 339192 339193 self assert: (self nonEmpty endsWith:(self nonEmpty copyWithoutFirst)). 339194 self assert: (self nonEmpty endsWith:(self nonEmpty )). 339195 self deny: (self nonEmpty endsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 339196 339197!SortedCollectionTest methodsFor: 'tests - begins ends with'! 339198testsEndsWithEmpty 339199 339200 self deny: (self nonEmpty endsWith:(self empty )). 339201 self deny: (self empty endsWith:(self nonEmpty )). 339202 ! ! 339203 339204 339205!SortedCollectionTest methodsFor: 'tests - comma and delimiter'! 339206testAsCommaStringEmpty 339207 339208 self assert: self empty asCommaString = ''. 339209 self assert: self empty asCommaStringAnd = ''. 339210 339211 339212! ! 339213 339214!SortedCollectionTest methodsFor: 'tests - comma and delimiter'! 339215testAsCommaStringMore 339216 339217 "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. 339218 self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' 339219" 339220 339221 | result resultAnd index allElementsAsString | 339222 result:= self nonEmpty asCommaString . 339223 resultAnd:= self nonEmpty asCommaStringAnd . 339224 339225 index := 1. 339226 (result findBetweenSubStrs: ',' )do: 339227 [:each | 339228 index = 1 339229 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] 339230 ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. 339231 index:=index+1 339232 ]. 339233 339234 "verifying esultAnd :" 339235 allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 339236 1 to: allElementsAsString size do: 339237 [:i | 339238 i<(allElementsAsString size ) 339239 ifTrue: [ 339240 i = 1 339241 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] 339242 ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] 339243 ]. 339244 i=(allElementsAsString size) 339245 ifTrue:[ 339246 i = 1 339247 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 339248 ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 339249 ]. 339250 339251 339252 ].! ! 339253 339254!SortedCollectionTest methodsFor: 'tests - comma and delimiter'! 339255testAsCommaStringOne 339256 339257 "self assert: self oneItemCol asCommaString = '1'. 339258 self assert: self oneItemCol asCommaStringAnd = '1'." 339259 339260 self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). 339261 self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). 339262 ! ! 339263 339264!SortedCollectionTest methodsFor: 'tests - comma and delimiter'! 339265testAsStringOnDelimiterEmpty 339266 339267 | delim emptyStream | 339268 delim := ', '. 339269 emptyStream := ReadWriteStream on: ''. 339270 self empty asStringOn: emptyStream delimiter: delim. 339271 self assert: emptyStream contents = ''. 339272! ! 339273 339274!SortedCollectionTest methodsFor: 'tests - comma and delimiter'! 339275testAsStringOnDelimiterLastEmpty 339276 339277 | delim emptyStream | 339278 delim := ', '. 339279 emptyStream := ReadWriteStream on: ''. 339280 self empty asStringOn: emptyStream delimiter: delim last:'and'. 339281 self assert: emptyStream contents = ''. 339282! ! 339283 339284!SortedCollectionTest methodsFor: 'tests - comma and delimiter'! 339285testAsStringOnDelimiterLastMore 339286 339287 | delim multiItemStream result last allElementsAsString | 339288 339289 delim := ', '. 339290 last := 'and'. 339291 result:=''. 339292 multiItemStream := ReadWriteStream on:result. 339293 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 339294 339295 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 339296 1 to: allElementsAsString size do: 339297 [:i | 339298 i<(allElementsAsString size-1 ) 339299 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 339300 i=(allElementsAsString size-1) 339301 ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. 339302 i=(allElementsAsString size) 339303 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 339304 ]. 339305 339306! ! 339307 339308!SortedCollectionTest methodsFor: 'tests - comma and delimiter'! 339309testAsStringOnDelimiterLastOne 339310 339311 | delim oneItemStream result | 339312 339313 delim := ', '. 339314 result:=''. 339315 oneItemStream := ReadWriteStream on: result. 339316 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 339317 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 339318 339319 339320 ! ! 339321 339322!SortedCollectionTest methodsFor: 'tests - comma and delimiter'! 339323testAsStringOnDelimiterMore 339324 339325 | delim multiItemStream result index | 339326 "delim := ', '. 339327 multiItemStream := '' readWrite. 339328 self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. 339329 self assert: multiItemStream contents = '1, 2, 3'." 339330 339331 delim := ', '. 339332 result:=''. 339333 multiItemStream := ReadWriteStream on:result. 339334 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 339335 339336 index:=1. 339337 (result findBetweenSubStrs: ', ' )do: 339338 [:each | 339339 self assert: each= ((self nonEmpty at:index)asString). 339340 index:=index+1 339341 ].! ! 339342 339343!SortedCollectionTest methodsFor: 'tests - comma and delimiter'! 339344testAsStringOnDelimiterOne 339345 339346 | delim oneItemStream result | 339347 "delim := ', '. 339348 oneItemStream := '' readWrite. 339349 self oneItemCol asStringOn: oneItemStream delimiter: delim. 339350 self assert: oneItemStream contents = '1'." 339351 339352 delim := ', '. 339353 result:=''. 339354 oneItemStream := ReadWriteStream on: result. 339355 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 339356 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 339357 339358 339359 ! ! 339360 339361 339362!SortedCollectionTest methodsFor: 'tests - converting'! 339363assertNoDuplicates: aCollection whenConvertedTo: aClass 339364 | result | 339365 result := self collectionWithEqualElements asIdentitySet. 339366 self assert: (result class includesBehavior: IdentitySet). 339367 self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! 339368 339369!SortedCollectionTest methodsFor: 'tests - converting'! 339370assertNonDuplicatedContents: aCollection whenConvertedTo: aClass 339371 | result | 339372 result := aCollection perform: ('as' , aClass name) asSymbol. 339373 self assert: (result class includesBehavior: aClass). 339374 result do: 339375 [ :each | 339376 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 339377 ^ result! ! 339378 339379!SortedCollectionTest methodsFor: 'tests - converting'! 339380assertSameContents: aCollection whenConvertedTo: aClass 339381 | result | 339382 result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. 339383 self assert: result size = aCollection size! ! 339384 339385!SortedCollectionTest methodsFor: 'tests - converting'! 339386testAsArray 339387 "self debug: #testAsArray3" 339388 self 339389 assertSameContents: self collectionWithoutEqualElements 339390 whenConvertedTo: Array! ! 339391 339392!SortedCollectionTest methodsFor: 'tests - converting'! 339393testAsBag 339394 339395 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! 339396 339397!SortedCollectionTest methodsFor: 'tests - converting'! 339398testAsByteArray 339399| res | 339400self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 339401 self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . 339402 339403 res := true. 339404 self integerCollectionWithoutEqualElements 339405 detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] 339406 ifNone: [ res := false ]. 339407 self assert: res = false. 339408 339409 339410 self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! 339411 339412!SortedCollectionTest methodsFor: 'tests - converting'! 339413testAsIdentitySet 339414 "test with a collection without equal elements :" 339415 self 339416 assertSameContents: self collectionWithoutEqualElements 339417 whenConvertedTo: IdentitySet. 339418! ! 339419 339420!SortedCollectionTest methodsFor: 'tests - converting'! 339421testAsOrderedCollection 339422 339423 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! 339424 339425!SortedCollectionTest methodsFor: 'tests - converting'! 339426testAsSet 339427 | | 339428 "test with a collection without equal elements :" 339429 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. 339430 ! ! 339431 339432 339433!SortedCollectionTest methodsFor: 'tests - copy'! 339434testCopyEmptyWith 339435 "self debug: #testCopyWith" 339436 | res element | 339437 element := self elementToAdd. 339438 res := self empty copyWith: element. 339439 self assert: res size = (self empty size + 1). 339440 self assert: (res includes: (element value))! ! 339441 339442!SortedCollectionTest methodsFor: 'tests - copy'! 339443testCopyEmptyWithout 339444 "self debug: #testCopyEmptyWithout" 339445 | res | 339446 res := self empty copyWithout: self elementToAdd. 339447 self assert: res size = self empty size. 339448 self deny: (res includes: self elementToAdd)! ! 339449 339450!SortedCollectionTest methodsFor: 'tests - copy'! 339451testCopyEmptyWithoutAll 339452 "self debug: #testCopyEmptyWithoutAll" 339453 | res | 339454 res := self empty copyWithoutAll: self collectionWithElementsToRemove. 339455 self assert: res size = self empty size. 339456 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! 339457 339458!SortedCollectionTest methodsFor: 'tests - copy'! 339459testCopyNonEmptyWith 339460 "self debug: #testCopyNonEmptyWith" 339461 | res element | 339462 element := self elementToAdd . 339463 res := self nonEmpty copyWith: element. 339464 "here we do not test the size since for a non empty set we would get a problem. 339465 Then in addition copy is not about duplicate management. The element should 339466 be in at the end." 339467 self assert: (res includes: (element value)). 339468 self nonEmpty do: [ :each | res includes: each ]! ! 339469 339470!SortedCollectionTest methodsFor: 'tests - copy'! 339471testCopyNonEmptyWithout 339472 "self debug: #testCopyNonEmptyWithout" 339473 339474 | res anElementOfTheCollection | 339475 anElementOfTheCollection := self nonEmpty anyOne. 339476 res := (self nonEmpty copyWithout: anElementOfTheCollection). 339477 "here we do not test the size since for a non empty set we would get a problem. 339478 Then in addition copy is not about duplicate management. The element should 339479 be in at the end." 339480 self deny: (res includes: anElementOfTheCollection). 339481 self nonEmpty do: 339482 [:each | (each = anElementOfTheCollection) 339483 ifFalse: [self assert: (res includes: each)]]. 339484 339485! ! 339486 339487!SortedCollectionTest methodsFor: 'tests - copy'! 339488testCopyNonEmptyWithoutAll 339489 "self debug: #testCopyNonEmptyWithoutAll" 339490 | res | 339491 res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. 339492 "here we do not test the size since for a non empty set we would get a problem. 339493 Then in addition copy is not about duplicate management. The element should 339494 be in at the end." 339495 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. 339496 self nonEmpty do: 339497 [ :each | 339498 (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! 339499 339500!SortedCollectionTest methodsFor: 'tests - copy'! 339501testCopyNonEmptyWithoutAllNotIncluded 339502 "self debug: #testCopyNonEmptyWithoutAllNotIncluded" 339503 | res | 339504 res := self nonEmpty copyWithoutAll: self collectionNotIncluded. 339505 "here we do not test the size since for a non empty set we would get a problem. 339506 Then in addition copy is not about duplicate management. The element should 339507 be in at the end." 339508 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 339509 339510!SortedCollectionTest methodsFor: 'tests - copy'! 339511testCopyNonEmptyWithoutNotIncluded 339512 "self debug: #testCopyNonEmptyWithoutNotIncluded" 339513 | res | 339514 res := self nonEmpty copyWithout: self elementToAdd. 339515 "here we do not test the size since for a non empty set we would get a problem. 339516 Then in addition copy is not about duplicate management. The element should 339517 be in at the end." 339518 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 339519 339520 339521!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 339522testCopyAfter 339523 | result index collection | 339524 collection := self collectionWithoutEqualsElements . 339525 index:= self indexInForCollectionWithoutDuplicates . 339526 result := collection copyAfter: (collection at:index ). 339527 339528 "verifying content: " 339529 (1) to: result size do: 339530 [:i | 339531 self assert: (collection at:(i + index ))=(result at: (i))]. 339532 339533 "verify size: " 339534 self assert: result size = (collection size - index).! ! 339535 339536!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 339537testCopyAfterEmpty 339538 | result | 339539 result := self empty copyAfter: self collectionWithoutEqualsElements first. 339540 self assert: result isEmpty. 339541 ! ! 339542 339543!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 339544testCopyAfterLast 339545 | result index collection | 339546 collection := self collectionWithoutEqualsElements . 339547 index:= self indexInForCollectionWithoutDuplicates . 339548 result := collection copyAfterLast: (collection at:index ). 339549 339550 "verifying content: " 339551 (1) to: result size do: 339552 [:i | 339553 self assert: (collection at:(i + index ))=(result at: (i))]. 339554 339555 "verify size: " 339556 self assert: result size = (collection size - index).! ! 339557 339558!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 339559testCopyAfterLastEmpty 339560 | result | 339561 result := self empty copyAfterLast: self collectionWithoutEqualsElements first. 339562 self assert: result isEmpty.! ! 339563 339564!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 339565testCopyEmptyMethod 339566 | result | 339567 result := self collectionWithoutEqualsElements copyEmpty . 339568 self assert: result isEmpty . 339569 self assert: result class= self nonEmpty class.! ! 339570 339571!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 339572testCopyFromTo 339573 | result index collection | 339574 collection := self collectionWithoutEqualsElements . 339575 index :=self indexInForCollectionWithoutDuplicates . 339576 result := collection copyFrom: index to: collection size . 339577 339578 "verify content of 'result' : " 339579 1 to: result size do: 339580 [:i | 339581 self assert: (result at:i)=(collection at: (i + index - 1))]. 339582 339583 "verify size of 'result' : " 339584 self assert: result size = (collection size - index + 1).! ! 339585 339586!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 339587testCopyUpTo 339588 | result index collection | 339589 collection := self collectionWithoutEqualsElements . 339590 index:= self indexInForCollectionWithoutDuplicates . 339591 result := collection copyUpTo: (collection at:index). 339592 339593 "verify content of 'result' :" 339594 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 339595 339596 "verify size of 'result' :" 339597 self assert: result size = (index-1). 339598 ! ! 339599 339600!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 339601testCopyUpToEmpty 339602 | result | 339603 result := self empty copyUpTo: self collectionWithoutEqualsElements first. 339604 self assert: result isEmpty. 339605 ! ! 339606 339607!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 339608testCopyUpToLast 339609 | result index collection | 339610 collection := self collectionWithoutEqualsElements . 339611 index:= self indexInForCollectionWithoutDuplicates . 339612 result := collection copyUpToLast: (collection at:index). 339613 339614 "verify content of 'result' :" 339615 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 339616 339617 "verify size of 'result' :" 339618 self assert: result size = (index-1).! ! 339619 339620!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 339621testCopyUpToLastEmpty 339622 | result | 339623 result := self empty copyUpToLast: self collectionWithoutEqualsElements first. 339624 self assert: result isEmpty.! ! 339625 339626 339627!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 339628testCopyAfterLastWithDuplicate 339629 | result element collection | 339630 collection := self collectionWithSameAtEndAndBegining . 339631 element := collection first. 339632 339633 " collectionWithSameAtEndAndBegining first and last elements are equals. 339634 'copyAfter:' should copy after the last occurence of element :" 339635 result := collection copyAfterLast: (element ). 339636 339637 "verifying content: " 339638 self assert: result isEmpty. 339639 339640! ! 339641 339642!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 339643testCopyAfterWithDuplicate 339644 | result element collection | 339645 collection := self collectionWithSameAtEndAndBegining . 339646 element := collection last. 339647 339648 " collectionWithSameAtEndAndBegining first and last elements are equals. 339649 'copyAfter:' should copy after the first occurence :" 339650 result := collection copyAfter: (element ). 339651 339652 "verifying content: " 339653 1 to: result size do: 339654 [:i | 339655 self assert: (collection at:(i + 1 )) = (result at: (i)) 339656 ]. 339657 339658 "verify size: " 339659 self assert: result size = (collection size - 1).! ! 339660 339661!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 339662testCopyUpToLastWithDuplicate 339663 | result element collection | 339664 collection := self collectionWithSameAtEndAndBegining . 339665 element := collection first. 339666 339667 " collectionWithSameAtEndAndBegining first and last elements are equals. 339668 'copyUpToLast:' should copy until the last occurence :" 339669 result := collection copyUpToLast: (element ). 339670 339671 "verifying content: " 339672 1 to: result size do: 339673 [:i | 339674 self assert: (result at: i ) = ( collection at: i ) 339675 ]. 339676 339677 self assert: result size = (collection size - 1). 339678 339679! ! 339680 339681!SortedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 339682testCopyUpToWithDuplicate 339683 | result element collection | 339684 collection := self collectionWithSameAtEndAndBegining . 339685 element := collection last. 339686 339687 " collectionWithSameAtEndAndBegining first and last elements are equals. 339688 'copyUpTo:' should copy until the first occurence :" 339689 result := collection copyUpTo: (element ). 339690 339691 "verifying content: " 339692 self assert: result isEmpty. 339693 339694! ! 339695 339696 339697!SortedCollectionTest methodsFor: 'tests - copying same contents'! 339698testReverse 339699 | result | 339700 result := self nonEmpty reverse . 339701 339702 "verify content of 'result: '" 339703 1 to: result size do: 339704 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 339705 "verify size of 'result' :" 339706 self assert: result size=self nonEmpty size.! ! 339707 339708!SortedCollectionTest methodsFor: 'tests - copying same contents'! 339709testReversed 339710 | result | 339711 result := self nonEmpty reversed . 339712 339713 "verify content of 'result: '" 339714 1 to: result size do: 339715 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 339716 "verify size of 'result' :" 339717 self assert: result size=self nonEmpty size.! ! 339718 339719!SortedCollectionTest methodsFor: 'tests - copying same contents'! 339720testShallowCopy 339721 | result | 339722 result := self nonEmpty shallowCopy . 339723 339724 "verify content of 'result: '" 339725 1 to: self nonEmpty size do: 339726 [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. 339727 "verify size of 'result' :" 339728 self assert: result size=self nonEmpty size.! ! 339729 339730!SortedCollectionTest methodsFor: 'tests - copying same contents'! 339731testShallowCopyEmpty 339732 | result | 339733 result := self empty shallowCopy . 339734 self assert: result isEmpty .! ! 339735 339736!SortedCollectionTest methodsFor: 'tests - copying same contents'! 339737testSortBy 339738 " can only be used if the collection tested can include sortable elements :" 339739 | result tmp | 339740 self 339741 shouldnt: [ self collectionWithSortableElements ] 339742 raise: Error. 339743 self shouldnt: [self collectionWithSortableElements anyOne < self collectionWithSortableElements anyOne] raise: Error. 339744 result := self collectionWithSortableElements sortBy: [ :a :b | a < b ]. 339745 339746 "verify content of 'result' : " 339747 result do: 339748 [ :each | 339749 (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 339750 tmp := result first. 339751 result do: 339752 [ :each | 339753 self assert: each >= tmp. 339754 tmp := each ]. 339755 339756 "verify size of 'result' :" 339757 self assert: result size = self collectionWithSortableElements size! ! 339758 339759 339760!SortedCollectionTest methodsFor: 'tests - copying with or without'! 339761testCopyWithSequenceable 339762 339763 | result index element | 339764 index := self indexInNonEmpty . 339765 element := self nonEmpty at: index. 339766 result := self nonEmpty copyWith: (element ). 339767 339768 self assert: result size = (self nonEmpty size + 1). 339769 self assert: result last = element . 339770 339771 1 to: (result size - 1) do: 339772 [ :i | 339773 self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! 339774 339775!SortedCollectionTest methodsFor: 'tests - copying with or without'! 339776testCopyWithoutFirst 339777 339778 | result | 339779 result := self nonEmpty copyWithoutFirst. 339780 339781 self assert: result size = (self nonEmpty size - 1). 339782 339783 1 to: result size do: 339784 [:i | 339785 self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! 339786 339787 339788!SortedCollectionTest methodsFor: 'tests - copying with replacement for sorted'! 339789testCopyFromToWithForSorted 339790| collection result | 339791collection := self collectionOfSize5 . 339792 339793" testing that elements to be replaced are removed from the copy :" 339794result := collection copyReplaceFrom: 1 to: collection size with: self empty . 339795self assert: result isEmpty. 339796 339797" testing that replacement elements are all put into the copy :" 339798result := collection copyReplaceFrom: 1 to: collection size with: self replacementCollection . 339799 self replacementCollection do: 339800 [:each | 339801 self assert: (result occurrencesOf: each) = ( self replacementCollection occurrencesOf: each )]. 339802 339803self assert: result size = self replacementCollection size. 339804 339805! ! 339806 339807!SortedCollectionTest methodsFor: 'tests - copying with replacement for sorted'! 339808testCopyReplaceAllWithForSorted 339809 339810| collection result | 339811collection := self collectionOfSize5 . 339812 339813" testing that elements to be replaced are removed from the copy :" 339814result := collection copyReplaceAll: collection with: self empty . 339815self assert: result isEmpty. 339816 339817" testing that replacement elements are all put into the copy :" 339818result := collection copyReplaceAll: collection with: self replacementCollection . 339819 self replacementCollection do: 339820 [:each | 339821 self assert: (result occurrencesOf: each) = ( self replacementCollection occurrencesOf: each )]. 339822 339823self assert: result size = self replacementCollection size. 339824 339825! ! 339826 339827 339828!SortedCollectionTest methodsFor: 'tests - element accessing'! 339829testAfter 339830 "self debug: #testAfter" 339831 self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). 339832 self 339833 should: 339834 [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] 339835 raise: Error. 339836 self 339837 should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] 339838 raise: Error! ! 339839 339840!SortedCollectionTest methodsFor: 'tests - element accessing'! 339841testAfterIfAbsent 339842 "self debug: #testAfterIfAbsent" 339843 self assert: (self moreThan4Elements 339844 after: (self moreThan4Elements at: 1) 339845 ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). 339846 self assert: (self moreThan4Elements 339847 after: (self moreThan4Elements at: self moreThan4Elements size) 339848 ifAbsent: [ 33 ]) == 33. 339849 self assert: (self moreThan4Elements 339850 after: self elementNotInForElementAccessing 339851 ifAbsent: [ 33 ]) = 33! ! 339852 339853!SortedCollectionTest methodsFor: 'tests - element accessing'! 339854testAt 339855 "self debug: #testAt" 339856 " 339857 self assert: (self accessCollection at: 1) = 1. 339858 self assert: (self accessCollection at: 2) = 2. 339859 " 339860 | index | 339861 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 339862 self assert: (self moreThan4Elements at: index) = self elementInForElementAccessing! ! 339863 339864!SortedCollectionTest methodsFor: 'tests - element accessing'! 339865testAtIfAbsent 339866 "self debug: #testAt" 339867 | absent | 339868 absent := false. 339869 self moreThan4Elements 339870 at: self moreThan4Elements size + 1 339871 ifAbsent: [ absent := true ]. 339872 self assert: absent = true. 339873 absent := false. 339874 self moreThan4Elements 339875 at: self moreThan4Elements size 339876 ifAbsent: [ absent := true ]. 339877 self assert: absent = false! ! 339878 339879!SortedCollectionTest methodsFor: 'tests - element accessing'! 339880testAtLast 339881 "self debug: #testAtLast" 339882 | index | 339883 self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. 339884 "tmp:=1. 339885 self do: 339886 [:each | 339887 each =self elementInForIndexAccessing 339888 ifTrue:[index:=tmp]. 339889 tmp:=tmp+1]." 339890 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 339891 self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! 339892 339893!SortedCollectionTest methodsFor: 'tests - element accessing'! 339894testAtLastError 339895 "self debug: #testAtLast" 339896 self 339897 should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] 339898 raise: Error! ! 339899 339900!SortedCollectionTest methodsFor: 'tests - element accessing'! 339901testAtLastIfAbsent 339902 "self debug: #testAtLastIfAbsent" 339903 self assert: (self moreThan4Elements 339904 atLast: 1 339905 ifAbsent: [ nil ]) = self moreThan4Elements last. 339906 self assert: (self moreThan4Elements 339907 atLast: self moreThan4Elements size + 1 339908 ifAbsent: [ 222 ]) = 222! ! 339909 339910!SortedCollectionTest methodsFor: 'tests - element accessing'! 339911testAtOutOfBounds 339912 "self debug: #testAtOutOfBounds" 339913 self 339914 should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] 339915 raise: Error. 339916 self 339917 should: [ self moreThan4Elements at: -1 ] 339918 raise: Error! ! 339919 339920!SortedCollectionTest methodsFor: 'tests - element accessing'! 339921testAtPin 339922 "self debug: #testAtPin" 339923 self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. 339924 self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. 339925 self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! 339926 339927!SortedCollectionTest methodsFor: 'tests - element accessing'! 339928testAtRandom 339929 | result | 339930 result := self nonEmpty atRandom . 339931 self assert: (self nonEmpty includes: result).! ! 339932 339933!SortedCollectionTest methodsFor: 'tests - element accessing'! 339934testAtWrap 339935 "self debug: #testAt" 339936 " 339937 self assert: (self accessCollection at: 1) = 1. 339938 self assert: (self accessCollection at: 2) = 2. 339939 " 339940 | index | 339941 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 339942 self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. 339943 self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. 339944 self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. 339945 self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! 339946 339947!SortedCollectionTest methodsFor: 'tests - element accessing'! 339948testBefore 339949 "self debug: #testBefore" 339950 self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). 339951 self 339952 should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] 339953 raise: Error. 339954 self 339955 should: [ self moreThan4Elements before: 66 ] 339956 raise: Error! ! 339957 339958!SortedCollectionTest methodsFor: 'tests - element accessing'! 339959testBeforeIfAbsent 339960 "self debug: #testBefore" 339961 self assert: (self moreThan4Elements 339962 before: (self moreThan4Elements at: 1) 339963 ifAbsent: [ 99 ]) = 99. 339964 self assert: (self moreThan4Elements 339965 before: (self moreThan4Elements at: 2) 339966 ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! 339967 339968!SortedCollectionTest methodsFor: 'tests - element accessing'! 339969testFirstSecondThird 339970 "self debug: #testFirstSecondThird" 339971 self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). 339972 self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). 339973 self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). 339974 self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! 339975 339976!SortedCollectionTest methodsFor: 'tests - element accessing'! 339977testLast 339978 "self debug: #testLast" 339979 self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! 339980 339981!SortedCollectionTest methodsFor: 'tests - element accessing'! 339982testMiddle 339983 "self debug: #testMiddle" 339984 self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! 339985 339986 339987!SortedCollectionTest methodsFor: 'tests - empty'! 339988testIfEmpty 339989 339990 self nonEmpty ifEmpty: [ self assert: false] . 339991 self empty ifEmpty: [ self assert: true] . 339992 339993 339994 ! ! 339995 339996!SortedCollectionTest methodsFor: 'tests - empty'! 339997testIfEmptyifNotEmpty 339998 339999 self assert: (self empty ifEmpty: [true] ifNotEmpty: [false]). 340000 self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [true]). 340001 ! ! 340002 340003!SortedCollectionTest methodsFor: 'tests - empty'! 340004testIfEmptyifNotEmptyDo 340005 "self debug #testIfEmptyifNotEmptyDo" 340006 340007 self assert: (self empty ifEmpty: [true] ifNotEmptyDo: [:s | false]). 340008 self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | true]). 340009 self assert: (self nonEmpty 340010 ifEmpty: [false] 340011 ifNotEmptyDo: [:s | s]) == self nonEmpty.! ! 340012 340013!SortedCollectionTest methodsFor: 'tests - empty'! 340014testIfNotEmpty 340015 340016 self empty ifNotEmpty: [self assert: false]. 340017 self nonEmpty ifNotEmpty: [self assert: true]. 340018 self assert: (self nonEmpty ifNotEmpty: [:s | s ]) = self nonEmpty 340019 ! ! 340020 340021!SortedCollectionTest methodsFor: 'tests - empty'! 340022testIfNotEmptyDo 340023 340024 self empty ifNotEmptyDo: [:s | self assert: false]. 340025 self assert: (self nonEmpty ifNotEmptyDo: [:s | s]) == self nonEmpty 340026! ! 340027 340028!SortedCollectionTest methodsFor: 'tests - empty'! 340029testIfNotEmptyDoifNotEmpty 340030 340031 self assert: (self empty ifNotEmptyDo: [:s | false] ifEmpty: [true]). 340032 self assert: (self nonEmpty 340033 ifNotEmptyDo: [:s | s] 340034 ifEmpty: [false]) == self nonEmpty! ! 340035 340036!SortedCollectionTest methodsFor: 'tests - empty'! 340037testIfNotEmptyifEmpty 340038 340039 self assert: (self empty ifNotEmpty: [false] ifEmpty: [true]). 340040 self assert: (self nonEmpty ifNotEmpty: [true] ifEmpty: [false]). 340041 ! ! 340042 340043!SortedCollectionTest methodsFor: 'tests - empty'! 340044testIsEmpty 340045 340046 self assert: (self empty isEmpty). 340047 self deny: (self nonEmpty isEmpty).! ! 340048 340049!SortedCollectionTest methodsFor: 'tests - empty'! 340050testIsEmptyOrNil 340051 340052 self assert: (self empty isEmptyOrNil). 340053 self deny: (self nonEmpty isEmptyOrNil).! ! 340054 340055!SortedCollectionTest methodsFor: 'tests - empty'! 340056testNotEmpty 340057 340058 self assert: (self nonEmpty notEmpty). 340059 self deny: (self empty notEmpty).! ! 340060 340061 340062!SortedCollectionTest methodsFor: 'tests - equality'! 340063testEqualSignForSequenceableCollections 340064 "self debug: #testEqualSign" 340065 340066 self deny: (self nonEmpty = self nonEmpty asSet). 340067 self deny: (self nonEmpty reversed = self nonEmpty). 340068 self deny: (self nonEmpty = self nonEmpty reversed).! ! 340069 340070!SortedCollectionTest methodsFor: 'tests - equality'! 340071testHasEqualElements 340072 "self debug: #testHasEqualElements" 340073 340074 self deny: (self empty hasEqualElements: self nonEmpty). 340075 self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). 340076 self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). 340077 self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! 340078 340079!SortedCollectionTest methodsFor: 'tests - equality'! 340080testHasEqualElementsIsTrueForNonIdenticalButEqualCollections 340081 "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" 340082 340083 self assert: (self empty hasEqualElements: self empty copy). 340084 self assert: (self empty copy hasEqualElements: self empty). 340085 self assert: (self empty copy hasEqualElements: self empty copy). 340086 340087 self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). 340088 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). 340089 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! 340090 340091!SortedCollectionTest methodsFor: 'tests - equality'! 340092testHasEqualElementsOfIdenticalCollectionObjects 340093 "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" 340094 340095 self assert: (self empty hasEqualElements: self empty). 340096 self assert: (self nonEmpty hasEqualElements: self nonEmpty). 340097 ! ! 340098 340099 340100!SortedCollectionTest methodsFor: 'tests - fixture'! 340101test0CopyTest 340102 self shouldnt: [ self empty ]raise: Error. 340103 self assert: self empty size = 0. 340104 self shouldnt: [ self nonEmpty ]raise: Error. 340105 self assert: (self nonEmpty size = 0) not. 340106 self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. 340107 self assert: (self collectionWithElementsToRemove size = 0) not. 340108 self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. 340109 340110 self shouldnt: [ self elementToAdd ]raise: Error. 340111 self deny: (self nonEmpty includes: self elementToAdd ). 340112 self shouldnt: [ self collectionNotIncluded ]raise: Error. 340113 self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! 340114 340115!SortedCollectionTest methodsFor: 'tests - fixture'! 340116test0FixtureAsSetForIdentityMultiplinessTest 340117 340118 "a collection (of elements for which copy is not identical ) without equal elements:" 340119 | element res | 340120 self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ]raise: Error. 340121 element := self elementsCopyNonIdenticalWithoutEqualElements anyOne. 340122 self deny: element copy == element . 340123 340124 res := true. 340125 self elementsCopyNonIdenticalWithoutEqualElements 340126 detect: 340127 [ :each | 340128 (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] 340129 ifNone: [ res := false ]. 340130 self assert: res = false 340131 340132 ! ! 340133 340134!SortedCollectionTest methodsFor: 'tests - fixture'! 340135test0FixtureAsStringCommaAndDelimiterTest 340136 340137 self shouldnt: [self nonEmpty] raise:Error . 340138 self deny: self nonEmpty isEmpty. 340139 340140 self shouldnt: [self empty] raise:Error . 340141 self assert: self empty isEmpty. 340142 340143 self shouldnt: [self nonEmpty1Element ] raise:Error . 340144 self assert: self nonEmpty1Element size=1.! ! 340145 340146!SortedCollectionTest methodsFor: 'tests - fixture'! 340147test0FixtureBeginsEndsWithTest 340148 340149 self shouldnt: [self nonEmpty ] raise: Error. 340150 self deny: self nonEmpty isEmpty. 340151 self assert: self nonEmpty size>1. 340152 340153 self shouldnt: [self empty ] raise: Error. 340154 self assert: self empty isEmpty.! ! 340155 340156!SortedCollectionTest methodsFor: 'tests - fixture'! 340157test0FixtureConverAsSortedTest 340158 340159 self shouldnt: [self collectionWithSortableElements ] raise: Error. 340160 self deny: self collectionWithSortableElements isEmpty .! ! 340161 340162!SortedCollectionTest methodsFor: 'tests - fixture'! 340163test0FixtureCopyPartOfForMultipliness 340164 340165self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. 340166 340167self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 340168 340169self assert: self collectionWithSameAtEndAndBegining size > 1. 340170 3401711 to: self collectionWithSameAtEndAndBegining size do: 340172 [:i | 340173 (i > 1 ) & (i < self collectionWithSameAtEndAndBegining size) 340174 ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at:i) = (self collectionWithSameAtEndAndBegining first)]. 340175 ]! ! 340176 340177!SortedCollectionTest methodsFor: 'tests - fixture'! 340178test0FixtureCopyPartOfSequenceableTest 340179 340180 self shouldnt: [self collectionWithoutEqualsElements ] raise: Error. 340181 self collectionWithoutEqualsElements do: 340182 [:each | self assert: (self collectionWithoutEqualsElements occurrencesOf: each)=1]. 340183 340184 self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. 340185 self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualsElements size. 340186 340187 self shouldnt: [self empty] raise: Error. 340188 self assert: self empty isEmpty .! ! 340189 340190!SortedCollectionTest methodsFor: 'tests - fixture'! 340191test0FixtureCopySameContentsTest 340192 340193 self shouldnt: [self nonEmpty ] raise: Error. 340194 self deny: self nonEmpty isEmpty. 340195 340196 self shouldnt: [self empty ] raise: Error. 340197 self assert: self empty isEmpty. 340198 340199! ! 340200 340201!SortedCollectionTest methodsFor: 'tests - fixture'! 340202test0FixtureCopyWithOrWithoutSpecificElementsTest 340203 340204 self shouldnt: [self nonEmpty ] raise: Error. 340205 self deny: self nonEmpty isEmpty . 340206 340207 self shouldnt: [self indexInNonEmpty ] raise: Error. 340208 self assert: self indexInNonEmpty > 0. 340209 self assert: self indexInNonEmpty <= self nonEmpty size.! ! 340210 340211!SortedCollectionTest methodsFor: 'tests - fixture'! 340212test0FixtureCopyWithReplacementForSorted 340213 340214self shouldnt: [self collectionOfSize5 ] raise: Error. 340215self assert: self collectionOfSize5 size = 5. 340216 340217self shouldnt: [self replacementCollection ] raise: Error. 340218self deny: self replacementCollection isEmpty. 340219 340220self shouldnt: [self empty] raise: Error. 340221self assert: self empty isEmpty.! ! 340222 340223!SortedCollectionTest methodsFor: 'tests - fixture'! 340224test0FixtureCreationWithTest 340225 340226self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. 340227self assert: self collectionMoreThan5Elements size >= 5.! ! 340228 340229!SortedCollectionTest methodsFor: 'tests - fixture'! 340230test0FixtureEmptyTest 340231 340232self shouldnt: [ self nonEmpty ] raise: Error. 340233self deny: self nonEmpty isEmpty. 340234 340235self shouldnt: [ self empty ] raise: Error. 340236self assert: self empty isEmpty.! ! 340237 340238!SortedCollectionTest methodsFor: 'tests - fixture'! 340239test0FixtureIncludeTest 340240 | elementIn | 340241 self shouldnt: [ self nonEmpty ]raise: Error. 340242 self deny: self nonEmpty isEmpty. 340243 340244 self shouldnt: [ self elementNotIn ]raise: Error. 340245 340246 elementIn := true. 340247 self nonEmpty detect: 340248 [ :each | each = self elementNotIn ] 340249 ifNone: [ elementIn := false ]. 340250 self assert: elementIn = false. 340251 340252 self shouldnt: [ self anotherElementNotIn ]raise: Error. 340253 340254 elementIn := true. 340255 self nonEmpty detect: 340256 [ :each | each = self anotherElementNotIn ] 340257 ifNone: [ elementIn := false ]. 340258 self assert: elementIn = false. 340259 340260 self shouldnt: [ self empty ] raise: Error. 340261 self assert: self empty isEmpty. 340262 340263! ! 340264 340265!SortedCollectionTest methodsFor: 'tests - fixture'! 340266test0FixtureIncludeWithIdentityTest 340267 | element | 340268 self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. 340269 element := self collectionWithCopyNonIdentical anyOne. 340270 self deny: element == element copy. 340271! ! 340272 340273!SortedCollectionTest methodsFor: 'tests - fixture'! 340274test0FixtureIndexAccessFotMultipliness 340275 self 340276 shouldnt: [ self collectionWithSameAtEndAndBegining ] 340277 raise: Error. 340278 self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 340279 self assert: self collectionWithSameAtEndAndBegining size > 1. 340280 1 to: self collectionWithSameAtEndAndBegining size 340281 do: 340282 [ :i | 340283 i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: 340284 [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! 340285 340286!SortedCollectionTest methodsFor: 'tests - fixture'! 340287test0FixtureIterateSequencedReadableTest 340288 340289 | res | 340290 340291 self shouldnt: self nonEmptyMoreThan1Element raise: Error. 340292 self assert: self nonEmptyMoreThan1Element size > 1. 340293 340294 340295 self shouldnt: self empty raise: Error. 340296 self assert: self empty isEmpty . 340297 340298 res := true. 340299 self nonEmptyMoreThan1Element 340300 detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] 340301 ifNone: [ res := false ]. 340302 self assert: res = false.! ! 340303 340304!SortedCollectionTest methodsFor: 'tests - fixture'! 340305test0FixtureOccurrencesForMultiplinessTest 340306 | cpt element collection | 340307 self shouldnt: [self collectionWithEqualElements ]raise: Error. 340308self shouldnt: [self collectionWithEqualElements ]raise: Error. 340309 340310self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 340311element := self elementTwiceInForOccurrences . 340312collection := self collectionWithEqualElements . 340313 340314cpt := 0 . 340315" testing with identity check ( == ) so that identy collections can use this trait : " 340316self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. 340317self assert: cpt = 2.! ! 340318 340319!SortedCollectionTest methodsFor: 'tests - fixture'! 340320test0FixtureOccurrencesTest 340321 | tmp | 340322 self shouldnt: [self empty ]raise: Error. 340323 self assert: self empty isEmpty. 340324 340325 self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. 340326 self deny: self collectionWithoutEqualElements isEmpty. 340327 340328 tmp := OrderedCollection new. 340329 self collectionWithoutEqualElements do: [ 340330 :each | 340331 self deny: (tmp includes: each). 340332 tmp add: each. 340333 ]. 340334 340335 340336 self shouldnt: [ self elementNotInForOccurrences ] raise: Error. 340337 self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! 340338 340339!SortedCollectionTest methodsFor: 'tests - fixture'! 340340test0FixturePrintTest 340341 340342 self shouldnt: [self nonEmpty ] raise: Error.! ! 340343 340344!SortedCollectionTest methodsFor: 'tests - fixture'! 340345test0FixtureRemoveByIndexTest 340346 340347self shouldnt: [self collectionWith5Elements ] raise: Error. 340348self assert: self collectionWith5Elements size = 5.! ! 340349 340350!SortedCollectionTest methodsFor: 'tests - fixture'! 340351test0FixtureRequirementsOfTAddTest 340352 self 340353 shouldnt: [ self collectionWithElement ] 340354 raise: Exception. 340355 self 340356 shouldnt: [ self otherCollection ] 340357 raise: Exception. 340358 self 340359 shouldnt: [ self element ] 340360 raise: Exception. 340361 self assert: (self collectionWithElement includes: self element). 340362 self deny: (self otherCollection includes: self element)! ! 340363 340364!SortedCollectionTest methodsFor: 'tests - fixture'! 340365test0FixtureSequencedElementAccessTest 340366 self 340367 shouldnt: [ self moreThan4Elements ] 340368 raise: Error. 340369 self assert: self moreThan4Elements size >= 4. 340370 self 340371 shouldnt: [ self subCollectionNotIn ] 340372 raise: Error. 340373 self subCollectionNotIn 340374 detect: [ :each | (self moreThan4Elements includes: each) not ] 340375 ifNone: [ self assert: false ]. 340376 self 340377 shouldnt: [ self elementNotInForElementAccessing ] 340378 raise: Error. 340379 self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). 340380 self 340381 shouldnt: [ self elementInForElementAccessing ] 340382 raise: Error. 340383 self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! 340384 340385!SortedCollectionTest methodsFor: 'tests - fixture'! 340386test0FixtureSetAritmeticTest 340387 self 340388 shouldnt: [ self collection ] 340389 raise: Error. 340390 self deny: self collection isEmpty. 340391 self 340392 shouldnt: [ self nonEmpty ] 340393 raise: Error. 340394 self deny: self nonEmpty isEmpty. 340395 self 340396 shouldnt: [ self anotherElementOrAssociationNotIn ] 340397 raise: Error. 340398 self collection isDictionary 340399 ifTrue: 340400 [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] 340401 ifFalse: 340402 [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. 340403 self 340404 shouldnt: [ self collectionClass ] 340405 raise: Error! ! 340406 340407!SortedCollectionTest methodsFor: 'tests - fixture'! 340408test0FixtureSubcollectionAccessTest 340409 self 340410 shouldnt: [ self moreThan3Elements ] 340411 raise: Error. 340412 self assert: self moreThan3Elements size > 2! ! 340413 340414!SortedCollectionTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/28/2009 14:11'! 340415test0FixtureTConvertAsSetForMultiplinessTest 340416 "a collection ofFloat with equal elements:" 340417 | res | 340418 self 340419 shouldnt: [ self withEqualElements ] 340420 raise: Error. 340421 self 340422 shouldnt: 340423 [ self withEqualElements do: [ :each | self assert: each class = Float ] ] 340424 raise: Error. 340425 res := true. 340426 self withEqualElements 340427 detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] 340428 ifNone: [ res := false ]. 340429 self assert: res = true. 340430 340431 "a collection of Float without equal elements:" 340432 self 340433 shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ] 340434 raise: Error. 340435 self 340436 shouldnt: 340437 [ self elementsCopyNonIdenticalWithoutEqualElements do: [ :each | self assert: each class = Float ] ] 340438 raise: Error. 340439 res := true. 340440 self elementsCopyNonIdenticalWithoutEqualElements 340441 detect: 340442 [ :each | 340443 (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] 340444 ifNone: [ res := false ]. 340445 self assert: res = false! ! 340446 340447!SortedCollectionTest methodsFor: 'tests - fixture'! 340448test0FixtureTConvertTest 340449 "a collection of number without equal elements:" 340450 | res | 340451 self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. 340452 340453 res := true. 340454 self collectionWithoutEqualElements 340455 detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] 340456 ifNone: [ res := false ]. 340457 self assert: res = false. 340458 340459 340460! ! 340461 340462!SortedCollectionTest methodsFor: 'tests - fixture'! 340463test0FixtureTRemoveTest 340464 | duplicate | 340465 self shouldnt: [ self empty ]raise: Error. 340466 self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. 340467 self deny: self nonEmptyWithoutEqualElements isEmpty. 340468 duplicate := true. 340469 self nonEmptyWithoutEqualElements detect: 340470 [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] 340471 ifNone: [duplicate := false]. 340472 self assert: duplicate = false. 340473 340474 340475 self shouldnt: [ self elementNotIn ] raise: Error. 340476 self assert: self empty isEmpty. 340477 self deny: self nonEmptyWithoutEqualElements isEmpty. 340478 self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! 340479 340480!SortedCollectionTest methodsFor: 'tests - fixture'! 340481test0TSequencedStructuralEqualityTest 340482 340483 self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! 340484 340485!SortedCollectionTest methodsFor: 'tests - fixture'! 340486test0TStructuralEqualityTest 340487 self shouldnt: [self empty] raise: Error. 340488 self shouldnt: [self nonEmpty] raise: Error. 340489 self assert: self empty isEmpty. 340490 self deny: self nonEmpty isEmpty.! ! 340491 340492 340493!SortedCollectionTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! 340494testIdentityIncludes 340495 " test the comportement in presence of elements 'includes' but not 'identityIncludes' " 340496 " can not be used by collections that can't include elements for wich copy doesn't return another instance " 340497 | collection element | 340498 self 340499 shouldnt: [ self collectionWithCopyNonIdentical ] 340500 raise: Error. 340501 collection := self collectionWithCopyNonIdentical. 340502 element := collection anyOne copy. 340503 "self assert: (collection includes: element)." 340504 self deny: (collection identityIncludes: element)! ! 340505 340506!SortedCollectionTest methodsFor: 'tests - includes'! 340507testIdentityIncludesNonSpecificComportement 340508 " test the same comportement than 'includes: ' " 340509 | collection | 340510 collection := self nonEmpty . 340511 340512 self deny: (collection identityIncludes: self elementNotIn ). 340513 self assert:(collection identityIncludes: collection anyOne) 340514! ! 340515 340516!SortedCollectionTest methodsFor: 'tests - includes'! 340517testIncludesAllOfAllThere 340518 "self debug: #testIncludesAllOfAllThere'" 340519 self assert: (self empty includesAllOf: self empty). 340520 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 340521 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 340522 340523!SortedCollectionTest methodsFor: 'tests - includes'! 340524testIncludesAllOfNoneThere 340525 "self debug: #testIncludesAllOfNoneThere'" 340526 self deny: (self empty includesAllOf: self nonEmpty ). 340527 self deny: (self nonEmpty includesAllOf: { self elementNotIn. self anotherElementNotIn })! ! 340528 340529!SortedCollectionTest methodsFor: 'tests - includes'! 340530testIncludesAnyOfAllThere 340531 "self debug: #testIncludesAnyOfAllThere'" 340532 self deny: (self nonEmpty includesAnyOf: self empty). 340533 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 340534 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 340535 340536!SortedCollectionTest methodsFor: 'tests - includes'! 340537testIncludesAnyOfNoneThere 340538 "self debug: #testIncludesAnyOfNoneThere'" 340539 self deny: (self nonEmpty includesAnyOf: self empty). 340540 self deny: (self nonEmpty includesAnyOf: { self elementNotIn. self anotherElementNotIn })! ! 340541 340542!SortedCollectionTest methodsFor: 'tests - includes'! 340543testIncludesElementIsNotThere 340544 "self debug: #testIncludesElementIsNotThere" 340545 340546 self deny: (self nonEmpty includes: self elementNotIn). 340547 self assert: (self nonEmpty includes: self nonEmpty anyOne). 340548 self deny: (self empty includes: self elementNotIn)! ! 340549 340550!SortedCollectionTest methodsFor: 'tests - includes'! 340551testIncludesElementIsThere 340552 "self debug: #testIncludesElementIsThere" 340553 340554 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 340555 340556 340557!SortedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 340558testIdentityIndexOf 340559 "self debug: #testIdentityIndexOf" 340560 | collection element | 340561 collection := self collectionMoreThan1NoDuplicates. 340562 element := collection first. 340563 self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! 340564 340565!SortedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 340566testIdentityIndexOfIAbsent 340567 | collection element | 340568 collection := self collectionMoreThan1NoDuplicates. 340569 element := collection first. 340570 self assert: (collection 340571 identityIndexOf: element 340572 ifAbsent: [ 0 ]) = 1. 340573 self assert: (collection 340574 identityIndexOf: self elementNotInForIndexAccessing 340575 ifAbsent: [ 55 ]) = 55! ! 340576 340577!SortedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 340578testIndexOf 340579 "self debug: #testIndexOf" 340580 | tmp index collection | 340581 collection := self collectionMoreThan1NoDuplicates. 340582 tmp := collection size. 340583 collection reverseDo: 340584 [ :each | 340585 each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. 340586 tmp := tmp - 1 ]. 340587 self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! 340588 340589!SortedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 340590testIndexOfIfAbsent 340591 "self debug: #testIndexOfIfAbsent" 340592 | collection | 340593 collection := self collectionMoreThan1NoDuplicates. 340594 self assert: (collection 340595 indexOf: collection first 340596 ifAbsent: [ 33 ]) = 1. 340597 self assert: (collection 340598 indexOf: self elementNotInForIndexAccessing 340599 ifAbsent: [ 33 ]) = 33! ! 340600 340601!SortedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 340602testIndexOfStartingAt 340603 "self debug: #testLastIndexOf" 340604 | element collection | 340605 collection := self collectionMoreThan1NoDuplicates. 340606 element := collection first. 340607 self assert: (collection 340608 indexOf: element 340609 startingAt: 2 340610 ifAbsent: [ 99 ]) = 99. 340611 self assert: (collection 340612 indexOf: element 340613 startingAt: 1 340614 ifAbsent: [ 99 ]) = 1. 340615 self assert: (collection 340616 indexOf: self elementNotInForIndexAccessing 340617 startingAt: 1 340618 ifAbsent: [ 99 ]) = 99! ! 340619 340620!SortedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 340621testIndexOfSubCollectionStartingAt 340622 "self debug: #testIndexOfIfAbsent" 340623 | subcollection index collection | 340624 collection := self collectionMoreThan1NoDuplicates. 340625 subcollection := self collectionMoreThan1NoDuplicates. 340626 index := collection 340627 indexOfSubCollection: subcollection 340628 startingAt: 1. 340629 self assert: index = 1. 340630 index := collection 340631 indexOfSubCollection: subcollection 340632 startingAt: 2. 340633 self assert: index = 0! ! 340634 340635!SortedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 340636testIndexOfSubCollectionStartingAtIfAbsent 340637 "self debug: #testIndexOfIfAbsent" 340638 | index absent subcollection collection | 340639 collection := self collectionMoreThan1NoDuplicates. 340640 subcollection := self collectionMoreThan1NoDuplicates. 340641 absent := false. 340642 index := collection 340643 indexOfSubCollection: subcollection 340644 startingAt: 1 340645 ifAbsent: [ absent := true ]. 340646 self assert: absent = false. 340647 absent := false. 340648 index := collection 340649 indexOfSubCollection: subcollection 340650 startingAt: 2 340651 ifAbsent: [ absent := true ]. 340652 self assert: absent = true! ! 340653 340654!SortedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 340655testLastIndexOf 340656 "self debug: #testLastIndexOf" 340657 | element collection | 340658 collection := self collectionMoreThan1NoDuplicates. 340659 element := collection first. 340660 self assert: (collection lastIndexOf: element) = 1. 340661 self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! 340662 340663!SortedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 340664testLastIndexOfIfAbsent 340665 "self debug: #testIndexOfIfAbsent" 340666 | element collection | 340667 collection := self collectionMoreThan1NoDuplicates. 340668 element := collection first. 340669 self assert: (collection 340670 lastIndexOf: element 340671 ifAbsent: [ 99 ]) = 1. 340672 self assert: (collection 340673 lastIndexOf: self elementNotInForIndexAccessing 340674 ifAbsent: [ 99 ]) = 99! ! 340675 340676!SortedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 340677testLastIndexOfStartingAt 340678 "self debug: #testLastIndexOf" 340679 | element collection | 340680 collection := self collectionMoreThan1NoDuplicates. 340681 element := collection last. 340682 self assert: (collection 340683 lastIndexOf: element 340684 startingAt: collection size 340685 ifAbsent: [ 99 ]) = collection size. 340686 self assert: (collection 340687 lastIndexOf: element 340688 startingAt: collection size - 1 340689 ifAbsent: [ 99 ]) = 99. 340690 self assert: (collection 340691 lastIndexOf: self elementNotInForIndexAccessing 340692 startingAt: collection size 340693 ifAbsent: [ 99 ]) = 99! ! 340694 340695 340696!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 340697testIdentityIndexOfDuplicate 340698 "self debug: #testIdentityIndexOf" 340699 | collection element | 340700 340701 "testing fixture here as this method may not be used by some collections testClass" 340702 self shouldnt: [self collectionWithNonIdentitySameAtEndAndBegining ] raise: Error. 340703 collection := self collectionWithNonIdentitySameAtEndAndBegining . 340704 self assert: collection first = collection last. 340705 self deny: collection first == collection last. 340706 1 to: collection size do: 340707 [ :i | 340708 i > 1 & (i < collection size) ifTrue: 340709 [ self deny: (collection at: i) = collection first ] ]. 340710 340711 340712 element := collection last. 340713 " floatCollectionWithSameAtEndAndBegining first and last elements are equals but are not the same object" 340714 self assert: (collection identityIndexOf: element) = collection size! ! 340715 340716!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 340717testIdentityIndexOfIAbsentDuplicate 340718 "self debug: #testIdentityIndexOfIfAbsent" 340719 | collection element elementCopy | 340720 collection := self collectionWithNonIdentitySameAtEndAndBegining . 340721 element := collection last. 340722 elementCopy := element copy. 340723 self deny: element == elementCopy . 340724 self assert: (collection 340725 identityIndexOf: element 340726 ifAbsent: [ 0 ]) = collection size. 340727 self assert: (collection 340728 identityIndexOf: elementCopy 340729 ifAbsent: [ 55 ]) = 55! ! 340730 340731!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 340732testIndexOfDuplicate 340733 "self debug: #testIndexOf" 340734 | collection element | 340735 collection := self collectionWithSameAtEndAndBegining. 340736 element := collection last. 340737 340738 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 340739 'indexOf: should return the position of the first occurrence :'" 340740 self assert: (collection indexOf: element) = 1! ! 340741 340742!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 340743testIndexOfIfAbsentDuplicate 340744 "self debug: #testIndexOfIfAbsent" 340745 | collection element | 340746 collection := self collectionWithSameAtEndAndBegining. 340747 element := collection last. 340748 340749 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 340750 'indexOf:ifAbsent: should return the position of the first occurrence :'" 340751 self assert: (collection 340752 indexOf: element 340753 ifAbsent: [ 55 ]) = 1! ! 340754 340755!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 340756testIndexOfStartingAtDuplicate 340757 "self debug: #testLastIndexOf" 340758 | collection element | 340759 collection := self collectionWithSameAtEndAndBegining. 340760 element := collection last. 340761 340762 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 340763 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" 340764 self assert: (collection 340765 indexOf: element 340766 startingAt: 1 340767 ifAbsent: [ 55 ]) = 1. 340768 self assert: (collection 340769 indexOf: element 340770 startingAt: 2 340771 ifAbsent: [ 55 ]) = collection size! ! 340772 340773!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 340774testLastIndexOfDuplicate 340775 "self debug: #testLastIndexOf" 340776 | collection element | 340777 collection := self collectionWithSameAtEndAndBegining. 340778 element := collection first. 340779 340780 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 340781 'lastIndexOf: should return the position of the last occurrence :'" 340782 self assert: (collection lastIndexOf: element) = collection size! ! 340783 340784!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 340785testLastIndexOfIfAbsentDuplicate 340786 "self debug: #testIndexOfIfAbsent" 340787 "self debug: #testLastIndexOf" 340788 | collection element | 340789 collection := self collectionWithSameAtEndAndBegining. 340790 element := collection first. 340791 340792 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 340793 'lastIndexOf: should return the position of the last occurrence :'" 340794 self assert: (collection 340795 lastIndexOf: element 340796 ifAbsent: [ 55 ]) = collection size! ! 340797 340798!SortedCollectionTest methodsFor: 'tests - index accessing for multipliness'! 340799testLastIndexOfStartingAtDuplicate 340800 "self debug: #testLastIndexOf" 340801 | collection element | 340802 collection := self collectionWithSameAtEndAndBegining. 340803 element := collection last. 340804 340805 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 340806 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" 340807 self assert: (collection 340808 lastIndexOf: element 340809 startingAt: collection size 340810 ifAbsent: [ 55 ]) = collection size. 340811 self assert: (collection 340812 lastIndexOf: element 340813 startingAt: collection size - 1 340814 ifAbsent: [ 55 ]) = 1! ! 340815 340816 340817!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340818testAllButFirstDo 340819 340820 | result | 340821 result:= OrderedCollection new. 340822 340823 self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 340824 340825 1 to: (result size) do: 340826 [:i| 340827 self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. 340828 340829 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 340830 340831!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340832testAllButLastDo 340833 340834 | result | 340835 result:= OrderedCollection new. 340836 340837 self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 340838 340839 1 to: (result size) do: 340840 [:i| 340841 self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. 340842 340843 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 340844 340845!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340846testCollectFromTo 340847 340848 | result | 340849 result:=self nonEmptyMoreThan1Element 340850 collect: [ :each | each ] 340851 from: 1 340852 to: (self nonEmptyMoreThan1Element size - 1). 340853 340854 1 to: result size 340855 do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. 340856 self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! 340857 340858!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340859testDetectSequenced 340860" testing that detect keep the first element returning true for sequenceable collections " 340861 340862 | element result | 340863 element := self nonEmptyMoreThan1Element at:1. 340864 result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. 340865 self assert: result = element. ! ! 340866 340867!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340868testDo! ! 340869 340870!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340871testFindFirst 340872 340873 | element result | 340874 element := self nonEmptyMoreThan1Element at:1. 340875 result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. 340876 340877 self assert: result=1. ! ! 340878 340879!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340880testFindFirstNotIn 340881 340882 | result | 340883 340884 result:=self empty findFirst: [:each | true]. 340885 340886 self assert: result=0. ! ! 340887 340888!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340889testFindLast 340890 340891 | element result | 340892 element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. 340893 result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. 340894 340895 self assert: result=self nonEmptyMoreThan1Element size. ! ! 340896 340897!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340898testFindLastNotIn 340899 340900 | result | 340901 340902 result:=self empty findFirst: [:each | true]. 340903 340904 self assert: result=0. ! ! 340905 340906!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340907testFromToDo 340908 340909 | result | 340910 result:= OrderedCollection new. 340911 340912 self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 340913 340914 1 to: (self nonEmptyMoreThan1Element size -1) do: 340915 [:i| 340916 self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. 340917 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 340918 340919!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340920testKeysAndValuesDo 340921 "| result | 340922 result:= OrderedCollection new. 340923 340924 self nonEmptyMoreThan1Element keysAndValuesDo: 340925 [:i :value| 340926 result add: (value+i)]. 340927 340928 1 to: result size do: 340929 [:i| 340930 self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" 340931 | indexes elements | 340932 indexes:= OrderedCollection new. 340933 elements := OrderedCollection new. 340934 340935 self nonEmptyMoreThan1Element keysAndValuesDo: 340936 [:i :value| 340937 indexes add: (i). 340938 elements add: value]. 340939 340940 (1 to: self nonEmptyMoreThan1Element size )do: 340941 [ :i | 340942 self assert: (indexes at: i) = i. 340943 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 340944 ]. 340945 340946 self assert: indexes size = elements size. 340947 self assert: indexes size = self nonEmptyMoreThan1Element size . 340948 340949 ! ! 340950 340951!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340952testKeysAndValuesDoEmpty 340953 | result | 340954 result:= OrderedCollection new. 340955 340956 self empty keysAndValuesDo: 340957 [:i :value| 340958 result add: (value+i)]. 340959 340960 self assert: result isEmpty .! ! 340961 340962!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340963testPairsCollect 340964 340965 | index result | 340966 index:=0. 340967 340968 result:=self nonEmptyMoreThan1Element pairsCollect: 340969 [:each1 :each2 | 340970 self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). 340971 (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). 340972 ]. 340973 340974 result do: 340975 [:each | self assert: each = true]. 340976 340977! ! 340978 340979!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340980testPairsDo 340981 | index | 340982 index:=1. 340983 340984 self nonEmptyMoreThan1Element pairsDo: 340985 [:each1 :each2 | 340986 self assert:(self nonEmptyMoreThan1Element at:index)=each1. 340987 self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. 340988 index:=index+2]. 340989 340990 self nonEmptyMoreThan1Element size odd 340991 ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] 340992 ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! 340993 340994!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 340995testReverseDo 340996 | result | 340997 result:= OrderedCollection new. 340998 self nonEmpty reverseDo: [: each | result add: each]. 340999 341000 1 to: result size do: 341001 [:i| 341002 self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! 341003 341004!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 341005testReverseDoEmpty 341006 | result | 341007 result:= OrderedCollection new. 341008 self empty reverseDo: [: each | result add: each]. 341009 341010 self assert: result isEmpty .! ! 341011 341012!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 341013testReverseWithDo 341014 341015 | secondCollection result index | 341016 result:= OrderedCollection new. 341017 index := self nonEmptyMoreThan1Element size + 1. 341018 secondCollection:= self nonEmptyMoreThan1Element copy. 341019 341020 self nonEmptyMoreThan1Element reverseWith: secondCollection do: 341021 [:a :b | 341022 self assert: (self nonEmptyMoreThan1Element indexOf: a ) = (index := index - 1 ). 341023 result add: (a = b)]. 341024 341025 1 to: result size do: 341026 [:i| 341027 self assert: (result at:i)=(true)]. 341028 self assert: result size = self nonEmptyMoreThan1Element size.! ! 341029 341030!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 341031testWithCollect 341032 341033 | result newCollection index collection | 341034 341035 index := 0. 341036 collection := self nonEmptyMoreThan1Element . 341037 newCollection := collection copy. 341038 result:=collection with: newCollection collect: [:a :b | 341039 self assert: (collection indexOf: a ) = ( index := index + 1). 341040 self assert: (a = b). 341041 b]. 341042 341043 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 341044 self assert: result size = collection size.! ! 341045 341046!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 341047testWithCollectError 341048 self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! 341049 341050!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 341051testWithDo 341052 341053 | secondCollection result index | 341054 result:= OrderedCollection new. 341055 secondCollection:= self nonEmptyMoreThan1Element copy. 341056 index := 0. 341057 341058 self nonEmptyMoreThan1Element with: secondCollection do: 341059 [:a :b | 341060 self assert: (self nonEmptyMoreThan1Element indexOf: a) = ( index := index + 1). 341061 result add: (a =b)]. 341062 341063 1 to: result size do: 341064 [:i| 341065 self assert: (result at:i)=(true)]. 341066 self assert: result size = self nonEmptyMoreThan1Element size.! ! 341067 341068!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 341069testWithDoError 341070 341071 self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! 341072 341073!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 341074testWithIndexCollect 341075 341076 | result index collection | 341077 index := 0. 341078 collection := self nonEmptyMoreThan1Element . 341079 result := collection withIndexCollect: [:each :i | 341080 self assert: i = (index := index + 1). 341081 self assert: i = (collection indexOf: each) . 341082 each] . 341083 341084 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 341085 self assert: result size = collection size.! ! 341086 341087!SortedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 341088testWithIndexDo 341089 341090 "| result | 341091 result:=Array new: self nonEmptyMoreThan1Element size. 341092 self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 341093 341094 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" 341095 | indexes elements | 341096 indexes:= OrderedCollection new. 341097 elements := OrderedCollection new. 341098 341099 self nonEmptyMoreThan1Element withIndexDo: 341100 [:value :i | 341101 indexes add: (i). 341102 elements add: value]. 341103 341104 (1 to: self nonEmptyMoreThan1Element size )do: 341105 [ :i | 341106 self assert: (indexes at: i) = i. 341107 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 341108 ]. 341109 341110 self assert: indexes size = elements size. 341111 self assert: indexes size = self nonEmptyMoreThan1Element size . 341112 ! ! 341113 341114 341115!SortedCollectionTest methodsFor: 'tests - occurrencesOf'! 341116testOccurrencesOf 341117 | collection | 341118 collection := self collectionWithoutEqualElements . 341119 341120 collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! 341121 341122!SortedCollectionTest methodsFor: 'tests - occurrencesOf'! 341123testOccurrencesOfEmpty 341124 | result | 341125 result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). 341126 self assert: result = 0! ! 341127 341128!SortedCollectionTest methodsFor: 'tests - occurrencesOf'! 341129testOccurrencesOfNotIn 341130 | result | 341131 result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. 341132 self assert: result = 0! ! 341133 341134 341135!SortedCollectionTest methodsFor: 'tests - occurrencesOf for multipliness'! 341136testOccurrencesOfForMultipliness 341137 341138| collection element | 341139collection := self collectionWithEqualElements . 341140element := self elementTwiceInForOccurrences . 341141 341142self assert: (collection occurrencesOf: element ) = 2. ! ! 341143 341144 341145!SortedCollectionTest methodsFor: 'tests - printing'! 341146testPrintElementsOn 341147 341148 | aStream result allElementsAsString | 341149 result:=''. 341150 aStream:= ReadWriteStream on: result. 341151 341152 self nonEmpty printElementsOn: aStream . 341153 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 341154 1 to: allElementsAsString size do: 341155 [:i | 341156 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 341157 ].! ! 341158 341159!SortedCollectionTest methodsFor: 'tests - printing'! 341160testPrintNameOn 341161 341162 | aStream result | 341163 result:=''. 341164 aStream:= ReadWriteStream on: result. 341165 341166 self nonEmpty printNameOn: aStream . 341167 Transcript show: result asString. 341168 self nonEmpty class name first isVowel 341169 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 341170 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 341171 341172!SortedCollectionTest methodsFor: 'tests - printing'! 341173testPrintOn 341174 | aStream result allElementsAsString | 341175 result:=''. 341176 aStream:= ReadWriteStream on: result. 341177 341178 self nonEmpty printOn: aStream . 341179 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 341180 1 to: allElementsAsString size do: 341181 [:i | 341182 i=1 341183 ifTrue:[ 341184 self accessCollection class name first isVowel 341185 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 341186 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 341187 i=2 341188 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 341189 i>2 341190 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. 341191 ].! ! 341192 341193!SortedCollectionTest methodsFor: 'tests - printing'! 341194testPrintOnDelimiter 341195 | aStream result allElementsAsString | 341196 result:=''. 341197 aStream:= ReadWriteStream on: result. 341198 341199 self nonEmpty printOn: aStream delimiter: ', ' . 341200 341201 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 341202 1 to: allElementsAsString size do: 341203 [:i | 341204 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 341205 ].! ! 341206 341207!SortedCollectionTest methodsFor: 'tests - printing'! 341208testPrintOnDelimiterLast 341209 341210 | aStream result allElementsAsString | 341211 result:=''. 341212 aStream:= ReadWriteStream on: result. 341213 341214 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 341215 341216 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 341217 1 to: allElementsAsString size do: 341218 [:i | 341219 i<(allElementsAsString size-1 ) 341220 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 341221 i=(allElementsAsString size-1) 341222 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 341223 i=(allElementsAsString size) 341224 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 341225 ].! ! 341226 341227!SortedCollectionTest methodsFor: 'tests - printing'! 341228testStoreOn 341229" for the moment work only for collection that include simple elements such that Integer" 341230 341231"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 341232string := ''. 341233str := ReadWriteStream on: string. 341234elementsAsStringExpected := OrderedCollection new. 341235elementsAsStringObtained := OrderedCollection new. 341236self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 341237 341238self nonEmpty storeOn: str. 341239result := str contents . 341240cuttedResult := ( result findBetweenSubStrs: ';' ). 341241 341242index := 1. 341243 341244cuttedResult do: 341245 [ :each | 341246 index = 1 341247 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 341248 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 341249 elementsAsStringObtained add: tmp. 341250 index := index + 1. ] 341251 ifFalse: [ 341252 index < cuttedResult size 341253 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 341254 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 341255 elementsAsStringObtained add: tmp. 341256 index := index + 1.] 341257 ifFalse: [self assert: ( each = ' yourself)' ) ]. 341258 ] 341259 341260 ]. 341261 341262 341263 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 341264 341265! ! 341266 341267 341268!SortedCollectionTest methodsFor: 'tests - remove'! 341269testRemoveAllError 341270 "self debug: #testRemoveElementThatExists" 341271 | el res subCollection | 341272 el := self elementNotIn. 341273 subCollection := self nonEmptyWithoutEqualElements copyWith: el. 341274 self 341275 should: [ res := self nonEmptyWithoutEqualElements removeAll: subCollection ] 341276 raise: Error! ! 341277 341278!SortedCollectionTest methodsFor: 'tests - remove'! 341279testRemoveAllFoundIn 341280 "self debug: #testRemoveElementThatExists" 341281 | el res subCollection | 341282 el := self nonEmptyWithoutEqualElements anyOne. 341283 subCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. 341284 self 341285 shouldnt: 341286 [ res := self nonEmptyWithoutEqualElements removeAllFoundIn: subCollection ] 341287 raise: Error. 341288 self assert: self nonEmptyWithoutEqualElements size = 1. 341289 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 341290 341291!SortedCollectionTest methodsFor: 'tests - remove'! 341292testRemoveAllSuchThat 341293 "self debug: #testRemoveElementThatExists" 341294 | el subCollection | 341295 el := self nonEmptyWithoutEqualElements anyOne. 341296 subCollection := self nonEmptyWithoutEqualElements copyWithout: el. 341297 self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | subCollection includes: each ]. 341298 self assert: self nonEmptyWithoutEqualElements size = 1. 341299 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 341300 341301!SortedCollectionTest methodsFor: 'tests - remove'! 341302testRemoveElementFromEmpty 341303 "self debug: #testRemoveElementFromEmpty" 341304 self 341305 should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] 341306 raise: Error! ! 341307 341308!SortedCollectionTest methodsFor: 'tests - remove'! 341309testRemoveElementReallyRemovesElement 341310 "self debug: #testRemoveElementReallyRemovesElement" 341311 | size | 341312 size := self nonEmptyWithoutEqualElements size. 341313 self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. 341314 self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! 341315 341316!SortedCollectionTest methodsFor: 'tests - remove'! 341317testRemoveElementThatExists 341318 "self debug: #testRemoveElementThatExists" 341319 | el res | 341320 el := self nonEmptyWithoutEqualElements anyOne. 341321 self 341322 shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] 341323 raise: Error. 341324 self assert: res == el! ! 341325 341326!SortedCollectionTest methodsFor: 'tests - remove'! 341327testRemoveIfAbsent 341328 "self debug: #testRemoveElementThatExists" 341329 | el res | 341330 el := self elementNotIn. 341331 self 341332 shouldnt: 341333 [ res := self nonEmptyWithoutEqualElements 341334 remove: el 341335 ifAbsent: [ 33 ] ] 341336 raise: Error. 341337 self assert: res == 33! ! 341338 341339 341340!SortedCollectionTest methodsFor: 'tests - removing by index'! 341341testRemoveAt 341342 341343| collection element result oldSize | 341344collection := self collectionWith5Elements . 341345element := collection at: 3. 341346oldSize := collection size. 341347 341348result := collection removeAt: 3. 341349self assert: result = element . 341350self assert: collection size = (oldSize - 1).! ! 341351 341352!SortedCollectionTest methodsFor: 'tests - removing by index'! 341353testRemoveAtNotPresent 341354 341355| | 341356self should: [self empty removeAt: 2] raise: Error.! ! 341357 341358!SortedCollectionTest methodsFor: 'tests - removing by index'! 341359testRemoveFirst 341360 341361| collection element result oldSize | 341362collection := self collectionWith5Elements . 341363element := collection first. 341364oldSize := collection size. 341365 341366result := collection removeFirst. 341367self assert: result = element . 341368self assert: collection size = (oldSize - 1).! ! 341369 341370!SortedCollectionTest methodsFor: 'tests - removing by index'! 341371testRemoveFirstNElements 341372 341373| collection elements result oldSize | 341374collection := self collectionWith5Elements . 341375elements := {collection first. collection at:2}. 341376oldSize := collection size. 341377 341378result := collection removeFirst: 2. 341379self assert: result = elements . 341380self assert: collection size = (oldSize - 2).! ! 341381 341382!SortedCollectionTest methodsFor: 'tests - removing by index'! 341383testRemoveFirstNElementsNotPresent 341384 341385self should: [self empty removeFirst: 2] raise: Error.! ! 341386 341387!SortedCollectionTest methodsFor: 'tests - removing by index'! 341388testRemoveFirstNotPresent 341389 341390self should: [self empty removeFirst] raise: Error.! ! 341391 341392!SortedCollectionTest methodsFor: 'tests - removing by index'! 341393testRemoveLast 341394 341395| collection element result oldSize | 341396collection := self collectionWith5Elements . 341397element := collection last. 341398oldSize := collection size. 341399 341400result := collection removeLast. 341401self assert: result = element . 341402self assert: collection size = (oldSize - 1).! ! 341403 341404!SortedCollectionTest methodsFor: 'tests - removing by index'! 341405testRemoveLastNElements 341406 341407| collection result oldSize elements | 341408collection := self collectionWith5Elements . 341409elements := { (collection at: (4)). collection last. }. 341410oldSize := collection size. 341411 341412 341413result := (collection removeLast: 2). 341414self assert: result = elements. 341415self assert: collection size = (oldSize - 2).! ! 341416 341417!SortedCollectionTest methodsFor: 'tests - removing by index'! 341418testRemoveLastNElementsNElements 341419 341420self should: [self empty removeLast: 2] raise: Error.! ! 341421 341422!SortedCollectionTest methodsFor: 'tests - removing by index'! 341423testRemoveLastNotPresent 341424 341425self should: [self empty removeLast] raise: Error.! ! 341426 341427 341428!SortedCollectionTest methodsFor: 'tests - set arithmetic'! 341429containsAll: union of: one andOf: another 341430 341431 self assert: (one allSatisfy: [:each | union includes: each]). 341432 self assert: (another allSatisfy: [:each | union includes: each])! ! 341433 341434!SortedCollectionTest methodsFor: 'tests - set arithmetic'! 341435numberOfSimilarElementsInIntersection 341436 ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! 341437 341438!SortedCollectionTest methodsFor: 'tests - set arithmetic'! 341439testDifference 341440 "Answer the set theoretic difference of two collections." 341441 "self debug: #testDifference" 341442 341443 self assert: (self collection difference: self collection) isEmpty. 341444 self assert: (self empty difference: self collection) isEmpty. 341445 self assert: (self collection difference: self empty) = self collection 341446! ! 341447 341448!SortedCollectionTest methodsFor: 'tests - set arithmetic'! 341449testDifferenceWithNonNullIntersection 341450 "Answer the set theoretic difference of two collections." 341451 "self debug: #testDifferenceWithNonNullIntersection" 341452 " #(1 2 3) difference: #(2 4) 341453 -> #(1 3)" 341454 | res overlapping | 341455 overlapping := self collectionClass 341456 with: self anotherElementOrAssociationNotIn 341457 with: self anotherElementOrAssociationIn. 341458 res := self collection difference: overlapping. 341459 self deny: (res includes: self anotherElementOrAssociationIn). 341460 overlapping do: [ :each | self deny: (res includes: each) ]! ! 341461 341462!SortedCollectionTest methodsFor: 'tests - set arithmetic'! 341463testDifferenceWithSeparateCollection 341464 "Answer the set theoretic difference of two collections." 341465 "self debug: #testDifferenceWithSeparateCollection" 341466 | res separateCol | 341467 separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. 341468 res := self collection difference: separateCol. 341469 self deny: (res includes: self anotherElementOrAssociationNotIn). 341470 self assert: res = self collection. 341471 res := separateCol difference: self collection. 341472 self deny: (res includes: self collection anyOne). 341473 self assert: res = separateCol! ! 341474 341475!SortedCollectionTest methodsFor: 'tests - set arithmetic'! 341476testIntersectionBasic 341477 "self debug: #testIntersectionBasic" 341478 | inter | 341479 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 341480 self deny: inter isEmpty. 341481 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 341482 341483!SortedCollectionTest methodsFor: 'tests - set arithmetic'! 341484testIntersectionEmpty 341485 "self debug: #testIntersectionEmpty" 341486 341487 | inter | 341488 inter := self empty intersection: self empty. 341489 self assert: inter isEmpty. 341490 inter := self empty intersection: self collection . 341491 self assert: inter = self empty. 341492 ! ! 341493 341494!SortedCollectionTest methodsFor: 'tests - set arithmetic'! 341495testIntersectionItself 341496 "self debug: #testIntersectionItself" 341497 341498 self assert: (self collection intersection: self collection) = self collection. 341499 ! ! 341500 341501!SortedCollectionTest methodsFor: 'tests - set arithmetic'! 341502testIntersectionTwoSimilarElementsInIntersection 341503 "self debug: #testIntersectionBasic" 341504 | inter | 341505 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 341506 self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. 341507 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 341508 341509!SortedCollectionTest methodsFor: 'tests - set arithmetic'! 341510testUnion 341511 "self debug: #testUnionOfEmpties" 341512 341513 | union | 341514 union := self empty union: self nonEmpty. 341515 self containsAll: union of: self empty andOf: self nonEmpty. 341516 union := self nonEmpty union: self empty. 341517 self containsAll: union of: self empty andOf: self nonEmpty. 341518 union := self collection union: self nonEmpty. 341519 self containsAll: union of: self collection andOf: self nonEmpty.! ! 341520 341521!SortedCollectionTest methodsFor: 'tests - set arithmetic'! 341522testUnionOfEmpties 341523 "self debug: #testUnionOfEmpties" 341524 341525 self assert: (self empty union: self empty) isEmpty. 341526 341527 ! ! 341528 341529 341530!SortedCollectionTest methodsFor: 'tests - subcollections access'! 341531testAllButFirst 341532 "self debug: #testAllButFirst" 341533 | abf col | 341534 col := self moreThan3Elements. 341535 abf := col allButFirst. 341536 self deny: abf first = col first. 341537 self assert: abf size + 1 = col size! ! 341538 341539!SortedCollectionTest methodsFor: 'tests - subcollections access'! 341540testAllButFirstNElements 341541 "self debug: #testAllButFirst" 341542 | abf col | 341543 col := self moreThan3Elements. 341544 abf := col allButFirst: 2. 341545 1 341546 to: abf size 341547 do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. 341548 self assert: abf size + 2 = col size! ! 341549 341550!SortedCollectionTest methodsFor: 'tests - subcollections access'! 341551testAllButLast 341552 "self debug: #testAllButLast" 341553 | abf col | 341554 col := self moreThan3Elements. 341555 abf := col allButLast. 341556 self deny: abf last = col last. 341557 self assert: abf size + 1 = col size! ! 341558 341559!SortedCollectionTest methodsFor: 'tests - subcollections access'! 341560testAllButLastNElements 341561 "self debug: #testAllButFirst" 341562 | abf col | 341563 col := self moreThan3Elements. 341564 abf := col allButLast: 2. 341565 1 341566 to: abf size 341567 do: [ :i | self assert: (abf at: i) = (col at: i) ]. 341568 self assert: abf size + 2 = col size! ! 341569 341570!SortedCollectionTest methodsFor: 'tests - subcollections access'! 341571testFirstNElements 341572 "self debug: #testFirstNElements" 341573 | result | 341574 result := self moreThan3Elements first: self moreThan3Elements size - 1. 341575 1 341576 to: result size 341577 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. 341578 self assert: result size = (self moreThan3Elements size - 1). 341579 self 341580 should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] 341581 raise: Error! ! 341582 341583!SortedCollectionTest methodsFor: 'tests - subcollections access'! 341584testLastNElements 341585 "self debug: #testLastNElements" 341586 | result | 341587 result := self moreThan3Elements last: self moreThan3Elements size - 1. 341588 1 341589 to: result size 341590 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. 341591 self assert: result size = (self moreThan3Elements size - 1). 341592 self 341593 should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] 341594 raise: Error! ! 341595 341596"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 341597 341598SortedCollectionTest class 341599 uses: TEmptyTest classTrait + TIterateSequencedReadableTest classTrait + TPrintOnSequencedTest classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TSequencedElementAccessTest classTrait + TSubCollectionAccess classTrait + TIndexAccessForMultipliness classTrait + TRemoveTest classTrait + TConvertTest classTrait + TAddTest classTrait + TBeginsEndsWith classTrait + TCopySequenceableSameContents classTrait + TSetArithmetic classTrait + TRemoveByIndexTest classTrait + TCopyPartOfSequenceable classTrait + TCopyPartOfSequenceableForMultipliness classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopySequenceableWithReplacementForSorted classTrait + TCopyTest classTrait + TConvertAsSortedTest classTrait + TIncludesWithIdentityCheckTest classTrait + TConvertAsSetForMultiplinessIdentityTest classTrait + TSequencedStructuralEqualityTest classTrait + TCreationWithTest classTrait + TOccurrencesForMultiplinessTest classTrait 341600 instanceVariableNames: ''! 341601AppRegistry subclass: #SoundService 341602 instanceVariableNames: '' 341603 classVariableNames: '' 341604 poolDictionaries: '' 341605 category: 'System-Applications'! 341606!SoundService commentStamp: 'gk 2/24/2004 23:14' prior: 0! 341607This is the AppRegistry class for the sound system. 341608 341609A sound system offers a small protocol for playing sounds and making beeps and works like a facade towards the rest of Squeak. A sound system is registered in this registry and can be accessed by "SoundService default". This way we decouple the sound system from the rest of Squeak and make it pluggable. It also is a perfect spot to check for the Preference class>>soundsEnabled.! 341610 341611Object subclass: #SoundTheme 341612 instanceVariableNames: 'sounds' 341613 classVariableNames: 'Current' 341614 poolDictionaries: '' 341615 category: 'Polymorph-Widgets-Themes'! 341616!SoundTheme commentStamp: 'gvc 9/12/2007 14:54' prior: 0! 341617Groups a set of sounds to use with a UITheme. 341618Note that, although instances may have their sounds changed the preferences will still indicate the class of theme that is current.! 341619 341620 341621!SoundTheme methodsFor: 'accessing' stamp: 'gvc 9/12/2007 14:34'! 341622sounds 341623 "Answer the value of sounds" 341624 341625 ^ sounds! ! 341626 341627!SoundTheme methodsFor: 'accessing' stamp: 'gvc 9/12/2007 14:34'! 341628sounds: anObject 341629 "Set the value of sounds" 341630 341631 sounds := anObject! ! 341632 341633 341634!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 9/12/2007 17:35'! 341635defaultAbortSound 341636 "Answer the default abort sound." 341637 341638 ^self defaultSound! ! 341639 341640!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 9/12/2007 17:36'! 341641defaultAlertSound 341642 "Answer the default alert sound." 341643 341644 ^self defaultSound! ! 341645 341646!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 7/30/2009 17:49'! 341647defaultDefaultSound 341648 "Answer the default default sound!!" 341649 341650 ^Beeper default! ! 341651 341652!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 9/12/2007 17:36'! 341653defaultDenySound 341654 "Answer the default deny sound." 341655 341656 ^self defaultSound! ! 341657 341658!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 9/12/2007 17:36'! 341659defaultMessageSound 341660 "Answer the default message sound." 341661 341662 ^self defaultSound! ! 341663 341664!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 9/12/2007 17:36'! 341665defaultQuestionSound 341666 "Answer the default question sound." 341667 341668 ^self defaultSound! ! 341669 341670!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 9/12/2007 17:36'! 341671defaultWindowCloseSound 341672 "Answer the default window close sound." 341673 341674 ^self defaultSound! ! 341675 341676!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 9/12/2007 17:36'! 341677defaultWindowMaximizeSound 341678 "Answer the default window maximize sound." 341679 341680 ^self defaultSound! ! 341681 341682!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 9/12/2007 17:36'! 341683defaultWindowMinimizeSound 341684 "Answer the default window minimize sound." 341685 341686 ^self defaultSound! ! 341687 341688!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 9/12/2007 17:50'! 341689defaultWindowOpenSound 341690 "Answer the default window open sound." 341691 341692 ^self defaultSound! ! 341693 341694!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 9/12/2007 17:36'! 341695defaultWindowRestoreDownSound 341696 "Answer the default window restore down sound." 341697 341698 ^self defaultSound! ! 341699 341700!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 9/12/2007 17:36'! 341701defaultWindowRestoreUpSound 341702 "Answer the default window restore up sound." 341703 341704 ^self defaultSound! ! 341705 341706!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 9/12/2007 14:38'! 341707initialize 341708 "Initialize the receiver." 341709 341710 super initialize. 341711 self initializeSounds! ! 341712 341713!SoundTheme methodsFor: 'initialize-release' stamp: 'gvc 9/12/2007 17:37'! 341714initializeSounds 341715 "Initialize the receiver's event sounds." 341716 341717 self sounds: Dictionary new. 341718 self sounds 341719 at: #default put: self defaultDefaultSound; 341720 at: #abort put: self defaultAbortSound; 341721 at: #alert put: self defaultAlertSound; 341722 at: #deny put: self defaultDenySound; 341723 at: #message put: self defaultMessageSound; 341724 at: #question put: self defaultQuestionSound; 341725 at: #windowMinimize put: self defaultWindowMinimizeSound; 341726 at: #windowMaximize put: self defaultWindowMaximizeSound; 341727 at: #windowRestoreUp put: self defaultWindowRestoreUpSound; 341728 at: #windowRestoreDown put: self defaultWindowRestoreDownSound; 341729 at: #windowClose put: self defaultWindowCloseSound! ! 341730 341731 341732!SoundTheme methodsFor: 'sounds' stamp: 'gvc 7/30/2009 17:48'! 341733abortSound 341734 "Answer the abort sound." 341735 341736 ^self sounds at: #abort ifAbsent: [self defaultSound]! ! 341737 341738!SoundTheme methodsFor: 'sounds' stamp: 'gvc 7/30/2009 17:48'! 341739alertSound 341740 "Answer the alert sound." 341741 341742 ^self sounds at: #alert ifAbsent: [self defaultSound]! ! 341743 341744!SoundTheme methodsFor: 'sounds' stamp: 'gvc 7/30/2009 17:48'! 341745defaultSound 341746 "Answer the default sound." 341747 341748 ^self sounds at: #default ifAbsent: [self defaultDefaultSound]! ! 341749 341750!SoundTheme methodsFor: 'sounds' stamp: 'gvc 7/30/2009 17:48'! 341751denySound 341752 "Answer the deny sound." 341753 341754 ^self sounds at: #deny ifAbsent: [self defaultSound]! ! 341755 341756!SoundTheme methodsFor: 'sounds' stamp: 'gvc 7/30/2009 17:48'! 341757messageSound 341758 "Answer the message sound." 341759 341760 ^self sounds at: #message ifAbsent: [self defaultSound]! ! 341761 341762!SoundTheme methodsFor: 'sounds' stamp: 'gvc 7/30/2009 17:48'! 341763questionSound 341764 "Answer the question sound." 341765 341766 ^self sounds at: #question ifAbsent: [self defaultSound]! ! 341767 341768!SoundTheme methodsFor: 'sounds' stamp: 'gvc 7/30/2009 17:48'! 341769windowCloseSound 341770 "Answer the window close sound." 341771 341772 ^self sounds at: #windowClose ifAbsent: [self defaultSound]! ! 341773 341774!SoundTheme methodsFor: 'sounds' stamp: 'gvc 7/30/2009 17:48'! 341775windowMaximizeSound 341776 "Answer the window maximize sound." 341777 341778 ^self sounds at: #windowMaximize ifAbsent: [self defaultSound]! ! 341779 341780!SoundTheme methodsFor: 'sounds' stamp: 'gvc 7/30/2009 17:48'! 341781windowMinimizeSound 341782 "Answer the window minimize sound." 341783 341784 ^self sounds at: #windowMinimize ifAbsent: [self defaultSound]! ! 341785 341786!SoundTheme methodsFor: 'sounds' stamp: 'gvc 7/30/2009 17:49'! 341787windowOpenSound 341788 "Answer the window open sound." 341789 341790 ^self sounds at: #windowOpen ifAbsent: [self defaultSound]! ! 341791 341792!SoundTheme methodsFor: 'sounds' stamp: 'gvc 7/30/2009 17:49'! 341793windowRestoreDownSound 341794 "Answer the window restore down sound." 341795 341796 ^self sounds at: #windowRestoreDown ifAbsent: [self defaultSound]! ! 341797 341798!SoundTheme methodsFor: 'sounds' stamp: 'gvc 7/30/2009 17:49'! 341799windowRestoreUpSound 341800 "Answer the window restore up sound." 341801 341802 ^self sounds at: #windowRestoreUp ifAbsent: [self defaultSound]! ! 341803 341804"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 341805 341806SoundTheme class 341807 instanceVariableNames: ''! 341808 341809!SoundTheme class methodsFor: 'as yet unclassified' stamp: 'gvc 9/12/2007 15:20'! 341810allThemeClasses 341811 "Answer the subclasses of the receiver that are considered to be 341812 concrete (useable as a theme)." 341813 341814 ^self withAllSubclasses reject: [:c | c isAbstract]! ! 341815 341816!SoundTheme class methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 18:27'! 341817beCurrent 341818 "Make a new instance of the receiver be the current theme." 341819 341820 self isAbstract ifTrue: [^self error: self name, ' is abstract, send #beCurrent to a subclass.']. 341821 self current: self newDefault! ! 341822 341823!SoundTheme class methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 18:25'! 341824current 341825 "Answer the current ui theme." 341826 341827 ^Current ifNil: [Current := NullSoundTheme newDefault. Current]! ! 341828 341829!SoundTheme class methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 18:26'! 341830current: aSoundTheme 341831 "Set the current sound theme." 341832 341833 Current := aSoundTheme. 341834 SoundTheme allThemeClasses do: [:c | c changed: #isCurrent]! ! 341835 341836!SoundTheme class methodsFor: 'as yet unclassified' stamp: 'gvc 9/12/2007 14:48'! 341837isAbstract 341838 "Answer whether the receiver is considered to be abstract." 341839 341840 ^false! ! 341841 341842!SoundTheme class methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 18:27'! 341843isCurrent 341844 "Answer whether an instance of the receiver is the current theme." 341845 341846 ^self current class == self! ! 341847 341848!SoundTheme class methodsFor: 'as yet unclassified' stamp: 'gvc 9/13/2007 10:39'! 341849newDefault 341850 "Answer a new instance of the sound theme with 341851 its default sounds." 341852 341853 ^self new! ! 341854 341855!SoundTheme class methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 18:04'! 341856themeName 341857 "Answer the friendly name of the theme." 341858 341859 ^'Beeper sounds'! ! 341860SequenceableCollection subclass: #SourceFileArray 341861 instanceVariableNames: '' 341862 classVariableNames: '' 341863 poolDictionaries: '' 341864 category: 'Files-System'! 341865!SourceFileArray commentStamp: '<historical>' prior: 0! 341866This class is an abstract superclass for source code access mechanisms. It defines the messages that need to be understood by those subclasses that store and retrieve source chunks on files, over the network or in databases. 341867The first concrete subclass, StandardSourceFileArray, supports access to the traditional sources and changes files. Other subclasses might implement multiple source files for different applications, or access to a network source server.! 341868]style[(254 23 184)f1,f1LStandardSourceFileArray Comment;,f1! 341869 341870 341871!SourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:42'! 341872at: index 341873 self subclassResponsibility! ! 341874 341875!SourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:43'! 341876at: index put: aFileStream 341877 self subclassResponsibility! ! 341878 341879!SourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:43'! 341880size 341881 self subclassResponsibility! ! 341882 341883 341884!SourceFileArray methodsFor: 'sourcepointer conversion' stamp: 'hmm 4/25/2000 22:00'! 341885fileIndexFromSourcePointer: anInteger 341886 "Return the index of a source file corresponding to the given source pointer." 341887 self subclassResponsibility! ! 341888 341889!SourceFileArray methodsFor: 'sourcepointer conversion' stamp: 'hmm 4/25/2000 22:00'! 341890filePositionFromSourcePointer: anInteger 341891 "Return the position within a source file for the given source pointer." 341892 self subclassResponsibility! ! 341893 341894!SourceFileArray methodsFor: 'sourcepointer conversion' stamp: 'hmm 4/25/2000 22:01'! 341895sourcePointerFromFileIndex: index andPosition: position 341896 "Return a sourcePointer encoding the given file index and position" 341897 self subclassResponsibility! ! 341898Object subclass: #SpaceTally 341899 instanceVariableNames: 'results' 341900 classVariableNames: '' 341901 poolDictionaries: '' 341902 category: 'System-Tools'! 341903!SpaceTally commentStamp: 'sd 6/20/2003 22:31' prior: 0! 341904I'm responsible to help getting information about system space usage. The information I compute is represented by a spaceTallyItem 341905 341906try something like: 341907 341908((SpaceTally new spaceTally: (Array with: TextMorph with: Point)) 341909 asSortedCollection: [:a :b | a spaceForInstances > b spaceForInstances]) 341910 341911SpaceTally new systemWideSpaceTally 341912 341913 341914This class has been created from a part of SystemDictionary. It still deserves a nice 341915clean, such as using object instead of array having 4 slots. 341916 341917sd-20 June 2003! 341918 341919 341920!SpaceTally methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:31'! 341921results 341922 341923 ^ results! ! 341924 341925 341926!SpaceTally methodsFor: 'class analysis' stamp: 'efc 7/6/2004 00:30'! 341927computeSpaceUsage 341928 341929 | entry c instanceCount | 341930 1 to: results size do: [:i | 341931 entry := results at: i. 341932 c := self class environment at: entry analyzedClassName. 341933 instanceCount := c instanceCount. 341934 entry codeSize: c spaceUsed. 341935 entry instanceCount: instanceCount. 341936 entry spaceForInstances: (self spaceForInstancesOf: c withInstanceCount: instanceCount). 341937 Smalltalk garbageCollectMost]. 341938 341939! ! 341940 341941!SpaceTally methodsFor: 'class analysis' stamp: 'sd 6/20/2003 22:54'! 341942preAllocateResultsFor: classes 341943 341944 results := OrderedCollection new: classes size. 341945 classes do: [:cl | results add: (SpaceTallyItem analyzedClassName: cl name)]. 341946 results := results asArray. 341947! ! 341948 341949!SpaceTally methodsFor: 'class analysis' stamp: 'sd 6/20/2003 22:24'! 341950spaceTally: classes 341951 "Answer a collection of SpaceTallyItems representing the memory space (in bytes) consumed by the code and instances of each class in the system. Note that code sizes do not currently report memory consumed by class variables. " 341952 341953 "((SpaceTally new spaceTally: (Array with: TextMorph with: Point)) asSortedCollection: [:a :b | a spaceForInstances > b spaceForInstances]) asArray" 341954 341955 self preAllocateResultsFor: classes. 341956 Smalltalk garbageCollect. 341957 self computeSpaceUsage. 341958 ^ results 341959! ! 341960 341961!SpaceTally methodsFor: 'class analysis' stamp: 'efc 7/6/2004 00:25'! 341962systemWideSpaceTally 341963 "Answer a collection of SpaceTallyItems representing the memory space (in bytes) consumed by the code and instances of each class in the system. Note that code sizes do not currently report memory consumed by class variables. " 341964 341965 "(SpaceTally new systemWideSpaceTally asSortedCollection: [:a :b | a spaceForInstances > b spaceForInstances]) asArray" 341966 341967 ^self spaceTally: Smalltalk allClasses. 341968 341969! ! 341970 341971 341972!SpaceTally methodsFor: 'fileOut' stamp: 'stephane.ducasse 8/5/2009 17:07'! 341973printSpaceAnalysis 341974 "SpaceTally new printSpaceAnalysis" 341975 341976 | stream | 341977 stream := FileStream newFileNamed: 'STspace.text'. 341978 [ self printSpaceAnalysis: 1 on: stream ] ensure: [ stream close ]! ! 341979 341980!SpaceTally methodsFor: 'fileOut' stamp: 'stephane.ducasse 8/5/2009 17:32'! 341981printSpaceAnalysis: threshold on: aStream 341982 "SpaceTally new printSpaceAnalysis: 1 on:(FileStream forceNewFileNamed: 'STspace.text')" 341983 341984 "sd-This method should be rewrote to be more coherent within the rest of the class 341985 ie using preAllocate and spaceForInstanceOf:" 341986 341987 "If threshold > 0, then only those classes with more than that number 341988 of instances will be shown, and they will be sorted by total instance space. 341989 If threshold = 0, then all classes will appear, sorted by name." 341990 341991 | codeSpace instCount instSpace totalCodeSpace totalInstCount totalInstSpace eltSize n totalPercent percent | 341992 Smalltalk garbageCollect. 341993 totalCodeSpace := totalInstCount := totalInstSpace := n := 0. 341994 results := OrderedCollection new: Smalltalk classNames size. 341995 'Taking statistics...' 341996 displayProgressAt: Sensor cursorPoint 341997 from: 0 to: Smalltalk classNames size 341998 during: [:bar | 341999 "stephane.ducasse: clearly a hack because MethodContext allInstances fails right now" 342000 ((Smalltalk allClasses) 342001 reject: [:each | each name = 'MethodContext']) do: 342002 [:cl | codeSpace := cl spaceUsed. 342003 bar value: (n := n+1). 342004 Smalltalk garbageCollectMost. 342005 instCount := cl instanceCount. 342006 instSpace := (cl indexIfCompact > 0 ifTrue: [4] ifFalse: [8])*instCount. "Object headers" 342007 cl isVariable 342008 ifTrue: [eltSize := cl isBytes ifTrue: [1] ifFalse: [4]. 342009 cl allInstancesDo: [:x | instSpace := instSpace + (x basicSize*eltSize)]] 342010 ifFalse: [instSpace := instSpace + (cl instSize*instCount*4)]. 342011 results add: (SpaceTallyItem analyzedClassName: cl name codeSize: codeSpace instanceCount: instCount spaceForInstances: instSpace). 342012 totalCodeSpace := totalCodeSpace + codeSpace. 342013 totalInstCount := totalInstCount + instCount. 342014 totalInstSpace := totalInstSpace + instSpace]]. 342015 totalPercent := 0.0. 342016 342017 aStream timeStamp. 342018 aStream 342019 nextPutAll: ('Class' padded: #right to: 30 with: $ ); 342020 nextPutAll: ('code space' padded: #left to: 12 with: $ ); 342021 nextPutAll: ('# instances' padded: #left to: 12 with: $ ); 342022 nextPutAll: ('inst space' padded: #left to: 12 with: $ ); 342023 nextPutAll: ('percent' padded: #left to: 8 with: $ ); cr. 342024 342025 threshold > 0 ifTrue: [ 342026 "If inst count threshold > 0, then sort by space" 342027 results := (results select: [:s | s instanceCount >= threshold or: [s spaceForInstances > (totalInstSpace // 500)]]) 342028 asSortedCollection: [:s :s2 | s spaceForInstances > s2 spaceForInstances]]. 342029 342030 results do: [:s | 342031 aStream 342032 nextPutAll: (s analyzedClassName padded: #right to: 30 with: $ ); 342033 nextPutAll: (s codeSize printString padded: #left to: 12 with: $ ); 342034 nextPutAll: (s instanceCount printString padded: #left to: 12 with: $ ); 342035 nextPutAll: (s spaceForInstances printString padded: #left to: 14 with: $ ). 342036 percent := s spaceForInstances*100.0/totalInstSpace roundTo: 0.1. 342037 totalPercent := totalPercent + percent. 342038 percent >= 0.1 ifTrue: [ 342039 aStream nextPutAll: (percent printString padded: #left to: 8 with: $ )]. 342040 aStream cr]. 342041 342042 aStream 342043 cr; nextPutAll: ('Total' padded: #right to: 30 with: $ ); 342044 nextPutAll: (totalCodeSpace printString padded: #left to: 12 with: $ ); 342045 nextPutAll: (totalInstCount printString padded: #left to: 12 with: $ ); 342046 nextPutAll: (totalInstSpace printString padded: #left to: 14 with: $ ); 342047 nextPutAll: ((totalPercent roundTo: 0.1) printString padded: #left to: 8 with: $ ).! ! 342048 342049 342050!SpaceTally methodsFor: 'fileout' stamp: 'PeterHugossonMiller 9/3/2009 11:24'! 342051compareTallyIn: beforeFileName to: afterFileName 342052 "SpaceTally new compareTallyIn: 'tally' to: 'tally2'" 342053 342054 | answer s beforeDict a afterDict allKeys before after diff | 342055 beforeDict := Dictionary new. 342056 s := FileDirectory default fileNamed: beforeFileName. 342057 [s atEnd] whileFalse: [ 342058 a := Array readFrom: s nextLine. 342059 beforeDict at: a first put: a allButFirst. 342060 ]. 342061 s close. 342062 afterDict := Dictionary new. 342063 s := FileDirectory default fileNamed: afterFileName. 342064 [s atEnd] whileFalse: [ 342065 a := Array readFrom: s nextLine. 342066 afterDict at: a first put: a allButFirst. 342067 ]. 342068 s close. 342069 answer := String new writeStream. 342070 allKeys := (Set new addAll: beforeDict keys; addAll: afterDict keys; yourself) asSortedCollection. 342071 allKeys do: [ :each | 342072 before := beforeDict at: each ifAbsent: [#(0 0 0)]. 342073 after := afterDict at: each ifAbsent: [#(0 0 0)]. 342074 diff := before with: after collect: [ :vBefore :vAfter | vAfter - vBefore]. 342075 diff = #(0 0 0) ifFalse: [ 342076 answer nextPutAll: each,' ',diff printString; cr. 342077 ]. 342078 ]. 342079 StringHolder new contents: answer contents; openLabel: 'space diffs'. 342080 342081 342082 342083! ! 342084 342085!SpaceTally methodsFor: 'fileout' stamp: 'sd 6/20/2003 23:07'! 342086printSpaceDifferenceFrom: fileName1 to: fileName2 342087 "For differential results, run printSpaceAnalysis twice with different fileNames, 342088 then run this method... 342089 SpaceTally new printSpaceAnalysis: 0 on: 'STspace.text1'. 342090 --- do something that uses space here --- 342091 SpaceTally new printSpaceAnalysis: 0 on: 'STspace.text2'. 342092 SpaceTally new printSpaceDifferenceFrom: 'STspace.text1' to: 'STspace.text2' 342093" 342094 | f coll1 coll2 item | 342095 f := FileStream readOnlyFileNamed: fileName1. 342096 coll1 := OrderedCollection new. 342097 [f atEnd] whileFalse: [coll1 add: (f upTo: Character cr)]. 342098 f close. 342099 f := FileStream readOnlyFileNamed: fileName2. 342100 coll2 := OrderedCollection new. 342101 [f atEnd] whileFalse: 342102 [item := (f upTo: Character cr). 342103 ((coll1 includes: item) and: [(item endsWith: 'percent') not]) 342104 ifTrue: [coll1 remove: item] 342105 ifFalse: [coll2 add: item]]. 342106 f close. 342107 (StringHolder new contents: (String streamContents: 342108 [:s | 342109 s nextPutAll: fileName1; cr. 342110 coll1 do: [:x | s nextPutAll: x; cr]. 342111 s cr; cr. 342112 s nextPutAll: fileName2; cr. 342113 coll2 do: [:x | s nextPutAll: x; cr]])) 342114 openLabel: 'Differential Space Analysis'. 342115! ! 342116 342117!SpaceTally methodsFor: 'fileout' stamp: 'sd 6/20/2003 22:59'! 342118saveTo: aFileName 342119 "| st | 342120 st := SpaceTally new. 342121 st spaceTally: (Array with: TextMorph with: Point). 342122 st saveTo: 'spaceTally2'" 342123 | s | 342124 (FileDirectory default fileExists: aFileName) ifTrue: [ 342125 FileDirectory default deleteFileNamed: aFileName]. 342126 s := FileDirectory default fileNamed: aFileName. 342127 results do: [:each | s nextPutAll: each analyzedClassName asString ; 342128 nextPutAll: ' '; nextPutAll: each codeSize printString; 342129 nextPutAll: ' '; nextPutAll: each instanceCount printString; 342130 nextPutAll: ' '; nextPutAll: each spaceForInstances printString; cr]. 342131 s close! ! 342132 342133 342134!SpaceTally methodsFor: 'instance size' stamp: 'efc 7/6/2004 00:30'! 342135spaceForInstancesOf: aClass withInstanceCount: instCount 342136 "Answer the number of bytes consumed by all instances of the given class, including their object headers." 342137 342138 | isCompact instVarBytes bytesPerElement contentBytes headerBytes total | 342139 instCount = 0 ifTrue: [^ 0]. 342140 isCompact := aClass indexIfCompact > 0. 342141 instVarBytes := aClass instSize * 4. 342142 aClass isVariable 342143 ifTrue: [ 342144 bytesPerElement := aClass isBytes ifTrue: [1] ifFalse: [4]. 342145 total := 0. 342146 aClass allInstancesDo: [:inst | 342147 contentBytes := instVarBytes + (inst size * bytesPerElement). 342148 headerBytes := 342149 contentBytes > 255 342150 ifTrue: [12] 342151 ifFalse: [isCompact ifTrue: [4] ifFalse: [8]]. 342152 total := total + headerBytes + contentBytes]. 342153 ^ total] 342154 ifFalse: [ 342155 headerBytes := 342156 instVarBytes > 255 342157 ifTrue: [12] 342158 ifFalse: [isCompact ifTrue: [4] ifFalse: [8]]. 342159 ^ instCount * (headerBytes + instVarBytes)]. 342160! ! 342161Object subclass: #SpaceTallyItem 342162 instanceVariableNames: 'analyzedClassName codeSize instanceCount spaceForInstances' 342163 classVariableNames: '' 342164 poolDictionaries: '' 342165 category: 'System-Tools'! 342166!SpaceTallyItem commentStamp: 'sd 6/20/2003 22:02' prior: 0! 342167I'm represent an entry in the spaceTally.! 342168 342169 342170!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:59'! 342171analyzedClassName 342172 342173 ^ analyzedClassName! ! 342174 342175!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:59'! 342176analyzedClassName: aClassName 342177 342178 analyzedClassName := aClassName! ! 342179 342180!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:08'! 342181codeSize 342182 342183 ^ codeSize! ! 342184 342185!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:09'! 342186codeSize: aNumber 342187 342188 codeSize := aNumber! ! 342189 342190!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:09'! 342191instanceCount 342192 342193 ^ instanceCount! ! 342194 342195!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:09'! 342196instanceCount: aNumber 342197 342198 instanceCount := aNumber! ! 342199 342200!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:10'! 342201spaceForInstances 342202 342203 ^ spaceForInstances! ! 342204 342205!SpaceTallyItem methodsFor: 'accessing' stamp: 'sd 6/20/2003 22:10'! 342206spaceForInstances: aNumber 342207 342208 spaceForInstances := aNumber! ! 342209 342210 342211!SpaceTallyItem methodsFor: 'printing' stamp: 'sd 6/20/2003 22:52'! 342212printOn: aStream 342213 342214 analyzedClassName isNil 342215 ifFalse: [aStream nextPutAll: analyzedClassName asString]. 342216 aStream nextPutAll: ' ('. 342217 codeSize isNil 342218 ifFalse: [aStream nextPutAll: 'code size: ' ; nextPutAll: codeSize asString]. 342219 instanceCount isNil 342220 ifFalse: [aStream nextPutAll: ' instance count: ' ; nextPutAll: instanceCount asString]. 342221 spaceForInstances isNil 342222 ifFalse: [aStream nextPutAll: ' space for instances: ' ; nextPutAll: spaceForInstances asString]. 342223 aStream nextPut: $). 342224 ! ! 342225 342226"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 342227 342228SpaceTallyItem class 342229 instanceVariableNames: ''! 342230 342231!SpaceTallyItem class methodsFor: 'instance creation' stamp: 'sd 6/20/2003 22:54'! 342232analyzedClassName: aClassName 342233 342234 ^ self new 342235 analyzedClassName: aClassName ; yourself 342236 ! ! 342237 342238!SpaceTallyItem class methodsFor: 'instance creation' stamp: 'sd 6/20/2003 22:54'! 342239analyzedClassName: aClassName codeSize: codeSize instanceCount: instanceCount spaceForInstances: spaceForInstances 342240 342241 ^ self new 342242 analyzedClassName: aClassName ; 342243 codeSize: codeSize ; 342244 instanceCount: instanceCount ; 342245 spaceForInstances: spaceForInstances ; yourself! ! 342246ArrayedCollection variableSubclass: #SparseLargeTable 342247 instanceVariableNames: 'base size chunkSize defaultValue' 342248 classVariableNames: '' 342249 poolDictionaries: '' 342250 category: 'Collections-Arrayed'! 342251!SparseLargeTable commentStamp: '<historical>' prior: 0! 342252Derivated from Stephan Pair's LargeArray, but to hold a sparse table, in which most of the entries are the same default value, it uses some tricks.! 342253 342254 342255!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:58'! 342256arrayClass 342257 342258 ^(self basicAt: 1) class 342259! ! 342260 342261!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:58'! 342262at: index 342263 342264 self pvtCheckIndex: index. 342265 ^self noCheckAt: index. 342266! ! 342267 342268!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:58'! 342269at: index put: value 342270 342271 self pvtCheckIndex: index. 342272 ^self noCheckAt: index put: value 342273! ! 342274 342275!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 17:56'! 342276base 342277 342278 ^ base. 342279! ! 342280 342281!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:58'! 342282chunkSize 342283 342284 ^chunkSize 342285! ! 342286 342287!SparseLargeTable methodsFor: 'accessing' stamp: 'tak 12/21/2004 16:59'! 342288noCheckAt: index 342289 | chunkIndex t | 342290 342291 chunkIndex := index - base // chunkSize + 1. 342292 (chunkIndex > self basicSize or: [chunkIndex < 1]) ifTrue: [^ defaultValue]. 342293 t := self basicAt: chunkIndex. 342294 t ifNil: [^ defaultValue]. 342295 ^ t at: (index - base + 1 - (chunkIndex - 1 * chunkSize)) 342296! ! 342297 342298!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 19:18'! 342299noCheckAt: index put: value 342300 | chunkIndex t | 342301 342302 chunkIndex := index - base // chunkSize + 1. 342303 chunkIndex > self basicSize ifTrue: [^ value]. 342304 t := self basicAt: chunkIndex. 342305 t ifNil: [^ value]. 342306 ^ t at: (index - base + 1 - (chunkIndex - 1 * chunkSize)) put: value 342307! ! 342308 342309!SparseLargeTable methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:58'! 342310size 342311 342312 ^size 342313! ! 342314 342315!SparseLargeTable methodsFor: 'accessing' stamp: 'kwl 6/30/2006 03:02'! 342316zapDefaultOnlyEntries 342317 342318 | lastIndex newInst | 342319 1 to: self basicSize do: [:i | 342320 (self allDefaultValueSubtableAt: i) ifTrue: [self basicAt: i put: nil]. 342321 ]. 342322 342323 lastIndex := self findLastNonNilSubTable. 342324 lastIndex = 0 ifTrue: [^ self]. 342325 342326 newInst := self class new: lastIndex*chunkSize chunkSize: chunkSize arrayClass: (self basicAt: lastIndex) class base: base defaultValue: defaultValue. 342327 newInst privateSize: self size. 342328 base to: newInst size do: [:i | newInst at: i put: (self at: i)]. 342329 1 to: newInst basicSize do: [:i | 342330 (newInst allDefaultValueSubtableAt: i) ifTrue: [newInst basicAt: i put: nil]. 342331 ]. 342332 342333 " this is not allowed in production: self becomeForward: newInst. " 342334 ^ newInst. 342335! ! 342336 342337 342338!SparseLargeTable methodsFor: 'initialization' stamp: 'yo 12/1/2003 16:58'! 342339initChunkSize: aChunkSize size: aSize arrayClass: aClass base: b defaultValue: d 342340 342341 | lastChunkSize | 342342 chunkSize := aChunkSize. 342343 size := aSize. 342344 base := b. 342345 defaultValue := d. 342346 1 to: (self basicSize - 1) do: [ :in | self basicAt: in put: (aClass new: chunkSize withAll: defaultValue) ]. 342347 lastChunkSize := size \\ chunkSize. 342348 lastChunkSize = 0 ifTrue: [lastChunkSize := chunkSize]. 342349 size = 0 342350 ifTrue: [self basicAt: 1 put: (aClass new: 0)] 342351 ifFalse: [self basicAt: self basicSize put: (aClass new: lastChunkSize withAll: defaultValue)]. 342352! ! 342353 342354 342355!SparseLargeTable methodsFor: 'printing' stamp: 'yo 12/1/2003 17:06'! 342356printElementsOn: aStream 342357 | element | 342358 aStream nextPut: $(. 342359 base to: size do: [:index | element := self at: index. aStream print: element; space]. 342360 self isEmpty ifFalse: [aStream skip: -1]. 342361 aStream nextPut: $) 342362! ! 342363 342364!SparseLargeTable methodsFor: 'printing' stamp: 'yo 12/1/2003 15:58'! 342365printOn: aStream 342366 342367 (#(String) includes: self arrayClass name) 342368 ifTrue: [^self storeOn: aStream]. 342369 ^super printOn: aStream 342370! ! 342371 342372!SparseLargeTable methodsFor: 'printing' stamp: 'yo 12/1/2003 15:59'! 342373storeOn: aStream 342374 342375 | x | 342376 (#(String) includes: self arrayClass name) ifTrue: 342377 [aStream nextPut: $'. 342378 1 to: self size do: 342379 [:i | 342380 aStream nextPut: (x := self at: i). 342381 x == $' ifTrue: [aStream nextPut: x]]. 342382 aStream nextPutAll: ''' asLargeArrayChunkSize: '. 342383 aStream nextPutAll: self chunkSize asString. 342384 ^self]. 342385 ^super storeOn: aStream 342386! ! 342387 342388 342389!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 18:58'! 342390allDefaultValueSubtableAt: index 342391 342392 | t | 342393 t := self basicAt: index. 342394 t ifNil: [^ true]. 342395 t do: [:e | 342396 e ~= defaultValue ifTrue: [^ false]. 342397 ]. 342398 ^ true. 342399! ! 342400 342401!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 17:10'! 342402analyzeSpaceSaving 342403 342404 | total elems tablesTotal nonNilTables | 342405 total := size - base + 1. 342406 elems := 0. 342407 base to: size do: [:i | (self at: i) ~= defaultValue ifTrue: [elems := elems + 1]]. 342408 tablesTotal := self basicSize. 342409 nonNilTables := 0. 342410 1 to: self basicSize do: [:i | (self basicAt: i) ifNotNil: [nonNilTables := nonNilTables + 1]]. 342411 342412 ^ String streamContents: [:strm | 342413 strm nextPutAll: 'total: '. 342414 strm nextPutAll: total printString. 342415 strm nextPutAll: ' elements: '. 342416 strm nextPutAll: elems printString. 342417 strm nextPutAll: ' tables: '. 342418 strm nextPutAll: tablesTotal printString. 342419 strm nextPutAll: ' non-nil: '. 342420 strm nextPutAll: nonNilTables printString. 342421 ]. 342422 342423! ! 342424 342425!SparseLargeTable methodsFor: 'private' stamp: 'nk 8/31/2004 08:34'! 342426copyEmpty 342427 "Answer a copy of the receiver that contains no elements." 342428 ^self speciesNew: 0 342429! ! 342430 342431!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 22:34'! 342432findLastNonNilSubTable 342433 342434 (self basicAt: self basicSize) ifNotNil: [^ self basicSize]. 342435 342436 self basicSize - 1 to: 1 by: -1 do: [:lastIndex | 342437 (self basicAt: lastIndex) ifNotNil: [^ lastIndex]. 342438 ]. 342439 ^ 0. 342440! ! 342441 342442!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 19:19'! 342443privateSize: s 342444 342445 size := s. 342446! ! 342447 342448!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 17:34'! 342449pvtCheckIndex: index 342450 342451 index isInteger ifFalse: [self errorNonIntegerIndex]. 342452 index < 1 ifTrue: [self errorSubscriptBounds: index]. 342453 index > size ifTrue: [self errorSubscriptBounds: index]. 342454! ! 342455 342456!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 15:59'! 342457similarInstance 342458 342459 ^self class 342460 new: self size 342461 chunkSize: self chunkSize 342462 arrayClass: self arrayClass 342463! ! 342464 342465!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 15:59'! 342466similarInstance: newSize 342467 342468 ^self class 342469 new: newSize 342470 chunkSize: self chunkSize 342471 arrayClass: self arrayClass 342472! ! 342473 342474!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 15:59'! 342475similarSpeciesInstance 342476 342477 ^self similarInstance 342478! ! 342479 342480!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 16:00'! 342481similarSpeciesInstance: newSize 342482 342483 ^self similarInstance: newSize 342484! ! 342485 342486!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 16:00'! 342487speciesNew 342488 342489 ^self species 342490 new: self size 342491 chunkSize: self chunkSize 342492 arrayClass: self arrayClass 342493! ! 342494 342495!SparseLargeTable methodsFor: 'private' stamp: 'yo 12/1/2003 16:00'! 342496speciesNew: newSize 342497 342498 ^self species 342499 new: newSize 342500 chunkSize: self chunkSize 342501 arrayClass: self arrayClass 342502! ! 342503 342504"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 342505 342506SparseLargeTable class 342507 instanceVariableNames: ''! 342508 342509!SparseLargeTable class methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:54'! 342510defaultChunkSize 342511 342512 ^100! ! 342513 342514!SparseLargeTable class methodsFor: 'accessing' stamp: 'yo 12/1/2003 15:54'! 342515defaultChunkSizeForFiles 342516 342517 ^8000! ! 342518 342519 342520!SparseLargeTable class methodsFor: 'instance creation' stamp: 'yo 12/1/2003 16:06'! 342521new: size 342522 342523 ^self new: size chunkSize: self defaultChunkSize 342524! ! 342525 342526!SparseLargeTable class methodsFor: 'instance creation' stamp: 'yo 12/1/2003 16:07'! 342527new: size chunkSize: chunkSize 342528 342529 ^self new: size chunkSize: chunkSize arrayClass: Array 342530! ! 342531 342532!SparseLargeTable class methodsFor: 'instance creation' stamp: 'yo 12/1/2003 16:08'! 342533new: size chunkSize: chunkSize arrayClass: aClass 342534 342535 ^self new: size chunkSize: chunkSize arrayClass: Array base: 1. 342536! ! 342537 342538!SparseLargeTable class methodsFor: 'instance creation' stamp: 'yo 12/1/2003 16:37'! 342539new: size chunkSize: chunkSize arrayClass: aClass base: b 342540 342541 ^self new: size chunkSize: chunkSize arrayClass: Array base: 1 defaultValue: nil. 342542! ! 342543 342544!SparseLargeTable class methodsFor: 'instance creation' stamp: 'yo 12/1/2003 16:37'! 342545new: size chunkSize: chunkSize arrayClass: aClass base: b defaultValue: d 342546 342547 | basicSize | 342548 (basicSize := ((size - 1) // chunkSize) + 1) = 0 342549 ifTrue: [basicSize := 1]. 342550 ^(self basicNew: basicSize) 342551 initChunkSize: chunkSize size: size arrayClass: aClass base: b defaultValue: d; 342552 yourself 342553! ! 342554Object subclass: #SparseXTable 342555 instanceVariableNames: 'tables xTables' 342556 classVariableNames: '' 342557 poolDictionaries: '' 342558 category: 'Multilingual-Display'! 342559 342560!SparseXTable methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:12'! 342561tableFor: code 342562 342563 | div t table | 342564 div := code // 65536. 342565 t := xTables at: div ifAbsent: [table := Array new: 65536 withAll: 0. xTables at: div put: table. table]. 342566 ^ t. 342567! ! 342568Path subclass: #Spline 342569 instanceVariableNames: 'coefficients' 342570 classVariableNames: '' 342571 poolDictionaries: '' 342572 category: 'ST80-Paths'! 342573!Spline commentStamp: '<historical>' prior: 0! 342574I represent a collection of Points through which a cubic spline curve is fitted.! 342575 342576 342577!Spline methodsFor: 'accessing'! 342578coefficients 342579 "Answer an eight-element Array of Arrays each of which is the length 342580 of the receiver. The first four arrays are the values, first, second and 342581 third derivatives, respectively, for the parametric spline in x. The last 342582 four elements are for y." 342583 342584 ^coefficients! ! 342585 342586 342587!Spline methodsFor: 'displaying'! 342588computeCurve 342589 "Compute an array for the coefficients." 342590 342591 | length extras | 342592 length := self size. 342593 extras := 0. 342594 coefficients := Array new: 8. 342595 1 to: 8 do: [:i | coefficients at: i put: (Array new: length + extras)]. 342596 1 to: 5 by: 4 do: 342597 [:k | 342598 1 to: length do: 342599 [:i | (coefficients at: k) 342600 at: i put: (k = 1 342601 ifTrue: [(self at: i) x asFloat] 342602 ifFalse: [(self at: i) y asFloat])]. 342603 1 to: extras do: [:i | (coefficients at: k) 342604 at: length + i put: ((coefficients at: k) 342605 at: i + 1)]. 342606 self derivs: (coefficients at: k) 342607 first: (coefficients at: k + 1) 342608 second: (coefficients at: k + 2) 342609 third: (coefficients at: k + 3)]. 342610 extras > 0 342611 ifTrue: [1 to: 8 do: 342612 [:i | 342613 coefficients at: i put: ((coefficients at: i) 342614 copyFrom: 2 to: length + 1)]]! ! 342615 342616!Spline methodsFor: 'displaying'! 342617displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm 342618 "Display the receiver, a spline curve, approximated by straight line 342619 segments." 342620 342621 | n line t x y x1 x2 x3 y1 y2 y3 | 342622 collectionOfPoints size < 1 ifTrue: [self error: 'a spline must have at least one point']. 342623 line := Line new. 342624 line form: self form. 342625 line beginPoint: 342626 (x := (coefficients at: 1) at: 1) rounded @ (y := (coefficients at: 5) at: 1) rounded. 342627 1 to: (coefficients at: 1) size - 1 do: 342628 [:i | 342629 "taylor series coefficients" 342630 x1 := (coefficients at: 2) at: i. 342631 y1 := (coefficients at: 6) at: i. 342632 x2 := ((coefficients at: 3) at: i) / 2.0. 342633 y2 := ((coefficients at: 7) at: i) / 2.0. 342634 x3 := ((coefficients at: 4) at: i) / 6.0. 342635 y3 := ((coefficients at: 8) at: i) / 6.0. 342636 "guess n" 342637 n := 5 max: (x2 abs + y2 abs * 2.0 + ((coefficients at: 3) 342638 at: i + 1) abs + ((coefficients at: 7) 342639 at: i + 1) abs / 100.0) rounded. 342640 1 to: n - 1 do: 342641 [:j | 342642 t := j asFloat / n. 342643 line endPoint: 342644 (x3 * t + x2 * t + x1 * t + x) rounded 342645 @ (y3 * t + y2 * t + y1 * t + y) rounded. 342646 line 342647 displayOn: aDisplayMedium 342648 at: aPoint 342649 clippingBox: clipRect 342650 rule: anInteger 342651 fillColor: aForm. 342652 line beginPoint: line endPoint]. 342653 line beginPoint: 342654 (x := (coefficients at: 1) at: i + 1) rounded 342655 @ (y := (coefficients at: 5) at: i + 1) rounded. 342656 line 342657 displayOn: aDisplayMedium 342658 at: aPoint 342659 clippingBox: clipRect 342660 rule: anInteger 342661 fillColor: aForm]! ! 342662 342663!Spline methodsFor: 'displaying'! 342664displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm 342665 "Get the scaled and translated path of newKnots." 342666 342667 | newKnots newSpline | 342668 newKnots := aTransformation applyTo: self. 342669 newSpline := Spline new. 342670 newKnots do: [:knot | newSpline add: knot]. 342671 newSpline form: self form. 342672 newSpline 342673 displayOn: aDisplayMedium 342674 at: 0 @ 0 342675 clippingBox: clipRect 342676 rule: anInteger 342677 fillColor: aForm! ! 342678 342679 342680!Spline methodsFor: 'private'! 342681derivs: a first: point1 second: point2 third: point3 342682 "Compute the first, second and third derivitives (in coefficients) from 342683 the Points in this Path (coefficients at: 1 and coefficients at: 5)." 342684 342685 | l v anArray | 342686 l := a size. 342687 l < 2 ifTrue: [^self]. 342688 l > 2 342689 ifTrue: 342690 [v := Array new: l. 342691 v at: 1 put: 4.0. 342692 anArray := Array new: l. 342693 anArray at: 1 put: (6.0 * ((a at: 1) - ((a at: 2) * 2.0) + (a at: 3))). 342694 2 to: l - 2 do: 342695 [:i | 342696 v at: i put: (4.0 - (1.0 / (v at: (i - 1)))). 342697 anArray 342698 at: i 342699 put: (6.0 * ((a at: i) - ((a at: (i + 1)) * 2.0) + (a at: (i + 2))) 342700 - ((anArray at: (i - 1)) / (v at: (i - 1))))]. 342701 point2 at: (l - 1) put: ((anArray at: (l - 2)) / (v at: (l - 2))). 342702 l - 2 to: 2 by: 0-1 do: 342703 [:i | 342704 point2 342705 at: i 342706 put: ((anArray at: (i - 1)) - (point2 at: (i + 1)) / (v at: (i - 1)))]]. 342707 point2 at: 1 put: (point2 at: l put: 0.0). 342708 1 to: l - 1 do: 342709 [:i | point1 342710 at: i 342711 put: ((a at: (i + 1)) - (a at: i) - 342712 ((point2 at: i) * 2.0 + (point2 at: (i + 1)) / 6.0)). 342713 point3 at: i put: ((point2 at: (i + 1)) - (point2 at: i))]! ! 342714 342715"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 342716 342717Spline class 342718 instanceVariableNames: ''! 342719 342720!Spline class methodsFor: 'examples' stamp: '6/8/97 13:55 di'! 342721example 342722 "Designate points on the Path by clicking the red button. Terminate by 342723 pressing any other button. A curve will be displayed, through the 342724 selected points, using a long black form." 342725 342726 | splineCurve aForm flag| 342727 aForm := Form extent: 2@2. 342728 aForm fillBlack. 342729 splineCurve := Spline new. 342730 splineCurve form: aForm. 342731 flag := true. 342732 [flag] whileTrue: 342733 [Sensor waitButton. 342734 Sensor redButtonPressed 342735 ifTrue: 342736 [splineCurve add: Sensor waitButton. 342737 Sensor waitNoButton. 342738 aForm displayOn: Display at: splineCurve last] 342739 ifFalse: [flag:=false]]. 342740 splineCurve computeCurve. 342741 splineCurve isEmpty 342742 ifFalse: [splineCurve displayOn: Display. 342743 Sensor waitNoButton]. 342744 342745 "Spline example"! ! 342746TestCase subclass: #SplitJoinTest 342747 instanceVariableNames: 'eg stringToSplit' 342748 classVariableNames: '' 342749 poolDictionaries: '' 342750 category: 'CollectionsTests-SplitJoin'! 342751!SplitJoinTest commentStamp: 'onierstrasz 4/12/2009 20:33' prior: 0! 342752"Evaluate me to view the SplitJoin documentation:" 342753 342754self showDocumentation 342755 342756"CHANGES LOG: 342757- merged implementations by Keith Hodges (Join) and Damiena Pollet 342758 and Oscar Nierstrasz (RubyShards) into SplitJoin package 342759- moved all extension methods to *splitjoin method category 342760- merged all tests into SplitJoinTest 342761- fixed protocol in SequenceableCollection to splitOn: and joinUsing: 342762 and split: join: for splitters and joiners 342763- added Object>>joinTo: aStream and SequenceableCollection>>joinTo: aStream 342764 to support joining of either sequences or sequences of sequences 342765- prepared some documentation 342766- added systematic tests for all split/join cases 342767- added Object>>join: 342768- prepared split/join tests for all 16 cases 342769- prepares split+join tests for 4 standard cases 342770- reviewed/merged old tests 342771- changed splitjoin tests to use different joiner 342772- added separate test for split+join=id cases 342773- adapted documentation -- join result type is type of joiner or array or string 342774- fix split tests to check result asOrderedCollection 342775- added split tests for OrderedCollection and SortedCollection 342776- new join: method for OrderedCollection and SortedCollection 342777 (uses appendTo: in Object and SequenceableCollection) 342778- reviewed all split: implementations -- removed unnecessary helper methods 342779- check boundary conditions -- split on empty sequence ... 342780"! 342781 342782 342783!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 19:22'! 342784testJoinArrayUsingArray 342785 self assert: ((1 to: 4) joinUsing: #(8 9)) 342786 equals: #(1 8 9 2 8 9 3 8 9 4)! ! 342787 342788!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/10/2009 23:14'! 342789testJoinArrayUsingChar 342790 self assert: ((1 to: 4) joinUsing: $:) 342791 equals: '1:2:3:4'! ! 342792 342793!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/11/2009 00:11'! 342794testJoinArrayUsingObject 342795 self assert: ((1 to: 4) joinUsing: 0) 342796 equals: #(1 0 2 0 3 0 4)! ! 342797 342798!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 19:23'! 342799testJoinArrayUsingOrderedCollection 342800 self assert: ((1 to: 4) joinUsing: #(8 9) asOrderedCollection) 342801 equals: #(1 8 9 2 8 9 3 8 9 4) asOrderedCollection! ! 342802 342803!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 19:46'! 342804testJoinArrayUsingSortedCollection 342805 self assert: ((1 to: 4) joinUsing: #(8 9) asSortedCollection) 342806 equals: #(1 8 9 2 8 9 3 8 9 4) asSortedCollection! ! 342807 342808!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/10/2009 23:14'! 342809testJoinArrayUsingString 342810 self assert: ((1 to: 4) joinUsing: '--') 342811 equals: '1--2--3--4'! ! 342812 342813!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/10/2009 23:15'! 342814testJoinStringUsingChar 342815 self assert: ('splitjoin' joinUsing: $-) 342816 equals: 's-p-l-i-t-j-o-i-n'! ! 342817 342818!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/10/2009 23:17'! 342819testJoinStringUsingString 342820 self assert: ('bda' joinUsing: 'an') 342821 equals: 'bandana'! ! 342822 342823!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/10/2009 23:17'! 342824testJoinUsingLastOnArray 342825 self assert: ((1 to: 4) joinUsing: ', ' last: ' and ') 342826 equals: '1, 2, 3 and 4'! ! 342827 342828!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/10/2009 22:38'! 342829testJoinUsingLastOnArrayOfStrings 342830 self 342831 assert: (#('Squeak is modern' 'open source' 'highly portable' 'fast' 'full-featured' ) joinUsing: ', ' last: ' and ') 342832 equals: 'Squeak is modern, open source, highly portable, fast and full-featured'! ! 342833 342834!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 19:24'! 342835testSplitArrayOnBlock 342836 self assert: ((1 to: 10) asArray splitOn: [:n| n even]) 342837 equals: #(#(1) #(3) #(5) #(7) #(9) #()) asOrderedCollection! ! 342838 342839!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 19:24'! 342840testSplitArrayOnElement 342841 self assert: ((1 to: 10) asArray splitOn: 4) 342842 equals: #(#(1 2 3) #(5 6 7 8 9 10)) asOrderedCollection 342843! ! 342844 342845!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 19:25'! 342846testSplitArrayOnSequence 342847 self assert: ((1 to: 10) asArray splitOn: (4 to: 5)) 342848 equals: #(#(1 2 3) #(6 7 8 9 10)) asOrderedCollection 342849! ! 342850 342851!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 20:32'! 342852testSplitJoinBoundaryCases 342853 "Empty splitter, joiner or sequence." 342854 self assert: (#() join: (#() split: #())) equals: #(). 342855 self assert: ('' join: ('' split: '')) equals: ''. 342856 self assert: ('' join: ('.' asRegex split: '')) equals: ''. "NB: Doesn't work with empty regex" 342857 342858 "Overlapping splitters, or at end of sequence" 342859 self assert: ('an' join: ('an' split: 'banana')) equals: 'banana'. 342860 self assert: ('na' join: ('na' split: 'banana')) equals: 'banana'. 342861 self assert: ('ana' join: ('ana' split: 'banana')) equals: 'banana'. 342862! ! 342863 342864!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 20:07'! 342865testSplitJoinIdentity 342866 | array string | 342867 array := #(5 1 4 1 3 1 2 1). 342868 string := 'how now brown cow'. 342869 self assert: (1 join: (1 split: array)) equals: array. 342870 self assert: (#(1 3) join: (#(1 3) split: array)) equals: array. 342871 self assert: ($o join: ($o split: string)) equals: string. 342872 self assert: ('ow' join: ('ow' split: string)) equals: string.! ! 342873 342874!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/11/2009 10:31'! 342875testSplitJoinOnElement 342876 self assert: (0 join: (3 split: #(1 2 3 4 5))) 342877 equals: #(1 2 0 4 5)! ! 342878 342879!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/11/2009 10:33'! 342880testSplitJoinOnSequence 342881 self assert: (#(6 6 6) join: (#(3 4) split: #(1 2 3 4 5))) 342882 equals: #(1 2 6 6 6 5)! ! 342883 342884!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/11/2009 10:32'! 342885testSplitJoinStringOnChar 342886 self assert: ($: join: (Character space split: 'how now brown cow?')) 342887 equals: 'how:now:brown:cow?'! ! 342888 342889!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/11/2009 10:36'! 342890testSplitJoinStringOnString 342891 self assert: ('oo' join: ('ow' split: 'how now brown cow?')) 342892 equals: 'hoo noo broon coo?'! ! 342893 342894!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 19:26'! 342895testSplitOrderedCollectionOnElement 342896 self assert: (((1 to: 10) asOrderedCollection) splitOn: 4) 342897 equals: {(1 to: 3) asOrderedCollection . (5 to: 10) asOrderedCollection} asOrderedCollection. 342898! ! 342899 342900!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 19:26'! 342901testSplitOrderedCollectionOnOrderedCollection 342902 self assert: (((1 to: 10) asOrderedCollection) splitOn: ((4 to: 5) asOrderedCollection)) 342903 equals: {(1 to: 3) asOrderedCollection . (6 to: 10) asOrderedCollection} asOrderedCollection. 342904! ! 342905 342906!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 19:27'! 342907testSplitSortedCollectionOnElement 342908 self assert: (((1 to: 10) asSortedCollection) splitOn: 4) 342909 equals: {(1 to: 3) asSortedCollection . (5 to: 10) asSortedCollection} asOrderedCollection. 342910! ! 342911 342912!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 19:26'! 342913testSplitSortedCollectionOnSortedCollection 342914 self assert: (((1 to: 10) asSortedCollection) splitOn: ((4 to: 5) asSortedCollection)) 342915 equals: {(1 to: 3) asSortedCollection . (6 to: 10) asSortedCollection} asOrderedCollection. 342916 342917! ! 342918 342919!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 18:52'! 342920testSplitStringOnBlock 342921 self assert: ('foobar' splitOn: [:ch | 'aeiou' includes: ch]) 342922 equals: #('f' '' 'b' 'r') asOrderedCollection! ! 342923 342924!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 18:53'! 342925testSplitStringOnChar 342926 self assert: ('does eat oats and lambs eat oats' splitOn: Character space) 342927 equals: #('does' 'eat' 'oats' 'and' 'lambs' 'eat' 'oats') asOrderedCollection! ! 342928 342929!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 18:53'! 342930testSplitStringOnRegex 342931 self assert: ('foobar' splitOn: '[aeiou]+' asRegex) 342932 equals: #('f' 'b' 'r') asOrderedCollection! ! 342933 342934!SplitJoinTest methodsFor: 'running' stamp: 'onierstrasz 4/12/2009 18:53'! 342935testSplitStringOnSubstring 342936 self assert: ('the banana man can can bananas' splitOn: 'an') 342937 equals: #('the b' '' 'a m' ' c' ' c' ' b' '' 'as') asOrderedCollection! ! 342938 342939 342940!SplitJoinTest methodsFor: 'testing' stamp: 'onierstrasz 4/10/2009 21:09'! 342941assert: result equals: expected 342942 result = expected 342943 ifFalse: [self signalFailure: 'Assertion failed: (' , result asString , ') ~= (' , expected asString , ')']! ! 342944 342945"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 342946 342947SplitJoinTest class 342948 instanceVariableNames: ''! 342949 342950!SplitJoinTest class methodsFor: 'documentation' stamp: 'onierstrasz 4/11/2009 14:19'! 342951documentation 342952 <ignoreForCoverage> 342953 "self showDocumentation" 342954 342955 ^ '"This package provides functionality for splitting and joining strings similarly to that offered by Perl, Python and Ruby. In addition, split and join work for any kind of sequence, and offer the possibility to split strings using regular expressions. 342956 342957Suppose object A is a SequenceableCollection of elements of type T (let''s call its type S[T]), and B is a splitter of type either T or S[T]. Then A splitOn: B yields an object C of type OC[S[T]] (OC=OrderedCollection). B can be either an element or a subsequence, so:" 342958 342959 ''abracadabra'' splitOn: $b. 342960 "-> an OrderedCollection(''a'' ''racada'' ''ra'')" 342961 342962 ''abracadabra'' splitOn: ''ca''. 342963 "-> an OrderedCollection(''abra'' ''dabra'')" 342964 342965"A splitOn: B is the same as B split: A, so:" 342966 342967 ''ab'' split: ''abracadabra''. 342968 "-> an OrderedCollection('''' ''racad'' ''ra'')" 342969 342970"joinUsing: and join: are the inverse of splitOn: and split:. You may use either of the forms: 342971 C joinUsing: B 342972or: 342973 B join: C 342974The result is normally the same type as the joiner. If the joiner (B) is of type S[T] and C is of type OC[S[T]] or Array[S[T]], the result is also of type S[T]. For example:" 342975 342976 '' loves '' join: #(''john'' ''jane'' ''jack''). 342977 "-> ''john loves jane loves jack''" 342978 342979"An object that is not a sequence can also be used as a joiner, in which case the final result is an array. Also the collection being joined may contain elements that are not sequences, in which case they are treated as singleton arrays." 342980 342981 1 join: ''hello''. 342982 "-> #($h 1 $e 1 $l 1 $l 1 $o)" 342983 342984"Note that in the case of characters and strings being used as joiners, the result is always a string." 342985 342986"In general: 342987 ((A splitOn: B) joinUsing: B) = A 342988or: 342989 (B join: (B split: A)) = A 342990so:" 342991 342992 (''r'' join: (''r'' split: ''abracadabra'')) = ''abracadabra''. 342993 "-> true" 342994 342995"Although the main application is for Strings, split and join will work for any kinds of SequenceableCollections, including Arrays and Intervals." 342996 342997 [:n | n isPrime] split: (2 to: 20). 342998 "-> an OrderedCollection(#() #() #(4) #(6) #(8 9 10) #(12) #(14 15 16) #(18) #(20))" 342999 343000"In addition, the following special cases are supported: 343001 343002- split an S[T] using a block of type T->Boolean:" 343003 343004 ''abracadabra'' splitOn: [:x | ''bc'' includes: x]. 343005 "-> an OrderedCollection(''a'' ''ra'' ''ada'' ''ra'')" 343006 343007"- split a String using a regex:" 343008 343009 ''abracadabra'' splitOn: ''[bcdr]+'' asRegex. 343010 "-> an OrderedCollection(''a'' ''a'' ''a'' ''a'' ''a'')" 343011 343012"- join all elements of an S[T] yielding another S[T]: '' ''- " 343013 343014 ''abracadabra'' joinUsing: '':''. 343015 " -> ''a:b:r:a:c:a:d:a:b:r:a''" 343016 343017"Note that in these cases the rule that (B join: (B split: A)) = A does not hold, either because B maps to different elements, or because there is no A to start with." 343018 343019 $: join: (1 to: 4). 343020 "-> ''1:2:3:4''" 343021 343022"Finally, there is the convenient utility method joinUsing:last:, used as follows:" 343023 343024 (1 to: 5) joinUsing: '', '' last: '' and ''. 343025 "-> ''1, 2, 3, 4 and 5''" 343026 343027"This package merges and generalizes functionality from the Join package by Keith Hodges and the RubyShards package by Damien Pollet and Oscar Nierstrasz. " 343028'! ! 343029 343030!SplitJoinTest class methodsFor: 'documentation' stamp: 'pavel.krivanek 7/6/2009 13:09'! 343031showDocumentation 343032 <ignoreForCoverage> 343033 Workspace new contents: self documentation; openLabel: 'SplitJoin Documentation'.! ! 343034 343035 343036!SplitJoinTest class methodsFor: 'sunitgui' stamp: 'onierstrasz 4/12/2009 18:50'! 343037packageNamesUnderTest 343038 <ignoreForCoverage> 343039 ^ #('SplitJoin')! ! 343040Object subclass: #SqNumberParser 343041 instanceVariableNames: 'sourceStream base neg integerPart fractionPart exponent scale nDigits lastNonZero requestor failBlock' 343042 classVariableNames: 'BelllerophonBase10' 343043 poolDictionaries: '' 343044 category: 'Kernel-Numbers'! 343045!SqNumberParser commentStamp: 'nice 4/27/2006 22:38' prior: 0! 343046This is a class specialized in parsing and building numbers. 343047Number syntax should follow Smalltalk syntax. 343048 343049If you have to read foreign number syntax, create a subclass.! 343050 343051 343052!SqNumberParser methodsFor: 'accessing' stamp: 'nice 4/27/2006 22:57'! 343053exponentLetters 343054 "answer the list of possible exponents for Numbers. 343055 Note: this parser will not honour precision attached to the exponent. 343056 different exponent do not lead to different precisions. 343057 only IEEE 754 floating point numbers will be created" 343058 343059 ^'edq'! ! 343060 343061!SqNumberParser methodsFor: 'accessing' stamp: 'nice 5/1/2006 01:58'! 343062failBlock: aBlockOrNil 343063 failBlock := aBlockOrNil! ! 343064 343065!SqNumberParser methodsFor: 'accessing' stamp: 'nice 5/1/2006 01:59'! 343066requestor: anObjectOrNil 343067 requestor := anObjectOrNil! ! 343068 343069 343070!SqNumberParser methodsFor: 'error' stamp: 'nice 4/28/2006 00:20'! 343071expected: errorString 343072 requestor isNil 343073 ifFalse: [requestor 343074 notify: errorString , ' ->' 343075 at: sourceStream position 343076 in: sourceStream]. 343077 self fail! ! 343078 343079!SqNumberParser methodsFor: 'error' stamp: 'NikoSchwarz 10/17/2009 10:45'! 343080fail 343081 failBlock ifNotNil: [^failBlock value]. 343082 self error: 'Reading a number failed'! ! 343083 343084 343085!SqNumberParser methodsFor: 'initialize-release' stamp: 'damiencassou 5/30/2008 10:56'! 343086on: aStringOrStream 343087 sourceStream := aStringOrStream isString 343088 ifTrue: [ aStringOrStream readStream ] 343089 ifFalse: [ aStringOrStream ]. 343090 base := 10. 343091 neg := false. 343092 integerPart := fractionPart := exponent := scale := 0. 343093 requestor := failBlock := nil! ! 343094 343095 343096!SqNumberParser methodsFor: 'parsing-large int' stamp: 'nice 8/31/2008 23:00'! 343097nextElementaryLargeIntegerBase: aRadix 343098 "Form an unsigned integer with incoming digits from sourceStream. 343099 Return this integer, or zero if no digits found. 343100 Stop reading if end of digits or if a LargeInteger is formed. 343101 Count the number of digits and the position of lastNonZero digit and store them in instVar" 343102 343103 | value digit | 343104 value := 0. 343105 nDigits := 0. 343106 lastNonZero := 0. 343107 aRadix <= 10 343108 ifTrue: ["Avoid using digitValue which is awfully slow" 343109 [value isLarge or: [sourceStream atEnd 343110 or: [digit := sourceStream next charCode - 48. 343111 (0 > digit 343112 or: [digit >= aRadix]) 343113 and: [sourceStream skip: -1. 343114 true]]]] 343115 whileFalse: [nDigits := nDigits + 1. 343116 0 = digit 343117 ifFalse: [lastNonZero := nDigits]. 343118 value := value * aRadix + digit]] 343119 ifFalse: [ 343120 [value isLarge or: [sourceStream atEnd 343121 or: [digit := sourceStream next digitValue. 343122 (0 > digit 343123 or: [digit >= aRadix]) 343124 and: [sourceStream skip: -1. 343125 true]]]] 343126 whileFalse: [nDigits := nDigits + 1. 343127 0 = digit 343128 ifFalse: [lastNonZero := nDigits]. 343129 value := value * aRadix + digit]]. 343130 ^value! ! 343131 343132!SqNumberParser methodsFor: 'parsing-large int' stamp: 'nice 7/26/2009 00:24'! 343133nextLargeIntegerBase: aRadix nPackets: nPackets 343134 "Form a Large integer with incoming digits from sourceStream. 343135 Return this integer, or zero if no digits found. 343136 Stop reading when no more digits or when nPackets elementary LargeInteger have been encountered. 343137 Count the number of digits and the lastNonZero digit and store them in instVar" 343138 343139 | high nDigitsHigh low nDigitsLow halfPackets | 343140 halfPackets := nPackets bitShift: -1. 343141 halfPackets = 0 ifTrue: [^self nextElementaryLargeIntegerBase: aRadix]. 343142 high := self nextLargeIntegerBase: aRadix nPackets: halfPackets. 343143 high isLarge ifFalse: [^high]. 343144 nDigitsHigh := nDigits. 343145 low := self nextLargeIntegerBase: aRadix nPackets: halfPackets. 343146 nDigitsLow := nDigits. 343147 nDigits := nDigitsHigh + nDigitsLow. 343148 lastNonZero = 0 ifFalse: [lastNonZero := lastNonZero + nDigitsHigh]. 343149 ^high * (aRadix raisedToInteger: nDigitsLow) + low! ! 343150 343151 343152!SqNumberParser methodsFor: 'parsing-private' stamp: 'nice 7/26/2009 00:22'! 343153makeFloatFromMantissa: m exponent: k base: aRadix 343154 "Convert infinite precision arithmetic into Floating point. 343155 This alogrithm rely on correct IEEE rounding mode 343156 being implemented in Integer>>asFloat and Fraction>>asFloat" 343157 343158 ^(k positive 343159 ifTrue: [m * (aRadix raisedToInteger: k)] 343160 ifFalse: [Fraction numerator: m denominator: (aRadix raisedToInteger: k negated)]) asFloat! ! 343161 343162!SqNumberParser methodsFor: 'parsing-private' stamp: 'nice 10/7/2009 01:30'! 343163makeIntegerOrScaledInteger 343164 "at this point, there is no digit, nor fractionPart. 343165 maybe it can be a scaled decimal with fraction omitted..." 343166 343167 neg 343168 ifTrue: [integerPart := integerPart negated]. 343169 self readExponent 343170 ifTrue: [^integerPart * (base raisedToInteger: exponent)]. 343171 self readScale 343172 ifTrue: [^integerPart asScaledDecimal: scale]. 343173 ^ integerPart! ! 343174 343175!SqNumberParser methodsFor: 'parsing-private' stamp: 'nice 10/7/2009 01:40'! 343176makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart 343177 "at this point integerPart fractionPart and scale have been read out (in inst var). 343178 Form a ScaledDecimal. 343179 Care of eliminating trailing zeroes from the fractionPart" 343180 343181 | decimalMultiplier decimalFraction | 343182 decimalMultiplier := base raisedToInteger: numberOfNonZeroFractionDigits. 343183 decimalFraction := integerPart * decimalMultiplier + (fractionPart // (base raisedTo: numberOfTrailingZeroInFractionPart)) / decimalMultiplier. 343184 neg 343185 ifTrue: [decimalFraction := decimalFraction negated]. 343186 ^decimalFraction asScaledDecimal: scale! ! 343187 343188!SqNumberParser methodsFor: 'parsing-private' stamp: 'nice 7/26/2009 00:04'! 343189readExponent 343190 "read the exponent if any (stored in instVar). 343191 Answer true if found, answer false if none. 343192 If exponent letter is not followed by a digit, 343193 this is not considered as an error. 343194 Exponent are always read in base 10." 343195 343196 | eneg | 343197 exponent := 0. 343198 sourceStream atEnd ifTrue: [^ false]. 343199 (self exponentLetters includes: sourceStream peek) 343200 ifFalse: [^ false]. 343201 sourceStream next. 343202 eneg := sourceStream peekFor: $-. 343203 exponent := self nextUnsignedIntegerOrNilBase: 10. 343204 exponent ifNil: ["Oops, there was no digit after the exponent letter.Ungobble the letter" 343205 exponent := 0. 343206 sourceStream 343207 skip: (eneg 343208 ifTrue: [-2] 343209 ifFalse: [-1]). 343210 ^ false]. 343211 eneg 343212 ifTrue: [exponent := exponent negated]. 343213 ^ true! ! 343214 343215!SqNumberParser methodsFor: 'parsing-private' stamp: 'nice 10/16/2008 00:24'! 343216readNamedFloatOrFail 343217 "This method is used when there is no digit encountered: 343218 It try and read a named Float NaN or Infinity. 343219 Negative sign for -Infinity has been read before sending this method, and is indicated in the neg inst.var. 343220 Fail if no named Float is found" 343221 343222 neg ifFalse: [(sourceStream nextMatchAll: 'NaN') 343223 ifTrue: [^ Float nan]]. 343224 (sourceStream nextMatchAll: 'Infinity') 343225 ifTrue: [^ neg 343226 ifTrue: [Float infinity negated] 343227 ifFalse: [Float infinity]]. 343228 ^self expected: ['a digit between 0 and ' , (Character digitValue: base - 1)]! ! 343229 343230!SqNumberParser methodsFor: 'parsing-private' stamp: 'nice 7/26/2009 00:45'! 343231readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart 343232 "at this stage, sign integerPart and a decimal point have been read. 343233 try and form a number with a fractionPart" 343234 343235 | numberOfNonZeroFractionDigits numberOfTrailingZeroInFractionPart mantissa value | 343236 fractionPart := self nextUnsignedIntegerOrNilBase: base. 343237 fractionPart ifNil: ["No fractionPart found,ungobble the decimal point and return the integerPart" 343238 sourceStream skip: -1. 343239 ^ neg 343240 ifTrue: [integerPart negated] 343241 ifFalse: [integerPart]]. 343242 numberOfNonZeroFractionDigits := lastNonZero. 343243 numberOfTrailingZeroInFractionPart := nDigits - lastNonZero. 343244 self readExponent 343245 ifFalse: [self readScale 343246 ifTrue: [^self makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits 343247 andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart]]. 343248 343249 fractionPart isZero 343250 ifTrue: [mantissa := integerPart 343251 // (base raisedToInteger: numberOfTrailingZeroInIntegerPart). 343252 exponent := exponent + numberOfTrailingZeroInIntegerPart] 343253 ifFalse: [mantissa := integerPart 343254 * (base raisedToInteger: numberOfNonZeroFractionDigits) + (fractionPart // (base raisedToInteger: numberOfTrailingZeroInFractionPart)). 343255 exponent := exponent - numberOfNonZeroFractionDigits]. 343256 343257 value := self makeFloatFromMantissa: mantissa exponent: exponent base: base. 343258 ^ neg 343259 ifTrue: [value isZero 343260 ifTrue: [Float negativeZero] 343261 ifFalse: [value negated]] 343262 ifFalse: [value]! ! 343263 343264!SqNumberParser methodsFor: 'parsing-private' stamp: 'nice 10/16/2008 02:17'! 343265readScale 343266 "read the scale if any (stored in instVar). 343267 Answer true if found, answer false if none. 343268 If scale letter is not followed by a digit, this is not considered as an error. 343269 Scales are always read in base 10, though i do not see why..." 343270 343271 scale := 0. 343272 sourceStream atEnd ifTrue: [^ false]. 343273 (sourceStream peekFor: $s) 343274 ifFalse: [^ false]. 343275 scale := self nextUnsignedIntegerOrNilBase: 10. 343276 scale ifNil: [ 343277 scale := 0. 343278 sourceStream skip: -1. "ungobble the s" 343279 ^ false]. 343280 ^ true! ! 343281 343282 343283!SqNumberParser methodsFor: 'parsing-public' stamp: 'nice 10/16/2008 01:07'! 343284nextIntegerBase: aRadix 343285 "Form an integer with following digits. 343286 Fail if no digit found" 343287 343288 | isNeg value | 343289 isNeg := sourceStream peekFor: $-. 343290 value := self nextUnsignedIntegerBase: aRadix. 343291 ^isNeg 343292 ifTrue: [value negated] 343293 ifFalse: [value]! ! 343294 343295!SqNumberParser methodsFor: 'parsing-public' stamp: 'nice 10/16/2008 00:49'! 343296nextIntegerBase: aRadix ifFail: aBlock 343297 "Form an integer with following digits" 343298 343299 | isNeg value | 343300 isNeg := sourceStream peekFor: $-. 343301 value := self nextUnsignedIntegerOrNilBase: aRadix. 343302 value isNil ifTrue: [^aBlock value]. 343303 ^isNeg 343304 ifTrue: [value negated] 343305 ifFalse: [value]! ! 343306 343307!SqNumberParser methodsFor: 'parsing-public' stamp: 'nice 10/16/2008 00:49'! 343308nextNumber 343309 "main method for reading a number. 343310 This one can read Float Integer and ScaledDecimal" 343311 343312 | numberOfTrailingZeroInIntegerPart | 343313 base := 10. 343314 neg := sourceStream peekFor: $-. 343315 integerPart := self nextUnsignedIntegerOrNilBase: base. 343316 integerPart ifNil: [ 343317 "This is not a regular number beginning with a digit 343318 It is time to check for exceptional condition NaN and Infinity" 343319 ^self readNamedFloatOrFail]. 343320 numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero. 343321 (sourceStream peekFor: $r) 343322 ifTrue: ["<base>r<integer>" 343323 (base := integerPart) < 2 343324 ifTrue: [^ self expected: 'an integer greater than 1 as valid radix']. 343325 (sourceStream peekFor: $-) 343326 ifTrue: [neg := neg not]. 343327 integerPart := self nextUnsignedIntegerBase: base. 343328 numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero]. 343329 ^ (sourceStream peekFor: $.) 343330 ifTrue: [self readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart] 343331 ifFalse: [self makeIntegerOrScaledInteger]! ! 343332 343333!SqNumberParser methodsFor: 'parsing-public' stamp: 'nice 10/16/2008 00:50'! 343334nextNumberBase: b 343335 "Method for reading a number without radix prefix. 343336 This one can read Float Integer and ScaledDecimal" 343337 343338 | numberOfTrailingZeroInIntegerPart | 343339 base := b. 343340 neg := sourceStream peekFor: $-. 343341 integerPart := self nextUnsignedIntegerOrNilBase: base. 343342 integerPart ifNil: [ 343343 "This is not a regular number beginning with a digit 343344 It is time to check for exceptional condition NaN and Infinity" 343345 ^self readNamedFloatOrFail]. 343346 numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero. 343347 ^ (sourceStream peekFor: $.) 343348 ifTrue: [self readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart] 343349 ifFalse: [self makeIntegerOrScaledInteger]! ! 343350 343351!SqNumberParser methodsFor: 'parsing-public' stamp: 'nice 10/16/2008 00:51'! 343352nextScaledDecimal 343353 "Main method for reading a (scaled) decimal number. 343354 Good Gracious, do not accept a decimal in another base than 10!! 343355 In other words, do not accept radix notation like 2r1.1, even not 10r5.3 343356 Do not accept exponent notation neither, like 1.0e-3" 343357 343358 | numberOfNonZeroFractionDigits numberOfTrailingZeroInFractionPart | 343359 base := 10. 343360 neg := sourceStream peekFor: $-. 343361 integerPart := self nextUnsignedIntegerBase: base. 343362 (sourceStream peekFor: $.) 343363 ifTrue: [fractionPart := self nextUnsignedIntegerOrNilBase: base. 343364 fractionPart ifNil: ["Oops, the decimal point seems not part of this number" 343365 sourceStream skip: -1. 343366 ^ neg 343367 ifTrue: [integerPart negated asScaledDecimal: 0] 343368 ifFalse: [integerPart asScaledDecimal: 0]]. 343369 numberOfNonZeroFractionDigits := lastNonZero. 343370 numberOfTrailingZeroInFractionPart := nDigits - lastNonZero. 343371 self readScale 343372 ifFalse: ["No scale were provided. use number of digits after decimal point as scale" 343373 scale := nDigits]. 343374 ^self makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart]. 343375 self readScale. 343376 neg ifTrue: [integerPart := integerPart negated]. 343377 ^integerPart asScaledDecimal: scale! ! 343378 343379!SqNumberParser methodsFor: 'parsing-public' stamp: 'nice 10/16/2008 01:05'! 343380nextUnsignedIntegerBase: aRadix 343381 "Form an unsigned integer with incoming digits from sourceStream. 343382 Fail if no digit found. 343383 Count the number of digits and the lastNonZero digit and store int in instVar " 343384 343385 | value | 343386 value := self nextUnsignedIntegerOrNilBase: aRadix. 343387 value ifNil: [^self expected: ('a digit between 0 and ' copyWith: (Character digitValue: aRadix - 1))]. 343388 ^value! ! 343389 343390!SqNumberParser methodsFor: 'parsing-public' stamp: 'nice 10/16/2008 01:05'! 343391nextUnsignedIntegerBase: aRadix ifFail: errorBlock 343392 "Form an unsigned integer with incoming digits from sourceStream. 343393 Answer this integer, or execute errorBlock if no digit found. 343394 Count the number of digits and the position of lastNonZero digit and store them in instVar" 343395 343396 | value | 343397 value := self nextUnsignedIntegerOrNilBase: aRadix. 343398 value ifNil: [^errorBlock value]. 343399 ^value! ! 343400 343401!SqNumberParser methodsFor: 'parsing-public' stamp: 'nice 7/26/2009 00:21'! 343402nextUnsignedIntegerOrNilBase: aRadix 343403 "Form an unsigned integer with incoming digits from sourceStream. 343404 Answer this integer, or nil if no digit found. 343405 Count the number of digits and the position of lastNonZero digit and store them in instVar" 343406 343407 | nPackets high nDigitsHigh lastNonZeroHigh low | 343408 "read no more digits than one elementary LargeInteger" 343409 high := self nextElementaryLargeIntegerBase: aRadix. 343410 nDigits = 0 ifTrue: [^nil]. 343411 343412 "Not enough digits to form a LargeInteger, stop iteration" 343413 high isLarge ifFalse: [^high]. 343414 343415 "We now have to engage arithmetic with LargeInteger 343416 Decompose the integer in a high and low packets of growing size:" 343417 nPackets := 1. 343418 nDigitsHigh := nDigits. 343419 lastNonZeroHigh := lastNonZero. 343420 [ 343421 low := self nextLargeIntegerBase: aRadix nPackets: nPackets . 343422 high := high * (aRadix raisedToInteger: nDigits) + low. 343423 lastNonZero = 0 ifFalse: [lastNonZeroHigh := lastNonZero + nDigitsHigh]. 343424 nDigitsHigh := nDigitsHigh + nDigits. 343425 low isLarge] 343426 whileTrue: [nPackets := nPackets * 2]. 343427 343428 nDigits := nDigitsHigh. 343429 lastNonZero := lastNonZeroHigh. 343430 ^high! ! 343431 343432"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 343433 343434SqNumberParser class 343435 instanceVariableNames: ''! 343436 343437!SqNumberParser class methodsFor: 'instance creation' stamp: 'nice 5/1/2006 00:45'! 343438on: aStringOrStream 343439 ^self new on: aStringOrStream! ! 343440 343441!SqNumberParser class methodsFor: 'instance creation' stamp: 'nice 5/1/2006 02:02'! 343442parse: aStringOrStream 343443 ^(self new) 343444 on: aStringOrStream; 343445 nextNumber! ! 343446 343447!SqNumberParser class methodsFor: 'instance creation' stamp: 'nice 5/1/2006 02:02'! 343448parse: aStringOrStream onError: failBlock 343449 ^(self new) 343450 on: aStringOrStream; 343451 failBlock: failBlock; 343452 nextNumber! ! 343453ClassTestCase subclass: #SqNumberParserTest 343454 instanceVariableNames: '' 343455 classVariableNames: '' 343456 poolDictionaries: '' 343457 category: 'KernelTests-Numbers'! 343458!SqNumberParserTest commentStamp: 'nice 5/7/2006 17:54' prior: 0! 343459Provide tests for new clas aimed at parsing numbers. 343460 343461It duplicates NumberParsingTest, with few more tests.! 343462 343463 343464!SqNumberParserTest methodsFor: 'tests - Float' stamp: 'nice 5/7/2006 17:46'! 343465testFloatFromStreamAsNumber 343466 "This covers parsing in Number>>readFrom:" 343467 343468 | rs aFloat | 343469 rs := '10r-12.3456' readStream. 343470 aFloat := SqNumberParser parse: rs. 343471 self assert: -12.3456 = aFloat. 343472 self assert: rs atEnd. 343473 343474 rs := '10r-12.3456e2' readStream. 343475 aFloat := SqNumberParser parse: rs. 343476 self assert: -1234.56 = aFloat. 343477 self assert: rs atEnd. 343478 343479 rs := '10r-12.3456e2e2' readStream. 343480 aFloat := SqNumberParser parse: rs. 343481 self assert: -1234.56 = aFloat. 343482 self assert: rs upToEnd = 'e2'. 343483 343484 rs := '10r-12.3456d2' readStream. 343485 aFloat := SqNumberParser parse: rs. 343486 self assert: -1234.56 = aFloat. 343487 self assert: rs atEnd. 343488 343489 rs := '10r-12.3456q2' readStream. 343490 aFloat := SqNumberParser parse: rs. 343491 self assert: -1234.56 = aFloat. 343492 self assert: rs atEnd. 343493 343494 rs := '-12.3456q2' readStream. 343495 aFloat := SqNumberParser parse: rs. 343496 self assert: -1234.56 = aFloat. 343497 self assert: rs atEnd. 343498 343499 rs := '12.3456q2' readStream. 343500 aFloat := SqNumberParser parse: rs. 343501 self assert: 1234.56 = aFloat. 343502 self assert: rs atEnd. 343503 343504 rs := '12.3456z2' readStream. 343505 aFloat := SqNumberParser parse: rs. 343506 self assert: 12.3456 = aFloat. 343507 self assert: rs upToEnd = 'z2'. 343508! ! 343509 343510!SqNumberParserTest methodsFor: 'tests - Float' stamp: 'nice 5/7/2006 17:46'! 343511testFloatFromStreamWithExponent 343512 "This covers parsing in Number>>readFrom:" 343513 343514 | rs aFloat | 343515 rs := '1.0e-14' readStream. 343516 aFloat := SqNumberParser parse: rs. 343517 self assert: 1.0e-14 = aFloat. 343518 self assert: rs atEnd. 343519 343520 rs := '1.0e-14 1' readStream. 343521 aFloat := SqNumberParser parse: rs. 343522 self assert: 1.0e-14 = aFloat. 343523 self assert: rs upToEnd = ' 1'. 343524 343525 rs := '1.0e-14eee' readStream. 343526 aFloat := SqNumberParser parse: rs. 343527 self assert: 1.0e-14 = aFloat. 343528 self assert: rs upToEnd = 'eee'. 343529 343530 rs := '1.0e14e10' readStream. 343531 aFloat := SqNumberParser parse: rs. 343532 self assert: 1.0e14 = aFloat. 343533 self assert: rs upToEnd = 'e10'. 343534 343535 rs := '1.0e+14e' readStream. "Plus sign is not parseable" 343536 aFloat := SqNumberParser parse: rs. 343537 self assert: 1.0 = aFloat. 343538 self assert: rs upToEnd = 'e+14e'. 343539 343540 rs := '1.0e' readStream. 343541 aFloat := SqNumberParser parse: rs. 343542 self assert: 1.0 = aFloat. 343543 self assert: rs upToEnd = 'e'.! ! 343544 343545!SqNumberParserTest methodsFor: 'tests - Float' stamp: 'nice 8/31/2008 03:32'! 343546testFloatGradualUnderflow 343547 "Gradual underflow are tricky. 343548 This is a non regression test for http://bugs.squeak.org/view.php?id=6976" 343549 343550 | float trueFraction str | 343551 343552 "as a preamble, use a base 16 representation to avoid round off error and check that number parsing is correct" 343553 float := SqNumberParser parse: '16r2.D2593D58B4FC4e-256'. 343554 trueFraction := 16r2D2593D58B4FC4 / (16 raisedTo: 256+13). 343555 self assert: float asTrueFraction = trueFraction. 343556 self assert: float = trueFraction asFloat. 343557 343558 "now print in base 10" 343559 str := (String new: 32) writeStream. 343560 float absPrintExactlyOn: str base: 10. 343561 343562 "verify if SqNumberParser can read it back" 343563 self assert: (SqNumberParser parse: str contents) = float. ! ! 343564 343565!SqNumberParserTest methodsFor: 'tests - Float' stamp: 'nice 5/1/2006 00:40'! 343566testFloatPrintString 343567 "self debug: #testFloatPrintString" 343568 343569 | f r | 343570 f := Float basicNew: 2. 343571 r := Random new seed: 1234567. 343572 100 343573 timesRepeat: [f basicAt: 1 put: (r nextInt: 16r100000000)- 1. 343574 f basicAt: 2 put: (r nextInt: 16r100000000) - 1. 343575 #(2 8 10 16) 343576 do: [:base | | str | 343577 str := (String new: 64) writeStream. 343578 f negative ifTrue: [str nextPut: $-]. 343579 str print: base; nextPut: $r. 343580 f absPrintExactlyOn: str base: base. 343581 self assert: (SqNumberParser parse: str contents) = f]]. 343582 "test big num near infinity" 343583 10 343584 timesRepeat: [f basicAt: 1 put: 16r7FE00000 + ((r nextInt: 16r100000) - 1). 343585 f basicAt: 2 put: (r nextInt: 16r100000000) - 1. 343586 #(2 8 10 16) 343587 do: [:base | | str | 343588 str := (String new: 64) writeStream. 343589 f negative ifTrue: [str nextPut: $-]. 343590 str print: base; nextPut: $r. 343591 f absPrintExactlyOn: str base: base. 343592 self assert: (SqNumberParser parse: str contents) = f]]. 343593 "test infinitesimal (gradual underflow)" 343594 10 343595 timesRepeat: [f basicAt: 1 put: 0 + ((r nextInt: 16r100000) - 1). 343596 f basicAt: 2 put: (r nextInt: 16r100000000) - 1. 343597 #(2 8 10 16) 343598 do: [:base | | str | 343599 str := (String new: 64) writeStream. 343600 f negative ifTrue: [str nextPut: $-]. 343601 str print: base; nextPut: $r. 343602 f absPrintExactlyOn: str base: base. 343603 self assert: (SqNumberParser parse: str contents) = f]].! ! 343604 343605!SqNumberParserTest methodsFor: 'tests - Float' stamp: 'nice 5/1/2006 00:40'! 343606testFloatReadError 343607 "This covers parsing in Number>>readFrom:" 343608 343609 | rs num | 343610 rs := '1e' readStream. 343611 num := SqNumberParser parse: rs. 343612 self assert: 1 = num. 343613 self assert: rs upToEnd = 'e'. 343614 343615 rs := '1s' readStream. 343616 num := SqNumberParser parse: rs. 343617 self assert: 1 = num. 343618 self assert: rs upToEnd = 's'. 343619 343620 rs := '1.' readStream. 343621 num := SqNumberParser parse: rs. 343622 self assert: 1 = num. 343623 self assert: num isInteger. 343624 self assert: rs upToEnd = '.'. 343625 343626 rs := '' readStream. 343627 self should: [SqNumberParser parse: rs] raise: Error. 343628 343629 rs := 'foo' readStream. 343630 self should: [SqNumberParser parse: rs] raise: Error. 343631 343632 rs := 'radix' readStream. 343633 self should: [SqNumberParser parse: rs] raise: Error. 343634 343635 rs := '.e0' readStream. 343636 self should: [SqNumberParser parse: rs] raise: Error. 343637 343638 rs := '-.e0' readStream. 343639 self should: [SqNumberParser parse: rs] raise: Error. 343640 343641 rs := '--1' readStream. 343642 self should: [SqNumberParser parse: rs] raise: Error.! ! 343643 343644!SqNumberParserTest methodsFor: 'tests - Float' stamp: 'damiencassou 5/30/2008 11:09'! 343645testFloatReadWithRadix 343646 "This covers parsing in Number>>readFrom: 343647 Note: In most Smalltalk dialects, the radix notation is not used for numbers 343648 with exponents. In Squeak, a string with radix and exponent can be parsed, 343649 and the exponent is always treated as base 10 (not the base indicated in the 343650 radix prefix). I am not sure if this is a feature, a bug, or both, but the 343651 Squeak behavior is documented in this test. -dtl" 343652 | aNumber rs | 343653 aNumber := '2r1.0101e9' asNumber. 343654 self assert: 672.0 = aNumber. 343655 self assert: (SqNumberParser parse: '2r1.0101e9') = (1.3125 * (2 raisedTo: 9)). 343656 rs := '2r1.0101e9e9' readStream. 343657 self assert: (SqNumberParser parse: rs) = 672.0. 343658 self assert: rs upToEnd = 'e9'! ! 343659 343660 343661!SqNumberParserTest methodsFor: 'tests - Integer' stamp: 'damiencassou 5/30/2008 11:09'! 343662testIntegerReadFrom 343663 "Ensure remaining characters in a stream are not lost when parsing an integer." 343664 | rs i s | 343665 rs := '123s could be confused with a ScaledDecimal' readStream. 343666 i := SqNumberParser parse: rs. 343667 self assert: i == 123. 343668 s := rs upToEnd. 343669 self assert: 's could be confused with a ScaledDecimal' = s. 343670 rs := '123.s could be confused with a ScaledDecimal' readStream. 343671 i := SqNumberParser parse: rs. 343672 self assert: i == 123. 343673 s := rs upToEnd. 343674 self assert: '.s could be confused with a ScaledDecimal' = s! ! 343675 343676!SqNumberParserTest methodsFor: 'tests - Integer' stamp: 'nice 5/7/2006 17:46'! 343677testIntegerReadWithRadix 343678 "This covers parsing in Number>>readFrom: 343679 Note: In most Smalltalk dialects, the radix notation is not used for numbers 343680 with exponents. In Squeak, a string with radix and exponent can be parsed, 343681 and the exponent is always treated as base 10 (not the base indicated in the 343682 radix prefix). I am not sure if this is a feature, a bug, or both, but the 343683 Squeak behavior is documented in this test. -dtl" 343684 343685 | aNumber rs | 343686 aNumber := '2r1e26' asNumber. 343687 self assert: 67108864 = aNumber. 343688 self assert: (SqNumberParser parse: '2r1e26') = (2 raisedTo: 26). 343689 rs := '2r1e26eee' readStream. 343690 self assert: (SqNumberParser parse: rs) = 67108864. 343691 self assert: rs upToEnd = 'eee' 343692! ! 343693 343694!SqNumberParserTest methodsFor: 'tests - Integer' stamp: 'NikoSchwarz 10/17/2009 10:41'! 343695testcheckForCoverage 343696 343697self should: ['.' asNumber = nil] raise: Error. 343698self should: ['1.' asNumber = 1]. 343699self should: ['.1' asNumber = nil] raise: Error.! ! 343700 343701 343702!SqNumberParserTest methodsFor: 'tests - ScaledDecimal' stamp: 'nice 8/29/2008 22:03'! 343703testScaledDecimalWithTrailingZeroes 343704 "This is a non regression tests for http://bugs.squeak.org/view.php?id=7169" 343705 343706 self assert: (SqNumberParser parse: '0.50s2') = (1/2). 343707 self assert: (SqNumberParser parse: '0.500s3') = (1/2). 343708 self assert: (SqNumberParser parse: '0.050s3') = (1/20).! ! 343709Clipboard subclass: #SqueakClipboard 343710 instanceVariableNames: '' 343711 classVariableNames: '' 343712 poolDictionaries: '' 343713 category: 'System-Clipboard'! 343714!SqueakClipboard commentStamp: 'michael.rueger 3/2/2009 13:21' prior: 0! 343715A SqueakClipboard is the legacy clipboard using VM supplied primitives. 343716 343717 343718! 343719 343720Object subclass: #Stack 343721 instanceVariableNames: 'linkedList' 343722 classVariableNames: '' 343723 poolDictionaries: '' 343724 category: 'Collections-Stack'! 343725!Stack commentStamp: 'dc 7/24/2005 15:41' prior: 0! 343726I implement a simple Stack. #push: adds a new object of any kind on top of the stack. #pop returns the first element and remove it from the stack. #top answer the first element of the stack without removing it.! 343727 343728 343729!Stack methodsFor: 'accessing' stamp: 'dc 7/25/2005 10:04'! 343730size 343731 "How many objects in me ?" 343732 ^ self linkedList size! ! 343733 343734!Stack methodsFor: 'accessing' stamp: 'sd 3/25/2006 15:05'! 343735top 343736 "Answer the first element of the stack without removing it." 343737 self notEmptyCheck. 343738 ^ self linkedList first element! ! 343739 343740 343741!Stack methodsFor: 'adding' stamp: 'dc 7/25/2005 10:22'! 343742push: anObject 343743 "Adds a new object of any kind on top of the stack." 343744 self linkedList 343745 addFirst: (StackLink with: anObject). 343746 ^ anObject.! ! 343747 343748 343749!Stack methodsFor: 'initialization' stamp: 'dc 7/25/2005 11:39'! 343750initialize 343751 super initialize. 343752 linkedList := LinkedList new! ! 343753 343754 343755!Stack methodsFor: 'removing' stamp: 'dc 7/24/2005 16:16'! 343756pop 343757 "Returns the first element and remove it from the stack." 343758 343759 self notEmptyCheck. 343760 ^self linkedList removeFirst element! ! 343761 343762 343763!Stack methodsFor: 'testing' stamp: 'stephane.ducasse 12/5/2008 18:14'! 343764ifEmpty: emptyBlock ifNotEmpty: notEmptyBlock 343765 "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise" 343766 " If the notEmptyBlock has an argument, eval with the receiver as its argument" 343767 "copied from Collection of course" 343768 343769 ^ self isEmpty ifTrue: emptyBlock ifFalse: [notEmptyBlock valueWithPossibleArgument: self]! ! 343770 343771!Stack methodsFor: 'testing' stamp: 'stephane.ducasse 12/5/2008 18:21'! 343772ifEmpty: emptyBlock ifNotEmptyDo: notEmptyBlock 343773 "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise" 343774 "Evaluate the notEmptyBlock with the receiver as its argument" 343775 "copied from Collection" 343776 343777 ^ self isEmpty ifTrue: emptyBlock ifFalse: [notEmptyBlock value: self]! ! 343778 343779!Stack methodsFor: 'testing' stamp: 'stephane.ducasse 12/5/2008 18:15'! 343780ifNotEmpty: aBlock 343781 "Evaluate the given block unless the receiver is empty. 343782 343783 If the block has an argument, eval with the receiver as its argument, 343784 but it might be better to use ifNotEmptyDo: to make the code easier to 343785 understand" 343786 "copied from Collection" 343787 ^self isEmpty ifFalse: [aBlock valueWithPossibleArgument: self]. 343788! ! 343789 343790!Stack methodsFor: 'testing' stamp: 'stephane.ducasse 12/5/2008 18:16'! 343791ifNotEmptyDo: aBlock 343792 "Evaluate the given block with the receiver as its argument." 343793 "copied from Collection" 343794 ^self isEmpty ifFalse: [aBlock value: self]. 343795! ! 343796 343797!Stack methodsFor: 'testing' stamp: 'stephane.ducasse 12/5/2008 18:22'! 343798ifNotEmptyDo: notEmptyBlock ifEmpty: emptyBlock 343799 "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise 343800 Evaluate the notEmptyBlock with the receiver as its argument" 343801 "copied from Collection" 343802 343803 ^ self isEmpty ifFalse: [notEmptyBlock value: self] ifTrue: emptyBlock! ! 343804 343805!Stack methodsFor: 'testing' stamp: 'dc 7/25/2005 10:05'! 343806isEmpty 343807 ^ self linkedList isEmpty! ! 343808 343809!Stack methodsFor: 'testing' stamp: 'stephane.ducasse 12/5/2008 18:16'! 343810isEmptyOrNil 343811 "Answer whether the receiver contains any elements, or is nil. Useful in numerous situations where one wishes the same reaction to an empty collection or to nil" 343812 "copied from Collection" 343813 343814 ^ self isEmpty! ! 343815 343816 343817!Stack methodsFor: 'private' stamp: 'dc 7/25/2005 10:05'! 343818errorEmptyStack 343819 self error: 'this stack is empty'! ! 343820 343821!Stack methodsFor: 'private' stamp: 'dc 7/25/2005 10:20'! 343822linkedList 343823 "The stack is implemented with a LinkedList. Do NOT call this function, it 343824 is for private use !!" 343825 ^ linkedList! ! 343826 343827!Stack methodsFor: 'private' stamp: 'dc 7/25/2005 10:05'! 343828notEmptyCheck 343829 "Ensure the stack is not empty." 343830 self isEmpty 343831 ifTrue: [self errorEmptyStack]! ! 343832Link subclass: #StackLink 343833 instanceVariableNames: 'element' 343834 classVariableNames: '' 343835 poolDictionaries: '' 343836 category: 'Collections-Stack'! 343837!StackLink commentStamp: '<historical>' prior: 0! 343838I implement an element of a stack. I'm a container for any type of object, saved into the 'element' variable. My superclass Link allows me to be part of a LinkedList.! 343839 343840 343841!StackLink methodsFor: 'accessing' stamp: 'dc 7/24/2005 15:34'! 343842element 343843 ^element! ! 343844 343845!StackLink methodsFor: 'accessing' stamp: 'dc 7/25/2005 10:16'! 343846element: anObject 343847 "Any kind of Object." 343848 element := anObject! ! 343849 343850 343851!StackLink methodsFor: 'printing' stamp: 'dc 7/25/2005 10:15'! 343852printOn: aStream 343853 aStream nextPutAll: self class printString; 343854 nextPutAll: ' with: '; 343855 nextPutAll: self element printString! ! 343856 343857"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 343858 343859StackLink class 343860 instanceVariableNames: ''! 343861 343862!StackLink class methodsFor: 'instance creation' stamp: 'dc 7/25/2005 10:15'! 343863with: anObject 343864 ^ self new element: anObject! ! 343865TestCase subclass: #StackTest 343866 uses: TEmptyTest - {#testIfNotEmptyifEmpty. #testIfEmpty. #testNotEmpty} + TCloneTest - {#testCopyNonEmpty} 343867 instanceVariableNames: 'empty nonEmpty' 343868 classVariableNames: '' 343869 poolDictionaries: '' 343870 category: 'CollectionsTests-Stack'! 343871 343872!StackTest methodsFor: 'setup' stamp: 'stephane.ducasse 12/5/2008 17:42'! 343873setUp 343874 343875 empty := Stack new. 343876 nonEmpty := Stack new. 343877 nonEmpty push: 1. 343878 nonEmpty push: -2. 343879 nonEmpty push: 3. 343880 nonEmpty push: 1. 343881 ! ! 343882 343883 343884!StackTest methodsFor: 'test' stamp: 'dc 6/21/2006 10:55'! 343885testEmptyError 343886 343887 | aStack | 343888 aStack := Stack new. 343889 self should: [ aStack top ] raise: Error. 343890 self should: [ aStack pop] raise: Error. 343891 343892 aStack push: 'element'. 343893 343894 self shouldnt: [ aStack top ] raise: Error. 343895 self shouldnt: [ aStack pop] raise: Error. 343896 343897 343898 "The stack is empty again due to previous pop" 343899 self should: [ aStack top ] raise: Error. 343900 self should: [ aStack pop] raise: Error.! ! 343901 343902!StackTest methodsFor: 'test' stamp: 'sd 3/21/2006 22:13'! 343903testPop 343904 343905 | aStack res elem | 343906 elem := 'anElement'. 343907 aStack := Stack new. 343908 self assert: aStack isEmpty. 343909 343910 aStack push: 'a'. 343911 aStack push: elem. 343912 res := aStack pop. 343913 self assert: res = elem. 343914 self assert: res == elem. 343915 343916 self assert: aStack size = 1. 343917 aStack pop. 343918 self assert: aStack isEmpty. 343919 343920! ! 343921 343922!StackTest methodsFor: 'test' stamp: 'sd 3/21/2006 22:13'! 343923testPush 343924 343925 | aStack | 343926 aStack := Stack new. 343927 aStack push: 'a'. 343928 self assert: aStack size = 1. 343929 aStack push: 'b'. 343930 self assert: aStack size = 2. 343931 ! ! 343932 343933!StackTest methodsFor: 'test' stamp: 'sd 3/21/2006 22:13'! 343934testSize 343935 343936 | aStack | 343937 aStack := Stack new. 343938 self assert: aStack size = 0. 343939 aStack push: 'a'. 343940 self assert: aStack size = 1. 343941 aStack push: 'b'. 343942 self assert: aStack size = 2. 343943 aStack pop. 343944 self assert: aStack size = 1. 343945 aStack pop. 343946 self assert: aStack size = 0. 343947 343948 343949 343950 343951 343952! ! 343953 343954!StackTest methodsFor: 'test' stamp: 'sd 3/21/2006 22:13'! 343955testTop 343956 343957 | aStack | 343958 aStack := Stack new. 343959 self assert: aStack isEmpty. 343960 aStack push: 'a'. 343961 aStack push: 'b'. 343962 self assert: aStack top = 'b'. 343963 self assert: aStack top = 'b'. 343964 self assert: aStack size = 2.! ! 343965 343966 343967!StackTest methodsFor: 'tests - copy - clone'! 343968testCopyCreatesNewObject 343969 "self debug: #testCopyCreatesNewObject" 343970 343971 | copy | 343972 copy := self nonEmpty copy. 343973 self deny: self nonEmpty == copy. 343974 ! ! 343975 343976!StackTest methodsFor: 'tests - copy - clone'! 343977testCopyEmpty 343978 "self debug: #testCopyEmpty" 343979 343980 | copy | 343981 copy := self empty copy. 343982 self assert: copy isEmpty.! ! 343983 343984 343985!StackTest methodsFor: 'tests - empty' stamp: 'stephane.ducasse 12/5/2008 17:45'! 343986empty 343987 343988 ^ empty! ! 343989 343990!StackTest methodsFor: 'tests - empty' stamp: 'stephane.ducasse 12/5/2008 17:45'! 343991nonEmpty 343992 343993 ^ nonEmpty! ! 343994 343995!StackTest methodsFor: 'tests - empty'! 343996testIfEmptyifNotEmpty 343997 343998 self assert: (self empty ifEmpty: [true] ifNotEmpty: [false]). 343999 self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [true]). 344000 ! ! 344001 344002!StackTest methodsFor: 'tests - empty'! 344003testIfEmptyifNotEmptyDo 344004 "self debug #testIfEmptyifNotEmptyDo" 344005 344006 self assert: (self empty ifEmpty: [true] ifNotEmptyDo: [:s | false]). 344007 self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | true]). 344008 self assert: (self nonEmpty 344009 ifEmpty: [false] 344010 ifNotEmptyDo: [:s | s]) == self nonEmpty.! ! 344011 344012!StackTest methodsFor: 'tests - empty'! 344013testIfNotEmpty 344014 344015 self empty ifNotEmpty: [self assert: false]. 344016 self nonEmpty ifNotEmpty: [self assert: true]. 344017 self assert: (self nonEmpty ifNotEmpty: [:s | s ]) = self nonEmpty 344018 ! ! 344019 344020!StackTest methodsFor: 'tests - empty'! 344021testIfNotEmptyDo 344022 344023 self empty ifNotEmptyDo: [:s | self assert: false]. 344024 self assert: (self nonEmpty ifNotEmptyDo: [:s | s]) == self nonEmpty 344025! ! 344026 344027!StackTest methodsFor: 'tests - empty'! 344028testIfNotEmptyDoifNotEmpty 344029 344030 self assert: (self empty ifNotEmptyDo: [:s | false] ifEmpty: [true]). 344031 self assert: (self nonEmpty 344032 ifNotEmptyDo: [:s | s] 344033 ifEmpty: [false]) == self nonEmpty! ! 344034 344035!StackTest methodsFor: 'tests - empty'! 344036testIsEmpty 344037 344038 self assert: (self empty isEmpty). 344039 self deny: (self nonEmpty isEmpty).! ! 344040 344041!StackTest methodsFor: 'tests - empty'! 344042testIsEmptyOrNil 344043 344044 self assert: (self empty isEmptyOrNil). 344045 self deny: (self nonEmpty isEmptyOrNil).! ! 344046 344047 344048!StackTest methodsFor: 'tests - fixture'! 344049test0FixtureCloneTest 344050 344051self shouldnt: [ self nonEmpty ] raise: Error. 344052self deny: self nonEmpty isEmpty. 344053 344054self shouldnt: [ self empty ] raise: Error. 344055self assert: self empty isEmpty. 344056 344057! ! 344058 344059!StackTest methodsFor: 'tests - fixture'! 344060test0FixtureEmptyTest 344061 344062self shouldnt: [ self nonEmpty ] raise: Error. 344063self deny: self nonEmpty isEmpty. 344064 344065self shouldnt: [ self empty ] raise: Error. 344066self assert: self empty isEmpty.! ! 344067 344068"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 344069 344070StackTest class 344071 instanceVariableNames: 'testSize'! 344072SelectionMenu subclass: #StandardFileMenu 344073 instanceVariableNames: 'canTypeFileName pattern' 344074 classVariableNames: '' 344075 poolDictionaries: '' 344076 category: 'Morphic-FileList'! 344077!StandardFileMenu commentStamp: 'mp 8/15/2005 18:44' prior: 0! 344078I represent a SelectionMenu which operates like a modal dialog for selecting files, somewhat similar to the StandardFile dialogs in MacOS and Java Swing. 344079 344080Try for example, the following: 344081 344082 StandardFileMenu oldFile inspect 344083 344084 StandardFileMenu oldFileStream inspect 344085 344086 StandardFileMenu newFile inspect 344087 344088 StandardFileMenu newFileStream inspect 344089 344090 (StandardFileMenu oldFileMenu: FileDirectory default withPattern: '*') startUpWithCaption: 'Select a file:' 344091 344092 (StandardFileMenu oldFileMenu: (FileDirectory default) withPatternList: {'*.txt'. '*.changes'}) startUpWithCaption: 'Select a file:' 344093! 344094 344095 344096!StandardFileMenu methodsFor: 'basic control sequences' stamp: 'rbb 2/16/2005 16:59'! 344097confirmExistingFiles: aResult 344098 344099 |choice| 344100 (aResult directory fileExists: aResult name) ifFalse: [^aResult]. 344101 344102 choice := (UIManager default chooseFrom: #('overwrite that file' 'choose another name' 344103 'cancel') 344104 title: aResult name, ' 344105already exists.'). 344106 344107 choice = 1 ifTrue: [ 344108 aResult directory 344109 deleteFileNamed: aResult name 344110 ifAbsent: 344111 [^self startUpWithCaption: 344112'Can''t delete ', aResult name, ' 344113Select another file']. 344114 ^aResult]. 344115 choice = 2 ifTrue: [^self startUpWithCaption: 'Select Another File']. 344116 ^nil 344117 ! ! 344118 344119!StandardFileMenu methodsFor: 'basic control sequences' stamp: 'DamienCassou 9/29/2009 13:12'! 344120getTypedFileName: aResult 344121 344122 | name | 344123 name := UIManager default 344124 request: 'Enter a new file name' 344125 initialAnswer: ''. 344126 name isEmptyOrNil ifTrue: [^self startUpWithCaption: 'Select a File:' translated]. 344127 name := aResult directory fullNameFor: name. 344128 ^ StandardFileMenuResult 344129 directory: (FileDirectory forFileName: name) 344130 name: (FileDirectory localNameFor: name) 344131! ! 344132 344133!StandardFileMenu methodsFor: 'basic control sequences' stamp: 'acg 9/28/1999 23:34'! 344134startUpWithCaption: aString at: location 344135 344136 |result| 344137 result := super startUpWithCaption: aString at: location. 344138 result ifNil: [^nil]. 344139 result isDirectory ifTrue: 344140 [self makeFileMenuFor: result directory. 344141 self computeForm. 344142 ^self startUpWithCaption: aString at: location]. 344143 result isCommand ifTrue: 344144 [result := self getTypedFileName: result. 344145 result ifNil: [^nil]]. 344146 canTypeFileName ifTrue: [^self confirmExistingFiles: result]. 344147 ^result 344148 ! ! 344149 344150 344151!StandardFileMenu methodsFor: 'menu building' stamp: 'di 5/12/2000 10:31'! 344152directoryNamesString: aDirectory 344153"Answer a string concatenating the directory name strings in aDirectory, each string followed by a '[...]' indicator, and followed by a cr." 344154 344155 ^ String streamContents: 344156 [:s | aDirectory directoryNames do: 344157 [:dn | s nextPutAll: dn withBlanksTrimmed , ' [...]'; cr]] 344158 344159! ! 344160 344161!StandardFileMenu methodsFor: 'menu building' stamp: 'zz 8/15/2005 17:33'! 344162fileNamesString: aDirectory 344163"Answer a string concatenating the file name strings in aDirectory, each string followed by a cr." 344164 344165 ^String streamContents: 344166 [:s | 344167 aDirectory fileNames do: 344168 [:fn | 344169 pattern do:[:each | (each match: fn) ifTrue: [ 344170 s nextPutAll: fn withBlanksTrimmed; cr]]]] 344171 ! ! 344172 344173!StandardFileMenu methodsFor: 'menu building' stamp: 'zz 8/15/2005 16:28'! 344174makeFileMenuFor: aDirectory 344175"Initialize an instance of me to operate on aDirectory" 344176 344177 | theMenu | 344178 pattern ifNil: [pattern := {'*'}]. 344179 Cursor wait showWhile: 344180 [self 344181 labels: (self menuLabelsString: aDirectory) 344182 font: (MenuStyle fontAt: 1) 344183 lines: (self menuLinesArray: aDirectory). 344184 theMenu := self selections: (self menuSelectionsArray: aDirectory)]. 344185 ^theMenu! ! 344186 344187!StandardFileMenu methodsFor: 'menu building' stamp: 'acg 4/15/1999 21:57'! 344188menuLabelsString: aDirectory 344189"Answer a menu labels object corresponding to aDirectory" 344190 344191 ^ String streamContents: 344192 [:s | 344193 canTypeFileName ifTrue: 344194 [s nextPutAll: 'Enter File Name...'; cr]. 344195 s nextPutAll: (self pathPartsString: aDirectory). 344196 s nextPutAll: (self directoryNamesString: aDirectory). 344197 s nextPutAll: (self fileNamesString: aDirectory). 344198 s skip: -1]! ! 344199 344200!StandardFileMenu methodsFor: 'menu building' stamp: 'tpr 11/28/2003 15:12'! 344201menuLinesArray: aDirectory 344202"Answer a menu lines object corresponding to aDirectory" 344203 344204 | typeCount nameCnt dirDepth| 344205 typeCount := canTypeFileName 344206 ifTrue: [1] 344207 ifFalse: [0]. 344208 nameCnt := aDirectory directoryNames size. 344209 dirDepth := aDirectory pathParts size. 344210 ^Array streamContents: [:s | 344211 canTypeFileName ifTrue: [s nextPut: 1]. 344212 s nextPut: dirDepth + typeCount + 1. 344213 s nextPut: dirDepth + nameCnt + typeCount + 1]! ! 344214 344215!StandardFileMenu methodsFor: 'menu building' stamp: 'zz 8/15/2005 18:18'! 344216menuSelectionsArray: aDirectory 344217"Answer a menu selections object corresponding to aDirectory. The object is an array corresponding to each item, each element itself constituting a two-element array, the first element of which contains a selector to operate on and the second element of which contains the parameters for that selector." 344218 344219 |dirSize| 344220 dirSize := aDirectory pathParts size. 344221 ^Array streamContents: [:s | 344222 canTypeFileName ifTrue: 344223 [s nextPut: (StandardFileMenuResult 344224 directory: aDirectory 344225 name: nil)]. 344226 s nextPut: (StandardFileMenuResult 344227 directory: (FileDirectory root) 344228 name: ''). 344229 aDirectory pathParts doWithIndex: 344230 [:d :i | s nextPut: (StandardFileMenuResult 344231 directory: (self 344232 advance: dirSize - i 344233 containingDirectoriesFrom: aDirectory) 344234 name: '')]. 344235 aDirectory directoryNames do: 344236 [:dn | s nextPut: (StandardFileMenuResult 344237 directory: (FileDirectory on: (aDirectory fullNameFor: dn)) 344238 name: '')]. 344239 aDirectory fileNames do: 344240 [:fn | pattern do: [:pat | (pat match: fn) ifTrue: [ 344241 s nextPut: (StandardFileMenuResult 344242 directory: aDirectory 344243 name: fn)]]]]! ! 344244 344245!StandardFileMenu methodsFor: 'menu building' stamp: 'acg 4/15/1999 21:03'! 344246pathPartsString: aDirectory 344247"Answer a string concatenating the path parts strings in aDirectory, each string followed by a cr." 344248 344249 ^String streamContents: 344250 [:s | 344251 s nextPutAll: '[]'; cr. 344252 aDirectory pathParts asArray doWithIndex: 344253 [:part :i | 344254 s next: i put: $ . 344255 s nextPutAll: part withBlanksTrimmed; cr]]! ! 344256 344257 344258!StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 00:32'! 344259advance: anInteger containingDirectoriesFrom: aDirectory 344260 344261 | theDirectory | 344262 theDirectory := aDirectory. 344263 1 to: anInteger do: [:i | theDirectory := theDirectory containingDirectory]. 344264 ^theDirectory! ! 344265 344266!StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 20:50'! 344267computeLabelParagraph 344268 "Answer a Paragraph containing this menu's labels, one per line and centered." 344269 344270 ^ Paragraph withText: labelString asText style: (MenuStyle leftFlush)! ! 344271 344272!StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 22:03'! 344273newFileFrom: aDirectory 344274 344275 canTypeFileName := true. 344276 ^self makeFileMenuFor: aDirectory! ! 344277 344278!StandardFileMenu methodsFor: 'private' stamp: 'zz 8/15/2005 18:25'! 344279newFileFrom: aDirectory withPatternList: aPatternList 344280 344281 canTypeFileName := true. 344282 pattern := aPatternList. 344283 ^self makeFileMenuFor: aDirectory! ! 344284 344285!StandardFileMenu methodsFor: 'private' stamp: 'zz 8/15/2005 16:29'! 344286newFileFrom: aDirectory withPattern: aPattern 344287 344288 canTypeFileName := true. 344289 pattern := {aPattern}. 344290 ^self makeFileMenuFor: aDirectory! ! 344291 344292!StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 22:03'! 344293oldFileFrom: aDirectory 344294 344295 canTypeFileName := false. 344296 ^self makeFileMenuFor: aDirectory! ! 344297 344298!StandardFileMenu methodsFor: 'private' stamp: 'zz 8/15/2005 17:28'! 344299oldFileFrom: aDirectory withPatternList: aPatternList 344300 344301 canTypeFileName := false. 344302 pattern := aPatternList. 344303 ^self makeFileMenuFor: aDirectory! ! 344304 344305!StandardFileMenu methodsFor: 'private' stamp: 'zz 8/15/2005 16:28'! 344306oldFileFrom: aDirectory withPattern: aPattern 344307 344308 canTypeFileName := false. 344309 pattern := {aPattern}. 344310 ^self makeFileMenuFor: aDirectory! ! 344311 344312!StandardFileMenu methodsFor: 'private' stamp: 'zz 8/15/2005 16:31'! 344313pattern: aPattern 344314 " * for all files, or '*.cs' for changeSets, etc. Just like fileLists" 344315 344316 pattern := {aPattern}! ! 344317 344318!StandardFileMenu methodsFor: 'private' stamp: 'zz 8/15/2005 17:29'! 344319patternList: aPatternList 344320 344321 pattern := aPatternList! ! 344322 344323"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 344324 344325StandardFileMenu class 344326 instanceVariableNames: ''! 344327 344328!StandardFileMenu class methodsFor: 'instance creation' stamp: 'alain.plantec 6/1/2008 20:17'! 344329newFileMenu: aDirectory 344330 ^ super new newFileFrom: aDirectory! ! 344331 344332!StandardFileMenu class methodsFor: 'instance creation' stamp: 'alain.plantec 6/1/2008 20:19'! 344333newFileMenu: aDirectory withPatternList: aPatternList 344334 ^ super new newFileFrom: aDirectory withPatternList: aPatternList! ! 344335 344336!StandardFileMenu class methodsFor: 'instance creation' stamp: 'alain.plantec 6/1/2008 20:18'! 344337newFileMenu: aDirectory withPattern: aPattern 344338 ^ super new newFileFrom: aDirectory withPattern: aPattern! ! 344339 344340!StandardFileMenu class methodsFor: 'instance creation' stamp: 'alain.plantec 6/1/2008 20:19'! 344341oldFileMenu: aDirectory 344342 ^ super new oldFileFrom: aDirectory! ! 344343 344344!StandardFileMenu class methodsFor: 'instance creation' stamp: 'alain.plantec 6/1/2008 20:21'! 344345oldFileMenu: aDirectory withPatternList: aPatternList 344346 ^super new oldFileFrom: aDirectory withPatternList: aPatternList! ! 344347 344348!StandardFileMenu class methodsFor: 'instance creation' stamp: 'alain.plantec 6/1/2008 20:21'! 344349oldFileMenu: aDirectory withPattern: aPattern 344350 ^super new oldFileFrom: aDirectory withPattern: aPattern! ! 344351 344352 344353!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'tk 2/14/2000 14:28'! 344354newFile 344355 344356 ^self newFileFrom: (FileDirectory default)! ! 344357 344358!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'dgd 9/21/2003 13:17'! 344359newFileFrom: aDirectory 344360 344361 ^(self newFileMenu: aDirectory) 344362 startUpWithCaption: 'Select a File:' translated! ! 344363 344364!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'acg 4/15/1999 22:18'! 344365newFileStream 344366 344367 ^self newFileStreamFrom: (FileDirectory default)! ! 344368 344369!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'tk 2/14/2000 14:28'! 344370newFileStreamFrom: aDirectory 344371 344372 | sfmResult fileStream | 344373 sfmResult := self newFileFrom: aDirectory. 344374 sfmResult ifNil: [^nil]. 344375 fileStream := sfmResult directory newFileNamed: sfmResult name. 344376 [fileStream isNil] whileTrue: 344377 [sfmResult := self newFileFrom: aDirectory. 344378 sfmResult ifNil: [^nil]. 344379 fileStream := sfmResult directory newFileNamed: sfmResult name]. 344380 ^fileStream 344381! ! 344382 344383!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'tk 2/14/2000 14:28'! 344384oldFile 344385 344386 ^self oldFileFrom: (FileDirectory default)! ! 344387 344388!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'dgd 9/21/2003 13:17'! 344389oldFileFrom: aDirectory 344390 344391 ^(self oldFileMenu: aDirectory) 344392 startUpWithCaption: 'Select a File:' translated! ! 344393 344394!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'acg 4/15/1999 22:17'! 344395oldFileStream 344396 344397 ^self oldFileStreamFrom: (FileDirectory default) 344398! ! 344399 344400!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'tk 2/14/2000 14:27'! 344401oldFileStreamFrom: aDirectory 344402 344403 | sfmResult fileStream | 344404 sfmResult := self oldFileFrom: aDirectory. 344405 sfmResult ifNil: [^nil]. 344406 fileStream := sfmResult directory oldFileNamed: sfmResult name. 344407 [fileStream isNil] whileTrue: 344408 [sfmResult := self oldFileFrom: aDirectory. 344409 sfmResult ifNil: [^nil]. 344410 fileStream := sfmResult directory oldFileNamed: sfmResult name]. 344411 ^fileStream 344412! ! 344413Object subclass: #StandardFileMenuResult 344414 instanceVariableNames: 'directory name' 344415 classVariableNames: '' 344416 poolDictionaries: '' 344417 category: 'Morphic-FileList'! 344418 344419!StandardFileMenuResult methodsFor: 'accessing' stamp: 'acg 4/15/1999 08:43'! 344420directory 344421 344422 ^directory! ! 344423 344424!StandardFileMenuResult methodsFor: 'accessing' stamp: 'acg 4/15/1999 08:43'! 344425directory: aDirectory 344426 344427 ^directory := aDirectory! ! 344428 344429!StandardFileMenuResult methodsFor: 'accessing' stamp: 'acg 4/15/1999 08:43'! 344430name 344431 344432 ^name! ! 344433 344434!StandardFileMenuResult methodsFor: 'accessing' stamp: 'acg 4/15/1999 08:43'! 344435name: aString 344436 344437 ^name := aString! ! 344438 344439!StandardFileMenuResult methodsFor: 'accessing' stamp: 'sw 6/9/1999 11:50'! 344440printOn: aStream 344441 super printOn: aStream. 344442 aStream nextPutAll: ' with directory: '. 344443 directory printOn: aStream. 344444 aStream nextPutAll: ' name: '. 344445 name printOn: aStream 344446 344447"StandardFileMenu oldFile"! ! 344448 344449 344450!StandardFileMenuResult methodsFor: 'testing' stamp: 'acg 4/15/1999 09:05'! 344451isCommand 344452 344453 ^name isNil! ! 344454 344455!StandardFileMenuResult methodsFor: 'testing' stamp: 'acg 4/15/1999 20:57'! 344456isDirectory 344457 344458 ^name = ''! ! 344459 344460 344461!StandardFileMenuResult methodsFor: 'private' stamp: 'acg 4/15/1999 08:42'! 344462directory: aDirectory name: aString 344463 344464 directory := aDirectory. 344465 name := aString. 344466 ^self! ! 344467 344468"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 344469 344470StandardFileMenuResult class 344471 instanceVariableNames: ''! 344472 344473!StandardFileMenuResult class methodsFor: 'instance creation' stamp: 'acg 4/15/1999 08:42'! 344474directory: aDirectory name: aString 344475 344476 ^super new directory: aDirectory name: aString! ! 344477FileStream subclass: #StandardFileStream 344478 instanceVariableNames: 'name fileID buffer1' 344479 classVariableNames: 'Registry' 344480 poolDictionaries: '' 344481 category: 'Files-Kernel'! 344482!StandardFileStream commentStamp: '<historical>' prior: 0! 344483Provides a simple, platform-independent, interface to a file system. This initial version ignores issues of Directories etc. The instance-variable fallbackStream at the moment holds an instance of HFSMacFileStream, to bridge us to the new world while in the old. The instance variable rwmode, inherited from class PositionableStream, here is used to hold a Boolean -- true means opened for read-write, false means opened for read-only. 2/12/96 sw! 344484 344485 344486!StandardFileStream methodsFor: 'access' stamp: 'jm 9/21/1998 14:16'! 344487directory 344488 "Return the directory containing this file." 344489 344490 ^ FileDirectory forFileName: self fullName 344491! ! 344492 344493!StandardFileStream methodsFor: 'access' stamp: 'tk 3/14/2000 23:31'! 344494directoryUrl 344495 344496 ^ self directory url! ! 344497 344498!StandardFileStream methodsFor: 'access'! 344499file 344500 "Answer the object representing the receiver's file. Need for compatibility with some calls -- check senders. 2/14/96 sw" 344501 344502 ^ self! ! 344503 344504!StandardFileStream methodsFor: 'access' stamp: 'jm 9/21/1998 14:19'! 344505fullName 344506 "Answer this file's full path name." 344507 344508 ^ name 344509! ! 344510 344511!StandardFileStream methodsFor: 'access'! 344512isDirectory 344513 "Answer whether the receiver represents a directory. For the post-transition case, uncertain what to do. 2/14/96 sw" 344514 ^ false! ! 344515 344516!StandardFileStream methodsFor: 'access' stamp: 'ar 11/24/1998 14:00'! 344517localName 344518 ^ name ifNotNil: [(name findTokens: FileDirectory pathNameDelimiter asString) last]! ! 344519 344520!StandardFileStream methodsFor: 'access' stamp: 'jm 9/21/1998 14:19'! 344521name 344522 "Answer this file's full path name." 344523 344524 ^ name 344525! ! 344526 344527!StandardFileStream methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:32'! 344528peekFor: item 344529 "Answer false and do not advance if the next element is not equal to item, or if this stream is at the end. If the next element is equal to item, then advance over it and return true" 344530 | next | 344531 "self atEnd ifTrue: [^ false]. -- SFStream will give nil" 344532 (next := self next) == nil ifTrue: [^ false]. 344533 item = next ifTrue: [^ true]. 344534 self skip: -1. 344535 ^ false! ! 344536 344537!StandardFileStream methodsFor: 'access'! 344538printOn: aStream 344539 "Put a printed version of the receiver onto aStream. 1/31/96 sw" 344540 344541 aStream nextPutAll: self class name; nextPutAll: ': '; print: name! ! 344542 344543!StandardFileStream methodsFor: 'access' stamp: 'ar 6/16/2002 18:58'! 344544reset 344545 self ensureOpen. 344546 self position: 0.! ! 344547 344548!StandardFileStream methodsFor: 'access'! 344549size 344550 "Answer the size of the file in characters. 2/12/96 sw" 344551 344552 ^ self primSize: fileID! ! 344553 344554 344555!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 1/11/2000 10:44'! 344556defaultBrowserReadyWait 344557 ^5000! ! 344558 344559!StandardFileStream methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'! 344560post: data target: target url: url ifError: errorBlock 344561 "Post data to the given URL. The returned file stream contains the reply of the server. 344562 If Squeak is not running in a browser evaluate errorBlock" 344563 | sema index request result | 344564 self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value]. 344565 sema := Semaphore new. 344566 index := Smalltalk registerExternalObject: sema. 344567 request := self primURLPost: url target: target data: data semaIndex: index. 344568 request == nil ifTrue:[ 344569 344570 Smalltalk unregisterExternalObject: sema. 344571 ^errorBlock value. 344572 ] ifFalse:[ 344573 [sema wait. "until something happens" 344574 result := self primURLRequestState: request. 344575 result == nil] whileTrue. 344576 result ifTrue:[fileID := self primURLRequestFileHandle: request]. 344577 self primURLRequestDestroy: request. 344578 ]. 344579 Smalltalk unregisterExternalObject: sema. 344580 fileID == nil ifTrue:[^nil]. 344581 self register. 344582 name := url. 344583 rwmode := false. 344584 buffer1 := String new: 1.! ! 344585 344586!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 2/2/2001 14:22'! 344587post: data url: url ifError: errorBlock 344588 344589 self post: data target: nil url: url ifError: errorBlock! ! 344590 344591!StandardFileStream methodsFor: 'browser requests' stamp: 'ar 2/26/2001 15:58'! 344592primBrowserReady 344593 <primitive:'primitivePluginBrowserReady'> 344594 ^nil! ! 344595 344596!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 9/21/2000 16:58'! 344597primURLPost: url data: contents semaIndex: index 344598 ^self primURLPost: url target: nil data: contents semaIndex: index! ! 344599 344600!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 9/21/2000 16:58'! 344601primURLPost: url target: target data: contents semaIndex: index 344602 "Post the data (url might be 'mailto:' etc)" 344603 <primitive:'primitivePluginPostURL'> 344604 ^nil 344605 ! ! 344606 344607!StandardFileStream methodsFor: 'browser requests'! 344608primURLRequest: url semaIndex: index 344609 <primitive:'primitivePluginRequestURLStream'> 344610 ^nil! ! 344611 344612!StandardFileStream methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'! 344613primURLRequest: url target: target semaIndex: index 344614 "target - String (frame, also ':=top', ':=parent' etc)" 344615 <primitive:'primitivePluginRequestURL'> 344616 ^nil 344617 ! ! 344618 344619!StandardFileStream methodsFor: 'browser requests'! 344620primURLRequestDestroy: request 344621 <primitive:'primitivePluginDestroyRequest'> 344622 ^nil! ! 344623 344624!StandardFileStream methodsFor: 'browser requests'! 344625primURLRequestFileHandle: request 344626 <primitive: 'primitivePluginRequestFileHandle'> 344627 ^nil! ! 344628 344629!StandardFileStream methodsFor: 'browser requests'! 344630primURLRequestState: request 344631 <primitive:'primitivePluginRequestState'> 344632 ^false! ! 344633 344634!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 2/29/2000 11:22'! 344635requestURL: url target: target 344636 ^self requestURL: url target: target ifError: [nil]! ! 344637 344638!StandardFileStream methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'! 344639requestURL: url target: target ifError: errorBlock 344640 "Request to go to the target for the given URL. 344641 If Squeak is not running in a browser evaluate errorBlock" 344642 344643 | sema index request result | 344644 self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value]. 344645 sema := Semaphore new. 344646 index := Smalltalk registerExternalObject: sema. 344647 request := self primURLRequest: url target: target semaIndex: index. 344648 request == nil ifTrue:[ 344649 344650 Smalltalk unregisterExternalObject: sema. 344651 ^errorBlock value. 344652 ] ifFalse:[ 344653 [sema wait. "until something happens" 344654 result := self primURLRequestState: request. 344655 result == nil] whileTrue. 344656 self primURLRequestDestroy: request. 344657 ]. 344658 Smalltalk unregisterExternalObject: sema. 344659 fileID == nil ifTrue:[^nil]. 344660 self register. 344661 name := url. 344662 rwmode := false. 344663 buffer1 := String new: 1.! ! 344664 344665!StandardFileStream methodsFor: 'browser requests'! 344666requestURLStream: url 344667 "FileStream requestURLStream:'http://www.squeak.org'" 344668 ^self requestURLStream: url ifError:[nil]! ! 344669 344670!StandardFileStream methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'! 344671requestURLStream: url ifError: errorBlock 344672 "Request a FileStream for the given URL. 344673 If Squeak is not running in a browser evaluate errorBlock" 344674 "FileStream requestURLStream:'http://www.squeak.org'" 344675 | sema index request result | 344676 self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value]. 344677 sema := Semaphore new. 344678 index := Smalltalk registerExternalObject: sema. 344679 request := self primURLRequest: url semaIndex: index. 344680 request == nil ifTrue:[ 344681 344682 Smalltalk unregisterExternalObject: sema. 344683 ^errorBlock value. 344684 ] ifFalse:[ 344685 [sema wait. "until something happens" 344686 result := self primURLRequestState: request. 344687 result == nil] whileTrue. 344688 result ifTrue:[fileID := self primURLRequestFileHandle: request]. 344689 self primURLRequestDestroy: request. 344690 ]. 344691 Smalltalk unregisterExternalObject: sema. 344692 fileID == nil ifTrue:[^nil]. 344693 self register. 344694 name := url. 344695 rwmode := false. 344696 buffer1 := String new: 1.! ! 344697 344698!StandardFileStream methodsFor: 'browser requests' stamp: 'stephaneducasse 2/4/2006 20:32'! 344699waitBrowserReadyFor: timeout ifFail: errorBlock 344700 | startTime delay okay | 344701 okay := self primBrowserReady. 344702 okay ifNil:[^errorBlock value]. 344703 okay ifTrue: [^true]. 344704 startTime := Time millisecondClockValue. 344705 delay := Delay forMilliseconds: 100. 344706 [(Time millisecondsSince: startTime) < timeout] 344707 whileTrue: [ 344708 delay wait. 344709 okay := self primBrowserReady. 344710 okay ifNil:[^errorBlock value]. 344711 okay ifTrue: [^true]]. 344712 ^errorBlock value! ! 344713 344714 344715!StandardFileStream methodsFor: 'dnd requests' stamp: 'ar 1/10/2001 20:01'! 344716primDropRequestFileHandle: dropIndex 344717 "Primitive. Return the (read-only) file handle for some file that was just dropped onto Squeak. 344718 Fail if dropIndex is out of range or the primitive is not supported." 344719 <primitive: 'primitiveDropRequestFileHandle' module:'DropPlugin'> 344720 ^nil! ! 344721 344722!StandardFileStream methodsFor: 'dnd requests' stamp: 'ar 1/10/2001 20:01'! 344723primDropRequestFileName: dropIndex 344724 "Primitive. Return the file name for some file that was just dropped onto Squeak. 344725 Fail if dropIndex is out of range or the primitive is not supported." 344726 <primitive: 'primitiveDropRequestFileName' module:'DropPlugin'> 344727 ^nil! ! 344728 344729!StandardFileStream methodsFor: 'dnd requests' stamp: 'ar 6/3/2007 21:47'! 344730requestDropStream: dropIndex 344731 "Return a read-only stream for some file the user has just dropped onto Squeak." 344732 | rawName | 344733 rawName := self primDropRequestFileName: dropIndex. 344734 name := (FilePath pathName: rawName isEncoded: true) asSqueakPathName. 344735 fileID := self primDropRequestFileHandle: dropIndex. 344736 fileID == nil ifTrue:[^nil]. 344737 self register. 344738 rwmode := false. 344739 buffer1 := String new: 1. 344740 344741! ! 344742 344743 344744!StandardFileStream methodsFor: 'finalization' stamp: 'ar 3/21/98 18:16'! 344745actAsExecutor 344746 super actAsExecutor. 344747 name := nil.! ! 344748 344749!StandardFileStream methodsFor: 'finalization' stamp: 'ar 10/7/1998 15:44'! 344750finalize 344751 self primCloseNoError: fileID.! ! 344752 344753 344754!StandardFileStream methodsFor: 'open/close' stamp: 'stephaneducasse 2/4/2006 20:32'! 344755close 344756 "Close this file." 344757 344758 fileID ifNotNil: [ 344759 self primClose: fileID. 344760 self unregister. 344761 fileID := nil]. 344762! ! 344763 344764!StandardFileStream methodsFor: 'open/close' stamp: 'jm 2/6/2002 08:33'! 344765closed 344766 "Answer true if this file is closed." 344767 344768 ^ fileID isNil or: [(self primSizeNoError: fileID) isNil] 344769! ! 344770 344771!StandardFileStream methodsFor: 'open/close' stamp: 'jm 9/21/1998 16:20'! 344772ensureOpen 344773 "Make sure that this file really is open." 344774 344775 self closed ifTrue: [^ self reopen]. 344776 (self primSizeNoError: fileID) ifNotNil: [^ self]. 344777 self reopen. 344778! ! 344779 344780!StandardFileStream methodsFor: 'open/close'! 344781open 344782 "For compatibility with a few existing things. 2/14/96 sw" 344783 344784 ^ self reopen! ! 344785 344786!StandardFileStream methodsFor: 'open/close' stamp: 'nes 7/4/2009 17:44'! 344787open: fileName forWrite: writeMode 344788 "Open the file with the given name. If writeMode is true, allow writing, otherwise open the file in read-only mode." 344789 "Changed to do a GC and retry before failing ar 3/21/98 17:25" 344790 | f | 344791 f := fileName asVmPathName. 344792 344793 fileID := StandardFileStream retryWithGC:[self primOpen: f writable: writeMode] 344794 until:[:id| id notNil] 344795 forFileNamed: fileName. 344796 fileID ifNil: [^ nil]. "allows sender to detect failure" 344797 name := fileName. 344798 self register. 344799 rwmode := writeMode. 344800 buffer1 := String new: 1. 344801! ! 344802 344803!StandardFileStream methodsFor: 'open/close'! 344804openReadOnly 344805 "Open the receiver as a read-only file. 1/31/96 sw" 344806 344807 ^ self open: name forWrite: false! ! 344808 344809!StandardFileStream methodsFor: 'open/close' stamp: 'jm 9/21/1998 13:58'! 344810reopen 344811 "Close and reopen this file. The file position is reset to zero." 344812 "Details: Files that were open when a snapshot occurs are no longer valid when the snapshot is resumed. This operation re-opens the file if that has happened." 344813 344814 fileID ifNotNil: [self primCloseNoError: fileID]. 344815 self open: name forWrite: rwmode. 344816! ! 344817 344818 344819!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 344820primAtEnd: id 344821 "Answer true if the file position is at the end of the file." 344822 344823 <primitive: 'primitiveFileAtEnd' module: 'FilePlugin'> 344824 self primitiveFailed 344825! ! 344826 344827!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 344828primClose: id 344829 "Close this file." 344830 344831 <primitive: 'primitiveFileClose' module: 'FilePlugin'> 344832 self primitiveFailed 344833! ! 344834 344835!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 344836primCloseNoError: id 344837 "Close this file. Don't raise an error if the primitive fails." 344838 344839 <primitive: 'primitiveFileClose' module: 'FilePlugin'> 344840! ! 344841 344842!StandardFileStream methodsFor: 'primitives' stamp: 'stephaneducasse 2/4/2006 20:32'! 344843primFlush: id 344844 "Flush pending changes to the disk" 344845 | p | 344846 <primitive: 'primitiveFileFlush' module: 'FilePlugin'> 344847 "In some OS's seeking to 0 and back will do a flush" 344848 p := self position. 344849 self position: 0; position: p! ! 344850 344851!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 344852primGetPosition: id 344853 "Get this files current position." 344854 344855 <primitive: 'primitiveFileGetPosition' module: 'FilePlugin'> 344856 self primitiveFailed 344857! ! 344858 344859!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 344860primOpen: fileName writable: writableFlag 344861 "Open a file of the given name, and return the file ID obtained. 344862 If writableFlag is true, then 344863 if there is none with this name, then create one 344864 else prepare to overwrite the existing from the beginning 344865 otherwise 344866 if the file exists, open it read-only 344867 else return nil" 344868 344869 <primitive: 'primitiveFileOpen' module: 'FilePlugin'> 344870 ^ nil 344871! ! 344872 344873!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 344874primRead: id into: byteArray startingAt: startIndex count: count 344875 "Read up to count bytes of data from this file into the given string or byte array starting at the given index. Answer the number of bytes actually read." 344876 344877 <primitive: 'primitiveFileRead' module: 'FilePlugin'> 344878 self closed ifTrue: [^ self error: 'File is closed']. 344879 self error: 'File read failed'. 344880! ! 344881 344882!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 344883primSetPosition: id to: anInteger 344884 "Set this file to the given position." 344885 344886 <primitive: 'primitiveFileSetPosition' module: 'FilePlugin'> 344887 self primitiveFailed 344888! ! 344889 344890!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 344891primSize: id 344892 "Answer the size of this file." 344893 344894 <primitive: 'primitiveFileSize' module: 'FilePlugin'> 344895 self primitiveFailed 344896! ! 344897 344898!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 344899primSizeNoError: id 344900 "Answer the size of this file. Answer nil if the primitive fails; this indicates that the file handle has become stale." 344901 344902 <primitive: 'primitiveFileSize' module: 'FilePlugin'> 344903 ^ nil 344904! ! 344905 344906!StandardFileStream methodsFor: 'primitives' stamp: 'JMM 5/24/2001 21:55'! 344907primTruncate: id to: anInteger 344908 "Truncate this file to the given position." 344909 344910 <primitive: 'primitiveFileTruncate' module: 'FilePlugin'> 344911 self primitiveFailed 344912! ! 344913 344914!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! 344915primWrite: id from: stringOrByteArray startingAt: startIndex count: count 344916 "Write count bytes onto this file from the given string or byte array starting at the given index. Answer the number of bytes written." 344917 344918 <primitive: 'primitiveFileWrite' module: 'FilePlugin'> 344919 self closed ifTrue: [^ self error: 'File is closed']. 344920 self error: 'File write failed'. 344921! ! 344922 344923 344924!StandardFileStream methodsFor: 'properties-setting' stamp: 'stephaneducasse 2/4/2006 20:32'! 344925ascii 344926 "opposite of binary" 344927 buffer1 := String new: 1! ! 344928 344929!StandardFileStream methodsFor: 'properties-setting' stamp: 'stephaneducasse 2/4/2006 20:32'! 344930binary 344931 buffer1 := ByteArray new: 1! ! 344932 344933!StandardFileStream methodsFor: 'properties-setting' stamp: 'JMM 1/28/2001 18:44'! 344934getFileType 344935 "On the Macintosh, get the file type and creator of this file. On other platforms, do nothing." 344936 344937 ^FileDirectory default 344938 getMacFileTypeAndCreator: self fullName 344939 344940! ! 344941 344942!StandardFileStream methodsFor: 'properties-setting' stamp: 'PeterHugossonMiller 9/2/2009 15:59'! 344943insertLineFeeds 344944 "(FileStream oldFileNamed: 'BBfix2.st') insertLineFeeds" 344945 | s crLf f | 344946 crLf := String with: Character cr with: (Character value: 10). 344947 s := (self next: self size) readStream. 344948 self close. 344949 f := FileStream newFileNamed: self name. 344950 [s atEnd] whileFalse: 344951 [f nextPutAll: (s upTo: Character cr); nextPutAll: crLf]. 344952 f close! ! 344953 344954!StandardFileStream methodsFor: 'properties-setting'! 344955isBinary 344956 ^ buffer1 class == ByteArray! ! 344957 344958!StandardFileStream methodsFor: 'properties-setting' stamp: 'tk 11/4/1998 19:17'! 344959isReadOnly 344960 344961 ^ rwmode not 344962! ! 344963 344964!StandardFileStream methodsFor: 'properties-setting' stamp: 'stephaneducasse 2/4/2006 20:32'! 344965readOnly 344966 "Make this file read-only." 344967 344968 rwmode := false. 344969! ! 344970 344971!StandardFileStream methodsFor: 'properties-setting' stamp: 'stephaneducasse 2/4/2006 20:32'! 344972readWrite 344973 "Make this file writable." 344974 344975 rwmode := true. 344976! ! 344977 344978!StandardFileStream methodsFor: 'properties-setting' stamp: 'jm 12/5/97 15:14'! 344979setFileTypeToObject 344980 "On the Macintosh, set the file type and creator of this file to be a Squeak object file. On other platforms, do nothing. Setting the file type allows Squeak object files to be sent as email attachments and launched by double-clicking. On other platforms, similar behavior is achieved by creating the file with the '.sqo' file name extension." 344981 344982 FileDirectory default 344983 setMacFileNamed: self fullName 344984 type: 'SOBJ' 344985 creator: 'FAST'. 344986! ! 344987 344988 344989!StandardFileStream methodsFor: 'read, write, position' stamp: 'sw 2/12/96'! 344990atEnd 344991 "Answer whether the receiver is at its end. " 344992 ^ self primAtEnd: fileID! ! 344993 344994!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'! 344995basicNext 344996 "Answer the next byte from this file, or nil if at the end of the file." 344997 344998 | count | 344999 count := self primRead: fileID into: buffer1 startingAt: 1 count: 1. 345000 count = 1 345001 ifTrue: [^ buffer1 at: 1] 345002 ifFalse: [^ nil]. 345003! ! 345004 345005!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'! 345006compressFile 345007 "Write a new file that has the data in me compressed in GZip format." 345008 | zipped buffer | 345009 345010 self readOnly; binary. 345011 zipped := self directory newFileNamed: (self name, FileDirectory dot, 'gz'). 345012 zipped binary; setFileTypeToObject. 345013 "Type and Creator not to be text, so can be enclosed in an email" 345014 zipped := GZipWriteStream on: zipped. 345015 buffer := ByteArray new: 50000. 345016 'Compressing ', self fullName displayProgressAt: Sensor cursorPoint 345017 from: 0 to: self size 345018 during: [:bar | 345019 [self atEnd] whileFalse: [ 345020 bar value: self position. 345021 zipped nextPutAll: (self nextInto: buffer)]. 345022 zipped close. 345023 self close]. 345024 ^zipped! ! 345025 345026!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'! 345027findString: string 345028 "Fast version of #upToAll: to find a String in a file starting from the beginning. 345029 Returns the position and also sets the position there. 345030 If string is not found 0 is returned and position is unchanged." 345031 345032 | pos buffer count oldPos sz | 345033 oldPos := self position. 345034 self reset. 345035 sz := self size. 345036 pos := 0. 345037 buffer := String new: 2000. 345038 [ buffer := self nextInto: buffer. 345039 (count := buffer findString: string) > 0 345040 ifTrue: ["Found the string part way into buffer" 345041 self position: pos. 345042 self next: count - 1. 345043 ^self position ]. 345044 pos := ((pos + 2000 - string size) min: sz). 345045 self position: pos. 345046 pos = sz] whileFalse. 345047 "Never found it, and hit end of file" 345048 self position: oldPos. 345049 ^0! ! 345050 345051!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'! 345052findStringFromEnd: string 345053 "Fast version to find a String in a file starting from the end. 345054 Returns the position and also sets the position there. 345055 If string is not found 0 is returned and position is unchanged." 345056 345057 | pos buffer count oldPos | 345058 oldPos := self position. 345059 self setToEnd. 345060 pos := self position. 345061 [ pos := ((pos - 2000 + string size) max: 0). "the [+ string size] allows for the case where the end of the search string is at the beginning of the current buffer" 345062 self position: pos. 345063 buffer := self next: 2000. 345064 (count := buffer findString: string) > 0 345065 ifTrue: ["Found the string part way into buffer" 345066 self position: pos. 345067 self next: count-1. "use next instead of position:, so that CrLfFileStream can do its magic if it is being used" 345068 ^self position]. 345069 pos = 0] whileFalse. 345070 "Never found it, and hit beginning of file" 345071 self position: oldPos. 345072 ^0! ! 345073 345074!StandardFileStream methodsFor: 'read, write, position' stamp: 'ar 2/6/2001 17:59'! 345075flush 345076 "Flush pending changes" 345077 ^self primFlush: fileID! ! 345078 345079!StandardFileStream methodsFor: 'read, write, position' stamp: 'mir 2/25/2000 12:37'! 345080next 345081 "Answer the next byte from this file, or nil if at the end of the file." 345082 345083 ^ self basicNext! ! 345084 345085!StandardFileStream methodsFor: 'read, write, position'! 345086next: n 345087 "Return a string with the next n characters of the filestream in it. 1/31/96 sw" 345088 ^ self nextInto: (buffer1 class new: n)! ! 345089 345090!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'! 345091next: n into: aString startingAt: startIndex 345092 "Read n bytes into the given string. 345093 Return aString or a partial copy if less than 345094 n elements have been read." 345095 | count | 345096 count := self primRead: fileID into: aString 345097 startingAt: startIndex count: n. 345098 count = n 345099 ifTrue:[^aString] 345100 ifFalse:[^aString copyFrom: 1 to: startIndex+count-1]! ! 345101 345102!StandardFileStream methodsFor: 'read, write, position' stamp: 'ar 1/2/2000 15:33'! 345103next: anInteger putAll: aString startingAt: startIndex 345104 "Store the next anInteger elements from the given collection." 345105 rwmode ifFalse: [^ self error: 'Cannot write a read-only file']. 345106 self primWrite: fileID from: aString startingAt: startIndex count: anInteger. 345107 ^aString! ! 345108 345109!StandardFileStream methodsFor: 'read, write, position' stamp: 'jm 9/21/1998 13:55'! 345110nextPut: char 345111 "Write the given character to this file." 345112 345113 rwmode ifFalse: [^ self error: 'Cannot write a read-only file']. 345114 buffer1 at: 1 put: char. 345115 self primWrite: fileID from: buffer1 startingAt: 1 count: 1. 345116 ^ char 345117! ! 345118 345119!StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 2/5/2000 21:43'! 345120nextPutAll: aString 345121 "Write all the characters of the given string to this file." 345122 345123 rwmode ifFalse: [^ self error: 'Cannot write a read-only file']. 345124 self primWrite: fileID from: aString startingAt: 1 count: aString basicSize. 345125 ^ aString 345126! ! 345127 345128!StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 2/5/2000 21:58'! 345129nextWordsInto: aBitmap 345130 "Note: The file primitives automatically adjust for word based objects." 345131 345132 self next: aBitmap basicSize into: aBitmap startingAt: 1. 345133 aBitmap restoreEndianness. 345134 ^ aBitmap! ! 345135 345136!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'! 345137padToEndWith: aChar 345138 "On the Mac, files do not truncate. One can delete the old file and write a new one, but sometime deletion fails (file still open? file stale?). This is a sad compromise. Just let the file be the same length but pad it with a harmless character." 345139 345140 | pad | 345141 self atEnd ifTrue: [^ self]. 345142 pad := self isBinary 345143 ifTrue: [aChar asCharacter asciiValue] "ok for char or number" 345144 ifFalse: [aChar asCharacter]. 345145 self nextPutAll: (buffer1 class new: ((self size - self position) min: 20000) 345146 withAll: pad).! ! 345147 345148!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'! 345149peek 345150 "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " 345151 | next | 345152 self atEnd ifTrue: [^ nil]. 345153 next := self basicNext. 345154 self position: self position - 1. 345155 ^ next! ! 345156 345157!StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 10/19/2001 11:29'! 345158peekLast 345159 "Return that item just put at the end of the stream" 345160 345161 ^ buffer1 size > 0 345162 ifTrue: [buffer1 last] 345163 ifFalse: [nil] 345164! ! 345165 345166!StandardFileStream methodsFor: 'read, write, position'! 345167position 345168 "Return the receiver's current file position. 2/12/96 sw" 345169 345170 ^ self primGetPosition: fileID! ! 345171 345172!StandardFileStream methodsFor: 'read, write, position'! 345173position: pos 345174 "Set the receiver's position as indicated. 2/12/96 sw" 345175 345176 ^ self primSetPosition: fileID to: pos! ! 345177 345178!StandardFileStream methodsFor: 'read, write, position'! 345179readInto: byteArray startingAt: startIndex count: count 345180 "Read into the given array as specified, and return the count 345181 actually transferred. index and count are in units of bytes or 345182 longs depending on whether the array is Bitmap, String or ByteArray" 345183 ^ self primRead: fileID into: byteArray 345184 startingAt: startIndex count: count 345185! ! 345186 345187!StandardFileStream methodsFor: 'read, write, position' stamp: 'yo 10/31/2002 22:33'! 345188readOnlyCopy 345189 345190 ^ self class readOnlyFileNamed: self name. 345191! ! 345192 345193!StandardFileStream methodsFor: 'read, write, position'! 345194setToEnd 345195 "Set the position of the receiver to the end of file. 1/31/96 sw" 345196 345197 self position: self size! ! 345198 345199!StandardFileStream methodsFor: 'read, write, position'! 345200skip: n 345201 "Set the character position to n characters from the current position. 345202 Error if not enough characters left in the file. 1/31/96 sw" 345203 345204 self position: self position + n! ! 345205 345206!StandardFileStream methodsFor: 'read, write, position' stamp: 'JMM 5/24/2001 22:00'! 345207truncate 345208 "Truncate to zero" 345209 345210 ^ self truncate: 0! ! 345211 345212!StandardFileStream methodsFor: 'read, write, position' stamp: 'JMM 5/24/2001 22:47'! 345213truncate: pos 345214 "Truncate to this position" 345215 345216 self position: pos. 345217 ^self primTruncate: fileID to: pos! ! 345218 345219!StandardFileStream methodsFor: 'read, write, position' stamp: 'stephaneducasse 2/4/2006 20:32'! 345220upTo: delim 345221 "Fast version to speed up nextChunk" 345222 | pos buffer count | 345223 pos := self position. 345224 buffer := self next: 2000. 345225 (count := buffer indexOf: delim) > 0 ifTrue: 345226 ["Found the delimiter part way into buffer" 345227 self position: pos + count. 345228 ^ buffer copyFrom: 1 to: count - 1]. 345229 self atEnd ifTrue: 345230 ["Never found it, and hit end of file" 345231 ^ buffer]. 345232 "Never found it, but there's more..." 345233 ^ buffer , (self upTo: delim)! ! 345234 345235!StandardFileStream methodsFor: 'read, write, position' stamp: 'PeterHugossonMiller 9/3/2009 11:25'! 345236upToEnd 345237 "Answer a subcollection from the current access position through the last element of the receiver." 345238 345239 | newStream buffer | 345240 buffer := buffer1 species new: 1000. 345241 newStream := (buffer1 species new: 100) writeStream. 345242 [self atEnd] whileFalse: [newStream nextPutAll: (self nextInto: buffer)]. 345243 ^ newStream contents! ! 345244 345245 345246!StandardFileStream methodsFor: 'registry' stamp: 'ar 3/21/98 17:23'! 345247register 345248 ^self class register: self! ! 345249 345250!StandardFileStream methodsFor: 'registry' stamp: 'ar 3/21/98 17:23'! 345251unregister 345252 ^self class unregister: self! ! 345253 345254"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 345255 345256StandardFileStream class 345257 instanceVariableNames: ''! 345258 345259!StandardFileStream class methodsFor: '*network-uri' stamp: 'JMM 2/3/2008 14:16'! 345260oldFileFullyNamed: t2 345261 345262 ^ (self isAFileNamed: t2) 345263 ifTrue: [self new open: t2 forWrite: true] 345264 ifFalse: [(FileDoesNotExistException fileName: t2) signal]! ! 345265 345266!StandardFileStream class methodsFor: '*network-uri' stamp: 'JMM 2/3/2008 14:12'! 345267readOnlyFileFullyNamed: t1 345268 | t3 | 345269 t3 := self new open: t1 forWrite: false. 345270 ^ t3 isNil 345271 ifTrue: [((FileDoesNotExistException fileName: t1) 345272 readOnly: true) signal] 345273 ifFalse: [t3]! ! 345274 345275 345276!StandardFileStream class methodsFor: 'browser requests' stamp: 'mir 3/8/2001 16:28'! 345277isRunningAsBrowserPlugin 345278 self new waitBrowserReadyFor: 1000 ifFail: [^false]. 345279 ^true! ! 345280 345281!StandardFileStream class methodsFor: 'browser requests' stamp: 'mir 9/7/2000 16:08'! 345282privateCheckForBrowserPrimitives 345283 <primitive:'primitivePluginBrowserReady'> 345284 ^false! ! 345285 345286 345287!StandardFileStream class methodsFor: 'error handling' stamp: 'alain.plantec 2/10/2009 18:15'! 345288fileDoesNotExistUserHandling: fullFileName 345289 345290 | selection newName | 345291 selection := UIManager default 345292 chooseFrom: {'Create a new file' translated. 'Choose another name' translated} 345293 message: (FileDirectory localNameFor: fullFileName) , ('\', ('does not exist.' translated)) withCRs. 345294 selection = 1 ifTrue: 345295 [^ self new open: fullFileName forWrite: true]. 345296 selection = 2 ifTrue: 345297 [ newName := UIManager default request: 'Enter a new file name' translated initialAnswer: fullFileName. 345298 ^ self oldFileNamed: (self fullName: newName)]. 345299 self halt! ! 345300 345301!StandardFileStream class methodsFor: 'error handling' stamp: 'alain.plantec 2/10/2009 18:18'! 345302fileExistsUserHandling: fullFileName 345303 | dir localName choice newName newFullFileName | 345304 dir := FileDirectory forFileName: fullFileName. 345305 localName := FileDirectory localNameFor: fullFileName. 345306 choice := UIManager default 345307 chooseFrom: {'Overwrite that file' translated. 'Choose another name' translated} 345308 message: localName , ('\', ('already exists.' translated)) withCRs. 345309 345310 choice = 1 ifTrue: [ 345311 dir deleteFileNamed: localName 345312 ifAbsent: [self error: 'Could not delete the old version of that file']. 345313 ^ self new open: fullFileName forWrite: true]. 345314 345315 choice = 2 ifTrue: [ 345316 newName := UIManager default request: 'Enter a new file name' translated initialAnswer: fullFileName. 345317 newFullFileName := self fullName: newName. 345318 ^ self newFileNamed: newFullFileName]. 345319 345320 self error: 'Please close this to abort file opening'! ! 345321 345322!StandardFileStream class methodsFor: 'error handling' stamp: 'DamienCassou 9/29/2009 13:12'! 345323readOnlyFileDoesNotExistUserHandling: fullFileName 345324 345325 | dir files choices selection newName fileName | 345326 dir := FileDirectory forFileName: fullFileName. 345327 files := dir fileNames. 345328 fileName := FileDirectory localNameFor: fullFileName. 345329 choices := fileName correctAgainst: files. 345330 choices add: 'Choose another name' translated. 345331 selection := UIManager default 345332 chooseFrom: choices 345333 message: (FileDirectory localNameFor: fullFileName) , ('\', ('does not exist.' translated)) withCRs. 345334 selection = 0 ifTrue:["cancel" ^ nil "should we raise another exception here?"]. 345335 selection < (choices size - 1) ifTrue: [ 345336 newName := (dir pathName , FileDirectory slash , (choices at: selection))]. 345337 selection = (choices size - 1) ifTrue: [ 345338 newName := UIManager default 345339 request: 'Enter a new file name' translated 345340 initialAnswer: fileName]. 345341 newName isEmptyOrNil ifFalse: [^ self readOnlyFileNamed: (self fullName: newName)]. 345342 ^ self error: 'Could not open a file'! ! 345343 345344 345345!StandardFileStream class methodsFor: 'file creation' stamp: 'TPR 8/13/1999 21:22'! 345346fileNamed: fileName 345347 "Open a file with the given name for reading and writing. If the name has no directory part, then the file will be created in the default directory. If the file already exists, its prior contents may be modified or replaced, but the file will not be truncated on close." 345348 345349 ^ self new open: (self fullName: fileName) forWrite: true 345350! ! 345351 345352!StandardFileStream class methodsFor: 'file creation' stamp: 'stephaneducasse 2/4/2006 20:32'! 345353forceNewFileNamed: fileName 345354 "Create a new file with the given name, and answer a stream opened 345355 for writing on that file. If the file already exists, delete it without 345356 asking before creating the new file." 345357 | dir localName fullName f | 345358 fullName := self fullName: fileName. 345359 (self isAFileNamed: fullName) 345360 ifFalse: [f := self new open: fullName forWrite: true. 345361 ^ f isNil 345362 ifTrue: ["Failed to open the file" 345363 (FileDoesNotExistException fileName: fullName) signal] 345364 ifFalse: [f]]. 345365 dir := FileDirectory forFileName: fullName. 345366 localName := FileDirectory localNameFor: fullName. 345367 dir 345368 deleteFileNamed: localName 345369 ifAbsent: [(CannotDeleteFileException new 345370 messageText: 'Could not delete the old version of file ' , fullName) signal]. 345371 f := self new open: fullName forWrite: true. 345372 ^ f isNil 345373 ifTrue: ["Failed to open the file" 345374 (FileDoesNotExistException fileName: fullName) signal] 345375 ifFalse: [f]! ! 345376 345377!StandardFileStream class methodsFor: 'file creation' stamp: 'stephaneducasse 2/4/2006 20:32'! 345378isAFileNamed: fileName 345379 "Answer true if a file of the given name exists." 345380 345381 | f | 345382 f := self new open: fileName forWrite: false. 345383 f ifNil: [^ false]. 345384 f close. 345385 ^ true 345386! ! 345387 345388!StandardFileStream class methodsFor: 'file creation' stamp: 'stephaneducasse 2/4/2006 20:32'! 345389newFileNamed: fileName 345390 "Create a new file with the given name, and answer a stream opened for writing on that file. If the file already exists, ask the user what to do." 345391 345392 | fullName | 345393 fullName := self fullName: fileName. 345394 345395 ^(self isAFileNamed: fullName) 345396 ifTrue: ["file already exists:" 345397 (FileExistsException fileName: fullName fileClass: self) signal] 345398 ifFalse: [self new open: fullName forWrite: true] 345399 345400! ! 345401 345402!StandardFileStream class methodsFor: 'file creation' stamp: 'StephaneDucasse 8/30/2009 17:35'! 345403oldFileNamed: fileName 345404 "Open an existing file with the given name for reading and writing. If the name has no directory part, then the default directory will be assumed. If the file does not exist, an exception is signaled. If the file exists, its prior contents may be modified or replaced, but the file will not be truncated on close." 345405 345406 | fullName | 345407 fullName := self fullName: fileName. 345408 345409 ^(self isAFileNamed: fullName) 345410 ifTrue: [self new open: fullName forWrite: true] 345411 ifFalse: ["File does not exist..." 345412 (FileDoesNotExistException fileName: fullName) signal]! ! 345413 345414!StandardFileStream class methodsFor: 'file creation' stamp: 'stephaneducasse 2/4/2006 20:32'! 345415readOnlyFileNamed: fileName 345416 "Open an existing file with the given name for reading." 345417 345418 | fullName f | 345419 fullName := self fullName: fileName. 345420 f := self new open: fullName forWrite: false. 345421 ^ f isNil 345422 ifFalse: [f] 345423 ifTrue: ["File does not exist..." 345424 ((FileDoesNotExistException fileName: fullName) readOnly: true) signal]. 345425 345426 "StandardFileStream readOnlyFileNamed: 'kjsd.txt' "! ! 345427 345428 345429!StandardFileStream class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:41'! 345430register: anObject 345431 WeakArray isFinalizationSupported ifFalse:[^anObject]. 345432 self registry add: anObject! ! 345433 345434!StandardFileStream class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:41'! 345435registry 345436 WeakArray isFinalizationSupported ifFalse:[^nil]. 345437 ^Registry isNil 345438 ifTrue:[Registry := WeakRegistry new] 345439 ifFalse:[Registry].! ! 345440 345441!StandardFileStream class methodsFor: 'registry' stamp: 'stephaneducasse 2/4/2006 20:32'! 345442retryWithGC: execBlock until: testBlock forFileNamed: fullName 345443 "Re-implemented to only force GC if a file with the given name exists" 345444 | blockValue foundIt | 345445 blockValue := execBlock value. 345446 (testBlock value: blockValue) ifTrue:[^blockValue]. 345447 "See if we have a file with the given name" 345448 foundIt := Registry keys "hold on strongly for now" 345449 anySatisfy:[:file| file name sameAs: fullName]. 345450 foundIt ifFalse:[^blockValue]. 345451 Smalltalk garbageCollectMost. 345452 blockValue := execBlock value. 345453 (testBlock value: blockValue) ifTrue:[^blockValue]. 345454 Smalltalk garbageCollect. 345455 ^execBlock value.! ! 345456 345457!StandardFileStream class methodsFor: 'registry' stamp: 'ar 10/7/1998 15:23'! 345458unregister: anObject 345459 WeakArray isFinalizationSupported ifFalse:[^anObject]. 345460 self registry remove: anObject ifAbsent:[]! ! 345461Object subclass: #StandardScriptingSystem 345462 instanceVariableNames: '' 345463 classVariableNames: 'ClassVarNamesInUse FormDictionary HelpStrings StandardPartsBin' 345464 poolDictionaries: '' 345465 category: 'Morphic-Refactoring Candidates'! 345466!StandardScriptingSystem commentStamp: '<historical>' prior: 0! 345467An instance of this is installed as the value of the global variable "ScriptingSystem". Client subclasses are invited, such as one used internally by squeak team for ongoing internal work.! 345468 345469 345470!StandardScriptingSystem methodsFor: '*etoys-parts bin' stamp: 'sw 5/3/1999 22:40'! 345471prototypicalHolder 345472 | aHolder | 345473 aHolder := PasteUpMorph authoringPrototype color: Color orange muchLighter; borderColor: Color orange lighter. 345474 aHolder setNameTo: 'holder'; extent: 160 @ 110. 345475 ^ aHolder behaveLikeHolder. 345476! ! 345477 345478!StandardScriptingSystem methodsFor: '*etoys-parts bin' stamp: 'sw 10/27/1998 13:35'! 345479resetStandardPartsBin 345480 "ScriptingSystem resetStandardPartsBin" 345481 345482 StandardPartsBin := nil! ! 345483 345484 345485!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'ar 3/3/2001 19:45'! 345486deletePrivateGraphics 345487 "ScriptingSystem deletePrivateGraphics" 345488 self deletePrivateGraphics: self privateGraphics 345489 afterStoringToFileNamed: 'disGraphics'! ! 345490 345491!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'di 2/3/2001 20:10'! 345492deletePrivateGraphics: nameList afterStoringToFileNamed: aFileName 345493 "This method is used to strip private graphics from the FormDictionary and store them on a file of the given name" 345494 345495 | replacement toRemove aReferenceStream keySymbol | 345496 toRemove := Dictionary new. 345497 replacement := FormDictionary at: #Gets. 345498 345499 nameList do: 345500 [:aKey | 345501 keySymbol := aKey asSymbol. 345502 (toRemove at: keySymbol put: (self formAtKey: keySymbol)). 345503 FormDictionary at: keySymbol put: replacement]. 345504 345505 aReferenceStream := ReferenceStream fileNamed: aFileName. 345506 aReferenceStream nextPut: toRemove. 345507 aReferenceStream close! ! 345508 345509!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 2/24/2003 16:28'! 345510formAtKey: aString 345511 "Answer the form saved under the given key" 345512 345513 Symbol hasInterned: aString ifTrue: 345514 [:aKey | ^ FormDictionary at: aKey ifAbsent: [nil]]. 345515 ^ nil! ! 345516 345517!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'ar 3/3/2001 19:46'! 345518formAtKey: aKey extent: extent depth: depth 345519 "ScriptingSystem saveForm: (TileMorph downPicture) atKey: 'downArrow'" 345520 ^ FormDictionary at: aKey asSymbol ifAbsent: [Form extent: extent depth: depth]! ! 345521 345522!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'ar 3/3/2001 19:49'! 345523formDictionary 345524 ^FormDictionary! ! 345525 345526!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'ar 3/3/2001 19:44'! 345527privateGraphics 345528 "ScriptingSystem deletePrivateGraphics" 345529 ^#(#BadgeMiniPic #BadgePic #Broom #CedarPic #CollagePic #CoverMain #CoverSpiral #CoverTexture #Fred #ImagiPic #KayaPic #StudioPic)! ! 345530 345531!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 10/6/1999 20:57'! 345532saveForm: aForm atKey: aKey 345533 FormDictionary at: aKey asSymbol put: aForm! ! 345534 345535!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 10/24/1998 14:12'! 345536squeakyMouseForm 345537 ^ self formAtKey: 'squeakyMouse' 345538 345539" 345540 ScriptingSystem saveForm: (Form 345541 extent: 30@29 345542 depth: 16 345543 fromArray: #( 1811114995 1878286257 2012637171 1811180532 1811180533 1811179508 1811180532 1811179508 1744006133 1878289396 1811180533 1878289396 1744007156 1674736630 1744006132 1811114995 1811181556 1744006131 1811246068 1811180532 1811179508 1811180532 1744071668 1811113972 1811180532 1811180532 1811179507 1878288338 1945529332 1744071668 1743941620 1811112945 1811179506 1811114995 1744006131 1744006130 1744005106 1811048434 1811113969 1743939570 1811179506 1743939571 1676833782 1676765171 1811047410 1744006131 1811048435 1811116020 1811180531 1743939571 1811048435 1743939570 1743939570 1743939570 1743940594 1744005106 1811181556 1811180532 1676766196 1743939570 1878420468 1676963830 1189896082 1811245044 1744137204 1744070644 1811179508 1811113971 1743939571 1811179508 1811246070 1811309524 1811302093 1811310580 1811246068 1674867703 1744049472 1120606594 1118465013 1744137205 1811179508 1811180532 1744071667 1744006132 1811112947 1811247095 1605584589 358761132 289435638 1676830707 1741975543 1462778473 1811312631 702891724 1811310548 1945528308 1811178450 1945528307 1878288372 1878353875 1878421494 1051471335 1809213397 1118524175 1811246068 1945659348 1185698607 1878486005 1672694510 1118531574 1607626741 1878420467 1811180533 1743942645 1744072693 1811301035 1185770487 1878486006 1324239597 1811180533 1811116019 1120623438 1878352818 1945462739 704868339 1878289395 1811049459 1878221808 1878223859 1743876083 1811162563 1945463796 1811181556 1464746666 1811116018 1809019893 1120551562 1945464821 1741844468 1466842760 1878289395 1811048434 1811050483 1811050483 1878223859 1049188174 1741910004 1811181556 1256998634 1811114994 1878289396 1466840647 1744007156 1744006131 1676877216 1743940596 1878222835 1743938545 1878351792 1676833781 358641652 1743940596 1811050484 845566798 1811113970 1811114995 1811163652 1811112913 1878420468 1878282028 1811179506 1607560178 1878289395 1676900342 1878351825 1466853330 1811113971 1811116019 635659217 1811179506 1811245045 1676942754 1744137206 1744201717 1676962806 1676962805 1811310581 1676896245 1744199635 1811376117 1744072695 1744005109 1811244019 499279861 1811310581 1811244020 1811293668 1399943159 1605528567 1744136181 982063522 986342388 1744070645 1744189066 430063308 1744071669 1744070644 1744067504 566519797 1744136181 1744137205 1743999854 912813044 1811311606 1742162607 4195488 283139922 1945531382 1253113857 144710948 1601400791 1811246069 1811167879 1464821747 1744136180 1674799094 1811178482 843473875 1811311606 1878533542 2106790 2080066222 1876193270 696845376 627472380 1185772536 1878355957 1743990309 1744007157 1676898294 1744006132 1811114996 1743941620 1811180533 1809204941 4194368 4217681 1878290421 1252982848 4194336 1670540278 1739811795 1878353906 1744006131 1811179506 1744007157 1744005106 1945462771 1811182582 1811311574 1393641133 1462856629 2012638196 1876382449 1112301394 1742041045 1945596917 1676833781 1811113970 1811179507 1811180532 1672705014 1674735606 1672697648 1945725943 1878551479 1809215479 1811312629 1809216504 1809215479 1809215478 1462853490 1878487029 1744007158 1744005075 1811239726 704979363 495004132 700789287 562372997 631646663 1739998892 4194400 1116497846 698688932 562375109 770124262 633609569 495070758 1257010166 562315916 1809279958 2012894002 1047280171 980237901 910966381 1668677696 4194400 6314867 1047281260 908804749 910968495 1393719290 1809279959 1185750370 1809214455 1878469062 423836236 1532188466 1601592148 1462986647 1672937568 4194368 6319062 1603622706 1601525554 1601522417 1047336194 770206679 1878487031 1878409899 977955830 1809145716 1118586509 980105834 980045584 1811372914 980104778 1605526483 1395605131 910769804 1118651052 1534358520 1809136234 1118596053 1532059506 1878485973 1326456163 1945660374 1742106615 1811311607 1945725942 1742107641 1744072693 1811311605 1744203767 1878551543 564478604 1878553591 1603428242 1811048433 1811049459 1051290611 1744006131 1811049459 1878156273 1743874034 1744007156 1743874033 1811048434 1811113970 1743939571 1743933228 1603301363 1743875059 1811049458 1945461745 1811181556 1811113971 1811049458 1811048434 1811116020 1878287346 1878223857 1743940594 1744006130 1744007157 1945395153 1945400309 1811048434 1743810547 1676765170 1878353906 1811113970 1743874032 1810983921 1743874033 1811113971 1676765169 1743874034 1743940593 1743939569 1811047409 1676765168 1743940595 1810981872 1945397235 1607560179 1743941620 1810982897 1810983921 1811048433 1744007155 1743875059 1811048434 1743875058 1743939568 1676832754 1811116019 1811114994 1811244019 1676962805 1677029367 1811244020 1744005106 1743940594 1811246068 1744070645 1676961781 1744004084 1676897269 1811180533 1878353908 1744004083 1744070645) 345544 offset: 0@0) atKey: 'squeakyMouse'"! ! 345545 345546 345547!StandardScriptingSystem methodsFor: 'help dictionary' stamp: 'dgd 9/1/2003 14:25'! 345548helpStringOrNilFor: aSymbol 345549 "If my HelpStrings dictionary has an entry at the given symbol, 345550 answer that entry's value, else answer nil" 345551 HelpStrings 345552 at: aSymbol 345553 ifPresent:[:string | ^ string translated]. 345554^ nil! ! 345555 345556 345557!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 11/26/1999 15:44'! 345558stripGraphicsForExternalRelease 345559 "ScriptingSystem stripGraphicsForExternalRelease" 345560 345561 | replacement | 345562 replacement := FormDictionary at: #Gets. 345563 345564 #('BadgeMiniPic' 'BadgePic' 'Broom' 'CedarPic' 'CollagePic' 'CoverMain' 'CoverSpiral' 'CoverTexture' 'Fred' 'ImagiPic' 'KayaPic' 'StudioPic') 345565 do: 345566 [:aKey | FormDictionary at: aKey asSymbol put: replacement]! ! 345567 345568"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 345569 345570StandardScriptingSystem class 345571 instanceVariableNames: ''! 345572 345573!StandardScriptingSystem class methodsFor: 'utilities' stamp: 'nk 9/1/2004 10:53'! 345574applyNewEToyLook 345575 "Apply the new EToy look based on free fonts, approximating the classic look as closely as possible." 345576 345577 "StandardScriptingSystem applyNewEToyLook" 345578 345579" | aTextStyle aFont | 345580 aTextStyle := TextStyle named: #BitstreamVeraSansMono. 345581 aFont := aTextStyle fontOfSize: 12. 345582 aFont := aFont emphasis: 1. 345583 Preferences setEToysFontTo: aFont. 345584 Preferences setButtonFontTo: aFont. 345585 345586 aTextStyle := TextStyle named: #Accushi. 345587 aFont := aTextStyle fontOfSize: 12. 345588 Preferences setFlapsFontTo: aFont. 345589 345590 (aTextStyle := TextStyle named: #Accuny) 345591 ifNotNil: 345592 [Preferences setSystemFontTo: (aTextStyle fontOfSize: 12)]" 345593 345594 Preferences setDefaultFonts: #( 345595 (setEToysFontTo: BitstreamVeraSansBold 10) 345596 (setButtonFontTo: BitstreamVeraSansMono 9) 345597 (setFlapsFontTo: Accushi 12) 345598 (setSystemFontTo: Accuny 10) 345599 (setWindowTitleFontTo: BitstreamVeraSansBold 12) 345600 ) 345601! ! 345602 345603!StandardScriptingSystem class methodsFor: 'utilities' stamp: 'mir 11/26/2004 16:14'! 345604removePlayersIn: project 345605 "Remove existing player references for project" 345606 345607 References keys do: 345608 [:key | (References at: key) costume pasteUpMorph == project world 345609 ifTrue: [References removeKey: key]]. 345610! ! 345611 345612!StandardScriptingSystem class methodsFor: 'utilities' stamp: 'mir 11/25/2004 19:01'! 345613removeUnreferencedPlayers 345614 "Remove existing but unreferenced player references" 345615 "StandardScriptingSystem removeUnreferencedPlayers" 345616 References keys do: 345617 [:key | (References at: key) costume pasteUpMorph 345618 ifNil: [References removeKey: key]]. 345619! ! 345620 345621!StandardScriptingSystem class methodsFor: 'utilities' stamp: 'asm 4/12/2003 14:38'! 345622unload 345623 "Unload the receiver from global registries" 345624 345625 self environment at: #Flaps ifPresent: [:cl | 345626 cl unregisterQuadsWithReceiver: ScriptingSystem] ! ! 345627SourceFileArray subclass: #StandardSourceFileArray 345628 instanceVariableNames: 'files' 345629 classVariableNames: '' 345630 poolDictionaries: '' 345631 category: 'Files-System'! 345632!StandardSourceFileArray commentStamp: '<historical>' prior: 0! 345633This class implements the source file management behavior of traditional Squeak, with a sources file and a changes file. File positions are mapped such that those files can be up to 32MBytes in size. 345634 345635Structure: 345636 files Array -- storing the actual source files 345637! 345638 345639 345640!StandardSourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/25/2000 21:20'! 345641at: index 345642 ^files at: index! ! 345643 345644!StandardSourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/25/2000 21:20'! 345645at: index put: aFile 345646 files at: index put: aFile! ! 345647 345648!StandardSourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/25/2000 21:20'! 345649size 345650 ^files size! ! 345651 345652 345653!StandardSourceFileArray methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:06'! 345654initialize 345655 super initialize. 345656 files := Array new: 2. 345657 files at: 1 put: (SourceFiles at: 1). 345658 files at: 2 put: (SourceFiles at: 2)! ! 345659 345660!StandardSourceFileArray methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:32'! 345661initialize: nFiles 345662 files := Array new: nFiles! ! 345663 345664 345665!StandardSourceFileArray methodsFor: 'sourcepointer conversion' stamp: 'stephaneducasse 2/4/2006 20:32'! 345666fileIndexFromSourcePointer: anInteger 345667 "Return the index of the source file which contains the source chunk addressed by anInteger" 345668 "This implements the recent 32M source file algorithm" 345669 345670 | hi | 345671 hi := anInteger // 16r1000000. 345672 ^hi < 3 345673 ifTrue: [hi] 345674 ifFalse: [hi - 2]! ! 345675 345676!StandardSourceFileArray methodsFor: 'sourcepointer conversion' stamp: 'stephaneducasse 2/4/2006 20:32'! 345677filePositionFromSourcePointer: anInteger 345678 "Return the position of the source chunk addressed by anInteger" 345679 "This implements the recent 32M source file algorithm" 345680 345681 | hi lo | 345682 hi := anInteger // 16r1000000. 345683 lo := anInteger \\ 16r1000000. 345684 ^hi < 3 345685 ifTrue: [lo] 345686 ifFalse: [lo + 16r1000000]! ! 345687 345688!StandardSourceFileArray methodsFor: 'sourcepointer conversion' stamp: 'stephaneducasse 2/4/2006 20:32'! 345689sourcePointerFromFileIndex: index andPosition: position 345690 | hi lo | 345691 "Return a source pointer according to the new 32M algorithm" 345692 ((index between: 1 and: 2) and: [position between: 0 and: 16r1FFFFFF]) 345693 ifFalse: [self error: 'invalid source code pointer']. 345694 hi := index. 345695 lo := position. 345696 lo >= 16r1000000 ifTrue: [ 345697 hi := hi+2. 345698 lo := lo - 16r1000000]. 345699 ^hi * 16r1000000 + lo! ! 345700 345701"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 345702 345703StandardSourceFileArray class 345704 instanceVariableNames: ''! 345705 345706!StandardSourceFileArray class methodsFor: 'initialization' stamp: 'nk 7/30/2004 21:50'! 345707install 345708 "Replace SourceFiles by an instance of me with the standard sources and changes files. 345709 This only works if SourceFiles is either an Array or an instance of this class" 345710 345711 "StandardSourceFileArray install" 345712 345713 SourceFiles := self new! ! 345714 345715!StandardSourceFileArray class methodsFor: 'initialization' stamp: 'ar 5/17/2000 18:27'! 345716new: nFiles 345717 ^self new initialize: nFiles.! ! 345718TestCase subclass: #StandardSystemFontsTest 345719 instanceVariableNames: '' 345720 classVariableNames: '' 345721 poolDictionaries: '' 345722 category: 'Tests-SystemTests-Support'! 345723 345724!StandardSystemFontsTest methodsFor: 'testing' stamp: 'M 8/30/2009 13:21'! 345725testRestoreDefaultFonts 345726 self saveStandardSystemFontsDuring: [ 345727 Preferences restoreDefaultFonts. 345728 self assert: #standardDefaultTextFont familyName: 'Accuny' pointSize: 9. 345729 self assert: #standardListFont familyName: 'Accuny' pointSize: 9. 345730 self assert: #standardMenuFont familyName: 'Accuny' pointSize: 9. 345731 self assert: #windowTitleFont familyName: 'Accuny' pointSize: 12. 345732 self assert: #standardBalloonHelpFont familyName: 'Accuny' pointSize: 10. 345733 self assert: #standardCodeFont familyName: 'Accuny' pointSize: 9. 345734 self assert: #standardButtonFont familyName: 'Accuny' pointSize: 9]! ! 345735 345736 345737!StandardSystemFontsTest methodsFor: 'utilities' stamp: 'bp 6/13/2004 18:22'! 345738assert: selector familyName: aString pointSize: anInteger 345739 345740 | font | 345741 font := Preferences perform: selector. 345742 self assert: font familyName = aString. 345743 self assert: font pointSize = anInteger 345744 ! ! 345745 345746!StandardSystemFontsTest methodsFor: 'utilities' stamp: 'bp 6/13/2004 21:51'! 345747saveStandardSystemFontsDuring: aBlock 345748 345749 | standardDefaultTextFont standardListFont standardEToysFont standardMenuFont 345750 windowTitleFont standardBalloonHelpFont standardCodeFont standardButtonFont | 345751 345752 standardDefaultTextFont := Preferences standardDefaultTextFont. 345753 standardListFont := Preferences standardListFont. 345754 standardEToysFont := Preferences standardEToysFont. 345755 standardMenuFont := Preferences standardMenuFont. 345756 windowTitleFont := Preferences windowTitleFont. 345757 standardBalloonHelpFont := Preferences standardBalloonHelpFont. 345758 standardCodeFont := Preferences standardCodeFont. 345759 standardButtonFont := Preferences standardButtonFont. 345760 [aBlock value] ensure: [ 345761 Preferences setSystemFontTo: standardDefaultTextFont. 345762 Preferences setListFontTo: standardListFont. 345763 Preferences setEToysFontTo: standardEToysFont. 345764 Preferences setMenuFontTo: standardMenuFont. 345765 Preferences setWindowTitleFontTo: windowTitleFont. 345766 Preferences setBalloonHelpFontTo: standardBalloonHelpFont. 345767 Preferences setCodeFontTo: standardCodeFont. 345768 Preferences setButtonFontTo: standardButtonFont]. 345769! ! 345770Object subclass: #StandardToolSet 345771 instanceVariableNames: '' 345772 classVariableNames: '' 345773 poolDictionaries: '' 345774 category: 'Tools-Base'! 345775!StandardToolSet commentStamp: '<historical>' prior: 0! 345776Main comment stating the purpose of this class and relevant relationship to other classes. 345777 345778Possible useful expressions for doIt or printIt. 345779 345780Structure: 345781 instVar1 type -- comment about the purpose of instVar1 345782 instVar2 type -- comment about the purpose of instVar2 345783 345784Any further useful comments about the general approach of this implementation.! 345785 345786 345787"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 345788 345789StandardToolSet class 345790 instanceVariableNames: ''! 345791 345792!StandardToolSet class methodsFor: '*MonticelloGUI' stamp: 'al 10/12/2008 19:48'! 345793openMonticelloBrowser 345794 MCWorkingCopyBrowser open! ! 345795 345796!StandardToolSet class methodsFor: '*MonticelloGUI' stamp: 'al 10/12/2008 21:13'! 345797openMonticelloConfigurations 345798 MCConfigurationBrowser open! ! 345799 345800 345801!StandardToolSet class methodsFor: 'browsing' stamp: 'ar 7/16/2005 15:20'! 345802browseChangeSetsWithClass: aClass selector: aSelector 345803 "Browse all the change sets with the given class/selector" 345804 ^ChangeSorter browseChangeSetsWithClass: aClass selector: aSelector! ! 345805 345806!StandardToolSet class methodsFor: 'browsing' stamp: 'md 3/10/2006 21:42'! 345807browseHierarchy: aClass selector: aSelector 345808 "Open a browser" 345809 | newBrowser | 345810 (aClass == nil) ifTrue: [^ self]. 345811 (newBrowser := SystemBrowser default new) setClass: aClass selector: aSelector. 345812 newBrowser spawnHierarchy.! ! 345813 345814!StandardToolSet class methodsFor: 'browsing' stamp: 'davidroethlisberger 2/11/2009 12:00'! 345815browseImplementorsOf: aSymbol name: titleString autoSelect: autoSelectString 345816 ^self browseMessageSet: (SystemNavigation default allImplementorsOf: aSymbol) asSortedCollection name: titleString autoSelect: autoSelectString! ! 345817 345818!StandardToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 11:12'! 345819browseMessageNames: aString 345820 ^(MessageNames methodBrowserSearchingFor: aString) openInWorld! ! 345821 345822!StandardToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 11:13'! 345823browseMessageSet: messageList name: title autoSelect: autoSelectString 345824 "Open a message set browser" 345825 ^MessageSet 345826 openMessageList: messageList 345827 name: title 345828 autoSelect: autoSelectString! ! 345829 345830!StandardToolSet class methodsFor: 'browsing' stamp: 'davidroethlisberger 2/11/2009 11:59'! 345831browseSendersOf: aSymbol name: titleString autoSelect: autoSelectString 345832 ^self browseMessageSet: (SystemNavigation default allCallsOn: aSymbol) asSortedCollection name: titleString autoSelect: autoSelectString! ! 345833 345834!StandardToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 11:35'! 345835browseVersionsOf: aClass selector: aSelector 345836 "Open a browser" 345837 VersionsBrowser 345838 browseVersionsOf: (aClass compiledMethodAt: aSelector) 345839 class: aClass theNonMetaClass 345840 meta: aClass isMeta 345841 category: (aClass organization categoryOfElement: aSelector) 345842 selector: aSelector! ! 345843 345844!StandardToolSet class methodsFor: 'browsing' stamp: 'md 3/10/2006 21:43'! 345845browse: aClass selector: aSelector 345846 "Open a browser" 345847 ^SystemBrowser default fullOnClass: aClass selector: aSelector! ! 345848 345849!StandardToolSet class methodsFor: 'browsing' stamp: 'ar 7/15/2005 18:58'! 345850openChangedMessageSet: aChangeSet 345851 "Open a ChangedMessageSet for aChangeSet" 345852 ChangedMessageSet openFor: aChangeSet! ! 345853 345854!StandardToolSet class methodsFor: 'browsing' stamp: 'ar 7/15/2005 18:58'! 345855openClassListBrowser: anArray title: aString 345856 "Open a class list browser" 345857 ^ClassListBrowser new initForClassesNamed: anArray title: aString 345858! ! 345859 345860 345861!StandardToolSet class methodsFor: 'completion' stamp: 'damiencassou 7/29/2009 16:12'! 345862codeCompletionAround: aBlock textMorph: aTextMorph keyStroke: evt 345863 ^ aBlock value! ! 345864 345865 345866!StandardToolSet class methodsFor: 'debugging' stamp: 'ar 7/15/2005 19:15'! 345867debugContext: aContext label: aString contents: contents 345868 "Open a debugger on the given process and context." 345869 ^Debugger openContext: aContext label: aString contents: contents! ! 345870 345871!StandardToolSet class methodsFor: 'debugging' stamp: 'ar 7/17/2005 11:16'! 345872debugError: anError 345873 "Handle an otherwise unhandled error" 345874 ^Processor activeProcess 345875 debug: anError signalerContext 345876 title: anError description! ! 345877 345878!StandardToolSet class methodsFor: 'debugging' stamp: 'ar 9/27/2005 19:18'! 345879debugSyntaxError: anError 345880 "Handle a syntax error" 345881 | notifier | 345882 notifier := SyntaxError new 345883 setClass: anError errorClass 345884 code: anError errorCode 345885 debugger: (Debugger context: anError signalerContext) 345886 doitFlag: anError doitFlag. 345887 notifier category: anError category. 345888 SyntaxError open: notifier.! ! 345889 345890!StandardToolSet class methodsFor: 'debugging' stamp: 'ar 7/15/2005 18:57'! 345891debug: aProcess context: aContext label: aString contents: contents fullView: aBool 345892 "Open a debugger on the given process and context." 345893 ^Debugger openOn: aProcess context: aContext label: aString contents: contents fullView: aBool! ! 345894 345895!StandardToolSet class methodsFor: 'debugging' stamp: 'ar 7/17/2005 11:16'! 345896interrupt: aProcess label: aString 345897 "Open a debugger on the given process and context." 345898 Debugger 345899 openInterrupt: aString 345900 onProcess: aProcess! ! 345901 345902 345903!StandardToolSet class methodsFor: 'initialization' stamp: 'ar 7/17/2005 01:04'! 345904initialize 345905 ToolSet register: self. 345906 Preferences installMissingWindowColors.! ! 345907 345908!StandardToolSet class methodsFor: 'initialization' stamp: 'ar 7/16/2005 16:18'! 345909unload 345910 ToolSet unregister: self.! ! 345911 345912 345913!StandardToolSet class methodsFor: 'inspecting' stamp: 'ar 7/15/2005 18:57'! 345914basicInspect: anObject 345915 "Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides." 345916 ^BasicInspector openOn: anObject! ! 345917 345918!StandardToolSet class methodsFor: 'inspecting' stamp: 'ar 7/15/2005 19:34'! 345919explore: anObject 345920 "Open an explorer on the given object." 345921 ^ObjectExplorer new openExplorerFor: anObject! ! 345922 345923!StandardToolSet class methodsFor: 'inspecting' stamp: 'ar 7/15/2005 19:54'! 345924inspectorClassOf: anObject 345925 "Answer the inspector class for the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides." 345926 | map | 345927 map := Dictionary new. 345928 #( 345929 (CompiledMethod CompiledMethodInspector) 345930 (CompositeEvent OrderedCollectionInspector) 345931 (Dictionary DictionaryInspector) 345932 (ExternalStructure ExternalStructureInspector) 345933 (FloatArray OrderedCollectionInspector) 345934 (OrderedCollection OrderedCollectionInspector) 345935 (Set SetInspector) 345936 (WeakSet WeakSetInspector) 345937 ) do:[:spec| 345938 map at: spec first put: spec last. 345939 ]. 345940 anObject class withAllSuperclassesDo:[:cls| 345941 map at: cls name ifPresent:[:inspectorName| ^Smalltalk classNamed: inspectorName]. 345942 ]. 345943 ^Inspector! ! 345944 345945!StandardToolSet class methodsFor: 'inspecting' stamp: 'ar 7/15/2005 18:58'! 345946inspect: anObject 345947 "Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides." 345948 ^(self inspectorClassOf: anObject) openOn: anObject! ! 345949 345950!StandardToolSet class methodsFor: 'inspecting' stamp: 'ar 7/15/2005 19:57'! 345951inspect: anObject label: aString 345952 "Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides." 345953 ^(self inspectorClassOf: anObject) openOn: anObject withEvalPane: true withLabel: aString! ! 345954 345955 345956!StandardToolSet class methodsFor: 'menu' stamp: 'al 10/23/2008 20:34'! 345957mainMenuItems 345958 "Answer the most important menu items available for this tool set" 345959 ^#( 345960 ('Class Browser' #openClassBrowser) 345961 ('Workspace' #openWorkspace) 345962 ('Test Runner' #openTestRunner) 345963 ('Monticello Browser' #openMonticelloBrowser) 345964 ) 345965! ! 345966 345967!StandardToolSet class methodsFor: 'menu' stamp: 'OscarNierstrasz 9/29/2009 12:42'! 345968menuItems 345969 "Answer the menu items available for this tool set" 345970 ^#( 345971 ('Class Browser' #openClassBrowser) 345972 ('Message Names' #openMessageNames) 345973 ('Method Finder' #openMethodFinder) 345974 - 345975 ('Workspace' #openWorkspace) 345976 ('Transcript' #openTranscript) 345977 ('File Browser' #openFileList) 345978 - 345979 ('Test Runner' #openTestRunner) 345980 ('Process Browser' #openProcessBrowser) 345981 - 345982 ('Monticello Browser' #openMonticelloBrowser) 345983 "('Monticello Configurations' #openMonticelloConfigurations)" 345984 ('Recover lost changes...' #openRecentChangesLog) 345985 "('Simple Change Sorter' #openChangeSorter)" 345986 ('Change Sorter' #openDualChangeSorter) 345987 ) 345988! ! 345989 345990!StandardToolSet class methodsFor: 'menu' stamp: 'ar 7/17/2005 13:05'! 345991openChangeSorter 345992 ChangeSorter new morphicWindow openInWorld! ! 345993 345994!StandardToolSet class methodsFor: 'menu' stamp: 'md 3/10/2006 21:47'! 345995openClassBrowser 345996 SystemBrowser default open! ! 345997 345998!StandardToolSet class methodsFor: 'menu' stamp: 'ar 7/17/2005 13:05'! 345999openDualChangeSorter 346000 DualChangeSorter new morphicWindow openInWorld! ! 346001 346002!StandardToolSet class methodsFor: 'menu' stamp: 'hfm 11/29/2008 20:06'! 346003openFileList 346004 FileList prototypicalToolWindow openInWorld.! ! 346005 346006!StandardToolSet class methodsFor: 'menu' stamp: 'ar 7/17/2005 12:59'! 346007openMessageNames 346008 "Bring a MessageNames tool to the front" 346009 MessageNames openMessageNames! ! 346010 346011!StandardToolSet class methodsFor: 'menu' stamp: 'al 10/27/2008 17:26'! 346012openMethodFinder 346013 SelectorBrowser new open! ! 346014 346015!StandardToolSet class methodsFor: 'menu' stamp: 'ar 7/17/2005 12:59'! 346016openProcessBrowser 346017 ProcessBrowser open! ! 346018 346019!StandardToolSet class methodsFor: 'menu' stamp: 'al 10/12/2008 21:11'! 346020openRecentChangesLog 346021 ChangeList browseRecentLog! ! 346022 346023!StandardToolSet class methodsFor: 'menu' stamp: 'adrian.lienhard 8/12/2009 22:47'! 346024openTestRunner 346025 Smalltalk at: #TestRunner ifPresent: [ :class | ^ class open ]. 346026 self inform: 'No test runner installed.'! ! 346027 346028!StandardToolSet class methodsFor: 'menu' stamp: 'al 10/12/2008 19:07'! 346029openTranscript 346030 Transcript open! ! 346031 346032!StandardToolSet class methodsFor: 'menu' stamp: 'md 1/18/2006 19:08'! 346033openWorkspace 346034 Workspace open! ! 346035SystemWindow subclass: #StandardWindow 346036 uses: TEasilyThemed - {#theme} 346037 instanceVariableNames: '' 346038 classVariableNames: '' 346039 poolDictionaries: '' 346040 category: 'Polymorph-Widgets-Windows'! 346041!StandardWindow commentStamp: 'gvc 5/18/2007 12:05' prior: 0! 346042Themed SystemWindow that avoids being picked up except via the title bar. Supports opening in "fullscreen" mode, taking docking bars into account (not flaps though). 346043Prevents yellow button menu. 346044Uses TEasilyThemed for easy theme access to subclasses.! 346045 346046 346047!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 10:57'! 346048basicIsSticky 346049 "Answer the super isSticky." 346050 346051 ^super isSticky! ! 346052 346053!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 10:36'! 346054defaultColor 346055 "Answer the default color/fill style for the receiver" 346056 346057 ^self theme windowColor! ! 346058 346059!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 10:33'! 346060defaultLabel 346061 "Answer the default label for the receiver." 346062 346063 ^'Window' translated! ! 346064 346065!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 11:39'! 346066delete 346067 "If fullscreen remove the owner too." 346068 346069 self mustNotClose ifTrue: [^ self]. 346070 self model okToChange ifFalse: [^ self]. 346071 self model okToClose ifFalse: [^self]. 346072 self isFullscreen 346073 ifTrue: [self owner delete] 346074 ifFalse: [super delete]! ! 346075 346076!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/12/2006 16:26'! 346077flash 346078 "Flash the window." 346079 346080 |fs c w d| 346081 fs := self fillStyle. 346082 c := self color alphaMixed: 0.5 with: Color white. 346083 w := self world. 346084 d := 0. 346085 2 timesRepeat: [ 346086 (Delay forDuration: d milliSeconds) wait. 346087 d := 200. 346088 self color: c. 346089 w ifNotNil: [w displayWorldSafely]. 346090 (Delay forDuration: d milliSeconds) wait. 346091 self fillStyle: fs. 346092 w ifNotNil: [w displayWorldSafely]] 346093! ! 346094 346095!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 10:37'! 346096initialize 346097 "Initialize the receiver." 346098 346099 super initialize. 346100 self 346101 setLabel: self defaultLabel; 346102 setWindowColor: self defaultColor! ! 346103 346104!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 16:47'! 346105isFullscreen 346106 "Answer whether the window should be draw as fullscreen, i.e. 346107 no title bar or borders." 346108 346109 ^self owner isKindOf: FullscreenMorph! ! 346110 346111!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 10:58'! 346112isSticky 346113 "Override here to stop the window being grabbed except via title bar." 346114 346115 ^true! ! 346116 346117!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 19:33'! 346118makeBorderless 346119 "Remove the border and border width offsets.." 346120 346121 |l b| 346122 b := self class borderWidth. 346123 self submorphsDo: [:m | 346124 l := m layoutFrame. 346125 l ifNotNil: [ 346126 l rightFraction = 1 ifTrue: [l rightOffset: l rightOffset + b]. 346127 l leftFraction = 0 ifTrue: [l leftOffset: l leftOffset - b]. 346128 l bottomFraction = 1 ifTrue: [l bottomOffset: l bottomOffset + b]]]. 346129 self borderWidth: 0! ! 346130 346131!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/29/2006 12:12'! 346132model: anObject 346133 "Reset the minimum extent." 346134 346135 super model: anObject. 346136 self title: self title! ! 346137 346138!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 6/21/2007 16:07'! 346139mouseMove: evt 346140 "Handle a mouse-move event" 346141 346142 | cp | 346143 self isFullscreen ifTrue: [^self]. "do nothing if fullscreen" 346144 cp := evt cursorPoint. 346145 self valueOfProperty: #clickPoint ifPresentDo: 346146 [:firstClick | 346147 ((self labelRect containsPoint: firstClick) and: [(cp dist: firstClick) > 3]) ifTrue: 346148 ["If this is a drag that started in the title bar, then pick me up" 346149 ^self basicIsSticky ifFalse: 346150 [self fastFramingOn 346151 ifTrue: [self doFastFrameDrag: firstClick] 346152 ifFalse: [evt hand grabMorph: self topRendererOrSelf]]]]. 346153 model windowActiveOnFirstClick ifTrue: 346154 ["Normally window takes control on first click. 346155 Need explicit transmission for first-click activity." 346156 submorphs do: [:m | (m containsPoint: cp) ifTrue: [m mouseMove: evt]]]! ! 346157 346158!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/7/2008 11:45'! 346159noteNewOwner: aMorph 346160 "Go fullscreen if needed." 346161 346162 super noteNewOwner: aMorph. 346163 (self isFullscreen and: [labelArea owner notNil]) ifTrue: [ 346164 self 346165 beWithoutGrips; 346166 removeLabelArea; 346167 makeBorderless. 346168 (self submorphs size = 1 and: [self submorphs first isKindOf: PanelMorph]) 346169 ifTrue: [self submorphs first roundedCorners: #()]]! ! 346170 346171!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 12:07'! 346172open 346173 "Where else would you want to open it?." 346174 346175 self openInWorld! ! 346176 346177!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/13/2006 09:55'! 346178openAsIsIn: aWorld 346179 "Sad fixup for dodgy layout." 346180 346181 super openAsIsIn: aWorld. 346182 self allMorphs do: [:m | m layoutChanged]! ! 346183 346184!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 12:01'! 346185openFullscreen 346186 "Open the receiver in a FullscreenMorph." 346187 346188 ^FullscreenMorph new 346189 setContentMorph: self; 346190 openInWorld! ! 346191 346192!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 13:00'! 346193openedFullscreen 346194 "Should activate and update the layout." 346195 346196 self allMorphs do: [:m | m layoutChanged]. 346197 self activate! ! 346198 346199!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 19:20'! 346200wantsRoundedCorners 346201 "Check to see if the property is set first." 346202 346203 ^self isFullscreen 346204 ifTrue: [false] 346205 ifFalse: [^super wantsRoundedCorners]! ! 346206 346207!StandardWindow methodsFor: 'as yet unclassified' stamp: 'gvc 10/16/2006 14:15'! 346208yellowButtonActivity: shiftState 346209 "Do nothing."! ! 346210 346211 346212!StandardWindow methodsFor: 'controls'! 346213newAlphaImage: aForm help: helpText 346214 "Answer an alpha image morph." 346215 346216 ^self theme 346217 newAlphaImageIn: self 346218 image: aForm 346219 help: helpText! ! 346220 346221!StandardWindow methodsFor: 'controls'! 346222newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText 346223 "Answer an alpha channel selector with the given selectors." 346224 346225 ^self theme 346226 newAlphaSelectorIn: self 346227 for: aModel 346228 getAlpha: getSel 346229 setAlpha: setSel 346230 help: helpText! ! 346231 346232!StandardWindow methodsFor: 'controls'! 346233newAutoAcceptTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 346234 "Answer a text editor for the given model." 346235 346236 ^self theme 346237 newAutoAcceptTextEditorIn: self 346238 for: aModel 346239 getText: getSel 346240 setText: setSel 346241 getEnabled: enabledSel! ! 346242 346243!StandardWindow methodsFor: 'controls'! 346244newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText 346245 "Answer a text entry for the given model." 346246 346247 ^self theme 346248 newAutoAcceptTextEntryIn: self 346249 for: aModel 346250 get: getSel 346251 set: setSel 346252 class: aClass 346253 getEnabled: enabledSel 346254 font: aFont 346255 help: helpText! ! 346256 346257!StandardWindow methodsFor: 'controls'! 346258newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText 346259 "Answer a text entry for the given model." 346260 346261 ^self theme 346262 newAutoAcceptTextEntryIn: self 346263 for: aModel 346264 get: getSel 346265 set: setSel 346266 class: aClass 346267 getEnabled: enabledSel 346268 help: helpText! ! 346269 346270!StandardWindow methodsFor: 'controls'! 346271newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText 346272 "Answer a text entry for the given model." 346273 346274 ^self theme 346275 newAutoAcceptTextEntryIn: self 346276 for: aModel 346277 get: getSel 346278 set: setSel 346279 class: String 346280 getEnabled: enabledSel 346281 font: aFont 346282 help: helpText 346283! ! 346284 346285!StandardWindow methodsFor: 'controls'! 346286newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText 346287 "Answer a text entry for the given model." 346288 346289 ^self theme 346290 newAutoAcceptTextEntryIn: self 346291 for: aModel 346292 get: getSel 346293 set: setSel 346294 class: String 346295 getEnabled: enabledSel 346296 help: helpText! ! 346297 346298!StandardWindow methodsFor: 'controls'! 346299newBalloonHelp: aTextStringOrMorph for: aMorph 346300 "Answer a new balloon help with the given contents for aMorph 346301 at a given corner." 346302 346303 ^self theme 346304 newBalloonHelpIn: self 346305 contents: aTextStringOrMorph 346306 for: aMorph 346307 corner: #bottomLeft! ! 346308 346309!StandardWindow methodsFor: 'controls'! 346310newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol 346311 "Answer a new balloon help with the given contents for aMorph 346312 at a given corner." 346313 346314 ^self theme 346315 newBalloonHelpIn: self 346316 contents: aTextStringOrMorph 346317 for: aMorph 346318 corner: cornerSymbol! ! 346319 346320!StandardWindow methodsFor: 'controls'! 346321newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText 346322 "Answer a bracket slider with the given selectors." 346323 346324 ^self theme 346325 newBracketSliderIn: self 346326 for: aModel 346327 getValue: getSel 346328 setValue: setSel 346329 min: minValue 346330 max: maxValue 346331 quantum: quantum 346332 getEnabled: enabledSel 346333 help: helpText! ! 346334 346335!StandardWindow methodsFor: 'controls'! 346336newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText 346337 "Answer a bracket slider with the given selectors." 346338 346339 ^self 346340 newBracketSliderFor: aModel 346341 getValue: getSel 346342 setValue: setSel 346343 min: minValue 346344 max: maxValue 346345 quantum: quantum 346346 getEnabled: nil 346347 help: helpText! ! 346348 346349!StandardWindow methodsFor: 'controls'! 346350newButtonFor: aModel action: actionSel getEnabled: enabledSel label: stringOrText help: helpText 346351 "Answer a new button." 346352 346353 ^self 346354 newButtonFor: aModel 346355 getState: nil 346356 action: actionSel 346357 arguments: nil 346358 getEnabled: enabledSel 346359 label: stringOrText 346360 help: helpText! ! 346361 346362!StandardWindow methodsFor: 'controls'! 346363newButtonFor: aModel action: actionSel label: stringOrText help: helpText 346364 "Answer a new button." 346365 346366 ^self 346367 newButtonFor: aModel 346368 getState: nil 346369 action: actionSel 346370 arguments: nil 346371 getEnabled: nil 346372 label: stringOrText 346373 help: helpText! ! 346374 346375!StandardWindow methodsFor: 'controls'! 346376newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText 346377 "Answer a new button." 346378 346379 ^self theme 346380 newButtonIn: self for: aModel 346381 getState: stateSel 346382 action: actionSel 346383 arguments: args 346384 getEnabled: enabledSel 346385 getLabel: labelSel 346386 help: helpText! ! 346387 346388!StandardWindow methodsFor: 'controls'! 346389newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText 346390 "Answer a new button." 346391 346392 ^self theme 346393 newButtonIn: self for: aModel 346394 getState: stateSel 346395 action: actionSel 346396 arguments: args 346397 getEnabled: enabledSel 346398 label: stringOrText 346399 help: helpText! ! 346400 346401!StandardWindow methodsFor: 'controls'! 346402newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel labelForm: aForm help: helpText 346403 "Answer a new button." 346404 346405 ^self theme 346406 newButtonIn: self for: aModel 346407 getState: stateSel 346408 action: actionSel 346409 arguments: args 346410 getEnabled: enabledSel 346411 label: (AlphaImageMorph new image: aForm) 346412 help: helpText! ! 346413 346414!StandardWindow methodsFor: 'controls'! 346415newCancelButton 346416 "Answer a new cancel button." 346417 346418 ^self newCancelButtonFor: self! ! 346419 346420!StandardWindow methodsFor: 'controls'! 346421newCancelButtonFor: aModel 346422 "Answer a new cancel button." 346423 346424 ^self theme 346425 newCancelButtonIn: self 346426 for: aModel! ! 346427 346428!StandardWindow methodsFor: 'controls'! 346429newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText 346430 "Answer a checkbox with the given label." 346431 346432 ^self theme 346433 newCheckboxIn: self 346434 for: aModel 346435 getSelected: getSel 346436 setSelected: setSel 346437 getEnabled: enabledSel 346438 label: stringOrText 346439 help: helpText! ! 346440 346441!StandardWindow methodsFor: 'controls'! 346442newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText 346443 "Answer a checkbox with the given label." 346444 346445 ^self theme 346446 newCheckboxIn: self 346447 for: aModel 346448 getSelected: getSel 346449 setSelected: setSel 346450 getEnabled: nil 346451 label: stringOrText 346452 help: helpText! ! 346453 346454!StandardWindow methodsFor: 'controls'! 346455newCloseButton 346456 "Answer a new close button." 346457 346458 ^self newCloseButtonFor: self ! ! 346459 346460!StandardWindow methodsFor: 'controls'! 346461newCloseButtonFor: aModel 346462 "Answer a new close button." 346463 346464 ^self theme 346465 newCloseButtonIn: self 346466 for: aModel! ! 346467 346468!StandardWindow methodsFor: 'controls'! 346469newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText 346470 "Answer a color chooser with the given selectors." 346471 346472 ^self theme 346473 newColorChooserIn: self 346474 for: aModel 346475 getColor: getSel 346476 setColor: setSel 346477 getEnabled: enabledSel 346478 help: helpText! ! 346479 346480!StandardWindow methodsFor: 'controls'! 346481newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText 346482 "Answer a color chooser with the given selectors." 346483 346484 ^self theme 346485 newColorChooserIn: self 346486 for: aModel 346487 getColor: getSel 346488 setColor: setSel 346489 getEnabled: nil 346490 help: helpText! ! 346491 346492!StandardWindow methodsFor: 'controls'! 346493newColorPickerFor: target getter: getterSymbol setter: setterSymbol 346494 "Answer a new color picker for the given morph and accessors." 346495 346496 ^self theme 346497 newColorPickerIn: self 346498 for: target 346499 getter: getterSymbol 346500 setter: setterSymbol! ! 346501 346502!StandardWindow methodsFor: 'controls'! 346503newColorPresenterFor: aModel getColor: getSel help: helpText 346504 "Answer a color presenter with the given selectors." 346505 346506 ^self theme 346507 newColorPresenterIn: self 346508 for: aModel 346509 getColor: getSel 346510 help: helpText! ! 346511 346512!StandardWindow methodsFor: 'controls'! 346513newColumn: controls 346514 "Answer a morph laid out with a column of controls." 346515 346516 ^self theme 346517 newColumnIn: self 346518 for: controls! ! 346519 346520!StandardWindow methodsFor: 'controls'! 346521newDialogPanel 346522 "Answer a new main dialog panel." 346523 346524 ^self theme 346525 newDialogPanelIn: self! ! 346526 346527!StandardWindow methodsFor: 'controls'! 346528newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText 346529 "Answer a drop list for the given model." 346530 346531 ^self theme 346532 newDropListIn: self 346533 for: aModel 346534 list: listSel 346535 getSelected: getSel 346536 setSelected: setSel 346537 getEnabled: enabledSel 346538 useIndex: true 346539 help: helpText! ! 346540 346541!StandardWindow methodsFor: 'controls'! 346542newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 346543 "Answer a drop list for the given model." 346544 346545 ^self theme 346546 newDropListIn: self 346547 for: aModel 346548 list: listSel 346549 getSelected: getSel 346550 setSelected: setSel 346551 getEnabled: enabledSel 346552 useIndex: useIndex 346553 help: helpText! ! 346554 346555!StandardWindow methodsFor: 'controls'! 346556newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText 346557 "Answer a drop list for the given model." 346558 346559 ^self 346560 newDropListFor: aModel 346561 list: listSel 346562 getSelected: getSel 346563 setSelected: setSel 346564 getEnabled: nil 346565 useIndex: true 346566 help: helpText! ! 346567 346568!StandardWindow methodsFor: 'controls'! 346569newEmbeddedMenu 346570 "Answer a new menu." 346571 346572 ^self theme 346573 newEmbeddedMenuIn: self 346574 for: self! ! 346575 346576!StandardWindow methodsFor: 'controls'! 346577newExpander: aString 346578 "Answer an expander with the given label." 346579 346580 ^self theme 346581 newExpanderIn: self 346582 label: aString 346583 forAll: #()! ! 346584 346585!StandardWindow methodsFor: 'controls'! 346586newExpander: aString for: aControl 346587 "Answer an expander with the given label and control." 346588 346589 ^self theme 346590 newExpanderIn: self 346591 label: aString 346592 forAll: {aControl}! ! 346593 346594!StandardWindow methodsFor: 'controls'! 346595newExpander: aString forAll: controls 346596 "Answer an expander with the given label and controls." 346597 346598 ^self theme 346599 newExpanderIn: self 346600 label: aString 346601 forAll: controls! ! 346602 346603!StandardWindow methodsFor: 'controls'! 346604newFuzzyLabel: aString 346605 "Answer a new fuzzy label." 346606 346607 ^self theme 346608 newFuzzyLabelIn: self 346609 for: nil 346610 label: aString 346611 offset: 1 346612 alpha: 0.5 346613 getEnabled: nil! ! 346614 346615!StandardWindow methodsFor: 'controls'! 346616newFuzzyLabelFor: aModel label: aString getEnabled: enabledSel 346617 "Answer a new fuzzy label." 346618 346619 ^self theme 346620 newFuzzyLabelIn: self 346621 for: aModel 346622 label: aString 346623 offset: 1 346624 alpha: 0.5 346625 getEnabled: enabledSel! ! 346626 346627!StandardWindow methodsFor: 'controls'! 346628newFuzzyLabelFor: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel 346629 "Answer a new fuzzy label." 346630 346631 ^self theme 346632 newFuzzyLabelIn: self 346633 for: aModel 346634 label: aString 346635 offset: offset 346636 alpha: alpha 346637 getEnabled: enabledSel! ! 346638 346639!StandardWindow methodsFor: 'controls'! 346640newGroupbox 346641 "Answer a plain groupbox." 346642 346643 ^self theme 346644 newGroupboxIn: self! ! 346645 346646!StandardWindow methodsFor: 'controls'! 346647newGroupbox: aString 346648 "Answer a groupbox with the given label." 346649 346650 ^self theme 346651 newGroupboxIn: self 346652 label: aString! ! 346653 346654!StandardWindow methodsFor: 'controls'! 346655newGroupbox: aString for: control 346656 "Answer a groupbox with the given label and control." 346657 346658 ^self theme 346659 newGroupboxIn: self 346660 label: aString 346661 for: control! ! 346662 346663!StandardWindow methodsFor: 'controls'! 346664newGroupbox: aString forAll: controls 346665 "Answer a groupbox with the given label and controls." 346666 346667 ^self theme 346668 newGroupboxIn: self 346669 label: aString 346670 forAll: controls! ! 346671 346672!StandardWindow methodsFor: 'controls'! 346673newGroupboxFor: control 346674 "Answer a plain groupbox with the given control." 346675 346676 ^self theme 346677 newGroupboxIn: self 346678 for: control! ! 346679 346680!StandardWindow methodsFor: 'controls'! 346681newGroupboxForAll: controls 346682 "Answer a plain groupbox with the given controls." 346683 346684 ^self theme 346685 newGroupboxIn: self 346686 forAll: controls! ! 346687 346688!StandardWindow methodsFor: 'controls'! 346689newHSVASelector: aColor help: helpText 346690 "Answer a hue-saturation-volume selector with the given color." 346691 346692 ^self theme 346693 newHSVASelectorIn: self 346694 color: aColor 346695 help: helpText! ! 346696 346697!StandardWindow methodsFor: 'controls'! 346698newHSVSelector: aColor help: helpText 346699 "Answer a hue-saturation-volume selector with the given color." 346700 346701 ^self theme 346702 newHSVSelectorIn: self 346703 color: aColor 346704 help: helpText! ! 346705 346706!StandardWindow methodsFor: 'controls'! 346707newHueSelector: aModel getHue: getSel setHue: setSel help: helpText 346708 "Answer a hue selector with the given selectors." 346709 346710 ^self theme 346711 newHueSelectorIn: self 346712 for: aModel 346713 getHue: getSel 346714 setHue: setSel 346715 help: helpText! ! 346716 346717!StandardWindow methodsFor: 'controls'! 346718newImage: aForm 346719 "Answer a new image." 346720 346721 ^self theme 346722 newImageIn: self 346723 form: aForm! ! 346724 346725!StandardWindow methodsFor: 'controls'! 346726newImage: aForm size: aPoint 346727 "Answer a new image." 346728 346729 ^self theme 346730 newImageIn: self 346731 form: aForm 346732 size: aPoint! ! 346733 346734!StandardWindow methodsFor: 'controls'! 346735newIncrementalSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText 346736 "Answer an inremental slider with the given selectors." 346737 346738 ^self theme 346739 newIncrementalSliderIn: self 346740 for: aModel 346741 getValue: getSel 346742 setValue: setSel 346743 min: min 346744 max: max 346745 quantum: quantum 346746 getEnabled: enabledSel 346747 help: helpText! ! 346748 346749!StandardWindow methodsFor: 'controls'! 346750newLabel: aString 346751 "Answer a new text label." 346752 346753 ^self 346754 newLabelFor: nil 346755 label: aString 346756 getEnabled: nil! ! 346757 346758!StandardWindow methodsFor: 'controls'! 346759newLabelFor: aModel label: aString getEnabled: enabledSel 346760 "Answer a new text label." 346761 346762 ^self theme 346763 newLabelIn: self 346764 for: aModel 346765 label: aString 346766 getEnabled: enabledSel! ! 346767 346768!StandardWindow methodsFor: 'controls'! 346769newLabelGroup: labelsAndControls 346770 "Answer a morph laid out with a column of labels and a column of associated controls." 346771 346772 ^self theme 346773 newLabelGroupIn: self 346774 for: labelsAndControls 346775 spaceFill: false! ! 346776 346777!StandardWindow methodsFor: 'controls'! 346778newLabelGroup: labelsAndControls font: aFont labelColor: aColor 346779 "Answer a morph laid out with a column of labels and a column of associated controls." 346780 346781 ^self theme 346782 newLabelGroupIn: self 346783 for: labelsAndControls 346784 spaceFill: false 346785 font: aFont 346786 labelColor: aColor 346787! ! 346788 346789!StandardWindow methodsFor: 'controls'! 346790newLabelGroupSpread: labelsAndControls 346791 "Answer a morph laid out with a column of labels and a column of associated controls." 346792 346793 ^self theme 346794 newLabelGroupIn: self 346795 for: labelsAndControls 346796 spaceFill: true! ! 346797 346798!StandardWindow methodsFor: 'controls'! 346799newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText 346800 "Answer a list for the given model." 346801 346802 ^self theme 346803 newListIn: self 346804 for: aModel 346805 list: listSelector 346806 selected: getSelector 346807 changeSelected: setSelector 346808 getEnabled: enabledSel 346809 help: helpText! ! 346810 346811!StandardWindow methodsFor: 'controls'! 346812newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText 346813 "Answer a list for the given model." 346814 346815 ^self 346816 newListFor: aModel 346817 list: listSelector 346818 selected: getSelector 346819 changeSelected: setSelector 346820 getEnabled: nil 346821 help: helpText! ! 346822 346823!StandardWindow methodsFor: 'controls'! 346824newMenu 346825 "Answer a new menu." 346826 346827 ^self theme 346828 newMenuIn: self 346829 for: self! ! 346830 346831!StandardWindow methodsFor: 'controls'! 346832newMenuFor: aModel 346833 "Answer a new menu." 346834 346835 ^self theme 346836 newMenuIn: self 346837 for: aModel! ! 346838 346839!StandardWindow methodsFor: 'controls'! 346840newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText 346841 "Answer a morph drop list for the given model." 346842 346843 ^self 346844 newMorphDropListFor: aModel 346845 list: listSel 346846 getSelected: getSel 346847 setSelected: setSel 346848 getEnabled: enabledSel 346849 useIndex: true 346850 help: helpText! ! 346851 346852!StandardWindow methodsFor: 'controls'! 346853newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 346854 "Answer a morph drop list for the given model." 346855 346856 ^self theme 346857 newMorphDropListIn: self 346858 for: aModel 346859 list: listSel 346860 getSelected: getSel 346861 setSelected: setSel 346862 getEnabled: enabledSel 346863 useIndex: useIndex 346864 help: helpText! ! 346865 346866!StandardWindow methodsFor: 'controls'! 346867newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText 346868 "Answer a morph drop list for the given model." 346869 346870 ^self 346871 newMorphDropListFor: aModel 346872 list: listSel 346873 getSelected: getSel 346874 setSelected: setSel 346875 getEnabled: nil 346876 useIndex: true 346877 help: helpText! ! 346878 346879!StandardWindow methodsFor: 'controls'! 346880newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText 346881 "Answer a morph list for the given model." 346882 346883 ^self theme 346884 newMorphListIn: self 346885 for: aModel 346886 list: listSelector 346887 getSelected: getSelector 346888 setSelected: setSelector 346889 getEnabled: enabledSel 346890 help: helpText! ! 346891 346892!StandardWindow methodsFor: 'controls'! 346893newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText 346894 "Answer a morph list for the given model." 346895 346896 ^self 346897 newMorphListFor: aModel 346898 list: listSelector 346899 getSelected: getSelector 346900 setSelected: setSelector 346901 getEnabled: nil 346902 help: helpText! ! 346903 346904!StandardWindow methodsFor: 'controls'! 346905newNoButton 346906 "Answer a new No button." 346907 346908 ^self newNoButtonFor: self! ! 346909 346910!StandardWindow methodsFor: 'controls'! 346911newNoButtonFor: aModel 346912 "Answer a new No button." 346913 346914 ^self theme 346915 newNoButtonIn: self 346916 for: aModel! ! 346917 346918!StandardWindow methodsFor: 'controls'! 346919newOKButton 346920 "Answer a new OK button." 346921 346922 ^self newOKButtonFor: self! ! 346923 346924!StandardWindow methodsFor: 'controls'! 346925newOKButtonFor: aModel 346926 "Answer a new OK button." 346927 346928 ^self 346929 newOKButtonFor: aModel 346930 getEnabled: nil! ! 346931 346932!StandardWindow methodsFor: 'controls'! 346933newOKButtonFor: aModel getEnabled: enabledSel 346934 "Answer a new OK button." 346935 346936 ^self theme 346937 newOKButtonIn: self 346938 for: aModel 346939 getEnabled: enabledSel! ! 346940 346941!StandardWindow methodsFor: 'controls'! 346942newPanel 346943 "Answer a new panel." 346944 346945 ^self theme 346946 newPanelIn: self! ! 346947 346948!StandardWindow methodsFor: 'controls'! 346949newPluggableDialogWindow 346950 "Answer a new pluggable dialog." 346951 346952 ^self 346953 newPluggableDialogWindow: 'Dialog'! ! 346954 346955!StandardWindow methodsFor: 'controls'! 346956newPluggableDialogWindow: title 346957 "Answer a new pluggable dialog with the given content." 346958 346959 ^self 346960 newPluggableDialogWindow: title 346961 for: nil! ! 346962 346963!StandardWindow methodsFor: 'controls'! 346964newPluggableDialogWindow: title for: contentMorph 346965 "Answer a new pluggable dialog with the given content." 346966 346967 ^self theme 346968 newPluggableDialogWindowIn: self 346969 title: title 346970 for: contentMorph! ! 346971 346972!StandardWindow methodsFor: 'controls'! 346973newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText 346974 "Answer a checkbox (radio button appearance) with the given label." 346975 346976 ^self theme 346977 newRadioButtonIn: self 346978 for: aModel 346979 getSelected: getSel 346980 setSelected: setSel 346981 getEnabled: enabledSel 346982 label: stringOrText 346983 help: helpText! ! 346984 346985!StandardWindow methodsFor: 'controls'! 346986newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText 346987 "Answer a checkbox (radio button appearance) with the given label." 346988 346989 ^self 346990 newRadioButtonFor: aModel 346991 getSelected: getSel 346992 setSelected: setSel 346993 getEnabled: nil 346994 label: stringOrText 346995 help: helpText! ! 346996 346997!StandardWindow methodsFor: 'controls'! 346998newRow 346999 "Answer a morph laid out as a row." 347000 347001 ^self theme 347002 newRowIn: self 347003 for: #()! ! 347004 347005!StandardWindow methodsFor: 'controls'! 347006newRow: controls 347007 "Answer a morph laid out with a row of controls." 347008 347009 ^self theme 347010 newRowIn: self 347011 for: controls! ! 347012 347013!StandardWindow methodsFor: 'controls'! 347014newSVSelector: aColor help: helpText 347015 "Answer a saturation-volume selector with the given color." 347016 347017 ^self theme 347018 newSVSelectorIn: self 347019 color: aColor 347020 help: helpText! ! 347021 347022!StandardWindow methodsFor: 'controls'! 347023newSeparator 347024 "Answer an horizontal separator." 347025 347026 ^self theme 347027 newSeparatorIn: self! ! 347028 347029!StandardWindow methodsFor: 'controls'! 347030newSliderFor: aModel getValue: getSel setValue: setSel getEnabled: enabledSel help: helpText 347031 "Answer a slider with the given selectors." 347032 347033 ^self theme 347034 newSliderIn: self 347035 for: aModel 347036 getValue: getSel 347037 setValue: setSel 347038 min: 0 347039 max: 1 347040 quantum: nil 347041 getEnabled: enabledSel 347042 help: helpText! ! 347043 347044!StandardWindow methodsFor: 'controls'! 347045newSliderFor: aModel getValue: getSel setValue: setSel help: helpText 347046 "Answer a slider with the given selectors." 347047 347048 ^self theme 347049 newSliderIn: self 347050 for: aModel 347051 getValue: getSel 347052 setValue: setSel 347053 min: 0 347054 max: 1 347055 quantum: nil 347056 getEnabled: nil 347057 help: helpText! ! 347058 347059!StandardWindow methodsFor: 'controls'! 347060newSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText 347061 "Answer a slider with the given selectors." 347062 347063 ^self theme 347064 newSliderIn: self 347065 for: aModel 347066 getValue: getSel 347067 setValue: setSel 347068 min: min 347069 max: max 347070 quantum: quantum 347071 getEnabled: enabledSel 347072 help: helpText! ! 347073 347074!StandardWindow methodsFor: 'controls'! 347075newString: aStringOrText 347076 "Answer a new embossed string." 347077 347078 ^self theme 347079 newStringIn: self 347080 label: aStringOrText 347081 font: self theme labelFont 347082 style: #plain! ! 347083 347084!StandardWindow methodsFor: 'controls'! 347085newString: aStringOrText font: aFont style: aStyle 347086 "Answer a new embossed string." 347087 347088 ^self theme 347089 newStringIn: self 347090 label: aStringOrText 347091 font: aFont 347092 style: aStyle! ! 347093 347094!StandardWindow methodsFor: 'controls'! 347095newString: aStringOrText style: aStyle 347096 "Answer a new embossed string." 347097 347098 ^self theme 347099 newStringIn: self 347100 label: aStringOrText 347101 font: self theme labelFont 347102 style: aStyle! ! 347103 347104!StandardWindow methodsFor: 'controls'! 347105newTabGroup: labelsAndPages 347106 "Answer a tab group with the given tab labels associated with pages." 347107 347108 ^self theme 347109 newTabGroupIn: self 347110 for: labelsAndPages! ! 347111 347112!StandardWindow methodsFor: 'controls'! 347113newText: aStringOrText 347114 "Answer a new text." 347115 347116 ^self theme 347117 newTextIn: self 347118 text: aStringOrText! ! 347119 347120!StandardWindow methodsFor: 'controls'! 347121newTextEditorFor: aModel getText: getSel setText: setSel 347122 "Answer a text editor for the given model." 347123 347124 ^self 347125 newTextEditorFor: aModel 347126 getText: getSel 347127 setText: setSel 347128 getEnabled: nil! ! 347129 347130!StandardWindow methodsFor: 'controls'! 347131newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 347132 "Answer a text editor for the given model." 347133 347134 ^self theme 347135 newTextEditorIn: self 347136 for: aModel 347137 getText: getSel 347138 setText: setSel 347139 getEnabled: enabledSel ! ! 347140 347141!StandardWindow methodsFor: 'controls'! 347142newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText 347143 "Answer a text entry for the given model." 347144 347145 ^self theme 347146 newTextEntryIn: self 347147 for: aModel 347148 get: getSel 347149 set: setSel 347150 class: aClass 347151 getEnabled: enabledSel 347152 help: helpText! ! 347153 347154!StandardWindow methodsFor: 'controls'! 347155newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText 347156 "Answer a text entry for the given model." 347157 347158 ^self theme 347159 newTextEntryIn: self 347160 for: aModel 347161 get: getSel 347162 set: setSel 347163 class: String 347164 getEnabled: enabledSel 347165 help: helpText! ! 347166 347167!StandardWindow methodsFor: 'controls' stamp: 'gvc 8/2/2007 13:47'! 347168newTextEntryFor: aModel getText: getSel setText: setSel help: helpText 347169 "Answer a text entry for the given model." 347170 347171 ^self theme 347172 newTextEntryIn: self 347173 for: aModel 347174 get: getSel 347175 set: setSel 347176 class: String 347177 getEnabled: nil 347178 help: helpText! ! 347179 347180!StandardWindow methodsFor: 'controls'! 347181newTitle: aString for: control 347182 "Answer a morph laid out with a column with a title." 347183 347184 ^self theme 347185 newTitleIn: self 347186 label: aString 347187 for: control! ! 347188 347189!StandardWindow methodsFor: 'controls'! 347190newToolDockingBar 347191 "Answer a tool docking bar." 347192 347193 ^self theme 347194 newToolDockingBarIn: self! ! 347195 347196!StandardWindow methodsFor: 'controls'! 347197newToolSpacer 347198 "Answer a tool spacer." 347199 347200 ^self theme 347201 newToolSpacerIn: self! ! 347202 347203!StandardWindow methodsFor: 'controls'! 347204newToolbar 347205 "Answer a toolbar." 347206 347207 ^self theme 347208 newToolbarIn: self! ! 347209 347210!StandardWindow methodsFor: 'controls'! 347211newToolbar: controls 347212 "Answer a toolbar with the given controls." 347213 347214 ^self theme 347215 newToolbarIn: self 347216 for: controls! ! 347217 347218!StandardWindow methodsFor: 'controls'! 347219newToolbarHandle 347220 "Answer a toolbar handle." 347221 347222 ^self theme 347223 newToolbarHandleIn: self! ! 347224 347225!StandardWindow methodsFor: 'controls'! 347226newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector 347227 "Answer a new tree morph." 347228 347229 ^self theme 347230 newTreeIn: self 347231 for: aModel 347232 list: listSelector 347233 selected: getSelector 347234 changeSelected: setSelector! ! 347235 347236!StandardWindow methodsFor: 'controls'! 347237newVerticalSeparator 347238 "Answer a vertical separator." 347239 347240 ^self theme 347241 newVerticalSeparatorIn: self! ! 347242 347243!StandardWindow methodsFor: 'controls'! 347244newYesButton 347245 "Answer a new Yes button." 347246 347247 ^self newYesButtonFor: self! ! 347248 347249!StandardWindow methodsFor: 'controls'! 347250newYesButtonFor: aModel 347251 "Answer a new yes button." 347252 347253 ^self theme 347254 newYesButtonIn: self 347255 for: aModel! ! 347256 347257!StandardWindow methodsFor: 'controls' stamp: 'gvc 9/29/2006 12:11'! 347258title 347259 "Answer tht window title." 347260 347261 ^self label! ! 347262 347263!StandardWindow methodsFor: 'controls' stamp: 'gvc 8/29/2006 16:53'! 347264title: aString 347265 "Set the window title." 347266 347267 self setLabel: aString 347268 ! ! 347269 347270 347271!StandardWindow methodsFor: 'layout' stamp: 'gvc 9/14/2006 16:49'! 347272layoutBounds 347273 "Bounds of pane area only." 347274 347275 ^self isFullscreen 347276 ifTrue: [self perform: #layoutBounds withArguments: #() inSuperclass: Morph] 347277 ifFalse: [super layoutBounds]! ! 347278 347279 347280!StandardWindow methodsFor: 'services'! 347281abort: aStringOrText 347282 "Open an error dialog." 347283 347284 ^self abort: aStringOrText title: 'Error' translated! ! 347285 347286!StandardWindow methodsFor: 'services'! 347287abort: aStringOrText title: aString 347288 "Open an error dialog." 347289 347290 ^self theme 347291 abortIn: self 347292 text: aStringOrText 347293 title: aString! ! 347294 347295!StandardWindow methodsFor: 'services'! 347296alert: aStringOrText 347297 "Open an alert dialog." 347298 347299 ^self alert: aStringOrText title: 'Alert' translated! ! 347300 347301!StandardWindow methodsFor: 'services'! 347302alert: aStringOrText title: aString 347303 "Open an alert dialog." 347304 347305 ^self 347306 alert: aStringOrText 347307 title: aString 347308 configure: [:d | ]! ! 347309 347310!StandardWindow methodsFor: 'services'! 347311alert: aStringOrText title: aString configure: aBlock 347312 "Open an alert dialog. 347313 Configure the dialog with the 1 argument block 347314 before opening modally." 347315 347316 ^self theme 347317 alertIn: self 347318 text: aStringOrText 347319 title: aString 347320 configure: aBlock! ! 347321 347322!StandardWindow methodsFor: 'services'! 347323chooseColor 347324 "Answer the result of a color selector dialog ." 347325 347326 ^self chooseColor: Color black! ! 347327 347328!StandardWindow methodsFor: 'services'! 347329chooseColor: aColor 347330 "Answer the result of a color selector dialog with the given color." 347331 347332 ^self theme 347333 chooseColorIn: self 347334 title: 'Colour Selector' translated 347335 color: aColor! ! 347336 347337!StandardWindow methodsFor: 'services'! 347338chooseColor: aColor title: title 347339 "Answer the result of a color selector dialog with the given title and initial colour." 347340 347341 ^self theme 347342 chooseColorIn: self 347343 title: title 347344 color: aColor! ! 347345 347346!StandardWindow methodsFor: 'services'! 347347chooseDirectory: title 347348 "Answer the result of a file dialog with the given title, answer a directory." 347349 347350 ^self 347351 chooseDirectory: title 347352 path: nil! ! 347353 347354!StandardWindow methodsFor: 'services'! 347355chooseDirectory: title path: path 347356 "Answer the result of a file dialog with the given title, answer a directory." 347357 347358 ^self theme 347359 chooseDirectoryIn: self 347360 title: title 347361 path: path! ! 347362 347363!StandardWindow methodsFor: 'services'! 347364chooseDropList: aStringOrText list: aList 347365 "Open a drop list chooser dialog." 347366 347367 ^self 347368 chooseDropList: aStringOrText 347369 title: 'Choose' translated 347370 list: aList! ! 347371 347372!StandardWindow methodsFor: 'services'! 347373chooseDropList: aStringOrText title: aString list: aList 347374 "Open a drop list chooser dialog." 347375 347376 ^self theme 347377 chooseDropListIn: self 347378 text: aStringOrText 347379 title: aString 347380 list: aList! ! 347381 347382!StandardWindow methodsFor: 'services'! 347383chooseFileName: title extensions: exts path: path preview: preview 347384 "Answer the result of a file name chooser dialog with the given title, extensions 347385 to show, path and preview type." 347386 347387 ^self theme 347388 chooseFileNameIn: self 347389 title: title 347390 extensions: exts 347391 path: path 347392 preview: preview! ! 347393 347394!StandardWindow methodsFor: 'services'! 347395chooseFont 347396 "Answer the result of a font selector dialog." 347397 347398 ^self chooseFont: nil! ! 347399 347400!StandardWindow methodsFor: 'services'! 347401chooseFont: aFont 347402 "Answer the result of a font selector dialog with the given initial font." 347403 347404 ^self theme 347405 chooseFontIn: self 347406 title: 'Font Selector' translated 347407 font: aFont! ! 347408 347409!StandardWindow methodsFor: 'services'! 347410deny: aStringOrText 347411 "Open a denial dialog." 347412 347413 ^self deny: aStringOrText title: 'Access Denied' translated! ! 347414 347415!StandardWindow methodsFor: 'services'! 347416deny: aStringOrText title: aString 347417 "Open a denial dialog." 347418 347419 ^self theme 347420 denyIn: self 347421 text: aStringOrText 347422 title: aString! ! 347423 347424!StandardWindow methodsFor: 'services'! 347425fileOpen: title 347426 "Answer the result of a file open dialog with the given title." 347427 347428 ^self 347429 fileOpen: title 347430 extensions: nil! ! 347431 347432!StandardWindow methodsFor: 'services'! 347433fileOpen: title extensions: exts 347434 "Answer the result of a file open dialog with the given title and extensions to show." 347435 347436 ^self 347437 fileOpen: title 347438 extensions: exts 347439 path: nil! ! 347440 347441!StandardWindow methodsFor: 'services'! 347442fileOpen: title extensions: exts path: path 347443 "Answer the result of a file open dialog with the given title, extensions to show and path." 347444 347445 ^self 347446 fileOpen: title 347447 extensions: exts 347448 path: path 347449 preview: nil! ! 347450 347451!StandardWindow methodsFor: 'services'! 347452fileOpen: title extensions: exts path: path preview: preview 347453 "Answer the result of a file open dialog with the given title, extensions to show, path and preview type." 347454 347455 ^self theme 347456 fileOpenIn: self 347457 title: title 347458 extensions: exts 347459 path: path 347460 preview: preview! ! 347461 347462!StandardWindow methodsFor: 'services'! 347463fileSave: title 347464 "Answer the result of a file save dialog with the given title." 347465 347466 ^self 347467 fileSave: title 347468 extensions: nil 347469 path: nil! ! 347470 347471!StandardWindow methodsFor: 'services'! 347472fileSave: title extensions: exts 347473 "Answer the result of a file save dialog with the given title." 347474 347475 ^self 347476 fileSave: title 347477 extensions: exts 347478 path: nil! ! 347479 347480!StandardWindow methodsFor: 'services'! 347481fileSave: title extensions: exts path: path 347482 "Answer the result of a file save dialog with the given title, extensions to show and path." 347483 347484 ^self theme 347485 fileSaveIn: self 347486 title: title 347487 extensions: exts 347488 path: path! ! 347489 347490!StandardWindow methodsFor: 'services'! 347491fileSave: title path: path 347492 "Answer the result of a file save open dialog with the given title." 347493 347494 ^self 347495 fileSave: title 347496 extensions: nil 347497 path: path! ! 347498 347499!StandardWindow methodsFor: 'services'! 347500longMessage: aStringOrText title: aString 347501 "Open a (long) message dialog." 347502 347503 ^self theme 347504 longMessageIn: self 347505 text: aStringOrText 347506 title: aString! ! 347507 347508!StandardWindow methodsFor: 'services'! 347509message: aStringOrText 347510 "Open a message dialog." 347511 347512 ^self message: aStringOrText title: 'Information' translated! ! 347513 347514!StandardWindow methodsFor: 'services'! 347515message: aStringOrText title: aString 347516 "Open a message dialog." 347517 347518 ^self theme 347519 messageIn: self 347520 text: aStringOrText 347521 title: aString! ! 347522 347523!StandardWindow methodsFor: 'services'! 347524proceed: aStringOrText 347525 "Open a proceed dialog." 347526 347527 ^self proceed: aStringOrText title: 'Proceed' translated! ! 347528 347529!StandardWindow methodsFor: 'services'! 347530proceed: aStringOrText title: aString 347531 "Open a proceed dialog and answer true if not cancelled, false otherwise." 347532 347533 ^self theme 347534 proceedIn: self 347535 text: aStringOrText 347536 title: aString! ! 347537 347538!StandardWindow methodsFor: 'services'! 347539question: aStringOrText 347540 "Open a question dialog." 347541 347542 ^self question: aStringOrText title: 'Question' translated! ! 347543 347544!StandardWindow methodsFor: 'services'! 347545question: aStringOrText title: aString 347546 "Open a question dialog and answer true if yes, 347547 false if no and nil if cancelled." 347548 347549 ^self theme 347550 questionIn: self 347551 text: aStringOrText 347552 title: aString! ! 347553 347554!StandardWindow methodsFor: 'services'! 347555questionWithoutCancel: aStringOrText 347556 "Open a question dialog." 347557 347558 ^self questionWithoutCancel: aStringOrText title: 'Question' translated! ! 347559 347560!StandardWindow methodsFor: 'services'! 347561questionWithoutCancel: aStringOrText title: aString 347562 "Open a question dialog and answer true if yes, 347563 false if no and nil if cancelled." 347564 347565 ^self theme 347566 questionWithoutCancelIn: self 347567 text: aStringOrText 347568 title: aString! ! 347569 347570!StandardWindow methodsFor: 'services'! 347571textEntry: aStringOrText 347572 "Open a text entry dialog." 347573 347574 ^self textEntry: aStringOrText title: 'Entry' translated! ! 347575 347576!StandardWindow methodsFor: 'services'! 347577textEntry: aStringOrText title: aString 347578 "Open a text entry dialog." 347579 347580 ^self 347581 textEntry: aStringOrText 347582 title: aString 347583 entryText: ''! ! 347584 347585!StandardWindow methodsFor: 'services'! 347586textEntry: aStringOrText title: aString entryText: defaultEntryText 347587 "Open a text entry dialog." 347588 347589 ^self theme 347590 textEntryIn: self 347591 text: aStringOrText 347592 title: aString 347593 entryText: defaultEntryText! ! 347594 347595"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 347596 347597StandardWindow class 347598 uses: TEasilyThemed classTrait 347599 instanceVariableNames: ''! 347600ChangeSetCategory subclass: #StaticChangeSetCategory 347601 instanceVariableNames: '' 347602 classVariableNames: '' 347603 poolDictionaries: '' 347604 category: 'Tools-Changes'! 347605!StaticChangeSetCategory commentStamp: '<historical>' prior: 0! 347606StaticChangeSetCategory is a user-defined change-set category that has in it only those change sets specifically placed there.! 347607 347608 347609!StaticChangeSetCategory methodsFor: 'add' stamp: 'sw 4/11/2001 15:58'! 347610addChangeSet: aChangeSet 347611 "Add the change set manually" 347612 347613 self elementAt: aChangeSet name put: aChangeSet! ! 347614 347615 347616!StaticChangeSetCategory methodsFor: 'queries' stamp: 'sw 4/11/2001 16:10'! 347617acceptsManualAdditions 347618 "Answer whether the user is allowed manually to manipulate the contents of the change-set-category." 347619 347620 ^ true! ! 347621 347622!StaticChangeSetCategory methodsFor: 'queries' stamp: 'sw 4/11/2001 16:00'! 347623includesChangeSet: aChangeSet 347624 "Answer whether the receiver includes aChangeSet in its retrieval list" 347625 347626 ^ elementDictionary includesKey: aChangeSet name! ! 347627 347628 347629!StaticChangeSetCategory methodsFor: 'updating' stamp: 'sd 11/20/2005 21:27'! 347630reconstituteList 347631 "Reformulate the list. Here, since we have a manually-maintained list, at this juncture we only make sure change-set-names are still up to date, and we purge moribund elements" 347632 347633 | survivors | 347634 survivors := elementDictionary select: [:aChangeSet | aChangeSet isMoribund not]. 347635 self clear. 347636 (survivors asSortedCollection: [:a :b | a name <= b name]) reverseDo: 347637 [:aChangeSet | self addChangeSet: aChangeSet]! ! 347638Form subclass: #StaticForm 347639 instanceVariableNames: '' 347640 classVariableNames: '' 347641 poolDictionaries: '' 347642 category: 'Graphics-Display Objects'! 347643!StaticForm commentStamp: '<historical>' prior: 0! 347644An optimization for Nebraska - a StaticForm does not change once created so it may be cached on the remote end.! 347645 347646 347647!StaticForm methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 09:59'! 347648isStatic 347649 347650 ^true! ! 347651MorphicAlarm subclass: #StepMessage 347652 instanceVariableNames: 'stepTime' 347653 classVariableNames: '' 347654 poolDictionaries: '' 347655 category: 'Morphic-Events'! 347656 347657!StepMessage methodsFor: 'accessing' stamp: 'ar 10/22/2000 16:56'! 347658stepTime: aNumber 347659 "Set the step time for this message. If nil, the receiver of the message will be asked for its #stepTime." 347660 stepTime := aNumber! ! 347661 347662 347663!StepMessage methodsFor: 'printing' stamp: 'ar 10/22/2000 15:59'! 347664printOn: aStream 347665 super printOn: aStream. 347666 aStream 347667 nextPut: $(; 347668 print: receiver; 347669 space; 347670 print: selector; 347671 space; 347672 print: scheduledTime; 347673 nextPut: $).! ! 347674 347675 347676!StepMessage methodsFor: 'testing' stamp: 'ar 10/22/2000 16:56'! 347677stepTime 347678 "Return the step time for this message. If nil, the receiver of the message will be asked for its #stepTime." 347679 ^stepTime! ! 347680 347681"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 347682 347683StepMessage class 347684 instanceVariableNames: ''! 347685 347686!StepMessage class methodsFor: 'instance creation' stamp: 'ar 10/22/2000 15:48'! 347687scheduledAt: scheduledTime stepTime: stepTime receiver: aTarget selector: aSelector arguments: argArray 347688 ^(self receiver: aTarget selector: aSelector arguments: argArray) 347689 scheduledTime: scheduledTime; 347690 stepTime: stepTime! ! 347691MorphicUIBugTest subclass: #StickynessBugz 347692 instanceVariableNames: '' 347693 classVariableNames: '' 347694 poolDictionaries: '' 347695 category: 'Tests-Bugs'! 347696!StickynessBugz commentStamp: 'wiz 11/24/2006 00:24' prior: 0! 347697A StickynessBugz is for mantis #5500 rectangles and ellipses don't act sticky when rotated even when they are.. 347698 347699Instance Variables 347700! 347701 347702 347703!StickynessBugz methodsFor: 'as yet unclassified' stamp: 'wiz 7/28/2007 18:54'! 347704testForTiltedStickyness 347705"self new testForTiltedStickyness" 347706"self run: #testForTiltedStickyness" 347707 347708 347709| m | 347710m := RectangleMorph new openCenteredInWorld . 347711 347712cases := Array with: m . "save for tear down." 347713 347714self assert: ( m topRendererOrSelf isSticky not ) . 347715 347716m beSticky . 347717 347718self assert: ( m topRendererOrSelf isSticky ) . 347719 347720m addFlexShell . 347721 347722cases := Array with: m topRendererOrSelf . 347723 347724m topRendererOrSelf rotationDegrees: 45.0 . 347725 347726self assert: ( m topRendererOrSelf isSticky ) . 347727 347728m beUnsticky . 347729 347730self assert: ( m topRendererOrSelf isSticky not ) . 347731 347732m topRendererOrSelf delete. 347733^true 347734 347735 347736 347737 347738 347739 347740! ! 347741Object subclass: #Stopwatch 347742 instanceVariableNames: 'timespans state' 347743 classVariableNames: '' 347744 poolDictionaries: '' 347745 category: 'Kernel-Chronology'! 347746!Stopwatch commentStamp: '<historical>' prior: 0! 347747A Stopwatch maintains a collection of timespans.! 347748 347749 347750!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 23:12'! 347751activate 347752 347753 self isSuspended ifTrue: 347754 [self timespans add: 347755 (Timespan starting: DateAndTime now duration: Duration zero). 347756 self state: #active] 347757! ! 347758 347759!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 23:45'! 347760duration 347761 347762 | ts last | 347763 self isSuspended 347764 ifTrue: 347765 [ (ts := self timespans) isEmpty ifTrue: 347766 [ ts := { Timespan starting: DateAndTime now duration: Duration zero } ] ] 347767 ifFalse: 347768 [ last := self timespans last. 347769 ts := self timespans allButLast 347770 add: (last duration: (DateAndTime now - last start); yourself); 347771 yourself ]. 347772 347773 ^ (ts collect: [ :t | t duration ]) sum 347774! ! 347775 347776!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 11:21'! 347777end 347778 347779 ^ self timespans last next 347780 347781! ! 347782 347783!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 22:48'! 347784isActive 347785 347786 ^ self state = #active 347787! ! 347788 347789!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 22:48'! 347790isSuspended 347791 347792 ^ self state = #suspended 347793 347794! ! 347795 347796!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 13:25'! 347797printOn: aStream 347798 347799 super printOn: aStream. 347800 aStream 347801 nextPut: $(; 347802 nextPutAll: self state; 347803 nextPut: $:; 347804 print: self duration; 347805 nextPut: $). 347806 347807! ! 347808 347809!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 12:03'! 347810reActivate 347811 347812 self 347813 suspend; 347814 activate. 347815! ! 347816 347817!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 11:54'! 347818reset 347819 347820 self suspend. 347821 timespans := nil. 347822 347823! ! 347824 347825!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 23:18'! 347826start 347827 347828 ^ self timespans first start 347829 347830! ! 347831 347832!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 22:47'! 347833state 347834 347835 ^ state ifNil: [ state := #suspended ] 347836! ! 347837 347838!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 22:46'! 347839state: aSymbol 347840 347841 state := aSymbol 347842! ! 347843 347844!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 23:13'! 347845suspend 347846 347847 | ts | 347848 self isActive ifTrue: 347849 [ ts := self timespans last. 347850 ts duration: (DateAndTime now - ts start). 347851 self state: #suspended] 347852! ! 347853 347854!Stopwatch methodsFor: 'squeak protocol' stamp: 'brp 9/24/2003 22:44'! 347855timespans 347856 347857 ^ timespans ifNil: [ timespans := OrderedCollection new ] 347858! ! 347859 347860"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 347861 347862Stopwatch class 347863 instanceVariableNames: ''! 347864ClassTestCase subclass: #StopwatchTest 347865 instanceVariableNames: 'aStopwatch aDelay' 347866 classVariableNames: '' 347867 poolDictionaries: '' 347868 category: 'KernelTests-Chronology'! 347869 347870!StopwatchTest methodsFor: 'Coverage' stamp: 'brp 9/24/2003 22:49'! 347871classToBeTested 347872 347873 ^ Stopwatch 347874 347875! ! 347876 347877!StopwatchTest methodsFor: 'Coverage' stamp: 'brp 9/24/2003 23:01'! 347878selectorsToBeIgnored 347879 347880 | private | 347881 private := #( #printOn: #state: ). 347882 347883 ^ super selectorsToBeIgnored, private 347884! ! 347885 347886 347887!StopwatchTest methodsFor: 'Tests' stamp: 'brp 9/25/2003 11:45'! 347888testActive 347889 347890 | sw | 347891 sw := Stopwatch new. 347892 sw activate. 347893 347894 1 seconds asDelay wait. 347895 self 347896 assert: (sw duration >= 1 seconds). 347897 347898 2 seconds asDelay wait. 347899 self 347900 assert: (sw duration >= 3 seconds). 347901 347902 sw suspend.! ! 347903 347904!StopwatchTest methodsFor: 'Tests' stamp: 'brp 9/24/2003 22:56'! 347905testNew 347906 347907 | sw | 347908 sw := Stopwatch new. 347909 347910 self 347911 assert: (sw isSuspended); 347912 assert: (sw state = #suspended); 347913 deny: (sw isActive); 347914 assert: (sw timespans isEmpty) 347915 347916! ! 347917 347918!StopwatchTest methodsFor: 'Tests' stamp: 'brp 9/25/2003 12:02'! 347919testReActivate 347920 347921 | sw | 347922 sw := Stopwatch new. 347923 sw 347924 activate; 347925 suspend; 347926 reActivate. 347927 347928 self 347929 assert: (sw isActive). 347930! ! 347931 347932!StopwatchTest methodsFor: 'Tests' stamp: 'brp 9/25/2003 11:56'! 347933testReset 347934 347935 | sw | 347936 sw := Stopwatch new. 347937 sw activate. 347938 347939 sw reset. 347940 self 347941 assert: (sw isSuspended); 347942 assert: (sw timespans isEmpty) 347943! ! 347944 347945!StopwatchTest methodsFor: 'Tests' stamp: 'brp 9/26/2004 19:36'! 347946testStartStop 347947 347948 | sw t1 t2 t3 t4 | 347949 sw := Stopwatch new. 347950 t1 := DateAndTime now. 347951 (Delay forMilliseconds: 10) wait. 347952 sw activate; activate. 347953 (Delay forMilliseconds: 10) wait. 347954 t2 := DateAndTime now. 347955 347956 self 347957 deny: (sw isSuspended); 347958 assert: (sw isActive); 347959 assert: (sw timespans size = 1); 347960 assert: (t1 <= sw start); 347961 assert: (sw start <= t2). 347962 347963 (Delay forMilliseconds: 10) wait. 347964 t3 := DateAndTime now. 347965 (Delay forMilliseconds: 10) wait. 347966 sw suspend; suspend. 347967 (Delay forMilliseconds: 10) wait. 347968 t4 := DateAndTime now. 347969 347970 self 347971 assert: (sw isSuspended); 347972 deny: (sw isActive); 347973 assert: (sw timespans size = 1); 347974 assert: (sw end between: t3 and: t4); 347975 assert: (t3 <= sw end); 347976 assert: (sw end <= t4). 347977! ! 347978 347979 347980!StopwatchTest methodsFor: 'running' stamp: 'brp 1/21/2004 18:49'! 347981setUp 347982 aStopwatch := Stopwatch new. 347983 aDelay := Delay forMilliseconds: 1.! ! 347984 347985 347986!StopwatchTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:49'! 347987testChangingStatus 347988 aStopwatch activate. 347989 self assert: aStopwatch isActive. 347990 self assert: aStopwatch timespans size = 1. 347991 aStopwatch suspend. 347992 self assert: aStopwatch isSuspended. 347993 self assert: aStopwatch timespans size = 1. 347994 aStopwatch activate. 347995 aStopwatch reActivate. 347996 self assert: aStopwatch isActive. 347997 self assert: aStopwatch timespans size = 3. 347998 aStopwatch reset. 347999 self assert: aStopwatch isSuspended. 348000 self assert: aStopwatch timespans size = 0.! ! 348001 348002!StopwatchTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:49'! 348003testInitialStatus 348004 self assert: aStopwatch isSuspended. 348005 self deny: aStopwatch isActive. 348006 self assert: aStopwatch duration = 0 seconds! ! 348007 348008!StopwatchTest methodsFor: 'testing' stamp: 'brp 9/26/2004 19:32'! 348009testMultipleTimings 348010 aStopwatch activate. 348011 aDelay wait. 348012 aStopwatch suspend. 348013 aStopwatch activate. 348014 aDelay wait. 348015 aStopwatch suspend. 348016 self assert: aStopwatch timespans size = 2. 348017 self assert: aStopwatch timespans first asDateAndTime <= 348018 aStopwatch timespans last asDateAndTime. 348019! ! 348020 348021!StopwatchTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 348022testPrintOn 348023 | cs rw | 348024 cs := 'a Stopwatch(suspended:0:00:00:00)' readStream. 348025 rw := ReadWriteStream on: ''. 348026 aStopwatch printOn: rw. 348027 self assert: rw contents = cs contents! ! 348028 348029!StopwatchTest methodsFor: 'testing' stamp: 'brp 9/26/2004 19:32'! 348030testSingleTiming 348031 | timeBefore | 348032 timeBefore := DateAndTime now. 348033 aStopwatch activate. 348034 aDelay wait. 348035 aStopwatch suspend. 348036 self assert: aStopwatch timespans size = 1. 348037 self assert: aStopwatch timespans first asDateAndTime >= timeBefore. 348038 self assert: aStopwatch timespans first asDateAndTime <= aStopwatch end. 348039! ! 348040Object subclass: #Stream 348041 instanceVariableNames: '' 348042 classVariableNames: '' 348043 poolDictionaries: '' 348044 category: 'Collections-Streams'! 348045!Stream commentStamp: '<historical>' prior: 0! 348046I am an abstract class that represents an accessor for a sequence of objects. This sequence is referred to as my "contents".! 348047 348048 348049!Stream methodsFor: '*monticello' stamp: 'cwp 8/9/2003 12:02'! 348050isMessageStream 348051 ^ false! ! 348052 348053 348054!Stream methodsFor: 'accessing' stamp: 'yo 8/30/2002 17:13'! 348055basicNext 348056 348057 ^ self next. 348058! ! 348059 348060!Stream methodsFor: 'accessing' stamp: 'yo 8/30/2002 17:13'! 348061basicNextPut: anObject 348062 348063 ^ self nextPut: anObject! ! 348064 348065!Stream methodsFor: 'accessing' stamp: 'yo 8/30/2002 17:13'! 348066basicNextPutAll: aCollection 348067 348068 ^ self nextPutAll: aCollection. 348069! ! 348070 348071!Stream methodsFor: 'accessing' stamp: 'marcus.denker 8/15/2008 17:36'! 348072binary 348073 "do nothing" 348074 ^self! ! 348075 348076!Stream methodsFor: 'accessing'! 348077contents 348078 "Answer all of the contents of the receiver." 348079 348080 self subclassResponsibility! ! 348081 348082!Stream methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:07'! 348083flush 348084 "Do nothing by default"! ! 348085 348086!Stream methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:38'! 348087localName 348088 ^'a stream'! ! 348089 348090!Stream methodsFor: 'accessing'! 348091next 348092 "Answer the next object accessible by the receiver." 348093 348094 self subclassResponsibility! ! 348095 348096!Stream methodsFor: 'accessing'! 348097next: anInteger 348098 "Answer the next anInteger number of objects accessible by the receiver." 348099 348100 | aCollection | 348101 aCollection := OrderedCollection new. 348102 anInteger timesRepeat: [aCollection addLast: self next]. 348103 ^aCollection! ! 348104 348105!Stream methodsFor: 'accessing'! 348106next: anInteger put: anObject 348107 "Make anObject be the next anInteger number of objects accessible by the 348108 receiver. Answer anObject." 348109 348110 anInteger timesRepeat: [self nextPut: anObject]. 348111 ^anObject! ! 348112 348113!Stream methodsFor: 'accessing'! 348114nextMatchAll: aColl 348115 "Answer true if next N objects are the ones in aColl, 348116 else false. Advance stream of true, leave as was if false." 348117 | save | 348118 save := self position. 348119 aColl do: [:each | 348120 (self next) = each ifFalse: [ 348121 self position: save. 348122 ^ false] 348123 ]. 348124 ^ true! ! 348125 348126!Stream methodsFor: 'accessing'! 348127nextMatchFor: anObject 348128 "Gobble the next object and answer whether it is equal to the argument, 348129 anObject." 348130 348131 ^anObject = self next! ! 348132 348133!Stream methodsFor: 'accessing'! 348134nextPut: anObject 348135 "Insert the argument, anObject, as the next object accessible by the 348136 receiver. Answer anObject." 348137 348138 self subclassResponsibility! ! 348139 348140!Stream methodsFor: 'accessing'! 348141nextPutAll: aCollection 348142 "Append the elements of aCollection to the sequence of objects accessible 348143 by the receiver. Answer aCollection." 348144 348145 aCollection do: [:v | self nextPut: v]. 348146 ^aCollection! ! 348147 348148!Stream methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:40'! 348149openReadOnly 348150 ^self! ! 348151 348152!Stream methodsFor: 'accessing' stamp: 'ajh 7/31/2001 20:34'! 348153printOn: stream 348154 348155 super printOn: stream. 348156 stream space. 348157 self contents printOn: stream. 348158! ! 348159 348160!Stream methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:41'! 348161readOnly 348162 ^self! ! 348163 348164!Stream methodsFor: 'accessing' stamp: 'ls 9/12/1998 20:55'! 348165upToEnd 348166 "answer the remaining elements in the string" 348167 | elements | 348168 elements := OrderedCollection new. 348169 [ self atEnd ] whileFalse: [ 348170 elements add: self next ]. 348171 ^elements! ! 348172 348173 348174!Stream methodsFor: 'as yet unclassified' stamp: 'RAA 9/11/2000 19:12'! 348175sleep 348176 348177 "an FTP-based stream might close the connection here"! ! 348178 348179 348180!Stream methodsFor: 'enumerating'! 348181do: aBlock 348182 "Evaluate aBlock for each of the objects accessible by receiver." 348183 348184 [self atEnd] 348185 whileFalse: [aBlock value: self next]! ! 348186 348187 348188!Stream methodsFor: 'file open/close' stamp: 'marcus.denker 8/15/2008 17:35'! 348189close 348190 "Presumably sets the status of the receiver to be closed. This message does 348191 nothing at this level, but is included for FileStream compatibility." 348192 348193 ^self! ! 348194 348195 348196!Stream methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:48'! 348197write:encodedObject 348198 ^encodedObject putOn:self. 348199! ! 348200 348201 348202!Stream methodsFor: 'printing' stamp: 'sma 6/1/2000 09:56'! 348203print: anObject 348204 "Have anObject print itself on the receiver." 348205 348206 anObject printOn: self! ! 348207 348208 348209!Stream methodsFor: 'readability' stamp: 'kph 9/27/2007 21:53'! 348210<< items 348211 348212 items putOn: self. 348213 348214 ^ self! ! 348215 348216 348217!Stream methodsFor: 'testing'! 348218atEnd 348219 "Answer whether the receiver can access any more objects." 348220 348221 self subclassResponsibility! ! 348222 348223!Stream methodsFor: 'testing' stamp: 'ab 8/28/2003 18:30'! 348224closed 348225 ^ false! ! 348226 348227!Stream methodsFor: 'testing' stamp: 'ar 12/23/1999 15:43'! 348228isStream 348229 "Return true if the receiver responds to the stream protocol" 348230 ^true! ! 348231 348232!Stream methodsFor: 'testing' stamp: 'mir 11/10/2003 18:22'! 348233isTypeHTTP 348234 ^false! ! 348235 348236!Stream methodsFor: 'testing' stamp: 'ar 5/17/2001 19:07'! 348237nextWordsPutAll: aCollection 348238 "Write the argument a word-like object in big endian format on the receiver. 348239 May be used to write other than plain word-like objects (such as ColorArray)." 348240 aCollection class isPointers | aCollection class isWords not 348241 ifTrue: [^self error: aCollection class name,' is not word-like']. 348242 1 to: aCollection basicSize do:[:i| 348243 self nextNumber: 4 put: (aCollection basicAt: i). 348244 ]. 348245 ^aCollection! ! 348246 348247"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 348248 348249Stream class 348250 instanceVariableNames: ''! 348251 348252!Stream class methodsFor: 'instance creation'! 348253new 348254 348255 self error: 'Streams are created with on: and with:'! ! 348256TestCase subclass: #StreamBugz 348257 instanceVariableNames: '' 348258 classVariableNames: '' 348259 poolDictionaries: '' 348260 category: 'Tests-Bugs'! 348261 348262!StreamBugz methodsFor: 'as yet unclassified' stamp: 'ar 8/5/2003 02:25'! 348263testReadWriteStreamNextNBug 348264 | aStream | 348265 aStream := ReadWriteStream on: String new. 348266 aStream nextPutAll: 'Hello World'. 348267 self shouldnt:[aStream next: 5] raise: Error. 348268! ! 348269AbstractFont subclass: #StrikeFont 348270 instanceVariableNames: 'characterToGlyphMap xTable glyphs name type minAscii maxAscii maxWidth strikeLength ascent descent xOffset raster subscript superscript emphasis derivativeFonts pointSize fallbackFont charIndex' 348271 classVariableNames: 'DefaultStringScanner' 348272 poolDictionaries: 'TextConstants' 348273 category: 'Graphics-Fonts'! 348274!StrikeFont commentStamp: '<historical>' prior: 0! 348275I represent a compact encoding of a set of Forms corresponding to characters in the ASCII character set. All the forms are placed side by side in a large form whose height is the font height, and whose width is the sum of all the character widths. The xTable variable gives the left-x coordinates of the subforms corresponding to the glyphs. Characters are mapped to glyphs by using the characterToGyphMap. 348276 348277Subclasses can have non-trivial mapping rules as well as different representations for glyphs sizes (e.g., not using an xTable). If so, these classes should return nil when queried for xTable and/or the characterToGlyphMap. This will cause the CharacterScanner primitive to fail and query the font for the width of a character (so that a more programatical approach can be implemented). 348278 348279For display, fonts need to implement two messages: 348280 #installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor 348281This method installs the receiver (a font) on the given DisplayContext (which may be an instance of BitBlt or Canvas (or any of it's subclasses). The font should take the appropriate action to initialize the display context so that further display operations can be optimized. 348282 #displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta 348283This method is called for each subsequent run of characters in aString which is to be displayed with the (previously installed) settings. 348284! 348285 348286 348287!StrikeFont methodsFor: 'accessing'! 348288ascent 348289 "Answer the receiver's maximum extent of characters above the baseline." 348290 348291 ^ascent! ! 348292 348293!StrikeFont methodsFor: 'accessing' stamp: 'di 9/2/2000 13:06'! 348294ascentKern 348295 "Return the kern delta for ascenders." 348296 (emphasis noMask: 2) ifTrue: [^ 0]. 348297 ^ (self ascent-5+4)//4 max: 0 "See makeItalicGlyphs" 348298 348299! ! 348300 348301!StrikeFont methodsFor: 'accessing' stamp: 'yo 1/6/2005 04:19'! 348302ascentOf: aCharacter 348303 348304 (self hasGlyphOf: aCharacter) ifFalse: [ 348305 fallbackFont ifNotNil: [ 348306 ^ fallbackFont ascentOf: aCharacter. 348307 ]. 348308 ]. 348309 ^ self ascent. 348310! ! 348311 348312!StrikeFont methodsFor: 'accessing' stamp: 'jmv 9/22/2009 18:40'! 348313baseKern 348314 "Return the base kern value to be used for all characters." 348315 348316 | italic | 348317 italic := emphasis allMask: 2. 348318 348319 (self isSynthetic not and: [ glyphs depth > 1 ]) ifTrue: [ 348320 ^(italic or: [ pointSize < 9 ]) 348321 ifTrue: [ 1 ] 348322 ifFalse: [ 0] ]. 348323 348324 italic ifFalse: [^ 0]. 348325 ^ ((self height-1-self ascent+4)//4 max: 0) "See makeItalicGlyphs" 348326 + (((self ascent-5+4)//4 max: 0))! ! 348327 348328!StrikeFont methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 348329characterToGlyphMap 348330 ^ characterToGlyphMap ifNil: [ characterToGlyphMap := self createCharacterToGlyphMap ]! ! 348331 348332!StrikeFont methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 348333characterToGlyphMap: anArray 348334 characterToGlyphMap := anArray! ! 348335 348336!StrikeFont methodsFor: 'accessing' stamp: 'nk 3/15/2004 18:57'! 348337derivativeFonts 348338 ^derivativeFonts copyWithout: nil! ! 348339 348340!StrikeFont methodsFor: 'accessing' stamp: 'jmv 3/19/2009 15:50'! 348341descent 348342 "Answer the receiver's maximum extent of characters below the baseline." 348343 348344 ^pointSize < 9 348345 ifTrue: [descent-1] 348346 ifFalse: [descent]! ! 348347 348348!StrikeFont methodsFor: 'accessing' stamp: 'di 9/2/2000 13:06'! 348349descentKern 348350 "Return the kern delta for descenders." 348351 (emphasis noMask: 2) ifTrue: [^ 0]. 348352 ^ (self height-1-self ascent+4)//4 max: 0 "See makeItalicGlyphs" 348353 348354! ! 348355 348356!StrikeFont methodsFor: 'accessing' stamp: 'yo 1/6/2005 04:19'! 348357descentOf: aCharacter 348358 348359 (self hasGlyphOf: aCharacter) ifFalse: [ 348360 fallbackFont ifNotNil: [ 348361 ^ fallbackFont descentOf: aCharacter. 348362 ]. 348363 ]. 348364 ^ self descent. 348365! ! 348366 348367!StrikeFont methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 348368fallbackFont 348369 ^ fallbackFont ifNil: [ fallbackFont := FixedFaceFont new errorFont fontSize: self height ]! ! 348370 348371!StrikeFont methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 348372fallbackFont: aFontSetOrNil 348373 fallbackFont := aFontSetOrNil! ! 348374 348375!StrikeFont methodsFor: 'accessing' stamp: 'jmv 8/6/2009 09:14'! 348376familyName 348377 ^self name withoutJustTrailingDigits! ! 348378 348379!StrikeFont methodsFor: 'accessing' stamp: 'tk 6/26/1998 16:45'! 348380familySizeFace 348381 "Answer an array with familyName, a String, pointSize, an Integer, and 348382 faceCode, an Integer." 348383 348384 ^Array with: name 348385 with: self height 348386 with: emphasis 348387 348388 "(1 to: 12) collect: [:x | (TextStyle default fontAt: x) familySizeFace]"! ! 348389 348390!StrikeFont methodsFor: 'accessing' stamp: 'ar 9/21/2000 11:53'! 348391fontNameWithPointSize 348392 ^self name withoutTrailingDigits, ' ', self pointSize printString! ! 348393 348394!StrikeFont methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 348395glyphInfoOf: aCharacter into: glyphInfoArray 348396 "Answer the width of the argument as a character in the receiver." 348397 | code | 348398 (self hasGlyphOf: aCharacter) 348399 ifFalse: 348400 [ fallbackFont ifNotNil: 348401 [ ^ fallbackFont 348402 glyphInfoOf: aCharacter 348403 into: glyphInfoArray ]. 348404 code := 0 ] 348405 ifTrue: [ code := aCharacter charCode ]. 348406 glyphInfoArray 348407 at: 1 348408 put: glyphs; 348409 at: 2 348410 put: (xTable at: code + 1); 348411 at: 3 348412 put: (xTable at: code + 2); 348413 at: 4 348414 put: (self ascentOf: aCharacter); 348415 at: 5 348416 put: self. 348417 ^ glyphInfoArray! ! 348418 348419!StrikeFont methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 348420glyphOf: aCharacter 348421 "Answer the width of the argument as a character in the receiver." 348422 | code | 348423 (self hasGlyphOf: aCharacter) ifFalse: 348424 [ fallbackFont ifNotNil: [ ^ fallbackFont glyphOf: aCharacter ]. 348425 ^ (Form extent: 1 @ self height) fillColor: Color white ]. 348426 code := aCharacter charCode. 348427 ^ glyphs copy: ((xTable at: code + 1) @ 0 corner: (xTable at: code + 2) @ self height)! ! 348428 348429!StrikeFont methodsFor: 'accessing'! 348430glyphs 348431 "Answer a Form containing the bits representing the characters of the 348432 receiver." 348433 348434 ^glyphs! ! 348435 348436!StrikeFont methodsFor: 'accessing'! 348437height 348438 "Answer the height of the receiver, total of maximum extents of 348439 characters above and below the baseline." 348440 348441 ^self ascent + self descent! ! 348442 348443!StrikeFont methodsFor: 'accessing' stamp: 'yo 1/6/2005 04:19'! 348444heightOf: aCharacter 348445 348446 (self hasGlyphOf: aCharacter) ifFalse: [ 348447 fallbackFont ifNotNil: [ 348448 ^ fallbackFont heightOf: aCharacter. 348449 ]. 348450 ]. 348451 ^ self height. 348452! ! 348453 348454!StrikeFont methodsFor: 'accessing'! 348455lineGrid 348456 ^ ascent + descent! ! 348457 348458!StrikeFont methodsFor: 'accessing'! 348459maxAscii 348460 "Answer the integer that is the last Ascii character value of the receiver." 348461 348462 ^maxAscii! ! 348463 348464!StrikeFont methodsFor: 'accessing'! 348465maxWidth 348466 "Answer the integer that is the width of the receiver's widest character." 348467 348468 ^maxWidth! ! 348469 348470!StrikeFont methodsFor: 'accessing'! 348471minAscii 348472 "Answer the integer that is the first Ascii character value of the receiver." 348473 348474 ^minAscii! ! 348475 348476!StrikeFont methodsFor: 'accessing' stamp: 'ls 3/27/2000 19:54'! 348477name 348478 "Answer the receiver's name." 348479 348480 ^name ifNil: ['(unnamed)']! ! 348481 348482!StrikeFont methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 348483name: aString 348484 "Set the receiver's name." 348485 name := aString! ! 348486 348487!StrikeFont methodsFor: 'accessing' stamp: 'sw 1/18/2000 20:54'! 348488pointSize 348489 ^ pointSize! ! 348490 348491!StrikeFont methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 348492pointSize: anInteger 348493 pointSize := anInteger! ! 348494 348495!StrikeFont methodsFor: 'accessing'! 348496raster 348497 "Answer an integer that specifies the layout of the glyphs' form." 348498 348499 ^raster! ! 348500 348501!StrikeFont methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 348502setGlyphs: newGlyphs 348503 "Replace the glyphs form. Used to make a synthetic bold or italic font quickly." 348504 glyphs := newGlyphs! ! 348505 348506!StrikeFont methodsFor: 'accessing'! 348507subscript 348508 "Answer an integer that is the further vertical offset relative to the 348509 baseline for positioning characters as subscripts." 348510 348511 ^subscript! ! 348512 348513!StrikeFont methodsFor: 'accessing'! 348514superscript 348515 "Answer an integer that is the further vertical offset relative to the 348516 baseline for positioning characters as superscripts." 348517 348518 ^superscript! ! 348519 348520!StrikeFont methodsFor: 'accessing' stamp: 'nk 6/17/2003 14:26'! 348521textStyle 348522 ^ TextStyle actualTextStyles detect: 348523 [:aStyle | aStyle fontArray includes: self] ifNone: [nil]! ! 348524 348525!StrikeFont methodsFor: 'accessing' stamp: 'jmv 8/3/2009 10:01'! 348526widthOf: aCharacter 348527 "Answer the width of the argument as a character in the receiver." 348528 | code | 348529 code := aCharacter charCode. 348530 self characterToGlyphMap size > code ifTrue: [ 348531 code := characterToGlyphMap at: code + 1 ]. 348532 ((code < minAscii or: [maxAscii < code]) 348533 or: [(xTable at: code + 1) < 0]) 348534 ifTrue: [^ self fallbackFont widthOf: aCharacter]. 348535 ^ (xTable at: code + 2) - (xTable at: code + 1)! ! 348536 348537!StrikeFont methodsFor: 'accessing'! 348538xTable 348539 "Answer an Array of the left x-coordinate of characters in glyphs." 348540 348541 ^xTable! ! 348542 348543!StrikeFont methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 348544xTable: anObject 348545 xTable := anObject! ! 348546 348547 348548!StrikeFont methodsFor: 'building' stamp: 'StephaneDucasse 10/17/2009 17:15'! 348549buildFromForm: allGlyphs data: data name: aString 348550 | x | 348551 pointSize := data first. 348552 ascent := data second. 348553 descent := data third. 348554 minAscii := 32. 348555 maxAscii := 255. 348556 name := aString. 348557 type := 0. "ignored for now" 348558 superscript := (ascent - descent) // 3. 348559 subscript := (descent - ascent) // 3. 348560 emphasis := 0. 348561 xTable := (Array new: 258) atAllPut: 0. 348562 maxWidth := 0. 348563 glyphs := allGlyphs. 348564 x := 0. 348565 minAscii 348566 to: maxAscii + 1 348567 do: 348568 [ :i | 348569 x := data at: i - minAscii + 4. 348570 xTable 348571 at: i + 1 348572 put: x ]. 348573 xTable 348574 at: 258 348575 put: x. 348576 self reset. 348577 derivativeFonts := Array new: 32! ! 348578 348579!StrikeFont methodsFor: 'building' stamp: 'StephaneDucasse 10/17/2009 17:15'! 348580setGlyphsDepthAtMost: aNumber 348581 glyphs depth > aNumber ifTrue: [ glyphs := glyphs asFormOfDepth: aNumber ]! ! 348582 348583!StrikeFont methodsFor: 'building' stamp: 'StephaneDucasse 10/17/2009 17:15'! 348584stripHighGlyphs 348585 "Remove glyphs for characters above 128" 348586 | i | 348587 maxAscii := 127. 348588 xTable := xTable 348589 copyFrom: 1 348590 to: maxAscii + 3. 348591 i := xTable at: maxAscii + 1. 348592 xTable 348593 at: maxAscii + 2 348594 put: i. 348595 xTable 348596 at: maxAscii + 3 348597 put: i. 348598 glyphs := glyphs copy: (0 @ 0 extent: i @ glyphs height). 348599 maxWidth := 0. 348600 2 348601 to: xTable size 348602 do: [ :ii | maxWidth := maxWidth max: (xTable at: ii) - (xTable at: ii - 1) - 1 ]. 348603 characterToGlyphMap := nil. 348604 self reset! ! 348605 348606 348607!StrikeFont methodsFor: 'character shapes'! 348608alter: char formBlock: formBlock 348609 self characterFormAt: char 348610 put: (formBlock value: (self characterFormAt: char))! ! 348611 348612!StrikeFont methodsFor: 'character shapes' stamp: 'lr 7/4/2009 10:42'! 348613characterFormAtMulti: character 348614 "Answer a Form copied out of the glyphs for the argument, character." 348615 | ascii leftX rightX | 348616 ascii := character charCode. 348617 (ascii 348618 between: minAscii 348619 and: maxAscii) ifFalse: [ ascii := maxAscii + 1 ]. 348620 leftX := xTable at: ascii + 1. 348621 rightX := xTable at: ascii + 2. 348622 ^ glyphs copy: (leftX @ 0 corner: rightX @ self height)! ! 348623 348624!StrikeFont methodsFor: 'character shapes' stamp: 'lr 7/4/2009 10:42'! 348625characterFormAt: character 348626 "Answer a Form copied out of the glyphs for the argument, character." 348627 | ascii leftX rightX | 348628 ascii := character charCode. 348629 (ascii 348630 between: minAscii 348631 and: maxAscii) ifFalse: [ ascii := maxAscii + 1 ]. 348632 leftX := xTable at: ascii + 1. 348633 rightX := xTable at: ascii + 2. 348634 leftX < 0 ifTrue: [ ^ glyphs copy: (0 @ 0 corner: 0 @ self height) ]. 348635 ^ glyphs copy: (leftX @ 0 corner: rightX @ self height)! ! 348636 348637!StrikeFont methodsFor: 'character shapes' stamp: 'StephaneDucasse 10/17/2009 17:15'! 348638characterFormAt: character put: characterForm 348639 "Copy characterForm over the glyph for the argument, character." 348640 | ascii leftX rightX widthDif newGlyphs | 348641 ascii := character asciiValue. 348642 ascii < minAscii ifTrue: [ ^ self error: 'Cant store characters below min ascii' ]. 348643 ascii > maxAscii ifTrue: 348644 [ (self confirm: 'This font does not accomodate ascii values higher than ' , maxAscii printString , '. 348645Do you wish to extend it permanently to handle values up to ' , ascii printString) 348646 ifTrue: [ self extendMaxAsciiTo: ascii ] 348647 ifFalse: [ ^ self error: 'No change made' ] ]. 348648 leftX := xTable at: ascii + 1. 348649 rightX := xTable at: ascii + 2. 348650 widthDif := characterForm width - (rightX - leftX). 348651 widthDif ~= 0 ifTrue: 348652 [ "Make new glyphs with more or less space for this char" 348653 newGlyphs := Form 348654 extent: (glyphs width + widthDif) @ glyphs height 348655 depth: glyphs depth. 348656 newGlyphs 348657 copy: (0 @ 0 corner: leftX @ glyphs height) 348658 from: 0 @ 0 348659 in: glyphs 348660 rule: Form over. 348661 newGlyphs 348662 copy: ((rightX + widthDif) @ 0 corner: newGlyphs width @ glyphs height) 348663 from: rightX @ 0 348664 in: glyphs 348665 rule: Form over. 348666 glyphs := newGlyphs. 348667 "adjust further entries on xTable" 348668 xTable := xTable copy. 348669 ascii + 2 348670 to: xTable size 348671 do: 348672 [ :i | 348673 xTable 348674 at: i 348675 put: (xTable at: i) + widthDif ] ]. 348676 glyphs 348677 copy: (leftX @ 0 extent: characterForm extent) 348678 from: 0 @ 0 348679 in: characterForm 348680 rule: Form over 348681 " 348682| f | f _ TextStyle defaultFont. 348683f characterFormAt: $ put: (Form extent: (f widthOf: $ )+10@f height) 348684"! ! 348685 348686!StrikeFont methodsFor: 'character shapes' stamp: 'lr 7/4/2009 10:42'! 348687characterForm: char pixelValueAt: pt put: val 348688 | f | 348689 f := self characterFormAt: char. 348690 f 348691 pixelAt: pt 348692 put: val. 348693 self 348694 characterFormAt: char 348695 put: val! ! 348696 348697!StrikeFont methodsFor: 'character shapes' stamp: 'StephaneDucasse 10/17/2009 17:15'! 348698ensureCleanBold 348699 "This ensures that all character glyphs have at least one pixel of white space on the right 348700 so as not to cause artifacts in neighboring characters in bold or italic." 348701 | wider glyph | 348702 emphasis = 0 ifFalse: [ ^ self ]. 348703 minAscii 348704 to: maxAscii 348705 do: 348706 [ :i | 348707 glyph := self characterFormAt: (Character value: i). 348708 (glyph copy: (glyph boundingBox topRight - (1 @ 0) corner: glyph boundingBox bottomRight)) isAllWhite ifFalse: 348709 [ wider := Form 348710 extent: (glyph width + 1) @ glyph height 348711 depth: glyph depth. 348712 glyph depth > 1 ifTrue: [ wider fillWhite ]. 348713 glyph displayOn: wider. 348714 self 348715 characterFormAt: (Character value: i) 348716 put: wider ] ] 348717 " 348718StrikeFont allInstancesDo: [:f | f ensureCleanBold]. 348719(StrikeFont familyName: 'NewYork' size: 21) ensureCleanBold. 348720StrikeFont shutDown. 'Flush synthetic fonts'. 348721"! ! 348722 348723!StrikeFont methodsFor: 'character shapes' stamp: 'lr 7/4/2009 10:42'! 348724extendMaxAsciiTo: newMax 348725 "Extend the range of this font so that it can display glyphs up to newMax." 348726 newMax + 3 <= xTable size ifTrue: [ ^ self ]. "No need to extend." 348727 xTable size = (maxAscii + 3) ifFalse: [ ^ self error: 'This font is not well-formed.' ]. 348728 348729 "Insert a bunch of zero-width characters..." 348730 xTable := (xTable 348731 copyFrom: 1 348732 to: maxAscii + 2) , ((maxAscii + 1 to: newMax) collect: [ :i | xTable at: maxAscii + 2 ]) , { (xTable at: maxAscii + 3) }. 348733 maxAscii := newMax. 348734 self fillZeroWidthSlots. 348735 characterToGlyphMap := nil! ! 348736 348737!StrikeFont methodsFor: 'character shapes' stamp: 'lr 7/4/2009 10:42'! 348738fillZeroWidthSlots 348739 "Note: this is slow because it copies the font once for every replacement." 348740 | nullGlyph | 348741 nullGlyph := (Form extent: 1 @ glyphs height) fillGray. 348742 "Now fill the empty slots with narrow box characters." 348743 minAscii 348744 to: maxAscii 348745 do: 348746 [ :i | 348747 (self widthOf: (Character value: i)) = 0 ifTrue: 348748 [ self 348749 characterFormAt: (Character value: i) 348750 put: nullGlyph ] ]! ! 348751 348752!StrikeFont methodsFor: 'character shapes' stamp: 'lr 7/4/2009 10:42'! 348753fixOneWideChars 348754 "This fixes all 1-wide characters to be 2 wide with blank on the right 348755 so as not to cause artifacts in neighboring characters in bold or italic." 348756 | twoWide | 348757 minAscii 348758 to: maxAscii 348759 do: 348760 [ :i | 348761 (self widthOf: (Character value: i)) = 1 ifTrue: 348762 [ twoWide := Form extent: 2 @ glyphs height. 348763 (self characterFormAt: (Character value: i)) 348764 displayOn: twoWide 348765 at: 0 @ 0. 348766 self 348767 characterFormAt: (Character value: i) 348768 put: twoWide ] ] 348769 " 348770StrikeFont allInstancesDo: [:f | f fixOneWideChars]. 348771StrikeFont shutDown. 'Flush synthetic fonts'. 348772"! ! 348773 348774!StrikeFont methodsFor: 'character shapes' stamp: 'lr 7/4/2009 10:42'! 348775makeCarriageReturnsWhite 348776 "Some larger fonts have a gray carriage return (from the zero wide fixup) make it white so it doesn't show" 348777 | crForm | 348778 crForm := self characterFormAt: 13 asCharacter. 348779 crForm fillWhite. 348780 self 348781 characterFormAt: 13 asCharacter 348782 put: crForm! ! 348783 348784!StrikeFont methodsFor: 'character shapes' stamp: 'StephaneDucasse 10/17/2009 17:15'! 348785makeControlCharsVisible 348786 | glyph d | 348787 self characterToGlyphMap. 348788 glyph := self characterFormAt: Character space. 348789 glyph 348790 border: glyph boundingBox 348791 width: 1 348792 fillColor: Color blue. 348793 self 348794 characterFormAt: (Character value: 133) 348795 put: glyph. 348796 348797 "Keep tab(9), lf(10), cr(13) and space(32) transparent or whatever the user chose" 348798 #( 348799 0 348800 1 348801 2 348802 3 348803 4 348804 5 348805 6 348806 7 348807 8 348808 11 348809 12 348810 14 348811 15 348812 16 348813 17 348814 18 348815 19 348816 20 348817 21 348818 22 348819 23 348820 24 348821 25 348822 26 348823 27 348824 28 348825 29 348826 30 348827 31 348828 ) do: 348829 [ :ascii | 348830 characterToGlyphMap 348831 at: ascii + 1 348832 put: 133 ]! ! 348833 348834!StrikeFont methodsFor: 'character shapes' stamp: 'jmv 3/26/2009 14:40'! 348835makeLfInvisible 348836 self characterToGlyphMap. 348837 characterToGlyphMap at: 11 put: (11 < minAscii ifFalse: [11] ifTrue: [maxAscii+1])! ! 348838 348839!StrikeFont methodsFor: 'character shapes' stamp: 'StephaneDucasse 10/17/2009 17:15'! 348840makeLfVisible 348841 | glyph | 348842 self characterToGlyphMap. 348843 glyph := self characterFormAt: (Character value: 163). 348844 glyph 348845 border: glyph boundingBox 348846 width: 1 348847 fillColor: Color blue. 348848 " glyph _ glyph reverse." 348849 self 348850 characterFormAt: (Character value: 132) 348851 put: glyph. 348852 characterToGlyphMap 348853 at: 11 348854 put: 132! ! 348855 348856!StrikeFont methodsFor: 'character shapes' stamp: 'jmv 3/26/2009 14:40'! 348857makeTabInvisible 348858 self characterToGlyphMap. 348859 characterToGlyphMap at: 10 put: (10 < minAscii ifFalse: [10] ifTrue:[maxAscii+1])! ! 348860 348861!StrikeFont methodsFor: 'character shapes' stamp: 'jmv 3/26/2009 14:41'! 348862makeTabVisible 348863 self characterToGlyphMap. 348864 characterToGlyphMap at: 10 put: 172! ! 348865 348866!StrikeFont methodsFor: 'character shapes' stamp: 'jmv 3/26/2009 15:17'! 348867useLeftArrow 348868 self characterToGlyphMap. 348869 characterToGlyphMap at: 96 put: 95. 348870 characterToGlyphMap at: 95 put: 94! ! 348871 348872!StrikeFont methodsFor: 'character shapes' stamp: 'jmv 3/26/2009 14:49'! 348873useUnderscore 348874 self characterToGlyphMap. 348875 characterToGlyphMap at: 96 put: 129. 348876 characterToGlyphMap at: 95 put: 128! ! 348877 348878!StrikeFont methodsFor: 'character shapes' stamp: 'jmv 8/6/2009 14:23'! 348879useUnderscoreIfOver1bpp 348880 348881 glyphs depth = 1 ifTrue: [ 348882 characterToGlyphMap ifNotNil: [ 348883 characterToGlyphMap at: 96 put: 95. 348884 characterToGlyphMap at: 95 put: 94 ]. 348885 ^self ]. 348886 348887 self characterToGlyphMap. 348888 characterToGlyphMap at: 96 put: 129. 348889 characterToGlyphMap at: 95 put: 128! ! 348890 348891!StrikeFont methodsFor: 'character shapes' stamp: 'lr 7/4/2009 10:42'! 348892widen: char by: delta 348893 | newForm | 348894 ^ self 348895 alter: char 348896 formBlock: 348897 [ :charForm | 348898 "Make a new form, wider or narrower..." 348899 newForm := Form extent: charForm extent + (delta @ 0). 348900 charForm displayOn: newForm. "Copy this image into it" 348901 newForm "and substitute it in the font" ]! ! 348902 348903 348904!StrikeFont methodsFor: 'copying' stamp: 'BG 12/9/2004 17:27'! 348905deepCopy 348906 " there is a circular reference from the derivative fonts back to the receiver. It is therefore not possible to make a deep copy. We make a sahllow copy. The method postCopy can be used to modify the shallow copy. " 348907 ^self copy! ! 348908 348909!StrikeFont methodsFor: 'copying' stamp: 'BG 12/9/2004 17:35'! 348910postCopy 348911 " the receiver is a just created shallow copy. This method gives it the final touch. " 348912 348913 glyphs := glyphs copy. 348914 xTable := xTable copy. 348915 characterToGlyphMap := characterToGlyphMap copy. 348916 348917 self reset. " takes care of the derivative fonts "! ! 348918 348919!StrikeFont methodsFor: 'copying' stamp: 'tk 8/19/1998 16:15'! 348920veryDeepCopyWith: deepCopier 348921 "Return self. I am shared. Do not record me."! ! 348922 348923 348924!StrikeFont methodsFor: 'displaying' stamp: 'lr 7/4/2009 10:42'! 348925characters: anInterval in: sourceString displayAt: aPoint clippedBy: clippingRectangle rule: ruleInteger fillColor: aForm kernDelta: kernDelta on: aBitBlt 348926 "Simple, slow, primitive method for displaying a line of characters. 348927 No wrap-around is provided." 348928 | ascii destPoint leftX rightX sourceRect | 348929 destPoint := aPoint. 348930 anInterval do: 348931 [ :i | 348932 self flag: #yoDisplay. 348933 "if the char is not supported, fall back to the specified fontset." 348934 ascii := (sourceString at: i) charCode. 348935 (ascii < minAscii or: [ ascii > maxAscii ]) ifTrue: [ ascii := maxAscii ]. 348936 leftX := xTable at: ascii + 1. 348937 rightX := xTable at: ascii + 2. 348938 sourceRect := leftX @ 0 extent: (rightX - leftX) @ self height. 348939 aBitBlt 348940 copyFrom: sourceRect 348941 in: glyphs 348942 to: destPoint. 348943 destPoint := destPoint + ((rightX - leftX + kernDelta) @ 0) 348944 "destPoint printString displayAt: 0@(i*20)" ]. 348945 ^ destPoint! ! 348946 348947!StrikeFont methodsFor: 'displaying' stamp: 'yo 5/19/2004 11:36'! 348948displayLine: aString at: aPoint 348949 "Display the characters in aString, starting at position aPoint." 348950 348951 self characters: (1 to: aString size) 348952 in: aString 348953 displayAt: aPoint 348954 clippedBy: Display boundingBox 348955 rule: Form over 348956 fillColor: nil 348957 kernDelta: 0 348958 on: (BitBlt current toForm: Display). 348959! ! 348960 348961!StrikeFont methodsFor: 'displaying' stamp: 'lr 7/4/2009 10:42'! 348962displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY 348963 | destPoint leftX rightX glyphInfo char displayInfo destY | 348964 destPoint := aPoint. 348965 charIndex := startIndex. 348966 glyphInfo := Array new: 5. 348967 [ charIndex <= stopIndex ] whileTrue: 348968 [ char := aString at: charIndex. 348969 (self hasGlyphOf: char) not 348970 ifTrue: 348971 [ displayInfo := self fallbackFont 348972 displayString: aString 348973 on: aBitBlt 348974 from: charIndex 348975 to: stopIndex 348976 at: destPoint 348977 kern: kernDelta 348978 from: self 348979 baselineY: baselineY. 348980 charIndex := displayInfo at: 1. 348981 destPoint := displayInfo at: 2 ] 348982 ifFalse: 348983 [ self 348984 glyphInfoOf: char 348985 into: glyphInfo. 348986 leftX := glyphInfo at: 2. 348987 rightX := glyphInfo at: 3. 348988 glyphInfo fifth ~= aBitBlt lastFont ifTrue: [ glyphInfo fifth installOn: aBitBlt ]. 348989 aBitBlt sourceForm: (glyphInfo at: 1). 348990 destY := baselineY - (glyphInfo at: 4). 348991 aBitBlt destX: destPoint x. 348992 aBitBlt destY: destY. 348993 aBitBlt sourceOrigin: leftX @ 0. 348994 aBitBlt width: rightX - leftX. 348995 aBitBlt height: self height. 348996 aBitBlt copyBits. 348997 destPoint := destPoint + ((rightX - leftX + kernDelta) @ 0). 348998 charIndex := charIndex + 1 ] ]. 348999 ^ Array 349000 with: charIndex 349001 with: destPoint! ! 349002 349003!StrikeFont methodsFor: 'displaying' stamp: 'yo 12/20/2002 18:54'! 349004displayStringR2L: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 349005 "You are screwed if you reach this method." 349006 self halt. 349007 aBitBlt displayString: aString 349008 from: startIndex 349009 to: stopIndex 349010 at: aPoint 349011 strikeFont: self 349012 kern: kernDelta.! ! 349013 349014!StrikeFont methodsFor: 'displaying' stamp: 'ar 4/10/2005 18:06'! 349015displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 349016 "Draw the given string from startIndex to stopIndex 349017 at aPoint on the (already prepared) BitBlt." 349018 349019 (aString isByteString) ifFalse: [^ self displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent.]. 349020 349021 ^ aBitBlt displayString: aString 349022 from: startIndex 349023 to: stopIndex 349024 at: aPoint 349025 strikeFont: self 349026 kern: kernDelta.! ! 349027 349028!StrikeFont methodsFor: 'displaying' stamp: 'ar 4/10/2005 18:06'! 349029displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY 349030 "Draw the given string from startIndex to stopIndex 349031 at aPoint on the (already prepared) BitBlt." 349032 349033 (aString isByteString) ifFalse:[^ self displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY.]. 349034 349035 ^ aBitBlt displayString: aString 349036 from: startIndex 349037 to: stopIndex 349038 at: aPoint 349039 strikeFont: self 349040 kern: kernDelta.! ! 349041 349042!StrikeFont methodsFor: 'displaying' stamp: 'BG 3/16/2005 08:27'! 349043fontDisplay 349044 "TextStyle default defaultFont fontDisplay." 349045 349046 Display restoreAfter: 349047 [(Form extent: 440@400) displayAt: 90@90. 349048 0 to: 15 do: 349049 [:i | 349050 i storeStringHex displayAt: 100 @ (20 * i + 100). 349051 0 to: 15 do: 349052 [:j | 349053 ((16*i+j) between: 1 and: (self xTable size - 2)) ifTrue: 349054 [(self characterFormAt: (16 * i + j) asCharacter) 349055 displayAt: (20 * j + 150) @ (20 * i + 100)]]]. 349056 'Click to continue...' asDisplayText displayAt: 100@450]! ! 349057 349058!StrikeFont methodsFor: 'displaying' stamp: 'yo 1/5/2005 13:59'! 349059installOn: aDisplayContext 349060 349061 ^aDisplayContext installStrikeFont: self. 349062! ! 349063 349064!StrikeFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 15:08'! 349065installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor 349066 ^aDisplayContext 349067 installStrikeFont: self 349068 foregroundColor: foregroundColor 349069 backgroundColor: backgroundColor! ! 349070 349071!StrikeFont methodsFor: 'displaying' stamp: 'lr 7/4/2009 10:42'! 349072widthOfString: aString from: firstIndex to: lastIndex 349073 | resultX | 349074 resultX := 0. 349075 firstIndex 349076 to: lastIndex 349077 do: [ :i | resultX := resultX + (self widthOf: (aString at: i)) ]. 349078 ^ resultX! ! 349079 349080 349081!StrikeFont methodsFor: 'emphasis' stamp: 'lr 7/4/2009 10:42'! 349082bonk: glyphForm with: bonkForm 349083 "Bonking means to run through the glyphs clearing out black pixels 349084 between characters to prevent them from straying into an adjacent 349085 character as a result of, eg, bolding or italicizing" 349086 "Uses the bonkForm to erase at every character boundary in glyphs." 349087 | bb offset x | 349088 offset := bonkForm offset x. 349089 bb := BitBlt current toForm: glyphForm. 349090 bb 349091 sourceForm: bonkForm; 349092 sourceRect: bonkForm boundingBox; 349093 combinationRule: Form erase; 349094 destY: 0. 349095 x := self xTable. 349096 (x isMemberOf: SparseLargeTable) 349097 ifTrue: 349098 [ x base 349099 to: x size - 1 349100 do: 349101 [ :i | 349102 bb 349103 destX: (x at: i) + offset; 349104 copyBits ] ] 349105 ifFalse: 349106 [ 1 349107 to: x size - 1 349108 do: 349109 [ :i | 349110 bb 349111 destX: (x at: i) + offset; 349112 copyBits ] ]! ! 349113 349114!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 3/20/2009 10:27'! 349115derivativeFont: aStrikeFont at: index 349116 349117 | newDeriv | 349118 (aStrikeFont isNil and: [ index = 0 ]) 349119 ifTrue: [derivativeFonts := nil. ^ self]. 349120 derivativeFonts ifNil: [derivativeFonts := Array new: 32]. 349121 derivativeFonts size < 32 ifTrue: [ 349122 newDeriv := Array new: 32. 349123 newDeriv replaceFrom: 1 to: derivativeFonts size with: derivativeFonts. 349124 derivativeFonts := newDeriv. 349125 ]. 349126 derivativeFonts at: index put: aStrikeFont.! ! 349127 349128!StrikeFont methodsFor: 'emphasis'! 349129emphasis 349130 "Answer the integer code for synthetic bold, italic, underline, and 349131 strike-out." 349132 349133 ^emphasis! ! 349134 349135!StrikeFont methodsFor: 'emphasis' stamp: 'lr 7/4/2009 10:42'! 349136emphasis: code 349137 "Set the integer code for synthetic bold, itallic, underline, and strike-out, 349138 where bold=1, italic=2, underlined=4, and struck out=8." 349139 emphasis := code! ! 349140 349141!StrikeFont methodsFor: 'emphasis' stamp: 'lr 7/4/2009 10:42'! 349142emphasized: code 349143 "Answer a copy of the receiver with emphasis set to include code." 349144 | derivative addedEmphasis base safeCode | 349145 code = 0 ifTrue: [ ^ self ]. 349146 (derivativeFonts == nil or: [ derivativeFonts size = 0 ]) ifTrue: [ ^ self ]. 349147 derivative := derivativeFonts at: (safeCode := code min: derivativeFonts size). 349148 derivative == nil ifFalse: [ ^ derivative ]. "Already have this style" 349149 349150 "Dont have it -- derive from another with one with less emphasis" 349151 addedEmphasis := 1 bitShift: safeCode highBit - 1. 349152 base := self emphasized: safeCode - addedEmphasis. "Order is Bold, Ital, Under, Narrow" 349153 addedEmphasis = 1 ifTrue: 349154 [ "Compute synthetic bold version of the font" 349155 derivative := (base copy ensureCleanBold name: base name , 'B') makeBoldGlyphs ]. 349156 addedEmphasis = 2 ifTrue: 349157 [ "Compute synthetic italic version of the font" 349158 derivative := (base copy name: base name , 'I') makeItalicGlyphs ]. 349159 addedEmphasis = 4 ifTrue: 349160 [ "Compute underlined version of the font" 349161 derivative := (base copy name: base name , 'U') makeUnderlinedGlyphs ]. 349162 addedEmphasis = 8 ifTrue: 349163 [ "Compute narrow version of the font" 349164 derivative := (base copy name: base name , 'N') makeCondensedGlyphs ]. 349165 addedEmphasis = 16 ifTrue: 349166 [ "Compute struck-out version of the font" 349167 derivative := (base copy name: base name , 'X') makeStruckOutGlyphs ]. 349168 derivative emphasis: safeCode. 349169 derivativeFonts 349170 at: safeCode 349171 put: derivative. 349172 ^ derivative! ! 349173 349174!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 4/26/2008 14:12'! 349175isSynthetic 349176 ^type = 3! ! 349177 349178!StrikeFont methodsFor: 'emphasis' stamp: 'StephaneDucasse 10/17/2009 17:15'! 349179isSynthetic: aBoolean 349180 type := aBoolean 349181 ifTrue: [ 3 ] 349182 ifFalse: [ 0 ]! ! 349183 349184!StrikeFont methodsFor: 'emphasis' stamp: 'StephaneDucasse 10/17/2009 17:15'! 349185makeBoldGlyphs 349186 "Make a bold set of glyphs with same widths by ORing 1 bit to the right 349187 (requires at least 1 pixel of intercharacter space)" 349188 | g bonkForm | 349189 g := glyphs deepCopy. 349190 bonkForm := (Form extent: 1 @ 16) fillBlack offset: -1 @ 0. 349191 self 349192 bonk: g 349193 with: bonkForm. 349194 glyphs depth = 1 349195 ifTrue: 349196 [ g 349197 copyBits: g boundingBox 349198 from: g 349199 at: 1 @ 0 349200 clippingBox: g boundingBox 349201 rule: Form under 349202 fillColor: nil ] 349203 ifFalse: 349204 [ 0 349205 to: g width - 2 349206 do: 349207 [ :x | 349208 0 349209 to: g height - 1 349210 do: 349211 [ :y | 349212 (glyphs colorAt: x @ y) = Color white ifFalse: 349213 [ g 349214 colorAt: (x + 1) @ y 349215 put: ((glyphs colorAt: (x + 1) @ y) = Color white 349216 ifTrue: [ glyphs colorAt: x @ y ] 349217 ifFalse: [ Color black ]) ] ] ] ]. 349218 glyphs := g. 349219 self isSynthetic: true. 349220 fallbackFont ifNotNil: [ fallbackFont := fallbackFont emphasized: 1 ]! ! 349221 349222!StrikeFont methodsFor: 'emphasis' stamp: 'StephaneDucasse 10/17/2009 17:15'! 349223makeCondensedGlyphs 349224 "Make a condensed set of glyphs with same widths. 349225 NOTE: this has been superceded by kerning -- should not get called" 349226 | g newXTable x x1 w | 349227 g := glyphs deepCopy. 349228 newXTable := Array new: xTable size. 349229 newXTable 349230 at: 1 349231 put: (x := xTable at: 1). 349232 1 349233 to: xTable size - 1 349234 do: 349235 [ :i | 349236 x1 := xTable at: i. 349237 w := (xTable at: i + 1) - x1. 349238 w > 1 ifTrue: [ w := w - 1 ]. "Shrink every character wider than 1" 349239 g 349240 copy: (x @ 0 extent: w @ g height) 349241 from: x1 @ 0 349242 in: glyphs 349243 rule: Form over. 349244 newXTable 349245 at: i + 1 349246 put: (x := x + w) ]. 349247 xTable := newXTable. 349248 glyphs := g. 349249 self isSynthetic: true. 349250 fallbackFont ifNotNil: [ fallbackFont emphasized: 8 ] 349251 349252 " 349253(TextStyle default fontAt: 1) copy makeCondensedGlyphs 349254 displayLine: 'The quick brown fox jumps over the lazy dog' 349255 at: Sensor cursorPoint 349256"! ! 349257 349258!StrikeFont methodsFor: 'emphasis' stamp: 'StephaneDucasse 10/17/2009 17:15'! 349259makeItalicGlyphs 349260 "Make an italic set of glyphs with same widths by skewing left and right. 349261 In the process, characters would overlap, so we widen them all first. 349262 " 349263 | extraWidth newGlyphs newXTable x newX w extraOnLeft | 349264 extraOnLeft := (self height - 1 - self ascent + 4) // 4 max: 0. 349265 extraWidth := ((self ascent - 5 + 4) // 4 max: 0) + extraOnLeft. 349266 newGlyphs := Form 349267 extent: (glyphs width + ((maxAscii + 1 - minAscii) * extraWidth)) @ glyphs height 349268 depth: glyphs depth. 349269 newGlyphs fillWhite. 349270 newXTable := xTable copy. 349271 349272 "Copy glyphs into newGlyphs with room on left and right for overlap." 349273 minAscii 349274 to: maxAscii + 1 349275 do: 349276 [ :ascii | 349277 x := xTable at: ascii + 1. 349278 w := (xTable at: ascii + 2) - x. 349279 newX := newXTable at: ascii + 1. 349280 newGlyphs 349281 copy: ((newX + extraOnLeft) @ 0 extent: w @ glyphs height) 349282 from: x @ 0 349283 in: glyphs 349284 rule: Form over. 349285 newXTable 349286 at: ascii + 2 349287 put: newX + w + extraWidth ]. 349288 glyphs := newGlyphs. 349289 xTable := newXTable. 349290 "Slide the bitmaps left and right for synthetic italic effect." 349291 4 349292 to: self ascent - 1 349293 by: 4 349294 do: 349295 [ :y | 349296 "Slide ascenders right..." 349297 glyphs 349298 copy: (1 @ 0 extent: glyphs width @ (self ascent - y)) 349299 from: 0 @ 0 349300 in: glyphs 349301 rule: Form over ]. 349302 self ascent 349303 to: self height - 1 349304 by: 4 349305 do: 349306 [ :y | 349307 "Slide descenders left..." 349308 glyphs 349309 copy: (0 @ y extent: glyphs width @ glyphs height) 349310 from: 1 @ y 349311 in: glyphs 349312 rule: Form over ]. 349313 self isSynthetic: true. 349314 fallbackFont ifNotNil: [ fallbackFont := fallbackFont emphasized: 2 ]! ! 349315 349316!StrikeFont methodsFor: 'emphasis' stamp: 'StephaneDucasse 10/17/2009 17:15'! 349317makeStruckOutGlyphs 349318 "Make a struck-out set of glyphs with same widths" 349319 | g | 349320 g := glyphs deepCopy. 349321 g fillBlack: (0 @ (self ascent - (self ascent // 3)) extent: g width @ 1). 349322 glyphs := g. 349323 self isSynthetic: true. 349324 fallbackFont ifNotNil: [ fallbackFont := fallbackFont emphasized: 16 ]! ! 349325 349326!StrikeFont methodsFor: 'emphasis' stamp: 'StephaneDucasse 10/17/2009 17:15'! 349327makeUnderlinedGlyphs 349328 "Make an underlined set of glyphs with same widths" 349329 | g | 349330 g := glyphs deepCopy. 349331 g fillBlack: (0 @ (self ascent + 1) extent: g width @ 1). 349332 glyphs := g. 349333 self isSynthetic: true. 349334 fallbackFont ifNotNil: [ fallbackFont := fallbackFont emphasized: 4 ]! ! 349335 349336!StrikeFont methodsFor: 'emphasis' stamp: 'nk 3/15/2004 18:46'! 349337releaseCachedState 349338 349339 self reset.! ! 349340 349341!StrikeFont methodsFor: 'emphasis' stamp: 'StephaneDucasse 10/17/2009 17:15'! 349342reset 349343 "Reset the cache of derivative emphasized fonts" 349344 fallbackFont class = FixedFaceFont ifTrue: [ fallbackFont := nil ]. 349345 derivativeFonts notNil ifTrue: 349346 [ derivativeFonts withIndexDo: 349347 [ :f :i | 349348 (f notNil and: [ f isSynthetic ]) ifTrue: 349349 [ derivativeFonts 349350 at: i 349351 put: nil ] ] ] 349352 " 349353 derivativeFonts _ Array new: 32. 349354 #('B' 'I' 'BI') doWithIndex: 349355 [:tag :index | 349356 (style _ TextStyle named: self familyName) ifNotNil: 349357 [(font _ style fontArray 349358 detect: [:each | each name = (self name , tag)] 349359 ifNone: [nil]) ifNotNil: [derivativeFonts at: index put: font]]] 349360 "! ! 349361 349362 349363!StrikeFont methodsFor: 'file in/out' stamp: 'lr 7/4/2009 10:42'! 349364buildfontNamed: nm fromForms: forms startingAtAscii: startAscii ascent: a descent: d maxWid: m 349365 "This builds a StrikeFont instance from existing forms." 349366 | lastAscii width ascii charForm missingForm tempGlyphs | 349367 name := nm. 349368 ascent := 11. 349369 descent := 3. 349370 maxWidth := 16. 349371 pointSize := 8. 349372 name := (name copyWithout: Character space) , (pointSize < 10 349373 ifTrue: [ '0' , pointSize printString ] 349374 ifFalse: [ pointSize printString ]). 349375 minAscii := 258. 349376 maxAscii := 0. 349377 superscript := (ascent - descent) // 3. 349378 subscript := (descent - ascent) // 3. 349379 emphasis := 0. 349380 type := 0. "ignored for now" 349381 tempGlyphs := Form extent: (maxWidth * 257) @ self height. 349382 xTable := (Array new: 258) atAllPut: 0. 349383 xTable 349384 at: 1 349385 put: 0. 349386 349387 "Read character forms and blt into tempGlyphs" 349388 lastAscii := -1. 349389 1 349390 to: forms size 349391 do: 349392 [ :i | 349393 charForm := forms at: i. 349394 width := charForm width. 349395 ascii := startAscii - 1 + i. 349396 self 349397 displayChar: ascii 349398 form: charForm. 349399 ascii = 256 349400 ifTrue: [ missingForm := charForm deepCopy ] 349401 ifFalse: 349402 [ minAscii := minAscii min: ascii. 349403 maxAscii := maxAscii max: ascii. 349404 lastAscii + 1 349405 to: ascii - 1 349406 do: 349407 [ :as | 349408 xTable 349409 at: as + 2 349410 put: (xTable at: as + 1) ]. 349411 tempGlyphs 349412 copy: ((xTable at: ascii + 1) @ 0 extent: charForm extent) 349413 from: 0 @ 0 349414 in: charForm 349415 rule: Form over. 349416 xTable 349417 at: ascii + 2 349418 put: (xTable at: ascii + 1) + width. 349419 lastAscii := ascii ] ]. 349420 lastAscii + 1 349421 to: maxAscii + 1 349422 do: 349423 [ :as | 349424 xTable 349425 at: as + 2 349426 put: (xTable at: as + 1) ]. 349427 missingForm == nil ifFalse: 349428 [ tempGlyphs 349429 copy: missingForm boundingBox 349430 from: missingForm 349431 to: (xTable at: maxAscii + 2) @ 0 349432 rule: Form over. 349433 xTable 349434 at: maxAscii + 3 349435 put: (xTable at: maxAscii + 2) + missingForm width ]. 349436 glyphs := Form extent: (xTable at: maxAscii + 3) @ self height. 349437 glyphs 349438 copy: glyphs boundingBox 349439 from: 0 @ 0 349440 in: tempGlyphs 349441 rule: Form over. 349442 xTable := xTable 349443 copyFrom: 1 349444 to: maxAscii + 3. 349445 characterToGlyphMap := nil! ! 349446 349447!StrikeFont methodsFor: 'file in/out' stamp: 'lr 7/4/2009 10:42'! 349448displayChar: ascii form: charForm 349449 "Convenience utility used during conversion of BitFont files" 349450 | m bigForm | 349451 Display fillBlack: (0 @ 0 extent: 20 @ 14). 349452 ascii printString displayAt: 0 @ 2. 349453 charForm width > 0 ifTrue: 349454 [ m := 5. 349455 bigForm := charForm 349456 magnify: charForm boundingBox 349457 by: m @ m. 349458 Display 349459 border: ((bigForm boundingBox expandBy: m) translateBy: 50 @ 2) 349460 width: m. 349461 bigForm displayAt: 50 @ 2. 349462 Display fillBlack: (50 @ 2 + ((m * charForm width) @ 0) extent: 1 @ (m * self height)) ]! ! 349463 349464!StrikeFont methodsFor: 'file in/out' stamp: 'lr 7/4/2009 10:42'! 349465newFromStrike: fileName 349466 "Build an instance from the strike font file name. The '.strike' extension 349467 is optional." 349468 | strike startName raster16 | 349469 name := fileName copyUpTo: $.. "assumes extension (if any) is '.strike'" 349470 strike := FileStream readOnlyFileNamed: name , '.strike.'. 349471 strike binary. 349472 349473 "strip off direcory name if any" 349474 startName := name size. 349475 349476 [ startName > 0 and: [ (name at: startName) ~= $> & ((name at: startName) ~= $]) ] ] whileTrue: [ startName := startName - 1 ]. 349477 name := name 349478 copyFrom: startName + 1 349479 to: name size. 349480 type := strike nextWord. "type is ignored now -- simplest 349481 assumed. Kept here to make 349482 writing and consistency more 349483 straightforward." 349484 minAscii := strike nextWord. 349485 maxAscii := strike nextWord. 349486 maxWidth := strike nextWord. 349487 strikeLength := strike nextWord. 349488 ascent := strike nextWord. 349489 descent := strike nextWord. 349490 "xOffset _" 349491 strike nextWord. 349492 raster16 := strike nextWord. 349493 superscript := (ascent - descent) // 3. 349494 subscript := (descent - ascent) // 3. 349495 emphasis := 0. 349496 glyphs := Form 349497 extent: (raster16 * 16) @ self height 349498 offset: 0 @ 0. 349499 glyphs bits fromByteStream: strike. 349500 xTable := (Array new: maxAscii + 3) atAllPut: 0. 349501 (minAscii + 1 to: maxAscii + 3) do: 349502 [ :index | 349503 xTable 349504 at: index 349505 put: strike nextWord ]. 349506 349507 "Set up space character" 349508 ((xTable at: Space asciiValue + 2) = 0 or: [ (xTable at: Space asciiValue + 2) = (xTable at: Space asciiValue + 1) ]) ifTrue: 349509 [ Space asciiValue + 2 349510 to: xTable size 349511 do: 349512 [ :index | 349513 xTable 349514 at: index 349515 put: (xTable at: index) + DefaultSpace ] ]. 349516 strike close. 349517 characterToGlyphMap := nil! ! 349518 349519!StrikeFont methodsFor: 'file in/out' stamp: 'lr 7/4/2009 10:42'! 349520objectForDataStream: refStrm 349521 "I am about to be written on an object file. Write a reference to a known Font in the other system instead. " 349522 "A path to me" 349523 | dp | 349524 (TextConstants 349525 at: #forceFontWriting 349526 ifAbsent: [ false ]) ifTrue: [ ^ self ]. 349527 "special case for saving the default fonts on the disk. See collectionFromFileNamed:" 349528 dp := DiskProxy 349529 global: #StrikeFont 349530 selector: #familyName:size:emphasized: 349531 args: (Array 349532 with: self familyName 349533 with: self height 349534 with: self emphasis). 349535 refStrm 349536 replace: self 349537 with: dp. 349538 ^ dp! ! 349539 349540!StrikeFont methodsFor: 'file in/out' stamp: 'sma 6/1/2000 09:32'! 349541printOn: aStream 349542 super printOn: aStream. 349543 aStream 349544 nextPut: $(; 349545 nextPutAll: self name; 349546 space; 349547 print: self height; 349548 nextPut: $)! ! 349549 349550!StrikeFont methodsFor: 'file in/out' stamp: 'damiencassou 5/30/2008 14:51'! 349551readBDFFromFile: fileName name: aString 349552 "This builds a StrikeFont instance by reading the X11 Binary 349553 Distribution Format font source file. See the BDFFontReader class 349554 comment." 349555 "StrikeFont new readBDFFromFile: 'helvR12' name: 'Helvetica12'." 349556 | fontReader stream | 349557 fontReader := BDFFontReader openFileNamed: fileName. 349558 stream := fontReader read readStream. 349559 xTable := stream next. 349560 glyphs := stream next. 349561 minAscii := stream next. 349562 maxAscii := stream next. 349563 maxWidth := stream next. 349564 ascent := stream next. 349565 descent := stream next. 349566 pointSize := stream next. 349567 name := aString. 349568 " xTable size <= 256 ifTrue: [self setStopConditions]." 349569 type := 0. "no one see this" 349570 superscript := (ascent - descent) // 3. 349571 subscript := (descent - ascent) // 3. 349572 emphasis := 0. 349573 self reset! ! 349574 349575!StrikeFont methodsFor: 'file in/out' stamp: 'lr 7/4/2009 10:42'! 349576readBFHeaderFrom: f 349577 name := self 349578 restOfLine: 'Font name = ' 349579 from: f. 349580 ascent := (self 349581 restOfLine: 'Ascent = ' 349582 from: f) asNumber. 349583 descent := (self 349584 restOfLine: 'Descent = ' 349585 from: f) asNumber. 349586 maxWidth := (self 349587 restOfLine: 'Maximum width = ' 349588 from: f) asNumber. 349589 pointSize := (self 349590 restOfLine: 'Font size = ' 349591 from: f) asNumber. 349592 name := (name copyWithout: Character space) , (pointSize < 10 349593 ifTrue: [ '0' , pointSize printString ] 349594 ifFalse: [ pointSize printString ]). 349595 minAscii := 258. 349596 maxAscii := 0. 349597 superscript := (ascent - descent) // 3. 349598 subscript := (descent - ascent) // 3. 349599 emphasis := 0. 349600 type := 0 "ignored for now"! ! 349601 349602!StrikeFont methodsFor: 'file in/out' stamp: 'damiencassou 5/30/2008 14:51'! 349603readEFontBDFForJapaneseFromFile: fileName name: aString overrideWith: otherFileName 349604 | fontReader stream | 349605 fontReader := EFontBDFFontReaderForRanges readOnlyFileNamed: fileName. 349606 stream := (fontReader 349607 readRanges: fontReader rangesForJapanese 349608 overrideWith: otherFileName 349609 otherRanges: { (Array with: 8481 with: 12320) } 349610 additionalOverrideRange: fontReader additionalRangesForJapanese) readStream. 349611 xTable := stream next. 349612 glyphs := stream next. 349613 minAscii := stream next. 349614 maxAscii := stream next. 349615 maxWidth := stream next. 349616 ascent := stream next. 349617 descent := stream next. 349618 pointSize := stream next. 349619 name := aString. 349620 type := 0. "no one see this" 349621 superscript := (ascent - descent) // 3. 349622 subscript := (descent - ascent) // 3. 349623 emphasis := 0. 349624 self reset! ! 349625 349626!StrikeFont methodsFor: 'file in/out' stamp: 'damiencassou 5/30/2008 14:51'! 349627readEFontBDFForKoreanFromFile: fileName name: aString overrideWith: otherFileName 349628 | fontReader stream | 349629 fontReader := EFontBDFFontReaderForRanges readOnlyFileNamed: fileName. 349630 stream := (fontReader 349631 readRanges: fontReader rangesForKorean 349632 overrideWith: otherFileName 349633 otherRanges: { (Array with: 8481 with: 12320) } 349634 additionalOverrideRange: fontReader additionalRangesForKorean) readStream. 349635 xTable := stream next. 349636 glyphs := stream next. 349637 minAscii := stream next. 349638 maxAscii := stream next. 349639 maxWidth := stream next. 349640 ascent := stream next. 349641 descent := stream next. 349642 pointSize := stream next. 349643 name := aString. 349644 type := 0. "no one see this" 349645 superscript := (ascent - descent) // 3. 349646 subscript := (descent - ascent) // 3. 349647 emphasis := 0. 349648 self reset! ! 349649 349650!StrikeFont methodsFor: 'file in/out' stamp: 'damiencassou 5/30/2008 14:51'! 349651readEFontBDFFromFile: fileName name: aString rangeFrom: startRange to: endRange 349652 | fontReader stream | 349653 fontReader := EFontBDFFontReader readOnlyFileNamed: fileName. 349654 stream := (fontReader 349655 readFrom: startRange 349656 to: endRange) readStream. 349657 xTable := stream next. 349658 glyphs := stream next. 349659 minAscii := stream next. 349660 maxAscii := stream next. 349661 maxWidth := stream next. 349662 ascent := stream next. 349663 descent := stream next. 349664 pointSize := stream next. 349665 name := aString. 349666 type := 0. "no one see this" 349667 superscript := (ascent - descent) // 3. 349668 subscript := (descent - ascent) // 3. 349669 emphasis := 0. 349670 self reset! ! 349671 349672!StrikeFont methodsFor: 'file in/out' stamp: 'damiencassou 5/30/2008 14:51'! 349673readEFontBDFFromFile: fileName name: aString ranges: ranges 349674 | fontReader stream | 349675 fontReader := EFontBDFFontReaderForRanges readOnlyFileNamed: fileName. 349676 stream := (fontReader readRanges: ranges) readStream. 349677 xTable := stream next. 349678 glyphs := stream next. 349679 minAscii := stream next. 349680 maxAscii := stream next. 349681 maxWidth := stream next. 349682 ascent := stream next. 349683 descent := stream next. 349684 pointSize := stream next. 349685 name := aString. 349686 type := 0. "no one see this" 349687 superscript := (ascent - descent) // 3. 349688 subscript := (descent - ascent) // 3. 349689 emphasis := 0. 349690 self reset! ! 349691 349692!StrikeFont methodsFor: 'file in/out' stamp: 'lr 7/4/2009 10:42'! 349693readF12FromStream: aStream 349694 | box blt | 349695 minAscii := 0. 349696 maxAscii := 94 * 94. 349697 ascent := 12. 349698 descent := 0. 349699 pointSize := 12. 349700 superscript := 0. 349701 subscript := 0. 349702 emphasis := 0. 349703 maxWidth := 12. 349704 box := Form extent: 12 @ 12. 349705 glyphs := Form extent: (94 * 94 * 12) @ 12. 349706 blt := BitBlt toForm: glyphs. 349707 xTable := XTableForFixedFont new. 349708 xTable maxAscii: maxAscii + 3. 349709 xTable width: 12. 349710 1 349711 to: 256 349712 do: 349713 [ :index | 349714 1 349715 to: 12 349716 do: [ :i | aStream next ] ]. 349717 (minAscii + 1 to: 94 * 94) do: 349718 [ :index | 349719 self 349720 readCharacter: box bits 349721 from: aStream. 349722 blt 349723 copy: ((12 * (index - 1)) @ 0 extent: 12 @ 12) 349724 from: 0 @ 0 349725 in: box ]! ! 349726 349727!StrikeFont methodsFor: 'file in/out' stamp: 'lr 7/4/2009 10:42'! 349728readFromBitFont: fileName 349729 "This builds a StrikeFont instance by reading the data file format 349730 produced by BitFont, a widely available font conversion utility 349731 written by Peter DiCamillo at Brown University" 349732 "StrikeFont new readFromBitFont: 'Palatino10.BF' " 349733 | f lastAscii charLine width ascii charForm line missingForm tempGlyphs iRect p rectLine left tokens right | 349734 f := FileStream readOnlyFileNamed: fileName. 349735 self readBFHeaderFrom: f. 349736 349737 "NOTE: if font has been scaled (and in any case), 349738 the REAL bitmap dimensions come after the header." 349739 self 349740 restOfLine: 'Extent information for entire font' 349741 from: f. 349742 "Parse the following line (including mispelling!!)" 349743 "Image rectange: left = -2, right = 8, bottom = -2, top = 7" 349744 tokens := (f upTo: Character cr) findTokens: ' '. 349745 iRect := Rectangle 349746 left: (tokens at: 5) asNumber 349747 right: (tokens at: 8) asNumber 349748 top: (tokens at: 14) asNumber 349749 bottom: (tokens at: 11) asNumber. 349750 ascent := iRect top. 349751 descent := iRect bottom negated. 349752 tempGlyphs := Form extent: (maxWidth * 257) @ self height. 349753 xTable := (Array new: 258) atAllPut: 0. 349754 xTable 349755 at: 1 349756 put: 0. 349757 349758 "Read character forms and blt into tempGlyphs" 349759 lastAscii := -1. 349760 349761 [ charLine := self 349762 restOfLine: 'Character: ' 349763 from: f. 349764 charLine == nil ifFalse: 349765 [ p := f position. 349766 rectLine := f upTo: Character cr. 349767 (rectLine beginsWith: 'Image rectange: left = ') 349768 ifTrue: 349769 [ tokens := rectLine findTokens: ' '. 349770 left := (tokens at: 5) asNumber. 349771 right := (tokens at: 8) asNumber ] 349772 ifFalse: 349773 [ left := right := 0. 349774 f position: p ]. 349775 width := (self 349776 restOfLine: 'Width (final pen position) = ' 349777 from: f) asNumber - left max: right - left + 1. 349778 (charLine beginsWith: 'Missing character') ifTrue: [ ascii := 256 ]. 349779 ('x''*' match: charLine) ifTrue: 349780 [ ascii := Number 349781 readFrom: (charLine 349782 copyFrom: 3 349783 to: 4) asUppercase 349784 base: 16 ]. 349785 charForm := Form extent: width @ self height. 349786 ('*[all blank]' match: charLine) ifFalse: 349787 [ self 349788 restOfLine: ' +' 349789 from: f. 349790 1 349791 to: self height 349792 do: 349793 [ :y | 349794 line := f upTo: Character cr. 349795 4 349796 to: (width + 3 min: line size + iRect left - left) 349797 do: 349798 [ :x | 349799 (line at: x - iRect left + left) = $* ifTrue: 349800 [ charForm 349801 pixelValueAt: (x - 4) @ (y - 1) 349802 put: 1 ] ] ] ] ]. 349803 charLine == nil ] whileFalse: 349804 [ self 349805 displayChar: ascii 349806 form: charForm. 349807 ascii = 256 349808 ifTrue: [ missingForm := charForm deepCopy ] 349809 ifFalse: 349810 [ minAscii := minAscii min: ascii. 349811 maxAscii := maxAscii max: ascii. 349812 lastAscii + 1 349813 to: ascii - 1 349814 do: 349815 [ :a | 349816 xTable 349817 at: a + 2 349818 put: (xTable at: a + 1) ]. 349819 tempGlyphs 349820 copy: ((xTable at: ascii + 1) @ 0 extent: charForm extent) 349821 from: 0 @ 0 349822 in: charForm 349823 rule: Form over. 349824 xTable 349825 at: ascii + 2 349826 put: (xTable at: ascii + 1) + width. 349827 lastAscii := ascii ] ]. 349828 f close. 349829 lastAscii + 1 349830 to: maxAscii + 1 349831 do: 349832 [ :a | 349833 xTable 349834 at: a + 2 349835 put: (xTable at: a + 1) ]. 349836 missingForm == nil ifFalse: 349837 [ tempGlyphs 349838 copy: missingForm boundingBox 349839 from: missingForm 349840 to: (xTable at: maxAscii + 2) @ 0 349841 rule: Form over. 349842 xTable 349843 at: maxAscii + 3 349844 put: (xTable at: maxAscii + 2) + missingForm width ]. 349845 glyphs := Form extent: (xTable at: maxAscii + 3) @ self height. 349846 glyphs 349847 copy: glyphs boundingBox 349848 from: 0 @ 0 349849 in: tempGlyphs 349850 rule: Form over. 349851 xTable := xTable 349852 copyFrom: 1 349853 to: maxAscii + 3. 349854 characterToGlyphMap := nil! ! 349855 349856!StrikeFont methodsFor: 'file in/out' stamp: 'lr 7/4/2009 10:42'! 349857readFromStrike2Stream: file 349858 "Build an instance from the supplied binary stream on data in strike2 format" 349859 type := file nextInt32. 349860 type = 2 ifFalse: 349861 [ file close. 349862 self error: 'not strike2 format' ]. 349863 minAscii := file nextInt32. 349864 maxAscii := file nextInt32. 349865 maxWidth := file nextInt32. 349866 ascent := file nextInt32. 349867 descent := file nextInt32. 349868 pointSize := file nextInt32. 349869 superscript := (ascent - descent) // 3. 349870 subscript := (descent - ascent) // 3. 349871 emphasis := file nextInt32. 349872 xTable := (Array new: maxAscii + 3) atAllPut: 0. 349873 (minAscii + 1 to: maxAscii + 3) do: 349874 [ :index | 349875 xTable 349876 at: index 349877 put: file nextInt32 ]. 349878 glyphs := Form new readFrom: file. 349879 349880 "Set up space character" 349881 ((xTable at: Space asciiValue + 2) = 0 or: [ (xTable at: Space asciiValue + 2) = (xTable at: Space asciiValue + 1) ]) ifTrue: 349882 [ Space asciiValue + 2 349883 to: xTable size 349884 do: 349885 [ :index | 349886 xTable 349887 at: index 349888 put: (xTable at: index) + DefaultSpace ] ]. 349889 characterToGlyphMap := nil! ! 349890 349891!StrikeFont methodsFor: 'file in/out' stamp: 'lr 7/4/2009 10:42'! 349892readFromStrike2: fileName 349893 "StrikeFont new readFromStrike2: 'Palatino14.sf2'" 349894 "Build an instance from the strike font stored in strike2 format. 349895 fileName is of the form: <family name><pointSize>.sf2" 349896 | file | 349897 ('*.sf2' match: fileName) ifFalse: [ self halt "likely incompatible" ]. 349898 name := fileName copyUpTo: $.. "Drop filename extension" 349899 file := FileStream readOnlyFileNamed: fileName. 349900 file binary. 349901 [ self readFromStrike2Stream: file ] ensure: [ file close ]! ! 349902 349903!StrikeFont methodsFor: 'file in/out' stamp: 'lr 7/4/2009 10:42'! 349904restOfLine: leadString from: file 349905 "Utility method to assist reading of BitFont data files" 349906 | line | 349907 349908 [ line := file upTo: Character cr. 349909 line size < leadString size or: [ leadString ~= (line 349910 copyFrom: 1 349911 to: leadString size) ] ] whileTrue: [ file atEnd ifTrue: [ ^ nil ] ]. 349912 ^ line 349913 copyFrom: leadString size + 1 349914 to: line size! ! 349915 349916!StrikeFont methodsFor: 'file in/out' stamp: 'lr 7/4/2009 10:42'! 349917writeAsStrike2named: fileName 349918 "Write me onto a file in strike2 format. 349919 fileName should be of the form: <family name><pointSize>.sf2" 349920 | file | 349921 file := FileStream fileNamed: fileName. 349922 self writeAsStrike2On: file. 349923 file close! ! 349924 349925!StrikeFont methodsFor: 'file in/out' stamp: 'lr 7/4/2009 10:42'! 349926writeAsStrike2On: file 349927 "Write me onto a file in strike2 format. 349928 fileName should be of the form: <family name><pointSize>.sf2" 349929 file binary. 349930 file nextInt32Put: 2. 349931 file nextInt32Put: minAscii. 349932 file nextInt32Put: maxAscii. 349933 file nextInt32Put: maxWidth. 349934 file nextInt32Put: ascent. 349935 file nextInt32Put: descent. 349936 file nextInt32Put: pointSize. 349937 superscript := (ascent - descent) // 3. 349938 subscript := (descent - ascent) // 3. 349939 file nextInt32Put: emphasis. 349940 (minAscii + 1 to: maxAscii + 3) do: [ :index | file nextInt32Put: (xTable at: index) ]. 349941 glyphs writeOn: file. 349942 file close! ! 349943 349944 349945!StrikeFont methodsFor: 'mac reader'! 349946aComment 349947 "To read Mac font resources. 3499481) Use ResEdit in the Fonts folder in the System Folder. Open the file of the Font you want. (A screen font, not a TrueType outline font). 3499492) Open the FOND resource and scroll down to the list of sizes and resource numbers. Note the resource number of the size you want. 3499503) Open the NFNT resource. Click on the number you have noted. 3499514) Choose 'Open Using Hex Editor' from the resource editor. 3499525) Copy all of the hex numbers and paste into a text editor. Save the file into the Smalltalk folder under the name 'FontName 12 hex' (or other size). 3499536) Enter the fileName below and execute: 349954 349955TextStyle default fontAt: 8 put: (StrikeFont new readMacFontHex: 'fileName'). 349956 349957Select text and type Command-7 to change it to your new font. 349958 349959(There is some problem in the ParagraphEditor with the large size of Cairo 18. Its line heights are not the right.) 349960 "! ! 349961 349962!StrikeFont methodsFor: 'mac reader' stamp: 'lr 7/4/2009 10:42'! 349963fixKerning: extraWidth 349964 "Insert one pixel (extraWidth) between each character. And add the bits for the space character" 349965 "Create a space character Form. Estimate width by ascent / 2 - 1" 349966 | characterForm char leftX | 349967 characterForm := Form extent: (ascent // 2 - 1) @ self height. 349968 self 349969 characterFormAt: $ 349970 put: characterForm. 349971 349972 "Put one pixel of space after every character. Mac fonts have no space in the bitmap." 349973 extraWidth <= 0 ifTrue: [ ^ self ]. 349974 minAscii 349975 to: maxAscii 349976 do: 349977 [ :ascii | 349978 char := Character value: ascii. 349979 leftX := xTable at: ascii + 1. 349980 characterForm := Form extent: ((self widthOf: char) + extraWidth) @ self height. 349981 characterForm 349982 copy: (characterForm boundingBox extendBy: (0 - extraWidth) @ 0) 349983 from: leftX @ 0 349984 in: glyphs 349985 rule: Form over. 349986 self 349987 characterFormAt: char 349988 put: characterForm ]! ! 349989 349990!StrikeFont methodsFor: 'mac reader' stamp: 'lr 7/4/2009 10:42'! 349991readMacFontHex: fileName 349992 "Read the hex version of a Mac FONT type resource. See the method aComment for how to prepare the input file. 4/26/96 tk" 349993 | file hh fRectWidth | 349994 name := fileName. "Palatino 12" 349995 file := FileStream readOnlyFileNamed: fileName , ' hex'. 349996 349997 "See Inside Macintosh page IV-42 for this record" 349998 "FontType _ " 349999 Number 350000 readFrom: (file next: 4) 350001 base: 16. 350002 emphasis := 0. 350003 minAscii := Number 350004 readFrom: (file next: 4) 350005 base: 16. 350006 maxAscii := Number 350007 readFrom: (file next: 4) 350008 base: 16. 350009 maxWidth := Number 350010 readFrom: (file next: 4) 350011 base: 16. 350012 "kernMax _ " 350013 Number 350014 readFrom: (file next: 4) 350015 base: 16. 350016 "NDescent _ " 350017 Number 350018 readFrom: (file next: 4) 350019 base: 16. 350020 fRectWidth := Number 350021 readFrom: (file next: 4) 350022 base: 16. 350023 hh := Number 350024 readFrom: (file next: 4) 350025 base: 16. 350026 "OWTLoc _ " 350027 Number 350028 readFrom: (file next: 4) 350029 base: 16. 350030 ascent := Number 350031 readFrom: (file next: 4) 350032 base: 16. 350033 descent := Number 350034 readFrom: (file next: 4) 350035 base: 16. 350036 "leading _ " 350037 Number 350038 readFrom: (file next: 4) 350039 base: 16. 350040 xOffset := 0. 350041 raster := Number 350042 readFrom: (file next: 4) 350043 base: 16. 350044 strikeLength := raster * 16. 350045 superscript := (ascent - descent) // 3. 350046 subscript := (descent - ascent) // 3. 350047 self 350048 strikeFromHex: file 350049 width: raster 350050 height: hh. 350051 self xTableFromHex: file. 350052 file close. 350053 350054 "Insert one pixel between each character. And add space character." 350055 self fixKerning: fRectWidth - maxWidth. 350056 350057 "Recompute character to glyph mapping" 350058 characterToGlyphMap := nil! ! 350059 350060!StrikeFont methodsFor: 'mac reader' stamp: 'lr 7/4/2009 10:42'! 350061strikeFromHex: file width: w height: h 350062 "read in just the raw strike bits from a hex file. No spaces or returns. W is in words (2 bytes), h in pixels." 350063 | newForm theBits offsetX offsetY str num cnt | 350064 offsetX := 0. 350065 offsetY := 0. 350066 offsetX > 32767 ifTrue: [ offsetX := offsetX - 65536 ]. "stored two's-complement" 350067 offsetY > 32767 ifTrue: [ offsetY := offsetY - 65536 ]. "stored two's-complement" 350068 newForm := Form 350069 extent: strikeLength @ h 350070 offset: offsetX @ offsetY. 350071 theBits := newForm bits. 350072 cnt := 0. "raster may be 16 bits, but theBits width is 32" 350073 1 350074 to: theBits size 350075 do: 350076 [ :i | 350077 (cnt := cnt + 32) > strikeLength 350078 ifTrue: 350079 [ cnt := 0. 350080 num := Number 350081 readFrom: (str := file next: 4) 350082 base: 16 ] 350083 ifFalse: 350084 [ cnt = strikeLength ifTrue: [ cnt := 0 ]. 350085 num := Number 350086 readFrom: (str := file next: 8) 350087 base: 16 ]. 350088 theBits 350089 at: i 350090 put: num ]. 350091 glyphs := newForm! ! 350092 350093!StrikeFont methodsFor: 'mac reader' stamp: 'lr 7/4/2009 10:42'! 350094xTableFromHex: file 350095 | strike num str wid | 350096 strike := file. 350097 xTable := (Array new: maxAscii + 3) atAllPut: 0. 350098 (minAscii + 1 to: maxAscii + 3) do: 350099 [ :index | 350100 num := Number 350101 readFrom: (str := strike next: 4) 350102 base: 16. 350103 xTable 350104 at: index 350105 put: num ]. 350106 1 350107 to: xTable size - 1 350108 do: 350109 [ :ind | 350110 wid := (xTable at: ind + 1) - (xTable at: ind). 350111 wid < 0 | (wid > 40) ifTrue: 350112 [ file close. 350113 self error: 'illegal character width' ] ]! ! 350114 350115 350116!StrikeFont methodsFor: 'make arrows' stamp: 'lr 7/4/2009 10:42'! 350117makeAssignArrow 350118 "Replace the underline character with an arrow for this font" 350119 | arrowForm arrowCanvas arrowY arrowLeft arrowRight arrowHeadLength | 350120 arrowForm := (self characterFormAt: $_) copy. 350121 arrowCanvas := arrowForm getCanvas. 350122 arrowCanvas fillColor: Color white. 350123 arrowY := arrowForm height // 2. 350124 arrowLeft := 0. 350125 arrowRight := arrowForm width - 2. 350126 arrowHeadLength := (arrowRight - arrowLeft) * 2 // 5. 350127 "Draw the lines" 350128 arrowCanvas 350129 line: arrowLeft @ arrowY 350130 to: arrowRight @ arrowY 350131 color: Color black. 350132 arrowCanvas 350133 line: arrowLeft @ arrowY 350134 to: (arrowLeft + arrowHeadLength) @ (arrowY - arrowHeadLength) 350135 color: Color black. 350136 arrowCanvas 350137 line: arrowLeft @ arrowY 350138 to: (arrowLeft + arrowHeadLength) @ (arrowY + arrowHeadLength) 350139 color: Color black. 350140 350141 "Replace the glyph" 350142 self 350143 characterFormAt: $_ 350144 put: arrowForm! ! 350145 350146!StrikeFont methodsFor: 'make arrows' stamp: 'lr 7/4/2009 10:42'! 350147makeReturnArrow 350148 "Replace the caret character with an arrow" 350149 | arrowForm arrowCanvas arrowHeadLength arrowX arrowTop arrowBottom | 350150 arrowForm := (self characterFormAt: $^) copy. 350151 arrowCanvas := arrowForm getCanvas. 350152 arrowCanvas fillColor: Color white. 350153 arrowHeadLength := (arrowForm width - 2) // 2. 350154 arrowX := arrowHeadLength max: arrowForm width // 2. 350155 arrowTop := arrowForm height // 4. 350156 arrowBottom := arrowTop + (arrowForm width * 4 // 5). 350157 arrowBottom := (arrowBottom min: arrowForm height) max: arrowForm height * 2 // 3. 350158 350159 "Draw the lines" 350160 arrowCanvas 350161 line: arrowX @ arrowTop 350162 to: arrowX @ arrowBottom 350163 color: Color black. 350164 arrowCanvas 350165 line: arrowX @ arrowTop 350166 to: (arrowX - arrowHeadLength) @ (arrowTop + arrowHeadLength) 350167 color: Color black. 350168 arrowCanvas 350169 line: arrowX @ arrowTop 350170 to: (arrowX + arrowHeadLength) @ (arrowTop + arrowHeadLength) 350171 color: Color black. 350172 350173 "Replace the glyph" 350174 self 350175 characterFormAt: $^ 350176 put: arrowForm! ! 350177 350178 350179!StrikeFont methodsFor: 'multibyte character methods' stamp: 'lr 7/4/2009 10:42'! 350180fixAscent: a andDescent: d head: h 350181 "(a + d) = (ascent + descent) ifTrue: [" 350182 | bb newGlyphs | 350183 ascent := a. 350184 descent := d. 350185 newGlyphs := Form extent: glyphs width @ (h + glyphs height). 350186 bb := BitBlt toForm: newGlyphs. 350187 bb 350188 copy: (0 @ h extent: glyphs extent) 350189 from: 0 @ 0 350190 in: glyphs 350191 fillColor: nil 350192 rule: Form over. 350193 glyphs := newGlyphs 350194 "]."! ! 350195 350196!StrikeFont methodsFor: 'multibyte character methods' stamp: 'lr 7/4/2009 10:42'! 350197fixForISO8859From: aStrikeFont 350198 | fixer m mappingTable | 350199 fixer := StrikeFontFixer newOn: aStrikeFont. 350200 self reset. 350201 xTable := aStrikeFont xTable copy. 350202 glyphs := Form extent: aStrikeFont glyphs extent. 350203 maxAscii := 255. 350204 minAscii := 0. 350205 mappingTable := fixer mappingTable. 350206 "stopConditions _ nil." 350207 0 350208 to: 255 350209 do: 350210 [ :i | 350211 (m := mappingTable at: i + 1) ~= nil 350212 ifTrue: 350213 [ self 350214 characterFormAt: (Character value: i) 350215 put: (aStrikeFont characterFormAt: (Character value: m)) ] 350216 ifFalse: 350217 [ self 350218 characterFormAt: (Character value: i) 350219 put: (aStrikeFont characterFormAt: Character space) ] ]. 350220 ^ self! ! 350221 350222!StrikeFont methodsFor: 'multibyte character methods' stamp: 'lr 7/4/2009 10:42'! 350223fixXTable 350224 | newXTable val | 350225 xTable size >= 258 ifTrue: [ ^ self ]. 350226 newXTable := Array new: 258. 350227 1 350228 to: xTable size 350229 do: 350230 [ :i | 350231 newXTable 350232 at: i 350233 put: (xTable at: i) ]. 350234 val := xTable at: xTable size. 350235 xTable size + 1 350236 to: 258 350237 do: 350238 [ :i | 350239 newXTable 350240 at: i 350241 put: val ]. 350242 minAscii := 0. 350243 maxAscii := 255. 350244 xTable := newXTable! ! 350245 350246!StrikeFont methodsFor: 'multibyte character methods' stamp: 'lr 7/4/2009 10:42'! 350247hasGlyphOf: aCharacter 350248 | code | 350249 code := aCharacter charCode. 350250 (code 350251 between: self minAscii 350252 and: self maxAscii) not ifTrue: [ ^ false ]. 350253 (xTable at: code + 1) < 0 ifTrue: [ ^ false ]. 350254 ^ true! ! 350255 350256!StrikeFont methodsFor: 'multibyte character methods' stamp: 'lr 7/4/2009 10:42'! 350257readCharacter: aBits from: aStream 350258 | pos | 350259 pos := 0. 350260 12 timesRepeat: 350261 [ 1 350262 to: 2 350263 do: 350264 [ :w | 350265 aBits 350266 byteAt: pos + w 350267 put: aStream next ]. 350268 pos := pos + 4 ]! ! 350269 350270!StrikeFont methodsFor: 'multibyte character methods' stamp: 'lr 7/4/2009 10:42'! 350271setupDefaultFallbackFont 350272 | fonts f | 350273 fonts := TextStyle default fontArray. 350274 f := fonts first. 350275 1 350276 to: fonts size 350277 do: [ :i | self height > (fonts at: i) height ifTrue: [ f := fonts at: i ] ]. 350278 self fallbackFont: f. 350279 self reset! ! 350280 350281 350282!StrikeFont methodsFor: 'testing' stamp: 'lr 7/4/2009 10:42'! 350283checkCharacter: character 350284 "Answer a Character that is within the ascii range of the receiver--either 350285 character or the last character in the receiver." 350286 | ascii | 350287 ascii := character asciiValue. 350288 (ascii < minAscii or: [ ascii > maxAscii ]) 350289 ifTrue: [ ^ maxAscii asCharacter ] 350290 ifFalse: [ ^ character ]! ! 350291 350292 350293!StrikeFont methodsFor: 'private' stamp: 'yo 3/11/2005 07:38'! 350294createCharacterToGlyphMap 350295 "Private. Create the character to glyph mapping for a font that didn't have any before. This is basically equivalent to what the former setStopCondition did, only based on indexes." 350296 350297 maxAscii < 256 ifTrue: [^ (1 to: 256) collect: [:i | i - 1]]. 350298 ^ nil. 350299! ! 350300 350301!StrikeFont methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 350302leftAndRighOrNilFor: char 350303 | code leftX | 350304 code := char charCode. 350305 (code 350306 between: self minAscii 350307 and: self maxAscii) not ifTrue: [ code := $? charCode ]. 350308 leftX := xTable at: code + 1. 350309 leftX < 0 ifTrue: 350310 [ code := $? charCode. 350311 leftX := xTable at: code + 1 ]. 350312 ^ Array 350313 with: leftX 350314 with: (xTable at: code + 2)! ! 350315 350316"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 350317 350318StrikeFont class 350319 instanceVariableNames: ''! 350320 350321!StrikeFont class methodsFor: 'accessing' stamp: 'nk 9/1/2004 11:00'! 350322actualFamilyNames 350323 "Answer a sorted list of actual family names, without the Default aliases" 350324 350325 ^(self familyNames copyWithoutAll: TextStyle defaultFamilyNames) asOrderedCollection! ! 350326 350327!StrikeFont class methodsFor: 'accessing' stamp: 'ar 2/3/2002 23:04'! 350328familyName: aName pointSize: aSize 350329 "Answer a font (or the default font if the name is unknown) in the specified size." 350330 350331 ^ ((TextStyle named: aName asSymbol) ifNil: [TextStyle default]) fontOfPointSize: aSize! ! 350332 350333!StrikeFont class methodsFor: 'accessing' stamp: 'ar 11/25/2004 15:19'! 350334familyName: aName size: aSize 350335 "Answer a font (or the default font if the name is unknown) in the specified size." 350336 | style | 350337 style := TextStyle named: aName asSymbol. 350338 style ifNil: [^(FontSubstitutionDuringLoading forFamilyName: aName pixelSize: aSize) 350339 signal: 'missing font' ]. 350340 ^style fontOfSize: aSize! ! 350341 350342!StrikeFont class methodsFor: 'accessing' stamp: 'sma 12/30/1999 13:48'! 350343familyNames 350344 ^ (TextConstants select: [:each | each isKindOf: TextStyle]) keys asSortedCollection! ! 350345 350346!StrikeFont class methodsFor: 'accessing' stamp: 'tak 11/11/2004 21:14'! 350347setupDefaultFallbackFont 350348" 350349 StrikeFont setupDefaultFallbackFont 350350" 350351 350352 (#(#Accuat #Accujen #Accula #Accumon #Accusf #Accushi #Accuve #Atlanta) collect: [:e | TextStyle named: e]) do: [:style | 350353 style fontArray do: [:e | 350354 e reset. 350355 e setupDefaultFallbackFont. 350356 ]. 350357 ]. 350358 TTCFont allSubInstances 350359 do: [:font | font reset. 350360 font setupDefaultFallbackFont] 350361 350362! ! 350363 350364 350365!StrikeFont class methodsFor: 'character shapes' stamp: 'jmv 3/27/2009 09:28'! 350366makeControlCharsVisible 350367 " 350368 Make normally not visible characters, visible 350369 StrikeFont makeControlCharsVisible 350370 " 350371 self allInstances do: [ :font | font makeControlCharsVisible ]! ! 350372 350373!StrikeFont class methodsFor: 'character shapes' stamp: 'jmv 3/26/2009 14:51'! 350374makeLfInvisible 350375 " 350376 Make line feed characters invisible 350377 StrikeFont makeLfInvisible 350378 " 350379 self allInstances do: [ :font | font makeLfInvisible ]! ! 350380 350381!StrikeFont class methodsFor: 'character shapes' stamp: 'jmv 3/26/2009 14:51'! 350382makeLfVisible 350383 " 350384 Make line feed characters visible 350385 StrikeFont makeLfVisible 350386 " 350387 self allInstances do: [ :font | font makeLfVisible ]! ! 350388 350389!StrikeFont class methodsFor: 'character shapes' stamp: 'jmv 3/26/2009 14:53'! 350390makeTabInvisible 350391 " 350392 Make tab characters invisible 350393 StrikeFont makeTabInvisible 350394 " 350395 self allInstances do: [ :font | font makeTabInvisible ]! ! 350396 350397!StrikeFont class methodsFor: 'character shapes' stamp: 'jmv 3/26/2009 14:53'! 350398makeTabVisible 350399 " 350400 Make tab characters visible 350401 StrikeFont makeTabVisible 350402 " 350403 self allInstances do: [ :font | font makeTabVisible ]! ! 350404 350405!StrikeFont class methodsFor: 'character shapes' stamp: 'jmv 8/6/2009 14:24'! 350406useUnderscoreIfOver1bpp 350407 "Sets underscore and caret glyphs for chars 95 and 94. 350408 Only for enhanced StrikeFonts, i.e. those with glyphs of more than 1bpp. 350409 ASCII standard glyphs" 350410 " 350411 StrikeFont useUnderscoreIfOver1bpp 350412 " 350413 self allInstances do: [ :font | font useUnderscoreIfOver1bpp ]! ! 350414 350415 350416!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:15'! 350417dejaVuSansBold12Data 350418 "Created using: 350419 Clipboard default clipboardText: 350420 ((FileStream oldFileNamed: 'AAFonts/DejaVu Sans Bold 12.txt') contentsOfEntireFile substrings 350421 collect: [ :each | each asNumber]) asString 350422 " 350423 ^#(12 15 4 0 6 11 17 29 39 55 69 72 78 84 92 103 107 113 117 123 135 147 159 171 183 195 207 219 231 243 248 253 265 276 287 295 311 324 335 347 360 370 380 393 405 410 417 429 439 454 467 481 492 506 518 529 541 553 566 584 596 609 620 627 633 640 648 660 664 675 686 696 707 718 726 737 748 753 760 771 776 793 804 816 827 838 846 856 864 875 886 901 911 922 932 941 945 953 964 974 985 994 1002 1014 1024 1034 1044 1054 1064 1074 1084 1094 1104 1114 1124 1134 1144 1154 1164 1174 1184 1194 1204 1214 1224 1234 1244 1254 1264 1274 1284 1294 1300 1305 1314 1325 1337 1349 1360 1369 1378 1391 1399 1409 1421 1427 1440 1446 1452 1463 1470 1476 1488 1499 1508 1512 1522 1528 1537 1546 1564 1582 1595 1604 1617 1630 1643 1656 1669 1681 1698 1710 1720 1730 1740 1750 1755 1760 1767 1773 1787 1800 1814 1828 1842 1856 1870 1880 1894 1906 1918 1930 1942 1955 1966 1977 1988 1999 2010 2021 2032 2043 2060 2070 2081 2092 2103 2114 2120 2126 2133 2139 2151 2162 2174 2186 2198 2210 2222 2233 2245 2256 2267 2278 2289 2300 2311 2322)! ! 350424 350425!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:16'! 350426dejaVuSansBold12Form 350427 "Created using: 350428 Clipboard default clipboardText: 350429 ((ByteArray streamContents:[:s| 350430 PNGReadWriter 350431 putForm: (Form fromFileNamed: 'AAFonts/DejaVu Sans Bold 12.bmp') 350432 onStream: s]) asString base64Encoded) 350433 " 350434 ^Form fromBinaryStream: ( 350435'iVBORw0KGgoAAAANSUhEUgAACRMAAAATCAYAAAAJHQhJAABs90lEQVR4XuVdB0xUW9c1mcxk 350436MmECAQIBQgkltIAaBCF2jYoVWyzYe+8de38+xd4e1qfYxS5WVBQrNixgAwvSZShDGWBm1nfb 350437NKYjlu/dk8z/f/LOLefec8/Ze+21124AsL+xv7G/sb+xv7G/sb+xv7G/sb+xv7G/sb+xv7G/ 350438sb+xv7G/sb+xv7GvST6fxox2oei9NhG54kxcXtwVoV2W4kZuNfsfzn+8yasycW5SI7i2nI3T 350439qR9xY3UXeHgPwP635ZDJ5ex/QH/Su6pMw44IHzg3mYzEXLX/XVT39ySXy1D28SyWDolAz/H/ 3504404GmxzKzjZSUvsHtiL0QMXoIzH8oMzhm5vArZN9ZgaEQ3dO/WHYOWXsJXieF7l8uK8Hh9d3g5 350441BqD36qv4mPYvegSPw+1iA9cR3cAwlwawahWNV6JXiG5lhQYuw3BDZOjeqpGbsAa9Ah3hGNgb 350442f93MRfUfMv/Jd1SRfhITGgphGTwftwqkRvuL7i1FMysBvAfvw2ux9juVFT3CmjZ2sHILgLuV 350443NUIX3ESBVHO88gq1Z5el+zlejWoOW4E3RsVlajwvWdkrbO3sAIFbb2x7VkzckxQFtxYg1Noa 350444Hv4usHTshI3PSqn5ou99/fBzk4nxMmYoGjvYwqv9ZPxzJxOid7vRNXgCEg3NH1kpXh8ah2B7 350445G/gPP4z0SrmZ70sK0f01aO9sDffOy3H9m8ToMdW5CVjYygm2zu5wsPNG/5iXEMuMfBvV2biy 350446KByetg5o2DMKR57lIidhGho2nIqkEgPjq9B8lxrPv0L+m+Z4Db7fX49uLnzYtfsbySUyk591 3504474Z1FCCPmukff7XhSJDUw7vc4OMgDFraexDOzgMfAf/Fez3h/5BnJJZ9wdJgXBLbNMffiV0jY 350448v4+yv7G/sb+xv/0nWgP2PwL2N/Y39jf2N/Y39jf2N/Y39jf2N/Y39jf2N/Y39jf2N/Y39jf2 350449NzY2MiBXlLwBXV1s4dnQDbZeA7EvVVwnMolcVoMqSRVqmEAoGdiWVkkgqZax/0H/oU1WmoId 350450kcHw8/OHX8MuWJFYgJrfEAAl50p1ZTkqqlRzRS6VoKJcopxPrP5OTSB31PW5i98ex7QwJ/iN 350451OGIyeUIuycCJ0f5wCp2KY2liI0QikqyzCG18WmFa7Atkvo7D/A6+CJt5AZkGCEXy4juYGNIV 350452Mc9e4MikYNhwhWg86wbypfVMJhInY1HLtlh5Lxe591aiXavFSBbL/6A1miQUHce4QFsETo1H 350453bo3+e5MWJGBeEzv4DvsXaTqIRPLqHMRPC4Jnp5VIyClHXtJ69PDyxdDYdFSqvUNT5ht5rmsL 350454WsDRexiOf6li9gAxUjZ2hJM7TSQi54Xk03GM8PdE9/VJyCcJqwvbwD14Fq7k1vw8MlHJXUwO 3504557ogtL7KRdnYxOrsJ0IDrgA5rHqLIGFFHLkHW9eUId3FAqxVJEElNnwvkWEf62iJgxF6kFEuN 3504569peKHmF9Z080HLQV93KL8PFcFNp7BGDk4Q+oMHCfko8x6OQZjl2vviHl6Cy0ceIR43NEp/VP 350457UCL7/yITKeZ48fOd6O9pi+B5CQa/cUWrzjqPif628B/xL1LF+m0MuVSEpBWt4RE6hVirSlBK 350458rXceaLX0Lr7ruE5dn5FcVobXO7rD1a0b/k7K/y376H/fXq1C9vWV6BlAEj97YdWNbFT95ucs 350459Lf2El0+S8fxtHiRm2CrknJfkv8Xz5GQ8efEe3yU/dxw1FWKUlpRCXFmj/55qKiEuJb4RcaVq 350460fBL6uLKqP8OOl9WUo0QkgqhIjKo62IbUcxcXQUSco6Sihv0fVZ3fQ4VyrrDFRmc/mYj9jf2N 350461/Y39jf2N/Y39jf2N/e2H2j/93METBGLKpZw/JoOR/Y39jf2N/Y39jf2N/Y39jf2N/c3URoHr 350462ohx8y/yG3GJJnVVpZKL7WBrmiCazrxIBbxlED1YTQU5/TLiYzf7AGvubkTlYgbR/usPdfxSO 350463Z1RCVvoC23p4wG9UHDKr2T93WDknpGJkfcqCmAj4y2USiHIKUCat/7kgL7mHGSGtGTLRKrQO 350464nmZQ3YX97f9r7pBNWl6Ab7klqP6PBD1lku/4kpGtHF+NOI8Yn/iPx6PksgrkZYp+OwHkv9ok 350465Xy8iqmsImrSbgrgvEjPeixgvd/ZHE9/GiFh1E7k69lySyPMlbgraBTVCSLeluF0g/fXzR/wY 350466Uc3bYvV9eq1u2yIKj38z8VNWnoa9/d3AtwvHlldlpo+l/A22dbYHh+eOvrtSUCrT9cwr8eHQ 350467KLRs3BjNB+9EirjuhJ7iZ1vRw5UHi8ApiM/RVh4l1c4uTg6AgO9OqaPRNv09LAmzRIMGHDh0 3504682Y435b//u5VVpOP42ABYcJ3RY9cblJlJ4BKnbEVXRy4sG0/G6c8SPf2qkXN5HsKbNELjpr2w 3504697qHoP6fWSSlTvjuKqeGhaNZzFe58N/17lld/w5kxPuDz6Lmic+5WZeLsjHA0DQ5DxNKbJhFE 350470zbp/4vxxo4l7EPhgeOw7lP+CvV0vmUjBOG3QoAH4DefiYanpsovysqdYFmIBu64HkFElh/hR 350471FBoLHNH35DedjnPF62i0DhiFmzpkSaWip9g3NRz+9kII7f0QPmUvnog0X6y88i1iujvBsfN2 350472pOr5oGWVmbi5bQq6NXGDjYBYNGxcEdAiAmPXXUdWlVzn2MlxKv8m+Yj9vZ3BbcCDz7h4xPZz 350473AacBH94j9Tt0hsb1q5o0Kw6Rzly4DbuoNtm/49nRZRjWPhAuNhYQ2rohqPNY/H0uFSW1JT0l 350474n3FpywJMHNgJTT1twGugOSe03r3kGxJiFmN8n7Zo7GEPIZ9HvDcvhPaYim0Jn7UY5fKKtzg0 350475dyA6h/nD1dYCPK4AVo4+COs+DmtOpUBkINOA3HC2diI2HAP3pD6Pdf50ZGZQi2p6Av6ZOwjt 350476GrrBTsiHwNoZfmFdMGTBEaUEpNFz6zg/KRX69mI0JvVsBl9HK2LB4VPjbdZjEqIvvtVaeMh7 350477Kc+4ik0Tu6GJmw0sLGzhHtwNk7fcwOfy/++sNknmVWyZPQSdQrxgL+SBb+kI3xb9MXffA+RW 3504781ffimo593exU78WqDTalVhpc91Q/Yg7buaNx+8GIOqD73mqK03Bl53wM6xQML+K9CvgWsHVr 350479hLb9p+Hv48koqJZrn5vDBd/CGg7u/gjt0A8TV+xDwsdSSNWzYIzNMadIXMyTmdxPY00Uf8Kd 350480f1dgfO9WCHSzhyXxrQqsHOHVpB36jFuEbWef43ut+679jclLH2JuQ77GXDfY38C+Urs/KfGa 350481d3MJWttxqP/GsW2JRTdyDZ7f0LvkOPXBka+ahmL11yPo48TR+l41j+XCpV8sPlUZHoeGIfI5 350482EfsWjUAXYm47WglgYe0EnzBiv1l5GI+yKzWML33vjiOwgUtgG0TOjcGtrxWax5Drwte7OLBk 350483pOY1QrthzPJY3P9mwjU4PFgSa3NIl9FYdeqlVpaRXFaJzNsxmNO/NfydrcHnkvumC3yD26LH 3504840KlYezaDytgyaR1Ue77mzqcjvR3pf/P9MT1R23CVi59gCWFvUH1sw7HrvQSZJ3rDkbqmDTrs 350485eKeU1JXXZOJYLwfmfhzRR80mIeXSt7azpv+bcyTO5EhR+uQvtLKm79UiaB5uqRmVcmk+bsxs 350486BAvmOq3XPkFF2k50cWDmK+FAbX1TrvHOih8uQ5glfT6e+2Ac+1Jl+vOr9eyUP9tOiPkooewx 350487i5CleFLLgSx/+TdaWGoeU/u5k3bW7hlDMHLxaaRX1H1fkRU/weYIFwg9h+LoJ4l5a7SJ33W9 3504887Ac65lmdxluSipNLItHCx55w4FTv6WeNu77W1t/9/FkF3tYU4f3ju0hMTETi/TfUnsr+ZrzV 350489FCZj38wIBBN2L59DzEuLECx9WqaVDVl0cww8yP/OIXxOr2bot/AE3pTK6hg8uYsp/tZwdHOH 350490u3utn5sjbBvOwL1awRRZ6SvsGewNAbmmO3fF+vuFGjacWf5aPa3Dpo6D/f3Y34/9/djfz9x+ 350491P2JDGMPF5NJivDq1AsM7NIKrjQA8viUcvUMQPnoHXpXpwGo+XMW2mX3R0s8JVgICP3LyR6v+ 350492M7ElnsBTCJ+mJvsCxvkyth7HERG736v8AQL4jRvuSeFaHKfeOJjBqEiQqkSv4rB6TGcEe9jB 350493gsf4xo1bIWLodKyNe6sstyITv8P5NSPQPsCJ8KH5sCSu36LHWKw+90l1HbLEzv0lCLN1R6/l 350494azHMzxr+Ey8iRwe+VZX/BEeXDUf7QBdYC60JH7ADRiw/hmcFVbXwr1TEjGmPxu62EBC+mdDR 350495H21H/I0rXyp/O7hv8hh0+TOkn0M8/+IXBzClnRdshPYIjIhC3IcyM4NrL7BxUAvCdyVxNks4 350496B/XC4nMZqCCeTVpMJBq72hLvlQOuhSMCO03B3icik30xm/AYfJDIzQ5QiN+dxcohreBtJ1Di 350497ltTP3TBOLK98hz09XWAXOgZzB/jB2ncszmVVq401BVtGdEAwg9GqK0WQ2HfCpnEIb0jMTwGB 350498S3k2Q/+Fx/CyqG4Bz6qCFJzbMhdDOoXA20FIYOIm+K52XbE/var+bMOca1g2pCciIiLQo98M 350499HPmgieVJv9/F3yPo/x7RZzL2vhZrHp95FD3t6XvTp6phKmb4W44h5lLBtfHw5jHHcD0x+nK+ 350500ERUkCT7EhMNW+V4s0HTZE4gNHVOZio1trJT3ZtV6I94YUWgSP1mOpkIT8SDnwbj8Xf7jWOoP 3505014qI/s59RnNNMn14Lv1BgyUJbOHs3RquIEYjafhGvRdX611qeF0ac/qZBsKlPTPO3HvfpNvYu 350502HI7OwZ5wII+zoY8bt/JIvV/PnLW/MvshDq8ch4gwHzhZWxDYvw1cA1uj79RonH7xBSn7hsDP 350503dyjivlXXL+b+G/r/KA5qCv4kl5Yg7QIRS+tBxNKciHWCR9p+fmjRZwa23fikFUAnr1v6cjcG 350504egrh3DMGaSaQP8hjih6uREsbKzSeHIdPetY+SfpB9He3Q9PRczDAzwYBky4iWxfpiIj/Pd/S 350505B752LmgxKRYv04j4Q+hE3Ck2ogJlguKeXPwI85u3w5oHeTSZqHkUHv0BKnI1eQmIamoDx27/ 350506IK3ClGdeibcxEXAUuKDH5id61dIkH/ejt5sL2k+egnAXG4SQql01dVPTokowPliHTo4W8BgU 350507i3SJXON+Ph6MhLuFC7pvou9HLhPh/tIw2Dh1wsKN09DM1hFddqSi3ITylPKqLMTPaQpr8tuw 350508boqZp57gacJhbJgzGJ16/43ntX0cWQmebOwJbyJW03X5dby7G4WQxvpJvbLy9zg80g9C6xZY 350509liQyGYuSfk/EwlArCAPG4nh6hd71TvL5GIZ5WcG7bxRmhDvDOmg2rufpVjEieRMHJ0/A3nv3 350510EDu3Kxq6O8K92xa8MaWMYj2qTNZtza7B96S16OQkhN/4s/hWbcrcrcLn40PhqTZXdNlh6QcH 350511wN02CMNmDoCfjT8mXMjSSXbVmEtZJqrAEfP1/b6+cBV6IHL3a42yoHXB+E1VtPwpZCJKZtBW 350512iGZrUoiPqxJpm9vC2rottqRVmkW6kcsKcGOKP+EIEg9lVwISdg6AB48P/ynXUaCUCyZezIE+ 350513cLVvjw0puiVFyQ//blQIhDqMP8vmfyGl3DCZiGTiZZ4aSlybNPRbYf3LchQlzUNjAfFvQQCm 350514XstXfrDS7/ewZek2XHlfArFiXKJKZN3/FytXnf3FH4MUOecGw5XrikFnc5jARi6uzQuFNUeH 350515Icx1QMe1DyGSGQ906yUTGTK2Bb4YezpTg3ltsD/HAV22p1LOv64P5t1uYsPhGL4nc8lElFTg 3505161YVoY8812t8U4IHrO0W56NNztR/xPvT0J95TvwMfNWrJVrzbjwHuPB39BfAZcQQZkv/fwJQy 350517CKT13m3RLjpFy6iT5D7BqegZGNCmIdzsLCG0dYVfaGci8BKDy29EBjMPJO93oaON+nUs0Xxt 350518CrX5mzVfiHtru+65coGmDOMXuzE80NLoHDNlvnAsG2FM7Dslo/hnkIkoo/r1QYwPttEEtEy4 350519719FJqKIRLeWo629gkjUAlHXaLWTupKJGjSwRcddasQS4nt8t7MjbEx5V4JAzEgoUO4v+glQ 350520Vci6sghtHbh6nyvPtTvWJakk002ZFzz3SOx/V6Fao64vQXtHA9dw6Yq/7uSbfg2uM3rtUQPZ 350521iT3v29nx8BfoO4YDj7G3UPQLyERZcZFw4dCkPt/JNzX2J7KVPlqAJsx92nfbj/Qqwpl9swGt 350522rei/OUeeRa5U8RxuYaI3V0kS9J2SSI2B2ruz49DfiT7Guv12vJXIKUM+eU0ryvBv0ECI4KhE 350523FJLZgMTemp8wG40tGHC59V94QgSw5fIyvNrcEXYcmoTm3PuA0jGREYBvdDsb1Vp/KJ163qY+ 350524P57/DINkopS/msNSGIqVz8vMIhNJRcnYGOHCEIWFCBx3DB9/IJAtFT3A351c4Nrjn/80mYi0 350525TxOmBYCvY46zn0zE/lbfxDVWPTNpHq5M8FEmL1A/Y2QitSBJ8MKHBiXtDZFwpoVPw10dQA2Z 350526pT2n2xyNYLqs+Dl29vOg1gCe0JIiPXEdO2LVHfOl3OtzHTZ1HOzvx/5+7O/H/n7m9vtZZCLS 350527J8uIHQA3nmlYTdbl+Whhy9FpL6t8SQK/Oz0K3nwGkyGCV8e/VtGBonsLEWxBr7dNlzyi9gzK 350528P34WjY72HL22uGO/08ihVEG+I2F6IEUk1ecfqeOQSYtDYUn8d4H/JMTn1GgHu17tw7DGgei1 3505299BgepBeiXFKOwoyHOLGsNxoGjcCBNyqMU16ZgfjYY7ic9Byp79Lw7NxCNCN8Hofu+zSCIb8W 350530czRzDHrIRLLi+4gK9kCnlRfwNCURMSP84RZxwLx7KX+Hs0ev4XWuGOIPsejnwgHXZwo1t7Pv 350531ncOlBx9QUCGBKHkD2hLYkHXbLSb7Yvbd/9VILjIpqKZOalMjEJmadCr5eAjDm/rC278NZsVr 350532KlqRc+HKsVO4dvUfRDiobCO5rBgPlzWDFYkXDt6BhKcPcXJ+C9hyePAYchxfq8zJXCdwhxsr 3505330NmFb5qv/xPJRGRQ9una1oxfzoVL33+Vc576zhYq8H4+EQi6gOxaQUZTyESmYoa/4xi5LA/x 350534ozzViFwcuA+7oMQ5dBOD0rClrbXGexE0jsJDA+s5OTdbWandGxH/iH5dYeC+CnFzqr+2T2wC 350535mahesVS2kYl0/Cx8BmDHkyJlbKr2vQsazsANNQWV+sQ0f89xEmTGR6G1geP4bhFYf+97vVzP 3505369HWzGnmJa9DVhWcgrsAF36Edlt/KM4px/z+QiX4UBzWKVVHxv15w0RdL4/tiDBFrrB0Togi9 350537b/ZhiI8z2q97YhQjkOYnYG4TRzSZegafJfoIEGmI6eEOn6GxhL8uRemLrYjw8MXwE1+0VKbk 350538JUmYHhqODXef4PyqPgiwt0WTmdeRJ60HMhExj79dWYYIfwc4+Edg+dWsP0LliiLqpe1BXw83 3505399N73QSO+qZuY9S/6urug8/qHessoyiXpONjfB8HT45FdXY2cK3MQbOeFYUcytM5vamk+MuaU 350540n7gcbRyc0GXrSyrGR9mzzzci3MkJHdYkKUv/FT1YhmbOTTH3ai4xxyqRcXw0Aty6YkdquXEy 350541EZkI/ukiZgYJlfNV6N0NU9cdwrWUbG0SHDFnphFxzk13HuDInA7wsLZFGBmHMDB3ZWVp+Heo 350542D2z8J+Lct2rj74hUshnjC2vf4Tj0rlwvkYgU/9jd2wPekXvwWiyDtPA+1nZyQ8DYMzpFVUjV 350543xBJRCVXijoyZSMRig+Xu/iQykYJDUfhgPbq6eaL/gQ8a5U51z91YRHo6a8yV2q08dRci3Hww 350544+OA7lEtLkbK9Bzx8huG4DiUoc8lEtLrUJoQ7u6Pn1mcolsl/GOP/bWQicjC55wfBhVjMpyQW 350545UUoAx3s7QtBovuYGVJWLhwfmY0ALH9hbcChjmG/lDL9mXTF0Hq0+RH1EfsQG7DoUV77LIPt+ 350546BUNdiY3db7qSoFH1+QgGuduh1V9PdMpJKYDVKT60ocBx7oV9b4ohqSxCZso1xO6/iq8Sw2Qi 350547WWkyljalP3y7bvuoYKW8/CX+bkEbvTbtNiOVeblVObexbVxruFq7oWW3VnCzb4junQNha9sI 350548/Zad1uHwpuCv5pY/5YORy3Jxabg7uM79cepbDZ0ddXsmAgW0k+U9ZC+e5ZejLPs+NvdwoR0T 350549y+ZY81yVxSEXv8Le5Sux7dB53L61Fz0djZGJEjCudU9EHbiJNMKJl4i/IOGvTnDkqhy31+oL 350550OLHoHd15CFefZqCgrApV4m+4v70fTdwiyV4t/sZLXY5e+iH0c+WCK7SDkGsamciUj4fayFy4 3505511PNxi1iO088yUSypQVVZATKeJ+D4gTN4X244++PdTkX2BxHUWPxIOS81sjwEvhgZ+xqFZSK8 350552OTwKvkww3KrNRqQy7Ge5NBcXRzIOI98bw2NTUUTM2zeHhtHAGNcToy7m1jkL2lCrEr3H7bNX 350553kW5mrWB5RTqunr2N9yLjwEHxg5WYuvIY7n0oIACnEqRfnI0mQhXJTxVYKkbKwYloaqvf2G/A 350554d0PXldeRJdFNPEvd1IYBHlQ/YdNleCo2Pl/ksnJ8vTIfIUxAXtBkkbJuePW3sxirAIh4Lui0 3505554BgefRKhokqC0ty3SDq5DqN7TsNNnQa5DDXUOnQF28eFEgCPghzQAZvfVJg1f82Z5zXZFzHJ 350556X6AkELaathsJqTkolVRDUlaILy8TEbc9CoN6zMTtot9BJiKNupVozzh3HJtmmH9FVf+37mQi 350557cl6tQQrD/JaXpWBNc0uTwQrrNtGqY/Xcg+QDsUY6MfdtG4ZpsY+RWSpBpSgdd3aNRENFNobX 350558SMRlVut/JmQmS/5rnJoVqgTMvMZeZUDF/ejtbMI1PIcbvIZMUoAXB4YqQXbL5muVxFp55Rts 350559aM2sVVahiLr4DiJqHfyOT8Q6eHTDHEyJJvZcudzsuWjufJLmXsAwd3q8PJ8JuP5dpvZtl+DB 350560/MYMmO+I3ke+0s44YTvM8Kedd37ATGUApDxlNZqpZc1R+wsz5uK70+DHo/fGRvMfKTP2ZCWP 350561saolA8IJQxB1pxBVBTcxpzGjhmTdCmuSS5QGuEz8HOvbMs4yzxPD4zIph+NdTHeG/Eo41732 3505624r2RDL+Kt3vQ24VZ8wQBmHwx2+CzK3u+AqFC/UCkrmPJuvQburtoBu3rgVBUJ3vl/41MRMoK 350563N2bWUfsIHPpYUafstZ85bvaTieofGKmW1LCfTPSznzNZXoFZvxtYhmJRQibKamTazq0i+766 350564FB/PTmZ8G91JIvVNJiLJP5t6uILHtUPYhH1IzvuO18fnop0TD1z7NliSkGuytH59r8PsJ0Gw 350565vx/7+7G/3y8nE5XcR1R4MIKDgxHWR+UvmUwmqlDzOwibd8LJdyiRVEL05QUSzt3QyAyv+hSL 350566Aa4K+9gbff86j+ef81GY+xEPT63B0F5L8EgREK36ihPDPJn1lQ+/CfHIFb/Fzs60sjXXbTBO 350567KnwlWT7iR7jTiTZ8d/Raew6PXr/D29dPcPvcfqyd3hedx1+gyUTiJ1gczPgBNh2w5ZkIEkkp 350568slPvIP7mFy3wWS6VQFxaCnFFjZatKM27jpmhwZh0+rN2QITAlb6cnYrQZrORkC9VBilzb2/E 350569qLZ+cBSqBSrdRiHhN6mhmzsGfa0ybQva+Q1GfIGM8W1Wolng+DrhpwpyWBsbDuy7/IN36lnn 350570RLAjhwggNbfiwm3QCeL9lCH3czrS09V/H/D8xGQ0YhJHOLZtsTa52GxbP/NYLzjoUCOqTwX7 3505712raRvPQ+ZgXwGSI2jetKv51AbwfSZ+mBw1+rTT532eut6OygINjx4dphCjYev4FHKWn48OwQ 350572ejPYcAOHHtj/tNYz/JSF4qr69SdlxY+wojmzVvA8MOTEVwIjkqHk8UrifTJ+jN94XMjWttel 350573OfGY2o5ep1oO36+lMmUOZvirj6HuP/c8hrppkh05rgNxOlv/d1Xxaj1aWtbGTQMx826RHrWW 350574cjpBiSErcUwgOtVkn8EQN67KBv+m8il5HpHYdSWRVmhV/O6/RkGVbiw1POoIRUYksdSy75/w 350575NP4fzBoyB7dF8nrHRX9Fv59GJlLgZASGnp16C/tmtYMTEz/h+4zGaR0YoIK0Frb8kTLgWJ+Y 3505765m857v1u9GBU5rlOHbEoLgU5YgkqCt8jYesQ+DHrN997NM58+7HrVeckYt+/97WUUChFw+dH 350577EXNZtf+Rdkqkm+7zJ+4apTw/x64TdjCCC//vZKK64KB6Ffr5VnD0CUP38X/jDBG7JeNd8rJn 350578WN6UsbuEQZh5Pp2IX5Thy+W5CGbwXds6qAf+dFxDg1xBYEkVlaiRsR8PYg2uVZGKXQMDYWfr 350579jTaDZ2BmXz+K9Mx16ooNyXr24VpzRlJeyf7SyPWMXVflJiPxjeinxNL/S8/JUKs3MpFZpTpI 350580ibAlZLaE4SwGeXEiJnhxKacrgdrQEjDKnfjwvCYgsZj4d3Um4kZ4wTZsKR4UyUwL+ti0xYaU 350581MsNyoGrj1JQTtUOXfelUUJsytNcyhragMaIelqgZFCTTOQrNmYwpgdcg7HlVqnuh+IlkIlnB 350582FYz25MGxzzFk1sgpkOTySA/aKbBsgb9fqqQHS+7NQUM+7SQ2nPugTkFixcInrtR0aGTEexvr 350583yRhTHmNwy4jTLMu/hIGMQoQwdKW27BsJDA31AI/jhB5/b0M/l/ohE8nlYiQvakKVreH7TsSV 350584PPNlgGUlD7GwCWPk2HVGzHsV25As/7dUUY7HeZASKJEVxGOQM5NNELIUTxWEhdJ7mMkEVMg5 350585f5t5bvKi2/R3QfzdZeAZCtQy14HRee+SPLy+uhdLR7SFlyWnTnNScT2OpRfajliKvVdfI09i 350586GohQ/TkWEfaaZCJKFnJTVzhxubANGoDF+67gaXoexBIpagjjsSjnI14knkHM8tFo7+2M5osS 350587UVC7XBPxjSmIf1z3Hpgz0I/OnBEEEd9tqUnzRUlspObwWGoOk/Pl2YpQJgNKiOAFd3WyheUy 350588Gjg0aJDXZOPiRD+GFCFA0ILHFJmh3p1ceRmerwpj7tkCQfNuaj0vc85d/2SimbgYvxodFEQi 3505896zDMjf+mV83M1GfCtXaFqzVxTkEjzLtHAoEyFCfNRSOB2n/TRybi8mhCH9cVkUfpbAPdBKAS 3505903J/XiHmHdui0M00DTCbncvLKMAacsULL9a8o1TVD41ECfxTAtLwWecb4NVpFG74GuZYolHrI 350591tfmmco25hTEejCqUxyhcLZDVm8Fi9nySFeDqWC/mHXhizBWVnLesOAmzA+n+HJdIijRLg/Y5 350592OBPpzJChWmPDm0oKfP98qDvsCGDMpf0ItHFUAapyeQVerW9JPzeOK4ZcylNlz5JzhQAoWzAA 350593pbDJOCwfrShvZo2Wq5M1MlzI/iXJq9GSKY8mCJiCC48PYoACUHDoil1pFUb2kSdY196OAfCs 350594ELb4Lq2IZOjZiZOxhAhs1CbsGnru6Qf7wVXoici10QQQQ4wtaCKi57aDg2VjzL5VqALjU8/j 350595WFJunerOSz6dwfKREWgdRMtH83gWsHEJQOv+s7HrViYqdYJZM3Hp5h5M7ugLe6E13FsMx4Zb 3505962VqZNtLiVJyPnoxezX2Jc/PBs7CHV0gXjN/xVAWSEUGM7JsbMLyFB2wsHeDfaToOJMZjph6C 350597R1XuIxxcOBhtA5xhLSDu1S0IXSdsxJX0MsMZ1bWUiUg7MPfOZoxq5Ulc1x5+Hadg7y3t62qO 350598exauPjyFxf3D4G5jAWvXphiwKh6fK2V1Ah51r1OV+BQ3EY2ENKDjFL4GdwtqTFqbr9w/jgV9 350599gon10hL2Pm0wMvoavlaU48uNjRjbwY+YN0LYEX8fvfk2cqp0vdfpOH81BlO6NIKzpQBWtcan 350600fK9Fr3Fm3QREhHkT5xRQJUZ8W/TGtM3xeK9WG13j3IFTERf3NwaFucNGz5yh5sItci64w1po 3506014jsJnIbTFzZiZBsf2Al48J50hwbORSk4tnwEwoM8qFK4ZDkWB4+GaNltKOb8cx8FNXKj88Qc 350602gDl5aQi95lg0xbInaoR/yUfs6UyXSeB6jMSlXClECYTPwmVKOZ6gSzkqyk+TgQG3YfHIl9F7 350603VtLMADrISvhdBzKqILq3lFI4oBIORtFlnMm5/PXkcHjx6DWv+fL7KE9RKJ4J0HjePbXvrQoZ 350604+7vBXlF+IT7PfIVQ9b3bZ7JGcFtfZpm6HV1XR9nUYDqpQLuuizMs3bth2YWPKiVJEuzJvIUN 350605kf6wtmuO+Ze/mXTd+l6H2U+CYH8/9vdjf79fTSYyaAfmPsD+eX0Q4mJB2bU8azcEdZqEfWq2 350606sLrfwfWdqlfKn8JqFPsh4cc2iUrSUiytqShBpZpvSyceMqQbi0AMmdGTSVojfLG1L5TJAxoK 350607Ho79cDpHPw5EYpDHB7jQdjrXCeErriC9VKpFZin7eBHrxnZGEw87CHlcCMgSKiHt0XdiNBKy 350608Gf8juj2aTr1BBNdFeHE4Cn1DCTvGwgK23i0xKiYV5bLvuDmrGTpueEP7dAyuyfMchmPvSonn 350609ewGRTvoJyzXiQpSpBT9r//uHgWr1MYgZfJgKJFrBNaQfVlzOhESqOQa9/k9ePEb5BWLsiQ8E 350610npiLO6vawKvTLrPxU6p8RTKBEXoKYd8qCvGZEh02BgdWjcbiaLpu5fya3GuYrcgi57mh3753 350611yns3x357t7ODpgqyCWQiubwYdyZ56y8lpsduUpKJiu9gEunfWzbHXyk03ivLPY8B5Dyx7YJ9 350612JM5eUwaRuEYNi9L8N+1P5+KSUgmHB/eBh/ChQo/CvI7SVVpY3/dnOLZiJDoFucHWgixPE4B2 350613w1ci7rUI4k/XsGl8ZzR2tYaFhS3cgrpg3PoLeFurdC2VHJu0CE0tFcSJsTj3PlkVwOb7YfyF 3506147LqpiZiBGf7yY+Q1KrVmrgcipkbAg7T1Oc7odzxT53hJ3O/ZSgarJPCNbnOGoqGAUWeelKAb 350615txQTAftQet7btJiESc1tGEx+BZ6J9ZTv2MfY/Q1s0emf95CYjEtqYqlNF2uv5zS+JTOKpbKV 350616TKT6VkW4q1TmEipL2enENG07YNOrcv33XFdM83ccN5c5juuOwSc1VWlIhbYHixXPxAqtN76h 350617zlvX6x3q4wwO1wHtV95REooopcMnW9HTlUc91y2pFbSdsjiYsVM0zy+XFeHptt5qKowWCFny 350618xCju//9CJjIXBzWp0odDZ2xKEVOx4BGuCsX2mbhXJEb67YNYM7ET3JmEIlLAQlHmy1QM8r/c 350619l1yfP51djpERrdDI0wGWfB4s7DwQ0n0SNl3NQCmBZ51YOhitfYn/ZmEFR9+W6D93D5KytBVT 350620TMFdTcVS/5S+5sZP67RuE+tJxrOXyBRLGcJdKvYN9KSVrT0GYE+qHozZZRCOX9uLqZ0D4WRJ 350621+ARerTF250N8r2W/m4qb/lf6m7MvK+Zsz+Y+1HfCJ/Bfr7AemLR6Paa1dEXQjKvIrTFvn/4T 350622+tYVhzUWYylL+QvNqfPaozvDe1H4eS/XtWC4L3Q81QiZSLVYqy/KprxMo2QiIjA/1VehFNQX 350623MedWoVXASFzLKcK31CSciz2B5O9SStXoZCThqFs0wqxrmci8TpYVIQKBkScIgLsG2RfGw9cm 350624mFIKMEgOkhXi5nRVOQqrkDm4nE0zjI01kviUMJ5x5tQcMrKVJM1EAGUICNBkUTJlBFTl3sHO 350625ie3gRgAlLShlokB06xQAW7sgRK46r33+csPOcF0buZF/v0EEFHgO6BH7mVZrUGfzug3HtULV 3506269dRlX2067sJ7XQovdWS1kc7rYOY4YbM1BjOGpRW5eLJ7ELxIYhNVUkoF8lD3QDpS58bCh8+B 350627feftSM26bnLgugHfBo62QggsndEwfBw23fiqsSkrJdaIvrbNJ2DG4JbwsrWAhY07mvaajb0P 3506288gzKBlJl5c6PoB07IkjnOVJTdpY0aO8vYgxaRplIVCZCqlKZSIiQRfdVi0HxbYzzZIA1PWQi 350629QZOFSpWcupCJSNWdrGcXsDNqIJq5MIQ74t5t/Dph7NoLeqUd9T4DyWdcWDsWnfxs6G+GvEeX 350630ZhgYtRMXnmVpSfgp33vRU+zs78F8o9ZovS6FmsOlT1ahubUNQmfG4aO4DBkXlqF3YydYEd9V 35063136XbMDtMJblWnXUBE5s0w4J7mgxf8VNFDW8O3IdfwLtb0+HPEOcCZ93VqGupW5moglh7FihB 350632C+t2W5FGlkAi5sv6lgxgZtMRu95LDD8bI++CzL4LE2p+g/Xu5Fa8Vs5xU+7Z2Lnrm0zEETrA 350633yUpBJGqK2ZcytTMc6/JMiP1l9UhyDyCCweOuIL86H1fGeRNBVGIOjFqDkQEGxuAbibn9vKmA 350634q6DRHNwu1CNjrFjLyfPYdcehz9p7jLpstG2XvbTKnYHx1GQeRy+GTGRBkonMvIZdl30Gr6G+ 350635lmj8vew5VoQqZDj5cG45HIu2HsGVx++RZ0Qpod7JRMQ6UHhzMnx59NrkMeISchmWvujOdATw 350636mW972HlVOTPCcXq7vT0D3jIBdcIOuD6aJNPaoeuuy9jUgQDHuF4YlyCCjLA1jvZyoK/LlA3T 350637XCeL8WhFcy0CtFWLVXhcrP08SKCArKlsyaynlnaW9HrIsUP4llcoM7SPSAtwKypEmRFoH74R 350638L8QmkEnkpXgUFUQEKnSXlNU5Zwng6e2zDIgL6f9GAoXPiwuR9uILFSCn1uCXMYj05EMQOBO3 350639Cs3PLi29P4uxk3T8LBpj1g26TKzGOmDlAndbTVlojl0HRKuVsq3OvYp5YbpLNTr0PoFvNfT9 350640i19Eo72dZhYnz9YDrlYcjXlGtqrMc5jcSKjzXnnuA1SlBo2RRMjrpmxEuH3t63pqXVdj3IRt 350641UnvcDTj26LzzrVEpaNP2fwm+npuGJtRexoNL92g8FElNW5uJe3OzqS3VbY1G3cLhY1HrGXCc 3506420HPvR6175hDBATshR+/4FO91bqi1nhKcXDh0WIP7Ou6ZQwAaDkKu3jlDvZPnuuaCkXdiYUc4 350643Wxzl9UkyERlEPDHYXWnj1P4pyyTWI5mIyiym1nUieLrwsdIuVpVJ4MN/Kl0GUpqlKNlI3O/E 350644WxARfeny04pzzqPfL2XD0PuJZcv1TGmMUjxd345WSuR5YURcJsq+HMdQTx61Htl1iMZzYj2S 350645V33CoV6OdGDYeywu5zNrlCQde7rQ5CY+sWbcEcl+iEykb55ryVT/YNaNTFr1U4PpBvfMel6H 3506462U+CYH8/9vdjf79frkwkJ/CyUaSqDwFsRqntUV9PY2JDHXYVxwNjbhaZtYbL8q9ioq+BkiE8 350647b4y7nKcq71KRjrPb12HdupWY0tZJe88WeKHX3DVYt/0spcRM4o7HFL4Asdd6R8zG1hM38DT9 350648uwZepGiSjGMY7W+hsjksvdFxfDTOvaJLr8tLH2OxIomMawlnH3/4uttBQO6vTFIfqVq9qXM7 350649rHgmwsf9fbXKd7iNTKD2cPHTpWjTeTPSKuVK9T6+73hcyvyOlJg+dAn92nspSWq/txWD246j 350650kzJr/bve9jDlGMrUyhUMRfyrCxjrw6Pfp1hzDPrnERH4OjMTLey5lM1hGTAUMSkl2v0M4Kfk 350651Ob5eikIre0v4DNxJqd1r+2mVyE0iA54cOPU6pAPPysCRoZ4MLiVAwOSLyK42bnPo+nvpo4Vo 350652om4n1yOZiLQPZNIa1BRcxVDSNmq5DimkjUaSgMaS2IUVwhYl4JtYhJTd/agAtk37zZQKOqUm 350653324wtt3PYxKlNP9N4wSJNCmJ8tlCsDRZrB9n1aFMlPGtSFneojo7HjODrXSOh2vtAR8Hxv/n 350654WsHJ1Z7+Tsikhy4b8LSkFqFI+h235wUxwXo+HHxcYcmh/7eu8mbKbzZ9L7o7CyEUCuHUaQdl 350655q6s3czDDX30MtT71daLXGrehOJtyBkNcaf/EsVcsvugqN0KsQYokV47rEJx9fw9RQQIGWx6j 350656tN017i15EVMCkkxKS0ZydCsa/7AIxqJa75/+Fl8q8VCOc38cz6w2A5dUw1IJ/GX3xx/DUv/E 350657fr+KTETN7w8xCGd8PaVfp34uv0jM60+WkVaVoKpXTPM3HsdxH4ErOpIfy5XBUbLCyL/4VF33 35065864nTDmCoj4BS9u+w6g4KamQofroNvdwIu4Tnip5bnqBIqulfq5+f9PeSN/WAq01DDF8yBaHM 350659+W0YNZ3/ApnIXBxUv0L/S5yYEcJgr+Q6eakWtj8aG+e1ofEKgQ8Gb7mGV8R+U1kjMxuD/C/3 350660JfHhB7MDlXFwjR/fAT7u1jrtDIHvKBz7pFqPTcFdzcFS/5S+v4RMJK/G92dHsWx4BzRysQKP 350661w4XQxkrFTQhbjCSRNtZPEvIdrGr5PHw/TLqmmgfm4Kb/hf7mNENzlrKB3IbgDKNg+f9GJqor 350662DmssxkIev7ebPWNDrFNW8JCXv8DqZvQ3JQxbpRR70U8mEicr5Xut22/TMrb1ArJ5lzDUjQ+f 350663iSSoXYNvJ/vCkR+IWffUlHvEj9SUglpizvqJaOI3SqdjK/l8FnPbOjMfGxHUbDMHZz5Voibv 350664KqYF2qDhzBvIZwKIsmoJJNW1nA1JJi4vbAsHDeecCNC1X42kQikjA8sojjCKR7Wd1TXNGGPA 350665eRAuqRndVZ/+RTc7xsjovIcyMqQFd7FhwUZcSiuGWOEkiiqQmbQPS5fHmeUM/5BjLxPh1hRf 3506668Oy6YX9GlRY5hWLzqi9+369gsDMTtA5ejCfi+iETkUHYx2vb0GW/uC7oeyBdZ83M2sEGjnUQ 350667Ru9+jIJajpGUWBSmBhBzx7YdNpCT3ozAtbFNWf356PxZhWHRnUK9UmhyyXvEMBnipMO1+JG2 350668GpWsPB0XV0ci2F7zI+bZByNy9SWkl6tl3astBooyZ8XqZc4aaCo9ma5MIIX48wOc2jgDvZs4 350669MN8WB0KPVhgStRPnkr9CLJWb9gxrARsqJ1+MzORz2LlgCFp7CJlFnHD2m/TGjI2n8OCzyhmV 350670fItHVEs7pYxuw3FH8aFcRqmLnCOAHNde+/C+kiQWrVaqg9Bgg5AITHLVABUJPu7uiqCR8chT 350671sjOJAPuCIDrzgOOGYRdyUSO6jamMyhDPdzISCmUmj5Vj1wbL7hTQxlnRLYxVZFGS2fPF8h9y 350672gGV5F+jMQtKAC1pAkcSM3Y9jv9O03Lqp/dTv2XsS7jD3LK/+hIPd7HQDVWa8/x8lE6nerSsG 350673xGYYXStMd+jn4MYtGrghFWyOPDyCAS7EcxCGYvntG5hj0Hmag9tP/kFXihhgi/abXqNc1zhM 350674yKpVV11TlMvT50RJvr9BnLLMGeNEmXkNCwPXkEkIAFpZ5kyARrPvKLPByG8p4/AQePJ1AX5+ 3506756Dr7EF7oMezqm0xEjakoCbMUCkSE4XcuR0rtcTen+NGqGlwvDcUiCgx7NJ9SniINUZ9JtyES 350676M8pwxDtf8TwXj6NIhSchQlc8h5gAUMczpCpy/0vWsf/Jih5gaaiaY2IZhuUP9cvdy0R3ERWs 3506776cjYtotWEoN0g+jV+HZ2PPyY7BqeW38c+FBp8rOlFQZt0GHnO7NIeIr/RgWx1ZQAFQFsnmsP 350678bE4uqpMMKCkhejPpFT7niyGpIUs7ipB+bRlaMBlLjn2O08qJ6usAxwGdoh8gT5yPx5u7wokB 350679lD1H0Ws7CVIkzVFklPHh2XcjEtJFkFSVIS/tJo6feErNZbksD/GKjFqOI7puekScMw+PNnVh 350680pJbVvnliPt2ZRTvbAv8xiCXmSJmE2McS16K9HX19r9HxyvrmhkGUPFwerbiuYix5eBAdDgeO 350681ofXVCqHzLiK9RIz0uHHKeWDTYSdVnuGHyESB03Dq6Gw0teZQRCL3PtvwtEhmxtpsjWYL4pFR 350682Wo7MS5MRIFD83QbNF17BZ3EZvpybAD++Ahj7RwsYMzo+wl68N0+hvGaF4BlxSBVVoiLvOQ6M 3506839FP+veW6l5TUvnlzhpgLIz1Mmwsa98yHFxGMup9JzN/yfHz+UkyRMBW2IselLw6mlaK6phLF 350684WWl4cOlfbN19CznVJswTc5xGwr78J9yW3jsaz8eDEtrmSdvWjt4jLJpgAZPNLJd8QEy4IpOY 350685VPdkyk+T98sl7tu6LTanVqL6i0INko+Gc1SKpLLyN9jZ3ZF6Vjz3jhjcwZVaZ7nOPRCTVs6s 350686VaRq60Sa5ElmRR+js0FJIJsmLamyYrXWRrEqI6sB1xndN2tmtMlyz6I/UzZD0DgKj8UmkImK 350687EjDKrYE2+V5eA1HKCSwf2hredkIqC779kPnYfuYhPhaUo6qiAG9v7sa0fjN+G5movtdh9pMg 3506882N+P/f3Y3++Xk4mqMrC/K+1HOg+8yOy733FjMmOnE3t3w+6d4Os7Etcys5ESH4vTb8uNkm7V 35068998zyD+exc8VYBCuwACsCK1pGkoXoX/TOCwSOUjf8gsYRapAbr27fqABtK6+2GLXuEj6WMYBt 350690ZRq2diSxCw5smgzApFFdEKgox27hhxGxHyF5ux3tremkht7HmDLMpH9XmI5H8RfwKLeKtidC 350691B+Hi5+cE3iikApK9NiUhU1wNSdEnpLzMpex5We45RIaOw+1iWh39w7FpaOtBBCOEzmgeORyh 350692tprPSy7Jwq3ovvC24MK6xXI8KVT926blCqqUknqw1NCv9n6r9e4VY8iT1SITncNobx74jeZR 350693SanqYzDWpIS9lfklByXVMrPfpXpCLIfLBZf8EYFmEmfOeXgFd9LyUVFdgezby6myWCTOrYld 350694ivFic2elvU4+r/simUk+lU77reY77q3vCQ+BfjJR7eO0CVsZODkugCbPcJ3QdeMTym7S+VwY 350695PK7m+0PsHBUKB0XAkWMJn26LcD6DLsssJ/ziFS1twLXwQb/o28gufILlLaxV/ybs8uqvh9GD 350696STZt4BSJC3ky03FWdXK9ht9mgxYLLxP+RCVEqccxMVBFyOO59sau58WQyiqRcXI0fPl0//Zb 350697UrVKB0rzr2NGQ4HG9fSVN6Nsy9KX2K2wPclST8uSNZT4zcUMf+UxVGDscyx6MAlmTv1O4pvk 350698G072o8lFDexVeL/qOqQK9xxGiYgD1yHnkFNTiodRjZXXHnouR8OmpBRb5jPvicJLypgy6gxW 350699NP8+SjT6E9e4Nx+NGbzFa+xlWvm0Lrik7xS9inSmzjezcdGf2K++yUR670F93S++i8k+CsVx 350700Rkm/Nqb5dDe6k2ULyYSR099QXZ+Y5m88zrL5Wp0J6+o+pUXIMqoCRJ2vRyYmqRGKWo+djM61 350701iETKPdFT8/wkkehhdDe42DTG5LgMVOSrVaYwgNf+P5KJzMFBDSfVHtNMqlXv6xKK5u7M3mEV 350702igVXvqCiFgnTVAySbJWfruH4+ftIyyoi7AMpqsvy8OrkVDQWavc157xk39v33+Drd6Kv1Fjf 350703J0h8mIrMQuN9JTmPceP2c3zMLaYIVFJJET4lrFAqQinxVXkVch7fQOKLdOQWk+XVpIRtmYEb 350704K1oyMQYunLutx82MIlRKSohzrEZbOzrp0Gf8VXo919i/BfAZvBNJX0ogIfpnPr+Efw8nM7ir 350705CkvlufXClqRMlFYU4cOFuQix1MRS69rXGEar6suBY/hqXPsoIsZVii8316CdLjz3J5OJyLhr 350706fkKUkjio+2eLDtu1E0dJLC1oxjmkFxfi6aaOsGPel9d4OlGwNm7adFYc0kjcNP8FDo7SgZv+ 350707YH+juOxP7m8eF6IId+c01Dq3+N1BRCqUaglsu82G14arePypZCIzcFiz8HJKHGU4LY5CKhAl 3507080bEuFQHeGu22qpT2GpgDCpjSipNmwJ/vjAGnswlHoBA3xnoRC8QwxKs5H6RM0vsDg+Et0CT4 350709WDgGov3g+fjnRjrE6mohMgmKsj7hUxad3UBmI9yaGwQb/0mIz61Bde4dbBgcDAc+zbAMHhSN 35071027nVlLP9ivzwOPTAQ2fsxf5ZzWDDoRdI1947kfL1Bka505u9bacYfKxdO1nNyOX5TdcwNmTf 350711L6sIOIwRUJvRXDvjpC7EjLo0WdEdzAjgE2ParRyTYTLR5XonE5EZzikxA5iAtBCNppxHZpXc 350712ZOdA4B6B9Q9U5B3Fe7cg3mXLNYQDKDNBeacsDUd3HsSVJxn4Xl6FysI0nF/YmpkTDWDXlVbu 350713ULxrhWHZgO9DAEEkeacYqbEj4MNX9N9Lsfh1KjA8XowQJvPIrrPueq3VeUnYProFnGsDVQJn 350714NBu5GYk5VRpKRwW3opSKODrJLZ7jlEETcwIWwxmQhe8Ygj4zonH87geIquV1ctyMzVl5dRE+ 350715Jp3Ahpl90dSJMTpdhzPrzCfE9nWmiUQcO7RafA1ZzHOTfb+KUb5BmEuWpSLJcZN8wOXYo8Nf 350716icgszkfKgeHwEWgasGXPlqNlswXKb5EkIcxWJyHkMiSEyb46SQhGx8qxQZPR+5BSIvv/JxOp 350717lQ/548hExH5g23IREnKr6y87KD8Nmyn5eiv4NPOhMh2s225BWr4JzlOJSlWM6z4EJ19e/ilk 350718Ir3fuX1HRL8QE9e4Wf/X4NkjdHSMVuYmpciVuBvz+jeDu2VtkiUf/lNuoEAm/yVkIk3gzQUD 35071947JQ9f0GJvjoB94oYrOrAmD4C8mv9qCzLRloJjNyCcM+fjjcOOSafgCvH69kgDIO3Ede0Tmu 350720qi/HMMRDjQTK88DQ41/0qtVR63fCbDRSZKNat8SaJ6UGVRQrPxxAfzfmGgI/jDtbS67Z2Bqi 3507212Pc779a2ZepAJlKS7Ez4kWuMTluEADvv7J6Hge0awc3WAjyO5nFUac/ac9RlEC7kMmVA8y4q 350722lQ1JYgEZkCDJ7guYzMoG9t1x8FOVHlL8I8xvpJhPg6lAR+1zKr954pyLmggMjpEfOBsPTJEa 350723VyfMq48l9zwGOhtYXx374ERmjfZ+wBAqfkj1jW8FKwGHAgG8BsYgpVRmVjZlA8e+OJUlVY5j 350724gJOOv6uvPTru2ej4xE+USQwNnPopz6upwKNKcDBvzpgxF9TPqyNTVl7xUlmeoAHfBe3GLEJ0 350725TCzO3XyOLyW1SkTUF5lIXo0vh3vDkbpmQ8wmnTtSDaCNlRaISpY1eKEoZ0qVjS6gypnxLQLQ 350726n7A/bSm1tkzkXh0FDw6tEDHySoHG2iRJJyXJNde7QYc1Cb5kIGplGA0U2obvwjuJBO92dqQV 3507274azaYGNqpeGAGGHztVlxhyoJp8q8Lsabg4PhyQS/7Lv/i09VJpCJ1FUXBQGYGPcBpSSIVpSA 350728kW4mrGFuI/9YMpG56zD7SRDs78f+fuzv98vJRDqSEMl9d55i3yX29EPX/jYPF9OlOqOx7w/F 350729dTMS8SQfaD+A8qE8RuBiri7Fmgp8vrEVk7sEwk4r65suq0aqhpD+2Gh3Rq2FKT1aI3qN49Pp 350730THp+4BxIs+MQ6Uz7FpY+4Rg+YzHW7SRshTtvkKsoX0sGHcMG4dL7BNq/c+yPs7kyHQFRhohj 350731AuYjr0jDzr7uEHBt0XTiQaRkv2L+bY+WM47idYlUS3nhh8lEYXTCpbrKNzlum6Ah2HArh/KV 350732zBnDj2BRZEJbVvo7vHun9kvPohLlPvw7Cs087WDB5YBn6YLGXadj31ORXuyN69ITManlWr6b 350733uQQBKpHvSzLObRgIHx/zyETyqm+4NDOYVmjgkEScBOQpSuzUlOBz6ku8fKn2S/2sQfaoLs3F 350734l/RP+FZYqTUOafErHJneEvZcATz67sLr7BT8O7EpbJl/a5KJBuB8bh3JRJSPZaE8j6KEIEmK 350735f7+LsRsJbCFgRhKKFZgclfBLrx/WbbUVrWjy3yRG0aeBwfJmUtEjRHd3YYiNlmg4JhZvy2rh 350736BmZihr/yGDIgnL6vKxNMtEfEIbLqQDU+H4xQlReL+aBpo5PY6VR/+pxkCXeGOFTyQEH+4cBl 350737wCmlogR9b3cxk7k3yn8i/Q/Cj1H4tGSm+131RBQyeYaM9TSgA09zmcBTXXBJjtd4o2sD+8lE 350738xshEd5RKYrrJRCSmWYLHy+jScoKGM5Hw/ir7yUQmXk+xpioJRZR/rEkk0o4fTkOSqBD3/+4M 350739Z9smmHrmM00QVk/+ZGJv/yUykak4qEEy0bcT6K2PTOQ3CFEDfdUUdwRwbTkS6+PTleXHTcUg 350740FftJ0btbOLptFaJmTML4MaMxekhneFlo9zXnvLKKz7ixbQb6tvSHs7VASwVIo2/ZR8RHT0RE 350741qA8cLflaiioa91sjwsvT6zCpZ3P4OVmBb+Qerm+dht4t/OBkJdCveKiFe86hcE8N3NWhB2K/ 350742VOv1AxRYKt85DF1790Zv8hfRBl6WmlhqXfsaw2jNxnN/NplI8hY7Otio1oqNifhSWoWqsly8 350743jpuJJsqqJP9oVSVpYBOOfz7QGCRZwSSU6evQiyGK1cJN44zhpj/Y/9Tv7m+OH6A+Z51IrJpU 3507448EzCX51c4da0NbwVz73DDq1z/z+QiczBYc3ByxU26pxGAoZkdAm5hE+VvIgp22kfgX/ViOv6 350745yUR65Ip/1MFTBQerIXp9GTHLJqFfay9GmlShSuGIrptT9NwXUyfZ1gejz3xDdU0Ozo/0BJfr 350746jK6rjuP4qi5w5hIDH3FOYxKR0oek/BOpVHRB4ZARY/Ns1xn+5ILFdcOg4181AndGyUQFKkax 350747QAeZqL6JGYayT2o3XQoFGmXOXGuXOTtSr2XO5LISvNjZF+58GnzxH30Y78uNSPMT71ZakYeU 350748I+MRyGzcNu23Kp1HBdOO5zUE+++/RmpqKlIf7VNmafC8R+FYcho+ZpcZDNhSJBWlOstEpRqV 350749+nwh/66rrBhF3tFBGqHkhEd70Zsz1xOjLuZqZQ9TpTEGudF9hEGYeT4dpRIx0i/MQpCQZgW6 350750DjiGr+oyyoSTnZMUg+kRwXC15kNg64VWQ2djcks7ZZDcUNk43aAPA4BRUmc+aD9yCXbHP0d2 350751ueynBEhkFdl4Eb8HS0d1gC9TwqqB+2gGoCQc6mYecHd3h3vIRFz/rroHybsd6OA3EBep7/Yd 350752vRETgcu4bKnyfS0k35fauiJOXoAm/uOZzD1irbg5BX6KoFSnLbibRoJKb/FoTx84c3SUR9LD 350753/KwWZ+L+jv7w4ClUXBI1JUxtOuKfHy1z9myF0kj4eWXOXmKdIghq2xl70iVGA5+/sswZz7kF 350754Ipo5MkYuB/ZtluFWXk39kIkIw+3TwR5wUK6fDuhx8BOqTBxDTdYZjKBKvVggaMwCdHEyIAls 350755X7cyZxoEIp4Q9l5N0XXsGsS9FFHgmLzsBVYxRkMD+x44/NXINRiCrFEy0bgDeFWq//uXVebh 350756bVIcokeH0HKyOgipJpOJ1EmtpIOttqeS68E0JjOP4zleY61VlwR37ncMzy+NhRdXvyQ4pezW 3507572ZZ5Vl0RvWMgRR6y73GYWmOr0vehix1pGwzGjnVdGIDODl0PZGgRhORVX3B8qAcDQjZQOnc8 350758z2E4+bWqzt+8plrHc2wMt1cqtIVE3UKB1LwSf+qKhAdqZyjWgUy0sgUdEOASgLuPvz/8Dfxa 350759TL6iww4QIWlhU0bmWI9Dp2sdCJiF+6UqMHkmox5J7hs06K4iCPD8Z+gNcJF73Sh3I+dUfPPU 350760vsgxbJcRdpPShjVEEjHnuvrGLbpOlSz4EedWt+qbE2FfP0OJTG4WmYivcW8m/N3Ye9U1PjWy 350761pCH1TEHQQi2SpNE5U9d3UsvuVwBkouSdGBFir1wTlMpttmGYceGbqkSEqWQiBrCh/35N69lQ 350762wZDssxjixqHJnNMTkf1yPVpa0lnbiowmZWLH3enw5zFZz3E3sY4I7nE8x+BswgqECbnwnnAe 350763V6MYgqZDLxzJrNFeS6b5K0E6fsB03KqdmU/Yp+l7mbrcwmZY/eAptrW3pu2tbiqivmodzUL8 350764nKaM/2WFkNnxyKrSF1TmwSFsNGKeairx6CUTESBg/t0NGBhkqwLJKIWCW5gZOQv7br9DQbkE 3507655fnvcf/0Nswb1Bb+jpYQ2nmj9dDlOJEi+mPJROauw+wnQbC/H/v7sb/fLycTiVRqMIJG8ylQ 350766ktx3FXYVuZfeuK8iT9RuivWP7Ku+76k3g2XObDtie1ql3nNq/Bo00Pz/OgNhhO9f/BlPrx7C 350767ysGNYc34Pop7U9oOHAeEb0imS5tQ5ZfnUKqoJDBLJtW93D0Cja05WtcVePbCxmSRskTYyqR7 350768tIQ8zx19tz8gMJlqVJVkElhXPmVPkMlSbRVlzvSNq5YNIwiYgLiMSqWKt2XwHMRnGi9vrnwG 350769zHGK/Vbndcl9VjGG52plzpz7Yvv6nnBx6oToZ3QAUX0MP9p+lrK75MtJjPJhbDaBL8aeztSZ 350770NKL+LNTnq76/K5o6gcgUMpG8JhcJi1oyvrcQDSeexhcTqwUYmyfKMWfGY06w4lnKUJkRhwkB 350771NL5GkhMUSieU6rqhMmfOg3H5u+5701gLAmaqbHAyuzp+EJx1fZdqP13VA7Sur2cukAppN2cE 350772MglJNmgWdQXfJNrfu9mY4S86hjpOTZ2UVEZedOUVRZJ7dWURwpjAqw1D3FI0WcE1jPdm1kv7 350773zthyN40m1j05gmGezN8de+EwExjWvDcu3AceQjJFxkvGoYFMaWeeH6bcFKlKjn89gr5OHIPv 350774Tt96Tl1THUu1aon1rypMntMGz/sH9avLWqH3GGNlzt7/owzAWukqc8acqybnIlWCklLomroM 3507753esL0/wNxykqiHDcR+opc7bWcJkzM66n+E6Kn21Hb0XCDRG37Lj6rmZiTNlzrFComds0x/jx 3507767eBkG4wZ574ofXX18yvvy0yM9E/rX5fvRuc3o0+hv1bf+7mfkLBjOrr5q5VJIpOfYjPMwyDl 350777lUiPZZLUjfU157ykSo6yHKexvsQ+NVOhpGKsbymerm2rxOSN3UOikXvQ+2NwT3NwV8U+b/Sc 350778f0Bfc9fsuqzbmlVBiLizmv+jLuahU0jAZagyXq++XlCxjBp6rGbhpv/v/c3w6chzq+O+ie8T 350779sKQtgaNFxuDFp3gMMXBuY5jsn9CX3otMw2HVz2sML6fPW4FX61vSeC1hIx56eYchlHPgOjAO 350780WWp7XYP6cLx+xFlXOlZ+A3E4Phod7bQdKfUmK0nGqhZ28BxyHF9JI0LBwHYeRJEOSIYVmflN 350781lvDRYLu7ROK0goQg+Yy4SY3orF3qJ4DvqBP4rItAQxgbivpwimsoWlXGfnRVlDnrpK0EUN/O 350782sD4nXqsfqeJABgms22KLGrAil+Xj8kgPerNlarUrWnHSbAQytZobzn2gIftqtiEtK8LTbb2p 350783utyU4zv+OD5WmE5UIY2TKb6040qW8VJMbNMyqIjA8mz6/uk64jqyu9TJRD5TVOos0mycjnRW 350784Lva6yET6AuiSj3vQlSFjWYQsxmMdgXktlrriuurGGJNFYKjJRImYTcn6kgGlOzrraht8vqSB 350785lv8a1/Ytw8h2KiIfz64Ruk9ai9iENBRIZHX6vpX3KClA2s1YrJ3cHY0UJd04lvBqNxLL9l3D 35078663zjYBYlD+43CPEFMhWr1wCZiDLuFgTDgSFYyWUFuDrWyyj7mlwb4r7VGJ3jmhkES4jnKMbT 350787FaHMOiJE08VJyjJRmt9DjVaWjpbxUZONCxP8lLX5G0c9oudwfTu5xD0nLwlhDEorNF+VrBFU 350788/t1kIvJvSRl3sbqDA/PeuHBovwp3C2rqxaGXZp9hgrFkndShOJstNXkMpKORtj2cJp1w+cp5 350789pfrvJbg/TyEBaofO/7zTkOQmZdOfrG7GOB+WaLn+lUFZRd1rK+EQTGcCvASA3X3fx1pZaOrX 350790ECJs1XOqLrXWNUpqIM68j12DvJn7FaLJ/EQUKsqcSStRUl6j45neVJYD06eKZmw8ZG19paqH 350791bRfsS1eRXqrS96KLotZ7i7+VdVoVe+VaxXH2YejX2oV+B4IgRDHlfWrP9SdLGBY1xxqe/o7E 350792c7NEi78Zac2yZ7SjL3BCgAfjhDKS3prnqcLXk8MYpQyyxvx2XNwSASeKyMSD14hTyKz+we9S 350793Woi7i8OUdcHt2q/H0xKZ+c+WWNu/3xgPb54DesZ+MVnVSPHfagexJV/PY0aIFbg2zTD/SpZe 350794FSa987X0Hmb4K4DMjoi+l41yqVxD2UbXOkCy5nUpx+hWJorAwc/6MmRINRqFQpBxZSJFdgQF 3507956lTpWstlKhU7k5WJhuBSnkqZaJBLA5PWy/pwbjWcB5eW6KEgavK9MGhfmqYCaD0AoD96DtMz 350796ZrbrVCYyPGfMmAsm27qVyP/4FInxx7AzKgIeTHY0mUGdWmnCPFFTzVFXN5Skq9QTNJ4ZYdNc 350797m+BDEZh4vsMRPTOMXusdemipc8lyL2AIpcwmgF/f8WhjT4IPsfiSfxuTiMCQMLAvhoTQDqd1 350798u60awT0qoHBvKZpp2NtWaLZU28aR5sZjtBePskc9O0SgIXkMxwWRp75pZIfLawpwZ0VbRhXU 350799AgFjTyCjdpZ5LVtT4N4ZyxJyda5j2mQiCb6em4PWTnxNMEEmRbVUZqLv8WeSicxdh9lPgmB/ 350800P/b3Y3+/X08m0rGnqyexOfVH7PV1P0QmosqcrV+O8c1sleXT3bvOwup167D5yBMUSuU/hE/K 350801qsshluiyvel9U4FLUWoPZCms6HDYU+p+Qnh3HodZ47sj0IYLjhWpPvBVeXxNaSZS7lzC8X1b 350802sGRkczhw6es69j5Gg7bRHRA6PR4P9/SFC1fz3txGJhD7biFuz2mOjhveaPmNOslE0hK8PjIN 350803ze25hO0XjsVnn+NxLP1vvltXLI/PQLkJ2JHJZCLlGBJQIFaUORuGa5/uY2GwELYdt+CNWHMM 350804fyKZSFb2Gju6OzH+vRXCFt3Bd6lx/05d2UKWf1GJFZlDJtLnG977qyMzX/jwiNyHtDLZj+Pz 350805StysHBnxy9DVjcA07FtgeuxjPD+7GOEuPPrfR17TyjNjFFgaD+4D/sX7Cpn5ZCJ1tQDnSJxR 350806Uyb68E84o0zEgdA1AE2CgxFc+xcehfsldSQTETjrVIaEyPUco5G4SGHFsjpihr/oGMoOTNuK 350807dtZG1jH1THS5FLmXRtClKgxeyw7d9qVTdiXlY4zzNnJvPHiPv0YpOJPv7u22Dsy7qyOZSANL 3508085cN7xHF80hFPqSkTUfgB+8lEBnxKEktaGKLEpUNXPNUqcaLCLInvbnd3upRjfWKav+O4ucxx 350809XHcMiaul6C0rwaNlivllhdYb31Dnrfv11IhEPBd0mjEPfbwEWoQiObFnJ0zyVSUhWjfFrIuZ 350810qgR/jfNbo+0WumyMuRjpn9b/R8lEetdDEkN8Ltb/XVQXIiV2nFKMgLRZzMIg1ZXzjPU157wl 3508115vRNwnQ/E/uWPlCq25lzDxyHztiSnA8JgWfmXxzIkHgt0fyvFJ1lpBS4Z23c9dBn/cpEpmKp 350812P7+vgIhp31MqHdbGy+uyZteJTKSGP3JchyoxYfobUnEJFOqL+mwanWQik5V9tpupBLTdTCWj 350813X9PfLB+BOPcSxbmtfNDM3xn+Iw4iTSzTPHe7bUgj78UMTPZP6GsODmsOXq6cm58OMoItVmjU 350814owNdaYrnjXFXNVUz9SsTldxHVDhtwIf1iUZKmQlOJxncJxwFsmxIBvGRl6iXPFPfoEuTET1r 350815CWLO3UPqNxFEKaQzNRwXHh9Eb2eO0jHTXiTEeL6uDezd+uNQhkTTQSACNpcJ50D2/QrF3CLJ 350816GmQJpUO9HBnAQQDvARtw430hKiQl+HJ7PTo5cpRM+NWPi3Wq2ciZUm1chvG1JkVFwClJYjJ/ 350817iXMHLTCs3lQXZ1hfloqxjZp8D+THQ26krys0AwSFt2YiUMAY7EP34XlBBcpz7mNTBBOYtWyO 350818Nc/FauOvgriIeEci4pdxhpFrJq7jPxXXM4m/FYlRpR6QkoqQvKkHXHn05AuaEodPlXK9gfFH 350819W5ciOvYanmV8R3m1FJLiz0jaNVjJDFaXrDSbTEQ4wJfGtEfvOdtx7nE6vpdXQ1KYhnNRLZmA 350820BgcukSp5VzKzOecc43iRZc4Op6FYUow0ZZkzLjxGXNDIFFESNJY3ZQxVwiCtJTOra4NVKBOJ 350821JWJkXJyllLirrXAlr0jHlTMJePWtBJIaCYoykhAzqiF9LetW+PtFWZ03Q/req1H0IRGH105E 3508221wBVRrfAJQz9F57Ax0ozWaCVH3FiYX+EuSjkBbmwDeyGSX8fRuKHIm3lL7V1pjZQICu4jOE+ 350823wVj4uJSW/53orSpzVvIdLw+OgK+AJvmdS03B2VVkPXortFybQhEopEQwbbg71wTmtSN6H6FV 350824yfSx42s0lInojYfKyMk8jdGKDDa+K7osPoHkz0WQVEsgzvuAB3HRGNuLzOjXdW6yvm0xvr28 350825ih3jQ5Wl9xrYtsem1+U/xcmlNoevJzBUkZEk8ESvVWfwLJOcX1Uo/XAKI7x4v5VMRGXMEAHP 3508265W0VKi1cOIb/haTvUm12rUckdl1JRGKi2i/pCTJKpbqvJfuOhMl+hHPHg9/kBIo8Y84YZKIk 350827RDWx0AuSSN7vQU8nBnC2bY6Zh5PxTVxFrGufkBQzBo2YzBie1wjEZVab/e4oMP3VRrRXyPTb 350828t8a848+QpeMaXOc++JdRntJ3jZqcC0xmEpk50xYbXqnm3ajGTREZ9Q/OP3yP3FIJaiSFSIub 350829oVyrFMaX+YSXUiQvZkg+pOHTezVO3n6ER7dPYnVvT4ZQZ4GQJckaeypJ5krd1IYh3Kh+Fk2X 3508306S7LSRJrro2my/gos1V8MTmxSLn/JIzXBPToEmiaQG115ikMZ74JrnMv7H1fSaxzbxHTgwGc 350831eV4YWQu8MMuJJtbg7IuTEcDseVyX3tidVlHn71yWfwWjPYlvps8xZV3tupKJ6IzVC5gZYg2L 350832hrNwq9A89ToyOKWs3e/YHbtSRKgoTsflpW3pAIw+MhHHEV02PkJ+WQGSt3RjiFtceI5m6vlq 3508331EHmwytyC25nFBPrbjkK3ifi1KlnTO3uPMSP9qTfE4dU5HmMAuKcqhrB6qB6EZIUgJTAF8P+ 350834ScKXkipi3pcg5+19nNsZhQFdpuKmKcpEJHFbAb5zndB9SzJx3Xw8iO5EA3e/gUxE/u3uh+uI 350835CmOIcxb+GHs8XQme/RFkIrJ29ny1Wt6zTyNNJEFlQQoOjfZX/r2VDiKm8TljxlwwtoaJX2Lf 35083639tw6vZLfCksR7VUgvxH0WhroyIbK9YkedlTLA1h9gybDtiWUqoq3aseaLVqTvsh1blIWBCq 350837XOc0M1BkKEqag4YCemx8Lm3Hug7SzBKh+hL+z7+K0qUcIripAEOl33CqryP9TTJrbZNFmmtt 350838Td4NzG5M35dlk3FYProxbXNaBGH2jXxNf45Yzx8r13PFOjoWV/LVyyAU4+nm7nBWBsT2IlWs 350839ey2R1ZTiQ9x4+At0Awh6yUTqgIQwGPMuf4a4Rm72evUnkonMXYfZT4Jgfz/292N/vz+CTEQE 3508408h4uaMLsD9YI6tkVfr4jce1bLtISTuD8+/I6JMUQwbxHK9CcwYN4zp2wOO4ZvpVIUFUhwqfk 35084104he/A9SxObb5FXpB9CrUWuMXL4P8cnpyBeTNqAI7y7MRyhzPUtG7YHGvIqQciwKXb2Fqqx4 350842rhsiD3+icKDqvAc4eeoW3uSWU/smee+Vb2OUoDApr0+Bwfk3MCs0BJPjUvAwdj56N3WDtcAC 350843dr5tMG7PC7w9NxWhzeYgIV9qVuKY+N1pzG/nBB6jOKP5b/PJRIaacgynniLpRAx27L+Mz5XV 350844yH1wDDG79iF2xzizx/ArGxmIT1ranFFBIN5zyGycTfmI9PR0zd/nXJTVLntkEYhJZGlVSRFe 3508457Y9UYkUcdwLbzhTXiUxE2k3PtvaAC5PI4thpPR6LpD/B5uDBqd18nH4vZhSs1P7N2Hrlb3ag 350846qwIzJ2w41/aTsfFEAh6/fIsPzw6hN1NCiCS2739a63mlf0FeuYzyue/OZvw2ji1aLbmGz2IJ 350847itNOYUojJmmXsGedum7Co4IqteTEQqQnX0bc9U8awX6zyETqwV/rZlhwMQ05Bdl4//AMNk4Z 350848gb+SxXXCDH/VMSRZ782G1lr4h/ZPLWGqJgunB7lqlcnR9VOoocvy4jHKw/i9cT1HIZ4IRpF2 35084997Km9Lsj1Utvi2R1wiU1sNQGQvj0jMLeS0l49jIFT5LiEbt+EsKbjSXwGfaTiXRhD7IqMXLT 350850bmH/7PZwYtYevs8YnPlmGGeUlTzG8jDLesU0f8dxle93I4JRxyLtgaVnXiK3rAqVoo+4tX0Y 350851AhjckqxgoXgmdb2eikjkih6bkiGSEvvqm30Y7K1JKCL339InK9GMOQfHNgzTYpORqeP8fN/x 350852uJhTUyeM9E/rX59kIp0K/ern8xmBA0lvkU3YfjVVJfh0dbEyCYr0o83CIIsTMcGLY1pfc85r 3508531j2Yd94pdThvA4duiHlVBPG3u1jfxUmJgXOdO2PFpVTkV9SguqII31KTcHr7fPRncE+duGs6 350854cc2KYmS+iMe/xNwulJmHpf6KvhzbFph19AkyS4m+VeUQZb7B3bjNmDZ4LhJ/lTKRrBA3FUrf 350855ZJnaqPN4VyQhYtKvcWyyQtzEEs1Wv9BKADdKJqqFmwbPOIXXBWUQ5z7F/hF+2rjpD/Y3isv+ 3508565P7mrC+k//lA6X8S2GyjmbiaXUmc+wUOapxblWRuKib78/o+xbIQ03Fhk3FYM/BylU+US+Dm 350857mnEyfsPZSCrSxCAbmAMKGGtUWSIbIZqtIdmNFXgd3QpWBHi+453ETAaqFUIXJWmdv+zVFoQ7 350858uKDnnveqAIg0H1cn+oLP88TAmFu4vXswvPh8+E68SjvSr3ahrxvPqGHM9xyAmJc66ngS58i7 350859PBqe1IO2RZe9DHtfXo6Uv5rTjGJBY8x/UFLvmTV1JRPRNRUt0XytNsuUlMu9OjdUKdes8eM6 350860oOPahxqZx0bflYGyDcb6y2W5OD/ASX9fiwCM1yMvbNoiYvj8PNc++OeNZkk0sjRO7FAvtfqr 350861av3d+mFPWrk2gJJ3GeO8eUoHS1cNfnoulePN9q5w1JclwnFAl62vqY3E6PPkuaHPzhSU1lFZ 350862QDeQIsaXR3HYPKsvQhz5dcr2UlyP7xiCvrM2I+7RF6pGvUlZU7XnUg0R9Ip0h+ego/gsIYzy 3508635FVooU4m4wphI+RqEMnce23Fs2J6kcuKi4QLh14gvcZeQb5Mk1hXpFTjIqXg9hssOaX57D0x 3508645OhnZeaP6OkuDPYTGp3zJp3bsiFGx75V1vo1eoxTJMUuNes9y2vw/cEm9PEUmJSpWb9kolql 350865bcT6+1fnJmBJazslocipy3o8EEmNPxNhGFa9KDPd8TdjDCTxI/PUUI1ML83/XoVvlxegjQPX 350866wLrTDX8nFehkC5uy15KZhO9iRymdY50ZHNYhmH72qyoDRu94KvF2ZyemxBcPnsPPUEFpo89Y 3508674Ifx57LqTKCpzonHjCBLvee3DJqB+BztrAd1JrkCONO1zymv8/kQutup9Xfsg5OK7EDiO8g8 3508682lOt7J2qBJpyLNWZiBvpRWcWcZ3Qc7cqc6ny3W70YEAIPgFQnM6srpsTrZ61Yoysacr5iH3v 3508690nB3wjEcgLismh8mE1HPPfsJkt6VGCwfqntPycf1qf5a+6nQPQhuQv17FcfKBe42ms+EY9ce 3508700S9U4HZ1zhXMDbPRCZQ69D5BkYQpGzBlAzraacrdcoT2sLfgaO071dnxmBViZZr9YohMRF13 350871I8LtNa/Ls3GHixXnt5GJyL9JMk5irD/jqFg2wYwLdKbcn0Amotf9q5gXaq0HAOfCocMa3Bdp 350872E0s5Vq7wsNU/Z/TNBXPeiWl2rgWC5t9V2tGaWd21s/nFeLqqmUoqm28DR3sL8CysYcHV857F 350873TwmnVM3e0JElQs9BUimglSr4wPPH9KRiWmFvaztlwKwB1xsTElQlC+TVWTg3ngEUrMKw9J4I 3508741aIkLAql12uB3wScz6rWWpc72arssIazNctOmutHqJeQ5jecR9kJRslExN+HMyV2yHI6SXUg 350875/fzJZCJz1mH2kyDY34/9/djf708gE9Hk1AQsbKHDVuN4YMzNItN8Yy3CdjneHx6DQKF5ShjG 350876yUSqLGGdP64zetdShKX2rPIvSFjXg1HkJpMt6AxjGhelbRdLRw/4+LjDlq84nw3aRr9U2oyl 350877r/ZiaONG6LcqDo8/EUGaqgqIviQjbnV/NA4ajv1vxGbb4PS9ZSB+6y48VQSQa/3bGCFJJq2B 3508781AR1v585BlPVC/QptpvSVO+qgdnYiOaPA56Ap5rvte7HZDKRkfFat9mkVMCss81R+hS7tsYj 350879o1ym89/qSS+5N1dRCkZml0nhemFCYjFt32ddwNTGun1/jpU7fBz4SlvYzS8Q/t4usObRz9Rj 3508807C0U1ZVMRCmXh6hVJFD78Rth3iNxnTDDX3UMpcysKMlk1Rob3miWc6xUUy0Shq2i7MfqzGPo 35088166QgUYzHtVrln+TiZ6oyTNZtsCm1EjnnhlLl4BVl1nLUy6xJc3B+mDs9rzluGHo+F4U3p8Kf 350882zyQlLHykUdXA6PeqpmJVr1iqDlz0d/X76WQiPT8Ln0jsUCsRrR8DrEHupXHw4dUfpvl7jpMg 350883Mz4Kre0NHdcd6+rhekci3cAliUSb6dKmSswndT+GeAvAceiC7WkVxJpThnekjWItAM9AKSqB 350884Rx9sfizSSNIxFyP90/r/CJnIaAxDva9zEIKc+TrjyM1WJJuHQdYQ69toL63S9Tr7mnNeou+1 350885Kdp9LT2awF2rbx6ukDHtWvaEjV8zeGr1LcCNaQHa9+DaEK4WtfvmIn6cj9bYSLWsMYvHI8yG 350886Y5LtbQruai6W+if0/dlkIsq3+HYB0/R+QxzYtVmBuzqS5o2RiczFTf8L/c1ZOyRvDdn1xLk7 350887rsVDBaZsBib7M/s+WRFmFi5sLg5rDC9Xt0dLHkQhyKKBkugduvypFmm03shEpCGYfXoAnHm+ 350888mJJIgAM1mTjaywGCJgs1lFZosPo7np/djkXjeqF1QzfYCBg2sdARfq0iEbX/AXJryZfJK9Lw 350889TzcnOHbZgdRa2THSwmTsntQBvrYCCGx90H5iDJILa5QPovJbEvYtGIL2DQmnhM8lXogtXANa 350890os/0zYiLW6isNcz3Gog9r8XajnjxAyxk1Cjsuu5FukSuUXLFuu1GDQWg+iIT1WQeRU97Osjr 350891MeSYyQAORXIShlK1y3X2J57/s6NLMax9IJwJI8fCxg2NO4/B2rOpKDFXIvpHyETyMrw9vgyj 350892e7ZGQ3c7CHkccC1s4EK8m14TVuNocq5OhR+TyUSEcZmVdBCrpwxA+yaecLDkgyuwhnNAGwyY 350893G4NbXyo0PhpFk5Wl4+rGCejSmJgvAgGsXYPQZXw04tPLtPqThmj6/ggmIE0ysx9rOFO1G5nF 3508949iruL4zrFgpvB0vwuDwI7b3QtOtYrIl7CVHt51+ehv3TeqC5nxOs+HTfsN4zsCPhs6ZENaBb 3508954aXWHPqiQxZQV5NV5ODFrSRkmglUyCszkXTrBXJMLGtnkExEZh8+WIymVg5ou+QacS/lyDi/ 350896BL0aOcLKLgC9Fm7GrGZ2sHLyRbOIsVh5+CFy1OTJj/Sms+/J+t5Tb4m03534sUrS0jYc/7yX 350897GGTH27k3RrvIOdh5I0NJ9lG0GlEq4rfPxZCOQfCwtwSfJ4ANYdC16TcVa48lo6BalwPMoTYH 350898Bzc/hLTrjXFLduP6+xLNrP+fQCZStKqCFzgdPQ392gTC1ZbYqHgWsHHxQ1jnQZi+Zj+uvS6A 350899RFa/ZCLJu53KTd1SUY7OQP/qnOtY0EIhZ8+Dc/eNv5VMRPWveIPNHWyhD7Qm523Z59vYu3A4 350900OjXxgD2x7gisHOHVtBvGrIjFw6xKjblYl3dHAgCil2exYXo/tA4k1im+yhHgOIRjQ7JI7zzS 350901Kt8nuoO5ipJMxLNbnlxK7BH5SI7bikXj+6J9sA+ciH2CyyXWQmd/tOo/G7tufUWFTG70mzY0 350902nqr8ZBxeNpJ6RnZCPvhCO3g06YSRyw4jOb9K97mr0rFPobZB/tQkvXX2p2qpq8Apq9Yb8UZt 350903Tat4tR4tlQRFVUafomWeHgVvPv2tOkXE4G2F+nuuxLvdPRhGNx8+o8/U6VmYpfxmktKRlAAE 350904B8OV64pBZ3NMuhdjQewfadLiFMTO7opABwviO3BBUMR8HL93GkMMOm4zcenmHkzu4EvMDWu4 350905NR+G6IQsLXtAWpyKc9GT0bOZDxwtecT+bgP3oHCM3f4Excz8JPfo7FsbMaKFO7GfW8G16QCs 350906PnUKUwN1E4FqRCmI+2s8uod6wV7II4ICtE3SY8wi7Dj/AoUKJUMDZCLFdXNub6KvK7SFd7sJ 350907iLlyEqOUJVNnUCVT641MVKhWT7nRfLq0lx6lPfHrGPRjSPYcmxZYeCP3jyET0e/gFU7/PYF5 350908B8TaYOkAn+a9MHVTPN6L9WW+zkR84gFM7+RHHEPMmWZDteaMxlxQvJOES5hhxvpPnUfyCRei 350909p2Nw5zD4OVtDwCX2cksn+BL3OG3rdXwu17R/JFkJWD+8NXwJh7B2gEkmfotTC3qisZOQGKcT 350910Gnaegpj4Ixio167VzFDmB87C3SLd9lbpw3lopAhcOkfiLFNWQvw4Co0Fir8PUJaOJduno0OY 350911rHprtFz5iPqOqADHwxVoYU3vw55DNf0RskzrmaHujIJrKFY8E5u3xhnwIxTfSe3/pk0m0l1P 3509123Cz79Q8nE9X3ONjfj/392N+P/f1+NpmIstWKXiFu9Ui097Oly3RauyOk23QcfFdRJzIRvRdW 3509134/vzE1g5oj387RQkBHsEdByFVadStPAUU2xymTgNZ4m9fUAbf9jz1e+BB7uGEZj97xOVDViZ 350914gUu79yLu9ktkFlWiPP0o+rswme2e43G7WE7gk4+xN2okerYJgieB+fC5XAhsXBHYZiDm772n 350915hXVW5SUjdtFgtPEnMB8LKzj5t8WQxbF6faI/sf2sMfxsMpFp6ue67USuU3P06ugPW8KP9e+x 350916FOefJeDvPgGwJcbv3nGF1nX+FDKR2e/2+0tc3B6F4V3D4EvYvnwiSM4h5jTX0E/gi8l3ijV8 350917/9jFQ9DW3xFC8nuw80arwUtxPKUQpRlXED2mIwIJe5i0J7lCB3iHdMKQWetxPDlfdwJTUSIm 350918N3GGszPxazIZiXpKxskqvyJh6xREhHgQ74WIBRDn9gnrhhELdiMpt7pOmOGvOkb8bAVClarQ 350919W7VUoeWS99jV0YY+xiIES5LF+HRQgU3zEThTM7Ck8CVUCQck/kH4vpEutI/C9cLYqwWaWBXh 350920BxRcHQsvRhHVJTIOZ4a40f0tW2BtSrl536uOknjaWKoFbIkAfcch87Dt0huKvMF+MlFtMhGH 350921wM9s4ewdhNY9RiFqRzzeiGpM3vfkkg/Y3d1B6Zv+KKb5W4/LuIU9C4b91OtJC58g7myKkkik 350922fh7xu3icSMqh1qmylGi09WiFRdc+I/PxUayZ0JOI5TgTOBRxfhtn+LXohUlrT+JprkTnfZmL 350923kf5p/euKg5pFJvLoinEjuqGplz0RQyT2EmsXwrYagDkxd5HFrJGmYpDU+kPEk/dO7QR/e+N9 350924zTmvtCgFh2Z2QQB5XmtXBPdagLiHZ3X3FT3FvikdiZi2BSzsvNBqeDQSXl/SiW/ISl7hyNzu 350925aOTI4EddZuDQ7Thl2aLaY9szJZwem40HQvtGIfZpIWoIzLjozTlET+6JZj4O1HPkEZibV5P2 3509266D9pOWIupihtXlNxV3Ow1D+h768gE1ExrcIXOLl6LLqFeNLfEPGcvZv1xJQNF/G2VGY0NqqP 350927TGQObvpf6W9aTPoddvfygE+f5di8bAw6N3GHjYAHvpUT/Fr2xYytV/Cx1rnNwWR/Xt80nJgf 350928QX/XVs5o3G0G9l07hkGGcGkzcFhT8HLVM0zFpjZWypjbJh0xtwZ/guNprGb0724kYPH1+CC4 350929kQa0ZUusIwzmoqS5aESC8Xx/TLmapxG4ra+We5HOEOD7jsWZzGqTjyNrlZNlFpLFcrC/sbvV 350930dQ79Md+erAjJ68LhwOXDuc14RJ9KQmpWESqqpZQMY/aHZ7gZtwurlmzGxbSSn/Idsr/9eJPk 350931vcSdS/sR1cmFYcbz4DflloYKGvvbj+xRNSi4sxLtKCUUCwRMPI2vEvY/2//cezbR4a7JisMA 350932Zy7ch12sk7PO/vaj3yMBKmU8wqO0PFQqSE1VBUje3pvJXOfCc1S8VsnUH7re87+VxDibOtSW 350933/i9/DwbPYYQUxv5mmsO+hwGjbcN3/PDckxffwSRvJlPUpg3WPcijiM3q71ydTCSXliPzRhRC 350934mGALScZ5Vvb/Ryaqt/fBfhIE+/uxvx/7+/1iMtHvxPvkMikkFRWQSGX1dk5ZtRiFOZn4/DkT 350935uaIKLXxBv0IED95jziO7hv22BPvtT8PfwJ+Of/9e/E/G/ofA6vdfgbSYAei+6rFGkJr9jf3t 350936/2P+liMvq0QnAZL9jf3t/35+yyVI/3cwIti/PrO//bFztAp5Lx/hY+l/35Y0hsPW1V+RFSYi 350937iiK3c+DY8yAydIiSsJ9MZPJLeo89PZ3BJUACn3HxiO1Hsvf58B4Zh8zqn3PfCRN9wBMGYfaN 350938PA1ZRvY39jc2zSG5VIRne0cjyFqfDCMH1k3G4dCbUp3sfva3399yzw2Ak9o747n1x773lex/ 350939MPVqNFUj98ZCtLAlvhOOHdqsTEKhlP3fw3/qHevKjLPthJiPEr3HlL/8Gy0sNY9hP5no53+L 350940X2IjYE/sTQJbd/gF+MHdThV0svAbiSPp9bP+yUvuI6qDP5yFzP7IcUTE7g9GVR3/a98D+8lE 350941v+H5k3MvvAkCXC3pbBhBIKZdz/9hUjcpyX1pjLemJLdFCJY+LdMiExXdHAMPDQl5CwRFJWll 350942YZs2nnuYHeIMF3d3uGv9XOASOv//Yt00dRzs78f+fuzvx/5+5vb7r+N9Jq+zkkxcXjcBvVoF 350943wMWKDy7fCi6NOmLk6jNIK2U/EYL99qee42rKIBKVoopUfVT73+xv7G/sb3RyjESUjYKySmRf 350944noyGjabVqWwx+xv7G/sb+xv7W/03WVUJvheXI/faVDRi//rM/sb+9hvxPtNwWLMrjlHnbQwf 350945B0XlkmBEJYl0xtnZTyZif2N/Y3/7v3AuKzLv4/CayejT0h+utkJY2LggsN0QRMUkIKOM/cDd 350946n9woMhHXAvZeYegxZRMufxSzn/j1k74TibiIACdFEBWJ2Q9Q/tfeL/vJRP8332HR0xhM690K 350947ga42EJBS/lZkGawemLDmOJ4WVNf/nOAIYO/fAeO33dEqncGG74H9ZKLf+Pw5fNj5dsTUAyko 350948qac9p+Z7MvZO744mrnQpDaNkImL+23iEou+C43hTIvuz1+x6KMnC/sb+xv7G/sb+xv7G/qav 350949AT/z/7Bf7ZX9jf3tJ3xX8hpknRkBXyEXXEt3tI+6ipxq9n9b7G/sb+xv7G9/QpPmnMNIXwtw 350950BU5oOesSsti/PrO/sb/9HnvJRBzWbDKRRmyhM2YdSYNYD77bgP2vgf2N/Y39jf2N/Y39jf2N 350951/Y39jf2N/Y39jf3tT3ec1cuc/V84+uwnE7G/sb+xv7G/sb+xv7G/sb+xv7G/sb+xv7G/sb+x 350952v7G/sb+xv7G//Z+2/wGvKLc/QracDAAAAABJRU5ErkJggg==' 350953 ) base64Decoded asByteArray readStream! ! 350954 350955!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:16'! 350956dejaVuSansBold7Data 350957 "Created using: 350958 Clipboard default clipboardText: 350959 ((FileStream oldFileNamed: 'AAFonts/DejaVu Sans Bold 7.txt') contentsOfEntireFile substrings 350960 collect: [ :each | each asNumber]) asString 350961 " 350962 ^#(7 8 3 0 3 7 12 20 27 38 47 51 56 61 66 74 78 83 87 92 99 106 113 120 128 135 142 149 156 163 167 171 179 187 195 201 211 220 227 234 242 248 254 262 270 274 279 287 294 303 311 320 327 336 344 351 359 367 376 387 395 403 411 416 421 426 431 440 444 451 458 464 471 478 484 491 498 502 507 514 518 528 535 543 550 557 563 570 576 583 590 600 607 615 621 627 630 636 644 651 658 664 669 678 685 692 699 706 713 720 727 734 741 748 755 762 769 776 783 790 797 804 811 818 825 832 839 846 853 860 867 874 877 881 887 894 901 909 917 924 930 940 946 952 961 966 976 981 987 995 1000 1006 1014 1022 1029 1033 1039 1044 1050 1056 1068 1080 1089 1095 1104 1113 1122 1131 1140 1150 1160 1167 1173 1179 1185 1192 1196 1200 1205 1210 1219 1227 1236 1245 1254 1263 1272 1279 1288 1296 1304 1312 1320 1328 1335 1342 1349 1356 1363 1370 1377 1384 1395 1401 1408 1415 1422 1429 1434 1438 1443 1448 1456 1463 1471 1479 1487 1493 1501 1509 1517 1524 1531 1538 1545 1553 1560 1568)! ! 350963 350964!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:17'! 350965dejaVuSansBold7Form 350966 "Created using: 350967 Clipboard default clipboardText: 350968 ((ByteArray streamContents:[:s| 350969 PNGReadWriter 350970 putForm: (Form fromFileNamed: 'AAFonts/DejaVu Sans Bold 7.bmp') 350971 onStream: s]) asString base64Encoded) 350972 " 350973 ^Form fromBinaryStream: ( 350974'iVBORw0KGgoAAAANSUhEUgAABiEAAAALCAYAAAAZZi58AAA7+0lEQVR4XuVdB1BT2fdmhoFh 350975MsmECRkyhKEMZWgDyKCiI/ZBAbGhg9h777o27GtbC7bdtaCuDcuquOuqrKKoKIqASlFA1CgC 350976UgRCh1CS73/fS4ckBBd/v//+cmcySu67L/edd8v5znfOuUaA4RfDL4ZfDL8YfjH88r9XqlJ2 350977Y9igCDwWig1fGIZfDL8YfjH8YvjF8EsXlNaKF4g+EInIn//E21r99leJuB6Fb7JRImpFbf5r 3509785HwVGb4gv7FIJGLUv43GD0t249j2RYiI+QiRRNL1vyNuRHF2DnlnYjQUZSGn9N/3zsSltzCh 350979+zTE5Ur/vS/UX06S5nKknlqL1WcyUSPW3q5VmIpjK9cjOl2IFg3vQdzwETd3R2DHnk3YcCoV 350980wtb210hqM3B41hhMWrYVa+YsxMFnFWhtcy9J5QPMc+eAwyEf93l4UKnhPjVJWO3FgHW/8ehl 350981yUKv7Wmo+x5jQ9KId6cmY+yBTNSr3J8am5WJGzB68Z8obJYovqt9FYnJKy7hwcl5mHY8B42y 350982NpKa59gwbjEi5/UET+WZxLVpiAyfgQt5TdLrWksQu2QMtiQKISZtJZJapO+fjGXR8Tgxdzqi 3509833jbqJR+tz1ObjoMzQxE+YwEWbv0L+U0aZCtpQO5vUxCy+SkqtYwH+llf/IQRYT8jQ8PaSNXX 350984pO7B+HknEHduKcI2PkK5pvFQl4lfZodi4pqT+P23fdi4aBpmb4nB+3qx7D41SFpLySwc22ar 350985y+7b53sLRI0ttHzlRZR/AytC5uFqfpPmNi3FuL18GOZGv0dDG5lIxFVIjZyMOZFnsXvmTBx7 350986Xad2b9UxzfNbh+c1GuQgrkHarzMxI/IxSpq7ZhxLWhtQXlyK6ibxN8hIhKqSEghFXYMrJaIC 350987xG4ehW72dvAMXo2r7+vbyeifPWs9vhaW6HxW6pkqvnxBeaO43ffCkq+oaRbrvV+U5KQhu6RR 3509887RkkkhZUCTKQ8bFadl0tCjJfIqu4oUufVf25a5Gf8Qpvy0QdrGNEH8nLQNq7CjS1HZviJlSX 350989FKG0tvm79bPTz9Vci6/FX1GrYy5IWmuQl5GOD8LmNnNV1rbl/8ezGKl1Tngf02xN4b4sEdXU 350990Ak//bQQjI/KxVd+4JcJHWNQjEL++FSJtW3/02/IStaoDrvopVg9fjafVKt+RQZd1agZ8eWzw 350991ey/EpQ9kw2j9inurw7DxsbD9wkRdf2Y+/O3YYJjboc+Sv/ClWaK1v/SmVZWMH/vYYcgv0g1O 350992UvsKO/3tEEA2Sfkm3FBWjKqKRLp/iRVVKC5r+L4DpjYVm4Om4GphC/13U9F97Aj1BI/Ng2fo 350993Dtwvlm2wZMPdN7YbrBka5E2Uk/3j/eBkyYAZ2w69px3GszLp/ST1b3B4rCf4LFOYsKzhM3oz 350994bueL2i3iqT/2BttIXV5q75j+8DAy+jOa5fVkcby/dyr8HTlgMLhwGrIFqTUSDe3Ix2464oUS 350995WjH5dGMDRnXjg2XGAt97JNb/+Un6PqjNOecilg92AofNh0/4Hjwsaf7/MbGJAhJJ5G/DNgPb 350996rg9mn8hAtVjyDQvEZ1wItSIyYcB3fTJqJG3HrExexgzwPIKw+poADXJ5N+bj7u7J6ONA5M22 350997ge/4Q8isU5e3sZk5rN36Yfz6S8isatX5HrV9L+1nGZJPrcQIX1uwTU3B5ruj/4wjeKP4vbZr 350998gfa/ta8fsr/J+Ms4MgZ2LHuEHctErVjzPdrJycwDyxOotUEMYcJyeJgp54b8GmPrMYgmSqrG 350999PlHjN3IGBrhwwSTj12XgbBxKKFZsNGryMWHBtvdMHE0VKhT/du0HzMLBR0Wa2xubgesyGEui 351000c+jnk25uTfgStwNhvtZgmZqBY+uJoIj7KG3VMoeM2j6fjncgEuDkMEuweu9Eep3091oKr2G8 351001DQOeK5/QCrJEUomExa5guCzEQ3LP1uI/SL0RLEecQx5ZS2tTN6A7eSfTYr+Sa0V4f2o0rFne 351002WHHvK1rJ+pu+bxAsOP7YllKF+qyfEUjWH7cFsSgh/W8uuIapjgzYjDkNgUjH88jXBZV6zsCD 351003yG4k3zW8QeSIsTglUCq3dS+3oCeTuk79XbaUp+BM5AkkdmK9oNYiQfQ8hO99oRNAattPOgfI 351004qpG4zB2mtvqBXElrGZ7sGA5nc5N2631n+9fp+ahH+/85o02zEDkpT5H6vlKjkeBf9SytQiTt 351005C4W7hSlYvbYhjVqzCZCb7T+bBqE1z36AJ8MMPJ/JOJZR02XKM62TnZsNbw4brhOP4VVla4dt 351006vmXeGn4x/GL4pXP7gEbMRfb0T3+sRbC7JRhmbNj0i1AYeSStVci4sBajfKzBZpjDofd0HM8m 351007xg+C7VYSA6Zl0DHkkn1d9C4KwyyNwOq5CUlVUkOEuPIVTszrD0eOGUyJHu/afx6iBSKFga06 351008/Tim9yQ6D9MSrsN24EWtXB9qRuGfyzB24TrMHLcVTyrEKn1tQsnTKCwf4QMbcyY49j0xZs0Z 351009pHxtVjHKZSAy1B2WTBZses/B6eza72fA0Kc/KjqNef9IvG4g63BrBZ7tHg4nnhvC9j8hxnuJ 351010/vhjtBu4LCv4LbqGPEqnIpjwp0B7mJsR3dJjDPY+lRqlKRmLhAX4KHiH9Ad/IeZmAjLeCSDI 351011K0Fdq0QvAqNBcA2rhzqDYyLtv6nHCrWxo2o8Kvl7DcLmrsWscZvwsFyGOQi2jpzaHw5usxSG 351012T1rfuroCA+zNYW4/ACsItmnU8/1Qxq7q0gLkCchztPl8Kqr9pj1b0lKJ3KSHePA0GxVyY3hT 351013GV4nPsCjFAFqWiUKI1RRTBj4zJ7Y8rJObzzX1dfIx/iefkobRvv3UYvUzT3BNDKG7cQYfNFg 351014TKKM9Ten2sOY0r9N3bD4gVDjPKF+a5c/u73OrooT9cCk+mBO/b83Am/UBeS3fCPu1KKHK3/H 351015GGbmNvAaOg8/Py7RiOWsRkXjc2nn8WSXXkPwecpvP2BUDztwGExwnfwxYcs1ZNeIO3Uf3cbv 351016IiQcnovBbjzSngN7v7FYum4B5v+SRuOlztoBvu1vJeZt/XINY62Y8PvxFW2v0w9zasE0ZO8r 351017iP0RYUR+5gR7m9v1RPiOOHyREUsScQPy7uzB/OWnkF6lgSgS1+HDjV1YuSUaqV+b1Gxpr8+u 351018wdLNW7Fs2RGkCJU6sLg6FTuIbavfos0Ybs1Ej02pCruoLntqY/ZBDHQIwJ5LuxFgwUD3Dalq 3510199tR/rreTZ/37Jyxcfw0fGjQ9ayVeRi3FksOPUSySqD1r5unVWLFlPRZvUG+rkP3kDRipNv8I 351020OS64gc3TVyA6p1ZGFjaj5MFPmLHoOFIrWuj+vLu4Cgt+PIiN8zfgBrFXapOPRFyNl/uDYcPv 351021hSkrIrDhp2hk1ogV+5jw2TYE2NohcN0ujLKhZP5CKXNKF3lzCWsnL8XZ15pxELXPF8fvwvS5 351022B5FQ3NZuWo2M0yuxYONuRMxbh8tvlQQa1a6QjK8p4+Zhw/LJGL/qMj0mdcmm695nDXJitmDu 3510232kvI0URyEnyY/PNczD9E9I8m1XXnM25tXYC129di4Za/kNeoxTapxR4hafqE6Ml9MeOi0uFB 351024H9uBrnt/MwlRl7Yd/f03IFVIDGEh3THnfoV0sJHBJYiJwMhu1mCaMsFz8cO4fa/oQSGpTsQy 351025dzPYDp6Kvjwmem55gZKMA5j6A1lgNG2kVY+xyMUU1qGn8epDBh4/zFLzHmi/+TTh0/lQWNuM 351026xaWCZsVC9D4qEDzHafijSGq0L4yLxKKJIejm4I1hExYiMq7wuxpjal9uRfDk31FAbarictxf 3510275AaOz0rcSLmBlT4cuC+ORzm14Dd8wF/nfsOeUDuYtCMh0nHi4EUk5giQcXUJujHN0T/yNW28 351028pjaS5PinePPpM7JuRcCPTclWnRQSCX5DKFEMGcaaNnATuMy5iffFxSguLkFFvUzJlNTj9f4A 3510298PgB2HorEx8/vMTt6BjkUAoIxY6WUtcXoyj7CqY5kfc6/or0GWueYoWHGSyHROJJTiIODLWE 351030GaXg1kgNp6eG82DeexPupsdhcx8u3BbGoUws+Uag0Axhfh6EerDjlBEqL1+oIFja1de/x62r 35103195Dx/iVOhVrD1HkBEqqUi5mo8AmiVo9DX3c72Dh6Y9DkjYhOLWt3v+a8aIyyoozSRmD4RKgx 351032+6ryfvc5CYeCiGw8f8AzSjaSOmTsGwgLdjcsjE7BB8Iax0VfQXatRKXdX3j7KRN3D4yHsxkD 3510333qsSIBRLtL5Hrd9LGpBzdDghrlww8fB9eux8eHUP534+i9e1XUxCLL2H1OhpcGXxEbT3uWIO 35103460VCEEO0G5kfFQTYxS92g6lRexLCyIgN/90ZqGu3Hsjkad4dyy69wId3SfhttgdYVsNxPLex 351035zfv4C7nv/kaEHxucQYeQ09hRe1H79p+e4mAQD6ZuS5EoA3MUAbnelwmrkF/wTPAZ71/G4eof 3510366bQMFHPo7VWMs1Z5R6VCiPRRAMl6JzgVAkt2H+xMr6PB4peYCbBleOGHxErZ5t+CgsuhsGL3 351037xZ7MetQkrUY3sj4wXeYSYkAEwclgcLmBiHove576bPwazAO7RwTiEn9GMCGMu0c8lo4xisjc 3510384Q9zdi9sfSbA/ZXeYFoOxeE39UqPCdmaUPzlLW790B1sYwsM2JksJURUxuKH8lo00yRJA17v 351039G45xpz8qFGdxUw3KcimZKJ+1pTwRuwLJnDQyAW/AJsR/B4Pmf5yEqHyIOY4msJ90Gdkl0nf+ 351040zSQELfsSfK0SKZWkNt/9r5IQYrH4P/J+/18ZIqseYb6TCayGH0Pql2o0idVJCLGoEvmJezGI 351041ABqfiBS9AQ3lkbjOjyf1IpR95N5pkuZSPN47CaOXnMCzgkKknl+NscSQeLdApIOA+LZ5q7Mf 351042hl9n+HUGVtfRWq+VhKD1DwYsBuzCw/cCZD5/QRsZaDLg+iy4mLHgPfckEjKzkHr7PK4Qoz6F 351043md4eGQouwxurHr7H/eVeMDN1wZybxbQhWKF3cPpiS2wGct4k486laMQXiBRG0pQIHzC4Qfg1 351044KQspD5NQqGrYIOtI8u9ncCOrWgXQt6LsAcEuHC76LI9G0rtPyHl8EnMJPrLouxVPZZGMkuYi 351045xK7oCY6xEW3M7cza1rm9XM/+qOg8JXKdhl6bTWEbMB39rAhO2/da4WSkk0Rq+orszOc4PYaQ 351046N903IpXSw5srkJOejdzE/RhsocR1tN60tx/YbYzHxo5z8VAPT2iJuAx3ZjnSRmpT17m4mXYT 351047C4NXaSQh5EaNrPs38SC3Ws0zX3XPka7bSVhFeeCHRhKyyBoMr9VIqulArxEVIn7/DPS1Y0qN 3510485ho+/HHXUdzadh60oKlFxSgmbkZLOy9sorNu7wO2qT3GnxcQw0kDck+Gwobljnl/FKgZa1sb 351049hCgpKUNNG29hXXiuq6+hcObXuwvgZkqu8V6lMYJXXJmIVd4M+j7G1kpbh9q+W3AF4TbG5BoT 351050IlMTOM+ORakG/bI6KQK+bEdMjTqGMGtNOFGOSX2wmMKkH98g/neZDaCzmFPn97Jx+F42lyrq 351051pWRbl5MQUqyWk/sYx6e6gcUfgSg1LCcbczYTcD3rTufxZJdd04icYyPANzaGRc/5OH4vA4L8 351052z8hNuY3zvyfja4uyP1YOodgfn42Pbx/j6GRXMNXuQwzCxR9Q3CBW2MNKBQVSJ0AyF7J/CQaP 351053I+9HAvYP48OY1Rs7XtXq5cj0vUmIDjGnLkwjiwbijzyGpNcPcYTIhmHeH5Gvv5/TsUhwCUvG 351054L8ahI5sxY8IynFUhydXwcak63pM0fkTMqgA4cc1h678A574jud51hnCZHiKsRoUGfeTb7qcu 351055Hzpi6PVF7D90Dr8fnYfu9v2xJaFMQUhTNsqs47MQMprYcQ9EYNqElYT4qPuvy04f2Uijf3jo 351056uTZJKyGt1JmITaS2+T/QZ83jU+6MUHRrOcI2PcDXVkmncLWue6uTEFUJWODMUih2ktY6lOTJ 351057vBFkHhYdeu8SomGJmxlshszH6EFzcPHJQ9x+kCeLSkjG2m5MOI5ahkBrYjj88QZOLV6K3/O0 351058hHiJcnF0KBem9uE4ndugQTGS9u9zqTScR9JEDNzDuOAGn4RAhf1peBOJ/ubWGHetkB68X+4f 351059wOKJw+BNSIjgCYuw//6X72aooDaKtO3DMPFiPm2slsqAAYdZ8RBKhIif5QBGt3VIVngKdWzI 351060ai2KQRhfuVCrKs7Vrw5gEJeHYVHvlExVaynuLOqBASt2EKZQcySEqbkV+HaeCCQKd7aMWZPU 351061vcKPfoQkWSY1dGt+vhYUxkyCHcMdS+LLpe+BbseGddhlfK7/jMth1mArvDUpw5spXBc/QZWk 351062Ck8Wk03TaxWtqOrruUsBqCrBU8QcXoOJfR3B67EKz6r1ULyrn2FVDx4c+07E2sMxxChcpZGQ 351063EBXcwGIvtoJtp7/Lu4rZ7mzw+i7DyfvpeJubgYTotRjs2h+bHpcrPecpIuzcSPCYnpi4dAj4 351064DB+sS6rWPL5aChEz3gZM2fuX1L7A5h7EYD36Iu0FopMgbP6EcyMsaWU2uVaHrLR9T78jFu0R 351065/0kDgdN1JARRotx6wNGci74b49XIRn2Monxff7h6z8OdnDuY5+0Kf1++Ym7IlUpLd184+SzG 351066/fd31X+fyHMTJc/QyzQ5Rr/H91EItDDHgANZ0jVJrQ9VeLzIBaYOUlClvT0HAw9mt2/fXIAr 3510674TZg9dik9PyjiVdTsDymYPfleGQUtPfo0vfdabqu6eNpDLdko8/OdNS3FuH6RFswvVcjsUp5 351068n/rMPejLtsKY3wXIJsYFz+ErMda7H3amfcadGQ5gkjGUUqsSMp0eicFcM7A4DLC8liOuVMXT 351069o+IR1vqwwHHtCUe2Ofy3p7aLFqLWhNL7q9GdZQKb0VHIkYcOa3nO+ozdCAkn47BJ+7PXvLmM 351070X0/+jFDvEOyL+hnnX1YqwV3pKzx6LWwXtq55vSLEy/np6G5jDlMTBniew7H+r8/0WikfTzaD 351071piOsJx8WzsOxM+GrzPBC5JIbg4hRPrBmMcBxGoH9GVLi52vCTgx3tgC/5zjMGGyjIJBpBepN 351072NJYNcQWXxYFTwApcknuGtN1HFW2I7B7toO9n1SNM/X7y/gXMxZR+djDnemHSce1RRdrHzxN8 351073yTqFSS48dF/6B+0NoflaE1j3n4gR3XjgdZuE3VGbMdqNC0vvqfgtp14N2FkPmIKxfmSdV+2T 351074TGbrR/vSMmPb9kT49liF94Wibb/xGOZl2UbeHcvBuh/pm48V3OY9RCXVpqUMiXvD4WvNgqkZ 351075B7beo7BbDUx1FG2kvvdKxKWIneUEC5mHa9OncxhpZYURZz7ShrYXm3qAQ/auZ5Xkumn24AzY 351076j6zqjzgdYgnr8BgUtUqjAt+dDoM9byD2vihGxqFA8G1HI+ptA73XP1/fHRyPZXhEjA3ir7GY 3510775chB373S1Aba+qxtLrUzCH2DLkMZMlcFzSMAPA95eeSTdR3zgrQbpzoq3zpvdfXD8OsMv87Q 3510786jryaq/OPIOF/WzBIEYrpuNoHMlp0LkG5F2eCR8LE9qQz3PxRjffoVgb/1UxF1tLYjHPlQFu 351079t0HwItfxR5zAe5HS2z374ECYM1wxYddlxBM9oqpZPRVLxeMN6E1FS41cjah4gSIytKngFtYM 351080JP2kDOYMK/gtvSuNChXl4JcAC7C9J2FReA9YsSzRd2sqvjzfhJ4sK4w894k2GFMYdWGPYERe 3510812YsAizbrH8EFZa9TUdAo//cfGERk/TH3DERPKyInUy68Jp9A6kP1/mj2vi/B/Yi+4JoYw5Ss 351082+5uJ0aRVH51c3AhBzGqMm3cYD/KVKSoUenSvH3D7S7NGguDZrgDwWG6YfeWTii6jeV+TtinG 3510839XBrZQREQXsCS16qEhbA2UTLPtSOhHiKlR4E3864gAvTCbb1WCl1PmssQOrrMjTL/1W8M2II 351084PTQEXGMOei6LRmoBIdQrpPuePLKknRG+/gNiIkLgziHvxcQCXqFrsHPlcLiyjYkB1RFDVl1V 351085pKuhx3LpHSz2MIOJTSgOX49EiDXBIlsT1R0aKV3lwz1cir6BF6qRLh3gua68RjruPuDkcB4Y 351086lo6wZNpg3MXPahiV6md5/CJCUnDhPysMHkweRp5VH4vUb308MwI8IzN4TonAGEdCRNhNRMyX 351087ljaGoQo8WOJOsMlSPBTE0ePFdWEcCqurUV1dgzpCxigwqQoG6ixu0e97zZE4XU9CKK8TvTuG 351088oe2woAksnFzJe3LErIsXMaWzeLKrrqlLw/ZeLBix+2BXmnpkjrixElUisew+PPTZlaFIhSXK 351089PYohqvcRl+PB6t7oPvsC3tU1IC9mMfy6z8fNohbyG+nY0Zsl60cTiu6sx+hhQXBns9F3T6bU 351090wfW/TEJ0hDkV2RDM2OBYWsO17xTsjS+W2trkvzXnGDYHWMIu/BIEhPSSOufpwIHfWteQjSPj 351091vMBnm8KUZQ3fsVSWk+aOcafOdsTwe3sp/O0twDCzgHPAAuzesxhDnDlg8bwwekss8kUq2F0j 351092RlXBoUwOHActQXRWjUwOeta1xa866rpy3lI2zcr0s1ge7A1bSwtwzIxh5jobfxY2q+M6cy8M 351093H+QCrsNw7E9T9l8n/vzH9c0oid+KEIJRLZxDsDW+RDruOminXH/r8bXgMwrL26atEqPu/R/Y 351094NLYHbNlmYPK9MSBwFDbcL5ViY12Y9XvU6YVTtdlN6pF5YDAsjK0xlt7LmvE5ejSsLALwS06j 351095BhKiMQv7Bzhg2G8C7QoWxWgUpuIXMijCz2cg8+JEeAceREqhjLlqfIujIVYw49jAyqY35u+/ 351096jleyUCZqIubH/ojxg/wRMPUnXLmwHgt2n8WhpWMQFBiEMcuikFIhSzEkrsXro2PgYGEHD1s2 351097LPpsxIPsG5hIhThtfqHR+0VKopjCaf4jYuBW1ou/3ibtlF4z9SWFEJbL0jGVC1FYWv/9SAiy 3510980O8cNh7Rn2WTpjIeM+1N4bZU9rKXuhGSZRbiK/UjISTNxYiL6AVL+3E4/V6kxqrNdWPRHodW 351099Q3bhuYoHRW3abgzusQCxOXfaLwQNAvwdE4cXOdl4cmwinM14tJGFVviF8Zhhx4CNXz/4OtrC 351100udd47LxbqJZ3VCJ6j6hgS5pkeFmrXDjKn/yIgTyyqJqRj+UAbJEZ6inj9zayuXKDovC28h2d 351101TsbIfqY0XUtbz922f4sK8eD4Okzu7wI772DM3hKFv1LyUNMiUWEWOWqeZG3zQkpaapCX8hei 351102Ns9GsLcdXAdMRsTxBwpPLXr8DrOG7bC9SJSnuxKXIW6hG5gOYdh3ZA1CvBzhEzwO/XqFYmmg 351103DbiBx/FO3r7pI86O4MHUfSniUqMQxGWg25pn7UgfatM0JwuMsYk1Rh7LkW34lLxNZARNB8qY 351104zGBuYjdDLdUNvRnTz+2E8b8X6PieGocmcFn0mPxWNZ6u9IWliqzat6PG1reQEDIPLZuxOCsQ 3511056e/ZLa+bdRir+7ojeF4w3PuuxuFZGhbOuSewY6gbQg9GYYLa71PyNFWTp6TiDqYQIs7zh2c0 351106+6zahyoqCmCIhTS9UX1n2lNyYsGcZQpjcz+si/+qZOrJRpN7cTH68s1kKZ+sMGjrE7X8n/+E 351107hJCPN3afXXgp+BOT7ZhkvD1tc5+HWOjCgNuiq4ie7IWgIw9wLtQDo6KuY31PFmwn30SJqldG 351108cx6iR1Fh4yyiDLZJs0eUouJb8+FmZkTIizV4VNHeU0v0+SpmupjBzGUmrn4W6UGIUWvkBMUa 351109qdXISn3nG44/SpS/2VwSj01DemHm+WwI6+pQJ//UizQbNylDRUYCkrI+oeDDExwI4oHpu17q 351110dSh7l+Z9tiCOjtIyp4HwGyrFgugtjhBCnOm1ABdeElI+MxnpJU3SdFL9yXX+W3E/4x62+Jsr 351111DdyNOfiZUn7HHMOz7EfYR/7PCzmBDyLZ2vZOJQJG7vnR8Jq+H5uKFEu7i0292e0if1jdV+FG 351112RhIdsWLqvpyOutF/PprAdsgsjHIjBqCVN5UKrJa5S/UjNv4AATYq/+eqeGTq6pNMZizfFYjJ 351113FODVhTkENFtjTHSebH/RIW+ZHDTKVdaO6Tkfl9IEyCuokSo8VY8wz4mQkkP3Ij77Hd4kPUDS 351114F5FSb9Ekb53KlxjCh0vhwfXHTxmVtPevle0EXCtskdbFL4ALdyAOJD/Cuu6WsHQMI2PjBqbZ 351115WyIw6r3SCUCUh8tTnWHp2gtuPEdMjBYo6hqy9mMA1xmzY0tQGjcXzpaUciZS8x4pSDuNKS4W 3511166LbsNopkxj4qsnGYZZvQ47YGoeonWOJqCqtR55RhwuIaZF1YgaEeTugeGoHo1GI01Bfg/pFf 351117kFolaedNrcm7+psijDo5b3X1w/DrDL/O0Op04TRJYzYODuTA3D0AffrMxZWnKXhd1izVh2lM 351118INPjVPVg2fqqKeyectaJCPSFhz0XZnRbLuzcfdAjMELh7EORCWsHWdP1VHoTc6+pOPFGZqCg 3511199nOyllsF7sCpHaNgz7RF2Fnpmld6awKsOf2x69EnlJR8xOvMQtSLpc5Jc4mx1MycA/7A7biX 3511208wE5H4RoKovFJBszdFubLN1vRAKcH+8IK09/OLNU9itxNTLPLsCQsO24dHQBAif8iuwGKQmc 351121c3go+CwWWGofDnxWPdOeEofujymcx2/FJFcTmFh4YuSGv/D5i3p/tBNDLagtK0FFQ2sbz0e5 351122Lq2iWyt0bqKTO5iCpfpdawOEldUoST1ISBcWeu9IV3c8E9ch57cJcGTyEbz/BarEmvZzzcad 351123ssc/Yoi1aTsSgurHbBelfMQiIYoL85F1Yw16W1jAb80dFDdL6BTBvy4ci4B+AZi4kciG1mvq 3511248fbcbPhyyX253THnfK7UUEEMbb9OCMSCo5ewPWwoFpzNpA2JNH4MtICR1Vhc+6IttayKZzQV 351125hXN6JKyY7ph9MQOfMq9goRcTRmRM7U4qRVnqXgyw4NM6RrOKY9jH82GwNZFGVtuGKh1jlPvR 351126A2wL4BMSTN3ppiM816XXUGTi8w3owTSChU8IIQmJzuW/i3beU02zdGuGI0zYfbH70V+Y62wC 351127bnAUrVOqE2gcOg3Tkvgc3JhiB2MjK4w6r05WtJbcwgxHNnwjnqNaa6qkjjBpZzCn7u+pdLZs 351128GWZ3lmdV6CpjpupaKHcy04IF3abuwhxvNtwnrkOITWfxZBddQ+lyDsYwspmMv8vFWvQq6j5W 351129CCUyVODN8juYrHIfKWmXi+iZPvAcNATeXuMRlSkz0tK/QfXjIT482o5xM44h/VMs6YcZvFYn 351130tcPH/y0SQhfmlGMa55kxeJ0Tj58GcdvgOfJbMw9gWU8mzOyHYdOfAul+owsH0nVP8JyqEyTi 351131ULBVmzot7UQlSE1IRk5ePnLv70B/QsL3k0XBUe0qspLxKvczCt4nIDJQpV1TKdKT0vA+Px9v 35113247ahn1o7YuwXpCCV+r1PKTgRbg8TZjcsjcnAm9gN6MWxw6QYqXO1AqN6zMaZ5A/Ie/caOeXN 351133Shw69hiSch4jcqgluEOP4K1Iol+dJvxK19mh94ZYZBG57yJyl9d1KQlRn4k9fdlg+SzF5ZQs 351134vLqxHr3NLTDkyFsVsp2MH3ZvRJzfh0CCibpvTJXpCh3gz39aX5+B3VQqO8teGN+XD/O+e5BZ 351135r0e7DuyUdPtAWfvUBBwYYQNTY2vFnvafJiE6xKk6cDy9/ggTsMaHCc7gn5FT+xnRo4l9Nfx3 351136FMiwrFGnASUtQDbMjE3AYHPAZpi0U3BbawVIOLsWgxzs4MQzg8XgA8hq49FAHbhzbOUenN3Y 351137F2x+GK68vIowvsrkq07EUjczOMy8g4Lc85jqzAbfpwfsyAvfklKtObeXjIRwnp+gk4TQ/lza 351138FURNG8BsF6lCyx9ysN3zafPyldQ+x1pvWSSEWIj7M+3B6LZWr0gISVMR4tb3Bc+KGPUfflXz 351139qKaUv9L893hxbRV6kPcyUM6ENxfg6mRfjIx6i/qyu5hKp8d5rDGyQSxT+L1WyTagmmf4wdMM 351140vKADePw6AfvJwtk2vLb21Xb0ZlsiSNXoQgDOvgEW4A2NxMPMR3Q7Tj/ZBKXyqN1aBX9LU5gw 3511412LC0IsZ4QmC8qtPDi7kmGRv8uWA7BmPlL9fxTFCp7iVCM4syLzLVT8FXeuNRNURWCp7h+i8r 351142EUyUMK7/BiTL8+SKviDxz+t49FEl9xuRw0oiB9sRGzCTvDtL8lz3/t6O/l6h2DjRFaaOcxQh 3511430FLPdBM4zIjF1zqpgdJMxTNdbdPMfSyVqUokhNRD4lKHXieKSAh5W5X7vqGfuwAltS3av699 351144iS1kY+ZRuS+bxWgsy0HMTOd23saKdpkXMJb/LSSECaz9Q9GPjCsL//W4X9LcORJi2T0k7iFr 351145hBHlnZGIexoXzgTkXJ8KD2Lkc2Jr8FwZ87uax0kQ1xwD9qt6vyhJBFNeP6yJ/SKLWkrFxu5M 3511468MdeRWGrentFKjSFnK7hxeOfMcaeCYcpVxULrGJuiSrwPvEclvUwh4nzfEWaL53GeVnUkDMh 351147VSlPb3odI3L0XvtcJeehzMOK7YdFm0Nhz9LghdWcjwujeDDvNhpBnn6ISClF5p4BcB8UDj+u 351148BQJ+faucu5QXY8I6+LLZsHWyBNN+Ii62iVTT9d7E9TmIGm0DE1Z3rJYx9x0+Jx0tFqyIFtOX 351149hKC80V9uoXLjao/Ma0+iV+LViYUI7OYAPpfsX2bGbYzbcmKuTVQMIY9nEdLOeYH63kLtG7Mc 351150lJFdNDEovx/dxhjGDOlewjIlv6VKOGvxZqfup9qHtnNS+lsyAlvL+SEdkoLWoYTEbuyA8JL9 351151lvAe2Tfk/5ddt1zDdW37JJOZy0KpzNrtLzrlrUOu8nYLH6u/i1YhUo/OxWAPPp0K0qbnFBxO 351152EWr1ztFkrHmyxFUtFaKkOgkRvpbovfEK9gdZwWmWMq0BBZjGWfMxbNMqBAYsxZZQf4zfOhNe 3511533F7Y1sZ7rTZ1M33OCcM3As+r2xgnRvJhN/44zs5xBT/klIIwoOcTZegZaQ/7kb8qDjikwaOj 351154MUysgnAgs057agwy1p//2A8WxkZkzZkjM3Q9xoblh3EvPQMJ5yMQ4sQi+7ANhmy+JzUs/QdI 351155CH3mreEbow2/zvDrtJAQbSPWZcYkl4nbMUu1PaUPv6H0Npkep6IH512eAW/qLCJjFmzcfDB0 3511567X1FiL2+WIjy3C/NScS1PRPgyjBTGtBkehOnPyETnvyMQK40XSZljG4uisPWUZ6wNDWivdYD 351157N8bRB43KiRQ69c5oQpo2tqCxthGVKVvgx7LE8NMCRSTEIg82mCymulMM0ZXm+43A0ae3Ma/3 351158GJzIqVd4QzZVFiFfFQ+002XbYzl5fzhewejj3RtB/sHYGF8CYZv+dC7dgQyfZKq8ExV8ooZf 3511595N/VpiCiBwdMCmeb98Dy2GKVVBQES91cBh+iq/kuv63jvETtmFJcdg+LqTRMqiREGw9N2rMz 351160+zdMdLKA1/xr+KTjjAvF2GExwGCpGFaotDA5JzCm9zzcfnoUI/zm05iJ2v/OhFgSQ84InMtT 351161925l9YzAnWwqE8NHFFTIHNGoPXox2aOtJ+LWVzH5uwJx02zJuCH2CKacYLJAj3XP1c/io/dx 351162Bv075/Oa20UfnCKGEbbXQsR8VPdK7QjPdeU1EioyfgoxMhJSz2H4Ugy1ps5zcMG82FKFQw19 3511635putMd02SViA38fwYUR5lb4VqdgcfoI/m+z5TnNwt4yMkWvhsCHzymLoMaWzHMHABZfDYE10 351164A1OWucLJzG1RPEpoh4B6NLaIFRjKcvhZtUjltlhWL8yp83vSD5fZiiiwgpJaDV6//8CYqboW 351165zvmb1uEUkRAEC6p7/ccSO4svLPgu4DM6iSe76hpFJIQ/fkpvEwkhqkK1SiSE/08qkRAqz6Q4 3511669FsiQt61OXAja7TjhLPIlUem1yZjXTcGIa+HIHDifiQLW2X94CgwYUcYtGvqKbJlEmLLxGjJ 351167v4BRPOV+0SlHvabPuBRGiHFZOmTVyO+SgnjsHWELlvcaaepDXTiQqouajwBPW/B4luAw2tRp 351168a9fyFQm7w9HblbSzkDltynESqXuydyL83e1g1bZdUz6uLx8MD0IocTlt2omrkHZyMYJ8HcG3 351169lLUzkhHV9LUqhJFWjCrDoaYMet9kUI7Bjqq4toM6DfhVXmfK4uiFbf8JeTjbQflMmjEkhRum 3511704O6He+rYtCP82SX11G8PR8QEgnsdZqnZCrS268BOKdfnnKZG4diqadh4+hjGWLd9Zs2Y9XvU 351171dYRTdeF4xV5zbSoczXsi4upRjLJ1x6L75Yp91kifXKNtFSlBzDR499+GBxmx+KGXH1bczlEK 351172sP49/rp0GykvYjA/IAzLhtnB1HUxnlSpG4Hzr29GZGIBXmzrBRbZRPfS4bUs9NqWJvV4oNPF 351173MMHstggXX75D8pFRsCHEh/3ka+0MtEpAL03HZBlyGh91pGP6JgWxTf4u1YGUX1Qp9aps67mv 351174Id857VW/wJU+E+KvlD+xrJs53Bbeo89EkKaXysDVGcQYzB+D82kqabDoCIi+4Jp7Y150OgqK 351175lb/TXJKKuw/S8KEgH1m3KKaQyHG7TI6Erfup3cFTLEUIn+jTLRw9HYcMgQCpp6cRMGGFkfJI 351176CHEp/p7rCpuQX5H87jl+GUYY4e4baPZWHs75cJkHMVROxnWVUE/52R+8YT8jSdbOzH2ZdGNo 351177KkdORg4E7zLw9O/TWNXPCQGRsrAePXKYU54/ha9u48SWWRjqYQ3HPmFYfvBv2qNXFUyofYhy 351178Q0cLiPLx98HlCOvtAGuPQMzecgKxrwpRp0pQyPogVPVgkpFbjmM2YIKrKWzGxyDvw3mM9ByE 3511796f35Su9dea7ctoYVM5Uc/WpnQkhlY+q2RCobYpxJ290fHHNfLLmQCsHHN7h/8Wq7MyFy814j 3511807uAEuDAY8P7hkR5nQmgy/Nbj9YEhsGR5YtaJJ8j9/BqXpzhqWZT+6cHUCRA8/hEDLc3AD9qL 35118158JWtcXLftwx3EtMRGJiEtI/17Z79yXU/LXpj8g3JVrZ26qqp1KQoQpMiTzTibHdgtMTK35/ 351182CcGHZJyd6wUWbxiOvm1sp0hn5RdB2ChWzye7rTfMOb2wOiZN2d5iECJfa8pJSYzpO/uArZJ3 351183UlKThqM7j+F2ai4+CxJxMJinlq5Jd45gAU6P4IHpNg1H7z7B7f1j4cCgPB++qK1j0lyzRFkw 351184MaZTK7XLIU3edcauPmBRBgXbybhZ0orKR4vgaiIdm6ue1SgVXPpgf3NwA/bjRfZlTHZkwWXW 351185Hyhs1iedQCWSdxF5E8NG9x9u4u2XNvkddZAXtS9/VJyb05lICDrn/PC+mHNRvwMQqbk8n/Ie 351186G7gF1+5eREQ/i3Ye9hSjf4/yvm8TCUFFyUgjIT7iU1YqMtQiIX7E/Yz72NomEuKXAB5sQ7Yj 3511875lEiHt+9hhNHfqfz6Wp9RrX7Sftg1GlPBt3z0WXSbqwbwge31xrcKWrqWGnU9v+OvDJkMqM8 351188Oq5nCpB2YQ7cmXyEaoiEaCdvXXLVNv4a84mME/FaUABBwk8YwGGg27pk9UgBotDaT1SewSFP 351189l2Y16gyyPj1QizyRE2TpZE5bcO3AZXtg2SMVUkP0DseGWoLF5cKLOvfmeDBsLIgiT9bzBFVj 351190XX02jg63Ab9nMPysrRF0KEPl4PpWFP81HY4sLvgcW4y5oEy/QOc/X+4DC+fJ+O1VgXIeEd2j 3511918GkknSNcNSq0fSQE5chhCl7wQTz+UCIzdLVApJJHmwK0ZcIGZTrB/1AkREfz1vCN0YZfZ/h1 351192WkiItmuwKBfHArkwdxuM3n3m4erzF8iiPCDbRn+p5VpuwqfocbA1MYff6hvILa/El7S7BMjX 351193d4yFSNuCuCicvEl01JJyFD6LxCALVW/1VlS/uYrNYT7gmpjAevhBvJQd/FlfkIaMj0LU1+Xh 351194z7luYDjNw6NKafq9knur0YMt05lN2XAKWoDJ3Tmw6LMJTypkOqO4gTaQS4G7qqG8BRUpRzBt 351195xBrciqf+Xa/1LAJJ9XNsHjkQ4yPTpYYwTVhOtT+E7N2wsh8xRlnDjY7KV/bnm3Muq35KdZ8H 351196JW6qRklhEcrrW9RS7wqf7UIAzwQW/hG4mfFBY9pky6EH8PTtMxwKJIZ+q1Bc+qjlHBEd6ZhE 351197n65hnicbVgHbcC+3AAVF5WgUd4Cj2xpWapKwfuR0HIm/hTUjpuFISoXifJG8ixPhQIxgTmN2 3511984MrjdOS8PI8xfFUSQoCPhfL3IkLusUBwmd2wIjYf1YX3sLY7MdZyh+BwBsEO4iaU575CrrBN 3511996iFdkT80vqNSjh3Fs5wMxF8jGKtOTzzXRddI7RQHMJDTnpi3DI6iU6FJz7wcBat25D3lFPVG 3512005jldg+QN3TUT/Ob9sE+OS6i0T8N4sAo5gmSBcq63PxNChkkZLpiw/yYSk+Jx8eeTSK/9l58J 3512018e4Jjk9z03A+oPQ+RS+2wo9p1Hk82WXXNCDnSAisjI3B7b0IJ+IzICD2nfepsYi+Ij8TQnof 351202nmMYDsYTG9y7RESRZ2Kq3UeEgls/oI9nGH4h+PrkFG90n38FggZCYoiFSFhJnffjhEmnUhT9 351203YNuOxRlZ1oKOMOg/rhcJ8NtwHowYrph2/A5uHwiFPdMF8+PK1NepDlJ50ZklWKYwYbtjUtRr 3512049RS1C//Cy7dv8Xj3AHBl53zqxIGyOnpuZD/E3iGW7eo0tqOj54gxntMP639dB3+OOklORfpp 351205bvcAC/qPx6HbD/E3ITh8VCP8ZGuTRf+NuHL3KrYFWcOE6YU5x2LxJPEx4q6fw9m/P0mJKzlG 3512069ZiNsykC5H/IRm5FswKHOoRHIYlgo0/ZSbj1eywZAxK96jThV7puiB26LziO2wlP8TThLmIu 3512073MSH+i4mIcj4OTPKCizPBbiU9h6pZ6bCmWmHidcKVEhKmfOSoK1e1AH+/Kf1KpEQ4VQkhP9u 351208ZNR33E7dkb19RKY8ksLIzBmTTz1HKt1eJZJCB2b9J3UUVtSOg3XgVB04Xrn/ZuOXQD4sbLjE 3512097rBVzf5lpK+Hq7pBawD6RCSjQnASId3n4r5qeBRh+Y/O6A9XSwaMCaPPsu+PxdE5CtAtzfGW 351210iEP77tH54UUFtxAR5Ew2OQ5cgiJwS3G4WStRKo9j3gAncAg7Z27fC6PGD4QtywHjjmfSJ/e3 35121175v0YGobu/F0ygT5Iiw/mPrPohb9ALMGGbQWXyfKPBdDf8nRauxqN6koQ8qIsTglUPckbvpy 351212Fz+O8gCXvFCPUdsQ96VJSxiqpkN45R+V3IaCi5jT247IyQRmXBf0n3EAj2Ue55TSXvL+DTIz 351213M5H59ARGWpnAcXI00kukOUepsOp1Id6wYZuCwfPE8IgYvKtTvs+movvYMcYLlgwWbHpMxN6H 351214JYrB1/IlBpPsmPBc8UgtsoJSRD9cXYNhnjwwqPx3HsOw5toHqZJUk4JNg+xgbmYGc4c+mLz7 351215LvIbNS9KreT+YdZWCDmeq5YCSun5WouCFzcRFXlGephyRwxj7WuciYzCrRcFqG3V9Q75CIsp 351216Uhpmmj7hHFkIGZ4zsW99COwIG23u6AMHlgnMPcJxIKlCqjCRDZVKL8XwmIfLqdnIzs5GZvwe 351217BJC54LnyicrhvMp3aOE8CEvI/JATIeLGPPy9ayJ625vDjGUNn/BDyKxr48VMABrfrS/C119E 351218RqW2EGZ5OK2OaANRERIOz0WAG+kzdYi8qz/Grr2E943fSEJU3KVDOTWlOqomc/NL7Cr0NDeD 351219w7go8r7EGvrMRr+9rzXmotQUJaR+jewwRSP1NmJimLy7Zxr6OVnAzIwDp/4zsP/BF71P9hfX 351220vccfW8LhZ8+GCdVHVjcsvPJB4VHYPs+oLNR6daL0fde9xpFZg+Bty4GZCQvW3cdh572iNpuR 351221NqJIjNqcy1gV7AFLMreZfB+EbvoLn9rmFmz+jAuhVnR+Z9/1ye1SDEhTx8yj8/paBPxKh1q2 351222FFzEaOqQPOvx+KO4VZECL33fIKIc+2M7HW0mguDMWLLmemLJnRI9FMJ4TLfT4d2sayzWpmJz 3512230BRcla/bepIQ9DokzEbKuyq9DqOiPFIebQuBE5usSz3DMXuIbfszFwZNQ6gvDxynEOxQPRMi 3512245wrWjfCGFdOU7GvDECk7E4I6uyDEyRwW7oEII8qI6pkQtTm/Y+1waRsmzw39Zx7Dm3odJITi 351225fhzwfEdjSn+idNpNV0m59g0kxPL2c7a86G+s7mkB3qDteFLW8n1ICBWZ8ZlmYNv0QNjWm/jY 351226IFYDhTaDZ2JcT6s28laVQyimDrLRSpAqx9Ar7B7dDXYcM5hQ+VMHzMdvstBzhVH/h77gm6mM 351227SUI0pv86Hh7EiMbzGYFwf76aBwhVGnMOYRAxDjC7r1dEzMkJilc/+hHAb41wsl9UpW6iUynY 351228TPxTcYgmPaf2D4GV7WiczK3EhzPjYM8bgF0pVco1RpiAlV5mMLabpE7m6zwTQpomwXF2HMrF 351229mkkI6dlRpmTvedbhwWf6GP+7koToaN4avjHa8OsMv05PEoJeZy9h5RAnsOkzIUJxLKdRJ56Q 3512306rXFiN89Dl5Ubn3qbACrwdj+slYPvYSQEH8uQz87luwgYQbsAijs1qRwMhN+yEGBsAB/TCT7 351231q8phyWXxq9DXWtrOhOOO0bsTUdaq9OwveRqF5cN9CB5hwNyuB0JXn0bKV/0PZBQJi1DdLFH8 351232+8/O8/vn/dGUvkbfqE3dhEYxro/jd6BrkbHAdwTfwh4Dp83AIHtbDDv6Vg2/6kNCFFwOVTd8 351233f0t/m6tRJBQp/lXHcdXIitmBmUO8Yc0y0XgwNUemt9L7ZXUGfpvjB54pVWcG634zsHxSD3DN 351234WLCwICSR18x250zqJCEob+Nj0+Fnw4Ip0wqeo/cgrVZPPNdV14jLEb/MAwyLPlgdk4osck32 351235m2RcWuILNtMXEc+qaKeH44RsZBCD3OXULPo+2Wk3sbYnC+w+O5FOcKJY+AjLPRmwCt6PB5nS 35123636I+GXe3oT+HhZ6bpalKGrMOYACHjzGX8lVSfLTHj20xKYNtB7+pR2kdVjfm/CffG4E36gJ9 351237LmLXkxDS+5uyreEZMAeHE4qVDqKq9yEGxl192Gp2Fn3wZFdeQx3gnxS1HMN9bYi9hAELx94I 3512383/g73lSL9b4PPbbP7MKZV1KyS1ybhYs/EYMzIVFbyx5hx+yliFg0Aj42bJgxefAYuhDHnn1V 351239SWWmG4N2SX32BawMcifzl9QTjBC+M06RHls/EkLuRPgF5XUt7dtM2425fsQ4b+GOsZHJUqdN 351240XTjwm+tKEL8xAHYsc7gHhsJHlYQgdfciBpJ9hAefCeuxabSDWrt76wfBhtgDfcdMgZ/KWUeS 3512411jIk7hkDDy4THOfBWHoyDjf2TUNf+n2zYeMdhKXR76UkhFaMqh2Hfo+6rj0TQoyGTzexdWx3 351242sjcQDGnnh4k/xaFApG4A10hCdIQ//3F9M4rjNiGIYH9zpyBsiitWngmho12HZ0KI8nBl8QgE 3512439ydzhiF95vGqZ1HowKzfXleNV4fHwpXDhl2/SZgxwLodDtaNUzXjeDUbVOJ69CBjPPCYuj3X 351244CN+pdAV4/ZYirqY8ee0RJHtQSW0advnbIeBAplouzc4W4YNF8AuMRHqtGIZf/jOl8skqDBpz 351245FFn1/+WT7ilC7PF6+LGZcJt0ALEvBfhaU443928hpbTZ8F+UzKB099AEODN0H9r3by6i4if4 351246eS4xiO59iOImieG/9G8E4ZTXiu2wI8jRcnBkXfouDOSrn0FiMDIixE9hciLeFFej6nMc1vdi 351247gzP4kFZZab+PGI3vTyPEUhld+P9zPHT8jjs6J+nf/b7FaK3LQVQwX5EmQD+jTiH+XOANFuUp 351248N0DmgaNCQtQmR6AHdVAnp7fagbP/DRKiK/RHwzdGG36d4ZMQ3wdziUXVKCspR22zuNN6cWON 351249EMIa9fOXKA/dlPXdwTIxhYkJBz2W3VRPFUTWvGaRCM1iw9eh/ut7K8HH+5ftR1qJ7N/a//47 351250EesxLug0W7XlKCmvpccR9beo8iv9d5MmB0VxLfLTk5CYkgNhs+GPu86W5ppCvIgah4ELr6PA 3512518LHP/8YaIW5Cvcjw7Vn/c7aY6hycD++GgA13FWfIGX75N81LEarK6/TGbP9tnNqRrkG1Fbc0 351252oSb3Iqb1nY6YQvVgACPDf+WGXwy/6LMwNCIvdjvGeHJoj3hTjhtGbL6FTw2Gv4lTpfLhXLhy 351253XRCwLBrZhk/UGX7ROIdU0h4UV2kEi1KjiBBfPqunWzAYGVH58ncGwsGcGHCYVvAK+QHRb6o7 351254LQNaMbAzg1WvBbgkaPx3G0r+l0kImRcJ12cWzuU2dHI+NaOmtAD5RbIUKyokhLixAoX5hSir 351255bencPYkhc4UnU5lfm8kA03NFh4bNdqkQZSkQv1kuOvph+HWGX2dodf++fYw6mLkIRQRMt0gM 3512563xDy/3VvNfxi+EUfA1Tp33PhzmTCfsRhhbez4RfDL4Zf/j/O1XlwZxn+XDX88p/BqR2SELKo 351257TIa1PxZflmbEUS2GT0IYfjH80inDD2EpS0vUwv4Mvxh+Mfxi+MXwi+GXf//+1ojyQnnOdenn 351258c6H2HODyokow0h9ZCsRvLbr6obVOLDH8OsOv+5+sM/xi+MXwi+EXwy+GXwy/GH4x/GL45X+l 351259/B//S4lkkfSscwAAAABJRU5ErkJggg==' 351260 ) base64Decoded asByteArray readStream! ! 351261 351262!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:17'! 351263dejaVuSansBold9Data 351264 "Created using: 351265 Clipboard default clipboardText: 351266 ((FileStream oldFileNamed: 'AAFonts/DejaVu Sans Bold 9.txt') contentsOfEntireFile substrings 351267 collect: [ :each | each asNumber]) asString 351268 " 351269 ^#(9 11 3 0 4 8 14 24 33 46 57 60 65 70 77 86 90 95 99 104 113 122 131 140 149 158 167 176 185 194 198 202 212 222 231 238 250 260 269 278 288 296 304 314 324 328 333 343 351 363 373 384 393 404 413 422 431 440 450 463 472 482 491 497 502 507 513 522 526 535 544 552 561 570 577 586 595 599 604 612 616 628 637 646 655 664 670 678 685 694 702 713 721 729 737 745 748 754 764 772 780 787 793 802 810 818 826 834 842 850 858 866 874 882 890 898 906 914 922 930 938 946 954 962 970 978 986 994 1002 1010 1018 1026 1030 1034 1042 1051 1059 1069 1078 1086 1094 1105 1112 1120 1129 1134 1145 1150 1156 1166 1172 1177 1186 1195 1202 1206 1213 1218 1226 1234 1248 1262 1271 1278 1288 1298 1308 1318 1327 1336 1349 1358 1366 1374 1382 1390 1394 1398 1402 1407 1418 1428 1439 1450 1461 1472 1483 1491 1502 1511 1520 1529 1538 1548 1557 1566 1575 1583 1592 1601 1610 1618 1631 1639 1648 1657 1666 1675 1679 1684 1689 1694 1703 1711 1720 1729 1738 1747 1756 1765 1774 1783 1792 1801 1810 1818 1827 1835)! ! 351270 351271!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:18'! 351272dejaVuSansBold9Form 351273 "Created using: 351274 Clipboard default clipboardText: 351275 ((ByteArray streamContents:[:s| 351276 PNGReadWriter 351277 putForm: (Form fromFileNamed: 'AAFonts/DejaVu Sans Bold 9.bmp') 351278 onStream: s]) asString base64Encoded) 351279 " 351280 ^Form fromBinaryStream: ( 351281'iVBORw0KGgoAAAANSUhEUgAABywAAAAOCAYAAAB92+u/AABTLklEQVR4XuVdB0xUWdsmIUMI 351282gQwBAgFCCSW00EKPgqDBLoIYsYAFEERFURFksPde1s9VsSu2VawrtsWKlXVtq9iwYUGUIkXq 351283zPOfe+70AoNlf3fnJBOROZx77qnv+zxv0QI0v2h+0fyi+UXzi+YXzS+aXzS/aH7R/KL5RfOL 3512845hfNL5pffs4iELSionAOwgOHYebs4QgKy8a58lbNH5ifdb749Xi0LQ5B/aZhVXYUgobk4EEt 351285X/MH5pv2AB9lR4fA0nokTv19EAMt7ZF0rqpjbTR/xI31oxDcex4ufWxps27Lx0uY1zsYo9bf 351286wMdmgdL+1D/Ziwl9hmL2lhzwBvZDxpGXaBAoqVtzE3MGJyPnyHZkx0Vi5IprqOQr1vvy9wqE 351287uifiRCH777kqZW1dR6avA0KjQuHgm4nrNYJ/bA4aX5/AtK6BSMl7jSZl79lagUuzuiEwcQf+ 351288rpFd7/yqm1gxoAdSt5zCbzP7o3v6cbxpEii8O/PO0j8zpbnsPBb09Ufsjqd0fAX8WtxZHYGA 351289YRvwV1Urjqf3QOTMA8jfmIzwQWvUGke11oto3o4y89Zf5bzR96t9isNZPeA3eAPu1vDbXcu1 351290DzYj1q8rpuwvRo2KNgX8atzeMALhQ+cjd/cixHUbglXXK9Da1hoT9nVEG32lY/r+InLWHMDD 3512915+y/T78I/oE93IIPBdMR1nkK/mjj/mouPYj4gH5YUVQFvpJ3rX+4ATHdUrH/r0tYNbAr0vLf 351292o0Wunuj9mPeS/llxjCtxmdcZAWkn8K5ZoPkHrfTYND7Dpr5m0NLSglm/zXjWqDnjU/r8Od5U 351293NiqsP0FrHcpeluBVWT1dz7XvX+B5aQUa+YJ/5A6sLyvBk5K3qG0VqFW/ofwlnj4rRbWGrW3m 3512943RsrS/H8eSkqGv+dspfWPzpg1RcwLmwcLlQL/p8nrgmv9sXCTtccEVueoeoKDz76BgiYeRVV 351295fM0/oDW/aH7R/KL5RfPLTyZwVP6BkdZaVFhmPkZhq/GwQfl9VZBgK66nxQ3G0nv13/Tspvd/ 351296YHa4AwIzz6KsRdCx/n6H58soZ/eWIphL2iVAzR+Vgg7d++/Ozke0lwX0tTv29+q8i7I68r9r 351297r50fNWaaX/4NCgUBLy6tQGyANbgcLeh6suCbNFj1W7Q5tLR1YeLSHZN2F6NW8+VVzS+aXzS/ 351298aOJ5yW/A+zuXce7cJdx++0UpkNtW4X++h71rduLmpxZCAFzCprWH8aSO/5+XGxm55/+lH63V 351299eFx4GvmnL6O4quXHPuvLC5zckotrH5rBr3uC3zfvQVHFf4/Qbnz/F85fuIMPNW9x6/xF3P3Y 351300rHnnQM0VTA6OxvbL2xHdeTKufNZ8mUjzy88o3xOypKr6HyFy/r9La+Vf2JUVg85OZjDQ1QXX 351301whWhcbNx8OFn8T3NGB1V/bkOg1w8kfTbc6WGDeKxaynHlfUZSJt/EA/lyG9Gry/NS4SriQnM 351302g3goKG+RkxMqcW1xX9gZWSBwzE7cLd6LQZ1ScVnunFDLOKLqHEZ798X607+ij/foryb+1V8z 351303rai4vgZDArtj+h9lCiS04rhfw9J+XuiUtAW3q1oVxunVgQS4kXGy778Wd5QYEbRlJHFmehfY 351304BkzDHx9apMa2Dg82RMHRIwG5j+vwpTgHUQ5WsLXyx9Q/PlBDAlXjyuyHmtur0MtcByYhWcg9 351305sBEzRkYiJa8UzaI10lKGM+mBsHQegg0FuRgcNA6XpPgjpo0vz/Yh2csRURsfor6dvdX87nek 351306ejmg34obqJQjOBmjj3tr+8GWjI/nuGN42yxPzH7C5Xk9YWfmjMhF51BasgcDO01E4Veso+8j 351307/9bh6W+p8LcJwrTTZeIxU1Wa3hzHRG8bdMk+hbdNcu/W/AbHxnvBlLy7R8phlDZ9nfEQbYuQ 351308+pv7W8EqYj0e1PM7jGu19Ryt9gCzthaw9IFwYYIbnOLzUd7wFDk97dBtbTEahQPY+PY8Vo/u 351309CmdTPWhraUPXxB5+Pcdg44M68cA/yh2LTlZcmLhFY+nlj+KNKeBX4BIvCF6jD+GN/AJirHKK 351310fwOvvzcsDXShb2oP3wgeTr5rVrkJqaJScR7pnnrgOIxG/gc+GeBi/C/cCFqmvbD+UaPiePh3 351311DBj91tL8eg8G2Pli+s1a4RjUo+TEQsQFO8BEnwsLj16YkHNdbOUmqH+ILROjEOxsAh0VALXg 351312yxPszhqGHr4OMNXXga6RHQIGZmP/A6kLpP4BNiR2g7edKfR1dKBnbAuf3ilYU1AqnkvZhfkS 351313e+PsFZ6poCCJPnaya4cB6D7e3ILJ5IC1NGCeZwf/Iatwt1bQdjtaErCZroFHhzBveBjcLLnQ 3513140dYB19INYcPn4dCjWvG78Wsf48i8WAQ7mkBP1xB2QcMw79gz1P3EwkPjq6OYOaQL3CwMoKNn 351315DIfg4Vh6RnYumEvo4619mDsqHO6WhjAwYeZsDBbn3UWlEmJBUHsLcwMM2DE0DMPqhw1tK7cE 351316HDW0dEWXoTPx24MaKWGDCF+lF7FhchQC7I2hp2MAc9dQxM46hOeNArl2ONA1MIG1ayD6jJqB 3513177VfeiYU2lXNsFYeTnwTtfi8qLZV3kbcoCX387Nn1zbWES6f+SF58DC+l+yO3N+TJj68hHaiV 351318z+NcJLrqk/EyQ9c55/GhRaA+OcG8j1E3rJGaiy8P16Crkdxal6pvFLYS9+sFSt9BND+Nby4h 351319J30gOhGhkavHhZlTJ0RP2YiLpQ2SeVQYXw4RLt3QLX4J8p/Xy8y3bHsGMHMMQvTkDTjfVnvC 351320/RgaNxeHn0j2Y1PZZfw6rhc8Lcna5ujByMoFgb1GYck5Vihrc+8Lx0SdudoVSQB+LUOErnwg 351321IxDX3V6AIAMtaFsPwcE3Lbi7uDO45N2dx19AJfN8QS1uZHlBlxnrbv9DMbOGyHn15sBAWJDf 351322mUftxfsT4+CmpwUdx3jklTYLz9libOhnQe45Q3Sacw3NpYeQ6KQDLY4VBmx9RvcuM5aVl3nw 351323NWDmPRgLiz6rd9aJ6uhYIzwlGwtyLqOM3AHLQ2zRe3OJzLnw5MByzJ42HF5cufEhd23xnskY 351324EJONYy8bO6iE3MTqQUEYkvOwY0DZz0JY1t3G/EDm7OPCbdBkzFi6H4/rvyNhWf8Y+5fNwqz5 351325G3DuXZPS32k+YdkRIKoICwb3QI+I8ch91vjff9/6u1jYiVmfurDumoCsVSfo3SUtv97ZOR8T 351326B3nDmBDu2lZDkPe2Y8Cv4DMB9zzNYefiBjc34cfFDuaeEqCPOec+FS5BL0sOtE1DMP3MO6Xe 351327A6qUqK85X9rrl+Z/r/nfa/73P+77jtxDbRkeN5dfQ05aBPzsjKHLIbKfhTMCBi3DX7VSIOXd 351328/ZgVG0LwAH3oGloTnT0NOUUVaK24hGx/Ljn/jNBl8Z/Uy0bQXIq8BCdWDgueh2tVLADSWFqA 351329laPDWd1Il8ii9t4IGzgVu582CJ/TjLILKzCikx0MdfVgQmTVYSuLUM2X1p0a8HRHLPzDRyEu 351330JABjCFAmf87x60pwavU4Ak5aw0jfCNYErBy3+hRKpIhNRrfOndwXPtZcoudYwXfQXOSX/jP3 351331lVr9E8kgs4SfZfuFQOhKDHIzg1XwJOS9aOwgIci8cx94kvHnWndGyo6H1Hjm8IRg2BgSLMbc 351332G0NXXaegYOXFTPTw84Ofsk9PHq6qSTAJmstwceVwBFobgCOUjbUdUpSuQ4GgEU+3DYZvXx4W 351333JQYihHcRFUKAktGBlwwKhAuDF0hhEq1Vd7AzvR99Jz2CjwTFLkT+i44R4c0VfyN/w0yMG9oX 351334XTsHKH9n8vHvMxM3vsETMH9GLCL7R2HUkkv4KHovAjqemD6M/D4ayb/ckMJpHmEdg29pWWLI 3513350TKZ92kPD/hh9YgOVH4yCY4cUo9jj4QTZcq95GqLMMtfX+jRtB3PlQCpgi9/Y0UXQ1rHsMsK 351336/K3Ma4zs9eK13WCk1YZOKYUpdAzf6Dhu8bXfG4WvwyMleIY6hpFKcQJ5nMbQHPbe3TA0cyMK 351337XtYr1+v1vJBxqZJ+p1QHVxN7+JF1WTL/KrZmDUEXV0sY6unDxNYHvZMW4/CDapm11tF22zci 351338kH6uHoxtvNFr9EJCyCzHkNAxOEJk9q81bv1RdTqMU7SlB7e8w5F4B4ILa8PYOxqp0zIxtr8b 351339DInOoueZgctVfFkM/+FOJAaGIVsFISdoLEU+rwe6JOag6JOivtPwdAdG9BiPfcVvcGP1IIQk 3513407qV7VKJH3sCM/sORc+0ezm/JxKDwMCoLyDsnqeNhK2h8gpw+pux51CcHTxv/CS/CVlQWrcPQ 351341zoOx8e9aletR0PAMufFB6Dmd6I0NSsjI4k0Y2nUcfntUgvzMLghKPaJATLXlhcvcvwWzu8Nv 351342+C48axDQfn28MB2hAaOx+wl7VqyNCsX4vBKUFa3EgNCJOPGuReW4MrpiadF+8LqaE7xMC7qO 351343Q7Hu4nN8bpGeu+vIjhiFzWcPYs6Qboicc0F830mvofqne5AU1AuLb1a3OT474wLQf/l1RbKS 351344WeuFc9G710z88fwBdiV2xchdspgas46mR4zA5is3cGhRPHqH9URSzl0Fb/B/0lObkXM/XFqC 351345CCL3Lb9RqfQOpXLi57+wOsILfRZeQnmLQEFnf7BxMELit+Heu7vYOioYA9fdUzCGVmt/kDVR 351346lj8W7k5DsLOk8atwrbae830ISyJUZPvaI+bgGzQwZJt9EBbcEZKRTc+xc4AlWZC6sOvSEx42 351347PhiaMooI2N4YXVDJDmbZcYy0N4Pf0FSM7m4LM6HnCHtgTkcnzwQxICy7AB9gVRgjiOnDqd84 351348ZE4ZjYgug5DzuFElYclMcOn+GFhpc+CYfAafGKWICLdPNvSAsZYefHjX8JlMet29tYgfvQwn 351349i45guP9wHCk6iWWjE/Dr3/VtkqHfvgBb8DZvCOy9Mqkgz4xBxSUe/MiloWMRjBGTxmOAuyG0 351350tS3RP+cxGw6i8jzGh3RCxJB+cDFQoWQy82pH2PM+CZiSOQGDfE2o0K/nw8OVaiEL/vkqZgwc 351351gIS0LEznTcaIUBvoabGg/oE3LQoKwbPtMbDV02WVB2WXoRBYFylKs5fLLr66+2vRx1wb2oau 3513526DN6KnjTUjFs0DRyoQmUK1qzpmGUvzE93LjBS3GPgM0MyLekM5cKW+ZBsZicNRmxQea0T9zg 351353JbjL1Gn9iD/S3Mm7kAvUJwYTp01EjI8xOPo+yDj3SeUmV1tpbKrAoxtFeNeBy0vQ+A5FNx6h 351354okm1RW9t0QwiQIVgaGoGASm9YMSAlLZkLb5vFRPZj3NHw8NAG/q2RMBKmgJeNg/p44ajb4Ar 351355gtNPyIQYYUrNjWz46IkEVC46L7mLeulDWX7upk9BXCdzSkobhkqUgcZXB5Hspk/BVctOQzBh 3513562jRMHB4OJ5dRSsgVHrKnjkF0gAUFHrT0PTHhxDtqEaJqrcxauhfFde1/T8nKsjOYFmhEjSEM 351357XXshfjIPvPQUxIQ6wtBWNRH5fQjLOtQ/2YPRzFhomyJ0VgElkdQ5pGWVBT14ZVymIUsYA5BL 351358Uz3p3lNFWDJK3qhDb6mAp0wRYeYnyVWPno323UZh8rTJGNnVDvrMnndNwoFXjUrne2b2ZMQF 351359W9L55naaj1u1arTnkojfXiprj4eZvFQM9GbPGuPuhPhjzvWmV9gdY03miwMz/xhM4PGQMT4O 351360PT2d0GfjE1ZYlt77IuJNeg0woIsac1W6bxAsmXcJWY77IkGJkJF/zvYnfdeG7YijeE+El6qL 351361qXDmMO+8iD0zxEo+o0QOwWGy5wSCKlxIdSbvwkXIsvtUMP99rCtZ07pwSsgjwt8XPMrpDwuy 351362T7lBs3G1kk8NCl7vHw57HXJ+2w/Hb6+bwa+5hcUhRnT/Bc5mvfoVzroZaYh0YvaXNsx6r2PH 351363TcV6urMgCHb9d+GlvEGP/LqlhkHxcBHuf67PRBx6+eOAtZ+OsKwswCgb8ncGnbDobv3/y7to 351364PmHJ3Fst/6/r56cdF9H61PfH7Ft1qg3uPvyOoZbMuIRg2f0vHSYsM/plyJAU0r+jCtD5uehm 351365YQTXgZngxfnAxDQImSeUG63JKz5fe7602y/N/17zv9f873/Y9+oY37RHWFKgcpQ9q1fadUN8 351366OiOHj8GgAZm4VCU0Lr2zCr3NOURWNoZn/7GYRvTMuFB39Fj1gNX3r8xGkCE5P4zDsPRWBV4d 351367jIcjkZ20zXpi9V0WrBM0PsWmfmYUU7AMHID4MUkYGR1GyEsPTCz8LMQkboLnTeRVXWt0G52B 351368jLEx6J96AmXyQFXzR9zOP4CDZ/5WALEYkGdNf2tCQjogbFgqMnmZGD80FA4GurDuvwZ/fRbq 351369zbW38QvRy9N508Eb2wcOegy2cBoff7AxrLr9Uw7eFWNNN2u4RaZgTH93uAzdh9fNArWxDQZz 351370mNCjLxImZyI10hXGbmnU0+DUCjLn03lIG+QNU9dUXCZrpPzEMFipIIl0XCcpeCioKmW/J9K1 351371wBp4+iIusRfsXVNURuxiDKqPzRuHpPQNKKqUAslbPqP0ZRk+3JHChVrLcXo8I8tzYBE8AmMG 351372uIHL6CxdV4gNQ9vGbfio+vN/GOSgp5oQa8N4u6OFIRJ89BlZwRdZFyvIvmjBu2Nj4KLL6Hcp 351373OPqmWep9P6Bw00KiVyzB7vs1MoBue3jAj6onaHmLvFgbiuUwOo71kAN4o8TAuuY6T9KeSW9s 351374UmK4Vn93ETpxRdFkOmOxEtmewShnM0Qq0SG7jRyiqE/KYQoSfEOH6KgDMS6Th6kpAxHkNxoF 351375ld+OW6j9vaEPRk6T6IULNxUqNYb+ZsJSCU6jYxuN9fdqZYlJ4XxZRu/CiyblOqm62MOPrNtE 351376CLixHvrQ1ndAj8R0pCd2h72+0MjBLByLb0hCq6qNlTR/QNEff+GjNKHSWom/C67hjRD7ayo9 351377TJ8ramuKVFsUszn2nuKNPxthqTZOIbduZ8+eh8WrNuPw9ddi5w9B9UWMddSmZ9OMolq0fH6C 351378gpzx8GXWnmEoVj748u/V0RiPvpcF2EzeueBVx6M6aH6RIvaf7kRqwjT8evQc8jIDYMixRN81 351379t/FZQ6IGNb07hw3zWSzzsVoyRiM+PH2Nmtafd3z4NUWYH+qNRDnjv++F5XwTYamWFwzjQm3H 351380WOWQw+uPE2JFR8BvxBchWdNQ/Au6ugzDiXI+6v6aiyCPFFwkdfiVhZjZ2ROjDpQqjw//uRAT 351381XXTI4emC8X98Yi9WfjOaWvmqCUsiKB2MsST9M0f0/lKxRQfz3AB9lsC7WcsoRWUoyp2Gvi6m 3513820OPowtS5DzJzi/ChSfBjCcvWMhwb7gj3SZfYC4IR7IZYEcHOBH22lNBx+Hx1Grz0mL5OR1Gt 351383eouCeZ/7jz6Kx7Hp+Tb0NWWt4FapsIJrefMbos0Z5bEncp7KkcDFOYi0tkDPGcsQZdX2Zagc 3513843CrHydEO4Oi6YXx++67udDN8KkCamy5Rdq0xeN9rlvD6fBmpzkQB1vNBdlGtkOhjhWaOywSq 351385DAmqL2GcE1uHJ/Rarb3BgzepYzFwL0rVEACVgXOlfx7Del4cQmyJYCQilRRIVrmP8HBi2ydE 351386o10I4njrcfzPNwru7C0171AmtJTllx3GYAvZ+aq9sxxh5raIWHwWL6veoyhvHZav2oWColPY 351387uHIb8lYmYOKhNxL3en41CjM8iTCqD4cuQbAhyo1BwBwxKaVq7mpvsmOl7TiW7kvG6/ncRDeq 3513883NnEbMeTL3yJpUvZa1Q2qxDIGt8gf7IXFd64nYVk8jcC+Mw7XcnypmS0Rd9fcPszX4b8r3r5 351389DJ+afhRh2Rmz8rYgyZ0hK00QMuMPMVnZIXJC1wyONlzo2MRSb7+W0oMYZqMDro0TzHSVEZaE 3513905CekmEHQXBTV8BXfgRCe59OY+dGBw4j91EuHHf8X2Dec8YjWhVvaeZYcVdLH1jcH2H1v1BW/ 351391FDd8c3ui/ahtx4bQYO6EJHsi0Op5i/cjO5eNqK1tUoyRr2Ic1Zmr1neHEGtDnsWVkFSMpVS2 351392L1FQOI5IOllOn9dC3nkgs7/MIrDrZTNa3x/GUCsDOHTyhJm+GyYTIIwxjljMGEeQ+2bipWp2 351393j747jrGu5EzSdULs4lnoa0nOGW4gZhZWSqxTG58jd4gtAfJ04Tr2IApW94IZM39+PFyu5Cu1 351394UvpYMI1aNnKsopDz6Eub48AYNvjZD8S+0pa27/KHv6C7nR8GD/OFkUkQRg30hH3UduHYf8H7 351395Z2875HHe/O4UZgwIgouVEetNYemBHslrcEHkXSh+fgDS1y/ByEBrGBo7IHzSbjyslQaQPuHP 351396ndMwMNAexno6MDB3Rc+sk3jfIvKOf4jctG5wMDaEddAoLNmQjgB5xbu5HNc3TUI/bytwdfVh 3513975hqOMWsvio1IlMoqUn/Pry3Gnsnh7DMC2WcEKj0XApG59X+Y0N0ZJgZGsA+bgNwHtaqtjdu5 351398V1orCrGouzk4HHKXLi5so74/Updlob+rKUwcwpF+4C5u756EbvZGMLLriikHS4TGS5L6ab8s 351399wKjOdtTzQrqfovG6sXkyInytqfWxqVMIYucdxuNa+RAefkhdmoUoD3Nwlcwdv+Zv7JrYVY1x 35140086P9j/IwhQG5l6kHzOW1SO7uDkuuDjh6JrD1CkXM9GN4rcqCvY0zWv4MPDfBlZxLpugj9Dym 351401UUDIGaZD5KheOU/xbFMvmDBGIlk3UEuU9ZJtfWGqZYCgBXdQx1jj/9IVRuSeDJj7F0rzRsOJ 351402nMMm4Stxl7x7w+PNiCL7nGM9CNueNmBRJy5LMgrlD7HFv74fZpLfqZST5Qh3QeUZjFCyv1XK 3514033SrAuW8hBt+dmY4wly5I23WHRmgQ8GtQnMdDD5cgTDr8ss22v+V80XxCSfO/1/zvfx7CUuke 351404bSpD4YZU9HIzod4Temau6Df/uthTQaxn6bgh7UKlohzXXIp9gxldVh8+mQUSz7CWarwu/SyW 351405528uCKGeUMaevRBszXh9WCN682N8EUXL+ZiPWEbnNI/GgTeSsGf8hkqU17WKCYrpjIxnGIJF 3514061xQtz1kPzJWI7+IEU0Iw6nAt4OTfDxmHXgm9S+pwd0kX2ARMwt7L+ViV2IXccXowsPDCgIz5 351407GBNgg9DlLBkjaH6Lk9N7w8VEV0jAaMEwbJVMuH5K1r55ho+NApmfvx44lfQv99AcBBOSV9vA 351408Bl2z8vH0YR4mSfVP6d8zuIz/YBx+zyey7iEMDkjG+aqOYRtU5iHj+ObIaHh3ZQ0Cmb/pwhDO 3514092ubosfSGQs44Rrb9dGkOupgQmdyoE7LPlctGVGnjTi+c5MpGcxJ6Vp669gvCvZUTlsWH1mPl 351410ypWynw3HUdKgPEegoFqEIxCd5EYtWt8eZPUB4+749XEjkeE/4tkbEWEu+Vn8XgSom0M9C7Vh 3514116JOI/52+jzfVDWgRvZdQl1IFgjd+uI+CA1uxft0GbD98Bc9rW8Gvf43rR3dgw7r12HbwPIor 351412mqRk5vf4fYwLJZa4ATNx6VE+JrrrUVk7+4KsETYTOrn82QPcu/cQL6qaZXTn9vCAH1GP6g4v 351413cxFFdExdKx/4WBH9ybw/djyXM4wQEN0+0xN6RLd2D3YiBLIxuv/6WC7CVC2KZjHGp0ZwDXWl 351414Mpv/7CIi08nuvYqCiXBjyFxvHq69PNsOpiCFbwzaiuJ6ibzbXPsJtS3fAbdQ93s7VQYD35mw 351415VIHTmEdsQUmjLPbAYdJpGPhj1k1CfisYxXYAK/iBdS9OdocuOYP65jyi94ZA8AXFG/tQvZs5 351416P0x6/Mp6qnag3arCLPiQe6LnkqvUW1vA/4w7v0bD1sAFY099YA3N0z1k2mLWXnXRcoSbsh6s 351417jsmnUM7/+QhLdXEKlboMxwzhi27Ikpqk7cWXz2NuZ0J6GgZj3oVS1Da2is/N9vCD9r7/J+sI 3514186ouxKbk7fOzNYKDDga6xPQKis7D7HuvRR8OFLhyMzq5WRJ/WJX/viT5pW3C56BDmDgmAjaE+ 351419jGwDMGjGATz4rD72IYtrGMDcXTa64tfVUcRHOoShdHBdqTx7CD5bWfwHcn9ZhDmZI+DPyAQG 351420fuBdrJAl9S36YP68UQi05sLQNgyThViHOjjGz1hHHcN7OhdMOz7Cdpy7YGjyMIT2XYgb1Xy1 351421zvd/so7aGEgbWGDL2zwWqzXpRQ2TaI7uY3Gw1ubAIemUCsJSRDCqYQnBkjMzMGmAMwwtwzCG 351422x0NiJzMYegxDhsgL5ss9LA1mPeBMXH1hZxMKXu5FPKqQANOsh6U5AoZNQHJPO9bDsq4SV2cH 351423w4Mc/K+aVCVgrsWdZWEwJgemvvsYHFQjrAlN0O2pS8MaZN2QgOWtZLAGMQKqaV9sI4KToOkD 351424ISyz0M/VTIqw/BPlP5iw5JefQqKzK8YVVLAHYc01TPVgAHFJf8V9NemDrSVNX8ViNz7LQS8T 351425IvgTkuTwu1bZOV06CzOmjUdMkCW45n4YvuaKjFURv+4+fultCauIDSh+e1b1oaWtCyNjLvQM 351426beA/aDaOPpMKMVF7g7WANfTEgAHBsDfSA5cIr5HT9uBedasSob4Jz3dGUe8lPa9MFIouULIG 351427Hm6Lh6ehrtjDcligOXQNvZC4o5gCZOI5J4rvwK0P8LnxMx5sHQhrjsTCU63DmN+EyscXsHvp 351428eER4mlKl3dA5HPEzN+L4LZZwVIfEZ0mlery5dRwbZ8Yj3NmQKLo6MPWMIODwblx4XIkmvqwV 35142919Ul3anwYBi8kCoAAv5HnBnjCf/Mc4SQq8BFnj+1CGWeoWdmC1PHRJws2oTBQ7ehRLhm+ZXn 351430MdFVhxoPZJ/+nZC/OiyJe71GcQ2JPSzTMYLxuGMIuVmXWUFNNHeE8EkpqFRqZaRqLTY+2YAe 351431xsw+64edL5q/3RKx9k/M9COEIccBSWc/qQ4HoKKd7JRwWOt8JWGprQcjAx1KVnbmncH7ZsFX 351432Ki2dMHXlaLjrGqHbmlu4tZqA5bruSFo5lbUcVeibD4YndYEZxwqDcl+gWv6CYTzefZj5cca4 35143385Wylrnnx1FPQpGxg8K7tdTi+e/p8GE8tc36I/dVs3rt+c5Q2h6/uQr3NkXTvWbaawOeNEp7 351434RTP7pztGZS7FprwLeFje2KG1pNZctZbhRDxj9W+AwHl/UUX28xXW4EPHZTwKKoTnSMNDrAoj 351435F6y2PUaf+USUkylw13dC0o51RLFmQ8rWECW7vxkjQMXg4NtWMfD17lgKtWxm97gBAqYXKgA1 351436jc+2IdqKQ89EfV3G+tALUws+KvXubnmfjwkM+KBjh2G5krAUKsfh8zVM83bA0Lx3skCFgjJZ 351437jw+l5SjZNwDmZK2cff8JpZ8aqfHF49wEuNn2Q84T9T0uG0tyMW7wCKRm8DCdl4ZY6pnLgW1c 351438HrWWllZyDRx6ImlyEnrY6VGLzaB5f9K5YEI1PdoYAQuyPrS5LuiTlIFpaXHoN2IbTWhPAYl5 351439QfRs07Nj2+hpb8ACg+Kw4EQZ/bUvzIlgY+rHeNALvezJvgxfeY8QUEJDkrlynroi4xHG43Z+ 351440J/oMXdvuSJyUSIgXuWdInes6ZoSUmZiGYQGm1JvErN9WesZ2VHlcVHgFayOtoUPIyh6LCvGp 351441LcMZMoZc536IHxoAU8bTXs8IZm7k/0P86f85jsk484kv00+OqYp+MuO1oR+9S3UsQzB8Ygoi 351442magNhMBzSz1Jc5RKt6Nvr2LuCJl1c3YADKTnxkH1uHGMyV0/PhNTeTkSDxgmPG9UKnjk3h4d 351443HQLvnstYQ5a25ksNAbr6Sibd4ya9N9F1xK+8wN595lHUIKHu9nwEGjBe37/i8ZePOBlvR/tt 3514442m8HXjS8Q95gS3rejSfnnaD5HY6PcyPAmRl6LjuM/0Vbg0P35nO6Nx+t606jc3hnsdE5Gh+t 351445Q7gRUfQD5+OvOjkjpplTEetjRJ+l75stNjgTtNbhVf5U9twld+N2KfBOgbCsvY5pjDyjbYH+ 351446G++iSkTsfynF9YPrsXz5r9h74QmqRJ7+gka8uXkJz+u/D3Gh2sPy688XzSeUNP97zf/+J/Kw 351447bHmNPZFm0HGbjCs1QgJvRThMmLtG3xhcUx8MSYhGr5R8fOCrF1FEFNpR5qNP9I+rQtCvsgDx 351448dhxwONoK9Tgc8nu7eNa7icijM3z1aVQS2y5E55v3P+Tm38Tzzy2yxNiVZYiwZXRnC/hETsTK 351449w3fE+rtIpuWYh2Ly2p3I3boW8ybEISmnmAW46+5gQVgXzCp8gP3DbIgsYQjXfmOQMXU8pmz6 351450G2U3ZqFL2ALcIed7U8lW9DE3R9CwSeBlxMGTy4amvC8V+uzp4Sx09U7AHxVSP5N3+fL0IFbM 351451Vm7cKh+RSGZ+RP278Rn1IpKQeiwyno58fJbqX1selu4DxmJslDuswlbiwRfZuyp7XA/Ymsp6 351452eEl7AzBG0IVrhsHLNQorheHImHBeG+ekI76rHewGbKdkhzRxVPdwMwbbkXtY1wFxO5+ISWh1 3514537nQmRYOeCsKSuT/LXpag5HkpKhv5OBRj0a6BkCxheQnjnZQRluFY96iR9i/BuyuyDj9FXYXU 351454z8K1zxgN+jKegAaBmFtUqyiDaxvAxt1XHBK224Tf8a6FJXzfn+Yh1Iwj01euay/08zWhXsTG 351455FgQkZ7AKm/5YcVOibze9yEWMNYd6c1k4mBGCxhTdV/ylEKKupSwf4xijSm0HJBdI9Dd18IAf 351456UY9GNNvYEyZEprUbuQu7RtmT91QkI/lVlzDZnfTbLBIbD89AAJGNjLquodFmJGfYVUzz0qOE 3514578OKDixFmxJCSWTJhhhnP78PDbckzuOi86C7qRHNCSDfeH89QWlrKft59whe+NL7Byn9t6qT/ 351458Yg/LtmRsMU5D5OU9pS0y2MOI5FCCRRE9L/YASsvlntsR7OEH1qXGKqas8bGYlHqxE/1MhXus 351459I9iGqF1CyP+1NhI2+tbov+oirm6KhaO+Obozulur6F6StEXDbl9bgUif3siYO5h6hzOE+Y3a 351460n5OwVAenUIbvPNyTyEZVsRqKQwRLlq4ze98iNrWRYQgWF8mG62wPP2h8nIOBwX0wKi0LvMxk 3514619HU1pFG5RN+r0wat8+IgspLG0ggI06elYkiQhWKd9rAMgiHPGhCBEeMzkD19GrkzPWlaDn3/ 351462WezaaHmL41NiMHTMFPCmZyM9IRx2Qs9wPTuCEU+ZijF9nImurAuXlN8pISmNfWgZOKFn4lRk 351463TRmF6MQdQuxDhGuQ5zj2RnL6eES6EtyMY4nITcJIZB2q0wY+Iq6jA4vOUpEKpet8R8KSGjod 351464mwBvriJGLjYmEGMHHJgRbH9MDBtlUIx1qINj/IA6BoQLSpqUhD7OBlQG7Ug76hmjSeaUiao5 351465PC0V0R6GVBZwn3AaH1oFPx1h2S4Gog4WSDiN0ylOZN+ZIWLHCzQJKnEh1YXgYw4YfbJcBWEp 351466yvNkMQh5b1vVACkU81eGrX4oYcCZ+Ms312GEt7E47wBVQMy6IOvkW9ZLjsl7sysFQZZcGLsO 351467wNLLH/Dp+lx08YjD3pc1eHl8JqIDPeDTfSw2364SWvY14vXhNPgbaUOHawJ9ouQYBfFwtqwZ 351468tTeyKFgl8rCTFTQKkGCrJeNxQ39fcRrDqYDQBSv+/sKGhE1civyiw4jzj8PhonwsHZ2AdX/X 351469qyXUKyd326lDLcHGwdV5NE6VC4H0qgIkMv01YMLsCg+FT6cQZyXpa0cJy9aqP7E2yoYCpX1/ 351470uSsTq1iecNOx6IzxucXiOgxI+dfybjC3Zb0LlB9aBUjpHIKByenImjoavV24FKAz6sKCkaI6 3514718TbsAjZ0H0AuilQ21C1j3TPuJN2UsiE9/sQ8mn/MBL02SARb6tVXchyz+9pJQmiSjWPXd4Y4 351472Z55AUI/izTGw01VCINoIlWA5hUfh/7V/YXEfOxhoE+DYIRQjeL/iyM2XqGn5dqJa0ELW+I0j 351473+JU3HKEOZKyIcmPXZ7GYkL3/aySsmHCVnmOwRxgrnAK+Ib2wtriB9QZzcEfy/mJU1pTi3PxQ 351474mNoloqDkFEZ0FnpFknH6eGYMnBgBzGsarlVX4Nx4F2pB5pF+WWIlrYJw1TbyQvymu9RdXzx3 351475UmtSXZKJ/+mkcO2yBhHfnOtB5K1nwIahplYZR4fQMKBaWsqAfzXzBKojAIrGxrwvfv27Tm3P 351476QGXfL7l+A8u7GELPNghBtnoE8FiOG9eXqLw4Fl04hUyiVOl5Z+LUxUWy9URGJ2RMFsrNT/0d 351477Ye5GkbejynExhN/UM+xFrEZ7Wm22RwSl4KnIExosiO8EHxOZO0Hb0Btj9pYoJF//JsJSat1T 3514784bKmCpeneNAwrjLrXvAZV6a4U+tgv1mFuLkqFIbmA7DvyR0sDzGExcD9uHsyCQ7aTP7Q1bLW 35147980xse199cS7StUosqalwKgwXy5xPHmmnFc441ouhFHmJTmyY2cQ8mRwDKseBX4VLkzzgOOI4 351480yvht12es2kqFhIIIvHm6OxGu+gZwi12Mrbm5yJX/HLyoIhrAZzy7nIfNqxdj/pzZ4I0JgyVR 351481yjhO42lidPHzOfaIP/GBzD3Zm7+Pgh0jXPvNZAX9ur/Yc52QL1E7JOQsv7VFeM6JlEDFNsTr 351482nbQxN4CMv44lwsbw6P3KSwqBOUfynDbHT/QMbVuMOMbk0mlF2bERsNVWsve0LTFwzysqt9Rc 351483nwZPcqdo27PeCR06OwiI6uVtBV2GrFx4WWwQpNo4wg7x+R/Q/E5orCT6f9kRDLaUeN6r1U8i 35148447FjLnpfxjNiJUIZ0JPIfUz4d7XmTp25EZ8HRAjdJkW+MznVGEBLxwb9F+Xh4l9P8L62RTzv 351485Hd339UqMNihAbsJEh2gg4MNEuOowoccOsgpo1UWkMtE5rIfh6DOyf33M4NjJGcb2CThVcglp 351486DPBmORh5QmOulrLTmOTJhmhmwoQ5jjqA18K9yXgLDCBzous+BZeqGlGyuTcB45SEWxc0ofR4 351487Gny4TLitgdigLNwWMx4rb8iEJ1QgLIns++rIZAQaa0simdTdxbIeZlLnqQ5MvSKQlJ6J1JhA 351488WNiPYuWcH0hYfsv5ovmEkuZ/r/nf/0SEpRwOQEFgBtjVtkLM+p0YLYyUxG9pVRIyUDlJVHpl 351489BbpRY8XeWH+zBC9fvsSr0nJKErDyRC3eljzG48eP8OeeBDgzhoTG3bD8wkPyO/L7kreobWVz 351490iX+6+gvi5DAFHfMuyDzOhq5mSIcsL0J26LthcFoSutux6SvsBm3EgzoJQcWx7AHethO4dLsE 351491H6XyPgmqziMpMA4nnp7DGAdtAlpn08hLEsPiE4gLTKL3KTX+dY5Ebkk1wSomwlNfQlgy8lx+ 351492djdYEwArfXcB9vPIz9ZhmJb3hOrUVeeSYK/ddthQpTkoRf0jOIHYq5G8a/KeJ9RwVrp/ys9p 351493BkxfiUGuJjBxi8Gq65WyXg3t6UlMrvYYe+hxzBA4IgOzhOTq62dvUNPUgNIT4+HhykbKknix 3514945GOKD5caeIbOKxTnlFT3Tq++Oh3+BioISxWyQkv5RczrZgZtcq9Grb1Fc5gKqi5grKcZzEyN 351495wOUawsRjLDVsPDnWhYLUFiEjkRLNhoQ1ChUaUBE9/EleJsKsrNGNtx8Fu9MRYkl+zs6nMnrl 3514962ZGwpnppLPI/8lXiKaKPWeRuvGbkEBHhpmOHwTm3UV5bjts5g2HHrH0dBwwn+tAXfhMBd5Ph 351497zER56Lkej0UeLwTXeLC2B0yFOhbjDfhYjuBu+XAB87pbUK8px7htYm9BtfGA71yP9b64L8w5 351498aY6o3SV4vi8a5jRtxzLc+yJpr/LcBCKzsXkbi8sKWfKSwbyEYfBpnQuTWM9JX0IqvReeUbpu 351499mHRRQjQ2lmxFPzPWW1ZEPreNOYjwDdWpI/4LOSzbimIijdOseiCL8y2+9AeyGSNxBrc4d0Qm 351500KkiHsIcfWpfIxlbDcbpCat1VnMJwK+F7UvypoUPtipwHri3rxZJMNKqWVAogcVvMuqlG2bm5 3515016OnNGnPUMGGLleEkPxlh2R5OoezvxBEPlKyVJVeuYFm4KcV/tQ0cEblCkjuyPfyA39yAxlY2 351502amLjF4LHXpgKTz3J9+q0Qc/AymIU7MvBqiULMFdFHSbKw5ML+7FhxULMna28DvV4P7wFa5bM 351503x5zMWHjQ3J6sQQuL3XzEvVO5+N8y8pzp49HbTpcasLsOmoKZ5N6emT4YbszfMLgSYwQghX1E 351504SuvGfKFMJcI1dN0xIf8FKior8TJ/HFx0mAh1i9l7qSN12sBHJO3Yo2/qdLZOcigspet8T8JS 351505FK1Myxih8y/gbV09ygoXIsRIaEzwUsqZhcE2CFbMRIKIkYoyqBaO8b3rEOJ9ufBOqL+7DCEd 351506bUedqKTS7Rx9h5riHRjpZQ1D5sxhMIm3rT8dYdkeBqIWnsR4oxdm0D1uEb0XpdW3MJtgOByH 351507RJwU8mFa7VlWqgQm1BRspUmZ0mvrEensiV6hdjSUhUHgPMq+KngZVt/A/FAPxO5+gYbyk0j0 3515086ITsk3/jxsYBcOspvLBFCpWOC1LPPMK5OWEw1SbCZvdpWBTP5CskxFfqGZTLE18115DBeCwK 351509LekkHpYHMdBchdeiv3zorvbfvd3xUlZHGngWhctR6mHZRl/bISybyy5gQU9LcIiiESaVb0+e 351510OG2pL8Od3DFwZ+K+Ww3GAWG4QXbcuTBw6o6Y2FjExnSDPWNJwjGFd98ELCwoE4eLkVjtbKLe 351511nIzAuF6YX5QJ50tBQV0PTC1kwytWF06Fhy5jQTFWRtGhiVyF+St0nJKQX9YqYym6trsxVaSj 351512cu6iqrEa9zcNgBVDLHSTWOMx4SbLbv+OrasWYcHS9fjtyFpEWDDCdRa1eGo/lFohJjLhaDkm 3515138IqahBV7zqP4k6JHmLohYRVCwnwqxvk9KzApygsm5GDSdZsofu4EFw4Zux5YL0WEUOLdfzhO 351514EeGWCanczXWEWDhjcjp0dkvE6bu7MSBgHEtYij3NdOE+mSgQ5JmfzqZQBUPG00zBK+sLSs/y 3515154E8OJ22roULwQmSB6PRNHpY7pD0svzZ0isjaWuztyUfN/d1YIsp72E6I328KCatjAU8vS3qW 3515166buNxp6n9bJhgjr0bp/xem8MXbcUFNr7Gp/b7Fs1XuQOIkS2Gbokj6AguDIPy/EXqmStBi+M 351517V+5hKc5JMBcLV2zEbxef4rPoDBJ5Q5H2Ui+qaE+4j2Tby8JUUe4IAy9M+P2tODyxGKD6+zKO 351518bFmI5FA2b6bIAlEtwlKsIARi3u06OWMOSYQAfuU5THAVWvuePCb8mZz/1z/LnjFH2Fw7JuEz 351519saCfBQyZvJf11TQUlb7zSCyf4Ad9qoBfpVZEYmsosYDPEgUOow6iVNm5KlKYlChHIiKiJHcY 351520BSv03FOR/75FvXGQNnRRBpa0Q1juHWjZdr4dZXdV60cUTJN4dbdJ/hMFbqFYyFvIKm62CcJc 351521MEIDIgNJ3mt5AyMReKDQhvg5wjaU9cVmVJvhj1Q+485ClohX8i6LxP1Ygs7cbzR2sIjAxgd1 351522Kkk6yXPZNSOoPMsCBOL/q6rfRj9FCr3U+4rXpkiRV3Pu2p8bUTuBmH+7TsaKsIQAgD1EHplU 351523oXVC9KoiCiqqR1hKQqKK8xiJLTjrcXdJMA0j1nP9DZya6Aodjh1GHWcVCUHrOxwaYkXljwnb 351524l6KHpTcmbV+Ibha+mLJ1FgWAjXuwHuGi/v69MhSGTF/J2ZF1VWItLGh9j6Mj7cBhUhOcvIWd 351525/c0UjckYj5/C+ehqqg1t066YXygJ28bIDPsWTkZcZws2d3DgLNyQChukQFg2v8ZvNFwVY+wV 351526hfHz95I5vYwZE1fh7JNKfKl9izu/r0N6tB+sjYxgFzwKK/54jQb+/w9hqc75ovmEkuZ/r/nf 351527/0SEpVykJel7euGFfIUclkq9deT0HQUPSwa8EOb0+jpMoRal9y7i6LalGBduQ+VwSlwwcqjI 3515280FffH3Nu1RIddAv6mEinOahG0YoIGrZSbERt4ockUVQeRs8N64LZ5y9iLsEZOFaRWH/rExq+ 351529VKD0zWdUFs0WezAypOSx9GBYcokOHDkM/sZShCWTl9jWCJ1mXcTHj8zPpui6+JpCvkyF8NrS 3515303n9KsANx/4pqqIdlqGt/zBgdjB5L76CW0YGk+ve1pe0clnJ9EpKrq8OMxHnuzPtvFXtY8quL 351531sKI3Q5zpwSVxP543ti/jK6a6+IIXZ9YgNcITps7tE5atnwqxqAd5JscK/VbebHfMWytvYduk 3515323vAw14cu1waBQ+bheIlUVCiGrFjcFaa2o1Dw8SMuzuoEI1vWEKjmWgbFLhgwdfXDBsX3UhES 351533tvFpDnoy+rAlmxJJRIYPs1RFYo+WmQ9xXSILLZEj15gQzHkj7IVjvgdPpEKbqo0HfOd61Bv1 351534zzk0/RIzJmvImIi8MZi9OksUUo7/CWfHOhMZh4mMc5vsyY84lWhPvSQ7LRKCoEwd6pHBgWNK 351535ASr4FShIcSR90IHz2LP4xGflwHvLQ6jcpmPVDSk8ciaJsAFdRwycuwFbtmxhP7v/wMsGKQ9L 351536bXskCFOG/LCQrz9hSFgZnEbBw5LFKkoPxMGOowPHyLHoaq7cw7Jd7OEH1qXEtbyH5ctdiGjD 351537w7K9dkWE3ou8sSwuStZP3PZiSe5GkZGMjh0iM5IR6jMUG+6weoLIW1NfFIlKDezin6yjLk6h 3515386GFZjeL9yXClHpZDqIGnQp3aZzgxO5x6jIm9MNXADz4UrsWY7m4w09VWji+og0E0vUTuICux 351539jqm8nXIUZPi23U7LWxxOcBSHJNeSd4gg59+piR5STjNtfLiE9LovLVPJ6sYKzlXK2pDHT762 351540jhAfUa/OdyQsxRiEBPeRYBByxtfWI3CmQsnz1cExvncdK4K5C3F22T2kZjtq8APSYzPzaC4m 351541dBuIlaf2YZgyfKYtDOSfrNMOBqIOnsSeobdYspacJbsLVhO5gAP7xHwaRlspYak2MCEc+BmT 351542ouBkaIVuKTxkxQfAxMgLw6dJ5epr+oQnzytZT0phsv78c0KBRU74YgWVzyhaGAb3oblUqBXl 351543t/z9Ax91t2Yj0J212mPaSnEgk6rjjJTT5WhteoeTmYHUZZgRlk27zEBBWYsSb7Y3OCDMYTnw 351544wBuxssS07a+vHDD/WqG+3TGU9+JTEtqP6e9BYQ7LXpueUSsMJtyZJ81hKWv12Z4Q1PDyKNKD 351545jKm1Yf8VV2kIOhmiuLEejVKWcC2lexBlJhEsRYQl6+mo7HAzRd/tz9Fc9Rrv6/gyQjlLWEpy 351546YQqaX2H3AHOWsLzyWYaw1HFPx1UpslzQ+Bjre5pQ9+FOC/+SzU8gzpHKENBs6BEm5yJN1C5t 351547GcWQsHyJh0LJrkGw5nDgMPokG1Nefi6UWRJ9eY+7+ZswK74rHLlMDj5LBERPwvLdhLz82Ni2 351548pbH8BciQlB8JSbl7OSZF+8OSyfHHdUTX+FnYlH8X70V5IUX9elmGOmlLJ0aoDu6N/z1qFHpY 351549uiF5XzEqa9/g/PxQmNgMwqpFEXCLYMMAtr47zMaHVtYnqVx+ShU/UXgcoTLG5HgooDnCmByW 351550O2RyWH4pL6Wh6FTlRjgxSZTDcvF3ymFZhcsZnkRQkM03oW5O0m/LYcmEdbyOjYOFBhgeY/Bb 351551yZd2PYRUCn8V5zDJXRe67pNwroLfbt+YBMdzqSUORzYMI78S54R5GRwJeSbyBBI0vsJvIx3Y 351552vAwTzxEFT6BmvtmPOJPiTP/OKfGQ2OtP0p6UgqgkDOmDX/uwISt8slBYRfZW43vcuVsqk7NV 351553nOfSYQwuVKlJWNbfwYIgA6E3GZPTlk+U4fkI4rIWTeKwrWSNFE5lcqvowcrbHeaEENQPmIM/ 3515545c75xsfr0Z0oadr6ZrA01Idr2mVUE6Lh/aEhsNI1gY0JYzFnhWFHy8Rz3PAoB/0ttWlsdt6B 351555XRjDhF7ScUR8XqkMOavOevjyaBOimHAsBr6YpiRcbFt/Lx9KvCOEZeOrI0jztYBH8l48reer 351556d3eR+5fxPNDSdUZSXgk5m/ioupzOgjby61WZVZVIcaOWfayV4YBdL8Q5lsVWhmp6WNI7Sc8L 351557mZelcoeSuastK0V1c3selqKw0gSgyGeeQcjr4yOVewp20BJNNaHogaEpvWFL1qKB1wQcKW38 351558KiDiqyyrxRZ8dhgpJPC+PFiFMDU9LMXhnzviYangFdyCxhY+NSSqLC3GxQ1DYC9v9cqAvTaK 351559uRqpdwnjVa/riczrNXSe3x2Og422LBjTULyGhiMy8o5EmK0OdAjIefYjXywDPM3pCWMiUzh2 351560doWJ3Ujkl1xBpqcJHAIdifLK5EK6JZY1Gkt2YQhpQ1vPEHraRL7ssYrms5QYDDDeAOQOCh+G 351561zmaMsdRaibEUcy7d34iB5O+1uN5IO648J3vT8+3ivOLSoKcCYSl6fyZX3KUq8TNa+eoYXv3z 351562hKU654vmE0qa/73mf/8TEZby9wqRtRZSWcsKgzfuknhYkntfXXn3fclV/NLLjIaw9Ew9iLtE 351563p6ltZtNjfCyvk41cJErVwBXiCVLkp6ClEsVFD/ChUYoEucViCtqOQnyg6QVyY6wJeaEPt5FL 351564sGJCKMyJDBeUlifJU8ZE53n/EFdP52HLvCFw0ZdKESKow53FIbAJmoA1S0fSMK+svkRk4EHT 351565kBxkg9Cld2motC9SIVlFHzFhyYTjLliMSAdz+CRvw6V85mcL+I7dp0DadQRXkPQvHXuOzkUI 351566qXv07EwEeibj0PU8oudL+vcjCEtV5X1RHtYvXYil6w/h1gdh/q+GEuxLcCY6mjbMeizDzSq+ 3515676vWm644pQgPmqsuT4a6rSFQ3Pv4VPX3azmHZWnkdy/swhtmW6LX0qow3p9oG+NLETuNz7Bvr 351568CwuHSCzOv4RtyT4wZ34ueEMxGUZ3S2MMmokuZN13IU4/+yybm1MFYdny5jdh6FkJNiImMfV9 351569kH7ib5SUlAg/T/HocSn1MlaHEBUDn3q+mC4iApsq8eZDvdp4wPeuR3Uxqq8rw0d04Tm1kHpg 3515708ctPYrQDR2l7BgFzaVqc1rLfEW+vvA7HPh4nyogOUX1VmHpAGXGgOocli28QOa/rQhR+bJHI 351571caI8tP/lHJZNb5E/2ZvgNNowj9gqm8NS1H7dPaxgjBOILKytJZvDUm3s4QfWvTCJzWEZsekx 351572m9ufEI2Pc/qxpBmTH7nHOnEOS7XbZaL6HZ0EX0ND+I7PwbaMYJgYuGH0nqdsKGF+OU4lOVKv 351573f22z3lh7V5TzVtKWx5SLbJ5NNbCLf7KOumtTJb6pbYZuC6+z76YMOy07iiGWUoSLGvgBayRP 351574sOolh3H5RhEubR8FJ2l8QR0MguhKyYyuZByO1UUfCb7NR+XFKbJ11GpHWMe0N3Ie1KLpzQFE 351575SxP11ReR4si04YIxTJSHWpEHoSWid7+SwYKaqt6hrJbMS50E+5COLiXGPuqEuAbp16hNZ1FY 351576WCj+XLxQRHNLdqhOG/iIuI5hCJbdZe8Ktg4fDZ/e00iC8vOqbJ6V/Y4pcmcPBPV3sbATeZ62 351577LYYfYY3WvtwXylHWw3CEnN3itkR/I9e2WjjG967DkHDC96q/J+xvB9qRLk3vzmHDfEUnJsb7 351578lOaE1NaDsV045lwoR+2D1TTcuZbFQOxnDEjUwED+0TqCdjAQ0dy1gSfReuScLl7TlfB4FugU 3515795QcTMSbHfq/oYSlSGuZvwLl3TWiv1FydCk/7WBwra0DJ1j6wC2VzIYjbYzpqawin0MFISY2F 351580r60X+nV3pJeh5YCdeC4d8o68RM2fi9HVfTB2lrDCWys56IbbmcA7Ziziw6wIEbkCf5P2maTj 351581x5OcqMWDjnkQYtPYGNFc4YVk6DsJx14r5sthYie/3jsIlgTkdxpbIL6IHq8XxeC9KrbwV6eo 351582EupVbdy26jB5EPzsBlJ3cekx+XQhEz6MMmURgpGThaFTyYT22/CIvYzrHmDb9DSkpQyAK8NY 35158361igc9x4pE3fRsPf0HYYqyM/AzY/gvtATJ4hVAKl5rniTAJ8/PsjcTIP06eNRZQ3G7KR22m+ 3515840sTpqt6zsiAejpb+iExKBy8zBf3cmFCv2rCIyJHyWGhF+dlJ8NDThpFHNCZMm4BoDyNqQRc4 35158567rEy4K8f1XhNHgzZIbVIOx51Sz7/MYSbI+0oO0bew0k7UxEjI8J+7xISQ4NAeNl1SsKYzJ4 351586SI8Pp15f2mY9sfquXFg20WFYeYb1ZJHzlBCV5uoSFO5fgbQBvkQRJvVsE1HQAcVObAGsaw7f 351587AWlYsb8QJdXNULkf5Q81RjhKdofv1AKUN33EuUxfmkuMxkw3tYExo+wb+hPio5wenKX7Y8ia 351588Z/ZKAKKGj8TIkcwnDv19mPxm2rAdcRTvpWNji6ykZ2QgoRtrvcwQaReEuUMbX+4nBIkeVTKs 351589Og9DWlYW0kZ0h7NLvOzlQtvhITsjBdEBFrQdLX0PpP7+jjVikH+eqlwObeyj5rfHMdGbS5VF 351590M79ojM3MRtbYfnDUk55PNS9SJfUU14bs//mfb2NdtC3rHeM1HnkvGmT/Tpucf53C0aNHD/YT 351591OQWHXje1+27t9Y0Bh98cGgl7jpaCgs3MT4KLHg1J4dA9HulZ6YgPd6BksZ5zAva/aFT7nKLn 3515923OOtiGEAd20DOPVIkGlPx3Ywtj5pUNkekz9uiocwnNieV2wdG12Ye/fGiAnTkM2bgBg/Zh0y 351593OQMUvRNV9ZFaz67oSnMYaxs6I7RfL/hbsqCBY8JhvG2RtFNzgyVEWQFbMVwje0belFJuLRGT 35159495buHbEFMPN74+74VeQl3vAYm6MsaX5Mf5q3sgXvjqfAlZwHuk6JOFTarPadwHiKr+ttxua2 351595c4pE2gxFr+w2/761DMeGO8Jj0iXF8M7Sa1kJocCul8PIiGHWpXo5LGkOJUYJInemfa8xyMxI 351596RHdHY+goDQfKxq1PFsetN0Dg3CJxDsviDRHUQ1Xb0BX9xmSCN3kE+o/azuZx4NegaE6gOE9i 351597Ms1hqS9n/CHJBaFj2Rmxk3jgZYzDsHA3SkT90Z6HpVQOSz37XhgzhfTTXkUuRqm//eaz43Yp 351598Ls3pAhOi9Jt0mYUL5S3tnjUd/b/SftIcCawRgY5VF4xIG4cB9O5lwrHny+WwVJy7gNk3aZ4k 3515995XPT/rix41KA0d7e6D08FdOyeRgX4UzbYcKDiAwJxNbPWobwHJKOmUuF+4Dc+Vv6mrLgYPdU 351600zJ83AT2ZXGUKIOMzbOptKgbD3CdflMktW/eX0HCO8aruvQUlDWX4fbiNEGRzwlhh9ABBwxNs 351601ibYCR8cecbnXkDfOldxjJui69JY4XxQTFjpbFBZayxg9NjyRKKDMe/iy4WSNfGIxdabyaAuq 351602xkqBsBTXU/SqaHff/j8QluqcLwLNJ5Q0/3vN//7nJSwp4BtJQ4QxOSwNTX0wbEwsIlNP0hyW 351603Kj0speUXost9LlqG7mYE/OCYI3DIZMyYlYmEHuQeWP2gTdlXVud7hHXhxtC38kWvIQkYkxSL 3516047s7C/FaxEvmx5VMRNo8NpqHPGJlPOre4oOEp9s+fhw15f+BKUREu78tAAHmerkcGrgmNZfmf 351605/6KpU3S5tvD2doK5PkccRcM6ci1uC73gmbyNOQtkLeUXbLwgk9O+8U0BFo/OJPqTQOZnVaW1 351606uhjnzxShrEl1HVH/qNcH1wPDxg+Fu4Fi/zp0fn9FhKD2ysM13WnuUyZsqbGjtziPI/305NF8 351607g9LyhhHR4ycyeIAnm+tZS98TE4+9kYylGoTlvjg7Oi76LoPAW7YSK1eSz4bj5I4XqP/e0vk6 351608iQ6TOXoxCt40yvwsjSu9y5+KACNtsbxhau9O140xDR8pm8PSr+s4qh8wnjtHk52JPMGBaeBw 351609ZM3NwvBAU2GoYw7Mg1OwbEsuduasQFZcd/RfLhdmXjRuygjLL/dpOgtmPVgGx2HCxAT083JC 351610/+3P1cYDvnc9/qezGOusQ3Vitz6xwnojEdvHnTob6DiPpUZlFMxkzhoTb0TECdsb2hNOzPrW 35161198WMm7V4mzeMgqYcMz9EiurERcKPyQeqbYPYQ29RfioZToxRYJAEw2oPc5DFN8iZYOGNHtEx 351612GNDdB1aOo5TgG//OHJaKYyGL0+jYRmP9PRX4GMXvJtBwvPLkr7rYww+t+zoPyW760NZ3RM/R 351613UzF1dE84CmV9JsLJgqsS4kbddqtvzkeIMRceKQfwnPHEbXqD/KkBMOL6IvPcJ1b2/W0orOlZ 351614pw/78FGYItWWvnsK2fNNamMX/2QdtXEKuXXLRORatHIT8q6+kniaSv397APrMSVlEiYN86d3 351615gLbtcBx936oWfkDz9JM5cY4Yh6xpY9DPg8nTK6VbqoNBiAytOKbwHzoJWVNGIszeSLaO2AlH 3516160k5PVzPoydS5hTn+bFjVkFETkdjdns6phDxjyEd9tr/9xyJ1sB+sbV1hzeDMRm4U18jOmozR 351617AzrBjuD4IplKjH1wndE7KQO89ETEJO8S5rCU4BoGjj2QkJ6NbHIvjuofBHsRztrBOqrwEek6 351618ejZdEEfqZBMsPb5/IGycfoCHpeh52mzaubiJhG+gKeH04T31HJsTtj3CUh0c4wfU4br0Q/Kk 351619ZPRz4dJ7viPtqCPj0hzPOf2E7YQifvJ4STtjT7D5T9XAQL5fHYKj9FEDb2kLA1EDTxITuSXb 351620EGGmJTQ8SkD+B4kcq6UOAaUanGggwmhX2DKhsxo+4lSCE9wnFaJaWqBqfIFji1MQFewKS64O 3516217bCusRNCE1bKCHxUAK+5haXh7ojZ/kzK2qAWD3ckI9DCAMYuUVh8sZxarrFC/X3syx6EQDsj 3516226Orow8w5FCNnr0JWuDklrIwCMpD/RpF05VecpwC6jlMyzRVJw4p2M4KWaU/8qsQK7usIy7YJ 351623L2VjfWdBEOz678JLecCeX4dnx+ZhaCc7GOkZwNytB8ZtuIIPzfKLQUu1haCqOlLzXHt/A5J7 351624+MLeRA8cjj5MHPwRMX4N/ngl8RpTZ700PM/DnJE94WNrDF2OLozs/BGVvgU3yuUAfDK3j/Jm 351625YpC/Nbg6ejB1DkP88tN49UUqdElzKX4bakMT13pOvSQDOEorg2tSesHLigsOIaK5Vl7olbIG 351626595KKRS1d7FqiB9sjXSJwm0Bz75p2HS9XGz5Iv8ebBg9HTiM/E1sdaV8D/Dx5d0d5O89jqcd 351627UOQE9U9xfG8+7rxTPbYy/VI41Piovb0MYWbW6DPvFJ5XvsWN3/6HZSt24OzN09iyZiMO3f4o 351628fr9dkeb0cAhaIPFQpQDCtWz4Mpeq9RAcVBpjWxt6JvYIGDAV229VSjx/mfd+fQ7r0iLhb0sE 351629ALJezFy6YNisPGo5LNuONjh6RrB08kOP4TxsKXwr9uRVuS7lczm0cx41fbiBndNjEeZqAa6u 351630DvRN7ODTPRYZa/PxqIb/jYSlcC9zQ7Ds/hflpFzVn1gTyYIHXJ80HHnVRq4MIen1rYQlu46E 351631lo7y+52xjCo9j/WTByDQwRT6uvowdQhE1KT1OFfaILGyUnN86Xp7mo8VhAj2t2dyBgvJcSIU 3516327XpQ02Z7VDBbG04FZm6nBeS8fY6ji8diYKgnbE30yZ4lZ4StHyLScnD1QzM6cifxG17j7IrR 351633CHczhwE5Q4xsyVmTsQO3KuWsBmtvsdZsNH8FG3JC4Tn8cuSPtGVBEsarXFiHDfXCKq/SHvhP 351634t0bT3LIG/jxcEoVGaiYAxBgXmoPSefThjisCHcyvKk0UvM0bAnvvTAoAdZSw/Bpi4tP1dYjv 351635ZE3G3QDWgSOxZONUBCpdrwGYsn4xRgRYgWtoh7AJu/B3jdQZ3/IJRTsyMcDfFoY6HOibu6Jn 3516361km8Ewp4/Jr72JkaBjtDsobdIpCxeDz85BXvlgrc2sVDTCcHGOtyoMO1hGvwAIxbfgKvGttf 3516376/zaYuye1A32RlxY+sVh/tqJ8GPAEVGO4x9BWDL/b3yJg2PcqIe4VcSaf4SwpP1qKsPVnIno 351638603mRFcPxg6dMZSc3cU18h7qgUjfuBSjAq3p3IWO34H7UkCoZG7YcVuwbgoFftslLOsfYvP4 351639fghyJue1DpOH3ApefSYg58YnsXzHKABPcsch2MaABfCkrPlq7m3HuC52MNTlwspvCKYvGwdf 351640A/kzsBkvc6NgQcO4+oB3vUZ2zivPY5wzh4ILjDdlHfW67AUTLVmLyIfrmUT6BAwfmosXZC21 351641vD+BcW7kPDAKwfwb1RIAYlkwG1bItA+2lDS2v7fl73RRiF0pjwhlMiafyVtKIx6woYX+DYTl 351642t/ZL87/X/O81//v/P8JScsdmYSDR1/S1iV5g5oaIhTfYvIBqyC8iQ9XKu/swc1gwnIieqWNg 351643Ca/eqci5WaE+Ydlaidu5s5AY0Qmuloasjmnjg74TNuCKUH5k7ogWalRTh+Ltg2HLpNmQitzD 351644GKFsjnEk7yHpp65VGKYeeiHGHuhZW1eCkyuS0dPTElw9csd59sSYFSdRUvcVZCBfKj+z1M/f 351645Ur5n/9qVQ7WUz0d7pTDNVTGUnirZVscCPkGuMNU3gfugedi8aBCcje0Rs6OkQ4Ql693y7X2X 3516461n9apIyoW5TgEMza/lx8Amsmx5D72orIJtqqx9G0L7YJ0/nwa4pxaN5whDqbET3NABYevTEx 351647pwCXd/MQ5WtN2tGBgbkzgggQvvpCmWxajbYIS9Kfqrs7MLmPJyz0OVTG8uyehF+uV6iNB3zv 351648eu+PjaREpCiKkDQmN5lJfcSxw8hj73FkuC3FfLwyCiUGmITczYtlsSCvrKvCUPMM4Fkk9cxa 351649FM0OoMZvlgP3Ym8ME53MFH02PVMCnirHHJThG7pEx7FwD0f8ot+pPqE2bvET57BUHAtGDjeD 351650nVdXDM3ciIKX9W3r9QTs3kqdBeR1TPWwhx9Zl54TbwuxKTMGwc4EGyA6jpG1F3omLEDe/SqZ 3516516EXqtsuvfYTDOcdkooQIGl/j9KZ9uFvNR9PL3RgRloCNv+/FIkKQetuQdUP2s7lzMAZnbkbh 351652u8YOYxf/ZJ0O4RRqOuLMPbIJib7m0Cf4vIVXJKYfKWG9UdXAD94XLMVQP0vytyrwBXUwCKbO 351653tbUYGWhF1gAXtp0TsWJLpkKdsgtLMNDDBHoGVggYvgLH8+fIplEhuuT7s3MR4WwEPWMXRE2b 351654hd4W0uRZM8rOL8YgLzMYcK0RGLsEZ15X43XBLxjfzxe2xkTW0TOBvW8PDOdtw81PLWphH2rh 351655Gv9Qne9JWLJYWTmub56Efj7MHacHE8cQDF9wDM/q+Eqxb6XPawfH+BnrtCtrEIJw54hgQnIn 351656ob8vOzYK+IwaGMj3rPP57mYkdSYYEMHx7UMSsZjBx+TnUx0MpB08iV2Hb3BwqDU1QLSPP0EN 351657IlUSlj+yiELCKhMw/9F+CJrwam8s7HTN0X9rCaoKefDRN4D/jCtKCbGvKV/oBm2f8JIuy0Ns 3516580XtziYzCpPnl/6c8I8ClhVMC8kqbf9o+MqGUHueOhoeBNgxsOyM6eQp42TxMHT8cfYJCMOH3 35165992LwV/MLvlpR/Vw0jw2fIcx7oPmFyUlzE0u6mUJb3xOTTpVp/jr7J9ainBJrFLYaD6Usxptf 35166078EAOz9KdhQk2LYb+kjzi5RHQ8NnfBHlbGU8lw+ylrIGgfNx+xvyQPE/5iPWSktlSLCffq11 351661cO20BTT/14vIY9O8/068aOr4uzOhYJZ0ZiMFWHUZhWmrTtDwhdKE5Z2d8zAh2gOGjFWu9TCa 351662D+ZnIiy/er1pPqGk+d9r/vc/DWH5b9Dj27u/ElztERSVhPFDfKj3lr5U6CmRbN9U8wGlz5+h 3516635FUZapr5mi8I/QvkDXUIy59Fd+Rrvl70nyj1DzZgNO8syls1fz41v6jC4xpQVd2o+Xte88tX 3516643RW1d9ciQfPPGM1fC+QcKXtWilq+4D+DgXTMEbIFpXujYK5th1EnymTOUy3NXx4/pjDhcS1/ 351665csJL88t/4aJrxse/9mNeQg94WhtB39Aa3v0m4tfzpdSSSfPLt5XjU7rD2YhDw/NYD8r9KiD6 351666v1oanu5ArLMRjL1Tcfyt5p9zP3yvy4WtWpBzGWXNytfjkwPLMXuWYthvzS/KS9X58ejcLREz 351667VvwPq+cmI9RSB1ocC0RsZMOuf9V8Nb7CiYVRcGDyMruk4lzlvwcQ1XzCsiPz/BoFuWuRHe0I 351668PY4DEo69V8g/q95d3oIPF5djqJ8V9fzR9czE9RpZwvK3aHNKaBo7dcPE3OIOKzU0bEuwA5xc 3516693eDmJvy4OsEhOBs3agQdPoOkw+d90xi20y/N/17zv9f873/c9x3aq/8GwrLuPn6ND4WbhQF0 351670dE3g3DUZ665+1HzDuv+AvNH4ZAN6+4/D6ev/Q0+/cTRnqeYXzS8/ZF3yq1D063RMTekJe9eU 351671n/rM0/yi+UXzy7/wjGl6g9MrspGR3B12mn/GaH75D2Ig6sp3LRW3cWTrCqSGmEHfbSIKKmQx 351672M80nLDW/aH7R/KL5RUXZ0occnBae6D1eEm5K84vmF80v/61S//d6xIc4w9yAA46eCRw7DwZv 35167315+oaPmGsLlUSOOAax+OjMMv/1WRE9i+ty9gypd/H2H57Q2JxorDdUDP7HyUfmejFlVpB/4/ 351674inhdKAm3p/lF84vmF80vml80v3z1vdJBeUPzi+aXH7ou+ZW4kO4PY6IT+I7NUztamuYXzS+a 351675XzS/qHXGNL3C/lGuMNQ3Q0Dqoe+uP2p+0fzyT8lvqjAQdeU7BuvoYqgDI+e+mHX6nUz4e6b8 351676H9v4+2fIJsw6AAAAAElFTkSuQmCC' 351677 ) base64Decoded asByteArray readStream! ! 351678 351679!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:18'! 351680dejaVuSansBoldOblique12Data 351681 "Created using: 351682 Clipboard default clipboardText: 351683 ((FileStream oldFileNamed: 'AAFonts/DejaVu Sans Bold Oblique 12.txt') contentsOfEntireFile substrings 351684 collect: [ :each | each asNumber]) asString 351685 " 351686 ^#(12 15 4 0 6 13 20 33 44 61 75 79 87 95 104 116 123 130 136 146 159 172 185 198 211 224 237 250 264 277 284 292 304 316 328 337 353 365 378 391 405 417 429 443 457 464 474 488 498 515 529 544 557 572 584 596 608 621 634 652 667 679 693 703 708 718 727 740 745 756 768 779 791 803 811 823 835 841 849 861 867 884 896 908 920 932 941 951 960 972 982 996 1008 1018 1030 1041 1046 1057 1069 1080 1092 1103 1112 1125 1136 1147 1158 1169 1180 1191 1202 1213 1224 1235 1246 1257 1268 1279 1290 1301 1312 1323 1334 1345 1356 1367 1378 1389 1400 1411 1422 1433 1439 1446 1456 1468 1481 1494 1507 1517 1527 1540 1550 1560 1572 1579 1592 1599 1606 1618 1626 1634 1648 1661 1671 1676 1688 1695 1705 1715 1735 1753 1766 1775 1788 1801 1814 1827 1840 1853 1874 1887 1899 1911 1923 1935 1942 1950 1958 1966 1980 1994 2009 2024 2039 2054 2069 2080 2097 2110 2123 2136 2149 2162 2175 2187 2198 2209 2220 2231 2242 2253 2271 2282 2294 2306 2318 2330 2336 2345 2353 2361 2373 2385 2397 2409 2421 2433 2445 2457 2470 2482 2494 2506 2518 2530 2543 2555)! ! 351687 351688!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:18'! 351689dejaVuSansBoldOblique12Form 351690 "Created using: 351691 Clipboard default clipboardText: 351692 ((ByteArray streamContents:[:s| 351693 PNGReadWriter 351694 putForm: (Form fromFileNamed: 'AAFonts/DejaVu Sans Bold Oblique 12.bmp') 351695 onStream: s]) asString base64Encoded) 351696 " 351697 ^Form fromBinaryStream: ( 351698'iVBORw0KGgoAAAANSUhEUgAACfwAAAATCAYAAADP9F61AAB/CElEQVR4XuVdB0wUaRsm2exm 351699s9kNBAgECCWU0IJiEEvsGnsvsffe69n72U49bGc5sfeKXaxYsWLDBhZERZTelrKU3eeftrMz 351700u7PLgt5/nvMlm9zJN/PNfPOV93ve531eG0D8RfxF/EX8RfxF/EX8RfxF/EX8RfxF/EX8RfxF 351701/EX8RfxF/EX8RfxF/EX8RfylukWnK0Xy/t7wdAzHlFMfUZB2F5sHh8G//Z94kFMh/g4SfzEp 351702pcn70MPLBz22PkdORhx2jK4Hv+aLcTOzXPyd8x8tmqTd6BXkgVqjL+Db13MYEeqBoF57kKTR 351703/aB1pgxpV+egvr0SNabGILPC+vvqtMV4d2A4gmyd0PC3KLwr1FpopxyZt5agubMC9q72kCnD 351704MPtWDrQ68+3pNCk4O7slfBzdUW/4FsS+jcWSZo0x76Ha/DVF8VjZ0BYSnxG4mvYBezs6wca5 351705M/Z/KrP4bFkPNmN4Ay84udVE18XR+PyD+vcf3SPKM3B9QSM4KIMx4VI6KnTWPbM27xHWtHeF 3517060qsr1tzNQrmZ63TlWbi9tAWcFXZwsZdBGTYLN7PNf+PilxFoYieB15CL+Ja8H52dbeDUcS+S 351707y3Scvi5B0qHhCFTao+mf8SgUaFunzUXcuk7wUHmi4/IYpDLfQqfT4NPJiahlp4Cjiy1kjq2w 351708/mWR4brcGxjnL4Wq7u94kvEUS+qpIPEdhZgc3Q/cl8n5shjt/R3hWnsA1lx7g7i1bVBv0nXk 351709aHWVXKtByqkJqKmyRb1FD5Cvrfpz6bQFeB7ZGz4qN7RaEI1PJVqrbImvF2ainoMCDi52kNk1 351710xorHaotzj722+D0OT2wEDwdPNJ24G3FvL+O3Bq0Q8bK48mvVDzArVA55jRm4l/Ea65rZw8aj 351711P86la3+qeVSWdhmz69lDWXMarmVpqzAWtChM3IvBASo4N56Jk0lFFvu0PP0aFjZxgsLeBXYy 351712FerMv4NcC2NApytC/IoGUEl8MTomDUk72sHRxgXdDqeYnbPstSXJiBpXE7YOdTD+4GuotTrx 351713b6biL+Iv4i/iL+IvVhcb8XeB+Iv4i/iL+Iv4i/iL+Iv4i/iL+Iv4i/iL+Iv4i/iL+Iv4i/iL 351714+Iv4i/iL+Mv3FV3RK2xo7QSJ0gXezko4NpyLmLSy6t+PcFCXlZaiXKtj/7+iVANNaYVVzn/x 351715l598vGjz8XBRXajkTvB2UcGu9lSc+1L68zwfMd5Ki4tQUmYgVWjLSlBUVMKOSfEXfn9lXxkB 351716H4ktGq16joy4eQhTyBA0JRb5uh9JYipB0pERCHJtitXP1FZfkxw1DrVca2HErnjkVVgirlQg 35171752EEOgSEYeCGW/iS8xaHx4TCvekqPFVrzb57zs0pqN92A56lPMO+iY3h4eiLtgsv41uZ+ba0 351718aWfQz90GDq02IzH9NiYGyqAMX4A4tYXnK3yKJQ380G37K2SnXMC02sEYfiHjP7Em6jQfETW2 351719BlwaLscjtRXkr5IkHBoWCOdaY3Aw0TzpS1eRg7g1HREQ2h/rbqQg590RjA11R5M/ngiSh8jv 351720lX5uADxs7NHirwRk3JmGEJkCteY8gNqoDXKdevpXZ3h598L+5FKjvxUg/u9e8HVvilmnklDE 3517217lU0aa2hXxNM2vcUmZmPsLGHL3x67sUHhhCoSdyElg42cO93Bqkpx9HD1QaO7bb/MHIs9Rzq 351722OCxo0gLL76Xg5dEZaOntCO/mM3D6s8bKNVqN19v7EO/XAVvflFRxfS9E4t5BCHSrj8lHEq0i 351723cZFk1vTri9Dcrz5Gb3uItOzn2DEwEJ7t/0ZCia7S9Sft/DDU6b4bCSkPsHV4Hbg6BaHb6jvI 351724soIYXPZxLzo52cC56yF8+haNQZ42sGu2Fq9Lfr55VZJ0GMODXNHMDAlVqG+Kk45gVA1X1Bq5 351725G8/zLM+9iuy7WNnWH7UHb0Rsag4S9o9ADY8WWBNfaL6Niq+I6uUKG8e2iHyXjpvjAyBV1sGi 351726x4WVrAkpODuV+FbBA7AlLrtScqD4y/eX8oxYbBhcH16OLgjuMAdR74t+GZtaV56LpPhHiHv0 351727HMn5Ff8nW7YcxeoC5BeooanQVdOuqYDmO+8h/vIfHK8VGhQW5CNfXVStcwV37BWXWwhi0Zai 3517286Dva+S8U8RP+xF/EX8RfxF/EX8RfxF/EX8RfxF/+xRK3uiWcJEqEz7UcLSr+Iv4i/iL+Iv4i 351729/iL+Iv4i/iL+Iv7y85cKTSEK8gmnQn4BCku/TxlHV5qEXZ0C0HpjAoq1hXhzYBRquoRhyvlU 351730lInfKfxLFG15CdQFzHjR/FxKSrqKdFwYEwi3NusQryYJE8cxobY7wn+7gK9l4h9/4i//0rhU 351731x2FeuA9D+LuIabX80Cfqq9WKeeIv4i/iLz/x/K7IR1J8svhV7v6t/tdpUZS4FyObhKFO52W4 351732m1MFFUXNBxwdGQSlgliTNz9CjgBxS1f6BdFz2qNOrVDU6boajwq0/+f3K8STJU1Qb8p5fCrI 351733xpON7VFr4Cl8+0lIZjpNEo6Mb46w8A5YdCurSkREkpz9eE07uMoc0GDGOaSYIU+TyqffLi9A 351734xzq1EBreCcvv534X4VFXkY3bC+rDTuKA5mteoEhICVZXgezYZWjhLINTo5k4+7GEbZN8ntTz 351735kxGqsoGNjRPabn0LzU+4n5elRmNW23CEtZyG81+rpsStK0vDlTn1YS9zRavfr+JrqTnyfhZi 351736V/dAfWJ+1G49G1czfm2FeF1RAiK7ukMqD8Hkq5lVsuNIQv7zLd3gKbdFrTGH8MaMarVOm4e4 351737P1vDRUKML0UtzI7N/UcIvhVZsVja3Aky56aYG53yfx/DNpYnKcNItyE6wakDdn2gozfe/t0a 351738DjZu6HM6DeXp59DXzQb2LTch0Wjx0JV9xoEuzpD4DMPFTC10+bGYFiKHY5tIvKskSkNX9AzL 3517396/uip4ChTn7ExJNL0L+RHxyVSrjU6IhZRxJ4BgC1sEW0gYvCB/32vkOxzvzClvX4IBYNaoEa 351740bnaQy1Rw8glDyz5zcDSJH7HBfW/uYKCilx78gRZOEkjduyAyociojRIkrG8Oe6If7Zr8iRfF 351741Ru+j01D39mj4B+KL/htGjOZdJDoQC7PP4BNILec/c1nWExxZNgJtwrzhpFLB0aceus/YhbhM 35174289GspV9vYNuiiRjQri587GX0mCP7+lSa4MQj++zr3UOImDkMnRvXgJeTivp2zgGN0HvOXsG2 351743yO+U92wXZg/qiEY1vOFsK4eMWAhc/Ouh8/h1uJRcOYu/IicWS5o4QEI9H/E9G5t+T7IU3P0N 351744ITIb5j2Mfqr6WPasUGDRKUHqg8NYNakHGod4EX0nh9LJF+Fth2FVzDcWxNNp3iGyraPwvZkf 351745KYF/Ocvc4laETze2Yc7AVgjzdoJKLofKJQANekzHtthvgouQTkv0953dmDugOULc7aBQOsK7 351746ThdM/vsmK9H+S242xDry8vgqTOrbGrV9naGSKWDvVQfdZu7Hs38oFYuuLAXHBnhDqv+ezl1w 3517474HOZyfhP+KsFtabwvrvcDq4B9dF14gZc+VhsZu6UIedVNCIXDEP7uoHwcFBCYeeGwAadMWLe 351748FkS/zmPXXKF2JDIl7F28UaNhBwyZvRnRCXmma7SZ5zP8ZAjmRLZWtT7vXV5fwN9zh6FDvQC4 3517492ZFzmljDvWqgceehmBlxCHdSuIYjtx0VGqyI5xmf2m8n0ceNblPqPw43cq27Tvi9bXn1LP2t 351750IicOG3v5QkH9TQ6fHuvxILv8O9omf87otO8jD/wnx3Pc0oawY+vYodna1ygx9x0c2yDynSHa 351751kYqeracy6R/D2M3Gi7N/YdbANgj3c4GtXAaloxdqtR6MBXvv4qsAaG3220vksPcMQ/tx63DF 351752zNqsK81C/Jm/MNO4vTZDsHDffaRpdFa3J1U6wa9+N0zdept4Tp3p2nxnDxYObYdwYh0g21HY 351753ucA3tBHa95uIP6M/U+umTv0IC8KVFtdm/c+W2O8p28DseCnFh10d4ET9TYnwBY+o6Nqz/d3p 351754e9g3x/oE06hSLbFHzQljnsGhBda+KELBvemoIafbIKPL2TYIG+/UYP1a44Iex1INc7/gAebV 351755Zu7j2hX7ONG7pR/2oKurhPqbPGgCrmRqOQfSjzg+Kogey8QBr9HCm1Rqmb1dXel9UxmO+Q/y 351756ed+zIvMG5tW3Y767E5ovv8f+rTzlELq6VN6frj2O4Uu5jv+dNxp/Z3f0O0PbFFtbO0AWMg13 351757CwTGSNkn7O/szG/DuSsOpZQb2QOPsW3qQAxbcAJJxd8PTOhK3mFPH2/IncmIYU2176OOm4sw 351758BfncCoTNizOJyv4nQKCsi0PhTR6YbOzRbN3r7zsY5TzB/tk90cDPCQoJPf5/RF/UtqIvCu7P 351759QqicmXMLH1n9d16fz628HW79WnMeih9J/IeKNjcexzevwZo1a7DlRIL4geJqzW8NUm9sxLh2 351760teBB2FgSGykCJ95GHrnn5d3AGF+JMAagK8bLiCaUvSGR28O7bm8sOf/pu4COwmfL0NDZBZ7e 3517613vA2/nk4wa2tML6gLXiB7QP8qX1J5t4Bf97N/iFOwB+9B1Tl/cRfV/x1xV9X/HV/5rrVwZgF 351762McKsRDyO/4gCS+pTFXl4dXIVxnSsCz9nEhNUwtE7FM2HbES8WhgLyX5+ChETu6FhAHF+VBD1 351763fcLRbtgCbL/2AYWErUApc12biCAZbfPVnvcABewZrRiJ27vDQ0qf2wNGHDdJH6nTpCHu8HKM 3517646dIQQe72UMiIM6q9G/zDmqHr0BnYcIUP/JMqPjnxh7FoQFMEuRDvQJxLfet2wKiIGJ4aFlkv 351765Nao/fP37YPnvveBn64Ve215Rz8w/yxBn5Kg/MLpDbXgTOKnKyRvhHUbjj+PPkGWGmKV+/jdG 351766ta0Df1dbog8VcPAKRxcC83qR/++TzqryPrnXx8BPwj3/SeE//iZttxAOtltrB6Gehy1sPeph 3517674J8xZp1sVj1XcSJ2jm6JUC8H4hsTfomQ9ph57D2raqXNuYU5LWiMSkraQg0GIuJWOk+xpzzl 351768CLpbcdZ16X4EKeXVf9bS9IfYO68/mga5QiXl3ps+01h7Xix6EYGmDo5oOHYGegXYw7f/biQW 351769aXl9sntCB9T1c4SM6Hu/0THIMbp3eU48ji0ZjBY13GGnUMDRrzEGrbyAjyXfN9a0xSm4f2wd 351770Zg7ugAbBngSeLmNxe/M/FeoveyaIr1W3RC8bh+HDh2P4uKU4n2KkgFaaisurJmIE+ffhozBz 351771+2PBQL+yj/sodS3yGd16n8BXM2ugNdjxL39NaRJ2duRgN04dsSe51CoMIyd2DsJVNlbhdzau 351772PRGVWvHD8fUfiZP/f+urLODdprj19/6dskOeLEZdJRczJvdWV/jUaISOw+Yi8up7k/P+v4Fx 351773i/XaKu+hAni+wsEDNZr1wYwtV/AuLQHHpjaEq29/HPxYavCvVxFD/5mvqSpOnqMVnm/1lj61 351774St3Q4LMfiQ51/eBC+sVVpC+kB2bujkNWuZDdXIL3+wfAV+6IVutfWbVf6srTcHVOAzg61sPU 351775E0koFlIWrcjGneUt4OLcAKNm9UWQyhN9Dn8WDGDRaT7j9MwW8Hb0RMORfyP2zS0satpIMEW8 351776Tv0Yi+ooifk8FtfTk7CjvSO1fh8XXL9pwl/9qdH4rM7Gk7/aIXTAz0P4o/gXH49ieADhi25i 351777XlXX9L1KkXJyLEJsXdBicQzSynTm98GHf6KNmxPqDp+FgTVs4dZ9H5LNEdCIM9CL1Y1hK/HC 351778kItp+HyoK1wI32Pn/Z94302rfoZ1bV0g9x6EqJQykzbVLyPR08uW5/vU/63g2QZ0dHdArREr 351779sbCDO2xrzUJsrpb5ewVxDuoJVxsHtNn6Fum3JyGQsL/r/v7EZPyTabVfbmxPE7uUtTD1ZBzu 351780nd+FlVP7oeeMy0g32StKkHR0Mhp7OsK76QTsfPgWV2c2QLPlz8z4YMuRdmEqaqmIc+Kc2ErT 351781whv8i7mIW9OeOBsEYtD2eOSZuY7kPr3Y2hPeDjXQb+ZI1LF3RMsNr83ym8q+XcXqWX8j7ksi 351782Ts1rD187O3g2HI3dr9Rm/KnM3HDphsOfv+HCEC9ICD/jhoSSf3W8l34+juH+cjg0X4MXVnKk 351783yPXwUxQ53l3RYuEVpJodv2S90Qiy80KXhasxLEQFz77E+crs/CjAvek1IJfXwPR7GUjY0Bz2 351784xNgffCHTIn9Iq36BrT28YOvXG5vicsxiz+qHc1Crir678pTD6EacGx3b70BS+g2M85dCVX8Z 351785nhXyr7VM+FM/xJxaCmpzUYTOxgMGMLGW8KfNvIhhPhI4dzmAz0TnFT1fhUa21m1E2rTT6Otb 351786BwsfqU0+TvLBgcRGY4vaE/bh9p1DGF9TSTm/170uYQ3ur9EkG9gOdWbHIL3c3IerQOb1uahv 351787LzE1bB1a4++3fIerOcJf+bdoTKpBPIPUHd12vhN0ZhQ+XYp65EFCWRvz4+h3yo3bgkXrziEh 351788txBv9IQ/dQHeXtqIRRtirZJZ/ndIUJmImRwChX0T/MmRMCYX5sLEvRgSJER4kMCp1RoqElDo 351789O3ylFmyja2wbYdXzIjPgyiusaWpn5lBCtNV6LZ4X6kw28seL60Bp5jCjCp+P+xYALZLIcHR4 351790AOScdryHX0G2wIHi/ba2cDTTjtR3FK5ma02Ml+i5zeEqFbrGQFLQz6uh3hILh1EJsWAdE1yw 351791qA1jS3d4miMjEt/0jydq02si+8JPIQyQhE2/bHaO/ecdnQX3MKOGXPDgGzj+CjLNyOEXfbyJ 351792XQuGoE2YFxyUCti6+KFO+2GYvz0G79UVlkGH27MRxj3EEhvLjHsFJnPwIrkZWwAkVPUWIc6I 351793zKItIcbZonbwlJu7zhHtdyShVH8osaIdiX1dTI9ONSKWVXadK3oe55CLqlhfP2cuLm4PL7kF 351794UEbqj7HXc8w8lycGRfNTPagfLUA40/dO7XciqVTg+SjDVnhz59fzxtBLhggc4b9pUfLpLGY1 351795dmL+3R51Jh/Hey5oatS2OcPCtA8l8B3JX5+KXm1EGyfO2iH1w+hrORbu4YT225PYPa38y1EW 351796kOb2D2WUfYvB8o5enPXR+CeHT89NeGa0xlozxpQ1JuFCGp9sVfo1Bks7WGpPAd8+W/G8oKrt 351797OaDZqqcsUERGfzxe19n8mkn0UYddH6g5o3m/DW0drQEMCcfDmGvEvTMQPciTOcAbjRddLm6M 35179882fATsMeEP9HQ9hS9X0wMibH5ICS+Hc7ODPvHzr9OvX9Cx8vQh2lHlgwGJGapO3o4Gz6HhSB 35179968o44uBEP6vfyGikV3DndzauT63B9L0zOmx7TxMeK3Jwb0ULOEno7+0/5CCSmJQPmVcnIEhO 35180038936Bn2AE3tq8P0+yp5zSFe2o7cG+MRIK2kPyXOaG8U9aXTZuHSUG/+d7ZtgBXxtE1xYaAH 351801cejvhRPfBA79BXcx3WjdN04lQ5J013b2IBwZ9D5YY/RhvP8BhI8y0p6saY+A0eeRVo19lTzY 351802J+/pyABJHuh/Nu0fT0dA2lZPl9aDilpTAjD+Rm7171WSiMgubgaQnxn/1Xsufl8MOJdusS9I 3518032y1xU0saNCPm13BiPlrzd5M+P5NWSTvc+u5UYIv4yz9TeAfouf88+fXXI/sRYNzTP9HcUcKz 351804E9tGMmu+JcIfsdey+5v+/OM/BjE52u8ixHUYcgZpZhyj/XqZkk20eU+xpZcPtcfIVLaQE/uT 3518051LU1lt3K+K4UOf/EHlCV9xN/XfHXFX9d8df9metaxpgfYHaoKcYsZJeRwTs+JKBtDrjX5uA+ 351806cfZwlpieD+yarsEr40Brwrn4YH0vM7iWDZw778dHBkPT5d3BLOY55TWmU84mal98thZtnOl9 3518070bbuHFzPrDDadx7jr+7eFs6ohn2U3WvjiXu6SASf55MRpqfNuorxgTI6sGrBDWSWG+97zxA5 351808IAQ+zScj8uorfFNroFF/w6uYbZjSwhch/SPx1Ch9Hem0ynp8GsejY/H4VSLevIjBn62dKAym 351809lxEG8/8uVX2fpJ3tjXBYe7TclEj199dTQ+Dv2R4rop/gSfQKtPf0w5DTX6ttD2jzXuHChYdI 351810zilBCeGQ7eMh4TldyrNf4Oa9N8go0iD36XoqXaVxisr82KkIllWGHdihacRLs06+Ss+XX89j 351811Spgt72zVl/BpFCasR3P7qp0XdeXfcH5iIwT6B6BW19W4ZxQErVW/wcWoszgZ0ZbAJJzQcU8y 3518123wmc9xB/tCCwLynhhJ57DHfjorGspTNxZndEq78S2EDUqp750m6tRd8QWysIfsY4gg9GXMn+ 351813oeflpJ2dCAc4Q8L43XD+oNRHNneGO4Nt2NaejovfhMlsebcmIlBKk0YarjQX8GsddvxrX0P4 3518149GKmoAZ3TVeEYvaDylMbawse448m9laPFduGK00EOqzC13dWBV//Ppz8/1rfCBevDDP/7r8T 3518153/rLsR7M3DI3n53QeO5VHo72b2DcYry2yqSOSvF8CWRKJdyazcbJ94WccVZ1DP1nvqa6ODl/ 351816XPN9xhbJIulXMauunfCcl3pjUNQXQZtIV56Ba3Prw9G7Hw59Kq2EM5CHR2s7wMunMyJiM4Xv 351817R+yHr7b1hp9PR6wm61Rk4tqs2nCpt5jwY2pN94brE1Gv7QY8+fQIu8c3spgiXj+neYSYBivM 351818CiyRKX3XD6oHTwcXBLef/dOl9KXV8BajkaM7uu1KqjSAluyv/EcRaOvuhY4Rd5FdYZ7sV5S4 351819B/0DPNFqyTWklVUQe/B81HOpjTl3cs34HdNwuq87bBxaYlNiBu5MDYZMEYZ5caZ7bsn7vejr 351820Tfg459/jkdo0H6MwtqYbwicexTsjFbbSL2cxKdQVdaacwicN4S99txPdPb3R50gKZUvqdGo8 351821nFMLClkIpt3JYPB5YaxfV6HGl/tb0dtbxvIXfFsNx7y/juJGQiY0RudZbXo0RoR3QuSLT7gf 351822ORL13JwQ0Gk5bmaUWxjrBXi6rh1cnWixjcr5NEV4s3cgAtwbY9a5T2ZtXj2BraZHQ8w895l4 351823VqKdiJZwCxqHi+k/RnxIl8vMjbq/40nGMyyrr6JJsjm6f3m8lyP96gzUtvch1qOUShXsyfmR 351824dft3NHXzQ+9Nwkqi+vGe+3A1WnkQ9bbGI19LtHOJsB+dG2OVmfTsBlJkdxxN+Uav75WQIikR 351825lDE14FZvCqKSis2uJeTZJYklgVt/FlPfn4macjlqTL+HjIQNxDlOAq8hF0z4KRYJf/qc/ZR6 351826Sq8oNqrIWsJfwf3ZCFUQh9O1r4hBXIoPu4kXkQVh8q1cMwZ3Is5FjEXHOj5wUkpZxSq3wPro 351827OC6SitAk5bpJBR2JR3+cIhy1Ol0Org4lN1QvDI/JpUlnryPRzUMB986b8cIC+1lX+gF79JFA 351828zq0RcecbijSFSH9zG4e3HsJrI8KYEOFPV/4VZ8cEUpuwY8t1Ztmn2uzLGEaRtAwHtvQ7WzGh 351829pTfsPRqgUwsf2Hk0RqcmxP8TE3/khuuC0Ya0414Cn1HXkfsvbUAlCRvR2pEwOEYSDmnORCKV 351830hebVo4EEmUcnRNxMgVqdhGPD/WkjReqPMVdND9MUifPsWqzcuB/nLh/C5Fo0YVDiPRSXzKjU 351831adPOYkSLHpj19znEfciivtuXmyvRigHfbGwb4o/4IhOjI/7wThy7+QIpOcUoK1Uj5fZadPag 351832x5qNXRNEvCw2a7CQkp/OEgnkKjljHDmg1eZEk82WHJMxo30pQ447b8wv+Dm4s7gR7USWeaL9 351833/CN4kJyD4rJSqNPeIPb0Mdz8YlntR5v/EEsa0H0vcWqN9S+EF6uKb6cx0JPuI6lbe6y69hF5 351834BR8RPaM27awnwKTGf77ggUmFz1ahiT1tcDs2nIGoV5ko+BaLlc0ZlUFqo9f83xb+vKRYnIlO 351835QEE1lFpKPsbg1LUEZFkZlaRJPoZZU1bhaOxbZBSWIDc+Ep0YZSvbRqvw3PjAX5SMKxEDEGov 351836MXtosas1HLue5wsbT8UJ2NjGyYRQZKLUVhSPFcz3tnFsi23vNVTf5D7bjA56sNhIAUxXlopz 351837k2sx35n4lnVHYuOllwxomo43tw9gUb9u+J1jqPHaYSIltcS8SUu4gr8G12DuRcx3/1GITquw 351838eJ3F71rV+uS7TAmjiU9kn9boixVRD5CUWQhNaRFyPsfj2sHVGNN9JA5/KhNuh+yf1yW8sZVy 351839uBsDIMhRc+Z9AzjHu64FNiZoKn8Ph1bYzJkX/L+Rc6YIuU+2EsY1Q5Am5n6n1beRbnRgMW77 351840LzOGBa+enqREGm6F+gPjB+zr6cEn0ji2w/YkjcV7OHXchQ/MXlRAGRam/UMCtyuI9UDCGNFB 351841/dbgYkIGsS4Ta+y9SAwJUrBgdaMVT3mkC+GxXAH1+1PsXkACTd0JA7+cbS8OfzR3sqI9ezRZ 351842Hc8LMOB/Bzq6U1eej4SDQ+HPAHXKOovwmHE+lbxeRxhQNMnXo9NKup2ycmjyvyLx7ilsnjMd 351843W54XChtv29sxDgcFas83JZuQ0aRLmWhSk/FSkoD1ze1N9qaM8wPhwew/eucFe1BNO49RAfRh 351844RurRGweYKMjiFxFoYsdE6E67QylUkCStZysaMHOI7qsWDMiuK/+C4/08mUjDMMy5Z7pekXZA 351845Kwf6WkWt2YjNKULSgcFMH0rg3HIlHnCIHWS/r25sx37nv99oqEN+/Ib2DNFdAofGvyM2u8IK 351846kCIG8xrqlXaVCB59DMnGZJPi51jViP7Odk0i8NLI4Rc3vzaUFvZ82iFpCHpx63MS37R6Rc4H 351847WNNJT/QwkN9/FOnv+/ZIDpD0f4rO0pWn4HA3F3b93ptcVu175cX+xqhRKlHrt0v48h1KD/y+ 351848ML9u/+g+X19Jn/Pqk2PwRbH4mWWV9rEWpSWlVXb+GYiVxNnt5Dfxp3aqar8T55PrEwLptU5V 351849G7+deY88TjpCS4Q//XfTpMdiaUM7gzLG1+oDVFUlm5CkvHVdPCGTOqH+2J2IS8/CyyMz0cJN 351850BqlzMyyMSatWCsR/ag8QP1FI/HXFX1f8dX+Vuhbt+NQzmNAiHOHhddByygUensjfg8jgHX/U 351851JADtAjNrNXnGaWrPEPzqTMXR5xkEhqZBXsoTXLuVbKQeVIK3O3uyQVzKgN5YdfYZPmdm4xuB 351852/+6f0xlt5j0wnP8Jp9KjxXVpvEMWiAkx2SjPuYsljejzmcSlLdY9UxsREorwfDWtbksS8uqM 351853+gtn7sQj4U0CXsTdwJndqzCpezcselDAuaYAd6fTgVQS927YFp8DTUkuPj+9hKgrySbOIMom 351854KixAfkEhSk2U/VJwYmQIAvvuwCsBHFyrfo3dA4IQMjwKKRysWVeWgQe7ZqNPk2C428kNjmCK 351855dJH1rzk+q/s+5sq9GTXg3T+acopQgQn9fSilbaGAkKrg7uSZ9uWOfvBV2KPRkgcmah3asjy8 351856iZqIUKUSYbNu81RAytVfkZyUhCTO792zk5jZQH/WlcGbmFsv1NW3Lx6S516uzUKdgQuRET0I 351857nvZNsfZVyQ+229WIWxAOpTKcJ+BACjN8OtCNCvQnsx3EF+roObOqEYVJuPU7j4wqYrxUKrqL 351858M1BXj7/KXNBg6FLsPHMTj14k4O3jvejprleL64jIh+94fZ30IQXZPzh1sjbzKiYG0cGDMr/h 351859OJdWQTswY2ajji2Dn3r1ROTrQjMZWUrx8cgoNA0n1sk6bTHnds53Yce/9DWF8YhoZkzac0aX 351860A58t2vikSlHC5nY0WVzqgd773yCBxe7kCBy6DZdu3sRNzu/O8zQeQYCPr0vhVH8MNl/Wk5Iz 3518618O7uUSwf0hvLH6n/fzj5/7O+Eb5SGWb+3X8n1pUHJNFDT3A6mw6tVoP8L/E4u7KngcgvD8L4 351862SxkGkuK/gHGL6dqybzexc89dZJTrTEgYuU8PIfLCRxOfKUX85rbVfw0uEW0Vkm3dj8TgQIVB 351863gXb+Q54NWB0M/ae+ppo4udC4pmxThSN86nXDb9vuIK3UVPEsXu8DIBUDf7+KT8R6lfdyB7q7 351864S+hg/7G0IrL4i/jLf7moH69Eex8HOIe0xqAJw9HYRUr55UImXaiWsIL4C19VVFFrDh6qq9+P 351865JHfi5qV4s+Q8cfRnDmLG+P1jvjuLhL+82xMZhRe+FK0lwh/J9j3T38OKCBm+84WUO9zY2Z16 351866UYnKAwFedlA4BqFevZrwtGMYp8SBsDzlILo602orj0gCoD71GqMGR0ve2kMZMh5nvlRurP7R 351867kCFJuffCkRTLObeNCX96CfDaZASSPBiTrpqXdKRTFKsY8uQJA2u/LA0xi5rBmdnI7etMw9kU 351868807Jf5vwp6tIQ/SYAMgdWmL9q2LexE/c3Jo5IDmgxQY6TSRp5H070YtR7zMlk5lMelLZkTmQ 351869m3MgUfVK1SgsM2L9F79ERBM7s4Q/wfcpeYW1eqVAl6448KlM8MD95fR4hCjJKLzRWDqqFg2Y 351870SAMw4Wau4D1p9UGDTLPFjejpH2hkRxuzYbNumigGVu6QK0T8mpZM3xPG9/I4s2S4ovgVaMCA 351871DB6DLiCLSVmSfrYv3PTRTtwINAKAvD8rlCZsymtiOpPbnAJxCOBIoZ/Lxmmuy1NwpLsL26/G 351872qRAr+7uJwzArATF7lmJk60DYSfhzqCol7+ZY+EklUHo3wcB5kYiO/4aSKvR3afJedHGh56p7 351873nyg2nTUJNKXF/oUh4W7wbTkWq/ZFE4DAB6TlFUJDkoOIA39S3HlsntySiv5T1JyCS+nlJmDV 351874l6gh8JUxh54OnRCiokG+kGl3eYeciq9R6OWqV0wZj5v61LMFd/FbCBO94NwJ+z6WsfdOOTYI 351875PgzATUajX00rFxhLFSjXCrdDRrbfK+AeCO9hHpu+1B19TxjSrxs/3628SlJlV6E+OR8/Hx1o 351876eJfa03Hhq3VEAF47fmNwLUfHA9tJEFjOpjf9Ivw+AYb+Nr3/CfRmUgLLAifhdp5wX8oCRuLA 351877oXlo5qInG9fCmAPC6Qb5fWOaYkConsorDN4qJk1SUikFMH49PRL+RJ8p3ELgywCi5DflpjTl 3518783kMiV1FKODbOnalxRBHY2Ih5Q/9QIG1EM0ZKXgLXjlvwihOlQ7b95VhvuDPKC8ra8/lKaUbv 351879x45l0vkxLYRxqNtRaUJLmPZerm1B7MVWtsch75m8o+8oxDBjoCL1GHowkZ2yoMmIzddR8+bj 351880vk6MYp6pTLll440bweeG3idMySbcaFLj8aLNiMYgT9PnLH6+Go1sGeW9MQY7gAQFHi9n1P8o 351881ouMzg5Lf27/R2oHuL5+R9DXanBuYEkIA0aoa6NYzlLjOkDaDTNnfjgn2sG+2Dq9KdIK2wPkR 351882fvT3kbih5fhhqOdAjytlyFic+KwxWd8+H+oNDyZFa+25sUiKmYO6zH4k9x2Afe8qN3C1eY+w 351883toNeAU4Grx5bBR0gBltCAt9RpqmEqEgacg+/nWe2rbLkPejoxETW/2GwgZP29oKnyhd9V0ag 351884CzHfVWHjEDGzBVxsa2H69WxOFKcWBa/P4HBs9Uglhv0yA3c2TkLv1vUQ5OkIlUwKmcoZfnU7 351885Y8JfMUjhkOJ0Ja+xjgG9ZUFjEXUxEpPahcDVVgWXkLaYvNM04olMWf3l7j4sHNoWtX2coJTJ 351886qDT/9bvNwvEPGiPHWiJOrxiK5kEusLX3QO2ei3Eu/gomB9H7jiJsHm9+k/ZJ8vVIzBnYEqHe 351887TlApbOEW0gJDlkXhdT6HJM4hVxqT5H1HxhjaL0jAqeVD0CzQmW3/zOOzGO5Djz375huQwIxX 351888Xl8ET8T5uyewfGhzBDqroHINRbfF0bwUbNyU3PKaM3Hf6ABLBhzNr80ovXAUaXjtBE6k9i8y 351889fXr8jiEIVjGR0N0iEJteZlJf6juandv89qfgzNVdmN4lDO72dnAP64HF5z6iMO8VopYOQhN/ 351890oi/tPFF/8DrEciIO+feYjBPRkZjapQ687BWC70zP5TwknF+HKT0aIdDNHgqlA7xqt8foiPN4 351891azS39EFX9P4xAQcPr8CARn5wVJofX7wxY+eOsG7zEPXgNKUAb/LNOM+vCJ2MoyfWYnTbUHjY 35189226LmjHvsWvfm/BqM71IfAVTaOTmV2q1G404YvvQMPhHvx10/TX5ufXCSUfbU5sRgpK/+Odaz 351893z6HNusQqaTswZxEyLQj5/56DollnJDnH8+7OY5SBVaiz4C4dcUrUs/EaSn1bsk72tckIlhP/ 351894ZtcMa1+XgCyaN3+jDaUIq0DN6beofyOJ2PF/NqH3U6k3Bp1IpYjuupIkHBjMBE/Z18OsS9+w 351895sQU9hhxa/423GsPz5MTqlTFk8Bl0nP13yqlLXi/0kwVhSmw+jIuukI70JOtwvxP79zwBwh/4 351896P13ZRzZF+vcCQ1Uhm1Rk3cHq9u6w9e6IxWffs+kOyb7QpFzHmr7BsHdqiNkXvlQ5zfA/tQeI 351897nygk/rriryv+ur9K3e8p5TnPcTJiEro3CoATuXdKVXANboahfz1GPpdsQTouV+qVz70x5Jzl 351898yPiylKPo70WfvaXuXRCZUGSkLlQKdYGG92/FL/5EY+bc5TtkDw5MC2MIgL4YeMBUZUOneYfI 351899Ng5UG9aS3CkSw2wGb1OFYPCGq3hfIKBArknFrcgZ6NU4iEoRK5PbwtknFE27jsW6WFq1Njd2 351900FsIDB+J4Shkq8p7j8PzeaODjCKXSEX6NhmDLi0KUpZ7CsOAwTL+Vw+B65BmtD3FGUyFs6mm8 351901zdWgLD2atoOoYEONwDOXQ51TxFF90iA/X/PDiYGG99Eg7XQfBq+UEH4CfzQd/hfuZpaj3Oh9 351902LO7fOzvCM2QMopLUUCdFYUyID3ocED7fW4u7V+Q+x4EpjQkbwA/dVl3DVw13jBbjZQRDACXs 351903Mvf2fyIuzzK5TFv0FvuHBNC2JDHu3NpH4GGO6XgofqkP6JPCf+x19qxbFL8SDZkxGzjxFuW4 351904p9QpqPvRPxpbUOPJknqws0LNo6p2pK40GXs6OkHiNRjRGVr+WGewZc8hV6lnplSKRpDB8gqW 351905fEmOSXVOsWF8VRQjR11mZl4fw2BfBv9UhmD00fe81IFk8GYzO/o5leELKR9S5XNSC/W7S9j0 351906W280CXaHPXHOcfSugy5TInH7ayEynx7FsuFtEOrpAKXKCf6NB2I5z9YswgsWH3NEmy2JyH2/ 351907D/19mOe0r485MfzUzlUtVcGOf+VrPh/uCy9GCbFG9x6oSY19OWrMME8UJ4vmwz70YoQfHFtv 351908wMuiHFwfq8furCEM8vF1+4YLcTOzXHAsac3g6z8aJ/+/1zfCxSvDzL/379wzpY2yDhY95mQb 351909I9aRq5OC6X2U2CO8Bp1n0zX+vzFusV27r4c7pdjacuktlvRHjvvcR3+hqyex5jm2wobXxTzb 3519107cWa5oJ4Pql+9f74ZNThCGgoavPxxepg6D/zNdXFybnjWvhnj8ZL+QEIXNIhuT+fT69ASeo9 3519117F/cH7UoLF/JEyqoEg79K9etyMHDrVPRp019BBN1lURdhaMfGvZZgKMvc5D1PAorRrRFLdIm 351912ILBU7zpd8dv2eyaES3qMW4+9W4ulW67fEkOXn0JCgdbK+lW9v3B9nRlsXVcJ5m5NHWvuUVHw 351913CQlJ2RRJn0pJvac3PElbQRGCidFpPPuLez9ZyBRcfHgCS/o3gp+TCrZutdFnZQy+GZNnq4Ch 351914/wr16bWqaoQ/XUU+EqPpNoLc7am54VW7A8au2ITfewTAo8Vy3GdEQqqCy/9s9XWaBKuxeW4m 351915Tl3xC/zJkL0r891Vpw0b8washiG42dCpqy5bF9ln3mln9LNrijVMJBn5gNlXR8OPnHy29bD4 351916XjJixgUhaPwN6nCtLUlD4osU6gBFdu5IXykkbt2w920uPl+eg/p2Unj02I2k/CQcHOQHhVNL 351917rIrLq/R5KYf1MB/GqFegxsRoQTlYs9eXEgZndzcqKoFU+4q3kFua3Fj/0n+cVpupQZFxbxsm 351918t/aFvXt9dGhOKvw1QsfG3rD3bIaxm2+ZLChVAR7+qVL0PALN7OUImnAZGdwUf2QkA+MU4qpG 351919UapZB7syhAnhvOrcon60kHGcSREw4VaVIgtKEreyJAVl7bm4Zyk9r7YcRekJuLymN/xIINHG 351920DvXmXEemsSOcPOzHb0RHNymkbp2w8UkCDuuJaiSZ5oMp0Uibfh4DPGjjVeXqDielDAp7T4S1 351921H4d1Vz7yAAgyNWLMeEY9Q+6H7jNnYGDTQDirFHDwaYgBK6LxocgyKFTyxqA6p6ozF7EW0mWV 351922fz2JgV6GFCSXU9TIS76K5a1dqXmgCB6Ls185imh6Qi31XdtjZ1IpYxyl4GgvN2Y+mxJhuCkR 351923lXUXsypj1v6d6kdi3scTzur5g5rAW8UY/BI7+LcYiqVRb1lApSpFk3IJa8Z1QA1HvaSvHG51 351924e2H6hhN4+FltUf1F8+UyFrVwoUnJjs2w4qFhjSlO2IrOxCZZZw6dQlyn+Yrr64ajia8jHAO7 351925YuXpgxjkpUTYnFt4dmgoAuT2aLGBn7JCm3uHJdBJPfviYNwJ9GPIr04ddrERaNQ8YdPUkYv9 351926Vmqx15bl4PneIcS96fnj2ecgPulT0hY+McxPeQimXLMubQW3HX1qdsPc4BKaVKi3xDC3udfZ 351927t/jLxElsqZ3K6uvUj/F7PcO7TI6xPuqc246q9hTsv8qJ2rx2HAsa02u0jaoelj4tFLzOqeMe 351928JJuJIFfHzUWYvr+MUvBw7yElQHc7BhySurXBkphvLMnW0jMbpxgQridD4IjNmE+Sn0kZ+YuZ 351929KM+6jhmkWh7hnOj7x0K0dKTv59LtCFLKhZ5RjuCB89HbT0oBH90oIJwDgnH6R5t7C1NDmPSn 351930ynDMe2CacqOYSufP7P3uA3CBo9zKH8scw4XYn0/10wcPeKA/QyrW5sUa0q1a3Z7wd7Brthav 351931mbFmUMEjnqPNVsphxd+/iG/lVBs9p63GrrN38TbLslODa5DZqAypZLml4N4MRs3MdLwUPlmC 351932eir6b45tt+G93vDMNAAF+uckS2nyfvR0Z4icIZNwJaOC54TrxKTudR9AEr3LkRo1AF4EqODY 351933Zj3Ob2hD2Hp6kJ3rPHMz6wSh+vLpCsahYPhJ3Tpiw9MCwb7R5tzEbzVo+1Dq4IcgF+Y72jfA 351934gpuZlapvaYveYB9h4+mBPKfmy8wqAqrZNMb8tFn6knN1GLwlxNg+nGIWbM+7NYFOJ2yUSps8 3519358Cc++QB19lUM9iDTpy/B07xsJDz7xCOVFDyPRF9fORQ1puF69nco1eXewPgAqRl72gHN1xhS 351936PGnTzzH2B3FocPSGu8pIbVbmh2EnU9l31pV+Q8zvbeAmlErKSK1PmxuHiHauRul2iff3DIQr 351937M6fc+51mHcFk2vVzsxoxKZ6NfzJ49dnHpqUo/bAbHZyE6tHfz1L7tmz7tGMrV7AvfOBha9QX 351938ZEpzztlGH1BE/s21x3GkGtmDpcl6AqgN3HqfYNWbue2Q++Snwq+4urg13MixQ4CfTeecRXKx 351939lmMjGuo7ctLUcduXOXjBVcl/XqlLHbSr62L0/sS8nX2fdWhw7yG1dYG93MbiO2uL3uPIuFqM 351940I9L0G3n33cOuPdRa8mk/Ouuf0c4VDsb3Nxpf5r6ZwtkLjjK9rX+T/Wa8PnD0gjObnskVPY5+ 351941oUD5jwf7w9tM6jN9fxY++R11lcJ1bBv/iReM4qd5Z+kfJs7Ss0wwmy0nHYhOk4QdnV2pc6A8 351942YDTOfSs3OHbdeuNUmpayl4/11Sum1sXvTwoph2fcojp08JB9c6zjBFBVpF/EOEYVxK7JasTn 351943Z+LmwkZwIOeRMggjjyRRtuPDOWGUM1jiNQQXMrUs0WBbRxeqLYlrZ2x7qz+LFeLpknqsKrPJ 351944z7kLDnwuswAk0ykDjB1nVhH+qEAU+n1cehzDl2oE62jLyqkx+/8im1S6Jv9De4D4iULiryv+ 351945uuKvKwbCHxuI5DUUV3N0PNwt71mkQf2e9zMNpOXhVE6GQEeTNZuod7Cnu/mUhRJXdNuXzDuL 351946V2TH4cD61Vi9bBJauDE2uFTG2jNyn86YvmI11uy8jlSuUh5F+HNkn9m3zVgs3XoMVx8nI7dU 351947a5ZclP9wGRrbc+wkj2aYsO0+MvTphbU5iJ1XlwnskhF4cSCCfF2hJG0DiS9GxeRQ9e7+FoZa 351948024jT/MB+/t6GynRumPgpWyivTzETquF0CmxlH3Dpsci8NAmq+KQlfMWp2c1oPwAQsGG2sIk 351949nF/aF73XPqeCocoyHmL72M4YfyHjhxP+2Pch+ogi/EkDMfHGFyTs6QUPqT4gkP8+Fu0J9Uvs 351950GhYKe0rVywF1xh7Am0Lh71IZ7k6lkb2zCYNDHeBcbwy2P8wUPDOT37e88BMuTA8jvheBzVjo 351951J53mE05MCDVk5GiyENczhElEaaf6wp2qZwjYJoPtv0b1ZgO59cpoBkyFsZfJtMJFdAC2Mc4o 351952PEattyO1ZABx5lWMInAk0hmWUFjBEp5IHxOZ7pbEVuwJGzcuOx/JF+ahkYOEwBC6YGsCo3hU 3519538grru3TE/Et0UAaJr49oMRx7XhYYKWoS9vRCxp4mzkQhk6/y8HyynzIvDqEwD+q922zAnbdc 351954NcUPSM0rNbqnBp/P/MYGMhr/FC4+cFHQ30fp7AFX/VlbEYxxZ7+yY6D8SxQGetNrh8K/LbqF 351955M2pWMh/02/OG5xMwxTvjsLgh4UxXqeBQexYv6Lo62PEvew2BLc1kfI9S74E49uQU+jNnbKdO 351956e9n07KZ7whecHM4ErhK45qL7BK7P8dfZyELw290Cy3OCi68ramFWbG6V8fUfjZP/v+sb4+KV 351957Yebf+3ddfiymBjN+HJduOMwRjaDmevQAJhMKP6X//xvjFtu16oTdGBSgoHCvVstuIbOcsOUe 351958b0Q3L+JbyTzRdcMj5HLXZR6eb8gmoyvPwv113eFjH4Cu4/ujpkrYf1AdDP1nvqa6ODlv7jZe 351959iqsv3+DN6zicXdGBsI8YYqHPCFzm9B2ZKU+/RpK+hPj47ejtTbRlWwtjdsTifVYRTwCkKjj0 351960L103/w6LZxn/ZA6eBjuAd7ZwQNMVcfxApSpg71XB0q2p7zPgIC8r0o++v3F9c9h6ZZi7NXUq 351961+zu5HxR9vIatM3qjSaALVFIplE4usGXmharuYj6JmHM/hUc4Ql1l/PeTB2PKrdxqY+j/9frV 351962wktLknFicjh93hKaN/6jcJ6TJbAquPzPVp8+R1uPzbNYw7eT6ONmne+uOm1YIPyp8WhhOH14 351963cu+DqNSqpeAhF0RyE9c78GlgR4bgKbdNDuI8FR3CIOg45w+MCfNEu+3vBdKlFuP9kYmo78ws 351964zDJn1BnyF+6kZSFuVUs4Kfww+CAdbUmqVWlKNIKbozb/BfaNqwtH7uCTeaHnjgQUUQzgAtxn 351965VBqo1J3FpvfQJG5mUtoZ1IfM9kfxc6xm0ss5tNqCN0Sf5NzfiLkRp/AypxBv/m4ND1LWvoBk 351966wK7HvDW3TMhn/zbhj0xffGqoL2RO7SiZYR7pLOEvtGBAKlWD5QZnGDGOHuudWmQK3C1vzCop 351967UOSKQ12ZlJpO6LD7g1kSjMmGkHkby1vSg9zGNhzTL6UJOvF5Ubf6hcatOaYfeIIsodz/aZcw 351968vbYtFS04/vQXlBbcx6ya9EYvrzFD8PBtydFIGrQzrmUZohWJQ8u0EJkFcqwKdebG8tI+8N8n 351969Gfv7eNIHFEUNTLmSYZE0QQIYKdHz0cbTyFiRu6PB4FWITuKnFdBVfEVUb4bYJ/VCrx3PkV3w 351970DY92DkMw+44eGBDNV7fUvN+GtgypyGOAIbqqsr/rKgqREncSf83ohbpuzDNKlPBs2BczN0Th 351971XnI+77vSin02lRKMjRUBtYVf8OR8JBYMaQE/PQlA5oTQzhPx5+FYJOVxD48VyHm0Bf0Y8Fnm 3519723g5LOQQtXUU6okf5Q+k7DKe/lrMpmh04a4vCLRBuCsJhfTwVFZq32NragXcAICMOErcwKQWI 351973b15/SRwK1E/we12mTUZxjLteOpkFre0Q0icCN9IMZFRK2ZE5XFCqbvnWRLZy2yHJQA/4ILsu 351974H7FTghggWYk6ix6zEbkWn8/GEe12cFUkq1a/iHA21Ne/S8hvuKPvF31ufc61pBKsIWqtsnY4 351975P89BbDSycT+Ezn4gqNpJ1dvfmSGH8VO4mmtb7tsP2+LzLeT0515HpxgwF91qqOeMzvue48Zv 351976IZCTzzE3BjeWNyKMOQncum5H3MWx8JeaErD59yABkCc4N5xJTd7jMFLUHAl6Tv+o4xYwJG0y 351977ukZ4TeQqi0p8RuF6rlCbEviOvkYZUlpNFl4dn4a6zJ4iCxjDpow2kMKtbW+kmfaItWcgmdJH 351978i+K0OGwbyKgnSb3R//AndryVfjqMAT4Ca7TSCy0m7caTHGHbiAxOGMZEfnD7i1vMpfyl9sIj 3519793dn00lyiBVfJVhowgVETy8b132rSSgASN3Tfw1ecqPh2go3+c+0ZhdQiYh9s50TU9UDf48lI 351980OtCFGLck8eY2cnNjMTNUwRjho3ExwwJxnnSg9XAz9ImqFqZFfzWfcoWw316vb85EjurtLm/0 3519812fWGsrssB1h84aTxJuyysKk4Z0bFme4/Jj23XBiwLXy6lABc+OrV5qKXzKVp1eVwyB5GpHU9 3519820UPm2QXr43K/K5VoRd4bxN58hLepOSginIXaMjW+3o1ACwdTMMlAdCTVS9ph+eUk5BXnIH5b 351983Tyb6nRwD9KGY2nciu9DENFJBouVsHIpLQb5Gg7xPcTix6yTeFXMdjeG0o0fiiIYzo/A6uwi5 351984CYcxipPeo0kEDYyQjqHn69tQe5rEoS4m7X2AT3kaaPLf4PBgBmA3TjvPCRgyjhjTafNwbwGT 351985Vk1ij3pTj+FlVjHyEw5iqL9cMPiA2xcS56aYc/I1MvM/4/yEEEY1g7+35N+ZhhBGVaD+smcm 351986wSk51/T2hi0arzaoVRvaUSH8t33YMrImNU4ldqEYufs5D+Th15fz9hND+yRxti2WEt8uJ/UK 351987fgtVGoCUbmtxOyWXsOPG04pxJImqu4FExb1HZe+s0xbg8R9NmehqO4SN34+naUUoSr2O3/Xk 351988d0UoZt8v4JBg9crvVowvozHTaNYJeswkHsXoYP2Y4adp4j2/fR1M3P8IX9WlKMr8hM+EXaYr 351989/YDdHehUTw7NViP2ayHKyonxmpqAO6e2Yt3BBHY+GwOaxiQEyll6ph/rLO2wi+ss1SuTO6Hj 3519903mTq+V6tacoQ+frSRD7SsRAzGSFyet3tuotedz+Q6qGU85MmH2gSN1FnRYlUwjqQtBmXMJZK 351991vy6BZ79jPOI9ufa8iWxP24PEubRV/1bwktH/3ePv56wScNal4fCR0M6JJU8LqefOvDKJGRf2 351992aLrqqaBqME1kuI81XTzpeagMwtDdr0zqUsF4MWNp0rORinNVCH8GMq8cIb/xFTp0Fbl4eWIF 351993hrUgA51s4RLUFH2nr8Px2ESkF5aiJOc9bu+ZhX7jz1I2/M9C+Pun9gDxE4XEX1f8dcVf91cn 351994/NFqOvQ+aZw9oCz1DMYwhHcb21D0HNIUbj6Dce7TV7y8uBf7H+sV6TR4t7UNY7+Y/uxbbEQC 35199517FB4L7HIqahvRdzb7kPOk9fgdWrV1O/PzccRbyR6lp+7BQEySrHDIyD52hMpwNcBBwcCvcG 351996GPLnJV4QCJUl4up8NCOwbblHMwwePxDNvBi7T+KEVmtfUHYNiRnSatoK1PztOpURhFKszX6L 3519972yeO424a7SQ80CWQsoULmEA2qUcnRNxMgbpUg9yP8YhP01BtfiIwi8COe5FcRt9H/Wo3RjXw 351998gEqmhHNQKwyf0h81VGQghSHYkPx26fcjMbquI2S2dTEn9gvenFmEjj4KyLz7Yj+jTFJdfE6o 3519996N+nzIjw93pXD3gQmFeztSQGz38fazAudRphV6arvwtX1CTtMAQrEc5EKflzaoVNTAq/sozH 352000uHrnHXI05QTW8AiRfX0gk9fEjDt5Zs7V33Bpdn3WOWYXPg3nzZ511YibSzt+bOShmPVAzf47 352001qzStCMPcOPrf8x+vQycPQ8AzhSlRAdh2PIyPUsOzZ3AZUiG/Gnbk9naORpgJqcSl5uCwiTg8 352002tRk89EFDEhV8W03CjrgsQ0Ba8StsaO9KjLOaGLnvNXJSzmJciBIyjw5YeSudPTeQxLi5YQrB 352003gF26PwzpgoVxUzI4lh88XJL4NzoywfS2YRNw6EUW1Blx2NDBlUMadkCj+VfwVUPgSInb0Zmp 352004r/fz0GfXfDyYH85PpSxxQOPFt5FlYdxrSz7h/OxGtJ+KXAMi4gVsdOux41/3mmK82tCKwdII 352005TGf5E6ipa2gSnix4KosT86+rQMbVqaihJ4BNuEillddmXcQQL4nZeW9s63PxdWsVzP9pnPz/ 352006W5+Pi1eGmX/v34/3dDWz3xtIijkxQ+Gl/3dGmf7fwLjFdi1lQ3BIf01HTUA7M2Q/Y38pOU/J 352007ua0t/oBT0xvA2aUxZp39iJz41Yy6MtGW3xhe4EF1MPSf+Zrq4OTGfhQ/xo9C+yEuYIA+jT2T 3520088YnFIVlfCvkMF3FhajC1j0s9e+PAB8134dC/cl1twXuibhzefMlBYWmFSV2pW2ssPBlP4JYE 3520093p39FFvaO5sQLquEvVcRS+fWt5H7omfEFbzNLkZJdjy29/JiUoYa0qR/z/2txfbNYeuVYe7W 3520101LH0d3KPz767Cu3cLPAsFLUw54Fa4H6MP73XHKzbsgqj6jgwdh+xF27X84yqhqH/1+tXCyMl 352011U5KvacWQQ+0QPvEg4jPUSIuZgzp60rgyHAsfqauFy/+M9auDzasfzEaowlrfXdXbsED4y8Pt 352012CQHUwuDSja/sZE3RO1PpNGgkkYtwvhKO9KHRwhFtxa83oI2TkYFNHP68GvTFwiPxJkaCtiQb 352013Kckf8TWXVNkpxZcz4xGiskeD+TeQnvcWpxb3RribglpIHYK74vcLKawDXFf8Frv60BGPyuBh 352014+Gv3XDTTt23fEAtvZ0Hz7SxG+suow1zLvxIEyXysU4c4xC5+XGh5wOfexDh/mqTo1vc0DyjT 352015qylShD8jlcAfCZh8b1E/IdV8CJBp2nWTtLM5V4YxxrUEXkMuUqliaZLgZwKoYSJvpQEYfyPX 352016wgGoAHcpkgoNXMzmLMDmr9Gi4NV+jGMWYoljfUw/89Es+VLHkeU0/KRwaf0HKyVqYD0nYFtP 352017AsiQOKPV6jhKCpmr8OLS7TAP4GMjdJ8fxa7jN/EyJQfFZcTm/eEaIvSACJVSMYY1xjRJ29HO 352018UT/eSYfoSSRkFuDr7eVoqjceAieZHHD1Rt6Xk8OpNJ2kwRYw6jS+luss9lVx8iVEDG0ED4Wx 3520196osjwkdsxzMjsJNq48Qw+MkqU+ss/iFjLO/WOIaMJINzWBdMWn0ANxKzUWoGbPoR86M8/wPu 352020Rm3AjD4N2H6h6jNtaj7sR18v2liwDR2HI2/5pEhtxgUM9Vah9lyajFX8ah2a20sIkG4SjrzI 352021QG5SFEaT4DUDdpHKeNdGeMOR4yAt/3oaw/1kTHTiACoNi678C47q1SQp1cxSw9o8KdAoYtsI 352022kAgZin1vDd8k7Yw+ZTMZIbm70ihe03aIw/ERvhIWLy0zh6Bb6fNxNnar3seoPvddqOjkUkOE 352023jn6N1f9IFSY2fboV/cYCB83Xs8pv/Otc0TMqVdBxS0XLT9YTIAnnOCfNtdm27Rtg/g3zymbG 35202436D70S/CRGZuPQrczSf6qT8V4aj0Coc/KYnv0AJr4rM4B0kPDDiXLvyM1FgtQNr5IfAmDQq3 352025Xjjy9AyrLMftn7RTvRmDh/keAqQKKgUMA15ziQHWfBOS9DHtfCoL7JLtuVWlvWbrzHxLG5N9 352026wM63GcZsfYCscn5keEHCSSwf3AS+xgphxDrlP/Icvgmsu8UvDCCFXdO1gmlxY0b7MkoRxHg5 352027xR0vBbg33ZBeujtn7um0Wbg4xIs+eDBqusWvNqAVs4/YNlyOR8ZpOLMvYaC7IVr25YOlFGlW 352028FjgeV7PK2T71HHIJCdEjmDVVifD5D8ymQqGAnZdb0d2Tc5CybYBlTyzv22S0+wAvKUsQqzsn 352029hk39YHYtqsjC7SXN2Ggyud9A7H1TZIEoW4D7M2vS/WcU/cs6FT8fQBdn/n7MP6Rk4sJgup/J 3520309N9CqY4skT1m1JRXTiy20n4rTX+Ew8vHoEvDYLg7KE3U0tz6nKJsSiodBEXepNfkdpHvWLu3 352031nHpfG1ZlmnRGkKSjMQEyhtw5giKsm/1uqVHo5ylhx9gTlkidjcuDPFj1uDHXchiS6WkM8ZFa 352032fnejtZ2rROnaK4pV0KPbP4EBnnol44V4kK8HToj5MNCdvd8C9tDI7Qs7NI1gHKYE0JKwgVkD 352033JV4YeinL4DyObMsAdJ4YZHRW4aXkYpRU2DRobDsSKOwUtNqbTzdExKabkF/59d3QK+orkzaG 3520342z6pAMykMOcQfG0c22ArE7FlAEql8B9/k4ks496j8ncuTznOflNSFftOrpYFdJ4tq8+oeBj2 352035HR4J1orxxRszjVbimdCYUdTGvDg1exYyPL8tGq18akKup9R8mDOFROWDJn0mYF7ETpx9kIyC 352036cnNgsgxBk2MFgs04gW2EA3bWfSFnKQEGPVQzhE9GiV5vy5HOyJa0U9Ou8Uo8ZdZdNuWcQ0ts 352037SsignX3yQPQY3YT47t4YcS0Dnw70gBu5nilqCqag0+bEYnYYR+GIOIe0WBaL7Aq+2iLd5y7o 352038eigFZcTzrG9JBzQpw2bjlhm179KvV7CguTOtVk3sr1NOfECJsSNRW4q8pAtY2JRWI5F49sWR 352039FFPlJGsIf4boSGLPbhmB++kGddz82IkItMKG169x/yXCX3X2APEThcRfV/x1xV/3lyf8lRHY 352040YDcXxp5cycM+n61owBBznND6ryeIJ2wCH8am4O/fObhGnKEkZs5zfmNNA6N1ebcwXo8TOHfF 352041oZRyq9f6so970YnB/yQevVhim/l3zMD9HVPRIdjBxGYnz1dhs26yWKou7w5m1iQwa3kQJl2j 352042MzBU5Mdja3c6oFevAsNVy5XY+qN5/6lYHnkS95L5GSr0BLmsW+MpTI0bFKIvpC1KE+T2WEWQ 35204305cHEZ3hrZDBrfl0wkn5FAfGhcNBaoca/dfiekoJu7dbh8/ZoFqEPxv6WhupE+qN/BsPs8ur 352044/T7GparPrS1Kw4e3b/DmDeeXlAo1806F8WvRo6Y77GQSSJUuCGjcB/MOmvo1yEKedWOXtWAI 352045T6SPYiSOJJWYfVZdWTL2dqQDYMjU0ccZcQZuYAypNH3ymyEwsTTrNa5sGY4QpSuVtrKICsB2 352046Q+8oQ0BH+jm9QpbBuWlcKrMjv755iefPnxt+r5KQrTHGmLUoK0jDx6RkpOYYxg63VOQ+ReSA 352047QMKG9ka/fYQT7NM5zGniDJlDI/z+gA6Y5SqP27j3w3mjQEWdNg1n+7mb/54OxNnqnYZTPxsx 352048Exk8j5iTE68azolvtrRiScaygHEEhsKcm4ri8UdDWtiBS4IhiyZpJzq56NuTw3/IQSRZUFAj 352049iZTrevjQGIbMA+2XXxNMCVgV7PhXvaaMwJQG++ivGYSoL8RaUMG5xsmQnYhbtLl3sYAhBUq9 352050+uHQJ7qOIRW20E8C35FXeD4wHr5uQU2QP+7/WZz8/1ufj4tXhpl/799ZRTjejzjjT7rN4iDv 352051WRxBAu+hF5FJ4WP/f4xbbNfq/86S/qj1S5jsRxMpDHs5KRCUkBaHzX384eDXG5vicojvTrY1 352052mFVmNQ7crA6G/jNfw66DVcDJ+fPFAS03JbL7dVnyXtZnbSxkQdpKzswc63EsEffmMYEDxE/h 3520532wXLL6fw9n1rcWgx1D2yYiy6NhKua/bHIVxWBXuvKpbOrS+xC0TzLt3RvTv564IWQfZMphED 352054Vv4997emvjlsvTLM3dK11v5dm8vBUW1DMWZPHFLVpdDkJOLU1FpMEIYLLcZj8kwy+A2LolKi 3520558rKeEvOl98lvVDtVxdD/6/Wrc6YjfTcDmbVMEToDtwk7P/XKYrT29kSNIGcT/3ZVcfmfrT61 3520567lYRm6cCIHe0Z8Zd5b6V6rRhnvBHODuj+7tTh732nKiOykrMKF8rFj9ShcOg6KDffLKeHMGK 352057MV1Q39eOfw+pDwZHfYE5iXz1i83o4q6AZ49IJOSn4ty4YCikbmg9dz/OH5qLJoQjXOozDNHp 3520589MtnXBxFD1jC8TXoTBoxyTVIOjQE/kyUmdy3E0Z28ac+oqLGZFxOF1bwuT7Gj144PfqbHC6N 352059iyFazqCA8k8AD5ZKwf1ZCOWl35LCd9RVE/KeMKiQgqP9vSBz7UwcnExBrpTDjJoOybBe/syg 352060sJF5CSN8mY3HezDOpZlXiqQUuvQRgS49cOyLZVVJnbYISadmoakLfX9lYH9sfphtNj0f76BX 352061qsa3+CjMrM8wmImNYiCP/EI4SDe1JiYfmTZwMaKfvsbr168Rd3AIQ36TI2jUUTxKTEaWpvI0 352062Tbk3DN/RvX80Mpg+5x4s5SHTcEu/2HJyyNt4DUeMANmgIv0yJutln737s4dVc6U0JQojAxXU 352063Aci5yWwcj0+DujAdj7b2pNVDKAerqdoRqcARv38GOtdyg0qugmtIK4yYPRnNmAVIVX8ZnhVW 352064H1zjlvzYSYx6jAS2vs0weN7fOPsohQXOfnQh14+StOe4tGspRrUNJkBL5hsxaQmptBN7+6Km 352065tze8feth4iVTg4QEv+vb+WPs9Rxq3Lxe1wx28mBMvsYQAspTcJgEtinQTUuN810EEOfelyFp 352066aPNwfyGjXERGs009j8SUFKSkJOLM6AB6M5QGYMItOhpYp3mDLa0YlUplbcxnnOUVhZ9waY4+ 3520671Qs/asgwP+mUCEnWEP647SgM7bAb2ufD6O3BEKBsG2HV8yKB5zMYlVa1w6S7s1S47+LQxtSx 352068kBMzCr766NBlhrXIUjvkOEg/158BOPmSvbzrVA2wXCA1K13vLf5uzdSzbYw/XxQLv6OqNsYu 352069GY5QfQSd70Dsf1/yXX3Dq+fWhwJ3Ne8iWRVNsi/qLrhLHLgzED3Ik/43Tlp9k3sQgOmZNC0q 3520700ggAhIx0lXig45xRCFeZ9g/3ezgKpBzWaTNwYZQfs6fz9z9em7w9Xwkn33C0H7kCUfE5vDWd 352071VW6zqj1+qmmz7TFzz7P1Alz+VmZ+3yhOQ8Lt44gYYVAHlviNxc08ASDjrD4ihAQIhUllbMpf 352072zvyhri95bYg0NR5LxBrDKk3JgjD5RgJODvFlgOlAjI1O44Fj1DUMKYOaMy0WY/PIYAJsIFU5 3520736ajDnCuDqbHv1m0dIrq50XaNfQtsSDDvaChLjcbUMJUJ6OY3/CwVJW12vnNU3PQKWJb3+QLE 352074b+kGT1b5rAPWxFlOmUI6O3Yxzg5l3d8FU8aTBOGxflI6XYgAQKsreobl9en30zvbTOpYIHss 352075bcSoMNp6ICA4GMEWfo0mXDRRwTXs2ycxtobKgv1niGqjgB896dihFTYnGmw1DUeFWZ+ONvfm 352076eEa9iyQ+XjWr4kCtq3qyE0kEXWhIqUY5bvVBHRxAI/vqCDr6yJLt6sq38/JiJzNqKioT5cWc 35207762PgJzHd23jOAI8BOJeuNYBg+r6wa4KIl0yKKG0WLg31ZsZ4S1aFg3Qek+cX+t+bm4x9XcU3 352078nNCrHRNOhx1cAj5L9DasJcHjzgsSgXn1ufsmt31OEIU2w5DCm4pgJ52+vAhhMuJMT7bn3qPy 352079d866NJQBUmU85TVSvffOtBD6GbmkSC1n/7BifHHHDKkAzK7D3BR8xF5zOk1rpg8EVDV1FciK 352080XYG27sYRm3J4tFuO2KwKtt6XYz3YPuKqCLL3ImyzQ12d2bFocJYmYWd7vRO1F6K+0v9eygbo 352081EADRsU9IOTOCPg8oamJajIG4n3djNG2D2DbA0iuE3U04sOwar8b1EwOIPcENfY9eQ0RTO8ax 352082sI5NN8Qfb2mIHhPAjitFrdm4Z6xswZJBSULjdSTqn0cegJFnvpqchaign6QoTAq3o4nMLs2x 3520838Oo3k/O9Nu00+roZHFwqv3aYczJJMPWYVSl9i99h/+g6cJRynDOTY5FPAkixc9B/SiRiEjJQ 352084qClCVtIDnN4yB4Na1YC7nRIOvg3Rd95+xKWXsvb2f4XwV509QPxEIfHXFX9d8df9VeqaPUsR 352085Z0tzKRc3tbTn2JNpuDoiACFT6P1C0DblnPnrLXkqqBJBY79jESAz76Cad99UbZ8MrqrUkUfa 352086SJezzZ5JdFoNcpKfIubYJszuEQxbxi6WBk5kg3lZFVyJKzr89QR5FaS9lYvYOWGEo0GGwPEx 352087jJpfERJ2DkCAcRYRhS96bTGo/975LQxhv8UijVH4k3l2xfrYLygsK0VBSgJepWsoWzR2ehhC 352088J9NEifKUQ2wqK/55PBATb+ez7zM7VAFVnbmE40ZLB+k4SeHZa68JMaCyonlPYxR6/NoSRq1/ 352089H0NK3wCMPnwQk2vawbN7JF4X6Uze50eV/1dmHRILfLy+E9wZO0nu0xfbX6ktn3U5qehUDVYY 352090sutw/p3KUmQkJkApVzrUx/JnhfT8sedjEFwH10wjdQ9r7UiL8z/9LJumlf8zOF8NuMtnXPmj 352091M7zktB1fnPMMe8fVhp3C4HzTvNFnXLKhgvyOGBF5ybSrS+qpWHJf5LtKyLrqB8Q4lxuIEvqU 352092WcT8i1/RwHxKYxv93OYH6pOY/kI9ps8Eapptu+QtdvTwoImUDvUw7cR7YWWnKmLHv+Y1ubgz 352093V6+eqBS+RhaISbH5Rn2nxrOI5mbVYfVnH3MBoeYwacc21p0/vg8n/8nqG+HilWHm3/13nlqn 352094HZquecXzqeo077GtgzO7Nw84SZ+F/w2MW2zX6veHvCeb0J0RyrCRuqL18tvINBFIKee1ZVuj 352095O3rXd4Fzg+k49aGYwZzScWGkvi17NF/PF+CpDob+M19THZycN66ZYGRqj057gn2jazLrqRQ+ 352096g08itVxnikMSc2wFMccqcuOxewwn86F9YyxnFHmrgkP/6nXHWaxr4ec5kOWKcLF3yj9kAXuv 352097KpZuVX2OEMI/cn9OfXPYemWYu1W4fCV/N2SkIcb/0GhDNkGeHUdmKdSTEDn3U4RhDpPOnCbV 352098GuaLfk+qKob+X69fVU4SrUSnb0OKgDGncXPHUNT0bIjfTjzBhXG0sBzZxhBGYbuquPzPVr9a 3520992LyWM+6s8K1Upw2bH31gXcWkrbXM/LVAXKDSPLSHd+PFOHF8IUXWo9JezRJOo1ieHoPZde2g 352100Cp2CaMJRT5Ic2jjSB1zy4KsreYU1pGOFc8CLX9mQNhSJQ8DEm7mMcyUbsYsb89JwShwaYv71 352101DLMEskNdXRhHjGUJb/KdPuzqSKsBktKLlRBa/ingIXFTS75EsADx0hwpKv/BQtRVKRE2Jxa5 352102AhuTIeLSDo3/fMGkdCvH11ND4COlv2HIlGsWyYW6nOsYy0TeCjlP+AbOF1xd2p4hAcjh03U1 352103bnwrrSLZqwD3Z4UyURZu6MNV5CJT2fZyq3wse/TH2XROWg5thQBD3ZC6hCLVrXrOGseaN1tY 352104kMKx3Q7WsK5IjUJfd4nByVtiujjcnqNPleaGrjvemU2VbHJAIg/MHKXF4uer0YghHXoMvlLp 3521054ZYk56YcHwwfGd12t91JFtuuGuClQVZCDPYuG4U2gfaMkS+FQ0g7jF66G5dfpEHDGUPVIcSS 35210647k05w1uHvoTk7vVhgsDMEpU3mgyaD4io+ORVqK1+pkL7kxFsD0ZLVZIGQU3xxKHE+fO2P+J 352107NtC1eXcwiwRIKWIkMZfilqGhnTM6MbKwmreR6OgiqeQdHNGGYXxrsy9juD5VKHNo1Tu4U4/r 352108HdxketQb7BrBS8Pn2R/HBaLadRUaFJcZ3pvXjmtPXlp3MpX08ZGBbDSQc/tIKnW76XX8TVAQ 352109+OPWJw3idMt9n3tzAmMoE9/MvTcOfy7jRXuQ65yD3og7byBoWmqHjGYwpB53RPudBpI79zqJ 35211012A2V77pe1zBCB+mns9IXM0R7kvqHmk5iFvZglEsk8Cx6VLcEUgNy3tmDpnFUj09uKtTP8ai 352111OjTAqAiZhEvpFQTo+QzLGBKT1G80j0jMvYdd4z/xolhHkVxO9vckjBAJ5Eo5K2fN7Z+825PZ 352112lEdS/9G4lKnl7x1xK1m1UpnPYERxVIL479ff7Pvx5tu9Gagpt649iVtXwmGkEW6PISdRRNm5 3521139WkCHQkyzjDscdqSAhQLkHa0aSfRm0mRKwuZhrsFxmt+IZ78XpdNZd/677eCayQLADsYSDjU 352114Ph8fgaaMIpKq7mI8VvPBlOzLw+ioVOLe9Yf1RaiKHkcunbYLgo26gntsVKzCLYQA9yVUm3pJ 3521159zxGBULpWROezL3cex02q+yszX+CdR3c6PVZ7ov+G/Zgqj6KijBWN1oiCnIiDiu3nUqQdHgE 352116ghR6m6wB5sakVUrqJ1U8JjDODqGU8rSx/AJ/NraFss4iPBawNSpSj6OnK30QCp52R9DZaIns 352117ofl8BlPr2EFKPPPsi6lVcoZwCzuOpB7ovPYWPuaR6liFBhUU6qBEp9TXaRIJZykD/Lh05xy4 352118NXgb2Y6xQRzZ6KGvUT2ZSF4ynfMti06yL0f1BDMCdNtgAN3KUo6iD0P85n5PAzHXCR33JAu+ 352119v1ZA6dqBeafBFzJ5tpThWfmy/dxIWJ6aJ6cvpP5jWYVGrgqDjHC43srTH56YswJVfxwvbYix 352120A0geOgsP1ALteLXH2G5ManCZDwbsN7WNuPXJFA9Xs7UC7Ruet/DpEtRTMeOQcXpTEcIzmAhh 352121TjoCc/cw986Gb8rvU23uHcypTc9niWc/1l7gOc2sGF+8McMBass+H0Ivxr61axKBl8UC3yBg 352122PG7mmh+P5XlJuHt6F9YunIBuYU6MreiKHpwowQezQw199FAtsC7eZddFZfhCPGK+KaXGoQ9o 3521234TpRiXV0BlWf2CfGb8Zsqk+l8O5/hLdWquPmIoxcsxSB6D6yGVwJwLsbcdbKJO1ViRMaDe+B 352124YPLvEk/0O5YicPgnSc7dWZIzHSXvj5Fnv/FVlklQhlFFtwsfgH5hdtTzuPfYKxiVX/BiJwYF 352125MqmxPLtg7f1sE3I4Neae6Mccs886NcbcaxmCdSsj/JHtFr09hAn1nTmkWHpNIM+e2ooyVGit 352126Xxv/S4S/6uwB4icKib+u+OuKv+6vTvhTx81HbSadmHHKPoOjswsOJD4mbBcfdDucYkbdnjjz 352127b9YrbhE4HkdJxbi8P7sFfy6diGaujDqF1B0tJy+j0vmu2XENXwSeeV0z+8pxQMKhu/p5MW/P 35212806g1wmpl306gl6spKYg8m//RmFFytlHCq9lgTBjcFO5yCRzqTsXpFA0v6EH96QFO71iF3/rU 352129g4vM9H65sbMRHkSctz+8xf6+XkYBKe4YeCkbZV/PYERIbVZhWB03j7ZbTNTPWuPvt4b2H27o 352130CR85gbt2X4e7KYmImlwX9jJH1J92AknF2moT/ixh1Oz7fNGwKX0nxWYj9dQw+Cnc0X1PEoqM 3521313ue/RPgjCUivd/SDrx7bcO+ItY9yK32PkoT1aM44g1x7G1Ro1KwNJ4H38Ms87F2vUufoNQQX 352132M4so5XJ74ixyJVtrBW5uvR1pqRQ9X8XiznziKj+7T278AUxt6gqZ3Avt5h7A5RMr0TtIRdhU 3521334Ri+5Q7S9Lhj+jkMZJRKbCTu6LaLj4mTmHpPVwPR9nZeJRhC7jWM8GbqB0xg6+tKEgxnbDIw 3521343asGaoeHI9zo13TUEXzkEGXKPx9kVTrkNWfifoHOAsY1k8G4yCxZ/BR1Wq3hG1UVO/4VryHT 352135Lrd3rvyattve88ZDyZtIdHKt7Dp7tPgroVL/Bhdft3HugMg3pvhXecE3pKkrzODrVcTJf7L6 352136xrh4ZZj59/6d8s/pgy8lPhh5NYezjhYhcXc/2j9F4uH1FrHZIP4NjFts1/LIfjIPtJ06Cz38 352137FGZJfwbiE42/+/bcgAfZ5cJt+Q3H6dTy78bQf+ZrqoOT8+aumZ8iYAhPWILGIe0ZMZ7hhlSz 352138BPb0dEMbNjNKkwjan18VHFrUdQm/4yCGuGTynQTxbAJ7H3/Tol1ZVSz9Z6tvDluvDHO3Cpev 3521395O+GZ+Vj3KQdt5H1lXTB3uRSk/tJCPtYv/foNAn4iyHwSnwM86WqGPp/vX6VzzW6ck4bUth7 352140esEloCc2PCDOnzm3MTOUPutLPPqwGWSqjsv/XPWris3T4+45Vuv5c1b4VqrThlnCX+qZCWhB 352141HlzqtMK0KxlVOjzrnUv6jqn4egJ93AmnyNALrLIZ78CafAlHop/hGwEU0CzHQIRMvo2MpH3o 3521427iahFxVGwYIfBfUe+/r7QOHSFmue0JGZVNSajJRfZRS6cm9hSrCMcHJNIJxf9ARNOdSdWWgl 352143cG42FydfZaK4JAfvLi5BCzatsASefY9QUp7mykFG1cScgoxhY32Lv9s4Muo6G0zIWz8aeCAX 352144sg3N7VmHolWHeJ78fx+e/L+uNBn7e7hD5t4T+5OFSXXclE3ObdbjcU4RMp/txYhgJeMI7SOY 352145/kKnLUdRfg5ycnLw7eFq1ghy63kIb7PIf89DUTn/+csy7mBdLz+abCRzR+uFF/DJAkGLdPw9 35214637USm0/dw5u0AmgqylGS8xEPD81GCwb4k7h1w94PpYLOXUs/nrOSJPbtHYQu49fj9MMkZBaW 352147oqwwDc9PLUY7DxlLQNnxngPcFdxnwU2pV2/siM9GwbfH2D0yhDYqJCSQ9YF34KQAl7jlaGRH 352148j1OnNn/hZVFlJD1iYZgazIB+Tmix8hZS1cXISYpBhD5tACkFvZF/uNUVvcf5IxfwODkHxeXl 352149KM58i5s7JqGhk5RaWDy6RSKhSGdCpFjd2JZ12pps0EXPWWKwJaeurjwfSbFHEDG5C2o5y1gV 352150F9fwbpi5/zUVyVxVwp8m+RQW928ELyUzz6X2CGozGsv2xiAhu9SUrFmSiG0DG1EATr0uKwQN 352151cyptnK0vRl0lI7wL6H6WB2H0iSTk57zBmTmNqYgZt557EXsxAr39FVCGzcR1Ronm3KgAK9LM 352152SuE/jibwcQma+lShJFEyO+EU4YCmU1uT46bX4c8smZdMDzdLD6LbyODVeTnOv86gU05/eYGY 352153/UsxuP1w4uBWLkgEVRKHkidqLUrVaXgTexALu/kzZCZiTDu3QsSTArbvTK6rRP2RW58ro2/2 352154cJNzE9Nrct9lBaLJdykvhTo9Hnt60ylwuApHlbVDM/gZlSijiGbedQLkW7beiz/R2E44ylPo 352155HrqSd9jbz4f59nIEDD+Kj0abNPc6Rcgo7Lx8Ezdvcn53XiBDwx0TBLg77DKVUp1MSXKVVNyV 352156+WDgsRRqLBhITKaqZdx7+Iy4yqgJlCM1qg/cudE8Rv2jzbuLubWVrPR87YkHEZ9RTDg8viH+ 3521577Ap092W+lTIYo6NSePs4byw3W1vpt6fX5sdY1tC28vZknui5PZEXecgbmxzDjUo9yZCWyDS3 352158MYytQKZdDG06CisP3cALKkV7GQq/xeP47CYMWVOO4EkxbAp7AyD1Bcd6MOOJjC6+nSf4LnoV 352159OhLYrTU6EpfuxSH2/BaMq+/IzGM3Arg2JQ2VvDaA/OxPVReLHuQL2mq6QgP5U2/fuPc6xJJU 3521601A9m85UVZAEYezlT+F6az4gaE8zsT45ouoRMM6lB0s5OcNErsE29bpbcT4GjUv26zE/bakws 352161/3ZpFurp35MYP6OOJVtFLjdE+9uh2drXgin+dRWpOE5+I8/BuCRgI6kf6NUmnNHlwGdhhWkL 352162ZA/qOVLOYlodeyhr/obr2dpq2Xzn+zHApjwQo058gLooC4nRS9DWTWoCJmkzL2CIF7O3ybzR 352163Z9tTZBUR++jl5WjH1JcHjUV0Gr3O59/5DSHMdycdNxE3PkFNjvG0BFyPOonnnBT/BhUVwm5u 352164HYE7aYVQf4nFxt6+jP3AT6GeHzuNuTdhozRdiAvvc6Ep16Ag7R0eRm/HomEDsOxhAccWJNar 352165ET7mI/UY255aQxsvwc1vatp+6aZ3ZpLAiYHkzu0LrqptxbeT6O2mV5bZxyrLkA4jVnGGqG+c 3521669l7DqruR72kYt7x2Ou7Bu5TLmBbKHJRd2mF9PF+hg1vfsW0kuwYbt08+L63kpwcs6HFIkdlI 352167Nez2jmy6Lj04L3QPS+9ccJ+Y9wp9n/6OG1+LUZzxDPvH12YI0A5otvIxCpi5XJ5yGN30aams 352168GF/cMePUfCmuJmUg7e1V/NnV8M38RhsUFHjPTypvCigRJ59ciT92XsRj4l7q0gpUaLIRv60r 352169s0d5YMBZ2uFPzu+onq6MQ74+Ft/NMXFKarMuYACjMiL1GYjD7/OR8/4SlnfwYJ5PAq/BF6h0 352170QLSdYFCTlMhtISfbdGqDja/5EdrFr9YwZxkJJBIy7ddYXMog7Pb7tCNPImEIsjWnC0j7kyTn 3521714QhU0A6nemMXYQij5G3bcAWbSlt/Fkg7N5BNrUOrh7TEuhfGiggVyL6/Bl2Y9OvKwEHY+aLA 3521724rleW5qHhP0D4MsEVdWceV8wvXulhL+yTzjQy51OC+zSCksvv0eORlv9M/B/iPBXnT1A/EQh 3521738dcVf13x1/3VCX+fD3QxpBMzUvSKbKMn1Dig3pCRaOBRF4vvfcHHR9GIupVqhIflUtlWpPqA 3521746qeFlRCrMnB5XCB77vbttQ7XkkjbtAQ5Hx8jeut8zNmdYJKFRacrxos/GzNOPVMCCf+M9B7b 352175u9RCq3F/4lBMPD5mqYn7k8p6j3B4RmPm7EjYPiPOs2roVLaJz1cQMagunGWGc5pzqz8Rx7HD 352176XxyIxPH7ycjX262ZMZjMpPhVhM1FnD4QpSwFJ0fWQGC/XXjx5RkOze2Jet72UCicENB0BLY8 352177eIQ9A4MRMjwKKaW6KpLTivD++CTUsbdDwz/iUVSWjlurOsJD7oGB0db7C4wJfxbbZN9nJ+Ke 352178nsXOv/fhWoqG6OsUXN//N7bu3I3Vfar3Pv92oWy+IyMRrFdtVAZh2K4HeJOUhCTu70MKz3ai 352179MlOcH8hkpiC+f/AI7H34HknPzmJpWyYgz0aBGpPOITGjyBDQrs3C5WHecGy1GYlFaTjTz90q 352180ZbLq2JHfW7a0coJjnRHYei8NmuwYjPJVwbfTYpx9yz9X6SoycGlCMHsWtVEFotucSJy59Riv 3521813rzHizOTUFN/1mmyHNcSjPr2YxpPRc+gnkFn5ZgRTZyNCz7j+qoOrAIj2bchE6ORWqrvV1LJ 3521828zEun7iIN2q+rZfPOb+69jBNr80t3OC2sGln8TY9Aykvb+Lw6vEYtiKOssN15WlVxo5/vWu+ 3521834ewIfyuvMZAqdKUfcbCvFz0/HJoj4nkhb+2ObOtoIJPF5FQ6Rvn4OnEWChuCiKhbeBz/DA9i 352184jmPznL6oW3MAz6/2PTj5z1bfGBevDDP/3r/T/jkFG2C85Y2GwAHy8fXVNeya2RZeehEHp+ZY 352185fi9HwDfx/8O4xXatgezniS7r4pBToYX61U4MIPxeQqQ/bVYMJgTR9guFg4/bj6dpRQJt1cC4 3521860ykoNdprqoOh/8zX6Iu1ODlZuPOF+5MqneBTuy2GLd6PB2l8/zsXh3Ro8zfik17jDYGplpak 35218748G6tgyW74xOe+nAzKrg0KKuayODZ9d1iE1Ro4w4U+R+eY3YE5swc9AobE80YNpc7F3q0RGr 352188Y5KQW1KC/NSXuHokCvG5Bvuhqlj6z1bfHLZeGeZuTZ3K/p57axJrdzkQGPf11CKU5CTgzPwW 352189cJHSc7PuvFhWYZF7P4dWW9j0qdxMO1zcvqoY+n+9PreQZLSEv1pQQVqWSMnqRwsRrj/bkKqh 35219097NRlBmPQ5PCmTbs0WR5HPL136CKuPzPVp/uG+uweX2p+BrF+mis8a1Upw2zhD9WytEKAMW4 352191lCbtQgcnUhKZlinNuTEBATLCWbX/k6DTVJ+aSqJyR0jdugh0lMPetyb8HWVUR9rXn4ebWfxo 352192E5IYeG95MzgqAzDi2CdDhNC7SLRzIg++o7D/zgOcWEBMarkrOm56ZUgzSxjnixszxBhLP5kv 352193Bh0y72COYZyT8hrTTRR+uB8k7958erATTvTR59OqHAnHLdYQ/ripMrgLk6VCyv+P8+fI/xfr 3521942OfPiZ2NMKUKdRc9YCekyfWlKTg+1M9w2OYaHc7Nseh6umB0Ls9BLfQjpS3fcCNbC/FkcV2W 352195bCT0M46eIyMZNptN40iMO9tQjD78vtI0y3x1rDEmaXZJKdjrY/3NprSWOjXCjLOfjcBKDZL2 35219692ejkfg/0vg9jmRjpY6iF1jf2olxjDfBysfqSgEXSlb1+gzUUprrNylc267CfSOVMU3iJrS0 352197F6qvRECfTYgTUCUjI5hZ53LHvSbpEiu+HEMPhnTk3Hk/L5WLuaIt+oJHpzdhdt8G8FBYBxAK 352198FZogKINzra6YHHEUdz7kW1SL0qadQl93vTGxW9ggSTuHQV4KBE+8Siz4Ffh2Rq9qSf9UHsFw 35219940RNK4MGYlu8ASSrzxjqqvB5bP587iagjwbXGx9pp/syqULN/RTw67cDCYVcYJBMg7ccbfSR 3522007QI/VYPlPIZ65e0Q7+LfFX9c46fyqOw6WeAkVmGIX98A5Fgey+XIuPk7WrpILT6bxHsYLnMc 352201rJbaIRn8v4XI6GtduuPol3LB68xF4lAb7xl9Clcy5eRdnnPc3D3K0y7hN31aVIkzWq2OQ57W 352202+r4kjSxSacpQzwGttrwxu2cZiF1ynnwzvy2+Il15ylH0cuO0a9Q/5NjKubca7U1SLHLXvvqY 352203dOQNCo32D9434aRQqGwty3u8Dp08zLcnsauJwZGPkVthrj3CQBvKIXJUfGWiPMl9OggTb9Ag 352204UeyUIAtgInHYaTwXV9JMpfZ5gJRTR+wxQ5T/enYsq14ntP6HEuv/BwESJEky0KtJ6g+ZfiPO 3522054Gu5mf25+IUBvLahbZExnPTkVFpyjqKTss5CxAnYNKTddf+PlnCW0OtMwLDD+KA/EBHAzeRg 352206GriRuPIJ9Nz9zqDiYJq2lVvKUo6hv5flOU79OGqq+vGRfWU4LTkv9cOYazlmxlE+YsmUBo5t 352207EfleY/S3UiTtYlR5FWGYGyec3qQysge1h359hNg3+dV2igilD1J61ISvHUNQDZrMqg8YvqMU 3522089h6uUBnJ7kscGmH+NYNqta7oFTZ1dBO0WbiEWOr7Zl/HbyzR2jDu7N3smTlii8arXxjSdRe9 352209xuZObmbtIVK95eDncsExylWnY9vPv4+F9WxN9joXX2fG7uSfMQx9wVcIN6iYKBA2N47998In 352210i1HXjOIMNabYNAa2aLTaoNLMa4e6jrCZ7/6ORozdZFePf37h1q8xw5CamNc+87ykkt9dJoKL 352211m2aHZ683XMnu20L3sPTOpHNjdx8v4TVOQgC9E47xFFvy70xDsIz+7k5+3rCXWh5fwmNGBXd/ 352212/TfjR9Jb+gb6cmGIl5mzG3FWbLgAt7OZyDhtNq6QhHdeHTs0W2cgAHNteu6YtnOxY1PIkAoP 352213bH3i/PF0aT3OfFShzvy7Jqrnpcl72OhsKs3g73QKbINaI33v5uuMUhGRJOeLM1DXjllfhx5E 352214UokG77d3pMkRUk/0OcQ/R5cm7UR7bur+hfd4NgQ9t55bVN8Xmm98oMYR7bYLA9OVEf7KU44w 3522159j5hc0y9ZTF1iVVn4P8Y4a+qe4D4iULiryv+uuKv+6vUNVdi9QGoqvpY9oyPMaeeHmPmXOSB 352216AefT2XX0/qyagpgj++OoH/P255RTGF/TTFouiTeGXTZV6KAChPQBBGYUgw17wnWM8bN8dlHV 352217GIPjHzWC+EZu4gVE9A2gg5oVtTGfc/5Yq1ezsHWFT4Af3G31aoVu6LT5Fe88pc17isj+IfBr 352218PR27ricgTa0hHOnpSLyxGzPa+CGk31Y8zase+Z60VdJvRWJzLJOGiVSoO/4Xjr0tqcI9tKio 352219KEeF1rpn+CffxxQntKn07FldHNJkPH7Yg84ulbdHppPiYy/czBRGtrjCDkr2HdzQO+or63ug 352220RRkcEDQ5FnnqR1gQbm+CBwnjCNWzI7+n7Pr7PN4x5DlN8llsORCHTDOYcXlWLFZ19LS8Jpj5 3522212TZazfo99BjA56ND4CcXWiNUcHXXnxEkULj4ITgkAJ4OcoMPpYiP85OKig6Mjc5VUhEkcLxc 352222g2aCuLsLuh+hlU4L4pZUGTv+1a7Jf7iYPU9Vek3rv6ksNOT6+u3saATK6TNW6IwbfPXLXEOm 352223KeGfG/qc/Mbz41mDr+sV5b4fJ//Z6pvi4pVh5t/7d+rM61SJb8KvOyJup/POyv8Gxi22ayki 352224LUn2Wx/H4u/kPq9+vQsD/RWQuLTHpoRixm+chth1vRFgbwd7hcRCWw0x9fg7k7aqi6H/zNdU 352225FSc39mt4DooWFFYywRmeLmXWTtJfdQXXFoSb2BHK0Cm4yBBMqoJD/9J1/2AyRBp9y5oD5uG3 3522261ubxbonvSB5noCrYe5Wx9J+svjlc1xq8t7I6lf1dV/gSm8w+qwrBw/bgNSc4w3A/GUI4mZ24 3522277dScdb/aGPp/vX51CH+aj4fR39uMbUS0ETbuCN4VaQW5Nlbh8j9Z/apg8wbfvF5gxDrfSnXa 352228MEv4i2QU6Ww8ByE6Q1ulA3zaWZJx6IZeVNQmndpOZaS2xC2ZD3ZizsC2CPdzga2MXmClCgd4 3522291WqNoYsP4nFmmYkzNuXEGAQrHdD491jkcA7cOm0h3kbNQeeaLlASB17POt0wa98T5Bg5wsuy 352230nuDQokFoEeJGtCmF3M4VAfU6YvSKQ7h8ZArCmEOE1K0z/n5VKAjUv4tsC0fqEN7TrPw1OZl2 352231dnElHFRSePYSlln8kYQ/0lDLuDgWAVQeZz8M2m9dutWSV2tZRQqfEVfYAxD5/Ds6uUDm1R9H 352232U8osgzHqRJxaNgjNAl2gIvreNaAhekz9C5eSCs06OoxTR5keMvjS+7qyZOzt6GTR0Hfvd5oH 352233ROo0H3F62Uh0bRoKH2dbyKVSKOzdEFi/A4bOi8TltwVWkTBJSf6uzuaZ5GTUa/LVSMwb0RkN 352234g90JA1YGua0LfMPbYci8bbj2QZiYRwJlb8+uxPDWNeBmKyeezROhrYdiyZEnyBIANt5u7wI3 352235CTO559+x2oGm0xbjU8xGTO7WAP7OKsikcti6+KNeh2FYuOsWPheZzvOS94cxu2cTBLsR/SZT 352236wdm7Jpr3m44N514j1wy5RP1wDmrpncvz4owc5yQhbhh8ycVMEUiRdauS6pBKlZL+ErduJ1EK 352237f1Utmi/3cOPJF14kp6VCpZ1h3sWcQUJFlo4LJL51OGZc/IpSzSecmdMWfg728GkxBdsPzkID 352238Fxf41++CsSuj8CyTT4ShnNfyAIw+9800tVvhEyyuy6gF+Y7GNcJgjBMwzG2kCti7B6Nxt3H4 35223948gjpJcKk9IKP8Tg7xl90DTYDXZyGTUPAuq2Rf/Jy7Az5hOKOf1i0o5EDpWDG3xq1EebPpOw 352240Ym8M3uabrnuCz8f5uXQ/gpRyoXac0EFAydXcOChMjkHk7P5oGeoFR6UMMoU9XP3C0KzbCMxZ 352241exi33ufx+tNSO/pIcwo4MnLc8q7bLfx8JLng2iQmuphwGAw1inI3dw9Ksv5JBNroU1IoQzD2 352242pCFirrK+1Ed+sfVkQZgUm2emz0qRvIdJLU8Ah8Ypkrj3mMy5BxlZf6i7q8FRIeDYptL2fbqO 352243yFl90YwaW+Se6oaghl0wZul+xKYUC6591fn2+vaKifa2zuiFhv5OUEo4JLxmC3H+nVpwTTe0 352244xycwkOvS15P9mUgJGYIn36TW1dQ7BxExcxi6NKkFX8K4k0tlUDp5o1arAZgdGYMktbBtRDq9 352245OjnpCeizcN+MIUzuGR8urceEzvXg66SETKaEo2dNNOs1BWtPvzSxW9jrSgzy4jSpsB22JJp3 352246tFAqw60NpHdl7bm4n2+4d8nrdRyA2QGtNiUK2g1JB4fAn4nscm65Eg9yuKTiErze0JIFtesu 352247ijOJCiKVBS4OZQg7AmlbuSUnZrRVThdTKW1aiYOKHHJsjx1JpWbGUAkS1jcn9mlT5x2PvO/W 352248CyfM2XdWkD2+t2jznmH3xFYIcFQQY88fjQcux6mbu9DVxUCa/8TYCfrgGUo1Zf8DRP/RD/W8 3522497KFy9EWDPvNwKN5U5awi9wWilg9H21pecCBsFpmK2KvqdcDYzXE824JSFn5F2AOdQ+GqksPO 352250oza6ztmNIwsb0X0t8cWoGH4qrYq8l9S929TyJPpZCpnSEV41mqDrqPnYcvY5b3xr084aAlXa 35225172DV6Xhr/ruTWNgzHB52Sjj4NsGQP6NwfAYzp8ngEE7aDG5f9GQUZEgn5af9nRllGT5wb1DS 352252M9TnBZqQ5xgbhkTKeU/BdgibLn5dW5YYGzjqBKs6wvtGx75YbF+neWdQG+Ck7y9J2MAofBL2 352253+nCDvS54DwvvTNvtb3B21Uji+3sQ30gBO7dANOoxBeujE5Fv5MxkUy4Tjvd+UU9xNWIgGnib 352254H1/8MUOsbQHNMXLDeZyZxXwzeShmcRzylr6BvjzZ/zvG9mpFnBddYUvsMzKVE3zrtMeIpYfx 352255JIt/RilOOoE5nWrChVV09se4G7k853rWvY0YUt+TuBfhxAtugWGrjuPkAgbUM6mvRWb0YHjq 352256g4sCRuHcN9NUB9r0s+jrZlibI99pDOssowJMpkk4ZpQmIefeSrRyodWz3dqvxSPGeU2RqRkV 352257H2XtOYjlOLZIcrleJVwePJFK3W8ahHMSfdzMr6HC863coMLEIZtWhfBHBRpdGUWv4xJPDOKQ 352258NcRE+Pun3k/8dcVfV/x1xV/3v0j4Y1X8BDBm6lx0cS3GtAuFG7V3S6F0DkDDngtwLsVgz2/T 35225920bmfhz1Y1MSdiy2TumIUBcmSEnhguBmfTA14gSe55peo8uPxdRgxgHu0R9n07SWsdCIyejd 352260LBjOPEe2FLY+jdB/4QE8MsK1NZ+vYP+Ra3j5VQ2NJguPN3WgVVaMbKRTK8aiV8va8HOlz6Mq 352261J1/U7TgGq0+9NrHXaKd6Jp4cWYrhbWvBy0EJpYMXarUZjiWHHyPjP6aE9/96n/834S/76khG 352262CbsyUpoRkaz8M5tpyMauFnr3bggPWzt4NxqGDdee48K8lvC0VcGtzgjsT9IYEaFoxfDizwfQ 352263xZnAg46kWAx+rq4d+X8fH5p0PDmxFr/1b83zKVn+SeHLURrnY/N/YGiLIGoeS5WuCGk1HKvO 352264JCAn6xn2z+qK2h62FE4gJc7NfnXaoN+UFdgXa6RCSuAel4Z6M4FKnhgcnWnRDiax+g/Rf2Bw 3522650wA4KUgszR3Bjbpg5PztuPWNXv9ov1LVsONf7Zodna2/RupHX1ORdQ0zajH/5j3AxK9lXuSA 352266+dk1xZpXJVbh60oHT9Ro0hUj527A8YdpvDFRfZz8Z6tviotXhpl/799zro3hr88Swqdn5wyv 352267oDpo0WM0Fm67jMS8cvP47/8R4xbbtRXZjxB1Kt4k2J4i/b2JxtHYbywJ8/WG1nAP6IW1xL9l 352268J0Zj/ZSeaBxE4zpUW426Yuyy/bhj6TmrgaH/zNdUFSc39mu0jXxvlc+fh0MeeYW7q/ugvr8z 352269lDI57L3C0WnSJlxPKWHbrQoO/UvXzX+B/dPaIcRZSfhPPRDadgRWRNFYdkXucxxZNICYL65Q 352270kbwS0v8f1gK9JyzFzqvvTPwh1mLvVcXSf7b65nBda/DeyupYc4+K/Fc4sXwYWtd0J9YxAuN2 352271DUCDruOx+gTxnGXm79fj6Bc6ow6JhR7swmLovU98rTaG/ivUr0opT7uAqbXdUWfsJuxaNQbt 352272Qj3ob+AWhEY9hduoOi7/c9WvCjavJ04mbW9H88ms9K1UtQ2LhL9/q6jj5qK2f9VIhv9WYZ03 3522738hqYfjdfkGDx+eggKiWSzKc/78D9jx12SxKxmSRrSt3Rcd0js0xPa0vWtamoobBFg+WPBclO 3522744i/iL1Uan8WvsK4FAfTKPNB14zNBmdj/Yin9cg5TattBogpCz8WHEPsmDWpNOcpK8pGW9BQx 352275Rzbij82X8bFYK/5B8IsVrSYDz49MRV0GJFKEzjRJ0yf+8k87AVIQNdyfIlxKnFtjzTP1P5pm 352276RvzlJx4L2nSc7e8hqPZrDEClne4DNxt39DvHJ6KQhMr1ze0FlU/FX/4le/vzLVyKfY3UPA0q 352277tBUoyfmIuGNz0IwiSMngP+IUUst//HciycDqpBMYH6JgnARDcCatQpTf4NIwxmll1wzrXpdU 352278rz/LPmF/Z8ZJ6drLrENe/MWasanBpxOMGpLMGwOOfK5SAI3lexfgzjS9ClMdzLlOOKy01iv8 352279kfOmOO0hNnbxoInTzp3NKt1WpfxshL8fXcRPFBJ/XfHXFX/dX6Xu99nyWbg8IgA1psSySgs/ 352280/rxQAU1xMTQV/1DATnkRctJS8OnjZ3zNUqPMDOaVdra/gMKSFC7t1uO5Wvx4gviLwNjNj8WU 352281IJqEyk3nXFlRP5iDWg7hWPhITaeata96JifxF+4aIv75Kf7CL6RqXP+6AyoVyhB/EX8Ra9Gq 352282U5GcqRF/R4i/iBzHK0Xyvu6oO+yU2SxN4i/iL//JsV2Rjec3niC9TCeyOW09Nk8KBl0d6Vtl 35228330pV8f+fivBHLnofdneAT/MNSCjR/RNNAD/wp9MkYVdnFyq9ad3FpoQ4TdJ+9PchDuO2dTDz 352284clql0XM/omTGTEKw0hGNF1xDuvg3DvGXn6ykXxyLQIUTmi6+icxfbHyWZ8dhU29f4XQSSn/0 352285WnMbaaXin5O/Usm6rE/zyKj2ODYWlN0Vf/k/zL+0C5hcg47ctW/4O+6Kn3QpykJGdf/ORHWz 352286SsHBUxCbX/mcLIpfgQa2/LXb2hQJ4i//bHmzWZ8SScAp2nwRYtL+GWCdpyIjcUbrNfHVUhf+ 352287FcofDel0XtKACbiZW70+0OXdxqRAmUk6YvGXqpdagW6Muq0cfoMPI/kHEt3YlOfcuSaQnl6I 3522888KdNO21QOKR+SoROu4qMH0CqKHq+Gi293OHl7Q1v4x/x735dd363kv6/WaryfuKvK/664q8r 352289/ro/c93vs+WfYkk9H7PKDb9SyYjdhAldGiDARQWZ3BZuNVpi8O/HEJ8j/oAI8RfhonmzGa0c 352290mMw2fU8JEnCFilaTj6ysXBQT9phWk8f+t/iL+Iv4y3fikAWpSM0tgTpxL3r5hGBKbL74O0X8 352291RfxF/EX8RfzFCGMrR35KKvJK8vEisiM8a83GA7X47TDxF/GX/3I5Oa5ZlbB5XVE8VlbRt1LV 352292NsjykxH+ypD59CLO30mxSpJW/EX8RfxF/OVnKlrNV9zdNQd9GwfAxVYFJ9+66DJxDc6+zhU/ 352293CewXLE9+rwc7pSM8azZD72kbEJ2Y/8s7Jn7ew5MWZUV5yMnJIX55KCwTP+FPjKXiyzH0cOGT 352294wpw67cNHKyKM0s70M1LZsEOzda9RIv45/a+XpKj56NciFF4OCkjJFPZugWjQaQQW7b6Fz0X/ 3522953FwfHyCFjcwOnrU7Y9r2+8goE+9Y6OlqmuKiqkWT8BdaCKQjFn+peqFSBJKptWcfwov8Hz8H 352296NJ/O4fdedeFtTxM05TWm466RYqoQ4a/wyRLUU5GpDpRwDmqOoSujkVT0H1DtZ1Nlm/nZN8eG 352297hBLxDzzxF/EX8RfxF/EX8Rfxl3+tZF4cAi8JfU5tEvESxeI/p4q/iL/8a4XKGhE9AoFKKWR2 3522983mg8Zhdeil+dVfxF/EX8RfxF/MV4vyj/gqiBflBKZbD3bY6J+xNQKH48VPxF/OU/XWbWlFcJ 352299m69Ijaqyb6WqbZDFRvyfRvxF/EX8RfxF/EX8RfxF/EX8RfxF/EX8RfxF/EX8xZpiLqXvf7GI 352300n/An/iL+Iv4i/iL+Iv4i/iL+Iv4i/iL+Iv4i/iL+Iv4i/iL+Iv4i/iL+Iv7yXyz/A1lmX+p2 352301IcjMAAAAAElFTkSuQmCC' 352302 ) base64Decoded asByteArray readStream! ! 352303 352304!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:18'! 352305dejaVuSansBoldOblique7Data 352306 "Created using: 352307 Clipboard default clipboardText: 352308 ((FileStream oldFileNamed: 'AAFonts/DejaVu Sans Bold Oblique 7.txt') contentsOfEntireFile substrings 352309 collect: [ :each | each asNumber]) asString 352310 " 352311 ^#(7 8 3 0 3 8 13 21 28 38 47 50 55 61 67 75 80 85 89 95 104 113 122 131 140 149 158 167 176 185 189 194 202 210 218 224 234 242 250 258 266 273 280 288 297 302 309 317 323 333 342 351 359 368 376 383 390 398 406 416 425 432 441 448 452 458 464 472 476 483 490 497 505 512 516 523 530 535 541 548 552 562 569 576 583 590 596 602 608 614 620 628 636 641 649 656 660 667 675 682 689 696 702 710 717 724 731 738 745 752 759 766 773 780 787 794 801 808 815 822 829 836 843 850 857 864 871 878 885 892 899 906 909 914 921 928 936 944 952 959 965 973 979 985 993 998 1006 1011 1016 1024 1029 1034 1043 1051 1058 1062 1070 1075 1081 1088 1100 1111 1119 1125 1134 1143 1152 1161 1170 1179 1191 1199 1206 1213 1220 1227 1232 1237 1242 1247 1256 1265 1274 1283 1292 1301 1310 1317 1327 1335 1343 1351 1359 1367 1375 1382 1389 1396 1403 1410 1417 1424 1434 1441 1448 1455 1462 1469 1473 1478 1483 1488 1495 1502 1509 1516 1523 1530 1537 1545 1552 1559 1566 1573 1580 1587 1595 1602)! ! 352312 352313!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:19'! 352314dejaVuSansBoldOblique7Form 352315 "Created using: 352316 Clipboard default clipboardText: 352317 ((ByteArray streamContents:[:s| 352318 PNGReadWriter 352319 putForm: (Form fromFileNamed: 'AAFonts/DejaVu Sans Bold Oblique 7.bmp') 352320 onStream: s]) asString base64Encoded) 352321 " 352322 ^Form fromBinaryStream: ( 352323'iVBORw0KGgoAAAANSUhEUgAABkMAAAALCAYAAADMdPoxAABBmklEQVR4XuV9B0yT3fu2CYE0 352324pE2bQiBAGAEMCAE0ODAOFCMILkCjgAv33uNVfPV1vG5xT9yKW9zixIkiQxBRCmrZo6yyoYz2 352325+s7ztHRRwPn7fP89CW98e85znvOceV/3dd/36QRof9L+pP1J+5P2J+1P2p9+dXq3zRP9Vkaj 352326XCzR/s7Q/qT9SfuT9iftT9qffnESC58jZJg/pgT6Y+lVPuq+8bwVV+ciLbsKTSIBUj9ko1r7 352327z+kOU2NeBGZ6jcHkgAnYHl2KZsnv67Pmqkx8/FqOpuZK8JN5KG34b42PRCJG2ePpcBsfjhtL 352328+8H3JB8N39FfkkYBnm6egr/u5qOxjeeod1R/OofFk9cgIr0aYrVydD7vEv5eEIK/50zG1mih 352329hjJNyL0Rgq0RZzGvz0CEvChrVYZKtcnbMGLsftza6Q///amo11gmFJNDwnF2WTD2pNT9/rVf 352330/Qln5k/H4Q81Gr6rFp8OBSJgTxKqlNa2RNIIwfPdWLx0LZZPXoiLfJFSXjPyrwfDa/lNXJox 352331GPOjpH0hkYiQd/8fTFkXheJmRV3iymScWDgNG+/yUUveIa5IxtmQhQgJmYFpexNQSX6TVMdi 352332tfdEnLy1DsMCT4P/nfO4NvkgVobdxN4xPeB3KBV1GvqdGueatPNYPHUvEqvE7cypIrzYOQ2z 352333975EoUiiMf/VviVYsmYFpsw/hy/1GspUv8PuVSdxK9QPPcaEIV1TGXExIqn+i4jAvMEzcb9Y 352334/AvWUyNqKupU9hyJuAZp4Yswbf/7NvfvxqIX2Dl9Dva9ErRaf41Fr7BvyRKsWT4ZC8K/QqSW 352335Lxbcw3TPhYi4OgeDZz9CqVjSqk2CZ9sxbe4BRAsaft3eIa5DWaEAlQ3iH3hWBGFhIYQi8S/b 352336x8rjQ+HftTvGh6Wi9hfv+RJxI6qLClFS29xuG+pL85BXWq+yzqm9q6a4EEVVjRr3rFZzQfgF 3523377z/ktnvWU+8SFfGQkMRHRdPvOXPoMRIIfmiMqGfLBYUorRP//z/jxPUQpCaBVyxqs/+p9hbz 352338kpCSp7pHS8TVyP2QgJT82m8au9+ZOqn/UB0Xgm6szpgVJT0w63n7MNRrK6KfLEP/0eeRozQx 352339RJ+PwG/kfnzKvIFJniGIq1bbJMSleLhsMe4KFAMmrk3Hhfn9YME1R//ld5FHDgVxdTIOjB2B 352340jWqHtKSpCC9Dx6OnGQv6XBt4b0lEtVJ+S9uSayWy91UhMdQbTn5hSKuT/SapRvzanrD2D0d2 352341o/S3qgKyweRexayFj1BcLYCguvl/JBiJwD8VCO/1sfQBKV/gWZHYFNAD5hwOrPrPx/k0tQlD 352342nsuKWAofFzPo6zDQdWWsSj+09NXzzYHoY28MJoMDmwELNNRTg+Rd/nA2Y0NPj7yrz3QcS67S 352343OAkl9V9weqwldDuZwP9yLppU6qnF+029werUCZ3oP310C4lr1SZxdTpubhiHPtZcMJjG6DH3 352344Dgpk80dS/wm7B3Bkz0v/dKyn4n6JuJWQVvLmIGYMsIOhPhPGLv7YFCVQEQypPqxIPoMFgzrD 352345gGUEJ98NeJTf8GcJxQ25uLnMEw4mZC4buWDcwST5HPieVJ20Ff04pL/Mx+G20rqSSISImmED 352346HbovdcAwtIfXighkKgk74toMPNg1C0OczcBmcmHtNgH7k6tbP6+jD65lNwxdeAIJwmYN9Uv/ 352347DL3D8EUkaTePfm8NH5E7p8PT0QQsPX0YWHeH3z+PUNikeFbXchIiydhTczRxQy8wDYfiJL9B 3523485d26VlPwsFR9fpC8mbYkbzIeyPJUyzei7O1u+FqxYOm7G2/LmpXyFc+ofqNiPkvqeTjkbUS+ 352349iYMBuz7RQqiinCGGnqDAjQhfwobAQKnNVGoQvMGxpb7oaW0AJpn/TsNW4MInxXpT7zddrj18 352350Vt9FrtKYSevwk9bBMoHL8JW4zKtuow4dME1dEbTrDUqbJXJBrSj6IGZ62JP1oweWcWe4L7qN 352351PLIXZpwaBiOlMZP+cTFoP4/spUI8ma7oc0kDHyeHGoHZYy0SyD5fHbsKXZnWmPZEKN974zf2 352352BtvQC/t5dUSAvIkAMy489vEIYKrDx1B3cHTtMf9VJakrC+f8TMB22yh9tiYZ2/qxwR24G5/I 352353vi3KuoypdmxYE9CQTv6/On4depFv9z2TQfqaALsP+zHUVJ/Op+dX2WPMsNVR+w4T+J3Pke8T 352354EnEZ/T10P1lMwN0i6bgLn87CgDnPUK68n4g+44iXAV0Pu6/ifGkqjcPp0GNE4G38dqBWHoON 352355fjMQkdf0DedDHVJ29AdHbW1/b6qKWQ5nph3mvSj/pvJNRc+xxc8Rhno6P9y+ljOBbRWMyOL2 35235689qv59f0wZ+oFKnmP0NExBPwKpv/m98gLkfCgfHoZsyAwaB94BEALKlJwsYhY3EuS7EmGvgn 3523574GOkC7btSIS+q/olQi4lNH86Ox0uXDbsxx1BYvm39+GPrFvtT9qftD+1nSqil8CJ5YjFr8o1 352358KBv44AsbW8nxpTH7MaWvNTgMfRj1WoYXQrECA+U+xd6Zg9DFiAmWqQt8NzxFEZEPxYI7mERk 352359t+5r4ok81oicKxNgTc626TelymHq2Vr+HWwM6g1rLgMMtinsBy7CrdxGpfM8F5FrR8DBkAmu 352360jQ+2JlYr8qrisHnCXKycNharHxTK6mxA4fM9mNrfGly2Cbr6huAKT1luE+Fr+Ay4mbPBNO6B 352361GRcyWinQfv68aL8NlIxM4y+OO0I/1snw1gccGtsFpi5TEf61/tveI8rC1Tm9YMI2g8e6aAgp 352362xW1tCnYPswKbbQPfPclyXEcpNMpyM8Dn81X+sgTfpsiQiCvx4fQ8DLBmE1xJ2s7sgX8SqtuX 352363n6risck/CCsWBmLmyVTUtODm+q+4uGwY7Kz9cTG3SVZ/Lb5cWQbPzgZgW/TH0ps53zUuYlEl 352364BLmZrb6Pn5GL0vrvl0Vqv1zHrvXbEJ5cIVWmi7Lx8OBGrN95EcnlYoXiPSIAZtyB2JNa/814 352365748uk/AverNIGbOgNss0l0RhiYu+msxOYU9rTLlfIp9P34xZvwOT/myeMg79ud/q8GnXAHDo 35236676awmR36jd+MyOx6DZj057Dmn1imo6SCfZmGsPeYSgimWZiz9y2EBN92hFF/d357uJQikFrG 352367Ts+6td5C/o35T7AtqBcsOQwwzbpj4uH3Ct0gkXnTLi5GQEgkChs16OhEBYg+sR4hodeRXNao 352368pHf7jBubliBk42JMWH6LxvqKZ/i4d/Yurq7qC4tuC/CgqFlJR0W+z3cAVkQcx9h+ixBdoaxj 352369I3rUrXOx//EdbFpwDDzRrz7vKPlgL6ZM2oOESrGGs6MKn65uwJINF5FYqnS2N5Ui/kQIlv7z 352370D2ZO2oHYcrFKm+NCBsB3XwTWeQ0jegkp4Smu4+PywlFYeV9A6zUpGaIu5ymO/PM39t3loZzI 352371HRXvT+OvhRsRumI8lt0poMvV8/ZjmNd6XD/gDw9aHlHIA/zTo2FJZIGJK/7BvwcfIEfWP5Lm 352372UsReuIq7B8bC3mY4DvLqVciujJsrMXbhVWRpIiUbihEfvgkh2y4joUhB1orrsnB/5zKs2vgX 352373Js07D77Ss5LGXESdu4UbGwbDynEqrucp9VVzIa4H9cGca5cwtc/UNufkDxFlCQcQPG4PkjSQ 352374sJKmMsQfW46FoQ+QUas0Pg2FeLZrIZZv34pZE0MRX6U8dpWIXtgXY45FYOVAf5zOaGj1zoq4 352375bRjmuRL3CxpU9Qc729YfUHj1X8/hCI3YAh/vnUipk2gmQ2gh75g3DI1GyMFtW2QI1ZjiyKnw 352376WPQKuW9XYnDwbQjki7gG6ZdXwMfJBExdPbCJgm7KhUxaMCm8OQHOHpvx8Ml2DOwyDvcEJXi5 352377bjgCDqW0YupqEjegFxHS/I8n4OvHaEQlFKkowZXJEFrZkLQDA60GYGdyjUqnlT4IhpV5IK4X 352378Shc+7/JaTBszGI7O3gic+S9u8uvUNpk0HBzuiU3va37pgheXRmGZ11RcUxLUxVUJ2OxuBIsR 352379e/Ay6QbmO7NgHXxX3pfSb6hHRuQ5nNwzBU76hJy4pEpO0GUIyXTl4Bk8SeYj7fE/6MPRg9PS 352380N6hSY+G+vHiK+M9ZSHu0Dn3JBuy8XLVMi/Iq9fBIWLL0oKPfDSFxqgKrpDkPV0dboevSh+AT 3523819rmQsNdlNU1q1gV5uDmrC1GA+SP0SSr4qc8RcTsdNUqCdUWxgDxbiMwXG9GPy0Gff+NVrDek 352382FgjxWNOdCSPPHXj+/g6WdSP/HnZKxbJCLHyJFV056DzhJGJiwuBvzoTLXzGtvuu7x6uuGLlF 352383dd90gItFpcgR1LRpJSWpy8CjG1FI/hyPI+RAVVay0nP3SyRCZ/uge2cLWDt7YNKGa0ipaFbr 35238401xcGW8lBRKsPtiSXKtEXqViz0AOOO5krWak4tp0e+gZeOJQmkh+CIZP6gyW2RCsjSDrKZOH 3523856MsncDejXuV5A49QxPA/IzpsChz0yfxY+lwKkGT53IEkP0c65kVCKRPcbh5573nqvaaDsOpi 352386DNKzMvDx5SUcOiMlg1qeZffdJl3HYgFuBZqB4bQMb6okKm3jeuylFXCqpB0P+wdxybv3ILVe 352387vfxORN1eCw8TNroEn0SKbLOV9xVRvqcq1dfyOy0A+xwnc6wJ+TemwFaPElZtMO1xmcr3UuVM 352388/M4TklWIp7M6g6nUZnFlPLYMMIA+AWs77ieDF3MCk7vog9VrHeKrVdvJ6beJjFk67q3oDpZ+ 352389V6yKrW63DnbvjXinVgd34A684SfiuJ8ZdCwm0sQSXUfJI8y258Bl/mUkZWbjc8J9XL77mV6H 352390DVUlEBRm4vlaN7AIqN76OpseOyEBfpK6T9g1gOpDmdKz4iXm2+vBLPAGCsm4NWaHY6SxATwP 352391p9P7emP2RQRasOC0OIq2nJEIHyPYgo2+W5NRUxWLv3tyCUlLgA4h2UXph+FlQEgXQpS0AP+s 3523928FEwYzpjyZ0n2DnEBNweK/BYIAO5onQcGWIITv8deF/wFv/2NwCr62JEFjbKDtsalAmoeZeP 352393tDsr0JOjC9Ohu5GoJFRJ6lKwkzxnM/k6PhdXQCTbZ2qTt2Lo2HPIUhYYxQ2oyn+LUA9DWE15 352394QH9PU2k0tgwxg14nXRgPWIuo36BYped+kLl8LfyoEiXjNCG5jIbhFL/hmwj6z0e8CLjywr7Y 352395nG9qH6e/qhAht6QRFkFQUoUGcft57dbTkuce2irvT05icXO750QLyctuBxj96akp7yrGEIKz 352396/8Yo8Euk1nmayBBxQxVyX22BO9cYI8Oz27RoVU+J/7rDlEv2ctmfhfc++f78csd4+BEQ9iY3 352397D/HnVmD02PV4mCv6BiLkx9Zte23R/jztz9O2vFbKzNoyCARlqGmStD5PTi7Cznc1reT4f3qy 352398ybkcihefM5CalIpS2ZnbmH8X811Y4LjOxrFnyfgYdwenziejktpfmvJwLcAMHHImJmU/wRJn 352399NiwDw5HZIJHLfwe8jGA0YB1uJ/KQ+i4Kl45dxiclwzwaRxo4YPb1j/j8PhYflZUplLX3s3Cc 352400fciXK9qr34dipMcsHIlKQUZ2OmKv/gPfgfNwp6BFHslGxAI3GOlSylKCs5a9+Wms0Uqh3EEb 352401ROXkPKWwFxmDWpnhS03SNgQtuY6Eh+sxfo0q/mkL00oay8BLTkX8yUD0mX4PAkrJSOTZL7w0 352402xB71RbegCBTI6heXPsRUa51WxjMDd3/SaKmunuo+7cIASpHeiQP3zTdwdOps3OzA4IEy5ilN 352403fojbUakob1az6CYy6JjBa+TydGPuJYyxccbsi2/xeH1fWA090aEFPiWbVPFuYOO43rBg6rRW 352404zlN/xiMRntXY6rnmxiYlgkyMxkZVGUAsfIFlLkyYjQonyq4KxO8YDGNC5E2+wJd7VNDPVRM5 352405vEiIenW5qR289+eWycHlcZbSMuy+2KapDNFDJG7tD0Ob8ThwKAhWuuYIuMSjdQGFRB9UJbOE 352406l2NWc2+suy7DrFdO4V6GSA37fCcm/dk8JRz6U79RxsJTrMCwm4HbaRlIurEaA4yInDL8OL6K 352407JK0w6c9gzT+tTG3hVxTWieV7cBFf1VKfqmPrQEO6jp0PkpEWvQ/DTHWg12U+nrWQ6B1g1N+e 3524083xEuVRo7ylCRRXSTiy59ob2HWsb/yRx7cF2X4npcFHaNtIAhwT0ffyPukTTXQlhB5nNjNSrU 352409dXYU7i0tQ3VdNcrKqtEoVjU4LoveAE9be/juTf5PeFBKcWcJhHV1KC9pvb9+N8YjZHmpsAZ1 352410laUQyvqO9gqKPom9YeE4Oq87THuF4HmpEsFE6TmFtWhurkdFpei3ez9QXhpCYT3ETbWoqG5s 3524115UFTXVaGKjK+wlINOL0iGou6OWLqg5IOsKwY9WUCVDdJfuvY1ZOxK6fHrlyur5HjuqIn+Hvs 352412EkRkilrpD26Pa1uHQnvUkLlQW1dBxlLVw0yNDKnAizmdwe23HR9kFYlFQuTnlaGuhiiGCyql 352413ljMyhlRdaGhRUjflXUOAhTWCDh7AvFVRKCzm47NA6trE2++F7vOikBmzDgMHb0TkhQUYMuOS 352414igW7XIhN2gg3FhPdQ17SCtnWk1PaNqqjKKE5YoINrIKuIU9tkKreLIezYT9s/yAlPXhX12H6 352415mEGEDBmCgJmbcTuj/reTIRRjxTvgh+E7kxWEABnwIkIo2ejbY95TIcREsN/nQYDI4ANIE7VW 352416KJXcJ6QOqzvWxLdvTVP7IRTuHKmysV6jO2UDBE9XoxfXCuMuZau4DdKK+fe74eMyDEvmuIFr 3524177IvzOWqbZlUMVjjrQ9/QFKaWzvBZcRVf1dy1at5vRm8WFx57NbdBWcC6OtEGbOfFeFzc2tpT 352418egDpw272IwK+CBhy4cJ52QuV+VD1ZhmciJA593k5AV1v8ZcLAyajrsjnAaUIDXUn4G78TRQ2 352419t/2b9LCoRnZsBPYuG40eFl0w8UruNylzxEX3MdvZHF1HLkTo5WjwK5s09/uLrfCxtMBQ2YFC 352420CQK5d1fDf9QSHLwZjeT0r0hLfIKTy7zQK/gSshsUc6Xi7Vr0ZHHgGjAKzmwLjL9bpLCgKbmP 352421YEsdWAYT5W1DLiImWUPfbiYeyKy0ix/Ohj3DHGPOZ2l005Y+r4fOc57TVvKS2mRs7sOCfncp 3524222Gip32JCJErU1mJ7edL3mmF0eHvv1YFZQARy60Tk8IrHv71ZMPZVEK/SMrqwnRkFoTpxJ3yC 3524236TZ6sJnxRJ7XUifTwgU2BNT3WBgBvtL8bKnPZvoTlCkLYPTvTNh6eMHBcRoe8l9jjZst3Lwc 352424weEOxkEZsdRSzsqtByysA3CN/5EmZJTbnH99PCz1LBB4JVdmfUCY7kUOhKBSr4d8eyBFJIsh 352425uBkAU0K6zHha3kEdhORKF6mO2+xn5ID+hMPehGjrvQnva6TtEH0JwxBDPQIMQ3A8MgE5al5w 352426EnEJ7gcT8GI7E1FCpb4ojsREC11S71O6XykCw9NASm5QLrLUHrCcELf281+hQlyBt2t7gm0y 352427Ase/yIBKxQvMtWPB9e9YZEctgGuPiZg/0AmBtzPxfns/cEz8cC6zQYUoXuioDz0mAwyzETiQ 352428rOz90oS8iAlk77NCvwF2YBsNwra4ilYHtig7AjMd9MF0no/beapEgFhwG+PMjTBULUxBU94V 352429BA1Zj3c16vPqKWZ3NsLgA2k02VP18RIOHt8Pf7Iv7gzbj3PvyuXvbyxKxPMU4TeFi5CIMnFp 352430phssDfShq28Eh+Hr8KhFeK5OwD89mOB2H4eg/pbgmnTHtDM8WnimlTZRuzDVvTMM9PVh1HMx 352431omSEl4T0f/KpOehvySXCWBBmeVuB5fIX3raQieI6ZEZuxYS+1uAyDdBl2Frcl/UPX9k7iBBi 352432lPV/0rGZ6EvqMu4RqFKXvH2ugQgaaAMuxw6jD32kzzNpHiHypzxs7Uaulif//6kPkPnhNKa6 352433mKH7nHCkErJSmseWr82Wd3K6jsboflbgmrph2pZ/Mb2/FQzIvxfcyKXHU17O2Re+fSzBUW6b 352434uAZfb21AYC/yO2VhNmQFrn2Vktzy51z8MbKnKZnDSn2u1K8m3cdgqqdlq74wcB2L0X2tYD9J 352435asBAh0yYPQC2Bgzosc3QbcIJOoQA7Rkll5XMMDaiQEomVL7GEkcWHBZHE+VfBV7Ot6ffQZ/1 352436pv64nNtE9uIPCB1oBNvgCNRS56pxL2xIrEDOpbEwNxuDiPwKJBCixdB5idTaLPsCAiwN4L7j 352437PQriQ+FNZDG/g8m0oYGdsTfCyBqlrH93DTSAyfAw6dqh17eSPGcyin63cqp8Tc5Zgz7YrEzC 352438ayBDWkjGvoZOWPqm6ptlpMTD23D3Uxaysqi/FNzador2FPuZ9KPrtr22aH+e9udpW963gNfq 352439zzewLqAXLFm6YBi74594xdqvT92DgVwTjLqSp2LIJXy1hihYOER5SpRFFg5wcfXA4nuF8jKU 352440siEr3BfG3B6YOM6V7P/DEZamZF1Z/gwzbXTB6TEHh+7FgV/e0Fou4J+Cr6kumLZDsPRsIm1V 352441TMsE5Qk4OMEVRpSxix4XXWdH0mTAs1XTcSQ+FmFTe8KUyNvdFj1B2oMQzDkjlR1qP2zHAJdJ 352442OPvyDv7uYwXvMEVoFVp5/yke/OomVPET8LHkx4wmqDaEJbxESDd96OibwT3kMT5FKtqgEYOU 352443vcLqPkSByHHCrBt5qt7zbWBasSgfr44uw8xVpxBf2iS3yny1wJ7IYq5Y8bxMQ+ghglnu/YU+ 352444hmw4zTiP9Bol2VpwB+MtOOi/MwV1Tbm4PMoEBp6HaDwrjJoKK+psoTyEI6OweVpou0YfDfyT 352445GGqodCax+2OnUtilytdLMGD8DTl+q0n6F2425DzMzcf9BS5wmHYfxbRuQIjUuC+obK5B5tsP 352446KFHSD9Sln8AYSwYM3BbiXFwOKuoFiJxE5GGb6XhUKtaobMqK3IyA7iZgEILdoOtYrFo/F16d 352447yRzWYcNuxEY54U4ZMfIOesKQ3QNz1k+BM8sIg7bEyOdfi+Ho14eEjLuVhLImtWgH7eC9P7ZM 352448zBpShmCu8WPhQspMjCxuvR6/noCvmTG8DiTh/cHB4Op3w8oXhaisrERVjUJhSGNHfYJ/LuVo 352449xOA/ikl/Lk8Vh/7Mby3RMbiD9kuV7USRdzPAFJ3MAuQk4a/Cmn9amacreqP79PP4XFOHrIj5 3524506NV9toJsljSj8OZEWOkRkuxyLkTVn3B23nAM6WEKXe4ghYV/Bxj1d+d3hEtbsLn1+HDEJUVi 352451IyGIdG2m4UELbqMxBAf2Uw5hg48dPLa9hkAk7hgn/kl5DTmImNMHViSPwbHBoDmbsX6qO9G7 352452sGDiOh774qTydfv4tW18qp5n7xOCOzmi735OJa8tPKqEXb/5t6ZSvD06F56O5jAy4IChw8GA 3524530I/SCCIyjMh0nIAN2xZigKU1hmyJI/qSDjDp/zhP2VOlJDcXRbXqOqJa8G9vlD/bZcBI+M8+ 352454jpRqcZv4lcbIvyFP+HSORgz7uYU8rn6HdT0161A6eraTOqtyI6CzfLG3zT4RBjH3FQHBwxAa 352455TYRG/wFY8oAvZ9Cbcq8gwJwIn0amsHafjV13eUQQkSnnsm5i9WgPDCRK4wMXdiLIezFOnCHK 352456jdG+GDX3KBJkbk6i3DtY3s8GnR3NoM/siiUPC1AQOQ12dlMRWdRaSGnKvYzRZmYYcy2/FbgV 352457Pp0BG0NqE5UK0ZV5hajIkYbJKqok9aorCH8DGdJUeAdzvOYjUqDEGkqqELPCGQyiGKRcfWlm 352458zkGPKPIvI7eVxZUsfIjpWEQUtB0iQpT3EH+7m8DcZyfiylv3U1XMSvQ0JJtaJ310mXZFrmyX 352459H/gVcdg8qCsmnk9E5AxbolhcgZgq9TKpeBgZjRReIiKW9QCbCLfzXlS0tjbuxIb9IA90s7KE 352460o88q3MxWY/HIoVcStZQITdaYcFmzwCNpLkP0uv4w0NGBnh4DFiP3qVh80+P5agFRuFtiwvVc 352461lLxej95sHdhMUyjH6dh8RQKUVCmAkvpv4lo+InfPx4huNnDymob1x+8juVCxWTQX3MAEO4XV 352462nPTPBv60i2QLcViEj0/OYPPsoehq7QzvWdtxQ+baTh2cRU/+Qk+jzgg68k5u5STKOItJftsQ 352463X8THrdUj4OoyGBPH+2Lpg0ScnTBe7h4macjAGX8z6FkEIDwmHP4m5FDeplinFEDrx+4EHQYb 352464HDYDOrrm8AtLlxNRtDBiNBxnMhvaINCo5w3geUhq6U8p4Lb3Y8vJEHn9eizpt1sOwxGZYNNe 352465nvS9Upfe5oLrpA8NSBlzeO5KoQ+MlmdViVV9uK5WuCG2tM3ryOdWbu/1qXvhwaXanSbPU66T 3524662X01YtTmizSfkIUHeCr1SX83xZiwM5jq1A2B5FC389yAsNlOYNrNwbNy5frJXnM8HLMdbDHh 3524671FkEW7NU2kyBSV1DHxyXh/oqx7PZnaFrrPC6k9bDQNdVsahqyMPt2Q5gmo/BhezG9uugrP5l 35246880J53Nn6umC7zES4chgtUTauL+ots2LsBIb1aBz5pOQ5V/cBO8g4G3geRroSAVv7fhMhMw0x 352469JOwL3UfCqBmw1bVEsMyFXdKYibPDjQgBfhrpn89htDn5/lXRcpJSUkWRkuRAm38VZyc6YeDO 352470KFwKdIbv0WtY1Z0N60lqJGRjDi6MNoMO2TP6bWt9/lAxwZc4M4jSwhqBp7+0IljF5XHY7mlM 352471iJRh2JvU2h27+t069DRwwcq3al5ulWTPHdjaZZS2YjS0Vwk1RRFvwa4BuKFkzdgoiMJaTzdM 352472PZdKyKga1LT81Yo0KlklRPkQ+zwOvOwcfLq+AC5MMwTdKZKdmxfhZ0yIq1H78Yr3BvsIsaXf 352473dSViKZfsd1vhbmiEfiuvIZHPR3LMOyI4S2QKpZXoxrGC/75X4MUcgI9xJxUyuDxmLdy4Fhix 3524746xlSE8Mx0YaDHv8k0HO1QfAMK11ZsAi8BJ5AKK2LbU7KvkDq633wNlLU1dI+2/Fn8Cn3Nf4m 352475gp5qHheDD6a1WqPqedL/Z6LLyHEYaGOP0btfo1hmJSzNU6z1lnd2Dr4AHi+c/FsHpsMO4B3/ 352476PmbYEqAx/SlN3rbXtoo3BKCTPWd46FPw3p1GoBWDgFIp2dKUe4nspZr7XGO/+kvPZun7dGHm 352477vRWPeFnILqymx1sYNQ3WnB5YcikWqanxePqMRwu/otxIzLRjwm7mHXwRFKNCBnoostKbjOuI 352478c1lopOSOwQZ0uymX7EEmlJeYEHnXg2FrNhSHiRJQ9OUohpg6Y/nTWOzzJAK45Qgci4vEvC5G 352479cA9NkVtevtvcF4amXdHdyhwD1r+QK4D8zGwxI6oEgvtE0WDQC+veVsi8OSpRLMhGwqmpcOJa 352480YuSuWFWlTXMpXoR0B9d+Hp4KxR2SIcInk2HJ7I7VMZWKvYic5bEHg+Fm54Khy88iXlCL8pQI 352481hEXm0GdoUtghxFdK5Hvd2wPnfpoM+dF1215btD9P+/O0LU8di1DkbufR15Av2yOkYW/YMHcP 352482hO+ojYiMeYMUGRFQl7ILnqZEJiWEhx5RlFoOOyw39qJCUh6lQlKaBeKWBi+B5N1j0NvFBgYU 352483YaHLhLG1I3r4blV4xlL4YLM3zBmyULucbpipbHlPhTkd0RW+O64jYkcg7Ax6YK0sNFP5s5mw 352484IXv1ijvpKBJ8QVJKEb0PXVi2DZGXJqJLz79w+yMfaenFqM27gb+2SsMTN+ZGYIo9i5DPXvB2 352485dMLMKGmoUDoc7OZAeI7/F8d3TofXmB00BmsuiEAQkQ9ZLOU/C4w81TaxcWHZTiQI4mgypJOu 352486CTzWvYQgR9GGtq1Xy1EsrNeAW4gsr0tIKrYqbvkYOgAcHQbYXDtMvFlI732iKqKULuEhYlZP 352487Iqeren1QChP+tflw5XDRfeF1ZKiFj6pJXI9ebOqMEUJc9QbLnFjosvAVKqgzujASC13Z6ERw 352488yImXZzFjfiRNVki9Oi4jwNocQ4+ky+UHsagCgrxMJJ6fh+4GxugfEok82bypSjyAOf4e6O8V 352489jG2vSuh2U+G2D44hSkkGC5YDlyGCL/N6b8zHnSWe8N9E5sAaolRdcQuZsnZHzSWkD7sPNr2T 352490hV6qeYf1RJmiwCKquKM6cQv6Gxii3+o7+Jj2CKt7ke8xcMfG5/kQ8sLgY8TBwD2KuzSaCe6f 352491aqtLYxqHGarhUGhi5c5K9DWxhK/McEOe1wHe+yPLiPg47UeVCcKFt+cxipTpt/2D6vxpKsCt 3524926XbguoYgWliKJyohqXRgOekeisRKmFUJL2nGrN+PSX8uT3U+/Mxvm9wJXtGR7mt2VGSVRmlU 352493hE6UZ7/MiPFXYc0/rQwVLj98ajc4eXjCxTkQYR+UwxAS8mQxRZ4MwaH4Nzg8bRw2PuHhyVw7 352494UofCOLcjjPq78zvCpdKxY0uJYaLre7PMCQwl7C7FEEbw3rIHAYQ0MXYPwd1sUYc48c/KK0T8 352495i1jwsrKREjEPzvoM2E08hhheDA4MNYaRzzHay6k9/NoePqXzDMj+uPsZeEnhmGTLls/9Dp9r 352496I08zHlXFrt/6W/6NybBl2mDM/qdIjgvHtC4MmAbcpA3j5OWJnqm+5j029WYTkvUuvb+1h0n/ 35249713kd6TbLX/+NnhxTQuTcxu0tPjAjckTnWVG0rqct/Erh7t+RR/epBgwrlo9R23i+o2c7/Qi4 352498rHi1FK6GLOhRcQ45bDB0KeKjN/6Oq5ZbwBe/u4ZNAa5wcLQAk9UL6xPVLFIq4rHDzw9b74Zj 352499St+JiMj8jFPDXTFdZhX9dJ49DPpuQWJ+LLZ4GELfsh/NvvXb1DqUklTJvxzOBr0JgVGrJrjX 35250003EZDQmIfyZs3yW3I8FRU3q+0BkcSri1GYeI/OY2rKaqkbRtKPwPp6lslhJJGR5OtICewyJE 352501ExBS91Hq0aHJm4K6jOreBAuw3DYiqUbz5VmVyScxxckIdoGH5Hc9tPrGGgGyv8QjfJYT9JUs 352502zFssjGPXu6PbVCK0lafiwGAujIafBr+dC36oA8JGzxaznpWrhgRZ3wtM8nvQ0Wi8v7+GEBTS 352503uwiUv0tMWLyt/Q1g7HO4VfgjaT21+LhvKCys/bD76Qe8PRFIWHhFGCGVueRtSuYjg5BFpmDr 352504mcutEjSPRzME92bDzXUcTn9tsbB/jIXduDDtOxOhV1+DX6HmFt1UDUFui9Vcy18OBFVq5SjP 352505krgb2LdgECy4Dph2PU8eh1gQextX78ajSImASj8SiMmXM5BxaRx6Bx3C89dnMM7FG4d4ubg3 352506N1geF7Ts+XJ0JQeN05JnEJZHY7EDIYYmKsCE4PY4mOvaYNLVFGSk3MJSVyY4A3bJwezjyZZS 352507d+9szYJly/MzZMBO9JnakHRhFXyHtpaT5lth/OUP0m/PLUJNs9q7r6S0ynsUTN4rI0PEDeX4 352508enc+nPQtMPGe1GJI+qwlxh5/haSkJESfnQRbPUJIyCyn5fXr2WP+y4pWc77s0VRY69lhzvNy 3525091W/Rs4HvknFwJEy2xzYpG6/6rZ0x66mwdR+wyB4S/wlniKK/k35XrHgUj2NDDWHofUzuukyX 352510Y/fG5sRsPCCCvWnXfujMUm1z1BQr8t0jcFYm/EmoUFGUBTp1L0a9Uj0UgNcnBBZLj5CifbHo 352511ylf55Z9R06w11sHus0VuUUfXweiCWTcS8WyHJ4yYrgh5W9VqvtfkJ+PeDn/SV6r7i7j4HiZY 3525126MFO5hHUkoruSPuI6teWOIxsAy8c+SySC6yvlziC7TQN2+a4gkVInPAspdiNNYnY0IsF0/5B 3525136OcwDMe/CvBksiNc/T1hw3bAgqgyJWKyFrxjo2FJBE9LQwa4A1q7Cku9EQ3l8VpVCYYsXJ3R 352514BfosFyy8k9dqr6Yvh7zoBxPTMbimtkdTypJ9I/1pawHleSW4Mx7mxsNUYlVqUqq+W9cTTE2h 352515FSyC8UTYev8REkFkmZ8b7M2NYcDWJySWC/6SjZfcw+2ZUHr5IDkbmK6raTKSFqQtxsvvOlFO 352516rxaQb7ebi+flMmsmSxZ6bUiUg+tX8wk46UTOaI70bGPoKMIjUoqasaaKOUGBEIb1NDwuE5M9 3525178QEmWynqotvH6oKFL8sJ+fSc9vxpuVunJW+B2hqlv+v1UvJdijy6LIMoxnQImTDqnDzkiTyP 3525185YBF0UplqXoJKSUNs2GK0VfzCLlABBsTxT0+7bXtJZElWr6JsjpZ6sQgoFtq+ddyv4qmPlft 35251913uYaMFCz3XvlPqCkGXPVO85a8yPxGovKzIndMC09sLq+wX0/i/iH4cPEfCGn8lUmZ/CqJlE 352520mJaeaVR/T7Fm0/0tKX+BefZmGHH4Gta4mcBNds9Yc/41jDazxph/52Dw8FX4a7g3FoYMh6WF 352521gkRVWHESMrjXepX1sqO/OfpvvIodXqawm35bcYcXZf1zdR5cje0xPixZ5T4rijBc2pUoiHQt 3525224H8sTVW50QYZUsc7jOGmOuhECJEQ2XndXBCJNWvD8Sb5DS7/M5LsmXpk/5iCszzp3Wb/SzKk 352523o3Wr/Upx7c/T/rw2yBA6fAgXNjOeyg2OSh9MgRXDEfMvnsCCVU9VPHjF9bl4vMIVTBNfnEzM 352524RK6gWi6bv/zbQxqeSJcDa6duGLQkkr5LriXt8rSQ4jFaaahPlPYGcJqj6iFM3xtSmIJHh6fD 352525mex53EEH5DHNxUV3Md7SFF6bHyKFENpDuwzDUZkM05B3F8v7E9xAeaXYjcLueCkwjloxFZv3 352526jENXz31IqWmCqLoGgschmH1SqhRLCfWEGUsfTKLoYtkqDCkKb4yD6+hTeBe1BG6Dt8svMW6N 352527HXi4u7AfRh7n0/VpwpBRK6bj2LuXCPHwwZIZQzHlPB/5TxRt+Oa9r+Xdn59i46B+WHGfp4Jb 3525286svykE21KTsXxTLv6Xfr3GDA1Ie+uQ92JiiR2YRk552bCge2IfquilS5207uwXtlFEwMvRFG 352529cJVUqWEsVWrIlYfPsMx/LZ48WI3gvQqiRSwqQ75SG1rIgsybS+FmYg3fXTEo7SAsB+/gUFhy 352530OWAyiJxtF4w7ArHcW6fk9U4M6zMXN18cx/jeQbiYI/1+KhIDRcS1xBeXhn/Vh8siQnbQd4Zk 352531QVCjkBnjV7tC32QUruQ10QTB6WEEJ+gyiI6jheQic00pIoOkOR8RY0yhYzlJ3h453ni4GF0N 352532HTEtPFUl7AyNazrAe39mmWVwoUIrL3kuL9MiZ7WUEUavRndmC9lAxkqXupdvM+JLKWOEWtQp 352533XRZNY1ajYa3ixaviuPYw6W/IU8OhP/Nb9v3FpL+4GLDtJTJL69FIRZew14epv0Im/lVY808r 352534Q9+De20GupD5YhN0Bum1qnd30mPPtEKfweMR+roUjbI6DDwVUVM6wqi/O78jXCrF9wSvXMtH 352535QznRY/bjQM9xEV7KjCppDMF2xvI3xciJDIG7kR4sgiJopW97OPGPyks6Q/J6w95ClkdkaD0W 352536h1aos/Q6gSXTVbSLX9vBpy15DCYTLPLH0GOjuwzXfctzmvLUsaom7Pqtv0VNt4ae7Sw8JZhB 352537Uv4SCx30iS7lGS2f0OW5UuMLqZcRhyaHazvApP/rvI50m5Rnhp6JF0LWzcfCLdsR1JkBq8kP 3525386Gfbwq81kt+TR0X0aQvDSnmAFUQG1IznO3pW1TOEjr0uQFlt+5e9NlUL8OlKMHoHnkNM5AoM 352539HLEPMRmFqJQdZIXxr/FRUIToDfNw4OLf6G1KhahSCq3QJMCjld6YcCINZR92YKDLZFx8EY6p 3525403dzlIRgiJ1uDYTkKB6PTkXR+MuzIwtKzn4NHJZoV8xUv58HOSOFCp6zs2uthLD2gO4gZ15Hg 352541KL3sbAxMuR7YJ/MyqRbk0JMnO69UHpOOsmgpVrL+bMy5hOAhK+UXBiqTJBQoZ5n6Iiz2HS7N 352542JUKxzURcyVVVLDRVFSDz032s6sGC8bAjiOUXoEo5xj112d6T9fA048IxOAxvMwsgUIqL3+LO 3525439f7xUyR+zUVO2nPsH2sDps0UIqA1qygw1/diqikIiMJp9yeFcCcuw+uDu3E5Jh2Zac+w298K 352544LId5qhcxURcdXhwNM25fbIjiIf7UJNgRBej8qFKVSwi/HB9J+rIPNsZXar7EveWgcV2Gu594 352545eLzJgyh7VcOE0UAonwfeFzJPXt3DscV9YeuxlYA6sUo4tSLlWKRiIV4udYZRnw0qB5ikQYj0 352546Z+HYMtsbThb28Ji8HpdSpG3ryLpLXPMZN7bMwBBC/tkPmor1px7jU4lIJdRPTZkAgrJaFYvx 352547t38HYWNCIWJWuGPMhWyUpxzC8N6zcfXOVowKUJBER3xkYekISadL/qhDh60Ucz9xoxtY3IHY 3525488SYLmfEnMN6WMNT+4fK7EDLO+MNU1wD9Qm4iOSMDKVHncexuhnxc6efZfbDhxRekvw7HigEm 3525490OP2J8SA9Ptb8je+zKJjuwqKFHH86DwCgI59bR3DnX/aF6Y6XPRZeQPJmRmIPeQDY47C3Z1+ 3525501mCI1HWNzJvMs8NhxHLDv0kK8pQuY6R6YZwy0cmRgS/V8sNw6kshAdtuBGh2xeJIRegFOp/V 352551HYsvPEN0dDRex3+mL82if7eYgHtF1UjcQA74oIvILqaUkkw4LIqmY1jLn7eYiHvFjUTgmQhL 352552CqirtTn7wlgi/Bpj8KaHSP3yDtdW9ocRtydWRhXLx1/ajl5Y/SgN2bkC+X7RknKvjoeVeh0s 352553R8y5nS8Hl9JvlQqejVkUkGPB7d8kuSI87tB2nHz8Hvzsr4g+NAbWRNE8/4liHdYmb0EftsL6 352554pSWVPpoGG11DDFh3HS/uH8SkLiyY+Z+WX9ZF7Tn8k0NhRAkqumyirFUlqSV1HxHqzqGtvSwC 352555riC3qYIcyHZ0LGFm9zWIbQnhRPbU0hdr0cfACAM3v0Jy+BiYU3eHPFdVMksqXmFBF0W8VgVg 352556FuLt1kEwInO7798P8LlAGue3uEJ57UmtcgyVSCTF80W4M2mQiscItS8nrO0BA5lFQXtKVfpO 352557guH9MEPJGrW9FOZN9jOnGQi7ex27xtlB33S0nKDhH/eBIVE4jzkRD97THfAx46DXuji6Xyni 352558SY/TB2sfkDPpy3u8y1BYUlFWV3rmo3AsnoenO4fCjNQxQSmEwauFRKlvMQLbb71C9IsHuHry 352559LJ5mSb3equNC0I3VGbNlxCBtjWcyDIdieXgeOpzMYQuMvyOgy9LtkxGqorQDGGxgKg/3ROcp 352560ASBlL8GvYd4qedJ6fLD98By4cKwRdParvO+keQoLMsU7RSiOJGuNAobva6VCD9NWbpXbXtuo 352561vmOYDMfh2DS8PhxAk3Hz7guk7SZzuK0+l/arH47GpODJNm+yf5pj3O3WfaGikHnyEG95fHyO 352562PoIAa6bM1VeCyuiF6MKwxPgrPAiU5iZdD7sftsbn4f3RUbDQk46dVNFiCq6lOQwd5yCy5f4c 352563YRSmWOmBZeKMGTcTcH60NQzIWeS4MEoe8k+UcwPzuprAwdMDtgaE0H2hWEsvFzqAY2IDY4uh 352564OJpeL1dyfTw5CV0oL5hdL8EvoGTAZhWCvzCZsspiwnHJa9VY9BrIEMr680awDYz6rsHdlFyU 352565t7j+ixvlcYjpeL7lJSp73v+SDOlo3Wq/Ulz787Q/T/P6oy3sTFStnIsjg2Gla4K+40ZjXOgj 352566xCUXyNdVXRkPF8aag+myFA/51L0ApfJ409T5GzndFrqMLph2IRVl5XlIvH8XyTKsVJqXja+v 352567d5H9nIluyyJpC9S8MoXnQ8btQzj5MBk5xcX4ShRKbmw92M16oFDSiivw/sQs9DHRQyeGPWZc 352568V1yqnRWXAH5ZFQqiqfuNFPefVb3bjmFuA9HPyRQshi7Y9oMwwH0ObsguI60vlREIFO7LF8rl 352569YHHtV1xbPAxTzrzFg39HYfTuFI13aVBGXp/I2bfshjQEryYMSbVheK9esLYZhZO3NqG/kSFs 352570eyra8M17X3MdhPR9asp/re94VA8FJSTlhPViFUO590cDYatPzoApx/EmTXq5eGZBtVJIs2q8 352571XekCBsENG+7H4u46dxjo2SA4IkveRw2ZZzBpxiW8PBKMRY/L2oxNTl2Ym3IymJxJ5vAh8i8v 352572Jx+CyoZ2Y5nLiR2qL3NL5EZFFa/Xwm/CdtyM3IFxo0Nw5WOFQpG8kMgGOsYYuDIcL5PT8P7q 352573FHTWNcKQ/W/wmSZDslGkRNDEhXSDvqEXDqWUIe/ZRrgbdIKhF8FppIyksRz8hATkKq2Zljsv 3525741T2vablthg0YnSfjfHwyXt24ipf5Mkt66i6CDvDeH1emPo0O0dtumdqP2DPYGJZjjiOekEwZ 3525758WEYRnnb+p7Gh3zpvCxVinNPY1YdNrrODMOjmDd4fD4U2y5/aYVZ28SkvyNPDYf+zG/514gu 352576SccaEyNSwU+6ix1jOoNl7Ikd7xT6kF+FNf+0Mrl3l6GP0xgciI7B8Yku6D77ijyUNYUZ0g95 352577wqATC92X38Gnr7I6DNyw+nmpvI6OMOrvzm8Pl8rHTkYOsMk5wjBzx9KIDDWsMxxHX6fia9oT 352578rOvDgdnYqzQZ0h5O/JPyjvuQPMdpOHo7AqFBJI+csRMP3Sd6led4cO0crsULaP1Ye/i1PXxK 35257951kH4mRCFnL5H/Dq3n18kBl6d/hcG3nqWFUTdv3W32JXdoW+0RDsfc3Dq31+sCRz9J+YCsV7 352580ZH1Vl7IT/TkE28mMgNvDpP/rPJW57GSn4vlEpTfLnckZaYIhW+7hwT6iQ2I7KvBzG/hV/Jvy 352581qKs8NGFYFZ1UG3i+vWdbkSFVMX/BhS21wmw/PixRQu4egVFhPPAvBcFbyQqVSq//8UJnQ8ot 352582mgiSlr0xaU+0PEwDtdFlXpwOr3k3kNsgc20NdIShYReM3PQMAlm52s9XsHyIPQwYDBjY9MXo 352583CV6w1jfEoO0JKlaLckGICith6oq/1RTlpVFL0NXaDye+ir5dgGzrsjlCBEQtcIKZ5y4k17Qt 352584lNEDohSS6M0ab4w7q9m7pCH/Af4ZRr6TaYDOHrNwOKZExaOBEpyTt/UFW4mg0KVC9ghVL37e 352585S1m4KJXhqF3ERMVI2zvKEcZMPbI5m8HFex4ORwtU48o2VyGbl4IPHz4g7vJsODLN4Xf0NfhC 352586JevohlzcWu4FB2PC0pJ6uo38C+HJFa1CwoipOI9z+xPllT4MOntg9tFYFcuepvwbmNqZDadF 352587j1Hc3JYHRwPy7q+Dr7Mx9PVYMHX2xsLj8ShTDt9BGPvUA75kceuBQebQ4Jn78aJQdax5ez1g 352588YB6AiPwm2buvY3LvsQhLrWlTuG6q5CP68iEceyHto47YU7EwDicPhOP5Z6HmcF8V0VjiyIbz 352589stdypTqVvoQFYcqlDGTfmokuhPm27O5GFNYs2HqH4FaGIkyXgz4lXDxCSno60tPf49osB+hb 352590BuO+jBykrI9axl6Pa43eQf/irtLzElEuHm4dBzdLNvT0jdDZLQDb3iiUZPLnKZd5Ezv09l+C 352591sOhCOXBUrp/6U76giMrTc1qK15WawgLl4MHW8ehtxYEeNYYO/THmr3B8qla0W89xCf2sRBYf 352592UE/NgoAqo3yhumI9UvddWJE81XcrlxdXJSLUi8wf6yCc/VKv8Vta1gr1u/q6EaUdgidR1A8/ 352593mykfV+Vy1KXCY80oi2LVNktEeXiyYwJ6k/7WZ5uj69D5OPSyQIVwoL/dfj5tea5x/jcU4umO 352594cehhJrO4sByKdXcVF33Kv9V5OR3KjtoHdlOX4CsBrwdrfNHDxhD6uvowcvDCvLA4+TqkPSDa 3525958LoRV/MQPn8gbDhkXXFt0G/SDjzJE6l5CBIFLyGpda0nIkKNwKXCXxyhwl/o2mJ6JHWQVdOC 352596A4O6PDNUoSQQZVzEZLIP2Iw7iy+E+BOXPcViJyYhUC4hR4nwpe8+UYrXKv+dtrjv1OpST2Uv 352597NMp9/zgBcxrvsyDtigsZjIm3BIq10piD877GMBlNBNPm9skQeq8QpiLuc8U3XY72dutQIkyw 352598Ye0xEZN6clW8fJ4S5TvLbgSm+rrAkCim3eedxUeZdWk9/zpWDXWAkT4DHOshhKRUeP9UJh1A 352599oJMB2OZu8PN1ApvjjtCPitjadfwI/OXdBYb6emCbOWPwrDB8kp1f2eEjYaxEZFZ/PIZJXY3A 352600sXJHwGgXUtdA7EmtV7SPtrKQeWRxFJ6YdF63EMSpe+1IhIiaaauSJy9bUYZXa9zANRmC3bLQ 352601Zur1KN5Zi/ebexN5YhIii0XIoO46USJB22ubKOsWQoY5kO8n+4/LCKwIT0aFbFyfz7Ujfe6L 352602maO7EcCm2ufSfjUEx8YD4wK6gqMUs1zxPtXvvTirD6y4DOgyTeA8fBUi+NI9WJR5EdNcuIQM 352603ZMutg+j+fr8bI6zZpL/7YIRPF7BkY0fNy9hVRNDWMYP/ab4iJj19XxcD+q4heFNehHvjzNCJ 352604CI7bZUYkTSXPsc7dFJ3HnUKa8DPChpnA2OcI0mSkev61sTAlILPn2hi5txxFsMywVbo8VscG 35260509QUVZRHyhjT1p4tmsiQhqwLGGtuBJ9jX7/Livl/SYZ0tG61Xymu/Xnan6d5/VW8JOc+yxkr 352606YqpU5P0zc91hxdKBLtsWfgdS5We81ChC6Xw2H6cSEkuUfQt/DTQnsgG197DR2W8PUpSMFiqj 352607F8OBoSDllVPC1uGw4+pJ6yUKuB4TQvFCoNiLxLWFyCysRi3/NEaaqN4Zdm4CAcZU+FBdLhz9 352608/sWTljjoBKMWPN+NKf2swWGZwGUkUaDzqr7pfJc0VqKwlJA14loUC6q/6R4xzdjnx9ugEgmA 3526098iQ0UZePDOFznP9de7PUy0O9HgacVyguam/xlGAYd4aFoQXcg2fDx9YQrsteolx21pS/WI6g 352610Hc9xe/FEHE4TtbNnkzPJRvlCcxP4XWzb27+9VFsivey1oYIQPGqERHPFB1xaE4T+9sa0l0Ir 352611T0Elw0epHHYF892MaKMeHZYdfKZPgYcFdT+YIQzYBnAIDJOftQpPEz25UYSK5XjUOtI/HDDY 352612FnAdvRVvZWGtix7M7RDv/YllunRQJut8ICy5btgQL53Htcnb0FclRLIJRl1WjLEyZmUwjdHF 352613PRh74stbY9Y2MOnvyFPHoT/zWyxFrMkwN8fMAf2DViP8XZnKHP9VWPNPK5N0egtOJ0rHkjo7 352614LmwNQ0xZs2yNXcSyaX9h41J/uJqx5HUcVqujI4z6u/Pbw6UtY6drMwmXPmQhJ78E1Y2q8qcU 352615QyzEkVUeMCHYxKLvbJxKka6N9nDiH5W3bQQ6c9kw6z4WG64+xjmiG7QzYJD+soTrsGW4zBd1 352616iF/bw6et8461kxf2TXkaMaYadv3W3xryH2GjvzOMmIQoc/XHmutf5PoZqjy7x1oak5Y+CIYl 352617py+2JneMSf/XeQp9muY7Q84sGAv/QY5k7MizXUdi5cWPch18W/j1d+XRDgkaMGyLzPpinj3Y 352618beD59p5tRYb8yiQRPkPI4psoaP69t+crlP3UHQdW8DmhEHbF5W+xwd1RY4z5H0mN2Rcw3n0m 352619rmaJoP3pv5soz53SctF3A4vfkRrzb2G+ZxBCo75CUFIKYf473DhzD19qxNo/UO2NYUM5sqP3 352620wc+CBRe1C/X/ryXKq6j4VSgmDpuEPW/Kfhhga2uSXoauCx0GBw4zH7UiRFSE289hGGFFheVg 352621wW1jkgrJrw0p+2UU4r/kIOP9dYT0M4KJzyEVcP9d/U7dy5R+A/Oc2LCVXWb6p6UDg7gwVYp9 352622r3n9VdPhMZjW0/Co7L+9L7/b7QUz+xm4XdD0fedU7hVMsNalQ2WNPp8tJ4bVyRDeAcqDRg9G 352623/VcjSvB97/hdZMiPJO1Ximt/nvbnfd/6k4hL8Wjlco13Onb8bCOqS6g7/L5fLqfOmepyIarq 352624W4cGrnm/GX05umAwGDByW4TrOarYTdwkgqhR+2XtXyJnVbzEfHsWfQdetUaPmAZkXw3BlqgE 352625hIfsQGzlf1O2ouZbRXERhDKlkbihCiVURA0lrwbtT7+or5trIMiKx/H5G/CmUvv7VivGvKkO 352626NSLt35P/b+kwGlFVwMeL0AU4mFKn/R3yH0rFSp64/9/1fo3CNjEs5cRAXe3QFp5v71kq/TYy 352627RFybiw+8Mo1W8tqftD9pf2o5JMSo+XINyz0soK+nB4aRKybufoHCBu1fN+2loruTYGtoB49Z 352628RxBb1qz9HaL9qR3husWrSzXEhsZzSyREfrbM66u6Uev6KnJBL5gw9aBvaI8BU3bice6PE/9i 352629wU0EWTBh6b4Al778mQLwFGvpPSDtXUoracrFJX8TGAw+KI9X/F9NLJshWPOg4IfksubaUuTn 352630qMV1VyNDqFAlOfmlqP0BI5j4tb1gwGwJQcmE8cBQeYiN9hJlpDLaUjl8pWrc9h9J7bVF+/O0 352631P0/b8v7L8nVjdTEKBEJ5CCrtT78nidIpL2rjH/bg0P6k/amVDCl8irld2LDyPYBPtdo/p7Q/ 352632aX/6b2LwXFwNsgbXcQouZmq/Mbn2px9LK1yYbWJYcenDdvF8e89SqZP2d6/2J+1Pf8BhIRah 352633skigEqdX+9P/8QRo/3+0P2l/0v6k/YkkkTBfHvOd+sspKFe596ytJGkkZGeOavjKgvKGn7Jm 352634aq8t2p+n/Xnalqf9SfuT9iftT9qftD9pf9L+pP1J+9P/tfT/ALA9ggQWqM0TAAAAAElFTkSu 352635QmCC' 352636 ) base64Decoded asByteArray readStream! ! 352637 352638!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:19'! 352639dejaVuSansBoldOblique9Data 352640 "Created using: 352641 Clipboard default clipboardText: 352642 ((FileStream oldFileNamed: 'AAFonts/DejaVu Sans Bold Oblique 9.txt') contentsOfEntireFile substrings 352643 collect: [ :each | each asNumber]) asString 352644 " 352645 ^#(9 11 3 0 4 10 17 28 37 50 61 65 72 79 86 95 100 106 110 117 128 139 150 161 172 183 194 205 216 227 232 238 247 256 265 272 285 295 305 315 326 335 344 355 366 372 380 391 399 412 423 434 444 455 465 474 483 494 504 517 529 539 550 558 563 571 578 588 593 602 612 620 629 638 644 653 662 667 673 683 688 701 710 719 728 738 745 753 760 770 778 789 799 807 816 824 828 837 846 854 863 872 879 889 897 905 913 921 929 937 945 953 961 969 977 985 993 1001 1009 1017 1025 1033 1041 1049 1057 1065 1073 1081 1089 1097 1105 1113 1117 1123 1132 1142 1153 1163 1172 1180 1188 1199 1207 1215 1225 1231 1242 1248 1254 1263 1270 1277 1288 1298 1307 1311 1320 1326 1334 1342 1357 1372 1383 1390 1401 1412 1423 1434 1445 1456 1471 1481 1490 1499 1508 1517 1523 1529 1536 1543 1554 1565 1576 1587 1598 1609 1620 1629 1642 1653 1664 1675 1686 1697 1707 1717 1726 1735 1744 1753 1762 1771 1785 1793 1802 1811 1820 1829 1834 1841 1847 1853 1863 1872 1881 1890 1899 1908 1917 1926 1937 1947 1957 1967 1977 1987 1998 2008)! ! 352646 352647!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:19'! 352648dejaVuSansBoldOblique9Form 352649 "Created using: 352650 Clipboard default clipboardText: 352651 ((ByteArray streamContents:[:s| 352652 PNGReadWriter 352653 putForm: (Form fromFileNamed: 'AAFonts/DejaVu Sans Bold Oblique 9.bmp') 352654 onStream: s]) asString base64Encoded) 352655 " 352656 ^Form fromBinaryStream: ( 352657'iVBORw0KGgoAAAANSUhEUgAAB9gAAAAOCAYAAABkfMdcAABe10lEQVR4XuVdB0xVSRcmIRBC 352658IBAgECCUUEKLoBFQA6JgFFAUCwG7gooVewN7WTv2il2xrIpdrFixYsOGDUEpggLS+3vfPzP3 3526599QKP/d1d3TcJCbl33ty5M3NnzvnOd87RANS/qH9R/6L+Rf2L+hf1L+pf1L+of1H/ov5F/Yv6 352660F/Uv6l/Uv6h/kS58fi0+7uoH3+h9uHokDr26x+FyQb36D8xvOZc8lN6fh85+03Hs+hHMDgnE 352661zAu5qOPz1X9w/tZxb0DOkT6wdBqHK88PItTSGTG3fvxf81jxagfCvSKw/1Nts/Xrc09hjGcH 352662TD2vfK75/HrkX4xFUPdpSLxxFguDfRGTXIBGBfVp3S+HhmHwjhTsG2QHLS0HjLiguC4t5fdn 352663wt0iGDufpmCyqwVC9n1S2o+aN+vR1dEXQ0aFwtU1CsnfeP/q3pd1bBS8g9biRRVf6VyUp2/H 352664wA6hWHotF7Uy78VvLMH91X3QZeRWXLm6Ef3b9cf+zFqZNqrxem1nWLRbjNR7K+Br4YNl6VXi 352665+7wKvNoRAe8Biciq40vNQ+6ZsfDymY4LuXXctfqvuBQbhOCpB3H93GJ0952A5IIGQf1y3Jvh 352666DovgBDy5PgVuFiHY96nu/xqj2g8JGDRiP1K2k/WtpQO3STdQwlO+n/B5VXi3bwi8QnfgXS2/ 3526672e+m4OJkeHuNQ1K28nXObyjE9QUhCIzZg5TkFejVYRRO5io+o/i1b7FtyCRcLcxH8pQOaDs8 352668EZ9q+UrnP/v8Bqzc8xC5H85g3cp9SCtu/MfXYWNxKpZ2a48Jycq/MVGfq99iZ7gHAv9IRVGj 3526698ro1mUcxNqAvFibdxJHJfvBfcB+lSuaNV5aOxJVrcDwjD08PrER80kdU85V/DyV3F6Fz68HY 352670k1EJnvqfLU3uL+939ICZpgY0tF0w/vK3Zuf3v1Z4tSXI+ZSFvNI6ldcKn9+Iiq9ZyPxciGqe 352671+q+vf2Xt1pchL+sTcoprVZ+3hgp8zcrE54Iqhb+he0f1t8/IzPqKiobfb141/nUh8+hAdF/6 352672DJW/wCZChZaXW3rB0tALcTeLpDa2+mwiBJtpwWHkBRQ0qv8HrP5F/Yv6F/Uv6l/Uv/ydpfb9 352673dgQaE2VDg/4ZolP8K6WKnFAg+35xOGw0BL8hSsqkO6U/rT91OWcxsbUl/JY/RnkLBXl+WSoB 352674k7ShYdgZ617X/EQ5qhqv4jvBUEMbrabfa9n45lzCH/29YWOgRcbL4i+8SyfEv6pWXKfkBsY7 352675kXaNu2LL29omr4vaM/LH+jc1zT/XKAAb3tSo/wei/kX03Vdk/ImZIe4w19OEtstE3Cnl4/32 352676QFj7rkB6FV9G7+gLcw1N6Jq2Qp8/rqOgQf1levUv6l/Uv6h/UaXwStNxaM1SLFm+FZeyqlu8 352677V5elH8Zuanyq/IgLm9YhKaPiPw2880uuYaSdpkCO1YDlwHMo/EWAYH59AW7vXIklS5Zj68Ws 352678fxygpkaFnKt7cCC1APXE2JZ5aRd2Xc5GzX95PRCDQOn7e7hxPxMlxe9w98ZDfKrg/cbvQ+Yw 3526795TAuEaNnbd5NHDh4E7m1P2f+ql+sQkjYbmTk3sCswBE4V8BT/w34V9bZsy/j6HWyt9d8xtV9 352680h3FP/clXf+2MrSpATkmd+g+EjOxQ8+Uq1o4OhLulAXR0jWHvOxSrU77KEXQaCq5idjsLeMXd 352681aZLgwca6OhN/jvWEa69luJYrS3ZpwPdbS9DV1hSGDkNwPEd+PfMbvuLiDF/YeY7EntRkxIZO 352682wc0fMsSa8nuY3soCwTuf4vpUN1j23C9FjmF1eAU4Pbw75t/JR+bxUei5IA0V/9A5yK/LwZkY 352683D1j4rcCT8qb3WEqK+XBsIvz9IrH1/jfUy/SxLv8SYn0tYWLkhrEKSCB8XjGujLCDZb8/kZ48 352684EvZW/XHqK0dU4ddm4tBQJ9iE7sIHmTOEyiopCwLg7DcVx99yMiM9S0vuLkeggw0sLTpg4aNy 3526857npNBjZ1MUebuNtI29QFll4L8LhCAgfgleLBwvbQ1zBB53mH8OfWuYjqPxNXCnky81+DD/uH 352686wt0hALGn7uHQyHCsk8G8GkseYGU3a7iNvYCvzWAJ/Lo8XIz1g0vXOJzNlDYsM8Ljk03o62gK 352687A8sQJLyrVSCv5eHKmlhM7t8NPSMjEegzGhe/y/S5Kh0rfS3QYdk93F/hC0u/NXhZ/feuI35D 352688AS5NbwvLjsvxRAVZhpKgUuZ1hrN/LM5l18jJ/xxpMAERLtawMW+FcRcLFZP7Gr/iZH8r2EZe 352689wIsTEbCyH4VrJbwmnpuPc+PcYOo1Axe/KviWW4DTNuQcRV9LB4y+nI7DfSzhPOEWfkj0UUPx 352690JlaBtHme0NXQR7vFT5nxm07YCjJhPsvT8TV1ElwsQrA3U37zr8vcixCbDvjjeSXKH8Sijf0A 352691JOUrZnjx6otwd143hO15i4oGnpTwWfJ0DyZ0cYSxnik8+scj9buAcUeM4Ombe8HRezouC1h4 3526920oNXhLQ9UxFCQHB9bV2Y2HkibDUBwyUXscS7VAmuM9bhk5XwN9aD++Sr+CZjROfXvMa6zobQ 352693tB2OC4U8qUXw7cIQdBh9Q2pg/9lDpw7ZhyLg0HoabhRLj2PZ6xNYNMQPTmb60CeLtPvUg0gv 352694lV98/OoPOBw7CIGeNjDQIkqgTmvEPqxQLEB9SUZ8TDj8PWxgrKsDfUsPhEw7gPQf8vPMK76H 352695NcO7wtPBFHra2tAzd4F/ZDxS8pULDvzGItxZ4g9TyuLSsMGw5G/yHx8B6cdRkF5oSGF/WmSB 35269635SbB15lFlK2TkOYjxPMDXSgZ+qEzjF/IqtWemMrODsIVlLtCf70vLHoSaWCtVaMJ4lxGOjn 352697AgvSro6hNdr0nI4Dz39IbQT8xh9IPzoPA3wdYKKnBxPHToiKT0Fe7e+hQFa82oMpfTqSb14f 352698OvqWaBu2FJdz5eePV5GJlO3T0dfHmYyzAUwdfdBv2nbc+FKtFDyp/bgHvS044MGw81q8ljkE 352699at9tRTdjibnQ0oOZky8GLDqLzGrpdcyryUPqvnkY3q01bMh3rGtki7bBI7DsbLaIRSzVnqYW 352700dA0t4OTdA9HLT+J1aWPTzxb8abeahrtlfJXrsL7V5uNB4iKM7OEFB3MqGBrBqpUf+k2Ix6Wc 352701WvlnmnTHbsH+yvbjuW3JfqwBq0FnUcCTebZJMBI+yh/EIuOkSRASPih6RjB2kt8x5fjSPASY 352702k+9J1wERm9NQ0shXWFfuGRLvb+C7UmTIYPt0fBeYsPHQgfvM+6I9WPwbLTiNS0Exj8/2sE/7 352703QmAq847sECt5gZMrxyG0vRMsDHWhb+YEv0HzcTRd+juTnwttGNp4I3z+SXyolF4rDSUvcWr1 352704ePRuaZvahrD17oc5J96hgicprJUj48wKjOzmAStDHWjrGcOmVUf0mXYYH2v4qCIgQUcDBXuL 3527054E+//VLueW/F879LwGqn59VyHwNSzxz9/sxBA+kfr/gqB9gZd8NWCSGMz69E+mpqbNWAafBW 352706nB9oyX4XdiKPvRcTOrsak2t68F74hDvb67/gSIQVNJkB+6WgnSq8WMO1Y9YjgQm6TOB5uR19 352707rYnwoe+BiWc574eGr2cQaU/Wjp4X5j0UCLdEKSm8Ngue9J0NPDH9UoFoLT+Ka8PWsqJxMOmx 352708B5kSSkdJSjQcyDlg2GYoZi9YiUMvufbrsw+gl007LH5aKacMfbu7C8viouFnQfpkKs3I5/Mq 352709kXF4KvpGzMHZ7Nq/pOBVvNiKvh49sOl1VcuAh48JCDbRIDJEFC4X/TyQiM8rwqVIWzJ/ZghN 352710/NwCgTgPJ4faQousBadeMZizeGOL30XDZhiSvyt+l4bCu9i1bAEWxifhg8S+rui6aGzso4lw 352711zG9+DB1GI6VE/Y2iormsTMeqrrYwswnAsmeV6vf+NW+wge5rmsZoEzYJCxPuoKBemYG9Dnkp 352712WxAX6QdLbbKGLQfgbAtB25w/I+Bs5wo3Nzfxn7M92s0Sn3N0LypKXYlgSy1omvph7pX8v+QZ 352713+P/uWc31Vf3vq/999b//991XLEeU4e4Md+gIZC5FpMHGbzewfE4ikx8VnoU517A2uhtaUb2M 352714AM227YZj97saBYBcMdKTlmME0YtsjfVhbN8efaftRlqJANBsLERytCO0NYzQZVMGM2zyaz/h 352715aKQT6Z8B2k5LRn69YE+rzcOtbZMR6mVLdH9tomMRULFjX8w8mikyiDIQPPsiVgzxhb2RLvTM 352716XNBl4lFkSui7jQXnMS4gFEOCPRGy4i6KG/kyuMVJ/DHcHy5EVzIgmEFA5B84+bpUHqiluMWM 352717UHhaG5C+OMB/YiLeVvL+UUOpKn1tLE7DvuULsGAB/VuM9eeymE7KANWnWzHYwxxWHafh1Ofa 352718FsmiP9I2I9LXDob6FvAetQ9vhfoXOeM+J01CJzsjorNbof3og3hXLTnG1XizbRB8vbzgpeCv 35271986jDSr04lRuEMnH+j0HoQJ6pLZTpjaTJlUoxhmfL0dkjHIsXDYRn5zlIKRR62NYj99x0dHM1 352720h66+tLzPb/iO+9vHIsDJBPrGjgicmSSHCagyhlVf7uJo/GxER/RAF78OaOftrXBMfCLW40Xl 352721/ydzNhamYPGQ3giNmIajEl7L1R+OYsYAcr1vFFZeL2A6nuQay0vqD0synhbhx5GrAMBvDkf5 352722reu+244gE249Gfqvw5uaJgjWtR+wu7cl0YWU69pmoYn4XM//67jR/4EF/fQ6MthPS683d48a 352723G6a4aQv6oAltfROCa3RC+LQtSMmWNg79XbjO71hX1SKLQ+mZOMAnPBa7zh/Hol7tMCDhrUg2 352724UBUb+hXqqooJNfBVwxlF32p5Gpb6Ggr0vBhMJ/KPjY4GdNvE4WGFvIGu+v0BDG1NdOK0cqUY 352725NK/qPQ6P9Uev+ReQXc2TO99L7q9GH//R2J+ejVvEuNt53j05z/7azD2ImnAYl9cGw4zgyvZR 3527265+QcMXk/nuHAyniceJvPef2fzJQjkfH5P3B7Vn8spgb2E+MxdPtbuQgYfyupoyIdW/oQe87m 352727N8ojEhBs982+UQjoR+wAX+QNow2F17EopBumHM9AZvI0+HZbheeyc0PP7t0rsTE5EzmpO7Fy 3527288yXkSMgbDd+uI863LUaf+ypaI9S4fm0BOaPHH8ALCay+8s0uDOk4AJvS8pGxpz/aDTmGnHqK 352729dWbi9NqV2JeWh3cn47HywDP84Anx6VoUvb2FQwtDYadD7QoWCFxwDA8+lUmdvaxuRRo5s+fj 3527303CmydvU1oOc1H4/K5cemLucMYrw7YPbNYqVrjV+bgwuzAxE49RjeVvDkscWXCRjSaSA23s/G 3527314/W94Dvhotw6qn27HSPi7uB7zmmM93RBz/jHKJNZj/yqdzi+ZiUS078i49garDr0Sgqv/tvW 352732T/lzrA/xQL89mU2uWxbFZVUoOkYm4NmPRiV2xpOI6dwDC6/l4PP5CegQshkZCs5+fl0+rm9f 352733iW0pWchK2YaVO27ia73yqDx5Z8bA3ak/dimJplH7cafKOG1tzhVsWbkDNz9/wpUtK7GTkkSb 352734NbATwP1QbzOyYVpj6IVCbnNUwcBON9DcExGwaz0b98sJ0L/cB3a95Fk6vPLXODIjGE4GYkav 352735pr4LhiZ+YpPCK0rBlFb6MPHqj/Gj6AZqgu676IQ1oODqTLRzDMHG9AoFjId6fDk2GLbEQKzn 3527362ANjZ07H6FAfBP7xVMpDXqGBveYttnU3g5Z5KHkvBawR3ndcHGpNDFBtMSeNMzw/XRuJ0Wsv 35273749ExolSMPItH54mBZVSC1CLg80twZZg1LCJO4uvf5PnOK3uAed626JHwXrSouTBFG9GTgnuG 352738bggdNxEDvUyI4KkHzznyB0Tdp0QM69QFfcP8YUs3HIswnMhrVGjMz9wTAmubDug3ZjpmjusF 352739VzaP+mivIBJBxbM1GNRnGGJmxiGWGOW9TKlRXBdt4h4pZGbRzfvF9n6kD1qckKxEQavJ2IAA 352740Iy1YdBqNuAVCxXUZdt//JrVB8kqfYGNvG2hr6sOhyzBMiYvD9NF90WP8BSlhj75X/vXtWCpq 352741Kw6j/MyJ8YEI9QoYObR+VmIErMla0zLxRHjMVER2smSKpVHARtEaoIpsxvbesCL1dG27IGoK 352742EaZciTCiaYHeuz/+9MOTV5WD9LRMlKm41rLTniK7oukQRy/ju8GdbPoxMycjorURmRcdtI59 352743KJo/aqD9mroFUV7WcOrYB5ExMxA3Jw7TovuivZUudOwikPBawffaWICL410JiCNQImwjcem7 352744NHml6MoI2BEDm7ZVF4yNm4/Y0ZxApaFpj1FXxQdZQ1EqVvWwYuOvZ9sJgyfOxuwpwxHoYg1/ 352745gderVHvWXUl7czAtKgjObP1qwSZ8Dz7U8OWerWMTiPFzhOtiAZbv4wzQqtTh+nYXa3pas77p 352746WHijL/lu4mZPwvDuHjA17YKNGTVyz5QUGPn1Wdjf05R58PqteSn/Lq2m456CA7/k+hhmnNR2 352747nYzUMgXv5T4D93+U4cXeKLQigoOmcTtMScpEFU9BXQXPkLzP5s+0J/ZncYywqlebEGwm3N/F 352748grfsb7RdYnC9hEeul+J2jDP53sTvyA6wrCTEtDVgxnKL9v0xcdY0RHaxZQZaLcue2CIwckrP 352749LbdW4sb1hLM+fY4pukvsjbXZSZjoadiyNtn6i8PEvu4wpH03740DWXWi9Z+VOAh22vQb98ew 352750KXGImzkOAwJc4BDKnX8Vb45g1UJuXxndyYLtK/rugzCTrZeFWHX4Ffe8y1HceHvMwgPBeDfm 352751JSHcgjxTvz2WCoxn1FC+McCICIZOGC8RWrD+y1EMsqGKjSfiUkuQMsKWvX/P/VnMuFP+cC68 3527529ASkhxkcACxSmiz6iN6JrdvcJAy1o6SLNph1pwS1+cmY1lafPNMafba+EAlsfF4ZHs73hh75 352753hhyizrJzrjYzEUMciGKuZYXQLZJ1S/Bk/wrRd0LHI7qzJRsPDR0nRB7OkjjDavBmvT8x8hvA 352754d4X4rOYIVimIdrDHiGslivfBgrMYZEXX+Ewii/BFhqq3iVFw0RUQQtpOwsm/YLD6q+XHzXFw 3527550qKA0jq8rvl5+z6/+jXWdjZk8xSnhBSncIyKr2GUvaZSgo4q72IgY7z8f8fGqOsWvG0C2BXW 352756Mw7cjve1/20DO90PGhtUA4wbc48jzJx+w+FIymtUOwO7kEym570AaRLKvCIDu3h/O4Z+5vQM 352757msS83VtktD4xFYvvlUvPQd4pzFjK7alUFym8sRhdLIzgGjYLcUPawsS0A2ZdyGmRzPcz9qzm 352758+qr+99X/vvrf//vuKya3fcO9XcuwYFE8kj4o9gCvSJuLwKGKcQNe+WMs8zNiREn7rlGYNmsy 352759hoZNxJm8BhnwKQdnJ3syoqSeXQAipxP9N6obHB0H4YyAVMQ8yu/PgaeeADws/YG01d0IUKwN 3527602/AEvBbovnzeD9xf6CNoqxMiRo7ByEHd4WVljV4HskTAEr/2HbZ3J/qKtjUCRs4kGEEYgkcc 352761lTJqUb34y51TOHHpBYobpInuJQ9WItBcF6ate2LkNCJLTxuJnq1NoWveFcvvl0jpkQ0FKVg+ 352762cSJmxs3F9MGeMNZxxeTUsn/sfG5JXxUDrpnY3dMObr3HYmxvD7hHnUZ+g2r4ESXBvt4WjSHj 352763ZmDKgDYwMpGICETG993hJYiNi8WEXs7QJ/rKoS/1Erp3PpIiLJQYIXXgMfMuylp0TpUgdY43 3527649AVt6NqHYPzEvnB1H4sbKhAhaRjrlFUxGDV+CU5n1kgbwAvz8OFcFOxth4qcW6jOlbk/jOAv 352765enAKGYPxfd1goGWDQUl5cgC58j6XIn3PSLQx0lRqjJUyzPY5gpz/M9INxTySRzsRLEAPbePu 352766MhyOhnte5GdMcBV9tJl8AXn1svNM9MvzG7B4wVJsT8mTI+k1h6P81nUbCnBhjLOIsKFpNxJX 352767i3lKwfMvx4bCXlsTxl4DMbQTp1caeAzBrAVicsuGC2LDuRRuZO+PIZM43CjIVTFu9P9gQX9H 352768HUnsp6XXm7vHGT63cdiAfisMmD4Xs2MGwMdKh82FnvskXBSFmv97cJ3frS6/vhBp157iu+Qe 352769ToxJr1Luy0V0kMShzEmbMbTNAFuB84EZum97hUpJLE5VbOhXqNsSTEhy7eg5IHBgJKJGjsfM 352770FQdwR8Y5qyx1KtwIzmbUhRjbKn4g4+widDPXJBjnFBHG+W+UmswLOHqnAHU12biyNxF38v86 352771rlT98TDGtrOBY/fFuF7YAPUvf4PsVvEU68ZNwJLd55G8fSA5M7ThGJWEXAWGWV7JExw7kY6y 352772hlK8SNqFpOcl/4mw/fy6XFzbuhSL15/FpxbgkSz6TuYLfKn8/SLJ1OeeRLSXPxbc+q50Dn/c 352773mgDnn4TTKjawl6Viqpu0i3xzBvaSGxzwqVA41XHHzPvlgskpx8N5XtDTtkGvuHno0yYYy4+f 352774xsG1S7A1rZRtpmW0fUNvLHxcgcZ8unmbIHjnR5S+34eBLh4Yk/RFoScIZf9cH2VHBFUDKUNU 352775fV2jDLtD2sDOFKUbU9CKGHUdR1/CN56itstwZyIVFKwx7HIxd0B+fYD9lChgqgttXVO49IzD 3527764affpfr2dxvYlXqv135AQogZ82rrkfCOMaVKro5kh5i+z3KloHj5g1nwIAZM/Q5/4HklX+Hz 352777ijIykF8tVHSKcXWELTOG241MQUlTrBVeEa6OdiBjKG8wESkSx8eglYkbhsRFM6abooOThQFO 352778pmGATZvM3UQP+UeL2sOACHcd5t9uMv+M/Id4CiOdqKemN+akliggc/zAzTEOTCkSEgtKUsbA 352779UQb855fdxfRWOkz4WMxYdHXI3MsxOmWZtEzQuMQJMKYhe0WenMqui9+zCrmPT2PT9DB4muvA 352780tMduVuf5QUlDlvTf8j0P2Xgc62cObdPW6D15LU48+IwKBWNUlveNhY0ThyImBvbZnIGdroec 352781pNHwbDcWB54XoaY0A5d2r8P6Q6l4eX0n4rcdwrrBzrDts0/Kg4GxtZ4sR0dDMsemLnAj/dYw 3527828MOal9VSAMKLVR3J/FHm9gnkkb7xiGFtjCMx+mk5Y/yNEoFQm4tTo6i3hRbMg1bhbpFYKOFV 352783FyD7e62C9pKQ38ixKgsuT4E7BbCZgapcvm4EV1f+W1ChDuubM+mbJsy6LMXNgjqpg6o8JxPf 352784hWtFoj2rAadFBBD+j5tcSGVKKrhWLGCDiusqUvypcTJjUxcYUU/mXgeRXS//DPOQddi/MAiW 352785ZM1q24YiPvWbDHNeom7fowqeIbyvDTMXJ5jo2CKSRpuofosdvSxgYO0BO8pW1RN7Hki2qaVN 3527863knbDZNvke+r9i22dDWSfsfaj9jTx5IROhyGJuK9YM/hEeFohS+n7LhOvs0iVki2aymYC35j 352787Hk6EmTPAiIbOLhe0uat3y9s0DzuOXNJmY57AkGXQEateVIv32mAT0nc7RF36Ltor6NqqKpNm 352788ePJ5hbgwxJoBo17zH0uRjOjzKCmNracwbr0zoPVhLFrraLDoKUJvYXqupIyyJ+/BnY3MG4aA 352789XHdi2zKlxn7YCcbiTJ3kQvZbY3Tb+g61vG+4OMYJ+pZt4W2jD4cxN1HKr8DTpTRMknz6E+qV 352790/2gBBc00YRk0E9OCLJmi3G72VbmQyrUfd6GnGSVZBGNb2l2s6WbG9sbWk87LAUaS67/ozhIE 352791mGoyo33oxqdSTExGahtuQ8aVrCuJcRWe4ct9bNFjT6bC/b/i8QJGJJD8NqrfbEQ3Oy/0H+RJ 352792wMgOiAzzgL3EvsTnVePrxzyRUtsSoLU0LR5D/VvDzlQP2tp6MHP2x8gNd1BYLyYhvd3SFcZk 352793LK17r8LaSV3haGwAS89BWCv73fEq8PbcKowK9ICVgTZ0DG3QLnI33gmEPeYptKQ/vKyNYOwY 352794iJk7t6G/DRlD8344lisAPBpL8SppKQEB3GBhoAtDm3bov/gcPgnWe+XzP9BBX1pOo3sYa7/y 352795A84sDIenlSFpvxtmJAjaN+2FA9n1Eu9CvrWw3Ti3Yxw625G+OIVgyY1CAZGGnHO7u8OEvK/9 352796yKvMm0FE0BNctxNcF7dH5K+xNwiIVIb0nUPhokeAsnaTcfxDpWDPE9dzjrkl+EaF7WnAuv9u 352797HF89CJ6WpkQ5nY/LOQVISxjDvLiMnXphqVzfyG/CdyBx2QBiJDCAkaO4/xy4RyPUzMGAjk4w 3527981deDiUNHDF1xEdk1PIl36cHexSpkPuYP7wAbQ/k5Fc8XGU/7LpiydRPCbThC0gEBIUlyXKx7 352799LsDi6C5wNrVG74PZXIi6BwmYFNIG1jQ6BvVW9PBH1OZ0tn/8uBXDFAIpmZtGFvjGY2f2yzV+ 352800bI92m5rKQHPe90uItCV1zPrgcE6DgLC4EQFGnHzxqY6TicsezIe3PiUYrgC//AFmeZAz2noY 352801rhSTfbDgHKLstURyYu3bLQyI0/OcIyJ9bOhiTPZ3Z4yhob3q83Fhcmvoa4r3j16m4qgnjBD6 352802aAG8yTer4zIeFwsF3pV1xADR3UTem8dtqhRprPDCMNhokj1sdIpUOMCmDOwVj+LQRldeDvsZ 352803Ruv8K3Ph79IJkw8+R0kDn4twkhSHQJcOmHJK9fC3P2PPUn8DqPrfV//7v5aBvSlZouJDMuLH 352804BMHDQheamnowbz0IOzKqpQ27KRzeot9hCdLKlRmcGpB3KhIOBJDWaz1FnJOXAmTZmSiWzN1L 352805I4BQwqa2PXpPGoRW5Ow16jAHKd8aJHChuxwupO+DZc/FnsQ0Z2ZhhUS90lsY56gJTfMQbH0u 3528067cnN3u/NUcT2bstkG219Mzh6h2N1WpkI+Fzm54yQ5WdxeeckdHM2gZ6BNTpNScTxZSFw7rQM 352807TysknAheH8KMEA9Y6Aui2WkrNrA3lObg848Gzrv+WxYKqng/BaRlfV2yG0u6mDAPT11zD4T9 352808kYQkmb4qbaOcjGmnQTj1lcdIoUP9Z8gYwJrHj+jZ8nxzTzh2lF4LdVn70dOU4m926LPugVSU 352809ALnx+X4Hy5l8rwvnoXvwqoIn1YeUaAema3COLnyBg4OGKBULr+gKR9YUeLraRV3G57SF6BKa 352810IBfmVRajeZ20FWvXrpX6W5eQjCwJJwWqh1kFbBB5L1OCMV2vem3jcLeUx+SPrkb6Uk4zdUWZ 352811yK/kcWsuL1t6vRNjbE7SKDhTsj7RW0PmHcHd9wWoqKtA+kpfIi8ROWzw6SYxO4a7PL2Mo7u3 352812Y2tCIpKf5KOGV4+Sd7eQtHc7tmzfjzMPvsidzZXPV7BoZlo2g3E88yOOjXBm2IV1n214oSC0 352813Kj3jCz68wouXb5Er4wyhCo7yO9ctT1sKH4oDmrci+6FOk2FbGwqSMcGVYm3tsODuB5ynDlFN 352814OfNI4EaWIWvxsEQ8tryaIuSU1P5cLOhvqCOp37b0evP3qEFV4PDROlbk8FHzYS/6WtFv3QRB 352815CR8EkTj+JlznN6v7IzUWbQ0sELTyHttv6f72fGs/2Oq7YNwlcYhjSqza01e6Tfqdf0oaD3c9 352816Lvqi66TbomisLcOG/v26LcGEJNeOrJ6n4zoOF742iDGUrd2I/q8D92nJuLTID8bGPog79xYl 352817tbwW4jG/Z53ypxswPIDUMdGDjp4pnALGYMu1O/hz0UD42BsTWckKnmELcTazWgZ3bBpTag4v 352818kq1jaagHIztfDFsjHYm3pe0oqqMIO1KGJymr39R14flf/PoKDm5YjsVzx6OrlTbD/2ffKZHA 352819b8W/twyOwwKKyZBxN7Trgllnc0S4Y3M40a9Yh9WrfIYl7fUZlnK3TBkRuARPD83l2tLThTFp 352820a2DMSHTzHYnEzBqRfKYKxvRv1aPpvVXBmoR7DMWMmsNpVW1ToYG9LnMPepiQg9I5Ri6PhDJF 3528217vv93VgWNxK+ZoZwjZiOudMi4GpoBt9RZGEu34e0YmF+BZoXgRy4Bu0xe/dK9O6xCi9kwC9m 352822YNcxQpv+EzAqyB56ZIPeeC8FSzo7IOCP+0rzadDwuM/+6MBYtDrOo5CUU6cik/U7LhMFQkvL 352823AdFXipQk2ydKxkhqvLdFlMBrrrbgIQ7M6E6AUM7A7torDkeIgb3+HzSwK/JeZ8Dcy9Xwo8Yt 352824ywicEIDuJVejYKvBsdQfVyg2nmfu6cGAZ5thyQqJBnLPL76FOE89YiCxw7CkXPnwGmTBfk7e 352825iMXzYhHTvwOsDK3hM3IrHhY3yq2hwpS5ZP3YIWzHc7w7Fg6LJgx7z5d1YEYhfTMT6OsYwNqz 352826H+YlvZdSZigIHMk8MO3QNSKEGAwMoGfmgT6LkvGlKaWvsRCXJ7WCLhHOPaZek0sXIOxvwdVZ 352827aG+kCT3Hnhg3fQxCnA1h1Gowtj4WhwziCCIaTOiff6cQ5Xm3sTrYghESjGW89dj6ZcYuXRkP 352828cfnrLPxN3mOc2TQD4V7mTEkwcQ/BhJWHcOvDDzYP1HiuoTQUM2eEL/+Uij/jJ6NPGzNok43K 352829tE0fTFmXhIdfKmSAkXoUpq5GT2ttKcYmr+QOZnq1xngiPNaXpmEVE6JoyBUTOLvawWfhE5TQ 352830/cRFbPzhgPNPONCPhqU2QucV54hB1oylAxgqkQ6Az/uK0wMsmcJuRjb0uPmxGBviDANNfbgM 3528313YsMAUhSlb4SvnStE+Vr7cuqJr5zYXv6aL9EHNWC/+MGxjpqMtZonyMCT2uJZ5t2GCGOkrB8 352832Lx4J9zIV6oj71gnxL6qa2YeE7RHgzLY9ugQGIpD8devkDlMaytY4ENvf18rUJYbaBY/lFEia 3528334+Yq269kog1IPENLV48xtw3bjMPhtwoiDEg8w3vRE7noFOL7ZugVvw79rMj3Musmnu7pByt9 352834d4zZuAABlP1sPQTnhZ4HEr8JmDwCnvpUWE5FyffLiGIhz8XvWPFkETuw5MOgl+LWeCfGTjcX 352835KIXidg3QcdULVPHqUPJiP4Y5EYVbyxZDT3KeDULDa1Ntmsm1yaVKqaj/gVcHh8FRh+6hc3Ff 352836kGqDKku7BEYgfYcuiIpbj0PXXqKwVgFYIhBqNDQsMeB0gbQQLPIq0Zcgf9Xhk4CQw1i7tWKD 352837bcZmSqCgyh0nXNS83YZgCqiZdMWG1xxgwYVjN4Df6pcoy05EP0sDtI/dj0WdDGE15BK+F9/E 352838VEoAouSSe6Vya6Au6wD6WmiKQu7bD9yLtwrASbpnXhzrzPYQYysTth9ZdF+PZ0rBX2LAe7oJ 352839oTTcvKYpOi+6JcX6FhrRV1IF1qgLNmXUyAh+OTjSx1aOpCDcm7kcy7rwnJcmsfarUJjzDZn0 352840nvVwXP1KQJSiWk7p51XiXeIIuNn2RML72haC4tSTaATChk1gnlSx4/vAnXrF6Hlh/uMKkRxw 352841Ldqe7Y2a+vboGjkRI7vZMi8OXQISPhR52Zfj2YaeLOKJlqkn+o2fhRljQtF58CFGkmF5jqa2 352842YaQHQ7eeGB0zBL6Wuqxd4blOPXPS1gTBQksH1p2GYsqsSQhvQz1kxJEcKjIOY164K/TomnUb 352843gBnzl2DTxS+s/eTJHuQ6ad+1J6JjBqODBdc+Y63T9kXvQs4+M0sYShh3xQbaH7jJvicBuUN0 352844lv3ArQmUqGiErpvfCsAZYXvGCNqcisvLgmGlrQP7sPW4L0GWEtczQY/dHLFC/BzSF1Nz6Iv6 352845ogd7H08uBLjQA0lANJL8jY6hIXQ0FfS/sRipSzqzNDX6Tt0xatJIdLWlnhvG6LJO6Nki9M6g 352846JCI7hXOqcL4sOA8QSS8AcZ8o0csSvoOnYPb0OOwh5yyvOAUxruTcNWmL8InC6BhtEbTmBdsj 352847itN2YVqwLSNxmbSLQiw5g5ZuI4ovfQ9eAc4NsmJRLEL2cmTE6pfx6EQATl3PuSJvb2HKHaE3 352848N78uG4nh5HzWcUXM5ULxt2gRgZNfa/Bpf2/yfQnfoQKPF7Uj72hM5jRDZMQpvDSeyPE0VUU8 352849ktbRKD46cByWKEoLsLgdkRutBjJPSpqu4NQwO/L+ZuixQ2K91Gbh3PrF7FydP2sY2lEyDjnT 352850XMdxuc7oPlL77RE29rIi8juRQU/nS8ktygzsLCXQ6f5MxjTutgnp5RJKVmMZ3l3dh3WrN+Dg 352851tQyU1ItBiLf3XzKPy59pVGtaJvj/9yz1N4Cq/331v/+LebBXpGEe0ZspcVMIVDPjU/oW9KEy 352852kRYBMInx2WvQSPTrMhiJWXVSeuKTRdQ7TIfI24qfIU7/Iuvs4IZJKdIhLHOOhZHzVku+ria5 352853ZtFLlGJHRLIiz7XsOBRx6w8j5VUhamXDU9Z9wbGhdoKoRFboPD4B9wsFRDKaas/fCJqmvpi4 352854YT/2bV2K8WGDsUGgt1USmb9bv114fnchvPW1Ye4zCJNnTcb4BZeQX5WJ3f0CxWTd2nfYFkRk 352855TWvqmU/whRB76BL9YYfEXkhDgebeWIuBHQfhz88lyDgxG8GdpjNylioE9KYK11eiR1eQfvUQ 352856k8D0aK7PEum+Kt3fifFmZ4gd3PuOw7i+7rDrkYCPtZJ9m42hHgZERuuP6fPl+9ZQ8hT7JnRC 35285729DFSM6WBtXr8q9j69zRCLIzgMuEayhSgufUF6Rggb8ZSxXUalQi3sl4JlHyxXp/Sr5ohWl3 352858yyUcHMTk7frPiQg1E64dIttteYWPR8PhM/EOSgV9qinKQWbmJ+QU14p1/MonWOitJ4dPGHaK 352859x6tq4bn7FacG2MBpvDj9n5DsweFDRNZIHg0nbS5FUr1Ab8ra3wee4VvIXJTi0ZyO8JkkDiHP 352860K72HuLa6rK8d/3gkiuhISdlJ4RZMp9ezdIOnIDy8d+AsXJcIF8orfY6EYa0IFiGZPswC7Xv4 352861wlpHE7omFgSQ1mS6jf/Se1KYJb8+B38OsGbGJjtvV5iQNgy8ZipMecnG7f1eoltrsqhp+z/J 352862RA1VAUf5besSvXovM2waIWB1MhJCzQRk6yIFWEUJbsd5kj1RG86jz+Fr2XMs66DP5PWA+HvI 352863yslBDvnL/VqMGsFciLAZ467YnFGjAi7z/2FBP7+ONPbT0uvN3Xu0dwliethz+oxDL0xashv3 352864vjWQORRGVNSCy0QOe/i7cJ3frS7VvZ9u6g0bPWuErruFezsHw1HPHN2Wp0qdJ5VPF6OdRJvU 352865KPZw00B4dx2Lad2tpXCoFmNDv0DdlmBCcrgsJSkRYzPDDjXtEX3jh4z+b4bem/djJCXxmXXH 352866lhcVMnmsVcFjfsc6NXi7azTCZetQLNfMC+ExszBtqC8sCOZhEigOp90spqQCXiSuw+EYY6aN 352867QXcHcm5rWqP/YcGZ26J2mqijADtShidJYyfyWJPC67wyPNsSDnsdDbkUw45jxQR9SUxG08Qb 352868UYvjMbevA9sPjbttw7taFXGiX6yO6thDCR4s7woz2pYzaYvs6wGUiMDw5BeitlTGmP6tepVP 352869VcKahHvMdeY42wxOq2KbCg3sVenL4WOgCfsRqhlZxYylBATbUM++KpTdnQEPO/n869SLOWVy 352870K3F4IB1zeHQfj003ckWdYjkxYvxgo0/Z2/2wMOkWDo5sBZdB5IC/vgMTe7ZHK3dfRCwWG0pp 3528717vX7G/rD2UAPJiZ6ZIC0YBW6hTFCS+/Foa2eHjznPlKsjFY8RGxrsgjNpMNoySpCzEtRn8sv 352872T8vTtcMxOv4SHopCxC/HCEGIeFUVJNlS8mQ/VgiFqsUbcaGJcJDKc6/X43NiKMw0xCFXmUfr 352873xgDm0So0rioiEdwY58TA74ANb5r1sqn/dhdr+9oRgNoEHeMui/K0SRte8gUKizCfuSP6xj8U 352874hc8WsbeerCfGWwsE/EEFkTLcnU7XiD46/PFc3rBHFK6zY4PQM2oyZsdOxiAfCy6ElGl3qVzT 352875pXcmwkWL2zhNvfpjwvh+8KAHEhHSh535qjBEBO1L8e04Fi5Px2Uszn9tUAp8froUj2GexuJ8 352876T3ouGLLjGX5IvhtVEsKt5cELBTmJWDi0gmymhOb+qJNgUslfvzWnMyyoImfZDhEzN+Lkoy8K 352877vc9bAuTmPjmHbXGD0dGWfD/apvCZdlEAYtfi86nJ8DIkz3MIx4b7RSIiRWnqFLTtMJ9sZrXI 3528783NsLlrZ9sflRAQofrYCfoSX6nyLjXHINUW16I/FzvQh8/3Z1ElqRA07bKRrnC0qQOtmVzKEB 352879fFdKpG1gIJSu3LhpGnpg1MG3IjIFxzji8lg/ayJHmrg9Kww6KzZu8ouvIoqynjRof7nryp4t 352880mQdLlTrCvul5L8KTSj6Xe3GqmyjkmZ73QjypaLo9UbsS0RyUvYvoXYVho2l49mNi4ovcM3Rb 352881Y+ZtxaEMxXWtMfh8ofwzhPepEHjvOdsf9ew7oLW5PjGAnMPri6NgrynIsVYj83yaauPGbXJI 3528826TMjzbU7K5iyK/mO73cIxq7dYjytlFQKvwm8wDVhN+IKx3BUOnb6aDXykMio03ybGrAZfhHf 352883lbWpaQi3sIU4KUFIYAQz0v9e9pJ1ibHLNxaXv9bLAK8nOMKNgS9WplfJnUNxbXQ5T/jLRQKv 352884XaGQp02U2dsisIqdFSmjWQoA05B9+FT9FeejaehBXbSeeVPE1qSMY32mPKfi0Tp/GJkEYtuL 352885V0ggwKRF+DE8PTkcdlrK8+DxKp5gRUcDQQqAEOzJVE5aq3i2jHkbsHXdahxOKSG4sf3s3UGO 352886/EC+ec+p55Gr4DwShnnXchovR/Rjxk0yLnbDLskBhzRKzj2W39QCEUn5MkQhgfGdGKskc31/ 352887ODQSrnr6cBu8AnsSE5Eo+3fillSOKDlSYtFrpBzdgbUrlmDRvMno40Tn0RHjbpVKgJSGgtBv 352888b1gahrpP+xBiKkytwI1V7dttLN+gplkQNjwX5i7jobG+kf1flS74TuyH4tjnOga2PxeQCi37 352889cyS+6tfrmHeRhmFrDJwxn8gS8zC1nzMzplsPv8qizIjZ6NJkLmH7WnZDCCBdx3LmP1nozX4r 352890JLuJ30UL1qHrcDevBG93C5RsobzBPBeMWaSRmNulEuchAcW70euOGCuMQCJqTx/2Xk4w0jaB 352891z/RTcvk0RfW03QjQK/B4Ez6HfB82/bYhreALzo2w51IwtJ6Ekx++IyOB81Y3630IXxok+tZE 352892/6terCbnFxkH24E49KmWIx/u4toRRpHh177H9kDjJue0qfmSAlBEfTKE34o0qUgOjC1LwGtd 352893pwgs2X8eqa8LUN3IQ0MDT/Qt3JnkwnLoBmzMkJLbRIqAtiumpJYJwPFhDByX9JBhnuLUSMDS 352894BdQQmZmmktCEZZ+9zFtaJP/SKAYZTxHfyRIOHVxg4jgaKZkpmOSmA03rgTieI0GIqMnA5kDO 3528958EDlcfPA1Xj4QzynVygBTM8bi55UkDW7nq1Z3TazcLtEnpTDq3yHQ9Gt2F7mGnUAGQJPL+Ha 352896pEB2x9gLcsTJpjzY63JOYUJrwd4mEZEkdU4HLg2IgFRk1jYUY2bMQHQPF9j13MPm/p8ysP+M 352897PUv9DaDqf1/97/9aBnZhBBnbqGuiqG/0PNlBQ6trmCBgySGs6N2HhfzmNdajUQj6VaVjmY++ 352898fEjvWQ9kDCc1KHyWwHmQGQdgTepHZGdnIzunEJWyOR2LsvHh3Ttk3F6HbjTXsbYDhux9gAxy 3528997X1mnkivZBHmkqaio7m2+NladN+9LMp5yG/8jhtk/zS1DsKsjesxPcSBkfVshySx3NGUzBxt 352900rwkt8wDM3HUJT2SI3D9SxqL7nFQ8SwiGCTlrDmZLhDUnssijOd0xNkUAuJffw/RWBmg1JQX5 352901X1MZuVvLfhRSSoRezlk4OycQdrZdMC0hEfFRXrByjcCalBxmZFOFgN4UJsP19REq6sQGdi3L 352902YPyRkk/APum+NhWx4EfaJvR3M4Gp+yBsecKRXFXpW82H/Yh0I9iSQzDGxS3EmuPvxSGYCzLw 352903vrAadWWvsTfMGuZUR1AgY9fmJGO2rwmL+thm/HGFOcx5RcRIZqspwMcaOAcHJsOIvYP5RE+g 352904uhy3JojMdysH92d2RKhEhKnk4TYMSO91MFvKCUXopf3p9Az4mGhB17E/tqRxYVjrsg+hv7Mp 352905jA30YWBkDs8pt0RepQnkW9Ey8cKgiaPQ1UYH2o5ROJkrXi+NxQ+xngDiNkHLcf3ZaczqaAXX 352906yINMF6TpF9rSqHVmoUiUXGMiEon0mEtGdKTk9RszWpN1rQunIQl4lF+GgtQl8DXUYN9u56W3 352907UFDHQ81bLm0NF9ZcGuf5cZdikgK93jZCYT5Qlv/3yXYMdiZ4jL47og+9E6VvawmO8rvWLbwc 352908AzdWdzQu0LpTuLqSocZFnp2PlzN5XdMiFLsIBtj49ST6W8p/OwYdV+FFtQxu1ERET1Vxnn+n 352909jgyO1cLrzd1jkTclcTeHaLa3soh9QcYsOoCQwP534Tq/W13uDCzB/dXBxIhI9RIT+M1LQYGU 352910x3YtPiQEMV2Stvn4WyaSpvmj/bAdeFJMcJzBVlybkt64LcCGfoW6LcGExGvQBsMERJv6rANc 3529119BWKLQpS8or0f4JZxt68j/gAY+7bsArBmgfSYbubw2N+7zoJ0nXId+gYOgnzqHwyexja0HOI 352912RTNsVAlTUgUvEtZhUYmeFaCkpBDpW7k1bDsiRaqOKu00iU0pwI6U4UlN3VN2nWI71AiradoZ 352913Cy5morS6BM8F72ISzBEcpTEZYjTdSSN18PDt/CBYSjhrqIIT/Wp1VJV7qbG6M23LOgKJHwrw 352914NGEYWlvpM2xNKsKyqhjTv1WP2JxVxZooZsUcwJvBaVVtU6GBvfzedLTSJUaV019VyjXAueUr 352915y2Mkn5ubV5WNm/sWIbKDBfSJQZwxRCzDcPhzvcLwV8/WdYdD+1gkpx3AAAcHhG+/j5fJM9DW 352916SBwOLDeJhkLThVvMReRkn8PkNgYMvPcaH4+4buZkE+6LvUryjPIKTqE/MXpouUxSmseDhe+y 3529170WS5ZW6USIcj+XZhCDqMviFi19Ki6iKWLfdnuovJB1T4/1zfYu91sQJENz9OgWeG7gFWbD46 352918LHsuF55diqlMwe/rJU0CfiWPEzDc3YAsMBcM2vIQRc3kpmqs+YZnuwawPMUa1kNZ+FJpz01L 352919aBo4oVvEYAwe1Bd+1hxT3rpjBGYe/iBn7JcUBHkF5zDEmpI1PDDrgRjoyE/ivOC17KNw9msj 352920C898fqAlYy3LAtFiZvIjLPE1ZKHyhh3/IqcIirzXkyeQb0QT5t2WIeVzGcreH8FQewI8GAVg 352921w5saGSPVR1w/uB7Ll6/FnqRjWMBy55kjdL/y8PbNlXOR9oxxbt91NP44kII332vlFLSWMvTr 352922St7j1uFVmNCDeolrwrr/UXwhhwiv8CJGOWixd1ubLs0WzD7YCx5DL5K2iLA52E4U1ogZBWzb 352923Y8mzCpQ9mAefdrPEuZArnmN1JyNuHta+ImuREzipEGs1+BwKBUKliBVvzOWW4zeW4/WuUFho 352924akiFNXm6uB07oI0CNohYewoJIcL2DDgSkEjZTZ3NQsVqGPpjvWDuRHUVeM/KtWcszn0nW4R9 352925EzLyaR7Dpwf+wETqbUGFCvK+BUreVxS9YEl7ziAjEcpWVJd6xisIr8b7fhHDaRhidgBUyvdZ 3529263w29Qj1YPkUDr1m4ooA9L35GZ6x9Xa38vuVAnC6oEO05Ok4jCdBRLkgnoMmF7eXL9NuyP07m 352927lyJtgRf0dN0xdHoQJ7hIvKPwvWVzofCKrzODDiVEhB3mvlHxe7kiYvp8LFy4GMviE3D8zkeU 352928SaxzOh9Nt2mGXoK0E6I2dR0ROnE2Yvq4McOLQbs43FFkBKopRMadU0iYPxCtjbgQarIhzIVh 352929iTVp3rki6TaEhjS65jZnCOa/6gVWMQO3OfoezpGKEFL7jsudruM+HVeu/8EUGS2bgTjyWazE 352930cKQqHbiNWI3xbfVhPfA4cmo+IzHUDKaB8zG/OzmnNC3QNzFbPrdf/VdcnO4pEbrLDCE7PyjN 352931Icwvv48Z7jqM1TpEAelD1O8vpzGxjT5TDJyjKPlBsZd75dNFjOVt0mOPfFoMQXggWwmBWOwl 352932IYgoIJETrDlj1ZEwy6ZzMMrUlyw0tFeIlbb8byg7XfAdi2Qk0xDsFXih1GXuQncKaFsNwllB 352933PtSPFFimxux+xxggLVvesRBpXIQZRgIhQG7afPINSchZwjry76GLtnMEgAiPegVZyhFwhKCT 3529349eALjFxJ9x9uDxODKaJ3IXvLgscVEpFvNGE/igMFeMVXMdJe+n05T2maO1+Q9/1DrUL5Udsh 352935EifzGpTLmRJykeg5elxKIUq+O9nfUoLVKszjT8Fgjkgg+Rtl/eeiQ1ASHHce8SXOKOHc8Euu 352936Y4xD03OqfL7EcyH1HhKeHuL1nIOzUzvAREtsULHpsRypRcKoUMIUFQ4YnSItt4lys5v0YOQY 352937Fm51NQ3HJ01epKSU+5SUouWEcVee4UA/Ko/54I/HAoWcpduwYGfTsj1T0MYqGKv3jocbAYcT 352938tg+CrSbZYyZflw7DxqvA0xW+3P4hmB/JwoXXN0fY0XRcoaRbTSuEJ2bJ7UO88pfYNcSJReJo 352939M/6YlBEg4/ASjAmyY2epkb/Y661ZD3bSt2drusKUyDnGbfohZvEBpAsiklyYE4e9D3JRUfkN 352940GVcSMCuMGGaMTOHaYyYOveBCHv8KBnZV9yz1N4Cq/331v//rGNgp2f3NBk4ukyS3iYAcs144 3529418OQ8ortMZtFEpKP6vMOxpZHwot5dOjYIHD+H6HPLsefBd2nZ8O1WBqpKk0Ot0f+IvE67N8RU 3529426R4iGQpW9G6VeXhx4zg2TAzgIsSQ80/o5d749RQGEMOW1cAzTK/hl6ZiBjFYioh3LEJOa1Gu 352943bg1tS3RbfBvfheFmqVd42E6kHhsEa/3WmHwmExW1FSjI+Y4aGlY3LFCkz1APm7vLusNW34Dg 352944BIMw0t8SxhKez9Uv18DP3BOxt4rw/dooOFr2xPaM6mb2Wu4ctJTAaJRhMlxf9wg82B0QMH8d 352945RrZuhegz+Wiok+7rX9/7lUdAzDsRxvANYcQeyWhOVJ4xFc27BXpueyuHd9Rkn8YUbyNoahrB 352946e+oZfFZCIGXjaEC9guYxryCxl7eYwMoiUr36E/P6e8PMgqyHd2+xJ9QHU++Kw/UvomCohEee 352947GP8pQdrm/nDU1YKJ7wyc/lTdfO56+rwXezHWzwYGeqZwCZyEPU+kjSzUKzRt+0A42oTh6Mcs 352948XFkUAKvWMxkOUXJlGKzp2LCIPJJhjXcimH43TTjbULyJYoEaxkHYIZRhCT44wFLxN6TlOBY3 352949ZAnC5fc4XYnosOF/5ijMG1+bdQiD7bSJYSQAixhpQ5bgrhqO8nvWfYaVfoZc3XXSda2HXpBy 352950/OJXv8HmYC5yooH7AObINGdcN9jQvcmkI2Zs2o3du+nfHiRe/STCPkXYTDO5VluEBf2TdWSw 352951n5Zeb+4eNajOpo5nMsb3+pw/0Z9GVCC6wtirnKH178J1fre6wvM9K2kcWlECjY4jhuzLkIqs 352952ynRqQZv6rSIwMsQLwfMuMjIsjVY20VVbrs2WYEO/Qt2WYEKitUNkAf8xcZgfNxFhbU0Ivq0F 352953i55bkSE4z3lFAv3fvC+O5jSgNu8aFnW1YPYjahgVpiJRBY/5T9VR9Efwh3OFLcOUmsKLlNfR 352954grMgSs3/1464jiLsSBme1NQ9ZdfF2A7n4CgZhcFSwjAr+j3BqnZ+rOWcUlj6GB14zOYIrarg 352955RL9aHVXsQiwdw+aurC2L0I04ML8nOo9OQNKKAK6tvn+KnENUxZj+rXriVI4qYE10zu2ax2lV 352956bVPjZwBA9QW3kfBHHEZ2MIVhq4GYMXcK+jobwtJ/DOIWrkTiizLRxsprbBQwaEqQMjYAEy6l 352957ceAgNUzKhoHl1+PrxanwcuyNrS9LkfNnP5gTgfgUMZZWPCbgu4EDxtzkGMI3WOgQA3RcSQeW 352958h8qMvRhkL2DgGbRBzMnPSg0D1KuQTpSORJ4ZWSbp19PDCIioC48Zd/CjBV79PytEPL+xAl+z 352959MpGZlYeyer5S73Wh8UFo3LIfyRnYaz/sQi9zGlKlB3a8U0I0+JZMFAe6YLtjlxJPRRomM/3A 352960GHgaUW/mvlhz66uSfPiNqK2slfLC/n6NY6/S1AO3S/nyEQQUbrzk4JZQQGi7Ffn5KG8Qt1v5 352961kmOPaJj3kSIkFF2OInNGWaurGWuVX5mO1VRo13LE6KuKwkxVID2+C/lotGAdfkAqZ7h0vUIB 352962y9AYQTs4g1Nj4SWMddaWyjfNxrShDg2ikCP1KLg8HW2od7zbRFwulInuUF+OfDbHX6W80Wuz 352963jiC6sxfa96I51oQsyXJk3f0TayaEoJWxFjR1reEzcDa2nE7DF0GeLlVIHryqPDw9vwNzh3WC 352964vT5ZH4YuCBqzHIm3PqJUMMY0x17Op0xkfi5kudgly5dDveFON/P6fCSFW8Fu6Al8KsnGpTk+ 352965MLLsjYTkA5jgZYeua1+IFJvsQ/1hLTIWSP/pd1iG5wIwvCx1ClyJkiT0YKVAc+6J/rAi9XQ8 352966ZrNwxbR8TuzDwtVqmoVI5yqsK0Lmx2KRkCpsT8NmOC4KcgXV5l3BXF9j5mFnHZGIrDrpupR9 352967fk2CfS5ZhHWE/VNUPif2ZpEkaB6irW+ERv1SAXPbEJ3XvhaxsRW1J44AQQxcc8UGGVH/7EeR 352968/skbKKterGJ53iQPBanfOUTjWs4LbO1lydinthG7RSH35euOFnmFKLrPWOFkzn7cngxXPXsM 352969/fMz6ug3wti9JghO+Cjae0W/ERg9Kh7NYZ4ELG+XzDt+OSSYV6twHBIYjSkY83BlFxYCR6/N 352970LNwUvLuwXcr0lsxhKFu+HO7HQCllbeq0En+Xsu/PKxOEFaQRMIiyIARzSt6/QJZkiOHq1xxR 352971iexdfYiSJN676hkhhQuntUmODFLzei1jDFKix7rX1WC5NlPnsjzIGmRt786UMbyV0NQGZNwM 352972XdGlrRkLpecfny5FZhPmiNYzs4KhnitiUsi+xyvA6f4W0Da2hjH1EHCMRrLsXkTzOm7qxcJK 352973GXhNxe4tA5mnuzDnoaIiYh2Ts3yjEnCgoTAF8zpSjxlt2PTdinSlIeQbkXecAog6cJ8pD1Sz 352974+wRgtG0Th0cVfLlxoeGuJVMTiH+n2FhV+/k0JntawH30EXxoYX7OM4PpOjeC37I7yK+ux4/7 35297589ic0XPuluA7rn6xmvseBcAdjRjyemswWwsWfQ6K9p10gUFSGKqcm4tGkQcbp+yLGfM0Rccc 352976L0pWsMLgc5wCy6VPoTncbknkcOOh+ns+ygR7Or/iMRZ46ckRcDgFgoBYQzgQi/fjHha2pwq0 352977GEwVvouW4xjOo4HKcqO5HJ3Bgpx81a+4UE067jNFxCq2xt+shz/Nv+g6Caml0mOj7TwYi8Z4 352978kr7rwDHqGD7LkCqE9STzAQqfI+qLUJageWLTq7gwUmx+LBB+Io/rv+xvFPRfmGvOZigXxYlX 3529798QIbupmwbzp0rzAP6SZ0MWp6TsXzdZlFWuAVC+fLAmGC/ki+B/NUkdm/aitryPw3oDwnHbdO 352980bcQoD31mTB97U8Du/nGTW+9EGd8mI9tVpM2DJ91fBblS+fVZOMDCchLAQyIqiei7IGdSm7Ce 352981cNHTgcu4ZBSIvBdLcC3KBhq6NvByt4D94CS8e7gAXmYOaO9kyCJyrJDIy0v3uvyLM+BloAlt 352982fT0WWcNj2g0pAzz1IvPU1YVL35Hwt9CEgYJ8wo0/HmNTP1toaxqj/fRzClP7VAv2TV0Fe4FS 352983A3vZXc5DRwLAEBYej9/sN/8rGNhV3bPU3wCq/vfV//4vZGAnZ9JZFtrQXJSSiu1jAkMmNdzF 352984H5+P7kQfya7nobFR+tuuy9zLGeKtB+NcgeLvvqGiAF/SD2EgNQRqO2BY4jN8+vIVZXU8NJTl 352985IqdMTGC7smUJA9dmDnJnoL+2pT/GxFHAbRHWnc4UGWZzHj7AxzKxnEjTB9E8hNRb6qggcgmP 352986yF7MQKBjja4T47F9SQScjJwRdTRbHKKzoQyZqcexcWowbGmYTtsRYq/ziidY6ueCkLhVmORn 352987Jor8ZtZ9LQ6t6AUXv6WiiF8l10ay/MAaGsI/aUIrvzYHybF+sCJyRcL9+9g93A1WHabjnCAX 352988veK9Vt7ArrSuoK+9lu3DH13sEbg9HWlrOpHzJhY7lkj39a/v/X8NP6oteIxTO1Zj2YoNOJjy 352989XopkzGTBj8cwjkZv0TSBb2wycpVhHaRu4fkhzBhtHLgd70k9mnpvBCXcS0RzFOmd6Svh34Ho 3529905jm3MKFdH6kIBIoKryYLZ2d1hKmWLhzCN+JhcYNK71d6awKcpDAEaccRXsVLJAx2g2Wb4ViX 352991dAhzgmxh22Umjr0uYzJXxZOFXNhnGsJ90RV8ruJytRdf46KuKZIlRGP7YQeCKMHFcgAXHpSc 352992z1/PRcOJ6u6OUTieTrCSTMHfx3fI+PRdLo2CNHldsa7EAdw6aDUtlRkwWC72bA6D4fA/1XCU 35299337FuVmKE0roGPmKPc2oIyDwQrryu3xq8rFaGzXD4goZRJyyT8ICtL3mL+2lf5TALVbCgf7SO 352994DPbT0uvN3avPFuzvVLYXRNvjVbzBgUhnRmg19l+N5xV/L67zu9Wl6/HLmSnwNDSE54QE7J3Z 352995ESb6bhh1+IMIO+UizHIptij5KWTjU5aigmszgKWMkGyzpdjQr1C3JZiQCJcVfrfEzmLq0AHh 352996sQfwWOI8EOn/EuGfWf53Xbp/iCOMqILH/JfqUFLLaQk5kOL1BSVi20tzmJIqeJEwJa/dgO24 352997kpqKVMHf7ZQUPMquUBl3UqWOIuxIGZ7U1D1l17monmIDO6/yJTYHmZJ1Z4l+EgZS2d9Lyu19 352998j3Jyuyo40a9WRyTb1eXi2talWLz+LD7VyOKrVaJ1o6lnjS5zkvGlOB0butK2zNBzlxjTVxVj 352999+rfqqYo1cXvcOm6PawanVbVNOQM79Vq7lfAHFixej3NZquci5ddn42AvW/gsS0dV+QPMbm2P 353000AafkPeDfbOqHbkNiEb91FUZ4t8XAmWPhZ6YFQ7+Vog1S+NFVZexEuFMbTDibSxY9AZmOkINO 3530012wJ+w8choq0xdB1H4fxXTuH7uKsXzKmype+AwJHTMWNML3gYa3Ebtr4XZqd8U+qNzy+9gxhn 353002LWZIuaHAUMavectyfVEDXsvzszatIAmFdSHYq1RhereNeStSNux1ZuxR7L0uLOWP5jMFQtPE 353003EwMmjkPvVobQ1LJEr03pqJAR9muzTmP59MmIGeYPa3rQGbih39jJmLHynBSrmX50L+K7MaFC 353004Q8sCHUfMFjBfFmLloZcol2iXhbsLcUO7PtGYFjcHM0cL5kPTHEHxz+T6ILXIMzZy4Ujso+XG 353005hIZmuDzCCRaeoRg1LQ5xkwejo5UOUxQ7E0BDkvzQkH8GIxy1GdO/66jJGBXEhasz774RLxSE 353006Eq/O2I4QSkIw74kdb5vIycQvw71ZHlxeBrtARE+LQX9vM5bT1dh/FZ5ViD+ykusT4dd5ICbO 353007jsPU4V3hQA5EFprkRqEc24+lZtDnlDuhAYEJMSnRLBS0SfBOOW9N9p7ln5B6dDUm9HCDEVE0 353008zHruVxgOTlGhkQNo2GvnwNFYlngTH37IK8RciLyFWHXkjdy8UQHHy2McLn+rRMbmQMaUo8qu 353009XVt7znONAOPeMdJeZ9M8aFgbQ7QKjcKYMWPY3+ghXWFHvcgtuZwWDBwXhGbSsQ3C+DkLMHfq 353010IHSg4QnJXPuvfCJab43fUjCjLReeTtemE4ZOjcPsiYPRxckW3RPEHrfC9rQIgDSarMnp0aFo 353011a8YxAg1aj0dStvjbFtYVg03c34qDz0VrTFjHpPsupWSMxsKrmNaGyzGnY831LW7acPjTCA1a 353012jhgjESlCUXs0fNIcliuO5uz+Kjo0hHWNg3aImJtSoMi5wYyIIDR+yz7DOIhjfNZ9ScJoFy4X 353013nc+8myJPEsm6moaO8OnK5YMPDAxC2LwbzBuTu0+MR1GX5cN0Vz7lco1rt8J0CfBR+BvbyEuc 353014R2f5fWIQE4ZEk37HxqIbiPWmxj1NGHn0xYRZMxAd0gpGNIKBTW9sSBMrxcK+mpK1n1WvfO3z 353015im9jTntDhW1qWQZhRWqRXJsmgrFi3/1MD5ZLyiH6iuidr491gq5Za/SInIzZcdMxMtiZ5ebT 353016dY9B8lfJHNJCYoUWnMZJRzwRgpOTGSNaE/r2HRHSszNcmCc8mZsFqVJ5/IR7LBeimlNMdN2n 3530174Np3aUM5ZzQTgBjtFnEeKIIzifudHjzn3JcKSU0BjpwzE+CuJxG+sPwRFnhTw54NBh7LEZFW 353018pECv2zFw1qIEkXG4oeAs41UQAS3EUpBn2h49YuZKsCcXY2PyZ4n8SRWC/PFiYVZeMZsMV7sh 353019UtFQuPNjAzs/FIEryoxV7BzMPoWZEdNw8kvLzvgjfSmRSQvmvsMwdcpwdHHQZ94UkgpN4fnB 353020nMcMGW+H4GhMiuT2O00Tf6xIExMQi69PYSQ0GnrVM2ISYmdNwMCIObgjkEu+nhnGQGVNIw/0 353021Gx+DgR0E6VEkonKU3JwGd9KGpgEBqsfORtysiRjWvTXs/MRKaEPOUfSl7E8r8X5LS9HVcXBm 353022MoAreo+NwSBfK857S59GI6mUehdRvvLql1hDiWs64m/924WhrI65ZBh0SrK7FMlIbyytgczY 353023mPU5jOxvd7HQh5LgrNF351upUJDCepJMbOFzhH2pFbBNNe2icLmIx4gE8ymRQAIMlv2Nov6X 353024CkN4knEIHTsJw/xt2HdvFboZ6YLzvfjKCA7g19SHo5I5Fc2XYSv0Hj0WER0sufHUa4dFEkQ8 353025YZ/oGAjHS1guDHeHR9BQIkPMxZypg8kZqMXJohLeUwOp95S2FfxHxWLx5kuidAacEkC+SftI 353026nPpchIxj49l3zTxWXlVLPadSCDrTPd8iFLs/1koZHu5Nb8WtNZrH93oxKgX5rmh981CJkGEs 3530277G08ultoQcdxOA7cO4nRTuScpeROCfmZ9y0Zw2wEkQuIESjqVJ7Ud86v/YTEAbbsmfQcjhac 353028wwvXHMc7iTNNGBWEpQCoV83AXvt2C7oayZ+PqpZfwcCu6p6l/gZQ9b+v/vd/IQN7hSDvNI3q 3530298aRCQv67hWnMq1ULesYGMPMaiOhB4Zh1XZwz/d2xNYgb6cvyImpZdiZ6DLcnLlp7CpmyIBmv 353030BHfivLioUladMHwm0aEmD4CPR4TIIC7eY2rwZp0/i2hl3u9PuTOIlp3BJtAycUVAWCSiR4Sj 353031kz2Vc3RZOqj8BjFRqzhtNyZ2sWVGGA2COfSROMcz9s5C3KYkpNxPQ+qxWLQ3FBtlRPruw9UI 353032stCFiYMr7E11RSnYtMwDsfKBOJ1V8aO9WC7pgbNwNf58J5N2qeE7UuOjEUvHkBhzT8eNxgaZ 3530331EzS41CP78+vIPlOZpMYhXRfKc6kA9vAsZgyzJsZSGT72tLy/+aHb9KoXXQd0wU6qYaWMZza 353034cHnGuT9f9N/4UmSoZtEQl3GRyShpwq//UIR6mnIyvJY5Os08ixyJc7/g9EB4hB1H5qvNCPad 353035hQdNkJ1pZJ6kaFe2TqhOPn5pPNauXYt1O84TvKDp9/vx9ABWSI3LCux/Ih7vqlc7MHnuUbws 353036bUDJrYWYuOYavtTwpGSLQ8McRZEJtPQt4dy6LdztDLmImgY2cPcUjok3guPE+he/PI3oQjT/ 353037rBHaDJqNhTMGwtNEKMdYosvkddiXuB871sQiMqgH5j0ol9eV7kyCi7YYz1NU3m3jvP10bAIw 353038fHw0wnwd0HYal/OaV5SiMo7yO9ad6t5EXQmdpT73JIfx6bXFrBtFgmgKP3BrgjOXJsptgCg1 35303954IFS7DlSo5Ix5TEjTT17eDTMxz9ureHvYGZKKdrS7Ggf7KOLPbT0uvN3RMZPvVcEDZ1DmIn 353040DUEXRwMuUoBHNBLJXiuNR/18XOd3q1v6aCn8yNntPvY4M1pRI1byjHYwMvAk57hwfdYi5/Q4 353041uNG1rLDNPtiY9kPKXtESbOhXqKsqJiSF3QnCbisrQv3fImw3Ti8ne8L06YjsZEn0Qz20jbsr 353042+j5UwWN+xzqH+0jWGYbOjvZwtzdkMphtlyjMiIvFlJG90cHeAxNuilPTNIcpqYIXieoYe6DP 353043+FjMiZ2CUWGd4BGwhKU+bXE7TdRRhB0puiaLncjeU3b9R6oA29F3QsjoSRgeQGVVbdiGJeB1 353044JU/p7/mVzzhMW9cT8wRpC1TBiX61OmKMnnsfyWjAUrLtrSksRYuGnjNCx09BJJPptWDZcwOe 353045SxiSVcWY/q16qmBNUvikRtOYXkvalDOw0xBfA63IDyzC8GdOQwuE9isY5eSC8cRgVJOxGV1s 353046FYdN/nBoGnp528NYR5Nt1LqmzugcuRLJWdJhoRqLbmNBRwd0XfWIsbvYteIHWD+wNcz0DGHr 353047G4WNqd/E3oG1+bi5cQy6uZlBT0sbhlbu6DZyEVbFtGdhDnRdx+JMrpL86g05OBZODI0mQVI5 353048vIUKY/7ZaDjrmiBg9dNmla6WGNi5CY1iAKxZ6H4pdoRs+UZzC0gA08q818XKdSnSD05FMB0P 353049PRM4+AzE/GMvUdoo7wmYnxQhEWpM/GdOFKXcRr5Sg474Tw/eC59IeU7yq99h3/ggtLUzIfOh 353050BV1jW7QNHoVlSS+kcpQrKiXXxzCDspH/eryRBQ0ai/FoxySEtneEqZ42dAyt4N51OBYdfY6S 353051BnljStGDHRjfzYXU1YWRrTf6zT6IJwpY0jRX+gGWK90EXdelS4X0UeghUJyGXZN7sJwU2tr6 353052MHfuiP6z9+JBoTQ7vuBKHIJdzaGvowtj27boHr0Cp16XKiR75B7jQr5ZDjglWiv8xkJcHOsM 353053HeOOWHC7qMmUDfR9yzJTcerUk2ZD9gvLyzNJuPn+h0KDmbDcnuSqML8rt0mnY3VnS7iPOYKM 353054os+4tX8t1u5LQfrdg4hfvQ2n0nLlvN6ZQO+/Ck8lNnxKcpnoos0ZcgSGh2uj7MX57ZkSbA7n 353055jhGYvecBCuukyTg1OSnYNKEH2lgbQofMh5ljO/SIWoyTn8RECcn2NLX1YGzpBM+uAzFj4wVk 353056lEobJmWfzf2Jc86J62jDbepdpvQqA2FqvqRg88Re8LI1ho6WDgzMndCueyTitl7EO4mDSlF7 353057DTmH0UcmrL1U3Smpcs9mYeWXCjwnZYzfsr+j339x6kL4Uk9MHQcMSfwommPFYyAORcjdN0KX 353058zRlyJB9R+BazPjgicY6IfrOJ+w0zOs/gyCqy78gMCLm3sHViT7Ql86qrZwxr9wAMiduNOzk1 353059UueF8L1aTb/XrIGjNvc6No7pBjczIXinA/u+q3E1q0phm+KxIkLH9QnMAKntNkUkoD7fH4ch 353060QV5wNCd7gRb5zu280GviJqR8lj7TaCjnHSx3mQm678qUD/lHwclHOzGphwcs9bWhTda7C1nv 353061s3bfQ4ECAoc4/xUVCKwQdlA+5UTh+YEsRBuNthG49a1ozG+Nc+R+Z+SP9TIeFD/S1iDInJzP 353062Rj6Ye4M7Y1kYpf19WHoGg44rkV4p23dxSCFlKVAqny1Be33FngaUFdn7kESYtXoujL2sh7WU 353063If0NMaTbSnvtsjP14nDYSHgNq2qs+qul6G48+nuYQs/QBj6Ry7Fpohfzwpb0vOfSJ+ihzYTt 353064WB3pDUsDI9h1jMTaG3nSrNLGEjzdNw0921hBn5yb+pbu6D77PHKFOU5rPuFUbDCcjcn+5dgV 3530654xZOgS/1prEdjouCqBz8xh9IT5yJ3p7WMNDWhp6pPby6j8Di4xki+aXiwSx46FBwe6WU8ZEC 353066ApcWhcLNRB8mrj0xY9UMdKRkN9tIEZFBmH9TFNKr4DQGWGkI8n41SL2vZNhSRtBb1ZGF2HKf 353067IT82XvNpezyUpa2EP81dadoN8U/LRd+QqN4CcZvSfaEeSBwZTehtJfIUshnWov7zeWV4fTQO 353068fdpawUCHnO+uAYhcdgoZZeL9mosSpIvWMTuxblR7WCmYU/F8kTPJvQ/i1saik7E8sUF6DKTX 3530695dU/BsPf3RpGRGamQLB74GisT8mR8AgswPUlPeFsxBFKhbny2b2qtzgwuh0sdHVgZNcOvYf0 353070gjMlXtqNwBUZ2ZEa6gdZcQS59osfyZBuqpC+jGN+67dfwjzzRJ5cWo4YdUEc0aP64yFEOumQ 353071+QvAsvsUfKrE8xXcvLtNusYAOFl50jhgHV7KGLo5BUaBV5LEmhV73mvDdbL8WajIwC6OhKN4 353072j/idDOw/o6/qf1/976v//X/OwN6Qc4ST6WWiS7Gcy0/3Ykp3N5hSYEvbGA6dJyHps1i+2Rhg 353073pFB+Ep53crhMVSbOLR0EH3sj6OgawdazO0atTBYRsMR4AY30IkghJxFeUbJc3zQFEQEesDXW 353074hZaOIaxbB2NM/EVkSoCSfB6Pi1DIq8Cb/VzUI6GnEC13ZraDscjbVAvGrYdiyyOZ0N5kHEpf 353075J2HxED84meoR+cUJnYYsRtKrUpVSFirSwURR5CQ8t37O3vxz+yosfzXFoCql4vF8eOkpk8Ol 353076UwaJUwkZwsWvDawI3tJh9AbsnxcEG0NzdCSG5x88MSn28fyO6LTkCb5cjkLbvkcUEjVEa/N7 353077MpfGTO58X9FkTmyV8MjGetE88xoaFRIdeNVfcDMhFoO7eMCGrmkNZWNiiE7x4rzfdD1VZBzH 3530783DBv2BrqEGzLAb6Dl+LYtSOY26c1LPS0oEXwQru23TBo1h48KWmU15W2CHSl7srnkuKdmyJ9 353079YGNAnmHiAO+Qsdh4l0sF8WJtgMo4ym9XN16FugKy79Up7gT014X7lCsoFGJmNRnYoHCftEDY 3530808VzRd6kIN7Jw6Yi+E+JxMaf2L2BB/2QdeeynpdebuycMLc0RcXRhaG4Pj87hmLz2DF6WNCho 3530815+fjOr9bXV7FW5xKOCsVUYpf+wWXdx4VpaD6njITnf0n42DKWawbGwwPKwPoSLSZmiv//JZg 353082Q79CXVUxIfHa0WkWuxPqyN5zzuPYZB+ib+tAz8wdITMP45UEjqoKHvNb1rm3FgNaE3sOGfdW 353083weOx9VYuynOuYfVwPzgS2UNb1xg2rbticOwepEnYOJrFlFTAi/7JOoqwI0XX5LET6XvKrtPo 353084nG+OxaEv7QPDdrogasVZvJMxQMv+vjE/CREW1DYajqT8RpVxol+tjkry04+HWBnaCYNnTJRr 353085602ZjDyjIsb0b9VTBWvi9qtqvFztR3CqpjG9lrSpgX+pVD3/A90HHW1SAP+nCge4DYKNlhUG 353086JEmzEBoKLmKSuwGsem+XYrf8lOcSw/6JwTbQtemHHa8qWsR2bsp7Xf3Lf6fUfkhADytnRB7O 353087VJgz/t//dnio+ngCU9qbwsipK4ZOisWcuGkYHdEZrq79se9jrfpP4j89J5XpiO9sxBTKfoe/ 353088NEmeUOtxYiGu4uBJDmVDvxXEaMRT/0H5Veam/C6mtRLnmxLmsJY2CJ5Gf1sPzBJ4iAg917nf 353089cMp+jfqv/RaVmpIS1IjA6DKkrexEFGRN2A45ibz/U1aj8s4RBhxbIiIp7/8CoH+FkjzUBrIp 353090bJorQs8lyTCXavuNUxJNb3PmET/xyre/aDypFeV107ULwphFe5EmAWjLGthrs85hXVw0gux0 353091CWhoh2En81SeO8nyTxrY/9+i/gZQ9b+v/vd/HQN78/viFxwa0F0u/PbvUCqeLEX3Tn0xZuYs 353092jAm2J8YvA/gslzbYN1R8ZynHPuWKZQ31L7/oGS2MtmDgi5VNeP4L5bujfVtj6IVspK8KgO8c 353093ebKg+hf1L78mFlCFF+uHI+7WX486of5F/YsqhYbw/l7ZqP4Dof7lH97jKvB01VDMSy1V/8FQ 353094/9KMLFeCjxkF/xn7oipYE039fIGltVUN01OlTY1/50Pn4XvKbIxYm66QKa0upeplPPyt2yPu 353095WuFfAvnUv/z3S0NFPrJzin55IKL+exr2zQhFGytDGJi3QtDYdbiUWaH+yso/XF4cXIjoQJoK 353096gRhxvOfgTon6G42bKvyGPJyOdoORgR3C9nz8JwQKqP9f84X34xkOrBCH9tt6NafZuanJPI11 353097i8ThQo9mVKr/QLawPJjdHq26DcfUuNmYEOYFUxrezSoUW15V/t97+bKxQSzckrbDCJzJb/jt 353098x2qFrwE0dNsg7lGFSvVpFIjMPT2YV4i1IEeWOpe1M3rAVkcbdkOOyuXbb0mpzUrC9K4OMKRr 3530991XEcbkqkeZI1sOcnhcNCQwv6Vt4YsPyK0tyzzZW8k8PRxskNbm4Sf64u8F+gulGh4ft97F6m 353100IAzwst24//3nfR/N9VX976v/ffW///fdb2nhVzxCXLchOPX195Pdy5+uw+D2DjDW1YGhjTfC 3531015yfhrfoTV3/bIopEZjUI5wp5zazbB5jdMQjrX2bj7OC2iDjx+5Mo1b/890v1+6NYGjsFA70c 3531020GOn+mMA6l/Uv6h/+W+VqoxELI6dioFtHdE7MVv9na7Uv6hNST+7RyWsiV+VjuU++ipheqq2 353103qaH+w6/+Rf2L+hf1L/+NssDbiABbbREyYRNSFIS6Uv+i/kX9i/oXZeXh6v5o52ACXS0dGFm3 353104RuDIZTj5uvSnAKWmWgaw9YnE+juF/wkFj6VSMuuDwyqmUuLzy5A61Q3aLOToK6n88upYNHXN 3531050XbAGtwu/PvIFspysP8KpfZjAoJNFISkNQlGgvpH/lH/ov5F/Yv6F/Uv/2KpeBSHNrpcWphn 353106leqvS6p/+e+V8odz0MFED+beY3EkU/3lLvUv6l/Uv/y3Stnd2WhnrAeLDjFSKYfUv6h/+a+X 353107me46KmFNvIIzKmN6qrb5P1eVD/YKl2gnAAAAAElFTkSuQmCC' 353108 ) base64Decoded asByteArray readStream! ! 353109 353110!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:22'! 353111dejaVuSansBook12Data 353112 "Created using: 353113 Clipboard default clipboardText: 353114 ((FileStream oldFileNamed: 'AAFonts/DejaVu Sans Book 12.txt') contentsOfEntireFile substrings 353115 collect: [ :each | each asNumber]) asString 353116 " 353117 ^#(12 15 4 0 5 9 15 27 36 51 63 66 71 75 82 93 96 101 104 110 120 130 140 150 160 170 180 190 200 210 213 216 227 238 249 256 272 283 293 304 315 324 332 344 355 359 365 375 384 397 408 420 429 441 451 461 472 483 494 510 521 531 541 546 552 557 564 577 581 591 601 609 619 629 636 646 656 660 666 675 679 693 703 713 723 733 740 748 754 764 773 786 795 804 812 819 823 830 841 851 861 870 877 890 900 910 920 930 940 950 960 970 980 990 1000 1010 1020 1030 1040 1050 1060 1070 1080 1090 1100 1110 1120 1130 1140 1150 1160 1170 1175 1179 1188 1197 1207 1217 1227 1235 1243 1257 1265 1273 1284 1289 1303 1309 1315 1326 1332 1338 1349 1359 1368 1371 1379 1383 1391 1399 1416 1432 1442 1450 1461 1472 1483 1495 1506 1518 1533 1544 1553 1562 1571 1580 1584 1588 1593 1599 1612 1623 1635 1647 1659 1671 1683 1693 1705 1716 1727 1738 1749 1759 1768 1777 1787 1797 1807 1817 1827 1837 1853 1861 1871 1881 1891 1901 1906 1911 1917 1923 1933 1943 1953 1963 1973 1983 1992 2003 2013 2023 2033 2043 2053 2062 2072 2081)! ! 353118 353119!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:22'! 353120dejaVuSansBook12Form 353121 "Created using: 353122 Clipboard default clipboardText: 353123 ((ByteArray streamContents:[:s| 353124 PNGReadWriter 353125 putForm: (Form fromFileNamed: 'AAFonts/DejaVu Sans Book 12.bmp') 353126 onStream: s]) asString base64Encoded) 353127 " 353128 ^Form fromBinaryStream: ( 353129'iVBORw0KGgoAAAANSUhEUgAACCIAAAATCAYAAABPoj6PAABte0lEQVR4XuVdB0yTaxc2IRJC 3531302rRpCaQQRhhhhRWWBFCQuAeuuPfee+LeE/W6xa24xS1OEKSyFcGBCxwoICB7lNE+//t9LaWl 353131g6J4/3tv36QJ4uH9vr7znOc855x2gPY37W/a37S/aX/T/qb9Tfub9jftb9rftL9pf9P+pv1N 353132+5v2N+1v2tFqv0VizcxtiM4XoDz9OObPO46XFULtH5j/UBM1lOMDPwbpBbUQiYSo+BSP6JRc 353133CEQi7R+cPzXmIgE+3QzFqs3n8LZKgM+3d2E1/fOvjXldfhwOrViD0y9KIdRg3kSiehQlhmHl 3531342jNIK2lQLSesQObldZg7awG23spGtVCkQq4ESVu7w1i3PXgBIbiVeAr9jAzR52Q2apW8D7XO 353135hA0NaCD9yf6s+n3rkB8TipGeJmBxbdB1wTm8+T+fQ6Kajwgf7QiPefeRX6/u3avxNqw/7PyW 353136I7qgXvH/6/MQOacDnDv5wKnbFqSUCpWMLxmfBiE9t7I/U+3p+kDY9TmAN5K1IxI14MfDBfB0 353137GoOzWQIiX4nXBwfAxasjXDvMxu3culaPv2Z3xU3M8+JAp70BvKaexDNyX/QxNELw6c+oU7oG 353138GlCcFIo+rr0R+qxMo3VL/13dN9yc7YMOMyLwSaD+b4TFidjS0wnODh4YF/4RNWqeIcg6i/EO 353139DOgwHTHmKB/3FjiD7bIUiRUq1nzxI4w1Y6Hj9peolv35bz43639EYYW/NbqFPke5BnMoEpbh 3531402Y5usOm0GjGF9arHruotjg1zgaufK5yHHEFmlbDlcSBr/eX2jmCZjcWjYhXjRtZbWco2dHHo 353141hdCUUo3nXfub9jftb9rftKW10/4h0P6m/U37m/Y37W/a37S/aX/T/qb9Tfub9jftb9rftL9p 353142f9P+pi1NJKrF14jp8PXrgy7eA7AnvVz7HQf/uTmuR/79xQjsvgp3+Ccw3m8g9mdU/G3zTDkk 353143BTUC1EucaCJhHWqqBWj4D68zkagcCYucoUc77CqQFOIGfTXOO03msJC/Hf19R+P4G/VzRzkC 353144S5/9hUH+YxCWrtoBTDmwM09PQa/Jx/As6yn2jOqJOZezlJIRROXJWNXFBV2XXcPj86sxqpsv 353145AkbtBF+Fo7O1TlxRRTJC3JgwDd6JG+cWwIPFQ79w5Q7uv7M1FMViVaAXpt/8rsLZLkTlyz3o 3531464zYERzKrFMaaIqRknx2PTmNO4G35T8RvIefssigUNIjkZDL3BoFjMhy3f1QqOHpF1e9xaqQn 353147gve/RhXpvz7/Pub5dMLy6EJ6DxUnbETPrssRlV+BD+HjETA2XDL+HATtzYRAZvx/fT3XIefK 353148BHh5jEQYPx6XN05Ar06+6DrpIFKKG9TeL98jF8LffyHu5de3/ByyJt+EDYbXwH14UaaeiCIS 353149fMLFqZ0x4lA6fuY+wsqevbAurkjpuUKNcVb4KHh4jsKR6Ej8NaMvOvr1xdKIbJXkBVF9GT6/ 353150eYUP+dUQyv78f1iTNVnnMcG9I1Y8KVJ7blJnbeHjEPh7TsalTwLVcg0/wV/XHUFLIvG98jsi 353151lwSh+1o+fjaI1I8DWe/V+R/w6s1nlKkg5zQUxSAkoCMWRub+3/evslZfmoXUhBR8KKn/h9wV 353152DShJP4153exgoM+CRafpOPa85D99P/5xfaOiAlV1wv/T84WoqyxFcWmVVOfR/vYb49lQg4ry 353153ClTX/7cI0tpPRND+pv1N+5v2N+1v2t+0v2llK4xZCX9zP6zmF2u/waP9Tfub9jftb9rftL9p 353154f9P+pmVNJBTgZ042PudX/pIuWJ//CKvHL0ckFYkr+IyIBaOx6lE+6rVfr/wHzXE50o/NwfDB 35315547A2MkdpFPsfe3bDDzxYEIDg3emoaKjAi13ECTjvntooc+1v//L11konrqgqA9s7GcF+2h1k 353156pR9AN54NJt7M04ozhHJc1RR8xGvi3C2tb9nRq/n4v8bHghq58df+9s9uDZVFKKvV/oxEmu0b 353157Ab7eWIR+w0ORWKzZmFHZNq5NcoBV/8N4Xan8b2q/RmBmoA8Ghqag9G9wJIsqX2CjDxvGPTbj 353158VtxNbOxuDLbPRryo/D8QXj7dxtYl63HlXaXGhJvqt6cwIagPVt5XTjwR1eXg+twg+AzcoTQb 353159jCYtYUsXWHgswoNmZCZKr0nb1R0WLtNx9atAko1jI/zZurAceR5fakX/l/O8NGUHull4YnFU 353160gUY6Nf03qbsxtPNw/JVSonTshZWvETbKD36jwlSu3X+2TlCIuG1D0G1cmMZZ10T1P/BwoTtM 353161O65BXFGDivV3EhMCOmLEfqJfttF+pcb6QF9LOE+NwBfBn1lDSokIomasTVWMTsUFVIkXG31h 353162O/IW8skgNORGYIhtR+x4qXjpi8qeYnGfxXhapvjF6gv42DPeDxZsJgwde2PZlfeoFMqzJrPP 353163jEDAzDvIq1fG+KtFXuweTAmyhyFDH2xTZwSNWocbnwUqv6f08vvxAHPc3TH3YQHC+tij+55X 353164NPOy+bsv6jUPcWV/78au+3wGweaeWJlS0aS05URh1+QgOPBYYPEc0GXKbkTnNH1Pyhi+s2c5 353165ZozoAW9rLnTbKWfjimpzEXt8LaYP7AQnMw709Vgwtu+E4SGnkVJQJzO2dciP3o6Jvf3gaM4F 353166Q1ePHt8u4zfi6hs1jOPaL7gwylLh+eI5aId27Zp9dJ2wML5cyUFegJTTyzDE11o8t2YuCJp0 353167CK8qW+hP8tGxnoaYUpH0u/xIOIL5wZ4w5+hBj2MOj77zEBb/Q+4SodZT/tMwzO3jDjMOAxwz 353168N/SeE4an+bX/ikOvOP0KtkzrA09LLvT1ubD2G4VNd7JR1caKBZWyLm6hM/TaMeC1OgUVzdeY 353169wtzoQJ9rCa9+8xXGvHHcf6Sex7qJPeBuaQimPgtGNh3Qd9pmXEzJh0AoUuyzPQMG5k7w7zcF 353170a45FI0vmkFe7NnSsMDm6RI2MDqymPJa7LCs+PMShpaPQ1c0KRix96LONYevdE2OX7cOtjCIa 3531714BCpYcCLmqX2UiWr9jyWkROWv8TRUbZgGnbCige5ap+tOCZsBOx6rcCIFv6Mwkx7XfL/zZ9P 353172jbU5hl/42myvKE9XRgF8+YmnsWJ0EJzJ+cJgGsLaqy9mhN5GZlmD6jnS0QfXwgO9pu/Gw8/y 353173xvtv9Wnuhu6TtuHOR/mIClFDKV5f3YQJ3VzJXteHLtkvZo5+6DNuOU6liZWils4Y6YeMQWvm 353174/+ZYS+g7zEa0CkOiIf8Oxlsx4DDnMQoix8KC4YaQ5Ar5O+JLOIKN2kHPdSkSy0Vy5/bXs/1g 353175xO6E0FfVdIrEOzMcwLKZgIicumZAyGvs68kDx3ctEkqEONjbGByfNYgvESrszy8XR8OK5YTZ 353176d/M1GxfpmDT+zhiDI3IR2skMQfsyFVKkbvFjSeQUx7A29xG2zw5B+Ovfi2ii5uFD+Gg4eczF 3531773XzNmeGiP5yiUKRB6j/1hmY+YndPRKCdIfR1xGPf1t/td8+sv3M8/zOgQ10RXsfz8exThdYS 353178Z2hjNf00FvbzgrUhA+3Nxypfc+a6REd0R/DSy/hQ9WsGa0vnmq7jfDk7htKlH64MgJGODtie 353179c3E1u+aXz6c2O+M0/A7aL6f9ctovp/1yrZX7E/e5SPAdMXuno4erKdj6+jCw8kTP6Ufk7cPk 353180UwgZ1hF2RkwwiP3u2W8u9kd9om3b6te7EWRojqHnvsg5m6m7ozx5NbyMO2JbeqVE7y9BxuX1 353181GNfFBaYECxDr/b7oNWoxjqQ0EVRFtXmI/WsS0akMaIzE1KkzxmyLkTqSRaIavA0bCO8xx3Bv 353182/yB4DDmOD0rAO2HNNzw9vRrju7vBwoAJpoEF3LpPwJozCfhe00zPrsnClZXDEWBvBIYeEyau 353183fbHk3CuNUlO3dWvVeytbO5T+T9nOmeGY4WdG7LBOmHnyBUoaRK1cG59wbd1oBNobgsEwgkO3 353184WThK5unl/rHo5GgClp4eOBbeGLwyAu8IBiAUFONbdhaystR8PuejspXvIcjjI2x+P3gRbEVP 353185R/57qtLZ6/PvYnaHTpi7fS46ec9CpMTm2DHEC1YcXbm/FVa8w5WQYLgak7HmOaNvyGW8/Y00 353186/XSEZFkBvn/9hGx1Y5H1CXkVvx8le2bVXISEpaC4QaSgv5VnnMbKuSEISy5u1bnREs70d8jS 353187c//uALpxdWE77T4KW9iLoppM7OnMIZiJNSZG/mhRlxN8j8bmniZoz3DG1PBXKGtQn/XhZ9Qc 353188OOq1YHtLMK7fwtdahZn9KRn1dqXS36nCpRp/L/Os9gwuTO07oMeohdgZkYp8gRIMkdkBa5Lk 3531898W5pNodfxL7+K/Kan0Vk/aWcxZpx3eBK+RLIuJu7dceE9eeR8ikNhwZ3wLiIb22Cof6dsq3D 353190y1rWj4Q1OYjaPU2qB3GJU7f/4tN43iz7hqguF5HzfeA1+zZy61o4jwge+O3qJDi7Tsf1nFqV 353191RIWrk33Qe/k2TOzQGesTFZ3CIsEXRMzqhIDFkXhyaAgsqTNI1xYTb+TKEadaynQilStPwCJn 353192JqzHXsSHove4MMYaTOdFSCj/PzjRhRV4fXQ4XDquwOPClte5sCwV27sSn+G2JIX7Tjrm16ag 353193Q4+l2DrRB0Ebk5WSO1rKoCMS5ODaDHc4jT0vLddC3etFMcvhaxeMvS/EmbyEFekIJTj28L3n 353194sCrIE1NufKfnpKUMMbW5D7CikzEsg0MRk5mBmEv7sDpkP1Jk1rOm894495+vTIar2wy6VE5L 353195rf7HQyzydsKIE2+V+qioTDEv9xB/1pD12DDUE332vGzmH6ayIO3BiE5DcTTjAx5s6AVz+m5s 353196D16vvXhTrWpdCsVj4zYIV743/HldujwdBwc6wG/5YxQ2aLBfb0yDi+MYhGfVKJchuP3+YA8M 353197WrcJIz26YmtqudKsRJrsw6axLkPK1i6w77UTz8qEv2TbaZIRqm2JCPU5uDjQBoG739AOrYqk 353198pXB3mIIoJY4VMRFhEfjNjFiKMXxvmh1Y1kOw89ZDnF3sBwODztj5qonMUPftKiYHjMOFL8oP 3531990Jq3B9GLx4bT6FBcjUkA/144ts+agI1J5WqJCCJRBdK2+MOyVxhtPBbHLICb3ShcljhqnpwM 353200x5Mc4gyTEhGEqPnGR/iJmL8BeK1HzvmBsHBbigTJmAmL+Vjlw4WR/xyE3eWDfzcMc/yNYOC3 353201FvGSMRcVR2GCozW8e4zAjHlj4c5WcZmSsRjv4IBeMzbj+PVoxCfH49H5jRjqwALXbzX4jf2R 353202hfzl1mas3H4MEQ/4SE5JQsy1fZjVkQd9y5E4+6lWxQFMLj1zexjrK1MaGXCfdwWJaWlIa/y8 353203eIOvFc0u2voCRK/wA8+8K+YfuIbHCSlIeHwDx/acxktJbStRfSmyX8r0I/kkXpkHN4Yu7GY8 353204lBoNgneH0YfHgNWADbj0OBGJ0Rexvr8VGLw+OPxOID3UShI3oCOXBcfhW3ApOgGJjy9j20hn 353205mHfegpSyfz4bK2Z2IHrP+wuXHsUj6ck1hI5yBJPtiw3PKhTJLj9f4s6BEIzr4Q4rAu7oMQxg 3532066RKIEUv3487Ln2rTSwmLHmGGnT4BhBhgui4Bv1QZMCE716lIeBiOtdSYG/XCgcwaucvm7ZkJ 353207cGQbwHPUepy4FYMEsiajbxzD+nG+4FnJKogyfaYmIe5BBMLWjYOfMVHavOfh+heB+rVGr7dX 353208+FRWr0bmBV59LmvaAzcWwdeQDbu+C/HX+buITUhGQkwkzu5ehIGuXLRvQ2VXE+NLWJqGg0Oo 353209tdsF6x+LSR2aO//ag8llgttxB15Wy1/ohfenwJ7DBbO9EiICMdoY7iHSs0GVwUfP5elxsGeR 353210uRy7GeF345CYEIMbYcsQbMsCL3A1oiRgjML4P0tC9OXtGOXMAtNtEaIkCuHv9hlzdRcmehCj 353211ymkO7v9okL7727ABMGNaoveyI7gVm4SUpCeIPL8Py8f0wfizn8TkkuZnzJPD6MtTsmZeZrdq 353212/gsfTIOtvg2m3CtQokDU43vECJgzXLE0vhS12SfR21CsTNZIjW0hiu5PhA2LzBe5M/+S209F 353213eDCJrA+i1DcCx3XfrmOyHQt2k6/je12TwZ55qA+M2d5YxS+m36Pq9X5yn3LhTxTnMhmFry7n 353214KibasuE4M5IGYlWdvdQn/tICeLH0YEMMDPn5yEBWcS3SN/vCrHuYAmibm5kuGV/5MazLe4AQ 353215fwPokDWobzsGJzN/01HXUIynG7vCc/zF/wQRQbx3yXriuGLGqRikStZjmxMR6DlPx9s8+VSc 353216zX+v/USENlwX2j9OxBD+gMM9DMj5PREHIvlIyVA8a6k1mJWegDs7B8OKYY3J9wt/6YxQqzfw 353217T2Fct6YzlSL+3ljgDUPjACw+Ho41vc3BcZyIM79wPrXlGafpd9B+Oe2X03457ZdrrZzyMycK 35321844mDNiBUhUNRTTAK7dA/0BM8riemH47E0yQ+Is/swPxpm6SYQu6deQTP4MJ9/E7cSMhA5ssk 353219RB6ai85uo3G7gICKwkI8musEbnMbpf47rhKA23L4JeTUUXXDq/Bqfx+YsO0xdNMlxKZl4u2b 353220Z4i9HoZ1kwZgUngWTZClwN68G2NhybDC4B03wU+Kw53TO7Bi0y18lYk2ayTy6pkOwLH3iqCh 3532214Nt9rO5qAoaxPyZtOYPIJwR7iItE+LYp6GTCgEm3dXiYWyszTsnYMm02Nh27hScJj3F2SUcY 353222sn2w4XnF33rntvq9ldkDlE0kyMLxvkZguc/B6cjTmONlhe47Ult3n1W8xKldYbgek4iE+2GY 3532236sYCw3M1Pj84j4t3HiMhJQH3Dk2EE8MIwac+oSZzDzpzWnDUmo8jWKXm9yuNv/myZfqg9kk4 353224wue5g6G2bng98iIXIMA5AAsim4D77KxsJG72b8IDhOVIWecDNtcHC8KjEX12MfwM2OiwNqVV 353225JBRqr/xMJ7jPnAHwsWKjfTsNSPTtTDDsRv5vr5mPp4bAnOOJkNifcqRZYVkKtnTiwiAoFC8q 353226hK06N1rCmf4OWQorfr6RzI0+G0yLYbiUo560UZW+Df4cfbAJBmk+6hpyW3I81LzB7q7mMOU5 353227YOKdfPUp6KnzbJQF2B4LEfFQBRYhg3HJ4WsEK3AbvhpHb1CYbwJi75zB9hldYGkzTjm+1irM 3532287E/J/AEiAq8vDj8RP+tZylNE3QrHroX94cTRg0nXtQRLqmtGrtIBr08Y3gvUExFag1P9F+Q1 353229d/JW4f3ZSXBiN/WbRO6264cWoZcVA+31WLCfcAmfBaJ/HRFBY7xM0qf/tnRU1DegQShU7gjc 353230QHxgpl2w9OR9xBN/y+MrWzHMjg376XeR3+wcEZJ78eAgbww/8U4tNkC9yyTPIKyPL1ZqU9Il 353231jCLnoNvEc8gWNKCYvxZdu65TJFfUl4lxnlwK56lD6dd3eP+tXIkzmspu8g7pGVkorhOiKu8t 3532320okuUFqv6Cj9cn0xAox1xaQgAx/Mu/pZIUDp7yMjlCBlV3/4jAvHxxo1Z3BDIR6HBMB/QaQU 353233S1VwsOfewsyA4Tj2rhoNP+OwqksPbElRDN6Vw85U4GuUE3v/ADcE78ugI99rc65hmqcvFt3L 353234k/poMg/2g9/06/hGxrsi/S8Ed5qPBwTrbuz/HZ2hp6l/ul/BT3xIuInDi7rBkq0LHbYn5pxN 353235xpeyul+a96ZxLCa6TTd4kj2tLjMDRTC9MMEbPTbHqyBzUOV/9iK44xzcya2jSZ3zA/ph78um 353236rBX0WqPXVxa9vqi1XPH9HV69zUFpnVDNupRg2G8+4ufflD2ioegJ1nX1xsRL6te4IPssRrt3 353237wYanyrP2iskZweg4+xZy6+pRELUMgd02IblU+Ev7UJbc0slnDm59q/1lDFKT9dy2RARiWC5w 353238ccSMmBKa/ZV1tCdseh5Dlsyk1hclIWxmV9gbiA8aHT0uLD16YHrYa1RSzyrjYy5xfrsuS6IZ 353239qQ3fLmEgzwA9wj6KjcGGH7g/LxCDj35QOnHUQfYhrDsMjAcjogVWS3MiAhVxOsnOGqOv59KT 353240LapKx1Z/E3QkFwWVFeHD/b8wvXcPTFq3FoN8BmDt+ino2Xsadt9936ZOBFXKZsQwSzjPj0MJ 353241bRQLkHW8L3hGPYjTvMnYrSHO9R5Gxgg+mS12mpGFJxSKWlw8ovoK/CgWNGN4ClGesgE+LFMM 353242i/iuVhkWfAhDd64Beh3LUkh1RzPA3Zww6fhJjNBAaVTlWCl9GgIP447YlFzaKkCWytSRtskX 353243TH13hCSUya0TrmEfnJIhT4gdfAboHiZeX1QqnQuDTcD224RUGYNJWPEMm/1tMCD882+l9qMO 353244ybJvX1BS10pHU10Jvnwr0yhdW3VJlZxcw/cIDDbmoPOeTLl98/XuGvQ0Z8G4w0gsP3AZD5+m 353245IDUxFpHndmF+sCMxoiwRvCUaebXKD6382+NgxfHH8rC5BCBywKyon/LrScVc1306jT6GXOmY 353246U60yYyeCDAwRuCleCZtegJzEGGRVqXHek/VS9eE8JtgxYDrwFLIEbecMq848SCuaviuikK9k 3532473oSCPPDPXcDrir+HiNBQnILd/c3BMO2FbU+LpHPdmu/rMWYifMz8sCW9SuZy+4HICbawHzgP 3532483UyaP58Jp/4D4coxQq/D76Tzpuzcq3q5i8wlF35rnqCo2VwKPl3EBGLQ2E6+idx6FYYlfQ6t 353249gTc5h4Zfy9O4T7spt1T2SbWKZ5Kz7Wqe+Lwne3qNFxs2U+6hQAnQIxQKW71mWjP/wuJYzHdi 353250wGLMDeQ1X/N1X3B2oDGY3mvJOSS+m6hsAcaDL+ObNBqrAskh7rAOXo1ZHawx6GJO01qoSMEK 353251DybMR9/GD2FTRpiciPGwYTlg2i0xIFbzLgz9TNjwDHmCn1I5SsnpAZ5BILY9FzvDRPW5uDXN 353252HmyH6bidq94QFVa8wK7uRmA6z0FkXr3SMal4thbe5r1xPKu2xfGty4/Cqk5G4Np6wpJrAhcn 353253Htj24xH+ruo/5RD+PSJCNV6FdgLbbAweFov+799N+4kILRm8dahtEGo/EUHT8Sp5jClWTHiu 353254TpVGrqnMFPTjFoabiPWdGlHb7gVZZ5qw8j3OTXGBscsEHE8vpe8U6neX53aAsc1QHErTXG9t 3532556zNO0++g/XLaL6f9ctov11q5XzqT1BERql9jZwCHOO1u0tk1FXTKn4+JrsyExbBwApTL230V 353256X14hR5L9RvDxGIJNjNHnSJNtWf1qJwKNCRbwVHweU1F4i52ZRO9XH9lM2Z3vDnQFl9cf51tw 353257PNZX/kRBcbUCZkI5YLd2NgTbbTYishXTs9d8uYmFXlwYBW1DqpIgB+r71eZcIfY7F10Pvvvb 353258APrffW/5uzsakyxZ6LAhjWB+BJvZ0AFs2xm/rP+KhKXgL3YB12utzO8EKEjYhgAjG0y8ladm 353259TmuQdW4cbBnG6LnruZzjqKWWd204TOWc99Q+SUbyb+jscniAxGazmhBJ26MUsebeRCswPVYi 353260pUKkoV5ZirSDw2Crrwue32SEXo7Dq5yfqCTOJSG9t/XhFpLUYvT/L+tpgmycHWEJjmcIYn82 353261BhGUI3VLALgGAdj2rLyVWF7LONOflhWTUJ5gobMxgtbtxwR7snbCPqjci5RdnrrGC2ybsdi3 353262oSsMTQbjQk6dWqyzLGE5fLzn4+y+fgRnOY1Pahwjgqxj6G3EEQcAamgbiPE1A3Rar1gLn856 353263m/YUn6vbDjP7UzJtRkRQFp1NzUP6IQw0Z8By9CV8rWvCvpwHDoG7oR2m3G4qmaGMiNAa7Ovf 353264Ll+bn4Lo9J9K/QTC8neIffoF1ZLzter1HnQzVOyXikJ/vj0AnHbtYTb0LD7X/vuICJriZcoy 353265BDOM7BEwai2uvBY7qEUVSVjmyoHHSnGGFjo7RdpVbOhD8F772QqBvP+V1lBVgM/vs5DbBll5 353266tL+1YtyLn+PSqavgvy1ARQEf23qZwzRoLR7/0P55+D18rwpfUtKRJ/hv7Ne2xiDblIggeH8I 3532673Wz64PSnOpoBEzXFAe5Lm5RcUf03RIwlirTVAGw9ewhjAsbiRFQ0rh/biGU7U1BGPas0FtNs 353268WPBcJQYYG0FEcdpmIYr5KxDUdzdeVopUGovvD3UDl+WPrWkVGg8mnXHg8lCYWYzGrfzG6P8q 353269ZGzzh5H7ciQ3RtzXZOHSVCcw2jHgNOUisqqFbe5EUHpA5N3AKGtHzHpcLLnYcnB+AA+GvU8i 353270W5aNX5uNk70NwRt4ATn1ot9ePMIftzUCcRu+X8EgijBy5KOcQi5qKMLjJZ6wI4DBp3zNlEbl 353271G7kID6fawDg4HJ9b6bQXlvCx2FUfLP9tyKhqUhqlhJXcJsIKVU5ksDFFfJEQEcr4mG3Pgvty 353272+VRtlHGRstwdloMuKYxzy8YUAROK3yL6zCZM7eEAjsUvGK3UuFlw4NBjKjadicbb4lqNDDrK 3532734CqMXgoPljlGXM2VGh65kQvgbmCDYQeSUVinjHFVhtfhU+HCNkDABiXkALK3Lw8zBadTKF7+ 353274SCYGNAvWkyKlTk91cy0e8yZghTo7Yuc6guU0HzEt1LtSryDWIvtUP/A4knT0bWAMiUQE9Fjk 353275DJbDbET9FP6eA6ANiAgVRfHY3ssUDIv++CtFni3Xqu+7IQK7e5jDhwaHxLIN+TcxxsYRM69c 353276xGhlz9/8EJen2oFpPw2R+Q3Kv5OwBE/mORKZmXhUJFR6Xn880hOGBt0R9kGg2plUGImRpmJj 353277W+M+DXuo77PoLkaZsqUZfBqdWx4rUloFzLQVEUEkKkcSOVOYpkNxuRnQWZt1HL0N2fDfnkGT 3532784qh1GDfXAQzb6dJSDiJBJvYFWaL74RQ8nO0Eh2lRKG7M/vJ2P7pQRLHj8kQxqmTOxdFWYDnO 353279QuTnTBwbYAqW+xJEN6tBJazMwO5uRjDsshPpFQSouDcHTmx7Ot1Xndpzuxj8NX7gcHywKk5s 353280pCoFCiqSsdzDAv3CPyuWaGkmn7GrG6w6LMTtjDsY49AZu+L52B1sDdc5D+TOueKUcITd//JL 353281YC3FzL2+aRL6dLCBIUOPGIh26DRqPa6/a4pKljLaN0UjOmwWejgZg8XkwbH7TBxOKGhWskSI 3532826i9R2De7LzzJua2vy4SRrS8GLAqXnsE/4g9jZndH8JgsGDt2w/SDUYja5C+fXYQiWGXfw86p 353283PeBC1i6DZQLX3nMQltBU2kZVStymPsiznh7CjG4O4mc59cDsIzF4vFnJWbT5CZ6eWYRgN1Ow 353284GVxYd5qA3bH50jX0W1lcyl/i+FgHGDqMwbGMMpV/478pCg/3T0FnW0OwDG0RNPsU0svqUZF5 353285BcsHesCMQ76D20Csv5sjvj9k/i7q0Ax0o+ZFybuLx6IeP1PPYOmgDrAyYIBhYAWfwSEIf16s 353286QOjy33AfkbsmINDOCEyV89xsHsnYzgoj60NmHqX9rY/Eta1j0NHWAPpsf2zLEDuZBd9jsHd6 353287T7iasaHXXh8cUwf49V+Icx9rVKc71nAefkROgjVXsVwaTXQdYQaDoL2oerEJPobuWCEtAVaH 353288z+HBMGpHRW9kSPsXvD2ArgQ4mRVDdNLiBKz3N4Bxr31ENxfK6BrL4MmxwJCTH5C4wgNcl8Xg 353289N4uqEP6IxGQbLnw3v1CfnlWmtIimAGRbGE2aOuOOjnKEbZ8tiGlWsktU/xPJ+4fDkdhGO+KL 353290NHpmW59x2u9A1X457ZfTfrn/NxFBXE7yMQ7O6wcvCxbaU+X5iEOn05hQ8GV0TlFpDKZas+C9 3532917rnUHpHtozhqGmz07TH7cbFau5dyxMav8ATXcTYeFjTQztyHsxxh2qsp+5awgLIt9OC6NBHl 353292LZyjtd9uYZ6XESx6r8fd7EqFwI2aLw8QOqkLnIxZ0NNlwNDKHV3GhSKeOGFpbCqM2CVsP2xK 353293ysGriHUY1ckORkx9unxQn/nheE/wpIq0bejEMSLOzffSTAzFL8KxtL87TBg6TU7vHYpz0lBT 353294jhqJbS7782+BjrLvnZKPdGkq8/ZgGjujxzyij5XWK7y3yv6qM7DNnwPjPgeR9i0NB3rzwPbb 3532958ksYGqW//YhehY6W/lgRXSCn/+qwnDA67IXK2tZ0xFfcWnTkMuE0/RpyalunR7zZHUgcZpoT 353296Eego90CO6pJ1CnhAFMabs+C3JV1i81XRmeNY5uPpzA2ihhqU10jsbpmfZdfjz5gldCZQ84GH 353297FWoRizQkItDr73k4llE6MhkrFo84y8ZuxA1iCzUI8hB/bAkG+9rAiMWEoU1HjNp4Ex9k6jbX 353298frmEsdZceIbEEqe3EOWpWxHA5RLbIkUp8UN9wFTLONMfl6VJCxNgbdgVBzJzETXTHly/rUiv 353299UrHOyuKxzI0Fm6kP8P1dGLobGKHvqWyVAUxUAMjdKc7wWp6E4q/nMcg2kMavlM8NWRMEo2Yb 3533009sLRLIFmmE8b4Wv/dSKC9Ow73AMGHHGGSWnfW6JwY44TDDqsRXKZUCkRodXY179c/tmmjjAw 3533017Ylt8c2yn5RnIGyYNdjO8xFF+qEx1AUEQ23WrxiHng9v5yFYuaQzDLldsP+t4F9HRNAUL2sk 353302tbgvuIqUjAxkpKci7tpOjHdjQ59gqncUgnaqkHlkKGxtB2DHg7corG5owqI0wKv+s3JEf2IZ 353303OyBwzHpEZJaiIvsh9szqA3dzjlJ8TDM8ThFnc+k5C4ef5iuU+WoJj2u13Kf72DWNwn84kufO 353304xCF+s+dqWPpUdaCmqvNQiLLXl7FqqA8suQQPY+pBp50uLIadpoM55frcGo8X19ZiWAdLcBkc 353305mHcYga0Pv8n7/zTA1/6MHNGj393E1old4UzGW59hQPCUgVh45Cnya+XLrufFHcCMHs4wYTHA 353306MffEgKXhSCtu+CW/LvV+lK4UMthH8n428Bu+AocOzkZH3/l06d/fLWf7p+U0x+laxr7jl7mB 353307F7ALr2vk56YkbiGcOW4IiS/TnIjQsqKiYb3sErFxSUcxqTBiRXWfET6AfCmvEDz4nI+M48Ng 353308yXLBYn4phBXPsbVHN2xUks5EtlW/2oUgrg64/qvwuKBeQ8bKD9wZYwGj3ifkMjiUPV0IJwNf 353309bE6vQnbUfszq2xOT1q6hMyKsWT8FvfrOxL6HWX+UiEBN3I/I8bCxn4qHkoubctyEkAvLaUG8 353310nPFMObOeLnAE2325Amu6tYAsbchEz4MT0wZTHhQpGN3ChnrU11Wj+FM8Tkxzh6HdBFz+Wiu/ 3533114OJXw8e6L8Le1qhRGnXA5JmRi0cH7dkW8Oq/CMfIAS138FamYUMHAzhP3oPQmd3gYKgHXSY5 353312zMkhvT/muxo2shAF96bCVtdQgbUseB+GfqZG6BhyE29/VqGqKBPXl/nB0LQ/jnyQpPMvUQ6I 353313UKzH5+u8YSAZZzlSiwqyjlDwAxn3jmLV2EBYMXWga+SGfnNCcYGfjYoGUdOY1rfwIcacqKEC 3533142fwL2DEnGG5GutBhWiFw3GocvfcSPwRClYDC1zvL0MlIH2b9D+KVxDCt/34dE23YcJn/EAUq 3533150uEIGxrQQJ75+nAwTIhTcV2KPJO99tMZ9ONxELDzNZnbCqSu9iIG80hclYmWlk9FRX2XWlTk 353316v8K1kI5EmQ3EDkk0vqjyBTb6sGE58QGKhKLfMpSoOn5duTwMvPRNyfNlx7SBzhyiUqZBrPRR 353317keibfMm7Tbjf4rsp/86ynwraiPxVIkKHhXsQ0tUYTOthOJyuJMVTqwy7Z3h1vDfMvdeII+6J 353318sZ17dQSsneYiJuuhigstA8VvD6KHIYcoJWlixm5zBb5KMpfj76mMNqrJ3IsgjgmGXs1T+c4C 353319WsYIwcRR3ao+r6npk14b4j7pUha1WTjR1wi6pt0REh6Htz+qNKrB3lZEBKpVpm2ED4uH/mea 353320HPLUvn1LRWIRw2xfpkAKhuRdHw5TpjfWPa+UksGGWHlhdWoZvkcMgbX3WjyrlMxlxFCiaPlg 3533210wvFiFpBdjiGE1DY1NUeBuSuXfCoQOF704pd+k50MeKhy4pdmObCge2kq/hWpw7AqicG2Hy4 353322sozQNTRNmk5UOVBQhvglrrAYdLFFAp2orhyF5XXi3xMn3R4CEDRU/URxjVD63KKn29DTlAOX 353323mU0AY6vu3IoMnNgZhoiHVPmhZMTdOYZlvSzAcVuMxz+FMu+lCyM7R7gPWofzUQmIfxSO1cGW 353324YPB6Yk9GE1AtyD6HcbYMGHhNQOilKCQkJ+LxzRPYFLJLMra70cOIAesBMv0McIUDcXrryqwP 353325wecLpB8WzHssw4m7fCTG3cTeyURxNOqK0LRG9j2V/ioRV6gUsY0pJyXpt8TP2oXuRkzYDtqA 353326C9Szos5j/RBPODvwoCd3FumB5+gOv9FbcJHIJUYRBburCfTNh+PC17rfIiLUF/CxvY85jDos 353327wLVPNUrLN0jH18EDXWcdQiQ/AVEn5sKHy4LrhBCM6zYMGy4+RkLcVWzuZ0G/18Wcuqa/s3eB 353328r7p3bxx3nj4s+qxE+KN4etxX9rEg49aLzF+FzHvpwtDWDm5q5ln1PLrB0b5pHhv741pYw33E 353329ZvH78fl49bNOnLY4mJzpdsOx9XI0Esna4z+4jEPrV+HIy0rx3D5tln5VTQmY5r8X/ozCTHsu 353330OmyQ12fqvp7DQBOiIx35SJxAcZjnaIjOf4nJp3RmHIpAzGGAR/RjivhKE3cvDYKJ2XBcy2sQ 353331f/cXZF3xDBG4JYUG/+tyb2GGIxu2E67Qqatr3uxGoIE1JkU2pZqlwKev5wfD1EhCGlOSzvlZ 353332zFGMt2eAG7BN8Xvt+OcQEdqUcd7GZ5z2O1C1X0775bRf7u8kIij7W8GXy5hkzwTXfSy2n9iJ 353333Yf6jEHb7Kg6u34pImVrF6p67NdAIDD0dOoJQV58BJpMp+VhgwMksBSyg7utFjLAwRNDuVyj5 353334eAx9zRww/X6TjiuqfonQTmyi9/fAqsspyCmvV6HP1uL7g/Xo7+GNPn09wTN0xfAtd/BBYkdT 353335deD3duXBrOdqXOKnI/NdJl7wb+P4zkN48oMAkIK3ONCVC17/E4g9NRJWDGN0nh+G23HEec2/ 353336i7NHLiGT0tfrviC8Pw/crgfwVtCYqY0F425rcYX/DC+eHEAvI8WscVVZ17B4wGy6FGrTz+TO 353337Fza0jCnQqaFVzKP0vc/iS51sKvNUxIbPhQfR7/ue/oTaZu+tzi4ofLIJPc3EWVH1LPpgC79Q 353338Cf7RaB+Pwf1Cefyj0S76/mAlujj3wvqovCZyLF2SKRH3D02Es3EHLI8rVoppVL8/hZHW+jDq 353339tgMppS3Xv23++7zrI2Gm0woigrAWpXlf8fnzZ+kn61k4Jjkwweu5V2lGhJUebDjMjUOpDPmc 3533407bFCgjlFYfbAJbieVQWh7M/ScaCyqJpCh+WPbelVKvZny0SEytcH0MeEBbthO3Ar+RVexl/B 3533412t7mYFkHY8ZwF3CMAzD/2CM8e/MGKXd2YqSDARyn35Qp90dl3psEO64nlt56gM2BBuD4b1BI 353342GyzFyQruYIQJGwG7XisEP2mCM/1pWXp/DjSGQZf9ZJ0LURw9C/YsVyzhlyopqUj+P2YeHJm2 353343mPqgkGCAH3C4uwEMuh+WS+svd159OYuBVt5YnVJBEySuECeu+7J4pYQaYSkfS10ZMBl8QVxm 353344RhOMS4KvWU16KM16+Ev4VUuY2R+UaQsigvi8UXLGkPNFdh7FWJIxBl35Ltd3afYZDDI3QV9J 353345th0FIkJrsa9/u3xNNi5PJ+eBaS/sSBQHRVHBBkeGW4NtPZzYrxVSDHWzr3y/dNbTtL/Ql9g6 3533466/g/UUkHzqjHBP/JRATq+7SEl6nqsyJ1HTqwTDAkQn69VZfHY6FTU3YE2aYJXiWWS8fR7Qdw 353347+X4ckojck9tHsLi7GdgKcpr1J6p4jfCDp3ArOh4pKUmIvRWGJT3Mlchp2F/VB9w8F4GH/GSk 353348piQg+uoBzOtiqvH7sUxcyZ2vHh+jWiMex/UYh23nH+JpchLiIsMRunqv+P8VcLYb+GuiO7iG 353349neWy+GiCx7VO7iIm2LFg1n0pjkfykUT0x4PTO8DQKBBbZfyecutC1HZEhJoPJzHUgtwnnecj 3533507E4ckpNiELF1ACzJ/TVFgtuI+9SDsasPAsbI42t6poMR/rlW8gxqD1D4GgOWfVfjbJQKfE0q 3533511wIOp6Ec1arfHcfogMFYcewWYhOT8fThBYRO9oGRLhteS6NQIMFCy1K2IMCABYeRobj2JB7R 353352F9aiL/n+ZgOP4b2SUhxUBq3MfX1h5zELsSXN9iD1fhl70Evyfen3izqLlb3ModveChPu5Kst 353353U/urc9rWchrhdPTftIx9V77YDF+eN9amNiUFoImWk22If36blLz5+0QEcpHnvHuDN2+ScWak 353354NaxHnEEyUUjT766GrznZPFEZ5P/I/7/LkTrxTAccx9t8vnIiAjWZr45hjBOLro3aTtcEXVY9 353355RF5tNd7s74fOy2KgTnmiUvtkhk+FG1uHZmyb9NyBpGL1JRrov6t8jnXeHKL08+nMDI2t7tMp 3533569DHk0UpI7IkziM2phpAY4It6zUNcGcXuj8OZY9GtNqJa0ygW/4MpdgTQjZSmDKeidydbseG7 353357ScyWbhq/KqRv8gXbagoeN98orZhXqjUUxmBFBza4gduQppRN3ZRSiGk/DHuSi5sxIVOxuZMl 353358gkLT6To2yp4vqkjDwXWhCI+MQ8rzVPBvh2ERuRj1OH5YzW+KdhBHSLSHLtMQ7uN34VpcClKI 353359AyJ0rAvYbC+ExBQpr51CKfLDzdDedCjtpJBfa8Qg5u9Af2KMNhqT+lZ9sSX2R1M0JDHC93Xh 353360wrDXMSkjjP49cVoe620IHck4y9a1k/tZWIVvqTewf+kw+JjqQ4dhAf9RITh06xm+VakbU/Wk 353361HtkmrPqGZzcPImSkPywYOtA39cGwpftxI/UbqqSKHnEKPlgCLzYLTuOP4kVJUwT7q9AAcIz6 3533624ERWLe20LEk/hbldbcHR0wfPpR9WnjiMwabieasqT8IKYhxT7O4mJVKAD42s4TfiMiEVzyll 353363yhgDz31VH6lLlWchBuq0s++b3rUkmqxt4mhfrxgN09qzSlhwmzZq6Uh6deOrY4XJ0SWqZbhd 353364ceCdQPpuisQUIRoa5Pd506XT8ny2nogg+VumJ1Y8LVGeblCD/S4rU/aZGOMWnliZXEFnXLk0 353365xBIuC/koUXehCYsRt9SNGO3Dcf5LnaICr8FciueIQxxfb6R9S43RuioUvbuPbcTRqMfrQxOE 353366WtdnppI+q1GcFY3dQ6zBMB+K8E9NilPl23OY5WskqaOpByPHQAybF4qItELVEQxqxlnt/ykz 353367YGqolLRsGPY8go+NDNTqV6CAUsPe8mdQYzmcxiw0xY9nEsf1FDwiCrsgcx+CLCVKg6gEMbPs 3533686VRuzZUn6Z2x1Q+sdrqwmXQLeSoyvFB3a9qOzjAgY6NrMwERatJLUq2WgM7jbSml7ijeVqtX 353369jqmxL3kyD05WwxVKKqndFw5iJ53smV7wZCO6GRMH3fRLKjMWter+lextwadwBPMsMe5uodze 3533701ndZgGgZZr+wKArznZmwnnSXjqihsvk8mmkPpu1EXPtWp2RciaN3kjVYSvvRbzofyF6Lme8E 353371jstCRBXJRA9WZWAnAfesxt+W1gxUyXimnjWRPMttCZ7IRMNQZUGorEHyZ1E7sP234rnM3V+V 353372sR3+bALKXP6mMruFeiU4A8VfbmGJHwHse2xCTH5di+ccp/NfeC1ZP5QudHeCFXT07DHzQYH0 3533733KtK3wp/qnTLjXzN350uPWMNptMcOlpSqvcUPMQcJzJ/E8URUZrPs4bzKOmP6b0GSc3SGIvT 353374FsuXHNDkvNF4HoQl4C90BoeA2cnljWulFtkn+4Jn3B9nPlPZzPJxe7Q5jInjgU5HWsbHAhd7 353375DNswFR62o3AzXyjOUDXZGkY9j0qJu9Sae3tkAMw43gh5kIrw0VQUzBxE5ktSUVIk44GmMB10 353376jjg0GvWrdzjQzRBmwy4rzSwlEnxBxBQCvtuMQfjHpn0uzL+BYVSmtL2ZTWWBVI0BTSZlKgVw 353377hLWlyHn7Eq8+5KK8TvH5guJc9Wf4HyIitPUZp+l30H457ZfTfjntl/sTRARaf5nnBKbFCJz7 353378JFD691IcpfA+xsjq7DLOISobYVKIG/QJtvJAXcp+YodPsmWCyWBAX1cHulb9sYjgBQwdXegz 353379yO9tJ4kjy6mI78SdGNCIA+gawK7jIMzYeAb8rzKOXdoxzIHTvFgUC6vxNWo7BtkwYRS4mg54 353380Ed9JJhh+64dye4xgGNOooIYlJ7GqIxvGA89K70F5fZNyhHoSR+80xJSK6HGa78gk+E8Essp+ 353381IuPESFjryowrub/zY7Yi2MYavdbfwfOH5GcLLpynR+ArsRduDjNpGVNoJ+5P6Tg2vvdayt5q 3533821CspXKuWYAX70M2AJ8lkJv/eLeJLlfnIepeNH1UNrcY/qPT+r09PRccuC3HlbRnqJGukOOsd 353383coqrUSsoRfbDNfBjc9HtkGLp1PqCaKzw5RCbaDKufBZobm/I/F5YkoB1/hwxTqmCiCCLBSmM 353384a81HnBlFdCSHqYj4KlCSTbAcKet9wLUciqPphShMP4ZhVlx0WJtCk7pFgq+ImO5M/j8Y2x4+ 353385x531vWBjS36OEUdPiojjaoGTLvScFyGhXBU+oGKMG/EOYQHuTbEBy3m+nE5b//0axlm1R7v2 3533865hh+QQbjIfu3KGounIwCsPO1jM5S9x03pzmA0V4X7dm+WJugArMQViLz+FBYMO0VS3tqiDP9 353387SVnaWUOcr124XHTZ/5bWPYXFjzHbgQGbyYoZFGjsdpot9G3FQWTiCPvu4HICsftNjVJHB5Vp 353388w6TDemK7SIIIro2EFTmrGrNONsk24EfkZNjoE5v0lqyTqAWMS4qfpGmIr/0iZvbHZNQ7V5Tj 353389C0qwFlXPa2Yzi7MCy2KIjdgXwUO2doQhwVxuU9HrzYkIrcW+/uXy9L+rs3BpGrEvzfpgx6Mn 353390ODyCnB1WwxCW0eS8Ffsu5PutzbmOmR4umHAhW7ynJBlQKfuuNRjaP0FWU7xMVZ+ymVrlZCoS 353391sdRFH4ZddiClpKHVeJWqVvdFvZym/UnlsluWowIbW+xPKO6vJvs0+mr6fkYUTqMeH5PicWRO 353392rirF48Q4G53Bo1Cmn8p0bO/IheXYm5J+NMPjWi+3QP65NZnYTzAS85ER+F7/54gIjePCsp8u 353393xWyk+HMAB6bDxM9Xi6+xeBgoKQksxdec55HvI1SNr2mKw2ksV4ioVQtxLquZXtdQhNjlXmBJ 3533947l5RQz5ujrEAy30Z+I1ZhQm2kndzAqyZLljEL21dcLAEW2VKsq/RelL+Qyzzt4Q5l9IPxCWf 353395/+lEBE1wOo0xUeI/3d/FGM4L41Ai0Y3qcy5hmJmRXGD4bxMRmjbLG+wKtEa/s5TiJkTh3XGw 35339691pFR9fKAmg/Hm9ADzN9sgGsYWLihfHrwnAt8TMdES4PEJYg58NbZEuiUgVZpzA8YBa9Qep+ 3533978LFnQkdYG3Jh4tIHSy9lih3d1CK6MwvOHGsMP8RH4smJcGLqwWLQQaSXC2UATBMMu57XDABW 3533987tgXXwpNF22jAS4mIoh+24mssNCVEBWExdGY6WCN0TdlGCp/mIggLE/HocGWBDQYjLDXlYpM 3533993/oyfH6TgYwXKYi7fQwrB9qDbeCDJffyxNHFxKDI2NUVFr5rkShhPmv6fGFJPFZ7s8Dr11Qb 353400TZw2XQfsgFCky5TloC6HHZ044AUrr6NG108zJA62yXflywRQ4EP8VvQ0N0PgvDBEPk1F6tNI 353401hM0LgKlxIFY/LhAfpsTI/3x2OHHwm6PP5rt4W1SJqp/vcG9LMCwZ7dG+BaN7TYARdNtz4NBz 353402GjadiUJmkUClUiAd04wWPm8+q1RABEWZiDq9EVO6k/kgRp9RwBrppUelQzQbckaeUEEfFBxp 353403iY+G/LuY6ciAof98nIhKQtKjE1gQaA59ncZ5K8WT2eSycl8hzbhBOU93EecpJ2gvMiUsMjHr 353404miXnPBXPv0wqqox0pCU9wtl1A2Bj5IH5kZK105ZEBElpkSalTvb5Mp+Xmfha3qBa5nUWCgRC 353405le9WR5z4fY1UkQtUPDMjBVcXuIP5S0QEBux6D4EvTw/GPbbRqT9/l4hQXfcV5wZawj0kET+/ 353406nMNACzcsiy9r8UKr/XIew8xZcF8WRwN0v09EaH5u6hDlqC9W3/4sKaHwK0QExbNYlzKW+AWK 353407pQDqSpAVfwPHQ5dj+mB/OntJO6KYzLqpvAxBmxIRJECFATcIeyXOp8q0DfBRBqBUUpFSTJjR 353408dXQrkba+Ayz7n8PXenFtuRB3a4wgjlmhZC+aDLuKXCUZTxoKo7DYjQEdHR0w3Zcipki1kSNO 353409Y8uU1HdVAwJXv8XRgWYE7J2Ay19qNTPAlNxzrSYilD7BTNv2GgCv4o/xkKvKv2dNDqL2zUZf 353410T0tw9XRk/kZsHNeImiLbKfJiqdwdLI5cYrmFIKmisc4fC/azY1GibP1I/l9VP7oyEVKrPAkQ 353411voCPYjlFuBTJKzzAcV1KP0+tcSx5luM8ecIllZGCP8+hWdQ+Q8F5Kyq6RxvJVORQTauVYCac 353412R83HMCcC9I8Mw4tSoXrHheQdGst0SfWbLX5gmQzF9XwZBTj/OoaaiMv7aPzujfMyJ05x3OeQ 353413O851mXj+WjnPLc6jhFHuskQxFTSVEeHkABPiZOmOhQdv4GlmPqoaRG1GRKBaedJyeHDEhhZN 353414qBG8x6HuhjAdKjEyiM7z6VQf8CzH4y4xIKvSt8DPehAuZDzAdEdnzH1SIj5f3Azhu7mZ/in4 353415jAtjrKGvz4I+xxvLY4tkWNUS4NSoK51yUwz4boQP1w7THyiCDJRhnrS1C3gE1N7Al5R1oUAH 353416AXHGnBoF68ZMaS2NQW02Tvc3JvM5B1feFJF7jtzj9YVIOjobQZaMpvqcZr4YuTYc/KyfqCj9 353417hudXN2Bgp2n/PCLCL5xx2u9A1X457ZfTfrn/KxGBduSzYD3lER1MopSIoIFzSGMiggy2Ulf+ 353418CmGDzNGe5YsNCT9RqyTytaHiExKuHsbGBePQx8scDJ12aG/cHVsSxAEWFCFvroM+rMbdoGti 353419U/2XP9sCf7YBeh3LEmdt9GGD6zUJOyP4yMyvlNdjG8tNzN1OHMos+Gx6IXd3yhERVnmCaT1V 353420TEQQVuHduVnoSGwsprEbhi5bgW68pnFNOzoO7g59sSEyHQlHxsGJxYTT5PP4KCGolX56ox5P 353421eHqEOATE/SnDo6TvLUtEaAwi4Dhh4Job+FgpVHjvVt91CviHxD7mBePIU3n8Q+k6IWskMcQb 353422bGmWAgYse67Fozx5Z4OwMhNHh1hA3zAIWxKLNc4kqOz3dUXPcHHLbIzo6QVjPWVEhKa/aQ6K 353423x60lTkxeV2xPETvlQ7p7ws3eEmbmNnDuFiJ513e4EtIXLjwGGEZO6L34PF6X1kvfWVj9Eecn 353424O4LJcsb4IwlIj9yAvg7uGH/0BU2CmGDRDizfzUrLBjTqoQ7TryIjKwtZsp/sbyipJXNKZ16l 353425bJcn8jotlUF2tBnaGfbEwZQvyMnJkX6+vjhO1pMxBkfkypM/ci5gAK89DVIXKCt50FCMlD0D 353426YanPgffiSOQ2I+loijP9UVlqja/zBpPTRarDUnrq4zkO0DMZjPNf5ddaQ/4tjLPUh+20h9IM 353427moL3h9Gdy4Lf1nSF/S8sS8ByDyM5vZrqY6yVKQaEf5bPElv3BWcHmUDPfqa0TKhGGJeKYBrV 353428Z/gvYmZ/TKaNiAj0eaPkjCHnS1m9LBFBXB5aNlCmse+GggeY7WQIn3XJKBNqPxGhkYxwYQpV 353429vppgbJZDcKhZtlYxMZwtxZCEpSkI7emAblsSpaVElQUS/duICC3hZar6lMv+KicjwKcrM+DG 3534301oWB93ScePZTGjCpCV4lts9zwT+6FMM7u8KSxwGLyiTF0EP7ZnIa91dfjBcX12JMoAOM9FXL 353431Uf093j8X/byt1PYnLHuFS6uGw9/WkPgc2qntT/n76bWIj0lxn1mq8LgmnE0eI6tAykrSj8sS 353432JJZrjsf9vlw5nm/0Bcd+Dvhlf5CIoOquF5UjfqETWBJCY2vxtcaMTirxNU1xOI3lUnHgr3il 353433cyt4fwjd6CzIX4hcIpa4ECx0vvw8C8l9O8KU03LwanNyLP1+TNhJ1pWw4hUOD/bC4INP8YAi 353434thCcMLniX0BE0ACn0xgTpbDEM/1gajsF9wrERMyPR3uBZzYMl2TKT/8WEUHWaBF8vYhB1n7Y 353435nFZOb7CkFZ6wGxeJ/DpFg6++9CPizq5AVxsHdOrkBANd4lQbEYaMcuWRPaK6HERMCsD4S19R 35343625CP25NswPVegejvxcg8PQJWhh3p1GOiaiqa1ACWY6+LDUVhDT5dmwcvDgO2o08hkxhLZQkh 353437cDfvi1PZtUqICIrGYSMzj7oQ28qIUss4VUJUUBYpqq40Q/yCpkX/K/NKbaCjI2zANOmF0KRi 353438zdKTCz7gaF8e2P7bkEGMHsHHY+hn4YRp17NQXFaGMurz9SbZ4Cz4bkhEfnklBCrqFzYe+Eyb 3534396YgtbYpGWO7OlXNKSGWJ8cuynYEnpYoKwqvQTmDrU4C1PAObYpntCeLCZPA5Ouqvaa19xfnB 353440puDK1DUR1ReAv2c03A0k4C9xytsPXotdU11h2GED0ipVj8+2PlZgtteHme9wLN1/HSk5lSrH 353441szXsK+V/34CKr8m4tncJhnYwhX57Jqz6bJNGh4wzF9d4lnMclMZiug0DLksTybhS6fiHwZRF 3534429vGLSqkMlV7Fj9W4bsR1CtlWkxEtIbrQ6eSZbHTanoKCxrkuywd/lRdtsEnTyas6CMmevjWW 353443KBSBu/GmRtS2pRmoFF8cHgZd/t56x7wyJaUxrV2zdxMS50jWa83JBa1RdlVfKGn4HLUanQz1 353444YBa8Gyklwt8jIlDpti8PhZXrXITvCYaFJGq2pQuN2oPPt/iDY9QTh94WI0P2O1Vqnt5tyNXc 353445ZsboS7x8lYkPX4nzSJZEpHHKOGPSZ56CgZv+PAH3ji1AJ6KIuy+4i/x69XdcdfZVzHZhgN0p 353446FK+qW0lEKInCRAuWgsNO6lSlan5aTpTuJZod/uk0+vHYdPR4NTnPk5aT9USlifxer+Coi5pm 353447C4bTAvALs3CspwU6hb6SRJ8VIHKcDZyIw7kw6zh6GYgjgwQKzr6fiA3xBNtsIA7c3o0+xmx4 353448r+RLDcJfIrcIy5EW2g1GTFfMu5cvV7tL7TnQmPlnojxQ1SoigrAS785OhCOTBddpZ5DyvhnA 3534491uzzKbdCyfuX4OlKAmhyPTFxx3nc46cgLZ3sbX4Y+vIU94GCM1Y6r5PoeZXWelUCPDVGwU+0 353450VN0PUwbYmGSpo1oZltSOVUtEoPvQ4Fl/RAluD7apMZhMJ8y8nqO4FjUBmVR8r0bCmboICoX+ 353451WxiLpvnTcJ41nUdphpYMpXuorjAFZ0KGwdeSygqmQ3Sbbph9JAmF9aI2ISKIHSZcOMyOpvc5 353452nYqNa4ExN/Kkukn1yx3oaEj0pvgiZB3rCauuB/CuMhcRw2zgsz4NRa93IsDQCQv4pc3ONAmj 353453vH07cLvskwK70nkqjUeIuyEBt56hgpxfTxZQ2RmWI1EhM5oA2RcnwI5tJ42SkdOXdc0RvDMZ 353454xQ0ijc4mwZcbWOBjII5epIxGsiendh6BHZGvUFBdh6r8V3hwJATDvAmwK6l/beAxBrtivv/z 353455iAi/cMZpvwNV++W0X0775f6vRIRm961SIkIjjkI7x2WcUjLOIaWlGbjuWPi4WQR1SyCimrKZ 353456IuJU+ha1AV2MyD3QQ5xGnTp3X4cNgSXDGEEhV/G2QiiOJjQyojMC0MSEN5exYpA7eHoUTsCA 353457hd8obLj2VhwoQ5P+ueAFzcIoAoBaTVBRg55K/d5PpjSD0u/RNK5L3c0QtIWPouJELKWyWnE6 353458YktKqdooSFXzpAyPkr43nSGpsTRDMA5HnsGMDr5NAQTN3vu37z41Dh6lQRsUQYFgGNWFn/Hu 353459TSaycstQ1zxCvT4fD5d6EUzIFuPPZyst6dlaUF/+/1SXZpCNes8KHwMbtj0mX/mssqyoyjXc 353460LAV4afJmdOS0gz5xaCQWF4K/OQhm7kslZFF96NrPVsDGmvpWX5pBtY5cjoRFzhJdSdnHAD2P 353461ZSklPjgvSlAk4FJOtvOjYU3trdUPkaskqEhTnOlPylLZD+Y56oHdcRtSChplS/HlzhTY6hIb 353462++C7Jl2V6MLfrgyHma4Vxl3LRklj3wXPEBrIAcNrTbNAPSF+3CX9cDpgTXy+pG/yKcnC5ZEW 353463BB/bJc0M14hxdOHqw2VxHH7WSbBBSSYZtfa5hGRhQfD5wt/E1/7fMr9DRGjpjGka57/QmUMR 353464a74rwb6InXJ6EMxMg3H0Q6k8EaG12Ne/XL7Jf/Aax0baEEdye+iZ9paWaWiOodL4bs1nXJ7s 353465CrepEfgiECn0S5dWbcTQNqnA0DY1YWh/XLYVOJ6md4by7K99ceSjQKmTsOzNFYT0MIc+2wNz 353466CI4ixavYLhi1KRx341TgVcJSJK71A9fID7MO3ETc89d495HYiM9Pob+xfNZEjfAvOuNDFxgZ 353467tiRXgvhVHcAxaEmuEFFz3WDddR72XrqPuOTnSM9Q3p/q92vXIj6mCR5H4Ww6uvpgSMt+UR9x 353468Zq125uPE/WiIx7WZnOlIRBYK/xwRoUU8bKIcHtZm+FqbyyVgb/gb5YGptD9Xkm1EFV5Xxsds 353469ezbxNaa0KjhY3B8bfltIf3V5uLuwIzoteUD8C+LgKXYzPPGfSkTQBKfTFBOl/f251zDK0gLD 353470r3xDPZ3d2QC2U+/JYfztfhsk05AtomBISI3QWuTeWwg3JrnMLuUoda7m35uLwKHH6VTVVP3a 353471WXYsqUNazFYUO1nEZAKOfN1YEen/wQoEGLHgNHEXdo5wgOuchyhsHmVGl2Zgw36OPDumVqY0 353472Q1sZUWoNquZEBRW1s6nU6ecH8GDY55RcJgBR7Sec6mMI3oDzLdbaVk5CeI3jo2zB5HXBxrhC 353473BSeS6u9bibQNHcAiDmoqE0N5/EI46apZE+xOCH1V3QIRYVoTEYFKFT/Ikj4cKpSw1Fi2MxWJ 353474COXJWOlJgArfTQpkgUa2p8/GF802UiVebPShv0dzpUJYU4Qv798SA7ccdXU5uDjIlGyoh2qd 3534755VRdwOK30TizaSp6OHDQXtcALn1mYtvZWLwvrv3l/SRrvNQWv0NM+FbM6O0Mg/btwXHogamb 353476ziCaOIVrG8sdVLzAnukTsOKqvOErPtwlh6ckLRzbdBTuFjXPCtK4bsTsOLbHSnGdQtpR6kGz 353477X1WnfBSTH1RfilV4scmn6SIhB1/sXEewnOYjplj4y4YSnXL6VDB4HCpNYHXbEBGod5tH3s1x 353478Lh4rebc/wbpVf6FQ5+cy+HDFmV9eyKT6/pXv25B7FSOsuDDhcuG9RnzGanKhNeRHYpo9E3ZT 353479r+DhZtn0kuK5ZNrPxKMiZeMlwMcjvWBo0B2H3ws0dHSX4Mk8DfrkdsPBdwIVhmkdvt+YDDuO 353480G5bGFasF7agz4dlaAkooORNaXIOSKDDbGTEKDE26ZMIMW7Ake6npbP+Gy8NMweqwHqnf4rCQ 353481TnWkJO2jpE67Mbsjtj66iFHWzsQxWNa09k/2hoX/Fjy6PAbmTE+sSq1QIFkU81fCmxh8/cLe 353482oUZYhVd7e8CI44v1SaW/VO6DzjTDXw0fDge+a5QTGlSfAwSIiRwPG3txGstfISKI10cVPl6Y 353483CmfyvXpse4qfDa0DRUV0LT6iLyyUZ3vWZp1Ab8Pm+0A9KzRZwuQVM41/PyPCcncOnKZfQrIK 353484ZbgRrG8pI4KDRhkR2l4J9t/4ELdWBcDIwBuLbsuTEf52IoKmjO1WzLPmGRE0IPoSZ0jhuyc4 353485vaQzjAlwPvVegWqgTQVQIsy7hiHGSsYwtBO4NlNwv6CCLsvCtZlMM5ab9kACFrsYwn/LA5wb 353486bkPugmeopFLYhvWAVfd9eHiU3KsWY3Dnh/z5W/ftBqY5sIkDJpAAquYYdOy9XJ3fxlJQRuRu 353487j8q8ifFWBgiQkKdkz5Cf/A1EZ+ehi0yUTKO+/Ck9DhdCAsDjdcNfMjqkaqLjD9yf7UTWTC+s 353488vRSL1FfEaKwrR35prdIxL/mWhQ+fC1DdIGr5fP8/EBF+5YzTfgeq9stpv5z2y/1/MyJQqYWJ 353489XrXgKa17qPt79XaTED8fTYG1vgPmxpZoiK20HPmqeBf8wJ2RptCRYBri39UgJ/ovjPM0Ate5 353490L0Z2d4HX2EN41owEXl+eg4yos9g00gVspjtC4kvF2c7CesKQ5YjevYkNzXLFlKNP8am4GjUV 353491+chMTkWuQIiKZ1uJY9kIvcLExGHlYOgrfMivpnX0mq+RWNnVBm5jDiDm2U2s7GJMbBX5dNga 353492ExGU4FHS92b7YWNKPtKl+lc98iNnwtVpIq7mCBTe+08SEX6pP+I4eXVoAMz0DNBpPV+OxKhs 353493PJo7KoQFd+hAmt8hIoh1m3XoRDDFoC1J0nS1mgc4Na1bmviSHoahVkwYd1mJm89icGCMG2y6 353494rsLdrzU0Gf3uJGu0Z7hjGb9EReaHFogIxBZa5MxSIA+IRD/xaKIldIhz5PYPYSvwYhVEhIpU 353495rPJkwWrsVWn6aflxawXO9MdkG5B3Yyws26vG5pg+G6VYI03MGWCsGsfTF2eclCUgnR1oIlPq 353496o7k8OUcSyiT1sgnuucYbTDVlVlTjJxJMxnaqnM6v/UQEkVIs6d2h7jDgiDNUKutbWPEcWzoa 353497wn5qBGJ2yRARGse5JZyqEfv6h8mLhK2Tp5qw4g1OjLYF23oYDic9x7kpTqDKNOyUKdtMBb9E 353498zbAj/Y7ChgVBcOgVilSZ7IjSfg17IoxyxkswNJupUSiW9NEkW4yoqdZSDO1Py7YGx6P/T8l6 353499kf+/FrK/qvh7IZVxtB+55z1WSPAqJhxmP5azles+UyTJpr+lbHrxWf5U3seVRQUqycppiH+V 353500iyPKW5bTsD/iAJ7n2x+nPslnlRF8PIIeGr+ffov4mBSPmxWjMiMChbM5z7mJl8rI/Z/zUdkg 3535010hiPa0u50j9ZmoF+PsGvVGUccF8u3gsaPqu1GRHaTu4ZDu5JkJORrqX3h+UyIixVlhGB+JRH 353502SjIitKaJ1xUbLosfgb9vALyHHaWD3xXej8bq2Ir6Je3Llhk/DTG9tu6vcX2ow+nEc90yJio+ 3535037wvxcLo9TPueQDp/FTwNXLH0qbx/4feICFIlOZlOxWM16Aj46RlIu78ZgWYdEHIrVaXBJ2uE 353504NuRdJQPBoWtuNW/CYj6WB/XFnldV4r+jiQgMOC8WZwKo/3YJA3mSlLwUc7srF9zOoUirkL3Y 3535056lEYtxFdjHSI4jwY574or9NM1cU16nVcWvOWamVPiUPdwBeb06taNzZtZERRmQ+We1hIavCJ 3535065C7rrGN9YGTUC2HvBTIbLQy9CIDb90SWQk1zdZeiWInIxMkxREEwDMDq6B8akxDovqmMCL2N 353507wJFEtTeUZSEtKRGJiTKfR/vIuzHgOuscYlNeIqdSqLQvas5XejFh2Pu4TP1hKsXHANgGbJcr 353508zSCsSMM2qt5i/3B8ls1sQIEV0XPgoEfWxoG3itGXVS+wyYcN08Hnm2VE+IJzg0zAVpHOrrHv 353509irRQBJl6IISvvNadqv2S/fQSQuf0g6uhLnSY1ggcuwphd1+jmLqIWsO+qi/G67thWDk2gE4d 353510r2voin5zQ3HpabZacEXhnarSsdnXkBijycQYrcOX8GAYcYli+UFmTX0Qp5Kj1k0VUbo3+hjA 353511aX4srfRQtcXnO+nDsOtW3IlvNt9Pb2JdABdM77U081vlBdaQh+ujLcDyWoNnksOrMj0UnQ0M 353512Ebg5QQEwoNZ+TlIMsqvU9ElFsn88jwnkrDAdfIYuO9HS+tdkj1Ct6uUudDE0gP+aWGmUqqp9 353513r1YRbRMigkg8Hrfmw5OtD+sRR/Facvb9yvdtrJukw/TBxrRKjZUe6h3eHepJnNiuGDTAWRr9 3535142ziXgVwu/NbEoajZXAo+XcQEW2IMTLwuU39K/TvTfWbsRJCBuj6J835sBHLq1Iyr4COO9uHB 353515uM9RMcmtvgI/igUK+5lanzfGWoKtIvuJ2jlurLvlJF8niz67CqMwlyjU9jOj5MhMNPnu9jhY 353516EaBy0toRsGM6KNTLbGw1mXvQmYB/HScGw85qJG7IpKuverERPhb+mNjPDgybqXj0s9nzSxKx 353517zpcDXq+DyKxuNKrTERpkAG7AVjxTkqGopfmpz4vEHGcmjLrvwosKYav3WEPeDYyydsSsx03k 353518ELX7QomTTjzu1ciKWIG5B5JVAo4qz8TSJ5hB1o/LknipgkqRpV7v7QaDds33gbgm3WOZsRXX 353519yWLR5YDommCU4T3bAUy7ybiRW69U94gkgCFLaT/6TWVehFQNOWfwAkORrmJsW9I/GuuYsdyW 3535204IkMkYo6xxe76jcrKdP6s0gjubp8RK0JBM/ACwtu5ais8a/8nGlDIkJjTbfmdc7Ivpzn1ET+ 3535210XyeNZxHDc84eYOiyTBSRqKkiLTrO7BgPvoGXW+wUe/NvTERNrqKz6IzBRlaYuz5O1jlzZFm 353522R2haJ4W4N8ESRt7D0MXaCbNiisXnLjlTfK38MSLABLy+p+V1LkE2zo6yAsdtAR7kFSFhvT8M 353523eD2xJ6NC7uyiMr70NzWF/wBvGBkH42Sz7GQ1H8MxxoYNhynyUTJy54xE7+8uU2dO5bwTgGOO 353524PZMAF/IAjMbngbrz/f9ERGjtGafpd9B+Oe2X03457Zf7I0SERt3DfRniiO7xq0QE8Z14F1Ns 353525GbCZcF3BcSko+oJCgUhjPIayFeuVEWbrv+JcfyPoe6xQcDAIa74Rp9NQ2BnYYeTRN3TGA6V3 353526N10yygA9yD1F/7ssBVs7G4JpFYQhgwNhzdSRphQ27rIB/FfXMc+DA6Mu25FaJtT4nqAcQGdn 353527eMLUewUSc8U/81wX06l0W8ZuchF/6xoevS5W3b/kvdmu47Bymh9MHaaKgwaobKUT3eDUcywG 353528ubT+vf+uRhHPcyMXwJ2pB+vR4fhYI2rhrtSB5bjbMrqUEKUJIfBgsOC/PUOFU4lar+qJCDVZ 353529ZzGW6DZ2Ey7i029mjaDJoq48eM44ize5iVjhbSr+udH+p3CqFwSnMmgPrv8KPMxVFvjSAhGh 3535304TuujjAjeNgmPJfZA5S9sNCF6LS6tph8J1+zrKn081QQEUpjMY3KzLlIHthuqPiBH5UNrcKZ 353531/pSsqPYTTvfjEYfjAlyMayZLPlFhwwkW54yFT8S2qyDrKHoRx5jDxFN43Ew2PjIUPXn6cJwX 353532I9W76cxkHEN03XIH8c3kE2PPYqYLGzZTxCVmhT+jMNtBn2AXe/A4XXmZFbX4CYWvEUzPY2Ek 353533vtWKFPTK7Jh7eF/ZdpjZn5JRaiO2wm5s6V4oTz+EgeYMWI25rBJLolNZ358NR0MXDBrqBvYv 353534Yl//dnmq5M0p4j9gWw3F4XQxCY4qHXOBJiMEY1dKsbS8XlniKngx26G95UhcaFa6s7Ff+6l3 353535kEdnthZjaEy7qbidV98Mb7qNKXZMKYb2p2Vbg+NpRkRoIfurSny7AqmrPcGymS7Bq1hyQZrU 353536fff1/BCY6sjsFVqOnLGLm+NaXeVxLU3xL3Jm0/21KNeK/rwH4KxMeRuRsAwpm/zB1ri/duB0 3535373oWMStU6iBSPsxmPiBxlvkAxzmbUabucH1GVXEt4XFvL/TEiAlnjUbPIGneeh0eFTdnXGwoe 353538Yg5Z3w6zJHuhtfias/yeEfcng69pisNpLFeIqNVLcemToJkuU4y4Vd5gcTpj95sasa+D4Pos 353539jxA8LRE2Ye+3JsGGKvv5tKxVfl2K+Hlvii0YXHNYdVyOqB/18u83UfJ+NFZH3eXiEnWNd03x 353540k0Vw0ZcZPw0xvbbuTxOcTlNMVKo7P10KV54L+nS2hIHfFgXfqorSDFEYb8lFQKhmQKk4zb0t 353541Bl7IIc5rKqpxHOw7yKedEgOoBOwePgu7Ivh49fIGZnSdgvOxkdgzwRVsbidsS69sNrHleLal 353542B7pvSkFZ45eqJ06h8VZgWA/BzluPcG6xHwzY4lTy1CIqil0Ff64+zLvNx4Frj5GYkoTY2yex 353543fowXjI0sYcE1RIel95HXvP4YFV16YTBMLUbjVr6wadHt6Agj9+UKZQ5+h4ggu2FbGv+KZ2vh 353544bd4bx7NqlTjs47Dcmwtex3k4ev8pnt47inkdeeD6rAJf4mQQ1f7As6hIREaSz+XNBHwmyu/E 353545Q7hO/TvqGX40OvoFn3Bhoj30dc3Rb/tdpKSlIU36ScfbvCqImbjlSAldiFUHL+FeXBJSUxMR 353546c+s4Vg91Apvpgtl3cpXWUVepIJalYs+Gfbj8gI9kaq5uHMT8LqbQY3liaXShnIEjLE3GxkBz 353547uI7ZgYiYJCQ+voJto5zB5vhgFV8+qplyHlKHjK7xQJxVRjwR1eD90QEw1TdG4LzDuM1PQQr/ 353548Ng7NDYCxvhkGHZcBuImCdTHsLO7GJSMlKRY3Di9GT0sefEKi8EPKUGuas5bml/4ulTlIub4P 353549S4Z1gKn1uFaTVahnjLM2RYdhS7DveopKUkdLe5qKLo+b7wTT4HB8IXuiNvsUBpoQBWzcMaTk 353550VaAiPxXHxztAnygCPitvIGJ1EMwcJuLyF/EhX/hgGmz1zDEy4rtiCnaK2HBuEEwYrlhKRYTQ 35355148KA+7wrSJSsrdSn93FmVT9YMXjote91k2NFWIm3p8fDgWUIr9EbcPJOLNnLCXh86yQ2TeoI 353552E6txMk4dmT6fJYP/MAJH1o+Hv4k+uN7zcf2rbGkI+edLPy9e4VNZvWbGkLAK789OgSuHA8cB 353553S3Hg8gPwk1ORkhiDO+HbMMnHEPr2sxFX1sZEhB3qHHQ1+BQxA65MBuzGncG7KqEUaJDud9nP 353554fT7elza0mfHXSCBa5s5QTB8prMCb46OJQ53M5bgtOEuenZwYi1tHQtCPKNCG5NJ+mF+nsTHa 353555uD4yT42FPUt5n1yvBbj9rbYFZUyIggczYc92xryoIlpuvJML+s3dgVM3oxGfkoKE6KvYPzeI 353556rGEzheheTQ3o6nfHMMSCCfMeixB2MxZJ1Dl3MwyLepiDaTEEx94pZoYRFj3EdDtdtNOhUm4u 353557Ab9UqJKoRqXfpOQMuofhg2w9y+IYzCR9UBEWvAEX5DPq0Ap+R3CNuuOvl5XyxnfqFnQi92SX 353558nekKAKva9Vz7BRfH2tBn94JL8fL7q/HzMlt9H/XfETHMEs4L4qRs5V8hIvwewTIPtybaQN+o 353559ExaefIgEsq8jto+Gt6M7zBnN94EujOwc4T5oHc5HJSAh6izW9CP6Ca8H/pJxwAo+XcB4Ytga 353560dpiMnVeiab3kyZ3T2Lp8txgwTN+NHkYMWA+Q6WeAC+xsDKWR9LRymHMdM12NYBscgiM3Y5CU 353561StZozB2c278G0yasR0JZS8AL9axd6GbEhO3gTbgYTUCu6IvYONQTzg486DWmnfuTRATq3/U/ 3535628HhdEE1GmH/zqzjy7+8mIjSOO48ATf3W4pxk3FcHW4Jh3At7yb4QtmKeVc+jGxzsjDTKiCAq 353563eYIlQydibVgEHj0lOsnTezi2MAA8tidWJJRK9O032B3IgWHgOtxITpdELVbg+SY/ooM5Ydxf 353564t8l9xEfk0UXo7ekOM4YyElYWjvYyAtvCAcZsqnSVPEOZBjLO9QePTgk4HNfyGqRE4HmO5Fxq 353565x5aWgWkEAjLD+sOU64PVEl2MIjXt6s6DYcBmJMtGvFDl1SZYo3279rAccx25suUVqtKxPZAL 353566hv04HIl5pnB2qLoTWzwnzJQ7EP7NRIQ/8R20X0775bRfTvvl/ggRgbofM/agpzELjmP2Iybt 353567Dub0JkBWzmck37mJlEJif9WXIvslOeufHEZfnhJbTXIHUPbOx1PDYck0Q88115GRX4Xa6iK8 353568e7QXY4MmKGTqUY/HRGN2n9FYf/oR0r8Wo6a+DlUFb/Fo9wjYMrgI3JamlGggBo6diCNjFm3r 3535691X17gL9CzyDqZQ5KBfWoq/iOpLBRsOW4YdnTphJGgm/3sKqLMfR5fhi3Ygf2h53AmbPncGzr 353570FHQ0YcCk21oFp7FmemsREsNPExBbJPdzWzXZ9560JRyRBP9JiruL8G2/995N7y+Z+7QWPjJ6 353571gKatIn0v+pq2h57dOJxMfq+8jFFjpKMEZG3PccKoHRGITUrGk2u7MMHDEExdXVgOOYCot8Wt 353572JiKIKtOxI8gATKcpCE99r/DsVo8X0a9OhyeiiI6mbPq5edDG1zsh6GysC33zIEzdfBK3YlPx 353573MvMDstLOYKCxHhymX0WGwnhkI6dYgKaseUYIXHETb8nvqgvScW62BzgGzujiYwqmZX9svv0S 353574+RW1qBeU4turGJzfS8Yot05zIkJ9Pu5MsYM+xwMTdpzHnXs3Eb5rPvp69aYj0VuDM/0pWTFR 353575QL5WuTyxX5K9cMIdGujP3NcFHKY31qYqKf8nwSf1bafhAXHSUPZ4wnIPMM2GI+KbErI60a+p 353576kpcck4EI/1yH71dHwYLhiLlRysrRqMe45PA1ghdZdpmOzUcv41bkLUSc2o2lQ91haC2bRloT 353577zOzvlPkDRAReXxx+In7W81SCM94Ox65FA+DMoQhiaxDVAj5F2VOnBppKS7/9Cvb1b5dP3eAL 353578A6shOJReJrcmG8kIXKc5xMEpFDumUrahs5Ee2rfnwG3kBpy5K9svG7ygdYgpqJfH0Mz1YeQz 353579AZtPXsPdB3dx7eRmTPAxIueaPIb2R2VbieO1TETQFHtNwZvI4zhNMB8KO3p8aQP6WzFhM/Gm 353580FK9i2Y/HqfSfqK0rR3bUDgxyMgNb1mFZn4sbxO5uEdfSFP8i/V0fZwU9Obkx8PPygw3zV/uz 353581h/3ADTQulcyPxLGlveDs4gvrZv3dVNKfi7ErJmxZhX6WHNgNWInjt58gmeBjT6Ou4cT2BZix 353582LUV674jxOAY4bqOxOfwe4hITEBsZjh0r/5LB2Qxh3Wcpwm7I4Gz7VmPquDWIL20dHve7cucP 353583rMV0WXzvDxARaDLch5MYRta4Zd9VCKfxq3Cs6mNB7vjhOP2xRiOcRRm+Ztl3Jc4QHx///mks 353584721BcDMZfE1THE5DOfFePY7RnYdh9Yk7iEtOQfyjS9g51R88sh+8lkahoEFCiErZggADFpzG 3535857MSNOHLuX1xP1g8TZgOP4b0Ssipld2Tu6ws7j1mILVEkrv2InAjr9nqw6LsW5ylsNeoc1gRb 353586NfseYqyOw+uKDQ+yUFxRjM/xxzDDzxoc2f2qIab3+/25KccI1eF0rcC+xbpvGjb5MumSXT0O 353587K2ZMa/erzETZVpt9Ar1teojT6FDG2WwXuC9SjD4SCb4j6uASjOziCnOO2EGiyzKFS/ep2PVI 353588sWZw1et9CA4KQWyzSM7avGjsGOkNUyZxNNp1w/zw1ygXNjE8itMvY+OEbnA1Y0NPlwkjG2/0 353589nbETkR+K8eXqVKJ8GaHLRr7C92jIu4nxNtbSWrmiqgxs72hC1/CpErUdEUHMkjdC31PZLRrw 353590VL0Ns2YOJtmFX/PlIUIndoYdcSwwjezRedJOROXUNIsmbblkhlq5dvLR19lX12FcL2/Y8ljQ 353591JZuOY+aMziNDcJz/HQKhqFVgqKjqDY7O6gtfe2OwdHWgy7aAZ/BcHIz9pjS9nyCPj0OzesLF 353592hAV9lglce83CgSe5CrJUWqIBxPiyGn9Lyv5RNAaKkX5+NUYGEDCepUccaMZwCByFNRfTUSK7 3535936Spf4dCkznA2ZUFP3wBWHQZhyclkKYmj+XdraX6bz6GguAAV9a1cX/UVKFASvf0rQHRl+g4E 3535942gTjRFYtPb+fbyxBoLGueO4Z1hiwfB16GVOp4czgO24H7n+qlj5XbExNxX0VKd6oPTXWkgGH 353595OY+VrrH2TB7sOg5DyJlUpUb0j5RzWDehO9wsDMDQI448mw4Inr4Vl5/9oDN+KPSpow+OqSP8 353596gidj9bFoZMlmRlG3xnWsMDm6RHNHODFSizOuYcesAfCzNwFbXw8MQ0u4BQ3H/J0ReJYvkHFi 353597/R4RQVwaQxwRqy5dF8Vk/3h+EhwZTDhNuaj++7L8sS2jqk2JCLTz6sJwmLdXLMdDpbzOjT+J 353598kJGBcDRhQ59hAEuP3pi2/QbelDb80t1D9ZmXeBorRgfByZSc9Tri1Ga87qFIKKrXzBggZ3xo 353599J+LU636AONJzEXt8HWYMCoQLtd4I6MQ0tIZXn2nYfiMTZQ2/xuSnFaj3t7FjWm94WHChr0vu 353600LQsP9J4WitvvK5TuYZogtJCqwcmA1+oU1RErkshlHSLnuTpVvmwNVeJhsDHtNGxcO1Jg7vk2 353601BBoYICj0hSLZQFiKpHW+4Bj1wL7XVa00rFouK6N+T9Qj5/xAWLgtVal0/2kiAs2IL4jH/imB 353602sOGSe4FtDo8BIbgcfxWjlewD/01RiDo0HV2JI59JDHb7rjNwKP5HswxGQlR9eoDd03vC1ZRJ 353603DHAGUeL8MGjpeene+fH0EGZ0tYchg0HOuY4Yu+MW7m3wV9Ahan8k4fSKkQh0NAFLT5ecO1Zw 3536047zoSC/c+QI5ApEGkRy3y+QcwnXoWkwmeY3fMCovC/RVe4DgtQHx5GxIR1JGn6gsQu6ELjLme 353605mHf9y99ORGhcbz9TT2PpQG9YchlgcC3RYdAynHleLAUmWzfPMvNIja1DV0w/RP5uk79mWXJq 353606PuLS6nHo3cEWRsz2aM/gwTFoPLbeyUKlsCnaIf/xVgzzNAOzfVOpJmHFW1xZ3h9ulG7EsYDX 353607oJWISLgmt2blQNbwATAme5LhuVIp0VZcG7UdDHoebcpMJcynM4fp6BFwNrG86Tx5sRPdeEYI 3536082vFMqovTBuHbIxhgxoH38lh5AljkGJjrEyD1cTE0ruttNlb9XLbSGNd+IoL2O1C1X0775bRf 3536097u8hIkjv22dnsGywD6wM9MWOGx0CfHYNwYP8+pZ1SNk7gDjv3lxegf7OBgQsE+v+bLuemH88 353610GYV1rciIUP0O4UsGo6OdAXRlUyRbBWLyX4/xXdCUlTGPfxEX7j/H5+IqVOYn4q9exnQJNSpT 353611Wn3efYT0sIeBblMfDMsgzD75Qg5PEDtnchB3fDlGd3GBGa13mMO16xisOMFHTvU/L6PA3/He 353612GtkPzdaApo3C0ZgalpBtXLcdFh7A5rE+MGczYGDfHQvCCXC7MhAmXAeMDs9uNRFBrKO23XfS 353613HIskGNOPNFzfG4LxffzgZE5s2/YtjXNTIA0VeJF1czX6UaVF6f8jALTHCOyI+o7qsje4smoQ 3536143IhTsfFvdZjm6DBiG+IKGjQmItBYUXEaTi/qC1djJvQILmQfMAIhx8m6qhG2Cmf6U7Ipq70I 353615xhqMU9m1Ksa5AqlrvcGiyAJf6rCjIwvsgF14XaMcE/gZNQv2+lYYfzu/KcOLTCShAvb5/jC6 353616G3DQmdjyVPZZdscdyKhqhQ0uwbjU4WtGtr4YOHc3bmeWijFwjTGzv1PmDxARZJ6lo8eGsa0X 353617uo9cgNArKcgTCDVw7BGM5/kW+LN/Hfv6t8vXF2ciNUt5OSDq3kjLyBdjthXPsTnIB3NuvMPb 353618hwewYLAf7b/QIza1tXcwZu2KxLty4S9jaP8E2T9BREgPn45AeyOCSxKfi4Un+i86idTiegW8 353619SpdpDMcu03DgzjmMaNa/JrhWa+Tq8mOxc4wvzFn6YBk7odv0A4jLjMSY3+lvrC8s2Ppg8hzR 353620ZcoexLxW0l9REsJmdYcjj0mwDnO4B89DGD+P+IGEqP76GAcXDISPjRGYetQcuaHrqCU49DhX 353621miW8JTxOU5zt/yX3p4gIdCDamwisHeEHawOi3xlYw3/kOlzNLNcsQ+0v4Gt/Ro58j7c3sHlC 353622FzgRPEyPQfntBmDhkafIl/XbUTr9k/2Y3t0JxsSfzDYn+2rJGaQVN7Raz6r7fguzfTph7uHD 353623WD7MF1ZcfeireL8mrI4694zh1H0mwu6ex0iFsj+aYXq/1B/bjOzD5Ur3oWY4nWaYaKNuRJfb 353624Nx2Ci0qykLT7fxk0fxrA+6V3EhJFcqMfLHuLHf/FTxbD3W4kLikZuN9ppfwFcLEfj5t5LS/2 3536250E5mNLjeFjX3tL/9Pa018/vPWPclSN7SHV7jzyGrRihRHAvw6d0HmhUvbKjAt+yvKKxq0P7J 353626/T80wftD6MY1wdCIXI1SIGprE9Xl4u5i4kzleGPpg3yVmVm0v/2f56lRidmWjor6BgiFzUlk 353627ZxBMFMKVKcS4a2hAfeF9BUNE+1sbz0n1G+zrYgCTwRflMmf8MmBN1x2jyiK9+9frLr/tyG7j 353628Wsf/+rVG1YybaQ8uceA8+8WITare3QQLcXmKypYMZJrIx0bArtdKI9lad17Vo172UxyHhf8w 353629O+Z3voP2y2m/nPbLab9ca+V+FQNa1HMm7ubWakyoV36f1KL8Rw5ycotRI/yNfkQNqCnJR86X 353630L/j2oxy1QkVifNbpUXBg6UiJBky7gdgeVyAHMjZUFyPv62d8+c330f7279H3NC3N8O/W2wQo 353631zsshe6NMIeBIWFeBn7lf8eVbASpqVWTvI8B2nUCA2nqh9i+y/3MD5D/C6vc4MbIrZkV80n6s 353632WfvbH23UPVtRoP13o/a3f8h6rPmAU6O6Yubl7F/CB7S/aX+j15EgD+mpX1H1HznX1OF0rdWR 353633RdUviS/bALaS0lLNm/YTEZq1hvx7mO3ugXmPCnEk2B7d/3rV6mwILbWMbV3QaVWyXOSY9rf/ 353634Tvs3zq+oNg/Rm/vBq9t0hF6MRlpWPkoqBRBUl6HgUzpiLu/G3P79sPZp8W+BRtrfWjEn9aXI 353635evYQYVNcaJb9mU+12j8oLV54H3Fhui8cOkxC+Psq7V+r/8Q5kot8MMbgiFyVslv8WApZebS/ 353636/eb4V6QjbNNunIt8Qqd+i39wDltGu4HD8sSymKLfIjuJ6kvw4VksLq/rAVOWO0Jkoub/3etV 353637+4kIbXGfZWekIPrkHHhxTTHwVPYvg55UCYetfmwYdtkO/rcKCOqFSlMDNtRV4uu9xXBnmmLY 3536381V8j8rUUqanrOP9fQkRo+Ttov5z2y2m/nPbLtVbuv4QBtdSEgmLkfMhEZlYuyuu036n637RP 353639WklEqMnCrUN7ER7/Dd/iw7H30C1k1Wi/raL97R++1kUC5D/jIyH5IfYOtgDjX6DLan/T/qb9 353640TftbW519iSlRODDUEgyHueBr/9mn/U3b94UGOJ3GmcMpH1Z6Am5uDYY51xcbn1UoldN+IoL2 353641N+1v2t/Ee5JKwZVwGiFDfWDO0GkCnPR4cA2ej4NR2dL00Nrf/ob5oA57c33wXAdg9a1P2s/W 3536421P72H1F0yvD5TQYyMqjPG3wqVp1xKP/DK4ncK3zIr9Z+YklbjH9VJo7O7AUvayrNX3s6fZhn 35364339nYF53z21EK4jNLFxzrTpi0PwGF9aL/xjms/USENhrHdmjPtkG3JVeRXfM70au1yLm5CJ0a 353644S0gpKfnS5ETThUnXdYgramiD80rx8/JtDioaRK14dyGEDc2ii2U/DcI/fOaq/g7aL6f9ctov 353645p/1yrZXTfgxI+9t/S0/RfuKz9jctWOuiciSt6AgTpi70DB0RvC4K+fXav+a1v2l/0/6m/Wef 3536469jftb9qP04l+WUdu7EvPyB2j9qegWAW+3E77h137m/Y37W/NW0PVT3zPfoe3H7+ioKJe+wdE 353647+5v2N+1v2t+0v2l/0/72j2nC2jLkZb/F68wvikQE4kT7kvkGH3KKFVIJ/xMMvbasga39Tfub 3536489jftb9rftL9pf9P+pv1N+5v2N+1v2t+0v2l/0/6m/U372z+5/Q+8mn7Re4N3pQAAAABJRU5E 353649rkJggg==' 353650 ) base64Decoded asByteArray readStream! ! 353651 353652!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:23'! 353653dejaVuSansBook7Data 353654 "Created using: 353655 Clipboard default clipboardText: 353656 ((FileStream oldFileNamed: 'AAFonts/DejaVu Sans Book 7.txt') contentsOfEntireFile substrings 353657 collect: [ :each | each asNumber]) asString 353658 " 353659 ^#(7 8 3 0 3 6 11 19 25 35 43 46 50 54 59 67 70 74 77 82 89 96 103 110 117 124 131 138 145 152 155 158 166 174 182 187 197 205 212 219 227 233 239 247 254 257 261 268 274 282 289 297 303 311 318 325 332 339 347 357 364 371 378 382 387 391 396 405 409 415 422 428 435 442 447 454 460 463 467 473 476 485 491 498 505 512 517 523 528 534 541 550 556 562 568 573 576 581 589 596 603 610 615 624 631 638 645 652 659 666 673 680 687 694 701 708 715 722 729 736 743 750 757 764 771 778 785 792 799 806 813 820 823 826 832 838 845 851 858 864 870 879 884 890 898 902 911 916 921 929 934 939 946 953 959 962 968 972 978 984 994 1004 1011 1016 1024 1032 1040 1047 1054 1061 1071 1078 1084 1090 1096 1102 1105 1108 1113 1118 1126 1133 1141 1149 1157 1165 1173 1180 1188 1195 1202 1209 1216 1223 1229 1236 1242 1248 1254 1260 1266 1273 1283 1289 1296 1303 1310 1317 1321 1325 1330 1335 1342 1348 1355 1362 1369 1376 1382 1390 1397 1403 1409 1415 1421 1427 1434 1441)! ! 353660 353661!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:23'! 353662dejaVuSansBook7Form 353663 "Created using: 353664 Clipboard default clipboardText: 353665 ((ByteArray streamContents:[:s| 353666 PNGReadWriter 353667 putForm: (Form fromFileNamed: 'AAFonts/DejaVu Sans Book 7.bmp') 353668 onStream: s]) asString base64Encoded) 353669 " 353670 ^Form fromBinaryStream: ( 353671'iVBORw0KGgoAAAANSUhEUgAABaIAAAALCAYAAACNtvp/AAAy3ElEQVR4XuV9B0wcWbruSE/3 3536726erpPb2ne692tXu1Qbszmt0Z7eyOZtYzo3G2SA3ddFI3OWcw2Rg3GLCNE8kJJ2zjhLNxzjZO 3536734IhtjG3ACUwwNiZnmk7fO1XVXd1NBxqbSdtHQkCdqjqhTvi/7w/nI8D+k/0n+0/2n+w/2X+a 353674nKTursCy8HxU9qntvzPsP9l/sv9k/8n+k10kjUaF7spiLMlajfMtctv2y6FOdA6poR7pRseA 3536750v47cZwkb76EosK9eNCtmtT3Knub0NSjgLKvBY3doz/fMTb0CPmBqShvKkdqYD4eDWlsGJdK 353676vD2TgbSTrVBqNBbyF2LhqTdm85WvT2FJ7nGczM9CaZNx32jk9Ti0OBNr1yxD1tZ76FHrn9cM 35367712FndjFqu8jvZTtRN2yY9wQFkggcqz6JuV6rUTOsmeS5qEZ3+XLM21MPuUGbqOudV5dg/oFG 353678jBpcV7WXYcXSUlzYkI5dz0b019+VITf3Ap5cykPe5XaoyDOa4RoUJa9D9aD275RNeEy+g0Yz 353679iOpN6dh6bgcyCu+jX62h+2BbymKcqT6DnLwr6FDZ1k6NvAGHs7Pofl207b5RvzLtUKD1RBpk 353680J6x809PpkB1tgcJMvuL1SSzJOYKjeZlmvukrHFmajW17i7ByyWKsPFCLgbHlU982LQUpacbf 3536819X2+k2pUBbVBHdXdN5CfUmz2vZqRZ9g5Pw8VXaox7xlC3a5M5O8oQPrWR0b1petKjT8z45DO 353682V7Ti3MpsHH4xbFSP90mKgQ60941O6D3qkR70jHwYXtKoB1FXkgAhR4D4kjoMqidvPmnUCgwN 353683jtBj3/I9o+jv6Mbw2HFCrveR6yOTWR9VHxpqG9Cr1Ez++jrahRc1DehTWm9rb3snBpVj2ypH 353684d3s35GrNT4vB5d3oHFCYHYOUjNLX+ByvB43Hm3q4+4PH4Pumj4wqOHAXmdI03O7X6P9+cxdZ 353685nlm4O2AwqZXN2BsYiL3Nw2gqCUTo4ddGCyH1rOEz1AJRuzUEjrMcEbKlFoPkXmXrUcRIl5uQ 353686FRrNKFpOLADfiQMXlwBsqBkyWz+643pvISdhG56OkPrKn2NH4krc7GHeNzrQi5Fe7f29I+gd 353687mHzBQtN3E4sji/BMztRH+e468vxc4OLGgWtAPsrbldp6P8BK/uf4/TdpRv1I5w0+xvogFzhx 3536883MDh+CHn6ju2L5Vt55HKd4IrjwdXVx8su/jGaOPU9VdjiRR//nI+2y9UP6VN/RzT3dzh7i5B 353689wt6XRhuxevApDswXwcVVAI/wHFxrV2mfu4dcf+oZ8uM8BX/4Mhk3de/UyNFYmgJ3Rw44ju6Y 353690f6SRfSe1kQw9P4AUgSM4PD7EEYW41an6SSdiR3kewqUCcGbOQei2GpNN1LbFtxOXoj7Dp4En 3536910aYyHt9M//LAcXBF3L56jBiOf3kLLqwMBJd8Ux6PC3HcVlSTca5/jg8+nwc3nhdStt7CO4W5 35369270Z+vGQ4/Vphct0nswzvtPVRD7/CqcWemDPLGe4eAYhcuBuPtHNq7HwxnJfm8kzmPvU3EUhK 353693E9wQvPUJ3YdjnzPsE9lXv8L3y6oxRAlqZM4/ypmGX38lY8uTffVbzFlTi2GNxnSNoPpsRQDc 353694OFxwXbkIWHkBLXKNSX+7OHkj53o7O0fGPheYcwmv5ab9yXHkIulQg8GYVaCtbAW858yCC18C 353695z8A0lDbKjeeB2wz85b//ghlUv/vn4p6FfmP7dPQVdnkLsbZOL8SO1hfD26sY9aNUn/Tjtswd 353696ydd76byByjRM+UcsrvVQeQOozOAh5lIXhus2wce3iFnXVB0oWyBA4pk2us3q/vvIlYRgTyOz 353697nilaDiNSvJSscWrj+Ut+uA5/x28+i8b1Xg3bFzODCvGIFp6fYF3EClQaruuDT7AxZDY+/zZV 353698v8YO1+PM5h248U45IcGyt3It5m95Qo8Fi/dZGEsTmqMDpvuT5fnchfLFfMz2XEl/y/Hea3ac 35369964CVFvwZ/m9tbnxoO38WAJgIf69qX6FP9ctqh0bdjRvLRJglSMeFNqXx+ka+39ZQR/Ayr9oM 353700EMcvbxgNx9LhQeagKHkf6gZsE+7eZ67Zf7L/ZP/Jwjwcs1Zb3q/kqD8QD54LB86SbFQarNPq 3537014UZcXJcEP4kHwpccxKMeQpi0X0CCIA0V3WTP1QzjSVEmDjcpGBK6ag8yQ8XguUsRnFrEzmVq 353702DbqVI8H0OUR+SynB8xEDAqyrAqvS12LT4qU4Q+Q9/ToygpZLBQjnu4JL5Eg3QTjyLzSxgJ6W 353703zdL9IXLnI3h9FU16Te66OU75BvKGNPkgGojcRbdzhRAzOMGEtGszS4CZlEMw0KZYL4L5ZsKd 353704yLZtBNxrhmqwOcwdbs4OEC25inayNstfHcBct9mYPVv/M0e8BHf7NeOSsB3lKyH463/gf/77 353705/8Nvvkk3Ky+oeytRmLoYSxfk4VqHFhMNv8TR/Di4OC5kZDwKnxJyT+REcJ6jELJTLSaYzNz4 353706ent7D5bF+ULAccScOQZtcArA+sdDtpPlXY9RUdnCkj3UXtNytwI13UpT0s2Q9LWAZSYrX/3u 353707DCJmBOH4W5WJLNh+Lgyf/O+PEXzmnRExwhDFqfj6N19i3rVus6RJ3800zPjHl/j4t5+a4CJD 353708rOXm4saMw/htY7CWdSz1IdfN4SVL8p45OZW6lj71bwRf8MFz48Jn4WE8HdBjN9mX/4UpmXcZ 353709MnsCeOnnkG+dYH+NizlBpM0EA7u4wDt5ERYsOokWhWbCmPVD86zjKQvyPJnPTUcXQOjsSurP 353710R/LhV0b8iqr3EfavyMOJelNSW/66HHtLyvBqSG2w/t/B1uwVyMk/iFoDWZEif3tfEuVFhDfC 353711cy+jTcsT0IqRrLXIWTxmjg9WYbk4HhefX0CseDkeDk4mET2AF2fWYtnGS2gyQ1ZqFO24Vbwc 353712a842YMhQAaDuw6O9K7B8bT6WbS5n22BNOUCV9fLMBhSUVKKDGhOKDlSWFGDDmZcMB0Hy6/at 353713QP6mfCzfo+UlLCh7NMp2XFnEhWvCahRt3o7TzwfYb6JRvMGlTUU4sjUVkUvOoVWh57parxQi 353714Pf8saavG7Pi9snEJVp1+YazsIGXdLMpGTmEelhZVsLyOrqyyoi04OqYsvaKLcDoDTbhb222V 3537157LeZiB6qx+m163CmccRkPR54sgc5W26h04BEV/dWoyQvD7n5h1FnQFDrxtrSiAAs0irhDL/f 353716loj5ONGqsAnnWlNKvhcRre68gDhKgznYjjNzfbDhqZz9gC3nliGA8z0++e3HmBldgpcUmTJU 353717jRWSeJTVX0aSx0pUE5L4VrYvMq52mUxUzfBjrPJOQlkXWQhGB9A9pDJfPyJctByei7hjbxgN 353718JREC204mIvZwC03Y9NacwObceXD9JwfJOZtx7HHPe5EX1lL/nWxEbKqjSUiKZLqTJUI8TRiR 353719upxLhmQx2USoPNUQulsrkGGmTI2iG01vmcmhJItgqHQNakY0rNZlVMUMCtXbE4gQ5aB6jFCt 3537207i5Htn8gBFzrG6F+IA6jpjAIScdajBbPsYO1pyIV/JTrrBaW+oY5okicalMTQfwMYiS5bF00 353721ihbsDxSj4CHVDjLQqzcgJrcSA+8xoVQjAzZpkyjN08CIZbJbPjCAUfIededFxIqWocpgUVZ2 353722PyZa4Dj4iASEEBbCN2ktzr0cMBmL6vZzSPSTYaFfDI6+MT8O6bkgWanvCzIHnhV5w2PVPfSq 353723mXHZV/8QL3tVpooUajMn5KP31hf0t5gokaXRjKCuUAxBzk10KXXv7EWffHKI6FsdzTg+jwv/ 353724zdUsyLFaR5eZcPFYTVtoUPN4rYczZnEy2fIyHL/HLMdkXOxQG9eF9NnzLd4Q5txGt4raaHpR 353725WSCFzxbTflE0lsDfeyteyi095wG/babPUd9yrjSPtR6hiNhV4hAcatEuomoVO9fGEx4t9ikh 353726t5v3+kG4uka7JsjxosgTPjtf0WCFmldtJ8MgyntMyHhS9+IQSL0CsPbRENncXqDIwwclFKAl 353727G21VPgGyJfVov50NUeRhWkhjhfeKLIhiT+CNvA1nk0VIN7eOEkBYsYiPoF31ZscWrShYHYHc 353728B4MWx5qagLADc6fi41/9Fl/wsnF5kgmyH52IJsB5iWe6TeW9T91+6UQ0NQfU4ygOJmPf/NHb 353729NXgfSyTzUN5rfg3T9N1AqjjLSClj/X3VyBfPhBNPC055ZJ0T5zPWUcou3C1Kwfyi22hXKNH9 353730YCdkSetQ3qYYh4R+v7lmtS72n2f/eXaW9z77BS0LeCegjCKWDdZAeg8l8pn/5kq8Gx5BR+11 353731VDSPMOTzajH8S8i+Lq9DcdpuvKDkkYE7SHOUoPBOG4YVcvS0PEdjn5LFNQWecbjQqTZrodT9 353732sBQHKvTELXWt81oG+EFFeNjDyJ6qvsfYHi5A2uUOBvOoh/D8oAze3Bn4YuZiPJhM4sGG8s2v 353733Rw+wVBiLSxTW88wzwivj7R/yhn2Iid2PxlFDkH4GsR6mVr8UwXGvQAz+8lvoHgcvaEYbsN3t 353734V/joo4/w77+fguku5utAg/TnV1D2xJgMMJLxyHfMl0TgRBsZJ+9OI4bU7bEVa1DG0jgBDoJs 353735nK5txxAhuzNdw3CpW/OeypWn2OInQf79fhpr9VXmwiO0BPXjkICWsMxk5FNtbD2eghhZFBJL 353736W4yN0tTvcCaSg6i8WLiFnzI26CEyaPWqCGQWZSAsv4o2UBtrOFCWJMGSy2XIsEAIPtvsReTp 353737O4z8T32/V9Wo71NNHEt9wPUPIaLZcUVk/poiXwjzqul+YPDSd5g+LRRHWpUTw0s/eb4aI90d 353738GFQZGKp1dtIEpe5Zke7ZgYfInfUxHNdpeZQfmYi2hqcsfnvCheRK5uIcwbGKlkMIFllfA348 353739+Z2xiBb8ABbRv0hFNPm2/XUnsWPXAWyXCSFadg0dSs2/bFvlfT2TanVuvbxRNB6SIftim94o 3537408ANwrmUimmjDO992YljJ/KYaSGmui+ZFIFjwNT7+pxDBQe746uMpECUU4fEgQzivFISitO4G 353741Mj3TCPHcRi9GmpFarPWMxum6s4jzXouq6mJEy87Qmm/TjfYRcp3mYNGNbjPkirZOVF1Ub3Ak 353742Ihh7mvQAT9lyAKHhpWhVMUR0UW4yXL92QRIhoo9PMhFNWzAuj0BhzTDzP2njGs8YnNcKmpru 353743MsSTttaOaGwuU912CtHe61FnRgsjry9BSEAxTcAZEpFPt8Zg0amzSB+z0KZP/xIOXKIlDlqJ 353744cwYughr5U2yUuCEiygcCIsSLo9bg6tsxbjnqHpTPFyC1okcvlI82Yk9EFA42K2itYUzkHlZg 3537451AxQQH8+Kvq0//ffREYI0w4ji0ELFirqwdd4cLoIWeEiuAWsJooKWwBFNVYHuEEUnoWi0w9M 3537463Azo8dBxB5tDZ8Ft6W2WUFe2XUKWXwKKb71mNkZC9ndWH0CqwBeF1QbaMkqZcCoBESUv0XAo 353747CtGlr81OONWbYwick4wburbLn2GjVxiOt6ltIqrUbccR7r2JtqqfsDBEvuUGz1AcfauyiRib 353748CBGd4e4DWRTR0hfepwl1mwQzSSzWyCKw7skwhmsKET5/LRKNykvB3vWB8Cl6RhQFBnWRP8cm 353749zxCUGgi4TL9sxvMx/aLpv410ryWMdbKl53yKTJ6jBIZQz0J2blHPFok5kJVWobnXvBvVRIlo 353750Zg06hEAhI5jQY8HDjyaX2Xn8oggefvvQQoSe00nzsL9Uhtj9zZATUBMu1Cua1D03sZjrBK5j 353751AHbWG7v4alTtuDhfiPDMaIiSz5qso9TYbb+0ALzIQ2getbxJDD3MR0RBtZHVslGfvS3H4dMX 353752sNo7EoevHsfx6l72PkV7Fa49tk17qxl5jh0RLnCgvD5cvLCsjAHc9DjjSjEvIRBidxfM4SXj 3537534IshRggkG+tw/VEs9HABh+sOvs8ilL1TMULty0OY5z4HLu4i+McmwcM9k+3/kcZTWOTDA9ed 353754B1dhIkrqBrRC5T3k+jAW7o6x+2jgRr1r8OleJHDnwNldiqDEFHi5GyhO3ERISAgGf/YshOx8 353755xlryj+9JMIo3F5ciMG4HHverTeeWmxBxcYHgz3FA5JYz2JkeBMEcqoznrDCe4cpHTJQfeLMM 353756yqY9Tw5ivtAZrlxXOAvn6/uLfq8Y8dE+EBJiZmxfUh4ryTyqz8QIiJ8HT8N2krKio/whDcrH 353757gwEGWNwn89TJ0RV8oScSS14w9eq5gogvLHsIGAv4A7i31AOpWksnal6EB+7UegaMoGZtAGTX 353758yf7SdQkRf5+KpQ8HoWzeh5CIUrwh+3f3jWxIYw6jWT6EuqIA+BYyrpb9t7PgufAGo+QjBMPO 353759wDAcbFEaewO4fIPffRpMiCWNxTlr/H/lhASo8daA90nvO9d+dOBm/3n2n/czzrMG1Aaf7kMy 353760fyo+IXvATK9M2jtCN/+zvMbs84QEu5nrjS9/9wkcPAMQEBiDgpt6ha+SyH2R/EUof7Abss1P 353761mPW59zoS5vhhJ8EaCo0Z4nSNLwQhi7Croom1GqPWwvp98XCb40TWdCJvraxkjFcUTdgTIEZG 353762fhL4DhyIQnNxvUNFFPG7SV1K0ERZihHSN1sYh4tPzyDSLd3AA1WFnhfVaB3R/X4Pb0C6fB8U 353763V1cwVpscZ3BiDuLFc335lsiQ2p2xZA3mY+72J8YWYxa+E6XA76jcjRUr96O6R2VkQVUU6AT/ 353764LXXGMgq5/83pRDj7b8ezYfP7sJH1qOIVdrn/2ioRTVuXzycEmUgEEW8GPv0iAld6zIy9kToU 353765SvxR8kqO0aZ9CPLQ4pyRVlS/6IFK95v12HuJLSI35D8eZpXhlohoeeMJpItmYZbDHDh5L8GR 353766sl1IkXDgMIuL+cebWcOhkRfb4S9YioqGCiz1iEVpyxj8RhQiGZ6LWMWqNSwzKflkrOybm4oL 353767zy5iQXQJGgwVCW0nESkmColOouyRRtIEPvtc3y0siy3G877n2DY3Gzd7jTETZXwV47cJTzst 3537684R8Ka5nHP780IpqW+TvOItprHTOe6HfMQ8kqTwgKHmNoInjpp84na8CTTUHwL6DIZqIsebgJ 353769Ib75qKSsjA2e1ai6cXNVEgqO7UCojynW+7H2C0t4ytATl8sPRm7ZWxa30O/reoU90THYXz+i 3537705w0sYR3qergTZju7wmXsdUv3hzlgBpHBaW94o+vO5H4i/7tGoviJFt+MvMCuKBeydnDA47nB 353771zTsLJ3UevoZluPohu2Q7Fnq7guPmBldxCg48GzTAXMeQ4UPJ0a5wEspwUTtfGVzFhRuPCw4/ 353772Drue6LkSS5hr3LyGY1joxQWX1NfVeykuvVXYNL8mMsdGGo5CJpgNRzdXzPjia0ScYEIPMRxH 353773MNZuzUGE0xQIVlczltUGGIvjxoGTIGUMjrKAv8bJG6grQbzrDPINOITjysM1nacU5T18fyNC 353774yf7q4uiC0E0PjPmWYQuhZOjyDiGVcBiuXA6ced4ISdnPGOhZwmQfcl3Tj1syKbIqB6xgMMt4 353775Xv5yC/jTEnG5S631PCBcbcB2VoH60UQttyiAeXeRJxbe7EXf7Qx4Zt6hBSfGNP0NTsZy4Jcm 353776g8hhHq5rw2TQbvDX1iIpKhnryh7ixMIUbD+3D3kZmchYmINDNf3s4FQPPMJ6zq/xv/4ShH31 353777ciuWQFVY7qEnP3UEqMyDIalGB3owbBiao18+uUQ0IV9zItbg0bAezC6WyvShLChhQEuY2VKm 353778RtWJ64s9EDcmnhPtckAWmK8/c8byOz1GhJmq7QwWxBJteNeYhZYQ9j2kvWrS7+1XMsALO4o3 353779Sn09F06bBlnZO1IOlZ8JfuQJvFUZxme6hhSBDDd6jd2o+h/kw/3rb/DNV1zk3evTL77KVhwJ 3537804yL9MhUyQYn2q+mYPj3DqoWZRtmD2gvFyI72hJAQ+NnFZ/HwzZD+nWPCDLA/WgKEnYytD3G2 353781OBsxngJ4RGej+EIteijXPkUz9gdzkXLkOSsMU5Pp7hJvpF9vR1v5KoTy3eEzNwVhIatwt6oI 353782vkSJ8VrXT0TRcSwuBofIBFO9PY54IoS3mGxQXDhN/QrfeRbgVpeK7d9FkgW40a+xSThixsli 353783uq9scw/zhOwE4w7IlJXKljVwPw8BhpZDY9/nNgN/m5puExGd/t3v8fsvI3HstWJCgtnFsmWI 3537842HAfDzaEY8mlMqKQMl7UbjaXI430z9Wm2wYLnnE7mLlMCGdPfb8wZZLvXbMeEt8SNCpse45u 353785P8cRX/95CpIu6V1L6LHTcAGF83zgNOWv+Ov33sgZ40r6PkQ0NW6OhgqRWz2EkbpCSAL2s+OG 353786Jb348bjcdAvZc3fhWUMpYlPL0HQ7Dfyka+hhrbG6cDnhC/zZ45DR83ql22H4feON/c2mlpaK 353787N6cQz43HyTeKccae8Rpmtn2UpbZPjBFwUrSVYYlHMDZV9dkUB43yXugfYMh+1ZujiPTegKfa 353788DVM2zRG5D3SeFKsgCWbmmUbZgoOBAqy428ts5mo11Grm+qFgEfLYZwrgPF0b/kX5GqUR3lir 353789VSjJG4jyLnQfmhUWvhV514FAMfIf6st3maEPJZM2R4rdr0i9288iRppP99O4RLQ4Hru2pcB3 353790wRHUD6vN3pM2W4wdZG9Td5xD2Lce2EsUFdTfcw3KMFu2gqqvCPm6tlflQxx4gHVptNqXQRb6 353791jHpuJg+bn44YWHw8xHJ+KI616tzKNTbNh7H5Q9V58Eq6hE61Ak17QhCyt5mdX/23M+G3sgpt 353792lcsREOqH8B3P0Xo+HgFFWqsadT/uF3jBe14cxMGEcNApkKj4mD7zaI8ped0G+M4dY2WlbMOl 353793TAkidz9jyR6K7I439FoZ+w2J8jtPEoUz79TseG29tRf5C2XIWr0fFY1EUKfcBa9dwsshzQ9C 353794RL/vXLN/QtL+8+w/zwLBabg2UWt9iB+2PihnZZKxCsoZPrlGIZsoY5IIt0yTME5UuIbS1VmI 353795F82Bo9AFEtkBvBxmwja8Ld+ERPEMfPn3b+ASuASltf3achhjjfK3jSgrCIRQdp4JQaFoxG5f 353796bxS/YPCJWq1m5d/FrnPAcYzG6XfqMfKNVhFPMEP5Mg8iE0chIGgVI/NRWOtqHiIX7Med8/mI 353797ST+KJm3IjBvL/IxlaSIrzhSsRJU562CqfEqObaXCB/wVX3/rgKjiavT26su3HSuZCXVmIMtT 353798IQ5lztMImHaHOGYbDbp1HmpqyqBHuAT3DWT+wZrN8HJKxtm3Spv2IdrD82Ex4t2+wh8/1hPR 3537995gxjaBy2zBPh2xmLQs1II85uWY6kuTm4QsgDOszHzUJECgjZI4jA2hsdDLEhb8LR9LnIv3AH 353800+xdEIe+qTtl+G6kOQTjbqcc1md/9CV/O0Ibm4CbiaIuCsRyO4kJ2pZPIqCp0XpmPrz+RYj/J 353801U3eVYZ7HMtbinQ4ls9sfX/9jBpLPvDUmhZVdeFAcCU7UMbTagGUmI1/+YiuC4s+iXdmB80lB 353802KHouZwnst8eiEVRMhYYkdd4ejJjjb7UezGp0lmUi9dhrGjO+PpqKzLJOA0MgBZr3RyKa8nC2 353803iIusY62fc2gOc+sONVbStQoE3TtuNFxComs8LjRMBC/9tPnMmOnCrXw/eCXOgy9ZL3QeXgxP 353804sgA3++R4VZoO2cF6jJBnF+rWtJ9ovzCHp8YaMoVIVuGJIQboeIGt3mIUVPYaeNFYwDpqhoOi 353805jTJaSxHmpbtu6X45ez8156J8TO8feLAckvgydGu09/fJWeKzu3whRPMYPGn4jPJ1Kby/cEHh 353806Y4Z8pgwcQ8MP0BiJwQk6z3bqOSWUai2uCvdAQZUWV9XvQGCQFoNbwVzj5/liY+0QjUmo+npl 3538073WG96CeDiKbKOBwswHIthhxt2AFfn520oswEY4kZIzDauz9AgJx7jMdJ//1cCHUYyxr+sprX 353808jH2eUxFxuo2sfUq8PRkDwSImYgCz/3ui6JmcVnJukDKGa+PxX/Q7/QXIvd+P0fbrKAjmYKr/ 353809AQbv/cBEtCUMZhWDqijPmGnw2ttE9kU5nm3yQvABvffMRxMjX6nFcxY++90nmEq0KzM/+x0+ 353810neZqTA4quvHiynp4/e0TzFhQRsf2MiIz761DevEZrPWLpuNJ0ZPMT2vBqGrD+WRXhJXcw42i 353811YEx1XoLrz88hOXS7ievReET0+whEZu8lZRxpMo0vPdaakLGInosLXRO3iKbdcraGwGN5Bbos 353812xKmkFowgonHUxaOmFAJVBWFYfptMMmuhOKg+8czWC3KknoWBMiPrZZnnUtwfNHD9v5oMQdpN 3538139BnFPX6BLb7B2Ns4itHmAwjz20q7I7L1e30ReaF8ovmSEM1MMqS+W4zyTRUJT7AhYDq+dU/G 353814+mN30Nj//m7/yv5G3Dm2Hsnu32J6wAY8od03HyI/YoUxsCCEQ75HAq68rcEaSRDZdEZpqwZf 353815J0LOvmH6QSfsURuT/5Rp4Ek94CHlYwbZpPY2mcbCod2QXuxGeNQ+NI1qWIvoYxOxiPZ6X4vo 35381659jsZayZ/pDN2Xjhn4+jpTJwBDm41a2ymYi+1XoHSwPnIsZvEW62mitPjhdbfeG/bh/pb52G 353817n/QZ0ZIfMdKwn0CE9yZWS04Lg648uAljsbVKS05aec64PykXxhx4J54xH/+OCp/ykBDcglVG 353818B6aYJ94ogGZo/X8LaQbAjAkRFAnhiluoXC1G8Nj4+eoOnIsSYOG+VYhZeQ8Dw09QGJWNfbke 353819CDrcygrplFJBGpiHghABMivMeIdY+g6jzTgUycOCS+9M3EtNNu4xXh22ENF0aJ9Vs/HrX/+d 353820aOud4ORk8OOx1Ci+pqHnRuPJJQjgc8EjWuG/TUtnhe0M4di+ZNYqpp9TjdZ31vtCmmr0jEyi 353821s+69h6zpBqCBUsoQ4fHRkAUiWvuuG2bfRVn4k/Gs25y9ssYoRczPm4UzPsPnU8Jw5LUV7b7h 353822ez315RmVYbZs07br+8taX1rrM/KcREaXZeh29fb6ZqQGe8PDNwb555vZ8C6m86HSuG2G/Ut5 353823QvnE4ezrF9geGIHSVv0aTxHvcQFrcWJtHArKjmNBUgkB8r5YUaUPFUNpzaV/+juSyg08cyjX 353824zqJAxJ1qwIM8b8wr6zIAAb2oXOMHv9WV+pBShGzYKP0avLX6eOWmYWqGUbeBj8+nJ+McFUO6 353825rxLr8vbhVt1TVJ7eiPmURYfQHwt23ke38scjom2Za/ZPSNp/nv3n2UBEU2GZqH27dXzLRNYi 353826OscDf/vdZ3DxDkRMfgU6VRrzOMLHDH5Q9uPliXmYyVlNYwDK6u5SKg+hu2rQ+mAropMPM/Ii 353827AaZdlTuRHuoFqVcEVpB1jfb4pKx4RZ/iD5/74ACRUylFrIpcH321C35+u/BqVBsXM0ZM73Us 353828gUuFxhCE4mDdHYKPKGW00ibPjrF4hy6fIsirK0jfZOD82SWI3lyLPoPyJ268M4EwWiPPUZLk 353829CT5XiLjtj1ljElXHFSx0dkeeAfkzHhFtdI/zVMuhOQgOe1wUAp+8W3TYAPOhMfR9PhY3Kt+c 353830RJzHctypPYAQAUMca0ZqsIonxrb6UasW0RQJsUYSTghrBjeoO8/C76+fYQ5fBKHAHVzv5Uay 353831lab7IsI4Gcb4hux/t7M5mBW1kz0nZjws86H5lGxXu8YN/5zFh9RDCsHsb8Bdow1Np2xFacAU 353832fM+VwsPDA1Lu9/gm8Cjt8USR28fDZ2AWX5vHn42ZESdZgygabwq/xHcuPHqeGZ5bYmwRbbv3 3538336S/PIpp6xzCerCJ9W1CCBbbipZ84n+V6qgoh/OJzcFbeZOcTg1mDsePEaiRp11RjrGcs9+vk 3538342HsDH5pnGbNZ+2ZjieiaMcYoo2+vIj/MB7LSembd1mIdf3c3cA2xDhV3uGwdUmLmIi7aE1Nn 353835LdRet4CNyFpUuysBQheOyXsaT2cjkNzPdfwKn3scwmsVowRtK9+IRC93uHF54BnlGZfxl//+ 353836VM99GWAkXR/e6DPlwhbN/g7S6HjEx5Of2FB4hm1CzZB1zGU97z4WzTDIc50Fh9izLD6fFCKa 353837xj1jv/tivcJjwhjrffPImu8gxHbtHkCdG+UbcgRv1Vq5RMoo0zSaPlTMlyL7/qBNXCxV3rWX 35383817E6dTWu1ZcbjPdKC8Syeaxm0/2EiL4pkzBEtAUMZg2D0oaSD5bCwSkX1e33sUwYhVMG3jEf 353839TVSYoEys/aIIAz5MFiOfaNaKiNkIFZArtPFfOTMwg7vcKG4ZdbruwWU7UdNZjVxxBE6Siqio 353840RUiUy8aVzXOcgTSaeCET68oKCKdzkHGt05SI0Ybm2NtsuGEeRGjYYTo0x/sIRPSJl+/GP93T 353841XHxV+iCyTDGSzr+jNdrtl+ZDmmVgLW7RLU2OlmNJECaU0pYLRiErlHJaI8WA8sMIMYhFRIXK 353842OBDpBp6ECAdiR3z++8/ATT1Ou+LrrAloQqt6NUQ+u1nBkSafVkZhHWsFuAaSgL2sqx1lOXE5 353843iRBlt/uN60m0ILligxjRBvF2x7an+bgMCSX1JjGox/YvHdemow5lJTmIJwuoMFiGwmNV6FRo 353844bNAIdaLqWCFkwUK4e8cjp6QMdR1y6zFOqdhO0nhcflOD1ZJgHGxR0KS6n7MMFy4uh0c8Q1Qy 353845sX5DEXaQ0djQsX1PxSJ0tzbW75hFkFKmREi04Rh0MaJX62JEkw25wXzcMrW8FWWL3OFV9Pw9 353846Y0TLUb/DH6Kl1/QHHpLJn+6ROQlENEMaNxyKhqNvEZ4MqG0UzIjmbMEU/HNeBXotlKfuLEOK 3538470yxMc8pgY5492+wJUd5dmkCi3Fjvr/aANxXCw1q/mH1OAo8NpvHGaA1isD+2vdRaayj70PK6 353848l7XQpMZBsHQNqziyKDzSWlYx8rVa3qHHayAN0VvS09+VaFjnOgshdgo1E09vFA07PDCd44q4 3538498x3kHb0ol/HgOs0da2pHtGCnFhu8/bD1+QhRQO1GIBlbVQPq8a3raUuZIPAXVZjETbTUh4Zx 3538507m21iKYOVTsYL0Hq6VYbDyOqwjJBFM60qwlYO4pgjt4qXzbdibVIHnxE+jLogIEVrxA5lX2s 353851ll9nEW1oxTz4aLXeipn6xiEBKH4+YtO6z2i/xVhVrX0X+ZYcA4vo8bTE5ufNApy7thHBRKml 353852twKxcBDomPeOq6Gm6yvUWzY/LCBa9/16i2grfWmxz8yNI7KPj2jjzNPWAiLm4BNdjG0j0pra 353853F0SRtNWeomkPvBzTDCzRKIHFH8E5GfAea7lMvtVefwe4C9NR3tmCQ2Gu4LjOpw/uZPJbcSJR 353854itRtqxHinY97BsBa0byPKO/iECjOwE2d0KMewrPdkZBkXjI6EIW1iJZat4jON7CI/ilCc7zv 353855XLN/QtL+8+w/zwYimjpIWOqABaVHscBjIa41vkHniNr686q3OBnFReol5gBx9cAbvOoetbKf 353856dOPV635WmTxcu4EQAtns+ST0AV+LnfGnfyTovUXVSsjlKi0RdR5z3TO0hAPBEGUp+Po/f4W/ 353857fM+BOKIA5Q1V2BbCQ+rFd1ZDYo00nkRmbCEqa09iUfwGPLZwWKNmpB5HN5XS5/iYU863l8nA 353858EwbAXbAU97ueY6s/D56EYBmv/B8qUfUtCZqFIHPYgvLiIwQvtQ9R8ngwkenvTICIZg5jT4R0 353859wRm0vg/JPvQYGxIW4WRtJQrjKLf4EZaofbpJDIfkE3g1rLZMRNMW0TykX6dAvQpd12T458ci 3538607G7QWsqPymlFhJ6IvoQwV2NrfUrOWiqMwUXqfCWyhw8NyMfHMh+aT8rMDczWW8IO3sfK0Hxa 353861XqDweJjWclK35+8Li6QV0qONexCVfB4d7KGLnURRE4v9WoJ7+Mlq+KdepeVYq/J/kQ+81j1k 353862DvSjvBxf16GpX/0LjBE9iLptfhDmPGRjROveoWw9gtBp0zDVVrz0k+dTB6JtQ7hHFi62vEH5 353863Sm8ErKtEj5YUrVvriD/PXKkNA8c866PDwBS+CpFizRPmAM/h2vXwDGXw1QfljYPZLH0zNjSH 353864exByxobm0H3v7itIkiyn13ka6wgZWZIytojiarHO0EOsEM2lzwigrJIDXbTXLWEjSqHIjzRz 353865nXp/NM52UMZK2XD1Oci0kXAby+Y4YLkWG3SXy+Dorc2jnuGH09wN9S7/fxJS9MUIy8GoFMy5 353866CDTmCvHGproxB9zR2NkXRXWmhy9aw1zj5wWSesjZeqjVmkkNzUFbXYeIaKthnZUya6FrDWMF 353867eqCwRjeONsAzaD9r9WwRf1nNI1jHw9gimp+ls4h+ZWQRvVHqi5JGxfihOSjP4IBp4AQX4Hr7 353868KN02UYDW2pxgsjyPBDo0IRXuN1Q3dixgNYv3U56iIkrRR7irkWcoIsrCdEJEW8RgVjAow1mS 353869tkqnwUfmD9eky+hSWzqscJxTpmlXm6Ph8Csm2p83pQgLIJpxw5MhR15ivywc4eEe+OaPf4Vg 353870tf4kZ+rZd1c3YAftYko2/SMp4M52hONsHlKONmkXMMbtKcxpOua4uoMvCoQsZx6kkTuNTnJk 3538713qdES2kcEo4bHFZ4OgmxB1vGJUcsCp4Uieeltw621DfU4SbrIlaYhJ5Qtl1Fji+Hji3jSghT 353872Ng7MwAPk+8/GZ4Qsnk003KJgJhYnnddzFRF/+Q3+4cAzsmygra4fb0CIOw98dy5cXANZd69x 353873wSittZdAQGmgnCKwpdrYrVfZcQNrwkVEQ+UCB14C9hjE7aHcwBKFmWYFtYbDSXCb4wwXBy6S 353874S/UnxdKx3MK44HAFkHgGIHFjBUsGGPWbtf6lLIvbHuPC4TOotyHwv4YA9DOHL+Bx24h5l2Vz 353875bnfqHlTIxJBde4e3V/MR7M6E5gjl8xCQtgv3upTshNnl44ktL/XhXKj4pYG+xUyMUyN3LfJt 353876OL5YfvENe3o2BTjOrwwEl8MlfcyDJL54zEnOfPD57uByPZFURPpqVDOuO5lFi3fFO9zYFEtr 353877Tnl8IURiX6RsvUufiDpxIjodt8cSYUQz+6TID47Rh9Awomv73zDLXcTE0wtcjhvd6nE3BmMr 353878ciKMrHfCf38lMzgFuhlnl/nBlUNpbbnwX3YWzXIbDt/UPefiCqdvP8d3sYfNh0TQWioLlt5n 353879NgCiFDuQLISLC1HmEHDlwg3Dmop2Y+tlc8KjNq5wksAFbjw3cITJ2Pt00Ng6R3vC+CcB5k8Y 353880H6xagm//4IpioiGl6tV6WII//j2FDetTvyMA0lW6mFXDqN3gRYQ8PVlscSPuvY7oz36Dv5P5 353881aaK4sSRQ993EosgivaeFDUQ0o0TpQmv3qG0gjXILXi7EdAcB/CKjIHAzsMalYkolBkJCxZTi 353882JmKfUbyyI5BJnMi3IfPFJ4uNEU3HdXabDWeeEN5RcZDyMtmDR+hYXNqYz/4JhbjVqbIsqGjv 353883j3Ml73KXIDA+CVL3xSaWzxNX4FBx8TYj1IshoyeNiGbjnDox8cv4ydinHXtMX0qQGBcACZ8D 353884hzF9yfaZmRjRJuOICB07ogVE+ObDnbJI21GjPa26Gzdz/YhiMxihiRvxaIAZn0+LgzBjJhe+ 353885kdEQco33jtGGneD/8TNE0koX4/MNKGvfz/0IQa0m68E6B3zmfYy1iHq1LxKeK+8QZd4o2edj 353886IV1SobeqUbXhZODnmJr9gD3giPJACv70d/jGxUwIp3FjRN/9yWNEv+9cs39C0v7z7D/PBiKa 353887Cs9QuQ5eX/wn/u2j/4H/+1UczrYpjV3k3UytXBVtV5AX4AJHIpcI/BfhdIsVInqoBpvD3eDo 3538884ARnx9mY4RiAvMta8kI9jK7OASgIaZEgXKz3UBxtxtF5Irhy3cEjZYRt1MeIpNy5Wy7lI5ys 35388951SMTTdBGPIvNNl0IJGivx0DRAbU/X6v9egDyjfrXWolzJ4tqetiCP78f36Pr3VhLagf0WLc 3538901XkjOcyA0EMMoU8kwl2mwDWjDO9UGtuI6L4bSPzHH/CNq5CRaw0wmk1tVA6gvV/B/jb2UmvD 353891zSIiW7g4ELz7Df70n7/Vh+aYI0Z2JWP0w8QzZWJEO0gzcaisBPPFLgT7ucEjjRDkinGIaEpW 3538923xIKJycBvPyjkXu5bXws84H5fbcWQphsEFJO04uKVAmy7vajeR+RY9c/1eNESjG92Rshh17j 3538936QZPBB9u1Z+7o+UWfAkhSRtLLREjqayblW3M4SI91gqGQCChLau947egqlf9sw/NwSpPqPjr 353894BA/y3LjwSjuIOjMGP1SYsruZU/BfX9qGl37qfIpUf3qsBNe0Z09plB24ve8QqqnvQq13C1OQ 353895mexFYy+uKw+BK86jxcCSmpJx50ncIZKKwZfM08u4H5Q3Dmazkew0vH79yRGkevHBdeYgbMtj 353896Vka+kRMA/8RMLCZcmLNOeaDqQkW2O76fzScYKFKPgSxhI3L9Tr4XZju60fGapzno3tOJ64u4 353897mOrsicj4IDj6aclmQug/WO+Had85gO8ZjMS0aHD8dXlUGSJMn0MUidGrcO5WKZYECsEXCCAU 353898+yBpl/4MGupcnswgXwQGB8A7cDHK2lQGuGo2nMbgKmuYy5a8BHdHcAj28olZhYpO1aQS0bo1 353899NU3KoeM2c8j9R+uHTQ6iNIex5ntJ4RfoB6nXfJMxZhZ/jZM3ULMLc11mwNGV8IN+K3G5TaEP 353900G1W5HkHOBOc6OiNo/T3Wm9M6VqjHwdQQeHGdCe9GxaQ2jPVNMNn2KEhDU7BQFgU3F50CyzxW 353901s3z/CF7sDsPM6W7wnpuOdE8ebRFtEYNZwaC6tnaWxeHz//gKslt9Ru356AfRXP9Ip+ure28h 353902J7GYccMnIG5n0gpUdKvf+33yl7sh2/TY6GAM+0+Tl34O/at4fQLzxHOxvbINct1hhY/LcLGu 35390336Z4t/+qSd11EbEeBT+L03/fa82hN7aDWJi0Abe7VPY/2UyskquRL54JTkghHg1aOvH+CTaG 353904cSzGjfyX7Bcq9rROWKheA7Gv3oLHpuep0EbSxVbj4f8o7ZgAmfpj7c8/WFuJEHQ61gfrakds 353905HPtVWCZOwGVLhxcSBc488SKbSZEfioiejO9u/4Sk/efZPxE9/ny52ffjzlUKOO6Nd4cTR4zE 353906Eib+sP2nH3f/o+I4ny1ajw1bzpp4n/7i2qvsxavnr+1/HOnwy7sLyFp8zuTgbvtPPz+cppAr 3539077Bpr/yLm0hL7n0s/b9w6jO5e+U82j8xhMFv24P47C4mCPtckmsJH9v9J7T/ZWxp9V4mSReGQ 353908ajWCc/NOoK5fbb+LGn06uTOCixnNqP0n+0/2klTtV7E0UAwB1wHTHcNQVNVr8+ZOnVRdEi+A 353909t9ZF8ecOxA3v/aUS0ZqBamyIdIdAZrugTFkUVRdFwl2ajgttYyzUydq3NVKIkMJ7RqdVW32f 353910VqnjxDOIfac9INZ63c1YBk7QKnAidbH/PPvPs7e8f+W1z/7T5Ox/9p/+tZKy7SIyxd/jG7/d 353911JmdJ2X+y/2T/aQJ46N1lZEmm4lv7n0v2nyaIwax6rlPRMtJDIOEGYE2l6ZlX9k9E23+y/2T/ 353912yf6T/Sf7T/af7D/Zf7L/ZP/J/pP9J/tP9p/sP9l/sv9k/8n+k/2nHzT9f2RrpA/AW/3EAAAA 353913AElFTkSuQmCC' 353914 ) base64Decoded asByteArray readStream! ! 353915 353916!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:23'! 353917dejaVuSansBook9Data 353918 "Created using: 353919 Clipboard default clipboardText: 353920 ((FileStream oldFileNamed: 'AAFonts/DejaVu Sans Book 9.txt') contentsOfEntireFile substrings 353921 collect: [ :each | each asNumber]) asString 353922 " 353923 ^#(9 11 3 0 4 7 12 21 29 41 51 54 58 62 69 78 80 84 86 90 98 106 114 122 130 138 146 154 162 170 172 175 184 193 202 208 220 228 236 245 254 261 267 276 285 288 293 301 308 318 326 336 343 353 360 368 376 385 393 405 413 421 430 434 438 442 447 456 459 466 474 481 489 497 502 510 517 520 524 531 534 545 552 560 568 576 581 588 593 600 607 617 624 631 638 644 647 653 662 670 678 685 690 699 707 715 723 731 739 747 755 763 771 779 787 795 803 811 819 827 835 843 851 859 867 875 883 891 899 907 915 923 927 930 938 946 954 962 970 977 984 995 1001 1007 1016 1020 1031 1036 1041 1050 1056 1061 1070 1078 1085 1087 1094 1097 1104 1110 1123 1136 1143 1149 1157 1165 1173 1182 1191 1200 1212 1221 1228 1235 1242 1249 1252 1255 1259 1264 1275 1283 1293 1303 1313 1323 1333 1341 1351 1360 1369 1378 1387 1395 1402 1410 1417 1424 1431 1438 1445 1453 1465 1472 1480 1488 1496 1504 1508 1512 1517 1522 1530 1537 1545 1553 1561 1569 1577 1586 1594 1601 1608 1615 1623 1630 1638 1645)! ! 353924 353925!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:24'! 353926dejaVuSansBook9Form 353927 "Created using: 353928 Clipboard default clipboardText: 353929 ((ByteArray streamContents:[:s| 353930 PNGReadWriter 353931 putForm: (Form fromFileNamed: 'AAFonts/DejaVu Sans Book 9.bmp') 353932 onStream: s]) asString base64Encoded) 353933 " 353934 ^Form fromBinaryStream: ( 353935'iVBORw0KGgoAAAANSUhEUgAABm4AAAAOCAYAAAAmGuPiAABKMklEQVR4XuVdB0xUWRfeZOPG 353936bNxIhEiAIAQlwExooYcOoYqgaAARxN57F3uv2HsvuFbsYsWKFRs2bKBSB5ChwzDDzPff994w 353937hSkMiP+6OzchIveV+2493/lO+Q3Q/qL9RfuL9hftL9pftL9of9H+ov1F+4v2F+0v2l+0q4hE 353938fBRemoX+E1ciccBI7H9fp/2d8k+OB78IqYn9MWz8QCSsy0CFUKT9naKkCDlnEMMOw/5nqRjE 3539398sOmrHrN+pdXgOsrhmHy4XeoVtK3IpEApffWYvjEfXhZ0disrhHcjF2YPmMDdq+YgoUpn1Hb 3539407Bn8/HOYHDUWO49txYwhsZiw5xWqml3D+7ALvb0m4jp5Vh+fqUivVGwH/+thRLAisevUTLi5 353941zUVG9f9nHjTkXcDMmNm4zBEo9jn3Plb0H43DH2ohFEnbI6x6ie2jp2B/2gnMHb4Cd0ql/SYq 353942u4FRHlE4+CkPF4Z4YuDpAgjIvdXv9mJEwia8qBKCX3AB0wcsxA3yTkHJLSwbsQAp13dhwoT9 353943dF/1j96Ct3lXMNwjBke+NrR+TVVnYMWgCdh1bAumD47GmB0vUKlk7IU1H3B0UgxmX8pHg0h1 353944f4uElXixbQgGrk1HqUCk8pqXuydg3IYUHJ43AgtT88BT8kx6vkSPp9tGzZfxuzMV5kvTnGma 353945K7K//7xzQYiarD0YGDIDV5XMhaZrql9tQXTPebhZIlBaX/54DfoP2YlnHy9jbvREpHzjqfy2 353946tAz138X7tA8JA7biTa3oP7v331wTD3cLE5jZhWHm8fdK9yjtOAcrUZhXgrqf+P3UO/Jz8sBt 353947EGq3zCGsBSevEFWCX3uu/fYzH16ftQkB9qNxu+Kf6QSRoABnRvVC4l0uPu2OQcTal6gWab/w 353948p/1F+4v2F+0v/+ZCnS1+un/gry4WGHiuSKE+c6UfjDr/iT/MhuFmedv3/Idr+iFiaTrKGkUt 353949tsff5sfe9SNnp6jxO+4nRcPWsAt0WKM0er6q9vLe70Avt3G4I3637P/V3dfefaD95f8hIxXj 3539501vJ+cOimh24hm+TGkB53Uz0YsYMw+dgn1Gm/7KT9RfuL9pf/NHCvRs7DG7jzlksrVTUttVnJ 353951WLL9Mbj1ebi0Zj1uFQv+/X1RfhOjWF3QpYv4RwO5or2LkPcd37LzUfkTFCm0sjVzB6asuoNi 3539527lNsmbwa6Vzhv/AMr0bRtwJU1FeD8y0fXN5/S/nWyLmIoU6R2HZ0Grx7bkJWvfbLIdpfftJa 353953InsCr7oejf8xWZciYUvSN2GwR3d01TOEVfAMpGTXSUhH6rsrX2xFjPcInMpVTQjy8q5jx66b 353954KOCJ5J5dlDoFXq6DcSRHnowS1X/AnhhLmAUtxdUbi+DlPB0Pq8TvLLuO4S6R2JG6EeGek5Au 353955g3Ubsvehp3kwtr+rQuHFkbB2mCG5r937prEMD5IGYeg25SSmdJ8tQdq8MPRLegRuM32AsOY1 353956tvWzh0PsbmQ1I9Oo7xwZwHwfhalkv7Uyczvie85AaiFfZhw2ISYsEZcLGog8UoPXW/rBxdkP 35395701I5tExCPSOq7ya8ybuMIS79kPylQaIDuDvfG6w+m5H+/CaS16zE0Q91cmOxO8qCHotraYvh 3539585SIzFo1cPFzVB2GL76nVdYga8nB2YhDitr9U6CshNx1Lg2zhNPQIsnnN+oD3GQfi2Ogufre3 35395922w8liHgm+bC/mwe+b5krEnNb5X8pUlpyDuPqX2m4qK4rxXXCB/5Zycgcs4NFAvk5zfnMpnf 353960bkNxrBlZLjuHw0zMMSBFebuF1c+xMsCbcBFl9JrTRFfSpHe5+mSHwvr4TZ3ypen31AfKlUii 3539618juY4ByMLe95ENW+wmo/DyQ+qSYf2oD8K4sQbqWLP37vCB2DHnCKTsJz8UBRk/F98hi4d9OF 353962vnU/rEkvlXxsw7cTmDj2sOLAE4H6bfIkBFh0hY6uMaxDZuJcXoNaxVH1ixUIjtiG9+RZwpIr 353963GOs7FGcKBP9XZVNDzgH0DVjADF7VWxyZEgQr/S7QNXXHoA3pKOaL+6T2HXaP7wUXs874w1xJ 353964X9dn4+SCBAQ7mEFPh/SbmSMipuzF41K+dNJdSkSEiwWMu+pCt6sJ7MMmYffj7woTScT7iD29 353965jdBBRqkpVYQ2CepG8FuZiRqZe0WCUjzaMQp+ZAx0DczhOfYEvorHSUHIJz+d//wdf1hNpK0G 353966qMlflrEPk8PsYUK1z8AC3gmrcPlrveTwqP92GStiXWFK6g0sfDBy+yN8/0WYz9xLSxHvbQlD 353967XT2Yug3Glkdlcoe7SFiP/PsHMC8hEPbdjWBkZg3PvpOw/sI7lCvZCEX8b0iONERH1niklQnl 3539685qPsOOjomcApcg5OfaiWOWT5KHlyELOjPWBhqIcuet1gGzQMK88xVgnSZ+hCr6sBull5oM/4 353969dbj4oUra1wrjTX502Rh9q1xpnUnPbeJ381BwZzsmhjvCTJ+Mo74ZHHuOwpoLHyTvVraeZBXR 353970yq5Rtu801YsaCnAl0RsWvvNwvaihReWxX5ffoBu0HR9k9hDh9+sYa/kHfu8hbYNflz9hN+Me 353971uEKRQhsl/fx4H6b3caa/Vc+IDf8hq5GaXaOkH3VJ/xnAKmA89mdWyI9VK56hSwlVAeOw90U5 353972XU9btj0/gKlhdjDW6wI9fVPY+CYg6QEz/+TWHSEqOvwuM24EaGsyHif7W8En6Y2cYpYSIMrS 353973xsLWaRY+bA8Cq/9pFDY27VVkr/fUgVHzv3mxMSi1BMKyu0h0s8PwM/ngi5/Z+P02Zrk6YMzF 353974IvL7LfK7PUadL5TsTdT+/ny1P6yjDyrdS5j9pAN+MxmCNK7iHFkb0gubm1kayl5DW019OIbp 353975CdNx7EONnJWcelBcglvL4jHhWLba6/5p4qax4BSiWZSgW6vRt7W1vdpP3BCB6utJTBm2ViLP 353976/JsLP/cIelsGYfvbWqUCJW2FnjoGdi5zWmXpqvR8oYhUc9n9lSjO3h7AYDY558yjsfVZuUaA 353977ua1ruaU2aX+99tdrf/3Pq1cFTO9UiDQ++yj5M/fiPIRbGxJZieDA3qvxoglXkrq8m5swpqcj 353978LMws4dZ3JvY/YbClgHMFk5zdJcCZlgnL0zEndDCO5/JpOas88wgSYzzBMjGk5XeP8NHYLJbz 353979KcXG053D4GGmR8u8znHy1s6ixhLcSIxA9OBIJOx8h9pme5KA+xInFg+CH9sIerr66O7SB1N2 3539803EZenVT25xddxfxeNjDS04WRTQQWXFZv7f4jRZP2KCe2KvBix0DYGxrCpu8K3MjnaSZHEXy7 353981c6gnLA110dUiCDNOZdPy5r5BzuhuQOaJsSNik9LxnciTIu4NDOr2G377TfHnL7dleFnTcp8I 353982az7j7MJoOJt0ZmRiFfNQJCzD3QXhCA4NxaTzBRJ5dfsIT4KbmOspfUZh2moMcDEhfWUIVgg5 353983d7KqWzx3qHOqPj8dB+YPQaizOQx0OuL335R9lzEGXi1r0zhenNEPw/dlSeYb1dbclEmIHJ0s 353984t86aK37UYdD2qmd0De+xNdAArPFp+K7Uq0eI7zfGwsogCDs+8lQrnW8mwtUyGoc+1avsd2H5 353985PUy3+wud/mqGg2Swbevws2bYuD3qVGFfZf9vvjfK4UddCpObwNqrD8asOIaM4oZm2FgHXqte 353986SvQ6wuKLiHNrHeb9N1ynCZHxPeMQZke5wdyA7OkGlvCOX4hDpzdh+OCdNDnYVl3Gz7qmJdys 353987Dn9RZ910RxsMPUH2XUL0vtnVB45xp5Avp6AmZ2DGFoycdAxfeIrPaOQ+xsbxC3ExV36d8vPO 353988YPLAJDx4fQKzZp9BHl+GgMk5iL6uQ3Ds2lbE2bMQsuyBRN+idnz4RUhbHQd3i260x82MY1k/ 3539891eOG0jFdnj8AU1O+KPUGozwx3h8YhbhV9xQ8yyiPsox1QzHrXDY+nZqKoZteKPUUUz4PqT7f 353990iIRBW/CikpCGuWcwLWY2LuYxfVzzejuGTjyGbM4DrEqYidQi1R5fvOJXuLx1FFz0ic7deRpO 353991Z3El51nzsRhAxiJ0+UO5sRDxC5GaGIVJKblK5Q7q7M9YPxBDtj1X8H4VCTi4nJiApbdykXV4 353992LIbvfIMamWsaviQjyk08D8g8DF/z//egZbzidmHs9BR8a1B8t6DwEmaN3IKXVfJnWWNJGhaN 35399324Gnr49ieuJ55PNFrXxvA74kxyFg+g2UNIraRVfyQ8RN3avV8HNnmDP+t2T0dhiM1BIhUZLe 353994wBgHH8w/uBh+5L5bJeX48uIZ8uubDotLBKx7YMnjEuQciwU7YCO9UYoERbg0cyR2EuWTQqfm 353995HUM/Cy8sTS9BQ2MdOFnP8J6rmoQRCctxb6oHIvZm05NQJOTi1gQ39N7P/L/i6Q4s3fMAXzM3 3539960vfcyHuPM4ShvKCEDGqr1xB1yOT+HQO/WQ/I+6uQscgT1rF78KqCj/q8q0j0tMOQ0wxDJ6rL 353997wZUT53Hj9Fx42CoRMKvfIHnb37iTVYw6MviCiiycmuQMVtwJeqOkJmUt5wvyyupooCFsKMPL 353998vbGwck7EE1lmk0yib8eGwickBGyWagFBGWDKPtQf9sGLcDm7Go3CRtSWE6FDxeIT8fNwLLo7 3539997Gem0wtUWJaGCXZsJBzIBJdP5kjNV1yZ5wXzXrvxmRwSovosbAmxgN/iNOTVC8HnZmL/kACM 354000kTmkWrNA67nFqBaINLZYKubWqz34s44fQOq7MjL3qvFuXxRY3qvxqrbp8CxHxsZIdDd0xpB1 354001F5HJIWNAzdFXF7Ay2hGeU84hr9lByPu8G2EWtvBm2WJ4arGcEl92HIS8ItxbFQCL0B34yGMU 354002+WX3FsCHFYL5Z16jhCek25/75CiWJR5AVp1IQWHN437GrR3D4WjZm1bQtVUBSwk7xTdmwM2m 354003H5Kuf0Y5Ne/45ci+n4zl85Pxob79iRsRLxcXprnDgjD1d8QuyC223dQaPg6BWJVZK2l3welB 354004cHAkgrqNTBuIwNaNNQBHc/kKbaT6jXt/MXxJPy84n0W7kApr8/Bg1xA42A7B8a88xT1HUIYn 354005ScGwCGbI4rY9oxzPNvWEZdBWhnDm3sFUctANOfgS38n9osYaFL26jbR3FQrzVZVQ39J4cC4O 354006BttjKZ7XyBKRxUgdZg23RU9RnTEPrnYTcEf8DCp0QZSjG+xdJ8n9LdyyFw7kNNBz9PvNmXAh 354007z79QKKD33nuJ7rAbcZY+9Kj6UlLv6jgOqRyB2PJxPYJtorD/s3LwJuQ+wBIfCwQnPaeFoubf 3540089WJJIPrs/iwndMleU/MhGUOtdQig6wAdm+E48rG2XYWCf5q44WVtRqD9KI2v137iRoXCR9DY 3540097mPzK5eWFAXM3ygZaXirxlXVHi/dXwlgeboVMU5BmHPpE3LSViDCKQKr07+3eN63dS231Cbt 354010r9f+eu2v/3n17XH2Cbm3MN7BFYk3i8EX1oPz8QORi5pkrQXwYvXC8ssfUVZbjYKMw1i47A7K 354011hMx+U3x9Kty85+M+V8jgmQOx6LXiGR2FgcInE+2sELM1HblVDeDXfUf2k8tIzeTSeIoO12QZ 354012jC2ZVUS2r0VhVhZKmoH/Ru4rpJ6+jW/NyA9+QSqmu1siYOZRPC2sg1DIR/mnNGwcaA/r/rvw 354013tpq5vrH6G95k5aGKzwfn8jg4ei3Fi5r2P2M0bY9Swofg8L5Wgdj8qhwFF8fALXy7RmMnaihB 354014VlYhahsJuXZ+NGydZuJRlQh1dXzy/np8PT0CNs2wqlyb889jHBmfAYc+oV4DPJi5ygs6TcSI 354015mWodBt3vVdl48pDI5wLl85bWZ9jaYezZr6jnc4nyKhiWPXfhE0+kFoNWZW5BpIUlIuYl4y75 3540169kqeAHWU8pw1CDe47TOutW+3IMymD3Z/qBf30xkMs/PA/PvclmVGFRi0veqpUv1sCXxtPWFn 354017l4DTBUpCSFE4Y7gDbNxsEbL+ndKxpXQWOclD0TO8LxY/qFT6Hmp9cy4Ng7X7YtzP2KhSDpXg 354018Z3ZPLDr3BqUS/HwMy+cexPu6tnuVt0ddW4kbOYNDQQ3Rj93Evqn+6GE3Cim5MjiTYF4zh5E4 354019L1YAyxI3muLVX/46/nd8+FAqp3ymdADcz1ngNOHyh8sQwJY+h9p7b60JhdGfVhiXxlVrFf9P 354020ETct4Wa1URQ+bEMgOwFXCcHaUPIMx+eHwdx+Gh5Uab/32n+h0OT2k9M4k56NsrxUTHa2QcKR 354021bKUklDb1ScW3L0Tf/M/2gbA0DTMiJtNrtr10JW0mbqhOyTvaFw4Jl1AsFOL7teFw6LUP2USY 3540225X3cgSDrQTifvlGpsMT7sJ1sIgPJJkIEt9dr4eswAfcqibLv1gIMS3qqlK3kfzuCPlZh2JfN 3540230wiYU7E853j4YqVEeSsE59wA2PUjRIdARDPVn1LXYVykC4x0zRGUMAeHnhQrMI0/RNw0FiAl 3540243geT75ZDVHkf05zcMD+jWtp/x6Ng0/co3Z62vK+WEGc+pO+UxcEU1nOQsbM/nCN30Qp/ieBd 354025dBHjg8fiRFpSiwobuW+peYllPl5YIG5/i0Lhx50IMfHAiswa5v+fdiHYeiCufBfJEX8+TpPo 3540269tOukawYnCkSygh9CxE84Lhc/zTFxL2rpH8EVV/w8NQGTItyRjf2GAVLPpXjVHEHY9jd4BI1 354027DRtSHuJLlfowB1WP58DNlQEZ9GGaNhX2ZqFIesxVsBgWVr/Cll72iD3yVTK3RKJ6ZG30Bzv+ 354028GG5uCIR13GkUClSPA71GHMWeS7yP2BFqjegj3+TY9JaERJo4XOoJ25FXUSpsm3BKkWubg2wk 354029sXlbo9htC3GTVpSDlPHOsOy1Bg++N7ZCCI7HjlW94Zv4EJUUKdqQg4P9vDB62wKaSJa0wToK 354030q4lwG7iK8SyTE5J4n7CrJxt9D3+RFwAJCZE+2xXO0++hXEk/MvvZeNz7kWe8SYKf4wRxDN/t 354031CGLHI7VU2CaFhybjQQHTsbYuSHxUJQWzhWcQz/LGmle1RKlxAyNtPLGc7KXUPlp6ZQT8xxzC 354032lphQmb8NhbXnSmQ2kZmUBepUZziMv4isO/MJGT0EKXl8mb2xBGnTXeA06So4Ve+wtZct+u79 354033qBy48Qtxcbw9IamTkV2vfJ1UP5kL/6jD+MpX/u0bw7wwftcuQjhFYeeusfAK3yozHprtE3xO 354034GpbHEvKPshDtagqX2BW4li8DitjR2LJtCgKtDKBrwEavxNP4XCuUUew8w/7JobA20oWuIVGc 354035TCOErlj5IyhJx4YEV5hQHn3OA7B0eyK8ZcZSSProeGIfOJh0hZ6RDcJmnkCWWMFCeSiNtJSx 354036MhSHNOFz7mLdQOqZXWHqEodlO6TPZNobhY3rR8Orhz4MbGOwQbx/qQOP8sYR9fhyejK83Ebi 354037yIcaxevI8zesHwOv7nowsIvFpkdf8WL/GHj30IO+dTQ2PJF5H7sv1q4cAlezrnJtofum9BF2 354038jPaDpYEuupo6I3rJRXwRK8eYe/th/box8DHXV9rv6vqWvp8VibWrRsCL3G8WdYK2oMo8OJGs 354039O0Pokr4zZvliTDJDCirra3Xg+uPOUNgPTSUyUtPeX42MeR5wn/MYRWdi4Rh3DhzKyrg2E6s8 354040usBs6BV6fxZVP8NCb3+afK7/tB/RtsFIesFY+TbkncJQO0/MS+ci9+8o2Pc/ITkjRaJaorTy 354041hfOUu4qea53/xO/d5JVG9e82wE+GlFG+N29GgM1Q2tOtvYib0vTV6Bc4GgdfV4o9C4Wo+XQK 35404200IjsPBGkdpnt3Uta79iXfvrtb/+1yVuhJVvcHRWb9gZkn2K7K863ZwweO8HOZmAlodsFfci 354043UWMhUgawEbj1vZyyQigUylxTirQZnvBf8hjcsntIDBuFs2Jlct3bdfCxjMWFYqEKw5F0JHp7 354044IfEGR0HuphTLRbc3YlSoC9iWLNh79cWskznMeSEowsURNnCamorMa6vQ37EbdLuawXPiGeRW 354045ZGFnOAuh297T3yjic3BzbQI8LY2hr/cXOppLMQxtjFbyjSgZCYlUVUzInbYB/qb2sPz8YP4X 354046Y6VPnalx6x/ie7V8e1QRN/0o4iazHPkXR8HObUGr8LJIVIesXf3gOeYCigRU2Jft6GnUER0N 354047A7D4bqlSj0thbRZ297OE05Qr4Ag0U2jvD+sq9WhRQdw0fDuO4Z52hFSQ+fGfhfuV8lhAqvRU 354048IuM3cPGthDH6E/GrUFwljoDB+4w9vczhl/RCzlK8vgXiRliVhZRF8fB3sIatezgmbLuHwooc 354049XEkajV6E3LB2CsTQ1ZfxVSz/iEQ1eL2pJ+yiDyK7hoMrE5zgNpshK5uPyR05/Y1qDNoe9U04 354050584UF/ivuo5jCfaI2JetoF8RFJxGvFMsDpyfBx+/FRL8IPecutdYFzsJZ28mIXYikaWURrD4 354051iuRIC/iuewuuGnzI4Gcb9D+a2yr8/G8ibqT7XTGuTXSAA5EFuRKcGYOkxFCErXtNe2nJETca 3540524tVf/Tpe9iHE2vpibhqzV9Nk3YPV6GkTji1va5nnhFnLPUdYkYH1MYHoE8KC3bg0ev38asRN 354053S7iZ8bzqSLApwXOGZnAIn4G/31bJkVBpeVTIJkcM3HkfedUCCQmqDtv+cJ2+DnTImde8bkWc 354054F6yo0N66xrALn4XjYi9GAecW1g4NgZM5wdFdCFY0dUDPcVtxr6hB+twBlPemHroamcN9wApc 354055fPkAh2ZEwL6bHsHWNghPPIUP1Zphb3lsbY2eM45JsHVL2Fuj+ur3SJkfBWczgk/1zeE7cgce 354056fxdotP41wS3Sb3yKPeP8SX+TsSBnewfDCOz6WC+5PixkCS6eXoFYZ2PodQ/B4lvFEj2eOozd 354057HvWNZRnYPT4IbCMyPqSPek5LRqZM3jReQRpWD3CBiZ4ujO37YtGlr0plEFXeo9I2+NNt0DNx 354058Qt+JUzBgwFo8qRCq3Ufbq04kqsLD6c7wWPyc1ieqw+Yt6YsyFrrBZtQ1WhfA6N+fY7GXm0RH 35405991trrWZF5bcxxlYf+vpdofNnB3TsrEf/rtupAzp00oW+7Rgi5N7FNEdr9Js6GA7Ww3G9mRst 354060Zd001t4Tix5wkH0kBjZhhFwoeYLVQ5fgnooYs4LiNMx00IG+/xLcLua3rGSjQoBY98c5jvR5 354061Nc8Xw9OV8RCiiJvPlynixhVGXSjiZi4OZ7QvcSOkYrP6jMUNiuX+chC92Krb09r3UYLTx93h 354062YEfsp8kyWWIjorsuOnX4A0aBi3FLJlEaFQPx1qxgxB/OQaWSCenXVRemZsYw7O6MvonH8bZS 354063xo3/WzIiLL0xefoAuJsbw9jcFVFzT+JdlRIXanqCesI0eKeENBLVZWFHX3ck7HlOew40Vmcj 354064dY4/fGffot3jG7L3EuImGqeLpIu5+ukCeIj7p4mwUehjXgneXj+ApSOCwTI0hVv/GdgkQ75I 35406556uKHzJfJaRPykZMjyEKPgMWgkcuxYEbb2mPFvl5eBML/GwRs485LBlhwhKhOyiw04DCG8sR 3540665WACI0s/DJs9Gp4u45ByfDjsg7dJQndRSrqVnlaIP1uEmqwtCLDsi79lvD7kPG7q8nF7eTDc 354067xl6igU5j/kn0s+6Dv/MErVJQ0f35eDZcPRbiWXXbiBtB3nH0ZUfiWBve3WripocnhkY5wCpy 354068IzK4ja0Wgq++OoZYr/FI+85s2qG+C3AvY6NCG668TEaM51hcLRHKuyUXnEI/dm8cyVXca6oe 354069zoCL2BpSTpHN/47HSUGwDGXmfcvPYMI+yHvccJGxgQgYkQeRQ9a1sOIBEp2M4TxsNZIvP0JW 354070YbVa0qwtxA3tnTjNEQ5TGQGf8hTMOxYFq8AtyKIslAR5OBpphbD9OWR/rMaTOYGIT8nGyzVh 354071iGr6W6Iz7CbeRblM26jwJBMdjGFqZIWE44rut40lNzDV2Q59Enxh22cXbe2mDOh/2B8DK6cp 354072uKLGYkFUkY4ZvrE4nqf8moaaOgioEBzOFGgWoK62gfFS/PQ3OQMSceu7UAPi5iFSTt/DJ24D 3540732XfykDrDBdZDzqOosUlo1oHjhBR8qm4Ej3MfSWRf8FvLkIJUvrVzw2xgP/II3pQTgZlfjpw3 3540742SinjAj4eUgZxIbjxBR8pu9NR1KYCTqJQ3tQAOwqAeQuE04iq1KAxsp3SB7iAO+lTyU52xQE 354075fPLMUwPZcJ58hgD6RjSUPMSG3maSZ9Lt1TNCz3WPUdZQjczNwYQgZQwvNCJuuNXIOjwcrl5T 354076cPZrvdLrqOeHrEkHp74Cz9cHopuZN+I3PUAx/f8AWITvl7xPVVvovkkgyrCxJ/FR3DerQyzg 354077v1ZKtlL97qCq31voW+Z+PXjOvUp7egp4PPqs62Phh6QnlKs5ObvLv+LdJ6nbefO+Vifc8bL3 354078oJf9IFzgMHuYqPIhEt2I7PO0GrxPO9HTdRKtAOIT+aCfvSPYHonMefdxB3q6TaEFVMo6/MuR 354079eNj6LcPj4mz8HW8L36WPaU9WWvHh0BfJX8UKI0L4LCIC3uyHlc1APBX/2AfOY85KXL0pGSjr 354080YAxY3qskChNl+0Uj5xwGsj2xRANvmNaCjbaUtq5l7Vesa3+99tf/OsSNnNzTyMHlsXawTtiL 354081B+lJ8LcfhbSCfLx7/11OwarqeevjvWCu8xe6OfsjKCgIQcG9MemkNOyJqPop1iREIDzYFRYm 3540827hg6lpw/bB+EJazB02rKs/k2ptoZwnl4Ek6kPcPnklr5UMj8YtxZ3Rf25rboPfsQHhXypOFw 354083KaM8Vx8sSstDDb8B1ZwsPHtbSre7kXMWA1iE6HiQinF2Dphw9gvqhALUcqloBUJ8v07ID9+1 354084eE1kH97nXQgx74k9H6tRkDoW1iyppTU3YxvigqbhHucjDk1ZoFRxoUlpak/SmdXifhSi7NYU 354085ODhOx4Mq+fYoxZ3CKrw+MBbePQxh4hCNlTc5GuNlOszd+ekI6bcGD8pkkrZTBiApw+Hgu0pB 354086cU8pZe8v8YF54BpkVAhV7uXN33sxwVQalqwFjxuG0OLg2gw3OIw4hdwGeeKG0leMJ6TO6JQc 3540871BGi5gkl4/faw0SKqEzH9KA4bMvgopHIoPOnHMJH0neC/BPoaxWKPdmKETxUETeUUpZStNsM 3540882ocXZP5Vfb2GRf7msLIzh+3AXXhcWIP6stdIHuGCgJUvJLKfsOYVNva0R6+xsXBymYobJfJ4 354089qTpjPtxdZuKRbOQNNRi0PeqZuXYeg629sDKzGkVn48HyTcKbOvmwV7l/94NNZDK+lT3ELBd3 354090BcNQOql7+myEjiKETTV5Z684iayjsJd0D8WuFjwPmvDz0TZg2H8bcUOVyvvT4Oy5RA6rXnt7 354091GsP8xiKVyKSyxI2mmPdXv44mau6vRAg7CMvuFeP7041EF+gjIXKo50TJPEdY9wnJI0MxIeUr 354092Sh/OhIvnYjr6xK9I3KjDzQq6iHUER4kjtUj0HU/3IJToIWX1bC1hWz7nAU6m3MXHpjqinJbW 354093qbvvPo4fu47XVAQaXgGuEXJN7j7qmWXkHOWX4iEVqSSQyV/F5zwiz7yDLA51BhP8Rfa8E5Nd 354094YNGX6ESoKCQ1Bfj4qQAVlLccwTAf/h4Miz8J9p6cgg9E70dH6xnkAL8VzB6pgL3JHp795jOD 354095vcXY2nnccRpbCyrf4GCCHTwXZdAOBC1h75brS5E21RUu447hbTmf1nuen+EBh1GXaIO99iJu 354096KIOMCyNtYDvsEF5x+eQbi3BtmjOcpsoYBxvbYviRLFTzK2n83SOE8RptCWP/cL2gEOeGO8F/ 354097wTXkEjKn4ftT7OxPrp90A6WU0WLDVxyJsYJ74nUUEPxdfG8ZfC3CsPMjrxUGKfk4M8Qa9mNO 354098EMKOYMIP+9DHSAfuK15K9AT/b+JGHTZvSV9EG2/bjcRVscF2zYul8PGcJwlX3mriRgKecw4h 354099xn0EzhWSyVp8BeM9+2LP5yaXRiJoPt2NUR6G6EgEpw46hGUcloTreTyJAJd/dTnifF3gET4F 354100h18V4eWW4Ui8mofcG6sxOCwIIVGELRYzsKKGbzga74SwNddxPSkCNn5Mrgvmg5bAx1fRpZz3 354101fisCrIfIWWbVv1sPP9uRuFVOhUrbjiW770tDpeVm4fSaFe0WKo2O3XptFLyHM9a2VCgbZe3x 354102tx8rZwmjyfvokFW3FsK3hy+WPVYMmUS9u6H0GfYMtIHztJt0bFnqbxWPlyCkzxa8rVWcdI2V 354103OXj9qYQGE/UF6djUzxKO025LLHd4RDjzJwou7/lX8JVSBJa9wN6B1nCecUchZqWw8gFmO3RH 3541041DF5q5aGvAuY5qaHPzr+hU5//AmzPuvxRKyUF9W9w8bAHvBdeB25teT5359jT7wF/rIYq9S7 354105hiqn5veHm5kRbHqOwfJDaXhXymtVnFNV48YreYcbB5dhVKg1jEzd0X/+KbG1zifsjbJF8Mr7 354106kgRejDARjsNkcdICPlG+TTz3BTWEUHpIBHwDi9G4nE55UEyUeEZVP5kHZ8t4nCWHJxUDeEtA 354107D4TtZdwaZa0m9PX10PmP39GJPVLi7kxbHFoPVutqr2oNU1aFlCfHvcrm7xH/GNhh3J1yJXUW 354108iCJkH+0pJ/NuPiFyBliRekL4dbGeQCsglT6X+qEtCDUnbvy6EpJW1xyxBz8QoCtqvRBcxsGl 3541094V4YcvYTMpb4IzjpDW2JpbDpcstwa6oXIvd8pslMqZWd6n6W9YhRZ+WiyTPkx6Iruvz5Ozpa 354110DsNJGffw2pwb2DYjFn42RoSQ7QQz/8k48q663UKlNc1JV0Ji3iBKT8pD6UC4lWROUiTx2/V+ 354111YA+6hOLaLGyJiMCW9/WouDcF/kPFfwtgIZaAODllB9m3/47pho5mg3C+qFHJWmsEJ3UMrAwC 354112sPldndK1WPFkFQLMA7AqQ36fUzg0qVCYE32QcEbaBoVrJMpe5v+UoneEkzPGUHF/2xBvtTZz 354113Bbydp9Pu5vQYmlFAXcat//YEOHgxVoSNhSmIYYXQwFIBTJK6aFZP7BWD/KZ72eIY60KiOB9g 3541142xvJ3/hypLaX92JJeLvm49lYQJ7JpjxUpedZ+d1JsLaSISwsopBS2Ci2Il0DX8dJkjmtlrhh 3541159cHqpf3hFEjO4cIG1WtY5vm1mSvhYSE1XKD+7y3zPlVtob+DFYrdn2X69dZ40q/L6X7VpN/V 3541169S19f48Iub4V5J9CfwtHTDj8ENkUIGlhnakT7mhvv972iD9TSIOQivTpcPVZThO2jFeNL1YQ 354117xUZJ6nAETjiApL4R2PiuBoWnY+EYfx6cJoubBkLEDbUjxI4DLIkS65nYYIIJNeIksWatfJQI 354118N8+FtDJS1iI8L2UUnP0WIV183vI+7EQvow74vYsLZl7nSAgZpd6aohq83REJkz86wCBkM53v 354119IfPEYgzyt0WPHtbwipqEpJRnKCQEStXXu9gxe+lPJW7aupa1X7Gu/fXaX/9rEjc0ocAOpsG6 354120snskBlhEjvyjg1i+JPLKbcnZnobBbD+yd9a3IN8LUHh+BCyNw+mwrrKyRvWny9g4OQreRKbt 3541212OEv9AicguQ3jCxHRwSwjsel3G+4s30k3K38MOtCLiMfVdzFBAdXTD3xEoU1jYo4lJ2AC4+I 354122LKjEa1HOe4PIUXsHO8LExBGRowfBzZmRqb+cnwl/1wTsev4ND9cOxIQTDCF1bZiVQh5A+ocQ 354123WH+aMzhX0WKVaQ8VDYOSOXV0OqGzeV+svJZLG6LJtkfjvVjWOE52fGSM4ygF2/u/J6Hv2P3I 354124lDEI5HCqISDETc6pobB2apawmMrbem4M7FhxOPy5Xu1e3nzOVL3YhD6mHZUSN025laTkUC3e 3541257+sPO/+luC8+H3eOj0SAb0/ETdlFt4Nzex0GeVrA2IjI+BGJOCXOrUaHRHtzECO9gjDrXBZe 354126Hx6J2DWPmX5mxeNyMyOCphycHTp0kP50DcSWrHpaiT7QOoD8LpVlytLGwEJfPv9L/dv1CPKW 354127KnGYkElJ8O5qiZEXi+SMK4TlGUgKs0Zo0ks5zx91GLQ96um4/of7oLs7Y5xGefDHWThhroxX 354128v6ghG/t7WaInFc6ekt/H28Jx5n1UyGIIQuheGOaBwec5RH6qwfPF/gjdKB9SjfZiXuCCHv3+ 354129Ri5fPbbVFD9rjo3bp66txA299tjK90QpzpwoL9dzq/FsWRDCN2ehVoa40RTz/urXNe0dnLR5 354130REdmAase7ph2SZovTFaPQeVSuZLYCwN3vqLXR3Mdya9I3KjCzeqif0g8bgreYnNYN3TznYrk 354131TK5KQyxZbKtYt1xN3Qr1dS7K6yhPzkh2X5zIV06o0obj1tE0RqTzEz3ZhXFBNuim3xVdqTPH 354132QN6gmMbHPmLCTw32ZrB1OA7JkMFUaHgPgqGe1bSMvVuuv4B4u95yZDNlpBduN0gSRaU9iJvG 354133wtPMN36SfmPVI4qEXCIhIYM9pecrHe1IvC+0hLF/uL7oNAa4jcQ1mbOQmps+1kPpv9FkOquX 354134RB6jvaejWQjdI9Y/aWB8z3x/MP39ovrPODI2BtMWD4C9z0qJnuD/Tdyow+Yt6S0Yr0BHjLhc 354135QuSMGrxc7gvvRVJD3TZ73OhRrlh/dkFX0nF6Oh3RoaMO/XuTB4PkI637Y2/qMSwM7w4TyjtE 354136SVxY3sf9GE3Y0lxOGsY5BWD960oUnEkgAtJe+nr+12T09ZzKWJ8KSnGXKGLNPWbgUl4F3m4I 354137hvuMdLnDXrrQNfNwUVBUaCCISq+VCUciDlGjTJHYXh43NOl1ZQ58enhgxqU8tTEMa54vgrsD 354138owAT1bzC+vAQLMuoVBu/U9ZKx82ZiUNMky50+5t5xDxbCHeZa5omYOm1MUQxNhypxTJWVTWZ 354139SApxxIBdGbQXC+Nx4w2HYWdQIGAE4LovqVge5wELYyP0cInG7GUj4OoxT2VS5PVRbBh0c0f8 354140nO04n5GH6sb2iWUoaqxGbsY5bEscADdjfbCj1jPzlLKIs0nAVZlwb01A6FqZSCGMA7052Y7G 354141pbT58BQfIox3gx3MB56jLQ+o8Xy/NQCmAYx3g3KPm0DYxTO5jP5pj5tIdqScV0N7CSmKh9cg 354142nLiwHIHd7TH2VI6coK5Z26nDYzI8/QYjwqU3vUGqakPdu40I9Z2H24+lHjl0P7fS40apdZea 354143Zzh7MMKBnAKj8i0ODiQk9aa3Cglu6XAZnBf4e6ITTEN2yoVAVLV3KCOwm8Cfv4OUFKUt6Lys 354144MeQSB7UfdyCE1U/Ogq7q4Uw4Oc5AetYpxAUwYQKpA3mg/0z6b1Ri/J0yQgPttZMyFHZuIzA7 3541452hZuiXflwjdoMpaUx84UJytE7/tAJ7JVd19zolwT4uZktJHSBLiSn26Dmll/1iL73CLEeljC 354146SIaMvNNEALDlQQUNAhzG0X3MjINy0KGsjrrX165J0UDq9ZqdQRRZajNRomBpPvYtPbO1worc 3541472jQ0QA8jKww8/lVlTqGWAKemwpHS76BAmj0zd9vS74r9QPZsOaKCSnK9FZP7ecCc9DkreBx2 354148PfouR25oTNyQdfAtuS/sY08hn8/FncnO8Fv7mp7PlIyQNsYZ4XszcS8xCEMv5uDZ0lAMOPoa 354149aeNd0GuPrCKEzO+0CWD9aYTo43nS5KSUcufmBLj23IGP9VRePxf4rsqUSVYsRM3bHejrEIkd 354150b5slehVw8WxTKCyCmLNH1XoUfr+O0bZOmHalADzKCKT8HuZNTMKVrBJUV+ThxcVtmNXfE5ZG 354151xrDyHYqkK1/+78SNJmtZ+xXr2l+v/fW/JnEju0+3dI9Sj5s4Vxh36gILjwAEBYUiYd1TVAo1 354152wHTNFJ1NirHawmc4QuSsbv5M/lUa/5gHYvv7eonizNZZHL2BnBcFaRswOtQOxrrd4Nh7GvY9 354153Yc4LipCKZQVh68PLmGhvh9GnPhGcQnnccGkjOS5RzNur8XChylzn7gjf+Q41lPd13zkqo1Io 3541549WRqhk+b2pN0dg3djze/ZWB1qB8Sb5fRhgWatKeldysN20TaMcKiM3TFMoyh01Qalx4Z401I 354155NEOYkvNpwaVcufOu5t0uRFo4Y9pVjoKCURNPBEHlN2QcnwRHlmqPGybnyUIiD8TTie/bZuzH 354156Q/aReLBc5+JRzlVMCJsl43HD09jjhsaXVDjxMnlZx1tPDyxnN7i5usLVxQXO9hYwYI2U11lQ 3541575yHLD5uy6mW8xPJxZqQD3KenoqBBNrSUegz6o/X0O+qzsNHPCC6Lnoktz6lQht3BGnuDNiSV 354158KNDNArD1PU8cbnkYLG0m4bbM/G7IOYDedgOQUtAoVaq6k36WCQ9P58+1tkDCuSKloX4VMZm8 354159oc5/2+NmKpyaedxQz+LnHsNAv4m4+u6c1ONGQ8z7q18n2T+yDmCglS50zfthW2aVRPZlSILe 354160+PtLKTLWRaPP0ru05b/kOeL+UoXZ6ml8MVYtrmvbNS3j9JaU+c2jf1iEyHvcUHXCqvc4v2IA 354161HExdMPE0g+HksG1XhgxpwrYiYR2+pK7CkEAHsKxYYJkb4C+LpjrVmJjCPiWPDyAx1gc23Y1h 3541620OyZOZeWY6APi5AvFJ7VQUf9MOyncuQSIv/blTUYTvSFPYz0Gb2yTL2Q4I+pTo4Yl/IRVQKG 354163bPPpogwfM7rPFrG3vh4sHZzg5CT+sWehh/sMOmRmS9i7xXoqbUjzevI+HZNICZnTHsSNKpzb 354164hIPpUGmhSZJzvTUY+4fryT4fEbxSzptWyDmDGGtmH25+v0hUifTJjvBcxnjLaFLocKbkGWml 354165pbiztD/GHvkM7pt18FdBwv5fiBs12LwlvQWtN/g7Gq7DxZ6m/n5Y9qJGcu1vbRJU+Lk40scB 354166g1MJGyQsw/URjgg/kKM2zBjFtnrZj6c7Ue5ZDd9wYuJYHCYCDq34FlslMXk9GAadEpr7eE2X 354167uIdTLPnVWe4wsXSHg01f7PmkyKSKqp8g0cNPJkF5U44b+ZwpbRVEW+yjZqF7mBw37lj4VDbH 354168Tb9W5bihN8mT4+DUwx8L04oU+luRfJkHV0cmARmdXNOoC4xMzWBmRn6MdWmrMkOLEKx6WaN4 35416971NC3DhJk5eJqh5ihl+cXA6aGoq4cZqOh7LEjSCfCGjmsBPHG5WSc2QDYyvJcSPjiSIvDPOR 354170ezQKzkMuSayOlVnsV+c+wZktMxHrbgYj6xCMXLof115zCCgSKRJryn7EZBt1WHBeXcX+JSMR 354171wjaCmXssZm05gye51RILft7Xk5g8ZJWcNTMtoFsEYhsRPikBcpwd43FTyyvFI3JwGvbojzWz 354172QhC6+iWTBJXKJ2LZER27GMPUjBkLU8O/0KGzF51PRNMcNzGtjNFLWbw9/eEcN++wIcAWg84W 354173ygGpn0PcUL8LUHxzAXzNnDDpnBTUadp2Ks/VfKfOMI5h4kyqagPlSnt6sAdilkyHjyTHDdXP 354174LJXxdJ2mysYNVhdPWdUzXGA/4abSZ9S9WY9ApzG4UqI8Ubqq3FZK3appaxOpNYScRYS3TE4a 354175UT3ebfQHa0Ayrq/1AzvuNE2oSg7a4lQMYvti7uZh8Bt+mcnDwfuAbRFh5G9DCEHDEIIS4rzg 354176LEbau2NOOhe8vFMYYuuJBQ/KlXovKJ1rvGwkx7FgP+4CCviazVHZ0JQaedx8bJ3HjYAAhxgr 354177H6xI59AKbOpM87SR8dzoLg2NQffxnYlwbLI6ocaBrQjkJd4xzb1CyL1NXiGUNUl/O6lHiibn 354178VJPHzX41HjdtJm5shuDs3V2kTV6YdblAMrd/BnFDhzVgNetX2jJlOV7WatDvLfRtSwYMQl4x 354179nu6KAct9kYx302Z5oZnO6Sc92yiLKxdraT1FeEfbR+No5lWMcwrEBrFVOCUD5J+MhkPkcszs 354180FUXn7yu/MwmBA1dhko8vlsoIakIuIUs8bRE5oT8cnCbJhQ0UVtzHTI9grEu/xBi+yFidN5al 354181Y6GvM0am5CmVF+peJ8HHdpREeamsPyjBOtB6EK5xpaBY2MJ6+b973HzUfo8b7a/X/vp/K3FD 354182na39LIkc/YHXJuJGxP+CQxFs9ElWnfuxtfsQJWd5WQ8Xy4gcXJ/tju7eiUjNycfD9X3gOSqF 354183NqaSO8ur8/BgRyzYLnNogzM6hMlwGzhNv4zXN9dhkEcPGHVjIXDGReRVvsfuPmyEbMmiDZPo 354184MNc9pAqeJnKDl5eKucGuGLDtEbIuz8GARGmul9Yqnpvawwrwh6U1EyqNm54Ir4AVeFqcJdee 3541859iRuWlsauelY5G2OoKRncgSc3DfK5J2RlcWU9YUq4ob35TiGOngiMa1EpfW5gsWvrKdXIxfP 354186dg6CR+g8XM75itSZMZhzjSPNcbP2ucY5bijr7Vi2vKxOyWysbqot0dURNw05+xHGls8byxhi 354187qMegP1rP6B4WwLnT7+hkYMLoG8xMYdTlD3QwiUNKvoAOgfwmyRs6vxMdhKxO4g8LjLpaKvZm 354188qsWrNV7Q+UNGb2Gij04dLTH6aon4GgEKUuJg2rGTVDlKEbNmajBZCAuRBxUTd4sIkdqSUeu/ 354189K8dNCa5Pap7jpik/ZSUezQ9AxMK16OvWOsz7y19HGQFnH8NIR0eMPJaFj+enwp0Qs/vEUSpE 3541909W+xzq8H3KIjEDr5DHJ5IrnnOE9jdFcMdg6W83Zr8oKz91opE0mhva5pGae3JMu2lONGztDx 3541915hQ4io0PaGxr6YlFtwpo+Zk++2yZeSEgGKo/2VvWPC6jz1bZvVYdJm4sOodBNr5K6+ioBlbe 354192WH6viNbV0WSaFYNXKbw70DkSm9Nz6XBoEkN8S6ae0SUyez/djzdGwcKkP85ylBs0qMXeFLa2 3541937YeT+Y0q7lWPvVusLzqLAaT+VEGjRud1mz1uis6gP1uJ14vPKonHiSripiWM/cP1lMeN+yhc 354194l/W4IcQO5XFzVcbj5uAXvsTj5nQMW+JxI0/Q7EIfn6kKui/a44btj8QFgxG78j64jUwbHMVr 354195pynvfhOGrXm5DO7iuagOv6u979NOBLPjcbm0KfpFKS4PtoKrmLhRh81b0lswY3oOQzyH4eSN 354196lQgMlN8D2kTcCMuuY4RjLzoMi6iGCvfhI6dkaCi4h9Npn1H6hpkctzgFuLnUD5bhe+U8bqhD 354197t+jSTIzc+U6cKO0SBrM9sexJKbL/JsqSAMbaiVLi7etni8B55/G+nA8hn4v35xPhofsbOloO 354198xbEcJcQN2YTvTvZA7/2MmxL1/9sT3RGxN7tFwkMTQbRpMakkTehk2YfwRRJPvgpPFnrCJm4/ 354199XlcKiDB+DXM87TD4dD4tMFIDx+fxUJlJWDe7EbhRTIgsHl8aR5ko3t/sT4C1eTiSHpQpJHEU 354200CSvw9up1ZBYRwYqyzC96iK3RVpJwZ6LGepR/L0FJCfOT94AQaSxCxGRzUc0XQlDxBR/yqkhb 354201hOBxHpF7LWEz5ookESDljvxsRU/0XJzG5AIof41Dg23gMDlNYkFDL6zsfehl5i7HDjZZxYy3 354202ZWHgvpcoI+8T1n7FlXmeMA/bTccKZrxLylBazSffwgMnYw+GOPlhyZNKtSGSpN/PQ8m7Gzi4 354203bBQhXgxg7LdIpaeOIsmXgUW+xjAgG9+oZQeR9q6UPmg0upf3HlsDTeCx/CkR0BtQcHUJIu26 354204wcjCF0Nnj0OAgxcGrkiVJOriXBwMC/YonPtULBmLkqJM7IroDtdFTxU9bnhFuLcqABYh2+kc 354205OYyF2AL4EKXs4vNv8Z2K89lYg4KnJ7Fi7kFk1TUT0Kiwedxs3N01Es6W4dj6pqbNQia1XjmX 354206J8HJOgbr07JRSccIrUb2uYmwt/4ZxA3DPBddTYSnmRtmpDJKYrreegiucqg10vTTAIEGhJRS 3542074ob0UeWjeXAzNoaelTSuONXP3lYhWHjhPbjUnK0rwMNdQwlZnIC/c3gtg2Q1z7C3isLeD/XK 354208CQYq0WY/a4Tv+YyG/DTsO3QVrwoZAlFQ+QkXEj1g1S8ZXxo0cKvm5+P0EGs4jE5GJh1KkJCd 354209X29geYgVApNeyVk08D7vRk/T7rAzY2N4arG8dT4VPi2sGwzNrQjoYQRnEZ3vxhWm5kZgj06T 354210hEykE+COcYDrTCZ/FRU24evReNj4LkdGpVADkrEKz9eFwMJnCR5wNc9XIWosQEq8DybfLdeI 354211uKHD0BGF79jIRNzUJMeN2Op28ysyFvVfcXGaE7rI5UrRgdPk0/gszimzrpclfFdLc9ycHUb2 354212yzHH8K6CyXHz5a00x82pgSxy71lk1zL3rg83lclxQyWddYX3jNPI4vLpeVVX/B4P72TiO191 354213jpsThPhymXoeOdQzSx9jU5/ucrld2k7cMB5tlS+2op+tL+ZcL6IF+p9B3FDfcZL0jeNEcb8W 354214M7Fgm/q1xX5X1rcRpir7gR7n0he4cfcdiuuoGMo1+HRsCGzFVngSEMGKxNGmGNncmxhnY4cJ 354215qYXg1eXg9Hh76JjLxh8m83KALTz6+8MmZBvey8hAVAjSoG4GMJIIuWcQb2kIPevxuN00T6k4 354216yTNdydy5gELed9ya7QbHseR3vvRszljoDRsvB0lM66a1f3aMC3zm36XXoSbrSFPgoInc9P8k 354217bjRZy9qvWNf+eu2v/0Vz3PBzcSzWHJb9t+Fm2kr42o3EtZzPeP5KPu+oSiUlLZsSRYXtYOzJ 354218KCHyO5Fzsq9ix47HCqGclT2jIe8G9h5IxYu8SvCFlMychTMz3WAevkeCT0RULP6tRI4hyjE9 354219vyS8ECcgFlZ9xoMnn1HOZ+RVzvXpcJGJpMAvvIyZnpYImHUUTwvrCOnNR8XnNGxKcIBN7B68 354220q2lZ9misyMSeafNwl0tko4Pb8FjNHirgZuL8yZvI4ym/hm6Pmy46scfg/FfSHj4Ht9aNQoS3 354221Faw1bM/PLFRY0DOjbcGKT1YaoUOi+DCwxrgLeeA1lODuQnd0MY7Fmfw61POFGhE3VELytaF2 3542226LvzDWqEbTuTKO/T+dP3IpMQYKKKx9h28DmTG4EKofZiEyHiLBEx/wjuZRWhikfkNnU5bigZ 354223cagNnKecx1ciewi4Gdjcuzv0jbrBbWoK3lcw5A2fYPUXGTlyhJAy4oaSJeIsnTA99StqCLb+ 354224cOMAdl3LaxGD/mi9SFiGtAm2sB55Fp+KpTqHkvzHSPI3p0OqiWpeYJmbCYI3P0VBU31xNi6O 354225tYbFoAt0/gfKsn6Gow1GnPmI4qZrSggxutIHllFH6bBoNEEW1h2+695IvPI1wWRe5j6YlvwQ 354226X7i1qK/mIOvmHiRO2aOAn/+NxI2osRbFH+7i0KwgmJN99NQ35ViVSncQzTJF11Zi3l/9uob8 354227C5jkaoeEg1n0uqaMEr+kjIWzwzAczeZJPMS6dLLD+ONvwG2QeY7dEBxvClNOY2c2bAbvwoPc 354228KjQI6lD67hzm+pojQIyd2/cazXB6W+T0probReWoqGdyw7w/HAdrsWKbxrZWjDcTReplrPaG 354229nhjDMN6mAdiYSXBvnTzuVYeJaWNxC5m6qQ4SXMT/cgjh1DNfVqGRxyE6rmAYGDDEDIWv+jn2 354230x75X5WJ95DMcHkeeqy8mdjjnMdDSETNvcFBHcO263vZwtLGA18wmfEz0n6Wf8CjtPvJ5yrG3 354231JL8sja1d4En213dKsHVL2LvlekKeTnaD17RTeEuH3SbfU/YZT9JfyWF3amyocZP9vamo+pvc 354232mhcQnctIO4ILZfLMhLIQuvkdvS9S16sibkR89Rj7h+tJ/58Z5oygJYzumM99gT1xbNhPuI4S 354233OsfNFyRHWcFzXhqKiB6vJH0F/C16YseH1uW4SYkzQWenOXQ4cKYNVvT6orkFCqPbu2PhY6JP 354234JlzAg8Vu6NKD+X51+F3tfeV3MdmOjSHHKWNBHgpvr0JoN1054kYVNqf6X53egr5X+B03xhPc 35423572GHIHGUjqaiQNw0xX+VzbvSvFCMlKcXE8OPSr4b5jQaaTIKNkHxHayJ94JNDwN0+uMvdCXs 354236r2OfOUj5JB+qo/H7LSwYloSnknjtNcg6PBruxl3Qld0Pa9NLJVYwfPJhO8cFgW2gAx09E9j3 354237moRdt1/i0hwvdPeaL5eEX9LOZ8sQFMEovIWl1zDOdzBt7dGaIjvBZQuV9M2rz16o6r8XS4PQ 354238Z9dnOcZQWPUGyZMDYdlVB7qmbkhYfw/FTcoXSvDqphjeQ6KYENf/TvpT1mNEz34SE0KOTKpH 354239a2LhZmEAXfL3rmYuiJp7Am+rNFNiNOSdwxR/Kxh3Jc81YCFw3C48KZPvK2HNR6QkhsPWWA+6 354240hmyETD6El+Uy4dBoKxofmAbKK6eYOj5K7m/D6EA2DMmE7dLVDK4xi3D2c61kTjTkncZ4z+4w 3542410NWDiUssll/+JrH8aurXpn5XJdDT7yJkwrfMV+CouUbuenJwvMr81mKoNWVrgyEfx5B56YkF 354242d0oVrLaoQ6RRRsA+2d8CboulsQqZaxpRnDoCbMdZ4gX9B/5qGmM9Uzj1nYtTH6Q5TRgX1P2Y 354243FUWApYEudPW6wTZ4BFZf+EAL89JnUHVdYWzpht7jknAhS+ourPAe6keXjdG3yhXmhtz3COuR 354244e2MjRofYopueLvQMe8ApfDw2XsmWvFvZvbLrSNk1zN8Y68bm9ZTiP//SdLiaeWEOOazptndp 354245tlY62mHW42q1bVfXBsZCTh8dekjXOvVezoPdmNrbCaZdqW+1gu/glbjwqVquH1W9T/EZOviz 354246w2/oxBqKA68qVOdiEc8HG9e5EJSkY/PYcLiaG6CLDtk3jKwRMHwd0vJ4Gu9VjdznODQzEi7d 3542479aGrS+aDTSBGrE9TAPYi/jckRxqiI2s80sqEzb6jFpkrPdD5L3eskPFiLL0yBGa/G6KvTPgm 354248zuUJcHSagusyHkMU+X64P2n7mudq9yFmr0vDEJPf0OHPzko95JTNkaZ1kUsIf79ZD5X3azNl 354249r3ROa7hPCEqIgBkJNhlHA6sgTFg2CR6yIbfY0diydTICLMkerM9Cz9mn8FFGCdLIfYo94wPB 354250MmDmUuCM88gTk298zl2si3eGMVmzxrZ9kLhuBrxkxlJY/QFnFg+AhzlR6pMxNLENwJC1N8FR 354251Qdwwz7yNpDhndKP2U6f+WLx1JnnmWEloN9m+Ubc2ZP8v+zs1T8szNqC3jT8W3CxWeZ2y9rX0 354252Ptlr+SX3sXWEDyz0Sb91c0S/hecJCSPjVcWOwuYtk1T2u7Rv9WDqPABLtifCW81exC+8igWR 354253zuiuT+2/hmAFjMYOmVBpooZ8XJrljx76XZn4/eTc+3xsPDyI0GbA6olpa6fLjR3VT0XnBsL0 354254dz2E7PokJxNQRgNzHDrDasIdlFNCLhXbNlgPRjEpKBSfR5wrhCyX8bIRctMx39Mew0/nSZ5T 354255+2oNPHX00Wu/1DCFkRl+x5+dFdeP5EyjEgtbS8N7Kt2b322An+0IpTkT1MlNLYGNHyltWcst 354256tUn767W/Xvvrf159S+uRz7mD9YM9YNq5Ay3TddBhY8Du9zRglXjOd/4THX6XkVtl9jNaGZWy 354257ANHORBnZ1RhWfiOw6Q5HbSQICWYtfYDtEyPhyTKETqdO0CH4xn/oGlz5Vi9vwEKUft9OJMDC 354258WhopQFiWjpUxbrA0MYGpWXdY+w7DxnscOc8fAVFWHF0QB29Cyuvq6sPMKRwTt96kk/VqvOcR 354259Moq2GBd7BvxIaY/2SNqlYVQDTQtt5aqrOuRlUzg9f3MvDB/gDlMiS0XM3YyZQSboYhaOTW8V 3542608z4oI26qHkyDdacu6EGUNnZ24h//WXSIHI2/XQbfNfdEpS3/c+9g79xBCHHqAf3Of+B3paE8 3542619WjrYmYePsKO0f5gmRjD2MwRkfPO4EPRaxyfGw13CxN0MzGFhVMoRm9/KhfRQlR+B+O9+mK3 354262rFW/sBafTs5AsIUu/vzLGA7h03Aws6JFDPqj9YLCMxho5YaFGdUKOoC8YzGw9ElC1ZO5cLYc 354263iNMF8jqG6udLyXf2xymipyk6Pxhs1wXIaJYTo+FrMiItiUKYkFS1mavhzY6X0+uow7bN8XMP 354264vU7o2Lkb7MPGYsPVbFrR3xI2/hl16uRmdbKx0u/t2g0sj94YtexvPOHwVO63tHHzTDv81UrM 354265+6tfJ6z+RMj/9zSBKrsWcu5cx1tCsFI5uafHzEby8fUYG2oLY6LH6GpMsOmwNUjNbqajbMLO 354266Zl3wZ8e/YGitiJ3b/ZoWcLo6WVad7oPeBzP2I97OmMaQ3T0GY9N9RmfFYNu+cLLzQkh4FEbO 354267GApnsceNOtyrtq6xDI82xsHRqAvRF1ojOC4SNjZN95UifW0UbPR1oE9I1DFJq9GLxRAzFHGU 354268eXACwXNdoaNrBAvPgVh1ZDsi2U311Xi7fwRciZ5Yn+wDk5MJ+cZ9i1ML4+BlaQx9SufF9kZM 3542694klk14uUYG9LOezdErZuv3oD6OnpK8XuqtZ/a7AUNX/2Twyiv7GrmSviVl+XzB3qelXETUsY 354270uz3qBd8fY+eYAFgZ6op1xwfxQkZ3TDkyrIhxpHWKRnZ9MP98TqvyDvO+HMO4yBGYMsgH5qQN 354271XU2c5NrQhNG92fbwDumHcXNHw7VpnqrB7+rv4yH3QiJCLPXQxZCF4Om7sX+0oyRUmjpsrone 354272gs7xfH8W7Ax85aJoKCVu2rO0J1BvE7gnLHbKyF5IvMfF57390XvNCzlh40fKq6QBmHKlRGX9 3542732pBetGCh/aV9S1O/N4pEv0ybqAPqYVIEzIzcMGrrVbwpqga/kYfyL49wdOF4rHpUof0D10Kh 354274Et55OU1Vmrjuv1Joz56MVfAzdcf8dO4vNYf/bYX3fhtCjHSgp8+mE5dKQF3OAfQNWIDMNYG0 354275YK/DGq0Qw14bC+M6PQ72ntI40Bqf4+82wt92ZKsU9/+v0hJx+ivKJT+jUKEGomzl81JpUmg3 354276d0sfrHlaoTQ+POXJ+uVkAtjuiyWh4n4F4qa95or2K9a1v1776/8Z4kbt/mw7TC6Z7T++vxLF 3542770O1bz/GtkgfO1Qlw9FhE5yfU/vJrn/vqiBvtL9ouEwuQf2Y8Bm3OlPNe0v7yHx93ItNWVzf8 354278MPmt/eXfud4TNmr/ev+vFWF1PrKL6/812FxT+YUKxxbZezMdeUy2/Kb9Q679RftLewgD9chL 35427934fEeH/YmRlAvxsbPrGzsedeniTfjvYXFX0nIMTXKl+wqQTeAtF/fJ7UImv/UAQP2IznlULt 354280H3ztLz9PYOC+x4tPZWgQClGXl4blQWZwnvtIacx41cIuFSt2iiTB6a9WtJ+4YTyVX20Kgf3g 354281cxIvHY3vbSxFelIc3C2M0D1si1x/MjkXDNHdIRyzUnJalfdASqw2S9ppPYFO2vlPlJbapP31 3542822l+v/fU/r/7fvD/zC1KR2MsepgYGMHOOwcq0ohZz6Wh/+efPfUHJIyTvvoCPeeTfPZfwpV77 354283x0z7CyUzCVBX14CKx/Pg5jxDLk+v9hftL9pf/nvrvZ6s98qMBXRe7gfav961v/yD2FwT+YUO 354284WbgiBBFb3yvk+tF+4kb7i/YX7S//WOG9344wE31YBU/D8Y+12m8Fo/1F+0s7FSr85WRfcxjo 354285dsZfXVkImrhfzj1Z0/XZ09wBQw99lIux+qsUbSdu6MTJ1nowdByKg+9r/5H+/DnfpSL8TivD 3542867mh/0f6i/UX7i/aX/1b5Vc4p7S//UrlJkIeUBCt06WwIz+mpknyB2l+0v2h/+S+vdyPtX+/a 354287X/5xbN6S/EIbTXbXR4+QRbhVrJje5X9XDupDuPY1aQAAAABJRU5ErkJggg==' 354288 ) base64Decoded asByteArray readStream! ! 354289 354290!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:24'! 354291dejaVuSansOblique12Data 354292 "Created using: 354293 Clipboard default clipboardText: 354294 ((FileStream oldFileNamed: 'AAFonts/DejaVu Sans Oblique 12.txt') contentsOfEntireFile substrings 354295 collect: [ :each | each asNumber]) asString 354296 " 354297 ^#(12 15 4 0 5 11 17 30 40 54 67 70 77 84 93 105 110 117 121 131 142 153 165 177 189 201 212 223 234 245 251 257 269 281 293 301 318 329 340 353 366 377 388 401 414 420 429 442 451 466 479 492 503 516 527 538 549 562 573 589 602 612 626 634 639 647 655 669 673 683 694 704 715 726 732 743 754 759 765 775 780 796 807 818 829 840 848 857 863 874 883 895 906 916 927 937 941 950 962 973 984 995 1003 1017 1028 1039 1050 1061 1072 1083 1094 1105 1116 1127 1138 1149 1160 1171 1182 1193 1204 1215 1226 1237 1248 1259 1270 1281 1292 1303 1314 1325 1330 1336 1345 1357 1369 1381 1393 1402 1412 1425 1434 1443 1455 1462 1475 1481 1488 1500 1508 1515 1529 1541 1551 1555 1566 1572 1581 1590 1609 1626 1637 1645 1657 1669 1681 1693 1705 1717 1735 1748 1759 1770 1781 1792 1798 1805 1812 1820 1833 1846 1859 1872 1885 1898 1911 1922 1937 1950 1963 1976 1989 2000 2011 2022 2032 2042 2052 2062 2072 2082 2099 2109 2120 2131 2142 2153 2158 2165 2172 2179 2190 2201 2212 2223 2234 2245 2256 2268 2280 2291 2302 2313 2324 2336 2348 2360)! ! 354298 354299!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:24'! 354300dejaVuSansOblique12Form 354301 "Created using: 354302 Clipboard default clipboardText: 354303 ((ByteArray streamContents:[:s| 354304 PNGReadWriter 354305 putForm: (Form fromFileNamed: 'AAFonts/DejaVu Sans Oblique 12.bmp') 354306 onStream: s]) asString base64Encoded) 354307 " 354308 ^Form fromBinaryStream: ( 354309'iVBORw0KGgoAAAANSUhEUgAACTgAAAATCAYAAAC+oPBuAAB/CUlEQVR4XuVdB0xTbRc2MRJC 3543102tCUpk0hjDDCCqBRhlERNQgunHHvvffEvSfuyecWt7jFBQ5Apoo4wIULBZS9C7R9/vfeQtvb 3543113rLU7/ezJ+mf75f3vvfe977jnOc855wmgP6L/ov+i/6L/ov+i/6L/ov+i/6L/ov+i/6L/ov+ 354312i/6L/ov+i/6L/ov+y/9L5LICxK/ujM7LIpFdko6bywPQccppvCuV6f/g6LlIC14jOvIl8qrk 354313ZJ6UIT0hAlFvCiCVy/V/cP7EtSxJx62dy7HuxAsUSTJxf99KrDnyBHmyn/tecrkUOfHBWLoi 354314BC+L678vyIpf4ciI5mg58h8k5UtrbVuVk4ijS2di2vQlOPGiCLJa5pgsPxHb+ztDbN0JCy6m 3543154s3lSWg/IhQZUrmO55dBKpVCSsaB+m9Z9X/rHsevuLW6N1xEPJh7jsKe+Nw/cs7Lq7Jwc0YL 354316uIy/hswqeT2+owSfL01DK8fe2Ban+51kZe9xamwLOHu3g73LWFzJqKrl/CBjKZXR30v9v9XP 354317l4QNHWHfbS9Sy7TvJ/l8BbNaO6PXpofIqpBXX1OGtPNT4eXgAhvb7tibWqbWn+JbKu5X/d+y 354318X/dt5BVfcGGsA4yaGMFx1Ak8SzqI/j5zEJUvr2NsK/Ht+nR4ekxDWFZVg+4pK0jC3v4ucB9/ 354319HC+LZHWuxbzEnejf3Bku1i0w+XomquqYmxXpoRjnaIQmRo4YefwZkg4NgM/sSOTXMm55D6bC 354320geOIGQ/zUZQQiJYcK4wK+1Hruvy3pCrrFma2dMGYy9/qfHfG2EnzkLCtF5xbT8OZ18V1vkvF 3543211xuY29YJnq3t4Dw6FF8ra28vy76FMTYcNF8Yh6KCaMx25sB+ckSt+69cVojk/QPh6j4Bx18W 354322/RHjq/+i/6L/ov+i/1K7NNH/IdB/0X/Rf9F/0X/Rf9F/0X/Rf9F/0X/Rf9F/0X/Rf9F/0X/R 354323f9F/0X/5/4r0xx3iMLRBKw9HeE45h7Qy/Sc36b9QRI+3CO7TCoOCHyFi6wB49Q5CfJ70j3g2 354324WUU5yisU85QirVRJyiCp0u95K8u6jEHmXHitSUJxXgTG23LgOi8WRb/AaS6v+Iobc9rDb21c 354325rcQI5bMUv8ShkW0RsDoc3yS1OPjJtytOOYVZAYOw6loq0sKXo6vfUjzMkepoL8HbA33QdV0s 354326PsZtR08LAzQT+2PL40Kd5ICi2AVw49hg3O1sFD9bi9bG5hh8OVMnwacweg48vGbg+P0Y3N49 354327HC19t+BF2Z9JPKj6fgezW3fE+qe1Ezbk8ipkRSyFb+txOJ6iuy31na/P7YjOC6/hc2kuopd1 354328gM/SGNZvLpdm4coQC3A9V+JpcS4iJtqB4zIH0YXMtrKSV9jfxxMjz31Bpdp9JZ8uYVaHTph9 3543294R1KZDXkplK8PTUZnXqvQfjXQqSdHIW2g48hTUKR08qRuqMj+KIAnPhUig9Hu0No0hn73kh+ 3543302XiWPluHzt224vGHh1jvb4pmBtYYePgtyuuxhuTSbNwPbI/2Sx/Va43QY1PwBLsHtkHfzZHI 354331qqyLRCVFbkwQ+nUYg+CnuciOXYcu7echIltayzWlSF7vh65BifgQuQH+ps1gYDUAh96U1bom 354332JTlpePUqDT8kMlTkfUDKy3fI+kP0Amocsu8tRDufFYgvrN8zUeSm+KA+aDN4B2Jz6iagVWaF 354333Y6l/R8w4/47spXFY29kbCx/k1k68LP+B969eIS1XApkkF2nkv99/L9e91mSFeLZvMNr02YSH 354334WRX6r3D81JyQoejFMUzxtgJf6Ijuy67js0T/yWL6L/ov+i+/R/Sf4KT/ov+i/6L/ov+i/6L/ 354335ov+i//LbJXxOc5j6bEFyif4bt/ov+i/6L/ov+i/6L/ov+i/6L/ovbEI5hyqKiMM0Jx9l0p/T 354336m0tf7cPY8f8gtVSOqh+R2DJ+FkJel+p/ZoL/6LwofnEQ0wf1w6CpexGfK/1DnkuK72ET4dFt 354337D1LLq5AduRYB/oEIb2DmFP2X/+KcrELR53dIL5ZWEzHSkZ4nqXV/USdoVBV+QurLN8go0U2M 354338KIpbhA699iIprwSZD1eic/cdSCnX//1L61vIypD17iVSPuShQibBj7RXeJWWDYlM/tvWfdGX 354339VLx8/RXFUimKv77Gy9TPKJL+uvtV5n3C+6/FNPmNIqx8+VaASpn8P7xeKpH38R2+Vq+X8ux0 354340ZBRU/tHnsbyqGNkFEv3XGf4FkRW/wP4hPuizOREF9Zzn0txorPW1R7uFYUhnIRFRRMT3Z6ai 354341k1cvbEgs/Fe+o7ziA471aYV+W8MQG3Ueizt5YEpE7v91DsklaTg1sSO6LLqLLGlDMo3l49mJ 354342FVi09SY+lct0rOsKfAsLRFdPPyyK+NHoDINUFsBbM1xh2nErXpSyfEvJJ4ROaQmH3tuRUE1u 354343p8myt+ehlTEfPltfouwPWadyyWdcmOYLvzk3kFFV/2eSlaTiyFBnuI0+jtRimc59NCt8OQK8 354344OmFOWGa9MsdRGQZlMtl/Yh+Tl73F8XG+6L0mukEZP6lsmtt6OMBzRig+6JqrshKkBPeDJccW 354345Y65l/ZZsmFVZEVjsbQ/flRF1EoV/lTTRfeiW4OlKT3AthuL6d8WgpB3sCguv1UgqKcerbT6w 3543466LBdS6mkDugfYSNg12IR4ovlZEK/wb7Otuh2OA0VdQwaFd0wcexppKtNfNqAexOKpX1bwdzY 354347GGYeI7A7IY/xAeSyIiRtD4D7kCN4UyZn3Wi+xx3Bgn5esBFwwDGxhkfATBx5wWTJq96P2UdV 354348diRWdnLDgIOvUap+37JX2NbJHj3Ju0nkcq17fjg6GAMPav/tj1kw5anY1dkCHktjtQ7Oiu9x 354349ODy/DzysTcA1sUHbEZtxN12bhS/5fBN7lk7FkC4esOEboImwO458qNAxpyT4GnkUa6YNQMfm 354350VjDhGIJn3gI9Zh1EfHYl64aVeS8Ik/t0QAsbEbiGBuCKHdFh5HpcT6sbkKFSryZu8YOoaRMI 354351uh1GWoV2+6qv59BX3ARNmmj8uK2x7lkpS59FeH1jO2b2aQ0HMx6MuGI4th2CzTGKg1qaEYoB 354352piz9Vf84HivwuFiutbmk3dmBaQEesDbhwIhngRbdZ+BAdJbWmpFLC/DywioM93GAiMuBwK49 354353RmwMw8e/KKIvK/4U1k4MgKetEBxDY1h4DMKasM/1itBovJFRgc9nhsCqWRMIWeYKZbh9u9Af 354354pozv2QwckQO8h67GVZb5SH3XjxEHsHBIJ7hZ8mFkYAQTy+boPGIxDj34hFKZvNb+m3FMYO7U 354355Bj0nrEFIXKaWUcr+TGrX203CvTx53W0NHDE9soBlrpcjPfo4VozpCnd6/RmBZ+qA1j3GYfnB 354356cLwtlGo/C1k3a1nWTVX6afQWGcN7ywulslXXNTV7wOeQnhDxfLD1VTnr/dTXKaXY5cTtxAA7 354357LsQ+i3DtY5nyu1B/Sz/TB2Ljdtj0vFSnga4cJ35H7Egt1wbubk2FkyE1bk6YGV3Aem0z+4m4 354358m8Nck5WfTiBAKEBXljOBior6/OAglozsTO91xhw+LFw7Y9Tqc0jOq6rzuzc14MOyVS8sCElG 354359PouiTgEdXyIPY9momv5NYOHmh9FrQ/FCIzU5a/9GAtiSfW7Vpbcolmk/+6eI/Zg/0AfOZE80 354360pOe5C7x7TcD665/pdy1P3YmOfN37Ys3PbNCl6mcoRPQsJ3Dsp+ABS+rpopi5cOHYYeK9PPr/ 3543613xljDWPPVXiqgzQjeRuMHmIuWi6KUswnck4d1TinSp9vhrdxE/A77iCgrJxhDKbs6AgTUXcc 354362SpMwzoL4ZR7g2YzEZY0U4ZIvFzHZxRimXbfhaaEMJ/qYgUt0okcFMq0z8ePZsXDk2WHkyTSV 354363LpR9E6OsmtY+XvxO2JUq0fgW33F9mIVyf3KY+hD5ZPzjFzWHRW+mbqW8pigW81wNq68xx+Ar 354364WYy9rCIjHJunByLkVfEvMQSk329jVgt7DDr1uU6dkPVbvt4DXxH7nvWrnQe54eNhI/TD/reN 354365i0Cs/B6NPRN94WzKRbMmnEb1UZ6yHR2EzpgdXVhn25Kk1fASumNZYjHLmDlhxoO8Bvdb025W 354366Pe6v/6Jjzuc9w7m9wbjxoUz/B0Onvl6Kd6GB6NXSAjxDDtzmKyLb5QUPMMnWAkNuMNPvV3w4 354367iu4iAxgTGyIg8CLSfsLBUUJFjXN177Um/sF4pwEUyisycHepD7EvmoLnPhMXP5T/kv3xV++3 354368DXk3/W+r/231v63+t/2T2+rW1yR4s7czTARdiZ5e8RN6nwSZ0QcwM6AVrPhGMOJbw73PctzO 354369qNTp7HgZug5j/dxgzjNSYFQjVuLss1wlyC7Lj8QsZxO0WZ/MwBBp3ez9UfS3tkLfw++0MA5Z 354370eTqijyzBiM4tYEWwSwOCh4hsWqBDn0nYfDudoT/LJd/wYPcU+LuaEludC1PnDhiz+wkKNe01 354371gvvt9GuJEQfPYXX31hhzKk3rvvLKHCSHbsDE7q1gLeSCKyRj0H0iNlx4hpxKdoz16+1NGNOZ 354372OGIoXMqxKxZd+vBbMZt6fcsGvMcKDw5jzgm6HlRkJaFK1BydCh9rPkzsu2DRxTSU/YRDvSo7 354373Bnun+MOV2KNcU3cM2xGLHKlcaXMUPd2OYW3tIeQYQegcgOVh6Qy8gLLls7+kIS2ttl86cspl 354374P+GMzEL8iWUY4esKC74hmtaMi7g3TqfXj6QkL36Kdd4u6LN4Nrp6DMURNRKdvCwVBycQLMKK 354375YKj2k3E/T2NNfHuAncRuciSYkYldJ8wIeYWiX0RikJYX4Pu3L/j4obbx+1AnKachcnvzHMwm 354376OG16hba/pCztMtbNnoON1z+yrhfKPp/vyoHNuHDkyuSNwi//uvaV6bgw3JrY1ARrMw/A9sT8 354377Op1yMjIfN7bn14lBmfjtx1vJr8VyG4XL/tttNXDY2vDZxv6tZs7nRUyAbVN1fJEPUzsPdB21 354378BAfvM8fz38RW/9ZrGm6La+LF5B7N/TFmzTkkfUvDtQXt0WrMJXyrkjcKr/2Tr6kvVluu6ccw 354379bosNyaX1Ix0UpeLi6uFob098XEY8WLr3waJTz1HAht1T6+XRcrSx6cooBam772Ts6dccvsvZ 354380iQSUH+R7RCA6eI3A0hnt4Tr0PNLZ2pW9w8nJrWFh7oXpoWn48WQLunYLwksNH3vl5xD0FPHQ 354381PuglirOuYKgFF54rn6JEcx1KXmNPt7aYSc65wtznONTfAyOvf///EpwofsHzHfC3boNVCfUj 354382esmlOYjZ3BPuPdfjQVaFzn7zE4PQw6MfAhd1g0v3A1pnigrrv4Ux1gTvWhCLwvwozHTiwGHK 354383PQaJpSorDNPcHDDsXDojw568MgvhgT5oMfgAkgtV2TKLX+5Hf/eeWLZ9MjzcZxP9qvpvxU+I 354384nsuF+eBLyCxOwfYOfIh6heBzpaafOQ8xawm2Zd4D26NT8Ph2CLYtW4mTr9l84sVIOTwG7uaW 354385aL/gOj5nxWClX28Ev2PHzEtT9yPAxgOB0Xn1G2+awOUJz0ln8b5MpnO8i57tQh+PXlgY2BOu 354386fjuQoiOjY2VmBHbvCMfHd6GY5Mol548R7IYcxmuW9rK8e5hsz4HjDOJHKYrDwuYcWI+5hez/ 354387A6GWesfCxI3oYN0RW5KL67fPUMSwYS3Jd7nBSnSs2Q+y7i6Ed+vxCFrTEy7ddM9VaeYlOgOp 354388x8onKM69iwl0BtIYFNbxHaV58djSvTm6b4xGtg5im8LP4NQgP4PkzT50NhGgS/B7lHw5hd5i 354389Hny2vlL6mHUTnKrScbq3GDyfrXhVDRzXj+BUgqerPGFLHJWZZLOmHXX2LbAovu4PUvJ0PYat 354390iEex2mBJsyMwhwDe3nOPITz6LoLHu0DcbjOel6mc1lm35qJtu/m4wxIdojgcVqCd0Awd5/yD 354391sOh4RJPFumHSSKzXcAKxEZzkZa9xeKA9nMeFshgnFImpB6y8VuFJNWmlODUUhy6/QF6VGsGp 354392Kh+vrh7ChV8EWP+axSJFVtgkONkMxKnPTOCm8tt1zGolgIXvPBy8GY3osL0Y68aDqOteDccv 354393eceQUejkPxhTApdigjtxbrstRFyxjoVU/grbu7aE34RVCA69i+jYKNzYPw1thIYw63VQ24Eg 354394L0byvkVYvO0YLkc8QmJiDO6GLEUPK0NwPZcjoUheq8H09cpUtLJxgKmRITk84ljTABfFzIOr 354395wAPzL8YjKSlJ9Xv+DjkSDQVHko6rsz0htuqMmTvPI/xRIhKib+H0jg048lIxl2SlmXidnMTs 354396KykRN1Z1gMDQFiNDNQ4oeRleHxoIa645Os8lDrCoeMSGh2BJd0sYEcfqjlfqta0L8TioC1Gk 3543977NF3ZQjuPorBnUMz0EbAg8eS6J+u4/6nyKYevhi58hCuPoih596EFsZoZjkEod90K++Vua8Q 354398dmApxgV4wd6UIllwICSHaMDEDbiQlF03uTLnHua4ccHhc2DoMA2RBdpzkSIJcG2G4mh09Xd9 354399/Ai3Ds0me0szCLswjWJ5+QdcnNUaAo4FfMZvxInr9xETF40753dhbg8HGFsMwdUsmXb/VgNx 354400iO7/KR7HR+LmmV2YF2APrpE1+u1NZoA8ymush6ieSe2X/DpTaSjW2jb5tVZqW2qu31rWGWZG 354401IniNXImDlyIQHR+HyFtnsHNeLzjxeGi7UQXW1vTPsRyJsGwZuxFhZINxd3PVCEe1X6NoU4Do 354402mU4wUjPIGddajcTN6mspRSv19FS4m/DgOuYwkgs0iTtFiJ3nCiPr0bido+t+1ePEFcDYkDxv 354403eJ4GaPcMm7xN6HnSTNQTIWp7p/KZiMFiZOSIafeZClxB1Aw4cl0xL6ZIY6w/4+r8dhDxbNFl 354404+jacuRmJ2NiHuLJ/NnzNjSBovwKROVLt+1jWzJUkJD68gLV9bGBo6IJZ95hREVT/1xZ4Q6yj 354405f2GH1YjOZet/AA5FKeZiQsRJLOliDgOuB5bGFai+oSwPCVu6EmDfDgELD+DSvVgkJkTj9rm9 354406WDLMH0MOvaMBB2nRZ7x6pppz0cdHwM7QFD33P1Sbi8lISS+ufua3OOBnAmH3I/igde5K8C7Y 354407HwLiyDhY7cigCEh8s0G4nCVj0WWycGOiA1m7IxH6tRI/rg+BGUVeS1EjzJH3eDjHFYYUCVWD 354408KCUriEFgS2PYjrmuFeUhSTuMALEAnXamKA1eWcFjBPmLYew6DVfSFc+Xe382XLjWGHFRVZOe 354409rtUfsxYdRCL4rHmEPLW+ZeXf8TZZe00nJcXh8rJOEDXjovn0y1pKq8KAEcBl8hnEkvF8naEA 354410ld8d8IdFm/VIZosAqcxH2nPyTY4Nh62gPYJelqkZA3cQ2E5AA9xG9iNwNPXndRhaZ7s5Ha08 3544115uFBrqzBSn72zZGwEvfCqS9Vv1lHKkXyhrYQOM/Bo0J5I5wr6QgdYUv01fkIuZ+Ip+R7NMao 354412+X59GCxM++Lc17rftyIvDc+fpyFPw2CtKvyAF0Sn+SGRafV7thaHhbJdAxwb+i/aUhS3AG5C 354413b2x5of8EJ53G6uu98BebotOS07if8AxvshSEIV0EJ1nJV6Q+icK5xe2JntUCgQnFP0UC6tJr 354414ByKeau+5iWFr0aMv08FOgS5X5nhCaOqD+YdDsILo63znsTjxk/vj79hvG/Ju+t9W/9vqf1v9 354415b/snt9XtlMvBnXF24LVajARdGBTBW15sHYklMYU69R0KL2xrIoTX5D24RuExEeewdelWxOax 3544162xZ3A9tCyHPCgNWnce/JCyQ/uoxtYz1g3+sEPlWq7KR70xwh8N7MKKUkL3+Lw32tYNXviNb7 3544170ZG3PS3ANe+EGXuuIDo5Fa9TkhB17QjWju+DSQRLUtoSxPZ9vM4bQnNfLDh8C9FxUQg7EYS1 354418x1K0CFWU/v31wlBYGgjRaUMsw+5Q2C/PEDzMGeYtByJw3wXcJZhpPMFeQ/cvwWB3CzgPDUaS 354419pvOPCibcvwF7LoQjJuERrm7uCzun8biT8/8LvGvoe3x48Uxt3j3Diw8F9PgWP16Fdq79sfkK 354420wUKvbEb/Fv7Y+rLxelzpmwvYd+gy7sfG4tae4XAwVwWFUjZhfko4wiJiiB19HydmtoKZxpyR 354421ZlzEQLM6goVqCTStc9xK3+D4SEdwlP2J0WPPfcSFEpzde4US667bdqnA53Nj4dm8B9ZG5TCD 354422kivzkPb2M95eGgbXrv/gvdrcl+Y8xGIvMzQftR2XH0bi8qY+sBZ3wk6NYLOGYN1F74jvYPFI 354423+DU3B6dp3YFWTZpYYOjVrF+G16cdCoDY2BMrNXwOVVnhWOQlgHn37XQgFKtenHYI3cUidA1+ 354424pzNYui788m9rX5V1AxMdjWFixid6MjtxgTkHyvH6QA+Ymvph4/UrWOXNB6/tclxP1DxvVOu+ 354425XlhuQC1Y7s/isv9yW00ctjZ8trF/U57Bm73BE3XFjoin9PM8IZjh3dBgLBnUHHxDMTqvi0au 354426VP6vY6t/4zUN3i8lX3B9YXuyX1nBd0oQToY9RGxcJK4fXIiuVkYwIN/Arv8uJKqVQm0oXvsn 354427X9NQrFY5N61H4urnAhQVFaOsQrfeIy9/hyMD7WDtNw//XI9CQmI0ru8aDRcTN8yPzmc9cyj9 354428Kn5NB7iNYCcjKffRsncIGdsOPTewEwloIkjyHgzynYpzaWWQ5j7AvDa+2JxconVmZl4Zi07T 354429w/Du8R70tjRAU+OWmHkjg+G/pM/r4nSkJL/Ah4IqojtkIDX5Od7nVrDcuxKZtwLRXtSMJpXY 3544309N2BxwWyP8AXXopXe3vAucd+vC6vi1ibhXure8J32imdmYRoskbaaUz0HYl/nheR8SE+o87t 354431sFDHt5WVZeENGbN32VTZxGy8e56sxL7UdfbM65PRwmsRomrIStI8xG3uibZjjiFF7Vmqsm5j 354432oV8vbHiUC2nlZ5we4oHBpxWlR2m9i/Sf+q0EsqpCfHyRjFdfihm6GZUV721cGE5sHIfWZkZo 354433ym2OyYcfIjWrjPX5K9PPYpjfIkS8j8GWrqZo1pSP1osi8EMq13kWvznYFy7+O/CytO7xDl/c 354434GR1mXcKnWr6N5HMopnUegr1PCyAtfYkdXdtgVkQO6/NW5H1CWvW7VBV9RdrHHzoDFhR+mGS8 354435pcpYVuTiPRm715n/v2y3lJ33bKs/XPorSsLWSQyb1h5dloUjs0Ku094tSQnGkI4TceodGZOi 354436RKz2aYfFsexkv5r1nZZXQcaGmrdkbH7UHgggK36Ff4a2Qf/tCVq2pvpzZF0bSvsZTjXAz0D7 354437FZNf4lORlN6HUsk+lJavul43wanwEeY4c2A36R7y5A0gOFWl41RvW5rNSbGoSp6uhpftQFzM 3544380FGvWZKJmCOBGOrbEnZiLox4ZrBt3g7dJ+xEAlnI30IHwtZjORJrCETxi9DcZjhu5crpQSlN 354439PYRB7r2wK5kdCJZLM3BxsDmEXZhGFKsRokFwoiZTUpAvzBzH4dLXSh2g/G74mrlj+WOF4SLJ 354440SsSppYPQud88rJvpi07T1mJ+/84YuDgECVnsE0FeGIVpDpZaAP5vXShkE9jW0RxeKxOZpImK 354441zzgz1Bp8j8XKGts0GerKcFjy2mKjDoayvOwFtnjzIO53Hl91TWJpCXLyJRobdzESl3uAY+Kv 354442k/GpqRy/DGoPHml/QEd7msGavAs9Xbtg9dFl8OaJ0ffcV62UdQrlpguENuNwtw5HK0Xce76j 354443C8xtBjEikeq1CHMiMJcYb6YBwdqRIfmRmOHEgf2EMIbznM64wGdGJJS92o5OAjG67n6hqoct 354444L0RsYEtwrYgx8f33KQtyaTEyv+Q2KhtZVUE60gsq690+p6iScRim7uwIPr8jK8Ahr8rDk6PT 3544450FZkCL5LAKZtOILL4dFIfJKI6FunsX1WN9gLHTFk31OdNbepb5u8xYfMgyHYEUSACBPtjB3y 354446io841kMIQbdDjOgiuSwbYcMs0NRmPO5XG9k06Dm/FXh8d8y+/BHlMm12dPKdSAY5oaZ/9kwB 354447xFE+1h6Gwq44oPZcymeqjjSs9fs1pC15vuiV3jDhumDiWVXtdYaS/PIqziWpFLaa/vkddzJI 354448kDXrjNpbBRrjWts1qvOBygBoopWBTXltp11IpaIsJV9xdxVZn1xL9Nhwn/VAl1ek4VA3Afi+ 354449e/BaF5u5ul9hh2kY1dIcnXalKuc8DdidGgRr2+6Y1N0axi0XK88l9WtFnRdhTnsxXOZE0dlz 354450asaAji4W92EQCui5ssADfOL8XnLnGzNSkwLbo5fAnWuMdupkspq5ohFpJnmzF51NjNAiMEFJ 354451EpZXfcfdhXX1z4P35uda/fM77abHtkbKXmwheymHEZ1R9jIIPnwhuuxL1UqDSvUvk8lZDZ1P 354452LFm5GEpRbjjG2XDQfBGT8FzjLIgYbwuO63zEVpNc88LHwcbYC6uTSrTnauIatOGRZ9yjeMaC 354453BxNhS8DGVU9Vbau+hmKotQW8+3vA1Hm2ktBCn33Xx5D2LRHIovRR6//uVCfwXOfgAdFXKHDg 3544544mQXGJt2w/akItX6KE/Bzk5kHvup5l552imMsufBYcwZfKhHLXLaQLwTiNYmHDiMCsHbUu39 354455viqdYrFrZ2HKvjkcVrYTGCRBTTA67Uh3iEmbiOo2lVkRWNZeBBN7d1ibmMHNRQye42iEvPk/ 354456Kvhkr05a7QWR1xqtTJu//sz7ivP9TCHuc4Y181WdZIXPIehtaomhVxqf8pXSjx4vd4eo7QZW 354457clrjx7G639br8KxUXmc7YS3Z0fRR5DIpKqpk9Xb0UOefiOgI4Xky/R88HaBHyvYOEDpOVUab 354458Kf+mg+BUI8WPl8HdpHm9gmhqIwF1H3UVWSznFRUdPGSASi+TlbzFqQluMHUbg8PJBYpSCeTf 354459zs/0gqndQOxPKmjU/vi79tuGvJv+t9X/tvrfVv/b/sltf+qcqfqKc+PG6iR1UyUrDnUne3DH 3544607VqR6mz6+LdLY2FnzIzor7GhU5O+qdmOMuTcnQR7gcrmoYH+f3rD0ro/jr6XaDldkje2gzGn 354461BeY/qLuMh7w0GRvb8mEzPkKJ19Y+DiXI/ZGnVe6OIuVfnOAB7zmheM9iX8jKPuLawg7wHK8d 3544628KlsQ3SjyqzrGOJcP0zvt+gTv+A9VLhwb/iueELboZQ+/GRFJ/QMfs+KhTUUyy1P3QW/luNx 3544638weLLVf8EbeXeMNj2m18r0f5FMoZFLGM4Fhce4w4kqKVabm+8vFEH5ipk4B4VNBLKbEhR8Fz 3544642DXWNdpYx+Kzdd5wn/1IGQFO4327fGHTeRde1QQxFycgsIU1Bl9reLYHah0m7hsOF4Klthy8 354465AofDEvDmWx5KiQO6mMp2a2yOIVeyfrs9KyMY8EwXLmzHqoKk6EwbvSxg4j4PNzMrf8omrgu/ 354466/KvaywqRsKo1BE4TcXhfH5iadMbe17XvMxVfiBPWmg/P5XEoKIjBXBeCoUyLREFd+6oSy/XA 3544673KufWLDcfLwgeDMblvvLcdnf3FYTh60V023k3xRjlomLA81gzIJpyKt+IHx+C3C4rbH6SfG/ 354468j63+RddUEF/kveRcVuxJVvQGDx991nLsU+MfEegFE0EbBGpkDpQVPMGunhZo1oQLr9VPGbhs 354469Q/HaP/mahmK1NXOTQZBtxoeD30wcr8YHGN/p/gy42A3Hpeqs/1UF7/Dw+CL4iEzR50x6vUpr 354470/X48RoaSjPf4mEv5a2WQ5H3B5++lP126iuq3sjADHz//QKlU//HEP1HK0q7jyIkbiHubjZKs 354471e1jcWgy3WbeRpQMDlxZ/xftPBTSBSlaejc9fsrXOSf2XBuiKZelITsnWIhL+3fgv8TMsc4fA 354472YyWe/EI/g06Ck+RdMPxNBOh2SFVarl4Ep4Joosg7YfL9PEVJoFO9YaMRgaKugNyc1QJChwHY 354473cPEujo/vg2U3nyLuxiGsDtyPZOI8piLobfuHIkMqry5/NxoOLRbQWYKkuVFY0dETky+m68zQ 354474QqVj3tGRD2GP4/hY2TCCU+nLnfATW6Df8Q+6+89/iMn2IvirRVdQTtHcmI3wN22GZqb+2Pgo 354475t9aD4d8mONFs0Gvj4Gg7FOfTKxmHT2HcErTi2WL05QzGQVuavBFtjS0w4nYu+6LMuooh5kTx 354476WZOklZqwLuOMyvjFrYWwxFRI8hE9zw3GxBESoYOUVJV1C3M8m2P0mTSkXx8OCy7Tma3qKxfh 354477420gZElJq9UncYAPsybfed/rBpF8qDJGj9e3A5/vjQ1PtUl4sqxLGGjGUxIClU6bp2vQmm+H 354478CXeyFVHsFOC1rg141qMR9kPGANkUJbw6YHtK+S+eJ5XIfx+JU5umooerABYDLtJZ2RoqBQ8n 354479w4FvD9+xq3Dk7itkS+rv5KMyqAUHmILntUq7tF9lBm4HtoWA64BB2+4jvUzGOtezozehi7Ur 354480Jl/PYFUeKz6GYICFAB2CkpGVEIgWXFtMiNDI3FMQSdYoBy5zYxiZwCjSzJHuQvA6bKP3Qrqs 3544810YP5aM4RoOPmJ/VOq13Tv9PMaFajm6o539xIiO5HVHtRzTXOs6PrTBFY37bU8xfELoOnMR/t 3544821iVqpbevvX8j2E95oDQ8VX3m4f5kOxg5zUK0WiaU2q5RAUN3qtN3xjGMk5prqRJcuXlPcGCY 354483E4yFbTA7VJuQpdqrH2CKvVGtwIaiX2O0WHQNp4ZYwnaCCjCW5T3E/BZm6LT+Ajb7msBsIHM9 3544841FzbcnEk4sn5KGq+ELE1RBkqulijjBp1TmSHz4IrR4xue16yPjdFHN3sbQy+2lmr/u7q40aT 354485W0SGSkOOBtUjZsONW4/+1cAIRf+GsNUAyxWpaI3I+yVW91+JT8cDIOR4YMWT4gbsK4qUwUZq 354486ZBotJZsmU5mif+g3rbNTSabte1ZJPKGA4k58Mwy6nKWRvSoNR3sTMMV9CR7lK/aHYmqNGztj 3544879qNCJUDyeq8fTF1m4VLoONiSPTa8Jn03uf5wgBgC3906SXilz7egPXFI9zuejJggf4iN3TD9 3544882ldm+QiyD2VcGQUbiigVU4Aqorusak8Am04bEFcP0gOtU0Svgy8Zf6u++5BcxH5NYfQsOAuZ 354489WZjod05cilaWATjxSUeZDbJG702yg0gNEHu+zQ82XnNx/fkNjHDqiG0x0dje0xbNZ9xhRGfQ 3544900U2JIQi+/bnR5XipufT90T9YNLwLPKjSpFQKeBsvDFgWijdq0SkUgf5MH1NYjziLB+dWYkhb 354491W7L/C2DXcTKCE/O05wo5f9+EbcO0Xl6wFXFhyDWFs88wrCMAkfr3kUnScW/XZHRxJWcN3wIe 354492gzfgTso9zHExIWAOU6eRV+Xi2bk1GOPnBgseB8bmLdE78AxeqUXg3hxpqRERTJ3xL9SMmM+4 354493u30S/F1MYcyzgPvA1bj+9DoBYkQMnVte+RkhPU1hMyYU0RfXYVRHR4i4XJi2HIhN97KY2SCp 354494FNC+Qq39TQHAiGA9+jZyZOr9imE95o7y36QFyTg20R2mRB/fHv2d0c5yRBh+1Fxbc58Jobh7 354495dD76uFuBz+HDrtMsnHpdjIqcJzixqB88qfLGAgd0WXQJH9SB03IqNbIQztOu4n5IIAa2tYOA 354496w/5Oiuf/jvijgRjUzoGsLQ4Etu0wfIN2WV5qrR7sKoT1yFA8urQWI9rbE2cPDxYeg7Hh7lft 3544971PWSr3iwdxq6uZH9gZzXDn6zEBJ9FRPshPA/oKbPK9/3HMKCZ6EnVULNyJ62cWrmbnbiCSwe 3544983B6OYmMYGhpD7OCFgNkheEfeO6g9TytC3Grkzerz7TZGWwtpIrv6fKxIO4xuImuMvaNwbob0 354499FEHUUzuVdPnrfehqaoXBpz/Te6qo8z68kdQ89xvs8xegibAbDqdVKA3Jp2tbQ0zOIaWt9+YA 354500uZcJ0X/USK5V3xGxpC1EFgHY8bSAdgxTZD+hBsGb3v9ebEdnU3uMufiVud8YsUXGG9IpjYu0 354501Si9nIHSAGcwGKGw95pmsm+BER/5cHQLzn8zo1hAH+8FhzrDvsUErPTm1LyTsGQxnux7YEpPT 354502YKDyd+23+k+M0P+2+t9W/9v+LW0bg3flJZ/H6lG+cDHnwYAuiWMOj5HBSNVwsNJlT4Um8Nv/ 354503ts69VV7yDOvb8CDqXr9no0pRjCO6bU3QTFlqMHpaWKH/0fcsuoki60ATs8G4Vo/ANbn0B+7M 354504cAGXOD8XXn7PbuuRs7I8/R72zOgJDxuBosySVXN0GhmEmGosLT86EH5DjhK9hTi1MqOwb1o3 354505NCdjZmRsBrcuM3D8dRmtZ4UM98OCSFUWjcofsQieGUBsDMX40me9aX+EfpOyYGISlJSrzuqq 3545068mKt8vs/K6r3oIIzB8GMfqamMBI6oOP4vYjLqWJ9DzbJuTMRLX2W4c6nQhR+uo1l7ZtjTNj3 354507nwpWpQNvUk5heic/zL+qUYKO1jfJt29iQGy9vTptPSYWlom7S7yJvuuAkcdSWclNFFY9zYHg 354508XNtTGGQ86dfz6GeqCoq5Othco5zVRNzLK8Gztb7w18Ap2aQ4cTFa6tL9qssOq4gOLugZ8lmp 35450988urvuBkLzt03qvCWeUlT7DCyxnjI/KUYycpVgXKyiTFKGcty1+EZzt7wIyMyYijrxhjQvsm 354510zvSBmCLHvKkfCU9a+Aqha0fD19UcfGJz2rQZjFWX3pB+pSh4dQkbxvmjuQUfHMqe67cMoa+L 3545111bKVU8StzhAI/bGf3I8KhLo0xRV860E4lKqbwE5hE6m7OsGklqzj9cEv/6b2krf/IMCUYPFk 354512juQkLoM7l8q0rpsEKpdm4dY0Zxjbj8PVjCpiWx0hezyFpabVmtlfHcv1DUqqN2Hwd+Cyv7+t 354513Ng5bK6bbyL/Rf6cJixwG9sDA/l4GoT3PmFkh4F/AVv+2a56s84bAvCs2xTD9j7Ki5wgeZAue 35451462xE5MgY8z3n3lyCF4vQddcLxj2qsqOxqYczvKetxwxPHvF3MH2/DcVr/+RrGorV1qw1u+GH 354515cC8uDnGx0bh1PBD+5gbgtAxETAEzK1riklaw6H4UHyqIvzX5AIa0bI3x++/hzY9SVDHOqHpi 354516on9tO0NyPpJ2Sy8gtaCA4LhbMaUHFfzFAVfsgi4zDiIxt4r13K8P5lsfHPdPacuG7bL9W400 3545179m/03yuz8ThkCQa3sydYMxlrTjM04bTSKin3u3DcerVV+58/oW2NFMcvRHPDJrAYcafOQBOq 354518DHTs4UUYWNO/XXuMXHMQO8a1QYdFd5WEsvpixH9K2/pixerzQ175ica4LYacRuTF2rH7hvTP 354519SnCiFbu742DDccOCuCLUJZQxvp8yxutK+2rELCMgef8PugitMOI6MawIGH9g5GytCOePxwJg 3545204TIFl9IKkJ8WhiXeFvBaFo/C8o84O9YDfuviai3NRaeGnu4EAyNXzAjLrDfoLK/KwJXRtuB7 354521UKXQdE9o2vjyMEHzhQqnckX2U5xdMQT+/eZi7cxO6DhtLeb198eQ5Wfw5LuOjEP/NsGpJBlb 3545222pujzbonTNIAVaZnljO4jtO0yEOlyevQhmuOoWE6oqifrIAH1xLDwxr2DhQZaYYLOfB8d2iR 3545235WqEigirqqpAyY+3eBA8Aa3MW2DyhY+sAJSsJAXB/YgitiwSOVJFtgeuxTDcYAGJ5GXPsamd 354524MZrxzGHON0BTQyEcO03AjnsaC4rOONILYlEXbDy+A9O6ukLMIcqLWUv0W34Z70t0z49y4jzq 354525Luai+fz7rPXT5RVfcG4kmWcu43AkMQPF5UX4lnQOC32s4DLmJNJqSAeyLFwdRBxx3luYKc6r 354526y+gYUyWX1DIcUQ7riIm2MLAew0gTrsha1RUiEx/Wcik0eJCdgvCjqzHO1x7GTZtB4NIdkzeE 3545274P5bRepeuUwGqbSKfJPaf1KZrPqbfEbs+W2Y3Zc4Tw2bgmPZDkMD9+NGUgbKalm7suJUhExs 354528Dj6VVjguT4MJX4qUfQEwF3hg9uVPrIxh6l2kUhmZjxKkHekFO58tWkRLGhic7gye4xTc/C6t 354529JonwtEAgRUYtEQFjPkBCv58ExZkvcGN9L9iIPLHwbpZibKiNmjjgDUl/d7Jl9V4Hiv6FCDjx 354530SUsxoP/+LhhdBMzsOTXX9DiahnLNsaffW67Vv2ZbzXbU4RE6xBKGNmNwPUvawOcXwG9PMnIK 354531CRCo/vvxGFt8eFoO2ppnUidtaUrp801oZ0yMkwtM40RxrQl8AjdjWhshjB2HYj8LwYGxFlN3 354532oiN1v6O670f3a2KKAaFpSNrYFhad99JRHFTmuJRdfjB3I0bh6zBy2PPQdkMyI/2/4lozDLyY 354533iWKKECpqhSXVKckVEbbkwB52Hd+VRAHikO8uhFHz+cq0o9rn0Fec6yuGgcscxBTJGWPdVZ0I 354534QZF/b02Cg6E5BoUqUuvS5LsAETj16n+uRv98+O5+zSDtZoWNh52RLcZVg7t07fHQgQQ8JkDK 354535qN0IT82pF1Atl7xDsL8Ja7aymnehndbGbbCeJWOgLOsKBlNkWjXiiTwvAuNteQyCLfV8329P 354536g7OxHcZeUZEby55vRjueFcbUAKZF8VjqLob3ZgKwUaWkrAbgYqZi7pc824C2fHI2X9AdWUNF 354537C58na8bIxJIo+GbosfMZK7FRXpSIlQQcsOq3EespgMFxPM5/qk/WQmIIJ+1CLwsjmPpvQmye 354538jmyYZJ97u98PQo1yjkpF1NILq1mIvoqz8CWCiBHPAKAri5BdVEnGNhwjnRQZ9KSlucgrVz9P 354539qpDzaBO6mvPhNvVSndHQut+RgNEH1yHoyCWERyfgcWI0wg7Oh6+5AO03v1CC6orMolwIHZrD 354540e9QmnIuIwaObwZhCdDAjp6m49V0tbXbVD9xf0RFivjP6Lz9Cl3+NjwrDsbWzsOy2KqsSlcr1 354541wkQX8C39MC/4BqJiH+LCun5o4eYBa2MrjLyZrVLeK7/hxhwPmJg0x9B1J3E7+hEiiDHYzdIY 354542LjPvKokIP94l4uJ8d/BthuEYnSKeStssUa7706MdifHeDYsOhSE6jtxvbR+4OrgRPaQ5Fqpl 354543opEXRGGGIxdi5xZoO3Q1Qm5GISbiOOa2FYDTIhDxaqRfyoE2ykqMgOPMM0RB7BQxnHaKfsXV 354544xHzibHl1EtO9TGHTYx0ivkk07i9kZLJT3McIIsfmaD96E87cjcK9s8sJoGMIM7/ZmORHDLVN 354545Z3E3+j7OLu8CcyMbhkNI9iMMwy3JXHZpjrbD1tb6TlR5gPPUt7Hwxez9V/EwLga3qbKwIj6x 354546A2IYWRmpPWCCrRE9N7wGrEDInUeIuXsUc9uLYGg5GGe+qJH5iYMhdJILcfB1wYKDYfQ3D93Q 354547Hy7WDjDluWDOo0KNcTWEwMYWrr2W4MiNSMSS756SV6XIFvosCL5mVugyPxjXHsbTJTpvnd2N 354548VRuu4jPZ3z4nXcICDz6sicMturoUZ2p1KU76fBO6Yn4s087Kuz8Z9kKV8yU+sAV4bgsQVyRn 3545492ChXxxEQokMQkgmwS+m64uqoWJqo/CgQ7iIReFTZyWpdT5YTjmnO5uhBzg6V3p+P6MBW4NmM 354550wqVvVXSE9NMdxO4SeWP5/R+Ks6Q6w5IJ0SfVHS1yyXsc7mMJy75HGZHCVQUf8EKtJGnS43sI 354551HuNC9FQvBN7P1gYaixOxuKWQAWqr5mBtBKcSPFnhAUGrpYxsig2VfyuDSK174G/ab/WfGKH/ 354552bfW/rf63/Vva6sSSvp5Hfys3xllKYTdZdwLRVkj2y2GbcOr4AvSefAYxUeexa/t1+nxW17Pp 354553TLCc2rMB0mfhLn+YcQzpUqJNicOGw+WCS/2MHTDqMnsglVz2HTdGWdMBdW/yUrGvhwWsB7CX 354554GpBXfMBRYhs2aWaObquv4sV33WUA6Gj7d6GY37UdAgb6EsccVV7vMJ7kMZ0/0uwIzG9lipZj 354555d+BqzHO8fv0Kj+9fwJ7Nx/Gq2jEcE9gXgY8KiBP0Mdb7iGDeaQ6Cb0Qjgeg0N0/+g3MpinEp 354556jF2CPvMVwViUHnJ5pCOcBm/ChXvxeJqcjIf7esO+jXaWVVnJO1xaMg7rEovozJZZ0TswadZl 354557fKtqOK5Um9S8B21LXhkEO4/5uBj/FPHhhzC5uRk67lDgO+rvofN7l6fh3JRW4FNZjZqawH3K 354558WaSV1eByGs+c9wBTCZY7+Bpx8Oh4ZrmsFGmXF6Gb72QcTc7X1oWkxUhPeYrYW/sxtrkrxt+s 354559gyxVQQX6tYOA64QxIa91BnjRQUBCe0x5kM/4d83yyVeHMAlOgq7EkVBGnAoDPGslnijnWel3 354560pH/6hE81v7REHBvnAp6oI9bGqpxklM63pLUXwyegyLJtz8CEylN3o7PTAJypDsal2hwfPQYH 354561XigIRHn352LgsgitDAMlyUHoaGIEVzW7TLVmCvFoDsH9NOwNnXvLjwdY3t4UFr7zcSTiCV69 354562iMGZwA4Qcx0xaOEEtBGbw2f6AYTFPceLuItYHWAFfstFDNxFmnUD4+14aDH/GsLWdoJY2B4r 354563I3NqD36urkAh8D/AjpXUE7/8a9pXZeLaBAclOaMq/Sz6iHnw2fqKvT1Z//mPlsLDWIwewW9o 354564G7YgajocucTGIw7b2vaWGizXyHkGgwhSXyz3Z3DZ/0dbTRy2Nny2sX+TSaUoe38I3YQm6Lw3 354565FaUszyPLvIQBps1gP0XlgP83sNW/7hoKO5nsBr55N2yp9p/Iil7gn8EEe7QdjH9eMAPuqX31 354566MMGLjdzm4qHaPSTfbmFxByf4r76HrHLKuSyGoataxqPG4LV/8DUNxWrZfDeUv+D5pnYwNm6H 354567Tc9L1fYUKtjQnA7YLpK8xl4/U7jOjWatLlJvTPRvb2dmTPwuDhDwHNB76VGERcbgQehGDHTg 354568wWbYWXxRr+xRX8y3njiurrbhIYHwtyBtZ9xhZNf82X51tWXDdnXhvT/zN7kkHVdmtICJqTcm 354569bzuPiJgExNw+iGkt+bAacYUR0P/bcNz/WFsGD+LxanS0MUfLqbqTNtT0f26CwucwN/gaIuMe 354570IWzvWLhwiL7dJRhv1LgQ9cWI/5S2DcWKFT6KhzQpWmDvVjd234D+m+g04EkHfPPBuJRZt5Ob 354571Msi+vUtFSkoybq/2hkWbZQhLTkHK43OY4GyFXsGP8CqF/P/Xn5CnthmVp2xHB3Iw+BOHYMH3 35457225gx+ogWI0uaHYlVncRo1kRhXLYaewjJ+Xl4EtQN7sNP4H0tdRnpEnZpl7DQR3G9gfUQnHhf 354573vyw3krSDRAkTwL+OSC55cTwCW/AUBxZpV5wSioOXniOvqgIfjg7GQKrEWFU+Xl45iHMvFSVr 354574GmMU/zIQnQDk3y6Ngr39SFz8VqXxLtXM+tE3ka2xgPMfToG9kSrrhWafdDRMA7MIUSl6Dwyw 354575Bse0C4KesNd8VETlC5TGNsd+AHbE57IDSORwuxfYFk79gpFSIqsuMSMGz2crXrHME1l+IoI3 3545767sLpm9FIfJqIyEvbMY44SpsJOmJLsprRLcvCtWEWaGZoDIFddwQeu4O4xCicX9kdlgbGaL0q 354577kd2hTTm+h9uAYzcaF79W6pyjxamnMcWdT4Nl9HtyHDBkXwKyK9XJZz9wY6g5DInyGq1Wn1yW 3545789whLPLiKaDm1MpDyslfY1lEAob8qol/RTy7Cx9nAgCqXokZik5Vl4tmNA1g8zBtWnKYwsmiN 354579QQt24VLCFxRrgANURia7ZnXXsTfVyPhEvWtZ5jOEBS/FSB8bcJsawtSjP+buCEX8Z2YdWGle 354580Irb3sgTfYSj2PdYmrkjSjqGvpRX6H35DK0iUcz89fCvGtLcBz4gP+y4LcOLiCnRovZDO9kYb 354581wo6qTAbKsX+yHu34InTdrzB+5UVxWOBmBKtRt5RrgI5suD0a1iy1+41semJj1HelolCVfhp9 354582xQZwnHa/VuKl5hyg+68FWFVkqDGGd7VCWNszUT+TznuV3722tsZt1jPSBEuJwj/UwgC245jR 354583NXS5MfU9ixiqMnnd/at+Rmi1NFFVOk3tnRfqeGe6DvSlgTDTME4078dtORc30iV1jnH2zZGw 354584MqrtftX98qj7FeNH2AhY20/C/Twyf75dwmh7KzqbXz5lYPOsMPpWjvYY8NpiA3lWeclTrPIU 354585wXOVgpAmzVRkalMHYmjSidAIzRfG6oyyog7t4C5EYXRfRjtwlfcxdMLMSAVAU1GSjTcROzHM 354586kQsTn7VIqI4Yqfx4HAGi+vf/WL3/ZjYYdzeb7r+yNAdv7m7FQALO2Q07TmclUe4bBUnYP9wV 354587PPpbGMDEoT0GzQ7ChcQsnWSnGiKC0yz26LKaslhcq1G4xUISpLODcJhkWkVUggnMBl9ROknk 354588xUnY6G0CcXemwih5T5EFTTHwEhWxqiBu2Vv2RcinCgWR16o7jnyooAm/92e50GDag1qyLFHn 35458939fzA2FO3t9ujO6SBxSg/+FYb5iSsWoq6ozNCfl1koFp50XqUQyz40DQbgkisiprIXPn4PYY 354590a4g0yjkqxjwcY6ytMSacHaCWZV0mhr4p+p3/qg24qzncNd/7R+Ra+JkS59HkcwQE/3X6CgWE 354591VVV+R9hwC5j2O49v1eeI5O1++JmQcR51TumcUpA5FqI51xYT76my6qSHjoEdzwVTr9SS4ZN8 354592k48hA2Ep6oCNiQVqRKbPCOklRhO+L/ZUp7+nS1SeGUrWeAvMuZ2lVp+/Eh9P9ITYchiuZcmY 35459334KO1JIz58CJ/rAgYP+WJ2olDKszATYxHcA4xyX0vk9A+ulhyKiUq/Sts0TfMh2IS1kyNRL6 354594erQRMoMIlHq20BmzoguZ/YqJwfIoA6/Pz0E7Mwv4LrmuFZ1CtxM6YkZUAfM+XA7cZt9SOhUo 354595QnU4ed+mHDfMuqU2NmStj7MxoQlSNfteSdIaeHHJO80IQ2Yt70QT9oIDYCbuzNAPKSAkYUkr 354596GNtPxcN81dgqIvWawWrgMcYeVZxIke8tlPsF9Q2+UN9R7MvslwDaJwjA10TchzhTqjTe14CA 354597KSe1DTMqIm9pK4gpHbNMB0GfzkIo0iLW0uDb5cEwN+3LTK1PRXvv6Aih43REVet6X8/1hVjU 354598EyGfK1Wkx4SV8BK6Yc49xTlEpek3JcBCArWPU0TlYY7wnL4JI1zdEUjOPGqefjnVH1YOExD2 354599nWnXVX45iyFWfLReHY2kk6PhKGiOaZe/MGyfwph5cOVT2fpKVGvswkjYmXbG9heltdiHuYjZ 3546003I3M+dZYcCOd1Z5SzFHqTMvXvr42gpMsExcHmLJmt6Lfq/Ar3rx4ibffClGpVWq3EoWZefQ5 3546019ScQnH7Xfqv/xAj9b6v/bfW/7d9McKLJSRGTYC/uioNpKluwKuMKxtnz4Dz5MtHLqQzw0zE2 354602hAXYp4OhivE8qD144t449VlSbefK2HEpquzs4W4Q8jthd2odtifBbm6OsQeX6Ewcw2ZoYtIO 35460306Z3grhZMxgYcci/22O0RmCgIvP0BvSwMlLYzwYCOPoMxIwNIXj4QcMxWfwYa7ydMTiEYI2y 354604SuQ8PoyJrQj2034VHuXJVPbprVGwMqOCN3SfGydHT8TVLCny7k2Go9VAopdU6rAXrmLCSEVW 354605fHn5K2z1sYbfrqfIKc7Dx0eHMIk4RKxHMzGU0rRrWNzZBs5D9iEpJwuxu4fC1caXOJ4y6O/R 354606WFxJ93vIlAQnhw5b8aK4EmU/ErG1k5XSDld/j9q/YQXy09/iXXoBKtTmaEOfmcoUe2dNH3Qc 354607tRdx36k5JmXgvIWf05CeV4YKSRG+PT6GcS72GFZLiWt5xTfcXNQGAmNnjDv5FqUy3SQ4Cs+w 354608FHXH0Q8VzHmsUT6Z0ulsDFRZl2hsm8LF2vVglByUlyRhbRs+zHqz614KnToL91Z2hKlpB6zQ 354609iOqv+nIKvV2YWb7ojP6r28DaPwgxmQX4/uoKlvg6ovNGVTZxquxczIbOsHIZhzNpZSh9ewIj 354610Ha3QdUs88qRyJc4ZMc0RBjxv9kDO2oKyjVoqyRM1pJobEx0h8FyKyFy1Zy2MwcLm1PrkofWK 354611aOW9abvpzT50Fjlg6sN8xrs929AOvGaGaMZxxLizH2r3LVAZLe4tRRuBBfoeS9PO8lZP/PJv 354612al8YvwKexsQ5e0iR9Y7yvywi34DKMJzNhsGXJCOoowmMPVcgrkCmCPA94A8T1nXaDA7TVFnR 354613FViuIZxmRtbqrGTFEH8Sl/3X22rgsLXhs439GyXr23C1MfRqm1W5L6SfQR+xKtvbv4Wt/m3X 354614KPw6aTg3yZU46ntgS3gkDgyxg7HNIAQ/L9LSaxTZK6n9Poa+B+2vSbuA6V7O6LM9gd7faoJT 354615uWqVbhqF1/7B1zQEq9Xlu6H2mff/dCHnsmLOqhz5lK/XHH3OpqOqOA4L3biwHHQKH+uTAVQH 354616JqoP7ZoYEh357EdmwPWN0bARq/SZhmC+9cZxlW0JrnlTvS01PwIgthhK65mN77futrqwXV14 354617b2P/psDCB8Ga4Hlb1LFweRlebPGGwHkOHqkFWP4OHPc/17YRQRmK/nvAVK1/WclrhIz3gIO9 354618CFxnVaWbhmDEf0LbxmLFiuQTdWP3De1fB8EpHw+ociVdGgbqymXZxKnjALd5igOSPpRtdddT 354619llek48osT5g0M4DA0gLmLUdg9ZG7SM3XIN5UFSPj/WukZRWTjaASGTdmonX7QOLsK8Dbi8vQ 354620t6UpOAZ8OPZchTvfKlRkCsrwcbJC55VhiD83DW6cphD5BeFpdUYmKsXatg5iojQ8QoGGcvzx 354621eABEgrpryCuUKz4jwl25AdYQnOS/hiCiebDqIhzU+o2Kn2J9O3N4b3qmVUqOApIChGzvIsHr 354622Pb7gCwNw/FMlK9M4dp4rOCyZI3RJVfYjBPW0BNeyJ4Ie6S7nIJeVIOPNSzx/logHoUEY1YIP 354623Xqv5iPgh1XiGMrw9PhTOrWbiRkalkny2sDmHUWaqLil7uQ0d+Bx4rHyiYoGXPsPa1kQx57fH 354624hsRChlN9b2eFsve0RK5FzsgOnw1Xril6HXzHXq+fbBAfQqfD09wZ/VeFIDzuMRIiQrC0uxWM 354625bYfiRJqECUQc7QVTAzN02/QAX4pKkfc+AjuGOoJLlDCuBlGlIVLybCP8zYjRzXNA53GrceTO 354626S3yvpYyctDgdqS+e4/nz2n8pH/NYsxHVvE/emwc4SZe/M0GzZgK0XviQznJF7SPhM13Ad5qA 354627Cx/KWQkQT1d7wdJ/L102itrcMsNmoaVZC4zYcgERMQ9xYU1v2Au4sOh3Dl+p6MCCSExt4c1U 354628NiXEqdzbDNzm85URCzVOTuO2G5XjSWfJ2tgWxuIe2BuZrHi/5KeIuRmMGVT2oOazcKfaYVhE 354629bbyGVKanTzrfXft9avrvh/Nf2Qml+Q+nwcFAlUZcdU131TMpfy+Q+qlQTWlSPf8+jbYpH/IY 354630imDJ01Xw5JgwSm6qjB+1/Ymh2FX3LySKUVgs4qg0rWq/+0dGwt6QWT5MeY1pP1z4pisjDXEe 354631L24JjoZxorxW0A4ThrUCz6QtltUVCUdds74NuLWMcU2/PHK/m+R+dKpkS3J+vf6B+BWeMG2z 354632Fo+LqxSkKxMV8UHzWupZqWenlCFRdUYNOm071w4T1SIgCx5Mgl1TMfqd/6bz2Snn+HhbA5gP 354633ulhdprX63TXOiqYca3ScvA/RamVzCqOmw6FZffpvBtP+F2hDQ1f/Tcjc67ouAl9Z9gWq5EB2 3546346gOc270ck3t7wIxKT29oi2En0tid2a+2woene41QZchO9RaB76uqga4O+tElOamMdSnMjHX3 354635JtqB13otnpXIq5X1AbDgeWFlPJM8K/12Hv3EQvQ49hEVFWk42tMCTlPu0AAZHY1jqSDqVn29 354636gCGWfDqzU2ktc0vy8SzGOiocEQK/vVrPzGhLl/7lwXvL81r7VPUdismuXBi3nIErdZH4SpOx 354637oa0QLQJZas0TMHq1lyW6HWZPy06X7RO2xtpnpfV3uFN7qn2zujN31kefkWQi9tgSDOvkCnNj 354638A8Z1VqPvKM6FGjDBRJtIrdBdyB5Tsz/S5UOIk2XERXr/1zlmJdTZzof9xFvKEmyK+VSI6BmO 3546394DjNVBKKKT1gXRsezAecwqdypgGTFz0bzmKVvqiIKhRq1f2nnQKtTeBYPd/Ude77E2zAY5w7 3546401U4JAbN8L21Y7KQMixlqhpAUGaEDYGY2EBfVic6kj+/Xh8GCOO1OVxsnyn75LTB4qDcxXNpi 354641zvk3Win4le3E6sQaxX1MNZ9JloVLg8wg0MjKRhHnBpmJFYBOdda3r+f7wdREO+pD652KE7Hc 3546423QSucyIZZGGFbt0dQrNBuJIlUzPCBpG5QwFKzCxliqhgtWegvk074jCcGq5B4i1A5FR78DRS 3546433dPvy1NlQdLUOynjn8dxQL9Vp/Ew9btWNsnS5A1oSwEKWmCwou64UA0srHGIho2whEitrHbx 3546444+Vw56siaCgw81BPc1gNOolP1QS69NO9YWY/BQ/JfC1P2YFOtl0RnPQIyz2dMP5+voL03sEM 354645XqsStfcHyvmyuT1MOES/NrbD0COpWpkAKGfgUAuRYt+kgOXvtzHdRYjWK+O17Cf1oIPItX4w 354646F7fHkjsZ2hG9VRIUfY1H8FA7CLxWIJ4tjXetBKc8RExxgLHzRJx/nQdJleL6qrwnOD63C+y4 354647TZUEazPPgVhy7AHe5hSjKPM5rm8eAp9RCkLsf4Lg1Mj9Vv+JEfrfVv/b6n/bv5vgVO3IshnP 354648KHv9ljizheYDcPpLpYI8sXEk1iQWszi6lrCWVDVwno1HhexBGIlLWsLIfAhu/JDV6fSuAcEr 354649c6MR2JIDA+u+2JWYQ2eDluogUSmwls9IuPoP1s0cjA4OfDpQsynfCwvuqJwiNJnCTFFOpaYf 354650yfuD6GbqhJnRhcpnyKUIYIZCtJkWjIjUbNYAFAUxSELwzx6w9tbOeM0kOB1TEJxkFI41Gz6W 354651XHCETvCbuhaLO9kxMoZ+CluBLrZO6Bf0EOkZ8dg33A02PvMR+lZF1qobV4pDyCg7WFSfa7Vh 354652oJoEJ7Oab0pwplbDd+BRdpXWezRGtJ459hiGWJui295IJLNgYXkR42HDIB4YE1tQlcUgao4b 354653jJREG0v4zg/F+1IdGTskXxG2oDVMjF0w4fQ7neQmJXFolScEGmSCGrtZpKa3y6X5SD67EmO6 354654t4Ytz5zOnl2WdggBbeYw1oKCiGCEVku09ckaclPEig4wNe2EVQ++MzDef4Z7w72FI2ys7OHW 354655ygcTzn6idUPqe1XkJOLA+LawNOZA6NAJE3dHIlMzYKcyE7cXtYGl13zczCA6ZPI+9LWzx6B/ 354656FKXoKNthaSsjOpsJ2/pVlNwwQfv195CaloY09d/HbyioUI055cfoLrbEkOrM2KrxVzj7m4gD 354657cCDxE9LT01W/FyHoa2qGgRol8yVv9qKzCQctF0XWUXmiBO/Oz4CnQIR2gTfxrYI9+Lc++OXf 3546580/4NgruLwW25CNHK9p/p0ibG1Tgbc85L8O5QL4JH2WP8tcxq+7MaJ2o5BxcTNfeXl3iXVab8 354659XjVYbq+TXxqB5TYEl/0D2mrgsLXhs439GyVfUh/jykIPcE06YuPdJPqZXqUxzyIFBk3wueMf 3546606XH/t7DVv+0a5b+XpeHMBBdw6CQPA7A/mT2ZgMIvaYoBFzPJPWQoenkEI5s3x4hDL5QB/FT2 354661l7E2BrAYptLVGoXX/sHXNASrVa21vjj3Vc35L6WyWlrD0HYcbqv5LuhALlOFY57a41MO9IWl 354662oTGajz+BlGJZgzFRfWln0nk3UkqYmGtR0nq0FXthTVKJEsutF+bbIBxX0das3yktEndRzFy4 354663sLRtSL/1asuC7erCe3/qb8VPscpLgOYLmBnFaLJecBcIrEYrbavfhuP+x9o2hsuh6J8Pl1kP 3546646P5lxSk4MsoLfsvCEBtM9T8Ql5W4dv0x4j+hbWOwYtpHcWM48dXVjd03tH92glPFBxzpbqlk 354665SNfJLJVJIaUWZ0E8FreyxZBL31BRVYmsG8SxTZTR2Pyq6kgVOatz9PuL29gzxh0u7dvD2cQA 354666XLcpuJhewQoUlKQEo797H+x9UYTcqEB4mHth+uFwxEWdwfzWYrjNe6RgH5enYm9XM9gOP4cv 354667tBFejOS9vWBhYAz3hRH4QYDwvMiFaGnmix2vtB0X9ybawth9OZ3VojbJj5wJZ64zZkcX/Daj 354668WKejVKC2iNSiu2uLCEm/MAx2DmNxNVO7dmlNOSiFgqORurK7ECa+u1mdt4q0wgIIuh5kTbet 354669+Q3LPl7GvDYC8NzGIyS1uN4l7egovftT4WhojTF3c5mRHYnr0cGmPVbcT0d+dWms3JfB6Cow 354670ge+OZ8guLtWK4GZ3LkRgjJUBHKersotQjoUpxLEg7nOaUdtXLs/F7eEWWhEI9JooSsTatjzw 354671fTYjqZgdoJAQw7mXmSm6709l1LWXZlzCMAIWqWe8qVFUL8z2hrg6uqqpsQN6LliHSa2EaEmc 3546722kWNLG9Y+mIn+jkYo5mhGTz7z8OO0Dh8Kqqqxfj++VTiVJrur0+uYf/iYfC24qAZxxJ+Kx8p 354673NvwfYRhlZYKOO1LZ0w5TpQW9HTDwwld605PlR2OhuyOGn/2sKtlFO/tFypJusu/XMMRFFd2p 354674KLk1GY5GYnTfp15W7SvuTnWEAQEulQQeaSYuDTTTMqLp+XhvCuwNLDEiTFHGKP8+BWCZN6jc 354675ZE3/XDXHKnPeFyKOIvqQNX7sYwXzmepBbKtpy6sFsGQobQYsB0pJBt68JPvSswhs8RWA33EH 354676TS5jPH81uYT57NXZ3YzbYfPzMu13ZrlGBWIpwA6TzkzSiPq1Sd+fY0+AGTh2I3EqTVLLGGQg 354677dIApI/JE1zjxO+1CKrkfZTCOtnXAmH+C0NPSERNvUKCygnRl7DANkQXaz2TSaTd9rYJlvABu 354678IuIYf1mkMKQEXfDPe9Uz5t4ZAYsm5hh+O1fHfkfm6PWxsDW0wKBz1c756vtwWsxCKAFoXrx4 354679idT36cgp0wYT8iLGwKo+/RuYou/Jzwowobp/Q8fxOB1PEfmSEBu2B2PdjGHkNgf3cuoG8wuf 3546807UY3cVN6jmiWHVWQJobDksMeXUC3KYrBXBcO7Caz1PcnANWDqQ7gOE5nZG+pKc9mUr1uZTkR 354681mO3Kg8PEG1qp6+V5dzDSgk/vL7lUCTrT1ljzRPEslZ9DyLemDNBcvN7rR5TNPjjxsUL3WZ73 354682CGs6kLPRawFOHhkNe+PmWBCVp3PtF0ROg4ORdpkANqnIuIUFXnzyrmNw8l1ZnfuJNCMUA8yo 354683NN4Z2lmYaCDQEu7L2MgNCsVdVE3sq7fDnRjob06OJfoPMdAnnUDiWw2gWOP3MaOYPfNi5Vdc 354684nUql0u6AKUEnERaZgKfJz5H8YBe6ivjKc6CGpChm2fNKiYOstYkr5sUoCCCKlOaWGH7je63j 354685RgPOAtLuOrOdXPoNF/qbQtTrJL5UqadJr8WQEatAPWnmRQwk30Kz7r/kNQVwaz8Xdb/Q/maw 354686GXtXZfBXOyVEugyLgBP4pGaEUGXMhFpnVDFdwkvIIO0o+uULrCDmGMOLGAWFrCmyFe2Eanpw 354687zX1MPFbgifozUeUmWgq1Un3TEXICT6x8WqK8Pm6hG0w0dGu2d6KzFpoQXe92jkZ0nQJUEqiV 3546881awhw5qoRS8yCEZ8VTQ17RAUUGe2RtSelMoGZEZHA/+QabxvLbaArPgNrqwfhQ72lAOSKunb 354689A3MOxSO7et7UAAqhmoACAd9O9xbDcngYk1xXkoQ1BGhQJyoqAikoUii1T5N9++YUOIk7IEjN 354690IMy5RYxEi+EEBM7Dw3kt4Tz2OrKKX2Gbjz1xtGQQ4GQBWlj2wCGWc5LaPz+fHw07oluKehKD 354691ldWhQkW9C2E7nsxRaR4eLfWAwHU2wjWCDWqEdnAtJw4uYmOtuq/Kcqn8e+EjzHGhgKymELSd 354692jysf2Pe4WglO5DwpfnkA/a0N6TUo7HGcNrYLImeh88B1uJKchdLKMnxPicCRZcPQxlxBRG3S 354693lA+3QRtx+3M53WeDHOzAb/396v22Ie+m/231v63+t9X/tn9yW9Y9s0JR0k09OwUllweZoUan 354694oM7bs+OnKO16dakq/IzUhLOY5GwE014HEJ2swOBevdcmLMty72FOSz6MaGC7GYw41eXphG2x 354695KrFIq286UIbXRHHusPy4Xmt02qSMd6wqwPOjw2FnSM7ogOMq3a/kJXZ1J1iA/QAEPfhKnMUy 354696FCSshbeTRmr/ikw82DEW3pYcNG1iAJFbAGYdiEKG2ng9WtQHgY/y8D1sJGwdJuGuDnuvMCYQ 354697vedH0SWEimIpIoDGexFbN1jN1l3aygRuc+8hR0ZFvveEqXlfHEuTNOxcrA6ktKx2FtSGgSre 354698Q71E3UJcfBCKZZ3t0HbxA+RUOxvU3+OXnN2FUZjmYMmqq1BSkfcBKQzCwSuk5arKD1KZogq+ 354699vkdqahq+FVSw9kG3k6Tj+jxPmBi7YtLZNJTJ5HXMHYWuaTaQ6fymSO9bfYRwmfNICz+kM/q3 3547008cF6omPm3ZsEz76nGPhnrfejdL9l7SE264w1D3/oDGDVlPrMJcU4FSP11ES4iVtjOVlzkowI 354701rOlsAYfRoUin1nr+PYy1bsJKfKGEzmLAJ3b4w7rt8KyrQ2GhkfmKfgaCMbJlpFH+mjlielSB 354702xvvNh6sRsWnu5Oj+tgQbfX2U4PQ8G/TbGY9cljFvCH75d7SvQsaVcbA3JO33P2dpP1jpdFSe 354703G+mhGGlrCFG3fUitcY6XvMKOjiawGH6DYXOxyc9guQ3BZf+Etpo4bK2YbiP/ppjbubg71gZG 354704rvOUtjtzXldXj6Ec5zWZs/8lbPVvu0aprxAM4NBQOxg1bQZD8+7KcnWaknt7OMybWGJ0RA7y 354705Enagr7MHppx7ryTO0hUVro6GjaElhqqRPRuF1/7B19RIfbBaJR7vsRyJhdQeU4GS76m4FTQA 354706thwR/LclKwMHKV3k+3Vyllio+ZZkhXh+aAQcOUZwGKfK/l9vTFQv2unWnZuQfWJfNcGm3phv 354707A3DcmraMMtTVPzobq1rlnMb0W5+2bNiuLrz3Z/5GBUV2NLHB+HCm/6ImS71AAwf+HTjuf61t 354708Y5J9KPq3pLMSVRUlI3iYJ7queYgfVSV4trY1+FRQdQ05rAEY8Z/QVmWf1B8rrvFRCOqB3Te0 354709/ya/wqi7SEAEnQu15teUTJhb2awbDx0tHzgSO16WovTVHvgJ+IySFjUizb6PJT5emHb1Kyqp 354710EiBjHeA2J5JmG9KTb0Nb2FanvCujs0SYY1iY6p7yqizcWeABHjm0hu0IxkwPc7RdGcMaSXG6 354711t0hn2QPVYiYH5CwXGDtNx7082W8zitlEWvwVr9UW1otU7VJimkKRbla3NkeHoBesjGTFmGlH 354712nZS92kEWpAg9Dr5nz0SU/wBT7DlwmRtTK8mGUpAKkoIxzMEY4o7LcPubpMFjRRNKDMkmrMbW 354713r4ne49Qy/wzVNqXaRJK6G52o+tFqmS4UBCcjOM1kllSSS1Kxq5MJTPue0SA+lSN1XzeIuC2w 3547148GGuzm/65WQvopgzU6orgYUWHNhMuM+ilMlQlv0Jb958IM6rShQmroSXmQ+CaikRUj9AIh/v 354715I09h09QecBU0QzO+E7pMXIfjEanI0cja0vgSdZUoSIvGmaAZ6NVCBIOmxrD3HYtVR+7iVbYK 3547165ClOXAZ3vptWvU/lPM6+ieHOnZUZdKjsI62cmCX3aIJTOwcMuUbNZSp6cTpatlNl2pIVJmBV 354717a2Pdz8/xxKoapyztvOXAcqR26UYFIGOGIdUO8pInK+HBEaDLP+9rTT/N/N6K/s2HXGMFeCUf 354718QjDI0gh2Y68is6YkUPU1FhqHju7+uQznuS5RgLGKdL9lbGu9KBbzXblwnKECBZXjM0L7WWpA 354719SSObsbir/n1quUbZpiAKMxw5jHsxv4ciLXVF+iVMduZC2GkjEvJ1RDtWrymLYTeUddrZx8kY 354720DlMVaaopkuyOjgJwTYxh2m0/XlPZwioVEWPCHscYTmDNa+k5lh+JWc4idCIgVfhMJ3A19iB6 354721npO50vUge6YjWX4cVrflwdhzOZ1em/Huw3W/R43UzMW6+ue0WKiKoKP7JyB//1Bl6lg5vX5m 354722wNnIQiuKkXUcSxQZ74zbbcbzMs35UIKkNV7gapTUZDxX1mUMNOWyEqwpMuP85lxYjyRrReO8 354723y38wGfb8Nlj3LBvPt3aEwKwXDr1nceYXRmOmEx+eK8JxbaYLLHocUhJzKSLkYEsnzAgLxzIP 354724Phwm3dY9P8vfI2SEHYytB+Hw61ICJCRhfVs+LAaeoUnV2uefhC4jZSJglspkPd9zorCmowhG 3547251v1x4Hn9SMDF8YvQXMgkEqrunY/7E+1gNeIWI2tNjaF/f7I9hCxRTrU53GvA2PdnJsKVb4Yu 354726mx4RZbPhjoJSquSjwBGTb6v0H2rO5URMI4a/CmBQlJytJh1Vqp8rZXgZ5AOB/UTcqSZoFccv 354727RHOe7pKfqjGj2rlhYRyznTTjMkZYGcNjhSqTI92W74qp5xNYjRh1HYyOKhRq1/2vud8CjfvJ 354728ftzCBDsRI3Oe0rAYwWZYCNFysVrJzwqqtr8I1qNvM7MSVX7ByV5ixn6h6NcUNmOuIPbIENia 354729tMCsG9+0suvU3N9i2HXVtdX3sdDYfyo/haCnmEkaqomQE1sMw43vMqUjkirFp96nrncqjg9E 354730C772N6SMmwP+IvL8YRrPJVSQ7CvkWoCpwHokXXpFfW5optCXZoVhnK0QHXeqbI+a963PfqvI 354731ZBeB/RNbgW+kem6dYAMNvonQYXsKw9apSDuC7kJTBjlOsacK6LT9hcVPsL6dCK6zIxj6SGH0 354732TDgRx+HJ2BAMtG+NlYnF1aUP7dEtOBrnR9rDcQIZM6nm+q9C9sOV8BGbw6tLK6KTdkDQ8xJW 354733Q5TKWiH0WoWo6M3oILLD6NB0VLLpCRXfcCuwLfn2XbExOkcHsTEfH17E49aeUXAytsHIi+xn 354734S20EJ+n3O5jlJoDjkCBcinqMV5+L6DGrKspCPsteJqsowLe0t/iYVcIAef8LBKfG7rf6T4zQ 354735/7b631b/2/7VBCcagzLSshUP+BFn9og7dAZvilC7eNROnaVkqTL2fcWU0yWFNbBK6yykgo4s 354736R+JWHUEf6lhd0q21aM83hueiq3hcrTe+SsvRWc5b6/z6cQNDzJvARENXlxWm4PxCP1hwzdBu 354737yAj4t+6F1Xe/sWZrpTLipz+9ju1j3WFiQID2K6qAxvzoQPgNPozUz2GY7ET0sUmHEfMpD2WS 354738YmSlJuAxweyozCvHh3bGwkiFI4Qmh2mC/CmfUKCGieXFboS/lTNGh7xFSck7hIx2hpX/JsTm 354739SRtNcKoNA615j7fl0uoSddvpYJvytwfR29YDgVHEyavxHv8GwemX3EPyBVfneIBPdNgp5+sm 354740N9XYvLOdTdB2AzMbMZWleICZGL1Pp2vpXpUfjyGgxWgyv0vxaqsffJY/Zs3UpK3XZSJ8qTfE 354741Zn5YF5Vdb3KTkmhYx1ySkflzcUEHWLsOxe7Yb0h/GIT+TrbwX3ZDWWJbgfcYwcBhGh7kybVw 354742aDr7AAtxik1om918GBkHZj8VH46hh8hIK0uv7vmrKAcoMNFd1YLG+4j+38uUh9ar4hiZFBj7 354743QAPwy7+ifUEswWO4tbZfqdZeLv2Bu7NcVdnQGD8e2ge9ZMU3tfEzE0YmuvpiufXHZf+MtloY 354744Q22YbiP/piBUvkRQe55O31oVscGnOHFhNfQ8TVT8N7HVv+0aBbkpBUeG24NnOwgH4p/i1AQX 354745ulzd1gRtkhOdJZrDh8eoMejo2B4Lw5jl5JX3aL2SkWm5MXjtn3xNQ7DaGrycub80hbGdH2Yc 354746jMePSiZRhMqEIvbezAg0p8i6Tzd5g0fudaj6XvXFRPWinZEVBh+LZSePpHxEfqW84ZhvfXFc 354747um1zzL72kj2Q7PN3JQGw4f3Wry0btqsL7/2Zv9G+TB6zPG+NL3VTOwGcpt9TciV+F477X2vb 354748GKH9NDxXzLn5EHsGeiJgYzRyqCpDkjfY21kI61Gq/ahBGPEf0LZRWHG1T7U+2H1D+/8lBKes 354749dy/JonyGu5s6wcJ9Pi4nkkWacB5TXS3QZds9RVail++QVSZjEDVUE+c19o2aj/t5VE30axhm 354750IUSXYCZBgDKqT43yIKBuIp2Cis4q1M1O6RCimIO3xjvCbXY0DXCUPluH1lwTdN77mnlIl6bi 354751n74WdKS1Rd9/kFrCDk6c6SOGuN8FnfVBFYDIBQy1IobI6voZfv9Xo5g4m76cGQxbp4kIy9Lh 354752WP5+AyMsjeG1+qnKcSb5iNPDbMBruQiROkhcivqJYvQ5k6671Bwx7jLCV6KzqTHsBu3DkwYA 354753G8rnK3uLYwOtwLEfjxtq70C9W96bx4hnlMaKxKnpLcARdMLGsBgkvsyoO8qJvOu5sQ4wJv1f 354754zVBLN0k2nn2dTSDupVLK6RJ0EQvQkmeLMVcyGO9d+eUshllzYD/uCr7VEvGUfrYvxFwvrH7C 354755rH2d92g5XWe859EPOuvIKoy+RAT5WxOw7L4yIu1XCJUWPT50B+b2c4epYVMC4rXF0MC9uJac 354756Q28gDWWtSgte4+7hlRjTyR7GTZvBxKU7pmw8hch3+awbXp3zIPMSBrj0wZnqkjtUphpbNdYr 354757rTA934oOFor6+7Kipwjyc0F/tTr2VA1UMccRow9FaJVUe3B8PJyNTNHvgmLjprO6iHhaGzxF 354758cKSYo1yBP/ZXs8hlBTE0kYbfIYg1c5es+AOevPjBeG9F/8xU5TVzQZIehsU+IhhZDcIxNTCm 3547595pnqY6gr2tbPUJcT5+kqLy64XsvxiGW9S97uh58JExBT9M9nzbhVk93NxG8/3ko035mvM0sX 354760fa83VLaTmqwVLNfurMnsQtZM7Dp0EHDgPPmSMgpCEyQPEOkmbqn6FaL7kQ/V6dLzEDHeFk05 354761rRAYrQBB5QUUOcZYC9RSXqu2ZunyOVMdIPKejuneZP/owyRCygoe0eUKTDoGIVljrshK3+P8 3547621ObgiTpiXawKgK15d825yA6CxdbZvzHPE4H3s5UKSs1cbLeJmZZXTvqiyn2aDzyvTP9a/D1P 354763C5invkXR0y10mc+WgTHa6SjpTDWmigivUl3EtkhyHhrCfMBZJnFUVoKX+3rAlCKOsmRJUkT0 354764mqP/rh0YZEXA3LWJytTKTALWE6z04MOu9xT4W9tj3I0slTKXfw/jbczhN70P7PmeNEmA9Rml 354765OXi4vB0BK9tgyf0f1enPK/H59ABY8L2xKZmFIFAdvcZxW4C4otr29SfYEWAOI7Ou2BKfV2vp 354766RQZ4ergbRLZUiQ6WLEzV0QeW/tqOIkUUr0DLOVQfh7vivcqQFroEM/cq6vQ3VPIjxsKK1w6b 3547671IhZssJEbO4kQBOhWo11mlxpCI7HCgbTX/L5HEbZidB+0zPlmlQQNU3R93Tt6eVpw9qYtFPT 354768XeTSXEQt8yJnFTMaiO5TYI+Jt7Pr1NM+nQiAmCUjFp0lkyKRV2cfVIxfPuLXt4eJoQvmxhQx 354769nBI0iKdB9q/6eo4ufzDocqYKDMh/iKkOQi19V7FfaZB26H7FivOAzOOold4QmXXDticFzIgV 354770up2QsdfU3Edz3y6ImgFHIXOO0IELBHwUVjuXVI5Igdb+xfZOkte74WtijkGhqoxkdKahC+Pg 354771IPDEsli1OvF0v81g1HIx4tXWVkV6KMaS+7VWy1JFf3OeOQaqG3FkHCKXtQbPwAHT1KJFlO+7 354772M7XO/VZpwD5ZBU+BKkMdRRIzH6oN+Eq/haK/qYYxSeZC3KrWMOZS5SLVAHvZd1wfZkGA4UO4 354773f6gfLK0GIEQjsxyd2p/oPFPGecGmx0G8l8gVmQv728FjzGS0t/TCKk3wguzXhUm70ctShLZL 354774IpCVF4/lnjxYD7ugBJjV22bfGg1rnj28XUWw6HOYvoe2Hp2Oa/O8ILLqiW312L8Updf4aL3u 354775GWvghS6CE7XfUqXExeaDcOFr1U/pvP8VglNj9lv9J0bof1v9b6v/bf9mglN56g6CQQkRcIJZ 3547769vo8sTV4PlvxkjiUJG+DMXrePZrsxCZ09mKOA6bWI7sqnc3g8lBYcFsiMLZQY3+WIO9HMeu5 354777R9/DyBpj7+oOfKPO2So2u4X8e/6jJcQJyUGrpQnaGXeIbvQ1Yg38zIxgOeB4ndnUqSyjA0zF 3547786KuWrVlemY5LE93RduYZxD/cj3GeIhhUO+4MxB2w4mEyLs/3gcf4UFY7uzb8MetuINpYdcDm 35477956UEk0nG3j42xF6/q+Voqa2PH09u4lr057qxPOV7nEX02RFo1W0vnXGasoNS9vWCq/ckLJ3Y 354780vsHv8f8WueQzLs9yB5/XAtNCP9RbJ1XgNgTD2qamy8tK8WpPFwi5THKI0i57OA3uXfbiTVkW 354781rg1rhSFXs+q0e+QVGbizuB3Rybpggw5i+8/KlTEucB64nS7HX5S4FK1tfRF4NY1Roo/So6Pm 354782u8HIwBpDQpikAJooN98VXMcZiCqo+/noDDHCHsrs6TXYTvRST3CJM9tq5I16ObxqyqMZOc1i 354783YJVa/pTLA2GmaQuS/aYsr5DGW+hs1Q3AL//77cvxej/BNozqaH++pr0MBfGr0JpnAu9l1/FE 354784DZOOPzkG9kY2te6/KhxGgeVShI4YFkylMvcloh5nMTD6huOyf0JbbRy2Nny2sX9T+JiuY6gF 354785Oymw8ns0tgRYgGPeB/+8LvvXsdW/7pqSVBwb4QCezUAcSC6i/11W9p4uV8e3ILZ5ItM2lxfG 354786YGELIzThtMDc21kMPUp1j05YH6eR4aUReO2ffE1DsNqatdZ2RRiePn+BF69SkZaex0pYVzjy 354787xbAec4cRaE7t7d8u9IOpaV+lT6u+mOjf026M7nZNyN5+Nr1OXaIG8+1zqnbMtyE4rqKtHSbc 354788+lHPtg3pt35t2bBdXXjvz/yNLp9oYomhagEPVPDw26MDYEX2FvVs8b8Lx/2vtWUlzxk2UQbV 354789sNuqVAYnLkxtXdBnazyN4VH9fwkdCwcTdyx5lK/svyEY8Z/QtqFYsWKPphJZGNQLu29o/03Y 354790FfreMBN2xm4dACs76PoDYWMc4V6droo2qGx0R0jkPZiPPiNX4ditRKQmhWDswCDcT7yFXaPd 354791IHKdgqvfKhnGSsLGLvAYdUpptCsUHCeY+y5HaFQ0wvaMRXNzH2x8qsh2IC9JRpCvAAYCL0zc 354792eQkPExIRe+8SgpcORiuxAOYiDjgu03A9g72sW+Q0ojxppLtmvm8B4lZ4wcR+LC5/+zlwvS6C 354793E33YjrOBgfUY3MmpO1MUHbXdQwx+23VKJ7KskHJcmMN3h24HPx31MMMFXDM/LD3zALEPL2Hr 3547946JYQmvljc0I+U3Go+IGkiJsICwvDhY1dYWpojf7bL9L/PzwhnQFAUIv34/kpaGFsAFPfJQiN 354795eYqkpCTlLzn1K0rU21d8QMi4fpi84Qiu3ItFYmIMIi7swix/K3D4Hphz/WutxB/FmGUjbKQl 354796uJ4rtcp+0TVFQ2ZiwuK9OH87GgmJcbh/aT/md7cFV+SDpRFZzFrrVGm/8yNha2yLfhtCERlP 3547975lvwLHQ048F5Yig+S+SMMbwzkxrDPjhSR3QQlUJ3jJ0RTNzHY+flSCQkROFa8Fz4WXBg2nUr 354798nqix5KXfo7B/2xFcexCPxIRo3AzZiLFtrOAy4ghSNWv3liRhbRs+xAFH8UGdEUmcZDeIk4yK 354799amJLycm2SZVlJOH6/kAMbWcJ64HMjEz1lYKHU+Bs7o5+c7YjNO5znZnGwkZag++1Ek90lISh 354800Ha/uPkQZKlWCN/6m9hh2KAk/SoqR8eQkZrYWoJnlYITcv4y1fdzQZuZlfFH7TuPsOcSJdxZf 354801WMAt6bfz6GdqhBaBCfReRmdGMDRFz30PqufsE8Q/uIz9c/1hyRGj88Z4FbOZzJWMsDloxTOC 354802ddd52H/5PuISExAdfhEH106Er60dhmoARXT/BmJ0330fT0n/TxNj8fDmGewOHAx3oQE4dv2w 354803LYYJFmleo76ekpJTkVEqY7blOGFmPcpoUtkcssIXwYtvCDOfqdh+7i4eJT5GQnQ4Lh3egCl+ 354804ROkniuhGtcwkdP86UrnWRNZqZj+r7ZqauZdzewysue5YpuGUZbuWUsTeHRsCayMzdN+pSgur 354805nIP0eBHFbn0o7ty5w/iFR6cgr6r6OxtrZ3Nhkq72obMJOewvMFnLimuZWUHoQ/j2eNgZkMPb 354806gAuPlU8YUSTUXMm8OQfuPC7sei/FsZvRiI+9j+vH12NsOzNwLbpg9T2moVnz7pPv59ULEM68 354807OVdn/xyxDxZe+8xQdBX927KkKS1A9BwXGFkMRmh16tTTfe3h2ms2tobcwMO4RCQ+uoOz26ai 354808o7kRhD7LcO97FQuBTpFJq9bMXbJCJK6jCB9m6DhjF86G3cGtKycQNLUTLIwEaL/8AX6wpW2n 354809HOXEmDUia4/jNBW3vusonURn5uKjabNm4LovZUQjUSSaea6G9N+EXdmdKhQw/OboENhwbTDk 3548102BvGWSfLi8KC5jw4TtbO/CQve4Et3jyI+57TWSOcAiWODLWFIQFm+269jUTNtU3/nuN9boU2 354811eDrJDqIu/7CTDqhSkWf7wJKtnGrWFQwx1yYS1tfh/rNCEdO6EX3MfuBmXHoYjYjQnZjS0RVu 354812tnxwmi9CfPXzSt4Ho4tYCKfmzug05wjCY2Nx7/xmjGghhGXPXUguUvuOZSnY5S+EkVV3LDl+ 354813GzHUHnzrNHYsW4VzahkT5cWPsbq1MYzsBmDTpSjERV3H/tnd4NHcHEZ8DcJO+Wvs72EKrl0f 354814LD9+E9FkX0yMuYfrJ3diyYJdeKqmnEdNd4RQLaW66n5PsKaNMTiOQxF0OQrx0WE4OL87XG0F 354815MDTth/NqRA2a4CliEm5oJxlV5kCoIO8q21JGk9ARMzRKItAl8YTMFK+KflXnARU8cHq0PfhO 354816E3Dhk4TZTsh0+Cnuw+yP0qde7/GF0GEqMz04TQwXwn7yfaWxV15z/YO630kueY/DfczBcx6B 354817bVeikBATjlNrB8NVYImeO58yjB7aOBcIYO/siI5kbtytnhsjWwph3iUIiQXM7IGrvMg3IP1u 354818vxaNuMgr2D3NDy3dzGAkDMDxT5Va7ztNRymL6MX9MHThTpwKI98yMR73Q7dhPHEKWvTYg5fV 354819eueVIRYwbjEVx+4nIunZC6TlV1WfjZGY6cyFzeBgJH7LQ/bHxwhd2RfNrXgwsByBsB8yxvn2 354820YrM3BKbN0cpCjPabn2kBxIq0181gYOSACWHfq8H+PISPskIzcgaJ1TLVKfW79ycx2sEELpND 3548218UmiIGlSZaytecTQjtE25Cs+HEV3IVU2xBfb2LI8Ef03YqEneOQcHX/oAZ6o71vPUpBerL0n 354822S7+eR1+xKQaEZrA6hXUSnCh9djh7Dfi/meD0O99N/9vqf1v9b6v/bf9rBKcfYSOILd4SizVs 354823xS9nhsDKUIR20w/g7M4h6L7gOC4cXI3AvUnK87MiLw3PkxIRtsobfF5bLLuWyLClv+oIgpTl 354824RWOxBw9C70W4+Cob5RWlyH4XheMLBmB0yEftjJjVQQgCvq8y+zSbVH05i5H+I7A25B5epOej 354825vKoK5XkfkXBhNfrYEidn60W4m1Wlw+ajAhnawdhiBO7kqu6fHbkNq/ddR+KHHJRWVqIkMwln 35482657WF2H4UQtMrNRz7SQge6gSzFgMRuCcEZ06dwNFDBxG8PRCDW5nDacgBJBU0PGM9pSd+uh2C 354827e9XYrjQ3AacvpGplVvhVov4ei/eF4m50Ao1jhB5Y+lPvwdBdij7h5TM2G435e56WVydmWTe5 3548286RMuzmgJnqElegVFIIW1NO1HZBRVsWApxBlAbFq+Y3+sPXMHDyKu4cjy/nAjOFdTbktMO/YA 354829acXq+mY5Unf5wZPgNgXERlru05mhm7Pjx7mIWkF0VF5zTDqRiLeM5/qCH2WyX/Jdr51/hMwK 354830ha6aEXkOt9+XsOLmVVnhWNyO4IAcOwQsPIArkU+R8vY90l4/xKYOJuC3X4d7qdpj+CmrlNGf 354831JO0Y+pjz4THvMt7kS1CWk4qbm/rClmeOFs1NYchrhSnHE5BeVAFpRTF+pD3BzaP7EPquTAN3 354832oMpF8xhlz1nx0qg5cDE0hB3xiVwhc/bRndPYOr0bOs1S2FFVGVcahF/+59t/u0xw8vq3l5e+ 354833xA5id5p4r0eiOrZDBUQc6wEhwRTnX4zXWqPPXnxgZApTYrnEbyFqMwZrD4ci7M4tXDt3EJtm 35483490MrkbVWafsG47J/QlsWHLY2fLaxf6PP+aTV8OLy4bM2TIFtPY5H1J1QBK8ag/bmhjC0CsCG 354835h9+1Mc9/AVv92655vKYNBDYDsD+5kDFHa0hOJi4zEJ5dUyqtGCnHiQ/VzAwCIyPY9lyCo2F1 35483636OxeO2ffE19sVqVb4XgQ5H18K0QfHq6owi+u4gecjIYIQQzonyP4SdXoo+dEK3mh+OHVHGv 354837emOif0u7N/vhLzAi7Tar2rUzh7X/NEz3MwfHwg/zgq8hMoFgrrEPEHZ2H1bO34TIHBbM17Ir 354838Fh0OQ1RsDB7cCEFQ4DKcUfPFNgTHra3t4nk78aSebRvSr2ZbNmxXF977M3+j8NYjfS0I3joc 354839WylsmvhzTqzoCwe+Ffruf87wqf0uHPe/1lZTih+vRkcbc7Scql0Ss0akWdcx3t4ABhY9sCaU 3548409B8bjtPrhsJNYIHu2xIZWTsbhBH/AW3VpS6smDkn64fdN7R/VoITVZfUyH4ynVGpviLLu49p 354841rm6YSRwBitIUvWDbYZsycltTil6dwYpRXeBuIwSHKnfVlDhFbb3Qe9Y+3E8vV0tTV4GvV6fB 354842q8NSPMhmguOSL9expJsDTIx4sGozDBtvf2HUy6/8HofDC/qjNXEeGRkYgWfuDO/+c7E34gOy 354843Hm9GBxND2AwNYY10+nphACxsxzPKKik/OFGuipO3wdfUDiPPfv55w7UughNxyCwnQIrV0HOs 354844pW+02tOkAgNYjVKU1KLG8FNIf1i7TMXtH7VnTpLmP8Ox2V3gLOKCZ+aMjqPW4WJqoXa2jLSD 3548456CpgS/9qAOdZGqXcylOwvQNPZ3pZUe9TDIOPSsEctn4cunvZQ8w1QDMjPsyd2qHv9CBcfZVf 354846v4wWdKo8Y9aSVJTx/v70Igzs2ALW5FA1MDSGqWNb9J25A2Fv2csByaX5eHZiPnq2MIMxmW8W 354847LQMwc/9DfNUo31aYoIgc6RCUXGdWLzrbSepFrB7uA0eiBBgYmcDKvQemBN3AGw3SkiTtLGZ3 354848cYO5MXHgm1ihud9orDqVyEiBWSNV6WfQR2yoFSVBRQEsJM53+wnXlaXO6j1HZRLk/yhs1FyX 354849Fv9AXnn9wY0VHlyYD77CCnYqnuU7wsa5wXvdE/rQpZTYpH2D4chVpAfluQ7B8lW9YdnMAELX 354850nlhwPBHZGuNkbNoTwW91RMiXPCHPwFGWQnq73w8mjHKbhuR6R7TrNxM7wt5qkWmo/S/78Sms 354851HNUZbhZ8GDYzJGvJEa27j8aiXdfwMp+5BjX7b2rIg6ltC3ToOxHLg28jNV8bzNR6JvUf7SiX 354852MtuKAnDiU2X9vrW8CjlPT2HFSF/6+am9k2/mAE//IZi18QTuvytgkK3o/oXsqVwV2d20yRO1 354853XaN4BkU6V671aNzUOEAV13bHEY1r6RKk81vB2Lgl5t7K0n5GHeNl4n+ABs/pNmLm2Gmu19y7 354854Y2HD02Yt67pWlnUDo6ybkvtYYOh17drQdFRqwnEsHuIDJ1NjGBmLYduqC8auPIHYTIlW+7rG 354855TfuZSf+JJ7B0WEc4mxnDoCn1zhw4j9qDB19K2fsXdFWmylV/97z70+BI1V+/pGD4J53bhFlD 354856/OBuJ4axYTMY8s3h4jMI8/beYYCl6kJn0hIyI0lZn1uSiejgWejpbgm+oQG4Qlt4BkzGlisp 354857KJTq2BeIYvpPFwFZn+boeyxNZ7YyeeUnHA8QknEQwH/fG2Z0Z3V5vSbNbDBSLZJBXb5HBKK1 354858iQDtlj/UypxHpzbe3wVCcQ8c1CC4yrKuYog5e7pkpV4UtxBuhnWU/zRwxuxojahxGjwVwW1B 354859nM4ysYVR0+FoNRTXNdYTXU7NpBWW6spW9ZsJTnTZpdBF6OZI9DSuCA4+w7H24n0c6WMK0wGh 354860yKge49zwcbAh43roSTT2T2gPGxMuBHbeGL7mElKLtOdbRWYU9k7rjhYWPBgacCC080LPmYfx 354861opiZSbTo1UnM8XeEgGMMM7dumL7/LiI2d4CQhQhc+SMeh+f3VeiU5Hzhih3gRfb1pSceM7Kp 3548627PEVMlKqa95vbhfF/Uxd/DAh6CIuLW0NC42yIzm3RsNKzNy3a8ociGyYJVmzb45kaUtFOYyC 354863lagHjn+srLVfWV48NvqKIe64Fo+qs2sq2jGvpe8jYpKA5FS56NHWEGmU7ZTl3MEYa5EyI57q 354864emafut5JocNHY9/kznAi+hGH6D0tu03G1ptpDEI8vSavD4OFuCeOJkZg28i2sOYTR6B1awxa 354865dg4vCqTa3+BlCGYzvvkd3FzeGsKWixnZwdjeV12eHFqAYV08YEf0ZQMD0pdLJ4xafYFxz6Ln 354866RzGtkz0EhuQcMFI5Yam9Iv3mSvR2FcGI6LiWLbthyq5LODPZGSK1rFc1z5xDfUuyfxu5zCTA 354867pJRF7zuN3qIm4HqtVpLD6Sxas5zIs9krSU/K9fEtDHPdBbAmzuOX6muiJBmbvCmC/EEtp7I0 3548688zKGWfLgtTxWKzsffW11NA7rvsXvhF2pEm1QgErZLKDOVPYyyzoJTrSeJmSUkWys6D/BSa7/ 354869bfW/rf631f+2f3xbNnm62gtcs4G4mKlx1ld+x6O9k+DrSBwf5OxsaiSCY/sR2Pzgu9I+fBnU 354870HjxdunYtdjN1Jpe8u4jA7g4wblrd3sgCXgOX49JHCUv7fDyksdUpeFBLgBmFa64e3gkuYvXS 354871J81gbOONEUS3eJ7HxAM+RVxC+POvKCgrQ967W1jtawqzgEOMQIcPZ6fBhziVmtX014wHx27z 354872cTK5gJ1UXJGNp2fXYGyXFrAyUeheLfzHYvWZJ/jxX8p49Jvfo+DhZNg1q8NeIz/TAY0LDtTS 354873k4zqsg21A9lo0tt64ux2noQjwXPga2cCrsABvlMP4v7tVehkTpwLvbfjuVogqCJAtAV6nySY 354874+pdT6OM+Tks319bTqGyxunS/32c/1uqXKHqLm7vnYhBxqlqaGKnmv84fWyZ1oqffXo2e9lw0 354875pdsYwaLdGGy9+xnFeU9xZIYvbLhNVfgd1wpegzchWkNHpyokDLPg0vpqbdiwvDILUTtGw9uG 354876YIcEmzZ36Yihiw4gPE2BTccsdW8Qfvlfb/9oScPapx3rBwuTtlgdr5GRmOy/D6bY65wDHNZg 354877aA0sl8JCLZzRrvdErPjnDt4USn8Ol/0T2rLgibXhjI39GyXfLvSHqTrWTWxmkTXB8nuOQeCe 35487863ieW8ne57+Arf5t11TlpeJxWhFrX7KydCQ9V2Ufy7k3D609J+Fkah4yYg5j0SBvOIrr91yN 354879x2v/3Gvqg9UyfBEf6sbjlcGB4S9xda4vHCifnyGf+Px6El9iJMOXWF9M9O9pV4J3oUvQp6XC 354880v2ru1hWTt91GWomM+KSTcXbZEHg7EB2+WTNwyPdr5TcMCw5EIkvDr1cfzLchOO6f0JYN22X7 354881t5/9G71nZMfjnxld4Ur2F0pXbhUwHbvCPzGyY/5OHPe/2LZB+mheHDZ1d0f/DSewZ1Y3uIq5 354882Cpuk6yQEhb1n8SU3BCP+/7dtCFZcY0PTwUn1xO4b2n+T/7sBSmUWODMOk65k/bbybI2Rqq+h 354883GGLrhjlR+VrPRZe88rVEqzm3kFX1+585J3waXO0G4kSapHGLKv8RFrtbwH9P/cts6L/8fZIV 354884Ng5OjqNw/kvFf/o9aILhsy3oZNMeyyKyqsuJySDJ/Yy377+hsFKGivx0fP7GnipU/+XPF1lh 354885nKJUzogrPw0M6r+oj+tjbOwggKD9WsTny/R/QP6W75p1DUMtTNH37BdIpFJWXar81Vb4WKqi 354886x+UyYjxWlSPtSHeIzIfgapb+z4f/h1R8CcV4J2v0PfHhp8nyzHOSqlPdCgKPlXhS8nfvoU9W 354887eEDosUJn1sc6x0r6Fef7mcJ88GWdxGp9F4pInrC6DUSus3D3h/QXzdFKRQkQs0E69x9dBKeK 354888D0fQXWSDsbdzftp2pB3sIy8jo6IKVVXMX3naMQz+FwlOv1oa8m7631b/2+p/W/1v+ye3bdzZ 354889lYWrk8fi1Jeq34BHUOWjMvAlPRP5EtkvPG8rUZxD+v30Bd+yi1GhQy+5M72FimDVlAv7HisQ 3548909rmcFWstpZ7zUzqyCiV/FN6q//Ib9TbpN1wguq1pv9qzUTCuoQJ9fLyx7HExCqNno3W3A/9Z 354891/eeXjWNVCbK/piMjt1SrXI6sPA8Znz8RzDEbxZU69FiZFBUSCSqk+m9n/ye/v+Q9Dg0aiH1v 354892JPo/GPovf9fcrixGTnGl/g+E/stfIbKcCMzrHYiHefp/1uq//Ek6ZC5eJb5H0V+OMdcXK5bL 354893S/B0pWeDsfv69v8HEJwK8WjxSGx/WfaHfaA8RC10h8u4G8jScLDfC2wL18EHkVL872yepwZ5 354894YmjIB50ZKfRf9F/qI0f6emLMhfRa69P+dzbQUrw9OQ5uYkf0XnIMES/SkVciQXlxDr68jMbF 354895PQvR36s9Ft7P0X8g7z8kFbnv8ezRDeyZ6A6B2A9bk4v1//v90vNWhuLne9DPzRU9gx7Xmm5T 354896/+W/I8WPl8OdU+3kEPfB2fS6HTmpOzqCXx1Jx2sfhJdl+j8Xfvt3enEUm/ecw53oRDxOiMT1 354897Q0vRz1kAm0GHkFr6a8c/5som9Lbmw2NFYp3ZJP/rcrKXGBbDrmtl66z3vlgUi/muQq3obf2X 3548986r0iKQZhu8fATeiK6WGZWg6exp9HErwP7gIBvz02xnxHeZVMOxJXg+Akk1VBUvQFEau8IbQe 354899gSuZP0+2ohzsrbm6I/tN/P/bBKf6vpv+t9X/tvrfVv/b/sltG3XOFCdg5YhNePYXEr0pm648 354900Nx3vUl/jQ1bxLzub9V/+kvlRFIcFbgK0WZeM0nrODXnpe1w9EoqXhVUoeB6Kozc+6H9wrP6L 354901fq4fSRYeP4xG/MMQzGzlgGFhP/Qfk9R/0X/Rf9F/+cNEmv8a0ZGxiL2xGQGOnbAtpVz/B0X/ 354902Rf/lXxJZaWaDsGJ51RecagB239D+//8EJ1kx0qKi8Un/nWv6L/ov+i8N2TvkFciKO4J5Aa4Q 354903GqjA0GY8W7QfvhwnHn1llKzUf/nzJXmjNwQ8S7TqORv/xH7/K8h4+i/6L79bqgo/I/XFczx/ 354904/hwvUr+guB5Zz4q/vsaL54prUj7m6f9a+xckJ3ojBrdRlN414Ahh69UbM3eH41PpryfLc81a 354905IGB+CJILpH/9uM50EqLjzsZnKJW8/wddRLaYEJEH/RdtsTcwAN+2A6YeTf7lpFhJWghGORvT 3549065T8MXeYipojZvybBKaSnSKHnCTwx9Wxao7+5ushKs/D2pWIvZPu9SstuVDZQyvkslWpnJVH+ 354907dGTb+5XSkHfT/7b631b/2+p/2z+5bWNEXpGHtJ/sQ/9F/+W/KJK0g+gqtMbo2/of7Kf/ov/S 354908YP05+y6mNefBkGsOjxG7kJAn1f9B0X/Rf9F/0X/5w6T05XZ0s+DA0MQBXQOv4rNE//Ud/Rf9 354909l39L8u5PbhBWrChrXX/svqH9N9H/T6L/ov+i//JfFro8XUEmPr59jXefMlEg0f+0lPov+i/6 354910L/ov+i/6L/ov+i9/vA5XWYTMtFSkpv3QIqVrEpyy3r1CyptP+FH65zsaylN3oiNfd2aSJvyO 3549112Jmq/1GG+i/6L/ov+i/6L/ov+i/6L/ov+i/6L/ov+i/6L/ov+i/6L/ov+i/6Lw2V/wH+kUto 3549125sYFWwAAAABJRU5ErkJggg==' 354913 ) base64Decoded asByteArray readStream! ! 354914 354915!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:24'! 354916dejaVuSansOblique7Data 354917 "Created using: 354918 Clipboard default clipboardText: 354919 ((FileStream oldFileNamed: 'AAFonts/DejaVu Sans Oblique 7.txt') contentsOfEntireFile substrings 354920 collect: [ :each | each asNumber]) asString 354921 " 354922 ^#(7 8 3 0 3 7 12 20 26 35 43 46 51 56 61 69 72 76 79 85 93 101 109 117 125 133 141 149 157 165 169 173 181 189 197 202 212 219 226 233 241 248 255 263 271 275 281 288 294 303 311 319 326 334 341 348 354 362 369 378 386 392 401 406 410 415 421 429 433 439 446 452 459 465 469 476 482 486 490 496 499 508 514 520 527 534 539 545 550 556 562 570 576 582 589 595 599 605 613 620 627 634 640 648 655 662 669 676 683 690 697 704 711 718 725 732 739 746 753 760 767 774 781 788 795 802 809 816 823 830 837 844 847 851 857 864 871 878 885 891 897 905 910 916 924 928 936 941 946 954 959 964 973 981 987 989 995 999 1005 1011 1023 1033 1040 1045 1053 1061 1069 1077 1085 1093 1104 1111 1118 1125 1132 1139 1143 1147 1152 1157 1165 1173 1181 1189 1197 1205 1213 1219 1228 1236 1244 1252 1260 1267 1274 1281 1287 1293 1299 1305 1311 1317 1327 1333 1339 1345 1351 1357 1361 1365 1369 1374 1381 1388 1394 1400 1406 1413 1419 1427 1434 1441 1448 1455 1462 1470 1478 1486)! ! 354923 354924!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:25'! 354925dejaVuSansOblique7Form 354926 "Created using: 354927 Clipboard default clipboardText: 354928 ((ByteArray streamContents:[:s| 354929 PNGReadWriter 354930 putForm: (Form fromFileNamed: 'AAFonts/DejaVu Sans Oblique 7.bmp') 354931 onStream: s]) asString base64Encoded) 354932 " 354933 ^Form fromBinaryStream: ( 354934'iVBORw0KGgoAAAANSUhEUgAABc4AAAALCAYAAABGbR6BAAA4v0lEQVR4XuV9aVBUSdpu/7p/ 354935741vbtyJrzs6ZmK6v5jp7hi7O6YXO9rWVgPZi6IgoNiLfV8EBC1kX0QQFTcUERdwA1FQwRUV 354936AUVAEWQREUVQ2ddiKQqqnpvnnOJUFVUFaOvYPZURhNbJk2fJk/nm+zzvkh8Bul90v+h+0f2i 354937+0X3yx+jSDrz4OeVi+fTMt3vDN0vul90v+h+0f2ik0U6VI3MuDhk3HyNadni66FMKsbI8BRm 354938JWPoHxJDKtP9NVRrX0l6UH5oBw5cfY5J6bvtJ9n0EJ6/GMEM+beD+vd3/h1ks69xfr03Dt8r 354939Qbj7HjRNLu15ZbIptBwMw4GmSS31YnRd24WEgxXomafPyWSz6L+1FcLs6zgeuQ13R6Tz6iXo 354940rihASfE+BAlCkNMyMa9eStqnIuHcQ5Rui8fZF9Nq1391IRb7qltwPm4fHo7L3tM46sK5zank 354941+dWvL5t6gmOh8bjWMzNvno6idncY9l4rQmLMJfTMypSeW4QHe6Jx7H4VMqIPo0X+LWTSCbTk 354942bsaOyiF6XlPvL2opQGrKaTSMzGJmsAY5KYmI35iMK68ldBvxszzEbr+Fuvw4pFUMLVkeUNce 354943rNiHjPwj2Ojoh+zmcc3yqf8GEiKL0T2r+brS0UbkpaTiTNOo2r1l4mfIi0jAmeKdEB5vh3he 354944vXT4HvbvzkPuZif4ZDZAJJ3f/ilOxOxEed1JxO6owvBvmMPSmWnMSpW/wTQ68oRI0dJn1Nga 354945un8MSWkX0DYuVaufaj+DmLgsHIqOQfHrGbX6ieYsRO2/h9oj0cioF6k/z0Q7LqQl4ljN4DuR 354946HTKpBGMDQ5h6gz6i2ogGhyH+Df1KzeHXVxMgsPJAetUQZt+RHKSuKxoYxISWcUeNX/HEJCQq 35494733SGvM+b9cEHkcXUc5J3G5+VvVGbcfJukx/w3ZgxNojJ2T++zvHR/APitgPgO55E14wMUy0Z 3549488Iy/iYo0T6Q9VBWMsrE7iA06iY7eUmwKLlITjDLJC5Rk3kaf/EPJZodQvccDPBMjOKY/wBg5 354949LhU9QnZkBmqGpUoL9ADu7PKAOccYaw38UdAlUQgb+nnuQSSfXNSi+7wgApvyFEJVNtOFgtAI 354950XO1jrjk1IsLU62vYkf8U46Lh9/LRqEk4VBEPrz2PMKE08cVdl5HgyIGJgR5sUisxqLL4TeHp 3549518SCYrVqGv/wchwfzFm3ZbD9upziDyzGD0Zo1cNxVjaF5i+f9NAG4XC6MVq8CP6UC/RreTSYd 354952wb2Elfjrun14LJapCJYXuVb4doUxzMzMwHVIwO0BxXeQjjXhdJQr+Jbm4FgE40yHQumQjT/C 354953Pk8e3c6Msw7ffvJ3OBe+VhHg1MIxWJ0BbzNj8v5rYBp6Bs+mVIVU7+00uJDxYLjOBIEnnqj0 3549543YcsFdu9YGNhhBU/WiCtZvitwMXM6/Nw/+ILeJQOKb3zKCpDl2PZalOYmehhxa9uyFZS9qSi 354955xzgb6whTEw5MDfVg4p2Jh6NStt3Xq01gZmoMfUM7RJ97iom5uaV8XeqbmNkg/FwnDaTU6uwi 354956caV7RumeT1CUIICJoQk4HFNwbDfhVNuk4robTBFaMcqOuZpoLoJuDivqwzgIrxydNx9GUB7C 354957gbBqTO08mXQcT/KCwXXZh5qhWbYuTO0a5HjwV/jTT4m0QksrgbXx+Om/vkBg+YjKOf+9LgOt 354958Yhn9fNVRFtiodC2qT8/FOYFD+tREXx+2cSXoEs/vNxOYrluB1R5H8HhC9kZtqW9iqv8LVtrv 354959Qq1csafmVs/tXfDmccj8MIaengAHmpk+bT0WAEvyHQyX/wUff0XmBfm/ZcBRMt9fIV9ghb2P 354960xfJ524cST3NsrWfGh6gmGryQcozMybnZHpT4c7Dx5iCR2ZmwdTuHHjIeKGUxy+QLcI93QkLO 354961nX6eA0fbTFYZr4qxQMi1fjKmpRiu2gpL+31oEFF9mwCuJyPHZbJJtB3zgHVSJdNusgVZvhby 354962sWUGk9Vf4E9/scKJFwrZLLofhzX/WgvnnQ9p+TxRvwNeqXUYV5YJ5NmO++vhy+WbcE/EHJdO 354963tqPkwBFU9s68gbwdR/3eIOx6OL7IeWI8OeCIgCsDb00QiKpj4LDlgcp7aCYw7mG7E5k/NuGL 354964PlPLXgesV5ILc4p4Z9FW7H8wpiIjX1/ehj3VI0y7fY4IVmun+fgfiqCg5vbTCtztnPrjPLN0 354965DPX7nGFo4o59j8bl62IdtnluR/2EjF0De0s3w2yFGRLvDL0TkkomncSzws3gk3loEXoSLSLp 3549660sHfW8w13S+6X3S/LKTnXcKW5KvomZEtKuPGH59ACM+Y6HemcD/YgkkWx0yjt+oIIt35sBKE 354967I7O8m8YzMnEL9joE4kq/lJGR97fBIewyS6JJ+muQG+MJaw4HVm6RON4skhNm0+gqjoSVoRGM 354968TT1w6PGUEq7owfXUZOxITMH552L2/t1lu+DHN6fxhIUgGvktY6y8kklFeHRkIyE3ODAPysNz 354969sewdyv6F7y2q3wU3c6J38Dywd07OTrTgsA8XJhaByH08sTTZN1qH/YF8GK+xQlodQ0RJXl9B 354970vDMX64xCcP6lQpeRTTbjgKsB1hDcxf7pO2HPo/ElymgRWguEMPv6E3yy7Bf8vDIIt4bV8XH+ 354971hvWIi4rFSfIO9Heb7sbt/QHgeJfQuFk200+wiCvMjdfBKGDp/S6b7sODgh3Y6G4NDsGea9cq 354972vYeRN3LaxG/0jcSva1BRP0Drkwxp14l75fXol8hUiL7oAw1qepImHPR7qhe3ZsDgzx+Dc/S5 354973RsOTbLoDJwQ/4fuvPsGn3+mDQ+vAXDhtuYshOf5aDLctCZe9qzolPLbYb+3HRKiNXYVlq0xo 354974/GJgwIcwr4Ulpn8r7vo91C8oK5TamhoZw0GYDOGG/XhIdK3FcNr7rteG04Zm58aGAfzk+Hx+ 354975mR24g3Q30h8mxuD4HEazEqFPyeFXV7Yi4lgzxueRq1JRO26cyMLxm+2KMSDpR82pvdixVYht 354976pT0s9yMVteJy0SVizHCBe9J1dMtlBGPE2IHbdaeJoeYOO3eo97ueuBcPusqQnHoXo++MOCf8 3549770q3tEB58iNH57zPxHDdzDiC37IWCQyH8ZH1BBnamRiCx5CUr62TTnShMSMX1h4VITLmBPtLP 354978kp4y7I7KpPmLOQzWXV2AQ4cvoH6QEPbt15Gzlxj84s7RMlub8Y7iAFsz7cAJSUfmkfNoVDIM 354979UkbbO2dLULTTD4KQY2gZV+XO+m4TY9KB+xiZ/26TXajMz0bO1ccYnZ17t2E0nN2PndsiEHe+ 354980i5VzMnEHSs+V4HSCO1wii9CpzA8SY9/FhGRcqruApORri+o3SzVmdF9PhfDwIzUjF/3s489x 35498168RB5JQ+VamXzQyh4XwWdiZsQtqNHlWeUfwcZ+LScLP+LOJTyzAglWnmZ++kwS/5FvpmZCrY 354982+fE+BwRd146dKcNmbvQuVDzIRczOGnZ8qhHnw7cImbu5miY/FiLOxa1ZCEipRV99OgL2Niop 354983gcTSVpuD2EBHGBnbwW1DNpoJkJR0nIC/8Br6RQ3Y5beLkDWDqEyPQu48K7H48T44+F2klcPZ 354984yWGIpqVaifPJloNw9z2Fjul5hPBxDwSW9NLKSE/lcexO9IeVexR2HLmBF5PKwmIIVwO9cObV 3549857G8bEOI2HPET4mrvrNKxdhxzscEOQoRIxa3Yz3fG6a4ZVYvXqAgjjTtg6VZEk16qxLkIPa9H 3549866AksHa7ABj0XFPdJVdpPi2cYhWusCkIDV5T0S9UHTGUaPF3NsNavFEMqxDYhNzc6YmejuieA 354987bOY1LoTYIal8YFFrprg1EzaW6WicmPf8k03YYSEg5No07a1Q4MRBcr0SSdx/HaE8IUr7Zwnp 354988VI6NnGCUDct+kzVrYlKyJHJCNjuFcbF2wqFvcJJcZxrtWdaw3P9ExdIt7qnB6eQA2PO4RNHn 354989wWHDAdx+JVYjVWrJnAmPc4TNnhZMsUK4HVk29sjpkNALVXu2FbjpTD0loM94G8Ajh1FQqPqe 354990+nt4MSFj2tk64Hgno9zPDlUiztAc++YWV/q6djj2XKJB8VugTvIShf6GcCOCbEzKkNPinibU 3549919yhdl2+NrHb5b+o7utjh4FPl+zog94VEbT5k8h1xUj7e554/t50sBjsdYR5+Fu3yeajcJ2rP 354992bb2aKP7eKCHjnhLkBT6G0PvJGkeeTSs93zrwTQXk/cg4k3TiuJMT+zyy6RfI8zKEz4lWWhmQ 354993zXQTsnktXM8xRh6mvQ2y20nbmZfId9DH5hrR0tvaOtHvKJP24ILzGoRWMqSntO8KAs2EuDnA 354994yAPptAhjYqmqwN5rBUH+S9bCLhNVY7PZehZgySbqkWzuyc7pma7TENgfRrtc1o3Xp4HnmINn 3549955PfMyzw4Ox7DcwlFWG8Hb9Vq2Ga2knE7hZbdfLjldynJ1wzYupzA047zCOYE4lzXNKvYZNnZ 35499641D7JIbuJsPaNRuPJzUtbi3IdjZEEFHWWWMlWci7TriQ+yjeZ+ZlPnyCr6vIHHrsviqAp2cB 354997XhH5Lp18itP+K/D5//sYyzgJuPGOCT2ZdBDXg+yxp2XqrRf6zhNu8L3Yu6BcoeZNzwUfOB1S 35499894pRf6YBXPF3QEar+A3fhbQLcEJmm1jj8YNvCIb/3WXh/iMGuXh7xNWI/jjE+XAZwh13olFp 354999jswnzuf0odcFbnDUAsw1lYZdjjAxNZMDY2KMcc9Gq9zoXJ0ZhvDMKvRJZjD04CiEIbtR3iNZ 355000Amn+dnNtoWfR/Trdr9O1uqWtG2K0nT1KDOnK4K8Lea5W2NHA6MBSqVQJ1CXB0mEHyjrHMDHY 355001jJul7TQBSRmIHyTZQlhBDKdTrTjo7Injz6dZfHHE3gibLj7FqHgS/a21eDintxG8kWHtROMN 3550026vpSFa86KcEcxShpHFEipzMh3FGKl3IdZXakAblRibgs94SUjtTjcKgdzDn6+NkgUc3J57eU 355003xe6tEXO05SI6h+hlXYWI3D3POL8ApqOcNppzIrCnTqR0bATVO9YjU4uOQDkbPMwg4yHswpKJ 355004t6mWPVj3p4/w0Ucfw/pkOY4nnGb1NhVjcdstlD4aUsFY4qe5EGY20ZhggmBrv/QHBA8M4XpY 355005AM6+XhynSidakeOpD/uthMR5NQYRwWfWtkd/U3TezKuz8DCLRfUY0cOnX6E43ALrC14sQdfR 355006jIN+P/VDqIh3x+YUF9ikN6vXUx7vpUI4Jpfi6kZj+Gog3xncpq8dt70NLvtNdQ5K+Gfh31qP 355007zRIsJOBj/xOx3OhUizSOGXY2Tb0j3PVh66eG+llvXWoeTgwMKAhU0jbf2wi+8rbTXWfh+fXf 355008YVfwmsY2i+G0916/AE6jvwtPHwl14xrWpEk0bHdE+LU+iIfrkU3I+e2PJn8HTjNzHuee2HXv 3550093Xmc/+7xA8HMAw8KkXs8B1scHJZslP1DvePMOEYmZz/4c0heX8aW6Dw8nZKp8QNXA+yw+y34 355010gY/mK3xP9lvD6XQXLWCk4mH0DE5gcqgHQ3LFRibpxvXUQDgZfYt/mTjCft3X+N7MBcG7q2gr 355011EjXxY20jUVp7Dll3BzE9PkaHckw27oZP2gOMvCpEcMAJ3DufhIQLXWpgUlQTibXcAxoVVeZ5 355012phiymAjDIl9rbKtXH3AjZSGwSa2nPZh77igR50ffPXFOh4OVRsL3UKuKIjFRvxUWPsWMF6i0 355013FxfcLJE+7wNRbQcue4O3tX5Bb+vpjuOwN4xCjUizNWW85RCcHfbj8bw+mx0gVryQTJQed4XV 355014blXFQSZ+jH2m3+JXE0PoWwlxpm2CVaTFTw/Ccq0A/m7WMDF2wJbSbtYCN59gP+/LgfDWoHqY 3550151eQjpFm640wXIbOH7yLZZj2KexT9PFYlBG/THYxR35IsDls5ApzrkY+xmR5c3xKHws5p1sJd 355016u2szDmkIxZt8XYeLGUI4c/mIutqzpLAlKSGet9iZwSFsF85Wd6mFvDAhbscRxBeiRB7SRh0b 355017rcuEj0s0TtW8ohdaSviNtBQgwjUR5YOKcTX9/CSCIy6h49Fu2AUqyEOKbAkyDsedMRn9jlfC 355018eLTHMNV3o1WbYeRyBi81WPaoduvNNqNaJFMQTRH6cCnpZ+YCqQ80CkXFqOa22urGqmNg7HQa 355019XRKZVnIoQD8QZXIAKBt/gETrjey1mOeKYL2HFe1uEuI4kh2v9HvrWSHMmwuH7RXoV7b6Udfg 355020CDVcowwhluHIEHpid9MEsbSnwjmUWA0thLg7JlM6Jwbnj3jBM4/IrLE72GQRyV5rpEIIY2Kd 355021fz2jUJJ6LwiwTsgYBun3W+uLm8MyWhbc8DVE2B2G/B6p1NTWSaVtsHkM/Y6zQ1VEuREgVw5q 355022p9sPEfI6AGeaBjWGsVH3uu5nhrj7CgAn6TwOR9sstMvBmbSnEK4WO9A0NUes30OkpZAZO8Tg 355023UeDJQ2IN45klG7wMb/5utEyOoCLaGfE5W+C7sx7johrEWwbjmpJBTTbzCuc8VuHXVVxsUfKC 355024pUBCz0V/cP2i4G4ehpJuTYp5F86HGMGRADsVizCZnxVCe6QqGcZkoxWI8D6qBhjH7kbCcRsj 3550257yTd5ThTfBU77bxx5lYRiuoVYF7SV4eyR0tTpKj5ULfbC3wrLgxWrobboRb6+rQMMjNGwEZ/ 3550262BmtwLrgc+icVkQrdV1JhjMhRsw4JrDbWsPIIukE2s5sgqWRKSxcNiBCYI9dcuMi7e17Pgb2 3550275HzjdQZwz6ynDU7jj3bB6otP8dVqc/hmtdAeZy0nQsGjriFYj3A7W6TPXWOiAanknsHCADgY 355028r8Bq/7PommaedYfDRpSPqMroDMf1KB2S0e3S7MncG57As+IEeIZk4wEVsUEddxDSc5J+X64R 355029fALdifxeDk7MWZwjpIA9uc/a9UX0PKfO2c4zQ2CoN2yNlO5PSIW2gkjYmVEeOsbwO9bCgI6p 355030ZuwyJ30Y7gd7o5+x0jMX7VOK0GCmr4zB4XsiwJrPGmKZvjeEp78b+E7xuEPNMXEHiiLtwDXj 355031wsyUGGarmMiRofIIrPr0b/jZiAtBKmPVl41WQuiwjSahqfWz2NcVucS4Nlq5CfyE+wyxJH6C 355032LFdf5BGD4vj9LRAk1UJE1qRC52+gT613hFw66hWGS8SgLRuvx3a+B/K7xBA1HoSnYCcd6Saq 355033igQ/poaZ01OPkekWhHNy70Pp0B1sceTSBJrBD5/ic4cLrIGbIkcEG2+zESDaiXMCWNIcCPk1 355034umSdoi5zH2rmZKxsGFV7cpYcGq9VeXzLubbQs+h+ne7X6VrdwuvQLIYfZCPEzhz6q0xg7XeQ 355035dhqiZcngNfjxklA3j3TuPC+E2T8+xpdGdhA4B2JP7YiKLj1SvhE2iffQkucN+12KiFbZ8C14 355036/8zH8fYpNd1bOt5MiJHVWGWThEsdk0qe44QEzvSCiYERjAxtkSrXP+5kHENdRznSBGRd41rB 355037K70Wgy+vYM+5ZzQ+67sUgpDiHkw+OwEfH8boPeel2P+4Cb3iKbxubsXQW3ilUfd+1FONqDXL 355038oc8xhWXEFbzsVNxbs6PSc5wV2oBjEYDsRyKV99eG6aSjLbhIvmv+/QElb8IuFIUaYpVHPqsX 355039qAJrEZoOucI4sADP54NuolvFOiThPhUNKe3HJX8BsuQOJaMVQfjyfxHi/H+vwJZbl5Gcdo/W 355040LdhnGanBNldLWFhYwGz1F/g7N5vV+4ZuxSD6JkPQDt/YAN/8l5gm56d5puC+SPEd2xu6MDHd 355041j5amHiUHBoLfM61gnFDFeiIOlfrBaFOVyv2VvRrLdrqDY2gEQ4LzEotu4USkI7gmBli9moyP 355042in6GiKQ8kJN48D7bgqod9nDcU6fixUnXx/MhvDOmilu14KDfS7247Qj8Nl9DV9Me2PlfxaCa 355043p20ddrjHoqy7DdlEt0xvVidYKNxmKMjTiKHeFpf9ljplPLbYb63HCIcTqUzeyiZQv5UDp7Pd 355044DHn8G3HXh65v3O8Cp+2Er5olmP7hfrg5pKFmhInqGa7YBCPP87RHt7irBEkbdqPoqCMMo2vp 355045tovhtPddvxBOo76L3z//gp84VrDkmsMzXYG1qQiX467eOPvoKmJ9tqPs5YTCaUsbfvrQxy3J 3550468V8N4J1+GFs8LMAx1sM65714wEZ2KzAcx9QINslzGE4zTps7bmdqDCM9fbjuZ7zRFztf7fg8 355047rPamv+ewU/u5KNiamMBk7Tf42uksXs0ozteE0eaMvxpx2js6vtA9FOtvBwqEYTj2ZErNMP3k 355048TARsORxax+C7kXOa5FFwWvAcwxW8+zqaS14A27EY1dQQfht8SD+rYtvF2s8jzkdwO8QC8fdF 355049iyiIwyiLCkFBZzcubwxHSa9UBTxuMTWB74YAbC19yRJHsslW5K63hDkB/9lFmdicdBRZkQLw 355050LPxwqHEuxHAGfTcj8MN/fQLO/uYFyeSZrjy42B7AE7E66dlf4gVruQV5clh7qpZ3QpxPNmO/ 355051TxxuD6l6lD49aAPHE52M4qHkATLfCvhomwW8Svq0euTN9FcglW+JhFt9aqTwJCHMfUx/wj++ 355052skV26+Q8UrsX1+ODcbhlAHVbePC7PjhvkE9hRDRNe1a/LPTEao8SNq1O/yUBvloRi/KBGUy1 355053ZoJnnIqGSfV+HqmKg5nraXRqUhqoMMNkEyz7Zjm+/WItYioGVYC5qDYahg4n8WJagl5i1f/p 355054+/UalQGNfU4UxodFuxHuZAG+dzwOX2tCn5JHr7S/DHH2ZmxqCebPFhElrxRKs3QaQ49vIjc5 355055ALYWDgjZfgY13UzOx+nOMwi0i0dpz7SSsnsPKT5pqBocRtOpCDhZWMFdGIfNhxvReUWIzXJl 355056l7Ji3U4MQQ5RomVDpQiy24Vm+WQUt+6D4d//hXVEsKz7/nN853ser+R9V5dgDEe5VVvNw4a0 355057s3bKY0l1mqhUCslirvstuS7zrvwNZ9iwTpU6cxdsV0oFUb/VFPZyI9lUWy6CLA2xco0/SuQG 355058Dqqt0T9+gAkhxPh8Pqw5P2MZ7xg6JHPXzoC1IE+N7Bc/3gsrQT4LsOjrfP43fME7hKfz5itV 355059Z+V4ik4NpXo8AzbuBag95YsNlxtQEOiNwzez4SQ4gc4Zxf1tPAgh2J4DN7/z6GzLhr2z4nlq 355060owwhKOpRIocleH7MGqbbHtERMtS9uSbbaVA8/aoYQUaKd6+NNoSzhrYmKQ20XKLubfzlDzAw 355061Xo1ln/2MjdcVRhs6NCo/AW6G/8IX31sitljVO4ciI3dYuKKwRzFmx+5shFlYBRsKJLofCzO/ 35506266wyL5vpxHGBACeIMWmsJhE8n0LFQjtajg38ZNx/XoIQj2w0NR6Cb/xdvCDAyyq2WgU0yWb7 355063ULrhX/iH00W1KBfpSAVCl69GUvWIuiFsdgiVyTyYJ1WopJxiFtInyBQE4ZqS8Yh6x33eW1SM 355064fbQn3kEBApVSp9DRCfZ+uD6kOE/SU4p4viv2140uLYKErBtiebSJtP8yAh0P0CGk0p4LEPzi 355065RtYpMaM4OvBxQO6ZPdm0F/aCTDwSMQrzrGSWbj/RuAt2HswCKu25CJeVXjRxTRtDqTr3Y2gl 355066xlfZVAv2OIbgBkVqz75CgYcbK98nHu0kYzeXVn5ne87DaYUnew1KEXZa5YNCQuDKJhuxwy6E 355067NkxRz+rjzEQNsN9j4CoCnTLRRr9LITz4CchM9IL/3kr0SRTX83LJxQsJcw3nX73JtYlcJ7LH 355068ezkX+6m1lRgmU6yD2fs4/+qDInKO8v2pCAYbr5P0e8tG7yLSYiMqx6j+LIHbShfkPRfTURln 355069XKyxp2WuD/fAwfM4/Z7S3mK4/OLJjgG671eQdh1iJWNyKmyCr6JfHt0y5wlJGYWi7beoeDKK 355070n2ZBEHCZDr2jDHZJDjG04VDScQwC97ME2BAAURICgZxMoqLRXCNIvzzOgperD9zT7qO3Lg3u 355071W+WKD5U25XIIeN6b4UOudU3upS3tKYKXEyEuyDr08lwQ3DIfqxqY51IsCGJx+aVYQVBkORMi 3550724ZVq2KBG4nwEZcFW2KLkBUQRMu3XDyJBGIm03HJ0jEsh6a9H2UOGqHgfxPnbzjXdJ1B1v073 3550736zTPP0oOtGe7I+zWsJwcvwmh5UZcaX+AEwWKVCyUAS6B+xU+/styGJo5IfmuIv0fZWAOMQrW 355074qPuKO0qwN9odBqvMYW5kAZ+4bFT2Slhv2ubTm2Gz6l/40cgTaVdesHLr6RE/RN8exGjTMXhZ 355075xCscGEYokiwSVaOq8vf8gVuozfFG2GUFDpFNNOPUMSbt2tTTXATwLOEeEgL/dMbDmwrVr8oM 355076x4bdhTiTth7C44zHrSbdm6OvD8/TLzQS4ecP3MGQiCLOv8PyH9fAh/LcFSnuvdSiuK8Rfv7s 355077r/jeQFXnr4k3xUp9U3Adt+CuPDXoLCHOqEiA/AAhbo/M90abQGuuF4x8TqBtUj06VfIil+ic 355078xeil1qeJh0hx2Ew7NTCEayOO+Ovhq2XuKCw7iLgiRsc+FrkdVUppScUvLiLSKRSnWsfpfh9v 355079u4i9keuxMf0i2icph4x72OlK+s86EJk1CsOmTDqM6nRfRJ6rQXGcF5Ll2JDSSdLNLNioNApf 355080Nm1fi8/+uUKeqsUInkeesOPkWa4LLLdUYIDokZTut/HnFdh4tZv+TpKOXDg65rK6vuTFSTh8 355081+w0hH6+w6RdYJ6OmI/AmBEbtmFTFm08bDvpd1M/2ozR6PXLa5fW2O1lycm5uPzsejMhLRK8f 355082ugGfZZ8Tw76ZWlpTBre90orbloTL3lmdKh5b7Le2Y/ucfsSnn3wDPXMfHGyeYAwj0cZwv8Q4 355083av1W3PWh62Wzg7ib5gjb4A1wsIlno++oCJ/7sSZwvdiDiedFiNuwH9VDU3h+lM9Ghi+G0953 355084/UI4jRobpmuZtL9SosNHrLNnuS1qnRE6bkfNwwxY8YihYHh2Ufz0uzjedwluP5rjQBMlI8V4 355085vN8B/nL8SOEPW/t9qB/TgOE04LSJxnTYCA6hhejbVEaEdDvGKUn7+ZqPz8dqb/qbwYjpcCBr 355086S/uUlME3fIVDojaMRhVtOO1dHV/oHovxaqIHKbCm2o124WqKC/T0hKgaky2I595X3VKwnbSX 355087YNSfnXCyncG2+c4KbLtYe1XinJAzJ73W48qA9jQWoofpcOP8iq8++xZrDVfii8++wzqeH7If 355088K4hbyXAjTm90hpv1GljualQhwKWjD3Ag8gCu5YfAN/cZRhr3wDuF8SAT1WfAT5iHmrIdMP/a 355089EGkPXqMmzQ0Jd9SJnLE7QljJrQGqyuwY7kXxEHpLe07RxZQs5dKWGwQrMkBshcUsyakscLpL 355090NiLwhGoYNi2A47gIkBObM12nILDchRa1UIFeXPSwxPZGzSEz4peXEGXpgO2V2lOmUItCV4EL 355091TGLvK+V+p54rCsHHWjFF38MKO5u1hyNMNe+EhXMBXssJsY5cW1jsaWHyLBKlws88Uc1Thgod 355092PcC3wM5HExoBxZMsN6KkUZYqYsW9Ewdzufe9AsS/wPlIaxhybOAR4Agj7wsqG6CoRhqMyNOn 355093zAERQmJb/Qw9j1Tk33mG0bfMv0SRKaLOGpzb6QeDn8wQe6OX7ueOHCe45r1U6fPB0ihEECVq 355094tHYbvNMqMThDkYBO8C/pRd/1SMTcHpZ7Ih6A1S/rwKPIZitjfP+dB67KyaSh674wFjKphqi8 3550950XvMLVkltyJYH/5lIxqfc+i6H8xiaxXflxA0yWYC5MmJOuXrqrfVXnc3TA8eSvmdZCO3EcqL 355096YYHW/LbUnONFVLG/mee6r3btoVJiEY+7z4bQ0udFXsaFzaZwOtzKAsq5Ok60+jweuh4Aq5R6 3550979FYnwMHdBbaxFeis2ARLpXPpc6jIEoq4dV6PvIL1sIhTPE95oB78bg0redh0INfOELHylBBD 3550981z3w5V8pMMsFjyxOmVX97De/HaAHX7W2BoiuHpO39YfFlodEthEFO8cORvH3NcgiYlyq2QJ9 355099/a0qZJq0/xK8zJNVjnXkOMDu8DN5rkJq/wEHWGe2KXkTjeFuhDViKhuR62KD3UqbLVHeT3H8 355100cJzK9EEAIfOmiLzxCTmBI9422KU072kwcMobZkHbEWFJed/OS49DAEKAWbRaZAsd4nxIAKPg 355101ItbyrTI/B69hvfNBmuBVtOlBkV+gSvooCsxcC3LEfqU0JZrIvKYda/DnP3+NVev0Sd8p/fET 355102UTOmfn9JbyUyQ+1hTsAEx+AHfOfKGAHH7yfCLvKu3AuhB4WeAjYlUEOaDYJvqK8Rj+THGeL6 355103Cktc021S1+LLnwzlCoMx1hoLUTFCRVlVIcohmZWRDWm2CFG6RoCj4hpUnn6bCHmkzUg5Njnv 355104pdeF8ftJsI9WnaeTDWlw2MQo0aLaOKz955f4JfyWihJN5Ty0j2XmBPW+tuTa1PnUmuPmwch0 355105+j5O6TT5M3fO/PvXp9ogZM74R0Uq2EXTHkQT9SmwI88wIu/DIk9HOrUR21fy8GVqDAQ57qcV 355106X1r5up8A/sYKFY9s6XgbziV5w9baHuv33kaPfD2dbs+GwE9huGVkSAicMh7T43+m6yRc3c/Q 355107hjgqLVmkXRLu99Qi1SkCN+S6CuWp4xFUgJKkABy8nYfQzedwNsIHh5+KlTzQcmH1+XcQ3lXK 3551085zlF5REOwtX2csQ6JaFqRDUd2khdJnxdU3G7VzFXjrr9gH8YptE5L1XmiRaP88cHLfHlNzbY 35510928islbO9ZdibUYy6loe4elAIJ64ZrL3TcLVL/N48zt92ruk+gar7dbpfp4U4p1LXufLZlHmj 355110FeGw2foQIy8u4UjVoBJxI0VfiQd4cqO7crmZYI6/f/oNTO2d4b9DkTeZKvR+KBx9fPfpJ/hG 355111jwOrwBw8mVLHIMMPdsHwxwCUy5+59zrR09z2ovLpXaQH7lLsuUAM+g9zI+FmJ0D44Vp2z6SK 355112PVkozvaG/xkmV7KUEMqSV5eRXsCkHmvK9IYFteZxHdkotf5rwXRu3cYTbrDb16Ki06lFNt6J 355113hs8R5lrz8VTFnqNo6KlGcnAuaq9GwTOjGSKle7+5Tr90Z6iSKAeYc20Qmjs/gm4K7fkBMHY7 355114onUPidEKIVz2MM5Zs6/OwN3ttIrzByVrc6OycbsoHrsfjGuMaA12ikFJl/YUa5r6XRFlfBTe 3551157hm4S7Cykz/jMU+tjeFrBWxKTxpfuplqTN1AlWOOApyaS6dIRZMSPG/Es4AFj0f6xRRWmy6h 355116e0YpZYSZK873qPaH6FEmPJxSUTYvXdhCOOj3UE+RbrwVeor6f7mr8B6zvVcQsno59EzNYLrm 355117n/jcOFPN6Wdx3PZ2uOzt61Tx2GK/tR2josE5yvspER1pN88ah+QpO38r7vrQ9dT8Gasj33/Z 355118VzDaeoeVg7RD2np9uB06hKiwg3gwLKVz3OfaGSPhgWhJOO191y+E04aue+IXl0voJ5wLZex0 355119WBeGcrmhTtx2EIJAKqpiEu3ke+nb7Gc3ldWGn34vx//2OYXR5ftrrTVCeBkjCxvS+Ai6rp7t 355120QBtOa0g1wI9cTwQGBSEoyAeOTom4Nypb4HzNx+djtTf9TZWHyTYIn9urTXQPMQ6JbESRNoxG 355121OztqwWnv6vhC91isPEy2RnBJLQpTtiC/5gairCPY7ADa8Nz7qlsM29H9/CAJ/PDbGJZj2wve 355122Tiy2Xaz9R28V9ttxAkEJd9H/+CACUlWFrkRMLEXSflQcuozWujRYB1xT8prsw820GOS1j+JJ 355123tj+xmI1huCIeftmMYKiNNYVnMZVPdhZD91Jg8u0v4NMhNeofbaR8A+zSGtQUNulAKTZYxaJq 355124VPpOlSyN7UUPsdM7BdWjUjXiuC2TD0dqgz4pUby3WMD9lLrHBa2M8HxVFvQ5wT7x5DSCyCQ/ 3551251DCm7v0pJRa5abklkcrRt5UD64NKJNvMKxT5G8HIkigFlgZY9unfoed7RJELi8plPTktT3kz 355126gPJ4HtyUnm/gqh/MEyiiVoJXFwLBi7qjsgkBvWldkQ9MN91UC29j6gdx1ZtDL1R0DsfyCJh4 355127qnu4zoULXotxQ2q1du/SoRu+MAy/q+o5S55h7Fkl8tKCYce1hm9iDso7J+XWy4UtYzJxN6pO 355128pSDQhgu+/1YcL2vDsGRhwfDkmJBY30XoyvNFCCHLZ8WdKAx1w97b17BjfRrrxVIc7o8Tc3ko 355129CVF4xdeazQ3XvJMHwRnGO0E6chcxRg44Kc9b3pFrD8OoCibdEemzqe4WPB6QyNtZwEUeJicV 355130v0RpPFlQEu+x30T5uvPLQnWdJx2wbmMpu6nsRFM6LJUMKMpt6ZzsWbZwOtXFksvUc7me654X 355131KjuF5nRLuBYqLP5z582M3keahTlSa0ZU6pw1eNo37+TDu6Qf010nwPunOY62i9B+yB4uSu8y 355132d46UkFON6dYw4eqpPE9Hrh0MI+V9KhWh+ZgHTEOK8Voy154D3jylZK48z7GFwby2JiptreB+ 355133gXlHiqR04Kax+Y67u4boSBvKMNNXuhEG80I5JxpSYO5RrEIUUsYq7g5mrwipqB67rGyQ+USs 355134YiDryHEE11cAHvlmyptg0PsJmP0KjrkQN4gskfZdhIeeKfQFuez+D3Sqodrt4Nuko25sGi8L 355135PGGzu1lFfk617Fb5/nPh2F3nQ2DkzFjqNZXJhu0QRM2fn2OoivNBlvI7EHmXardJxbtOE5lH 355136bWKYF2SFjcWvNKaIml/ubeYiiPIMkk7g8WEB+HsZ75CuUzZYG8GESU89OQx3j1w6JzxV7seb 355137w1ce6SOdlbA75tfGmjHHiYL5OJuP1aEK748HiXyE3RiUR0dJMTsj1Uj83o8zR8A1yitiCk+J 355138Irw2RHGNrpMurFFuqmUfBGG36IW767Qb3JU8l+i86UXecMntoPug65QrPE7V4vwmWwgvvWb7 355139hT4unz9dp13ZPPOjlRFw2i6PrHicAadgZo8L+hwN96/bYomAqwN0BNKriyGwjKqk5cvrs/ZY 355140tb6MzAMC1psy4eRymA0jrY3lwv8qmX9Uv2fbYFWQInUJdR/X012q+Vun5HtyiB4gydyHXfdG 355141bofBfkejylh8st8eflcH6fHXcdyJyDu5p+NMF064CrAtxR0+JzvYNYvyjPc2toN9WDG6+0vJ 3551422ukA27AS1hg7O1iBrY6+2HM4DJZh1+hNfubAUqXQHHYu1ggt7lZEjVA5CCu3w81zH7sJkGLM 355143PsZeazc1EkETcS7tv4IgW3WSfaHy7yTOF5truk+g6n6d7tdpIc5HK7HRLIxdz6j9oXjxNeiq 355144OYYL7WIlonOSgHBzuBer75VBeStvMXNGXpeEST3Y14Uh5T2bqP2LOCEqYd60TtzxSp5Tmazr 355145NSkwNFREhVK6wkB1Buy//RXxtUrp4KbEjC43eodcM5j1sh6ry0BoZBqS/PkwM+fDK/Ew9ghj 355146UfxS+94JlN5emuiP9HuNKBAG05692spk2znklGtOo0jdOyx6C9aHEPJX9ARZzpZw941Z8N7v 355147s1DYrbMoFCZOB2hPRm3ntGXawu0cpf9JaF3KPFF1A3Hp4A3EJV3BjfQ4XJ63TgzVZMDbLQ0V 355148/W+3p8tEczY2RZ9AxZU0bEguxrOJuRSXXTjj9AsEua1MKklChsdxPOk9gjSVTEIa0/v7UGRa 355149ngd+NN7LkmlURK54RolIflUAAW+Hilc242Cij6DbI/Q6PdI7whB+Mz0L4qAPX/8a50N9FfsF 355150UPU+1tjRNMlGc9Sk+WC7PBf+0DVP6CnpcMqFwm0m8VUYntsjqq8NbYOS34TL3r5OFY8t9lvb 355151sWeHbWF39DmDlad7UL7NEobCGyxO/K2460PXixoPwZMfg2tdr1G+1Q6C3TUYnpVj3EPG+Ovy 355152KFQOSem2jYddYRxawhqQFsNp77teG05jvosePvtaDxwuFzz7MByqVjhcDpUGsyQjnQrEygeX 3551535E5N2vDThzpeHclFoPx4S5YVVgWWsjyTdHaGHWf3EywQqIE414bTHiRaY0Op4vgMe1zb+ZqP 355154z8dqb/qbwZ8WCKafhaw3Z9fDIU0RYaUNo9G6iRac9q6OL3QPBY7QnKqlPsUIv9jG4cKzUXRd 355155WA9exG3WEUAbnntfdQthuzmn2VdnbLF6QyUt18VPj8GDGMrbxUtrr0Kci9tPI3ae14NGIvNm 355156BIILX6K7ZAPCLverDNyHOz3g4OoIDiEFPf2ikf9kXD7wxHhRGI+tV5h82RMEhLsaG8PcJQ3l 355157cgVC9OgQvPVXYZ0pF+ZWHohKdIe+01G1pO6MBS0LrhtuqG54SQRd/S5nhF5YGuGijTgfuOoL 355158082arbqD5amIPsV4Q3QVhGLDuZca7yXpvoLNZmtgQN7FJfXGvPC2abw4J4S92Sp89vGXWGsV 355159guNPlTxDJxqQsvL/4r/ndvHmeWJfg1Ko90QTMpz0YWBC6kxM4RBbiPYJzcrR9LMjsLNXpNdg 355160FIdulIQSC5ohBxxjDty332K9/+ZCDbM8DaFvaAATD3XiQDp8BzGmLjiltEPwfOJ/uHYvXPX1 355161YEzlhyIWq/PPplTI1SdHfWFuxoOVjSeSi59jUmnMdV9JQrzS7r+1W5wQf3dEK7FObaTaWV2C 3551624rrBpeU4H21GyYVKPBvTrLiWJCXjWo9qXU+JEFHXByDuLkWyExeW7uHYRP61C83AzZeKhY0f 355163dAm9LCkzjgeE5PaWhxZdcv4Cn680AdecCw7HHlFnn7KbklAExrnN1tA3MAHHxBDGDsko62Oe 355164gW3HJRZXEysEZdzGa6UJztQbswYC4UXFmLzkxUXSQ80eJ9LJZyjcbIm1esb0M3FtArGnrEdj 355165WzoHeCAXMUob+F3yMlfZ8JWZgwO47M1TOa583mRrNhwNw3G1R/Fuf19tRud7tCBzfqdcWb3k 355166o1B05wBsWYglEpW8d5TPGa+Lx/L//hlblDegnXhKBLwF1hmYwpTMFZfkEhZk0O09TBBdqzkt 355167lXSiDWc2UW2NsHb5j7CIL8FzpZDdS148xU7oVComC8ojg5kPJwNNsEbfhM67Zuq8lfUkZQnR 355168C+7gpT1SIQpnB+9ip7MRjHnWsOQ5IrqwXWVOMJ5bIVj2Vx6OtM/bIHK6HdnGf8HyuFp5/vWb 3551698Pif/6FDDucWa0l3CcLMfNjUGdKh2xBaRqB8SLFJ2cBVH3DnLT6SrjzY/PX/4ovVJgojlK1Q 355170Bdh2F/rAa55iwESd+CCuStG/sy/z4eZ8XCW1kyYyj4kyGcSroeklAcmXF0Kh/4shrF0DEGCl 355171j/Vyb5O7m83htN4fHq5OsHWOV/Hummw7gUAjIp855rDyz2YBo6jxABx+XgFTB3+EeujDLvcF 355172Ox+m2vMQwllL2vBgbeePfXXy6IMbIXDcq9hDQtSYCcdfVoHj4IsgZz3YUQZUed3dzfbYWjfO 355173eCEW+8HlKONdQh9Xmqd0eGyiPWKrRfJ2Dkh5OEFkcwMOuLlg70PGoDp3nL32w3E5sHemvcGl 355174VOqyywEQZD2l1yxt9xeTdws2WUfktSks1x9Bvdy6XhNvDecAF1hyjGHEj8KFF4o+FDUQcmbF 355175SvKefghx04P1YUVeWuo+yfM83U77G2OdEQdmHEusP8psSMys5Ufg8usamPkdZo27w1XJ4Jt7 355176QRgXhw02q+Em36CV3t9h84/469pthIxWGkcj5fD/Zjki75F+GatEyHc/Mf+XP89BTwF21AxD 355177KnmBk258NlKK2byTj6+52SoeZRQpFvL1x1i21pQe8zyPPWgYn0stU4tEe9WwQG3Euag6BvaJ 355178998o7cC/kzhfbK7pPoGq+3W6X6d5/okf74O1IB8v5fqedKQW6Y56WP3LzzBxjsF5+R49FYk2 355179+OWzP+N/VlFrqA02FSl0Wzo95e1U2OuthaEJB/zwfDxTkkOS58dgb3eYNfjOlfJEK/y6cg3W 355180rVsLPcuNONGkkHUTIkLaS0dQEcFDuNLeCvU77Yg+YwJTY3ME5TSzXtbUevH6Vjp8rakN77mw 355181EEQhv2Vs0TRpsulR9Itm6L2nBidm35qofpt7q+lrS0jPuJQy3ZEL3qf/B3/74Vd5ehPyZ+iK 355182zJZJFdxYGrQOZjbEUOvshQAvA/xglcHqELR+8egAIk9WIC8mU2UDaaqEf/sJlq0zp3VeS5cU 355183lfQtSynikUFMzM5icmhYbQ8d8atSpDmvwQ/LV2L1ym/xyZ/+iu9/lb+HSQDyOxRyvudWCuz1 35518418GA6Lh2kbkoyQ6Fub4B0QHMYem2leAPxTcV3RPCJOCGWp7wjnw/rPqBrN1WDgg73kbrQFTI 355185/kI46IPX398KfqB6vZe8XtyWDTeffGZPGDI+W/cZ4rNla2FKjykunNNqWBKdwW02MDGzhLWl 355186ObhOW3Czd2ZxXPY+6ubhscV+aztW5r8Mf1thTM9HUxNL+KWXonNK+s5w14euf1yYi7JuudFk 355187ph9VJ/NpfVfyqgTx4VuxPcyKcB+a2y6G0953vTacxuBZY0Rq2WC/Kd0Rvhnb4GlG6d9WCM5R 355188RNlow08f6nhXYTA5rg9zWy8k5t/AKaEl+R4c8Kzt4LurhjZSMRjuJIIJb2Hn4gaP8GMsdtCG 3551890+jjpmvkx/2wV/m4tvM1HJ+P1d70t+La+jCmo6/y0arklKYNozEcrWac9q6OL1a3UDktdIet 355190iQGMTAivG5iNh0rttOG591W3ELabw9fVMTzY+njAReAAvlMMLr6Yx6ss0P6j92G1nyWLd/bt 3551913jdWft4MBLYjJyhWJbc45b0QnHILfTO/7b4FEUm43jMD3S+/j3I8rRAvpj/sbsvUhqJJgg04 3551920cDsgi+TDKHlWgFKO8W6/4GU+2nwBsJ5QlSO/Gfsjk0pzh2F0dh4tFElnFf3i6I82mmNX419 355193VNJ1zS/jjzLgYULI1e31agrff1qZy7UnHW9CppOzmqFjSeOOGEOOCHzUvJr/7bLXzY8N/dY+ 355194RwiZHctHxN2xP978pnKdRgiw7b5oyfqKtOc8POyzVLwTNBHnlIG4ZZ8jgq4OvJEu9L6I87cp 355195uk+g6n6d7tctff7JpH2oyLqsdcP1f0c5L7QhpJo5HGOK8GxK93WWd75mTDVjt3PEgnsyjbde 355196wrWWVty63PIfoTdKhp6h7fXEe8X0f+Qy/awA2851vJGRRvfL72xeS2cxPSvV/Y74I30zSQfO 355197puSjfVr3592HLkNj07+r9WEhbEfteZbr6oMLC+Drhdq/H+J8tAsvhnWfeNb98p9VxC/LkBFi 355198B64ZFxY2nog9XoM+3RfYbBmsSICdMR/RJS81bgSl+0X3iy6U6kQr6BubwtjIGsICRVTJm5QD 355199Hqaw2VKOgdkPO4+oDYUaFiGNqM1R891c2Hypf6SS4GIJl/Rq1otlSQrZZCuO+ZnCfEMhnVuW 355200PT6POM8NtIC5X5bWkH9tpWGXI0xM57wmTcFxz0brEgiwmZ5riLJT9rjkY8OZjrfKFbyUZ9H9 355201Ot2v07W6xcmXKQz2ijSmUtD98p9RpH0l8HM5qhYFoPtFB4k7KhVpZTxsDLiIuN6r+/Ne94vu 355202l3/X3BupQpKtAcw2KlLp6H7R/UKV6ZeXFsR29Ga5DmlomJC9VfuPdL+Ldb/oftH9ovtF94vu 355203F90vul90v+h+0f2i+0X3i+4X3S+6X3S/6H7R/aL7RfeL7hdF+f+9A/SZwPYLrgAAAABJRU5E 355204rkJggg==' 355205 ) base64Decoded asByteArray readStream! ! 355206 355207!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:25'! 355208dejaVuSansOblique9Data 355209 "Created using: 355210 Clipboard default clipboardText: 355211 ((FileStream oldFileNamed: 'AAFonts/DejaVu Sans Oblique 9.txt') contentsOfEntireFile substrings 355212 collect: [ :each | each asNumber]) asString 355213 " 355214 ^#(9 11 3 0 4 8 14 25 33 44 54 58 64 70 77 86 90 95 99 106 115 124 134 144 154 164 173 182 192 201 205 210 219 228 237 244 257 266 275 285 295 304 312 322 332 337 344 354 361 372 382 393 402 413 422 431 440 450 459 471 482 490 501 507 511 518 524 534 538 546 555 563 571 579 584 592 600 604 609 617 621 633 641 649 657 666 672 679 684 692 700 710 719 727 736 744 747 754 763 771 780 789 795 805 813 821 829 837 845 853 861 869 877 885 893 901 909 917 925 933 941 949 957 965 973 981 989 997 1005 1013 1021 1029 1033 1037 1045 1054 1064 1073 1081 1088 1095 1106 1113 1121 1131 1136 1147 1152 1157 1166 1172 1178 1189 1199 1207 1210 1218 1224 1231 1239 1253 1267 1276 1282 1292 1302 1312 1322 1332 1342 1356 1366 1375 1384 1393 1402 1407 1412 1418 1424 1434 1444 1455 1466 1477 1488 1499 1508 1520 1530 1540 1550 1560 1569 1577 1586 1594 1602 1610 1618 1626 1634 1647 1655 1663 1671 1679 1687 1691 1697 1703 1709 1717 1725 1733 1741 1749 1757 1765 1774 1783 1791 1799 1807 1815 1825 1835 1845)! ! 355215 355216!StrikeFont class methodsFor: 'dejaVu font data' stamp: 'JuanVuletich 8/22/2009 18:25'! 355217dejaVuSansOblique9Form 355218 "Created using: 355219 Clipboard default clipboardText: 355220 ((ByteArray streamContents:[:s| 355221 PNGReadWriter 355222 putForm: (Form fromFileNamed: 'AAFonts/DejaVu Sans Oblique 9.bmp') 355223 onStream: s]) asString base64Encoded) 355224 " 355225 ^Form fromBinaryStream: ( 355226'iVBORw0KGgoAAAANSUhEUgAABzUAAAAOCAYAAACmYEGdAABUpUlEQVR4XuVdB0xUWRfeZLNm 355227s9FohGCUUEIJLbTQQ4dIlyahVwVRsXexV2zYK3bFLnaxYsUGNhRBQUR6r0MZBma+/703w/SB 355228YdVV/7nJJDr3cue++2455/tO+QOQ/SL7RfaL7BfZL7JfZL/IfpH9IvtF9ovsF9kvsl9kv8h+ 355229+X0Kq6cWdxaGY+HeTZg8YSdeNjNlf1J+0cJsfIylvqGYHheEGacL0cFkyf6kfK990JiBSQbW 355230WPXqK9Kj9eC0JQ+drIHNL4vZgcJTMxG18Rka+3g3LBYDldfnwn/2RZTSWRLadKPx9XEsmZuE 355231/TtmI3ZDJhp6WGJ+sxH3E+Ox5+lj7Aw1gXn0IXzsENOORUfR0UBYxVzCl9xd8LaejNt1TPHt 355232Dsdg8rmvqH+5CWFz7qOJxfoJ51Id7i0NwYI7teiR8PusngY83RKL+O1PUMsQ88yMGjzYOAGz 355233D2bg2qpwzLlehW6hvlj0IhwJsMK4y1+Qu8sbNgl3UMf37sj5zVwaiAUPGsHk/C2r8zOOxwVg 355234xf1aqj9mex72j4/C1qxSPEsKxZzbtVRbVttbrHO1w5xHpXi+2BGOS7NB+xdzSa6X0rPTMOd8 355235Nm4sc4eh/SxcKeuS3L67BhnLQjEvXfR5xZ3/95aMxeSTn9HRR1tWTxNeH5qLaRvP4vSKaMy/ 355236WgGGpPfS+gJr4jfj4bNDGG9hjIDtb9AqYT+wusuRFmWF4NQCfDoeBKvoi6jo+W/XG6P8EqYG 355237rccrWl97lom23L2IJNo9beyR2Ib24SAmjt+Cx/npWBi6Cs8k3KetzxfB0Wk5ssoeYbadB5Lf 355238tYs/81teIjkkCrvftnLXn8ydzUwa8g7HwVJNFcah25HdJPsyiuwX2S/fs/zxn29qVjtydi3D 3552391Yqen3OoEAJWzd3F8B13FIWdLO4BXnNjCjxmZ6Be9oVr2S+yX2S/yH6R/fI7C8/kPbvWGsMH 355240D4OC6RxkNksCHLrw5ag/1Ib+g0GqUUiv/T5CdlnaRDhEpOILXfr7lNX2CsvtHbE2p/07zkMn 3552418re7wWbhC6n/hl56BYme+lBSUBjAuJ2QJGHcpGK8aLQ/UgrofH9DgAQeXkh+3yHQxzpJfVD1 355242zhLrZb/87vuVidacA4i1UoW8iju25bHXRcFeX3hsfM8FaVidedjupgR5dQfMTCsBnSX78qrs 355243F9kvsl9kv5CFUfcGNy/dRk5D94AwgeqMLdib3YCGrP1ISs0F7f8QB7g9UQ9yw4djOPFRHbMX 355244n+isn3rfddQU43NpI+j/4VzT3mxFQhJBHFU/wuY52/C0oef/T5ZgtKCipAItXXQ0lZegktYt 355245ozIVA19T4zDpZAEqn61HRGImWmRfXpL98ruv655O0Dp7ZO65u2ufYGesHdTlh2OUoT9W365A 355246lzCx3/ERB0IdMS29uk8SvKcxC9tjQrDiRpmIDtX55Rym2ujCaU22CIHNbH2DrT5a0I9KRV7u 355247IcQnPhQwlOguO4NQsyCcKMjHIT8zRF2qFDBkYLW9wfqwebhd3YBnq4KxILPlx6+XrlKcj3dE 355248zOkSkfkSeLb2QpxbOB5LLxWhXei5u8oJYttJD1ZzRDkSZu0NTDD3xI73RUiLMMPYo1+o32E2 355249Z2O9pytWvmgWILG7qu5gZXAMtj6to94RW/dNQaSpHnxTCrjvoyN3C9wsJuFOyUuscrLB3Mxm 355250wefqrsK1iUYwn3UZ2Q9PY/P6VOS38811dw3uJhLrxXo+bn/OxNr4HcjlM5JhMcpwKcEB4ce/ 3552519KlHM2l5ODo5ALPPfEKb0LMzqu9iqasBLGbcRq2QAQOrsxDHogyg6b0NrwouYsaMy6jia8Ns 355252yECChSuSc77g6jhz+KQU/hB9nkX/ghMxDohLK5NovEGNp/k19o4PROLlYhEjM3rpZcyx14Xt 355253okw0CdX1VF1GtJkv9ucX4GSQKYJPlkg2EiHm/MJEYs4PfxIxPGG1vcYKEv972z/GRS86DH+z 355254cKQVvcdOTwvE36zlrrE/RAUBAuQ87AUdv5Mo6yYWXMd7JBPg2/b8ajyaYoPI67UiVhYs+mfs 355255D/DDzo900Av3Yaz/bokCM4vViPsr1+NZK99BUJeJLeFmUJJXhOWUs1wglLRqeJ8Si7iUDyKL 355256icWoxbO9k+GiOwpy8sowDt6Ct3zWKbxxdwpNRiqi7WJwukTQOohaYPbRuFwleFk0ZszF3IzG 355257n3KIt7/fDE+XNVyrG2rz551Fop8JVBRGQNNpBk7m0wTeB4v2AYfnhMDVRBVD/9bExHvix04v 355258voTVMW4wURtBKDqjYOC9CBc+t4u8W0ZFOhb7WUJbmWg3TB5qlmFYd6dC4uHIYvWg4fEy2Awf 355259DNMlotZcJCi31VEO/wxlK1fkR9FxHd62CR2UtI+4khQDJ30VjJAfAS23ZchsZHJ+ow2vV9tj 3552601HBeH8MJUP7Pv1QRmVYhcJmRa6jg4gqEWKpBfthwqFhGIPl+lcD4Scutt8fmwMtAEfIKarCO 3552613obM2l9XEaB/vYakcaNhoCKPoSP04Z90HzXdou+DSa9G9tn1mDrWDvpqilBU0YaV7zRsu1kk 355262sp948/4GG+yHY6jNeuS0Cx1e5ecQoDgIQ6g5H4ahcuqwjd2DbCFrr56WfFzZMBGeJmoYITcc 355263ChpWCJx3AE9rGBL6koOCsgGco5bj9NtGgfcn2K73owa/w0XcC0BcmxHmC/C0he8CoRXhxpYp 355264GGOqCgWiXkHFCC7RS3HseQ33AKb60XHDvkI+8oFFQ/YiCxjP4ilE7HbuSPlMFwVVSlLho+ON 35526541+FnpWvPWl1mZk8FvpmcTjyroW757rLTsFPxwuHv4haLlJ9jPoDg81X4BXfXqEXHUOA0l8Y 355266pDcbT1pYAm0VPA+iqKv37GjF07lmsBKysGTSCpCePAkexqrEu5KHspEnZux/gTpGH+9+6BDI 355267qdli/K4XIha3TNonXN80ccD9yWs6YfLBN2hmCu7Ld2eWIcxOG4qEIDt8hAbMfRNxlWPZWXUp 355268Ctpy7Pc9bPBfxP4fjGGc9y+nF49bHOtdWvYimBtNx+NmfoGnDGfGasN1H1uIYjXew0RDRyTn 355269dggpEDW4OcUYprMysMvFAOP57oL2nI2wG6qIkCvV3HfY8WELRhuNwxW+e4ResA+e+oSgW8Lg 355270vAs6SgjSz9h4ItJK6BzB4ArG65kj8SlPAGQxKpE+yxKm8Wmcv+vAh61uUBbYC8RnyCD88ac6 355271Ym/X8/62pxJpQcYIv8ob21z7IJwpE3+u0V4kwtZtG/L5DH3aPp3G3Ki5OP2pbcCWlWyB0gdT 355272LlX0KUgJrIkKYk0YheFKNfM7AhuNuBtnhoAzZVK2b0bmXAvYLBFvTS523OXscV/9hnFTfRhH 3552734roEUpmsDzSJRnqdbFl2UuSvlw+2CO3L/z8g8itSA0wRfvqLAMgrTGr2ngN5u0ZDN/QqagYA 355274CJedGQvloUJnxzA5GM97hlYWb9/TPhxBjB5xpmoGYderJoneBX0B1t9ydvQ3Ttmvl/162a// 355275cfXiyIGSkyEwCz6Br2K8iOiFJ7DqTJFYnZBR/Rjb4xyhPUoecqMMEZqSLwJmMFvzcXF1NJwN 355276NaCma4fQpWfxvrmHSziWnQuFWXgayrt7cYE2fNgXDMcpF1HWK9/Sy/Fw93T4WGhBaZQytM09 355277MDnlPVfWZXXX4cmO8bDVIPRYBQ04J2aghu9+Z5SeRpxXIAInpOAdjSmgz7Z8uIA10U7QVVSA 355278giIBdsaswYUPzSLnIr30EuZ7GECZ0M21vZOQWd/zH5E30o9RuDQ+34Igg1FQMovF4Tya1Gc1 355279aTSXfyAWNsR8jtDxR/ILtvcXi1GBa7OdoK0oj5FGkdif1y5wb73faIehf/yBP4Q/f6oi5kbd 355280wOVMeiUe75kKTyMlAu8YjKHDBmMkn94j2v4j9vhbwdktBvve8Z6XXONVGcmYHmwJw8irqGby 355281g7D3kRxpDY2RBA7hvgQ3KxkDfD90VGedQlKCP+wIPEOelNfFzME/xonIov17ULOn+jYW+kdj 355282H/+cM5vxevc4BC64LOJJSXpY2TssRVYra0A4wO/Urrv8PEKU/8RfauE49ZXexzvqQP5uT4wa 355283PAT//PUnBg0ZJnA+qnjs5OpG/w7jkB67+KFthHALab/r63tm/W2MV/8bg4exf1deSQ/2oYk4 355284mlUroPv9CFzid2wrbRHEUhSgYuqLOSlXcHpJEGKPfua+V2nwjZ/Vrj9co4TOtzb1/XCilCGR 355285DDkbZQq3pAeopHej5TVBeFnNxKMm0fntKk1Dgu8iPKgXryuTfMPmiTNx6K3o/dhVfgMrE9bh 355286TtE77IuZhLN84yH1msZ7iZiU8gQZG3xhaBKOlLy2gd0FBB794VAsLNRUYBSyjcBO/xt9vpu4 355287G+b7TsfVym4JhNZbHJyZgC0Pq0XkuO7ah9g4aQkufcpHanw09hfQpdYD2/MIsjJ4G3I4mCW9 355288LB3LYxORVsjjGtoLTmP+9N14XvwUSWELkCEFxkFGEqh8ewMpc5yg/I8CHFek42OjIG7aVXwC 355289CXPS8OLCXDjo2WHm5TKRZ+upu4fF/lNwsVz8umO25ODQjMnYllkrgmP1NDzF1imLkZb/CWcm 355290R2K3ENdEe7kOEzZkIDMlCqb63tjwoumneSgzKq9ips8c3KrpkUDyv8DOyVOxN7tRZE90V9/D 355291uskrkf6Z4JbGx+JYUde/lFO78PV0HDxmX0elmHOxpzINQUYhuPSN+J8YUrMJDxIMYbn8FXXJ 355292SENqMhvuYpLLLGQ2M1F/awJGzxK1iGJ11yP7yHwEj7aAjooGDMzsELD8LqoJReXRPCcE7MlB 355293c+t7bPNypTw1KI/KDALQnn8NFUITQE5OcWoIjD02IbOaDmZXIwpf56Kuq29Sk9X1FSfDTeG3 355294X5QRp0AlgrxLeNBE/b/kchI2Xf6EstsEqXm7DJ8ub0LSZUFLB1JYFQc6fR9rnGqkT3ZA9Dke 355295u95VcgbjTGwx52IhaIwWvN7qCl3fo/jC99w9TXnIuPEQLx/vhoeWBw4U0cUTj9kncfxGDipo 355296PWB2FuNiggHU/FNFlNbu1lIUlbGtKVmMBmRtcoSq03YBAU9AsSs5hynuY+CmrYHgi1UiG4RZ 355297cx0RxgE4W97dx2Wei71BVgjYeBdFrd1g9rSjuvAzGhksiQJp3k53aLluQy6/pQZ5CWUmwkIn 355298EDufV4PeTcOnU+Ohb5CAjAYmb6OdjISR3QJcKaKhu/MrLk42gvGMe2j4DhakpLJEq2+S2hq1 355299pa4FXf20rc5MxenHX9DazSD2yDyYqIzBsWKGkIKdjiXu+rCKWofzz4rQ0MkEk3j+8tcXsCrA 355300SmwYDXI9fzkaCAMTO2hpiZILtOcLYGY6H89b2dY19IobmGWkAp/UrzxisD4Ta101YBq7Fw+L 355301msFg9qCtPBsnl87Arpw2wb5M5uIpR6FitHxF5t4YGGj4YF9+h9BvzhUwghAhZPppw2zKxmZv 355302LRhHbcOdjw3Uu+ihleFV2nos3J3DFabJfkwMpuCRkJB2yk8XvidKuc9ItjM1mcMdu4Ci+GQ2 355303TMwW4gWfcsrfntmai+MTLaDvtxGPqgXfWevTOTAh51eMYkv2YaFtRYwvBOc5Xu6s7mpcT7CC 355304ma0m1DhGKL1tzTVMoK/rzyVXydA0Bzz0EHqZR3J1k+/KTRvWUw7jaSmx9pldqH9zBOP11eF3 355305QPCMpObYnP1c5DqpvE08kzJBAPMJOFR/rgRxLm1/Zpy1xOzE18tTYaA8hkvoskMMBUPfZg7O 3553065TZQe6K7tQzZN2/ig1AYFMobbxsB6ISLgvyUte5xb+j4pKKE7/xgtT7FHGMjzOJYyrHon7Db 3553071QDRfMAKBfC/ToK9XihOlnQh1UcfwZfY80eG8nkw2wSjRhHPdpy9/kkAIXOBJSwTnwqRszW4 355308MdEY9klviLXGRFPWRrjpeSD5JZ+gT5DnL1faQC+Gbc3FYrbi7XYfGBB3XHYfYdSYTS+x1Ucb 355309ZtMuCYAWLNoLJNq4YPMH3l7a5e2Oje86xAobX474wDzhAdfqsO1TKvHehuGvP//CMIM4nCho 355310/+ECGakkWduvETFw+abztzMf2z0csPQlTcr2edjqao35z1ulH3dWIqwdkvoEV6Tpw8Z5E953 355311sCTW27psxofO/w9Lc3JvMXv6F167y07D3/j7eRD/qoVZcw0RJsFIqxRUOiSRmrnJLrBbPLAQ 355312YGXnZ2Hl01YhQ4KLmLuaTWaQcmHTy10INnPFouuF+JKRBB8zH2zIrO839Bd/+dazo79xyn69 3553137NfLfv2Pqx9oac5MQtLjJjFAZClOh+nCasFNlBH6Rw+tgtAlaYKeC52FOBqqB7OJh5FV3oq2 355314ug+4tHYeDvLpAD3V1xFrEYDUEgbHaHY5PMasw3NO6DZS7nq+whGmUfvwpLQVXfRWlOfcwcV7 355315pWyDNVLmejwb5jaLkFHdhZ72Cnx4Vy0gj5IGdB9upeN1fbeg/vh8IwK9pmH/wyI0MUgduBlF 355316jw9ixpgArH/WKHCudTeXorSewCOYDXg43wMJ/4Ex9EDHKFyORI/DkY9toH08grj40yhlSIdv 355317kDJ7deFXNHZ1EaRzOJzmPmXfIcxudHYy0EMvw9UEN0y7U9/n7zNbcwhdXxfG8WdQ1DnQEKlN 355318eLbcGsM4pKBiyCUUv9+BcUueSlzH5PppLXqBZ/mNouE7yYhd1+IRtJUXrpXFKMHpaGdMPlNA 355319YC6NeLJiNLx25EsdzpXFbMHb3QHQUnPG7AN38b68GfT2Auwj9K6x58oHbDDU92814uEcUxhP 355320Z3vTUPr8mTiY2szFzSrGgEjYvnCA36ddJz7t84ahrQcMdMJxtUayDNn19QRCDVyx9UUmVlob 355321cnFAsQAwpedqSodxfCN28b3bCOMW0n7X1/cd7zbA3jAeGY0cXIFWjqxjU2Cm7orNQvPxvXGJ 35532236kti1GPT5/qhDDkbjR+zke1kMEBG0vRgsWkA8gsaSX6ZKA+ezu8Rv0NzbjrqO5hDQzf+Gnt 355323pMM1yLVhNGQoRqmqQ13LEHYhy3CpiKc3kM4CfiYxlB7I7ChD5qEZsNIOEtGXZL/IRmF1FOHG 3553246avILq1HfoovdAlsJKdN9r3wu1vKUEn7NfcE6VA4IWQDXkgIuUx7uRS2divx+hvf4x/iQL1t 355325TroIv1bDBm+lIDXbc9bDK5QE1dvxdq0HQggCQMBbjiSOToTC1GcbsgpuYfXmbDS1fsHL7DJK 355326OFzrGYbTZd3EgVeNS1FuWEYAkJ2FqZgctVksoMtiteDJLBNYLM6SCOoIk5qUYpNJEAPm8/Co 355327UVyfjbgTbQjvXoCaXk1czIsR7aYPPdcoLDr6QuTi+ZGkZseHbfByWYVsWq/iVo+MGaawXJjJ 355328zXHQ8WEzHPXHc4UJAYLk2TxCAJkrlngRffZulJ8dC/U+rN4oEqv2DY7F28Fva47Y8DzM1rfY 355329HhqMzXfTEKtvKzZUXtvrlbC3l7xwyTn9fNAfFuMvoqJbujklBdIQHWsseyZoCcEOwWgDg4n3 3553300NhLDBcfxRi9QKT1EkPtOUiyN8MMvjwDjXeioWP9bSB1d0sRHp9cj0nuutAKSBVr4SyuXIrQ 355331gdboOKw+fh+fGhn9KrQtz5fCUn8CbvKBvj31j7DU0QzRB3PQIu49tWRj3ZhgHBQivHtqbmKK 355332qS1W3LmKyYZWWPG6TZD4OOwFbT4hhtX1BYe9tOB1mB1ugMwdkUEQPVrBR/GZ3ldMf443uP9p 355333LhHXSyCeCVCH5ao3aKPACM5veh+XOH/9tSEVvceJ5tAKPIRPHf2PSdPjAIqEyKGFFlZYkk0T 355334HLvfKYGx99YVHfIknusMt47f873wyw0sddWDw9yLKGpniqz7ogMe0Ak4h/IeltixGQRuw0Z/ 355335JywixkKdZ0+XwtljKXbHm8Jq2Uu2EQqnrX7IARweZ4Gg02XsEA+kJ6KRAzb2hrskiLbbM4yh 355336E3ESxXSWyDOo2SdzCRZun6GXuOETKK9SDQcuaUblMxpgf7qBadycE5SHq6YzduZzvFnphYTi 355337r4kxx4r79fRjMeuo3DEOybmi4AurGY+nG8FCyGuc/jkF7tp+OMnxXKQiCEwyhiNfH+T6Ph6o 355338B5ct79BOfHctTB9jjrLH0112DhE2YUia7w5vDshBWiWOM3IViQ5AnXtv18PBOB4Xs05jgrEp 355339Ei6JWo11FadirJ4nQRTTUHZlGszNEnCxTLJVHGn8sT9EF4bjT6CwgynU11GCkJiIe3x3w9Vw 355340ayQ8bBaz9klDJnN4H+J5W2zzssPUlBQEmgZiX0oC7Lx3CRiysP6FwQejOgPrIhygr6KA4cOV 355341YRGxBZl13dw7qOykH/Q812NXoj9MlOUw0jAYyZl1grIEAT7mnF6CEBtNjJSTg6KBL5Ke8859 355342Vlcl7m+Oho26AkbqeCDx2CFEWoTgQlWvIUAdsg7MhBdl/aoIo4AkZHAAH9LiOF53CEHGsC2e 355343lUZv4qzFctzdEA5LFU6fR/YjzJRtmEN5saT6Qt97E/YuCYKlhgLkNdyx7G41W44gQLTKtCCY 355344RFznEu7k3q1Nj4RJ4Hlq/bP78INxzE0KjGLS8nF6uhPsJx3FuxYmt9407i5laNPbp6FXErbM 355345Ic4FxeEYZRKNlDdf8TxlMkbrjMRwZTvMutgL6nZT3jmG3uuI9t4wVZUXGCNb4a7B030JcNEd 355346CTl5VViP24Xn9d288V6PhJFHEnYvCYSZqhzkNN2x+EY5d72Q8/5gSww17wrq9piyYweCjEnL 355347224umEiO2cB9OZKmuMFASRVeKYVsr77Pl7Ai2BLqI4l+R2jAkgCn84i7l16QgjFKg7ge2PKG 355348U9jeHptGw45vP3d9OQxvs0m4T6x1ytpPn7ev2XLSdnhYTsHNmh6wWh5jmsUYHCjq4nggBUJp 355349JNuznjyDC1N8YDv7IVchf7XWnthfl1FJRi3pacSzJDeYhB1EfhuhXFdfJoAwbxzj88pvz90K 355350D+uZuFvHWW/MWtyI1eWG/Rs+fCj+/nMEV87kkdaLCNI6WSA8jkRSs6cKF0OMEXKp+ruShXWZ 355351GxDgMglH37OjB1DvpvA85nj4YPndqj5DF/GXbz07ZJ90kv162a//tUlNUoarerwLk1wMoCw/ 355352DPIKyrBf/EQgNFVX0SF4afsIRC0R1jurroyHgS2h57YyBQ1ehHLB3ZtuDZ/9n0ErOY9Jo8ch 355353tYjPWLklEzNN7SSGrSf7q74aQeh0K/CkkSlS1/ElHRvGu8FMTweG1r6Yn1bMvjdpr5E8binu 355354lH7BjdXBMFcl7nZFHXiueIxqQpZZNj4Zr3ujKPU0IDtlCtyN1KA4cgTkhuphhpjQcvSGcoII 355355ZBvy1VU0Sx3FQuJ74IzxbtknHPQcSXlLySsZI3jzC9QKjVFcORwVg8P5NNDyDyE64oCA3iYN 355356vsHqKsf1eQHcfIEUMXg9Ghp/D4HBlKtiLfK58mtbPo5G6UM/6ih1nwrrQx93ucN6Lm9NsqNV 3553578AycmI0ZmKDxJ8fTcShs1r/F1+tTEHeyVJSwJPCTe3OdYWxkBCPuxw6TLvCMxtkAvD9m8hFa 355358PRVpiPLZiHcdLA6QHwK/bTxSk9FUjrpOJrUfGssaBIlyknB+lAgLDU9sfc2LyEM6AUzQs+jT 3553590I6UlxpzTmFpxGiYGRjDPnQ5LhS0oPH9eayKcYO5gSFsApcgrUAwEgL901546I1FanEH6h4s 355360g6NRGA7lixoVUfrOZBO47vwoYuDfFw7wO7XrrryMOGMnbHh0E9OMbbDqjfh2ZBjD65MIHXHB 355361I9SWpSFQxw0pheL1rl6MQzv0uABOMFBc4me14cctpP2u7++Js/VyKHRd96KA/+yg5F4dmCx4 355362/uNwid+sLRlVK9TQEYszeLphw9MN8CR0iJ0f+LyrOX3qRp7i9knq+kcmeSMw0BjKDjzjVunx 355363jZ/TThpcg702xsAwPA2FtbWoLn6GfaGaUA04xTWyaX48HRYee/GpibjnCAwhatdjfG1lCJxr 355364feELv0V95R2sJeoN1EZREQOtIpNx59UtbIt3gd4oQndUsUbs3mw09gwAD+kD75Bc39VPPUOq 355365emHsQxwWIq5df9+z8YpaAuuYBjc9RcgPH4JBf6kh+nIVRwb5NrzjV6jvlVluE2eoZshZEayZ 355366LXtVI3NPAlz1laCgQPQRPhtTQ+JxIK+No7/3jZX86Hrq3JICI+l91+XnxkLPYz2Bo4nHmKTt 355367T4TUZNamI1LXkQCrO/slVKqvx8GAEODlh/6NQYPlMGKEPIb+PQiD5UZghIY39nzs5IKm9+IM 355368KNC5IWcvVl4XjDOd7OGBTW+a0ZSTghDn2bj7ORMbIqbhzBcJggWjGhlLrCCnSPxGrnThrUjg 355369+3Y8IQiuYRMmovU1uBqqD59UdjxgVlcNso8v4ZKai49loabrvyE1Kc+eKY6IOssTuJnV1xGj 355370b48NfEmYO95vhJ1uDO40SiJXTovdDKLgOBmXWB02q1+KhotlteJ5ojVGDf8Hf/2jgaA9OWIT 355371ZZNeY7cXemPCiSI05RJkq140btQxRZTYsjP+UByqBDXlkVDUcUTcjkzU8Fv6dOQi2UkP3omL 355372Mc5RB0qjNGE7fiee1XdLmKtqpE8hFJQpN7jWS/wbpTp9EoytFuBGaQe6WgpxZaEzHOff5YZr 355373ZdZeR5jOaOz6SOe+00+7XaBss45LalLKycPZsHFYihcckrgzfwc8TCJxoYLvoOpuxZfM09g4 355374xRP6ihqwj1qK/Tffo4bOnoeLUbrEHhkh9qMdlIpiYn0xu+qRf/cIVo53gtYoHbjGJyH1YSFl 355375gSu8/9oLzyDBwhgxqZ95lqXMFmStcIZbUhaamT1ofn8KC/0soKVmhLGJGzAlZCVBlJOeHv6I 3553765RgusP+uFdmr7aAXcQ5ltALsddVGAJ8lKZv40IfJ/Odsi9weGorSF8HRfALSOOFAu4qIA02d 355377JLPb+jk72N7gVhxvcP619nSuATTHZ1AkNLudHgxn92V523cbRukpBGpaY81rmhRj0oP+DEEv 355378c5Js8zXgucRzPdmXidsrzXg01UjguXr7VXeJxBgjE0SnvEZTD0usUcW9SQawXiV6PrH7MCEI 355379t2d4mOiEoFPEudDxATu8nZCYkY19HnoI44RAZbclyLlNOfhyJQrmYWzisPPDFjgZxOIOx0OZ 355380XpgCT3VHbPkg6rnXdC8OmjpT8biFJfD7zls+sMk7WhHSl9hD3WkjL6zE5wPw0nCS3J/udGQK 3553819GcMu3U5FFnY3foZVxfaw4gvByPbc14JI6wTsPPKcxSSFvCS1kB7Dtba6CPubqOY0OifsNtF 355382V8ASlDJcyIiHnuVyvtDe5FlOkC0cYok8O+ruzoCpxXw85ABhDyYaY/R2EtDoRP5OTzgkPsTb 355383w2PhSr0zgpQ+6A2jUEIAEUeuk14LIeoYLq+GMVtfizU2YHt/msPIPwIOBl7Y8qpF4jMzOz7j 355384ZKwhdEP2I5cmaqTT/GgqLMYcEAjD9Xy+A1eZFDRkysc2Ie/ErrYOdDfeRbR5NO42dqOjvYtL 355385dLQXnsQU/0Tcrx+Y9xy9LBN3XhSjhcEk+n6N3T7E+bbrI4d4a8WzeYYYpuaDjffL0MFoxOud 3553863tC0WYu37bywc7m7/WDgvAiX8hvBYDLQVPQSb6o5ZzeThpwtXjAJ2o6nxHeMxmxs91aFvDXb 355387+5Oq30ooT55rcbekHT30StxdbAezafe4hkKdeVvhasPztCb/5m2yB0xDCKGT6LOrIQubPZQx 3553883HwZXtLY4346xwDDtYKxPbMSdOJczN3jDh3fE5RCxg5fbQsXfrKcNLZZ5wx74pxoY/X2YUmQ 35538957loLL6GRe6WCNn6BLUMvhBNc6zgzp0rsk8TQugLxJaHZWinl+HyBD2M0nPF9COvUEtvR8ER 355390f+iMZkdUINu/WGCE4ZoB2CpujMSdkb2eIOsCtyKzko6ezi9IiycU1oVPqbOQGm+SNeSU3bH6 355391dgnaGa14fyAQWuaLiLuExZ1302DinubM+zYvZQw14YVT6x3zMGVPJGUQ77enB13dTGp/7hlj 355392ibhT+Wgm7mQmvR5FuUXUv0l5ofSkP0xjb3OjJpCGb1fCCND2Ai8KRNPDqTD3SqEAWSovg60V 355393ErM4RijdlbgSZwFfTr4KFu0Vlju6YWteJ9vwzdMMNiae2JbfSeU7WTvaFRv5ZCwSGBtv5IiN 355394b+tRcDwaZi6rkcnJw0V59Y42xdSHTZw9Xo60GAsE8IX8EtzfrchJCYWpy3Lcq+nm28vFuDTF 355395As7EeSh89oslNbu+4MgYXfgd+zygfGTf20NLopHZN54dsk86yX697Nf/OqQmdc55eRKyHZ+B 3553968PPVcNIbg/X3cnBtRTKyGohzu6iRjyAiozaNg76DqKEG+yxswOPVgbBUGYIhqpZwdnWFq1sA 355397Em9WCRoxtWRjY7QvPG01oWQZi0mEXqJt4QrvKD5PTVo2lpiNgtmkXUh/VYJmhihBVp6+EI66 355398KlC1m4UzfClbSNlnp5c1Jp/JRxOdjtayd3j5uYW6W9pebcb8M59RdCYcViEpeN1AgKhMOppq 355399yWg6BMF1ZgG2cAgVksAd67ocmYSc2px/DlPsg7kGPewxMFD3dDvGhW3Fu6YKZCSFIebgt+dQ 355400Yo/xKxhdRTgYHESFhiSNgXyclhB3s+AYxZWGZ1sQYqwCFZMQbH5aL+hF2w++QeXgWhCFxLQi 355401kRxMzIbHSHSLxsWqHgnyaxHOEDKGTtA+5LQyxa4PMm3AWD55lfZiAWxctyKvk8XDqpR54WvH 3554023SzBq/XRWJXdj65HyJEfj4+Huf18pPOFkiW9MlMjw3G0uEsARIt2mILrFXR0lN7EItcx2Py+ 355403nbfG70yF99x0VHaU4dw4Xyx7UMsdL3VP+2jCeWsupefwcJtNsNOU7GVERYjJ2Q5fs7HYdO8r 355404Wjvqkb3dCxpaljDW98DK9AI00KqRtWssDDyEDIZ6anGL0NXMo6bAy2g0VmU2iPUGZTZlItHK 355405GouyaCIySl84wO/TrhnPllpBf9xlVBLrNMVNB4HnK0Tb9RLPupE4V8Zgh9Q0SMDDJvH7ko1x 3554062GFDP7ntvwd28f3bCOIW0n7X9/c0vFxmCcOpj9As4lBgDU1OioQfgUv8bm0pEvPJOrgTetqa 355407xzWof7kNvvoOXJKTqydTfTpROgp1Nze+wLZIfyReK0X1vQnQ0p/Jw1KkxTd+UjtpcI1efMlp 3554088wfqnqHO1RsRUOeE42Ybm3rCnFhjlTnrYG/GS7UkLb7wO9STkci+VtMIXIPEgStxa5YRBv+t 355409geCdT4j7hTib8k9gnLE91nCMM6TCQ/rAO3j1a3j1BFZhOjWDbTwt9d9LqBfCPsRhITxsYADf 355410k5jM5jEwC9yMh2XthEzWgpfr7GEY34sbfyPe8ZPrpeKIiPstK8kFxgTW9aSKkPnKLiBWaygM 3554115j7h9tEvVvKD6weCkfDwIfEYk4Au0k9/IqRmR24ynC1mI7NZysmlF+FIqA82EUQGmbwz1G+L 355412iBJDCvSV16bBRMkAzi428F+VhtfVPJC69NJcOGkoQt0qElsyXuHsrDCsuHwH+yY6QEtJDdaT 355413UlHQaxlD5eoaDecFF5CxOwC61onIqGV7TJSeDITFhJuoFQcY015ggZmZxLBylMeenTGmPmJ7 355414slDhZy99RCkVfrYUHy/9d+FnScJsjMtKAevV1ufzqdAP/Id5473JMLBaLpBjT4A0WvFaLIEr 355415SGjm4dh4YxiE78d7GrMPopWGz5dmwlSLlxuO93sdKDg6Dt6LMgiykO2Foue8TSRELQlSNhXl 355416oYgK0dOJiocb4Kasj2n3GgTCDPiM+BvqxIZ/XEZDZ80TrHdWhgUHABYWSElvNSudUJz82iVW 355417OegovY2VbooY9Odf+OuvYTCbdQ1lAp54WVhkqgL3rS/RyKCj6ukOBKr9jVEcLxppS+6xORhj 355418qAxNxxgsP3gbH2rp3xyusavxIzKOrUbcaILc1XPHtP0vuVY6HQXHEW1qgxlpnwWSOjPr72CK 3554196zTcJghlRtl5THCOxt7nVeigV+PeIoLcDL2EamYH3iePxUS+UJv0wgPw0bRD0msam2CbqAvT 355420RJ4nNKn873CWw6Ch8hQJKz/kLwwa5YJVj+q4B1pFWiDULVb06z7O7kuXS8TxK7K3x2vBuNe6 355421T+g32R9l2PLlXxDXRtVlA5eQrrsRDS1+cJ0CMdQpA4xh8uY88JvbzwgoKSnxPiOHQd6Obanb 35542219jZZyGpZOkKeNCw24+EgpICNMLOiCW8uIe1ky4ir9eI9kv2MdoQcXdqiTkOg+O8R3h/MgL2 3554238ZdRUZtBWTpu6rV05LZtAKMiDaHmUbhSzUDN9Qjo81lTkl5x6rYb8K5ddI+SdWpWfGQS9Qzy 355424+Ge4AkaOHAVlLQt4T9uFB+U8o5PyswHQ6Ks/67U8IwHOXP9N9DdCfhj+/vMfaEen4mOboLU+ 355425veIxDiaGw1FHHoP+HgHT8GTcrxKTb5T0ztJxxV4xsf6Z9bcwnlAckt93CJxXucn20AkXzJ3T 3554269CABJk5sEI7VloNkYh6jzvMMS14kWsFu1WvQmp8i0cELO/PbUXUhDPaEMtlCIwgRe3PMvN8g 355427dt+T9+TJKA0M1pqEuw2Sz1ny/rUfoYP4C2WS8xaTJNZ0M2h5b0F2k7ioAxwrd6EcWZ/2+MB9 355428wzsBgKUXHIoyEQ0JzuISE7z2JCkxwcwck8+KAlkDMtwh84NudocLh9hmdRXj6BgtuO39xBVO 355429GF+Ju0A/FNc4YaMYZBJ+Qy/s+yTe4IpRdg7hJv44yhfCuDDFHfoR1yjFmjRwCNb3FAiZ3PZ6 355430FZw9tnHIP44HJZ+3NLvPsThW3NsnO9SxdvBFdjgdAkw87KUD32PF3PfVcHscTMeyvbUpoMzP 355431lCDcG/gMSKpxNdwYIZzw7FQfBEnlOn8u/Mw9sOxGKTr5LRbJem9izu838cA3Xx14H2Z71rLX 355432syNByF/helK3PpsLKxc2AEgaCBzz1obXQZ7gxz/GLmKexxqH4kwZ714nlUp9D3buGyqCRogO 355433nLZ+4Mo5VFhYg2BcrGay58g0EKlfefP+cbcLtMae5eVBo8asBRdCieMP3cZqfYZ5pvqI2p9F 355434KG5MEYOqJ7Ot4LGbtyZYba8Eksn3rnWLmZkchaEaF0MM4H+GBEMJcPDlGjjZLcKTXgCcCkfs 355435jFXEPdf4cD7cJxzCoWhPLH9F/P/BbNgHHaOMi/jBmfebXaBt5gBjqym4UEoXkLMeTTODC2Xo 355436wETzsyWws1+OFy1MsYTmu5QwmI5eigy+sONFR/ygPOhvqASkiDVOEEtqMsl8ZkFQ/fsvKPoc 355437pBSImheHMT/ACjrqurD2m4pNaa9R3UFHw4dL2LjqIr52sf4zUvNbzw7ZJ51kv172638dUpNR 355438ehJ+hryc0SRZc9TPEAHHiTuv/S12Lb+Gyh5BL52b8QaQJ/Oc/zMcCoRMrmSVSKUaEDgjWp9i 355439tpkNcRb3n5eK1fIU840UYLniCdcAid94tTk3DUlxbtCT/xuDVZ0w/dh7ruEYSfIF+ybjVVMj 355440co5NhLluAFLyOfdH80NMNjDFrKvFAnoUWx5cjrVPKgiwZTTC0ypFCJGWJ2uxggOuUFGKAvWh 355441rG6OoDmzMcZrLTeMPqunGTmHJ8E1YA3Scx5iZ/RohG1+jGrOPXMhXFMwvyk3z+lgKI45LDE/ 355442JG+MLZSMQHpqDhk2FEMUHQkAvIS6Z/nHKG3hN76VHzoIg4bIiRjf9jRmY8/kWGx6KAjIN5ZV 355443g9bTg9a8Y4hynoF74qJi0UtxeYY5tCXIr7360BY3R+JebuPz5vEmiGte1CXKkHqOKTtH53Bn 3554447MgtwrkJ8Vyy8OMeLxgLGRmSd2fhyQkwt52Nq3zeQozKu9g4LQq+rp4Im7YZj2p7uODh6z3R 355445sFBTgrp5IFZc/SJwd7G6ynBlphN8N71A1acTiCPI7D2cXJ09lRcQrCuYooNyBrgSBqU//yTw 355446iL+4n0GqEdwwqqSsdDLIBMEnS7hzSy86AA+FEfDiS51EGWQbh4nkYW/P2QBbBS2MO1MsljQn 35544784TtjzSG5fQr3Jy0PEKlbxzgd2nX+XEvQQzZE+RjGycKj57Ydkzaa6x3UIfbjjxCxmLrqiMH 355448DYU8n8G5ouUCPG3hxzhWSolxDBy7+LFtBHELab/r6/sV9ooYNuhP9m+P1EVEWjnbA5OMpjfb 355449ADoT71MpTX4ELvG7te3FwqszlsBRQws6GtaYc71cJBxt2Slen13EubQyIBhJD8hzthulJ3wF 355450fk9afONntZMG12CvDX1u6h/KKeewF9SddyKfJE+o/WtGRZLqqLmJaYZqcF/7ANUMltT4wq9e 355451T66LmucHMMffCtpKI4n9q4Dh//wNtShexEJyHu6OM8HYM2xDn37xkH7wDrI+SM8Nuz928tWv 355452hBNRn9fJkurv+8RThLAPcVgIFxsYwPeMkpMIMo/EeT5v4IZbkTAay8ZtvhXv+Nn10jg/dRUf 355453h79RME6VMghZ7Dk2R8dg6QoP6Hod5qYj7Bcr+cH1A8FIyCiNp/014bQlVyzGNBDMRYTUbLo/ 355454CbbR10QOJREgufoaYvWJzSc/FH8PGkIJAWwBmLxYNeGbUiASioNWmoldkW4ICrSBinYEUoU8 355455Mal42ztjMOFgNh6tcIXXxmeobc1Hio89Fr5gkw9tb1bD3mo+MglhmBQoL04kLs7wYyhoeI9t 355456ng5YxJeQWGC8VReIDexD5eUQ60VCEIkuBpHERStoPdeYQZCaQrkxpBH6hUvtjTjoyrGVFTW/ 355457QxJDV5CWdrenOSLydKmAslB9OQQ6Lnvwic7zfHi1whqGk+5QnkWil4QeIq7V9EmsMWoeYb23 355458PmxnXUBRhxTJeQkAcq6JMebwKcTsnB7r4B+8HW9pTI6Fli0xLp7yIbE/0hvLRxOue3lrpe3N 355459KliqeOJgUZfgRRl1Ew3Cl2Hbe2x10YL7zjyxpHLn56OIsPLD+jtFaGF0ofHdccSaWCExk889 355460nxQyHmxCmIUaRinrwnHcIizw1IfH3oIBWdFmrvKAxih9eM/YjPPPvhKK3XfIx9nThrLsi9gx 3554611x9GimoYncjOQUt6Hd+aYAyXbR9Enpv2agV8Em4Ta4IdKseH413XGzrHdysxV6SXX1A0D4Tu 355462rsK1eD3oxLAvUAq43+EMDb5Qs8y6G4jWscaatxwls7sZ7/aPhab5Iq73KvU3Y46iuJ9Qu1Rf 355463evZcIo63vl5gsbkuxqWz1y37N62w+k1b333xjUu4fDniBU3XfQKhUagDs/QEfHX9qbDX3H60 355464DDHzZhGqqqo4nxI83eAEQz5PIfbYBYU5HpCbgXgDwbDLve3X3b2IOeY6CDyQLwKecIklPUeu 355465NbzIMxq4UaRd+9s1cLENgpd1EA5+pqODtHQ0jOMSZb1t93yiU96BpwLNEZtejJcrrWEyI5Nr 355466TflhiwM0SMsl4RC6xOVyLkSDUACfcS8mqk8jLxzqI0E0+e41++jPeF4mN8+kwBiZdJTdmANT 355467jbHEepQQpoxoU//+DKYaycNkkWgeud6E9eIMcdrfbYCdPs8SlL2vqnCBImnyBAgW0kLSwzAG 355468t+rpKDkZCkOPncjjM9B5t8ER5nMeo+BqHGyj0ijCpvHuOFiNv4PPGdNh5ig+fDcZmixzlRP0 3554693Kdhsr0Bwvg88EXGm7MOtvpxAuMVPDOrcSfRFpqjV+NxnQTvdWY9bo4zReDZcgGvBzKEqM3k 355470hwIWtb2CqIPDKrwRNo4RQ0ycC1LkhPuS8FEWbM8bUws+pK1C9GgjqI0awRHalRFyqYot8LZk 355471YoaFO9djnm3csx2u5jO4Vqk11yJg6H1U7P1K1RPPR9VzPRzb8Ga1E1w2sUkh8u9VhACLEQrD 355472oeLHzktNtn+7xhEOK3nGQNw+u3h9vl7pAMc1b9lels2PMM3MDTu5nv6ksuICW846ZbU8wWwr 355473D2qt8+6tt1jj6Mg916g+DBShoagMjz0fRfI1UfUWXtj/mfMbZJ+WrpR3IXtu63Aj2oTr1dAb 355474Etdk/G221zE5t+ajuZa/wmMkw0cZ+PH2Ljd8S+hlSg6khFdHVyTn8s48+sddcDNNwIMmFnuO 355475fHihr9jz6AC7pXwW4OSYLVywLa9ThICvuL8DCZ5GUBqlB7eEXcis6c238xn7vSy4hmbUuV1+ 355476FgHGkdwQdJQhTKwJfHvTBlDv3B42ZL7Jrq84EWqJSL79RilKY+0w73E+zsd4EPJiKR5Oc8WM 355477+/m4OM4Bk2/UCHmrdKP65nToD1FD9NVqoToGATL4wSgqHbUdBUjxNcf4ixViQt/R8H5/OEyd 355478l+BuNUPE8KotLwWe2mNw5EuXVKQmGWLOyygIB963cMdzfXEiDj4pQVNrNXJvpSAxxAZaSqow 3554799p6H1Lfs5P8/m9SU9uyQfdJJ9utlv/7XITUb702CgTVPPmDWXEW4oT9OEbJzT8VVLN8tCtxR 355480VtyhugK6ncDv1d7DMj8TjBwsD11bF7i6eiGekI2F9ZnqKzHQG0ne1XL4hyB/qChQI0bBbFam 355481iBxDjY1ei7epE2GgNpYr29ffiILJ2FTKsIM0lMlaQpBQ+z+zPfeZbShIW4pAMxWomAYg8WQO 355482N5IK7dVmLDhbhOLzkbAM3IkXpCE25anZDDqhX5WcW9inFyTvrtwND9M4XKlsoe4mi1kZIjq7 355483uNJGyPpu/ge5pKY4DIE9Rj5PzdxPOBPrhHjiHmKwpB+jeGBYstF2/k43KA7jkChagTjK0Q3u 355484LBxNgLKELGMZinV3KkQB7K5K3FxI3E2uScis7+lTr4sxD+cRfQSY9XCKObwOCFn497Ti65MU 355485RDpPx4Oy51gWuUGARBBckx0oOjMRljYzcKmE/n3uOWYnvl6aAWvHZcT6+IgTcVYYwwHmyPfu 355486ohuBm/XCnm0EoRt9A3US1gCz5joijXxxopQnK5ARRBzlhkLVyBJWVpawtLSAhakulAyniHgV 355487kumgSJ3nthgdgknLwS5/A9gvuC5g3C0tDvB7tKvApfE60B7HSRtArGNKPxVuR/z9x31joGaW 355488iMxGJidajCnMFr6QmNZqQBiHVNjFf9hGCLeQ9ru+vqdyKJqYijiLUBHXHDThf4JNzP8IXOJ3 355489a8uV9/OPIFKHDK8YgN05rUJei6RuRvRJ6GOfPqVhtnc0dmWz5Xd2n5owS3zOvaelxTd+Vjtp 355490cA1+PJDUt8hIB9NMtTCW433Foudjp5sVhTtTPELeUcToKsF54xtuGrR+8YVfvJ7U6XxN/LAp 3554914zMau5hs41vS8H+YggCpJT9cG7G32Xmq+8VD+sE7yHrVoSowMDWDmRn7Y2qkDaPwk5SsJM3f 35549294mnCGEf4rCQf/N99dVwGAXwGUxT2LYvzHo9Nb8R7/jZ9dIUcg4MvI+hqOYFtsaMw7asWhSf 3554939IMBXx/9YSU/un5AGAmZ5s16tMD9QspPvRjTQDCXP75JoCMOmDpC0HaZ9xStzFqkjx+NOU9a 355494+iCxSpC24hDyWkjvBl0EXajiI5dI8CgRoYk3UEUjDjG/AArEo6wTJozGbE6/pPWLDvEyewG0 355495nvoHWGSlDB0rI1hNvY4qCeFWSW+eQINAsSE/KNfXlbYwnS6dsiGN0P9vS2f+bvi4rECWUEiW 355496mquh0HVLQWFvjPX6DMwyNce8R6IhF5l1NxGj78jNdyfuvbUVEheHtT78kjNRK23uyi9H4a3l 355497LpBvgB33WQNDRqhATU2N+KhiFOnFN1wJ5lPvSBTcqXGSHk8Wxph2n/cMba+Ww1IvHvebWFzA 3554989vZEMmyFkLcCGe7xWCC0bVciS5xnBAWs2lHKL88duwbXCEXbZc8niYQlo/Q0wi3CKAuIvtZ9 355499dxedChPA/11XfR7uHFqGaEKYUzLwwpQNJ/H4My9vikSLXOKjPpbtIULug9bipziXPAO+xspQ 355500twnHopQbeMfn2UyGW1pkbSs2l0RL5jwELCcPb+KgTw2AdfwFlJAeG+9OIMHMBJMvPcH5hf6I 3555012vuOKxA0P18GiyF/4h+F3neoBpURg/GP3iyuZ3B7zlrY6I0jFDSmgFWPhWYY15OqIi0IGlar 355502+rVipPoSEnBIBaPwaDCxj5fgOed9Uu10Y0TCGIv0JTQuAWOC9GhomyZyiVeelfVsmFrzwmSQ 355503/VhrheIyv1UIsbZvjTeCG9966R27OG+7zvxtcNbj5XwRbN+D1jdb4Klli6UP60WsvkkAw8Zg 355504otj8uGQfdibT8Zgg7SjyU0UO9htIgY5JEQr6bjxLR/62pMVb8TE/WMQdwi4/Xfik8i4b9rta 355505LUBkkRbv9fcTYaEVgCN8+VapPs14IU/ElaoLIdCU1J+mHw4UCvZna8xTxtlWoJrwTf0qkewj 355506rf/TI9RhMFcQeGMTOD7EnSA+n0hL5nQYGM0RyC3cU3UZ0bpWWPGKJkIeTTV1xqZH6ZhraY1F 355507mYJnK+n1ZxSxDxv97DGXc+62ZM6AXeA2bAkyhj+ftx6/klKYGgkDi9lIr+ykQrYbOW4UT34S 35550881V1MVgkPwlPaahH5loXaNosxK2qPs6n9hysc3YSUXJpWYlwChLOicIWqIwjxeQtEOdtVfDv 355509PDXrSdLXeg7S3tegg7Sma83CMofR3HDq9M/74a7tjzPcnB2kt58nLBJ4dwiVkyXsuthIDL0G 355510DPqh13i5K2mvsdZGD+NusZUAMm+H0bi7Eo1tWD0VSCPeY/hVnjUy1Sffb7La3xPKug7XYIhe 355511sA8eZnxrmQxjH26CYI5nB/lcXhZT8aiZPy/AJYQYh3EBO6oP8ylIf7KXEBK9sFkoPA9Z72nJ 355512I3epPs0mc/MWUFEmnOz5vBpakDnLkhuulgpnZDqJm19VeIzFR8cIPmN3OdIiTbnruafiPAJ0 355513x+BoMYP7bj7t8YRp3HUq5LvIHLXlYKOdFoL4vFuoMZsLCqjCdyq9OhObXDThxgHCyXw7k8x8 355514BMg+cg3bjuaFNGS1PEciAfD1Gr31ekIYBZxB7v2FsHPdxA2R3XuOXI+wQuTulfD13YH8Thqy 355515El0Rtn0d/F2WEXKXkCFe7j4EmbljyhRHGAafoJQ9YYMAe/ulSD+fAAv3bfjQIUpo5h6IgKnT 355516ItyRsGdJY5g4Y/FGI8LyZa8CZzLupoBsxZRiL/50T80C2ffUlP162a//3UjND5sdoUuCCMze 355517CArH4W0QjnRCLqdlJWPl3TrR6CJtb7DaxggJfXgJkufeBEPJeqqg7nkYXjqCubok6pXVFxGs 355518x7uveuofY9VoLQIfSEVOWTa2E+Tf9tx2EXKqPGMZrDV4ho5kqPJN45bhblkJ7m6Mgq22EhTV 355519TTB23VPUVt/Dythkrv7w5XggtPi8pBxW8hn0kHdAShjsYo4ir+I5NvrYY0paSb9Gs8Kkptg5 3555205Iwxo/wTN/xs58c98HNbhWdFGQJj/J6k5r/qr7sWD1Y4QcthiUC0AnGlgwDNXUYn8aK7tL1F 355521kr25gEE1b+2ex/iIQ/j4iQC7E9LFR+oi9MsvxB1taTUVacXSE5p9vldGNR4lB8MxfCsyXl3D 355522Cj8XTDz0lkuK91RdRKgOL4xkL9lx0k8LLrslYxBdX47AS5+9v7hYxwEvKOr1rYNxdYgLhA7h 355523tk+sDlF6KgA6LjvFRNFiSoUD/A7tmp4shtlgMe30BcNWdpFYj9o/+KeXnCfTZw1S5MrF4gql 355524N1usoFJP9ItxSINd/JdthHALab/r63sqh6JOAM6V8+dH60JZWhz0DSdTeex/FC7xu7WlIscV 355525nUa8qSniT+ej4MpsWBtF4FAeXzh0Ko9gCNRVreHkMhnHOaHSJfUpLb7xs9qRhRx7X7gGuTas 355526h/2N4QojMHKkEjQt/DH3cDbqu9ltmQ13EGvqx3VIIuex7nY8gaNs4uYr7Q9f+I/rwRpg/ef9 355527njCZkMHFJjrytsNZyQIr+zBI6hcP6Qfv+NH1wtiHOCzk33z/9Zg3DCJ5Tk5klK/jAaaISGOT 355528W9+Kd/zs+t5CkoR34kmnvfMiaQTJOdBxWYTE6Bhsed6IHqKP8+HG8D3yhdtHf1jJj67vLf1h 355529JGRhkE5GOkIY014exjSQ/r6R1GzDm1XuCCPdodteY6V7uEgIO7LUvUxHRl4DuggSa0PSQ1R+ 355530Pos4MxcuK0seUu35hzAhegfetJJ5lgoJBtYFK180oe3zKcQ6xeMqJzdD6/NEmCk7YdXdMgIY 3555316UFb2TPsH6+HwYO0EX+tWoQB5o6V9hzzbdy5HhX8pavkJMJM/QWAd+meny5R6KfIBy1zLHtJ 355532k74/gsC7O8MJEadKRMB9ev5OuBIvfXdOC7poBTg/3RLGcecFwoewmN3ootPR9HINbPVjcZMg 355533wuhdPUKWQN1oeL6NIHjNMelEPpfYEhkLowpPLt7A2+oO4u97QPtyFxv8dAji9wblLcjrrwcd 355534TfWora1lf4pvYqoRQVTeKkYDrYvvsu5C9ZvnyK1uJw4WEsB8hdSpVtAPOogCPgGbWXcHCUam 355535mHG1FJ1djfhwehosjcbhfJkg4NddeRXxBsaYcbtWrADKBl7doG63glD4OsHsbkHh9WVw1nTE 355536ej6vPkZjEYrqSMKwG82FN7DGxxJhhz72qcRRYWU0bQQ88gTfIx11H27j4LJo2GuMgknCVcpi 355537UJqSMccSowiBJixxH9JzqgeUM4sspHdTcPxl6iBgNr3B/nh7aKnowGnCMizwMoaZ1yQkp38W 355538eO97PdVgkXgHX2pque+x/EUyHNU9cIAjQJEJm3UIRYkk1cn9Sq99g6OxBtAOP40Szhrsrk7H 355539ZANN+G1+iLJ2Yh8zu9BY9AQnNm3G3SreuUD15cr2OibXI63iLa5sCIWBmguSnvGIJLKdtssu 355540fKRLngN2X+KFJepd1RHkv4k6PNbeRlFrN+f3XuP0TFNo8Vm1kP1oOfHytVDvkQBmVtmYYPrj 355541ZsHf48yD4Hrj5BBy2sJN4i46b3SUnIuFgV4MTgl5qZNhbXRcdyOvldiz9N4POxE62YeeGNKO 3555428hpbZQMTPnd/dlue0QcpGIzR1oWeqgUW8eWaId/VFEMt+G/LRGUnE8zOGuSkLYWHjgVmXC4T 355543ULipPsdItgij5rn6hsT+pl0oEelP15MH1rBz9tkQ7+MCN4xZ5sEDuJZTiTZyHXc14MOFRDho 355544OmHdS2HLRoLAmUmsazGhhaizvfgY/NQMkXCWzJnUhdbSJ0iJNqCS8AsTFGSI2AOemjAabQKT 3555452EvcsB+9pfzsWKgq6RHviXeR014ug42GLtQMJxIKnHD4zB7UPVgKe72x2JvLUU4IEGq1nQkS 355546btWKAoGkcc0SCxjPzBSJrU+GwXq1zYcg6KfiYj9W5mRUghCzaC4owr1DCGHP132dAKHKzmNr 355547BRcx1pXiiAnqribIiQT/RNwbQE5NkhDW8T+GQmJtMBpzcX6uLUaoj8MtTh9k6F/toVoIP5ZP 355548vHM6qjKT4WcWhAN8oVWaM+fBVDccR3Nb0EPcdbSyd3hTwsup3fhgGgx0IpH6kYbu9q+4ucIF 355549o+SdsJ3j0dj8ZD7MDWJw7B0791dPew3ys16ikrOXyVDkiTbOAh7kTQ9nwEhvPM4UtRPySwGu 355550LnLECDk7bOS0abw3EaZjDvHWctsrLCdDcnDuhsb7k2HufZgbEoQtlK2EgxMPsCP7MKPaMFCZ 355551PhOWhCB/pZx331H1Pse41uFkn2ZjePuHet8mfF4NlIejOTfvAOlpw99eeIy0rCWwMozFuSLi 355552rqdX49muUJg4E6AoJzQc6QltOlwdgfvfo6Wb/W58TfyxN58zBw+nw5CYo7PEHNEb85A23x4j 355553hlliFR+pzh7zIRGAtuDubbwsa6VCxbaTOavszDGdE46eMkTT9xMwMGrJnAkTq6VUuBEyUf6j 355554dW4YpThWQO5sz0mCIyHPRTvZYOpNYc/LZjxM0IeSrgmiz5GerR14t8EZmto6GCMENHaVXcY0 355555K1vMuVEFesN9zDa3QuKTJoF9SxqQjdNVg7G2BWZn1AuFU6ch71AUzAhC83YfRggkMORlMY0C 355556fISLKKnJIaz7AEUllZ9Nakp7dsg+6ST79bJf/+uQmlfDdeG0LZ+Xt58MBWuqi4hjOXh3ajkO 355557vSnGh5xStPHpFCShE6zrTpFsEs+InmpcizOExZxr+NrBZMt56cdwsUBUryLPfWMzXhoJ/pK2 355558JxX3P9UTuhKhl9TnIm2ePQzDTwjIq8yWDzg5zRIKw3Qx4SIvBF5h5jMUNjFARey5vxh21rxQ 355559k+R51UjoQUFjpmP/oyI0k/mYGM0oenwQM70DsfF5o9QpRiiDtM0LcZzAGBiVN7Aq8QrX00BS 355560YdRm49rND9wIJ+IxCM4YPSIxPXEvntYROg69HDcT3QhSwWdAY/yRhdXTiGcbPKBlNRfpFV39 3555614CpM1FwNh5p6BE4UtKGHkEmebveH6igPpBCyXY/QfNCyliIw8RnKHs1HxNYPYnX3rxemwdoy 355562gZBxOr/bM9GLzmLllrsop5ORGFYg5VmdAG5DRt26O9sU6gT4eO5lGZrpTLb3iZERZmX2Yfzf 355563/ATzzU0w5SqhhxFYQvWTrfDXJAg3ORPMuvqVMggivU5r8l8jv7FbVIdYZAGT2U/E5ucio16p 355564OG0mcLYeQg4vwN3U08ghZanOj1LhAL9+u3zs9lDto10X9+y5McUIBhMuorw3GhVBnsQZ2HOJ 355565BnGFjXGowWPNDXxq6ASD3oKK93eQsmItblYIYhzSYBf/ZRth3ELa7/r6vjFjAvRt1lChtsl9 35556621Gdi5vbx8NU1QaJd3h47I/AJX63tl3lVzHD0ghRR/Opu5I0tChOS4C5SSxO9a5fAjOovTsH 355567RoPlYLfyHiro/fQpJb7xs9r1h2tIg+GRoWtdbBfgXkEpakk5gV6J+6ucYT7lNpcY6g9f+NXr 355568S0/6Q9NhA7KbukArSscyd11oKyvCauF1fKH1EOc9A63l75H1nnfH9IeH9Id3kPVmBtE4yq2v 355569Rt6zbGLNSf/3fdULYx/isJB/8z2FuZnEI+1LJ7UWMjePhZH7JrzmpG/5ZrzjJ9dLU0gezHiY 355570JsZfKCc4nxpk7SMNp1fgCV+4//6wkh9dLw1Gwn2eZ/NgOEwdwYfyQCPwv+qnWzHWlIcxDaQ/ 355571EVJzNQEEzXnUJJUgTFqdnQp1pzxCyPi3YZ5rxXqglF1dDH8LLaiqKkFBUQtGDuFYc62IG4ax 355572p/4RVofOQFpJ78HOQMWNRXDVUMBIfR+suFnOy6nU04Q3R2bAXW8khg5TgIqhK+I3X8aNZA+o 355573GExFepXkkHx3E+wQfVkohBijApcn2yEwJX/A1oh9kZq1txJgNWYH3rdJXqj0j3sxhgAjz3Es 355574QykX9NHLJORkasbb/XGwUpaDvArB6i86h3yhHExkkmaNPwVDeikGX+Dm2aL6ac/Bepuh+OOv 355575wRjG5ymo4rlbMOF8ZyFBOo6GvuJwYp7loWTggrjkWyjuJ0wtCZy764omwWcxm/A8aSxM1RSI 35557631MgQEUHRKw4j9wWoXa94WDNlDB82CgYeM7GsbdNgu+M2YjHiebQjThDJf6VVJiteTg1bwwM 355577FYdh6HBF6LtOxLYMQaGAtH5yVleAnLwitB2isPbKJxGil/Z6DZzMJ1N5KqlL+NI4WAYdIi6o 355578/tcLGQ7p0/sSieSxyF55l4/qzr7nuO72ZFh6bhcg4HjvLQ/b/fyw9S1NlDQhFKQ2umjf+hYL 3555798aBB6D00P8Y0PV0kPGAD41mJxhg8aAjx7uSIuRoBRR07hC4+hZzGHgFltDU/DctDbaA5Ug7D 3555805UZCw9wL8RvSUconsJB9/UP0NUyO3ZeqoRNC5uzCrULBMXPb8a1TOa0IXORbW1nEOpCkwPWO 355581ifbpIlaG2UBDYTjkRyhD29ILscsO4l4R7/eyEs1gOE0w2T0VolbHG8f5wqKS7cSSTgQ4/n6T 355582A6EkZQhYLgm3J0ORPl5uBw2XDcjiu8SoZxUKxzfEmk18ZCVaEEqaKGlHWvicHasHn1SeEYRw 355583Wxb9I3aNlsMfisG4UCX4rlo+nMXiQAuoKRBniqI27MIWI/VlnYhBBTXHc572CXz39rckyBLq 355584CsOoUGEj7Wcj9XWDiKGJuHfW+nwhIaDF4SZnj91aFwMXI1XIDxsGuZEasBw7Fwef14h6QpIG 355585MG46CEyrkGDc0ImS9NUIsVDG0L//gbymDUKXnsX7ZnEe+wRhMF0Hf48Qn6eg4VYUlP9UQiBf 355586rpvOD5vhMGwILJaLhsVt/3gIofrWmH+bp9xRVqrHx0Lfez83mTbvLirFCV8dgffJM1bYBqfh 355587f+DPf4aKeHkrmMzCYz4POJKEsnPfIWKNTYV5sZkkGM6BJMA8TTHxXqNUxATvLBnYXcmouIkl 355588HpqQl1OGgesUbEoOg4kbTxH/tNsDVpMOY0+CLdRHjoSm/QTselIrCBJ11yJzWwxs1OUxnDyv 355589bccjJa+d71mKcWGuM9SIM0rNMhTLdy+Hi2k81/uZ1V2P53smwkl7BHE2KUBRywoBS65wzybS 355590A8XHZLxA2C4WvQSXF7hAnTirVM3GYuGWpXAhlNDbHGUkf7ubQO7S7rJT8DfmeWvn7xCsJ5VW 355591UokzieB5xvL3QYXg3+4NQ+9teNvK9xvzeSGHqD75PJZp2QQYOzqZa7XKaryPyebeOMzxcCT/ 3555923mqu5DGS8/JsRzQsVYgze4QWHGK34WElD4wuOxUA69gUbJ1gBRV5eajZjsP2TF4uLd68D4cq 355593Me8rdi+Fkx7PE1XcPPSW28v8YaYmj2GEjKFs5IVZh19x80aT6QWuzXeCuvxwjLBg52RjtuZg 355594T7gJNA3t4OYbg8RVE2Blv1zAG4UM3xah/CdGjkkRY3xCKtimGK4/Cw+okGN0FO5zg4JqONL4 355595hPGexqdIcjNB6MFeAIKQ9VLGQM/3kEDqAPb5Q6ylscdElC8qDI7u3/hr8DDefpXTRvQVQRm0 355596+fE0mHuIV+pFSM2uIhzythQwtPldSE1pzw7ZJ51kv172638dUnO5pSFXD+DqaBlJCDQaiSH/ 355597/IPhKmYI3/2BG4L26XxzgjwcjL/+HIQhwzhyu2YINwqDAElQm4kd4wl5eOQIjFI3gee0FGQ3 355598CuuEXSg65EmAgqdFLNbJkjp3LGy0CTxg8FCM0LRGMKmXNImR77q+4Li/Npz5CNor8z1hqKoI 355599ZTVNAhibjkOvGoWMYHrQ/CENKyPsoD1KHvKjtGEfsRJpuc0SvbkkGy0zuR71zB7m9ztrv+MY 355600ySJNRKGBls4PWwg5WXzY8b+0eFEneo0136x2hu24qfA3HAE5FSuMS9qM8cYjYTztFmr48Qwq 355601ckEUYk5/Ru7uSMy4K57Ena3/D4Yo68KQIBSNyI+xI2berv0mwpfF5BmMS3qfzI6vuLN1MjyN 355602lTFskKTQ60Nhs54Xwpk0vK3N3IwIC1UoKmvA2GM6Up6WoODaaoTZaEJJSQXqOqZwiduOrEbR 3556033FTnowicK61crIE/vfQyFrhoYPhQBagau2PStgeoIjCU8ovjpMIBfvl2F6Rr15i5mADGJ+Nq 355604JU+3Jz2jrYb+hcHD+Na8nAaCT5XyhdPjYRwa8v9g0OARBFHvi4TNtwXC+UqHXfyXbURxC2m/ 3556056+v795vsMIzCEtlYjoq+PQJnbMbVPMGz50fgEr9bWyatEPcyPqKVP8Ibsx1fHt7Bh2b2Pu7I 355606T0FU4HJcenAaS6X6fenwjZ/Vrj9co3dtGUkgPCksPT0KJoFHkL7ek9Axh0JOUQ9u0w4gm2+P 35560794cv/Or1ZI7qHREmGDVMDipmAVh64SPqv95EUgSBpY6Qo3BLfYdoJGfWcfdVv3hIP3jHj64X 3556081vklYQAD/Z40kMreEwtrVULWIdaC6+Q9yKzmGUp9K97xs+ulKfsnBGPq3CjYqpFzoAvn+O0i 355609ffSHlfzoemkwEp4M5wer2H0UxqRG4H8aQhjTQPr74z+z1CMO/4b7a5CcRfs5loLk5fNsKTxi 355610BF15S85OgtesKyjv+r6gTur4SOz50D6gv8mY7YRwAjDv+gUsK2W/SC7HJkzE8SL6Lzk2ap2/ 3556112gJ/y7FYlfYKZa0M9NCb8fXFOawOsUPQgcIBe3jIfoFUBh5nAvQF4onL7FyQcc9Ph0HXRnxo 355612aNkvP7aUngyAKhlSSX88rvGHU6ZlY7FzEE6UssHFmvRY6JO5HVR8cOgXPc9+rXXdjbJzYTAN 355613Fg+uStcHQaottoNLcu53C1n/o8uzebbwPVQktVzS8mQWzBzWiTVw+38rzOZnWGLniFXZrf8K 355614IKVCKaWHQ8d+I97QRM9KflKT8nT8eAj+ppECgJW05b8kNb+lyD7pJPv1sl//65CaEs8uegGO 355615LzshYpz1q5WyN+9QRusGgwAON7sZIepipcSITrJffgE5i8rNZo7YOw393qmUIeL8IKx+WYJb 3556160yKx75Psy7GyX/6b0lV8AjNWSzaolv0i+2XgZ18naHTZx0xkvwxAB627i8S5opHFZL/8/5bi 3556174qbfRobtDyOhosXNtoGPlBhTf/39h6QmHYVnd+B2Zbfsr0jZL7JffuheY6L14xVsjHeHidpI 355618jFDSgbX/dGy5lo/mHtm/+L7/fDNQm7kGTkaROF/GkP0JIeekLRd7IsZg5pVymSd5Zb/8vqUx 355619NxNvyjvAZHai6tluhBnaIPHxvw/pxmx6jlX2lpiT2fzbzMFRX0tMk9IzkDwLi495wzAyXWKu 355620j/8fAKIJ2cmesJ6SLhCSf6CFUXUHy70NoKzuiR15gh7i/KTm7jEaUNRyQMLxfKkjP/CX8vMh 3556210JTvzQ/W+xkFi8QXYkN3/6zS3zhlv17262W//sfVS33+0d7h5KlctP3i8l36Qnfoq4yCkpYN 355622ItbfEfCokv3yC96rtJdY6uAmkItSYltmM3IuXca7hhpkXUjH5w7Zf7eyX360vt+NDhodHUVH 355623EB6ZihKG7K852S+yX2S//NfnEBN0WgfoNTcxI3AtXrfJ/jkk++X3w0jICCqHfaTDmKTp7w/Z 355624n3bZL7JfZL/Ifvn3ZcNoVahbRSL5fpXsE3iyX2S//B+VgsNRMFEcjmFyI6FpE4G113lh8/9N 355625sVLRhWfiZZT8RsDqTEsvpEiZb5y0uns2zxLOv5En6r8tLqqK0Pdbi/s1P85QT1J6g59V6EWH 3556264a8mJjShmj8Oy763t+wX2S+yX2S/yH75htJdfhYBprx8Y7JfZL/8SoXFKMHJYA3Iq9pj9qVS 3556272Y+sJvtF9ovsl//+HGI14eF0A8iN0Efonnf/ytBV9ovslx9V2nM2SYWRUGl6pMCYpO3vf0Ba 355628opFwQgiRAAAAAElFTkSuQmCC' 355629 ) base64Decoded asByteArray readStream! ! 355630 355631 355632!StrikeFont class methodsFor: 'derivative font caching' stamp: 'lr 7/4/2009 10:42'! 355633shutDown 355634 "StrikeFont shutDown" 355635 "Deallocate synthetically derived copies of base fonts to save space" 355636 self allSubInstancesDo: [ :sf | sf reset ]. 355637 StrikeFontSet allSubInstancesDo: [ :sf | sf reset ]. 355638 DefaultStringScanner := nil! ! 355639 355640 355641!StrikeFont class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 355642convertFontsNamed: familyName 355643 " StrikeFont convertFontsNamed: 'NewYork' " 355644 "This utility is for use after you have used BitFont to produce data files 355645 for the fonts you wish to use. It will read the BitFont files and then 355646 write them out in strike2 (*.sf2) format which is much more compact, 355647 and which can be read in again very quickly." 355648 "For this utility to work as is, the BitFont data files must be named 355649 'familyNN.BF', and must reside in the same directory as the image." 355650 | f | 355651 (FileDirectory default fileNamesMatching: familyName , '*.BF') do: 355652 [ :fname | 355653 Transcript 355654 cr; 355655 show: fname. 355656 f := StrikeFont new readFromBitFont: fname. 355657 f writeAsStrike2named: f name , '.sf2' ]! ! 355658 355659!StrikeFont class methodsFor: 'examples'! 355660example 355661 "Displays a line of text on the display screen at the location of the cursor. 355662 Example depends on the strike font file, 'TimesRoman10.strike'. existing." 355663 355664 (StrikeFont new readFromStrike2: 'NewYork12.sf2') 355665 displayLine: 'A line of 12-pt text in New York style' at: Sensor cursorPoint 355666 355667 "StrikeFont example."! ! 355668 355669!StrikeFont class methodsFor: 'examples' stamp: 'tpr 6/10/2005 16:07'! 355670readStrikeFont2Family: familyName 355671 "StrikeFont readStrikeFont2Family: 'Lucida'" 355672 ^self readStrikeFont2Family: familyName fromDirectory: FileDirectory default! ! 355673 355674!StrikeFont class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 355675readStrikeFont2Family: familyName fromDirectory: aDirectory 355676 "StrikeFont readStrikeFont2Family: 'Lucida' fromDirectory: FileDirectory default" 355677 "This utility reads all available .sf2 StrikeFont files for a given family from 355678 the current directory. It returns an Array, sorted by size, suitable for handing 355679 to TextStyle newFontArray: ." 355680 "For this utility to work as is, the .sf2 files must be named 'familyNN.sf2'." 355681 | fileNames strikeFonts fontArray | 355682 fileNames := aDirectory fileNamesMatching: familyName , '##.sf2'. 355683 strikeFonts := fileNames collect: [ :fname | StrikeFont new readFromStrike2: fname ]. 355684 strikeFonts do: [ :font | font reset ]. 355685 strikeFonts := strikeFonts asSortedCollection: [ :a :b | a height < b height ]. 355686 fontArray := strikeFonts asArray. 355687 ^ fontArray 355688 355689 "TextConstants at: #Lucida put: (TextStyle fontArray: (StrikeFont 355690 readStrikeFont2Family: 'Lucida'))."! ! 355691 355692 355693!StrikeFont class methodsFor: 'font creation' stamp: 'jmv 8/4/2009 09:55'! 355694createDejaVu: pointSize 355695 "Warning: Uses the methods in 'dejaVu font data' category, that will be removed soon (or are already removed) to save space." 355696 355697 | base bold oblique boldOblique point | 355698 point := pointSize asString. 355699 base := (StrikeFont new 355700 buildFromForm: (self perform: ('dejaVuSansBook', point, 'Form') asSymbol) 355701 data: (self perform: ('dejaVuSansBook', point, 'Data') asSymbol) 355702 name: 'Bitmap DejaVu Sans ', point) 355703 pointSize: pointSize. 355704 bold := (StrikeFont new 355705 buildFromForm: (self perform: ('dejaVuSansBold', point, 'Form') asSymbol) 355706 data: (self perform: ('dejaVuSansBold', point, 'Data') asSymbol) 355707 name: 'Bitmap DejaVu Sans ', point, 'B') 355708 emphasis: 1; 355709 pointSize: pointSize. 355710 oblique := (StrikeFont new 355711 buildFromForm: (self perform: ('dejaVuSansOblique', point, 'Form') asSymbol) 355712 data: (self perform: ('dejaVuSansOblique', point, 'Data') asSymbol) 355713 name: 'Bitmap DejaVu Sans ', point, 'I') 355714 emphasis: 2; 355715 pointSize: pointSize. 355716 boldOblique := (StrikeFont new 355717 buildFromForm: (self perform: ('dejaVuSansBoldOblique', point, 'Form') asSymbol) 355718 data: (self perform: ('dejaVuSansBoldOblique', point, 'Data') asSymbol) 355719 name: 'Bitmap DejaVu Sans ', point, 'BI') 355720 emphasis: 3; 355721 pointSize: pointSize. 355722 355723 base derivativeFont: bold at: 1. 355724 base derivativeFont: oblique at: 2. 355725 base derivativeFont: boldOblique at: 3. 355726 355727 ^base! ! 355728 355729!StrikeFont class methodsFor: 'font creation' stamp: 'lr 7/4/2009 10:42'! 355730fromHostFont: fontName size: fontSize flags: fontFlags weight: fontWeight 355731 " 355732 ^StrikeFont fromHostFont: (StrikeFont hostFontFromUser) 355733 size: 12 flags: 0 weight: 4. 355734 " 355735 | fontHandle glyphs xTable xStart maxWidth w glyphForm ascent descent fontHeight | 355736 fontHandle := self 355737 primitiveCreateFont: fontName 355738 size: fontSize 355739 flags: fontFlags 355740 weight: fontWeight. 355741 ascent := self primitiveFontAscent: fontHandle. 355742 descent := self primitiveFontDescent: fontHandle. 355743 fontHeight := ascent + descent. 355744 xTable := Array new: 258. 355745 xStart := maxWidth := 0. 355746 0 355747 to: 255 355748 do: 355749 [ :i | 355750 xTable 355751 at: i + 1 355752 put: xStart. 355753 w := self 355754 primitiveFont: fontHandle 355755 widthOfChar: i. 355756 w > maxWidth ifTrue: [ maxWidth := w ]. 355757 xStart := xStart + w ]. 355758 xTable 355759 at: 256 355760 put: xStart. 355761 xTable 355762 at: 257 355763 put: xStart. 355764 xTable 355765 at: 258 355766 put: xStart. 355767 glyphs := Form 355768 extent: xTable last @ fontHeight 355769 depth: 1. 355770 glyphForm := Form 355771 extent: maxWidth @ fontHeight 355772 depth: 1. 355773 0 355774 to: 255 355775 do: 355776 [ :i | 355777 glyphForm fillWhite. 355778 self 355779 primitiveFont: fontHandle 355780 glyphOfChar: i 355781 into: glyphForm. 355782 xStart := xTable at: i + 1. 355783 glyphForm 355784 displayOn: glyphs 355785 at: xStart @ 0. 355786 glyphForm 355787 displayOn: Display 355788 at: xStart @ 0 ]. 355789 self primitiveDestroyFont: fontHandle. 355790 ^ Array 355791 with: glyphs 355792 with: xTable! ! 355793 355794!StrikeFont class methodsFor: 'font creation' stamp: 'PeterHugossonMiller 9/3/2009 11:25'! 355795hostFontFromUser 355796 "StrikeFont hostFontFromUser" 355797 | fontNames index labels | 355798 fontNames := self listFontNames asSortedCollection. 355799 labels := (String new: 100) writeStream. 355800 fontNames 355801 do: [ :fn | labels nextPutAll: fn ] 355802 separatedBy: [ labels cr ]. 355803 index := UIManager default 355804 chooseFrom: labels contents substrings 355805 title: 'Choose your font'. 355806 index = 0 ifTrue: [ ^ nil ]. 355807 ^ fontNames at: index! ! 355808 355809!StrikeFont class methodsFor: 'font creation' stamp: 'jmv 8/6/2009 14:24'! 355810installDejaVu 355811 "Warning: Uses the methods in 'dejaVu font data' category, that will be removed soon (or are already removed) to save space." 355812" 355813StrikeFont installDejaVu 355814" 355815 355816 TextConstants at: 'Bitmap DejaVu Sans' put: (TextStyle fontArray: 355817 (Array 355818 with: (self createDejaVu: 7) 355819 with: (self createDejaVu: 9) 355820 with: (self createDejaVu: 12))). 355821 Preferences restoreDefaultFonts. 355822 StrikeFont limitTo16Bits. 355823 StrikeFont useUnderscoreIfOver1bpp! ! 355824 355825!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 21:12'! 355826listFont: index 355827 <primitive:'primitiveListFont' module:'FontPlugin'> 355828 ^nil! ! 355829 355830!StrikeFont class methodsFor: 'font creation' stamp: 'PeterHugossonMiller 9/3/2009 11:25'! 355831listFontNames 355832 "StrikeFont listFontNames" 355833 "List all the OS font names" 355834 | font fontNames index | 355835 fontNames := Array new writeStream. 355836 index := 0. 355837 355838 [ font := self listFont: index. 355839 font == nil ] whileFalse: 355840 [ fontNames nextPut: font. 355841 index := index + 1 ]. 355842 ^ fontNames contents! ! 355843 355844!StrikeFont class methodsFor: 'font creation' stamp: 'tak 8/3/2005 21:11'! 355845localeChanged 355846 self setupDefaultFallbackFont! ! 355847 355848!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 21:13'! 355849primitiveCreateFont: fontName size: fontSize flags: fontFlags weight: fontWeight 355850 <primitive:'primitiveCreateFont' module:'FontPlugin'> 355851 ^self primitiveFailed! ! 355852 355853!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 21:13'! 355854primitiveDestroyFont: fontHandle 355855 <primitive:'primitiveDestroyFont' module:'FontPlugin'> 355856 ^self primitiveFailed! ! 355857 355858!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 21:14'! 355859primitiveFont: fontHandle glyphOfChar: charIndex into: glyphForm 355860 <primitive:'primitiveFontGlyphOfChar' module:'FontPlugin'> 355861 ^self primitiveFailed! ! 355862 355863!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 21:15'! 355864primitiveFont: fontHandle widthOfChar: charIndex 355865 <primitive:'primitiveFontWidthOfChar' module:'FontPlugin'> 355866 ^self primitiveFailed! ! 355867 355868!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 22:25'! 355869primitiveFontAscent: fontHandle 355870 <primitive:'primitiveFontAscent' module:'FontPlugin'> 355871 ^self primitiveFailed! ! 355872 355873!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 22:25'! 355874primitiveFontDescent: fontHandle 355875 <primitive:'primitiveFontDescent' module:'FontPlugin'> 355876 ^self primitiveFailed! ! 355877 355878!StrikeFont class methodsFor: 'font creation' stamp: 'ar 6/4/2000 21:14'! 355879primitiveFontEncoding: fontHandle 355880 <primitive:'primitiveFontEncoding' module:'FontPlugin'> 355881 ^self primitiveFailed! ! 355882 355883 355884!StrikeFont class methodsFor: 'instance creation' stamp: 'ar 2/3/2002 23:06'! 355885familyName: aName pointSize: aSize emphasized: emphasisCode 355886 "Create the font with this emphasis" 355887 355888 ^ (self familyName: aName pointSize: aSize) emphasized: emphasisCode! ! 355889 355890!StrikeFont class methodsFor: 'instance creation' stamp: 'tk 1/28/1999 11:31'! 355891familyName: aName size: aSize emphasized: emphasisCode 355892 "Create the font with this emphasis" 355893 355894 ^ (self familyName: aName size: aSize) emphasized: emphasisCode! ! 355895 355896!StrikeFont class methodsFor: 'instance creation' stamp: 'yo 9/16/2002 15:55'! 355897fixForISO8859From: aStrikeFont 355898 355899 ^aStrikeFont copy fixForISO8859From: aStrikeFont. 355900! ! 355901 355902!StrikeFont class methodsFor: 'instance creation'! 355903fromStrike: fileName 355904 "Read a font from disk in the old ST-80 'strike' format. 355905 Note: this is an old format; use strike2 format instead" 355906 355907 ^self new newFromStrike: fileName! ! 355908 355909!StrikeFont class methodsFor: 'instance creation' stamp: 'ar 1/5/2002 21:41'! 355910fromUser 355911 "StrikeFont fromUser" 355912 ^self fromUser: TextStyle defaultFont! ! 355913 355914!StrikeFont class methodsFor: 'instance creation' stamp: 'pavel.krivanek 11/21/2008 16:58'! 355915fromUser: priorFont 355916 355917 ^ UIManager default fontFromUser: priorFont.! ! 355918 355919!StrikeFont class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 355920fromUser: priorFont allowKeyboard: aBoolean 355921 "rr 3/23/2004 10:02 : made the menu invoked modally, thus allowing 355922 keyboard control" 355923 "StrikeFont fromUser" 355924 "Present a menu of available fonts, and if one is chosen, return it. 355925 Otherwise return nil." 355926 | fontList fontMenu style active ptMenu label spec font | 355927 fontList := StrikeFont actualFamilyNames. 355928 fontMenu := MenuMorph new defaultTarget: self. 355929 fontList do: 355930 [ :fontName | 355931 style := TextStyle named: fontName. 355932 active := priorFont familyName sameAs: fontName. 355933 ptMenu := MenuMorph new defaultTarget: self. 355934 style pointSizes do: 355935 [ :pt | 355936 (active and: [ pt = priorFont pointSize ]) 355937 ifTrue: [ label := '<on>' ] 355938 ifFalse: [ label := '<off>' ]. 355939 label := label , pt printString , ' pt'. 355940 ptMenu 355941 add: label 355942 target: fontMenu 355943 selector: #modalSelection: 355944 argument: { fontName. pt } ]. 355945 style isTTCStyle ifTrue: 355946 [ ptMenu 355947 add: 'new size' 355948 target: style 355949 selector: #addNewFontSizeDialog: 355950 argument: { fontName. fontMenu } ]. 355951 active 355952 ifTrue: [ label := '<on>' ] 355953 ifFalse: [ label := '<off>' ]. 355954 label := label , fontName. 355955 fontMenu 355956 add: label 355957 subMenu: ptMenu ]. 355958 spec := fontMenu 355959 invokeModalAt: ActiveHand position 355960 in: ActiveWorld 355961 allowKeyboard: aBoolean. 355962 spec ifNil: [ ^ nil ]. 355963 style := TextStyle named: spec first. 355964 style ifNil: [ ^ self ]. 355965 font := style fonts 355966 detect: [ :any | any pointSize = spec last ] 355967 ifNone: [ nil ]. 355968 ^ font! ! 355969 355970!StrikeFont class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 355971newForJapaneseFromEFontBDFFile: fileName name: aString overrideWith: otherFileName 355972 | n | 355973 n := self new. 355974 n 355975 readEFontBDFForJapaneseFromFile: fileName 355976 name: aString 355977 overrideWith: otherFileName. 355978 ^ n! ! 355979 355980!StrikeFont class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 355981newForKoreanFromEFontBDFFile: fileName name: aString overrideWith: otherFileName 355982 | n | 355983 n := self new. 355984 n 355985 readEFontBDFForKoreanFromFile: fileName 355986 name: aString 355987 overrideWith: otherFileName. 355988 ^ n! ! 355989 355990!StrikeFont class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 355991newFromBDFFile: aFileName name: aString 355992 "StrikeFont newFromBDFFile: 'helvR12.bdf' name: 'Helvetica12'" 355993 "Read a font from disk in the X11 Bitmap Distribution Format." 355994 | n | 355995 n := self new. 355996 n 355997 readBDFFromFile: aFileName 355998 name: aString. 355999 ^ n 356000 356001 "TextConstants at: #Helvetica put: (TextStyle fontArray: {StrikeFont newFromBDFFile: 'helvR12.bdf' name: 'Helvetica12'})" 356002 "TextConstants at: #Lucida put: (TextStyle fontArray: {StrikeFont newFromBDFFile: 'luRS12.bdf' name: 'Lucida'})" 356003 "TextStyle default fontAt: 5 put: (StrikeFont new readFromStrike2: 'helv12.sf2')."! ! 356004 356005!StrikeFont class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 356006newFromEFontBDFFile: fileName name: aString ranges: ranges 356007 | n | 356008 n := self new. 356009 n 356010 readEFontBDFFromFile: fileName 356011 name: aString 356012 ranges: ranges. 356013 ^ n! ! 356014 356015!StrikeFont class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 356016newFromEFontBDFFile: aFileName name: aString startRange: start endRange: end 356017 | n | 356018 n := self new. 356019 n 356020 readEFontBDFFromFile: aFileName 356021 name: aString 356022 rangeFrom: start 356023 to: end. 356024 ^ n 356025 356026 "TextConstants at: #Helvetica put: (TextStyle fontArray: {StrikeFont newFromBDFFile: 'helvR12.bdf' name: 'Helvetica12'})" 356027 "TextConstants at: #Lucida put: (TextStyle fontArray: {StrikeFont newFromBDFFile: 'luRS12.bdf' name: 'Lucida'})" 356028 "TextStyle default fontAt: 5 put: (StrikeFont new readFromStrike2: 'helv12.sf2')."! ! 356029 356030!StrikeFont class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 356031newFromF12File: aFileName 356032 "StrikeFont newFromF12File: 'kaname.f12'" 356033 | file n | 356034 ('*.F12' match: aFileName) ifFalse: 356035 [ "self halt. " 356036 "likely incompatible" 356037 ]. 356038 file := FileStream readOnlyFileNamed: aFileName. 356039 file binary. 356040 n := self new. 356041 n name: (FileDirectory baseNameFor: (FileDirectory localNameFor: aFileName)). 356042 n readF12FromStream: file. 356043 ^ n! ! 356044 356045!StrikeFont class methodsFor: 'instance creation' stamp: 'tak 12/20/2004 10:23'! 356046passwordFontSize: aSize 356047 ^ FixedFaceFont new passwordFont fontSize: aSize! ! 356048 356049 356050!StrikeFont class methodsFor: 'removing' stamp: 'jmv 3/31/2009 08:20'! 356051limitTo16Bits 356052 "Limit glyph depth to 16 bits (it is usually 16 or 32). 356053 356054 StrikeFont limitTo16Bits 356055 " 356056 StrikeFont allInstances do: [ :f | f 356057 setGlyphsDepthAtMost: 16 ].! ! 356058 356059!StrikeFont class methodsFor: 'removing' stamp: 'jmv 3/31/2009 08:19'! 356060saveSpace 356061 "Removes glyphs over 128, leaving only lower ascii. 356062 Also limit glyph depth to 4 bits (it is usually 16 or 32). 356063 This effectively turns off subpixel rendering, as glyphs will only have 16 shades of gray. 356064 356065 StrikeFont saveSpace 356066 " 356067 StrikeFont allInstances do: [ :f | f 356068 stripHighGlyphs; 356069 setGlyphsDepthAtMost: 4 ].! ! 356070Object subclass: #StrikeFontFixer 356071 instanceVariableNames: 'strikeFont charForms newFont' 356072 classVariableNames: 'MappingTable NoFontTable' 356073 poolDictionaries: '' 356074 category: 'Multilingual-Display'! 356075 356076!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:12'! 356077characterFormAt: aCharacter at: aPoint 356078 356079 | f | 356080 f := charForms at: aCharacter asciiValue + 1. 356081 (f magnifyBy: 3) displayAt: aPoint. 356082 ^ f. 356083! ! 356084 356085!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:13'! 356086displayOn: aDisplayObject at: aPoint magnifyBy: aNumber 356087 356088 | form hStep vStep bb source nextPoint | 356089 hStep := (strikeFont maxWidth * aNumber * 1.2) asInteger. 356090 vStep := (strikeFont height * aNumber * 1.2) asInteger. 356091 356092 form := Form extent: (hStep * 16)@(vStep * 16). 356093 bb := BitBlt toForm: form. 356094 0 to: 15 do: [:i | 356095 1 to: 16 do: [:j | 356096 source := ((charForms at: (i * 16 + j)) magnifyBy: aNumber). 356097 nextPoint := (hStep * (j - 1)@(vStep * i)). 356098 bb copy: ((nextPoint+((hStep@vStep - source extent) // 2)) extent: source extent) 356099 from: 0@0 in: source fillColor: Color black rule: Form over. 356100 ]. 356101 ]. 356102 form displayOn: aDisplayObject at: aPoint. 356103! ! 356104 356105!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:13'! 356106font: aStrikeFont 356107 356108 strikeFont := aStrikeFont. 356109 self forms. 356110! ! 356111 356112!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 15:04'! 356113forms 356114 356115 1 to: 256 do: [:i | 356116 charForms at: i put: (strikeFont characterFormAt: (Character value: (i - 1))) 356117 ]. 356118! ! 356119 356120!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 11:06'! 356121initialize 356122 356123 super initialize. 356124 charForms := Array new: 256. 356125! ! 356126 356127!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 15:04'! 356128mappingTable 356129 356130 ^ MappingTable. 356131! ! 356132 356133!StrikeFontFixer methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:13'! 356134storeEditedGlyphsOn: aStream 356135 356136 | n | 356137 NoFontTable do: [:i | 356138 n := strikeFont name. 356139 (n beginsWith: 'NewYork') ifTrue: [n := 'NewYork']. 356140 aStream nextPutAll: '((StrikeFont familyName: ''', n, ''' size: ', 356141 strikeFont height asString, ')'. 356142 aStream nextPutAll: ' characterFormAt: '. 356143 aStream nextPutAll: '(Character value: ', i asString, ')'. 356144 aStream nextPutAll: ' put: '. 356145 (strikeFont characterFormAt: (Character value: i)) storeOn: aStream base: 2. 356146 aStream nextPutAll: ')!!'. 356147 aStream nextPut: Character cr. 356148 aStream nextPut: Character cr. 356149 ]. 356150! ! 356151 356152"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 356153 356154StrikeFontFixer class 356155 instanceVariableNames: ''! 356156 356157!StrikeFontFixer class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 356158initialize 356159" 356160 StrikeFontFixer initialize 356161" 356162 356163 | d | 356164 self initializeNoFontTable. 356165 d := Array new: 256. 356166 0 to: 127 do: [:i | d at: i+1 put: i]. 356167 16r80 to: 16r9F do: [:i | d at: i+1 put: nil]. 356168 d at: 16rA0+1 put: 16r20. 356169 d at: 16rA1+1 put: 16rC1. 356170 d at: 16rA2+1 put: 16rA2. 356171 d at: 16rA3+1 put: 16rA3. 356172 d at: 16rA4+1 put: 16rA9. "CURRENCY SIGN" 356173 d at: 16rA5+1 put: 16rB4. 356174 d at: 16rA6+1 put: 16r7C. "BROKEN BAR" 356175 d at: 16rA7+1 put: 16rA4. 356176 d at: 16rA8+1 put: 16r80. "DIAERESIS" 356177 d at: 16rA9+1 put: 16rA9. 356178 d at: 16rAA+1 put: 16rBB. 356179 d at: 16rAB+1 put: 16rC7. 356180 d at: 16rAC+1 put: 16rD1. "NOT SIGN" 356181 d at: 16rAD+1 put: 16rD0. 356182 d at: 16rAE+1 put: 16rA8. 356183 d at: 16rAF+1 put: 16rD1. "MACRON" 356184 d at: 16rB0+1 put: 16rA1. 356185 d at: 16rB1+1 put: 16r2B. "PLUS-MINUS SIGN" 356186 d at: 16rB2+1 put: 16rAB. "SUPERSCRIPT TWO" 356187 d at: 16rB3+1 put: 16rAB. "SUPERSCRIPT THREE" 356188 d at: 16rB4+1 put: 16rAB. 356189 d at: 16rB5+1 put: 16r75. "MICRO SIGN" 356190 d at: 16rB6+1 put: 16rA6. 356191 d at: 16rB7+1 put: 16rA5. 356192 d at: 16rB8+1 put: 16r82. "CEDILLA" 356193 d at: 16rB9+1 put: 16rAB. "SUPERSCRIPT ONE" 356194 d at: 16rBA+1 put: 16rBC. 356195 d at: 16rBB+1 put: 16rC8. 356196 d at: 16rBC+1 put: 16r4D. "VULGAR FRACTION ONE QUARTER" 356197 d at: 16rBD+1 put: 16r4D. "VULGAR FRACTIOIN ONE HALF" 356198 d at: 16rBE+1 put: 16r4D. "VALGAR FRACTION THREE QUARTERS" 356199 d at: 16rBF+1 put: 16rC0. 356200 d at: 16rC0+1 put: 16rCB. 356201 d at: 16rC1+1 put: 16rCB. "CAPITAL A WITH ACUTE" 356202 d at: 16rC2+1 put: 16rCB. "CAPITAL A WITH CIRCUMFLEX" 356203 d at: 16rC3+1 put: 16rCC. 356204 d at: 16rC4+1 put: 16r80. 356205 d at: 16rC5+1 put: 16r81. 356206 d at: 16rC6+1 put: 16rAE. 356207 d at: 16rC7+1 put: 16r82. 356208 d at: 16rC8+1 put: 16r83. "CAPITAL E WITH GRAVE" 356209 d at: 16rC9+1 put: 16r83. 356210 d at: 16rCA+1 put: 16r83. "CAPITAL E WITH CIRCUMFLEX" 356211 d at: 16rCB+1 put: 16r83. "CAPITAL E WITH DIAERESIS" 356212 d at: 16rCC+1 put: 16r49. "CAPITAL I WITH GRAVE" 356213 d at: 16rCD+1 put: 16r49. "CAPITAL I WITH ACUTE" 356214 d at: 16rCE+1 put: 16r49. "CAPITAL I WITH CIRCUMFLEX" 356215 d at: 16rCF+1 put: 16r49. "CAPITAL I WITH DIAERESIS" 356216 d at: 16rD0+1 put: 16r44. "CAPITAL ETH" 356217 d at: 16rD1+1 put: 16r84. 356218 d at: 16rD2+1 put: 16rCD. "CAPITAL O WITH GRAVE" 356219 d at: 16rD3+1 put: 16rCD. "CAPITAL O WITH ACUTE" 356220 d at: 16rD4+1 put: 16rCD. "CAPITAL O WITH CIRCUMFLEX" 356221 d at: 16rD5+1 put: 16rCD. 356222 d at: 16rD6+1 put: 16r85. 356223 d at: 16rD7+1 put: 16r2B. "MULTIPLICATION SIGN" 356224 d at: 16rD8+1 put: 16rBF. 356225 d at: 16rD9+1 put: 16r86. "CAPITAL U WITH GRAVE" 356226 d at: 16rDA+1 put: 16r86. "CAPITAL U WITH ACUTE" 356227 d at: 16rDB+1 put: 16r86. "CAPITAL U WITH CIRCUMFLEX" 356228 d at: 16rDC+1 put: 16r86. "CAPTIAL U WITH DIAERESIS" 356229 d at: 16rDD+1 put: 16r59. "CAPITAL Y WITH ACUTE" 356230 d at: 16rDE+1 put: 16r50. "CAPITAL THORN" 356231 d at: 16rDF+1 put: 16rA7. 356232 d at: 16rE0+1 put: 16r88. 356233 d at: 16rE1+1 put: 16r87. 356234 d at: 16rE2+1 put: 16r89. 356235 d at: 16rE3+1 put: 16r8B. 356236 d at: 16rE4+1 put: 16r8A. 356237 d at: 16rE5+1 put: 16r8C. 356238 d at: 16rE6+1 put: 16rBE. 356239 d at: 16rE7+1 put: 16r8D. 356240 d at: 16rE8+1 put: 16r8F. 356241 d at: 16rE9+1 put: 16r8E. 356242 d at: 16rEA+1 put: 16r90. 356243 d at: 16rEB+1 put: 16r91. 356244 d at: 16rEC+1 put: 16r93. 356245 d at: 16rED+1 put: 16r92. 356246 d at: 16rEE+1 put: 16r94. 356247 d at: 16rEF+1 put: 16r95. 356248 d at: 16rF0+1 put: 16r64. "SMALL ETH" 356249 d at: 16rF1+1 put: 16r96. 356250 d at: 16rF2+1 put: 16r98. 356251 d at: 16rF3+1 put: 16r97. 356252 d at: 16rF4+1 put: 16r99. 356253 d at: 16rF5+1 put: 16r9B. 356254 d at: 16rF6+1 put: 16r9A. 356255 d at: 16rF7+1 put: 16r2D. "DIVISION SIGN" 356256 d at: 16rF8+1 put: 16rBF. 356257 d at: 16rF9+1 put: 16r9D. 356258 d at: 16rFA+1 put: 16r9C. 356259 d at: 16rFB+1 put: 16r9E. 356260 d at: 16rFC+1 put: 16r9F. 356261 d at: 16rFD+1 put: 16rD8. "SMALL Y WITH ACUTE" 356262 d at: 16rFE+1 put: 16r70. "SMALL THORN" 356263 d at: 16rFF+1 put: 16rD8. 356264 356265 MappingTable := d. 356266! ! 356267 356268!StrikeFontFixer class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 356269initializeNoFontTable 356270 356271 | n | 356272 n := #( 356273 16rA4 "CURRENCY SIGN" 356274 16rA6 "BROKEN BAR" 356275 16rA8 "DIAERESIS" 356276 16rAC "NOT SIGN" 356277 16rAF "MACRON" 356278 16rB1 "PLUS-MINUS SIGN" 356279 16rB2 "SUPERSCRIPT TWO" 356280 16rB3 "SUPERSCRIPT THREE" 356281 16rB5 "MICRO SIGN" 356282 16rB8 "CEDILLA" 356283 16rB9 "SUPERSCRIPT ONE" 356284 16rBC "VULGAR FRACTION ONE QUARTER" 356285 16rBD "VULGAR FRACTIOIN ONE HALF" 356286 16rBE "VALGAR FRACTION THREE QUARTERS" 356287 16rC1 "CAPITAL A WITH ACUTE" 356288 16rC2 "CAPITAL A WITH CIRCUMFLEX" 356289 16rC8 "CAPITAL E WITH GRAVE" 356290 16rCA "CAPITAL E WITH CIRCUMFLEX" 356291 16rCB "CAPITAL E WITH DIAERESIS" 356292 16rCC "CAPITAL I WITH GRAVE" 356293 16rCD "CAPITAL I WITH ACUTE" 356294 16rCE "CAPITAL I WITH CIRCUMFLEX" 356295 16rCF "CAPITAL I WITH DIAERESIS" 356296 16rD0 "CAPITAL ETH" 356297 16rD2 "CAPITAL O WITH GRAVE" 356298 16rD3 "CAPITAL O WITH ACUTE" 356299 16rD4 "CAPITAL O WITH CIRCUMFLEX" 356300 16rD7 "MULTIPLICATION SIGN" 356301 16rD9 "CAPITAL U WITH GRAVE" 356302 16rDA "CAPITAL U WITH ACUTE" 356303 16rDB "CAPITAL U WITH CIRCUMFLEX" 356304 16rDD "CAPITAL Y WITH ACUTE" 356305 16rDE "CAPITAL THORN" 356306 16rF0 "SMALL ETH" 356307 16rF7 "DIVISION SIGN" 356308 16rFD "SMALL Y WITH ACUTE" 356309 16rFE "SMALL THORN" 356310 ). 356311 NoFontTable := n. 356312 356313! ! 356314 356315!StrikeFontFixer class methodsFor: 'as yet unclassified' stamp: 'nk 7/30/2004 18:09'! 356316newOn: aStrikeFont 356317 ^self new font: aStrikeFont! ! 356318AbstractFont subclass: #StrikeFontSet 356319 instanceVariableNames: 'fontArray emphasis derivativeFonts name rIndex' 356320 classVariableNames: '' 356321 poolDictionaries: '' 356322 category: 'Multilingual-Display'! 356323 356324!StrikeFontSet methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:14'! 356325ascentOf: aCharacter 356326 ^(self fontOf: aCharacter) ascent! ! 356327 356328!StrikeFontSet methodsFor: 'accessing' stamp: 'IgorStasenko 4/19/2009 14:51'! 356329characterToGlyphMap 356330 "used in 356331 primDisplayString: aString from: startIndex to: stopIndex 356332 map: font characterToGlyphMap xTable: font xTable 356333 kern: kernDelta. 356334 356335 Since 'font xTable' using a first font xtable, we could use the same glyph mapping for it' 356336 356337 This should allow a primitive to not fail, because of characterToGlyphMap == nil 356338 " 356339 ^ (fontArray at: 1) characterToGlyphMap! ! 356340 356341!StrikeFontSet methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:15'! 356342descentOf: aCharacter 356343 ^(self fontOf: aCharacter) descent! ! 356344 356345!StrikeFontSet methodsFor: 'accessing' stamp: 'yo 9/23/2002 20:08'! 356346fontArray 356347 356348 ^ fontArray 356349! ! 356350 356351!StrikeFontSet methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:14'! 356352fontOf: aCharacter 356353 "Answer the actual font to use for aCharacter" 356354 ^self fontOf: aCharacter ifAbsent:[fontArray at: 1]! ! 356355 356356!StrikeFontSet methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:14'! 356357fontOf: aCharacter ifAbsent: aBlock 356358 "Answer the actual font to use for aCharacter" 356359 | encoding font | 356360 encoding := aCharacter leadingChar + 1. 356361 encoding <= fontArray size 356362 ifTrue:[font := fontArray at: encoding]. 356363 font ifNil:[^aBlock value]. 356364 ^font 356365! ! 356366 356367!StrikeFontSet methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:15'! 356368heightOf: aCharacter 356369 ^(self fontOf: aCharacter) height! ! 356370 356371!StrikeFontSet methodsFor: 'accessing' stamp: 'tak 12/21/2004 16:43'! 356372latin1 356373 "Answer primary font" 356374 ^ fontArray at: 1! ! 356375 356376!StrikeFontSet methodsFor: 'accessing' stamp: 'sd 2/4/2008 21:20'! 356377maxAsciiFor: encoding 356378 356379 | f | 356380 f := (fontArray at: encoding+1). 356381 f ifNotNil: [^ f maxAscii]. 356382 ^ 0. 356383! ! 356384 356385!StrikeFontSet methodsFor: 'accessing' stamp: 'yo 8/5/2003 15:31'! 356386textStyle 356387 356388 ^ TextStyle actualTextStyles detect: [:aStyle | (aStyle fontArray collect: [:s | s name]) includes: self name] 356389 ifNone: []. 356390! ! 356391 356392!StrikeFontSet methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:15'! 356393widthOf: aCharacter 356394 "Answer the width of the argument as a character in the receiver." 356395 ^(self fontOf: aCharacter) widthOf: aCharacter! ! 356396 356397 356398!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:14'! 356399ascent 356400 356401 ^ (fontArray at: 1) ascent. 356402! ! 356403 356404!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:14'! 356405ascentKern 356406 356407 ^ (fontArray at: 1) ascentKern. 356408! ! 356409 356410!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:14'! 356411baseKern 356412 356413 ^ (fontArray at: 1) baseKern. 356414! ! 356415 356416!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 356417bonk: glyphForm with: bonkForm at: j 356418 "Bonking means to run through the glyphs clearing out black pixels 356419 between characters to prevent them from straying into an adjacent 356420 character as a result of, eg, bolding or italicizing" 356421 "Uses the bonkForm to erase at every character boundary in glyphs." 356422 356423 | bb offset font x | 356424 font := (fontArray at: j). 356425 offset := bonkForm offset x. 356426 bb := BitBlt toForm: glyphForm. 356427 bb sourceForm: bonkForm; sourceRect: bonkForm boundingBox; 356428 combinationRule: Form erase; destY: 0. 356429 x := font xTable. 356430 (x isMemberOf: SparseLargeTable) ifTrue: [ 356431 x base to: x size-1 do: [:i | bb destX: (x at: i) + offset; copyBits]. 356432 ] ifFalse: [ 356433 1 to: x size-1 do: [:i | bb destX: (x at: i) + offset; copyBits]. 356434 ]. 356435! ! 356436 356437!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 356438copy 356439 356440 | s a | 356441 s := self class new. 356442 s name: self name. 356443 s emphasis: self emphasis. 356444 s reset. 356445 a := Array new: fontArray size. 356446 1 to: a size do: [:i | 356447 a at: i put: (fontArray at: i) copy. 356448 ]. 356449 s fontArray: a. 356450 ^ s. 356451! ! 356452 356453!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'nk 9/1/2004 12:06'! 356454derivativeFonts 356455 ^derivativeFonts copyWithout: nil! ! 356456 356457!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:14'! 356458descent 356459 356460 ^ (fontArray at: 1) descent. 356461! ! 356462 356463!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:10'! 356464descentKern 356465 356466 ^ (fontArray at: 1) descentKern. 356467! ! 356468 356469!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 5/19/2004 11:36'! 356470displayLine: aString at: aPoint 356471 "Display the characters in aString, starting at position aPoint." 356472 356473 self characters: (1 to: aString size) 356474 in: aString 356475 displayAt: aPoint 356476 clippedBy: Display boundingBox 356477 rule: Form over 356478 fillColor: nil 356479 kernDelta: 0 356480 on: (BitBlt current toForm: Display). 356481! ! 356482 356483!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:06'! 356484emphasis 356485 "Answer the integer code for synthetic bold, italic, underline, and 356486 strike-out." 356487 356488 ^ emphasis. 356489! ! 356490 356491!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 356492emphasis: code 356493 "Set the integer code for synthetic bold, itallic, underline, and strike-out, 356494 where bold=1, italic=2, underlined=4, and struck out=8." 356495 356496 emphasis := code. 356497! ! 356498 356499!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'marcus.denker 9/14/2008 19:09'! 356500emphasized: code 356501 356502 "Answer a copy of the receiver with emphasis set to include code." 356503 | derivative addedEmphasis base safeCode | 356504 code = 0 ifTrue: [^ self]. 356505 derivativeFonts isEmptyOrNil ifTrue: [^ self]. 356506 derivative := derivativeFonts at: (safeCode := code min: derivativeFonts size). 356507 derivative ifNotNil: [^ derivative]. "Already have this style" 356508 356509 "Dont have it -- derive from another with one with less emphasis" 356510 addedEmphasis := 1 bitShift: safeCode highBit - 1. 356511 base := self emphasized: safeCode - addedEmphasis. "Order is Bold, Ital, Under, Narrow" 356512 addedEmphasis = 1 ifTrue: "Compute synthetic bold version of the font" 356513 [derivative := (base copy name: base name , 'B') makeBoldGlyphs]. 356514 addedEmphasis = 2 ifTrue: "Compute synthetic italic version of the font" 356515 [ derivative := (base copy name: base name , 'I') makeItalicGlyphs]. 356516 addedEmphasis = 4 ifTrue: "Compute underlined version of the font" 356517 [derivative := (base copy name: base name , 'U') makeUnderlinedGlyphs]. 356518 addedEmphasis = 8 ifTrue: "Compute narrow version of the font" 356519 [derivative := (base copy name: base name , 'N') makeCondensedGlyphs]. 356520 addedEmphasis = 16 ifTrue: "Compute struck-out version of the font" 356521 [derivative := (base copy name: base name , 'X') makeStruckOutGlyphs]. 356522 derivative emphasis: safeCode. 356523 derivativeFonts at: safeCode put: derivative. 356524 ^ derivative 356525! ! 356526 356527!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:11'! 356528familyName 356529 356530 ^ (fontArray at: 1) familyName. 356531! ! 356532 356533!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:11'! 356534familySizeFace 356535 356536 ^ Array 356537 with: (fontArray at: 1) name 356538 with: self height 356539 with: (fontArray at: 1) emphasis 356540! ! 356541 356542!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 356543fontArray: anArray 356544 356545 fontArray := anArray. 356546! ! 356547 356548!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:12'! 356549fontNameWithPointSize 356550 356551 ^ (fontArray at: 1) fontNameWithPointSize. 356552! ! 356553 356554!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:12'! 356555glyphs 356556 356557 ^ (fontArray at: 1) glyphs 356558! ! 356559 356560!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:50'! 356561glyphsEncoding: anInteger 356562 356563 ^ (fontArray at: (anInteger+1)) glyphs. 356564! ! 356565 356566!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:12'! 356567height 356568 356569 ^ (fontArray at: 1) height. 356570! ! 356571 356572!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:12'! 356573initializeWithFontArray: anArray 356574 "Initialize with given font array, the ascent of primary font is modified 356575 if another font has higher size" 356576 | primaryFont maxHeight newFont | 356577 fontArray := anArray. 356578 primaryFont := anArray at: 1. 356579 emphasis := 0. 356580 name := primaryFont name. 356581 maxHeight := anArray 356582 inject: 0 356583 into: [:theHeight :font | (font notNil 356584 and: [theHeight < font height]) 356585 ifTrue: [font height] 356586 ifFalse: [theHeight]]. 356587 primaryFont height < maxHeight 356588 ifTrue: [newFont := primaryFont copy 356589 fixAscent: primaryFont ascent + (maxHeight - primaryFont height) 356590 andDescent: primaryFont descent 356591 head: 0. 356592 fontArray at: 1 put: newFont]. 356593 self reset! ! 356594 356595!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 1/5/2005 13:59'! 356596installOn: aDisplayContext 356597 356598 ^ aDisplayContext installStrikeFont: self. 356599! ! 356600 356601!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:50'! 356602installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor 356603 356604 ^ aDisplayContext 356605 installStrikeFont: self 356606 foregroundColor: foregroundColor 356607 backgroundColor: backgroundColor. 356608! ! 356609 356610!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:13'! 356611lineGrid 356612 356613 | f | 356614 f := fontArray at: 1. 356615 ^ f ascent + f descent. 356616! ! 356617 356618!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:52'! 356619maxEncoding 356620 356621 ^ fontArray size. 356622! ! 356623 356624!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 2/24/2005 15:45'! 356625maxWidth 356626 356627 ^ (fontArray at: 1) maxWidth. 356628! ! 356629 356630!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:52'! 356631name 356632 356633 ^ name 356634! ! 356635 356636!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 356637name: aString 356638 356639 name := aString 356640! ! 356641 356642!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 356643objectForDataStream: refStrm 356644 | dp | 356645 "I am about to be written on an object file. Write a reference to a known Font in the other system instead. " 356646 356647 "A path to me" 356648 (TextConstants at: #forceFontWriting ifAbsent: [false]) ifTrue: [^ self]. 356649 "special case for saving the default fonts on the disk. See collectionFromFileNamed:" 356650 356651 dp := DiskProxy global: #StrikeFontSet selector: #familyName:size:emphasized: 356652 args: (Array with: self familyName with: self pointSize 356653 with: self emphasis). 356654 refStrm replace: self with: dp. 356655 ^ dp. 356656! ! 356657 356658!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:13'! 356659pointSize 356660 356661 ^ (fontArray at: 1) pointSize. 356662! ! 356663 356664!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:53'! 356665printOn: aStream 356666 356667 super printOn: aStream. 356668 aStream nextPutAll: '(' , self name. 356669 aStream space. 356670 self height printOn: aStream. 356671 aStream nextPut: $). 356672! ! 356673 356674!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 356675reset 356676 "Reset the cache of derivative emphasized fonts" 356677 356678 derivativeFonts := Array new: 32. 356679! ! 356680 356681!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:13'! 356682subscript 356683 356684 ^ (fontArray at: 1) subscript 356685! ! 356686 356687!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:13'! 356688superscript 356689 356690 ^ (fontArray at: 1) superscript 356691! ! 356692 356693!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:13'! 356694widthOfString: aString 356695 356696 aString ifNil:[^0]. 356697 "Optimizing" 356698 (aString isByteString) ifTrue: [ 356699 ^ (self fontArray at: 1) widthOfString: aString from: 1 to: aString size]. 356700 ^ self widthOfString: aString from: 1 to: aString size. 356701" 356702 TextStyle default defaultFont widthOfString: 'zort' 21 356703" 356704! ! 356705 356706!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 356707widthOfString: aString from: startIndex to: stopIndex 356708 "Measure the length of the given string between start and stop index" 356709 356710 | resultX | 356711 resultX := 0. 356712 startIndex to: stopIndex do:[:i | 356713 resultX := resultX + (self widthOf: (aString at: i))]. 356714 ^ resultX. 356715! ! 356716 356717!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:14'! 356718xTable 356719 "Answer an Array of the left x-coordinate of characters in glyphs." 356720 356721 ^ (fontArray at: 1) xTable. 356722! ! 356723 356724!StrikeFontSet methodsFor: 'as yet unclassified' stamp: 'yo 9/17/2002 17:56'! 356725xTableEncoding: anInteger 356726 "Answer an Array of the left x-coordinate of characters in glyphs." 356727 356728 ^(fontArray at: anInteger + 1) xTable. 356729! ! 356730 356731 356732!StrikeFontSet methodsFor: 'character shapes' stamp: 'sd 2/4/2008 21:20'! 356733characterFormAt: character 356734 356735 | encoding ascii xTable leftX rightX | 356736 encoding := character leadingChar + 1. 356737 ascii := character charCode. 356738 (ascii < (fontArray at: encoding) minAscii or: [ascii > (fontArray at: encoding) maxAscii]) 356739 ifTrue: [ascii := (fontArray at: encoding) maxAscii]. 356740 xTable := (fontArray at: encoding) xTable. 356741 leftX := xTable at: ascii + 1. 356742 rightX := xTable at: ascii + 2. 356743 ^ (fontArray at: encoding) glyphs copy: (leftX @ 0 corner: rightX @ self height). 356744! ! 356745 356746!StrikeFontSet methodsFor: 'character shapes' stamp: 'sd 2/4/2008 21:20'! 356747characterFormAt: character put: characterForm 356748 356749 | ascii leftX rightX widthDif newGlyphs encoding xTable glyphs | 356750 encoding := character leadingChar + 1. 356751 ascii := character charCode. 356752 ascii < (fontArray at: encoding) minAscii ifTrue: [ 356753 ^ self error: 'Cant store characters below min ascii' 356754 ]. 356755 ascii > (fontArray at: encoding) maxAscii ifTrue: [ 356756 ^ self error: 'No change made' 356757 ]. 356758 xTable := (fontArray at: encoding) xTable. 356759 leftX := xTable at: ascii + 1. 356760 rightX := xTable at: ascii + 2. 356761 glyphs := (fontArray at: encoding) glyphs. 356762 widthDif := characterForm width - (rightX - leftX). 356763 widthDif ~= 0 ifTrue: [ 356764 newGlyphs := Form extent: glyphs width + widthDif @ glyphs height. 356765 newGlyphs copy: (0 @ 0 corner: leftX @ glyphs height) from: 0 @ 0 356766 in: glyphs rule: Form over. 356767 newGlyphs 356768 copy: (rightX + widthDif @ 0 corner: newGlyphs width @ glyphs height) 356769 from: rightX @ 0 in: glyphs rule: Form over. 356770 glyphs := newGlyphs. 356771 "adjust further entries on xTable" 356772 xTable := xTable copy. 356773 ascii + 2 to: xTable size do: [:i | 356774 xTable at: i put: (xTable at: i) + widthDif]]. 356775 glyphs copy: (leftX @ 0 extent: characterForm extent) from: 0 @ 0 in: characterForm rule: Form over. 356776! ! 356777 356778 356779!StrikeFontSet methodsFor: 'displaying' stamp: 'sd 2/4/2008 21:20'! 356780characters: anInterval in: sourceString displayAt: aPoint clippedBy: clippingRectangle rule: ruleInteger fillColor: aForm kernDelta: kernDelta on: aBitBlt 356781 "Simple, slow, primitive method for displaying a line of characters. 356782 No wrap-around is provided." 356783 356784 | ascii encoding destPoint leftX rightX sourceRect xTable noFont f | 356785 destPoint := aPoint. 356786 anInterval do: 356787 [:i | 356788 encoding := (sourceString at: i) leadingChar + 1. 356789 noFont := false. 356790 [f := fontArray at: encoding] 356791 on: Exception do: [:ex | noFont := true. f := fontArray at: 1]. 356792 f ifNil: [noFont := true. f := fontArray at: 1]. 356793 ascii := noFont ifTrue: [$?] ifFalse: [(sourceString at: i) charCode]. 356794 (ascii < f minAscii 356795 or: [ascii > f maxAscii]) 356796 ifTrue: [ascii := f maxAscii]. 356797 xTable := f xTable. 356798 leftX := xTable at: ascii + 1. 356799 rightX := xTable at: ascii + 2. 356800 sourceRect := leftX@0 extent: (rightX-leftX) @ self height. 356801 aBitBlt copyFrom: sourceRect in: f glyphs to: destPoint. 356802 destPoint := destPoint + ((rightX-leftX+kernDelta)@0). 356803 "destPoint printString displayAt: 0@(i*20)." 356804 ]. 356805 ^ destPoint. 356806! ! 356807 356808!StrikeFontSet methodsFor: 'displaying' stamp: 'efc 8/6/2005 11:45'! 356809displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY 356810 356811 | destPoint leftX rightX glyphInfo g destY | 356812 destPoint := aPoint. 356813 glyphInfo := Array new: 5. 356814 startIndex to: stopIndex do: [:charIndex | 356815 self glyphInfoOf: (aString at: charIndex) into: glyphInfo. 356816 g := glyphInfo at:1. 356817 leftX := glyphInfo at:2. 356818 rightX := glyphInfo at:3. 356819 ((glyphInfo at:5) ~= aBitBlt lastFont) ifTrue: [ 356820 (glyphInfo at:5) installOn: aBitBlt. 356821 ]. 356822 aBitBlt sourceForm: g. 356823 destY := baselineY - (glyphInfo at:4). 356824 aBitBlt destX: (destPoint x) destY: destY width: (rightX - leftX) height: (self height). 356825 aBitBlt sourceOrigin: leftX @ 0. 356826 aBitBlt copyBits. 356827 destPoint := destPoint + (rightX - leftX + kernDelta @ 0). 356828 ]. 356829 ^ destPoint.! ! 356830 356831!StrikeFontSet methodsFor: 'displaying' stamp: 'sd 2/4/2008 21:20'! 356832displayStringR2L: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 356833 356834 | destPoint font | 356835 destPoint := aPoint. 356836 startIndex to: stopIndex do: [:charIndex | 356837 | encoding ascii xTable leftX rightX | 356838 encoding := (aString at: charIndex) leadingChar + 1. 356839 ascii := (aString at: charIndex) charCode. 356840 font := fontArray at: encoding. 356841 ((ascii between: font minAscii and: font maxAscii) not) ifTrue: [ 356842 ascii := font maxAscii]. 356843 xTable := font xTable. 356844 leftX := xTable at: ascii + 1. 356845 rightX := xTable at: ascii + 2. 356846 aBitBlt sourceForm: font glyphs. 356847 aBitBlt destX: destPoint x - (rightX - leftX). 356848 aBitBlt destY: destPoint y. 356849 aBitBlt sourceOrigin: leftX @ 0. 356850 aBitBlt width: rightX - leftX. 356851 aBitBlt height: self height. 356852 aBitBlt copyBits. 356853 destPoint := destPoint - (rightX - leftX + kernDelta @ 0). 356854 ]. 356855! ! 356856 356857!StrikeFontSet methodsFor: 'displaying' stamp: 'yo 1/7/2005 12:04'! 356858displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 356859 356860 ^ self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent. 356861! ! 356862 356863!StrikeFontSet methodsFor: 'displaying' stamp: 'sd 2/4/2008 21:20'! 356864displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY 356865 "Draw the given string from startIndex to stopIndex 356866 at aPoint on the (already prepared) BitBlt." 356867 356868 "Assume this is a wide string" 356869 | isMulti | 356870 isMulti := true. 356871 356872 "Look for an excuse to use the fast primitive" 356873 (aString isKindOf: ByteString) 356874 ifTrue:[ isMulti := false] 356875 ifFalse:[ (aString isKindOf: Text) 356876 ifTrue:[ (aString string isKindOf: ByteString) 356877 ifTrue:[ isMulti := false ] 356878 ]]. 356879 356880 isMulti ifTrue:[^ self displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY]. 356881 356882 ^ aBitBlt displayString: aString 356883 from: startIndex 356884 to: stopIndex 356885 at: aPoint 356886 strikeFont: self 356887 kern: kernDelta! ! 356888 356889!StrikeFontSet methodsFor: 'displaying' stamp: 'John M McIntosh 11/4/2008 22:14'! 356890displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont baselineY: baselineY 356891 356892 | destPoint leftX rightX glyphInfo g tag char destY | 356893 destPoint := aPoint. 356894 rIndex := startIndex. 356895 tag := (aString at: rIndex) leadingChar. 356896 glyphInfo := Array new: 5. 356897 [rIndex <= stopIndex] whileTrue: [ 356898 char := aString at: rIndex. 356899 ((fromFont hasGlyphOf: char) or: [char leadingChar ~= tag]) ifTrue: [^ Array with: rIndex with: destPoint]. 356900 self glyphInfoOf: char into: glyphInfo. 356901 g := glyphInfo at: 1. 356902 leftX := glyphInfo at: 2. 356903 rightX := glyphInfo at: 3. 356904 (glyphInfo fifth ~= aBitBlt lastFont) ifTrue: [ 356905 glyphInfo fifth installOn: aBitBlt. 356906 ]. 356907 aBitBlt sourceForm: g. 356908 destY := baselineY - (glyphInfo at: 4). 356909 aBitBlt destX: destPoint x. 356910 aBitBlt destY: destY. 356911 aBitBlt sourceOrigin: leftX @ 0. 356912 aBitBlt width: rightX - leftX. 356913 aBitBlt height: self height. 356914 aBitBlt copyBits. 356915 destPoint := destPoint + (rightX - leftX + kernDelta @ 0). 356916 rIndex := rIndex + 1. 356917 ]. 356918 ^ Array with: rIndex with: destPoint. 356919! ! 356920 356921!StrikeFontSet methodsFor: 'displaying' stamp: 'BG 3/16/2005 08:27'! 356922fontDisplay 356923 "TextStyle default defaultFont fontDisplay." 356924 356925 Display restoreAfter: 356926 [(Form extent: 440@400) displayAt: 90@90. 356927 0 to: 15 do: 356928 [:i | 356929 i storeStringHex displayAt: 100 @ (20 * i + 100). 356930 0 to: 15 do: 356931 [:j | 356932 ((16*i+j) between: 1 and: (self xTable size - 2)) ifTrue: 356933 [(self characterFormAt: (16 * i + j) asCharacter) 356934 displayAt: (20 * j + 150) @ (20 * i + 100)]]]. 356935 'Click to continue...' asDisplayText displayAt: 100@450]! ! 356936 356937 356938!StrikeFontSet methodsFor: 'emphasis' stamp: 'sd 2/4/2008 21:14'! 356939makeBoldGlyphs 356940 "Make a bold set of glyphs with same widths by ORing 1 bit to the right 356941 (requires at least 1 pixel of intercharacter space)" 356942 356943 | g bonkForm font | 356944 1 to: fontArray size do: [:i | 356945 font := fontArray at: i. 356946 font ifNotNil: [ 356947 g := font glyphs deepCopy. 356948 bonkForm := (Form extent: 1@16) fillBlack offset: -1@0. 356949 self bonk: g with: bonkForm at: i. 356950 g copyBits: g boundingBox from: g at: (1@0) 356951 clippingBox: g boundingBox rule: Form under fillColor: nil. 356952 (fontArray at: i) setGlyphs: g. 356953 ]. 356954 ]. 356955! ! 356956 356957!StrikeFontSet methodsFor: 'emphasis' stamp: 'sd 2/4/2008 21:18'! 356958makeItalicGlyphs 356959 "Make an italic set of glyphs with same widths by skewing left and right 356960 (may require more intercharacter space)" 356961 356962 | g bonkForm bc font | 356963 1 to: fontArray size do: [:j | 356964 font := (fontArray at: j). 356965 font ifNotNil: [ 356966 g := font glyphs deepCopy. 356967 "BonkForm will have bits where slanted characters overlap their neighbors." 356968 bonkForm := Form extent: (self height//4+2) @ self height. 356969 bc := font descent//4 + 1. "Bonker x-coord corresponding to char boundary." 356970 bonkForm fill: (0 @ 0 corner: (bc+1) @ font ascent) fillColor: Color black. 356971 4 to: font ascent-1 by: 4 do: 356972 [:y | "Slide ascenders right..." 356973 g copy: (1@0 extent: g width @ (font ascent - y)) 356974 from: 0@0 in: g rule: Form over. 356975 bonkForm copy: (1@0 extent: bonkForm width @ (font ascent - y)) 356976 from: 0@0 in: bonkForm rule: Form over]. 356977 bonkForm fill: (0 @ 0 corner: (bc+1) @ font ascent) fillColor: Color white. 356978 bonkForm fill: (bc @ font ascent corner: bonkForm extent) fillColor: Color black. 356979 font ascent to: font height-1 by: 4 do: 356980 [:y | "Slide descenders left..." 356981 g copy: (0@y extent: g width @ g height) 356982 from: 1@y in: g rule: Form over. 356983 bonkForm copy: (0@0 extent: bonkForm width @ bonkForm height) 356984 from: 1@0 in: bonkForm rule: Form over]. 356985 bonkForm fill: (bc @ font ascent corner: bonkForm extent) fillColor: Color white. 356986 "Now use bonkForm to erase at every character boundary in glyphs." 356987 bonkForm offset: (0-bc) @ 0. 356988 font bonk: g with: bonkForm. 356989 font setGlyphs: g 356990 ]. 356991 ]. 356992! ! 356993 356994!StrikeFontSet methodsFor: 'emphasis' stamp: 'sd 2/4/2008 21:18'! 356995makeStruckOutGlyphs 356996 "Make a struck-out set of glyphs with same widths" 356997 356998 | g font | 356999 1 to: fontArray size do: [:i | 357000 font := (fontArray at: i). 357001 font ifNotNil: [ 357002 g := font glyphs deepCopy. 357003 g fillBlack: (0 @ (font ascent - (font ascent//3)) extent: g width @ 1). 357004 font setGlyphs: g 357005 ]. 357006 ]. 357007! ! 357008 357009!StrikeFontSet methodsFor: 'emphasis' stamp: 'sd 2/4/2008 21:18'! 357010makeUnderlinedGlyphs 357011 "Make an underlined set of glyphs with same widths" 357012 357013 | g font | 357014 1 to: fontArray size do: [:i | 357015 font := (fontArray at: i). 357016 font ifNotNil: [ 357017 g := font glyphs deepCopy. 357018 g fillBlack: (0 @ (font ascent+1) extent: g width @ 1). 357019 font setGlyphs: g 357020 ]. 357021 ]. 357022! ! 357023 357024 357025!StrikeFontSet methodsFor: 'testing' stamp: 'yo 2/12/2007 19:34'! 357026isFontSet 357027 357028 ^ true. 357029! ! 357030 357031 357032!StrikeFontSet methodsFor: 'private' stamp: 'sd 2/4/2008 21:13'! 357033addNewFont: aFont at: encodingIndex 357034 357035 | newArray | 357036 encodingIndex > fontArray size ifTrue: [ 357037 newArray := Array new: encodingIndex. 357038 newArray replaceFrom: 1 to: fontArray size with: fontArray startingAt: 1. 357039 ] ifFalse: [ 357040 newArray := fontArray. 357041 ]. 357042 357043 newArray at: encodingIndex put: aFont. 357044 357045 self initializeWithFontArray: newArray. 357046! ! 357047 357048!StrikeFontSet methodsFor: 'private' stamp: 'sd 2/4/2008 21:14'! 357049glyphInfoOf: aCharacter into: glyphInfoArray 357050 357051 | index f code leftX | 357052 index := aCharacter leadingChar + 1. 357053 fontArray size < index ifTrue: [^ self questionGlyphInfoInto: glyphInfoArray]. 357054 (f := fontArray at: index) ifNil: [^ self questionGlyphInfoInto: glyphInfoArray]. 357055 357056 code := aCharacter charCode. 357057 ((code between: f minAscii and: f maxAscii) not) ifTrue: [ 357058 ^ self questionGlyphInfoInto: glyphInfoArray. 357059 ]. 357060 leftX := f xTable at: code + 1. 357061 leftX < 0 ifTrue: [ 357062 ^ self questionGlyphInfoInto: glyphInfoArray. 357063 ]. 357064 glyphInfoArray at: 1 put: f glyphs; 357065 at: 2 put: leftX; 357066 at: 3 put: (f xTable at: code + 2); 357067 at: 4 put: (f ascentOf: aCharacter); 357068 at: 5 put: self. 357069 ^ glyphInfoArray. 357070! ! 357071 357072!StrikeFontSet methodsFor: 'private' stamp: 'sd 2/4/2008 21:14'! 357073questionGlyphInfoInto: glyphInfoArray 357074 357075 | f ascii | 357076 f := fontArray at: 1. 357077 ascii := $? asciiValue. 357078 glyphInfoArray at: 1 put: f glyphs; 357079 at: 2 put: (f xTable at: ascii + 1); 357080 at: 3 put: (f xTable at: ascii + 2); 357081 at: 4 put: (self ascentOf: $?); 357082 at: 5 put: self. 357083 ^ glyphInfoArray. 357084! ! 357085 357086"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 357087 357088StrikeFontSet class 357089 instanceVariableNames: ''! 357090 357091!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 357092createExternalFontFileForLatin2: fileName 357093" 357094 StrikeFontSet createExternalFontFileForLatin2: 'latin2.out'. 357095" 357096 357097 | file array f installDirectory | 357098 file := FileStream newFileNamed: fileName. 357099 installDirectory := Smalltalk at: #M17nInstallDirectory ifAbsent: []. 357100 installDirectory := installDirectory 357101 ifNil: [String new] 357102 ifNotNil: [installDirectory , FileDirectory pathNameDelimiter asString]. 357103 array := Array 357104 with: (StrikeFont newFromEFontBDFFile: installDirectory , 'b10.bdf' name: 'LatinTwo9' ranges: EFontBDFFontReaderForRanges rangesForLatin2) 357105 with: (StrikeFont newFromEFontBDFFile: installDirectory , 'b12.bdf' name: 'LatinTwo10' ranges: EFontBDFFontReaderForRanges rangesForLatin2) 357106 with: (StrikeFont newFromEFontBDFFile: installDirectory , 'b14.bdf' name: 'LatinTwo12' ranges: EFontBDFFontReaderForRanges rangesForLatin2) 357107 with: (StrikeFont newFromEFontBDFFile: installDirectory , 'b16.bdf' name: 'LatingTwo14' ranges: EFontBDFFontReaderForRanges rangesForLatin2) 357108 with: (StrikeFont newFromEFontBDFFile: installDirectory , 'b24.bdf' name: 'LatinTwo20' ranges: EFontBDFFontReaderForRanges rangesForLatin2). 357109 TextConstants at: #forceFontWriting put: true. 357110 f := ReferenceStream on: file. 357111 f nextPut: array. 357112 file close. 357113 TextConstants removeKey: #forceFontWriting. 357114! ! 357115 357116!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 357117createExternalFontFileForUnicodeJapanese: fileName 357118" 357119 StrikeFontSet createExternalFontFileForUnicodeJapanese: 'uJapaneseFont.out'. 357120" 357121 357122 | file array f installDirectory | 357123 file := FileStream newFileNamed: fileName. 357124 installDirectory := Smalltalk at: #M17nInstallDirectory ifAbsent: []. 357125 installDirectory := installDirectory 357126 ifNil: [String new] 357127 ifNotNil: [installDirectory , FileDirectory pathNameDelimiter asString]. 357128 array := Array 357129 with: (StrikeFont newForJapaneseFromEFontBDFFile: installDirectory , 'b12.bdf' name: 'Japanese10' overrideWith: 'shnmk12.bdf') 357130 with: ((StrikeFont newForJapaneseFromEFontBDFFile: installDirectory , 'b14.bdf' name: 'Japanese12' overrideWith: 'shnmk14.bdf') "fixAscent: 14 andDescent: 1 head: 1") 357131 with: ((StrikeFont newForJapaneseFromEFontBDFFile: 'b16.bdf' name: 'Japanese14' overrideWith: 'shnmk16.bdf') "fixAscent: 16 andDescent: 4 head: 4") 357132 with: (StrikeFont newForJapaneseFromEFontBDFFile: installDirectory , 'b24.bdf' name: 'Japanese18' overrideWith: 'kanji24.bdf'). 357133 TextConstants at: #forceFontWriting put: true. 357134 f := ReferenceStream on: file. 357135 f nextPut: array. 357136 file close. 357137 TextConstants removeKey: #forceFontWriting. 357138! ! 357139 357140!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'janggoon 11/4/2008 22:12'! 357141createExternalFontFileForUnicodeKorean: fileName 357142" 357143 Smalltalk garbageCollect. 357144 StrikeFontSet createExternalFontFileForUnicodeKorean: 'uKoreanFont.out'. 357145" 357146 357147 | file array f installDirectory | 357148 file := FileStream newFileNamed: fileName. 357149 installDirectory := Smalltalk at: #M17nInstallDirectory ifAbsent: []. 357150 installDirectory := installDirectory 357151 ifNil: [String new] 357152 ifNotNil: [installDirectory , FileDirectory pathNameDelimiter asString]. 357153 array := Array 357154 with: (StrikeFont newForKoreanFromEFontBDFFile: installDirectory , 'b12.bdf' name: 'Korean10' overrideWith: 'shnmk12.bdf') 357155 with: ((StrikeFont newForKoreanFromEFontBDFFile: installDirectory , 'b14.bdf' name: 'Korean12' overrideWith: 'shnmk14.bdf') "fixAscent: 14 andDescent: 1 head: 1") 357156 with: ((StrikeFont newForKoreanFromEFontBDFFile: installDirectory , 'b16.bdf' name: 'Korean14' overrideWith: 'hanglg16.bdf') fixAscent: 16 andDescent: 4 head: 4) 357157 with: (StrikeFont newForKoreanFromEFontBDFFile: installDirectory , 'b24.bdf' name: 'Korean18' overrideWith: 'hanglm24.bdf'). 357158 TextConstants at: #forceFontWriting put: true. 357159 f := ReferenceStream on: file. 357160 f nextPut: array. 357161 file close. 357162 TextConstants removeKey: #forceFontWriting.! ! 357163 357164!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 357165decodedFromRemoteCanvas: aString 357166 357167 | array | 357168 array := aString findTokens: #($ ). 357169 ^ self familyName: (array at: 1) size: (array at: 2) asNumber emphasized: (array at: 3) asNumber. 357170! ! 357171 357172!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 357173duplicateArrayElementsForLeadingCharShift 357174" 357175 self duplicateArrayElementsForLeadingCharShift 357176" 357177 | array font | 357178 self allInstances do: [:s | 357179 s emphasis = 0 ifTrue: [ 357180 array := s fontArray. 357181 2 to: (4 min: array size) do: [:i | 357182 font := array at: i. 357183 s addNewFont: font at: ((i - 1) << 2) + 1. 357184 ]. 357185 ] ifFalse: [ 357186 s reset 357187 ]. 357188 ]. 357189! ! 357190 357191!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 357192familyName: aName size: aSize 357193 "Answer a font (or the default font if the name is unknown) in the specified size." 357194 357195 | collection | 357196 collection := self allInstances select: [:inst | (inst name beginsWith: aName) and: [inst emphasis = 0]]. 357197 collection isEmpty ifTrue: [ 357198 (aName = 'DefaultMultiStyle') ifTrue: [ 357199 collection := (TextConstants at: #DefaultMultiStyle) fontArray. 357200 ] ifFalse: [ 357201 ^ TextStyle defaultFont 357202 ] 357203 ]. 357204 collection := collection asSortedCollection: [:a :b | a pointSize <= b pointSize]. 357205 collection do: [:s | (s pointSize >= aSize) ifTrue: [^ s]]. 357206 ^ TextStyle defaultFont. 357207! ! 357208 357209!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 21:03'! 357210familyName: aName size: aSize emphasized: emphasisCode 357211 "Create the font with this emphasis" 357212 357213 ^ (self familyName: aName size: aSize) emphasized: emphasisCode 357214! ! 357215 357216!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 5/25/2004 14:32'! 357217findMaximumLessThan: f in: array 357218 357219 array size to: 1 by: -1 do: [:i | 357220 f height >= (array at: i) height ifTrue: [^ array at: i]. 357221 ]. 357222 ^ array first. 357223! ! 357224 357225!StrikeFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 9/23/2002 16:32'! 357226newFontArray: anArray 357227 357228 ^super new initializeWithFontArray: anArray 357229! ! 357230 357231 357232!StrikeFontSet class methodsFor: 'filein/out' stamp: 'yo 1/18/2005 16:00'! 357233installExternalFontFileName6: fileName encoding: encoding encodingName: aString textStyleName: styleName 357234 357235 ^ self installExternalFontFileName6: fileName inDir: FileDirectory default encoding: encoding encodingName: aString textStyleName: styleName. 357236 357237" 357238StrikeFontSet createExternalFontFileForCyrillic: 'cyrillicFont.out'. 357239 357240StrikeFontSet installExternalFontFileName6: 'latin2.out' encoding: Latin2Environment leadingChar encodingName: #Latin2 textStyleName: #DefaultMultiStyle. 357241StrikeFontSet installExternalFontFileName6: 'uJapaneseFont.out' encoding: JapaneseEnvironment leadingChar encodingName: #Japanese textStyleName: #DefaultMultiStyle. 357242 357243StrikeFontSet installExternalFontFileName6: 'uKoreanFont.out' encoding: UnicodeKorean leadingChar encodingName: #Korean textStyleName: #DefaultMultiStyle. 357244 357245StrikeFontSet removeFontsForEncoding: 2 encodingName: #Gb2312. 357246self halt. 357247StrikeFontSet removeFontsForEncoding: 3 encodingName: #KsX1001. 357248" 357249! ! 357250 357251!StrikeFontSet class methodsFor: 'filein/out' stamp: 'tak 8/3/2005 17:40'! 357252installExternalFontFileName6: fileName inDir: dir encoding: encoding encodingName: aString textStyleName: styleName 357253 | aStream | 357254 aStream := dir readOnlyFileNamed: fileName. 357255 [self 357256 installExternalFontOn: aStream 357257 encoding: encoding 357258 encodingName: aString 357259 textStyleName: styleName] 357260 ensure: [aStream close]! ! 357261 357262!StrikeFontSet class methodsFor: 'filein/out' stamp: 'yo 3/17/2004 10:32'! 357263installExternalFontFileName: fileName encoding: encoding encodingName: aString textStyleName: styleName 357264 357265 ^ self installExternalFontFileName: fileName inDir: FileDirectory default encoding: encoding encodingName: aString textStyleName: styleName. 357266 357267" 357268StrikeFontSet createExternalFontFileForCyrillic: 'cyrillicFont.out'. 357269 357270StrikeFontSet installExternalFontFileName: 'chineseFont.out' encoding: 2 encodingName: #Gb2312 textStyleName: #DefaultMultiStyle. 357271StrikeFontSet installExternalFontFileName: 'japaneseFont.out' encoding: 1 encodingName: #JisX0208 textStyleName: #DefaultMultiStyle. 357272StrikeFontSet installExternalFontFileName: 'defaultFont.out' encoding: 0 encodingName: #Latin1 textStyleName: #DefaultMultiStyle. 357273StrikeFontSet installExternalFontFileName: 'cyrillicFont.out' encoding: UnicodeCyrillic leadingChar encodingName: #Cyrillic textStyleName: #DefaultMultiStyle. 357274StrikeFontSet installExternalFontFileName: 'extendedLatinFont.out' encoding: UnicodeLatinExtendedAB leadingChar encodingName: #ExtendedLatin textStyleName: #DefaultMultiStyle. 357275StrikeFontSet installExternalFontFileName: 'ipaExtensionsFont.out' encoding: UnicodeIPA leadingChar encodingName: #IPAExtensions textStyleName: #DefaultMultiStyle. 357276StrikeFontSet installExternalFontFileName: 'armenianFont.out' encoding: UnicodeArmenian leadingChar encodingName: #Armenian textStyleName: #DefaultMultiStyle. 357277StrikeFontSet installExternalFontFileName: 'greekFont.out' encoding: UnicodeGreek leadingChar encodingName: #Greek textStyleName: #DefaultMultiStyle. 357278 357279StrikeFontSet installExternalFontFileName: 'arrowFont.out' encoding: UnicodeArrows leadingChar encodingName: #Arrow textStyleName: #DefaultMultiStyle. 357280 357281StrikeFontSet installExternalFontFileName: 'uJapaneseFont.out' indir: FileDirectory default encoding: JapaneseEnvironment leadingChar encodingName: #Japanese textStyleName: #DefaultMultiStyle. 357282 357283StrikeFontSet installExternalFontFileName: 'uKoreanFont.out' encoding: UnicodeKorean leadingChar encodingName: #Korean textStyleName: #DefaultMultiStyle. 357284 357285StrikeFontSet removeFontsForEncoding: 2 encodingName: #Gb2312. 357286self halt. 357287StrikeFontSet removeFontsForEncoding: 3 encodingName: #KsX1001. 357288" 357289! ! 357290 357291!StrikeFontSet class methodsFor: 'filein/out' stamp: 'sd 2/4/2008 21:20'! 357292installExternalFontFileName: fileName inDir: dir encoding: encoding encodingName: aString textStyleName: styleName 357293 357294 | array arrayFour oldStyle arrayOfFS fs fonts newFonts | 357295 array := (ReferenceStream on: (dir readOnlyFileNamed: fileName)) next. 357296 357297 arrayFour := Array new: 4 withAll: array last. 357298 arrayFour replaceFrom: 1 to: array size with: array startingAt: 1. 357299 TextConstants at: aString asSymbol put: arrayFour. 357300 357301 oldStyle := TextConstants at: styleName asSymbol. 357302 arrayOfFS := oldStyle fontArray. 357303 arrayOfFS := (1 to: 4) collect: [:i | 357304 fs := arrayOfFS at: i. 357305 fonts := fs fontArray. 357306 encoding + 1 > fonts size ifTrue: [ 357307 newFonts := Array new: encoding + 1. 357308 newFonts replaceFrom: 1 to: fonts size with: fonts startingAt: 1. 357309 newFonts at: encoding + 1 put: (arrayFour at: i). 357310 fs initializeWithFontArray: newFonts. 357311 ] ifFalse: [ 357312 fonts at: encoding + 1 put: (arrayFour at: i). 357313 ]. 357314 fs. 357315 ]. 357316 357317 TextConstants at: styleName asSymbol put: (TextStyle fontArray: arrayOfFS). 357318 oldStyle becomeForward: (TextConstants at: styleName asSymbol). 357319 357320! ! 357321 357322!StrikeFontSet class methodsFor: 'filein/out' stamp: 'sd 2/4/2008 21:20'! 357323installExternalFontOn: aStream encoding: encoding encodingName: aString textStyleName: styleName 357324 357325 | array fonts encodingIndex textStyle | 357326 357327 array := aStream 357328 untilEndWithFork: [(ReferenceStream on: aStream) next] 357329 displayingProgress: 'Font reading...'. 357330 357331 TextConstants at: aString asSymbol put: array. 357332 357333 textStyle := TextConstants at: styleName asSymbol. 357334 encodingIndex := encoding + 1. 357335 textStyle fontArray do: [:fs | 357336 fonts := fs fontArray. 357337 encodingIndex > fonts size 357338 ifTrue: [fonts := (Array new: encodingIndex) 357339 replaceFrom: 1 to: fonts size with: fonts startingAt: 1]. 357340 fonts at: encodingIndex put: (self findMaximumLessThan: fs fontArray first in: array). 357341 fs initializeWithFontArray: fonts. 357342 ]. 357343! ! 357344 357345!StrikeFontSet class methodsFor: 'filein/out' stamp: 'tak 8/4/2005 11:03'! 357346installExternalFontOn: aStream forLocale: locale 357347 self 357348 installExternalFontOn: aStream 357349 encoding: locale languageEnvironment leadingChar 357350 encodingName: locale languageEnvironment fontEncodingName 357351 textStyleName: #DefaultMultiStyle! ! 357352 357353!StrikeFontSet class methodsFor: 'filein/out' stamp: 'sd 2/4/2008 21:20'! 357354installNewFontAtIndex: newIndex fromOld: oldIndex 357355 357356 | fontArray newArray | 357357 self allInstances do: [:set | 357358 fontArray := set fontArray. 357359 newIndex + 1 > fontArray size ifTrue: [ 357360 newArray := Array new: newIndex + 1. 357361 newArray replaceFrom: 1 to: fontArray size with: fontArray startingAt: 1. 357362 newArray at: newIndex + 1 put: (fontArray at: oldIndex + 1). 357363 set initializeWithFontArray: newArray. 357364 ] ifFalse: [ 357365 fontArray at: newIndex + 1 put: (fontArray at: oldIndex + 1). 357366 ]. 357367 ]. 357368 357369" 357370StrikeFontSet installNewFontAtIndex: UnicodeSimplifiedChinese leadingChar fromOld: UnicodeJapanese leadingChar 357371StrikeFontSet installNewFontAtIndex: UnicodeKorean leadingChar fromOld: UnicodeJapanese leadingChar 357372" 357373! ! 357374 357375!StrikeFontSet class methodsFor: 'filein/out' stamp: 'sd 2/4/2008 21:20'! 357376removeFontsForEncoding: leadingChar encodingName: encodingSymbol 357377 357378 | insts fonts newFonts index | 357379 leadingChar = 0 ifTrue: [^ self error: 'you cannot delete the intrinsic fonts']. 357380 insts := self allInstances. 357381 insts do: [:inst | 357382 fonts := inst fontArray. 357383 fonts size >= (leadingChar + 1) ifTrue: [ 357384 leadingChar + 1 = fonts size ifTrue: [ 357385 newFonts := fonts copyFrom: 1 to: fonts size - 1. 357386 index := newFonts indexOf: nil. 357387 index > 0 ifTrue: [newFonts := newFonts copyFrom: 1 to: index - 1]. 357388 inst initializeWithFontArray: newFonts. 357389 ] ifFalse: [ 357390 fonts at: leadingChar + 1 put: nil. 357391 ]. 357392 ]. 357393 ]. 357394 357395 TextConstants removeKey: encodingSymbol asSymbol ifAbsent: []. 357396! ! 357397ArrayedCollection subclass: #String 357398 instanceVariableNames: '' 357399 classVariableNames: 'AsciiOrder CSLineEnders CSNonSeparators CSSeparators CaseInsensitiveOrder CaseSensitiveOrder HtmlEntities LowercasingTable Tokenish UppercasingTable' 357400 poolDictionaries: '' 357401 category: 'Collections-Strings'! 357402!String commentStamp: '<historical>' prior: 0! 357403A String is an indexed collection of Characters. Class String provides the abstract super class for ByteString (that represents an array of 8-bit Characters) and WideString (that represents an array of 32-bit characters). In the similar manner of LargeInteger and SmallInteger, those subclasses are chosen accordingly for a string; namely as long as the system can figure out so, the String is used to represent the given string. 357404 357405Strings support a vast array of useful methods, which can best be learned by browsing and trying out examples as you find them in the code. 357406 357407Here are a few useful methods to look at... 357408 String match: 357409 String contractTo: 357410 357411String also inherits many useful methods from its hierarchy, such as 357412 SequenceableCollection , 357413 SequenceableCollection copyReplaceAll:with: 357414! 357415]style[(55 376 188 13 2 18 72 24 2 44)f1,f2,f1,f1LString match:;,f1,f1LString contractTo:;,f1,f1LSequenceableCollection ,;,f1,f1LSequenceableCollection copyReplaceAll:with:;! 357416 357417 357418!String methodsFor: '*monticello' stamp: 'avi 2/4/2004 14:14'! 357419extractNumber 357420 ^ ('0', self select: [:ea | ea isDigit]) asNumber! ! 357421 357422 357423!String methodsFor: '*morphic' stamp: 'ar 4/10/2005 17:07'! 357424asMorph 357425 "Answer the receiver as a StringMorph" 357426 357427 ^ StringMorph contents: self 357428 357429"'bugs black blood' asMorph openInHand"! ! 357430 357431!String methodsFor: '*morphic' stamp: 'ar 4/10/2005 17:07'! 357432asStringMorph 357433 "Answer the receiver as a StringMorph" 357434 357435 ^ StringMorph contents: self 357436 357437"'bugs black blood' asStringMorph openInHand"! ! 357438 357439 357440!String methodsFor: '*network-mime' stamp: 'mir 2/16/2006 23:21'! 357441asMIMEType 357442 ^MIMEType fromMIMEString: self! ! 357443 357444 357445!String methodsFor: '*network-uri' stamp: 'mir 2/26/2002 14:59'! 357446asURI 357447 "convert to a Url" 357448 "'http://www.cc.gatech.edu/' asURI" 357449 "'msw://chaos.resnet.gatech.edu:9000/' asURI" 357450 ^URI fromString: self! ! 357451 357452!String methodsFor: '*network-uri' stamp: 'JMM 8/2/2007 12:09'! 357453asURIForceEncoding 357454 "convert to a Url after we do the HTTP string safe encoding" 357455 "'http://www.cc.gatech.edu/' asURIWithEncoding" 357456 "'msw://chaos.resnet.gatech.edu:9000/' asURIWithEncoding" 357457 ^URI fromString: self encodeForHTTPAlternateSkipSlashColon! ! 357458 357459!String methodsFor: '*network-uri' stamp: 'PeterHugossonMiller 9/3/2009 11:26'! 357460encodeForHTTPAlternate 357461 "change dangerous characters to their %XX form, for use in HTTP transactions" 357462 | encodedStream | 357463 encodedStream := (String new) writeStream. 357464 357465 self do: [ :c | 357466 c isSafeForHTTPAlternate ifTrue: [ encodedStream nextPut: c ] ifFalse: [ 357467 encodedStream nextPut: $%. 357468 encodedStream nextPut: (c asciiValue // 16) asHexDigit. 357469 encodedStream nextPut: (c asciiValue \\ 16) asHexDigit. 357470 ] 357471 ]. 357472 ^encodedStream contents. ! ! 357473 357474!String methodsFor: '*network-uri' stamp: 'PeterHugossonMiller 9/3/2009 11:27'! 357475encodeForHTTPAlternateSkipSlashColon 357476 "change dangerous characters to their %XX form, for use in HTTP transactions" 357477 | encodedStream | 357478 encodedStream := (String new) writeStream. 357479 357480 self do: [ :c | 357481 (c isSafeForHTTPAlternate or: [c == $/ or: [c == $:]]) ifTrue: [ encodedStream nextPut: c ] ifFalse: [ 357482 encodedStream nextPut: $%. 357483 encodedStream nextPut: (c asciiValue // 16) asHexDigit. 357484 encodedStream nextPut: (c asciiValue \\ 16) asHexDigit. 357485 ] 357486 ]. 357487 ^encodedStream contents. ! ! 357488 357489 357490!String methodsFor: '*packageinfo-base' stamp: 'nk 8/30/2004 09:02'! 357491escapeEntities 357492 ^ self species streamContents: [:s | self do: [:c | s nextPutAll: c escapeEntities]] 357493! ! 357494 357495 357496!String methodsFor: '*services-base' stamp: 'rr 3/21/2006 12:00'! 357497service 357498 ^ self serviceOrNil ifNil: [ServiceCategory new id: self asSymbol]! ! 357499 357500!String methodsFor: '*services-base' stamp: 'rr 3/21/2006 12:00'! 357501serviceOrNil 357502 ^ ServiceRegistry current serviceWithId: self asSymbol! ! 357503 357504 357505!String methodsFor: '*splitjoin' stamp: 'onierstrasz 4/12/2009 20:21'! 357506join: aCollection 357507 ^ String 357508 streamContents: [:stream | aCollection 357509 do: [:each | stream nextPutAll: each asString] "NB: coerce elements to Strings" 357510 separatedBy: [stream nextPutAll: self]]! ! 357511 357512 357513!String methodsFor: '*vb-regex'! 357514allRegexMatches: rxString 357515 ^rxString asRegex matchesIn: self! ! 357516 357517!String methodsFor: '*vb-regex'! 357518asRegex 357519 "Compile the receiver as a regex matcher. May raise RxParser>>syntaxErrorSignal 357520 or RxParser>>compilationErrorSignal. 357521 This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov. 357522 Refer to `documentation' protocol of RxParser class for details." 357523 ^RxParser preferredMatcherClass for: (RxParser new parse: self)! ! 357524 357525!String methodsFor: '*vb-regex'! 357526asRegexIgnoringCase 357527 "Compile the receiver as a regex matcher. May raise RxParser>>syntaxErrorSignal 357528 or RxParser>>compilationErrorSignal. 357529 This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov. 357530 Refer to `documentation' protocol of RxParser class for details." 357531 ^RxParser preferredMatcherClass 357532 for: (RxParser new parse: self) 357533 ignoreCase: true! ! 357534 357535!String methodsFor: '*vb-regex'! 357536copyWithRegex: rxString matchesReplacedWith: aString 357537 ^rxString asRegex 357538 copy: self replacingMatchesWith: aString! ! 357539 357540!String methodsFor: '*vb-regex'! 357541copyWithRegex: rxString matchesTranslatedUsing: aBlock 357542 ^rxString asRegex 357543 copy: self translatingMatchesUsing: aBlock! ! 357544 357545!String methodsFor: '*vb-regex'! 357546matchesRegex: regexString 357547 "Test if the receiver matches a regex. May raise RxParser>>regexErrorSignal or 357548 child signals. 357549 This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov. 357550 Refer to `documentation' protocol of RxParser class for details." 357551 ^regexString asRegex matches: self! ! 357552 357553!String methodsFor: '*vb-regex'! 357554matchesRegexIgnoringCase: regexString 357555 "Test if the receiver matches a regex. May raise RxParser>>regexErrorSignal or 357556 child signals. 357557 This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov. 357558 Refer to `documentation' protocol of RxParser class for details." 357559 ^regexString asRegexIgnoringCase matches: self! ! 357560 357561!String methodsFor: '*vb-regex'! 357562prefixMatchesRegex: regexString 357563 "Test if the receiver's prefix matches a regex. 357564 May raise RxParser class>>regexErrorSignal or child signals. 357565 This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov. 357566 Refer to `documentation' protocol of RxParser class for details." 357567 ^regexString asRegex matchesPrefix: self! ! 357568 357569!String methodsFor: '*vb-regex'! 357570prefixMatchesRegexIgnoringCase: regexString 357571 "Test if the receiver's prefix matches a regex. 357572 May raise RxParser class>>regexErrorSignal or child signals. 357573 This is a part of the Regular Expression Matcher package, (c) 1996, 1999 Vassili Bykov. 357574 Refer to `documentation' protocol of RxParser class for details." 357575 ^regexString asRegexIgnoringCase matchesPrefix: self! ! 357576 357577!String methodsFor: '*vb-regex'! 357578regex: rxString matchesCollect: aBlock 357579 ^rxString asRegex matchesIn: self collect: aBlock! ! 357580 357581!String methodsFor: '*vb-regex'! 357582regex: rxString matchesDo: aBlock 357583 ^rxString asRegex matchesIn: self do: aBlock! ! 357584 357585 357586!String methodsFor: 'accessing' stamp: 'ar 4/12/2005 16:30'! 357587byteAt: index 357588 ^self subclassResponsibility! ! 357589 357590!String methodsFor: 'accessing' stamp: 'ar 4/12/2005 16:30'! 357591byteAt: index put: value 357592 ^self subclassResponsibility! ! 357593 357594!String methodsFor: 'accessing' stamp: 'ar 4/12/2005 16:30'! 357595byteSize 357596 ^self subclassResponsibility! ! 357597 357598!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357599do: aBlock toFieldNumber: aNumber 357600 "Considering the receiver as a holder of tab-delimited fields, evaluate aBlock on behalf of a field in this string" 357601 357602 | start end index | 357603 start := 1. 357604 index := 1. 357605 [start <= self size] whileTrue: 357606 [end := self indexOf: Character tab startingAt: start ifAbsent: [self size + 1]. 357607 end := end - 1. 357608 aNumber = index ifTrue: 357609 [aBlock value: (self copyFrom: start to: end). 357610 ^ self]. 357611 index := index + 1. 357612 start := end + 2] 357613 357614" 3576151 to: 6 do: 357616 [:aNumber | 357617 'fred charlie elmo wimpy friml' do: 357618 [:aField | Transcript cr; show: aField] toFieldNumber: aNumber] 357619"! ! 357620 357621!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357622endsWithDigit 357623 "Answer whether the receiver's final character represents a digit. 3/11/96 sw" 357624 357625 ^ self size > 0 and: [self last isDigit]! ! 357626 357627!String methodsFor: 'accessing' stamp: 'ar 4/10/2005 17:12'! 357628findAnySubStr: delimiters startingAt: start 357629 "Answer the index of the character within the receiver, starting at start, that begins a substring matching one of the delimiters. delimiters is an Array of Strings (Characters are permitted also). If the receiver does not contain any of the delimiters, answer size + 1." 357630 357631 | min ind | 357632 min := self size + 1. 357633 delimiters do: [:delim | "May be a char, a string of length 1, or a substring" 357634 delim isCharacter 357635 ifTrue: [ind := self indexOfSubCollection: (String with: delim) 357636 startingAt: start ifAbsent: [min]] 357637 ifFalse: [ind := self indexOfSubCollection: delim 357638 startingAt: start ifAbsent: [min]]. 357639 min := min min: ind]. 357640 ^ min! ! 357641 357642!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357643findBetweenSubStrs: delimiters 357644 "Answer the collection of String tokens that result from parsing self. Tokens are separated by 'delimiters', which can be a collection of Strings, or a collection of Characters. Several delimiters in a row are considered as just one separation." 357645 357646 | tokens keyStart keyStop | 357647 tokens := OrderedCollection new. 357648 keyStop := 1. 357649 [keyStop <= self size] whileTrue: 357650 [keyStart := self skipAnySubStr: delimiters startingAt: keyStop. 357651 keyStop := self findAnySubStr: delimiters startingAt: keyStart. 357652 keyStart < keyStop 357653 ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]]. 357654 ^tokens! ! 357655 357656!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357657findCloseParenthesisFor: startIndex 357658 "assume (self at: startIndex) is $(. Find the matching $), allowing parentheses to nest." 357659 " '(1+(2-3))-3.14159' findCloseParenthesisFor: 1 " 357660 " '(1+(2-3))-3.14159' findCloseParenthesisFor: 4 " 357661 | pos nestLevel | 357662 pos := startIndex+1. 357663 nestLevel := 1. 357664 [ pos <= self size ] whileTrue: [ 357665 (self at: pos) = $( ifTrue: [ nestLevel := nestLevel + 1 ]. 357666 (self at: pos) = $) ifTrue: [ nestLevel := nestLevel - 1 ]. 357667 nestLevel = 0 ifTrue: [ ^pos ]. 357668 pos := pos + 1. 357669 ]. 357670 ^self size + 1! ! 357671 357672!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357673findDelimiters: delimiters startingAt: start 357674 "Answer the index of the character within the receiver, starting at start, that matches one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1." 357675 357676 start to: self size do: [:i | 357677 delimiters do: [:delim | delim = (self at: i) ifTrue: [^ i]]]. 357678 ^ self size + 1! ! 357679 357680!String methodsFor: 'accessing' stamp: 'AdrianLienhard 8/26/2009 21:51'! 357681findLastOccuranceOfString: subString startingAt: start 357682 self deprecated: 'Use instead #findLastOccurrenceOfString:startingAt:'. 357683 ^ self findLastOccurrenceOfString: subString startingAt: start ! ! 357684 357685!String methodsFor: 'accessing' stamp: 'nice 10/5/2009 03:15'! 357686findLastOccurrenceOfString: subString startingAt: start 357687 "Answer the index of the last occurrence of subString within the receiver, starting at start. If 357688 the receiver does not contain subString, answer 0. Case-sensitive match used." 357689 357690 | last now | 357691 last := self findString: subString startingAt: start. 357692 last = 0 ifTrue: [^ 0]. 357693 [last > 0] whileTrue: 357694 [now := last. 357695 last := self findString: subString startingAt: last + 1]. 357696 357697 ^ now 357698! ! 357699 357700!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357701findString: subString 357702 "Answer the index of subString within the receiver, starting at start. If 357703 the receiver does not contain subString, answer 0." 357704 ^self findString: subString startingAt: 1.! ! 357705 357706!String methodsFor: 'accessing' stamp: 'nice 7/27/2007 23:34'! 357707findString: subString startingAt: start 357708 "Answer the index of subString within the receiver, starting at start. If 357709 the receiver does not contain subString, answer 0." 357710 357711 ^self findString: subString startingAt: start caseSensitive: true! ! 357712 357713!String methodsFor: 'accessing' stamp: 'nice 7/27/2007 23:33'! 357714findString: key startingAt: start caseSensitive: caseSensitive 357715 "Answer the index in this String at which the substring key first occurs, 357716 at or beyond start. The match can be case-sensitive or not. If no match 357717 is found, zero will be returned." 357718 357719 "IMPLEMENTATION NOTE: do not use CaseSensitiveOrder because it is broken for WideString 357720 This is a temporary work around until Wide CaseSensitiveOrder search is fixed 357721 Code should revert to: 357722 caseSensitive 357723 ifTrue: [^ self findSubstring: key in: self startingAt: start matchTable: CaseSensitiveOrder] 357724 ifFalse: [^ self findSubstring: key in: self startingAt: start matchTable: CaseInsensitiveOrder]" 357725 357726 ^caseSensitive 357727 ifTrue: [ 357728 (self class isBytes and: [key class isBytes]) 357729 ifTrue: [self 357730 findSubstring: key 357731 in: self 357732 startingAt: start 357733 matchTable: CaseSensitiveOrder] 357734 ifFalse: [WideString new 357735 findSubstring: key 357736 in: self 357737 startingAt: start 357738 matchTable: nil]] 357739 ifFalse: [ 357740 (self class isBytes and: [key class isBytes]) 357741 ifTrue: [self 357742 findSubstring: key 357743 in: self 357744 startingAt: start 357745 matchTable: CaseInsensitiveOrder] 357746 ifFalse: [WideString new 357747 findSubstring: key 357748 in: self 357749 startingAt: start 357750 matchTable: CaseInsensitiveOrder]]! ! 357751 357752!String methodsFor: 'accessing' stamp: 'ar 4/10/2005 17:13'! 357753findTokens: delimiters 357754 "Answer the collection of tokens that result from parsing self. Return strings between the delimiters. Any character in the Collection delimiters marks a border. Several delimiters in a row are considered as just one separation. Also, allow delimiters to be a single character." 357755 357756 | tokens keyStart keyStop separators | 357757 357758 tokens := OrderedCollection new. 357759 separators := delimiters isCharacter 357760 ifTrue: [Array with: delimiters] 357761 ifFalse: [delimiters]. 357762 keyStop := 1. 357763 [keyStop <= self size] whileTrue: 357764 [keyStart := self skipDelimiters: separators startingAt: keyStop. 357765 keyStop := self findDelimiters: separators startingAt: keyStart. 357766 keyStart < keyStop 357767 ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]]. 357768 ^tokens! ! 357769 357770!String methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 11:29'! 357771findTokens: delimiters escapedBy: quoteDelimiters 357772 "Answer a collection of Strings separated by the delimiters, where 357773 delimiters is a Character or collection of characters. Two delimiters in a 357774 row produce an empty string (compare this to #findTokens, which 357775 treats sequential delimiters as one). 357776 357777 The characters in quoteDelimiters are treated as quote characters, such 357778 that any delimiter within a pair of matching quoteDelimiter characters 357779 is treated literally, rather than as a delimiter. 357780 357781 The quoteDelimiter characters may be escaped within a quoted string. 357782 Two sequential quote characters within a quoted string are treated as 357783 a single character. 357784 357785 This method is useful for parsing comma separated variable strings for 357786 spreadsheet import and export." 357787 | tokens rs activeEscapeCharacter ts char token delimiterChars quoteChars | 357788 delimiterChars := (delimiters isNil 357789 ifTrue: [ '' ] 357790 ifFalse: [ delimiters ]) asString. 357791 quoteChars := (quoteDelimiters isNil 357792 ifTrue: [ '' ] 357793 ifFalse: [ quoteDelimiters ]) asString. 357794 tokens := OrderedCollection new. 357795 rs := self readStream. 357796 activeEscapeCharacter := nil. 357797 ts := String new writeStream. 357798 [ rs atEnd ] whileFalse: 357799 [ char := rs next. 357800 activeEscapeCharacter isNil 357801 ifTrue: 357802 [ (quoteChars includes: char) 357803 ifTrue: [ activeEscapeCharacter := char ] 357804 ifFalse: 357805 [ (delimiterChars includes: char) 357806 ifTrue: 357807 [ token := ts contents. 357808 tokens add: token. 357809 ts := String new writeStream ] 357810 ifFalse: [ ts nextPut: char ] ] ] 357811 ifFalse: 357812 [ char == activeEscapeCharacter 357813 ifTrue: 357814 [ rs peek == activeEscapeCharacter 357815 ifTrue: [ ts nextPut: rs next ] 357816 ifFalse: [ activeEscapeCharacter := nil ] ] 357817 ifFalse: [ ts nextPut: char ] ] ]. 357818 token := ts contents. 357819 (tokens isEmpty and: [ token isEmpty ]) ifFalse: [ tokens add: token ]. 357820 ^ tokens! ! 357821 357822!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357823findTokens: delimiters includes: subString 357824 "Divide self into pieces using delimiters. Return the piece that includes subString anywhere in it. Is case sensitive (say asLowercase to everything beforehand to make insensitive)." 357825 357826^ (self findTokens: delimiters) 357827 detect: [:str | (str includesSubString: subString)] 357828 ifNone: [nil]! ! 357829 357830!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357831findTokens: delimiters keep: keepers 357832 "Answer the collection of tokens that result from parsing self. The tokens are seperated by delimiters, any of a string of characters. If a delimiter is also in keepers, make a token for it. (Very useful for carriage return. A sole return ends a line, but is also saved as a token so you can see where the line breaks were.)" 357833 357834 | tokens keyStart keyStop | 357835 tokens := OrderedCollection new. 357836 keyStop := 1. 357837 [keyStop <= self size] whileTrue: 357838 [keyStart := self skipDelimiters: delimiters startingAt: keyStop. 357839 keyStop to: keyStart-1 do: [:ii | 357840 (keepers includes: (self at: ii)) ifTrue: [ 357841 tokens add: (self copyFrom: ii to: ii)]]. "Make this keeper be a token" 357842 keyStop := self findDelimiters: delimiters startingAt: keyStart. 357843 keyStart < keyStop 357844 ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]]. 357845 ^tokens! ! 357846 357847!String methodsFor: 'accessing' stamp: 'nice 7/27/2007 23:13'! 357848findWordStart: key startingAt: start 357849 | ind | 357850 "HyperCard style searching. Answer the index in self of the substring key, when that key is preceeded by a separator character. Must occur at or beyond start. The match is case-insensitive. If no match is found, zero will be returned." 357851 357852 ind := start. 357853 [ind := self findString: key startingAt: ind caseSensitive: false. 357854 ind = 0 ifTrue: [^ 0]. "not found" 357855 ind = 1 ifTrue: [^ 1]. "First char is the start of a word" 357856 (self at: ind-1) isSeparator] whileFalse: [ind := ind + 1]. 357857 ^ ind "is a word start"! ! 357858 357859!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357860includesSubString: subString 357861 ^ (self findString: subString startingAt: 1) > 0! ! 357862 357863!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357864includesSubstring: aString caseSensitive: caseSensitive 357865 357866 ^ (self findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0! ! 357867 357868!String methodsFor: 'accessing' stamp: 'yo 8/28/2002 16:45'! 357869indexOf: aCharacter 357870 357871 aCharacter isCharacter ifFalse: [^ 0]. 357872 ^ self class 357873 indexOfAscii: aCharacter asciiValue 357874 inString: self 357875 startingAt: 1. 357876! ! 357877 357878!String methodsFor: 'accessing' stamp: 'ar 4/12/2005 16:31'! 357879indexOf: aCharacter startingAt: start 357880 357881 (aCharacter isCharacter) ifFalse: [^ 0]. 357882 ^ self class indexOfAscii: aCharacter asciiValue inString: self startingAt: start! ! 357883 357884!String methodsFor: 'accessing' stamp: 'ar 4/12/2005 16:31'! 357885indexOf: aCharacter startingAt: start ifAbsent: aBlock 357886 | ans | 357887 (aCharacter isCharacter) ifFalse: [ ^ aBlock value ]. 357888 ans := self class indexOfAscii: aCharacter asciiValue inString: self startingAt: start. 357889 ans = 0 357890 ifTrue: [ ^ aBlock value ] 357891 ifFalse: [ ^ ans ]! ! 357892 357893!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357894indexOfAnyOf: aCharacterSet 357895 "returns the index of the first character in the given set. Returns 0 if none are found" 357896 ^self indexOfAnyOf: aCharacterSet startingAt: 1! ! 357897 357898!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357899indexOfAnyOf: aCharacterSet ifAbsent: aBlock 357900 "returns the index of the first character in the given set. Returns the evaluation of aBlock if none are found" 357901 ^self indexOfAnyOf: aCharacterSet startingAt: 1 ifAbsent: aBlock! ! 357902 357903!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357904indexOfAnyOf: aCharacterSet startingAt: start 357905 "returns the index of the first character in the given set, starting from start. Returns 0 if none are found" 357906 ^self indexOfAnyOf: aCharacterSet startingAt: start ifAbsent: [ 0 ]! ! 357907 357908!String methodsFor: 'accessing' stamp: 'nice 3/15/2007 21:03'! 357909indexOfAnyOf: aCharacterSet startingAt: start ifAbsent: aBlock 357910 "returns the index of the first character in the given set, starting from start " 357911 357912 | ans | 357913 ans := self isWideString 357914 ifTrue: ["Fallback to naive implementation" 357915 self class 357916 findFirstInString: self 357917 inCharacterSet: aCharacterSet 357918 startingAt: start] 357919 ifFalse: ["We know we contain only byte characters 357920 So use a byteArrayMap opimized for primitive call" 357921 self class 357922 findFirstInString: self 357923 inSet: aCharacterSet byteArrayMap 357924 startingAt: start]. 357925 ans = 0 357926 ifTrue: [^ aBlock value] 357927 ifFalse: [^ ans]! ! 357928 357929!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357930indexOfSubCollection: sub 357931 #Collectn. 357932 "Added 2000/04/08 For ANSI <sequenceReadableCollection> protocol." 357933 ^ self 357934 indexOfSubCollection: sub 357935 startingAt: 1 357936 ifAbsent: [0]! ! 357937 357938!String methodsFor: 'accessing' stamp: 'nice 7/27/2007 22:58'! 357939indexOfSubCollection: sub startingAt: start ifAbsent: exceptionBlock 357940 | index | 357941 index := self findString: sub startingAt: start. 357942 index = 0 ifTrue: [^ exceptionBlock value]. 357943 ^ index! ! 357944 357945!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 357946lastIndexOfPKSignature: aSignature 357947 "Answer the last index in me where aSignature (4 bytes long) occurs, or 0 if not found" 357948 | a b c d | 357949 a := aSignature first. 357950 b := aSignature second. 357951 c := aSignature third. 357952 d := aSignature fourth. 357953 (self size - 3) to: 1 by: -1 do: [ :i | 357954 (((self at: i) = a) 357955 and: [ ((self at: i + 1) = b) 357956 and: [ ((self at: i + 2) = c) 357957 and: [ ((self at: i + 3) = d) ]]]) 357958 ifTrue: [ ^i ] 357959 ]. 357960 ^0! ! 357961 357962!String methodsFor: 'accessing' stamp: 'yo 12/17/2002 16:56'! 357963leadingCharRunLengthAt: index 357964 357965 | leadingChar | 357966 leadingChar := (self at: index) leadingChar. 357967 index to: self size do: [:i | 357968 (self at: i) leadingChar ~= leadingChar ifTrue: [^ i - index]. 357969 ]. 357970 ^ self size - index + 1. 357971! ! 357972 357973!String methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:33'! 357974lineCorrespondingToIndex: anIndex 357975 "Answer a string containing the line at the given character position. 1/15/96 sw: Inefficient first stab at this" 357976 357977 | cr aChar answer | 357978 cr := Character cr. 357979 answer := ''. 357980 1 to: self size do: 357981 [:i | 357982 aChar := self at: i. 357983 aChar = cr 357984 ifTrue: 357985 [i > anIndex 357986 ifTrue: 357987 [^ answer] 357988 ifFalse: 357989 [answer := '']] 357990 ifFalse: 357991 [answer := answer copyWith: aChar]]. 357992 ^ answer! ! 357993 357994!String methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:34'! 357995lineCount 357996 "Answer the number of lines represented by the receiver, where every cr adds one line. 5/10/96 sw" 357997 357998 | cr count | 357999 cr := Character cr. 358000 count := 1 min: self size.. 358001 1 to: self size do: 358002 [:i | (self at: i) = cr ifTrue: [count := count + 1]]. 358003 ^ count 358004 358005" 358006'Fred 358007the 358008Bear' lineCount 358009"! ! 358010 358011!String methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:34'! 358012lineNumber: anIndex 358013 "Answer a string containing the characters in the given line number. 5/10/96 sw" 358014 358015 | crString pos finalPos | 358016 crString := String with: Character cr. 358017 pos := 0. 358018 1 to: anIndex - 1 do: 358019 [:i | pos := self findString: crString startingAt: pos + 1. 358020 pos = 0 ifTrue: [^ nil]]. 358021 finalPos := self findString: crString startingAt: pos + 1. 358022 finalPos = 0 ifTrue: [finalPos := self size + 1]. 358023 ^ self copyFrom: pos + 1 to: finalPos - 1 358024 358025" 358026'Fred 358027the 358028Bear' lineNumber: 3 358029"! ! 358030 358031!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 358032linesDo: aBlock 358033 "execute aBlock with each line in this string. The terminating CR's are not included in what is passed to aBlock" 358034 | start end | 358035 start := 1. 358036 [ start <= self size ] whileTrue: [ 358037 end := self indexOf: Character cr startingAt: start ifAbsent: [ self size + 1 ]. 358038 end := end - 1. 358039 358040 aBlock value: (self copyFrom: start to: end). 358041 start := end + 2. ].! ! 358042 358043!String methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:28'! 358044skipAnySubStr: delimiters startingAt: start 358045 "Answer the index of the last character within the receiver, starting at start, that does NOT match one of the delimiters. delimiters is a Array of substrings (Characters also allowed). If the receiver is all delimiters, answer size + 1." 358046 358047 | any this ind ii | 358048 ii := start-1. 358049 [(ii := ii + 1) <= self size] whileTrue: [ "look for char that does not match" 358050 any := false. 358051 delimiters do: [:delim | 358052 delim isCharacter 358053 ifTrue: [(self at: ii) == delim ifTrue: [any := true]] 358054 ifFalse: ["a substring" 358055 delim size > (self size - ii + 1) ifFalse: "Here's where the one-off error was." 358056 [ind := 0. 358057 this := true. 358058 delim do: [:dd | 358059 dd == (self at: ii+ind) ifFalse: [this := false]. 358060 ind := ind + 1]. 358061 this ifTrue: [ii := ii + delim size - 1. any := true]] 358062 ifTrue: [any := false] "if the delim is too big, it can't match"]]. 358063 any ifFalse: [^ ii]]. 358064 ^ self size + 1! ! 358065 358066!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 358067skipDelimiters: delimiters startingAt: start 358068 "Answer the index of the character within the receiver, starting at start, that does NOT match one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1. Assumes the delimiters to be a non-empty string." 358069 358070 start to: self size do: [:i | 358071 delimiters detect: [:delim | delim = (self at: i)] 358072 ifNone: [^ i]]. 358073 ^ self size + 1! ! 358074 358075!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 358076startsWithDigit 358077 "Answer whether the receiver's first character represents a digit" 358078 358079 ^ self size > 0 and: [self first isDigit]! ! 358080 358081!String methodsFor: 'accessing' stamp: 'md 5/26/2005 13:35'! 358082string 358083 ^self! ! 358084 358085!String methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! 358086tabDelimitedFieldsDo: aBlock 358087 "Considering the receiver as a holder of tab-delimited fields, evaluate execute aBlock with each field in this string. The separatilng tabs are not included in what is passed to aBlock" 358088 358089 | start end | 358090 "No senders but was useful enough in earlier work that it's retained for the moment." 358091 start := 1. 358092 [start <= self size] whileTrue: 358093 [end := self indexOf: Character tab startingAt: start ifAbsent: [self size + 1]. 358094 end := end - 1. 358095 aBlock value: (self copyFrom: start to: end). 358096 start := end + 2] 358097 358098" 358099'fred charlie elmo 2' tabDelimitedFieldsDo: [:aField | Transcript cr; show: aField] 358100"! ! 358101 358102 358103!String methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! 358104* arg 358105 358106 ^ arg adaptToString: self andSend: #*! ! 358107 358108!String methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! 358109+ arg 358110 358111 ^ arg adaptToString: self andSend: #+! ! 358112 358113!String methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! 358114- arg 358115 358116 ^ arg adaptToString: self andSend: #-! ! 358117 358118!String methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! 358119/ arg 358120 358121 ^ arg adaptToString: self andSend: #/! ! 358122 358123!String methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! 358124// arg 358125 358126 ^ arg adaptToString: self andSend: #//! ! 358127 358128!String methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! 358129\\ arg 358130 358131 ^ arg adaptToString: self andSend: #\\! ! 358132 358133 358134!String methodsFor: 'comparing' stamp: 'lr 7/7/2006 11:19'! 358135< aString 358136 "Answer whether the receiver sorts before aString. 358137 The collation order is simple ascii (with case differences)." 358138 358139 ^ (self compare: self with: aString collated: AsciiOrder) = 1! ! 358140 358141!String methodsFor: 'comparing' stamp: 'lr 7/7/2006 11:20'! 358142<= aString 358143 "Answer whether the receiver sorts before or equal to aString. 358144 The collation order is simple ascii (with case differences)." 358145 358146 ^ (self compare: self with: aString collated: AsciiOrder) <= 2! ! 358147 358148!String methodsFor: 'comparing' stamp: 'lr 7/7/2006 11:21'! 358149= aString 358150 "Answer whether the receiver sorts equally as aString. 358151 The collation order is simple ascii (with case differences)." 358152 358153 aString isString ifFalse: [ ^ false ]. 358154 ^ (self compare: self with: aString collated: AsciiOrder) = 2! ! 358155 358156!String methodsFor: 'comparing' stamp: 'lr 7/7/2006 11:21'! 358157> aString 358158 "Answer whether the receiver sorts after aString. 358159 The collation order is simple ascii (with case differences)." 358160 358161 ^ (self compare: self with: aString collated: AsciiOrder) = 3! ! 358162 358163!String methodsFor: 'comparing' stamp: 'lr 7/7/2006 11:21'! 358164>= aString 358165 "Answer whether the receiver sorts after or equal to aString. 358166 The collation order is simple ascii (with case differences)." 358167 358168 ^ (self compare: self with: aString collated: AsciiOrder) >= 2! ! 358169 358170!String methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! 358171alike: aString 358172 "Answer some indication of how alike the receiver is to the argument, 0 is no match, twice aString size is best score. Case is ignored." 358173 358174 | i j k minSize bonus | 358175 minSize := (j := self size) min: (k := aString size). 358176 bonus := (j - k) abs < 2 ifTrue: [ 1 ] ifFalse: [ 0 ]. 358177 i := 1. 358178 [(i <= minSize) and: [((super at: i) bitAnd: 16rDF) = ((aString at: i) asciiValue bitAnd: 16rDF)]] 358179 whileTrue: [ i := i + 1 ]. 358180 [(j > 0) and: [(k > 0) and: 358181 [((super at: j) bitAnd: 16rDF) = ((aString at: k) asciiValue bitAnd: 16rDF)]]] 358182 whileTrue: [ j := j - 1. k := k - 1. ]. 358183 ^ i - 1 + self size - j + bonus. ! ! 358184 358185!String methodsFor: 'comparing' stamp: 'ar 4/10/2005 16:39'! 358186caseInsensitiveLessOrEqual: aString 358187 "Answer whether the receiver sorts before or equal to aString. 358188 The collation order is case insensitive." 358189 ^(self compare: aString caseSensitive: false) <= 2! ! 358190 358191!String methodsFor: 'comparing' stamp: 'ar 4/10/2005 16:39'! 358192caseSensitiveLessOrEqual: aString 358193 "Answer whether the receiver sorts before or equal to aString. 358194 The collation order is case sensitive." 358195 ^(self compare: aString caseSensitive: true) <= 2! ! 358196 358197!String methodsFor: 'comparing' stamp: 'yo 8/27/2002 14:15'! 358198charactersExactlyMatching: aString 358199 "Do a character-by-character comparison between the receiver and aString. Return the index of the final character that matched exactly." 358200 358201 | count | 358202 count := self size min: aString size. 358203 1 to: count do: [:i | 358204 (self at: i) = (aString at: i) ifFalse: [ 358205 ^ i - 1]]. 358206 ^ count! ! 358207 358208!String methodsFor: 'comparing' stamp: 'ar 4/10/2005 16:38'! 358209compare: aString 358210 "Answer a comparison code telling how the receiver sorts relative to aString: 358211 1 - before 358212 2 - equal 358213 3 - after. 358214 The collation sequence is ascii with case differences ignored. 358215 To get the effect of a <= b, but ignoring case, use (a compare: b) <= 2." 358216 ^self compare: aString caseSensitive: false! ! 358217 358218!String methodsFor: 'comparing' stamp: 'ar 4/10/2005 16:42'! 358219compare: aString caseSensitive: aBool 358220 "Answer a comparison code telling how the receiver sorts relative to aString: 358221 1 - before 358222 2 - equal 358223 3 - after. 358224 " 358225 | map | 358226 map := aBool ifTrue:[CaseSensitiveOrder] ifFalse:[CaseInsensitiveOrder]. 358227 ^self compare: self with: aString collated: map! ! 358228 358229!String methodsFor: 'comparing' stamp: 'yo 12/15/2005 14:28'! 358230compare: string1 with: string2 collated: order 358231 358232 (string1 isByteString and: [string2 isByteString]) ifTrue: [ 358233 ^ ByteString compare: string1 with: string2 collated: order 358234 ]. 358235 "Primitive does not fail properly right now" 358236 ^ String compare: string1 with: string2 collated: order 358237 358238" 358239self assert: 'abc' = 'abc' asWideString. 358240self assert: 'abc' asWideString = 'abc'. 358241self assert: ((ByteArray with: 97 with: 0 with: 0 with: 0) asString ~= 'a000' asWideString). 358242self assert: ('a000' asWideString ~= (ByteArray with: 97 with: 0 with: 0 with: 0) asString). 358243 358244self assert: ('abc' sameAs: 'aBc' asWideString). 358245self assert: ('aBc' asWideString sameAs: 'abc'). 358246self assert: ((ByteArray with: 97 with: 0 with: 0 with: 0) asString sameAs: 'Abcd' asWideString) not. 358247self assert: ('a000' asWideString sameAs: (ByteArray with: 97 with: 0 with: 0 with: 0) asString) not. 358248 358249"! ! 358250 358251!String methodsFor: 'comparing' stamp: 'ar 4/10/2005 17:27'! 358252crc16 358253 "Compute a 16 bit cyclic redundancy check." 358254 358255 | crc | 358256 crc := 0. 358257 1 to: self byteSize do: [:i | 358258 crc := (crc bitShift: -8) bitXor: ( 358259 #( 16r0000 16rC0C1 16rC181 16r0140 16rC301 16r03C0 16r0280 16rC241 358260 16rC601 16r06C0 16r0780 16rC741 16r0500 16rC5C1 16rC481 16r0440 358261 16rCC01 16r0CC0 16r0D80 16rCD41 16r0F00 16rCFC1 16rCE81 16r0E40 358262 16r0A00 16rCAC1 16rCB81 16r0B40 16rC901 16r09C0 16r0880 16rC841 358263 16rD801 16r18C0 16r1980 16rD941 16r1B00 16rDBC1 16rDA81 16r1A40 358264 16r1E00 16rDEC1 16rDF81 16r1F40 16rDD01 16r1DC0 16r1C80 16rDC41 358265 16r1400 16rD4C1 16rD581 16r1540 16rD701 16r17C0 16r1680 16rD641 358266 16rD201 16r12C0 16r1380 16rD341 16r1100 16rD1C1 16rD081 16r1040 358267 16rF001 16r30C0 16r3180 16rF141 16r3300 16rF3C1 16rF281 16r3240 358268 16r3600 16rF6C1 16rF781 16r3740 16rF501 16r35C0 16r3480 16rF441 358269 16r3C00 16rFCC1 16rFD81 16r3D40 16rFF01 16r3FC0 16r3E80 16rFE41 358270 16rFA01 16r3AC0 16r3B80 16rFB41 16r3900 16rF9C1 16rF881 16r3840 358271 16r2800 16rE8C1 16rE981 16r2940 16rEB01 16r2BC0 16r2A80 16rEA41 358272 16rEE01 16r2EC0 16r2F80 16rEF41 16r2D00 16rEDC1 16rEC81 16r2C40 358273 16rE401 16r24C0 16r2580 16rE541 16r2700 16rE7C1 16rE681 16r2640 358274 16r2200 16rE2C1 16rE381 16r2340 16rE101 16r21C0 16r2080 16rE041 358275 16rA001 16r60C0 16r6180 16rA141 16r6300 16rA3C1 16rA281 16r6240 358276 16r6600 16rA6C1 16rA781 16r6740 16rA501 16r65C0 16r6480 16rA441 358277 16r6C00 16rACC1 16rAD81 16r6D40 16rAF01 16r6FC0 16r6E80 16rAE41 358278 16rAA01 16r6AC0 16r6B80 16rAB41 16r6900 16rA9C1 16rA881 16r6840 358279 16r7800 16rB8C1 16rB981 16r7940 16rBB01 16r7BC0 16r7A80 16rBA41 358280 16rBE01 16r7EC0 16r7F80 16rBF41 16r7D00 16rBDC1 16rBC81 16r7C40 358281 16rB401 16r74C0 16r7580 16rB541 16r7700 16rB7C1 16rB681 16r7640 358282 16r7200 16rB2C1 16rB381 16r7340 16rB101 16r71C0 16r7080 16rB041 358283 16r5000 16r90C1 16r9181 16r5140 16r9301 16r53C0 16r5280 16r9241 358284 16r9601 16r56C0 16r5780 16r9741 16r5500 16r95C1 16r9481 16r5440 358285 16r9C01 16r5CC0 16r5D80 16r9D41 16r5F00 16r9FC1 16r9E81 16r5E40 358286 16r5A00 16r9AC1 16r9B81 16r5B40 16r9901 16r59C0 16r5880 16r9841 358287 16r8801 16r48C0 16r4980 16r8941 16r4B00 16r8BC1 16r8A81 16r4A40 358288 16r4E00 16r8EC1 16r8F81 16r4F40 16r8D01 16r4DC0 16r4C80 16r8C41 358289 16r4400 16r84C1 16r8581 16r4540 16r8701 16r47C0 16r4680 16r8641 358290 16r8201 16r42C0 16r4380 16r8341 16r4100 16r81C1 16r8081 16r4040) 358291 at: ((crc bitXor: (self byteAt: i)) bitAnd: 16rFF) + 1) ]. 358292 ^crc! ! 358293 358294!String methodsFor: 'comparing' stamp: 'nice 7/27/2007 22:55'! 358295endsWith: suffix 358296 "Answer whether the tail end of the receiver is the same as suffix. 358297 The comparison is case-sensitive." 358298 358299 | extra | 358300 (extra := self size - suffix size) < 0 ifTrue: [^ false]. 358301 ^ (self findString: suffix startingAt: extra + 1) > 0 358302" 358303 'Elvis' endsWith: 'vis' 358304"! ! 358305 358306!String methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! 358307endsWithAnyOf: aCollection 358308 aCollection do:[:suffix| 358309 (self endsWith: suffix) ifTrue:[^true]. 358310 ]. 358311 ^false! ! 358312 358313!String methodsFor: 'comparing' stamp: 'md 5/11/2008 12:08'! 358314hash 358315 "#hash is implemented, because #= is implemented" 358316 "ar 4/10/2005: I had to change this to use ByteString hash as initial 358317 hash in order to avoid having to rehash everything and yet compute 358318 the same hash for ByteString and WideString." 358319 ^ self class stringHash: self initialHash: ByteString hash! ! 358320 358321!String methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! 358322howManyMatch: string 358323 "Count the number of characters that match up in self and aString." 358324 | count shorterLength | 358325 358326 count := 0 . 358327 shorterLength := ((self size ) min: (string size ) ) . 358328 (1 to: shorterLength do: [:index | 358329 (((self at: index ) = (string at: index ) ) ifTrue: [count := (count + 1 ) . 358330 ] ). 358331 ] ). 358332 ^ count 358333 358334 ! ! 358335 358336!String methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! 358337match: text 358338 "Answer whether text matches the pattern in this string. 358339 Matching ignores upper/lower case differences. 358340 Where this string contains #, text may contain any character. 358341 Where this string contains *, text may contain any sequence of characters." 358342 358343 ^ self startingAt: 1 match: text startingAt: 1 358344" 358345 '*' match: 'zort' true 358346 '*baz' match: 'mobaz' true 358347 '*baz' match: 'mobazo' false 358348 '*baz*' match: 'mobazo' true 358349 '*baz*' match: 'mozo' false 358350 'foo*' match: 'foozo' true 358351 'foo*' match: 'bozo' false 358352 'foo*baz' match: 'foo23baz' true 358353 'foo*baz' match: 'foobaz' true 358354 'foo*baz' match: 'foo23bazo' false 358355 'foo' match: 'Foo' true 358356 'foo*baz*zort' match: 'foobazort' false 358357 'foo*baz*zort' match: 'foobazzort' false 358358 '*foo#zort' match: 'afoo3zortthenfoo3zort' true 358359 '*foo*zort' match: 'afoodezortorfoo3zort' true 358360"! ! 358361 358362!String methodsFor: 'comparing' stamp: 'ar 4/10/2005 17:35'! 358363sameAs: aString 358364 "Answer whether the receiver sorts equal to aString. The 358365 collation sequence is ascii with case differences ignored." 358366 ^(self compare: aString caseSensitive: false) = 2! ! 358367 358368!String methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! 358369startingAt: keyStart match: text startingAt: textStart 358370 "Answer whether text matches the pattern in this string. 358371 Matching ignores upper/lower case differences. 358372 Where this string contains #, text may contain any character. 358373 Where this string contains *, text may contain any sequence of characters." 358374 | anyMatch matchStart matchEnd i matchStr j ii jj | 358375 i := keyStart. 358376 j := textStart. 358377 358378 "Check for any #'s" 358379 [i > self size ifTrue: [^ j > text size "Empty key matches only empty string"]. 358380 (self at: i) = $#] whileTrue: 358381 ["# consumes one char of key and one char of text" 358382 j > text size ifTrue: [^ false "no more text"]. 358383 i := i+1. j := j+1]. 358384 358385 "Then check for *" 358386 (self at: i) = $* 358387 ifTrue: [i = self size ifTrue: 358388 [^ true "Terminal * matches all"]. 358389 "* means next match string can occur anywhere" 358390 anyMatch := true. 358391 matchStart := i + 1] 358392 ifFalse: ["Otherwise match string must occur immediately" 358393 anyMatch := false. 358394 matchStart := i]. 358395 358396 "Now determine the match string" 358397 matchEnd := self size. 358398 (ii := self indexOf: $* startingAt: matchStart) > 0 ifTrue: 358399 [ii = 1 ifTrue: [self error: '** not valid -- use * instead']. 358400 matchEnd := ii-1]. 358401 (ii := self indexOf: $# startingAt: matchStart) > 0 ifTrue: 358402 [ii = 1 ifTrue: [self error: '*# not valid -- use #* instead']. 358403 matchEnd := matchEnd min: ii-1]. 358404 matchStr := self copyFrom: matchStart to: matchEnd. 358405 358406 "Now look for the match string" 358407 [jj := text findString: matchStr startingAt: j caseSensitive: false. 358408 anyMatch ifTrue: [jj > 0] ifFalse: [jj = j]] 358409 whileTrue: 358410 ["Found matchStr at jj. See if the rest matches..." 358411 (self startingAt: matchEnd+1 match: text startingAt: jj + matchStr size) ifTrue: 358412 [^ true "the rest matches -- success"]. 358413 "The rest did not match." 358414 anyMatch ifFalse: [^ false]. 358415 "Preceded by * -- try for a later match" 358416 j := j+1]. 358417 ^ false "Failed to find the match string"! ! 358418 358419 358420!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358421adaptToCollection: rcvr andSend: selector 358422 "If I am involved in arithmetic with a collection, convert me to a number." 358423 358424 ^ rcvr perform: selector with: self asNumber! ! 358425 358426!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358427adaptToNumber: rcvr andSend: selector 358428 "If I am involved in arithmetic with a number, convert me to a number." 358429 358430 ^ rcvr perform: selector with: self asNumber! ! 358431 358432!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358433adaptToPoint: rcvr andSend: selector 358434 "If I am involved in arithmetic with a point, convert me to a number." 358435 358436 ^ rcvr perform: selector with: self asNumber! ! 358437 358438!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358439adaptToString: rcvr andSend: selector 358440 "If I am involved in arithmetic with a string, convert us both to 358441 numbers, and return the printString of the result." 358442 358443 ^ (rcvr asNumber perform: selector with: self asNumber) printString! ! 358444 358445!String methodsFor: 'converting' stamp: 'PeterHugossonMiller 9/3/2009 11:26'! 358446asAlphaNumeric: totalSize extraChars: additionallyAllowed mergeUID: minimalSizeOfRandomPart 358447 "Generates a String with unique identifier ( UID ) qualities, the difference to a 358448 UUID is that its beginning is derived from the receiver, so that it has a meaning 358449 for a human reader. 358450 358451 Answers a String of totalSize, which consists of 3 parts 358452 1.part: the beginning of the receiver only consisting of 358453 a-z, A-Z, 0-9 and extraChars in Collection additionallyAllowed ( which can be nil ) 358454 2.part: a single _ 358455 3.part: a ( random ) UID of size >= minimalSizeOfRandomPart consisting of 358456 a-z, A-Z, 0-9 358457 358458 Starting letters are capitalized. 358459 TotalSize must be at least 1. 358460 Exactly 1 occurrence of $_ is guaranteed ( unless additionallyAllowed includes $_ ). 358461 The random part has even for small sizes good UID qualitites for many practical purposes. 358462 If only lower- or uppercase letters are demanded, simply convert the answer with 358463 say #asLowercase. The probability of a duplicate will rise only moderately ( see below ). 358464 358465 Example: 358466 size of random part = 10 358467 in n generated UIDs the chance p of having non-unique UIDs is 358468 n = 10000 -> p < 1e-10 if answer is reduced to lowerCase: p < 1.4 e-8 358469 n = 100000 -> p < 1e-8 358470 at the bottom is a snippet for your own calculations 358471 Note: the calculated propabilites are theoretical, 358472 for the actually used random generator they may be much worse" 358473 | stream out sizeOfFirstPart index ascii ch skip array random | 358474 totalSize > minimalSizeOfRandomPart ifFalse: [ self errorOutOfBounds ]. 358475 stream := self readStream. 358476 out := (String new: totalSize) writeStream. 358477 index := 0. 358478 skip := true. 358479 sizeOfFirstPart := totalSize - minimalSizeOfRandomPart - 1. 358480 [ stream atEnd or: [ index >= sizeOfFirstPart ] ] whileFalse: 358481 [ (((ascii := (ch := stream next) asciiValue) >= 65 and: [ ascii <= 90 ]) or: 358482 [ (ascii >= 97 and: [ ascii <= 122 ]) or: 358483 [ ch isDigit or: [ additionallyAllowed notNil and: [ additionallyAllowed includes: ch ] ] ] ]) 358484 ifTrue: 358485 [ skip 358486 ifTrue: [ out nextPut: ch asUppercase ] 358487 ifFalse: [ out nextPut: ch ]. 358488 index := index + 1. 358489 skip := false ] 358490 ifFalse: [ skip := true ] ]. 358491 out nextPut: $_. 358492 array := Array new: 62. 358493 1 358494 to: 26 358495 do: 358496 [ :i | 358497 array 358498 at: i 358499 put: (i + 64) asCharacter. 358500 array 358501 at: i + 26 358502 put: (i + 96) asCharacter ]. 358503 53 358504 to: 62 358505 do: 358506 [ :i | 358507 array 358508 at: i 358509 put: (i - 5) asCharacter ]. 358510 random := UUIDGenerator default randomGenerator. 358511 totalSize - index - 1 timesRepeat: [ out nextPut: (array atRandom: random) ]. 358512 ^ out contents 358513 358514 " calculation of probability p for failure of uniqueness in n UIDs 358515 Note: if answer will be converted to upper or lower case replace 62 with 36 358516 | n i p all | 358517 all := 62 raisedTo: sizeOfRandomPart. 358518 i := 1. 358519 p := 0.0 . 358520 n := 10000. 358521 [ i <= n ] 358522 whileTrue: [ 358523 p := p + (( i - 1 ) / all ). 358524 i := i + 1 ]. 358525 p 358526 358527 approximation formula: n squared / ( 62.0 raisedTo: sizeOfRandomPart ) / 2 358528 " 358529 358530 "'Crop SketchMorphs and Grab Screen Rect to JPG' 358531 asAlphaNumeric: 31 extraChars: nil mergeUID: 10 358532 'CropSketchMorphsAndG_iOw94jquN6' 358533 'Monticello' 358534 asAlphaNumeric: 31 extraChars: nil mergeUID: 10 358535 'Monticello_kp6aV2l0IZK9uBULGOeG' 358536 'version-', ( '1.1.2' replaceAll: $. with: $- ) 358537 asAlphaNumeric: 31 extraChars: #( $- ) mergeUID: 10 358538 'Version-1-1-2_kuz2tMg2xX9iRLDVR'"! ! 358539 358540!String methodsFor: 'converting' stamp: 'ar 4/10/2005 17:18'! 358541asByteArray 358542 "Convert to a ByteArray with the ascii values of the string." 358543 | b | 358544 b := ByteArray new: self byteSize. 358545 1 to: self size * 4 do: [:i | 358546 b at: i put: (self byteAt: i). 358547 ]. 358548 ^ b. 358549! ! 358550 358551!String methodsFor: 'converting' stamp: 'ar 4/10/2005 16:22'! 358552asByteString 358553 "Convert the receiver into a ByteString" 358554 ^self asOctetString! ! 358555 358556!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358557asDate 358558 "Many allowed forms, see Date>>#readFrom:" 358559 358560 ^ Date fromString: self! ! 358561 358562!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358563asDateAndTime 358564 358565 "Convert from UTC format" ^ DateAndTime fromString: self! ! 358566 358567!String methodsFor: 'converting' stamp: 'yo 10/22/2002 17:38'! 358568asDefaultDecodedString 358569 358570 ^ self 358571! ! 358572 358573!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358574asDisplayText 358575 "Answer a DisplayText whose text string is the receiver." 358576 358577 ^DisplayText text: self asText! ! 358578 358579!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358580asDuration 358581 "convert from [nnnd]hh:mm:ss[.nanos] format. [] implies optional elements" 358582 358583 ^ Duration fromString: self 358584 ! ! 358585 358586!String methodsFor: 'converting' stamp: 'ar 4/12/2005 13:55'! 358587asFileName 358588 "Answer a String made up from the receiver that is an acceptable file 358589 name." 358590 358591 | string checkedString | 358592 string := FileDirectory checkName: self fixErrors: true. 358593 checkedString := (FilePath pathName: string) asVmPathName. 358594 ^ (FilePath pathName: checkedString isEncoded: true) asSqueakPathName. 358595! ! 358596 358597!String methodsFor: 'converting' stamp: 'yo 8/27/2002 14:38'! 358598asFourCode 358599 358600 | result | 358601 self size = 4 ifFalse: [^self error: 'must be exactly four characters']. 358602 result := self inject: 0 into: [:val :each | 256 * val + each asciiValue]. 358603 (result bitAnd: 16r80000000) = 0 358604 ifFalse: [self error: 'cannot resolve fourcode']. 358605 (result bitAnd: 16r40000000) = 0 ifFalse: [^result - 16r80000000]. 358606 ^ result 358607! ! 358608 358609!String methodsFor: 'converting' stamp: 'PeterHugossonMiller 9/3/2009 11:26'! 358610asHex 358611 | stream | 358612 stream := (String new: self size * 4) writeStream. 358613 self do: [ :ch | stream nextPutAll: ch hex ]. 358614 ^stream contents! ! 358615 358616!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358617asIRCLowercase 358618 "Answer a String made up from the receiver whose characters are all 358619 lowercase, where 'lowercase' is by IRC's definition" 358620 358621 ^self collect: [ :c | c asIRCLowercase ]! ! 358622 358623!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358624asIdentifier: shouldBeCapitalized 358625 "Return a legal identifier, with first character in upper case if shouldBeCapitalized is true, else lower case. This will always return a legal identifier, even for an empty string" 358626 358627 | aString firstChar firstLetterPosition | 358628 aString := self select: [:el | el isAlphaNumeric]. 358629 firstLetterPosition := aString findFirst: [:ch | ch isLetter]. 358630 aString := firstLetterPosition == 0 358631 ifFalse: 358632 [aString copyFrom: firstLetterPosition to: aString size] 358633 ifTrue: 358634 ['a', aString]. 358635 firstChar := shouldBeCapitalized ifTrue: [aString first asUppercase] ifFalse: [aString first asLowercase]. 358636 358637 ^ firstChar asString, (aString copyFrom: 2 to: aString size) 358638" 358639'234Fred987' asIdentifier: false 358640'235Fred987' asIdentifier: true 358641'' asIdentifier: true 358642'()87234' asIdentifier: false 358643'())z>=PPve889 U >' asIdentifier: false 358644 358645"! ! 358646 358647!String methodsFor: 'converting' stamp: 'laza 10/1/2004 09:55'! 358648asInteger 358649 ^self asSignedInteger 358650! ! 358651 358652!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358653asLegalSelector 358654 | toUse | 358655 toUse := ''. 358656 self do: 358657 [:char | char isAlphaNumeric ifTrue: [toUse := toUse copyWith: char]]. 358658 (self size == 0 or: [self first isLetter not]) 358659 ifTrue: [toUse := 'v', toUse]. 358660 358661 ^ toUse withFirstCharacterDownshifted 358662 358663"'234znak 43 ) 2' asLegalSelector"! ! 358664 358665!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358666asLowercase 358667 "Answer a String made up from the receiver whose characters are all 358668 lowercase." 358669 358670 ^ self copy asString translateToLowercase! ! 358671 358672!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358673asNumber 358674 "Answer the Number created by interpreting the receiver as the string 358675 representation of a number." 358676 358677 ^Number readFromString: self! ! 358678 358679!String methodsFor: 'converting' stamp: 'ar 4/10/2005 20:55'! 358680asOctetString 358681 "Convert the receiver into an octet string" 358682 | string | 358683 string := String new: self size. 358684 1 to: self size do: [:i | string at: i put: (self at: i)]. 358685 ^string! ! 358686 358687!String methodsFor: 'converting' stamp: 'stephane.ducasse 3/31/2009 21:27'! 358688asPacked 358689 "Convert to a longinteger that describes the string" 358690 358691 ^ self inject: 0 into: [ :pack :next | pack * 256 + next asInteger ].! ! 358692 358693!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358694asParagraph 358695 "Answer a Paragraph whose text string is the receiver." 358696 358697 ^Paragraph withText: self asText! ! 358698 358699!String methodsFor: 'converting' stamp: 'dew 9/13/2001 01:17'! 358700asPluralBasedOn: aNumberOrCollection 358701 "Append an 's' to this string based on whether aNumberOrCollection is 1 or of size 1." 358702 358703 ^ (aNumberOrCollection = 1 or: 358704 [aNumberOrCollection isCollection and: [aNumberOrCollection size = 1]]) 358705 ifTrue: [self] 358706 ifFalse: [self, 's'] 358707! ! 358708 358709!String methodsFor: 'converting' stamp: 'marcus.denker 2/18/2009 16:15'! 358710asSignedInteger 358711 "Returns the first signed integer it can find or nil." 358712 358713 | start stream | 358714 start := self findFirst: [:char | char isDigit]. 358715 start isZero ifTrue: [^ nil]. 358716 stream := self readStream position: start - 1. 358717 ((stream position ~= 0) and: [stream peekBack = $-]) 358718 ifTrue: [stream back]. 358719 ^ Integer readFrom: stream! ! 358720 358721!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358722asSmalltalkComment 358723 "return this string, munged so that it can be treated as a comment in Smalltalk code. Quote marks are added to the beginning and end of the string, and whenever a solitary quote mark appears within the string, it is doubled" 358724 358725 ^String streamContents: [ :str | 358726 | quoteCount first | 358727 358728 str nextPut: $". 358729 358730 quoteCount := 0. 358731 first := true. 358732 self do: [ :char | 358733 char = $" 358734 ifTrue: [ 358735 first ifFalse: [ 358736 str nextPut: char. 358737 quoteCount := quoteCount + 1 ] ] 358738 ifFalse: [ 358739 quoteCount odd ifTrue: [ 358740 "add a quote to even the number of quotes in a row" 358741 str nextPut: $" ]. 358742 quoteCount := 0. 358743 str nextPut: char ]. 358744 first := false ]. 358745 358746 quoteCount odd ifTrue: [ 358747 "check at the end" 358748 str nextPut: $". ]. 358749 358750 str nextPut: $". 358751 ]. 358752 ! ! 358753 358754!String methodsFor: 'converting' stamp: 'yo 12/19/2003 21:16'! 358755asSqueakPathName 358756 358757 ^ self. 358758! ! 358759 358760!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358761asString 358762 "Answer this string." 358763 358764 ^ self 358765! ! 358766 358767!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358768asStringOrText 358769 "Answer this string." 358770 358771 ^ self 358772! ! 358773 358774!String methodsFor: 'converting' stamp: 'ar 4/10/2005 19:24'! 358775asSymbol 358776 "Answer the unique Symbol whose characters are the characters of the 358777 string." 358778 ^Symbol intern: self! ! 358779 358780!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358781asText 358782 "Answer a Text whose string is the receiver." 358783 358784 ^Text fromString: self! ! 358785 358786!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358787asTime 358788 "Many allowed forms, see Time>>readFrom:" 358789 358790 ^ Time fromString: self.! ! 358791 358792!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358793asTimeStamp 358794 "Convert from obsolete TimeStamp format" 358795 358796 ^ TimeStamp fromString: self! ! 358797 358798!String methodsFor: 'converting' stamp: 'damiencassou 5/30/2008 11:45'! 358799asUnsignedInteger 358800 "Returns the first integer it can find or nil." 358801 | start stream | 358802 start := self findFirst: [ :char | char isDigit ]. 358803 start isZero ifTrue: [ ^ nil ]. 358804 stream := self readStream position: start - 1. 358805 ^ Integer readFrom: stream! ! 358806 358807!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358808asUppercase 358809 "Answer a String made up from the receiver whose characters are all 358810 uppercase." 358811 358812 ^self copy asString translateToUppercase! ! 358813 358814!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358815asUrl 358816 "convert to a Url" 358817 "'http://www.cc.gatech.edu/' asUrl" 358818 "msw://chaos.resnet.gatech.edu:9000/' asUrl" 358819 ^Url absoluteFromText: self! ! 358820 358821!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358822asUrlRelativeTo: aUrl 358823 ^aUrl newFromRelativeText: self! ! 358824 358825!String methodsFor: 'converting' stamp: 'yo 2/24/2005 18:33'! 358826asVmPathName 358827 358828 ^ (FilePath pathName: self) asVmPathName. 358829! ! 358830 358831!String methodsFor: 'converting' stamp: 'ar 4/12/2005 17:36'! 358832asWideString 358833 self isWideString 358834 ifTrue:[^self] 358835 ifFalse:[^WideString from: self]! ! 358836 358837!String methodsFor: 'converting' stamp: 'ar 7/22/2009 22:00'! 358838base64Decoded 358839 "Decode the receiver from base 64" 358840 "'SGVsbG8gV29ybGQ=' base64Decoded" 358841 ^(Base64MimeConverter mimeDecode: self as: self class)! ! 358842 358843!String methodsFor: 'converting' stamp: 'StephaneDucasse 9/1/2009 15:50'! 358844base64Encoded 358845 "Encode the receiver as base64" 358846 "'Hello World' base64Encoded" 358847 ^(Base64MimeConverter mimeEncode: self readStream) contents! ! 358848 358849!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358850capitalized 358851 "Return a copy with the first letter capitalized" 358852 | cap | 358853 self isEmpty ifTrue: [ ^self copy ]. 358854 cap := self copy. 358855 cap at: 1 put: (cap at: 1) asUppercase. 358856 ^ cap! ! 358857 358858!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358859compressWithTable: tokens 358860 "Return a string with all substrings that occur in tokens replaced 358861 by a character with ascii code = 127 + token index. 358862 This will work best if tokens are sorted by size. 358863 Assumes this string contains no characters > 127, or that they 358864 are intentionally there and will not interfere with this process." 358865 | str null finalSize start result ri c ts | 358866 null := Character value: 0. 358867 str := self copyFrom: 1 to: self size. "Working string will get altered" 358868 finalSize := str size. 358869 tokens doWithIndex: 358870 [:token :tIndex | 358871 start := 1. 358872 [(start := str findString: token startingAt: start) > 0] 358873 whileTrue: 358874 [ts := token size. 358875 ((start + ts) <= str size 358876 and: [(str at: start + ts) = $ and: [tIndex*2 <= 128]]) 358877 ifTrue: [ts := token size + 1. "include training blank" 358878 str at: start put: (Character value: tIndex*2 + 127)] 358879 ifFalse: [str at: start put: (Character value: tIndex + 127)]. 358880 str at: start put: (Character value: tIndex + 127). 358881 1 to: ts-1 do: [:i | str at: start+i put: null]. 358882 finalSize := finalSize - (ts - 1). 358883 start := start + ts]]. 358884 result := String new: finalSize. 358885 ri := 0. 358886 1 to: str size do: 358887 [:i | (c := str at: i) = null ifFalse: [result at: (ri := ri+1) put: c]]. 358888 ^ result! ! 358889 358890!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358891contractTo: smallSize 358892 "return myself or a copy shortened by ellipsis to smallSize" 358893 | leftSize | 358894 self size <= smallSize 358895 ifTrue: [^ self]. "short enough" 358896 smallSize < 5 358897 ifTrue: [^ self copyFrom: 1 to: smallSize]. "First N characters" 358898 leftSize := smallSize-2//2. 358899 ^ self copyReplaceFrom: leftSize+1 "First N/2 ... last N/2" 358900 to: self size - (smallSize - leftSize - 3) 358901 with: '...' 358902" 358903 'A clear but rather long-winded summary' contractTo: 18 358904"! ! 358905 358906!String methodsFor: 'converting' stamp: 'KR 1/30/2006 21:47'! 358907convertFromEncoding: encodingName 358908 ^self convertFromWithConverter: (TextConverter newForEncoding: encodingName)! ! 358909 358910!String methodsFor: 'converting' stamp: 'KR 1/30/2006 21:47'! 358911convertFromSuperSwikiServerString 358912 ^self convertFromEncoding: 'shift_jis'! ! 358913 358914!String methodsFor: 'converting' stamp: 'yo 7/8/2004 12:02'! 358915convertFromWithConverter: converter 358916 358917 | readStream writeStream c | 358918 readStream := self readStream. 358919 writeStream := String new writeStream. 358920 converter ifNil: [^ self]. 358921 [readStream atEnd] whileFalse: [ 358922 c := converter nextFromStream: readStream. 358923 c ifNotNil: [writeStream nextPut: c] ifNil: [^ writeStream contents] 358924 ]. 358925 ^ writeStream contents 358926! ! 358927 358928!String methodsFor: 'converting' stamp: 'KR 1/30/2006 21:49'! 358929convertToEncoding: encodingName 358930 ^self convertToWithConverter: (TextConverter newForEncoding: encodingName).! ! 358931 358932!String methodsFor: 'converting' stamp: 'KR 1/30/2006 21:50'! 358933convertToSuperSwikiServerString 358934 ^self convertToEncoding: 'shift_jis'! ! 358935 358936!String methodsFor: 'converting' stamp: 'ar 4/12/2005 14:01'! 358937convertToSystemString 358938 358939 | readStream writeStream converter | 358940 readStream := self readStream. 358941 writeStream := String new writeStream. 358942 converter := LanguageEnvironment defaultSystemConverter. 358943 converter ifNil: [^ self]. 358944 [readStream atEnd] whileFalse: [ 358945 converter nextPut: readStream next toStream: writeStream 358946 ]. 358947 converter emitSequenceToResetStateIfNeededOn: writeStream. 358948 ^ writeStream contents. 358949! ! 358950 358951!String methodsFor: 'converting' stamp: 'yo 7/8/2004 12:01'! 358952convertToWithConverter: converter 358953 358954 | readStream writeStream | 358955 readStream := self readStream. 358956 writeStream := String new writeStream. 358957 converter ifNil: [^ self]. 358958 [readStream atEnd] whileFalse: [ 358959 converter nextPut: readStream next toStream: writeStream 358960 ]. 358961 converter emitSequenceToResetStateIfNeededOn: writeStream. 358962 ^ writeStream contents. 358963! ! 358964 358965!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358966correctAgainst: wordList 358967 "Correct the receiver: assume it is a misspelled word and return the (maximum of five) nearest words in the wordList. Depends on the scoring scheme of alike:" 358968 | results | 358969 results := self correctAgainst: wordList continuedFrom: nil. 358970 results := self correctAgainst: nil continuedFrom: results. 358971 ^ results! ! 358972 358973!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358974correctAgainst: wordList continuedFrom: oldCollection 358975 "Like correctAgainst:. Use when you want to correct against several lists, give nil as the first oldCollection, and nil as the last wordList." 358976 358977 ^ wordList isNil 358978 ifTrue: [ self correctAgainstEnumerator: nil 358979 continuedFrom: oldCollection ] 358980 ifFalse: [ self correctAgainstEnumerator: [ :action | wordList do: action without: nil] 358981 continuedFrom: oldCollection ]! ! 358982 358983!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 358984correctAgainstDictionary: wordDict continuedFrom: oldCollection 358985 "Like correctAgainst:continuedFrom:. Use when you want to correct against a dictionary." 358986 358987 ^ wordDict isNil 358988 ifTrue: [ self correctAgainstEnumerator: nil 358989 continuedFrom: oldCollection ] 358990 ifFalse: [ self correctAgainstEnumerator: [ :action | wordDict keysDo: action ] 358991 continuedFrom: oldCollection ]! ! 358992 358993!String methodsFor: 'converting' stamp: 'yo 7/29/2005 16:04'! 358994encodeForHTTP 358995 "change dangerous characters to their %XX form, for use in HTTP transactions" 358996 358997 ^ self encodeForHTTPWithTextEncoding: 'utf-8' conditionBlock: [:c | c isSafeForHTTP]. 358998! ! 358999 359000!String methodsFor: 'converting' stamp: 'yo 7/29/2005 16:04'! 359001encodeForHTTPWithTextEncoding: encodingName 359002 359003 ^ self encodeForHTTPWithTextEncoding: encodingName conditionBlock: [:c | c isSafeForHTTP]. 359004! ! 359005 359006!String methodsFor: 'converting' stamp: 'PeterHugossonMiller 9/3/2009 11:28'! 359007encodeForHTTPWithTextEncoding: encodingName conditionBlock: conditionBlock 359008 "change dangerous characters to their %XX form, for use in HTTP transactions" 359009 359010 | httpSafeStream encodedStream cont | 359011 httpSafeStream := (String new) writeStream. 359012 encodedStream := MultiByteBinaryOrTextStream on: (String new: 6). 359013 encodedStream converter: (TextConverter newForEncoding: encodingName). 359014 self do: [:c | 359015 (conditionBlock value: c) 359016 ifTrue: [httpSafeStream nextPut: (Character value: c charCode)] 359017 ifFalse: [ 359018 encodedStream text; reset. 359019 encodedStream nextPut: c. 359020 encodedStream position: 0. 359021 encodedStream binary. 359022 cont := encodedStream contents. 359023 cont do: [:byte | 359024 httpSafeStream nextPut: $%. 359025 httpSafeStream nextPut: (byte // 16) asHexDigit. 359026 httpSafeStream nextPut: (byte \\ 16) asHexDigit. 359027 ]. 359028 ]. 359029 ]. 359030 ^ httpSafeStream contents. 359031! ! 359032 359033!String methodsFor: 'converting' stamp: 'yo 7/5/2004 16:48'! 359034findSelector 359035 "Dan's code for hunting down selectors with keyword parts; while this doesn't give a true parse, in most cases it does what we want, in where it doesn't, we're none the worse for it." 359036 | sel possibleParens level n | 359037 sel := self withBlanksTrimmed. 359038 (sel includes: $:) ifTrue: 359039 [sel := sel copyReplaceAll: ':' with: ': '. "for the style (aa max:bb) with no space" 359040 possibleParens := sel findTokens: Character separators. 359041 sel := self class streamContents: 359042 [:s | level := 0. 359043 possibleParens do: 359044 [:token | 359045 (level = 0 and: [token endsWith: ':']) 359046 ifTrue: [s nextPutAll: token] 359047 ifFalse: [(n := token occurrencesOf: $( ) > 0 ifTrue: [level := level + n]. 359048 (n := token occurrencesOf: $[ ) > 0 ifTrue: [level := level + n]. 359049 (n := token occurrencesOf: $] ) > 0 ifTrue: [level := level - n]. 359050 (n := token occurrencesOf: $) ) > 0 ifTrue: [level := level - n]]]]]. 359051 359052 sel isEmpty ifTrue: [^ nil]. 359053 sel isOctetString ifTrue: [sel := sel asOctetString]. 359054 Symbol hasInterned: sel ifTrue: 359055 [:aSymbol | ^ aSymbol]. 359056 ^ nil! ! 359057 359058!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359059initialIntegerOrNil 359060 "Answer the integer represented by the leading digits of the receiver, or nil if the receiver does not begin with a digit" 359061 | firstNonDigit | 359062 (self size == 0 or: [self first isDigit not]) ifTrue: [^ nil]. 359063 firstNonDigit := (self findFirst: [:m | m isDigit not]). 359064 firstNonDigit = 0 ifTrue: [firstNonDigit := self size + 1]. 359065 ^ (self copyFrom: 1 to: (firstNonDigit - 1)) asNumber 359066" 359067'234Whoopie' initialIntegerOrNil 359068'wimpy' initialIntegerOrNil 359069'234' initialIntegerOrNil 359070'2N' initialIntegerOrNil 359071'2' initialIntegerOrNil 359072' 89Ten ' initialIntegerOrNil 359073'78 92' initialIntegerOrNil 359074" 359075! ! 359076 359077!String methodsFor: 'converting' stamp: 'PeterHugossonMiller 9/3/2009 11:29'! 359078keywords 359079 "Answer an array of the keywords that compose the receiver." 359080 | kwd char keywords | 359081 keywords := Array streamContents: 359082 [:kwds | kwd := (String new: 16) writeStream. 359083 1 to: self size do: 359084 [:i | 359085 kwd nextPut: (char := self at: i). 359086 char = $: ifTrue: 359087 [kwds nextPut: kwd contents. 359088 kwd reset]]. 359089 (kwd position = 0) ifFalse: [kwds nextPut: kwd contents]]. 359090 (keywords size >= 1 and: [(keywords at: 1) = ':']) ifTrue: 359091 ["Has an initial keyword, as in #:if:then:else:" 359092 keywords := keywords allButFirst]. 359093 (keywords size >= 2 and: [(keywords at: keywords size - 1) = ':']) ifTrue: 359094 ["Has a final keyword, as in #nextPut::andCR" 359095 keywords := keywords copyReplaceFrom: keywords size - 1 359096 to: keywords size with: {':' , keywords last}]. 359097 ^ keywords! ! 359098 359099!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359100numericSuffix 359101 ^ self stemAndNumericSuffix last 359102 359103" 359104'abc98' numericSuffix 359105'98abc' numericSuffix 359106"! ! 359107 359108!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359109onlyLetters 359110 "answer the receiver with only letters" 359111 ^ self select:[:each | each isLetter]! ! 359112 359113!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359114romanNumber 359115 | value v1 v2 | 359116 value := v1 := v2 := 0. 359117 self reverseDo: 359118 [:each | 359119 v1 := #(1 5 10 50 100 500 1000) at: ('IVXLCDM' indexOf: each). 359120 v1 >= v2 359121 ifTrue: [value := value + v1] 359122 ifFalse: [value := value - v1]. 359123 v2 := v1]. 359124 ^ value! ! 359125 359126!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359127sansPeriodSuffix 359128 "Return a copy of the receiver up to, but not including, the first period. If the receiver's *first* character is a period, then just return the entire receiver. " 359129 359130 | likely | 359131 likely := self copyUpTo: $.. 359132 ^ likely size == 0 359133 ifTrue: [self] 359134 ifFalse: [likely]! ! 359135 359136!String methodsFor: 'converting' stamp: 'yo 8/27/2002 11:13'! 359137splitInteger 359138 "Answer an array that is a splitting of self into a string and an integer. 359139 '43Sam' ==> #(43 'Sam'). 'Try90' ==> #('Try' 90) 359140 BUT NOTE: 'Sam' ==> #('Sam' 0), and '90' ==> #('' 90) ie, (<string> <integer>)." 359141 359142 | pos | 359143 (pos := self findFirst: [:d | d isDigit not]) = 0 ifTrue: [^ Array with: '' with: self asNumber]. 359144 self first isDigit ifTrue: [ 359145 ^ Array with: (self copyFrom: 1 to: pos - 1) asNumber 359146 with: (self copyFrom: pos to: self size)]. 359147 (pos := self findFirst: [:d | d isDigit]) = 0 ifTrue: [^ Array with: self with: 0]. 359148 ^ Array with: (self copyFrom: 1 to: pos - 1) 359149 with: (self copyFrom: pos to: self size) asNumber! ! 359150 359151!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359152stemAndNumericSuffix 359153 "Parse the receiver into a string-valued stem and a numeric-valued suffix. 6/7/96 sw" 359154 359155 | stem suffix position | 359156 359157 stem := self. 359158 suffix := 0. 359159 position := 1. 359160 [stem endsWithDigit and: [stem size > 1]] whileTrue: 359161 [suffix := stem last digitValue * position + suffix. 359162 position := position * 10. 359163 stem := stem copyFrom: 1 to: stem size - 1]. 359164 ^ Array with: stem with: suffix 359165 359166"'Fred2305' stemAndNumericSuffix"! ! 359167 359168!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359169subStrings 359170 "Answer an array of the substrings that compose the receiver." 359171 #Collectn. 359172 "Added 2000/04/08 For ANSI <readableString> protocol." 359173 ^ self substrings! ! 359174 359175!String methodsFor: 'converting' stamp: 'damiencassou 5/30/2008 11:45'! 359176subStrings: separators 359177 "Answer an array containing the substrings in the receiver separated 359178 by the elements of separators." 359179 | char result sourceStream subString | 359180 #Collectn. 359181 "Changed 2000/04/08 For ANSI <readableString> protocol." 359182 (separators isString or: [ separators allSatisfy: [ :element | element isKindOf: Character ] ]) ifFalse: [ ^ self error: 'separators must be Characters.' ]. 359183 sourceStream := self readStream. 359184 result := OrderedCollection new. 359185 subString := String new. 359186 [ sourceStream atEnd ] whileFalse: 359187 [ char := sourceStream next. 359188 (separators includes: char) 359189 ifTrue: 359190 [ subString notEmpty ifTrue: 359191 [ result add: subString copy. 359192 subString := String new ] ] 359193 ifFalse: [ subString := subString , (String with: char) ] ]. 359194 subString notEmpty ifTrue: [ result add: subString copy ]. 359195 ^ result asArray! ! 359196 359197!String methodsFor: 'converting' stamp: 'PeterHugossonMiller 9/3/2009 11:29'! 359198substrings 359199 "Answer an array of the substrings that compose the receiver." 359200 | result end beginning | 359201 359202 result := (Array new: 10) writeStream. 359203 359204 359205 359206 end := 0. 359207 "find one substring each time through this loop" 359208 [ 359209 "find the beginning of the next substring" 359210 beginning := self indexOfAnyOf: CSNonSeparators startingAt: end+1 ifAbsent: [ nil ]. 359211 beginning ~~ nil ] 359212 whileTrue: [ 359213 "find the end" 359214 end := self indexOfAnyOf: CSSeparators startingAt: beginning ifAbsent: [ self size + 1 ]. 359215 end := end - 1. 359216 359217 result nextPut: (self copyFrom: beginning to: end). 359218 359219 ]. 359220 359221 359222 ^result contents! ! 359223 359224!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359225surroundedBySingleQuotes 359226 "Answer the receiver with leading and trailing quotes. " 359227 359228 ^ $' asString, self, $' asString! ! 359229 359230!String methodsFor: 'converting' stamp: 'yo 8/28/2002 15:14'! 359231translateFrom: start to: stop table: table 359232 "translate the characters in the string by the given table, in place" 359233 self class translate: self from: start to: stop table: table! ! 359234 359235!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359236translateToLowercase 359237 "Translate all characters to lowercase, in place" 359238 359239 self translateWith: LowercasingTable! ! 359240 359241!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359242translateToUppercase 359243 "Translate all characters to lowercase, in place" 359244 359245 self translateWith: UppercasingTable! ! 359246 359247!String methodsFor: 'converting' stamp: 'yo 8/28/2002 15:13'! 359248translateWith: table 359249 "translate the characters in the string by the given table, in place" 359250 ^ self translateFrom: 1 to: self size table: table! ! 359251 359252!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359253truncateTo: smallSize 359254 "return myself or a copy shortened to smallSize. 1/18/96 sw" 359255 359256 ^ self size <= smallSize 359257 ifTrue: 359258 [self] 359259 ifFalse: 359260 [self copyFrom: 1 to: smallSize]! ! 359261 359262!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359263truncateWithElipsisTo: maxLength 359264 "Return myself or a copy suitably shortened but with elipsis added" 359265 359266 ^ self size <= maxLength 359267 ifTrue: 359268 [self] 359269 ifFalse: 359270 [(self copyFrom: 1 to: (maxLength - 3)), '...'] 359271 359272 359273 "'truncateWithElipsisTo:' truncateWithElipsisTo: 20"! ! 359274 359275!String methodsFor: 'converting' stamp: 'KR 9/22/2005 23:06'! 359276unescapePercents 359277 "decode %xx form. This is the opposite of #encodeForHTTP" 359278 ^ self unescapePercentsWithTextEncoding: 'utf-8'.! ! 359279 359280!String methodsFor: 'converting' stamp: 'ky 7/8/2006 17:56'! 359281unescapePercentsWithTextEncoding: encodingName 359282 "decode string including %XX form" 359283 | unescaped char asciiVal specialChars oldPos pos converter | 359284 unescaped := ReadWriteStream on: String new. 359285 specialChars := '+%' asCharacterSet. 359286 oldPos := 1. 359287 [pos := self indexOfAnyOf: specialChars startingAt: oldPos. 359288 pos > 0] 359289 whileTrue: [unescaped 359290 nextPutAll: (self copyFrom: oldPos to: pos - 1). 359291 char := self at: pos. 359292 (char = $% 359293 and: [pos + 2 <= self size]) 359294 ifTrue: [asciiVal := (self at: pos + 1) asUppercase digitValue * 16 + (self at: pos + 2) asUppercase digitValue. 359295 asciiVal > 255 359296 ifTrue: [^ self]. 359297 unescaped 359298 nextPut: (Character value: asciiVal). 359299 pos := pos + 3. 359300 pos <= self size 359301 ifFalse: [char := nil]. 359302 oldPos := pos] 359303 ifFalse: [char = $+ 359304 ifTrue: [unescaped nextPut: Character space] 359305 ifFalse: [unescaped nextPut: char]. 359306 oldPos := pos + 1]]. 359307 oldPos <= self size 359308 ifTrue: [unescaped 359309 nextPutAll: (self copyFrom: oldPos to: self size)]. 359310 converter := (TextConverter newForEncoding: encodingName) 359311 ifNil: [TextConverter newForEncoding: nil]. 359312 ^ [unescaped contents convertFromWithConverter: converter] 359313 on: Error 359314 do: ["the contents may be squeak-encoded" 359315 unescaped contents]! ! 359316 359317!String methodsFor: 'converting' stamp: 'yo 8/27/2002 11:20'! 359318unparenthetically 359319 "If the receiver starts with (..( and ends with matching )..), strip them" 359320 359321 | curr | 359322 curr := self. 359323 [((curr first = $() and: [curr last = $)])] whileTrue: 359324 [curr := curr copyFrom: 2 to: (curr size - 1)]. 359325 359326 ^ curr 359327 359328" 359329 359330'((fred the bear))' unparenthetically 359331 359332" 359333 ! ! 359334 359335!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359336unzipped 359337 | magic1 magic2 | 359338 magic1 := (self at: 1) asInteger. 359339 magic2 := (self at: 2) asInteger. 359340 (magic1 = 16r1F and:[magic2 = 16r8B]) ifFalse:[^self]. 359341 ^(GZipReadStream on: self) upToEnd! ! 359342 359343!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359344withBlanksCondensed 359345 "Return a copy of the receiver with leading/trailing blanks removed 359346 and consecutive white spaces condensed." 359347 359348 | trimmed lastBlank | 359349 trimmed := self withBlanksTrimmed. 359350 ^String streamContents: [:stream | 359351 lastBlank := false. 359352 trimmed do: [:c | (c isSeparator and: [lastBlank]) ifFalse: [stream nextPut: c]. 359353 lastBlank := c isSeparator]]. 359354 359355 " ' abc d ' withBlanksCondensed" 359356! ! 359357 359358!String methodsFor: 'converting' stamp: 'yo 7/5/2004 16:43'! 359359withBlanksTrimmed 359360 "Return a copy of the receiver from which leading and trailing blanks have been trimmed." 359361 359362 | first result | 359363 first := self findFirst: [:c | c isSeparator not]. 359364 first = 0 ifTrue: [^ '']. "no non-separator character" 359365 result := self 359366 copyFrom: first 359367 to: (self findLast: [:c | c isSeparator not]). 359368 result isOctetString ifTrue: [^ result asOctetString] ifFalse: [^ result]. 359369 359370 " ' abc d ' withBlanksTrimmed" 359371! ! 359372 359373!String methodsFor: 'converting' stamp: 'md 9/19/2004 15:19'! 359374withFirstCharacterDownshifted 359375 "Return a copy with the first letter downShifted" 359376 359377 | answer | 359378 359379 self ifEmpty: [^ self copy]. 359380 answer := self copy. 359381 answer at: 1 put: (answer at: 1) asLowercase. 359382 ^ answer. ! ! 359383 359384!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359385withNoLineLongerThan: aNumber 359386 "Answer a string with the same content as receiver, but rewrapped so that no line has more characters than the given number" 359387 | listOfLines currentLast currentStart resultString putativeLast putativeLine crPosition | 359388 aNumber isNumber not | (aNumber < 1) ifTrue: [self error: 'too narrow']. 359389 listOfLines := OrderedCollection new. 359390 currentLast := 0. 359391 [currentLast < self size] whileTrue: 359392 [currentStart := currentLast + 1. 359393 putativeLast := (currentStart + aNumber - 1) min: self size. 359394 putativeLine := self copyFrom: currentStart to: putativeLast. 359395 (crPosition := putativeLine indexOf: Character cr) > 0 ifTrue: 359396 [putativeLast := currentStart + crPosition - 1. 359397 putativeLine := self copyFrom: currentStart to: putativeLast]. 359398 currentLast := putativeLast == self size 359399 ifTrue: 359400 [putativeLast] 359401 ifFalse: 359402 [currentStart + putativeLine lastSpacePosition - 1]. 359403 currentLast <= currentStart ifTrue: 359404 ["line has NO spaces; baleout!!" 359405 currentLast := putativeLast]. 359406 listOfLines add: (self copyFrom: currentStart to: currentLast) withBlanksTrimmed]. 359407 359408 listOfLines size > 0 ifFalse: [^ '']. 359409 resultString := listOfLines first. 359410 2 to: listOfLines size do: 359411 [:i | resultString := resultString, String cr, (listOfLines at: i)]. 359412 ^ resultString 359413 359414"#(5 7 20) collect: 359415 [:i | 'Fred the bear went down to the brook to read his book in silence' withNoLineLongerThan: i]"! ! 359416 359417!String methodsFor: 'converting' stamp: 'jmv 8/6/2009 09:17'! 359418withoutJustTrailingDigits 359419 "Answer the portion of the receiver that precedes any trailing series of digits. If the receiver consists entirely of digits and blanks, return an empty string" 359420 | firstDigit | 359421 firstDigit := (self findFirst: [:m | m isDigit]). 359422 ^ firstDigit > 0 359423 ifTrue: 359424 [(self copyFrom: 1 to: firstDigit-1) withoutTrailingBlanks] 359425 ifFalse: 359426 [self] 359427 359428" 359429'Wh oopi e234' withoutJustTrailingDigits 359430'Wh oopi e 234' withoutJustTrailingDigits 359431" 359432! ! 359433 359434!String methodsFor: 'converting' stamp: 'md 10/5/2005 11:01'! 359435withoutLeadingBlanks 359436 359437 "Return a copy of the receiver from which leading blanks have been 359438trimmed." 359439 359440 359441 | first | 359442 359443 first := self findFirst: [:c | c isSeparator not ]. 359444 359445 first = 0 ifTrue: [^ '']. 359446 359447 "no non-separator character" 359448 359449 ^ self copyFrom: first to: self size 359450 359451 359452 359453 " ' abc d' withoutLeadingBlanks" 359454! ! 359455 359456!String methodsFor: 'converting' stamp: 'PeterHugossonMiller 9/3/2009 11:30'! 359457withSeparatorsCompacted 359458 "replace each sequences of whitespace by a single space character" 359459 "' test ' withSeparatorsCompacted = ' test '" 359460 "' test test' withSeparatorsCompacted = ' test test'" 359461 "'test test ' withSeparatorsCompacted = 'test test '" 359462 359463 | out in next isSeparator | 359464 self isEmpty ifTrue: [^ self]. 359465 359466 out := (String new: self size) writeStream. 359467 in := self readStream. 359468 isSeparator := [:char | char asciiValue < 256 359469 and: [CSSeparators includes: char]]. 359470 [in atEnd] whileFalse: [ 359471 next := in next. 359472 (isSeparator value: next) 359473 ifTrue: [ 359474 out nextPut: $ . 359475 [in atEnd or: 359476 [next := in next. 359477 (isSeparator value: next) 359478 ifTrue: [false] 359479 ifFalse: [out nextPut: next. true]]] whileFalse] 359480 ifFalse: [out nextPut: next]]. 359481 ^ out contents! ! 359482 359483!String methodsFor: 'converting' stamp: 'yo 8/27/2002 14:06'! 359484withoutLeadingDigits 359485 "Answer the portion of the receiver that follows any leading series of digits and blanks. If the receiver consists entirely of digits and blanks, return an empty string" 359486 | firstNonDigit | 359487 firstNonDigit := (self findFirst: [:m | m isDigit not and: [m ~= $ ]]). 359488 ^ firstNonDigit > 0 359489 ifTrue: 359490 [self copyFrom: firstNonDigit to: self size] 359491 ifFalse: 359492 [''] 359493 359494" 359495'234Whoopie' withoutLeadingDigits 359496' 4321 BlastOff!!' withoutLeadingDigits 359497'wimpy' withoutLeadingDigits 359498' 89Ten ' withoutLeadingDigits 359499'78 92' withoutLeadingDigits 359500" 359501! ! 359502 359503!String methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! 359504withoutTrailingBlanks 359505 "Return a copy of the receiver from which trailing blanks have been trimmed." 359506 359507 | last | 359508 last := self findLast: [:c | c isSeparator not]. 359509 last = 0 ifTrue: [^ '']. "no non-separator character" 359510 ^ self copyFrom: 1 to: last 359511 359512 " ' abc d ' withoutTrailingBlanks" 359513! ! 359514 359515!String methodsFor: 'converting' stamp: 'yo 8/27/2002 14:06'! 359516withoutTrailingDigits 359517 "Answer the portion of the receiver that precedes any trailing series of digits and blanks. If the receiver consists entirely of digits and blanks, return an empty string" 359518 | firstDigit | 359519 firstDigit := (self findFirst: [:m | m isDigit or: [m = $ ]]). 359520 ^ firstDigit > 0 359521 ifTrue: 359522 [self copyFrom: 1 to: firstDigit-1] 359523 ifFalse: 359524 [self] 359525 359526" 359527'Whoopie234' withoutTrailingDigits 359528' 4321 BlastOff!!' withoutLeadingDigits 359529'wimpy' withoutLeadingDigits 359530' 89Ten ' withoutLeadingDigits 359531'78 92' withoutLeadingDigits 359532" 359533! ! 359534 359535!String methodsFor: 'converting' stamp: 'dgd 11/26/2005 21:19'! 359536zipped 359537 | stream gzstream | 359538 359539 stream := RWBinaryOrTextStream on: String new. 359540 359541 gzstream := GZipWriteStream on: stream. 359542 gzstream nextPutAll: self. 359543 gzstream close. 359544 stream reset. 359545 359546 ^ stream contents. 359547! ! 359548 359549 359550!String methodsFor: 'copying' stamp: 'yo 11/3/2004 19:24'! 359551copyReplaceTokens: oldSubstring with: newSubstring 359552 "Replace all occurrences of oldSubstring that are surrounded 359553 by non-alphanumeric characters" 359554 ^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: true 359555 "'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Snick'"! ! 359556 359557!String methodsFor: 'copying' stamp: 'yo 11/3/2004 19:24'! 359558deepCopy 359559 "DeepCopy would otherwise mean make a copy of the character; since 359560 characters are unique, just return a shallowCopy." 359561 359562 ^self shallowCopy! ! 359563 359564!String methodsFor: 'copying' stamp: 'yo 11/3/2004 19:24'! 359565padded: leftOrRight to: length with: char 359566 leftOrRight = #left ifTrue: 359567 [^ (String new: (length - self size max: 0) withAll: char) , self]. 359568 leftOrRight = #right ifTrue: 359569 [^ self , (String new: (length - self size max: 0) withAll: char)].! ! 359570 359571 359572!String methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! 359573displayAt: aPoint 359574 "Display the receiver as a DisplayText at aPoint on the display screen." 359575 359576 self displayOn: Display at: aPoint! ! 359577 359578!String methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! 359579displayOn: aDisplayMedium 359580 "Display the receiver on the given DisplayMedium. 5/16/96 sw" 359581 359582 self displayOn: aDisplayMedium at: 0 @ 0! ! 359583 359584!String methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! 359585displayOn: aDisplayMedium at: aPoint 359586 "Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium, using black-colored text." 359587 359588 self displayOn: aDisplayMedium at: aPoint textColor: Color black! ! 359589 359590!String methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! 359591displayOn: aDisplayMedium at: aPoint textColor: aColor 359592 "Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium, rendering the text in the designated color" 359593 359594 (self asDisplayText foregroundColor: (aColor ifNil: [Color black]) backgroundColor: Color white) 359595 displayOn: aDisplayMedium at: aPoint! ! 359596 359597!String methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! 359598displayProgressAt: aPoint from: minVal to: maxVal during: workBlock 359599 "Display this string as a caption over a progress bar while workBlock is evaluated. 359600 359601EXAMPLE (Select next 6 lines and Do It) 359602'Now here''s some Real Progress' 359603 displayProgressAt: Sensor cursorPoint 359604 from: 0 to: 10 359605 during: [:bar | 359606 1 to: 10 do: [:x | bar value: x. 359607 (Delay forMilliseconds: 500) wait]]. 359608 359609HOW IT WORKS (Try this in any other language :-) 359610Since your code (the last 2 lines in the above example) is in a block, 359611this method gets control to display its heading before, and clean up 359612the screen after, its execution. 359613The key, though, is that the block is supplied with an argument, 359614named 'bar' in the example, which will update the bar image every 359615it is sent the message value: x, where x is in the from:to: range. 359616" 359617 ^ProgressInitiationException 359618 display: self 359619 at: aPoint 359620 from: minVal 359621 to: maxVal 359622 during: workBlock! ! 359623 359624 359625!String methodsFor: 'encoding' stamp: 'ar 4/10/2005 17:16'! 359626getInteger32: location 359627 | integer | 359628 <primitive: 'getInteger' module: 'IntegerPokerPlugin'> 359629 "^IntegerPokerPlugin doPrimitive: #getInteger" 359630 359631 "the following is about 7x faster than interpreting the plugin if not compiled" 359632 359633 integer := 359634 ((self at: location) asInteger bitShift: 24) + 359635 ((self at: location+1) asInteger bitShift: 16) + 359636 ((self at: location+2) asInteger bitShift: 8) + 359637 (self at: location+3) asInteger. 359638 359639 integer > 1073741824 ifTrue: [^1073741824 - integer ]. 359640 ^integer 359641! ! 359642 359643!String methodsFor: 'encoding' stamp: 'ar 4/10/2005 17:17'! 359644putInteger32: anInteger at: location 359645 | integer | 359646 <primitive: 'putInteger' module: 'IntegerPokerPlugin'> 359647 "IntegerPokerPlugin doPrimitive: #putInteger" 359648 359649 "the following is close to 20x faster than the above if the primitive is not compiled" 359650 "PUTCOUNTER := PUTCOUNTER + 1." 359651 integer := anInteger. 359652 integer < 0 ifTrue: [integer := 1073741824 - integer. ]. 359653 self at: location+3 put: (Character value: (integer \\ 256)). 359654 self at: location+2 put: (Character value: (integer bitShift: -8) \\ 256). 359655 self at: location+1 put: (Character value: (integer bitShift: -16) \\ 256). 359656 self at: location put: (Character value: (integer bitShift: -24) \\ 256). 359657 359658"Smalltalk at: #PUTCOUNTER put: 0"! ! 359659 359660!String methodsFor: 'encoding' stamp: 'ar 4/10/2005 17:18'! 359661writeLeadingCharRunsOn: stream 359662 359663 | runLength runValues runStart leadingChar | 359664 self isEmpty ifTrue: [^ self]. 359665 359666 runLength := OrderedCollection new. 359667 runValues := OrderedCollection new. 359668 runStart := 1. 359669 leadingChar := (self at: runStart) leadingChar. 359670 2 to: self size do: [:index | 359671 (self at: index) leadingChar = leadingChar ifFalse: [ 359672 runValues add: leadingChar. 359673 runLength add: (index - runStart). 359674 leadingChar := (self at: index) leadingChar. 359675 runStart := index. 359676 ]. 359677 ]. 359678 runValues add: (self last) leadingChar. 359679 runLength add: self size + 1 - runStart. 359680 359681 stream nextPut: $(. 359682 runLength do: [:rr | rr printOn: stream. stream space]. 359683 stream skip: -1; nextPut: $). 359684 runValues do: [:vv | vv printOn: stream. stream nextPut: $,]. 359685 stream skip: -1. 359686! ! 359687 359688 359689!String methodsFor: 'filter streaming' stamp: 'yo 8/26/2002 22:31'! 359690byteEncode:aStream 359691 359692 ^aStream writeString: self. 359693! ! 359694 359695!String methodsFor: 'filter streaming' stamp: 'yo 8/26/2002 22:31'! 359696putOn:aStream 359697 359698 ^aStream nextPutAll: self. 359699! ! 359700 359701 359702!String methodsFor: 'formatting' stamp: 'md 5/26/2005 13:34'! 359703expandMacros 359704 ^self expandMacrosWithArguments: #()! ! 359705 359706!String methodsFor: 'formatting' stamp: 'PeterHugossonMiller 9/3/2009 11:28'! 359707expandMacrosWithArguments: anArray 359708 | newStream readStream char index | 359709 newStream := (String new: self size) writeStream. 359710 readStream := self readStream. 359711 [ readStream atEnd ] whileFalse: 359712 [ char := readStream next. 359713 char == $< 359714 ifTrue: 359715 [ | nextChar | 359716 nextChar := readStream next asUppercase. 359717 nextChar == $N ifTrue: [ newStream cr ]. 359718 nextChar == $T ifTrue: [ newStream tab ]. 359719 nextChar isDigit ifTrue: 359720 [ index := nextChar digitValue. 359721 359722 [ readStream atEnd or: [ (nextChar := readStream next asUppercase) isDigit not ] ] whileFalse: [ index := index * 10 + nextChar digitValue ] ]. 359723 nextChar == $? ifTrue: 359724 [ | trueString falseString | 359725 trueString := readStream upTo: $:. 359726 falseString := readStream upTo: $>. 359727 readStream position: readStream position - 1. 359728 newStream nextPutAll: ((anArray at: index) 359729 ifTrue: [ trueString ] 359730 ifFalse: [ falseString ]) ]. 359731 nextChar == $P ifTrue: [ newStream nextPutAll: (anArray at: index) printString ]. 359732 nextChar == $S ifTrue: [ newStream nextPutAll: (anArray at: index) ]. 359733 readStream skipTo: $> ] 359734 ifFalse: 359735 [ newStream nextPut: (char == $% 359736 ifTrue: [ readStream next ] 359737 ifFalse: [ char ]) ] ]. 359738 ^ newStream contents! ! 359739 359740!String methodsFor: 'formatting' stamp: 'md 5/26/2005 13:34'! 359741expandMacrosWith: anObject 359742 ^self expandMacrosWithArguments: (Array with: anObject)! ! 359743 359744!String methodsFor: 'formatting' stamp: 'md 5/26/2005 13:34'! 359745expandMacrosWith: anObject with: anotherObject 359746 ^self 359747 expandMacrosWithArguments: (Array with: anObject with: anotherObject)! ! 359748 359749!String methodsFor: 'formatting' stamp: 'md 5/26/2005 13:34'! 359750expandMacrosWith: anObject with: anotherObject with: thirdObject 359751 ^self expandMacrosWithArguments: (Array 359752 with: anObject 359753 with: anotherObject 359754 with: thirdObject)! ! 359755 359756!String methodsFor: 'formatting' stamp: 'md 5/26/2005 13:34'! 359757expandMacrosWith: anObject with: anotherObject with: thirdObject with: fourthObject 359758 ^self expandMacrosWithArguments: (Array 359759 with: anObject 359760 with: anotherObject 359761 with: thirdObject 359762 with: fourthObject)! ! 359763 359764!String methodsFor: 'formatting' stamp: 'yo 11/3/2004 19:24'! 359765format: aCollection 359766 "format the receiver with aCollection 359767 359768 simplest example: 359769 'foo {1} bar' format: {Date today}. 359770 359771 complete example: 359772 '\{ \} \\ foo {1} bar {2}' format: {12. 'string'}. 359773 " 359774 | result stream | 359775 result := String new writeStream. 359776 stream := self readStream. 359777 359778 [stream atEnd] 359779 whileFalse: [| currentChar | 359780 currentChar := stream next. 359781 currentChar == ${ 359782 ifTrue: [| expression | 359783 expression := self getEnclosedExpressionFrom: stream. 359784 result 359785 nextPutAll: (self evaluateExpression: expression parameters: aCollection)] 359786 ifFalse: [ 359787 currentChar == $\ 359788 ifTrue: [stream atEnd 359789 ifFalse: [result nextPut: stream next]] 359790 ifFalse: [result nextPut: currentChar]]]. 359791 359792 ^ result contents! ! 359793 359794!String methodsFor: 'formatting' stamp: 'yo 11/3/2004 19:24'! 359795withCRs 359796 "Return a copy of the receiver in which backslash (\) characters have been replaced with carriage returns." 359797 359798 ^ self collect: [ :c | c = $\ ifTrue: [ Character cr ] ifFalse: [ c ]].! ! 359799 359800 359801!String methodsFor: 'internet' stamp: 'PeterHugossonMiller 9/3/2009 11:26'! 359802decodeMimeHeader 359803 "See RFC 2047, MIME Part Three: Message Header Extension for Non-ASCII 359804 Text. Text containing non-ASCII characters is encoded by the sequence 359805 =?character-set?encoding?encoded-text?= 359806 Encoding is Q (quoted printable) or B (Base64), handled by 359807 Base64MimeConverter / RFC2047MimeConverter. 359808 359809 Thanks to Yokokawa-san, it works in m17n package. Try the following: 359810 359811 '=?ISO-2022-JP?B?U1dJS0lQT1AvGyRCPUJDKyVpJXMlQRsoQi8=?= =?ISO-2022-JP?B?GyRCJVElRiUjJSobKEIoUGF0aW8p?=' decodeMimeHeader. 359812" 359813 | input output temp charset decoder encodedStream encoding pos | 359814 input := self readStream. 359815 output := String new writeStream. 359816 359817 [ output nextPutAll: (input upTo: $=). 359818 "ASCII Text" 359819 input atEnd ] whileFalse: 359820 [ (temp := input next) = $? 359821 ifTrue: 359822 [ charset := input upTo: $?. 359823 encoding := (input upTo: $?) asUppercase. 359824 temp := input upTo: $?. 359825 input next. 359826 "Skip final =" 359827 (charset isNil or: [ charset size = 0 ]) ifTrue: [ charset := 'LATIN-1' ]. 359828 encodedStream := MultiByteBinaryOrTextStream 359829 on: String new 359830 encoding: charset. 359831 decoder := encoding = 'B' 359832 ifTrue: [ Base64MimeConverter new ] 359833 ifFalse: [ RFC2047MimeConverter new ]. 359834 decoder 359835 mimeStream: temp readStream; 359836 dataStream: encodedStream; 359837 mimeDecode. 359838 output nextPutAll: encodedStream reset contents. 359839 pos := input position. 359840 input skipSeparators. 359841 "Delete spaces if followed by =" 359842 input peek = $= ifFalse: [ input position: pos ] ] 359843 ifFalse: 359844 [ output 359845 nextPut: $=; 359846 nextPut: temp ] ]. 359847 ^ output contents! ! 359848 359849!String methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! 359850decodeQuotedPrintable 359851 "Assume receiver is in MIME 'quoted-printable' encoding, and decode it." 359852 359853 ^QuotedPrintableMimeConverter mimeDecode: self as: self class! ! 359854 359855!String methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! 359856withInternetLineEndings 359857 "change line endings from CR's to CRLF's. This is probably in 359858prepration for sending a string over the Internet" 359859 | cr lf | 359860 cr := Character cr. 359861 lf := Character linefeed. 359862 ^self class streamContents: [ :stream | 359863 self do: [ :c | 359864 stream nextPut: c. 359865 c = cr ifTrue:[ stream nextPut: lf ]. ] ].! ! 359866 359867!String methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! 359868withSqueakLineEndings 359869 "assume the string is textual, and that CR, LF, and CRLF are all 359870 valid line endings. Replace each occurence with a single CR" 359871 | cr lf input c crlf inPos outPos outString lineEndPos newOutPos | 359872 cr := Character cr. 359873 lf := Character linefeed. 359874 crlf := CharacterSet new. 359875 crlf add: cr; add: lf. 359876 359877 inPos := 1. 359878 outPos := 1. 359879 outString := 359880 String new: self size. 359881 359882 [ lineEndPos := self indexOfAnyOf: crlf startingAt: inPos ifAbsent: [0]. 359883 lineEndPos ~= 0 ] whileTrue: [ 359884 newOutPos := outPos + (lineEndPos - inPos + 1). 359885 outString replaceFrom: outPos to: newOutPos - 2 with: self startingAt: inPos. 359886 outString at: newOutPos-1 put: cr. 359887 outPos := newOutPos. 359888 359889 ((self at: lineEndPos) = cr and: [ lineEndPos < self size and: [ (self at: lineEndPos+1) = lf ] ]) ifTrue: [ 359890 "CRLF ending" 359891 inPos := lineEndPos + 2 ] 359892 ifFalse: [ 359893 "CR or LF ending" 359894 inPos := lineEndPos + 1 ]. ]. 359895 359896 "no more line endings. copy the rest" 359897 newOutPos := outPos + (self size - inPos + 1). 359898 outString replaceFrom: outPos to: newOutPos-1 with: self startingAt: inPos. 359899 359900 ^outString copyFrom: 1 to: newOutPos-1 359901 ! ! 359902 359903!String methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! 359904withoutQuoting 359905 "remove the initial and final quote marks, if present" 359906 "'''h''' withoutQuoting" 359907 | quote | 359908 self size < 2 ifTrue: [ ^self ]. 359909 quote := self first. 359910 (quote = $' or: [ quote = $" ]) 359911 ifTrue: [ ^self copyFrom: 2 to: self size - 1 ] 359912 ifFalse: [ ^self ].! ! 359913 359914 359915!String methodsFor: 'paragraph support' stamp: 'damiencassou 5/30/2008 11:45'! 359916indentationIfBlank: aBlock 359917 "Answer the number of leading tabs in the receiver. If there are 359918 no visible characters, pass the number of tabs to aBlock and return its value." 359919 | reader leadingTabs lastSeparator cr tab ch | 359920 cr := Character cr. 359921 tab := Character tab. 359922 reader := self readStream. 359923 leadingTabs := 0. 359924 [ reader atEnd not and: [ (ch := reader next) = tab ] ] whileTrue: [ leadingTabs := leadingTabs + 1 ]. 359925 lastSeparator := leadingTabs + 1. 359926 [ reader atEnd not and: [ ch isSeparator and: [ ch ~= cr ] ] ] whileTrue: 359927 [ lastSeparator := lastSeparator + 1. 359928 ch := reader next ]. 359929 lastSeparator = self size | (ch = cr) ifTrue: [ ^ aBlock value: leadingTabs ]. 359930 ^ leadingTabs! ! 359931 359932 359933!String methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'! 359934basicType 359935 "Answer a symbol representing the inherent type of the receiver" 359936 359937 "Number String Boolean player collection sound color etc" 359938 ^ #String! ! 359939 359940!String methodsFor: 'printing' stamp: 'yo 8/26/2002 22:57'! 359941encodeDoublingQuoteOn: aStream 359942 "Print inside string quotes, doubling inbedded quotes." 359943 | x | 359944 aStream print: $'. 359945 1 to: self size do: 359946 [:i | 359947 aStream print: (x := self at: i). 359948 x = $' ifTrue: [aStream print: x]]. 359949 aStream print: $'! ! 359950 359951!String methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'! 359952isLiteral 359953 359954 ^true! ! 359955 359956!String methodsFor: 'printing' stamp: 'sd 7/8/2006 18:06'! 359957printOn: aStream 359958 "Print inside string quotes, doubling inbedded quotes." 359959 359960 self storeOn: aStream! ! 359961 359962!String methodsFor: 'printing' stamp: 'yo 8/26/2002 22:58'! 359963storeOn: aStream 359964 "Print inside string quotes, doubling inbedded quotes." 359965 | x | 359966 aStream nextPut: $'. 359967 1 to: self size do: 359968 [:i | 359969 aStream nextPut: (x := self at: i). 359970 x = $' ifTrue: [aStream nextPut: x]]. 359971 aStream nextPut: $'! ! 359972 359973!String methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'! 359974stringRepresentation 359975 "Answer a string that represents the receiver. For most objects this is simply its printString, but for strings themselves, it's themselves, to avoid the superfluous extra pair of quotes. 6/12/96 sw" 359976 359977 ^ self ! ! 359978 359979 359980!String methodsFor: 'system primitives' stamp: 'sw 10/20/2004 17:51'! 359981endsWithAColon 359982 "Answer whether the final character of the receiver is a colon" 359983 359984 ^ self size > 0 and: [self last == $:] 359985 359986" 359987#fred: endsWithAColon 359988'fred' endsWithAColon 359989"! ! 359990 359991!String methodsFor: 'system primitives' stamp: 'ar 4/10/2005 16:55'! 359992findSubstring: key in: body startingAt: start matchTable: matchTable 359993 "Answer the index in the string body at which the substring key first occurs, at or beyond start. The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches. If no match is found, zero will be returned." 359994 | index c1 c2 | 359995 matchTable == nil ifTrue: [ 359996 key size = 0 ifTrue: [^ 0]. 359997 start to: body size - key size + 1 do: 359998 [:startIndex | 359999 index := 1. 360000 [(body at: startIndex+index-1) 360001 = (key at: index)] 360002 whileTrue: 360003 [index = key size ifTrue: [^ startIndex]. 360004 index := index+1]]. 360005 ^ 0 360006 ]. 360007 360008 key size = 0 ifTrue: [^ 0]. 360009 start to: body size - key size + 1 do: 360010 [:startIndex | 360011 index := 1. 360012 [c1 := body at: startIndex+index-1. 360013 c2 := key at: index. 360014 ((c1 leadingChar = 0) ifTrue: [(matchTable at: c1 asciiValue + 1)] 360015 ifFalse: [c1 asciiValue + 1]) 360016 = ((c2 leadingChar = 0) ifTrue: [(matchTable at: c2 asciiValue + 1)] 360017 ifFalse: [c2 asciiValue + 1])] 360018 whileTrue: 360019 [index = key size ifTrue: [^ startIndex]. 360020 index := index+1]]. 360021 ^ 0 360022! ! 360023 360024!String methodsFor: 'system primitives' stamp: 'nice 10/17/2008 23:32'! 360025numArgs 360026 "Answer either the number of arguments that the receiver would take if considered a selector. Answer -1 if it couldn't be a selector. It is intended mostly for the assistance of spelling correction." 360027 360028 | firstChar numColons start ix | 360029 self size = 0 ifTrue: [^ -1]. 360030 firstChar := self at: 1. 360031 (firstChar isLetter) ifTrue: 360032 ["Fast reject if any chars are non-alphanumeric 360033 NOTE: fast only for Byte things - Broken for Wide" 360034 self class isBytes 360035 ifTrue: [(self findSubstring: '~' in: self startingAt: 1 matchTable: Tokenish) > 0 ifTrue: [^ -1]] 360036 ifFalse: [2 to: self size do: [:i | (self at: i) tokenish ifFalse: [^ -1]]]. 360037 "Fast colon count" 360038 numColons := 0. start := 1. 360039 [(ix := self indexOf: $: startingAt: start) > 0] 360040 whileTrue: 360041 [ix = start ifTrue: [^-1]. 360042 numColons := numColons + 1. 360043 start := ix + 1]. 360044 numColons = 0 ifTrue: [^ 0]. 360045 self last = $: 360046 ifTrue: [^ numColons] 360047 ifFalse: [^ -1]]. 360048 firstChar isSpecial ifTrue: 360049 [self size = 1 ifTrue: [^ 1]. 360050 2 to: self size do: [:i | (self at: i) isSpecial ifFalse: [^ -1]]. 360051 ^ 1]. 360052 ^ -1.! ! 360053 360054 360055!String methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! 360056hasContentsInExplorer 360057 360058 ^false! ! 360059 360060!String methodsFor: 'testing' stamp: 'ar 4/10/2005 16:49'! 360061includesUnifiedCharacter 360062 ^false! ! 360063 360064!String methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! 360065isAllDigits 360066 "whether the receiver is composed entirely of digits" 360067 self do: [:c | c isDigit ifFalse: [^ false]]. 360068 ^ true! ! 360069 360070!String methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! 360071isAllSeparators 360072 "whether the receiver is composed entirely of separators" 360073 self do: [ :c | c isSeparator ifFalse: [ ^false ] ]. 360074 ^true! ! 360075 360076!String methodsFor: 'testing' stamp: 'yo 8/4/2003 12:26'! 360077isAsciiString 360078 360079 | c | 360080 c := self detect: [:each | each asciiValue > 127] ifNone: [nil]. 360081 ^ c isNil. 360082! ! 360083 360084!String methodsFor: 'testing' stamp: 'ar 4/10/2005 16:23'! 360085isByteString 360086 "Answer whether the receiver is a ByteString" 360087 ^false! ! 360088 360089!String methodsFor: 'testing' stamp: 'ar 4/10/2005 23:25'! 360090isOctetString 360091 "Answer whether the receiver can be represented as a byte string. 360092 This is different from asking whether the receiver *is* a ByteString 360093 (i.e., #isByteString)" 360094 1 to: self size do: [:pos | 360095 (self at: pos) asInteger >= 256 ifTrue: [^ false]. 360096 ]. 360097 ^ true. 360098! ! 360099 360100!String methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! 360101isString 360102 ^ true! ! 360103 360104!String methodsFor: 'testing' stamp: 'ar 4/12/2005 19:52'! 360105isWideString 360106 "Answer whether the receiver is a WideString" 360107 ^false! ! 360108 360109!String methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! 360110lastSpacePosition 360111 "Answer the character position of the final space or other separator character in the receiver, and 0 if none" 360112 self size to: 1 by: -1 do: 360113 [:i | ((self at: i) isSeparator) ifTrue: [^ i]]. 360114 ^ 0 360115 360116" 360117'fred the bear' lastSpacePosition 360118'ziggie' lastSpacePosition 360119'elvis ' lastSpacePosition 360120'wimpy ' lastSpacePosition 360121'' lastSpacePosition 360122"! ! 360123 360124 360125!String methodsFor: 'translating' stamp: 'dgd 8/24/2004 19:42'! 360126translated 360127 "answer the receiver translated to the default language" 360128 ^ NaturalLanguageTranslator current translate: self! ! 360129 360130!String methodsFor: 'translating' stamp: 'dgd 8/27/2004 18:43'! 360131translatedIfCorresponds 360132 "answer the receiver translated to the default language only if 360133 the receiver begins and ends with an underscore (_)" 360134 ^ ('_*_' match: self) 360135 ifTrue: [(self copyFrom: 2 to: self size - 1) translated] 360136 ifFalse: [self]! ! 360137 360138!String methodsFor: 'translating' stamp: 'dgd 8/24/2004 19:38'! 360139translatedTo: localeID 360140 "answer the receiver translated to the given locale id" 360141 ^ localeID translator translate: self! ! 360142 360143 360144!String methodsFor: 'user interface' stamp: 'ar 9/27/2005 20:02'! 360145openInWorkspaceWithTitle: aTitle 360146 "Open up a workspace with the receiver as its contents, with the given title" 360147 UIManager default edit: self label: aTitle! ! 360148 360149 360150!String methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'! 360151correctAgainstEnumerator: wordBlock continuedFrom: oldCollection 360152 "The guts of correction, instead of a wordList, there is a block that should take another block and enumerate over some list with it." 360153 360154 | choices scoreMin results score maxChoices | 360155 scoreMin := self size // 2 min: 3. 360156 maxChoices := 10. 360157 oldCollection isNil 360158 ifTrue: [ choices := SortedCollection sortBlock: [ :x :y | x value > y value ] ] 360159 ifFalse: [ choices := oldCollection ]. 360160 wordBlock isNil 360161 ifTrue: 360162 [ results := OrderedCollection new. 360163 1 to: (maxChoices min: choices size) do: [ :i | results add: (choices at: i) key ] ] 360164 ifFalse: 360165 [ wordBlock value: [ :word | 360166 (score := self alike: word) >= scoreMin ifTrue: 360167 [ choices add: (Association key: word value: score). 360168 (choices size >= maxChoices) ifTrue: [ scoreMin := (choices at: maxChoices) value] ] ]. 360169 results := choices ]. 360170 ^ results! ! 360171 360172!String methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'! 360173evaluateExpression: aString parameters: aCollection 360174 "private - evaluate the expression aString with 360175 aCollection as the parameters and answer the 360176 evaluation result as an string" 360177 | index | 360178 index := ('0' , aString) asNumber. 360179 360180 index isZero 360181 ifTrue: [^ '[invalid subscript: {1}]' format: {aString}]. 360182 360183 index > aCollection size 360184 ifTrue: [^ '[subscript is out of bounds: {1}]' format: {aString}]. 360185 360186 ^ (aCollection at: index) asString! ! 360187 360188!String methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'! 360189getEnclosedExpressionFrom: aStream 360190 "private - get the expression enclosed between '{' and 360191 '}' and remove all the characters from the stream" 360192 | result currentChar | 360193 result := String new writeStream. 360194 360195 [aStream atEnd 360196 or: [(currentChar := aStream next) == $}]] 360197 whileFalse: [result nextPut: currentChar]. 360198 360199 ^ result contents withBlanksTrimmed! ! 360200 360201!String methodsFor: 'private' stamp: 'yo 8/26/2002 22:53'! 360202replaceFrom: start to: stop with: replacement startingAt: repStart 360203 "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." 360204 <primitive: 105> 360205 super replaceFrom: start to: stop with: replacement startingAt: repStart! ! 360206 360207!String methodsFor: 'private' stamp: 'yo 8/28/2002 15:22'! 360208stringhash 360209 360210 ^ self hash. 360211! ! 360212 360213 360214!String methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 08:14'! 360215asCharacter 360216 "Answer the receiver's first character, or a * if none. Idiosyncratic, provisional." 360217 360218 self deprecated: 'Don''t use it, it''s evil.'. 360219 ^ self size > 0 ifTrue: [self first] ifFalse:[$*]! ! 360220 360221"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 360222 360223String class 360224 instanceVariableNames: ''! 360225 360226!String class methodsFor: 'examples' stamp: 'yo 11/3/2004 19:24'! 360227example 360228 "To see the string displayed at the cursor point, execute this expression 360229 and select a point by pressing a mouse button." 360230 360231 'this is some text' displayOn: Display at: Sensor waitButton! ! 360232 360233 360234!String class methodsFor: 'formatting' stamp: 'md 6/5/2005 07:49'! 360235expandMacro: macroType argument: argument withExpansions: expansions 360236 macroType = $s ifTrue: [^expansions at: argument]. 360237 macroType = $p ifTrue: [^(expansions at: argument) printString]. 360238 macroType = $n ifTrue: [^String cr]. 360239 macroType = $t ifTrue: [^String tab]. 360240 self error: 'unknown expansion type'! ! 360241 360242 360243!String class methodsFor: 'initialization' stamp: 'ar 4/9/2005 22:37'! 360244initialize "self initialize" 360245 360246 | order | 360247 AsciiOrder := (0 to: 255) as: ByteArray. 360248 360249 CaseInsensitiveOrder := AsciiOrder copy. 360250 ($a to: $z) do: 360251 [:c | CaseInsensitiveOrder at: c asciiValue + 1 360252 put: (CaseInsensitiveOrder at: c asUppercase asciiValue +1)]. 360253 360254 "Case-sensitive compare sorts space, digits, letters, all the rest..." 360255 CaseSensitiveOrder := ByteArray new: 256 withAll: 255. 360256 order := -1. 360257 ' 0123456789' do: "0..10" 360258 [:c | CaseSensitiveOrder at: c asciiValue + 1 put: (order := order+1)]. 360259 ($a to: $z) do: "11-64" 360260 [:c | CaseSensitiveOrder at: c asUppercase asciiValue + 1 put: (order := order+1). 360261 CaseSensitiveOrder at: c asciiValue + 1 put: (order := order+1)]. 360262 1 to: CaseSensitiveOrder size do: 360263 [:i | (CaseSensitiveOrder at: i) = 255 ifTrue: 360264 [CaseSensitiveOrder at: i put: (order := order+1)]]. 360265 order = 255 ifFalse: [self error: 'order problem']. 360266 360267 "a table for translating to lower case" 360268 LowercasingTable := String withAll: (Character allByteCharacters collect: [:c | c asLowercase]). 360269 360270 "a table for translating to upper case" 360271 UppercasingTable := String withAll: (Character allByteCharacters collect: [:c | c asUppercase]). 360272 360273 "a table for testing tokenish (for fast numArgs)" 360274 Tokenish := String withAll: (Character allByteCharacters collect: 360275 [:c | c tokenish ifTrue: [c] ifFalse: [$~]]). 360276 360277 "CR and LF--characters that terminate a line" 360278 CSLineEnders := CharacterSet empty. 360279 CSLineEnders add: Character cr. 360280 CSLineEnders add: Character lf. 360281 360282 "separators and non-separators" 360283 CSSeparators := CharacterSet separators. 360284 CSNonSeparators := CSSeparators complement.! ! 360285 360286 360287!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! 360288cr 360289 "Answer a string containing a single carriage return character." 360290 360291 ^ self with: Character cr 360292! ! 360293 360294!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! 360295crlf 360296 "Answer a string containing a carriage return and a linefeed." 360297 360298 ^ self with: Character cr with: Character lf 360299! ! 360300 360301!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! 360302crlfcrlf 360303 ^self crlf , self crlf. 360304! ! 360305 360306!String class methodsFor: 'instance creation' stamp: 'ar 4/10/2005 16:24'! 360307fromByteArray: aByteArray 360308 360309 ^ aByteArray asString 360310! ! 360311 360312!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! 360313fromPacked: aLong 360314 "Convert from a longinteger to a String of length 4." 360315 360316 | s | 360317 s := self new: 4. 360318 s at: 1 put: (aLong digitAt: 4) asCharacter. 360319 s at: 2 put: (aLong digitAt: 3) asCharacter. 360320 s at: 3 put: (aLong digitAt: 2) asCharacter. 360321 s at: 4 put: (aLong digitAt: 1) asCharacter. 360322 ^s 360323 360324"String fromPacked: 'TEXT' asPacked" 360325! ! 360326 360327!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! 360328fromString: aString 360329 "Answer an instance of me that is a copy of the argument, aString." 360330 360331 ^ aString copyFrom: 1 to: aString size! ! 360332 360333!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! 360334lf 360335 "Answer a string containing a single carriage return character." 360336 360337 ^ self with: Character lf! ! 360338 360339!String class methodsFor: 'instance creation' stamp: 'ar 4/10/2005 23:26'! 360340new: sizeRequested 360341 "Answer an instance of this class with the number of indexable 360342 variables specified by the argument, sizeRequested." 360343 self == String 360344 ifTrue:[^ByteString new: sizeRequested] 360345 ifFalse:[^self basicNew: sizeRequested].! ! 360346 360347!String class methodsFor: 'instance creation' stamp: 'PeterHugossonMiller 9/3/2009 11:30'! 360348readFrom: inStream 360349 "Answer an instance of me that is determined by reading the stream, 360350 inStream. Embedded double quotes become the quote Character." 360351 360352 | outStream char done | 360353 outStream := (self new: 16) writeStream. 360354 "go to first quote" 360355 inStream skipTo: $'. 360356 done := false. 360357 [done or: [inStream atEnd]] 360358 whileFalse: 360359 [char := inStream next. 360360 char = $' 360361 ifTrue: 360362 [char := inStream next. 360363 char = $' 360364 ifTrue: [outStream nextPut: char] 360365 ifFalse: [done := true]] 360366 ifFalse: [outStream nextPut: char]]. 360367 ^outStream contents! ! 360368 360369!String class methodsFor: 'instance creation' stamp: 'dc 2/12/2007 10:47'! 360370space 360371 "Answer a string containing a single space character." 360372 360373 ^ self with: Character space 360374! ! 360375 360376!String class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! 360377tab 360378 "Answer a string containing a single tab character." 360379 360380 ^ self with: Character tab 360381! ! 360382 360383!String class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:29'! 360384value: anInteger 360385 360386 ^ self with: (Character value: anInteger). 360387! ! 360388 360389!String class methodsFor: 'instance creation' stamp: 'ar 4/12/2005 17:34'! 360390with: aCharacter 360391 | newCollection | 360392 aCharacter asInteger < 256 360393 ifTrue:[newCollection := ByteString new: 1] 360394 ifFalse:[newCollection := WideString new: 1]. 360395 newCollection at: 1 put: aCharacter. 360396 ^newCollection! ! 360397 360398 360399!String class methodsFor: 'primitives' stamp: 'yo 12/15/2005 13:41'! 360400compare: string1 with: string2 collated: order 360401 "Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array." 360402 360403 | len1 len2 c1 c2 | 360404 order == nil ifTrue: [ 360405 len1 := string1 size. 360406 len2 := string2 size. 360407 1 to: (len1 min: len2) do:[:i | 360408 c1 := (string1 at: i) asInteger. 360409 c2 := (string2 at: i) asInteger. 360410 c1 = c2 ifFalse: [c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]]. 360411 ]. 360412 len1 = len2 ifTrue: [^ 2]. 360413 len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3]. 360414 ]. 360415 len1 := string1 size. 360416 len2 := string2 size. 360417 1 to: (len1 min: len2) do:[:i | 360418 c1 := (string1 at: i) asInteger. 360419 c2 := (string2 at: i) asInteger. 360420 c1 < 256 ifTrue: [c1 := order at: c1 + 1]. 360421 c2 < 256 ifTrue: [c2 := order at: c2 + 1]. 360422 c1 = c2 ifFalse:[c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]]. 360423 ]. 360424 len1 = len2 ifTrue: [^ 2]. 360425 len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3]. 360426! ! 360427 360428!String class methodsFor: 'primitives' stamp: 'nice 3/15/2007 20:59'! 360429findFirstInString: aString inCharacterSet: aCharacterSet startingAt: start 360430 "Trivial, non-primitive version" 360431 360432 start 360433 to: aString size 360434 do: [:i | (aCharacterSet 360435 includes: (aString at: i)) 360436 ifTrue: [^ i]]. 360437 ^ 0! ! 360438 360439!String class methodsFor: 'primitives' stamp: 'nice 5/9/2006 20:17'! 360440findFirstInString: aString inSet: inclusionMap startingAt: start 360441 "Trivial, non-primitive version" 360442 360443 | i stringSize ascii more | 360444 inclusionMap size ~= 256 ifTrue: [^ 0]. 360445 stringSize := aString size. 360446 more := true. 360447 i := start - 1. 360448 [more and: [(i := i + 1) <= stringSize]] whileTrue: [ 360449 ascii := (aString at: i) asciiValue. 360450 more := ascii < 256 ifTrue: [(inclusionMap at: ascii + 1) = 0] ifFalse: [true]. 360451 ]. 360452 360453 i > stringSize ifTrue: [^ 0]. 360454 ^ i! ! 360455 360456!String class methodsFor: 'primitives' stamp: 'ar 4/10/2005 16:36'! 360457indexOfAscii: anInteger inString: aString startingAt: start 360458 "Trivial, non-primitive version" 360459 | stringSize | 360460 stringSize := aString size. 360461 start to: stringSize do: [:pos | 360462 (aString at: pos) asInteger = anInteger ifTrue: [^ pos]]. 360463 ^ 0 360464! ! 360465 360466!String class methodsFor: 'primitives' stamp: 'ar 4/10/2005 16:29'! 360467stringHash: aString initialHash: speciesHash 360468 | stringSize hash low | 360469 stringSize := aString size. 360470 hash := speciesHash bitAnd: 16rFFFFFFF. 360471 1 to: stringSize do: [:pos | 360472 hash := hash + (aString at: pos) asInteger. 360473 "Begin hashMultiply" 360474 low := hash bitAnd: 16383. 360475 hash := (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF. 360476 ]. 360477 ^ hash. 360478! ! 360479 360480!String class methodsFor: 'primitives' stamp: 'ar 4/10/2005 16:36'! 360481translate: aString from: start to: stop table: table 360482 "Trivial, non-primitive version" 360483 | char | 360484 start to: stop do: [:i | 360485 char := (aString at: i) asInteger. 360486 char < 256 ifTrue: [aString at: i put: (table at: char+1)]. 360487 ]. 360488! ! 360489Model subclass: #StringHolder 360490 instanceVariableNames: 'contents' 360491 classVariableNames: '' 360492 poolDictionaries: '' 360493 category: 'ST80-Kernel-Remnants'! 360494!StringHolder commentStamp: '<historical>' prior: 0! 360495I am a kind of Model that includes a piece of text. In some cases, the text can be edited, and in some the text is a method. 360496 360497Categories 'code pane menu' and 'message list menu' are messages that may be called by my menus when the text is a method, and when some pane is a list of methods. Other of my subclasses may ignore these two catagories altogether.! 360498 360499 360500!StringHolder methodsFor: '*services-base' stamp: 'rr 3/15/2004 09:17'! 360501codeTextMorph 360502 ^ self dependents 360503 detect: [:dep | (dep isKindOf: PluggableTextMorph) 360504 and: [dep getTextSelector == #contents]] 360505 ifNone: []! ! 360506 360507!StringHolder methodsFor: '*services-base' stamp: 'rr 6/9/2005 10:47'! 360508requestor 360509 ^ (TextRequestor new) model: self; yourself! ! 360510 360511!StringHolder methodsFor: '*services-base' stamp: 'rr 3/15/2004 09:17'! 360512selectedInterval 360513 ^self codeTextMorph selectionInterval! ! 360514 360515 360516!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360517browseAllMessages 360518 "Create and schedule a message set browser on all implementors of all the messages sent by the current method." 360519 360520 | aClass aName method filteredList | 360521 (aName := self selectedMessageName) ifNotNil: [ 360522 method := (aClass := self selectedClassOrMetaClass) compiledMethodAt: aName. 360523 filteredList := method messages reject: 360524 [:each | #(new initialize = ) includes: each]. 360525 self systemNavigation browseAllImplementorsOfList: filteredList asSortedCollection 360526 title: 'All messages sent in ', aClass name, '.', aName] 360527! ! 360528 360529!StringHolder methodsFor: '*tools' stamp: 'tk 4/18/1998 16:11'! 360530browseClass 360531 "Open an class browser on this class and method" 360532 360533 self selectedClassOrMetaClass ifNotNil: [ 360534 Browser newOnClass: self selectedClassOrMetaClass 360535 selector: self selectedMessageName]! ! 360536 360537!StringHolder methodsFor: '*tools' stamp: 'sd 4/16/2003 08:42'! 360538browseLocalImplementors 360539 "Present a menu of all messages sent by the currently selected message. 360540 Open a message set browser of all implementors of the message chosen in or below 360541 the selected class. 360542 Do nothing if no message is chosen." 360543 self getSelectorAndSendQuery: #browseAllImplementorsOf:localTo: 360544 to: self systemNavigation 360545 with: { self selectedClass }! ! 360546 360547!StringHolder methodsFor: '*tools' stamp: 'sd 4/16/2003 20:41'! 360548browseLocalSendersOfMessages 360549 "Present a menu of the currently selected message, as well as all 360550 messages sent by it. Open a message set browser of all implementors 360551 of the message chosen in or below the selected class" 360552 360553 self getSelectorAndSendQuery: #browseAllCallsOn:localTo: 360554 to: self systemNavigation 360555 with: { self selectedClass }! ! 360556 360557!StringHolder methodsFor: '*tools' stamp: 'sd 4/16/2003 08:45'! 360558browseMessages 360559 "Present a menu of all messages sent by the currently selected message. 360560 Open a message set browser of all implementors of the message chosen." 360561 360562 self getSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation! ! 360563 360564!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360565browseMethodFull 360566 "Create and schedule a full Browser and then select the current class and message." 360567 360568 | myClass | 360569 (myClass := self selectedClassOrMetaClass) ifNotNil: 360570 [Browser fullOnClass: myClass selector: self selectedMessageName]! ! 360571 360572!StringHolder methodsFor: '*tools' stamp: 'sd 4/16/2003 20:40'! 360573browseSendersOfMessages 360574 "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all senders of the selector chosen." 360575 360576 self getSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation! ! 360577 360578!StringHolder methodsFor: '*tools' stamp: 'stephane.ducasse 10/12/2008 21:02'! 360579browseUnusedMethods 360580 | classes unsent messageList cls | 360581 (cls := self selectedClass) 360582 ifNil: [^ self]. 360583 classes := Array with: cls with: cls class. 360584 unsent := Set new. 360585 classes 360586 do: [:c | unsent addAll: c selectors]. 360587 unsent := self systemNavigation allUnsentMessagesIn: unsent. 360588 messageList := OrderedCollection new. 360589 classes 360590 do: [:c | (c selectors 360591 select: [:s | unsent includes: s]) asSortedCollection 360592 do: [:sel | messageList add: c name , ' ' , sel]]. 360593 self systemNavigation browseMessageList: messageList name: 'Unsent Methods in ' , cls name! ! 360594 360595!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360596browseVersions 360597 "Create and schedule a Versions Browser, showing all versions of the 360598 currently selected message. Answer the browser or nil." 360599 | selector class | 360600 self classCommentIndicated 360601 ifTrue: [ ClassCommentVersionsBrowser browseCommentOf: self selectedClass. 360602 ^nil ]. 360603 360604 (selector := self selectedMessageName) 360605 ifNil:[ self inform: 'Sorry, only actual methods have retrievable versions.'. ^nil ] 360606 ifNotNil: [ 360607 class := self selectedClassOrMetaClass. 360608 ^VersionsBrowser 360609 browseVersionsOf: (class compiledMethodAt: selector) 360610 class: self selectedClass 360611 meta: class isMeta 360612 category: (class organization categoryOfElement: selector) 360613 selector: selector]! ! 360614 360615!StringHolder methodsFor: '*tools' stamp: 'tk 4/28/1998 19:14'! 360616buildMessageBrowser 360617 "Create and schedule a message browser." 360618 360619 self selectedMessageName ifNil: [^ self]. 360620 Browser openMessageBrowserForClass: self selectedClassOrMetaClass 360621 selector: self selectedMessageName editString: nil! ! 360622 360623!StringHolder methodsFor: '*tools' stamp: 'sd 1/16/2004 21:14'! 360624classHierarchy 360625 "Create and schedule a class list browser on the receiver's hierarchy." 360626 360627 self systemNavigation 360628 spawnHierarchyForClass: self selectedClassOrMetaClass "OK if nil" 360629 selector: self selectedMessageName 360630! ! 360631 360632!StringHolder methodsFor: '*tools' stamp: 'sw 5/8/2000 02:16'! 360633classListKey: aChar from: view 360634 "Respond to a Command key. I am a model with a list of classes and a 360635 code pane, and I also have a listView that has a list of methods. The 360636 view knows how to get the list and selection." 360637 360638 aChar == $f ifTrue: [^ self findMethod]. 360639 aChar == $r ifTrue: [^ self recent]. 360640 aChar == $h ifTrue: [^ self spawnHierarchy]. 360641 aChar == $x ifTrue: [^ self removeClass]. 360642 ^ self messageListKey: aChar from: view! ! 360643 360644!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360645copyName 360646 "Copy the current selector to the clipboard" 360647 | selector | 360648 (selector := self selectedMessageName) ifNotNil: 360649 [Clipboard clipboardText: selector asString asText]! ! 360650 360651!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360652copySelector 360653 "Copy the selected selector to the clipboard" 360654 360655 | selector | 360656 (selector := self selectedMessageName) ifNotNil: 360657 [Clipboard clipboardText: selector asString]! ! 360658 360659!StringHolder methodsFor: '*tools' stamp: 'sw 7/1/2001 08:24'! 360660fileOutMessage 360661 "Put a description of the selected message on a file" 360662 360663 self selectedMessageName ifNotNil: 360664 [Cursor write showWhile: 360665 [self selectedClassOrMetaClass fileOutMethod: self selectedMessageName]]! ! 360666 360667!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360668findMethodInChangeSets 360669 "Find and open a changeSet containing the current method." 360670 360671 | aName | 360672 (aName := self selectedMessageName) ifNotNil: [ 360673 ChangeSorter browseChangeSetsWithClass: self selectedClassOrMetaClass 360674 selector: aName]! ! 360675 360676!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360677inspectInstances 360678 "Inspect all instances of the selected class." 360679 360680 | myClass | 360681 (myClass := self selectedClassOrMetaClass) ifNotNil: 360682 [myClass theNonMetaClass inspectAllInstances]. 360683! ! 360684 360685!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360686inspectSubInstances 360687 "Inspect all instances of the selected class and all its subclasses" 360688 360689 | aClass | 360690 (aClass := self selectedClassOrMetaClass) ifNotNil: [ 360691 aClass theNonMetaClass inspectSubInstances]. 360692! ! 360693 360694!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360695messageListKey: aChar from: view 360696 "Respond to a Command key. I am a model with a code pane, and I also 360697 have a listView that has a list of methods. The view knows how to get 360698 the list and selection." 360699 360700 | sel class | 360701 aChar == $D ifTrue: [^ self toggleDiffing]. 360702 360703 sel := self selectedMessageName. 360704 aChar == $m ifTrue: "These next two put up a type in if no message selected" 360705 [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation]. 360706 aChar == $n ifTrue: 360707 [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation]. 360708 360709 "The following require a class selection" 360710 (class := self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view]. 360711 aChar == $b ifTrue: [^ Browser fullOnClass: class selector: sel]. 360712 aChar == $N ifTrue: [^ self browseClassRefs]. 360713 aChar == $i ifTrue: [^ self methodHierarchy]. 360714 aChar == $h ifTrue: [^ self classHierarchy]. 360715 aChar == $p ifTrue: [^ self browseFullProtocol]. 360716 360717 "The following require a method selection" 360718 sel ifNotNil: 360719 [aChar == $o ifTrue: [^ self fileOutMessage]. 360720 aChar == $c ifTrue: [^ self copySelector]. 360721 aChar == $v ifTrue: [^ self browseVersions]. 360722 aChar == $O ifTrue: [^ self openSingleMessageBrowser]. 360723 aChar == $x ifTrue: [^ self removeMessage]]. 360724 360725 ^ self arrowKey: aChar from: view! ! 360726 360727!StringHolder methodsFor: '*tools' stamp: 'marcus.denker 11/29/2008 23:23'! 360728messageListSelectorTitle 360729 | selector aString aStamp aSize | 360730 360731 (selector := self selectedMessageName) ifNil: [ 360732 aSize := self messageList size. 360733 ^ (aSize == 0 ifTrue: ['no'] ifFalse: [aSize printString]), ' message', (aSize == 1 ifTrue: [''] ifFalse: ['s'])] ifNotNil: [ 360734 aString := selector truncateWithElipsisTo: 28. 360735 ^ (aStamp := self timeStamp) size > 0 360736 ifTrue: [aString, String cr, aStamp] 360737 ifFalse: [aString]]! ! 360738 360739!StringHolder methodsFor: '*tools' stamp: 'sd 1/16/2004 21:10'! 360740methodHierarchy 360741 "Create and schedule a method browser on the hierarchy of implementors." 360742 360743 self systemNavigation 360744 methodHierarchyBrowserForClass: self selectedClassOrMetaClass 360745 selector: self selectedMessageName 360746! ! 360747 360748!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360749offerDurableMenuFrom: menuRetriever shifted: aBoolean 360750 "Pop up (morphic only) a menu whose target is the receiver and whose contents are provided by sending the menuRetriever to the receiver. The menuRetriever takes two arguments: a menu, and a boolean representing the shift state; put a stay-up item at the top of the menu." 360751 360752 | aMenu | 360753 aMenu := MenuMorph new defaultTarget: self. 360754 aMenu addStayUpItem. 360755 self perform: menuRetriever with: aMenu with: aBoolean. 360756 aMenu popUpInWorld! ! 360757 360758!StringHolder methodsFor: '*tools' stamp: 'alain.plantec 6/1/2008 20:35'! 360759offerMenuFrom: menuRetriever shifted: aBoolean 360760 "Pop up a menu whose target is 360761 the receiver and whose contents are provided by sending the 360762 menuRetriever to the receiver. The menuRetriever takes two arguments: 360763 a menu, and a boolean representing the shift state." 360764 | aMenu | 360765 aMenu := MenuMorph new defaultTarget: self. 360766 self 360767 perform: menuRetriever 360768 with: aMenu 360769 with: aBoolean. 360770 aMenu popUpInWorld! ! 360771 360772!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360773openSingleMessageBrowser 360774 | msgName mr | 360775 "Create and schedule a message list browser populated only by the currently selected message" 360776 360777 (msgName := self selectedMessageName) ifNil: [^ self]. 360778 360779 mr := MethodReference new 360780 setStandardClass: self selectedClassOrMetaClass 360781 methodSymbol: msgName. 360782 360783 self systemNavigation 360784 browseMessageList: (Array with: mr) 360785 name: mr asStringOrText 360786 autoSelect: nil! ! 360787 360788!StringHolder methodsFor: '*tools' stamp: 'RAA 12/10/1999 09:36'! 360789packageListKey: aChar from: view 360790 "Respond to a Command key in the package pane in the PackageBrowser" 360791 aChar == $f ifTrue: [^ self findClass]. 360792 ^ self classListKey: aChar from: view 360793! ! 360794 360795!StringHolder methodsFor: '*tools' stamp: 'sd 5/23/2003 14:42'! 360796removeFromCurrentChanges 360797 "Tell the changes mgr to forget that the current msg was changed." 360798 360799 ChangeSet current removeSelectorChanges: self selectedMessageName 360800 class: self selectedClassOrMetaClass. 360801 self changed: #annotation! ! 360802 360803!StringHolder methodsFor: '*tools' stamp: 'sw 1/28/1999 12:34'! 360804revertAndForget 360805 "Revert to the previous version of the current method, and tell the changes mgr to forget that it was ever changed. Danger!! Use only if you really know what you're doing!!" 360806 360807 self okToChange ifFalse: [^ self]. 360808 self revertToPreviousVersion. 360809 self removeFromCurrentChanges. 360810 self contentsChanged 360811! ! 360812 360813!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360814revertToPreviousVersion 360815 "Revert to the previous version of the current method" 360816 | aClass aSelector changeRecords | 360817 self okToChange ifFalse: [^ self]. 360818 aClass := self selectedClassOrMetaClass. 360819 aClass ifNil: [^ self changed: #flash]. 360820 aSelector := self selectedMessageName. 360821 changeRecords := aClass changeRecordsAt: aSelector. 360822 (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [self changed: #flash. ^ Beeper beep]. 360823 changeRecords second fileIn. 360824 self contentsChanged 360825! ! 360826 360827!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360828selectMessageAndEvaluate: aBlock 360829 "Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector. If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any" 360830 360831 | selector method messages | 360832 (selector := self selectedMessageName) ifNil: [^ self]. 360833 method := (self selectedClassOrMetaClass ifNil: [^ self]) 360834 compiledMethodAt: selector 360835 ifAbsent: []. 360836 (method isNil or: [(messages := method messages) size == 0]) 360837 ifTrue: [^ aBlock value: selector]. 360838 (messages size == 1 and: [messages includes: selector]) 360839 ifTrue: 360840 [^ aBlock value: selector]. "If only one item, there is no choice" 360841 360842 self systemNavigation 360843 showMenuOf: messages 360844 withFirstItem: selector 360845 ifChosenDo: [:sel | aBlock value: sel]! ! 360846 360847!StringHolder methodsFor: '*tools' stamp: 'nk 11/15/2002 12:23'! 360848systemCatListKey: aChar from: view 360849 "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." 360850 360851 aChar == $f ifTrue: [^ self findClass]. 360852 aChar == $x ifTrue: [^ self removeSystemCategory]. 360853 ^ self classListKey: aChar from: view! ! 360854 360855!StringHolder methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 360856timeStamp 360857 "Answer the time stamp for the chosen class and method, if any, else an empty string" 360858 360859 | selector aMethod | 360860 (selector := self selectedMessageName) ifNotNil: 360861 [self selectedClassOrMetaClass 360862 ifNil: 360863 [^ String new] 360864 ifNotNil: 360865 [aMethod := self selectedClassOrMetaClass compiledMethodAt: selector ifAbsent: [nil]. 360866 aMethod ifNotNil: [^ Utilities timeStampForMethod: aMethod]]]. 360867 ^ String new! ! 360868 360869 360870!StringHolder methodsFor: '*tools-traits' stamp: 'al 12/6/2005 22:22'! 360871browseClassRefs 360872 360873 | cls | 360874 cls := self selectedClass. 360875 (cls notNil and: [cls isTrait not]) 360876 ifTrue: [self systemNavigation browseAllCallsOnClass: cls theNonMetaClass] 360877! ! 360878 360879!StringHolder methodsFor: '*tools-traits' stamp: 'al 12/6/2005 22:23'! 360880browseClassVarRefs 360881 "1/17/96 sw: devolve responsibility to the class, so that the code that does the real work can be shared" 360882 360883 | cls | 360884 cls := self selectedClass. 360885 (cls notNil and: [cls isTrait not]) 360886 ifTrue: [self systemNavigation browseClassVarRefs: cls]! ! 360887 360888!StringHolder methodsFor: '*tools-traits' stamp: 'al 12/6/2005 22:22'! 360889browseClassVariables 360890 "Browse the class variables of the selected class. 2/5/96 sw" 360891 | cls | 360892 cls := self selectedClass. 360893 (cls notNil and: [cls isTrait not]) 360894 ifTrue: [self systemNavigation browseClassVariables: cls] 360895! ! 360896 360897!StringHolder methodsFor: '*tools-traits' stamp: 'sd 5/10/2008 17:29'! 360898browseFullProtocol 360899 "Open up a protocol-category browser on the value of the 360900 receiver's current selection." 360901 360902 ^ self spawnFullProtocol! ! 360903 360904!StringHolder methodsFor: '*tools-traits' stamp: 'al 12/6/2005 22:24'! 360905browseInstVarDefs 360906 360907 | cls | 360908 cls := self selectedClassOrMetaClass. 360909 (cls notNil and: [cls isTrait not]) 360910 ifTrue: [self systemNavigation browseInstVarDefs: cls]! ! 360911 360912!StringHolder methodsFor: '*tools-traits' stamp: 'al 12/6/2005 22:24'! 360913browseInstVarRefs 360914 "1/26/96 sw: real work moved to class, so it can be shared" 360915 | cls | 360916 cls := self selectedClassOrMetaClass. 360917 (cls notNil and: [cls isTrait not]) 360918 ifTrue: [self systemNavigation browseInstVarRefs: cls]! ! 360919 360920 360921!StringHolder methodsFor: 'accessing' stamp: 'di 5/19/1998 15:34'! 360922acceptContents: aString 360923 "Set aString to be the contents of the receiver. Return true cuz happy" 360924 360925 self contents: aString. 360926 ^ true! ! 360927 360928!StringHolder methodsFor: 'accessing' stamp: 'nk 4/29/2004 12:32'! 360929classCommentIndicated 360930 "Answer true iff we're viewing the class comment." 360931 ^false! ! 360932 360933!StringHolder methodsFor: 'accessing'! 360934contents 360935 "Answer the contents that the receiver is holding--presumably a string." 360936 360937 ^contents! ! 360938 360939!StringHolder methodsFor: 'accessing' stamp: 'AlexandreBergel 1/16/2009 10:25'! 360940contents: textOrString 360941 "Set textOrString to be the contents of the receiver." 360942 360943 contents := textOrString "asString"! ! 360944 360945!StringHolder methodsFor: 'accessing' stamp: 'tk 4/3/98 22:50'! 360946contentsSelection 360947 "Return the interval of text in the code pane to select when I set the pane's contents" 360948 360949 ^ 1 to: 0 "null selection"! ! 360950 360951!StringHolder methodsFor: 'accessing' stamp: 'sw 12/9/2000 23:59'! 360952noteAcceptanceOfCodeFor: aSelector 360953 "A method has possibly been submitted for the receiver with aSelector as its selector; If the receiver wishes to take soem action here is a chance for it to do so" 360954! ! 360955 360956!StringHolder methodsFor: 'accessing' stamp: 'sw 12/1/2000 11:04'! 360957reformulateList 360958 "If the receiver has a way of reformulating its message list, here is a chance for it to do so"! ! 360959 360960!StringHolder methodsFor: 'accessing' stamp: 'sw 12/6/2000 17:48'! 360961reformulateListNoting: newSelector 360962 "A method has possibly been submitted for the receiver with newSelector as its selector; If the receiver has a way of reformulating its message list, here is a chance for it to do so" 360963 360964 ^ self reformulateList! ! 360965 360966!StringHolder methodsFor: 'accessing' stamp: 'tk 4/18/1998 14:59'! 360967selectedClassName 360968 "I may know what class is currently selected" 360969 360970 self selectedClass ifNotNil: [^ self selectedClass name]. 360971 ^ nil! ! 360972 360973!StringHolder methodsFor: 'accessing' stamp: 'tk 4/18/1998 15:01'! 360974selectedClassOrMetaClass 360975 360976 ^ self selectedClass "I don't know any better"! ! 360977 360978!StringHolder methodsFor: 'accessing' stamp: 'tk 4/18/1998 15:22'! 360979selectedMessageName 360980 360981 ^ nil! ! 360982 360983!StringHolder methodsFor: 'accessing' stamp: 'AlexandreBergel 1/16/2009 10:24'! 360984textContents: aStringOrText 360985 "Set aStringOrText to be the contents of the receiver." 360986 360987 contents := aStringOrText! ! 360988 360989 360990!StringHolder methodsFor: 'code pane menu' stamp: 'dgd 10/1/2004 13:43'! 360991codePaneMenu: aMenu shifted: shifted 360992 "Note that unless we override perform:orSendTo:, 360993 PluggableTextController will respond to all menu items in a 360994 text pane" 360995 | donorMenu | 360996 donorMenu := shifted 360997 ifTrue: [ParagraphEditor shiftedYellowButtonMenu] 360998 ifFalse: [ParagraphEditor yellowButtonMenu]. 360999 ^ aMenu addAllFrom: donorMenu! ! 361000 361001!StringHolder methodsFor: 'code pane menu' stamp: 'AlexandreBergel 1/16/2009 10:37'! 361002perform: selector orSendTo: otherTarget 361003 "Selector was just chosen from a menu by a user. If can respond, then 361004perform it on myself. If not, send it to otherTarget, presumably the 361005editPane from which the menu was invoked." 361006 361007 ^ (self respondsTo: selector) 361008 ifTrue: [ self perform: selector] 361009 ifFalse: [ otherTarget perform: selector]! ! 361010 361011!StringHolder methodsFor: 'code pane menu' stamp: 'tk 4/6/98 11:43'! 361012showBytecodes 361013 "We don't know how to do this" 361014 361015 ^ self changed: #flash! ! 361016 361017 361018!StringHolder methodsFor: 'evaluation'! 361019doItContext 361020 "Answer the context in which a text selection can be evaluated." 361021 361022 ^nil! ! 361023 361024!StringHolder methodsFor: 'evaluation'! 361025doItReceiver 361026 "Answer the object that should be informed of the result of evaluating a 361027 text selection." 361028 361029 ^nil! ! 361030 361031 361032!StringHolder methodsFor: 'initialization'! 361033defaultContents 361034 361035 ^''! ! 361036 361037!StringHolder methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:07'! 361038initialize 361039 "Initialize the state of the receiver with its default contents." 361040 361041 super initialize. 361042 contents := self defaultContents. 361043! ! 361044 361045!StringHolder methodsFor: 'initialization' stamp: 'wiz 1/3/2007 14:27'! 361046openAsMorphLabel: labelString 361047 "Workspace new openAsMorphLabel: 'Workspace'" 361048 ^(self embeddedInMorphicWindowLabeled: labelString) openInWorld! ! 361049 361050!StringHolder methodsFor: 'initialization' stamp: 'alain.plantec 6/1/2008 20:36'! 361051openLabel: aString andTerminate: terminateBoolean 361052 "Create a standard system view of the model, me, a StringHolder and open it.; do not terminate the active process if in mvc" 361053 361054 ^ self openAsMorphLabel: aString! ! 361055 361056 361057!StringHolder methodsFor: 'initialize-release' stamp: 'jmv 5/10/2009 09:32'! 361058embeddedInMorphicWindowLabeled: labelString 361059 361060 ^self embeddedInMorphicWindowLabeled: labelString wrap: true! ! 361061 361062!StringHolder methodsFor: 'initialize-release' stamp: 'jmv 5/10/2009 09:42'! 361063embeddedInMorphicWindowLabeled: labelString wrap: aBoolean 361064 | window | 361065 window := (SystemWindow labelled: labelString) model: self. 361066 window addMorph: ((PluggableTextMorph 361067 on: self 361068 text: #contents 361069 accept: #acceptContents: 361070 readSelection: nil 361071 menu: #codePaneMenu:shifted:) 361072 wrapFlag: aBoolean) 361073 frame: (0@0 corner: 1@1). 361074 ^ window! ! 361075 361076!StringHolder methodsFor: 'initialize-release' stamp: 'jmv 5/10/2009 09:21'! 361077openLabel: aString 361078 "Create a standard system view of the model, me, a StringHolder and open it. If in mvc, terminate the active controller so that the new window will immediately be activated." 361079 self openAsMorphLabel: aString! ! 361080 361081!StringHolder methodsFor: 'initialize-release' stamp: 'jmv 5/10/2009 09:37'! 361082openLabel: aString wrap: aBoolean 361083 361084 "Create a standard system view of the model, me, a StringHolder and open it." 361085 (self embeddedInMorphicWindowLabeled: aString wrap: aBoolean) openInWorld! ! 361086 361087 361088!StringHolder methodsFor: 'optional panes' stamp: 'sw 1/24/2001 21:25'! 361089wantsAnnotationPane 361090 "Answer whether the receiver, seen in some browser window, would like to have the so-called annotationpane included. By default, various browsers defer to the global preference 'optionalButtons' -- but individual subclasses can insist to the contrary." 361091 361092 ^ Preferences annotationPanes! ! 361093 361094!StringHolder methodsFor: 'optional panes' stamp: 'sw 1/24/2001 18:57'! 361095wantsOptionalButtons 361096 "Answer whether the receiver, seen in some browser window, would like to have the so-called optional button pane included. By default, various browsers defer to the global preference 'optionalButtons' -- but individual subclasses can insist to the contrary." 361097 361098 ^ Preferences optionalButtons! ! 361099 361100 361101!StringHolder methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 20:36'! 361102buildWith: builder 361103 | windowSpec textSpec | 361104 windowSpec := builder pluggableWindowSpec new. 361105 windowSpec model: self. 361106 windowSpec label: 'Workspace'. 361107 windowSpec children: OrderedCollection new. 361108 textSpec := builder pluggableTextSpec new. 361109 textSpec 361110 model: self; 361111 getText: #contents; 361112 setText: #acceptContents:; 361113 selection: nil; 361114 menu: #codePaneMenu:shifted:; 361115 frame: (0@0corner: 1@1). 361116 windowSpec children add: textSpec. 361117 361118 ^builder build: windowSpec! ! 361119 361120 361121!StringHolder methodsFor: 'user edits' stamp: 'di 4/21/1998 11:30'! 361122clearUserEditFlag 361123 "Clear the hasUnacceptedEdits flag in all my dependent views." 361124 361125 self changed: #clearUserEdits! ! 361126 361127!StringHolder methodsFor: 'user edits' stamp: 'tk 4/13/1998 23:07'! 361128okToChange 361129 361130 self canDiscardEdits ifTrue: [^ true]. 361131 self changed: #wantToChange. "Solicit cancel from view" 361132 ^ self canDiscardEdits 361133! ! 361134 361135"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 361136 361137StringHolder class 361138 instanceVariableNames: ''! 361139 361140!StringHolder class methodsFor: 'initialization'! 361141initialize 361142 "The class variables were initialized once, and subsequently filled with 361143 information. Re-executing this method is therefore dangerous." 361144 361145 "workSpace := StringHolder new" 361146 361147 "StringHolder initialize"! ! 361148 361149 361150!StringHolder class methodsFor: 'instance creation' stamp: 'ar 9/27/2005 20:48'! 361151open 361152 (Smalltalk at: #Workspace ifAbsent:[self]) new openLabel: 'Workspace' 361153 "Not to be confused with our own class var 'Workspace'"! ! 361154 361155!StringHolder class methodsFor: 'instance creation' stamp: 'wiz 1/3/2007 14:23'! 361156openLabel: aString 361157 361158 ^self new openLabel: aString! ! 361159 361160 361161!StringHolder class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:44'! 361162windowColorSpecification 361163 "Answer a WindowColorSpec object that declares my preference" 361164 361165 ^ WindowColorSpec classSymbol: self name wording: 'Workspace' brightColor: #lightYellow pastelColor: #paleYellow helpMessage: 'A place for text in a window.'! ! 361166Morph subclass: #StringMorph 361167 instanceVariableNames: 'font emphasis contents hasFocus' 361168 classVariableNames: '' 361169 poolDictionaries: '' 361170 category: 'Morphic-Basic'! 361171!StringMorph commentStamp: 'efc 3/7/2003 17:34' prior: 0! 361172StringMorph is a "lightweight" Morph to display a String. It supports only a single font, color, and emphasis combination. For multiple text styles, use TextMorph. 361173 361174Structure: 361175instance var Type Description 361176font StrikeFont (normally nil; then the accessor #font gives back TextStyle 361177 or nil defaultFont) 361178emphasis SmallInteger bitmask determining character attributes (underline, bold, italics, narrow, struckout) 361179contents String The text that will be displayed. 361180hasFocus Boolean Do I have the keyboard focus or not? 361181 361182If you shift-click on a StringMorph you can edit its string. This is accomplished the following way: StringMorph can launch a StringMorphEditor if it receives a #mouseDown event. 361183 361184A StringMorph may also be used like a SimpleButtonMorph to do an action when clicked. Use the menu 'extras' / 'add mouseUpAction'. 361185 361186The following propery will be defined: 361187aStringMorph valueOfProperty: #mouseUpCodeToRun! 361188]style[(11 20 5 14 6 97 9 14 47 9 10 53 9 40 12 108 6 49 7 168 17 75 17 163)f1LStringMorph Hierarchy;,f1,f1LMorph Comment;,f1,f1LString Comment;,f1,f1LTextMorph Comment;,f1,f1i,f1,f1LStrikeFont Comment;,f1,f1LTextStyle Comment;,f1,f1LSmallInteger Comment;,f1,f1LString Comment;,f1,f1LBoolean Comment;,f1,f1LStringMorphEditor Comment;,f1,f1LSimpleButtonMorph Comment;,f1! 361189 361190 361191!StringMorph methodsFor: '*FreeType-override' stamp: 'tween 3/2/2008 10:41'! 361192changeFont 361193 | newFont chooser| 361194 "newFont := StrikeFont fromUser: self fontToUse." 361195 chooser := self openModal: ( 361196 Cursor wait showWhile: [FontChooser 361197 windowTitle: 'Choose a Font' 361198 for: self 361199 setSelector: #font: 361200 getSelector: self fontToUse]). 361201 newFont := chooser result. 361202 newFont ifNotNil:[self font: newFont].! ! 361203 361204 361205!StringMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/9/2007 12:29'! 361206paneColor 361207 "Answer the window's pane color or our owner's color otherwise." 361208 361209 ^self paneColorOrNil ifNil: [self owner ifNil: [Color transparent] ifNotNil: [self owner color]]! ! 361210 361211 361212!StringMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/22/2007 12:18'! 361213handlesMouseDown: evt 361214 "If the shift key is pressed then yes. 361215 As normal if the editableStringMorphs preference is false." 361216 361217 ^(Preferences editableStringMorphs and: [ 361218 evt shiftPressed and: [self wantsKeyboardFocusOnShiftClick]]) 361219 ifTrue: [true] 361220 ifFalse: [super handlesMouseDown: evt]! ! 361221 361222!StringMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/4/2007 12:24'! 361223measureContents 361224 "Round up in case fractional." 361225 361226 | f | 361227 f := self fontToUse. 361228 ^(((f widthOfString: contents) max: self minimumWidth) @ f height) ceiling! ! 361229 361230!StringMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/15/2007 13:18'! 361231minHeight 361232 "Answer the minimum height of the receiver." 361233 361234 ^self fontToUse height max: super minHeight! ! 361235 361236!StringMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/22/2007 12:14'! 361237mouseDown: evt 361238 "If the shift key is pressed, make this string the keyboard input focus. 361239 Process as normal if the editableStringMorphs preference is false." 361240 361241 (Preferences editableStringMorphs and: [ 361242 evt shiftPressed and: [self wantsKeyboardFocusOnShiftClick]]) 361243 ifTrue: [self launchMiniEditor: evt] 361244 ifFalse: [super mouseDown: evt]. 361245! ! 361246 361247!StringMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/4/2007 12:24'! 361248setWidth: width 361249 "Round up in case fractional." 361250 361251 self extent: (width @ (font ifNil: [TextStyle defaultFont]) height) ceiling! ! 361252 361253 361254!StringMorph methodsFor: 'accessing'! 361255contents 361256 361257 ^ contents! ! 361258 361259!StringMorph methodsFor: 'accessing'! 361260contentsClipped: aString 361261 "Change my text, but do not change my size as a result" 361262 contents = aString ifTrue: [^ self]. "No substantive change" 361263 contents := aString. 361264 self changed! ! 361265 361266!StringMorph methodsFor: 'accessing' stamp: 'nk 2/26/2004 13:15'! 361267contents: newContents 361268 | scanner | 361269 contents := newContents isText 361270 ifTrue: [scanner := StringMorphAttributeScanner new initializeFromStringMorph: self. 361271 (newContents attributesAt: 1 forStyle: self font textStyle) 361272 do: [:attr | attr emphasizeScanner: scanner]. 361273 emphasis := scanner emphasis. 361274 font := scanner font emphasis: emphasis. 361275 color := scanner textColor. 361276 newContents string] 361277 ifFalse: [contents = newContents 361278 ifTrue: [^ self]. 361279 "no substantive change" 361280 newContents]. 361281 self fitContents! ! 361282 361283!StringMorph methodsFor: 'accessing' stamp: 'ar 12/12/2001 02:44'! 361284fitContents 361285 361286 | newBounds boundsChanged | 361287 newBounds := self measureContents. 361288 boundsChanged := bounds extent ~= newBounds. 361289 self extent: newBounds. "default short-circuits if bounds not changed" 361290 boundsChanged ifFalse: [self changed]! ! 361291 361292!StringMorph methodsFor: 'accessing' stamp: 'ar 1/31/2001 19:33'! 361293font 361294 "who came up with #fontToUse rather than font?!!" 361295 ^self fontToUse! ! 361296 361297!StringMorph methodsFor: 'accessing' stamp: 'tk 8/28/2000 13:59'! 361298fontName: fontName size: fontSize 361299 361300 ^ self font: (StrikeFont familyName: fontName size: fontSize) 361301 emphasis: 0! ! 361302 361303!StringMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 23:07'! 361304fontToUse 361305 | fontToUse | 361306 fontToUse := font isNil ifTrue: [TextStyle defaultFont] ifFalse: [font]. 361307 (emphasis isNil or: [emphasis = 0]) 361308 ifTrue: [^fontToUse] 361309 ifFalse: [^fontToUse emphasized: emphasis]! ! 361310 361311!StringMorph methodsFor: 'accessing' stamp: 'di 4/2/1999 16:11'! 361312font: aFont emphasis: emphasisCode 361313 font := aFont. 361314 emphasis := emphasisCode. 361315 self fitContents. 361316" 361317in inspector say, 361318 self font: (TextStyle default fontAt: 2) emphasis: 1 361319"! ! 361320 361321!StringMorph methodsFor: 'accessing' stamp: 'sw 2/18/2003 02:55'! 361322getCharacters 361323 "obtain a string value from the receiver." 361324 361325 ^ self contents! ! 361326 361327!StringMorph methodsFor: 'accessing' stamp: 'jmv 9/7/2009 00:34'! 361328hasTranslucentColor 361329 361330 ^true! ! 361331 361332!StringMorph methodsFor: 'accessing' stamp: 'sw 9/8/1999 11:10'! 361333interimContents: aString 361334 "The receiver is under edit and aString represents the string the user sees as she edits, which typically will not have been accepted and indeed may be abandoned" 361335 361336 self contents: aString! ! 361337 361338!StringMorph methodsFor: 'accessing' stamp: 'sw 9/8/1999 13:44'! 361339minimumWidth 361340 "Answer the minimum width that the receiver can have. A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!! Obeyed by fitContents." 361341 361342 ^ 3! ! 361343 361344!StringMorph methodsFor: 'accessing' stamp: 'tk 12/16/1998 11:55'! 361345userString 361346 "Do I have a text string to be searched on?" 361347 361348 ^ contents! ! 361349 361350!StringMorph methodsFor: 'accessing' stamp: 'sw 9/16/1999 22:57'! 361351valueFromContents 361352 "Return a new value from the current contents string." 361353 ^ contents! ! 361354 361355 361356!StringMorph methodsFor: 'drawing' stamp: 'StephaneDucasse 8/27/2009 17:06'! 361357areasRemainingToFill: aRectangle 361358 361359 ^ Array with: aRectangle! ! 361360 361361!StringMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:38'! 361362drawOn: aCanvas 361363 361364 aCanvas drawString: contents in: bounds font: self fontToUse color: color.! ! 361365 361366!StringMorph methodsFor: 'drawing' stamp: 'jmv 9/7/2009 00:36'! 361367imageForm: depth forRectangle: rect 361368 | canvas | 361369 canvas := Display defaultCanvasClass extent: rect extent depth: depth. 361370 canvas form fillColor: Color white. 361371 canvas translateBy: rect topLeft negated 361372 during:[:tempCanvas| tempCanvas fullDrawMorph: self]. 361373 ^ canvas form offset: rect topLeft! ! 361374 361375!StringMorph methodsFor: 'drawing' stamp: 'tk 8/1/2001 14:15'! 361376lookTranslucent 361377 361378 "keep the text the same color (black)"! ! 361379 361380 361381!StringMorph methodsFor: 'editing'! 361382acceptContents 361383 "The message is sent when the user hits enter or Cmd-S. Accept the current contents and end editing. This default implementation does nothing." 361384! ! 361385 361386!StringMorph methodsFor: 'editing' stamp: 'sw 9/8/1999 17:04'! 361387acceptValue: aValue 361388 | val | 361389 self contents: (val := aValue asString). 361390 ^ val! ! 361391 361392!StringMorph methodsFor: 'editing' stamp: 'sw 9/17/1999 13:27'! 361393cancelEdits 361394 361395 self doneWithEdits! ! 361396 361397!StringMorph methodsFor: 'editing' stamp: 'di 9/6/1999 22:44'! 361398doneWithEdits 361399 361400 hasFocus := false! ! 361401 361402!StringMorph methodsFor: 'editing' stamp: 'nk 2/24/2005 20:11'! 361403launchMiniEditor: evt 361404 361405 | textMorph | 361406 hasFocus := true. "Really only means edit in progress for this morph" 361407 textMorph := StringMorphEditor new contentsAsIs: contents. 361408 textMorph beAllFont: self fontToUse. 361409 textMorph bounds: (self bounds expandBy: 0@2). 361410 self addMorphFront: textMorph. 361411 evt hand newKeyboardFocus: textMorph. 361412 textMorph editor selectFrom: 1 to: textMorph paragraph text string size! ! 361413 361414!StringMorph methodsFor: 'editing' stamp: 'sw 9/8/1999 10:42'! 361415lostFocusWithoutAccepting 361416 "The message is sent when the user, having been in an editing episode on the receiver, changes the keyboard focus -- typically by clicking on some editable text somewhere else -- without having accepted the current edits." 361417 361418 self acceptContents! ! 361419 361420!StringMorph methodsFor: 'editing' stamp: 'sw 7/21/1999 14:59'! 361421wantsKeyboardFocusOnShiftClick 361422 ^ owner topRendererOrSelf wantsKeyboardFocusFor: self 361423! ! 361424 361425 361426!StringMorph methodsFor: 'event handling' stamp: 'sw 9/8/1999 11:26'! 361427hasFocus 361428 ^ hasFocus! ! 361429 361430!StringMorph methodsFor: 'event handling' stamp: 'sw 5/6/1998 15:45'! 361431wouldAcceptKeyboardFocus 361432 ^ self isLocked not! ! 361433 361434 361435!StringMorph methodsFor: 'font' stamp: 'efc 2/22/2003 21:35'! 361436emphasis: aNumber 361437 "Set the receiver's emphasis as indicated. aNumber is a bitmask with the following format: 361438 361439 bit attribute 361440 1 bold 361441 2 italic 361442 4 underlined 361443 8 narrow 361444 16 struckOut" 361445 361446 "examples: 0 -> plain. 361447 1 -> bold. 2 -> italic. 3 -> bold italic. 4 -> underlined 361448 5 -> bold underlined. 6 -> italic underlined. 7 -> bold italic underlined 361449 etc..." 361450 361451 emphasis := aNumber. 361452 ^ self font: font emphasis: emphasis! ! 361453 361454 361455!StringMorph methodsFor: 'halos and balloon help' stamp: 'sw 6/15/1998 15:34'! 361456addOptionalHandlesTo: aHalo box: box 361457 self flag: #deferred. 361458 361459 "Eventually... 361460 self addFontHandlesTo: aHalo box: box"! ! 361461 361462!StringMorph methodsFor: 'halos and balloon help' stamp: 'sw 6/6/2001 13:34'! 361463boundsForBalloon 361464 "Some morphs have bounds that are way too big. This is a contorted way of making things work okay in PluggableListMorphs, whose list elements historically have huge widths" 361465 361466 | ownerOwner | 361467 ^ ((owner notNil and: [(ownerOwner := owner owner) notNil]) and: 361468 [ownerOwner isKindOf: PluggableListMorph]) 361469 ifTrue: 361470 [self boundsInWorld intersect: ownerOwner boundsInWorld] 361471 ifFalse: 361472 [super boundsForBalloon]! ! 361473 361474 361475!StringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'! 361476defaultColor 361477 "answer the default color/fill style for the receiver" 361478 ^ Color black! ! 361479 361480!StringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42'! 361481initialize 361482"initialize the state of the receiver" 361483 super initialize. 361484"" 361485 font := nil. 361486 emphasis := 0. 361487 hasFocus := false! ! 361488 361489!StringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:57'! 361490initWithContents: aString font: aFont emphasis: emphasisCode 361491 super initialize. 361492 361493 font := aFont. 361494 emphasis := emphasisCode. 361495 hasFocus := false. 361496 self contents: aString! ! 361497 361498 361499!StringMorph methodsFor: 'layout' stamp: 'nk 5/11/2001 09:33'! 361500fullBounds 361501 self contents ifNil: [ self contents: 'String Morph' ]. 361502 ^super fullBounds! ! 361503 361504 361505!StringMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:17'! 361506addCustomMenuItems: aCustomMenu hand: aHandMorph 361507 361508 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 361509 aCustomMenu add: 'change font' translated action: #changeFont. 361510 aCustomMenu add: 'change emphasis' translated action: #changeEmphasis. 361511! ! 361512 361513!StringMorph methodsFor: 'menu' stamp: 'alain.plantec 2/6/2009 17:29'! 361514changeEmphasis 361515 361516 | reply aList | 361517 aList := #(normal bold italic narrow underlined struckOut). 361518 reply := UIManager default chooseFrom: (aList collect: [:t | t translated]) values: aList. 361519 reply ifNotNil:[ 361520 self emphasis: (TextEmphasis perform: reply) emphasisCode. 361521 ]. 361522! ! 361523 361524 361525!StringMorph methodsFor: 'objects from disk' stamp: 'tk 11/29/2004 16:52'! 361526fixUponLoad: aProject seg: anImageSegment 361527 "We are in an old project that is being loaded from disk. 361528Fix up conventions that have changed." 361529 361530 | substituteFont | 361531 substituteFont := aProject projectParameters at: 361532#substitutedFont ifAbsent: [#none]. 361533 (substituteFont ~~ #none and: [self font == substituteFont]) 361534 ifTrue: [ self fitContents ]. 361535 361536 ^ super fixUponLoad: aProject seg: anImageSegment! ! 361537 361538 361539!StringMorph methodsFor: 'parts bin' stamp: 'dgd 2/14/2003 21:58'! 361540initializeToStandAlone 361541 super initializeToStandAlone. 361542 361543 font := nil. 361544 emphasis := 0. 361545 hasFocus := false. 361546 self contents: 'String: Shift-click on me to edit'! ! 361547 361548 361549!StringMorph methodsFor: 'printing' stamp: 'efc 2/22/2003 21:35'! 361550font: aFont 361551 "Set the font my text will use. The emphasis remains unchanged." 361552 361553 font := aFont. 361554 ^ self font: font emphasis: emphasis! ! 361555 361556!StringMorph methodsFor: 'printing' stamp: 'jm 11/3/97 16:52'! 361557printOn: aStream 361558 361559 super printOn: aStream. 361560 aStream print: contents. 361561! ! 361562 361563"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 361564 361565StringMorph class 361566 instanceVariableNames: ''! 361567 361568!StringMorph class methodsFor: 'instance creation' stamp: 'sw 8/22/97 22:19'! 361569contents: aString 361570 " 'StringMorph contents: str' is faster than 'StringMorph new contents: str' " 361571 ^ self contents: aString font: nil! ! 361572 361573!StringMorph class methodsFor: 'instance creation' stamp: 'di 4/1/1999 17:15'! 361574contents: aString font: aFont 361575 ^ self basicNew initWithContents: aString font: aFont emphasis: 0! ! 361576 361577!StringMorph class methodsFor: 'instance creation' stamp: 'di 4/1/1999 17:15'! 361578contents: aString font: aFont emphasis: emphasisCode 361579 ^ self basicNew initWithContents: aString font: aFont emphasis: emphasisCode! ! 361580 361581 361582!StringMorph class methodsFor: 'scripting' stamp: 'sw 5/6/1998 14:00'! 361583authoringPrototype 361584 ^ super authoringPrototype contents: 'String'! ! 361585 361586 361587!StringMorph class methodsFor: 'testing' stamp: 'di 5/6/1998 21:07'! 361588test 361589 "Return a morph with lots of strings for testing display speed." 361590 | c | 361591 c := AlignmentMorph newColumn. 361592 SystemOrganization categories do: 361593 [:cat | c addMorph: (StringMorph new contents: cat)]. 361594 ^ c! ! 361595 361596!StringMorph class methodsFor: 'testing' stamp: 'di 5/6/1998 21:08'! 361597test2 361598 "Return a morph with lots of strings for testing display speed." 361599 | c r | 361600 c := AlignmentMorph newColumn. 361601 SystemOrganization categories reverseDo: 361602 [:cat | c addMorph: (StringMorph new contents: cat)]. 361603 r := RectangleMorph new extent: c fullBounds extent. 361604 c submorphsDo: [:m | r addMorph: m]. 361605 ^ r 361606! ! 361607Object subclass: #StringMorphAttributeScanner 361608 instanceVariableNames: 'fontNumber textColor emphasis alignment actualFont indent kern' 361609 classVariableNames: '' 361610 poolDictionaries: '' 361611 category: 'Morphic-Text Support'! 361612!StringMorphAttributeScanner commentStamp: '<historical>' prior: 0! 361613A StringMorphAttributeScanner provides the interface of a CharacterScanner so that text attributes may be collected from a Text and used elsewhere, like in setting the attributes of a StringMorph. 361614! 361615]style[(2 195)cblack;,f3cblack;! 361616 361617 361618!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 13:12'! 361619actualFont 361620 "Answer the value of actualFont" 361621 361622 ^ actualFont ifNil: [ TextStyle defaultFont ]! ! 361623 361624!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 12:34'! 361625alignment 361626 "Answer the value of alignment" 361627 361628 ^ alignment! ! 361629 361630!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 12:34'! 361631emphasis 361632 "Answer the value of emphasis" 361633 361634 ^ emphasis! ! 361635 361636!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 13:14'! 361637font 361638 "Answer the value of font" 361639 361640 ^self textStyle fontAt: self fontNumber! ! 361641 361642!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 13:11'! 361643fontNumber 361644 "Answer the value of font" 361645 361646 ^ fontNumber! ! 361647 361648!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 12:34'! 361649indent 361650 "Answer the value of indent" 361651 361652 ^ indent! ! 361653 361654!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 12:34'! 361655kern 361656 "Answer the value of kern" 361657 361658 ^ kern! ! 361659 361660!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 12:34'! 361661textColor 361662 "Answer the value of textColor" 361663 361664 ^ textColor! ! 361665 361666!StringMorphAttributeScanner methodsFor: 'accessing' stamp: 'nk 2/26/2004 13:12'! 361667textStyle 361668 ^self actualFont textStyle ifNil: [ TextStyle default ]! ! 361669 361670 361671!StringMorphAttributeScanner methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:07'! 361672initialize 361673 super initialize. 361674 emphasis := 0. 361675 indent := 0. 361676 kern := 0. 361677 fontNumber := 1. 361678 actualFont := TextStyle defaultFont! ! 361679 361680 361681!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'nk 2/26/2004 12:40'! 361682addEmphasis: anInteger 361683 "Set the value of emphasis" 361684 361685 emphasis := emphasis bitOr: anInteger! ! 361686 361687!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'nk 2/26/2004 12:41'! 361688addKern: kernDelta 361689 "Set the current kern amount." 361690 kern := kern + kernDelta! ! 361691 361692!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'nk 2/26/2004 12:37'! 361693indentationLevel: anInteger 361694 "Set the value of indent" 361695 361696 indent := anInteger! ! 361697 361698!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'marcus.denker 11/10/2008 10:04'! 361699setActualFont: aFont 361700 "Set the value of actualFont, from a TextFontReference" 361701 361702 actualFont := aFont. 361703 aFont textStyle ifNotNil: [ :ts | fontNumber := ts fontIndexOf: aFont ]! ! 361704 361705!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'nk 2/26/2004 12:39'! 361706setAlignment: aSymbol 361707 "Set the value of alignment" 361708 361709 alignment := aSymbol! ! 361710 361711!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'nk 2/26/2004 13:10'! 361712setFont: fontNum 361713 "Set the value of font" 361714 361715 fontNumber := fontNum! ! 361716 361717!StringMorphAttributeScanner methodsFor: 'scanning' stamp: 'nk 2/26/2004 12:34'! 361718textColor: anObject 361719 "Set the value of textColor" 361720 361721 textColor := anObject! ! 361722 361723 361724!StringMorphAttributeScanner methodsFor: 'string morph' stamp: 'nk 2/26/2004 13:09'! 361725initializeFromStringMorph: aStringMorph 361726 | style | 361727 actualFont := aStringMorph font ifNil: [ TextStyle defaultFont ]. 361728 style := actualFont textStyle. 361729 emphasis := actualFont emphasis. 361730 fontNumber := (style fontIndexOf: actualFont) ifNil: [ 1 ]. 361731 textColor := aStringMorph color. 361732! ! 361733TextMorph subclass: #StringMorphEditor 361734 instanceVariableNames: '' 361735 classVariableNames: '' 361736 poolDictionaries: '' 361737 category: 'Morphic-Text Support'! 361738!StringMorphEditor commentStamp: '<historical>' prior: 0! 361739I am a textMorph used as a pop-up editor for StringMorphs. I present a yellow background and I go away when a CR is typed or when the user clicks elsewhere.! 361740 361741 361742!StringMorphEditor methodsFor: 'display' stamp: 'alain.plantec 5/28/2009 11:08'! 361743initialize 361744 "Initialize the receiver. Give it a white background" 361745 361746 super initialize. 361747 self backgroundColor: Color white. 361748 self color: Color red! ! 361749 361750 361751!StringMorphEditor methodsFor: 'drawing' stamp: 'sw 9/7/1999 16:22'! 361752drawOn: aCanvas 361753 361754 aCanvas fillRectangle: self bounds color: Color yellow muchLighter. 361755 ^ super drawOn: aCanvas! ! 361756 361757 361758!StringMorphEditor methodsFor: 'event handling' stamp: 'nk 6/12/2004 22:07'! 361759keyStroke: evt 361760 "This is hugely inefficient, but it seems to work, and it's unlikely it will ever need 361761 to be any more efficient -- it's only intended to edit single-line strings." 361762 361763 | char priorEditor newSel | 361764 (((char := evt keyCharacter) = Character enter) or: [(char = Character cr) 361765 or: [char = $s and: [evt commandKeyPressed]]]) 361766 ifTrue: [owner doneWithEdits; acceptContents. 361767 self flag: #arNote. "Probably unnecessary" 361768 evt hand releaseKeyboardFocus. 361769 ^ self delete]. 361770 361771 (char = $l and: [evt commandKeyPressed]) ifTrue: "cancel" 361772 [owner cancelEdits. 361773 evt hand releaseKeyboardFocus. 361774 ^ self delete]. 361775 361776 super keyStroke: evt. 361777 owner interimContents: self contents asString. 361778 newSel := self editor selectionInterval. 361779 361780 priorEditor := self editor. "Save editor state" 361781 self releaseParagraph. "Release paragraph so it will grow with selection." 361782 self paragraph. "Re-instantiate to set new bounds" 361783 self installEditorToReplace: priorEditor. "restore editor state" 361784 self editor selectFrom: newSel first to: newSel last. 361785! ! 361786 361787!StringMorphEditor methodsFor: 'event handling' stamp: 'nk 1/23/2004 13:18'! 361788keyboardFocusChange: aBoolean 361789 | hadFocus | 361790 owner ifNil: [ ^self ]. 361791 hadFocus := owner hasFocus. 361792 super keyboardFocusChange: aBoolean. 361793 aBoolean ifFalse: 361794 [hadFocus ifTrue: 361795 [owner lostFocusWithoutAccepting; doneWithEdits]. 361796 ^ self delete]! ! 361797 361798"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 361799 361800StringMorphEditor class 361801 instanceVariableNames: ''! 361802 361803!StringMorphEditor class methodsFor: 'new-morph participation' stamp: 'kfr 5/1/2000 13:41'! 361804includeInNewMorphMenu 361805 "Not to be instantiated from the menu" 361806 ^ false! ! 361807CollectionRootTest subclass: #StringTest 361808 uses: TIncludesTest + TCloneTest + TCopyTest + TSetArithmetic + TIterateSequencedReadableTest + TPrintOnSequencedTest + TAsStringCommaAndDelimiterSequenceableTest + TIndexAccess + TSequencedElementAccessTest + TSubCollectionAccess + TPutBasicTest + TCopySequenceableSameContents + TCopyPartOfSequenceable + TCopyPartOfSequenceableForMultipliness + TCopySequenceableWithOrWithoutSpecificElements + TCopySequenceableWithReplacement + TReplacementSequencedTest + TConvertTest - {#testAsByteArray} + TConvertAsSortedTest + TBeginsEndsWith + TIndexAccessForMultipliness - {#testIdentityIndexOfIAbsentDuplicate. #testIdentityIndexOfDuplicate. #collectionWithNonIdentitySameAtEndAndBegining} + TSequencedConcatenationTest + TPutTest + TConvertAsSetForMultiplinessTest + TSortTest + TSequencedStructuralEqualityTest + TOccurrencesForMultiplinessTest + TCreationWithTest 361809 instanceVariableNames: 'string emptyString elementInNonEmpty notIn subcollection nonEmpty1element withoutEqualElements collectionNotIncluded indexInNonEmptyArray valueArray sameAtEndAndBegining nonEmpty5ElementsSorted unsortedCollection' 361810 classVariableNames: '' 361811 poolDictionaries: '' 361812 category: 'CollectionsTests-Text'! 361813!StringTest commentStamp: '<historical>' prior: 0! 361814This is the unit test for the class String. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 361815 - http://www.c2.com/cgi/wiki?UnitTest 361816 - http://minnow.cc.gatech.edu/squeak/1547 361817 - the sunit class category! 361818 361819 361820!StringTest methodsFor: 'initialization' stamp: 'delaunay 5/13/2009 15:58'! 361821setUp 361822 string := 'Hi, I am a String'. 361823 emptyString := ''. 361824 subcollection := 'bcd'. 361825 nonEmpty5ElementsSorted := 'a' , subcollection , 'e'. 361826 unsortedCollection := 'azsbe'. 361827 indexInNonEmptyArray := #(1 3 2 ). 361828 valueArray := #($a $b $c ). 361829 nonEmpty1element := 'a'. 361830 withoutEqualElements := 'abcde'. 361831 361832 sameAtEndAndBegining := 'abca'. 361833 elementInNonEmpty := $c. 361834 collectionNotIncluded := notIn asString , notIn asString. 361835 notIn := $z! ! 361836 361837 361838!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:57'! 361839aValue 361840" return a value to put into nonEmpty" 361841 ^ elementInNonEmpty ! ! 361842 361843!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:58'! 361844anIndex 361845" return an index in nonEmpty bounds" 361846 ^ 2! ! 361847 361848!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:02'! 361849anotherElementOrAssociationIn 361850 " return an element (or an association for Dictionary ) present in 'collection' " 361851 ^ self collection anyOne! ! 361852 361853!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:02'! 361854anotherElementOrAssociationNotIn 361855 " return an element (or an association for Dictionary )not present in 'collection' " 361856 ^ notIn ! ! 361857 361858!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:57'! 361859anotherValue 361860" return a value ( not eual to 'aValue' ) to put into nonEmpty " 361861 ^ self nonEmpty anyOne.! ! 361862 361863!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:32'! 361864collectionMoreThan1NoDuplicates 361865 " return a collection of size > 1 without equal elements" 361866 ^ withoutEqualElements ! ! 361867 361868!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:52'! 361869collectionMoreThan5Elements 361870" return a collection including at least 5 elements" 361871 361872 ^ nonEmpty5ElementsSorted ! ! 361873 361874!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:03'! 361875collectionNotIncluded 361876" return a collection for wich each element is not included in 'nonEmpty' " 361877 ^ notIn ! ! 361878 361879!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:52'! 361880collectionWith1TimeSubcollection 361881 " return a collection including 'oldSubCollection' only one time " 361882 ^ nonEmpty5ElementsSorted! ! 361883 361884!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:52'! 361885collectionWith2TimeSubcollection 361886 " return a collection including 'oldSubCollection' two or many time " 361887 ^ nonEmpty5ElementsSorted , subcollection! ! 361888 361889!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:52'! 361890collectionWithElement 361891 "Returns a collection that already includes what is returned by #element." 361892 ^ nonEmpty5ElementsSorted! ! 361893 361894!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:06'! 361895collectionWithElementsToRemove 361896" return a collection of elements included in 'nonEmpty' " 361897 ^ subcollection ! ! 361898 361899!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:59'! 361900collectionWithEqualElements 361901" return a collecition including atLeast two elements equal" 361902 361903^ sameAtEndAndBegining ! ! 361904 361905!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 11:30'! 361906collectionWithSameAtEndAndBegining 361907" return a collection with elements at end and begining equals . 361908(others elements of the collection are not equal to those elements)" 361909 ^ sameAtEndAndBegining ! ! 361910 361911!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:52'! 361912collectionWithSortableElements 361913 " return a collection only including elements that can be sorted (understanding '<' )" 361914 ^ nonEmpty5ElementsSorted! ! 361915 361916!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 13:26'! 361917collectionWithoutEqualElements 361918" return a collection without equal elements" 361919 ^ withoutEqualElements ! ! 361920 361921!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 11:27'! 361922collectionWithoutEqualsElements 361923 361924" return a collection not including equal elements " 361925 ^ withoutEqualElements ! ! 361926 361927!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:52'! 361928collectionWithoutNilElements 361929 " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" 361930 ^ nonEmpty5ElementsSorted! ! 361931 361932!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 13:12'! 361933element 361934 "Returns an object that can be added to the collection returned by #collection." 361935 ^ elementInNonEmpty ! ! 361936 361937!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:40'! 361938elementInForElementAccessing 361939" return an element inculded in 'moreThan4Elements'" 361940 ^ self moreThan4Elements anyOne! ! 361941 361942!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:06'! 361943elementInForIncludesTest 361944" return an element included in nonEmpty " 361945 ^ elementInNonEmpty ! ! 361946 361947!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:32'! 361948elementInForIndexAccessing 361949" return an element included in 'accessCollection' " 361950 ^ withoutEqualElements anyOne! ! 361951 361952!StringTest methodsFor: 'requirements'! 361953elementInForReplacement 361954" return an element included in 'nonEmpty' " 361955^ self nonEmpty anyOne.! ! 361956 361957!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:06'! 361958elementNotIn 361959"return an element not included in 'nonEmpty' " 361960 361961 ^notIn ! ! 361962 361963!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:41'! 361964elementNotInForElementAccessing 361965" return an element not included in 'moreThan4Elements' " 361966 ^ notIn ! ! 361967 361968!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:32'! 361969elementNotInForIndexAccessing 361970" return an element not included in 'accessCollection' " 361971 ^ notIn ! ! 361972 361973!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:59'! 361974elementTwiceInForOccurrences 361975" return an element included exactly two time in # collectionWithEqualElements" 361976^ sameAtEndAndBegining first .! ! 361977 361978!StringTest methodsFor: 'requirements' stamp: 'stephane.ducasse 11/21/2008 15:08'! 361979empty 361980 ^ emptyString! ! 361981 361982!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:52'! 361983firstCollection 361984 " return a collection that will be the first part of the concatenation" 361985 ^ nonEmpty5ElementsSorted! ! 361986 361987!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 13:24'! 361988firstIndex 361989" return an index between 'nonEmpty' bounds that is < to 'second index' " 361990 ^3! ! 361991 361992!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 11:03'! 361993indexArray 361994" return a Collection including indexes between bounds of 'nonEmpty' " 361995 361996 ^ indexInNonEmptyArray ! ! 361997 361998!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 11:28'! 361999indexInForCollectionWithoutDuplicates 362000" return an index between 'collectionWithoutEqualsElements' bounds" 362001 ^ 2! ! 362002 362003!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 11:31'! 362004indexInNonEmpty 362005" return an index between bounds of 'nonEmpty' " 362006 362007 ^ 2.! ! 362008 362009!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:52'! 362010integerCollectionWithoutEqualElements 362011 " return a collection of integer without equal elements" 362012 ^ nonEmpty5ElementsSorted! ! 362013 362014!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:52'! 362015moreThan3Elements 362016 " return a collection including atLeast 3 elements" 362017 ^ nonEmpty5ElementsSorted! ! 362018 362019!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:52'! 362020moreThan4Elements 362021 " return a collection including at leat 4 elements" 362022 ^ nonEmpty5ElementsSorted! ! 362023 362024!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 13:24'! 362025newElement 362026"return an element that will be put in the collection in place of another" 362027 ^ elementInNonEmpty ! ! 362028 362029!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:52'! 362030nonEmpty 362031 ^ nonEmpty5ElementsSorted! ! 362032 362033!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:26'! 362034nonEmpty1Element 362035" return a collection of size 1 including one element" 362036 ^ nonEmpty1element ! ! 362037 362038!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:52'! 362039nonEmptyMoreThan1Element 362040 " return a collection that don't includes equl elements'" 362041 ^ nonEmpty5ElementsSorted! ! 362042 362043!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 11:34'! 362044oldSubCollection 362045" return a subCollection included in collectionWith1TimeSubcollection . 362046ex : subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)" 362047 ^ subcollection ! ! 362048 362049!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 13:12'! 362050otherCollection 362051 "Returns a collection that does not include what is returned by #element." 362052 ^ collectionNotIncluded ! ! 362053 362054!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 11:35'! 362055replacementCollection 362056" return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection' " 362057 ^ string! ! 362058 362059!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 13:23'! 362060replacementCollectionSameSize 362061" return a collection of size (secondIndex - firstIndex + 1)" 362062 ^nonEmpty1element ! ! 362063 362064!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:33'! 362065secondCollection 362066" return a collection that will be the second part of the concatenation" 362067 ^ nonEmpty1element ! ! 362068 362069!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 13:25'! 362070secondIndex 362071" return an index between 'nonEmpty' bounds that is > to 'second index' " 362072 ^ self firstIndex ! ! 362073 362074!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 15:19'! 362075sizeCollection 362076 "Answers a collection whose #size is 4" 362077 ^ 'abcd'! ! 362078 362079!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:54'! 362080sortedInAscendingOrderCollection 362081" return a collection sorted in an acsending order" 362082 ^nonEmpty5ElementsSorted 362083 ! ! 362084 362085!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:45'! 362086subCollectionNotIn 362087" return a collection for which at least one element is not included in 'moreThan4Elements' " 362088 ^ collectionNotIncluded ! ! 362089 362090!StringTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:54'! 362091unsortedCollection 362092 ^ unsortedCollection ! ! 362093 362094!StringTest methodsFor: 'requirements'! 362095valueArray 362096" return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty' at indexes in 'indexArray' " 362097 | result | 362098 result := Array new: self indexArray size. 362099 1 to: result size do: 362100 [:i | 362101 result at:i put: (self aValue ). 362102 ]. 362103 ^ result.! ! 362104 362105!StringTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:30'! 362106withEqualElements 362107 " return a collection including equal elements (classic equality)" 362108 ^ sameAtEndAndBegining ! ! 362109 362110 362111!StringTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! 362112elementToAdd 362113 ^ $u! ! 362114 362115 362116!StringTest methodsFor: 'test - creation'! 362117testOfSize 362118 "self debug: #testOfSize" 362119 362120 | aCol | 362121 aCol := self collectionClass ofSize: 3. 362122 self assert: (aCol size = 3). 362123! ! 362124 362125!StringTest methodsFor: 'test - creation'! 362126testWith 362127 "self debug: #testWith" 362128 362129 | aCol element | 362130 element := self collectionMoreThan5Elements anyOne. 362131 aCol := self collectionClass with: element. 362132 self assert: (aCol includes: element).! ! 362133 362134!StringTest methodsFor: 'test - creation'! 362135testWithAll 362136 "self debug: #testWithAll" 362137 362138 | aCol collection | 362139 collection := self collectionMoreThan5Elements asOrderedCollection . 362140 aCol := self collectionClass withAll: collection . 362141 362142 collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. 362143 362144 self assert: (aCol size = collection size ).! ! 362145 362146!StringTest methodsFor: 'test - creation'! 362147testWithWith 362148 "self debug: #testWithWith" 362149 362150 | aCol collection element1 element2 | 362151 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . 362152 element1 := collection at: 1. 362153 element2 := collection at:2. 362154 362155 aCol := self collectionClass with: element1 with: element2 . 362156 self assert: (aCol occurrencesOf: element1 ) == ( collection occurrencesOf: element1). 362157 self assert: (aCol occurrencesOf: element2 ) == ( collection occurrencesOf: element2). 362158 362159 ! ! 362160 362161!StringTest methodsFor: 'test - creation'! 362162testWithWithWith 362163 "self debug: #testWithWithWith" 362164 362165 | aCol collection | 362166 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . 362167 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 362168 362169 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 362170 362171!StringTest methodsFor: 'test - creation'! 362172testWithWithWithWith 362173 "self debug: #testWithWithWithWith" 362174 362175 | aCol collection | 362176 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. 362177 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 362178 362179 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 362180 362181!StringTest methodsFor: 'test - creation'! 362182testWithWithWithWithWith 362183 "self debug: #testWithWithWithWithWith" 362184 362185 | aCol collection | 362186 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . 362187 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 362188 362189 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 362190 362191 362192!StringTest methodsFor: 'test - equality'! 362193testEqualSign 362194 "self debug: #testEqualSign" 362195 362196 self deny: (self empty = self nonEmpty).! ! 362197 362198!StringTest methodsFor: 'test - equality'! 362199testEqualSignIsTrueForNonIdenticalButEqualCollections 362200 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 362201 362202 self assert: (self empty = self empty copy). 362203 self assert: (self empty copy = self empty). 362204 self assert: (self empty copy = self empty copy). 362205 362206 self assert: (self nonEmpty = self nonEmpty copy). 362207 self assert: (self nonEmpty copy = self nonEmpty). 362208 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 362209 362210!StringTest methodsFor: 'test - equality'! 362211testEqualSignOfIdenticalCollectionObjects 362212 "self debug: #testEqualSignOfIdenticalCollectionObjects" 362213 362214 self assert: (self empty = self empty). 362215 self assert: (self nonEmpty = self nonEmpty). 362216 ! ! 362217 362218 362219!StringTest methodsFor: 'test - set arithmetic' stamp: 'stephane.ducasse 12/20/2008 21:57'! 362220collectionClass 362221 362222 ^ String! ! 362223 362224 362225!StringTest methodsFor: 'test-comparing' stamp: 'lr 7/7/2006 11:32'! 362226testComparing 362227 self assert: 'foo' < 'foo:'. 362228 self assert: 'foo' < 'fooBar'. 362229 self assert: 'foo' <= 'foo:'. 362230 self assert: 'foo' <= 'fooBar'. 362231 self assert: 'foo:' > 'foo'. 362232 self assert: 'fooBar' > 'foo'. 362233 self assert: 'foo:' >= 'foo'. 362234 self assert: 'fooBar' >= 'foo'! ! 362235 362236 362237!StringTest methodsFor: 'testing' stamp: 'md 3/16/2006 22:12'! 362238testEquality 362239 362240 self assert: 'abc' = 'abc' asWideString. 362241 self assert: 'abc' asWideString = 'abc'. 362242 self assert: ((ByteArray with: 97 with: 0 with: 0 with: 0) asString ~= 'a000' asWideString). 362243 self assert: ('a000' asWideString ~= (ByteArray with: 97 with: 0 with: 0 with: 0) asString). 362244 362245 self assert: ('abc' sameAs: 'aBc' asWideString). 362246 self assert: ('aBc' asWideString sameAs: 'abc'). 362247 self assert: ((ByteArray with: 97 with: 0 with: 0 with: 0) asString 362248 sameAs: 'Abcd' asWideString) not. 362249 self assert: ('a000' asWideString sameAs: 362250 (ByteArray with: 97 with: 0 with: 0 with: 0) asString) not.! ! 362251 362252!StringTest methodsFor: 'testing' stamp: 'nice 10/5/2009 03:44'! 362253testFindLastOccurenceOfStringStartingAt 362254 362255 self assert: ('Smalltalk' findLastOccurrenceOfString: 'al' startingAt: 2) = 7. 362256 self assert: ('aaa' findLastOccurrenceOfString: 'aa' startingAt: 1) = 2. 362257 self assert: ('Smalltalk' asWideString findLastOccurrenceOfString: 'al' startingAt: 2) = 7. 362258 self assert: ('Smalltalk' asWideString findLastOccurrenceOfString: 'al' asWideString startingAt: 2) = 7. 362259 self assert: (('Smalltalk' copyWith: 835 asCharacter) findLastOccurrenceOfString: 'al' asWideString startingAt: 2) = 7.! ! 362260 362261!StringTest methodsFor: 'testing' stamp: 'nice 10/17/2008 23:53'! 362262testNumArgs 362263 "This is about http://code.google.com/p/pharo/issues/detail?id=237" 362264 362265 self assert: ('*+-/\~=<>&@%,|' allSatisfy: [:char | (String with: char) numArgs = 1]) 362266 description: 'binary selectors have 1 argument'. 362267 362268 self assert: 'x' numArgs = 0 362269 description: 'unary selectors have 0 arguments'. 362270 self assert: 'x0' numArgs = 0 362271 description: 'unary selectors have 0 arguments'. 362272 self assert: 'yourself' numArgs = 0 362273 description: 'unary selectors have 0 arguments'. 362274 362275 self assert: 'x:' numArgs = 1 362276 description: 'keyword selectors have as many elements as colons characters'. 362277 self assert: 'x:y:' numArgs = 2 362278 description: 'keyword selectors have as many elements as colons characters'. 362279 self assert: 'at:put:' numArgs = 2 362280 description: 'keyword selectors have as many elements as colons characters'. 362281 362282 self assert: 'at:withoutTrailingColon' numArgs = -1 362283 description: 'keyword selectors should have a trailing colon character'. 362284 362285 self assert: ':x' numArgs = -1 362286 description: 'keyword selectors cannot begin with a colon character'. 362287 362288 self assert: 'x::y:' numArgs = -1 362289 description: 'keyword selectors cannot have two consecutive colon characters'. 362290 362291 self assert: '0x' numArgs = -1 362292 description: 'selectors cannot begin with a digit'. 362293 362294 "This one is known to fail... 362295 self assert: 'x:0:' numArgs = -1 362296 description: 'no keyword selector part can begin with a digit'. 362297 " 362298 362299 ! ! 362300 362301 362302!StringTest methodsFor: 'testing - converting' stamp: 'KR 06/24/2005 11:21'! 362303testPercentEncodingJa 362304 | leading hiraA hiraO hiraAO encodedHiraA encodedHiraO encodedHiraAO | 362305 362306 "Make Japanese String from unicode. see http://www.unicode.org/charts/PDF/U3040.pdf" 362307 leading := JapaneseEnvironment leadingChar. 362308 hiraA := (Character leadingChar: leading code: 16r3042) asString. "HIRAGANA LETTER A" 362309 hiraO := (Character leadingChar: leading code: 16r304A) asString. "HIRAGANA LETTER O" 362310 hiraAO := hiraA, hiraO. 362311 362312 "Percent Encoded Japanese String" 362313 encodedHiraA := hiraA encodeForHTTP. 362314 self assert: encodedHiraA = '%E3%81%82'. 362315 encodedHiraO := hiraO encodeForHTTP. 362316 self assert: encodedHiraO = '%E3%81%8A'. 362317 encodedHiraAO := hiraAO encodeForHTTP. 362318 self assert: encodedHiraAO = '%E3%81%82%E3%81%8A'. 362319 362320 "without percent encoded string" 362321 self assert: '' unescapePercents = ''. 362322 self assert: 'abc' unescapePercents = 'abc'. "latin1 character" 362323 self assert: hiraAO unescapePercents = hiraAO. "multibyte character" 362324 362325 "encoded latin1 string" 362326 self assert: '%61' unescapePercents = 'a'. 362327 self assert: '%61%62%63' unescapePercents = 'abc'. 362328 362329 "encoded multibyte string" 362330 Locale currentPlatform: (Locale isoLanguage: 'ja') during: [ 362331 self assert: encodedHiraA unescapePercents = hiraA. 362332 self assert: encodedHiraAO unescapePercents = hiraAO]. 362333 362334 "mixed string" 362335 Locale currentPlatform: (Locale isoLanguage: 'ja') during: [ 362336 self assert: (encodedHiraAO,'a') unescapePercents = (hiraAO, 'a'). 362337 self assert: ('a', encodedHiraA) unescapePercents = ('a', hiraA). 362338 self assert: ('a', encodedHiraA, 'b') unescapePercents = ('a', hiraA, 'b'). 362339 self assert: ('a', encodedHiraA, 'b', encodedHiraO) unescapePercents = ('a', hiraA, 'b', hiraO). 362340 self assert: (encodedHiraA, encodedHiraO, 'b', encodedHiraA) unescapePercents = (hiraA, hiraO, 'b', hiraA)]. 362341 362342 362343 "for Seaside" 362344 Locale currentPlatform: (Locale isoLanguage: 'ja') during: [ 362345 self assert: (encodedHiraA, '+', encodedHiraO) unescapePercents = (hiraA, ' ', hiraO)]. 362346 362347! ! 362348 362349 362350!StringTest methodsFor: 'testing - instance creation' stamp: 'dc 3/21/2007 11:22'! 362351testSpace 362352 "self debug: #testSpace" 362353 362354 string := String new. 362355 self assert: string size = 0. "instead of #isEmpty to be consistent with the following test" 362356 362357 string := String space. 362358 self assert: string size = 1. 362359 self assert: string = ' '! ! 362360 362361 362362!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362363testFindTokensEscapedBy01 362364 362365 | tokens | 362366 string := 'this, is, "a, test"'. 362367 tokens := string findTokens: ',' escapedBy: '"'. 362368 self assert: tokens size == 3! ! 362369 362370!StringTest methodsFor: 'testing - tokenizing' stamp: 'fbs 2/13/2006 22:20'! 362371testFindTokensEscapedBy02 362372 362373 | tokens | 362374 string := ''. 362375 tokens := string findTokens: ',' escapedBy: '"'. 362376 self assert: tokens isEmpty! ! 362377 362378!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362379testFindTokensEscapedBy03 362380 362381 | tokens | 362382 string := 'this, is, a, test'. 362383 tokens := string findTokens: ',' escapedBy: '"'. 362384 self assert: tokens size == 4! ! 362385 362386!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362387testFindTokensEscapedBy04 362388 362389 | tokens | 362390 string := 'this, is, a"," test'. 362391 tokens := string findTokens: ',' escapedBy: '"'. 362392 self assert: tokens size == 3. 362393 self assert: tokens third = ' a, test'! ! 362394 362395!StringTest methodsFor: 'testing - tokenizing' stamp: 'fbs 2/13/2006 22:19'! 362396testFindTokensEscapedBy05 362397 362398 | tokens | 362399 string := 'this, /is, a"," test/'. 362400 tokens := string findTokens: ',#' escapedBy: '"/'. 362401 self assert: tokens size = 2. 362402 self assert: tokens first = 'this'. 362403 self assert: tokens second = ' is, a"," test'.! ! 362404 362405!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362406testFindTokensEscapedBy06 362407 362408 | tokens | 362409 string := 'this, is, "a, test'. 362410 tokens := string findTokens: ',' escapedBy: '"'. 362411 self assert: tokens size == 3. 362412 self assert: tokens third = ' a, test'! ! 362413 362414!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362415testFindTokensEscapedBy07 362416 362417 | tokens | 362418 string := 'a:b::c'. 362419 tokens := string findTokens: ':' escapedBy: '"'. 362420 self assert: tokens size == 4. 362421 self assert: tokens first = 'a'. 362422 self assert: tokens second = 'b'. 362423 self assert: tokens third = ''. 362424 self assert: tokens fourth = 'c'! ! 362425 362426!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362427testFindTokensEscapedBy08 362428 362429 | tokens | 362430 string := 'this, is, ##a, test'. 362431 tokens := string findTokens: ',' escapedBy: '#'. 362432 self assert: tokens size == 4. 362433 self assert: tokens third = ' a'. 362434 self assert: tokens fourth = ' test'! ! 362435 362436!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362437testFindTokensEscapedBy09 362438 362439 | tokens | 362440 string := 'this, is, ###a, test#'. 362441 tokens := string findTokens: ',' escapedBy: '#'. 362442 self assert: tokens size == 3. 362443 self assert: tokens third = ' #a, test'! ! 362444 362445!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362446testFindTokensEscapedBy10 362447 362448 | tokens | 362449 string := 'this, is, ###a, test'. 362450 tokens := string findTokens: ',' escapedBy: '#'. 362451 self assert: tokens size == 3. 362452 self assert: tokens third = ' #a, test'! ! 362453 362454!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362455testFindTokensEscapedBy11 362456 362457 | tokens | 362458 string := 'this, is, """a, test"'. 362459 tokens := string findTokens: ',' escapedBy: '"'. 362460 self assert: tokens size == 3. 362461 self assert: tokens third = ' "a, test'! ! 362462 362463!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362464testFindTokensEscapedBy12 362465 362466 | tokens | 362467 string := 'one, two# three; four. five'. 362468 tokens := string findTokens: ',#;.' escapedBy: '"'. 362469 self assert: tokens size == 5. 362470 self assert: tokens third = ' three'! ! 362471 362472!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362473testFindTokensEscapedBy13 362474 362475 | tokens | 362476 string := 'one, two# three; four. five'. 362477 tokens := string findTokens: ',#;.' escapedBy: nil. 362478 self assert: tokens size == 5. 362479 self assert: tokens third = ' three'! ! 362480 362481!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362482testFindTokensEscapedBy14 362483 362484 | tokens | 362485 string := 'one, "two# three"; &four. five&'. 362486 tokens := string findTokens: ',#;.' escapedBy: '"&'. 362487 self assert: tokens size == 3. 362488 self assert: tokens second = ' two# three'. 362489 self assert: tokens third = ' four. five'! ! 362490 362491!StringTest methodsFor: 'testing - tokenizing' stamp: 'fbs 2/13/2006 22:19'! 362492testFindTokensEscapedBy15 362493 362494 | tokens | 362495 string := 'one, "two# three"; &four. five&'. 362496 tokens := string findTokens: nil escapedBy: '"&'. 362497 self assert: tokens size = 1. 362498 self assert: tokens first = 'one, two# three; four. five'! ! 362499 362500!StringTest methodsFor: 'testing - tokenizing' stamp: 'fbs 2/13/2006 22:19'! 362501testFindTokensEscapedBy16 362502 362503 | tokens | 362504 string := 'one, "two# three"; &four. five&'. 362505 tokens := string findTokens: nil escapedBy: nil. 362506 self assert: tokens size = 1. 362507 self assert: tokens first = string! ! 362508 362509!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362510testFindTokensEscapedBy21 362511 362512 | tokens | 362513 string := 'this, is, "a, test"'. 362514 tokens := string findTokens: $, escapedBy: $". 362515 self assert: tokens size == 3! ! 362516 362517!StringTest methodsFor: 'testing - tokenizing' stamp: 'fbs 2/13/2006 22:19'! 362518testFindTokensEscapedBy22 362519 362520 | tokens | 362521 string := ''. 362522 tokens := string findTokens: $, escapedBy: $". 362523 self assert: tokens size = 0! ! 362524 362525!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362526testFindTokensEscapedBy23 362527 362528 | tokens | 362529 string := 'this, is, a, test'. 362530 tokens := string findTokens: $, escapedBy: $". 362531 self assert: tokens size == 4! ! 362532 362533!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362534testFindTokensEscapedBy24 362535 362536 | tokens | 362537 string := 'this, is, a"," test'. 362538 tokens := string findTokens: $, escapedBy: $". 362539 self assert: tokens size == 3. 362540 self assert: tokens third = ' a, test'! ! 362541 362542!StringTest methodsFor: 'testing - tokenizing' stamp: 'fbs 2/13/2006 22:19'! 362543testFindTokensEscapedBy25 362544 362545 | tokens | 362546 string := 'this, /is, a"," test/'. 362547 tokens := string findTokens: $, escapedBy: $/. 362548 self assert: tokens size = 2. 362549 self assert: tokens first = 'this'. 362550 self assert: tokens second = ' is, a"," test'.! ! 362551 362552!StringTest methodsFor: 'testing - tokenizing' stamp: 'stephaneducasse 2/4/2006 20:10'! 362553testFindTokensEscapedBy26 362554 362555 | tokens | 362556 string := 'this, is, "a, test'. 362557 tokens := string findTokens: $, escapedBy: $". 362558 self assert: tokens size == 3. 362559 self assert: tokens third = ' a, test'! ! 362560 362561 362562!StringTest methodsFor: 'tests - accessing' stamp: 'sd 6/5/2005 09:27'! 362563testAt 362564 362565 self assert: (string at: 1) = $H.! ! 362566 362567 362568!StringTest methodsFor: 'tests - as set tests'! 362569testAsIdentitySetWithEqualsElements 362570 | result collection | 362571 collection := self withEqualElements . 362572 result := collection asIdentitySet. 362573 collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 362574 self assert: result class = IdentitySet.! ! 362575 362576!StringTest methodsFor: 'tests - as set tests'! 362577testAsSetWithEqualsElements 362578 | result | 362579 result := self withEqualElements asSet. 362580 self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 362581 self assert: result class = Set! ! 362582 362583 362584!StringTest methodsFor: 'tests - as sorted collection'! 362585testAsSortedArray 362586 | result collection | 362587 collection := self collectionWithSortableElements . 362588 result := collection asSortedArray. 362589 self assert: (result class includesBehavior: Array). 362590 self assert: result isSorted. 362591 self assert: result size = collection size! ! 362592 362593!StringTest methodsFor: 'tests - as sorted collection'! 362594testAsSortedCollection 362595 362596 | aCollection result | 362597 aCollection := self collectionWithSortableElements . 362598 result := aCollection asSortedCollection. 362599 362600 self assert: (result class includesBehavior: SortedCollection). 362601 result do: 362602 [ :each | 362603 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 362604 362605 self assert: result size = aCollection size.! ! 362606 362607!StringTest methodsFor: 'tests - as sorted collection'! 362608testAsSortedCollectionWithSortBlock 362609 | result tmp | 362610 result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. 362611 self assert: (result class includesBehavior: SortedCollection). 362612 result do: 362613 [ :each | 362614 self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 362615 self assert: result size = self collectionWithSortableElements size. 362616 tmp:=result at: 1. 362617 result do: [:each| self assert: tmp>=each. tmp:=each]. 362618 ! ! 362619 362620 362621!StringTest methodsFor: 'tests - at put'! 362622testAtPut 362623 "self debug: #testAtPut" 362624 362625 self nonEmpty at: self anIndex put: self aValue. 362626 self assert: (self nonEmpty at: self anIndex) = self aValue. 362627 ! ! 362628 362629!StringTest methodsFor: 'tests - at put'! 362630testAtPutOutOfBounds 362631 "self debug: #testAtPutOutOfBounds" 362632 362633 self should: [self empty at: self anIndex put: self aValue] raise: Error 362634 ! ! 362635 362636!StringTest methodsFor: 'tests - at put'! 362637testAtPutTwoValues 362638 "self debug: #testAtPutTwoValues" 362639 362640 self nonEmpty at: self anIndex put: self aValue. 362641 self nonEmpty at: self anIndex put: self anotherValue. 362642 self assert: (self nonEmpty at: self anIndex) = self anotherValue.! ! 362643 362644 362645!StringTest methodsFor: 'tests - begins ends with'! 362646testsBeginsWith 362647 362648 self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty size)). 362649 self assert: (self nonEmpty beginsWith:(self nonEmpty )). 362650 self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 362651 362652!StringTest methodsFor: 'tests - begins ends with'! 362653testsBeginsWithEmpty 362654 362655 self deny: (self nonEmpty beginsWith:(self empty)). 362656 self deny: (self empty beginsWith:(self nonEmpty )). 362657! ! 362658 362659!StringTest methodsFor: 'tests - begins ends with'! 362660testsEndsWith 362661 362662 self assert: (self nonEmpty endsWith:(self nonEmpty copyWithoutFirst)). 362663 self assert: (self nonEmpty endsWith:(self nonEmpty )). 362664 self deny: (self nonEmpty endsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 362665 362666!StringTest methodsFor: 'tests - begins ends with'! 362667testsEndsWithEmpty 362668 362669 self deny: (self nonEmpty endsWith:(self empty )). 362670 self deny: (self empty endsWith:(self nonEmpty )). 362671 ! ! 362672 362673 362674!StringTest methodsFor: 'tests - comma and delimiter'! 362675testAsCommaStringEmpty 362676 362677 self assert: self empty asCommaString = ''. 362678 self assert: self empty asCommaStringAnd = ''. 362679 362680 362681! ! 362682 362683!StringTest methodsFor: 'tests - comma and delimiter'! 362684testAsCommaStringMore 362685 362686 "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. 362687 self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' 362688" 362689 362690 | result resultAnd index allElementsAsString | 362691 result:= self nonEmpty asCommaString . 362692 resultAnd:= self nonEmpty asCommaStringAnd . 362693 362694 index := 1. 362695 (result findBetweenSubStrs: ',' )do: 362696 [:each | 362697 index = 1 362698 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] 362699 ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. 362700 index:=index+1 362701 ]. 362702 362703 "verifying esultAnd :" 362704 allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 362705 1 to: allElementsAsString size do: 362706 [:i | 362707 i<(allElementsAsString size ) 362708 ifTrue: [ 362709 i = 1 362710 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] 362711 ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] 362712 ]. 362713 i=(allElementsAsString size) 362714 ifTrue:[ 362715 i = 1 362716 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 362717 ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 362718 ]. 362719 362720 362721 ].! ! 362722 362723!StringTest methodsFor: 'tests - comma and delimiter'! 362724testAsCommaStringOne 362725 362726 "self assert: self oneItemCol asCommaString = '1'. 362727 self assert: self oneItemCol asCommaStringAnd = '1'." 362728 362729 self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). 362730 self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). 362731 ! ! 362732 362733!StringTest methodsFor: 'tests - comma and delimiter'! 362734testAsStringOnDelimiterEmpty 362735 362736 | delim emptyStream | 362737 delim := ', '. 362738 emptyStream := ReadWriteStream on: ''. 362739 self empty asStringOn: emptyStream delimiter: delim. 362740 self assert: emptyStream contents = ''. 362741! ! 362742 362743!StringTest methodsFor: 'tests - comma and delimiter'! 362744testAsStringOnDelimiterLastEmpty 362745 362746 | delim emptyStream | 362747 delim := ', '. 362748 emptyStream := ReadWriteStream on: ''. 362749 self empty asStringOn: emptyStream delimiter: delim last:'and'. 362750 self assert: emptyStream contents = ''. 362751! ! 362752 362753!StringTest methodsFor: 'tests - comma and delimiter'! 362754testAsStringOnDelimiterLastMore 362755 362756 | delim multiItemStream result last allElementsAsString | 362757 362758 delim := ', '. 362759 last := 'and'. 362760 result:=''. 362761 multiItemStream := ReadWriteStream on:result. 362762 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 362763 362764 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 362765 1 to: allElementsAsString size do: 362766 [:i | 362767 i<(allElementsAsString size-1 ) 362768 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 362769 i=(allElementsAsString size-1) 362770 ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. 362771 i=(allElementsAsString size) 362772 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 362773 ]. 362774 362775! ! 362776 362777!StringTest methodsFor: 'tests - comma and delimiter'! 362778testAsStringOnDelimiterLastOne 362779 362780 | delim oneItemStream result | 362781 362782 delim := ', '. 362783 result:=''. 362784 oneItemStream := ReadWriteStream on: result. 362785 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 362786 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 362787 362788 362789 ! ! 362790 362791!StringTest methodsFor: 'tests - comma and delimiter'! 362792testAsStringOnDelimiterMore 362793 362794 | delim multiItemStream result index | 362795 "delim := ', '. 362796 multiItemStream := '' readWrite. 362797 self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. 362798 self assert: multiItemStream contents = '1, 2, 3'." 362799 362800 delim := ', '. 362801 result:=''. 362802 multiItemStream := ReadWriteStream on:result. 362803 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 362804 362805 index:=1. 362806 (result findBetweenSubStrs: ', ' )do: 362807 [:each | 362808 self assert: each= ((self nonEmpty at:index)asString). 362809 index:=index+1 362810 ].! ! 362811 362812!StringTest methodsFor: 'tests - comma and delimiter'! 362813testAsStringOnDelimiterOne 362814 362815 | delim oneItemStream result | 362816 "delim := ', '. 362817 oneItemStream := '' readWrite. 362818 self oneItemCol asStringOn: oneItemStream delimiter: delim. 362819 self assert: oneItemStream contents = '1'." 362820 362821 delim := ', '. 362822 result:=''. 362823 oneItemStream := ReadWriteStream on: result. 362824 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 362825 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 362826 362827 362828 ! ! 362829 362830 362831!StringTest methodsFor: 'tests - concatenation'! 362832testConcatenation 362833 | result index | 362834 result:= self firstCollection,self secondCollection . 362835 "first part : " 362836 index := 1. 362837 self firstCollection do: 362838 [:each | 362839 self assert: (self firstCollection at: index)=each. 362840 index := index+1.]. 362841 "second part : " 362842 1 to: self secondCollection size do: 362843 [:i | 362844 self assert: (self secondCollection at:i)= (result at:index). 362845 index:=index+1]. 362846 "size : " 362847 self assert: result size = (self firstCollection size + self secondCollection size).! ! 362848 362849!StringTest methodsFor: 'tests - concatenation'! 362850testConcatenationWithEmpty 362851 | result | 362852 result:= self empty,self secondCollection . 362853 362854 1 to: self secondCollection size do: 362855 [:i | 362856 self assert: (self secondCollection at:i)= (result at:i). 362857 ]. 362858 "size : " 362859 self assert: result size = ( self secondCollection size).! ! 362860 362861 362862!StringTest methodsFor: 'tests - converting'! 362863assertNoDuplicates: aCollection whenConvertedTo: aClass 362864 | result | 362865 result := self collectionWithEqualElements asIdentitySet. 362866 self assert: (result class includesBehavior: IdentitySet). 362867 self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! 362868 362869!StringTest methodsFor: 'tests - converting'! 362870assertNonDuplicatedContents: aCollection whenConvertedTo: aClass 362871 | result | 362872 result := aCollection perform: ('as' , aClass name) asSymbol. 362873 self assert: (result class includesBehavior: aClass). 362874 result do: 362875 [ :each | 362876 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 362877 ^ result! ! 362878 362879!StringTest methodsFor: 'tests - converting'! 362880assertSameContents: aCollection whenConvertedTo: aClass 362881 | result | 362882 result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. 362883 self assert: result size = aCollection size! ! 362884 362885!StringTest methodsFor: 'tests - converting'! 362886testAsArray 362887 "self debug: #testAsArray3" 362888 self 362889 assertSameContents: self collectionWithoutEqualElements 362890 whenConvertedTo: Array! ! 362891 362892!StringTest methodsFor: 'tests - converting'! 362893testAsBag 362894 362895 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! 362896 362897!StringTest methodsFor: 'tests - converting'! 362898testAsIdentitySet 362899 "test with a collection without equal elements :" 362900 self 362901 assertSameContents: self collectionWithoutEqualElements 362902 whenConvertedTo: IdentitySet. 362903! ! 362904 362905!StringTest methodsFor: 'tests - converting' stamp: 'sd 6/5/2005 09:26'! 362906testAsInteger 362907 362908 self assert: '1796exportFixes-tkMX' asInteger = 1796. 362909 self assert: 'donald' asInteger isNil. 362910 self assert: 'abc234def567' asInteger = 234. 362911 self assert: '-94' asInteger = -94. 362912 self assert: 'foo-bar-92' asInteger = -92! ! 362913 362914!StringTest methodsFor: 'tests - converting'! 362915testAsOrderedCollection 362916 362917 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! 362918 362919!StringTest methodsFor: 'tests - converting'! 362920testAsSet 362921 | | 362922 "test with a collection without equal elements :" 362923 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. 362924 ! ! 362925 362926!StringTest methodsFor: 'tests - converting' stamp: 'sd 6/5/2005 09:27'! 362927testAsSmalltalkComment 362928 362929 | exampleStrings | 362930 exampleStrings := #( 362931 '' 362932 ' ' 362933 '"' 362934 '""' 362935 '"""' 362936 'abc"abc' 362937 'abc""abc' 362938 'abc"hello"abc' 362939 'abc"' 362940 '"abc' ). 362941 362942 "check that the result of scanning the comment is empty" 362943 exampleStrings do: [ :s | 362944 | tokens | 362945 tokens := Scanner new scanTokens: s asSmalltalkComment. 362946 self assert: (tokens isEmpty) ]. 362947 362948 "check that the result has the same non-quote characters as the original" 362949 exampleStrings do: [ :s | 362950 self assert: ( (s copyWithout: $") = (s asSmalltalkComment copyWithout: $"))]. 362951 362952 "finnaly, test for some common kinds of inputs" 362953 self assert: ( 'abc' asSmalltalkComment = '"abc"'). 362954 self assert: ( 'abc"abc' asSmalltalkComment = '"abc""abc"'). 362955 self assert: ('abc""abc' asSmalltalkComment = '"abc""abc"' ). 362956 ! ! 362957 362958!StringTest methodsFor: 'tests - converting' stamp: 'sd 6/5/2005 09:27'! 362959testCapitalized 362960 362961 | uc lc empty | 362962 uc := 'MElViN'. 362963 lc := 'mElViN'. 362964 empty := ' '. 362965 self assert: lc capitalized = uc. 362966 self assert: uc capitalized = uc. 362967 "the string gets copied" 362968 self deny: uc capitalized == uc. 362969 self deny: empty capitalized == empty.! ! 362970 362971!StringTest methodsFor: 'tests - converting' stamp: 'ky 7/8/2006 15:28'! 362972testUnescapePercents 362973 self assert: '' unescapePercents = ''. 362974 self assert: 'x' unescapePercents = 'x'. 362975 362976 self assert: '+' unescapePercents = ' '. 362977 self assert: 'x+' unescapePercents = 'x '. 362978 self assert: '+x' unescapePercents = ' x'. 362979 self assert: 'x+x' unescapePercents = 'x x'. 362980 362981 self assert: '%' unescapePercents = '%'. 362982 self assert: '%3' unescapePercents = '%3'. 362983 self assert: '%3C' unescapePercents = '<'. 362984 362985 self assert: '%3Cx%3E4%3C%2Fx%3E' unescapePercents = '<x>4</x>'. 362986 362987 self assert: '!!@#$%25%5E&*()%7B%7D%5B%5D=:/;?+''%22' unescapePercents = '!!@#$%^&*(){}[]=:/;? ''"'. 362988 self assert: '!!%40%23%24%25%5E%26*()%7B%7D%5B%5D%3D%3A%2F%3B%3F%2B''%22' unescapePercents = '!!@#$%^&*(){}[]=:/;?+''"'. 362989 self assert: '%21@%23%24%25%5E%26*%28%29%7B%7D%5B%5D%3D%3A/%3B%3F+%27%22' unescapePercents = '!!@#$%^&*(){}[]=:/;? ''"'! ! 362990 362991!StringTest methodsFor: 'tests - converting' stamp: 'ky 7/8/2006 18:01'! 362992testUnescapePercentsWithTextEncoding 362993 | leading kataTe kataSu kataTo | 362994 leading := JapaneseEnvironment leadingChar. 362995 "Katakana letter Te" 362996 kataTe := (Character leadingChar: leading code: 12486) asString. 362997 "Katakana letter Su" 362998 kataSu := (Character leadingChar: leading code: 12473) asString. 362999 "Katakana letter To" 363000 kataTo := (Character leadingChar: leading code: 12488) asString. 363001 self assert: ('%83e%83X%83g' unescapePercentsWithTextEncoding: 'shift_jis') 363002 = (kataTe , kataSu , kataTo). 363003 self assert: ('%83e%83X%83g%20and%20%83e%83X%83g' unescapePercentsWithTextEncoding: 'shift_jis') 363004 = (kataTe , kataSu , kataTo , ' and ' , kataTe , kataSu , kataTo)! ! 363005 363006!StringTest methodsFor: 'tests - converting' stamp: 'dc 4/10/2007 09:35'! 363007testUpTo 363008 "self debug: #testUpTo" 363009 self assert: #up:to: keywords = #(up: to:). 363010 self assert: #copy:from:to: keywords = #(copy: from: to:). 363011 self assert: #up keywords = #(up). 363012 self assert: #at: keywords = #(at:). 363013 ! ! 363014 363015!StringTest methodsFor: 'tests - converting' stamp: 'sd 6/5/2005 09:27'! 363016testWithFirstCharacterDownshifted 363017 363018 | uc lc empty | 363019 uc := 'MElViN'. 363020 lc := 'mElViN'. 363021 empty := ' '. 363022 self assert: uc withFirstCharacterDownshifted = lc. 363023 self assert: lc withFirstCharacterDownshifted = lc. 363024 "the string gets copied" 363025 self deny: lc withFirstCharacterDownshifted == lc. 363026 self deny: empty withFirstCharacterDownshifted == empty.! ! 363027 363028!StringTest methodsFor: 'tests - converting' stamp: 'md 2/5/2007 15:21'! 363029testZipped 363030 | compressed | 363031 363032 compressed := 'hello' zipped. 363033 self assert: (compressed unzipped = 'hello').! ! 363034 363035 363036!StringTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 363037testCopyEmptyWith 363038 "self debug: #testCopyWith" 363039 | res | 363040 res := self empty copyWith: self elementToAdd. 363041 self assert: res size = (self empty size + 1). 363042 self assert: (res includes: self elementToAdd)! ! 363043 363044!StringTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 363045testCopyEmptyWithout 363046 "self debug: #testCopyEmptyWithout" 363047 | res | 363048 res := self empty copyWithout: self elementToAdd. 363049 self assert: res size = self empty size. 363050 self deny: (res includes: self elementToAdd)! ! 363051 363052!StringTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 363053testCopyEmptyWithoutAll 363054 "self debug: #testCopyEmptyWithoutAll" 363055 | res | 363056 res := self empty copyWithoutAll: self collectionWithElementsToRemove. 363057 self assert: res size = self empty size. 363058 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! 363059 363060!StringTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 363061testCopyNonEmptyWith 363062 "self debug: #testCopyNonEmptyWith" 363063 | res | 363064 res := self nonEmpty copyWith: self elementToAdd. 363065 "here we do not test the size since for a non empty set we would get a problem. 363066 Then in addition copy is not about duplicate management. The element should 363067 be in at the end." 363068 self assert: (res includes: self elementToAdd). 363069 self nonEmpty do: [ :each | res includes: each ]! ! 363070 363071!StringTest methodsFor: 'tests - copy'! 363072testCopyNonEmptyWithout 363073 "self debug: #testCopyNonEmptyWithout" 363074 363075 | res anElementOfTheCollection | 363076 anElementOfTheCollection := self nonEmpty anyOne. 363077 res := (self nonEmpty copyWithout: anElementOfTheCollection). 363078 "here we do not test the size since for a non empty set we would get a problem. 363079 Then in addition copy is not about duplicate management. The element should 363080 be in at the end." 363081 self deny: (res includes: anElementOfTheCollection). 363082 self nonEmpty do: 363083 [:each | (each = anElementOfTheCollection) 363084 ifFalse: [self assert: (res includes: each)]]. 363085 363086! ! 363087 363088!StringTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 363089testCopyNonEmptyWithoutAll 363090 "self debug: #testCopyNonEmptyWithoutAll" 363091 | res | 363092 res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. 363093 "here we do not test the size since for a non empty set we would get a problem. 363094 Then in addition copy is not about duplicate management. The element should 363095 be in at the end." 363096 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]. 363097 self nonEmpty do: 363098 [ :each | 363099 (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! 363100 363101!StringTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! 363102testCopyNonEmptyWithoutAllNotIncluded 363103 ! ! 363104 363105!StringTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 363106testCopyNonEmptyWithoutNotIncluded 363107 "self debug: #testCopyNonEmptyWithoutNotIncluded" 363108 | res | 363109 res := self nonEmpty copyWithout: self elementToAdd. 363110 "here we do not test the size since for a non empty set we would get a problem. 363111 Then in addition copy is not about duplicate management. The element should 363112 be in at the end." 363113 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 363114 363115 363116!StringTest methodsFor: 'tests - copy - clone'! 363117testCopyCreatesNewObject 363118 "self debug: #testCopyCreatesNewObject" 363119 363120 | copy | 363121 copy := self nonEmpty copy. 363122 self deny: self nonEmpty == copy. 363123 ! ! 363124 363125!StringTest methodsFor: 'tests - copy - clone'! 363126testCopyEmpty 363127 "self debug: #testCopyEmpty" 363128 363129 | copy | 363130 copy := self empty copy. 363131 self assert: copy isEmpty.! ! 363132 363133!StringTest methodsFor: 'tests - copy - clone'! 363134testCopyNonEmpty 363135 "self debug: #testCopyNonEmpty" 363136 363137 | copy | 363138 copy := self nonEmpty copy. 363139 self deny: copy isEmpty. 363140 self assert: copy size = self nonEmpty size. 363141 self nonEmpty do: 363142 [:each | copy includes: each]! ! 363143 363144 363145!StringTest methodsFor: 'tests - copying part of sequenceable'! 363146testCopyAfter 363147 | result index collection | 363148 collection := self collectionWithoutEqualsElements . 363149 index:= self indexInForCollectionWithoutDuplicates . 363150 result := collection copyAfter: (collection at:index ). 363151 363152 "verifying content: " 363153 (1) to: result size do: 363154 [:i | 363155 self assert: (collection at:(i + index ))=(result at: (i))]. 363156 363157 "verify size: " 363158 self assert: result size = (collection size - index).! ! 363159 363160!StringTest methodsFor: 'tests - copying part of sequenceable'! 363161testCopyAfterEmpty 363162 | result | 363163 result := self empty copyAfter: self collectionWithoutEqualsElements first. 363164 self assert: result isEmpty. 363165 ! ! 363166 363167!StringTest methodsFor: 'tests - copying part of sequenceable'! 363168testCopyAfterLast 363169 | result index collection | 363170 collection := self collectionWithoutEqualsElements . 363171 index:= self indexInForCollectionWithoutDuplicates . 363172 result := collection copyAfterLast: (collection at:index ). 363173 363174 "verifying content: " 363175 (1) to: result size do: 363176 [:i | 363177 self assert: (collection at:(i + index ))=(result at: (i))]. 363178 363179 "verify size: " 363180 self assert: result size = (collection size - index).! ! 363181 363182!StringTest methodsFor: 'tests - copying part of sequenceable'! 363183testCopyAfterLastEmpty 363184 | result | 363185 result := self empty copyAfterLast: self collectionWithoutEqualsElements first. 363186 self assert: result isEmpty.! ! 363187 363188!StringTest methodsFor: 'tests - copying part of sequenceable'! 363189testCopyEmptyMethod 363190 | result | 363191 result := self collectionWithoutEqualsElements copyEmpty . 363192 self assert: result isEmpty . 363193 self assert: result class= self nonEmpty class.! ! 363194 363195!StringTest methodsFor: 'tests - copying part of sequenceable'! 363196testCopyFromTo 363197 | result index collection | 363198 collection := self collectionWithoutEqualsElements . 363199 index :=self indexInForCollectionWithoutDuplicates . 363200 result := collection copyFrom: index to: collection size . 363201 363202 "verify content of 'result' : " 363203 1 to: result size do: 363204 [:i | 363205 self assert: (result at:i)=(collection at: (i + index - 1))]. 363206 363207 "verify size of 'result' : " 363208 self assert: result size = (collection size - index + 1).! ! 363209 363210!StringTest methodsFor: 'tests - copying part of sequenceable'! 363211testCopyUpTo 363212 | result index collection | 363213 collection := self collectionWithoutEqualsElements . 363214 index:= self indexInForCollectionWithoutDuplicates . 363215 result := collection copyUpTo: (collection at:index). 363216 363217 "verify content of 'result' :" 363218 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 363219 363220 "verify size of 'result' :" 363221 self assert: result size = (index-1). 363222 ! ! 363223 363224!StringTest methodsFor: 'tests - copying part of sequenceable'! 363225testCopyUpToEmpty 363226 | result | 363227 result := self empty copyUpTo: self collectionWithoutEqualsElements first. 363228 self assert: result isEmpty. 363229 ! ! 363230 363231!StringTest methodsFor: 'tests - copying part of sequenceable'! 363232testCopyUpToLast 363233 | result index collection | 363234 collection := self collectionWithoutEqualsElements . 363235 index:= self indexInForCollectionWithoutDuplicates . 363236 result := collection copyUpToLast: (collection at:index). 363237 363238 "verify content of 'result' :" 363239 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 363240 363241 "verify size of 'result' :" 363242 self assert: result size = (index-1).! ! 363243 363244!StringTest methodsFor: 'tests - copying part of sequenceable'! 363245testCopyUpToLastEmpty 363246 | result | 363247 result := self empty copyUpToLast: self collectionWithoutEqualsElements first. 363248 self assert: result isEmpty.! ! 363249 363250 363251!StringTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 363252testCopyAfterLastWithDuplicate 363253 | result element collection | 363254 collection := self collectionWithSameAtEndAndBegining . 363255 element := collection first. 363256 363257 " collectionWithSameAtEndAndBegining first and last elements are equals. 363258 'copyAfter:' should copy after the last occurence of element :" 363259 result := collection copyAfterLast: (element ). 363260 363261 "verifying content: " 363262 self assert: result isEmpty. 363263 363264! ! 363265 363266!StringTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 363267testCopyAfterWithDuplicate 363268 | result element collection | 363269 collection := self collectionWithSameAtEndAndBegining . 363270 element := collection last. 363271 363272 " collectionWithSameAtEndAndBegining first and last elements are equals. 363273 'copyAfter:' should copy after the first occurence :" 363274 result := collection copyAfter: (element ). 363275 363276 "verifying content: " 363277 1 to: result size do: 363278 [:i | 363279 self assert: (collection at:(i + 1 )) = (result at: (i)) 363280 ]. 363281 363282 "verify size: " 363283 self assert: result size = (collection size - 1).! ! 363284 363285!StringTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 363286testCopyUpToLastWithDuplicate 363287 | result element collection | 363288 collection := self collectionWithSameAtEndAndBegining . 363289 element := collection first. 363290 363291 " collectionWithSameAtEndAndBegining first and last elements are equals. 363292 'copyUpToLast:' should copy until the last occurence :" 363293 result := collection copyUpToLast: (element ). 363294 363295 "verifying content: " 363296 1 to: result size do: 363297 [:i | 363298 self assert: (result at: i ) = ( collection at: i ) 363299 ]. 363300 363301 self assert: result size = (collection size - 1). 363302 363303! ! 363304 363305!StringTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 363306testCopyUpToWithDuplicate 363307 | result element collection | 363308 collection := self collectionWithSameAtEndAndBegining . 363309 element := collection last. 363310 363311 " collectionWithSameAtEndAndBegining first and last elements are equals. 363312 'copyUpTo:' should copy until the first occurence :" 363313 result := collection copyUpTo: (element ). 363314 363315 "verifying content: " 363316 self assert: result isEmpty. 363317 363318! ! 363319 363320 363321!StringTest methodsFor: 'tests - copying same contents'! 363322testReverse 363323 | result | 363324 result := self nonEmpty reverse . 363325 363326 "verify content of 'result: '" 363327 1 to: result size do: 363328 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 363329 "verify size of 'result' :" 363330 self assert: result size=self nonEmpty size.! ! 363331 363332!StringTest methodsFor: 'tests - copying same contents'! 363333testReversed 363334 | result | 363335 result := self nonEmpty reversed . 363336 363337 "verify content of 'result: '" 363338 1 to: result size do: 363339 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 363340 "verify size of 'result' :" 363341 self assert: result size=self nonEmpty size.! ! 363342 363343!StringTest methodsFor: 'tests - copying same contents'! 363344testShallowCopy 363345 | result | 363346 result := self nonEmpty shallowCopy . 363347 363348 "verify content of 'result: '" 363349 1 to: self nonEmpty size do: 363350 [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. 363351 "verify size of 'result' :" 363352 self assert: result size=self nonEmpty size.! ! 363353 363354!StringTest methodsFor: 'tests - copying same contents'! 363355testShallowCopyEmpty 363356 | result | 363357 result := self empty shallowCopy . 363358 self assert: result isEmpty .! ! 363359 363360!StringTest methodsFor: 'tests - copying same contents'! 363361testShuffled 363362 | result | 363363 result := self nonEmpty shuffled . 363364 363365 "verify content of 'result: '" 363366 result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. 363367 "verify size of 'result' :" 363368 self assert: result size=self nonEmpty size.! ! 363369 363370!StringTest methodsFor: 'tests - copying same contents'! 363371testSortBy 363372 " can only be used if the collection tested can include sortable elements :" 363373 | result tmp | 363374 self 363375 shouldnt: [ self collectionWithSortableElements ] 363376 raise: Error. 363377 self shouldnt: [self collectionWithSortableElements anyOne < self collectionWithSortableElements anyOne] raise: Error. 363378 result := self collectionWithSortableElements sortBy: [ :a :b | a < b ]. 363379 363380 "verify content of 'result' : " 363381 result do: 363382 [ :each | 363383 (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 363384 tmp := result first. 363385 result do: 363386 [ :each | 363387 self assert: each >= tmp. 363388 tmp := each ]. 363389 363390 "verify size of 'result' :" 363391 self assert: result size = self collectionWithSortableElements size! ! 363392 363393 363394!StringTest methodsFor: 'tests - copying with or without'! 363395testCopyWithFirst 363396 363397 | index element result | 363398 index:= self indexInNonEmpty . 363399 element:= self nonEmpty at: index. 363400 363401 result := self nonEmpty copyWithFirst: element. 363402 363403 self assert: result size = (self nonEmpty size + 1). 363404 self assert: result first = element . 363405 363406 2 to: result size do: 363407 [ :i | 363408 self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! 363409 363410!StringTest methodsFor: 'tests - copying with or without'! 363411testCopyWithSequenceable 363412 363413 | result index element | 363414 index := self indexInNonEmpty . 363415 element := self nonEmpty at: index. 363416 result := self nonEmpty copyWith: (element ). 363417 363418 self assert: result size = (self nonEmpty size + 1). 363419 self assert: result last = element . 363420 363421 1 to: (result size - 1) do: 363422 [ :i | 363423 self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! 363424 363425!StringTest methodsFor: 'tests - copying with or without'! 363426testCopyWithoutFirst 363427 363428 | result | 363429 result := self nonEmpty copyWithoutFirst. 363430 363431 self assert: result size = (self nonEmpty size - 1). 363432 363433 1 to: result size do: 363434 [:i | 363435 self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! 363436 363437!StringTest methodsFor: 'tests - copying with or without'! 363438testCopyWithoutIndex 363439 | result index | 363440 index := self indexInNonEmpty . 363441 result := self nonEmpty copyWithoutIndex: index . 363442 363443 "verify content of 'result:'" 363444 1 to: result size do: 363445 [:i | 363446 i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. 363447 i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. 363448 363449 "verify size of result : " 363450 self assert: result size=(self nonEmpty size -1).! ! 363451 363452!StringTest methodsFor: 'tests - copying with or without'! 363453testForceToPaddingStartWith 363454 363455 | result element | 363456 element := self nonEmpty at: self indexInNonEmpty . 363457 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). 363458 363459 "verify content of 'result' : " 363460 1 to: 2 do: 363461 [:i | self assert: ( element ) = ( result at:(i) ) ]. 363462 363463 3 to: result size do: 363464 [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. 363465 363466 "verify size of 'result' :" 363467 self assert: result size = (self nonEmpty size + 2).! ! 363468 363469!StringTest methodsFor: 'tests - copying with or without'! 363470testForceToPaddingWith 363471 363472 | result element | 363473 element := self nonEmpty at: self indexInNonEmpty . 363474 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). 363475 363476 "verify content of 'result' : " 363477 1 to: self nonEmpty size do: 363478 [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. 363479 363480 (result size - 1) to: result size do: 363481 [:i | self assert: ( result at:i ) = ( element ) ]. 363482 363483 "verify size of 'result' :" 363484 self assert: result size = (self nonEmpty size + 2).! ! 363485 363486 363487!StringTest methodsFor: 'tests - copying with replacement'! 363488firstIndexesOf: subCollection in: collection 363489" return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " 363490 | tmp result currentIndex | 363491 tmp:= collection. 363492 result:= OrderedCollection new. 363493 currentIndex := 1. 363494 363495 [tmp isEmpty ]whileFalse: 363496 [ 363497 (tmp beginsWith: subCollection) 363498 ifTrue: [ 363499 result add: currentIndex. 363500 1 to: subCollection size do: 363501 [:i | 363502 tmp := tmp copyWithoutFirst. 363503 currentIndex := currentIndex + 1] 363504 ] 363505 ifFalse: [ 363506 tmp := tmp copyWithoutFirst. 363507 currentIndex := currentIndex +1. 363508 ] 363509 ]. 363510 363511 ^ result. 363512 ! ! 363513 363514!StringTest methodsFor: 'tests - copying with replacement'! 363515testCopyReplaceAllWith1Occurence 363516 | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | 363517 363518 result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 363519 363520 "detecting indexes of olSubCollection" 363521 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . 363522 index:= firstIndexesOfOccurrence at: 1. 363523 363524 "verify content of 'result' : " 363525 "first part of 'result'' : '" 363526 363527 1 to: (index -1) do: 363528 [ 363529 :i | 363530 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 363531 ]. 363532 363533 " middle part containing replacementCollection : " 363534 363535 index to: (index + self replacementCollection size-1) do: 363536 [ 363537 :i | 363538 self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) 363539 ]. 363540 363541 " end part :" 363542 363543 endPartIndexResult := index + self replacementCollection size . 363544 endPartIndexCollection := index + self oldSubCollection size . 363545 363546 1 to: (result size - endPartIndexResult - 1 ) do: 363547 [ 363548 :i | 363549 self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). 363550 ]. 363551 363552 363553 ! ! 363554 363555!StringTest methodsFor: 'tests - copying with replacement'! 363556testCopyReplaceAllWithManyOccurence 363557 | result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff | 363558 " testing fixture here as this method may be not used for collection that can't contain equals element :" 363559 self shouldnt: [self collectionWith2TimeSubcollection ]raise: Error. 363560 self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection ) = 2. 363561 363562 " test :" 363563 diff := self replacementCollection size - self oldSubCollection size. 363564 result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 363565 363566 "detecting indexes of olSubCollection" 363567 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection . 363568 363569 " verifying that replacementCollection has been put in places of oldSubCollections " 363570 firstIndexesOfOccurrence do: [ 363571 :each | 363572 (firstIndexesOfOccurrence indexOf: each) = 1 363573 ifTrue: [ 363574 each to: self replacementCollection size do: 363575 [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. 363576 ] 363577 ifFalse:[ 363578 (each + diff) to: self replacementCollection size do: 363579 [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. 363580 ]. 363581 363582 ]. 363583 363584 " verifying that the 'between' parts correspond to the initial collection : " 363585 1 to: firstIndexesOfOccurrence size do: [ 363586 :i | 363587 i = 1 363588 " specific comportement for the begining of the collection :" 363589 ifTrue: [ 363590 1 to: ((firstIndexesOfOccurrence at: i) - 1 ) do: 363591 [ :j | 363592 self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] 363593 ] 363594 " between parts till the end : " 363595 ifFalse: [ 363596 resultBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self replacementCollection size. 363597 collectionBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self oldSubCollection size. 363598 363599 1 to: ( firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: 363600 [ :j | 363601 self assert: (result at: (resultBetweenPartIndex + i - 1)) = (self collectionWith2TimeSubcollection at: (collectionBetweenPartIndex +i - 1)) ] 363602 ] 363603 ]. 363604 363605 "final part :" 363606 1 to: (self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size ) ) do: 363607 [ 363608 :i | 363609 self assert: ( result at:(firstIndexesOfOccurrence last + self replacementCollection size -1) + i ) = ( self collectionWith2TimeSubcollection at:(firstIndexesOfOccurrence last + self oldSubCollection size -1) + i ) . 363610 ]! ! 363611 363612!StringTest methodsFor: 'tests - copying with replacement'! 363613testCopyReplaceFromToWith 363614 | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | 363615 363616 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 363617 lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. 363618 lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. 363619 363620 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . 363621 363622 "verify content of 'result' : " 363623 "first part of 'result' " 363624 363625 1 to: (indexOfSubcollection - 1) do: 363626 [ 363627 :i | 363628 self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) 363629 ]. 363630 363631 " middle part containing replacementCollection : " 363632 363633 (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: 363634 [ 363635 :i | 363636 self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) 363637 ]. 363638 363639 " end part :" 363640 1 to: (result size - lastIndexOfReplacementCollection ) do: 363641 [ 363642 :i | 363643 self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). 363644 ]. 363645 363646 363647 363648 363649 363650 ! ! 363651 363652!StringTest methodsFor: 'tests - copying with replacement'! 363653testCopyReplaceFromToWithInsertion 363654 | result indexOfSubcollection | 363655 363656 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 363657 363658 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . 363659 363660 "verify content of 'result' : " 363661 "first part of 'result'' : '" 363662 363663 1 to: (indexOfSubcollection -1) do: 363664 [ 363665 :i | 363666 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 363667 ]. 363668 363669 " middle part containing replacementCollection : " 363670 indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: 363671 [ 363672 :i | 363673 self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) 363674 ]. 363675 363676 " end part :" 363677 (indexOfSubcollection + self replacementCollection size) to: (result size) do: 363678 [:i| 363679 self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. 363680 363681 " verify size: " 363682 self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). 363683 363684 363685 363686 363687 363688 ! ! 363689 363690 363691!StringTest methodsFor: 'tests - element accessing'! 363692testAfter 363693 "self debug: #testAfter" 363694 self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). 363695 self 363696 should: 363697 [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] 363698 raise: Error. 363699 self 363700 should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] 363701 raise: Error! ! 363702 363703!StringTest methodsFor: 'tests - element accessing'! 363704testAfterIfAbsent 363705 "self debug: #testAfterIfAbsent" 363706 self assert: (self moreThan4Elements 363707 after: (self moreThan4Elements at: 1) 363708 ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). 363709 self assert: (self moreThan4Elements 363710 after: (self moreThan4Elements at: self moreThan4Elements size) 363711 ifAbsent: [ 33 ]) == 33. 363712 self assert: (self moreThan4Elements 363713 after: self elementNotInForElementAccessing 363714 ifAbsent: [ 33 ]) = 33! ! 363715 363716!StringTest methodsFor: 'tests - element accessing'! 363717testAtAll 363718 "self debug: #testAtAll" 363719 " self flag: #theCollectionshouldbe102030intheFixture. 363720 363721 self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. 363722 self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." 363723 | result | 363724 result := self moreThan4Elements atAll: #(2 1 2 ). 363725 self assert: (result at: 1) = (self moreThan4Elements at: 2). 363726 self assert: (result at: 2) = (self moreThan4Elements at: 1). 363727 self assert: (result at: 3) = (self moreThan4Elements at: 2). 363728 self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! 363729 363730!StringTest methodsFor: 'tests - element accessing'! 363731testAtIfAbsent 363732 "self debug: #testAt" 363733 | absent | 363734 absent := false. 363735 self moreThan4Elements 363736 at: self moreThan4Elements size + 1 363737 ifAbsent: [ absent := true ]. 363738 self assert: absent = true. 363739 absent := false. 363740 self moreThan4Elements 363741 at: self moreThan4Elements size 363742 ifAbsent: [ absent := true ]. 363743 self assert: absent = false! ! 363744 363745!StringTest methodsFor: 'tests - element accessing'! 363746testAtLast 363747 "self debug: #testAtLast" 363748 | index | 363749 self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. 363750 "tmp:=1. 363751 self do: 363752 [:each | 363753 each =self elementInForIndexAccessing 363754 ifTrue:[index:=tmp]. 363755 tmp:=tmp+1]." 363756 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 363757 self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! 363758 363759!StringTest methodsFor: 'tests - element accessing'! 363760testAtLastError 363761 "self debug: #testAtLast" 363762 self 363763 should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] 363764 raise: Error! ! 363765 363766!StringTest methodsFor: 'tests - element accessing'! 363767testAtLastIfAbsent 363768 "self debug: #testAtLastIfAbsent" 363769 self assert: (self moreThan4Elements 363770 atLast: 1 363771 ifAbsent: [ nil ]) = self moreThan4Elements last. 363772 self assert: (self moreThan4Elements 363773 atLast: self moreThan4Elements size + 1 363774 ifAbsent: [ 222 ]) = 222! ! 363775 363776!StringTest methodsFor: 'tests - element accessing'! 363777testAtOutOfBounds 363778 "self debug: #testAtOutOfBounds" 363779 self 363780 should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] 363781 raise: Error. 363782 self 363783 should: [ self moreThan4Elements at: -1 ] 363784 raise: Error! ! 363785 363786!StringTest methodsFor: 'tests - element accessing'! 363787testAtPin 363788 "self debug: #testAtPin" 363789 self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. 363790 self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. 363791 self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! 363792 363793!StringTest methodsFor: 'tests - element accessing'! 363794testAtRandom 363795 | result | 363796 result := self nonEmpty atRandom . 363797 self assert: (self nonEmpty includes: result).! ! 363798 363799!StringTest methodsFor: 'tests - element accessing'! 363800testAtWrap 363801 "self debug: #testAt" 363802 " 363803 self assert: (self accessCollection at: 1) = 1. 363804 self assert: (self accessCollection at: 2) = 2. 363805 " 363806 | index | 363807 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 363808 self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. 363809 self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. 363810 self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. 363811 self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! 363812 363813!StringTest methodsFor: 'tests - element accessing'! 363814testBefore 363815 "self debug: #testBefore" 363816 self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). 363817 self 363818 should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] 363819 raise: Error. 363820 self 363821 should: [ self moreThan4Elements before: 66 ] 363822 raise: Error! ! 363823 363824!StringTest methodsFor: 'tests - element accessing'! 363825testBeforeIfAbsent 363826 "self debug: #testBefore" 363827 self assert: (self moreThan4Elements 363828 before: (self moreThan4Elements at: 1) 363829 ifAbsent: [ 99 ]) = 99. 363830 self assert: (self moreThan4Elements 363831 before: (self moreThan4Elements at: 2) 363832 ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! 363833 363834!StringTest methodsFor: 'tests - element accessing'! 363835testFirstSecondThird 363836 "self debug: #testFirstSecondThird" 363837 self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). 363838 self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). 363839 self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). 363840 self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! 363841 363842!StringTest methodsFor: 'tests - element accessing'! 363843testLast 363844 "self debug: #testLast" 363845 self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! 363846 363847!StringTest methodsFor: 'tests - element accessing'! 363848testMiddle 363849 "self debug: #testMiddle" 363850 self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! 363851 363852 363853!StringTest methodsFor: 'tests - equality'! 363854testEqualSignForSequenceableCollections 363855 "self debug: #testEqualSign" 363856 363857 self deny: (self nonEmpty = self nonEmpty asSet). 363858 self deny: (self nonEmpty reversed = self nonEmpty). 363859 self deny: (self nonEmpty = self nonEmpty reversed).! ! 363860 363861!StringTest methodsFor: 'tests - equality'! 363862testHasEqualElements 363863 "self debug: #testHasEqualElements" 363864 363865 self deny: (self empty hasEqualElements: self nonEmpty). 363866 self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). 363867 self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). 363868 self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! 363869 363870!StringTest methodsFor: 'tests - equality'! 363871testHasEqualElementsIsTrueForNonIdenticalButEqualCollections 363872 "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" 363873 363874 self assert: (self empty hasEqualElements: self empty copy). 363875 self assert: (self empty copy hasEqualElements: self empty). 363876 self assert: (self empty copy hasEqualElements: self empty copy). 363877 363878 self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). 363879 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). 363880 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! 363881 363882!StringTest methodsFor: 'tests - equality'! 363883testHasEqualElementsOfIdenticalCollectionObjects 363884 "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" 363885 363886 self assert: (self empty hasEqualElements: self empty). 363887 self assert: (self nonEmpty hasEqualElements: self nonEmpty). 363888 ! ! 363889 363890 363891!StringTest methodsFor: 'tests - fixture'! 363892howMany: subCollection in: collection 363893" return an integer representing how many time 'subCollection' appears in 'collection' " 363894 | tmp nTime | 363895 tmp:= collection. 363896 nTime:= 0. 363897 363898 [tmp isEmpty ]whileFalse: 363899 [ 363900 (tmp beginsWith: subCollection) 363901 ifTrue: [ 363902 nTime := nTime + 1. 363903 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] 363904 ] 363905 ifFalse: [tmp := tmp copyWithoutFirst.] 363906 ]. 363907 363908 ^ nTime. 363909 ! ! 363910 363911!StringTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/17/2009 15:26'! 363912test0CopyTest 363913 self 363914 shouldnt: self empty 363915 raise: Error. 363916 self assert: self empty size = 0. 363917 self 363918 shouldnt: self nonEmpty 363919 raise: Error. 363920 self assert: (self nonEmpty size = 0) not. 363921 self 363922 shouldnt: self collectionWithElementsToRemove 363923 raise: Error. 363924 self assert: (self collectionWithElementsToRemove size = 0) not. 363925 self 363926 shouldnt: self elementToAdd 363927 raise: Error! ! 363928 363929!StringTest methodsFor: 'tests - fixture'! 363930test0FixtureAsStringCommaAndDelimiterTest 363931 363932 self shouldnt: [self nonEmpty] raise:Error . 363933 self deny: self nonEmpty isEmpty. 363934 363935 self shouldnt: [self empty] raise:Error . 363936 self assert: self empty isEmpty. 363937 363938 self shouldnt: [self nonEmpty1Element ] raise:Error . 363939 self assert: self nonEmpty1Element size=1.! ! 363940 363941!StringTest methodsFor: 'tests - fixture'! 363942test0FixtureBeginsEndsWithTest 363943 363944 self shouldnt: [self nonEmpty ] raise: Error. 363945 self deny: self nonEmpty isEmpty. 363946 self assert: self nonEmpty size>1. 363947 363948 self shouldnt: [self empty ] raise: Error. 363949 self assert: self empty isEmpty.! ! 363950 363951!StringTest methodsFor: 'tests - fixture'! 363952test0FixtureCloneTest 363953 363954self shouldnt: [ self nonEmpty ] raise: Error. 363955self deny: self nonEmpty isEmpty. 363956 363957self shouldnt: [ self empty ] raise: Error. 363958self assert: self empty isEmpty. 363959 363960! ! 363961 363962!StringTest methodsFor: 'tests - fixture'! 363963test0FixtureConverAsSortedTest 363964 363965 self shouldnt: [self collectionWithSortableElements ] raise: Error. 363966 self deny: self collectionWithSortableElements isEmpty .! ! 363967 363968!StringTest methodsFor: 'tests - fixture'! 363969test0FixtureCopyPartOfForMultipliness 363970 363971self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. 363972 363973self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 363974 363975self assert: self collectionWithSameAtEndAndBegining size > 1. 363976 3639771 to: self collectionWithSameAtEndAndBegining size do: 363978 [:i | 363979 (i > 1 ) & (i < self collectionWithSameAtEndAndBegining size) 363980 ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at:i) = (self collectionWithSameAtEndAndBegining first)]. 363981 ]! ! 363982 363983!StringTest methodsFor: 'tests - fixture'! 363984test0FixtureCopyPartOfSequenceableTest 363985 363986 self shouldnt: [self collectionWithoutEqualsElements ] raise: Error. 363987 self collectionWithoutEqualsElements do: 363988 [:each | self assert: (self collectionWithoutEqualsElements occurrencesOf: each)=1]. 363989 363990 self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. 363991 self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualsElements size. 363992 363993 self shouldnt: [self empty] raise: Error. 363994 self assert: self empty isEmpty .! ! 363995 363996!StringTest methodsFor: 'tests - fixture'! 363997test0FixtureCopySameContentsTest 363998 363999 self shouldnt: [self nonEmpty ] raise: Error. 364000 self deny: self nonEmpty isEmpty. 364001 364002 self shouldnt: [self empty ] raise: Error. 364003 self assert: self empty isEmpty. 364004 364005! ! 364006 364007!StringTest methodsFor: 'tests - fixture'! 364008test0FixtureCopyWithOrWithoutSpecificElementsTest 364009 364010 self shouldnt: [self nonEmpty ] raise: Error. 364011 self deny: self nonEmpty isEmpty . 364012 364013 self shouldnt: [self indexInNonEmpty ] raise: Error. 364014 self assert: self indexInNonEmpty > 0. 364015 self assert: self indexInNonEmpty <= self nonEmpty size.! ! 364016 364017!StringTest methodsFor: 'tests - fixture'! 364018test0FixtureCopyWithReplacementTest 364019 364020 self shouldnt: [self replacementCollection ]raise: Error. 364021 self shouldnt: [self oldSubCollection] raise: Error. 364022 364023 self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. 364024 self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. 364025 364026 ! ! 364027 364028!StringTest methodsFor: 'tests - fixture'! 364029test0FixtureCreationWithTest 364030 364031self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. 364032self assert: self collectionMoreThan5Elements size >= 5.! ! 364033 364034!StringTest methodsFor: 'tests - fixture'! 364035test0FixtureIncludeTest 364036 | elementIn | 364037 self shouldnt: [ self nonEmpty ]raise: Error. 364038 self deny: self nonEmpty isEmpty. 364039 364040 self shouldnt: [ self elementNotIn ]raise: Error. 364041 364042 elementIn := true. 364043 self nonEmpty detect: 364044 [ :each | each = self elementNotIn ] 364045 ifNone: [ elementIn := false ]. 364046 self assert: elementIn = false. 364047 364048 self shouldnt: [ self anotherElementNotIn ]raise: Error. 364049 364050 elementIn := true. 364051 self nonEmpty detect: 364052 [ :each | each = self anotherElementNotIn ] 364053 ifNone: [ elementIn := false ]. 364054 self assert: elementIn = false. 364055 364056 self shouldnt: [ self empty ] raise: Error. 364057 self assert: self empty isEmpty. 364058 364059! ! 364060 364061!StringTest methodsFor: 'tests - fixture'! 364062test0FixtureIndexAccessFotMultipliness 364063 self 364064 shouldnt: [ self collectionWithSameAtEndAndBegining ] 364065 raise: Error. 364066 self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 364067 self assert: self collectionWithSameAtEndAndBegining size > 1. 364068 1 to: self collectionWithSameAtEndAndBegining size 364069 do: 364070 [ :i | 364071 i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: 364072 [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! 364073 364074!StringTest methodsFor: 'tests - fixture'! 364075test0FixtureIndexAccessTest 364076 | res collection element | 364077 self 364078 shouldnt: [ self collectionMoreThan1NoDuplicates ] 364079 raise: Error. 364080 self assert: self collectionMoreThan1NoDuplicates size >1. 364081 res := true. 364082 self collectionMoreThan1NoDuplicates 364083 detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] 364084 ifNone: [ res := false ]. 364085 self assert: res = false. 364086 self 364087 shouldnt: [ self elementInForIndexAccessing ] 364088 raise: Error. 364089 self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). 364090 self 364091 shouldnt: [ self elementNotInForIndexAccessing ] 364092 raise: Error. 364093 self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! 364094 364095!StringTest methodsFor: 'tests - fixture'! 364096test0FixtureIterateSequencedReadableTest 364097 364098 | res | 364099 364100 self shouldnt: self nonEmptyMoreThan1Element raise: Error. 364101 self assert: self nonEmptyMoreThan1Element size > 1. 364102 364103 364104 self shouldnt: self empty raise: Error. 364105 self assert: self empty isEmpty . 364106 364107 res := true. 364108 self nonEmptyMoreThan1Element 364109 detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] 364110 ifNone: [ res := false ]. 364111 self assert: res = false.! ! 364112 364113!StringTest methodsFor: 'tests - fixture'! 364114test0FixtureOccurrencesForMultiplinessTest 364115 | cpt element collection | 364116 self shouldnt: [self collectionWithEqualElements ]raise: Error. 364117self shouldnt: [self collectionWithEqualElements ]raise: Error. 364118 364119self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 364120element := self elementTwiceInForOccurrences . 364121collection := self collectionWithEqualElements . 364122 364123cpt := 0 . 364124" testing with identity check ( == ) so that identy collections can use this trait : " 364125self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. 364126self assert: cpt = 2.! ! 364127 364128!StringTest methodsFor: 'tests - fixture'! 364129test0FixtureOccurrencesTest 364130 | tmp | 364131 self shouldnt: [self empty ]raise: Error. 364132 self assert: self empty isEmpty. 364133 364134 self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. 364135 self deny: self collectionWithoutEqualElements isEmpty. 364136 364137 tmp := OrderedCollection new. 364138 self collectionWithoutEqualElements do: [ 364139 :each | 364140 self deny: (tmp includes: each). 364141 tmp add: each. 364142 ]. 364143 364144 364145 self shouldnt: [ self elementNotInForOccurrences ] raise: Error. 364146 self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! 364147 364148!StringTest methodsFor: 'tests - fixture'! 364149test0FixturePrintTest 364150 364151 self shouldnt: [self nonEmpty ] raise: Error.! ! 364152 364153!StringTest methodsFor: 'tests - fixture'! 364154test0FixturePutOneOrMoreElementsTest 364155 self shouldnt: self aValue raise: Error. 364156 364157 364158 self shouldnt: self indexArray raise: Error. 364159 self indexArray do: [ 364160 :each| 364161 self assert: each class = SmallInteger. 364162 self assert: (each>=1 & each<= self nonEmpty size). 364163 ]. 364164 364165 self assert: self indexArray size = self valueArray size. 364166 364167 self shouldnt: self empty raise: Error. 364168 self assert: self empty isEmpty . 364169 364170 self shouldnt: self nonEmpty raise: Error. 364171 self deny: self nonEmpty isEmpty.! ! 364172 364173!StringTest methodsFor: 'tests - fixture'! 364174test0FixturePutTest 364175 self shouldnt: self aValue raise: Error. 364176 self shouldnt: self anotherValue raise: Error. 364177 364178 self shouldnt: self anIndex raise: Error. 364179 self nonEmpty isDictionary 364180 ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. 364181 364182 self shouldnt: self empty raise: Error. 364183 self assert: self empty isEmpty . 364184 364185 self shouldnt: self nonEmpty raise: Error. 364186 self deny: self nonEmpty isEmpty.! ! 364187 364188!StringTest methodsFor: 'tests - fixture'! 364189test0FixtureSequencedConcatenationTest 364190 self 364191 shouldnt: self empty 364192 raise: Exception. 364193 self assert: self empty isEmpty. 364194 self 364195 shouldnt: self firstCollection 364196 raise: Exception. 364197 self 364198 shouldnt: self secondCollection 364199 raise: Exception! ! 364200 364201!StringTest methodsFor: 'tests - fixture'! 364202test0FixtureSequencedElementAccessTest 364203 self 364204 shouldnt: [ self moreThan4Elements ] 364205 raise: Error. 364206 self assert: self moreThan4Elements size >= 4. 364207 self 364208 shouldnt: [ self subCollectionNotIn ] 364209 raise: Error. 364210 self subCollectionNotIn 364211 detect: [ :each | (self moreThan4Elements includes: each) not ] 364212 ifNone: [ self assert: false ]. 364213 self 364214 shouldnt: [ self elementNotInForElementAccessing ] 364215 raise: Error. 364216 self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). 364217 self 364218 shouldnt: [ self elementInForElementAccessing ] 364219 raise: Error. 364220 self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! 364221 364222!StringTest methodsFor: 'tests - fixture'! 364223test0FixtureSetAritmeticTest 364224 self 364225 shouldnt: [ self collection ] 364226 raise: Error. 364227 self deny: self collection isEmpty. 364228 self 364229 shouldnt: [ self nonEmpty ] 364230 raise: Error. 364231 self deny: self nonEmpty isEmpty. 364232 self 364233 shouldnt: [ self anotherElementOrAssociationNotIn ] 364234 raise: Error. 364235 self collection isDictionary 364236 ifTrue: 364237 [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] 364238 ifFalse: 364239 [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. 364240 self 364241 shouldnt: [ self collectionClass ] 364242 raise: Error! ! 364243 364244!StringTest methodsFor: 'tests - fixture'! 364245test0FixtureSubcollectionAccessTest 364246 self 364247 shouldnt: [ self moreThan3Elements ] 364248 raise: Error. 364249 self assert: self moreThan3Elements size > 2! ! 364250 364251!StringTest methodsFor: 'tests - fixture'! 364252test0FixtureTConvertAsSetForMultiplinessTest 364253 "a collection with equal elements:" 364254 | res | 364255 self shouldnt: [ self withEqualElements] raise: Error. 364256 364257 res := true. 364258 self withEqualElements 364259 detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] 364260 ifNone: [ res := false ]. 364261 self assert: res = true. 364262 364263! ! 364264 364265!StringTest methodsFor: 'tests - fixture'! 364266test0FixtureTConvertTest 364267 "a collection of number without equal elements:" 364268 | res | 364269 self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. 364270 364271 res := true. 364272 self collectionWithoutEqualElements 364273 detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] 364274 ifNone: [ res := false ]. 364275 self assert: res = false. 364276 364277 364278! ! 364279 364280!StringTest methodsFor: 'tests - fixture'! 364281test0SortingArrayedTest 364282 | tmp sorted | 364283 " an unsorted collection of number " 364284 self shouldnt: [ self unsortedCollection ]raise: Error. 364285 self unsortedCollection do:[:each | each isNumber]. 364286 sorted := true. 364287 self unsortedCollection pairsDo: [ 364288 :each1 :each2 | 364289 each2 < each1 ifTrue: [ sorted := false]. 364290 ]. 364291 self assert: sorted = false. 364292 364293 364294 364295 " a collection of number sorted in an ascending order" 364296 self shouldnt: [ self sortedInAscendingOrderCollection ]raise: Error. 364297 self sortedInAscendingOrderCollection do:[:each | each isNumber]. 364298 tmp:= self sortedInAscendingOrderCollection at:1. 364299 self sortedInAscendingOrderCollection do: 364300 [: each | self assert: (each>= tmp). tmp:=each] 364301 ! ! 364302 364303!StringTest methodsFor: 'tests - fixture'! 364304test0TSequencedStructuralEqualityTest 364305 364306 self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! 364307 364308!StringTest methodsFor: 'tests - fixture'! 364309test0TStructuralEqualityTest 364310 self shouldnt: [self empty] raise: Error. 364311 self shouldnt: [self nonEmpty] raise: Error. 364312 self assert: self empty isEmpty. 364313 self deny: self nonEmpty isEmpty.! ! 364314 364315!StringTest methodsFor: 'tests - fixture'! 364316testOFixtureReplacementSequencedTest 364317 364318 self shouldnt: self nonEmpty raise: Error. 364319 self deny: self nonEmpty isEmpty. 364320 364321 self shouldnt: self elementInForReplacement raise: Error. 364322 self assert: (self nonEmpty includes: self elementInForReplacement ) . 364323 364324 self shouldnt: self newElement raise: Error. 364325 364326 self shouldnt: self firstIndex raise: Error. 364327 self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). 364328 364329 self shouldnt: self secondIndex raise: Error. 364330 self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). 364331 364332 self assert: self firstIndex <=self secondIndex . 364333 364334 self shouldnt: self replacementCollection raise: Error. 364335 364336 self shouldnt: self replacementCollectionSameSize raise: Error. 364337 self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size 364338 ! ! 364339 364340 364341!StringTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 15:09'! 364342anotherElementNotIn 364343 ^ $k! ! 364344 364345!StringTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 15:09'! 364346collection 364347 ^ 'ghj'! ! 364348 364349!StringTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 364350elementNotInForOccurrences 364351 ^ $z! ! 364352 364353!StringTest methodsFor: 'tests - includes'! 364354testIdentityIncludesNonSpecificComportement 364355 " test the same comportement than 'includes: ' " 364356 | collection | 364357 collection := self nonEmpty . 364358 364359 self deny: (collection identityIncludes: self elementNotIn ). 364360 self assert:(collection identityIncludes: collection anyOne) 364361! ! 364362 364363!StringTest methodsFor: 'tests - includes'! 364364testIncludesAllOfAllThere 364365 "self debug: #testIncludesAllOfAllThere'" 364366 self assert: (self empty includesAllOf: self empty). 364367 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 364368 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 364369 364370!StringTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 364371testIncludesAllOfNoneThere 364372 "self debug: #testIncludesAllOfNoneThere'" 364373 self deny: (self empty includesAllOf: self collection). 364374 self deny: (self nonEmpty includesAllOf: { 364375 (self elementNotIn). 364376 (self anotherElementNotIn) 364377 })! ! 364378 364379!StringTest methodsFor: 'tests - includes'! 364380testIncludesAnyOfAllThere 364381 "self debug: #testIncludesAnyOfAllThere'" 364382 self deny: (self nonEmpty includesAnyOf: self empty). 364383 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 364384 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 364385 364386!StringTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 364387testIncludesAnyOfNoneThere 364388 "self debug: #testIncludesAnyOfNoneThere'" 364389 self deny: (self nonEmpty includesAnyOf: self empty). 364390 self deny: (self nonEmpty includesAnyOf: { 364391 (self elementNotIn). 364392 (self anotherElementNotIn) 364393 })! ! 364394 364395!StringTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! 364396testIncludesElementIsNotThere 364397 "self debug: #testIncludesElementIsNotThere" 364398 self deny: (self nonEmpty includes: self elementNotInForOccurrences). 364399 self assert: (self nonEmpty includes: self nonEmpty anyOne). 364400 self deny: (self empty includes: self elementNotInForOccurrences)! ! 364401 364402!StringTest methodsFor: 'tests - includes'! 364403testIncludesElementIsThere 364404 "self debug: #testIncludesElementIsThere" 364405 364406 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 364407 364408!StringTest methodsFor: 'tests - includes' stamp: 'delaunay 4/9/2009 10:44'! 364409testIncludesSubstringAnywhere 364410 "self debug: #testIncludesSubstringAnywher'" 364411 self assert: (self empty includesAllOf: self empty). 364412 self assert: (self nonEmpty includesAllOf: { (self nonEmpty anyOne) }). 364413 self assert: (self nonEmpty includesAllOf: self nonEmpty)! ! 364414 364415 364416!StringTest methodsFor: 'tests - index access'! 364417testIdentityIndexOf 364418 "self debug: #testIdentityIndexOf" 364419 | collection element | 364420 collection := self collectionMoreThan1NoDuplicates. 364421 element := collection first. 364422 self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! 364423 364424!StringTest methodsFor: 'tests - index access'! 364425testIdentityIndexOfIAbsent 364426 | collection element | 364427 collection := self collectionMoreThan1NoDuplicates. 364428 element := collection first. 364429 self assert: (collection 364430 identityIndexOf: element 364431 ifAbsent: [ 0 ]) = 1. 364432 self assert: (collection 364433 identityIndexOf: self elementNotInForIndexAccessing 364434 ifAbsent: [ 55 ]) = 55! ! 364435 364436!StringTest methodsFor: 'tests - index access'! 364437testIndexOfIfAbsent 364438 "self debug: #testIndexOfIfAbsent" 364439 | collection | 364440 collection := self collectionMoreThan1NoDuplicates. 364441 self assert: (collection 364442 indexOf: collection first 364443 ifAbsent: [ 33 ]) = 1. 364444 self assert: (collection 364445 indexOf: self elementNotInForIndexAccessing 364446 ifAbsent: [ 33 ]) = 33! ! 364447 364448!StringTest methodsFor: 'tests - index access'! 364449testIndexOfStartingAt 364450 "self debug: #testLastIndexOf" 364451 | element collection | 364452 collection := self collectionMoreThan1NoDuplicates. 364453 element := collection first. 364454 self assert: (collection 364455 indexOf: element 364456 startingAt: 2 364457 ifAbsent: [ 99 ]) = 99. 364458 self assert: (collection 364459 indexOf: element 364460 startingAt: 1 364461 ifAbsent: [ 99 ]) = 1. 364462 self assert: (collection 364463 indexOf: self elementNotInForIndexAccessing 364464 startingAt: 1 364465 ifAbsent: [ 99 ]) = 99! ! 364466 364467!StringTest methodsFor: 'tests - index access'! 364468testIndexOfStartingAtIfAbsent 364469 "self debug: #testLastIndexOf" 364470 | element collection | 364471 collection := self collectionMoreThan1NoDuplicates. 364472 element := collection first. 364473 self assert: (collection 364474 indexOf: element 364475 startingAt: 2 364476 ifAbsent: [ 99 ]) = 99. 364477 self assert: (collection 364478 indexOf: element 364479 startingAt: 1 364480 ifAbsent: [ 99 ]) = 1. 364481 self assert: (collection 364482 indexOf: self elementNotInForIndexAccessing 364483 startingAt: 1 364484 ifAbsent: [ 99 ]) = 99! ! 364485 364486!StringTest methodsFor: 'tests - index access'! 364487testIndexOfSubCollectionStartingAt 364488 "self debug: #testIndexOfIfAbsent" 364489 | subcollection index collection | 364490 collection := self collectionMoreThan1NoDuplicates. 364491 subcollection := self collectionMoreThan1NoDuplicates. 364492 index := collection 364493 indexOfSubCollection: subcollection 364494 startingAt: 1. 364495 self assert: index = 1. 364496 index := collection 364497 indexOfSubCollection: subcollection 364498 startingAt: 2. 364499 self assert: index = 0! ! 364500 364501!StringTest methodsFor: 'tests - index access'! 364502testIndexOfSubCollectionStartingAtIfAbsent 364503 "self debug: #testIndexOfIfAbsent" 364504 | index absent subcollection collection | 364505 collection := self collectionMoreThan1NoDuplicates. 364506 subcollection := self collectionMoreThan1NoDuplicates. 364507 absent := false. 364508 index := collection 364509 indexOfSubCollection: subcollection 364510 startingAt: 1 364511 ifAbsent: [ absent := true ]. 364512 self assert: absent = false. 364513 absent := false. 364514 index := collection 364515 indexOfSubCollection: subcollection 364516 startingAt: 2 364517 ifAbsent: [ absent := true ]. 364518 self assert: absent = true! ! 364519 364520!StringTest methodsFor: 'tests - index access'! 364521testLastIndexOf 364522 "self debug: #testLastIndexOf" 364523 | element collection | 364524 collection := self collectionMoreThan1NoDuplicates. 364525 element := collection first. 364526 self assert: (collection lastIndexOf: element) = 1. 364527 self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! 364528 364529!StringTest methodsFor: 'tests - index access'! 364530testLastIndexOfIfAbsent 364531 "self debug: #testIndexOfIfAbsent" 364532 | element collection | 364533 collection := self collectionMoreThan1NoDuplicates. 364534 element := collection first. 364535 self assert: (collection 364536 lastIndexOf: element 364537 ifAbsent: [ 99 ]) = 1. 364538 self assert: (collection 364539 lastIndexOf: self elementNotInForIndexAccessing 364540 ifAbsent: [ 99 ]) = 99! ! 364541 364542!StringTest methodsFor: 'tests - index access'! 364543testLastIndexOfStartingAt 364544 "self debug: #testLastIndexOf" 364545 | element collection | 364546 collection := self collectionMoreThan1NoDuplicates. 364547 element := collection last. 364548 self assert: (collection 364549 lastIndexOf: element 364550 startingAt: collection size 364551 ifAbsent: [ 99 ]) = collection size. 364552 self assert: (collection 364553 lastIndexOf: element 364554 startingAt: collection size - 1 364555 ifAbsent: [ 99 ]) = 99. 364556 self assert: (collection 364557 lastIndexOf: self elementNotInForIndexAccessing 364558 startingAt: collection size 364559 ifAbsent: [ 99 ]) = 99! ! 364560 364561 364562!StringTest methodsFor: 'tests - index accessing for multipliness'! 364563testIndexOfDuplicate 364564 "self debug: #testIndexOf" 364565 | collection element | 364566 collection := self collectionWithSameAtEndAndBegining. 364567 element := collection last. 364568 364569 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 364570 'indexOf: should return the position of the first occurrence :'" 364571 self assert: (collection indexOf: element) = 1! ! 364572 364573!StringTest methodsFor: 'tests - index accessing for multipliness'! 364574testIndexOfIfAbsentDuplicate 364575 "self debug: #testIndexOfIfAbsent" 364576 | collection element | 364577 collection := self collectionWithSameAtEndAndBegining. 364578 element := collection last. 364579 364580 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 364581 'indexOf:ifAbsent: should return the position of the first occurrence :'" 364582 self assert: (collection 364583 indexOf: element 364584 ifAbsent: [ 55 ]) = 1! ! 364585 364586!StringTest methodsFor: 'tests - index accessing for multipliness'! 364587testIndexOfStartingAtDuplicate 364588 "self debug: #testLastIndexOf" 364589 | collection element | 364590 collection := self collectionWithSameAtEndAndBegining. 364591 element := collection last. 364592 364593 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 364594 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" 364595 self assert: (collection 364596 indexOf: element 364597 startingAt: 1 364598 ifAbsent: [ 55 ]) = 1. 364599 self assert: (collection 364600 indexOf: element 364601 startingAt: 2 364602 ifAbsent: [ 55 ]) = collection size! ! 364603 364604!StringTest methodsFor: 'tests - index accessing for multipliness'! 364605testLastIndexOfDuplicate 364606 "self debug: #testLastIndexOf" 364607 | collection element | 364608 collection := self collectionWithSameAtEndAndBegining. 364609 element := collection first. 364610 364611 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 364612 'lastIndexOf: should return the position of the last occurrence :'" 364613 self assert: (collection lastIndexOf: element) = collection size! ! 364614 364615!StringTest methodsFor: 'tests - index accessing for multipliness'! 364616testLastIndexOfIfAbsentDuplicate 364617 "self debug: #testIndexOfIfAbsent" 364618 "self debug: #testLastIndexOf" 364619 | collection element | 364620 collection := self collectionWithSameAtEndAndBegining. 364621 element := collection first. 364622 364623 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 364624 'lastIndexOf: should return the position of the last occurrence :'" 364625 self assert: (collection 364626 lastIndexOf: element 364627 ifAbsent: [ 55 ]) = collection size! ! 364628 364629!StringTest methodsFor: 'tests - index accessing for multipliness'! 364630testLastIndexOfStartingAtDuplicate 364631 "self debug: #testLastIndexOf" 364632 | collection element | 364633 collection := self collectionWithSameAtEndAndBegining. 364634 element := collection last. 364635 364636 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 364637 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" 364638 self assert: (collection 364639 lastIndexOf: element 364640 startingAt: collection size 364641 ifAbsent: [ 55 ]) = collection size. 364642 self assert: (collection 364643 lastIndexOf: element 364644 startingAt: collection size - 1 364645 ifAbsent: [ 55 ]) = 1! ! 364646 364647 364648!StringTest methodsFor: 'tests - indexof' stamp: 'on 5/13/2008 16:34'! 364649findFirstInString: aString fromString: searchString 364650 364651 ^ String findFirstInString: aString inSet: (CharacterSet newFrom: searchString) byteArrayMap startingAt: 1! ! 364652 364653!StringTest methodsFor: 'tests - indexof' stamp: 'on 5/14/2008 13:27'! 364654testFindFirstInString 364655 364656 "These tests are more specific than thsoe in testIndexOf." 364657 364658 "more boundary tests" 364659 self assert: (self findFirstInString: '' fromString: '') = 0. 364660 self assert: (self findFirstInString: 'x' fromString: '') = 0. 364661 self assert: (self findFirstInString: '' fromString: 'x') = 0. 364662 364663 self assert: (self findFirstInString: 'x' fromString: 'x') = 1. "<- FIXED" 364664 364665 self assert: (self findFirstInString: 'hello' fromString: 'hello') = 1. 364666 self assert: (self findFirstInString: 'hello' fromString: 'ello') = 2. 364667 self assert: (self findFirstInString: 'hello' fromString: 'llo') = 3. 364668 self assert: (self findFirstInString: 'hello' fromString: 'o') = 5. "<- FIXED" 364669 self assert: (self findFirstInString: 'hello' fromString: 'x') = 0. 364670! ! 364671 364672!StringTest methodsFor: 'tests - indexof' stamp: 'nice 3/15/2007 21:11'! 364673testIndexOf 364674 364675 "test for http://bugs.impara.de/view.php?id=3574" 364676 self assert: ('abc-' asWideString indexOfAnyOf: (CharacterSet newFrom: ' -0123456789')) = 4. 364677 self assert: ('ab7' asWideString indexOfAnyOf: (CharacterSet newFrom: ' -0123456789')) = 3. 364678 self assert: ('a2c' asWideString indexOfAnyOf: (CharacterSet newFrom: ' -0123456789')) = 2. 364679 self assert: ('3bc' asWideString indexOfAnyOf: (CharacterSet newFrom: ' -0123456789')) = 1. 364680 self assert: ('abc' asWideString indexOfAnyOf: (CharacterSet newFrom: ' -0123456789')) = 0. 364681 364682 "extension to wide characters" 364683 self assert: ((String with: 803 asCharacter with: 811 asCharacter) indexOfAnyOf: (CharacterSet newFrom: (String with: 811 asCharacter with: 812 asCharacter))) = 2. 364684 364685 self assert: ('abc' indexOfAnyOf: (CharacterSet newFrom: (String with: 811 asCharacter with: 812 asCharacter))) = 0. 364686 364687 self assert: ('abc' indexOfAnyOf: (CharacterSet newFrom: (String with: 811 asCharacter with: $c))) = 3. 364688 364689 "make sure start index is used in wide string algorithm" 364690 self assert: ('ab bcd abc' copyWith: 811 asCharacter) substrings = {'ab'. 'bcd'. 'abc' copyWith: 811 asCharacter}.! ! 364691 364692 364693!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364694testAllButFirstDo 364695 364696 | result | 364697 result:= OrderedCollection new. 364698 364699 self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 364700 364701 1 to: (result size) do: 364702 [:i| 364703 self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. 364704 364705 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 364706 364707!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364708testAllButLastDo 364709 364710 | result | 364711 result:= OrderedCollection new. 364712 364713 self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 364714 364715 1 to: (result size) do: 364716 [:i| 364717 self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. 364718 364719 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 364720 364721!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364722testCollectFromTo 364723 364724 | result | 364725 result:=self nonEmptyMoreThan1Element 364726 collect: [ :each | each ] 364727 from: 1 364728 to: (self nonEmptyMoreThan1Element size - 1). 364729 364730 1 to: result size 364731 do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. 364732 self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! 364733 364734!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364735testDetectSequenced 364736" testing that detect keep the first element returning true for sequenceable collections " 364737 364738 | element result | 364739 element := self nonEmptyMoreThan1Element at:1. 364740 result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. 364741 self assert: result = element. ! ! 364742 364743!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364744testDo! ! 364745 364746!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364747testFindFirst 364748 364749 | element result | 364750 element := self nonEmptyMoreThan1Element at:1. 364751 result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. 364752 364753 self assert: result=1. ! ! 364754 364755!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364756testFindFirstNotIn 364757 364758 | result | 364759 364760 result:=self empty findFirst: [:each | true]. 364761 364762 self assert: result=0. ! ! 364763 364764!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364765testFindLast 364766 364767 | element result | 364768 element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. 364769 result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. 364770 364771 self assert: result=self nonEmptyMoreThan1Element size. ! ! 364772 364773!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364774testFindLastNotIn 364775 364776 | result | 364777 364778 result:=self empty findFirst: [:each | true]. 364779 364780 self assert: result=0. ! ! 364781 364782!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364783testFromToDo 364784 364785 | result | 364786 result:= OrderedCollection new. 364787 364788 self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 364789 364790 1 to: (self nonEmptyMoreThan1Element size -1) do: 364791 [:i| 364792 self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. 364793 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 364794 364795!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364796testKeysAndValuesDo 364797 "| result | 364798 result:= OrderedCollection new. 364799 364800 self nonEmptyMoreThan1Element keysAndValuesDo: 364801 [:i :value| 364802 result add: (value+i)]. 364803 364804 1 to: result size do: 364805 [:i| 364806 self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" 364807 | indexes elements | 364808 indexes:= OrderedCollection new. 364809 elements := OrderedCollection new. 364810 364811 self nonEmptyMoreThan1Element keysAndValuesDo: 364812 [:i :value| 364813 indexes add: (i). 364814 elements add: value]. 364815 364816 (1 to: self nonEmptyMoreThan1Element size )do: 364817 [ :i | 364818 self assert: (indexes at: i) = i. 364819 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 364820 ]. 364821 364822 self assert: indexes size = elements size. 364823 self assert: indexes size = self nonEmptyMoreThan1Element size . 364824 364825 ! ! 364826 364827!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364828testKeysAndValuesDoEmpty 364829 | result | 364830 result:= OrderedCollection new. 364831 364832 self empty keysAndValuesDo: 364833 [:i :value| 364834 result add: (value+i)]. 364835 364836 self assert: result isEmpty .! ! 364837 364838!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364839testPairsCollect 364840 364841 | index result | 364842 index:=0. 364843 364844 result:=self nonEmptyMoreThan1Element pairsCollect: 364845 [:each1 :each2 | 364846 self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). 364847 (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). 364848 ]. 364849 364850 result do: 364851 [:each | self assert: each = true]. 364852 364853! ! 364854 364855!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364856testPairsDo 364857 | index | 364858 index:=1. 364859 364860 self nonEmptyMoreThan1Element pairsDo: 364861 [:each1 :each2 | 364862 self assert:(self nonEmptyMoreThan1Element at:index)=each1. 364863 self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. 364864 index:=index+2]. 364865 364866 self nonEmptyMoreThan1Element size odd 364867 ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] 364868 ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! 364869 364870!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364871testReverseDo 364872 | result | 364873 result:= OrderedCollection new. 364874 self nonEmpty reverseDo: [: each | result add: each]. 364875 364876 1 to: result size do: 364877 [:i| 364878 self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! 364879 364880!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364881testReverseDoEmpty 364882 | result | 364883 result:= OrderedCollection new. 364884 self empty reverseDo: [: each | result add: each]. 364885 364886 self assert: result isEmpty .! ! 364887 364888!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364889testReverseWithDo 364890 364891 | secondCollection result index | 364892 result:= OrderedCollection new. 364893 index := self nonEmptyMoreThan1Element size + 1. 364894 secondCollection:= self nonEmptyMoreThan1Element copy. 364895 364896 self nonEmptyMoreThan1Element reverseWith: secondCollection do: 364897 [:a :b | 364898 self assert: (self nonEmptyMoreThan1Element indexOf: a ) = (index := index - 1 ). 364899 result add: (a = b)]. 364900 364901 1 to: result size do: 364902 [:i| 364903 self assert: (result at:i)=(true)]. 364904 self assert: result size = self nonEmptyMoreThan1Element size.! ! 364905 364906!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364907testWithCollect 364908 364909 | result newCollection index collection | 364910 364911 index := 0. 364912 collection := self nonEmptyMoreThan1Element . 364913 newCollection := collection copy. 364914 result:=collection with: newCollection collect: [:a :b | 364915 self assert: (collection indexOf: a ) = ( index := index + 1). 364916 self assert: (a = b). 364917 b]. 364918 364919 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 364920 self assert: result size = collection size.! ! 364921 364922!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364923testWithCollectError 364924 self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! 364925 364926!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364927testWithDo 364928 364929 | secondCollection result index | 364930 result:= OrderedCollection new. 364931 secondCollection:= self nonEmptyMoreThan1Element copy. 364932 index := 0. 364933 364934 self nonEmptyMoreThan1Element with: secondCollection do: 364935 [:a :b | 364936 self assert: (self nonEmptyMoreThan1Element indexOf: a) = ( index := index + 1). 364937 result add: (a =b)]. 364938 364939 1 to: result size do: 364940 [:i| 364941 self assert: (result at:i)=(true)]. 364942 self assert: result size = self nonEmptyMoreThan1Element size.! ! 364943 364944!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364945testWithDoError 364946 364947 self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! 364948 364949!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364950testWithIndexCollect 364951 364952 | result index collection | 364953 index := 0. 364954 collection := self nonEmptyMoreThan1Element . 364955 result := collection withIndexCollect: [:each :i | 364956 self assert: i = (index := index + 1). 364957 self assert: i = (collection indexOf: each) . 364958 each] . 364959 364960 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 364961 self assert: result size = collection size.! ! 364962 364963!StringTest methodsFor: 'tests - iterate on sequenced reable collections'! 364964testWithIndexDo 364965 364966 "| result | 364967 result:=Array new: self nonEmptyMoreThan1Element size. 364968 self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 364969 364970 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" 364971 | indexes elements | 364972 indexes:= OrderedCollection new. 364973 elements := OrderedCollection new. 364974 364975 self nonEmptyMoreThan1Element withIndexDo: 364976 [:value :i | 364977 indexes add: (i). 364978 elements add: value]. 364979 364980 (1 to: self nonEmptyMoreThan1Element size )do: 364981 [ :i | 364982 self assert: (indexes at: i) = i. 364983 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 364984 ]. 364985 364986 self assert: indexes size = elements size. 364987 self assert: indexes size = self nonEmptyMoreThan1Element size . 364988 ! ! 364989 364990 364991!StringTest methodsFor: 'tests - occurrencesOf'! 364992testOccurrencesOf 364993 | collection | 364994 collection := self collectionWithoutEqualElements . 364995 364996 collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! 364997 364998!StringTest methodsFor: 'tests - occurrencesOf'! 364999testOccurrencesOfEmpty 365000 | result | 365001 result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). 365002 self assert: result = 0! ! 365003 365004!StringTest methodsFor: 'tests - occurrencesOf'! 365005testOccurrencesOfNotIn 365006 | result | 365007 result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. 365008 self assert: result = 0! ! 365009 365010 365011!StringTest methodsFor: 'tests - occurrencesOf for multipliness'! 365012testOccurrencesOfForMultipliness 365013 365014| collection element | 365015collection := self collectionWithEqualElements . 365016element := self elementTwiceInForOccurrences . 365017 365018self assert: (collection occurrencesOf: element ) = 2. ! ! 365019 365020 365021!StringTest methodsFor: 'tests - printing'! 365022testPrintElementsOn 365023 365024 | aStream result allElementsAsString | 365025 result:=''. 365026 aStream:= ReadWriteStream on: result. 365027 365028 self nonEmpty printElementsOn: aStream . 365029 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 365030 1 to: allElementsAsString size do: 365031 [:i | 365032 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 365033 ].! ! 365034 365035!StringTest methodsFor: 'tests - printing'! 365036testPrintNameOn 365037 365038 | aStream result | 365039 result:=''. 365040 aStream:= ReadWriteStream on: result. 365041 365042 self nonEmpty printNameOn: aStream . 365043 Transcript show: result asString. 365044 self nonEmpty class name first isVowel 365045 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 365046 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 365047 365048!StringTest methodsFor: 'tests - printing'! 365049testPrintOn 365050 | aStream result allElementsAsString | 365051 result:=''. 365052 aStream:= ReadWriteStream on: result. 365053 365054 self nonEmpty printOn: aStream . 365055 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 365056 1 to: allElementsAsString size do: 365057 [:i | 365058 i=1 365059 ifTrue:[ 365060 self accessCollection class name first isVowel 365061 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 365062 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 365063 i=2 365064 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 365065 i>2 365066 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. 365067 ].! ! 365068 365069!StringTest methodsFor: 'tests - printing'! 365070testPrintOnDelimiter 365071 | aStream result allElementsAsString | 365072 result:=''. 365073 aStream:= ReadWriteStream on: result. 365074 365075 self nonEmpty printOn: aStream delimiter: ', ' . 365076 365077 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 365078 1 to: allElementsAsString size do: 365079 [:i | 365080 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 365081 ].! ! 365082 365083!StringTest methodsFor: 'tests - printing'! 365084testPrintOnDelimiterLast 365085 365086 | aStream result allElementsAsString | 365087 result:=''. 365088 aStream:= ReadWriteStream on: result. 365089 365090 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 365091 365092 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 365093 1 to: allElementsAsString size do: 365094 [:i | 365095 i<(allElementsAsString size-1 ) 365096 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 365097 i=(allElementsAsString size-1) 365098 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 365099 i=(allElementsAsString size) 365100 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 365101 ].! ! 365102 365103!StringTest methodsFor: 'tests - printing'! 365104testStoreOn 365105" for the moment work only for collection that include simple elements such that Integer" 365106 365107"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 365108string := ''. 365109str := ReadWriteStream on: string. 365110elementsAsStringExpected := OrderedCollection new. 365111elementsAsStringObtained := OrderedCollection new. 365112self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 365113 365114self nonEmpty storeOn: str. 365115result := str contents . 365116cuttedResult := ( result findBetweenSubStrs: ';' ). 365117 365118index := 1. 365119 365120cuttedResult do: 365121 [ :each | 365122 index = 1 365123 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 365124 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 365125 elementsAsStringObtained add: tmp. 365126 index := index + 1. ] 365127 ifFalse: [ 365128 index < cuttedResult size 365129 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 365130 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 365131 elementsAsStringObtained add: tmp. 365132 index := index + 1.] 365133 ifFalse: [self assert: ( each = ' yourself)' ) ]. 365134 ] 365135 365136 ]. 365137 365138 365139 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 365140 365141! ! 365142 365143 365144!StringTest methodsFor: 'tests - puting with indexes'! 365145testAtAllIndexesPut 365146 365147 self nonEmpty atAllPut: self aValue. 365148 self nonEmpty do:[ :each| self assert: each = self aValue]. 365149 ! ! 365150 365151!StringTest methodsFor: 'tests - puting with indexes'! 365152testAtAllPut 365153 | | 365154 self nonEmpty atAll: self indexArray put: self aValue.. 365155 365156 self indexArray do: 365157 [:i | self assert: (self nonEmpty at: i)=self aValue ]. 365158 ! ! 365159 365160!StringTest methodsFor: 'tests - puting with indexes'! 365161testAtAllPutAll 365162 365163 | valueArray | 365164 valueArray := self valueArray . 365165 self nonEmpty atAll: self indexArray putAll: valueArray . 365166 365167 1 to: self indexArray size do: 365168 [:i | 365169 self assert: (self nonEmpty at:(self indexArray at: i))= (valueArray at:i) ]! ! 365170 365171!StringTest methodsFor: 'tests - puting with indexes'! 365172testAtLastPut 365173 | result index | 365174 index := self indexArray anyOne. 365175 result := self nonEmpty atLast: index put: self aValue. 365176 365177 self assert: (self nonEmpty at: (self nonEmpty size +1 - index)) = self aValue .! ! 365178 365179!StringTest methodsFor: 'tests - puting with indexes'! 365180testAtWrapPut 365181 "self debug: #testAtWrapPut" 365182 | index | 365183 index := self indexArray anyOne. 365184 365185 self nonEmpty atWrap: 0 put: self aValue. 365186 self assert: (self nonEmpty at:(self nonEmpty size))=self aValue. 365187 365188 self nonEmpty atWrap: (self nonEmpty size+1) put: self aValue. 365189 self assert: (self nonEmpty at:(1))=self aValue. 365190 365191 self nonEmpty atWrap: (index ) put: self aValue. 365192 self assert: (self nonEmpty at: index ) = self aValue. 365193 365194 self nonEmpty atWrap: (self nonEmpty size+index ) put: self aValue . 365195 self assert: (self nonEmpty at:(index ))=self aValue .! ! 365196 365197!StringTest methodsFor: 'tests - puting with indexes'! 365198testFromToPut 365199 365200 | collection index | 365201 index := self indexArray anyOne. 365202 collection := self nonEmpty copy. 365203 collection from: 1 to: index put: self aValue.. 365204 1 to: index do: 365205 [:i | self assert: (collection at: i)= self aValue]. 365206 (index +1) to: collection size do: 365207 [:i | self assert: (collection at:i)= (self nonEmpty at:i)].! ! 365208 365209!StringTest methodsFor: 'tests - puting with indexes'! 365210testSwapWith 365211 "self debug: #testSwapWith" 365212 | result index | 365213 index := self indexArray anyOne. 365214 result:= self nonEmpty copy . 365215 result swap: index with: 1. 365216 self assert: (result at: index) = (self nonEmpty at:1). 365217 self assert: (result at: 1) = (self nonEmpty at: index). 365218 ! ! 365219 365220 365221!StringTest methodsFor: 'tests - replacing'! 365222testReplaceAllWith 365223 | result collection oldElement newElement | 365224 collection := self nonEmpty . 365225 result := collection copy. 365226 oldElement := self elementInForReplacement . 365227 newElement := self newElement . 365228 result replaceAll: oldElement with: newElement . 365229 365230 1 to: collection size do: 365231 [: 365232 each | 365233 ( collection at: each ) = oldElement 365234 ifTrue: [ self assert: ( result at: each ) = newElement ]. 365235 ].! ! 365236 365237!StringTest methodsFor: 'tests - replacing'! 365238testReplaceFromToWith 365239 | result collection replacementCollection firstIndex secondIndex | 365240 collection := self nonEmpty . 365241 replacementCollection := self replacementCollectionSameSize . 365242 firstIndex := self firstIndex . 365243 secondIndex := self secondIndex . 365244 result := collection copy. 365245 result replaceFrom: firstIndex to: secondIndex with: replacementCollection . 365246 365247 "verify content of 'result' : " 365248 "first part of 'result'' : '" 365249 365250 1 to: ( firstIndex - 1 ) do: [ :i | self assert: (collection at:i ) = ( result at: i ) ]. 365251 365252 " middle part containing replacementCollection : " 365253 365254 ( firstIndex ) to: ( firstIndex + replacementCollection size - 1 ) do: 365255 [ :i | 365256 self assert: ( result at: i ) = ( replacementCollection at: ( i - firstIndex +1 ) ) 365257 ]. 365258 365259 " end part :" 365260 ( firstIndex + replacementCollection size) to: (result size) do: 365261 [:i| 365262 self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ]. 365263 365264 ! ! 365265 365266!StringTest methodsFor: 'tests - replacing'! 365267testReplaceFromToWithStartingAt 365268 | result repStart collection replacementCollection firstIndex secondIndex | 365269 collection := self nonEmpty . 365270 result := collection copy. 365271 replacementCollection := self replacementCollectionSameSize . 365272 firstIndex := self firstIndex . 365273 secondIndex := self secondIndex . 365274 repStart := replacementCollection size - ( secondIndex - firstIndex + 1 ) + 1. 365275 result replaceFrom: firstIndex to: secondIndex with: replacementCollection startingAt: repStart . 365276 365277 "verify content of 'result' : " 365278 "first part of 'result'' : '" 365279 365280 1 to: ( firstIndex - 1 ) do: [ :i | self assert: ( collection at:i ) = ( result at: i ) ]. 365281 365282 " middle part containing replacementCollection : " 365283 365284 ( firstIndex ) to: ( replacementCollection size - repStart +1 ) do: 365285 [:i| 365286 self assert: (result at: i)=( replacementCollection at: ( repStart + ( i -firstIndex ) ) ) ]. 365287 365288 " end part :" 365289 ( firstIndex + replacementCollection size ) to: ( result size ) do: 365290 [ :i | 365291 self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ].! ! 365292 365293 365294!StringTest methodsFor: 'tests - set arithmetic'! 365295containsAll: union of: one andOf: another 365296 365297 self assert: (one allSatisfy: [:each | union includes: each]). 365298 self assert: (another allSatisfy: [:each | union includes: each])! ! 365299 365300!StringTest methodsFor: 'tests - set arithmetic'! 365301numberOfSimilarElementsInIntersection 365302 ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! 365303 365304!StringTest methodsFor: 'tests - set arithmetic'! 365305testDifference 365306 "Answer the set theoretic difference of two collections." 365307 "self debug: #testDifference" 365308 365309 self assert: (self collection difference: self collection) isEmpty. 365310 self assert: (self empty difference: self collection) isEmpty. 365311 self assert: (self collection difference: self empty) = self collection 365312! ! 365313 365314!StringTest methodsFor: 'tests - set arithmetic'! 365315testDifferenceWithNonNullIntersection 365316 "Answer the set theoretic difference of two collections." 365317 "self debug: #testDifferenceWithNonNullIntersection" 365318 " #(1 2 3) difference: #(2 4) 365319 -> #(1 3)" 365320 | res overlapping | 365321 overlapping := self collectionClass 365322 with: self anotherElementOrAssociationNotIn 365323 with: self anotherElementOrAssociationIn. 365324 res := self collection difference: overlapping. 365325 self deny: (res includes: self anotherElementOrAssociationIn). 365326 overlapping do: [ :each | self deny: (res includes: each) ]! ! 365327 365328!StringTest methodsFor: 'tests - set arithmetic'! 365329testDifferenceWithSeparateCollection 365330 "Answer the set theoretic difference of two collections." 365331 "self debug: #testDifferenceWithSeparateCollection" 365332 | res separateCol | 365333 separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. 365334 res := self collection difference: separateCol. 365335 self deny: (res includes: self anotherElementOrAssociationNotIn). 365336 self assert: res = self collection. 365337 res := separateCol difference: self collection. 365338 self deny: (res includes: self collection anyOne). 365339 self assert: res = separateCol! ! 365340 365341!StringTest methodsFor: 'tests - set arithmetic'! 365342testIntersectionBasic 365343 "self debug: #testIntersectionBasic" 365344 | inter | 365345 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 365346 self deny: inter isEmpty. 365347 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 365348 365349!StringTest methodsFor: 'tests - set arithmetic'! 365350testIntersectionEmpty 365351 "self debug: #testIntersectionEmpty" 365352 365353 | inter | 365354 inter := self empty intersection: self empty. 365355 self assert: inter isEmpty. 365356 inter := self empty intersection: self collection . 365357 self assert: inter = self empty. 365358 ! ! 365359 365360!StringTest methodsFor: 'tests - set arithmetic'! 365361testIntersectionItself 365362 "self debug: #testIntersectionItself" 365363 365364 self assert: (self collection intersection: self collection) = self collection. 365365 ! ! 365366 365367!StringTest methodsFor: 'tests - set arithmetic'! 365368testIntersectionTwoSimilarElementsInIntersection 365369 "self debug: #testIntersectionBasic" 365370 | inter | 365371 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 365372 self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. 365373 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 365374 365375!StringTest methodsFor: 'tests - set arithmetic'! 365376testUnion 365377 "self debug: #testUnionOfEmpties" 365378 365379 | union | 365380 union := self empty union: self nonEmpty. 365381 self containsAll: union of: self empty andOf: self nonEmpty. 365382 union := self nonEmpty union: self empty. 365383 self containsAll: union of: self empty andOf: self nonEmpty. 365384 union := self collection union: self nonEmpty. 365385 self containsAll: union of: self collection andOf: self nonEmpty.! ! 365386 365387!StringTest methodsFor: 'tests - set arithmetic'! 365388testUnionOfEmpties 365389 "self debug: #testUnionOfEmpties" 365390 365391 self assert: (self empty union: self empty) isEmpty. 365392 365393 ! ! 365394 365395 365396!StringTest methodsFor: 'tests - sorting'! 365397testIsSorted 365398 self assert: [ self sortedInAscendingOrderCollection isSorted ]. 365399 self deny: [ self unsortedCollection isSorted ]! ! 365400 365401!StringTest methodsFor: 'tests - sorting'! 365402testIsSortedBy 365403 self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a<b]). 365404 self deny: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a>b]). 365405! ! 365406 365407!StringTest methodsFor: 'tests - sorting'! 365408testSort 365409 | result tmp | 365410 result := self unsortedCollection sort. 365411 tmp := result at: 1. 365412 result do: 365413 [:each | self assert: each>=tmp. tmp:= each. ].! ! 365414 365415!StringTest methodsFor: 'tests - sorting'! 365416testSortUsingSortBlock 365417 | result tmp | 365418 result := self unsortedCollection sort: [:a :b | a>b]. 365419 tmp := result at: 1. 365420 result do: 365421 [:each | self assert: each<=tmp. tmp:= each. ].! ! 365422 365423 365424!StringTest methodsFor: 'tests - subcollections access'! 365425testAllButFirst 365426 "self debug: #testAllButFirst" 365427 | abf col | 365428 col := self moreThan3Elements. 365429 abf := col allButFirst. 365430 self deny: abf first = col first. 365431 self assert: abf size + 1 = col size! ! 365432 365433!StringTest methodsFor: 'tests - subcollections access'! 365434testAllButFirstNElements 365435 "self debug: #testAllButFirst" 365436 | abf col | 365437 col := self moreThan3Elements. 365438 abf := col allButFirst: 2. 365439 1 365440 to: abf size 365441 do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. 365442 self assert: abf size + 2 = col size! ! 365443 365444!StringTest methodsFor: 'tests - subcollections access'! 365445testAllButLast 365446 "self debug: #testAllButLast" 365447 | abf col | 365448 col := self moreThan3Elements. 365449 abf := col allButLast. 365450 self deny: abf last = col last. 365451 self assert: abf size + 1 = col size! ! 365452 365453!StringTest methodsFor: 'tests - subcollections access'! 365454testAllButLastNElements 365455 "self debug: #testAllButFirst" 365456 | abf col | 365457 col := self moreThan3Elements. 365458 abf := col allButLast: 2. 365459 1 365460 to: abf size 365461 do: [ :i | self assert: (abf at: i) = (col at: i) ]. 365462 self assert: abf size + 2 = col size! ! 365463 365464!StringTest methodsFor: 'tests - subcollections access'! 365465testFirstNElements 365466 "self debug: #testFirstNElements" 365467 | result | 365468 result := self moreThan3Elements first: self moreThan3Elements size - 1. 365469 1 365470 to: result size 365471 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. 365472 self assert: result size = (self moreThan3Elements size - 1). 365473 self 365474 should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] 365475 raise: Error! ! 365476 365477!StringTest methodsFor: 'tests - subcollections access'! 365478testLastNElements 365479 "self debug: #testLastNElements" 365480 | result | 365481 result := self moreThan3Elements last: self moreThan3Elements size - 1. 365482 1 365483 to: result size 365484 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. 365485 self assert: result size = (self moreThan3Elements size - 1). 365486 self 365487 should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] 365488 raise: Error! ! 365489 365490"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 365491 365492StringTest class 365493 uses: TIncludesTest classTrait + TCloneTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TIterateSequencedReadableTest classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TIndexAccess classTrait + TSequencedElementAccessTest classTrait + TSubCollectionAccess classTrait + TPutBasicTest classTrait + TCopySequenceableSameContents classTrait + TCopyPartOfSequenceable classTrait + TCopyPartOfSequenceableForMultipliness classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopySequenceableWithReplacement classTrait + TReplacementSequencedTest classTrait + TConvertTest classTrait + TConvertAsSortedTest classTrait + TBeginsEndsWith classTrait + TIndexAccessForMultipliness classTrait + TSequencedConcatenationTest classTrait + TPrintOnSequencedTest classTrait + TPutTest classTrait + TConvertAsSetForMultiplinessTest classTrait + TSortTest classTrait + TSequencedStructuralEqualityTest classTrait + TOccurrencesForMultiplinessTest classTrait + TCreationWithTest classTrait 365494 instanceVariableNames: ''! 365495RWBinaryOrTextStream subclass: #SwikiPseudoFileStream 365496 instanceVariableNames: 'directoryUrl localName directory' 365497 classVariableNames: '' 365498 poolDictionaries: '' 365499 category: 'Network-RemoteDirectory'! 365500 365501!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 14:53'! 365502directory 365503 365504 ^directory url! ! 365505 365506!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 14:53'! 365507directory: x 365508 365509 directory := x! ! 365510 365511!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 15:00'! 365512directoryObject 365513 365514 ^directory! ! 365515 365516!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 15:00'! 365517directoryUrl 365518 365519 ^directory url! ! 365520 365521!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/13/2000 11:50'! 365522directoryUrl: x 365523 365524 directoryUrl := x! ! 365525 365526!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 13:59'! 365527fileName 365528 365529 ^localName! ! 365530 365531!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 14:01'! 365532isTypeHTTP 365533 365534 ^true! ! 365535 365536!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/13/2000 11:50'! 365537localName 365538 365539 ^localName! ! 365540 365541!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/13/2000 11:50'! 365542localName: x 365543 365544 localName := x! ! 365545String subclass: #Symbol 365546 instanceVariableNames: '' 365547 classVariableNames: 'NewSymbols OneCharacterSymbols SymbolTable' 365548 poolDictionaries: '' 365549 category: 'Collections-Strings'! 365550!Symbol commentStamp: '<historical>' prior: 0! 365551I represent Strings that are created uniquely. Thus, someString asSymbol == someString asSymbol.! 365552 365553 365554!Symbol methodsFor: 'accessing'! 365555at: anInteger put: anObject 365556 "You cannot modify the receiver." 365557 365558 self errorNoModification! ! 365559 365560!Symbol methodsFor: 'accessing' stamp: 'sma 2/5/2000 12:32'! 365561precedence 365562 "Answer the receiver's precedence, assuming it is a valid Smalltalk 365563 message selector or 0 otherwise. The numbers are 1 for unary, 365564 2 for binary and 3 for keyword selectors." 365565 365566 self size = 0 ifTrue: [^ 0]. 365567 self first isLetter ifFalse: [^ 2]. 365568 self last = $: ifTrue: [^ 3]. 365569 ^ 1! ! 365570 365571!Symbol methodsFor: 'accessing'! 365572replaceFrom: start to: stop with: replacement startingAt: repStart 365573 365574 self errorNoModification! ! 365575 365576 365577!Symbol methodsFor: 'comparing' stamp: 'ar 4/10/2005 23:45'! 365578= aSymbol 365579 "Compare the receiver and aSymbol." 365580 self == aSymbol ifTrue: [^ true]. 365581 self class == aSymbol class ifTrue: [^ false]. 365582 "Use String comparison otherwise" 365583 ^ super = aSymbol! ! 365584 365585 365586!Symbol methodsFor: 'converting' stamp: 'st 11/22/2004 17:26'! 365587asMutator 365588 "Return a setter message from a getter message. For example, 365589 #name asMutator returns #name:" 365590 ^ (self copyWith: $:) asSymbol! ! 365591 365592!Symbol methodsFor: 'converting' stamp: 'ar 4/10/2005 22:42'! 365593asString 365594 "Refer to the comment in String|asString." 365595 | newString | 365596 newString := self species new: self size. 365597 newString replaceFrom: 1 to: newString size with: self startingAt: 1. 365598 ^newString! ! 365599 365600!Symbol methodsFor: 'converting'! 365601asSymbol 365602 "Refer to the comment in String|asSymbol."! ! 365603 365604!Symbol methodsFor: 'converting' stamp: 'sw 1/28/98 18:18'! 365605capitalized 365606 ^ self asString capitalized asSymbol! ! 365607 365608!Symbol methodsFor: 'converting' stamp: 'md 8/10/2004 10:54'! 365609withFirstCharacterDownshifted 365610 "Answer an object like the receiver but with first character downshifted if necesary" 365611 365612 ^self asString withFirstCharacterDownshifted asSymbol.! ! 365613 365614 365615!Symbol methodsFor: 'copying' stamp: 'tk 6/26/1998 11:35'! 365616clone 365617 "Answer with the receiver, because Symbols are unique."! ! 365618 365619!Symbol methodsFor: 'copying'! 365620copy 365621 "Answer with the receiver, because Symbols are unique."! ! 365622 365623!Symbol methodsFor: 'copying'! 365624shallowCopy 365625 "Answer with the receiver, because Symbols are unique."! ! 365626 365627!Symbol methodsFor: 'copying' stamp: 'tk 8/19/1998 16:05'! 365628veryDeepCopyWith: deepCopier 365629 "Return self. I am immutable in the Morphic world. Do not record me."! ! 365630 365631 365632!Symbol methodsFor: 'evaluating' stamp: 'md 3/24/2006 12:09'! 365633value: anObject 365634 ^anObject perform: self.! ! 365635 365636 365637!Symbol methodsFor: 'filter streaming' stamp: 'mpw 1/1/1901 00:20'! 365638byteEncode:aStream 365639 ^aStream writeSymbol:self. 365640! ! 365641 365642 365643!Symbol methodsFor: 'printing' stamp: 'sw 8/19/1999 11:30'! 365644isOrientedFill 365645 "Needs to be implemented here because symbols can occupy 'color' slots of morphs." 365646 365647 ^ false! ! 365648 365649!Symbol methodsFor: 'printing' stamp: 'di 4/25/2000 12:32'! 365650storeOn: aStream 365651 365652 aStream nextPut: $#. 365653 (Scanner isLiteralSymbol: self) 365654 ifTrue: [aStream nextPutAll: self] 365655 ifFalse: [super storeOn: aStream]! ! 365656 365657 365658!Symbol methodsFor: 'system primitives' stamp: 'di 1/2/1999 17:00'! 365659flushCache 365660 "Tell the interpreter to remove all entries with this symbol as a selector from its method lookup cache, if it has one. This primitive must be called whenever a method is defined or removed. 365661 NOTE: Only one of the two selective flush methods needs to be used. 365662 Squeak 2.3 and later uses 116 (See CompiledMethod flushCache)." 365663 365664 <primitive: 119> 365665! ! 365666 365667!Symbol methodsFor: 'system primitives' stamp: 'PeterHugossonMiller 9/3/2009 11:30'! 365668numArgs: n 365669 "Answer a string that can be used as a selector with n arguments. 365670 TODO: need to be extended to support shrinking and for selectors like #+ " 365671 365672 | selector numArgs aStream offs | 365673 365674 selector := self. 365675 (numArgs := selector numArgs) >= n ifTrue: [^self]. 365676 aStream := (String new: 16) writeStream. 365677 aStream nextPutAll: self. 365678 365679 (numArgs = 0) ifTrue: [aStream nextPutAll: ':'. offs := 0] ifFalse: [offs := 1]. 365680 2 to: n - numArgs + offs do: [:i | aStream nextPutAll: 'with:']. 365681 ^aStream contents asSymbol 365682 365683! ! 365684 365685 365686!Symbol methodsFor: 'testing' stamp: 'md 1/20/2006 16:16'! 365687includesKey: sym 365688 ^self == sym.! ! 365689 365690!Symbol methodsFor: 'testing' stamp: 'md 8/27/2005 16:33'! 365691isDoIt 365692 365693 ^ (self == #DoIt) or: [self == #DoItIn:].! ! 365694 365695!Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:32'! 365696isInfix 365697 "Answer whether the receiver is an infix message selector." 365698 365699 ^ self precedence == 2! ! 365700 365701!Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:34'! 365702isKeyword 365703 "Answer whether the receiver is a message keyword." 365704 365705 ^ self precedence == 3! ! 365706 365707!Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:13'! 365708isPvtSelector 365709 "Answer whether the receiver is a private message selector, that is, 365710 begins with 'pvt' followed by an uppercase letter, e.g. pvtStringhash." 365711 365712 ^ (self beginsWith: 'pvt') and: [self size >= 4 and: [(self at: 4) isUppercase]]! ! 365713 365714!Symbol methodsFor: 'testing' stamp: 'md 4/30/2003 15:31'! 365715isSymbol 365716 ^ true ! ! 365717 365718!Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:34'! 365719isUnary 365720 "Answer whether the receiver is an unary message selector." 365721 365722 ^ self precedence == 1! ! 365723 365724 365725!Symbol methodsFor: 'private'! 365726errorNoModification 365727 365728 self error: 'symbols can not be modified.'! ! 365729 365730!Symbol methodsFor: 'private'! 365731string: aString 365732 365733 1 to: aString size do: [:j | super at: j put: (aString at: j)]. 365734 ^self ! ! 365735 365736"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 365737 365738Symbol class 365739 instanceVariableNames: ''! 365740 365741!Symbol class methodsFor: 'access' stamp: 'ar 4/10/2005 22:49'! 365742allSymbols 365743 "Answer all interned symbols" 365744 ^Array streamContents:[:s| 365745 s nextPutAll: NewSymbols. 365746 s nextPutAll: OneCharacterSymbols. 365747 s nextPutAll: SymbolTable. 365748 ]. 365749! ! 365750 365751!Symbol class methodsFor: 'access' stamp: 'nice 7/27/2007 23:15'! 365752selectorsContaining: aString 365753 "Answer a list of selectors that contain aString within them. Case-insensitive. Does return symbols that begin with a capital letter." 365754 365755 | size selectorList ascii | 365756 365757 selectorList := OrderedCollection new. 365758 (size := aString size) = 0 ifTrue: [^selectorList]. 365759 365760 aString size = 1 ifTrue: 365761 [ 365762 ascii := aString first asciiValue. 365763 ascii < 128 ifTrue: [selectorList add: (OneCharacterSymbols at: ascii+1)] 365764 ]. 365765 365766 aString first isLetter ifFalse: 365767 [ 365768 aString size == 2 ifTrue: 365769 [Symbol hasInterned: aString ifTrue: 365770 [:s | selectorList add: s]]. 365771 ^selectorList 365772 ]. 365773 365774 selectorList := selectorList copyFrom: 2 to: selectorList size. 365775 365776 self allSymbolTablesDo: [:each | 365777 each size >= size ifTrue: 365778 [(each findString: aString startingAt: 1 caseSensitive: false) > 0 365779 ifTrue: [selectorList add: each]]]. 365780 365781 ^selectorList reject: [:each | "reject non-selectors, but keep ones that begin with an uppercase" 365782 each numArgs < 0 and: [each asString withFirstCharacterDownshifted numArgs < 0]]. 365783 365784"Symbol selectorsContaining: 'scon'"! ! 365785 365786!Symbol class methodsFor: 'access' stamp: 'tween 9/13/2004 10:09'! 365787thatStartsCaseSensitive: leadingCharacters skipping: skipSym 365788 "Same as thatStarts:skipping: but caseSensitive" 365789 | size firstMatch key | 365790 365791 size := leadingCharacters size. 365792 size = 0 ifTrue: [^skipSym ifNil: [#''] ifNotNil: [nil]]. 365793 firstMatch := leadingCharacters at: 1. 365794 size > 1 ifTrue: [key := leadingCharacters copyFrom: 2 to: size]. 365795 self allSymbolTablesDo: [:each | 365796 each size >= size ifTrue: 365797 [ 365798 ((each at: 1) == firstMatch and: 365799 [key == nil or: 365800 [(each findString: key startingAt: 2 caseSensitive: true) = 2]]) 365801 ifTrue: [^each] 365802 ] 365803 ] after: skipSym. 365804 365805 ^nil 365806! ! 365807 365808!Symbol class methodsFor: 'access' stamp: 'RAA 5/29/2001 14:35'! 365809thatStarts: leadingCharacters skipping: skipSym 365810 "Answer a selector symbol that starts with leadingCharacters. 365811 Symbols beginning with a lower-case letter handled directly here. 365812 Ignore case after first char. 365813 If skipSym is not nil, it is a previous answer; start searching after it. 365814 If no symbols are found, answer nil. 365815 Used by Alt-q (Command-q) routines" 365816 365817 | size firstMatch key | 365818 365819 size := leadingCharacters size. 365820 size = 0 ifTrue: [^skipSym ifNil: [#''] ifNotNil: [nil]]. 365821 365822 firstMatch := leadingCharacters at: 1. 365823 size > 1 ifTrue: [key := leadingCharacters copyFrom: 2 to: size]. 365824 365825 self allSymbolTablesDo: [:each | 365826 each size >= size ifTrue: 365827 [ 365828 ((each at: 1) == firstMatch and: 365829 [key == nil or: 365830 [(each findString: key startingAt: 2 caseSensitive: false) = 2]]) 365831 ifTrue: [^each] 365832 ] 365833 ] after: skipSym. 365834 365835 ^nil 365836 365837"Symbol thatStarts: 'sf' skipping: nil" 365838"Symbol thatStarts: 'sf' skipping: #sfpGetFile:with:with:with:with:with:with:with:with:" 365839"Symbol thatStarts: 'candidate' skipping: nil" 365840! ! 365841 365842 365843!Symbol class methodsFor: 'initialization' stamp: 'RAA 5/29/2001 08:21'! 365844allSymbolTablesDo: aBlock 365845 365846 NewSymbols do: aBlock. 365847 SymbolTable do: aBlock.! ! 365848 365849!Symbol class methodsFor: 'initialization' stamp: 'RAA 5/29/2001 14:35'! 365850allSymbolTablesDo: aBlock after: aSymbol 365851 365852 NewSymbols do: aBlock after: aSymbol. 365853 SymbolTable do: aBlock after: aSymbol.! ! 365854 365855!Symbol class methodsFor: 'initialization' stamp: 'RAA 12/17/2000 18:05'! 365856compactSymbolTable 365857 "Reduce the size of the symbol table so that it holds all existing symbols + 25% (changed from 1000 since sets like to have 25% free and the extra space would grow back in a hurry)" 365858 365859 | oldSize | 365860 365861 Smalltalk garbageCollect. 365862 oldSize := SymbolTable array size. 365863 SymbolTable growTo: SymbolTable size * 4 // 3 + 100. 365864 ^oldSize printString,' ',(oldSize - SymbolTable array size) printString, ' slot(s) reclaimed'! ! 365865 365866!Symbol class methodsFor: 'initialization' stamp: 'RAA 5/29/2001 09:04'! 365867initialize 365868 365869 "Symbol initialize" 365870 365871 Symbol rehash. 365872 OneCharacterSymbols := nil. 365873 OneCharacterSymbols := (1 to: 256) collect: [ :i | (i - 1) asCharacter asSymbol]. 365874 Smalltalk addToShutDownList: self. 365875! ! 365876 365877 365878!Symbol class methodsFor: 'instance creation'! 365879findInterned:aString 365880 365881 self hasInterned:aString ifTrue:[:symbol| ^symbol]. 365882 ^nil.! ! 365883 365884!Symbol class methodsFor: 'instance creation' stamp: 'ar 4/10/2005 23:04'! 365885internCharacter: aCharacter 365886 aCharacter asciiValue > 256 ifTrue:[^self intern: aCharacter asString]. 365887 OneCharacterSymbols ifNil: [^self intern: aCharacter asString]. 365888 ^OneCharacterSymbols at: aCharacter asciiValue + 1 365889! ! 365890 365891!Symbol class methodsFor: 'instance creation' stamp: 'ar 4/12/2005 17:37'! 365892intern: aStringOrSymbol 365893 365894 ^(self lookup: aStringOrSymbol) ifNil:[ 365895 | aClass aSymbol | 365896 aStringOrSymbol isSymbol ifTrue:[ 365897 aSymbol := aStringOrSymbol. 365898 ] ifFalse:[ 365899 aClass := aStringOrSymbol isOctetString ifTrue:[ByteSymbol] ifFalse:[WideSymbol]. 365900 aSymbol := aClass new: aStringOrSymbol size. 365901 aSymbol string: aStringOrSymbol. 365902 ]. 365903 NewSymbols add: aSymbol. 365904 aSymbol].! ! 365905 365906!Symbol class methodsFor: 'instance creation' stamp: 'RAA 5/29/2001 08:09'! 365907lookup: aStringOrSymbol 365908 365909 ^(SymbolTable like: aStringOrSymbol) ifNil: [ 365910 NewSymbols like: aStringOrSymbol 365911 ]! ! 365912 365913!Symbol class methodsFor: 'instance creation'! 365914newFrom: aCollection 365915 "Answer an instance of me containing the same elements as aCollection." 365916 365917 ^ (aCollection as: String) asSymbol 365918 365919" Symbol newFrom: {$P. $e. $n} 365920 {$P. $e. $n} as: Symbol 365921"! ! 365922 365923!Symbol class methodsFor: 'instance creation' stamp: 'di 10/11/1999 00:02'! 365924readFrom: strm "Symbol readFromString: '#abc'" 365925 365926 strm peek = $# ifFalse: [self error: 'Symbols must be introduced by #']. 365927 ^ (Scanner new scan: strm) advance "Just do what the code scanner does"! ! 365928 365929 365930!Symbol class methodsFor: 'private' stamp: 'ar 4/10/2005 22:43'! 365931hasInterned: aString ifTrue: symBlock 365932 "Answer with false if aString hasnt been interned (into a Symbol), 365933 otherwise supply the symbol to symBlock and return true." 365934 365935 | symbol | 365936 ^ (symbol := self lookup: aString) 365937 ifNil: [false] 365938 ifNotNil: [symBlock value: symbol. 365939 true]! ! 365940 365941!Symbol class methodsFor: 'private' stamp: 'RAA 5/29/2001 14:33'! 365942possibleSelectorsFor: misspelled 365943 "Answer an ordered collection of possible corrections 365944 for the misspelled selector in order of likelyhood" 365945 365946 | numArgs candidates lookupString best binary short long first ss | 365947 lookupString := misspelled asLowercase. "correct uppercase selectors to lowercase" 365948 numArgs := lookupString numArgs. 365949 (numArgs < 0 or: [lookupString size < 2]) ifTrue: [^ OrderedCollection new: 0]. 365950 first := lookupString first. 365951 short := lookupString size - (lookupString size // 4 max: 3) max: 2. 365952 long := lookupString size + (lookupString size // 4 max: 3). 365953 365954 "First assemble candidates for detailed scoring" 365955 candidates := OrderedCollection new. 365956 self allSymbolTablesDo: [:s | (((ss := s size) >= short "not too short" 365957 and: [ss <= long "not too long" 365958 or: [(s at: 1) = first]]) "well, any length OK if starts w/same letter" 365959 and: [s numArgs = numArgs]) "and numArgs is the same" 365960 ifTrue: [candidates add: s]]. 365961 365962 "Then further prune these by correctAgainst:" 365963 best := lookupString correctAgainst: candidates. 365964 ((misspelled last ~~ $:) and: [misspelled size > 1]) ifTrue: [ 365965 binary := misspelled, ':'. "try for missing colon" 365966 Symbol hasInterned: binary ifTrue: [:him | best addFirst: him]]. 365967 ^ best! ! 365968 365969!Symbol class methodsFor: 'private' stamp: 'ar 9/27/2005 20:01'! 365970rehash "Symbol rehash" 365971 "Rebuild the hash table, reclaiming unreferenced Symbols." 365972 365973 SymbolTable := WeakSet withAll: self allSubInstances. 365974 NewSymbols := WeakSet new.! ! 365975 365976!Symbol class methodsFor: 'private' stamp: 'RAA 5/29/2001 09:04'! 365977shutDown: aboutToQuit 365978 365979 SymbolTable addAll: NewSymbols. 365980 NewSymbols := WeakSet new.! ! 365981CollectionRootTest subclass: #SymbolTest 365982 uses: TIncludesTest + TCloneTest - {#testCopyCreatesNewObject} + TCopyPreservingIdentityTest + TCopyTest + TSetArithmetic - {#testDifferenceWithNonNullIntersection} + TIterateSequencedReadableTest + TSequencedConcatenationTest + TPrintOnSequencedTest + TAsStringCommaAndDelimiterSequenceableTest + TIndexAccess + TIndexAccessForMultipliness - {#testIdentityIndexOfIAbsentDuplicate. #testIdentityIndexOfDuplicate. #collectionWithNonIdentitySameAtEndAndBegining} + TSequencedElementAccessTest + TSubCollectionAccess + TCopySequenceableSameContents - {#testShuffled} + TCopyPartOfSequenceable - {#testCopyEmptyMethod. #integerCollectionWithoutEqualElements} + TCopyPartOfSequenceableForMultipliness + TCopySequenceableWithReplacement + TBeginsEndsWith + TConvertAsSortedTest + TConvertTest - {#testAsByteArray} + TCopySequenceableWithOrWithoutSpecificElements + TConvertAsSetForMultiplinessTest + TSequencedStructuralEqualityTest + TOccurrencesForMultiplinessTest 365983 instanceVariableNames: 'emptySymbol subcollection nonEmptySymbol5ElementsNoDuplicates notIn collectionNotIncluded collectionSize4 collection1Element sameAtEndAndBegining with2timeSubcollection' 365984 classVariableNames: '' 365985 poolDictionaries: '' 365986 category: 'CollectionsTests-Text'! 365987!SymbolTest commentStamp: '<historical>' prior: 0! 365988This is the unit test for the class Symbol. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 365989 - http://www.c2.com/cgi/wiki?UnitTest 365990 - http://minnow.cc.gatech.edu/squeak/1547 365991 - the sunit class category! 365992 365993 365994!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:49'! 365995anotherElementNotIn 365996 ^ notIn ! ! 365997 365998!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:02'! 365999anotherElementOrAssociationIn 366000 " return an element (or an association for Dictionary ) present in 'collection' " 366001 ^ self collection anyOne! ! 366002 366003!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:03'! 366004anotherElementOrAssociationNotIn 366005 " return an element (or an association for Dictionary )not present in 'collection' " 366006 ^ notIn ! ! 366007 366008!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:49'! 366009collection 366010 366011 ^ nonEmptySymbol5ElementsNoDuplicates ! ! 366012 366013!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:10'! 366014collectionMoreThan1NoDuplicates 366015 " return a collection of size > 1 without equal elements" 366016 ^ nonEmptySymbol5ElementsNoDuplicates ! ! 366017 366018!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:45'! 366019collectionNotIncluded 366020" return a collection for wich each element is not included in 'nonEmpty' " 366021 ^ collectionNotIncluded ! ! 366022 366023!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:39'! 366024collectionWith1TimeSubcollection 366025" return a collection including 'oldSubCollection' only one time " 366026 ^ nonEmptySymbol5ElementsNoDuplicates ! ! 366027 366028!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:41'! 366029collectionWith2TimeSubcollection 366030" return a collection including 'oldSubCollection' two or many time " 366031 ^ with2timeSubcollection ! ! 366032 366033!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:45'! 366034collectionWithElementsToRemove 366035" return a collection of elements included in 'nonEmpty' " 366036 ^ subcollection ! ! 366037 366038!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:00'! 366039collectionWithEqualElements 366040" return a collecition including atLeast two elements equal" 366041 366042^ sameAtEndAndBegining .! ! 366043 366044!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:13'! 366045collectionWithSameAtEndAndBegining 366046 " return a collection with elements at end and begining equals . 366047(others elements of the collection are not equal to those elements)" 366048 ^ sameAtEndAndBegining ! ! 366049 366050!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:20'! 366051collectionWithSortableElements 366052 " return a collection only including elements that can be sorted (understanding '<' )" 366053 ^ nonEmptySymbol5ElementsNoDuplicates .! ! 366054 366055!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:55'! 366056collectionWithoutEqualElements 366057" return a collection without equal elements" 366058 ^ nonEmptySymbol5ElementsNoDuplicates ! ! 366059 366060!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:36'! 366061collectionWithoutEqualsElements 366062 366063" return a collection not including equal elements " 366064 ^ nonEmptySymbol5ElementsNoDuplicates ! ! 366065 366066!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:56'! 366067collectionWithoutNilElements 366068" return a collection that doesn't includes a nil element and that doesn't includes equal elements'" 366069 ^nonEmptySymbol5ElementsNoDuplicates ! ! 366070 366071!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:15'! 366072elementInForElementAccessing 366073" return an element inculded in 'moreThan4Elements'" 366074 ^ self moreThan4Elements anyOne! ! 366075 366076!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:11'! 366077elementInForIndexAccessing 366078" return an element included in 'collectionMoreThan1NoDuplicates' " 366079 ^ self collectionMoreThan1NoDuplicates anyOne.! ! 366080 366081!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:45'! 366082elementNotIn 366083"return an element not included in 'nonEmpty' " 366084 366085 ^ notIn ! ! 366086 366087!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:15'! 366088elementNotInForElementAccessing 366089" return an element not included in 'moreThan4Elements' " 366090 ^ notIn ! ! 366091 366092!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:11'! 366093elementNotInForIndexAccessing 366094" return an element not included in 'collectionMoreThan1NoDuplicates' " 366095 ^ notIn ! ! 366096 366097!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:56'! 366098elementNotInForOccurrences 366099 ^ notIn ! ! 366100 366101!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:00'! 366102elementTwiceInForOccurrences 366103" return an element included exactly two time in # collectionWithEqualElements" 366104^ sameAtEndAndBegining first! ! 366105 366106!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:49'! 366107empty 366108 ^ emptySymbol ! ! 366109 366110!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:00'! 366111firstCollection 366112" return a collection that will be the first part of the concatenation" 366113 ^ nonEmptySymbol5ElementsNoDuplicates ! ! 366114 366115!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:37'! 366116indexInForCollectionWithoutDuplicates 366117" return an index between 'collectionWithoutEqualsElements' bounds" 366118 ^ 2! ! 366119 366120!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 16:17'! 366121indexInNonEmpty 366122" return an index between bounds of 'nonEmpty' " 366123 366124 ^ 2! ! 366125 366126!SymbolTest methodsFor: 'requirements'! 366127integerCollectionWithoutEqualElements 366128" return a collection of integer without equal elements" 366129 ^ self explicitRequirement! ! 366130 366131!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:17'! 366132moreThan3Elements 366133 " return a collection including atLeast 3 elements" 366134 ^ nonEmptySymbol5ElementsNoDuplicates ! ! 366135 366136!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:15'! 366137moreThan4Elements 366138 366139" return a collection including at leat 4 elements" 366140 ^ nonEmptySymbol5ElementsNoDuplicates ! ! 366141 366142!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:49'! 366143nonEmpty 366144 ^ nonEmptySymbol5ElementsNoDuplicates ! ! 366145 366146!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:02'! 366147nonEmpty1Element 366148" return a collection of size 1 including one element" 366149 ^collection1Element ! ! 366150 366151!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:59'! 366152nonEmptyMoreThan1Element 366153" return a collection that don't includes equal elements'" 366154 ^nonEmptySymbol5ElementsNoDuplicates ! ! 366155 366156!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:39'! 366157oldSubCollection 366158" return a subCollection included in collectionWith1TimeSubcollection . 366159ex : subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)" 366160 ^ subcollection ! ! 366161 366162!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:39'! 366163replacementCollection 366164" return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection' " 366165 ^ collection1Element ! ! 366166 366167!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:00'! 366168secondCollection 366169" return a collection that will be the second part of the concatenation" 366170 ^ collectionSize4 ! ! 366171 366172!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:58'! 366173sizeCollection 366174 "Answers a collection whose #size is 4" 366175 ^ collectionSize4 ! ! 366176 366177!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:16'! 366178subCollectionNotIn 366179" return a collection for which at least one element is not included in 'moreThan4Elements' " 366180 ^ collectionNotIncluded ! ! 366181 366182!SymbolTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:30'! 366183withEqualElements 366184 " return a collection including equal elements (classic equality)" 366185 ^ sameAtEndAndBegining ! ! 366186 366187 366188!SymbolTest methodsFor: 'setup' stamp: 'delaunay 4/27/2009 15:41'! 366189setUp 366190 emptySymbol := #''. 366191 collectionSize4 := #abcd. 366192 collection1Element := #a. 366193 subcollection := #bcd. 366194 with2timeSubcollection := #abcdebcda. 366195 nonEmptySymbol5ElementsNoDuplicates := #abcde. 366196 sameAtEndAndBegining := #abcda. 366197 notIn := $z. 366198 collectionNotIncluded := #zz.! ! 366199 366200 366201!SymbolTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! 366202elementToAdd 366203 ^ $u! ! 366204 366205 366206!SymbolTest methodsFor: 'test - equality'! 366207testEqualSign 366208 "self debug: #testEqualSign" 366209 366210 self deny: (self empty = self nonEmpty).! ! 366211 366212!SymbolTest methodsFor: 'test - equality'! 366213testEqualSignIsTrueForNonIdenticalButEqualCollections 366214 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 366215 366216 self assert: (self empty = self empty copy). 366217 self assert: (self empty copy = self empty). 366218 self assert: (self empty copy = self empty copy). 366219 366220 self assert: (self nonEmpty = self nonEmpty copy). 366221 self assert: (self nonEmpty copy = self nonEmpty). 366222 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 366223 366224!SymbolTest methodsFor: 'test - equality'! 366225testEqualSignOfIdenticalCollectionObjects 366226 "self debug: #testEqualSignOfIdenticalCollectionObjects" 366227 366228 self assert: (self empty = self empty). 366229 self assert: (self nonEmpty = self nonEmpty). 366230 ! ! 366231 366232 366233!SymbolTest methodsFor: 'test - set arithmetic' stamp: 'stephane.ducasse 12/20/2008 21:57'! 366234collectionClass 366235 366236 ^ Symbol! ! 366237 366238 366239!SymbolTest methodsFor: 'tests' stamp: 'md 9/6/2005 20:02'! 366240testAsMutator 366241 366242 self assert: #x asMutator = #x:. 366243 self assert: #x asMutator isSymbol! ! 366244 366245!SymbolTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:29'! 366246testCapitalized 366247 366248 | uc lc | 366249 uc := #MElViN. 366250 lc := #mElViN. 366251 self assert: lc capitalized = uc. 366252 self assert: uc capitalized = uc. 366253! ! 366254 366255!SymbolTest methodsFor: 'tests' stamp: 'md 2/16/2006 17:17'! 366256testNumArgs2 366257 "TODO: need to be extended to support shrinking and for selectors like #+ " 366258 366259 self assert: (#test numArgs: 0) = #test. 366260 self assert: (#test numArgs: 1) = #test:. 366261 self assert: (#test numArgs: 2) = #test:with:. 366262 self assert: (#test numArgs: 3) = #test:with:with:. 366263 366264 366265 self assert: (#test: numArgs: 0) = #test:. 366266 self assert: (#test: numArgs: 1) = #test:. 366267 self assert: (#test: numArgs: 2) = #test:with:. 366268 self assert: (#test: numArgs: 3) = #test:with:with:. 366269 366270 self assert: (#test:with: numArgs: 0) = #test:with:. 366271 self assert: (#test:with: numArgs: 1) = #test:with:. 366272 self assert: (#test:with: numArgs: 2) = #test:with:. 366273 self assert: (#test:with: numArgs: 3) = #test:with:with:. 366274 self assert: (#test:with: numArgs: 4) = #test:with:with:with:. 366275 366276 self assert: (#test:with:with: numArgs: 0) = #test:with:with:. 366277 self assert: (#test:with:with: numArgs: 1) = #test:with:with:. 366278 self assert: (#test:with:with: numArgs: 2) = #test:with:with:. 366279 self assert: (#test:with:with: numArgs: 3) = #test:with:with:. 366280 self assert: (#test:with:with: numArgs: 4) = #test:with:with:with:.! ! 366281 366282!SymbolTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:29'! 366283testWithFirstCharacterDownshifted 366284 366285 | uc lc empty | 366286 uc := #MElViN. 366287 lc := #mElViN. 366288 empty := #' '. 366289 self assert: uc withFirstCharacterDownshifted = lc. 366290 self assert: lc withFirstCharacterDownshifted = lc. 366291 366292! ! 366293 366294 366295!SymbolTest methodsFor: 'tests - as set tests'! 366296testAsIdentitySetWithEqualsElements 366297 | result collection | 366298 collection := self withEqualElements . 366299 result := collection asIdentitySet. 366300 collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 366301 self assert: result class = IdentitySet.! ! 366302 366303!SymbolTest methodsFor: 'tests - as set tests'! 366304testAsSetWithEqualsElements 366305 | result | 366306 result := self withEqualElements asSet. 366307 self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 366308 self assert: result class = Set! ! 366309 366310 366311!SymbolTest methodsFor: 'tests - as sorted collection'! 366312testAsSortedArray 366313 | result collection | 366314 collection := self collectionWithSortableElements . 366315 result := collection asSortedArray. 366316 self assert: (result class includesBehavior: Array). 366317 self assert: result isSorted. 366318 self assert: result size = collection size! ! 366319 366320!SymbolTest methodsFor: 'tests - as sorted collection'! 366321testAsSortedCollection 366322 366323 | aCollection result | 366324 aCollection := self collectionWithSortableElements . 366325 result := aCollection asSortedCollection. 366326 366327 self assert: (result class includesBehavior: SortedCollection). 366328 result do: 366329 [ :each | 366330 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 366331 366332 self assert: result size = aCollection size.! ! 366333 366334!SymbolTest methodsFor: 'tests - as sorted collection'! 366335testAsSortedCollectionWithSortBlock 366336 | result tmp | 366337 result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. 366338 self assert: (result class includesBehavior: SortedCollection). 366339 result do: 366340 [ :each | 366341 self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 366342 self assert: result size = self collectionWithSortableElements size. 366343 tmp:=result at: 1. 366344 result do: [:each| self assert: tmp>=each. tmp:=each]. 366345 ! ! 366346 366347 366348!SymbolTest methodsFor: 'tests - begins ends with'! 366349testsBeginsWith 366350 366351 self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty size)). 366352 self assert: (self nonEmpty beginsWith:(self nonEmpty )). 366353 self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 366354 366355!SymbolTest methodsFor: 'tests - begins ends with'! 366356testsBeginsWithEmpty 366357 366358 self deny: (self nonEmpty beginsWith:(self empty)). 366359 self deny: (self empty beginsWith:(self nonEmpty )). 366360! ! 366361 366362!SymbolTest methodsFor: 'tests - begins ends with'! 366363testsEndsWith 366364 366365 self assert: (self nonEmpty endsWith:(self nonEmpty copyWithoutFirst)). 366366 self assert: (self nonEmpty endsWith:(self nonEmpty )). 366367 self deny: (self nonEmpty endsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 366368 366369!SymbolTest methodsFor: 'tests - begins ends with'! 366370testsEndsWithEmpty 366371 366372 self deny: (self nonEmpty endsWith:(self empty )). 366373 self deny: (self empty endsWith:(self nonEmpty )). 366374 ! ! 366375 366376 366377!SymbolTest methodsFor: 'tests - comma and delimiter'! 366378testAsCommaStringEmpty 366379 366380 self assert: self empty asCommaString = ''. 366381 self assert: self empty asCommaStringAnd = ''. 366382 366383 366384! ! 366385 366386!SymbolTest methodsFor: 'tests - comma and delimiter'! 366387testAsCommaStringMore 366388 366389 "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. 366390 self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' 366391" 366392 366393 | result resultAnd index allElementsAsString | 366394 result:= self nonEmpty asCommaString . 366395 resultAnd:= self nonEmpty asCommaStringAnd . 366396 366397 index := 1. 366398 (result findBetweenSubStrs: ',' )do: 366399 [:each | 366400 index = 1 366401 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] 366402 ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. 366403 index:=index+1 366404 ]. 366405 366406 "verifying esultAnd :" 366407 allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 366408 1 to: allElementsAsString size do: 366409 [:i | 366410 i<(allElementsAsString size ) 366411 ifTrue: [ 366412 i = 1 366413 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] 366414 ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] 366415 ]. 366416 i=(allElementsAsString size) 366417 ifTrue:[ 366418 i = 1 366419 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 366420 ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 366421 ]. 366422 366423 366424 ].! ! 366425 366426!SymbolTest methodsFor: 'tests - comma and delimiter'! 366427testAsCommaStringOne 366428 366429 "self assert: self oneItemCol asCommaString = '1'. 366430 self assert: self oneItemCol asCommaStringAnd = '1'." 366431 366432 self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). 366433 self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). 366434 ! ! 366435 366436!SymbolTest methodsFor: 'tests - comma and delimiter'! 366437testAsStringOnDelimiterEmpty 366438 366439 | delim emptyStream | 366440 delim := ', '. 366441 emptyStream := ReadWriteStream on: ''. 366442 self empty asStringOn: emptyStream delimiter: delim. 366443 self assert: emptyStream contents = ''. 366444! ! 366445 366446!SymbolTest methodsFor: 'tests - comma and delimiter'! 366447testAsStringOnDelimiterLastEmpty 366448 366449 | delim emptyStream | 366450 delim := ', '. 366451 emptyStream := ReadWriteStream on: ''. 366452 self empty asStringOn: emptyStream delimiter: delim last:'and'. 366453 self assert: emptyStream contents = ''. 366454! ! 366455 366456!SymbolTest methodsFor: 'tests - comma and delimiter'! 366457testAsStringOnDelimiterLastMore 366458 366459 | delim multiItemStream result last allElementsAsString | 366460 366461 delim := ', '. 366462 last := 'and'. 366463 result:=''. 366464 multiItemStream := ReadWriteStream on:result. 366465 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 366466 366467 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 366468 1 to: allElementsAsString size do: 366469 [:i | 366470 i<(allElementsAsString size-1 ) 366471 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 366472 i=(allElementsAsString size-1) 366473 ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. 366474 i=(allElementsAsString size) 366475 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 366476 ]. 366477 366478! ! 366479 366480!SymbolTest methodsFor: 'tests - comma and delimiter'! 366481testAsStringOnDelimiterLastOne 366482 366483 | delim oneItemStream result | 366484 366485 delim := ', '. 366486 result:=''. 366487 oneItemStream := ReadWriteStream on: result. 366488 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 366489 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 366490 366491 366492 ! ! 366493 366494!SymbolTest methodsFor: 'tests - comma and delimiter'! 366495testAsStringOnDelimiterMore 366496 366497 | delim multiItemStream result index | 366498 "delim := ', '. 366499 multiItemStream := '' readWrite. 366500 self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. 366501 self assert: multiItemStream contents = '1, 2, 3'." 366502 366503 delim := ', '. 366504 result:=''. 366505 multiItemStream := ReadWriteStream on:result. 366506 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 366507 366508 index:=1. 366509 (result findBetweenSubStrs: ', ' )do: 366510 [:each | 366511 self assert: each= ((self nonEmpty at:index)asString). 366512 index:=index+1 366513 ].! ! 366514 366515!SymbolTest methodsFor: 'tests - comma and delimiter'! 366516testAsStringOnDelimiterOne 366517 366518 | delim oneItemStream result | 366519 "delim := ', '. 366520 oneItemStream := '' readWrite. 366521 self oneItemCol asStringOn: oneItemStream delimiter: delim. 366522 self assert: oneItemStream contents = '1'." 366523 366524 delim := ', '. 366525 result:=''. 366526 oneItemStream := ReadWriteStream on: result. 366527 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 366528 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 366529 366530 366531 ! ! 366532 366533 366534!SymbolTest methodsFor: 'tests - concatenation'! 366535testConcatenation 366536 | result index | 366537 result:= self firstCollection,self secondCollection . 366538 "first part : " 366539 index := 1. 366540 self firstCollection do: 366541 [:each | 366542 self assert: (self firstCollection at: index)=each. 366543 index := index+1.]. 366544 "second part : " 366545 1 to: self secondCollection size do: 366546 [:i | 366547 self assert: (self secondCollection at:i)= (result at:index). 366548 index:=index+1]. 366549 "size : " 366550 self assert: result size = (self firstCollection size + self secondCollection size).! ! 366551 366552!SymbolTest methodsFor: 'tests - concatenation'! 366553testConcatenationWithEmpty 366554 | result | 366555 result:= self empty,self secondCollection . 366556 366557 1 to: self secondCollection size do: 366558 [:i | 366559 self assert: (self secondCollection at:i)= (result at:i). 366560 ]. 366561 "size : " 366562 self assert: result size = ( self secondCollection size).! ! 366563 366564 366565!SymbolTest methodsFor: 'tests - converting'! 366566assertNoDuplicates: aCollection whenConvertedTo: aClass 366567 | result | 366568 result := self collectionWithEqualElements asIdentitySet. 366569 self assert: (result class includesBehavior: IdentitySet). 366570 self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! 366571 366572!SymbolTest methodsFor: 'tests - converting'! 366573assertNonDuplicatedContents: aCollection whenConvertedTo: aClass 366574 | result | 366575 result := aCollection perform: ('as' , aClass name) asSymbol. 366576 self assert: (result class includesBehavior: aClass). 366577 result do: 366578 [ :each | 366579 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 366580 ^ result! ! 366581 366582!SymbolTest methodsFor: 'tests - converting'! 366583assertSameContents: aCollection whenConvertedTo: aClass 366584 | result | 366585 result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. 366586 self assert: result size = aCollection size! ! 366587 366588!SymbolTest methodsFor: 'tests - converting'! 366589testAsArray 366590 "self debug: #testAsArray3" 366591 self 366592 assertSameContents: self collectionWithoutEqualElements 366593 whenConvertedTo: Array! ! 366594 366595!SymbolTest methodsFor: 'tests - converting'! 366596testAsBag 366597 366598 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! 366599 366600!SymbolTest methodsFor: 'tests - converting'! 366601testAsIdentitySet 366602 "test with a collection without equal elements :" 366603 self 366604 assertSameContents: self collectionWithoutEqualElements 366605 whenConvertedTo: IdentitySet. 366606! ! 366607 366608!SymbolTest methodsFor: 'tests - converting'! 366609testAsOrderedCollection 366610 366611 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! 366612 366613!SymbolTest methodsFor: 'tests - converting'! 366614testAsSet 366615 | | 366616 "test with a collection without equal elements :" 366617 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. 366618 ! ! 366619 366620 366621!SymbolTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 366622testCopyEmptyWith 366623 "self debug: #testCopyWith" 366624 | res | 366625 res := self empty copyWith: self elementToAdd. 366626 self assert: res size = (self empty size + 1). 366627 self assert: (res includes: self elementToAdd)! ! 366628 366629!SymbolTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 366630testCopyEmptyWithout 366631 "self debug: #testCopyEmptyWithout" 366632 | res | 366633 res := self empty copyWithout: self elementToAdd. 366634 self assert: res size = self empty size. 366635 self deny: (res includes: self elementToAdd)! ! 366636 366637!SymbolTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 366638testCopyEmptyWithoutAll 366639 "self debug: #testCopyEmptyWithoutAll" 366640 | res | 366641 res := self empty copyWithoutAll: self collectionWithElementsToRemove. 366642 self assert: res size = self empty size. 366643 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! 366644 366645!SymbolTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 366646testCopyNonEmptyWith 366647 "self debug: #testCopyNonEmptyWith" 366648 | res | 366649 res := self nonEmpty copyWith: self elementToAdd. 366650 "here we do not test the size since for a non empty set we would get a problem. 366651 Then in addition copy is not about duplicate management. The element should 366652 be in at the end." 366653 self assert: (res includes: self elementToAdd). 366654 self nonEmpty do: [ :each | res includes: each ]! ! 366655 366656!SymbolTest methodsFor: 'tests - copy'! 366657testCopyNonEmptyWithout 366658 "self debug: #testCopyNonEmptyWithout" 366659 366660 | res anElementOfTheCollection | 366661 anElementOfTheCollection := self nonEmpty anyOne. 366662 res := (self nonEmpty copyWithout: anElementOfTheCollection). 366663 "here we do not test the size since for a non empty set we would get a problem. 366664 Then in addition copy is not about duplicate management. The element should 366665 be in at the end." 366666 self deny: (res includes: anElementOfTheCollection). 366667 self nonEmpty do: 366668 [:each | (each = anElementOfTheCollection) 366669 ifFalse: [self assert: (res includes: each)]]. 366670 366671! ! 366672 366673!SymbolTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 366674testCopyNonEmptyWithoutAll 366675 "self debug: #testCopyNonEmptyWithoutAll" 366676 | res | 366677 res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. 366678 "here we do not test the size since for a non empty set we would get a problem. 366679 Then in addition copy is not about duplicate management. The element should 366680 be in at the end." 366681 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]. 366682 self nonEmpty do: 366683 [ :each | 366684 (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! 366685 366686!SymbolTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! 366687testCopyNonEmptyWithoutAllNotIncluded 366688 ! ! 366689 366690!SymbolTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 366691testCopyNonEmptyWithoutNotIncluded 366692 "self debug: #testCopyNonEmptyWithoutNotIncluded" 366693 | res | 366694 res := self nonEmpty copyWithout: self elementToAdd. 366695 "here we do not test the size since for a non empty set we would get a problem. 366696 Then in addition copy is not about duplicate management. The element should 366697 be in at the end." 366698 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 366699 366700!SymbolTest methodsFor: 'tests - copy'! 366701testCopyReturnsIdentity 366702 "self debug: #testCopyReturnsIdentity" 366703 366704 | copy | 366705 copy := self nonEmpty copy. 366706 self assert: self nonEmpty == copy. 366707 ! ! 366708 366709 366710!SymbolTest methodsFor: 'tests - copy - clone'! 366711testCopyEmpty 366712 "self debug: #testCopyEmpty" 366713 366714 | copy | 366715 copy := self empty copy. 366716 self assert: copy isEmpty.! ! 366717 366718!SymbolTest methodsFor: 'tests - copy - clone'! 366719testCopyNonEmpty 366720 "self debug: #testCopyNonEmpty" 366721 366722 | copy | 366723 copy := self nonEmpty copy. 366724 self deny: copy isEmpty. 366725 self assert: copy size = self nonEmpty size. 366726 self nonEmpty do: 366727 [:each | copy includes: each]! ! 366728 366729 366730!SymbolTest methodsFor: 'tests - copying part of sequenceable'! 366731testCopyAfter 366732 | result index collection | 366733 collection := self collectionWithoutEqualsElements . 366734 index:= self indexInForCollectionWithoutDuplicates . 366735 result := collection copyAfter: (collection at:index ). 366736 366737 "verifying content: " 366738 (1) to: result size do: 366739 [:i | 366740 self assert: (collection at:(i + index ))=(result at: (i))]. 366741 366742 "verify size: " 366743 self assert: result size = (collection size - index).! ! 366744 366745!SymbolTest methodsFor: 'tests - copying part of sequenceable'! 366746testCopyAfterEmpty 366747 | result | 366748 result := self empty copyAfter: self collectionWithoutEqualsElements first. 366749 self assert: result isEmpty. 366750 ! ! 366751 366752!SymbolTest methodsFor: 'tests - copying part of sequenceable'! 366753testCopyAfterLast 366754 | result index collection | 366755 collection := self collectionWithoutEqualsElements . 366756 index:= self indexInForCollectionWithoutDuplicates . 366757 result := collection copyAfterLast: (collection at:index ). 366758 366759 "verifying content: " 366760 (1) to: result size do: 366761 [:i | 366762 self assert: (collection at:(i + index ))=(result at: (i))]. 366763 366764 "verify size: " 366765 self assert: result size = (collection size - index).! ! 366766 366767!SymbolTest methodsFor: 'tests - copying part of sequenceable'! 366768testCopyAfterLastEmpty 366769 | result | 366770 result := self empty copyAfterLast: self collectionWithoutEqualsElements first. 366771 self assert: result isEmpty.! ! 366772 366773!SymbolTest methodsFor: 'tests - copying part of sequenceable'! 366774testCopyFromTo 366775 | result index collection | 366776 collection := self collectionWithoutEqualsElements . 366777 index :=self indexInForCollectionWithoutDuplicates . 366778 result := collection copyFrom: index to: collection size . 366779 366780 "verify content of 'result' : " 366781 1 to: result size do: 366782 [:i | 366783 self assert: (result at:i)=(collection at: (i + index - 1))]. 366784 366785 "verify size of 'result' : " 366786 self assert: result size = (collection size - index + 1).! ! 366787 366788!SymbolTest methodsFor: 'tests - copying part of sequenceable'! 366789testCopyUpTo 366790 | result index collection | 366791 collection := self collectionWithoutEqualsElements . 366792 index:= self indexInForCollectionWithoutDuplicates . 366793 result := collection copyUpTo: (collection at:index). 366794 366795 "verify content of 'result' :" 366796 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 366797 366798 "verify size of 'result' :" 366799 self assert: result size = (index-1). 366800 ! ! 366801 366802!SymbolTest methodsFor: 'tests - copying part of sequenceable'! 366803testCopyUpToEmpty 366804 | result | 366805 result := self empty copyUpTo: self collectionWithoutEqualsElements first. 366806 self assert: result isEmpty. 366807 ! ! 366808 366809!SymbolTest methodsFor: 'tests - copying part of sequenceable'! 366810testCopyUpToLast 366811 | result index collection | 366812 collection := self collectionWithoutEqualsElements . 366813 index:= self indexInForCollectionWithoutDuplicates . 366814 result := collection copyUpToLast: (collection at:index). 366815 366816 "verify content of 'result' :" 366817 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 366818 366819 "verify size of 'result' :" 366820 self assert: result size = (index-1).! ! 366821 366822!SymbolTest methodsFor: 'tests - copying part of sequenceable'! 366823testCopyUpToLastEmpty 366824 | result | 366825 result := self empty copyUpToLast: self collectionWithoutEqualsElements first. 366826 self assert: result isEmpty.! ! 366827 366828 366829!SymbolTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 366830testCopyAfterLastWithDuplicate 366831 | result element collection | 366832 collection := self collectionWithSameAtEndAndBegining . 366833 element := collection first. 366834 366835 " collectionWithSameAtEndAndBegining first and last elements are equals. 366836 'copyAfter:' should copy after the last occurence of element :" 366837 result := collection copyAfterLast: (element ). 366838 366839 "verifying content: " 366840 self assert: result isEmpty. 366841 366842! ! 366843 366844!SymbolTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 366845testCopyAfterWithDuplicate 366846 | result element collection | 366847 collection := self collectionWithSameAtEndAndBegining . 366848 element := collection last. 366849 366850 " collectionWithSameAtEndAndBegining first and last elements are equals. 366851 'copyAfter:' should copy after the first occurence :" 366852 result := collection copyAfter: (element ). 366853 366854 "verifying content: " 366855 1 to: result size do: 366856 [:i | 366857 self assert: (collection at:(i + 1 )) = (result at: (i)) 366858 ]. 366859 366860 "verify size: " 366861 self assert: result size = (collection size - 1).! ! 366862 366863!SymbolTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 366864testCopyUpToLastWithDuplicate 366865 | result element collection | 366866 collection := self collectionWithSameAtEndAndBegining . 366867 element := collection first. 366868 366869 " collectionWithSameAtEndAndBegining first and last elements are equals. 366870 'copyUpToLast:' should copy until the last occurence :" 366871 result := collection copyUpToLast: (element ). 366872 366873 "verifying content: " 366874 1 to: result size do: 366875 [:i | 366876 self assert: (result at: i ) = ( collection at: i ) 366877 ]. 366878 366879 self assert: result size = (collection size - 1). 366880 366881! ! 366882 366883!SymbolTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 366884testCopyUpToWithDuplicate 366885 | result element collection | 366886 collection := self collectionWithSameAtEndAndBegining . 366887 element := collection last. 366888 366889 " collectionWithSameAtEndAndBegining first and last elements are equals. 366890 'copyUpTo:' should copy until the first occurence :" 366891 result := collection copyUpTo: (element ). 366892 366893 "verifying content: " 366894 self assert: result isEmpty. 366895 366896! ! 366897 366898 366899!SymbolTest methodsFor: 'tests - copying same contents'! 366900testReverse 366901 | result | 366902 result := self nonEmpty reverse . 366903 366904 "verify content of 'result: '" 366905 1 to: result size do: 366906 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 366907 "verify size of 'result' :" 366908 self assert: result size=self nonEmpty size.! ! 366909 366910!SymbolTest methodsFor: 'tests - copying same contents'! 366911testReversed 366912 | result | 366913 result := self nonEmpty reversed . 366914 366915 "verify content of 'result: '" 366916 1 to: result size do: 366917 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 366918 "verify size of 'result' :" 366919 self assert: result size=self nonEmpty size.! ! 366920 366921!SymbolTest methodsFor: 'tests - copying same contents'! 366922testShallowCopy 366923 | result | 366924 result := self nonEmpty shallowCopy . 366925 366926 "verify content of 'result: '" 366927 1 to: self nonEmpty size do: 366928 [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. 366929 "verify size of 'result' :" 366930 self assert: result size=self nonEmpty size.! ! 366931 366932!SymbolTest methodsFor: 'tests - copying same contents'! 366933testShallowCopyEmpty 366934 | result | 366935 result := self empty shallowCopy . 366936 self assert: result isEmpty .! ! 366937 366938!SymbolTest methodsFor: 'tests - copying same contents'! 366939testSortBy 366940 " can only be used if the collection tested can include sortable elements :" 366941 | result tmp | 366942 self 366943 shouldnt: [ self collectionWithSortableElements ] 366944 raise: Error. 366945 self shouldnt: [self collectionWithSortableElements anyOne < self collectionWithSortableElements anyOne] raise: Error. 366946 result := self collectionWithSortableElements sortBy: [ :a :b | a < b ]. 366947 366948 "verify content of 'result' : " 366949 result do: 366950 [ :each | 366951 (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 366952 tmp := result first. 366953 result do: 366954 [ :each | 366955 self assert: each >= tmp. 366956 tmp := each ]. 366957 366958 "verify size of 'result' :" 366959 self assert: result size = self collectionWithSortableElements size! ! 366960 366961 366962!SymbolTest methodsFor: 'tests - copying with or without'! 366963testCopyWithFirst 366964 366965 | index element result | 366966 index:= self indexInNonEmpty . 366967 element:= self nonEmpty at: index. 366968 366969 result := self nonEmpty copyWithFirst: element. 366970 366971 self assert: result size = (self nonEmpty size + 1). 366972 self assert: result first = element . 366973 366974 2 to: result size do: 366975 [ :i | 366976 self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! 366977 366978!SymbolTest methodsFor: 'tests - copying with or without'! 366979testCopyWithSequenceable 366980 366981 | result index element | 366982 index := self indexInNonEmpty . 366983 element := self nonEmpty at: index. 366984 result := self nonEmpty copyWith: (element ). 366985 366986 self assert: result size = (self nonEmpty size + 1). 366987 self assert: result last = element . 366988 366989 1 to: (result size - 1) do: 366990 [ :i | 366991 self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! 366992 366993!SymbolTest methodsFor: 'tests - copying with or without'! 366994testCopyWithoutFirst 366995 366996 | result | 366997 result := self nonEmpty copyWithoutFirst. 366998 366999 self assert: result size = (self nonEmpty size - 1). 367000 367001 1 to: result size do: 367002 [:i | 367003 self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! 367004 367005!SymbolTest methodsFor: 'tests - copying with or without'! 367006testCopyWithoutIndex 367007 | result index | 367008 index := self indexInNonEmpty . 367009 result := self nonEmpty copyWithoutIndex: index . 367010 367011 "verify content of 'result:'" 367012 1 to: result size do: 367013 [:i | 367014 i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. 367015 i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. 367016 367017 "verify size of result : " 367018 self assert: result size=(self nonEmpty size -1).! ! 367019 367020!SymbolTest methodsFor: 'tests - copying with or without'! 367021testForceToPaddingStartWith 367022 367023 | result element | 367024 element := self nonEmpty at: self indexInNonEmpty . 367025 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). 367026 367027 "verify content of 'result' : " 367028 1 to: 2 do: 367029 [:i | self assert: ( element ) = ( result at:(i) ) ]. 367030 367031 3 to: result size do: 367032 [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. 367033 367034 "verify size of 'result' :" 367035 self assert: result size = (self nonEmpty size + 2).! ! 367036 367037!SymbolTest methodsFor: 'tests - copying with or without'! 367038testForceToPaddingWith 367039 367040 | result element | 367041 element := self nonEmpty at: self indexInNonEmpty . 367042 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). 367043 367044 "verify content of 'result' : " 367045 1 to: self nonEmpty size do: 367046 [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. 367047 367048 (result size - 1) to: result size do: 367049 [:i | self assert: ( result at:i ) = ( element ) ]. 367050 367051 "verify size of 'result' :" 367052 self assert: result size = (self nonEmpty size + 2).! ! 367053 367054 367055!SymbolTest methodsFor: 'tests - copying with replacement'! 367056firstIndexesOf: subCollection in: collection 367057" return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " 367058 | tmp result currentIndex | 367059 tmp:= collection. 367060 result:= OrderedCollection new. 367061 currentIndex := 1. 367062 367063 [tmp isEmpty ]whileFalse: 367064 [ 367065 (tmp beginsWith: subCollection) 367066 ifTrue: [ 367067 result add: currentIndex. 367068 1 to: subCollection size do: 367069 [:i | 367070 tmp := tmp copyWithoutFirst. 367071 currentIndex := currentIndex + 1] 367072 ] 367073 ifFalse: [ 367074 tmp := tmp copyWithoutFirst. 367075 currentIndex := currentIndex +1. 367076 ] 367077 ]. 367078 367079 ^ result. 367080 ! ! 367081 367082!SymbolTest methodsFor: 'tests - copying with replacement'! 367083testCopyReplaceAllWith1Occurence 367084 | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | 367085 367086 result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 367087 367088 "detecting indexes of olSubCollection" 367089 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . 367090 index:= firstIndexesOfOccurrence at: 1. 367091 367092 "verify content of 'result' : " 367093 "first part of 'result'' : '" 367094 367095 1 to: (index -1) do: 367096 [ 367097 :i | 367098 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 367099 ]. 367100 367101 " middle part containing replacementCollection : " 367102 367103 index to: (index + self replacementCollection size-1) do: 367104 [ 367105 :i | 367106 self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) 367107 ]. 367108 367109 " end part :" 367110 367111 endPartIndexResult := index + self replacementCollection size . 367112 endPartIndexCollection := index + self oldSubCollection size . 367113 367114 1 to: (result size - endPartIndexResult - 1 ) do: 367115 [ 367116 :i | 367117 self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). 367118 ]. 367119 367120 367121 ! ! 367122 367123!SymbolTest methodsFor: 'tests - copying with replacement'! 367124testCopyReplaceAllWithManyOccurence 367125 | result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff | 367126 " testing fixture here as this method may be not used for collection that can't contain equals element :" 367127 self shouldnt: [self collectionWith2TimeSubcollection ]raise: Error. 367128 self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection ) = 2. 367129 367130 " test :" 367131 diff := self replacementCollection size - self oldSubCollection size. 367132 result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 367133 367134 "detecting indexes of olSubCollection" 367135 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection . 367136 367137 " verifying that replacementCollection has been put in places of oldSubCollections " 367138 firstIndexesOfOccurrence do: [ 367139 :each | 367140 (firstIndexesOfOccurrence indexOf: each) = 1 367141 ifTrue: [ 367142 each to: self replacementCollection size do: 367143 [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. 367144 ] 367145 ifFalse:[ 367146 (each + diff) to: self replacementCollection size do: 367147 [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. 367148 ]. 367149 367150 ]. 367151 367152 " verifying that the 'between' parts correspond to the initial collection : " 367153 1 to: firstIndexesOfOccurrence size do: [ 367154 :i | 367155 i = 1 367156 " specific comportement for the begining of the collection :" 367157 ifTrue: [ 367158 1 to: ((firstIndexesOfOccurrence at: i) - 1 ) do: 367159 [ :j | 367160 self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] 367161 ] 367162 " between parts till the end : " 367163 ifFalse: [ 367164 resultBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self replacementCollection size. 367165 collectionBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self oldSubCollection size. 367166 367167 1 to: ( firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: 367168 [ :j | 367169 self assert: (result at: (resultBetweenPartIndex + i - 1)) = (self collectionWith2TimeSubcollection at: (collectionBetweenPartIndex +i - 1)) ] 367170 ] 367171 ]. 367172 367173 "final part :" 367174 1 to: (self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size ) ) do: 367175 [ 367176 :i | 367177 self assert: ( result at:(firstIndexesOfOccurrence last + self replacementCollection size -1) + i ) = ( self collectionWith2TimeSubcollection at:(firstIndexesOfOccurrence last + self oldSubCollection size -1) + i ) . 367178 ]! ! 367179 367180!SymbolTest methodsFor: 'tests - copying with replacement'! 367181testCopyReplaceFromToWith 367182 | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | 367183 367184 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 367185 lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. 367186 lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. 367187 367188 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . 367189 367190 "verify content of 'result' : " 367191 "first part of 'result' " 367192 367193 1 to: (indexOfSubcollection - 1) do: 367194 [ 367195 :i | 367196 self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) 367197 ]. 367198 367199 " middle part containing replacementCollection : " 367200 367201 (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: 367202 [ 367203 :i | 367204 self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) 367205 ]. 367206 367207 " end part :" 367208 1 to: (result size - lastIndexOfReplacementCollection ) do: 367209 [ 367210 :i | 367211 self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). 367212 ]. 367213 367214 367215 367216 367217 367218 ! ! 367219 367220!SymbolTest methodsFor: 'tests - copying with replacement'! 367221testCopyReplaceFromToWithInsertion 367222 | result indexOfSubcollection | 367223 367224 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 367225 367226 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . 367227 367228 "verify content of 'result' : " 367229 "first part of 'result'' : '" 367230 367231 1 to: (indexOfSubcollection -1) do: 367232 [ 367233 :i | 367234 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 367235 ]. 367236 367237 " middle part containing replacementCollection : " 367238 indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: 367239 [ 367240 :i | 367241 self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) 367242 ]. 367243 367244 " end part :" 367245 (indexOfSubcollection + self replacementCollection size) to: (result size) do: 367246 [:i| 367247 self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. 367248 367249 " verify size: " 367250 self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). 367251 367252 367253 367254 367255 367256 ! ! 367257 367258 367259!SymbolTest methodsFor: 'tests - element accessing'! 367260testAfter 367261 "self debug: #testAfter" 367262 self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). 367263 self 367264 should: 367265 [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] 367266 raise: Error. 367267 self 367268 should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] 367269 raise: Error! ! 367270 367271!SymbolTest methodsFor: 'tests - element accessing'! 367272testAfterIfAbsent 367273 "self debug: #testAfterIfAbsent" 367274 self assert: (self moreThan4Elements 367275 after: (self moreThan4Elements at: 1) 367276 ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). 367277 self assert: (self moreThan4Elements 367278 after: (self moreThan4Elements at: self moreThan4Elements size) 367279 ifAbsent: [ 33 ]) == 33. 367280 self assert: (self moreThan4Elements 367281 after: self elementNotInForElementAccessing 367282 ifAbsent: [ 33 ]) = 33! ! 367283 367284!SymbolTest methodsFor: 'tests - element accessing'! 367285testAt 367286 "self debug: #testAt" 367287 " 367288 self assert: (self accessCollection at: 1) = 1. 367289 self assert: (self accessCollection at: 2) = 2. 367290 " 367291 | index | 367292 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 367293 self assert: (self moreThan4Elements at: index) = self elementInForElementAccessing! ! 367294 367295!SymbolTest methodsFor: 'tests - element accessing'! 367296testAtAll 367297 "self debug: #testAtAll" 367298 " self flag: #theCollectionshouldbe102030intheFixture. 367299 367300 self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. 367301 self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." 367302 | result | 367303 result := self moreThan4Elements atAll: #(2 1 2 ). 367304 self assert: (result at: 1) = (self moreThan4Elements at: 2). 367305 self assert: (result at: 2) = (self moreThan4Elements at: 1). 367306 self assert: (result at: 3) = (self moreThan4Elements at: 2). 367307 self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! 367308 367309!SymbolTest methodsFor: 'tests - element accessing'! 367310testAtIfAbsent 367311 "self debug: #testAt" 367312 | absent | 367313 absent := false. 367314 self moreThan4Elements 367315 at: self moreThan4Elements size + 1 367316 ifAbsent: [ absent := true ]. 367317 self assert: absent = true. 367318 absent := false. 367319 self moreThan4Elements 367320 at: self moreThan4Elements size 367321 ifAbsent: [ absent := true ]. 367322 self assert: absent = false! ! 367323 367324!SymbolTest methodsFor: 'tests - element accessing'! 367325testAtLast 367326 "self debug: #testAtLast" 367327 | index | 367328 self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. 367329 "tmp:=1. 367330 self do: 367331 [:each | 367332 each =self elementInForIndexAccessing 367333 ifTrue:[index:=tmp]. 367334 tmp:=tmp+1]." 367335 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 367336 self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! 367337 367338!SymbolTest methodsFor: 'tests - element accessing'! 367339testAtLastError 367340 "self debug: #testAtLast" 367341 self 367342 should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] 367343 raise: Error! ! 367344 367345!SymbolTest methodsFor: 'tests - element accessing'! 367346testAtLastIfAbsent 367347 "self debug: #testAtLastIfAbsent" 367348 self assert: (self moreThan4Elements 367349 atLast: 1 367350 ifAbsent: [ nil ]) = self moreThan4Elements last. 367351 self assert: (self moreThan4Elements 367352 atLast: self moreThan4Elements size + 1 367353 ifAbsent: [ 222 ]) = 222! ! 367354 367355!SymbolTest methodsFor: 'tests - element accessing'! 367356testAtOutOfBounds 367357 "self debug: #testAtOutOfBounds" 367358 self 367359 should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] 367360 raise: Error. 367361 self 367362 should: [ self moreThan4Elements at: -1 ] 367363 raise: Error! ! 367364 367365!SymbolTest methodsFor: 'tests - element accessing'! 367366testAtPin 367367 "self debug: #testAtPin" 367368 self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. 367369 self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. 367370 self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! 367371 367372!SymbolTest methodsFor: 'tests - element accessing'! 367373testAtRandom 367374 | result | 367375 result := self nonEmpty atRandom . 367376 self assert: (self nonEmpty includes: result).! ! 367377 367378!SymbolTest methodsFor: 'tests - element accessing'! 367379testAtWrap 367380 "self debug: #testAt" 367381 " 367382 self assert: (self accessCollection at: 1) = 1. 367383 self assert: (self accessCollection at: 2) = 2. 367384 " 367385 | index | 367386 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 367387 self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. 367388 self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. 367389 self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. 367390 self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! 367391 367392!SymbolTest methodsFor: 'tests - element accessing'! 367393testBefore 367394 "self debug: #testBefore" 367395 self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). 367396 self 367397 should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] 367398 raise: Error. 367399 self 367400 should: [ self moreThan4Elements before: 66 ] 367401 raise: Error! ! 367402 367403!SymbolTest methodsFor: 'tests - element accessing'! 367404testBeforeIfAbsent 367405 "self debug: #testBefore" 367406 self assert: (self moreThan4Elements 367407 before: (self moreThan4Elements at: 1) 367408 ifAbsent: [ 99 ]) = 99. 367409 self assert: (self moreThan4Elements 367410 before: (self moreThan4Elements at: 2) 367411 ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! 367412 367413!SymbolTest methodsFor: 'tests - element accessing'! 367414testFirstSecondThird 367415 "self debug: #testFirstSecondThird" 367416 self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). 367417 self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). 367418 self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). 367419 self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! 367420 367421!SymbolTest methodsFor: 'tests - element accessing'! 367422testLast 367423 "self debug: #testLast" 367424 self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! 367425 367426!SymbolTest methodsFor: 'tests - element accessing'! 367427testMiddle 367428 "self debug: #testMiddle" 367429 self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! 367430 367431 367432!SymbolTest methodsFor: 'tests - equality'! 367433testEqualSignForSequenceableCollections 367434 "self debug: #testEqualSign" 367435 367436 self deny: (self nonEmpty = self nonEmpty asSet). 367437 self deny: (self nonEmpty reversed = self nonEmpty). 367438 self deny: (self nonEmpty = self nonEmpty reversed).! ! 367439 367440!SymbolTest methodsFor: 'tests - equality'! 367441testHasEqualElements 367442 "self debug: #testHasEqualElements" 367443 367444 self deny: (self empty hasEqualElements: self nonEmpty). 367445 self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). 367446 self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). 367447 self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! 367448 367449!SymbolTest methodsFor: 'tests - equality'! 367450testHasEqualElementsIsTrueForNonIdenticalButEqualCollections 367451 "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" 367452 367453 self assert: (self empty hasEqualElements: self empty copy). 367454 self assert: (self empty copy hasEqualElements: self empty). 367455 self assert: (self empty copy hasEqualElements: self empty copy). 367456 367457 self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). 367458 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). 367459 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! 367460 367461!SymbolTest methodsFor: 'tests - equality'! 367462testHasEqualElementsOfIdenticalCollectionObjects 367463 "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" 367464 367465 self assert: (self empty hasEqualElements: self empty). 367466 self assert: (self nonEmpty hasEqualElements: self nonEmpty). 367467 ! ! 367468 367469 367470!SymbolTest methodsFor: 'tests - fixture'! 367471howMany: subCollection in: collection 367472" return an integer representing how many time 'subCollection' appears in 'collection' " 367473 | tmp nTime | 367474 tmp:= collection. 367475 nTime:= 0. 367476 367477 [tmp isEmpty ]whileFalse: 367478 [ 367479 (tmp beginsWith: subCollection) 367480 ifTrue: [ 367481 nTime := nTime + 1. 367482 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] 367483 ] 367484 ifFalse: [tmp := tmp copyWithoutFirst.] 367485 ]. 367486 367487 ^ nTime. 367488 ! ! 367489 367490!SymbolTest methodsFor: 'tests - fixture'! 367491test0CopyTest 367492 self shouldnt: [ self empty ]raise: Error. 367493 self assert: self empty size = 0. 367494 self shouldnt: [ self nonEmpty ]raise: Error. 367495 self assert: (self nonEmpty size = 0) not. 367496 self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. 367497 self assert: (self collectionWithElementsToRemove size = 0) not. 367498 self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. 367499 367500 self shouldnt: [ self elementToAdd ]raise: Error. 367501 self deny: (self nonEmpty includes: self elementToAdd ). 367502 self shouldnt: [ self collectionNotIncluded ]raise: Error. 367503 self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! 367504 367505!SymbolTest methodsFor: 'tests - fixture'! 367506test0FixtureAsStringCommaAndDelimiterTest 367507 367508 self shouldnt: [self nonEmpty] raise:Error . 367509 self deny: self nonEmpty isEmpty. 367510 367511 self shouldnt: [self empty] raise:Error . 367512 self assert: self empty isEmpty. 367513 367514 self shouldnt: [self nonEmpty1Element ] raise:Error . 367515 self assert: self nonEmpty1Element size=1.! ! 367516 367517!SymbolTest methodsFor: 'tests - fixture'! 367518test0FixtureBeginsEndsWithTest 367519 367520 self shouldnt: [self nonEmpty ] raise: Error. 367521 self deny: self nonEmpty isEmpty. 367522 self assert: self nonEmpty size>1. 367523 367524 self shouldnt: [self empty ] raise: Error. 367525 self assert: self empty isEmpty.! ! 367526 367527!SymbolTest methodsFor: 'tests - fixture'! 367528test0FixtureCloneTest 367529 367530self shouldnt: [ self nonEmpty ] raise: Error. 367531self deny: self nonEmpty isEmpty. 367532 367533self shouldnt: [ self empty ] raise: Error. 367534self assert: self empty isEmpty. 367535 367536! ! 367537 367538!SymbolTest methodsFor: 'tests - fixture'! 367539test0FixtureConverAsSortedTest 367540 367541 self shouldnt: [self collectionWithSortableElements ] raise: Error. 367542 self deny: self collectionWithSortableElements isEmpty .! ! 367543 367544!SymbolTest methodsFor: 'tests - fixture'! 367545test0FixtureCopyPartOfForMultipliness 367546 367547self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. 367548 367549self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 367550 367551self assert: self collectionWithSameAtEndAndBegining size > 1. 367552 3675531 to: self collectionWithSameAtEndAndBegining size do: 367554 [:i | 367555 (i > 1 ) & (i < self collectionWithSameAtEndAndBegining size) 367556 ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at:i) = (self collectionWithSameAtEndAndBegining first)]. 367557 ]! ! 367558 367559!SymbolTest methodsFor: 'tests - fixture'! 367560test0FixtureCopyPartOfSequenceableTest 367561 367562 self shouldnt: [self collectionWithoutEqualsElements ] raise: Error. 367563 self collectionWithoutEqualsElements do: 367564 [:each | self assert: (self collectionWithoutEqualsElements occurrencesOf: each)=1]. 367565 367566 self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. 367567 self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualsElements size. 367568 367569 self shouldnt: [self empty] raise: Error. 367570 self assert: self empty isEmpty .! ! 367571 367572!SymbolTest methodsFor: 'tests - fixture'! 367573test0FixtureCopySameContentsTest 367574 367575 self shouldnt: [self nonEmpty ] raise: Error. 367576 self deny: self nonEmpty isEmpty. 367577 367578 self shouldnt: [self empty ] raise: Error. 367579 self assert: self empty isEmpty. 367580 367581! ! 367582 367583!SymbolTest methodsFor: 'tests - fixture'! 367584test0FixtureCopyWithOrWithoutSpecificElementsTest 367585 367586 self shouldnt: [self nonEmpty ] raise: Error. 367587 self deny: self nonEmpty isEmpty . 367588 367589 self shouldnt: [self indexInNonEmpty ] raise: Error. 367590 self assert: self indexInNonEmpty > 0. 367591 self assert: self indexInNonEmpty <= self nonEmpty size.! ! 367592 367593!SymbolTest methodsFor: 'tests - fixture'! 367594test0FixtureCopyWithReplacementTest 367595 367596 self shouldnt: [self replacementCollection ]raise: Error. 367597 self shouldnt: [self oldSubCollection] raise: Error. 367598 367599 self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. 367600 self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. 367601 367602 ! ! 367603 367604!SymbolTest methodsFor: 'tests - fixture'! 367605test0FixtureIncludeTest 367606 | elementIn | 367607 self shouldnt: [ self nonEmpty ]raise: Error. 367608 self deny: self nonEmpty isEmpty. 367609 367610 self shouldnt: [ self elementNotIn ]raise: Error. 367611 367612 elementIn := true. 367613 self nonEmpty detect: 367614 [ :each | each = self elementNotIn ] 367615 ifNone: [ elementIn := false ]. 367616 self assert: elementIn = false. 367617 367618 self shouldnt: [ self anotherElementNotIn ]raise: Error. 367619 367620 elementIn := true. 367621 self nonEmpty detect: 367622 [ :each | each = self anotherElementNotIn ] 367623 ifNone: [ elementIn := false ]. 367624 self assert: elementIn = false. 367625 367626 self shouldnt: [ self empty ] raise: Error. 367627 self assert: self empty isEmpty. 367628 367629! ! 367630 367631!SymbolTest methodsFor: 'tests - fixture'! 367632test0FixtureIndexAccessFotMultipliness 367633 self 367634 shouldnt: [ self collectionWithSameAtEndAndBegining ] 367635 raise: Error. 367636 self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 367637 self assert: self collectionWithSameAtEndAndBegining size > 1. 367638 1 to: self collectionWithSameAtEndAndBegining size 367639 do: 367640 [ :i | 367641 i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: 367642 [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! 367643 367644!SymbolTest methodsFor: 'tests - fixture'! 367645test0FixtureIndexAccessTest 367646 | res collection element | 367647 self 367648 shouldnt: [ self collectionMoreThan1NoDuplicates ] 367649 raise: Error. 367650 self assert: self collectionMoreThan1NoDuplicates size >1. 367651 res := true. 367652 self collectionMoreThan1NoDuplicates 367653 detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] 367654 ifNone: [ res := false ]. 367655 self assert: res = false. 367656 self 367657 shouldnt: [ self elementInForIndexAccessing ] 367658 raise: Error. 367659 self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). 367660 self 367661 shouldnt: [ self elementNotInForIndexAccessing ] 367662 raise: Error. 367663 self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! 367664 367665!SymbolTest methodsFor: 'tests - fixture'! 367666test0FixtureIterateSequencedReadableTest 367667 367668 | res | 367669 367670 self shouldnt: self nonEmptyMoreThan1Element raise: Error. 367671 self assert: self nonEmptyMoreThan1Element size > 1. 367672 367673 367674 self shouldnt: self empty raise: Error. 367675 self assert: self empty isEmpty . 367676 367677 res := true. 367678 self nonEmptyMoreThan1Element 367679 detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] 367680 ifNone: [ res := false ]. 367681 self assert: res = false.! ! 367682 367683!SymbolTest methodsFor: 'tests - fixture'! 367684test0FixtureOccurrencesForMultiplinessTest 367685 | cpt element collection | 367686 self shouldnt: [self collectionWithEqualElements ]raise: Error. 367687self shouldnt: [self collectionWithEqualElements ]raise: Error. 367688 367689self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 367690element := self elementTwiceInForOccurrences . 367691collection := self collectionWithEqualElements . 367692 367693cpt := 0 . 367694" testing with identity check ( == ) so that identy collections can use this trait : " 367695self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. 367696self assert: cpt = 2.! ! 367697 367698!SymbolTest methodsFor: 'tests - fixture'! 367699test0FixtureOccurrencesTest 367700 | tmp | 367701 self shouldnt: [self empty ]raise: Error. 367702 self assert: self empty isEmpty. 367703 367704 self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. 367705 self deny: self collectionWithoutEqualElements isEmpty. 367706 367707 tmp := OrderedCollection new. 367708 self collectionWithoutEqualElements do: [ 367709 :each | 367710 self deny: (tmp includes: each). 367711 tmp add: each. 367712 ]. 367713 367714 367715 self shouldnt: [ self elementNotInForOccurrences ] raise: Error. 367716 self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! 367717 367718!SymbolTest methodsFor: 'tests - fixture'! 367719test0FixturePrintTest 367720 367721 self shouldnt: [self nonEmpty ] raise: Error.! ! 367722 367723!SymbolTest methodsFor: 'tests - fixture'! 367724test0FixtureSequencedConcatenationTest 367725 self 367726 shouldnt: self empty 367727 raise: Exception. 367728 self assert: self empty isEmpty. 367729 self 367730 shouldnt: self firstCollection 367731 raise: Exception. 367732 self 367733 shouldnt: self secondCollection 367734 raise: Exception! ! 367735 367736!SymbolTest methodsFor: 'tests - fixture'! 367737test0FixtureSequencedElementAccessTest 367738 self 367739 shouldnt: [ self moreThan4Elements ] 367740 raise: Error. 367741 self assert: self moreThan4Elements size >= 4. 367742 self 367743 shouldnt: [ self subCollectionNotIn ] 367744 raise: Error. 367745 self subCollectionNotIn 367746 detect: [ :each | (self moreThan4Elements includes: each) not ] 367747 ifNone: [ self assert: false ]. 367748 self 367749 shouldnt: [ self elementNotInForElementAccessing ] 367750 raise: Error. 367751 self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). 367752 self 367753 shouldnt: [ self elementInForElementAccessing ] 367754 raise: Error. 367755 self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! 367756 367757!SymbolTest methodsFor: 'tests - fixture'! 367758test0FixtureSetAritmeticTest 367759 self 367760 shouldnt: [ self collection ] 367761 raise: Error. 367762 self deny: self collection isEmpty. 367763 self 367764 shouldnt: [ self nonEmpty ] 367765 raise: Error. 367766 self deny: self nonEmpty isEmpty. 367767 self 367768 shouldnt: [ self anotherElementOrAssociationNotIn ] 367769 raise: Error. 367770 self collection isDictionary 367771 ifTrue: 367772 [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] 367773 ifFalse: 367774 [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. 367775 self 367776 shouldnt: [ self collectionClass ] 367777 raise: Error! ! 367778 367779!SymbolTest methodsFor: 'tests - fixture'! 367780test0FixtureSubcollectionAccessTest 367781 self 367782 shouldnt: [ self moreThan3Elements ] 367783 raise: Error. 367784 self assert: self moreThan3Elements size > 2! ! 367785 367786!SymbolTest methodsFor: 'tests - fixture'! 367787test0FixtureTConvertAsSetForMultiplinessTest 367788 "a collection with equal elements:" 367789 | res | 367790 self shouldnt: [ self withEqualElements] raise: Error. 367791 367792 res := true. 367793 self withEqualElements 367794 detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] 367795 ifNone: [ res := false ]. 367796 self assert: res = true. 367797 367798! ! 367799 367800!SymbolTest methodsFor: 'tests - fixture'! 367801test0FixtureTConvertTest 367802 "a collection of number without equal elements:" 367803 | res | 367804 self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. 367805 367806 res := true. 367807 self collectionWithoutEqualElements 367808 detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] 367809 ifNone: [ res := false ]. 367810 self assert: res = false. 367811 367812 367813! ! 367814 367815!SymbolTest methodsFor: 'tests - fixture'! 367816test0TSequencedStructuralEqualityTest 367817 367818 self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! 367819 367820!SymbolTest methodsFor: 'tests - fixture'! 367821test0TStructuralEqualityTest 367822 self shouldnt: [self empty] raise: Error. 367823 self shouldnt: [self nonEmpty] raise: Error. 367824 self assert: self empty isEmpty. 367825 self deny: self nonEmpty isEmpty.! ! 367826 367827 367828!SymbolTest methodsFor: 'tests - includes'! 367829testIdentityIncludesNonSpecificComportement 367830 " test the same comportement than 'includes: ' " 367831 | collection | 367832 collection := self nonEmpty . 367833 367834 self deny: (collection identityIncludes: self elementNotIn ). 367835 self assert:(collection identityIncludes: collection anyOne) 367836! ! 367837 367838!SymbolTest methodsFor: 'tests - includes'! 367839testIncludesAllOfAllThere 367840 "self debug: #testIncludesAllOfAllThere'" 367841 self assert: (self empty includesAllOf: self empty). 367842 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 367843 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 367844 367845!SymbolTest methodsFor: 'tests - includes'! 367846testIncludesAllOfNoneThere 367847 "self debug: #testIncludesAllOfNoneThere'" 367848 self deny: (self empty includesAllOf: self nonEmpty ). 367849 self deny: (self nonEmpty includesAllOf: { self elementNotIn. self anotherElementNotIn })! ! 367850 367851!SymbolTest methodsFor: 'tests - includes'! 367852testIncludesAnyOfAllThere 367853 "self debug: #testIncludesAnyOfAllThere'" 367854 self deny: (self nonEmpty includesAnyOf: self empty). 367855 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 367856 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 367857 367858!SymbolTest methodsFor: 'tests - includes'! 367859testIncludesAnyOfNoneThere 367860 "self debug: #testIncludesAnyOfNoneThere'" 367861 self deny: (self nonEmpty includesAnyOf: self empty). 367862 self deny: (self nonEmpty includesAnyOf: { self elementNotIn. self anotherElementNotIn })! ! 367863 367864!SymbolTest methodsFor: 'tests - includes'! 367865testIncludesElementIsNotThere 367866 "self debug: #testIncludesElementIsNotThere" 367867 367868 self deny: (self nonEmpty includes: self elementNotIn). 367869 self assert: (self nonEmpty includes: self nonEmpty anyOne). 367870 self deny: (self empty includes: self elementNotIn)! ! 367871 367872!SymbolTest methodsFor: 'tests - includes'! 367873testIncludesElementIsThere 367874 "self debug: #testIncludesElementIsThere" 367875 367876 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 367877 367878 367879!SymbolTest methodsFor: 'tests - index access'! 367880testIdentityIndexOf 367881 "self debug: #testIdentityIndexOf" 367882 | collection element | 367883 collection := self collectionMoreThan1NoDuplicates. 367884 element := collection first. 367885 self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! 367886 367887!SymbolTest methodsFor: 'tests - index access'! 367888testIdentityIndexOfIAbsent 367889 | collection element | 367890 collection := self collectionMoreThan1NoDuplicates. 367891 element := collection first. 367892 self assert: (collection 367893 identityIndexOf: element 367894 ifAbsent: [ 0 ]) = 1. 367895 self assert: (collection 367896 identityIndexOf: self elementNotInForIndexAccessing 367897 ifAbsent: [ 55 ]) = 55! ! 367898 367899!SymbolTest methodsFor: 'tests - index access'! 367900testIndexOf 367901 "self debug: #testIndexOf" 367902 | tmp index collection | 367903 collection := self collectionMoreThan1NoDuplicates. 367904 tmp := collection size. 367905 collection reverseDo: 367906 [ :each | 367907 each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. 367908 tmp := tmp - 1 ]. 367909 self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! 367910 367911!SymbolTest methodsFor: 'tests - index access'! 367912testIndexOfIfAbsent 367913 "self debug: #testIndexOfIfAbsent" 367914 | collection | 367915 collection := self collectionMoreThan1NoDuplicates. 367916 self assert: (collection 367917 indexOf: collection first 367918 ifAbsent: [ 33 ]) = 1. 367919 self assert: (collection 367920 indexOf: self elementNotInForIndexAccessing 367921 ifAbsent: [ 33 ]) = 33! ! 367922 367923!SymbolTest methodsFor: 'tests - index access'! 367924testIndexOfStartingAt 367925 "self debug: #testLastIndexOf" 367926 | element collection | 367927 collection := self collectionMoreThan1NoDuplicates. 367928 element := collection first. 367929 self assert: (collection 367930 indexOf: element 367931 startingAt: 2 367932 ifAbsent: [ 99 ]) = 99. 367933 self assert: (collection 367934 indexOf: element 367935 startingAt: 1 367936 ifAbsent: [ 99 ]) = 1. 367937 self assert: (collection 367938 indexOf: self elementNotInForIndexAccessing 367939 startingAt: 1 367940 ifAbsent: [ 99 ]) = 99! ! 367941 367942!SymbolTest methodsFor: 'tests - index access'! 367943testIndexOfStartingAtIfAbsent 367944 "self debug: #testLastIndexOf" 367945 | element collection | 367946 collection := self collectionMoreThan1NoDuplicates. 367947 element := collection first. 367948 self assert: (collection 367949 indexOf: element 367950 startingAt: 2 367951 ifAbsent: [ 99 ]) = 99. 367952 self assert: (collection 367953 indexOf: element 367954 startingAt: 1 367955 ifAbsent: [ 99 ]) = 1. 367956 self assert: (collection 367957 indexOf: self elementNotInForIndexAccessing 367958 startingAt: 1 367959 ifAbsent: [ 99 ]) = 99! ! 367960 367961!SymbolTest methodsFor: 'tests - index access'! 367962testIndexOfSubCollectionStartingAt 367963 "self debug: #testIndexOfIfAbsent" 367964 | subcollection index collection | 367965 collection := self collectionMoreThan1NoDuplicates. 367966 subcollection := self collectionMoreThan1NoDuplicates. 367967 index := collection 367968 indexOfSubCollection: subcollection 367969 startingAt: 1. 367970 self assert: index = 1. 367971 index := collection 367972 indexOfSubCollection: subcollection 367973 startingAt: 2. 367974 self assert: index = 0! ! 367975 367976!SymbolTest methodsFor: 'tests - index access'! 367977testIndexOfSubCollectionStartingAtIfAbsent 367978 "self debug: #testIndexOfIfAbsent" 367979 | index absent subcollection collection | 367980 collection := self collectionMoreThan1NoDuplicates. 367981 subcollection := self collectionMoreThan1NoDuplicates. 367982 absent := false. 367983 index := collection 367984 indexOfSubCollection: subcollection 367985 startingAt: 1 367986 ifAbsent: [ absent := true ]. 367987 self assert: absent = false. 367988 absent := false. 367989 index := collection 367990 indexOfSubCollection: subcollection 367991 startingAt: 2 367992 ifAbsent: [ absent := true ]. 367993 self assert: absent = true! ! 367994 367995!SymbolTest methodsFor: 'tests - index access'! 367996testLastIndexOf 367997 "self debug: #testLastIndexOf" 367998 | element collection | 367999 collection := self collectionMoreThan1NoDuplicates. 368000 element := collection first. 368001 self assert: (collection lastIndexOf: element) = 1. 368002 self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! 368003 368004!SymbolTest methodsFor: 'tests - index access'! 368005testLastIndexOfIfAbsent 368006 "self debug: #testIndexOfIfAbsent" 368007 | element collection | 368008 collection := self collectionMoreThan1NoDuplicates. 368009 element := collection first. 368010 self assert: (collection 368011 lastIndexOf: element 368012 ifAbsent: [ 99 ]) = 1. 368013 self assert: (collection 368014 lastIndexOf: self elementNotInForIndexAccessing 368015 ifAbsent: [ 99 ]) = 99! ! 368016 368017!SymbolTest methodsFor: 'tests - index access'! 368018testLastIndexOfStartingAt 368019 "self debug: #testLastIndexOf" 368020 | element collection | 368021 collection := self collectionMoreThan1NoDuplicates. 368022 element := collection last. 368023 self assert: (collection 368024 lastIndexOf: element 368025 startingAt: collection size 368026 ifAbsent: [ 99 ]) = collection size. 368027 self assert: (collection 368028 lastIndexOf: element 368029 startingAt: collection size - 1 368030 ifAbsent: [ 99 ]) = 99. 368031 self assert: (collection 368032 lastIndexOf: self elementNotInForIndexAccessing 368033 startingAt: collection size 368034 ifAbsent: [ 99 ]) = 99! ! 368035 368036 368037!SymbolTest methodsFor: 'tests - index accessing for multipliness'! 368038testIndexOfDuplicate 368039 "self debug: #testIndexOf" 368040 | collection element | 368041 collection := self collectionWithSameAtEndAndBegining. 368042 element := collection last. 368043 368044 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 368045 'indexOf: should return the position of the first occurrence :'" 368046 self assert: (collection indexOf: element) = 1! ! 368047 368048!SymbolTest methodsFor: 'tests - index accessing for multipliness'! 368049testIndexOfIfAbsentDuplicate 368050 "self debug: #testIndexOfIfAbsent" 368051 | collection element | 368052 collection := self collectionWithSameAtEndAndBegining. 368053 element := collection last. 368054 368055 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 368056 'indexOf:ifAbsent: should return the position of the first occurrence :'" 368057 self assert: (collection 368058 indexOf: element 368059 ifAbsent: [ 55 ]) = 1! ! 368060 368061!SymbolTest methodsFor: 'tests - index accessing for multipliness'! 368062testIndexOfStartingAtDuplicate 368063 "self debug: #testLastIndexOf" 368064 | collection element | 368065 collection := self collectionWithSameAtEndAndBegining. 368066 element := collection last. 368067 368068 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 368069 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" 368070 self assert: (collection 368071 indexOf: element 368072 startingAt: 1 368073 ifAbsent: [ 55 ]) = 1. 368074 self assert: (collection 368075 indexOf: element 368076 startingAt: 2 368077 ifAbsent: [ 55 ]) = collection size! ! 368078 368079!SymbolTest methodsFor: 'tests - index accessing for multipliness'! 368080testLastIndexOfDuplicate 368081 "self debug: #testLastIndexOf" 368082 | collection element | 368083 collection := self collectionWithSameAtEndAndBegining. 368084 element := collection first. 368085 368086 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 368087 'lastIndexOf: should return the position of the last occurrence :'" 368088 self assert: (collection lastIndexOf: element) = collection size! ! 368089 368090!SymbolTest methodsFor: 'tests - index accessing for multipliness'! 368091testLastIndexOfIfAbsentDuplicate 368092 "self debug: #testIndexOfIfAbsent" 368093 "self debug: #testLastIndexOf" 368094 | collection element | 368095 collection := self collectionWithSameAtEndAndBegining. 368096 element := collection first. 368097 368098 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 368099 'lastIndexOf: should return the position of the last occurrence :'" 368100 self assert: (collection 368101 lastIndexOf: element 368102 ifAbsent: [ 55 ]) = collection size! ! 368103 368104!SymbolTest methodsFor: 'tests - index accessing for multipliness'! 368105testLastIndexOfStartingAtDuplicate 368106 "self debug: #testLastIndexOf" 368107 | collection element | 368108 collection := self collectionWithSameAtEndAndBegining. 368109 element := collection last. 368110 368111 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 368112 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" 368113 self assert: (collection 368114 lastIndexOf: element 368115 startingAt: collection size 368116 ifAbsent: [ 55 ]) = collection size. 368117 self assert: (collection 368118 lastIndexOf: element 368119 startingAt: collection size - 1 368120 ifAbsent: [ 55 ]) = 1! ! 368121 368122 368123!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368124testAllButFirstDo 368125 368126 | result | 368127 result:= OrderedCollection new. 368128 368129 self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 368130 368131 1 to: (result size) do: 368132 [:i| 368133 self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. 368134 368135 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 368136 368137!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368138testAllButLastDo 368139 368140 | result | 368141 result:= OrderedCollection new. 368142 368143 self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 368144 368145 1 to: (result size) do: 368146 [:i| 368147 self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. 368148 368149 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 368150 368151!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368152testCollectFromTo 368153 368154 | result | 368155 result:=self nonEmptyMoreThan1Element 368156 collect: [ :each | each ] 368157 from: 1 368158 to: (self nonEmptyMoreThan1Element size - 1). 368159 368160 1 to: result size 368161 do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. 368162 self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! 368163 368164!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368165testDetectSequenced 368166" testing that detect keep the first element returning true for sequenceable collections " 368167 368168 | element result | 368169 element := self nonEmptyMoreThan1Element at:1. 368170 result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. 368171 self assert: result = element. ! ! 368172 368173!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368174testDo! ! 368175 368176!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368177testFindFirst 368178 368179 | element result | 368180 element := self nonEmptyMoreThan1Element at:1. 368181 result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. 368182 368183 self assert: result=1. ! ! 368184 368185!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368186testFindFirstNotIn 368187 368188 | result | 368189 368190 result:=self empty findFirst: [:each | true]. 368191 368192 self assert: result=0. ! ! 368193 368194!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368195testFindLast 368196 368197 | element result | 368198 element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. 368199 result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. 368200 368201 self assert: result=self nonEmptyMoreThan1Element size. ! ! 368202 368203!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368204testFindLastNotIn 368205 368206 | result | 368207 368208 result:=self empty findFirst: [:each | true]. 368209 368210 self assert: result=0. ! ! 368211 368212!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368213testFromToDo 368214 368215 | result | 368216 result:= OrderedCollection new. 368217 368218 self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 368219 368220 1 to: (self nonEmptyMoreThan1Element size -1) do: 368221 [:i| 368222 self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. 368223 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 368224 368225!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368226testKeysAndValuesDo 368227 "| result | 368228 result:= OrderedCollection new. 368229 368230 self nonEmptyMoreThan1Element keysAndValuesDo: 368231 [:i :value| 368232 result add: (value+i)]. 368233 368234 1 to: result size do: 368235 [:i| 368236 self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" 368237 | indexes elements | 368238 indexes:= OrderedCollection new. 368239 elements := OrderedCollection new. 368240 368241 self nonEmptyMoreThan1Element keysAndValuesDo: 368242 [:i :value| 368243 indexes add: (i). 368244 elements add: value]. 368245 368246 (1 to: self nonEmptyMoreThan1Element size )do: 368247 [ :i | 368248 self assert: (indexes at: i) = i. 368249 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 368250 ]. 368251 368252 self assert: indexes size = elements size. 368253 self assert: indexes size = self nonEmptyMoreThan1Element size . 368254 368255 ! ! 368256 368257!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368258testKeysAndValuesDoEmpty 368259 | result | 368260 result:= OrderedCollection new. 368261 368262 self empty keysAndValuesDo: 368263 [:i :value| 368264 result add: (value+i)]. 368265 368266 self assert: result isEmpty .! ! 368267 368268!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368269testPairsCollect 368270 368271 | index result | 368272 index:=0. 368273 368274 result:=self nonEmptyMoreThan1Element pairsCollect: 368275 [:each1 :each2 | 368276 self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). 368277 (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). 368278 ]. 368279 368280 result do: 368281 [:each | self assert: each = true]. 368282 368283! ! 368284 368285!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368286testPairsDo 368287 | index | 368288 index:=1. 368289 368290 self nonEmptyMoreThan1Element pairsDo: 368291 [:each1 :each2 | 368292 self assert:(self nonEmptyMoreThan1Element at:index)=each1. 368293 self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. 368294 index:=index+2]. 368295 368296 self nonEmptyMoreThan1Element size odd 368297 ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] 368298 ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! 368299 368300!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368301testReverseDo 368302 | result | 368303 result:= OrderedCollection new. 368304 self nonEmpty reverseDo: [: each | result add: each]. 368305 368306 1 to: result size do: 368307 [:i| 368308 self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! 368309 368310!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368311testReverseDoEmpty 368312 | result | 368313 result:= OrderedCollection new. 368314 self empty reverseDo: [: each | result add: each]. 368315 368316 self assert: result isEmpty .! ! 368317 368318!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368319testReverseWithDo 368320 368321 | secondCollection result index | 368322 result:= OrderedCollection new. 368323 index := self nonEmptyMoreThan1Element size + 1. 368324 secondCollection:= self nonEmptyMoreThan1Element copy. 368325 368326 self nonEmptyMoreThan1Element reverseWith: secondCollection do: 368327 [:a :b | 368328 self assert: (self nonEmptyMoreThan1Element indexOf: a ) = (index := index - 1 ). 368329 result add: (a = b)]. 368330 368331 1 to: result size do: 368332 [:i| 368333 self assert: (result at:i)=(true)]. 368334 self assert: result size = self nonEmptyMoreThan1Element size.! ! 368335 368336!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368337testWithCollect 368338 368339 | result newCollection index collection | 368340 368341 index := 0. 368342 collection := self nonEmptyMoreThan1Element . 368343 newCollection := collection copy. 368344 result:=collection with: newCollection collect: [:a :b | 368345 self assert: (collection indexOf: a ) = ( index := index + 1). 368346 self assert: (a = b). 368347 b]. 368348 368349 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 368350 self assert: result size = collection size.! ! 368351 368352!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368353testWithCollectError 368354 self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! 368355 368356!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368357testWithDo 368358 368359 | secondCollection result index | 368360 result:= OrderedCollection new. 368361 secondCollection:= self nonEmptyMoreThan1Element copy. 368362 index := 0. 368363 368364 self nonEmptyMoreThan1Element with: secondCollection do: 368365 [:a :b | 368366 self assert: (self nonEmptyMoreThan1Element indexOf: a) = ( index := index + 1). 368367 result add: (a =b)]. 368368 368369 1 to: result size do: 368370 [:i| 368371 self assert: (result at:i)=(true)]. 368372 self assert: result size = self nonEmptyMoreThan1Element size.! ! 368373 368374!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368375testWithDoError 368376 368377 self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! 368378 368379!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368380testWithIndexCollect 368381 368382 | result index collection | 368383 index := 0. 368384 collection := self nonEmptyMoreThan1Element . 368385 result := collection withIndexCollect: [:each :i | 368386 self assert: i = (index := index + 1). 368387 self assert: i = (collection indexOf: each) . 368388 each] . 368389 368390 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 368391 self assert: result size = collection size.! ! 368392 368393!SymbolTest methodsFor: 'tests - iterate on sequenced reable collections'! 368394testWithIndexDo 368395 368396 "| result | 368397 result:=Array new: self nonEmptyMoreThan1Element size. 368398 self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 368399 368400 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" 368401 | indexes elements | 368402 indexes:= OrderedCollection new. 368403 elements := OrderedCollection new. 368404 368405 self nonEmptyMoreThan1Element withIndexDo: 368406 [:value :i | 368407 indexes add: (i). 368408 elements add: value]. 368409 368410 (1 to: self nonEmptyMoreThan1Element size )do: 368411 [ :i | 368412 self assert: (indexes at: i) = i. 368413 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 368414 ]. 368415 368416 self assert: indexes size = elements size. 368417 self assert: indexes size = self nonEmptyMoreThan1Element size . 368418 ! ! 368419 368420 368421!SymbolTest methodsFor: 'tests - occurrencesOf'! 368422testOccurrencesOf 368423 | collection | 368424 collection := self collectionWithoutEqualElements . 368425 368426 collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! 368427 368428!SymbolTest methodsFor: 'tests - occurrencesOf'! 368429testOccurrencesOfEmpty 368430 | result | 368431 result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). 368432 self assert: result = 0! ! 368433 368434!SymbolTest methodsFor: 'tests - occurrencesOf'! 368435testOccurrencesOfNotIn 368436 | result | 368437 result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. 368438 self assert: result = 0! ! 368439 368440 368441!SymbolTest methodsFor: 'tests - occurrencesOf for multipliness'! 368442testOccurrencesOfForMultipliness 368443 368444| collection element | 368445collection := self collectionWithEqualElements . 368446element := self elementTwiceInForOccurrences . 368447 368448self assert: (collection occurrencesOf: element ) = 2. ! ! 368449 368450 368451!SymbolTest methodsFor: 'tests - printing'! 368452testPrintElementsOn 368453 368454 | aStream result allElementsAsString | 368455 result:=''. 368456 aStream:= ReadWriteStream on: result. 368457 368458 self nonEmpty printElementsOn: aStream . 368459 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 368460 1 to: allElementsAsString size do: 368461 [:i | 368462 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 368463 ].! ! 368464 368465!SymbolTest methodsFor: 'tests - printing'! 368466testPrintNameOn 368467 368468 | aStream result | 368469 result:=''. 368470 aStream:= ReadWriteStream on: result. 368471 368472 self nonEmpty printNameOn: aStream . 368473 Transcript show: result asString. 368474 self nonEmpty class name first isVowel 368475 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 368476 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 368477 368478!SymbolTest methodsFor: 'tests - printing'! 368479testPrintOn 368480 | aStream result allElementsAsString | 368481 result:=''. 368482 aStream:= ReadWriteStream on: result. 368483 368484 self nonEmpty printOn: aStream . 368485 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 368486 1 to: allElementsAsString size do: 368487 [:i | 368488 i=1 368489 ifTrue:[ 368490 self accessCollection class name first isVowel 368491 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 368492 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 368493 i=2 368494 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 368495 i>2 368496 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. 368497 ].! ! 368498 368499!SymbolTest methodsFor: 'tests - printing'! 368500testPrintOnDelimiter 368501 | aStream result allElementsAsString | 368502 result:=''. 368503 aStream:= ReadWriteStream on: result. 368504 368505 self nonEmpty printOn: aStream delimiter: ', ' . 368506 368507 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 368508 1 to: allElementsAsString size do: 368509 [:i | 368510 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 368511 ].! ! 368512 368513!SymbolTest methodsFor: 'tests - printing'! 368514testPrintOnDelimiterLast 368515 368516 | aStream result allElementsAsString | 368517 result:=''. 368518 aStream:= ReadWriteStream on: result. 368519 368520 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 368521 368522 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 368523 1 to: allElementsAsString size do: 368524 [:i | 368525 i<(allElementsAsString size-1 ) 368526 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 368527 i=(allElementsAsString size-1) 368528 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 368529 i=(allElementsAsString size) 368530 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 368531 ].! ! 368532 368533!SymbolTest methodsFor: 'tests - printing'! 368534testStoreOn 368535" for the moment work only for collection that include simple elements such that Integer" 368536 368537"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 368538string := ''. 368539str := ReadWriteStream on: string. 368540elementsAsStringExpected := OrderedCollection new. 368541elementsAsStringObtained := OrderedCollection new. 368542self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 368543 368544self nonEmpty storeOn: str. 368545result := str contents . 368546cuttedResult := ( result findBetweenSubStrs: ';' ). 368547 368548index := 1. 368549 368550cuttedResult do: 368551 [ :each | 368552 index = 1 368553 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 368554 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 368555 elementsAsStringObtained add: tmp. 368556 index := index + 1. ] 368557 ifFalse: [ 368558 index < cuttedResult size 368559 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 368560 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 368561 elementsAsStringObtained add: tmp. 368562 index := index + 1.] 368563 ifFalse: [self assert: ( each = ' yourself)' ) ]. 368564 ] 368565 368566 ]. 368567 368568 368569 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 368570 368571! ! 368572 368573 368574!SymbolTest methodsFor: 'tests - set arithmetic'! 368575containsAll: union of: one andOf: another 368576 368577 self assert: (one allSatisfy: [:each | union includes: each]). 368578 self assert: (another allSatisfy: [:each | union includes: each])! ! 368579 368580!SymbolTest methodsFor: 'tests - set arithmetic'! 368581numberOfSimilarElementsInIntersection 368582 ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! 368583 368584!SymbolTest methodsFor: 'tests - set arithmetic'! 368585testDifference 368586 "Answer the set theoretic difference of two collections." 368587 "self debug: #testDifference" 368588 368589 self assert: (self collection difference: self collection) isEmpty. 368590 self assert: (self empty difference: self collection) isEmpty. 368591 self assert: (self collection difference: self empty) = self collection 368592! ! 368593 368594!SymbolTest methodsFor: 'tests - set arithmetic'! 368595testDifferenceWithSeparateCollection 368596 "Answer the set theoretic difference of two collections." 368597 "self debug: #testDifferenceWithSeparateCollection" 368598 | res separateCol | 368599 separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. 368600 res := self collection difference: separateCol. 368601 self deny: (res includes: self anotherElementOrAssociationNotIn). 368602 self assert: res = self collection. 368603 res := separateCol difference: self collection. 368604 self deny: (res includes: self collection anyOne). 368605 self assert: res = separateCol! ! 368606 368607!SymbolTest methodsFor: 'tests - set arithmetic'! 368608testIntersectionBasic 368609 "self debug: #testIntersectionBasic" 368610 | inter | 368611 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 368612 self deny: inter isEmpty. 368613 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 368614 368615!SymbolTest methodsFor: 'tests - set arithmetic'! 368616testIntersectionEmpty 368617 "self debug: #testIntersectionEmpty" 368618 368619 | inter | 368620 inter := self empty intersection: self empty. 368621 self assert: inter isEmpty. 368622 inter := self empty intersection: self collection . 368623 self assert: inter = self empty. 368624 ! ! 368625 368626!SymbolTest methodsFor: 'tests - set arithmetic'! 368627testIntersectionItself 368628 "self debug: #testIntersectionItself" 368629 368630 self assert: (self collection intersection: self collection) = self collection. 368631 ! ! 368632 368633!SymbolTest methodsFor: 'tests - set arithmetic'! 368634testIntersectionTwoSimilarElementsInIntersection 368635 "self debug: #testIntersectionBasic" 368636 | inter | 368637 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 368638 self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. 368639 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 368640 368641!SymbolTest methodsFor: 'tests - set arithmetic'! 368642testUnion 368643 "self debug: #testUnionOfEmpties" 368644 368645 | union | 368646 union := self empty union: self nonEmpty. 368647 self containsAll: union of: self empty andOf: self nonEmpty. 368648 union := self nonEmpty union: self empty. 368649 self containsAll: union of: self empty andOf: self nonEmpty. 368650 union := self collection union: self nonEmpty. 368651 self containsAll: union of: self collection andOf: self nonEmpty.! ! 368652 368653!SymbolTest methodsFor: 'tests - set arithmetic'! 368654testUnionOfEmpties 368655 "self debug: #testUnionOfEmpties" 368656 368657 self assert: (self empty union: self empty) isEmpty. 368658 368659 ! ! 368660 368661 368662!SymbolTest methodsFor: 'tests - subcollections access'! 368663testAllButFirst 368664 "self debug: #testAllButFirst" 368665 | abf col | 368666 col := self moreThan3Elements. 368667 abf := col allButFirst. 368668 self deny: abf first = col first. 368669 self assert: abf size + 1 = col size! ! 368670 368671!SymbolTest methodsFor: 'tests - subcollections access'! 368672testAllButFirstNElements 368673 "self debug: #testAllButFirst" 368674 | abf col | 368675 col := self moreThan3Elements. 368676 abf := col allButFirst: 2. 368677 1 368678 to: abf size 368679 do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. 368680 self assert: abf size + 2 = col size! ! 368681 368682!SymbolTest methodsFor: 'tests - subcollections access'! 368683testAllButLast 368684 "self debug: #testAllButLast" 368685 | abf col | 368686 col := self moreThan3Elements. 368687 abf := col allButLast. 368688 self deny: abf last = col last. 368689 self assert: abf size + 1 = col size! ! 368690 368691!SymbolTest methodsFor: 'tests - subcollections access'! 368692testAllButLastNElements 368693 "self debug: #testAllButFirst" 368694 | abf col | 368695 col := self moreThan3Elements. 368696 abf := col allButLast: 2. 368697 1 368698 to: abf size 368699 do: [ :i | self assert: (abf at: i) = (col at: i) ]. 368700 self assert: abf size + 2 = col size! ! 368701 368702!SymbolTest methodsFor: 'tests - subcollections access'! 368703testFirstNElements 368704 "self debug: #testFirstNElements" 368705 | result | 368706 result := self moreThan3Elements first: self moreThan3Elements size - 1. 368707 1 368708 to: result size 368709 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. 368710 self assert: result size = (self moreThan3Elements size - 1). 368711 self 368712 should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] 368713 raise: Error! ! 368714 368715!SymbolTest methodsFor: 'tests - subcollections access'! 368716testLastNElements 368717 "self debug: #testLastNElements" 368718 | result | 368719 result := self moreThan3Elements last: self moreThan3Elements size - 1. 368720 1 368721 to: result size 368722 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. 368723 self assert: result size = (self moreThan3Elements size - 1). 368724 self 368725 should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] 368726 raise: Error! ! 368727 368728"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 368729 368730SymbolTest class 368731 uses: TIncludesTest classTrait + TCloneTest classTrait + TCopyPreservingIdentityTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TIterateSequencedReadableTest classTrait + TSequencedConcatenationTest classTrait + TPrintOnSequencedTest classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TIndexAccess classTrait + TIndexAccessForMultipliness classTrait + TSequencedElementAccessTest classTrait + TSubCollectionAccess classTrait + TCopySequenceableSameContents classTrait + TCopyPartOfSequenceable classTrait + TCopyPartOfSequenceableForMultipliness classTrait + TCopySequenceableWithReplacement classTrait + TBeginsEndsWith classTrait + TConvertAsSortedTest classTrait + TConvertTest classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TConvertAsSetForMultiplinessTest classTrait + TSequencedStructuralEqualityTest classTrait + TOccurrencesForMultiplinessTest classTrait 368732 instanceVariableNames: ''! 368733StringHolder subclass: #SyntaxError 368734 instanceVariableNames: 'class selector category debugger doitFlag' 368735 classVariableNames: '' 368736 poolDictionaries: '' 368737 category: 'Tools-Debugger'! 368738!SyntaxError commentStamp: '<historical>' prior: 0! 368739I represent syntax error report for syntax errors encountered when filing in class descriptions from a non-interactive source such as an external file. As a StringHolder, the string to be viewed is the method code or expression containing the error. 368740 368741The user may fix the error and accept the method to continue the fileIn. 368742! 368743 368744 368745!SyntaxError methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 368746category: aSymbol 368747 "Record the message category of method being compiled. This is used when the user corrects the error and accepts." 368748 368749 category := aSymbol. 368750! ! 368751 368752!SyntaxError methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:30'! 368753setClass: aClass code: aString debugger: aDebugger doitFlag: flag 368754 368755 | types printables badChar | 368756 class := aClass. 368757 debugger := aDebugger. 368758 selector := aClass parserClass new parseSelector: aString. 368759 types := Scanner classPool at: #TypeTable. "dictionary" 368760 printables := '!!@#$%&*-_=+<>{}?/\,·£¢§¶ªº–—“‘”’…Úæگ׿«»`~`' asSet. 368761 badChar := aString detect: [:aChar | (types at: aChar asciiValue ifAbsent: [#xLetter]) == #xBinary and: [ 368762 (printables includes: aChar) not]] ifNone: [nil]. 368763 contents := badChar 368764 ifNil: [aString] 368765 ifNotNil: ['<<<This string contains a character (ascii value ', 368766 badChar asciiValue printString, 368767 ') that is not normally used in code>>> ', aString]. 368768 category ifNil: [category := aClass organization categoryOfElement: selector]. 368769 category ifNil: [category := ClassOrganizer default]. 368770 doitFlag := flag! ! 368771 368772 368773!SyntaxError methodsFor: 'menu' stamp: 'alain.plantec 6/1/2008 20:38'! 368774debug 368775 "Show the stack of the process leading to this syntax editor, typically showing the stack of the compiler as called from fileIn." 368776 368777 debugger openFullNoSuspendLabel: 'Stack of the Syntax Error'. 368778! ! 368779 368780!SyntaxError methodsFor: 'menu' stamp: 'jm 5/3/1998 14:22'! 368781listMenu: aMenu 368782 368783 ^ aMenu labels: 368784'proceed 368785debug calling process 368786browse full' 368787 lines: #() 368788 selections: #(proceed debug browseMethodFull) 368789! ! 368790 368791!SyntaxError methodsFor: 'menu' stamp: 'di 5/5/1998 00:06'! 368792proceed 368793 "The user has has edited and presumably fixed the syntax error and the filein can now proceed." 368794 368795 debugger proceed: self topView. 368796! ! 368797 368798 368799!SyntaxError methodsFor: 'message list' stamp: 'stephane.ducasse 3/31/2009 20:53'! 368800list 368801 "Answer an array of one element made up of the class name, message category, and message selector in which the syntax error was found. This is the single item in the message list of a view/browser on the receiver." 368802 368803 selector ifNil: [^ Array with: (class name, ' ', category, ' ', '<none>')]. 368804 category ifNil: [^ Array with: (class name, ' ', '<none>')]. 368805 ^ Array with: (class name, ' ', category, ' ', selector) 368806! ! 368807 368808!SyntaxError methodsFor: 'message list' stamp: 'jm 5/3/1998 13:48'! 368809listIndex 368810 "There is always exactly one element in my list and it is always selected." 368811 368812 ^ 1 368813! ! 368814 368815 368816!SyntaxError methodsFor: 'other' stamp: 'mtf 7/21/2008 20:44'! 368817contents: aString notifying: aController 368818 "Compile the code in aString and proceed. Do not notify anybody of errors, because nobody would have been notified of errors if this syntax error had not arisen" 368819 368820 doitFlag 368821 ifTrue: [Compiler new evaluate: aString] 368822 ifFalse: [class compile: aString classified: category]. 368823 aController hasUnacceptedEdits: false. 368824 self proceed! ! 368825 368826!SyntaxError methodsFor: 'other' stamp: 'sd 11/20/2005 21:27'! 368827notify: error at: location in: source 368828 "Open a syntax error view, inserting the given error message into the given source at the given location. This message is sent to the 'requestor' when the parser or compiler finds a syntax error." 368829 368830 | aClass aString | 368831 aClass := thisContext sender receiver encoder classEncoding. 368832 aString := 368833 source contents 368834 copyReplaceFrom: location 368835 to: location - 1 368836 with: error. 368837 self setClass: aClass 368838 code: aString 368839 debugger: (Debugger context: thisContext) 368840 doitFlag: false. 368841 self class open: self. 368842! ! 368843 368844 368845!SyntaxError methodsFor: 'text menu support' stamp: 'jm 5/3/1998 14:15'! 368846selectedClass 368847 "Answer the class in which the syntax error occurred." 368848 368849 ^ class 368850! ! 368851 368852!SyntaxError methodsFor: 'text menu support' stamp: 'jm 5/3/1998 14:33'! 368853selectedClassOrMetaClass 368854 "Answer the class of the method being compiled." 368855 368856 ^ class 368857! ! 368858 368859!SyntaxError methodsFor: 'text menu support' stamp: 'jm 5/3/1998 14:17'! 368860selectedMessageName 368861 "Answer the selector of the method being compiled." 368862 368863 ^ selector 368864! ! 368865 368866"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 368867 368868SyntaxError class 368869 instanceVariableNames: ''! 368870 368871!SyntaxError class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 368872buildMorphicViewOn: aSyntaxError 368873 "Answer an Morphic view on the given SyntaxError." 368874 | window | 368875 window := (SystemWindow labelled: 'Syntax Error') model: aSyntaxError. 368876 368877 window addMorph: (PluggableListMorph on: aSyntaxError list: #list 368878 selected: #listIndex changeSelected: nil menu: #listMenu:) 368879 frame: (0@0 corner: 1@0.15). 368880 368881 window addMorph: (PluggableTextMorph on: aSyntaxError text: #contents 368882 accept: #contents:notifying: readSelection: #contentsSelection 368883 menu: #codePaneMenu:shifted:) 368884 frame: (0@0.15 corner: 1@1). 368885 368886 ^ window openInWorldExtent: 380@220! ! 368887 368888!SyntaxError class methodsFor: 'instance creation' stamp: 'di 9/14/2001 07:46'! 368889errorInClass: aClass withCode: codeString doitFlag: doit 368890 "Open a view whose model is a syntax error. The error occurred when trying to add the given method code to the given class." 368891 368892 self open: 368893 (self new setClass: aClass 368894 code: codeString 368895 debugger: (Debugger context: thisContext) 368896 doitFlag: doit). 368897! ! 368898 368899!SyntaxError class methodsFor: 'instance creation' stamp: 'alain.plantec 6/1/2008 20:39'! 368900open: aSyntaxError 368901 "Answer a standard system view whose model is an instance of me." 368902 <primitive: 19> 368903 "Simulation guard" 368904 self buildMorphicViewOn: aSyntaxError. 368905 Project spawnNewProcessIfThisIsUI: Processor activeProcess. 368906 ^ Processor activeProcess suspend! ! 368907Error subclass: #SyntaxErrorNotification 368908 instanceVariableNames: 'inClass code category doitFlag errorMessage location' 368909 classVariableNames: '' 368910 poolDictionaries: '' 368911 category: 'Exceptions-Extensions'! 368912 368913!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'ar 9/27/2005 19:17'! 368914category 368915 ^category! ! 368916 368917!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'ar 9/27/2005 19:11'! 368918doitFlag 368919 ^doitFlag! ! 368920 368921!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'ar 9/27/2005 19:10'! 368922errorClass 368923 ^inClass! ! 368924 368925!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'ar 9/27/2005 19:10'! 368926errorCode 368927 ^code! ! 368928 368929!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'eem 9/23/2008 14:23'! 368930errorMessage 368931 ^errorMessage! ! 368932 368933!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'eem 9/23/2008 14:23'! 368934location 368935 ^location! ! 368936 368937!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'ar 9/27/2005 19:14'! 368938messageText 368939 ^ super messageText 368940 ifNil: [messageText := code]! ! 368941 368942!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'ar 9/27/2005 19:15'! 368943setClass: aClass category: aCategory code: codeString doitFlag: aBoolean 368944 inClass := aClass. 368945 category := aCategory. 368946 code := codeString. 368947 doitFlag := aBoolean ! ! 368948 368949!SyntaxErrorNotification methodsFor: 'accessing' stamp: 'eem 9/23/2008 14:20'! 368950setClass: aClass category: aCategory code: codeString doitFlag: aBoolean errorMessage: errorString location: anInteger 368951 inClass := aClass. 368952 category := aCategory. 368953 code := codeString. 368954 doitFlag := aBoolean. 368955 errorMessage := errorString. 368956 location := anInteger! ! 368957 368958 368959!SyntaxErrorNotification methodsFor: 'exceptiondescription' stamp: 'ar 9/27/2005 19:13'! 368960defaultAction 368961 ^ToolSet debugSyntaxError: self! ! 368962 368963"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 368964 368965SyntaxErrorNotification class 368966 instanceVariableNames: ''! 368967 368968!SyntaxErrorNotification class methodsFor: 'exceptionInstantiator' stamp: 'eem 9/23/2008 14:19'! 368969inClass: aClass category: aCategory withCode: codeString doitFlag: doitFlag errorMessage: errorString location: location 368970 ^ (self new 368971 setClass: aClass 368972 category: aCategory 368973 code: codeString 368974 doitFlag: doitFlag 368975 errorMessage: errorString 368976 location: location) signal! ! 368977 368978 368979!SyntaxErrorNotification class methodsFor: 'exceptioninstantiator' stamp: 'ar 9/27/2005 19:15'! 368980inClass: aClass category: aCategory withCode: codeString doitFlag: doitFlag 368981 ^ (self new 368982 setClass: aClass 368983 category: aCategory 368984 code: codeString 368985 doitFlag: doitFlag) signal! ! 368986AppRegistry subclass: #SystemBrowser 368987 instanceVariableNames: '' 368988 classVariableNames: '' 368989 poolDictionaries: '' 368990 category: 'Tools-Base'! 368991!SystemBrowser commentStamp: '<historical>' prior: 0! 368992This is the AppRegistry class for class browsing! 368993 368994 368995"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 368996 368997SystemBrowser class 368998 instanceVariableNames: ''! 368999 369000!SystemBrowser class methodsFor: 'initialize-release' stamp: 'sd 11/20/2005 21:28'! 369001unload 369002 | pref | 369003 pref := Preferences preferenceAt: #browserShowsPackagePane. 369004 Preferences 369005 addPreference: #browserShowsPackagePane 369006 categories: pref categoryList 369007 default: pref defaultValue 369008 balloonHelp: pref helpString 369009 projectLocal: pref localToProject 369010 changeInformee: nil 369011 changeSelector: nil 369012 ! ! 369013 369014 369015!SystemBrowser class methodsFor: 'instance creation' stamp: 'hpt 8/5/2004 20:27'! 369016defaultOpenBrowser 369017 ^self default openBrowser! ! 369018 369019 369020!SystemBrowser class methodsFor: 'registration' stamp: 'hpt 9/30/2004 20:53'! 369021addRegistryMenuItemsTo: aMenu inAccountOf: aBrowser 369022 "Add some useful options related Browser registry to the 369023 browsers windows menu" 369024 aMenu addLine; 369025 add: 'Register this Browser as default' 369026 target: [self default: aBrowser class] 369027 action: #value; 369028 add: 'Choose new default Browser' 369029 target: self 369030 action: #askForDefault! ! 369031SystemChangeTestRoot subclass: #SystemChangeErrorHandling 369032 instanceVariableNames: 'capturedEvents' 369033 classVariableNames: '' 369034 poolDictionaries: '' 369035 category: 'Tests-SystemChangeNotification'! 369036!SystemChangeErrorHandling commentStamp: 'rw 4/3/2006 17:21' prior: 0! 369037This class tests the error handing of the notification mechanism to ensure that one client that receives a system change cannot lock up the complete system."! 369038 369039 369040!SystemChangeErrorHandling methodsFor: 'event notifications' stamp: 'rw 4/3/2006 17:57'! 369041handleEventWithError: event 369042 369043 self error: 'Example of event handling code that throws an error.'! ! 369044 369045!SystemChangeErrorHandling methodsFor: 'event notifications' stamp: 'rw 4/3/2006 18:07'! 369046handleEventWithHalt: event 369047 369048 self halt: 'Example of event handling code that contains a halt.'! ! 369049 369050!SystemChangeErrorHandling methodsFor: 'event notifications' stamp: 'rw 4/3/2006 17:57'! 369051storeEvent1: anEvent 369052 369053 capturedEvents add: anEvent! ! 369054 369055!SystemChangeErrorHandling methodsFor: 'event notifications' stamp: 'rw 4/3/2006 17:57'! 369056storeEvent2: anEvent 369057 369058 capturedEvents add: anEvent! ! 369059 369060!SystemChangeErrorHandling methodsFor: 'event notifications' stamp: 'rw 4/3/2006 17:57'! 369061storeEvent3: anEvent 369062 369063 capturedEvents add: anEvent! ! 369064 369065 369066!SystemChangeErrorHandling methodsFor: 'running' stamp: 'rw 4/3/2006 17:51'! 369067setUp 369068 369069 super setUp. 369070 capturedEvents := OrderedCollection new! ! 369071 369072!SystemChangeErrorHandling methodsFor: 'running' stamp: 'rw 4/3/2006 17:56'! 369073tearDown 369074 369075 capturedEvents := nil. 369076 super tearDown! ! 369077 369078 369079!SystemChangeErrorHandling methodsFor: 'testing' stamp: 'rw 4/5/2006 17:24'! 369080testErrorOperation 369081 369082 | notifier wasCaptured | 369083 notifier := self systemChangeNotifier. 369084 wasCaptured := false. 369085 notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent1:. 369086 notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent2:. 369087 notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #handleEventWithError:. 369088 notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent3:. 369089 [notifier classAdded: self class inCategory: #FooCat] on: Error do: [:exc | 369090 wasCaptured := true. 369091 self assert: (capturedEvents size = 3)]. 369092 self assert: wasCaptured.! ! 369093 369094!SystemChangeErrorHandling methodsFor: 'testing' stamp: 'rw 4/5/2006 17:24'! 369095testHaltOperation 369096 369097 | notifier wasCaptured | 369098 notifier := self systemChangeNotifier. 369099 wasCaptured := false. 369100 notifier notify: self ofAllSystemChangesUsing: #storeEvent1:. 369101 notifier notify: self ofAllSystemChangesUsing: #storeEvent2:. 369102 notifier notify: self ofAllSystemChangesUsing: #handleEventWithHalt:. 369103 notifier notify: self ofAllSystemChangesUsing: #storeEvent3:. 369104 [notifier classAdded: self class inCategory: #FooCat] on: Halt do: [:exc | 369105 wasCaptured := true. 369106 self assert: (capturedEvents size = 3)]. 369107 self assert: wasCaptured.! ! 369108 369109!SystemChangeErrorHandling methodsFor: 'testing' stamp: 'rw 4/5/2006 17:24'! 369110testUnhandledEventOperation 369111 369112 | notifier wasCaptured | 369113 notifier := self systemChangeNotifier. 369114 wasCaptured := false. 369115 notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent1:. 369116 notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent2:. 369117 notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #zork:. 369118 notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent3:. 369119 [notifier classAdded: self class inCategory: #FooCat] on: MessageNotUnderstood do: [:exc | 369120 wasCaptured := true. 369121 self assert: (capturedEvents size = 3)]. 369122 self assert: wasCaptured.! ! 369123SystemChangeTestRoot subclass: #SystemChangeErrorHandlingTest 369124 instanceVariableNames: 'capturedEvents' 369125 classVariableNames: '' 369126 poolDictionaries: '' 369127 category: 'Tests-SystemChangeNotification'! 369128Object subclass: #SystemChangeNotifier 369129 instanceVariableNames: 'eventSource silenceLevel' 369130 classVariableNames: 'UniqueInstance' 369131 poolDictionaries: '' 369132 category: 'System-Change Notification'! 369133 369134!SystemChangeNotifier methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 11:08'! 369135initialize 369136 369137 super initialize. 369138 eventSource := SystemEventManager new. 369139 silenceLevel := 0.! ! 369140 369141 369142!SystemChangeNotifier methodsFor: 'public' stamp: 'nice 4/16/2009 09:56'! 369143doSilently: aBlock 369144 "Perform the block, and ensure that no system notification are broadcasted while doing so." 369145 369146 silenceLevel := silenceLevel + 1. 369147 ^[aBlock value] ensure: [silenceLevel > 0 ifTrue: [silenceLevel := silenceLevel - 1]]! ! 369148 369149!SystemChangeNotifier methodsFor: 'public' stamp: 'gk 8/14/2007 23:47'! 369150hasNotificationsFor: anObject 369151 "Do we send system notifications to anObject?" 369152 369153 ^eventSource hasActionsWithReceiver: anObject! ! 369154 369155!SystemChangeNotifier methodsFor: 'public' stamp: 'NS 1/26/2004 20:41'! 369156isBroadcasting 369157 369158 ^ silenceLevel = 0! ! 369159 369160!SystemChangeNotifier methodsFor: 'public' stamp: 'rw 7/29/2003 17:01'! 369161noMoreNotificationsFor: anObject 369162 "Stop sending system notifications to an object." 369163 369164 eventSource removeActionsWithReceiver: anObject! ! 369165 369166!SystemChangeNotifier methodsFor: 'public' stamp: 'rw 7/10/2003 12:00'! 369167notify: anObject ofAllSystemChangesUsing: oneArgumentSelector 369168 "Notifies an object of any system changes." 369169 369170 self 369171 notify: anObject 369172 ofEvents: self allSystemEvents 369173 using: oneArgumentSelector! ! 369174 369175!SystemChangeNotifier methodsFor: 'public' stamp: 'bvs 7/20/2004 12:13'! 369176notify: anObject ofSystemChangesOfChange: changeKind using: oneArgumentSelector 369177 "Notifies an object of system changes of the specified changeKind (#added, #removed, ...). Evaluate 'AbstractEvent allChangeKinds' to get the complete list." 369178 369179 self 369180 notify: anObject 369181 ofEvents: (self systemEventsForChange: changeKind) 369182 using: oneArgumentSelector! ! 369183 369184!SystemChangeNotifier methodsFor: 'public' stamp: 'bvs 7/20/2004 12:13'! 369185notify: anObject ofSystemChangesOfItem: itemKind change: changeKind using: oneArgumentSelector 369186 "Notifies an object of system changes of the specified itemKind (#class, #category, ...) and changeKind (#added, #removed, ...). This is the finest granularity possible. 369187 Evaluate 'AbstractEvent allChangeKinds' to get the complete list of change kinds, and 'AbstractEvent allItemKinds to get all the possible item kinds supported." 369188 369189 self 369190 notify: anObject 369191 ofEvents: (Bag with: (self systemEventsForItem: itemKind change: changeKind)) 369192 using: oneArgumentSelector! ! 369193 369194!SystemChangeNotifier methodsFor: 'public' stamp: 'bvs 7/20/2004 12:13'! 369195notify: anObject ofSystemChangesOfItem: itemKind using: oneArgumentSelector 369196 "Notifies an object of system changes of the specified itemKind (#class, #method, #protocol, ...). Evaluate 'AbstractEvent allItemKinds' to get the complete list." 369197 369198 self 369199 notify: anObject 369200 ofEvents: (self systemEventsForItem: itemKind) 369201 using: oneArgumentSelector! ! 369202 369203 369204!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'gk 8/23/2007 21:35'! 369205class: aClass oldComment: oldComment newComment: newComment oldStamp: oldStamp newStamp: newStamp 369206 "A class was commented in the system." 369207 369208 self trigger: (CommentedEvent class: aClass oldComment: oldComment newComment: newComment oldStamp: oldStamp newStamp: newStamp)! ! 369209 369210!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'ab 2/10/2005 16:32'! 369211classCategoryAdded: aClassCategoryName 369212 369213 self trigger: (AddedEvent 369214 classCategory: aClassCategoryName)! ! 369215 369216!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'ab 2/10/2005 16:35'! 369217classCategoryRemoved: aClassCategoryName 369218 369219 self trigger: (RemovedEvent 369220 classCategory: aClassCategoryName)! ! 369221 369222!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'ab 2/10/2005 16:44'! 369223classCategoryRenamedFrom: anOldClassCategoryName to: aNewClassCategoryName 369224 369225 self trigger: (RenamedEvent 369226 classCategoryRenamedFrom: anOldClassCategoryName 369227 to: aNewClassCategoryName)! ! 369228 369229!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'rw 7/29/2003 15:12'! 369230class: aClass recategorizedFrom: oldCategory to: newCategory 369231 self trigger: (RecategorizedEvent 369232 class: aClass 369233 category: newCategory 369234 oldCategory: oldCategory)! ! 369235 369236!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'rw 7/29/2003 15:11'! 369237classAdded: aClass inCategory: aCategoryName 369238 self trigger: (AddedEvent class: aClass category: aCategoryName)! ! 369239 369240!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/26/2004 09:37'! 369241classCommented: aClass 369242 "A class with the given name was commented in the system." 369243 369244 self trigger: (CommentedEvent class: aClass)! ! 369245 369246!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'rw 7/29/2003 15:11'! 369247classCommented: aClass inCategory: aCategoryName 369248 "A class with the given name was commented in the system." 369249 369250 self trigger: (CommentedEvent class: aClass category: aCategoryName)! ! 369251 369252!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/20/2004 19:37'! 369253classDefinitionChangedFrom: oldClass to: newClass 369254 self trigger: (ModifiedClassDefinitionEvent classDefinitionChangedFrom: oldClass to: newClass)! ! 369255 369256!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/16/2004 15:10'! 369257classRemoved: aClass fromCategory: aCategoryName 369258 self trigger: (RemovedEvent class: aClass category: aCategoryName)! ! 369259 369260!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 12:19'! 369261classRenamed: aClass from: oldClassName to: newClassName inCategory: aCategoryName 369262 self trigger: (RenamedEvent 369263 class: aClass 369264 category: aCategoryName 369265 oldName: oldClassName 369266 newName: newClassName)! ! 369267 369268!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 12:48'! 369269classReorganized: aClass 369270 self trigger: (ReorganizedEvent class: aClass)! ! 369271 369272!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/19/2004 09:48'! 369273evaluated: textOrStream 369274 ^ self evaluated: textOrStream context: nil.! ! 369275 369276!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/19/2004 09:47'! 369277evaluated: expression context: aContext 369278 self trigger: (DoItEvent 369279 expression: expression 369280 context: aContext)! ! 369281 369282!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 11:24'! 369283methodAdded: aMethod selector: aSymbol inClass: aClass 369284 "A method with the given selector was added to aClass, but not put in a protocol." 369285 369286 self trigger: (AddedEvent 369287 method: aMethod 369288 selector: aSymbol 369289 class: aClass)! ! 369290 369291!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 11:24'! 369292methodAdded: aMethod selector: aSymbol inClass: aClass requestor: requestor 369293 "A method with the given selector was added to aClass, but not put in a protocol." 369294 369295 self trigger: (AddedEvent 369296 method: aMethod 369297 selector: aSymbol 369298 class: aClass 369299 requestor: requestor)! ! 369300 369301!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 11:24'! 369302methodAdded: aMethod selector: aSymbol inProtocol: aCategoryName class: aClass 369303 "A method with the given selector was added to aClass in protocol aCategoryName." 369304 369305 self trigger: (AddedEvent 369306 method: aMethod 369307 selector: aSymbol 369308 protocol: aCategoryName 369309 class: aClass)! ! 369310 369311!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 11:24'! 369312methodAdded: aMethod selector: aSymbol inProtocol: aCategoryName class: aClass requestor: requestor 369313 "A method with the given selector was added to aClass in protocol aCategoryName." 369314 369315 self trigger: (AddedEvent 369316 method: aMethod 369317 selector: aSymbol 369318 protocol: aCategoryName 369319 class: aClass 369320 requestor: requestor)! ! 369321 369322!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 11:41'! 369323methodChangedFrom: oldMethod to: newMethod selector: aSymbol inClass: aClass 369324 self trigger: (ModifiedEvent 369325 methodChangedFrom: oldMethod 369326 to: newMethod 369327 selector: aSymbol 369328 inClass: aClass)! ! 369329 369330!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'mtf 8/25/2007 23:21'! 369331methodChangedFrom: oldMethod to: newMethod selector: aSymbol inClass: aClass oldProtocol: oldProtocol newProtocol: newProtocol requestor: requestor 369332 self trigger: ((ModifiedMethodEvent 369333 methodChangedFrom: oldMethod 369334 to: newMethod 369335 selector: aSymbol 369336 inClass: aClass 369337 requestor: requestor) 369338 oldProtocol: oldProtocol; 369339 newProtocol: newProtocol)! ! 369340 369341!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/27/2004 11:41'! 369342methodChangedFrom: oldMethod to: newMethod selector: aSymbol inClass: aClass requestor: requestor 369343 self trigger: (ModifiedEvent 369344 methodChangedFrom: oldMethod 369345 to: newMethod 369346 selector: aSymbol 369347 inClass: aClass 369348 requestor: requestor)! ! 369349 369350!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/28/2004 11:12'! 369351methodRemoved: aMethod selector: aSymbol class: aClass 369352 "A method with the given selector was removed from the class." 369353 369354 self trigger: (RemovedEvent 369355 method: aMethod 369356 selector: aSymbol 369357 class: aClass)! ! 369358 369359!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 1/28/2004 11:11'! 369360methodRemoved: aMethod selector: aSymbol inProtocol: protocol class: aClass 369361 "A method with the given selector was removed from the class." 369362 369363 self trigger: (RemovedEvent 369364 method: aMethod 369365 selector: aSymbol 369366 protocol: protocol 369367 class: aClass)! ! 369368 369369!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'NS 4/7/2004 13:35'! 369370selector: selector recategorizedFrom: oldCategory to: newCategory inClass: aClass 369371 369372 self trigger: (RecategorizedEvent 369373 method: (aClass compiledMethodAt: selector ifAbsent: [nil]) 369374 protocol: newCategory 369375 class: aClass 369376 oldProtocol: oldCategory)! ! 369377 369378!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'al 7/18/2004 10:48'! 369379traitDefinitionChangedFrom: oldTrait to: newTrait 369380 self trigger: (ModifiedTraitDefinitionEvent traitDefinitionChangedFrom: oldTrait to: newTrait)! ! 369381 369382 369383!SystemChangeNotifier methodsFor: 'private' stamp: 'rw 7/10/2003 15:15'! 369384notify: anObject ofEvents: eventsCollection using: oneArgumentSelector 369385 "Notifies an object of any events in the eventsCollection. Send it back a message #oneArgumentSelector, with as argument the particular system event instance." 369386 369387 eventsCollection do: [:eachEvent | 369388 eventSource when: eachEvent send: oneArgumentSelector to: anObject]! ! 369389 369390!SystemChangeNotifier methodsFor: 'private' stamp: 'rw 7/29/2003 17:05'! 369391releaseAll 369392 "Release all the dependents so that nobody receives notifications anymore." 369393 369394 "Done for cleaning up the system." 369395 "self uniqueInstance releaseAll" 369396 369397 eventSource releaseActionMap! ! 369398 369399!SystemChangeNotifier methodsFor: 'private' stamp: 'NS 1/26/2004 20:43'! 369400setBroadcasting 369401 silenceLevel := 0.! ! 369402 369403!SystemChangeNotifier methodsFor: 'private' stamp: 'NS 1/26/2004 20:41'! 369404trigger: event 369405 369406 self isBroadcasting ifTrue: [event trigger: eventSource] 369407 369408" | caughtExceptions | 369409 caughtExceptions := OrderedCollection new. 369410 self isBroadcasting ifTrue: [ 369411 [(eventSource actionForEvent: event eventSelector) valueWithArguments: (Array with: event)] on: Exception do: [:exc | caughtExceptions add: exc]]. 369412 caughtExceptions do: [:exc | exc resignalAs: exc class new]"! ! 369413 369414 369415!SystemChangeNotifier methodsFor: 'private-event lists' stamp: 'rw 7/29/2003 15:14'! 369416allSystemEvents 369417 ^AbstractEvent systemEvents! ! 369418 369419!SystemChangeNotifier methodsFor: 'private-event lists' stamp: 'rw 7/29/2003 15:14'! 369420systemEventsForChange: changeKind 369421 | selectorBlock | 369422 selectorBlock := AbstractEvent eventSelectorBlock. 369423 ^AbstractEvent allItemKinds 369424 collect: [:itemKind | selectorBlock value: itemKind value: changeKind]! ! 369425 369426!SystemChangeNotifier methodsFor: 'private-event lists' stamp: 'rw 7/29/2003 15:14'! 369427systemEventsForItem: itemKind 369428 | selectorBlock | 369429 selectorBlock := AbstractEvent eventSelectorBlock. 369430 ^AbstractEvent allChangeKinds 369431 collect: [:changeKind | selectorBlock value: itemKind value: changeKind]! ! 369432 369433!SystemChangeNotifier methodsFor: 'private-event lists' stamp: 'rw 7/29/2003 15:14'! 369434systemEventsForItem: itemKind change: changeKind 369435 ^AbstractEvent eventSelectorBlock value: itemKind value: changeKind! ! 369436 369437"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 369438 369439SystemChangeNotifier class 369440 instanceVariableNames: ''! 369441 369442!SystemChangeNotifier class methodsFor: 'instance creation' stamp: 'rw 6/28/2003 09:41'! 369443new 369444 369445 ^self error: self instanceCreationErrorString! ! 369446 369447 369448!SystemChangeNotifier class methodsFor: 'item kinds' stamp: 'NS 1/21/2004 09:31'! 369449categoryKind 369450 369451 ^ AbstractEvent categoryKind! ! 369452 369453!SystemChangeNotifier class methodsFor: 'item kinds' stamp: 'NS 1/21/2004 09:31'! 369454classKind 369455 369456 ^ AbstractEvent classKind! ! 369457 369458!SystemChangeNotifier class methodsFor: 'item kinds' stamp: 'NS 1/21/2004 09:32'! 369459expressionKind 369460 ^ AbstractEvent expressionKind! ! 369461 369462!SystemChangeNotifier class methodsFor: 'item kinds' stamp: 'NS 1/21/2004 09:31'! 369463methodKind 369464 369465 ^ AbstractEvent methodKind! ! 369466 369467!SystemChangeNotifier class methodsFor: 'item kinds' stamp: 'NS 1/21/2004 09:32'! 369468protocolKind 369469 ^ AbstractEvent protocolKind! ! 369470 369471 369472!SystemChangeNotifier class methodsFor: 'public' stamp: 'NS 1/27/2004 16:23'! 369473uniqueInstance 369474 369475 UniqueInstance ifNil: [UniqueInstance := self createInstance]. 369476 ^UniqueInstance! ! 369477 369478 369479!SystemChangeNotifier class methodsFor: 'private' stamp: 'NS 1/27/2004 16:23'! 369480createInstance 369481 369482 ^self basicNew initialize! ! 369483 369484!SystemChangeNotifier class methodsFor: 'private' stamp: 'rw 6/28/2003 09:41'! 369485instanceCreationErrorString 369486 369487 ^'This is a singleton implementation, so you are not allowed to create instances yourself. Use #uniqueInstance to access the instance.'! ! 369488 369489!SystemChangeNotifier class methodsFor: 'private' stamp: 'marcus.denker 11/10/2008 10:04'! 369490resetUniqueInstance 369491 "self resetUniqueInstance" 369492 369493 UniqueInstance 369494 ifNotNil: [:u | UniqueInstance releaseAll. 369495 UniqueInstance := nil]! ! 369496SystemChangeTestRoot subclass: #SystemChangeNotifierTest 369497 instanceVariableNames: 'capturedEvent notifier' 369498 classVariableNames: '' 369499 poolDictionaries: '' 369500 category: 'Tests-SystemChangeNotification'! 369501!SystemChangeNotifierTest commentStamp: 'rw 4/3/2006 17:19' prior: 0! 369502A SystemChangeNotifierTest is a test class that tests whether the triggering of changes indeed results in the intended changes to be sent to registered object. The basic mechanism for each test is fairly simple: 369503 - register the receiver as the one to get the change notifier. 369504 - manually trigger a change (so the system is not polluted just to see whether we get the needed event). 369505 - the method #event: is invoked and remembers the change event. 369506 - the change event is checked to see whether it was the intended one. 369507 369508Instance Variables 369509 capturedEvent: Remembers the captured event! 369510 369511 369512!SystemChangeNotifierTest methodsFor: 'event notifications' stamp: 'marcus.denker 9/14/2008 21:06'! 369513event: event 369514 "The notification message being sent to me when an event is captured. Remember it." 369515 369516 self capturedEvent: event! ! 369517 369518 369519!SystemChangeNotifierTest methodsFor: 'running' stamp: 'rw 10/19/2006 17:21'! 369520setUp 369521 369522 super setUp. 369523 notifier := SystemChangeNotifier createInstance.! ! 369524 369525!SystemChangeNotifierTest methodsFor: 'running' stamp: 'rw 10/19/2006 17:23'! 369526tearDown 369527 369528 super tearDown. 369529 self capturedEvent: nil. 369530 notifier releaseAll. 369531 notifier := nil! ! 369532 369533 369534!SystemChangeNotifierTest methodsFor: 'testing-system triggers' stamp: 'rw 4/5/2006 17:24'! 369535testClassAddedEvent 369536 369537 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. 369538 self systemChangeNotifier classAdded: self class inCategory: #FooCat. 369539 self 369540 checkEventForClass: self class 369541 category: #FooCat 369542 change: #Added! ! 369543 369544!SystemChangeNotifierTest methodsFor: 'testing-system triggers' stamp: 'rw 4/5/2006 17:24'! 369545testClassAddedEvent2 369546 369547 self systemChangeNotifier notify: self ofSystemChangesOfItem: #class change: #Added using: #event:. 369548 self systemChangeNotifier classAdded: self class inCategory: #FooCat. 369549 self 369550 checkEventForClass: self class 369551 category: #FooCat 369552 change: #Added! ! 369553 369554!SystemChangeNotifierTest methodsFor: 'testing-system triggers' stamp: 'rw 4/5/2006 17:24'! 369555testClassCommentedEvent 369556 369557 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. 369558 self systemChangeNotifier classCommented: self class inCategory: #FooCat. 369559 self 369560 checkEventForClass: self class 369561 category: #FooCat 369562 change: #Commented! ! 369563 369564!SystemChangeNotifierTest methodsFor: 'testing-system triggers' stamp: 'rw 4/5/2006 17:24'! 369565testClassRecategorizedEvent 369566 369567 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. 369568 self systemChangeNotifier 369569 class: self class 369570 recategorizedFrom: #FooCat 369571 to: #FooBar. 369572 self 369573 checkEventForClass: self class 369574 category: #FooBar 369575 change: #Recategorized. 369576 self assert: capturedEvent oldCategory = #FooCat! ! 369577 369578!SystemChangeNotifierTest methodsFor: 'testing-system triggers' stamp: 'rw 4/5/2006 17:24'! 369579testClassRemovedEvent 369580 369581 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. 369582 self systemChangeNotifier classRemoved: self class fromCategory: #FooCat. 369583 self 369584 checkEventForClass: self class 369585 category: #FooCat 369586 change: #Removed! ! 369587 369588!SystemChangeNotifierTest methodsFor: 'testing-system triggers' stamp: 'rw 10/19/2006 17:24'! 369589testClassRenamedEvent 369590 "self run: #testClassRenamedEvent" 369591 369592 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. 369593 self systemChangeNotifier 369594 classRenamed: self class 369595 from: #OldFooClass 369596 to: #NewFooClass 369597 inCategory: #FooCat. 369598 self 369599 checkEventForClass: self class 369600 category: #FooCat 369601 change: #Renamed. 369602" self assert: capturedEvent oldName = #OldFooClass. 369603 self assert: capturedEvent newName = #NewFooClass"! ! 369604 369605!SystemChangeNotifierTest methodsFor: 'testing-system triggers' stamp: 'rw 4/5/2006 17:25'! 369606testDoItEvent 369607 369608 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. 369609 self systemChangeNotifier 369610 evaluated: '1 + 2' 369611 context: self. 369612 self assert: capturedEvent isDoIt. 369613 self assert: capturedEvent item = '1 + 2'. 369614 self assert: capturedEvent itemKind = AbstractEvent expressionKind. 369615 self assert: capturedEvent itemClass = nil. 369616 self assert: capturedEvent itemMethod = nil. 369617 self assert: capturedEvent itemProtocol = nil. 369618 self assert: capturedEvent itemExpression = '1 + 2'. 369619 self assert: capturedEvent context = self.! ! 369620 369621!SystemChangeNotifierTest methodsFor: 'testing-system triggers' stamp: 'rw 4/5/2006 17:25'! 369622testMethodAddedEvent1 369623 369624 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. 369625 self systemChangeNotifier 369626 methodAdded: self class >> #testMethodAddedEvent1 369627 selector: #testMethodAddedEvent1 369628 inProtocol: #FooCat 369629 class: self class. 369630 self 369631 checkEventForMethod: self class >> #testMethodAddedEvent1 369632 protocol: #FooCat 369633 change: #Added! ! 369634 369635!SystemChangeNotifierTest methodsFor: 'testing-system triggers' stamp: 'rw 4/5/2006 17:25'! 369636testMethodAddedEvent2 369637 369638 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. 369639 self systemChangeNotifier 369640 methodAdded: self class >> #testMethodAddedEvent1 369641 selector: #testMethodAddedEvent1 369642 inClass: self class. 369643 self 369644 checkEventForMethod: self class >> #testMethodAddedEvent1 369645 protocol: nil 369646 change: #Added! ! 369647 369648!SystemChangeNotifierTest methodsFor: 'testing-system triggers' stamp: 'rw 4/5/2006 17:25'! 369649testMethodAddedEvent3 369650 369651 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. 369652 self systemChangeNotifier 369653 methodChangedFrom: self class >> #testMethodAddedEvent1 369654 to: self class >> #testMethodAddedEvent2 369655 selector: #testMethodAddedEvent2 369656 inClass: self class. 369657 self 369658 checkEventForMethod: self class >> #testMethodAddedEvent2 369659 protocol: nil 369660 change: #Modified 369661 oldMethod: self class >> #testMethodAddedEvent1.! ! 369662 369663!SystemChangeNotifierTest methodsFor: 'testing-system triggers' stamp: 'rw 4/5/2006 17:25'! 369664testMethodRemovedEvent 369665 369666 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. 369667 self systemChangeNotifier 369668 methodRemoved: self class>> #testMethodRemovedEvent 369669 selector: #testMethodRemovedEvent 369670 inProtocol: #FooCat 369671 class: self class. 369672 self 369673 checkEventForMethod: self class>> #testMethodRemovedEvent 369674 protocol: #FooCat 369675 change: #Removed.! ! 369676 369677 369678!SystemChangeNotifierTest methodsFor: 'private' stamp: 'rw 4/3/2006 16:34'! 369679capturedEvent: eventOrNil 369680 "Remember the event being sent." 369681 369682 capturedEvent := eventOrNil! ! 369683 369684!SystemChangeNotifierTest methodsFor: 'private' stamp: 'rw 4/3/2006 16:36'! 369685checkEventForClass: aClass category: cat change: changeKind 369686 369687 self assert: (capturedEvent perform: ('is' , changeKind) asSymbol). 369688 self assert: capturedEvent item = aClass. 369689 self assert: capturedEvent itemKind = AbstractEvent classKind. 369690 self assert: capturedEvent itemClass = aClass. 369691 self assert: capturedEvent itemCategory = cat! ! 369692 369693!SystemChangeNotifierTest methodsFor: 'private' stamp: 'rw 4/3/2006 16:43'! 369694checkEventForMethod: aMethod protocol: prot change: changeKind 369695 369696 self assert: (capturedEvent perform: ('is' , changeKind) asSymbol). 369697 self assert: capturedEvent item = aMethod. 369698 self assert: capturedEvent itemKind = AbstractEvent methodKind. 369699 self assert: capturedEvent itemClass = self class. 369700 self assert: capturedEvent itemMethod = aMethod. 369701 self assert: capturedEvent itemProtocol = prot! ! 369702 369703!SystemChangeNotifierTest methodsFor: 'private' stamp: 'rw 4/3/2006 16:43'! 369704checkEventForMethod: aMethod protocol: prot change: changeKind oldMethod: oldMethod 369705 369706 self checkEventForMethod: aMethod protocol: prot change: changeKind. 369707 self assert: capturedEvent oldItem == oldMethod 369708 ! ! 369709 369710!SystemChangeNotifierTest methodsFor: 'private' stamp: 'rw 10/19/2006 17:23'! 369711systemChangeNotifier 369712 "The notifier to use. Do not use the one in the system so that the fake events triggered in the tests perturb clients of the system's change notifier (e.g. the changes file then shows fake entries)." 369713 369714 ^notifier! ! 369715TestCase subclass: #SystemChangeTestRoot 369716 instanceVariableNames: '' 369717 classVariableNames: '' 369718 poolDictionaries: '' 369719 category: 'Tests-SystemChangeNotification'! 369720!SystemChangeTestRoot commentStamp: 'rw 4/5/2006 17:28' prior: 0! 369721The Root test class for the System Change Notification tests.! 369722 369723 369724!SystemChangeTestRoot methodsFor: 'running' stamp: 'rw 4/3/2006 17:59'! 369725tearDown 369726 369727 self unhook. 369728 super tearDown! ! 369729 369730!SystemChangeTestRoot methodsFor: 'running' stamp: 'rw 4/3/2006 17:23'! 369731unhook 369732 369733 self systemChangeNotifier noMoreNotificationsFor: self! ! 369734 369735 369736!SystemChangeTestRoot methodsFor: 'private' stamp: 'rw 4/3/2006 17:48'! 369737systemChangeNotifier 369738 "The notifier to use. Use the one for the system." 369739 369740 ^SystemChangeNotifier uniqueInstance! ! 369741IdentityDictionary subclass: #SystemDictionary 369742 instanceVariableNames: 'cachedClassNames' 369743 classVariableNames: 'LastImageName LastQuitLogPosition LowSpaceProcess LowSpaceSemaphore MemoryHogs ShutDownList SpecialSelectors StartUpList StartupStamp SystemChanges' 369744 poolDictionaries: '' 369745 category: 'System-Support'! 369746!SystemDictionary commentStamp: '<historical>' prior: 0! 369747I represent a special dictionary that supports protocol for asking questions about the structure of the system. Other than class names, I contain (print this)... 369748 Smalltalk keys select: [:k | ((Smalltalk at: k) isKindOf: Class) not] 369749 thenCollect: [:k | k -> (Smalltalk at: k) class] 369750! 369751 369752 369753!SystemDictionary methodsFor: 'accessing' stamp: 'ar 7/11/1999 21:56'! 369754organization 369755 "Return the organizer for the receiver" 369756 ^SystemOrganization! ! 369757 369758 369759!SystemDictionary methodsFor: 'class and trait names' stamp: 'al 1/12/2006 23:59'! 369760allClassesAndTraits 369761 "Return all the classes and traits defined in the Smalltalk SystemDictionary" 369762 369763 ^ self classNames , self traitNames collect: [:each | self at: each]! ! 369764 369765!SystemDictionary methodsFor: 'class and trait names' stamp: 'al 1/13/2006 00:15'! 369766allClassesAndTraitsDo: aBlock 369767 ^self allClassesAndTraits do: aBlock! ! 369768 369769!SystemDictionary methodsFor: 'class and trait names' stamp: 'al 1/12/2006 23:57'! 369770classNamed: className 369771 ^self classOrTraitNamed: className.! ! 369772 369773!SystemDictionary methodsFor: 'class and trait names' stamp: 'al 1/13/2006 00:51'! 369774classNames 369775 "Answer a SortedCollection of all class names." 369776 | names | 369777 cachedClassNames == nil ifTrue: 369778 [names := OrderedCollection new: self size. 369779 self do: 369780 [:cl | (cl isInMemory 369781 and: [(cl isKindOf: Class) 369782 and: [(cl name beginsWith: 'AnObsolete') not]]) 369783 ifTrue: [names add: cl name]]. 369784 cachedClassNames := names asSortedCollection]. 369785 ^ cachedClassNames! ! 369786 369787!SystemDictionary methodsFor: 'class and trait names' stamp: 'al 1/12/2006 23:56'! 369788classOrTraitNamed: aString 369789 "aString is either a class or trait name or a class or trait name followed by ' class' or 'classTrait' respectively. 369790 Answer the class or metaclass it names." 369791 369792 | meta baseName baseClass | 369793 (aString endsWith: ' class') 369794 ifTrue: [meta := true. 369795 baseName := aString copyFrom: 1 to: aString size - 6] 369796 ifFalse: [ 369797 (aString endsWith: ' classTrait') 369798 ifTrue: [ 369799 meta := true. 369800 baseName := aString copyFrom: 1 to: aString size - 11] 369801 ifFalse: [ 369802 meta := false. 369803 baseName := aString]]. 369804 baseClass := Smalltalk at: baseName asSymbol ifAbsent: [^ nil]. 369805 meta 369806 ifTrue: [^ baseClass classSide] 369807 ifFalse: [^ baseClass]! ! 369808 369809!SystemDictionary methodsFor: 'class and trait names' stamp: 'di 2/16/2000 10:28'! 369810flushClassNameCache 369811 "Smalltalk flushClassNameCache" 369812 "Forse recomputation of the cached list of class names." 369813 369814 cachedClassNames := nil! ! 369815 369816!SystemDictionary methodsFor: 'class and trait names' stamp: 'NS 1/27/2004 12:08'! 369817forgetClass: aClass logged: aBool 369818 "Delete the class, aClass, from the system. 369819 Note that this doesn't do everything required to dispose of a class - to do that use Class>>removeFromSystem." 369820 369821 aBool ifTrue: [SystemChangeNotifier uniqueInstance classRemoved: aClass fromCategory: aClass category]. 369822 SystemOrganization removeElement: aClass name. 369823 self removeFromStartUpList: aClass. 369824 self removeFromShutDownList: aClass. 369825 self removeKey: aClass name ifAbsent: []. 369826 self flushClassNameCache! ! 369827 369828!SystemDictionary methodsFor: 'class and trait names'! 369829hasClassNamed: aString 369830 "Answer whether there is a class of the given name, but don't intern aString if it's not alrady interned. 4/29/96 sw" 369831 369832 Symbol hasInterned: aString ifTrue: 369833 [:aSymbol | ^ (self at: aSymbol ifAbsent: [nil]) isKindOf: Class]. 369834 ^ false! ! 369835 369836!SystemDictionary methodsFor: 'class and trait names' stamp: 'sw 9/5/97 18:30'! 369837removeClassNamed: aName 369838 "Invoked from fileouts: if there is currently a class in the system named aName, then remove it. If anything untoward happens, report it in the Transcript. " 369839 369840 | oldClass | 369841 (oldClass := self at: aName asSymbol ifAbsent: [nil]) == nil 369842 ifTrue: 369843 [Transcript cr; show: 'Removal of class named ', aName, ' ignored because ', aName, ' does not exist.'. 369844 ^ self]. 369845 369846 oldClass removeFromSystem! ! 369847 369848!SystemDictionary methodsFor: 'class and trait names' stamp: 'sw 10/28/96'! 369849renameClassNamed: oldName as: newName 369850 "Invoked from fileouts: if there is currently a class in the system named oldName, then rename it to newName. If anything untoward happens, report it in the Transcript. " 369851 369852 | oldClass | 369853 (oldClass := self at: oldName asSymbol ifAbsent: [nil]) == nil 369854 ifTrue: 369855 [Transcript cr; show: 'Class-rename for ', oldName, ' ignored because ', oldName, ' does not exist.'. 369856 ^ self]. 369857 369858 oldClass rename: newName! ! 369859 369860!SystemDictionary methodsFor: 'class and trait names' stamp: 'rw 10/7/2006 08:34'! 369861renameClass: aClass as: newName 369862 "Rename the class, aClass, to have the title newName." 369863 "Original one I want to keep but needs to be fixed" 369864 369865 | oldref i oldName category | 369866 oldName := aClass name. 369867 category := aClass category. 369868 SystemOrganization classify: newName under: aClass category. 369869 SystemOrganization removeElement: aClass name. 369870 oldref := self associationAt: aClass name. 369871 self removeKey: aClass name. 369872 oldref key: newName. 369873 self add: oldref. "Old association preserves old refs" 369874 (Array with: StartUpList with: ShutDownList) do: 369875 [:list | i := list indexOf: aClass name ifAbsent: [0]. 369876 i > 0 ifTrue: [list at: i put: newName]]. 369877 self flushClassNameCache. 369878 SystemChangeNotifier uniqueInstance classRenamed: aClass from: oldName to: newName inCategory: category! ! 369879 369880!SystemDictionary methodsFor: 'class and trait names' stamp: 'al 1/12/2006 23:54'! 369881traitNames 369882 "Answer a SortedCollection of all traits (not including class-traits) names." 369883 | names | 369884 names := OrderedCollection new. 369885 self do: 369886 [:cl | (cl isInMemory 369887 and: [(cl isKindOf: Trait) 369888 and: [(cl name beginsWith: 'AnObsolete') not]]) 369889 ifTrue: [names add: cl name]]. 369890 ^ names! ! 369891 369892 369893!SystemDictionary methodsFor: 'class names' stamp: 'rw 10/17/2006 23:07'! 369894renameClass: aClass from: oldName 369895 "Rename the class, aClass, to have the title newName." 369896 | oldref i newName category | 369897 newName := aClass name. 369898 category := SystemOrganization categoryOfElement: oldName. 369899 SystemOrganization classify: newName under: category. 369900 SystemOrganization removeElement: oldName. 369901 oldref := self associationAt: oldName. 369902 self removeKey: oldName. 369903 oldref key: newName. 369904 self add: oldref. "Old association preserves old refs" 369905 (Array with: StartUpList with: ShutDownList) do: 369906 [:list | i := list indexOf: oldName ifAbsent: [0]. 369907 i > 0 ifTrue: [list at: i put: newName]]. 369908 self flushClassNameCache. 369909 369910 SystemChangeNotifier uniqueInstance classRenamed: aClass from: oldName to: newName inCategory: category! ! 369911 369912 369913!SystemDictionary methodsFor: 'copying' stamp: 'tk 10/20/2000 11:35'! 369914veryDeepCopyWith: deepCopier 369915 "Return self. I can't be copied. Do not record me."! ! 369916 369917 369918!SystemDictionary methodsFor: 'dictionary access' stamp: 'md 3/2/2006 22:01'! 369919associationOrUndeclaredAt: key 369920 "return an association or install in undeclared. Used for mating up ImageSegments." 369921 369922 ^ self associationAt: key ifAbsent: [ 369923 Undeclared at: key put: nil. 369924 Undeclared associationAt: key]! ! 369925 369926!SystemDictionary methodsFor: 'dictionary access'! 369927at: aKey put: anObject 369928 "Override from Dictionary to check Undeclared and fix up 369929 references to undeclared variables." 369930 | index element | 369931 (self includesKey: aKey) ifFalse: 369932 [self declare: aKey from: Undeclared. 369933 self flushClassNameCache]. 369934 super at: aKey put: anObject. 369935 ^ anObject! ! 369936 369937 369938!SystemDictionary methodsFor: 'housekeeping'! 369939cleanOutUndeclared 369940 Undeclared removeUnreferencedKeys! ! 369941 369942!SystemDictionary methodsFor: 'housekeeping' stamp: 'adrian_lienhard 7/18/2009 16:02'! 369943compressSources 369944 "Copy all the source file to a compressed file. Usually preceded by Smalltalk condenseSources." 369945 "The new file will be created in the default directory, and the code in openSources 369946 will try to open it if it is there, otherwise it will look for normal sources." 369947 "Smalltalk compressSources" 369948 369949 | f cfName cf | 369950 f := SourceFiles first. 369951 (SmalltalkImage current sourcesName endsWith: 'sources') 369952 ifTrue: [cfName := (SmalltalkImage current sourcesName allButLast: 7) , 'stc'] 369953 ifFalse: [self error: 'Hey, I thought the sources name ended with ''.sources''.']. 369954 cf := (CompressedSourceStream on: (FileStream newFileNamed: cfName)) 369955 segmentSize: 20000 maxSize: f size. 369956 369957 "Copy the sources" 369958'Compressing Sources File...' 369959 displayProgressAt: Sensor cursorPoint 369960 from: 0 to: f size 369961 during: 369962 [:bar | f position: 0. 369963 [f atEnd] whileFalse: 369964 [cf nextPutAll: (f next: 20000). 369965 bar value: f position]]. 369966 cf close. 369967 self setMacFileInfoOn: cfName. 369968 self inform: 'You now have a compressed sources file!! 369969Pharo will use it the next time you start.'! ! 369970 369971!SystemDictionary methodsFor: 'housekeeping' stamp: 'adrian-lienhard 5/27/2009 21:28'! 369972condenseChanges 369973 "Move all the changes onto a compacted sources file." 369974 "Smalltalk condenseChanges" 369975 | f oldChanges count | 369976 f := FileStream fileNamed: 'ST80.temp'. 369977 f header; timeStamp. 369978 'Condensing Changes File...' 369979 displayProgressAt: Sensor cursorPoint 369980 from: 0 369981 to: self classNames size + self traitNames size 369982 during: [:bar | 369983 count := 0. 369984 self 369985 allClassesAndTraitsDo: [:classOrTrait | 369986 bar value: (count := count + 1). 369987 classOrTrait moveChangesTo: f. 369988 classOrTrait putClassCommentToCondensedChangesFile: f. 369989 classOrTrait classSide moveChangesTo: f]]. 369990 SmalltalkImage current lastQuitLogPosition: f position. 369991 f trailer; close. 369992 oldChanges := SourceFiles at: 2. 369993 oldChanges close. 369994 FileDirectory default deleteFileNamed: oldChanges name , '.old'; 369995 rename: oldChanges name toBe: oldChanges name , '.old'; 369996 rename: f name toBe: oldChanges name. 369997 self setMacFileInfoOn: oldChanges name. 369998 SourceFiles 369999 at: 2 370000 put: (FileStream oldFileNamed: oldChanges name)! ! 370001 370002!SystemDictionary methodsFor: 'housekeeping' stamp: 'md 3/1/2006 00:02'! 370003condenseSources 370004 "Move all the changes onto a compacted sources file." 370005 "Smalltalk condenseSources" 370006 370007 | f dir newVersionString count | 370008 Utilities fixUpProblemsWithAllCategory. 370009 "The above removes any concrete, spurious '-- all --' categories, which mess up the process." 370010 dir := FileDirectory default. 370011 newVersionString := UIManager default request: 'Please designate the version 370012for the new source code file...' initialAnswer: SmalltalkImage current sourceFileVersionString. 370013 newVersionString ifNil: [^ self]. 370014 newVersionString = SmalltalkImage current sourceFileVersionString ifTrue: 370015 [^ self error: 'The new source file must not be the same as the old.']. 370016 SmalltalkImage current sourceFileVersionString: newVersionString. 370017 370018 "Write all sources with fileIndex 1" 370019 f := FileStream newFileNamed: SmalltalkImage current sourcesName. 370020 f header; timeStamp. 370021'Condensing Sources File...' 370022 displayProgressAt: Sensor cursorPoint 370023 from: 0 to: self classNames size + self traitNames size 370024 during: 370025 [:bar | count := 0. 370026 Smalltalk allClassesAndTraitsDo: 370027 [:classOrTrait | bar value: (count := count + 1). 370028 classOrTrait fileOutOn: f moveSource: true toFile: 1]]. 370029 f trailer; close. 370030 370031 "Make a new empty changes file" 370032 SmalltalkImage current closeSourceFiles. 370033 dir rename: SmalltalkImage current changesName 370034 toBe: SmalltalkImage current changesName , '.old'. 370035 (FileStream newFileNamed: SmalltalkImage current changesName) 370036 header; timeStamp; close. 370037 SmalltalkImage current lastQuitLogPosition: 0. 370038 370039 self setMacFileInfoOn: SmalltalkImage current changesName. 370040 self setMacFileInfoOn: SmalltalkImage current sourcesName. 370041 SmalltalkImage current openSourceFiles. 370042 self inform: 'Source files have been rewritten!! 370043Check that all is well, 370044and then save/quit.'! ! 370045 370046!SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 4/17/2003 20:59'! 370047forgetDoIts 370048 "Smalltalk forgetDoIts" 370049 "get rid of old DoIt methods" 370050 370051 self systemNavigation allBehaviorsDo: 370052 [:cl | cl forgetDoIts] 370053 370054! ! 370055 370056!SystemDictionary methodsFor: 'housekeeping' stamp: 'alain.plantec 6/11/2008 14:12'! 370057makeExternalRelease 370058 "Smalltalk makeExternalRelease" 370059 (self confirm: SystemVersion current version , ' 370060Is this the correct version designation? 370061If not, choose no, and fix it.') 370062 ifFalse: [^ self]. 370063 "Object classPool at: #DependentsFields" 370064 self reclaimDependents. 370065 Preferences enable: #fastDragWindowForMorphic. 370066 Smalltalk at: #Browser ifPresent:[:br| br initialize]. 370067 Undeclared isEmpty 370068 ifFalse: [self halt]. 370069 ScriptingSystem deletePrivateGraphics. 370070 #(#Helvetica #Palatino #Courier ) 370071 do: [:n | TextConstants 370072 removeKey: n 370073 ifAbsent: []]. 370074 (Utilities classPool at: #UpdateUrlLists) copy 370075 do: [:pair | (pair first includesSubstring: 'Disney' caseSensitive: false) 370076 ifTrue: [(Utilities classPool at: #UpdateUrlLists) 370077 remove: pair]]. 370078 (ServerDirectory serverNames copyWithoutAll: #('UCSBCreateArchive' 'UIUCArchive' 'UpdatesExtUIUC' 'UpdatesExtWebPage' )) 370079 do: [:sn | ServerDirectory removeServerNamed: sn]. 370080 self garbageCollect. 370081 self obsoleteClasses isEmpty 370082 ifFalse: [self halt]. 370083 Symbol rehash. 370084 self halt: 'Ready to condense changes or sources'! ! 370085 370086!SystemDictionary methodsFor: 'housekeeping' stamp: 'ar 9/27/2005 21:45'! 370087makeInternalRelease 370088 "Smalltalk makeInternalRelease" 370089 (self confirm: SystemVersion current version , ' 370090Is this the correct version designation? 370091If not, choose no, and fix it.') 370092 ifFalse: [^ self]. 370093 (Object classPool at: #DependentsFields) size > 1 370094 ifTrue: [self halt]. 370095 Smalltalk at: #Browser ifPresent:[:br| br initialize]. 370096 Undeclared isEmpty 370097 ifFalse: [self halt]. 370098 self garbageCollect. 370099 self obsoleteClasses isEmpty 370100 ifFalse: [self halt]. 370101 Symbol rehash. 370102 self halt: 'Ready to condense changes'. 370103 self condenseChanges! ! 370104 370105!SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 9/29/2004 18:15'! 370106reclaimDependents 370107 "No-opped due to weak dictionary in use" 370108 self garbageCollect! ! 370109 370110!SystemDictionary methodsFor: 'housekeeping' stamp: 'al 1/13/2006 00:19'! 370111reconstructChanges 370112 "Move all the changes and its histories onto another sources file." 370113 "Smalltalk reconstructChanges" 370114 370115 | f oldChanges classCount | 370116 f := FileStream fileNamed: 'ST80.temp'. 370117 f header; timeStamp. 370118'Condensing Changes File...' 370119 displayProgressAt: Sensor cursorPoint 370120 from: 0 to: self classNames size + self traitNames size 370121 during: 370122 [:bar | classCount := 0. 370123 Smalltalk allClassesAndTraitsDo: 370124 [:classOrTrait | bar value: (classCount := classCount + 1). 370125 classOrTrait moveChangesWithVersionsTo: f. 370126 classOrTrait putClassCommentToCondensedChangesFile: f. 370127 classOrTrait classSide moveChangesWithVersionsTo: f]]. 370128 SmalltalkImage current lastQuitLogPosition: f position. 370129 f trailer; close. 370130 oldChanges := SourceFiles at: 2. 370131 oldChanges close. 370132 FileDirectory default 370133 deleteFileNamed: oldChanges name , '.old'; 370134 rename: oldChanges name toBe: oldChanges name , '.old'; 370135 rename: f name toBe: oldChanges name. 370136 self setMacFileInfoOn: oldChanges name. 370137 SourceFiles at: 2 370138 put: (FileStream oldFileNamed: oldChanges name)! ! 370139 370140!SystemDictionary methodsFor: 'housekeeping' stamp: 'nk 6/2/2006 10:22'! 370141removeAllLineFeeds 370142 "Smalltalk removeAllLineFeeds" 370143 "Scan all methods for source code with lineFeeds. 370144 Replaces all occurrences of <CR><LF> or <LF> by <CR>. 370145 When done, offers to display an Inspector containing the message 370146 names grouped by author initials. 370147 In this dictionary, the key 'OK' contains the methods that had literals that contained <LF> characters." 370148 | n authors totalStripped totalOK | 370149 'Scanning sources for LineFeeds. 370150This will take a few minutes...' 370151 displayProgressAt: Sensor cursorPoint 370152 from: 0 370153 to: CompiledMethod instanceCount 370154 during: [:bar | 370155 n := 0. 370156 authors := self 370157 removeAllLineFeedsQuietlyCalling: [:cls :sel | (n := n + 1) \\ 100 = 0 370158 ifTrue: [bar value: n]]]. 370159 totalStripped := authors 370160 inject: 1 370161 into: [:sum :set | sum + set size]. 370162 totalOK := (authors at: 'OK') size. 370163 totalStripped := totalStripped - totalOK. 370164 Transcript cr; show: totalStripped printString , ' methods stripped of LFs.'. 370165 Transcript cr; show: totalOK printString , ' methods still correctly contain LFs.'. 370166 (self confirm: 'Do you want to see the affected methods?') 370167 ifTrue: [authors inspect]! ! 370168 370169!SystemDictionary methodsFor: 'housekeeping' stamp: 'nk 6/2/2006 08:35'! 370170removeAllLineFeedsQuietly 370171 "Smalltalk removeAllLineFeedsQuietly" 370172 "Scan all methods for source code with lineFeeds. 370173 Replaces all occurrences of <CR><LF> or <LF> by <CR>. 370174 Answer a Dictionary keyed by author name containing sets of affected method names, 370175 as well as (at the key 'OK') a list of methods that still contain LF characters inside literal strings or characters." 370176 ^self removeAllLineFeedsQuietlyCalling: [ :cls :sel | ].! ! 370177 370178!SystemDictionary methodsFor: 'housekeeping' stamp: 'nk 6/2/2006 09:22'! 370179removeAllLineFeedsQuietlyCalling: aBlock 370180 "Smalltalk removeAllLineFeedsQuietly" 370181 "Scan all methods for source code with lineFeeds. 370182 Replaces all occurrences of <CR><LF> or <LF> by <CR>. 370183 Answer a Dictionary keyed by author name containing sets of affected method names, 370184 as well as (at the key 'OK') a list of methods that still contain LF characters inside literal strings or characters. 370185 Evaluate aBlock for each method so that status can be updated." 370186 | oldCodeString newCodeString oldStamp oldCategory authors nameString | 370187 self forgetDoIts. 370188 authors := Dictionary new. 370189 authors at: 'OK' put: Set new. 370190 self systemNavigation 370191 allBehaviorsDo: [:cls | cls selectors 370192 do: [:selector | 370193 aBlock value: cls value: selector. 370194 oldCodeString := cls sourceCodeAt: selector. 370195 (oldCodeString includes: Character lf) 370196 ifTrue: [ 370197 newCodeString := oldCodeString withSqueakLineEndings. 370198 nameString := cls name , '>>' , selector. 370199 ((cls compiledMethodAt: selector) hasLiteralSuchThat: [ :lit | lit asString includes: Character lf ]) 370200 ifTrue: [(authors at: 'OK') 370201 add: nameString] 370202 ifFalse: [oldStamp := (Utilities 370203 timeStampForMethod: (cls compiledMethodAt: selector)) 370204 copy replaceAll: Character cr 370205 with: Character space. 370206 (authors 370207 at: (oldStamp copyFrom: 1 to: (oldStamp findFirst: [ :c | c isAlphaNumeric not ])) 370208 ifAbsentPut: [Set new]) 370209 add: nameString. 370210 oldCategory := cls whichCategoryIncludesSelector: selector. 370211 cls 370212 compile: newCodeString 370213 classified: oldCategory 370214 withStamp: oldStamp 370215 notifying: nil ]]]]. 370216 ^ authors! ! 370217 370218!SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 9/29/2004 18:15'! 370219removeEmptyMessageCategories 370220 "Smalltalk removeEmptyMessageCategories" 370221 self garbageCollect. 370222 (ClassOrganizer allInstances copyWith: SystemOrganization) 370223 do: [:org | org removeEmptyCategories]! ! 370224 370225!SystemDictionary methodsFor: 'housekeeping' stamp: 'alain.plantec 5/18/2009 16:00'! 370226testFormatter 370227 "Smalltalk testFormatter" 370228 370229 "Reformats the source for every method in the system, and 370230 then compiles that source and verifies that it generates 370231 identical code" 370232 370233 | newCodeString methodNode oldMethod newMethod badOnes n | 370234 badOnes := OrderedCollection new. 370235 self forgetDoIts. 370236 'Formatting all classes...' 370237 displayProgressAt: Sensor cursorPoint 370238 from: 0 370239 to: CompiledMethod instanceCount 370240 during: 370241 [:bar | 370242 n := 0. 370243 self systemNavigation allBehaviorsDo: 370244 [:cls | 370245 "Transcript cr; show: cls name." 370246 370247 cls selectors do: 370248 [:selector | 370249 (n := n + 1) \\ 100 = 0 ifTrue: [bar value: n]. 370250 newCodeString := cls prettyPrinterClass 370251 format: (cls sourceCodeAt: selector) 370252 in: cls 370253 notifying: nil. 370254 methodNode := cls compilerClass new 370255 compile: newCodeString 370256 in: cls 370257 notifying: nil 370258 ifFail: []. 370259 newMethod := methodNode generate: #(0 0 0 0). 370260 oldMethod := cls compiledMethodAt: selector. 370261 oldMethod = newMethod 370262 ifFalse: 370263 [Transcript 370264 cr; 370265 show: '***' , cls name , ' ' , selector. 370266 badOnes add: cls name , ' ' , selector]]]]. 370267 self systemNavigation browseMessageList: badOnes asSortedCollection 370268 name: 'Formatter Discrepancies'! ! 370269 370270!SystemDictionary methodsFor: 'housekeeping' stamp: 'alain.plantec 5/18/2009 16:00'! 370271testFormatter2 370272 "Smalltalk testFormatter2" 370273 370274 "Reformats the source for every method in the system, and 370275 then verifies that the order of source tokens is unchanged." 370276 370277 | newCodeString badOnes n oldCodeString oldTokens newTokens | 370278 badOnes := OrderedCollection new. 370279 self forgetDoIts. 370280 'Formatting all classes...' 370281 displayProgressAt: Sensor cursorPoint 370282 from: 0 370283 to: CompiledMethod instanceCount 370284 during: 370285 [:bar | 370286 n := 0. 370287 self systemNavigation allBehaviorsDo: 370288 [:cls | 370289 "Transcript cr; show: cls name." 370290 370291 cls selectors do: 370292 [:selector | 370293 (n := n + 1) \\ 100 = 0 ifTrue: [bar value: n]. 370294 oldCodeString := (cls sourceCodeAt: selector) asString. 370295 newCodeString := cls prettyPrinterClass 370296 format: oldCodeString 370297 in: cls 370298 notifying: nil. 370299 oldTokens := oldCodeString findTokens: Character separators. 370300 newTokens := newCodeString findTokens: Character separators. 370301 oldTokens = newTokens 370302 ifFalse: 370303 [Transcript 370304 cr; 370305 show: '***' , cls name , ' ' , selector. 370306 badOnes add: cls name , ' ' , selector]]]]. 370307 self systemNavigation browseMessageList: badOnes asSortedCollection 370308 name: 'Formatter Discrepancies'! ! 370309 370310!SystemDictionary methodsFor: 'housekeeping' stamp: 'sd 4/17/2003 21:01'! 370311verifyChanges "Smalltalk verifyChanges" 370312 "Recompile all methods in the changes file." 370313 self systemNavigation allBehaviorsDo: [:class | class recompileChanges]. 370314! ! 370315 370316 370317!SystemDictionary methodsFor: 'image, changes name' stamp: 'yo 3/29/2004 09:36'! 370318primImageName 370319 "Answer the full path name for the current image." 370320 "Smalltalk imageName" 370321 370322 <primitive: 121> 370323 self primitiveFailed! ! 370324 370325!SystemDictionary methodsFor: 'image, changes name' stamp: 'yo 3/29/2004 09:36'! 370326primImageName: newName 370327 "Set the the full path name for the current image. All further snapshots will use this." 370328 370329 <primitive: 121> 370330 ^ self primitiveFailed! ! 370331 370332!SystemDictionary methodsFor: 'image, changes name' stamp: 'yo 3/29/2004 09:36'! 370333primVmPath 370334 "Answer the path for the directory containing the Smalltalk virtual machine. Return the empty string if this primitive is not implemented." 370335 "Smalltalk vmPath" 370336 370337 <primitive: 142> 370338 ^ ''! ! 370339 370340 370341!SystemDictionary methodsFor: 'memory space'! 370342bytesLeft 370343 "Answer the number of bytes of space available. Does a full garbage collection." 370344 370345 ^ self garbageCollect 370346! ! 370347 370348!SystemDictionary methodsFor: 'memory space' stamp: 'ar 2/25/2001 18:00'! 370349bytesLeftString 370350 "Return a string describing the amount of memory available" 370351 | availInternal availPhysical availTotal | 370352 self garbageCollect. 370353 availInternal := self primBytesLeft. 370354 availPhysical := self bytesLeft: false. 370355 availTotal := self bytesLeft: true. 370356 (availTotal > (availInternal + 10000)) "compensate for mini allocations inbetween" 370357 ifFalse:[^availInternal asStringWithCommas, ' bytes available']. 370358 ^String streamContents:[:s| 370359 s nextPutAll: availInternal asStringWithCommas, ' bytes (internal) '; cr. 370360 s nextPutAll: availPhysical asStringWithCommas, ' bytes (physical) '; cr. 370361 s nextPutAll: availTotal asStringWithCommas, ' bytes (total) '].! ! 370362 370363!SystemDictionary methodsFor: 'memory space' stamp: 'ar 2/25/2001 17:55'! 370364bytesLeft: aBool 370365 "Return the amount of available space. If aBool is true, include possibly available swap space. If aBool is false, include possibly available physical memory. For a report on the largest free block currently availabe within Squeak memory but not counting extra memory use #primBytesLeft." 370366 <primitive: 112> 370367 ^self primBytesLeft! ! 370368 370369!SystemDictionary methodsFor: 'memory space'! 370370createStackOverflow 370371 "For testing the low space handler..." 370372 "Smalltalk installLowSpaceWatcher; createStackOverflow" 370373 370374 self createStackOverflow. "infinite recursion"! ! 370375 370376!SystemDictionary methodsFor: 'memory space' stamp: 'JMM 1/27/2005 13:23'! 370377forceTenure 370378 "Primitive. Tell the GC logic to force a tenure on the next increment GC." 370379 <primitive: 'primitiveForceTenure'> 370380 ^self primitiveFailed! ! 370381 370382!SystemDictionary methodsFor: 'memory space' stamp: 'ar 2/11/2001 02:36'! 370383garbageCollect 370384 "Primitive. Reclaims all garbage and answers the number of bytes of available space." 370385 Object flushDependents. 370386 Object flushEvents. 370387 ^self primitiveGarbageCollect! ! 370388 370389!SystemDictionary methodsFor: 'memory space'! 370390garbageCollectMost 370391 "Primitive. Reclaims recently created garbage (which is usually most of it) fairly quickly and answers the number of bytes of available space." 370392 370393 <primitive: 131> 370394 ^ self primBytesLeft! ! 370395 370396!SystemDictionary methodsFor: 'memory space'! 370397installLowSpaceWatcher 370398 "Start a process to watch for low-space conditions." 370399 "Smalltalk installLowSpaceWatcher" 370400 370401 self primSignalAtBytesLeft: 0. "disable low-space interrupts" 370402 LowSpaceProcess == nil ifFalse: [LowSpaceProcess terminate]. 370403 LowSpaceProcess := [self lowSpaceWatcher] newProcess. 370404 LowSpaceProcess priority: Processor lowIOPriority. 370405 LowSpaceProcess resume. 370406 370407! ! 370408 370409!SystemDictionary methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:46'! 370410isRoot: oop 370411 "Primitive. Answer whether the object is currently a root for youngSpace." 370412 <primitive: 'primitiveIsRoot'> 370413 ^self primitiveFailed! ! 370414 370415!SystemDictionary methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:47'! 370416isYoung: oop 370417 "Primitive. Answer whether the object currently resides in youngSpace." 370418 <primitive: 'primitiveIsYoung'> 370419 ^self primitiveFailed! ! 370420 370421!SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 16:49'! 370422lowSpaceThreshold 370423 "Return the low space threshold. When the amount of free memory (after garbage collection) falls below this limit, the system is in serious danger of completely exhausting memory and crashing. This limit should be made high enough to allow the user open a debugger to diagnose a problem or to save the image." 370424 370425 thisContext isPseudoContext 370426 ifTrue: [^ 400000 "Enough for JIT compiler"] 370427 ifFalse: [^ 200000 "Enough for interpreter"]! ! 370428 370429!SystemDictionary methodsFor: 'memory space' stamp: 'marcus.denker 2/19/2009 21:00'! 370430lowSpaceWatcher 370431 "Wait until the low space semaphore is signalled, then take appropriate 370432 actions. " 370433 | free preemptedProcess | 370434 self garbageCollectMost <= self lowSpaceThreshold 370435 ifTrue: [self garbageCollect <= self lowSpaceThreshold 370436 ifTrue: ["free space must be above threshold before 370437 starting low space watcher" 370438 ^ Beeper beep]]. 370439 Smalltalk specialObjectsArray at: 23 put: nil. 370440 "process causing low space will be saved here" 370441 LowSpaceSemaphore := Semaphore new. 370442 self primLowSpaceSemaphore: LowSpaceSemaphore. 370443 self primSignalAtBytesLeft: self lowSpaceThreshold. 370444 "enable low space interrupts" 370445 LowSpaceSemaphore wait. 370446 "wait for a low space condition..." 370447 self primSignalAtBytesLeft: 0. 370448 "disable low space interrupts" 370449 self primLowSpaceSemaphore: nil. 370450 LowSpaceProcess := nil. 370451 "The process that was active at the time of the low space interrupt." 370452 preemptedProcess := Smalltalk specialObjectsArray at: 23. 370453 Smalltalk specialObjectsArray at: 23 put: nil. 370454 "Note: user now unprotected until the low space watcher is re-installed" 370455 self memoryHogs isEmpty 370456 ifFalse: [free := self bytesLeft. 370457 self memoryHogs 370458 do: [:hog | hog freeSomeSpace]. 370459 self bytesLeft > free 370460 ifTrue: [^ self installLowSpaceWatcher]]. 370461 Project interruptName: 'Space is low' preemptedProcess: preemptedProcess! ! 370462 370463!SystemDictionary methodsFor: 'memory space' stamp: 'nk 10/28/2000 20:37'! 370464lowSpaceWatcherProcess 370465 ^LowSpaceProcess! ! 370466 370467!SystemDictionary methodsFor: 'memory space' stamp: 'sma 4/22/2000 19:03'! 370468memoryHogs 370469 "Answer the list of objects to notify with #freeSomeSpace if memory gets full." 370470 370471 ^ MemoryHogs ifNil: [MemoryHogs := OrderedCollection new]! ! 370472 370473!SystemDictionary methodsFor: 'memory space'! 370474okayToProceedEvenIfSpaceIsLow 370475 "Return true if either there is enough memory to do so safely or if the user gives permission after being given fair warning." 370476 370477 self garbageCollectMost > self lowSpaceThreshold ifTrue: [^ true]. "quick" 370478 self garbageCollect > self lowSpaceThreshold ifTrue: [^ true]. "work harder" 370479 370480 ^ self confirm: 370481'WARNING: There is not enough space to start the low space watcher. 370482If you proceed, you will not be warned again, and the system may 370483run out of memory and crash. If you do proceed, you can start the 370484low space notifier when more space becomes available simply by 370485opening and then closing a debugger (e.g., by hitting Cmd-period.) 370486Do you want to proceed?' 370487! ! 370488 370489!SystemDictionary methodsFor: 'memory space'! 370490primBytesLeft 370491 "Primitive. Answer the number of bytes available for new object data. 370492 Not accurate unless preceded by 370493 Smalltalk garbageCollectMost (for reasonable accuracy), or 370494 Smalltalk garbageCollect (for real accuracy). 370495 See Object documentation whatIsAPrimitive." 370496 370497 <primitive: 112> 370498 ^ 0! ! 370499 370500!SystemDictionary methodsFor: 'memory space' stamp: 'ar 2/11/2001 02:16'! 370501primitiveGarbageCollect 370502 "Primitive. Reclaims all garbage and answers the number of bytes of available space." 370503 370504 <primitive: 130> 370505 ^ self primBytesLeft! ! 370506 370507!SystemDictionary methodsFor: 'memory space'! 370508primLowSpaceSemaphore: aSemaphore 370509 "Primitive. Register the given Semaphore to be signalled when the 370510 number of free bytes drops below some threshold. Disable low-space 370511 interrupts if the argument is nil." 370512 370513 <primitive: 124> 370514 self primitiveFailed! ! 370515 370516!SystemDictionary methodsFor: 'memory space'! 370517primSignalAtBytesLeft: numBytes 370518 "Tell the interpreter the low-space threshold in bytes. When the free 370519 space falls below this threshold, the interpreter will signal the low-space 370520 semaphore, if one has been registered. Disable low-space interrupts if the 370521 argument is zero. Fail if numBytes is not an Integer." 370522 370523 <primitive: 125> 370524 self primitiveFailed! ! 370525 370526!SystemDictionary methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:48'! 370527rootTable 370528 "Primitive. Answer a snapshot of the VMs root table. 370529 Keep in mind that the primitive may itself cause GC." 370530 <primitive: 'primitiveRootTable'> 370531 ^self primitiveFailed! ! 370532 370533!SystemDictionary methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:49'! 370534rootTableAt: index 370535 "Primitive. Answer the nth element of the VMs root table" 370536 <primitive: 'primitiveRootTableAt'> 370537 ^nil! ! 370538 370539!SystemDictionary methodsFor: 'memory space' stamp: 'JMM 1/27/2005 12:27'! 370540setGCBiasToGrowGCLimit: aNumber 370541 "Primitive. Indicate that the bias to grow logic should do a GC after aNumber Bytes" 370542 <primitive: 'primitiveSetGCBiasToGrowGCLimit'> 370543 ^self primitiveFailed 370544"Example: 370545 Smalltalk setGCBiasToGrowGCLimit: 16*1024*1024. 370546"! ! 370547 370548!SystemDictionary methodsFor: 'memory space' stamp: 'JMM 1/27/2005 13:12'! 370549setGCBiasToGrow: aNumber 370550 "Primitive. Indicate that the GC logic should be bias to grow" 370551 <primitive: 'primitiveSetGCBiasToGrow'> 370552 ^self primitiveFailed 370553"Example: 370554 Smalltalk setGCBiasToGrowGCLimit: 16*1024*1024. 370555 Smalltalk setGCBiasToGrow: 1. 370556"! ! 370557 370558!SystemDictionary methodsFor: 'memory space' stamp: 'ar 1/18/2005 16:54'! 370559setGCSemaphore: semaIndex 370560 "Primitive. Indicate the GC semaphore index to be signaled on GC occurance." 370561 <primitive: 'primitiveSetGCSemaphore'> 370562 ^self primitiveFailed 370563"Example: 370564 370565 | index sema process | 370566 sema := Semaphore new. 370567 index := Smalltalk registerExternalObject: sema. 370568 Smalltalk setGCSemaphore: index. 370569 process := [ 370570 [[true] whileTrue:[ 370571 sema wait. 370572 Smalltalk beep. 370573 ]] ensure:[ 370574 Smalltalk setGCSemaphore: 0. 370575 Smalltalk unregisterExternalObject: sema. 370576 ]. 370577 ] fork. 370578 process inspect. 370579"! ! 370580 370581!SystemDictionary methodsFor: 'memory space'! 370582signalLowSpace 370583 "Signal the low-space semaphore to alert the user that space is running low." 370584 370585 LowSpaceSemaphore signal.! ! 370586 370587!SystemDictionary methodsFor: 'memory space' stamp: 'apb 10/3/2000 16:40'! 370588useUpMemory 370589 "For testing the low space handler..." 370590 "Smalltalk installLowSpaceWatcher; useUpMemory" 370591 370592 | lst | 370593 lst := nil. 370594 [true] whileTrue: [ 370595 lst := Link nextLink: lst. 370596 ].! ! 370597 370598!SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 21:15'! 370599useUpMemoryWithArrays 370600 "For testing the low space handler..." 370601 "Smalltalk installLowSpaceWatcher; useUpMemoryWithArrays" 370602 370603 | b | "First use up most of memory." 370604 b := String new: self bytesLeft - self lowSpaceThreshold - 100000. 370605 b := b. "Avoid unused value warning" 370606 (1 to: 10000) collect: [:i | Array new: 10000]! ! 370607 370608!SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 16:49'! 370609useUpMemoryWithContexts 370610 "For testing the low space handler..." 370611 "Smalltalk installLowSpaceWatcher; useUpMemoryWithContexts" 370612 370613 self useUpMemoryWithContexts! ! 370614 370615!SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 16:50'! 370616useUpMemoryWithTinyObjects 370617 "For testing the low space handler..." 370618 "Smalltalk installLowSpaceWatcher; useUpMemoryWithTinyObjects" 370619 370620 | b | "First use up most of memory." 370621 b := String new: self bytesLeft - self lowSpaceThreshold - 100000. 370622 b := b. "Avoid unused value warning" 370623 (1 to: 10000) collect: [:i | BitBlt new]! ! 370624 370625 370626!SystemDictionary methodsFor: 'miscellaneous'! 370627exitToDebugger 370628 "Primitive. Enter the machine language debugger, if one exists. Essential. 370629 See Object documentation whatIsAPrimitive." 370630 370631 <primitive: 114> 370632 self primitiveFailed! ! 370633 370634!SystemDictionary methodsFor: 'miscellaneous' stamp: 'alain.plantec 6/1/2008 20:41'! 370635handleUserInterrupt 370636 Preferences cmdDotEnabled ifTrue: 370637 [[Project interruptName: 'User Interrupt'] fork]! ! 370638 370639!SystemDictionary methodsFor: 'miscellaneous' stamp: 'AndrewBlack 9/1/2009 08:15'! 370640hasMorphic 370641 "Answer whether the Morphic classes are available in the 370642 system (they may have been stripped, such as by a call to 370643 Smalltalk removeMorphic" 370644 370645 ^ (self 370646 at: #Morph 370647 ifAbsent: []) 370648 isKindOf: Class! ! 370649 370650!SystemDictionary methodsFor: 'miscellaneous' stamp: 'Bill Schwab 9/8/2009 18:07'! 370651logError: errMsg inContext: aContext to: aFilename 370652 "Log the error message and a stack trace to the given file." 370653 370654 | ff | 370655 370656 "wks - 9-09 - do not delete existing errors. Note that this could be made 370657 conditional or left here in this state for those who want it. 370658 FileDirectory default deleteFileNamed: aFilename ifAbsent: []." 370659 (ff := FileStream fileNamed: aFilename) ifNil: [^ self "avoid recursive errors"]. 370660 370661 [ 370662 "9-09 - move to end." 370663 ff setToEnd. 370664 370665 "9-09 - write something easy to find to verify correct operation." 370666 ff nextPutAll:'THERE_BE_DRAGONS_HERE'; cr. 370667 370668 ff nextPutAll: errMsg; cr. 370669 aContext errorReportOn: ff. 370670 370671 "wks 9-09 - write some type of separator" 370672 ff nextPutAll:( String new:60 withAll:$- ); cr; cr. 370673 370674 ] ensure:[ 370675 ff close. 370676 ]. 370677! ! 370678 370679!SystemDictionary methodsFor: 'miscellaneous' stamp: 'yo 7/2/2004 13:32'! 370680m17nVersion 370681 370682 ^ 'M17n 5.0' copy 370683! ! 370684 370685!SystemDictionary methodsFor: 'miscellaneous' stamp: 'yo 7/2/2004 13:32'! 370686nihongoVersion 370687 370688 ^ 'Nihongo7.0' copy 370689! ! 370690 370691!SystemDictionary methodsFor: 'miscellaneous' stamp: 'John M McIntosh 3/2/2009 21:02'! 370692scopeFor: varName from: lower envtAndPathIfFound: envtAndPathBlock 370693 "Null compatibility with partitioning into environments." 370694 370695 370696 (self includesKey: varName) 370697 ifTrue: [^ envtAndPathBlock value: self value: String new] 370698 ifFalse: [^ nil]! ! 370699 370700!SystemDictionary methodsFor: 'miscellaneous' stamp: 'MPH 10/24/2000 14:27'! 370701setMacFileInfoOn: aString 370702 "On Mac, set the file type and creator (noop on other platforms)" 370703 FileDirectory default 370704 setMacFileNamed: aString 370705 type: 'STch' 370706 creator: 'FAST'.! ! 370707 370708!SystemDictionary methodsFor: 'miscellaneous' stamp: 'alain.plantec 6/19/2008 10:04'! 370709verifyMorphicAvailability 370710 "If Morphic is available, return true; if not, put up an informer and return false" 370711 self deprecated: #mvcIsRemoved. 370712 self hasMorphic ifFalse: 370713 [Beeper beep. 370714 self inform: 'Sorry, Morphic must 370715be present to use this feature'. 370716 ^ false]. 370717 ^ true! ! 370718 370719 370720!SystemDictionary methodsFor: 'objects from disk' stamp: 'tk 9/28/2000 15:50'! 370721objectForDataStream: refStrm 370722 | dp | 370723 "I am about to be written on an object file. Write a reference to Smalltalk instead." 370724 370725 dp := DiskProxy global: #Smalltalk selector: #yourself 370726 args: #(). 370727 refStrm replace: self with: dp. 370728 ^ dp! ! 370729 370730!SystemDictionary methodsFor: 'objects from disk' stamp: 'tk 3/7/2000 18:40'! 370731storeDataOn: aDataStream 370732 "I don't get stored. Use a DiskProxy" 370733 370734 self error: 'use a DiskProxy to store me'! ! 370735 370736 370737!SystemDictionary methodsFor: 'printing' stamp: 'stephane.ducasse 9/10/2008 21:36'! 370738isSelfEvaluating 370739 self == Smalltalk ifTrue: [^true]. 370740 ^super isSelfEvaluating! ! 370741 370742!SystemDictionary methodsFor: 'printing' stamp: 'sma 6/1/2000 09:53'! 370743printElementsOn: aStream 370744 aStream nextPutAll:'(lots of globals)'! ! 370745 370746!SystemDictionary methodsFor: 'printing' stamp: 'stephane.ducasse 9/10/2008 21:36'! 370747printOn: aStream 370748 self == Smalltalk ifFalse: [^super printOn: aStream]. 370749 aStream nextPutAll: 'Smalltalk'! ! 370750 370751 370752!SystemDictionary methodsFor: 'retrieving' stamp: 'sd 4/17/2003 21:15'! 370753allClasses 370754 "Return all the class defines in the Smalltalk SystemDictionary" 370755 "Smalltalk allClasses" 370756 370757 ^ self classNames collect: [:name | self at: name]! ! 370758 370759!SystemDictionary methodsFor: 'retrieving' stamp: 'sd 4/17/2003 21:18'! 370760allClassesDo: aBlock 370761 "Evaluate the argument, aBlock, for each class in the system." 370762 370763 (self classNames collect: [:name | self at: name]) do: aBlock! ! 370764 370765!SystemDictionary methodsFor: 'retrieving' stamp: 'al 2/23/2006 21:39'! 370766allTraits 370767 "Return all traits defined in the Smalltalk SystemDictionary" 370768 370769 ^ self traitNames collect: [:each | self at: each]! ! 370770 370771!SystemDictionary methodsFor: 'retrieving' stamp: 'sd 9/29/2004 18:17'! 370772poolUsers 370773 "Answer a dictionary of pool name -> classes that refer to it. 370774 Also includes any globally know dictionaries (such as 370775 Smalltalk, Undeclared etc) which although not strictly 370776 accurate is potentially useful information" 370777 "Smalltalk poolUsers" 370778 | poolUsers pool refs | 370779 poolUsers := Dictionary new. 370780 self keys 370781 do: [:k | "yes, using isKindOf: is tacky but for reflective code like 370782 this it is very useful. If you really object you can:- 370783 a) go boil your head. 370784 b) provide a better answer. 370785 your choice." 370786 (((pool := self at: k) isKindOf: Dictionary) 370787 or: [pool isKindOf: SharedPool class]) 370788 ifTrue: [refs := self systemNavigation allClasses 370789 select: [:c | c sharedPools identityIncludes: pool] 370790 thenCollect: [:c | c name]. 370791 refs 370792 add: (self systemNavigation 370793 allCallsOn: (self associationAt: k)). 370794 poolUsers at: k put: refs]]. 370795 ^ poolUsers! ! 370796 370797 370798!SystemDictionary methodsFor: 'shrinking' stamp: 'eem 7/1/2009 14:00'! 370799abandonSources 370800 "Smalltalk abandonSources" 370801 "Replaces every method by a copy with the 4-byte source pointer 370802 replaced by a string of all arg and temp names, followed by its 370803 length. These names can then be used to inform the decompiler." 370804 "wod 11/3/1998: zap the organization before rather than after 370805 condensing changes." 370806 "eem 7/1/2009 13:59 update for the closure schematic temp names regime" 370807 | oldMethods newMethods bTotal bCount | 370808 (self confirm: 'This method will preserve most temp names 370809(up to about 15k characters of temporaries) 370810while allowing the sources file to be discarded. 370811-- CAUTION -- 370812If you have backed up your system and 370813are prepared to face the consequences of 370814abandoning source code files, choose Yes. 370815If you have any doubts, you may choose No 370816to back out with no harm done.') 370817 == true 370818 ifFalse: [^ self inform: 'Okay - no harm done']. 370819 self forgetDoIts. 370820 oldMethods := OrderedCollection new: CompiledMethod instanceCount. 370821 newMethods := OrderedCollection new: CompiledMethod instanceCount. 370822 bTotal := 0. 370823 bCount := 0. 370824 self systemNavigation allBehaviorsDo: [:b | bTotal := bTotal + 1]. 370825 'Saving temp names for better decompilation...' 370826 displayProgressAt: Sensor cursorPoint 370827 from: 0 370828 to: bTotal 370829 during: 370830 [:bar | 370831 self systemNavigation allBehaviorsDo: 370832 [:cl | "for test: (Array with: Arc with: Arc class) do:" 370833 bar value: (bCount := bCount + 1). 370834 cl selectors do: 370835 [:selector | | m oldCodeString methodNode | 370836 m := cl compiledMethodAt: selector. 370837 m fileIndex > 0 ifTrue: 370838 [oldCodeString := cl sourceCodeAt: selector. 370839 methodNode := cl compilerClass new 370840 parse: oldCodeString 370841 in: cl 370842 notifying: nil. 370843 oldMethods addLast: m. 370844 newMethods addLast: (m copyWithTempsFromMethodNode: methodNode)]]]]. 370845 oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. 370846 self systemNavigation allBehaviorsDo: [:b | b zapOrganization]. 370847 self condenseChanges. 370848 Preferences disable: #warnIfNoSourcesFile! ! 370849 370850!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:18'! 370851abandonTempNames 370852 "Replaces every method by a copy with no source pointer or 370853 encoded temp names." 370854 "Smalltalk abandonTempNames" 370855 | continue oldMethods newMethods n m | 370856 continue := self confirm: '-- CAUTION -- 370857If you have backed up your system and 370858are prepared to face the consequences of 370859abandoning all source code, hit Yes. 370860If you have any doubts, hit No, 370861to back out with no harm done.'. 370862 continue 370863 ifFalse: [^ self inform: 'Okay - no harm done']. 370864 self forgetDoIts; garbageCollect. 370865 oldMethods := OrderedCollection new. 370866 newMethods := OrderedCollection new. 370867 n := 0. 370868 'Removing temp names to save space...' 370869 displayProgressAt: Sensor cursorPoint 370870 from: 0 370871 to: CompiledMethod instanceCount 370872 during: [:bar | self systemNavigation 370873 allBehaviorsDo: [:cl | cl selectors 370874 do: [:sel | 370875 bar value: (n := n + 1). 370876 m := cl compiledMethodAt: sel. 370877 oldMethods addLast: m. 370878 newMethods 370879 addLast: (m copyWithTrailerBytes: #(0 ))]]]. 370880 oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. 370881 SmalltalkImage current closeSourceFiles. 370882 self flag: #shouldUseAEnsureBlockToBeSureThatTheFileIsClosed. 370883 "sd: 17 April 2003" 370884 Preferences disable: #warnIfNoChangesFile. 370885 Preferences disable: #warnIfNoSourcesFile! ! 370886 370887!SystemDictionary methodsFor: 'shrinking' stamp: 'di 3/3/2001 08:31'! 370888cleanUpUndoCommands 370889 "Smalltalk cleanUpUndoCommands" "<== print this to get classes involved" 370890 370891 | classes i p | 370892 classes := Bag new. 370893 'Ferreting out obsolete undo commands' 370894 displayProgressAt: Sensor cursorPoint 370895 from: 0 to: Morph withAllSubclasses size 370896 during: 370897 [:bar | i := 0. 370898 Morph withAllSubclassesDo: 370899 [:c | bar value: (i := i+1). 370900 c allInstancesDo: 370901 [:m | (p := m otherProperties) ifNotNil: 370902 [p keys do: 370903 [:k | (p at: k) class == Command ifTrue: 370904 [classes add: c name. 370905 m removeProperty: k]]]]]]. 370906 ^ classes! ! 370907 370908!SystemDictionary methodsFor: 'shrinking' stamp: 'md 8/12/2008 22:15'! 370909computeImageSegmentation 370910 "Smalltalk computeImageSegmentation" 370911 "Here's how the segmentation works: 370912 For each partition, we collect the classes involved, and also all 370913 messages no longer used in the absence of this partition. We 370914 start by computing a 'Miscellaneous' segment of all the 370915 unused classes in the system as is." 370916 | partitions unusedCandM newClasses expandedCandM | 370917 partitions := Dictionary new. 370918 unusedCandM := self unusedClassesAndMethodsWithout: {{}. {}}. 370919 partitions at: 'Miscellaneous' put: unusedCandM. 370920 newClasses := Array 370921 streamContents: [:s | (SystemOrganization categoriesMatching: 'VMConstruction-*') 370922 do: [:cat | (SystemOrganization superclassOrder: cat) 370923 do: [:c | s nextPut: c name]]]. 370924 expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 370925 partitions at: 'VMConstruction' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 370926 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 370927 unusedCandM := expandedCandM. 370928 newClasses := Array 370929 streamContents: [:s | (SystemOrganization categoriesMatching: 'ST80-*') 370930 do: [:cat | (SystemOrganization superclassOrder: cat) 370931 do: [:c | s nextPut: c name]]]. 370932 expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 370933 partitions at: 'ST80' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 370934 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 370935 unusedCandM := expandedCandM. 370936 newClasses := Array 370937 streamContents: [:s | (SystemOrganization categoriesMatching: 'Morphic-Games') 370938 do: [:cat | (SystemOrganization superclassOrder: cat) 370939 do: [:c | s nextPut: c name]]]. 370940 expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 370941 partitions at: 'Games' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 370942 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 370943 unusedCandM := expandedCandM. 370944 newClasses := Array 370945 streamContents: [:s | (SystemOrganization categoriesMatching: 'Morphic-Remote') 370946 do: [:cat | (SystemOrganization superclassOrder: cat) 370947 do: [:c | s nextPut: c name]]]. 370948 expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 370949 partitions at: 'Nebraska' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 370950 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 370951 unusedCandM := expandedCandM. 370952 newClasses := Array 370953 streamContents: [:s | ((SystemOrganization categoriesMatching: 'Network-*') 370954 copyWithoutAll: #('Network-Kernel' 'Network-Url' 'Network-Protocols' 'Network-ObjectSocket' )) 370955 do: [:cat | (SystemOrganization superclassOrder: cat) 370956 do: [:c | s nextPut: c name]]]. 370957 expandedCandM := Smalltalk unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 370958 partitions at: 'Network' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 370959 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 370960 unusedCandM := expandedCandM. 370961 newClasses := Array 370962 streamContents: [:s | (SystemOrganization categoriesMatching: 'Balloon3D-*') 370963 do: [:cat | (SystemOrganization superclassOrder: cat) 370964 do: [:c | s nextPut: c name]]]. 370965 expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 370966 partitions at: 'Balloon3D' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 370967 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 370968 unusedCandM := expandedCandM. 370969 newClasses := Array 370970 streamContents: [:s | (SystemOrganization categoriesMatching: 'FFI-*') 370971 do: [:cat | (SystemOrganization superclassOrder: cat) 370972 do: [:c | s nextPut: c name]]]. 370973 expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 370974 partitions at: 'FFI' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 370975 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 370976 unusedCandM := expandedCandM. 370977 newClasses := Array 370978 streamContents: [:s | (SystemOrganization categoriesMatching: 'Genie-*') 370979 do: [:cat | (SystemOrganization superclassOrder: cat) 370980 do: [:c | s nextPut: c name]]]. 370981 expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 370982 partitions at: 'Genie' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 370983 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 370984 unusedCandM := expandedCandM. 370985 newClasses := Array 370986 streamContents: [:s | (SystemOrganization categoriesMatching: 'Speech-*') 370987 do: [:cat | (SystemOrganization superclassOrder: cat) 370988 do: [:c | s nextPut: c name]]]. 370989 expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 370990 partitions at: 'Speech' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 370991 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 370992 unusedCandM := expandedCandM. 370993 newClasses := Array 370994 streamContents: [:s | #('Morphic-Components' ) 370995 do: [:cat | (SystemOrganization superclassOrder: cat) 370996 do: [:c | s nextPut: c name]]]. 370997 expandedCandM := Smalltalk unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 370998 partitions at: 'Components' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 370999 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 371000 unusedCandM := expandedCandM. 371001 newClasses := Array 371002 streamContents: [:s | #('Sound-Scores' 'Sound-Interface' ) 371003 do: [:cat | (SystemOrganization superclassOrder: cat) 371004 do: [:c | s nextPut: c name]]]. 371005 newClasses := newClasses , #(#WaveletCodec #Sonogram #FWT #AIFFFileReader ). 371006 expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 371007 partitions at: 'Sound' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 371008 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 371009 unusedCandM := expandedCandM. 371010 newClasses := Array 371011 streamContents: [:s | ((SystemOrganization categoriesMatching: 'Tools-*') 371012 copyWithout: 'Tools-Menus') 371013 do: [:cat | (SystemOrganization superclassOrder: cat) 371014 do: [:c | s nextPut: c name]]]. 371015 newClasses := newClasses copyWithoutAll: #(#Debugger #Inspector #ContextVariablesInspector #SyntaxError #ChangeSet #ChangeRecord #ClassChangeRecord #ChangeList #VersionsBrowser ). 371016 expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 371017 partitions at: 'Tools' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 371018 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 371019 unusedCandM := expandedCandM. 371020 newClasses := Array 371021 streamContents: [:s | (SystemOrganization categoriesMatching: 'Balloon-MMFlash*') 371022 do: [:cat | (SystemOrganization superclassOrder: cat) 371023 do: [:c | s nextPut: c name]]]. 371024 newClasses := newClasses , #(#ADPCMCodec ). 371025 expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 371026 partitions at: 'Flash' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 371027 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 371028 unusedCandM := expandedCandM. 371029 newClasses := Array 371030 streamContents: [:s | (SystemOrganization categoriesMatching: 'Balloon-TrueType*') 371031 do: [:cat | (SystemOrganization superclassOrder: cat) 371032 do: [:c | s nextPut: c name]]]. 371033 expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 371034 partitions at: 'TrueType' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 371035 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 371036 unusedCandM := expandedCandM. 371037 newClasses := Array 371038 streamContents: [:s | (SystemOrganization categoriesMatching: 'Graphics-Files') 371039 do: [:cat | (SystemOrganization superclassOrder: cat) 371040 do: [:c | s nextPut: c name]]]. 371041 expandedCandM := self unusedClassesAndMethodsWithout: {unusedCandM first asArray , newClasses. unusedCandM second}. 371042 partitions at: 'GraphicFiles' put: {(expandedCandM first copyWithoutAll: unusedCandM first) addAll: newClasses; 371043 yourself. expandedCandM second copyWithoutAll: unusedCandM second}. 371044 unusedCandM := expandedCandM. 371045 #(#AliceConstants 'Balloon3D' #B3DEngineConstants 'Balloon3D' #WonderlandConstants 'Balloon3D' #FFIConstants 'FFI' #KlattResonatorIndices 'Speech' ) 371046 pairsDo: [:poolName :part | (partitions at: part) first add: poolName]. 371047 partitions 371048 keysDo: [:k | k = 'Miscellaneous' 371049 ifFalse: [(partitions at: 'Miscellaneous') first removeAllFoundIn: (partitions at: k) first]]. 371050 ^ partitions! ! 371051 371052!SystemDictionary methodsFor: 'shrinking' stamp: 'alain.plantec 6/10/2008 18:27'! 371053discardDiscards 371054 "Discard all discard* methods - including this one." 371055 371056 (self class selectors select: [:each | each beginsWith: 'discard']) 371057 do: [:each | self class removeSelector: each]. 371058 #(lastRemoval majorShrink) 371059 do: [:each | self class removeSelector: each]! ! 371060 371061!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:20'! 371062discardFFI 371063 "Discard the complete foreign function interface. 371064 NOTE: Recreates specialObjectsArray to prevent obsolete 371065 references. Has to specially remove external structure 371066 hierarchy before ExternalType" 371067 self 371068 at: #ExternalStructure 371069 ifPresent: [:cls | (ChangeSet superclassOrder: cls withAllSubclasses asArray) 371070 reverseDo: [:c | c removeFromSystem]]. 371071 SystemOrganization removeCategoriesMatching: 'FFI-*'. 371072 self recreateSpecialObjectsArray. 371073 "Remove obsolete refs" 371074 ByteArray removeSelector: #asExternalPointer. 371075 ByteArray removeSelector: #pointerAt:! ! 371076 371077!SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/5/2000 01:32'! 371078discardFlash 371079 "Discard Flash support." 371080 371081 SystemOrganization removeCategoriesMatching: 'Balloon-MMFlash*' 371082! ! 371083 371084!SystemDictionary methodsFor: 'shrinking' stamp: 'RAA 12/17/2000 16:50'! 371085discardMIDI 371086 371087 "this seems to have gone away"! ! 371088 371089!SystemDictionary methodsFor: 'shrinking' stamp: 'cwp 11/8/2002 13:38'! 371090discardNetworking 371091 "Discard the support for TCP/IP networking." 371092 371093 SystemOrganization removeCategoriesMatching: 'Network-*'. 371094 371095! ! 371096 371097!SystemDictionary methodsFor: 'shrinking' stamp: 'alain.plantec 6/19/2008 10:58'! 371098discardOddsAndEnds 371099 "This method throws out lots of classes that are not frequently 371100 used." 371101 "Smalltalk discardOddsAndEnds" 371102 self organization removeSystemCategory: 'System-Serial Port'. 371103 self organization removeSystemCategory: 'ST80-Symbols'. 371104 self organization removeSystemCategory: 'Tools-File Contents Browser'. 371105 self organization removeSystemCategory: 'System-Compression'. 371106 self organization removeSystemCategory: 'Tools-Explorer'. 371107 self organization removeSystemCategory: 'System-Digital Signatures'. 371108 self organization removeSystemCategory: 'ST80-Paths'. 371109 "bit editor (remove Form editor first):" 371110 Form removeSelector: #bitEdit. 371111 StrikeFont removeSelector: #edit:. 371112 self removeClassNamed: #FormButtonCache. 371113 self removeClassNamed: #FormMenuController. 371114 self removeClassNamed: #FormMenuView. 371115 "self removeClassNamed: #BitEditor." 371116 "inspector for Dictionaries of Forms" 371117 Dictionary removeSelector: #inspectFormsWithLabel:. 371118 SystemDictionary removeSelector: #viewImageImports. 371119 "experimental updating object viewer:" 371120 Object removeSelector: #evaluate:wheneverChangeIn:. 371121 self removeClassNamed: #ObjectViewer. 371122 self removeClassNamed: #ObjectTracer. 371123 "miscellaneous classes:" 371124 self removeClassNamed: #Array2D. 371125 self removeClassNamed: #DriveACar. 371126 self removeClassNamed: #EventRecorder. 371127 self removeClassNamed: #FindTheLight. 371128 self removeClassNamed: #PluggableTest. 371129 self removeClassNamed: #SystemMonitor. 371130 self removeClassNamed: #ProtocolBrowser. 371131 self removeClassNamed: #ObjectExplorerWrapper. 371132 self removeClassNamed: #HierarchyBrowser. 371133 self removeClassNamed: #LinkedMessageSet. 371134 self removeClassNamed: #ObjectExplorer. 371135 self removeClassNamed: #PackageBrowser. 371136 self removeClassNamed: #AbstractHierarchicalList. 371137 self removeClassNamed: #ChangeList. 371138 self removeClassNamed: #VersionsBrowser. 371139 self removeClassNamed: #ChangeRecord. 371140 self removeClassNamed: #SelectorBrowser. 371141 self removeClassNamed: #HtmlFileStream. 371142 self removeClassNamed: #CrLfFileStream. 371143 self removeClassNamed: #FXGrafPort. 371144 self removeClassNamed: #FXBlt. 371145 self 371146 at: #SampledSound 371147 ifPresent: [:c | c initialize]. 371148 #(#Helvetica #Palatino #Courier #ComicBold #ComicPlain ) 371149 do: [:k | TextConstants 371150 removeKey: k 371151 ifAbsent: []]. 371152 Preferences 371153 setButtonFontTo: (StrikeFont familyName: #NewYork size: 12). 371154 Preferences 371155 setFlapsFontTo: (StrikeFont familyName: #NewYork size: 12). 371156 #(#GZipConstants #ZipConstants #KlattResonatorIndices ) 371157 do: [:k | self 371158 removeKey: k 371159 ifAbsent: []]! ! 371160 371161!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:23'! 371162discardSoundSynthesis 371163 "Discard the sound synthesis facilities, and the methods and 371164 classes that use it. This also discards MIDI." 371165 self discardMIDI. 371166 self discardSpeech. 371167 SystemOrganization removeCategoriesMatching: 'Sound-Interface'. 371168 self 371169 at: #GraphMorph 371170 ifPresent: [:graphMorph | #(#playOnce #readDataFromFile ) 371171 do: [:sel | graphMorph removeSelector: sel]]. 371172 self 371173 at: #TrashCanMorph 371174 ifPresent: [:trashMorph | 371175 trashMorph class removeSelector: #samplesForDelete. 371176 trashMorph class removeSelector: #samplesForMouseEnter. 371177 trashMorph class removeSelector: #samplesForMouseLeave]. 371178 SystemOrganization removeCategoriesMatching: 'Sound-Synthesis'. 371179 SystemOrganization removeCategoriesMatching: 'Sound-Scores'! ! 371180 371181!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:23'! 371182discardSUnit 371183 "Smalltalk discardSUnit" 371184 | oc | 371185 oc := OrderedCollection new. 371186 (self 371187 at: #TestCase 371188 ifAbsent: [^ self]) 371189 allSubclassesWithLevelDo: [:c :i | oc addFirst: c] 371190 startingLevel: 0. 371191 oc 371192 do: [:c | c removeFromSystem]. 371193 SystemOrganization removeCategoriesMatching: 'SUnit-*'! ! 371194 371195!SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/5/2000 01:32'! 371196discardTrueType 371197 "Discard TrueType support." 371198 371199 SystemOrganization removeCategoriesMatching: 'Balloon-TrueType*'. 371200 371201! ! 371202 371203!SystemDictionary methodsFor: 'shrinking' stamp: 'stephane.ducasse 10/12/2008 20:55'! 371204lastRemoval 371205 "Smalltalk lastRemoval" 371206 "Some explicit removals - add unwanted methods keeping 371207 other methods." 371208 | oldDicts newDicts | 371209 #(#abandonSources ) 371210 do: [:each | self class removeSelector: each]. 371211 "Get rid of all unsent methods." 371212 [self removeAllUnsentMessages > 0] whileTrue. 371213 "Shrink method dictionaries." 371214 self garbageCollect. 371215 oldDicts := MethodDictionary allInstances. 371216 newDicts := Array new: oldDicts size. 371217 oldDicts 371218 withIndexDo: [:d :index | newDicts at: index put: d rehashWithoutBecome]. 371219 oldDicts elementsExchangeIdentityWith: newDicts. 371220 oldDicts := newDicts := nil. 371221 self 371222 allClassesDo: [:c | c zapOrganization]. 371223 SystemOrganization := nil. 371224 ChangeSet current initialize! ! 371225 371226!SystemDictionary methodsFor: 'shrinking' stamp: 'stephane.ducasse 3/31/2009 20:46'! 371227majorShrink 371228 "Undertake a major shrinkage of the image. 371229 This method throws out lots of the system that is not needed 371230 for, eg, operation in a hand-held PC. majorShrink produces a 371231 999k image in Squeak 2.8 371232 Smalltalk majorShrink; abandonSources; lastRemoval" 371233 | oldDicts newDicts | 371234 self error: 'You can only run majorShrink in MVC'. 371235 Project current isTopProject 371236 ifFalse: [^ self error: 'You can only run majorShrink in the top project']. 371237 (self confirm: 'All sub-projects will be deleted from this image. 371238You should already have made a backup copy, 371239or you must save with a different name after shrinking. 371240Shall we proceed to discard most of the content in this image?') 371241 ifFalse: [^ self inform: 'No changes have been made.']. 371242 "Remove all projects but the current one. - saves 522k" 371243 Project current setParent: Project current. 371244 MorphicModel removeUninstantiatedModels. 371245 Utilities classPool at: #ScrapsBook put: nil. 371246 Utilities zapUpdateDownloader. 371247 Project rebuildAllProjects. 371248 "Smalltalk discardVMConstruction." 371249 "755k" 371250 self discardSoundSynthesis. 371251 "544k" 371252 self discardOddsAndEnds. 371253 "227k" 371254 self discardNetworking. 371255 "234k" 371256 "Smalltalk discard3D." 371257 "407k" 371258 self discardFFI. 371259 "33k" 371260 self discardMorphic. 371261 "1372k" 371262 Symbol rehash. 371263 "40k" 371264 "Above by itself saves about 4,238k" 371265 "Remove references to a few classes to be deleted, so that they 371266 won't leave obsolete versions around." 371267 ChangeSet class compile: 'defaultName 371268 ^ ''Changes'' ' classified: 'initialization'. 371269 "Now delete various other classes.." 371270 SystemOrganization removeSystemCategory: 'Graphics-Files'. 371271 SystemOrganization removeSystemCategory: 'System-Object Storage'. 371272 "Smalltalk removeClassNamed: #Project." 371273 self removeClassNamed: #FormSetFont. 371274 self removeClassNamed: #FontSet. 371275 self removeClassNamed: #InstructionPrinter. 371276 self removeClassNamed: #ChangeSorter. 371277 self removeClassNamed: #DualChangeSorter. 371278 self removeClassNamed: #EmphasizedMenu. 371279 self removeClassNamed: #MessageTally. 371280 StringHolder class removeSelector: #originalWorkspaceContents. 371281 CompiledMethod removeSelector: #symbolic. 371282 RemoteString removeSelector: #makeNewTextAttVersion. 371283 self removeClassNamed: #PenPointRecorder. 371284 self removeClassNamed: #Path. 371285 self removeClassNamed: #Base64MimeConverter. 371286 self removeClassNamed: #RWBinaryOrTextStream. 371287 self removeClassNamed: #AttributedTextStream. 371288 self removeClassNamed: #WordNet. 371289 self removeClassNamed: #SelectorBrowser. 371290 TextStyle 371291 allSubInstancesDo: [:ts | ts 371292 newFontArray: (ts fontArray 371293 copyFrom: 1 371294 to: (2 min: ts fontArray size))]. 371295 ListParagraph initialize. 371296 PopUpMenu initialize. 371297 ChangeSet noChanges. 371298 ChangeSet classPool 371299 at: #AllChangeSets 371300 put: (OrderedCollection with: ChangeSet current). 371301 SystemDictionary removeSelector: #majorShrink. 371302 [self removeAllUnsentMessages > 0] 371303 whileTrue: [Smalltalk unusedClasses 371304 do: [:c | (Smalltalk at: c) removeFromSystem]]. 371305 SystemOrganization removeEmptyCategories. 371306 self 371307 allClassesDo: [:c | c zapOrganization]. 371308 self garbageCollect. 371309 'Rehashing method dictionaries . . .' 371310 displayProgressAt: Sensor cursorPoint 371311 from: 0 371312 to: MethodDictionary instanceCount 371313 during: [:bar | 371314 oldDicts := MethodDictionary allInstances. 371315 newDicts := Array new: oldDicts size. 371316 oldDicts 371317 withIndexDo: [:d :index | 371318 bar value: index. 371319 newDicts at: index put: d rehashWithoutBecome]. 371320 oldDicts elementsExchangeIdentityWith: newDicts]. 371321 oldDicts := newDicts := nil. 371322 Project rebuildAllProjects. 371323 ChangeSet current initialize. 371324 "seems to take more than one try to gc all the weak refs in 371325 SymbolTable " 371326 3 371327 timesRepeat: [self garbageCollect. 371328 Symbol compactSymbolTable]! ! 371329 371330!SystemDictionary methodsFor: 'shrinking' stamp: 'stephane.ducasse 10/26/2008 12:08'! 371331presumedSentMessages | sent | 371332"Smalltalk presumedSentMessages" 371333 371334 "The following should be preserved for doIts, etc" 371335 sent := IdentitySet new. 371336 #( rehashWithoutBecome compactSymbolTable rebuildAllProjects 371337 browseAllSelect: lastRemoval 371338 scrollBarValue: vScrollBarValue: scrollBarMenuButtonPressed: 371339 withSelectionFrom: to: removeClassNamed: 371340 dragon: hilberts: mandala: web factorial tinyBenchmarks benchFib 371341 newDepth: restoreAfter: forgetDoIts zapAllMethods obsoleteClasses 371342 removeAllUnsentMessages abandonSources removeUnreferencedKeys 371343 reclaimDependents zapOrganization condenseChanges browseObsoleteReferences 371344 subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: 371345 methodsFor:stamp: methodsFor:stamp:prior: instanceVariableNames: 371346 startTimerInterruptWatcher unusedClasses) do: 371347 [:sel | sent add: sel]. 371348 "The following may be sent by perform: in dispatchOnChar..." 371349 (ParagraphEditor classPool at: #CmdActions) asSet do: 371350 [:sel | sent add: sel]. 371351 (ParagraphEditor classPool at: #ShiftCmdActions) asSet do: 371352 [:sel | sent add: sel]. 371353 ^ sent! ! 371354 371355!SystemDictionary methodsFor: 'shrinking' stamp: 'stephane.ducasse 10/26/2008 12:08'! 371356removeAllUnsentMessages 371357 "Smalltalk removeAllUnsentMessages" 371358 "[Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]. 371359 Smalltalk removeAllUnSentMessages > 0] whileTrue." 371360 "Remove all implementations of unsent messages." 371361 | sels n | 371362 sels := self systemNavigation allUnSentMessages. 371363 "The following should be preserved for doIts, etc" 371364 "needed even after #majorShrink is pulled" 371365 #(#rehashWithoutBecome #compactSymbolTable #rebuildAllProjects #browseAllSelect: #lastRemoval #scrollBarValue: vScrollBarValue: #scrollBarMenuButtonPressed: #withSelectionFrom: #to: #removeClassNamed: #dragon: #hilberts: #mandala: #web #factorial #tinyBenchmarks #benchFib #newDepth: #restoreAfter: #forgetDoIts #zapAllMethods #obsoleteClasses #removeAllUnSentMessages #abandonSources #removeUnreferencedKeys #reclaimDependents #zapOrganization #condenseChanges #browseObsoleteReferences #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: #methodsFor:stamp: #methodsFor:stamp:prior: #instanceVariableNames: #startTimerInterruptWatcher #unusedClasses ) 371366 do: [:sel | sels 371367 remove: sel 371368 ifAbsent: []]. 371369 "The following may be sent by perform: in dispatchOnChar..." 371370 (ParagraphEditor classPool at: #CmdActions) asSet 371371 do: [:sel | sels 371372 remove: sel 371373 ifAbsent: []]. 371374 (ParagraphEditor classPool at: #ShiftCmdActions) asSet 371375 do: [:sel | sels 371376 remove: sel 371377 ifAbsent: []]. 371378 sels size = 0 371379 ifTrue: [^ 0]. 371380 n := 0. 371381 self systemNavigation 371382 allBehaviorsDo: [:x | n := n + 1]. 371383 'Removing ' , sels size printString , ' messages . . .' 371384 displayProgressAt: Sensor cursorPoint 371385 from: 0 371386 to: n 371387 during: [:bar | 371388 n := 0. 371389 self systemNavigation 371390 allBehaviorsDo: [:class | 371391 bar value: (n := n + 1). 371392 sels 371393 do: [:sel | class basicRemoveSelector: sel]]]. 371394 ^ sels size! ! 371395 371396!SystemDictionary methodsFor: 'shrinking' stamp: 'marcus.denker 2/8/2009 18:17'! 371397removeNormalCruft 371398 "Remove various graphics, uniclasses, references. Caution: see 371399 comment at bottom of method" 371400 "Smalltalk removeNormalCruft" 371401 ScriptingSystem stripGraphicsForExternalRelease. 371402 References keys 371403 do: [:k | References removeKey: k]. 371404 self classNames 371405 do: [:cName | #('Player' 'CardPlayer' 'Component' 'WonderlandActor' 'MorphicModel' 'PlayWithMe' ) 371406 do: [:superName | ((cName ~= superName 371407 and: [cName beginsWith: superName]) 371408 and: [(cName allButFirst: superName size) 371409 allSatisfy: [:ch | ch isDigit]]) 371410 ifTrue: [self removeClassNamed: cName]]]. 371411 self 371412 at: #Wonderland 371413 ifPresent: [:cls | cls removeActorPrototypesFromSystem]. 371414 ChangeSet current clear 371415 "Caution: if any worlds in the image happen to have uniclass 371416 players associated with them, running this method would 371417 likely compromise their functioning and could cause errors, 371418 especially if the uniclass player of the current world had any 371419 scripts set to ticking. If that happens to you somehow, you will 371420 probably want to find a way to reset the offending world's 371421 player to be an UnscriptedCardPlayer, or perhaps nil"! ! 371422 371423!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 9/29/2004 18:26'! 371424removeSelector: descriptor 371425 "Safely remove a selector from a class (or metaclass). If the 371426 class or the method doesn't exist anymore, never mind and 371427 answer nil. 371428 This method should be used instead of 'Class removeSelector: 371429 #method' to omit global class references." 371430 | class sel | 371431 class := self 371432 at: descriptor first 371433 ifAbsent: [^ nil]. 371434 (descriptor size > 2 371435 and: [descriptor second == #class]) 371436 ifTrue: [class := class class. 371437 sel := descriptor third] 371438 ifFalse: [sel := descriptor second]. 371439 ^ class removeSelector: sel! ! 371440 371441!SystemDictionary methodsFor: 'shrinking' stamp: 'di 2/25/2001 22:34'! 371442reportClassAndMethodRemovalsFor: collectionOfClassNames 371443 | initialClassesAndMethods finalClassesAndMethods | 371444 "Smalltalk reportClassAndMethodRemovalsFor: #(Celeste Scamper MailMessage)" 371445 371446 initialClassesAndMethods := self unusedClassesAndMethodsWithout: {{}. {}}. 371447 finalClassesAndMethods := self unusedClassesAndMethodsWithout: {collectionOfClassNames. {}}. 371448 ^ {finalClassesAndMethods first copyWithoutAll: initialClassesAndMethods first. 371449 finalClassesAndMethods second copyWithoutAll: initialClassesAndMethods second}! ! 371450 371451!SystemDictionary methodsFor: 'shrinking' stamp: 'sd 4/29/2003 19:06'! 371452unusedClasses 371453 "Enumerates all classes in the system and returns a list of those that are 371454 apparently unused. A class is considered in use if it (a) has subclasses 371455 or (b) is referred to by some method or (c) has its name in use as a 371456 literal. " 371457 "Smalltalk unusedClasses asSortedCollection" 371458 ^ self systemNavigation allUnusedClassesWithout: {{}. {}}! ! 371459 371460!SystemDictionary methodsFor: 'shrinking' stamp: 'alain.plantec 2/8/2009 22:52'! 371461unusedClassesAndMethodsWithout: classesAndMessagesPair 371462 "Accepts and returns a pair: {set of class names. set of selectors}. 371463 It is expected these results will be diff'd with the normally unused 371464 results. " 371465 | classRemovals messageRemovals nClasses nMessages | 371466 (classRemovals := IdentitySet new) addAll: classesAndMessagesPair first. 371467 (messageRemovals := IdentitySet new) addAll: classesAndMessagesPair second. 371468 nClasses := nMessages := -1. 371469 371470 [ "As long as we keep making progress..." 371471 classRemovals size > nClasses or: [ messageRemovals size > nMessages ] ] whileTrue: 371472 [ "...keep trying for bigger sets of unused classes and selectors." 371473 nClasses := classRemovals size. 371474 nMessages := messageRemovals size. 371475 UIManager default 371476 informUser: 'Iterating removals ' translated, (classesAndMessagesPair first isEmpty 371477 ifTrue: [ 'for baseline...' translated] 371478 ifFalse: [ 'for ' translated, classesAndMessagesPair first first , ' etc...' ]) , Character cr asString , nClasses printString , ' classes, ' , nMessages printString , ' messages. 371479| 371480|' 371481 during: 371482 [ "spacers move menu off cursor" 371483 classRemovals addAll: (self systemNavigation allUnusedClassesWithout: { 371484 classRemovals. 371485 messageRemovals 371486 }). 371487 messageRemovals addAll: (self systemNavigation allUnSentMessagesWithout: { 371488 classRemovals. 371489 messageRemovals 371490 }) ] ]. 371491 ^ { 371492 classRemovals. 371493 (self systemNavigation allUnSentMessagesWithout: { classRemovals. messageRemovals }) 371494 }! ! 371495 371496!SystemDictionary methodsFor: 'shrinking' stamp: 'marcus.denker 12/15/2008 12:18'! 371497writeImageSegmentsFrom: segmentDictionary withKernel: kernel 371498 "segmentDictionary is associates segmentName -> {classNames. methodNames}, 371499 and kernel is another set of classNames determined to be essential. 371500 Add a partition, 'Secondary' with everything not in partitions and not in the kernel. 371501 Then write segments based on this partitioning of classes." 371502 "First, put all classes that are in no other partition, and not in kernel into a new partition called 'Secondary'. Also remove any classes in kernel from putative partitions." 371503 | metas secondary dups segDict overlaps classes n symbolHolder | 371504 secondary := Smalltalk classNames asIdentitySet. 371505 segmentDictionary keysDo: 371506 [ :segName | 371507 secondary removeAllFoundIn: (segmentDictionary at: segName) first. 371508 (segmentDictionary at: segName) first removeAllFoundIn: kernel ]. 371509 secondary removeAllFoundIn: kernel. 371510 secondary removeAllFoundIn: #( 371511 #PseudoContext 371512 #Utilities 371513 #Preferences 371514 #OutOfScopeNotification 371515 #FakeClassPool 371516 #BlockCannotReturn 371517 #FormSetFont 371518 #ExternalSemaphoreTable 371519 #NetNameResolver 371520 #ScreenController 371521 #InterpreterPlugin 371522 #Command 371523 #WeakSet 371524 ). 371525 FileDirectory allSubclassesDo: 371526 [ :c | 371527 secondary 371528 remove: c name 371529 ifAbsent: [ ] ]. 371530 segmentDictionary 371531 at: 'Secondary' 371532 put: { secondary. { } }. 371533 371534 "Now build segDict giving className -> segName, and report any duplicates." 371535 dups := Dictionary new. 371536 segDict := IdentityDictionary new: 3000. 371537 segmentDictionary keysDo: 371538 [ :segName | 371539 (segmentDictionary at: segName) first do: 371540 [ :className | 371541 (segDict includesKey: className) ifTrue: 371542 [ (dups includesKey: className) ifFalse: 371543 [ dups 371544 at: className 371545 put: Array new ]. 371546 dups 371547 at: className 371548 put: (dups at: className) , { segName } ]. 371549 segDict 371550 at: className 371551 put: segName ] ]. 371552 dups size > 0 ifTrue: 371553 [ dups inspect. 371554 ^ self error: 'Duplicate entries' ]. 371555 371556 "Then for every class in every partition, make sure that neither it 371557 nor any of its superclasses are in any other partition. If they are, 371558 enter them in a dictionary of overlaps. 371559 If the dictionary is not empty, then stop and report it." 371560 overlaps := Dictionary new. 371561 segmentDictionary keysDo: 371562 [ :segName | 371563 classes := (segmentDictionary at: segName) first asArray collect: [ :k | Smalltalk at: k ]. 371564 classes do: 371565 [ :c | 371566 (c isKindOf: Class) ifTrue: 371567 [ c withAllSuperclasses do: 371568 [ :sc | 371569 n := segDict 371570 at: sc name 371571 ifAbsent: [ segName ]. 371572 n ~= segName ifTrue: 371573 [ n = 'Secondary' 371574 ifTrue: 371575 [ (segmentDictionary at: 'Secondary') first 371576 remove: sc name 371577 ifAbsent: [ ] ] 371578 ifFalse: 371579 [ overlaps 371580 at: c name 371581 put: (c withAllSuperclasses collect: 371582 [ :cc | 371583 segDict 371584 associationAt: cc name 371585 ifAbsent: [ cc name -> 'Kernel' ] ]) ] ] ] ] ] ]. 371586 overlaps size > 0 ifTrue: 371587 [ overlaps inspect. 371588 ^ self error: 'Superclasses in separate segments' ]. 371589 371590 "If there are no overlaps, then proceed to write the partitioned classes." 371591 symbolHolder := Symbol allSymbols. "Hold onto Symbols with strong pointers, 371592 so they will be in outPointers" 371593 segmentDictionary keysDo: 371594 [ :segName | 371595 UIManager default 371596 informUser: segName 371597 during: 371598 [ classes := (segmentDictionary at: segName) first asArray collect: [ :k | Smalltalk at: k ]. 371599 metas := classes 371600 select: [ :c | c isKindOf: Class ] 371601 thenCollect: [ :c | c class ]. 371602 (ImageSegment new 371603 copyFromRoots: classes , metas 371604 sizeHint: 0) 371605 extract; 371606 writeToFile: segName ] ]. 371607 symbolHolder "Keep compiler for getting uppity."! ! 371608 371609!SystemDictionary methodsFor: 'shrinking' stamp: 'stephane.ducasse 3/22/2009 10:47'! 371610zapAllOtherProjects 371611 "Smalltalk zapAllOtherProjects" 371612"Note: as of this writing, the only reliable way to get rid of all but the current project is te execute the following, one line at a time... 371613 Smalltalk zapAllOtherProjects. 371614 Smalltalk garbageCollect. 371615 Project rebuildAllProjects. 371616" 371617 371618 371619 Project allInstancesDo: [:p | p setParent: nil]. 371620 Project current setParent: Project current. 371621 TheWorldMenu allInstancesDo: [:m | 1 to: m class instSize do: [:i | m instVarAt: i put: nil]]. 371622 ChangeSet classPool at: #AllChangeSets put: nil. 371623 Project classPool at: #AllProjects put: nil. 371624 ChangeSet initialize. 371625 Project rebuildAllProjects. "Does a GC" 371626 Project allProjects size > 1 ifTrue: [Project allProjects inspect]! ! 371627 371628 371629!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/4/1999 15:38'! 371630addToShutDownList: aClass 371631 "This will add a ref to this class at the BEGINNING of the shutDown list." 371632 371633 self addToShutDownList: aClass after: nil! ! 371634 371635!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:04'! 371636addToShutDownList: aClass after: predecessor 371637 371638 self add: aClass toList: ShutDownList after: predecessor! ! 371639 371640!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/4/1999 15:37'! 371641addToStartUpList: aClass 371642 "This will add a ref to this class at the END of the startUp list." 371643 371644 self addToStartUpList: aClass after: nil! ! 371645 371646!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:04'! 371647addToStartUpList: aClass after: predecessor 371648 371649 self add: aClass toList: StartUpList after: predecessor! ! 371650 371651!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 11/19/1999 22:36'! 371652add: aClass toList: startUpOrShutDownList after: predecessor 371653 "Add the name of aClass to the startUp or shutDown list. 371654 Add it after the name of predecessor, or at the end if predecessor is nil." 371655 371656 | name earlierName | 371657 name := aClass name. 371658 (self at: name ifAbsent: [nil]) == aClass ifFalse: 371659 [self error: name , ' cannot be found in Smalltalk dictionary.']. 371660 predecessor == nil 371661 ifTrue: ["No-op if alredy in the list." 371662 (startUpOrShutDownList includes: name) ifFalse: 371663 [startUpOrShutDownList == StartUpList 371664 ifTrue: ["Add to end of startUp list" 371665 startUpOrShutDownList addLast: name] 371666 ifFalse: ["Add to front of shutDown list" 371667 startUpOrShutDownList addFirst: name]]] 371668 ifFalse: ["Add after predecessor, moving it if already there." 371669 earlierName := predecessor name. 371670 (self at: earlierName) == predecessor ifFalse: 371671 [self error: earlierName , ' cannot be found in Smalltalk dictionary.']. 371672 (startUpOrShutDownList includes: earlierName) ifFalse: 371673 [self error: earlierName , ' cannot be found in the list.']. 371674 startUpOrShutDownList remove: name ifAbsent:[]. 371675 startUpOrShutDownList add: name after: earlierName]! ! 371676 371677!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'alain.plantec 6/11/2008 07:36'! 371678isMorphic 371679 "Answer true if the user interface is running in Morphic rathern than 371680 MVC. By convention the gloabl variable World is set to nil when MVC is 371681 running. ScheduledControllers could be set to nil when Morphic is 371682 running, but this symmetry is not yet in effect." 371683 self deprecated: #mvcIsRemoved. 371684 ^ World ~~ nil"or: [RequestCurrentWorldNotification signal notNil]"! ! 371685 371686!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 11/16/1999 20:12'! 371687processShutDownList: quitting 371688 "Send #shutDown to each class that needs to wrap up before a snapshot." 371689 371690 self send: #shutDown: toClassesNamedIn: ShutDownList with: quitting. 371691! ! 371692 371693!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 11/16/1999 20:12'! 371694processStartUpList: resuming 371695 "Send #startUp to each class that needs to run initialization after a snapshot." 371696 371697 self send: #startUp: toClassesNamedIn: StartUpList with: resuming. 371698! ! 371699 371700!SystemDictionary methodsFor: 'snapshot and quit'! 371701quitPrimitive 371702 "Primitive. Exit to another operating system on the host machine, if one 371703 exists. All state changes in the object space since the last snapshot are lost. 371704 Essential. See Object documentation whatIsAPrimitive." 371705 371706 <primitive: 113> 371707 self primitiveFailed! ! 371708 371709!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:22'! 371710removeFromShutDownList: aClass 371711 371712 ShutDownList remove: aClass name ifAbsent: []! ! 371713 371714!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:22'! 371715removeFromStartUpList: aClass 371716 371717 StartUpList remove: aClass name ifAbsent: []! ! 371718 371719!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'adrian_lienhard 7/18/2009 16:02'! 371720send: startUpOrShutDown toClassesNamedIn: startUpOrShutDownList with: argument 371721 "Send the message #startUp: or #shutDown: to each class named in the list. 371722 The argument indicates if the system is about to quit (for #shutDown:) or if 371723 the image is resuming (for #startUp:). 371724 If any name cannot be found, then remove it from the list." 371725 371726 | removals class | 371727 removals := OrderedCollection new. 371728 startUpOrShutDownList do: 371729 [:name | 371730 class := self at: name ifAbsent: [nil]. 371731 class == nil 371732 ifTrue: [removals add: name] 371733 ifFalse: [class isInMemory ifTrue: 371734 [[class perform: startUpOrShutDown with: argument] 371735 on: Exception 371736 do: [:ex | SmalltalkImage current hasDisplay 371737 ifTrue: [ex pass] 371738 ifFalse: [Smalltalk 371739 at: #Console 371740 ifPresent: [:console | console printNl: ex description]. 371741 Smalltalk 371742 logError: ex printString 371743 inContext: thisContext 371744 to: 'PharoDebug.log']]]]]. 371745 371746 "Remove any obsolete entries, but after the iteration" 371747 startUpOrShutDownList removeAll: removals! ! 371748 371749!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'marcus.denker 11/8/2008 17:10'! 371750setGCParameters 371751 "Adjust the VM's default GC parameters to avoid premature tenuring." 371752 371753 SmalltalkImage current vmParameterAt: 5 put: 4000. "do an incremental GC after this many allocations" 371754 SmalltalkImage current vmParameterAt: 6 put: 2000. "tenure when more than this many objects survive the GC" 371755 Smalltalk setGCBiasToGrowGCLimit: 16*1024*1024. 371756 Smalltalk setGCBiasToGrow: 1. 371757! ! 371758 371759!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'sd 11/16/2003 13:14'! 371760shutDown 371761 ^ SmalltalkImage current closeSourceFiles! ! 371762 371763!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'gk 2/23/2004 20:51'! 371764shutDownSound 371765 "No longer used in the release, but retained for backward compatibility." 371766 371767 SoundService default shutDown 371768! ! 371769 371770!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'JMM 11/21/2000 21:02'! 371771snapshotEmbeddedPrimitive 371772 <primitive: 247> 371773 ^nil "indicates error writing embedded image file"! ! 371774 371775!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 7/22/2000 14:34'! 371776snapshotPrimitive 371777 "Primitive. Write the current state of the object memory on a file in the 371778 same format as the Smalltalk-80 release. The file can later be resumed, 371779 returning you to this exact state. Return normally after writing the file. 371780 Essential. See Object documentation whatIsAPrimitive." 371781 371782 <primitive: 97> 371783 ^nil "indicates error writing image file"! ! 371784 371785 371786!SystemDictionary methodsFor: 'sources, change log' stamp: 'em 3/31/2005 11:48'! 371787currentChangeSetString 371788 "Smalltalk currentChangeSetString" 371789 ^ 'Current Change Set: ' translated, ChangeSet current name! ! 371790 371791!SystemDictionary methodsFor: 'sources, change log' stamp: 'sd 9/29/2004 18:27'! 371792currentProjectDo: aBlock 371793 "So that code can work after removal of Projects" 371794 self 371795 at: #Project 371796 ifPresent: [:projClass | aBlock value: projClass current]! ! 371797 371798!SystemDictionary methodsFor: 'sources, change log' stamp: 'sd 11/16/2003 12:55'! 371799externalizeSources 371800 "Write the sources and changes streams onto external files." 371801 "Smalltalk externalizeSources" 371802 "the logic of this method is complex because it uses changesName and self changesName 371803 may be this is normal - sd" 371804 371805 | sourcesName changesName aFile | 371806 sourcesName := SmalltalkImage current sourcesName. 371807 (FileDirectory default fileExists: sourcesName) 371808 ifTrue: [^ self inform: 371809'Sorry, you must first move or remove the 371810file named ', sourcesName]. 371811 changesName := SmalltalkImage current changesName. 371812 (FileDirectory default fileExists: changesName) 371813 ifTrue: [^ self inform: 371814'Sorry, you must first move or remove the 371815file named ', changesName]. 371816 371817 aFile := FileStream newFileNamed: sourcesName. 371818 aFile nextPutAll: SourceFiles first originalContents. 371819 aFile close. 371820 self setMacFileInfoOn: sourcesName. 371821 SourceFiles at: 1 put: (FileStream readOnlyFileNamed: sourcesName). 371822 371823 aFile := FileStream newFileNamed: SmalltalkImage current changesName. 371824 aFile nextPutAll: SourceFiles last contents. 371825 aFile close. 371826 "On Mac, set the file type and creator (noop on other platforms)" 371827 FileDirectory default 371828 setMacFileNamed: SmalltalkImage current changesName 371829 type: 'STch' 371830 creator: 'FAST'. 371831 SourceFiles at: 2 put: (FileStream oldFileNamed: changesName). 371832 371833 self inform: 'Sources successfully externalized'. 371834! ! 371835 371836!SystemDictionary methodsFor: 'sources, change log' stamp: 'ar 2/6/2001 18:42'! 371837forceChangesToDisk 371838 "Ensure that the changes file has been fully written to disk by closing and re-opening it. This makes the system more robust in the face of a power failure or hard-reboot." 371839 371840 | changesFile | 371841 changesFile := SourceFiles at: 2. 371842 (changesFile isKindOf: FileStream) ifTrue: [ 371843 changesFile flush. 371844 SecurityManager default hasFileAccess ifTrue:[ 371845 changesFile close. 371846 changesFile open: changesFile name forWrite: true]. 371847 changesFile setToEnd. 371848 ]. 371849! ! 371850 371851!SystemDictionary methodsFor: 'sources, change log' stamp: 'sd 11/16/2003 12:55'! 371852internalizeChangeLog 371853 "Smalltalk internalizeChangeLog" 371854 "Bring the changes file into a memory-resident filestream, for faster access and freedom from external file system. 1/31/96 sw" 371855 371856 | reply aName aFile | 371857 reply := self confirm: 'CAUTION -- do not undertake this lightly!! 371858If you have backed up your system and 371859are prepared to face the consequences of 371860the requested internalization of sources, 371861hit Yes. If you have any doubts, hit No 371862to back out with no harm done.'. 371863 371864 (reply == true) ifFalse: 371865 [^ self inform: 'Okay - abandoned']. 371866 371867 aName := SmalltalkImage current changesName. 371868 (aFile := SourceFiles last) == nil ifTrue: 371869 [(FileDirectory default fileExists: aName) 371870 ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.']. 371871 aFile := FileStream readOnlyFileNamed: aName]. 371872 SourceFiles at: 2 put: (ReadWriteStream with: aFile contentsOfEntireFile). 371873 371874 self inform: 'Okay, changes file internalized'! ! 371875 371876!SystemDictionary methodsFor: 'sources, change log' stamp: 'sd 11/16/2003 12:55'! 371877internalizeSources 371878 "Smalltalk internalizeSources" 371879 "Bring the sources and changes files into memory-resident filestreams, for faster access and freedom from file-system interface. 1/29/96 sw" 371880 371881 | reply aName aFile | 371882 reply := self confirm: 'CAUTION -- do not undertake this lightly!! 371883If you have backed up your system and 371884are prepared to face the consequences of 371885the requested internalization of sources, 371886hit Yes. If you have any doubts, hit No 371887to back out with no harm done.'. 371888 371889 (reply == true) ifFalse: 371890 [^ self inform: 'Okay - abandoned']. 371891 371892 aName := SmalltalkImage current sourcesName. 371893 (aFile := SourceFiles first) == nil ifTrue: 371894 [(FileDirectory default fileExists: aName) 371895 ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.']. 371896 aFile := FileStream readOnlyFileNamed: aName]. 371897 SourceFiles at: 1 put: (ReadWriteStream with: aFile contentsOfEntireFile). 371898 371899 aName := SmalltalkImage current changesName. 371900 (aFile := SourceFiles last) == nil ifTrue: 371901 [(FileDirectory default fileExists: aName) 371902 ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.']. 371903 aFile := FileStream readOnlyFileNamed: aName]. 371904 SourceFiles at: 2 put: (ReadWriteStream with: aFile contentsOfEntireFile). 371905 371906 self inform: 'Okay, sources internalized'! ! 371907 371908!SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/3/2000 15:59'! 371909recover: nCharacters 371910 "Schedule an editable text view on the last n characters of changes." 371911 self writeRecentCharacters: nCharacters toFileNamed: 'st80.recent'! ! 371912 371913!SystemDictionary methodsFor: 'sources, change log' stamp: 'md 5/16/2006 12:34'! 371914version 371915 "Answer the version of this release." 371916 371917 ^SystemVersion current version! ! 371918 371919!SystemDictionary methodsFor: 'sources, change log' stamp: 'JMM 4/13/2005 20:35'! 371920wordSize 371921 "Answer the size (in bytes) of an object pointer." 371922 "Smalltalk wordSize" 371923 371924 ^[SmalltalkImage current vmParameterAt: 40] on: Error do: [4]! ! 371925 371926!SystemDictionary methodsFor: 'sources, change log' stamp: 'adrian-lienhard 5/27/2009 21:28'! 371927writeRecentCharacters: nCharacters toFileNamed: aFilename 371928 "Schedule an editable text view on the last n characters of changes." 371929 | changes | 371930 changes := SourceFiles at: 2. 371931 changes setToEnd; skip: nCharacters negated. 371932 (FileStream newFileNamed: aFilename) nextPutAll: (changes next: nCharacters); close; open; edit! ! 371933 371934!SystemDictionary methodsFor: 'sources, change log' stamp: 'ar 9/27/2005 22:38'! 371935writeRecentToFile 371936 "Smalltalk writeRecentToFile" 371937 | numChars aDirectory aFileName | 371938 aDirectory := FileDirectory default. 371939 aFileName := Utilities 371940 keyLike: 'squeak-recent.01' 371941 withTrailing: '.log' 371942 satisfying: [:aKey | (aDirectory includesKey: aKey) not]. 371943 numChars := ChangeSet getRecentLocatorWithPrompt: 'copy logged source as far back as...'. 371944 numChars 371945 ifNotNil: [self writeRecentCharacters: numChars toFileNamed: aFileName]! ! 371946 371947 371948!SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:36'! 371949clearExternalObjects 371950 "Clear the array of objects that have been registered for use in non-Smalltalk code." 371951 "Smalltalk clearExternalObjects" 371952 371953 ExternalSemaphoreTable clearExternalObjects 371954! ! 371955 371956!SystemDictionary methodsFor: 'special objects' stamp: 'sd 9/29/2004 18:30'! 371957compactClassesArray 371958 "Smalltalk compactClassesArray" 371959 "Return the array of 31 classes whose instances may be 371960 represented compactly" 371961 ^ self specialObjectsArray at: 29! ! 371962 371963!SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 21:01'! 371964externalObjects 371965 "Return an array of objects that have been registered for use in non-Smalltalk code. Smalltalk objects should be referrenced by external code only via indirection through this array, thus allowing the objects to move during compaction. This array can be cleared when the VM re-starts, since variables in external code do not survive snapshots. Note that external code should not attempt to access a Smalltalk object, even via this mechanism, while garbage collection is in progress." 371966 "Smalltalk externalObjects" 371967 371968 ^ ExternalSemaphoreTable externalObjects 371969! ! 371970 371971!SystemDictionary methodsFor: 'special objects'! 371972hasSpecialSelector: aLiteral ifTrueSetByte: aBlock 371973 371974 1 to: self specialSelectorSize do: 371975 [:index | 371976 (self specialSelectorAt: index) == aLiteral 371977 ifTrue: [aBlock value: index + 16rAF. ^true]]. 371978 ^false! ! 371979 371980!SystemDictionary methodsFor: 'special objects' stamp: 'marcus.denker 6/5/2009 11:16'! 371981recreateSpecialObjectsArray 371982 "Smalltalk recreateSpecialObjectsArray" 371983 "The Special Objects Array is an array of object pointers used 371984 by the 371985 Squeak virtual machine. Its contents are critical and 371986 unchecked, so don't even think of playing here unless you 371987 know what you are doing." 371988 | newArray | 371989 newArray := Array new: 50. 371990 "Nil false and true get used throughout the interpreter" 371991 newArray at: 1 put: nil. 371992 newArray at: 2 put: false. 371993 newArray at: 3 put: true. 371994 "This association holds the active process (a ProcessScheduler)" 371995 newArray at: 4 put: (self associationAt: #Processor). 371996 "Numerous classes below used for type checking and instantiation" 371997 newArray at: 5 put: Bitmap. 371998 newArray at: 6 put: SmallInteger. 371999 newArray at: 7 put: ByteString. 372000 newArray at: 8 put: Array. 372001 newArray at: 9 put: Smalltalk. 372002 newArray at: 10 put: Float. 372003 newArray at: 11 put: MethodContext. 372004 newArray at: 12 put: BlockContext. 372005 newArray at: 13 put: Point. 372006 newArray at: 14 put: LargePositiveInteger. 372007 newArray at: 15 put: Display. 372008 newArray at: 16 put: Message. 372009 newArray at: 17 put: CompiledMethod. 372010 newArray at: 18 put: (self specialObjectsArray at: 18). 372011 "(low space Semaphore)" 372012 newArray at: 19 put: Semaphore. 372013 newArray at: 20 put: Character. 372014 newArray at: 21 put: #doesNotUnderstand:. 372015 newArray at: 22 put: #cannotReturn:. 372016 newArray at: 23 put: nil. 372017 "An array of the 32 selectors that are compiled as special bytecodes, 372018 paired alternately with the number of arguments each takes." 372019 newArray at: 24 put: #( #+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1 372020 #* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1 372021 #at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0 372022 #blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ). 372023 "An array of the 255 Characters in ascii order." 372024 newArray at: 25 put: ((0 to: 255) collect: [:ascii | Character value: ascii]). 372025 newArray at: 26 put: #mustBeBoolean. 372026 newArray at: 27 put: ByteArray. 372027 newArray at: 28 put: Process. 372028 "An array of up to 31 classes whose instances will have compact headers" 372029 newArray at: 29 put: self compactClassesArray. 372030 newArray at: 30 put: (self specialObjectsArray at: 30). 372031 "(delay Semaphore)" 372032 newArray at: 31 put: (self specialObjectsArray at: 31). 372033 "(user interrupt Semaphore)" 372034 "Prototype instances that can be copied for fast initialization" 372035 newArray at: 32 put: (Float new: 2). 372036 newArray at: 33 put: (LargePositiveInteger new: 4). 372037 newArray at: 34 put: Point new. 372038 newArray at: 35 put: #cannotInterpret:. 372039 "Note: This must be fixed once we start using context prototypes (yeah, right)" 372040 "(MethodContext new: CompiledMethod fullFrameSize)." 372041 newArray at: 36 put: (self specialObjectsArray at: 36). "Is the prototype MethodContext (unused by the VM)" 372042 newArray at: 37 put: BlockClosure. 372043 "(BlockContext new: CompiledMethod fullFrameSize)." 372044 newArray at: 38 put: (self specialObjectsArray at: 38). "Is the prototype BlockContext (unused by the VM)" 372045 newArray at: 39 put: (self specialObjectsArray at: 39). "preserve external semaphores" 372046 "array of objects referred to by external code" 372047 newArray at: 40 put: PseudoContext. 372048 "newArray at: 41 put: TranslatedMethod." 372049 "finalization Semaphore" 372050 newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil: [Semaphore new]). 372051 newArray at: 43 put: LargeNegativeInteger. 372052 "External objects for callout. 372053 Note: Written so that one can actually completely remove the FFI." 372054 newArray at: 44 put: (self at: #ExternalAddress ifAbsent: []). 372055 newArray at: 45 put: (self at: #ExternalStructure ifAbsent: []). 372056 newArray at: 46 put: (self at: #ExternalData ifAbsent: []). 372057 newArray at: 47 put: (self at: #ExternalFunction ifAbsent: []). 372058 newArray at: 48 put: (self at: #ExternalLibrary ifAbsent: []). 372059 newArray at: 49 put: #aboutToReturn:through:. 372060 newArray at: 50 put: #run:with:in:. 372061 "Now replace the interpreter's reference in one atomic operation" 372062 self specialObjectsArray become: newArray! ! 372063 372064!SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:39'! 372065registerExternalObject: anObject 372066 "Register the given object in the external objects array and return its index. If it is already there, just return its index." 372067 372068 ^ExternalSemaphoreTable registerExternalObject: anObject! ! 372069 372070!SystemDictionary methodsFor: 'special objects'! 372071specialNargsAt: anInteger 372072 "Answer the number of arguments for the special selector at: anInteger." 372073 372074 ^ (self specialObjectsArray at: 24) at: anInteger * 2! ! 372075 372076!SystemDictionary methodsFor: 'special objects'! 372077specialObjectsArray "Smalltalk specialObjectsArray at: 1" 372078 <primitive: 129> 372079 ^ self primitiveFailed! ! 372080 372081!SystemDictionary methodsFor: 'special objects'! 372082specialSelectorAt: anInteger 372083 "Answer the special message selector from the interleaved specialSelectors array." 372084 372085 ^ (self specialObjectsArray at: 24) at: anInteger * 2 - 1! ! 372086 372087!SystemDictionary methodsFor: 'special objects'! 372088specialSelectorSize 372089 "Answer the number of special selectors in the system." 372090 372091 ^ (self specialObjectsArray at: 24) size // 2! ! 372092 372093!SystemDictionary methodsFor: 'special objects'! 372094specialSelectors 372095 "Used by SystemTracer only." 372096 372097 ^SpecialSelectors! ! 372098 372099!SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:40'! 372100unregisterExternalObject: anObject 372101 "Unregister the given object in the external objects array. Do nothing if it isn't registered." 372102 372103 ExternalSemaphoreTable unregisterExternalObject: anObject! ! 372104 372105 372106!SystemDictionary methodsFor: 'ui' stamp: 'sd 1/16/2004 20:49'! 372107inspectGlobals 372108 "Smalltalk inspectGlobals" 372109 372110 | associations aDict | 372111 associations := ((self keys select: [:aKey | ((self at: aKey) isKindOf: Class) not]) asSortedArray collect:[:aKey | self associationAt: aKey]). 372112 aDict := IdentityDictionary new. 372113 associations do: [:as | aDict add: as]. 372114 aDict inspectWithLabel: 'The Globals'! ! 372115 372116 372117!SystemDictionary methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 08:16'! 372118removeAllUnSentMessages 372119 self deprecated: 'Use ''removeAllUnsentMessages'' instead.'. 372120 ^ self removeAllUnsentMessages! ! 372121 372122!SystemDictionary methodsFor: 'deprecated' stamp: 'AndrewBlack 9/3/2009 02:24'! 372123unbindExternalPrimitives 372124 "Primitive. Force all external primitives to be looked up again afterwards. Since external primitives that have not found are bound for fast failure this method will force the lookup of all primitives again so that after adding some plugin the primitives may be found." 372125 self deprecated: 'Use ''SmalltalkImage unbindExternalPrimitives'' instead.'. 372126 ^ SmalltalkImage unbindExternalPrimitives.! ! 372127 372128"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 372129 372130SystemDictionary class 372131 instanceVariableNames: ''! 372132 372133!SystemDictionary class methodsFor: 'initialization' stamp: 'mir 11/20/2008 16:43'! 372134initialize 372135 "SystemDictionary initialize" 372136 372137 | oldList | 372138 oldList := StartUpList. 372139 StartUpList := OrderedCollection new. 372140 "These get processed from the top down..." 372141 #( 372142 Delay 372143 DisplayScreen 372144 Cursor 372145 InputEventFetcher 372146 ProcessorScheduler "Starts low space watcher and bkground." 372147 LanguageEnvironment 372148 FileDirectory "Enables file stack dump and opens sources." 372149 NaturalLanguageTranslator 372150 ShortIntegerArray 372151 ShortRunArray 372152 CrLfFileStream 372153 ) do:[:clsName| 372154 Smalltalk at: clsName ifPresent:[:cls| Smalltalk addToStartUpList: cls]. 372155 ]. 372156 oldList ifNotNil: [oldList do: [:className | Smalltalk at: className 372157 ifPresent: [:theClass | Smalltalk addToStartUpList: theClass]]]. 372158 #( 372159 ImageSegment 372160 PasteUpMorph 372161 "ControlManager" 372162 ) do:[:clsName| 372163 Smalltalk at: clsName ifPresent:[:cls| Smalltalk addToStartUpList: cls]. 372164 ]. 372165 372166 372167 oldList := ShutDownList. 372168 ShutDownList := OrderedCollection new. 372169 "These get processed from the bottom up..." 372170 #( 372171 Delay 372172 DisplayScreen 372173 InputEventFetcher 372174 Form 372175 "ControlManager" 372176 PasteUpMorph 372177 StrikeFont 372178 Color 372179 FileDirectory 372180 SoundPlayer 372181 HttpUrl 372182 Password 372183 PWS 372184 MailDB 372185 ImageSegment 372186 ) do:[:clsName| 372187 Smalltalk at: clsName ifPresent:[:cls| Smalltalk addToShutDownList: cls]. 372188 ]. 372189 372190 oldList ifNotNil: [oldList reverseDo: [:className | Smalltalk at: className 372191 ifPresent: [:theClass | Smalltalk addToShutDownList: theClass]]]. 372192! ! 372193DictionaryTest subclass: #SystemDictionaryTest 372194 instanceVariableNames: '' 372195 classVariableNames: '' 372196 poolDictionaries: '' 372197 category: 'Tests-System'! 372198 372199!SystemDictionaryTest methodsFor: 'problems' stamp: 'marcus.denker 7/29/2009 15:27'! 372200testClassComment 372201 self should: [self targetClass organization hasComment].! ! 372202 372203!SystemDictionaryTest methodsFor: 'problems' stamp: 'cyrille.delaunay 7/17/2009 11:25'! 372204testUnCategorizedMethods 372205 | categories slips | categories := self categoriesForClass: self targetClass. 372206 slips := categories select: [:each | each = #'as yet unclassified']. 372207 self should: [slips isEmpty]. ! ! 372208 372209 372210!SystemDictionaryTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 13:27'! 372211classToBeTested 372212 372213^ SystemDictionary! ! 372214 372215 372216!SystemDictionaryTest methodsFor: 'tests' stamp: 'sd 7/21/2009 10:37'! 372217testOtherInstancesOfSystemDictionaryAsString 372218 self deny: SystemDictionary new asString = 'Smalltalk'! ! 372219 372220!SystemDictionaryTest methodsFor: 'tests' stamp: 'sd 7/21/2009 10:37'! 372221testOtherInstancesOfSystemDictionaryPrintString 372222 self deny: SystemDictionary new printString = 'Smalltalk'! ! 372223 372224!SystemDictionaryTest methodsFor: 'tests' stamp: 'sd 7/21/2009 10:37'! 372225testOtherInstancesOfSystemDictionarySelfEvaluating 372226 self deny: SystemDictionary new isSelfEvaluating! ! 372227 372228!SystemDictionaryTest methodsFor: 'tests' stamp: 'sd 7/21/2009 10:37'! 372229testSmalltalkAsString 372230 self assert: Smalltalk asString = 'Smalltalk'! ! 372231 372232!SystemDictionaryTest methodsFor: 'tests' stamp: 'sd 7/21/2009 10:36'! 372233testSmalltalkPrintString 372234 self assert: Smalltalk printString = 'Smalltalk'! ! 372235 372236!SystemDictionaryTest methodsFor: 'tests' stamp: 'sd 7/21/2009 10:36'! 372237testSmalltalkSelfEvaluating 372238 self assert: Smalltalk isSelfEvaluating! ! 372239 372240"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 372241 372242SystemDictionaryTest class 372243 instanceVariableNames: ''! 372244 372245!SystemDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 13:28'! 372246shouldInheritSelectors 372247 372248^true! ! 372249EventManager subclass: #SystemEventManager 372250 instanceVariableNames: '' 372251 classVariableNames: '' 372252 poolDictionaries: '' 372253 category: 'System-Change Notification'! 372254!SystemEventManager commentStamp: 'tlk 5/7/2006 20:10' prior: 0! 372255A SystemEventManager is EventManager that overrides Object>>actionSequenceForEvent: anEventSelector to supply WeakActionSequenceTrappingErrors as the default event. 372256 372257! 372258 372259 372260!SystemEventManager methodsFor: 'events-accessing' stamp: 'rw 7/20/2003 17:02'! 372261actionSequenceForEvent: anEventSelector 372262 372263 ^(self actionMap 372264 at: anEventSelector asSymbol 372265 ifAbsent: [^WeakActionSequenceTrappingErrors new]) 372266 asActionSequenceTrappingErrors! ! 372267 372268"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 372269 372270SystemEventManager class 372271 instanceVariableNames: ''! 372272Object subclass: #SystemNavigation 372273 instanceVariableNames: 'browserClass hierarchyBrowserClass' 372274 classVariableNames: 'Default' 372275 poolDictionaries: '' 372276 category: 'System-Support'! 372277!SystemNavigation commentStamp: 'sd 4/15/2003 22:30' prior: 0! 372278I support the navigation of the system. I act as a facade but as I could require some state 372279or different way of navigating the system all my behavior are on the instance side! 372280 372281 372282!SystemNavigation methodsFor: '*multilingual-editor' stamp: 'sd 12/18/2004 18:17'! 372283allSelect: aBlock 372284 "Answer a SortedCollection of each method that, when used as 372285 the block 372286 argument to aBlock, gives a true result." 372287 | aCollection | 372288 aCollection := SortedCollection new. 372289 Cursor execute 372290 showWhile: [self 372291 allBehaviorsDo: [:class | class 372292 selectorsDo: [:sel | (aBlock 372293 value: (class compiledMethodAt: sel)) 372294 ifTrue: [aCollection add: class name , ' ' , sel]]]]. 372295 ^ aCollection! ! 372296 372297 372298!SystemNavigation methodsFor: '*tools-browser' stamp: 'mu 3/11/2004 15:46'! 372299browserClass 372300 browserClass ifNil: [browserClass := self defaultBrowserClass]. 372301 ^browserClass! ! 372302 372303!SystemNavigation methodsFor: '*tools-browser' stamp: 'mu 3/11/2004 15:46'! 372304browserClass: aBrowserClass 372305 browserClass := aBrowserClass! ! 372306 372307!SystemNavigation methodsFor: '*tools-browser' stamp: 'nk 2/25/2005 09:42'! 372308defaultBrowserClass 372309 ^SystemBrowser default! ! 372310 372311!SystemNavigation methodsFor: '*tools-browser' stamp: 'mu 3/11/2004 15:49'! 372312defaultHierarchyBrowserClass 372313 ^self class environment at: #HierarchyBrowser ifAbsent:[]! ! 372314 372315!SystemNavigation methodsFor: '*tools-browser' stamp: 'mu 3/11/2004 15:50'! 372316hierarchyBrowserClass 372317 hierarchyBrowserClass ifNil: [hierarchyBrowserClass := self defaultHierarchyBrowserClass]. 372318 ^hierarchyBrowserClass! ! 372319 372320!SystemNavigation methodsFor: '*tools-browser' stamp: 'mu 3/11/2004 15:47'! 372321hierarchyBrowserClass: aBrowserClass 372322 hierarchyBrowserClass := aBrowserClass! ! 372323 372324 372325!SystemNavigation methodsFor: 'accessing' stamp: 'Noury 10/26/2008 17:12'! 372326categoriesInPackageNamed: packageName 372327 ^(SystemOrganization categoriesMatching: packageName), (SystemOrganization categoriesMatching: packageName, '*')! ! 372328 372329 372330!SystemNavigation methodsFor: 'author' stamp: 'stephane.ducasse 8/8/2009 15:03'! 372331allContributors 372332 "SystemNavigation default allContributors" 372333 372334 | bag stamp | 372335 bag := Bag new. 372336 self allBehaviorsDo: [ :behavior | 372337 behavior methodsDo: [ :compiledMethod | 372338 stamp := compiledMethod timeStamp. 372339 stamp notEmpty ifTrue: [ 372340 bag add: compiledMethod timeStamp substrings first ]]]. 372341 ^bag! ! 372342 372343!SystemNavigation methodsFor: 'author' stamp: 'stephane.ducasse 8/8/2009 15:14'! 372344contributionsOf: aString 372345 "SystemNavigation default contributionsOf: 'alain.plantec'" 372346 372347 | stamp initials answer | 372348 answer := OrderedCollection new. 372349 self allBehaviorsDo: [ :behavior | 372350 behavior methodsDo: [ :compiledMethod | 372351 stamp := compiledMethod timeStamp. 372352 stamp notEmpty ifTrue: [ 372353 initials := compiledMethod timeStamp substrings first. 372354 aString = initials ifTrue: [ 372355 answer add: (compiledMethod selector -> compiledMethod methodClass)]]]]. 372356 ^answer! ! 372357 372358!SystemNavigation methodsFor: 'author' stamp: 'stephane.ducasse 8/8/2009 15:16'! 372359contributorsNotSignatories 372360 "SystemNavigation default contributorsNotSignatories" 372361 372362 | stamp signatories initials answer | 372363 answer := Dictionary new. 372364 signatories := self signatories. 372365 self allBehaviorsDo: [ :behavior | 372366 behavior methodsDo: [ :compiledMethod | 372367 stamp := compiledMethod timeStamp. 372368 stamp notEmpty ifTrue: [ 372369 initials := compiledMethod timeStamp substrings first. 372370 (signatories includes: initials) ifFalse: [ 372371 (answer at: initials ifAbsentPut: [OrderedCollection new]) 372372 add: (compiledMethod selector -> compiledMethod methodClass)]]]]. 372373 ^answer! ! 372374 372375!SystemNavigation methodsFor: 'author' stamp: 'stephane.ducasse 8/8/2009 15:08'! 372376signatories 372377 ^(self signatoriesString subStrings: {Character cr}) 372378 collect: [ :each | each substrings first]! ! 372379 372380!SystemNavigation methodsFor: 'author' stamp: 'stephane.ducasse 8/8/2009 15:08'! 372381signatoriesString 372382 ^'AB Alexandre Bergel 372383ack Alan Kay 372384ads Adam Spitz 372385ajh Anthony Hannan 372386aka Mark Guzdial 372387al Adrian Lienhard 372388aoy Andres Otaduy 372389apb Andrew P. Black 372390apl Alain Plantec 372391ar Andreas Raab 372392asm Alejandro Magistrello 372393avi Avi Bryant 372394bf Bert Freudenberg 372395BG Boris Gaertner 372396bh Bob Hartwig 372397BJP Bijan Parsia 372398bkv Brent Vukmer 372399bolot Bolot Kerimbaev 372400bootstrap Pavel Krivanek 372401BP Bijan Parsia 372402brp Brent Pinkney 372403btr Brian Rice 372404cbc Chris Cunningham 372405ccn Chris Norton 372406CdG Cees de Groot 372407cds C. David Shaffer 372408cmm Chris Muller 372409crl Craig Latta 372410cwp Colin Putney 372411daf Dave Faught 372412dao danil osipchuk 372413DAS David A Smith 372414dc Damien Cassou 372415dd Dominique Dutoit 372416dew Doug Way 372417DF Diego Fernandez 372418dgd Diego Gomez Deck 372419dhhi Dan Ingalls 372420di Dan Ingalls 372421DM Duane Maxwell 372422DSM Duane Maxwell 372423dtl Dave Lewis 372424dvf Daniel Vainsencher 372425edc Edgar DeCleene 372426efc Eddie Cottongim 372427efo Emilio Oca 372428em Ernest Micklei? 372429emm Ernest Micklei 372430es Enrico Spinielli 372431FBS Frank Shearar 372432fc Frank Caggiano 372433fcs Frank Sergeant 372434fm Florin Mateoc 372435gh Goran Krampe (nee Hultgren) 372436gk Goran Krampe (nee Hultgren) 372437gm German Morales 372438go Georg Gollmann 372439gsa German Arduino 372440HEG Henrik Ekenberg 372441HilaireFernandes Hilaire Fernandes 372442HK Herbert Konig 372443hmm Hans-Martin Mosner 372444hpt Hernan Tylim 372445huma Lyndon Tremblay 372446ich. Yuji Ichikawa 372447ikp Ian Piumarta 372448jaf Jan Fietz 372449jam Javier Musa 372450jcg Joshua Gargus 372451jdf David Farber 372452jdr Javier Diaz-Reinoso 372453je Jorn Eyrich 372454je77 Jochen Rick 372455JF Julian Fitzell 372456jhm John Maloney 372457jlb Jim Benson 372458jmb Hans Baveco 372459JMM John McIntosh 372460JMV Juan Manuel Vuletich 372461jon Jon Hylands 372462jrm John-Reed Maffeo 372463jrp John Pierce 372464jsp Jeff Pierce 372465ka Kazuhiro Abe 372466kfr Karl Ramberg 372467KLC Ken Causey 372468KR korakurider 372469KTT Kurt Thams 372470kwl Klaus D. Witzel 372471ky Koji Yokokawa 372472laza Alexander Lazarevic 372473LB Leo Burd 372474LC Leandro Caniglia 372475LEG Gerald Leeb 372476len Luciano Esteban Notarfrancesco 372477lr Lukas Renggli 372478lrs Lorenzo Schiavina 372479ls Lex Spoon 372480m3r Maurice Rabb 372481mas Mark Schwenk 372482MD Markus Denker 372483mdr Mike Rutenberg 372484mga Markus Galli 372485miki Mikael Kindborg 372486mikki Mikael Kindborg 372487mir Michael Rueger 372488mist Michal Starke 372489mjg Mark Guzdial 372490mjr Mike Roberts 372491mjt Mike Thomas 372492mk Matej Kosik 372493MPW Marcel Weiher 372494mrm Martin McClure 372495ms math 372496MU Masashi Umezawa 372497mw Martin Wirblat 372498nb Naala Brewer 372499nice Nicolas Cellier 372500nk Ned Konz 372501Noury Noury Bouraqadi 372502NS Nathanael Schaerli 372503PHK Peter Keeler 372504pk Pavel Krivanek 372505pm Patrick Mauritz 372506pnm Paul McDonough 372507RAA Bob Arning 372508raok Richard A. O"Keefe 372509rbb Brian Brown 372510rca Russell Allen 372511reThink Paul McDonough 372512rew Roger Whitney 372513rhi Robert Hirschfeld 372514Rik Rik Fischer SmOOdy 372515RJT Ron Teitelbaum 372516rr Romain Robbes 372517rw Roel Wuyts 372518rww Robert Withers 372519sbw Stephan B. Wessels 372520SD Stephane Ducasse 372521sge Steve Elkins 372522shrink Pavel Krivanek 372523slg Steve Gilbert 372524sm Simon Michael 372525sma Stefan Matthias Aust 372526sn Suslov Nikolay 372527spfa Stephane Rollandin 372528sps Steven Swerling 372529SqR Andres Valloud 372530SqR!!!! Andres Valloud 372531SqR!!!!!!!! Andres Valloud 372532sr Stephan Rudlof 372533ssa Sam S. Adams 372534st Samuel Tardieu 372535stephaneducasse Stephane Ducasse 372536stp Stephen Travis Pope 372537sumim Masato Sumi 372538svp Stephen Vincent Pair 372539sw Scott Wallace 372540T2 Toshiyuki Takeda 372541tak Takashi Yamamiya 372542tao Tim Olson 372543tb Todd Blanchard 372544TBn Torsten Bergmann 372545tetha Tetsuya Hayashi 372546tfei The Fourth Estate, Inc. 372547th Torge Husfeldt 372548ti Tobias Isenberg 372549TJ TJ Leone 372550tk Ted Kaehler 372551tk Thomas Kowark 372552tlk Tom Koenig 372553TN korakurider 372554TPR Tim Rowledge 372555TRee Trygve Reenskaug 372556Tsutomu Tsutomu Hiroshima 372557tween Andy Tween 372558vb Vassili Bykov 372559vj Vladimir Janousek 372560wiz Jerome Peace 372561wod Bill Dargel 372562ykoubo Koji Yokokawa 372563yo Yoshiki Ohshima 372564zz Serge Stinckwich 372565jmv 372566jm 372567jmm 372568md 372569sd 372570tpr'! ! 372571 372572 372573!SystemNavigation methodsFor: 'browse' stamp: 'marcus.denker 7/24/2009 16:47'! 372574allMethodsInCategory: category 372575 | aCollection | 372576 aCollection := Set new. 372577 Cursor wait showWhile: [ 372578 self allBehaviorsDo: [:x | ((category = ClassOrganizer allCategory 372579 ifTrue: [x organization allMethodSelectors] 372580 ifFalse: [x organization listAtCategoryNamed: category])) do: 372581 [:sel | aCollection add: (MethodReference new setStandardClass: x 372582methodSymbol: sel)]]]. 372583 ^aCollection. 372584! ! 372585 372586!SystemNavigation methodsFor: 'browse' stamp: 'md 8/27/2005 16:42'! 372587browseAllAccessesTo: instVarName from: aClass 372588 "Create and schedule a Message Set browser for all the receiver's methods 372589 or any methods of a subclass/superclass that refer to the instance variable name." 372590 372591 "self new browseAllAccessesTo: 'contents' from: Collection." 372592 372593 | coll | 372594 coll := OrderedCollection new. 372595 Cursor wait showWhile: [ 372596 aClass withAllSubAndSuperclassesDo: [:class | 372597 (class whichSelectorsAccess: instVarName) do: [:sel | 372598 sel isDoIt ifFalse: [ 372599 coll add: ( 372600 MethodReference new 372601 setStandardClass: class 372602 methodSymbol: sel 372603 ) 372604 ] 372605 ] 372606 ]. 372607 ]. 372608 ^ self 372609 browseMessageList: coll 372610 name: 'Accesses to ' , instVarName 372611 autoSelect: instVarName! ! 372612 372613!SystemNavigation methodsFor: 'browse' stamp: 'davidroethlisberger 2/11/2009 12:07'! 372614browseAllCallsOn: aLiteral 372615 "Create and schedule a message browser on each method that refers to 372616 aLiteral. For example, SystemNavigation new browseAllCallsOn: #open:label:." 372617 (aLiteral isKindOf: LookupKey) 372618 ifTrue: [^ self 372619 browseMessageList: (self allCallsOn: aLiteral) asSortedCollection 372620 name: 'Users of ' , aLiteral key 372621 autoSelect: aLiteral key]. 372622 self 372623 browseSendersOf: aLiteral 372624 name: 'Senders of ' , aLiteral 372625 autoSelect: aLiteral keywords first! ! 372626 372627!SystemNavigation methodsFor: 'browse' stamp: 'nk 6/26/2003 22:32'! 372628browseAllCallsOn: literal1 and: literal2 372629 "Create and schedule a message browser on each method that calls on the 372630 two Symbols, literal1 and literal2. For example, SystemNavigation new 372631 browseAllCallsOn: #at: and: #at:put:." 372632 372633 ^self 372634 browseMessageList: (self allCallsOn: literal1 and: literal2) 372635 name: literal1 printString , ' -and- ' , literal2 printString! ! 372636 372637!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/16/2003 08:53'! 372638browseAllCallsOn: aSymbol from: aClass 372639 "Create and schedule a Message Set browser for all the methods that call 372640 on aSymbol." 372641 372642 "self new browseAllCallsOn: #/. from: Number" 372643 372644 | key label | 372645 label := (aSymbol isKindOf: LookupKey) 372646 ifTrue: ['Users of ' , (key := aSymbol key)] 372647 ifFalse: ['Senders of ' , (key := aSymbol)]. 372648 ^ self 372649 browseMessageList: (self allCallsOn: aSymbol from: aClass) 372650 name: label 372651 autoSelect: key 372652 372653 ! ! 372654 372655!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/16/2003 11:44'! 372656browseAllCallsOn: aLiteral localTo: aClass 372657 "Create and schedule a message browser on each method in or below the given class that refers to 372658 aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:." 372659 372660 aClass ifNil: [ ^self inform: 'no selected class' ]. 372661 (aLiteral isKindOf: LookupKey) 372662 ifTrue: [self browseMessageList: (aClass allLocalCallsOn: aLiteral) asSortedCollection 372663 name: 'Users of ' , aLiteral key, ' local to ', aClass name 372664 autoSelect: aLiteral key] 372665 ifFalse: [self browseMessageList: (aClass allLocalCallsOn: aLiteral) asSortedCollection 372666 name: 'Senders of ' , aLiteral, ' local to ', aClass name 372667 autoSelect: aLiteral keywords first]! ! 372668 372669!SystemNavigation methodsFor: 'browse' stamp: 'tpr 12/17/2003 16:01'! 372670browseAllCallsOnClass: aClass 372671 "Create and schedule a message browser on each method that refers to 372672 aClass. For example, SystemNavigation new browseAllCallsOnClass: Object." 372673 self 372674 browseMessageList: aClass allCallsOn asSortedCollection 372675 name: 'Users of class ' , aClass theNonMetaClass name 372676 autoSelect: aClass theNonMetaClass name! ! 372677 372678!SystemNavigation methodsFor: 'browse' stamp: 'davidroethlisberger 2/11/2009 12:08'! 372679browseAllImplementorsOf: selector 372680 "Create and schedule a message browser on each method that implements 372681 the message whose selector is the argument, selector. For example, 372682 Smalltalk browseAllImplementorsOf: #at:put:." 372683 ^self browseImplementorsOf: selector name: 'Implementors of ' , selector autoSelect: nil! ! 372684 372685!SystemNavigation methodsFor: 'browse' stamp: 'apl 4/4/2005 18:23'! 372686browseAllImplementorsOf: selector localTo: aClass 372687 "Create and schedule a message browser on each method in or below the 372688 given class 372689 that implements the message whose selector is the argument, selector. 372690 For example, 372691 SystemNavigation new browseAllImplementorsOf: #at:put: localTo: 372692 Dictionary." 372693 aClass 372694 ifNil: [^ self inform: 'no class selected']. 372695 ^ self 372696 browseMessageList: ((self allImplementorsOf: selector localTo: aClass) 372697 collect: [:methRef | methRef actualClass name , ' ' , methRef methodSymbol]) 372698 name: 'Implementors of ' , selector , ' local to ' , aClass name! ! 372699 372700!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/15/2003 21:43'! 372701browseAllImplementorsOfList: selectorList 372702 "Create and schedule a message browser on each method that implements 372703 the message whose selector is in the argument selectorList. For example, 372704 Smalltalk browseAllImplementorsOf: #(at:put: size). 372705 1/16/96 sw: defer to the titled version" 372706 372707 self browseAllImplementorsOfList: selectorList title: 'Implementors of all'! ! 372708 372709!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/19/2003 12:15'! 372710browseAllImplementorsOfList: selectorList title: aTitle 372711 "Create and schedule a message browser on each method that implements 372712 the message whose selector is in the argument selectorList. For 372713 example, 372714 self new browseAllImplementorsOf: #(at:put: size). 372715 1/16/96 sw: this variant adds the title argument. 372716 1/24/96 sw: use a SortedCollection 372717 2/1/96 sw: show normal cursor" 372718 | implementorLists flattenedList | 372719 implementorLists := selectorList 372720 collect: [:each | self allImplementorsOf: each]. 372721 flattenedList := SortedCollection new. 372722 implementorLists 372723 do: [:each | flattenedList addAll: each]. 372724 Cursor normal show. 372725 ^ self browseMessageList: flattenedList name: aTitle! ! 372726 372727!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/16/2003 09:17'! 372728browseAllMethodsInCategory: category 372729 ^self browseMessageList: (self allMethodsInCategory: category) 372730 name: category! ! 372731 372732!SystemNavigation methodsFor: 'browse' stamp: 'Alexandre.Bergel 7/4/2009 11:10'! 372733browseAllObjectReferencesTo: anObject except: objectsToExclude ifNone: aBlock 372734 "Bring up a list inspector on the objects that point to anObject. 372735 If there are none, then evaluate aBlock on anObject. " 372736 372737 | aList shortName | 372738 aList := PointerFinder pointersTo: anObject except: objectsToExclude. 372739 aList size > 0 ifFalse: [^aBlock value: anObject]. 372740 shortName := (anObject name ifNil: [anObject printString]) contractTo: 20. 372741 aList inspectWithLabel: 'Objects pointing to ' , shortName! ! 372742 372743!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/7/2003 18:05'! 372744browseAllReferencesToPool: poolOrName from: aClass 372745 "Open a message list on all messages referencing the given pool" 372746 | pool list | 372747 (poolOrName isString) 372748 ifTrue:[pool := Smalltalk at: poolOrName asSymbol] 372749 ifFalse:[pool := poolOrName]. 372750 list := self allReferencesToPool: pool from: aClass. 372751 self 372752 browseMessageList: list 372753 name: 'users of ', poolOrName name. 372754 ^list! ! 372755 372756!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/29/2003 20:43'! 372757browseAllSelect: aBlock 372758 "Create and schedule a message browser on each method that, when used 372759 as the block argument to aBlock gives a true result. For example, 372760 SystemNavigation new browseAllSelect: [:method | method numLiterals > 372761 10]." 372762 ^ self 372763 browseMessageList: (self allMethodsSelect: aBlock) 372764 name: 'selected messages'! ! 372765 372766!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/29/2003 20:44'! 372767browseAllSelect: aBlock name: aName autoSelect: autoSelectString 372768 "Create and schedule a message browser on each method that, when used 372769 as the block argument to aBlock gives a true result. Do not return an 372770 #DoIt traces." 372771 "self new browseAllSelect: [:method | method numLiterals > 10] name: 372772 'Methods with more than 10 literals' autoSelect: 'isDigit'" 372773 ^ self 372774 browseMessageList: (self allMethodsNoDoitsSelect: aBlock) 372775 name: aName 372776 autoSelect: autoSelectString! ! 372777 372778!SystemNavigation methodsFor: 'browse' stamp: 'md 8/27/2005 17:17'! 372779browseAllStoresInto: instVarName from: aClass 372780 "Create and schedule a Message Set browser for all the receiver's methods 372781 or any methods of a subclass/superclass that refer to the instance variable name." 372782 372783 "self new browseAllStoresInto: 'contents' from: Collection." 372784 372785 | coll | 372786 coll := OrderedCollection new. 372787 Cursor wait showWhile: [ 372788 aClass withAllSubAndSuperclassesDo: [:class | 372789 (class whichSelectorsStoreInto: instVarName) do: [:sel | 372790 sel isDoIt ifFalse: [ 372791 coll add: ( 372792 MethodReference new 372793 setStandardClass: class 372794 methodSymbol: sel 372795 ) 372796 ] 372797 ] 372798 ]. 372799 ]. 372800 ^ self 372801 browseMessageList: coll 372802 name: 'Stores into ' , instVarName 372803 autoSelect: instVarName! ! 372804 372805!SystemNavigation methodsFor: 'browse' stamp: 'marcus.denker 9/14/2008 18:53'! 372806browseAllUnimplementedCalls 372807 "Create and schedule a message browser on each method that includes a 372808 message that is not implemented in any object in the system." 372809 372810 "self new browseAllUnimplementedCalls" 372811 372812 ^self browseMessageList: self allUnimplementedCalls name: 'Unimplemented calls'! ! 372813 372814!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/16/2003 08:53'! 372815browseClassCommentsWithString: aString 372816 "Smalltalk browseClassCommentsWithString: 'my instances' " 372817 "Launch a message list browser on all class comments containing aString as a substring." 372818 372819 | caseSensitive suffix list | 372820 372821 suffix := (caseSensitive := Sensor shiftPressed) 372822 ifTrue: [' (case-sensitive)'] 372823 ifFalse: [' (use shift for case-sensitive)']. 372824 list := Set new. 372825 Cursor wait showWhile: [ 372826 Smalltalk allClassesDo: [:class | 372827 (class organization classComment asString findString: aString 372828 startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [ 372829 list add: ( 372830 MethodReference new 372831 setStandardClass: class 372832 methodSymbol: #Comment 372833 ) 372834 ] 372835 ] 372836 ]. 372837 ^ self 372838 browseMessageList: list asSortedCollection 372839 name: 'Class comments containing ' , aString printString , suffix 372840 autoSelect: aString! ! 372841 372842!SystemNavigation methodsFor: 'browse' stamp: 'PeterHugossonMiller 9/3/2009 11:31'! 372843browseClassVarRefs: aClass 372844 "Put up a menu offering all class variable names; if the user chooses one, open up a message-list browser on all methods 372845 that refer to the selected class variable" 372846 372847 | lines labelStream vars allVars index owningClasses | 372848 lines := OrderedCollection new. 372849 allVars := OrderedCollection new. 372850 owningClasses := OrderedCollection new. 372851 labelStream := (String new: 200) writeStream. 372852 aClass withAllSuperclasses reverseDo: 372853 [:class | 372854 vars := class classVarNames asSortedCollection. 372855 vars do: 372856 [:var | 372857 labelStream nextPutAll: var; cr. 372858 allVars add: var. 372859 owningClasses add: class]. 372860 vars isEmpty ifFalse: [lines add: allVars size]]. 372861 labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better" 372862 labelStream skip: -1 "cut last CR". 372863 index := (UIManager default chooseFrom: (labelStream contents substrings) lines: lines). 372864 index = 0 ifTrue: [^ self]. 372865 self browseAllCallsOn: 372866 ((owningClasses at: index) classPool associationAt: (allVars at: index))! ! 372867 372868!SystemNavigation methodsFor: 'browse' stamp: 'sd 3/28/2003 18:49'! 372869browseClassVariables: aClass 372870 aClass classPool inspectWithLabel: 'Class Variables in ' , aClass name! ! 372871 372872!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:33'! 372873browseClassesWithNamesContaining: aString caseSensitive: caseSensitive 372874 "Smalltalk browseClassesWithNamesContaining: 'eMorph' caseSensitive: true " 372875 "Launch a class-list list browser on all classes whose names containg aString as a substring." 372876 372877 | suffix aList | 372878 suffix := caseSensitive 372879 ifTrue: [' (case-sensitive)'] 372880 ifFalse: [' (use shift for case-sensitive)']. 372881 aList := OrderedCollection new. 372882 Cursor wait 372883 showWhile: [Smalltalk 372884 allClassesDo: [:class | (class name includesSubstring: aString caseSensitive: caseSensitive) 372885 ifTrue: [aList add: class name]]]. 372886 aList size > 0 372887 ifTrue: [ToolSet openClassListBrowser: aList asSet asSortedArray title: 'Classes whose names contain ' , aString , suffix]! ! 372888 372889!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:34'! 372890browseClass: aBehavior 372891 | targetClass | 372892 targetClass := aBehavior isMeta 372893 ifTrue: [aBehavior theNonMetaClass] 372894 ifFalse: [aBehavior ]. 372895 ToolSet browse: targetClass selector: nil! ! 372896 372897!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:34'! 372898browseHierarchy: aBehavior 372899 | targetClass | 372900 targetClass := aBehavior isMeta 372901 ifTrue: [aBehavior theNonMetaClass] 372902 ifFalse: [aBehavior ]. 372903 ToolSet browseHierarchy: targetClass selector: nil.! ! 372904 372905!SystemNavigation methodsFor: 'browse' stamp: 'davidroethlisberger 2/11/2009 12:09'! 372906browseImplementorsOf: aSelector name: labelString autoSelect: autoSelectString 372907 "Create and schedule a senders browser for aSelector." 372908 | implementors title size | 372909 372910 implementors := self allImplementorsOf: aSelector. 372911 implementors size = 0 ifTrue: 372912 [^ self inform: 'There are no ' , labelString]. 372913 372914 title := (size := implementors size) > 1 372915 ifFalse: [labelString] 372916 ifTrue: [ labelString, ' [', size printString, ']']. 372917 372918 ToolSet 372919 browseImplementorsOf: aSelector 372920 name: title 372921 autoSelect: autoSelectString! ! 372922 372923!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/15/2003 16:08'! 372924browseInstVarDefs: aClass 372925 "Copied from browseInstVarRefs. Should be consolidated some day. 7/29/96 di 372926 7/30/96 sw: did the consolidation" 372927 "Change to use SystemNavigation 27 March 2003 sd" 372928 372929 aClass chooseInstVarThenDo: 372930 [:aVar | self browseAllStoresInto: aVar from: aClass]! ! 372931 372932!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/15/2003 16:08'! 372933browseInstVarRefs: aClass 372934 "1/16/96 sw: moved here from Browser so that it could be used from a variety of places. 372935 7/30/96 sw: call chooseInstVarThenDo: to get the inst var choice" 372936 372937 aClass chooseInstVarThenDo: 372938 [:aVar | self browseAllAccessesTo: aVar from: aClass]! ! 372939 372940!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/16/2003 09:18'! 372941browseMessageList: messageList name: label 372942 "Create and schedule a MessageSet browser on messageList." 372943 ^ self 372944 browseMessageList: messageList 372945 name: label 372946 autoSelect: nil! ! 372947 372948!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:34'! 372949browseMessageList: messageList name: labelString autoSelect: autoSelectString 372950 | title aSize | 372951 "Create and schedule a MessageSet browser on the message list." 372952 372953 messageList size = 0 ifTrue: 372954 [^ self inform: 'There are no 372955' , labelString]. 372956 372957 title := (aSize := messageList size) > 1 372958 ifFalse: [labelString] 372959 ifTrue: [ labelString, ' [', aSize printString, ']']. 372960 372961 ToolSet 372962 browseMessageSet: messageList 372963 name: title 372964 autoSelect: autoSelectString! ! 372965 372966!SystemNavigation methodsFor: 'browse' stamp: 'stephane.ducasse 5/23/2009 14:01'! 372967browseMethodsWhoseNamesContain: aString 372968 "Launch a tool which shows all methods whose names contain the given string; case-insensitive." 372969 ToolSet browseMessageNames: aString! ! 372970 372971!SystemNavigation methodsFor: 'browse' stamp: 'yo 7/31/2004 18:40'! 372972browseMethodsWithLiteral: aString 372973 "Launch a browser on all methods that contain string literals with aString as a substring. Make the search case-sensitive or insensitive as dictated by the caseSensitive boolean parameter" 372974 372975 self browseAllSelect: 372976 [:method | 372977 method hasLiteralSuchThat: [:lit | 372978 (lit isString and: [lit isSymbol not]) and: 372979 [lit = aString]]] 372980 name: 'Methods with string ', aString printString 372981 autoSelect: aString. 372982! ! 372983 372984!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/20/2003 14:11'! 372985browseMethodsWithSourceString: aString 372986 "SystemNavigation new browseMethodsWithSourceString: 'SourceString'" 372987 "Launch a browser on all methods whose source code contains aString as 372988 a substring." 372989 | caseSensitive suffix | 372990 suffix := (caseSensitive := Sensor shiftPressed) 372991 ifTrue: [' (case-sensitive)'] 372992 ifFalse: [' (use shift for case-sensitive)']. 372993 ^ self 372994 browseMessageList: (self allMethodsWithSourceString: aString matchCase: caseSensitive) 372995 name: 'Methods containing ' , aString printString , suffix 372996 autoSelect: aString! ! 372997 372998!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/15/2003 22:28'! 372999browseMethodsWithString: aString 373000 "Launch a browser on all methods that contain string literals with aString as a substring. The search is case-insensitive, unless the shift key is pressed, in which case the search is case-sensitive." 373001 373002 'string for testing'. 373003 ^ self browseMethodsWithString: aString matchCase: Sensor shiftPressed 373004 373005 "SystemNavigation new browseMethodsWithString: 'Testing' matchCase: false" 373006 "SystemNavigation new browseMethodsWithString: 'Testing' matchCase: true"! ! 373007 373008!SystemNavigation methodsFor: 'browse' stamp: 'bf 4/26/2005 11:44'! 373009browseMethodsWithString: aString matchCase: caseSensitive 373010 "Launch a browser on all methods that contain string literals with aString as a substring. Make the search case-sensitive or insensitive as dictated by the caseSensitive boolean parameter" 373011 373012 self browseAllSelect: 373013 [:method | 373014 method hasLiteralSuchThat: [:lit | 373015 (lit isString and: [lit isSymbol not]) and: 373016 [lit includesSubstring: aString caseSensitive: caseSensitive]]] 373017 name: 'Methods with string ', aString printString, (caseSensitive ifTrue: [' (case-sensitive)'] ifFalse: [' (case-insensitive)']) 373018 autoSelect: aString. 373019! ! 373020 373021!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:34'! 373022browseObsoleteMethodReferences 373023 "Open a browser on all referenced behaviors that are obsolete" 373024 373025 "SystemNavigation default browseObsoleteMethodReferences" 373026 373027 | list | 373028 list := self obsoleteMethodReferences. 373029 self 373030 browseMessageList: list 373031 name: 'Method referencing obsoletes' 373032 autoSelect: nil! ! 373033 373034!SystemNavigation methodsFor: 'browse' stamp: 'sd 4/15/2003 20:32'! 373035browseObsoleteReferences 373036 "self new browseObsoleteReferences" 373037 373038 | references | 373039 references := OrderedCollection new. 373040 (LookupKey allSubInstances select: 373041 [:x | ((x value isKindOf: Behavior) and: ['AnOb*' match: x value name]) or: 373042 ['AnOb*' match: x value class name]]) 373043 do: [:x | references addAll: (self allCallsOn: x)]. 373044 self 373045 browseMessageList: references 373046 name: 'References to Obsolete Classes'! ! 373047 373048!SystemNavigation methodsFor: 'browse' stamp: 'davidroethlisberger 2/11/2009 12:08'! 373049browseSendersOf: aSelector name: labelString autoSelect: autoSelectString 373050 | title size senders | 373051 "Create and schedule a senders browser for aSelector." 373052 373053 senders := self allCallsOn: aSelector. 373054 senders size = 0 ifTrue: 373055 [^ self inform: 'There are no ' , labelString]. 373056 373057 title := (size := senders size) > 1 373058 ifFalse: [labelString] 373059 ifTrue: [labelString, ' [', size printString, ']']. 373060 373061 ToolSet 373062 browseSendersOf: aSelector 373063 name: title 373064 autoSelect: autoSelectString! ! 373065 373066!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:34'! 373067browseUncommentedMethodsWithInitials: targetInitials 373068 "Browse uncommented methods whose initials (in the time-stamp, as logged to disk) match the given initials. Present them in chronological order. CAUTION: It will take several minutes for this to complete." 373069 "Time millisecondsToRun: [SystemNavigation default browseUncommentedMethodsWithInitials: 'jm']" 373070 373071 | initials timeStamp methodReferences cm | 373072 methodReferences := OrderedCollection new. 373073 self allBehaviorsDo: 373074 [:aClass | aClass selectors do: [:sel | 373075 cm := aClass compiledMethodAt: sel. 373076 timeStamp := Utilities timeStampForMethod: cm. 373077 timeStamp isEmpty ifFalse: 373078 [initials := timeStamp substrings first. 373079 initials first isDigit ifFalse: 373080 [((initials = targetInitials) and: [(aClass firstPrecodeCommentFor: sel) isNil]) 373081 ifTrue: 373082 [methodReferences add: (MethodReference new 373083 setStandardClass: aClass 373084 methodSymbol: sel)]]]]]. 373085 373086 ToolSet 373087 browseMessageSet: methodReferences 373088 name: 'Uncommented methods with initials ', targetInitials 373089 autoSelect: nil! ! 373090 373091!SystemNavigation methodsFor: 'browse' stamp: 'stephane.ducasse 8/8/2009 12:51'! 373092browseUndeclaredReferences 373093 "from Cuis: 0058-browseUndeclared.1" 373094 "SystemNavigation default" 373095 373096 Undeclared removeUnreferencedKeys. 373097 Undeclared keys do: [ :k | 373098 self 373099 browseMessageList: (self allCallsOn: (Undeclared associationAt: k)) 373100 name: 'References to Undeclared: ', k printString ]! ! 373101 373102!SystemNavigation methodsFor: 'browse' stamp: 'al 12/7/2005 21:11'! 373103methodHierarchyBrowserForClass: aClass selector: sel 373104 "Create and schedule a message set browser on all implementors of the 373105 currently selected message selector. Do nothing if no message is selected." 373106 "SystemNavigation default 373107 methodHierarchyBrowserForClass: ParagraphEditor 373108 selector: #isControlActive" 373109 373110 | list tab stab aClassNonMeta isMeta theClassOrMeta | 373111 aClass ifNil: [^ self]. 373112 aClass isTrait ifTrue: [^ self]. 373113 sel ifNil: [^ self]. 373114 aClassNonMeta := aClass theNonMetaClass. 373115 isMeta := aClassNonMeta ~~ aClass. 373116 list := OrderedCollection new. 373117 tab := ''. 373118 aClass allSuperclasses reverseDo: 373119 [:cl | 373120 (cl includesSelector: sel) ifTrue: 373121 [list addLast: tab , cl name, ' ', sel]. 373122 tab := tab , ' ']. 373123 aClassNonMeta allSubclassesWithLevelDo: 373124 [:cl :level | 373125 theClassOrMeta := isMeta ifTrue: [cl class] ifFalse: [cl]. 373126 (theClassOrMeta includesSelector: sel) ifTrue: 373127 [stab := ''. 1 to: level do: [:i | stab := stab , ' ']. 373128 list addLast: tab , stab , theClassOrMeta name, ' ', sel]] 373129 startingLevel: 0. 373130 self browseMessageList: list name: 'Inheritance of ' , sel 373131 373132! ! 373133 373134!SystemNavigation methodsFor: 'browse' stamp: 'ar 9/27/2005 20:34'! 373135spawnHierarchyForClass: aClass selector: aSelector 373136 "Create and schedule a new class hierarchy browser on the requested class/selector." 373137 "SystemNavigation default spawnHierarchyForClass: SmallInteger selector: #hash" 373138 373139 (aClass == nil) ifTrue: [^ self]. 373140 ToolSet browseHierarchy: aClass selector: aSelector 373141! ! 373142 373143 373144!SystemNavigation methodsFor: 'message sends' stamp: 'Noury 10/26/2008 17:32'! 373145addSelectorsReferingTo: aSymbol in: class to: sortedSenders special: special byte: byte 373146 {class. class class} do: [:behavior| (behavior 373147 thoroughWhichSelectorsReferTo: aSymbol 373148 special: special 373149 byte: byte) do: [ :sel | 373150 sortedSenders add: (MethodReference 373151 class: class 373152 selector: sel) ]]! ! 373153 373154!SystemNavigation methodsFor: 'message sends' stamp: 'Noury 10/26/2008 16:52'! 373155allSendersOf: selector 373156 | sortedSenders special byte | 373157 sortedSenders := SortedCollection new. 373158 special := Smalltalk 373159 hasSpecialSelector: selector 373160 ifTrueSetByte: [ :b | byte := b ]. 373161 self allBehaviorsDo: 373162 [ :behavior | 373163 self 373164 addSelectorsReferingTo: selector 373165 in: behavior 373166 to: sortedSenders 373167 special: special 373168 byte: byte ]. 373169 ^ sortedSenders! ! 373170 373171!SystemNavigation methodsFor: 'message sends' stamp: 'Noury 10/26/2008 15:54'! 373172allSendersOf: selector inClass: aClass 373173 | sortedSenders special byte | 373174 sortedSenders := SortedCollection new. 373175 special := aClass environment hasSpecialSelector: selector ifTrueSetByte: [:b | byte := b ]. 373176 self 373177 addSelectorsReferingTo: selector 373178 in: aClass 373179 to: sortedSenders 373180 special: special 373181 byte: byte. 373182 ^sortedSenders! ! 373183 373184!SystemNavigation methodsFor: 'message sends' stamp: 'Noury 10/26/2008 15:58'! 373185allSendersOf: selector inClassCategory: category 373186 | classes sortedSenders special byte | 373187 classes := SystemOrganization classesInCategory: category. 373188 sortedSenders := SortedCollection new. 373189 classes ifEmpty: [ ^ sortedSenders ]. 373190 special := classes anyOne environment 373191 hasSpecialSelector: selector 373192 ifTrueSetByte: [ :b | byte := b ]. 373193 classes do: 373194 [ :class | 373195 self 373196 addSelectorsReferingTo: selector 373197 in: class 373198 to: sortedSenders 373199 special: special 373200 byte: byte ]. 373201 ^ sortedSenders! ! 373202 373203!SystemNavigation methodsFor: 'message sends' stamp: 'Noury 10/26/2008 17:12'! 373204allSendersOf: selector inPackageNamed: packageName 373205 ^(self categoriesInPackageNamed: packageName) inject: SortedCollection new into: [:sortedSenders :category| 373206 sortedSenders, (self allSendersOf: selector inClassCategory: category)]! ! 373207 373208!SystemNavigation methodsFor: 'message sends' stamp: 'Noury 10/26/2008 15:30'! 373209isMessage: selector sentInClass: aClass 373210 ^(self allSendersOf: selector inClass: aClass) notEmpty ! ! 373211 373212!SystemNavigation methodsFor: 'message sends' stamp: 'Noury 10/26/2008 15:57'! 373213isMessage: selector sentInClassCategory: category 373214 ^(self allSendersOf: selector inClassCategory: category) notEmpty ! ! 373215 373216!SystemNavigation methodsFor: 'message sends' stamp: 'Noury 10/26/2008 16:00'! 373217isMessage: selector sentInPackageNamed: packageName 373218 ^(self allSendersOf: selector inPackageNamed: packageName) notEmpty ! ! 373219 373220!SystemNavigation methodsFor: 'message sends' stamp: 'Noury 10/26/2008 16:57'! 373221isUnsentMessage: selector 373222 ^(self allSendersOf: selector) isEmpty ! ! 373223 373224!SystemNavigation methodsFor: 'message sends' stamp: 'Noury 10/26/2008 17:22'! 373225unsentMessagesInCategory: category 373226 ^(SystemOrganization classesInCategory: category) inject: Set new into: [:unsentMessages :class| 373227 unsentMessages, (self unsentMessagesInClass: class)] 373228 ! ! 373229 373230!SystemNavigation methodsFor: 'message sends' stamp: 'Noury 10/26/2008 21:04'! 373231unsentMessagesInClass: aClass 373232 |methReferences| 373233 methReferences := Set new. 373234 aClass selectors do: [:selector| 373235 (self isUnsentMessage: selector) ifTrue: [ 373236 methReferences add: (MethodReference class: aClass selector: selector)]]. 373237 ^methReferences! ! 373238 373239!SystemNavigation methodsFor: 'message sends' stamp: 'Noury 10/26/2008 17:26'! 373240unsentMessagesInPackageNamed: packageName 373241 | unsentMessages | 373242 unsentMessages := self unsentMessagesInCategory: packageName. 373243 (SystemOrganization categoriesMatching: packageName, '-*') do: [:category| 373244 unsentMessages addAll: (self unsentMessagesInCategory: category)]. 373245 ^unsentMessages 373246 ! ! 373247 373248 373249!SystemNavigation methodsFor: 'message sends UI' stamp: 'Noury 10/26/2008 22:35'! 373250allClassesInPackageNamed: packageName 373251 | classes | 373252 classes := (SystemOrganization classesInCategory: packageName) asSet. 373253 (SystemOrganization categoriesMatching: packageName, '-*') do: [:category| 373254 classes addAll: (SystemOrganization classesInCategory: category)]. 373255 ^classes asArray! ! 373256 373257!SystemNavigation methodsFor: 'message sends UI' stamp: 'Noury 10/26/2008 22:58'! 373258allUnsentMessagesWithProgressBar 373259 | unsentMessages | 373260 unsentMessages := Set new. 373261 self 373262 doWithProgressBarForAllUnsentMessages: [:class :selector| 373263 unsentMessages add: (MethodReference class: class selector: selector)]. 373264 ^unsentMessages! ! 373265 373266!SystemNavigation methodsFor: 'message sends UI' stamp: 'Noury 10/26/2008 22:57'! 373267browseAllUnsentMessages 373268 "SystemNavigation default browseUnsentMessages" 373269 | unsentMessages | 373270 unsentMessages := self allUnsentMessagesWithProgressBar. 373271 ^self 373272 browseMessageList: unsentMessages asSortedCollection 373273 name: 'All unsent messages' 373274 ! ! 373275 373276!SystemNavigation methodsFor: 'message sends UI' stamp: 'Noury 10/26/2008 22:59'! 373277browseUnsentMessagesInClass: aClass 373278 "SystemNavigation default browseUnsentMessagesWithProgressBarInClass: BlockContext" 373279 | unsentMessages | 373280 unsentMessages := self unsentMessagesWithProgressBarInClass: aClass. 373281 ^self 373282 browseMessageList: unsentMessages asSortedCollection 373283 name: 'Unsent messages in class ', aClass name 373284 ! ! 373285 373286!SystemNavigation methodsFor: 'message sends UI' stamp: 'Noury 10/26/2008 22:59'! 373287browseUnsentMessagesInPackageNamed: packageName 373288 "SystemNavigation default browseUnsentMessagesWithProgressBarInPackageNamed: 'Kernel-Contexts'" 373289 | unsentMessages | 373290 unsentMessages := self unsentMessagesWithProgressBarInPackageNamed: packageName. 373291 ^self 373292 browseMessageList: unsentMessages asSortedCollection 373293 name: 'Unsent messages in package ', packageName 373294 ! ! 373295 373296!SystemNavigation methodsFor: 'message sends UI' stamp: 'Noury 10/26/2008 22:37'! 373297doWithProgressBar: aBlock forUnsentMessagesInClass: class 373298 | progressMessages selectors | 373299 progressMessages := 'Unsent messages in class ', class name. 373300 selectors := class selectors asArray. 373301 progressMessages 373302 displayProgressAt: Display center 373303 from: 0 to: selectors size 373304 during: [:bar | 373305 selectors with: (0 to: selectors size - 1) do: [:selector :index| 373306 bar value: index. 373307 (self isUnsentMessage: selector) ifTrue: [aBlock value: class value: selector] ]] 373308! ! 373309 373310!SystemNavigation methodsFor: 'message sends UI' stamp: 'Noury 10/26/2008 22:37'! 373311doWithProgressBar: aBlock forUnsentMessagesInPackageNamed: packageName 373312 |progressMessages classes | 373313 Cursor wait showWhile: [classes := self allClassesInPackageNamed: packageName]. 373314 progressMessages := 'Unsent messages in package ', packageName. 373315 progressMessages 373316 displayProgressAt: Display center 373317 from: 0 to: classes size 373318 during: [:bar | 373319 classes with: (0 to: classes size - 1) do: [:class :index| 373320 bar value: index. 373321 self doWithProgressBar: aBlock forUnsentMessagesInClass: class]]! ! 373322 373323!SystemNavigation methodsFor: 'message sends UI' stamp: 'Noury 10/26/2008 22:55'! 373324doWithProgressBarForAllUnsentMessages: aBlock 373325 |progressMessages classes | 373326 Cursor wait showWhile: [classes := self allClasses]. 373327 progressMessages := 'Unsent messages in all classes'. 373328 progressMessages 373329 displayProgressAt: Display center 373330 from: 0 to: classes size 373331 during: [:bar | 373332 classes with: (0 to: classes size - 1) do: [:class :index| 373333 bar value: index. 373334 self doWithProgressBar: aBlock forUnsentMessagesInClass: class]]! ! 373335 373336!SystemNavigation methodsFor: 'message sends UI' stamp: 'Noury 10/26/2008 22:49'! 373337removeUnsentMessagesWithProgressBarInClass: aClass 373338 self 373339 doWithProgressBar: [:class :selector| 373340 class remove: selector] 373341 forUnsentMessagesInClass: aClass! ! 373342 373343!SystemNavigation methodsFor: 'message sends UI' stamp: 'Noury 10/26/2008 22:48'! 373344removeUnsentMessagesWithProgressBarInPackageNamed: packageName 373345 self 373346 doWithProgressBar: [:class :selector| 373347 class removeSelector: selector] 373348 forUnsentMessagesInPackageNamed: packageName. 373349! ! 373350 373351!SystemNavigation methodsFor: 'message sends UI' stamp: 'Noury 10/26/2008 22:46'! 373352unsentMessagesWithProgressBarInClass: aClass 373353 | unsentMessages | 373354 unsentMessages := Set new. 373355 self 373356 doWithProgressBar: [:class :selector| 373357 unsentMessages add: (MethodReference class: class selector: selector)] 373358 forUnsentMessagesInClass: aClass. 373359 ^unsentMessages! ! 373360 373361!SystemNavigation methodsFor: 'message sends UI' stamp: 'Noury 10/26/2008 22:30'! 373362unsentMessagesWithProgressBarInPackageNamed: packageName 373363 | unsentMessages | 373364 unsentMessages := Set new. 373365 self 373366 doWithProgressBar: [:class :selector| 373367 unsentMessages add: (MethodReference class: class selector: selector)] 373368 forUnsentMessagesInPackageNamed: packageName. 373369 ^unsentMessages! ! 373370 373371 373372!SystemNavigation methodsFor: 'query' stamp: 'al 1/9/2006 19:13'! 373373allBehaviorsDo: aBlock 373374 "Evaluate the argument, aBlock, for each kind of Behavior in the system 373375 (that is, Object and its subclasses and Traits). 373376 ar 7/15/1999: The code below will not enumerate any obsolete or anonymous 373377 behaviors for which the following should be executed: 373378 373379 Smalltalk allObjectsDo:[:obj| obj isBehavior ifTrue:[aBlock value: obj]]. 373380 373381 but what follows is way faster than enumerating all objects." 373382 373383 aBlock value: ProtoObject. 373384 ProtoObject allSubclassesDoGently: aBlock. "don't bring in ImageSegments" 373385 373386 "Classes outside the ProtoObject hierarchy" 373387 Class subclassesDo: [:aClass | 373388 (aClass == ProtoObject class 373389 or: [aClass isInMemory not 373390 or: [aClass isMeta not]]) ifFalse: 373391 ["Enumerate the non-meta class and its subclasses" 373392 aBlock value: aClass soleInstance. 373393 aClass soleInstance allSubclassesDoGently: aBlock]]. 373394 373395 Trait allInstances , ClassTrait allInstances do: [:trait | 373396 aBlock value: trait]! ! 373397 373398!SystemNavigation methodsFor: 'query' stamp: 'marcus.denker 9/29/2008 08:23'! 373399allCallsOn: aLiteral 373400 "Answer a Collection of all the methods that call on aLiteral even deeply embedded in 373401 literal array." 373402 "self new allCallsOn: #open:label:." 373403 | aCollection special thorough aList byte | 373404 aCollection := OrderedCollection new. 373405 special := Smalltalk 373406 hasSpecialSelector: aLiteral 373407 ifTrueSetByte: [:b | byte := b]. 373408 thorough := aLiteral isSymbol. 373409 Cursor wait showWhile: [self allBehaviorsDo: [:class | 373410 aList := thorough 373411 ifTrue: [class 373412 thoroughWhichSelectorsReferTo: aLiteral 373413 special: special 373414 byte: byte] 373415 ifFalse: [class 373416 whichSelectorsReferTo: aLiteral 373417 special: special 373418 byte: byte]. 373419 aList do: [:sel | aCollection add: (MethodReference class: class selector: sel)]]]. 373420 ^ aCollection! ! 373421 373422!SystemNavigation methodsFor: 'query' stamp: 'marcus.denker 9/29/2008 08:29'! 373423allCallsOn: firstLiteral and: secondLiteral 373424 "Answer a SortedCollection of all the methods that call on both aLiteral 373425 and secondLiteral." 373426 373427 | aCollection secondArray firstSpecial secondSpecial firstByte secondByte | 373428 self flag: #ShouldUseAllCallsOn:. "sd" 373429 aCollection := SortedCollection new. 373430 firstSpecial := Smalltalk hasSpecialSelector: firstLiteral ifTrueSetByte: [:b | firstByte := b]. 373431 secondSpecial := Smalltalk hasSpecialSelector: secondLiteral ifTrueSetByte: [:b | secondByte := b]. 373432 Cursor wait showWhile: [ self allBehaviorsDo: [:class | 373433 secondArray := class whichSelectorsReferTo: secondLiteral special: secondSpecial byte: secondByte. 373434 ((class whichSelectorsReferTo: firstLiteral special: firstSpecial byte: firstByte) select: [:aSel | 373435 (secondArray includes: aSel)]) do: [:sel | 373436 aCollection add: (MethodReference class: class selector: sel)]]]. 373437 ^aCollection! ! 373438 373439!SystemNavigation methodsFor: 'query' stamp: 'marcus.denker 6/12/2009 15:33'! 373440allCallsOn: aSymbol from: aClass 373441 "Answer a SortedCollection of all the methods that call on aSymbol." 373442 373443 | aSortedCollection special byte | 373444 aSortedCollection := SortedCollection new. 373445 special := aClass environment hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte := b ]. 373446 aClass withAllSubclassesDo: [ :class | 373447 (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | 373448 aSortedCollection add: (MethodReference class: class selector: sel)]]. 373449 ^aSortedCollection! ! 373450 373451!SystemNavigation methodsFor: 'query' stamp: 'sd 4/17/2003 21:31'! 373452allClasses 373453 "currently returns all the classes defined in Smalltalk but could be customized 373454 for dealing with environments and in such a case would return on really all the classes" 373455 373456 ^ Smalltalk allClasses 373457 373458 ! ! 373459 373460!SystemNavigation methodsFor: 'query' stamp: 'al 2/13/2006 21:52'! 373461allClassesAndTraits 373462 373463 ^ Smalltalk allClassesAndTraits 373464 373465 ! ! 373466 373467!SystemNavigation methodsFor: 'query' stamp: 'sd 4/17/2003 21:31'! 373468allClassesDo: aBlock 373469 "currently returns all the classes defined in Smalltalk but could be customized 373470 for dealing with environments and in such a case would work on really all the classes" 373471 373472 ^ Smalltalk allClassesDo: aBlock 373473 373474 ! ! 373475 373476!SystemNavigation methodsFor: 'query' stamp: 'marcus.denker 9/29/2008 08:27'! 373477allClassesImplementing: aSelector 373478 "Answer an Array of all classes that implement the message aSelector." 373479 373480 | aCollection | 373481 aCollection := ReadWriteStream on: Array new. 373482 self allBehaviorsDo: [:class | (class includesSelector: aSelector) ifTrue: [aCollection nextPut: class]]. 373483 ^ aCollection contents! ! 373484 373485!SystemNavigation methodsFor: 'query' stamp: 'oha 6/27/2008 13:37'! 373486allClassesWithUnimplementedCalls 373487 "Answer an Array of classes that have messages with calls to methods that aren't implemented 373488 anywhere in the system" 373489 | all meth dict | 373490 dict := Dictionary new. 373491 all := self systemNavigation allImplementedMessages. 373492 self systemNavigation allBehaviorsDo: [:cl | 373493 cl selectorsDo: [:sel | 373494 meth := cl compiledMethodAt: sel. 373495 meth primitive = 0 ifTrue: [ 373496 meth messages do: [:m | 373497 (all includes: m) ifFalse: [ 373498 ((dict at: cl ifAbsentPut: [ Dictionary new ]) 373499 at: sel ifAbsentPut: [ OrderedCollection new]) 373500 add: m 373501 ] 373502 ] 373503 ] 373504 ] 373505 ]. 373506 ^ dict! ! 373507 373508!SystemNavigation methodsFor: 'query' stamp: 'sd 4/18/2003 10:04'! 373509allGlobalRefs 373510 "Answer a set of symbols that may be refs to Global names. In some sense we should only need the associations, but this will also catch, eg, HTML tag types." 373511 373512 ^ self allGlobalRefsWithout: {{}. {}}! ! 373513 373514!SystemNavigation methodsFor: 'query' stamp: 'stephane.ducasse 4/18/2009 11:40'! 373515allGlobalRefsWithout: classesAndMessagesPair 373516 "Answer a set of symbols that may be refs to Global names. In some 373517 sense we should only need the associations, but this will also catch, eg, 373518 HTML tag types. This method computes its result in the absence of 373519 specified classes and messages." 373520 "may be a problem if namespaces are introduced as for the moment 373521 only Smalltalk is queried. sd 29/4/03" 373522 | globalRefs absentClasses absentSelectors | 373523 globalRefs := IdentitySet new: CompiledMethod instanceCount. 373524 absentClasses := classesAndMessagesPair first. 373525 absentSelectors := classesAndMessagesPair second. 373526 self flag: #shouldBeRewrittenUsingSmalltalkAllClassesDo:. 373527 "sd 29/04/03" 373528 Cursor execute 373529 showWhile: [Smalltalk classNames 373530 do: [:cName | ((absentClasses includes: cName) 373531 ifTrue: [{}] 373532 ifFalse: [{Smalltalk at: cName. (Smalltalk at: cName) class}]) 373533 do: [:cl | (absentSelectors isEmpty 373534 ifTrue: [cl selectors] 373535 ifFalse: [cl selectors copyWithoutAll: absentSelectors]) 373536 do: [:sel | "Include all capitalized symbols for good 373537 measure" 373538 (cl compiledMethodAt: sel) literalsDo: [:m | 373539 ((m isSymbol) 373540 and: [m size > 0 373541 and: [m first canBeGlobalVarInitial]]) 373542 ifTrue: [globalRefs add: m]. 373543 (m isMemberOf: Array) 373544 ifTrue: [m 373545 do: [:x | ((x isSymbol) 373546 and: [x size > 0 373547 and: [x first canBeGlobalVarInitial]]) 373548 ifTrue: [globalRefs add: x]]]. 373549 m isVariableBinding 373550 ifTrue: [m key 373551 ifNotNil: [globalRefs add: m key]]]]]]]. 373552 ^ globalRefs! ! 373553 373554!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 13:30'! 373555allImplementedMessages 373556 "Answer a Set of all the messages that are implemented in the system." 373557 ^ self allImplementedMessagesWithout: {{}. {}}! ! 373558 373559!SystemNavigation methodsFor: 'query' stamp: 'al 1/13/2006 00:24'! 373560allImplementedMessagesWithout: classesAndMessagesPair 373561 "Answer a Set of all the messages that are implemented in the system, 373562 computed in the absence of the supplied classes and messages. Note this 373563 reports messages that are in the absent selectors set." 373564 | messages absentClasses | 373565 messages := IdentitySet new: CompiledMethod instanceCount. 373566 absentClasses := classesAndMessagesPair first. 373567 self flag: #shouldBeRewrittenUsingSmalltalkAllClassesDo:. "sd 29/04/03" 373568 Cursor execute showWhile: [ 373569 Smalltalk classNames , Smalltalk traitNames 373570 do: [:name | ((absentClasses includes: name) 373571 ifTrue: [{}] 373572 ifFalse: [{Smalltalk at: name. (Smalltalk at: name) classSide}]) 373573 do: [:each | messages addAll: each selectors]]]. 373574 ^ messages! ! 373575 373576!SystemNavigation methodsFor: 'query' stamp: 'sd 4/23/2003 22:31'! 373577allImplementorsOf: aSelector 373578 "Answer a SortedCollection of all the methods that implement the message 373579 aSelector." 373580 | aCollection | 373581 aCollection := SortedCollection new. 373582 Cursor wait 373583 showWhile: [self 373584 allBehaviorsDo: [:class | (class includesSelector: aSelector) 373585 ifTrue: [aCollection 373586 add: (MethodReference new setStandardClass: class methodSymbol: aSelector)]]]. 373587 ^ aCollection! ! 373588 373589!SystemNavigation methodsFor: 'query' stamp: 'apl 4/4/2005 17:59'! 373590allImplementorsOf: aSelector localTo: aClass 373591 "Answer a SortedCollection of all the methods that implement the message 373592 aSelector in, above, or below the given class." 373593 | cls aCollection | 373594 aCollection := SortedCollection new. 373595 cls := aClass theNonMetaClass. 373596 Cursor wait 373597 showWhile: [cls 373598 withAllSuperAndSubclassesDoGently: [:class | (class includesSelector: aSelector) 373599 ifTrue: [aCollection 373600 add: (MethodReference new setStandardClass: class methodSymbol: aSelector)]]. 373601 cls class 373602 withAllSuperAndSubclassesDoGently: [:class | (class includesSelector: aSelector) 373603 ifTrue: [aCollection 373604 add: (MethodReference new setStandardClass: class methodSymbol: aSelector)]]]. 373605 ^ aCollection! ! 373606 373607!SystemNavigation methodsFor: 'query' stamp: 'md 8/27/2005 16:42'! 373608allMethodsNoDoitsSelect: aBlock 373609 "Like allSelect:, but strip out Doits" 373610 | aCollection | 373611 aCollection := SortedCollection new. 373612 Cursor execute 373613 showWhile: [self 373614 allBehaviorsDo: [:class | class 373615 selectorsDo: [:sel | (sel isDoIt not 373616 and: [aBlock 373617 value: (class compiledMethodAt: sel)]) 373618 ifTrue: [aCollection 373619 add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]]. 373620 ^ aCollection! ! 373621 373622!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:41'! 373623allMethodsSelect: aBlock 373624 "Answer a SortedCollection of each method that, when used as the block 373625 argument to aBlock, gives a true result." 373626 | aCollection | 373627 aCollection := SortedCollection new. 373628 Cursor execute 373629 showWhile: [self 373630 allBehaviorsDo: [:class | class 373631 selectorsDo: [:sel | (aBlock 373632 value: (class compiledMethodAt: sel)) 373633 ifTrue: [aCollection 373634 add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]]. 373635 ^ aCollection! ! 373636 373637!SystemNavigation methodsFor: 'query' stamp: 'al 1/13/2006 11:59'! 373638allMethodsWithSourceString: aString matchCase: caseSensitive 373639 "Answer a SortedCollection of all the methods that contain, in source code, aString as a substring. Search the class comments also" 373640 373641 | list count adder | 373642 list := Set new. 373643 adder := [ :mrClass :mrSel | list add: ( MethodReference new 373644 setStandardClass: mrClass 373645 methodSymbol: mrSel)]. 373646 'Searching all source code...' 373647 displayProgressAt: Sensor cursorPoint 373648 from: 0 to: Smalltalk classNames size 373649 during: [:bar | 373650 count := 0. 373651 SystemNavigation default allBehaviorsDo: [:each | 373652 bar value: (count := count + 1). 373653 each selectorsDo: [:sel | 373654 ((each sourceCodeAt: sel) findString: aString 373655 startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [ 373656 sel isDoIt ifFalse: [adder value: each value: sel]]]. 373657 (each organization classComment asString findString: aString 373658 startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [ 373659 adder value: each value: #Comment] ]]. 373660 ^ list asSortedCollection! ! 373661 373662!SystemNavigation methodsFor: 'query' stamp: 'ar 8/18/2008 18:08'! 373663allObjectsDo: aBlock 373664 "Evaluate the argument, aBlock, for each object in the system 373665 excluding SmallIntegers." 373666 | object endMarker | 373667 object := self someObject. 373668 endMarker := Object new. 373669 [endMarker == object] 373670 whileFalse: [aBlock value: object. 373671 object := object nextObject]! ! 373672 373673!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:53'! 373674allObjectsSelect: aBlock 373675 "Evaluate the argument, aBlock, for each object in the system excluding 373676 SmallIntegers. Return a collection af all objects for whom the value is 373677 true. " 373678 ^ Array 373679 streamContents: [:s | self 373680 allObjectsDo: [:object | (aBlock value: object) 373681 ifTrue: [s nextPut: object]]]! ! 373682 373683!SystemNavigation methodsFor: 'query' stamp: 'nk 7/3/2003 19:51'! 373684allPrimitiveMethods 373685 "Answer an OrderedCollection of all the methods that are implemented by primitives." 373686 | aColl method | 373687 aColl := OrderedCollection new: 200. 373688 Cursor execute 373689 showWhile: [self allBehaviorsDo: [:class | class 373690 selectorsDo: [:sel | 373691 method := class compiledMethodAt: sel. 373692 method primitive ~= 0 373693 ifTrue: [aColl addLast: class name , ' ' , sel , ' ' , method primitive printString]]]]. 373694 ^ aColl! ! 373695 373696!SystemNavigation methodsFor: 'query' stamp: 'nk 7/3/2003 19:49'! 373697allPrimitiveMethodsInCategories: aList 373698 "Answer an OrderedCollection of all the methods that are implemented by 373699 primitives in the given categories. 1/26/96 sw" 373700 "SystemNavigation new allPrimitiveMethodsInCategories: 373701 #('Collections-Streams' 'Files-Streams' 'Files-Abstract' 'Files-Macintosh')" 373702 373703 | aColl method | 373704 aColl := OrderedCollection new: 200. 373705 Cursor execute 373706 showWhile: [self 373707 allBehaviorsDo: [:aClass | (aList includes: (SystemOrganization categoryOfElement: aClass theNonMetaClass name asString) asString) 373708 ifTrue: [aClass 373709 selectorsDo: [:sel | 373710 method := aClass compiledMethodAt: sel. 373711 method primitive ~= 0 373712 ifTrue: [aColl addLast: aClass name , ' ' , sel , ' ' , method primitive printString]]]]]. 373713 ^ aColl! ! 373714 373715!SystemNavigation methodsFor: 'query' stamp: 'ar 9/7/2003 17:58'! 373716allReferencesToPool: aPool from: aClass 373717 "Answer all the references to variables from aPool" 373718 | ref list | 373719 list := OrderedCollection new. 373720 aClass withAllSubclassesDo:[:cls| 373721 cls selectorsAndMethodsDo:[:sel :meth| 373722 ref := meth literals detect:[:lit| 373723 lit isVariableBinding and:[(aPool bindingOf: lit key) notNil] 373724 ] ifNone:[nil]. 373725 ref ifNotNil:[ 373726 list add:(MethodReference new setStandardClass: cls methodSymbol: sel) 373727 ]. 373728 ]. 373729 ]. 373730 ^list! ! 373731 373732!SystemNavigation methodsFor: 'query' stamp: 'sd 5/5/2003 09:18'! 373733allSelectorsWithAnyImplementorsIn: selectorList 373734 "Answer the subset of the given list which represent method selectors 373735 which have at least one implementor in the system." 373736 | good | 373737 good := OrderedCollection new. 373738 self allBehaviorsDo: [:class | selectorList 373739 do: [:aSelector | (class includesSelector: aSelector) 373740 ifTrue: [good add: aSelector]]]. 373741 ^ good asSet asSortedArray" 373742 SystemNavigation new selectorsWithAnyImplementorsIn: #( contents 373743 contents: nuts) 373744 "! ! 373745 373746!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 20:12'! 373747allSentMessages 373748 "Answer the set of selectors which are sent somewhere in the system." 373749 ^ self allSentMessagesWithout: {{}. {}}! ! 373750 373751!SystemNavigation methodsFor: 'query' stamp: 'stephane.ducasse 4/18/2009 11:39'! 373752allSentMessagesWithout: classesAndMessagesPair 373753 "Answer the set of selectors which are sent somewhere in the system, 373754 computed in the absence of the supplied classes and messages." 373755 | sent absentClasses absentSelectors | 373756 sent := IdentitySet new: CompiledMethod instanceCount. 373757 absentClasses := classesAndMessagesPair first. 373758 absentSelectors := classesAndMessagesPair second. 373759 self flag: #shouldBeRewrittenUsingSmalltalkAllClassesDo:. 373760 "sd 29/04/03" 373761 Cursor execute showWhile: [ 373762 Smalltalk classNames , Smalltalk traitNames do: [:name | 373763 ((absentClasses includes: name) 373764 ifTrue: [{}] 373765 ifFalse: [{Smalltalk at: name. (Smalltalk at: name) classSide}]) 373766 do: [:each | (absentSelectors isEmpty 373767 ifTrue: [each selectors] 373768 ifFalse: [each selectors copyWithoutAll: absentSelectors]) 373769 do: [:sel | "Include all sels, but not if sent by self" 373770 (each compiledMethodAt: sel) literalsDo: [:m | 373771 (m isSymbol) 373772 ifTrue: ["might be sent" 373773 m == sel 373774 ifFalse: [sent add: m]]. 373775 (m isMemberOf: Array) 373776 ifTrue: ["might be performed" 373777 m 373778 do: [:x | (x isSymbol) 373779 ifTrue: [x == sel 373780 ifFalse: [sent add: x]]]]]]]]. 373781 "The following may be sent without being in any literal frame" 373782 1 373783 to: Smalltalk specialSelectorSize 373784 do: [:index | sent 373785 add: (Smalltalk specialSelectorAt: index)]]. 373786 Smalltalk presumedSentMessages 373787 do: [:sel | sent add: sel]. 373788 ^ sent! ! 373789 373790!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 19:19'! 373791allUnSentMessagesWithout: classesAndMessagesPair 373792 "Answer the set of selectors that are implemented but not sent, computed 373793 in the absence of the supplied classes and messages." 373794 ^ (self allImplementedMessagesWithout: classesAndMessagesPair) 373795 copyWithoutAll: (self allSentMessagesWithout: classesAndMessagesPair)! ! 373796 373797!SystemNavigation methodsFor: 'query' stamp: 'PeterHugossonMiller 9/3/2009 11:31'! 373798allUnimplementedCalls 373799 "Answer an Array of each message that is sent by an expression in a 373800 method but is not implemented by any object in the system." 373801 | aStream secondStream all | 373802 all := self allImplementedMessages. 373803 aStream := (Array new: 50) writeStream. 373804 Cursor execute 373805 showWhile: [self 373806 allBehaviorsDo: [:cl | cl 373807 selectorsDo: [:sel | 373808 secondStream := (String new: 5) writeStream. 373809 (cl compiledMethodAt: sel) messages 373810 do: [:m | (all includes: m) 373811 ifFalse: [secondStream nextPutAll: m; 373812 space]]. 373813 secondStream position = 0 373814 ifFalse: [aStream nextPut: cl name , ' ' , sel , ' calls: ' , secondStream contents]]]]. 373815 ^ aStream contents! ! 373816 373817!SystemNavigation methodsFor: 'query' stamp: 'PeterHugossonMiller 9/3/2009 11:31'! 373818allUnimplementedNonPrimitiveCalls 373819 "Answer an Array of each message that is sent by an expression in a 373820 method but is not implemented by any object in the system." 373821 | aStream secondStream all meth | 373822 all := self systemNavigation allImplementedMessages. 373823 aStream := (Array new: 50) writeStream. 373824 Cursor execute 373825 showWhile: [self systemNavigation 373826 allBehaviorsDo: [:cl | cl 373827 selectorsDo: [:sel | 373828 secondStream := (String new: 5) writeStream. 373829 meth := cl compiledMethodAt: sel. 373830 meth primitive = 0 ifTrue: [ 373831 meth messages 373832 do: [:m | (all includes: m) 373833 ifFalse: [secondStream nextPutAll: m; 373834 space]]. 373835 secondStream position = 0 373836 ifFalse: [aStream nextPut: cl name , ' ' , sel , ' calls: ' , secondStream contents]]]]]. 373837 ^ aStream contents! ! 373838 373839!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 13:07'! 373840allUnreferencedClassVariablesOf: aClass 373841 "Answer a list of the names of all the receiver's unreferenced class 373842 vars, including those defined in superclasses" 373843 | aList | 373844 aList := OrderedCollection new. 373845 aClass withAllSuperclasses 373846 reverseDo: [:aSuperClass | aSuperClass classVarNames 373847 do: [:var | (self allCallsOn: (aSuperClass classPool associationAt: var)) isEmpty 373848 ifTrue: [aList add: var]]]. 373849 ^ aList! ! 373850 373851!SystemNavigation methodsFor: 'query' stamp: 'marcus.denker 10/22/2008 14:38'! 373852allUnsentMessages 373853 "SystemNavigation new allUnSentMessages" 373854 "Answer the set of selectors that are implemented by some object in the 373855 system but not sent by any." 373856 ^ self allUnSentMessagesWithout: {{}. {}}! ! 373857 373858!SystemNavigation methodsFor: 'query' stamp: 'stephane.ducasse 10/12/2008 21:01'! 373859allUnsentMessagesIn: selectorSet 373860 "Answer the subset of selectorSet which are not sent anywhere in the 373861 system. " 373862 ^ selectorSet copyWithoutAll: self allSentMessages! ! 373863 373864!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 19:06'! 373865allUnusedClassesWithout: classesAndMessagesPair 373866 "Enumerates all classes in the system and returns a list of those that are 373867 apparently unused. A class is considered in use if it (a) has subclasses 373868 or (b) is referred to by some method or (c) has its name in use as a 373869 literal." 373870 "SystemNavigation new unusedClasses" 373871 373872 | unused cl | 373873 unused := Smalltalk classNames asIdentitySet 373874 copyWithoutAll: (self allGlobalRefsWithout: classesAndMessagesPair). 373875 ^ unused 373876 reject: [:cName | 373877 cl := Smalltalk at: cName. 373878 cl subclasses isEmpty not 373879 or: [cl inheritsFrom: FileDirectory]]! ! 373880 373881!SystemNavigation methodsFor: 'query' stamp: 'sd 1/16/2004 21:01'! 373882hierarchyOfClassesSurrounding: aClass 373883 "Answer a list of classes in the hierarchy both above and below the given class" 373884 "SystemNavigation default hierarchyOfClassesSurrounding: StringHolder" 373885 373886 | list aClassNonMeta isMeta theClassOrMeta | 373887 aClass ifNil: [^ OrderedCollection new]. 373888 aClass ifNil: [^ self]. 373889 aClassNonMeta := aClass theNonMetaClass. 373890 isMeta := aClassNonMeta ~~ aClass. 373891 list := OrderedCollection new. 373892 aClass allSuperclasses reverseDo: 373893 [:cl | list addLast: cl]. 373894 aClassNonMeta allSubclassesWithLevelDo: 373895 [:cl :level | 373896 theClassOrMeta := isMeta ifTrue: [cl class] ifFalse: [cl]. 373897 list addLast: theClassOrMeta] 373898 startingLevel: 0. 373899 ^ list 373900 373901! ! 373902 373903!SystemNavigation methodsFor: 'query' stamp: 'sd 1/16/2004 21:03'! 373904hierarchyOfImplementorsOf: aSelector forClass: aClass 373905 "Answer a list of classes in the hierarchy both above and below the given class which implement the given selector." 373906 "SystemNavigation default hierarchyOfImplementorsOf: #contents forClass: StringHolder" 373907 373908 ^ (self hierarchyOfClassesSurrounding: aClass) select: 373909 [:cl | cl includesSelector: aSelector] 373910! ! 373911 373912!SystemNavigation methodsFor: 'query' stamp: 'sd 4/18/2003 10:44'! 373913isThereAnImplementorOf: aSelector 373914 "Answer true if there is at least one implementor of the selector found 373915 in the system, false if there are no implementors" 373916 "self new isThereAnImplementorOf: #contents. 373917 self new isThereAnImplementorOf: #nobodyImplementsThis." 373918 self 373919 allBehaviorsDo: [:class | (class includesSelector: aSelector) 373920 ifTrue: [^ true]]. 373921 ^ false! ! 373922 373923!SystemNavigation methodsFor: 'query' stamp: 'sd 4/20/2003 14:27'! 373924numberOfImplementorsOf: aSelector 373925 "Answer a count of the implementors of the given selector found in the 373926 system" 373927 "self new numberOfImplementorsOf: #contents. 373928 self new numberOfImplementorsOf: #nobodyImplementsThis. 373929 self new numberOfimplementorsOf: #numberOfImplementorsOf:." 373930 | aCount | 373931 aCount := 0. 373932 self 373933 allBehaviorsDo: [:class | (class includesSelector: aSelector) 373934 ifTrue: [aCount := aCount + 1]]. 373935 ^ aCount! ! 373936 373937!SystemNavigation methodsFor: 'query' stamp: 'sd 9/23/2004 22:03'! 373938obsoleteBehaviors 373939 "SystemNavigation default obsoleteBehaviors inspect" 373940 "Find all obsolete behaviors including meta classes" 373941 373942 | obs | 373943 obs := OrderedCollection new. 373944 Smalltalk garbageCollect. 373945 self 373946 allObjectsDo: [:cl | (cl isBehavior 373947 and: [cl isObsolete]) 373948 ifTrue: [obs add: cl]]. 373949 ^ obs asArray! ! 373950 373951!SystemNavigation methodsFor: 'query' stamp: 'sd 9/23/2004 22:06'! 373952obsoleteClasses 373953 373954 "SystemNavigation default obsoleteClasses inspect" 373955 "NOTE: Also try inspecting comments below" 373956 | obs c | 373957 obs := OrderedCollection new. Smalltalk garbageCollect. 373958 Metaclass allInstancesDo: 373959 [:m | c := m soleInstance. 373960 (c ~~ nil and: ['AnOb*' match: c name asString]) 373961 ifTrue: [obs add: c]]. 373962 ^ obs asArray 373963 373964"Likely in a ClassDict or Pool... 373965(Association allInstances select: [:a | (a value isKindOf: Class) and: ['AnOb*' match: a value name]]) asArray 373966" 373967"Obsolete class refs or super pointer in last lit of a method... 373968| n l found | 373969Smalltalk browseAllSelect: 373970 [:m | found := false. 373971 1 to: m numLiterals do: 373972 [:i | (((l := m literalAt: i) isMemberOf: Association) 373973 and: [(l value isKindOf: Behavior) 373974 and: ['AnOb*' match: l value name]]) 373975 ifTrue: [found := true]]. 373976 found] 373977"! ! 373978 373979!SystemNavigation methodsFor: 'query' stamp: 'PeterHugossonMiller 9/3/2009 11:32'! 373980obsoleteMethodReferences 373981 "SystemNavigation default obsoleteMethodReferences" 373982 373983 "Open a browser on all referenced behaviors that are obsolete" 373984 373985 | obsClasses obsRefs references | 373986 references := Array new writeStream. 373987 obsClasses := self obsoleteBehaviors. 373988 'Scanning for methods referencing obsolete classes' 373989 displayProgressAt: Sensor cursorPoint 373990 from: 1 373991 to: obsClasses size 373992 during: 373993 [:bar | 373994 obsClasses keysAndValuesDo: 373995 [:index :each | 373996 bar value: index. 373997 obsRefs := PointerFinder pointersTo: each except: obsClasses. 373998 obsRefs do: 373999 [:ref | 374000 "Figure out if it may be a global" 374001 374002 (ref isVariableBinding and: [ref key isString "or Symbol"]) 374003 ifTrue: 374004 [(Utilities pointersTo: ref) do: 374005 [:meth | 374006 (meth isKindOf: CompiledMethod) 374007 ifTrue: [meth methodReference ifNotNil: [:mref | references nextPut: mref]]]]]]]. 374008 ^references contents! ! 374009 374010!SystemNavigation methodsFor: 'query' stamp: 'stephane.ducasse 7/10/2009 16:07'! 374011reportSenderCountsFor: selectorList 374012 "Produce a report on the number of senders of each of the selectors in 374013 the list. 1/27/96 sw" 374014 "SystemNavigation default reportSenderCountsFor: #(foo: printString)" 374015 | total report thisSize | 374016 total := 0. 374017 report := ' 374018'. 374019 selectorList 374020 do: [:selector | 374021 thisSize := (self allCallsOn: selector) size. 374022 report := report , thisSize printString , String tab , selector printString , String cr. 374023 total := total + thisSize]. 374024 report := report , '--- ------------------ 374025'. 374026 report := report , total printString , String tab , 'TOTAL 374027'. 374028 ^ report! ! 374029 374030!SystemNavigation methodsFor: 'query' stamp: 'sd 4/29/2003 15:17'! 374031selectAllMethods: aBlock 374032 "Answer a SortedCollection of each method that, when used as the block 374033 argument to aBlock, gives a true result." 374034 | aCollection | 374035 aCollection := SortedCollection new. 374036 Cursor execute 374037 showWhile: [self 374038 allBehaviorsDo: [:class | class 374039 selectorsDo: [:sel | (aBlock 374040 value: (class compiledMethodAt: sel)) 374041 ifTrue: [aCollection 374042 add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]]. 374043 ^ aCollection! ! 374044 374045!SystemNavigation methodsFor: 'query' stamp: 'md 8/27/2005 17:17'! 374046selectAllMethodsNoDoits: aBlock 374047 "Like allSelect:, but strip out Doits" 374048 | aCollection | 374049 aCollection := SortedCollection new. 374050 Cursor execute 374051 showWhile: [self 374052 allBehaviorsDo: [:class | class 374053 selectorsDo: [:sel | (sel isDoIt not 374054 and: [aBlock 374055 value: (class compiledMethodAt: sel)]) 374056 ifTrue: [aCollection 374057 add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]]. 374058 ^ aCollection! ! 374059 374060!SystemNavigation methodsFor: 'query' stamp: 'md 7/19/2004 16:03'! 374061unimplemented 374062 "Answer an Array of each message that is sent by an expression in a method but is not implemented by any object in the system." 374063 374064 | all unimplemented entry | 374065 all := IdentitySet new: Symbol instanceCount * 2. 374066 Cursor wait showWhile: 374067 [self allBehaviorsDo: [:cl | cl selectorsDo: [:aSelector | all add: aSelector]]]. 374068 374069 unimplemented := IdentityDictionary new. 374070 Cursor execute showWhile: [ 374071 self allBehaviorsDo: [:cl | 374072 cl selectorsDo: [:sel | 374073 (cl compiledMethodAt: sel) messages do: [:m | 374074 (all includes: m) ifFalse: [ 374075 entry := unimplemented at: m ifAbsent: [Array new]. 374076 entry := entry copyWith: (cl name, '>', sel). 374077 unimplemented at: m put: entry]]]]]. 374078 ^ unimplemented 374079! ! 374080 374081 374082!SystemNavigation methodsFor: 'ui' stamp: 'AndrewBlack 9/1/2009 15:45'! 374083classFromPattern: pattern withCaption: aCaption 374084 "If there is a class whose name exactly given by pattern, return it. 374085 If there is only one class in the system whose name matches pattern, return it. 374086 Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen. 374087 This method ignores tab, space, & cr characters in the pattern" 374088 374089 | toMatch potentialClassNames classNames exactMatch index | 374090 (toMatch := pattern copyWithoutAll: 374091 {Character space. Character cr. Character tab}) 374092 isEmpty ifTrue: [^ nil]. 374093 Symbol hasInterned: toMatch ifTrue: 374094 [:patternSymbol | Smalltalk at: patternSymbol ifPresent: 374095 [:maybeClass | ((maybeClass isKindOf: Class) or: [maybeClass isKindOf: Trait]) 374096 ifTrue: [^ maybeClass]]]. 374097 374098 toMatch := (toMatch copyWithout: $.) asLowercase. 374099 potentialClassNames := (Smalltalk classNames , Smalltalk traitNames) asOrderedCollection. 374100 classNames := pattern last = $. 374101 ifTrue: [potentialClassNames select: 374102 [:nm | nm asLowercase = toMatch]] 374103 ifFalse: [potentialClassNames select: 374104 [:n | n includesSubstring: toMatch caseSensitive: false]]. 374105 classNames isEmpty ifTrue: [^ nil]. 374106 exactMatch := classNames detect: [:each | each asLowercase = toMatch] ifNone: [nil]. 374107 374108 index := classNames size = 1 374109 ifTrue: [1] 374110 ifFalse: [exactMatch 374111 ifNil: [UIManager default chooseFrom: classNames lines: #() title: aCaption] 374112 ifNotNil: [classNames addFirst: exactMatch. 374113 UIManager default chooseFrom: classNames lines: #(1) title: aCaption]]. 374114 index = 0 ifTrue: [^ nil]. 374115 ^ Smalltalk at: (classNames at: index) asSymbol 374116 374117" 374118 self classFromPattern: 'znak' withCaption: '' 374119 self classFromPattern: 'orph' withCaption: '' 374120 self classFromPattern: 'TCompil' withCaption: '' 374121" 374122! ! 374123 374124!SystemNavigation methodsFor: 'ui' stamp: 'rbb 2/18/2005 14:48'! 374125confirmRemovalOf: aSelector on: aClass 374126 "Determine if it is okay to remove the given selector. Answer 1 if it 374127 should be removed, 2 if it should be removed followed by a senders 374128 browse, and 3 if it should not be removed." 374129 | count answer caption allCalls | 374130 allCalls := self allCallsOn: aSelector. 374131 (count := allCalls size) == 0 374132 ifTrue: [^ 1]. 374133 "no senders -- let the removal happen without warning" 374134 count == 1 374135 ifTrue: [(allCalls first actualClass == aClass 374136 and: [allCalls first methodSymbol == aSelector]) 374137 ifTrue: [^ 1]]. 374138 "only sender is itself" 374139 caption := 'This message has ' , count printString , ' sender'. 374140 count > 1 374141 ifTrue: [caption := caption copyWith: $s]. 374142 answer := UIManager default 374143 chooseFrom: #('Remove it' 374144 'Remove, then browse senders' 374145 'Don''t remove, but show me those senders' 374146 'Forget it -- do nothing -- sorry I asked') title: caption. 374147 answer == 3 374148 ifTrue: [self 374149 browseMessageList: allCalls 374150 name: 'Senders of ' , aSelector 374151 autoSelect: aSelector keywords first]. 374152 answer == 0 374153 ifTrue: [answer := 3]. 374154 "If user didn't answer, treat it as cancel" 374155 ^ answer min: 3! ! 374156 374157!SystemNavigation methodsFor: 'ui' stamp: 'sd 4/15/2003 15:34'! 374158showMenuOf: selectorCollection withFirstItem: firstItem ifChosenDo: choiceBlock 374159 "Show a sorted menu of the given selectors, preceded by firstItem, and all 374160 abbreviated to 40 characters. Evaluate choiceBlock if a message is chosen." 374161 374162 ^ self showMenuOf: selectorCollection withFirstItem: firstItem ifChosenDo: choiceBlock withCaption: nil! ! 374163 374164!SystemNavigation methodsFor: 'ui' stamp: 'edc 11/8/2005 10:58'! 374165showMenuOf: selectorCollection withFirstItem: firstItem ifChosenDo: choiceBlock withCaption: aCaption 374166 "Show a sorted menu of the given selectors, preceded by firstItem, and all abbreviated to 40 characters. Use aCaption as the menu title, if it is not nil. Evaluate choiceBlock if a message is chosen." 374167 374168 | index menuLabels sortedList | 374169 sortedList := selectorCollection asSortedCollection. 374170 menuLabels := String streamContents: 374171 [:strm | strm nextPutAll: (firstItem contractTo: 40). 374172 sortedList do: [:sel | strm cr; nextPutAll: (sel contractTo: 40)]]. 374173 index := UIManager default chooseFrom: (menuLabels substrings) lines: #(1). 374174 index = 1 ifTrue: [choiceBlock value: firstItem]. 374175 index > 1 ifTrue: [choiceBlock value: (sortedList at: index - 1)]! ! 374176 374177 374178!SystemNavigation methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 08:21'! 374179allUnSentMessages 374180 374181 self deprecated: 'Use ''allUnsentMessages'' instead.'. 374182 ^ self allUnsentMessages. ! ! 374183 374184!SystemNavigation methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 08:21'! 374185allUnSentMessagesIn: selectorSet 374186 "Answer the subset of selectorSet which are not sent anywhere in the 374187 system. " 374188 self deprecated: 'Use ''allUnsentMessagesIn:'' instead.'. 374189 ^ self allUnsentMessagesIn: selectorSet! ! 374190 374191"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 374192 374193SystemNavigation class 374194 instanceVariableNames: ''! 374195 374196!SystemNavigation class methodsFor: 'accessing' stamp: 'marcus.denker 9/14/2008 21:05'! 374197default 374198 Default ifNil: [Default := self new]. 374199 ^Default! ! 374200TestCase subclass: #SystemNavigationTest 374201 instanceVariableNames: 'classFactory navigator' 374202 classVariableNames: '' 374203 poolDictionaries: '' 374204 category: 'Tests-System'! 374205!SystemNavigationTest commentStamp: 'nice 3/22/2008 00:19' prior: 0! 374206I am an sunit test for SystemNavigation.! 374207 374208 374209!SystemNavigationTest methodsFor: 'setUp-tearDown' stamp: 'Noury 10/26/2008 15:39'! 374210setUp 374211 super setUp. 374212 navigator := SystemNavigation new. 374213 classFactory := ClassFactoryForTestCase new. 374214! ! 374215 374216!SystemNavigationTest methodsFor: 'setUp-tearDown' stamp: 'Noury 10/26/2008 14:53'! 374217tearDown 374218 super tearDown. 374219 classFactory cleanUp! ! 374220 374221 374222!SystemNavigationTest methodsFor: 'testing' stamp: 'nice 3/22/2008 00:38'! 374223testAllMethodsInCategory 374224 "This is a non regression test for http://bugs.squeak.org/view.php?id=6986 374225 allMethodsInCategory: should return a list of existing methods" 374226 374227 | classAndMethods methodReferences | 374228 classAndMethods := SystemNavigation default allMethodsInCategory: 'removing'. 374229 methodReferences := classAndMethods collect: [:e | e isString 374230 ifTrue: [MessageSet 374231 parse: e 374232 toClassAndSelector: [:cls :sel | MethodReference class: cls selector: sel]] 374233 ifFalse: [e]]. 374234 self assert: (methodReferences allSatisfy: [:mr | mr actualClass includesSelector: mr methodSymbol])! ! 374235 374236!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:19'! 374237testIsMessageSentInCategoryWithClassesActuallySendingTheMessage 374238 5 timesRepeat: [classFactory newClass]. 374239 (classFactory createdClasses asArray first: 3) do: [:class| 374240 class compile: 'meth self m']. 374241 self assert: (navigator isMessage: #m sentInClassCategory: classFactory defaultCategory). 374242 self assert: (navigator allSendersOf: #m inClassCategory: classFactory defaultCategory) size = 3! ! 374243 374244!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:19'! 374245testIsMessageSentInCategoryWithTheSelectorInsideAnArray 374246 5 timesRepeat: [classFactory newClass]. 374247 (classFactory createdClasses asArray first: 3) do: [:class| 374248 class compile: 'meth ^#(a b m c)']. 374249 self assert: (navigator isMessage: #m sentInClassCategory: classFactory defaultCategory). 374250 self assert: (navigator allSendersOf: #m inClassCategory: classFactory defaultCategory) size = 3! ! 374251 374252!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 15:39'! 374253testIsMessageSentInClassActuallySendingTheMessage 374254 |class| 374255 class := classFactory newClass. 374256 class compile: 'meth self m'. 374257 self assert: (navigator isMessage: #m sentInClass: class). 374258 self assert: (navigator allSendersOf: #m inClass: class) size = 1! ! 374259 374260!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 15:39'! 374261testIsMessageSentInClassWithTheSelectorInsideAnArray 374262 |class| 374263 class := classFactory newClass. 374264 class compile: 'meth ^#(a b m c)'. 374265 self assert: (navigator isMessage: #m sentInClass: class). 374266 self assert: (navigator allSendersOf: #m inClass: class) size = 1! ! 374267 374268!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 17:32'! 374269testIsMessageSentInMetaclassActuallySendingTheMessage 374270 |class| 374271 class := classFactory newClass. 374272 class class compile: 'meth self m'. 374273 self assert: (navigator isMessage: #m sentInClass: class). 374274 self assert: (navigator allSendersOf: #m inClass: class) size = 1! ! 374275 374276!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 17:33'! 374277testIsMessageSentInMetaclassWithTheSelectorInsideAnArray 374278 |class| 374279 class := classFactory newClass. 374280 class class compile: 'meth ^#(a b m c)'. 374281 self assert: (navigator isMessage: #m sentInClass: class). 374282 self assert: (navigator allSendersOf: #m inClass: class) size = 1! ! 374283 374284!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:55'! 374285testIsMessageSentInPackageWithClassesActuallySendngTheMessage 374286 | classesSendingMessage | 374287 5 timesRepeat: [classFactory newClassInCategory: #One]. 374288 5 timesRepeat: [classFactory newClassInCategory: #Two]. 374289 classesSendingMessage := (classFactory createdClasses asArray first: 2), (classFactory createdClasses asArray last: 3). 374290 classesSendingMessage do: [:class| 374291 class compile: 'meth self m']. 374292 self assert: (navigator isMessage: #m sentInPackageNamed: classFactory packageName). 374293 self assert: (navigator allSendersOf: #m inPackageNamed: classFactory packageName) size = 5! ! 374294 374295!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:18'! 374296testIsMessageSentInPackageWithTheSelectorInsideAnArray 374297 | classesSendingMessage | 374298 5 timesRepeat: [classFactory newClassInCategory: #One]. 374299 5 timesRepeat: [classFactory newClassInCategory: #Two]. 374300 classesSendingMessage := (classFactory createdClasses asArray first: 2), (classFactory createdClasses asArray last: 3). 374301 classesSendingMessage do: [:class| 374302 class compile: 'meth ^#(a b m c)']. 374303 self assert: (navigator isMessage: #m sentInPackageNamed: classFactory packageName). 374304 self assert: (navigator allSendersOf: #m inPackageNamed: classFactory packageName) size = 5! ! 374305 374306!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 22:16'! 374307testIsMessageSentInSystemAnswersMethodReference 374308 | classesSendingMessage sentMessageSelector| 374309 sentMessageSelector := 'MessageSentOnlyByTestClassesXXXShouldNotBeRealyDefined' asSymbol. 374310 5 timesRepeat: [classFactory newClassInCategory: #One]. 374311 5 timesRepeat: [classFactory newClassInCategory: #Two]. 374312 classesSendingMessage := (classFactory createdClasses asArray first: 2), (classFactory createdClasses asArray last: 3). 374313 classesSendingMessage do: [:class| 374314 class compile: 'meth self ', sentMessageSelector]. 374315 self assert: ((navigator allSendersOf: sentMessageSelector) anyOne isKindOf: MethodReference)! ! 374316 374317!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 17:18'! 374318testIsMessageSentInSystemWithClassesActuallySendngTheMessage 374319 | classesSendingMessage sentMessageSelector| 374320 sentMessageSelector := 'MessageSentOnlyByTestClassesXXXShouldNotBeRealyDefined' asSymbol. 374321 5 timesRepeat: [classFactory newClassInCategory: #One]. 374322 5 timesRepeat: [classFactory newClassInCategory: #Two]. 374323 classesSendingMessage := (classFactory createdClasses asArray first: 2), (classFactory createdClasses asArray last: 3). 374324 classesSendingMessage do: [:class| 374325 class compile: 'meth self ', sentMessageSelector]. 374326 self assert: (navigator allSendersOf: sentMessageSelector) size = 5! ! 374327 374328!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 17:20'! 374329testIsMessageSentInSystemWithTheSelectorInsideAnArray 374330 | classesSendingMessage sentMessageSelector | 374331 sentMessageSelector := 'MessageSentOnlyByTestClassesXXXShouldNotBeRealyDefined' asSymbol. 374332 5 timesRepeat: [classFactory newClassInCategory: #One]. 374333 5 timesRepeat: [classFactory newClassInCategory: #Two]. 374334 classesSendingMessage := (classFactory createdClasses asArray first: 2), (classFactory createdClasses asArray last: 3). 374335 classesSendingMessage do: [:class| 374336 class compile: 'meth ^#(a b ', sentMessageSelector, ' c)']. 374337 self assert: (navigator allSendersOf: sentMessageSelector) size = 5! ! 374338 374339!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 17:03'! 374340testIsUnsentMessage 374341 | class | 374342 class := classFactory newClass. 374343 class compile: 'messageNeverSentInTheSystemXXXXThisIsForTest ^self'. 374344 self assert: (navigator isUnsentMessage: class selectors anyOne)! ! 374345 374346!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 22:14'! 374347testIsUnsentMessagesAnswerMethodReferences 374348 | class otherClass methReference | 374349 class := classFactory newClass. 374350 class compile: 'messageNeverSentInTheSystemXXXXThisIsForTest ^self'. 374351 class compile: 'sentMessage'. 374352 otherClass := classFactory newClass. 374353 otherClass compile: 'printString self sentMessage'. 374354 otherClass compile: 'otherMessageNeverSentInTheSystemXXXXThisIsForTest ^self'. 374355 methReference := (navigator unsentMessagesInCategory: classFactory defaultCategory) anyOne. 374356 self assert: (methReference isKindOf: MethodReference)! ! 374357 374358!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 22:11'! 374359testIsUnsentMessagesInCategory 374360 | class otherClass expecetedMethReferencesInClass expecetedMethReferencesInOtherClass | 374361 class := classFactory newClass. 374362 class compile: 'messageNeverSentInTheSystemXXXXThisIsForTest ^self'. 374363 class compile: 'sentMessage'. 374364 otherClass := classFactory newClass. 374365 otherClass compile: 'printString self sentMessage'. 374366 otherClass compile: 'otherMessageNeverSentInTheSystemXXXXThisIsForTest ^self'. 374367 expecetedMethReferencesInClass := (class selectors copyWithout: #sentMessage) collect: [:selector| 374368 MethodReference class: class selector: selector]. 374369 expecetedMethReferencesInOtherClass := (otherClass selectors copyWithout: #printString) collect: [:selector| 374370 MethodReference class: otherClass selector: selector]. 374371 self assert: (navigator unsentMessagesInCategory: classFactory defaultCategory) asSet = (expecetedMethReferencesInClass, expecetedMethReferencesInOtherClass)! ! 374372 374373!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 22:07'! 374374testIsUnsentMessagesInClass 374375 | class otherClass expecetedMethReferences | 374376 class := classFactory newClass. 374377 class compile: 'messageNeverSentInTheSystemXXXXThisIsForTest ^self'. 374378 class compile: 'otherMessageNeverSentInTheSystemXXXXThisIsForTest ^self'. 374379 class compile: 'sentMessage'. 374380 otherClass := classFactory newClass. 374381 otherClass compile: 'printString self sentMessage'. 374382 expecetedMethReferences := (class selectors copyWithout: #sentMessage) collect: [:selector| 374383 MethodReference class: class selector: selector]. 374384 self assert: (navigator unsentMessagesInClass: class) asSet = expecetedMethReferences! ! 374385 374386!SystemNavigationTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 22:12'! 374387testIsUnsentMessagesInPackage 374388 | class otherClass expecetedMethReferencesInClass expecetedMethReferencesInOtherClass | 374389 class := classFactory newClassInCategory: #One. 374390 class compile: 'messageNeverSentInTheSystemXXXXThisIsForTest ^self'. 374391 class compile: 'sentMessage'. 374392 otherClass := classFactory newClassInCategory: #Two. 374393 otherClass compile: 'printString self sentMessage'. 374394 otherClass compile: 'otherMessageNeverSentInTheSystemXXXXThisIsForTest ^self'. 374395 expecetedMethReferencesInClass := (class selectors copyWithout: #sentMessage) collect: [:selector| 374396 MethodReference class: class selector: selector]. 374397 expecetedMethReferencesInOtherClass := (otherClass selectors copyWithout: #printString) collect: [:selector| 374398 MethodReference class: otherClass selector: selector]. 374399 self assert: (navigator unsentMessagesInPackageNamed: classFactory packageName) asSet = (expecetedMethReferencesInClass, expecetedMethReferencesInOtherClass)! ! 374400Categorizer subclass: #SystemOrganizer 374401 instanceVariableNames: '' 374402 classVariableNames: '' 374403 poolDictionaries: '' 374404 category: 'System-Support'! 374405!SystemOrganizer commentStamp: '<historical>' prior: 0! 374406My instances provide an organization for the classes in the system, just as a ClassOrganizer organizes the messages within a class. The only difference is the methods for fileIn/Out.! 374407 374408 374409!SystemOrganizer methodsFor: 'accessing' stamp: 'ab 2/10/2005 16:33'! 374410addCategory: newCategory 374411 | r | 374412 r := super addCategory: newCategory. 374413 SystemChangeNotifier uniqueInstance classCategoryAdded: newCategory. 374414 ^ r! ! 374415 374416!SystemOrganizer methodsFor: 'accessing' stamp: 'Noury 10/26/2008 15:46'! 374417classesInCategory: category 374418 ^(self listAtCategoryNamed: category) collect: [:className| 374419 Smalltalk at: className]! ! 374420 374421!SystemOrganizer methodsFor: 'accessing' stamp: 'ab 2/10/2005 16:36'! 374422removeCategory: cat 374423 | r | 374424 r := super removeCategory: cat. 374425 SystemChangeNotifier uniqueInstance classCategoryRemoved: cat. 374426 ^ r! ! 374427 374428!SystemOrganizer methodsFor: 'accessing' stamp: 'ab 2/10/2005 16:47'! 374429renameCategory: oldCatString toBe: newCatString 374430 | r | 374431 r := super renameCategory: oldCatString toBe: newCatString. 374432 SystemChangeNotifier uniqueInstance 374433 classCategoryRenamedFrom: oldCatString to: newCatString. 374434 ^ r! ! 374435 374436 374437!SystemOrganizer methodsFor: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 11:32'! 374438fileOut 374439 "SystemOrganization fileOut" 374440 374441 | internalStream | 374442 internalStream := (String new: 30000) writeStream. 374443 internalStream nextPutAll: 'SystemOrganization changeFromCategorySpecs: #('; cr; 374444 print: SystemOrganization; "ends with a cr" 374445 nextPutAll: ')!!'; cr. 374446 374447 FileStream writeSourceCodeFrom: internalStream baseName: (FileDirectory default nextNameFor: 'SystemOrganization' extension: 'st') isSt: true 374448! ! 374449 374450!SystemOrganizer methodsFor: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 11:32'! 374451fileOutCategory: category 374452 "Store on the file named category (a string) concatenated with '.st' all the 374453 classes associated with the category." 374454 374455 | internalStream | 374456 internalStream := (String new: 1000) writeStream. 374457 self fileOutCategory: category on: internalStream initializing: true. 374458 ^ FileStream writeSourceCodeFrom: internalStream baseName: category isSt: true ! ! 374459 374460!SystemOrganizer methodsFor: 'filein/out' stamp: 'ar 12/22/1999 17:28'! 374461fileOutCategory: category on: aFileStream 374462 "Store on the file associated with aFileStream, all the classes associated 374463 with the category and any requested shared pools." 374464 ^self fileOutCategory: category on: aFileStream initializing: true! ! 374465 374466!SystemOrganizer methodsFor: 'filein/out' stamp: 'al 4/25/2004 11:41'! 374467fileOutCategory: category on: aFileStream initializing: aBool 374468 "Store on the file associated with aFileStream, all the traits and classes associated 374469 with the category and any requested shared pools in the right order." 374470 374471 | first poolSet tempClass classes traits | 374472 traits := self orderedTraitsIn: category. 374473 classes := self superclassOrder: category. 374474 poolSet := Set new. 374475 classes do: [:class | class sharedPools do: [:eachPool | poolSet add: eachPool]]. 374476 poolSet size > 0 ifTrue: [ 374477 tempClass := Class new. 374478 tempClass shouldFileOutPools ifTrue: [ 374479 poolSet := poolSet select: [:aPool | 374480 tempClass shouldFileOutPool: (Smalltalk keyAtIdentityValue: aPool)]. 374481 poolSet do: [:aPool | tempClass fileOutPool: aPool onFileStream: aFileStream]]]. 374482 first := true. 374483 traits, classes do: [:each | 374484 first 374485 ifTrue: [first := false] 374486 ifFalse: [aFileStream cr; nextPut: Character newPage; cr]. 374487 each 374488 fileOutOn: aFileStream 374489 moveSource: false 374490 toFile: 0 374491 initializing: false]. 374492 aBool ifTrue: [classes do: [:cls | cls fileOutInitializerOn: aFileStream]].! ! 374493 374494!SystemOrganizer methodsFor: 'filein/out' stamp: 'tk 9/28/2000 15:50'! 374495objectForDataStream: refStrm 374496 | dp | 374497 "I am about to be written on an object file. Write a path to me in the other system instead." 374498 374499self == SystemOrganization ifTrue: [ 374500 dp := DiskProxy global: #SystemOrganization selector: #yourself args: #(). 374501 refStrm replace: self with: dp. 374502 ^ dp]. 374503^ self 374504! ! 374505 374506!SystemOrganizer methodsFor: 'filein/out' stamp: 'dvf 9/27/2005 19:06'! 374507orderedTraitsIn: category 374508 "Answer an OrderedCollection containing references to the traits in the 374509 category whose name is the argument, category (a string). The traits 374510 are ordered so they can be filed in." 374511 374512 | behaviors traits | 374513 behaviors := (self listAtCategoryNamed: category asSymbol) 374514 collect: [:title | Smalltalk at: title]. 374515 traits := behaviors reject: [:each | each isBehavior]. 374516 traits := traits asSortedCollection: [:t1 :t2 | 374517 (t2 traitComposition allTraits includes: t1) 374518 or: [(t1 traitComposition allTraits includes: t2) not]]. 374519 ^traits asArray! ! 374520 374521!SystemOrganizer methodsFor: 'filein/out' stamp: 'dvf 9/27/2005 19:06'! 374522superclassOrder: category 374523 "Answer an OrderedCollection containing references to the classes in the 374524 category whose name is the argument, category (a string). The classes 374525 are ordered with superclasses first so they can be filed in." 374526 374527 | behaviors classes | 374528 behaviors := (self listAtCategoryNamed: category asSymbol) 374529 collect: [:title | Smalltalk at: title]. 374530 classes := behaviors select: [:each | each isBehavior]. 374531 ^ChangeSet superclassOrder: classes! ! 374532 374533 374534!SystemOrganizer methodsFor: 'query' stamp: 'dtl 8/26/2004 11:18'! 374535commentInventory: categoryName 374536 374537 "SystemOrganization commentInventory: 'Morphic*'" 374538 374539 | classes commentedClasses | 374540 classes := OrderedCollection new. 374541 self categories withIndexCollect: [:cat :idx | 374542 (categoryName match: cat) 374543 ifTrue: [classes addAll: (self listAtCategoryNumber: idx)] 374544 ifFalse: [nil]]. 374545 commentedClasses := classes select: [:catCls | (Smalltalk at: catCls) hasComment]. 374546 ^ 'There are ' , classes size asString , ' classes in ' , categoryName , 374547 ' of which ' , commentedClasses size asString , ' have comments and ', 374548 (classes size - commentedClasses size) asString , ' do not yet have comments.' 374549! ! 374550 374551!SystemOrganizer methodsFor: 'query' stamp: 'dtl 8/26/2004 11:23'! 374552uncommentedClassesIn: categoryName 374553 374554 "SystemOrganization uncommentedClassesIn: 'Morphic*'" 374555 374556 | classes | 374557 classes := OrderedCollection new. 374558 self categories withIndexCollect: [:cat :idx | 374559 (categoryName match: cat) 374560 ifTrue: [classes addAll: (self listAtCategoryNumber: idx)] 374561 ifFalse: [nil]]. 374562 ^ (classes collect: [:clsName | Smalltalk at: clsName] 374563 thenSelect: [:cls | cls hasComment not]) asArray 374564! ! 374565 374566 374567!SystemOrganizer methodsFor: 'remove' stamp: 'di 3/3/2001 16:07'! 374568categoriesMatching: matchString 374569 "Return all matching categories" 374570 ^ self categories select: [:c | matchString match: c]! ! 374571 374572!SystemOrganizer methodsFor: 'remove' stamp: 'di 3/3/2001 16:08'! 374573removeCategoriesMatching: matchString 374574 "Remove all matching categories with their classes" 374575 (self categoriesMatching: matchString) do: 374576 [:c | self removeSystemCategory: c]! ! 374577 374578!SystemOrganizer methodsFor: 'remove' stamp: 'jm 5/20/1998 19:38'! 374579removeMissingClasses 374580 "Remove any class names that are no longer in the Smalltalk dictionary. Used for cleaning up after garbage collecting user-generated classes." 374581 "SystemOrganization removeMissingClasses" 374582 374583 elementArray copy do: [:el | 374584 (Smalltalk includesKey: el) ifFalse: [self removeElement: el]]. 374585! ! 374586 374587!SystemOrganizer methodsFor: 'remove' stamp: 'al 4/25/2004 11:38'! 374588removeSystemCategory: category 374589 "remove all the classes and traits associated with the category" 374590 374591 (self orderedTraitsIn: category) , (self superclassOrder: category) 374592 reverseDo: [:each | each removeFromSystem]. 374593 374594 self removeCategory: category. 374595! ! 374596 374597 374598!SystemOrganizer methodsFor: 'private' stamp: 'rw 7/31/2003 17:23'! 374599ifClassOrganizerDo: aBlock 374600 "Do nothing, since this is not a class organizer"! ! 374601 374602 374603!SystemOrganizer methodsFor: '*gofer' stamp: 'dkh 10/12/2009 12:59'! 374604goferClassesInCategory: category 374605 374606 ^(self listAtCategoryNamed: category) collect: [:className| Smalltalk at: className]! ! 374607RectangleMorph subclass: #SystemProgressBarMorph 374608 instanceVariableNames: 'barSize' 374609 classVariableNames: '' 374610 poolDictionaries: '' 374611 category: 'Morphic-Widgets'! 374612!SystemProgressBarMorph commentStamp: 'laza 4/9/2004 11:47' prior: 0! 374613Instances of this morph get used by SystemProgressMoprh to quickly display a progress bar.! 374614 374615 374616!SystemProgressBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/23/2007 17:04'! 374617barFillStyle 374618 "Answer the fillStyle for the bar if present or 374619 Preferences menuTitleColor otherwise." 374620 374621 ^self valueOfProperty: #barFillStyle ifAbsent: [Preferences menuTitleColor]! ! 374622 374623!SystemProgressBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/23/2007 17:04'! 374624barFillStyle: aFillStyle 374625 "Set the fillStyle for the bar." 374626 374627 ^self setProperty: #barFillStyle toValue: aFillStyle! ! 374628 374629!SystemProgressBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/24/2007 11:51'! 374630extent: aPoint 374631 "Update the bar fillStyle if appropriate." 374632 374633 super extent: aPoint. 374634 self fillStyle isOrientedFill ifTrue: [ 374635 self fillStyle: (UITheme current progressBarFillStyleFor: self)]. 374636 self barFillStyle isOrientedFill ifTrue: [ 374637 self barFillStyle: (UITheme current progressBarProgressFillStyleFor: self)]! ! 374638 374639!SystemProgressBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/23/2007 17:04'! 374640privateMoveBy: delta 374641 "Update the bar fillStyle if appropriate." 374642 374643 | fill | 374644 super privateMoveBy: delta. 374645 fill := self barFillStyle. 374646 fill isOrientedFill ifTrue: [fill origin: fill origin + delta]! ! 374647 374648 374649!SystemProgressBarMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/29/2008 21:36'! 374650drawOn: aCanvas 374651 "Draw the receiver with the fill style for the bar, clipping to the inner bounds." 374652 374653 | area | 374654 area := self innerBounds. 374655 aCanvas fillRectangle: area fillStyle: self fillStyle. 374656 barSize > 0 ifTrue: [ 374657 area := area origin extent: (barSize min: area width) @ area height. 374658 aCanvas fillRectangle: area fillStyle: self barFillStyle]. 374659 self borderStyle frameRectangle: self bounds on: aCanvas 374660! ! 374661 374662!SystemProgressBarMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/24/2007 12:05'! 374663initialize 374664 "Initialize the receiver from the current theme." 374665 374666 super initialize. 374667 barSize := 0. 374668 self 374669 fillStyle: (UITheme current progressBarFillStyleFor: self); 374670 borderStyle: (UITheme current progressBarBorderStyleFor: self); 374671 barFillStyle: (UITheme current progressBarProgressFillStyleFor: self)! ! 374672 374673 374674!SystemProgressBarMorph methodsFor: 'accessing' stamp: 'laza 4/9/2004 10:37'! 374675barSize: anInteger 374676 barSize := anInteger. 374677 self changed.! ! 374678RectangleMorph subclass: #SystemProgressMorph 374679 instanceVariableNames: 'activeSlots bars labels font lock' 374680 classVariableNames: 'BarHeight BarWidth UniqueInstance' 374681 poolDictionaries: '' 374682 category: 'Morphic-Widgets'! 374683!SystemProgressMorph commentStamp: '<historical>' prior: 0! 374684An single instance of this morph class is used to display progress while the system is busy, eg. while it receives code updates or does a fileIn. To give the user progress information you don't deal directly with SystemProgressMorph. You keep on using the well established way of progress notification, that has been a long time in the system, is widely used and does not depend on the existence of SystemProgressMorph. For more information on this look at the example in this class or look at the comment of the method displayProgressAt:from:to:during: in class String. 374685 374686SystemProgressMorph is not meant to be used as a component inside other morphs. 374687 374688You can switch back to the old style of progress display by disabling the morphicProgressStyle setting in the morphic section of the preferences.! 374689]style[(461 8 51 33 233 11 1)f2,f2LSystemProgressMorph class example;,f2,f2LString displayProgressAt:from:to:during:;,f2,f2dPreferences openFactoredPanel;;,f2! 374690 374691 374692!SystemProgressMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2009 13:54'! 374693nextSlotFor: shortDescription 374694 | bar slots label | 374695 lock critical: [ 374696 slots := bars size. 374697 activeSlots = slots ifTrue: [^0]. 374698 activeSlots := activeSlots + 1. 374699 1 to: slots do: [:index | 374700 bar := (bars at: index). 374701 bar ifNil: [ 374702 bar := SystemProgressBarMorph new. 374703 bar extent: BarWidth@BarHeight + (2 * bar borderWidth). 374704 bars at: index put: bar. 374705 label := labels at: index put: (StringMorph contents: shortDescription font: font). 374706 self 374707 addMorphBack: label; 374708 addMorphBack: bar. 374709 ^index]. 374710 bar owner ifNil: [ 374711 bar := bars at: index. 374712 label := labels at: index. 374713 self 374714 addMorphBack: (label contents: shortDescription); 374715 addMorphBack: (bar barSize: 0). 374716 ^index]]] 374717 ! ! 374718 374719!SystemProgressMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/1/2009 12:37'! 374720setDefaultParameters 374721 374722 self theme setSystemProgressMorphDefaultParameters: self! ! 374723 374724 374725!SystemProgressMorph methodsFor: 'dropping/grabbing' stamp: 'laza 4/20/2004 11:38'! 374726slideToTrash: evt 374727 "If the user needs to dismiss a progress morph by hand, start with a 374728 fresh instance next time." 374729 self dismissViaHalo! ! 374730 374731 374732!SystemProgressMorph methodsFor: 'initialization' stamp: 'laza 7/29/2004 10:26'! 374733close: aBlock 374734 | slot | 374735 slot := aBlock value: SmallInteger maxVal. "This should prevent a redraw" 374736 self freeSlot: slot 374737 374738! ! 374739 374740!SystemProgressMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:08'! 374741initialize 374742 super initialize. 374743 activeSlots := 0. 374744 bars := Array new: 10. 374745 labels := Array new: 10. 374746 font := Preferences windowTitleFont. 374747 lock := Semaphore forMutualExclusion. 374748 self setDefaultParameters; 374749 setProperty: #morphicLayerNumber toValue: self morphicLayerNumber; 374750 layoutPolicy: TableLayout new; 374751 listDirection: #topToBottom; 374752 cellPositioning: #topCenter; 374753 cellInset: 5; 374754 listCentering: #center; 374755 hResizing: #shrinkWrap; 374756 vResizing: #shrinkWrap; 374757 layoutInset:4@4.! ! 374758 374759!SystemProgressMorph methodsFor: 'initialization' stamp: 'laza 4/18/2004 21:31'! 374760morphicLayerNumber 374761 "progress morphs are behind menus and balloons, but in front of most other stuff" 374762 ^self valueOfProperty: #morphicLayerNumber ifAbsent: [12]. 374763! ! 374764 374765!SystemProgressMorph methodsFor: 'initialization' stamp: 'jrp 7/6/2005 21:45'! 374766updateColor: aMorph color: aColor intensity: anInteger 374767 "update the apareance of aMorph" 374768 | fill | 374769 Preferences gradientMenu 374770 ifFalse: [^ self]. 374771 374772 fill := GradientFillStyle ramp: {0.0 -> Color white. 1 ->aColor}. 374773 fill radial: false; 374774 origin: aMorph topLeft; 374775 direction: 0 @ aMorph height. 374776 aMorph fillStyle: fill! ! 374777 374778 374779!SystemProgressMorph methodsFor: 'nil' stamp: 'nice 4/16/2009 18:59'! 374780label: shortDescription min: startMinValue max: startMaxValue 374781 "Answer the block that updates the progress bar." 374782 374783 "some fun stuff added (by kph) 374784 374785 - bar value: #label. - tell me my current label. 374786 - bar value: 'newLabel'. - enable changing the label from within the workBlock 374787 - bar value: #increment. - enable progress by one without keeping a counter 374788 - bar value: #decrement. - go backwards (if you really have to, useful for an abort, or rollback)!! 374789 374790 - bar value: newBigNum. - change the max on the fly - when you find there is more to do. 374791 - bar value: (bar value: #setMax) + 20 - change the max on the fly - when you find there is more/less to do. 374792 - bar value: (bar value: #setMin) - 20 - change the min on the fly - not sure why you would want to. 374793 - bar value: #stripe to be debugged 374794 374795 " 374796 | slot range newBarSize barSize lastRefresh maxValue minValue bar| 374797 maxValue := startMaxValue. 374798 minValue := startMinValue. 374799 ((range := maxValue - minValue) <= 0 or: [(slot := self nextSlotFor: shortDescription) = 0]) 374800 ifTrue: [^[:barVal| 0 ]]. 374801 self openInWorld. 374802 self align: self fullBounds center with: Display boundingBox center. 374803 barSize := -1. "Enforces a inital draw of the morph" 374804 lastRefresh := Time millisecondClockValue. 374805 bar := bars at: slot. 374806 bar removeProperty: #useStripe. 374807 (bar valueOfProperty: #nonStripedFillStyle) ifNotNilDo: [:fs | 374808 bar fillStyle: fs. 374809 bar removeProperty: #nonStripedFillStyle]. "force reset of fill style if striped" 374810 ^[:barValArg | | barVal return | 374811 barVal := barValArg. 374812 return := nil. 374813 bar := bars at: slot. 374814 "new fun stuff here" 374815 barVal == #current ifTrue: [ return := barSize ]. 374816 barVal == #label ifTrue:[ return := (labels at: slot) contents ]. 374817 barVal == #setMax ifTrue: [ return := maxValue. maxValue := minValue ]. 374818 barVal == #setMin ifTrue: [ return := minValue. minValue := maxValue ]. 374819 barVal == #stripe 374820 ifTrue: [bar setProperty: #useStripes toValue: true. 374821 bar setProperty: #nonStripedFillStyle toValue: bar fillStyle. 374822 bar fillStyle: ((GradientFillStyle ramp: ((1 to: 20) 374823 collect: [:i| Association key: (i/20.0) value: (i even 374824 ifTrue: [ Color white ] 374825 ifFalse: [Color cyan])])) 374826 origin: bar position; 374827 direction: 300@0; 374828 radial: false; 374829 yourself). 374830 barVal := #refresh]. 374831 barVal == #increment ifTrue: [return := barVal := barSize + 1]. 374832 barVal == #decrement ifTrue: [ return := barVal := barSize - 1]. 374833 (barVal isString and: [barVal isSymbol not]) ifTrue: [ 374834 (labels at: slot) contents: barVal. 374835 barVal := #refresh]. 374836 barVal == #refresh ifTrue: [self currentWorld displayWorld. return := true]. 374837 (barVal == SmallInteger maxVal or: [ barVal == #finished ]) ifTrue: [return := slot]. 374838 return ifNil: [ 374839 barVal > maxValue ifTrue: [return := maxValue := barVal]. 374840 barVal < minValue ifTrue: [return := minValue := barVal]. 374841 (barVal between: minValue and: maxValue) 374842 ifTrue: [newBarSize := (barVal - minValue / range * BarWidth) truncated. 374843 newBarSize = barSize 374844 ifFalse: [barSize := newBarSize. 374845 (Time millisecondsSince: lastRefresh) > 25 374846 ifTrue: [barVal := #refresh ]]]. 374847 barVal == #refresh ifTrue: [ 374848 ((bar valueOfProperty: #useStripes) ifNil: [false]) 374849 ifTrue: [bar fillStyle origin: bar position - ((Time millisecondClockValue // 50 \\ 30) @ 0)]. 374850 bar barSize: barSize. 374851 self currentWorld displayWorld. 374852 lastRefresh := Time millisecondClockValue]]. 374853 return]! ! 374854 374855 374856!SystemProgressMorph methodsFor: 'submorphs-add/remove' stamp: 'laza 4/20/2004 12:01'! 374857dismissViaHalo 374858 self class reset! ! 374859 374860 374861!SystemProgressMorph methodsFor: 'private' stamp: 'laza 5/28/2004 06:03'! 374862freeSlot: number 374863 number > 0 ifTrue: [ 374864 lock critical: [ 374865 (bars at: number) delete. 374866 (labels at: number) delete. 374867 activeSlots := activeSlots - 1. 374868 activeSlots = 0 374869 ifTrue: [self delete] 374870 ifFalse: [self align: self fullBounds center with: Display boundingBox center]]]! ! 374871 374872"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 374873 374874SystemProgressMorph class 374875 instanceVariableNames: ''! 374876 374877!SystemProgressMorph class methodsFor: 'examples' stamp: 'laza 4/9/2004 10:49'! 374878example 374879 "SystemProgressMorph example" 374880 'Progress' 374881 displayProgressAt: Display center 374882 from: 0 to: 1000 374883 during: [:bar | 0 to: 1000 do: [:i | bar value: i. (Delay forMilliseconds: 2) wait]] 374884! ! 374885 374886 374887!SystemProgressMorph class methodsFor: 'initialization' stamp: 'laza 4/10/2004 20:29'! 374888initialize 374889 "SystemProgressMorph initialize" 374890 BarHeight := 16. 374891 BarWidth := 200. 374892 self reset! ! 374893 374894 374895!SystemProgressMorph class methodsFor: 'instance creation' stamp: 'laza 4/9/2004 10:51'! 374896close: aBlock 374897 UniqueInstance ifNotNil: [UniqueInstance close: aBlock]! ! 374898 374899!SystemProgressMorph class methodsFor: 'instance creation' stamp: 'laza 4/18/2004 21:16'! 374900label: shortDescription min: minValue max: maxValue 374901 UniqueInstance ifNil: [UniqueInstance := super new]. 374902 ^UniqueInstance label: (shortDescription contractTo: 100) min: minValue asFloat max: maxValue asFloat! ! 374903 374904!SystemProgressMorph class methodsFor: 'instance creation' stamp: 'laza 4/6/2004 21:17'! 374905new 374906 ^self shouldNotImplement! ! 374907 374908!SystemProgressMorph class methodsFor: 'instance creation' stamp: 'laza 4/9/2004 10:35'! 374909reset 374910 "SystemProgressMorph reset" 374911 UniqueInstance ifNotNil: [UniqueInstance delete]. 374912 UniqueInstance := nil.! ! 374913TraitsTestCase subclass: #SystemTest 374914 instanceVariableNames: '' 374915 classVariableNames: '' 374916 poolDictionaries: '' 374917 category: 'Tests-Traits'! 374918 374919!SystemTest methodsFor: 'testing' stamp: 'al 4/9/2006 15:22'! 374920testAllClassesAndTraits 374921 "self debug: #testAllClassesAndTraits" 374922 374923 | trait | 374924 trait := self t1. 374925 self assert: (Smalltalk allClassesAndTraits includes: trait). 374926 self deny: (Smalltalk allClasses includes: trait). 374927 ! ! 374928 374929!SystemTest methodsFor: 'testing' stamp: 'al 1/13/2006 12:27'! 374930testAllImplementedMessagesWithout 374931 "self debug: #testAllImplementedMessagesWithout" 374932 374933 self t6 compile: 'das2qwdqwd'. 374934 self assert: (SystemNavigation default allImplementedMessages includes: #das2qwdqwd). 374935 self deny: (SystemNavigation default allImplementedMessages includes: #qwdqwdqwdc).! ! 374936 374937!SystemTest methodsFor: 'testing' stamp: 'al 1/13/2006 11:49'! 374938testAllSentMessages 374939 "self debug: #testAllSentMessages" 374940 374941 self t1 compile: 'foo 1 dasoia'. 374942 self assert: (SystemNavigation default allSentMessages includes: 'dasoia' asSymbol). 374943 self deny: (SystemNavigation default allSentMessages includes: 'nioaosi' asSymbol).! ! 374944 374945!SystemTest methodsFor: 'testing' stamp: 'adrian_lienhard 1/31/2009 18:48'! 374946testClassFromPattern 374947 "self debug: #testClassFromPattern" 374948 374949 self assert: (SystemNavigation default 374950 classFromPattern: 'TComposingD' withCaption: '') = TComposingDescription! ! 374951Object subclass: #SystemVersion 374952 instanceVariableNames: 'version date highestUpdate updates' 374953 classVariableNames: 'Current' 374954 poolDictionaries: '' 374955 category: 'System-Support'! 374956!SystemVersion commentStamp: 'tlk 11/14/2004 10:44' prior: 0! 374957I am responsible for maintaining what version of Squeak and the VM is running. I also track all of the update items that have been included in the image. 374958 374959I'm invoked at auto start to get the latest plugins, etc.! 374960 374961 374962!SystemVersion methodsFor: 'accessing'! 374963date 374964 ^date! ! 374965 374966!SystemVersion methodsFor: 'accessing'! 374967date: newDate 374968 date := newDate! ! 374969 374970!SystemVersion methodsFor: 'accessing' stamp: 'mir 5/1/2001 18:19'! 374971datedVersion 374972 "Answer the version of this release." 374973 374974 ^ self version asString , ' of ' , self date printString! ! 374975 374976!SystemVersion methodsFor: 'accessing' stamp: 'mir 3/29/2001 18:03'! 374977highestUpdate 374978 | sortedUpdates | 374979 highestUpdate ifNil: [ 374980 sortedUpdates := self updates asSortedCollection. 374981 highestUpdate := (sortedUpdates isEmpty 374982 ifTrue: [0] 374983 ifFalse: [sortedUpdates last])]. 374984 ^highestUpdate! ! 374985 374986!SystemVersion methodsFor: 'accessing'! 374987highestUpdate: anInteger 374988 highestUpdate := anInteger! ! 374989 374990!SystemVersion methodsFor: 'accessing'! 374991includesUpdate: anUpdate 374992 ^self updates includes: anUpdate! ! 374993 374994!SystemVersion methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/2/2009 15:50'! 374995majorMinorVersion 374996 "Return the major/minor version number of the form X.Y, without any 'alpha' or 'beta' or other suffix." 374997 "(SystemVersion new version: 'Squeak3.7alpha') majorMinorVersion" " --> 'Squeak3.7' " 374998 "SystemVersion current majorMinorVersion" 374999 375000 | char stream | 375001 (stream := (self version, 'x') readStream) upTo: $.. 375002 char := stream next. 375003 char ifNil: [^ version]. "eg: 'Jasmine-rc1' has no $. in it." 375004 [char isDigit] 375005 whileTrue: [char := stream next]. 375006 ^ version copyFrom: 1 to: stream position - 1 375007! ! 375008 375009!SystemVersion methodsFor: 'accessing' stamp: 'mir 3/29/2001 18:01'! 375010registerUpdate: update 375011 self updates add: update. 375012 self resetHighestUpdate! ! 375013 375014!SystemVersion methodsFor: 'accessing' stamp: 'mir 3/29/2001 18:01'! 375015resetHighestUpdate 375016 highestUpdate := nil! ! 375017 375018!SystemVersion methodsFor: 'accessing'! 375019unregisterUpdate: update 375020 self updates remove: update ifAbsent: []! ! 375021 375022!SystemVersion methodsFor: 'accessing'! 375023updates 375024 ^updates! ! 375025 375026!SystemVersion methodsFor: 'accessing'! 375027version 375028 ^version! ! 375029 375030!SystemVersion methodsFor: 'accessing'! 375031version: newVersion 375032 version := newVersion! ! 375033 375034 375035!SystemVersion methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 11:09'! 375036initialize 375037 super initialize. 375038 version := 'No version set'. 375039 date := Date today. 375040 updates := Set new. 375041! ! 375042 375043 375044!SystemVersion methodsFor: 'printing' stamp: 'mir 5/1/2001 18:20'! 375045printOn: stream 375046 stream 375047 nextPutAll: self datedVersion; 375048 nextPutAll: ' update ' , self highestUpdate printString! ! 375049 375050"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 375051 375052SystemVersion class 375053 instanceVariableNames: ''! 375054 375055!SystemVersion class methodsFor: 'accessing'! 375056current 375057 Current ifNil: [Current := SystemVersion new]. 375058 ^Current! ! 375059 375060!SystemVersion class methodsFor: 'accessing' stamp: 'dc 5/30/2008 10:17'! 375061parseVersionString: versionString 375062 "Answer the version of this release as version, date, update." 375063 "SystemVersion parseVersionString: 'Squeak3.1alpha of 28 February 2001 [latest update: #3966]' " 375064 | stream version date update | 375065 375066 [ stream := versionString readStream. 375067 version := stream upToAll: ' of '. 375068 date := Date readFrom: stream. 375069 stream upToAll: ' #'. 375070 update := Number readFrom: stream ] 375071 on: Error 375072 do: [ ^ nil ]. 375073 ^ { version. date. update }! ! 375074 375075!SystemVersion class methodsFor: 'accessing' stamp: 'mir 8/10/2001 11:53'! 375076pluginVersion: availableVersionString newerThan: currentVersionString 375077 | currentVersion availableVersion | 375078 (currentVersionString isEmptyOrNil 375079 or: [availableVersionString isEmptyOrNil]) 375080 ifTrue: [^true]. 375081 currentVersion := self parseVersionString: currentVersionString. 375082 availableVersion := self parseVersionString: availableVersionString. 375083 (currentVersion isNil 375084 or: [availableVersion isNil]) 375085 ifTrue: [^false]. 375086 ^(currentVersion at: 2) < (availableVersion at: 2)! ! 375087 375088 375089!SystemVersion class methodsFor: 'instance creation' stamp: 'mir 3/29/2001 18:06'! 375090newVersion: versionName 375091 | newVersion | 375092 newVersion := self new version: versionName. 375093 newVersion 375094 highestUpdate: self current highestUpdate. 375095 Current := newVersion 375096! ! 375097 375098 375099!SystemVersion class methodsFor: 'updating' stamp: 'sd 9/30/2003 13:58'! 375100check: pluginVersion andRequestPluginUpdate: updateURL 375101 "SystemVersion check: 'zzz' andRequestPluginUpdate: 'http://www.squeakland.org/installers/update.html' " 375102 375103 "We don't have a decent versioning scheme yet, so we are basically checking for a nil VM version on the mac." 375104 (self pluginVersion: pluginVersion newerThan: self currentPluginVersion) 375105 ifFalse: [^true]. 375106 (self confirm: 'There is a newer plugin version available. Do you want to install it now?') 375107 ifFalse: [^false]. 375108 HTTPClient 375109 requestURL: updateURL , (SmalltalkImage current platformName copyWithout: Character space) asLowercase , '.html' 375110 target: '_top'. 375111 ^false! ! 375112 375113!SystemVersion class methodsFor: 'updating' stamp: 'sd 11/16/2003 14:18'! 375114checkAndApplyUpdates: availableUpdate 375115 "SystemVersion checkAndApplyUpdates: nil" 375116 375117 ^(availableUpdate isNil 375118 or: [availableUpdate > SystemVersion current highestUpdate]) 375119 ifTrue: [ 375120 (self confirm: 'There are updates available. Do you want to install them now?') 375121 ifFalse: [^false]. 375122 Utilities 375123 readServerUpdatesThrough: availableUpdate 375124 saveLocally: false 375125 updateImage: true. 375126 SmalltalkImage current snapshot: true andQuit: false. 375127 true] 375128 ifFalse: [false]! ! 375129 375130!SystemVersion class methodsFor: 'updating' stamp: 'sd 9/30/2003 13:58'! 375131currentPluginVersion 375132 ^SmalltalkImage current vmVersion! ! 375133TestCase subclass: #SystemVersionTest 375134 instanceVariableNames: '' 375135 classVariableNames: '' 375136 poolDictionaries: '' 375137 category: 'Tests-System'! 375138!SystemVersionTest commentStamp: 'tlk 11/14/2004 10:47' prior: 0! 375139I am an sunit test for SystemVersion. Originally created to test SqueakMapSystemVersionFix change set. 375140I have no test fixtures.! 375141 375142 375143!SystemVersionTest methodsFor: 'as yet unclassified' stamp: 'tlk 11/14/2004 10:55'! 375144testMajorMinorVersion 375145 " 375146 SystemVersionTest run: #testMajorMinorVersion 375147 " 375148 self assert: (SystemVersion new version: 'Squeak3.7alpha') majorMinorVersion = 'Squeak3.7'. 375149 self assert: (SystemVersion new version: 'Squeak3.7') majorMinorVersion = 'Squeak3.7'. 375150 self assert: (SystemVersion new version: 'Squeak3') majorMinorVersion = 'Squeak3'. 375151 self assert: (SystemVersion new version: '') majorMinorVersion = ''. 375152! ! 375153MorphicModel subclass: #SystemWindow 375154 instanceVariableNames: 'labelString stripes label closeBox collapseBox activeOnlyOnTop paneMorphs paneRects collapsedFrame fullFrame isCollapsed menuBox mustNotClose labelWidgetAllowance updatablePanes allowReframeHandles labelArea expandBox' 375155 classVariableNames: 'CloseBoxImage CollapseBoxImage TopWindow' 375156 poolDictionaries: '' 375157 category: 'Morphic-Windows'! 375158!SystemWindow commentStamp: '<historical>' prior: 0! 375159SystemWindow is the Morphic equivalent of StandardSystemView -- a labelled container for rectangular views, with iconic facilities for close, collapse/expand, and resizing. 375160 375161The attribute onlyActiveOnTop, if set to true (and any call to activate will set this), determines that only the top member of a collection of such windows on the screen shall be active. To be not active means that a mouse click in any region will only result in bringing the window to the top and then making it active.! 375162 375163 375164!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/15/2008 21:22'! 375165aboutText 375166 "Answer the text to use for the About dialog." 375167 375168 ^self model 375169 ifNil: ['This is a system window without a model' translated] 375170 ifNotNil: [self model class instanceSide organization classComment 375171 ifEmpty: ['The model of this window has no class comment'] 375172 ifNotEmptyDo: [:comment | comment]]! ! 375173 375174!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/24/2008 14:57'! 375175aboutTitle 375176 "Answer the title to use for the About dialog." 375177 375178 |title| 375179 title := self model 375180 ifNil: ['SystemWindow'] 375181 ifNotNil: [(self model respondsTo: #aboutTitle) 375182 ifTrue: [self model aboutTitle] 375183 ifFalse: [self model class name]]. 375184 ^'About {1}' translated format: {title}! ! 375185 375186!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:58'! 375187activeFillStyle 375188 "Return the active fillStyle for the receiver." 375189 375190 ^self theme windowActiveFillStyleFor: self! ! 375191 375192!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:58'! 375193activeLabelFillStyle 375194 "Return the active label fillStyle for the receiver." 375195 375196 ^self theme windowActiveLabelFillStyleFor: self! ! 375197 375198!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:58'! 375199activeTitleFillStyle 375200 "Return the active title fillStyle for the receiver." 375201 375202 ^self theme windowActiveTitleFillStyleFor: self! ! 375203 375204!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/15/2007 11:16'! 375205addCollapseBox 375206 "If I have a labelArea, add a collapse box to it." 375207 375208 | frame | 375209 labelArea 375210 ifNil: [^ self]. 375211 collapseBox := self createCollapseBox. 375212 frame := LayoutFrame new. 375213 frame leftFraction: 1; 375214 leftOffset: self boxExtent x negated; 375215 topFraction: 0; 375216 topOffset: 0. 375217 collapseBox layoutFrame: frame. 375218 labelArea addMorphBack: collapseBox! ! 375219 375220!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/26/2007 14:16'! 375221addCornerGrips 375222 "Should add these to the front!!" 375223 375224 |tl tr lh| 375225 lh := self labelHeight. 375226 tl := TopLeftGripMorph new target: self; position: self position. 375227 tl layoutFrame topOffset: lh negated. 375228 tr := TopRightGripMorph new target: self; position: self position. 375229 tr layoutFrame topOffset: lh negated. 375230 self 375231 addMorph: tl; 375232 addMorph: tr; 375233 addMorph: (BottomLeftGripMorph new target: self;position: self position); 375234 addMorph: (BottomRightGripMorph new target: self;position: self position)! ! 375235 375236!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/1/2007 14:51'! 375237addEdgeGrips 375238 "Should add these to the front!!" 375239 375240 |t l r lh| 375241 lh := self labelHeight. 375242 t := WindowEdgeGripMorph new target: self; position: self position; edgeName: #top. 375243 t layoutFrame 375244 topOffset: lh negated; 375245 bottomOffset: lh negated + self class borderWidth. 375246 l := WindowEdgeGripMorph new target: self; position: self position; edgeName: #left. 375247 l layoutFrame topOffset: lh negated + 22. 375248 r := WindowEdgeGripMorph new target: self; position: self position; edgeName: #right. 375249 r layoutFrame topOffset: lh negated + 22. 375250 self 375251 addMorph: t; 375252 addMorph: l; 375253 addMorph: r; 375254 addMorph: (WindowEdgeGripMorph new target: self;position: self position; edgeName: #bottom)! ! 375255 375256!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/1/2007 14:43'! 375257addGrips 375258 "Add the edge and corner grips." 375259 375260 self 375261 addCornerGrips; 375262 addEdgeGrips! ! 375263 375264!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/7/2008 11:35'! 375265addGripsIfWanted 375266 "Add the edge and corner grips if the window wants them." 375267 375268 self wantsGrips ifTrue: [self addGrips]! ! 375269 375270!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/21/2009 16:51'! 375271allowedToClose 375272 "Answer whether the window is currently allowed to close." 375273 375274 ^self mustNotClose not and: [ 375275 self modalChild isNil]! ! 375276 375277!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/24/2007 17:18'! 375278animateClose 375279 "Animate closing." 375280 375281 | smallRect restoredRect rects steps| 375282 self isMinimized ifTrue: [^self]. 375283 restoredRect := self bounds. 375284 smallRect := restoredRect scaledAndCenteredIn: (0@0 extent: 20@20). 375285 smallRect := smallRect align: smallRect center with: restoredRect center. 375286 steps := Preferences windowAnimationSteps. 375287 rects := ((steps - 1)/steps to: 0 by: -1/steps) collect: [:x | 375288 smallRect interpolateTo: restoredRect at: (20 raisedTo: x) - 1 / 19]. 375289 World displayWorldSafely. 375290 self fastAnimateRectangles: rects! ! 375291 375292!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/25/2007 11:21'! 375293animateMaximize 375294 "Animate maximizing from restored." 375295 375296 |expandedRect restoredRect rects steps| 375297 expandedRect := self fullScreenBounds. 375298 restoredRect := self bounds. 375299 steps := Preferences windowAnimationSteps. 375300 rects := (1/steps to: 1 by: 1/steps) collect: [:x | 375301 restoredRect interpolateTo: expandedRect at: (20 raisedTo: x) - 1 / 19]. 375302 self fastAnimateRectangles: rects! ! 375303 375304!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/25/2007 11:21'! 375305animateMinimize 375306 "Animate minimizing." 375307 375308 |tb buttonRect restoredRect rects steps| 375309 tb := self worldTaskbar ifNil: [^self]. 375310 buttonRect := ((tb taskButtonOf: self) ifNil: [^self]) bounds. 375311 restoredRect := self isFlexed 375312 ifTrue: [(owner transform 375313 globalPointToLocal: fullFrame topLeft) 375314 extent: fullFrame extent] 375315 ifFalse: [fullFrame]. 375316 steps := Preferences windowAnimationSteps. 375317 rects := ((steps - 1)/steps to: 0 by: -1/steps) collect: [:x | 375318 buttonRect interpolateTo: restoredRect at: (20 raisedTo: x) - 1 / 19]. 375319 self fastAnimateRectangles: rects! ! 375320 375321!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/24/2007 15:05'! 375322animateRectangles: rects doing: aBlock 375323 "Animate the given rectangles." 375324 375325 |rectMorph| 375326 rectMorph := RectangleMorph new 375327 color: Color transparent; 375328 setProperty: #morphicLayerNumber toValue: 12; 375329 openInWorld. 375330 rects withIndexDo: [:r :i | 375331 rectMorph bounds: r rounded. 375332 aBlock value: rectMorph value: i. 375333 World doOneCycle. 375334 (Delay forMilliseconds: 1) wait]. 375335 rectMorph delete! ! 375336 375337!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/25/2007 11:21'! 375338animateRestore 375339 "Animate restoring from maximised." 375340 375341 |expandedRect restoredRect rects steps| 375342 expandedRect := self bounds. 375343 restoredRect := self unexpandedFrame. 375344 steps := Preferences windowAnimationSteps. 375345 rects := ((steps - 1)/steps to: 0 by: -1/steps) collect: [:x | 375346 restoredRect interpolateTo: expandedRect at: (20 raisedTo: x) - 1 / 19]. 375347 self fastAnimateRectangles: rects! ! 375348 375349!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/25/2007 11:21'! 375350animateRestoreFromMinimized 375351 "Animate restoring from minimised." 375352 375353 |tb buttonRect restoredRect rects steps| 375354 tb := self worldTaskbar ifNil: [^self]. 375355 buttonRect := ((tb taskButtonOf: self) ifNil: [^self]) bounds. 375356 restoredRect := self isFlexed 375357 ifTrue: [(owner transform 375358 globalPointToLocal: fullFrame topLeft) 375359 extent: fullFrame extent] 375360 ifFalse: [fullFrame]. 375361 steps := Preferences windowAnimationSteps. 375362 rects := (1/steps to: 1 by: 1/steps) collect: [:x | 375363 buttonRect interpolateTo: restoredRect at: (20 raisedTo: x) - 1 / 19]. 375364 self fastAnimateRectangles: rects! ! 375365 375366!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/16/2009 16:48'! 375367basicActivate 375368 "Bring me to the front and make me able to respond to mouse and keyboard. 375369 Was #activate (sw 5/18/2001 23:20)" 375370 375371 | oldTop outerMorph sketchEditor pal | 375372 outerMorph := self topRendererOrSelf. 375373 outerMorph owner ifNil: [^ self "avoid spurious activate when drop in trash"]. 375374 oldTop := TopWindow. 375375 oldTop = self ifTrue: [^self]. 375376 oldTop ifNotNil: [oldTop changed]. "invalidate with old drop shadow bounds" 375377 TopWindow := self. 375378 oldTop ifNotNil: [oldTop passivate]. 375379 outerMorph owner firstSubmorph == outerMorph 375380 ifFalse: ["Bring me (with any flex) to the top if not already" 375381 outerMorph owner addMorphFront: outerMorph]. 375382 self submorphsDo: [:m | m unlock]. 375383 labelArea ifNotNil: 375384 [labelArea submorphsDo: [:m | m unlock]. 375385 self setStripeColorsFrom: self paneColorToUse]. 375386 self isCollapsed ifFalse: 375387 [model modelWakeUpIn: self. 375388 self positionSubmorphs. 375389 labelArea ifNil: [self adjustBorderUponActivationWhenLabeless]]. 375390 375391 (sketchEditor := self extantSketchEditor) ifNotNil: 375392 [sketchEditor comeToFront. 375393 (pal := self world findA: PaintBoxMorph) ifNotNil: 375394 [pal comeToFront]]. 375395 self privateFullBounds: nil; changed "ensure fullBounds computed for active drop shadow" 375396! ! 375397 375398!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/15/2007 11:41'! 375399basicLabel 375400 "Answer the actual label morph." 375401 375402 ^label! ! 375403 375404!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/24/2007 13:58'! 375405basicTaskThumbnailOfSize: thumbExtent 375406 "Answer a new task thumbnail for the receiver." 375407 375408 ^super taskThumbnailOfSize: thumbExtent! ! 375409 375410!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/7/2008 11:42'! 375411beWithGrips 375412 "Add the grips and set a property to 375413 indicate that grips are wanted." 375414 375415 self removeProperty: #noGrips. 375416 (self isCollapsed not or: [self isTaskbarPresent]) ifTrue: [ 375417 self addGripsIfWanted]! ! 375418 375419!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/7/2008 11:41'! 375420beWithoutGrips 375421 "Remove the grips and set a property to 375422 indicate that grips are not wanted." 375423 375424 self setProperty: #noGrips toValue: true. 375425 self removeGrips! ! 375426 375427!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/16/2007 12:51'! 375428bringBehind: aMorph 375429 "Make the receiver be directly behind the given morph. 375430 Take into account any modal owner and propagate." 375431 375432 |outerMorph| 375433 outerMorph := self topRendererOrSelf. 375434 outerMorph owner ifNil: [^ self "avoid spurious activate when drop in trash"]. 375435 outerMorph owner addMorph: outerMorph after: aMorph topRendererOrSelf. 375436 self modalOwner ifNotNilDo: [:mo | mo bringBehind: self]! ! 375437 375438!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/20/2009 14:07'! 375439canBeMaximized 375440 "Answer whether we are not we can be maximised." 375441 375442 ^self isNotMaximized! ! 375443 375444!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 18:11'! 375445collapseBoxHit 375446 "The user has clicked on the collapse box. 375447 Collapse or expand the receiver as appropriate." 375448 375449 self isCollapsed 375450 ifTrue: [self playRestoreUpSound] 375451 ifFalse: [self playMinimizeSound]. 375452 self collapseOrExpand! ! 375453 375454!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 13:31'! 375455defaultBackgroundColor 375456 "Answer the color to be used as the base window color." 375457 375458 ^self theme 375459 windowColorFor: (self model ifNil: [self])! ! 375460 375461!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/19/2007 22:08'! 375462doubleClick: event 375463 "Handle a double click. Maximize/restore the window. 375464 Works in title bar area." 375465 375466 (labelArea containsPoint: event position) 375467 ifTrue: [self expandBoxHit]! ! 375468 375469!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/19/2007 21:48'! 375470doubleClickTimeout: event 375471 "Forget the #inactiveDoubleClick property. 375472 The property is set if an inactive window was double-clicked." 375473 375474 self removeProperty: #inactiveDoubleClick! ! 375475 375476!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/20/2009 17:44'! 375477drawDropShadowOn: aCanvas 375478 "Get the theme to draw the drop shawdow for the receiver." 375479 375480 |dropAreas| 375481 dropAreas := self areasRemainingToFill: (self bounds expandBy: self shadowOffsetRectangle). 375482 (dropAreas anySatisfy: [:rect | aCanvas isVisible: rect]) 375483 ifFalse: [^self]. "no need to draw since no intersection" 375484 self isActive 375485 ifTrue: [self theme 375486 drawWindowActiveDropShadowFor: self 375487 on: aCanvas] 375488 ifFalse: [self theme 375489 drawWindowInactiveDropShadowFor: self 375490 on: aCanvas]! ! 375491 375492!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/7/2007 13:26'! 375493fastAnimateRectangles: rects 375494 "Animate the given rectangles using the fast method." 375495 375496 |delay col merged| 375497 rects ifEmpty: [^self]. 375498 delay := Delay forMilliseconds: (Preferences windowAnimationDelay). 375499 col := Color gray alpha: 0.5. 375500 merged := rects first. 375501 rects withIndexDo: [:r :i | 375502 Display 375503 border: r rounded 375504 width: 1 375505 rule: Form blend 375506 fillColor: col. 375507 merged := merged merge: r. 375508 delay wait]. 375509 merged := merged expandBy: 1. 375510 World invalidRect: merged from: self! ! 375511 375512!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 15:43'! 375513fillStyleToUse 375514 "Answer the basic fill style for the receiver." 375515 375516 ^self isActive 375517 ifTrue: [self activeFillStyle] 375518 ifFalse: [self inactiveFillStyle]! ! 375519 375520!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/24/2007 16:41'! 375521fullScreenBounds 375522 "Answer the bounds that the receiver would tak if expanded to full screen." 375523 375524 | left right possibleBounds | 375525 left := right := 0. 375526 self paneMorphs 375527 do: [:pane | ((pane isKindOf: ScrollPane) 375528 and: [pane retractableScrollBar]) 375529 ifTrue: [pane scrollBarOnLeft 375530 ifTrue: [left := left max: pane scrollBarThickness] 375531 ifFalse: [right := right max: pane scrollBarThickness]]]. 375532 possibleBounds := (RealEstateAgent maximumUsableAreaInWorld: self world) 375533 insetBy: (left @ 0 corner: right @ 0). 375534 ((Flaps sharedFlapsAllowed 375535 and: [Project current flapsSuppressed not]) 375536 or: [Preferences fullScreenLeavesDeskMargins]) 375537 ifTrue: [possibleBounds := possibleBounds insetBy: 22]. 375538 ^possibleBounds! ! 375539 375540!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/23/2009 13:30'! 375541handlesDropShadowInHand 375542 "Answer whether the receiver will handle drop shadow drawing when picked up in the hand." 375543 375544 ^self theme handlesWindowDropShadowInHandFor: self! ! 375545 375546!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/31/2009 15:47'! 375547handlesKeyboard: evt 375548 "Return true if the receiver wishes to handle the given keyboard event" 375549 375550 (super handlesKeyboard: evt) ifTrue: [^true]. 375551 ^evt commandKeyPressed and: [ 375552 evt keyCharacter = Character arrowLeft or: [ 375553 evt keyCharacter = Character arrowRight or: [ 375554 evt keyCharacter = Character delete or: [ 375555 evt keyCharacter = $w]]]]! ! 375556 375557!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/15/2007 17:16'! 375558hasCloseBox 375559 "Answer whether the receiver currently has a close box." 375560 375561 ^closeBox notNil! ! 375562 375563!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/15/2007 17:16'! 375564hasCollapseBox 375565 "Answer whether the receiver currently has a collapse box." 375566 375567 ^collapseBox notNil! ! 375568 375569!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/15/2007 17:16'! 375570hasExpandBox 375571 "Answer whether the receiver currently has an expand box." 375572 375573 ^expandBox notNil! ! 375574 375575!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/15/2007 17:16'! 375576hasMenuBox 375577 "Answer whether the receiver currently has a menu box." 375578 375579 ^menuBox notNil! ! 375580 375581!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:58'! 375582inactiveFillStyle 375583 "Return the active fillStyle for the receiver." 375584 375585 ^self theme windowInactiveFillStyleFor: self! ! 375586 375587!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:59'! 375588inactiveLabelFillStyle 375589 "Return the inactive label fillStyle for the receiver." 375590 375591 ^self theme windowInactiveLabelFillStyleFor: self! ! 375592 375593!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:59'! 375594inactiveTitleFillStyle 375595 "Return the inactive title fillStyle for the receiver." 375596 375597 ^self theme windowInactiveTitleFillStyleFor: self! ! 375598 375599!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/20/2009 15:35'! 375600indicateModalChild 375601 "Make the user aware that this is the topmost modal child 375602 by flashing." 375603 375604 (self isMinimized and: [self isTaskbarPresent]) 375605 ifTrue: [self worldTaskbar ifNotNilDo: [:tb | 375606 tb indicateModalChildForMorph: self]] 375607 ifFalse: [self flash]! ! 375608 375609!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/16/2007 10:59'! 375610isMaximized 375611 "Answer whether we are maximised." 375612 375613 ^self unexpandedFrame notNil! ! 375614 375615!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/16/2007 11:01'! 375616isMinimized 375617 "Answer whether we are minimised." 375618 375619 ^self isCollapsed! ! 375620 375621!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/16/2007 11:01'! 375622isNotMaximized 375623 "Answer whether we are not maximised." 375624 375625 ^self unexpandedFrame isNil! ! 375626 375627!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/16/2007 11:01'! 375628isNotMinimized 375629 "Answer whether we are not minimised." 375630 375631 ^self isCollapsed not! ! 375632 375633!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/16/2007 11:00'! 375634isNotRestored 375635 "Answer whether we are maximised or minimised." 375636 375637 ^self isMinimized or: [self isMaximized]! ! 375638 375639!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/16/2007 11:03'! 375640isRestored 375641 "Answer whether we are neither expanded or collapsed." 375642 375643 ^(self isMinimized or: [self isMaximized]) not! ! 375644 375645!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/7/2007 20:01'! 375646isTaskbarPresent 375647 "Answer whether there is a taskbar in the world." 375648 375649 ^self worldTaskbar notNil! ! 375650 375651!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/31/2009 15:45'! 375652keyStroke: evt 375653 "Check for close window." 375654 375655 super keyStroke: evt. 375656 (self navigationKey: evt) ifTrue: [^true]. 375657 (evt commandKeyPressed and: [ 375658 evt keyCharacter = Character delete or: [ 375659 evt keyCharacter = $w]]) ifTrue: [ 375660 self delete. 375661 ^true]. 375662 ^false! ! 375663 375664!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/14/2007 12:57'! 375665labelArea 375666 "Answer the label area." 375667 375668 ^labelArea! ! 375669 375670!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/11/2007 15:13'! 375671labelString 375672 "Answer the actual label string." 375673 375674 ^label isNil 375675 ifTrue: [labelString] 375676 ifFalse: [label contents asString]! ! 375677 375678!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/2/2009 13:21'! 375679layoutChanged 375680 "No need to propagate to the world. 375681 Fixed to always flush layout cache." 375682 375683 (self owner isNil or: [self owner isWorldMorph not]) 375684 ifTrue: [^super layoutChanged]. 375685 fullBounds := nil. 375686 self layoutPolicy ifNotNilDo: [:layout | layout flushLayoutCache]! ! 375687 375688!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/14/2007 14:45'! 375689linkSplittersToSplitters 375690 "The pane morphs are already linked. Cross link the splitters as appropriate." 375691 375692 self splitters do: [:each | 375693 each splitsTopAndBottom 375694 ifTrue: [self splitters do: [:eachMorph | 375695 eachMorph splitsTopAndBottom ~= each splitsTopAndBottom ifTrue: [ 375696 eachMorph layoutFrame bottomFraction = each layoutFrame topFraction 375697 ifTrue: [each addLeftOrTop: eachMorph]. 375698 eachMorph layoutFrame topFraction = each layoutFrame bottomFraction 375699 ifTrue: [each addRightOrBottom: eachMorph]]]] 375700 ifFalse: [self splitters do: [:eachMorph | 375701 eachMorph splitsTopAndBottom ~= each splitsTopAndBottom ifTrue: [ 375702 eachMorph layoutFrame rightFraction = each layoutFrame leftFraction 375703 ifTrue: [each addLeftOrTop: eachMorph]. 375704 eachMorph layoutFrame leftFraction = each layoutFrame rightFraction 375705 ifTrue: [each addRightOrBottom: eachMorph]]]]]! ! 375706 375707!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/16/2007 11:02'! 375708maximize 375709 "Maximise the receiver. If collapsed the uncollapse first." 375710 375711 self isMinimized ifTrue: [self collapseOrExpand]. 375712 self isMaximized ifFalse: [self expandBoxHit]! ! 375713 375714!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/15/2007 12:26'! 375715menuBox 375716 "Answer the receiver's menu box." 375717 375718 ^menuBox! ! 375719 375720!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/27/2007 10:38'! 375721minimize 375722 "Minimise the receiver." 375723 375724 self isMinimized ifFalse: [self collapseBoxHit]! ! 375725 375726!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/24/2007 14:09'! 375727minimizeAfterGeneratingThumbnail 375728 "Minimize the window after thumbnail generation." 375729 375730 self isMinimized ifTrue: [^self]. 375731 isCollapsed := true. 375732 paneMorphs 375733 do: [:m | m delete; releaseCachedState]. 375734 self setBoundsWithFlex: (-10@-10 extent: 2@2). 375735 self hide. 375736 self layoutChanged 375737 ! ! 375738 375739!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/20/2009 16:03'! 375740minimizeOrRestore 375741 "Collapse or expand the window, depending on existing state" 375742 375743 |mc| 375744 isCollapsed 375745 ifTrue: ["Expand -- restore panes to morphics structure" 375746 Preferences windowAnimation ifTrue: [self animateRestoreFromMinimized]. 375747 isCollapsed := false. 375748 "Bring to front first" 375749 self 375750 setBoundsWithFlex: fullFrame; 375751 comeToFront; 375752 show. 375753 mc := self modalChild. 375754 paneMorphs reverseDo: [:m | 375755 mc ifNil: [m unlock]. 375756 self addMorph: m. 375757 self world startSteppingSubmorphsOf: m]. 375758 self activate] 375759 ifFalse: ["Collapse -- remove panes from morphics structure" 375760 isCollapsed := true. 375761 fullFrame := self getBoundsWithFlex. 375762 "First save latest fullFrame" 375763 paneMorphs 375764 do: [:m | m delete; releaseCachedState]. 375765 model modelSleep. 375766 self 375767 setBoundsWithFlex: (-100@-100 extent: 2@2); "place offscreen" 375768 hide. 375769 Preferences windowAnimation ifTrue: [self animateMinimize]. 375770 self isActive ifTrue: [ 375771 self world navigateVisibleWindowForward]]. 375772 self layoutChanged! ! 375773 375774!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/16/2007 12:24'! 375775modalChild 375776 "Answer the modal child of the receiver, if any." 375777 375778 ^self valueOfProperty: #modalChild! ! 375779 375780!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/21/2009 16:27'! 375781modalLockTo: aSystemWindow 375782 "Lock the receiver as a modal owner of the given window." 375783 375784 aSystemWindow 375785 setProperty: #modalOwner toValue: self. 375786 self setProperty: #modalChild toValue: aSystemWindow. 375787 (closeBox respondsTo: #enabled) ifTrue: [ 375788 self setProperty: #preModalCloseEnabled toValue: closeBox enabled]. 375789 (closeBox respondsTo: #enabled:) ifTrue: [ 375790 closeBox enabled: false]! ! 375791 375792!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/16/2007 12:24'! 375793modalOwner 375794 "Answer the modal owner of the receiver, if any." 375795 375796 ^self valueOfProperty: #modalOwner! ! 375797 375798!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/21/2009 16:29'! 375799modalUnlockFrom: aSystemWindow 375800 "Unlock the receiver as a modal owner of the given window." 375801 375802 aSystemWindow removeProperty: #modalOwner. 375803 self removeProperty: #modalChild. 375804 (closeBox respondsTo: #enabled:) ifTrue: [ 375805 closeBox enabled: (self valueOfProperty: #preModalCloseEnabled ifAbsent: [true])]. 375806 self removeProperty: #preModalCloseEnabled. 375807 self activate! ! 375808 375809!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/28/2009 13:51'! 375810navigateFocusForward 375811 "Change the keyboard focus to the next morph or the receiver 375812 in none are interested." 375813 375814 self nextMorphWantingFocus 375815 ifNil: [self takeKeyboardFocus] 375816 ifNotNil: [super navigateFocusForward] 375817 ! ! 375818 375819!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/18/2007 10:57'! 375820navigationKey: event 375821 "Check for tab key activity and change focus as appropriate. 375822 Check for menu key to do popup. 375823 Check for active window naviagation." 375824 375825 (self world navigationKey: event) ifTrue: [^true]. 375826 (self tabKey: event) ifTrue: [^true]. 375827 (event keyCharacter = Character escape and: [ 375828 event anyModifierKeyPressed]) ifTrue: [ 375829 self yellowButtonActivity: false. 375830 ^true]. 375831 ^false! ! 375832 375833!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:11'! 375834nextMorphAcrossInWindow 375835 "Answer the next morph in the window. Traverse 375836 from the receiver to its next sibling or owner's next sibling etc." 375837 375838 ^self! ! 375839 375840!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:05'! 375841nextMorphInWindow 375842 "Answer the next morph in the window. Traverse 375843 from the receiver to its first pane." 375844 375845 ^self hasSubmorphs 375846 ifTrue: [self submorphs first]! ! 375847 375848!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/10/2008 16:49'! 375849openModal: aSystemWindow 375850 "Open the given window locking the receiver until it is dismissed. 375851 Set the pane color to match the receiver. 375852 Answer the system window." 375853 375854 aSystemWindow 375855 theme: self theme; 375856 setWindowColor: self paneColor. 375857 ^super openModal: aSystemWindow! ! 375858 375859!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/29/2006 16:21'! 375860paneColorOrNil 375861 "Answer the window's pane color or nil otherwise." 375862 375863 ^self paneColor! ! 375864 375865!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/25/2006 13:44'! 375866paneColorTracksModel 375867 "Answer true if the colour of the window should be taken from the model." 375868 375869 ^true! ! 375870 375871!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/27/2007 11:01'! 375872playCloseSound 375873 "Play the themed sound for closing." 375874 375875 self theme windowCloseSound play! ! 375876 375877!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/27/2007 10:06'! 375878playMaximizeSound 375879 "Play the themed sound for maximizing." 375880 375881 self theme windowMaximizeSound play! ! 375882 375883!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/27/2007 10:06'! 375884playMinimizeSound 375885 "Play the themed sound for maximizing." 375886 375887 self theme windowMinimizeSound play! ! 375888 375889!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/12/2007 17:48'! 375890playOpenSound 375891 "Play the themed sound for opening." 375892 375893 self theme windowOpenSound play! ! 375894 375895!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/27/2007 10:06'! 375896playRestoreDownSound 375897 "Play the themed sound for restoring from maximized." 375898 375899 self theme windowRestoreDownSound play! ! 375900 375901!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/27/2007 10:05'! 375902playRestoreUpSound 375903 "Play the themed sound for restoring from minimized." 375904 375905 self theme windowRestoreUpSound play! ! 375906 375907!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/2/2009 10:26'! 375908preferredCornerStyle 375909 "Answer the preferred corner style." 375910 375911 ^self theme windowPreferredCornerStyleFor: self! ! 375912 375913!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:06'! 375914previousMorphInWindow 375915 "Answer the previous morph in the window. This will be the 375916 last submorph recursively of the first pane morph." 375917 375918 ^self hasSubmorphs 375919 ifTrue: [self lastSubmorphRecursive]! ! 375920 375921!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/4/2007 13:35'! 375922rememberKeyboardFocus: aMorph 375923 "Record the current keyboard focus for the receiver." 375924 375925 |m| 375926 m :=aMorph. 375927 (m notNil and: [(m hasOwner: self) not]) 375928 ifTrue: [m := nil]. 375929 self setProperty: #rememberedFocus toValue: m! ! 375930 375931!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/4/2007 13:42'! 375932rememberedKeyboardFocus 375933 "Answer the remembered keyboard focus for the receiver." 375934 375935 ^self valueOfProperty: #rememberedFocus! ! 375936 375937!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/25/2007 16:33'! 375938removeBoxes 375939 "Remove all label area boxes." 375940 375941 closeBox ifNotNil: [closeBox delete. closeBox := nil]. 375942 menuBox ifNotNil: [menuBox delete. menuBox := nil]. 375943 expandBox ifNotNil: [expandBox delete. expandBox := nil]. 375944 collapseBox ifNotNil: [collapseBox delete. collapseBox := nil]! ! 375945 375946!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/6/2007 12:58'! 375947removeCloseBox 375948 "Remove the close box." 375949 375950 closeBox ifNotNil: [closeBox delete. closeBox := nil]! ! 375951 375952!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/6/2007 12:58'! 375953removeCollapseBox 375954 "Remove the collapse box." 375955 375956 collapseBox ifNotNil: [collapseBox delete. collapseBox := nil]! ! 375957 375958!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/1/2007 14:41'! 375959removeEdgeGrips 375960 "Remove the window edge grips." 375961 375962 |edges| 375963 edges := self submorphsSatisfying: [:each | each isKindOf: WindowEdgeGripMorph]. 375964 edges do: [:each | each delete]! ! 375965 375966!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/6/2007 12:59'! 375967removeExpandBox 375968 "Remove the expand box." 375969 375970 expandBox ifNotNil: [expandBox delete. expandBox := nil]! ! 375971 375972!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/1/2007 14:42'! 375973removeGrips 375974 "Remove the edge and corner grips." 375975 375976 self 375977 removeCornerGrips; 375978 removeEdgeGrips! ! 375979 375980!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/7/2008 11:37'! 375981removeLabelArea 375982 "Remove the entire label area." 375983 375984 self removeGrips. 375985 labelArea delete. 375986 label := nil. 375987 (self isCollapsed not or: [self isTaskbarPresent]) ifTrue: [ 375988 self addGripsIfWanted]! ! 375989 375990!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 13:57'! 375991resetCollapsedFrame 375992 "Reset the collapsed frame." 375993 375994 collapsedFrame := nil! ! 375995 375996!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/27/2007 10:36'! 375997restore 375998 "Restore the receiver's normal size." 375999 376000 self isMinimized 376001 ifTrue: [self collapseBoxHit] 376002 ifFalse: [self isMaximized ifTrue: [self expandBoxHit]]! ! 376003 376004!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/23/2007 14:50'! 376005restoreAndActivate 376006 "Restore the window if minimised then activate." 376007 376008 self isMinimized 376009 ifTrue: [self restore]. 376010 self isActive 376011 ifFalse: [self activate]! ! 376012 376013!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/24/2007 13:43'! 376014restoreBeforeGeneratingThumbnail 376015 "Restore the window without activating unlocking or stepping." 376016 376017 self isMinimized ifFalse: [^self]. 376018 isCollapsed := false. 376019 self show. 376020 self setBoundsWithFlex: fullFrame. 376021 paneMorphs reverseDo: [:m | 376022 self addMorph: m]. 376023 self layoutChanged! ! 376024 376025!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/10/2009 16:26'! 376026setExpandBoxBalloonText 376027 "Set the expand box balloon help text as appropriate." 376028 376029 expandBox ifNil: [^self]. 376030 self unexpandedFrame 376031 ifNil: [expandBox setBalloonText: 'expand to full screen' translated] 376032 ifNotNil: [expandBox setBalloonText: 'contract to original size' translated]! ! 376033 376034!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/15/2009 15:21'! 376035shadowOffsetRectangle 376036 "Answer a rectangle describing the offsets to the 376037 receiver's bounds for a drop shadow." 376038 376039 ^self isActive 376040 ifTrue: [self theme windowActiveDropShadowOffsetRectangleFor: self] 376041 ifFalse: [self theme windowInactiveDropShadowOffsetRectangleFor: self]! ! 376042 376043!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/15/2008 21:46'! 376044showAbout 376045 "Show the class comment of the model in a workspace. 376046 Suggested by Michael Davies." 376047 376048 UITheme current 376049 longMessageIn: self 376050 text: self aboutText 376051 title: self aboutTitle! ! 376052 376053!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/24/2007 13:58'! 376054taskThumbnailOfSize: thumbExtent 376055 "Answer a new task thumbnail for the receiver." 376056 376057 |min thumb| 376058 min := self isMinimized 376059 ifTrue: [self restoreBeforeGeneratingThumbnail. 376060 true] 376061 ifFalse: [false]. 376062 thumb := self basicTaskThumbnailOfSize: thumbExtent. 376063 min ifTrue: [self minimizeAfterGeneratingThumbnail]. 376064 ^thumb! ! 376065 376066!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/16/2007 12:30'! 376067taskbarButtonClicked 376068 "The taskbar button for the receiver has been clicked. 376069 If minimised then restore. 376070 If active then minimize. 376071 Otherwise make active." 376072 376073 self isMinimized 376074 ifTrue: [self restore] 376075 ifFalse: [self isActive 376076 ifTrue: [self minimize] 376077 ifFalse: [self activate]]! ! 376078 376079!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/22/2007 14:01'! 376080taskbarButtonEntered: aButton event: evt in: aMorph 376081 "The mouse has entered out taskbar button. 376082 Show a thumbnail." 376083 376084 |thumb| 376085 Preferences worldTaskbarWindowPreview ifFalse: [^self]. 376086 thumb := self valueOfProperty: #taskbarThumbnail. 376087 thumb 376088 ifNil: [thumb := self theme newTaskbarThumbnailIn: self for: self] 376089 ifNotNil: [^self]. 376090 self setProperty: #taskbarThumbnail toValue: thumb. 376091 thumb bottomLeft: ((aButton left min: aButton owner right - thumb width)@ (aButton owner top - 4)). 376092 thumb openInWorld! ! 376093 376094!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/22/2007 14:01'! 376095taskbarButtonFor: aTaskbar 376096 "Answer a new task bar button for the receiver. 376097 Answer nil if not required." 376098 376099 ^self theme 376100 newTaskbarButtonIn: aTaskbar 376101 for: self! ! 376102 376103!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/25/2007 10:13'! 376104taskbarButtonLeft: aButton event: evt in: aMorph 376105 "The mouse has left our taskbar button. 376106 Remove our thumbnail." 376107 376108 Preferences worldTaskbarWindowPreview ifFalse: [^self]. 376109 self 376110 valueOfProperty: #taskbarThumbnail 376111 ifPresentDo: [:thumb | 376112 thumb delete. 376113 self removeProperty: #taskbarThumbnail]! ! 376114 376115!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/20/2009 14:08'! 376116taskbarButtonMenu: aMenu 376117 "Answer the menu for the task bar button." 376118 376119 | menu theme | 376120 theme := self theme. 376121 menu := theme newMenuIn: self for: self. 376122 menu 376123 addToggle: 'Restore' translated 376124 target: self 376125 selector: #restore 376126 getStateSelector: nil 376127 enablementSelector: #isNotRestored. 376128 menu lastItem 376129 icon: self theme windowMaximizeForm; 376130 font: theme menuFont. 376131 menu 376132 addToggle: 'Minimize' translated 376133 target: self 376134 selector: #minimize 376135 getStateSelector: nil 376136 enablementSelector: #isNotMinimized. 376137 menu lastItem 376138 icon: self theme windowMinimizeForm; 376139 font: theme menuFont. 376140 menu 376141 addToggle: 'Maximize' translated 376142 target: self 376143 selector: #maximize 376144 getStateSelector: nil 376145 enablementSelector: #canBeMaximized. 376146 menu lastItem 376147 icon: self theme windowMaximizeForm; 376148 font: theme menuFont. 376149 menu addLine. 376150 menu 376151 addToggle: 'Close' translated 376152 target: self 376153 selector: #closeBoxHit 376154 getStateSelector: nil 376155 enablementSelector: #allowedToClose. 376156 menu lastItem 376157 icon: self theme windowCloseForm; 376158 font: theme menuFont. 376159 ^menu! ! 376160 376161!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/17/2007 17:42'! 376162taskbarIcon 376163 "Answer the icon for the receiver in a task bar." 376164 376165 self model ifNotNil: [self model taskbarIcon ifNotNilDo: [:ico | ^ico]]. 376166 ^super taskbarIcon! ! 376167 376168!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/31/2009 15:57'! 376169taskbarLabel 376170 "Answer the label to use for a taskbar button for the receiver." 376171 376172 self model ifNotNil: [self model taskbarLabel ifNotNilDo: [:str | ^str]]. 376173 ^self labelString! ! 376174 376175!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 13:08'! 376176taskbarState 376177 "Answer one of #minimized, #restored, #maximized or #active." 376178 376179 ^self isMinimized 376180 ifTrue: [#minimized] 376181 ifFalse: [self isMaximized 376182 ifTrue: [#maximized] 376183 ifFalse: [self isActive 376184 ifTrue: [#active] 376185 ifFalse: [#restored]]]! ! 376186 376187!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/31/2009 15:54'! 376188taskbarTask 376189 "Answer a new taskbar task for the receiver. 376190 Answer nil if not required." 376191 376192 (self valueOfProperty: #noTaskbarTask ifAbsent: [false]) ifTrue: [^nil]. 376193 ^TaskbarTask 376194 morph: self 376195 state: self taskbarState 376196 icon: self taskbarIcon 376197 label: self taskbarLabel! ! 376198 376199!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/11/2007 15:06'! 376200taskbarThumbnailExtent 376201 "Answer the size of a taskbar thumbnail for the receiver." 376202 376203 ^self isMinimized 376204 ifTrue: [self fullFrame extent min: self defaultTaskbarThumbnailExtent] 376205 ifFalse: [super taskbarThumbnailExtent]! ! 376206 376207!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 15:51'! 376208theme 376209 "Answer the ui theme that provides controls. 376210 Don't call super since that implementation may delegate here." 376211 376212 (self valueOfProperty: #theme) ifNotNilDo: [:t | ^ t]. 376213 ^self class theme! ! 376214 376215!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/9/2009 17:09'! 376216themeChanged 376217 "Update the window colour and control boxes." 376218 376219 self labelArea delete. 376220 self removeGrips. 376221 self theme 376222 configureWindowBorderFor: self; 376223 configureWindowDropShadowFor: self. 376224 self paneColor: self defaultBackgroundColor. 376225 label ifNotNil: [ "don't if label area removed" 376226 self initializeLabelArea]. 376227 self setStripeColorsFrom: self paneColor. 376228 (self isCollapsed not or: [self isTaskbarPresent]) ifTrue: [ 376229 self addGripsIfWanted]. 376230 super themeChanged! ! 376231 376232!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/6/2009 12:26'! 376233toggleVisibleAndRaise 376234 "Toggle the visibility of the receiver, bringing to 376235 the front if becoming visible. Activate or passivate here." 376236 376237 self isActive ifTrue: [self world navigateVisibleWindowForward]. 376238 super toggleVisibleAndRaise. 376239 self visible ifTrue: [self activate]! ! 376240 376241!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/7/2008 11:43'! 376242wantsGrips 376243 "Answer whether the window wants edge and corner grips." 376244 376245 ^(self valueOfProperty: #noGrips ifAbsent: [false]) not! ! 376246 376247!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/10/2007 10:08'! 376248window 376249 "Answer the receiver's window." 376250 376251 ^self! ! 376252 376253!SystemWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/9/2007 11:47'! 376254worldTaskbar 376255 "Answer the world taskbar or nil if none." 376256 376257 ^self world submorphThat: [:m | m isTaskbar] ifNone: [] ! ! 376258 376259 376260!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/20/2009 14:59'! 376261activate 376262 "Activate the owner too." 376263 376264 |mo mc| 376265 mo := self modalOwner. 376266 mc := self modalChild. 376267 mc isNil 376268 ifFalse: [mc owner notNil ifTrue: [ 376269 mc activate. 376270 ^mc modalChild isNil ifTrue: [mc indicateModalChild]]]. 376271 (self paneMorphs size > 1 and: [self splitters isEmpty]) 376272 ifTrue: [self addPaneSplitters]. 376273 super activate. 376274 self basicActivate. 376275 self rememberedKeyboardFocus 376276 ifNil: [(self respondsTo: #navigateFocusForward) 376277 ifTrue: [self navigateFocusForward]] 376278 ifNotNilDo: [:m | m world 376279 ifNil: [self rememberKeyboardFocus: nil] "deleted" 376280 ifNotNilDo: [:w | 376281 m wantsKeyboardFocus 376282 ifTrue: [m takeKeyboardFocus] 376283 ifFalse: [(self respondsTo: #navigateFocusForward) 376284 ifTrue: [self navigateFocusForward]]]]. 376285 (mo notNil and: [mo isKindOf: SystemWindow]) 376286 ifTrue: [mo bringBehind: self]! ! 376287 376288!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/26/2008 12:12'! 376289addExpandBox 376290 "If I have a labelArea, add a close box to it" 376291 | frame | 376292 labelArea 376293 ifNil: [^ self]. 376294 expandBox := self createExpandBox. 376295 self setExpandBoxBalloonText. 376296 frame := LayoutFrame new. 376297 frame leftFraction: 1; 376298 leftOffset: (self boxExtent x * 2 + 3) negated; 376299 topFraction: 0; 376300 topOffset: 0. 376301 expandBox layoutFrame: frame. 376302 labelArea addMorphBack: expandBox! ! 376303 376304!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2009 13:56'! 376305addMenuControl 376306 "If I have a label area, add a menu control to it." 376307 376308 labelArea ifNil: [^ self]. "No menu if no label area" 376309 menuBox 376310 ifNotNil: [menuBox delete]. 376311 labelArea addMorphBack: (menuBox := self createMenuBox)! ! 376312 376313!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 12/1/2008 15:28'! 376314addMorph: aMorph fullFrame: aLayoutFrame 376315 "Add a morph to the receiver with the given layout frame." 376316 376317 | left right bottom top windowBorderWidth | 376318 windowBorderWidth := self class borderWidth. 376319 376320 left := aLayoutFrame leftOffset ifNil: [0]. 376321 right := aLayoutFrame rightOffset ifNil: [0]. 376322 376323 bottom := aLayoutFrame bottomOffset ifNil: [0]. 376324 top := aLayoutFrame topOffset ifNil: [0]. 376325 376326 aLayoutFrame rightFraction = 1 ifTrue: [aLayoutFrame rightOffset: right - windowBorderWidth]. 376327 aLayoutFrame leftFraction = 0 376328 ifTrue: [aLayoutFrame leftOffset: left + windowBorderWidth] 376329 ifFalse: [aLayoutFrame leftFraction = 1 ifFalse: [ 376330 aLayoutFrame leftOffset: left + ProportionalSplitterMorph splitterWidth]]. 376331 376332 aLayoutFrame bottomFraction = 1 ifTrue: [aLayoutFrame bottomOffset: bottom - windowBorderWidth]. 376333 aLayoutFrame topFraction = 0 376334 ifTrue: [aLayoutFrame topOffset: top] 376335 ifFalse: [aLayoutFrame topFraction = 1 ifFalse: [ 376336 aLayoutFrame topOffset: top + ProportionalSplitterMorph splitterWidth]]. 376337 376338 (aMorph class name = #BrowserCommentTextMorph) ifTrue: 376339 [aLayoutFrame rightOffset: windowBorderWidth negated. 376340 aLayoutFrame leftOffset: windowBorderWidth. 376341 aLayoutFrame bottomOffset: windowBorderWidth negated. 376342 aLayoutFrame topOffset: (windowBorderWidth negated) + 4]. 376343 376344 super addMorph: aMorph fullFrame: aLayoutFrame. 376345 376346 paneMorphs := paneMorphs copyReplaceFrom: 1 to: 0 with: (Array with: aMorph). 376347 aMorph adoptPaneColor: self paneColor. 376348 aMorph 376349 borderStyle: (self theme windowPaneBorderStyleFor: aMorph in: self); 376350 color: (aMorph initialColorInSystemWindow: self). 376351 Preferences scrollBarsOnRight "reorder panes so flop-out right-side scrollbar is visible" 376352 ifTrue: [self addMorphBack: aMorph]. 376353 376354 self owner ifNotNil: [ 376355 self addPaneSplitters] "do when opened for performance"! ! 376356 376357!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/25/2007 11:10'! 376358addPaneHSplitterBetween: topMorphs and: bottomMorphs 376359 "Add a horizontal splitter for the given morphs that share a common bottom fraction. 376360 If there is a horizontal discontinuity apply the splitter to the first contiguous group. 376361 Answer the morphs to which the splitter was applied." 376362 376363 |targetY fixed rightFraction leftFrame rightFrame sorted morph topGroup bottomGroup splitter offset| 376364 topMorphs ifEmpty: [^self]. 376365 targetY := topMorphs first layoutFrame bottomFraction. 376366 fixed := topMorphs select: [:m | m layoutFrame topFraction = m layoutFrame bottomFraction]. 376367 "fixed morphs appear in both top and bottom" 376368 sorted := ((topMorphs reject: [:m | m layoutFrame topFraction = m layoutFrame bottomFraction]) 376369 asSortedCollection: [:a :b | a layoutFrame rightFraction = b layoutFrame rightFraction 376370 ifTrue: [a layoutFrame leftFraction <= b layoutFrame leftFraction] 376371 ifFalse: [a layoutFrame rightFraction <= b layoutFrame rightFraction]]) readStream. 376372 sorted contents ifEmpty: [^fixed]. 376373 topGroup := OrderedCollection new. 376374 rightFraction := sorted contents first layoutFrame leftFraction. 376375 [sorted atEnd or: [morph := sorted next. 376376 (morph layoutFrame leftFraction ~= rightFraction and: [ 376377 morph layoutFrame rightFraction ~= rightFraction])]] whileFalse: [ 376378 topGroup add: morph. 376379 rightFraction := morph layoutFrame rightFraction]. 376380 leftFrame := topGroup first layoutFrame. 376381 rightFrame := topGroup last layoutFrame. 376382 bottomGroup := (bottomMorphs 376383 reject: [:m | m layoutFrame topFraction = m layoutFrame bottomFraction]) 376384 select: [:m | 376385 (m layoutFrame leftFraction 376386 between: leftFrame leftFraction 376387 and: rightFrame rightFraction) or: [ 376388 m layoutFrame rightFraction 376389 between: leftFrame leftFraction 376390 and: rightFrame rightFraction]]. 376391 offset := (topGroup collect: [:m | m layoutFrame bottomOffset ifNil: [0]]) max. 376392 splitter := ProportionalSplitterMorph new 376393 beSplitsTopAndBottom. 376394 splitter layoutFrame: (LayoutFrame 376395 fractions: (leftFrame leftFraction @ targetY 376396 corner: rightFrame rightFraction @ targetY) 376397 offsets: (((leftFrame leftOffset ifNil: [0]) @ 0 corner: ((rightFrame rightOffset ifNil: [0])@ 4)) 376398 translateBy: 0 @ offset)). 376399 topGroup := topGroup, fixed. 376400 topGroup do: [:m | splitter addLeftOrTop: m]. 376401 bottomGroup do: [:m | splitter addRightOrBottom: m]. 376402 self addMorphBack: splitter. 376403 ^topGroup! ! 376404 376405!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/14/2007 13:44'! 376406addPaneHSplitters 376407 "Add the horizontal pane splitters." 376408 376409 |remaining targetBottom sameBottom sameTop| 376410 remaining := paneMorphs reject: [:each | 376411 each layoutFrame bottomFraction = 1 or: [ 376412 each layoutFrame bottomFraction = 0]]. 376413 [remaining notEmpty] whileTrue: [ 376414 targetBottom := remaining first layoutFrame bottomFraction. 376415 sameBottom := remaining select: [:each | 376416 each layoutFrame bottomFraction = targetBottom]. 376417 sameTop := paneMorphs select: [:each | 376418 each layoutFrame topFraction = targetBottom]. 376419 remaining := remaining 376420 copyWithoutAll: (self addPaneHSplitterBetween: sameBottom and: sameTop)]! ! 376421 376422!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/14/2007 14:39'! 376423addPaneSplitters 376424 "Add the vertical and horizontal pane splitters." 376425 376426 self removePaneSplitters. 376427 self addPaneVSplitters. 376428 self addPaneHSplitters. 376429 self linkSplittersToSplitters! ! 376430 376431!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/25/2007 11:10'! 376432addPaneVSplitterBetween: leftMorphs and: rightMorphs 376433 "Add a vertical splitter for the given morphs that share a common right fraction. 376434 If there is a vertical discontinuity apply the splitter to the first contiguous group. 376435 Answer the morphs to which the splitter was applied." 376436 376437 |targetX fixed bottomFraction topFrame bottomFrame sorted morph leftGroup rightGroup splitter offset| 376438 leftMorphs ifEmpty: [^self]. 376439 targetX := leftMorphs first layoutFrame rightFraction. 376440 fixed := leftMorphs select: [:m | m layoutFrame leftFraction = m layoutFrame rightFraction]. 376441 "fixed morphs appear in both top and bottom" 376442 sorted := ((leftMorphs reject: [:m | m layoutFrame leftFraction = m layoutFrame rightFraction]) 376443 asSortedCollection: [:a :b | a layoutFrame bottomFraction = b layoutFrame bottomFraction 376444 ifTrue: [a layoutFrame topFraction <= b layoutFrame topFraction] 376445 ifFalse: [a layoutFrame bottomFraction <= b layoutFrame bottomFraction]]) readStream. 376446 sorted contents ifEmpty: [^fixed]. 376447 leftGroup := OrderedCollection new. 376448 bottomFraction := sorted contents first layoutFrame topFraction. 376449 [sorted atEnd or: [morph := sorted next. 376450 morph layoutFrame topFraction ~= bottomFraction and: [ 376451 morph layoutFrame bottomFraction ~= bottomFraction]]] whileFalse: [ 376452 leftGroup add: morph. 376453 bottomFraction := morph layoutFrame bottomFraction]. 376454 topFrame := leftGroup first layoutFrame. 376455 bottomFrame := leftGroup last layoutFrame. 376456 rightGroup := (rightMorphs 376457 reject: [:m | m layoutFrame leftFraction = m layoutFrame rightFraction]) 376458 select: [:m | 376459 m layoutFrame topFraction 376460 between: topFrame topFraction 376461 and: bottomFrame bottomFraction]. 376462 offset := (leftGroup collect: [:m | m layoutFrame rightOffset ifNil: [0]]) max. 376463 splitter := ProportionalSplitterMorph new. 376464 splitter layoutFrame: (LayoutFrame 376465 fractions: (targetX @ topFrame topFraction 376466 corner: targetX @ bottomFrame bottomFraction) 376467 offsets: ((0 @ (topFrame topOffset ifNil: [0]) corner: (4@ (bottomFrame bottomOffset ifNil: [0]))) 376468 translateBy: offset @ 0)). 376469 leftGroup := leftGroup, fixed. 376470 leftGroup do: [:m | splitter addLeftOrTop: m]. 376471 rightGroup do: [:m | splitter addRightOrBottom: m]. 376472 self addMorphBack: splitter. 376473 ^leftGroup! ! 376474 376475!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/14/2007 17:05'! 376476addPaneVSplitters 376477 "Add the vertical pane splitters." 376478 376479 |remaining targetRight sameRight sameLeft | 376480 remaining := paneMorphs reject: [:each | 376481 each layoutFrame rightFraction = 1 or: [ 376482 each layoutFrame rightFraction = 0]]. 376483 [remaining notEmpty] whileTrue: [ 376484 targetRight := remaining first layoutFrame rightFraction. 376485 sameRight := remaining select: [:each | 376486 each layoutFrame rightFraction = targetRight]. 376487 sameLeft := paneMorphs select: [:each | 376488 each layoutFrame leftFraction = targetRight and: [ 376489 each layoutFrame rightFraction ~= targetRight]]. 376490 remaining := remaining 376491 copyWithoutAll: (self addPaneVSplitterBetween: sameRight and: sameLeft)]! ! 376492 376493!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/21/2009 16:53'! 376494buildWindowMenu 376495 "Build and answer the window menu." 376496 376497 | aMenu | 376498 aMenu := self theme newMenuIn: self for: self. 376499 aMenu addToggle: 'close' translated target: self 376500 selector: #closeBoxHit getStateSelector: nil 376501 enablementSelector: #allowedToClose. 376502 aMenu lastItem icon: self theme windowCloseForm. 376503 aMenu addLine. 376504 aMenu add: 'about' translated action: #showAbout. 376505 aMenu lastItem icon: MenuIcons smallHelpIcon. 376506 aMenu addLine. 376507 aMenu addLine. 376508 aMenu add: 'change title...' translated action: #relabel. 376509 aMenu addLine. 376510 aMenu add: 'send to back' translated action: #sendToBack. 376511 aMenu add: 'make next-to-topmost' translated action: #makeSecondTopmost. 376512 aMenu addLine. 376513 self mustNotClose 376514 ifFalse: 376515 [aMenu add: 'make unclosable' translated action: #makeUnclosable] 376516 ifTrue: 376517 [aMenu add: 'make closable' translated action: #makeClosable]. 376518 aMenu 376519 add: (self isSticky ifTrue: ['make draggable'] ifFalse: ['make undraggable']) translated 376520 action: #toggleStickiness. 376521 aMenu addLine. 376522 self isMaximized 376523 ifTrue: [aMenu add: 'restore' translated action: #expandBoxHit. 376524 aMenu lastItem icon: self theme windowMaximizeForm] 376525 ifFalse: [aMenu add: 'maximize' translated action: #expandBoxHit. 376526 aMenu lastItem icon: self theme windowMaximizeForm]. 376527 self isCollapsed ifFalse: [aMenu add: 'window color...' translated action: #setWindowColor]. 376528 ^aMenu! ! 376529 376530!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2009 18:10'! 376531closeBoxHit 376532 "The user clicked on the close-box control in the window title. 376533 For Mac users only, the Mac convention of option-click-on-close-box is obeyed if the mac option key is down. 376534 If we have a modal child then don't delete. 376535 Play the close sound now since this is the only time we know that the close is user-initiated." 376536 376537 self allowedToClose ifFalse: [^self]. 376538 self playCloseSound. 376539 Preferences dismissAllOnOptionClose ifTrue: 376540 [Sensor rawMacOptionKeyPressed ifTrue: 376541 [^ self world closeUnchangedWindows]]. 376542 self delete 376543! ! 376544 376545!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/7/2008 11:36'! 376546collapseOrExpand 376547 "Collapse or expand the window, depending on existing state. 376548 Use the taskbar if present, otherwise do as normal." 376549 376550 | cf | 376551 self isTaskbarPresent ifTrue: [^self minimizeOrRestore]. 376552 isCollapsed 376553 ifTrue: 376554 ["Expand -- restore panes to morphics structure" 376555 isCollapsed := false. 376556 self activate. "Bring to frint first" 376557 Preferences collapseWindowsInPlace 376558 ifTrue: 376559 [fullFrame := fullFrame align: fullFrame topLeft with: self getBoundsWithFlex topLeft] 376560 ifFalse: 376561 [collapsedFrame := self getBoundsWithFlex]. 376562 collapseBox ifNotNil: [collapseBox setBalloonText: 'collapse this window']. 376563 self setBoundsWithFlex: fullFrame. 376564 paneMorphs reverseDo: 376565 [:m | self addMorph: m unlock. 376566 self world startSteppingSubmorphsOf: m]. 376567 self 376568 addPaneSplitters; 376569 addGripsIfWanted] 376570 ifFalse: 376571 ["Collapse -- remove panes from morphics structure" 376572 isCollapsed := true. 376573 fullFrame := self getBoundsWithFlex. 376574 "First save latest fullFrame" 376575 paneMorphs do: [:m | m delete; releaseCachedState]. 376576 self removePaneSplitters. 376577 self removeGrips. 376578 model modelSleep. 376579 cf := self getCollapsedFrame. 376580 (collapsedFrame isNil and: [Preferences collapseWindowsInPlace not]) ifTrue: 376581 [collapsedFrame := cf]. 376582 self setBoundsWithFlex: cf. 376583 collapseBox ifNotNil: [collapseBox setBalloonText: 'expand this window']. 376584 expandBox ifNotNil: [expandBox setBalloonText: 'expand to full screen']]. 376585 self layoutChanged! ! 376586 376587!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/22/2008 12:19'! 376588createCloseBox 376589 "Answer a button for closing the window." 376590 376591 ^self theme createCloseBoxFor: self! ! 376592 376593!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/22/2008 12:20'! 376594createCollapseBox 376595 "Answer a button for minimising the window." 376596 376597 ^self theme createCollapseBoxFor: self! ! 376598 376599!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/22/2008 12:20'! 376600createExpandBox 376601 "Answer a button for maximising/restoring the window." 376602 376603 ^self theme createExpandBoxFor: self! ! 376604 376605!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/22/2008 12:20'! 376606createMenuBox 376607 "Answer a button for the window menu." 376608 376609 ^self theme createMenuBoxFor: self! ! 376610 376611!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/24/2009 11:46'! 376612delete 376613 "Should activate window before asking model if okToChange 376614 since likely that a confirmation dialog will be requested. 376615 Don't if not owned by the world though." 376616 376617 | thisWorld sketchEditor aPaintBox animateClose| 376618 self mustNotClose ifTrue: [^ self]. 376619 (self owner notNil and: [self owner isWorldMorph]) 376620 ifTrue: [self activate]. 376621 model okToChange ifFalse: [^ self]. 376622 animateClose := (self visible and: [self world notNil and: [ 376623 Preferences windowAnimation and: [ 376624 Preferences noWindowAnimationForClosing not]]]). 376625 self removePaneSplitters. "in case we add some panes and reopen!!" 376626 thisWorld := self world. 376627 sketchEditor := self extantSketchEditor. 376628 self isFlexed 376629 ifTrue: [owner delete] 376630 ifFalse: [super delete]. 376631 model windowIsClosing; release. 376632 model := nil. 376633 animateClose ifTrue: [self animateClose]. 376634 sketchEditor ifNotNil: 376635 [sketchEditor deleteSelfAndSubordinates. 376636 thisWorld notNil ifTrue: 376637 [(aPaintBox := thisWorld paintBoxOrNil) ifNotNil: [aPaintBox delete]]]. 376638 376639 SystemWindow noteTopWindowIn: thisWorld. 376640! ! 376641 376642!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2009 18:13'! 376643expandBoxHit 376644 "The full screen expand box has been hit" 376645 376646 self isCollapsed 376647 ifTrue: [self playRestoreUpSound. 376648 self 376649 hide; 376650 collapseOrExpand. 376651 self unexpandedFrame ifNil: [self unexpandedFrame: fullFrame]. 376652 self 376653 fullScreen; 376654 setExpandBoxBalloonText. 376655 ^self show]. 376656 self unexpandedFrame 376657 ifNil: [self playMaximizeSound. 376658 Preferences windowAnimation ifTrue: [self animateMaximize]. 376659 self 376660 unexpandedFrame: fullFrame; 376661 fullScreen] 376662 ifNotNil: [self playRestoreDownSound. 376663 Preferences windowAnimation ifTrue: [self animateRestore]. 376664 self 376665 bounds: self unexpandedFrame; 376666 unexpandedFrame: nil]. 376667 self setExpandBoxBalloonText! ! 376668 376669!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/2/2009 16:05'! 376670extent: aPoint 376671 "Set the receiver's extent to value provided. Respect my minimumExtent." 376672 376673 | newExtent w| 376674 newExtent := self isCollapsed 376675 ifTrue: [aPoint max: (self labelWidgetAllowance @ 0)] 376676 ifFalse: [aPoint max: self minimumExtent]. 376677 newExtent = self extent ifTrue: [^ self]. 376678 376679 isCollapsed 376680 ifTrue: [super extent: newExtent x @ self labelHeight] 376681 ifFalse: [super extent: newExtent]. 376682 isCollapsed 376683 ifTrue: [collapsedFrame := self bounds] 376684 ifFalse: [fullFrame := self bounds]. 376685 (self isCollapsed or: [label isNil]) "shrink the label if insufficient space" 376686 ifFalse: [label minWidth: nil. 376687 label fitContents. 376688 w := (label width min: bounds width - labelWidgetAllowance). 376689 label setWidth: w; minWidth: w. 376690 label align: label bounds topCenter with: bounds topCenter + (0@borderWidth). 376691 collapsedFrame ifNotNil: 376692 [collapsedFrame := collapsedFrame withWidth: label width + labelWidgetAllowance]]. 376693 self theme windowExtentChangedFor: self! ! 376694 376695!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/22/2008 17:29'! 376696fullScreen 376697 "Zoom Window to Full World size with possible DeskMargins" 376698 "SystemWindow fullScreen" 376699 376700 | left right possibleBounds | 376701 left := right := 0. 376702 self paneMorphs 376703 do: [:pane | ((pane isKindOf: ScrollPane) 376704 and: [pane retractableScrollBar]) 376705 ifTrue: [pane scrollBarOnLeft 376706 ifTrue: [left := left max: pane scrollBarThickness] 376707 ifFalse: [right := right max: pane scrollBarThickness]]]. 376708 possibleBounds := (RealEstateAgent maximumUsableAreaInWorld: self world) 376709 insetBy: (left @ 0 corner: right @ 0). 376710 self class environment at: #Flaps ifPresent: [:cl | 376711 ((cl sharedFlapsAllowed 376712 and: [Project current flapsSuppressed not]) 376713 or: [Preferences fullScreenLeavesDeskMargins]) 376714 ifTrue: [possibleBounds := possibleBounds insetBy: 22]]. 376715 self bounds: possibleBounds! ! 376716 376717!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/16/2007 11:32'! 376718getRawLabel 376719 "Owner is needed by Preferences class>>refreshFontSettings and 376720 the #duplicate class is rather time consuming with Freetype fonts. 376721 Answer a shallowCopy of the label with the contents fitted." 376722 376723 |contentsFit| 376724 contentsFit := label shallowCopy fitContents. 376725 contentsFit extent: (label extent x min: contentsFit extent x) @ contentsFit extent y. 376726 ^contentsFit! ! 376727 376728!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/9/2009 17:09'! 376729initialize 376730 "Initialize a system window. Add label, stripes, etc., if desired" 376731 376732 super initialize. 376733 allowReframeHandles := true. 376734 labelString ifNil: [labelString := 'Untitled Window']. 376735 isCollapsed := false. 376736 activeOnlyOnTop := true. 376737 paneMorphs := Array new. 376738 borderColor := Color lightGray. 376739 borderWidth := 1. 376740 self color: Color lightGray lighter lighter lighter. 376741 self layoutPolicy: ProportionalLayout new. 376742 self clipSubmorphs: true. 376743 376744 self theme 376745 configureWindowBorderFor: self; 376746 configureWindowDropShadowFor: self. 376747 self initializeLabelArea. 376748 376749 self cellPositioning: #topLeft. "make the offsets easy to calculate!!" 376750 self addGripsIfWanted. 376751 376752 self extent: 300 @ 200. 376753 mustNotClose := false. 376754 updatablePanes := Array new! ! 376755 376756!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/2/2009 11:25'! 376757initializeLabelArea 376758 "Initialize the label area (titlebar) for the window." 376759 376760 label := self theme windowLabelFor: self. 376761 "Add default inital boxes" 376762 collapseBox := self createCollapseBox. "Add collapse box so #labelHeight will work" 376763 closeBox := self createCloseBox. 376764 self wantsExpandBox ifTrue: [ 376765 expandBox := self createExpandBox. 376766 self setExpandBoxBalloonText]. 376767 menuBox := self createMenuBox. 376768 stripes := Array 376769 with: (RectangleMorph newBounds: bounds) 376770 with: (RectangleMorph newBounds: bounds). 376771 self addLabelArea. 376772 labelArea 376773 goBehind; 376774 maxCellSize: self boxExtent. 376775 self replaceBoxes. 376776 Preferences clickOnLabelToEdit 376777 ifTrue: [label 376778 on: #mouseDown 376779 send: #relabel 376780 to: self]. 376781 labelArea fillStyle: self activeTitleFillStyle.! ! 376782 376783!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/19/2007 15:34'! 376784isActive 376785 "Answer active if no owner too to avoid color flickering." 376786 376787 self owner ifNil: [^true]. 376788 self activeOnlyOnTop ifTrue: [^ self == TopWindow]. 376789 ^ true! ! 376790 376791!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/17/2006 10:26'! 376792justDroppedInto: aMorph event: anEvent 376793 "Release the mouse focus as well." 376794 376795 isCollapsed 376796 ifTrue: [self position: ((self position max: 0@0) grid: 8@8). 376797 collapsedFrame := self bounds] 376798 ifFalse: [fullFrame := self bounds. 376799 TopWindow ~~ self ifTrue: [self activate]]. 376800 anEvent hand releaseMouseFocus. 376801 ^super justDroppedInto: aMorph event: anEvent! ! 376802 376803!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/1/2008 14:07'! 376804labelHeight 376805 "Answer the height for the window label. The standard behavior is at bottom; a hook is provided so that models can stipulate other heights, in support of various less-window-looking demos. 376806 If no label answer the class border width instead." 376807 376808 | aHeight | 376809 (model notNil and: [model respondsTo: #desiredWindowLabelHeightIn:]) ifTrue: 376810 [(aHeight := model desiredWindowLabelHeightIn: self) ifNotNil: [^ aHeight]]. 376811 376812 ^ label ifNil: [self class borderWidth] ifNotNil: 376813 [(label height + (self class borderWidth * 2)) max: 376814 (collapseBox ifNotNil: [collapseBox height] ifNil: [10])]! ! 376815 376816!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/10/2009 16:26'! 376817lockInactivePortions 376818 "Make me unable to respond to mouse and keyboard. Control boxes remain active." 376819 376820 self submorphsDo: [:m | m == labelArea ifFalse: [m lock]]! ! 376821 376822!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/18/2008 10:55'! 376823makeClosable 376824 "Reinstate the close box. Go via theme to maintain box order." 376825 376826 mustNotClose := false. 376827 closeBox 376828 ifNil: [closeBox := self createCloseBox. 376829 self replaceBoxes]! ! 376830 376831!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 4/3/2008 11:51'! 376832model: anObject 376833 "Set the model." 376834 376835 super model: anObject. 376836 self paneColorTracksModel ifTrue: [ 376837 self 376838 setProperty: #paneColor toValue: self defaultBackgroundColor; 376839 fillStyle: self fillStyleToUse; 376840 setStripeColorsFrom: self paneColorToUse. 376841 Preferences fadedBackgroundWindows ifFalse: [ "since not done in stripes" 376842 self adoptPaneColor: self paneColor]]. 376843 self minimumExtent: ( 376844 (anObject respondsTo: #minimumExtent) 376845 ifTrue: [anObject minimumExtent]). 376846 menuBox ifNotNil: [ 376847 menuBox 376848 labelGraphic: (self theme windowMenuIconFor: self); 376849 extent: self boxExtent]! ! 376850 376851!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 11/13/2007 12:24'! 376852mouseDown: evt 376853 "Changed to properly process the mouse down event if passing to 376854 submorphs." 376855 376856 (self valueOfProperty: #processingMouseDown) == true 376857 ifTrue: [^self]. "recursive handling" 376858 evt hand waitForClicksOrDrag: self event: evt. "allow double-click response" 376859 self setProperty: #clickPoint toValue: evt cursorPoint. 376860 TopWindow == self 376861 ifTrue: [self comeToFront] "rise above non-window morphs" 376862 ifFalse:[ 376863 TopWindow ifNotNilDo: [:w | 376864 w rememberKeyboardFocus: evt hand keyboardFocus]. 376865 evt hand releaseKeyboardFocus. 376866 self activate]. 376867 model windowActiveOnFirstClick ifTrue: 376868 ["Normally window keeps control of first click. 376869 Need explicit transmission for first-click activity." 376870 self setProperty: #processingMouseDown toValue: true. 376871 [evt wasHandled: false. 376872 self processEvent: evt] 376873 ensure: [self setProperty: #processingMouseDown toValue: false]]! ! 376874 376875!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2009 18:14'! 376876openAsIsIn: aWorld 376877 "This msg and its callees result in the window being activeOnlyOnTop. 376878 Play the open sound if the preference is enabled." 376879 376880 self playOpenSound. 376881 aWorld addMorph: self. 376882 self activate. 376883 aWorld startSteppingSubmorphsOf: self. 376884! ! 376885 376886!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/23/2007 13:53'! 376887paneColor 376888 | cc | 376889 (cc := self valueOfProperty: #paneColor) ifNotNil: [ 376890 ^Preferences fadedBackgroundWindows 376891 ifTrue: [self isActive 376892 ifTrue: [cc] 376893 ifFalse: [cc alphaMixed: 0.5 with: (Color white alpha: cc alpha)]] 376894 ifFalse: [cc]]. 376895 cc := paneMorphs isEmptyOrNil ifFalse: [paneMorphs first color]. 376896 cc ifNil: [cc := self defaultBackgroundColor]. 376897 cc isTransparent ifTrue: [cc := self defaultBackgroundColor]. 376898 self setProperty: #paneColor toValue: cc. 376899 ^self paneColor! ! 376900 376901!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/10/2009 15:04'! 376902passivate 376903 "Make me unable to respond to mouse and keyboard" 376904 376905 super passivate. 376906 self setStripeColorsFrom: self paneColorToUse. 376907 model modelSleep. 376908 "Control boxes remain active, except in novice mode" 376909 self lockInactivePortions. 376910 labelArea ifNil: "i.e. label area is nil, so we're titleless" 376911 [self adjustBorderUponDeactivationWhenLabeless]! ! 376912 376913!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/10/2009 11:40'! 376914replaceBoxes 376915 "Rebuild the various boxes." 376916 376917 labelArea removeAllMorphs. 376918 self setLabelWidgetAllowance. 376919 self theme configureWindowLabelAreaFor: self. 376920 self setFramesForLabelArea. 376921 self isActive ifFalse: [labelArea passivate]! ! 376922 376923!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/1/2009 12:06'! 376924setFramesForLabelArea 376925 "Set the layout for the label area." 376926 376927 self theme configureWindowLabelAreaFrameFor: self! ! 376928 376929!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 10/26/2007 21:13'! 376930setLabelWidgetAllowance 376931 "Set the extra space required, in general, apart from the label. 376932 Should make theme based (for centered titles), leave enough room 376933 for the moment." 376934 376935 ^labelWidgetAllowance := (self boxExtent x * 7) 376936 "allow for three on one side and centering plus a bit"! ! 376937 376938!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 1/29/2009 11:53'! 376939setStripeColorsFrom: paneColor 376940 "Set the stripe color based on the given paneColor. 376941 Removed box color update for Pharo compatability." 376942 376943 stripes ifNil: [^self]. 376944 self fillStyle: self fillStyleToUse. 376945 self isActive 376946 ifTrue: [label ifNotNil: [label color: self activeLabelFillStyle]. 376947 labelArea fillStyle: self activeTitleFillStyle] 376948 ifFalse: [label ifNotNil: [label color: self inactiveLabelFillStyle]. 376949 labelArea fillStyle: self inactiveTitleFillStyle]. 376950 self adoptPaneColor: self paneColor! ! 376951 376952!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 12/4/2007 14:54'! 376953setWindowColor: incomingColor 376954 "Removed existing color check - looked useless!!" 376955 376956 | aColor | 376957 incomingColor ifNil: [^ self]. "it happens" 376958 aColor := incomingColor. 376959 (aColor = ColorPickerMorph perniciousBorderColor 376960 or: [aColor = Color black]) ifTrue: [^ self]. 376961 self setProperty: #paneColor toValue: aColor. 376962 self setStripeColorsFrom: aColor. 376963 Preferences fadedBackgroundWindows ifFalse: [ 376964 self adoptPaneColor: aColor]. "reverse optimisation" 376965 self changed.! ! 376966 376967!SystemWindow methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 6/2/2009 10:35'! 376968wantsRoundedCorners 376969 "Answer whether rounded corners are wanted." 376970 376971 ^(self theme windowPreferredCornerStyleFor: self) == #rounded! ! 376972 376973 376974!SystemWindow methodsFor: '*services-base' stamp: 'rr 3/24/2004 17:22'! 376975requestor 376976 [^model requestor] 376977 on: Error 376978 do: [Transcript show: 'no requestor for : ', model class name.^ Requestor default] ! ! 376979 376980!SystemWindow methodsFor: '*services-base' stamp: 'rr 3/10/2006 14:15'! 376981topWindow 376982 ^ TopWindow! ! 376983 376984 376985!SystemWindow methodsFor: 'drawing' stamp: 'di 8/16/1998 01:14'! 376986areasRemainingToFill: aRectangle 376987 | areas | 376988 (areas := super areasRemainingToFill: aRectangle) isEmpty 376989 ifTrue: [^ areas "good news -- complete occlusion"]. 376990 "Check for special case that this is scrollbar damage" 376991 ((bounds topLeft - (14@0) corner: bounds bottomRight) containsRect: aRectangle) ifTrue: 376992 [paneMorphs do: [:p | ((p isKindOf: ScrollPane) and: [p scrollBarFills: aRectangle]) 376993 ifTrue: [^ Array new]]]. 376994 ^ areas! ! 376995 376996!SystemWindow methodsFor: 'drawing' stamp: 'ar 8/15/2001 21:55'! 376997colorForInsets 376998 ^self paneColor colorForInsets! ! 376999 377000!SystemWindow methodsFor: 'drawing' stamp: 'RAA 6/12/2000 18:16'! 377001makeMeVisible 377002 377003 self world extent > (0@0) ifFalse: [^ self]. 377004 377005 ((self world bounds insetBy: (0@0 corner: self labelHeight asPoint)) 377006 containsPoint: self position) ifTrue: [^ self "OK -- at least my top left is visible"]. 377007 377008 "window not on screen (probably due to reframe) -- move it now" 377009 self isCollapsed 377010 ifTrue: [self position: (RealEstateAgent assignCollapsePointFor: self)] 377011 ifFalse: [self position: (RealEstateAgent initialFrameFor: self initialExtent: self extent world: self world) topLeft]. 377012 377013! ! 377014 377015!SystemWindow methodsFor: 'drawing' stamp: 'ar 8/16/2001 12:47'! 377016raisedColor 377017 ^self paneColor raisedColor! ! 377018 377019!SystemWindow methodsFor: 'drawing' stamp: 'ar 12/18/2001 02:09'! 377020scrollBarColor 377021 ^self paneColor! ! 377022 377023 377024!SystemWindow methodsFor: 'events' stamp: 'gvc 5/13/2009 12:52'! 377025doFastFrameDrag: grabPoint 377026 "Do fast frame dragging from the given point" 377027 377028 | offset newBounds outerWorldBounds | 377029 outerWorldBounds := self boundsIn: nil. 377030 offset := outerWorldBounds origin - grabPoint. 377031 newBounds := outerWorldBounds newRectButtonPressedDo: [:f | 377032 Sensor cursorPoint + offset extent: outerWorldBounds extent]. 377033 Display deferUpdatesIn: Display boundingBox while: [ 377034 self position: (self globalPointToLocal: newBounds topLeft)]! ! 377035 377036!SystemWindow methodsFor: 'events' stamp: 'RAA 2/7/2001 07:11'! 377037handleListenEvent: evt 377038 "Make sure we lock our contents after DnD has finished" 377039 evt isMouse ifFalse:[^self]. 377040 evt hand hasSubmorphs ifTrue:[^self]. "still dragging" 377041 self == TopWindow ifFalse:[self lockInactivePortions]. 377042 evt hand removeMouseListener: self.! ! 377043 377044!SystemWindow methodsFor: 'events' stamp: 'di 12/1/2001 22:54'! 377045handlesMouseDown: evt 377046 "If I am not the topWindow, then I will only respond to dragging by the title bar. 377047 Any other click will only bring me to the top" 377048 377049 (self labelRect containsPoint: evt cursorPoint) 377050 ifTrue: [^ true]. 377051 ^ self activeOnlyOnTop and: [self ~~ TopWindow]! ! 377052 377053!SystemWindow methodsFor: 'events' stamp: 'ar 1/31/2001 21:02'! 377054handlesMouseOverDragging: evt 377055 ^true! ! 377056 377057!SystemWindow methodsFor: 'events' stamp: 'ar 1/31/2001 21:09'! 377058mouseEnterDragging: evt 377059 "unlock children for drop operations" 377060 (self ~~ TopWindow and:[evt hand hasSubmorphs]) ifTrue:[ 377061 self submorphsDo:[:m| m unlock]. 377062 evt hand addMouseListener: self. "for drop completion on submorph" 377063 ].! ! 377064 377065!SystemWindow methodsFor: 'events' stamp: 'RAA 2/7/2001 07:12'! 377066mouseLeaveDragging: evt 377067 "lock children after drop operations" 377068 (self ~~ TopWindow and:[evt hand hasSubmorphs]) ifTrue:[ 377069 self lockInactivePortions. 377070 evt hand removeMouseListener: self. 377071 ].! ! 377072 377073!SystemWindow methodsFor: 'events' stamp: 'bf 9/25/2008 14:58'! 377074mouseMove: evt 377075 "Handle a mouse-move event" 377076 377077 | cp | 377078 cp := evt cursorPoint. 377079 self valueOfProperty: #clickPoint ifPresentDo: 377080 [:firstClick | 377081 ((self labelRect containsPoint: firstClick) and: [(cp dist: firstClick) > 3]) ifTrue: 377082 ["If this is a drag that started in the title bar, then pick me up" 377083 ^ self isSticky ifFalse: 377084 [self fastFramingOn 377085 ifTrue: [self doFastFrameDrag: firstClick] "pass the first click." 377086 ifFalse: [evt hand grabMorph: self topRendererOrSelf]]]]. 377087 model windowActiveOnFirstClick ifTrue: 377088 ["Normally window takes control on first click. 377089 Need explicit transmission for first-click activity." 377090 submorphs do: [:m | (m containsPoint: cp) ifTrue: [m mouseMove: evt]]]! ! 377091 377092!SystemWindow methodsFor: 'events' stamp: 'di 6/10/1998 14:41'! 377093mouseUp: evt 377094 | cp | 377095 model windowActiveOnFirstClick ifTrue: 377096 ["Normally window takes control on first click. 377097 Need explicit transmission for first-click activity." 377098 cp := evt cursorPoint. 377099 submorphs do: [:m | (m containsPoint: cp) ifTrue: [m mouseUp: evt]]]! ! 377100 377101!SystemWindow methodsFor: 'events' stamp: 'jmv 2/19/2006 14:47'! 377102paneTransition: event 377103 "Mouse has entered or left a pane"! ! 377104 377105!SystemWindow methodsFor: 'events' stamp: 'jmv 2/19/2006 14:54'! 377106secondaryPaneTransition: event divider: aMorph 377107 "Mouse has entered or left a pane"! ! 377108 377109!SystemWindow methodsFor: 'events' stamp: 'sw 12/22/1999 18:31'! 377110wantsHalo 377111 ^ false! ! 377112 377113!SystemWindow methodsFor: 'events' stamp: 'ar 9/18/2000 18:34'! 377114wantsToBeDroppedInto: aMorph 377115 "Return true if it's okay to drop the receiver into aMorph" 377116 ^aMorph isWorldMorph or:[Preferences systemWindowEmbedOK]! ! 377117 377118 377119!SystemWindow methodsFor: 'geometry' stamp: 'di 6/16/1998 07:56'! 377120labelRect 377121 ^ self innerBounds withHeight: self labelHeight. 377122! ! 377123 377124!SystemWindow methodsFor: 'geometry' stamp: 'sw 2/16/1999 15:23'! 377125paneMorphs 377126 "Nominally private but a need for obtaining this from the outside arose" 377127 ^ paneMorphs copy! ! 377128 377129!SystemWindow methodsFor: 'geometry' stamp: 'sma 2/5/2000 14:09'! 377130panelRect 377131 "Answer the area below the title bar which is devoted to panes." 377132 377133 ^ self innerBounds insetBy: (0 @ self labelHeight corner: 0 @ 0)! ! 377134 377135!SystemWindow methodsFor: 'geometry' stamp: 'di 5/22/1998 13:24'! 377136position: newPos 377137 super position: newPos. 377138 isCollapsed 377139 ifTrue: [collapsedFrame := self bounds] 377140 ifFalse: [fullFrame := self bounds]. 377141! ! 377142 377143!SystemWindow methodsFor: 'geometry' stamp: 'sw 9/28/1999 11:02'! 377144removeMenuBox 377145 menuBox ifNotNil: 377146 [menuBox delete. 377147 menuBox := nil]. 377148! ! 377149 377150!SystemWindow methodsFor: 'geometry' stamp: 'JW 2/1/2001 13:15'! 377151setPaneRectsFromBounds 377152 "Reset proportional specs from actual bounds, eg, after reframing panes" 377153 | layoutBounds box frame left right top bottom | 377154 layoutBounds := self layoutBounds. 377155 paneMorphs do:[:m| 377156 frame := m layoutFrame. 377157 box := m bounds. 377158 frame ifNotNil:[ 377159 left := box left - layoutBounds left - (frame leftOffset ifNil:[0]). 377160 right := box right - layoutBounds left - (frame rightOffset ifNil:[0]). 377161 top := box top - layoutBounds top - (frame topOffset ifNil:[0]). 377162 bottom := box bottom - layoutBounds top - (frame bottomOffset ifNil:[0]). 377163 frame leftFraction: (left / layoutBounds width asFloat). 377164 frame rightFraction: (right / layoutBounds width asFloat). 377165 frame topFraction: (top / layoutBounds height asFloat). 377166 frame bottomFraction: (bottom / layoutBounds height asFloat). 377167 ]. 377168 ].! ! 377169 377170 377171!SystemWindow methodsFor: 'initialization' stamp: 'bvs 3/16/2004 11:13'! 377172addCloseBox 377173 "If I have a labelArea, add a close box to it" 377174 | frame | 377175 labelArea 377176 ifNil: [^ self]. 377177 closeBox := self createCloseBox. 377178 frame := LayoutFrame new. 377179 frame leftFraction: 0; 377180 leftOffset: 2; 377181 topFraction: 0; 377182 topOffset: 0. 377183 closeBox layoutFrame: frame. 377184 labelArea addMorphBack: closeBox! ! 377185 377186!SystemWindow methodsFor: 'initialization' stamp: 'nk 6/2/2004 11:27'! 377187addLabelArea 377188 377189 labelArea := (AlignmentMorph newSpacer: Color transparent) 377190 vResizing: #spaceFill; 377191 layoutPolicy: ProportionalLayout new. 377192 self addMorph: labelArea.! ! 377193 377194!SystemWindow methodsFor: 'initialization' stamp: 'dgd 10/26/2004 19:44'! 377195applyModelExtent 377196 | initialExtent | 377197 initialExtent := Preferences bigDisplay 377198 ifTrue: [(model initialExtent * 1.5) rounded] 377199 ifFalse: [model initialExtent]. 377200 self extent: initialExtent ! ! 377201 377202!SystemWindow methodsFor: 'initialization' stamp: 'marcus.denker 11/30/2008 20:46'! 377203boxExtent 377204 "answer the extent to use in all the buttons. 377205 The label height is used to be proportional to the fonts preferences" 377206 377207 ^ (14 @ 14) max: label height @ label height ! ! 377208 377209!SystemWindow methodsFor: 'initialization' stamp: 'jrp 7/23/2005 12:07'! 377210createBox 377211 "create a button with default to be used in the label area" 377212 "Transcript show: self paneColor asString; 377213 cr." 377214 | box | 377215 box := IconicButton new. 377216 box color: Color transparent; 377217 target: self; 377218 useSquareCorners; 377219 borderWidth: 0. 377220 377221 ^ box! ! 377222 377223!SystemWindow methodsFor: 'initialization' stamp: 'md 2/24/2006 15:57'! 377224defaultBorderColor 377225 "answer the default border color/fill style for the receiver" 377226 ^ #raised.! ! 377227 377228!SystemWindow methodsFor: 'initialization' stamp: 'md 2/24/2006 15:57'! 377229defaultColor 377230 "answer the default color/fill style for the receiver" 377231 ^ Color white.! ! 377232 377233!SystemWindow methodsFor: 'initialization' stamp: 'bvs 3/16/2004 13:20'! 377234gradientWithColor: aColor 377235 377236 | ramp | 377237 ramp := {0.0 -> Color white. 1.0 -> aColor}. 377238 377239 ^ (GradientFillStyle ramp: ramp) 377240 radial: true; 377241 origin: self bounds origin; 377242 direction: 0 @ 223; 377243 normal: 223 @ 0.! ! 377244 377245!SystemWindow methodsFor: 'initialization' stamp: 'jlb 5/29/2001 23:24'! 377246maximumExtent 377247 "This returns the maximum extent that the morph may be expanded to. 377248 Return nil if this property has not been set." 377249 377250 ^ self valueOfProperty: #maximumExtent! ! 377251 377252!SystemWindow methodsFor: 'initialization' stamp: 'jlb 5/29/2001 23:24'! 377253maximumExtent: aPoint 377254 "This returns the maximum extent that the morph may be expanded to. 377255 Return nil if this property has not been set." 377256 377257 ^ self setProperty: #maximumExtent toValue: aPoint! ! 377258 377259 377260!SystemWindow methodsFor: 'label' stamp: 'sw 11/7/2000 10:24'! 377261externalName 377262 "Answer the name by which the receiver is known in the UI" 377263 377264 ^ labelString! ! 377265 377266!SystemWindow methodsFor: 'label' stamp: 'di 5/4/1998 23:42'! 377267label 377268 ^ labelString! ! 377269 377270!SystemWindow methodsFor: 'label' stamp: 'sw 9/29/1999 07:22'! 377271labelWidgetAllowance 377272 ^ labelWidgetAllowance ifNil: [self setLabelWidgetAllowance]! ! 377273 377274!SystemWindow methodsFor: 'label' stamp: 'DamienCassou 9/29/2009 13:13'! 377275relabel 377276 | newLabel | 377277 newLabel := UIManager default 377278 request: 'New title for this window' translated 377279 initialAnswer: labelString. 377280 newLabel isEmptyOrNil ifTrue: [^self]. 377281 (model windowReqNewLabel: newLabel) 377282 ifTrue: [self setLabel: newLabel]! ! 377283 377284!SystemWindow methodsFor: 'label' stamp: 'dew 8/3/2004 01:12'! 377285setLabel: aString 377286 | frame | 377287 labelString := aString. 377288 label ifNil: [^ self]. 377289 label contents: aString. 377290 self labelWidgetAllowance. "Sets it if not already" 377291 self isCollapsed 377292 ifTrue: [self extent: (label width + labelWidgetAllowance) @ (self labelHeight + 2)] 377293 ifFalse: [label fitContents; setWidth: (label width min: bounds width - labelWidgetAllowance). 377294 label align: label bounds topCenter with: bounds topCenter + (0@borderWidth). 377295 collapsedFrame ifNotNil: 377296 [collapsedFrame := collapsedFrame withWidth: label width + labelWidgetAllowance]]. 377297 frame := LayoutFrame new. 377298 frame leftFraction: 0.5; 377299 topFraction: 0.5; 377300 leftOffset: label width negated // 2; 377301 topOffset: label height negated // 2. 377302 label layoutFrame: frame. 377303! ! 377304 377305!SystemWindow methodsFor: 'label' stamp: 'yo 6/30/2004 00:21'! 377306setLabelFont: aFont 377307 377308 label ifNil: [^ self]. 377309 label font: aFont. 377310! ! 377311 377312!SystemWindow methodsFor: 'label' stamp: 'BG 8/27/2003 19:07'! 377313update: aSymbol 377314 aSymbol = #relabel 377315 ifTrue: [^ model ifNotNil: [ self setLabel: model labelString ] ]. 377316 aSymbol = #close 377317 ifTrue: [self delete]! ! 377318 377319!SystemWindow methodsFor: 'label' stamp: 'jmv 8/6/2009 08:57'! 377320widthOfFullLabelText 377321 ^Preferences windowTitleFont widthOfString: labelString! ! 377322 377323 377324!SystemWindow methodsFor: 'layout' stamp: 'wiz 1/18/2006 15:44'! 377325convertAlignment 377326 "Primarily Jesse Welton's code to convert old system windows to ones with modern layout scheme" 377327 377328 | frame | 377329 self layoutPolicy: ProportionalLayout new. 377330 (paneMorphs isNil 377331 or: [paneRects isNil or: [paneMorphs size ~= paneRects size]]) 377332 ifFalse: 377333 [self addLabelArea. 377334 self putLabelItemsInLabelArea. 377335 self setFramesForLabelArea. 377336 paneMorphs with: paneRects 377337 do: 377338 [:m :r | 377339 frame := LayoutFrame new. 377340 frame 377341 leftFraction: r left; 377342 rightFraction: r right; 377343 topFraction: r top; 377344 bottomFraction: r bottom. 377345 m layoutFrame: frame. 377346 m 377347 hResizing: #spaceFill; 377348 vResizing: #spaceFill]]. 377349 labelArea isNil 377350 ifTrue: 377351 [self addLabelArea. 377352 self putLabelItemsInLabelArea. 377353 self setFramesForLabelArea. 377354 paneMorphs ifNotNil: 377355 [paneMorphs do: 377356 [:m | 377357 frame := m layoutFrame ifNil: [LayoutFrame new]. 377358 frame topOffset: (frame topOffset ifNil: [0]) - self labelHeight. 377359 frame bottomFraction ~= 1.0 377360 ifTrue: 377361 [frame bottomOffset: (frame bottomOffset ifNil: [0]) - self labelHeight]]]]. 377362 label ifNotNil: 377363 [frame := LayoutFrame new. 377364 frame 377365 leftFraction: 0.5; 377366 topFraction: 0; 377367 leftOffset: label width negated // 2. 377368 label layoutFrame: frame]. 377369 collapseBox ifNotNil: 377370 [frame := LayoutFrame new. 377371 frame 377372 rightFraction: 1; 377373 topFraction: 0; 377374 rightOffset: -1; 377375 topOffset: 1. 377376 collapseBox layoutFrame: frame]. 377377 stripes ifNotNil: 377378 [frame := LayoutFrame new. 377379 frame 377380 leftFraction: 0; 377381 topFraction: 0; 377382 rightFraction: 1; 377383 leftOffset: 1; 377384 topOffset: 1; 377385 rightOffset: -1. 377386 stripes first layoutFrame: frame. 377387 stripes first height: self labelHeight - 2. 377388 stripes first hResizing: #spaceFill. 377389 frame := LayoutFrame new. 377390 frame 377391 leftFraction: 0; 377392 topFraction: 0; 377393 rightFraction: 1; 377394 leftOffset: 3; 377395 topOffset: 3; 377396 rightOffset: -3. 377397 stripes last layoutFrame: frame. 377398 stripes last height: self labelHeight - 6. 377399 stripes last hResizing: #spaceFill]. 377400 menuBox ifNotNil: 377401 [frame := LayoutFrame new. 377402 frame 377403 leftFraction: 0; 377404 leftOffset: 19; 377405 topFraction: 0; 377406 topOffset: 1. 377407 menuBox layoutFrame: frame]. 377408 closeBox ifNotNil: 377409 [frame := LayoutFrame new. 377410 frame 377411 leftFraction: 0; 377412 leftOffset: 4; 377413 topFraction: 0; 377414 topOffset: 1. 377415 closeBox layoutFrame: frame]! ! 377416 377417!SystemWindow methodsFor: 'layout' stamp: 'JW 1/30/2001 22:45'! 377418layoutBounds 377419 "Bounds of pane area only." 377420 | box | 377421 377422 box := super layoutBounds. 377423 ^box withTop: box top + self labelHeight! ! 377424 377425!SystemWindow methodsFor: 'layout' stamp: 'sw 5/18/2001 16:09'! 377426putLabelItemsInLabelArea 377427 "Put label items into the label area, if there is one" 377428 377429 labelArea ifNotNil: 377430 [stripes ifNotNil: [stripes do: [:stripe | labelArea addMorph: stripe]]. 377431 closeBox ifNotNil: [labelArea addMorph: closeBox]. 377432 menuBox ifNotNil: [labelArea addMorph: menuBox]. 377433 collapseBox ifNotNil: [labelArea addMorph: collapseBox]. 377434 label ifNotNil: [labelArea addMorph: label]] 377435 377436! ! 377437 377438 377439!SystemWindow methodsFor: 'menu' stamp: 'md 11/14/2003 17:30'! 377440addCustomMenuItems: aCustomMenu hand: aHandMorph 377441 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 377442"template..." 377443 aCustomMenu addLine. 377444 aCustomMenu add: 'edit label...' translated action: #relabel. 377445! ! 377446 377447!SystemWindow methodsFor: 'menu' stamp: 'sw 10/6/2000 14:01'! 377448changeColor 377449 "Change the color of the receiver -- triggered, e.g. from a menu. This variant allows the recolor triggered from the window's halo recolor handle to have the same result as choosing change-window-color from the window-title menu" 377450 377451 ColorPickerMorph new 377452 choseModalityFromPreference; 377453 sourceHand: self activeHand; 377454 target: self; 377455 selector: #setWindowColor:; 377456 originalColor: self color; 377457 putUpFor: self near: self fullBoundsInWorld! ! 377458 377459!SystemWindow methodsFor: 'menu' stamp: 'sw 8/7/2000 17:35'! 377460deleteCloseBox 377461 closeBox ifNotNil: 377462 [closeBox delete. 377463 closeBox := nil]! ! 377464 377465!SystemWindow methodsFor: 'menu' stamp: 'dao 10/1/2004 12:57'! 377466fullScreenMaximumExtent 377467 "Zoom Window to Full World size with possible DeskMargins 377468 obey the maximum extent rules" 377469 377470 | left right possibleBounds | 377471 left := right := 0. 377472 self paneMorphs 377473 do: [:pane | ((pane isKindOf: ScrollPane) 377474 and: [pane retractableScrollBar]) 377475 ifTrue: [pane scrollBarOnLeft 377476 ifTrue: [left := left max: pane scrollBarThickness] 377477 ifFalse: [right := right max: pane scrollBarThickness]]]. 377478 possibleBounds := self worldBounds 377479 insetBy: (left @ 0 corner: right @ 0). 377480 377481 self maximumExtent ifNotNil: 377482 [possibleBounds := possibleBounds origin extent: ( self maximumExtent min: ( possibleBounds extent ))]. 377483 ((Flaps sharedFlapsAllowed 377484 and: [Project current flapsSuppressed not]) 377485 or: [Preferences fullScreenLeavesDeskMargins]) 377486 ifTrue: [possibleBounds := possibleBounds insetBy: 22]. 377487 self bounds: possibleBounds! ! 377488 377489!SystemWindow methodsFor: 'menu' stamp: 'gm 2/16/2003 20:35'! 377490makeSecondTopmost 377491 | aWorld nextWindow | 377492 aWorld := self world. 377493 nextWindow := aWorld submorphs 377494 detect: [:m | (m isSystemWindow) and: [m ~~ self]] 377495 ifNone: [^self]. 377496 nextWindow activate. 377497 aWorld addMorph: self behind: nextWindow! ! 377498 377499!SystemWindow methodsFor: 'menu' stamp: 'sw 8/7/2000 17:35'! 377500makeUnclosable 377501 mustNotClose := true. 377502 self deleteCloseBox! ! 377503 377504!SystemWindow methodsFor: 'menu' stamp: 'RAA 6/12/2000 09:01'! 377505offerWindowMenu 377506 | aMenu | 377507 aMenu := self buildWindowMenu. 377508 model ifNotNil: 377509 [model addModelItemsToWindowMenu: aMenu]. 377510 aMenu popUpEvent: self currentEvent in: self world! ! 377511 377512!SystemWindow methodsFor: 'menu' stamp: 'michael.rueger 3/9/2009 18:48'! 377513sendToBack 377514 | aWorld nextWindow | 377515 aWorld := self world. 377516 nextWindow := aWorld submorphs 377517 detect: [:m | (m isSystemWindow) and: [m ~~ self]] 377518 ifNone: [^self]. 377519 nextWindow activate. 377520 aWorld addMorphBack: self! ! 377521 377522!SystemWindow methodsFor: 'menu' stamp: 'sw 9/6/2000 18:46'! 377523setWindowColor 377524 "Allow the user to select a new basic color for the window" 377525 377526 ColorPickerMorph new 377527 choseModalityFromPreference; 377528 sourceHand: self activeHand; 377529 target: self; 377530 selector: #setWindowColor:; 377531 originalColor: self paneColorToUse; 377532 putUpFor: self 377533 near: self fullBounds! ! 377534 377535!SystemWindow methodsFor: 'menu' stamp: 'nb 6/17/2003 12:25'! 377536takeOutOfWindow 377537 "Take the receiver's pane morph out the window and place it, naked, where once the window was" 377538 | aMorph | 377539 paneMorphs size == 1 ifFalse: [^ Beeper beep]. 377540 aMorph := paneMorphs first. 377541 owner addMorphFront: aMorph. 377542 self delete! ! 377543 377544!SystemWindow methodsFor: 'menu' stamp: 'dgd 9/18/2004 18:27'! 377545wantsYellowButtonMenu 377546 "Answer true if the receiver wants a yellow button menu" 377547 ^ false! ! 377548 377549 377550!SystemWindow methodsFor: 'open/close' stamp: 'dgd 10/26/2004 19:45'! 377551initialExtent 377552 ^ Preferences bigDisplay 377553 ifTrue: [(model initialExtent * 1.75) rounded] 377554 ifFalse: [model initialExtent]! ! 377555 377556!SystemWindow methodsFor: 'open/close' stamp: 'sw 9/28/1999 13:32'! 377557mustNotClose 377558 ^ mustNotClose == true! ! 377559 377560!SystemWindow methodsFor: 'open/close' stamp: 'ar 5/11/2001 23:46'! 377561openAsIs 377562 ^self openAsIsIn: self currentWorld 377563! ! 377564 377565!SystemWindow methodsFor: 'open/close' stamp: 'ar 5/11/2001 23:47'! 377566openInWorld: aWorld 377567 "This msg and its callees result in the window being activeOnlyOnTop" 377568 self bounds: (RealEstateAgent initialFrameFor: self world: aWorld). 377569 ^self openAsIsIn: aWorld! ! 377570 377571!SystemWindow methodsFor: 'open/close' stamp: 'ar 5/11/2001 23:47'! 377572openInWorld: aWorld extent: extent 377573 "This msg and its callees result in the window being activeOnlyOnTop" 377574 self position: (RealEstateAgent initialFrameFor: self world: aWorld) topLeft; extent: extent. 377575 ^self openAsIsIn: aWorld! ! 377576 377577!SystemWindow methodsFor: 'open/close' stamp: 'alain.plantec 6/1/2008 23:07'! 377578openInWorldExtent: extent 377579 "This msg and its callees result in the window being activeOnlyOnTop" 377580 377581 self openInWorld: self currentWorld extent: extent! ! 377582 377583!SystemWindow methodsFor: 'open/close' stamp: 'sw 10/15/1998 11:13'! 377584positionSubmorphs 377585 "Feels like overkill, but effect needed" 377586 super positionSubmorphs. 377587 self submorphsDo: 377588 [:aMorph | aMorph positionSubmorphs]! ! 377589 377590 377591!SystemWindow methodsFor: 'panes' stamp: 'RAA 1/8/2001 20:37'! 377592addMorph: aMorph frame: relFrame 377593 | frame | 377594 frame := LayoutFrame new. 377595 frame 377596 leftFraction: relFrame left; 377597 rightFraction: relFrame right; 377598 topFraction: relFrame top; 377599 bottomFraction: relFrame bottom. 377600 self addMorph: aMorph fullFrame: frame. 377601 377602! ! 377603 377604!SystemWindow methodsFor: 'panes' stamp: 'md 2/24/2006 15:47'! 377605existingPaneColor 377606 "Answer the existing pane color for the window, obtaining it from the first paneMorph if any, and fall back on using the second stripe color if necessary." 377607 377608 | aColor | 377609 aColor := self valueOfProperty: #paneColor. 377610 aColor ifNil: [self setProperty: #paneColor toValue: (aColor := self paneColor)]. 377611 ^aColor.! ! 377612 377613!SystemWindow methodsFor: 'panes' stamp: 'sw 1/14/1999 10:52'! 377614holdsTranscript 377615 "ugh" 377616 | plug | 377617 ^ paneMorphs size == 1 and: [((plug := paneMorphs first) isKindOf: PluggableTextMorph) and: [plug model isKindOf: TranscriptStream]]! ! 377618 377619!SystemWindow methodsFor: 'panes' stamp: 'bvs 3/17/2004 09:15'! 377620paneColor: aColor 377621 self setProperty: #paneColor toValue: aColor. 377622 377623 self adoptPaneColor: aColor.! ! 377624 377625!SystemWindow methodsFor: 'panes' stamp: 'ar 8/15/2001 22:14'! 377626paneColorToUse 377627 ^ Display depth <= 2 377628 ifTrue: 377629 [Color white] 377630 ifFalse: 377631 [self paneColor]! ! 377632 377633!SystemWindow methodsFor: 'panes' stamp: 'sw 10/19/1999 09:44'! 377634paneMorphSatisfying: aBlock 377635 ^ paneMorphs detect: [:aPane | aBlock value: aPane] ifNone: [nil]! ! 377636 377637!SystemWindow methodsFor: 'panes' stamp: 'md 2/24/2006 15:46'! 377638replacePane: oldPane with: newPane 377639 "Make newPane exactly occupy the position and extent of oldPane" 377640 377641 | aLayoutFrame hadDep | 377642 hadDep := model dependents includes: oldPane. 377643 oldPane owner replaceSubmorph: oldPane by: newPane. 377644 newPane 377645 position: oldPane position; 377646 extent: oldPane extent. 377647 aLayoutFrame := oldPane layoutFrame. 377648 paneMorphs := paneMorphs collect: 377649 [:each | 377650 each == oldPane ifTrue: [newPane] ifFalse: [each]]. 377651 aLayoutFrame ifNotNil: [newPane layoutFrame: aLayoutFrame]. 377652 newPane color: Color transparent. 377653 hadDep ifTrue: [model removeDependent: oldPane. model addDependent: newPane]. 377654 377655 self changed 377656 377657! ! 377658 377659!SystemWindow methodsFor: 'panes' stamp: 'md 2/24/2006 15:46'! 377660restoreDefaultPaneColor 377661 "Useful when changing from monochrome to color display" 377662 377663 self setStripeColorsFrom: self paneColor.! ! 377664 377665!SystemWindow methodsFor: 'panes' stamp: 'RAA 1/10/2001 19:01'! 377666setUpdatablePanesFrom: getSelectors 377667 | aList aPane possibles | 377668 "Set my updatablePanes inst var to the list of panes which are list panes with the given get-list selectors. Order is important here!! Note that the method is robust in the face of panes not found, but a warning is printed in the transcript in each such case" 377669 377670 aList := OrderedCollection new. 377671 possibles := OrderedCollection new. 377672 self allMorphsDo: [ :pane | 377673 (pane isKindOf: PluggableListMorph) ifTrue: [ 377674 possibles add: pane. 377675 ]. 377676 ]. 377677 377678 getSelectors do: [:sel | 377679 aPane := possibles detect: [ :pane | pane getListSelector == sel] ifNone: [nil]. 377680 aPane 377681 ifNotNil: 377682 [aList add: aPane] 377683 ifNil: 377684 [Transcript cr; show: 'Warning: pane ', sel, ' not found.']]. 377685 updatablePanes := aList asArray! ! 377686 377687!SystemWindow methodsFor: 'panes' stamp: 'sw 12/21/1998 23:24'! 377688titleAndPaneText 377689 "If the receiver represents a workspace, return an Association between the title and that text, else return nil" 377690 (paneMorphs size ~~ 1 or: [(paneMorphs first isKindOf: PluggableTextMorph) not]) 377691 ifTrue: [^ nil]. 377692 ^ labelString -> paneMorphs first text 377693 377694! ! 377695 377696!SystemWindow methodsFor: 'panes' stamp: 'sw 10/19/1999 09:53'! 377697updatablePanes 377698 "Answer the list of panes, in order, which should be sent the #verifyContents message" 377699 ^ updatablePanes ifNil: [updatablePanes := #()]! ! 377700 377701!SystemWindow methodsFor: 'panes' stamp: 'md 2/24/2006 15:36'! 377702updatePaneColors 377703 "Useful when changing from monochrome to color display" 377704 377705 self setStripeColorsFrom: self paneColorToUse.! ! 377706 377707 377708!SystemWindow methodsFor: 'resize/collapse' stamp: 'ar 2/10/1999 04:19'! 377709collapse 377710 self isCollapsed ifFalse:[self collapseOrExpand]! ! 377711 377712!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 5/20/1998 08:25'! 377713collapsedFrame 377714 ^ collapsedFrame! ! 377715 377716!SystemWindow methodsFor: 'resize/collapse' stamp: 'gvc 5/13/2009 12:57'! 377717doFastWindowReframe: ptName 377718 377719 | newBounds | 377720 "For fast display, only higlight the rectangle during loop" 377721 newBounds := self bounds newRectButtonPressedDo: [:f | 377722 f 377723 withSideOrCorner: ptName 377724 setToPoint: (self pointFromWorld: Sensor cursorPoint) 377725 minExtent: self minimumExtent]. 377726 Display deferUpdatesIn: Display boundingBox while: [ 377727 self bounds: newBounds]. 377728 ^newBounds.! ! 377729 377730!SystemWindow methodsFor: 'resize/collapse' stamp: 'ar 2/10/1999 04:20'! 377731expand 377732 self isCollapsed ifTrue:[self collapseOrExpand]! ! 377733 377734!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/28/1999 13:21'! 377735fastFramingOn 377736 377737 ^ Preferences fastDragWindowForMorphic and: [self isFlexed not]! ! 377738 377739!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 5/20/1998 08:25'! 377740fullFrame 377741 ^ fullFrame! ! 377742 377743!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/28/1999 14:14'! 377744getBoundsWithFlex 377745 "Return the lastest bounds rectangle with origin forced to global coordinates" 377746 377747 self isFlexed 377748 ifTrue: [^ ((owner transform localPointToGlobal: bounds topLeft) 377749 extent: bounds extent)] 377750 ifFalse: [^ self bounds]. 377751! ! 377752 377753!SystemWindow methodsFor: 'resize/collapse' stamp: 'marcus.denker 11/30/2008 20:43'! 377754getCollapsedFrame 377755 377756 ^RealEstateAgent assignCollapseFrameFor: self.! ! 377757 377758!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 5/19/1998 09:34'! 377759isCollapsed 377760 ^ isCollapsed! ! 377761 377762!SystemWindow methodsFor: 'resize/collapse' stamp: 'jm 6/17/1998 11:55'! 377763mouseLeaveEvent: event fromPane: pane 377764 "For backward compatibility only. Not used by any newly created window" 377765 (pane isKindOf: ScrollPane) ifTrue: [pane mouseLeave: event]. 377766! ! 377767 377768!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/21/1998 16:12'! 377769paneWithLongestSide: sideBlock near: aPoint 377770 | thePane theSide theLen box | 377771 theLen := 0. 377772 paneMorphs do: 377773 [:pane | box := pane bounds. 377774 box forPoint: aPoint closestSideDistLen: 377775 [:side :dist :len | 377776 (dist <= 5 and: [len > theLen]) ifTrue: 377777 [thePane := pane. 377778 theSide := side. 377779 theLen := len]]]. 377780 sideBlock value: theSide. 377781 ^ thePane! ! 377782 377783!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/22/1998 22:55'! 377784reframePanesAdjoining: growingPane along: side to: aDisplayBox 377785 | delta newRect minDim theMin horiz | 377786 growingPane ifNil: [^ self]. "As from click outside" 377787 newRect := aDisplayBox. 377788 horiz := #(left right) includes: side. 377789 theMin := horiz ifTrue: [40] ifFalse: [20]. 377790 377791 "First check that this won't make any pane smaller than theMin screen dots" 377792 minDim := (((paneMorphs select: [:pane | pane bounds bordersOn: growingPane bounds along: side]) 377793 collect: [:pane | pane bounds adjustTo: newRect along: side]) copyWith: aDisplayBox) 377794 inject: 999 into: 377795 [:was :rect | was min: (horiz ifTrue: [rect width] ifFalse: [rect height])]. 377796 "If so, amend newRect as required" 377797 minDim > theMin ifFalse: 377798 [delta := minDim - theMin. 377799 newRect := newRect withSide: side setTo: 377800 ((newRect perform: side) > (growingPane bounds perform: side) 377801 ifTrue: [(newRect perform: side) + delta] 377802 ifFalse: [(newRect perform: side) - delta])]. 377803 377804 "Now adjust all adjoining panes for real" 377805 paneMorphs do: 377806 [:pane | (pane bounds bordersOn: growingPane bounds along: side) ifTrue: 377807 [pane bounds: (pane bounds adjustTo: newRect along: side)]]. 377808 "And adjust the growing pane itself" 377809 growingPane bounds: newRect. 377810 377811 "Finally force a recomposition of the whole window" 377812 self setPaneRectsFromBounds. 377813 self extent: self extent! ! 377814 377815!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/28/1999 14:15'! 377816setBoundsWithFlex: newFrame 377817 "Set bounds from newFrame with origin preserved from global coordinates" 377818 377819 self isFlexed 377820 ifTrue: [super bounds: ((owner transform globalPointToLocal: newFrame topLeft) 377821 extent: newFrame extent)] 377822 ifFalse: [super bounds: newFrame].! ! 377823 377824!SystemWindow methodsFor: 'resize/collapse' stamp: 'jlb 5/29/2001 23:06'! 377825unexpandedFrame 377826 "Return the frame size of an unexpanded window" 377827 377828 ^ self valueOfProperty: #unexpandedFrame! ! 377829 377830!SystemWindow methodsFor: 'resize/collapse' stamp: 'jlb 5/29/2001 23:07'! 377831unexpandedFrame: aRectangle 377832 "Set the frame size of an unexpanded window" 377833 377834 ^ self setProperty: #unexpandedFrame toValue: aRectangle! ! 377835 377836!SystemWindow methodsFor: 'resize/collapse' stamp: 'sw 5/30/2001 10:56'! 377837wantsExpandBox 377838 "Answer whether I'd like an expand box" 377839 377840 ^ true! ! 377841 377842 377843!SystemWindow methodsFor: 'stepping' stamp: 'sw 10/19/1999 09:30'! 377844amendSteppingStatus 377845 "Circumstances having changed, find out whether stepping is wanted and assure that the new policy is carried out" 377846 377847 self wantsSteps 377848 ifTrue: 377849 [self arrangeToStartStepping] 377850 ifFalse: 377851 [self stopStepping]! ! 377852 377853!SystemWindow methodsFor: 'stepping' stamp: 'di 4/9/2001 17:04'! 377854stepAt: millisecondClockValue 377855 "If the receiver is not collapsed, step it, after first stepping the model." 377856 377857 (isCollapsed not or: [self wantsStepsWhenCollapsed]) ifTrue: 377858 [model ifNotNil: [model stepAt: millisecondClockValue in: self]. 377859 super stepAt: millisecondClockValue "let player, if any, step"] 377860 377861"Since this method ends up calling step, the model-stepping logic should not be duplicated there."! ! 377862 377863!SystemWindow methodsFor: 'stepping' stamp: 'sw 10/19/1999 08:22'! 377864stepTime 377865 ^ model 377866 ifNotNil: 377867 [model stepTimeIn: self] 377868 ifNil: 377869 [200] "milliseconds"! ! 377870 377871!SystemWindow methodsFor: 'stepping' stamp: 'stephane.ducasse 11/8/2008 14:55'! 377872wantsSteps 377873 "Return true if the model wants its view to be stepped. For an open system window, we give the model to offer an opinion" 377874 377875 self isPartsDonor ifTrue: [^ false]. 377876 ^ isCollapsed not and: [model wantsStepsIn: self]! ! 377877 377878!SystemWindow methodsFor: 'stepping' stamp: 'di 4/9/2001 16:45'! 377879wantsStepsWhenCollapsed 377880 "Default is not to bother updating collapsed windows" 377881 377882 ^ false! ! 377883 377884 377885!SystemWindow methodsFor: 'testing' stamp: 'jam 3/9/2003 15:13'! 377886isSystemWindow 377887"answer whatever the receiver is a SystemWindow" 377888 ^ true! ! 377889 377890!SystemWindow methodsFor: 'testing' stamp: 'ar 12/2/2001 21:43'! 377891shouldDropOnMouseUp 377892 "Return true for consistency with fastdrag" 377893 ^true! ! 377894 377895!SystemWindow methodsFor: 'testing' stamp: 'NikoSchwarz 10/17/2009 11:27'! 377896wantsToBeCachedByHand 377897 "Return true if the receiver wants to be cached by the hand when it is dragged around." 377898 self hasTranslucentColor ifTrue:[^false]. 377899 self clipSubmorphs ifTrue: [^true]. 377900 self bounds = self fullBounds ifTrue:[^true]. 377901 self submorphsDo:[:m| 377902 (self bounds containsRect: m fullBounds) ifFalse:[ 377903 m wantsToBeCachedByHand ifFalse:[^false]. 377904 ]. 377905 ]. 377906 ^true! ! 377907 377908 377909!SystemWindow methodsFor: 'thumbnail' stamp: 'dgd 9/22/2004 19:29'! 377910icon 377911 "Answer a form with an icon to represent the receiver" 377912 ^ MenuIcons windowIcon! ! 377913 377914 377915!SystemWindow methodsFor: 'top window' stamp: 'sw 5/10/1999 15:42'! 377916activateAndForceLabelToShow 377917 self activate. 377918 bounds top < 0 ifTrue: 377919 [self position: (self position x @ 0)]! ! 377920 377921!SystemWindow methodsFor: 'top window' stamp: 'di 5/14/1998 11:49'! 377922activeOnlyOnTop 377923 ^ activeOnlyOnTop ifNil: [false]! ! 377924 377925!SystemWindow methodsFor: 'top window' stamp: 'di 5/14/1998 12:38'! 377926activeOnlyOnTop: trueOrFalse 377927 activeOnlyOnTop := trueOrFalse! ! 377928 377929!SystemWindow methodsFor: 'top window' stamp: 'sw 5/20/2001 22:32'! 377930adjustBorderUponActivationWhenLabeless 377931 "Adjust the border upon, um, activation when, um, labelless" 377932 377933 | aWidth | 377934 (aWidth := self valueOfProperty: #borderWidthWhenActive) ifNotNil: 377935 [self acquireBorderWidth: aWidth]! ! 377936 377937!SystemWindow methodsFor: 'top window' stamp: 'sw 5/20/2001 22:32'! 377938adjustBorderUponDeactivationWhenLabeless 377939 "Adjust the border upon deactivation when, labelless" 377940 377941 | aWidth | 377942 (aWidth := self valueOfProperty: #borderWidthWhenInactive) ifNotNil: 377943 [self acquireBorderWidth: aWidth]! ! 377944 377945!SystemWindow methodsFor: 'top window' stamp: 'LC 9/28/1999 19:04'! 377946extantSketchEditor 377947 "If my world has an extant SketchEditorMorph associated with anything 377948 in this window, return that SketchEditor, else return nil" 377949 | w sketchEditor pasteUp | 377950 (w := self world) isNil ifTrue: [^ nil]. 377951 (sketchEditor := w sketchEditorOrNil) isNil ifTrue: [^ nil]. 377952 (pasteUp := sketchEditor enclosingPasteUpMorph) isNil ifTrue: [^ nil]. 377953 self findDeepSubmorphThat: [:m | m = pasteUp] 377954 ifAbsent: [^ nil]. 377955 ^ sketchEditor! ! 377956 377957!SystemWindow methodsFor: 'top window' stamp: 'nk 8/6/2003 10:53'! 377958updatePanesFromSubmorphs 377959 "Having removed some submorphs, make sure this is reflected in my paneMorphs." 377960 paneMorphs := paneMorphs select: [ :pane | submorphs includes: pane ].! ! 377961 377962"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 377963 377964SystemWindow class 377965 instanceVariableNames: ''! 377966 377967!SystemWindow class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/15/2007 10:24'! 377968resetForms 377969 "Set the box forms to nil so that they will be taken from the current theme. 377970 Don't touch the expand or menu ones, delegated to theme anyway." 377971 377972 CloseBoxImage := nil. 377973 CollapseBoxImage := nil! ! 377974 377975!SystemWindow class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/17/2007 18:03'! 377976taskbarIcon 377977 "Answer the icon for the receiver in a task bar." 377978 377979 ^MenuIcons smallWindowIcon! ! 377980 377981 377982!SystemWindow class methodsFor: '*services-base' stamp: 'rr 3/10/2006 14:19'! 377983topWindow 377984 ^ TopWindow! ! 377985 377986 377987!SystemWindow class methodsFor: 'initializing' stamp: 'jrp 8/7/2005 17:09'! 377988borderWidth 377989 377990 "Making changes to this for some reason requires repositioning of CornerGripMorphs. 377991 Edit BorderedMorph#addCornerGrip and play with offsets to get them right if you increase 377992 border width. For instance, going from 4 to 6 here and you should updated offsets to 377993 (-23@-23 corner: 0@0) for the right placement of corner grips." 377994 377995 ^ 4! ! 377996 377997!SystemWindow class methodsFor: 'initializing' stamp: 'RAA 12/21/2000 12:01'! 377998classVersion 377999 "Changed to 1 for SystemWindow Dec 2000 - see if this helps loading old ones" 378000 ^ 1! ! 378001 378002!SystemWindow class methodsFor: 'initializing' stamp: 'jrp 7/30/2005 22:51'! 378003closeBoxImage 378004 "Supplied here because we don't necessarily have ComicBold" 378005 378006 ^ CloseBoxImage ifNil: [CloseBoxImage := (Form 378007 extent: 10@10 378008 depth: 32 378009 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 3326099520 3330310272 0 0 0 0 0 0 0 0 4144038145 3326099520 3330310272 0 0 0 4144038145 3326099520 0 0 0 4227924225 3326099520 3330310272 0 4144038145 3326099520 3330310272 0 0 0 0 4144038145 3326099520 4144038145 3326099520 3330310272 3336494814 0 0 0 0 0 4227924225 3326099520 3330310272 3336494814 0 0 0 0 0 4144038145 3326099520 4144038145 3326099520 3330310272 3336494814 0 0 0 4144038145 3326099520 3330310272 3336494814 4144038145 3326099520 3330310272 0 0 4144038145 3326099520 3330310272 3336494814 0 0 4144038145 3326099520 0 0 0 3330310272 3336494814 0 0 0 0 0 0) 378010 offset: 0@0)]! ! 378011 378012!SystemWindow class methodsFor: 'initializing' stamp: 'jrp 7/31/2005 13:21'! 378013collapseBoxImage 378014 "Supplied here because we don't necessarily have ComicBold" 378015 378016 ^ CollapseBoxImage ifNil: [ CollapseBoxImage := (Form 378017 extent: 10@10 378018 depth: 32 378019 fromArray: #( 0 0 4127260929 4127260929 4127260929 4127260929 4127260929 0 0 0 0 3875602689 3212869760 3212869760 3212869760 3212869760 3212869760 4227924225 0 0 4127260929 3212869760 3212869760 0 0 0 0 3212869760 4127260929 0 4127260929 3212869760 0 0 0 0 0 0 4127260929 3212869760 4127260929 3212869760 0 0 0 0 0 0 4127260929 3212869760 4127260929 3212869760 0 0 0 0 0 0 4127260929 3212869760 4128708375 3212869760 0 0 0 0 0 0 4127260929 3212869760 0 4127260929 3212869760 0 0 0 0 4127260929 3208659008 3212869760 0 3208659008 4127260929 4127260929 4127260929 4127260929 4127260929 3208659008 3212869760 0 0 0 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 0 0) 378020 offset: 0@0)]! ! 378021 378022!SystemWindow class methodsFor: 'initializing' stamp: 'jrp 7/31/2005 12:30'! 378023expandBoxImage 378024 378025 ^ (Form 378026 extent: 10@10 378027 depth: 32 378028 fromArray: #( 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 0 0 0 0 3875602689 0 0 0 0 4127260929 3877181721 3877181721 3875602689 0 3875602689 0 0 0 0 3875602689 3212869760 0 3875602689 3212869760 3875602689 0 0 0 0 3875602689 3212869760 0 3875602689 3212869760 3875602689 0 0 0 0 3875602689 3212869760 0 3875602689 3212869760 3875602689 4127260929 3875602689 3875602689 3875602689 3875602689 3212869760 0 3875602689 3212869760 0 3877181721 3212869760 3212869760 3212869760 3212869760 3212869760 0 3875602689 3212869760 0 3877181721 0 0 0 0 0 0 3875602689 3212869760 0 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 3212869760 0 0 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760) 378029 offset: 0@0)! ! 378030 378031!SystemWindow class methodsFor: 'initializing' stamp: 'jrp 8/9/2005 19:22'! 378032initialize 378033 378034 CollapseBoxImage := nil. 378035 CloseBoxImage := nil. 378036 ScriptingSystem saveForm: self expandBoxImage atKey: 'expandBox'. 378037 ScriptingSystem saveForm: self menuBoxImage atKey: 'TinyMenu'! ! 378038 378039!SystemWindow class methodsFor: 'initializing' stamp: 'jrp 7/31/2005 13:28'! 378040menuBoxImage 378041 378042 ^ (Form 378043 extent: 10@10 378044 depth: 32 378045 fromArray: #( 4227858432 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4227858432 0 4127195136 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4227858432 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4227858432 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4227858432 3212869760 0 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760) 378046 offset: 0@0)! ! 378047 378048 378049!SystemWindow class methodsFor: 'instance creation' stamp: 'di 6/18/97 05:31'! 378050labelled: labelString 378051 ^ (self basicNew setLabel: labelString) initialize! ! 378052 378053 378054!SystemWindow class methodsFor: 'new-morph participation' stamp: 'di 2/3/98 11:54'! 378055includeInNewMorphMenu 378056 "Include my subclasses but not me" 378057 ^ self ~~ SystemWindow! ! 378058 378059 378060!SystemWindow class methodsFor: 'top window' stamp: 'sw 12/6/2000 20:13'! 378061closeTopWindow 378062 "Try to close the top window. It may of course decline" 378063 378064 TopWindow ifNotNil: 378065 [TopWindow delete]! ! 378066 378067!SystemWindow class methodsFor: 'top window' stamp: 'gm 2/16/2003 20:55'! 378068noteTopWindowIn: aWorld 378069 | newTop | 378070 "TopWindow must be nil or point to the top window in this project." 378071 TopWindow := nil. 378072 aWorld ifNil: [^ self]. 378073 newTop := nil. 378074 aWorld submorphsDo: 378075 [:m | (m isSystemWindow) ifTrue: 378076 [(newTop == nil and: [m activeOnlyOnTop]) 378077 ifTrue: [newTop := m]. 378078 (m model isKindOf: Project) 378079 ifTrue: ["This really belongs in a special ProjWindow class" 378080 m label ~= m model name ifTrue: [m setLabel: m model name]]]]. 378081 newTop == nil ifFalse: [newTop activate]! ! 378082 378083!SystemWindow class methodsFor: 'top window' stamp: 'sw 12/6/2000 19:43'! 378084sendTopWindowToBack 378085 "Send the top window of the world to the back, activating the one just beneath it" 378086 378087 TopWindow ifNotNil: 378088 [TopWindow sendToBack]! ! 378089 378090!SystemWindow class methodsFor: 'top window' stamp: 'sw 1/4/2000 15:22'! 378091wakeUpTopWindowUponStartup 378092 TopWindow ifNotNil: 378093 [TopWindow isCollapsed ifFalse: 378094 [TopWindow model ifNotNil: 378095 [TopWindow model modelWakeUpIn: TopWindow]]]! ! 378096 378097!SystemWindow class methodsFor: 'top window' stamp: 'gm 2/16/2003 20:55'! 378098windowsIn: aWorld satisfying: windowBlock 378099 | windows s | 378100 378101 windows := OrderedCollection new. 378102 aWorld ifNil: [^windows]. "opening MVC in Morphic - WOW!!" 378103 aWorld submorphs do: 378104 [:m | 378105 ((m isSystemWindow) and: [windowBlock value: m]) 378106 ifTrue: [windows addLast: m] 378107 ifFalse: [((m isKindOf: TransformationMorph) and: [m submorphs size = 1]) 378108 ifTrue: [s := m firstSubmorph. 378109 ((s isSystemWindow) and: [windowBlock value: s]) 378110 ifTrue: [windows addLast: s]]]]. 378111 ^ windows! ! 378112SystemWindow subclass: #SystemWindowWithButton 378113 instanceVariableNames: 'buttonInTitle' 378114 classVariableNames: '' 378115 poolDictionaries: '' 378116 category: 'Morphic-Windows'! 378117!SystemWindowWithButton commentStamp: '<historical>' prior: 0! 378118A SystemWindow with a single extra button in its title bar.! 378119 378120 378121!SystemWindowWithButton methodsFor: 'as yet unclassified' stamp: 'wiz 2/14/2006 02:07'! 378122adjustExtraButton 378123 buttonInTitle ifNil: [^ self]. 378124 buttonInTitle align: buttonInTitle topLeft with: self innerBounds topRight - (buttonInTitle width + 20 @ -3)! ! 378125 378126!SystemWindowWithButton methodsFor: 'as yet unclassified' stamp: 'sw 2/15/1999 22:41'! 378127buttonInTitle: aButton 378128 buttonInTitle := aButton. 378129 self addMorphFront: aButton! ! 378130 378131 378132!SystemWindowWithButton methodsFor: 'geometry' stamp: 'sw 9/29/1999 07:26'! 378133extent: newExtent 378134 super extent: (newExtent max: 120 @ 50). 378135 self adjustExtraButton! ! 378136 378137 378138!SystemWindowWithButton methodsFor: 'label' stamp: 'sw 9/29/1999 07:27'! 378139setLabelWidgetAllowance 378140 ^ labelWidgetAllowance := 115! ! 378141 378142 378143!SystemWindowWithButton methodsFor: 'resize/collapse' stamp: 'sw 5/30/2001 11:11'! 378144wantsExpandBox 378145 "Answer whether I'd like an expand box" 378146 378147 ^ false! ! 378148Trait named: #TAddForIdentityCollectionsTest 378149 uses: {} 378150 category: 'CollectionsTests-Abstract'! 378151 378152!TAddForIdentityCollectionsTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:00'! 378153identityCollectionWithElementsCopyNotIdentical 378154 "Returns a collection including elements for which #copy doesn't return the same object." 378155 ^ self explicitRequirement! ! 378156 378157 378158!TAddForIdentityCollectionsTest methodsFor: 'tests - adding for identity collections' stamp: 'delaunay 5/13/2009 14:01'! 378159testTAddIfNotPresentWithElementCopy 378160" test specific to IdentityCollections for wich #addIfNotPresent should use == check insted of =." 378161 | added oldSize collection element elementCopy | 378162 collection := self identityCollectionWithElementsCopyNotIdentical . 378163 oldSize := collection size. 378164 378165 element := collection anyOne . 378166 elementCopy := element copy. 378167 self deny: (collection includes: elementCopy ). 378168 378169 added := collection addIfNotPresent: elementCopy . 378170 self assert: added == elementCopy . "test for identiy because #add: has not reason to copy its parameter." 378171 self assert: (collection size = (oldSize + 1)). 378172 378173 ! ! 378174 378175 378176!TAddForIdentityCollectionsTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/13/2009 14:01'! 378177test0FixtureAddForIdentityCollectionsTest 378178 378179 self shouldnt: [ self identityCollectionWithElementsCopyNotIdentical ] raise: Error. 378180 self identityCollectionWithElementsCopyNotIdentical do: [ : each | self deny: each == each copy ].! ! 378181 378182"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 378183 378184TAddForIdentityCollectionsTest classTrait 378185 uses: {}! 378186Trait named: #TAddForUniquenessTest 378187 uses: {} 378188 category: 'CollectionsTests-Abstract'! 378189 378190!TAddForUniquenessTest methodsFor: 'requirements' stamp: 'delaunay 5/12/2009 15:12'! 378191collectionWithElement 378192" return a collection already including 'element' " 378193 ^ self explicitRequirement! ! 378194 378195!TAddForUniquenessTest methodsFor: 'requirements' stamp: 'delaunay 5/12/2009 15:18'! 378196collectionWithoutElement 378197 " return a collection that does not include 'element' " 378198 ^ self explicitRequirement! ! 378199 378200!TAddForUniquenessTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/8/2008 15:40'! 378201element 378202 ^ self explicitRequirement! ! 378203 378204 378205!TAddForUniquenessTest methodsFor: 'tests - adding uniquely' stamp: 'stephane.ducasse 10/8/2008 15:31'! 378206testAddAlreadyThereDoesNotCount 378207 378208 | added oldSize | 378209 oldSize := self collectionWithElement size. 378210 self assert: (self collectionWithElement includes: self element). 378211 378212 added := self collectionWithElement add: self element. 378213 378214 self assert: added = self element. 378215 self assert: (self collectionWithElement includes: self element). 378216 self assert: self collectionWithElement size = oldSize.! ! 378217 378218!TAddForUniquenessTest methodsFor: 'tests - adding uniquely' stamp: 'delaunay 5/12/2009 15:18'! 378219testAddNewElementIncrementsSize 378220 | added oldSize | 378221 oldSize := self collectionWithoutElement size. 378222 self deny: (self collectionWithoutElement includes: self element). 378223 added := self collectionWithoutElement add: self element. 378224 self assert: added = self element. 378225 self assert: (self collectionWithoutElement includes: self element). 378226 self assert: self collectionWithoutElement size = (oldSize + 1)! ! 378227 378228!TAddForUniquenessTest methodsFor: 'tests - adding uniquely' stamp: 'stephane.ducasse 10/8/2008 16:33'! 378229testTAddIfNotPresentWithElementAlreadyIn 378230 378231 | added oldSize | 378232 oldSize := self collectionWithElement size. 378233 self assert: (self collectionWithElement includes: self element). 378234 378235 added := self collectionWithElement addIfNotPresent: self element. 378236 378237 self assert: added = self element. 378238 self assert: (self collectionWithElement includes: self element). 378239 self assert: self collectionWithElement size = oldSize.! ! 378240 378241!TAddForUniquenessTest methodsFor: 'tests - adding uniquely' stamp: 'delaunay 5/12/2009 15:18'! 378242testTAddIfNotPresentWithNewElement 378243 | added oldSize | 378244 oldSize := self collectionWithoutElement size. 378245 self deny: (self collectionWithoutElement includes: self element). 378246 added := self collectionWithoutElement addIfNotPresent: self element. 378247 self assert: added = self element. 378248 self assert: (self collectionWithoutElement includes: self element). 378249 self assert: self collectionWithoutElement size = (oldSize + 1)! ! 378250 378251 378252!TAddForUniquenessTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/12/2009 15:19'! 378253test0FixtureAddForUniquenessTest 378254 378255 self shouldnt: [ self element ] raise: Error. 378256 self shouldnt: [ self collectionWithElement ]raise: Error. 378257 self assert: (self collectionWithElement includes: self element). 378258 self shouldnt: [ self collectionWithoutElement ]raise: Error. 378259 self deny: (self collectionWithoutElement includes: self element)! ! 378260 378261"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 378262 378263TAddForUniquenessTest classTrait 378264 uses: {}! 378265Trait named: #TAddTest 378266 uses: {} 378267 category: 'CollectionsTests-Abstract'! 378268 378269!TAddTest methodsFor: 'requirements' stamp: 'damiencassou 1/20/2009 13:32'! 378270collectionWithElement 378271 "Returns a collection that already includes what is returned by #element." 378272 ^ self explicitRequirement! ! 378273 378274!TAddTest methodsFor: 'requirements' stamp: 'damiencassou 1/14/2009 10:29'! 378275element 378276 "Returns an object that can be added to the collection returned by #collection." 378277 ^ self explicitRequirement! ! 378278 378279!TAddTest methodsFor: 'requirements' stamp: 'damiencassou 1/14/2009 10:29'! 378280otherCollection 378281 "Returns a collection that does not include what is returned by #element." 378282 ^ self explicitRequirement! ! 378283 378284 378285!TAddTest methodsFor: 'tests - adding' stamp: 'delaunay 5/4/2009 10:17'! 378286testTAdd 378287 | added collection | 378288 collection :=self otherCollection . 378289 added := collection add: self element. 378290 378291 self assert: added == self element. "test for identiy because #add: has not reason to copy its parameter." 378292 self assert: (collection includes: self element) . 378293 self assert: (self collectionWithElement includes: self element). 378294 378295 ! ! 378296 378297!TAddTest methodsFor: 'tests - adding' stamp: 'delaunay 4/21/2009 15:27'! 378298testTAddAll 378299 | added collection toBeAdded | 378300 collection := self collectionWithElement . 378301 toBeAdded := self otherCollection . 378302 added := collection addAll: toBeAdded . 378303 self assert: added == toBeAdded . "test for identiy because #addAll: has not reason to copy its parameter." 378304 self assert: (collection includesAllOf: toBeAdded )! ! 378305 378306!TAddTest methodsFor: 'tests - adding' stamp: 'delaunay 4/21/2009 15:29'! 378307testTAddIfNotPresentWithElementAlreadyIn 378308 378309 | added oldSize collection element | 378310 collection := self collectionWithElement . 378311 oldSize := collection size. 378312 element := self element . 378313 self assert: (collection includes: element ). 378314 378315 added := collection addIfNotPresent: element . 378316 378317 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 378318 self assert: collection size = oldSize! ! 378319 378320!TAddTest methodsFor: 'tests - adding' stamp: 'delaunay 4/21/2009 15:32'! 378321testTAddIfNotPresentWithNewElement 378322 378323 | added oldSize collection element | 378324 collection := self otherCollection . 378325 oldSize := collection size. 378326 element := self element . 378327 self deny: (collection includes: element ). 378328 378329 added := collection addIfNotPresent: element . 378330 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 378331 self assert: (collection size = (oldSize + 1)). 378332 378333 ! ! 378334 378335!TAddTest methodsFor: 'tests - adding' stamp: 'delaunay 4/21/2009 15:38'! 378336testTAddTwice 378337 | added oldSize collection element | 378338 collection := self collectionWithElement . 378339 element := self element . 378340 oldSize := collection size. 378341 added := collection 378342 add: element ; 378343 add: element . 378344 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 378345 self assert: (collection includes: element ). 378346 self assert: collection size = (oldSize + 2)! ! 378347 378348!TAddTest methodsFor: 'tests - adding' stamp: 'delaunay 4/21/2009 15:35'! 378349testTAddWithOccurences 378350 | added oldSize collection element | 378351 collection := self collectionWithElement . 378352 element := self element . 378353 oldSize := collection size. 378354 added := collection add: element withOccurrences: 5. 378355 378356 self assert: added == element. "test for identiy because #add: has not reason to copy its parameter." 378357 self assert: (collection includes: element). 378358 self assert: collection size = (oldSize + 5)! ! 378359 378360!TAddTest methodsFor: 'tests - adding' stamp: 'delaunay 4/21/2009 15:38'! 378361testTWrite 378362 | added collection element | 378363 collection := self otherCollection . 378364 element := self element . 378365 added := collection write: element . 378366 378367 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 378368 self assert: (collection includes: element ) . 378369 self assert: (collection includes: element ). 378370 378371 ! ! 378372 378373!TAddTest methodsFor: 'tests - adding' stamp: 'delaunay 4/21/2009 15:39'! 378374testTWriteTwice 378375 | added oldSize collection element | 378376 collection := self collectionWithElement . 378377 element := self element . 378378 oldSize := collection size. 378379 added := collection 378380 write: element ; 378381 write: element . 378382 self assert: added == element . "test for identiy because #add: has not reason to copy its parameter." 378383 self assert: (collection includes: element ). 378384 self assert: collection size = (oldSize + 2)! ! 378385 378386 378387!TAddTest methodsFor: 'tests - fixture' stamp: 'damiencassou 1/20/2009 13:32'! 378388test0FixtureRequirementsOfTAddTest 378389 self 378390 shouldnt: [ self collectionWithElement ] 378391 raise: Exception. 378392 self 378393 shouldnt: [ self otherCollection ] 378394 raise: Exception. 378395 self 378396 shouldnt: [ self element ] 378397 raise: Exception. 378398 self assert: (self collectionWithElement includes: self element). 378399 self deny: (self otherCollection includes: self element)! ! 378400 378401"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 378402 378403TAddTest classTrait 378404 uses: {}! 378405Trait named: #TApplyingOnClassSide 378406 uses: {} 378407 category: 'Traits-Kernel-Traits'! 378408 378409!TApplyingOnClassSide methodsFor: 'composition' stamp: 'al 7/30/2004 09:07'! 378410assertConsistantCompositionsForNew: aTraitComposition 378411 "Applying or modifying a trait composition on the class side 378412 of a behavior has some restrictions." 378413 378414 | baseTraits notAddable message | 378415 baseTraits := aTraitComposition traits select: [:each | each isBaseTrait]. 378416 baseTraits isEmpty ifFalse: [ 378417 notAddable := (baseTraits reject: [:each | each classSide methodDict isEmpty]). 378418 notAddable isEmpty ifFalse: [ 378419 message := String streamContents: [:stream | 378420 stream nextPutAll: 'You can not add the base trait(s)'; cr. 378421 notAddable 378422 do: [:each | stream nextPutAll: each name] 378423 separatedBy: [ stream nextPutAll: ', ']. 378424 stream cr; nextPutAll: 'to this composition because it/they define(s) methods on the class side.']. 378425 ^TraitCompositionException signal: message]]. 378426 378427 (self instanceSide traitComposition traits asSet = 378428 (aTraitComposition traits 378429 select: [:each | each isClassTrait] 378430 thenCollect: [:each | each baseTrait]) asSet) ifFalse: [ 378431 ^TraitCompositionException signal: 'You can not add or remove class side traits on 378432 the class side of a composition. (But you can specify aliases or exclusions 378433 for existing traits or add a trait which does not have any methods on the class side.)']! ! 378434 378435!TApplyingOnClassSide methodsFor: 'composition' stamp: 'apb 8/24/2005 14:15'! 378436noteNewBaseTraitCompositionApplied: aTraitComposition 378437 "The argument is the new trait composition of my base trait - add 378438 the new traits or remove non existing traits on my class side composition. 378439 (Each class trait in my composition has its base trait on the instance side 378440 of the composition - manually added traits to the class side are always 378441 base traits.)" 378442 378443 | newComposition traitsFromInstanceSide | 378444 traitsFromInstanceSide := self traitComposition traits 378445 select: [:each | each isClassTrait] 378446 thenCollect: [:each | each baseTrait]. 378447 378448 newComposition := self traitComposition copyTraitExpression. 378449 (traitsFromInstanceSide copyWithoutAll: aTraitComposition traits) do: [:each | 378450 newComposition removeFromComposition: each classTrait]. 378451 (aTraitComposition traits copyWithoutAll: traitsFromInstanceSide) do: [:each | 378452 newComposition add: (each classTrait)]. 378453 378454 self setTraitComposition: newComposition! ! 378455 378456"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 378457 378458TApplyingOnClassSide classTrait 378459 uses: {}! 378460Trait named: #TAsStringCommaAndDelimiterSequenceableTest 378461 uses: TAsStringCommaAndDelimiterTest 378462 category: 'CollectionsTests-Abstract'! 378463 378464!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'requirements' stamp: 'stephane.ducasse 1/19/2009 16:17'! 378465empty 378466 378467 ^ self explicitRequirement ! ! 378468 378469!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'requirements' stamp: 'delaunay 4/8/2009 11:03'! 378470nonEmpty 378471 378472 ^ self explicitRequirement ! ! 378473 378474!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:56'! 378475nonEmpty1Element 378476" return a collection of size 1 including one element" 378477 ^ self explicitRequirement ! ! 378478 378479 378480!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: 'delaunay 4/8/2009 11:04'! 378481testAsCommaStringEmpty 378482 378483 self assert: self empty asCommaString = ''. 378484 self assert: self empty asCommaStringAnd = ''. 378485 378486 378487! ! 378488 378489!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: 'delaunay 4/23/2009 14:41'! 378490testAsCommaStringMore 378491 378492 "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. 378493 self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' 378494" 378495 378496 | result resultAnd index allElementsAsString | 378497 result:= self nonEmpty asCommaString . 378498 resultAnd:= self nonEmpty asCommaStringAnd . 378499 378500 index := 1. 378501 (result findBetweenSubStrs: ',' )do: 378502 [:each | 378503 index = 1 378504 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] 378505 ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. 378506 index:=index+1 378507 ]. 378508 378509 "verifying esultAnd :" 378510 allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 378511 1 to: allElementsAsString size do: 378512 [:i | 378513 i<(allElementsAsString size ) 378514 ifTrue: [ 378515 i = 1 378516 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] 378517 ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] 378518 ]. 378519 i=(allElementsAsString size) 378520 ifTrue:[ 378521 i = 1 378522 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 378523 ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] 378524 ]. 378525 378526 378527 ].! ! 378528 378529!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: 'delaunay 4/8/2009 11:38'! 378530testAsCommaStringOne 378531 378532 "self assert: self oneItemCol asCommaString = '1'. 378533 self assert: self oneItemCol asCommaStringAnd = '1'." 378534 378535 self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). 378536 self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). 378537 ! ! 378538 378539!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: 'stephane.ducasse 1/16/2009 10:23'! 378540testAsStringOnDelimiterEmpty 378541 378542 | delim emptyStream | 378543 delim := ', '. 378544 emptyStream := ReadWriteStream on: ''. 378545 self empty asStringOn: emptyStream delimiter: delim. 378546 self assert: emptyStream contents = ''. 378547! ! 378548 378549!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: 'delaunay 4/9/2009 09:43'! 378550testAsStringOnDelimiterLastEmpty 378551 378552 | delim emptyStream | 378553 delim := ', '. 378554 emptyStream := ReadWriteStream on: ''. 378555 self empty asStringOn: emptyStream delimiter: delim last:'and'. 378556 self assert: emptyStream contents = ''. 378557! ! 378558 378559!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: 'delaunay 4/9/2009 09:39'! 378560testAsStringOnDelimiterLastMore 378561 378562 | delim multiItemStream result last allElementsAsString | 378563 378564 delim := ', '. 378565 last := 'and'. 378566 result:=''. 378567 multiItemStream := ReadWriteStream on:result. 378568 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 378569 378570 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 378571 1 to: allElementsAsString size do: 378572 [:i | 378573 i<(allElementsAsString size-1 ) 378574 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 378575 i=(allElementsAsString size-1) 378576 ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. 378577 i=(allElementsAsString size) 378578 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 378579 ]. 378580 378581! ! 378582 378583!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: 'delaunay 4/9/2009 09:43'! 378584testAsStringOnDelimiterLastOne 378585 378586 | delim oneItemStream result | 378587 378588 delim := ', '. 378589 result:=''. 378590 oneItemStream := ReadWriteStream on: result. 378591 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 378592 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 378593 378594 378595 ! ! 378596 378597!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: 'delaunay 4/8/2009 11:53'! 378598testAsStringOnDelimiterMore 378599 378600 | delim multiItemStream result index | 378601 "delim := ', '. 378602 multiItemStream := '' readWrite. 378603 self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. 378604 self assert: multiItemStream contents = '1, 2, 3'." 378605 378606 delim := ', '. 378607 result:=''. 378608 multiItemStream := ReadWriteStream on:result. 378609 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 378610 378611 index:=1. 378612 (result findBetweenSubStrs: ', ' )do: 378613 [:each | 378614 self assert: each= ((self nonEmpty at:index)asString). 378615 index:=index+1 378616 ].! ! 378617 378618!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - comma and delimiter' stamp: 'delaunay 4/8/2009 14:43'! 378619testAsStringOnDelimiterOne 378620 378621 | delim oneItemStream result | 378622 "delim := ', '. 378623 oneItemStream := '' readWrite. 378624 self oneItemCol asStringOn: oneItemStream delimiter: delim. 378625 self assert: oneItemStream contents = '1'." 378626 378627 delim := ', '. 378628 result:=''. 378629 oneItemStream := ReadWriteStream on: result. 378630 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 378631 oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. 378632 378633 378634 ! ! 378635 378636 378637!TAsStringCommaAndDelimiterSequenceableTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/8/2009 11:36'! 378638test0FixtureAsStringCommaAndDelimiterTest 378639 378640 self shouldnt: [self nonEmpty] raise:Error . 378641 self deny: self nonEmpty isEmpty. 378642 378643 self shouldnt: [self empty] raise:Error . 378644 self assert: self empty isEmpty. 378645 378646 self shouldnt: [self nonEmpty1Element ] raise:Error . 378647 self assert: self nonEmpty1Element size=1.! ! 378648 378649"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 378650 378651TAsStringCommaAndDelimiterSequenceableTest classTrait 378652 uses: TAsStringCommaAndDelimiterTest classTrait! 378653Trait named: #TAsStringCommaAndDelimiterTest 378654 uses: {} 378655 category: 'CollectionsTests-Abstract'! 378656 378657!TAsStringCommaAndDelimiterTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 09:57'! 378658empty 378659 378660 ^ self explicitRequirement ! ! 378661 378662!TAsStringCommaAndDelimiterTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 09:57'! 378663nonEmpty 378664 378665 ^ self explicitRequirement ! ! 378666 378667!TAsStringCommaAndDelimiterTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 09:57'! 378668nonEmpty1Element 378669" return a collection of size 1 including one element" 378670 ^ self explicitRequirement ! ! 378671 378672 378673!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: 'delaunay 4/14/2009 14:41'! 378674testAsCommaStringEmpty 378675 378676 self assert: self empty asCommaString = ''. 378677 self assert: self empty asCommaStringAnd = ''. 378678 378679! ! 378680 378681!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: 'delaunay 4/30/2009 12:00'! 378682testAsCommaStringMore 378683 378684 | result resultAnd index allElementsAsString tmp | 378685 result:= self nonEmpty asCommaString . 378686 resultAnd:= self nonEmpty asCommaStringAnd . 378687 tmp :=OrderedCollection new. 378688 self nonEmpty do: [ :each | tmp add: each asString]. 378689 378690 "verifying result :" 378691 index := 1. 378692 allElementsAsString := (result findBetweenSubStrs: ', ' ). 378693 allElementsAsString do: 378694 [:each | 378695 self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). 378696 ]. 378697 378698 "verifying esultAnd :" 378699 allElementsAsString:=(resultAnd findBetweenSubStrs: ', ' ). 378700 1 to: allElementsAsString size do: 378701 [:i | 378702 i<(allElementsAsString size-1 ) | i= allElementsAsString size 378703 ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. 378704 i=(allElementsAsString size-1) 378705 ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. 378706 ].! ! 378707 378708!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: 'delaunay 4/14/2009 14:59'! 378709testAsCommaStringOne 378710 378711 self nonEmpty1Element do: 378712 [:each | 378713 self assert: each asString =self nonEmpty1Element asCommaString. 378714 self assert: each asString=self nonEmpty1Element asCommaStringAnd.]. 378715 378716 ! ! 378717 378718!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: 'delaunay 4/14/2009 14:42'! 378719testAsStringOnDelimiterEmpty 378720 378721 | delim emptyStream | 378722 delim := ', '. 378723 emptyStream := ReadWriteStream on: ''. 378724 self empty asStringOn: emptyStream delimiter: delim. 378725 self assert: emptyStream contents = ''. 378726! ! 378727 378728!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: 'delaunay 4/14/2009 14:42'! 378729testAsStringOnDelimiterLastEmpty 378730 378731 | delim emptyStream | 378732 delim := ', '. 378733 emptyStream := ReadWriteStream on: ''. 378734 self empty asStringOn: emptyStream delimiter: delim last:'and'. 378735 self assert: emptyStream contents = ''. 378736! ! 378737 378738!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: 'delaunay 4/14/2009 15:16'! 378739testAsStringOnDelimiterLastMore 378740 378741 | delim multiItemStream result last allElementsAsString tmp | 378742 378743 delim := ', '. 378744 last := 'and'. 378745 result:=''. 378746 tmp := self nonEmpty collect: [:each | each asString]. 378747 multiItemStream := ReadWriteStream on:result. 378748 self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. 378749 378750 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 378751 1 to: allElementsAsString size do: 378752 [:i | 378753 i<(allElementsAsString size-1 ) | i= allElementsAsString size 378754 ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. 378755 i=(allElementsAsString size-1) 378756 ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. 378757 ]. 378758! ! 378759 378760!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: 'delaunay 4/14/2009 15:09'! 378761testAsStringOnDelimiterLastOne 378762 378763 | delim oneItemStream result | 378764 378765 delim := ', '. 378766 result:=''. 378767 oneItemStream := ReadWriteStream on: result. 378768 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. 378769 oneItemStream do: 378770 [:each1 | 378771 self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] 378772 ]. 378773 378774 378775! ! 378776 378777!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: 'delaunay 4/14/2009 15:12'! 378778testAsStringOnDelimiterMore 378779 378780 | delim multiItemStream result allElementsAsString tmp | 378781 378782 378783 delim := ', '. 378784 result:=''. 378785 tmp:= self nonEmpty collect:[:each | each asString]. 378786 multiItemStream := ReadWriteStream on:result. 378787 self nonEmpty asStringOn: multiItemStream delimiter: ', '. 378788 378789 allElementsAsString := (result findBetweenSubStrs: ', ' ). 378790 allElementsAsString do: 378791 [:each | 378792 self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). 378793 ].! ! 378794 378795!TAsStringCommaAndDelimiterTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: 'delaunay 4/14/2009 15:06'! 378796testAsStringOnDelimiterOne 378797 378798 | delim oneItemStream result | 378799 378800 delim := ', '. 378801 result:=''. 378802 oneItemStream := ReadWriteStream on: result. 378803 self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. 378804 oneItemStream do: 378805 [:each1 | 378806 self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] 378807 ]. 378808 378809! ! 378810 378811 378812!TAsStringCommaAndDelimiterTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/14/2009 14:41'! 378813test0FixtureAsStringCommaAndDelimiterTest 378814 378815 self shouldnt: [self nonEmpty] raise:Error . 378816 self deny: self nonEmpty isEmpty. 378817 378818 self shouldnt: [self empty] raise:Error . 378819 self assert: self empty isEmpty. 378820 378821 self shouldnt: [self nonEmpty1Element ] raise:Error . 378822 self assert: self nonEmpty1Element size=1.! ! 378823 378824"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 378825 378826TAsStringCommaAndDelimiterTest classTrait 378827 uses: {}! 378828Trait named: #TBeginsEndsWith 378829 uses: {} 378830 category: 'CollectionsTests-Abstract'! 378831 378832!TBeginsEndsWith methodsFor: 'requirements' stamp: 'delaunay 4/9/2009 15:04'! 378833empty 378834 self explicitRequirement.! ! 378835 378836!TBeginsEndsWith methodsFor: 'requirements' stamp: 'delaunay 4/9/2009 14:58'! 378837nonEmpty 378838 self explicitRequirement.! ! 378839 378840 378841!TBeginsEndsWith methodsFor: 'tests - begins ends with' stamp: 'delaunay 4/9/2009 15:03'! 378842testsBeginsWith 378843 378844 self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty size)). 378845 self assert: (self nonEmpty beginsWith:(self nonEmpty )). 378846 self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 378847 378848!TBeginsEndsWith methodsFor: 'tests - begins ends with' stamp: 'delaunay 4/9/2009 15:11'! 378849testsBeginsWithEmpty 378850 378851 self deny: (self nonEmpty beginsWith:(self empty)). 378852 self deny: (self empty beginsWith:(self nonEmpty )). 378853! ! 378854 378855!TBeginsEndsWith methodsFor: 'tests - begins ends with' stamp: 'delaunay 4/9/2009 15:05'! 378856testsEndsWith 378857 378858 self assert: (self nonEmpty endsWith:(self nonEmpty copyWithoutFirst)). 378859 self assert: (self nonEmpty endsWith:(self nonEmpty )). 378860 self deny: (self nonEmpty endsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! 378861 378862!TBeginsEndsWith methodsFor: 'tests - begins ends with' stamp: 'delaunay 4/9/2009 15:11'! 378863testsEndsWithEmpty 378864 378865 self deny: (self nonEmpty endsWith:(self empty )). 378866 self deny: (self empty endsWith:(self nonEmpty )). 378867 ! ! 378868 378869 378870!TBeginsEndsWith methodsFor: 'tests - fixture' stamp: 'delaunay 4/9/2009 15:09'! 378871test0FixtureBeginsEndsWithTest 378872 378873 self shouldnt: [self nonEmpty ] raise: Error. 378874 self deny: self nonEmpty isEmpty. 378875 self assert: self nonEmpty size>1. 378876 378877 self shouldnt: [self empty ] raise: Error. 378878 self assert: self empty isEmpty.! ! 378879 378880"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 378881 378882TBeginsEndsWith classTrait 378883 uses: {}! 378884Trait named: #TBehaviorCategorization 378885 uses: {} 378886 category: 'Traits-Kernel-Traits'! 378887 378888!TBehaviorCategorization methodsFor: 'organization' stamp: 'marcus.denker 11/10/2008 10:04'! 378889category 378890 "Answer the system organization category for the receiver. First check whether the 378891 category name stored in the ivar is still correct and only if this fails look it up 378892 (latter is much more expensive)" 378893 378894 | result | 378895 self basicCategory ifNotNil: [ :symbol | 378896 ((SystemOrganization listAtCategoryNamed: symbol) includes: self name) 378897 ifTrue: [ ^symbol ] ]. 378898 self basicCategory: (result := SystemOrganization categoryOfElement: self name). 378899 ^result! ! 378900 378901!TBehaviorCategorization methodsFor: 'organization' stamp: 'al 3/18/2006 13:35'! 378902category: aString 378903 "Categorize the receiver under the system category, aString, removing it from 378904 any previous categorization." 378905 378906 | oldCategory | 378907 oldCategory := self basicCategory. 378908 aString isString 378909 ifTrue: [ 378910 self basicCategory: aString asSymbol. 378911 SystemOrganization classify: self name under: self basicCategory ] 378912 ifFalse: [self errorCategoryName]. 378913 SystemChangeNotifier uniqueInstance 378914 class: self recategorizedFrom: oldCategory to: self basicCategory! ! 378915 378916"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 378917 378918TBehaviorCategorization classTrait 378919 uses: {}! 378920Trait named: #TClassAndTraitDescription 378921 uses: {} 378922 category: 'Traits-Kernel-Traits'! 378923 378924!TClassAndTraitDescription methodsFor: 'accessing comment' stamp: 'dvf 9/27/2005 16:55'! 378925comment 378926 "Answer the receiver's comment. (If missing, supply a template) " 378927 | aString | 378928 aString := self instanceSide organization classComment. 378929 aString isEmpty ifFalse: [^ aString]. 378930 ^self classCommentBlank! ! 378931 378932!TClassAndTraitDescription methodsFor: 'accessing comment' stamp: 'al 5/9/2004 17:05'! 378933comment: aStringOrText 378934 "Set the receiver's comment to be the argument, aStringOrText." 378935 378936 self instanceSide classComment: aStringOrText.! ! 378937 378938!TClassAndTraitDescription methodsFor: 'accessing comment' stamp: 'al 5/9/2004 17:07'! 378939comment: aStringOrText stamp: aStamp 378940 "Set the receiver's comment to be the argument, aStringOrText." 378941 378942 self instanceSide classComment: aStringOrText stamp: aStamp.! ! 378943 378944!TClassAndTraitDescription methodsFor: 'accessing comment' stamp: 'al 5/9/2004 17:09'! 378945hasComment 378946 "return whether this class truly has a comment other than the default" 378947 | org | 378948 org := self instanceSide organization. 378949 ^org classComment isEmptyOrNil not! ! 378950 378951 378952!TClassAndTraitDescription methodsFor: 'accessing method dictionary' stamp: 'mtf 8/29/2007 20:02'! 378953addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor 378954 | priorMethodOrNil oldProtocol newProtocol | 378955 priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil]. 378956 self addSelectorSilently: selector withMethod: compiledMethod. 378957 oldProtocol := self organization categoryOfElement: selector. 378958 SystemChangeNotifier uniqueInstance 378959 doSilently: [self organization classify: selector under: category]. 378960 newProtocol := self organization categoryOfElement: selector. 378961 priorMethodOrNil isNil 378962 ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: self requestor: requestor] 378963 ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self oldProtocol: oldProtocol newProtocol: newProtocol requestor: requestor].! ! 378964 378965!TClassAndTraitDescription methodsFor: 'accessing method dictionary' stamp: 'al 5/8/2004 20:33'! 378966addSelector: selector withMethod: compiledMethod notifying: requestor 378967 | priorMethodOrNil | 378968 priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil]. 378969 self addSelectorSilently: selector withMethod: compiledMethod. 378970 priorMethodOrNil isNil 378971 ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inClass: self requestor: requestor] 378972 ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! ! 378973 378974!TClassAndTraitDescription methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 09:51'! 378975addSelectorSilently: selector withMethod: compiledMethod 378976 super addSelectorSilently: selector withMethod: compiledMethod. 378977 self instanceSide noteAddedSelector: selector meta: self isMeta.! ! 378978 378979!TClassAndTraitDescription methodsFor: 'accessing method dictionary' stamp: 'al 5/9/2004 16:36'! 378980noteAddedSelector: aSelector meta: isMeta 378981 "A hook allowing some classes to react to adding of certain selectors"! ! 378982 378983!TClassAndTraitDescription methodsFor: 'accessing method dictionary' stamp: 'al 5/8/2004 19:50'! 378984removeCategory: aString 378985 "Remove each of the messages categorized under aString in the method 378986 dictionary of the receiver. Then remove the category aString." 378987 | categoryName | 378988 categoryName := aString asSymbol. 378989 (self organization listAtCategoryNamed: categoryName) do: 378990 [:sel | self removeSelector: sel]. 378991 self organization removeCategory: categoryName! ! 378992 378993!TClassAndTraitDescription methodsFor: 'accessing method dictionary' stamp: 'al 5/8/2004 20:49'! 378994removeSelector: selector 378995 "Remove the message whose selector is given from the method 378996 dictionary of the receiver, if it is there. Answer nil otherwise." 378997 378998 | priorMethod priorProtocol | 378999 priorMethod := self compiledMethodAt: selector ifAbsent: [^ nil]. 379000 priorProtocol := self whichCategoryIncludesSelector: selector. 379001 super removeSelector: selector. 379002 SystemChangeNotifier uniqueInstance 379003 doSilently: [self updateOrganizationSelector: selector oldCategory: priorProtocol newCategory: nil]. 379004 SystemChangeNotifier uniqueInstance 379005 methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! ! 379006 379007 379008!TClassAndTraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 5/9/2004 20:50'! 379009isClassSide 379010 ^self == self classSide! ! 379011 379012!TClassAndTraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 5/9/2004 20:50'! 379013isInstanceSide 379014 ^self isClassSide not! ! 379015 379016!TClassAndTraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 5/9/2004 20:55'! 379017isMeta 379018 ^self isClassSide! ! 379019 379020 379021!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'sd 4/26/2008 17:28'! 379022acceptsLoggingOfCompilation 379023 "Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set. The metaclass follows the rule of the class itself. 6/18/96 sw" 379024 "weird name is so that it will come lexically before #compile, so that a clean build can make it through. 7/7/96 sw" 379025 379026 ^ true! ! 379027 379028!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'al 11/28/2005 22:18'! 379029compile: code classified: heading 379030 "Compile the argument, code, as source code in the context of the 379031 receiver and install the result in the receiver's method dictionary under 379032 the classification indicated by the second argument, heading. nil is to be 379033 notified if an error occurs. The argument code is either a string or an 379034 object that converts to a string or a PositionableStream on an object that 379035 converts to a string." 379036 379037 ^self 379038 compile: code 379039 classified: heading 379040 notifying: nil! ! 379041 379042!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:00'! 379043compile: text classified: category notifying: requestor 379044 | stamp | 379045 stamp := self acceptsLoggingOfCompilation ifTrue: [Utilities changeStamp] ifFalse: [nil]. 379046 ^ self compile: text classified: category 379047 withStamp: stamp notifying: requestor! ! 379048 379049!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:00'! 379050compile: text classified: category withStamp: changeStamp notifying: requestor 379051 ^ self compile: text classified: category withStamp: changeStamp notifying: requestor logSource: self acceptsLoggingOfCompilation! ! 379052 379053!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'al 11/28/2005 22:21'! 379054compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource 379055 | methodAndNode | 379056 methodAndNode := self compile: text asString classified: category notifying: requestor 379057 trailer: self defaultMethodTrailer ifFail: [^nil]. 379058 logSource ifTrue: [ 379059 self logMethodSource: text forMethodWithNode: methodAndNode 379060 inCategory: category withStamp: changeStamp notifying: requestor. 379061 ]. 379062 self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode 379063 method inProtocol: category notifying: requestor. 379064 self instanceSide noteCompilationOf: methodAndNode selector meta: self isClassSide. 379065 ^ methodAndNode selector! ! 379066 379067!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:12'! 379068compile: code notifying: requestor 379069 "Refer to the comment in Behavior|compile:notifying:." 379070 379071 ^self compile: code 379072 classified: ClassOrganizer default 379073 notifying: requestor! ! 379074 379075!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:12'! 379076compileSilently: code classified: category 379077 "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." 379078 379079 ^ self compileSilently: code classified: category notifying: nil.! ! 379080 379081!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:13'! 379082compileSilently: code classified: category notifying: requestor 379083 "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." 379084 379085 ^ SystemChangeNotifier uniqueInstance 379086 doSilently: [self compile: code classified: category withStamp: nil notifying: requestor logSource: false].! ! 379087 379088!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'al 6/29/2004 21:37'! 379089doneCompiling 379090 "A ClassBuilder has finished the compilation of the receiver. 379091 This message is a notification for a class that needs to do some 379092 cleanup / reinitialization after it has been recompiled."! ! 379093 379094!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'dvf 9/27/2005 17:13'! 379095noteCompilationOf: aSelector meta: isMeta 379096 "A hook allowing some classes to react to recompilation of certain selectors"! ! 379097 379098!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'al 5/9/2004 19:17'! 379099reformatAll 379100 "Reformat all methods in this class. 379101 Leaves old code accessible to version browsing" 379102 self selectorsDo: [:sel | self reformatMethodAt: sel]! ! 379103 379104!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'alain.plantec 5/18/2009 16:01'! 379105reformatMethodAt: selector 379106 | newCodeString method | 379107 newCodeString := self prettyPrinterClass 379108 format: (self sourceCodeAt: selector) 379109 in: self 379110 notifying: nil. 379111 method := self compiledMethodAt: selector. 379112 method 379113 putSource: newCodeString 379114 fromParseNode: nil 379115 class: self 379116 category: (self organization categoryOfElement: selector) 379117 inFile: 2 379118 priorMethod: method 379119! ! 379120 379121!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:13'! 379122wantsChangeSetLogging 379123 "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism. 7/12/96 sw" 379124 379125 ^ true! ! 379126 379127!TClassAndTraitDescription methodsFor: 'compiling' stamp: 'al 5/8/2004 20:13'! 379128wantsRecompilationProgressReported 379129 "Answer whether the receiver would like progress of its recompilation reported interactively to the user." 379130 379131 ^ true! ! 379132 379133 379134!TClassAndTraitDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:53'! 379135copy: sel from: class 379136 "Install the method associated with the first argument, sel, a message 379137 selector, found in the method dictionary of the second argument, class, 379138 as one of the receiver's methods. Classify the message under -As yet not 379139 classified-." 379140 379141 self copy: sel 379142 from: class 379143 classified: nil! ! 379144 379145!TClassAndTraitDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:54'! 379146copy: sel from: class classified: cat 379147 "Install the method associated with the first arugment, sel, a message 379148 selector, found in the method dictionary of the second argument, class, 379149 as one of the receiver's methods. Classify the message under the third 379150 argument, cat." 379151 379152 | code category | 379153 "Useful when modifying an existing class" 379154 code := class sourceMethodAt: sel. 379155 code == nil 379156 ifFalse: 379157 [cat == nil 379158 ifTrue: [category := class organization categoryOfElement: sel] 379159 ifFalse: [category := cat]. 379160 (self methodDict includesKey: sel) 379161 ifTrue: [code asString = (self sourceMethodAt: sel) asString 379162 ifFalse: [self error: self name 379163 , ' ' 379164 , sel 379165 , ' will be redefined if you proceed.']]. 379166 self compile: code classified: category]! ! 379167 379168!TClassAndTraitDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:54'! 379169copyAll: selArray from: class 379170 "Install all the methods found in the method dictionary of the second 379171 argument, class, as the receiver's methods. Classify the messages under 379172 -As yet not classified-." 379173 379174 self copyAll: selArray 379175 from: class 379176 classified: nil! ! 379177 379178!TClassAndTraitDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:54'! 379179copyAll: selArray from: class classified: cat 379180 "Install all the methods found in the method dictionary of the second 379181 argument, class, as the receiver's methods. Classify the messages under 379182 the third argument, cat." 379183 379184 selArray do: 379185 [:s | self copy: s 379186 from: class 379187 classified: cat]! ! 379188 379189!TClassAndTraitDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:54'! 379190copyAllCategoriesFrom: aClass 379191 "Specify that the categories of messages for the receiver include all of 379192 those found in the class, aClass. Install each of the messages found in 379193 these categories into the method dictionary of the receiver, classified 379194 under the appropriate categories." 379195 379196 aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! ! 379197 379198!TClassAndTraitDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:54'! 379199copyCategory: cat from: class 379200 "Specify that one of the categories of messages for the receiver is cat, as 379201 found in the class, class. Copy each message found in this category." 379202 379203 self copyCategory: cat 379204 from: class 379205 classified: cat! ! 379206 379207!TClassAndTraitDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:55'! 379208copyCategory: cat from: aClass classified: newCat 379209 "Specify that one of the categories of messages for the receiver is the 379210 third argument, newCat. Copy each message found in the category cat in 379211 class aClass into this new category." 379212 379213 self copyAll: (aClass organization listAtCategoryNamed: cat) 379214 from: aClass 379215 classified: newCat! ! 379216 379217!TClassAndTraitDescription methodsFor: 'copying' stamp: 'al 5/8/2004 18:55'! 379218copyMethodDictionaryFrom: donorClass 379219 "Copy the method dictionary of the donor class over to the receiver" 379220 379221 self methodDict: donorClass copyOfMethodDictionary. 379222 self organization: donorClass organization deepCopy.! ! 379223 379224 379225!TClassAndTraitDescription methodsFor: 'fileIn/Out' stamp: 'mtf 8/29/2007 20:07'! 379226classComment: aString stamp: aStamp 379227 "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." 379228 379229 | ptr header file oldCommentRemoteStr oldComment oldStamp | 379230 oldComment := self organization classComment. 379231 oldStamp := self organization commentStamp. 379232 (aString isKindOf: RemoteString) ifTrue: 379233 [SystemChangeNotifier uniqueInstance class: self oldComment: oldComment newComment: aString string oldStamp: oldStamp newStamp: aStamp. 379234 ^ self organization classComment: aString stamp: aStamp]. 379235 379236 oldCommentRemoteStr := self organization commentRemoteStr. 379237 (aString size = 0) & (oldCommentRemoteStr isNil) ifTrue: [^ self organization classComment: nil]. 379238 "never had a class comment, no need to write empty string out" 379239 379240 ptr := oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. 379241 SourceFiles ifNotNil: [(file := SourceFiles at: 2) ifNotNil: 379242 [file setToEnd; cr; nextPut: $!!. "directly" 379243 "Should be saying (file command: 'H3') for HTML, but ignoring it here" 379244 header := String streamContents: [:strm | strm nextPutAll: self name; 379245 nextPutAll: ' commentStamp: '. 379246 aStamp storeOn: strm. 379247 strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. 379248 file nextChunkPut: header]]. 379249 self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. 379250 SystemChangeNotifier uniqueInstance class: self oldComment: oldComment newComment: aString oldStamp: oldStamp newStamp: aStamp! ! 379251 379252!TClassAndTraitDescription methodsFor: 'fileIn/Out' stamp: 'al 10/13/2006 13:32'! 379253fileOutCategory: aSymbol on: aFileStream moveSource: moveSource toFile: fileIndex 379254 "File a description of the receiver's category, aString, onto aFileStream. If 379255 moveSource, is true, then set the method source pointer to the new file position. 379256 Note when this method is called with moveSource=true, it is condensing the 379257 .sources file, and should only write one preamble per method category." 379258 379259 | selectors | 379260 aFileStream cr. 379261 selectors := (aSymbol asString = ClassOrganizer allCategory) 379262 ifTrue: [ self organization allMethodSelectors ] 379263 ifFalse: [ self organization listAtCategoryNamed: aSymbol ]. 379264 379265 "Overridden to preserve author stamps in sources file regardless" 379266 selectors do: [:sel | 379267 self printMethodChunk: sel 379268 withPreamble: true 379269 on: aFileStream 379270 moveSource: moveSource 379271 toFile: fileIndex]. 379272 ^ self! ! 379273 379274!TClassAndTraitDescription methodsFor: 'fileIn/Out' stamp: 'al 10/13/2006 13:40'! 379275moveChangesTo: newFile 379276 "Used in the process of condensing changes, this message requests that 379277 the source code of all methods of the receiver that have been changed 379278 should be moved to newFile." 379279 379280 | changes | 379281 changes := self methodDict keys select: [:sel | 379282 (self compiledMethodAt: sel) fileIndex > 1 ]. 379283 self 379284 fileOutChangedMessages: changes 379285 on: newFile 379286 moveSource: true 379287 toFile: 2! ! 379288 379289 379290!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 17:13'! 379291classComment: aString 379292 "Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing. Empty string gets stored only if had a non-empty one before." 379293 ^ self classComment: aString stamp: '<historical>'! ! 379294 379295!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 11/28/2005 22:18'! 379296commentStamp: changeStamp 379297 self organization commentStamp: changeStamp. 379298 ^ self commentStamp: changeStamp prior: 0! ! 379299 379300!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 17:15'! 379301commentStamp: changeStamp prior: indexAndOffset 379302 "Prior source link ignored when filing in." 379303 379304 ^ ClassCommentReader new setClass: self 379305 category: #Comment 379306 changeStamp: changeStamp! ! 379307 379308!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 18:34'! 379309definition 379310 "Answer a String that defines the receiver in good old ST-80." 379311 379312 ^ self definitionST80! ! 379313 379314!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 11:32'! 379315fileOutCategory: catName 379316 379317 | internalStream | 379318 internalStream := (String new: 1000) writeStream. 379319 internalStream header; timeStamp. 379320 self fileOutCategory: catName on: internalStream moveSource: false toFile: 0. 379321 internalStream trailer. 379322 379323 ^ FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , catName) isSt: true.! ! 379324 379325!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 18:51'! 379326fileOutChangedMessages: aSet on: aFileStream 379327 "File a description of the messages of the receiver that have been 379328 changed (i.e., are entered into the argument, aSet) onto aFileStream." 379329 379330 self fileOutChangedMessages: aSet 379331 on: aFileStream 379332 moveSource: false 379333 toFile: 0! ! 379334 379335!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 18:52'! 379336fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex 379337 "File a description of the messages of this class that have been 379338 changed (i.e., are entered into the argument, aSet) onto aFileStream. If 379339 moveSource, is true, then set the method source pointer to the new file position. 379340 Note when this method is called with moveSource=true, it is condensing the 379341 .changes file, and should only write a preamble for every method." 379342 | org sels | 379343 (org := self organization) categories do: 379344 [:cat | 379345 sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. 379346 sels do: 379347 [:sel | self printMethodChunk: sel withPreamble: true on: aFileStream 379348 moveSource: moveSource toFile: fileIndex]]! ! 379349 379350!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 11:32'! 379351fileOutMethod: selector 379352 "Write source code of a single method on a file. Make up a name for the file." 379353 379354 | internalStream | 379355 (selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.']. 379356 (self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found']. 379357 internalStream := (String new: 1000) writeStream. 379358 internalStream header; timeStamp. 379359 self printMethodChunk: selector withPreamble: true 379360 on: internalStream moveSource: false toFile: 0. 379361 379362 FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true.! ! 379363 379364!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 18:52'! 379365fileOutOn: aFileStream 379366 "File a description of the receiver on aFileStream." 379367 379368 self fileOutOn: aFileStream 379369 moveSource: false 379370 toFile: 0! ! 379371 379372!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'sd 4/25/2008 15:38'! 379373fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex 379374 "File a description of the receiver on aFileStream. If the boolean 379375 argument, moveSource, is true, then set the trailing bytes to the position 379376 of aFileStream and to fileIndex in order to indicate where to find the 379377 source code." 379378 379379 aFileStream nextChunkPut: self definition. 379380 379381 self organization 379382 putCommentOnFile: aFileStream 379383 numbered: fileIndex 379384 moveSource: moveSource 379385 forClass: self. 379386 self organization categories do: 379387 [:heading | 379388 self fileOutCategory: heading 379389 on: aFileStream 379390 moveSource: moveSource 379391 toFile: fileIndex]! ! 379392 379393!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 18:53'! 379394fileOutOrganizationOn: aFileStream 379395 "File a description of the receiver's organization on aFileStream." 379396 379397 aFileStream cr; nextPut: $!!. 379398 aFileStream nextChunkPut: self name, ' reorganize'; cr. 379399 aFileStream nextChunkPut: self organization printString; cr! ! 379400 379401!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'marcus.denker 8/25/2008 12:04'! 379402localMethods 379403 "returns the methods of classes including the ones of the traits that the class uses" 379404 379405 ^ self methods select: [:each | self includesLocalSelector: each selector].! ! 379406 379407!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'marcus.denker 8/25/2008 12:03'! 379408methods 379409 "returns the methods of classes including the ones of the traits that the class uses" 379410 379411 ^ self methodDict values ! ! 379412 379413!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 18:53'! 379414methodsFor: categoryName 379415 "Answer a ClassCategoryReader for compiling the messages in the category, categoryName, of the receiver." 379416 379417 ^ ClassCategoryReader new setClass: self category: categoryName asSymbol 379418 379419 "(False methodsFor: 'logical operations') inspect"! ! 379420 379421!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 18:54'! 379422methodsFor: aString priorSource: sourcePosition inFile: fileIndex 379423 "Prior source pointer ignored when filing in." 379424 ^ self methodsFor: aString! ! 379425 379426!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 18:54'! 379427methodsFor: categoryName stamp: changeStamp 379428 ^ self methodsFor: categoryName stamp: (Utilities fixStamp: changeStamp) prior: 0! ! 379429 379430!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 18:54'! 379431methodsFor: categoryName stamp: changeStamp prior: indexAndOffset 379432 "Prior source link ignored when filing in." 379433 ^ ClassCategoryReader new setClass: self 379434 category: categoryName asSymbol 379435 changeStamp: changeStamp 379436 379437"Most importantly, return the new ClassCategoryReader, so a fileIn will let it seize control. So method will be placed in the proper category. See the transfer of control where ReadWriteStream fileIn calls scanFrom:"! ! 379438 379439!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 18:54'! 379440printCategoryChunk: categoryName on: aFileStream 379441 ^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream! ! 379442 379443!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 18:55'! 379444printCategoryChunk: category on: aFileStream priorMethod: priorMethod 379445 ^ self printCategoryChunk: category on: aFileStream 379446 withStamp: Utilities changeStamp priorMethod: priorMethod! ! 379447 379448!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'sd 4/25/2008 15:39'! 379449printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod 379450 "Print a method category preamble. This must have a category name. 379451 It may have an author/date stamp, and it may have a prior source link. 379452 If it has a prior source link, it MUST have a stamp, even if it is empty." 379453 379454"The current design is that changeStamps and prior source links are preserved in the changes file. All fileOuts include changeStamps. Condensing sources, however, eliminates all stamps (and links, natch)." 379455 379456 aFileStream cr; nextPut: $!!. 379457 aFileStream nextChunkPut: (String streamContents: 379458 [:strm | 379459 strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString. 379460 (changeStamp ~~ nil and: 379461 [changeStamp size > 0 or: [priorMethod ~~ nil]]) ifTrue: 379462 [strm nextPutAll: ' stamp: '; print: changeStamp]. 379463 priorMethod ~~ nil ifTrue: 379464 [strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]]). 379465 ! ! 379466 379467!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 18:55'! 379468printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream 379469 ^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp 379470 priorMethod: nil! ! 379471 379472!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'md 2/22/2006 16:25'! 379473printMethodChunk: selector withPreamble: doPreamble on: outStream 379474 moveSource: moveSource toFile: fileIndex 379475 "Copy the source code for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." 379476 | preamble method oldPos newPos sourceFile endPos | 379477 doPreamble 379478 ifTrue: [preamble := self name , ' methodsFor: ' , 379479 (self organization categoryOfElement: selector) asString printString] 379480 ifFalse: [preamble := '']. 379481 method := self methodDict at: selector ifAbsent: 379482 [outStream nextPutAll: selector; cr. 379483 outStream tab; nextPutAll: '** ERROR!! THIS SCRIPT IS MISSING ** ' translated; cr; cr. 379484 outStream nextPutAll: ' '. 379485 ^ outStream]. 379486 379487 ((method fileIndex = 0 379488 or: [(SourceFiles at: method fileIndex) == nil]) 379489 or: [(oldPos := method filePosition) = 0]) 379490 ifTrue: 379491 ["The source code is not accessible. We must decompile..." 379492 preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr]. 379493 outStream nextChunkPut: method decompileString] 379494 ifFalse: 379495 [sourceFile := SourceFiles at: method fileIndex. 379496 preamble size > 0 379497 ifTrue: "Copy the preamble" 379498 [outStream copyPreamble: preamble from: sourceFile at: oldPos] 379499 ifFalse: 379500 [sourceFile position: oldPos]. 379501 "Copy the method chunk" 379502 newPos := outStream position. 379503 outStream copyMethodChunkFrom: sourceFile. 379504 sourceFile skipSeparators. "The following chunk may have ]style[" 379505 sourceFile peek == $] ifTrue: [ 379506 outStream cr; copyMethodChunkFrom: sourceFile]. 379507 moveSource ifTrue: "Set the new method source pointer" 379508 [endPos := outStream position. 379509 method checkOKToAdd: endPos - newPos at: newPos. 379510 method setSourcePosition: newPos inFile: fileIndex]]. 379511 preamble size > 0 ifTrue: [outStream nextChunkPut: ' ']. 379512 ^ outStream cr! ! 379513 379514!TClassAndTraitDescription methodsFor: 'filein/out' stamp: 'al 5/9/2004 18:56'! 379515putClassCommentToCondensedChangesFile: aFileStream 379516 "Called when condensing changes. If the receiver has a class comment, and if that class comment does not reside in the .sources file, then write it to the given filestream, with the resulting RemoteString being reachable from the source file #2. Note that any existing backpointer into the .sources file is lost by this process -- a situation that maybe should be fixed someday." 379517 379518 | header aStamp aCommentRemoteStr | 379519 self isMeta ifTrue: [^ self]. "bulletproofing only" 379520 ((aCommentRemoteStr := self organization commentRemoteStr) isNil or: 379521 [aCommentRemoteStr sourceFileNumber == 1]) ifTrue: [^ self]. 379522 379523 aFileStream cr; nextPut: $!!. 379524 header := String streamContents: [:strm | strm nextPutAll: self name; 379525 nextPutAll: ' commentStamp: '. 379526 (aStamp := self organization commentStamp ifNil: ['<historical>']) storeOn: strm. 379527 strm nextPutAll: ' prior: 0']. 379528 aFileStream nextChunkPut: header. 379529 aFileStream cr. 379530 self organization classComment: (RemoteString newString: self organization classComment onFileNumber: 2 toFile: aFileStream) stamp: aStamp! ! 379531 379532 379533!TClassAndTraitDescription methodsFor: 'organization' stamp: 'dvf 8/19/2005 11:31'! 379534methodReferencesInCategory: aCategoryName 379535 ^(self organization listAtCategoryNamed: aCategoryName) 379536 collect: [:ea | MethodReference new 379537 setClassSymbol: self theNonMetaClass name 379538 classIsMeta: self isMeta 379539 methodSymbol: ea 379540 stringVersion: ''] 379541! ! 379542 379543!TClassAndTraitDescription methodsFor: 'organization' stamp: 'al 5/9/2004 19:19'! 379544reorganize 379545 "During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization. See the transfer of control where ReadWriteStream fileIn calls scanFrom:" 379546 379547 ^self organization! ! 379548 379549!TClassAndTraitDescription methodsFor: 'organization' stamp: 'al 5/8/2004 19:15'! 379550whichCategoryIncludesSelector: aSelector 379551 "Answer the category of the argument, aSelector, in the organization of 379552 the receiver, or answer nil if the receiver does not inlcude this selector." 379553 379554 (self includesSelector: aSelector) 379555 ifTrue: [^ self organization categoryOfElement: aSelector] 379556 ifFalse: [^nil]! ! 379557 379558!TClassAndTraitDescription methodsFor: 'organization' stamp: 'al 5/8/2004 19:29'! 379559zapOrganization 379560 "Remove the organization of this class by message categories. 379561 This is typically done to save space in small systems. Classes and methods 379562 created or filed in subsequently will, nonetheless, be organized" 379563 379564 self organization: nil. 379565 self isClassSide ifFalse: [self classSide zapOrganization]! ! 379566 379567 379568!TClassAndTraitDescription methodsFor: 'organization updating' stamp: 'al 5/9/2004 14:08'! 379569applyChangesOfNewTraitCompositionReplacing: oldComposition 379570 | changedSelectors | 379571 changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. 379572 self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition. 379573 ^ changedSelectors.! ! 379574 379575!TClassAndTraitDescription methodsFor: 'organization updating' stamp: 'al 5/9/2004 14:00'! 379576noteRecategorizedSelector: aSymbol from: oldCategoryOrNil to: newCategoryOrNil 379577 | changedCategories | 379578 changedCategories := self updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil. 379579 changedCategories do: [:each | 379580 (self organization isEmptyCategoryNamed: each) ifTrue: [self organization removeCategory: each]]! ! 379581 379582!TClassAndTraitDescription methodsFor: 'organization updating' stamp: 'al 5/9/2004 14:01'! 379583noteRecategorizedSelectors: aCollection oldComposition: aTraitComposition 379584 | oldCategory newCategory | 379585 aCollection do: [:each | 379586 oldCategory := self organization categoryOfElement: each. 379587 newCategory := (self traitComposition methodDescriptionForSelector: each) effectiveMethodCategory. 379588 self noteRecategorizedSelector: each from: oldCategory to: newCategory]! ! 379589 379590!TClassAndTraitDescription methodsFor: 'organization updating' stamp: 'al 5/9/2004 14:02'! 379591notifyOfRecategorizedSelector: element from: oldCategory to: newCategory 379592 SystemChangeNotifier uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self! ! 379593 379594!TClassAndTraitDescription methodsFor: 'organization updating' stamp: 'al 3/27/2006 10:21'! 379595updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil 379596 | currentCategory effectiveCategory sel changedCategories composition | 379597 changedCategories := IdentitySet new. 379598 composition := self hasTraitComposition 379599 ifTrue: [self traitComposition] 379600 ifFalse: [TraitComposition new]. 379601 (composition methodDescriptionsForSelector: aSymbol) do: [:each | 379602 sel := each selector. 379603 (self includesLocalSelector: sel) ifFalse: [ 379604 currentCategory := self organization categoryOfElement: sel. 379605 effectiveCategory := each effectiveMethodCategoryCurrent: currentCategory new: newCategoryOrNil. 379606 effectiveCategory isNil ifTrue: [ 379607 currentCategory ifNotNil: [changedCategories add: currentCategory]. 379608 self organization removeElement: sel. 379609 ] ifFalse: [ 379610 ((currentCategory isNil or: [currentCategory == ClassOrganizer ambiguous or: [currentCategory == oldCategoryOrNil]]) and: [currentCategory ~~ effectiveCategory]) ifTrue: [ 379611 currentCategory ifNotNil: [changedCategories add: currentCategory]. 379612 self organization 379613 classify: sel 379614 under: effectiveCategory 379615 suppressIfDefault: false]]]]. 379616 ^ changedCategories! ! 379617 379618 379619!TClassAndTraitDescription methodsFor: 'printing' stamp: 'al 5/9/2004 16:50'! 379620printOn: aStream 379621 aStream nextPutAll: self name! ! 379622 379623!TClassAndTraitDescription methodsFor: 'printing' stamp: 'al 5/9/2004 16:50'! 379624printOnStream: aStream 379625 aStream print: self name! ! 379626 379627!TClassAndTraitDescription methodsFor: 'printing' stamp: 'al 5/9/2004 16:50'! 379628storeOn: aStream 379629 "Classes and Metaclasses have global names." 379630 379631 aStream nextPutAll: self name! ! 379632 379633 379634!TClassAndTraitDescription methodsFor: 'private' stamp: 'al 5/8/2004 19:24'! 379635errorCategoryName 379636 self error: 'Category name must be a String'! ! 379637 379638 379639!TClassAndTraitDescription methodsFor: 'deprecated' stamp: 'AndrewBlack 9/1/2009 06:51'! 379640commentFollows 379641 "Answer a ClassCommentReader that will scan in the comment." 379642 self deprecated: 'Use a ClassCommentReader instead.'. 379643 379644 ^ ClassCommentReader forClass: self 379645! ! 379646 379647"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 379648 379649TClassAndTraitDescription classTrait 379650 uses: {}! 379651Trait named: #TCloneTest 379652 uses: {} 379653 category: 'CollectionsTests-Abstract'! 379654 379655!TCloneTest methodsFor: 'helper' stamp: 'stephane.ducasse 1/12/2009 14:57'! 379656empty 379657 379658 ^ self explicitRequirement! ! 379659 379660!TCloneTest methodsFor: 'helper' stamp: 'stephane.ducasse 1/12/2009 14:57'! 379661nonEmpty 379662 379663 ^ self explicitRequirement! ! 379664 379665 379666!TCloneTest methodsFor: 'tests - copy - clone' stamp: 'stephane.ducasse 11/21/2008 15:43'! 379667testCopyCreatesNewObject 379668 "self debug: #testCopyCreatesNewObject" 379669 379670 | copy | 379671 copy := self nonEmpty copy. 379672 self deny: self nonEmpty == copy. 379673 ! ! 379674 379675!TCloneTest methodsFor: 'tests - copy - clone' stamp: 'stephane.ducasse 11/21/2008 15:57'! 379676testCopyEmpty 379677 "self debug: #testCopyEmpty" 379678 379679 | copy | 379680 copy := self empty copy. 379681 self assert: copy isEmpty.! ! 379682 379683!TCloneTest methodsFor: 'tests - copy - clone' stamp: 'stephane.ducasse 11/21/2008 15:57'! 379684testCopyNonEmpty 379685 "self debug: #testCopyNonEmpty" 379686 379687 | copy | 379688 copy := self nonEmpty copy. 379689 self deny: copy isEmpty. 379690 self assert: copy size = self nonEmpty size. 379691 self nonEmpty do: 379692 [:each | copy includes: each]! ! 379693 379694 379695!TCloneTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/12/2009 15:47'! 379696test0FixtureCloneTest 379697 379698self shouldnt: [ self nonEmpty ] raise: Error. 379699self deny: self nonEmpty isEmpty. 379700 379701self shouldnt: [ self empty ] raise: Error. 379702self assert: self empty isEmpty. 379703 379704! ! 379705 379706"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 379707 379708TCloneTest classTrait 379709 uses: {}! 379710Trait named: #TComposingDescription 379711 uses: {} 379712 category: 'Traits-Kernel-Traits'! 379713 379714!TComposingDescription methodsFor: 'composition' stamp: 'apb 8/22/2005 17:31'! 379715+ aTraitOrTraitComposition 379716 "Use double dispatch to avoid having nested composition in cases where 379717 parenthesis are used, such as T1 + (T2 + T3)" 379718 379719 ^aTraitOrTraitComposition addOnTheLeft: self! ! 379720 379721!TComposingDescription methodsFor: 'composition' stamp: 'apb 8/22/2005 17:12'! 379722- anArrayOfSelectors 379723 ^TraitExclusion 379724 with: self 379725 exclusions: anArrayOfSelectors! ! 379726 379727!TComposingDescription methodsFor: 'composition' stamp: 'apb 8/22/2005 17:02'! 379728@ anArrayOfAssociations 379729 ^ TraitAlias with: self aliases: anArrayOfAssociations! ! 379730 379731 379732!TComposingDescription methodsFor: 'converting' stamp: 'apb 8/22/2005 15:47'! 379733asTraitComposition 379734 ^TraitComposition with: self! ! 379735 379736 379737!TComposingDescription methodsFor: 'private' stamp: 'apb 8/22/2005 17:53'! 379738addCompositionOnLeft: aTraitComposition 379739 ^ aTraitComposition add: self! ! 379740 379741!TComposingDescription methodsFor: 'private' stamp: 'apb 8/22/2005 17:40'! 379742addOnTheLeft: aTraitExpression 379743 ^TraitComposition with: aTraitExpression with: self! ! 379744 379745"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 379746 379747TComposingDescription classTrait 379748 uses: {}! 379749Trait named: #TConcatenationEqualElementsRemovedTest 379750 uses: TConcatenationTest 379751 category: 'CollectionsTests-Abstract'! 379752 379753!TConcatenationEqualElementsRemovedTest methodsFor: 'requirements'! 379754empty 379755 self explicitRequirement.! ! 379756 379757!TConcatenationEqualElementsRemovedTest methodsFor: 'requirements'! 379758firstCollection 379759" return a collection that will be the first part of the concatenation" 379760 self explicitRequirement! ! 379761 379762!TConcatenationEqualElementsRemovedTest methodsFor: 'requirements'! 379763secondCollection 379764" return a collection that will be the second part of the concatenation" 379765 self explicitRequirement! ! 379766 379767 379768!TConcatenationEqualElementsRemovedTest methodsFor: 'tests - concatenation' stamp: 'delaunay 5/11/2009 16:00'! 379769testConcatenation 379770 379771| collection1 collection2 result | 379772collection1 := self firstCollection . 379773collection2 := self secondCollection . 379774result := collection1 , collection2. 379775 379776collection1 do:[ :each | self assert: (result includes: each)]. 379777collection2 do:[ :each | self assert: (result includes: each)]. 379778! ! 379779 379780!TConcatenationEqualElementsRemovedTest methodsFor: 'tests - concatenation' stamp: 'delaunay 5/11/2009 16:02'! 379781testConcatenationWithDuplicate 379782 379783 379784| collection1 collection2 result | 379785collection1 := self firstCollection . 379786collection2 := self firstCollection . 379787result := collection1 , collection2. 379788 379789collection1 do:[ :each | self assert: (result includes: each)]. 379790self assert: result size = collection1 size.! ! 379791 379792!TConcatenationEqualElementsRemovedTest methodsFor: 'tests - concatenation'! 379793testConcatenationWithEmpty 379794 | result | 379795 result := self firstCollection , self empty. 379796 self assert: result = self firstCollection! ! 379797 379798 379799!TConcatenationEqualElementsRemovedTest methodsFor: 'tests - fixture'! 379800test0FixtureConcatenationTest 379801 self shouldnt: [ self firstCollection ]raise: Error. 379802 self deny: self firstCollection isEmpty. 379803 379804 self shouldnt: [ self firstCollection ]raise: Error. 379805 self deny: self firstCollection isEmpty. 379806 379807 self shouldnt: [ self empty ]raise: Error. 379808 self assert: self empty isEmpty! ! 379809 379810"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 379811 379812TConcatenationEqualElementsRemovedTest classTrait 379813 uses: TConcatenationTest classTrait! 379814Trait named: #TConcatenationTest 379815 uses: {} 379816 category: 'CollectionsTests-Abstract'! 379817 379818!TConcatenationTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 11:49'! 379819empty 379820 self explicitRequirement.! ! 379821 379822!TConcatenationTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:45'! 379823firstCollection 379824" return a collection that will be the first part of the concatenation" 379825 self explicitRequirement! ! 379826 379827!TConcatenationTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:46'! 379828secondCollection 379829" return a collection that will be the second part of the concatenation" 379830 self explicitRequirement! ! 379831 379832 379833!TConcatenationTest methodsFor: 'tests - concatenation' stamp: 'delaunay 5/11/2009 15:57'! 379834testConcatenation 379835 379836"| collection1 collection2 result | 379837collection1 := self firstCollection . 379838collection2 := self secondCollection . 379839result := collection1 , collection2. 379840 379841collection1 do:[ :each | self assert: (result includes: each)]. 379842collection2 do:[ :each | self assert: (result includes: each)]." 379843 379844| collection1 collection2 result | 379845collection1 := self firstCollection . 379846collection2 := self secondCollection . 379847result := collection1 , collection2. 379848 379849result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ]. 379850self assert: result size = (collection1 size + collection2 size)! ! 379851 379852!TConcatenationTest methodsFor: 'tests - concatenation' stamp: 'delaunay 5/11/2009 16:00'! 379853testConcatenationWithDuplicate 379854 379855 379856| collection1 collection2 result | 379857collection1 := self firstCollection . 379858collection2 := self firstCollection . 379859result := collection1 , collection2. 379860 379861result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ]. 379862self assert: result size = (collection1 size * 2)! ! 379863 379864!TConcatenationTest methodsFor: 'tests - concatenation' stamp: 'delaunay 5/11/2009 11:45'! 379865testConcatenationWithEmpty 379866 | result | 379867 result := self firstCollection , self empty. 379868 self assert: result = self firstCollection! ! 379869 379870 379871!TConcatenationTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/11/2009 11:46'! 379872test0FixtureConcatenationTest 379873 self shouldnt: [ self firstCollection ]raise: Error. 379874 self deny: self firstCollection isEmpty. 379875 379876 self shouldnt: [ self firstCollection ]raise: Error. 379877 self deny: self firstCollection isEmpty. 379878 379879 self shouldnt: [ self empty ]raise: Error. 379880 self assert: self empty isEmpty! ! 379881 379882"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 379883 379884TConcatenationTest classTrait 379885 uses: {}! 379886Trait named: #TConvertAsSetForMultiplinessIdentityTest 379887 uses: TConvertAsSetForMultiplinessTest 379888 category: 'CollectionsTests-Abstract'! 379889 379890!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:03'! 379891collectionWithCopy 379892 "return a collection of type 'self collectionWIithoutEqualsElements class' containing no elements equals ( with identity equality) 379893 but 2 elements only equals with classic equality" 379894 | result collection | 379895 collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. 379896 collection add: collection first copy. 379897 result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. 379898 ^ result! ! 379899 379900!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:08'! 379901collectionWithIdentical 379902 "return a collection of type : 'self collectionWIithoutEqualsElements class containing two elements equals ( with identity equality)" 379903 | result collection element | 379904 collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. 379905 element := collection first. 379906 collection add: element. 379907 result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. 379908 ^ result! ! 379909 379910!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:00'! 379911elementsCopyNonIdenticalWithoutEqualElements 379912 " return a collection that does niot incllude equal elements ( classic equality ) 379913 all elements included are elements for which copy is not identical to the element " 379914 ^ self explicitRequirement! ! 379915 379916!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'requirements'! 379917withEqualElements 379918 " return a collection including equal elements (classic equality)" 379919 ^ self explicitRequirement! ! 379920 379921 379922!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'tests - as identity set' stamp: 'delaunay 4/28/2009 14:07'! 379923testAsIdentitySetWithIdentityEqualsElements 379924 | result | 379925 result := self collectionWithIdentical asIdentitySet. 379926 " Only one element should have been removed as two elements are equals with Identity equality" 379927 self assert: result size = (self collectionWithIdentical size - 1). 379928 self collectionWithIdentical do: 379929 [ :each | 379930 (self collectionWithIdentical occurrencesOf: each) > 1 379931 ifTrue: 379932 [ "the two elements equals only with classic equality shouldn't 'have been removed" 379933 self assert: (result asOrderedCollection occurrencesOf: each) = 1 379934 " the other elements are still here" ] 379935 ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ]. 379936 self assert: result class = IdentitySet! ! 379937 379938!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'tests - as identity set' stamp: 'delaunay 4/28/2009 14:24'! 379939testAsIdentitySetWithoutIdentityEqualsElements 379940 | result collection | 379941 collection := self collectionWithCopy. 379942 result := collection asIdentitySet. 379943 " no elements should have been removed as no elements are equels with Identity equality" 379944 self assert: result size = collection size. 379945 collection do: 379946 [ :each | 379947 (collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ]. 379948 self assert: result class = IdentitySet! ! 379949 379950 379951!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'tests - as set tests'! 379952testAsIdentitySetWithEqualsElements 379953 | result collection | 379954 collection := self withEqualElements . 379955 result := collection asIdentitySet. 379956 collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 379957 self assert: result class = IdentitySet.! ! 379958 379959!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'tests - as set tests'! 379960testAsSetWithEqualsElements 379961 | result | 379962 result := self withEqualElements asSet. 379963 self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 379964 self assert: result class = Set! ! 379965 379966 379967!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/28/2009 14:15'! 379968test0FixtureAsSetForIdentityMultiplinessTest 379969 379970 "a collection (of elements for which copy is not identical ) without equal elements:" 379971 | element res | 379972 self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ]raise: Error. 379973 element := self elementsCopyNonIdenticalWithoutEqualElements anyOne. 379974 self deny: element copy == element . 379975 379976 res := true. 379977 self elementsCopyNonIdenticalWithoutEqualElements 379978 detect: 379979 [ :each | 379980 (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] 379981 ifNone: [ res := false ]. 379982 self assert: res = false 379983 379984 ! ! 379985 379986!TConvertAsSetForMultiplinessIdentityTest methodsFor: 'tests - fixture'! 379987test0FixtureTConvertAsSetForMultiplinessTest 379988 "a collection with equal elements:" 379989 | res | 379990 self shouldnt: [ self withEqualElements] raise: Error. 379991 379992 res := true. 379993 self withEqualElements 379994 detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] 379995 ifNone: [ res := false ]. 379996 self assert: res = true. 379997 379998! ! 379999 380000"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 380001 380002TConvertAsSetForMultiplinessIdentityTest classTrait 380003 uses: TConvertAsSetForMultiplinessTest classTrait! 380004Trait named: #TConvertAsSetForMultiplinessTest 380005 uses: {} 380006 category: 'CollectionsTests-Abstract'! 380007 380008!TConvertAsSetForMultiplinessTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:11'! 380009withEqualElements 380010 " return a collection including equal elements (classic equality)" 380011 ^ self explicitRequirement! ! 380012 380013 380014!TConvertAsSetForMultiplinessTest methodsFor: 'tests - as set tests' stamp: 'delaunay 5/14/2009 15:06'! 380015testAsIdentitySetWithEqualsElements 380016 | result collection | 380017 collection := self withEqualElements . 380018 result := collection asIdentitySet. 380019 collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 380020 self assert: result class = IdentitySet.! ! 380021 380022!TConvertAsSetForMultiplinessTest methodsFor: 'tests - as set tests' stamp: 'delaunay 4/28/2009 14:11'! 380023testAsSetWithEqualsElements 380024 | result | 380025 result := self withEqualElements asSet. 380026 self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. 380027 self assert: result class = Set! ! 380028 380029 380030!TConvertAsSetForMultiplinessTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/28/2009 14:17'! 380031test0FixtureTConvertAsSetForMultiplinessTest 380032 "a collection with equal elements:" 380033 | res | 380034 self shouldnt: [ self withEqualElements] raise: Error. 380035 380036 res := true. 380037 self withEqualElements 380038 detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] 380039 ifNone: [ res := false ]. 380040 self assert: res = true. 380041 380042! ! 380043 380044"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 380045 380046TConvertAsSetForMultiplinessTest classTrait 380047 uses: {}! 380048Trait named: #TConvertAsSortedTest 380049 uses: {} 380050 category: 'CollectionsTests-Abstract'! 380051 380052!TConvertAsSortedTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:14'! 380053collectionWithSortableElements 380054" return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" 380055 ^ self explicitRequirement! ! 380056 380057 380058!TConvertAsSortedTest methodsFor: 'tests - as sorted collection' stamp: 'delaunay 4/30/2009 11:08'! 380059testAsSortedArray 380060 | result collection | 380061 collection := self collectionWithSortableElements . 380062 result := collection asSortedArray. 380063 self assert: (result class includesBehavior: Array). 380064 self assert: result isSorted. 380065 self assert: result size = collection size! ! 380066 380067!TConvertAsSortedTest methodsFor: 'tests - as sorted collection' stamp: 'delaunay 4/24/2009 10:19'! 380068testAsSortedCollection 380069 380070 | aCollection result | 380071 aCollection := self collectionWithSortableElements . 380072 result := aCollection asSortedCollection. 380073 380074 self assert: (result class includesBehavior: SortedCollection). 380075 result do: 380076 [ :each | 380077 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 380078 380079 self assert: result size = aCollection size.! ! 380080 380081!TConvertAsSortedTest methodsFor: 'tests - as sorted collection' stamp: 'delaunay 4/24/2009 10:16'! 380082testAsSortedCollectionWithSortBlock 380083 | result tmp | 380084 result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. 380085 self assert: (result class includesBehavior: SortedCollection). 380086 result do: 380087 [ :each | 380088 self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 380089 self assert: result size = self collectionWithSortableElements size. 380090 tmp:=result at: 1. 380091 result do: [:each| self assert: tmp>=each. tmp:=each]. 380092 ! ! 380093 380094 380095!TConvertAsSortedTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/24/2009 10:21'! 380096test0FixtureConverAsSortedTest 380097 380098 self shouldnt: [self collectionWithSortableElements ] raise: Error. 380099 self deny: self collectionWithSortableElements isEmpty .! ! 380100 380101"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 380102 380103TConvertAsSortedTest classTrait 380104 uses: {}! 380105Trait named: #TConvertTest 380106 uses: {} 380107 category: 'CollectionsTests-Abstract'! 380108 380109!TConvertTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:59'! 380110collectionWithoutEqualElements 380111" return a collection without equal elements" 380112 ^ self explicitRequirement! ! 380113 380114!TConvertTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:00'! 380115integerCollectionWithoutEqualElements 380116" return a collection of integer without equal elements" 380117 ^ self explicitRequirement! ! 380118 380119 380120!TConvertTest methodsFor: 'tests - converting' stamp: 'delaunay 3/27/2009 09:43'! 380121assertNoDuplicates: aCollection whenConvertedTo: aClass 380122 | result | 380123 result := self collectionWithEqualElements asIdentitySet. 380124 self assert: (result class includesBehavior: IdentitySet). 380125 self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! 380126 380127!TConvertTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 12:36'! 380128assertNonDuplicatedContents: aCollection whenConvertedTo: aClass 380129 | result | 380130 result := aCollection perform: ('as' , aClass name) asSymbol. 380131 self assert: (result class includesBehavior: aClass). 380132 result do: 380133 [ :each | 380134 self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. 380135 ^ result! ! 380136 380137!TConvertTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 12:37'! 380138assertSameContents: aCollection whenConvertedTo: aClass 380139 | result | 380140 result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. 380141 self assert: result size = aCollection size! ! 380142 380143!TConvertTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 14:55'! 380144testAsArray 380145 "self debug: #testAsArray3" 380146 self 380147 assertSameContents: self collectionWithoutEqualElements 380148 whenConvertedTo: Array! ! 380149 380150!TConvertTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 12:49'! 380151testAsBag 380152 380153 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! 380154 380155!TConvertTest methodsFor: 'tests - converting' stamp: 'delaunay 4/24/2009 10:40'! 380156testAsByteArray 380157| res | 380158self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 380159 self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger] . 380160 380161 res := true. 380162 self integerCollectionWithoutEqualElements 380163 detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] 380164 ifNone: [ res := false ]. 380165 self assert: res = false. 380166 380167 380168 self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! 380169 380170!TConvertTest methodsFor: 'tests - converting' stamp: 'delaunay 4/15/2009 15:33'! 380171testAsIdentitySet 380172 "test with a collection without equal elements :" 380173 self 380174 assertSameContents: self collectionWithoutEqualElements 380175 whenConvertedTo: IdentitySet. 380176! ! 380177 380178!TConvertTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 12:42'! 380179testAsOrderedCollection 380180 380181 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! 380182 380183!TConvertTest methodsFor: 'tests - converting' stamp: 'delaunay 4/15/2009 15:36'! 380184testAsSet 380185 | | 380186 "test with a collection without equal elements :" 380187 self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. 380188 ! ! 380189 380190 380191!TConvertTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/24/2009 10:40'! 380192test0FixtureTConvertTest 380193 "a collection of number without equal elements:" 380194 | res | 380195 self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. 380196 380197 res := true. 380198 self collectionWithoutEqualElements 380199 detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] 380200 ifNone: [ res := false ]. 380201 self assert: res = false. 380202 380203 380204! ! 380205 380206"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 380207 380208TConvertTest classTrait 380209 uses: {}! 380210Trait named: #TCopyPartOfSequenceable 380211 uses: {} 380212 category: 'CollectionsTests-Abstract'! 380213 380214!TCopyPartOfSequenceable methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:31'! 380215collectionWithoutEqualsElements 380216 380217" return a collection not including equal elements " 380218 self explicitRequirement! ! 380219 380220!TCopyPartOfSequenceable methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 15:47'! 380221empty 380222 self explicitRequirement! ! 380223 380224!TCopyPartOfSequenceable methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:32'! 380225indexInForCollectionWithoutDuplicates 380226" return an index between 'collectionWithoutEqualsElements' bounds" 380227 self explicitRequirement! ! 380228 380229 380230!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: 'delaunay 4/22/2009 11:20'! 380231testCopyAfter 380232 | result index collection | 380233 collection := self collectionWithoutEqualsElements . 380234 index:= self indexInForCollectionWithoutDuplicates . 380235 result := collection copyAfter: (collection at:index ). 380236 380237 "verifying content: " 380238 (1) to: result size do: 380239 [:i | 380240 self assert: (collection at:(i + index ))=(result at: (i))]. 380241 380242 "verify size: " 380243 self assert: result size = (collection size - index).! ! 380244 380245!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: 'delaunay 4/16/2009 15:18'! 380246testCopyAfterEmpty 380247 | result | 380248 result := self empty copyAfter: self collectionWithoutEqualsElements first. 380249 self assert: result isEmpty. 380250 ! ! 380251 380252!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: 'delaunay 4/22/2009 11:21'! 380253testCopyAfterLast 380254 | result index collection | 380255 collection := self collectionWithoutEqualsElements . 380256 index:= self indexInForCollectionWithoutDuplicates . 380257 result := collection copyAfterLast: (collection at:index ). 380258 380259 "verifying content: " 380260 (1) to: result size do: 380261 [:i | 380262 self assert: (collection at:(i + index ))=(result at: (i))]. 380263 380264 "verify size: " 380265 self assert: result size = (collection size - index).! ! 380266 380267!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: 'delaunay 4/16/2009 15:27'! 380268testCopyAfterLastEmpty 380269 | result | 380270 result := self empty copyAfterLast: self collectionWithoutEqualsElements first. 380271 self assert: result isEmpty.! ! 380272 380273!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: 'delaunay 4/16/2009 15:27'! 380274testCopyEmptyMethod 380275 | result | 380276 result := self collectionWithoutEqualsElements copyEmpty . 380277 self assert: result isEmpty . 380278 self assert: result class= self nonEmpty class.! ! 380279 380280!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: 'delaunay 4/22/2009 11:22'! 380281testCopyFromTo 380282 | result index collection | 380283 collection := self collectionWithoutEqualsElements . 380284 index :=self indexInForCollectionWithoutDuplicates . 380285 result := collection copyFrom: index to: collection size . 380286 380287 "verify content of 'result' : " 380288 1 to: result size do: 380289 [:i | 380290 self assert: (result at:i)=(collection at: (i + index - 1))]. 380291 380292 "verify size of 'result' : " 380293 self assert: result size = (collection size - index + 1).! ! 380294 380295!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: 'delaunay 4/22/2009 11:24'! 380296testCopyUpTo 380297 | result index collection | 380298 collection := self collectionWithoutEqualsElements . 380299 index:= self indexInForCollectionWithoutDuplicates . 380300 result := collection copyUpTo: (collection at:index). 380301 380302 "verify content of 'result' :" 380303 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 380304 380305 "verify size of 'result' :" 380306 self assert: result size = (index-1). 380307 ! ! 380308 380309!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: 'delaunay 4/16/2009 15:28'! 380310testCopyUpToEmpty 380311 | result | 380312 result := self empty copyUpTo: self collectionWithoutEqualsElements first. 380313 self assert: result isEmpty. 380314 ! ! 380315 380316!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: 'delaunay 4/22/2009 11:24'! 380317testCopyUpToLast 380318 | result index collection | 380319 collection := self collectionWithoutEqualsElements . 380320 index:= self indexInForCollectionWithoutDuplicates . 380321 result := collection copyUpToLast: (collection at:index). 380322 380323 "verify content of 'result' :" 380324 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. 380325 380326 "verify size of 'result' :" 380327 self assert: result size = (index-1).! ! 380328 380329!TCopyPartOfSequenceable methodsFor: 'tests - copying part of sequenceable' stamp: 'delaunay 4/16/2009 15:29'! 380330testCopyUpToLastEmpty 380331 | result | 380332 result := self empty copyUpToLast: self collectionWithoutEqualsElements first. 380333 self assert: result isEmpty.! ! 380334 380335 380336!TCopyPartOfSequenceable methodsFor: 'tests - fixture' stamp: 'delaunay 4/16/2009 15:47'! 380337test0FixtureCopyPartOfSequenceableTest 380338 380339 self shouldnt: [self collectionWithoutEqualsElements ] raise: Error. 380340 self collectionWithoutEqualsElements do: 380341 [:each | self assert: (self collectionWithoutEqualsElements occurrencesOf: each)=1]. 380342 380343 self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. 380344 self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualsElements size. 380345 380346 self shouldnt: [self empty] raise: Error. 380347 self assert: self empty isEmpty .! ! 380348 380349"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 380350 380351TCopyPartOfSequenceable classTrait 380352 uses: {}! 380353Trait named: #TCopyPartOfSequenceableForMultipliness 380354 uses: {} 380355 category: 'CollectionsTests-Abstract'! 380356 380357!TCopyPartOfSequenceableForMultipliness methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 10:56'! 380358collectionWithSameAtEndAndBegining 380359" return a collection with elements at end and begining equals . 380360(others elements of the collection are not equal to those elements)" 380361 self explicitRequirement! ! 380362 380363 380364!TCopyPartOfSequenceableForMultipliness methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: 'delaunay 4/22/2009 11:06'! 380365testCopyAfterLastWithDuplicate 380366 | result element collection | 380367 collection := self collectionWithSameAtEndAndBegining . 380368 element := collection first. 380369 380370 " collectionWithSameAtEndAndBegining first and last elements are equals. 380371 'copyAfter:' should copy after the last occurence of element :" 380372 result := collection copyAfterLast: (element ). 380373 380374 "verifying content: " 380375 self assert: result isEmpty. 380376 380377! ! 380378 380379!TCopyPartOfSequenceableForMultipliness methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: 'delaunay 4/22/2009 11:03'! 380380testCopyAfterWithDuplicate 380381 | result element collection | 380382 collection := self collectionWithSameAtEndAndBegining . 380383 element := collection last. 380384 380385 " collectionWithSameAtEndAndBegining first and last elements are equals. 380386 'copyAfter:' should copy after the first occurence :" 380387 result := collection copyAfter: (element ). 380388 380389 "verifying content: " 380390 1 to: result size do: 380391 [:i | 380392 self assert: (collection at:(i + 1 )) = (result at: (i)) 380393 ]. 380394 380395 "verify size: " 380396 self assert: result size = (collection size - 1).! ! 380397 380398!TCopyPartOfSequenceableForMultipliness methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: 'delaunay 4/22/2009 11:14'! 380399testCopyUpToLastWithDuplicate 380400 | result element collection | 380401 collection := self collectionWithSameAtEndAndBegining . 380402 element := collection first. 380403 380404 " collectionWithSameAtEndAndBegining first and last elements are equals. 380405 'copyUpToLast:' should copy until the last occurence :" 380406 result := collection copyUpToLast: (element ). 380407 380408 "verifying content: " 380409 1 to: result size do: 380410 [:i | 380411 self assert: (result at: i ) = ( collection at: i ) 380412 ]. 380413 380414 self assert: result size = (collection size - 1). 380415 380416! ! 380417 380418!TCopyPartOfSequenceableForMultipliness methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: 'delaunay 4/22/2009 11:08'! 380419testCopyUpToWithDuplicate 380420 | result element collection | 380421 collection := self collectionWithSameAtEndAndBegining . 380422 element := collection last. 380423 380424 " collectionWithSameAtEndAndBegining first and last elements are equals. 380425 'copyUpTo:' should copy until the first occurence :" 380426 result := collection copyUpTo: (element ). 380427 380428 "verifying content: " 380429 self assert: result isEmpty. 380430 380431! ! 380432 380433 380434!TCopyPartOfSequenceableForMultipliness methodsFor: 'tests - fixture' stamp: 'delaunay 4/22/2009 10:56'! 380435test0FixtureCopyPartOfForMultipliness 380436 380437self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. 380438 380439self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 380440 380441self assert: self collectionWithSameAtEndAndBegining size > 1. 380442 3804431 to: self collectionWithSameAtEndAndBegining size do: 380444 [:i | 380445 (i > 1 ) & (i < self collectionWithSameAtEndAndBegining size) 380446 ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at:i) = (self collectionWithSameAtEndAndBegining first)]. 380447 ]! ! 380448 380449"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 380450 380451TCopyPartOfSequenceableForMultipliness classTrait 380452 uses: {}! 380453Trait named: #TCopyPreservingIdentityTest 380454 uses: {} 380455 category: 'CollectionsTests-Abstract'! 380456 380457!TCopyPreservingIdentityTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/19/2009 18:08'! 380458nonEmpty 380459 self explicitRequirement! ! 380460 380461 380462!TCopyPreservingIdentityTest methodsFor: 'tests - copy' stamp: 'stephane.ducasse 11/21/2008 15:46'! 380463testCopyReturnsIdentity 380464 "self debug: #testCopyReturnsIdentity" 380465 380466 | copy | 380467 copy := self nonEmpty copy. 380468 self assert: self nonEmpty == copy. 380469 ! ! 380470 380471"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 380472 380473TCopyPreservingIdentityTest classTrait 380474 uses: {}! 380475Trait named: #TCopySequenceableSameContents 380476 uses: {} 380477 category: 'CollectionsTests-Abstract'! 380478 380479!TCopySequenceableSameContents methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 11:24'! 380480collectionWithSortableElements 380481 " return a collection only including elements that can be sorted (understanding '<' )" 380482 self explicitRequirement! ! 380483 380484!TCopySequenceableSameContents methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 14:44'! 380485empty 380486 self explicitRequirement! ! 380487 380488!TCopySequenceableSameContents methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 14:44'! 380489nonEmpty 380490 self explicitRequirement! ! 380491 380492 380493!TCopySequenceableSameContents methodsFor: 'tests - copying same contents' stamp: 'delaunay 4/20/2009 14:38'! 380494testReverse 380495 | result | 380496 result := self nonEmpty reverse . 380497 380498 "verify content of 'result: '" 380499 1 to: result size do: 380500 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 380501 "verify size of 'result' :" 380502 self assert: result size=self nonEmpty size.! ! 380503 380504!TCopySequenceableSameContents methodsFor: 'tests - copying same contents' stamp: 'delaunay 4/21/2009 16:10'! 380505testReversed 380506 | result | 380507 result := self nonEmpty reversed . 380508 380509 "verify content of 'result: '" 380510 1 to: result size do: 380511 [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. 380512 "verify size of 'result' :" 380513 self assert: result size=self nonEmpty size.! ! 380514 380515!TCopySequenceableSameContents methodsFor: 'tests - copying same contents' stamp: 'delaunay 4/16/2009 14:40'! 380516testShallowCopy 380517 | result | 380518 result := self nonEmpty shallowCopy . 380519 380520 "verify content of 'result: '" 380521 1 to: self nonEmpty size do: 380522 [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. 380523 "verify size of 'result' :" 380524 self assert: result size=self nonEmpty size.! ! 380525 380526!TCopySequenceableSameContents methodsFor: 'tests - copying same contents' stamp: 'delaunay 4/16/2009 14:39'! 380527testShallowCopyEmpty 380528 | result | 380529 result := self empty shallowCopy . 380530 self assert: result isEmpty .! ! 380531 380532!TCopySequenceableSameContents methodsFor: 'tests - copying same contents' stamp: 'delaunay 4/16/2009 14:40'! 380533testShuffled 380534 | result | 380535 result := self nonEmpty shuffled . 380536 380537 "verify content of 'result: '" 380538 result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. 380539 "verify size of 'result' :" 380540 self assert: result size=self nonEmpty size.! ! 380541 380542!TCopySequenceableSameContents methodsFor: 'tests - copying same contents' stamp: 'delaunay 4/27/2009 11:25'! 380543testSortBy 380544 " can only be used if the collection tested can include sortable elements :" 380545 | result tmp | 380546 self 380547 shouldnt: [ self collectionWithSortableElements ] 380548 raise: Error. 380549 self shouldnt: [self collectionWithSortableElements anyOne < self collectionWithSortableElements anyOne] raise: Error. 380550 result := self collectionWithSortableElements sortBy: [ :a :b | a < b ]. 380551 380552 "verify content of 'result' : " 380553 result do: 380554 [ :each | 380555 (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. 380556 tmp := result first. 380557 result do: 380558 [ :each | 380559 self assert: each >= tmp. 380560 tmp := each ]. 380561 380562 "verify size of 'result' :" 380563 self assert: result size = self collectionWithSortableElements size! ! 380564 380565 380566!TCopySequenceableSameContents methodsFor: 'tests - fixture' stamp: 'delaunay 4/24/2009 10:59'! 380567test0FixtureCopySameContentsTest 380568 380569 self shouldnt: [self nonEmpty ] raise: Error. 380570 self deny: self nonEmpty isEmpty. 380571 380572 self shouldnt: [self empty ] raise: Error. 380573 self assert: self empty isEmpty. 380574 380575! ! 380576 380577"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 380578 380579TCopySequenceableSameContents classTrait 380580 uses: {}! 380581Trait named: #TCopySequenceableWithOrWithoutSpecificElements 380582 uses: {} 380583 category: 'CollectionsTests-Abstract'! 380584 380585!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:43'! 380586indexInNonEmpty 380587" return an index between bounds of 'nonEmpty' " 380588 380589 self explicitRequirement! ! 380590 380591!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 16:31'! 380592nonEmpty 380593 self explicitRequirement! ! 380594 380595 380596!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - copying with or without' stamp: 'delaunay 4/16/2009 16:56'! 380597testCopyWithFirst 380598 380599 | index element result | 380600 index:= self indexInNonEmpty . 380601 element:= self nonEmpty at: index. 380602 380603 result := self nonEmpty copyWithFirst: element. 380604 380605 self assert: result size = (self nonEmpty size + 1). 380606 self assert: result first = element . 380607 380608 2 to: result size do: 380609 [ :i | 380610 self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! 380611 380612!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - copying with or without' stamp: 'delaunay 4/16/2009 16:57'! 380613testCopyWithSequenceable 380614 380615 | result index element | 380616 index := self indexInNonEmpty . 380617 element := self nonEmpty at: index. 380618 result := self nonEmpty copyWith: (element ). 380619 380620 self assert: result size = (self nonEmpty size + 1). 380621 self assert: result last = element . 380622 380623 1 to: (result size - 1) do: 380624 [ :i | 380625 self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! 380626 380627!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - copying with or without' stamp: 'delaunay 4/16/2009 16:49'! 380628testCopyWithoutFirst 380629 380630 | result | 380631 result := self nonEmpty copyWithoutFirst. 380632 380633 self assert: result size = (self nonEmpty size - 1). 380634 380635 1 to: result size do: 380636 [:i | 380637 self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! 380638 380639!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - copying with or without' stamp: 'delaunay 4/16/2009 16:50'! 380640testCopyWithoutIndex 380641 | result index | 380642 index := self indexInNonEmpty . 380643 result := self nonEmpty copyWithoutIndex: index . 380644 380645 "verify content of 'result:'" 380646 1 to: result size do: 380647 [:i | 380648 i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. 380649 i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. 380650 380651 "verify size of result : " 380652 self assert: result size=(self nonEmpty size -1).! ! 380653 380654!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - copying with or without' stamp: 'delaunay 4/16/2009 16:53'! 380655testForceToPaddingStartWith 380656 380657 | result element | 380658 element := self nonEmpty at: self indexInNonEmpty . 380659 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). 380660 380661 "verify content of 'result' : " 380662 1 to: 2 do: 380663 [:i | self assert: ( element ) = ( result at:(i) ) ]. 380664 380665 3 to: result size do: 380666 [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. 380667 380668 "verify size of 'result' :" 380669 self assert: result size = (self nonEmpty size + 2).! ! 380670 380671!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - copying with or without' stamp: 'delaunay 4/16/2009 16:54'! 380672testForceToPaddingWith 380673 380674 | result element | 380675 element := self nonEmpty at: self indexInNonEmpty . 380676 result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). 380677 380678 "verify content of 'result' : " 380679 1 to: self nonEmpty size do: 380680 [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. 380681 380682 (result size - 1) to: result size do: 380683 [:i | self assert: ( result at:i ) = ( element ) ]. 380684 380685 "verify size of 'result' :" 380686 self assert: result size = (self nonEmpty size + 2).! ! 380687 380688 380689!TCopySequenceableWithOrWithoutSpecificElements methodsFor: 'tests - fixture' stamp: 'delaunay 4/24/2009 11:10'! 380690test0FixtureCopyWithOrWithoutSpecificElementsTest 380691 380692 self shouldnt: [self nonEmpty ] raise: Error. 380693 self deny: self nonEmpty isEmpty . 380694 380695 self shouldnt: [self indexInNonEmpty ] raise: Error. 380696 self assert: self indexInNonEmpty > 0. 380697 self assert: self indexInNonEmpty <= self nonEmpty size.! ! 380698 380699"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 380700 380701TCopySequenceableWithOrWithoutSpecificElements classTrait 380702 uses: {}! 380703Trait named: #TCopySequenceableWithReplacement 380704 uses: {} 380705 category: 'CollectionsTests-Abstract'! 380706 380707!TCopySequenceableWithReplacement methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 13:51'! 380708collectionWith1TimeSubcollection 380709" return a collection including 'oldSubCollection' only one time " 380710 self explicitRequirement! ! 380711 380712!TCopySequenceableWithReplacement methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 13:51'! 380713collectionWith2TimeSubcollection 380714" return a collection including 'oldSubCollection' two or many time " 380715 self explicitRequirement! ! 380716 380717!TCopySequenceableWithReplacement methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 13:52'! 380718oldSubCollection 380719" return a subCollection included in collectionWith1TimeSubcollection . 380720ex : subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)" 380721 self explicitRequirement! ! 380722 380723!TCopySequenceableWithReplacement methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 13:52'! 380724replacementCollection 380725" return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection' " 380726 self explicitRequirement! ! 380727 380728 380729!TCopySequenceableWithReplacement methodsFor: 'tests - copying with replacement' stamp: 'delaunay 4/17/2009 10:43'! 380730firstIndexesOf: subCollection in: collection 380731" return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " 380732 | tmp result currentIndex | 380733 tmp:= collection. 380734 result:= OrderedCollection new. 380735 currentIndex := 1. 380736 380737 [tmp isEmpty ]whileFalse: 380738 [ 380739 (tmp beginsWith: subCollection) 380740 ifTrue: [ 380741 result add: currentIndex. 380742 1 to: subCollection size do: 380743 [:i | 380744 tmp := tmp copyWithoutFirst. 380745 currentIndex := currentIndex + 1] 380746 ] 380747 ifFalse: [ 380748 tmp := tmp copyWithoutFirst. 380749 currentIndex := currentIndex +1. 380750 ] 380751 ]. 380752 380753 ^ result. 380754 ! ! 380755 380756!TCopySequenceableWithReplacement methodsFor: 'tests - copying with replacement' stamp: 'delaunay 4/17/2009 11:19'! 380757testCopyReplaceAllWith1Occurence 380758 | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | 380759 380760 result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 380761 380762 "detecting indexes of olSubCollection" 380763 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . 380764 index:= firstIndexesOfOccurrence at: 1. 380765 380766 "verify content of 'result' : " 380767 "first part of 'result'' : '" 380768 380769 1 to: (index -1) do: 380770 [ 380771 :i | 380772 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 380773 ]. 380774 380775 " middle part containing replacementCollection : " 380776 380777 index to: (index + self replacementCollection size-1) do: 380778 [ 380779 :i | 380780 self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) 380781 ]. 380782 380783 " end part :" 380784 380785 endPartIndexResult := index + self replacementCollection size . 380786 endPartIndexCollection := index + self oldSubCollection size . 380787 380788 1 to: (result size - endPartIndexResult - 1 ) do: 380789 [ 380790 :i | 380791 self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). 380792 ]. 380793 380794 380795 ! ! 380796 380797!TCopySequenceableWithReplacement methodsFor: 'tests - copying with replacement' stamp: 'delaunay 4/27/2009 12:05'! 380798testCopyReplaceAllWithManyOccurence 380799 | result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff | 380800 " testing fixture here as this method may be not used for collection that can't contain equals element :" 380801 self shouldnt: [self collectionWith2TimeSubcollection ]raise: Error. 380802 self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection ) = 2. 380803 380804 " test :" 380805 diff := self replacementCollection size - self oldSubCollection size. 380806 result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . 380807 380808 "detecting indexes of olSubCollection" 380809 firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection . 380810 380811 " verifying that replacementCollection has been put in places of oldSubCollections " 380812 firstIndexesOfOccurrence do: [ 380813 :each | 380814 (firstIndexesOfOccurrence indexOf: each) = 1 380815 ifTrue: [ 380816 each to: self replacementCollection size do: 380817 [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. 380818 ] 380819 ifFalse:[ 380820 (each + diff) to: self replacementCollection size do: 380821 [ :i | self assert: (result at: i) = ( self replacementCollection at: ( i - each + 1 ) ) ]. 380822 ]. 380823 380824 ]. 380825 380826 " verifying that the 'between' parts correspond to the initial collection : " 380827 1 to: firstIndexesOfOccurrence size do: [ 380828 :i | 380829 i = 1 380830 " specific comportement for the begining of the collection :" 380831 ifTrue: [ 380832 1 to: ((firstIndexesOfOccurrence at: i) - 1 ) do: 380833 [ :j | 380834 self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] 380835 ] 380836 " between parts till the end : " 380837 ifFalse: [ 380838 resultBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self replacementCollection size. 380839 collectionBetweenPartIndex := (firstIndexesOfOccurrence at: (i -1)) + self oldSubCollection size. 380840 380841 1 to: ( firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: 380842 [ :j | 380843 self assert: (result at: (resultBetweenPartIndex + i - 1)) = (self collectionWith2TimeSubcollection at: (collectionBetweenPartIndex +i - 1)) ] 380844 ] 380845 ]. 380846 380847 "final part :" 380848 1 to: (self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size ) ) do: 380849 [ 380850 :i | 380851 self assert: ( result at:(firstIndexesOfOccurrence last + self replacementCollection size -1) + i ) = ( self collectionWith2TimeSubcollection at:(firstIndexesOfOccurrence last + self oldSubCollection size -1) + i ) . 380852 ]! ! 380853 380854!TCopySequenceableWithReplacement methodsFor: 'tests - copying with replacement' stamp: 'delaunay 4/17/2009 13:48'! 380855testCopyReplaceFromToWith 380856 | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | 380857 380858 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 380859 lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. 380860 lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. 380861 380862 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . 380863 380864 "verify content of 'result' : " 380865 "first part of 'result' " 380866 380867 1 to: (indexOfSubcollection - 1) do: 380868 [ 380869 :i | 380870 self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) 380871 ]. 380872 380873 " middle part containing replacementCollection : " 380874 380875 (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: 380876 [ 380877 :i | 380878 self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) 380879 ]. 380880 380881 " end part :" 380882 1 to: (result size - lastIndexOfReplacementCollection ) do: 380883 [ 380884 :i | 380885 self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). 380886 ]. 380887 380888 380889 380890 380891 380892 ! ! 380893 380894!TCopySequenceableWithReplacement methodsFor: 'tests - copying with replacement' stamp: 'delaunay 4/17/2009 13:57'! 380895testCopyReplaceFromToWithInsertion 380896 | result indexOfSubcollection | 380897 380898 indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. 380899 380900 result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . 380901 380902 "verify content of 'result' : " 380903 "first part of 'result'' : '" 380904 380905 1 to: (indexOfSubcollection -1) do: 380906 [ 380907 :i | 380908 self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) 380909 ]. 380910 380911 " middle part containing replacementCollection : " 380912 indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: 380913 [ 380914 :i | 380915 self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) 380916 ]. 380917 380918 " end part :" 380919 (indexOfSubcollection + self replacementCollection size) to: (result size) do: 380920 [:i| 380921 self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. 380922 380923 " verify size: " 380924 self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). 380925 380926 380927 380928 380929 380930 ! ! 380931 380932 380933!TCopySequenceableWithReplacement methodsFor: 'tests - fixture' stamp: 'delaunay 4/17/2009 10:30'! 380934howMany: subCollection in: collection 380935" return an integer representing how many time 'subCollection' appears in 'collection' " 380936 | tmp nTime | 380937 tmp:= collection. 380938 nTime:= 0. 380939 380940 [tmp isEmpty ]whileFalse: 380941 [ 380942 (tmp beginsWith: subCollection) 380943 ifTrue: [ 380944 nTime := nTime + 1. 380945 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] 380946 ] 380947 ifFalse: [tmp := tmp copyWithoutFirst.] 380948 ]. 380949 380950 ^ nTime. 380951 ! ! 380952 380953!TCopySequenceableWithReplacement methodsFor: 'tests - fixture' stamp: 'delaunay 4/17/2009 14:58'! 380954test0FixtureCopyWithReplacementTest 380955 380956 self shouldnt: [self replacementCollection ]raise: Error. 380957 self shouldnt: [self oldSubCollection] raise: Error. 380958 380959 self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. 380960 self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. 380961 380962 ! ! 380963 380964"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 380965 380966TCopySequenceableWithReplacement classTrait 380967 uses: {}! 380968Trait named: #TCopySequenceableWithReplacementForSorted 380969 uses: {} 380970 category: 'CollectionsTests-Abstract'! 380971 380972!TCopySequenceableWithReplacementForSorted methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 13:22'! 380973collectionOfSize5 380974" return a collection of size 5" 380975self explicitRequirement! ! 380976 380977!TCopySequenceableWithReplacementForSorted methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 13:37'! 380978empty 380979self explicitRequirement.! ! 380980 380981!TCopySequenceableWithReplacementForSorted methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 13:25'! 380982replacementCollection 380983" return a collection including elements of type 'collectionOfSize5' elements'type" 380984self explicitRequirement! ! 380985 380986 380987!TCopySequenceableWithReplacementForSorted methodsFor: 'tests - copying with replacement for sorted' stamp: 'delaunay 4/22/2009 13:44'! 380988testCopyFromToWithForSorted 380989| collection result | 380990collection := self collectionOfSize5 . 380991 380992" testing that elements to be replaced are removed from the copy :" 380993result := collection copyReplaceFrom: 1 to: collection size with: self empty . 380994self assert: result isEmpty. 380995 380996" testing that replacement elements are all put into the copy :" 380997result := collection copyReplaceFrom: 1 to: collection size with: self replacementCollection . 380998 self replacementCollection do: 380999 [:each | 381000 self assert: (result occurrencesOf: each) = ( self replacementCollection occurrencesOf: each )]. 381001 381002self assert: result size = self replacementCollection size. 381003 381004! ! 381005 381006!TCopySequenceableWithReplacementForSorted methodsFor: 'tests - copying with replacement for sorted' stamp: 'delaunay 4/22/2009 13:40'! 381007testCopyReplaceAllWithForSorted 381008 381009| collection result | 381010collection := self collectionOfSize5 . 381011 381012" testing that elements to be replaced are removed from the copy :" 381013result := collection copyReplaceAll: collection with: self empty . 381014self assert: result isEmpty. 381015 381016" testing that replacement elements are all put into the copy :" 381017result := collection copyReplaceAll: collection with: self replacementCollection . 381018 self replacementCollection do: 381019 [:each | 381020 self assert: (result occurrencesOf: each) = ( self replacementCollection occurrencesOf: each )]. 381021 381022self assert: result size = self replacementCollection size. 381023 381024! ! 381025 381026 381027!TCopySequenceableWithReplacementForSorted methodsFor: 'tests - fixture' stamp: 'delaunay 4/22/2009 13:37'! 381028test0FixtureCopyWithReplacementForSorted 381029 381030self shouldnt: [self collectionOfSize5 ] raise: Error. 381031self assert: self collectionOfSize5 size = 5. 381032 381033self shouldnt: [self replacementCollection ] raise: Error. 381034self deny: self replacementCollection isEmpty. 381035 381036self shouldnt: [self empty] raise: Error. 381037self assert: self empty isEmpty.! ! 381038 381039"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 381040 381041TCopySequenceableWithReplacementForSorted classTrait 381042 uses: {}! 381043Trait named: #TCopyTest 381044 uses: {} 381045 category: 'CollectionsTests-Abstract'! 381046!TCopyTest commentStamp: 'stephane.ducasse 1/16/2009 19:07' prior: 0! 381047Tests whether a copied object contains the same elements than its source. 381048Note that the order is not garanteed -- see TEqualityTest for that. 381049 381050! 381051 381052 381053!TCopyTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 14:51'! 381054collectionNotIncluded 381055" return a collection for wich each element is not included in 'nonEmpty' " 381056 ^ self explicitRequirement! ! 381057 381058!TCopyTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:21'! 381059collectionWithElementsToRemove 381060" return a collection of elements included in 'nonEmpty' " 381061 ^ self explicitRequirement! ! 381062 381063!TCopyTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:29'! 381064elementToAdd 381065" return an element of type 'nonEmpy' elements'type' not yet included in nonEmpty" 381066 ^ self explicitRequirement! ! 381067 381068!TCopyTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/19/2009 18:08'! 381069empty 381070 ^ self explicitRequirement! ! 381071 381072!TCopyTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 14:51'! 381073nonEmpty 381074 ^ self explicitRequirement! ! 381075 381076 381077!TCopyTest methodsFor: 'tests - copy' stamp: 'delaunay 4/29/2009 11:11'! 381078testCopyEmptyWith 381079 "self debug: #testCopyWith" 381080 | res element | 381081 element := self elementToAdd. 381082 res := self empty copyWith: element. 381083 self assert: res size = (self empty size + 1). 381084 self assert: (res includes: (element value))! ! 381085 381086!TCopyTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 381087testCopyEmptyWithout 381088 "self debug: #testCopyEmptyWithout" 381089 | res | 381090 res := self empty copyWithout: self elementToAdd. 381091 self assert: res size = self empty size. 381092 self deny: (res includes: self elementToAdd)! ! 381093 381094!TCopyTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:24'! 381095testCopyEmptyWithoutAll 381096 "self debug: #testCopyEmptyWithoutAll" 381097 | res | 381098 res := self empty copyWithoutAll: self collectionWithElementsToRemove. 381099 self assert: res size = self empty size. 381100 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! 381101 381102!TCopyTest methodsFor: 'tests - copy' stamp: 'delaunay 4/29/2009 11:12'! 381103testCopyNonEmptyWith 381104 "self debug: #testCopyNonEmptyWith" 381105 | res element | 381106 element := self elementToAdd . 381107 res := self nonEmpty copyWith: element. 381108 "here we do not test the size since for a non empty set we would get a problem. 381109 Then in addition copy is not about duplicate management. The element should 381110 be in at the end." 381111 self assert: (res includes: (element value)). 381112 self nonEmpty do: [ :each | res includes: each ]! ! 381113 381114!TCopyTest methodsFor: 'tests - copy' stamp: 'stephane.ducasse 11/21/2008 17:17'! 381115testCopyNonEmptyWithout 381116 "self debug: #testCopyNonEmptyWithout" 381117 381118 | res anElementOfTheCollection | 381119 anElementOfTheCollection := self nonEmpty anyOne. 381120 res := (self nonEmpty copyWithout: anElementOfTheCollection). 381121 "here we do not test the size since for a non empty set we would get a problem. 381122 Then in addition copy is not about duplicate management. The element should 381123 be in at the end." 381124 self deny: (res includes: anElementOfTheCollection). 381125 self nonEmpty do: 381126 [:each | (each = anElementOfTheCollection) 381127 ifFalse: [self assert: (res includes: each)]]. 381128 381129! ! 381130 381131!TCopyTest methodsFor: 'tests - copy' stamp: 'delaunay 4/29/2009 11:01'! 381132testCopyNonEmptyWithoutAll 381133 "self debug: #testCopyNonEmptyWithoutAll" 381134 | res | 381135 res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. 381136 "here we do not test the size since for a non empty set we would get a problem. 381137 Then in addition copy is not about duplicate management. The element should 381138 be in at the end." 381139 self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. 381140 self nonEmpty do: 381141 [ :each | 381142 (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! 381143 381144!TCopyTest methodsFor: 'tests - copy' stamp: 'delaunay 4/29/2009 11:10'! 381145testCopyNonEmptyWithoutAllNotIncluded 381146 "self debug: #testCopyNonEmptyWithoutAllNotIncluded" 381147 | res | 381148 res := self nonEmpty copyWithoutAll: self collectionNotIncluded. 381149 "here we do not test the size since for a non empty set we would get a problem. 381150 Then in addition copy is not about duplicate management. The element should 381151 be in at the end." 381152 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 381153 381154!TCopyTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 381155testCopyNonEmptyWithoutNotIncluded 381156 "self debug: #testCopyNonEmptyWithoutNotIncluded" 381157 | res | 381158 res := self nonEmpty copyWithout: self elementToAdd. 381159 "here we do not test the size since for a non empty set we would get a problem. 381160 Then in addition copy is not about duplicate management. The element should 381161 be in at the end." 381162 self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! 381163 381164 381165!TCopyTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/11/2009 10:30'! 381166test0CopyTest 381167 self shouldnt: [ self empty ]raise: Error. 381168 self assert: self empty size = 0. 381169 self shouldnt: [ self nonEmpty ]raise: Error. 381170 self assert: (self nonEmpty size = 0) not. 381171 self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. 381172 self assert: (self collectionWithElementsToRemove size = 0) not. 381173 self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. 381174 381175 self shouldnt: [ self elementToAdd ]raise: Error. 381176 self deny: (self nonEmpty includes: self elementToAdd ). 381177 self shouldnt: [ self collectionNotIncluded ]raise: Error. 381178 self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! 381179 381180"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 381181 381182TCopyTest classTrait 381183 uses: {}! 381184Trait named: #TCreationWithTest 381185 uses: {} 381186 category: 'CollectionsTests-Abstract'! 381187 381188!TCreationWithTest methodsFor: 'requirements' stamp: 'stephane.ducasse 12/9/2008 18:24'! 381189collectionClass 381190 381191 ^ self explicitRequirement! ! 381192 381193!TCreationWithTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 11:49'! 381194collectionMoreThan5Elements 381195" return a collection including at least 5 elements" 381196 381197 ^ self explicitRequirement! ! 381198 381199 381200!TCreationWithTest methodsFor: 'test - creation' stamp: 'stephane.ducasse 12/9/2008 21:18'! 381201testOfSize 381202 "self debug: #testOfSize" 381203 381204 | aCol | 381205 aCol := self collectionClass ofSize: 3. 381206 self assert: (aCol size = 3). 381207! ! 381208 381209!TCreationWithTest methodsFor: 'test - creation' stamp: 'delaunay 5/14/2009 11:51'! 381210testWith 381211 "self debug: #testWith" 381212 381213 | aCol element | 381214 element := self collectionMoreThan5Elements anyOne. 381215 aCol := self collectionClass with: element. 381216 self assert: (aCol includes: element).! ! 381217 381218!TCreationWithTest methodsFor: 'test - creation' stamp: 'delaunay 5/14/2009 11:57'! 381219testWithAll 381220 "self debug: #testWithAll" 381221 381222 | aCol collection | 381223 collection := self collectionMoreThan5Elements asOrderedCollection . 381224 aCol := self collectionClass withAll: collection . 381225 381226 collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. 381227 381228 self assert: (aCol size = collection size ).! ! 381229 381230!TCreationWithTest methodsFor: 'test - creation' stamp: 'delaunay 5/14/2009 13:54'! 381231testWithWith 381232 "self debug: #testWithWith" 381233 381234 | aCol collection element1 element2 | 381235 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . 381236 element1 := collection at: 1. 381237 element2 := collection at:2. 381238 381239 aCol := self collectionClass with: element1 with: element2 . 381240 self assert: (aCol occurrencesOf: element1 ) == ( collection occurrencesOf: element1). 381241 self assert: (aCol occurrencesOf: element2 ) == ( collection occurrencesOf: element2). 381242 381243 ! ! 381244 381245!TCreationWithTest methodsFor: 'test - creation' stamp: 'delaunay 5/14/2009 13:53'! 381246testWithWithWith 381247 "self debug: #testWithWithWith" 381248 381249 | aCol collection | 381250 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . 381251 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 381252 381253 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 381254 381255!TCreationWithTest methodsFor: 'test - creation' stamp: 'delaunay 5/14/2009 13:53'! 381256testWithWithWithWith 381257 "self debug: #testWithWithWithWith" 381258 381259 | aCol collection | 381260 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. 381261 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 381262 381263 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 381264 381265!TCreationWithTest methodsFor: 'test - creation' stamp: 'delaunay 5/14/2009 13:53'! 381266testWithWithWithWithWith 381267 "self debug: #testWithWithWithWithWith" 381268 381269 | aCol collection | 381270 collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . 381271 aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 381272 381273 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! 381274 381275 381276!TCreationWithTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/14/2009 11:50'! 381277test0FixtureCreationWithTest 381278 381279self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. 381280self assert: self collectionMoreThan5Elements size >= 5.! ! 381281 381282"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 381283 381284TCreationWithTest classTrait 381285 uses: {}! 381286Trait named: #TDictionaryAddingTest 381287 uses: {} 381288 category: 'CollectionsTests-Unordered'! 381289 381290!TDictionaryAddingTest methodsFor: 'requirement' stamp: 'delaunay 5/5/2009 12:10'! 381291associationWithKeyAlreadyInToAdd 381292 " return an association that will be used to add to nonEmptyDict (the key of this association is already included in nonEmptyDict)" 381293 self explicitRequirement! ! 381294 381295!TDictionaryAddingTest methodsFor: 'requirement' stamp: 'delaunay 5/5/2009 12:08'! 381296associationWithKeyNotInToAdd 381297 " return an association that will be used to add to nonEmptyDict (the key of this association is not included in nonEmptyDict)" 381298 self explicitRequirement! ! 381299 381300!TDictionaryAddingTest methodsFor: 'requirement' stamp: 'AlexandreBergel 1/6/2009 14:32'! 381301nonEmptyDict 381302 self explicitRequirement! ! 381303 381304 381305!TDictionaryAddingTest methodsFor: 'test - adding' stamp: 'delaunay 5/5/2009 14:27'! 381306testAddAll 381307 381308 | collectionToAdd collection result oldSize | 381309 collection := self nonEmptyDict . 381310 oldSize := collection size. 381311 collectionToAdd := Dictionary new add: self associationWithKeyAlreadyInToAdd ; add: self associationWithKeyNotInToAdd ; yourself. 381312 381313 result := collection addAll: collectionToAdd . 381314 381315 self assert: result = collectionToAdd . 381316 " the association with the key already in should have replaced the oldest :" 381317 self assert: collection size = (oldSize + 1). 381318 381319 result associationsDo: [:assoc | self assert: (collection at: (assoc key) ) = assoc value].! ! 381320 381321!TDictionaryAddingTest methodsFor: 'test - adding' stamp: 'delaunay 5/5/2009 12:11'! 381322testAddWithKeyAlreadyIn 381323 | dictionary result association oldSize | 381324 dictionary := self nonEmptyDict. 381325 oldSize := dictionary size. 381326 association := self associationWithKeyAlreadyInToAdd . 381327 result := dictionary add: association. 381328 381329 self assert: result = association. 381330 self assert: (dictionary at: association key) = association value. 381331 self assert: dictionary size = oldSize .! ! 381332 381333!TDictionaryAddingTest methodsFor: 'test - adding' stamp: 'delaunay 5/5/2009 12:10'! 381334testAddWithKeyNotIn 381335 | dictionary result association oldSize | 381336 dictionary := self nonEmptyDict. 381337 oldSize := dictionary size. 381338 association := self associationWithKeyNotInToAdd. 381339 result := dictionary add: association. 381340 381341 self assert: result = association. 381342 self assert: (dictionary at: association key) = association value. 381343 self assert: dictionary size = oldSize + 1.! ! 381344 381345!TDictionaryAddingTest methodsFor: 'test - adding' stamp: 'delaunay 5/5/2009 14:17'! 381346testDeclareFrom 381347 | newDict v dictionary keyIn associationKeyNotIn | 381348 dictionary := self nonEmptyDict. 381349 keyIn := dictionary keys anyOne. 381350 associationKeyNotIn := self associationWithKeyNotInToAdd . 381351 newDict := Dictionary new add: associationKeyNotIn ; yourself. 381352 381353 381354 381355 "if the key already exist, nothing changes" 381356 v := dictionary at: keyIn. 381357 dictionary declare: keyIn from: newDict. 381358 self assert: (dictionary at: keyIn ) = v. 381359 381360 "if the key does not exist, then it gets removed from newDict and is added to the receiver" 381361 self nonEmptyDict declare: associationKeyNotIn key from: newDict. 381362 self assert: (dictionary at: associationKeyNotIn key) = associationKeyNotIn value. 381363 self assert: (newDict size = 0)! ! 381364 381365 381366!TDictionaryAddingTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/5/2009 14:20'! 381367test0FixtureDictionaryAddingTest 381368 381369 381370self shouldnt: [ self nonEmptyDict ]raise: Error. 381371self deny: self nonEmptyDict isEmpty. 381372 381373self shouldnt: [ self associationWithKeyNotInToAdd ]raise: Error. 381374self deny: (self nonEmptyDict keys includes: self associationWithKeyNotInToAdd key ). 381375 381376self shouldnt: [ self associationWithKeyAlreadyInToAdd ]raise: Error. 381377self assert: (self nonEmptyDict keys includes: self associationWithKeyAlreadyInToAdd key ). 381378! ! 381379 381380"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 381381 381382TDictionaryAddingTest classTrait 381383 uses: {}! 381384Trait named: #TDictionaryAssociationAccessTest 381385 uses: {} 381386 category: 'CollectionsTests-Unordered'! 381387 381388!TDictionaryAssociationAccessTest methodsFor: 'requirements' stamp: 'delaunay 5/5/2009 11:07'! 381389keyNotIn 381390" return a key not included in nonEmpty" 381391self explicitRequirement! ! 381392 381393!TDictionaryAssociationAccessTest methodsFor: 'requirements' stamp: 'delaunay 5/5/2009 11:08'! 381394nonEmpty 381395^ self explicitRequirement! ! 381396 381397 381398!TDictionaryAssociationAccessTest methodsFor: 'tests - dictionary assocition access' stamp: 'delaunay 5/5/2009 11:12'! 381399testAssociationAt 381400 381401| collection keyIn result | 381402collection := self nonEmpty. 381403keyIn := collection keys anyOne. 381404 381405result := collection associationAt: keyIn. 381406 381407self assert: (result key) = keyIn. 381408self assert: (result value ) = (collection at: keyIn ).! ! 381409 381410!TDictionaryAssociationAccessTest methodsFor: 'tests - dictionary assocition access' stamp: 'delaunay 5/5/2009 11:13'! 381411testAssociationAtError 381412 381413| collection keyNotIn | 381414collection := self nonEmpty. 381415keyNotIn := self keyNotIn . 381416 381417self should: [collection associationAt: keyNotIn] raise: Error. 381418 381419! ! 381420 381421!TDictionaryAssociationAccessTest methodsFor: 'tests - dictionary assocition access' stamp: 'delaunay 5/5/2009 11:16'! 381422testAssociationAtIfAbsent 381423 381424| collection keyIn result | 381425collection := self nonEmpty. 381426keyIn := collection keys anyOne. 381427 381428result := collection associationAt: keyIn ifAbsent: [888]. 381429 381430self assert: (result key) = keyIn. 381431self assert: (result value ) = (collection at: keyIn ). 381432 381433self assert: (collection associationAt: self keyNotIn ifAbsent: [888] ) = 888! ! 381434 381435!TDictionaryAssociationAccessTest methodsFor: 'tests - dictionary assocition access' stamp: 'delaunay 5/5/2009 11:22'! 381436testAssociationDeclareAt 381437 381438| collection keyIn result | 381439collection := self nonEmpty. 381440keyIn := collection keys anyOne. 381441 381442result := collection associationDeclareAt: keyIn . 381443self assert: (result key) = keyIn. 381444self assert: (result value ) = (collection at: keyIn ). 381445 381446result := collection associationDeclareAt: self keyNotIn . 381447self shouldnt: [collection at: self keyNotIn ] raise: Error. 381448self assert: (collection at: self keyNotIn ) = false.! ! 381449 381450 381451!TDictionaryAssociationAccessTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/5/2009 11:23'! 381452test0FixtureDictionaryAssocitionAccess 381453 381454self shouldnt: [self nonEmpty ] raise: Error. 381455self deny: self nonEmpty isEmpty. 381456 381457self shouldnt: [self keyNotIn ] raise: Error. 381458self deny: ( self nonEmpty keys includes: self keyNotIn ).! ! 381459 381460"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 381461 381462TDictionaryAssociationAccessTest classTrait 381463 uses: {}! 381464Trait named: #TDictionaryComparingTest 381465 uses: {} 381466 category: 'CollectionsTests-Unordered'! 381467 381468!TDictionaryComparingTest methodsFor: 'test - comparing' stamp: 'delaunay 5/5/2009 16:41'! 381469testEquality 381470 | nonEmptyDict2 | 381471 nonEmptyDict2 := self nonEmpty class new. 381472 self nonEmpty keysAndValuesDo: [ :key :value | nonEmptyDict2 at: key put: value ]. 381473 381474 self assert: (self nonEmptyDict = nonEmptyDict2)! ! 381475 381476"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 381477 381478TDictionaryComparingTest classTrait 381479 uses: {}! 381480Trait named: #TDictionaryCopyingTest 381481 uses: TCloneTest 381482 category: 'CollectionsTests-Unordered'! 381483 381484!TDictionaryCopyingTest methodsFor: 'helper'! 381485empty 381486 381487 ^ self explicitRequirement! ! 381488 381489!TDictionaryCopyingTest methodsFor: 'helper'! 381490nonEmpty 381491 381492 ^ self explicitRequirement! ! 381493 381494 381495!TDictionaryCopyingTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/7/2009 11:55'! 381496emptyDict 381497 self explicitRequirement! ! 381498 381499!TDictionaryCopyingTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/7/2009 11:55'! 381500newEmptyDict 381501 self explicitRequirement! ! 381502 381503!TDictionaryCopyingTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/7/2009 11:55'! 381504nonEmptyDict 381505 self explicitRequirement! ! 381506 381507!TDictionaryCopyingTest methodsFor: 'requirements' stamp: 'delaunay 5/5/2009 16:50'! 381508nonEmptyDifferentFromNonEmptyDict 381509" return a dictionary for which all keys are not included in nonEmptyDict" 381510self explicitRequirement.! ! 381511 381512 381513!TDictionaryCopyingTest methodsFor: 'test - copying' stamp: 'delaunay 5/6/2009 10:16'! 381514testDictionaryConcatenationWithCommonKeys 381515 381516 | dictionary1 dictionary2 result | 381517 dictionary1 := self nonEmptyDict. 381518 dictionary2 := self nonEmptyDict. 381519 result := dictionary1 , dictionary2. 381520 self assert: result size = ( dictionary2 size). 381521 381522 dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! ! 381523 381524!TDictionaryCopyingTest methodsFor: 'test - copying' stamp: 'delaunay 5/6/2009 10:23'! 381525testDictionaryConcatenationWithCommonKeysDifferentValues 381526 381527 | dictionary1 dictionary2 result value | 381528 381529 dictionary1 := self nonEmptyDict. 381530 value := self nonEmptyDifferentFromNonEmptyDict values anyOne. 381531 dictionary2 := dictionary1 copy. 381532 dictionary2 keys do: [ :key | dictionary2 at: key put: value ]. 381533 381534 381535 result := dictionary1 , dictionary2. 381536 self assert: result size = ( dictionary2 size). 381537 381538 dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! ! 381539 381540!TDictionaryCopyingTest methodsFor: 'test - copying' stamp: 'delaunay 5/6/2009 10:13'! 381541testDictionaryConcatenationWithoutCommonKeys 381542 381543 | dictionary1 dictionary2 result | 381544 dictionary1 := self nonEmptyDict. 381545 dictionary2 := self nonEmptyDifferentFromNonEmptyDict. 381546 result := dictionary1 , dictionary2. 381547 self assert: result size = (dictionary1 size + dictionary2 size). 381548 dictionary1 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]. 381549 dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! ! 381550 381551 381552!TDictionaryCopyingTest methodsFor: 'tests - copy - clone'! 381553testCopyCreatesNewObject 381554 "self debug: #testCopyCreatesNewObject" 381555 381556 | copy | 381557 copy := self nonEmpty copy. 381558 self deny: self nonEmpty == copy. 381559 ! ! 381560 381561!TDictionaryCopyingTest methodsFor: 'tests - copy - clone'! 381562testCopyEmpty 381563 "self debug: #testCopyEmpty" 381564 381565 | copy | 381566 copy := self empty copy. 381567 self assert: copy isEmpty.! ! 381568 381569!TDictionaryCopyingTest methodsFor: 'tests - copy - clone'! 381570testCopyNonEmpty 381571 "self debug: #testCopyNonEmpty" 381572 381573 | copy | 381574 copy := self nonEmpty copy. 381575 self deny: copy isEmpty. 381576 self assert: copy size = self nonEmpty size. 381577 self nonEmpty do: 381578 [:each | copy includes: each]! ! 381579 381580 381581!TDictionaryCopyingTest methodsFor: 'tests - fixture'! 381582test0FixtureCloneTest 381583 381584self shouldnt: [ self nonEmpty ] raise: Error. 381585self deny: self nonEmpty isEmpty. 381586 381587self shouldnt: [ self empty ] raise: Error. 381588self assert: self empty isEmpty. 381589 381590! ! 381591 381592!TDictionaryCopyingTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/5/2009 16:55'! 381593test0FixtureDictionaryCopyingTest 381594 381595| duplicateKey | 381596self shouldnt: [ self nonEmptyDict ] raise: Error. 381597self deny: self nonEmptyDict isEmpty. 381598 381599self shouldnt: [ self nonEmptyDifferentFromNonEmptyDict ] raise: Error. 381600self deny: self nonEmptyDifferentFromNonEmptyDict isEmpty. 381601 381602duplicateKey := true. 381603self nonEmptyDict keys detect: [ :key | self nonEmptyDifferentFromNonEmptyDict includes: key ] ifNone: [ duplicateKey := false ] . 381604self assert: duplicateKey = false. 381605! ! 381606 381607"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 381608 381609TDictionaryCopyingTest classTrait 381610 uses: TCloneTest classTrait! 381611Trait named: #TDictionaryEnumeratingTest 381612 uses: {} 381613 category: 'CollectionsTests-Unordered'! 381614 381615!TDictionaryEnumeratingTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/7/2009 11:58'! 381616emptyDict 381617 self explicitRequirement! ! 381618 381619!TDictionaryEnumeratingTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/7/2009 11:58'! 381620newEmptyDict 381621 self explicitRequirement! ! 381622 381623!TDictionaryEnumeratingTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/7/2009 11:58'! 381624nonEmptyDict 381625 self explicitRequirement! ! 381626 381627 381628!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: 'delaunay 5/5/2009 16:14'! 381629testAssociationsDo 381630 381631 | collection keys | 381632 collection := self nonEmptyDict . 381633 381634 keys := OrderedCollection new. 381635 381636 collection associationsDo: [ :assoc | 381637 keys add: assoc key. 381638 self assert: ( collection at: assoc key ) = assoc value. 381639 ]. 381640 381641 collection keys do: [:key | self assert: ( keys occurrencesOf: key ) = (collection keys occurrencesOf: key)].! ! 381642 381643!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: 'delaunay 5/5/2009 16:00'! 381644testAssociationsSelect 381645 | collection keys result | 381646 collection := self nonEmptyDict . 381647 keys := OrderedCollection new. 381648 result := collection associationsSelect: [ :assoc | 381649 keys add: assoc key. 381650 true]. 381651 381652 collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)]. 381653 self assert: result = collection.! ! 381654 381655!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: 'delaunay 5/5/2009 16:04'! 381656testCollect 381657 | collection values result | 381658 collection := self nonEmptyDict . 381659 values := OrderedCollection new. 381660 result := collection collect: [ :value | 381661 values add: value. 381662 ]. 381663 381664 collection values do: [ :value | self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)]. 381665 self assert: result = collection.! ! 381666 381667!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: 'delaunay 5/4/2009 14:20'! 381668testDo 381669 | t collection | 381670 collection := self nonEmptyDict . 381671 t := OrderedCollection new. 381672 collection do: [: 381673 value | t add: value 381674 ]. 381675 381676 t do: [ :each | self assert: (t occurrencesOf: each ) = ( collection values occurrencesOf: each) ].! ! 381677 381678!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: 'delaunay 5/5/2009 16:05'! 381679testKeysAndValuesDo 381680 381681 381682 | collection keys | 381683 collection := self nonEmptyDict . 381684 keys := OrderedCollection new. 381685 collection keysAndValuesDo: [ :key :value | 381686 keys add: key. 381687 self assert: (collection at: key) = value ]. 381688 381689 collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)]! ! 381690 381691!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: 'delaunay 5/5/2009 15:49'! 381692testKeysDo 381693 | collection keys | 381694 collection := self nonEmptyDict . 381695 keys := OrderedCollection new. 381696 collection keysDo: [ :key | 381697 keys add: key. 381698 ]. 381699 381700 collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)]! ! 381701 381702!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: 'delaunay 5/5/2009 16:12'! 381703testReject 381704 "Ensure that Dictionary>>reject: answers a dictionary not something else" 381705 381706 | collection result | 381707 collection := self nonEmptyDict . 381708 result := collection reject: [ :each | false]. 381709 381710 self assert: result = collection. ! ! 381711 381712!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: 'delaunay 5/5/2009 16:01'! 381713testSelect 381714 | collection values result | 381715 collection := self nonEmptyDict . 381716 values := OrderedCollection new. 381717 result := collection select: [ :value | 381718 values add: value. 381719 true]. 381720 381721 collection values do: [ :value| self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)]. 381722 self assert: result = collection.! ! 381723 381724!TDictionaryEnumeratingTest methodsFor: 'tests - dictionnary enumerating' stamp: 'delaunay 5/5/2009 16:14'! 381725testValuesDo 381726 | collection values | 381727 collection := self nonEmptyDict . 381728 values := OrderedCollection new. 381729 collection valuesDo: [ :value | 381730 values add: value. 381731 ]. 381732 381733 collection values do: [ :value | self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)]! ! 381734 381735 381736!TDictionaryEnumeratingTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/5/2009 16:06'! 381737test0FixtureDictionaryEnumeratingTest 381738 381739self shouldnt: [ self nonEmptyDict ] raise: Error. 381740self deny: self nonEmptyDict isEmpty.! ! 381741 381742"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 381743 381744TDictionaryEnumeratingTest classTrait 381745 uses: {}! 381746Trait named: #TDictionaryImplementationTest 381747 uses: {} 381748 category: 'CollectionsTests-Unordered'! 381749 381750!TDictionaryImplementationTest methodsFor: 'test - implementation' stamp: 'AlexandreBergel 1/7/2009 19:29'! 381751testAtNil 381752 "(self run: #testAtNil)" 381753 "nil is a valid key in squeak. In VW nil is not a valid key" 381754 "Ansi 1.9 p, 168 381755 5.7.2.5 Message: at: key put: newElement 381756 Synopsis 381757 Store newElement at key in the receiver. Answer newElement. 381758 Definition: <abstractDictionary> 381759 If lookup succeeds for key, then newElement replaces the element previously stored at key. 381760 Otherwise, the newElement is stored at the new key. In either case, subsequent successful 381761 lookups for key will answer newElement. Answer newElement. 381762 381763 The result is undefined if the key is nil. 381764 381765 This clearly indicates that different smalltalks where doing different assumptions." 381766 381767 381768 381769 | dict1 | 381770 dict1 := self emptyDict. 381771 self shouldnt: [ dict1 at: nil put: #none] raise: Error. 381772 self assert: (dict1 at: nil) = #none. 381773 ! ! 381774 381775!TDictionaryImplementationTest methodsFor: 'test - implementation' stamp: 'AlexandreBergel 1/7/2009 19:29'! 381776testFindElementOrNil 381777 "Set>>findElementOrNil: takes an associaiton (when called on a dictionary) an integer, the index of the first 381778 position at is either equal to the assocation or which is nil" 381779 | assoc indexForG | 381780 assoc := #g -> 100. 381781 self assert: (self nonEmptyDict findElementOrNil: assoc key) = (self nonEmptyDict array indexOf: nil). 381782 381783 indexForG := (#g hash \\ self emptyDict array size) + 1. 381784 self assert: (self emptyDict findElementOrNil: assoc key) = ((self emptyDict array indexOf: nil) max: indexForG).! ! 381785 381786!TDictionaryImplementationTest methodsFor: 'test - implementation' stamp: 'AlexandreBergel 1/7/2009 19:29'! 381787testKeyAt 381788 self assert: (self nonEmptyDict keyAt: 1) == #b. 381789 self assert: (self nonEmptyDict keyAt: 2) == #c. 381790 self assert: (self nonEmptyDict keyAt: 3) == #d. 381791! ! 381792 381793!TDictionaryImplementationTest methodsFor: 'test - implementation' stamp: 'AlexandreBergel 1/14/2009 15:15'! 381794testNew 381795 | d | 381796 d := self classToBeTested new: 10. 381797 self assert: d size = 0. 381798 381799 "Why 14? Mysterious" 381800 self assert: d capacity = 14! ! 381801 381802!TDictionaryImplementationTest methodsFor: 'test - implementation' stamp: 'AlexandreBergel 1/7/2009 19:29'! 381803testPseudo 381804 "(self run: #testPseudo)" 381805 "true and false are valid keys" 381806 381807 | dict1 | 381808 dict1 := self emptyDict. 381809 self shouldnt: [dict1 at: true put: #true] raise: Error. 381810 self assert: (dict1 at: true) = #true. 381811 381812 self shouldnt: [dict1 at: false put: #false] raise: Error. 381813 self assert: (dict1 at: false) = #false.! ! 381814 381815!TDictionaryImplementationTest methodsFor: 'test - implementation' stamp: 'AlexandreBergel 1/7/2009 19:29'! 381816testPseudoVariablesAreValidKeys 381817 "(self run: #testPseudoVariablesAreValidKeys)" 381818 "true and false are valid keys" 381819 381820 | dict1 | 381821 dict1 := self emptyDict. 381822 self shouldnt: [dict1 at: true put: #true] raise: Error. 381823 self assert: (dict1 at: true) = #true. 381824 381825 self shouldnt: [dict1 at: false put: #false] raise: Error. 381826 self assert: (dict1 at: false) = #false.! ! 381827 381828!TDictionaryImplementationTest methodsFor: 'test - implementation' stamp: 'AlexandreBergel 1/7/2009 19:29'! 381829testScanFor 381830 "Set>>scanFor: return an integer " 381831 | assoc indexForG | 381832 assoc := #g -> 100. 381833 self assert: (self nonEmptyDict scanFor: assoc) = (self nonEmptyDict array indexOf: nil). 381834 381835 indexForG := (#g hash \\ self emptyDict array size) + 1. 381836 self assert: (self emptyDict scanFor: assoc) = ((self emptyDict array indexOf: nil) max: indexForG). 381837! ! 381838 381839!TDictionaryImplementationTest methodsFor: 'test - implementation' stamp: 'AlexandreBergel 1/7/2009 19:29'! 381840testSpecies 381841 self assert: self nonEmptyDict species == self nonEmptyDict class. 381842 self assert: self emptyDict species == self emptyDict class! ! 381843 381844"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 381845 381846TDictionaryImplementationTest classTrait 381847 uses: {}! 381848Trait named: #TDictionaryIncludesTest 381849 uses: {} 381850 category: 'CollectionsTests-Unordered'! 381851 381852!TDictionaryIncludesTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 14:41'! 381853keyNotInNonEmpty 381854 " return a key not included in nonEmpty" 381855 ^ self explicitRequirement! ! 381856 381857!TDictionaryIncludesTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 14:25'! 381858nonEmpty 381859 381860^self explicitRequirement! ! 381861 381862!TDictionaryIncludesTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 14:41'! 381863valueNotInNonEmpty 381864 " return a value not included in nonEmpty" 381865 ^ self explicitRequirement! ! 381866 381867 381868!TDictionaryIncludesTest methodsFor: 'tests - dictionary including' stamp: 'delaunay 4/29/2009 14:43'! 381869testIncludesAssociation 381870 381871| associationNotIn associationIn keyIn valueIn | 381872 381873keyIn := self nonEmpty keys anyOne. 381874valueIn := self nonEmpty values anyOne. 381875associationNotIn := self keyNotInNonEmpty -> self valueNotInNonEmpty . 381876associationIn := self nonEmpty associations anyOne. 381877 381878self assert: (self nonEmpty includesAssociation: associationIn ). 381879self deny: (self nonEmpty includesAssociation: associationNotIn ). 381880" testing the case where key is included but not with the same value :" 381881self deny: (self nonEmpty includesAssociation: (keyIn-> self valueNotInNonEmpty )). 381882" testing the case where value is included but not corresponding key :" 381883self deny: (self nonEmpty includesAssociation: (self keyNotInNonEmpty -> valueIn )). 381884 381885 381886 381887! ! 381888 381889!TDictionaryIncludesTest methodsFor: 'tests - dictionary including' stamp: 'delaunay 4/30/2009 10:47'! 381890testIncludesComportementForDictionnary 381891 | valueIn collection keyIn | 381892 collection := self nonEmpty. 381893 valueIn := collection values anyOne. 381894 keyIn := collection keys anyOne. 381895 self assert: (collection includes: valueIn). 381896 self deny: (collection includes: self valueNotInNonEmpty). 381897 " testing that includes take only care of values :" 381898 self deny: (collection includes: keyIn)! ! 381899 381900!TDictionaryIncludesTest methodsFor: 'tests - dictionary including' stamp: 'delaunay 5/12/2009 10:31'! 381901testIncludesIdentityBasicComportement 381902 381903| valueIn collection | 381904collection := self nonEmpty . 381905valueIn := collection values anyOne. 381906 381907self assert: (collection includesIdentity: valueIn ) . 381908self deny: (collection includesIdentity: self valueNotInNonEmpty ).! ! 381909 381910!TDictionaryIncludesTest methodsFor: 'tests - dictionary including' stamp: 'delaunay 4/29/2009 14:46'! 381911testIncludesKey 381912 381913| collection keyIn keyNotIn | 381914 381915collection := self nonEmpty . 381916keyIn := collection keys anyOne. 381917keyNotIn := self keyNotInNonEmpty. 381918 381919self assert: ( collection includesKey: keyIn ). 381920self deny: ( collection includesKey: keyNotIn ).! ! 381921 381922 381923!TDictionaryIncludesTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/29/2009 14:42'! 381924test0FixtureDictionaryIncludes 381925 | in | 381926 self shouldnt: [ self nonEmpty ]raise: Error. 381927 self deny: self nonEmpty isEmpty. 381928 381929 381930 self shouldnt: [ self valueNotInNonEmpty ] raise: Error. 381931 in := false. 381932 self nonEmpty valuesDo: [ :assoc | assoc = self valueNotInNonEmpty ifTrue: [ in := true ] ]. 381933 self assert: in = false. 381934 381935 381936 self shouldnt: [ self keyNotInNonEmpty ] raise: Error. 381937 in := false. 381938 self nonEmpty keysDo: [ :assoc | assoc = self keyNotInNonEmpty ifTrue: [ in := true ] ]. 381939 self assert: in = false! ! 381940 381941"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 381942 381943TDictionaryIncludesTest classTrait 381944 uses: {}! 381945Trait named: #TDictionaryIncludesWithIdentityCheckTest 381946 uses: TDictionaryIncludesTest 381947 category: 'CollectionsTests-Unordered'! 381948 381949!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'requirements'! 381950keyNotInNonEmpty 381951 " return a key not included in nonEmpty" 381952 ^ self explicitRequirement! ! 381953 381954!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'requirements'! 381955nonEmpty 381956 381957^self explicitRequirement! ! 381958 381959!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'requirements' stamp: 'delaunay 5/12/2009 11:02'! 381960nonEmptyWithCopyNonIdentical. 381961" return a collection including elements for wich copy is not identical to the initial element ( this is not the cas of Integer )" 381962^self explicitRequirement! ! 381963 381964!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'requirements'! 381965valueNotInNonEmpty 381966 " return a value not included in nonEmpty" 381967 ^ self explicitRequirement! ! 381968 381969 381970!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - dictionary including'! 381971testIncludesAssociation 381972 381973| associationNotIn associationIn keyIn valueIn | 381974 381975keyIn := self nonEmpty keys anyOne. 381976valueIn := self nonEmpty values anyOne. 381977associationNotIn := self keyNotInNonEmpty -> self valueNotInNonEmpty . 381978associationIn := self nonEmpty associations anyOne. 381979 381980self assert: (self nonEmpty includesAssociation: associationIn ). 381981self deny: (self nonEmpty includesAssociation: associationNotIn ). 381982" testing the case where key is included but not with the same value :" 381983self deny: (self nonEmpty includesAssociation: (keyIn-> self valueNotInNonEmpty )). 381984" testing the case where value is included but not corresponding key :" 381985self deny: (self nonEmpty includesAssociation: (self keyNotInNonEmpty -> valueIn )). 381986 381987 381988 381989! ! 381990 381991!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - dictionary including'! 381992testIncludesComportementForDictionnary 381993 | valueIn collection keyIn | 381994 collection := self nonEmpty. 381995 valueIn := collection values anyOne. 381996 keyIn := collection keys anyOne. 381997 self assert: (collection includes: valueIn). 381998 self deny: (collection includes: self valueNotInNonEmpty). 381999 " testing that includes take only care of values :" 382000 self deny: (collection includes: keyIn)! ! 382001 382002!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - dictionary including'! 382003testIncludesIdentityBasicComportement 382004 382005| valueIn collection | 382006collection := self nonEmpty . 382007valueIn := collection values anyOne. 382008 382009self assert: (collection includesIdentity: valueIn ) . 382010self deny: (collection includesIdentity: self valueNotInNonEmpty ).! ! 382011 382012!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - dictionary including' stamp: 'delaunay 5/12/2009 11:10'! 382013testIncludesIdentitySpecificComportement 382014 382015| valueIn collection | 382016collection := self nonEmptyWithCopyNonIdentical . 382017valueIn := collection values anyOne. 382018 382019self assert: (collection includesIdentity: valueIn ) . 382020self deny: (collection includesIdentity: valueIn copy ) . 382021! ! 382022 382023!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - dictionary including'! 382024testIncludesKey 382025 382026| collection keyIn keyNotIn | 382027 382028collection := self nonEmpty . 382029keyIn := collection keys anyOne. 382030keyNotIn := self keyNotInNonEmpty. 382031 382032self assert: ( collection includesKey: keyIn ). 382033self deny: ( collection includesKey: keyNotIn ).! ! 382034 382035 382036!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - fixture'! 382037test0FixtureDictionaryIncludes 382038 | in | 382039 self shouldnt: [ self nonEmpty ]raise: Error. 382040 self deny: self nonEmpty isEmpty. 382041 382042 382043 self shouldnt: [ self valueNotInNonEmpty ] raise: Error. 382044 in := false. 382045 self nonEmpty valuesDo: [ :assoc | assoc = self valueNotInNonEmpty ifTrue: [ in := true ] ]. 382046 self assert: in = false. 382047 382048 382049 self shouldnt: [ self keyNotInNonEmpty ] raise: Error. 382050 in := false. 382051 self nonEmpty keysDo: [ :assoc | assoc = self keyNotInNonEmpty ifTrue: [ in := true ] ]. 382052 self assert: in = false! ! 382053 382054!TDictionaryIncludesWithIdentityCheckTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/12/2009 11:09'! 382055test0FixtureDictionaryIncludesIdentity 382056 | | 382057 self shouldnt: [ self nonEmptyWithCopyNonIdentical ]raise: Error. 382058 self deny: self nonEmptyWithCopyNonIdentical isEmpty. 382059 382060 self nonEmptyWithCopyNonIdentical do: [ :each | self deny: each == each copy ]. 382061 382062 ! ! 382063 382064"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 382065 382066TDictionaryIncludesWithIdentityCheckTest classTrait 382067 uses: TDictionaryIncludesTest classTrait! 382068Trait named: #TDictionaryKeyAccessTest 382069 uses: {} 382070 category: 'CollectionsTests-Unordered'! 382071 382072!TDictionaryKeyAccessTest methodsFor: 'requirements' stamp: 'delaunay 5/5/2009 10:34'! 382073nonEmptyWithoutEqualsValues 382074" return a dictionary that doesn't include equal values'" 382075^self explicitRequirement! ! 382076 382077!TDictionaryKeyAccessTest methodsFor: 'requirements' stamp: 'delaunay 5/5/2009 11:07'! 382078valueNotIn 382079" return a value not included in nonEmptyWithoutEqualValues " 382080^self explicitRequirement! ! 382081 382082 382083!TDictionaryKeyAccessTest methodsFor: 'tests - dictionary key access' stamp: 'delaunay 5/5/2009 10:32'! 382084testKeyAtIdentityValue 382085 382086 382087 | dict value result | 382088 dict := self nonEmpty . 382089 value := dict values anyOne. 382090 382091 result := dict keyAtIdentityValue: value. 382092 self assert: (dict at: result) = value. 382093 382094 self should: [dict keyAtIdentityValue: self valueNotIn ] raise: Error 382095 382096 ! ! 382097 382098!TDictionaryKeyAccessTest methodsFor: 'tests - dictionary key access' stamp: 'delaunay 5/5/2009 10:33'! 382099testKeyAtIdentityValueIfAbsent 382100 "self run: #testKeyAtValue" 382101 "self debug: #testKeyAtValue" 382102 382103 | dict value result | 382104 dict := self nonEmpty . 382105 value := dict values anyOne. 382106 382107 result := dict keyAtIdentityValue: value ifAbsent: [nil]. 382108 self assert: (dict at: result) = value. 382109 382110 self assert: (dict keyAtIdentityValue: self valueNotIn ifAbsent: [nil] ) = nil. 382111 ! ! 382112 382113!TDictionaryKeyAccessTest methodsFor: 'tests - dictionary key access' stamp: 'delaunay 5/5/2009 10:26'! 382114testKeyAtValue 382115 "self run: #testKeyAtValue" 382116 "self debug: #testKeyAtValue" 382117 382118 | dict value result | 382119 dict := self nonEmpty . 382120 value := dict values anyOne. 382121 382122 result := dict keyAtValue: value. 382123 self assert: (dict at: result) = value. 382124 382125 self should: [dict keyAtValue: self valueNotIn ] raise: Error 382126 382127 ! ! 382128 382129!TDictionaryKeyAccessTest methodsFor: 'tests - dictionary key access' stamp: 'delaunay 5/5/2009 10:31'! 382130testKeyAtValueIfAbsent 382131 "self run: #testKeyAtValue" 382132 "self debug: #testKeyAtValue" 382133 382134 | dict value result | 382135 dict := self nonEmpty . 382136 value := dict values anyOne. 382137 382138 result := dict keyAtValue: value ifAbsent: [nil]. 382139 self assert: (dict at: result) = value. 382140 382141 self assert: (dict keyAtValue: self valueNotIn ifAbsent: [nil] ) = nil. 382142 382143 ! ! 382144 382145 382146!TDictionaryKeyAccessTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/5/2009 10:39'! 382147test0FixtureDictionaryKeyAccess 382148 382149| collection equals | 382150self shouldnt: [ self nonEmptyWithoutEqualsValues ] raise: Error. 382151self deny: self nonEmptyWithoutEqualsValues isEmpty. 382152 382153equals := true. 382154collection := self nonEmptyWithoutEqualsValues values. 382155collection detect: [:each | (collection occurrencesOf: each) > 1 ] ifNone: [ equals := false]. 382156self assert: equals = false. 382157 382158self shouldnt: [ self valueNotIn ] raise: Error. 382159self deny: (self nonEmptyWithoutEqualsValues values includes: self valueNotIn )! ! 382160 382161"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 382162 382163TDictionaryKeyAccessTest classTrait 382164 uses: {}! 382165Trait named: #TDictionaryKeysValuesAssociationsAccess 382166 uses: {} 382167 category: 'CollectionsTests-Unordered'! 382168 382169!TDictionaryKeysValuesAssociationsAccess methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 16:59'! 382170nonEmpty 382171 382172self explicitRequirement.! ! 382173 382174 382175!TDictionaryKeysValuesAssociationsAccess methodsFor: 'tests - Dictionary keys values associations access' stamp: 'delaunay 5/5/2009 10:02'! 382176testAssociations 382177 382178 | collection result | 382179 collection := self nonEmpty . 382180 result := collection associations. 382181 382182 self assert: result size = collection size. 382183 result do: [:assoc | self assert: (assoc value) = (collection at: assoc key) ]. 382184 "keys do: [ :key | self assert: ( result at: key ) = ( collection at: key )] ." 382185 ! ! 382186 382187!TDictionaryKeysValuesAssociationsAccess methodsFor: 'tests - Dictionary keys values associations access' stamp: 'delaunay 5/4/2009 16:42'! 382188testKeys 382189 382190 | collection result | 382191 collection := self nonEmpty. 382192 result := collection keys. 382193 382194 result do: [ :key | self shouldnt: [collection at: key ] raise:Error ]. 382195 self assert: result size = collection size . 382196 382197 self should: [result detect: [:each | (result occurrencesOf: each ) > 1] ] raise: Error. ! ! 382198 382199!TDictionaryKeysValuesAssociationsAccess methodsFor: 'tests - Dictionary keys values associations access' stamp: 'delaunay 5/5/2009 10:05'! 382200testKeysSortedSafely 382201 | collection result | 382202 collection := self nonEmpty. 382203 result := collection keysSortedSafely . 382204 382205 result do: [ :key | self shouldnt: [collection at: key ] raise:Error ]. 382206 self assert: result size = collection size . 382207 382208 self should: [result detect: [:each | (result occurrencesOf: each ) > 1] ] raise: Error. 382209 self assert: result asArray isSorted.! ! 382210 382211!TDictionaryKeysValuesAssociationsAccess methodsFor: 'tests - Dictionary keys values associations access' stamp: 'delaunay 5/4/2009 16:58'! 382212testValues 382213 382214 | collection result | 382215 collection := self nonEmpty . 382216 result := collection values. 382217 382218 self assert: result size = collection size. 382219 result do: [:each | self assert: (collection occurrencesOf:each ) = (result occurrencesOf: each) ]. 382220 ! ! 382221 382222 382223!TDictionaryKeysValuesAssociationsAccess methodsFor: 'tests - fixture' stamp: 'delaunay 5/4/2009 16:59'! 382224test0FixtureDictionaryKeysValuesAssociationsAccess 382225 382226 self shouldnt: [self nonEmpty ] raise: Error. 382227 self deny: self nonEmpty isEmpty .! ! 382228 382229"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 382230 382231TDictionaryKeysValuesAssociationsAccess classTrait 382232 uses: {}! 382233Trait named: #TDictionaryPrintingTest 382234 uses: {} 382235 category: 'CollectionsTests-Unordered'! 382236 382237!TDictionaryPrintingTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/7/2009 19:32'! 382238emptyDict 382239 self explicitRequirement! ! 382240 382241!TDictionaryPrintingTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/7/2009 19:32'! 382242newEmptyDict 382243 self explicitRequirement! ! 382244 382245!TDictionaryPrintingTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/7/2009 19:32'! 382246nonEmptyDict 382247 self explicitRequirement! ! 382248 382249 382250!TDictionaryPrintingTest methodsFor: 'test - printing' stamp: 'PeterHugossonMiller 9/3/2009 11:33'! 382251testPrintElementsOn 382252 | str | 382253 str := String new writeStream. 382254 self nonEmptyDict printElementsOn: str. 382255 self assert: (str contents = '(#a->1 #b->30 #c->1 #d->-2 )')! ! 382256 382257!TDictionaryPrintingTest methodsFor: 'test - printing' stamp: 'PeterHugossonMiller 9/3/2009 11:33'! 382258testStoreOn 382259 | str | 382260 str := String new writeStream. 382261 self nonEmptyDict storeOn: str. 382262 self assert: str contents = '((Dictionary new) add: (#b->30); add: (#c->1); add: (#d->-2); add: (#a->1); yourself)'! ! 382263 382264"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 382265 382266TDictionaryPrintingTest classTrait 382267 uses: {}! 382268Trait named: #TDictionaryRemovingTest 382269 uses: {} 382270 category: 'CollectionsTests-Unordered'! 382271 382272!TDictionaryRemovingTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/7/2009 19:43'! 382273emptyDict 382274 self explicitRequirement! ! 382275 382276!TDictionaryRemovingTest methodsFor: 'requirements' stamp: 'delaunay 5/5/2009 14:53'! 382277keyNotInNonEmptyDict 382278" return a key not included in nonEmptyDict" 382279 self explicitRequirement! ! 382280 382281!TDictionaryRemovingTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/7/2009 19:43'! 382282newEmptyDict 382283 self explicitRequirement! ! 382284 382285!TDictionaryRemovingTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/7/2009 19:43'! 382286nonEmptyDict 382287 self explicitRequirement! ! 382288 382289 382290!TDictionaryRemovingTest methodsFor: 'test - removing' stamp: 'delaunay 5/5/2009 15:19'! 382291testKeysAndValuesRemove 382292 | oldSize collection keyIn | 382293 382294 collection := self nonEmptyDict . 382295 oldSize := collection size. 382296 keyIn := collection keys anyOne. 382297 382298 collection keysAndValuesRemove: [:key :value | key == self keyNotInNonEmptyDict ]. 382299 self assert: (collection size = (oldSize )). 382300 382301 collection keysAndValuesRemove: [:key :value | key == keyIn ]. 382302 self assert: (collection size = (oldSize - 1)). 382303 self should: [ collection at: keyIn ] raise: Error.! ! 382304 382305!TDictionaryRemovingTest methodsFor: 'test - removing' stamp: 'stephane.ducasse 1/8/2009 14:36'! 382306testRemove 382307 382308 self should: [self nonEmptyDict remove: nil] raise: Error. 382309 self should: [self nonEmptyDict remove: nil ifAbsent: ['What ever here']] raise: Error.! ! 382310 382311!TDictionaryRemovingTest methodsFor: 'test - removing' stamp: 'delaunay 5/5/2009 15:22'! 382312testRemoveKey 382313 "self debug: #testRemoveKey" 382314 382315 | collection oldSize keyIn | 382316 collection := self nonEmptyDict . 382317 oldSize := collection size. 382318 keyIn := collection keys anyOne. 382319 382320 collection removeKey: keyIn . 382321 self assert: (collection size = (oldSize - 1)). 382322 self should: [ (collection at: keyIn )] raise: Error. 382323 382324 self should: [collection removeKey: self keyNotInNonEmptyDict ] raise: Error! ! 382325 382326!TDictionaryRemovingTest methodsFor: 'test - removing' stamp: 'delaunay 5/5/2009 15:22'! 382327testRemoveKeyIfAbsent 382328 382329 | collection oldSize keyIn value result | 382330 collection := self nonEmptyDict . 382331 oldSize := collection size. 382332 keyIn := collection keys anyOne. 382333 value := collection at: keyIn . 382334 382335 result := collection removeKey: keyIn ifAbsent: [888]. 382336 382337 self assert: result = value. 382338 self assert: (collection size = (oldSize - 1)). 382339 self should: [ (collection at: keyIn )] raise: Error. 382340 382341 self assert: (collection removeKey: self keyNotInNonEmptyDict ifAbsent: [888] ) = 888.! ! 382342 382343 382344!TDictionaryRemovingTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/5/2009 14:55'! 382345test0FixtureDictionaryRemovingTest 382346 382347self shouldnt: [self nonEmptyDict ] raise: Error. 382348self deny: self nonEmptyDict isEmpty. 382349 382350self shouldnt: [self keyNotInNonEmptyDict ] raise: Error. 382351self deny: (self nonEmptyDict keys includes: self keyNotInNonEmptyDict ).! ! 382352 382353"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 382354 382355TDictionaryRemovingTest classTrait 382356 uses: {}! 382357Trait named: #TDictionaryValueAccessTest 382358 uses: {} 382359 category: 'CollectionsTests-Unordered'! 382360 382361!TDictionaryValueAccessTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 15:52'! 382362keyNotIn 382363" return a key not included in nonEmpty" 382364^ self explicitRequirement! ! 382365 382366!TDictionaryValueAccessTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 15:33'! 382367nonEmpty 382368 382369^ self explicitRequirement! ! 382370 382371 382372!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: 'delaunay 5/4/2009 15:51'! 382373testAt 382374 | collection association | 382375 collection := self nonEmpty . 382376 association := collection associations anyOne. 382377 382378 self assert: (collection at: association key) = association value.! ! 382379 382380!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: 'delaunay 5/4/2009 15:57'! 382381testAtError 382382 "self run: #testAtError" 382383 382384 | dict keyNotIn keyIn | 382385 dict := self nonEmpty . 382386 keyNotIn := self keyNotIn . 382387 keyIn := dict keys anyOne. 382388 382389 self shouldnt: [ dict at: keyIn ] raise: Error. 382390 382391 self should: [ dict at: keyNotIn ] raise: Error. 382392 382393 ! ! 382394 382395!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: 'delaunay 5/5/2009 10:48'! 382396testAtIfAbsent 382397 | collection association | 382398 collection := self nonEmpty . 382399 association := collection associations anyOne. 382400 382401 self assert: (collection at: association key ifAbsent: [ 888 ]) = association value. 382402 self assert: (collection at: self keyNotIn ifAbsent: [ 888 ]) = 888.! ! 382403 382404!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: 'delaunay 5/5/2009 10:52'! 382405testAtIfAbsentPut 382406 | collection association | 382407 collection := self nonEmpty . 382408 association := collection associations anyOne. 382409 382410 collection at: association key ifAbsentPut: [ 888 ]. 382411 self assert: (collection at: association key) = association value. 382412 382413 collection at: self keyNotIn ifAbsentPut: [ 888 ]. 382414 self assert: ( collection at: self keyNotIn ) = 888.! ! 382415 382416!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: 'delaunay 5/4/2009 16:04'! 382417testAtIfPresent 382418 "self run: #testAtIfAbsent" 382419 382420 | t collection association keyNotIn | 382421 collection := self nonEmpty . 382422 association := collection associations anyOne. 382423 keyNotIn := self keyNotIn . 382424 382425 t := false. 382426 self nonEmptyDict at: association key ifPresent: [:x | t := (x = association value)]. 382427 self assert: t. 382428 382429 self assert: (self nonEmptyDict at: association key ifPresent: [:x | 'ABCDEF']) = 'ABCDEF'. 382430 382431 self assert: (self nonEmptyDict at: keyNotIn ifPresent: [:x | Error signal]) isNil 382432! ! 382433 382434!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: 'delaunay 5/5/2009 11:41'! 382435testAtPutDict 382436 "self run: #testAtPutDict" 382437 "self debug: #testAtPutDict" 382438 382439 | adictionary keyIn | 382440 adictionary := self nonEmpty . 382441 keyIn := adictionary keys anyOne. 382442 382443 adictionary at: keyIn put: 'new'. 382444 self assert: (adictionary at: keyIn ) = 'new'. 382445 382446 adictionary at: keyIn put: 'newnew'. 382447 self assert: (adictionary at: keyIn ) = 'newnew'. 382448 382449 adictionary at: self keyNotIn put: 666. 382450 self assert: (adictionary at: self keyNotIn ) = 666.! ! 382451 382452!TDictionaryValueAccessTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: 'delaunay 5/5/2009 11:40'! 382453testAtPutNil 382454 "self run: #testAtPut" 382455 "self debug: #testAtPut" 382456 382457 | dict keyIn | 382458 dict := self nonEmpty . 382459 keyIn := dict keys anyOne. 382460 382461 dict at: nil put: 'new'. 382462 self assert: (dict at: nil) = 'new'. 382463 382464 dict at: keyIn put: nil. 382465 self assert: (dict at: keyIn ) isNil. 382466 382467 dict at: self keyNotIn put: nil. 382468 self assert: ( dict at: self keyNotIn ) isNil. 382469 382470 dict at: nil put: nil. 382471 self assert: (dict at: nil) isNil.! ! 382472 382473 382474!TDictionaryValueAccessTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/4/2009 15:55'! 382475test0FixtureDictionaryElementAccess 382476 382477| in | 382478self shouldnt: [ self nonEmpty ] raise: Error. 382479self deny: self nonEmpty isEmpty. 382480 382481self shouldnt: [ self keyNotIn ] raise: Error. 382482in := true. 382483self nonEmpty keys detect: [ :key | key = self keyNotIn ] ifNone: [ in := false]. 382484self assert: in = false.! ! 382485 382486"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 382487 382488TDictionaryValueAccessTest classTrait 382489 uses: {}! 382490Trait named: #TEasilyThemed 382491 uses: {} 382492 category: 'Polymorph-Widgets'! 382493!TEasilyThemed commentStamp: 'gvc 5/18/2007 11:55' prior: 0! 382494Trait providing useful theme-related methods.! 382495 382496 382497!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/8/2007 15:13'! 382498newAlphaImage: aForm help: helpText 382499 "Answer an alpha image morph." 382500 382501 ^self theme 382502 newAlphaImageIn: self 382503 image: aForm 382504 help: helpText! ! 382505 382506!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/26/2006 11:39'! 382507newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText 382508 "Answer an alpha channel selector with the given selectors." 382509 382510 ^self theme 382511 newAlphaSelectorIn: self 382512 for: aModel 382513 getAlpha: getSel 382514 setAlpha: setSel 382515 help: helpText! ! 382516 382517!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/5/2006 14:44'! 382518newAutoAcceptTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 382519 "Answer a text editor for the given model." 382520 382521 ^self theme 382522 newAutoAcceptTextEditorIn: self 382523 for: aModel 382524 getText: getSel 382525 setText: setSel 382526 getEnabled: enabledSel! ! 382527 382528!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/3/2009 13:23'! 382529newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText 382530 "Answer a text entry for the given model." 382531 382532 ^self theme 382533 newAutoAcceptTextEntryIn: self 382534 for: aModel 382535 get: getSel 382536 set: setSel 382537 class: aClass 382538 getEnabled: enabledSel 382539 font: aFont 382540 help: helpText! ! 382541 382542!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/18/2006 12:51'! 382543newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText 382544 "Answer a text entry for the given model." 382545 382546 ^self theme 382547 newAutoAcceptTextEntryIn: self 382548 for: aModel 382549 get: getSel 382550 set: setSel 382551 class: aClass 382552 getEnabled: enabledSel 382553 help: helpText! ! 382554 382555!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/27/2009 12:03'! 382556newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText 382557 "Answer a text entry for the given model." 382558 382559 ^self theme 382560 newAutoAcceptTextEntryIn: self 382561 for: aModel 382562 get: getSel 382563 set: setSel 382564 class: String 382565 getEnabled: enabledSel 382566 font: aFont 382567 help: helpText 382568! ! 382569 382570!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/18/2006 13:00'! 382571newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText 382572 "Answer a text entry for the given model." 382573 382574 ^self theme 382575 newAutoAcceptTextEntryIn: self 382576 for: aModel 382577 get: getSel 382578 set: setSel 382579 class: String 382580 getEnabled: enabledSel 382581 help: helpText! ! 382582 382583!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/30/2009 14:07'! 382584newBalloonHelp: aTextStringOrMorph for: aMorph 382585 "Answer a new balloon help with the given contents for aMorph 382586 at a given corner." 382587 382588 ^self theme 382589 newBalloonHelpIn: self 382590 contents: aTextStringOrMorph 382591 for: aMorph 382592 corner: #bottomLeft! ! 382593 382594!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/30/2009 14:07'! 382595newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol 382596 "Answer a new balloon help with the given contents for aMorph 382597 at a given corner." 382598 382599 ^self theme 382600 newBalloonHelpIn: self 382601 contents: aTextStringOrMorph 382602 for: aMorph 382603 corner: cornerSymbol! ! 382604 382605!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/8/2009 13:09'! 382606newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText 382607 "Answer a bracket slider with the given selectors." 382608 382609 ^self theme 382610 newBracketSliderIn: self 382611 for: aModel 382612 getValue: getSel 382613 setValue: setSel 382614 min: minValue 382615 max: maxValue 382616 quantum: quantum 382617 getEnabled: enabledSel 382618 help: helpText! ! 382619 382620!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/8/2009 13:10'! 382621newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText 382622 "Answer a bracket slider with the given selectors." 382623 382624 ^self 382625 newBracketSliderFor: aModel 382626 getValue: getSel 382627 setValue: setSel 382628 min: minValue 382629 max: maxValue 382630 quantum: quantum 382631 getEnabled: nil 382632 help: helpText! ! 382633 382634!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 10/17/2008 13:24'! 382635newButtonFor: aModel action: actionSel getEnabled: enabledSel label: stringOrText help: helpText 382636 "Answer a new button." 382637 382638 ^self 382639 newButtonFor: aModel 382640 getState: nil 382641 action: actionSel 382642 arguments: nil 382643 getEnabled: enabledSel 382644 label: stringOrText 382645 help: helpText! ! 382646 382647!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 10/17/2008 13:24'! 382648newButtonFor: aModel action: actionSel label: stringOrText help: helpText 382649 "Answer a new button." 382650 382651 ^self 382652 newButtonFor: aModel 382653 getState: nil 382654 action: actionSel 382655 arguments: nil 382656 getEnabled: nil 382657 label: stringOrText 382658 help: helpText! ! 382659 382660!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/17/2007 15:22'! 382661newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText 382662 "Answer a new button." 382663 382664 ^self theme 382665 newButtonIn: self for: aModel 382666 getState: stateSel 382667 action: actionSel 382668 arguments: args 382669 getEnabled: enabledSel 382670 getLabel: labelSel 382671 help: helpText! ! 382672 382673!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 10/17/2008 13:24'! 382674newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText 382675 "Answer a new button." 382676 382677 ^self theme 382678 newButtonIn: self for: aModel 382679 getState: stateSel 382680 action: actionSel 382681 arguments: args 382682 getEnabled: enabledSel 382683 label: stringOrText 382684 help: helpText! ! 382685 382686!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/14/2009 15:38'! 382687newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel labelForm: aForm help: helpText 382688 "Answer a new button." 382689 382690 ^self theme 382691 newButtonIn: self for: aModel 382692 getState: stateSel 382693 action: actionSel 382694 arguments: args 382695 getEnabled: enabledSel 382696 label: (AlphaImageMorph new image: aForm) 382697 help: helpText! ! 382698 382699!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 10:20'! 382700newCancelButton 382701 "Answer a new cancel button." 382702 382703 ^self newCancelButtonFor: self! ! 382704 382705!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 10:33'! 382706newCancelButtonFor: aModel 382707 "Answer a new cancel button." 382708 382709 ^self theme 382710 newCancelButtonIn: self 382711 for: aModel! ! 382712 382713!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 10/17/2008 13:24'! 382714newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText 382715 "Answer a checkbox with the given label." 382716 382717 ^self theme 382718 newCheckboxIn: self 382719 for: aModel 382720 getSelected: getSel 382721 setSelected: setSel 382722 getEnabled: enabledSel 382723 label: stringOrText 382724 help: helpText! ! 382725 382726!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 10/17/2008 13:24'! 382727newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText 382728 "Answer a checkbox with the given label." 382729 382730 ^self theme 382731 newCheckboxIn: self 382732 for: aModel 382733 getSelected: getSel 382734 setSelected: setSel 382735 getEnabled: nil 382736 label: stringOrText 382737 help: helpText! ! 382738 382739!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 10:20'! 382740newCloseButton 382741 "Answer a new close button." 382742 382743 ^self newCloseButtonFor: self ! ! 382744 382745!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 10:20'! 382746newCloseButtonFor: aModel 382747 "Answer a new close button." 382748 382749 ^self theme 382750 newCloseButtonIn: self 382751 for: aModel! ! 382752 382753!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/22/2006 09:24'! 382754newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText 382755 "Answer a color chooser with the given selectors." 382756 382757 ^self theme 382758 newColorChooserIn: self 382759 for: aModel 382760 getColor: getSel 382761 setColor: setSel 382762 getEnabled: enabledSel 382763 help: helpText! ! 382764 382765!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/8/2007 16:34'! 382766newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText 382767 "Answer a color chooser with the given selectors." 382768 382769 ^self theme 382770 newColorChooserIn: self 382771 for: aModel 382772 getColor: getSel 382773 setColor: setSel 382774 getEnabled: nil 382775 help: helpText! ! 382776 382777!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 10:30'! 382778newColorPickerFor: target getter: getterSymbol setter: setterSymbol 382779 "Answer a new color picker for the given morph and accessors." 382780 382781 ^self theme 382782 newColorPickerIn: self 382783 for: target 382784 getter: getterSymbol 382785 setter: setterSymbol! ! 382786 382787!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/22/2006 09:44'! 382788newColorPresenterFor: aModel getColor: getSel help: helpText 382789 "Answer a color presenter with the given selectors." 382790 382791 ^self theme 382792 newColorPresenterIn: self 382793 for: aModel 382794 getColor: getSel 382795 help: helpText! ! 382796 382797!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 10:21'! 382798newColumn: controls 382799 "Answer a morph laid out with a column of controls." 382800 382801 ^self theme 382802 newColumnIn: self 382803 for: controls! ! 382804 382805!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 5/15/2007 17:39'! 382806newDialogPanel 382807 "Answer a new main dialog panel." 382808 382809 ^self theme 382810 newDialogPanelIn: self! ! 382811 382812!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/8/2007 16:03'! 382813newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText 382814 "Answer a drop list for the given model." 382815 382816 ^self theme 382817 newDropListIn: self 382818 for: aModel 382819 list: listSel 382820 getSelected: getSel 382821 setSelected: setSel 382822 getEnabled: enabledSel 382823 useIndex: true 382824 help: helpText! ! 382825 382826!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/8/2007 16:03'! 382827newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 382828 "Answer a drop list for the given model." 382829 382830 ^self theme 382831 newDropListIn: self 382832 for: aModel 382833 list: listSel 382834 getSelected: getSel 382835 setSelected: setSel 382836 getEnabled: enabledSel 382837 useIndex: useIndex 382838 help: helpText! ! 382839 382840!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/8/2007 16:03'! 382841newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText 382842 "Answer a drop list for the given model." 382843 382844 ^self 382845 newDropListFor: aModel 382846 list: listSel 382847 getSelected: getSel 382848 setSelected: setSel 382849 getEnabled: nil 382850 useIndex: true 382851 help: helpText! ! 382852 382853!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/16/2007 14:14'! 382854newEmbeddedMenu 382855 "Answer a new menu." 382856 382857 ^self theme 382858 newEmbeddedMenuIn: self 382859 for: self! ! 382860 382861!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 16:21'! 382862newExpander: aString 382863 "Answer an expander with the given label." 382864 382865 ^self theme 382866 newExpanderIn: self 382867 label: aString 382868 forAll: #()! ! 382869 382870!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 16:20'! 382871newExpander: aString for: aControl 382872 "Answer an expander with the given label and control." 382873 382874 ^self theme 382875 newExpanderIn: self 382876 label: aString 382877 forAll: {aControl}! ! 382878 382879!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 16:21'! 382880newExpander: aString forAll: controls 382881 "Answer an expander with the given label and controls." 382882 382883 ^self theme 382884 newExpanderIn: self 382885 label: aString 382886 forAll: controls! ! 382887 382888!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 13:00'! 382889newFuzzyLabel: aString 382890 "Answer a new fuzzy label." 382891 382892 ^self theme 382893 newFuzzyLabelIn: self 382894 for: nil 382895 label: aString 382896 offset: 1 382897 alpha: 0.5 382898 getEnabled: nil! ! 382899 382900!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 13:00'! 382901newFuzzyLabelFor: aModel label: aString getEnabled: enabledSel 382902 "Answer a new fuzzy label." 382903 382904 ^self theme 382905 newFuzzyLabelIn: self 382906 for: aModel 382907 label: aString 382908 offset: 1 382909 alpha: 0.5 382910 getEnabled: enabledSel! ! 382911 382912!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 13:00'! 382913newFuzzyLabelFor: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel 382914 "Answer a new fuzzy label." 382915 382916 ^self theme 382917 newFuzzyLabelIn: self 382918 for: aModel 382919 label: aString 382920 offset: offset 382921 alpha: alpha 382922 getEnabled: enabledSel! ! 382923 382924!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 15:56'! 382925newGroupbox 382926 "Answer a plain groupbox." 382927 382928 ^self theme 382929 newGroupboxIn: self! ! 382930 382931!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 10:21'! 382932newGroupbox: aString 382933 "Answer a groupbox with the given label." 382934 382935 ^self theme 382936 newGroupboxIn: self 382937 label: aString! ! 382938 382939!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 10:22'! 382940newGroupbox: aString for: control 382941 "Answer a groupbox with the given label and control." 382942 382943 ^self theme 382944 newGroupboxIn: self 382945 label: aString 382946 for: control! ! 382947 382948!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 10:22'! 382949newGroupbox: aString forAll: controls 382950 "Answer a groupbox with the given label and controls." 382951 382952 ^self theme 382953 newGroupboxIn: self 382954 label: aString 382955 forAll: controls! ! 382956 382957!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 15:57'! 382958newGroupboxFor: control 382959 "Answer a plain groupbox with the given control." 382960 382961 ^self theme 382962 newGroupboxIn: self 382963 for: control! ! 382964 382965!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/10/2007 10:33'! 382966newGroupboxForAll: controls 382967 "Answer a plain groupbox with the given controls." 382968 382969 ^self theme 382970 newGroupboxIn: self 382971 forAll: controls! ! 382972 382973!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/8/2007 14:59'! 382974newHSVASelector: aColor help: helpText 382975 "Answer a hue-saturation-volume selector with the given color." 382976 382977 ^self theme 382978 newHSVASelectorIn: self 382979 color: aColor 382980 help: helpText! ! 382981 382982!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/8/2007 14:46'! 382983newHSVSelector: aColor help: helpText 382984 "Answer a hue-saturation-volume selector with the given color." 382985 382986 ^self theme 382987 newHSVSelectorIn: self 382988 color: aColor 382989 help: helpText! ! 382990 382991!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/7/2007 16:28'! 382992newHueSelector: aModel getHue: getSel setHue: setSel help: helpText 382993 "Answer a hue selector with the given selectors." 382994 382995 ^self theme 382996 newHueSelectorIn: self 382997 for: aModel 382998 getHue: getSel 382999 setHue: setSel 383000 help: helpText! ! 383001 383002!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/25/2006 15:36'! 383003newImage: aForm 383004 "Answer a new image." 383005 383006 ^self theme 383007 newImageIn: self 383008 form: aForm! ! 383009 383010!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 10/11/2006 13:13'! 383011newImage: aForm size: aPoint 383012 "Answer a new image." 383013 383014 ^self theme 383015 newImageIn: self 383016 form: aForm 383017 size: aPoint! ! 383018 383019!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/2/2009 15:00'! 383020newIncrementalSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText 383021 "Answer an inremental slider with the given selectors." 383022 383023 ^self theme 383024 newIncrementalSliderIn: self 383025 for: aModel 383026 getValue: getSel 383027 setValue: setSel 383028 min: min 383029 max: max 383030 quantum: quantum 383031 getEnabled: enabledSel 383032 help: helpText! ! 383033 383034!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/16/2007 15:51'! 383035newLabel: aString 383036 "Answer a new text label." 383037 383038 ^self 383039 newLabelFor: nil 383040 label: aString 383041 getEnabled: nil! ! 383042 383043!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/16/2007 15:50'! 383044newLabelFor: aModel label: aString getEnabled: enabledSel 383045 "Answer a new text label." 383046 383047 ^self theme 383048 newLabelIn: self 383049 for: aModel 383050 label: aString 383051 getEnabled: enabledSel! ! 383052 383053!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 13:22'! 383054newLabelGroup: labelsAndControls 383055 "Answer a morph laid out with a column of labels and a column of associated controls." 383056 383057 ^self theme 383058 newLabelGroupIn: self 383059 for: labelsAndControls 383060 spaceFill: false! ! 383061 383062!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/27/2009 12:01'! 383063newLabelGroup: labelsAndControls font: aFont labelColor: aColor 383064 "Answer a morph laid out with a column of labels and a column of associated controls." 383065 383066 ^self theme 383067 newLabelGroupIn: self 383068 for: labelsAndControls 383069 spaceFill: false 383070 font: aFont 383071 labelColor: aColor 383072! ! 383073 383074!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 13:23'! 383075newLabelGroupSpread: labelsAndControls 383076 "Answer a morph laid out with a column of labels and a column of associated controls." 383077 383078 ^self theme 383079 newLabelGroupIn: self 383080 for: labelsAndControls 383081 spaceFill: true! ! 383082 383083!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/7/2007 11:45'! 383084newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText 383085 "Answer a list for the given model." 383086 383087 ^self theme 383088 newListIn: self 383089 for: aModel 383090 list: listSelector 383091 selected: getSelector 383092 changeSelected: setSelector 383093 getEnabled: enabledSel 383094 help: helpText! ! 383095 383096!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/7/2007 11:48'! 383097newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText 383098 "Answer a list for the given model." 383099 383100 ^self 383101 newListFor: aModel 383102 list: listSelector 383103 selected: getSelector 383104 changeSelected: setSelector 383105 getEnabled: nil 383106 help: helpText! ! 383107 383108!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 10/12/2006 16:09'! 383109newMenu 383110 "Answer a new menu." 383111 383112 ^self theme 383113 newMenuIn: self 383114 for: self! ! 383115 383116!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 10/12/2006 16:09'! 383117newMenuFor: aModel 383118 "Answer a new menu." 383119 383120 ^self theme 383121 newMenuIn: self 383122 for: aModel! ! 383123 383124!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 13:32'! 383125newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText 383126 "Answer a morph drop list for the given model." 383127 383128 ^self 383129 newMorphDropListFor: aModel 383130 list: listSel 383131 getSelected: getSel 383132 setSelected: setSel 383133 getEnabled: enabledSel 383134 useIndex: true 383135 help: helpText! ! 383136 383137!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/8/2007 16:58'! 383138newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 383139 "Answer a morph drop list for the given model." 383140 383141 ^self theme 383142 newMorphDropListIn: self 383143 for: aModel 383144 list: listSel 383145 getSelected: getSel 383146 setSelected: setSel 383147 getEnabled: enabledSel 383148 useIndex: useIndex 383149 help: helpText! ! 383150 383151!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 13:32'! 383152newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText 383153 "Answer a morph drop list for the given model." 383154 383155 ^self 383156 newMorphDropListFor: aModel 383157 list: listSel 383158 getSelected: getSel 383159 setSelected: setSel 383160 getEnabled: nil 383161 useIndex: true 383162 help: helpText! ! 383163 383164!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 13:27'! 383165newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText 383166 "Answer a morph list for the given model." 383167 383168 ^self theme 383169 newMorphListIn: self 383170 for: aModel 383171 list: listSelector 383172 getSelected: getSelector 383173 setSelected: setSelector 383174 getEnabled: enabledSel 383175 help: helpText! ! 383176 383177!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 13:28'! 383178newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText 383179 "Answer a morph list for the given model." 383180 383181 ^self 383182 newMorphListFor: aModel 383183 list: listSelector 383184 getSelected: getSelector 383185 setSelected: setSelector 383186 getEnabled: nil 383187 help: helpText! ! 383188 383189!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/10/2007 14:25'! 383190newNoButton 383191 "Answer a new No button." 383192 383193 ^self newNoButtonFor: self! ! 383194 383195!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/10/2007 14:26'! 383196newNoButtonFor: aModel 383197 "Answer a new No button." 383198 383199 ^self theme 383200 newNoButtonIn: self 383201 for: aModel! ! 383202 383203!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 10:23'! 383204newOKButton 383205 "Answer a new OK button." 383206 383207 ^self newOKButtonFor: self! ! 383208 383209!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 3/23/2007 15:58'! 383210newOKButtonFor: aModel 383211 "Answer a new OK button." 383212 383213 ^self 383214 newOKButtonFor: aModel 383215 getEnabled: nil! ! 383216 383217!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 3/23/2007 15:56'! 383218newOKButtonFor: aModel getEnabled: enabledSel 383219 "Answer a new OK button." 383220 383221 ^self theme 383222 newOKButtonIn: self 383223 for: aModel 383224 getEnabled: enabledSel! ! 383225 383226!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 5/15/2007 17:40'! 383227newPanel 383228 "Answer a new panel." 383229 383230 ^self theme 383231 newPanelIn: self! ! 383232 383233!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/2/2007 10:39'! 383234newPluggableDialogWindow 383235 "Answer a new pluggable dialog." 383236 383237 ^self 383238 newPluggableDialogWindow: 'Dialog'! ! 383239 383240!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/2/2007 10:38'! 383241newPluggableDialogWindow: title 383242 "Answer a new pluggable dialog with the given content." 383243 383244 ^self 383245 newPluggableDialogWindow: title 383246 for: nil! ! 383247 383248!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/2/2007 10:38'! 383249newPluggableDialogWindow: title for: contentMorph 383250 "Answer a new pluggable dialog with the given content." 383251 383252 ^self theme 383253 newPluggableDialogWindowIn: self 383254 title: title 383255 for: contentMorph! ! 383256 383257!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 10/17/2008 13:25'! 383258newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText 383259 "Answer a checkbox (radio button appearance) with the given label." 383260 383261 ^self theme 383262 newRadioButtonIn: self 383263 for: aModel 383264 getSelected: getSel 383265 setSelected: setSel 383266 getEnabled: enabledSel 383267 label: stringOrText 383268 help: helpText! ! 383269 383270!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 10/17/2008 13:25'! 383271newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText 383272 "Answer a checkbox (radio button appearance) with the given label." 383273 383274 ^self 383275 newRadioButtonFor: aModel 383276 getSelected: getSel 383277 setSelected: setSel 383278 getEnabled: nil 383279 label: stringOrText 383280 help: helpText! ! 383281 383282!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/15/2007 17:48'! 383283newRow 383284 "Answer a morph laid out as a row." 383285 383286 ^self theme 383287 newRowIn: self 383288 for: #()! ! 383289 383290!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 10:27'! 383291newRow: controls 383292 "Answer a morph laid out with a row of controls." 383293 383294 ^self theme 383295 newRowIn: self 383296 for: controls! ! 383297 383298!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/8/2007 14:38'! 383299newSVSelector: aColor help: helpText 383300 "Answer a saturation-volume selector with the given color." 383301 383302 ^self theme 383303 newSVSelectorIn: self 383304 color: aColor 383305 help: helpText! ! 383306 383307!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/15/2007 15:41'! 383308newSeparator 383309 "Answer an horizontal separator." 383310 383311 ^self theme 383312 newSeparatorIn: self! ! 383313 383314!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 11:30'! 383315newSliderFor: aModel getValue: getSel setValue: setSel getEnabled: enabledSel help: helpText 383316 "Answer a slider with the given selectors." 383317 383318 ^self theme 383319 newSliderIn: self 383320 for: aModel 383321 getValue: getSel 383322 setValue: setSel 383323 min: 0 383324 max: 1 383325 quantum: nil 383326 getEnabled: enabledSel 383327 help: helpText! ! 383328 383329!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 13:13'! 383330newSliderFor: aModel getValue: getSel setValue: setSel help: helpText 383331 "Answer a slider with the given selectors." 383332 383333 ^self theme 383334 newSliderIn: self 383335 for: aModel 383336 getValue: getSel 383337 setValue: setSel 383338 min: 0 383339 max: 1 383340 quantum: nil 383341 getEnabled: nil 383342 help: helpText! ! 383343 383344!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 11:28'! 383345newSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText 383346 "Answer a slider with the given selectors." 383347 383348 ^self theme 383349 newSliderIn: self 383350 for: aModel 383351 getValue: getSel 383352 setValue: setSel 383353 min: min 383354 max: max 383355 quantum: quantum 383356 getEnabled: enabledSel 383357 help: helpText! ! 383358 383359!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 11:42'! 383360newString: aStringOrText 383361 "Answer a new embossed string." 383362 383363 ^self theme 383364 newStringIn: self 383365 label: aStringOrText 383366 font: self theme labelFont 383367 style: #plain! ! 383368 383369!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 11:42'! 383370newString: aStringOrText font: aFont style: aStyle 383371 "Answer a new embossed string." 383372 383373 ^self theme 383374 newStringIn: self 383375 label: aStringOrText 383376 font: aFont 383377 style: aStyle! ! 383378 383379!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/9/2007 11:43'! 383380newString: aStringOrText style: aStyle 383381 "Answer a new embossed string." 383382 383383 ^self theme 383384 newStringIn: self 383385 label: aStringOrText 383386 font: self theme labelFont 383387 style: aStyle! ! 383388 383389!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/16/2006 08:41'! 383390newTabGroup: labelsAndPages 383391 "Answer a tab group with the given tab labels associated with pages." 383392 383393 ^self theme 383394 newTabGroupIn: self 383395 for: labelsAndPages! ! 383396 383397!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 4/11/2007 16:25'! 383398newText: aStringOrText 383399 "Answer a new text." 383400 383401 ^self theme 383402 newTextIn: self 383403 text: aStringOrText! ! 383404 383405!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/7/2007 12:50'! 383406newTextEditorFor: aModel getText: getSel setText: setSel 383407 "Answer a text editor for the given model." 383408 383409 ^self 383410 newTextEditorFor: aModel 383411 getText: getSel 383412 setText: setSel 383413 getEnabled: nil! ! 383414 383415!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/5/2006 14:51'! 383416newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel 383417 "Answer a text editor for the given model." 383418 383419 ^self theme 383420 newTextEditorIn: self 383421 for: aModel 383422 getText: getSel 383423 setText: setSel 383424 getEnabled: enabledSel ! ! 383425 383426!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/18/2006 12:56'! 383427newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText 383428 "Answer a text entry for the given model." 383429 383430 ^self theme 383431 newTextEntryIn: self 383432 for: aModel 383433 get: getSel 383434 set: setSel 383435 class: aClass 383436 getEnabled: enabledSel 383437 help: helpText! ! 383438 383439!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/18/2006 13:00'! 383440newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText 383441 "Answer a text entry for the given model." 383442 383443 ^self theme 383444 newTextEntryIn: self 383445 for: aModel 383446 get: getSel 383447 set: setSel 383448 class: String 383449 getEnabled: enabledSel 383450 help: helpText! ! 383451 383452!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/7/2007 12:50'! 383453newTextEntryFor: aModel getText: getSel setText: setSel help: helpText 383454 "Answer a text entry for the given model." 383455 383456 ^self 383457 newTextEntryFor: aModel 383458 get: getSel 383459 set: setSel 383460 class: String 383461 getEnabled: nil 383462 help: helpText! ! 383463 383464!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 10:28'! 383465newTitle: aString for: control 383466 "Answer a morph laid out with a column with a title." 383467 383468 ^self theme 383469 newTitleIn: self 383470 label: aString 383471 for: control! ! 383472 383473!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 6/20/2007 09:38'! 383474newToolDockingBar 383475 "Answer a tool docking bar." 383476 383477 ^self theme 383478 newToolDockingBarIn: self! ! 383479 383480!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/19/2006 10:07'! 383481newToolSpacer 383482 "Answer a tool spacer." 383483 383484 ^self theme 383485 newToolSpacerIn: self! ! 383486 383487!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/19/2006 10:06'! 383488newToolbar 383489 "Answer a toolbar." 383490 383491 ^self theme 383492 newToolbarIn: self! ! 383493 383494!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/19/2006 10:07'! 383495newToolbar: controls 383496 "Answer a toolbar with the given controls." 383497 383498 ^self theme 383499 newToolbarIn: self 383500 for: controls! ! 383501 383502!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 9/19/2006 10:08'! 383503newToolbarHandle 383504 "Answer a toolbar handle." 383505 383506 ^self theme 383507 newToolbarHandleIn: self! ! 383508 383509!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/25/2006 10:28'! 383510newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector 383511 "Answer a new tree morph." 383512 383513 ^self theme 383514 newTreeIn: self 383515 for: aModel 383516 list: listSelector 383517 selected: getSelector 383518 changeSelected: setSelector! ! 383519 383520!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 8/7/2007 11:55'! 383521newVerticalSeparator 383522 "Answer a vertical separator." 383523 383524 ^self theme 383525 newVerticalSeparatorIn: self! ! 383526 383527!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/10/2007 14:25'! 383528newYesButton 383529 "Answer a new Yes button." 383530 383531 ^self newYesButtonFor: self! ! 383532 383533!TEasilyThemed methodsFor: 'controls' stamp: 'gvc 1/10/2007 14:23'! 383534newYesButtonFor: aModel 383535 "Answer a new yes button." 383536 383537 ^self theme 383538 newYesButtonIn: self 383539 for: aModel! ! 383540 383541 383542!TEasilyThemed methodsFor: 'services' stamp: 'gvc 5/18/2007 14:55'! 383543abort: aStringOrText 383544 "Open an error dialog." 383545 383546 ^self abort: aStringOrText title: 'Error' translated! ! 383547 383548!TEasilyThemed methodsFor: 'services' stamp: 'gvc 5/18/2007 14:55'! 383549abort: aStringOrText title: aString 383550 "Open an error dialog." 383551 383552 ^self theme 383553 abortIn: self 383554 text: aStringOrText 383555 title: aString! ! 383556 383557!TEasilyThemed methodsFor: 'services' stamp: 'gvc 8/30/2006 09:37'! 383558alert: aStringOrText 383559 "Open an alert dialog." 383560 383561 ^self alert: aStringOrText title: 'Alert' translated! ! 383562 383563!TEasilyThemed methodsFor: 'services' stamp: 'gvc 8/12/2009 18:15'! 383564alert: aStringOrText title: aString 383565 "Open an alert dialog." 383566 383567 ^self 383568 alert: aStringOrText 383569 title: aString 383570 configure: [:d | ]! ! 383571 383572!TEasilyThemed methodsFor: 'services' stamp: 'gvc 8/12/2009 18:15'! 383573alert: aStringOrText title: aString configure: aBlock 383574 "Open an alert dialog. 383575 Configure the dialog with the 1 argument block 383576 before opening modally." 383577 383578 ^self theme 383579 alertIn: self 383580 text: aStringOrText 383581 title: aString 383582 configure: aBlock! ! 383583 383584!TEasilyThemed methodsFor: 'services' stamp: 'gvc 5/3/2007 14:19'! 383585chooseColor 383586 "Answer the result of a color selector dialog ." 383587 383588 ^self chooseColor: Color black! ! 383589 383590!TEasilyThemed methodsFor: 'services' stamp: 'gvc 5/3/2007 13:38'! 383591chooseColor: aColor 383592 "Answer the result of a color selector dialog with the given color." 383593 383594 ^self theme 383595 chooseColorIn: self 383596 title: 'Colour Selector' translated 383597 color: aColor! ! 383598 383599!TEasilyThemed methodsFor: 'services' stamp: 'gvc 9/22/2006 11:04'! 383600chooseColor: aColor title: title 383601 "Answer the result of a color selector dialog with the given title and initial colour." 383602 383603 ^self theme 383604 chooseColorIn: self 383605 title: title 383606 color: aColor! ! 383607 383608!TEasilyThemed methodsFor: 'services' stamp: 'gvc 4/2/2007 15:34'! 383609chooseDirectory: title 383610 "Answer the result of a file dialog with the given title, answer a directory." 383611 383612 ^self 383613 chooseDirectory: title 383614 path: nil! ! 383615 383616!TEasilyThemed methodsFor: 'services' stamp: 'gvc 1/15/2007 14:45'! 383617chooseDirectory: title path: path 383618 "Answer the result of a file dialog with the given title, answer a directory." 383619 383620 ^self theme 383621 chooseDirectoryIn: self 383622 title: title 383623 path: path! ! 383624 383625!TEasilyThemed methodsFor: 'services' stamp: 'gvc 1/12/2007 14:24'! 383626chooseDropList: aStringOrText list: aList 383627 "Open a drop list chooser dialog." 383628 383629 ^self 383630 chooseDropList: aStringOrText 383631 title: 'Choose' translated 383632 list: aList! ! 383633 383634!TEasilyThemed methodsFor: 'services' stamp: 'gvc 1/12/2007 14:23'! 383635chooseDropList: aStringOrText title: aString list: aList 383636 "Open a drop list chooser dialog." 383637 383638 ^self theme 383639 chooseDropListIn: self 383640 text: aStringOrText 383641 title: aString 383642 list: aList! ! 383643 383644!TEasilyThemed methodsFor: 'services' stamp: 'gvc 4/4/2007 16:08'! 383645chooseFileName: title extensions: exts path: path preview: preview 383646 "Answer the result of a file name chooser dialog with the given title, extensions 383647 to show, path and preview type." 383648 383649 ^self theme 383650 chooseFileNameIn: self 383651 title: title 383652 extensions: exts 383653 path: path 383654 preview: preview! ! 383655 383656!TEasilyThemed methodsFor: 'services' stamp: 'gvc 5/3/2007 13:38'! 383657chooseFont 383658 "Answer the result of a font selector dialog." 383659 383660 ^self chooseFont: nil! ! 383661 383662!TEasilyThemed methodsFor: 'services' stamp: 'gvc 5/3/2007 13:38'! 383663chooseFont: aFont 383664 "Answer the result of a font selector dialog with the given initial font." 383665 383666 ^self theme 383667 chooseFontIn: self 383668 title: 'Font Selector' translated 383669 font: aFont! ! 383670 383671!TEasilyThemed methodsFor: 'services' stamp: 'gvc 1/10/2007 11:13'! 383672deny: aStringOrText 383673 "Open a denial dialog." 383674 383675 ^self deny: aStringOrText title: 'Access Denied' translated! ! 383676 383677!TEasilyThemed methodsFor: 'services' stamp: 'gvc 1/10/2007 11:13'! 383678deny: aStringOrText title: aString 383679 "Open a denial dialog." 383680 383681 ^self theme 383682 denyIn: self 383683 text: aStringOrText 383684 title: aString! ! 383685 383686!TEasilyThemed methodsFor: 'services' stamp: 'gvc 8/31/2006 15:32'! 383687fileOpen: title 383688 "Answer the result of a file open dialog with the given title." 383689 383690 ^self 383691 fileOpen: title 383692 extensions: nil! ! 383693 383694!TEasilyThemed methodsFor: 'services' stamp: 'gvc 9/27/2006 10:33'! 383695fileOpen: title extensions: exts 383696 "Answer the result of a file open dialog with the given title and extensions to show." 383697 383698 ^self 383699 fileOpen: title 383700 extensions: exts 383701 path: nil! ! 383702 383703!TEasilyThemed methodsFor: 'services' stamp: 'gvc 12/18/2006 11:21'! 383704fileOpen: title extensions: exts path: path 383705 "Answer the result of a file open dialog with the given title, extensions to show and path." 383706 383707 ^self 383708 fileOpen: title 383709 extensions: exts 383710 path: path 383711 preview: nil! ! 383712 383713!TEasilyThemed methodsFor: 'services' stamp: 'gvc 9/27/2006 13:38'! 383714fileOpen: title extensions: exts path: path preview: preview 383715 "Answer the result of a file open dialog with the given title, extensions to show, path and preview type." 383716 383717 ^self theme 383718 fileOpenIn: self 383719 title: title 383720 extensions: exts 383721 path: path 383722 preview: preview! ! 383723 383724!TEasilyThemed methodsFor: 'services' stamp: 'gvc 9/27/2006 10:33'! 383725fileSave: title 383726 "Answer the result of a file save dialog with the given title." 383727 383728 ^self 383729 fileSave: title 383730 extensions: nil 383731 path: nil! ! 383732 383733!TEasilyThemed methodsFor: 'services' stamp: 'gvc 9/27/2006 10:33'! 383734fileSave: title extensions: exts 383735 "Answer the result of a file save dialog with the given title." 383736 383737 ^self 383738 fileSave: title 383739 extensions: exts 383740 path: nil! ! 383741 383742!TEasilyThemed methodsFor: 'services' stamp: 'gvc 9/27/2006 10:33'! 383743fileSave: title extensions: exts path: path 383744 "Answer the result of a file save dialog with the given title, extensions to show and path." 383745 383746 ^self theme 383747 fileSaveIn: self 383748 title: title 383749 extensions: exts 383750 path: path! ! 383751 383752!TEasilyThemed methodsFor: 'services' stamp: 'gvc 8/31/2006 15:32'! 383753fileSave: title path: path 383754 "Answer the result of a file save open dialog with the given title." 383755 383756 ^self 383757 fileSave: title 383758 extensions: nil 383759 path: path! ! 383760 383761!TEasilyThemed methodsFor: 'services' stamp: 'gvc 4/15/2008 22:58'! 383762longMessage: aStringOrText title: aString 383763 "Open a (long) message dialog." 383764 383765 ^self theme 383766 longMessageIn: self 383767 text: aStringOrText 383768 title: aString! ! 383769 383770!TEasilyThemed methodsFor: 'services' stamp: 'gvc 8/29/2006 16:51'! 383771message: aStringOrText 383772 "Open a message dialog." 383773 383774 ^self message: aStringOrText title: 'Information' translated! ! 383775 383776!TEasilyThemed methodsFor: 'services' stamp: 'gvc 8/27/2006 10:24'! 383777message: aStringOrText title: aString 383778 "Open a message dialog." 383779 383780 ^self theme 383781 messageIn: self 383782 text: aStringOrText 383783 title: aString! ! 383784 383785!TEasilyThemed methodsFor: 'services' stamp: 'gvc 1/10/2007 14:28'! 383786proceed: aStringOrText 383787 "Open a proceed dialog." 383788 383789 ^self proceed: aStringOrText title: 'Proceed' translated! ! 383790 383791!TEasilyThemed methodsFor: 'services' stamp: 'gvc 8/25/2006 16:20'! 383792proceed: aStringOrText title: aString 383793 "Open a proceed dialog and answer true if not cancelled, false otherwise." 383794 383795 ^self theme 383796 proceedIn: self 383797 text: aStringOrText 383798 title: aString! ! 383799 383800!TEasilyThemed methodsFor: 'services' stamp: 'gvc 1/10/2007 14:28'! 383801question: aStringOrText 383802 "Open a question dialog." 383803 383804 ^self question: aStringOrText title: 'Question' translated! ! 383805 383806!TEasilyThemed methodsFor: 'services' stamp: 'gvc 2/28/2007 12:35'! 383807question: aStringOrText title: aString 383808 "Open a question dialog and answer true if yes, 383809 false if no and nil if cancelled." 383810 383811 ^self theme 383812 questionIn: self 383813 text: aStringOrText 383814 title: aString! ! 383815 383816!TEasilyThemed methodsFor: 'services' stamp: 'gvc 1/10/2007 14:46'! 383817questionWithoutCancel: aStringOrText 383818 "Open a question dialog." 383819 383820 ^self questionWithoutCancel: aStringOrText title: 'Question' translated! ! 383821 383822!TEasilyThemed methodsFor: 'services' stamp: 'gvc 2/28/2007 12:35'! 383823questionWithoutCancel: aStringOrText title: aString 383824 "Open a question dialog and answer true if yes, 383825 false if no and nil if cancelled." 383826 383827 ^self theme 383828 questionWithoutCancelIn: self 383829 text: aStringOrText 383830 title: aString! ! 383831 383832!TEasilyThemed methodsFor: 'services' stamp: 'gvc 1/10/2007 10:44'! 383833textEntry: aStringOrText 383834 "Open a text entry dialog." 383835 383836 ^self textEntry: aStringOrText title: 'Entry' translated! ! 383837 383838!TEasilyThemed methodsFor: 'services' stamp: 'gvc 1/10/2007 10:45'! 383839textEntry: aStringOrText title: aString 383840 "Open a text entry dialog." 383841 383842 ^self 383843 textEntry: aStringOrText 383844 title: aString 383845 entryText: ''! ! 383846 383847!TEasilyThemed methodsFor: 'services' stamp: 'gvc 1/10/2007 10:43'! 383848textEntry: aStringOrText title: aString entryText: defaultEntryText 383849 "Open a text entry dialog." 383850 383851 ^self theme 383852 textEntryIn: self 383853 text: aStringOrText 383854 title: aString 383855 entryText: defaultEntryText! ! 383856 383857 383858!TEasilyThemed methodsFor: 'theme' stamp: 'gvc 8/24/2006 18:44'! 383859theme 383860 "Answer the ui theme that provides controls." 383861 383862 ^UITheme current! ! 383863 383864"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 383865 383866TEasilyThemed classTrait 383867 uses: {}! 383868Trait named: #TEmptySequenceableTest 383869 uses: {} 383870 category: 'CollectionsTests-Abstract'! 383871 383872!TEmptySequenceableTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/5/2008 13:06'! 383873accessValuePutIn 383874 "return access the element put in the non-empty collection" 383875 383876 ^ self perform: self selectorToAccessValuePutIn! ! 383877 383878!TEmptySequenceableTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/5/2008 13:06'! 383879accessValuePutInOn: s 383880 383881 "return access the element put in the non-empty collection" 383882 383883 ^ s perform: self selectorToAccessValuePutIn! ! 383884 383885!TEmptySequenceableTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/5/2008 13:06'! 383886valuePutIn 383887 "the value that we will put in the non empty collection" 383888 383889 ^ #x! ! 383890 383891 383892!TEmptySequenceableTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/19/2009 18:12'! 383893empty 383894 383895 ^ self explicitRequirement! ! 383896 383897!TEmptySequenceableTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/19/2009 18:12'! 383898nonEmpty 383899 383900 ^ self explicitRequirement! ! 383901 383902!TEmptySequenceableTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/5/2008 13:05'! 383903selectorToAccessValuePutIn 383904 "return the selector of the method that should be invoked to access an element" 383905 383906 ^ self explicitRequirement! ! 383907 383908 383909!TEmptySequenceableTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/12/2009 14:57'! 383910test0FixtureEmptySequenceableTest 383911 383912self shouldnt: [ self nonEmpty ] raise: Error. 383913self deny: self nonEmpty isEmpty . 383914 383915self shouldnt: [ self empty ] raise: Error. 383916self assert: self empty isEmpty.! ! 383917 383918 383919!TEmptySequenceableTest methodsFor: 'tests - sequence isempty' stamp: 'stephane.ducasse 10/5/2008 12:57'! 383920testSequenceAbleIfEmptyifNotEmptyDo 383921 "self debug: #testSequenceAbleIfEmptyifNotEmptyDo" 383922 383923 self assert: (self nonEmpty 383924 ifEmpty: [false] 383925 ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! 383926 383927!TEmptySequenceableTest methodsFor: 'tests - sequence isempty' stamp: 'stephane.ducasse 10/5/2008 12:59'! 383928testSequenceIfEmptyifNotEmptyDo 383929 "self debug #testSequenceIfEmptyifNotEmptyDo" 383930 383931 self assert: (self nonEmpty 383932 ifEmpty: [false] 383933 ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! 383934 383935!TEmptySequenceableTest methodsFor: 'tests - sequence isempty' stamp: 'stephane.ducasse 10/5/2008 13:02'! 383936testSequenceIfNotEmpty 383937 383938 self assert: (self nonEmpty 383939 ifNotEmpty: [:s | self accessValuePutInOn: s]) = self valuePutIn! ! 383940 383941!TEmptySequenceableTest methodsFor: 'tests - sequence isempty' stamp: 'stephane.ducasse 10/5/2008 13:03'! 383942testSequenceIfNotEmptyDo 383943 383944 self empty ifNotEmptyDo: [:s | self assert: false]. 383945 self assert: (self nonEmpty ifNotEmptyDo: [:s | self accessValuePutInOn: s]) = self valuePutIn 383946! ! 383947 383948!TEmptySequenceableTest methodsFor: 'tests - sequence isempty' stamp: 'stephane.ducasse 10/5/2008 13:04'! 383949testSequenceIfNotEmptyDoifNotEmpty 383950 383951 self assert: (self nonEmpty 383952 ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn] 383953 ifEmpty: [false])! ! 383954 383955!TEmptySequenceableTest methodsFor: 'tests - sequence isempty' stamp: 'stephane.ducasse 10/5/2008 13:05'! 383956testSequenceIfNotEmptyifEmpty 383957 383958 self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [:s | (self accessValuePutInOn: s) = self valuePutIn])! ! 383959 383960"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 383961 383962TEmptySequenceableTest classTrait 383963 uses: {}! 383964Trait named: #TEmptyTest 383965 uses: {} 383966 category: 'CollectionsTests-Abstract'! 383967!TEmptyTest commentStamp: 'stephane.ducasse 10/5/2008 12:25' prior: 0! 383968I group a set of tests testing whether a collection is empty. 383969I do not do any assymption on the elements being added since it would 383970bind me to know how to access it. 383971! 383972 383973 383974!TEmptyTest methodsFor: 'requirements' stamp: 'stephane.ducasse 2/14/2009 17:25'! 383975empty 383976 383977 ^ self explicitRequirement! ! 383978 383979!TEmptyTest methodsFor: 'requirements' stamp: 'stephane.ducasse 2/14/2009 17:25'! 383980nonEmpty 383981 383982 ^ self explicitRequirement! ! 383983 383984 383985!TEmptyTest methodsFor: 'tests - empty' stamp: 'delaunay 3/27/2009 11:42'! 383986testIfEmpty 383987 383988 self nonEmpty ifEmpty: [ self assert: false] . 383989 self empty ifEmpty: [ self assert: true] . 383990 383991 383992 ! ! 383993 383994!TEmptyTest methodsFor: 'tests - empty' stamp: 'stephane.ducasse 10/5/2008 12:23'! 383995testIfEmptyifNotEmpty 383996 383997 self assert: (self empty ifEmpty: [true] ifNotEmpty: [false]). 383998 self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [true]). 383999 ! ! 384000 384001!TEmptyTest methodsFor: 'tests - empty' stamp: 'stephane.ducasse 10/5/2008 13:00'! 384002testIfEmptyifNotEmptyDo 384003 "self debug #testIfEmptyifNotEmptyDo" 384004 384005 self assert: (self empty ifEmpty: [true] ifNotEmptyDo: [:s | false]). 384006 self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | true]). 384007 self assert: (self nonEmpty 384008 ifEmpty: [false] 384009 ifNotEmptyDo: [:s | s]) == self nonEmpty.! ! 384010 384011!TEmptyTest methodsFor: 'tests - empty' stamp: 'stephane.ducasse 10/5/2008 13:03'! 384012testIfNotEmpty 384013 384014 self empty ifNotEmpty: [self assert: false]. 384015 self nonEmpty ifNotEmpty: [self assert: true]. 384016 self assert: (self nonEmpty ifNotEmpty: [:s | s ]) = self nonEmpty 384017 ! ! 384018 384019!TEmptyTest methodsFor: 'tests - empty' stamp: 'stephane.ducasse 10/5/2008 13:03'! 384020testIfNotEmptyDo 384021 384022 self empty ifNotEmptyDo: [:s | self assert: false]. 384023 self assert: (self nonEmpty ifNotEmptyDo: [:s | s]) == self nonEmpty 384024! ! 384025 384026!TEmptyTest methodsFor: 'tests - empty' stamp: 'stephane.ducasse 10/5/2008 13:04'! 384027testIfNotEmptyDoifNotEmpty 384028 384029 self assert: (self empty ifNotEmptyDo: [:s | false] ifEmpty: [true]). 384030 self assert: (self nonEmpty 384031 ifNotEmptyDo: [:s | s] 384032 ifEmpty: [false]) == self nonEmpty! ! 384033 384034!TEmptyTest methodsFor: 'tests - empty' stamp: 'delaunay 4/8/2009 15:26'! 384035testIfNotEmptyifEmpty 384036 384037 self assert: (self empty ifNotEmpty: [false] ifEmpty: [true]). 384038 self assert: (self nonEmpty ifNotEmpty: [true] ifEmpty: [false]). 384039 ! ! 384040 384041!TEmptyTest methodsFor: 'tests - empty' stamp: 'stephane.ducasse 10/5/2008 11:59'! 384042testIsEmpty 384043 384044 self assert: (self empty isEmpty). 384045 self deny: (self nonEmpty isEmpty).! ! 384046 384047!TEmptyTest methodsFor: 'tests - empty' stamp: 'stephane.ducasse 10/5/2008 12:00'! 384048testIsEmptyOrNil 384049 384050 self assert: (self empty isEmptyOrNil). 384051 self deny: (self nonEmpty isEmptyOrNil).! ! 384052 384053!TEmptyTest methodsFor: 'tests - empty' stamp: 'delaunay 4/2/2009 11:17'! 384054testNotEmpty 384055 384056 self assert: (self nonEmpty notEmpty). 384057 self deny: (self empty notEmpty).! ! 384058 384059 384060!TEmptyTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/12/2009 14:54'! 384061test0FixtureEmptyTest 384062 384063self shouldnt: [ self nonEmpty ] raise: Error. 384064self deny: self nonEmpty isEmpty. 384065 384066self shouldnt: [ self empty ] raise: Error. 384067self assert: self empty isEmpty.! ! 384068 384069"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 384070 384071TEmptyTest classTrait 384072 uses: {}! 384073Trait named: #TEnableOnHaloMenu 384074 uses: {} 384075 category: 'Polymorph-Widgets'! 384076!TEnableOnHaloMenu commentStamp: 'gvc 5/18/2007 11:56' prior: 0! 384077Trait providing an "enabled" option on the halo menu.! 384078 384079 384080!TEnableOnHaloMenu methodsFor: 'as yet unclassified' stamp: 'gvc 9/6/2006 15:22'! 384081addToggleItemsToHaloMenu: aCustomMenu 384082 "Add toggle-items to the halo menu" 384083 384084 super addToggleItemsToHaloMenu: aCustomMenu. 384085 aCustomMenu 384086 addUpdating: #enabledString 384087 target: self 384088 action: #toggleEnabled! ! 384089 384090!TEnableOnHaloMenu methodsFor: 'as yet unclassified' stamp: 'gvc 9/6/2006 15:24'! 384091enabled 384092 "Answer the enabled state of the receiver." 384093 384094 self requirement! ! 384095 384096!TEnableOnHaloMenu methodsFor: 'as yet unclassified' stamp: 'gvc 9/6/2006 15:24'! 384097enabled: aBoolean 384098 "Set the enabled state of the receiver." 384099 384100 self requirement! ! 384101 384102!TEnableOnHaloMenu methodsFor: 'as yet unclassified' stamp: 'gvc 9/6/2006 15:22'! 384103enabledString 384104 "Answer the string to be shown in a menu to represent the 384105 'enabled' status" 384106 384107 ^ (self enabled 384108 ifTrue: ['<on>'] 384109 ifFalse: ['<off>']), 'enabled' translated! ! 384110 384111!TEnableOnHaloMenu methodsFor: 'as yet unclassified' stamp: 'gvc 9/6/2006 15:23'! 384112toggleEnabled 384113 "Toggle the enabled state." 384114 384115 self enabled: self enabled not! ! 384116 384117"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 384118 384119TEnableOnHaloMenu classTrait 384120 uses: {}! 384121Trait named: #TGrowableTest 384122 uses: {} 384123 category: 'CollectionsTests-Abstract'! 384124 384125!TGrowableTest methodsFor: 'requirements' stamp: 'stephane.ducasse 1/19/2009 16:18'! 384126element 384127 384128 ^ self explicitRequirement ! ! 384129 384130!TGrowableTest methodsFor: 'requirements' stamp: 'stephane.ducasse 1/19/2009 16:20'! 384131elementNotIn 384132 384133 ^ self explicitRequirement! ! 384134 384135!TGrowableTest methodsFor: 'requirements' stamp: 'stephane.ducasse 1/19/2009 16:20'! 384136empty 384137 384138 ^ self explicitRequirement! ! 384139 384140!TGrowableTest methodsFor: 'requirements' stamp: 'damiencassou 1/20/2009 10:41'! 384141nonEmpty 384142 384143 ^ self explicitRequirement! ! 384144 384145 384146!TGrowableTest methodsFor: 'tests - fixture' stamp: 'cyrille.delaunay 3/20/2009 14:24'! 384147test0FixtureRequirementsOfTGrowableTest 384148 self shouldnt: [self empty] raise: Exception. 384149 self shouldnt: [self nonEmpty] raise: Exception. 384150 self shouldnt: [self element] raise: Exception. 384151 self shouldnt: [self elementNotIn] raise: Exception. 384152 self assert: self empty isEmpty. 384153 self deny: self nonEmpty isEmpty. 384154 self assert: (self nonEmpty includes: self element). 384155 self deny: (self nonEmpty includes: self elementNotIn).! ! 384156 384157 384158!TGrowableTest methodsFor: 'tests - growable' stamp: 'cyrille.delaunay 3/20/2009 09:47'! 384159testAddEmptyGrows 384160 "self debug: #testAddEmptyGrows" 384161 384162 | oldSize | 384163 oldSize := self empty size. 384164 self empty add: self element. 384165 self assert: (self empty size) = (oldSize + 1).! ! 384166 384167!TGrowableTest methodsFor: 'tests - growable' stamp: 'delaunay 5/12/2009 14:49'! 384168testAddNonEmptyGrowsWhenNewElement 384169 "self debug: #testAddNonEmptyGrowsWhenNewElement" 384170 384171 | oldSize | 384172 oldSize := self nonEmpty size. 384173 384174 self nonEmpty add: self elementNotIn. 384175 self assert: (self nonEmpty size) > oldSize.! ! 384176 384177"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 384178 384179TGrowableTest classTrait 384180 uses: {}! 384181Trait named: #TIdentityAddTest 384182 uses: {} 384183 category: 'CollectionsTests-Abstract'! 384184 384185!TIdentityAddTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/19/2009 18:22'! 384186collection 384187 ^ self explicitRequirement! ! 384188 384189!TIdentityAddTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/19/2009 18:22'! 384190element 384191 ^ self explicitRequirement! ! 384192 384193 384194!TIdentityAddTest methodsFor: 'tests - identity adding' stamp: 'damienpollet 1/9/2009 17:47'! 384195equalNotIdenticalElement 384196 ^ self element copy! ! 384197 384198!TIdentityAddTest methodsFor: 'tests - identity adding' stamp: 'damienpollet 1/9/2009 18:17'! 384199testIdentityAdd 384200 | added oldSize | 384201 oldSize := self collection size. 384202 self collection add: self element. 384203 self deny: (self collection includes: self equalNotIdenticalElement). 384204 384205 added := self collection add: self equalNotIdenticalElement. 384206 self assert: added == self equalNotIdenticalElement. 384207 self assert: (self collection includes: self equalNotIdenticalElement)! ! 384208 384209"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 384210 384211TIdentityAddTest classTrait 384212 uses: {}! 384213Trait named: #TIncludesForIdentityCollectionsTest 384214 uses: {} 384215 category: 'CollectionsTests-Abstract'! 384216 384217!TIncludesForIdentityCollectionsTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 13:56'! 384218identityCollectionWithElementsCopyNotIdentical 384219 " return a collection including elements for which #copy return a new object " 384220 ^ self explicitRequirement! ! 384221 384222 384223!TIncludesForIdentityCollectionsTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/13/2009 13:56'! 384224test0FixtureInludesForIdentityCollectionsTest 384225 self 384226 shouldnt: [ self identityCollectionWithElementsCopyNotIdentical ] 384227 raise: Error. 384228 self identityCollectionWithElementsCopyNotIdentical do: [ :each | self deny: each == each copy ]! ! 384229 384230 384231!TIncludesForIdentityCollectionsTest methodsFor: 'tests - including for identity collections' stamp: 'delaunay 5/13/2009 13:56'! 384232testIdentityIncludesForIdentityCollections 384233 " test the comportement in presence of elements 'includes' but not 'identityIncludes' " 384234 " can not be used by collections that can't include elements for wich copy doesn't return another instance " 384235 | collection element | 384236 collection := self identityCollectionWithElementsCopyNotIdentical . 384237 element := collection anyOne copy. 384238 self deny: (collection identityIncludes: element)! ! 384239 384240!TIncludesForIdentityCollectionsTest methodsFor: 'tests - including for identity collections' stamp: 'delaunay 5/13/2009 13:56'! 384241testIncludesAllOfForIdentityCollections 384242 "self debug: #testIncludesAllOfAllThere'" 384243 | collection copyCollection | 384244 collection := self identityCollectionWithElementsCopyNotIdentical . 384245 copyCollection := OrderedCollection new. 384246 collection do: [ :each | copyCollection add: each copy ]. 384247 self assert: (collection includesAllOf: collection). 384248 self deny: (collection includesAllOf: copyCollection). 384249 self deny: (collection includesAllOf: { (copyCollection anyOne) })! ! 384250 384251!TIncludesForIdentityCollectionsTest methodsFor: 'tests - including for identity collections' stamp: 'delaunay 5/13/2009 13:56'! 384252testIncludesAnyOfForIdentityCollections 384253 "self debug: #testIncludesAnyOfAllThere'" 384254 | collection copyCollection | 384255 collection := self identityCollectionWithElementsCopyNotIdentical . 384256 copyCollection := OrderedCollection new. 384257 collection do: [ :each | copyCollection add: each copy ]. 384258 self deny: (collection includesAnyOf: copyCollection). 384259 self assert: (collection includesAnyOf: { (collection anyOne) })! ! 384260 384261!TIncludesForIdentityCollectionsTest methodsFor: 'tests - including for identity collections' stamp: 'delaunay 5/13/2009 13:56'! 384262testIncludesForIdentityCollections 384263 "self debug: #testIncludesElementIsThere" 384264 | collection element elementCopy | 384265 collection := self identityCollectionWithElementsCopyNotIdentical . 384266 element := collection anyOne. 384267 elementCopy := element copy. 384268 self assert: (collection includes: element). 384269 self deny: (collection includes: elementCopy)! ! 384270 384271"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 384272 384273TIncludesForIdentityCollectionsTest classTrait 384274 uses: {}! 384275Trait named: #TIncludesTest 384276 uses: {} 384277 category: 'CollectionsTests-Abstract'! 384278 384279!TIncludesTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:47'! 384280anotherElementNotIn 384281" return an element different of 'elementNotIn' not included in 'nonEmpty' " 384282 ^ self explicitRequirement! ! 384283 384284!TIncludesTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:46'! 384285elementNotIn 384286"return an element not included in 'nonEmpty' " 384287 384288 ^ self explicitRequirement! ! 384289 384290!TIncludesTest methodsFor: 'requirements' stamp: 'stephane.ducasse 11/21/2008 14:11'! 384291empty 384292 ^ self explicitRequirement! ! 384293 384294!TIncludesTest methodsFor: 'requirements' stamp: 'stephane.ducasse 11/21/2008 14:11'! 384295nonEmpty 384296 ^ self explicitRequirement! ! 384297 384298 384299!TIncludesTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/24/2009 14:29'! 384300test0FixtureIncludeTest 384301 | elementIn | 384302 self shouldnt: [ self nonEmpty ]raise: Error. 384303 self deny: self nonEmpty isEmpty. 384304 384305 self shouldnt: [ self elementNotIn ]raise: Error. 384306 384307 elementIn := true. 384308 self nonEmpty detect: 384309 [ :each | each = self elementNotIn ] 384310 ifNone: [ elementIn := false ]. 384311 self assert: elementIn = false. 384312 384313 self shouldnt: [ self anotherElementNotIn ]raise: Error. 384314 384315 elementIn := true. 384316 self nonEmpty detect: 384317 [ :each | each = self anotherElementNotIn ] 384318 ifNone: [ elementIn := false ]. 384319 self assert: elementIn = false. 384320 384321 self shouldnt: [ self empty ] raise: Error. 384322 self assert: self empty isEmpty. 384323 384324! ! 384325 384326 384327!TIncludesTest methodsFor: 'tests - includes' stamp: 'delaunay 4/24/2009 14:39'! 384328testIdentityIncludesNonSpecificComportement 384329 " test the same comportement than 'includes: ' " 384330 | collection | 384331 collection := self nonEmpty . 384332 384333 self deny: (collection identityIncludes: self elementNotIn ). 384334 self assert:(collection identityIncludes: collection anyOne) 384335! ! 384336 384337!TIncludesTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:17'! 384338testIncludesAllOfAllThere 384339 "self debug: #testIncludesAllOfAllThere'" 384340 self assert: (self empty includesAllOf: self empty). 384341 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 384342 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 384343 384344!TIncludesTest methodsFor: 'tests - includes' stamp: 'delaunay 4/20/2009 10:52'! 384345testIncludesAllOfNoneThere 384346 "self debug: #testIncludesAllOfNoneThere'" 384347 self deny: (self empty includesAllOf: self nonEmpty ). 384348 self deny: (self nonEmpty includesAllOf: { self elementNotIn. self anotherElementNotIn })! ! 384349 384350!TIncludesTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:22'! 384351testIncludesAnyOfAllThere 384352 "self debug: #testIncludesAnyOfAllThere'" 384353 self deny: (self nonEmpty includesAnyOf: self empty). 384354 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 384355 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 384356 384357!TIncludesTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:26'! 384358testIncludesAnyOfNoneThere 384359 "self debug: #testIncludesAnyOfNoneThere'" 384360 self deny: (self nonEmpty includesAnyOf: self empty). 384361 self deny: (self nonEmpty includesAnyOf: { self elementNotIn. self anotherElementNotIn })! ! 384362 384363!TIncludesTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:05'! 384364testIncludesElementIsNotThere 384365 "self debug: #testIncludesElementIsNotThere" 384366 384367 self deny: (self nonEmpty includes: self elementNotIn). 384368 self assert: (self nonEmpty includes: self nonEmpty anyOne). 384369 self deny: (self empty includes: self elementNotIn)! ! 384370 384371!TIncludesTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:05'! 384372testIncludesElementIsThere 384373 "self debug: #testIncludesElementIsThere" 384374 384375 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 384376 384377"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 384378 384379TIncludesTest classTrait 384380 uses: {}! 384381Trait named: #TIncludesWithIdentityCheckTest 384382 uses: TIncludesTest 384383 category: 'CollectionsTests-Abstract'! 384384 384385!TIncludesWithIdentityCheckTest methodsFor: 'requirements'! 384386anotherElementNotIn 384387" return an element different of 'elementNotIn' not included in 'nonEmpty' " 384388 ^ self explicitRequirement! ! 384389 384390!TIncludesWithIdentityCheckTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 11:31'! 384391collectionWithCopyNonIdentical 384392 " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" 384393 ^ self explicitRequirement! ! 384394 384395!TIncludesWithIdentityCheckTest methodsFor: 'requirements'! 384396elementNotIn 384397"return an element not included in 'nonEmpty' " 384398 384399 ^ self explicitRequirement! ! 384400 384401!TIncludesWithIdentityCheckTest methodsFor: 'requirements'! 384402empty 384403 ^ self explicitRequirement! ! 384404 384405!TIncludesWithIdentityCheckTest methodsFor: 'requirements'! 384406nonEmpty 384407 ^ self explicitRequirement! ! 384408 384409 384410!TIncludesWithIdentityCheckTest methodsFor: 'tests - fixture'! 384411test0FixtureIncludeTest 384412 | elementIn | 384413 self shouldnt: [ self nonEmpty ]raise: Error. 384414 self deny: self nonEmpty isEmpty. 384415 384416 self shouldnt: [ self elementNotIn ]raise: Error. 384417 384418 elementIn := true. 384419 self nonEmpty detect: 384420 [ :each | each = self elementNotIn ] 384421 ifNone: [ elementIn := false ]. 384422 self assert: elementIn = false. 384423 384424 self shouldnt: [ self anotherElementNotIn ]raise: Error. 384425 384426 elementIn := true. 384427 self nonEmpty detect: 384428 [ :each | each = self anotherElementNotIn ] 384429 ifNone: [ elementIn := false ]. 384430 self assert: elementIn = false. 384431 384432 self shouldnt: [ self empty ] raise: Error. 384433 self assert: self empty isEmpty. 384434 384435! ! 384436 384437!TIncludesWithIdentityCheckTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/28/2009 11:34'! 384438test0FixtureIncludeWithIdentityTest 384439 | element | 384440 self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. 384441 element := self collectionWithCopyNonIdentical anyOne. 384442 self deny: element == element copy. 384443! ! 384444 384445 384446!TIncludesWithIdentityCheckTest methodsFor: 'tests - includes'! 384447testIdentityIncludesNonSpecificComportement 384448 " test the same comportement than 'includes: ' " 384449 | collection | 384450 collection := self nonEmpty . 384451 384452 self deny: (collection identityIncludes: self elementNotIn ). 384453 self assert:(collection identityIncludes: collection anyOne) 384454! ! 384455 384456!TIncludesWithIdentityCheckTest methodsFor: 'tests - includes'! 384457testIncludesAllOfAllThere 384458 "self debug: #testIncludesAllOfAllThere'" 384459 self assert: (self empty includesAllOf: self empty). 384460 self assert: (self nonEmpty includesAllOf: { self nonEmpty anyOne }). 384461 self assert: (self nonEmpty includesAllOf: self nonEmpty).! ! 384462 384463!TIncludesWithIdentityCheckTest methodsFor: 'tests - includes'! 384464testIncludesAllOfNoneThere 384465 "self debug: #testIncludesAllOfNoneThere'" 384466 self deny: (self empty includesAllOf: self nonEmpty ). 384467 self deny: (self nonEmpty includesAllOf: { self elementNotIn. self anotherElementNotIn })! ! 384468 384469!TIncludesWithIdentityCheckTest methodsFor: 'tests - includes'! 384470testIncludesAnyOfAllThere 384471 "self debug: #testIncludesAnyOfAllThere'" 384472 self deny: (self nonEmpty includesAnyOf: self empty). 384473 self assert: (self nonEmpty includesAnyOf: { self nonEmpty anyOne }). 384474 self assert: (self nonEmpty includesAnyOf: self nonEmpty).! ! 384475 384476!TIncludesWithIdentityCheckTest methodsFor: 'tests - includes'! 384477testIncludesAnyOfNoneThere 384478 "self debug: #testIncludesAnyOfNoneThere'" 384479 self deny: (self nonEmpty includesAnyOf: self empty). 384480 self deny: (self nonEmpty includesAnyOf: { self elementNotIn. self anotherElementNotIn })! ! 384481 384482!TIncludesWithIdentityCheckTest methodsFor: 'tests - includes'! 384483testIncludesElementIsNotThere 384484 "self debug: #testIncludesElementIsNotThere" 384485 384486 self deny: (self nonEmpty includes: self elementNotIn). 384487 self assert: (self nonEmpty includes: self nonEmpty anyOne). 384488 self deny: (self empty includes: self elementNotIn)! ! 384489 384490!TIncludesWithIdentityCheckTest methodsFor: 'tests - includes'! 384491testIncludesElementIsThere 384492 "self debug: #testIncludesElementIsThere" 384493 384494 self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! 384495 384496 384497!TIncludesWithIdentityCheckTest methodsFor: 'tests - including with identity' stamp: 'delaunay 4/28/2009 11:35'! 384498testIdentityIncludes 384499 " test the comportement in presence of elements 'includes' but not 'identityIncludes' " 384500 " can not be used by collections that can't include elements for wich copy doesn't return another instance " 384501 | collection element | 384502 384503 collection := self collectionWithCopyNonIdentical. 384504 element := collection anyOne copy. 384505 384506 self deny: (collection identityIncludes: element)! ! 384507 384508"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 384509 384510TIncludesWithIdentityCheckTest classTrait 384511 uses: TIncludesTest classTrait! 384512Trait named: #TIndexAccess 384513 uses: {} 384514 category: 'CollectionsTests-Abstract'! 384515 384516!TIndexAccess methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:14'! 384517collectionMoreThan1NoDuplicates 384518 " return a collection of size > 1 without equal elements" 384519 self explicitRequirement! ! 384520 384521!TIndexAccess methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:10'! 384522elementInForIndexAccessing 384523" return an element included in 'collectionMoreThan1NoDuplicates' " 384524 self explicitRequirement! ! 384525 384526!TIndexAccess methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 15:11'! 384527elementNotInForIndexAccessing 384528" return an element not included in 'collectionMoreThan1NoDuplicates' " 384529 self explicitRequirement! ! 384530 384531 384532!TIndexAccess methodsFor: 'tests - fixture' stamp: 'delaunay 5/14/2009 15:59'! 384533test0FixtureIndexAccessTest 384534 | res collection element | 384535 self 384536 shouldnt: [ self collectionMoreThan1NoDuplicates ] 384537 raise: Error. 384538 self assert: self collectionMoreThan1NoDuplicates size >1. 384539 res := true. 384540 self collectionMoreThan1NoDuplicates 384541 detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] 384542 ifNone: [ res := false ]. 384543 self assert: res = false. 384544 self 384545 shouldnt: [ self elementInForIndexAccessing ] 384546 raise: Error. 384547 self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). 384548 self 384549 shouldnt: [ self elementNotInForIndexAccessing ] 384550 raise: Error. 384551 self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! 384552 384553 384554!TIndexAccess methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 384555testIdentityIndexOf 384556 "self debug: #testIdentityIndexOf" 384557 | collection element | 384558 collection := self collectionMoreThan1NoDuplicates. 384559 element := collection first. 384560 self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! 384561 384562!TIndexAccess methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 384563testIdentityIndexOfIAbsent 384564 | collection element | 384565 collection := self collectionMoreThan1NoDuplicates. 384566 element := collection first. 384567 self assert: (collection 384568 identityIndexOf: element 384569 ifAbsent: [ 0 ]) = 1. 384570 self assert: (collection 384571 identityIndexOf: self elementNotInForIndexAccessing 384572 ifAbsent: [ 55 ]) = 55! ! 384573 384574!TIndexAccess methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 384575testIndexOf 384576 "self debug: #testIndexOf" 384577 | tmp index collection | 384578 collection := self collectionMoreThan1NoDuplicates. 384579 tmp := collection size. 384580 collection reverseDo: 384581 [ :each | 384582 each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. 384583 tmp := tmp - 1 ]. 384584 self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! 384585 384586!TIndexAccess methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 384587testIndexOfIfAbsent 384588 "self debug: #testIndexOfIfAbsent" 384589 | collection | 384590 collection := self collectionMoreThan1NoDuplicates. 384591 self assert: (collection 384592 indexOf: collection first 384593 ifAbsent: [ 33 ]) = 1. 384594 self assert: (collection 384595 indexOf: self elementNotInForIndexAccessing 384596 ifAbsent: [ 33 ]) = 33! ! 384597 384598!TIndexAccess methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 384599testIndexOfStartingAt 384600 "self debug: #testLastIndexOf" 384601 | element collection | 384602 collection := self collectionMoreThan1NoDuplicates. 384603 element := collection first. 384604 self assert: (collection 384605 indexOf: element 384606 startingAt: 2 384607 ifAbsent: [ 99 ]) = 99. 384608 self assert: (collection 384609 indexOf: element 384610 startingAt: 1 384611 ifAbsent: [ 99 ]) = 1. 384612 self assert: (collection 384613 indexOf: self elementNotInForIndexAccessing 384614 startingAt: 1 384615 ifAbsent: [ 99 ]) = 99! ! 384616 384617!TIndexAccess methodsFor: 'tests - index access' stamp: 'delaunay 5/11/2009 16:27'! 384618testIndexOfStartingAtIfAbsent 384619 "self debug: #testLastIndexOf" 384620 | element collection | 384621 collection := self collectionMoreThan1NoDuplicates. 384622 element := collection first. 384623 self assert: (collection 384624 indexOf: element 384625 startingAt: 2 384626 ifAbsent: [ 99 ]) = 99. 384627 self assert: (collection 384628 indexOf: element 384629 startingAt: 1 384630 ifAbsent: [ 99 ]) = 1. 384631 self assert: (collection 384632 indexOf: self elementNotInForIndexAccessing 384633 startingAt: 1 384634 ifAbsent: [ 99 ]) = 99! ! 384635 384636!TIndexAccess methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 384637testIndexOfSubCollectionStartingAt 384638 "self debug: #testIndexOfIfAbsent" 384639 | subcollection index collection | 384640 collection := self collectionMoreThan1NoDuplicates. 384641 subcollection := self collectionMoreThan1NoDuplicates. 384642 index := collection 384643 indexOfSubCollection: subcollection 384644 startingAt: 1. 384645 self assert: index = 1. 384646 index := collection 384647 indexOfSubCollection: subcollection 384648 startingAt: 2. 384649 self assert: index = 0! ! 384650 384651!TIndexAccess methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 384652testIndexOfSubCollectionStartingAtIfAbsent 384653 "self debug: #testIndexOfIfAbsent" 384654 | index absent subcollection collection | 384655 collection := self collectionMoreThan1NoDuplicates. 384656 subcollection := self collectionMoreThan1NoDuplicates. 384657 absent := false. 384658 index := collection 384659 indexOfSubCollection: subcollection 384660 startingAt: 1 384661 ifAbsent: [ absent := true ]. 384662 self assert: absent = false. 384663 absent := false. 384664 index := collection 384665 indexOfSubCollection: subcollection 384666 startingAt: 2 384667 ifAbsent: [ absent := true ]. 384668 self assert: absent = true! ! 384669 384670!TIndexAccess methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 384671testLastIndexOf 384672 "self debug: #testLastIndexOf" 384673 | element collection | 384674 collection := self collectionMoreThan1NoDuplicates. 384675 element := collection first. 384676 self assert: (collection lastIndexOf: element) = 1. 384677 self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! 384678 384679!TIndexAccess methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 384680testLastIndexOfIfAbsent 384681 "self debug: #testIndexOfIfAbsent" 384682 | element collection | 384683 collection := self collectionMoreThan1NoDuplicates. 384684 element := collection first. 384685 self assert: (collection 384686 lastIndexOf: element 384687 ifAbsent: [ 99 ]) = 1. 384688 self assert: (collection 384689 lastIndexOf: self elementNotInForIndexAccessing 384690 ifAbsent: [ 99 ]) = 99! ! 384691 384692!TIndexAccess methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 384693testLastIndexOfStartingAt 384694 "self debug: #testLastIndexOf" 384695 | element collection | 384696 collection := self collectionMoreThan1NoDuplicates. 384697 element := collection last. 384698 self assert: (collection 384699 lastIndexOf: element 384700 startingAt: collection size 384701 ifAbsent: [ 99 ]) = collection size. 384702 self assert: (collection 384703 lastIndexOf: element 384704 startingAt: collection size - 1 384705 ifAbsent: [ 99 ]) = 99. 384706 self assert: (collection 384707 lastIndexOf: self elementNotInForIndexAccessing 384708 startingAt: collection size 384709 ifAbsent: [ 99 ]) = 99! ! 384710 384711"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 384712 384713TIndexAccess classTrait 384714 uses: {}! 384715Trait named: #TIndexAccessForMultipliness 384716 uses: {} 384717 category: 'CollectionsTests-Abstract'! 384718 384719!TIndexAccessForMultipliness methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:02'! 384720collectionWithNonIdentitySameAtEndAndBegining 384721 " return a collection with elements at end and begining equals only with classic equality (they are not the same object). 384722(others elements of the collection are not equal to those elements)" 384723 self explicitRequirement! ! 384724 384725!TIndexAccessForMultipliness methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:04'! 384726collectionWithSameAtEndAndBegining 384727 " return a collection with elements at end and begining equals . 384728(others elements of the collection are not equal to those elements)" 384729 self explicitRequirement! ! 384730 384731 384732!TIndexAccessForMultipliness methodsFor: 'tests - fixture' stamp: 'delaunay 4/27/2009 14:08'! 384733test0FixtureIndexAccessFotMultipliness 384734 self 384735 shouldnt: [ self collectionWithSameAtEndAndBegining ] 384736 raise: Error. 384737 self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. 384738 self assert: self collectionWithSameAtEndAndBegining size > 1. 384739 1 to: self collectionWithSameAtEndAndBegining size 384740 do: 384741 [ :i | 384742 i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: 384743 [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! 384744 384745 384746!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: 'delaunay 4/27/2009 14:15'! 384747testIdentityIndexOfDuplicate 384748 "self debug: #testIdentityIndexOf" 384749 | collection element | 384750 384751 "testing fixture here as this method may not be used by some collections testClass" 384752 self shouldnt: [self collectionWithNonIdentitySameAtEndAndBegining ] raise: Error. 384753 collection := self collectionWithNonIdentitySameAtEndAndBegining . 384754 self assert: collection first = collection last. 384755 self deny: collection first == collection last. 384756 1 to: collection size do: 384757 [ :i | 384758 i > 1 & (i < collection size) ifTrue: 384759 [ self deny: (collection at: i) = collection first ] ]. 384760 384761 384762 element := collection last. 384763 " floatCollectionWithSameAtEndAndBegining first and last elements are equals but are not the same object" 384764 self assert: (collection identityIndexOf: element) = collection size! ! 384765 384766!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: 'delaunay 5/11/2009 10:07'! 384767testIdentityIndexOfIAbsentDuplicate 384768 "self debug: #testIdentityIndexOfIfAbsent" 384769 | collection element elementCopy | 384770 collection := self collectionWithNonIdentitySameAtEndAndBegining . 384771 element := collection last. 384772 elementCopy := element copy. 384773 self deny: element == elementCopy . 384774 self assert: (collection 384775 identityIndexOf: element 384776 ifAbsent: [ 0 ]) = collection size. 384777 self assert: (collection 384778 identityIndexOf: elementCopy 384779 ifAbsent: [ 55 ]) = 55! ! 384780 384781!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: 'delaunay 4/27/2009 14:00'! 384782testIndexOfDuplicate 384783 "self debug: #testIndexOf" 384784 | collection element | 384785 collection := self collectionWithSameAtEndAndBegining. 384786 element := collection last. 384787 384788 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 384789 'indexOf: should return the position of the first occurrence :'" 384790 self assert: (collection indexOf: element) = 1! ! 384791 384792!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: 'delaunay 4/27/2009 14:00'! 384793testIndexOfIfAbsentDuplicate 384794 "self debug: #testIndexOfIfAbsent" 384795 | collection element | 384796 collection := self collectionWithSameAtEndAndBegining. 384797 element := collection last. 384798 384799 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 384800 'indexOf:ifAbsent: should return the position of the first occurrence :'" 384801 self assert: (collection 384802 indexOf: element 384803 ifAbsent: [ 55 ]) = 1! ! 384804 384805!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: 'delaunay 4/27/2009 14:00'! 384806testIndexOfStartingAtDuplicate 384807 "self debug: #testLastIndexOf" 384808 | collection element | 384809 collection := self collectionWithSameAtEndAndBegining. 384810 element := collection last. 384811 384812 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 384813 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" 384814 self assert: (collection 384815 indexOf: element 384816 startingAt: 1 384817 ifAbsent: [ 55 ]) = 1. 384818 self assert: (collection 384819 indexOf: element 384820 startingAt: 2 384821 ifAbsent: [ 55 ]) = collection size! ! 384822 384823!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: 'delaunay 4/27/2009 14:00'! 384824testLastIndexOfDuplicate 384825 "self debug: #testLastIndexOf" 384826 | collection element | 384827 collection := self collectionWithSameAtEndAndBegining. 384828 element := collection first. 384829 384830 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 384831 'lastIndexOf: should return the position of the last occurrence :'" 384832 self assert: (collection lastIndexOf: element) = collection size! ! 384833 384834!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: 'delaunay 4/27/2009 14:00'! 384835testLastIndexOfIfAbsentDuplicate 384836 "self debug: #testIndexOfIfAbsent" 384837 "self debug: #testLastIndexOf" 384838 | collection element | 384839 collection := self collectionWithSameAtEndAndBegining. 384840 element := collection first. 384841 384842 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 384843 'lastIndexOf: should return the position of the last occurrence :'" 384844 self assert: (collection 384845 lastIndexOf: element 384846 ifAbsent: [ 55 ]) = collection size! ! 384847 384848!TIndexAccessForMultipliness methodsFor: 'tests - index accessing for multipliness' stamp: 'delaunay 4/27/2009 14:00'! 384849testLastIndexOfStartingAtDuplicate 384850 "self debug: #testLastIndexOf" 384851 | collection element | 384852 collection := self collectionWithSameAtEndAndBegining. 384853 element := collection last. 384854 384855 " floatCollectionWithSameAtEndAndBegining first and last elements are equals 384856 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" 384857 self assert: (collection 384858 lastIndexOf: element 384859 startingAt: collection size 384860 ifAbsent: [ 55 ]) = collection size. 384861 self assert: (collection 384862 lastIndexOf: element 384863 startingAt: collection size - 1 384864 ifAbsent: [ 55 ]) = 1! ! 384865 384866"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 384867 384868TIndexAccessForMultipliness classTrait 384869 uses: {}! 384870Trait named: #TIterateSequencedReadableTest 384871 uses: {} 384872 category: 'CollectionsTests-Abstract'! 384873 384874!TIterateSequencedReadableTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 14:05'! 384875empty 384876 ^self explicitRequirement.! ! 384877 384878!TIterateSequencedReadableTest methodsFor: 'requirements' stamp: 'delaunay 5/12/2009 14:10'! 384879nonEmptyMoreThan1Element 384880" return a collection that doesn't includes equal elements' and doesn't include nil elements'" 384881 ^self explicitRequirement.! ! 384882 384883 384884!TIterateSequencedReadableTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/23/2009 14:00'! 384885test0FixtureIterateSequencedReadableTest 384886 384887 | res | 384888 384889 self shouldnt: self nonEmptyMoreThan1Element raise: Error. 384890 self assert: self nonEmptyMoreThan1Element size > 1. 384891 384892 384893 self shouldnt: self empty raise: Error. 384894 self assert: self empty isEmpty . 384895 384896 res := true. 384897 self nonEmptyMoreThan1Element 384898 detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] 384899 ifNone: [ res := false ]. 384900 self assert: res = false.! ! 384901 384902 384903!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/7/2009 10:39'! 384904testAllButFirstDo 384905 384906 | result | 384907 result:= OrderedCollection new. 384908 384909 self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 384910 384911 1 to: (result size) do: 384912 [:i| 384913 self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. 384914 384915 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 384916 384917!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/7/2009 10:40'! 384918testAllButLastDo 384919 384920 | result | 384921 result:= OrderedCollection new. 384922 384923 self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 384924 384925 1 to: (result size) do: 384926 [:i| 384927 self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. 384928 384929 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 384930 384931!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/8/2009 10:39'! 384932testCollectFromTo 384933 384934 | result | 384935 result:=self nonEmptyMoreThan1Element 384936 collect: [ :each | each ] 384937 from: 1 384938 to: (self nonEmptyMoreThan1Element size - 1). 384939 384940 1 to: result size 384941 do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. 384942 self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! 384943 384944!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 5/12/2009 14:09'! 384945testDetectSequenced 384946" testing that detect keep the first element returning true for sequenceable collections " 384947 384948 | element result | 384949 element := self nonEmptyMoreThan1Element at:1. 384950 result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. 384951 self assert: result = element. ! ! 384952 384953!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/2/2009 13:58'! 384954testDo! ! 384955 384956!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/23/2009 14:00'! 384957testFindFirst 384958 384959 | element result | 384960 element := self nonEmptyMoreThan1Element at:1. 384961 result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. 384962 384963 self assert: result=1. ! ! 384964 384965!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/2/2009 15:29'! 384966testFindFirstNotIn 384967 384968 | result | 384969 384970 result:=self empty findFirst: [:each | true]. 384971 384972 self assert: result=0. ! ! 384973 384974!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/23/2009 14:04'! 384975testFindLast 384976 384977 | element result | 384978 element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. 384979 result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. 384980 384981 self assert: result=self nonEmptyMoreThan1Element size. ! ! 384982 384983!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/2/2009 15:30'! 384984testFindLastNotIn 384985 384986 | result | 384987 384988 result:=self empty findFirst: [:each | true]. 384989 384990 self assert: result=0. ! ! 384991 384992!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/2/2009 14:40'! 384993testFromToDo 384994 384995 | result | 384996 result:= OrderedCollection new. 384997 384998 self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 384999 385000 1 to: (self nonEmptyMoreThan1Element size -1) do: 385001 [:i| 385002 self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. 385003 self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! 385004 385005!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/23/2009 12:10'! 385006testKeysAndValuesDo 385007 "| result | 385008 result:= OrderedCollection new. 385009 385010 self nonEmptyMoreThan1Element keysAndValuesDo: 385011 [:i :value| 385012 result add: (value+i)]. 385013 385014 1 to: result size do: 385015 [:i| 385016 self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" 385017 | indexes elements | 385018 indexes:= OrderedCollection new. 385019 elements := OrderedCollection new. 385020 385021 self nonEmptyMoreThan1Element keysAndValuesDo: 385022 [:i :value| 385023 indexes add: (i). 385024 elements add: value]. 385025 385026 (1 to: self nonEmptyMoreThan1Element size )do: 385027 [ :i | 385028 self assert: (indexes at: i) = i. 385029 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 385030 ]. 385031 385032 self assert: indexes size = elements size. 385033 self assert: indexes size = self nonEmptyMoreThan1Element size . 385034 385035 ! ! 385036 385037!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/2/2009 15:35'! 385038testKeysAndValuesDoEmpty 385039 | result | 385040 result:= OrderedCollection new. 385041 385042 self empty keysAndValuesDo: 385043 [:i :value| 385044 result add: (value+i)]. 385045 385046 self assert: result isEmpty .! ! 385047 385048!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 5/14/2009 16:17'! 385049testPairsCollect 385050 385051 | index result | 385052 index:=0. 385053 385054 result:=self nonEmptyMoreThan1Element pairsCollect: 385055 [:each1 :each2 | 385056 self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). 385057 (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). 385058 ]. 385059 385060 result do: 385061 [:each | self assert: each = true]. 385062 385063! ! 385064 385065!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/23/2009 13:04'! 385066testPairsDo 385067 | index | 385068 index:=1. 385069 385070 self nonEmptyMoreThan1Element pairsDo: 385071 [:each1 :each2 | 385072 self assert:(self nonEmptyMoreThan1Element at:index)=each1. 385073 self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. 385074 index:=index+2]. 385075 385076 self nonEmptyMoreThan1Element size odd 385077 ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] 385078 ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! 385079 385080!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/2/2009 15:01'! 385081testReverseDo 385082 | result | 385083 result:= OrderedCollection new. 385084 self nonEmpty reverseDo: [: each | result add: each]. 385085 385086 1 to: result size do: 385087 [:i| 385088 self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! 385089 385090!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/2/2009 15:36'! 385091testReverseDoEmpty 385092 | result | 385093 result:= OrderedCollection new. 385094 self empty reverseDo: [: each | result add: each]. 385095 385096 self assert: result isEmpty .! ! 385097 385098!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 5/14/2009 16:18'! 385099testReverseWithDo 385100 385101 | secondCollection result index | 385102 result:= OrderedCollection new. 385103 index := self nonEmptyMoreThan1Element size + 1. 385104 secondCollection:= self nonEmptyMoreThan1Element copy. 385105 385106 self nonEmptyMoreThan1Element reverseWith: secondCollection do: 385107 [:a :b | 385108 self assert: (self nonEmptyMoreThan1Element indexOf: a ) = (index := index - 1 ). 385109 result add: (a = b)]. 385110 385111 1 to: result size do: 385112 [:i| 385113 self assert: (result at:i)=(true)]. 385114 self assert: result size = self nonEmptyMoreThan1Element size.! ! 385115 385116!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 5/14/2009 16:19'! 385117testWithCollect 385118 385119 | result newCollection index collection | 385120 385121 index := 0. 385122 collection := self nonEmptyMoreThan1Element . 385123 newCollection := collection copy. 385124 result:=collection with: newCollection collect: [:a :b | 385125 self assert: (collection indexOf: a ) = ( index := index + 1). 385126 self assert: (a = b). 385127 b]. 385128 385129 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 385130 self assert: result size = collection size.! ! 385131 385132!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/6/2009 17:12'! 385133testWithCollectError 385134 self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! 385135 385136!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 5/14/2009 16:19'! 385137testWithDo 385138 385139 | secondCollection result index | 385140 result:= OrderedCollection new. 385141 secondCollection:= self nonEmptyMoreThan1Element copy. 385142 index := 0. 385143 385144 self nonEmptyMoreThan1Element with: secondCollection do: 385145 [:a :b | 385146 self assert: (self nonEmptyMoreThan1Element indexOf: a) = ( index := index + 1). 385147 result add: (a =b)]. 385148 385149 1 to: result size do: 385150 [:i| 385151 self assert: (result at:i)=(true)]. 385152 self assert: result size = self nonEmptyMoreThan1Element size.! ! 385153 385154!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/7/2009 10:36'! 385155testWithDoError 385156 385157 self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! 385158 385159!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 5/14/2009 16:19'! 385160testWithIndexCollect 385161 385162 | result index collection | 385163 index := 0. 385164 collection := self nonEmptyMoreThan1Element . 385165 result := collection withIndexCollect: [:each :i | 385166 self assert: i = (index := index + 1). 385167 self assert: i = (collection indexOf: each) . 385168 each] . 385169 385170 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. 385171 self assert: result size = collection size.! ! 385172 385173!TIterateSequencedReadableTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: 'delaunay 4/23/2009 13:29'! 385174testWithIndexDo 385175 385176 "| result | 385177 result:=Array new: self nonEmptyMoreThan1Element size. 385178 self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 385179 385180 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" 385181 | indexes elements | 385182 indexes:= OrderedCollection new. 385183 elements := OrderedCollection new. 385184 385185 self nonEmptyMoreThan1Element withIndexDo: 385186 [:value :i | 385187 indexes add: (i). 385188 elements add: value]. 385189 385190 (1 to: self nonEmptyMoreThan1Element size )do: 385191 [ :i | 385192 self assert: (indexes at: i) = i. 385193 self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). 385194 ]. 385195 385196 self assert: indexes size = elements size. 385197 self assert: indexes size = self nonEmptyMoreThan1Element size . 385198 ! ! 385199 385200"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 385201 385202TIterateSequencedReadableTest classTrait 385203 uses: {}! 385204Trait named: #TIterateTest 385205 uses: {} 385206 category: 'CollectionsTests-Abstract'! 385207!TIterateTest commentStamp: 'stephane.ducasse 10/6/2008 17:49' prior: 0! 385208I'm testing that high-order iterators are working. 385209Note however that I do not pay attention to the order of the elements. 385210Hence, my doTest is designed to not checking that. 385211TIterateSequenceableTest is about this distinction and as such will not be applicable to test 385212Set, Bag, Dictionary. 385213 385214 385215! 385216 385217 385218!TIterateTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 10:11'! 385219collectionWithoutNilElements 385220" return a collection that doesn't includes a nil element and that doesn't includes equal elements'" 385221 self explicitRequirement! ! 385222 385223!TIterateTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 10:22'! 385224empty 385225 385226 self explicitRequirement! ! 385227 385228 385229!TIterateTest methodsFor: 'test - fixture' stamp: 'delaunay 4/23/2009 10:14'! 385230test0FixtureIterateTest 385231 385232 385233| res | 385234self shouldnt: [ self collectionWithoutNilElements ] raise: Error. 385235 385236self assert: ( self collectionWithoutNilElements occurrencesOf: nil) = 0. 385237 385238res := true. 385239self collectionWithoutNilElements 385240 detect: [ :each | (self collectionWithoutNilElements occurrencesOf: each) > 1 ] 385241 ifNone: [ res := false ]. 385242self assert: res = false.! ! 385243 385244 385245!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/23/2009 10:38'! 385246testAllSatisfy 385247 385248 | element | 385249 " when all element satisfy the condition, should return true : " 385250 self assert: ( self collectionWithoutNilElements allSatisfy: [:each | (each notNil) ] ). 385251 385252 " when all element don't satisfy the condition, should return false : " 385253 self deny: ( self collectionWithoutNilElements allSatisfy: [:each | (each notNil) not ] ). 385254 385255 " when only one element doesn't satisfy the condition' should return false'" 385256 element := self collectionWithoutNilElements anyOne. 385257 self deny: ( self collectionWithoutNilElements allSatisfy: [:each | (each = element) not] ).! ! 385258 385259!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/22/2009 15:57'! 385260testAllSatisfyEmpty 385261 385262 self assert: ( self empty allSatisfy: [:each | false]). 385263 ! ! 385264 385265!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/23/2009 10:34'! 385266testAnySastify 385267 385268 | element | 385269 " when all elements satisty the condition, should return true :" 385270 self assert: ( self collectionWithoutNilElements anySatisfy: [:each | each notNil ]). 385271 385272 " when only one element satisfy the condition, should return true :" 385273 element := self collectionWithoutNilElements anyOne. 385274 self assert: ( self collectionWithoutNilElements anySatisfy: [:each | (each = element) ] ). 385275 385276 " when all elements don't satisty the condition, should return false :" 385277 self deny: ( self collectionWithoutNilElements anySatisfy: [:each | (each notNil) not ]). 385278! ! 385279 385280!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/24/2009 15:24'! 385281testBasicCollect 385282 385283 | res index | 385284 index := 0. 385285 res := self collectionWithoutNilElements collect: [ 385286 :each | 385287 index := index + 1. 385288 each 385289 ]. 385290 385291 res do:[:each | self assert: (self collectionWithoutNilElements occurrencesOf: each) = (res occurrencesOf: each)]. 385292 self assert: index = self collectionWithoutNilElements size. 385293 ! ! 385294 385295!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/22/2009 15:58'! 385296testBasicCollectEmpty 385297 385298 | res | 385299 res := self empty collect: [:each | each class]. 385300 self assert: res isEmpty 385301 ! ! 385302 385303!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/22/2009 15:58'! 385304testCollectOnEmpty 385305 self assert: (self empty collect: [:e | self fail]) isEmpty! ! 385306 385307!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/22/2009 15:58'! 385308testCollectThenSelectOnEmpty 385309 385310 self assert: (self empty collect: [:e | self fail] thenSelect: [:e | self fail]) isEmpty! ! 385311 385312!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/23/2009 10:09'! 385313testDetect 385314 385315 | res element | 385316 element := self collectionWithoutNilElements anyOne . 385317 385318 res := self collectionWithoutNilElements detect: [:each | each = element]. 385319 self assert: (res = element). 385320 385321 385322 ! ! 385323 385324!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/23/2009 10:10'! 385325testDetectIfNone 385326 385327 | res element | 385328 res := self collectionWithoutNilElements detect: [:each | each notNil not] ifNone: [100]. 385329 self assert: res = 100. 385330 385331 element := self collectionWithoutNilElements anyOne. 385332 res := self collectionWithoutNilElements detect: [:each | each = element] ifNone: [100]. 385333 self assert: res = element. 385334 385335 385336 ! ! 385337 385338!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 5/14/2009 15:52'! 385339testDo2 385340 "dc: Bad test, it assumes that a new instance of #speciesClass allows addition with #add:. This is not the case of Interval for which species is Array." 385341 "res := self speciesClass new. 385342 self collection do: [:each | res add: each class]. 385343 self assert: res = self result. " 385344 | collection cptElementsViewed cptElementsIn | 385345 collection := self collectionWithoutNilElements. 385346 cptElementsViewed := 0. 385347 cptElementsIn := OrderedCollection new. 385348 collection do: 385349 [ :each | 385350 cptElementsViewed := cptElementsViewed + 1. 385351 " #do doesn't iterate with the same objects than those in the collection for FloatArray( I don' t know why ) . That's why I use #includes: and not #identityIncludes: '" 385352 (collection includes: each) ifTrue: [ 385353 " the collection used doesn't include equal elements. Therefore each element viewed should not have been viewed before " 385354 ( cptElementsIn includes: each ) ifFalse: [ cptElementsIn add: each ] . 385355 ]. 385356 ]. 385357 self assert: cptElementsViewed = collection size. 385358 self assert: cptElementsIn size = collection size. 385359 385360 ! ! 385361 385362!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/22/2009 16:22'! 385363testDoSeparatedBy 385364 | string expectedString beforeFirst | 385365 385366 string := ''. 385367 self collectionWithoutNilElements 385368 do: [ :each | string := string , each asString ] 385369 separatedBy: [ string := string , '|' ]. 385370 385371 expectedString := ''. 385372 beforeFirst := true. 385373 self collectionWithoutNilElements do: 385374 [ :each | 385375 beforeFirst = true 385376 ifTrue: [ beforeFirst := false ] 385377 ifFalse: [ expectedString := expectedString , '|' ]. 385378 expectedString := expectedString , each asString ]. 385379 self assert: expectedString = string! ! 385380 385381!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/23/2009 10:26'! 385382testDoWithout 385383 "self debug: #testDoWithout" 385384 385385 | res element collection | 385386 collection := self collectionWithoutNilElements . 385387 res := OrderedCollection new. 385388 element := self collectionWithoutNilElements anyOne . 385389 collection do: [:each | res add: each] without: element . 385390 " verifying result :" 385391 self assert: res size = (collection size - (collection occurrencesOf: element)). 385392 res do: [:each | self assert: (collection occurrencesOf: each) = ( res occurrencesOf: each ) ]. 385393 ! ! 385394 385395!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/23/2009 10:21'! 385396testInjectInto 385397 |result| 385398 result:= self collectionWithoutNilElements 385399 inject: 0 385400 into: [:inj :ele | ele notNil ifTrue: [ inj + 1 ]]. 385401 385402 self assert: self collectionWithoutNilElements size = result .! ! 385403 385404!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/23/2009 10:17'! 385405testNoneSatisfy 385406 385407 | element | 385408 self assert: ( self collectionWithoutNilElements noneSatisfy: [:each | each notNil not ] ). 385409 element := self collectionWithoutNilElements anyOne. 385410 self deny: ( self collectionWithoutNilElements noneSatisfy: [:each | (each = element)not ] ).! ! 385411 385412!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/22/2009 16:00'! 385413testNoneSatisfyEmpty 385414 385415 self assert: ( self empty noneSatisfy: [:each | false]). 385416 ! ! 385417 385418!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/23/2009 10:18'! 385419testReject 385420 385421 | res element | 385422 res := self collectionWithoutNilElements reject: [:each | each notNil not]. 385423 self assert: res size = self collectionWithoutNilElements size. 385424 385425 element := self collectionWithoutNilElements anyOne. 385426 res := self collectionWithoutNilElements reject: [:each | each = element]. 385427 self assert: res size = (self collectionWithoutNilElements size - 1). 385428 385429 385430 ! ! 385431 385432!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/22/2009 16:01'! 385433testRejectEmpty 385434 385435 | res | 385436 res := self empty reject: [:each | each odd]. 385437 self assert: res size = self empty size 385438 ! ! 385439 385440!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/22/2009 16:30'! 385441testRejectNoReject 385442 385443 | res | 385444 res := self collectionWithoutNilElements reject: [:each | each notNil not]. 385445 self assert: res size = self collectionWithoutNilElements size. 385446 ! ! 385447 385448!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/23/2009 10:20'! 385449testSelect 385450 385451 | res element | 385452 res := self collectionWithoutNilElements select: [:each | each notNil]. 385453 self assert: res size = self collectionWithoutNilElements size. 385454 385455 element := self collectionWithoutNilElements anyOne. 385456 res := self collectionWithoutNilElements select: [:each | (each = element) not]. 385457 self assert: res size = (self collectionWithoutNilElements size - 1). 385458 ! ! 385459 385460!TIterateTest methodsFor: 'tests - iterating' stamp: 'delaunay 4/22/2009 16:01'! 385461testSelectOnEmpty 385462 385463 self assert: (self empty select: [:e | self fail]) isEmpty 385464 ! ! 385465 385466"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 385467 385468TIterateTest classTrait 385469 uses: {}! 385470Trait named: #TOccurrencesForIdentityCollectionsTest 385471 uses: {} 385472 category: 'CollectionsTests-Abstract'! 385473 385474!TOccurrencesForIdentityCollectionsTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:22'! 385475identityCollectionWithElementsCopyNotIdentical 385476" return a collection including elements for which #copy return a new object " 385477^ self explicitRequirement! ! 385478 385479 385480!TOccurrencesForIdentityCollectionsTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/13/2009 14:23'! 385481test0FixtureOccurrencesForIdentityCollectionsTest 385482 385483self shouldnt: [ self identityCollectionWithElementsCopyNotIdentical ] raise: Error. 385484self identityCollectionWithElementsCopyNotIdentical do: [ :each | self deny: each copy == each ].! ! 385485 385486 385487!TOccurrencesForIdentityCollectionsTest methodsFor: 'tests - occurrencesOf for identity collections' stamp: 'delaunay 5/13/2009 14:27'! 385488testOccurencesOfForIdentityCollections 385489 385490| collection element elementCopy | 385491collection := self identityCollectionWithElementsCopyNotIdentical . 385492element := collection anyOne. 385493elementCopy := element copy. 385494 385495self assert: (collection occurrencesOf: elementCopy ) = 0.! ! 385496 385497"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 385498 385499TOccurrencesForIdentityCollectionsTest classTrait 385500 uses: {}! 385501Trait named: #TOccurrencesForMultiplinessTest 385502 uses: TOccurrencesTest 385503 category: 'CollectionsTests-Abstract'! 385504 385505!TOccurrencesForMultiplinessTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:05'! 385506collectionWithEqualElements 385507" return a collecition including atLeast two elements equal" 385508 385509^ self explicitRequirement.! ! 385510 385511!TOccurrencesForMultiplinessTest methodsFor: 'requirements'! 385512collectionWithoutEqualElements 385513 self explicitRequirement! ! 385514 385515!TOccurrencesForMultiplinessTest methodsFor: 'requirements'! 385516elementNotInForOccurrences 385517" return an element notIncluded in #collectionWithoutEqualElements" 385518 self explicitRequirement! ! 385519 385520!TOccurrencesForMultiplinessTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:24'! 385521elementTwiceInForOccurrences 385522" return an element included exactly two time in # collectionWithEqualElements" 385523^ self explicitRequirement! ! 385524 385525!TOccurrencesForMultiplinessTest methodsFor: 'requirements'! 385526empty 385527 self explicitRequirement! ! 385528 385529 385530!TOccurrencesForMultiplinessTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/13/2009 15:35'! 385531test0FixtureOccurrencesForMultiplinessTest 385532 | cpt element collection | 385533 self shouldnt: [self collectionWithEqualElements ]raise: Error. 385534self shouldnt: [self collectionWithEqualElements ]raise: Error. 385535 385536self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 385537element := self elementTwiceInForOccurrences . 385538collection := self collectionWithEqualElements . 385539 385540cpt := 0 . 385541" testing with identity check ( == ) so that identy collections can use this trait : " 385542self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. 385543self assert: cpt = 2.! ! 385544 385545!TOccurrencesForMultiplinessTest methodsFor: 'tests - fixture'! 385546test0FixtureOccurrencesTest 385547 | tmp | 385548 self shouldnt: [self empty ]raise: Error. 385549 self assert: self empty isEmpty. 385550 385551 self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. 385552 self deny: self collectionWithoutEqualElements isEmpty. 385553 385554 tmp := OrderedCollection new. 385555 self collectionWithoutEqualElements do: [ 385556 :each | 385557 self deny: (tmp includes: each). 385558 tmp add: each. 385559 ]. 385560 385561 385562 self shouldnt: [ self elementNotInForOccurrences ] raise: Error. 385563 self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! 385564 385565 385566!TOccurrencesForMultiplinessTest methodsFor: 'tests - occurrencesOf'! 385567testOccurrencesOf 385568 | collection | 385569 collection := self collectionWithoutEqualElements . 385570 385571 collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! 385572 385573!TOccurrencesForMultiplinessTest methodsFor: 'tests - occurrencesOf'! 385574testOccurrencesOfEmpty 385575 | result | 385576 result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). 385577 self assert: result = 0! ! 385578 385579!TOccurrencesForMultiplinessTest methodsFor: 'tests - occurrencesOf'! 385580testOccurrencesOfNotIn 385581 | result | 385582 result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. 385583 self assert: result = 0! ! 385584 385585 385586!TOccurrencesForMultiplinessTest methodsFor: 'tests - occurrencesOf for multipliness' stamp: 'delaunay 5/13/2009 15:22'! 385587testOccurrencesOfForMultipliness 385588 385589| collection element | 385590collection := self collectionWithEqualElements . 385591element := self elementTwiceInForOccurrences . 385592 385593self assert: (collection occurrencesOf: element ) = 2. ! ! 385594 385595"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 385596 385597TOccurrencesForMultiplinessTest classTrait 385598 uses: TOccurrencesTest classTrait! 385599Trait named: #TOccurrencesTest 385600 uses: {} 385601 category: 'CollectionsTests-Abstract'! 385602 385603!TOccurrencesTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:51'! 385604collectionWithoutEqualElements 385605 self explicitRequirement! ! 385606 385607!TOccurrencesTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:52'! 385608elementNotInForOccurrences 385609" return an element notIncluded in #collectionWithoutEqualElements" 385610 self explicitRequirement! ! 385611 385612!TOccurrencesTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:16'! 385613empty 385614 self explicitRequirement! ! 385615 385616 385617!TOccurrencesTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/13/2009 14:59'! 385618test0FixtureOccurrencesTest 385619 | tmp | 385620 self shouldnt: [self empty ]raise: Error. 385621 self assert: self empty isEmpty. 385622 385623 self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. 385624 self deny: self collectionWithoutEqualElements isEmpty. 385625 385626 tmp := OrderedCollection new. 385627 self collectionWithoutEqualElements do: [ 385628 :each | 385629 self deny: (tmp includes: each). 385630 tmp add: each. 385631 ]. 385632 385633 385634 self shouldnt: [ self elementNotInForOccurrences ] raise: Error. 385635 self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! 385636 385637 385638!TOccurrencesTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 5/13/2009 14:55'! 385639testOccurrencesOf 385640 | collection | 385641 collection := self collectionWithoutEqualElements . 385642 385643 collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! 385644 385645!TOccurrencesTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 5/13/2009 14:55'! 385646testOccurrencesOfEmpty 385647 | result | 385648 result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). 385649 self assert: result = 0! ! 385650 385651!TOccurrencesTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 5/13/2009 14:51'! 385652testOccurrencesOfNotIn 385653 | result | 385654 result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. 385655 self assert: result = 0! ! 385656 385657"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 385658 385659TOccurrencesTest classTrait 385660 uses: {}! 385661Trait named: #TPrintOnSequencedTest 385662 uses: TPrintTest 385663 category: 'CollectionsTests-Abstract'! 385664 385665!TPrintOnSequencedTest methodsFor: 'requirements' stamp: 'delaunay 4/10/2009 09:46'! 385666nonEmpty 385667 self explicitRequirement! ! 385668 385669 385670!TPrintOnSequencedTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/10/2009 09:47'! 385671test0FixturePrintTest 385672 385673 self shouldnt: [self nonEmpty ] raise: Error.! ! 385674 385675 385676!TPrintOnSequencedTest methodsFor: 'tests - printing' stamp: 'delaunay 4/10/2009 10:52'! 385677testPrintElementsOn 385678 385679 | aStream result allElementsAsString | 385680 result:=''. 385681 aStream:= ReadWriteStream on: result. 385682 385683 self nonEmpty printElementsOn: aStream . 385684 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 385685 1 to: allElementsAsString size do: 385686 [:i | 385687 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 385688 ].! ! 385689 385690!TPrintOnSequencedTest methodsFor: 'tests - printing' stamp: 'delaunay 4/10/2009 15:13'! 385691testPrintNameOn 385692 385693 | aStream result | 385694 result:=''. 385695 aStream:= ReadWriteStream on: result. 385696 385697 self nonEmpty printNameOn: aStream . 385698 Transcript show: result asString. 385699 self nonEmpty class name first isVowel 385700 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 385701 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 385702 385703!TPrintOnSequencedTest methodsFor: 'tests - printing' stamp: 'delaunay 4/10/2009 15:22'! 385704testPrintOn 385705 | aStream result allElementsAsString | 385706 result:=''. 385707 aStream:= ReadWriteStream on: result. 385708 385709 self nonEmpty printOn: aStream . 385710 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 385711 1 to: allElementsAsString size do: 385712 [:i | 385713 i=1 385714 ifTrue:[ 385715 self accessCollection class name first isVowel 385716 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 385717 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 385718 i=2 385719 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 385720 i>2 385721 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. 385722 ].! ! 385723 385724!TPrintOnSequencedTest methodsFor: 'tests - printing' stamp: 'delaunay 4/10/2009 10:29'! 385725testPrintOnDelimiter 385726 | aStream result allElementsAsString | 385727 result:=''. 385728 aStream:= ReadWriteStream on: result. 385729 385730 self nonEmpty printOn: aStream delimiter: ', ' . 385731 385732 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 385733 1 to: allElementsAsString size do: 385734 [:i | 385735 self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). 385736 ].! ! 385737 385738!TPrintOnSequencedTest methodsFor: 'tests - printing' stamp: 'delaunay 4/10/2009 10:28'! 385739testPrintOnDelimiterLast 385740 385741 | aStream result allElementsAsString | 385742 result:=''. 385743 aStream:= ReadWriteStream on: result. 385744 385745 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 385746 385747 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 385748 1 to: allElementsAsString size do: 385749 [:i | 385750 i<(allElementsAsString size-1 ) 385751 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. 385752 i=(allElementsAsString size-1) 385753 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 385754 i=(allElementsAsString size) 385755 ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. 385756 ].! ! 385757 385758!TPrintOnSequencedTest methodsFor: 'tests - printing'! 385759testStoreOn 385760" for the moment work only for collection that include simple elements such that Integer" 385761 385762"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 385763string := ''. 385764str := ReadWriteStream on: string. 385765elementsAsStringExpected := OrderedCollection new. 385766elementsAsStringObtained := OrderedCollection new. 385767self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 385768 385769self nonEmpty storeOn: str. 385770result := str contents . 385771cuttedResult := ( result findBetweenSubStrs: ';' ). 385772 385773index := 1. 385774 385775cuttedResult do: 385776 [ :each | 385777 index = 1 385778 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 385779 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 385780 elementsAsStringObtained add: tmp. 385781 index := index + 1. ] 385782 ifFalse: [ 385783 index < cuttedResult size 385784 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 385785 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 385786 elementsAsStringObtained add: tmp. 385787 index := index + 1.] 385788 ifFalse: [self assert: ( each = ' yourself)' ) ]. 385789 ] 385790 385791 ]. 385792 385793 385794 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 385795 385796! ! 385797 385798"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 385799 385800TPrintOnSequencedTest classTrait 385801 uses: TPrintTest classTrait! 385802Trait named: #TPrintTest 385803 uses: {} 385804 category: 'CollectionsTests-Abstract'! 385805 385806!TPrintTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 16:30'! 385807nonEmpty 385808 self explicitRequirement! ! 385809 385810 385811!TPrintTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/23/2009 14:11'! 385812test0FixturePrintTest 385813 385814 self shouldnt: [self nonEmpty ] raise: Error. 385815 self deny: self nonEmpty isEmpty.! ! 385816 385817 385818!TPrintTest methodsFor: 'tests - printing' stamp: 'delaunay 4/27/2009 10:16'! 385819testPrintElementsOn 385820 385821 | aStream result allElementsAsString tmp | 385822 result:=''. 385823 aStream:= ReadWriteStream on: result. 385824 tmp:= OrderedCollection new. 385825 self nonEmpty do: [:each | tmp add: each asString]. 385826 385827 self nonEmpty printElementsOn: aStream . 385828 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 385829 1 to: allElementsAsString size do: 385830 [:i | 385831 self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)). 385832 ].! ! 385833 385834!TPrintTest methodsFor: 'tests - printing' stamp: 'delaunay 4/14/2009 16:31'! 385835testPrintNameOn 385836 385837 | aStream result | 385838 result:=''. 385839 aStream:= ReadWriteStream on: result. 385840 385841 self nonEmpty printNameOn: aStream . 385842 Transcript show: result asString. 385843 self nonEmpty class name first isVowel 385844 ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] 385845 ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! 385846 385847!TPrintTest methodsFor: 'tests - printing' stamp: 'delaunay 4/27/2009 10:17'! 385848testPrintOn 385849 | aStream result allElementsAsString tmp | 385850 result:=''. 385851 aStream:= ReadWriteStream on: result. 385852 tmp:= OrderedCollection new. 385853 self nonEmpty do: [:each | tmp add: each asString]. 385854 385855 self nonEmpty printOn: aStream . 385856 allElementsAsString:=(result findBetweenSubStrs: ' ' ). 385857 1 to: allElementsAsString size do: 385858 [:i | 385859 i=1 385860 ifTrue:[ 385861 self accessCollection class name first isVowel 385862 ifTrue:[self assert: (allElementsAsString at:i)='an' ] 385863 ifFalse:[self assert: (allElementsAsString at:i)='a'].]. 385864 i=2 385865 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. 385866 i>2 385867 ifTrue:[self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)).]. 385868 ].! ! 385869 385870!TPrintTest methodsFor: 'tests - printing' stamp: 'delaunay 4/27/2009 10:17'! 385871testPrintOnDelimiter 385872 | aStream result allElementsAsString tmp | 385873 result:=''. 385874 aStream:= ReadWriteStream on: result. 385875 tmp:= OrderedCollection new. 385876 self nonEmpty do: [:each | tmp add: each asString]. 385877 385878 385879 385880 self nonEmpty printOn: aStream delimiter: ', ' . 385881 385882 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 385883 1 to: allElementsAsString size do: 385884 [:i | 385885 self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)) 385886 ].! ! 385887 385888!TPrintTest methodsFor: 'tests - printing' stamp: 'delaunay 4/27/2009 10:17'! 385889testPrintOnDelimiterLast 385890 385891 | aStream result allElementsAsString tmp | 385892 result:=''. 385893 aStream:= ReadWriteStream on: result. 385894 tmp:= OrderedCollection new. 385895 self nonEmpty do: [:each | tmp add: each asString]. 385896 385897 self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. 385898 385899 allElementsAsString:=(result findBetweenSubStrs: ', ' ). 385900 1 to: allElementsAsString size do: 385901 [:i | 385902 i<(allElementsAsString size-1 ) 385903 ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. 385904 i=(allElementsAsString size-1) 385905 ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. 385906 i=(allElementsAsString size) 385907 ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. 385908 ].! ! 385909 385910!TPrintTest methodsFor: 'tests - printing' stamp: 'delaunay 5/6/2009 14:26'! 385911testStoreOn 385912" for the moment work only for collection that include simple elements such that Integer" 385913 385914"| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | 385915string := ''. 385916str := ReadWriteStream on: string. 385917elementsAsStringExpected := OrderedCollection new. 385918elementsAsStringObtained := OrderedCollection new. 385919self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. 385920 385921self nonEmpty storeOn: str. 385922result := str contents . 385923cuttedResult := ( result findBetweenSubStrs: ';' ). 385924 385925index := 1. 385926 385927cuttedResult do: 385928 [ :each | 385929 index = 1 385930 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). 385931 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 385932 elementsAsStringObtained add: tmp. 385933 index := index + 1. ] 385934 ifFalse: [ 385935 index < cuttedResult size 385936 ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). 385937 tmp := each copyFrom: ( tmp size + 1) to: ( each size ). 385938 elementsAsStringObtained add: tmp. 385939 index := index + 1.] 385940 ifFalse: [self assert: ( each = ' yourself)' ) ]. 385941 ] 385942 385943 ]. 385944 385945 385946 elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" 385947 385948! ! 385949 385950"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 385951 385952TPrintTest classTrait 385953 uses: {}! 385954Trait named: #TPureBehavior 385955 uses: {} 385956 category: 'Traits-Kernel-Traits'! 385957 385958!TPureBehavior methodsFor: '*traits' stamp: 'al 9/16/2005 14:48'! 385959providedSelectors 385960 ^ProvidedSelectors current for: self! ! 385961 385962 385963!TPureBehavior methodsFor: 'accessing class hierarchy' stamp: 'damiencassou 1/20/2009 10:35'! 385964withAllSubclassesDo: aBlock 385965 | temp | 385966 temp := self allSubclassesDo: aBlock. 385967 aBlock value: self! ! 385968 385969!TPureBehavior methodsFor: 'accessing class hierarchy' stamp: 'al 12/31/2005 13:40'! 385970withAllSuperclasses 385971 "Answer an OrderedCollection of the receiver and the receiver's 385972 superclasses. The first element is the receiver, 385973 followed by its superclass; the last element is Object." 385974 385975 | temp | 385976 temp := self allSuperclasses. 385977 temp addFirst: self. 385978 ^ temp! ! 385979 385980 385981!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:12'! 385982allSelectors 385983 self explicitRequirement! ! 385984 385985!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:13'! 385986basicLocalSelectors 385987 self explicitRequirement! ! 385988 385989!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:13'! 385990basicLocalSelectors: aSetOrNil 385991 self explicitRequirement! ! 385992 385993!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 11/28/2005 21:48'! 385994changeRecordsAt: selector 385995 "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." 385996 385997 "(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]" 385998 ^ChangeSet 385999 scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil]) 386000 class: self meta: self isMeta 386001 category: (self whichCategoryIncludesSelector: selector) 386002 selector: selector.! ! 386003 386004!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:14'! 386005classAndMethodFor: aSymbol do: binaryBlock ifAbsent: absentBlock 386006 "Looks up the selector aSymbol in this class/trait. If it is found, binaryBlock is evaluated 386007 with this class/trait and the associated method. Otherwise absentBlock is evaluated. 386008 Note that this implementation is very simple because PureBehavior does not know 386009 about inheritance (cf. implementation in Behavior)" 386010 386011 ^ binaryBlock value: self value: (self compiledMethodAt: aSymbol ifAbsent: [^ absentBlock value]).! ! 386012 386013!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 8/2/2004 16:29'! 386014compiledMethodAt: selector 386015 "Answer the compiled method associated with the argument, selector (a 386016 Symbol), a message selector in the receiver's method dictionary. If the 386017 selector is not in the dictionary, create an error notification." 386018 386019 ^ self methodDict at: selector! ! 386020 386021!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 20:55'! 386022compiledMethodAt: selector ifAbsent: aBlock 386023 "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock" 386024 386025 ^ self methodDict at: selector ifAbsent: [aBlock value]! ! 386026 386027!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 20:55'! 386028compress 386029 "Compact the method dictionary of the receiver." 386030 386031 self methodDict rehash! ! 386032 386033!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:01'! 386034compressedSourceCodeAt: selector 386035 "(Paragraph compressedSourceCodeAt: #displayLines:affectedRectangle:) size 721 1921 386036 Paragraph selectors inject: 0 into: [:tot :sel | tot + (Paragraph compressedSourceCodeAt: sel) size] 13606 31450" 386037 | rawText parse | 386038 rawText := (self sourceCodeAt: selector) asString. 386039 parse := self compilerClass new parse: rawText in: self notifying: nil. 386040 ^ rawText compressWithTable: 386041 ((selector keywords , 386042 parse tempNames , 386043 self instVarNames , 386044 #(self super ifTrue: ifFalse:) , 386045 ((0 to: 7) collect: 386046 [:i | String streamContents: 386047 [:s | s cr. i timesRepeat: [s tab]]]) , 386048 (self compiledMethodAt: selector) literalStrings) 386049 asSortedCollection: [:a :b | a size > b size])! ! 386050 386051!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 11/28/2005 11:46'! 386052deregisterLocalSelector: aSymbol 386053 self basicLocalSelectors notNil ifTrue: [ 386054 self basicLocalSelectors remove: aSymbol ifAbsent: []]! ! 386055 386056!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 12/1/2005 15:40'! 386057firstCommentAt: selector 386058 "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote." 386059 386060 |someComments| 386061 someComments := self commentsAt: selector. 386062 ^someComments isEmpty ifTrue: [''] ifFalse: [someComments first] 386063 386064 386065"Behavior firstCommentAt: #firstCommentAt:"! ! 386066 386067!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'PeterHugossonMiller 9/2/2009 16:00'! 386068firstPrecodeCommentFor: selector 386069 "If there is a comment in the source code at the given selector that preceeds the body of the method, return it here, else return nil" 386070 386071 | parser source tree | 386072 "Behavior firstPrecodeCommentFor: #firstPrecodeCommentFor:" 386073 (#(Comment Definition Hierarchy) includes: selector) 386074 ifTrue: 386075 ["Not really a selector" 386076 ^ nil]. 386077 source := self sourceCodeAt: selector asSymbol ifAbsent: [^ nil]. 386078 parser := self parserClass new. 386079 tree := 386080 parser 386081 parse: source readStream 386082 class: self 386083 noPattern: false 386084 context: nil 386085 notifying: nil 386086 ifFail: [^ nil]. 386087 ^ (tree comment ifNil: [^ nil]) first! ! 386088 386089!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:49'! 386090"popeye" formalHeaderPartsFor: "olive oil" aSelector 386091 "RELAX!! The warning you may have just seen about possibly having a bad source file does not apply here, because this method *intends* to have its source code start with a comment. 386092 This method returns a collection giving the parts in the formal declaration for aSelector. This parse is in support of schemes in which adjutant properties of a method can be declared via special comments secreted in the formal header 386093 The result will have 386094 3 elements for a simple, argumentless selector. 386095 5 elements for a single-argument selector 386096 9 elements for a two-argument selector 386097 13 elements for a three-argument, selector 386098 etc... 386099 386100 The syntactic elements are: 386101 386102 1 comment preceding initial selector fragment 386103 386104 2 first selector fragment 386105 3 comment following first selector fragment (nil if selector has no arguments) 386106 386107 ---------------------- (ends here for, e.g., #copy) 386108 386109 4 first formal argument 386110 5 comment following first formal argument (nil if selector has only one argument) 386111 386112 ---------------------- (ends here for, e.g., #copyFrom:) 386113 386114 6 second keyword 386115 7 comment following second keyword 386116 8 second formal argument 386117 9 comment following second formal argument (nil if selector has only two arguments) 386118 386119 ---------------------- (ends here for, e.g., #copyFrom:to:) 386120 386121 Any nil element signifies an absent comment. 386122 NOTE: The comment following the final formal argument is *not* successfully retrieved by this method in its current form, though it can be obtained, if needed, by other means (e.g. calling #firstPrecodeCommentFor:). Thus, the *final* element in the structure returned by this method is always going to be nil." 386123 386124 ^ Scanner new scanMessageParts: (self methodHeaderFor: aSelector) 386125 386126" 386127 Behavior class formalHeaderPartsFor: #formalHeaderPartsFor: 386128" 386129 386130 386131 ! ! 386132 386133!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:49'! 386134formalParametersAt: aSelector 386135 "Return the names of the arguments used in this method." 386136 386137 | source parser message list params | 386138 source := self sourceCodeAt: aSelector ifAbsent: [^ #()]. "for now" 386139 (parser := self parserClass new) parseSelector: source. 386140 message := source copyFrom: 1 to: (parser endOfLastToken min: source size). 386141 list := message string findTokens: Character separators. 386142 params := OrderedCollection new. 386143 list withIndexDo: [:token :ind | ind even ifTrue: [params addLast: token]]. 386144 ^ params! ! 386145 386146!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:50'! 386147lookupSelector: selector 386148 ^ self explicitRequirement! ! 386149 386150!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:50'! 386151methodDict 386152 ^ self explicitRequirement! ! 386153 386154!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:02'! 386155methodDictionary 386156 "Convenience" 386157 ^self methodDict! ! 386158 386159!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/30/2005 18:24'! 386160methodDictionary: aDictionary 386161 self methodDict: aDictionary! ! 386162 386163!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:50'! 386164methodDict: aDictionary 386165 ^ self explicitRequirement! ! 386166 386167!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:50'! 386168methodHeaderFor: selector 386169 "Answer the string corresponding to the method header for the given selector" 386170 386171 | sourceString parser | 386172 sourceString := self ultimateSourceCodeAt: selector ifAbsent: [self standardMethodHeaderFor: selector]. 386173 (parser := self parserClass new) parseSelector: sourceString. 386174 ^ sourceString asString copyFrom: 1 to: (parser endOfLastToken min: sourceString size) 386175 386176 "Behavior methodHeaderFor: #methodHeaderFor: " 386177! ! 386178 386179!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:02'! 386180methodsDo: aBlock 386181 "Evaluate aBlock for all the compiled methods in my method dictionary." 386182 386183 ^ self methodDict valuesDo: aBlock! ! 386184 386185!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 11/28/2005 11:47'! 386186registerLocalSelector: aSymbol 386187 self basicLocalSelectors notNil ifTrue: [ 386188 self basicLocalSelectors add: aSymbol]! ! 386189 386190!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:03'! 386191selectors 386192 "Answer a Set of all the message selectors specified in the receiver's 386193 method dictionary." 386194 386195 ^ self methodDict keys! ! 386196 386197!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:03'! 386198selectorsAndMethodsDo: aBlock 386199 "Evaluate selectorBlock for all the message selectors in my method dictionary." 386200 386201 ^ self methodDict keysAndValuesDo: aBlock! ! 386202 386203!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:03'! 386204selectorsDo: selectorBlock 386205 "Evaluate selectorBlock for all the message selectors in my method dictionary." 386206 386207 ^ self methodDict keysDo: selectorBlock! ! 386208 386209!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:03'! 386210selectorsWithArgs: numberOfArgs 386211 "Return all selectors defined in this class that take this number of arguments. Could use String.keywords. Could see how compiler does this." 386212 386213 | list num | 386214 list := OrderedCollection new. 386215 self selectorsDo: [:aSel | 386216 num := aSel count: [:char | char == $:]. 386217 num = 0 ifTrue: [aSel last isLetter ifFalse: [num := 1]]. 386218 num = numberOfArgs ifTrue: [list add: aSel]]. 386219 ^ list! ! 386220 386221!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:04'! 386222sourceCodeAt: selector 386223 386224 ^ (self methodDict at: selector) getSourceFor: selector in: self! ! 386225 386226!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:04'! 386227sourceCodeAt: selector ifAbsent: aBlock 386228 386229 ^ (self methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self! ! 386230 386231!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:04'! 386232sourceMethodAt: selector 386233 "Answer the paragraph corresponding to the source code for the 386234 argument." 386235 386236 ^(self sourceCodeAt: selector) asText makeSelectorBoldIn: self! ! 386237 386238!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/30/2004 21:05'! 386239sourceMethodAt: selector ifAbsent: aBlock 386240 "Answer the paragraph corresponding to the source code for the 386241 argument." 386242 386243 ^ (self sourceCodeAt: selector ifAbsent: [^ aBlock value]) asText makeSelectorBoldIn: self! ! 386244 386245!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:51'! 386246standardMethodHeaderFor: aSelector 386247 | args | 386248 args := (1 to: aSelector numArgs) collect:[:i| 'arg', i printString]. 386249 args size = 0 ifTrue:[^aSelector asString]. 386250 args size = 1 ifTrue:[^aSelector,' arg1']. 386251 ^String streamContents:[:s| 386252 (aSelector findTokens:':') with: args do:[:tok :arg| 386253 s nextPutAll: tok; nextPutAll:': '; nextPutAll: arg; nextPutAll:' '. 386254 ]. 386255 ]. 386256! ! 386257 386258!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/16/2005 14:51'! 386259ultimateSourceCodeAt: selector ifAbsent: aBlock 386260 "Return the source code at selector" 386261 386262 ^self 386263 sourceCodeAt: selector 386264 ifAbsent: aBlock! ! 386265 386266!TPureBehavior methodsFor: 'accessing method dictionary' stamp: 'al 8/2/2004 16:26'! 386267>> selector 386268 "Answer the compiled method associated with the argument, selector (a 386269 Symbol), a message selector in the receiver's method dictionary. If the 386270 selector is not in the dictionary, create an error notification." 386271 386272 ^self compiledMethodAt: selector 386273! ! 386274 386275 386276!TPureBehavior methodsFor: 'adding/removing methods' stamp: 'al 9/16/2005 14:31'! 386277addSelectorSilently: selector withMethod: compiledMethod 386278 self methodDictAddSelectorSilently: selector withMethod: compiledMethod. 386279 self registerLocalSelector: selector! ! 386280 386281!TPureBehavior methodsFor: 'adding/removing methods' stamp: 'al 7/30/2004 22:43'! 386282addSelector: selector withMethod: compiledMethod 386283 ^ self addSelector: selector withMethod: compiledMethod notifying: nil! ! 386284 386285!TPureBehavior methodsFor: 'adding/removing methods' stamp: 'al 7/30/2004 22:43'! 386286addSelector: selector withMethod: compiledMethod notifying: requestor 386287 ^ self addSelectorSilently: selector withMethod: compiledMethod! ! 386288 386289!TPureBehavior methodsFor: 'adding/removing methods' stamp: 'adrian_lienhard 2/1/2009 17:32'! 386290basicAddSelector: selector withMethod: compiledMethod 386291 "Add the message selector with the corresponding compiled method to the 386292 receiver's method dictionary. 386293 Do this without sending system change notifications" 386294 386295 | oldMethodOrNil | 386296 oldMethodOrNil := self lookupSelector: selector. 386297 self methodDict at: selector put: compiledMethod. 386298 compiledMethod methodClass: self. 386299 compiledMethod selector: selector. 386300 386301 "Now flush Squeak's method cache, either by selector or by method" 386302 oldMethodOrNil ifNotNil: [oldMethodOrNil flushCache]. 386303 selector flushCache.! ! 386304 386305!TPureBehavior methodsFor: 'adding/removing methods' stamp: 'al 7/30/2004 22:43'! 386306basicRemoveSelector: selector 386307 "Assuming that the argument, selector (a Symbol), is a message selector 386308 in my method dictionary, remove it and its method." 386309 386310 | oldMethod | 386311 oldMethod := self methodDict at: selector ifAbsent: [^ self]. 386312 self methodDict removeKey: selector. 386313 386314 "Now flush Squeak's method cache, either by selector or by method" 386315 oldMethod flushCache. 386316 selector flushCache! ! 386317 386318!TPureBehavior methodsFor: 'adding/removing methods' stamp: 'al 11/28/2005 11:47'! 386319localSelectors 386320 "Return a set of selectors defined locally. 386321 The instance variable is lazily initialized. If it is nil then there 386322 are no non-local selectors" 386323 386324 ^ self basicLocalSelectors isNil 386325 ifTrue: [self selectors] 386326 ifFalse: [self basicLocalSelectors].! ! 386327 386328!TPureBehavior methodsFor: 'adding/removing methods' stamp: 'adrian_lienhard 2/17/2009 22:00'! 386329methodDictAddSelectorSilently: selector withMethod: compiledMethod 386330 self basicAddSelector: selector withMethod: compiledMethod! ! 386331 386332!TPureBehavior methodsFor: 'adding/removing methods' stamp: 'al 7/30/2004 22:50'! 386333removeSelectorSilently: selector 386334 "Remove selector without sending system change notifications" 386335 386336 ^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].! ! 386337 386338!TPureBehavior methodsFor: 'adding/removing methods' stamp: 'al 3/26/2006 21:37'! 386339removeSelector: aSelector 386340 "Assuming that the argument, selector (a Symbol), is a message selector 386341 in my method dictionary, remove it and its method. 386342 386343 If the method to remove will be replaced by a method from my trait composition, 386344 the current method does not have to be removed because we mark it as non-local. 386345 If it is not identical to the actual method from the trait it will be replaced automatically 386346 by #noteChangedSelectors:. 386347 386348 This is useful to avoid bootstrapping problems when moving methods to a trait 386349 (e.g., from TPureBehavior to TMethodDictionaryBehavior). Manual moving (implementing 386350 the method in the trait and then remove it from the class) does not work if the methods 386351 themselves are used for this process (such as compiledMethodAt:, includesLocalSelector: or 386352 addTraitSelector:withMethod:)" 386353 386354 | changeFromLocalToTraitMethod | 386355 changeFromLocalToTraitMethod := (self includesLocalSelector: aSelector) 386356 and: [self hasTraitComposition] 386357 and: [self traitComposition includesMethod: aSelector]. 386358 386359 changeFromLocalToTraitMethod 386360 ifFalse: [self basicRemoveSelector: aSelector] 386361 ifTrue: [self ensureLocalSelectors]. 386362 self deregisterLocalSelector: aSelector. 386363 self noteChangedSelectors: (Array with: aSelector) 386364 386365! ! 386366 386367 386368!TPureBehavior methodsFor: 'compiling' stamp: 'md 3/5/2006 23:49'! 386369binding 386370 ^ nil -> self! ! 386371 386372!TPureBehavior methodsFor: 'compiling' stamp: 'al 11/28/2005 11:28'! 386373bindingOf: varName 386374 386375 "Answer the binding of some variable resolved in the scope of the receiver" 386376 | aSymbol binding | 386377 aSymbol := varName asSymbol. 386378 386379 "Look in declared environment." 386380 binding := self environment bindingOf: aSymbol. 386381 ^binding! ! 386382 386383!TPureBehavior methodsFor: 'compiling' stamp: 'al 7/30/2004 22:02'! 386384compileAll 386385 ^ self compileAllFrom: self! ! 386386 386387!TPureBehavior methodsFor: 'compiling' stamp: 'al 7/30/2004 22:02'! 386388compileAllFrom: oldClass 386389 "Compile all the methods in the receiver's method dictionary. 386390 This validates sourceCode and variable references and forces 386391 all methods to use the current bytecode set" 386392 "ar 7/10/1999: Use oldClass selectors not self selectors" 386393 386394 oldClass selectorsDo: [:sel | self recompile: sel from: oldClass]. 386395 self environment currentProjectDo: [:proj | proj compileAllIsolated: self from: oldClass].! ! 386396 386397!TPureBehavior methodsFor: 'compiling' stamp: 'al 11/28/2005 11:28'! 386398compilerClass 386399 "Answer a compiler class appropriate for source methods of this class." 386400 386401 ^Compiler! ! 386402 386403!TPureBehavior methodsFor: 'compiling' stamp: 'al 8/2/2004 19:34'! 386404compile: code 386405 "Compile the argument, code, as source code in the context of the 386406 receiver. Create an error notification if the code can not be compiled. 386407 The argument is either a string or an object that converts to a string or a 386408 PositionableStream on an object that converts to a string." 386409 386410 ^self compile: code notifying: nil! ! 386411 386412!TPureBehavior methodsFor: 'compiling' stamp: 'md 2/28/2006 10:04'! 386413compile: code classified: category notifying: requestor trailer: bytes ifFail: failBlock 386414 "Compile code without logging the source in the changes file" 386415 386416 | methodNode | 386417 methodNode := self compilerClass new 386418 compile: code 386419 in: self 386420 classified: category 386421 notifying: requestor 386422 ifFail: failBlock. 386423 ^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! ! 386424 386425!TPureBehavior methodsFor: 'compiling' stamp: 'al 11/28/2005 21:52'! 386426compile: code notifying: requestor 386427 "Compile the argument, code, as source code in the context of the 386428 receiver and insEtall the result in the receiver's method dictionary. The 386429 second argument, requestor, is to be notified if an error occurs. The 386430 argument code is either a string or an object that converts to a string or 386431 a PositionableStream. This method also saves the source code." 386432 386433 | methodAndNode | 386434 methodAndNode := self 386435 compile: code "a Text" 386436 classified: nil 386437 notifying: requestor 386438 trailer: self defaultMethodTrailer 386439 ifFail: [^nil]. 386440 methodAndNode method putSource: code fromParseNode: methodAndNode node inFile: 2 386441 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr]. 386442 self addSelector: methodAndNode selector withMethod: methodAndNode method notifying: requestor. 386443 ^ methodAndNode selector! ! 386444 386445!TPureBehavior methodsFor: 'compiling' stamp: 'md 3/1/2006 20:01'! 386446decompilerClass 386447 "Answer a decompiler class appropriate for compiled methods of this class." 386448 386449 ^ self compilerClass decompilerClass! ! 386450 386451!TPureBehavior methodsFor: 'compiling' stamp: 'al 11/28/2005 11:28'! 386452decompile: selector 386453 "Find the compiled code associated with the argument, selector, as a 386454 message selector in the receiver's method dictionary and decompile it. 386455 Answer the resulting source code as a string. Create an error notification 386456 if the selector is not in the receiver's method dictionary." 386457 386458 ^self decompilerClass new decompile: selector in: self! ! 386459 386460!TPureBehavior methodsFor: 'compiling' stamp: 'al 8/2/2004 19:57'! 386461defaultMethodTrailer 386462 ^ #(0 0 0 0)! ! 386463 386464!TPureBehavior methodsFor: 'compiling' stamp: 'al 11/28/2005 11:28'! 386465evaluatorClass 386466 "Answer an evaluator class appropriate for evaluating expressions in the 386467 context of this class." 386468 386469 ^Compiler! ! 386470 386471!TPureBehavior methodsFor: 'compiling' stamp: 'al 11/28/2005 11:28'! 386472parserClass 386473 "Answer a parser class to use for parsing method headers." 386474 386475 ^self compilerClass parserClass! ! 386476 386477!TPureBehavior methodsFor: 'compiling' stamp: 'al 7/30/2004 22:17'! 386478recompileChanges 386479 "Compile all the methods that are in the changes file. 386480 This validates sourceCode and variable references and forces 386481 methods to use the current bytecode set" 386482 386483 self selectorsDo: 386484 [:sel | (self compiledMethodAt: sel) fileIndex > 1 ifTrue: 386485 [self recompile: sel from: self]]! ! 386486 386487!TPureBehavior methodsFor: 'compiling' stamp: 'al 7/30/2004 22:17'! 386488recompileNonResidentMethod: method atSelector: selector from: oldClass 386489 "Recompile the method supplied in the context of this class." 386490 386491 | trailer methodNode | 386492 trailer := method trailer. 386493 methodNode := self compilerClass new 386494 compile: (method getSourceFor: selector in: oldClass) 386495 in: self 386496 notifying: nil 386497 ifFail: ["We're in deep doo-doo if this fails (syntax error). 386498 Presumably the user will correct something and proceed, 386499 thus installing the result in this methodDict. We must 386500 retrieve that new method, and restore the original (or remove) 386501 and then return the method we retrieved." 386502 ^ self error: 'see comment']. 386503 selector == methodNode selector ifFalse: [self error: 'selector changed!!']. 386504 ^ methodNode generate: trailer 386505! ! 386506 386507!TPureBehavior methodsFor: 'compiling' stamp: 'al 7/30/2004 22:03'! 386508recompile: selector 386509 "Compile the method associated with selector in the receiver's method dictionary." 386510 ^self recompile: selector from: self! ! 386511 386512!TPureBehavior methodsFor: 'compiling' stamp: 'al 7/30/2004 22:03'! 386513recompile: selector from: oldClass 386514 "Compile the method associated with selector in the receiver's method dictionary." 386515 "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" 386516 | method trailer methodNode | 386517 method := oldClass compiledMethodAt: selector. 386518 trailer := method trailer. 386519 methodNode := self compilerClass new 386520 compile: (oldClass sourceCodeAt: selector) 386521 in: self 386522 notifying: nil 386523 ifFail: [^ self]. "Assume OK after proceed from SyntaxError" 386524 selector == methodNode selector ifFalse: [self error: 'selector changed!!']. 386525 self basicAddSelector: selector withMethod: (methodNode generate: trailer). 386526! ! 386527 386528!TPureBehavior methodsFor: 'compiling' stamp: 'al 9/16/2005 14:17'! 386529sourceCodeTemplate 386530 "Answer an expression to be edited and evaluated in order to define 386531 methods in this class or trait." 386532 386533 ^'message selector and argument names 386534 "comment stating purpose of message" 386535 386536 | temporary variable names | 386537 statements'! ! 386538 386539 386540!TPureBehavior methodsFor: 'copying' stamp: 'al 9/16/2005 14:19'! 386541copy 386542 "Answer a copy of the receiver without a list of subclasses." 386543 386544 | myCopy | 386545 myCopy := self shallowCopy. 386546 ^myCopy methodDictionary: self copyOfMethodDictionary! ! 386547 386548!TPureBehavior methodsFor: 'copying' stamp: 'al 7/30/2004 22:51'! 386549copyOfMethodDictionary 386550 "Return a copy of the receiver's method dictionary" 386551 386552 ^ self methodDict copy! ! 386553 386554!TPureBehavior methodsFor: 'copying' stamp: 'al 9/16/2005 14:20'! 386555deepCopy 386556 "Classes should only be shallowCopied or made anew." 386557 386558 ^ self shallowCopy! ! 386559 386560 386561!TPureBehavior methodsFor: 'initialization' stamp: 'al 12/1/2005 16:01'! 386562emptyMethodDictionary 386563 386564 ^ MethodDictionary new! ! 386565 386566!TPureBehavior methodsFor: 'initialization' stamp: 'al 12/1/2005 15:24'! 386567obsolete 386568 "Invalidate and recycle local methods, 386569 e.g., zap the method dictionary if can be done safely." 386570 self canZapMethodDictionary 386571 ifTrue: [self methodDict: self emptyMethodDictionary]. 386572 self hasTraitComposition ifTrue: [ 386573 self traitComposition traits do: [:each | 386574 each removeUser: self]]! ! 386575 386576 386577!TPureBehavior methodsFor: 'naming' stamp: 'al 9/16/2005 14:22'! 386578environment 386579 "Return the environment in which the receiver is visible" 386580 ^Smalltalk! ! 386581 386582!TPureBehavior methodsFor: 'naming' stamp: 'al 9/16/2005 14:21'! 386583name 386584 ^ self explicitRequirement! ! 386585 386586 386587!TPureBehavior methodsFor: 'newcompiler' stamp: 'md 3/1/2006 21:23'! 386588parseScope 386589 386590 ^ Smalltalk at: #ClassScope ifPresent: [:class | class new class: self]! ! 386591 386592 386593!TPureBehavior methodsFor: 'printing' stamp: 'al 9/16/2005 14:21'! 386594defaultNameStemForInstances 386595 "Answer a basis for external names for default instances of the receiver. 386596 For classees, the class-name itself is a good one." 386597 386598 ^ self name! ! 386599 386600!TPureBehavior methodsFor: 'printing' stamp: 'marcus.denker 11/10/2008 10:04'! 386601literalScannedAs: scannedLiteral notifying: requestor 386602 "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote). 386603 If scannedLiteral is not an association, answer it. 386604 Else, if it is of the form: 386605 nil->#NameOfMetaclass 386606 answer nil->theMetaclass, if any has that name, else report an error. 386607 Else, if it is of the form: 386608 #NameOfGlobalVariable->anythiEng 386609 answer the global, class, or pool association with that nameE, if any, else 386610 add it to Undeclared a answer the new Association." 386611 386612 | key value | 386613 (scannedLiteral isVariableBinding) 386614 ifFalse: [^ scannedLiteral]. 386615 key := scannedLiteral key. 386616 value := scannedLiteral value. 386617 key isNil 386618 ifTrue: "###<metaclass soleInstance name>" 386619 [(self bindingOf: value) ifNotNil:[:assoc| 386620 (assoc value isKindOf: Behavior) 386621 ifTrue: [^ nil->assoc value class]]. 386622 requestor notify: 'No such metaclass'. 386623 ^false]. 386624 (key isSymbol) 386625 ifTrue: "##<global var name>" 386626 [(self bindingOf: key) ifNotNil:[:assoc | ^assoc]. 386627 Undeclared at: key put: nil. 386628 ^Undeclared bindingOf: key]. 386629 requestor notify: '## must be followed by a non-local variable name'. 386630 ^false 386631 386632" Form literalScannedAs: 14 notifying: nil 14 386633 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm 386634 Form literalScannedAs: ##OneBitForm notifying: nil OneBitForm->a Form 386635 Form literalScannedAs: ##Form notifying: nil Form->Form 386636 Form literalScannedAs: ###Form notifying: nil nilE->Form class 386637"! ! 386638 386639!TPureBehavior methodsFor: 'printing' stamp: 'al 9/16/2005 14:21'! 386640longPrintOn: aStream 386641 "Append to the argument, aStream, the names and values of all of the receiver's instance variables. But, not useful for a class with a method dictionary." 386642 386643 aStream nextPutAll: '<<too complex to show>>'; cr.! ! 386644 386645!TPureBehavior methodsFor: 'printing' stamp: 'damiencassou 7/30/2009 11:07'! 386646prettyPrinterClass 386647 ^ PrettyPrinting prettyPrinterClassFor: self! ! 386648 386649!TPureBehavior methodsFor: 'printing' stamp: 'al 12/1/2005 15:37'! 386650storeLiteral: aCodeLiteral on: aStream 386651 "Store aCodeLiteral on aStream, changing an Association to ##GlobalName 386652 or ###MetaclassSoleInstanceName format if appropriate" 386653 | key value | 386654 (aCodeLiteral isVariableBinding) 386655 ifFalse: 386656 [aCodeLiteral storeOn: aStream. 386657 ^self]. 386658 key := aCodeLiteral key. 386659 (key isNil and: [(value := aCodeLiteral value) isMemberOf: Metaclass]) 386660 ifTrue: 386661 [aStream nextPutAll: '###'; nextPutAll: value soleInstance name. 386662 ^self]. 386663 (key isSymbol and: [(self bindingOf: key) notNil]) 386664 ifTrue: 386665 [aStream nextPutAll: '##'; nextPutAll: key. 386666 ^self]. 386667 aCodeLiteral storeOn: aStream! ! 386668 386669 386670!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:41'! 386671clearSendCaches 386672 LocalSends current clearOut: self! ! 386673 386674!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:41'! 386675hasRequiredSelectors 386676 ^ self requiredSelectors notEmpty! ! 386677 386678!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:41'! 386679requirements 386680 ^ self requiredSelectorsCache 386681 ifNil: [#()] 386682 ifNotNilDo: [:rsc | rsc requirements]! ! 386683 386684!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:42'! 386685sendCaches 386686 ^ self explicitRequirement! ! 386687 386688!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:42'! 386689sendCaches: aSendCaches 386690 ^ self explicitRequirement! ! 386691 386692!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:42'! 386693setRequiredStatusOf: selector to: aBoolean 386694 aBoolean 386695 ifTrue: [self requiredSelectorsCache addRequirement: selector] 386696 ifFalse: [self requiredSelectorsCache removeRequirement: selector].! ! 386697 386698!TPureBehavior methodsFor: 'send caches' stamp: 'al 9/16/2005 14:42'! 386699superRequirements 386700 ^ self requiredSelectorsCache superRequirements! ! 386701 386702 386703!TPureBehavior methodsFor: 'testing' stamp: 'al 9/16/2005 14:23'! 386704canZapMethodDictionary 386705 "Return true if it is safe to zap the method dictionary on #obsolete" 386706 ^true! ! 386707 386708!TPureBehavior methodsFor: 'testing' stamp: 'al 3/1/2006 23:02'! 386709includesBehavior: aBehavior 386710 ^self == aBehavior! ! 386711 386712 386713!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'al 9/16/2005 14:16'! 386714canUnderstand: selector 386715 "Answer whether the receiver can respond to the message whose selector 386716 is the argument." 386717 386718 ^ self classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false].! ! 386719 386720!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'marcus.denker 8/25/2008 09:23'! 386721hasMethods 386722 "Answer whether the receiver has any methods in its method dictionary." 386723 386724 ^ self methodDict notEmpty! ! 386725 386726!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'al 9/16/2005 14:16'! 386727includesLocalSelector: aSymbol 386728 ^self basicLocalSelectors isNil 386729 ifTrue: [self includesSelector: aSymbol] 386730 ifFalse: [self localSelectors includes: aSymbol]! ! 386731 386732!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'al 7/30/2004 22:35'! 386733includesSelector: aSymbol 386734 "Answer whether the message whose selector is the argument is in the 386735 method dictionary of the receiver's class." 386736 386737 ^ self methodDict includesKey: aSymbol! ! 386738 386739!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'al 7/30/2004 22:37'! 386740isAliasSelector: aSymbol 386741 "Return true if the selector aSymbol is an alias defined 386742 in my or in another composition somewhere deeper in 386743 the tree of traits compositions." 386744 386745 ^(self includesLocalSelector: aSymbol) not 386746 and: [self hasTraitComposition] 386747 and: [self traitComposition isAliasSelector: aSymbol]! ! 386748 386749!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'al 9/16/2005 14:16'! 386750isDisabledSelector: selector 386751 ^ self classAndMethodFor: selector do: [:c :m | m isDisabled] ifAbsent: [false]! ! 386752 386753!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'al 7/30/2004 22:37'! 386754isLocalAliasSelector: aSymbol 386755 "Return true if the selector aSymbol is an alias defined 386756 in my trait composition." 386757 386758 ^(self includesLocalSelector: aSymbol) not 386759 and: [self hasTraitComposition] 386760 and: [self traitComposition isLocalAliasSelector: aSymbol]! ! 386761 386762!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'al 9/16/2005 14:16'! 386763isProvidedSelector: selector 386764 ^ ProvidedSelectors current isSelector: selector providedIn: self 386765! ! 386766 386767!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'marcus.denker 9/29/2008 08:46'! 386768thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte 386769 "Answer a set of selectors whose methods access the argument as a 386770 literal. Dives into the compact literal notation, making it slow but 386771 thorough " 386772 386773 | selectors | 386774 selectors := IdentitySet new. 386775 self selectorsAndMethodsDo: [:sel :method | 386776 ((method hasLiteralThorough: literal) or: [specialFlag and: [method scanFor: specialByte]]) 386777 ifTrue: [selectors add: sel]]. 386778 ^ selectors! ! 386779 386780!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'al 7/30/2004 22:37'! 386781whichSelectorsReferTo: literal 386782 "Answer a Set of selectors whose methods access the argument as a 386783literal." 386784 386785 | special byte | 386786 special := self environment hasSpecialSelector: literal ifTrueSetByte: [:b | 386787byte := b]. 386788 ^self whichSelectorsReferTo: literal special: special byte: byte 386789 386790 "Rectangle whichSelectorsReferTo: #+."! ! 386791 386792!TPureBehavior methodsFor: 'testing method dictionary' stamp: 'md 2/15/2006 11:01'! 386793whichSelectorsReferTo: literal special: specialFlag byte: specialByte 386794 "Answer a set of selectors whose methods access the argument as a literal." 386795 386796 | who | 386797 who := IdentitySet new. 386798 self selectorsAndMethodsDo: 386799 [:sel :method | 386800 ((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]]) 386801 ifTrue: 386802 [((literal isVariableBinding) not 386803 or: [method literals allButLast includes: literal]) 386804 ifTrue: [who add: sel]]]. 386805 ^ who! ! 386806 386807 386808!TPureBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:51'! 386809addExclusionOf: aSymbol to: aTrait 386810 self setTraitComposition: ( 386811 self traitComposition copyWithExclusionOf: aSymbol to: aTrait)! ! 386812 386813!TPureBehavior methodsFor: 'traits' stamp: 'al 1/9/2006 17:58'! 386814addToComposition: aTrait 386815 self setTraitComposition: (self traitComposition copyTraitExpression 386816 add: aTrait; 386817 yourself)! ! 386818 386819!TPureBehavior methodsFor: 'traits' stamp: 'adrian_lienhard 2/1/2009 17:43'! 386820addTraitSelector: aSymbol withMethod: aCompiledMethod 386821 "Add aMethod with selector aSymbol to my 386822 methodDict. aMethod must not be defined locally." 386823 386824 | source methodAndNode | 386825 self assert: [(self includesLocalSelector: aSymbol) not]. 386826 self ensureLocalSelectors. 386827 386828 source := aCompiledMethod getSourceReplacingSelectorWith: aSymbol. 386829 methodAndNode := self 386830 compile: source 386831 classified: nil 386832 notifying: nil 386833 trailer: #(0 0 0 0) 386834 ifFail: [^nil]. 386835 methodAndNode method putSource: source fromParseNode: methodAndNode node inFile: 2 386836 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Trait method'; cr]. 386837 386838 self basicAddSelector: aSymbol withMethod: methodAndNode method! ! 386839 386840!TPureBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:39'! 386841applyChangesOfNewTraitCompositionReplacing: oldComposition 386842 | changedSelectors | 386843 changedSelectors := self traitComposition 386844 changedSelectorsComparedTo: oldComposition. 386845 changedSelectors isEmpty ifFalse: [ 386846 self noteChangedSelectors: changedSelectors]. 386847 self traitComposition isEmpty ifTrue: [ 386848 self purgeLocalSelectors]. 386849 ^changedSelectors! ! 386850 386851!TPureBehavior methodsFor: 'traits' stamp: 'al 11/28/2005 11:47'! 386852ensureLocalSelectors 386853 "Ensures that the instance variable localSelectors is effectively used to maintain 386854 the set of local selectors. 386855 This method must be called before any non-local selectors are added to the 386856 method dictionary!!" 386857 386858 self basicLocalSelectors isNil 386859 ifTrue: [self basicLocalSelectors: self selectors]! ! 386860 386861!TPureBehavior methodsFor: 'traits' stamp: 'al 10/22/2006 18:21'! 386862flattenDown: aTrait 386863 | selectors | 386864 self assert: [self hasTraitComposition and: [self traitComposition allTraits includes: aTrait]]. 386865 selectors := (self traitComposition transformationOfTrait: aTrait) selectors. 386866 self basicLocalSelectors: self basicLocalSelectors , selectors. 386867 self removeFromComposition: aTrait.! ! 386868 386869!TPureBehavior methodsFor: 'traits' stamp: 'al 10/22/2006 18:21'! 386870flattenDownAllTraits 386871 self traitComposition allTraits do: [:each | self flattenDown: each]. 386872 self assert: [ self traitComposition isEmpty ]. 386873 self traitComposition: nil.! ! 386874 386875!TPureBehavior methodsFor: 'traits' stamp: 'al 9/16/2005 14:29'! 386876hasTraitComposition 386877 self explicitRequirement! ! 386878 386879!TPureBehavior methodsFor: 'traits' stamp: 'al 8/6/2004 13:09'! 386880noteChangedSelectors: aCollection 386881 "Start update of my methodDict (after changes to traits in traitComposition 386882 or after a local method was removed from my methodDict). The argument 386883 is a collection of method selectors that may have been changed. Most of the time 386884 aCollection only holds one selector. But when there are aliases involved 386885 there may be several method changes that have to be propagated to users." 386886 386887 | affectedSelectors | 386888 affectedSelectors := IdentitySet new. 386889 aCollection do: [:selector | 386890 affectedSelectors addAll: (self updateMethodDictionarySelector: selector)]. 386891 self notifyUsersOfChangedSelectors: affectedSelectors. 386892 ^ affectedSelectors! ! 386893 386894!TPureBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:40'! 386895notifyUsersOfChangedSelectors: aCollection! ! 386896 386897!TPureBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:40'! 386898notifyUsersOfChangedSelector: aSelector 386899 self notifyUsersOfChangedSelectors: (Array with: aSelector)! ! 386900 386901!TPureBehavior methodsFor: 'traits' stamp: 'al 11/28/2005 11:47'! 386902purgeLocalSelectors 386903 self basicLocalSelectors: nil! ! 386904 386905!TPureBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:54'! 386906removeAlias: aSymbol of: aTrait 386907 self setTraitComposition: ( 386908 self traitComposition copyWithoutAlias: aSymbol of: aTrait)! ! 386909 386910!TPureBehavior methodsFor: 'traits' stamp: 'al 10/22/2006 18:22'! 386911removeFromComposition: aTrait 386912 self setTraitComposition: (self traitComposition copyTraitExpression 386913 removeFromComposition: aTrait)! ! 386914 386915!TPureBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:46'! 386916removeTraitSelector: aSymbol 386917 self assert: [(self includesLocalSelector: aSymbol) not]. 386918 self basicRemoveSelector: aSymbol! ! 386919 386920!TPureBehavior methodsFor: 'traits' stamp: 'al 9/16/2005 14:30'! 386921selfSentSelectorsFromSelectors: interestingSelectors 386922 | m result info | 386923 result := IdentitySet new. 386924 interestingSelectors collect: 386925 [:sel | 386926 m := self compiledMethodAt: sel ifAbsent: []. 386927 m ifNotNil: 386928 [info := (SendInfo on: m) collectSends. 386929 info selfSentSelectors do: [:sentSelector | result add: sentSelector]]]. 386930 ^result! ! 386931 386932!TPureBehavior methodsFor: 'traits' stamp: 'apb 8/22/2005 18:28'! 386933setTraitCompositionFrom: aTraitExpression 386934 ^ self setTraitComposition: aTraitExpression asTraitComposition! ! 386935 386936!TPureBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:48'! 386937setTraitComposition: aTraitComposition 386938 | oldComposition | 386939 (self hasTraitComposition not and: [aTraitComposition isEmpty]) ifTrue: [^self]. 386940 aTraitComposition assertValidUser: self. 386941 386942 oldComposition := self traitComposition. 386943 self traitComposition: aTraitComposition. 386944 self applyChangesOfNewTraitCompositionReplacing: oldComposition. 386945 386946 oldComposition traits do: [:each | each removeUser: self]. 386947 aTraitComposition traits do: [:each | each addUser: self]! ! 386948 386949!TPureBehavior methodsFor: 'traits' stamp: 'al 9/16/2005 14:30'! 386950traitComposition 386951 "Return my trait composition. Manipulating the composition does not 386952 effect changes automatically. Use #setTraitComposition: to do this but 386953 note, that you have to make a copy of the old trait composition before 386954 changing it because only the difference between the new and the old 386955 composition is updated." 386956 386957 ^self explicitRequirement ! ! 386958 386959!TPureBehavior methodsFor: 'traits' stamp: 'al 9/16/2005 14:31'! 386960traitCompositionIncludes: aTrait 386961 ^self == aTrait or: 386962 [self hasTraitComposition and: 386963 [self traitComposition allTraits includes: aTrait]]! ! 386964 386965!TPureBehavior methodsFor: 'traits' stamp: 'al 3/26/2006 21:29'! 386966traitCompositionString 386967 ^self hasTraitComposition 386968 ifTrue: [self traitComposition asString] 386969 ifFalse: ['{}']! ! 386970 386971!TPureBehavior methodsFor: 'traits' stamp: 'al 9/16/2005 14:53'! 386972traitComposition: aTraitComposition 386973 ^self explicitRequirement ! ! 386974 386975!TPureBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:55'! 386976traitOrClassOfSelector: aSymbol 386977 "Return the trait or the class which originally defines the method aSymbol 386978 or return self if locally defined or if it is a conflict marker method. 386979 This is primarly used by Debugger to determin the behavior in which a recompiled 386980 method should be put. If a conflict method is recompiled it should be put into 386981 the class, thus return self. Also see TraitComposition>>traitProvidingSelector:" 386982 386983 ((self includesLocalSelector: aSymbol) or: [ 386984 self hasTraitComposition not]) ifTrue: [^self]. 386985 ^(self traitComposition traitProvidingSelector: aSymbol) ifNil: [self]! ! 386986 386987!TPureBehavior methodsFor: 'traits' stamp: 'damiencassou 1/6/2009 10:58'! 386988traits 386989 "Returns a collection of all traits used by the receiver" 386990 ^ self traitComposition traits! ! 386991 386992!TPureBehavior methodsFor: 'traits' stamp: 'al 7/30/2004 21:55'! 386993traitsProvidingSelector: aSymbol 386994 | result | 386995 result := OrderedCollection new. 386996 self hasTraitComposition ifFalse: [^result]. 386997 (self traitComposition methodDescriptionsForSelector: aSymbol) 386998 do: [:methodDescription | methodDescription selector = aSymbol ifTrue: [ 386999 result addAll: (methodDescription locatedMethods 387000 collect: [:each | each location])]]. 387001 ^result! ! 387002 387003!TPureBehavior methodsFor: 'traits' stamp: 'al 9/16/2005 14:53'! 387004traitTransformations 387005 ^ self traitComposition transformations ! ! 387006 387007!TPureBehavior methodsFor: 'traits' stamp: 'al 10/13/2006 13:35'! 387008updateMethodDictionarySelector: aSymbol 387009 "A method with selector aSymbol in myself or my traitComposition has been changed. 387010 Do the appropriate update to my methodDict (remove or update method) and 387011 return all affected selectors of me so that my useres get notified." 387012 387013 | effectiveMethod modifiedSelectors descriptions selector | 387014 modifiedSelectors := IdentitySet new. 387015 descriptions := self hasTraitComposition 387016 ifTrue: [ self traitComposition methodDescriptionsForSelector: aSymbol ] 387017 ifFalse: [ #() ]. 387018 descriptions do: [:methodDescription | 387019 selector := methodDescription selector. 387020 (self includesLocalSelector: selector) ifFalse: [ 387021 methodDescription isEmpty 387022 ifTrue: [ 387023 self removeTraitSelector: selector. 387024 modifiedSelectors add: selector] 387025 ifFalse: [ 387026 effectiveMethod := methodDescription effectiveMethod. 387027 self addTraitSelector: selector withMethod: effectiveMethod. 387028 modifiedSelectors add: selector]]]. 387029 ^modifiedSelectors! ! 387030 387031 387032!TPureBehavior methodsFor: 'user interface' stamp: 'al 7/30/2004 22:38'! 387033crossReference 387034 "Answer an Array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included." 387035 387036 ^self selectors asSortedCollection asArray collect: [:x | Array 387037 with: (String with: Character cr), x 387038 with: (self whichSelectorsReferTo: x)] 387039 387040 "Point crossReference."! ! 387041 387042 387043!TPureBehavior methodsFor: 'private' stamp: 'stephane.ducasse 4/18/2009 11:39'! 387044spaceUsed 387045 "Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables." 387046 387047 | space | 387048 space := 0. 387049 self selectorsDo: [:sel | | method | 387050 space := space + 16. "dict and org'n space" 387051 method := self compiledMethodAt: sel. 387052 space := space + (method size + 6 "hdr + avg pad"). 387053 method literalsDo: [:lit | 387054 (lit isMemberOf: Array) ifTrue: [space := space + ((lit size + 1) * 4)]. 387055 (lit isMemberOf: Float) ifTrue: [space := space + 12]. 387056 (lit isMemberOf: ByteString) ifTrue: [space := space + (lit size + 6)]. 387057 (lit isMemberOf: LargeNegativeInteger) ifTrue: [space := space + ((lit size + 1) * 4)]. 387058 (lit isMemberOf: LargePositiveInteger) ifTrue: [space := space + ((lit size + 1) * 4)]]]. 387059 ^ space! ! 387060 387061"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 387062 387063TPureBehavior classTrait 387064 uses: {}! 387065Trait named: #TPutBasicTest 387066 uses: {} 387067 category: 'CollectionsTests-Abstract'! 387068 387069!TPutBasicTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:43'! 387070aValue 387071" return a value to put into nonEmpty" 387072 ^ self explicitRequirement! ! 387073 387074!TPutBasicTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:44'! 387075anIndex 387076" return an index in nonEmpty bounds" 387077 ^ self explicitRequirement! ! 387078 387079!TPutBasicTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:44'! 387080anotherValue 387081" return a value ( not eual to 'aValue' ) to put into nonEmpty " 387082 ^ self explicitRequirement! ! 387083 387084!TPutBasicTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 11:07'! 387085empty 387086 ^self explicitRequirement.! ! 387087 387088!TPutBasicTest methodsFor: 'requirements' stamp: 'stephane.ducasse 1/12/2009 16:56'! 387089nonEmpty 387090 387091 ^ self explicitRequirement! ! 387092 387093 387094!TPutBasicTest methodsFor: 'tests - at put' stamp: 'delaunay 3/27/2009 13:45'! 387095testAtPut 387096 "self debug: #testAtPut" 387097 387098 self nonEmpty at: self anIndex put: self aValue. 387099 self assert: (self nonEmpty at: self anIndex) = self aValue. 387100 ! ! 387101 387102!TPutBasicTest methodsFor: 'tests - at put' stamp: 'stephane.ducasse 1/12/2009 17:23'! 387103testAtPutOutOfBounds 387104 "self debug: #testAtPutOutOfBounds" 387105 387106 self should: [self empty at: self anIndex put: self aValue] raise: Error 387107 ! ! 387108 387109!TPutBasicTest methodsFor: 'tests - at put' stamp: 'stephane.ducasse 1/12/2009 17:17'! 387110testAtPutTwoValues 387111 "self debug: #testAtPutTwoValues" 387112 387113 self nonEmpty at: self anIndex put: self aValue. 387114 self nonEmpty at: self anIndex put: self anotherValue. 387115 self assert: (self nonEmpty at: self anIndex) = self anotherValue.! ! 387116 387117 387118!TPutBasicTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/28/2009 15:18'! 387119test0FixturePutTest 387120 self shouldnt: self aValue raise: Error. 387121 self shouldnt: self anotherValue raise: Error. 387122 387123 self shouldnt: self anIndex raise: Error. 387124 self nonEmpty isDictionary 387125 ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. 387126 387127 self shouldnt: self empty raise: Error. 387128 self assert: self empty isEmpty . 387129 387130 self shouldnt: self nonEmpty raise: Error. 387131 self deny: self nonEmpty isEmpty.! ! 387132 387133"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 387134 387135TPutBasicTest classTrait 387136 uses: {}! 387137Trait named: #TPutTest 387138 uses: {} 387139 category: 'CollectionsTests-Abstract'! 387140 387141!TPutTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:50'! 387142aValue 387143" return a value to put into nonEmpty" 387144 ^ self explicitRequirement! ! 387145 387146!TPutTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:51'! 387147indexArray 387148" return a Collection including indexes between bounds of 'nonEmpty' " 387149 387150 self explicitRequirement.! ! 387151 387152!TPutTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:51'! 387153nonEmpty 387154 387155 ^ self explicitRequirement! ! 387156 387157!TPutTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 11:06'! 387158valueArray 387159" return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty' at indexes in 'indexArray' " 387160 | result | 387161 result := Array new: self indexArray size. 387162 1 to: result size do: 387163 [:i | 387164 result at:i put: (self aValue ). 387165 ]. 387166 ^ result.! ! 387167 387168 387169!TPutTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/28/2009 10:53'! 387170test0FixturePutOneOrMoreElementsTest 387171 self shouldnt: self aValue raise: Error. 387172 387173 387174 self shouldnt: self indexArray raise: Error. 387175 self indexArray do: [ 387176 :each| 387177 self assert: each class = SmallInteger. 387178 self assert: (each>=1 & each<= self nonEmpty size). 387179 ]. 387180 387181 self assert: self indexArray size = self valueArray size. 387182 387183 self shouldnt: self empty raise: Error. 387184 self assert: self empty isEmpty . 387185 387186 self shouldnt: self nonEmpty raise: Error. 387187 self deny: self nonEmpty isEmpty.! ! 387188 387189 387190!TPutTest methodsFor: 'tests - puting with indexes' stamp: 'delaunay 4/28/2009 10:56'! 387191testAtAllIndexesPut 387192 387193 self nonEmpty atAllPut: self aValue. 387194 self nonEmpty do:[ :each| self assert: each = self aValue]. 387195 ! ! 387196 387197!TPutTest methodsFor: 'tests - puting with indexes' stamp: 'delaunay 4/28/2009 10:54'! 387198testAtAllPut 387199 | | 387200 self nonEmpty atAll: self indexArray put: self aValue.. 387201 387202 self indexArray do: 387203 [:i | self assert: (self nonEmpty at: i)=self aValue ]. 387204 ! ! 387205 387206!TPutTest methodsFor: 'tests - puting with indexes' stamp: 'delaunay 4/28/2009 10:54'! 387207testAtAllPutAll 387208 387209 | valueArray | 387210 valueArray := self valueArray . 387211 self nonEmpty atAll: self indexArray putAll: valueArray . 387212 387213 1 to: self indexArray size do: 387214 [:i | 387215 self assert: (self nonEmpty at:(self indexArray at: i))= (valueArray at:i) ]! ! 387216 387217!TPutTest methodsFor: 'tests - puting with indexes' stamp: 'delaunay 4/28/2009 11:23'! 387218testAtLastPut 387219 | result index | 387220 index := self indexArray anyOne. 387221 result := self nonEmpty atLast: index put: self aValue. 387222 387223 self assert: (self nonEmpty at: (self nonEmpty size +1 - index)) = self aValue .! ! 387224 387225!TPutTest methodsFor: 'tests - puting with indexes' stamp: 'delaunay 4/28/2009 11:00'! 387226testAtWrapPut 387227 "self debug: #testAtWrapPut" 387228 | index | 387229 index := self indexArray anyOne. 387230 387231 self nonEmpty atWrap: 0 put: self aValue. 387232 self assert: (self nonEmpty at:(self nonEmpty size))=self aValue. 387233 387234 self nonEmpty atWrap: (self nonEmpty size+1) put: self aValue. 387235 self assert: (self nonEmpty at:(1))=self aValue. 387236 387237 self nonEmpty atWrap: (index ) put: self aValue. 387238 self assert: (self nonEmpty at: index ) = self aValue. 387239 387240 self nonEmpty atWrap: (self nonEmpty size+index ) put: self aValue . 387241 self assert: (self nonEmpty at:(index ))=self aValue .! ! 387242 387243!TPutTest methodsFor: 'tests - puting with indexes' stamp: 'delaunay 4/28/2009 11:01'! 387244testFromToPut 387245 387246 | collection index | 387247 index := self indexArray anyOne. 387248 collection := self nonEmpty copy. 387249 collection from: 1 to: index put: self aValue.. 387250 1 to: index do: 387251 [:i | self assert: (collection at: i)= self aValue]. 387252 (index +1) to: collection size do: 387253 [:i | self assert: (collection at:i)= (self nonEmpty at:i)].! ! 387254 387255!TPutTest methodsFor: 'tests - puting with indexes' stamp: 'delaunay 4/28/2009 11:03'! 387256testSwapWith 387257 "self debug: #testSwapWith" 387258 | result index | 387259 index := self indexArray anyOne. 387260 result:= self nonEmpty copy . 387261 result swap: index with: 1. 387262 self assert: (result at: index) = (self nonEmpty at:1). 387263 self assert: (result at: 1) = (self nonEmpty at: index). 387264 ! ! 387265 387266"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 387267 387268TPutTest classTrait 387269 uses: {}! 387270Trait named: #TRemoveByIndexTest 387271 uses: {} 387272 category: 'CollectionsTests-Abstract'! 387273 387274!TRemoveByIndexTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 10:07'! 387275collectionWith5Elements 387276" return a collection of size 5 including 5 elements" 387277self explicitRequirement! ! 387278 387279!TRemoveByIndexTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 10:37'! 387280empty 387281" return an empty collection" 387282self explicitRequirement! ! 387283 387284 387285!TRemoveByIndexTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/22/2009 10:07'! 387286test0FixtureRemoveByIndexTest 387287 387288self shouldnt: [self collectionWith5Elements ] raise: Error. 387289self assert: self collectionWith5Elements size = 5.! ! 387290 387291 387292!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: 'delaunay 4/22/2009 10:24'! 387293testRemoveAt 387294 387295| collection element result oldSize | 387296collection := self collectionWith5Elements . 387297element := collection at: 3. 387298oldSize := collection size. 387299 387300result := collection removeAt: 3. 387301self assert: result = element . 387302self assert: collection size = (oldSize - 1).! ! 387303 387304!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: 'delaunay 4/22/2009 10:38'! 387305testRemoveAtNotPresent 387306 387307| | 387308self should: [self empty removeAt: 2] raise: Error.! ! 387309 387310!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: 'delaunay 4/22/2009 10:24'! 387311testRemoveFirst 387312 387313| collection element result oldSize | 387314collection := self collectionWith5Elements . 387315element := collection first. 387316oldSize := collection size. 387317 387318result := collection removeFirst. 387319self assert: result = element . 387320self assert: collection size = (oldSize - 1).! ! 387321 387322!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: 'delaunay 4/22/2009 10:24'! 387323testRemoveFirstNElements 387324 387325| collection elements result oldSize | 387326collection := self collectionWith5Elements . 387327elements := {collection first. collection at:2}. 387328oldSize := collection size. 387329 387330result := collection removeFirst: 2. 387331self assert: result = elements . 387332self assert: collection size = (oldSize - 2).! ! 387333 387334!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: 'delaunay 4/22/2009 10:40'! 387335testRemoveFirstNElementsNotPresent 387336 387337self should: [self empty removeFirst: 2] raise: Error.! ! 387338 387339!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: 'delaunay 4/22/2009 10:40'! 387340testRemoveFirstNotPresent 387341 387342self should: [self empty removeFirst] raise: Error.! ! 387343 387344!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: 'delaunay 4/22/2009 10:24'! 387345testRemoveLast 387346 387347| collection element result oldSize | 387348collection := self collectionWith5Elements . 387349element := collection last. 387350oldSize := collection size. 387351 387352result := collection removeLast. 387353self assert: result = element . 387354self assert: collection size = (oldSize - 1).! ! 387355 387356!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: 'delaunay 4/22/2009 10:37'! 387357testRemoveLastNElements 387358 387359| collection result oldSize elements | 387360collection := self collectionWith5Elements . 387361elements := { (collection at: (4)). collection last. }. 387362oldSize := collection size. 387363 387364 387365result := (collection removeLast: 2). 387366self assert: result = elements. 387367self assert: collection size = (oldSize - 2).! ! 387368 387369!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: 'delaunay 4/22/2009 10:41'! 387370testRemoveLastNElementsNElements 387371 387372self should: [self empty removeLast: 2] raise: Error.! ! 387373 387374!TRemoveByIndexTest methodsFor: 'tests - removing by index' stamp: 'delaunay 4/22/2009 10:40'! 387375testRemoveLastNotPresent 387376 387377self should: [self empty removeLast] raise: Error.! ! 387378 387379"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 387380 387381TRemoveByIndexTest classTrait 387382 uses: {}! 387383Trait named: #TRemoveForMultiplenessTest 387384 uses: TRemoveTest 387385 category: 'CollectionsTests-Abstract'! 387386 387387!TRemoveForMultiplenessTest methodsFor: 'requirements'! 387388elementNotIn 387389" return an element not included in nonEmptyWithoutEqualElements" 387390 self explicitRequirement! ! 387391 387392!TRemoveForMultiplenessTest methodsFor: 'requirements'! 387393empty 387394 self explicitRequirement! ! 387395 387396!TRemoveForMultiplenessTest methodsFor: 'requirements'! 387397nonEmptyWithoutEqualElements 387398" return a collection without equal elements " 387399 self explicitRequirement! ! 387400 387401 387402!TRemoveForMultiplenessTest methodsFor: 'test - remove' stamp: 'adrian_lienhard 2/21/2009 13:46'! 387403elementTwiceIn 387404 ^ self explicitRequirement! ! 387405 387406!TRemoveForMultiplenessTest methodsFor: 'test - remove' stamp: 'adrian_lienhard 2/21/2009 13:46'! 387407testRemoveElementThatExistsTwice 387408 "self debug: #testRemoveElementThatDoesExistsTwice" 387409 387410 | size | 387411 size := self nonEmpty size. 387412 self assert: (self nonEmpty includes: self elementTwiceIn). 387413 self nonEmpty remove: self elementTwiceIn. 387414 self assert: size - 1 = self nonEmpty size. 387415 387416 self assert: (self nonEmpty includes: self elementTwiceIn). 387417 self nonEmpty remove: self elementTwiceIn. 387418 self assert: size - 2 = self nonEmpty size! ! 387419 387420 387421!TRemoveForMultiplenessTest methodsFor: 'tests - fixture'! 387422test0FixtureTRemoveTest 387423 | duplicate | 387424 self shouldnt: [ self empty ]raise: Error. 387425 self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. 387426 self deny: self nonEmptyWithoutEqualElements isEmpty. 387427 duplicate := true. 387428 self nonEmptyWithoutEqualElements detect: 387429 [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] 387430 ifNone: [duplicate := false]. 387431 self assert: duplicate = false. 387432 387433 387434 self shouldnt: [ self elementNotIn ] raise: Error. 387435 self assert: self empty isEmpty. 387436 self deny: self nonEmptyWithoutEqualElements isEmpty. 387437 self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! 387438 387439 387440!TRemoveForMultiplenessTest methodsFor: 'tests - remove'! 387441testRemoveAll 387442 "self debug: #testRemoveElementThatExists" 387443 | el res subCollection collection | 387444 collection := self nonEmptyWithoutEqualElements. 387445 el := collection anyOne. 387446 subCollection := collection copyWithout: el. 387447 self 387448 shouldnt: [ res := collection removeAll: subCollection ] 387449 raise: Error. 387450 self assert: collection size = 1. 387451 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 387452 387453!TRemoveForMultiplenessTest methodsFor: 'tests - remove'! 387454testRemoveAllError 387455 "self debug: #testRemoveElementThatExists" 387456 | el res subCollection | 387457 el := self elementNotIn. 387458 subCollection := self nonEmptyWithoutEqualElements copyWith: el. 387459 self 387460 should: [ res := self nonEmptyWithoutEqualElements removeAll: subCollection ] 387461 raise: Error! ! 387462 387463!TRemoveForMultiplenessTest methodsFor: 'tests - remove'! 387464testRemoveAllFoundIn 387465 "self debug: #testRemoveElementThatExists" 387466 | el res subCollection | 387467 el := self nonEmptyWithoutEqualElements anyOne. 387468 subCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. 387469 self 387470 shouldnt: 387471 [ res := self nonEmptyWithoutEqualElements removeAllFoundIn: subCollection ] 387472 raise: Error. 387473 self assert: self nonEmptyWithoutEqualElements size = 1. 387474 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 387475 387476!TRemoveForMultiplenessTest methodsFor: 'tests - remove'! 387477testRemoveAllSuchThat 387478 "self debug: #testRemoveElementThatExists" 387479 | el subCollection | 387480 el := self nonEmptyWithoutEqualElements anyOne. 387481 subCollection := self nonEmptyWithoutEqualElements copyWithout: el. 387482 self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | subCollection includes: each ]. 387483 self assert: self nonEmptyWithoutEqualElements size = 1. 387484 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 387485 387486!TRemoveForMultiplenessTest methodsFor: 'tests - remove'! 387487testRemoveElementFromEmpty 387488 "self debug: #testRemoveElementFromEmpty" 387489 self 387490 should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] 387491 raise: Error! ! 387492 387493!TRemoveForMultiplenessTest methodsFor: 'tests - remove'! 387494testRemoveElementReallyRemovesElement 387495 "self debug: #testRemoveElementReallyRemovesElement" 387496 | size | 387497 size := self nonEmptyWithoutEqualElements size. 387498 self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. 387499 self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! 387500 387501!TRemoveForMultiplenessTest methodsFor: 'tests - remove'! 387502testRemoveElementThatExists 387503 "self debug: #testRemoveElementThatExists" 387504 | el res | 387505 el := self nonEmptyWithoutEqualElements anyOne. 387506 self 387507 shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] 387508 raise: Error. 387509 self assert: res == el! ! 387510 387511!TRemoveForMultiplenessTest methodsFor: 'tests - remove'! 387512testRemoveIfAbsent 387513 "self debug: #testRemoveElementThatExists" 387514 | el res | 387515 el := self elementNotIn. 387516 self 387517 shouldnt: 387518 [ res := self nonEmptyWithoutEqualElements 387519 remove: el 387520 ifAbsent: [ 33 ] ] 387521 raise: Error. 387522 self assert: res == 33! ! 387523 387524"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 387525 387526TRemoveForMultiplenessTest classTrait 387527 uses: TRemoveTest classTrait! 387528Trait named: #TRemoveTest 387529 uses: {} 387530 category: 'CollectionsTests-Abstract'! 387531 387532!TRemoveTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:53'! 387533elementNotIn 387534" return an element not included in nonEmptyWithoutEqualElements" 387535 self explicitRequirement! ! 387536 387537!TRemoveTest methodsFor: 'requirements' stamp: 'stephane.ducasse 11/29/2008 14:32'! 387538empty 387539 self explicitRequirement! ! 387540 387541!TRemoveTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:52'! 387542nonEmptyWithoutEqualElements 387543" return a collection without equal elements " 387544 self explicitRequirement! ! 387545 387546 387547!TRemoveTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/11/2009 10:57'! 387548test0FixtureTRemoveTest 387549 | duplicate | 387550 self shouldnt: [ self empty ]raise: Error. 387551 self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. 387552 self deny: self nonEmptyWithoutEqualElements isEmpty. 387553 duplicate := true. 387554 self nonEmptyWithoutEqualElements detect: 387555 [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] 387556 ifNone: [duplicate := false]. 387557 self assert: duplicate = false. 387558 387559 387560 self shouldnt: [ self elementNotIn ] raise: Error. 387561 self assert: self empty isEmpty. 387562 self deny: self nonEmptyWithoutEqualElements isEmpty. 387563 self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! 387564 387565 387566!TRemoveTest methodsFor: 'tests - remove' stamp: 'delaunay 5/11/2009 10:52'! 387567testRemoveAll 387568 "self debug: #testRemoveElementThatExists" 387569 | el res subCollection collection | 387570 collection := self nonEmptyWithoutEqualElements. 387571 el := collection anyOne. 387572 subCollection := collection copyWithout: el. 387573 self 387574 shouldnt: [ res := collection removeAll: subCollection ] 387575 raise: Error. 387576 self assert: collection size = 1. 387577 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 387578 387579!TRemoveTest methodsFor: 'tests - remove' stamp: 'delaunay 5/11/2009 10:52'! 387580testRemoveAllError 387581 "self debug: #testRemoveElementThatExists" 387582 | el res subCollection | 387583 el := self elementNotIn. 387584 subCollection := self nonEmptyWithoutEqualElements copyWith: el. 387585 self 387586 should: [ res := self nonEmptyWithoutEqualElements removeAll: subCollection ] 387587 raise: Error! ! 387588 387589!TRemoveTest methodsFor: 'tests - remove' stamp: 'delaunay 5/11/2009 10:52'! 387590testRemoveAllFoundIn 387591 "self debug: #testRemoveElementThatExists" 387592 | el res subCollection | 387593 el := self nonEmptyWithoutEqualElements anyOne. 387594 subCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. 387595 self 387596 shouldnt: 387597 [ res := self nonEmptyWithoutEqualElements removeAllFoundIn: subCollection ] 387598 raise: Error. 387599 self assert: self nonEmptyWithoutEqualElements size = 1. 387600 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 387601 387602!TRemoveTest methodsFor: 'tests - remove' stamp: 'delaunay 5/11/2009 10:52'! 387603testRemoveAllSuchThat 387604 "self debug: #testRemoveElementThatExists" 387605 | el subCollection | 387606 el := self nonEmptyWithoutEqualElements anyOne. 387607 subCollection := self nonEmptyWithoutEqualElements copyWithout: el. 387608 self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | subCollection includes: each ]. 387609 self assert: self nonEmptyWithoutEqualElements size = 1. 387610 self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! 387611 387612!TRemoveTest methodsFor: 'tests - remove' stamp: 'delaunay 5/11/2009 10:52'! 387613testRemoveElementFromEmpty 387614 "self debug: #testRemoveElementFromEmpty" 387615 self 387616 should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] 387617 raise: Error! ! 387618 387619!TRemoveTest methodsFor: 'tests - remove' stamp: 'delaunay 5/11/2009 10:52'! 387620testRemoveElementReallyRemovesElement 387621 "self debug: #testRemoveElementReallyRemovesElement" 387622 | size | 387623 size := self nonEmptyWithoutEqualElements size. 387624 self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. 387625 self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! 387626 387627!TRemoveTest methodsFor: 'tests - remove' stamp: 'delaunay 5/11/2009 10:52'! 387628testRemoveElementThatExists 387629 "self debug: #testRemoveElementThatExists" 387630 | el res | 387631 el := self nonEmptyWithoutEqualElements anyOne. 387632 self 387633 shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] 387634 raise: Error. 387635 self assert: res == el! ! 387636 387637!TRemoveTest methodsFor: 'tests - remove' stamp: 'delaunay 5/11/2009 10:52'! 387638testRemoveIfAbsent 387639 "self debug: #testRemoveElementThatExists" 387640 | el res | 387641 el := self elementNotIn. 387642 self 387643 shouldnt: 387644 [ res := self nonEmptyWithoutEqualElements 387645 remove: el 387646 ifAbsent: [ 33 ] ] 387647 raise: Error. 387648 self assert: res == 33! ! 387649 387650"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 387651 387652TRemoveTest classTrait 387653 uses: {}! 387654Trait named: #TReplacementSequencedTest 387655 uses: {} 387656 category: 'CollectionsTests-Abstract'! 387657 387658!TReplacementSequencedTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:35'! 387659elementInForReplacement 387660" return an element included in 'nonEmpty' " 387661^ self nonEmpty anyOne.! ! 387662 387663!TReplacementSequencedTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:38'! 387664firstIndex 387665" return an index between 'nonEmpty' bounds that is < to 'second index' " 387666 ^self explicitRequirement! ! 387667 387668!TReplacementSequencedTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:36'! 387669newElement 387670"return an element that will be put in the collection in place of another" 387671 self explicitRequirement! ! 387672 387673!TReplacementSequencedTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 09:49'! 387674nonEmpty 387675 ^self explicitRequirement! ! 387676 387677!TReplacementSequencedTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 16:19'! 387678replacementCollection 387679" return a collection that will be put into 'nonEmpty' " 387680 ^ self replacementCollectionSameSize, self replacementCollectionSameSize ! ! 387681 387682!TReplacementSequencedTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:39'! 387683replacementCollectionSameSize 387684" return a collection of size (secondIndex - firstIndex + 1)" 387685 ^self explicitRequirement! ! 387686 387687!TReplacementSequencedTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:27'! 387688secondIndex 387689" return an index between 'nonEmpty' bounds that is > to 'first index' " 387690 ^self explicitRequirement! ! 387691 387692 387693!TReplacementSequencedTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/6/2009 10:34'! 387694testOFixtureReplacementSequencedTest 387695 387696 self shouldnt: self nonEmpty raise: Error. 387697 self deny: self nonEmpty isEmpty. 387698 387699 self shouldnt: self elementInForReplacement raise: Error. 387700 self assert: (self nonEmpty includes: self elementInForReplacement ) . 387701 387702 self shouldnt: self newElement raise: Error. 387703 387704 self shouldnt: self firstIndex raise: Error. 387705 self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). 387706 387707 self shouldnt: self secondIndex raise: Error. 387708 self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). 387709 387710 self assert: self firstIndex <=self secondIndex . 387711 387712 self shouldnt: self replacementCollection raise: Error. 387713 387714 self shouldnt: self replacementCollectionSameSize raise: Error. 387715 self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size 387716 ! ! 387717 387718 387719!TReplacementSequencedTest methodsFor: 'tests - replacing' stamp: 'delaunay 5/12/2009 11:56'! 387720testReplaceAllWith 387721 | result collection oldElement newElement | 387722 collection := self nonEmpty . 387723 result := collection copy. 387724 oldElement := self elementInForReplacement . 387725 newElement := self newElement . 387726 result replaceAll: oldElement with: newElement . 387727 387728 1 to: collection size do: 387729 [: 387730 each | 387731 ( collection at: each ) = oldElement 387732 ifTrue: [ self assert: ( result at: each ) = newElement ]. 387733 ].! ! 387734 387735!TReplacementSequencedTest methodsFor: 'tests - replacing' stamp: 'delaunay 5/12/2009 12:05'! 387736testReplaceFromToWith 387737 | result collection replacementCollection firstIndex secondIndex | 387738 collection := self nonEmpty . 387739 replacementCollection := self replacementCollectionSameSize . 387740 firstIndex := self firstIndex . 387741 secondIndex := self secondIndex . 387742 result := collection copy. 387743 result replaceFrom: firstIndex to: secondIndex with: replacementCollection . 387744 387745 "verify content of 'result' : " 387746 "first part of 'result'' : '" 387747 387748 1 to: ( firstIndex - 1 ) do: [ :i | self assert: (collection at:i ) = ( result at: i ) ]. 387749 387750 " middle part containing replacementCollection : " 387751 387752 ( firstIndex ) to: ( firstIndex + replacementCollection size - 1 ) do: 387753 [ :i | 387754 self assert: ( result at: i ) = ( replacementCollection at: ( i - firstIndex +1 ) ) 387755 ]. 387756 387757 " end part :" 387758 ( firstIndex + replacementCollection size) to: (result size) do: 387759 [:i| 387760 self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ]. 387761 387762 ! ! 387763 387764!TReplacementSequencedTest methodsFor: 'tests - replacing' stamp: 'delaunay 5/12/2009 13:52'! 387765testReplaceFromToWithStartingAt 387766 | result repStart collection replacementCollection firstIndex secondIndex | 387767 collection := self nonEmpty . 387768 result := collection copy. 387769 replacementCollection := self replacementCollectionSameSize . 387770 firstIndex := self firstIndex . 387771 secondIndex := self secondIndex . 387772 repStart := replacementCollection size - ( secondIndex - firstIndex + 1 ) + 1. 387773 result replaceFrom: firstIndex to: secondIndex with: replacementCollection startingAt: repStart . 387774 387775 "verify content of 'result' : " 387776 "first part of 'result'' : '" 387777 387778 1 to: ( firstIndex - 1 ) do: [ :i | self assert: ( collection at:i ) = ( result at: i ) ]. 387779 387780 " middle part containing replacementCollection : " 387781 387782 ( firstIndex ) to: ( replacementCollection size - repStart +1 ) do: 387783 [:i| 387784 self assert: (result at: i)=( replacementCollection at: ( repStart + ( i -firstIndex ) ) ) ]. 387785 387786 " end part :" 387787 ( firstIndex + replacementCollection size ) to: ( result size ) do: 387788 [ :i | 387789 self assert: ( result at: i ) = ( collection at: ( secondIndex + 1 - ( firstIndex + replacementCollection size ) + i ) ) ].! ! 387790 387791"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 387792 387793TReplacementSequencedTest classTrait 387794 uses: {}! 387795Trait named: #TSequencedConcatenationTest 387796 uses: {} 387797 category: 'CollectionsTests-Abstract'! 387798 387799!TSequencedConcatenationTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 16:27'! 387800empty 387801 self explicitRequirement! ! 387802 387803!TSequencedConcatenationTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:11'! 387804firstCollection 387805" return a collection that will be the first part of the concatenation" 387806 self explicitRequirement! ! 387807 387808!TSequencedConcatenationTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:11'! 387809secondCollection 387810" return a collection that will be the second part of the concatenation" 387811 self explicitRequirement! ! 387812 387813 387814!TSequencedConcatenationTest methodsFor: 'tests - concatenation' stamp: 'delaunay 4/2/2009 16:42'! 387815testConcatenation 387816 | result index | 387817 result:= self firstCollection,self secondCollection . 387818 "first part : " 387819 index := 1. 387820 self firstCollection do: 387821 [:each | 387822 self assert: (self firstCollection at: index)=each. 387823 index := index+1.]. 387824 "second part : " 387825 1 to: self secondCollection size do: 387826 [:i | 387827 self assert: (self secondCollection at:i)= (result at:index). 387828 index:=index+1]. 387829 "size : " 387830 self assert: result size = (self firstCollection size + self secondCollection size).! ! 387831 387832!TSequencedConcatenationTest methodsFor: 'tests - concatenation' stamp: 'delaunay 4/2/2009 16:48'! 387833testConcatenationWithEmpty 387834 | result | 387835 result:= self empty,self secondCollection . 387836 387837 1 to: self secondCollection size do: 387838 [:i | 387839 self assert: (self secondCollection at:i)= (result at:i). 387840 ]. 387841 "size : " 387842 self assert: result size = ( self secondCollection size).! ! 387843 387844 387845!TSequencedConcatenationTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/14/2009 11:50'! 387846test0FixtureSequencedConcatenationTest 387847 self 387848 shouldnt: self empty 387849 raise: Exception. 387850 self assert: self empty isEmpty. 387851 self 387852 shouldnt: self firstCollection 387853 raise: Exception. 387854 self 387855 shouldnt: self secondCollection 387856 raise: Exception! ! 387857 387858"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 387859 387860TSequencedConcatenationTest classTrait 387861 uses: {}! 387862Trait named: #TSequencedElementAccessTest 387863 uses: {} 387864 category: 'CollectionsTests-Abstract'! 387865 387866!TSequencedElementAccessTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:40'! 387867elementInForElementAccessing 387868" return an element inculded in 'moreThan4Elements'" 387869 self explicitRequirement! ! 387870 387871!TSequencedElementAccessTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:40'! 387872elementNotInForElementAccessing 387873" return an element not included in 'moreThan4Elements' " 387874 self explicitRequirement! ! 387875 387876!TSequencedElementAccessTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:38'! 387877moreThan4Elements 387878 387879" return a collection including at leat 4 elements" 387880 self explicitRequirement! ! 387881 387882!TSequencedElementAccessTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:40'! 387883subCollectionNotIn 387884" return a collection for which at least one element is not included in 'moreThan4Elements' " 387885 self explicitRequirement! ! 387886 387887 387888!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:38'! 387889testAfter 387890 "self debug: #testAfter" 387891 self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). 387892 self 387893 should: 387894 [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] 387895 raise: Error. 387896 self 387897 should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] 387898 raise: Error! ! 387899 387900!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:38'! 387901testAfterIfAbsent 387902 "self debug: #testAfterIfAbsent" 387903 self assert: (self moreThan4Elements 387904 after: (self moreThan4Elements at: 1) 387905 ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). 387906 self assert: (self moreThan4Elements 387907 after: (self moreThan4Elements at: self moreThan4Elements size) 387908 ifAbsent: [ 33 ]) == 33. 387909 self assert: (self moreThan4Elements 387910 after: self elementNotInForElementAccessing 387911 ifAbsent: [ 33 ]) = 33! ! 387912 387913!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:38'! 387914testAt 387915 "self debug: #testAt" 387916 " 387917 self assert: (self accessCollection at: 1) = 1. 387918 self assert: (self accessCollection at: 2) = 2. 387919 " 387920 | index | 387921 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 387922 self assert: (self moreThan4Elements at: index) = self elementInForElementAccessing! ! 387923 387924!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:37'! 387925testAtAll 387926 "self debug: #testAtAll" 387927 " self flag: #theCollectionshouldbe102030intheFixture. 387928 387929 self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. 387930 self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." 387931 | result | 387932 result := self moreThan4Elements atAll: #(2 1 2 ). 387933 self assert: (result at: 1) = (self moreThan4Elements at: 2). 387934 self assert: (result at: 2) = (self moreThan4Elements at: 1). 387935 self assert: (result at: 3) = (self moreThan4Elements at: 2). 387936 self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! 387937 387938!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:37'! 387939testAtIfAbsent 387940 "self debug: #testAt" 387941 | absent | 387942 absent := false. 387943 self moreThan4Elements 387944 at: self moreThan4Elements size + 1 387945 ifAbsent: [ absent := true ]. 387946 self assert: absent = true. 387947 absent := false. 387948 self moreThan4Elements 387949 at: self moreThan4Elements size 387950 ifAbsent: [ absent := true ]. 387951 self assert: absent = false! ! 387952 387953!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:37'! 387954testAtLast 387955 "self debug: #testAtLast" 387956 | index | 387957 self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. 387958 "tmp:=1. 387959 self do: 387960 [:each | 387961 each =self elementInForIndexAccessing 387962 ifTrue:[index:=tmp]. 387963 tmp:=tmp+1]." 387964 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 387965 self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! 387966 387967!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:37'! 387968testAtLastError 387969 "self debug: #testAtLast" 387970 self 387971 should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] 387972 raise: Error! ! 387973 387974!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:37'! 387975testAtLastIfAbsent 387976 "self debug: #testAtLastIfAbsent" 387977 self assert: (self moreThan4Elements 387978 atLast: 1 387979 ifAbsent: [ nil ]) = self moreThan4Elements last. 387980 self assert: (self moreThan4Elements 387981 atLast: self moreThan4Elements size + 1 387982 ifAbsent: [ 222 ]) = 222! ! 387983 387984!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:38'! 387985testAtOutOfBounds 387986 "self debug: #testAtOutOfBounds" 387987 self 387988 should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] 387989 raise: Error. 387990 self 387991 should: [ self moreThan4Elements at: -1 ] 387992 raise: Error! ! 387993 387994!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:38'! 387995testAtPin 387996 "self debug: #testAtPin" 387997 self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. 387998 self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. 387999 self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! 388000 388001!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/14/2009 13:46'! 388002testAtRandom 388003 | result | 388004 result := self nonEmpty atRandom . 388005 self assert: (self nonEmpty includes: result).! ! 388006 388007!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:38'! 388008testAtWrap 388009 "self debug: #testAt" 388010 " 388011 self assert: (self accessCollection at: 1) = 1. 388012 self assert: (self accessCollection at: 2) = 2. 388013 " 388014 | index | 388015 index := self moreThan4Elements indexOf: self elementInForElementAccessing. 388016 self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. 388017 self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. 388018 self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. 388019 self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! 388020 388021!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:38'! 388022testBefore 388023 "self debug: #testBefore" 388024 self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). 388025 self 388026 should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] 388027 raise: Error. 388028 self 388029 should: [ self moreThan4Elements before: 66 ] 388030 raise: Error! ! 388031 388032!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:37'! 388033testBeforeIfAbsent 388034 "self debug: #testBefore" 388035 self assert: (self moreThan4Elements 388036 before: (self moreThan4Elements at: 1) 388037 ifAbsent: [ 99 ]) = 99. 388038 self assert: (self moreThan4Elements 388039 before: (self moreThan4Elements at: 2) 388040 ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! 388041 388042!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:37'! 388043testFirstSecondThird 388044 "self debug: #testFirstSecondThird" 388045 self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). 388046 self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). 388047 self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). 388048 self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! 388049 388050!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:38'! 388051testLast 388052 "self debug: #testLast" 388053 self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! 388054 388055!TSequencedElementAccessTest methodsFor: 'tests - element accessing' stamp: 'delaunay 4/27/2009 10:38'! 388056testMiddle 388057 "self debug: #testMiddle" 388058 self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! 388059 388060 388061!TSequencedElementAccessTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/27/2009 10:38'! 388062test0FixtureSequencedElementAccessTest 388063 self 388064 shouldnt: [ self moreThan4Elements ] 388065 raise: Error. 388066 self assert: self moreThan4Elements size >= 4. 388067 self 388068 shouldnt: [ self subCollectionNotIn ] 388069 raise: Error. 388070 self subCollectionNotIn 388071 detect: [ :each | (self moreThan4Elements includes: each) not ] 388072 ifNone: [ self assert: false ]. 388073 self 388074 shouldnt: [ self elementNotInForElementAccessing ] 388075 raise: Error. 388076 self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). 388077 self 388078 shouldnt: [ self elementInForElementAccessing ] 388079 raise: Error. 388080 self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! 388081 388082"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 388083 388084TSequencedElementAccessTest classTrait 388085 uses: {}! 388086Trait named: #TSequencedStructuralEqualityTest 388087 uses: TStructuralEqualityTest 388088 category: 'CollectionsTests-Abstract'! 388089 388090!TSequencedStructuralEqualityTest methodsFor: 'test - equality'! 388091empty 388092 388093 ^ self explicitRequirement! ! 388094 388095!TSequencedStructuralEqualityTest methodsFor: 'test - equality'! 388096nonEmpty 388097 388098 ^ self explicitRequirement! ! 388099 388100!TSequencedStructuralEqualityTest methodsFor: 'test - equality'! 388101testEqualSign 388102 "self debug: #testEqualSign" 388103 388104 self deny: (self empty = self nonEmpty).! ! 388105 388106!TSequencedStructuralEqualityTest methodsFor: 'test - equality'! 388107testEqualSignIsTrueForNonIdenticalButEqualCollections 388108 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 388109 388110 self assert: (self empty = self empty copy). 388111 self assert: (self empty copy = self empty). 388112 self assert: (self empty copy = self empty copy). 388113 388114 self assert: (self nonEmpty = self nonEmpty copy). 388115 self assert: (self nonEmpty copy = self nonEmpty). 388116 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 388117 388118!TSequencedStructuralEqualityTest methodsFor: 'test - equality'! 388119testEqualSignOfIdenticalCollectionObjects 388120 "self debug: #testEqualSignOfIdenticalCollectionObjects" 388121 388122 self assert: (self empty = self empty). 388123 self assert: (self nonEmpty = self nonEmpty). 388124 ! ! 388125 388126 388127!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: 'damiencassou 1/20/2009 14:01'! 388128testEqualSignForSequenceableCollections 388129 "self debug: #testEqualSign" 388130 388131 self deny: (self nonEmpty = self nonEmpty asSet). 388132 self deny: (self nonEmpty reversed = self nonEmpty). 388133 self deny: (self nonEmpty = self nonEmpty reversed).! ! 388134 388135!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: 'damiencassou 1/20/2009 13:56'! 388136testHasEqualElements 388137 "self debug: #testHasEqualElements" 388138 388139 self deny: (self empty hasEqualElements: self nonEmpty). 388140 self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). 388141 self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). 388142 self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! 388143 388144!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: 'damiencassou 1/20/2009 13:56'! 388145testHasEqualElementsIsTrueForNonIdenticalButEqualCollections 388146 "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" 388147 388148 self assert: (self empty hasEqualElements: self empty copy). 388149 self assert: (self empty copy hasEqualElements: self empty). 388150 self assert: (self empty copy hasEqualElements: self empty copy). 388151 388152 self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). 388153 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). 388154 self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! 388155 388156!TSequencedStructuralEqualityTest methodsFor: 'tests - equality' stamp: 'damiencassou 1/20/2009 13:56'! 388157testHasEqualElementsOfIdenticalCollectionObjects 388158 "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" 388159 388160 self assert: (self empty hasEqualElements: self empty). 388161 self assert: (self nonEmpty hasEqualElements: self nonEmpty). 388162 ! ! 388163 388164 388165!TSequencedStructuralEqualityTest methodsFor: 'tests - fixture' stamp: 'damiencassou 1/20/2009 13:59'! 388166test0TSequencedStructuralEqualityTest 388167 388168 self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! 388169 388170!TSequencedStructuralEqualityTest methodsFor: 'tests - fixture'! 388171test0TStructuralEqualityTest 388172 self shouldnt: [self empty] raise: Error. 388173 self shouldnt: [self nonEmpty] raise: Error. 388174 self assert: self empty isEmpty. 388175 self deny: self nonEmpty isEmpty.! ! 388176 388177"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 388178 388179TSequencedStructuralEqualityTest classTrait 388180 uses: TStructuralEqualityTest classTrait! 388181Trait named: #TSetArithmetic 388182 uses: {} 388183 category: 'CollectionsTests-Abstract'! 388184 388185!TSetArithmetic methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 11:52'! 388186anotherElementOrAssociationIn 388187 " return an element (or an association for Dictionary ) present in 'collection' " 388188 ^ self explicitRequirement! ! 388189 388190!TSetArithmetic methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 11:54'! 388191anotherElementOrAssociationNotIn 388192 " return an element (or an association for Dictionary )not present in 'collection' " 388193 ^ self explicitRequirement! ! 388194 388195!TSetArithmetic methodsFor: 'requirements' stamp: 'AlexandreBergel 1/19/2009 18:28'! 388196collection 388197 388198 ^ self explicitRequirement! ! 388199 388200!TSetArithmetic methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 16:25'! 388201collectionClass 388202" return the class to be used to create instances of the class tested" 388203 ^ self explicitRequirement! ! 388204 388205!TSetArithmetic methodsFor: 'requirements' stamp: 'AlexandreBergel 1/19/2009 18:28'! 388206nonEmpty 388207 388208 ^ self explicitRequirement! ! 388209 388210 388211!TSetArithmetic methodsFor: 'tests - fixture' stamp: 'delaunay 5/4/2009 14:00'! 388212test0FixtureSetAritmeticTest 388213 self 388214 shouldnt: [ self collection ] 388215 raise: Error. 388216 self deny: self collection isEmpty. 388217 self 388218 shouldnt: [ self nonEmpty ] 388219 raise: Error. 388220 self deny: self nonEmpty isEmpty. 388221 self 388222 shouldnt: [ self anotherElementOrAssociationNotIn ] 388223 raise: Error. 388224 self collection isDictionary 388225 ifTrue: 388226 [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] 388227 ifFalse: 388228 [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. 388229 self 388230 shouldnt: [ self collectionClass ] 388231 raise: Error! ! 388232 388233 388234!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: 'stephane.ducasse 11/21/2008 17:17'! 388235containsAll: union of: one andOf: another 388236 388237 self assert: (one allSatisfy: [:each | union includes: each]). 388238 self assert: (another allSatisfy: [:each | union includes: each])! ! 388239 388240!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: 'delaunay 4/29/2009 11:52'! 388241numberOfSimilarElementsInIntersection 388242 ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! 388243 388244!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: 'stephane.ducasse 12/20/2008 23:04'! 388245testDifference 388246 "Answer the set theoretic difference of two collections." 388247 "self debug: #testDifference" 388248 388249 self assert: (self collection difference: self collection) isEmpty. 388250 self assert: (self empty difference: self collection) isEmpty. 388251 self assert: (self collection difference: self empty) = self collection 388252! ! 388253 388254!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: 'delaunay 4/29/2009 11:54'! 388255testDifferenceWithNonNullIntersection 388256 "Answer the set theoretic difference of two collections." 388257 "self debug: #testDifferenceWithNonNullIntersection" 388258 " #(1 2 3) difference: #(2 4) 388259 -> #(1 3)" 388260 | res overlapping | 388261 overlapping := self collectionClass 388262 with: self anotherElementOrAssociationNotIn 388263 with: self anotherElementOrAssociationIn. 388264 res := self collection difference: overlapping. 388265 self deny: (res includes: self anotherElementOrAssociationIn). 388266 overlapping do: [ :each | self deny: (res includes: each) ]! ! 388267 388268!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: 'delaunay 4/29/2009 11:54'! 388269testDifferenceWithSeparateCollection 388270 "Answer the set theoretic difference of two collections." 388271 "self debug: #testDifferenceWithSeparateCollection" 388272 | res separateCol | 388273 separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. 388274 res := self collection difference: separateCol. 388275 self deny: (res includes: self anotherElementOrAssociationNotIn). 388276 self assert: res = self collection. 388277 res := separateCol difference: self collection. 388278 self deny: (res includes: self collection anyOne). 388279 self assert: res = separateCol! ! 388280 388281!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: 'delaunay 4/29/2009 11:59'! 388282testIntersectionBasic 388283 "self debug: #testIntersectionBasic" 388284 | inter | 388285 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 388286 self deny: inter isEmpty. 388287 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 388288 388289!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: 'delaunay 4/29/2009 11:44'! 388290testIntersectionEmpty 388291 "self debug: #testIntersectionEmpty" 388292 388293 | inter | 388294 inter := self empty intersection: self empty. 388295 self assert: inter isEmpty. 388296 inter := self empty intersection: self collection . 388297 self assert: inter = self empty. 388298 ! ! 388299 388300!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: 'stephane.ducasse 12/20/2008 21:43'! 388301testIntersectionItself 388302 "self debug: #testIntersectionItself" 388303 388304 self assert: (self collection intersection: self collection) = self collection. 388305 ! ! 388306 388307!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: 'delaunay 4/29/2009 11:59'! 388308testIntersectionTwoSimilarElementsInIntersection 388309 "self debug: #testIntersectionBasic" 388310 | inter | 388311 inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). 388312 self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. 388313 self assert: (inter includes: self anotherElementOrAssociationIn value)! ! 388314 388315!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: 'stephane.ducasse 11/21/2008 17:26'! 388316testUnion 388317 "self debug: #testUnionOfEmpties" 388318 388319 | union | 388320 union := self empty union: self nonEmpty. 388321 self containsAll: union of: self empty andOf: self nonEmpty. 388322 union := self nonEmpty union: self empty. 388323 self containsAll: union of: self empty andOf: self nonEmpty. 388324 union := self collection union: self nonEmpty. 388325 self containsAll: union of: self collection andOf: self nonEmpty.! ! 388326 388327!TSetArithmetic methodsFor: 'tests - set arithmetic' stamp: 'stephane.ducasse 11/21/2008 17:09'! 388328testUnionOfEmpties 388329 "self debug: #testUnionOfEmpties" 388330 388331 self assert: (self empty union: self empty) isEmpty. 388332 388333 ! ! 388334 388335"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 388336 388337TSetArithmetic classTrait 388338 uses: {}! 388339Trait named: #TSizeTest 388340 uses: {} 388341 category: 'CollectionsTests-Abstract'! 388342 388343!TSizeTest methodsFor: 'requirements' stamp: 'AlexandreBergel 1/19/2009 18:28'! 388344empty 388345 388346 ^ self explicitRequirement! ! 388347 388348!TSizeTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:50'! 388349sizeCollection 388350 "Answers a collection not empty" 388351 ^ self explicitRequirement! ! 388352 388353 388354!TSizeTest methodsFor: 'tests - fixture' stamp: 'damiencassou 1/20/2009 14:04'! 388355test0TSizeTest 388356 self shouldnt: [self empty] raise: Error. 388357 self shouldnt: [self sizeCollection] raise: Error. 388358 self assert: self empty isEmpty. 388359 self deny: self sizeCollection isEmpty.! ! 388360 388361 388362!TSizeTest methodsFor: 'tests - size capacity' stamp: 'delaunay 5/14/2009 10:51'! 388363testSize 388364 388365 | size | 388366 self assert: self empty size = 0. 388367 size := 0. 388368 self sizeCollection do: [ :each | size := size + 1]. 388369 388370 self assert: self sizeCollection size = size.! ! 388371 388372"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 388373 388374TSizeTest classTrait 388375 uses: {}! 388376Trait named: #TSortTest 388377 uses: {} 388378 category: 'CollectionsTests-Abstract'! 388379 388380!TSortTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:51'! 388381sortedInAscendingOrderCollection 388382" return a collection sorted in an acsending order" 388383 ^self explicitRequirement 388384 ! ! 388385 388386!TSortTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 16:51'! 388387unsortedCollection 388388" retur a collection that is not yat sorted" 388389 ^self explicitRequirement! ! 388390 388391 388392!TSortTest methodsFor: 'tests - fixture' stamp: 'delaunay 5/12/2009 10:09'! 388393test0SortingArrayedTest 388394 | tmp sorted | 388395 " an unsorted collection of number " 388396 self shouldnt: [ self unsortedCollection ]raise: Error. 388397 self unsortedCollection do:[:each | each isNumber]. 388398 sorted := true. 388399 self unsortedCollection pairsDo: [ 388400 :each1 :each2 | 388401 each2 < each1 ifTrue: [ sorted := false]. 388402 ]. 388403 self assert: sorted = false. 388404 388405 388406 388407 " a collection of number sorted in an ascending order" 388408 self shouldnt: [ self sortedInAscendingOrderCollection ]raise: Error. 388409 self sortedInAscendingOrderCollection do:[:each | each isNumber]. 388410 tmp:= self sortedInAscendingOrderCollection at:1. 388411 self sortedInAscendingOrderCollection do: 388412 [: each | self assert: (each>= tmp). tmp:=each] 388413 ! ! 388414 388415 388416!TSortTest methodsFor: 'tests - sorting' stamp: 'delaunay 3/27/2009 14:40'! 388417testIsSorted 388418 self assert: [ self sortedInAscendingOrderCollection isSorted ]. 388419 self deny: [ self unsortedCollection isSorted ]! ! 388420 388421!TSortTest methodsFor: 'tests - sorting' stamp: 'delaunay 3/27/2009 14:43'! 388422testIsSortedBy 388423 self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a<b]). 388424 self deny: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | a>b]). 388425! ! 388426 388427!TSortTest methodsFor: 'tests - sorting' stamp: 'delaunay 3/27/2009 15:22'! 388428testSort 388429 | result tmp | 388430 result := self unsortedCollection sort. 388431 tmp := result at: 1. 388432 result do: 388433 [:each | self assert: each>=tmp. tmp:= each. ].! ! 388434 388435!TSortTest methodsFor: 'tests - sorting' stamp: 'delaunay 3/27/2009 15:22'! 388436testSortUsingSortBlock 388437 | result tmp | 388438 result := self unsortedCollection sort: [:a :b | a>b]. 388439 tmp := result at: 1. 388440 result do: 388441 [:each | self assert: each<=tmp. tmp:= each. ].! ! 388442 388443"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 388444 388445TSortTest classTrait 388446 uses: {}! 388447Trait named: #TStructuralEqualityTest 388448 uses: {} 388449 category: 'CollectionsTests-Abstract'! 388450!TStructuralEqualityTest commentStamp: 'stephane.ducasse 1/16/2009 19:08' prior: 0! 388451Tests whether two objects are equals: they contain the same objects in the same order.! 388452 388453 388454!TStructuralEqualityTest methodsFor: 'test - equality' stamp: 'stephane.ducasse 1/19/2009 16:27'! 388455empty 388456 388457 ^ self explicitRequirement! ! 388458 388459!TStructuralEqualityTest methodsFor: 'test - equality' stamp: 'stephane.ducasse 1/19/2009 16:27'! 388460nonEmpty 388461 388462 ^ self explicitRequirement! ! 388463 388464!TStructuralEqualityTest methodsFor: 'test - equality' stamp: 'damiencassou 1/20/2009 14:02'! 388465testEqualSign 388466 "self debug: #testEqualSign" 388467 388468 self deny: (self empty = self nonEmpty).! ! 388469 388470!TStructuralEqualityTest methodsFor: 'test - equality' stamp: 'stephane.ducasse 1/16/2009 19:25'! 388471testEqualSignIsTrueForNonIdenticalButEqualCollections 388472 "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" 388473 388474 self assert: (self empty = self empty copy). 388475 self assert: (self empty copy = self empty). 388476 self assert: (self empty copy = self empty copy). 388477 388478 self assert: (self nonEmpty = self nonEmpty copy). 388479 self assert: (self nonEmpty copy = self nonEmpty). 388480 self assert: (self nonEmpty copy = self nonEmpty copy).! ! 388481 388482!TStructuralEqualityTest methodsFor: 'test - equality' stamp: 'stephane.ducasse 1/16/2009 19:25'! 388483testEqualSignOfIdenticalCollectionObjects 388484 "self debug: #testEqualSignOfIdenticalCollectionObjects" 388485 388486 self assert: (self empty = self empty). 388487 self assert: (self nonEmpty = self nonEmpty). 388488 ! ! 388489 388490 388491!TStructuralEqualityTest methodsFor: 'tests - fixture' stamp: 'damiencassou 1/20/2009 13:57'! 388492test0TStructuralEqualityTest 388493 self shouldnt: [self empty] raise: Error. 388494 self shouldnt: [self nonEmpty] raise: Error. 388495 self assert: self empty isEmpty. 388496 self deny: self nonEmpty isEmpty.! ! 388497 388498"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 388499 388500TStructuralEqualityTest classTrait 388501 uses: {}! 388502Trait named: #TSubCollectionAccess 388503 uses: {} 388504 category: 'CollectionsTests-Abstract'! 388505 388506!TSubCollectionAccess methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:48'! 388507moreThan3Elements 388508 " return a collection including atLeast 3 elements" 388509 self explicitRequirement! ! 388510 388511 388512!TSubCollectionAccess methodsFor: 'tests - fixture' stamp: 'delaunay 4/27/2009 10:48'! 388513test0FixtureSubcollectionAccessTest 388514 self 388515 shouldnt: [ self moreThan3Elements ] 388516 raise: Error. 388517 self assert: self moreThan3Elements size > 2! ! 388518 388519 388520!TSubCollectionAccess methodsFor: 'tests - subcollections access' stamp: 'delaunay 4/27/2009 10:48'! 388521testAllButFirst 388522 "self debug: #testAllButFirst" 388523 | abf col | 388524 col := self moreThan3Elements. 388525 abf := col allButFirst. 388526 self deny: abf first = col first. 388527 self assert: abf size + 1 = col size! ! 388528 388529!TSubCollectionAccess methodsFor: 'tests - subcollections access' stamp: 'delaunay 4/27/2009 10:48'! 388530testAllButFirstNElements 388531 "self debug: #testAllButFirst" 388532 | abf col | 388533 col := self moreThan3Elements. 388534 abf := col allButFirst: 2. 388535 1 388536 to: abf size 388537 do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. 388538 self assert: abf size + 2 = col size! ! 388539 388540!TSubCollectionAccess methodsFor: 'tests - subcollections access' stamp: 'delaunay 4/27/2009 10:48'! 388541testAllButLast 388542 "self debug: #testAllButLast" 388543 | abf col | 388544 col := self moreThan3Elements. 388545 abf := col allButLast. 388546 self deny: abf last = col last. 388547 self assert: abf size + 1 = col size! ! 388548 388549!TSubCollectionAccess methodsFor: 'tests - subcollections access' stamp: 'delaunay 4/27/2009 10:48'! 388550testAllButLastNElements 388551 "self debug: #testAllButFirst" 388552 | abf col | 388553 col := self moreThan3Elements. 388554 abf := col allButLast: 2. 388555 1 388556 to: abf size 388557 do: [ :i | self assert: (abf at: i) = (col at: i) ]. 388558 self assert: abf size + 2 = col size! ! 388559 388560!TSubCollectionAccess methodsFor: 'tests - subcollections access' stamp: 'delaunay 4/27/2009 10:48'! 388561testFirstNElements 388562 "self debug: #testFirstNElements" 388563 | result | 388564 result := self moreThan3Elements first: self moreThan3Elements size - 1. 388565 1 388566 to: result size 388567 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. 388568 self assert: result size = (self moreThan3Elements size - 1). 388569 self 388570 should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] 388571 raise: Error! ! 388572 388573!TSubCollectionAccess methodsFor: 'tests - subcollections access' stamp: 'delaunay 4/27/2009 10:48'! 388574testLastNElements 388575 "self debug: #testLastNElements" 388576 | result | 388577 result := self moreThan3Elements last: self moreThan3Elements size - 1. 388578 1 388579 to: result size 388580 do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. 388581 self assert: result size = (self moreThan3Elements size - 1). 388582 self 388583 should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] 388584 raise: Error! ! 388585 388586"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 388587 388588TSubCollectionAccess classTrait 388589 uses: {}! 388590AbstractFont subclass: #TTCFont 388591 instanceVariableNames: 'ttcDescription pointSize foregroundColor cache derivatives fallbackFont height ascent descent colorToCacheMap' 388592 classVariableNames: 'GlyphCacheData GlyphCacheIndex GlyphCacheReady GlyphCacheSize NamesToIndexes Registry Scale ShutdownList' 388593 poolDictionaries: '' 388594 category: 'Multilingual-Display'! 388595!TTCFont commentStamp: 'nk 4/2/2004 11:32' prior: 0! 388596I represent a font that uses TrueType derived glyph. Upon a request for glyph for a character through a call to #formOf: (or #widthOf:), I first search corresponding glyph in the cache. If there is not, it creates a 32bit depth form with the glyph. 388597 388598 The cache is weakly held. The entries are zapped at full GC. 388599 388600Structure: 388601 ttcDescription TTFontDescription -- The Squeak data structure for a TrueType font data file. 388602 pointSize Number -- Nominal Em size in points. Conversion to pixel sizes depends on the definition of TextStyle class>>pixelsPerInch. 388603 foregroundColor Color -- So far, this font need to know the glyph color in cache. 388604 cache WeakArray of <Color -> <Array(256) of glyph>> 388605 derivatives Array -- stores the fonts in the same family but different emphasis. 388606! 388607 388608 388609!TTCFont methodsFor: '*FreeType-addition' stamp: 'tween 4/23/2006 22:52'! 388610derivativeFont: aNewlyCreatedDerivativeFont mainFont: aMainFont 388611 388612 self derivativeFont: aNewlyCreatedDerivativeFont at: aMainFont emphasis. 388613 aNewlyCreatedDerivativeFont emphasis: aMainFont emphasis. 388614 aNewlyCreatedDerivativeFont lineGlyph: (aMainFont ttcDescription at: $_).! ! 388615 388616!TTCFont methodsFor: '*FreeType-addition' stamp: 'tween 4/23/2006 21:45'! 388617initialize: aFont 388618 388619 self initialize. 388620 self ttcDescription: aFont ttcDescription. 388621! ! 388622 388623!TTCFont methodsFor: '*FreeType-addition' stamp: 'tween 4/23/2006 22:54'! 388624lineGlyph: ignore 388625 ^self! ! 388626 388627 388628!TTCFont methodsFor: 'accessing' stamp: 'ar 11/14/2006 15:35'! 388629ascent 388630 ascent ifNil:[ascent := ttcDescription ascender * self pixelSize // (ttcDescription ascender - ttcDescription descender) * Scale y]. 388631 ^ (fallbackFont notNil 388632 and: [fallbackFont ascent > ascent]) 388633 ifTrue: [fallbackFont ascent] 388634 ifFalse: [ascent]! ! 388635 388636!TTCFont methodsFor: 'accessing' stamp: 'ar 11/14/2006 15:43'! 388637descent 388638 "One is added to make sure the gap between lines is filled. If we don't add, multi line selection in a text pane look ugly." 388639 ^descent ifNil:[descent := (ttcDescription descender * self pixelSize // (ttcDescription descender - ttcDescription ascender)) * Scale y + 1]. 388640! ! 388641 388642!TTCFont methodsFor: 'accessing' stamp: 'yo 11/30/2002 22:39'! 388643descentKern 388644 388645 ^ 0. 388646! ! 388647 388648!TTCFont methodsFor: 'accessing' stamp: 'yo 5/6/2004 19:25'! 388649emphasis 388650 "Answer the emphasis code (0 to 3) corresponding to my subfamily name" 388651 ^self indexOfSubfamilyName: self subfamilyName 388652 388653! ! 388654 388655!TTCFont methodsFor: 'accessing' stamp: 'nk 5/26/2003 20:13'! 388656emphasis: code 388657 388658 code > 3 ifTrue: [^ self]. 388659 code = 0 ifTrue: [^ self]. 388660 derivatives isNil ifTrue: [^ self]. 388661 ^ (derivatives at: code) ifNil: [self]. 388662! ! 388663 388664!TTCFont methodsFor: 'accessing' stamp: 'yo 8/1/2005 12:14'! 388665emphasized: code 388666 388667 code = 0 ifTrue: [^ self]. 388668 derivatives ifNil: [^ self]. 388669 (((code bitAnd: 20) ~= 0) and: [ 388670 derivatives size < code or: [(derivatives at: code) isNil]]) ifTrue: [ 388671 self addLined. 388672 ]. 388673 ^ (derivatives at: code) ifNil: [self]. 388674! ! 388675 388676!TTCFont methodsFor: 'accessing' stamp: 'sd 2/4/2008 21:20'! 388677fallbackFont 388678 ^ fallbackFont 388679 ifNil: [fallbackFont := FixedFaceFont new errorFont fontSize: self height]! ! 388680 388681!TTCFont methodsFor: 'accessing' stamp: 'sd 2/4/2008 21:20'! 388682fallbackFont: aFontSetOrNil 388683 388684 fallbackFont := aFontSetOrNil. 388685! ! 388686 388687!TTCFont methodsFor: 'accessing' stamp: 'yo 12/10/2002 17:08'! 388688familyName 388689 388690 ^ ttcDescription name. 388691! ! 388692 388693!TTCFont methodsFor: 'accessing' stamp: 'yo 11/30/2002 22:39'! 388694familySizeFace 388695 388696 ^ Array 388697 with: self familyName 388698 with: self height 388699 with: 0. 388700! ! 388701 388702!TTCFont methodsFor: 'accessing' stamp: 'dgd 8/17/2004 22:10'! 388703fontNameWithPointSize 388704 ^ self name withoutTrailingDigits , ' ' , self pointSize printString! ! 388705 388706!TTCFont methodsFor: 'accessing' stamp: 'ar 11/14/2006 15:44'! 388707height 388708 "Answer my height in pixels. This will answer a Float." 388709 ^height ifNil:[height := self pixelSize * Scale y]! ! 388710 388711!TTCFont methodsFor: 'accessing' stamp: 'dgd 12/11/2003 12:47'! 388712lineGrid 388713 "Answer the relative space between lines" 388714 ^ self ascent + self descent! ! 388715 388716!TTCFont methodsFor: 'accessing' stamp: 'yo 11/16/2002 01:00'! 388717maxAscii 388718 388719 ^ ttcDescription size. 388720! ! 388721 388722!TTCFont methodsFor: 'accessing' stamp: 'yo 11/16/2002 01:00'! 388723minAscii 388724 388725 ^ 0. 388726! ! 388727 388728!TTCFont methodsFor: 'accessing' stamp: 'yo 11/16/2002 01:00'! 388729name 388730 388731 ^ ttcDescription name. 388732! ! 388733 388734!TTCFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:27'! 388735pixelSize 388736 "Make sure that we don't return a Fraction" 388737 ^ TextStyle pointsToPixels: pointSize! ! 388738 388739!TTCFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:27'! 388740pixelSize: aNumber 388741 "Make sure that we don't return a Fraction" 388742 self pointSize: (TextStyle pixelsToPoints: aNumber) rounded. 388743! ! 388744 388745!TTCFont methodsFor: 'accessing' stamp: 'yo 6/23/2003 18:39'! 388746pointSize 388747 388748 ^ pointSize. 388749! ! 388750 388751!TTCFont methodsFor: 'accessing' stamp: 'nk 7/18/2004 15:32'! 388752pointSize: aNumber 388753 388754 self privatePointSize: aNumber. 388755 derivatives ifNotNil: [ derivatives do: [ :f | f ifNotNil: [ f privatePointSize: aNumber ]]]. 388756! ! 388757 388758!TTCFont methodsFor: 'accessing' stamp: 'nk 7/18/2004 15:31'! 388759privatePointSize: aNumber 388760 pointSize = aNumber 388761 ifFalse: [pointSize := aNumber. 388762 self flushCache]! ! 388763 388764!TTCFont methodsFor: 'accessing' stamp: 'nk 6/17/2003 14:26'! 388765textStyle 388766 ^ TextStyle actualTextStyles detect: 388767 [:aStyle | aStyle fontArray includes: self] ifNone: [nil]! ! 388768 388769 388770!TTCFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 388771setupDefaultFallbackFont 388772 388773 | fonts f | 388774 fonts := TextStyle default fontArray. 388775 f := fonts first. 388776 1 to: fonts size do: [:i | 388777 self height > (fonts at: i) height ifTrue: [f := fonts at: i]. 388778 ]. 388779 self fallbackFont: f. 388780 self reset. 388781 388782! ! 388783 388784 388785!TTCFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:52'! 388786releaseCachedState 388787 self flushCache.! ! 388788 388789!TTCFont methodsFor: 'caching' stamp: 'yo 6/30/2004 14:49'! 388790reset 388791! ! 388792 388793 388794!TTCFont methodsFor: 'character shapes' stamp: 'nk 11/3/2004 10:02'! 388795characterFormAt: character 388796 "Answer a Form copied out of the glyphs for the argument, 388797 character. Use a cached copy if possible." 388798 388799 ^self formOf: character! ! 388800 388801 388802!TTCFont methodsFor: 'copying' stamp: 'yo 12/10/2002 16:35'! 388803copy 388804 388805 ^ self. 388806! ! 388807 388808!TTCFont methodsFor: 'copying' stamp: 'yo 12/10/2002 16:35'! 388809deepCopy 388810 388811 ^ self. 388812! ! 388813 388814!TTCFont methodsFor: 'copying' stamp: 'yo 12/10/2002 16:36'! 388815veryDeepCopyWith: deepCopier 388816 388817 self flushCache. 388818 ^ self. 388819! ! 388820 388821 388822!TTCFont methodsFor: 'friend' stamp: 'ar 11/14/2006 15:19'! 388823cache 388824 ^cache! ! 388825 388826!TTCFont methodsFor: 'friend' stamp: 'sd 2/4/2008 21:20'! 388827derivativeFont: aTTCFont 388828 388829 | index | 388830 index := self indexOfSubfamilyName: (aTTCFont subfamilyName). 388831 index < 1 ifTrue: [ 388832 ^ self "inform: 'unknown sub family name. This font will be skipped'". 388833 ]. 388834 388835 self derivativeFont: aTTCFont at: index. 388836 388837 self addLined: aTTCFont. 388838! ! 388839 388840!TTCFont methodsFor: 'friend' stamp: 'sd 2/4/2008 21:20'! 388841derivativeFont: aTTCFont at: index 388842 388843 | newDeriv | 388844 aTTCFont ifNil: [derivatives := nil. ^ self]. 388845 derivatives ifNil: [derivatives := Array new: 32]. 388846 derivatives size < 32 ifTrue: [ 388847 newDeriv := Array new: 32. 388848 newDeriv replaceFrom: 1 to: derivatives size with: derivatives. 388849 derivatives := newDeriv. 388850 ]. 388851 derivatives at: index put: aTTCFont. 388852! ! 388853 388854!TTCFont methodsFor: 'friend' stamp: 'yo 5/6/2004 19:54'! 388855derivativeFontArray 388856 388857 ^ derivatives. 388858! ! 388859 388860!TTCFont methodsFor: 'friend' stamp: 'nk 9/1/2004 13:01'! 388861derivativeFonts 388862 388863 derivatives ifNil: [^ #()]. 388864 ^derivatives copyWithout: nil! ! 388865 388866!TTCFont methodsFor: 'friend' stamp: 'yo 1/7/2005 12:04'! 388867displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 388868 388869 ^ self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent. 388870! ! 388871 388872!TTCFont methodsFor: 'friend' stamp: 'ar 11/14/2006 15:40'! 388873displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY 388874 388875 | form glyphInfo destX destY hereX nextX actualFont | 388876 destX := aPoint x. 388877 glyphInfo := Array new: 5. 388878 startIndex to: stopIndex do: [:charIndex | 388879 self glyphInfoOf: (aString at: charIndex) into: glyphInfo. 388880 form := glyphInfo at: 1. 388881 hereX := glyphInfo at: 2. 388882 nextX := glyphInfo at: 3. 388883 (actualFont := glyphInfo at: 5) == aBitBlt lastFont 388884 ifFalse: [actualFont installOn: aBitBlt]. 388885 destY := baselineY - (glyphInfo at: 4). 388886 aBitBlt sourceForm: form. 388887 aBitBlt destX: destX. 388888 aBitBlt destY: destY. 388889 aBitBlt sourceX: hereX; sourceY: 0. 388890 aBitBlt width: nextX - hereX. 388891 aBitBlt height: form height. 388892 aBitBlt copyBits. 388893 destX := destX + (nextX - hereX) + kernDelta. 388894 ]. 388895 ^ destX @ destY 388896! ! 388897 388898!TTCFont methodsFor: 'friend' stamp: 'alain.plantec 5/28/2009 11:09'! 388899initialize 388900 388901 super initialize. 388902 foregroundColor := Color black. 388903! ! 388904 388905!TTCFont methodsFor: 'friend' stamp: 'yo 1/6/2005 21:59'! 388906installOn: aDisplayContext 388907 388908 ^aDisplayContext installTTCFont: self. 388909! ! 388910 388911!TTCFont methodsFor: 'friend' stamp: 'ar 11/14/2006 15:26'! 388912installOn: aDisplayContext foregroundColor: fgColor backgroundColor: bgColor 388913 self foregroundColor: fgColor. "install color" 388914 aDisplayContext installTTCFont: self foregroundColor: foregroundColor backgroundColor: bgColor 388915! ! 388916 388917!TTCFont methodsFor: 'friend' stamp: 'sd 2/4/2008 21:20'! 388918setupDefaultFallbackFontTo: aTextStyleOrNil 388919" 388920 TTCFont allInstances do: [:i | i setupDefaultFallbackFontTo: (TextStyle named: 'MultiMSMincho')]. 388921" 388922 388923 | fonts f | 388924 aTextStyleOrNil ifNil: [ 388925 self fallbackFont: nil. 388926 ^ self. 388927 ]. 388928 fonts := aTextStyleOrNil fontArray. 388929 (aTextStyleOrNil defaultFont familyName endsWith: self familyName) ifTrue: [fallbackFont := nil. ^ self]. 388930 388931 f := fonts first. 388932 1 to: fonts size do: [:i | 388933 self height >= (fonts at: i) height ifTrue: [f := fonts at: i]. 388934 ]. 388935 self fallbackFont: f. 388936 self reset. 388937 388938! ! 388939 388940!TTCFont methodsFor: 'friend' stamp: 'yo 11/16/2002 01:01'! 388941ttcDescription 388942 388943 ^ ttcDescription. 388944! ! 388945 388946!TTCFont methodsFor: 'friend' stamp: 'ar 11/14/2006 15:19'! 388947ttcDescription: aTTCDescription 388948 388949 ttcDescription := aTTCDescription. 388950 self flushCache. 388951! ! 388952 388953 388954!TTCFont methodsFor: 'initialize' stamp: 'ar 11/14/2006 15:17'! 388955flushCache 388956 "Flush the cache of this font" 388957 cache := foregroundColor := colorToCacheMap := nil.! ! 388958 388959!TTCFont methodsFor: 'initialize' stamp: 'ar 11/14/2006 15:27'! 388960foregroundColor: fgColor 388961 "Install the given foreground color" 388962 foregroundColor = fgColor ifFalse:[ 388963 foregroundColor := fgColor. 388964 colorToCacheMap ifNil:[colorToCacheMap := Dictionary new]. 388965 cache := colorToCacheMap at: fgColor ifAbsentPut:[WeakArray new: 256]. 388966 ShutdownList ifNotNil:[ShutdownList add: self]. 388967 ]. 388968! ! 388969 388970 388971!TTCFont methodsFor: 'objects from disk' stamp: 'sd 2/4/2008 21:20'! 388972objectForDataStream: refStrm 388973 | dp | 388974 "I am about to be written on an object file. Write a 388975reference to a known FontSet in the other system instead." 388976 388977 "a path to me" 388978 dp := DiskProxy global: #TTCFont selector: #familyName:pointSize:emphasis: 388979 args: {self familyName. self pointSize. self emphasis}. 388980 refStrm replace: self with: dp. 388981 ^ dp. 388982! ! 388983 388984 388985!TTCFont methodsFor: 'printing' stamp: 'yo 5/6/2004 19:25'! 388986printOn: aStream 388987 aStream nextPutAll: 'TTCFont('; 388988 nextPutAll: self familyName; space; 388989 print: self pointSize; space; 388990 nextPutAll: self subfamilyName; 388991 nextPut: $)! ! 388992 388993 388994!TTCFont methodsFor: 'public' stamp: 'yo 12/10/2002 16:35'! 388995depth 388996 388997 ^ 32. 388998! ! 388999 389000!TTCFont methodsFor: 'public' stamp: 'yo 11/16/2002 00:59'! 389001foregroundColor 389002 389003 ^ foregroundColor. 389004! ! 389005 389006!TTCFont methodsFor: 'public' stamp: 'yo 12/10/2002 16:36'! 389007size 389008 389009 ^ ttcDescription size. 389010! ! 389011 389012!TTCFont methodsFor: 'public' stamp: 'ar 11/14/2006 15:23'! 389013widthOf: aCharacter 389014 "This method cannot use #formOf: because formOf: discriminates the color and causes unnecessary bitmap creation." 389015 aCharacter charCode > 255 ifTrue: [ 389016 fallbackFont ifNotNil: [^ fallbackFont widthOf: aCharacter]. 389017 ^ 1 389018 ]. 389019 ^(self formOf: aCharacter) width! ! 389020 389021 389022!TTCFont methodsFor: 'testing' stamp: 'yo 5/6/2004 19:25'! 389023isRegular 389024 "Answer true if I am a Regular/Roman font (i.e. not bold, etc.)" 389025 ^ (self indexOfSubfamilyName: (self subfamilyName)) = 0. 389026! ! 389027 389028!TTCFont methodsFor: 'testing' stamp: 'nk 6/25/2003 12:55'! 389029isTTCFont 389030 ^true! ! 389031 389032 389033!TTCFont methodsFor: 'private' stamp: 'yo 5/7/2004 12:30'! 389034addLined 389035 389036 self addLined: self. 389037 self derivativeFonts do: [:e | 389038 e ifNotNil: [self addLined: e]. 389039 ]. 389040! ! 389041 389042!TTCFont methodsFor: 'private' stamp: 'sd 2/4/2008 21:20'! 389043addLined: aTTCFont 389044 389045 | l | 389046 l := LinedTTCFont fromTTCFont: aTTCFont emphasis: 4. 389047 self derivativeFont: l at: l emphasis. 389048 389049 l := LinedTTCFont fromTTCFont: aTTCFont emphasis: 16. 389050 self derivativeFont: l at: l emphasis. 389051 389052 l := LinedTTCFont fromTTCFont: aTTCFont emphasis: 20. 389053 self derivativeFont: l at: l emphasis. 389054! ! 389055 389056!TTCFont methodsFor: 'private' stamp: 'ar 11/14/2006 15:19'! 389057at: char put: form 389058 | assoc | 389059 assoc := foregroundColor -> form. 389060 GlyphCacheData at: (GlyphCacheIndex := GlyphCacheIndex \\ GlyphCacheSize + 1) put: assoc. 389061 cache at: (char asInteger + 1) put: assoc.! ! 389062 389063!TTCFont methodsFor: 'private' stamp: 'sd 2/4/2008 21:20'! 389064computeForm: char 389065 389066 | ttGlyph scale | 389067 scale := self pixelSize asFloat / (ttcDescription ascender - ttcDescription descender). 389068 Scale ifNotNil: [scale := Scale * scale]. 389069 ttGlyph := ttcDescription at: (char isCharacter ifTrue: [char charCode] ifFalse: [char]). 389070 ^ ttGlyph asFormWithScale: scale ascender: ttcDescription ascender descender: ttcDescription descender fgColor: foregroundColor bgColor: Color transparent depth: self depth. 389071! ! 389072 389073!TTCFont methodsFor: 'private' stamp: 'ar 11/14/2006 16:03'! 389074formOf: char 389075 389076 | code form | 389077 char charCode > 255 389078 ifTrue: [^ self fallbackFont formOf: char]. 389079 389080 cache ifNil:[self foregroundColor: Color black]. "make sure we have a cache" 389081 389082 code := char charCode. 389083 form := cache at: (code + 1). 389084 form class == Association ifTrue:[^self computeForm: code]. "in midst of loading" 389085 form ifNil:[ 389086 form := self computeForm: code. 389087 cache at: code+1 put: form. 389088 GlyphCacheData at: (GlyphCacheIndex := GlyphCacheIndex \\ GlyphCacheSize + 1) put: form. 389089 ]. 389090 ^form 389091! ! 389092 389093!TTCFont methodsFor: 'private' stamp: 'ar 11/14/2006 15:43'! 389094glyphInfoOf: aCharacter into: glyphInfoArray 389095 "Answer the width of the argument as a character in the receiver." 389096 389097 | form | 389098 (self hasGlyphOf: aCharacter) ifFalse: [ 389099 ^ self fallbackFont glyphInfoOf: aCharacter into: glyphInfoArray. 389100 ]. 389101 form := self formOf: aCharacter. 389102 glyphInfoArray at: 1 put: form; 389103 at: 2 put: 0; 389104 at: 3 put: form width; 389105 at: 4 put: ascent "(self ascentOf: aCharacter)"; 389106 at: 5 put: self. 389107 ^ glyphInfoArray. 389108! ! 389109 389110!TTCFont methodsFor: 'private' stamp: 'yo 1/6/2005 04:43'! 389111hasGlyphOf: aCharacter 389112 389113 ^ aCharacter charCode <= 255 389114! ! 389115 389116!TTCFont methodsFor: 'private' stamp: 'nk 3/25/2004 17:01'! 389117indexOfSubfamilyName: aName 389118 | decoded | 389119 389120 "decodeStyleName will consume all the modifiers and leave nothing if everything was recognized." 389121 decoded := TextStyle decodeStyleName: aName. 389122 decoded second isEmpty ifTrue: [ ^decoded first ]. 389123 389124 "If you get a halt here - please add the missing synonym to the lookup table in TextStyle>>decodeStyleName: ." 389125 389126 self error: 'please add the missing synonym ', aName, ' to the lookup table in TextStyle>>decodeStyleName:'. 389127 389128 ^0.! ! 389129 389130!TTCFont methodsFor: 'private' stamp: 'nk 4/1/2004 09:15'! 389131scale 389132 389133 ^ self pixelSize / ttcDescription unitsPerEm 389134! ! 389135 389136!TTCFont methodsFor: 'private' stamp: 'yo 5/6/2004 19:23'! 389137subfamilyName 389138 389139 ^ ttcDescription subfamilyName. 389140! ! 389141 389142"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 389143 389144TTCFont class 389145 instanceVariableNames: ''! 389146 389147!TTCFont class methodsFor: 'file list services' stamp: 'nk 7/16/2003 15:40'! 389148fileReaderServicesForFile: fullName suffix: suffix 389149 ^(suffix = 'ttf') | (suffix = '*') 389150 ifTrue: [ self services ] 389151 ifFalse: [ #() ]! ! 389152 389153!TTCFont class methodsFor: 'file list services'! 389154serviceInstallTrueTypeFontStyle 389155 "Return a service to install a true type font as a text style" 389156 389157 ^ SimpleServiceEntry 389158 provider: self 389159 label: 'install ttf style' 389160 selector: #newTextStyleFromTTFile: 389161 description: 'install a true type font as a text style' 389162 buttonLabel: 'install ttf'! ! 389163 389164!TTCFont class methodsFor: 'file list services'! 389165services 389166 "Return a set of services for use in FileList" 389167 389168 ^ Array with: self serviceInstallTrueTypeFontStyle! ! 389169 389170 389171!TTCFont class methodsFor: 'initialization' stamp: 'ar 11/14/2006 15:48'! 389172initialize 389173" 389174 self initialize 389175" 389176 389177 | tt | 389178 self allSubInstancesDo:[:fnt| fnt flushCache]. 389179 GlyphCacheSize := 512. 389180 GlyphCacheData := Array new: GlyphCacheSize. 389181 GlyphCacheIndex := 0. 389182 GlyphCacheReady := true. 389183 389184 tt := TTFontDescription default. 389185 tt ifNotNil: [self newTextStyleFromTT: tt]. 389186 389187 (FileList respondsTo: #registerFileReader:) ifTrue: [ 389188 FileList registerFileReader: self 389189 ]. 389190 389191 Smalltalk addToShutDownList: self.! ! 389192 389193!TTCFont class methodsFor: 'initialization' stamp: 'ar 11/14/2006 15:28'! 389194shutDown 389195 "Flush the glyph cache" 389196 GlyphCacheData atAllPut: nil. 389197 GlyphCacheIndex := 0. 389198 ShutdownList ifNotNil:[ShutdownList do:[:fnt| fnt flushCache]]. 389199 ShutdownList := WeakSet new. 389200! ! 389201 389202!TTCFont class methodsFor: 'initialization' stamp: 'nk 6/25/2003 13:14'! 389203unload 389204 389205 (FileList respondsTo: #unregisterFileReader:) ifTrue: [ 389206 FileList unregisterFileReader: self 389207 ]! ! 389208 389209 389210!TTCFont class methodsFor: 'instance creation' stamp: 'sd 2/4/2008 21:20'! 389211familyName: n pointSize: s emphasis: code 389212 389213 "(TTCFont familyName: 'BitstreamVeraSans' pointSize: 12 emphasis: 0)" 389214 | t ret index | 389215 t := self registry at: n asSymbol ifAbsent: [#()]. 389216 t isEmpty ifTrue: [ 389217 t := (TextConstants at: #DefaultTextStyle) fontArray. 389218 ret := t first. 389219 ret pointSize >= s ifTrue: [^ ret emphasis: code]. 389220 index := 2. 389221 [index <= t size and: [(t at: index) pointSize <= s]] whileTrue: [ 389222 ret := t at: index. 389223 index := index + 1. 389224 ]. 389225 ^ ret emphasis: code. 389226 ]. 389227 ^ ((TextStyle named: n) addNewFontSize: s) emphasis: code. 389228! ! 389229 389230!TTCFont class methodsFor: 'instance creation' stamp: 'yo 6/23/2003 18:44'! 389231family: f size: s 389232 389233 ^ self allInstances detect: [:a | a familyName = f and: [a pointSize = s]] ifNone: [nil]. 389234! ! 389235 389236!TTCFont class methodsFor: 'instance creation' stamp: 'sd 2/4/2008 21:20'! 389237getExistings: fontArray 389238 389239 | result em | 389240 result := OrderedCollection new. 389241 result add: fontArray. 389242 1 to: 3 do: [:i | 389243 em := (fontArray collect: [:f | f emphasized: i]). 389244 (em at: 1) ~= (fontArray at: 1) ifTrue: [ 389245 result add: em. 389246 ]. 389247 ]. 389248 ^ result asArray. 389249! ! 389250 389251!TTCFont class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:51'! 389252newTextStyleFromTT: description 389253 "Create a new TextStyle from specified TTFontDescription instance." 389254 389255 | array f | 389256 array := self pointSizes collect: 389257 [:pt | 389258 f := self new. 389259 f ttcDescription: description. 389260 f pointSize: pt]. 389261 ^self reorganizeForNewFontArray: array name: array first name asSymbol! ! 389262 389263!TTCFont class methodsFor: 'instance creation' stamp: 'sd 2/4/2008 21:20'! 389264newTextStyleFromTTFile: fileName 389265 "Create a new TextStyle from specified file name. On certain versions of Windows, you can evaluate following to get Arial font into the image. On other platforms, wait and see someone implements the support code for FontPlugin then we can start relying on the generic font lookup mechanism. 389266 TTCFontReader encodingTag: 0. 389267 self newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\symbol.TTF'. 389268 " 389269 389270 | description | 389271 description := TTFontDescription addFromTTFile: fileName. 389272 ^ self newTextStyleFromTT: description. 389273! ! 389274 389275!TTCFont class methodsFor: 'instance creation' stamp: 'sd 2/4/2008 21:20'! 389276newTextStyleFromTTStream: readStream 389277" 389278" 389279 389280 | description | 389281 description := TTFontDescription addFromTTStream: readStream. 389282 ^ self newTextStyleFromTT: description. 389283! ! 389284 389285!TTCFont class methodsFor: 'instance creation' stamp: 'sd 2/4/2008 21:20'! 389286reorganizeForNewFontArray: array name: styleName 389287 389288 | style existings regular altName | 389289 (TextConstants includesKey: styleName) ifFalse: [ 389290 TextConstants at: styleName put: (TextStyle fontArray: array). 389291 ^ TextConstants at: styleName. 389292 ]. 389293 389294 "There is a text style with the name I want to use. See if it is a TTC font..." 389295 style := TextConstants at: styleName. 389296 style isTTCStyle ifFalse: [ 389297 altName := ((array at: 1) name, 'TT') asSymbol. 389298 ^ self reorganizeForNewFontArray: array name: altName. 389299 ]. 389300 389301 existings := (self getExistings: style fontArray), (Array with: array). 389302 regular := existings detect: [:e | (e at: 1) isRegular] ifNone: [existings at: 1]. 389303 389304 regular do: [:r | 389305 r addLined: r. 389306 ]. 389307 389308 "The existing array may be different in size than the new one." 389309 existings do: [:e | 389310 (e at: 1) isRegular ifFalse: [ 389311 regular do: [ :r | | f | 389312 f := e detect: [ :ea | ea pointSize = r pointSize ] ifNone: [ ]. 389313 f ifNotNil: [ r derivativeFont: f ]. 389314 ]. 389315 ]. 389316 ]. 389317 389318 style newFontArray: regular. 389319 self register: regular at: styleName. 389320 self recreateCache. 389321 ^ style. 389322! ! 389323 389324 389325!TTCFont class methodsFor: 'objects from disk' stamp: 'nk 6/25/2003 13:42'! 389326classVersion 389327 "Version 0 had pixelSize; version 1 changed it to pointSize" 389328 ^1! ! 389329 389330 389331!TTCFont class methodsFor: 'other' stamp: 'yo 6/23/2003 19:46'! 389332isCacheAllNil 389333" 389334 self cacheAllNil 389335" 389336 self allInstances do: [:inst | 389337 inst cache do: [:e | 389338 e ifNotNil: [^ false]. 389339 ]. 389340 ]. 389341 389342 ^ true. 389343! ! 389344 389345!TTCFont class methodsFor: 'other' stamp: 'yo 6/23/2003 20:18'! 389346pointSizes 389347 389348 "The default sizes that are created when a TextStyle is created. You can add new sizes by the new-size feature." 389349 ^ #(9 12 15 24 36). 389350! ! 389351 389352!TTCFont class methodsFor: 'other' stamp: 'ar 11/14/2006 15:19'! 389353recreateCache 389354" 389355 self recreateCache. 389356" 389357 self allSubInstances do: [:inst | inst flushCache]. 389358 Smalltalk garbageCollect. 389359! ! 389360 389361!TTCFont class methodsFor: 'other' stamp: 'yo 3/17/2005 11:11'! 389362registerAll 389363" 389364 TTCFont registerAll 389365" 389366 389367 TextStyle allInstancesDo: [:e | 389368 (e fontArray first isMemberOf: TTCFont) ifTrue: [ 389369 self register: e fontArray at: e fontArray first familyName asSymbol. 389370 ]. 389371 ]. 389372! ! 389373 389374!TTCFont class methodsFor: 'other' stamp: 'yo 3/17/2005 10:52'! 389375register: anObject at: symbolName 389376 389377 self registry at: symbolName put: anObject. 389378! ! 389379 389380!TTCFont class methodsFor: 'other' stamp: 'NorbertHartl 6/13/2008 11:45'! 389381registry 389382 389383 ^ Registry isNil 389384 ifTrue: [Registry := IdentityDictionary new] 389385 ifFalse: [Registry]. 389386! ! 389387 389388!TTCFont class methodsFor: 'other' stamp: 'yo 5/7/2004 08:09'! 389389removeAllDerivatives 389390" 389391 self removeAllDerivatives 389392" 389393 389394 self allInstances do: [:s | 389395 s textStyle ifNotNil: [ 389396 s textStyle fontArray do: [:f | 389397 f derivativeFont: nil at: 0. 389398 ]. 389399 ]. 389400 ]. 389401! ! 389402 389403!TTCFont class methodsFor: 'other' stamp: 'yo 11/30/2002 22:37'! 389404removeStyleName: aString 389405 389406 TextConstants removeKey: aString asSymbol ifAbsent: []. 389407 TTFontDescription removeDescriptionNamed: aString asString. 389408! ! 389409 389410!TTCFont class methodsFor: 'other' stamp: 'sd 2/4/2008 21:20'! 389411repairBadSizes 389412 "There was a bug that would cause the TTCFonts to generate incorrectly sized glyphs. 389413 By looking at the dimensions of cached forms, 389414 we can tell whether the incorrect height logic was used. 389415 If it was, change the point size of the font and its derivatives. 389416 389417 Note that this is probably pointless to call after the new code has been loaded; it's here for documentation (it should be called from the CS preamble instead)." 389418 389419 "TTCFont repairBadSizes" 389420 | description computedScale cached desiredScale newPointSize repaired | 389421 repaired := OrderedCollection new. 389422 TTCFont allInstancesDo: [ :font | 389423 cached := (font cache copyFrom: $A asciiValue + 1 to: $z asciiValue + 1) 389424 detect: [ :f | f notNil ] ifNone: []. 389425 cached := cached ifNil: [ font formOf: $A ] ifNotNil: [ cached value ]. 389426 description := font ttcDescription. 389427 desiredScale := cached height asFloat / (description ascender - description descender). 389428 computedScale := font pixelSize asFloat / font ttcDescription unitsPerEm. 389429 (((computedScale / desiredScale) - 1.0 * cached height) abs < 1.0) ifFalse: [ 389430 newPointSize := (font pointSize * desiredScale / computedScale) rounded. 389431 font pointSize: newPointSize; flushCache. 389432 repaired add: font. 389433 font derivativeFonts do: [ :df | df ifNotNil: [ 389434 df pointSize: newPointSize; flushCache. 389435 repaired add: df. ]]. 389436 ]. 389437 ]. 389438 repaired isEmpty ifFalse: [ repaired asArray inspect ]. 389439! ! 389440 389441!TTCFont class methodsFor: 'other' stamp: 'sd 2/4/2008 21:20'! 389442scale: anObject 389443 389444 Scale := anObject. 389445! ! 389446 389447!TTCFont class methodsFor: 'other' stamp: 'yo 3/17/2005 10:53'! 389448unregister: symbolName 389449 389450 self registry removeKey: symbolName ifAbsent: []. 389451! ! 389452 389453!TTCFont class methodsFor: 'other' stamp: 'yo 6/23/2003 19:50'! 389454version 389455 389456 ^ '6.0'. 389457! ! 389458TTFontDescription subclass: #TTCFontDescription 389459 instanceVariableNames: '' 389460 classVariableNames: 'TTCDefault TTCDescriptions' 389461 poolDictionaries: '' 389462 category: 'Multilingual-Display'! 389463 389464!TTCFontDescription methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389465at: aCharOrInteger 389466 389467 | char | 389468 char := aCharOrInteger asCharacter. 389469 ^ glyphs at: (char charCode) + 1. 389470! ! 389471 389472!TTCFontDescription methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389473objectForDataStream: refStrm 389474 | dp | 389475 "I am about to be written on an object file. Write a reference to a known Font in the other system instead. " 389476 389477 "A path to me" 389478 (TextConstants at: #forceFontWriting ifAbsent: [false]) ifTrue: [^ self]. 389479 "special case for saving the default fonts on the disk. See collectionFromFileNamed:" 389480 389481 dp := DiskProxy global: #TTCFontDescription selector: #descriptionNamed:at: 389482 args: {self name. ((TTCFontDescription descriptionNamed: self name) indexOf: self)}. 389483 refStrm replace: self with: dp. 389484 ^ dp. 389485! ! 389486 389487"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 389488 389489TTCFontDescription class 389490 instanceVariableNames: ''! 389491 389492!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389493addFromTTFile: fileName 389494" 389495 Execute the following only if you know what you are doing. 389496 self addFromTTFile: 'C:\WINDOWS\Fonts\msgothic.TTC' 389497" 389498 389499 | tt old | 389500 (fileName asLowercase endsWith: 'ttf') ifTrue: [ 389501 tt := TTCFontReader readTTFFrom: (FileStream readOnlyFileNamed: fileName). 389502 ] ifFalse: [ 389503 tt := TTCFontReader readFrom: (FileStream readOnlyFileNamed: fileName). 389504 ]. 389505 389506 old := TTCDescriptions detect: [:f | f first name = tt first name] ifNone: [nil]. 389507 old ifNotNil: [TTCDescriptions remove: old]. 389508 TTCDescriptions add: tt. 389509 ^ tt. 389510! ! 389511 389512!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389513clearDefault 389514" 389515 self clearDefault 389516" 389517 389518 TTCDefault := nil. 389519! ! 389520 389521!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389522clearDescriptions 389523" 389524 self clearDescriptions 389525" 389526 389527 TTCDescriptions := Set new. 389528 TTCDefault ifNotNil: [TTCDescriptions add: TTCDefault]. 389529! ! 389530 389531!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'yo 11/30/2002 22:44'! 389532default 389533 389534 ^ TTCDefault. 389535! ! 389536 389537!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 19:29'! 389538descriptionNamed: descriptionName 389539 389540 ^ TTCDescriptions detect: [:f | f first name = descriptionName] ifNone: [TTCDefault]. 389541! ! 389542 389543!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389544descriptionNamed: descriptionName at: index 389545 389546 | array | 389547 (array := self descriptionNamed: descriptionName) ifNil: [^ nil]. 389548 ^ array at: index. 389549! ! 389550 389551!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'yo 11/30/2002 23:10'! 389552initialize 389553" 389554 self initialize 389555" 389556 389557 self clearDescriptions. 389558! ! 389559 389560!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389561removeDescriptionNamed: descriptionName 389562 389563 | tt | 389564 TTCDescriptions ifNil: [^ self]. 389565 [(tt := TTCDescriptions detect: [:f | ('Multi', f first name) = descriptionName] ifNone: [nil]) notNil] whileTrue:[ 389566 TTCDescriptions remove: tt 389567 ]. 389568! ! 389569 389570!TTCFontDescription class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389571setDefault 389572" 389573 self setDefault 389574" 389575 389576 TTCDefault := TTCFontReader readFrom: (FileStream readOnlyFileNamed: 'C:\WINDOWS\Fonts\msgothic.ttc'). 389577 self clearDescriptions. 389578 389579! ! 389580TTFontReader subclass: #TTCFontReader 389581 instanceVariableNames: 'fonts' 389582 classVariableNames: 'EncodingTag' 389583 poolDictionaries: '' 389584 category: 'Multilingual-Display'! 389585 389586!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389587decodeCmapFmtTable: entry 389588 | cmapFmt length cmap firstCode entryCount segCount segments offset code | 389589 cmapFmt := entry nextUShort. 389590 length := entry nextUShort. 389591 entry skip: 2. "skip version" 389592 389593 cmapFmt = 0 ifTrue: "byte encoded table" 389594 [length := length - 6. "should be always 256" 389595 length <= 0 ifTrue: [^ nil]. "but sometimes, this table is empty" 389596 cmap := Array new: length. 389597 entry nextBytes: length into: cmap startingAt: entry offset. 389598 ^ cmap]. 389599 389600 cmapFmt = 4 ifTrue: "segment mapping to deltavalues" 389601 [segCount := entry nextUShort // 2. 389602 entry skip: 6. "skip searchRange, entrySelector, rangeShift" 389603 segments := Array new: segCount. 389604 segments := (1 to: segCount) collect: [:e | Array new: 4]. 389605 1 to: segCount do: [:i | (segments at: i) at: 2 put: entry nextUShort]. "endCount" 389606 entry skip: 2. "skip reservedPad" 389607 1 to: segCount do: [:i | (segments at: i) at: 1 put: entry nextUShort]. "startCount" 389608 1 to: segCount do: [:i | (segments at: i) at: 3 put: entry nextShort]. "idDelta" 389609 offset := entry offset. 389610 1 to: segCount do: [:i | (segments at: i) at: 4 put: entry nextUShort]. "idRangeOffset" 389611 cmap := Array new: 65536 withAll: 0. 389612 segments withIndexDo: 389613 [:seg :si | 389614 seg first to: seg second do: 389615 [:i | 389616 seg last > 0 ifTrue: 389617 ["offset to glypthIdArray - this is really C-magic!!" 389618 entry offset: i - seg first - 1 * 2 + seg last + si + si + offset. 389619 code := entry nextUShort. 389620 code > 0 ifTrue: [code := code + seg third]] 389621 ifFalse: 389622 ["simple offset" 389623 code := i + seg third]. 389624 cmap at: i + 1 put: (code \\ 16r10000)]]. 389625 ^ cmap]. 389626 389627 cmapFmt = 6 ifTrue: "trimmed table" 389628 [firstCode := entry nextUShort. 389629 entryCount := entry nextUShort. 389630 cmap := Array new: entryCount + firstCode withAll: 0. 389631 entryCount timesRepeat: 389632 [cmap at: (firstCode := firstCode + 1) put: entry nextUShort]. 389633 ^ cmap]. 389634 ^ nil! ! 389635 389636!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389637getTableDirEntry: tagString from: fontData offset: offset 389638 "Find the table named tagString in fontData and return a table directory entry for it." 389639 389640 | nTables pos currentTag tag | 389641 nTables := fontData shortAt: 5 + offset bigEndian: true. 389642 tag := ByteArray new: 4. 389643 1 to: 4 do:[:i| tag byteAt: i put: (tagString at: i) asInteger]. 389644 tag := tag longAt: 1 bigEndian: true. 389645 pos := 13 + offset. 389646 1 to: nTables do:[:i| 389647 currentTag := fontData longAt: pos bigEndian: true. 389648 currentTag = tag ifTrue:[^TTFontTableDirEntry on: fontData at: pos]. 389649 pos := pos+16]. 389650 ^nil! ! 389651 389652!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389653parseTTCHeaderFrom: fontData 389654 389655 | pos nTables | 389656 nTables := fontData longAt: 9 bigEndian: true. 389657 fonts := Array new: nTables. 389658 pos := 13. 389659 1 to: nTables do: [:i | 389660 fonts at: i put: (fontData longAt: pos bigEndian: true). 389661 pos := pos + 4. 389662 ]. 389663 389664 ^ fonts 389665! ! 389666 389667!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389668processCharMap: assoc 389669 "Process the given character map" 389670 389671 | glyph cmap encode0 encode1 char value null | 389672 cmap := assoc value. 389673 null := (glyphs at: (cmap at: Character space asUnicode + 1) + 1) copy. 389674 null contours: #(). 389675 389676 encode0 := Array new: 256 withAll: glyphs first. 389677 encode1 := Array new: 65536 withAll: glyphs first. 389678 389679 0 to: 255 do: [:i | 389680 char := Character value: i. 389681 glyph := glyphs at: (cmap at: char asUnicode + 1) + 1. 389682 encode0 at: i+1 put: glyph. 389683 ]. 389684 Character separators do: [:c | 389685 encode0 at: (c asciiValue + 1) put: null. 389686 ]. 389687 0 to: 65536 - 1 do: [:i | 389688 value := cmap at: i+1. 389689 value = 65535 ifFalse: [ "???" 389690 encode1 at: i+1 put: (glyphs at: value+1). 389691 ] 389692 ]. 389693 389694 ^ {encode0. encode1}. 389695! ! 389696 389697!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389698processCharacterMappingTable: entry 389699 "Read the font's character to glyph index mapping table. 389700 If an appropriate mapping can be found then return an association 389701 with the format identifier and the contents of the table" 389702 | copy initialOffset nSubTables pID sID offset cmap assoc | 389703 initialOffset := entry offset. 389704 entry skip: 2. "Skip table version" 389705 nSubTables := entry nextUShort. 389706 1 to: nSubTables do:[:i| 389707 pID := entry nextUShort. 389708 sID := entry nextUShort. 389709 offset := entry nextULong. 389710 "Check if this is either a Macintosh encoded table 389711 or a Windows encoded table" 389712 (pID = 1 or:[pID = 3]) ifTrue:[ 389713 "Go to the beginning of the table" 389714 copy := entry copy. 389715 copy offset: initialOffset + offset. 389716 cmap := self decodeCmapFmtTable: copy. 389717 "(pID = 1 and: [cmap notNil])" "Prefer Macintosh encoding over everything else" 389718 "ifTrue: [pID -> cmap]." 389719 assoc := pID -> cmap. "Keep it in case we don't find a Mac encoded table" 389720 ]. 389721 ]. 389722 ^assoc! ! 389723 389724!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389725readFrom: aStream 389726 389727 "Read the raw font byte data" 389728 | fontData | 389729 (aStream respondsTo: #binary) ifTrue:[aStream binary]. 389730 fontData := aStream contents asByteArray. 389731 389732 fonts := self parseTTCHeaderFrom: fontData. 389733 ^ ((Array with: fonts first) collect: [:offset | 389734 fontDescription := TTCFontDescription new. 389735 self readFrom: fontData fromOffset: offset at: EncodingTag. 389736 ]) at: 1. 389737! ! 389738 389739!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389740readFrom: fontData fromOffset: offset at: encodingTag 389741 389742 | headerEntry maxProfileEntry nameEntry indexLocEntry charMapEntry glyphEntry horzHeaderEntry horzMetricsEntry kerningEntry glyphOffset cmap numHMetrics indexToLocFormat fontDescription0 fontDescription1 array result | 389743 389744 "Search the tables required to build the font" 389745 (headerEntry := self getTableDirEntry: 'head' from: fontData offset: offset) == nil ifTrue:[ 389746 ^self error:'This font does not have a header table']. 389747 (maxProfileEntry := self getTableDirEntry: 'maxp' from: fontData offset: offset) == nil ifTrue:[ 389748 ^self error:'This font does not have a maximum profile table']. 389749 (nameEntry := self getTableDirEntry: 'name' from: fontData offset: offset) == nil ifTrue:[ 389750 ^self error:'This font does not have a name table']. 389751 (indexLocEntry := self getTableDirEntry: 'loca' from: fontData offset: offset) == nil ifTrue:[ 389752 ^self error:'This font does not have a relocation table']. 389753 (charMapEntry := self getTableDirEntry: 'cmap' from: fontData offset: offset) == nil ifTrue:[ 389754 ^self error:'This font does not have a character map table']. 389755 (glyphEntry := self getTableDirEntry: 'glyf' from: fontData offset: offset) == nil ifTrue:[ 389756 ^self error:'This font does not have a glyph table']. 389757 (horzHeaderEntry := self getTableDirEntry: 'hhea' from: fontData offset: offset) == nil ifTrue:[ 389758 ^self error:'This font does not have a horizontal header table']. 389759 (horzMetricsEntry := self getTableDirEntry: 'hmtx' from: fontData offset: offset) == nil ifTrue:[ 389760 ^self error:'This font does not have a horizontal metrics table']. 389761 (kerningEntry := self getTableDirEntry: 'kern' from: fontData offset: offset) == nil ifTrue:[ 389762 Transcript cr; show:'This font does not have a kerning table';endEntry]. 389763 389764 389765 "Process the data" 389766 indexToLocFormat := self processFontHeaderTable: headerEntry. 389767 self processMaximumProfileTable: maxProfileEntry. 389768 self processNamingTable: nameEntry. 389769 glyphOffset := self processIndexToLocationTable: indexLocEntry format: indexToLocFormat. 389770 cmap := self processCharacterMappingTable: charMapEntry. 389771 (cmap == nil or:[cmap value == nil]) 389772 ifTrue:[^self error:'This font has no suitable character mappings']. 389773 self processGlyphDataTable: glyphEntry offsets: glyphOffset. 389774 numHMetrics := self processHorizontalHeaderTable: horzHeaderEntry. 389775 self processHorizontalMetricsTable: horzMetricsEntry length: numHMetrics. 389776 kerningEntry isNil 389777 ifTrue:[kernPairs := #()] 389778 ifFalse:[self processKerningTable: kerningEntry]. 389779 array := self processCharMap: cmap. 389780 fontDescription0 := fontDescription clone. 389781 fontDescription1 := fontDescription clone. 389782 fontDescription0 setGlyphs: (array at: 1) mapping: nil. 389783 fontDescription1 setGlyphs: (array at: 2) mapping: nil. 389784 "fontDescription setKernPairs: kernPairs." 389785 result := OrderedCollection new. 389786 (encodingTag = nil or: [encodingTag = 0]) ifTrue: [^ Array with: fontDescription1]. 389787 result add: fontDescription0. 389788 encodingTag -1 timesRepeat: [result add: nil]. 389789 result add: fontDescription1. 389790 ^ result asArray. 389791 389792! ! 389793 389794!TTCFontReader methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389795readTTFFrom: aStream 389796 389797 "Read the raw font byte data" 389798 | fontData | 389799 (aStream respondsTo: #binary) ifTrue:[aStream binary]. 389800 fontData := aStream contents asByteArray. 389801 fontDescription := TTCFontDescription new. 389802 389803 ^ self readFrom: fontData fromOffset: 0 at: EncodingTag. 389804! ! 389805 389806"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 389807 389808TTCFontReader class 389809 instanceVariableNames: ''! 389810 389811!TTCFontReader class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389812encodingTag: aNumber 389813" 389814 TTCFontReader encodingTag: 6 389815" 389816 389817 EncodingTag := aNumber. 389818! ! 389819AbstractFont subclass: #TTCFontSet 389820 instanceVariableNames: 'name fontArray foregroundColor' 389821 classVariableNames: 'Registry' 389822 poolDictionaries: '' 389823 category: 'Multilingual-Display'! 389824 389825!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:15'! 389826ascent 389827 389828 ^ (fontArray at: 1) ascent. 389829! ! 389830 389831!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 22:57'! 389832ascentOf: aCharacter 389833 389834 ^ (fontArray at: 1) ascentOf: aCharacter. 389835! ! 389836 389837!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:28'! 389838depth 389839 389840 ^ (fontArray at: 1) depth. 389841! ! 389842 389843!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:16'! 389844descent 389845 389846 ^ (fontArray at: 1) descent. 389847! ! 389848 389849!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:16'! 389850descentKern 389851 389852 ^ 0. 389853! ! 389854 389855!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:29'! 389856descentOf: aChar 389857 389858 ^ (fontArray at: 1) descentOf: aChar 389859! ! 389860 389861!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 1/7/2005 12:05'! 389862displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 389863 389864 ^ self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent. 389865! ! 389866 389867!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'John M McIntosh 11/4/2008 22:14'! 389868displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY 389869 389870 | destPoint font form encoding glyphInfo char charCode destY | 389871 destPoint := aPoint. 389872 glyphInfo := Array new: 5. 389873 startIndex to: stopIndex do: [:charIndex | 389874 char := aString at: charIndex. 389875 encoding := char leadingChar + 1. 389876 charCode := char charCode. 389877 font := fontArray at: encoding. 389878 ((charCode between: font minAscii and: font maxAscii) not) ifTrue: [ 389879 charCode := font maxAscii]. 389880 self glyphInfoOf: char into: glyphInfo. 389881 form := glyphInfo at: 1. 389882 (glyphInfo fifth ~= aBitBlt lastFont) ifTrue: [ 389883 glyphInfo fifth installOn: aBitBlt. 389884 ]. 389885 destY := baselineY - (glyphInfo at: 4). 389886 aBitBlt sourceForm: form. 389887 aBitBlt destX: destPoint x. 389888 aBitBlt destY: destY. 389889 aBitBlt sourceOrigin: 0 @ 0. 389890 aBitBlt width: form width. 389891 aBitBlt height: form height. 389892 aBitBlt copyBits. 389893 destPoint := destPoint + (form width + kernDelta @ 0). 389894 ]. 389895 ^ destPoint. 389896! ! 389897 389898!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'John M McIntosh 11/4/2008 22:18'! 389899displayStringR2L: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta 389900 389901 | destPoint font form encoding char charCode glyphInfo | 389902 destPoint := aPoint. 389903 glyphInfo := Array new: 5. 389904 startIndex to: stopIndex do: [:charIndex | 389905 char := aString at: charIndex. 389906 encoding := char leadingChar + 1. 389907 charCode := char charCode. 389908 font := fontArray at: encoding. 389909 ((charCode between: font minAscii and: font maxAscii) not) ifTrue: [ 389910 charCode := font maxAscii]. 389911 self glyphInfoOf: char into: glyphInfo. 389912 form := glyphInfo at: 1. 389913 (glyphInfo size > 4 and: [(glyphInfo at: 5) notNil and: [(glyphInfo at: 5) ~= aBitBlt lastFont]]) ifTrue: [ 389914 (glyphInfo at: 5) installOn: aBitBlt. 389915 ]. 389916 aBitBlt sourceForm: form. 389917 aBitBlt destX: destPoint x - form width. 389918 aBitBlt destY: destPoint y. 389919 aBitBlt sourceOrigin: 0 @ 0. 389920 aBitBlt width: form width. 389921 aBitBlt height: form height. 389922 aBitBlt copyBits. 389923 destPoint := destPoint - (form width + kernDelta @ 0). 389924 ]. 389925! ! 389926 389927!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:29'! 389928emphasis 389929 ^ (fontArray at: 1) emphasis! ! 389930 389931!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:16'! 389932emphasized: code 389933 389934! ! 389935 389936!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:20'! 389937familyName 389938 389939 ^ 'Multi', (fontArray at: 1) familyName. 389940! ! 389941 389942!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:29'! 389943familySizeFace 389944 389945 ^ Array 389946 with: (fontArray at: 1) name 389947 with: self height 389948 with: 0. 389949! ! 389950 389951!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:16'! 389952fontArray 389953 389954 ^ fontArray 389955! ! 389956 389957!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389958glyphInfoOf: aCharacter into: glyphInfoArray 389959 389960 | index f code | 389961 index := aCharacter leadingChar + 1. 389962 fontArray size < index ifTrue: [^ self questionGlyphInfoInto: glyphInfoArray]. 389963 (f := fontArray at: index) ifNil: [^ self questionGlyphInfoInto: glyphInfoArray]. 389964 389965 code := aCharacter charCode. 389966 ((code between: f minAscii and: f maxAscii) not) ifTrue: [ 389967 ^ self questionGlyphInfoInto: glyphInfoArray. 389968 ]. 389969 f glyphInfoOf: aCharacter into: glyphInfoArray. 389970 glyphInfoArray at: 5 put: self. 389971 ^ glyphInfoArray. 389972! ! 389973 389974!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:29'! 389975height 389976 389977 ^(fontArray at: 1) pixelSize. 389978! ! 389979 389980!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389981initializeWithFontArray: anArray 389982 389983 fontArray := anArray. 389984 "name := anArray first name." 389985! ! 389986 389987!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 1/6/2005 22:00'! 389988installOn: aDisplayContext 389989 389990 ^aDisplayContext installTTCFont: self. 389991! ! 389992 389993!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 389994installOn: aDisplayContext foregroundColor: fgColor backgroundColor: bgColor 389995 389996 foregroundColor := fgColor. 389997 fontArray do: [:s | s ifNotNil: [s installOn: aDisplayContext foregroundColor: fgColor backgroundColor: bgColor]]. 389998! ! 389999 390000!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 2/12/2007 19:34'! 390001isFontSet 390002 390003 ^ true. 390004! ! 390005 390006!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 12/29/2003 15:02'! 390007isTTCFont 390008 ^true! ! 390009 390010!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:30'! 390011lineGrid 390012 390013 ^ (fontArray at: 1) lineGrid. 390014! ! 390015 390016!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 390017maxAsciiFor: encoding 390018 390019 | f | 390020 f := (fontArray at: encoding+1). 390021 f ifNotNil: [^ f maxAscii]. 390022 ^ 0. 390023! ! 390024 390025!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:30'! 390026pointSize 390027 390028 ^ (fontArray at: 1) pixelSize * 72 // 96. 390029! ! 390030 390031!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:27'! 390032pointSizes 390033 390034 ^ self class pointSizes. 390035! ! 390036 390037!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 390038questionGlyphInfoInto: glyphInfoArray 390039 390040 | f form | 390041 f := fontArray at: 1. 390042 form := f formOf: $?. 390043 glyphInfoArray at: 1 put: form; 390044 at: 2 put: 0; 390045 at: 3 put: form width; 390046 at: 4 put: self. 390047 ^ glyphInfoArray. 390048! ! 390049 390050!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'yo 8/5/2003 15:31'! 390051textStyle 390052 390053 ^ TextStyle actualTextStyles 390054 detect: [:aStyle | (aStyle fontArray collect: [:s | s name]) includes: self name] 390055 ifNone: []. 390056! ! 390057 390058!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'JMM 11/4/2008 23:30'! 390059ttcDescription 390060 ^ (fontArray at: 1) ttcDescription! ! 390061 390062!TTCFontSet methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 390063widthOf: aCharacter 390064 390065 | encoding | 390066 encoding := aCharacter leadingChar. 390067 ^ (fontArray at: encoding + 1) widthOf: aCharacter. 390068! ! 390069 390070 390071!TTCFontSet methodsFor: 'objects from disk' stamp: 'sd 2/4/2008 21:20'! 390072objectForDataStream: refStrm 390073 | dp | 390074 "I am about to be written on an object file. Write a 390075reference to a known FontSet in the other system instead." 390076 390077 "a path to me" 390078 dp := DiskProxy global: #TTCFontSet selector: #familyName:pointSize: 390079 args: {self familyName. self pointSize}. 390080 refStrm replace: self with: dp. 390081 ^ dp. 390082! ! 390083 390084"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 390085 390086TTCFontSet class 390087 instanceVariableNames: ''! 390088 390089!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 390090discardDefault 390091" 390092 self discardDefault 390093" 390094 | ttc | 390095 ttc := TTCFontDescription default. 390096 ttc ifNotNil: [ 390097 TextConstants removeKey: ttc name asSymbol ifAbsent: []. 390098 ].! ! 390099 390100!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 390101familyName: n pointSize: s 390102 390103 "(self familyName: 'MultiMSGothic' pointSize: 14) pointSize" 390104 | t ret index | 390105 t := self registry at: n asSymbol ifAbsent: [#()]. 390106 t isEmpty ifTrue: [ 390107 t := (TextConstants at: #DefaultTextStyle) fontArray. 390108 ret := t first. 390109 ret pointSize >= s ifTrue: [^ ret]. 390110 index := 2. 390111 [index <= t size and: [(t at: index) pointSize <= s]] whileTrue: [ 390112 ret := t at: index. 390113 index := index + 1. 390114 ]. 390115 ^ ret. 390116 ]. 390117 ^ (TextStyle named: n) addNewFontSize: s.! ! 390118 390119!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 390120initialize 390121" 390122 self initialize 390123" 390124 390125 | tt | 390126 tt := TTCFontDescription default. 390127 tt ifNotNil: [self newTextStyleFromTT: tt]. 390128! ! 390129 390130!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 11/16/2002 01:18'! 390131newFontArray: anArray 390132 390133 ^super new initializeWithFontArray: anArray 390134! ! 390135 390136!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 390137newTextStyleFromTT: descriptionArray 390138 390139 | array f textStyle styleName arrayOfArray | 390140 390141 arrayOfArray := self pointSizes collect: [:pt | 390142 descriptionArray collect: [:ttc | 390143 ttc ifNil: [nil] ifNotNil: [ 390144 f := (ttc size > 256) 390145 ifTrue: [MultiTTCFont new initialize] 390146 ifFalse: [TTCFont new initialize]. 390147 f ttcDescription: ttc. 390148 f pointSize: pt. 390149 ]. 390150 ]. 390151 ]. 390152 390153 array := arrayOfArray collect: [:fonts | 390154 self newFontArray: fonts. 390155 ]. 390156 390157 styleName := (array at: 1) familyName asSymbol. 390158 textStyle := TextStyle fontArray: array. 390159 TextConstants at: styleName put: textStyle. 390160 390161 self register: array at: styleName. 390162 390163 ^ TextConstants at: styleName. 390164! ! 390165 390166!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 390167newTextStyleFromTTFile: fileName 390168" 390169 TTCFontReader encodingTag: JapaneseEnvironment leadingChar. 390170 self newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\msmincho.TTC' 390171 390172 TTCFontReader encodingTag: 0. 390173 self newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\symbol.ttf' 390174" 390175 390176 | description | 390177 description := TTCFontDescription addFromTTFile: fileName. 390178 ^ self newTextStyleFromTT: description. 390179! ! 390180 390181!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 11/30/2002 22:21'! 390182pointSizes 390183 390184 ^ TTCFont pointSizes. 390185! ! 390186 390187!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 12/2/2004 12:50'! 390188register: anObject at: symbolName 390189 390190 self registry at: symbolName put: anObject. 390191! ! 390192 390193!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 12/2/2004 13:07'! 390194registry 390195 390196 ^ Registry isNil 390197 ifTrue: [Registry := IdentityDictionary new] 390198 ifFalse: [Registry]. 390199! ! 390200 390201!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 390202removeStyleName: aString 390203 390204 | style symName | 390205 symName := aString asSymbol. 390206 style := TextConstants removeKey: symName ifAbsent: []. 390207 style ifNotNil: [self unregister: symName]. 390208 TTCFontDescription removeDescriptionNamed: aString asString. 390209! ! 390210 390211!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 390212setDefault 390213" 390214 self setDefault 390215" 390216 | tt | 390217 tt := TTCFontDescription default. 390218 tt ifNil: [TTCFontDescription setDefault]. 390219 tt := TTCFontDescription default. 390220 tt ifNotNil: [self newTextStyleFromTT: tt]. 390221! ! 390222 390223!TTCFontSet class methodsFor: 'as yet unclassified' stamp: 'yo 12/2/2004 12:49'! 390224unregister: symbolName 390225 390226 self registry removeKey: symbolName ifAbsent: []. 390227! ! 390228TTGlyph subclass: #TTCompositeGlyph 390229 instanceVariableNames: 'glyphs' 390230 classVariableNames: '' 390231 poolDictionaries: '' 390232 category: 'TrueType-Fonts'! 390233!TTCompositeGlyph commentStamp: '<historical>' prior: 0! 390234This class represents a composite TrueType glyph, e.g.one which contains many simple TTGlyphs.! 390235 390236 390237!TTCompositeGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:21'! 390238addGlyph: aGlyph transformation: aMatrix 390239 glyphs := glyphs copyWith: (aMatrix -> aGlyph)! ! 390240 390241!TTCompositeGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:43'! 390242contours 390243 ^contours ifNil:[contours := self computeContours]! ! 390244 390245!TTCompositeGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:20'! 390246glyphs 390247 390248 ^glyphs collect:[:assoc| assoc value].! ! 390249 390250!TTCompositeGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:28'! 390251glyphsAndTransformationsDo: aBlock 390252 glyphs do:[:assoc| 390253 aBlock value: assoc value value: assoc key. 390254 ].! ! 390255 390256 390257!TTCompositeGlyph methodsFor: 'initialize' stamp: 'ar 11/2/1998 01:20'! 390258initialize 390259 glyphs := #().! ! 390260 390261 390262!TTCompositeGlyph methodsFor: 'testing'! 390263isComposite 390264 ^true! ! 390265 390266 390267!TTCompositeGlyph methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 11:33'! 390268computeContours 390269 | out | 390270 out := (Array new: glyphs size * 4) writeStream. 390271 self glyphsAndTransformationsDo:[:glyph :transform| 390272 glyph contours do:[:ptArray| 390273 out nextPut: (transform localPointsToGlobal: ptArray). 390274 ]. 390275 ]. 390276 ^out contents! ! 390277 390278!TTCompositeGlyph methodsFor: 'private' stamp: 'ar 11/14/1998 20:27'! 390279flipAroundY 390280 bounds := (bounds origin x @ bounds corner y negated) corner: 390281 (bounds corner x @ bounds origin y negated). 390282 contours := nil.! ! 390283Object subclass: #TTContourConstruction 390284 instanceVariableNames: 'points' 390285 classVariableNames: '' 390286 poolDictionaries: '' 390287 category: 'TrueType-Support'! 390288!TTContourConstruction commentStamp: '<historical>' prior: 0! 390289This class represents a temporary contour structure during the construction of a TTGlyph from a TrueType file. 390290 390291Instance variables: 390292 points <Array of: TTPoint> The points defining this contour! 390293 390294 390295!TTContourConstruction methodsFor: 'accessing'! 390296points 390297 ^points! ! 390298 390299!TTContourConstruction methodsFor: 'accessing' stamp: 'ar 11/1/1998 22:34'! 390300points: anArray 390301 points := anArray asArray.! ! 390302 390303!TTContourConstruction methodsFor: 'accessing'! 390304segments 390305 390306 | segments | 390307 segments := OrderedCollection new. 390308 self segmentsDo:[:seg| segments add: seg]. 390309 ^segments! ! 390310 390311 390312!TTContourConstruction methodsFor: 'converting' stamp: 'PeterHugossonMiller 9/3/2009 11:35'! 390313asCompressedPoints 390314 "Return the receiver compressed into a PointArray. 390315 All lines will be converted into bezier segments with 390316 the control point set to the start point" 390317 | out minPt maxPt fullRange | 390318 minPt := -16r7FFF asPoint. 390319 maxPt := 16r8000 asPoint. 390320 "Check if we need full 32bit range" 390321 fullRange := points anySatisfy: [:any| any asPoint < minPt or:[any asPoint > maxPt]]. 390322 out := fullRange 390323 ifTrue: [(PointArray new: points size) writeStream] 390324 ifFalse:[(ShortPointArray new: points size) writeStream]. 390325 self segmentsDo:[:segment| 390326 out nextPut: segment start. 390327 segment isBezier2Segment 390328 ifTrue:[out nextPut: segment via] 390329 ifFalse:[out nextPut: segment start]. 390330 out nextPut: segment end. 390331 ]. 390332 ^out contents! ! 390333 390334 390335!TTContourConstruction methodsFor: 'enumerating' stamp: 'hmm 10/28/2001 21:55'! 390336segmentsDo: aBlock 390337 "Evaluate aBlock with the segments of the receiver. This may either be straight line 390338 segments or quadratic bezier curves. The decision is made upon the type flags 390339 in TTPoint as follows: 390340 a) Two subsequent #OnCurve points define a straight segment 390341 b) An #OnCurve point followed by an #OffCurve point followed 390342 by an #OnCurve point defines a quadratic bezier segment 390343 c) Two subsequent #OffCurve points have an implicitely defined 390344 #OnCurve point at half the distance between them" 390345 | last next mid index i | 390346 last := points first. 390347 "Handle case where first point is off-curve" 390348 (last type == #OnCurve) ifFalse: [ 390349 i := points findFirst: [:pt | pt type == #OnCurve]. 390350 i = 0 390351 ifTrue: [mid := TTPoint new 390352 type: #OnCurve; 390353 x: points first x + points last x // 2; 390354 y: points first y + points last y // 2. 390355 points := (Array with: mid), points] 390356 ifFalse: [points := (points copyFrom: i to: points size), (points copyFrom: 1 to: i)]. 390357 last := points first]. 390358 index := 2. 390359 [index <= points size] whileTrue:[ 390360 mid := points at: index. 390361 mid type == #OnCurve ifTrue:[ 390362 "Straight segment" 390363 aBlock value: (LineSegment from: last asPoint to: mid asPoint). 390364 last := mid. 390365 ] ifFalse:["Quadratic bezier" 390366 "Read ahead if the next point is on curve" 390367 next := (index < points size) ifTrue:[points at: (index+1)] ifFalse:[points first]. 390368 next type == #OnCurve ifTrue:[ 390369 "We'll continue after the end point" 390370 index := index + 1. 390371 ] ifFalse:[ "Calculate center" 390372 next := (next asPoint + mid asPoint) // 2]. 390373 aBlock value:(Bezier2Segment from: last asPoint via: mid asPoint to: next asPoint). 390374 last := next]. 390375 index := index + 1]. 390376 (index = (points size + 1)) ifTrue:[ 390377 aBlock value:(LineSegment from: points last asPoint to: points first asPoint)]! ! 390378 390379 390380!TTContourConstruction methodsFor: 'printing'! 390381printOn: aStream 390382 390383 aStream 390384 nextPutAll: self class name; 390385 nextPut:$(; 390386 print: points size; 390387 "space; 390388 print: self type;" 390389 nextPut:$)! ! 390390 390391"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 390392 390393TTContourConstruction class 390394 instanceVariableNames: ''! 390395 390396!TTContourConstruction class methodsFor: 'instance creation'! 390397on: points 390398 390399 ^self new points: points! ! 390400Object subclass: #TTFontDescription 390401 instanceVariableNames: 'glyphTable glyphs kernPairs copyright familyName fullName subfamilyName uniqueName versionName postscriptName trademark bounds unitsPerEm ascender descender lineGap' 390402 classVariableNames: 'Default Descriptions' 390403 poolDictionaries: '' 390404 category: 'TrueType-Fonts'! 390405!TTFontDescription commentStamp: '<historical>' prior: 0! 390406Holds a TrueType font in memory. Is used by TTSampleStringMorph as its font. 390407 390408Class owns a default example. ! 390409 390410 390411!TTFontDescription methodsFor: '*morphic-truetype' stamp: 'ar 11/14/1998 23:47'! 390412asMorph 390413 ^TTSampleFontMorph font: self! ! 390414 390415 390416!TTFontDescription methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:08'! 390417at: aCharOrInteger 390418 ^glyphTable at: aCharOrInteger asInteger+1! ! 390419 390420!TTFontDescription methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:08'! 390421at: index put: value 390422 ^self shouldNotImplement! ! 390423 390424!TTFontDescription methodsFor: 'accessing' stamp: 'yo 11/30/2002 22:38'! 390425name 390426 390427 ^ self familyName copyWithout: Character space. 390428! ! 390429 390430!TTFontDescription methodsFor: 'accessing' stamp: 'yo 11/30/2002 22:38'! 390431size 390432 390433 ^ glyphs size. 390434! ! 390435 390436 390437!TTFontDescription methodsFor: 'converting' stamp: 'sma 5/5/2000 13:46'! 390438asStrikeFontScale: scale 390439 "Generate a StrikeFont (actually a FormSetFont) for this TTF font at a given scale." 390440 390441 | forms | 390442 forms := (0 to: 255) collect: 390443 [:i | 390444 (self at: i) 390445 asFormWithScale: scale 390446 ascender: ascender 390447 descender: descender]. 390448 ^ FormSetFont new 390449 fromFormArray: forms 390450 asciiStart: 0 390451 ascent: (ascender * scale) rounded! ! 390452 390453 390454!TTFontDescription methodsFor: 'copying' stamp: 'yo 6/23/2003 18:23'! 390455deepCopy 390456 390457 "Since it shouldn't be copied for transmitting or any reason, it returns self." 390458 ^ self. 390459! ! 390460 390461!TTFontDescription methodsFor: 'copying' stamp: 'nk 9/3/2004 14:48'! 390462objectForDataStream: refStrm 390463 | dp | 390464 "I am about to be written on an object file. Write a reference to a known Font in the other system instead. " 390465 390466 "A path to me" 390467 (TextConstants at: #forceFontWriting ifAbsent: [false]) ifTrue: [^ self]. 390468 "special case for saving the default fonts on the disk. See collectionFromFileNamed:" 390469 390470 dp := DiskProxy global: #TTFontDescription selector: #descriptionFullNamed: 390471 args: {self fullName}. 390472 refStrm replace: self with: dp. 390473 ^ dp. 390474! ! 390475 390476!TTFontDescription methodsFor: 'copying' stamp: 'yo 11/30/2002 22:38'! 390477veryDeepCopyWith: deepCopier 390478 "Return self. I am shared. Do not record me." 390479! ! 390480 390481 390482!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'! 390483copyright 390484 ^copyright! ! 390485 390486!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'! 390487familyName 390488 ^familyName! ! 390489 390490!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'! 390491fullName 390492 ^fullName! ! 390493 390494!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'! 390495postscriptName 390496 ^postscriptName! ! 390497 390498!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'! 390499subfamilyName 390500 ^subfamilyName! ! 390501 390502!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'! 390503trademark 390504 ^trademark! ! 390505 390506!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'! 390507uniqueName 390508 ^uniqueName! ! 390509 390510!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:49'! 390511versionName 390512 ^versionName! ! 390513 390514 390515!TTFontDescription methodsFor: 'migration' stamp: 'yo 8/16/2004 10:44'! 390516blankGlyphForSeparators 390517 390518 | space | 390519 space := (self at: Character space charCode) copy. 390520 space contours: #(). 390521 Character separators do: [:s | 390522 glyphTable at: s charCode +1 put: space. 390523 ]. 390524! ! 390525 390526 390527!TTFontDescription methodsFor: 'printing' stamp: 'th 6/27/2003 17:08'! 390528printOn: aStream 390529 super printOn: aStream. 390530 aStream nextPut: $(. 390531 familyName printOn: aStream. 390532 aStream nextPut:$).! ! 390533 390534 390535!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:48'! 390536ascender 390537 ^ascender! ! 390538 390539!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:48'! 390540bounds 390541 ^bounds! ! 390542 390543!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:48'! 390544descender 390545 ^descender! ! 390546 390547!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:48'! 390548lineGap 390549 ^lineGap! ! 390550 390551!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:49'! 390552unitsPerEm 390553 ^unitsPerEm! ! 390554 390555 390556!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/14/1998 20:20'! 390557flipAroundY 390558 bounds := (bounds origin x @ bounds corner y negated) corner: 390559 (bounds corner x @ bounds origin y negated). 390560 glyphs do:[:glyph| glyph flipAroundY]! ! 390561 390562!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:27'! 390563setAscender: asc descender: desc lineGap: lgap 390564 ascender := asc. 390565 descender := desc. 390566 lineGap := lgap! ! 390567 390568!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:28'! 390569setBounds: aRect unitsPerEm: aNumber 390570 bounds := aRect. 390571 unitsPerEm := aNumber.! ! 390572 390573!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:27'! 390574setGlyphs: glyphArray mapping: mappingTable 390575 glyphs := glyphArray. 390576 glyphTable := mappingTable.! ! 390577 390578!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:48'! 390579setKernPairs: array 390580 kernPairs := array! ! 390581 390582!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:46'! 390583setStrings: anArray 390584 copyright := anArray at: 1. 390585 familyName := anArray at: 2. 390586 subfamilyName := anArray at: 3. 390587 uniqueName := anArray at: 4. 390588 fullName := anArray at: 5. 390589 versionName := anArray at: 6. 390590 postscriptName := anArray at: 7. 390591 trademark := anArray at: 8. 390592! ! 390593 390594"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 390595 390596TTFontDescription class 390597 instanceVariableNames: ''! 390598 390599!TTFontDescription class methodsFor: 'instance creations' stamp: 'tb 6/24/2003 17:10'! 390600addFromTTFile: fileName 390601" 390602 self addFromTTFile: 'C:\WINDOWS\Fonts\ARIALN.TTF' 390603" 390604 ^self addFromTTStream: (FileStream readOnlyFileNamed: fileName). 390605! ! 390606 390607!TTFontDescription class methodsFor: 'instance creations' stamp: 'tb 6/24/2003 17:08'! 390608addFromTTStream: readStream 390609" 390610 self addFromTTFile: 'C:\WINDOWS\Fonts\ARIALN.TTF' 390611" 390612 390613 | tt old | 390614 tt := TTFontReader readFrom: readStream. 390615 old := Descriptions detect: [:f | f name = tt name and: [f subfamilyName = tt subfamilyName]] ifNone: [nil]. 390616 old ifNotNil: [Descriptions remove: old]. 390617 Descriptions add: tt. 390618 ^ tt. 390619! ! 390620 390621!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 11/30/2002 22:22'! 390622clearDefault 390623" 390624 self clearDefault 390625" 390626 390627 Default := nil. 390628! ! 390629 390630!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 11/30/2002 22:22'! 390631clearDescriptions 390632" 390633 self clearDescriptions 390634" 390635 390636 Descriptions := Set new. 390637 Default ifNotNil: [Descriptions add: Default]. 390638! ! 390639 390640!TTFontDescription class methodsFor: 'instance creations' stamp: 'tk 12/10/2001 17:12'! 390641default 390642 ^ Default! ! 390643 390644!TTFontDescription class methodsFor: 'instance creations' stamp: 'dgd 11/4/2003 17:54'! 390645descriptionFullNamed: descriptionFullName 390646 ^ Descriptions 390647 detect: [:f | f fullName = descriptionFullName] 390648 ifNone: [Default]! ! 390649 390650!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 11/30/2002 22:22'! 390651descriptionNamed: descriptionName 390652 390653 ^ Descriptions detect: [:f | f name = descriptionName] ifNone: [Default]. 390654! ! 390655 390656!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 11/30/2002 22:22'! 390657initialize 390658" 390659 self initialize 390660" 390661 390662 self clearDescriptions. 390663! ! 390664 390665!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 2/21/2004 02:36'! 390666removeDescriptionNamed: descriptionName 390667 390668 | tt | 390669 Descriptions ifNil: [^ self]. 390670 [(tt := Descriptions detect: [:f | f name = descriptionName] ifNone: [nil]) notNil] whileTrue:[ 390671 Descriptions remove: tt 390672 ]. 390673! ! 390674 390675!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 12/13/2002 13:55'! 390676removeDescriptionNamed: descriptionName subfamilyName: subfamilyName 390677 390678 | tts | 390679 Descriptions ifNil: [^ self]. 390680 tts := Descriptions select: [:f | f name = descriptionName and: [f subfamilyName = subfamilyName]]. 390681 tts do: [:f | Descriptions remove: f]. 390682! ! 390683 390684!TTFontDescription class methodsFor: 'instance creations' stamp: 'yo 12/13/2002 13:20'! 390685setDefault 390686" 390687 self setDefault 390688" 390689 390690 Default := TTFontReader readFrom: (FileStream readOnlyFileNamed: 'C:\WINDOWS\Fonts\comic.ttf'). 390691! ! 390692Object subclass: #TTFontReader 390693 instanceVariableNames: 'charMap glyphs nGlyphs kernPairs infoBar fontDescription' 390694 classVariableNames: '' 390695 poolDictionaries: '' 390696 category: 'TrueType-Support'! 390697!TTFontReader commentStamp: '<historical>' prior: 0! 390698TTFontReader constructs a TTFontDescription from a TrueType font (.ttf).! 390699 390700 390701!TTFontReader methodsFor: 'processing' stamp: 'th 6/27/2003 16:58'! 390702processCharMap: assoc 390703 "Process the given character map" 390704 390705 | charTable glyph cmap | 390706 cmap := assoc value. 390707 charTable := Array new: 256 withAll: glyphs first. "Initialize with default glyph" 390708 390709 assoc key = 1 ifTrue: "Mac encoded table" 390710 [1 to: (cmap size min: charTable size) do: 390711 [:i | 390712 glyph := glyphs at: (cmap at: i) + 1. 390713 charTable at: (self macToWin: i) put: glyph]]. 390714 390715 assoc key = 3 ifTrue: "Win encoded table" 390716 [1 to: (cmap size min: charTable size) do: 390717 [:i | 390718 glyph := glyphs at: (cmap at: i) + 1. 390719 charTable at: i put: glyph]]. 390720 390721 ^ charTable! ! 390722 390723!TTFontReader methodsFor: 'processing' stamp: 'yo 6/29/2004 23:33'! 390724processCharacterMappingTable: entry 390725 "Read the font's character to glyph index mapping table. 390726 If an appropriate mapping can be found then return an association 390727 with the format identifier and the contents of the table" 390728 | copy initialOffset nSubTables pID sID offset cmap assoc | 390729 initialOffset := entry offset. 390730 entry skip: 2. "Skip table version" 390731 nSubTables := entry nextUShort. 390732 1 to: nSubTables do:[:i| 390733 pID := entry nextUShort. 390734 sID := entry nextUShort. 390735 offset := entry nextULong. 390736 "Check if this is either a Macintosh encoded table 390737 or a Windows encoded table" 390738 (pID = 1 or:[pID = 3]) ifTrue:[ 390739 "Go to the beginning of the table" 390740 copy := entry copy. 390741 copy offset: initialOffset + offset. 390742 cmap := self decodeCmapFmtTable: copy. 390743 (pID = 3 and: [cmap notNil]) "Prefer Windows encoding over everything else" 390744 ifTrue: [^ pID -> cmap]. 390745 assoc := pID -> cmap. "Keep it in case we don't find a Mac encoded table" 390746 ]. 390747 ]. 390748 ^assoc! ! 390749 390750!TTFontReader methodsFor: 'processing' stamp: 'ar 11/15/1998 01:00'! 390751processCompositeGlyph: glyph contours: nContours from: entry 390752 "Read a composite glyph from the font data. The glyph passed into this method contains some state variables that must be copied into the resulting composite glyph." 390753 | flags glyphIndex hasInstr cGlyph ofsX ofsY iLen a11 a12 a21 a22 m | 390754 cGlyph := TTCompositeGlyph new. 390755 a11 := a22 := 16r4000. "1.0 in F2Dot14" 390756 a21 := a12 := 0. "0.0 in F2Dot14" 390757 "Copy state" 390758 cGlyph bounds: glyph bounds; glyphIndex: glyph glyphIndex. 390759 hasInstr := false. 390760 [ flags := entry nextUShort. 390761 glyphIndex := entry nextUShort + 1. 390762 (flags bitAnd: 1) = 1 ifTrue:[ 390763 ofsX := entry nextShort. 390764 ofsY := entry nextShort. 390765 ] ifFalse:[ 390766 (ofsX := entry nextByte) > 127 ifTrue:[ofsX := ofsX - 256]. 390767 (ofsY := entry nextByte) > 127 ifTrue:[ofsY := ofsY - 256]]. 390768 ((flags bitAnd: 2) = 2) ifFalse:[self halt]. 390769 (flags bitAnd: 8) = 8 ifTrue:[ 390770 a11 := a22 := entry nextShort]. 390771 (flags bitAnd: 64) = 64 ifTrue:[ 390772 a11 := entry nextShort. 390773 a22 := entry nextShort]. 390774 (flags bitAnd: 128) = 128 ifTrue:[ 390775 "2x2 transformation" 390776 a11 := entry nextShort. 390777 a21 := entry nextShort. 390778 a12 := entry nextShort. 390779 a22 := entry nextShort]. 390780 m := MatrixTransform2x3 new. 390781 "Convert entries from F2Dot14 to float" 390782 m a11: (a11 asFloat / 16r4000). 390783 m a12: (a12 asFloat / 16r4000). 390784 m a21: (a21 asFloat / 16r4000). 390785 m a22: (a22 asFloat / 16r4000). 390786 m a13: ofsX. 390787 m a23: ofsY. 390788 cGlyph addGlyph: (glyphs at: glyphIndex) transformation: m. 390789 hasInstr := hasInstr or:[ (flags bitAnd: 256) = 256]. 390790 "Continue as long as the MORE:=COMPONENTS bit is set" 390791 (flags bitAnd: 32) = 32] whileTrue. 390792 hasInstr ifTrue:[ 390793 iLen := entry nextUShort. 390794 entry skip: iLen]. 390795 ^cGlyph! ! 390796 390797!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:42'! 390798processFontHeaderTable: entry 390799"Value Data Type Description 390800unitsPerEm USHORT Granularity of the font's em square. 390801xMax USHORT Maximum X-coordinate for the entire font. 390802xMin USHORT Minimum X-coordinate for the entire font. 390803yMax USHORT Maximum Y-coordinate for the entire font. 390804yMin USHORT Minimum Y-coordinate for the entire font. 390805indexToLocFormat SHORT Used when processing the Index To Loc Table." 390806 | origin corner units indexToLocFormat | 390807 entry skip: 4. "Skip table version number" 390808 entry skip: 4. "Skip font revision number" 390809 entry skip: 4. "Skip check sum adjustment" 390810 entry skip: 4. "Skip magic number" 390811 entry skip: 2. "Skip flags" 390812 390813 units := entry nextUShort. 390814 390815 entry skip: 8. "Skip creation date" 390816 entry skip: 8. "Skip modification date" 390817 390818 "Get min/max values of all glyphs" 390819 origin := entry nextShort @ entry nextShort. 390820 corner := entry nextShort @ entry nextShort. 390821 390822 entry skip: 2. "Skip mac style" 390823 entry skip: 2. "Skip lowest rec PPEM" 390824 entry skip: 2. "Skip font direction hint" 390825 indexToLocFormat := entry nextShort. 390826 390827 fontDescription setBounds: (origin corner: corner) unitsPerEm: units. 390828 ^indexToLocFormat! ! 390829 390830!TTFontReader methodsFor: 'processing' stamp: 'ar 11/3/1998 14:43'! 390831processGlyphDataTable: entry offsets: offsetArray 390832 "Read the actual glyph data from the font. 390833 offsetArray contains the start offsets in the data for each glyph." 390834 | initialOffset glyph nextOffset glyphLength glyphOffset nContours origin corner | 390835 initialOffset := entry offset. 390836 glyphs := Array new: nGlyphs. 390837 1 to: nGlyphs do:[:i | 390838 glyphs at: i put: (TTGlyph new glyphIndex: i-1)]. 390839 'Reading glyph data' 390840 displayProgressAt: Sensor cursorPoint 390841 from: 1 to: nGlyphs during:[:bar| 390842 390843 1 to: nGlyphs do:[:glyphIndex | 390844 bar value: glyphIndex. 390845 glyph := glyphs at: glyphIndex. 390846 glyphOffset := offsetArray at: glyphIndex. 390847 nextOffset := offsetArray at: glyphIndex+1. 390848 glyphLength := nextOffset - glyphOffset. 390849 glyphLength = 0 ifFalse:[ 390850 entry offset: initialOffset + glyphOffset. 390851 nContours := entry nextShort. 390852 origin := entry nextShort @ entry nextShort. 390853 corner := entry nextShort @ entry nextShort. 390854 glyph bounds: (origin corner: corner). 390855 nContours >= 0 ifTrue:[ 390856 self processSimpleGlyph: glyph contours: nContours from: entry 390857 ] ifFalse:[ 390858 glyph := self processCompositeGlyph: glyph contours: nContours from: entry. 390859 glyphs at: glyphIndex put: glyph]]] 390860 ].! ! 390861 390862!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:40'! 390863processHorizontalHeaderTable: entry 390864" 390865ascender SHORT Typographic ascent. 390866descender SHORT Typographic descent. 390867lineGap SHORT Typographic lineGap. 390868numberOfHMetrics USHORT Number hMetric entries in the HTMX 390869 Table; may be smaller than the total 390870 number of glyphs. 390871" 390872 | asc desc lGap numHMetrics | 390873 entry skip: 4. "Skip table version" 390874 asc := entry nextShort. 390875 desc := entry nextShort. 390876 lGap := entry nextShort. 390877 entry skip: 2. "Skip advanceWidthMax" 390878 entry skip: 2. "Skip minLeftSideBearing" 390879 entry skip: 2. "Skip minRightSideBearing" 390880 entry skip: 2. "Skip xMaxExtent" 390881 entry skip: 2. "Skip caretSlopeRise" 390882 entry skip: 2. "Skip caretSlopeRun" 390883 entry skip: 10. "Skip 5 reserved shorts" 390884 entry skip: 2. "Skip metricDataFormat" 390885 390886 numHMetrics := entry nextUShort. 390887 390888 fontDescription setAscender: asc descender: desc lineGap: lGap. 390889 ^numHMetrics! ! 390890 390891!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:40'! 390892processHorizontalMetricsTable: entry length: numHMetrics 390893 "Extract the advance width, left side bearing, and right 390894 side bearing for each glyph from the Horizontal Metrics Table." 390895 | index lastAW glyph | 390896 index := 1. 390897 [index <= numHMetrics] whileTrue:[ 390898 glyph := glyphs at: index. 390899 glyph advanceWidth: entry nextUShort. 390900 glyph leftSideBearing: entry nextShort. 390901 glyph updateRightSideBearing. 390902 index := index + 1]. 390903 index = (nGlyphs +1) ifTrue:[^true]. 390904 lastAW := (glyphs at: index-1) advanceWidth. 390905 390906 [index <= nGlyphs] whileTrue:[ 390907 glyph := glyphs at: index. 390908 glyph advanceWidth: lastAW. 390909 glyph leftSideBearing: entry nextShort. 390910 glyph updateRightSideBearing. 390911 index := index + 1].! ! 390912 390913!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:43'! 390914processIndexToLocationTable: entry format: indexToLocFormat 390915"glyphOffset ULONG[numGlyphs] An array that contains each glyph's 390916 offset into the Glyph Data Table. 390917" | glyphOffset offset| 390918 glyphOffset := Array new: nGlyphs+1. 390919 1 to: nGlyphs+1 do:[:i| 390920 (indexToLocFormat = 0) ifTrue:[ "Format0: offset/2 is stored" 390921 offset := entry nextUShort * 2. 390922 ] ifFalse:["Format1: store actual offset" 390923 offset := entry nextULong]. 390924 glyphOffset at: i put: offset]. 390925 ^glyphOffset! ! 390926 390927!TTFontReader methodsFor: 'processing' stamp: 'ar 11/1/1998 23:21'! 390928processKerningTable: entry 390929 "Extract the kerning information for pairs of glyphs." 390930 | covLow covHigh nKernPairs kp | 390931 entry skip: 2. "Skip table version" 390932 entry skip: 2. "Skip number of sub tables -- we're using the first one only" 390933 entry skip: 2. "Skip current subtable number" 390934 entry skip: 2. "Skip length of subtable" 390935 covHigh := entry nextByte. 390936 covLow := entry nextByte. 390937 390938 "Make sure the format is right (kerning table and format type 0)" 390939 ((covLow bitAnd: 2) = 2 or:[ covHigh ~= 0]) ifTrue:[^false]. 390940 nKernPairs := entry nextUShort. 390941 entry skip: 2. "Skip search range" 390942 entry skip: 2. "Skip entry selector" 390943 entry skip: 2. "Skip range shift" 390944 kernPairs := Array new: nKernPairs. 390945 1 to: nKernPairs do:[:i| 390946 kp := TTKernPair new. 390947 kp left: entry nextUShort. 390948 kp right: entry nextUShort. 390949 kp value: entry nextShort. 390950 kernPairs at: i put: kp]. 390951 ^true! ! 390952 390953!TTFontReader methodsFor: 'processing'! 390954processMaximumProfileTable: entry 390955" 390956numGlyphs USHORT The number of glyphs in the font. 390957" 390958 entry skip: 4. "Skip Table version number" 390959 nGlyphs := entry nextUShort.! ! 390960 390961!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:38'! 390962processNamingTable: entry 390963"copyright CHARPTR The font's copyright notice. 390964familyName CHARPTR The font's family name. 390965subfamilyName CHARPTR The font's subfamily name. 390966uniqueName CHARPTR A unique identifier for this font. 390967fullName CHARPTR The font's full name (a combination of 390968 familyName and subfamilyName). 390969versionName CHARPTR The font's version string. 390970" | nRecords initialOffset storageOffset pID sID lID nID length offset multiBytes string strings | 390971 strings := Array new: 8. 390972 strings atAllPut:''. 390973 initialOffset := entry offset. 390974 entry skip: 2. "Skip format selector" 390975 "Get the number of name records" 390976 nRecords := entry nextUShort. 390977 "Offset from the beginning of this table" 390978 storageOffset := entry nextUShort + initialOffset. 390979 1 to: nRecords do:[:i| 390980 pID := entry nextUShort. 390981 sID := entry nextUShort. 390982 lID := entry nextUShort. 390983 nID := entry nextUShort. 390984 length := entry nextUShort. 390985 offset := entry nextUShort. 390986 "Read only Macintosh or Microsoft strings" 390987 (pID = 1 or:[pID = 3 and:[sID = 1]]) ifTrue:[ 390988 "MS uses Unicode all others single byte" 390989 multiBytes := pID = 3. 390990 string := entry stringAt: storageOffset + offset length: length multiByte: multiBytes. 390991 "Put the name at the right location. 390992 Note: We prefer Macintosh strings about everything else." 390993 nID < strings size ifTrue:[ 390994 (pID = 1 or:[(strings at: nID+1) = '']) 390995 ifTrue:[strings at: nID+1 put: string]. 390996 ]. 390997 ]. 390998 ]. 390999 fontDescription setStrings: strings.! ! 391000 391001!TTFontReader methodsFor: 'processing' stamp: 'ar 11/1/1998 22:18'! 391002processSimpleGlyph: glyph contours: nContours from: entry 391003 391004 | endPts nPts iLength flags | 391005 endPts := Array new: nContours. 391006 1 to: nContours do:[:i| endPts at: i put: entry nextUShort]. 391007 glyph initializeContours: nContours with: endPts. 391008 nPts := endPts last + 1. 391009 iLength := entry nextUShort. "instruction length" 391010 entry skip: iLength. 391011 flags := self getGlyphFlagsFrom: entry size: nPts. 391012 self readGlyphXCoords: entry glyph: glyph nContours: nContours flags: flags endPoints: endPts. 391013 self readGlyphYCoords: entry glyph: glyph nContours: nContours flags: flags endPoints: endPts. 391014 glyph buildContours.! ! 391015 391016 391017!TTFontReader methodsFor: 'public' stamp: 'sd 1/30/2004 15:24'! 391018readFrom: aStream 391019 391020 | fontData headerEntry maxProfileEntry nameEntry indexLocEntry charMapEntry glyphEntry horzHeaderEntry horzMetricsEntry kerningEntry glyphOffset cmap numHMetrics indexToLocFormat | 391021 391022 "Read the raw font byte data" 391023 aStream binary. 391024 fontData := aStream contents asByteArray. 391025 fontDescription := TTFontDescription new. 391026 391027 "Search the tables required to build the font" 391028 (headerEntry := self getTableDirEntry: 'head' from: fontData) == nil ifTrue:[ 391029 ^self error:'This font does not have a header table']. 391030 (maxProfileEntry := self getTableDirEntry: 'maxp' from: fontData) == nil ifTrue:[ 391031 ^self error:'This font does not have a maximum profile table']. 391032 (nameEntry := self getTableDirEntry: 'name' from: fontData) == nil ifTrue:[ 391033 ^self error:'This font does not have a name table']. 391034 (indexLocEntry := self getTableDirEntry: 'loca' from: fontData) == nil ifTrue:[ 391035 ^self error:'This font does not have a relocation table']. 391036 (charMapEntry := self getTableDirEntry: 'cmap' from: fontData) == nil ifTrue:[ 391037 ^self error:'This font does not have a character map table']. 391038 (glyphEntry := self getTableDirEntry: 'glyf' from: fontData) == nil ifTrue:[ 391039 ^self error:'This font does not have a glyph table']. 391040 (horzHeaderEntry := self getTableDirEntry: 'hhea' from: fontData) == nil ifTrue:[ 391041 ^self error:'This font does not have a horizontal header table']. 391042 (horzMetricsEntry := self getTableDirEntry: 'hmtx' from: fontData) == nil ifTrue:[ 391043 ^self error:'This font does not have a horizontal metrics table']. 391044 (kerningEntry := self getTableDirEntry: 'kern' from: fontData) == nil ifTrue:[ 391045 Transcript cr; show:'This font does not have a kerning table';endEntry]. 391046 391047 391048 "Process the data" 391049 indexToLocFormat := self processFontHeaderTable: headerEntry. 391050 self processMaximumProfileTable: maxProfileEntry. 391051 self processNamingTable: nameEntry. 391052 glyphOffset := self processIndexToLocationTable: indexLocEntry format: indexToLocFormat. 391053 cmap := self processCharacterMappingTable: charMapEntry. 391054 (cmap == nil or:[cmap value == nil]) 391055 ifTrue:[^self error:'This font has no suitable character mappings']. 391056 self processGlyphDataTable: glyphEntry offsets: glyphOffset. 391057 numHMetrics := self processHorizontalHeaderTable: horzHeaderEntry. 391058 self processHorizontalMetricsTable: horzMetricsEntry length: numHMetrics. 391059 kerningEntry isNil 391060 ifTrue:[kernPairs := #()] 391061 ifFalse:[self processKerningTable: kerningEntry]. 391062 charMap := self processCharMap: cmap. 391063 fontDescription setGlyphs: glyphs mapping: charMap. 391064 fontDescription setKernPairs: kernPairs. 391065 ^fontDescription! ! 391066 391067 391068!TTFontReader methodsFor: 'private' stamp: 'sma 1/1/2000 19:17'! 391069decodeCmapFmtTable: entry 391070 | cmapFmt length cmap firstCode entryCount segCount segments offset code | 391071 cmapFmt := entry nextUShort. 391072 length := entry nextUShort. 391073 entry skip: 2. "skip version" 391074 391075 cmapFmt = 0 ifTrue: "byte encoded table" 391076 [length := length - 6. "should be always 256" 391077 length <= 0 ifTrue: [^ nil]. "but sometimes, this table is empty" 391078 cmap := Array new: length. 391079 entry nextBytes: length into: cmap startingAt: entry offset. 391080 ^ cmap]. 391081 391082 cmapFmt = 4 ifTrue: "segment mapping to deltavalues" 391083 [segCount := entry nextUShort // 2. 391084 entry skip: 6. "skip searchRange, entrySelector, rangeShift" 391085 segments := Array new: segCount. 391086 segments := (1 to: segCount) collect: [:e | Array new: 4]. 391087 1 to: segCount do: [:i | (segments at: i) at: 2 put: entry nextUShort]. "endCount" 391088 entry skip: 2. "skip reservedPad" 391089 1 to: segCount do: [:i | (segments at: i) at: 1 put: entry nextUShort]. "startCount" 391090 1 to: segCount do: [:i | (segments at: i) at: 3 put: entry nextShort]. "idDelta" 391091 offset := entry offset. 391092 1 to: segCount do: [:i | (segments at: i) at: 4 put: entry nextUShort]. "idRangeOffset" 391093 cmap := Array new: 256 withAll: 0. "could be larger, but Squeak can't handle that" 391094 segments withIndexDo: 391095 [:seg :si | 391096 seg first to: seg second do: 391097 [:i | 391098 i < 256 ifTrue: 391099 [seg last > 0 ifTrue: 391100 ["offset to glypthIdArray - this is really C-magic!!" 391101 entry offset: i - seg first - 1 * 2 + seg last + si + si + offset. 391102 code := entry nextUShort. 391103 code > 0 ifTrue: [code := code + seg third]] 391104 ifFalse: 391105 ["simple offset" 391106 code := i + seg third]. 391107 cmap at: i + 1 put: code]]]. 391108 ^ cmap]. 391109 391110 cmapFmt = 6 ifTrue: "trimmed table" 391111 [firstCode := entry nextUShort. 391112 entryCount := entry nextUShort. 391113 cmap := Array new: entryCount + firstCode withAll: 0. 391114 entryCount timesRepeat: 391115 [cmap at: (firstCode := firstCode + 1) put: entry nextUShort]. 391116 ^ cmap]. 391117 ^ nil! ! 391118 391119!TTFontReader methodsFor: 'private' stamp: 'ar 11/2/1998 01:33'! 391120getGlyphFlagsFrom: entry size: nPts 391121 "Read in the flags for this glyph. The outer loop gathers the flags that 391122 are actually contained in the table. If the repeat bit is set in a flag 391123 then the next byte is read from the table; this is the number of times 391124 to repeat the last flag. The inner loop does this, incrementing the 391125 outer loops index each time." 391126 | flags index repCount flagBits | 391127 flags := ByteArray new: nPts. 391128 index := 1. 391129 [index <= nPts] whileTrue:[ 391130 flagBits := entry nextByte. 391131 flags at: index put: flagBits. 391132 (flagBits bitAnd: 8) = 8 ifTrue:[ 391133 repCount := entry nextByte. 391134 repCount timesRepeat:[ 391135 index := index + 1. 391136 flags at: index put: flagBits]]. 391137 index := index + 1]. 391138 ^flags! ! 391139 391140!TTFontReader methodsFor: 'private' stamp: 'ar 11/2/1998 01:33'! 391141getTableDirEntry: tagString from: fontData 391142 "Find the table named tagString in fontData and return a table directory entry for it." 391143 | nTables pos currentTag tag | 391144 nTables := fontData shortAt: 5 bigEndian: true. 391145 tag := ByteArray new: 4. 391146 1 to: 4 do:[:i| tag byteAt: i put: (tagString at: i) asInteger]. 391147 tag := tag longAt: 1 bigEndian: true. 391148 pos := 13. 391149 1 to: nTables do:[:i| 391150 currentTag := fontData longAt: pos bigEndian: true. 391151 currentTag = tag ifTrue:[^TTFontTableDirEntry on: fontData at: pos]. 391152 pos := pos+16]. 391153 ^nil! ! 391154 391155!TTFontReader methodsFor: 'private' stamp: 'michael.rueger 2/5/2009 17:02'! 391156macToWin: index 391157 ^(index - 1) asCharacter macRomanToUnicode charCode + 1! ! 391158 391159!TTFontReader methodsFor: 'private' stamp: 'ar 11/2/1998 01:36'! 391160readGlyphXCoords:entry glyph: glyph nContours: nContours flags: flags endPoints: endPts 391161 "Read the x coordinates for the given glyph from the font file." 391162 | startPoint endPoint flagBits xValue contour ttPoint | 391163 startPoint := 1. 391164 1 to: nContours do:[:i| 391165 contour := glyph contours at: i. 391166 "Get the end point" 391167 endPoint := (endPts at: i) + 1. 391168 "Store number of points" 391169 startPoint to: endPoint do:[:j| 391170 ttPoint := contour points at: (j - startPoint + 1). 391171 flagBits := flags at: j. 391172 "If bit zero in the flag is set then this point is an on-curve 391173 point, if not, then it is an off-curve point." 391174 (flagBits bitAnd: 1) = 1 391175 ifTrue:[ ttPoint type: #OnCurve] 391176 ifFalse:[ttPoint type: #OffCurve]. 391177 "First we check to see if bit one is set. This would indicate that 391178 the corresponding coordinate data in the table is 1 byte long. 391179 If the bit is not set, then the coordinate data is 2 bytes long." 391180 (flagBits bitAnd: 2) = 2 ifTrue:[ "one byte" 391181 xValue := entry nextByte. 391182 xValue := (flagBits bitAnd: 16)=16 ifTrue:[xValue] ifFalse:[xValue negated]. 391183 ttPoint x: xValue. 391184 ] ifFalse:[ "two byte" 391185 "If bit four is set, then this coordinate is the same as the 391186 last one, so the relative offset (of zero) is stored. If bit 391187 is not set, then read in two bytes and store it as a signed value." 391188 (flagBits bitAnd: 16) = 16 ifTrue:[ ttPoint x: 0 ] 391189 ifFalse:[ 391190 xValue := entry nextShort. 391191 ttPoint x: xValue]]]. 391192 startPoint := endPoint + 1]! ! 391193 391194!TTFontReader methodsFor: 'private' stamp: 'ar 11/2/1998 01:37'! 391195readGlyphYCoords:entry glyph: glyph nContours: nContours flags: flags endPoints: endPts 391196 "Read the y coordinates for the given glyph from the font file." 391197 | startPoint endPoint flagBits yValue contour ttPoint | 391198 startPoint := 1. 391199 1 to: nContours do:[:i| 391200 contour := glyph contours at: i. 391201 "Get the end point" 391202 endPoint := (endPts at: i) + 1. 391203 "Store number of points" 391204 startPoint to: endPoint do:[:j| 391205 ttPoint := contour points at: (j - startPoint + 1). 391206 flagBits := flags at: j. 391207 "Check if this value one or two byte encoded" 391208 (flagBits bitAnd: 4) = 4 ifTrue:[ "one byte" 391209 yValue := entry nextByte. 391210 yValue := (flagBits bitAnd: 32)=32 ifTrue:[yValue] ifFalse:[yValue negated]. 391211 ttPoint y: yValue. 391212 ] ifFalse:[ "two byte" 391213 (flagBits bitAnd: 32) = 32 ifTrue:[ ttPoint y: 0 ] 391214 ifFalse:[ 391215 yValue := entry nextShort. 391216 ttPoint y: yValue]]]. 391217 startPoint := endPoint + 1]! ! 391218 391219!TTFontReader methodsFor: 'private' stamp: 'ar 11/1/1998 21:01'! 391220warn: aString 391221 Transcript cr; show: aString; endEntry.! ! 391222 391223!TTFontReader methodsFor: 'private' stamp: 'michael.rueger 2/5/2009 17:03'! 391224winToMac: index 391225 ^ (index - 1) asCharacter unicodeToMacRoman charCode + 1! ! 391226 391227"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 391228 391229TTFontReader class 391230 instanceVariableNames: ''! 391231 391232!TTFontReader class methodsFor: 'initialization' stamp: 'nk 7/16/2003 15:56'! 391233fileReaderServicesForFile: fullName suffix: suffix 391234 391235 391236 ^(suffix = 'fnt') | (suffix = '*') 391237 ifTrue: [ self services] 391238 ifFalse: [#()] 391239! ! 391240 391241!TTFontReader class methodsFor: 'initialization' stamp: 'sd 2/1/2002 19:32'! 391242initialize 391243 "self initialize" 391244 391245 FileList registerFileReader: self! ! 391246 391247!TTFontReader class methodsFor: 'initialization' stamp: 'sd 2/1/2002 19:31'! 391248openTTFFile: fullName 391249 391250 (TTFontReader parseFileNamed: fullName) asMorph open! ! 391251 391252!TTFontReader class methodsFor: 'initialization' stamp: 'sd 2/1/2002 22:02'! 391253serviceOpenTrueTypeFont 391254 391255 ^ SimpleServiceEntry 391256 provider: self 391257 label: 'open true type font' 391258 selector: #openTTFFile: 391259 description: 'open true type font'! ! 391260 391261!TTFontReader class methodsFor: 'initialization' stamp: 'sd 2/1/2002 22:03'! 391262services 391263 391264 ^ Array with: self serviceOpenTrueTypeFont 391265! ! 391266 391267!TTFontReader class methodsFor: 'initialization' stamp: 'sd 2/1/2002 19:29'! 391268unload 391269 391270 FileList unregisterFileReader: self ! ! 391271 391272 391273!TTFontReader class methodsFor: 'instance creation' stamp: 'MarcusDenker 9/30/2009 11:57'! 391274installTTF: ttfFileName asTextStyle: textStyleName sizes: sizeArray 391275 "Sizes are in pixels." 391276 "TTFontReader 391277 installTTF: 'F:\fonts\amazon__.TTF' 391278 asTextStyle: #Amazon 391279 sizes: #(24 60)" 391280 391281 | ttf fontArray | 391282 ttf := self parseFileNamed: ttfFileName. 391283 fontArray := sizeArray collect: 391284 [:each | 391285 (ttf asStrikeFontScale: each / ttf unitsPerEm) 391286 name: textStyleName; 391287 pointSize: each]. 391288 TextConstants at: textStyleName asSymbol put: (TextStyle fontArray: fontArray)! ! 391289 391290!TTFontReader class methodsFor: 'instance creation' stamp: 'PeterHugossonMiller 9/2/2009 16:01'! 391291parseFileNamed: aString 391292 "TTFontReader parseFileNamed:'c:\windows\arial.ttf'" 391293 "TTFontReader parseFileNamed:'c:\windows\times.ttf'" 391294 391295 | contents | 391296 contents := (FileStream readOnlyFileNamed: aString) binary contentsOfEntireFile. 391297 ^self readFrom: contents readStream.! ! 391298 391299!TTFontReader class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 00:53'! 391300readFrom: aStream 391301 391302 ^self new readFrom: aStream! ! 391303 391304!TTFontReader class methodsFor: 'instance creation' stamp: 'yo 2/15/2004 18:40'! 391305readTTFFrom: aStream 391306 391307 ^self new readTTFFrom: aStream! ! 391308Object subclass: #TTFontTableDirEntry 391309 instanceVariableNames: 'tag fontData offset length checkSum' 391310 classVariableNames: '' 391311 poolDictionaries: '' 391312 category: 'TrueType-Support'! 391313!TTFontTableDirEntry commentStamp: '<historical>' prior: 0! 391314This class represents an entry in a truetype font table directory. Used by TTFontReader only.! 391315 391316 391317!TTFontTableDirEntry methodsFor: 'accessing'! 391318nextByte 391319 391320 | value | 391321 value := fontData byteAt: offset. 391322 offset := offset + 1. 391323 ^value! ! 391324 391325!TTFontTableDirEntry methodsFor: 'accessing'! 391326nextBytes: numBytes into: array startingAt: byteOffset 391327 391328 1 to: numBytes do:[:i| 391329 array at: i put: (fontData byteAt: byteOffset + i - 1)].! ! 391330 391331!TTFontTableDirEntry methodsFor: 'accessing'! 391332nextLong 391333 391334 | value | 391335 value := fontData longAt: offset bigEndian: true. 391336 offset := offset + 4. 391337 ^value! ! 391338 391339!TTFontTableDirEntry methodsFor: 'accessing'! 391340nextShort 391341 391342 | value | 391343 value := fontData shortAt: offset bigEndian: true. 391344 offset := offset + 2. 391345 ^value! ! 391346 391347!TTFontTableDirEntry methodsFor: 'accessing'! 391348nextULong 391349 391350 | value | 391351 value := fontData unsignedLongAt: offset bigEndian: true. 391352 offset := offset + 4. 391353 ^value! ! 391354 391355!TTFontTableDirEntry methodsFor: 'accessing'! 391356nextUShort 391357 391358 | value | 391359 value := fontData unsignedShortAt: offset bigEndian: true. 391360 offset := offset + 2. 391361 ^value! ! 391362 391363!TTFontTableDirEntry methodsFor: 'accessing'! 391364offset 391365 ^offset! ! 391366 391367!TTFontTableDirEntry methodsFor: 'accessing'! 391368offset: newOffset 391369 offset := newOffset! ! 391370 391371!TTFontTableDirEntry methodsFor: 'accessing'! 391372skip: n 391373 "Skip n bytes" 391374 offset := offset + n.! ! 391375 391376!TTFontTableDirEntry methodsFor: 'accessing' stamp: 'ar 11/1/1998 23:37'! 391377stringAt: stringOffset length: byteLength multiByte: aBoolean 391378 391379 | string index stringLength | 391380 aBoolean ifFalse:[ 391381 stringLength := byteLength. 391382 string := String new: stringLength. 391383 index := stringOffset. 391384 1 to: stringLength do:[:i| 391385 string at: i put: (Character value: (fontData byteAt: index + i - 1))]. 391386 ^string 391387 ] ifTrue:[ 391388 stringLength := byteLength // 2. 391389 string := String new: stringLength. 391390 index := stringOffset. 391391 1 to: stringLength do:[:i| 391392 string at: i put: (Character value: (fontData byteAt: index + 1)). 391393 index := index + 2]. 391394 ^string]! ! 391395 391396 391397!TTFontTableDirEntry methodsFor: 'initialization'! 391398on: fd at: index 391399 391400 fontData := fd. 391401 tag := fontData longAt: index bigEndian: true. 391402 checkSum := fontData longAt: index+4 bigEndian: true. 391403 offset := (fontData longAt: index+8 bigEndian: true) + 1. 391404 length := fontData longAt: index+12 bigEndian: true.! ! 391405 391406"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 391407 391408TTFontTableDirEntry class 391409 instanceVariableNames: ''! 391410 391411!TTFontTableDirEntry class methodsFor: 'instance creation'! 391412on: fontData at: index 391413 391414 ^self new on: fontData at: index! ! 391415Object subclass: #TTGlyph 391416 instanceVariableNames: 'bounds contours advanceWidth leftSideBearing rightSideBearing glyphIndex' 391417 classVariableNames: '' 391418 poolDictionaries: '' 391419 category: 'TrueType-Fonts'! 391420!TTGlyph commentStamp: '<historical>' prior: 0! 391421This class represents a glyph of a TrueType font. 391422 391423Instance variables: 391424 bounds <Rectangle> The receiver's bounds 391425 contours <Array of: PointArray> The compressed contours in the receiver 391426 advanceWidth <Integer> advance width of the glyph 391427 leftSideBearing <Integer> left side bearing 391428 rightSideBearing <Integer> right side bearing 391429 glyphIndex <Integer> the original index of the glyph (used for kerning)! 391430 391431 391432!TTGlyph methodsFor: 'accessing'! 391433advanceWidth 391434 ^advanceWidth! ! 391435 391436!TTGlyph methodsFor: 'accessing'! 391437advanceWidth: aNumber 391438 advanceWidth := aNumber.! ! 391439 391440!TTGlyph methodsFor: 'accessing' stamp: 'ar 11/1/1998 22:25'! 391441bounds 391442 ^bounds! ! 391443 391444!TTGlyph methodsFor: 'accessing' stamp: 'ar 11/1/1998 22:25'! 391445bounds: aRectangle 391446 bounds := aRectangle! ! 391447 391448!TTGlyph methodsFor: 'accessing'! 391449contours 391450 ^contours! ! 391451 391452!TTGlyph methodsFor: 'accessing'! 391453contours: aCollection 391454 contours := aCollection asArray.! ! 391455 391456!TTGlyph methodsFor: 'accessing'! 391457glyphIndex 391458 ^glyphIndex! ! 391459 391460!TTGlyph methodsFor: 'accessing'! 391461glyphIndex: anInteger 391462 glyphIndex := anInteger! ! 391463 391464!TTGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:26'! 391465glyphsAndTransformationsDo: aBlock 391466 aBlock value: self value: MatrixTransform2x3 identity! ! 391467 391468!TTGlyph methodsFor: 'accessing'! 391469leftSideBearing 391470 ^leftSideBearing! ! 391471 391472!TTGlyph methodsFor: 'accessing'! 391473leftSideBearing: aNumber 391474 leftSideBearing := aNumber.! ! 391475 391476!TTGlyph methodsFor: 'accessing'! 391477rightSideBearing 391478 ^rightSideBearing! ! 391479 391480!TTGlyph methodsFor: 'accessing'! 391481rightSideBearing: aNumber 391482 rightSideBearing := aNumber.! ! 391483 391484 391485!TTGlyph methodsFor: 'converting' stamp: 'yo 6/23/2003 18:29'! 391486asFormWithScale: scale ascender: ascender descender: descender 391487 ^ self 391488 asFormWithScale: scale 391489 ascender: ascender 391490 descender: descender 391491 fgColor: Color black 391492 bgColor: Color white 391493 depth: 8 391494 replaceColor: true. 391495! ! 391496 391497!TTGlyph methodsFor: 'converting' stamp: 'yo 6/23/2003 18:27'! 391498asFormWithScale: scale ascender: ascender descender: descender fgColor: fgColor bgColor: bgColor depth: depth 391499 391500 ^ self 391501 asFormWithScale: scale 391502 ascender: ascender 391503 descender: descender 391504 fgColor: fgColor 391505 bgColor: bgColor 391506 depth: depth 391507 replaceColor: false. 391508! ! 391509 391510!TTGlyph methodsFor: 'converting' stamp: 'yo 5/7/2004 10:37'! 391511asFormWithScale: scale ascender: ascender descender: descender fgColor: fgColor bgColor: bgColor depth: depth replaceColor: replaceColorFlag 391512 391513 ^ self 391514 asFormWithScale: scale 391515 ascender: ascender 391516 descender: descender 391517 fgColor: fgColor 391518 bgColor: bgColor 391519 depth: depth 391520 replaceColor: replaceColorFlag 391521 lineGlyph: nil 391522 lingGlyphWidth: 0 391523 emphasis: 0.! ! 391524 391525!TTGlyph methodsFor: 'converting' stamp: 'yo 5/7/2004 11:22'! 391526asFormWithScale: scale ascender: ascender descender: descender fgColor: fgColor bgColor: bgColor depth: depth replaceColor: replaceColorFlag lineGlyph: lineGlyph lingGlyphWidth: lWidth emphasis: code 391527 391528 | form canvas newScale | 391529 form := Form extent: (advanceWidth @ (ascender - descender) * scale) rounded depth: depth. 391530 form fillColor: bgColor. 391531 canvas := BalloonCanvas on: form. 391532 canvas aaLevel: 4. 391533 canvas transformBy: (MatrixTransform2x3 withScale: scale asPoint * (1 @ -1)). 391534 canvas transformBy: (MatrixTransform2x3 withOffset: 0 @ ascender negated). 391535 canvas 391536 drawGeneralBezierShape: self contours 391537 color: fgColor 391538 borderWidth: 0 391539 borderColor: fgColor. 391540 ((code bitAnd: 4) ~= 0 or: [(code bitAnd: 16) ~= 0]) ifTrue: [ 391541 newScale := (form width + 1) asFloat / lineGlyph calculateWidth asFloat. 391542 canvas transformBy: (MatrixTransform2x3 withScale: (newScale / scale)@1.0). 391543 391544 (code bitAnd: 4) ~= 0 ifTrue: [ 391545 canvas 391546 drawGeneralBezierShape: lineGlyph contours 391547 color: fgColor 391548 borderWidth: 0 391549 borderColor: fgColor. 391550 ]. 391551 391552 (code bitAnd: 16) ~= 0 ifTrue: [ 391553 canvas transformBy: (MatrixTransform2x3 withOffset: 0@(ascender // 2)). 391554 canvas 391555 drawGeneralBezierShape: lineGlyph contours 391556 color: fgColor 391557 borderWidth: 0 391558 borderColor: fgColor. 391559 ]. 391560 ]. 391561 391562 replaceColorFlag ifTrue: [ 391563 form replaceColor: bgColor withColor: Color transparent. 391564 ]. 391565 ^ form! ! 391566 391567 391568!TTGlyph methodsFor: 'initialization' stamp: 'ar 11/1/1998 22:25'! 391569initialize 391570 391571 bounds := 0@0 corner: 0@0. 391572 contours := #(). 391573 advanceWidth := 0. 391574 leftSideBearing := 0. 391575 rightSideBearing := 0.! ! 391576 391577 391578!TTGlyph methodsFor: 'printing' stamp: 'tk 9/13/1999 09:54'! 391579printOn: aStream 391580 391581 aStream 391582 nextPutAll: self class name; 391583 nextPut:$(; 391584 print: (contours ifNil: [0] ifNotNil: [contours size]); 391585 nextPut:$).! ! 391586 391587 391588!TTGlyph methodsFor: 'testing'! 391589isComposite 391590 ^false! ! 391591 391592 391593!TTGlyph methodsFor: 'private' stamp: 'yo 5/7/2004 10:38'! 391594calculateWidth 391595 391596 | min max | 391597 min := SmallInteger maxVal. 391598 max := SmallInteger minVal. 391599 self contours do: [:a | a do: [:p | 391600 p x > max ifTrue: [max := p x]. 391601 p x < min ifTrue: [min := p x]. 391602 ]]. 391603 ^ max - min. 391604! ! 391605 391606!TTGlyph methodsFor: 'private' stamp: 'ar 5/25/2000 18:01'! 391607display 391608 | canvas | 391609 canvas := Display getCanvas. 391610 self contours do:[:ptArray| 391611 1 to: ptArray size by: 3 do:[:i| 391612 canvas line: (ptArray at: i) // 10 391613 to: (ptArray at: i+2) // 10 391614 width: 1 color: Color black. 391615 ]. 391616 ].! ! 391617 391618!TTGlyph methodsFor: 'private' stamp: 'ar 11/14/1998 20:22'! 391619flipAroundY 391620 bounds := (bounds origin x @ bounds corner y negated) corner: 391621 (bounds corner x @ bounds origin y negated). 391622 contours := self contours collect:[:contour| contour collect:[:pt| pt x @ pt y negated]].! ! 391623 391624 391625!TTGlyph methodsFor: 'private-initialization' stamp: 'ar 11/1/1998 22:18'! 391626buildContours 391627 "Build the contours in the receiver glyph. 391628 The contour is constructed by converting the points 391629 form each contour into an absolute value and then 391630 compressing the contours into PointArrays." 391631 | tx ty points | 391632 tx := ty := 0. 391633 contours := contours collect:[:contour| 391634 points := contour points. 391635 points do:[:pt| 391636 pt x: (tx := tx + pt x). 391637 pt y: (ty := ty + pt y)]. 391638 contour asCompressedPoints].! ! 391639 391640!TTGlyph methodsFor: 'private-initialization' stamp: 'ar 11/1/1998 22:42'! 391641initializeContours: numContours with: endPoints 391642 "Initialize the contours for creation of the glyph." 391643 | startPt pts endPt | 391644 contours := Array new: numContours. 391645 startPt := -1. 391646 1 to: numContours do:[:i| 391647 endPt := endPoints at: i. 391648 pts := Array new: endPt - startPt. 391649 1 to: pts size do:[:j| pts at: j put: TTPoint new]. 391650 contours at: i put: (TTContourConstruction on: pts). 391651 startPt := endPt].! ! 391652 391653!TTGlyph methodsFor: 'private-initialization' stamp: 'ar 11/1/1998 22:27'! 391654updateRightSideBearing 391655 "Update the right side bearing value" 391656 "@@: Is the following really correct?!!?!!" 391657 rightSideBearing := advanceWidth - leftSideBearing - bounds corner x + bounds origin x! ! 391658Object subclass: #TTKernPair 391659 instanceVariableNames: 'left right value mask' 391660 classVariableNames: '' 391661 poolDictionaries: '' 391662 category: 'TrueType-Fonts'! 391663!TTKernPair commentStamp: '<historical>' prior: 0! 391664A TTKernPair represents a TrueType kerning pair. 391665 391666Instance variables: 391667 left <Integer> The glyph index for the left character. 391668 right <Integer> The glyph index for the right character. 391669 value <Integer> The amount of kerning. 391670 mask <Integer> An efficient representation for the left and the right value.! 391671 391672 391673!TTKernPair methodsFor: 'accessing'! 391674left 391675 ^left! ! 391676 391677!TTKernPair methodsFor: 'accessing'! 391678left: aNumber 391679 391680 left := aNumber! ! 391681 391682!TTKernPair methodsFor: 'accessing' stamp: 'ar 11/1/1998 20:08'! 391683mask 391684 ^mask ifNil:[mask := self class maskFor: left with: right]! ! 391685 391686!TTKernPair methodsFor: 'accessing'! 391687right 391688 ^right! ! 391689 391690!TTKernPair methodsFor: 'accessing'! 391691right: aNumber 391692 391693 right := aNumber! ! 391694 391695!TTKernPair methodsFor: 'accessing'! 391696value 391697 ^value! ! 391698 391699!TTKernPair methodsFor: 'accessing'! 391700value: aNumber 391701 391702 value := aNumber! ! 391703 391704"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 391705 391706TTKernPair class 391707 instanceVariableNames: ''! 391708 391709!TTKernPair class methodsFor: 'accessing'! 391710maskFor: left with: right 391711 ^(left bitShift: 12) + right! ! 391712Object subclass: #TTPoint 391713 instanceVariableNames: 'x y type' 391714 classVariableNames: '' 391715 poolDictionaries: '' 391716 category: 'TrueType-Support'! 391717!TTPoint commentStamp: '<historical>' prior: 0! 391718A representation of a TrueType point which includes a 'type' flag defining whether this point is an 'on' or an 'off' curve point.! 391719 391720 391721!TTPoint methodsFor: 'accessing'! 391722type 391723 ^type! ! 391724 391725!TTPoint methodsFor: 'accessing'! 391726type: aSymbol 391727 391728 type := aSymbol! ! 391729 391730!TTPoint methodsFor: 'accessing'! 391731x 391732 ^x! ! 391733 391734!TTPoint methodsFor: 'accessing'! 391735x: aNumber 391736 391737 x := aNumber! ! 391738 391739!TTPoint methodsFor: 'accessing'! 391740y 391741 ^y! ! 391742 391743!TTPoint methodsFor: 'accessing'! 391744y: aNumber 391745 y := aNumber! ! 391746 391747 391748!TTPoint methodsFor: 'converting'! 391749asPoint 391750 ^x@y! ! 391751 391752 391753!TTPoint methodsFor: 'printing'! 391754printOn: aStream 391755 391756 aStream 391757 nextPutAll: self class name; 391758 nextPut:$(; 391759 print: x; 391760 nextPut:$@; 391761 print: y; 391762 nextPut:$|; 391763 print: type; 391764 nextPut:$)! ! 391765BorderedMorph subclass: #TTSampleFontMorph 391766 instanceVariableNames: 'font transform smoothing' 391767 classVariableNames: '' 391768 poolDictionaries: '' 391769 category: 'Morphic-TrueType'! 391770!TTSampleFontMorph commentStamp: '<historical>' prior: 0! 391771An example for using TrueType fonts.! 391772 391773 391774!TTSampleFontMorph methodsFor: 'accessing' stamp: 'ar 11/14/1998 22:52'! 391775doesBevels 391776 ^false! ! 391777 391778!TTSampleFontMorph methodsFor: 'accessing' stamp: 'sma 1/1/2000 18:08'! 391779font 391780 ^ font! ! 391781 391782!TTSampleFontMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 00:31'! 391783font: aTTFontDescription 391784 | morph | 391785 font := aTTFontDescription. 391786 morph := (TTSampleStringMorph font: font). 391787 morph extent: morph extent * 2. 391788 morph color: Color magenta. 391789 self addMorphCentered: morph. 391790 morph position: morph position x @ (self bounds bottom + 10). 391791 self privateFullMoveBy: self fullBounds origin negated.! ! 391792 391793!TTSampleFontMorph methodsFor: 'accessing' stamp: 'sma 1/1/2000 17:53'! 391794smoothing 391795 ^ smoothing! ! 391796 391797!TTSampleFontMorph methodsFor: 'accessing' stamp: 'bf 10/18/1999 16:19'! 391798smoothing: aNumber 391799 smoothing := aNumber. 391800 self changed! ! 391801 391802!TTSampleFontMorph methodsFor: 'accessing' stamp: 'ar 11/14/1998 22:53'! 391803transform 391804 ^transform ifNil:[self computeTransform].! ! 391805 391806 391807!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 8/17/2003 11:34'! 391808fontWithoutString: aTTFontDescription 391809 font := aTTFontDescription. 391810! ! 391811 391812!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 8/17/2003 11:43'! 391813glyphAt: position 391814 ^font at: (self glyphIndexAt: position).! ! 391815 391816!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 8/17/2003 11:54'! 391817glyphIndexAt: position 391818 | offset | 391819 offset := (position adhereTo: (bounds insetBy: 1)) - bounds origin. 391820 offset := (offset asFloatPoint / bounds extent) * 16. 391821 offset := offset truncated. 391822 ^offset y * 16 + offset x! ! 391823 391824!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 7/15/2003 15:12'! 391825printOn: aStream 391826 aStream nextPutAll: 'TTSampleFont('; 391827 nextPutAll: font familyName; 391828 nextPut: $)! ! 391829 391830!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 8/17/2003 12:12'! 391831selectGlyph 391832 | retval done | 391833 "Modal glyph selector" 391834 done := false. 391835 self on: #mouseDown send: #selectGlyphBlock:event:from: to: self withValue: [ :glyph | retval := glyph. done := true. ]. 391836 self on: #keyStroke send: #value to: [ done := true ]. 391837 [ done ] whileFalse: [ self world doOneCycle ]. 391838 self on: #mouseDown send: nil to: nil. 391839 self on: #keyStroke send: nil to: nil. 391840 ^retval! ! 391841 391842!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 8/17/2003 11:58'! 391843selectGlyphAndSendTo: aBlock 391844 self on: #mouseDown send: #selectGlyphBlock:event:from: to: self withValue: aBlock.! ! 391845 391846!TTSampleFontMorph methodsFor: 'connectors' stamp: 'nk 8/17/2003 12:17'! 391847selectGlyphBlock: aBlock event: evt from: me 391848 aBlock value: (self glyphAt: evt position). 391849! ! 391850 391851 391852!TTSampleFontMorph methodsFor: 'copying' stamp: 'sma 2/26/2000 19:20'! 391853veryDeepFixupWith: deepCopier 391854 "If fields were weakly copied, fix them here. If they were in the 391855 tree being copied, fix them up, otherwise point to the originals!!!!" 391856 391857 super veryDeepFixupWith: deepCopier. 391858 font := deepCopier references at: font ifAbsent: [font]! ! 391859 391860!TTSampleFontMorph methodsFor: 'copying' stamp: 'sma 2/26/2000 19:18'! 391861veryDeepInner: deepCopier 391862 "Copy all of my instance variables. Some need to be not copied at all, 391863 but shared. Warning!!!! Every instance variable defined in this class 391864 must be handled. We must also implement veryDeepFixupWith:. 391865 See DeepCopier class comment." 391866 391867 super veryDeepInner: deepCopier. 391868 "font := font" 391869 transform := transform veryDeepCopyWith: deepCopier. 391870 smoothing := smoothing veryDeepCopyWith: deepCopier! ! 391871 391872 391873!TTSampleFontMorph methodsFor: 'drawing' stamp: 'ar 11/14/1998 23:12'! 391874areasRemainingToFill: aRectangle 391875 ^ Array with: aRectangle! ! 391876 391877!TTSampleFontMorph methodsFor: 'drawing' stamp: 'sma 1/1/2000 17:56'! 391878drawCharactersOn: aCanvas 391879 | glyph origin r offset cy m | 391880 0 to: 255 do:[:i| 391881 glyph := font at: i. 391882 origin := font bounds extent * ((i \\ 16) @ (i // 16)). 391883 r := origin extent: font bounds extent. 391884 offset := r center - glyph bounds center. 391885 cy := glyph bounds center y. 391886 m := MatrixTransform2x3 withOffset: 0@cy. 391887 m := m composedWithLocal: (MatrixTransform2x3 withScale: 1@-1). 391888 m := m composedWithLocal: (MatrixTransform2x3 withOffset: 0@cy negated). 391889 m := m composedWithGlobal: (MatrixTransform2x3 withOffset: offset). 391890 aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas| 391891 balloonCanvas transformBy: m. 391892 balloonCanvas drawGeneralBezierShape: glyph contours 391893 color: color 391894 borderWidth: 0 391895 borderColor: Color black. 391896 ]. 391897 ].! ! 391898 391899!TTSampleFontMorph methodsFor: 'drawing' stamp: 'ar 12/30/1998 10:49'! 391900drawOn: aCanvas 391901 | origin extent offset | 391902 (font isNil) 391903 ifTrue:[^aCanvas frameRectangle: bounds color: Color black]. 391904 origin := self position asIntegerPoint. 391905 extent := self extent asIntegerPoint. 391906 0 to: 16 do:[:i| 391907 offset := (extent x * i // 16) @ (extent y * i // 16). 391908 aCanvas line: origin x @ (origin y + offset y) 391909 to: (origin x + extent x) @ (origin y + offset y) 391910 width: borderWidth color: borderColor. 391911 aCanvas line: (origin x + offset x) @ origin y 391912 to: (origin x + offset x) @ (origin y + extent y) 391913 width: borderWidth color: borderColor. 391914 ]. 391915 aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas| 391916 balloonCanvas transformBy: self transform. 391917 balloonCanvas aaLevel: self smoothing. 391918 self drawCharactersOn: balloonCanvas. 391919 ].! ! 391920 391921 391922!TTSampleFontMorph methodsFor: 'geometry' stamp: 'ar 11/14/1998 22:53'! 391923extent: extentPoint 391924 super extent: extentPoint. 391925 transform := nil.! ! 391926 391927!TTSampleFontMorph methodsFor: 'geometry' stamp: 'ar 11/14/1998 22:53'! 391928position: pos 391929 super position: pos. 391930 transform := nil.! ! 391931 391932 391933!TTSampleFontMorph methodsFor: 'halos and balloon help' stamp: 'sw 1/27/2000 15:43'! 391934addOptionalHandlesTo: aHalo box: box 391935 aHalo addHandleAt: box center color: Color magenta icon: nil on: #mouseDown send: #createSample to: self.! ! 391936 391937!TTSampleFontMorph methodsFor: 'halos and balloon help' stamp: 'ar 11/14/1998 23:39'! 391938balloonHelpTextForHandle: aHandle 391939 aHandle eventHandler firstMouseSelector == #createSample 391940 ifTrue:[^'Create a sample string']. 391941 ^super balloonHelpTextForHandle: aHandle! ! 391942 391943 391944!TTSampleFontMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:40'! 391945defaultBorderWidth 391946 "answer the default border width for the receiver" 391947 ^ 1! ! 391948 391949!TTSampleFontMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'! 391950defaultColor 391951 "answer the default color/fill style for the receiver" 391952 ^ Color black! ! 391953 391954!TTSampleFontMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:10'! 391955initialize 391956 "initialize the state of the receiver" 391957 super initialize. 391958 smoothing := 4. 391959 self extent: 300 @ 300! ! 391960 391961!TTSampleFontMorph methodsFor: 'initialization' stamp: 'alain.plantec 6/1/2008 23:08'! 391962openInWorld 391963 HandMorph attach: self! ! 391964 391965 391966!TTSampleFontMorph methodsFor: 'initialize' stamp: 'alain.plantec 6/1/2008 23:07'! 391967open 391968 self openInWorld! ! 391969 391970 391971!TTSampleFontMorph methodsFor: 'menu' stamp: 'ar 11/14/1998 23:46'! 391972createSample 391973 self world primaryHand attachMorph: (TTSampleStringMorph font: font)! ! 391974 391975!TTSampleFontMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:42'! 391976getSmoothingLevel 391977 "Menu support" 391978 smoothing = 1 391979 ifTrue: [^ 'turn on smoothing' translated]. 391980 smoothing = 2 391981 ifTrue: [^ 'more smoothing' translated]. 391982 smoothing = 4 391983 ifTrue: [^ 'turn off smoothing' translated]! ! 391984 391985!TTSampleFontMorph methodsFor: 'menu' stamp: 'sma 1/1/2000 17:51'! 391986nextSmoothingLevel 391987 smoothing = 1 391988 ifTrue: [smoothing := 2] 391989 ifFalse: [smoothing = 2 391990 ifTrue: [smoothing := 4] 391991 ifFalse: [smoothing = 4 391992 ifTrue: [smoothing := 1]]]. 391993 self changed! ! 391994 391995 391996!TTSampleFontMorph methodsFor: 'menus' stamp: 'ar 6/16/1999 07:21'! 391997addCustomMenuItems: aCustomMenu hand: aHandMorph 391998 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 391999 aCustomMenu addUpdating: #getSmoothingLevel action: #nextSmoothingLevel.! ! 392000 392001 392002!TTSampleFontMorph methodsFor: 'rotate scale and flex' stamp: 'ar 11/15/1998 22:42'! 392003newTransformationMorph 392004 ^MatrixTransformMorph new! ! 392005 392006 392007!TTSampleFontMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:09'! 392008canDrawBorder: aBorderStyle 392009 ^aBorderStyle style == #simple! ! 392010 392011 392012!TTSampleFontMorph methodsFor: 'updating' stamp: 'sma 1/1/2000 17:59'! 392013changed 392014 self invalidRect: (self fullBounds expandBy: 1)! ! 392015 392016 392017!TTSampleFontMorph methodsFor: 'private' stamp: 'ar 11/15/1998 22:48'! 392018computeTransform 392019 | fullExtent scale | 392020 fullExtent := font bounds extent * 16. 392021 scale := self extent asFloatPoint / fullExtent asFloatPoint. 392022 transform := MatrixTransform2x3 withScale: scale. 392023 transform := transform composedWithGlobal: (MatrixTransform2x3 withOffset: self position). 392024 ^transform! ! 392025 392026!TTSampleFontMorph methodsFor: 'private' stamp: 'ar 11/14/1998 22:55'! 392027privateMoveBy: delta 392028 super privateMoveBy: delta. 392029 transform := nil.! ! 392030 392031"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 392032 392033TTSampleFontMorph class 392034 instanceVariableNames: ''! 392035 392036!TTSampleFontMorph class methodsFor: 'connectors' stamp: 'nk 8/17/2003 11:34'! 392037fontWithoutString: aTTFontDescription 392038 ^self new fontWithoutString: aTTFontDescription! ! 392039 392040 392041!TTSampleFontMorph class methodsFor: 'instance creation' stamp: 'ar 11/14/1998 23:06'! 392042font: aTTFontDescription 392043 ^self new font: aTTFontDescription! ! 392044TTSampleFontMorph subclass: #TTSampleStringMorph 392045 instanceVariableNames: 'string ttBounds' 392046 classVariableNames: '' 392047 poolDictionaries: '' 392048 category: 'Morphic-TrueType'! 392049!TTSampleStringMorph commentStamp: '<historical>' prior: 0! 392050I allow the display of a string in a TrueType font as a stand-alone morph. 392051 392052Morph's color changes the inside of the characters. 392053Morph's borderColor changes the outline. 392054 392055Many free fonts are stored at www.FontGuy.com. 392056Use a normal web browser (not our Scamper) and go there. 392057Choose 'categories' and browse to a font you like. 392058Hold the mouse down on the example text in that font. 392059When the menu comes up, choose "Copy this link location". 392060Come back into Squeak, choose "load font from web..." 392061from my menu, and paste in the url.! 392062 392063 392064!TTSampleStringMorph methodsFor: 'accessing' stamp: 'tk 12/10/2001 16:21'! 392065font: aTTFontDescription 392066 font := aTTFontDescription. 392067 string ifNil: [self string: aTTFontDescription fullName] 392068 ifNotNil: [self initializeString].! ! 392069 392070!TTSampleStringMorph methodsFor: 'accessing' stamp: 'sma 1/1/2000 18:08'! 392071string 392072 ^ string! ! 392073 392074!TTSampleStringMorph methodsFor: 'accessing' stamp: 'ar 11/14/1998 23:53'! 392075string: aString 392076 string := aString. 392077 self initializeString.! ! 392078 392079 392080!TTSampleStringMorph methodsFor: 'drawing' stamp: 'ar 12/30/1998 10:51'! 392081drawOn: aCanvas 392082 | xStart glyph | 392083 (font isNil or:[string isNil or:[string isEmpty]]) 392084 ifTrue:[^aCanvas frameRectangle: bounds color: Color black]. 392085 xStart := 0. 392086 aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas| 392087 balloonCanvas transformBy: self transform. 392088 balloonCanvas aaLevel: self smoothing. 392089 string do:[:char| 392090 glyph := font at: char. 392091 balloonCanvas preserveStateDuring:[:subCanvas| 392092 subCanvas transformBy: (MatrixTransform2x3 withOffset: xStart@0). 392093 subCanvas 392094 drawGeneralBezierShape: glyph contours 392095 color: color 392096 borderWidth: borderWidth 392097 borderColor: borderColor]. 392098 xStart := xStart + glyph advanceWidth. 392099 ]. 392100 ].! ! 392101 392102 392103!TTSampleStringMorph methodsFor: 'geometry testing' stamp: 'dgd 2/22/2003 14:42'! 392104containsPoint: aPoint 392105 "^ super containsPoint: aPoint" 392106 392107 "so much faster..." 392108 392109 | picker | 392110 (self bounds containsPoint: aPoint) ifFalse: [^false]. 392111 picker := BalloonCanvas on: (Form extent: 1 @ 1 depth: 32). 392112 picker transformBy: (MatrixTransform2x3 withOffset: aPoint negated). 392113 self drawOn: picker. 392114 ^(picker form bits first) ~= 0! ! 392115 392116 392117!TTSampleStringMorph methodsFor: 'halos and balloon help' stamp: 'ar 11/14/1998 23:44'! 392118addOptionalHandlesTo: aHalo box: box! ! 392119 392120 392121!TTSampleStringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:40'! 392122defaultBorderWidth 392123 "answer the default border width for the receiver" 392124 ^ 0! ! 392125 392126!TTSampleStringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'! 392127defaultColor 392128 "answer the default color/fill style for the receiver" 392129 ^ {Color magenta. Color yellow. Color orange. Color lightGray} atRandom! ! 392130 392131 392132!TTSampleStringMorph methodsFor: 'initialize' stamp: 'sma 1/1/2000 18:08'! 392133initializeString 392134 | xStart char glyph | 392135 (font isNil or: [string isNil]) ifTrue: [^ self]. 392136 xStart := 0. 392137 ttBounds := 0@0 corner: 0@0. 392138 1 to: string size do: 392139 [:i | 392140 char := string at: i. 392141 glyph := font at: char. 392142 ttBounds := ttBounds quickMerge: (glyph bounds translateBy: xStart@0). 392143 xStart := xStart + glyph advanceWidth. 392144 ]. 392145 self extent: ttBounds extent // 40. 392146 borderWidth := ttBounds height // 40! ! 392147 392148 392149!TTSampleStringMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 22:17'! 392150addCustomMenuItems: aCustomMenu hand: aHandMorph 392151 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 392152 aCustomMenu add: 'edit contents...' translated action: #edit. 392153 aCustomMenu add: 'how to find more fonts...' translated action: #howTo. 392154 aCustomMenu add: 'load font from web...' translated action: #loadFromURL.! ! 392155 392156!TTSampleStringMorph methodsFor: 'menus' stamp: 'DamienCassou 9/29/2009 13:13'! 392157edit 392158 "Allow the user to change the text in a crude way" 392159 392160 | str | 392161 str := UIManager default request: 'Type in new text for this TrueType displayer.' translated 392162 initialAnswer: 'some text'. 392163 str isEmptyOrNil ifTrue: [^ self]. 392164 self string: str. 392165! ! 392166 392167!TTSampleStringMorph methodsFor: 'menus' stamp: 'tk 12/10/2001 16:02'! 392168howTo 392169 392170 self inform: 'Many free fonts are stored at www.FontGuy.com. 392171Use a normal web browser (not our Scamper) and go there. 392172Choose ''categories'' and browse to a font you like. 392173Hold the mouse down on the example text in that font. 392174When the menu comes up, choose "Copy this link location". 392175Come back into Squeak, choose "load font from web..." 392176from this menu, and paste in the url.'! ! 392177 392178!TTSampleStringMorph methodsFor: 'menus' stamp: 'DamienCassou 9/29/2009 13:13'! 392179loadFromURL 392180 "Allow the user to change the text in a crude way" 392181 392182 | url | 392183 url := UIManager default request: ' Type in the url for a TrueType font on the web.' translated 392184 initialAnswer: 'http://www.fontguy.com/download.asp?fontid=1494'. 392185 url isEmptyOrNil ifTrue: [^ self]. 392186 self loadFromURL: url. 392187! ! 392188 392189!TTSampleStringMorph methodsFor: 'menus' stamp: 'tk 12/10/2001 16:03'! 392190loadFromURL: urlString 392191 "Fetch the file, unarchive, unzip, and use as my font." 392192 392193 | rawStrm | 392194 rawStrm := HTTPSocket httpGet: urlString. "Later use an HttpURL?" 392195 self font: (TTFontReader readFrom: rawStrm asUnZippedStream). 392196! ! 392197 392198 392199!TTSampleStringMorph methodsFor: 'parts bin' stamp: 'tk 12/10/2001 17:36'! 392200initializeToStandAlone 392201 "Make me into an example" 392202 392203 | dd | 392204 dd := TTFontDescription default. 392205 dd ifNil: [^ RectangleMorph initializeToStandAlone]. "not available" 392206 392207 super initializeToStandAlone. 392208 self font: dd; color: (TranslucentColor r: 1.0 g: 0.097 b: 1.0 alpha: 0.6). 392209 self string: 'TrueType fonts are beautiful'. 392210! ! 392211 392212 392213!TTSampleStringMorph methodsFor: 'printing' stamp: 'nk 7/15/2003 15:12'! 392214printOn: aStream 392215 aStream nextPutAll: 'TTSampleString('; 392216 nextPutAll: font familyName; 392217 nextPut: $)! ! 392218 392219 392220!TTSampleStringMorph methodsFor: 'private' stamp: 'ar 11/14/1998 22:04'! 392221computeTransform 392222 | cy | 392223 cy := bounds origin y + bounds corner y * 0.5. 392224 transform := MatrixTransform2x3 392225 transformFromLocal: (ttBounds insetBy: borderWidth negated) 392226 toGlobal: bounds. 392227 transform := transform composedWithGlobal:(MatrixTransform2x3 withOffset: 0@cy negated). 392228 transform := transform composedWithGlobal:(MatrixTransform2x3 withScale: 1.0@-1.0). 392229 transform := transform composedWithGlobal:(MatrixTransform2x3 withOffset: 0@cy). 392230 ^transform! ! 392231Trait named: #TTransformationCompatibility 392232 uses: {} 392233 category: 'Traits-Kernel-Traits'! 392234!TTransformationCompatibility commentStamp: 'apb 8/22/2005 15:24' prior: 0! 392235methods that make the user of this trait protocol-compatible with TraitTransformation. 392236When used in Trait and ClassTrait, this eliminates the need for TraitHolders. 392237! 392238 392239 392240!TTransformationCompatibility methodsFor: 'enquiries' stamp: 'apb 8/22/2005 15:35'! 392241aliasesForSelector: aSelector 392242 ^ OrderedCollection new 392243! ! 392244 392245!TTransformationCompatibility methodsFor: 'enquiries' stamp: 'apb 8/22/2005 15:36'! 392246allAliasesDict 392247 ^IdentityDictionary new 392248! ! 392249 392250!TTransformationCompatibility methodsFor: 'enquiries' stamp: 'apb 8/22/2005 15:36'! 392251changedSelectorsComparedTo: aTraitTransformation 392252 | selectors otherSelectors changedSelectors aliases otherAliases | 392253 selectors := self allSelectors asIdentitySet. 392254 otherSelectors := aTraitTransformation allSelectors asIdentitySet. 392255 changedSelectors := IdentitySet withAll: ( 392256 (selectors difference: otherSelectors) union: (otherSelectors difference: selectors)). 392257 aliases := self allAliasesDict. 392258 otherAliases := aTraitTransformation allAliasesDict. 392259 aliases keysAndValuesDo: [:key :value | 392260 (value ~~ (otherAliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]]. 392261 otherAliases keysAndValuesDo: [:key :value | 392262 (value ~~ (aliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]]. 392263 ^ changedSelectors. 392264! ! 392265 392266!TTransformationCompatibility methodsFor: 'enquiries' stamp: 'apb 8/22/2005 15:36'! 392267collectMethodsFor: aSelector into: methodDescription 392268 (self includesSelector: aSelector) ifTrue: [ 392269 methodDescription addLocatedMethod: ( 392270 LocatedMethod 392271 location: self 392272 selector: aSelector)] 392273! ! 392274 392275!TTransformationCompatibility methodsFor: 'enquiries' stamp: 'dvf 9/22/2005 18:15'! 392276subject 392277 "for compatibility with TraitTransformations" 392278 ^ self 392279! ! 392280 392281!TTransformationCompatibility methodsFor: 'enquiries' stamp: 'apb 8/22/2005 15:36'! 392282trait 392283 "for compatibility with TraitTransformations" 392284 ^ self 392285! ! 392286 392287"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 392288 392289TTransformationCompatibility classTrait 392290 uses: {}! 392291MorphicModel subclass: #TabGroupMorph 392292 instanceVariableNames: 'tabSelectorMorph contentMorph pageMorphs' 392293 classVariableNames: '' 392294 poolDictionaries: '' 392295 category: 'Polymorph-Widgets'! 392296!TabGroupMorph commentStamp: 'gvc 5/18/2007 11:54' prior: 0! 392297Organises a set of pages sharing the same space and selected through the use of tabs along the top.! 392298 392299 392300!TabGroupMorph methodsFor: 'accessing' stamp: 'gvc 9/15/2006 13:28'! 392301contentMorph 392302 "Answer the value of contentMorph" 392303 392304 ^ contentMorph! ! 392305 392306!TabGroupMorph methodsFor: 'accessing' stamp: 'gvc 9/15/2006 13:28'! 392307contentMorph: anObject 392308 "Set the value of contentMorph" 392309 392310 contentMorph := anObject! ! 392311 392312!TabGroupMorph methodsFor: 'accessing' stamp: 'gvc 9/15/2006 13:53'! 392313pageMorphs 392314 "Answer the value of pageMorphs" 392315 392316 ^ pageMorphs! ! 392317 392318!TabGroupMorph methodsFor: 'accessing' stamp: 'gvc 9/15/2006 13:53'! 392319pageMorphs: anObject 392320 "Set the value of pageMorphs" 392321 392322 pageMorphs := anObject! ! 392323 392324!TabGroupMorph methodsFor: 'accessing' stamp: 'gvc 9/15/2006 11:51'! 392325tabSelectorMorph 392326 "Answer the value of tabSelectorMorph" 392327 392328 ^ tabSelectorMorph! ! 392329 392330!TabGroupMorph methodsFor: 'accessing' stamp: 'gvc 9/15/2006 11:51'! 392331tabSelectorMorph: anObject 392332 "Set the value of tabSelectorMorph" 392333 392334 tabSelectorMorph := anObject! ! 392335 392336 392337!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 14:13'! 392338addPage: aMorph label: aStringOrMorph 392339 "Add a page and its tab." 392340 392341 aMorph 392342 hResizing: #spaceFill; 392343 vResizing: #spaceFill. 392344 self pages add: aMorph. 392345 self tabSelectorMorph addTab: aStringOrMorph! ! 392346 392347!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2008 13:37'! 392348adoptPaneColor: paneColor 392349 "Pass on to the content morph a little lighter." 392350 392351 paneColor ifNil: [^super adoptPaneColor: paneColor]. 392352 super adoptPaneColor: (self theme subgroupColorFrom: paneColor). 392353 self contentMorph borderStyle: (self theme tabPanelBorderStyleFor: self)! ! 392354 392355!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 13:44'! 392356cornerStyle: aSymbol 392357 "Pass on to selector and content too." 392358 392359 super cornerStyle: aSymbol. 392360 self tabSelectorMorph cornerStyle: aSymbol. 392361 self contentMorph cornerStyle: aSymbol! ! 392362 392363!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/16/2006 08:47'! 392364font 392365 "Answer the label font" 392366 392367 ^self tabSelectorMorph font! ! 392368 392369!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/16/2006 08:46'! 392370font: aFont 392371 "Set the label font" 392372 392373 self tabSelectorMorph font: aFont! ! 392374 392375!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/2/2009 10:59'! 392376fullDrawOn: aCanvas 392377 "Patch up the selected tab visuals if required." 392378 392379 super fullDrawOn: aCanvas. 392380 self theme drawTabGroupFinishingFor: self on: aCanvas! ! 392381 392382!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/7/2008 12:13'! 392383initialize 392384 "Initialize the receiver." 392385 392386 super initialize. 392387 self 392388 borderWidth: 0; 392389 changeTableLayout; 392390 cellPositioning: #topLeft; 392391 cellInset: 0@-1; 392392 reverseTableCells: true; 392393 pageMorphs: OrderedCollection new; 392394 tabSelectorMorph: self newTabSelectorMorph; 392395 contentMorph: self newContentMorph; 392396 addMorph: self tabSelectorMorph; 392397 addMorph: self contentMorph. 392398 self tabSelectorMorph addDependent: self! ! 392399 392400!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/16/2006 08:44'! 392401labelsAndPages: assocs 392402 "Replace the tabs and the associated pages." 392403 392404 self contentMorph removeAllMorphs. 392405 self tabSelectorMorph removeAllMorphs. 392406 assocs do: [:a | self addPage: a value label: a key]! ! 392407 392408!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/2/2009 11:43'! 392409minExtent 392410 "Calculate the min extent of the receiver based on all pages." 392411 392412 |extra| 392413 self page ifNil: [^super minExtent max: self tabSelectorMorph minExtent]. 392414 extra := 0@(self tabSelectorMorph minExtent y) + (self contentMorph borderWidth * 2). 392415 extra := extra + self contentMorph layoutInset topLeft. 392416 extra := extra + self contentMorph layoutInset bottomRight. 392417 ^((self pages inject: 0 @ 0 into: [:mw :pm | mw max: pm minExtent]) + extra) 392418 max: self tabSelectorMorph minExtent! ! 392419 392420!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/7/2008 14:47'! 392421newContentMorph 392422 "Answer a new content morph" 392423 392424 |p| 392425 p := PanelMorph new 392426 roundedCorners: #(2 3 4); 392427 changeTableLayout; 392428 layoutInset: (4@4 corner: 4@4); 392429 cellInset: 8; 392430 vResizing: #spaceFill; 392431 hResizing: #spaceFill. 392432 p borderStyle: (self theme tabPanelBorderStyleFor: self). 392433 ^p! ! 392434 392435!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 13:30'! 392436newTabSelectorMorph 392437 "Answer a new tab selector morph" 392438 392439 ^TabSelectorMorph new 392440 vResizing: #shrinkWrap; 392441 hResizing: #spaceFill! ! 392442 392443!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 14:00'! 392444page 392445 "Answer the current page morph if any." 392446 392447 ^self pageMorph! ! 392448 392449!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 13:58'! 392450pageMorph 392451 "Answer the current page morph if any." 392452 392453 ^self contentMorph hasSubmorphs 392454 ifTrue: [self contentMorph submorphs first]! ! 392455 392456!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 14:00'! 392457pages 392458 "Answer the pages." 392459 392460 ^self pageMorphs! ! 392461 392462!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2008 13:38'! 392463paneColorOrNil 392464 "Answer the window's pane color or nil otherwise." 392465 392466 ^super paneColorOrNil ifNotNilDo: [:c | self theme subgroupColorFrom: c]! ! 392467 392468!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 11:51'! 392469selectedPageIndex 392470 "Answer the selected page index." 392471 392472 ^self tabSelectorMorph selectedIndex! ! 392473 392474!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 13:55'! 392475selectedPageIndex: index 392476 "Set the selected page index." 392477 392478 self tabSelectorMorph selectedIndex: index! ! 392479 392480!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'SW 5/23/2009 07:50'! 392481selectedTabBounds 392482 392483 | tsm aSelectedTab | 392484 tsm := self tabSelectorMorph. 392485 aSelectedTab := tsm selectedTab. 392486 ^aSelectedTab bounds.! ! 392487 392488!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/17/2008 11:36'! 392489themeChanged 392490 "Update the corner style." 392491 392492 self cornerStyle: (self theme tabGroupCornerStyleIn: self window). 392493 super themeChanged! ! 392494 392495!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 13:59'! 392496update: aSymbol 392497 "Handle tab changes." 392498 392499 super update: aSymbol. 392500 aSymbol == #selectedIndex 392501 ifTrue: [self updatePageIndex: self selectedPageIndex]! ! 392502 392503!TabGroupMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/12/2006 16:39'! 392504updatePageIndex: index 392505 "Change to the given page index." 392506 392507 |p| 392508 p := self pageMorph. 392509 p isNil 392510 ifTrue: [self contentMorph addMorph: (self pages at: index)] 392511 ifFalse: [self contentMorph 392512 replaceSubmorph: p 392513 by: (self pages at: index)]. 392514 self pageMorph layoutChanged. 392515 self adoptPaneColor: (self owner ifNil: [self]) paneColor! ! 392516PanelMorph subclass: #TabLabelMorph 392517 instanceVariableNames: '' 392518 classVariableNames: '' 392519 poolDictionaries: '' 392520 category: 'Polymorph-Widgets'! 392521!TabLabelMorph commentStamp: 'gvc 9/23/2008 11:49' prior: 0! 392522Specially themed label used for tab selector items. ! 392523 392524 392525!TabLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/7/2008 12:01'! 392526adoptPaneColor: paneColor 392527 "Use the theme for fillStyle and border." 392528 392529 super adoptPaneColor: paneColor. 392530 paneColor ifNil: [^self]. 392531 self fillStyle: self fillStyleToUse. 392532 self borderStyle: self borderStyleToUse! ! 392533 392534!TabLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/7/2008 11:29'! 392535borderStyleToUse 392536 "Answer the borderStyle that should be used for the receiver." 392537 392538 ^self isSelected 392539 ifTrue: [self theme tabLabelSelectedBorderStyleFor: self] 392540 ifFalse: [self theme tabLabelNormalBorderStyleFor: self]! ! 392541 392542!TabLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/7/2008 11:10'! 392543fillStyleToUse 392544 "Answer the basic fill style for the receiver." 392545 392546 ^self isSelected 392547 ifTrue: [self selectedFillStyle] 392548 ifFalse: [self normalFillStyle]! ! 392549 392550!TabLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 16:26'! 392551focusBounds 392552 "Answer the bounds for drawing the focus indication." 392553 392554 ^(self bounds width < 6 or: [self bounds height < 6]) 392555 ifTrue: [super focusBounds] 392556 ifFalse: [super focusBounds insetBy: (2@2 corner: 2@0)]! ! 392557 392558!TabLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/7/2008 11:16'! 392559initialize 392560 "Initialize the receiver." 392561 392562 super initialize. 392563 self fillStyle: self fillStyleToUse. 392564 self borderStyle: self borderStyleToUse! ! 392565 392566!TabLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/7/2008 11:09'! 392567isSelected 392568 "Answer whether the tab is selected." 392569 392570 ^(self owner isKindOf: TabSelectorMorph) and: [ 392571 self owner selectedTab == self]! ! 392572 392573!TabLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/14/2009 15:25'! 392574minWidth 392575 "Consult the theme also." 392576 392577 ^super minWidth max: self theme buttonMinWidth! ! 392578 392579!TabLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/7/2008 11:11'! 392580normalFillStyle 392581 "Return the normal fillStyle of the receiver." 392582 392583 ^self theme tabLabelNormalFillStyleFor: self! ! 392584 392585!TabLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/7/2008 11:11'! 392586selectedFillStyle 392587 "Return the selected fillStyle of the receiver." 392588 392589 ^self theme tabLabelSelectedFillStyleFor: self! ! 392590SimpleBorder subclass: #TabPanelBorder 392591 instanceVariableNames: 'tabSelector' 392592 classVariableNames: '' 392593 poolDictionaries: '' 392594 category: 'Polymorph-Widgets-Borders'! 392595!TabPanelBorder commentStamp: 'gvc 9/23/2008 11:48' prior: 0! 392596Specialist border for a TabGroup panel. Does not draw border beneath selected tab.! 392597 392598 392599!TabPanelBorder methodsFor: 'accessing' stamp: 'gvc 1/7/2008 14:02'! 392600tabSelector 392601 "Answer the value of tabSelector" 392602 392603 ^ tabSelector! ! 392604 392605!TabPanelBorder methodsFor: 'accessing' stamp: 'gvc 1/7/2008 14:02'! 392606tabSelector: anObject 392607 "Set the value of tabSelector" 392608 392609 tabSelector := anObject! ! 392610 392611 392612!TabPanelBorder methodsFor: 'as yet unclassified' stamp: 'gvc 1/7/2008 14:49'! 392613frameRectangle: aRectangle on: aCanvas 392614 "Draw the border taking the currently selected tab into account. 392615 Only works for top-positioned tabs for the moment." 392616 392617 |w h r tab| 392618 w := self width. 392619 w isPoint ifTrue: [h := w y. w := w x] ifFalse:[h := w]. 392620 r := aRectangle topLeft extent: w@aRectangle height. 392621 aCanvas fillRectangle: r color: self color. "left" 392622 r := aRectangle topRight - (w@0) extent: w@aRectangle height. 392623 aCanvas fillRectangle: r color: self color. "right" 392624 r := aRectangle bottomLeft + (w@h negated) extent: aRectangle width - w - w@h. 392625 aCanvas fillRectangle: r color: self color. "bottom" 392626 tab := self selectedTab. 392627 tab ifNil: [ 392628 r := aRectangle topLeft + (w@0) corner: aRectangle topRight - (w@h negated). 392629 aCanvas fillRectangle: r color: self color. 392630 ^self]. "top" 392631 r := aRectangle topLeft + (w@0) corner: tab bounds left + w@(aRectangle top + h). 392632 aCanvas fillRectangle: r color: self color. "top 1" 392633 r := tab bounds left + w@ aRectangle top corner: tab bounds right - w@(aRectangle top + h). 392634 aCanvas fillRectangle: r color: tab paneColor. "top 2" 392635 r := tab bounds right - w@ aRectangle top corner: aRectangle topRight - (w@h negated). 392636 aCanvas fillRectangle: r color: self color. "top 3"! ! 392637 392638!TabPanelBorder methodsFor: 'as yet unclassified' stamp: 'gvc 1/7/2008 14:27'! 392639selectedTab 392640 "Answer the currently selected tab." 392641 392642 ^(self tabSelector ifNil: [^nil]) selectedTab! ! 392643 392644!TabPanelBorder methodsFor: 'as yet unclassified' stamp: 'gvc 1/7/2008 14:16'! 392645style 392646 "Answer #tabbed." 392647 392648 ^#tabbed! ! 392649MorphicModel subclass: #TabSelectorMorph 392650 instanceVariableNames: 'selectedIndex font' 392651 classVariableNames: '' 392652 poolDictionaries: '' 392653 category: 'Polymorph-Widgets'! 392654!TabSelectorMorph commentStamp: 'gvc 5/18/2007 11:54' prior: 0! 392655Row of tabs for a TabGroupMorph.! 392656 392657 392658!TabSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/16/2006 08:54'! 392659font 392660 "Answer the label font" 392661 392662 ^font! ! 392663 392664!TabSelectorMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2009 13:47'! 392665font: aFont 392666 "Set the label font" 392667 392668 font == aFont ifTrue: [^self]. 392669 font := aFont. 392670 self updateFont! ! 392671 392672!TabSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/15/2006 11:37'! 392673selectedIndex 392674 "Answer the value of selectedIndex" 392675 392676 ^ selectedIndex! ! 392677 392678!TabSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/15/2006 13:24'! 392679selectedIndex: index 392680 "Set the value of selectedIndex" 392681 392682 selectedIndex == index ifTrue: [^self]. 392683 selectedIndex := index. 392684 self adoptPaneColor: self paneColor. 392685 self changed: #selectedIndex! ! 392686 392687 392688!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 14:43'! 392689addTab: aStringOrMorph 392690 "Add a new tab with the given text." 392691 392692 self 392693 addMorphBack: (self newLabelMorph: aStringOrMorph); 392694 adoptPaneColor: self paneColor! ! 392695 392696!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/2/2009 10:55'! 392697basicMinExtent 392698 "Anwer the unadjusted min extent." 392699 392700 ^super minExtent! ! 392701 392702!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/17/2008 11:35'! 392703cornerStyle: aSymbol 392704 "Pass to tabs also." 392705 392706 super cornerStyle: aSymbol. 392707 self tabs do: [:t | t cornerStyle: aSymbol]! ! 392708 392709!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'Henrik Sperre Johansen 5/19/2009 22:00'! 392710drawSubmorphsOn: aCanvas 392711 "Display submorphs back to front. 392712 Draw the focus here since we are using inset bounds 392713 for the focus rectangle." 392714 392715 super drawSubmorphsOn: aCanvas. 392716 self hasKeyboardFocus ifTrue: [ 392717 self selectedTab ifNotNilDo: [:t | 392718 self clipSubmorphs 392719 ifTrue: [aCanvas 392720 clipBy: (aCanvas clipRect intersect: self clippingBounds) 392721 during: [:c | t drawKeyboardFocusOn: c]] 392722 ifFalse: [t drawKeyboardFocusOn: aCanvas]]]! ! 392723 392724!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 13:34'! 392725focusBounds 392726 "Answer the bounds for drawing the focus indication." 392727 392728 ^self selectedTab 392729 ifNil: [super focusBounds] 392730 ifNotNilDo: [:tab | tab focusBounds]! ! 392731 392732!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 16:09'! 392733handlesKeyboard: evt 392734 "Yes, we do it here." 392735 392736 ^true! ! 392737 392738!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/17/2008 11:38'! 392739initialize 392740 "Initialize the receiver." 392741 392742 super initialize. 392743 selectedIndex := 0. 392744 self 392745 roundedCorners: #(1 4); 392746 borderWidth: 0; 392747 changeTableLayout; 392748 listDirection: #leftToRight; 392749 cellInset: (self theme tabSelectorCellInsetFor: self)! ! 392750 392751!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 16:12'! 392752keyStroke: event 392753 "Process keys navigation and space to toggle." 392754 392755 (self navigationKey: event) ifTrue: [^self]. 392756 event keyCharacter = Character arrowLeft 392757 ifTrue: [self selectPreviousTab]. 392758 event keyCharacter = Character arrowRight 392759 ifTrue: [self selectNextTab]! ! 392760 392761!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/6/2007 14:37'! 392762keyboardFocusChange: aBoolean 392763 "The message is sent to a morph when its keyboard focus changes. 392764 Update for focus feedback." 392765 392766 self focusChanged! ! 392767 392768!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/2/2009 11:10'! 392769minExtent 392770 "Add a bit for the round corner of the group." 392771 392772 ^self theme tabSelectorMorphMinExtentFor: self! ! 392773 392774!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/14/2009 15:27'! 392775newLabelMorph: aStringOrMorph 392776 "Answer a new label morph with the given label text." 392777 392778 |m l| 392779 l := aStringOrMorph isMorph 392780 ifTrue: [aStringOrMorph lock] 392781 ifFalse: [LabelMorph new 392782 contents: aStringOrMorph; 392783 font: self font; 392784 vResizing: #shrinkWrap; 392785 hResizing: #shrinkWrap; 392786 lock]. 392787 m := TabLabelMorph new 392788 roundedCorners: #(1 4); 392789 cornerStyle: self cornerStyle; 392790 changeTableLayout; 392791 listCentering: #center; 392792 layoutInset: (self theme tabLabelInsetFor: self); 392793 hResizing: #shrinkWrap; 392794 vResizing: #spaceFill; 392795 addMorph: l. 392796 m on: #mouseDown send: #tabClicked:with: to: self. 392797 ^m! ! 392798 392799!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 16:14'! 392800selectNextTab 392801 "Select the next tab, or the first if none selected." 392802 392803 self selectedIndex: self selectedIndex \\ self tabs size + 1! ! 392804 392805!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 16:18'! 392806selectPreviousTab 392807 "Select the previous tab, or the last if none selected." 392808 392809 self selectedIndex: (self selectedIndex < 2 392810 ifTrue: [self tabs size] 392811 ifFalse: [self selectedIndex - 1])! ! 392812 392813!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 13:45'! 392814selectedTab 392815 "Answer the selected tab." 392816 392817 ^self selectedIndex = 0 392818 ifFalse: [self tabs at: self selectedIndex]! ! 392819 392820!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 13:46'! 392821tabClicked: evt with: aMorph 392822 "A tab has been clicked." 392823 392824 self selectedIndex: (self tabs indexOf: aMorph)! ! 392825 392826!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 13:45'! 392827tabs 392828 "Answer the tabs." 392829 392830 ^self submorphs! ! 392831 392832!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 16:00'! 392833takesKeyboardFocus 392834 "Answer whether the receiver can normally take keyboard focus." 392835 392836 ^true! ! 392837 392838!TabSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/16/2006 08:50'! 392839updateFont 392840 "Update the label font." 392841 392842 self tabs do: [:t | 392843 ((t submorphs first isKindOf: StringMorph) or: [t submorphs first isTextMorph]) 392844 ifTrue: [t submorphs first font: self font]]! ! 392845LayoutPolicy subclass: #TableLayout 392846 instanceVariableNames: 'properties minExtentCache' 392847 classVariableNames: '' 392848 poolDictionaries: '' 392849 category: 'Morphic-Layouts'! 392850!TableLayout commentStamp: '<historical>' prior: 0! 392851The layout process: 392852For computing the new layout for the children of any morph, we start with an initial rectangle which is provided as a reference. 392853 392854Step 1: The first step of layout computation is to compute the minimum extent each of our children can have. The minimum extent is mapped through both the local layout frame of the morph (for relative positioning) and the global layout frame (for insets, such as cursor indication) to obtain the minimal size required for each cell. 392855 392856Step 2: Based on the cell sizes, the number of cells we can put into each row and column is computed. For equal spacing, the maximum size of the cells is taken into account here. 392857 392858Step 3: Based on the row/column sizes, we compute the extra space which should be added to each row/column. For 392859 #leftFlush/#topFlush - we add all extra space add the end 392860 #rightFlush/#bottomFlush - we add all extra space at the start 392861 #centering - we add 1/2 of the extra space at start and end 392862 #justified - we distribute the space evenly between the morphs 392863[NOTE: If any #spaceFill morphs are encountered during this step, #justified is implied and the space is exclusively and equally distributed between those #spaceFill morphs. This is for backward compatibility and should *never* be necessary in the new regime]. 392864 392865Step 4: The morphs are placed in the computed cells and the extra space is distributed as necessary. Placing the submorphs is done by mapping through the global and the local layout frame as requested. 392866 392867Start point: 392868=> bounds: new rectangle for the morph. 392869 392870Compute basic arrangement of morphs: 392871=> For each submorph compute minExtent 392872 - if global layout frame inset in global layout frame 392873 - if local layout frame inset in local layout frame 392874=> Compute number of morphs per, width and height of row/column 392875 - if equal spacing based on max size 392876=> Compute extra space per row/column 392877 - if centering = #justified; distribute space equally 392878 - if centering #leftFlush/#topFlush (-1) add start extra 392879 - if centering #rightFlush/#bottomFlush (1) add end extra 392880 - if centering #centered add 1/2 extra to start/end 392881 <extra space must be float and rounded accordingly!!> 392882=> Place morphs in appropriate cells 392883 - if global layout frame inset in global layout frame 392884 - if local layout frame inset in local layout frame 392885 <will likely cause #layoutChanged by submorphs> 392886 392887Distribute morphs in row/column: 392888 392889=> Compute the max length of each row/column 392890! 392891 392892 392893!TableLayout methodsFor: 'layout' stamp: 'PeterHugossonMiller 9/3/2009 11:36'! 392894computeCellSizes: aMorph in: newBounds horizontal: aBool 392895 "Step 1: Compute the minimum extent for all the children of aMorph" 392896 | cells cell size block maxCell minSize maxSize | 392897 cells := (Array new: aMorph submorphCount) writeStream. 392898 minSize := properties minCellSize asPoint. 392899 maxSize := properties maxCellSize asPoint. 392900 aBool ifTrue:[ 392901 minSize := minSize transposed. 392902 maxSize := maxSize transposed]. 392903 maxCell := 0@0. 392904 block := [:m| 392905 m disableTableLayout ifFalse:[ 392906 size := m minExtent asIntegerPoint. 392907 cell := LayoutCell new target: m. 392908 aBool ifTrue:[ 392909 cell hSpaceFill: m hResizing == #spaceFill. 392910 cell vSpaceFill: m vResizing == #spaceFill. 392911 ] ifFalse:[ 392912 cell hSpaceFill: m vResizing == #spaceFill. 392913 cell vSpaceFill: m hResizing == #spaceFill. 392914 size := size transposed. 392915 ]. 392916 size := (size min: maxSize) max: minSize. 392917 cell cellSize: size. 392918 maxCell := maxCell max: size. 392919 cells nextPut: cell]]. 392920 properties reverseTableCells 392921 ifTrue:[aMorph submorphsReverseDo: block] 392922 ifFalse:[aMorph submorphsDo: block]. 392923 ^maxCell -> cells contents! ! 392924 392925!TableLayout methodsFor: 'layout' stamp: 'aoy 2/15/2003 20:49'! 392926computeExtraSpacing: arrangement in: newBounds horizontal: aBool target: aMorph 392927 "Compute the required extra spacing for laying out the cells" 392928 392929 "match newBounds extent with arrangement's orientation" 392930 392931 | extent extra centering n extraPerCell cell last hFill vFill max amount allow | 392932 extent := newBounds extent. 392933 aBool ifFalse: [extent := extent transposed]. 392934 392935 "figure out if we have any horizontal or vertical space fillers" 392936 hFill := vFill := false. 392937 max := 0 @ 0. 392938 arrangement do: 392939 [:c | 392940 max := (max x max: c cellSize x) @ (max y + c cellSize y). 392941 max := max max: c cellSize. 392942 hFill := hFill or: [c hSpaceFill]. 392943 vFill := vFill or: [c vSpaceFill]]. 392944 392945 "Take client's shrink wrap constraints into account. 392946 Note: these are only honored when there are no #spaceFill children, 392947 or when #rubberBandCells is set." 392948 allow := properties rubberBandCells not. 392949 aMorph hResizing == #shrinkWrap 392950 ifTrue: 392951 [aBool 392952 ifTrue: [allow & hFill ifFalse: [extent := max x @ (max y max: extent y)]] 392953 ifFalse: [allow & vFill ifFalse: [extent := (max x max: extent x) @ max y]]]. 392954 aMorph vResizing == #shrinkWrap 392955 ifTrue: 392956 [aBool 392957 ifFalse: [allow & hFill ifFalse: [extent := max x @ (max y max: extent y)]] 392958 ifTrue: [allow & vFill ifFalse: [extent := (max x max: extent x) @ max y]]]. 392959 392960 "Now compute the extra v space" 392961 extra := extent y 392962 - (arrangement inject: 0 into: [:sum :c | sum + c cellSize y]). 392963 extra > 0 392964 ifTrue: 392965 ["Check if we have any #spaceFillers" 392966 392967 vFill 392968 ifTrue: 392969 ["use only #spaceFillers" 392970 392971 n := arrangement inject: 0 392972 into: [:sum :c | c vSpaceFill ifTrue: [sum + 1] ifFalse: [sum]]. 392973 n isZero ifFalse: [extraPerCell := extra asFloat / n asFloat]. 392974 extra := last := 0. 392975 arrangement do: 392976 [:c | 392977 c vSpaceFill 392978 ifTrue: 392979 [extra := (last := extra) + extraPerCell. 392980 amount := 0 @ (extra truncated - last truncated). 392981 c do: [:cc | cc cellSize: cc cellSize + amount]]]] 392982 ifFalse: 392983 ["no #spaceFillers; distribute regularly" 392984 392985 centering := properties wrapCentering. 392986 "centering == #topLeft ifTrue:[]." "add all extra space to the last cell; e.g., do nothing" 392987 centering == #bottomRight 392988 ifTrue: 392989 ["add all extra space to the first cell" 392990 392991 arrangement first addExtraSpace: 0 @ extra]. 392992 centering == #center 392993 ifTrue: 392994 ["add 1/2 extra space to the first and last cell" 392995 392996 arrangement first addExtraSpace: 0 @ (extra // 2)]. 392997 centering == #justified 392998 ifTrue: 392999 ["add extra space equally distributed to each cell" 393000 393001 n := arrangement size - 1 max: 1. 393002 extraPerCell := extra asFloat / n asFloat. 393003 extra := last := 0. 393004 arrangement do: 393005 [:c | 393006 c addExtraSpace: 0 @ (extra truncated - last truncated). 393007 extra := (last := extra) + extraPerCell]]]]. 393008 393009 "Now compute the extra space for the primary direction" 393010 centering := properties listCentering. 393011 1 to: arrangement size 393012 do: 393013 [:i | 393014 cell := arrangement at: i. 393015 extra := extent x - cell cellSize x. 393016 extra > 0 393017 ifTrue: 393018 ["Check if we have any #spaceFillers" 393019 cell := cell nextCell. 393020 cell hSpaceFill 393021 ifTrue: 393022 ["use only #spaceFillers" 393023 393024 393025 n := cell inject: 0 393026 into: [:sum :c | c hSpaceFill ifTrue: [sum + c target spaceFillWeight] ifFalse: [sum]]. 393027 n isZero ifFalse: [extraPerCell := extra asFloat / n asFloat]. 393028 extra := last := 0. 393029 cell do: 393030 [:c | 393031 c hSpaceFill 393032 ifTrue: 393033 [extra := (last := extra) + (extraPerCell * c target spaceFillWeight). 393034 amount := extra truncated - last truncated. 393035 c cellSize: c cellSize + (amount @ 0)]]] 393036 ifFalse: 393037 ["no #spaceFiller; distribute regularly" 393038 393039 393040 "centering == #topLeft ifTrue:[]" "add all extra space to the last cell; e.g., do nothing" 393041 centering == #bottomRight 393042 ifTrue: 393043 ["add all extra space to the first cell" 393044 393045 cell addExtraSpace: extra @ 0]. 393046 centering == #center 393047 ifTrue: 393048 ["add 1/2 extra space to the first and last cell" 393049 393050 cell addExtraSpace: (extra // 2) @ 0]. 393051 centering == #justified 393052 ifTrue: 393053 ["add extra space equally distributed to each cell" 393054 393055 n := cell size - 1 max: 1. 393056 extraPerCell := extra asFloat / n asFloat. 393057 extra := last := 0. 393058 cell do: 393059 [:c | 393060 c addExtraSpace: (extra truncated - last truncated) @ 0. 393061 extra := (last := extra) + extraPerCell]]]]]! ! 393062 393063!TableLayout methodsFor: 'layout' stamp: 'PeterHugossonMiller 9/3/2009 11:37'! 393064computeGlobalCellArrangement: cells in: newBounds horizontal: aBool wrap: wrap spacing: spacing 393065 "Compute number of cells we can put in each row/column. The returned array contains a list of all the cells we can put into the row/column at each level. 393066 Note: The arrangement is so that the 'x' value of each cell advances along the list direction and the 'y' value along the wrap direction. The returned arrangement has an extra cell at the start describing the width and height of the row." 393067 | output maxExtent n cell first last hFill vFill | 393068 output := Array new writeStream. 393069 first := last := nil. 393070 maxExtent := cells inject: 0@0 into:[:size :c| size max: c cellSize "e.g., minSize"]. 393071 spacing == #globalSquare ifTrue:[maxExtent := (maxExtent x max: maxExtent y) asPoint]. 393072 n := (wrap // maxExtent x) max: 1. 393073 hFill := vFill := false. 393074 1 to: cells size do:[:i| 393075 cell := cells at: i. 393076 hFill := hFill or:[cell hSpaceFill]. 393077 vFill := vFill or:[cell vSpaceFill]. 393078 cell cellSize: maxExtent. 393079 first ifNil:[first := last := cell] ifNotNil:[last nextCell: cell. last := cell]. 393080 (i \\ n) = 0 ifTrue:[ 393081 last := LayoutCell new. 393082 last cellSize: (maxExtent x * n) @ (maxExtent y). 393083 last hSpaceFill: hFill. 393084 last vSpaceFill: vFill. 393085 hFill := vFill := false. 393086 last nextCell: first. 393087 output nextPut: last. 393088 first := nil]]. 393089 first ifNotNil:[ 393090 last := LayoutCell new. 393091 last cellSize: (maxExtent x * n) @ (maxExtent y). self flag: #arNote."@@@: n is not correct!!" 393092 last nextCell: first. 393093 output nextPut: last]. 393094 ^output contents 393095! ! 393096 393097!TableLayout methodsFor: 'layout' stamp: 'ar 1/27/2001 14:40'! 393098flushLayoutCache 393099 "Flush any cached information associated with the receiver" 393100 minExtentCache := nil.! ! 393101 393102!TableLayout methodsFor: 'layout' stamp: 'aoy 2/17/2003 01:23'! 393103layout: aMorph in: box 393104 "Compute the layout for the given morph based on the new bounds" 393105 393106 | cells arrangement horizontal newBounds | 393107 aMorph hasSubmorphs ifFalse: [^self]. 393108 properties := aMorph assureTableProperties. 393109 newBounds := box origin asIntegerPoint corner: box corner asIntegerPoint. 393110 (properties wrapDirection == #none and: [properties cellSpacing == #none]) 393111 ifTrue: 393112 ["get into the fast lane" 393113 393114 properties listCentering == #justified 393115 ifFalse: 393116 ["can't deal with that" 393117 393118 properties listDirection == #leftToRight 393119 ifTrue: [^self layoutLeftToRight: aMorph in: newBounds]. 393120 properties listDirection == #topToBottom 393121 ifTrue: [^self layoutTopToBottom: aMorph in: newBounds]]]. 393122 horizontal := (properties listDirection == #topToBottom 393123 or: [properties listDirection == #bottomToTop]) not. 393124 "Step 1: Compute the minimum extent for all the children of aMorph" 393125 cells := self 393126 computeCellSizes: aMorph 393127 in: (0 @ 0 corner: newBounds extent) 393128 horizontal: horizontal. 393129 "Step 2: Compute the arrangement of the cells for each row and column" 393130 arrangement := self 393131 computeCellArrangement: cells 393132 in: newBounds 393133 horizontal: horizontal 393134 target: aMorph. 393135 "Step 3: Compute the extra spacing for each cell" 393136 self 393137 computeExtraSpacing: arrangement 393138 in: newBounds 393139 horizontal: horizontal 393140 target: aMorph. 393141 "Step 4: Place the children within the cells accordingly" 393142 self 393143 placeCells: arrangement 393144 in: newBounds 393145 horizontal: horizontal 393146 target: aMorph! ! 393147 393148!TableLayout methodsFor: 'layout' stamp: 'gm 2/28/2003 01:43'! 393149minExtentOf: aMorph in: box 393150 "Return the minimal size aMorph's children would require given the new bounds" 393151 393152 | cells arrangement horizontal newBounds minX minY dir | 393153 minExtentCache isNil ifFalse: [^minExtentCache]. 393154 aMorph hasSubmorphs ifFalse: [^0 @ 0]. 393155 properties := aMorph assureTableProperties. 393156 (properties wrapDirection == #none and: [properties cellSpacing == #none]) 393157 ifTrue: 393158 ["Get into the fast lane" 393159 393160 dir := properties listDirection. 393161 (dir == #leftToRight or: [dir == #rightToLeft]) 393162 ifTrue: [^self minExtentHorizontal: aMorph]. 393163 (dir == #topToBottom or: [dir == #bottomToTop]) 393164 ifTrue: [^self minExtentVertical: aMorph]]. 393165 newBounds := box origin asIntegerPoint corner: box corner asIntegerPoint. 393166 horizontal := (properties listDirection == #topToBottom 393167 or: [properties listDirection == #bottomToTop]) not. 393168 "Step 1: Compute the minimum extent for all the children of aMorph" 393169 cells := self 393170 computeCellSizes: aMorph 393171 in: (0 @ 0 corner: newBounds extent) 393172 horizontal: horizontal. 393173 "Step 2: Compute the arrangement of the cells for each row and column" 393174 arrangement := self 393175 computeCellArrangement: cells 393176 in: newBounds 393177 horizontal: horizontal 393178 target: aMorph. 393179 "Step 3: Extract the minimum size out of the arrangement" 393180 minX := minY := 0. 393181 arrangement do: 393182 [:cell | 393183 minX := minX max: cell cellSize x + cell extraSpace x. 393184 minY := minY + cell cellSize y + cell extraSpace y]. 393185 minExtentCache := horizontal ifTrue: [minX @ minY] ifFalse: [minY @ minX]. 393186 ^minExtentCache! ! 393187 393188!TableLayout methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:42'! 393189placeCells: arrangement in: newBounds horizontal: aBool target: aMorph 393190 "Place the morphs within the cells accordingly" 393191 393192 | xDir yDir anchor yDist place cell xDist cellRect corner inset | 393193 inset := properties cellInset. 393194 (inset isNumber and: [inset isZero]) ifTrue: [inset := nil]. 393195 aBool 393196 ifTrue: 393197 ["horizontal layout" 393198 393199 properties listDirection == #rightToLeft 393200 ifTrue: 393201 [xDir := -1 @ 0. 393202 properties wrapDirection == #bottomToTop 393203 ifTrue: 393204 [yDir := 0 @ -1. 393205 anchor := newBounds bottomRight] 393206 ifFalse: 393207 [yDir := 0 @ 1. 393208 anchor := newBounds topRight]] 393209 ifFalse: 393210 [xDir := 1 @ 0. 393211 properties wrapDirection == #bottomToTop 393212 ifTrue: 393213 [yDir := 0 @ -1. 393214 anchor := newBounds bottomLeft] 393215 ifFalse: 393216 [yDir := 0 @ 1. 393217 anchor := newBounds topLeft]]] 393218 ifFalse: 393219 ["vertical layout" 393220 393221 properties listDirection == #bottomToTop 393222 ifTrue: 393223 [xDir := 0 @ -1. 393224 properties wrapDirection == #rightToLeft 393225 ifTrue: 393226 [yDir := -1 @ 0. 393227 anchor := newBounds bottomRight] 393228 ifFalse: 393229 [yDir := 1 @ 0. 393230 anchor := newBounds bottomLeft]] 393231 ifFalse: 393232 [xDir := 0 @ 1. 393233 anchor := properties wrapDirection == #rightToLeft 393234 ifTrue: 393235 [yDir := -1 @ 0. 393236 newBounds topRight] 393237 ifFalse: 393238 [yDir := 1 @ 0. 393239 newBounds topLeft]]]. 393240 1 to: arrangement size 393241 do: 393242 [:i | 393243 cell := arrangement at: i. 393244 cell extraSpace ifNotNil: [anchor := anchor + (cell extraSpace y * yDir)]. 393245 yDist := cell cellSize y * yDir. "secondary advance direction" 393246 place := anchor. 393247 cell := cell nextCell. 393248 [cell isNil] whileFalse: 393249 [cell extraSpace ifNotNil: [place := place + (cell extraSpace x * xDir)]. 393250 xDist := cell cellSize x * xDir. "primary advance direction" 393251 corner := place + xDist + yDist. 393252 cellRect := Rectangle origin: (place min: corner) 393253 corner: (place max: corner). 393254 inset ifNotNil: [cellRect := cellRect insetBy: inset]. 393255 cell target layoutInBounds: cellRect. 393256 place := place + xDist. 393257 cell := cell nextCell]. 393258 anchor := anchor + yDist]! ! 393259 393260 393261!TableLayout methodsFor: 'nil' stamp: 'PeterHugossonMiller 9/3/2009 11:36'! 393262computeCellArrangement: cellHolder in: newBounds horizontal: aBool target: aMorph 393263 "Compute number of cells we can put in each row/column. The returned array contains a list of all the cells we can put into the row/column at each level. 393264 Note: The arrangement is so that the 'x' value of each cell advances along the list direction and the 'y' value along the wrap direction. The returned arrangement has an extra cell at the start describing the width and height of the row." 393265 | cells wrap spacing output maxExtent n sum index max cell first last w cellMax maxCell hFill vFill inset | 393266 maxCell := cellHolder key. 393267 cells := cellHolder value. 393268 properties wrapDirection == #none 393269 ifTrue:[wrap := SmallInteger maxVal] 393270 ifFalse:[wrap := aBool ifTrue:[newBounds width] ifFalse:[newBounds height]. 393271 wrap < maxCell x ifTrue:[wrap := maxCell x]]. 393272 spacing := properties cellSpacing. 393273 (spacing == #globalRect or:[spacing = #globalSquare]) ifTrue:[ 393274 "Globally equal spacing is a very special case here, so get out fast and easy" 393275 ^self computeGlobalCellArrangement: cells 393276 in: newBounds horizontal: aBool 393277 wrap: wrap spacing: spacing]. 393278 393279 output := Array new writeStream. 393280 inset := properties cellInset asPoint. 393281 aBool ifFalse:[inset := inset transposed]. 393282 first := last := nil. 393283 maxExtent := 0@0. 393284 sum := 0. 393285 index := 1. 393286 n := 0. 393287 hFill := vFill := false. 393288 [index <= cells size] whileTrue:[ 393289 w := sum. 393290 cell := cells at: index. 393291 cellMax := maxExtent max: cell cellSize. "e.g., minSize" 393292 (spacing == #localRect or:[spacing == #localSquare]) ifTrue:[ 393293 "Recompute entire size of current row" 393294 spacing == #localSquare 393295 ifTrue:[max := cellMax x max: cellMax y] 393296 ifFalse:[max := cellMax x]. 393297 sum := (n + 1) * max. 393298 ] ifFalse:[ 393299 sum := sum + (cell cellSize x). 393300 ]. 393301 ((sum + (n * inset x)) > wrap and:[first notNil]) ifTrue:[ 393302 "It doesn't fit and we're not starting a new line" 393303 (spacing == #localSquare or:[spacing == #localRect]) ifTrue:[ 393304 spacing == #localSquare 393305 ifTrue:[maxExtent := (maxExtent x max: maxExtent y) asPoint]. 393306 first do:[:c| c cellSize: maxExtent]]. 393307 w := w + ((n - 1) * inset x). 393308 "redistribute extra space" 393309 first nextCell ifNotNil:[first nextCell do:[:c| c addExtraSpace: inset x@0]]. 393310 last := LayoutCell new. 393311 last cellSize: w @ (maxExtent y). 393312 last hSpaceFill: hFill. 393313 last vSpaceFill: vFill. 393314 last nextCell: first. 393315 output position = 0 ifFalse:[last addExtraSpace: 0@inset y]. 393316 output nextPut: last. 393317 first := nil. 393318 maxExtent := 0@0. 393319 sum := 0. 393320 n := 0. 393321 hFill := vFill := false. 393322 ] ifFalse:[ 393323 "It did fit; use next item from input" 393324 first ifNil:[first := last := cell] ifNotNil:[last nextCell: cell. last := cell]. 393325 index := index+1. 393326 n := n + 1. 393327 maxExtent := cellMax. 393328 hFill := hFill or:[cell hSpaceFill]. 393329 vFill := vFill or:[cell vSpaceFill]. 393330 ]. 393331 ]. 393332 first ifNotNil:[ 393333 last := LayoutCell new. 393334 sum := sum + ((n - 1) * inset x). 393335 first nextCell ifNotNil:[first nextCell do:[:c| c addExtraSpace: inset x@0]]. 393336 last cellSize: sum @ maxExtent y. 393337 last hSpaceFill: hFill. 393338 last vSpaceFill: vFill. 393339 last nextCell: first. 393340 output position = 0 ifFalse:[last addExtraSpace: 0@inset y]. 393341 output nextPut: last]. 393342 output := output contents. 393343 properties listSpacing == #equal ifTrue:[ 393344 "Make all the heights equal" 393345 max := output inject: 0 into:[:size :c| size max: c cellSize y]. 393346 output do:[:c| c cellSize: c cellSize x @ max]. 393347 ]. 393348 ^output! ! 393349 393350!TableLayout methodsFor: 'nil' stamp: 'ar 11/14/2000 17:10'! 393351layoutLeftToRight: aMorph in: newBounds 393352 "An optimized left-to-right list layout" 393353 | inset n size extent width height block sum vFill posX posY extra centering extraPerCell last amount minX minY maxX maxY sizeX sizeY first cell props | 393354 size := properties minCellSize asPoint. minX := size x. minY := size y. 393355 size := properties maxCellSize asPoint. maxX := size x. maxY := size y. 393356 inset := properties cellInset asPoint x. 393357 extent := newBounds extent. 393358 n := 0. vFill := false. sum := 0. 393359 width := height := 0. 393360 first := last := nil. 393361 block := [:m| 393362 props := m layoutProperties ifNil:[m]. 393363 props disableTableLayout ifFalse:[ 393364 n := n + 1. 393365 cell := LayoutCell new target: m. 393366 (props hResizing == #spaceFill) ifTrue:[ 393367 cell hSpaceFill: true. 393368 extra := m spaceFillWeight. 393369 cell extraSpace: extra. 393370 sum := sum + extra. 393371 ] ifFalse:[cell hSpaceFill: false]. 393372 (props vResizing == #spaceFill) ifTrue:[vFill := true]. 393373 size := m minExtent. 393374 size := m minExtent. sizeX := size x. sizeY := size y. 393375 sizeX < minX 393376 ifTrue:[sizeX := minX] 393377 ifFalse:[sizeX > maxX ifTrue:[sizeX := maxX]]. 393378 sizeY < minY 393379 ifTrue:[sizeY := minY] 393380 ifFalse:[sizeY > maxY ifTrue:[sizeY := maxY]]. 393381 cell cellSize: sizeX. 393382 last ifNil:[first := cell] ifNotNil:[last nextCell: cell]. 393383 last := cell. 393384 width := width + sizeX. 393385 sizeY > height ifTrue:[height := sizeY]. 393386 ]. 393387 ]. 393388 properties reverseTableCells 393389 ifTrue:[aMorph submorphsReverseDo: block] 393390 ifFalse:[aMorph submorphsDo: block]. 393391 393392 n > 1 ifTrue:[width := width + (n-1 * inset)]. 393393 393394 (properties hResizing == #shrinkWrap and:[properties rubberBandCells or:[sum isZero]]) 393395 ifTrue:[extent := width @ (extent y max: height)]. 393396 (properties vResizing == #shrinkWrap and:[properties rubberBandCells or:[vFill not]]) 393397 ifTrue:[extent := (extent x max: width) @ height]. 393398 393399 posX := newBounds left. 393400 posY := newBounds top. 393401 393402 "Compute extra vertical space" 393403 extra := extent y - height. 393404 extra < 0 ifTrue:[extra := 0]. 393405 extra > 0 ifTrue:[ 393406 vFill ifTrue:[ 393407 height := extent y. 393408 ] ifFalse:[ 393409 centering := properties wrapCentering. 393410 centering == #bottomRight ifTrue:[posY := posY + extra]. 393411 centering == #center ifTrue:[posY := posY + (extra // 2)] 393412 ]. 393413 ]. 393414 393415 393416 "Compute extra horizontal space" 393417 extra := extent x - width. 393418 extra < 0 ifTrue:[extra := 0]. 393419 extraPerCell := 0. 393420 extra > 0 ifTrue:[ 393421 sum isZero ifTrue:["extra space but no #spaceFillers" 393422 centering := properties listCentering. 393423 centering == #bottomRight ifTrue:[posX := posX + extra]. 393424 centering == #center ifTrue:[posX := posX + (extra // 2)]. 393425 ] ifFalse:[extraPerCell := extra asFloat / sum asFloat]. 393426 ]. 393427 393428 n := 0. 393429 extra := last := 0. 393430 cell := first. 393431 [cell == nil] whileFalse:[ 393432 n := n + 1. 393433 width := cell cellSize. 393434 (extraPerCell > 0 and:[cell hSpaceFill]) ifTrue:[ 393435 extra := (last := extra) + (extraPerCell * cell extraSpace). 393436 amount := extra truncated - last truncated. 393437 width := width + amount. 393438 ]. 393439 cell target layoutInBounds: (posX @ posY extent: width @ height). 393440 posX := posX + width + inset. 393441 cell := cell nextCell. 393442 ]. 393443! ! 393444 393445!TableLayout methodsFor: 'nil' stamp: 'ar 11/14/2000 17:12'! 393446layoutTopToBottom: aMorph in: newBounds 393447 "An optimized top-to-bottom list layout" 393448 | inset n size extent width height block sum vFill posX posY extra centering extraPerCell last amount minX minY maxX maxY sizeX sizeY first cell props | 393449 size := properties minCellSize asPoint. minX := size x. minY := size y. 393450 size := properties maxCellSize asPoint. maxX := size x. maxY := size y. 393451 inset := properties cellInset asPoint y. 393452 extent := newBounds extent. 393453 n := 0. vFill := false. sum := 0. 393454 width := height := 0. 393455 first := last := nil. 393456 block := [:m| 393457 props := m layoutProperties ifNil:[m]. 393458 props disableTableLayout ifFalse:[ 393459 n := n + 1. 393460 cell := LayoutCell new target: m. 393461 (props vResizing == #spaceFill) ifTrue:[ 393462 cell vSpaceFill: true. 393463 extra := m spaceFillWeight. 393464 cell extraSpace: extra. 393465 sum := sum + extra. 393466 ] ifFalse:[cell vSpaceFill: false]. 393467 (props hResizing == #spaceFill) ifTrue:[vFill := true]. 393468 size := m minExtent. sizeX := size x. sizeY := size y. 393469 sizeX < minX 393470 ifTrue:[sizeX := minX] 393471 ifFalse:[sizeX > maxX ifTrue:[sizeX := maxX]]. 393472 sizeY < minY 393473 ifTrue:[sizeY := minY] 393474 ifFalse:[sizeY > maxY ifTrue:[sizeY := maxY]]. 393475 cell cellSize: sizeY. 393476 first ifNil:[first := cell] ifNotNil:[last nextCell: cell]. 393477 last := cell. 393478 height := height + sizeY. 393479 sizeX > width ifTrue:[width := sizeX]. 393480 ]. 393481 ]. 393482 properties reverseTableCells 393483 ifTrue:[aMorph submorphsReverseDo: block] 393484 ifFalse:[aMorph submorphsDo: block]. 393485 393486 n > 1 ifTrue:[height := height + (n-1 * inset)]. 393487 393488 (properties vResizing == #shrinkWrap and:[properties rubberBandCells or:[sum isZero]]) 393489 ifTrue:[extent := (extent x max: width) @ height]. 393490 (properties hResizing == #shrinkWrap and:[properties rubberBandCells or:[vFill not]]) 393491 ifTrue:[extent := width @ (extent y max: height)]. 393492 393493 posX := newBounds left. 393494 posY := newBounds top. 393495 393496 "Compute extra horizontal space" 393497 extra := extent x - width. 393498 extra < 0 ifTrue:[extra := 0]. 393499 extra > 0 ifTrue:[ 393500 vFill ifTrue:[ 393501 width := extent x. 393502 ] ifFalse:[ 393503 centering := properties wrapCentering. 393504 centering == #bottomRight ifTrue:[posX := posX + extra]. 393505 centering == #center ifTrue:[posX := posX + (extra // 2)] 393506 ]. 393507 ]. 393508 393509 393510 "Compute extra vertical space" 393511 extra := extent y - height. 393512 extra < 0 ifTrue:[extra := 0]. 393513 extraPerCell := 0. 393514 extra > 0 ifTrue:[ 393515 sum isZero ifTrue:["extra space but no #spaceFillers" 393516 centering := properties listCentering. 393517 centering == #bottomRight ifTrue:[posY := posY + extra]. 393518 centering == #center ifTrue:[posY := posY + (extra // 2)]. 393519 ] ifFalse:[extraPerCell := extra asFloat / sum asFloat]. 393520 ]. 393521 393522 n := 0. 393523 extra := last := 0. 393524 cell := first. 393525 [cell == nil] whileFalse:[ 393526 n := n + 1. 393527 height := cell cellSize. 393528 (extraPerCell > 0 and:[cell vSpaceFill]) ifTrue:[ 393529 extra := (last := extra) + (extraPerCell * cell extraSpace). 393530 amount := extra truncated - last truncated. 393531 height := height + amount. 393532 ]. 393533 cell target layoutInBounds: (posX @ posY extent: width @ height). 393534 posY := posY + height + inset. 393535 cell := cell nextCell. 393536 ].! ! 393537 393538!TableLayout methodsFor: 'nil' stamp: 'ar 1/27/2001 14:42'! 393539minExtentHorizontal: aMorph 393540 "Return the minimal size aMorph's children would require given the new bounds" 393541 | inset n size width height minX minY maxX maxY sizeX sizeY | 393542 size := properties minCellSize asPoint. minX := size x. minY := size y. 393543 size := properties maxCellSize asPoint. maxX := size x. maxY := size y. 393544 inset := properties cellInset asPoint. 393545 n := 0. 393546 width := height := 0. 393547 aMorph submorphsDo:[:m| 393548 m disableTableLayout ifFalse:[ 393549 n := n + 1. 393550 size := m minExtent. sizeX := size x. sizeY := size y. 393551 sizeX < minX 393552 ifTrue:[sizeX := minX] 393553 ifFalse:[sizeX > maxX ifTrue:[sizeX := maxX]]. 393554 sizeY < minY 393555 ifTrue:[sizeY := minY] 393556 ifFalse:[sizeY > maxY ifTrue:[sizeY := maxY]]. 393557 width := width + sizeX. 393558 sizeY > height ifTrue:[height := sizeY]. 393559 ]. 393560 ]. 393561 n > 1 ifTrue:[width := width + (n-1 * inset x)]. 393562 ^minExtentCache := width @ height! ! 393563 393564!TableLayout methodsFor: 'nil' stamp: 'ar 1/27/2001 14:42'! 393565minExtentVertical: aMorph 393566 "Return the minimal size aMorph's children would require given the new bounds" 393567 | inset n size width height minX minY maxX maxY sizeX sizeY | 393568 size := properties minCellSize asPoint. minX := size x. minY := size y. 393569 size := properties maxCellSize asPoint. maxX := size x. maxY := size y. 393570 inset := properties cellInset asPoint. 393571 n := 0. 393572 width := height := 0. 393573 aMorph submorphsDo:[:m| 393574 m disableTableLayout ifFalse:[ 393575 n := n + 1. 393576 size := m minExtent. sizeX := size x. sizeY := size y. 393577 sizeX < minX 393578 ifTrue:[sizeX := minX] 393579 ifFalse:[sizeX > maxX ifTrue:[sizeX := maxX]]. 393580 sizeY < minY 393581 ifTrue:[sizeY := minY] 393582 ifFalse:[sizeY > maxY ifTrue:[sizeY := maxY]]. 393583 height := height + sizeY. 393584 sizeX > width ifTrue:[width := sizeX]. 393585 ]. 393586 ]. 393587 n > 1 ifTrue:[height := height + (n-1 * inset y)]. 393588 ^minExtentCache := width @ height! ! 393589 393590 393591!TableLayout methodsFor: 'testing' stamp: 'ar 10/29/2000 01:29'! 393592isTableLayout 393593 ^true! ! 393594 393595 393596!TableLayout methodsFor: 'utilities' stamp: 'aoy 2/17/2003 01:22'! 393597indexForInserting: aMorph at: aPoint in: owner 393598 "Return the insertion index based on the layout strategy defined for some morph. Used for drop insertion." 393599 393600 | horizontal morphList index | 393601 owner hasSubmorphs ifFalse: [^1]. 393602 aMorph disableTableLayout ifTrue: [^1]. 393603 horizontal := (owner listDirection == #topToBottom 393604 or: [owner listDirection == #bottomToTop]) not . 393605 morphList := owner submorphs. 393606 owner reverseTableCells ifTrue: [morphList := morphList reversed]. 393607 index := self 393608 indexForInserting: aPoint 393609 inList: morphList 393610 horizontal: horizontal 393611 target: owner. 393612 owner reverseTableCells ifTrue: [index := morphList size - index + 2]. 393613 ^index ifNil: [1]! ! 393614 393615!TableLayout methodsFor: 'utilities' stamp: 'aoy 2/17/2003 01:22'! 393616indexForInserting: aPoint inList: morphList horizontal: aBool target: aMorph 393617 | box cmp1 cmp2 cmp3 noWrap | 393618 properties := aMorph layoutProperties. 393619 noWrap := properties wrapDirection == #none. 393620 aBool 393621 ifTrue: 393622 ["horizontal" 393623 393624 properties listDirection == #rightToLeft 393625 ifTrue: [cmp1 := [:rect | aPoint x > rect left]] 393626 ifFalse: [cmp1 := [:rect | aPoint x < rect right]]. 393627 properties wrapDirection == #bottomToTop 393628 ifTrue: 393629 [cmp2 := [:rect | aPoint y > rect top]. 393630 cmp3 := [:rect | aPoint y > rect bottom]] 393631 ifFalse: 393632 [cmp2 := [:rect | aPoint y < rect bottom]. 393633 cmp3 := [:rect | aPoint y < rect top]]] 393634 ifFalse: 393635 ["vertical" 393636 393637 properties listDirection == #bottomToTop 393638 ifTrue: [cmp1 := [:rect | aPoint y > rect top]] 393639 ifFalse: [cmp1 := [:rect | aPoint y < rect bottom]]. 393640 properties wrapDirection == #rightToLeft 393641 ifTrue: 393642 [cmp2 := [:rect | aPoint x > rect left]. 393643 cmp3 := [:rect | aPoint x > rect right]] 393644 ifFalse: 393645 [cmp2 := [:rect | aPoint x < rect right]. 393646 cmp3 := [:rect | aPoint x < rect left]]]. 393647 morphList keysAndValuesDo: 393648 [:index :m | 393649 self flag: #arNote. "it is not quite clear if we can really use #fullBounds here..." 393650 box := m fullBounds. 393651 noWrap 393652 ifTrue: 393653 ["Only in one direction" 393654 393655 (cmp1 value: box) ifTrue: [^index]] 393656 ifFalse: 393657 ["Check for inserting before current row" 393658 393659 (cmp3 value: box) ifTrue: [^index]. 393660 "Check for inserting before current cell" 393661 ((cmp1 value: box) and: [cmp2 value: box]) ifTrue: [^index]]]. 393662 ^morphList size + 1! ! 393663LayoutProperties subclass: #TableLayoutProperties 393664 instanceVariableNames: 'cellInset cellPositioning cellSpacing layoutInset listCentering listDirection listSpacing reverseTableCells rubberBandCells wrapCentering wrapDirection minCellSize maxCellSize' 393665 classVariableNames: '' 393666 poolDictionaries: '' 393667 category: 'Morphic-Layouts'! 393668 393669!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/13/2000 17:57'! 393670cellInset: aNumber 393671 cellInset := aNumber! ! 393672 393673!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:49'! 393674cellPositioning: aSymbol 393675 cellPositioning := aSymbol! ! 393676 393677!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:46'! 393678cellSpacing: aSymbol 393679 cellSpacing := aSymbol.! ! 393680 393681!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 16:37'! 393682layoutInset: aNumber 393683 layoutInset := aNumber! ! 393684 393685!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:46'! 393686listCentering: aSymbol 393687 listCentering := aSymbol! ! 393688 393689!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:46'! 393690listDirection: aSymbol 393691 listDirection := aSymbol.! ! 393692 393693!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:47'! 393694listSpacing: aSymbol 393695 listSpacing := aSymbol! ! 393696 393697!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/13/2000 17:58'! 393698maxCellSize: aNumber 393699 maxCellSize := aNumber.! ! 393700 393701!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/13/2000 17:57'! 393702minCellSize: aNumber 393703 minCellSize := aNumber.! ! 393704 393705!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:47'! 393706reverseTableCells: aBool 393707 reverseTableCells := aBool! ! 393708 393709!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:48'! 393710rubberBandCells: aBool 393711 rubberBandCells := aBool.! ! 393712 393713!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:48'! 393714wrapCentering: aSymbol 393715 wrapCentering := aSymbol! ! 393716 393717!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:48'! 393718wrapDirection: aSymbol 393719 wrapDirection := aSymbol! ! 393720 393721 393722!TableLayoutProperties methodsFor: 'initialize' stamp: 'ar 11/14/2000 17:45'! 393723initialize 393724 super initialize. 393725 cellSpacing := listSpacing := wrapDirection := #none. 393726 cellPositioning := #center. 393727 listCentering := wrapCentering := #topLeft. 393728 listDirection := #topToBottom. 393729 reverseTableCells := rubberBandCells := false. 393730 layoutInset := cellInset := minCellSize := 0. 393731 maxCellSize := 1073741823. "SmallInteger maxVal" 393732! ! 393733 393734 393735!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:45'! 393736cellInset 393737 ^cellInset! ! 393738 393739!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:49'! 393740cellPositioning 393741 ^cellPositioning! ! 393742 393743!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:46'! 393744cellSpacing 393745 ^cellSpacing! ! 393746 393747!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 16:37'! 393748layoutInset 393749 ^layoutInset! ! 393750 393751!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:46'! 393752listCentering 393753 ^listCentering! ! 393754 393755!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:46'! 393756listDirection 393757 ^listDirection! ! 393758 393759!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:47'! 393760listSpacing 393761 ^listSpacing! ! 393762 393763!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:47'! 393764maxCellSize 393765 ^maxCellSize! ! 393766 393767!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:47'! 393768minCellSize 393769 ^minCellSize! ! 393770 393771!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:47'! 393772reverseTableCells 393773 ^reverseTableCells! ! 393774 393775!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:47'! 393776rubberBandCells 393777 ^rubberBandCells! ! 393778 393779!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:48'! 393780wrapCentering 393781 ^wrapCentering! ! 393782 393783!TableLayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:48'! 393784wrapDirection 393785 ^wrapDirection! ! 393786 393787 393788!TableLayoutProperties methodsFor: 'testing' stamp: 'ar 11/13/2000 18:34'! 393789includesTableProperties 393790 ^true! ! 393791Archive subclass: #TarArchive 393792 instanceVariableNames: '' 393793 classVariableNames: '' 393794 poolDictionaries: '' 393795 category: 'Compression-Archives'! 393796!TarArchive commentStamp: '<historical>' prior: 0! 393797This is a kind of archive that uses the TAR format (popular in Unix). It is here as a placeholder.! 393798 393799 393800!TarArchive methodsFor: 'private' stamp: 'nk 2/21/2001 18:27'! 393801memberClass 393802 ^TarArchiveMember! ! 393803ArchiveMember subclass: #TarArchiveMember 393804 instanceVariableNames: '' 393805 classVariableNames: '' 393806 poolDictionaries: '' 393807 category: 'Compression-Archives'! 393808Morph subclass: #TaskbarMorph 393809 instanceVariableNames: 'tasks orderedTasks' 393810 classVariableNames: '' 393811 poolDictionaries: '' 393812 category: 'Polymorph-Widgets'! 393813!TaskbarMorph commentStamp: 'gvc 5/18/2007 11:28' prior: 0! 393814Themed synchronous taskbar (not using #step to poll windows). The buttons provide visual feedback as to whether a window is active or minimised (collapsed) plus a popup menu with options to restore, minimise, maximise and close the associated window. Optional (via Preferences) preview of the window while mouse is over a taskbar button. 393815See the preference browser (PreferenceBrowser open) under "docking bars" for options.! 393816 393817 393818!TaskbarMorph methodsFor: 'accessing' stamp: 'gvc 4/13/2007 13:52'! 393819orderedTasks 393820 "Answer the value of orderedTasks" 393821 393822 ^ orderedTasks! ! 393823 393824!TaskbarMorph methodsFor: 'accessing' stamp: 'gvc 4/13/2007 13:52'! 393825orderedTasks: anObject 393826 "Set the value of orderedTasks" 393827 393828 orderedTasks := anObject! ! 393829 393830!TaskbarMorph methodsFor: 'accessing' stamp: 'gvc 4/13/2007 13:52'! 393831tasks 393832 "Answer the value of tasks" 393833 393834 ^ tasks! ! 393835 393836!TaskbarMorph methodsFor: 'accessing' stamp: 'gvc 4/13/2007 13:52'! 393837tasks: anObject 393838 "Set the value of tasks" 393839 393840 tasks := anObject! ! 393841 393842 393843!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/20/2009 15:03'! 393844buttonForMorph: aMorph 393845 "Answer the button corresonding to the given 393846 morph or nil if none." 393847 393848 |index| 393849 index := (self orderedTasks collect: [:t | t morph]) indexOf: aMorph. 393850 ^index = 0 ifTrue: [nil] ifFalse: [self submorphs at: index ifAbsent: []]! ! 393851 393852!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/16/2007 14:44'! 393853edgeToAdhereTo 393854 "Must implement. Answer #bottom." 393855 393856 ^#bottom! ! 393857 393858!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/16/2007 16:21'! 393859handlesMouseDown: evt 393860 "Best to say we will to avoid being grabbed." 393861 393862 ^true! ! 393863 393864!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/20/2009 15:20'! 393865indicateModalChildForMorph: aMorph 393866 "Flash the button corresonding to the given morph ." 393867 393868 (self buttonForMorph: aMorph) ifNotNilDo: [:b | 393869 b indicateModalChild]! ! 393870 393871!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/13/2007 14:51'! 393872initialize 393873 "Initialize the receiver." 393874 393875 super initialize. 393876 self 393877 initializeLayout; 393878 initializeAppearance; 393879 tasks: #(); 393880 orderedTasks: OrderedCollection new! ! 393881 393882!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 12:14'! 393883initializeAppearance 393884 "Initialize the appearance." 393885 393886 self 393887 color: (Color black alpha: 0.3); 393888 fillStyle: (self theme taskbarFillStyleFor: self)! ! 393889 393890!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/13/2007 15:27'! 393891initializeLayout 393892 "Initialize the layout." 393893 393894 self 393895 changeTableLayout; 393896 layoutInset: 2; 393897 cellInset: 2; 393898 listDirection: #leftToRight; 393899 wrapDirection: #topToBottom; 393900 hResizing: #spaceFill; 393901 vResizing: #shrinkWrap; 393902 extent: self minimumExtent! ! 393903 393904!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/13/2007 13:28'! 393905intoWorld: aWorld 393906 "Stick to the bottom left now." 393907 393908 self 393909 setToAdhereToEdge: #bottomLeft; 393910 updateBounds. 393911 super intoWorld: aWorld! ! 393912 393913!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/13/2007 13:19'! 393914isAdheringToBottom 393915 "Must implement. Answer true." 393916 393917 ^true! ! 393918 393919!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/13/2007 13:17'! 393920isAdheringToLeft 393921 "Must implement. Answer false." 393922 393923 ^false! ! 393924 393925!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/13/2007 13:17'! 393926isAdheringToRight 393927 "Must implement. Answer false." 393928 393929 ^false! ! 393930 393931!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/13/2007 13:17'! 393932isAdheringToTop 393933 "Must implement. Answer false." 393934 393935 ^false! ! 393936 393937!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/13/2007 13:13'! 393938isDockingBar 393939 "Answer yes so we get updated when the Display is resized." 393940 393941 ^true! ! 393942 393943!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2007 10:35'! 393944isTaskbar 393945 "Answer true." 393946 393947 ^true! ! 393948 393949!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/16/2007 12:09'! 393950minimumExtent 393951 "Answer the minimum extent." 393952 393953 ^40@25! ! 393954 393955!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/13/2007 13:34'! 393956morphicLayerNumber 393957 "Helpful for ensuring some morphs always appear in front of or 393958 behind others. Smaller numbers are in front" 393959 393960 ^11! ! 393961 393962!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2007 10:58'! 393963ownerChanged 393964 "The receiver's owner has changed its layout. 393965 Since this method is called synchronously in the 393966 ui, delete the receiver if there are any excpetions." 393967 393968 self owner ifNil: [^self]. 393969 [self updateBounds. 393970 self updateTasks] 393971 on: Exception 393972 do: [:ex | self delete. ex pass]. 393973 super ownerChanged! ! 393974 393975!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/27/2009 13:48'! 393976preferredButtonCornerStyle 393977 "Answer the preferred button corner style 393978 for submorphs." 393979 393980 ^#square! ! 393981 393982!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2007 10:53'! 393983removeFromWorld 393984 "Delete the receiver from its world after restoring minimized tasks. 393985 Collapse those that were minimized after removal. 393986 Turn window animation off for the duration." 393987 393988 |mins animation| 393989 mins := self tasks select: [:t | t isMinimized]. 393990 animation := Preferences windowAnimation. 393991 animation ifTrue: [Preferences setPreference: #windowAnimation toValue: false]. 393992 [mins do: [:t | t morph restore; resetCollapsedFrame]. 393993 self delete. 393994 mins do: [:t | t morph minimize]] 393995 ensure: [animation ifTrue: [Preferences setPreference: #windowAnimation toValue: true]]! ! 393996 393997!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 12:59'! 393998taskButtonOf: aMorph 393999 "Answer the task button of the given morph or nil if none." 394000 394001 ^self submorphs detect: [:t | t model = aMorph] ifNone: []! ! 394002 394003!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 12:58'! 394004taskOf: aMorph 394005 "Answer the task of the given morph or nil if none." 394006 394007 ^self orderedTasks detect: [:t | t morph = aMorph] ifNone: []! ! 394008 394009!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2007 11:28'! 394010themeChanged 394011 "The theme has changed. Update our appearance." 394012 394013 self initializeAppearance. 394014 self removeAllMorphs. 394015 super themeChanged. 394016 self updateTaskButtons! ! 394017 394018!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/16/2007 15:01'! 394019updateBounds 394020 "Update the receiver's bounds to fill the world." 394021 394022 self width: self owner width! ! 394023 394024!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'stephane.ducasse 4/13/2009 21:11'! 394025updateTaskButtons 394026 "Make buttons for the ordered tasks." 394027 394028 |button oldButtons| 394029 oldButtons := self submorphs copy. 394030 self removeAllMorphs. 394031 WorldState addDeferredUIMessage: [oldButtons do: [:b | b model: nil]]. "release dependency after event handling" 394032 self orderedTasks do: [:t | 394033 button := t taskbarButtonFor: self. 394034 button ifNotNil: [self addMorphBack: button]]! ! 394035 394036!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/18/2007 13:05'! 394037updateTasks 394038 "Check for changes in the world's submorphs. 394039 Note that if the task attributes change then a 394040 task will be considered dead along with a new replacement." 394041 394042 |wm deadTasks newTasks| 394043 wm := self worldMorphs. 394044 self tasks: ((wm collect: [:m | m taskbarTask]) select: [:m | m notNil]) asOrderedCollection. 394045 deadTasks := self orderedTasks difference: self tasks. 394046 newTasks := self tasks difference: self orderedTasks. 394047 (newTasks isEmpty and: [deadTasks isEmpty]) 394048 ifTrue: [^self]. "no changes" 394049 newTasks copy do: [:t | 394050 (self orderedTasks detect: [:ot | ot morph = t morph] ifNone: []) ifNotNilDo: [:ot | 394051 self orderedTasks replaceAll: ot with: t. 394052 deadTasks remove: ot. 394053 newTasks remove: t]]. "replace in order any changed tasks." 394054 self orderedTasks 394055 removeAll: deadTasks; 394056 addAll: newTasks reversed. 394057 self updateTaskButtons. 394058 WorldState addDeferredUIMessage: [self layoutChanged] "may have a different number of rows"! ! 394059 394060!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/13/2007 13:30'! 394061wantsToBeTopmost 394062 "Answer if the receiver want to be one of the topmost 394063 objects in its owner." 394064 394065 ^ true! ! 394066 394067!TaskbarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/18/2007 12:39'! 394068worldMorphs 394069 "Answer the world's submorphs plus those in hand. 394070 Nasty case since hand removes the morph before dropping" 394071 394072 ^self world submorphs, 394073 ((self tasks 394074 select: [:t | t morph owner = self world activeHand]) 394075 collect: [:t | t morph])! ! 394076 394077"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 394078 394079TaskbarMorph class 394080 instanceVariableNames: ''! 394081 394082!TaskbarMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 4/25/2007 16:23'! 394083initialize 394084 "Initialize the receiver." 394085 394086 Preferences 394087 addPreference: #showWorldTaskbar 394088 categories: #(#'docking bars' windows) 394089 default: true 394090 balloonHelp: 'Whether the world''s taskbar should be shown or not.' 394091 projectLocal: false 394092 changeInformee: self 394093 changeSelector: #showTaskbarPreferenceChanged; 394094 addPreference: #worldTaskbarWindowPreview 394095 categories: #(#'docking bars' windows) 394096 default: true 394097 balloonHelp: 'Whether the world''s taskbar buttons should show previews of the associated window while the mouse is over them.'. 394098 self showTaskbarPreferenceChanged! ! 394099 394100!TaskbarMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 5/21/2008 17:11'! 394101reset 394102 "Remove the taskbar and add a new one." 394103 394104 (World submorphs select: [:m | m isKindOf: self]) 394105 do: [:tb | tb delete]. 394106 self new openInWorld! ! 394107 394108!TaskbarMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2007 10:46'! 394109showTaskbarPreferenceChanged 394110 "Add or remove the taskbar as appropriate. 394111 Delegate to the current project." 394112 394113 Project current showWorldTaskbar: Preferences showWorldTaskbar! ! 394114Object subclass: #TaskbarTask 394115 instanceVariableNames: 'morph state label icon' 394116 classVariableNames: '' 394117 poolDictionaries: '' 394118 category: 'Polymorph-Widgets'! 394119!TaskbarTask commentStamp: 'gvc 5/18/2007 11:20' prior: 0! 394120Holds the state of a taskbar/tasklist entry.! 394121 394122 394123!TaskbarTask methodsFor: 'accessing' stamp: 'gvc 4/18/2007 12:20'! 394124icon 394125 "Answer the value of icon" 394126 394127 ^ icon! ! 394128 394129!TaskbarTask methodsFor: 'accessing' stamp: 'gvc 4/18/2007 12:20'! 394130icon: anObject 394131 "Set the value of icon" 394132 394133 icon := anObject! ! 394134 394135!TaskbarTask methodsFor: 'accessing' stamp: 'gvc 4/18/2007 12:20'! 394136label 394137 "Answer the value of label" 394138 394139 ^ label! ! 394140 394141!TaskbarTask methodsFor: 'accessing' stamp: 'gvc 4/18/2007 12:20'! 394142label: anObject 394143 "Set the value of label" 394144 394145 label := anObject! ! 394146 394147!TaskbarTask methodsFor: 'accessing' stamp: 'gvc 4/18/2007 12:24'! 394148morph 394149 "Answer the value of morph" 394150 394151 ^ morph! ! 394152 394153!TaskbarTask methodsFor: 'accessing' stamp: 'gvc 4/18/2007 12:24'! 394154morph: anObject 394155 "Set the value of morph" 394156 394157 morph := anObject! ! 394158 394159!TaskbarTask methodsFor: 'accessing' stamp: 'gvc 4/18/2007 12:20'! 394160state 394161 "Answer the value of state" 394162 394163 ^ state! ! 394164 394165!TaskbarTask methodsFor: 'accessing' stamp: 'gvc 4/18/2007 12:20'! 394166state: anObject 394167 "Set the value of state" 394168 394169 state := anObject! ! 394170 394171 394172!TaskbarTask methodsFor: 'as yet unclassified' stamp: 'gvc 7/24/2007 12:18'! 394173= aTaskbarTask 394174 "Answer whether equal." 394175 394176 ^self species = aTaskbarTask species 394177 and: [self morph == aTaskbarTask morph 394178 and: [self state == aTaskbarTask state 394179 and: [self icon = aTaskbarTask icon 394180 and: [self label = aTaskbarTask label]]]]! ! 394181 394182!TaskbarTask methodsFor: 'as yet unclassified' stamp: 'gvc 4/23/2007 14:51'! 394183activate 394184 "Activate the task." 394185 394186 (self morph respondsTo: #restoreAndActivate) 394187 ifTrue: [self morph restoreAndActivate]! ! 394188 394189!TaskbarTask methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:06'! 394190buttonClickedForTasklist: aTasklist 394191 "Notify the tasklist." 394192 394193 aTasklist taskClicked: self! ! 394194 394195!TaskbarTask methodsFor: 'as yet unclassified' stamp: 'gvc 12/12/2007 12:01'! 394196hash 394197 "Hash is implemented because #= is implemented." 394198 394199 ^self morph hash 394200 bitXor: (self state hash 394201 bitXor: (self icon hash 394202 bitXor: self label hash))! ! 394203 394204!TaskbarTask methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 10:49'! 394205isActive 394206 "Answer whether the task is active." 394207 394208 ^self state == #active! ! 394209 394210!TaskbarTask methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 10:25'! 394211isMinimized 394212 "Answer whether the task is minimized." 394213 394214 ^self state == #minimized! ! 394215 394216!TaskbarTask methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 10:21'! 394217taskbarButtonFor: aTaskBar 394218 "Answer a button for the task." 394219 394220 ^self morph taskbarButtonFor: aTaskBar! ! 394221 394222!TaskbarTask methodsFor: 'as yet unclassified' stamp: 'gvc 5/9/2007 15:30'! 394223tasklistButtonFor: aTasklist 394224 "Answer a button for the task." 394225 394226 ^UITheme current 394227 newTasklistButtonIn: aTasklist 394228 for: self! ! 394229 394230"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 394231 394232TaskbarTask class 394233 instanceVariableNames: ''! 394234 394235!TaskbarTask class methodsFor: 'as yet unclassified' stamp: 'gvc 4/18/2007 12:26'! 394236morph: aMorph state: aSymbol icon: aForm label: aString 394237 "Answer a new instance of the receiver with the given parameters." 394238 394239 ^self new 394240 morph: aMorph; 394241 state: aSymbol; 394242 icon: aForm; 394243 label: aString! ! 394244Morph subclass: #TasklistMorph 394245 instanceVariableNames: 'tasks taskList preview' 394246 classVariableNames: '' 394247 poolDictionaries: '' 394248 category: 'Polymorph-Widgets'! 394249!TasklistMorph commentStamp: 'gvc 5/18/2007 11:19' prior: 0! 394250Themed task list/switcher to select the topmost window. Use cmd + left or right arrows (not ideal but the os typically handles cmd + tab/shift-tab). 394251On Linux, release of the command key is not detected (vm issue), so press and release cmd again or move the mouse!!! 394252 394253 394254!TasklistMorph methodsFor: 'accessing' stamp: 'gvc 4/20/2007 11:11'! 394255preview 394256 "Answer the value of preview" 394257 394258 ^ preview! ! 394259 394260!TasklistMorph methodsFor: 'accessing' stamp: 'gvc 4/20/2007 11:11'! 394261preview: anObject 394262 "Set the value of preview" 394263 394264 preview := anObject! ! 394265 394266!TasklistMorph methodsFor: 'accessing' stamp: 'gvc 4/20/2007 10:58'! 394267taskList 394268 "Answer the value of taskList" 394269 394270 ^ taskList! ! 394271 394272!TasklistMorph methodsFor: 'accessing' stamp: 'gvc 4/20/2007 10:58'! 394273taskList: anObject 394274 "Set the value of taskList" 394275 394276 taskList := anObject! ! 394277 394278!TasklistMorph methodsFor: 'accessing' stamp: 'gvc 4/20/2007 10:16'! 394279tasks 394280 "Answer the value of tasks" 394281 394282 ^ tasks! ! 394283 394284!TasklistMorph methodsFor: 'accessing' stamp: 'gvc 4/20/2007 10:16'! 394285tasks: anObject 394286 "Set the value of tasks" 394287 394288 tasks := anObject! ! 394289 394290 394291!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:02'! 394292activeTask 394293 "Answer the active task" 394294 394295 ^self tasks detect: [:t | t isActive] ifNone: []! ! 394296 394297!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:16'! 394298addMorphs 394299 "Add our morphs." 394300 394301 self preview: self newPreviewMorph. 394302 self taskList: self newTasksMorph. 394303 self addMorph: ( 394304 (UITheme current newColumnIn: self for: { 394305 self preview. 394306 self taskList}) 394307 vResizing: #shrinkWrap; 394308 cellInset: 8). 394309 self layoutChanged! ! 394310 394311!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 10:40'! 394312defaultPreviewExtent 394313 "Answer the default extent of the preview holder." 394314 394315 ^320@320! ! 394316 394317!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 14:56'! 394318done 394319 "Close the tasklist and make the active task current." 394320 394321 self delete. 394322 self activeTask activate! ! 394323 394324!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 14:51'! 394325handlesKeyboard: evt 394326 "Yes, we do it here." 394327 394328 ^true! ! 394329 394330!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:12'! 394331initialize 394332 "Initialize the receiver." 394333 394334 super initialize. 394335 self 394336 initializeTasks; 394337 initializeLayout; 394338 initializeAppearance; 394339 addMorphs; 394340 updateButtonsAndPreview; 394341 adoptPaneColor: self color! ! 394342 394343!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/2/2009 12:28'! 394344initializeAppearance 394345 "Initialize the appearance." 394346 394347 self 394348 color: (Color black alpha: 0.5); 394349 fillStyle: (self theme tasklistFillStyleFor: self); 394350 borderStyle: (self theme taskbarThumbnailNormalBorderStyleFor: self); 394351 cornerStyle: (self theme taskbarThumbnailCornerStyleFor: self)! ! 394352 394353!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:13'! 394354initializeLayout 394355 "Initialize the layout." 394356 394357 self 394358 changeTableLayout; 394359 layoutInset: 16; 394360 vResizing: #shrinkWrap; 394361 hResizing: #rigid; 394362 extent: self minimumExtent! ! 394363 394364!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 10:27'! 394365initializeTasks 394366 "Set up the current tasks." 394367 394368 self tasks: ((World submorphs 394369 collect: [:m | m taskbarTask]) 394370 select: [:m | m notNil]) asOrderedCollection! ! 394371 394372!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 15:01'! 394373keyStroke: event 394374 "Process keys to switch task." 394375 394376 event commandKeyPressed ifFalse: [self done]. 394377 event keyCharacter = Character arrowLeft 394378 ifTrue: [^self selectPreviousTask]. 394379 event keyCharacter = Character arrowRight 394380 ifTrue: [^self selectNextTask]! ! 394381 394382!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:14'! 394383minimumExtent 394384 "Answer the minimum extent." 394385 394386 ^self defaultPreviewExtent + 64! ! 394387 394388!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:11'! 394389newPreviewMorph 394390 "Answer a new preview holder." 394391 394392 ^Morph new 394393 color: Color transparent; 394394 extent: self defaultPreviewExtent! ! 394395 394396!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/26/2007 09:45'! 394397newTasksMorph 394398 "Answer a new task list." 394399 394400 ^Morph new 394401 changeTableLayout; 394402 listDirection: #leftToRight; 394403 wrapDirection: #topToBottom; 394404 cellInset: 1; 394405 color: Color transparent; 394406 hResizing: #spaceFill; 394407 vResizing: #shrinkWrap! ! 394408 394409!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:21'! 394410openAsIs 394411 "Open in the world." 394412 394413 self openAsIsIn: self currentWorld! ! 394414 394415!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2007 14:42'! 394416openAsIsIn: aWorld 394417 "Update the layout after opening." 394418 394419 aWorld addMorphCentered: self. 394420 self allMorphs do: [:m | m layoutChanged]. 394421 aWorld startSteppingSubmorphsOf: self. 394422 self wantsKeyboardFocus 394423 ifTrue: [self takeKeyboardFocus]! ! 394424 394425!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:35'! 394426selectNextTask 394427 "Make the next task active." 394428 394429 self selectTask: (self tasks 394430 after: self activeTask 394431 ifAbsent: [self tasks isEmpty 394432 ifFalse: [self tasks first]])! ! 394433 394434!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:35'! 394435selectPreviousTask 394436 "Make the previous task active." 394437 394438 self selectTask: (self tasks 394439 before: self activeTask 394440 ifAbsent: [self tasks isEmpty 394441 ifFalse: [self tasks last]])! ! 394442 394443!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:08'! 394444selectTask: aTask 394445 "Make the given task active and update the buttons." 394446 394447 self tasks do: [:t | t state: #restored]. 394448 aTask state: #active. 394449 self updateButtonsAndPreview! ! 394450 394451!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/25/2008 12:32'! 394452step 394453 "Check the sensor for the command key to see if we're done." 394454 394455 (Preferences keepTasklistOpen not and: [Sensor commandKeyPressed not]) 394456 ifTrue: [self done]! ! 394457 394458!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 14:59'! 394459stepTime 394460 "Check quickly." 394461 394462 ^100! ! 394463 394464!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2007 21:44'! 394465takesKeyboardFocus 394466 "Answer whether the receiver can normally take keyboard focus." 394467 394468 ^true! ! 394469 394470!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/2/2009 12:22'! 394471taskClicked: aTask 394472 "A button for a task has been pressed. 394473 Close after selecting." 394474 394475 self selectTask: aTask. 394476 self done! ! 394477 394478!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:09'! 394479updateButtonsAndPreview 394480 "Update the buttons and the preview.." 394481 394482 self 394483 updateTaskButtons; 394484 updatePreview! ! 394485 394486!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:31'! 394487updatePreview 394488 "Update the preview.." 394489 394490 self preview removeAllMorphs. 394491 self activeTask ifNotNilDo: [:t | 394492 self preview addMorphCentered: (t morph taskThumbnailOfSize: self preview extent)]! ! 394493 394494!TasklistMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/20/2007 11:03'! 394495updateTaskButtons 394496 "Make buttons for the ordered tasks." 394497 394498 |button| 394499 self taskList removeAllMorphs. 394500 self tasks do: [:t | 394501 button := t tasklistButtonFor: self. 394502 button ifNotNil: [self taskList addMorphBack: button]]! ! 394503 394504"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 394505 394506TasklistMorph class 394507 instanceVariableNames: ''! 394508 394509!TasklistMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 1/25/2008 12:35'! 394510initialize 394511 "Initialize the receiver." 394512 394513 Preferences 394514 addPreference: #keepTasklistOpen 394515 categories: #(windows) 394516 default: false 394517 balloonHelp: 'Whether the tasklist is closed (and the selected window activated) when the command key is released'! ! 394518ProtocolClient subclass: #TelnetProtocolClient 394519 instanceVariableNames: 'responseCode' 394520 classVariableNames: '' 394521 poolDictionaries: '' 394522 category: 'Network-Protocols'! 394523!TelnetProtocolClient commentStamp: 'mir 5/12/2003 18:06' prior: 0! 394524Abstract super class for protocol clients based on the generic telnet protocol "<response code> <response>" 394525 394526Structure: 394527 responseCode the numerical (integer) value of the last response code 394528! 394529 394530 394531!TelnetProtocolClient methodsFor: 'accessing' stamp: 'mir 2/22/2002 17:33'! 394532responseCode 394533 ^responseCode! ! 394534 394535 394536!TelnetProtocolClient methodsFor: 'private' stamp: 'mir 2/22/2002 17:34'! 394537determineResponseCode 394538 self lastResponse size >= 3 394539 ifFalse: [^0]. 394540 ^[SmallInteger readFromString: (self lastResponse copyFrom: 1 to: 3)] 394541 on: Error 394542 do: [:ex | ex return: 0]! ! 394543 394544!TelnetProtocolClient methodsFor: 'private' stamp: 'mir 11/14/2002 18:27'! 394545lastResponse: aString 394546 super lastResponse: aString. 394547 responseCode := self determineResponseCode! ! 394548 394549 394550!TelnetProtocolClient methodsFor: 'private protocol' stamp: 'nk 2/24/2005 18:21'! 394551fetchNextResponse 394552 "The FTP and similar protocols allow multi-line responses. 394553 If the response is multi-line, the fourth character of the first line is a 394554 $- and the last line repeats the numeric code but the code is followed by 394555 a space." 394556 394557 | response result firstLine | 394558 result := '' writeStream. 394559 firstLine := self stream nextLine. 394560 result nextPutAll: firstLine. 394561 (self responseIsContinuation: firstLine) 394562 ifTrue: 394563 ["continued over multiple lines. Discard continuation lines." 394564 394565 394566 [response := self stream nextLine. 394567 response ifNil: [^nil]. 394568 response size > 3 and: 394569 [(response copyFrom: 1 to: 3) = (firstLine copyFrom: 1 to: 3) 394570 and: [(response at: 4) = Character space]]] 394571 whileFalse: 394572 [result 394573 cr; 394574 nextPutAll: response]]. 394575 self lastResponse: result contents! ! 394576 394577!TelnetProtocolClient methodsFor: 'private protocol' stamp: 'mir 4/7/2003 15:46'! 394578lookForCode: code 394579 "We are expecting a certain code next." 394580 394581 self 394582 lookForCode: code 394583 ifDifferent: [:response | (TelnetProtocolError protocolInstance: self) signal: response] 394584! ! 394585 394586!TelnetProtocolClient methodsFor: 'private protocol' stamp: 'mir 11/14/2002 16:21'! 394587lookForCode: code ifDifferent: handleBlock 394588 "We are expecting a certain code next." 394589 394590 self fetchNextResponse. 394591 394592 self responseCode == code 394593 ifFalse: [handleBlock value: self lastResponse] 394594! ! 394595 394596 394597!TelnetProtocolClient methodsFor: 'private testing' stamp: 'mir 2/22/2002 17:35'! 394598responseIsContinuation 394599 ^(self lastResponse size > 3 394600 and: [(self lastResponse at: 4) == $-])! ! 394601 394602!TelnetProtocolClient methodsFor: 'private testing' stamp: 'mir 11/14/2002 16:18'! 394603responseIsContinuation: response 394604 ^(response size > 3 394605 and: [(response at: 4) == $-])! ! 394606 394607!TelnetProtocolClient methodsFor: 'private testing' stamp: 'mir 2/22/2002 17:35'! 394608responseIsError 394609 ^self responseCode between: 500 and: 599! ! 394610 394611!TelnetProtocolClient methodsFor: 'private testing' stamp: 'mir 2/22/2002 17:35'! 394612responseIsWarning 394613 ^self responseCode between: 400 and: 499! ! 394614 394615"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 394616 394617TelnetProtocolClient class 394618 instanceVariableNames: ''! 394619 394620!TelnetProtocolClient class methodsFor: 'accessing' stamp: 'mir 2/21/2002 17:21'! 394621rawResponseCodes 394622 self subclassResponsibility! ! 394623ProtocolClientError subclass: #TelnetProtocolError 394624 instanceVariableNames: '' 394625 classVariableNames: '' 394626 poolDictionaries: '' 394627 category: 'Network-Protocols'! 394628!TelnetProtocolError commentStamp: 'mir 5/12/2003 18:07' prior: 0! 394629Abstract super class for exceptions signalled by clients based on the telnet protocol. 394630! 394631 394632 394633!TelnetProtocolError methodsFor: 'accessing' stamp: 'mir 4/7/2003 16:47'! 394634code 394635 ^self protocolInstance responseCode! ! 394636 394637 394638!TelnetProtocolError methodsFor: 'private' stamp: 'len 12/14/2002 14:15'! 394639isCommandUnrecognized 394640 ^ self code = 500! ! 394641VariableNode subclass: #TempVariableNode 394642 instanceVariableNames: 'argType hasRefs hasDefs scope definingScope readingScopes writingScopes remoteNode' 394643 classVariableNames: '' 394644 poolDictionaries: '' 394645 category: 'Compiler-ParseNodes'! 394646!TempVariableNode commentStamp: '<historical>' prior: 0! 394647I am a parse tree leaf representing a temporary variable! 394648 394649 394650!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 8/3/2009 18:54'! 394651addReadWithin: scopeBlock "<BlockNode>" at: location "<Integer>" 394652 readingScopes ifNil: [readingScopes := Dictionary new]. 394653 (readingScopes at: scopeBlock ifAbsentPut: [Set new]) add: location. 394654 remoteNode ifNotNil: 394655 [remoteNode addReadWithin: scopeBlock at: location]! ! 394656 394657!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 8/3/2009 18:55'! 394658addWriteWithin: scopeBlock "<BlockNode>" at: location "<Integer>" 394659 writingScopes ifNil: [writingScopes := Dictionary new]. 394660 (writingScopes at: scopeBlock ifAbsentPut: [Set new]) add: location. 394661 remoteNode ifNotNil: 394662 [remoteNode addReadWithin: scopeBlock at: location]! ! 394663 394664!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2009 15:07'! 394665analyseClosure: rootNode "<MethodNode>" 394666 "Analyse whether the temporary needs to be made remote 394667 or not, and answer whether it was made remote. 394668 A temp cannot be local if it is written to remotely, 394669 or if it is written to after it is closed-over. An exception 394670 is an inlined block argument that appears to be written 394671 remotely but is actually local to a block." 394672 | latestWrite | 394673 self isBlockArg ifTrue: [^false]. 394674 remoteNode ifNotNil: [^false]. "If already remote, don't remote a second time" 394675 latestWrite := 0. 394676 ((writingScopes notNil 394677 and: [writingScopes associations anySatisfy: [:assoc| 394678 [:blockScope :refs| 394679 refs do: [:write| latestWrite := write max: latestWrite]. 394680 "A temp cannot be local if it is written to remotely." 394681 blockScope actualScope ~~ definingScope actualScope] 394682 value: assoc key value: assoc value]]) 394683 or: [readingScopes notNil 394684 and: [readingScopes associations anySatisfy: [:assoc| 394685 [:blockScope :refs| 394686 "A temp cannot be local if it is written to after it is closed-over." 394687 blockScope actualScope ~~ definingScope actualScope 394688 and: [refs anySatisfy: [:read| read < latestWrite]]] 394689 value: assoc key value: assoc value]]]) ifTrue: 394690 [remoteNode := definingScope addRemoteTemp: self rootNode: rootNode. 394691 ^true]. 394692 ^false! ! 394693 394694!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 5/20/2008 10:56'! 394695analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>" 394696 self addReadWithin: scopeBlock at: rootNode locationCounter! ! 394697 394698!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2009 11:46'! 394699beingAssignedToAnalyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>" 394700 self addWriteWithin: scopeBlock at: rootNode locationCounter. 394701 "For analysis of optimized blocks also record the set of temporaries written to 394702 within optimized blocks so that additional writes can be added at locations that 394703 represent subsequent iterations of the loop. e.g. testInlineBlockCollectionSD1" 394704 assignmentPools keysAndValuesDo: 394705 [:outerScopeBlock :set| 394706 "definingScope can be nil in expr in expr ifNil: [:arg|...] expressions because 394707 arg gets its definingScope set when [:arg|...] is analysed." 394708 outerScopeBlock actualScope 394709 = (definingScope 394710 ifNil: [scopeBlock] 394711 ifNotNil: [definingScope actualScope]) ifTrue: 394712 [set add: self]]! ! 394713 394714!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 7/20/2009 16:33'! 394715definingScope 394716 ^definingScope! ! 394717 394718!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 5/30/2008 11:17'! 394719definingScope: scopeBlock "<BlockNode>" 394720 definingScope := scopeBlock! ! 394721 394722!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2009 13:26'! 394723index: anInteger 394724 "For renumbering temps in the closure compiler." 394725 index := anInteger. 394726 code := self code: index type: LdTempType! ! 394727 394728!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 7/20/2009 14:27'! 394729isDefinedWithinBlockExtent: anInterval 394730 ^anInterval rangeIncludes: definingScope actualScope blockExtent first! ! 394731 394732!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 6/2/2008 16:50'! 394733isIndirectTempVector 394734 ^false! ! 394735 394736!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 5/20/2008 18:07'! 394737isReferencedWithinBlockExtent: anInterval 394738 readingScopes ~~ nil ifTrue: 394739 [readingScopes do: 394740 [:set "<Set of <Integer>>"| 394741 set do: 394742 [:location| 394743 (anInterval rangeIncludes: location) ifTrue: 394744 [^true]]]]. 394745 writingScopes ~~ nil ifTrue: 394746 [writingScopes do: 394747 [:set "<Set of <Integer>>"| 394748 set do: 394749 [:location| 394750 (anInterval rangeIncludes: location) ifTrue: 394751 [^true]]]]. 394752 ^false! ! 394753 394754!TempVariableNode methodsFor: 'code generation (closures)' stamp: 'eem 5/20/2008 18:01'! 394755referenceScopesAndIndicesDo: aBinaryBlock 394756 "Evaluate aBinaryBlock with all read or write scopes and locations. 394757 This is used to copy the reference information into RemoteTempVectorNodes" 394758 readingScopes ~~ nil ifTrue: 394759 [readingScopes keysAndValuesDo: 394760 [:scopeBlock "<BlockNode>" :set "<Set of <Integer>>"| 394761 set do: [:location| aBinaryBlock value: scopeBlock value: location]]]. 394762 writingScopes ~~ nil ifTrue: 394763 [writingScopes keysAndValuesDo: 394764 [:scopeBlock "<BlockNode>" :set "<Set of <Integer>>"| 394765 set do: [:location| aBinaryBlock value: scopeBlock value: location]]]! ! 394766 394767 394768!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 16:22'! 394769emitCodeForLoad: stack encoder: encoder 394770 remoteNode ~~ nil ifTrue: 394771 [remoteNode emitCodeForLoadFor: self stack: stack encoder: encoder]! ! 394772 394773!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 14:53'! 394774emitCodeForStore: stack encoder: encoder 394775 remoteNode ~~ nil ifTrue: 394776 [^remoteNode emitCodeForStoreInto: self stack: stack encoder: encoder]. 394777 encoder genStoreTemp: index! ! 394778 394779!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 14:54'! 394780emitCodeForStorePop: stack encoder: encoder 394781 remoteNode ~~ nil ifTrue: 394782 [^remoteNode emitCodeForStorePopInto: self stack: stack encoder: encoder]. 394783 encoder genStorePopTemp: index. 394784 stack pop: 1! ! 394785 394786!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 14:53'! 394787emitCodeForValue: stack encoder: encoder 394788 remoteNode ~~ nil ifTrue: 394789 [^remoteNode emitCodeForValueOf: self stack: stack encoder: encoder]. 394790 encoder genPushTemp: index. 394791 stack push: 1! ! 394792 394793!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 16:23'! 394794sizeCodeForLoad: encoder 394795 ^remoteNode isNil 394796 ifTrue: [0] 394797 ifFalse: [remoteNode sizeCodeForLoadFor: self encoder: encoder]! ! 394798 394799!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 14:52'! 394800sizeCodeForStore: encoder 394801 remoteNode ~~ nil ifTrue: 394802 [^remoteNode sizeCodeForStoreInto: self encoder: encoder]. 394803 self reserve: encoder. 394804 ^encoder sizeStoreTemp: index! ! 394805 394806!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 14:52'! 394807sizeCodeForStorePop: encoder 394808 remoteNode ~~ nil ifTrue: 394809 [^remoteNode sizeCodeForStorePopInto: self encoder: encoder]. 394810 self reserve: encoder. 394811 ^encoder sizeStorePopTemp: index! ! 394812 394813!TempVariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/20/2008 14:51'! 394814sizeCodeForValue: encoder 394815 remoteNode ~~ nil ifTrue: 394816 [^remoteNode sizeCodeForValueOf: self encoder: encoder]. 394817 self reserve: encoder. 394818 ^encoder sizePushTemp: index! ! 394819 394820 394821!TempVariableNode methodsFor: 'debugger access' stamp: 'eem 6/21/2008 13:32'! 394822cleanUpForRegeneration 394823 remoteNode := nil. 394824 definingScope := writingScopes := readingScopes := nil! ! 394825 394826 394827!TempVariableNode methodsFor: 'decompiler' stamp: 'eem 9/25/2008 09:45'! 394828remoteNode: aRemoteTempVectorNode 394829 remoteNode := aRemoteTempVectorNode! ! 394830 394831 394832!TempVariableNode methodsFor: 'initialize-release' stamp: 'eem 9/8/2008 18:27'! 394833name: varName index: i type: type scope: level 394834 "Only used for initting temporary variables" 394835 hasDefs := hasRefs := false. 394836 scope := level. 394837 ^super name: varName key: varName index: i type: type! ! 394838 394839!TempVariableNode methodsFor: 'initialize-release'! 394840nowHasDef 394841 hasDefs := true! ! 394842 394843!TempVariableNode methodsFor: 'initialize-release'! 394844nowHasRef 394845 hasRefs := true! ! 394846 394847!TempVariableNode methodsFor: 'initialize-release'! 394848scope: level 394849 "Note scope of temporary variables. 394850 Currently only the following distinctions are made: 394851 0 outer level: args and user-declared temps 394852 1 block args and doLimiT temps 394853 -1 a block temp that is no longer active 394854 -2 a block temp that held limit of to:do:" 394855 scope := level! ! 394856 394857 394858!TempVariableNode methodsFor: 'printing' stamp: 'eem 7/23/2008 21:21'! 394859printDefinitionForClosureAnalysisOn: aStream 394860 | refs | 394861 aStream 394862 nextPut: ${; 394863 nextPutAll: key. 394864 definingScope ifNotNil: [definingScope blockExtent ifNotNil: [:be| aStream nextPutAll: ' d@'; print: be first]]. 394865 readingScopes notNil ifTrue: 394866 [refs := Set new. 394867 readingScopes do: [:elems| refs addAll: elems]. 394868 refs asSortedCollection do: [:read| aStream nextPutAll: ' r@'; print: read]]. 394869 writingScopes notNil ifTrue: 394870 [refs := Set new. 394871 writingScopes do: [:elems| refs addAll: elems]. 394872 refs asSortedCollection do: [:write| aStream nextPutAll: ' w@'; print: write]]. 394873 aStream nextPut: $}! ! 394874 394875!TempVariableNode methodsFor: 'printing' stamp: 'eem 5/8/2008 11:39'! 394876printOn: aStream indent: level 394877 394878 aStream nextPutAll: name! ! 394879 394880!TempVariableNode methodsFor: 'printing' stamp: 'eem 7/24/2009 12:44'! 394881printWithClosureAnalysisOn: aStream indent: level 394882 394883 aStream nextPutAll: name. 394884 readingScopes notNil ifTrue: 394885 [(readingScopes inject: Set new into: [:them :reads| them addAll: reads. them]) asSortedCollection do: 394886 [:location| 394887 aStream space; nextPut: $r; nextPut: $@; print: location]]. 394888 writingScopes notNil ifTrue: 394889 [(writingScopes inject: Set new into: [:them :writes| them addAll: writes. them]) asSortedCollection do: 394890 [:location| 394891 aStream space; nextPut: $w; nextPut: $@; print: location]]! ! 394892 394893 394894!TempVariableNode methodsFor: 'testing' stamp: 'eem 9/10/2008 10:04'! 394895assignmentCheck: encoder at: location 394896 ^((self isBlockArg and: [Preferences allowBlockArgumentAssignment not]) 394897 or: [self isMethodArg]) 394898 ifTrue: [location] 394899 ifFalse: [-1]! ! 394900 394901!TempVariableNode methodsFor: 'testing' stamp: 'eem 9/8/2008 18:22'! 394902beBlockArg 394903 argType := #block! ! 394904 394905!TempVariableNode methodsFor: 'testing' stamp: 'eem 9/8/2008 18:21'! 394906beMethodArg 394907 argType := #method! ! 394908 394909!TempVariableNode methodsFor: 'testing' stamp: 'eem 9/8/2008 18:24'! 394910isArg 394911 ^argType notNil! ! 394912 394913!TempVariableNode methodsFor: 'testing' stamp: 'eem 9/8/2008 18:20'! 394914isBlockArg 394915 ^#block == argType! ! 394916 394917!TempVariableNode methodsFor: 'testing' stamp: 'eem 9/8/2008 18:20'! 394918isMethodArg 394919 ^#method == argType! ! 394920 394921!TempVariableNode methodsFor: 'testing' stamp: 'eem 5/29/2008 15:51'! 394922isRemote 394923 ^remoteNode notNil! ! 394924 394925!TempVariableNode methodsFor: 'testing'! 394926isTemp 394927 ^ true! ! 394928 394929!TempVariableNode methodsFor: 'testing'! 394930isUndefTemp 394931 ^ hasDefs not! ! 394932 394933!TempVariableNode methodsFor: 'testing'! 394934isUnusedTemp 394935 ^ hasRefs not! ! 394936 394937!TempVariableNode methodsFor: 'testing' stamp: 'eem 5/29/2008 15:51'! 394938remoteNode 394939 ^remoteNode! ! 394940 394941!TempVariableNode methodsFor: 'testing' stamp: 'eem 5/30/2008 12:31'! 394942scope 394943 "Answer scope of temporary variables. 394944 Currently only the following distinctions are made: 394945 0 outer level: args and user-declared temps 394946 1 block args and doLimiT temps 394947 -1 a block temp that is no longer active 394948 -2 a block temp that held limit of to:do:" 394949 ^scope! ! 394950 394951 394952!TempVariableNode methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:51'! 394953accept: aVisitor 394954 aVisitor visitTempVariableNode: self! ! 394955Object subclass: #TestCase 394956 instanceVariableNames: 'testSelector' 394957 classVariableNames: '' 394958 poolDictionaries: '' 394959 category: 'SUnit-Kernel'! 394960!TestCase commentStamp: '<historical>' prior: 0! 394961A TestCase is a Command representing the future running of a test case. Create one with the class method #selector: aSymbol, passing the name of the method to be run when the test case runs. 394962 394963When you discover a new fixture, subclass TestCase, declare instance variables for the objects in the fixture, override #setUp to initialize the variables, and possibly override# tearDown to deallocate any external resources allocated in #setUp. 394964 394965When you are writing a test case method, send #assert: aBoolean when you want to check for an expected value. For example, you might say "self assert: socket isOpen" to test whether or not a socket is open at a point in a test.! 394966 394967 394968!TestCase methodsFor: 'accessing' stamp: 'md 8/2/2006 10:59'! 394969assert: aBooleanOrBlock 394970 394971 aBooleanOrBlock value ifFalse: [self signalFailure: 'Assertion failed'] 394972 ! ! 394973 394974!TestCase methodsFor: 'accessing' stamp: 'md 8/2/2006 11:00'! 394975assert: aBooleanOrBlock description: aString 394976 aBooleanOrBlock value ifFalse: [ 394977 self logFailure: aString. 394978 TestResult failure signal: aString] 394979 ! ! 394980 394981!TestCase methodsFor: 'accessing' stamp: 'md 8/2/2006 11:00'! 394982assert: aBooleanOrBlock description: aString resumable: resumableBoolean 394983 | exception | 394984 aBooleanOrBlock value 394985 ifFalse: 394986 [self logFailure: aString. 394987 exception := resumableBoolean 394988 ifTrue: [TestResult resumableFailure] 394989 ifFalse: [TestResult failure]. 394990 exception signal: aString] 394991 ! ! 394992 394993!TestCase methodsFor: 'accessing' stamp: 'dc 4/2/2007 18:38'! 394994assert: expected equals: actual 394995 ^ self 394996 assert: (expected = actual) 394997 description: (self comparingStringBetween: expected and: actual) 394998! ! 394999 395000!TestCase methodsFor: 'accessing' stamp: 'md 8/2/2006 11:00'! 395001deny: aBooleanOrBlock 395002 395003 self assert: aBooleanOrBlock value not 395004 ! ! 395005 395006!TestCase methodsFor: 'accessing' stamp: 'md 8/2/2006 11:00'! 395007deny: aBooleanOrBlock description: aString 395008 self assert: aBooleanOrBlock value not description: aString 395009 ! ! 395010 395011!TestCase methodsFor: 'accessing' stamp: 'md 8/2/2006 11:00'! 395012deny: aBooleanOrBlock description: aString resumable: resumableBoolean 395013 self 395014 assert: aBooleanOrBlock value not 395015 description: aString 395016 resumable: resumableBoolean 395017 ! ! 395018 395019!TestCase methodsFor: 'accessing'! 395020resources 395021 | allResources resourceQueue | 395022 allResources := Set new. 395023 resourceQueue := OrderedCollection new. 395024 resourceQueue addAll: self class resources. 395025 [resourceQueue isEmpty] whileFalse: [ 395026 | next | 395027 next := resourceQueue removeFirst. 395028 allResources add: next. 395029 resourceQueue addAll: next resources]. 395030 ^allResources 395031 ! ! 395032 395033!TestCase methodsFor: 'accessing'! 395034selector 395035 ^testSelector 395036 ! ! 395037 395038!TestCase methodsFor: 'accessing'! 395039should: aBlock 395040 self assert: aBlock value 395041 ! ! 395042 395043!TestCase methodsFor: 'accessing'! 395044should: aBlock description: aString 395045 self assert: aBlock value description: aString 395046 ! ! 395047 395048!TestCase methodsFor: 'accessing'! 395049should: aBlock raise: anExceptionalEvent 395050 ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) 395051 ! ! 395052 395053!TestCase methodsFor: 'accessing'! 395054should: aBlock raise: anExceptionalEvent description: aString 395055 ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) 395056 description: aString 395057 ! ! 395058 395059!TestCase methodsFor: 'accessing' stamp: 'nk 5/11/2003 10:32'! 395060should: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString 395061 ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) 395062 description: aString 395063! ! 395064 395065!TestCase methodsFor: 'accessing' stamp: 'nk 5/11/2003 10:24'! 395066should: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString 395067 ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) 395068 description: aString 395069! ! 395070 395071!TestCase methodsFor: 'accessing'! 395072shouldnt: aBlock 395073 self deny: aBlock value 395074 ! ! 395075 395076!TestCase methodsFor: 'accessing'! 395077shouldnt: aBlock description: aString 395078 self deny: aBlock value description: aString 395079 ! ! 395080 395081!TestCase methodsFor: 'accessing'! 395082shouldnt: aBlock raise: anExceptionalEvent 395083 ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not 395084 ! ! 395085 395086!TestCase methodsFor: 'accessing'! 395087shouldnt: aBlock raise: anExceptionalEvent description: aString 395088 ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not description: aString 395089 ! ! 395090 395091!TestCase methodsFor: 'accessing' stamp: 'nk 5/11/2003 10:34'! 395092shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString 395093 ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) not 395094 description: aString 395095! ! 395096 395097!TestCase methodsFor: 'accessing' stamp: 'nk 5/11/2003 10:34'! 395098shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString 395099 ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) not 395100 description: aString 395101! ! 395102 395103!TestCase methodsFor: 'accessing' stamp: 'md 2/22/2006 14:26'! 395104signalFailure: aString 395105 TestResult failure signal: aString! ! 395106 395107 395108!TestCase methodsFor: 'dependencies'! 395109addDependentToHierachy: anObject 395110 "an empty method. for Composite compability with TestSuite" 395111 395112 395113 ! ! 395114 395115!TestCase methodsFor: 'dependencies'! 395116removeDependentFromHierachy: anObject 395117 "an empty method. for Composite compability with TestSuite" 395118 395119 395120 ! ! 395121 395122 395123!TestCase methodsFor: 'extensions' stamp: 'mx 3/20/2006 23:32'! 395124executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock 395125 395126 ^[aBlock value. 395127 false] 395128 on: anException 395129 do: [:exception | 395130 anotherBlock value: exception. 395131 exception return: true]! ! 395132 395133!TestCase methodsFor: 'extensions' stamp: 'mx 3/13/2006 23:21'! 395134fail 395135 395136 ^self assert: false! ! 395137 395138!TestCase methodsFor: 'extensions' stamp: 'md 8/2/2006 11:09'! 395139should: aBlock notTakeMoreThan: aDuration 395140 "Evaluate aBlock in a forked process and if it takes more than anInteger milliseconds 395141 to run we terminate the process and report a test failure. It'' important to 395142 use the active process for the test failure so that the failure reporting works correctly 395143 in the context of the exception handlers." 395144 395145 | evaluated evaluationProcess result delay testProcess | 395146 395147 evaluated := false. 395148 delay := Delay forDuration: aDuration. 395149 testProcess := Processor activeProcess. 395150 "Create a new process to evaluate aBlock" 395151 evaluationProcess := [ 395152 result := aBlock value. 395153 evaluated := true. 395154 delay unschedule. 395155 testProcess resume ] forkNamed: 'Process to evaluate should: notTakeMoreThanMilliseconds:'. 395156 395157 "Wait the milliseconds they asked me to" 395158 delay wait. 395159 "After this point either aBlock was evaluated or not..." 395160 evaluated ifFalse: [ 395161 evaluationProcess terminate. 395162 self assert: false description: ('Block evaluation took more than the expected <1p>' expandMacrosWith: aDuration)]. 395163 395164 ^result! ! 395165 395166!TestCase methodsFor: 'extensions' stamp: 'mx 3/20/2006 21:29'! 395167shouldFix: aBlock 395168 395169 ^self should: aBlock raise: Exception! ! 395170 395171!TestCase methodsFor: 'extensions' stamp: 'md 8/2/2006 11:08'! 395172should: aBlock notTakeMoreThanMilliseconds: anInteger 395173 "For compatibility with other Smalltalks" 395174 395175 self should: aBlock notTakeMoreThan: (Duration milliSeconds: anInteger).! ! 395176 395177!TestCase methodsFor: 'extensions' stamp: 'mx 3/20/2006 23:52'! 395178should: aBlock raise: anException withExceptionDo: anotherBlock 395179 395180 ^self assert: (self executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock)! ! 395181 395182 395183!TestCase methodsFor: 'printing'! 395184printOn: aStream 395185 395186 aStream 395187 nextPutAll: self class printString; 395188 nextPutAll: '>>#'; 395189 nextPutAll: testSelector 395190 ! ! 395191 395192 395193!TestCase methodsFor: 'running' stamp: 'md 2/22/2006 14:27'! 395194debug 395195 self resources do: [:res | 395196 res isAvailable ifFalse: [^res signalInitializationError]]. 395197 [(self class selector: testSelector) runCase] 395198 ensure: [self resources do: [:each | each reset]] 395199 ! ! 395200 395201!TestCase methodsFor: 'running' stamp: 'bp 11/15/2004 18:13'! 395202debugAsFailure 395203 | semaphore | 395204 semaphore := Semaphore new. 395205 self resources do: [:res | 395206 res isAvailable ifFalse: [^res signalInitializationError]]. 395207 [semaphore wait. self resources do: [:each | each reset]] fork. 395208 (self class selector: testSelector) runCaseAsFailure: semaphore.! ! 395209 395210!TestCase methodsFor: 'running' stamp: 'md 2/22/2006 14:17'! 395211failureLog 395212 ^Transcript 395213 395214 ! ! 395215 395216!TestCase methodsFor: 'running'! 395217isLogging 395218 "By default, we're not logging failures. If you override this in 395219 a subclass, make sure that you override #failureLog" 395220 ^false 395221 ! ! 395222 395223!TestCase methodsFor: 'running'! 395224logFailure: aString 395225 self isLogging ifTrue: [ 395226 self failureLog 395227 cr; 395228 nextPutAll: aString; 395229 flush] 395230 ! ! 395231 395232!TestCase methodsFor: 'running' stamp: 'bp 11/15/2004 18:17'! 395233openDebuggerOnFailingTestMethod 395234 "SUnit has halted one step in front of the failing test method. Step over the 'self halt' and 395235 send into 'self perform: testSelector' to see the failure from the beginning" 395236 395237 self 395238 halt; 395239 performTest! ! 395240 395241!TestCase methodsFor: 'running'! 395242run 395243 | result | 395244 result := TestResult new. 395245 self run: result. 395246 ^result 395247 ! ! 395248 395249!TestCase methodsFor: 'running' stamp: 'GwenaelCasaccio 10/1/2008 19:58'! 395250run: aResult 395251 aResult runCase: self. 395252! ! 395253 395254!TestCase methodsFor: 'running' stamp: 'AdrianLienhard 10/19/2009 10:30'! 395255runCase 395256 Author 395257 useAuthor: 'TestRunner' 395258 during: [ 395259 [self setUp. 395260 self performTest] 395261 ensure: [ 395262 self tearDown. 395263 self cleanUpInstanceVariables ] ]! ! 395264 395265!TestCase methodsFor: 'running' stamp: 'md 2/22/2006 14:27'! 395266runCaseAsFailure: aSemaphore 395267 [self setUp. 395268 self openDebuggerOnFailingTestMethod] ensure: [ 395269 self tearDown. 395270 aSemaphore signal]! ! 395271 395272!TestCase methodsFor: 'running' stamp: 'DavidRoethlisberger 11/10/2008 09:54'! 395273setUp! ! 395274 395275!TestCase methodsFor: 'running' stamp: 'DavidRoethlisberger 11/10/2008 09:54'! 395276tearDown! ! 395277 395278 395279!TestCase methodsFor: 'testing' stamp: 'JF 7/30/2003 13:40'! 395280expectedFailures 395281 ^ Array new! ! 395282 395283!TestCase methodsFor: 'testing' stamp: 'JF 7/30/2003 13:39'! 395284shouldPass 395285 "Unless the selector is in the list we get from #expectedFailures, we expect it to pass" 395286 ^ (self expectedFailures includes: testSelector) not! ! 395287 395288 395289!TestCase methodsFor: 'private' stamp: 'AdrianLienhard 10/19/2009 12:07'! 395290cleanUpInstanceVariables 395291 self class allInstVarNames do: [ :name | 395292 name = 'testSelector' ifFalse: [ 395293 self instVarNamed: name put: nil ] ]! ! 395294 395295!TestCase methodsFor: 'private' stamp: 'dc 4/2/2007 18:46'! 395296comparingStringBetween: expected and: actual 395297 ^ String streamContents: [:stream | 395298 stream 395299 nextPutAll: 'Expected '; 395300 nextPutAll: (expected printStringLimitedTo: 10); 395301 nextPutAll: ' but was '; 395302 nextPutAll: (actual printStringLimitedTo: 10); 395303 nextPutAll: '.' 395304 ]! ! 395305 395306!TestCase methodsFor: 'private' stamp: 'md 2/22/2006 14:27'! 395307executeShould: aBlock inScopeOf: anExceptionalEvent 395308 ^[aBlock value. 395309 false] on: anExceptionalEvent 395310 do: [:ex | ex return: true] 395311 ! ! 395312 395313!TestCase methodsFor: 'private' stamp: 'md 2/22/2006 14:27'! 395314executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: aString 395315 ^[aBlock value. 395316 false] on: anExceptionalEvent 395317 do: [:ex | ex return: (ex description includesSubString: aString) ] 395318 ! ! 395319 395320!TestCase methodsFor: 'private' stamp: 'md 2/22/2006 14:27'! 395321executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: aString 395322 ^[aBlock value. 395323 false] on: anExceptionalEvent 395324 do: [:ex | ex return: (ex description includesSubString: aString) not ] 395325 ! ! 395326 395327!TestCase methodsFor: 'private' stamp: 'md 2/22/2006 14:22'! 395328performTest 395329 395330 self perform: testSelector asSymbol 395331 ! ! 395332 395333!TestCase methodsFor: 'private'! 395334setTestSelector: aSymbol 395335 testSelector := aSymbol 395336 ! ! 395337 395338"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 395339 395340TestCase class 395341 instanceVariableNames: 'history'! 395342 395343!TestCase class methodsFor: '*sunitgui' stamp: 'lr 4/12/2009 00:27'! 395344packageNamesUnderTest 395345 "Answer a collection of package names under test. This is used by the test runner to automatically instrument the code in these packages when checking for test coverage." 395346 395347 ^ #()! ! 395348 395349 395350!TestCase class methodsFor: 'accessing' stamp: 'md 2/22/2006 14:28'! 395351allTestSelectors 395352 395353 ^self allSelectors asSortedCollection asOrderedCollection select: [:each | 395354 ('test*' match: each) and: [each numArgs isZero]] 395355 ! ! 395356 395357!TestCase class methodsFor: 'accessing'! 395358resources 395359 395360 ^#() 395361 ! ! 395362 395363!TestCase class methodsFor: 'accessing'! 395364sunitVersion 395365 ^'3.1' 395366 ! ! 395367 395368!TestCase class methodsFor: 'accessing' stamp: 'md 2/22/2006 14:29'! 395369testSelectors 395370 395371 ^self selectors asSortedCollection asOrderedCollection select: [:each | 395372 ('test*' match: each) and: [each numArgs isZero]] 395373 ! ! 395374 395375 395376!TestCase class methodsFor: 'building suites' stamp: 'stephaneducasse 2/3/2006 22:41'! 395377addTestsFor: classNameString toSuite: suite 395378 395379 | cls | 395380 cls := Smalltalk at: classNameString ifAbsent: [ ^suite ]. 395381 ^cls isAbstract 395382 ifTrue: [ 395383 cls allSubclasses do: [ :each | 395384 each isAbstract ifFalse: [ 395385 each addToSuiteFromSelectors: suite ] ]. 395386 suite] 395387 ifFalse: [ cls addToSuiteFromSelectors: suite ] 395388! ! 395389 395390!TestCase class methodsFor: 'building suites' stamp: 'nk 4/21/2002 16:37'! 395391addToSuiteFromSelectors: suite 395392 ^self addToSuite: suite fromMethods: (self shouldInheritSelectors 395393 ifTrue: [ self allTestSelectors ] 395394 ifFalse: [self testSelectors ])! ! 395395 395396!TestCase class methodsFor: 'building suites' stamp: 'nk 4/21/2002 10:51'! 395397addToSuite: suite fromMethods: testMethods 395398 testMethods do: [ :selector | 395399 suite addTest: (self selector: selector) ]. 395400 ^suite! ! 395401 395402!TestCase class methodsFor: 'building suites' stamp: 'stephaneducasse 2/3/2006 22:41'! 395403buildSuite 395404 | suite | 395405 suite := TestSuite new. 395406 ^ self isAbstract 395407 ifTrue: [ 395408 suite name: self name asString. 395409 self allSubclasses 395410 do: [:each | each isAbstract 395411 ifFalse: [each addToSuiteFromSelectors: suite]]. 395412 suite] 395413 ifFalse: [self addToSuiteFromSelectors: suite]! ! 395414 395415!TestCase class methodsFor: 'building suites'! 395416buildSuiteFromAllSelectors 395417 395418 ^self buildSuiteFromMethods: self allTestSelectors 395419 ! ! 395420 395421!TestCase class methodsFor: 'building suites'! 395422buildSuiteFromLocalSelectors 395423 395424 ^self buildSuiteFromMethods: self testSelectors 395425 ! ! 395426 395427!TestCase class methodsFor: 'building suites' stamp: 'stephaneducasse 2/3/2006 22:41'! 395428buildSuiteFromMethods: testMethods 395429 | suite | 395430 suite := (TestSuite new) 395431 name: self name asString; 395432 yourself. 395433 ^self addToSuite: suite fromMethods: testMethods! ! 395434 395435!TestCase class methodsFor: 'building suites'! 395436buildSuiteFromSelectors 395437 395438 ^self shouldInheritSelectors 395439 ifTrue: [self buildSuiteFromAllSelectors] 395440 ifFalse: [self buildSuiteFromLocalSelectors] 395441 ! ! 395442 395443!TestCase class methodsFor: 'building suites'! 395444suiteClass 395445 ^TestSuite 395446 ! ! 395447 395448 395449!TestCase class methodsFor: 'coverage' stamp: 'sd 1/28/2009 14:04'! 395450coverage 395451 "returns the coverage determined by a simple static analysis of test coverage 395452 made by the receiver on a class that is identified by the name of the receiver. 395453 We assume that SetTest test Set." 395454 395455 | cls className | 395456 (self name endsWith: 'Test') ifFalse: [self error: 'Please, use #coverageForClass: instead']. 395457 395458 className := self name copyFrom: 1 to: (self name size - 'Test' size). 395459 cls := Smalltalk at: className asSymbol ifAbsent: [self error: 'Please, use #coverageForClass: instead']. 395460 395461 "May happen with Transcript" 395462 cls isBehavior ifFalse: [cls := cls class]. 395463 395464 ^ self coverageForClass: cls! ! 395465 395466!TestCase class methodsFor: 'coverage' stamp: 'ab 12/25/2008 17:20'! 395467coverageAsString 395468 | cov className | 395469 cov := self coverage first asInteger. 395470 "coverage already checks that the name is ends with 'Test' and if the class tested exists" 395471 395472 className := self name copyFrom: 1 to: (self name size - 'Test' size). 395473 ^ self name asString, ' covers ', cov asString, '% of ', className.! ! 395474 395475!TestCase class methodsFor: 'coverage' stamp: 'sd 1/28/2009 14:57'! 395476coverageForClass: cls 395477 "returns the test coverage of all the methods included inherited ones" 395478 ^ self coverageForClass: cls until: ProtoObject! ! 395479 395480!TestCase class methodsFor: 'coverage' stamp: 'sd 1/28/2009 14:58'! 395481coverageForClass: cls until: aRootClass 395482 "returns the test coverage of all the methods included inherited ones but stopping at aRootClass included" 395483 395484 | definedMethods testedMethods untestedMethods | 395485 definedMethods := cls allSelectorsAboveUntil: aRootClass. 395486 definedMethods size = 0 395487 ifTrue: [^ {0. Set new}]. 395488 testedMethods := 395489 self methodDictionary values inject: Set new into: 395490 [:sums :cm | sums union: cm messages]. 395491 testedMethods := testedMethods reject: [:sel | (definedMethods includes: sel) not]. 395492 untestedMethods := definedMethods select: [:selector | (testedMethods includes: selector) not]. 395493 ^ { (testedMethods size * 100 / definedMethods size) asFloat . untestedMethods} 395494! ! 395495 395496!TestCase class methodsFor: 'coverage' stamp: 'ab 12/25/2008 17:15'! 395497coveragePercentage 395498 ^ self coverage first! ! 395499 395500!TestCase class methodsFor: 'coverage' stamp: 'sd 1/28/2009 15:03'! 395501localCoverage 395502 "returns the coverage determined by a simple static analysis of test coverage 395503 made by the receiver on a class that is identified by the name of the receiver. 395504 We assume that SetTest test Set. The computation of the coverage takes only into 395505 account the methods defined locally in the tested class. See coverage for a more global 395506 coverage" 395507 395508 | cls className | 395509 (self name endsWith: 'Test') ifFalse: [self error: 'Please, use #localCoverageForClass: instead']. 395510 className := self name copyFrom: 1 to: (self name size - 'Test' size). 395511 cls := Smalltalk at: className asSymbol ifAbsent: [self error: 'Please, use #localCoverageForClass: instead']. 395512 cls isBehavior ifFalse: [cls := cls class]. 395513 ^ self localCoverageForClass: cls! ! 395514 395515!TestCase class methodsFor: 'coverage' stamp: 'sd 1/28/2009 15:04'! 395516localCoverageAsString 395517 | cov className | 395518 cov := self localCoverage first asInteger. 395519 "coverage already checks that the name is ends with 'Test' and if the class tested exists" 395520 395521 className := self name copyFrom: 1 to: (self name size - 'Test' size). 395522 ^ self name asString, ' covers ', cov asString, '% of ', className.! ! 395523 395524!TestCase class methodsFor: 'coverage' stamp: 'sd 1/28/2009 14:55'! 395525localCoverageForClass: cls 395526 395527 | definedMethods testedMethods untestedMethods | 395528 definedMethods := cls selectors. 395529 "It happens for IdentityBag / IdentityBagTest" 395530 definedMethods size = 0 395531 ifTrue: [^ {0. Set new}]. 395532 395533 testedMethods := 395534 self methodDictionary values inject: Set new into: 395535 [:sums :cm | sums union: cm messages]. 395536 395537 "testedMethods contains all the methods send in test methods, which probably contains methods that have nothign to do with collection" 395538 testedMethods := testedMethods reject: [:sel | (definedMethods includes: sel) not]. 395539 395540 untestedMethods := definedMethods select: [:selector | (testedMethods includes: selector) not]. 395541 395542 ^ { (testedMethods size * 100 / definedMethods size) asFloat . untestedMethods} 395543! ! 395544 395545!TestCase class methodsFor: 'coverage' stamp: 'sd 1/28/2009 14:55'! 395546localCoveragePercentage 395547 ^ self localCoverage first! ! 395548 395549 395550!TestCase class methodsFor: 'history' stamp: 'simon.denier 11/13/2008 19:22'! 395551generateLastStoredRunMethod 395552 395553 self shouldGenerateLastStoredRunMethod ifTrue: [ 395554 self class 395555 compile: (self lastRunMethodNamed: #lastStoredRun) 395556 classified: 'history' ]! ! 395557 395558!TestCase class methodsFor: 'history' stamp: 'Alexandre.Bergel 4/3/2009 14:57'! 395559history 395560 ^ history ifNil: [ history := self newTestDictionary ]! ! 395561 395562!TestCase class methodsFor: 'history' stamp: 'Alexandre.Bergel 4/3/2009 14:45'! 395563history: aDictionary 395564 history := aDictionary! ! 395565 395566!TestCase class methodsFor: 'history' stamp: 'simon.denier 11/22/2008 20:56'! 395567lastRun 395568 ^ TestResult historyFor: self! ! 395569 395570!TestCase class methodsFor: 'history' stamp: 'simon.denier 11/13/2008 19:21'! 395571lastRunMethodNamed: aSelector 395572 395573 ^ String streamContents: [:str | 395574 str nextPutAll: aSelector asString ;cr. 395575 str tab; nextPutAll: '^ ', (self lastRun) storeString] 395576! ! 395577 395578!TestCase class methodsFor: 'history' stamp: 'AlexandreBergel 10/22/2008 10:33'! 395579lastStoredRun 395580 ^ ((Dictionary new) add: (#failures->#()); add: (#passed->#()); add: (#errors->#()); yourself)! ! 395581 395582!TestCase class methodsFor: 'history' stamp: 'Alexandre.Bergel 4/3/2009 14:57'! 395583newTestDictionary 395584 395585 ^ Dictionary new at: #timeStamp put: TimeStamp now; 395586 at: #passed put: Set new; 395587 at: #failures put: Set new; 395588 at: #errors put: Set new; 395589 yourself 395590 ! ! 395591 395592!TestCase class methodsFor: 'history' stamp: 'Alexandre.Bergel 4/3/2009 14:47'! 395593resetHistory 395594 history := nil! ! 395595 395596!TestCase class methodsFor: 'history' stamp: 'simon.denier 11/13/2008 21:29'! 395597shouldGenerateLastStoredRunMethod 395598 | sameRun | 395599 395600 (self class methodDictionary includesKey: #lastStoredRun) 395601 ifFalse: [^ true]. 395602 sameRun := #(#passed #failures #errors) inject: true into: 395603 [ :ok :set | ok and: [(self lastRun at: set) = (self lastStoredRun at: set) ]]. 395604 ^ sameRun not 395605! ! 395606 395607 395608!TestCase class methodsFor: 'initialize - event' stamp: 'AlexandreBergel 10/22/2008 13:31'! 395609initialize 395610 super initialize. 395611 SystemChangeNotifier uniqueInstance notify: self ofSystemChangesOfItem: #method using: #methodChanged:.! ! 395612 395613!TestCase class methodsFor: 'initialize - event' stamp: 'al 2/9/2009 20:00'! 395614methodChanged: anEvent 395615 "Remove the changed method from the known test results." 395616 395617 | cls sel | 395618 anEvent item isCompiledMethod ifFalse: [ ^ self ]. 395619 cls := anEvent item methodClass. 395620 (cls inheritsFrom: TestCase) 395621 ifFalse: [^ self]. 395622 sel := anEvent item selector. 395623 (sel beginsWith: 'test') 395624 ifFalse: [^ self]. 395625 TestResult removeFromTestHistory: sel in: cls. 395626! ! 395627 395628 395629!TestCase class methodsFor: 'instance creation'! 395630debug: aSymbol 395631 395632 ^(self selector: aSymbol) debug 395633 ! ! 395634 395635!TestCase class methodsFor: 'instance creation'! 395636run: aSymbol 395637 395638 ^(self selector: aSymbol) run 395639 ! ! 395640 395641!TestCase class methodsFor: 'instance creation'! 395642selector: aSymbol 395643 395644 ^self new setTestSelector: aSymbol 395645 ! ! 395646 395647!TestCase class methodsFor: 'instance creation'! 395648suite 395649 395650 ^self buildSuite 395651 ! ! 395652 395653 395654!TestCase class methodsFor: 'testing' stamp: 'Alexandre.Bergel 4/3/2009 15:06'! 395655hasMethodBeenRun: aSelector 395656 ^ ((self lastRun at: #errors), 395657 (self lastRun at: #failures), 395658 (self lastRun at: #passed)) 395659 includes: aSelector! ! 395660 395661!TestCase class methodsFor: 'testing' stamp: 'md 2/22/2006 14:21'! 395662isAbstract 395663 "Override to true if a TestCase subclass is Abstract and should not have 395664 TestCase instances built from it" 395665 395666 ^self name = #TestCase 395667 ! ! 395668 395669!TestCase class methodsFor: 'testing' stamp: 'AlexandreBergel 10/21/2008 15:58'! 395670methodFailed: aSelector 395671 ^ (self lastRun at: #failures) includes: aSelector! ! 395672 395673!TestCase class methodsFor: 'testing' stamp: 'AlexandreBergel 10/21/2008 16:00'! 395674methodPassed: aSelector 395675 ^ (self lastRun at: #passed) includes: aSelector! ! 395676 395677!TestCase class methodsFor: 'testing' stamp: 'AlexandreBergel 10/21/2008 16:00'! 395678methodProgressed: aSelector 395679 ^ ((self storedMethodRaisedError: aSelector) or: [self storedMethodFailed: aSelector]) 395680 and: [self methodPassed: aSelector] 395681 ! ! 395682 395683!TestCase class methodsFor: 'testing' stamp: 'AlexandreBergel 10/21/2008 16:00'! 395684methodRaisedError: aSelector 395685 ^ (self lastRun at: #errors) includes: aSelector! ! 395686 395687!TestCase class methodsFor: 'testing' stamp: 'AlexandreBergel 10/21/2008 16:00'! 395688methodRegressed: aSelector 395689 ^ (self storedMethodPassed: aSelector) and: [(self methodFailed: aSelector) or: [self methodRaisedError: aSelector]]! ! 395690 395691!TestCase class methodsFor: 'testing'! 395692shouldInheritSelectors 395693 "I should inherit from an Abstract superclass but not from a concrete one by default, unless I have no testSelectors in which case I must be expecting to inherit them from my superclass. If a test case with selectors wants to inherit selectors from a concrete superclass, override this to true in that subclass." 395694 395695 ^self superclass isAbstract 395696 or: [self testSelectors isEmpty] 395697 395698"$QA Ignore:Sends system method(superclass)$" 395699 ! ! 395700 395701!TestCase class methodsFor: 'testing' stamp: 'AlexandreBergel 10/21/2008 15:59'! 395702storedMethodFailed: aSelector 395703 ^ (self lastStoredRun at: #failures) includes: aSelector! ! 395704 395705!TestCase class methodsFor: 'testing' stamp: 'AlexandreBergel 10/21/2008 16:00'! 395706storedMethodPassed: aSelector 395707 ^ (self lastStoredRun at: #passed) includes: aSelector! ! 395708 395709!TestCase class methodsFor: 'testing' stamp: 'AlexandreBergel 10/21/2008 15:59'! 395710storedMethodRaisedError: aSelector 395711 ^ (self lastStoredRun at: #errors) includes: aSelector! ! 395712ProtoObject subclass: #TestCoverage 395713 instanceVariableNames: 'hasRun reference method' 395714 classVariableNames: '' 395715 poolDictionaries: '' 395716 category: 'SUnitGUI'! 395717 395718!TestCoverage methodsFor: 'actions' stamp: 'lr 3/30/2009 15:20'! 395719install 395720 reference actualClass methodDictionary 395721 at: reference methodSymbol 395722 put: self! ! 395723 395724!TestCoverage methodsFor: 'actions' stamp: 'lr 3/30/2009 15:31'! 395725uninstall 395726 reference actualClass methodDictionary 395727 at: reference methodSymbol 395728 put: method! ! 395729 395730 395731!TestCoverage methodsFor: 'evaluation' stamp: 'lr 3/30/2009 15:32'! 395732run: aSelector with: anArray in: aReceiver 395733 self mark; uninstall. 395734 ^ aReceiver withArgs: anArray executeMethod: method! ! 395735 395736 395737!TestCoverage methodsFor: 'initialization' stamp: 'lr 3/30/2009 15:19'! 395738initializeOn: aMethodReference 395739 hasRun := false. 395740 reference := aMethodReference. 395741 method := reference compiledMethod! ! 395742 395743 395744!TestCoverage methodsFor: 'testing' stamp: 'lr 3/30/2009 15:09'! 395745hasRun 395746 ^ hasRun! ! 395747 395748 395749!TestCoverage methodsFor: 'private' stamp: 'lr 3/30/2009 20:26'! 395750doesNotUnderstand: aMessage 395751 ^ method perform: aMessage selector withArguments: aMessage arguments! ! 395752 395753!TestCoverage methodsFor: 'private' stamp: 'lr 3/30/2009 15:26'! 395754flushCache! ! 395755 395756!TestCoverage methodsFor: 'private' stamp: 'lr 3/30/2009 15:21'! 395757mark 395758 hasRun := true! ! 395759 395760!TestCoverage methodsFor: 'private' stamp: 'lr 3/30/2009 15:27'! 395761reference 395762 ^ reference! ! 395763 395764"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 395765 395766TestCoverage class 395767 instanceVariableNames: ''! 395768 395769!TestCoverage class methodsFor: 'instance creation' stamp: 'lr 3/30/2009 15:23'! 395770on: aMethodReference 395771 ^ self new initializeOn: aMethodReference! ! 395772DynamicVariable subclass: #TestDynamicVariable 395773 instanceVariableNames: '' 395774 classVariableNames: '' 395775 poolDictionaries: '' 395776 category: 'KernelTests-Processes'! 395777!TestDynamicVariable commentStamp: 'mvl 3/13/2007 13:51' prior: 0! 395778TestDynamicVariable is a test class using in ProcessSpecificTest. 395779 395780! 395781 395782Exception subclass: #TestFailure 395783 instanceVariableNames: '' 395784 classVariableNames: '' 395785 poolDictionaries: '' 395786 category: 'SUnit-Kernel'! 395787!TestFailure commentStamp: '<historical>' prior: 0! 395788Signaled in case of a failed test (failure). The test framework distinguishes between failures and errors. A failure is anticipated and checked for with assertions. Errors are unanticipated problems like a division by 0 or an index out of bounds ...! 395789 395790 395791!TestFailure methodsFor: 'camp smalltalk' stamp: 'ajh 1/24/2003 19:23'! 395792defaultAction 395793 395794 Processor activeProcess 395795 debug: self signalerContext 395796 title: self description! ! 395797 395798!TestFailure methodsFor: 'camp smalltalk' stamp: 'ajh 2/1/2003 00:58'! 395799isResumable 395800 395801 ^ false! ! 395802Morph subclass: #TestInWorldMorph 395803 instanceVariableNames: 'intoWorldCount outOfWorldCount' 395804 classVariableNames: '' 395805 poolDictionaries: '' 395806 category: 'MorphicTests-Kernel'! 395807!TestInWorldMorph commentStamp: 'sd 6/5/2005 10:25' prior: 0! 395808Helper class for MorphTest! 395809 395810 395811!TestInWorldMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/4/2003 00:06'! 395812initialize 395813 super initialize. 395814 outOfWorldCount := intoWorldCount := 0.! ! 395815 395816!TestInWorldMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/4/2003 00:03'! 395817intoWorld: aWorld 395818 aWorld ifNil:[^self]. 395819 super intoWorld: aWorld. 395820 intoWorldCount := intoWorldCount + 1. 395821! ! 395822 395823!TestInWorldMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/4/2003 00:06'! 395824intoWorldCount 395825 ^intoWorldCount! ! 395826 395827!TestInWorldMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/4/2003 00:03'! 395828outOfWorld: aWorld 395829 aWorld ifNil:[^self]. 395830 super outOfWorld: aWorld. 395831 outOfWorldCount := outOfWorldCount + 1. 395832! ! 395833 395834!TestInWorldMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/4/2003 00:06'! 395835outOfWorldCount 395836 ^outOfWorldCount! ! 395837TestCase subclass: #TestIndenting 395838 instanceVariableNames: 'para' 395839 classVariableNames: '' 395840 poolDictionaries: '' 395841 category: 'Tests-ST80'! 395842 395843!TestIndenting methodsFor: 'running' stamp: 'hmm 2/2/2001 14:29'! 395844setUp 395845 | text | 395846 text := 'p ' asText, (Text string: 'word word' attribute: (TextIndent tabs: 1)). 395847 para := text asParagraph! ! 395848 395849 395850!TestIndenting methodsFor: 'testing' stamp: 'tlk 5/7/2006 17:14'! 395851testBreakAtSpaceLeavesSpaceOnOriginalLine 395852 "When an indented line is broken at a space, the character block must still lie in the line crossing the right margin." 395853 | cb | 395854 para compositionRectangle: (0@0 extent: para width - 24 @100); updateCompositionHeight. 395855 para clippingRectangle: (0@0 extent: 200@200). 395856 cb := para characterBlockForIndex: 7. 395857 self assert: cb top = 0. 395858 self assert: cb left >= 24! ! 395859 395860!TestIndenting methodsFor: 'testing' stamp: 'hmm 2/2/2001 14:41'! 395861testCR 395862 "Checks whether the beginning of a new line starts at the indented position" 395863 | cb | 395864 para replaceFrom: 7 to: 7 with: (String with: Character cr) displaying: false. 395865 para clippingRectangle: (0@0 extent: 200@200). 395866 cb := para characterBlockForIndex: 8. 395867 self assert: cb top > 0. 395868 self assert: cb left = 24! ! 395869 395870!TestIndenting methodsFor: 'testing' stamp: 'hmm 2/2/2001 14:41'! 395871testCR2 395872 "Checks whether the drawing of indented text is really indented..." 395873 | cb | 395874 para replaceFrom: 7 to: 7 with: (String with: Character cr) displaying: false. 395875 para clippingRectangle: (0@0 extent: 200@200). 395876 cb := para characterBlockForIndex: 8. 395877 self assert: (para asForm copy: (0@cb top extent: 24@cb height)) isAllWhite! ! 395878 395879!TestIndenting methodsFor: 'testing' stamp: 'hmm 2/2/2001 15:17'! 395880testCR3 395881 "Checks whether the beginning of a new line starts at the indented position" 395882 | cb | 395883 para replaceFrom: 11 to: 11 with: (Text string: (String with: Character cr) attribute: (TextIndent tabs: 1)) displaying: false. 395884 para clippingRectangle: (0@0 extent: 200@200). 395885 cb := para characterBlockForIndex: 12. 395886 self assert: cb top > 0. 395887 self assert: cb left = 24! ! 395888 395889!TestIndenting methodsFor: 'testing' stamp: 'tlk 5/7/2006 16:52'! 395890testNewLineAndTabProvidesDoubleIndent 395891 "Checks whether the beginning of a new line starts at the indented position" 395892 | cb | 395893 para replaceFrom: 11 to: 11 with: (Text string: (String with: Character cr) attribute: (TextIndent tabs: 1)) displaying: false. 395894 395895 cb := para characterBlockForIndex: 12. 395896 self assert: cb top > 0. 395897 self assert: cb left = 24! ! 395898 395899!TestIndenting methodsFor: 'testing' stamp: 'tlk 5/7/2006 16:52'! 395900testNewLineLeaveSpacesOnOldLine 395901 "Checks whether the drawing of indented text is really indented..." 395902 | cb | 395903 para replaceFrom: 7 to: 7 with: (String with: Character cr) displaying: false. 395904 395905 cb := para characterBlockForIndex: 8. 395906 self assert: (para asForm copy: (0@cb top extent: 24@cb height)) isAllWhite! ! 395907 395908!TestIndenting methodsFor: 'testing' stamp: 'tlk 5/7/2006 16:53'! 395909testNewLineStartsIndented 395910 "Checks whether the beginning of a new line starts at the indented position" 395911 | cb | 395912 para replaceFrom: 7 to: 7 with: (String with: Character cr) displaying: false. 395913 395914 cb := para characterBlockForIndex: 8. 395915 self assert: cb top > 0. 395916 self assert: cb left = 24! ! 395917 395918!TestIndenting methodsFor: 'testing' stamp: 'tlk 5/7/2006 17:11'! 395919testNewLineStartsIndentedWhenWrapped 395920 "Checks whether the beginning of a new line starts at the indented position" 395921 | cb | 395922 para compositionRectangle: (0@0 extent: para width - 20@100); updateCompositionHeight. 395923 para clippingRectangle: (0@0 extent: 200@200). 395924 cb := para characterBlockForIndex: 8. 395925 self assert: cb top > 0. 395926 self assert: cb left = 24! ! 395927 395928!TestIndenting methodsFor: 'testing' stamp: 'tlk 5/7/2006 16:36'! 395929testSetUp 395930 "just reminding us all what the paragraph looks like to begin with. assuming Accuny12 font " 395931 | cb | 395932 395933 395934 cb := para characterBlockForIndex: 1. "p" 395935 self assert: cb top = 0. 395936 self assert: cb left = 0. 395937 self assert: cb right = 7. 395938 395939 395940 cb := para characterBlockForIndex: 2. "the tab" 395941 self assert: cb top = 0. 395942 self assert: cb left = 7. 395943 self assert: cb right = 24. 395944 395945 395946 cb := para characterBlockForIndex: 3. "w" 395947 self assert: cb top = 0. 395948 self assert: cb left = 24. 395949 self assert: cb right = 34. 395950 395951 cb := para characterBlockForIndex: 7. " " "between word and word" 395952 self assert: cb top = 0. 395953 self assert: cb left = 52. 395954 self assert: cb right = 57. 395955 395956 cb := para characterBlockForIndex: 11. "d" "last char" 395957 self assert: cb top = 0. 395958 self assert: cb left = 79. 395959 self assert: cb right = 85. 395960 395961 395962! ! 395963ProcessLocalVariable subclass: #TestLocalVariable 395964 instanceVariableNames: '' 395965 classVariableNames: '' 395966 poolDictionaries: '' 395967 category: 'KernelTests-Processes'! 395968!TestLocalVariable commentStamp: 'mvl 3/13/2007 13:52' prior: 0! 395969TestLocalVariable is a test class using in ProcessSpecificTest.! 395970 395971 395972"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 395973 395974TestLocalVariable class 395975 instanceVariableNames: ''! 395976 395977!TestLocalVariable class methodsFor: 'as yet unclassified' stamp: 'mvl 3/13/2007 14:54'! 395978default 395979 "My default value for a new process is 0." 395980 395981 ^0! ! 395982TestParagraphFix subclass: #TestNewParagraphFix 395983 instanceVariableNames: '' 395984 classVariableNames: '' 395985 poolDictionaries: '' 395986 category: 'Tests-ST80'! 395987!TestNewParagraphFix commentStamp: '<historical>' prior: 0! 395988This class tests the same things as its superclass, but for NewParagraph which is used in the Morphic environment.! 395989 395990 395991!TestNewParagraphFix methodsFor: 'running' stamp: 'hmm 10/1/2000 17:41'! 395992setUp 395993 | morph | 395994 morph := TextMorph new contents: 'i i'. 395995 morph fit. 395996 para := morph paragraph! ! 395997 395998 395999!TestNewParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 17:42'! 396000testCharacterBlockAfterReplacingAll 396001 ^super testCharacterBlockAfterReplacingAll! ! 396002 396003!TestNewParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 17:42'! 396004testCharacterBlockAfterReplacingOther 396005 ^super testCharacterBlockAfterReplacingOther! ! 396006 396007!TestNewParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 17:42'! 396008testCharacterBlockAfterReplacingSpace 396009 ^super testCharacterBlockAfterReplacingSpace! ! 396010 396011!TestNewParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 17:43'! 396012testCharacterBlockNormal 396013 ^super testCharacterBlockNormal! ! 396014TestCase subclass: #TestObjectsAsMethods 396015 instanceVariableNames: '' 396016 classVariableNames: '' 396017 poolDictionaries: '' 396018 category: 'Tests-ObjectsAsMethods'! 396019 396020!TestObjectsAsMethods methodsFor: 'running' stamp: 'al 2/9/2009 20:19'! 396021setUp 396022 SystemChangeNotifier uniqueInstance doSilently: [ 396023 self class addSelector: #add:with: withMethod: ObjectsAsMethodsExample new. 396024 self class addSelector: #answer42 withMethod: ObjectsAsMethodsExample new. 396025 self class addSelector: #foo withMethod: AbstractObjectsAsMethod new ]! ! 396026 396027!TestObjectsAsMethods methodsFor: 'running' stamp: 'al 2/9/2009 20:19'! 396028tearDown 396029 SystemChangeNotifier uniqueInstance doSilently: [ 396030 self class removeSelector: #add:with:. 396031 self class removeSelector: #answer42. 396032 self class removeSelector: #foo ]! ! 396033 396034 396035!TestObjectsAsMethods methodsFor: 'testing' stamp: 'al 2/9/2009 19:55'! 396036testAddNumbers 396037 self assert: (self add: 3 with: 4) = 7. 396038 self assert: (self perform: #add:with: withArguments: #(3 4)) = 7.! ! 396039 396040!TestObjectsAsMethods methodsFor: 'testing' stamp: 'al 2/9/2009 19:52'! 396041testAnswer42 396042 self assert: self answer42 = 42! ! 396043 396044!TestObjectsAsMethods methodsFor: 'testing' stamp: 'al 2/9/2009 19:52'! 396045testDNU 396046 self should: [self foo] raise: MessageNotUnderstood! ! 396047TestCase subclass: #TestParagraphFix 396048 instanceVariableNames: 'para' 396049 classVariableNames: '' 396050 poolDictionaries: '' 396051 category: 'Tests-ST80'! 396052!TestParagraphFix commentStamp: '<historical>' prior: 0! 396053This class tests whether locating characters past the end of a text is possible in all cases.! 396054 396055 396056!TestParagraphFix methodsFor: 'running' stamp: 'hmm 10/1/2000 15:05'! 396057setUp 396058 para := 'i i' asParagraph! ! 396059 396060 396061!TestParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 15:52'! 396062testCharacterBlockAfterReplacingAll 396063 para replaceFrom: 1 to: 3 with: 'mmm' displaying: false. 396064 self assert: (para characterBlockForIndex: 4) stringIndex = 4! ! 396065 396066!TestParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 15:05'! 396067testCharacterBlockAfterReplacingOther 396068 para replaceFrom: 3 to: 3 with: 'm' displaying: false. 396069 self assert: (para characterBlockForIndex: 4) stringIndex = 4! ! 396070 396071!TestParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 15:05'! 396072testCharacterBlockAfterReplacingSpace 396073 para replaceFrom: 3 to: 3 with: ' ' displaying: false. 396074 self assert: (para characterBlockForIndex: 4) stringIndex = 4! ! 396075 396076!TestParagraphFix methodsFor: 'tests' stamp: 'hmm 10/1/2000 15:05'! 396077testCharacterBlockNormal 396078 self assert: (para characterBlockForIndex: 4) stringIndex = 4! ! 396079Object subclass: #TestResource 396080 instanceVariableNames: 'name description' 396081 classVariableNames: '' 396082 poolDictionaries: '' 396083 category: 'SUnit-Kernel'! 396084 396085!TestResource methodsFor: 'accessing'! 396086description 396087 396088 description isNil 396089 ifTrue: [^'']. 396090 396091 ^description 396092 ! ! 396093 396094!TestResource methodsFor: 'accessing'! 396095description: aString 396096 396097 description := aString 396098 ! ! 396099 396100!TestResource methodsFor: 'accessing'! 396101name 396102 396103 name isNil 396104 ifTrue: [^self printString]. 396105 396106 ^name 396107 ! ! 396108 396109!TestResource methodsFor: 'accessing'! 396110name: aString 396111 396112 name := aString 396113 ! ! 396114 396115!TestResource methodsFor: 'accessing'! 396116resources 396117 ^self class resources 396118 ! ! 396119 396120 396121!TestResource methodsFor: 'initializing' stamp: 'alain.plantec 5/28/2009 11:11'! 396122initialize 396123 super initialize. 396124 self setUp 396125 396126 ! ! 396127 396128 396129!TestResource methodsFor: 'printing'! 396130printOn: aStream 396131 396132 aStream nextPutAll: self class printString 396133 ! ! 396134 396135 396136!TestResource methodsFor: 'running'! 396137setUp 396138 "Does nothing. Subclasses should override this 396139 to initialize their resource" 396140 ! ! 396141 396142!TestResource methodsFor: 'running'! 396143signalInitializationError 396144 ^self class signalInitializationError 396145 ! ! 396146 396147!TestResource methodsFor: 'running'! 396148tearDown 396149 "Does nothing. Subclasses should override this 396150 to tear down their resource" 396151 ! ! 396152 396153 396154!TestResource methodsFor: 'testing'! 396155isAvailable 396156 "override to provide information on the 396157 readiness of the resource" 396158 396159 ^true 396160 ! ! 396161 396162!TestResource methodsFor: 'testing'! 396163isUnavailable 396164 "override to provide information on the 396165 readiness of the resource" 396166 396167 ^self isAvailable not 396168 ! ! 396169 396170"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 396171 396172TestResource class 396173 instanceVariableNames: 'current'! 396174 396175!TestResource class methodsFor: 'accessing'! 396176current 396177 396178 current isNil 396179 ifTrue: [current := self new]. 396180 396181 ^current 396182 ! ! 396183 396184!TestResource class methodsFor: 'accessing'! 396185current: aTestResource 396186 396187 current := aTestResource 396188 ! ! 396189 396190!TestResource class methodsFor: 'accessing'! 396191resources 396192 ^#() 396193 ! ! 396194 396195 396196!TestResource class methodsFor: 'creation'! 396197reset 396198 396199 current notNil ifTrue: [ 396200 [current tearDown] ensure: [ 396201 current := nil]] 396202 ! ! 396203 396204!TestResource class methodsFor: 'creation'! 396205signalInitializationError 396206 ^TestResult signalErrorWith: 'Resource ' , self name , ' could not be initialized' 396207 ! ! 396208 396209 396210!TestResource class methodsFor: 'testing' stamp: 'md 2/22/2006 14:21'! 396211isAbstract 396212 "Override to true if a TestResource subclass is Abstract and should not have 396213 TestCase instances built from it" 396214 396215 ^self name = #TestResource 396216 ! ! 396217 396218!TestResource class methodsFor: 'testing'! 396219isAvailable 396220 ^self current notNil and: [self current isAvailable] 396221 ! ! 396222 396223!TestResource class methodsFor: 'testing'! 396224isUnavailable 396225 396226 ^self isAvailable not 396227 ! ! 396228Object subclass: #TestResult 396229 instanceVariableNames: 'timeStamp failures errors passed' 396230 classVariableNames: '' 396231 poolDictionaries: '' 396232 category: 'SUnit-Kernel'! 396233!TestResult commentStamp: '<historical>' prior: 0! 396234This is a Collecting Parameter for the running of a bunch of tests. TestResult is an interesting object to subclass or substitute. #runCase: is the external protocol you need to reproduce. Kent has seen TestResults that recorded coverage information and that sent email when they were done.! 396235 396236 396237!TestResult methodsFor: 'accessing' stamp: 'simon.denier 11/13/2008 20:27'! 396238classesTested 396239 ^ (self tests collect: [ :testCase | testCase class ]) asSet! ! 396240 396241!TestResult methodsFor: 'accessing'! 396242correctCount 396243 "depreciated - use #passedCount" 396244 396245 ^self passedCount 396246 ! ! 396247 396248!TestResult methodsFor: 'accessing'! 396249defects 396250 ^OrderedCollection new 396251 addAll: self errors; 396252 addAll: self failures; yourself 396253 ! ! 396254 396255!TestResult methodsFor: 'accessing'! 396256errorCount 396257 396258 ^self errors size 396259 ! ! 396260 396261!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'! 396262expectedDefectCount 396263 ^ self expectedDefects size! ! 396264 396265!TestResult methodsFor: 'accessing' stamp: 'md 11/25/2004 16:36'! 396266expectedDefects 396267 ^ (errors, failures asOrderedCollection) select: [:each | each shouldPass not] ! ! 396268 396269!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'! 396270expectedPassCount 396271 ^ self expectedPasses size! ! 396272 396273!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:14'! 396274expectedPasses 396275 ^ passed select: [:each | each shouldPass] ! ! 396276 396277!TestResult methodsFor: 'accessing'! 396278failureCount 396279 396280 ^self failures size 396281 ! ! 396282 396283!TestResult methodsFor: 'accessing'! 396284passedCount 396285 396286 ^self passed size 396287 ! ! 396288 396289!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:07'! 396290runCount 396291 ^ passed size + failures size + errors size! ! 396292 396293!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:06'! 396294tests 396295 ^(OrderedCollection new: self runCount) 396296 addAll: passed; 396297 addAll: failures; 396298 addAll: errors; 396299 yourself! ! 396300 396301!TestResult methodsFor: 'accessing' stamp: 'AlexandreBergel 10/1/2008 11:52'! 396302timeStamp 396303 ^ timeStamp! ! 396304 396305!TestResult methodsFor: 'accessing' stamp: 'AlexandreBergel 10/1/2008 11:52'! 396306timeStamp: anObject 396307 timeStamp := anObject! ! 396308 396309!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'! 396310unexpectedErrorCount 396311 ^ self unexpectedErrors size! ! 396312 396313!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:14'! 396314unexpectedErrors 396315 ^ errors select: [:each | each shouldPass] ! ! 396316 396317!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'! 396318unexpectedFailureCount 396319 ^ self unexpectedFailures size! ! 396320 396321!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:14'! 396322unexpectedFailures 396323 ^ failures select: [:each | each shouldPass] ! ! 396324 396325!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 13:54'! 396326unexpectedPassCount 396327 ^ self unexpectedPasses size! ! 396328 396329!TestResult methodsFor: 'accessing' stamp: 'JF 7/30/2003 16:14'! 396330unexpectedPasses 396331 ^ passed select: [:each | each shouldPass not] ! ! 396332 396333 396334!TestResult methodsFor: 'compatibility' stamp: 'JF 7/30/2003 16:09'! 396335errors 396336 ^ self unexpectedErrors! ! 396337 396338!TestResult methodsFor: 'compatibility' stamp: 'md 11/25/2004 16:23'! 396339failures 396340 ^ self unexpectedFailures, self unexpectedPasses ! ! 396341 396342!TestResult methodsFor: 'compatibility' stamp: 'JF 7/30/2003 16:08'! 396343passed 396344 ^ self expectedPasses, self expectedDefects! ! 396345 396346 396347!TestResult methodsFor: 'diff' stamp: 'AlexandreBergel 10/1/2008 16:26'! 396348diff: aTestResult 396349 "Return a collection that contains differences" 396350 | passed1Selectors failed1Selectors errors1Selectors passed2Selectors failed2Selectors errors2Selectors | 396351 passed1Selectors := self passed collect: [:testCase | testCase selector]. 396352 failed1Selectors := self failures collect: [:testCase | testCase selector]. 396353 errors1Selectors := self errors collect: [:testCase | testCase selector]. 396354 396355 passed2Selectors := aTestResult passed collect: [:testCase | testCase selector]. 396356 failed2Selectors := aTestResult failures collect: [:testCase | testCase selector]. 396357 errors2Selectors := aTestResult errors collect: [:testCase | testCase selector]. 396358 396359 ^ {passed1Selectors copyWithoutAll: passed2Selectors . 396360 failed1Selectors copyWithoutAll: failed2Selectors . 396361 errors1Selectors copyWithoutAll: errors2Selectors}! ! 396362 396363 396364!TestResult methodsFor: 'history' stamp: 'simon.denier 11/13/2008 20:33'! 396365dispatchResultsIntoHistory 396366 396367 self classesTested do: 396368 [ :testClass | 396369 self class 396370 historyAt: testClass 396371 put: (self selectResultsForTestCase: testClass) ]. 396372! ! 396373 396374!TestResult methodsFor: 'history' stamp: 'simon.denier 11/13/2008 20:51'! 396375selectResultsForTestCase: aTestCaseClass 396376 | passedSelectors errorsSelectors failuresSelectors | 396377 passedSelectors := self passed 396378 select: [:testCase | testCase class == aTestCaseClass ] thenCollect: [:testCase | testCase selector]. 396379 errorsSelectors := self errors 396380 select: [:testCase | testCase class == aTestCaseClass ] thenCollect: [:testCase | testCase selector]. 396381 failuresSelectors := self failures 396382 select: [:testCase | testCase class == aTestCaseClass ] thenCollect: [:testCase | testCase selector]. 396383 396384 ^ self class newTestDictionary 396385 at: #passed put: passedSelectors asSet; 396386 at: #failures put: failuresSelectors asSet; 396387 at: #errors put: errorsSelectors asSet; 396388 yourself 396389 ! ! 396390 396391!TestResult methodsFor: 'history' stamp: 'simon.denier 11/22/2008 22:05'! 396392updateResultsInHistory 396393 396394 #(#passed #failures #errors) do: [ :status | 396395 (self perform: status) do: [ :testCase | 396396 self class updateTestHistoryFor: testCase status: status ] ]! ! 396397 396398 396399!TestResult methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:11'! 396400initialize 396401 super initialize. 396402 passed := OrderedCollection new. 396403 failures := Set new. 396404 errors := OrderedCollection new. 396405 timeStamp := TimeStamp now! ! 396406 396407 396408!TestResult methodsFor: 'printing' stamp: 'JF 7/30/2003 16:15'! 396409printOn: aStream 396410 aStream 396411 nextPutAll: self runCount printString; 396412 nextPutAll: ' run, '; 396413 nextPutAll: self expectedPassCount printString; 396414 nextPutAll: ' passes, '; 396415 nextPutAll: self expectedDefectCount printString; 396416 nextPutAll:' expected failures, '; 396417 nextPutAll: self unexpectedFailureCount printString; 396418 nextPutAll: ' failures, '; 396419 nextPutAll: self unexpectedErrorCount printString; 396420 nextPutAll:' errors, '; 396421 nextPutAll: self unexpectedPassCount printString; 396422 nextPutAll:' unexpected passes'.! ! 396423 396424 396425!TestResult methodsFor: 'querying' stamp: 'GwenaelCasaccio 10/1/2008 22:37'! 396426isErrorFor: class selector: selector 396427 ^ self errors anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]! ! 396428 396429!TestResult methodsFor: 'querying' stamp: 'GwenaelCasaccio 10/1/2008 22:37'! 396430isFailureFor: class selector: selector 396431 ^ self failures anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]! ! 396432 396433!TestResult methodsFor: 'querying' stamp: 'GwenaelCasaccio 10/1/2008 22:36'! 396434isPassedFor: class selector: selector 396435 ^ self passed anySatisfy: [:testCase | testCase class == class and: [testCase selector == selector]]! ! 396436 396437 396438!TestResult methodsFor: 'running' stamp: 'md 2/22/2006 14:27'! 396439runCase: aTestCase 396440 | testCasePassed | 396441 testCasePassed := true. 396442 [[aTestCase runCase] 396443 on: self class failure 396444 do: 396445 [:signal | 396446 failures add: aTestCase. 396447 testCasePassed := false. 396448 signal return: false]] 396449 on: self class error 396450 do: 396451 [:signal | 396452 errors add: aTestCase. 396453 testCasePassed := false. 396454 signal return: false]. 396455 testCasePassed ifTrue: [passed add: aTestCase]! ! 396456 396457 396458!TestResult methodsFor: 'testing'! 396459hasErrors 396460 396461 ^self errors size > 0 396462 ! ! 396463 396464!TestResult methodsFor: 'testing'! 396465hasFailures 396466 396467 ^self failures size > 0 396468 ! ! 396469 396470!TestResult methodsFor: 'testing' stamp: 'jf 3/4/2009 11:55'! 396471hasPassed 396472 ^ self hasErrors not and: [ self hasFailures not ]! ! 396473 396474!TestResult methodsFor: 'testing'! 396475isError: aTestCase 396476 396477 ^self errors includes: aTestCase 396478 ! ! 396479 396480!TestResult methodsFor: 'testing'! 396481isFailure: aTestCase 396482 ^self failures includes: aTestCase 396483 ! ! 396484 396485!TestResult methodsFor: 'testing'! 396486isPassed: aTestCase 396487 396488 ^self passed includes: aTestCase 396489 ! ! 396490 396491"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 396492 396493TestResult class 396494 instanceVariableNames: ''! 396495 396496!TestResult class methodsFor: 'exceptions'! 396497error 396498 ^self exError 396499 ! ! 396500 396501!TestResult class methodsFor: 'exceptions' stamp: 'md 2/22/2006 14:17'! 396502exError 396503 ^Error 396504 ! ! 396505 396506!TestResult class methodsFor: 'exceptions'! 396507failure 396508 ^TestFailure 396509 ! ! 396510 396511!TestResult class methodsFor: 'exceptions'! 396512resumableFailure 396513 ^ResumableTestFailure 396514 ! ! 396515 396516!TestResult class methodsFor: 'exceptions' stamp: 'md 2/22/2006 14:26'! 396517signalErrorWith: aString 396518 self error signal: aString 396519 ! ! 396520 396521!TestResult class methodsFor: 'exceptions' stamp: 'md 2/22/2006 14:26'! 396522signalFailureWith: aString 396523 self failure signal: aString 396524 ! ! 396525 396526 396527!TestResult class methodsFor: 'history' stamp: 'Alexandre.Bergel 4/3/2009 14:44'! 396528historyAt: aTestCaseClass 396529"I will return the last test dictionary for aTestCaseClass. If none found, I will create a new empty one and link it in the history." 396530 396531 ^ aTestCaseClass history ! ! 396532 396533!TestResult class methodsFor: 'history' stamp: 'Alexandre.Bergel 4/3/2009 14:45'! 396534historyAt: aTestCaseClass put: aDictionary 396535 aTestCaseClass history: aDictionary 396536 "^ self history at: aTestCaseClass put: aDictionary "! ! 396537 396538!TestResult class methodsFor: 'history' stamp: 'Alexandre.Bergel 4/3/2009 14:46'! 396539historyFor: aTestCaseClass 396540 "I return the last test dictionary for aTestCaseClass. 396541 If none found, I return an empty dictionary but will not link it to the class in the history." 396542 396543 | history | 396544 history := aTestCaseClass history. 396545 history ifNil: [ ^ self newTestDictionary ]. 396546 ^ history 396547 396548" ^ self history at: aTestCaseClass ifAbsent: [ self newTestDictionary ]"! ! 396549 396550!TestResult class methodsFor: 'history' stamp: 'Alexandre.Bergel 4/3/2009 14:10'! 396551newTestDictionary 396552 396553 ^ Dictionary new at: #timeStamp put: TimeStamp now; 396554 at: #passed put: Set new; 396555 at: #failures put: Set new; 396556 at: #errors put: Set new; 396557 yourself 396558 ! ! 396559 396560!TestResult class methodsFor: 'history' stamp: 'simon.denier 11/22/2008 20:56'! 396561removeFromTestHistory: aSelector in: aTestCaseClass 396562 | lastRun | 396563 396564 lastRun := self historyFor: aTestCaseClass. 396565 #(#passed #failures #errors) do: 396566 [ :set | (lastRun at: set) remove: aSelector ifAbsent: []]. 396567! ! 396568 396569!TestResult class methodsFor: 'history' stamp: 'simon.denier 11/22/2008 22:05'! 396570updateTestHistoryFor: aTestCase status: aSymbol 396571 | cls sel | 396572 396573 cls := aTestCase class. 396574 sel := aTestCase selector. 396575 self removeFromTestHistory: sel in: cls. 396576 ((self historyAt: cls) at: aSymbol ) add: sel! ! 396577Object subclass: #TestRunner 396578 instanceVariableNames: 'categories categoriesSelected classes classIndex classesSelected failedList failedSelected errorList errorSelected lastUpdate result previousRun' 396579 classVariableNames: '' 396580 poolDictionaries: '' 396581 category: 'SUnitGUI'! 396582!TestRunner commentStamp: '<historical>' prior: 0! 396583<lint: #ignore rule: #classNotReferenced rational: 'this view is only accessed from menus'> 396584 396585! 396586 396587 396588!TestRunner methodsFor: 'accessing' stamp: 'lr 10/31/2005 15:31'! 396589baseClass 396590 ^ TestCase! ! 396591 396592!TestRunner methodsFor: 'accessing' stamp: 'lr 11/3/2005 09:37'! 396593suiteAll 396594 ^ TestSuite new in: [ :suite | 396595 classesSelected do: [ :each | 396596 each isAbstract 396597 ifFalse: [ each addToSuiteFromSelectors: suite ] ]. 396598 suite name: (self label: 'Test' forSuite: suite) ].! ! 396599 396600!TestRunner methodsFor: 'accessing' stamp: 'lr 10/27/2005 10:29'! 396601suiteErrors 396602 ^ TestSuite new in: [ :suite | 396603 suite 396604 addTests: errorList; 396605 name: (self label: 'Error' forSuite: suite) ].! ! 396606 396607!TestRunner methodsFor: 'accessing' stamp: 'lr 10/27/2005 10:42'! 396608suiteFailures 396609 ^ TestSuite new in: [ :suite | 396610 suite 396611 addTests: failedList; 396612 name: (self label: 'Failure' forSuite: suite) ].! ! 396613 396614 396615!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 10/31/2005 15:09'! 396616categoryAt: anIndex 396617 ^ categoriesSelected includes: (categories at: anIndex ifAbsent: [ ^ false ]).! ! 396618 396619!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 10/31/2005 15:51'! 396620categoryAt: anInteger put: aBoolean 396621 categoriesSelected := categoriesSelected 396622 perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ]) 396623 with: (categories at: anInteger ifAbsent: [ ^ self ]). 396624 self changed: #categorySelected; updateClasses.! ! 396625 396626!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 10/31/2005 15:10'! 396627categoryList 396628 ^ categories! ! 396629 396630!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 11/1/2005 19:25'! 396631categoryMenu: aMenu 396632 ^ aMenu 396633 title: 'Categories'; 396634 add: 'Select all' action: #selectAllCategories; 396635 add: 'Select inversion' action: #selectInverseCategories; 396636 add: 'Select none' action: #selectNoCategories; 396637 addLine; 396638 add: 'Filter...' action: #filterCategories; 396639 addLine; 396640 add: 'Refresh' action: #updateCategories; 396641 yourself.! ! 396642 396643!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 10/31/2005 15:11'! 396644categorySelected 396645 ^ 0! ! 396646 396647!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 10/31/2005 15:12'! 396648categorySelected: anInteger 396649 self changed: #categorySelected.! ! 396650 396651!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 7/4/2009 15:08'! 396652filterCategories 396653 | pattern | 396654 pattern := UIManager default 396655 request: 'Pattern to select categories:' 396656 initialAnswer: '*'. 396657 pattern isNil ifTrue: [ ^ self ]. 396658 categoriesSelected := (categories 396659 select: [ :each | pattern match: each ]) asSet. 396660 self changed: #allSelections; changed: #categorySelected; updateClasses! ! 396661 396662!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 7/4/2009 15:08'! 396663selectAllCategories 396664 categoriesSelected := categories asSet. 396665 self changed: #allSelections; changed: #categorySelected; updateClasses! ! 396666 396667!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 7/4/2009 15:08'! 396668selectInverseCategories 396669 categoriesSelected := categories asSet 396670 removeAll: categoriesSelected; 396671 yourself. 396672 self changed: #allSelections; changed: #categorySelected; updateClasses! ! 396673 396674!TestRunner methodsFor: 'accessing-categories' stamp: 'lr 7/4/2009 15:08'! 396675selectNoCategories 396676 categoriesSelected := Set new. 396677 self changed: #allSelections; changed: #categorySelected; updateClasses! ! 396678 396679 396680!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 1/20/2009 14:49'! 396681browseClass 396682 (classes at: classIndex ifAbsent: [ ^ self ]) browse! ! 396683 396684!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 10/8/2005 19:58'! 396685classAt: anInteger 396686 ^ classesSelected includes: (classes at: anInteger ifAbsent: [ ^ false ]).! ! 396687 396688!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 11/21/2005 13:19'! 396689classAt: anInteger put: aBoolean 396690 classesSelected := classesSelected 396691 perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ]) 396692 with: (classes at: anInteger ifAbsent: [ ^ self ]). 396693 self changed: #classSelected; changed: #hasRunnable.! ! 396694 396695!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 10/10/2005 11:24'! 396696classList 396697 | offset ident | 396698 classes isEmpty ifTrue: [ ^ classes ]. 396699 offset := classes first allSuperclasses size. 396700 ^ classes collect: [ :each | 396701 ident := String 396702 new: 2 * (0 max: each allSuperclasses size - offset) 396703 withAll: $ . 396704 each isAbstract 396705 ifFalse: [ ident , each name ] 396706 ifTrue: [ 396707 ident asText , each name asText 396708 addAttribute: TextEmphasis italic; 396709 yourself ] ].! ! 396710 396711!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 1/20/2009 14:45'! 396712classMenu: aMenu 396713 ^ aMenu 396714 title: 'Classes'; 396715 add: 'Browse' action: #browseClass; 396716 addLine; 396717 add: 'Select all' action: #selectAllClasses; 396718 add: 'Select subclasses' action: #selectSubclasses; 396719 add: 'Select inversion' action: #selectInverseClasses; 396720 add: 'Select none' action: #selectNoClasses; 396721 addLine; 396722 add: 'Filter...' action: #filterClasses; 396723 addLine; 396724 add: 'Refresh' action: #updateClasses; 396725 yourself.! ! 396726 396727!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 1/20/2009 14:46'! 396728classSelected 396729 ^ classIndex! ! 396730 396731!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 1/20/2009 14:48'! 396732classSelected: anInteger 396733 classIndex := anInteger. 396734 self changed: #classSelected! ! 396735 396736!TestRunner methodsFor: 'accessing-classes' stamp: 'lr 7/4/2009 15:10'! 396737filterClasses 396738 | pattern | 396739 pattern := UIManager default 396740 request: 'Pattern to select tests:' 396741 initialAnswer: '*'. 396742 pattern isNil ifTrue: [ ^ self ]. 396743 classesSelected := (classes select: [ :each | 396744 pattern match: each name ]) asSet. 396745 self 396746 changed: #allSelections; 396747 changed: #classSelected; 396748 changed: #hasRunnable! ! 396749 396750!TestRunner methodsFor: 'accessing-classes' stamp: 'gvc 7/24/2007 12:01'! 396751selectAllClasses 396752 "Fixed to update all selections now that the 396753 selection invalidation has been optimised." 396754 396755 classesSelected := classes asSet. 396756 self 396757 changed: #allSelections; 396758 changed: #classSelected; 396759 changed: #hasRunnable! ! 396760 396761!TestRunner methodsFor: 'accessing-classes' stamp: 'gvc 7/24/2007 12:01'! 396762selectInverseClasses 396763 "Fixed to update all selections now that the 396764 selection invalidation has been optimised." 396765 396766 classesSelected := classes asSet 396767 removeAll: classesSelected; 396768 yourself. 396769 self 396770 changed: #allSelections; 396771 changed: #classSelected; 396772 changed: #hasRunnable! ! 396773 396774!TestRunner methodsFor: 'accessing-classes' stamp: 'gvc 7/24/2007 11:59'! 396775selectNoClasses 396776 "Fixed to update all selections now that the 396777 selection invalidation has been optimised." 396778 396779 classesSelected := Set new. 396780 self 396781 changed: #allSelections; 396782 changed: #classSelected; 396783 changed: #hasRunnable! ! 396784 396785!TestRunner methodsFor: 'accessing-classes' stamp: 'gvc 7/24/2007 12:01'! 396786selectSubclasses 396787 "Fixed to update all selections now that the 396788 selection invalidation has been optimised." 396789 396790 | classesForPackages | 396791 classesForPackages := self findClassesForCategories: categoriesSelected. 396792 classesSelected := (classesSelected gather: [ :class | 396793 class withAllSubclasses select: [ :each | 396794 classesForPackages includes: each ] ]) 396795 asSet. 396796 self 396797 changed: #allSelections; 396798 changed: #classSelected; 396799 changed: #hasRunnable! ! 396800 396801 396802!TestRunner methodsFor: 'accessing-menu' stamp: 'lr 10/21/2008 18:10'! 396803errorMenu: aMenu 396804 ^ self statusMenu: aMenu! ! 396805 396806!TestRunner methodsFor: 'accessing-menu' stamp: 'lr 10/21/2008 18:05'! 396807failureMenu: aMenu 396808 ^ aMenu! ! 396809 396810!TestRunner methodsFor: 'accessing-menu' stamp: 'simon.denier 11/13/2008 19:43'! 396811statusMenu: aMenu 396812 ^ aMenu 396813 add: 'History' action: #showHistoryMenu; 396814 add: 'Store result as progress reference' action: #storeResultIntoTestCases; 396815 add: 'Show progress' action: #showProgress; 396816 yourself! ! 396817 396818 396819!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/8/2005 22:37'! 396820errorList 396821 ^ errorList collect: [ :each | each printString ].! ! 396822 396823!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/6/2005 19:46'! 396824errorSelected 396825 ^ errorList indexOf: errorSelected.! ! 396826 396827!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/27/2005 10:37'! 396828errorSelected: anInteger 396829 errorSelected := errorList at: anInteger ifAbsent: nil. 396830 self changed: #errorSelected. 396831 errorSelected ifNotNil: [ self debug: errorSelected ].! ! 396832 396833!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/8/2005 22:37'! 396834failedList 396835 ^ failedList collect: [ :each | each printString ].! ! 396836 396837!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/6/2005 19:47'! 396838failedSelected 396839 ^ failedList indexOf: failedSelected.! ! 396840 396841!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/6/2005 20:14'! 396842failedSelected: anInteger 396843 failedSelected := failedList at: anInteger ifAbsent: nil. 396844 self changed: #failedSelected. 396845 failedSelected ifNotNil: [ self debug: failedSelected ].! ! 396846 396847!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/6/2005 15:47'! 396848result 396849 ^ result! ! 396850 396851!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/8/2005 22:47'! 396852result: aResult 396853 result := aResult! ! 396854 396855!TestRunner methodsFor: 'accessing-testing' stamp: 'jf 3/4/2009 11:59'! 396856statusColor 396857 result hasFailures 396858 ifTrue:[ ^ Color yellow ]. 396859 result hasErrors 396860 ifTrue: [ ^ Color red ]. 396861 ^ Color green! ! 396862 396863!TestRunner methodsFor: 'accessing-testing' stamp: 'lr 10/8/2005 22:45'! 396864statusText 396865 ^ result printString.! ! 396866 396867 396868!TestRunner methodsFor: 'accessing-ui' stamp: 'lr 3/30/2009 14:42'! 396869buttons 396870 ^ #(( 'Run Selected' #runAll #hasRunnable ) 396871 ( 'Run Profiled' #runProfiled #hasRunnable ) 396872 ( 'Run Coverage' #runCoverage #hasRunnable ) 396873 ( 'Run Failures' #runFailures #hasFailures ) 396874 ( 'Run Errors' #runErrors #hasErrors ))! ! 396875 396876!TestRunner methodsFor: 'accessing-ui' stamp: 'lr 10/8/2005 18:39'! 396877extent 396878 ^ 640 @ 480! ! 396879 396880!TestRunner methodsFor: 'accessing-ui' stamp: 'lr 1/20/2006 13:36'! 396881label 396882 ^ 'Test Runner' ! ! 396883 396884 396885!TestRunner methodsFor: 'actions' stamp: 'onierstrasz 5/14/2009 14:05'! 396886addDeclaredPackagesUnderTestTo: packages 396887 classesSelected do: 396888 [ :class | 396889 (class class selectors includes: #packageNamesUnderTest) ifTrue: 396890 [ class packageNamesUnderTest do: [ :name | packages add: (PackageInfo named: name) ] ] ]! ! 396891 396892!TestRunner methodsFor: 'actions' stamp: 'onierstrasz 5/14/2009 14:40'! 396893addMethodsUnderTestIn: packages to: methods 396894 packages 396895 do: [:package | package isNil 396896 ifFalse: [package methods 396897 do: [:method | ((#(#packageNamesUnderTest #classNamesNotUnderTest ) includes: method methodSymbol) 396898 or: [method compiledMethod isAbstract 396899 or: [method compiledMethod refersToLiteral: #ignoreForCoverage]]) 396900 ifFalse: [methods add: method]]]]! ! 396901 396902!TestRunner methodsFor: 'actions' stamp: 'onierstrasz 5/14/2009 14:14'! 396903collectCoverageFor: methods 396904 | wrappers suite | 396905 wrappers := methods collect: [ :each | TestCoverage on: each ]. 396906 suite := self 396907 reset; 396908 suiteAll. 396909 396910 [ wrappers do: [ :each | each install ]. 396911 [ self runSuite: suite ] ensure: [ wrappers do: [ :each | each uninstall ] ] ] valueUnpreemptively. 396912 wrappers := wrappers reject: [ :each | each hasRun ]. 396913 wrappers isEmpty 396914 ifTrue: 396915 [ UIManager default inform: 'Congratulations. Your tests cover all code under analysis.' ] 396916 ifFalse: 396917 [ MessageSet 396918 openMessageList: (wrappers collect: [ :each | each reference ]) 396919 name: 'Not Covered Code (' , (100 - (100 * wrappers size // methods size)) printString , '% Code Coverage)' ]. 396920 self saveResultInHistory! ! 396921 396922!TestRunner methodsFor: 'actions' stamp: 'lr 10/31/2005 17:01'! 396923debugSuite: aTestSuite 396924 self basicRunSuite: aTestSuite do: [ :each | each debug ].! ! 396925 396926!TestRunner methodsFor: 'actions' stamp: 'lr 10/31/2005 17:42'! 396927debug: aTestCase 396928 self debugSuite: (TestSuite new 396929 addTest: aTestCase; 396930 yourself).! ! 396931 396932!TestRunner methodsFor: 'actions' stamp: 'onierstrasz 5/14/2009 16:47'! 396933excludeClassesNotUnderTestFrom: methods 396934 | theClass | 396935 classesSelected do: 396936 [ :class | 396937 (class class selectors includes: #classNamesNotUnderTest) ifTrue: 396938 [ class classNamesNotUnderTest do: 396939 [ :className | 396940 theClass := Smalltalk classNamed: className. 396941 theClass ifNotNil:[ 396942 theClass methods do: 396943 [ :each | 396944 methods 396945 remove: each methodReference 396946 ifAbsent: [ ] ]. 396947 theClass class methods do: 396948 [ :each | 396949 methods 396950 remove: each methodReference 396951 ifAbsent: [ ] ]] ] ] ]! ! 396952 396953!TestRunner methodsFor: 'actions' stamp: 'onierstrasz 5/14/2009 14:11'! 396954promptForPackages 396955 | packages | 396956 packages := (PackageOrganizer default packages 396957 reject: [:package | (package packageName beginsWith: 'Kernel') 396958 or: [(package packageName beginsWith: 'Collections') 396959 or: [(package packageName beginsWith: 'Exceptions') 396960 or: [(package packageName beginsWith: 'SUnit') 396961 or: [(package packageName beginsWith: 'System') 396962 or: [package packageName includesSubstring: 'Test' caseSensitive: false]]]]]]) 396963 sort: [:a :b | a packageName < b packageName]. 396964 packages := Array 396965 with: (UIManager default 396966 chooseFrom: (packages 396967 collect: [:package | package packageName]) 396968 values: packages 396969 title: 'Select Package'). 396970 ^ packages! ! 396971 396972!TestRunner methodsFor: 'actions' stamp: 'lr 10/8/2005 22:52'! 396973reset 396974 self result: TestResult new; updateResults.! ! 396975 396976!TestRunner methodsFor: 'actions' stamp: 'AdrianLienhard 10/19/2009 09:43'! 396977runAll 396978 Author 396979 useAuthor: 'TestRunner' 396980 during: [ 396981 self reset; runSuite: self suiteAll. 396982 self saveResultInHistory ]! ! 396983 396984!TestRunner methodsFor: 'actions' stamp: 'onierstrasz 5/14/2009 14:15'! 396985runCoverage 396986 | packages methods | 396987 packages := Set new. 396988 self addDeclaredPackagesUnderTestTo: packages. 396989 packages isEmpty ifTrue: 396990 [ packages := self promptForPackages ]. 396991 methods := OrderedCollection new. 396992 self 396993 addMethodsUnderTestIn: packages 396994 to: methods. 396995 self excludeClassesNotUnderTestFrom: methods. 396996 methods isEmpty ifTrue: 396997 [ ^ UIManager default inform: 'No methods found for coverage analysis.' ]. 396998 self collectCoverageFor: methods 396999! ! 397000 397001!TestRunner methodsFor: 'actions' stamp: 'lr 10/8/2005 23:02'! 397002runErrors 397003 self result instVarNamed: 'errors' put: OrderedCollection new. 397004 self runSuite: self suiteErrors.! ! 397005 397006!TestRunner methodsFor: 'actions' stamp: 'lr 10/27/2005 10:42'! 397007runFailures 397008 self result instVarNamed: 'failures' put: Set new. 397009 self runSuite: self suiteFailures.! ! 397010 397011!TestRunner methodsFor: 'actions' stamp: 'lr 10/31/2005 17:13'! 397012runProfiled 397013 MessageTally spyOn: [ self runAll ].! ! 397014 397015!TestRunner methodsFor: 'actions' stamp: 'lr 3/30/2009 14:50'! 397016runSuite: aTestSuite 397017 self basicRunSuite: aTestSuite do: [ :each | self runTest: each ]. 397018 self updateResults 397019 397020! ! 397021 397022!TestRunner methodsFor: 'actions' stamp: 'lr 11/3/2005 09:15'! 397023runTest: aTestCase 397024 aTestCase run: result. 397025 self updateStatus: true.! ! 397026 397027 397028!TestRunner methodsFor: 'building' stamp: 'lr 11/21/2005 13:22'! 397029buildButtonsWith: aBuilder 397030 ^ aBuilder pluggablePanelSpec new 397031 model: self; 397032 layout: #horizontal; 397033 children: (self buttons collect: [ :each | 397034 aBuilder pluggableButtonSpec new 397035 model: self; 397036 label: each first; 397037 action: each second; 397038 enabled: each third; 397039 yourself ]); 397040 yourself.! ! 397041 397042!TestRunner methodsFor: 'building' stamp: 'lr 10/31/2005 15:12'! 397043buildCategoriesWith: aBuilder 397044 ^ aBuilder pluggableMultiSelectionListSpec new 397045 model: self; 397046 list: #categoryList; 397047 menu: #categoryMenu:; 397048 getIndex: #categorySelected; 397049 setIndex: #categorySelected:; 397050 getSelectionList: #categoryAt:; 397051 setSelectionList: #categoryAt:put:; 397052 yourself.! ! 397053 397054!TestRunner methodsFor: 'building' stamp: 'lr 10/17/2005 09:13'! 397055buildClassesWith: aBuilder 397056 ^ aBuilder pluggableMultiSelectionListSpec new 397057 model: self; 397058 list: #classList; 397059 menu: #classMenu:; 397060 getIndex: #classSelected; 397061 setIndex: #classSelected:; 397062 getSelectionList: #classAt:; 397063 setSelectionList: #classAt:put:; 397064 yourself.! ! 397065 397066!TestRunner methodsFor: 'building' stamp: 'lr 10/21/2008 18:04'! 397067buildErrorListWith: aBuilder 397068 ^ aBuilder pluggableListSpec new 397069 model: self; 397070 name: 'Error List'; 397071 list: #errorList; 397072 menu: #errorMenu:; 397073 getIndex: #errorSelected; 397074 setIndex: #errorSelected:; 397075 yourself.! ! 397076 397077!TestRunner methodsFor: 'building' stamp: 'lr 10/21/2008 18:04'! 397078buildFailureListWith: aBuilder 397079 ^ aBuilder pluggableListSpec new 397080 model: self; 397081 name: 'Failure List'; 397082 list: #failedList; 397083 menu: #failureMenu:; 397084 getIndex: #failedSelected; 397085 setIndex: #failedSelected:; 397086 yourself.! ! 397087 397088!TestRunner methodsFor: 'building' stamp: 'lr 10/21/2008 18:05'! 397089buildStatusWith: aBuilder 397090 ^ aBuilder pluggableInputFieldSpec new 397091 model: self; 397092 menu: #statusMenu:; 397093 color: #statusColor; 397094 getText: #statusText; 397095 yourself.! ! 397096 397097!TestRunner methodsFor: 'building' stamp: 'lr 10/31/2005 15:12'! 397098buildWith: aBuilder 397099 | window | 397100 window := aBuilder pluggableWindowSpec new 397101 model: self; label: self label; extent: self extent; 397102 children: (OrderedCollection new 397103 add: ((self buildCategoriesWith: aBuilder) 397104 frame: (0.00 @ 0.00 corner: 0.25 @ 0.92 ); 397105 yourself); 397106 add: ((self buildClassesWith: aBuilder) 397107 frame: (0.25 @ 0.00 corner: 0.50 @ 0.92 ); 397108 yourself); 397109 add: ((self buildStatusWith: aBuilder) 397110 frame: (0.50 @ 0.00 corner: 1.00 @ 0.08); 397111 yourself); 397112 add: ((self buildFailureListWith: aBuilder) 397113 frame: (0.50 @ 0.08 corner: 1.00 @ 0.50); 397114 yourself); 397115 add: ((self buildErrorListWith: aBuilder) 397116 frame: (0.50 @ 0.50 corner: 1.00 @ 0.92); 397117 yourself); 397118 add: ((self buildButtonsWith: aBuilder) 397119 frame: (0.00 @ 0.92 corner: 1.00 @ 1.00); 397120 yourself); 397121 yourself); 397122 yourself. 397123 ^ aBuilder build: window.! ! 397124 397125 397126!TestRunner methodsFor: 'history saving' stamp: 'simon.denier 11/13/2008 19:41'! 397127hasHistory 397128 397129 self flag: #Useless. "No Senders?" 397130 ^ true! ! 397131 397132!TestRunner methodsFor: 'history saving' stamp: 'simon.denier 11/13/2008 20:28'! 397133hasProgress 397134 397135 result classesTested do: [:cls | 397136 (cls class methodDictionary includesKey: #lastStoredRun) 397137 ifTrue: [^ true]]. 397138 ^ false! ! 397139 397140!TestRunner methodsFor: 'history saving' stamp: 'GwenaelCasaccio 10/1/2008 22:00'! 397141hasResults 397142 397143 ^ result notNil! ! 397144 397145!TestRunner methodsFor: 'history saving' stamp: 'AlexandreBergel 10/1/2008 12:00'! 397146historyMenuList 397147 ^ {'** save current result **'}, (self previousRun collect: [:ts | ts printString])! ! 397148 397149!TestRunner methodsFor: 'history saving' stamp: 'AlexandreBergel 10/1/2008 11:46'! 397150previousRun 397151 397152 ^ previousRun ifNil: [ previousRun := OrderedCollection new ]! ! 397153 397154!TestRunner methodsFor: 'history saving' stamp: 'simon.denier 11/13/2008 19:36'! 397155saveResultInHistory 397156 result dispatchResultsIntoHistory! ! 397157 397158!TestRunner methodsFor: 'history saving' stamp: 'AlexandreBergel 10/12/2008 11:55'! 397159showDiffWith: aTestResult 397160 | string diff | 397161 397162 diff := result diff: aTestResult. 397163 string := String streamContents: [:str| 397164 str nextPutAll: '----------------'; cr. 397165 str nextPutAll: 'Diff between current result with: ', aTestResult asString; cr. 397166 str nextPutAll: 'New passed: '. 397167 diff first do: [:s| str nextPutAll: s printString, ' ']. 397168 str cr. 397169 str nextPutAll: 'New failures: '. 397170 diff second do: [:s| str nextPutAll: s printString, ' ']. 397171 str cr. 397172 397173 str nextPutAll: 'New errors: '. 397174 diff third do: [:s| str nextPutAll: s printString, ' ']. 397175 str cr]. 397176 397177 Workspace new contents: string; openLabel: 'SUnit Progress' 397178 ! ! 397179 397180!TestRunner methodsFor: 'history saving' stamp: 'stephane.ducasse 10/12/2008 19:24'! 397181showHistoryMenu 397182 | selectionIndex selectedPreviousResult actionIndex | 397183 selectionIndex := UIManager default chooseFrom: self historyMenuList title: 'History:'. 397184 397185 "We pressed outside the menu" 397186 selectionIndex isZero ifTrue: [ ^ self ]. 397187 397188 "save current result is selected" 397189 selectionIndex = 1 ifTrue: [ self previousRun addFirst: result. ^ self ]. 397190 397191 selectedPreviousResult := self previousRun at: (selectionIndex - 1). 397192 actionIndex := (UIManager default chooseFrom: #('delete' 'show diff') title: 'Action:'). 397193 actionIndex = 1 ifTrue: [ self previousRun remove: selectedPreviousResult. ^ self ]. 397194 actionIndex = 2 ifTrue: [ self showDiffWith: selectedPreviousResult]. ! ! 397195 397196!TestRunner methodsFor: 'history saving' stamp: 'simon.denier 11/13/2008 17:02'! 397197showProgress 397198 | testCaseClasses d t string | 397199 testCaseClasses := (self suiteAll tests collect: [:testCase | testCase class]) asSet. 397200 397201 "At the end of the algorithm, d will contains all the diff between what was saved and the current result" 397202 d := Dictionary new. 397203 d at: #passed put: OrderedCollection new. 397204 d at: #failures put: OrderedCollection new. 397205 d at: #errors put: OrderedCollection new. 397206 397207 testCaseClasses do: [ :cls | 397208 (cls class methodDict includesKey: #lastStoredRun) 397209 ifTrue: [t := cls lastStoredRun. 397210 (t at: #passed) do: [:s | 397211 (result isErrorFor: cls selector: s) 397212 ifTrue: [(d at: #errors) add: {cls . s}]. 397213 (result isFailureFor: cls selector: s) 397214 ifTrue: [(d at: #failures) add: {cls . s}] ]. 397215 397216 (t at: #failures) do: [:s | (result isPassedFor: cls selector: s) 397217 ifTrue: [(d at: #passed) add: {cls . s}]. 397218 (result isErrorFor: cls selector: s) 397219 ifTrue: [(d at: #errors) add: {cls . s}]]. 397220 397221 (t at: #errors) do: [:s | (result isPassedFor: cls selector: s) 397222 ifTrue: [(d at: #passed) add: {cls . s}]. 397223 (result isFailureFor: cls selector: s) 397224 ifTrue: [(d at: #failures) add: {cls . s}]]]]. 397225 397226 397227 string := String streamContents: [:str| 397228 str nextPutAll: '----------------'; cr. 397229 str nextPutAll: 'Diff between current result and saved result'; cr. 397230 str nextPutAll: 'New passed: '. 397231 (d at: #passed) do: [:s| str nextPutAll: s printString, ' ']. 397232 str cr. 397233 str nextPutAll: 'New failures: '. 397234 (d at: #failures) do: [:s| str nextPutAll: s printString, ' ']. 397235 str cr. 397236 397237 str nextPutAll: 'New errors: '. 397238 (d at: #errors) do: [:s| str nextPutAll: s printString, ' ']. 397239 str cr]. 397240 397241 Workspace new contents: string; openLabel: 'SUnit Progress' string. 397242 397243 ! ! 397244 397245!TestRunner methodsFor: 'history saving' stamp: 'simon.denier 11/13/2008 20:28'! 397246storeResultIntoTestCases 397247 397248 result classesTested do: [:testCaseCls | testCaseCls generateLastStoredRunMethod ] 397249! ! 397250 397251 397252!TestRunner methodsFor: 'initialization' stamp: 'lr 3/22/2006 19:36'! 397253initialize 397254 super initialize. 397255 failedList := errorList := Array new. 397256 SystemChangeNotifier uniqueInstance 397257 notify: self ofSystemChangesOfItem: #class change: #Added using: #update; 397258 notify: self ofSystemChangesOfItem: #category change: #Added using: #update; 397259 notify: self ofSystemChangesOfItem: #class change: #Removed using: #update; 397260 notify: self ofSystemChangesOfItem: #category change: #Removed using: #update; 397261 notify: self ofSystemChangesOfItem: #class change: #Renamed using: #update; 397262 notify: self ofSystemChangesOfItem: #category change: #Renamed using: #update; 397263 notify: self ofSystemChangesOfItem: #class change: #Recategorized using: #update; 397264 notify: self ofSystemChangesOfItem: #category change: #Recategorized using: #update. 397265 self update; reset! ! 397266 397267 397268!TestRunner methodsFor: 'processing' stamp: 'lr 10/31/2005 17:43'! 397269basicRunSuite: aTestSuite do: aBlock 397270 self basicSetUpSuite: aTestSuite. 397271 [ aTestSuite name isEmptyOrNil 397272 ifTrue: [ aTestSuite tests do: aBlock ] 397273 ifFalse: [ aTestSuite tests do: aBlock displayingProgress: aTestSuite name ] ] 397274 ensure: [ self basicTearDownSuite: aTestSuite ]. 397275 ! ! 397276 397277!TestRunner methodsFor: 'processing' stamp: 'lr 10/27/2005 10:04'! 397278basicSetUpSuite: aTestSuite 397279 aTestSuite resources do: [ :each | 397280 each isAvailable 397281 ifFalse: [ each signalInitializationError ] ].! ! 397282 397283!TestRunner methodsFor: 'processing' stamp: 'lr 10/27/2005 10:04'! 397284basicTearDownSuite: aTestSuite 397285 aTestSuite resources do: [ :each | each reset ].! ! 397286 397287 397288!TestRunner methodsFor: 'testing' stamp: 'lr 11/21/2005 13:19'! 397289hasErrors 397290 ^ result hasErrors.! ! 397291 397292!TestRunner methodsFor: 'testing' stamp: 'lr 11/21/2005 13:19'! 397293hasFailures 397294 ^ result hasFailures.! ! 397295 397296!TestRunner methodsFor: 'testing' stamp: 'lr 11/21/2005 13:19'! 397297hasRunnable 397298 ^ classesSelected notEmpty.! ! 397299 397300 397301!TestRunner methodsFor: 'updating' stamp: 'lr 3/22/2006 19:35'! 397302update 397303 self updateCategories; updateClasses! ! 397304 397305!TestRunner methodsFor: 'updating' stamp: 'lr 10/31/2005 15:45'! 397306updateCategories 397307 categories := self findCategories. 397308 categoriesSelected := categoriesSelected isNil 397309 ifTrue: [ Set new ] 397310 ifFalse: [ 397311 categoriesSelected 397312 select: [ :each | categories includes: each ] ]. 397313 self changed: #categoryList; changed: #categorySelected.! ! 397314 397315!TestRunner methodsFor: 'updating' stamp: 'lr 1/20/2009 14:48'! 397316updateClasses 397317 | classesForCategories | 397318 classesForCategories := self findClassesForCategories: categoriesSelected. 397319 classes := classesForCategories asArray 397320 sort: [ :a :b | self sortClass: a before: b ]. 397321 classIndex := 0. 397322 classesSelected := classesSelected isNil 397323 ifTrue: [ classesForCategories ] 397324 ifFalse: [ 397325 classesSelected 397326 select: [ :each | classesForCategories includes: each ] ]. 397327 self changed: #classList; changed: #classSelected; changed: #hasRunnable.! ! 397328 397329!TestRunner methodsFor: 'updating' stamp: 'AlexandreBergel 10/1/2008 23:09'! 397330updateResults 397331 "<lint: #expect rule: #guardingClause>" 397332 "<lint: #expect rule: #longMethods>" 397333 397334 self updateStatus: false. 397335 failedList size = result failures size ifFalse: [ 397336 failedList := result failures asArray 397337 sort: [ :a :b | a printString <= b printString ]. 397338 failedSelected := nil. 397339 self 397340 changed: #failedList; 397341 changed: #failedSelected; 397342 changed: #hasFailures; 397343 changed: #hasProgress ]. 397344 errorList size = result errors size ifFalse: [ 397345 errorList := result errors asArray 397346 sort: [ :a :b | a printString <= b printString ]. 397347 errorSelected := nil. 397348 self 397349 changed: #errorList; 397350 changed: #errorSelected; 397351 changed: #hasErrors; 397352 changed: #hasProgress ].! ! 397353 397354!TestRunner methodsFor: 'updating' stamp: 'lr 11/3/2005 09:28'! 397355updateStatus: aBoolean 397356 "Update the status display, at most once a second if aBoolean is true." 397357 397358 (aBoolean and: [ lastUpdate = Time totalSeconds ]) 397359 ifTrue: [ ^ self ]. 397360 self changed: #statusText; changed: #statusColor. 397361 lastUpdate := Time totalSeconds.! ! 397362 397363 397364!TestRunner methodsFor: 'utilities' stamp: 'marcus.denker 11/10/2008 10:04'! 397365findCategories 397366 | visible | 397367 visible := Set new. 397368 self baseClass withAllSubclassesDo: [ :each | 397369 each category ifNotNil: [ :category | 397370 visible add: category ] ]. 397371 ^ Array streamContents: [ :stream | 397372 Smalltalk organization categories do: [ :each | 397373 (visible includes: each) 397374 ifTrue: [ stream nextPut: each ] ] ].! ! 397375 397376!TestRunner methodsFor: 'utilities' stamp: 'lr 10/31/2005 16:05'! 397377findClassesForCategories: aCollection 397378 | items | 397379 aCollection isEmpty 397380 ifTrue: [ ^ self baseClass withAllSubclasses ]. 397381 items := aCollection gather: [ :category | 397382 ((Smalltalk organization listAtCategoryNamed: category) 397383 collect: [ :each | Smalltalk at: each ]) 397384 select: [ :each | each includesBehavior: self baseClass ] ]. 397385 ^ items asSet.! ! 397386 397387!TestRunner methodsFor: 'utilities' stamp: 'lr 10/10/2005 08:43'! 397388sortClass: aFirstClass before: aSecondClass 397389 | first second | 397390 first := aFirstClass withAllSuperclasses reversed. 397391 second := aSecondClass withAllSuperclasses reversed. 397392 1 to: (first size min: second size) do: [ :index | 397393 (first at: index) == (second at: index) 397394 ifFalse: [ ^ (first at: index) name <= (second at: index) name ] ]. 397395 ^ second includes: aFirstClass.! ! 397396 397397 397398!TestRunner methodsFor: 'private' stamp: 'lr 11/21/2005 13:36'! 397399browserEnvironment 397400 ^ Smalltalk classNamed: #BrowserEnvironment.! ! 397401 397402!TestRunner methodsFor: 'private' stamp: 'lr 10/28/2005 13:28'! 397403defaultBackgroundColor 397404 "<lint: #expect rule: #overridesSuper rational: 'we want a different color than the parent'>" 397405 397406 ^ Color orange.! ! 397407 397408!TestRunner methodsFor: 'private' stamp: 'lr 10/27/2005 10:32'! 397409label: aString forSuite: aTestSuite 397410 ^ String streamContents: [ :stream | 397411 stream nextPutAll: 'Running '; print: aTestSuite tests size; space; nextPutAll: aString. 397412 aTestSuite tests size > 1 ifTrue: [ stream nextPut: $s ] ]. ! ! 397413 397414!TestRunner methodsFor: 'private' stamp: 'lr 12/21/2005 10:39'! 397415perform: selector orSendTo: otherTarget 397416 "<lint: #expect rule: #badMessage rational: 'this is a common morphic pattern'>" 397417 397418 ^ (self respondsTo: selector) 397419 ifTrue: [ self perform: selector ] 397420 ifFalse: [ super perform: selector orSendTo: otherTarget ].! ! 397421 397422!TestRunner methodsFor: 'private' stamp: 'lr 3/22/2006 19:26'! 397423windowIsClosing 397424 SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self! ! 397425 397426"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 397427 397428TestRunner class 397429 instanceVariableNames: ''! 397430 397431!TestRunner class methodsFor: 'initialization' stamp: 'lr 12/7/2005 13:56'! 397432initialize 397433 self registerInWorldMenu; registerInToolsFlap.! ! 397434 397435!TestRunner class methodsFor: 'initialization' stamp: 'KR 4/28/2006 21:06'! 397436registerInToolsFlap 397437 self environment at: #Flaps ifPresent: [ :class | 397438 class 397439 registerQuad: #( TestRunner build 'SUnit Runner' 'A production scale test-runner.' ) forFlapNamed: 'Tools'; 397440 replaceToolsFlap ].! ! 397441 397442!TestRunner class methodsFor: 'initialization' stamp: 'md 1/13/2006 18:14'! 397443registerInWorldMenu 397444 self environment at: #TheWorldMenu ifPresent: [ :class | 397445 class registerOpenCommand: (Array 397446 with: 'Test Runner' 397447 with: (Array 397448 with: self 397449 with: #open)) ].! ! 397450 397451 397452!TestRunner class methodsFor: 'instance-creation' stamp: 'KR 4/28/2006 21:07'! 397453build 397454 ^ ToolBuilder build: self new.! ! 397455 397456!TestRunner class methodsFor: 'instance-creation' stamp: 'lr 10/8/2005 18:35'! 397457open 397458 ^ ToolBuilder open: self new.! ! 397459Object subclass: #TestSuite 397460 instanceVariableNames: 'tests resources name' 397461 classVariableNames: '' 397462 poolDictionaries: '' 397463 category: 'SUnit-Kernel'! 397464!TestSuite commentStamp: '<historical>' prior: 0! 397465This is a Composite of Tests, either TestCases or other TestSuites. The common protocol is #run: aTestResult and the dependencies protocol! 397466 397467 397468!TestSuite methodsFor: 'accessing'! 397469addTest: aTest 397470 self tests add: aTest 397471 ! ! 397472 397473!TestSuite methodsFor: 'accessing'! 397474addTests: aCollection 397475 aCollection do: [:eachTest | self addTest: eachTest] 397476 ! ! 397477 397478!TestSuite methodsFor: 'accessing'! 397479defaultResources 397480 ^self tests 397481 inject: Set new 397482 into: [:coll :testCase | 397483 coll 397484 addAll: testCase resources; 397485 yourself] 397486 ! ! 397487 397488!TestSuite methodsFor: 'accessing'! 397489name 397490 397491 ^name 397492 ! ! 397493 397494!TestSuite methodsFor: 'accessing'! 397495name: aString 397496 397497 name := aString 397498 ! ! 397499 397500!TestSuite methodsFor: 'accessing'! 397501resources 397502 resources isNil ifTrue: [resources := self defaultResources]. 397503 ^resources 397504 ! ! 397505 397506!TestSuite methodsFor: 'accessing'! 397507resources: anObject 397508 resources := anObject 397509 ! ! 397510 397511!TestSuite methodsFor: 'accessing'! 397512tests 397513 tests isNil ifTrue: [tests := OrderedCollection new]. 397514 ^tests 397515 ! ! 397516 397517 397518!TestSuite methodsFor: 'dependencies' stamp: 'md 2/22/2006 14:24'! 397519addDependentToHierachy: anObject 397520 self addDependent: anObject. 397521 self tests do: [ :each | each addDependentToHierachy: anObject] 397522 ! ! 397523 397524!TestSuite methodsFor: 'dependencies' stamp: 'md 2/22/2006 14:24'! 397525removeDependentFromHierachy: anObject 397526 self removeDependent: anObject. 397527 self tests do: [ :each | each removeDependentFromHierachy: anObject] 397528 ! ! 397529 397530 397531!TestSuite methodsFor: 'running' stamp: 'stephane.ducasse 10/9/2008 18:36'! 397532run 397533 | result | 397534 result := TestResult new. 397535 self resources do: [ :res | 397536 res isAvailable ifFalse: [^res signalInitializationError]]. 397537 [self run: result] ensure: [self resources do: [:each | each reset]]. 397538 ^result 397539 ! ! 397540 397541!TestSuite methodsFor: 'running' stamp: 'stephane.ducasse 10/9/2008 18:36'! 397542run: aResult 397543 self tests do: [:each | 397544 self changed: each. 397545 each run: aResult]. 397546 ! ! 397547 397548"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 397549 397550TestSuite class 397551 instanceVariableNames: ''! 397552 397553!TestSuite class methodsFor: 'instance creation'! 397554named: aString 397555 397556 ^self new 397557 name: aString; 397558 yourself 397559 ! ! 397560TestCase subclass: #TestURI 397561 instanceVariableNames: '' 397562 classVariableNames: '' 397563 poolDictionaries: '' 397564 category: 'NetworkTests-URI'! 397565!TestURI commentStamp: 'mir 2/27/2002 14:42' prior: 0! 397566Main comment stating the purpose of this class and relevant relationship to other classes. 397567 397568 397569 Some parsers allow the scheme name to be present in a relative URI if 397570 it is the same as the base URI scheme. This is considered to be a 397571 loophole in prior specifications of partial URI [RFC1630]. Its use 397572 should be avoided. 397573 397574 http:g = http:g ; for validating parsers 397575 | http://a/b/c/g ; for backwards compatibility 397576! 397577 397578 397579!TestURI methodsFor: 'running file' stamp: 'mir 6/20/2005 17:17'! 397580testDefaultDirRoundtrip 397581 | defaultDir defaultURI uriDir | 397582 defaultDir := FileDirectory default. 397583 defaultURI := defaultDir uri. 397584 uriDir := FileDirectory uri: defaultURI. 397585 self should: [defaultDir fullName = uriDir fullName]! ! 397586 397587!TestURI methodsFor: 'running file' stamp: 'mir 6/20/2005 17:19'! 397588testDirectoryRoot 397589 397590 | rootDir uriRoot uriDir | 397591 rootDir := FileDirectory root. 397592 uriRoot := 'file:///' asURI. 397593 uriDir := FileDirectory uri: uriRoot. 397594 self should: [rootDir fullName = uriDir fullName]! ! 397595 397596 397597!TestURI methodsFor: 'running parsing' stamp: 'mir 2/20/2002 17:21'! 397598testSchemeAbsoluteFail1 397599 self should: [URI fromString: 'http:'] raise: IllegalURIException! ! 397600 397601!TestURI methodsFor: 'running parsing' stamp: 'mir 2/20/2002 17:24'! 397602testSchemeAbsolutePass1 397603 | uri | 397604 uri := URI fromString: 'http://www.squeakland.org'. 397605 self should: [uri scheme = 'http']. 397606 self should: [uri isAbsolute]. 397607 self shouldnt: [uri isOpaque]. 397608 self shouldnt: [uri isRelative]! ! 397609 397610!TestURI methodsFor: 'running parsing' stamp: 'mir 2/20/2002 17:25'! 397611testSchemeAbsolutePass2 397612 | uri | 397613 uri := URI fromString: 'mailto:somebody@somewhere.nowhere'. 397614 self should: [uri scheme = 'mailto']. 397615 self should: [uri isAbsolute]. 397616 self should: [uri isOpaque]. 397617 self shouldnt: [uri isRelative]! ! 397618 397619!TestURI methodsFor: 'running parsing' stamp: 'mir 2/20/2002 17:32'! 397620testSchemeAbsolutePass3 397621 | uri | 397622 uri := URI fromString: 'ftp://ftp@squeak.org'. 397623 self should: [uri scheme = 'ftp']. 397624 self should: [uri isAbsolute]. 397625 self shouldnt: [uri isOpaque]. 397626 self shouldnt: [uri isRelative]. 397627 self should: [uri userInfo = 'ftp']. 397628 self should: [uri host = 'squeak.org']. 397629 self should: [uri port isNil]. 397630! ! 397631 397632!TestURI methodsFor: 'running parsing' stamp: 'mir 2/20/2002 17:38'! 397633testSchemeAbsolutePass4 397634 | uri | 397635 uri := URI fromString: 'mailto:somebody@somewhere.nowhere#fragment'. 397636 self should: [uri scheme = 'mailto']. 397637 self should: [uri isAbsolute]. 397638 self should: [uri isOpaque]. 397639 self shouldnt: [uri isRelative]. 397640 self should: [uri fragment = 'fragment']. 397641! ! 397642 397643!TestURI methodsFor: 'running parsing' stamp: 'mir 2/20/2002 17:39'! 397644testSchemeAbsolutePass5 397645 | uri | 397646 uri := URI fromString: 'http://www.squeakland.org#fragment'. 397647 self should: [uri scheme = 'http']. 397648 self should: [uri isAbsolute]. 397649 self shouldnt: [uri isOpaque]. 397650 self shouldnt: [uri isRelative]. 397651 self should: [uri fragment = 'fragment']. 397652! ! 397653 397654 397655!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397656testResolveAbnormal1 397657 | baseURI relURI resolvedURI | 397658 baseURI := 'http://a/b/c/d;p?q' asURI. 397659 relURI := '../../../g'. 397660 resolvedURI := baseURI resolveRelativeURI: relURI. 397661 self should: [resolvedURI asString = 'http://a/../g']. 397662! ! 397663 397664!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397665testResolveAbnormal10 397666 | baseURI relURI resolvedURI | 397667 baseURI := 'http://a/b/c/d;p?q' asURI. 397668 relURI := './g/.'. 397669 resolvedURI := baseURI resolveRelativeURI: relURI. 397670 self should: [resolvedURI asString = 'http://a/b/c/g/']. 397671! ! 397672 397673!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397674testResolveAbnormal11 397675 | baseURI relURI resolvedURI | 397676 baseURI := 'http://a/b/c/d;p?q' asURI. 397677 relURI := 'g/./h'. 397678 resolvedURI := baseURI resolveRelativeURI: relURI. 397679 self should: [resolvedURI asString = 'http://a/b/c/g/h']. 397680! ! 397681 397682!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397683testResolveAbnormal12 397684 | baseURI relURI resolvedURI | 397685 baseURI := 'http://a/b/c/d;p?q' asURI. 397686 relURI := 'g/../h'. 397687 resolvedURI := baseURI resolveRelativeURI: relURI. 397688 self should: [resolvedURI asString = 'http://a/b/c/h']. 397689! ! 397690 397691!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397692testResolveAbnormal13 397693 | baseURI relURI resolvedURI | 397694 baseURI := 'http://a/b/c/d;p?q' asURI. 397695 relURI := 'g;x=1/./y'. 397696 resolvedURI := baseURI resolveRelativeURI: relURI. 397697 self should: [resolvedURI asString = 'http://a/b/c/g;x=1/y']. 397698! ! 397699 397700!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397701testResolveAbnormal14 397702 | baseURI relURI resolvedURI | 397703 baseURI := 'http://a/b/c/d;p?q' asURI. 397704 relURI := 'g;x=1/../y'. 397705 resolvedURI := baseURI resolveRelativeURI: relURI. 397706 self should: [resolvedURI asString = 'http://a/b/c/y']. 397707! ! 397708 397709!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397710testResolveAbnormal15 397711 | baseURI relURI resolvedURI | 397712 baseURI := 'http://a/b/c/d;p?q' asURI. 397713 relURI := 'g?y/./x'. 397714 resolvedURI := baseURI resolveRelativeURI: relURI. 397715 self should: [resolvedURI asString = 'http://a/b/c/g?y/./x']. 397716! ! 397717 397718!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 16:12'! 397719testResolveAbnormal16 397720 | baseURI relURI resolvedURI | 397721 baseURI := 'http://a/b/c/d;p?q' asURI. 397722 relURI := 'g?y/../x'. 397723 resolvedURI := baseURI resolveRelativeURI: relURI. 397724 self should: [resolvedURI asString = 'http://a/b/c/g?y/../x']. 397725! ! 397726 397727!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397728testResolveAbnormal17 397729 | baseURI relURI resolvedURI | 397730 baseURI := 'http://a/b/c/d;p?q' asURI. 397731 relURI := 'g#s/./x'. 397732 resolvedURI := baseURI resolveRelativeURI: relURI. 397733 self should: [resolvedURI asString = 'http://a/b/c/g#s/./x']. 397734! ! 397735 397736!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397737testResolveAbnormal18 397738 | baseURI relURI resolvedURI | 397739 baseURI := 'http://a/b/c/d;p?q' asURI. 397740 relURI := 'g#s/../x'. 397741 resolvedURI := baseURI resolveRelativeURI: relURI. 397742 self should: [resolvedURI asString = 'http://a/b/c/g#s/../x']. 397743! ! 397744 397745!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397746testResolveAbnormal2 397747 | baseURI relURI resolvedURI | 397748 baseURI := 'http://a/b/c/d;p?q' asURI. 397749 relURI := '../../../../g'. 397750 resolvedURI := baseURI resolveRelativeURI: relURI. 397751 self should: [resolvedURI asString = 'http://a/../../g']. 397752! ! 397753 397754!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397755testResolveAbnormal3 397756 | baseURI relURI resolvedURI | 397757 baseURI := 'http://a/b/c/d;p?q' asURI. 397758 relURI := '/./g'. 397759 resolvedURI := baseURI resolveRelativeURI: relURI. 397760 self should: [resolvedURI asString = 'http://a/./g']. 397761! ! 397762 397763!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397764testResolveAbnormal4 397765 | baseURI relURI resolvedURI | 397766 baseURI := 'http://a/b/c/d;p?q' asURI. 397767 relURI := '/../g'. 397768 resolvedURI := baseURI resolveRelativeURI: relURI. 397769 self should: [resolvedURI asString = 'http://a/../g']. 397770! ! 397771 397772!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397773testResolveAbnormal5 397774 | baseURI relURI resolvedURI | 397775 baseURI := 'http://a/b/c/d;p?q' asURI. 397776 relURI := 'g.'. 397777 resolvedURI := baseURI resolveRelativeURI: relURI. 397778 self should: [resolvedURI asString = 'http://a/b/c/g.']. 397779! ! 397780 397781!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397782testResolveAbnormal6 397783 | baseURI relURI resolvedURI | 397784 baseURI := 'http://a/b/c/d;p?q' asURI. 397785 relURI := '.g'. 397786 resolvedURI := baseURI resolveRelativeURI: relURI. 397787 self should: [resolvedURI asString = 'http://a/b/c/.g']. 397788! ! 397789 397790!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397791testResolveAbnormal7 397792 | baseURI relURI resolvedURI | 397793 baseURI := 'http://a/b/c/d;p?q' asURI. 397794 relURI := 'g..'. 397795 resolvedURI := baseURI resolveRelativeURI: relURI. 397796 self should: [resolvedURI asString = 'http://a/b/c/g..']. 397797! ! 397798 397799!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397800testResolveAbnormal8 397801 | baseURI relURI resolvedURI | 397802 baseURI := 'http://a/b/c/d;p?q' asURI. 397803 relURI := '..g'. 397804 resolvedURI := baseURI resolveRelativeURI: relURI. 397805 self should: [resolvedURI asString = 'http://a/b/c/..g']. 397806! ! 397807 397808!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397809testResolveAbnormal9 397810 | baseURI relURI resolvedURI | 397811 baseURI := 'http://a/b/c/d;p?q' asURI. 397812 relURI := './../g'. 397813 resolvedURI := baseURI resolveRelativeURI: relURI. 397814 self should: [resolvedURI asString = 'http://a/b/g']. 397815! ! 397816 397817!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397818testResolveNormal1 397819 | baseURI relURI resolvedURI | 397820 baseURI := 'http://a/b/c/d;p?q' asURI. 397821 relURI := 'g:h'. 397822 resolvedURI := baseURI resolveRelativeURI: relURI. 397823 self should: [resolvedURI asString = 'g:h']. 397824! ! 397825 397826!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397827testResolveNormal10 397828 | baseURI relURI resolvedURI | 397829 baseURI := 'http://a/b/c/d;p?q' asURI. 397830 relURI := 'g?y#s'. 397831 resolvedURI := baseURI resolveRelativeURI: relURI. 397832 self should: [resolvedURI asString = 'http://a/b/c/g?y#s']. 397833! ! 397834 397835!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397836testResolveNormal11 397837 | baseURI relURI resolvedURI | 397838 baseURI := 'http://a/b/c/d;p?q' asURI. 397839 relURI := ';x'. 397840 resolvedURI := baseURI resolveRelativeURI: relURI. 397841 self should: [resolvedURI asString = 'http://a/b/c/;x']. 397842! ! 397843 397844!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397845testResolveNormal12 397846 | baseURI relURI resolvedURI | 397847 baseURI := 'http://a/b/c/d;p?q' asURI. 397848 relURI := 'g;x'. 397849 resolvedURI := baseURI resolveRelativeURI: relURI. 397850 self should: [resolvedURI asString = 'http://a/b/c/g;x']. 397851! ! 397852 397853!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397854testResolveNormal13 397855 | baseURI relURI resolvedURI | 397856 baseURI := 'http://a/b/c/d;p?q' asURI. 397857 relURI := 'g;x?y#s'. 397858 resolvedURI := baseURI resolveRelativeURI: relURI. 397859 self should: [resolvedURI asString = 'http://a/b/c/g;x?y#s']. 397860! ! 397861 397862!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397863testResolveNormal14 397864 | baseURI relURI resolvedURI | 397865 baseURI := 'http://a/b/c/d;p?q' asURI. 397866 relURI := '.'. 397867 resolvedURI := baseURI resolveRelativeURI: relURI. 397868 self should: [resolvedURI asString = 'http://a/b/c/']. 397869! ! 397870 397871!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397872testResolveNormal15 397873 | baseURI relURI resolvedURI | 397874 baseURI := 'http://a/b/c/d;p?q' asURI. 397875 relURI := './'. 397876 resolvedURI := baseURI resolveRelativeURI: relURI. 397877 self should: [resolvedURI asString = 'http://a/b/c/']. 397878! ! 397879 397880!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397881testResolveNormal16 397882 | baseURI relURI resolvedURI | 397883 baseURI := 'http://a/b/c/d;p?q' asURI. 397884 relURI := '..'. 397885 resolvedURI := baseURI resolveRelativeURI: relURI. 397886 self should: [resolvedURI asString = 'http://a/b/']. 397887! ! 397888 397889!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397890testResolveNormal17 397891 | baseURI relURI resolvedURI | 397892 baseURI := 'http://a/b/c/d;p?q' asURI. 397893 relURI := '../'. 397894 resolvedURI := baseURI resolveRelativeURI: relURI. 397895 self should: [resolvedURI asString = 'http://a/b/']. 397896! ! 397897 397898!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397899testResolveNormal18 397900 | baseURI relURI resolvedURI | 397901 baseURI := 'http://a/b/c/d;p?q' asURI. 397902 relURI := '../g'. 397903 resolvedURI := baseURI resolveRelativeURI: relURI. 397904 self should: [resolvedURI asString = 'http://a/b/g']. 397905! ! 397906 397907!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397908testResolveNormal19 397909 | baseURI relURI resolvedURI | 397910 baseURI := 'http://a/b/c/d;p?q' asURI. 397911 relURI := '../..'. 397912 resolvedURI := baseURI resolveRelativeURI: relURI. 397913 self should: [resolvedURI asString = 'http://a/']. 397914! ! 397915 397916!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397917testResolveNormal2 397918 | baseURI relURI resolvedURI | 397919 baseURI := 'http://a/b/c/d;p?q' asURI. 397920 relURI := 'g'. 397921 resolvedURI := baseURI resolveRelativeURI: relURI. 397922 self should: [resolvedURI asString = 'http://a/b/c/g']. 397923! ! 397924 397925!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397926testResolveNormal20 397927 | baseURI relURI resolvedURI | 397928 baseURI := 'http://a/b/c/d;p?q' asURI. 397929 relURI := '../../'. 397930 resolvedURI := baseURI resolveRelativeURI: relURI. 397931 self should: [resolvedURI asString = 'http://a/']. 397932! ! 397933 397934!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397935testResolveNormal21 397936 | baseURI relURI resolvedURI | 397937 baseURI := 'http://a/b/c/d;p?q' asURI. 397938 relURI := '../../g'. 397939 resolvedURI := baseURI resolveRelativeURI: relURI. 397940 self should: [resolvedURI asString = 'http://a/g']. 397941! ! 397942 397943!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397944testResolveNormal3 397945 | baseURI relURI resolvedURI | 397946 baseURI := 'http://a/b/c/d;p?q' asURI. 397947 relURI := './g'. 397948 resolvedURI := baseURI resolveRelativeURI: relURI. 397949 self should: [resolvedURI asString = 'http://a/b/c/g']. 397950! ! 397951 397952!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397953testResolveNormal4 397954 | baseURI relURI resolvedURI | 397955 baseURI := 'http://a/b/c/d;p?q' asURI. 397956 relURI := 'g/'. 397957 resolvedURI := baseURI resolveRelativeURI: relURI. 397958 self should: [resolvedURI asString = 'http://a/b/c/g/']. 397959! ! 397960 397961!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397962testResolveNormal5 397963 | baseURI relURI resolvedURI | 397964 baseURI := 'http://a/b/c/d;p?q' asURI. 397965 relURI := '/g'. 397966 resolvedURI := baseURI resolveRelativeURI: relURI. 397967 self should: [resolvedURI asString = 'http://a/g']. 397968! ! 397969 397970!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397971testResolveNormal6 397972 | baseURI relURI resolvedURI | 397973 baseURI := 'http://a/b/c/d;p?q' asURI. 397974 relURI := '//g'. 397975 resolvedURI := baseURI resolveRelativeURI: relURI. 397976 self should: [resolvedURI asString = 'http://g']. 397977! ! 397978 397979!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397980testResolveNormal7 397981 | baseURI relURI resolvedURI | 397982 baseURI := 'http://a/b/c/d;p?q' asURI. 397983 relURI := '?y'. 397984 resolvedURI := baseURI resolveRelativeURI: relURI. 397985 self should: [resolvedURI asString = 'http://a/b/c/?y']. 397986! ! 397987 397988!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397989testResolveNormal8 397990 | baseURI relURI resolvedURI | 397991 baseURI := 'http://a/b/c/d;p?q' asURI. 397992 relURI := 'g?y'. 397993 resolvedURI := baseURI resolveRelativeURI: relURI. 397994 self should: [resolvedURI asString = 'http://a/b/c/g?y']. 397995! ! 397996 397997!TestURI methodsFor: 'running resolving' stamp: 'mir 2/27/2002 14:42'! 397998testResolveNormal9 397999 | baseURI relURI resolvedURI | 398000 baseURI := 'http://a/b/c/d;p?q' asURI. 398001 relURI := 'g#s'. 398002 resolvedURI := baseURI resolveRelativeURI: relURI. 398003 self should: [resolvedURI asString = 'http://a/b/c/g#s']. 398004! ! 398005 398006"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 398007 398008TestURI class 398009 instanceVariableNames: ''! 398010 398011!TestURI class methodsFor: 'test generation' stamp: 'sd 3/20/2008 22:28'! 398012generateAbnormalResolverTests 398013 "TestURI generateAbnormalResolverTests" 398014 398015 | relURIString result method testPairs pair | 398016 398017 testPairs := #( 398018 #('../../../g' 'http://a/../g' ) 398019 #('../../../../g' 'http://a/../../g' ) 398020 #('/./g' 'http://a/./g' ) 398021 #('/../g' 'http://a/../g' ) 398022 #('g.' 'http://a/b/c/g.' ) 398023 #('.g' 'http://a/b/c/.g' ) 398024 #('g..' 'http://a/b/c/g..' ) 398025 #('..g' 'http://a/b/c/..g' ) 398026 #('./../g' 'http://a/b/g' ) 398027 #('./g/.' 'http://a/b/c/g/' ) 398028 #('g/./h' 'http://a/b/c/g/h' ) 398029 #('g/../h' 'http://a/b/c/h' ) 398030 #('g;x=1/./y' 'http://a/b/c/g;x=1/y' ) 398031 #('g;x=1/../y' 'http://a/b/c/y' ) 398032 #('g?y/./x' 'http://a/b/c/g?y/./x' ) 398033 #('g?y/../x' 'http://a/b/c/g?y/../x' ) 398034 #('g#s/./x' 'http://a/b/c/g#s/./x' ) 398035 #('g#s/../x' 'http://a/b/c/g#s/../x' ) 398036 ). 398037 1 to: testPairs size do: [:index | 398038 pair := testPairs at: index. 398039 relURIString := pair first. 398040 result := pair last. 398041 method := String streamContents: [:stream | 398042 stream nextPutAll: 'testResolveAbnormal' , index printString; cr. 398043 stream 398044 nextPutAll: ' | baseURI relURI resolvedURI |' ; cr; 398045 nextPutAll: ' baseURI := ''http://a/b/c/d;p?q'' asURI.' ; cr; 398046 nextPutAll: ' relURI := '; nextPut: $'; nextPutAll: relURIString; nextPutAll: '''.' ; cr; 398047 nextPutAll: ' resolvedURI := baseURI resolveRelativeURI: relURI.' ; cr; 398048 nextPutAll: ' self should: [resolvedURI asString = '''; nextPutAll: result; nextPutAll: '''].' ; cr]. 398049 self compile: method classified: 'running resolving']. 398050! ! 398051 398052!TestURI class methodsFor: 'test generation' stamp: 'sd 3/20/2008 22:28'! 398053generateNormalResolverTests 398054 "TestURI generateNormalResolverTests" 398055 398056 | relURIString result method testPairs pair | 398057 398058 testPairs := #( 398059 #('g:h' 'g:h' ) 398060 #('g' 'http://a/b/c/g' ) 398061 #('./g' 'http://a/b/c/g' ) 398062 #('g/' 'http://a/b/c/g/' ) 398063 #('/g' 'http://a/g' ) 398064 #('//g' 'http://g' ) 398065 #('?y' 'http://a/b/c/?y' ) 398066 #('g?y' 'http://a/b/c/g?y' ) 398067 #('g#s' 'http://a/b/c/g#s' ) 398068 #('g?y#s' 'http://a/b/c/g?y#s' ) 398069 #(';x' 'http://a/b/c/;x' ) 398070 #('g;x' 'http://a/b/c/g;x' ) 398071 #('g;x?y#s' 'http://a/b/c/g;x?y#s' ) 398072 #('.' 'http://a/b/c/' ) 398073 #('./' 'http://a/b/c/' ) 398074 #('..' 'http://a/b/' ) 398075 #('../' 'http://a/b/' ) 398076 #('../g' 'http://a/b/g' ) 398077 #('../..' 'http://a/' ) 398078 #('../../' 'http://a/' ) 398079 #('../../g' 'http://a/g' ) 398080 ). 398081 1 to: testPairs size do: [:index | 398082 pair := testPairs at: index. 398083 relURIString := pair first. 398084 result := pair last. 398085 method := String streamContents: [:stream | 398086 stream nextPutAll: 'testResolveNormal' , index printString; cr. 398087 stream 398088 nextPutAll: ' | baseURI relURI resolvedURI |' ; cr; 398089 nextPutAll: ' baseURI := ''http://a/b/c/d;p?q'' asURI.' ; cr; 398090 nextPutAll: ' relURI := '; nextPut: $'; nextPutAll: relURIString; nextPutAll: '''.' ; cr; 398091 nextPutAll: ' resolvedURI := baseURI resolveRelativeURI: relURI.' ; cr; 398092 nextPutAll: ' self should: [resolvedURI asString = '''; nextPutAll: result; nextPutAll: '''].' ; cr]. 398093 self compile: method classified: 'running resolving']. 398094! ! 398095TestCase subclass: #TestValueWithinFix 398096 instanceVariableNames: '' 398097 classVariableNames: '' 398098 poolDictionaries: '' 398099 category: 'Tests-Bugs'! 398100 398101!TestValueWithinFix methodsFor: 'tests' stamp: 'ar 8/17/2007 13:38'! 398102testValueWithinNonLocalReturnFixReal 398103 "self run: #testValueWithinNonLocalReturnFixReal" 398104 "The real test for the fix is just as obscure as the original problem" 398105 | startTime deltaTime | 398106 self valueWithinNonLocalReturn. 398107 startTime := Time millisecondClockValue. 398108 [[] repeat] valueWithin: 100 milliSeconds onTimeout:[ 398109 "This *should* timeout after 100 msecs but the pending process from 398110 the previous invokation will signal timeout after 20 msecs already 398111 which will in turn cut this invokation short." 398112 deltaTime := Time millisecondClockValue - startTime. 398113 self deny: deltaTime < 90. 398114 ]. 398115! ! 398116 398117!TestValueWithinFix methodsFor: 'tests' stamp: 'ar 8/17/2007 13:38'! 398118testValueWithinNonLocalReturnFixSimply 398119 "self run: #testValueWithinNonLocalReturnFixSimply" 398120 "The simple version to test the fix" 398121 self valueWithinNonLocalReturn. 398122 self shouldnt:[(Delay forMilliseconds: 50) wait] raise: TimedOut.! ! 398123 398124!TestValueWithinFix methodsFor: 'tests' stamp: 'ar 8/17/2007 13:37'! 398125valueWithinNonLocalReturn 398126 "Do a non-local return from a valueWithin: block" 398127 [^self] valueWithin: 20 milliSeconds onTimeout:[]. 398128! ! 398129ArrayedCollection subclass: #Text 398130 instanceVariableNames: 'string runs' 398131 classVariableNames: '' 398132 poolDictionaries: 'TextConstants' 398133 category: 'Collections-Text'! 398134!Text commentStamp: '<historical>' prior: 0! 398135I represent a character string that has been marked with abstract changes in character appearance. Actual display is performed in the presence of a TextStyle which indicates, for each abstract code, an actual font to be used. A Text associates a set of TextAttributes with each character in its character string. These attributes may be font numbers, emphases such as bold or italic, or hyperling actions. Font numbers are interpreted relative to whatever textStyle appears, along with the text, in a Paragraph. Since most characters have the same attributes as their neighbors, the attributes are stored in a RunArray for efficiency. Each of my instances has 398136 string a String 398137 runs a RunArray! 398138]style[(148 9 97 13 237 9 163 6 10 8)f1,f1LTextStyle Comment;,f1,f1LTextAttribute Hierarchy;,f1,f1LParagraph Comment;,f1,f1LString Comment;,f1,f1LRunArray Comment;! 398139 398140 398141!Text methodsFor: '*morphic-converting' stamp: 'nk 2/26/2004 13:32'! 398142asMorph 398143 ^ self asTextMorph! ! 398144 398145!Text methodsFor: '*morphic-converting' stamp: 'nk 2/26/2004 13:31'! 398146asStringMorph 398147 ^ StringMorph 398148 contents: self string 398149 font: (self fontAt: 1 withStyle: TextStyle default) 398150 emphasis: (self emphasisAt: 1)! ! 398151 398152!Text methodsFor: '*morphic-converting' stamp: 'nk 2/26/2004 13:32'! 398153asTextMorph 398154 ^ TextMorph new contentsAsIs: self! ! 398155 398156 398157!Text methodsFor: 'accessing' stamp: 'tk 9/4/2000 16:04'! 398158append: stringOrText 398159 398160 self replaceFrom: string size + 1 398161 to: string size with: stringOrText! ! 398162 398163!Text methodsFor: 'accessing'! 398164at: index 398165 398166 ^string at: index! ! 398167 398168!Text methodsFor: 'accessing'! 398169at: index put: character 398170 398171 ^string at: index put: character! ! 398172 398173!Text methodsFor: 'accessing' stamp: 'gm 2/15/2003 14:59'! 398174embeddedMorphs 398175 "return the list of morphs embedded in me" 398176 398177 | morphs | 398178 morphs := IdentitySet new. 398179 runs withStartStopAndValueDo: 398180 [:start :stop :attribs | 398181 attribs 398182 do: [:attrib | attrib anchoredMorph ifNotNil: [morphs add: attrib anchoredMorph]]]. 398183 ^morphs select: [:m | m isMorph]! ! 398184 398185!Text methodsFor: 'accessing' stamp: 'gm 2/15/2003 14:59'! 398186embeddedMorphsFrom: start to: stop 398187 "return the list of morphs embedded in me" 398188 398189 | morphs | 398190 morphs := IdentitySet new. 398191 runs 398192 runsFrom: start 398193 to: stop 398194 do: 398195 [:attribs | 398196 attribs 398197 do: [:attr | attr anchoredMorph ifNotNil: [morphs add: attr anchoredMorph]]]. 398198 ^morphs select: [:m | m isMorph]! ! 398199 398200!Text methodsFor: 'accessing'! 398201findString: aString startingAt: start 398202 "Answer the index of subString within the receiver, starting at index 398203 start. If the receiver does not contain subString, answer 0." 398204 398205 ^string findString: aString asString startingAt: start! ! 398206 398207!Text methodsFor: 'accessing' stamp: 'di 11/23/1998 11:53'! 398208findString: aString startingAt: start caseSensitive: caseSensitive 398209 "Answer the index of subString within the receiver, starting at index 398210 start. If the receiver does not contain subString, answer 0." 398211 398212 ^string findString: aString asString startingAt: start caseSensitive: caseSensitive! ! 398213 398214!Text methodsFor: 'accessing' stamp: 'tk 9/6/2000 12:33'! 398215lineCount 398216 398217 ^ string lineCount! ! 398218 398219!Text methodsFor: 'accessing' stamp: 'ar 12/27/2001 00:03'! 398220prepend: stringOrText 398221 398222 self replaceFrom: 1 to: 0 with: stringOrText! ! 398223 398224!Text methodsFor: 'accessing' stamp: 'BG 6/8/2003 16:18'! 398225rangeOf: attribute startingAt: index 398226"Answer an interval that gives the range of attribute at index position index. An empty interval with start value index is returned when the attribute is not present at position index. " 398227 ^string size = 0 398228 ifTrue: [index to: index - 1] 398229 ifFalse: [runs rangeOf: attribute startingAt: index]! ! 398230 398231!Text methodsFor: 'accessing' stamp: 'tk 12/30/97 07:17'! 398232replaceFrom: start to: stop with: aText 398233 398234 | txt | 398235 txt := aText asText. "might be a string" 398236 string := string copyReplaceFrom: start to: stop with: txt string. 398237 runs := runs copyReplaceFrom: start to: stop with: txt runs! ! 398238 398239!Text methodsFor: 'accessing' stamp: 'tween 9/13/2004 10:07'! 398240runs: anArray 398241 398242 runs := anArray! ! 398243 398244!Text methodsFor: 'accessing'! 398245size 398246 398247 ^string size! ! 398248 398249!Text methodsFor: 'accessing'! 398250string 398251 "Answer the string representation of the receiver." 398252 398253 ^string! ! 398254 398255 398256!Text methodsFor: 'attributes' stamp: 'tk 11/1/2001 14:37'! 398257basicType 398258 "Answer a symbol representing the inherent type I hold" 398259 398260 "Number String Boolean player collection sound color etc" 398261 ^ #Text! ! 398262 398263!Text methodsFor: 'attributes' stamp: 'marcus.denker 11/21/2008 22:07'! 398264unembellished 398265 "Return true if the only emphases are the default font and bold" 398266 | font1 bold | 398267 font1 := TextFontChange defaultFontChange. 398268 bold := TextEmphasis bold. 398269 "If preference is set, then ignore any combo of font1 and bold" 398270 runs withStartStopAndValueDo: 398271 [:start :stop :emphArray | 398272 emphArray do: 398273 [:emph | (font1 = emph or: [bold = emph]) ifFalse: [^ false]]]. 398274 ^ true! ! 398275 398276 398277!Text methodsFor: 'comparing' stamp: 'tk 10/17/2001 14:12'! 398278hash 398279 "#hash is implemented, because #= is implemented. We are now equal to a string with the same characters. Hash must reflect that." 398280 398281 ^ string hash! ! 398282 398283!Text methodsFor: 'comparing' stamp: 'tk 9/6/2000 11:59'! 398284howManyMatch: aString 398285 398286 ^ self string howManyMatch: aString! ! 398287 398288!Text methodsFor: 'comparing'! 398289isText 398290 ^ true! ! 398291 398292!Text methodsFor: 'comparing' stamp: 'tk 10/19/2001 17:48'! 398293= other 398294 "Am I equal to the other Text or String? 398295 ***** Warning ***** Two Texts are considered equal if they have the same characters in them. They might have completely different emphasis, fonts, sizes, text actions, or embedded morphs. If you need to find out if one is a true copy of the other, you must do (text1 = text2 and: [text1 runs = text2 runs])." 398296 398297 other isText ifTrue: ["This is designed to run fast even for megabytes" 398298 ^ string == other string or: [string = other string]]. 398299 other isString ifTrue: [^ string == other or: [string = other]]. 398300 ^ false! ! 398301 398302 398303!Text methodsFor: 'converting'! 398304asDisplayText 398305 "Answer a DisplayText whose text is the receiver." 398306 398307 ^DisplayText text: self! ! 398308 398309!Text methodsFor: 'converting'! 398310asNumber 398311 "Answer the number created by interpreting the receiver as the textual 398312 representation of a number." 398313 398314 ^string asNumber! ! 398315 398316!Text methodsFor: 'converting' stamp: 'ar 4/12/2005 17:32'! 398317asOctetStringText 398318 398319 string class == WideString ifTrue: [ 398320 ^ self class string: string asOctetString runs: self runs copy. 398321 ]. 398322 ^self. 398323! ! 398324 398325!Text methodsFor: 'converting'! 398326asParagraph 398327 "Answer a Paragraph whose text is the receiver." 398328 398329 ^Paragraph withText: self! ! 398330 398331!Text methodsFor: 'converting'! 398332asString 398333 "Answer a String representation of the textual receiver." 398334 398335 ^string! ! 398336 398337!Text methodsFor: 'converting' stamp: 'RAA 5/28/2001 06:19'! 398338asStringOrText 398339 "Answer the receiver itself." 398340 398341 ^self! ! 398342 398343!Text methodsFor: 'converting'! 398344asText 398345 "Answer the receiver itself." 398346 398347 ^self! ! 398348 398349!Text methodsFor: 'converting' stamp: 'ls 7/14/1998 03:17'! 398350asUrl 398351 ^self asString asUrl! ! 398352 398353!Text methodsFor: 'converting' stamp: 'ls 7/14/1998 03:20'! 398354asUrlRelativeTo: aUrl 398355 ^self asString asUrlRelativeTo: aUrl! ! 398356 398357!Text methodsFor: 'converting' stamp: 'stephane.ducasse 4/13/2009 15:06'! 398358isoToSqueak 398359 self deprecated: 'Not necessary anymore with unicode fixes'. 398360 ^self "no longer needed"! ! 398361 398362!Text methodsFor: 'converting' stamp: 'stephane.ducasse 4/13/2009 15:06'! 398363macToSqueak 398364 "Convert the receiver from MacRoman to Squeak encoding" 398365 self deprecated: 'Not necessary anymore with unicode fixes'. 398366 ^ self class new setString: string macToSqueak setRuns: runs copy! ! 398367 398368!Text methodsFor: 'converting' stamp: 'PeterHugossonMiller 9/3/2009 11:44'! 398369removeAttributesThat: removalBlock replaceAttributesThat: replaceBlock by: convertBlock 398370 "Enumerate all attributes in the receiver. Remove those passing removalBlock and replace those passing replaceBlock after converting it through convertBlock" 398371 | added removed new | 398372 "Deliberately optimized for the no-op default." 398373 added := removed := nil. 398374 runs withStartStopAndValueDo: [ :start :stop :attribs | 398375 attribs do: [ :attrib | 398376 (removalBlock value: attrib) ifTrue:[ 398377 removed ifNil:[removed := Array new writeStream]. 398378 removed nextPut: {start. stop. attrib}. 398379 ] ifFalse:[ 398380 (replaceBlock value: attrib) ifTrue:[ 398381 removed ifNil:[removed := Array new writeStream]. 398382 removed nextPut: {start. stop. attrib}. 398383 new := convertBlock value: attrib. 398384 added ifNil:[added := Array new writeStream]. 398385 added nextPut: {start. stop. new}. 398386 ]. 398387 ]. 398388 ]. 398389 ]. 398390 (added isNil and:[removed isNil]) ifTrue:[^self]. 398391 "otherwise do the real work" 398392 removed ifNotNil:[removed contents do:[:spec| 398393 self removeAttribute: spec last from: spec first to: spec second]]. 398394 added ifNotNil:[added contents do:[:spec| 398395 self addAttribute: spec last from: spec first to: spec second]].! ! 398396 398397!Text methodsFor: 'converting' stamp: 'dvf 10/1/2003 02:58'! 398398replaceFrom: start to: stop with: replacement startingAt: repStart 398399 "This destructively replaces elements from start to stop in the receiver starting at index, repStart, in replacementCollection. Do it to both the string and the runs." 398400 398401 | rep newRepRuns | 398402 rep := replacement asText. "might be a string" 398403 string replaceFrom: start to: stop with: rep string startingAt: repStart. 398404 newRepRuns := rep runs copyFrom: repStart to: repStart + stop - start. 398405 runs := runs copyReplaceFrom: start to: stop with: newRepRuns! ! 398406 398407!Text methodsFor: 'converting' stamp: 'BG 6/8/2003 16:38'! 398408reversed 398409 398410 "Answer a copy of the receiver with element order reversed." 398411 398412 ^ self class string: string reversed runs: runs reversed. 398413 398414 " It is assumed that self size = runs size holds. "! ! 398415 398416!Text methodsFor: 'converting' stamp: 'stephane.ducasse 4/13/2009 15:06'! 398417squeakToIso 398418 self deprecated: 'Not necessary anymore with unicode fixes'. 398419 ^self "no longer needed"! ! 398420 398421!Text methodsFor: 'converting' stamp: 'stephane.ducasse 4/13/2009 15:06'! 398422squeakToMac 398423 "Convert the receiver from Squeak to MacRoman encoding" 398424 self deprecated: 'Not necessary anymore with unicode fixes'. 398425 ^ self class new setString: string squeakToMac setRuns: runs copy! ! 398426 398427!Text methodsFor: 'converting' stamp: 'nk 9/16/2003 16:46'! 398428withSqueakLineEndings 398429 "Answer a copy of myself in which all sequences of <CR><LF> or <LF> have been changed to <CR>" 398430 | newText | 398431 (string includes: Character lf) ifFalse: [ ^self copy ]. 398432 newText := self copyReplaceAll: String crlf with: String cr asTokens: false. 398433 (newText asString includes: Character lf) ifFalse: [ ^newText ]. 398434 ^newText copyReplaceAll: String lf with: String cr asTokens: false.! ! 398435 398436 398437!Text methodsFor: 'copying'! 398438copy 398439 398440 ^ self class new setString: string copy setRuns: runs copy 398441! ! 398442 398443!Text methodsFor: 'copying' stamp: 'marcus.denker 7/24/2009 16:48'! 398444copyFrom: start to: stop 398445 "Answer a copied subrange of the receiver." 398446 398447 | realStart realStop | 398448 stop > self size 398449 ifTrue: [realStop := self size] "handle selection at end of string" 398450 ifFalse: [realStop := stop]. 398451 start < 1 398452 ifTrue: [realStart := 1] "handle selection before start of string" 398453 ifFalse: [realStart := start]. 398454 ^self class 398455 string: (string copyFrom: realStart to: realStop) 398456 runs: (runs copyFrom: realStart to: realStop)! ! 398457 398458!Text methodsFor: 'copying' stamp: 'BG 6/12/2003 13:11'! 398459copyReplaceFrom: start to: stop with: aTextOrString 398460 398461 | txt | 398462 txt := aTextOrString asText. "might be a string" 398463 ^self class 398464 string: (string copyReplaceFrom: start to: stop with: txt string) 398465 runs: (runs copyReplaceFrom: start to: stop with: txt runs) 398466! ! 398467 398468!Text methodsFor: 'copying' stamp: 'tk 1/7/98 10:58'! 398469copyReplaceTokens: oldSubstring with: newSubstring 398470 "Replace all occurrences of oldSubstring that are surrounded 398471 by non-alphanumeric characters" 398472 ^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: true 398473 "'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Snick'"! ! 398474 398475!Text methodsFor: 'copying' stamp: 'di 11/9/97 17:13'! 398476deepCopy 398477 398478 ^ self copy "Both string and runs are assumed to be read-only"! ! 398479 398480 398481!Text methodsFor: 'emphasis'! 398482addAttribute: att 398483 ^ self addAttribute: att from: 1 to: self size! ! 398484 398485!Text methodsFor: 'emphasis'! 398486addAttribute: att from: start to: stop 398487 "Set the attribute for characters in the interval start to stop." 398488 runs := runs copyReplaceFrom: start to: stop 398489 with: ((runs copyFrom: start to: stop) 398490 mapValues: 398491 [:attributes | Text addAttribute: att toArray: attributes]) 398492! ! 398493 398494!Text methodsFor: 'emphasis' stamp: 'ar 12/17/2001 23:48'! 398495alignmentAt: characterIndex ifAbsent: aBlock 398496 | attributes emph | 398497 self size = 0 ifTrue: [^aBlock value]. 398498 emph := nil. 398499 attributes := runs at: characterIndex. 398500 attributes do:[:att | (att isKindOf: TextAlignment) ifTrue:[emph := att]]. 398501 ^ emph ifNil: aBlock ifNotNil:[emph alignment]! ! 398502 398503!Text methodsFor: 'emphasis'! 398504allBold 398505 "Force this whole text to be bold." 398506 string size = 0 ifTrue: [^self]. 398507 self makeBoldFrom: 1 to: string size! ! 398508 398509!Text methodsFor: 'emphasis' stamp: 'sw 12/7/1999 12:30'! 398510attributesAt: characterIndex 398511 "Answer the code for characters in the run beginning at characterIndex." 398512 "NB: no senders any more (supplanted by #attributesAt:forStyle: but retained for the moment in order not to break user code that may exist somewhere that still calls this" 398513 | attributes | 398514 self size = 0 398515 ifTrue: [^ Array with: (TextFontChange new fontNumber: 1)]. "null text tolerates access" 398516 attributes := runs at: characterIndex. 398517 ^ attributes! ! 398518 398519!Text methodsFor: 'emphasis' stamp: 'ar 12/17/2001 01:17'! 398520attributesAt: characterIndex do: aBlock 398521 "Answer the code for characters in the run beginning at characterIndex." 398522 "NB: no senders any more (supplanted by #attributesAt:forStyle: but retained for the moment in order not to break user code that may exist somewhere that still calls this" 398523 self size = 0 ifTrue:[^self]. 398524 (runs at: characterIndex) do: aBlock! ! 398525 398526!Text methodsFor: 'emphasis' stamp: 'sw 12/7/1999 11:32'! 398527attributesAt: characterIndex forStyle: aTextStyle 398528 "Answer the code for characters in the run beginning at characterIndex." 398529 | attributes | 398530 self size = 0 398531 ifTrue: [^ Array with: (TextFontChange new fontNumber: aTextStyle defaultFontIndex)]. "null text tolerates access" 398532 attributes := runs at: characterIndex. 398533 ^ attributes! ! 398534 398535!Text methodsFor: 'emphasis' stamp: 'di 4/1/1999 15:17'! 398536emphasisAt: characterIndex 398537 "Answer the fontfor characters in the run beginning at characterIndex." 398538 | attributes emph | 398539 self size = 0 ifTrue: [^ 0]. "null text tolerates access" 398540 emph := 0. 398541 attributes := runs at: characterIndex. 398542 attributes do: 398543 [:att | emph := emph bitOr: att emphasisCode]. 398544 ^ emph 398545 ! ! 398546 398547!Text methodsFor: 'emphasis' stamp: 'di 11/10/97 13:36'! 398548find: attribute 398549 "Return the first interval over which this attribute applies" 398550 | begin end | 398551 begin := 0. 398552 runs withStartStopAndValueDo: 398553 [:start :stop :attributes | 398554 (attributes includes: attribute) 398555 ifTrue: [begin = 0 ifTrue: [begin := start]. 398556 end := stop] 398557 ifFalse: [begin > 0 ifTrue: [^ begin to: end]]]. 398558 begin > 0 ifTrue: [^ begin to: end]. 398559 ^ nil! ! 398560 398561!Text methodsFor: 'emphasis' stamp: 'sw 12/7/1999 10:58'! 398562fontAt: characterIndex withStyle: aTextStyle 398563 "Answer the fontfor characters in the run beginning at characterIndex." 398564 | attributes font | 398565 self size = 0 ifTrue: [^ aTextStyle defaultFont]. "null text tolerates access" 398566 attributes := runs at: characterIndex. 398567 font := aTextStyle defaultFont. "default" 398568 attributes do: 398569 [:att | att forFontInStyle: aTextStyle do: [:f | font := f]]. 398570 ^ font! ! 398571 398572!Text methodsFor: 'emphasis'! 398573fontNumberAt: characterIndex 398574 "Answer the fontNumber for characters in the run beginning at characterIndex." 398575 | attributes fontNumber | 398576 self size = 0 ifTrue: [^1]. "null text tolerates access" 398577 attributes := runs at: characterIndex. 398578 fontNumber := 1. 398579 attributes do: [:att | (att isMemberOf: TextFontChange) ifTrue: [fontNumber := att fontNumber]]. 398580 ^ fontNumber 398581 ! ! 398582 398583!Text methodsFor: 'emphasis'! 398584makeBoldFrom: start to: stop 398585 398586 ^ self addAttribute: TextEmphasis bold from: start to: stop! ! 398587 398588!Text methodsFor: 'emphasis' stamp: 'md 1/20/2006 17:11'! 398589makeSelectorBold 398590 "For formatting Smalltalk source code, set the emphasis of that portion of 398591 the receiver's string that parses as a message selector to be bold." 398592 398593 | parser i | 398594 string size = 0 ifTrue: [^ self]. 398595 i := 0. 398596 [(string at: (i := i + 1)) isSeparator] whileTrue. 398597 (string at: i) = $[ ifTrue: [^ self]. "block, no selector" 398598 [(parser := Compiler parserClass new) parseSelector: string] on: Error do: [^ self]. 398599 self makeBoldFrom: 1 to: (parser endOfLastToken min: string size)! ! 398600 398601!Text methodsFor: 'emphasis' stamp: 'sma 2/5/2000 12:03'! 398602makeSelectorBoldIn: aClass 398603 "For formatting Smalltalk source code, set the emphasis of that portion of 398604 the receiver's string that parses as a message selector to be bold." 398605 398606 | parser | 398607 string size = 0 ifTrue: [^self]. 398608 (parser := aClass parserClass new) parseSelector: string. 398609 self makeBoldFrom: 1 to: (parser endOfLastToken min: string size)! ! 398610 398611!Text methodsFor: 'emphasis'! 398612removeAttribute: att from: start to: stop 398613 "Remove the attribute over the interval start to stop." 398614 runs := runs copyReplaceFrom: start to: stop 398615 with: ((runs copyFrom: start to: stop) 398616 mapValues: 398617 [:attributes | attributes copyWithout: att]) 398618! ! 398619 398620!Text methodsFor: 'emphasis'! 398621runLengthFor: characterIndex 398622 "Answer the count of characters remaining in run beginning with 398623 characterIndex." 398624 398625 ^runs runLengthAt: characterIndex! ! 398626 398627 398628!Text methodsFor: 'printing' stamp: 'sma 6/1/2000 09:49'! 398629printOn: aStream 398630 self printNameOn: aStream. 398631 aStream nextPutAll: ' for '; print: string! ! 398632 398633!Text methodsFor: 'printing'! 398634storeOn: aStream 398635 398636 aStream nextPutAll: '(Text string: '; 398637 store: string; 398638 nextPutAll: ' runs: '; 398639 store: runs; 398640 nextPut: $)! ! 398641 398642 398643!Text methodsFor: 'private'! 398644runs 398645 398646 ^runs! ! 398647 398648!Text methodsFor: 'private' stamp: 'tk 12/16/97 14:14'! 398649setString: aString setRunsChecking: aRunArray 398650 "Check runs and do the best you can to make them fit..." 398651 398652 string := aString. 398653 "check the runs" 398654 aRunArray ifNil: [^ aString asText]. 398655 (aRunArray isKindOf: RunArray) ifFalse: [^ aString asText]. 398656 aRunArray runs size = aRunArray values size ifFalse: [^ aString asText]. 398657 (aRunArray values includes: #()) ifTrue: [^ aString asText]. "not allowed?" 398658 aRunArray size = aString size ifFalse: [^ aString asText]. 398659 398660 runs := aRunArray.! ! 398661 398662!Text methodsFor: 'private'! 398663setString: aString setRuns: anArray 398664 398665 string := aString. 398666 runs := anArray! ! 398667 398668"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 398669 398670Text class 398671 instanceVariableNames: ''! 398672 398673!Text class methodsFor: 'initialization' stamp: 'mir 8/3/2004 13:30'! 398674initTextConstants 398675 "Initialize constants shared by classes associated with text display, e.g., 398676 Space, Tab, Cr, Bs, ESC." 398677 "1/24/96 sw: in exasperation and confusion, changed cmd-g mapping from 231 to 232 to see if I could gain any relief?!!" 398678 398679 398680 | letter varAndValue tempArray width | 398681 "CtrlA..CtrlZ, Ctrla..Ctrlz" 398682 letter := $A. 398683 #( 212 230 228 196 194 226 241 243 214 229 200 217 246 398684 245 216 202 210 239 211 240 197 198 209 215 242 231 398685 1 166 228 132 130 12 232 179 150 165 136 153 182 398686 14 15 138 17 18 19 11 21 134 145 151 178 167 ) do: 398687 [:kbd | 398688 TextConstants at: ('Ctrl', letter asSymbol) asSymbol put: kbd asCharacter. 398689 letter := letter == $Z ifTrue: [$a] ifFalse: [(letter asciiValue + 1) asCharacter]]. 398690 398691 varAndValue := #( 398692 Space 32 398693 Tab 9 398694 CR 13 398695 Enter 3 398696 BS 8 398697 BS2 158 398698 ESC 160 398699 Clear 173 398700 ). 398701 398702 varAndValue size odd ifTrue: [self error: 'unpaired text constant']. 398703 (2 to: varAndValue size by: 2) do: 398704 [:i | TextConstants at: (varAndValue at: i - 1) put: (varAndValue at: i) asCharacter]. 398705 398706 varAndValue := #( 398707 CtrlDigits (159 144 143 128 127 129 131 180 149 135) 398708 CtrlOpenBrackets (201 7 218 249 219 15) 398709 "lparen gottn by ctrl-:= = 201; should be 213 but can't type that on Mac" 398710 398711 "location of non-character stop conditions" 398712 EndOfRun 257 398713 CrossedX 258 398714 398715 "values for alignment" 398716 LeftFlush 0 398717 RightFlush 1 398718 Centered 2 398719 Justified 3 398720 398721 "subscripts for a marginTabsArray tuple" 398722 LeftMarginTab 1 398723 RightMarginTab 2 398724 398725 "font faces" 398726 Basal 0 398727 Bold 1 398728 Italic 2 398729 398730 "in case font doesn't have a width for space character" 398731 "some plausible numbers-- are they the right ones?" 398732 DefaultSpace 4 398733 DefaultTab 24 398734 DefaultLineGrid 16 398735 DefaultBaseline 12 398736 DefaultFontFamilySize 3 "basal, bold, italic" 398737 ). 398738 398739 varAndValue size odd ifTrue: [self error: 'unpaired text constant']. 398740 (2 to: varAndValue size by: 2) do: 398741 [:i | TextConstants at: (varAndValue at: i - 1) put: (varAndValue at: i)]. 398742 398743 TextConstants at: #DefaultRule put: Form over. 398744 TextConstants at: #DefaultMask put: Color black. 398745 398746 width := Display width max: 720. 398747 tempArray := Array new: width // DefaultTab. 398748 1 to: tempArray size do: 398749 [:i | tempArray at: i put: DefaultTab * i]. 398750 TextConstants at: #DefaultTabsArray put: tempArray. 398751 tempArray := Array new: (width // DefaultTab) // 2. 398752 1 to: tempArray size do: 398753 [:i | tempArray at: i put: (Array with: (DefaultTab*i) with: (DefaultTab*i))]. 398754 TextConstants at: #DefaultMarginTabsArray put: tempArray. 398755 398756"Text initTextConstants "! ! 398757 398758!Text class methodsFor: 'initialization'! 398759initialize "Text initialize" 398760 "Initialize constants shared by classes associated with text display." 398761 398762 TextConstants at: #CaretForm put: 398763 (Form extent: 16@5 398764 fromArray: #(2r001100e26 2r001100e26 2r011110e26 2r111111e26 2r110011e26) 398765 offset: -3@0). 398766 self initTextConstants! ! 398767 398768 398769!Text class methodsFor: 'instance creation' stamp: 'sw 12/6/1999 14:14'! 398770fromString: aString 398771 "Answer an instance of me whose characters are those of the argument, aString." 398772 398773 ^ self string: aString attribute: (TextFontChange fontNumber: TextStyle default defaultFontIndex)! ! 398774 398775!Text class methodsFor: 'instance creation' stamp: 'rbb 3/1/2005 11:18'! 398776fromUser 398777 "Answer an instance of me obtained by requesting the user to type a string." 398778 "Text fromUser" 398779 398780 ^ self fromString: 398781 (UIManager default request: 'Enter text followed by carriage return') 398782! ! 398783 398784!Text class methodsFor: 'instance creation'! 398785new: stringSize 398786 398787 ^self fromString: (String new: stringSize)! ! 398788 398789!Text class methodsFor: 'instance creation'! 398790streamContents: blockWithArg 398791 | stream | 398792 stream := TextStream on: (self new: 400). 398793 blockWithArg value: stream. 398794 ^ stream contents! ! 398795 398796!Text class methodsFor: 'instance creation'! 398797string: aString attribute: att 398798 "Answer an instance of me whose characters are aString. 398799 att is a TextAttribute." 398800 398801 ^self string: aString attributes: (Array with: att)! ! 398802 398803!Text class methodsFor: 'instance creation'! 398804string: aString attributes: atts 398805 "Answer an instance of me whose characters are those of aString. 398806 atts is an array of TextAttributes." 398807 398808 ^self string: aString runs: (RunArray new: aString size withAll: atts)! ! 398809 398810!Text class methodsFor: 'instance creation' stamp: 'adrian_lienhard 7/18/2009 16:03'! 398811string: aString emphasis: emphasis 398812 "This is an old method that is mainly used by old applications" 398813 398814 emphasis isNumber ifTrue: 398815 [self halt: 'Numeric emphasis is not supported'. 398816 "But if you proceed, we will do our best to give you what you want..." 398817 ^ self string: aString runs: (RunArray new: aString size withAll: 398818 (Array with: (TextFontChange new fontNumber: emphasis)))]. 398819 ^ self string: aString attributes: emphasis! ! 398820 398821 398822!Text class methodsFor: 'private' stamp: 'di 10/31/97 11:22'! 398823addAttribute: att toArray: others 398824 "Add a new text attribute to an existing set" 398825 "NOTE: The use of reset and set in this code is a specific 398826 hack for merging TextKerns." 398827 att reset. 398828 ^ Array streamContents: 398829 [:strm | others do: 398830 [:other | (att dominates: other) ifFalse: [strm nextPut: other]]. 398831 att set ifTrue: [strm nextPut: att]]! ! 398832 398833!Text class methodsFor: 'private'! 398834string: aString runs: anArray 398835 398836 ^self basicNew setString: aString setRuns: anArray! ! 398837TextAttribute subclass: #TextAction 398838 instanceVariableNames: '' 398839 classVariableNames: 'Purple' 398840 poolDictionaries: '' 398841 category: 'Collections-Text'! 398842 398843!TextAction methodsFor: 'as yet unclassified' stamp: 'nk 2/26/2005 09:49'! 398844analyze: aString 398845 "Analyze the selected text to find both the parameter to store and the text to emphesize (may be different from original selection). Does not return self!!. May be of the form: 3988463+4 398847<3+4> 398848Click Here<3+4> 398849<3+4>Click Here 398850" 398851 "Obtain the showing text and the instructions" 398852 | b1 b2 trim param show | 398853 b1 := aString indexOf: $<. 398854 b2 := aString indexOf: $>. 398855 (b1 < b2) & (b1 > 0) ifFalse: ["only one part" 398856 param := self validate: aString. 398857 param ifNil: [ ^{ nil. nil } ]. 398858 ^ Array with: param with: (param size = 0 ifTrue: [nil] ifFalse: [param])]. 398859 "Two parts" 398860 trim := aString withBlanksTrimmed. 398861 (trim at: 1) == $< 398862 ifTrue: [(trim last) == $> 398863 ifTrue: ["only instructions" 398864 param := self validate: (aString copyFrom: b1+1 to: b2-1). 398865 show := param size = 0 ifTrue: [nil] ifFalse: [param]] 398866 ifFalse: ["at the front" 398867 param := self validate: (aString copyFrom: b1+1 to: b2-1). 398868 show := param size = 0 ifTrue: [nil] 398869 ifFalse: [aString copyFrom: b2+1 to: aString size]]] 398870 ifFalse: [(trim last) == $> 398871 ifTrue: ["at the end" 398872 param := self validate: (aString copyFrom: b1+1 to: b2-1). 398873 show := param size = 0 ifTrue: [nil] 398874 ifFalse: [aString copyFrom: 1 to: b1-1]] 398875 ifFalse: ["Illegal -- <> has text on both sides" 398876 show := nil]]. 398877 ^ Array with: param with: show 398878! ! 398879 398880!TextAction methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:11'! 398881dominatedByCmd0 398882 "Cmd-0 should turn off active text" 398883 ^ true! ! 398884 398885!TextAction methodsFor: 'as yet unclassified' stamp: 'di 1/14/98 09:30'! 398886emphasizeScanner: scanner 398887 "Set the emphasis for text display" 398888 scanner textColor: Purple! ! 398889 398890!TextAction methodsFor: 'as yet unclassified' stamp: 'DSM 3/30/1999 13:15'! 398891info 398892 ^ 'no hidden info'! ! 398893 398894!TextAction methodsFor: 'as yet unclassified'! 398895mayActOnClick 398896 398897 ^ true! ! 398898 398899!TextAction methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 16:48'! 398900validate: aString 398901 "any format is OK with me" 398902 ^ aString! ! 398903 398904"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 398905 398906TextAction class 398907 instanceVariableNames: ''! 398908 398909!TextAction class methodsFor: 'as yet unclassified' stamp: 'di 1/14/98 09:30'! 398910initialize "TextAction initialize" 398911 Purple := Color r: 0.4 g: 0 b: 1.0! ! 398912TextAttribute subclass: #TextAlignment 398913 instanceVariableNames: 'alignment' 398914 classVariableNames: '' 398915 poolDictionaries: '' 398916 category: 'Collections-Text'! 398917 398918!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 12/15/2001 23:33'! 398919= other 398920 ^ (other class == self class) 398921 and: [other alignment = alignment]! ! 398922 398923!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 12/15/2001 23:33'! 398924alignment 398925 ^alignment! ! 398926 398927!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 12/15/2001 23:33'! 398928alignment: aNumber 398929 alignment := aNumber.! ! 398930 398931!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 12/16/2001 00:20'! 398932dominates: other 398933 "There can be only one..." 398934 ^self class == other class! ! 398935 398936!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 12/15/2001 23:34'! 398937emphasizeScanner: scanner 398938 "Set the emphasist for text scanning" 398939 scanner setAlignment: alignment.! ! 398940 398941!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 9/9/2003 22:03'! 398942hash 398943 "#hash is re-implemented because #= is re-implemented" 398944 ^ alignment hash! ! 398945 398946!TextAlignment methodsFor: 'as yet unclassified' stamp: 'ar 12/16/2001 01:55'! 398947writeScanOn: strm 398948 398949 strm nextPut: $a. 398950 alignment printOn: strm.! ! 398951 398952"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 398953 398954TextAlignment class 398955 instanceVariableNames: ''! 398956 398957!TextAlignment class methodsFor: 'as yet unclassified' stamp: 'KR 12/5/2005 00:53'! 398958alignmentSymbol: alignmentCode 398959 ^#(leftFlush rightFlush centered justified) at: (alignmentCode + 1)! ! 398960 398961 398962!TextAlignment class methodsFor: 'instance creation' stamp: 'ar 12/15/2001 23:36'! 398963centered 398964 ^self new alignment: 2! ! 398965 398966!TextAlignment class methodsFor: 'instance creation' stamp: 'ar 12/15/2001 23:36'! 398967justified 398968 ^self new alignment: 3! ! 398969 398970!TextAlignment class methodsFor: 'instance creation' stamp: 'ar 12/15/2001 23:35'! 398971leftFlush 398972 ^self new alignment: 0! ! 398973 398974!TextAlignment class methodsFor: 'instance creation' stamp: 'ar 12/15/2001 23:35'! 398975rightFlush 398976 ^self new alignment: 1! ! 398977HashAndEqualsTestCase subclass: #TextAlignmentTest 398978 instanceVariableNames: '' 398979 classVariableNames: '' 398980 poolDictionaries: '' 398981 category: 'CollectionsTests-Text'! 398982 398983!TextAlignmentTest methodsFor: 'initialization' stamp: 'mjr 8/20/2003 18:55'! 398984setUp 398985 super setUp. 398986 prototypes add: TextAlignment centered; 398987 add: TextAlignment justified; 398988 add: TextAlignment leftFlush; 398989 add: TextAlignment rightFlush ! ! 398990TextAttribute subclass: #TextAnchor 398991 instanceVariableNames: 'anchoredMorph' 398992 classVariableNames: '' 398993 poolDictionaries: '' 398994 category: 'Morphic-Text Support'! 398995!TextAnchor commentStamp: 'md 8/10/2006 11:52' prior: 0! 398996TextAnchors support anchoring of images in text. A TextAnchor exists as an attribute of text emphasis, and it gets control like a FontReference, through the emphasizeScanner: message. Depending on whether its anchoredMorph is a Morph or a Form, it repositions the morph, or displays the form respectively. The coordination between composition, display and selection can best be understood by browsing the various implementations of placeEmbeddedObject:. 398997 398998In the morphic world, simply embed any form or morph in text. 398999 399000 Workspace new 399001 contents: (Text withAll: 'foo') , (Text string: '*' attribute: (TextAnchor new anchoredMorph: MenuIcons confirmIcon)) , (Text withAll: 'bar'); 399002 openLabel: 'Text with Form'. 399003 399004 Workspace new 399005 contents: (Text withAll: 'foo') , (Text string: '*' attribute: (TextAnchor new anchoredMorph: EllipseMorph new)) , (Text withAll: 'bar'); 399006 openLabel: 'Text with Morph'. 399007 399008In this case you select a piece of the screen, and it gets anchored to a one-character text in the editor's past buffer. If you then paste into some other text, you will see the image as an embedded image.! 399009 399010 399011!TextAnchor methodsFor: 'accessing' stamp: 'di 11/10/97 13:21'! 399012anchoredMorph 399013 ^ anchoredMorph! ! 399014 399015!TextAnchor methodsFor: 'accessing' stamp: 'di 11/10/97 10:47'! 399016anchoredMorph: aMorph 399017 anchoredMorph := aMorph! ! 399018 399019!TextAnchor methodsFor: 'accessing' stamp: 'di 11/10/97 14:08'! 399020mayBeExtended 399021 "A textAnchor is designed to modify only a single character, and therefore must not be extended by the ParagraphEditor's emphasisHere facility" 399022 ^ false! ! 399023 399024 399025!TextAnchor methodsFor: 'comparing' stamp: 'di 7/1/1998 14:35'! 399026= other 399027 ^ (other class == self class) 399028 and: [other anchoredMorph == anchoredMorph]! ! 399029 399030!TextAnchor methodsFor: 'comparing' stamp: 'ar 9/9/2003 22:03'! 399031hash 399032 "#hash is re-implemented because #= is re-implemented" 399033 ^anchoredMorph identityHash! ! 399034 399035 399036!TextAnchor methodsFor: 'visiting' stamp: 'lr 2/3/2006 16:13'! 399037emphasizeScanner: aScanner 399038 self anchoredMorph ifNil: [ ^ self ]. 399039 aScanner placeEmbeddedObject: self anchoredMorph.! ! 399040 399041"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 399042 399043TextAnchor class 399044 instanceVariableNames: ''! 399045HashAndEqualsTestCase subclass: #TextAnchorTest 399046 instanceVariableNames: '' 399047 classVariableNames: '' 399048 poolDictionaries: '' 399049 category: 'MorphicTests-Text Support'! 399050 399051!TextAnchorTest methodsFor: 'initialization' stamp: 'mjr 8/20/2003 18:55'! 399052setUp 399053 super setUp. 399054 prototypes 399055 add: (TextAnchor new anchoredMorph: RectangleMorph new initialize); 399056 399057 add: (TextAnchor new anchoredMorph: EllipseMorph new initialize) ! ! 399058TestCase subclass: #TextAndTextStreamTest 399059 instanceVariableNames: '' 399060 classVariableNames: '' 399061 poolDictionaries: '' 399062 category: 'CollectionsTests-Text'! 399063!TextAndTextStreamTest commentStamp: '<historical>' prior: 0! 399064At May 09, 2003 Tim Olson sent a bug report to the Squeak developers list that inspired me to examine the protocol of TextStream in greater detail. (The bug that Tim reported was present in Squeak 3.4, it is shown in testExample1.) In a discussion that followed, Daniel Vainsencher proposed that we should have tests for Text and TextStreams. This class is an attempt to implement that proposal. For Squeak 3.4, some of the test examples fail.! 399065 399066 399067!TextAndTextStreamTest methodsFor: 'examples' stamp: 'BG 6/10/2003 20:17'! 399068example1: size 399069 399070 | ts text | 399071 399072 ts := TextStream on: (Text new: size). 399073 ts nextPutAll: 'xxxxx' asText. 399074 ts nextPutAll: ('yyyyy' asText allBold, 'zzzzzzz' asText). 399075 text := ts contents. 399076 ^text 399077 ! ! 399078 399079!TextAndTextStreamTest methodsFor: 'examples' stamp: 'BG 6/10/2003 20:26'! 399080example2 399081 399082 | ts text | 399083 399084 ts := TextStream on: (Text new: 50). 399085 ts nextPutAll: 'abc' asText. 399086 ts nextPutAll: 'def' asText allBold. 399087 ts nextPutAll: 'ghijk' asText. 399088 text := ts contents. 399089 ^text 399090 ! ! 399091 399092!TextAndTextStreamTest methodsFor: 'examples' stamp: 'BG 6/11/2003 13:09'! 399093replacementAtStartExample3 399094 399095 | text1 replacement length | 399096 399097 text1 := 'This is a simple text' copy asText. 399098 " without the copy, we would modify a constant that the compiler attached at the compiled method. " 399099 length := 'This' size. 399100 replacement := 'Tht' asText. 399101 text1 replaceFrom: 1 399102 to: length 399103 with: replacement 399104 startingAt: 1. 399105! ! 399106 399107!TextAndTextStreamTest methodsFor: 'examples' stamp: 'BG 6/11/2003 13:05'! 399108replacementExample3 399109 399110 " for a Text t, 399111 the following assertion should always hold: 399112 t string size = t run size 399113 This test examines the preservation of this assertion for in-place replacement 399114 Here, the replacement text is shorteer than the text that is shall replace. " 399115 399116 399117 | text1 string replacement startPos length startPosInRep string2 | 399118 399119 text1 := (string := 'This is again simple text' copy) asText. 399120 " without the copy, we would modify a constant that the compiler attached at the compiled method. " 399121 startPos := string findString: 'simple'. 399122 length := 'simple' size. 399123 replacement := (string2 := 'both simple and short') asText. 399124 startPosInRep := string2 findString: 'short'. 399125 text1 replaceFrom: startPos 399126 to: startPos + length - 1 399127 with: replacement 399128 startingAt: startPosInRep. 399129 399130! ! 399131 399132 399133!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:45'! 399134testAddStringToTextStream 399135 399136 "It is possible to add a string into a TextStream. 399137 This test verifies that the created text has text attributes for all its characters. " 399138 399139 | ts text | 399140 ts := TextStream on: (Text new: 50). 399141 ts nextPutAll: 'abc' asText. 399142 ts nextPutAll: 'def' asText allBold. 399143 ts nextPutAll: 'ghijk'. 399144 text := ts contents. 399145 " now, check the fundamental invariant of a text: " 399146 self assert: text string size = text runs size. 399147! ! 399148 399149!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:40'! 399150testExampleText1 399151 "self run: #testExampleText1" 399152 "inspired by a bug report from Tim Olson. 399153 Text attributes are lost when the stream collection is expanded. 399154 Documented BUG!!!!!!" 399155 399156 | text1 text2 atts1 atts2 | 399157 text1 := self example1: 10. " here we will loose the attribute bold " 399158 text2 := self example1: 50. " here we have a larger buffer and will not loose text attributes " 399159 atts1 := text1 runs copyFrom: 6 to: 10. 399160 atts2 := text2 runs copyFrom: 6 to: 10. 399161 399162 self assert: atts1 = atts2. 399163 ! ! 399164 399165!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:40'! 399166testExampleText2 399167 "a Text looses its attributes when it is reversed " 399168 399169 | text1 text2 | 399170 text1 := self example2. 399171 text2 := text1 reversed reversed. 399172 self assert: text1 runs = text2 runs. 399173 399174! ! 399175 399176!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:35'! 399177testRunArrayAdjacentMerge 399178 399179 "this demonstrates that adjancent runs with equal attributes are merged. " 399180 | runArray | 399181 runArray := RunArray new. 399182 runArray 399183 addLast: TextEmphasis normal times: 5; 399184 addLast: TextEmphasis bold times: 5; 399185 addLast: TextEmphasis bold times: 5. 399186 self assert: (runArray runs size = 2). ! ! 399187 399188!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:37'! 399189testRunArrayInvariant 399190 399191 "this verifies that the fundamental invariant of a RunArray is always satisfied. " 399192 "see comment below" 399193 | runArray | 399194 runArray := RunArray new. 399195 runArray 399196 addLast: TextEmphasis normal times: 5; 399197 addLast: TextEmphasis bold times: 5; 399198 addLast: TextEmphasis normal times: 5. 399199 self assert: 399200 ((1 to: runArray size) allSatisfy: 399201 [:idx | | lastIndex lastOffset lastRun lengthOfPreviousRuns | 399202 runArray at: idx. " updates the cached values " 399203 lastIndex := runArray instVarNamed: 'lastIndex'. 399204 lastRun := runArray instVarNamed: 'lastRun'. 399205 lastOffset := runArray instVarNamed: 'lastOffset'. 399206 lengthOfPreviousRuns 399207 := (1 to: lastRun - 1) 399208 inject: 0 399209 into: [:sum :idx2 | sum + (runArray runs at: idx2)]. 399210 lastIndex = (lastOffset + lengthOfPreviousRuns + 1) 399211 ] 399212 ). 399213 399214" This method is a bit tricky. First, it uses Object>>instVarNamed: to access instance variables for which no accessors are defined. The same method is used by the debuggers and by various inspectors. 399215The assertion itself explains the meaning of the cached values."! ! 399216 399217!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:36'! 399218testRunArrayReversal 399219 399220 "this tests the reversal of a RunArray " 399221 | runArray | 399222 runArray := RunArray new. 399223 runArray 399224 addLast: TextEmphasis normal times: 5; 399225 addLast: TextEmphasis bold times: 5; 399226 addLast: TextEmphasis normal times: 5. 399227 self assert: (runArray reversed runs size = 3). ! ! 399228 399229!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:32'! 399230testRunArrayRunsAreNotMerged 399231 399232 " this demonstrates that different runs are not merged " 399233 | runArray | 399234 runArray := RunArray new. 399235 runArray 399236 addLast: TextEmphasis normal times: 5; 399237 addLast: TextEmphasis bold times: 5; 399238 addLast: TextEmphasis normal times: 5. 399239 self assert: (runArray runs size = 3). ! ! 399240 399241!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:33'! 399242testRunArrayRunsSize 399243 399244 "this demonstrates that the size of a run array is the sum of the sizes of its runs. " 399245 | runArray | 399246 runArray := RunArray new. 399247 runArray 399248 addLast: TextEmphasis normal times: 5; 399249 addLast: TextEmphasis bold times: 5; 399250 addLast: TextEmphasis normal times: 5. 399251 self assert: (runArray size = 15). ! ! 399252 399253!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:49'! 399254testTextEmphasisRangeDetection1 399255 399256 "this tests the detection of the range of a text attribute. " 399257 | text startPos boldStyle | 399258 text := 'This is a text with attriute bold for some characters' asText. 399259 startPos := text findString: 'bold' startingAt: 1. 399260 text addAttribute: TextEmphasis bold from: startPos to: startPos + 3. 399261 boldStyle := TextEmphasis bold. 399262 399263 " uncomment the following statement for examine failures: " 399264 " ----------------- 399265 (1 to: text size) do: 399266 [:idx | | range | 399267 range := text rangeOf: boldStyle startingAt: idx. 399268 Transcript show: startPos; show: ' -- '; show: idx printString; show: ' '; show: range printString; show: range size printString; show: ((idx between: startPos and: startPos + 3) 399269 ifTrue: 399270 [range first = startPos & (range size = 4)] 399271 ifFalse: 399272 [range first = idx & (range size = 0)]) printString; cr. 399273 ]. 399274 ------------- " 399275 399276 self assert: 399277 ((1 to: text size) allSatisfy: 399278 [:idx | | range | 399279 range := text rangeOf: boldStyle startingAt: idx. 399280 (idx between: startPos and: startPos + 3) 399281 ifTrue: [range first = startPos & (range size = 4)] 399282 ifFalse: [range first = idx & (range size = 0)]])! ! 399283 399284!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:51'! 399285testTextEmphasisRangeDetection2 399286 399287 "this tests the detection of the range of a text attribute. 399288 Here the searched attribute spans three runs. The objective of the test is whether the entire range is always found." 399289 | text startPos searchedStyle | 399290 text := 'This is a text with attriute bold for some characters' asText. 399291 startPos := text findString: 'bold' startingAt: 1. 399292 text addAttribute: TextEmphasis bold from: startPos to: startPos + 3. 399293 text addAttribute: TextEmphasis italic from: startPos - 2 to: startPos + 5. 399294 searchedStyle := TextEmphasis italic. 399295 399296 " uncomment the following statement for examine failures: " 399297 " ----------------------- 399298 (1 to: text size) do: 399299 [:idx | | range | 399300 range := text rangeOf: searchedStyle startingAt: idx. 399301 Transcript show: startPos; show: ' -- '; show: idx printString; show: ' '; show: range printString; show: range size printString; show: ((idx between: startPos - 2 and: startPos -2 + 7) 399302 ifTrue: 399303 [range first = (startPos - 2) & (range size = 8)] 399304 ifFalse: 399305 [range first = idx & (range size = 0)]) printString; cr. 399306 ]. 399307 ----------------------- " 399308 self assert: 399309 ((1 to: text size) allSatisfy: 399310 [:idx | | range | 399311 range := text rangeOf: searchedStyle startingAt: idx. 399312 (idx between: startPos - 2 and: startPos -2 + 7) 399313 ifTrue: [range first = (startPos - 2) & (range size = 8)] 399314 ifFalse: [range first = idx & (range size = 0)]])! ! 399315 399316!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:53'! 399317testTextEmphasisRangeDetection3 399318 399319 "this tests the detection of the range of a text attribute. 399320 Here the searched attribute spans three runs. The the range to be detected begins at text position 1. The objective of the test is whether the entire range is always found." 399321 399322 | text startPos searchedStyle | 399323 text := 'This is a text with attriute bold for some characters' asText. 399324 startPos := text findString: 'bold' startingAt: 1. 399325 text addAttribute: TextEmphasis bold from: startPos to: startPos + 3. 399326 text addAttribute: TextEmphasis italic from: 1 to: startPos + 5. 399327 searchedStyle := TextEmphasis italic. 399328 399329 " uncomment the following statement to examine failures: " 399330 " ----------------------- 399331 (1 to: text size) do: 399332 [:idx | | range | 399333 range := text rangeOf: searchedStyle startingAt: idx. 399334 Transcript show: startPos; 399335 show: ' -- '; 399336 show: idx printString; 399337 show: ' '; 399338 show: range printString; 399339 show: range size printString; 399340 show: ' '; 399341 show: ((idx between: 1 and: startPos + 5) 399342 ifTrue: 399343 [range first = 1 & (range size = (startPos + 5))] 399344 ifFalse: 399345 [range first = idx & (range size = 0)]) printString; cr. 399346 ]. 399347 ----------------------- " 399348 self assert: 399349 ((1 to: text size) allSatisfy: 399350 [:idx | | range | 399351 range := text rangeOf: searchedStyle startingAt: idx. 399352 (idx between: 1 and: startPos + 5) 399353 ifTrue: 399354 [range first = 1 & (range size = (startPos + 5))] 399355 ifFalse: 399356 [range first = idx & (range size = 0)]])! ! 399357 399358!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:55'! 399359testTextEmphasisRangeDetection4 399360 399361 "this tests the detection of the range of a text attribute. 399362 Here the searched attribute spans three runs. The the range to be detected extends to the end of the text . The objective of the test is whether the 399363 entire range is always found." 399364 399365 | text startPos searchedStyle | 399366 text := 'This is a text with attriute bold for some characters' asText. 399367 startPos := text findString: 'bold' startingAt: 1. 399368 text addAttribute: TextEmphasis bold from: startPos to: startPos + 3. 399369 text addAttribute: TextEmphasis italic from: startPos - 2 to: text size. 399370 searchedStyle := TextEmphasis italic. 399371 399372 " uncomment the following statement to examine failures: " 399373 399374 " ----------------------------------------- 399375 (1 to: text size) do: 399376 [:idx | | range | 399377 range := text rangeOf: searchedStyle startingAt: idx. 399378 Transcript show: startPos; 399379 show: ' -- '; 399380 show: idx printString; 399381 show: ' '; 399382 show: range printString; 399383 show: range size printString; 399384 show: ' '; 399385 show: ((idx between: startPos - 2 and: text size) 399386 ifTrue: 399387 [range first = (startPos - 2) & (range size = (text size - (startPos - 2) + 1))] 399388 ifFalse: 399389 [range first = idx & (range size = 0)]) printString; 399390 cr. 399391 ]. 399392 -------------------------------" 399393 399394 self assert: 399395 ((1 to: text size) allSatisfy: 399396 [:idx | | range | 399397 range := text rangeOf: searchedStyle startingAt: idx. 399398 (idx between: startPos - 2 and: text size) 399399 ifTrue: [range first = (startPos - 2) & (range size = (text size - (startPos - 2) + 1))] 399400 ifFalse: [range first = idx & (range size = 0)]])! ! 399401 399402!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:56'! 399403testTextReplacement1 399404 399405 "for a Text t, 399406 the following assertion should always hold: 399407 t string size = t run size 399408 This test examines the preservation of this assertion for in-place replacement " 399409 399410 | text1 string replacement startPos length startPosInRep string2 | 399411 text1 := (string := 'This is a simple text' copy) asText. 399412 "without the copy, we would modify a constant that the compiler attached at the compiled method. " 399413 startPos := string findString: 'simple'. 399414 length := 'simple' size. 399415 replacement := (string2 := 'both simple and short*') asText. 399416 startPosInRep := string2 findString: 'short'. 399417 text1 replaceFrom: startPos 399418 to: startPos + length - 1 399419 with: replacement 399420 startingAt: startPosInRep. 399421 self assert: text1 string size = text1 runs size. 399422! ! 399423 399424!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:57'! 399425testTextReplacement2 399426 399427 399428 "for a Text t, 399429 the following assertion should always hold: 399430 t string size = t run size 399431 This test examines the preservation of this assertion for in-place replacement. 399432 Here, the replacement text has trailing characters. " 399433 399434 | text1 string replacement startPos length startPosInRep string2 | 399435 text1 := (string := 'This is simple text' copy) asText. 399436 "without the copy, we would modify a constant that the compiler attached at the compiled method. " 399437 startPos := string findString: 'simple'. 399438 length := 'simple' size. 399439 replacement := (string2 := 'both simple and short*************') asText. 399440 startPosInRep := string2 findString: 'short'. 399441 text1 replaceFrom: startPos 399442 to: startPos + length - 1 399443 with: replacement 399444 startingAt: startPosInRep. 399445 self assert: text1 string size = text1 runs size. 399446! ! 399447 399448!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:58'! 399449testTextReplacement3 399450 399451 "for a Text t, 399452 the following assertion should always hold: 399453 t string size = t run size 399454 This test examines the preservation of this assertion for in-place replacement 399455 Here, the replacement text is shorteer than the text that is shall replace. " 399456 399457 self should: [self replacementExample3] raise: Error! ! 399458 399459!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:59'! 399460testTextReplacementAtStartPos1 399461 399462 "for a Text t, 399463 the following assertion should always hold: 399464 t string size = t run size 399465 This test examines the preservation of this assertion for in-place replacement " 399466 399467 | text1 replacement length | 399468 text1 := 'This is a simple text' copy asText. 399469 "without the copy, we would modify a constant that the compiler attached at the compiled method. " 399470 length := 'This' size. 399471 replacement := 'That' asText. 399472 text1 replaceFrom: 1 399473 to: length 399474 with: replacement 399475 startingAt: 1. 399476 self assert: text1 string size = text1 runs size. 399477! ! 399478 399479!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:00'! 399480testTextReplacementAtStartPos2 399481 399482 "for a Text t, 399483 the following assertion should always hold: 399484 t string size = t run size 399485 This test examines the preservation of this assertion for in-place replacement " 399486 399487 | text1 replacement length | 399488 text1 := 'This is a simple text' copy asText. 399489 "without the copy, we would modify a constant that the compiler attached at the compiled method. " 399490 length := 'This' size. 399491 replacement := 'That********' asText. 399492 text1 replaceFrom: 1 399493 to: length 399494 with: replacement 399495 startingAt: 1. 399496 self assert: text1 string size = text1 runs size. 399497! ! 399498 399499!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:00'! 399500testTextReplacementAtStartPos3 399501 399502 "for a Text t, 399503 the following assertion should always hold: 399504 t string size = t run size 399505 This test examines the preservation of this assertion for in-place replacement 399506 Here, the replacement text is shorteer than the text that is shall replace. " 399507 399508 self should: [self replacementAtStartExample3] raise: Error! ! 399509 399510!TextAndTextStreamTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:44'! 399511testTextStreamAdjacentRunsWithIdentitcalAttributes 399512 399513 "This test verifies that adjacent runs with identical attributes are coalesced." 399514 399515 | ts text rangeOfBold | 399516 ts := TextStream on: (Text new: 50). 399517 ts nextPutAll: 'abc' asText. 399518 ts nextPutAll: 'def' asText allBold. 399519 ts nextPutAll: 'ghijk'. 399520 text := ts contents. 399521 rangeOfBold := text find: TextEmphasis bold. 399522 text removeAttribute: TextEmphasis bold from: rangeOfBold first to: rangeOfBold last. 399523 "now, check that only one run is left and that it has the correct size " 399524 self assert: text runs runs size = 1 & (text runs size = text string size). 399525! ! 399526Object subclass: #TextAttribute 399527 instanceVariableNames: '' 399528 classVariableNames: '' 399529 poolDictionaries: '' 399530 category: 'Collections-Text'! 399531!TextAttribute commentStamp: 'tk 7/22/2002 18:33' prior: 0! 399532Tells a piece of text to be a certain way. 399533 399534Select text, press Command-6, choose a attribute. If selected text is of the form 399535 Hi There<Smalltalk beep> 399536the part in angle brackets is saved for action, and the Hi There appears in the paragraph. If selection has no angle brackets, use the whole thing as both the text and the action. 399537 399538TextDoIt -- eval as a Smalltalk expression (the part in angle brackets) 399539 399540TextLink -- Show a method, class comment, class hierarchy, or class defintion. 399541 <Point extent:>, <Point Comment>, <Point Hierarchy>, or <Point Defintion> are what you type. 399542 399543TextURL -- Show the web page. <www.disney.com> 399544 399545These attributes of text need to be stored on the disk in a regular file-out. It is done in this form: Hi There 399546 in the text, and a Run containing dSmalltalk beep;; 399547 Click here to see the extent: 399548 in the text, and a Run containing method LPoint extent:; 399549See RunArray class scanFrom: where decoding is done. 399550! 399551]style[(903 24 25)f1,f1LRunArray class scanFrom:;,f1! 399552 399553 399554!TextAttribute methodsFor: 'as yet unclassified'! 399555actOnClickFor: model 399556 "Subclasses may override to provide, eg, hot-spot actions" 399557 ^ false! ! 399558 399559!TextAttribute methodsFor: 'as yet unclassified' stamp: 'ar 9/22/2001 16:00'! 399560actOnClickFor: model in: aParagraph 399561 ^self actOnClickFor: model! ! 399562 399563!TextAttribute methodsFor: 'as yet unclassified' stamp: 'ar 9/22/2001 16:08'! 399564actOnClickFor: model in: aParagraph at: clickPoint 399565 ^self actOnClickFor: model in: aParagraph! ! 399566 399567!TextAttribute methodsFor: 'as yet unclassified' stamp: 'ar 9/22/2001 16:22'! 399568actOnClickFor: model in: aParagraph at: clickPoint editor: editor 399569 ^self actOnClickFor: model in: aParagraph at: clickPoint! ! 399570 399571!TextAttribute methodsFor: 'as yet unclassified' stamp: 'ar 12/16/2001 23:18'! 399572anchoredMorph 399573 "If one hides here, return it" 399574 ^nil! ! 399575 399576!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:09'! 399577dominatedByCmd0 399578 "Subclasses may override if cmd-0 should turn them off" 399579 ^ false! ! 399580 399581!TextAttribute methodsFor: 'as yet unclassified'! 399582dominates: another 399583 "Subclasses may override condense multiple attributes" 399584 ^ false! ! 399585 399586!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 4/1/1999 15:16'! 399587emphasisCode 399588 "Subclasses may override to add bold, italic, etc" 399589 ^ 0! ! 399590 399591!TextAttribute methodsFor: 'as yet unclassified'! 399592emphasizeScanner: scanner 399593 "Subclasses may override to set, eg, font, color, etc"! ! 399594 399595!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 11/9/97 17:46'! 399596forFontInStyle: aTextStyle do: aBlock 399597 "No action is the default. Overridden by font specs"! ! 399598 399599!TextAttribute methodsFor: 'as yet unclassified'! 399600mayActOnClick 399601 "Subclasses may override to provide, eg, hot-spot actions" 399602 ^ false! ! 399603 399604!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 11/10/97 14:05'! 399605mayBeExtended 399606 "A quality that may be overridden by subclasses, such as TextAnchors, that really only apply to a single character" 399607 ^ true! ! 399608 399609!TextAttribute methodsFor: 'as yet unclassified'! 399610oldEmphasisCode: default 399611 "Allows running thorugh possibly multiple attributes 399612 and getting the emphasis out of any that has an emphasis (font number)" 399613 ^ default! ! 399614 399615!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:03'! 399616reset 399617 "Allow subclasses to prepare themselves for merging attributes"! ! 399618 399619!TextAttribute methodsFor: 'as yet unclassified'! 399620set 399621 "Respond true to include this attribute (as opposed to, eg, a bold 399622 emphasizer that is clearing the property" 399623 ^ true! ! 399624 399625 399626!TextAttribute methodsFor: 'testing' stamp: 'ar 9/21/2000 14:16'! 399627isKern 399628 ^false! ! 399629TextAttribute subclass: #TextColor 399630 instanceVariableNames: 'color' 399631 classVariableNames: '' 399632 poolDictionaries: '' 399633 category: 'Collections-Text'! 399634!TextColor commentStamp: '<historical>' prior: 0! 399635A TextColor encodes a text color change applicable over a given range of text.! 399636 399637 399638!TextColor methodsFor: 'accessing'! 399639color 399640 ^ color! ! 399641 399642!TextColor methodsFor: 'accessing'! 399643color: aColor 399644 color := aColor! ! 399645 399646 399647!TextColor methodsFor: 'comparing' stamp: 'di 10/31/97 11:19'! 399648= other 399649 ^ (other class == self class) 399650 and: [other color = color]! ! 399651 399652!TextColor methodsFor: 'comparing' stamp: 'sma 3/24/2000 10:51'! 399653hash 399654 ^ color hash! ! 399655 399656 399657!TextColor methodsFor: 'printing' stamp: 'sma 3/24/2000 10:51'! 399658printOn: aStream 399659 super printOn: aStream. 399660 aStream nextPutAll: ' code: '; print: color! ! 399661 399662 399663!TextColor methodsFor: 'scanning' stamp: 'di 10/31/97 11:20'! 399664dominates: other 399665 ^ other class == self class! ! 399666 399667!TextColor methodsFor: 'scanning'! 399668emphasizeScanner: scanner 399669 "Set the emphasis for text display" 399670 scanner textColor: color! ! 399671 399672!TextColor methodsFor: 'scanning' stamp: 'tk 12/16/97 09:47'! 399673writeScanOn: strm 399674 "Two formats. c125000255 or cblue;" 399675 399676 | nn str | 399677 strm nextPut: $c. 399678 (nn := color name) ifNotNil: [ 399679 (self class respondsTo: nn) ifTrue: [ 399680 ^ strm nextPutAll: nn; nextPut: $;]]. 399681 (Array with: color red with: color green with: color blue) do: [:float | 399682 str := '000', (float * 255) asInteger printString. 399683 strm nextPutAll: (str copyFrom: str size-2 to: str size)]! ! 399684 399685"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 399686 399687TextColor class 399688 instanceVariableNames: ''! 399689 399690!TextColor class methodsFor: 'constants'! 399691black 399692 ^ self new color: Color black! ! 399693 399694!TextColor class methodsFor: 'constants'! 399695blue 399696 ^ self new color: Color blue! ! 399697 399698!TextColor class methodsFor: 'constants'! 399699cyan 399700 ^ self new color: Color cyan! ! 399701 399702!TextColor class methodsFor: 'constants' stamp: 'ajh 9/10/2002 02:26'! 399703gray 399704 ^ self new color: Color gray! ! 399705 399706!TextColor class methodsFor: 'constants'! 399707green 399708 ^ self new color: Color green! ! 399709 399710!TextColor class methodsFor: 'constants'! 399711magenta 399712 ^ self new color: Color magenta! ! 399713 399714!TextColor class methodsFor: 'constants'! 399715red 399716 ^ self new color: Color red! ! 399717 399718!TextColor class methodsFor: 'constants' stamp: 'sma 3/24/2000 10:50'! 399719white 399720 ^ self new color: Color white! ! 399721 399722!TextColor class methodsFor: 'constants'! 399723yellow 399724 ^ self new color: Color yellow! ! 399725 399726 399727!TextColor class methodsFor: 'instance creation'! 399728color: aColor 399729 ^ self new color: aColor! ! 399730 399731!TextColor class methodsFor: 'instance creation' stamp: 'sma 3/24/2000 10:49'! 399732scanFrom: strm 399733 "read a color in the funny format used by Text styles on files. c125000255 or cblue;" 399734 399735 | r g b | 399736 strm peek isDigit 399737 ifTrue: 399738 [r := (strm next: 3) asNumber. 399739 g := (strm next: 3) asNumber. 399740 b := (strm next: 3) asNumber. 399741 ^ self color: (Color r: r g: g b: b range: 255)]. 399742 "A name of a color" 399743 ^ self color: (Color perform: (strm upTo: $;) asSymbol)! ! 399744Object subclass: #TextComposer 399745 instanceVariableNames: 'lines maxRightX currentY scanner possibleSlide nowSliding prevIndex prevLines currCharIndex startCharIndex stopCharIndex deltaCharIndex theText theContainer isFirstLine theTextStyle defaultLineHeight actualHeight wantsColumnBreaks' 399746 classVariableNames: '' 399747 poolDictionaries: '' 399748 category: 'Morphic-Text Support'! 399749 399750!TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 18:09'! 399751addNullLineForIndex: index 399752"This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I couldn't figure out where to put it in the main logic." 399753 399754 | oldLastLine r | 399755 399756 oldLastLine := lines last. 399757 oldLastLine last - oldLastLine first >= 0 ifFalse: [^self]. 399758 oldLastLine last = (index - 1) ifFalse: [^self]. 399759 399760 r := oldLastLine left @ oldLastLine bottom 399761 extent: 0@(oldLastLine bottom - oldLastLine top). 399762 "Even though we may be below the bottom of the container, 399763 it is still necessary to compose the last line for consistency..." 399764 399765 self addNullLineWithIndex: index andRectangle: r. 399766! ! 399767 399768!TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/5/2001 11:05'! 399769addNullLineWithIndex: index andRectangle: r 399770 399771 lines addLast: ( 399772 ( 399773 TextLine 399774 start: index 399775 stop: index - 1 399776 internalSpaces: 0 399777 paddingWidth: 0 399778 ) 399779 rectangle: r; 399780 lineHeight: defaultLineHeight baseline: theTextStyle baseline 399781 ) 399782! ! 399783 399784!TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 11:33'! 399785checkIfReadyToSlide 399786 399787 "Check whether we are now in sync with previously composed lines" 399788 399789 (possibleSlide and: [currCharIndex > stopCharIndex]) ifFalse: [^self]. 399790 399791 [prevIndex < prevLines size 399792 and: [(prevLines at: prevIndex) first < (currCharIndex - deltaCharIndex)]] 399793 whileTrue: [prevIndex := prevIndex + 1]. 399794 399795 (prevLines at: prevIndex) first = (currCharIndex - deltaCharIndex) ifTrue: [ 399796 "Yes -- next line will have same start as prior line." 399797 prevIndex := prevIndex - 1. 399798 possibleSlide := false. 399799 nowSliding := true 399800 ] ifFalse: [ 399801 prevIndex = prevLines size ifTrue: [ 399802 "Weve reached the end of prevLines, so no use to keep looking for lines to slide." 399803 possibleSlide := false 399804 ] 399805 ]! ! 399806 399807!TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/6/2001 14:48'! 399808composeAllLines 399809 399810 [currCharIndex <= theText size and: 399811 [(currentY + defaultLineHeight) <= theContainer bottom]] whileTrue: [ 399812 399813 nowSliding ifTrue: [ 399814 self slideOneLineDown ifNil: [^nil]. 399815 ] ifFalse: [ 399816 self composeOneLine ifNil: [^nil]. 399817 ] 399818 ]. 399819! ! 399820 399821!TextComposer methodsFor: 'as yet unclassified' stamp: 'th 11/18/2002 19:13'! 399822composeAllRectangles: rectangles 399823 399824 | charIndexBeforeLine numberOfLinesBefore reasonForStopping | 399825 399826 actualHeight := defaultLineHeight. 399827 charIndexBeforeLine := currCharIndex. 399828 numberOfLinesBefore := lines size. 399829 reasonForStopping := self composeEachRectangleIn: rectangles. 399830 399831 currentY := currentY + actualHeight. 399832 currentY > theContainer bottom ifTrue: [ 399833 "Oops -- the line is really too high to fit -- back out" 399834 currCharIndex := charIndexBeforeLine. 399835 lines size - numberOfLinesBefore timesRepeat: [lines removeLast]. 399836 ^self 399837 ]. 399838 399839 "It's OK -- the line still fits." 399840 maxRightX := maxRightX max: scanner rightX. 399841 1 to: rectangles size - 1 do: [ :i | 399842 "Adjust heights across rectangles if necessary" 399843 (lines at: lines size - rectangles size + i) 399844 lineHeight: lines last lineHeight 399845 baseline: lines last baseline 399846 ]. 399847 isFirstLine := false. 399848 reasonForStopping == #columnBreak ifTrue: [^nil]. 399849 currCharIndex > theText size ifTrue: [ 399850 ^nil "we are finished composing" 399851 ]. 399852 ! ! 399853 399854!TextComposer methodsFor: 'as yet unclassified' stamp: 'ar 12/17/2001 01:59'! 399855composeEachRectangleIn: rectangles 399856 399857 | myLine lastChar | 399858 399859 1 to: rectangles size do: [:i | 399860 currCharIndex <= theText size ifFalse: [^false]. 399861 myLine := scanner 399862 composeFrom: currCharIndex 399863 inRectangle: (rectangles at: i) 399864 firstLine: isFirstLine 399865 leftSide: i=1 399866 rightSide: i=rectangles size. 399867 lines addLast: myLine. 399868 actualHeight := actualHeight max: myLine lineHeight. "includes font changes" 399869 currCharIndex := myLine last + 1. 399870 lastChar := theText at: myLine last. 399871 lastChar = Character cr ifTrue: [^#cr]. 399872 wantsColumnBreaks ifTrue: [ 399873 lastChar = TextComposer characterForColumnBreak ifTrue: [^#columnBreak]. 399874 ]. 399875 ]. 399876 ^false! ! 399877 399878!TextComposer methodsFor: 'as yet unclassified' stamp: 'ASB 8/7/2008 13:28'! 399879composeLinesFrom: argStart to: argStop delta: argDelta into: argLinesCollection priorLines: argPriorLines atY: argStartY textStyle: argTextStyle text: argText container: argContainer wantsColumnBreaks: argWantsColumnBreaks 399880 wantsColumnBreaks := argWantsColumnBreaks. 399881 lines := argLinesCollection. 399882 theTextStyle := argTextStyle. 399883 theText := argText. 399884 theContainer := argContainer. 399885 deltaCharIndex := argDelta. 399886 currCharIndex := startCharIndex := argStart. 399887 stopCharIndex := argStop. 399888 prevLines := argPriorLines. 399889 currentY := argStartY. 399890 defaultLineHeight := theTextStyle lineGrid. 399891 maxRightX := theContainer left. 399892 possibleSlide := stopCharIndex < theText size 399893 and: [theContainer isMemberOf: Rectangle]. 399894 nowSliding := false. 399895 prevIndex := 1. 399896 scanner := CompositionScanner new text: theText textStyle: theTextStyle. 399897 scanner wantsColumnBreaks: wantsColumnBreaks. 399898 isFirstLine := true. 399899 self composeAllLines. 399900 isFirstLine 399901 ifTrue: ["No space in container or empty text" 399902 self 399903 addNullLineWithIndex: startCharIndex 399904 andRectangle: (theContainer left @ theContainer top extent: 0 @ defaultLineHeight)] 399905 ifFalse: [self fixupLastLineIfCR]. 399906 ^ {lines asArray. maxRightX}! ! 399907 399908!TextComposer methodsFor: 'as yet unclassified' stamp: 'dgd 2/22/2003 13:31'! 399909composeOneLine 399910 | rectangles | 399911 rectangles := theContainer rectanglesAt: currentY height: defaultLineHeight. 399912 rectangles notEmpty 399913 ifTrue: [(self composeAllRectangles: rectangles) ifNil: [^nil]] 399914 ifFalse: [currentY := currentY + defaultLineHeight]. 399915 self checkIfReadyToSlide! ! 399916 399917!TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 18:09'! 399918fixupLastLineIfCR 399919"This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I couldn't figure out where to put it in the main logic." 399920 399921 (theText size > 1 and: [theText last = Character cr]) ifFalse: [^self]. 399922 self addNullLineForIndex: theText size + 1. 399923! ! 399924 399925!TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/6/2001 15:15'! 399926slideOneLineDown 399927 399928 | priorLine | 399929 399930 "Having detected the end of rippling recoposition, we are only sliding old lines" 399931 prevIndex < prevLines size ifFalse: [ 399932 "There are no more prevLines to slide." 399933 ^nowSliding := possibleSlide := false 399934 ]. 399935 399936 "Adjust and re-use previously composed line" 399937 prevIndex := prevIndex + 1. 399938 priorLine := (prevLines at: prevIndex) 399939 slideIndexBy: deltaCharIndex andMoveTopTo: currentY. 399940 lines addLast: priorLine. 399941 currentY := priorLine bottom. 399942 currCharIndex := priorLine last + 1. 399943 wantsColumnBreaks ifTrue: [ 399944 priorLine first to: priorLine last do: [ :i | 399945 (theText at: i) = TextComposer characterForColumnBreak ifTrue: [ 399946 nowSliding := possibleSlide := false. 399947 ^nil 399948 ]. 399949 ]. 399950 ]. 399951! ! 399952 399953"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 399954 399955TextComposer class 399956 instanceVariableNames: ''! 399957 399958!TextComposer class methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 09:31'! 399959characterForColumnBreak 399960 399961 ^Character value: 12! ! 399962Object subclass: #TextContainer 399963 instanceVariableNames: 'textMorph shadowForm vertProfile minWidth rectangleCache fillsOwner avoidsOcclusions' 399964 classVariableNames: 'OuterMargin' 399965 poolDictionaries: '' 399966 category: 'Morphic-Text Support'! 399967!TextContainer commentStamp: '<historical>' prior: 0! 399968A TextContainer models the shape of an ownerMorph, possibly occluded by one or more occludingMorphs, and scans this shape to provide a list of rectangles suitable for layout of text. It does this by displaying the shadow of the ownerMorph in black, and any occludingMorphs in white, on its shadowForm. It then scans horizontal strips of appropriate height to find unbroken intervals of black, greater than minWidth in extent. Conputation of the rectangles is done on demand, and results are cached so that text can be redisplayed without having to recompute the rectangles.! 399969 399970 399971!TextContainer methodsFor: 'access' stamp: 'di 11/4/97 14:05'! 399972avoidsOcclusions 399973 ^ avoidsOcclusions ifNil: [false]! ! 399974 399975!TextContainer methodsFor: 'access' stamp: 'di 11/13/97 14:45'! 399976avoidsOcclusions: aBoolean 399977 avoidsOcclusions := aBoolean. 399978 self releaseCachedState! ! 399979 399980!TextContainer methodsFor: 'access' stamp: 'di 11/4/97 14:05'! 399981fillsOwner 399982 ^ fillsOwner ifNil: [true]! ! 399983 399984!TextContainer methodsFor: 'access' stamp: 'di 11/13/97 14:45'! 399985fillsOwner: aBoolean 399986 fillsOwner := aBoolean. 399987 self releaseCachedState! ! 399988 399989!TextContainer methodsFor: 'access' stamp: 'yo 1/3/2003 12:21'! 399990paragraphClass 399991 ^ MultiNewParagraph! ! 399992 399993!TextContainer methodsFor: 'access' stamp: 'di 11/16/97 09:39'! 399994releaseCachedState 399995 399996 shadowForm := nil. 399997 vertProfile := nil. 399998 rectangleCache := Dictionary new. 399999! ! 400000 400001!TextContainer methodsFor: 'access' stamp: 'tk 8/31/2000 14:50'! 400002textMorph 400003 ^ textMorph! ! 400004 400005 400006!TextContainer methodsFor: 'container protocol' stamp: 'di 10/27/97 23:09'! 400007bottom 400008 "Note we should really check for contiguous pixels here" 400009 ^ (self vertProfile findLast: [:count | count >= minWidth]) 400010 + shadowForm offset y! ! 400011 400012!TextContainer methodsFor: 'container protocol' stamp: 'di 10/28/97 18:33'! 400013left 400014 ^ textMorph owner left! ! 400015 400016!TextContainer methodsFor: 'container protocol' stamp: 'dgd 2/22/2003 19:06'! 400017rectanglesAt: lineY height: lineHeight 400018 "Return a list of rectangles that are at least minWidth wide 400019 in the specified horizontal strip of the shadowForm. 400020 Cache the results for later retrieval if the owner does not change." 400021 400022 | hProfile rects thisWidth thisX count pair outerWidth lineRect lineForm | 400023 pair := Array with: lineY with: lineHeight. 400024 rects := rectangleCache at: pair ifAbsent: [nil]. 400025 rects ifNotNil: [^rects]. 400026 outerWidth := minWidth + (2 * OuterMargin). 400027 self shadowForm. "Compute the shape" 400028 lineRect := 0 @ (lineY - shadowForm offset y) 400029 extent: shadowForm width @ lineHeight. 400030 lineForm := shadowForm copy: lineRect. 400031 400032 "Check for a full line -- frequent case" 400033 (lineForm tallyPixelValues second) = lineRect area 400034 ifTrue: 400035 [rects := Array with: (shadowForm offset x @ lineY extent: lineRect extent)] 400036 ifFalse: 400037 ["No such luck -- scan the horizontal profile for segments of minWidth" 400038 400039 hProfile := lineForm xTallyPixelValue: 1 orNot: false. 400040 rects := OrderedCollection new. 400041 thisWidth := 0. 400042 thisX := 0. 400043 1 to: hProfile size 400044 do: 400045 [:i | 400046 count := hProfile at: i. 400047 count >= lineHeight 400048 ifTrue: [thisWidth := thisWidth + 1] 400049 ifFalse: 400050 [thisWidth >= outerWidth 400051 ifTrue: 400052 [rects addLast: ((thisX + shadowForm offset x) @ lineY 400053 extent: thisWidth @ lineHeight)]. 400054 thisWidth := 0. 400055 thisX := i]]. 400056 thisWidth >= outerWidth 400057 ifTrue: 400058 [rects addLast: ((thisX + shadowForm offset x) @ lineY 400059 extent: thisWidth @ lineHeight)]]. 400060 rects := rects collect: [:r | r insetBy: OuterMargin @ 0]. 400061 rectangleCache at: pair put: rects. 400062 ^rects! ! 400063 400064!TextContainer methodsFor: 'container protocol' stamp: 'di 11/16/97 09:33'! 400065top 400066 "Note we should really check for contiguous pixels here" 400067 | outerWidth | 400068 outerWidth := minWidth + (2*OuterMargin). 400069 ^ (self vertProfile findFirst: [:count | count >= outerWidth]) - 1 400070 + shadowForm offset y! ! 400071 400072!TextContainer methodsFor: 'container protocol' stamp: 'di 10/28/97 18:33'! 400073topLeft "for compatibility" 400074 ^ textMorph owner topLeft! ! 400075 400076!TextContainer methodsFor: 'container protocol' stamp: 'di 11/7/97 12:01'! 400077translateBy: delta 400078 self releaseCachedState! ! 400079 400080!TextContainer methodsFor: 'container protocol' stamp: 'di 10/28/97 18:32'! 400081width "for compatibility" 400082 ^ textMorph owner width! ! 400083 400084 400085!TextContainer methodsFor: 'private' stamp: 'ar 10/26/2000 20:04'! 400086bounds 400087 | bounds theText | 400088 self fillsOwner ifFalse: [^ textMorph textBounds]. 400089 theText := textMorph. 400090 bounds := theText owner innerBounds. 400091 bounds := bounds insetBy: (textMorph valueOfProperty: #margins ifAbsent: [1@1]). 400092 theText owner submorphsBehind: theText do: 400093 [:m | bounds := bounds merge: m fullBounds]. 400094 ^ bounds! ! 400095 400096!TextContainer methodsFor: 'private' stamp: 'ar 10/26/2000 20:05'! 400097computeShadow 400098 | canvas back bounds theText | 400099 bounds := self bounds. 400100 theText := textMorph. 400101 canvas := (Display defaultCanvasClass extent: bounds extent depth: 1) 400102 shadowColor: Color black. 400103 canvas translateBy: bounds topLeft negated during:[:tempCanvas| 400104 self fillsOwner 400105 ifTrue: [tempCanvas fullDrawMorph: (theText owner copyWithoutSubmorph: theText)] 400106 ifFalse: [tempCanvas fillRectangle: textMorph bounds color: Color black]. 400107 self avoidsOcclusions ifTrue: 400108 [back := tempCanvas form deepCopy. 400109 tempCanvas form fillWhite. 400110 theText owner submorphsInFrontOf: theText do: 400111 [:m | (textMorph isLinkedTo: m) 400112 ifTrue: [] 400113 ifFalse: [tempCanvas fullDrawMorph: m]]. 400114 back displayOn: tempCanvas form at: 0@0 rule: Form reverse]. 400115 ]. 400116 shadowForm := canvas form offset: bounds topLeft. 400117 vertProfile := shadowForm yTallyPixelValue: 1 orNot: false. 400118 rectangleCache := Dictionary new. 400119 ^ shadowForm! ! 400120 400121!TextContainer methodsFor: 'private' stamp: 'di 11/4/97 14:06'! 400122for: aTextMorph minWidth: wid 400123 textMorph := aTextMorph. 400124 minWidth := wid. 400125 fillsOwner := true. 400126 avoidsOcclusions := false.! ! 400127 400128!TextContainer methodsFor: 'private' stamp: 'di 10/27/97 23:09'! 400129shadowForm 400130 shadowForm ifNil: [self computeShadow]. 400131 ^ shadowForm! ! 400132 400133!TextContainer methodsFor: 'private' stamp: 'di 10/27/97 23:08'! 400134vertProfile 400135 vertProfile ifNil: [self computeShadow]. 400136 ^ vertProfile! ! 400137 400138"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 400139 400140TextContainer class 400141 instanceVariableNames: ''! 400142 400143!TextContainer class methodsFor: 'initialization' stamp: 'di 11/16/97 09:25'! 400144initialize "TextContainer initialize" 400145 OuterMargin := 2! ! 400146Object subclass: #TextConverter 400147 instanceVariableNames: '' 400148 classVariableNames: '' 400149 poolDictionaries: 'EventSensorConstants' 400150 category: 'Multilingual-TextConversion'! 400151!TextConverter commentStamp: '<historical>' prior: 0! 400152The abstract class for all different type of text converters. nextFromStream: and nextPut:toStream: are the public accessible methods. If you are going to make a subclass for a stateful text conversion, you should override restoreStateOf:with: and saveStateOf: along the line of CompoundTextConverter. 400153! 400154 400155 400156!TextConverter methodsFor: 'conversion' stamp: 'michael.rueger 1/27/2009 18:12'! 400157convertFromSystemString: aString 400158 400159 | readStream writeStream | 400160 readStream := aString readStream. 400161 writeStream := String new writeStream. 400162 400163 [readStream atEnd] whileFalse: [ 400164 writeStream nextPut: (self nextFromStream: readStream)]. 400165 ^writeStream contents 400166! ! 400167 400168!TextConverter methodsFor: 'conversion' stamp: 'michael.rueger 1/27/2009 18:14'! 400169convertToSystemString: aString 400170 400171 | readStream writeStream | 400172 readStream := aString readStream. 400173 writeStream := String new writeStream. 400174 400175 [readStream atEnd] whileFalse: [ 400176 self nextPut: readStream next toStream: writeStream 400177 ]. 400178 self emitSequenceToResetStateIfNeededOn: writeStream. 400179 ^writeStream contents! ! 400180 400181!TextConverter methodsFor: 'conversion' stamp: 'yo 8/19/2002 15:27'! 400182nextFromStream: aStream 400183 400184 self subclassResponsibility. 400185! ! 400186 400187!TextConverter methodsFor: 'conversion' stamp: 'yo 8/19/2002 15:27'! 400188nextPut: aCharacter toStream: aStream 400189 400190 self subclassResponsibility. 400191! ! 400192 400193 400194!TextConverter methodsFor: 'friend' stamp: 'yo 7/29/2003 15:51'! 400195emitSequenceToResetStateIfNeededOn: aStream 400196! ! 400197 400198!TextConverter methodsFor: 'friend' stamp: 'yo 2/21/2004 03:26'! 400199restoreStateOf: aStream with: aConverterState 400200 400201 aStream position: aConverterState. 400202! ! 400203 400204!TextConverter methodsFor: 'friend' stamp: 'yo 2/21/2004 03:59'! 400205saveStateOf: aStream 400206 400207 ^ aStream position. 400208! ! 400209 400210"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 400211 400212TextConverter class 400213 instanceVariableNames: ''! 400214 400215!TextConverter class methodsFor: 'instance creation' stamp: 'yo 12/28/2003 00:54'! 400216default 400217 400218 ^ UTF8TextConverter new. 400219! ! 400220 400221!TextConverter class methodsFor: 'instance creation' stamp: 'yo 7/25/2003 14:08'! 400222defaultConverterClassForEncoding: encodingName 400223 "TextConverter defaultConverterClassForEncoding: 'shift-jis'" 400224 400225 ^ self allSubclasses 400226 detect: [:class | class encodingNames includes: encodingName] 400227 ifNone: [] 400228! ! 400229 400230!TextConverter class methodsFor: 'instance creation' stamp: 'mir 7/20/2004 15:51'! 400231defaultSystemConverter 400232 400233 ^LanguageEnvironment defaultSystemConverter! ! 400234 400235!TextConverter class methodsFor: 'instance creation' stamp: 'yo 2/21/2004 04:56'! 400236newForEncoding: aString 400237 | class encoding | 400238 aString ifNil: [^ Latin1TextConverter new]. 400239 encoding := aString asLowercase. 400240 class := self allSubclasses 400241 detect: [:each | each encodingNames includes: encoding] 400242 ifNone: []. 400243 class isNil 400244 ifTrue: [^ nil]. 400245 ^ class new! ! 400246 400247 400248!TextConverter class methodsFor: 'utilities' stamp: 'yo 7/5/2004 19:41'! 400249allEncodingNames 400250 "TextConverter allEncodingNames" 400251 | encodingNames | 400252 encodingNames := Set new. 400253 self allSubclasses 400254 do: [:each | 400255 | names | 400256 names := each encodingNames. 400257 names notEmpty 400258 ifTrue: [encodingNames add: names first asSymbol]]. 400259 ^encodingNames! ! 400260 400261!TextConverter class methodsFor: 'utilities' stamp: 'yo 8/19/2002 15:28'! 400262encodingNames 400263 400264 ^ #() copy. 400265! ! 400266Object subclass: #TextDiffBuilder 400267 instanceVariableNames: 'realSrc realDst srcMap dstMap srcLines dstLines srcPos dstPos added removed shifted runs matches multipleMatches patchSequence' 400268 classVariableNames: '' 400269 poolDictionaries: '' 400270 category: 'System-FilePackage'! 400271 400272!TextDiffBuilder methodsFor: 'creating patches'! 400273buildDisplayPatch 400274 ^Text streamContents:[:stream| 400275 self printPatchSequence: self buildPatchSequence on: stream. 400276 ]! ! 400277 400278!TextDiffBuilder methodsFor: 'creating patches' stamp: 'RAA 5/2/2001 23:35'! 400279buildPatchSequence 400280 "@@ TODO: Das funktioniert noch nicht für n-m matches" 400281 matches := TwoLevelDictionary new. 400282 self buildReferenceMap. 400283 runs := self processDiagonals. 400284 self validateRuns: runs. 400285 "There may be things which have just been moved around. Find those." 400286 shifted := self detectShiftedRuns. 400287 self processShiftedRuns. 400288 "Now generate a patch sequence" 400289 patchSequence := self generatePatchSequence. 400290 ^patchSequence! ! 400291 400292!TextDiffBuilder methodsFor: 'creating patches' stamp: 'ar 11/20/1998 16:57'! 400293buildReferenceMap 400294 dstLines doWithIndex:[:line :index| 400295 (srcPos at: line ifAbsent:[#()]) 400296 do:[:index2| matches at: index@index2 put: line] 400297 ]. 400298 srcLines doWithIndex:[:line :index| 400299 (dstPos at: line ifAbsent:[#()]) 400300 do:[:index2| matches at: index2@index put: line] 400301 ]. 400302! ! 400303 400304!TextDiffBuilder methodsFor: 'creating patches'! 400305collectRunFrom: todo startingWith: startIndex into: run 400306 | next start | 400307 start := startIndex. 400308 self remove: start from: todo. 400309 run add: (matches at: start). 400310 "Search downwards" 400311 next := start. 400312 [next := next + (1@1). 400313 todo includes: next] whileTrue:[ 400314 run addLast: (matches at: next). 400315 self remove: next from: todo]. 400316 "Search upwards" 400317 next := start. 400318 [next := next - (1@1). 400319 todo includes: next] whileTrue:[ 400320 run addFirst: (matches at: next). 400321 self remove: next from: todo. 400322 start := next. "To use the first index" 400323 ]. 400324 ^start! ! 400325 400326!TextDiffBuilder methodsFor: 'creating patches'! 400327detectShiftedRuns 400328 | sortedRuns lastY run shiftedRuns | 400329 runs size < 2 ifTrue: [^ nil]. 400330 shiftedRuns := OrderedCollection new. 400331 sortedRuns := SortedCollection sortBlock: [:a1 :a2 | a1 key x < a2 key x]. 400332 runs associationsDo: [:assoc | sortedRuns add: assoc]. 400333 lastY := sortedRuns first key y. 400334 2 to: sortedRuns size do:[:i | 400335 run := sortedRuns at: i. 400336 run key y > lastY 400337 ifTrue: [lastY := run key y] 400338 ifFalse: [shiftedRuns add: run]]. 400339 ^ shiftedRuns! ! 400340 400341!TextDiffBuilder methodsFor: 'creating patches'! 400342generatePatchSequence 400343 | ps | 400344 ps := OrderedCollection new: srcLines size. 400345 srcLines size timesRepeat:[ps add: nil]. 400346 self incorporateMatchesInto: ps. 400347 self incorporateRemovalsInto: ps. 400348 self incorporateAddsInto: ps. 400349 ^ps! ! 400350 400351!TextDiffBuilder methodsFor: 'creating patches' stamp: 'di 3/15/1999 14:01'! 400352incorporateAddsInto: aPatchSequence 400353 "Incorporate adds" 400354 | lastMatch lastIndex index | 400355 added ifNil:[^self]. 400356 added := added sortBy:[:a1 :a2| a1 key < a2 key]. 400357 lastMatch := 1. 400358 lastIndex := 0. 400359 1 to: added size do:[:i| 400360 index := (added at: i) key. 400361 [index > lastMatch] whileTrue:[ 400362 [lastIndex := lastIndex + 1. 400363 (aPatchSequence at: lastIndex) key == #match] whileFalse. 400364 lastMatch := lastMatch + 1. 400365 ]. 400366 aPatchSequence add: #insert->(added at: i) value afterIndex: lastIndex. 400367 lastIndex := lastIndex + 1. 400368 lastMatch := lastMatch + 1. 400369 ].! ! 400370 400371!TextDiffBuilder methodsFor: 'creating patches'! 400372incorporateMatchesInto: aPatchSequence 400373 "Incorporate matches" 400374 | index | 400375 runs associationsDo:[:assoc| 400376 index := assoc key y. 400377 assoc value do:[:line| 400378 self assert:[(aPatchSequence at: index) isNil]. 400379 aPatchSequence at: index put: (#match -> line). 400380 index := index + 1. 400381 ]. 400382 ]. 400383! ! 400384 400385!TextDiffBuilder methodsFor: 'creating patches'! 400386incorporateRemovalsInto: aPatchSequence 400387 "Incorporate removals" 400388 | index | 400389 removed ifNil:[^self]. 400390 removed do:[:assoc| 400391 index := assoc key. 400392 self assert:[(aPatchSequence at: index) isNil]. 400393 aPatchSequence at: index put: #remove -> assoc value. 400394 ]. 400395! ! 400396 400397!TextDiffBuilder methodsFor: 'creating patches' stamp: 'RAA 5/2/2001 23:41'! 400398processDiagonals 400399 400400 ^self processDiagonalsFrom: matches twoLevelKeys 400401! ! 400402 400403!TextDiffBuilder methodsFor: 'creating patches' stamp: 'RAA 5/2/2001 23:17'! 400404processDiagonalsFrom: todoList 400405 | runList start run todo | 400406 todo := todoList copy. 400407 runList := PluggableDictionary new. 400408 runList hashBlock: self pointHashBlock. 400409 runList equalBlock: self pointEqualBlock. 400410 [todo isEmpty] whileFalse:[ 400411 start := todo detect:[:any| true]. 400412 run := OrderedCollection new. 400413 start := self 400414 collectRunFrom: todo 400415 startingWith: start 400416 into: run. 400417 runList at: start put: run. 400418 ]. 400419 "If we have multiple matches we might have chosen a bad sequence. 400420 There we redo the whole thing recursively" 400421 self hasMultipleMatches ifFalse:[^runList]. 400422 runList size < 2 ifTrue:[^runList]. 400423 400424 run := nil. 400425 start := 0. 400426 runList associationsDo:[:assoc| 400427 (run isNil or:[assoc value size > run size]) ifTrue:[ 400428 run := assoc value. 400429 start := assoc key]]. 400430 "Now found the longest run" 400431 run := OrderedCollection new. 400432 start := self 400433 collectRunFrom: todoList 400434 startingWith: start 400435 into: run. 400436 "Find the diagonals in the remaining set" 400437 runList := self processDiagonalsFrom: todoList. 400438 runList at: start put: run. 400439 ^runList! ! 400440 400441!TextDiffBuilder methodsFor: 'creating patches'! 400442processShiftedRuns 400443 | key | 400444 shifted isNil ifTrue:[^self]. 400445 shifted do:[:assoc| 400446 key := assoc key. 400447 assoc value doWithIndex:[:line :idx| 400448 removed add: (key y + idx - 1) -> line. 400449 added add: (key x + idx - 1) -> line]. 400450 runs removeKey: assoc key. 400451 ]. 400452! ! 400453 400454!TextDiffBuilder methodsFor: 'creating patches' stamp: 'ar 11/20/1998 17:26'! 400455validateRuns: runList 400456 | srcPosCopy dstPosCopy lines srcIndex dstIndex | 400457 srcPosCopy := srcPos copy. 400458 srcPosCopy associationsDo:[:assoc| assoc value: assoc value asSet]. 400459 dstPosCopy := dstPos copy. 400460 dstPosCopy associationsDo:[:assoc| assoc value: assoc value asSet]. 400461 runList associationsDo:[:assoc| 400462 srcIndex := assoc key y. 400463 dstIndex := assoc key x. 400464 lines := assoc value. 400465 lines do:[:string| 400466 (srcPosCopy at: string) remove: srcIndex. 400467 (dstPosCopy at: string) remove: dstIndex. 400468 srcIndex := srcIndex + 1. 400469 dstIndex := dstIndex + 1. 400470 ]. 400471 ]. 400472 removed := OrderedCollection new. 400473 srcPosCopy associationsDo:[:assoc| 400474 assoc value do:[:index| removed add: (index -> assoc key)]. 400475 ]. 400476 removed := removed sortBy:[:a1 :a2| a1 key < a2 key]. 400477 added := OrderedCollection new. 400478 dstPosCopy associationsDo:[:assoc| 400479 assoc value do:[:index| added add: (index -> assoc key)]. 400480 ]. 400481 added := added sortBy:[:a1 :a2| a1 key < a2 key]. 400482! ! 400483 400484 400485!TextDiffBuilder methodsFor: 'initialize' stamp: 'nk 10/29/2000 12:15'! 400486destString: aString 400487 realDst := self split: aString asString. 400488 dstLines := OrderedCollection new. 400489 dstMap := OrderedCollection new. 400490 realDst 400491 doWithIndex: [:line :realIndex | 400492 dstLines 400493 add: (self formatLine: line). 400494 dstMap add: realIndex]. 400495 dstPos := PluggableDictionary new: dstLines size. 400496 dstPos hashBlock: self stringHashBlock. 400497 dstLines 400498 doWithIndex: [:line :index | (dstPos includesKey: line) 400499 ifTrue: [(dstPos at: line) 400500 add: index. 400501 multipleMatches := true] 400502 ifFalse: [dstPos 400503 at: line 400504 put: (OrderedCollection with: index)]]! ! 400505 400506!TextDiffBuilder methodsFor: 'initialize' stamp: 'nk 1/7/2004 09:24'! 400507formatLine: aString 400508 ^aString copyWithout: Character lf! ! 400509 400510!TextDiffBuilder methodsFor: 'initialize'! 400511from: sourceString to: destString 400512 self sourceString: sourceString. 400513 self destString: destString.! ! 400514 400515!TextDiffBuilder methodsFor: 'initialize' stamp: 'nk 10/29/2000 12:15'! 400516sourceString: aString 400517 realSrc := self split: aString asString. 400518 srcLines := OrderedCollection new. 400519 srcMap := OrderedCollection new. 400520 realSrc 400521 doWithIndex: [:line :realIndex | 400522 srcLines 400523 add: (self formatLine: line). 400524 srcMap add: realIndex]. 400525 srcPos := PluggableDictionary new: srcLines size. 400526 srcPos hashBlock: self stringHashBlock. 400527 srcLines 400528 doWithIndex: [:line :index | (srcPos includesKey: line) 400529 ifTrue: [(srcPos at: line) 400530 add: index. 400531 multipleMatches := true] 400532 ifFalse: [srcPos 400533 at: line 400534 put: (OrderedCollection with: index)]]! ! 400535 400536!TextDiffBuilder methodsFor: 'initialize'! 400537split: aString 400538 ^self split: aString by: self splitCharacter! ! 400539 400540 400541!TextDiffBuilder methodsFor: 'printing' stamp: 'nk 4/24/2004 08:48'! 400542printPatchSequence: seq on: aStream 400543 seq do: 400544 [:assoc | 400545 aStream 400546 withAttributes: (self attributesOf: assoc key) 400547 do: [aStream nextPutAll: assoc value; cr]]! ! 400548 400549 400550!TextDiffBuilder methodsFor: 'testing'! 400551hasMultipleMatches 400552 ^multipleMatches == true! ! 400553 400554 400555!TextDiffBuilder methodsFor: 'private' stamp: 'DamienPollet 11/24/2008 22:18'! 400556attributesOf: type 400557 "Private. 400558 Answer the TextAttributes that are used to display text of the given type." 400559 400560 ^type caseOf: { 400561 [#insert] -> [ {TextEmphasis bold. TextColor color: Color green muchDarker} ]. 400562 [#remove] -> [ {TextEmphasis bold. TextColor color: Color red darker} ]. 400563 } otherwise: [ {TextEmphasis normal} ]. 400564! ! 400565 400566!TextDiffBuilder methodsFor: 'private' stamp: 'stephane.ducasse 4/13/2009 21:12'! 400567pointEqualBlock 400568 ^[ :a :b | a x = b x and: [a y = b y]] ! ! 400569 400570!TextDiffBuilder methodsFor: 'private' stamp: 'stephane.ducasse 4/13/2009 21:12'! 400571pointHashBlock 400572 ^[:pt| (pt x bitShift: 12) + pt y] ! ! 400573 400574!TextDiffBuilder methodsFor: 'private' stamp: 'RAA 5/2/2001 23:28'! 400575remove: pointKey from: aSet 400576 400577 self hasMultipleMatches ifFalse:[^aSet remove: pointKey]. 400578 aSet removeAllXAndY: pointKey. 400579! ! 400580 400581!TextDiffBuilder methodsFor: 'private' stamp: 'ar 11/20/1998 17:26'! 400582split: aString by: splitChar 400583 | lines index nextIndex | 400584 lines := OrderedCollection new. 400585 index := 1. 400586 [index <= aString size] whileTrue:[ 400587 nextIndex := aString 400588 indexOf: splitChar 400589 startingAt: index 400590 ifAbsent:[aString size+1]. 400591 lines add: (aString copyFrom: index to: nextIndex-1). 400592 index := nextIndex+1]. 400593 ^lines! ! 400594 400595!TextDiffBuilder methodsFor: 'private'! 400596splitCharacter 400597 ^Character cr! ! 400598 400599!TextDiffBuilder methodsFor: 'private' stamp: 'stephane.ducasse 4/13/2009 21:12'! 400600stringHashBlock 400601 "Return a block for use in string hashing" 400602 | stringSize | 400603 ^[:string| 400604 stringSize := string size. 400605 stringSize = 0 400606 ifTrue:[0] 400607 ifFalse:[ stringSize < 3 400608 ifTrue:[(string at: 1) asInteger + 400609 ((string at: string size) asInteger bitShift: 8)] 400610 ifFalse:[ (string at: 1) asInteger + 400611 ((string at: stringSize // 3 + 1) asInteger bitShift: 4) + 400612 ((string at: stringSize // 2 + 1) asInteger bitShift: 8) + 400613 ((string at: stringSize * 2 // 3 + 1) asInteger bitShift: 12) + 400614 ((string at: stringSize) asInteger bitShift: 16)]]] ! ! 400615 400616"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 400617 400618TextDiffBuilder class 400619 instanceVariableNames: ''! 400620 400621!TextDiffBuilder class methodsFor: 'instance creation'! 400622buildDisplayPatchFrom: srcString to: dstString 400623 ^(self from: srcString to: dstString) buildDisplayPatch! ! 400624 400625!TextDiffBuilder class methodsFor: 'instance creation' stamp: 'nk 10/29/2000 12:38'! 400626buildDisplayPatchFrom: srcString to: dstString inClass: srcClass 400627 ^ ((srcClass notNil and: [ (Preferences valueOfFlag: #diffsWithPrettyPrint) ]) 400628 ifTrue: [PrettyTextDiffBuilder 400629 from: srcString 400630 to: dstString 400631 inClass: srcClass] 400632 ifFalse: [self from: srcString to: dstString]) buildDisplayPatch! ! 400633 400634!TextDiffBuilder class methodsFor: 'instance creation' stamp: 'sw 5/19/2001 10:52'! 400635buildDisplayPatchFrom: srcString to: dstString inClass: srcClass prettyDiffs: prettyBoolean 400636 "Build a display patch for mapping via diffs from srcString to dstString in the given class. If prettyBoolean is true, do the diffing for pretty-printed forms" 400637 400638 ^ ((srcClass notNil and: [prettyBoolean]) 400639 ifTrue: [PrettyTextDiffBuilder 400640 from: srcString 400641 to: dstString 400642 inClass: srcClass] 400643 ifFalse: [self from: srcString to: dstString]) buildDisplayPatch! ! 400644 400645!TextDiffBuilder class methodsFor: 'instance creation'! 400646from: srcString to: dstString 400647 ^self new from: srcString to: dstString! ! 400648TextAction subclass: #TextDoIt 400649 instanceVariableNames: 'evalString' 400650 classVariableNames: '' 400651 poolDictionaries: '' 400652 category: 'Collections-Text'! 400653 400654!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/5/97 17:01'! 400655actOnClickFor: anObject 400656 "Note: evalString gets evaluated IN THE CONTEXT OF anObject 400657 -- meaning that self and all instVars are accessible" 400658 Compiler evaluate: evalString for: anObject logged: false. 400659 ^ true ! ! 400660 400661!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 16:46'! 400662analyze: aString 400663 400664 | list | 400665 list := super analyze: aString. 400666 evalString := list at: 1. 400667 ^ list at: 2! ! 400668 400669!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/5/97 17:01'! 400670evalString: str 400671 evalString := str ! ! 400672 400673!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/30/97 10:33'! 400674info 400675 ^ evalString! ! 400676 400677!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 13:46'! 400678writeScanOn: strm 400679 400680 strm nextPut: $d; nextPutAll: evalString; nextPutAll: ';;'! ! 400681 400682"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 400683 400684TextDoIt class 400685 instanceVariableNames: ''! 400686 400687!TextDoIt class methodsFor: 'as yet unclassified' stamp: 'tk 12/6/97 20:28'! 400688evalString: str 400689 ^ self new evalString: str! ! 400690 400691!TextDoIt class methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 09:06'! 400692scanFrom: strm 400693 "read a doit in the funny format used by Text styles on files. d10 factorial;; end with two semicolons" 400694 400695 | pos end doit | 400696 pos := strm position. 400697 [strm skipTo: $;. strm peek == $;] whileFalse. 400698 end := strm position - 1. 400699 strm position: pos. 400700 doit := strm next: end-pos. 400701 strm skip: 2. ";;" 400702 ^ self evalString: doit! ! 400703MessageDialogWindow subclass: #TextEditorDialogWindow 400704 instanceVariableNames: 'textEditorMorph entryText' 400705 classVariableNames: '' 400706 poolDictionaries: '' 400707 category: 'Polymorph-Widgets-Windows'! 400708!TextEditorDialogWindow commentStamp: 'gvc 5/18/2007 11:16' prior: 0! 400709Multi-line text entry dialog.! 400710 400711 400712!TextEditorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/1/2007 11:23'! 400713cancel 400714 "Cancel and close." 400715 400716 self entryText: nil. 400717 ^super cancel! ! 400718 400719!TextEditorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/1/2007 11:21'! 400720entryText 400721 "Answer the value of entryText" 400722 400723 ^ entryText! ! 400724 400725!TextEditorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/1/2007 11:22'! 400726entryText: anObject 400727 "Set the value of entryText" 400728 400729 entryText := anObject. 400730 self changed: #entryText. 400731 self textEditorMorph selectAll! ! 400732 400733!TextEditorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/1/2007 11:23'! 400734initialize 400735 "Initialize the receiver." 400736 400737 super initialize. 400738 self entryText: ''! ! 400739 400740!TextEditorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/1/2007 11:21'! 400741textEditorMorph 400742 "Answer the value of textEditorMorph" 400743 400744 ^ textEditorMorph! ! 400745 400746!TextEditorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/1/2007 11:21'! 400747textEditorMorph: anObject 400748 "Set the value of textEditorMorph" 400749 400750 textEditorMorph := anObject! ! 400751 400752 400753!TextEditorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 11:24'! 400754defaultFocusMorph 400755 "Answer the morph that should have the keyboard 400756 focus by default when the dialog is opened." 400757 400758 ^self textEditorMorph textMorph! ! 400759 400760!TextEditorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/30/2008 12:09'! 400761entryHeight: aNumber 400762 "Set the height of the text editor morph. 400763 Set the width to be 2 times this also." 400764 400765 self textEditorMorph 400766 vResizing: #rigid; 400767 height: aNumber; 400768 hResizing: #rigid; 400769 width: aNumber * 2! ! 400770 400771!TextEditorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 10:30'! 400772icon 400773 "Answer an icon for the receiver." 400774 400775 ^self theme questionIcon! ! 400776 400777!TextEditorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 11:23'! 400778newButtons 400779 "Answer new buttons as appropriate." 400780 400781 ^{self newOKButton. self newCancelButton}! ! 400782 400783!TextEditorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/29/2007 13:32'! 400784newContentMorph 400785 "Answer a new content morph." 400786 400787 self iconMorph: self newIconMorph. 400788 self textMorph: self newTextMorph. 400789 self textEditorMorph: self newTextEditorMorph. 400790 ^self newGroupboxForAll: { 400791 self newRow: {self iconMorph. self textMorph}. 400792 self textEditorMorph}! ! 400793 400794!TextEditorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 11:25'! 400795newTextEditorMorph 400796 "Answer a new text entry morph." 400797 400798 ^(self 400799 newTextEditorFor: self 400800 getText: #entryText 400801 setText: #entryText: 400802 getEnabled: nil) selectAll! ! 400803 400804"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 400805 400806TextEditorDialogWindow class 400807 instanceVariableNames: ''! 400808 400809!TextEditorDialogWindow class methodsFor: 'as yet unclassified' stamp: 'gvc 5/21/2007 12:43'! 400810taskbarIcon 400811 "Answer the icon for the receiver in a task bar." 400812 400813 ^UITheme current smallQuestionIcon! ! 400814TextAttribute subclass: #TextEmphasis 400815 instanceVariableNames: 'emphasisCode setMode' 400816 classVariableNames: '' 400817 poolDictionaries: '' 400818 category: 'Collections-Text'! 400819!TextEmphasis commentStamp: '<historical>' prior: 0! 400820A TextEmphasis, encodes a characteristic applicable to all fonts. The encoding is as follows: 400821 1 bold 400822 2 itallic 400823 4 underlined 400824 8 narrow 400825 16 struck out! 400826 400827 400828!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:15'! 400829= other 400830 ^ (other class == self class) 400831 and: [other emphasisCode = emphasisCode]! ! 400832 400833!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:11'! 400834dominatedByCmd0 400835 "Cmd-0 should turn off emphasis" 400836 ^ true! ! 400837 400838!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:13'! 400839dominates: other 400840 (emphasisCode = 0 and: [other dominatedByCmd0]) ifTrue: [^ true]. 400841 ^ (other class == self class) 400842 and: [emphasisCode = other emphasisCode]! ! 400843 400844!TextEmphasis methodsFor: 'as yet unclassified'! 400845emphasisCode 400846 ^ emphasisCode! ! 400847 400848!TextEmphasis methodsFor: 'as yet unclassified'! 400849emphasisCode: int 400850 emphasisCode := int. 400851 setMode := true! ! 400852 400853!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'di 10/29/97 11:57'! 400854emphasizeScanner: scanner 400855 "Set the emphasist for text scanning" 400856 scanner addEmphasis: emphasisCode! ! 400857 400858!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'ar 9/9/2003 22:03'! 400859hash 400860 "#hash is re-implemented because #= is re-implemented" 400861 ^emphasisCode hash 400862! ! 400863 400864!TextEmphasis methodsFor: 'as yet unclassified'! 400865printOn: strm 400866 super printOn: strm. 400867 strm nextPutAll: ' code: '; print: emphasisCode! ! 400868 400869!TextEmphasis methodsFor: 'as yet unclassified'! 400870set 400871 ^ setMode and: [emphasisCode ~= 0]! ! 400872 400873!TextEmphasis methodsFor: 'as yet unclassified'! 400874turnOff 400875 setMode := false! ! 400876 400877!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 09:28'! 400878writeScanOn: strm 400879 400880 emphasisCode = 1 ifTrue: [strm nextPut: $b]. 400881 emphasisCode = 2 ifTrue: [strm nextPut: $i]. 400882 emphasisCode = 0 ifTrue: [strm nextPut: $n]. 400883 emphasisCode = 16 ifTrue: [strm nextPut: $=]. 400884 emphasisCode = 4 ifTrue: [strm nextPut: $u].! ! 400885 400886"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 400887 400888TextEmphasis class 400889 instanceVariableNames: ''! 400890 400891!TextEmphasis class methodsFor: 'as yet unclassified'! 400892bold 400893 ^ self new emphasisCode: 1! ! 400894 400895!TextEmphasis class methodsFor: 'as yet unclassified'! 400896italic 400897 ^ self new emphasisCode: 2! ! 400898 400899!TextEmphasis class methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:05'! 400900narrow 400901 ^ TextKern kern: -1! ! 400902 400903!TextEmphasis class methodsFor: 'as yet unclassified'! 400904normal 400905 ^ self new emphasisCode: 0! ! 400906 400907!TextEmphasis class methodsFor: 'as yet unclassified'! 400908struckOut 400909 ^ self new emphasisCode: 16! ! 400910 400911!TextEmphasis class methodsFor: 'as yet unclassified'! 400912underlined 400913 ^ self new emphasisCode: 4! ! 400914HashAndEqualsTestCase subclass: #TextEmphasisTest 400915 instanceVariableNames: '' 400916 classVariableNames: '' 400917 poolDictionaries: '' 400918 category: 'CollectionsTests-Text'! 400919 400920!TextEmphasisTest methodsFor: 'initialization' stamp: 'mjr 8/20/2003 18:55'! 400921setUp 400922 super setUp. 400923 prototypes add: TextEmphasis bold; 400924 add: TextEmphasis italic; 400925 add: TextEmphasis narrow; 400926 add: TextEmphasis normal; 400927 add: TextEmphasis struckOut; 400928 add: TextEmphasis underlined ! ! 400929 400930 400931!TextEmphasisTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:03'! 400932testAppendString 400933 "tests the Text>>prepend: method when appending a String " 400934 "self run: # testAppendString" 400935 400936 | receiver argument result expectedResult | 400937 400938 receiver := 'xxx' asText 400939 addAttribute: TextEmphasis bold from: 1 to: 3. 400940 argument := 'yyy'. 400941 expectedResult := 'xxxyyy' asText 400942 addAttribute: TextEmphasis bold from: 1 to: 3. 400943 result := receiver append: argument. 400944 self assert: (result == receiver). 400945 self assert: (result string = expectedResult string). 400946 self assert: (result runs = expectedResult runs)! ! 400947 400948!TextEmphasisTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:04'! 400949testAppendText 400950 "tests the Text>>prepend: method when appending a Text " 400951 | receiver argument result expectedResult | 400952 400953 receiver := 'xxx' asText 400954 addAttribute: TextEmphasis bold from: 1 to: 3. 400955 argument := 'yyy' asText 400956 addAttribute: TextEmphasis italic from: 1 to: 3. . 400957 expectedResult := 'xxxyyy' asText 400958 addAttribute: TextEmphasis bold from: 1 to: 3; 400959 addAttribute: TextEmphasis italic from: 4 to: 6. 400960 result := receiver append: argument. 400961 self assert: (result == receiver). 400962 self assert: (result string = expectedResult string). 400963 self assert: (result runs = expectedResult runs) 400964 400965 400966 ! ! 400967 400968!TextEmphasisTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:04'! 400969testPrependString 400970 "tests the Text>>prepend: method when prepending a String " 400971 | receiver argument result expectedResult | 400972 400973 receiver := 'xxx' asText 400974 addAttribute: TextEmphasis bold from: 1 to: 3. 400975 argument := 'yyy'. 400976 expectedResult := 'yyyxxx' asText 400977 addAttribute: TextEmphasis bold from: 4 to: 6. 400978 result := receiver prepend: argument. 400979 self assert: (result == receiver). 400980 self assert: (result string = expectedResult string). 400981 self assert: (result runs = expectedResult runs) 400982 400983 ! ! 400984 400985!TextEmphasisTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:04'! 400986testPrependText 400987 "tests the Text>>prepend: method when prepending Text " 400988 | receiver argument result expectedResult | 400989 400990 receiver := 'xxx' asText 400991 addAttribute: TextEmphasis bold from: 1 to: 3. 400992 argument := 'yyy' asText 400993 addAttribute: TextEmphasis italic from: 1 to: 3. 400994 expectedResult := 'yyyxxx' asText 400995 addAttribute: TextEmphasis italic from: 1 to: 3; 400996 addAttribute: TextEmphasis bold from: 4 to: 6. 400997 result := receiver prepend: argument. 400998 self assert: (result == receiver). 400999 self assert: (result string = expectedResult string). 401000 self assert: (result runs = expectedResult runs)! ! 401001TextEditorDialogWindow subclass: #TextEntryDialogWindow 401002 instanceVariableNames: '' 401003 classVariableNames: '' 401004 poolDictionaries: '' 401005 category: 'Polymorph-Widgets-Windows'! 401006!TextEntryDialogWindow commentStamp: 'gvc 5/18/2007 11:16' prior: 0! 401007Single-line text entry dialog.! 401008 401009 401010!TextEntryDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/10/2007 13:52'! 401011newButtons 401012 "Answer new buttons as appropriate." 401013 401014 ^{self newOKButton isDefault: true. self newCancelButton}! ! 401015 401016 401017!TextEntryDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 11:22'! 401018newTextEditorMorph 401019 "Answer a new text entry morph." 401020 401021 ^(self 401022 newTextEntryFor: self 401023 getText: #entryText 401024 setText: #entryText: 401025 getEnabled: nil 401026 help: nil) selectAll! ! 401027RectangleMorph subclass: #TextFieldMorph 401028 instanceVariableNames: '' 401029 classVariableNames: '' 401030 poolDictionaries: '' 401031 category: 'Morphic-Text Support'! 401032!TextFieldMorph commentStamp: '<historical>' prior: 0! 401033Act as a field in a HyperCard-like setting. Has both properties of a Rectangle, and exposes some proteries of the TextMorph it owns. 401034 401035! 401036 401037 401038!TextFieldMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:54'! 401039defaultColor 401040"answer the default color/fill style for the receiver" 401041 ^ Color veryLightGray lighter! ! 401042 401043!TextFieldMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:54'! 401044initialize 401045 "initialize the state of the receiver" 401046 | tm | 401047 super initialize. 401048 "" 401049 401050 self addMorph: (tm := TextMorph new). 401051 tm fillingOnOff! ! 401052 401053 401054!TextFieldMorph methodsFor: 'just like textmorph' stamp: 'tk 9/6/2000 11:03'! 401055append: stringOrText 401056 "add to my text" 401057 | tm | 401058 401059 (tm := self findA: TextMorph) ifNil: [^ nil]. 401060 tm contents append: stringOrText. 401061 tm releaseParagraph; paragraph. 401062 401063 401064 ! ! 401065 401066!TextFieldMorph methodsFor: 'just like textmorph' stamp: 'tk 8/30/2000 14:22'! 401067contents 401068 | tm | 401069 "talk to my text" 401070 401071 (tm := self findA: TextMorph) ifNil: [^ nil]. 401072 ^ tm contents! ! 401073 401074!TextFieldMorph methodsFor: 'just like textmorph' stamp: 'ar 4/10/2005 18:54'! 401075contents: textOrString 401076 "talk to my text" 401077 | tm newText atts | 401078 401079 (tm := self findA: TextMorph) ifNil: [^ nil]. 401080 textOrString isString ifTrue: [ 401081 tm contents ifNotNil: ["Keep previous properties of the field" 401082 newText := textOrString asText. 401083 atts := tm contents attributesAt: 1. 401084 atts do: [:each | newText addAttribute: each]. 401085 ^ tm contents: newText]]. 401086 401087 ^ tm contents: textOrString! ! 401088 401089!TextFieldMorph methodsFor: 'just like textmorph' stamp: 'tk 9/4/2000 16:28'! 401090fit 401091 "tell my text to recompute its looks" 401092 | tm | 401093 401094 (tm := self findA: TextMorph) ifNil: [^ nil]. 401095 tm releaseParagraph; paragraph.! ! 401096 401097!TextFieldMorph methodsFor: 'just like textmorph' stamp: 'tk 8/30/2000 14:24'! 401098fontName: fontName size: fontSize 401099 | tm | 401100 "talk to my text" 401101 401102 (tm := self findA: TextMorph) ifNil: [^ nil]. 401103 ^ tm fontName: fontName size: fontSize 401104! ! 401105 401106!TextFieldMorph methodsFor: 'just like textmorph' stamp: 'tk 9/6/2000 12:33'! 401107lineCount 401108 | tm | 401109 "how many lines in my text" 401110 401111 (tm := self findA: TextMorph) ifNil: [^ nil]. 401112 ^ tm contents string lineCount! ! 401113 401114!TextFieldMorph methodsFor: 'just like textmorph' stamp: 'ar 12/27/2001 00:03'! 401115prepend: stringOrText 401116 "add to my text" 401117 | tm | 401118 401119 (tm := self findA: TextMorph) ifNil: [^ nil]. 401120 tm contents prepend: stringOrText. 401121 tm releaseParagraph; paragraph. 401122 401123 401124 ! ! 401125 401126"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 401127 401128TextFieldMorph class 401129 instanceVariableNames: ''! 401130 401131!TextFieldMorph class methodsFor: '*etoys-instance creation' stamp: 'sw 6/13/2001 22:48'! 401132exampleBackgroundField 401133 "Answer a scrollable background field for a parts bin" 401134 401135 | aMorph | 401136 aMorph := self authoringPrototype. 401137 aMorph contents: 'background field' asText allBold. 401138 aMorph setProperty: #shared toValue: true. 401139 aMorph setNameTo: 'scrollingField1'. 401140 aMorph setProperty: #holdsSeparateDataForEachInstance toValue: true. 401141 ^ aMorph! ! 401142 401143 401144!TextFieldMorph class methodsFor: 'initialization' stamp: 'asm 4/11/2003 11:56'! 401145initialize 401146 401147 self registerInFlapsRegistry. ! ! 401148 401149!TextFieldMorph class methodsFor: 'initialization' stamp: 'asm 4/11/2003 11:58'! 401150registerInFlapsRegistry 401151 "Register the receiver in the system's flaps registry" 401152 self environment 401153 at: #Flaps 401154 ifPresent: [:cl | cl registerQuad: #(TextFieldMorph exampleBackgroundField 'Scrolling Field' 'A scrolling data field which will have a different value on every card of the background') 401155 forFlapNamed: 'Scripting'.]! ! 401156 401157!TextFieldMorph class methodsFor: 'initialization' stamp: 'asm 4/11/2003 12:41'! 401158unload 401159 "Unload the receiver from global registries" 401160 401161 self environment at: #Flaps ifPresent: [:cl | 401162 cl unregisterQuadsWithReceiver: self] ! ! 401163 401164 401165!TextFieldMorph class methodsFor: 'scripting' stamp: 'md 11/14/2003 17:32'! 401166authoringPrototype 401167 "Answer an instance of the receiver that can serve as a prototype for authoring" 401168 401169 | proto | 401170 proto := super authoringPrototype. 401171 proto setProperty: #shared toValue: true. 401172 proto extent: 170 @ 30. 401173 proto color: Color veryLightGray lighter. 401174 proto contents: 'on a clear day you can...'. 401175 ^ proto 401176! ! 401177TextAttribute subclass: #TextFontChange 401178 instanceVariableNames: 'fontNumber' 401179 classVariableNames: '' 401180 poolDictionaries: '' 401181 category: 'Collections-Text'! 401182!TextFontChange commentStamp: '<historical>' prior: 0! 401183A TextFontChange encodes a font change applicable over a given range of text. The font number is interpreted relative to the textStyle governing display of this text.! 401184 401185 401186!TextFontChange methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:15'! 401187= other 401188 ^ (other class == self class) 401189 and: [other fontNumber = fontNumber]! ! 401190 401191!TextFontChange methodsFor: 'as yet unclassified' stamp: 'nk 9/3/2004 15:48'! 401192dominates: other 401193 ^ other isKindOf: TextFontChange! ! 401194 401195!TextFontChange methodsFor: 'as yet unclassified'! 401196emphasizeScanner: scanner 401197 "Set the font for text display" 401198 scanner setFont: fontNumber! ! 401199 401200!TextFontChange methodsFor: 'as yet unclassified'! 401201fontNumber 401202 ^ fontNumber! ! 401203 401204!TextFontChange methodsFor: 'as yet unclassified'! 401205fontNumber: int 401206 fontNumber := int! ! 401207 401208!TextFontChange methodsFor: 'as yet unclassified' stamp: 'di 11/9/97 17:46'! 401209forFontInStyle: aTextStyle do: aBlock 401210 aBlock value: (aTextStyle fontAt: fontNumber)! ! 401211 401212!TextFontChange methodsFor: 'as yet unclassified' stamp: 'ar 9/9/2003 22:03'! 401213hash 401214 "#hash is re-implemented because #= is re-implemented" 401215 ^fontNumber hash! ! 401216 401217!TextFontChange methodsFor: 'as yet unclassified'! 401218printOn: strm 401219 super printOn: strm. 401220 strm nextPutAll: ' font: '; print: fontNumber! ! 401221 401222!TextFontChange methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 09:22'! 401223writeScanOn: strm 401224 401225 strm nextPut: $f. 401226 fontNumber printOn: strm.! ! 401227 401228"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 401229 401230TextFontChange class 401231 instanceVariableNames: ''! 401232 401233!TextFontChange class methodsFor: 'as yet unclassified' stamp: 'sw 12/6/1999 17:52'! 401234defaultFontChange 401235 "Answer a TextFontChange that represents the default font" 401236 401237 ^ self new fontNumber: TextStyle default defaultFontIndex! ! 401238 401239!TextFontChange class methodsFor: 'as yet unclassified'! 401240font1 401241 ^ self new fontNumber: 1! ! 401242 401243!TextFontChange class methodsFor: 'as yet unclassified'! 401244font2 401245 ^ self new fontNumber: 2! ! 401246 401247!TextFontChange class methodsFor: 'as yet unclassified'! 401248font3 401249 ^ self new fontNumber: 3! ! 401250 401251!TextFontChange class methodsFor: 'as yet unclassified'! 401252font4 401253 ^ self new fontNumber: 4! ! 401254 401255!TextFontChange class methodsFor: 'as yet unclassified'! 401256fontNumber: n 401257 ^ self new fontNumber: n! ! 401258HashAndEqualsTestCase subclass: #TextFontChangeTest 401259 instanceVariableNames: '' 401260 classVariableNames: '' 401261 poolDictionaries: '' 401262 category: 'CollectionsTests-Text'! 401263 401264!TextFontChangeTest methodsFor: 'initialization' stamp: 'mjr 8/20/2003 18:55'! 401265setUp 401266 "create the prototypes for testing" 401267 super setUp. 401268 prototypes add: TextFontChange defaultFontChange. 401269 prototypes add: TextFontChange font1. 401270 prototypes add: TextFontChange font2. 401271 prototypes add: TextFontChange font3. 401272 prototypes add: TextFontChange font4. 401273 prototypes 401274 add: (TextFontChange fontNumber: 6) ! ! 401275 401276 401277!TextFontChangeTest methodsFor: 'tests' stamp: 'mjr 8/17/2003 20:29'! 401278testEquality 401279 "Check that different instances of the same TextFontChange are equal" 401280 self assert: TextFontChange defaultFontChange = TextFontChange defaultFontChange. 401281 self assert: TextFontChange font1 = TextFontChange font1. 401282 self assert: TextFontChange font2 = TextFontChange font2. 401283 self assert: TextFontChange font3 = TextFontChange font3. 401284 self assert: TextFontChange font4 = TextFontChange font4. 401285 self assert: (TextFontChange fontNumber: 6) 401286 = (TextFontChange fontNumber: 6)! ! 401287 401288!TextFontChangeTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:10'! 401289testHash 401290 "test that different instances of the same TextFontChange hash to the 401291 same value" 401292 | hashes hash | 401293 hashes := OrderedCollection new. 401294 1 401295 to: 100 401296 do: [:i | hashes add: TextFontChange defaultFontChange hash]. 401297 hash := hashes at: 1. 401298 2 401299 to: 100 401300 do: [:i | self assert: (hashes at: i) 401301 = hash]! ! 401302TextFontChange subclass: #TextFontReference 401303 instanceVariableNames: 'font' 401304 classVariableNames: '' 401305 poolDictionaries: '' 401306 category: 'Collections-Text'! 401307!TextFontReference commentStamp: '<historical>' prior: 0! 401308A TextFontReference encodes a font change applicable over a given range of text. The font reference is absolute: unlike a TextFontChange, it is independent of the textStyle governing display of this text.! 401309 401310 401311!TextFontReference methodsFor: 'as yet unclassified'! 401312emphasizeScanner: scanner 401313 "Set the actual font for text display" 401314 scanner setActualFont: font! ! 401315 401316!TextFontReference methodsFor: 'as yet unclassified' stamp: 'di 5/10/1999 23:47'! 401317font 401318 401319 ^ font! ! 401320 401321!TextFontReference methodsFor: 'as yet unclassified' stamp: 'di 11/9/97 17:47'! 401322forFontInStyle: aTextStyle do: aBlock 401323 aBlock value: font! ! 401324 401325!TextFontReference methodsFor: 'as yet unclassified'! 401326toFont: aFont 401327 401328 font := aFont! ! 401329 401330!TextFontReference methodsFor: 'as yet unclassified' stamp: 'tk 7/22/2002 18:39'! 401331writeScanOn: strm 401332 401333 strm nextPut: $F. 401334 strm nextPutAll: font familyName; nextPut: $#. 401335 font height printOn: strm.! ! 401336 401337 401338!TextFontReference methodsFor: 'comparing' stamp: 'nk 9/3/2004 15:43'! 401339= other 401340 ^ (other class == self class) 401341 and: [other font = font]! ! 401342 401343!TextFontReference methodsFor: 'comparing' stamp: 'ar 9/9/2003 22:03'! 401344hash 401345 "#hash is re-implemented because #= is re-implemented" 401346 ^font hash! ! 401347 401348!TextFontReference methodsFor: 'comparing' stamp: 'nk 9/3/2004 15:24'! 401349printOn: aStream 401350 aStream nextPutAll: 'a TextFontReference('; 401351 print: font; 401352 nextPut: $)! ! 401353 401354"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 401355 401356TextFontReference class 401357 instanceVariableNames: ''! 401358 401359!TextFontReference class methodsFor: 'as yet unclassified'! 401360toFont: aFont 401361 ^ self new toFont: aFont! ! 401362HashAndEqualsTestCase subclass: #TextFontReferenceTest 401363 instanceVariableNames: '' 401364 classVariableNames: '' 401365 poolDictionaries: '' 401366 category: 'CollectionsTests-Text'! 401367 401368!TextFontReferenceTest methodsFor: 'tests' stamp: 'mjr 8/20/2003 18:55'! 401369setUp 401370 super setUp. 401371 prototypes 401372 add: (TextFontReference 401373 toFont: (StrikeFont familyName: 'NewYork' size: 15)) ! ! 401374Object subclass: #TextHighlight 401375 instanceVariableNames: 'color lineRange bounds borderWidth borderColor borderSides fillWidth' 401376 classVariableNames: '' 401377 poolDictionaries: '' 401378 category: 'Polymorph-Widgets'! 401379!TextHighlight commentStamp: 'gvc 5/18/2007 11:15' prior: 0! 401380Definition of a clickable highlighted range of text with optional borders.! 401381 401382 401383!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/23/2006 10:41'! 401384borderColor 401385 "Answer the value of borderColor" 401386 401387 ^ borderColor! ! 401388 401389!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/23/2006 10:41'! 401390borderColor: anObject 401391 "Set the value of borderColor" 401392 401393 borderColor := anObject! ! 401394 401395!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/23/2006 10:57'! 401396borderSides 401397 "Answer the value of borderSides" 401398 401399 ^ borderSides! ! 401400 401401!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/23/2006 10:57'! 401402borderSides: anObject 401403 "Set the value of borderSides" 401404 401405 borderSides := anObject! ! 401406 401407!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/23/2006 10:41'! 401408borderWidth 401409 "Answer the value of borderWidth" 401410 401411 ^ borderWidth! ! 401412 401413!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/23/2006 10:41'! 401414borderWidth: anObject 401415 "Set the value of borderWidth" 401416 401417 borderWidth := anObject! ! 401418 401419!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/25/2006 13:18'! 401420bounds 401421 "Answer the value of bounds" 401422 401423 ^ bounds! ! 401424 401425!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/25/2006 13:18'! 401426bounds: anObject 401427 "Set the value of bounds" 401428 401429 bounds := anObject! ! 401430 401431!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/23/2006 10:41'! 401432color 401433 "Answer the value of color" 401434 401435 ^ color! ! 401436 401437!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/23/2006 10:41'! 401438color: anObject 401439 "Set the value of color" 401440 401441 color := anObject! ! 401442 401443!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/25/2006 13:38'! 401444fillWidth 401445 "Answer the value of fillWidth" 401446 401447 ^ fillWidth! ! 401448 401449!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/25/2006 13:38'! 401450fillWidth: anObject 401451 "Set the value of fillWidth" 401452 401453 fillWidth := anObject! ! 401454 401455!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/25/2006 13:03'! 401456lineNumber 401457 "Answer the first in the line range." 401458 401459 ^self lineRange first! ! 401460 401461!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/25/2006 13:02'! 401462lineRange 401463 "Answer the value of lineRange" 401464 401465 ^ lineRange! ! 401466 401467!TextHighlight methodsFor: 'accessing' stamp: 'gvc 10/25/2006 13:02'! 401468lineRange: anObject 401469 "Set the value of lineRange" 401470 401471 lineRange := anObject! ! 401472 401473 401474!TextHighlight methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 16:19'! 401475clicked: evt 401476 "The receiver has had a mouse down." 401477 401478 self triggerEvent: #clicked! ! 401479 401480!TextHighlight methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 16:00'! 401481containsPoint: aPoint in: rect 401482 "Answer whther the bounds contain the given (local coordinate) point." 401483 401484 |r| 401485 r := self bounds. 401486 r := self fillWidth 401487 ifTrue: [rect left @ r top corner: (rect right @ r bottom)] 401488 ifFalse: [r]. 401489 ^r containsPoint: aPoint! ! 401490 401491!TextHighlight methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 16:29'! 401492drawOn: aCanvas in: rect offset: o 401493 "Draw the highlight on the given canvas for the given rectangle." 401494 401495 |r| 401496 r := self fillWidth 401497 ifTrue: [rect left @ (self bounds top + rect top) corner: rect right @ (self bounds bottom + rect top)] 401498 ifFalse: [self bounds translateBy: rect topLeft]. 401499 r := r translateBy: (self fillWidth ifTrue: [0@o y negated] ifFalse: [o negated]). 401500 self color isTransparent not ifTrue: [ 401501 aCanvas 401502 fillRectangle: r 401503 color: self color]. 401504 (self borderWidth > 0 and: [self borderColor isTransparent not]) ifTrue: [ 401505 (self borderSides includes: #top) ifTrue: [ 401506 aCanvas 401507 fillRectangle: ( r withHeight: self borderWidth) 401508 color: self borderColor]. 401509 (self borderSides includes: #right) ifTrue: [ 401510 aCanvas 401511 fillRectangle: (r withLeft: r right - self borderWidth) 401512 color: self borderColor]. 401513 (self borderSides includes: #bottom) ifTrue: [ 401514 aCanvas 401515 fillRectangle: ( r withTop: r bottom - self borderWidth) 401516 color: self borderColor]. 401517 (self borderSides includes: #left) ifTrue: [ 401518 aCanvas 401519 fillRectangle: ( r withWidth: self borderWidth) 401520 color: self borderColor]]! ! 401521 401522!TextHighlight methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 11:16'! 401523initialize 401524 "Initialize the receiver." 401525 401526 super initialize. 401527 self 401528 color: Color yellow; 401529 lineRange: (1 to: 0); 401530 borderWidth: 0; 401531 borderColor: Color transparent; 401532 borderSides: #(top right bottom left); 401533 fillWidth: false! ! 401534 401535!TextHighlight methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 13:20'! 401536position 401537 "Answer the bounds top left." 401538 401539 ^self bounds topLeft! ! 401540 401541!TextHighlight methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 13:19'! 401542position: aPoint 401543 "Set the bounds top left." 401544 401545 self bounds: (aPoint extent: self bounds extent)! ! 401546TextAttribute subclass: #TextIndent 401547 instanceVariableNames: 'amount' 401548 classVariableNames: '' 401549 poolDictionaries: '' 401550 category: 'Collections-Text'! 401551!TextIndent commentStamp: '<historical>' prior: 0! 401552create a hanging indent. ! 401553 401554 401555!TextIndent methodsFor: 'access' stamp: 'ls 6/22/1998 17:51'! 401556amount 401557 "number of tab spaces to indent by" 401558 ^amount! ! 401559 401560!TextIndent methodsFor: 'access' stamp: 'ls 6/22/1998 17:51'! 401561amount: anInteger 401562 "change the number of tabs to indent by" 401563 amount := anInteger! ! 401564 401565 401566!TextIndent methodsFor: 'condensing' stamp: 'ls 6/22/1998 19:27'! 401567dominates: anAttribute 401568 ^(self class == anAttribute class)! ! 401569 401570 401571!TextIndent methodsFor: 'printing' stamp: 'ls 6/22/1998 18:03'! 401572printOn: aStream 401573 super printOn: aStream. 401574 aStream nextPutAll: ' amount: '. 401575 amount printOn: aStream! ! 401576 401577 401578!TextIndent methodsFor: 'setting indentation' stamp: 'ls 6/22/1998 18:56'! 401579emphasizeScanner: scanner 401580 scanner indentationLevel: amount! ! 401581 401582"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 401583 401584TextIndent class 401585 instanceVariableNames: ''! 401586 401587!TextIndent class methodsFor: 'example' stamp: 'ls 6/24/1998 18:06'! 401588example 401589 "TextIndent example" 401590 | text pg | 401591 401592 "create an example text with some indentation" 401593 text := 'abcdao euoaeuo aeuo aeuoaeu o aeuoeauefgh bcd efghi' asText. 401594 text addAttribute: (TextColor red) from: 3 to: 8. 401595 text addAttribute: (TextIndent amount: 1) from: 1 to: 2. 401596 text addAttribute: (TextIndent amount: 2) from: 20 to: 35. 401597 401598 "stick it in a paragraph and display it" 401599 pg := text asParagraph. 401600 pg compositionRectangle: (0@0 extent: 100@200). 401601 pg textStyle alignment: 2. 401602 pg displayAt: 0@0. 401603! ! 401604 401605 401606!TextIndent class methodsFor: 'instance creation' stamp: 'ls 6/27/1998 15:55'! 401607amount: amount 401608 "create a TextIndent which will indent by the given amount. Currently this is a number of tabs, but may change in the futur" 401609 ^super new amount: amount! ! 401610 401611!TextIndent class methodsFor: 'instance creation' stamp: 'ls 6/27/1998 15:54'! 401612tabs: numTabs 401613 "create an indentation by the given number of tabs" 401614 ^self amount: numTabs! ! 401615TextAttribute subclass: #TextKern 401616 instanceVariableNames: 'kern active' 401617 classVariableNames: '' 401618 poolDictionaries: '' 401619 category: 'Collections-Text'! 401620!TextKern commentStamp: '<historical>' prior: 0! 401621A TextKern encodes a kerning change applicable over a given range of text. Positive values of kern spread letters out, negative kern will cause them to overlap more. Note that kerns other than 0 will display somewhat slower, as kerning is not yet supported in the text scanning primitive. ! 401622 401623 401624!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:15'! 401625= other 401626 ^ (other class == self class) 401627 and: [other kern = kern]! ! 401628 401629!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:10'! 401630dominatedByCmd0 401631 "Cmd-0 should turn off kerning" 401632 ^ true! ! 401633 401634!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:10'! 401635dominates: other 401636 "NOTE: The use of active in this code is specific to its use in the method 401637 Text class addAttribute: att toArray: others" 401638 (active and: [other class == self class and: [other kern + kern = 0]]) 401639 ifTrue: [active := false. ^ true]. "can only dominate once" 401640 ^ false! ! 401641 401642!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/29/97 11:50'! 401643emphasizeScanner: scanner 401644 "Augment (or diminish) the kerning offset for text display" 401645 scanner addKern: kern! ! 401646 401647!TextKern methodsFor: 'as yet unclassified' stamp: 'ar 9/9/2003 22:03'! 401648hash 401649 "#hash is re-implemented because #= is re-implemented" 401650 ^kern hash! ! 401651 401652!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:12'! 401653kern 401654 ^ kern! ! 401655 401656!TextKern methodsFor: 'as yet unclassified' stamp: 'tk 12/30/97 09:59'! 401657kern: kernValue 401658 kern := kernValue. 401659 self reset.! ! 401660 401661!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:04'! 401662reset 401663 active := true! ! 401664 401665!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:11'! 401666set 401667 ^ active! ! 401668 401669!TextKern methodsFor: 'as yet unclassified' stamp: 'tk 9/21/1999 15:57'! 401670writeScanOn: strm 401671 401672 kern > 0 ifTrue: [ 401673 1 to: kern do: [:kk | strm nextPut: $+]]. 401674 kern < 0 ifTrue: [ 401675 1 to: 0-kern do: [:kk | strm nextPut: $-]].! ! 401676 401677 401678!TextKern methodsFor: 'testing' stamp: 'ar 9/21/2000 14:16'! 401679isKern 401680 ^true! ! 401681 401682"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 401683 401684TextKern class 401685 instanceVariableNames: ''! 401686 401687!TextKern class methodsFor: 'as yet unclassified' stamp: 'di 10/29/97 11:49'! 401688kern: kernValue 401689 ^ self new kern: kernValue! ! 401690HashAndEqualsTestCase subclass: #TextKernTest 401691 instanceVariableNames: '' 401692 classVariableNames: '' 401693 poolDictionaries: '' 401694 category: 'CollectionsTests-Text'! 401695 401696!TextKernTest methodsFor: 'tests' stamp: 'mjr 8/20/2003 18:55'! 401697setUp 401698 super setUp. 401699 prototypes 401700 add: (TextKern kern: 1) ! ! 401701Object subclass: #TextLine 401702 instanceVariableNames: 'left right top bottom firstIndex lastIndex internalSpaces paddingWidth baseline' 401703 classVariableNames: '' 401704 poolDictionaries: '' 401705 category: 'Morphic-Text Support'! 401706!TextLine commentStamp: '<historical>' prior: 0! 401707A TextLine embodies the layout of a line of composed text. 401708 left right top bottom The full line rectangle 401709 firstIndex lastIndex Starting and stopping indices in the full text 401710 internalSpaces Number of spaces to share paddingWidth 401711 paddingWidth Number of pixels of extra space in full line 401712 baseline Distance of baseline below the top of the line 401713 leftMargin Left margin due to paragraph indentation 401714TextLine's rather verbose message protocol is required for compatibility with the old CharacterScanners.! 401715 401716 401717!TextLine methodsFor: '*FreeType-addition' stamp: 'tween 4/6/2007 12:48'! 401718justifiedPadFor: spaceIndex font: aFont 401719 "Compute the width of pad for a given space in a line of justified text." 401720 401721 | pad | 401722 internalSpaces = 0 ifTrue: [^0]. 401723 ^(aFont notNil and:[aFont isSubPixelPositioned]) 401724 ifTrue:[paddingWidth * 1.0 / internalSpaces] 401725 ifFalse:[ 401726 pad := paddingWidth // internalSpaces. 401727 spaceIndex <= (paddingWidth \\ internalSpaces) 401728 ifTrue: [pad + 1] 401729 ifFalse: [pad]] 401730 ! ! 401731 401732 401733!TextLine methodsFor: 'accessing'! 401734baseline 401735 ^ baseline! ! 401736 401737!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'! 401738bottom 401739 ^ bottom! ! 401740 401741!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'! 401742bottomRight 401743 ^ right@bottom! ! 401744 401745!TextLine methodsFor: 'accessing' stamp: 'di 10/21/97 20:12'! 401746first 401747 ^ firstIndex! ! 401748 401749!TextLine methodsFor: 'accessing'! 401750internalSpaces 401751 "Answer the number of spaces in the line." 401752 401753 ^internalSpaces! ! 401754 401755!TextLine methodsFor: 'accessing'! 401756internalSpaces: spacesInteger 401757 "Set the number of spaces in the line to be spacesInteger." 401758 401759 internalSpaces := spacesInteger! ! 401760 401761!TextLine methodsFor: 'accessing' stamp: 'di 10/21/97 20:14'! 401762last 401763 ^ lastIndex! ! 401764 401765!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'! 401766left 401767 ^ left! ! 401768 401769!TextLine methodsFor: 'accessing' stamp: 'di 10/21/97 20:42'! 401770leftMargin 401771 "This has to get fixed -- store during composition" 401772 ^ self left! ! 401773 401774!TextLine methodsFor: 'accessing' stamp: 'hmm 2/9/2001 11:58'! 401775leftMargin: lm 401776 left := lm! ! 401777 401778!TextLine methodsFor: 'accessing' stamp: 'di 10/26/97 16:03'! 401779leftMarginForAlignment: alignmentCode 401780 alignmentCode = 1 ifTrue: [^ self left + paddingWidth]. "right flush" 401781 alignmentCode = 2 ifTrue: [^ self left + (paddingWidth//2)]. "centered" 401782 ^ self left "leftFlush and justified"! ! 401783 401784!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'! 401785lineHeight 401786 ^ bottom - top! ! 401787 401788!TextLine methodsFor: 'accessing'! 401789paddingWidth 401790 "Answer the amount of space to be added to the font." 401791 401792 ^paddingWidth! ! 401793 401794!TextLine methodsFor: 'accessing'! 401795paddingWidth: padWidthInteger 401796 "Set the amount of space to be added to the font to be padWidthInteger." 401797 401798 paddingWidth := padWidthInteger! ! 401799 401800!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 20:00'! 401801rectangle 401802 ^ self topLeft corner: self bottomRight! ! 401803 401804!TextLine methodsFor: 'accessing' stamp: 'hmm 2/9/2001 11:58'! 401805rectangle: lineRectangle 401806 left := lineRectangle left. 401807 right := lineRectangle right. 401808 top := lineRectangle top. 401809 bottom := lineRectangle bottom! ! 401810 401811!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'! 401812right 401813 ^ right! ! 401814 401815!TextLine methodsFor: 'accessing' stamp: 'di 10/21/97 20:42'! 401816rightMargin 401817 "This has to get fixed -- store during composition" 401818 ^ self right! ! 401819 401820!TextLine methodsFor: 'accessing' stamp: 'di 11/26/97 16:18'! 401821setRight: x 401822 right := x! ! 401823 401824!TextLine methodsFor: 'accessing' stamp: 'di 10/20/97 23:27'! 401825stop: stopInteger 401826 "Set the stopping point in the string of the line to be stopInteger." 401827 401828 lastIndex := stopInteger! ! 401829 401830!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'! 401831top 401832 ^ top! ! 401833 401834!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'! 401835topLeft 401836 ^ left @ top! ! 401837 401838!TextLine methodsFor: 'accessing' stamp: 'di 11/26/97 16:58'! 401839width 401840 ^ right - left! ! 401841 401842 401843!TextLine methodsFor: 'comparing' stamp: 'di 10/20/97 23:24'! 401844= line 401845 401846 self species = line species 401847 ifTrue: [^((firstIndex = line first and: [lastIndex = line last]) 401848 and: [internalSpaces = line internalSpaces]) 401849 and: [paddingWidth = line paddingWidth]] 401850 ifFalse: [^false]! ! 401851 401852!TextLine methodsFor: 'comparing' stamp: 'ar 9/9/2003 22:03'! 401853hash 401854 "#hash is re-implemented because #= is re-implemented" 401855 ^firstIndex hash bitXor: lastIndex hash! ! 401856 401857 401858!TextLine methodsFor: 'printing' stamp: 'di 10/23/97 23:19'! 401859printOn: aStream 401860 super printOn: aStream. 401861 aStream space; print: firstIndex; nextPutAll: ' to: '; print: lastIndex! ! 401862 401863 401864!TextLine methodsFor: 'scanning'! 401865justifiedPadFor: spaceIndex 401866 "Compute the width of pad for a given space in a line of justified text." 401867 401868 | pad | 401869 internalSpaces = 0 ifTrue: [^0]. 401870 pad := paddingWidth // internalSpaces. 401871 spaceIndex <= (paddingWidth \\ internalSpaces) 401872 ifTrue: [^pad + 1] 401873 ifFalse: [^pad]! ! 401874 401875!TextLine methodsFor: 'scanning'! 401876justifiedTabDeltaFor: spaceIndex 401877 "Compute the delta for a tab in a line of justified text, so tab falls 401878 somewhere plausible when line is justified." 401879 401880 | pad extraPad | 401881 internalSpaces = 0 ifTrue: [^0]. 401882 pad := paddingWidth // internalSpaces. 401883 extraPad := paddingWidth \\ internalSpaces. 401884 spaceIndex <= extraPad 401885 ifTrue: [^spaceIndex * (pad + 1)] 401886 ifFalse: [^extraPad * (pad + 1) + (spaceIndex - extraPad * pad)]! ! 401887 401888 401889!TextLine methodsFor: 'updating' stamp: 'di 11/7/97 08:32'! 401890moveBy: delta 401891 "Move my rectangle by the given delta" 401892 left := left + delta x. 401893 right := right + delta x. 401894 top := top + delta y. 401895 bottom := bottom + delta y. 401896! ! 401897 401898!TextLine methodsFor: 'updating' stamp: 'di 10/20/97 23:25'! 401899slide: delta 401900 "Change the starting and stopping points of the line by delta." 401901 401902 firstIndex := firstIndex + delta. 401903 lastIndex := lastIndex + delta! ! 401904 401905!TextLine methodsFor: 'updating' stamp: 'di 4/28/1999 11:12'! 401906slideIndexBy: delta andMoveTopTo: newTop 401907 "Relocate my character indices and y-values. 401908 Used to slide constant text up or down in the wake of a text replacement." 401909 401910 firstIndex := firstIndex + delta. 401911 lastIndex := lastIndex + delta. 401912 bottom := bottom + (newTop - top). 401913 top := newTop. 401914! ! 401915 401916 401917!TextLine methodsFor: 'private' stamp: 'di 10/20/97 23:08'! 401918firstIndex: firstInteger lastIndex: lastInteger 401919 firstIndex := firstInteger. 401920 lastIndex := lastInteger! ! 401921 401922!TextLine methodsFor: 'private'! 401923internalSpaces: spacesInteger paddingWidth: padWidthInteger 401924 401925 internalSpaces := spacesInteger. 401926 paddingWidth := padWidthInteger! ! 401927 401928!TextLine methodsFor: 'private' stamp: 'di 10/23/97 19:57'! 401929lineHeight: height baseline: ascent 401930 bottom := top + height. 401931 baseline := ascent! ! 401932 401933"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 401934 401935TextLine class 401936 instanceVariableNames: ''! 401937 401938!TextLine class methodsFor: 'instance creation' stamp: 'di 10/20/97 23:08'! 401939start: startInteger stop: stopInteger internalSpaces: spacesInteger paddingWidth: padWidthInteger 401940 "Answer an instance of me with the arguments as the start, stop points, 401941 number of spaces in the line, and width of the padding." 401942 | line | 401943 line := self new firstIndex: startInteger lastIndex: stopInteger. 401944 ^ line internalSpaces: spacesInteger paddingWidth: padWidthInteger! ! 401945TestCase subclass: #TextLineEndingsTest 401946 instanceVariableNames: '' 401947 classVariableNames: '' 401948 poolDictionaries: '' 401949 category: 'CollectionsTests-Text'! 401950!TextLineEndingsTest commentStamp: 'nk 11/1/2003 07:55' prior: 0! 401951This is a test case for Text>>withSqueakLineEndings and String>>withSqueakLineEndings. 401952 401953The main problem we've seen with the Text version is that it doesn't preserve formatting correctly.! 401954 401955 401956!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:06'! 401957testDecoratedTextConversionCrLF 401958 401959 | text newText | 401960 text := ('123456', String crlf, '901234') asText. 401961 text addAttribute: TextColor blue from: 4 to: 10. 401962 text addAttribute: TextColor red from: 6 to: 9. 401963 text addAttribute: TextEmphasis bold. 401964 newText := text withSqueakLineEndings. 401965 self assert: ((text size - 1) = newText size). 401966 self assert: (newText size = newText runs size). 401967 self assert: (newText attributesAt: 6) = (text attributesAt: 6). 401968 self assert: (newText attributesAt: 8) = (text attributesAt: 9).! ! 401969 401970!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:06'! 401971testDecoratedTextConversionJustLF 401972 401973 | text newText | 401974 text := ('123456', String lf, '901234') asText. 401975 text addAttribute: TextColor blue from: 4 to: 10. 401976 text addAttribute: TextColor red from: 6 to: 9. 401977 text addAttribute: TextEmphasis bold. 401978 newText := text withSqueakLineEndings. 401979 self assert: ((text size) = newText size). 401980 self assert: (newText size = newText runs size). 401981 self assert: (newText attributesAt: 6) = (text attributesAt: 6). 401982 self assert: (newText attributesAt: 8) = (text attributesAt: 8).! ! 401983 401984!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'! 401985testDecoratedTextConversionNoLF 401986 401987 | text newText | 401988 text := ('123456', String cr, '901234') asText. 401989 text addAttribute: TextColor blue from: 4 to: 10. 401990 text addAttribute: TextColor red from: 6 to: 9. 401991 text addAttribute: TextEmphasis bold. 401992 newText := text withSqueakLineEndings. 401993 self assert: ((text size) = newText size). 401994 self assert: (newText size = newText runs size). 401995 self assert: (newText attributesAt: 6) = (text attributesAt: 6). 401996 self assert: (newText attributesAt: 8) = (text attributesAt: 8).! ! 401997 401998!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'! 401999testSimpleTextConversionCrLF 402000 402001 | string newText | 402002 string := 'This is a test', String crlf, 'of the conversion'. 402003 newText := string asText withSqueakLineEndings. 402004 self assert: ((string size - 1) = newText size). 402005 self assert: (newText size = newText runs size).! ! 402006 402007!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'! 402008testSimpleTextConversionJustCR 402009 402010 | string newText | 402011 string := 'This is a test', String cr, 'of the conversion'. 402012 newText := string asText withSqueakLineEndings. 402013 self assert: ((string size) = newText size). 402014 self assert: (newText size = newText runs size).! ! 402015 402016!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'! 402017testSimpleTextConversionJustLF 402018 402019 | string newText | 402020 string := 'This is a test', String lf, 'of the conversion'. 402021 newText := string asText withSqueakLineEndings. 402022 self assert: ((string size) = newText size). 402023 self assert: (newText size = newText runs size).! ! 402024 402025!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'! 402026testStringConversionCrLF 402027 402028 | string newString | 402029 string := 'This is a test', String crlf, 'of the conversion'. 402030 newString := string withSqueakLineEndings. 402031 self assert: ((string size - 1) = newString size).! ! 402032 402033!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'! 402034testStringConversionJustLF 402035 402036 | string newString | 402037 string := 'This is a test', String lf, 'of the conversion'. 402038 newString := string withSqueakLineEndings. 402039 self assert: (string size = newString size).! ! 402040 402041!TextLineEndingsTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:07'! 402042testStringConversionNoLF 402043 402044 | string newString | 402045 string := 'This is a test', String cr, 'of the conversion'. 402046 newString := string withSqueakLineEndings. 402047 self assert: (string = newString).! ! 402048Interval subclass: #TextLineInterval 402049 instanceVariableNames: 'internalSpaces paddingWidth lineHeight baseline' 402050 classVariableNames: '' 402051 poolDictionaries: 'TextConstants' 402052 category: 'Graphics-Text'! 402053!TextLineInterval commentStamp: '<historical>' prior: 0! 402054My instances specify the starting and stopping points in a String of a composed line. The step is always 1.! 402055 402056 402057!TextLineInterval methodsFor: '*FreeType-addition' stamp: 'tween 4/6/2007 12:48'! 402058justifiedPadFor: spaceIndex font: aFont 402059 "Compute the width of pad for a given space in a line of justified text." 402060 402061 | pad | 402062 internalSpaces = 0 ifTrue: [^0]. 402063 ^(aFont notNil and:[aFont isSubPixelPositioned]) 402064 ifTrue:[paddingWidth * 1.0 / internalSpaces] 402065 ifFalse:[ 402066 pad := paddingWidth // internalSpaces. 402067 spaceIndex <= (paddingWidth \\ internalSpaces) 402068 ifTrue: [pad + 1] 402069 ifFalse: [pad]]! ! 402070 402071 402072!TextLineInterval methodsFor: 'accessing'! 402073baseline 402074 ^ baseline! ! 402075 402076!TextLineInterval methodsFor: 'accessing'! 402077internalSpaces 402078 "Answer the number of spaces in the line." 402079 402080 ^internalSpaces! ! 402081 402082!TextLineInterval methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 402083internalSpaces: spacesInteger 402084 "Set the number of spaces in the line to be spacesInteger." 402085 internalSpaces := spacesInteger! ! 402086 402087!TextLineInterval methodsFor: 'accessing'! 402088lineHeight 402089 ^ lineHeight! ! 402090 402091!TextLineInterval methodsFor: 'accessing'! 402092paddingWidth 402093 "Answer the amount of space to be added to the font." 402094 402095 ^paddingWidth! ! 402096 402097!TextLineInterval methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 402098paddingWidth: padWidthInteger 402099 "Set the amount of space to be added to the font to be padWidthInteger." 402100 paddingWidth := padWidthInteger! ! 402101 402102!TextLineInterval methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 402103stop: stopInteger 402104 "Set the stopping point in the string of the line to be stopInteger." 402105 stop := stopInteger! ! 402106 402107 402108!TextLineInterval methodsFor: 'comparing'! 402109= line 402110 402111 self species = line species 402112 ifTrue: [^((start = line first and: [stop = line last]) 402113 and: [internalSpaces = line internalSpaces]) 402114 and: [paddingWidth = line paddingWidth]] 402115 ifFalse: [^false]! ! 402116 402117 402118!TextLineInterval methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 402119justifiedPadFor: spaceIndex 402120 "Compute the width of pad for a given space in a line of justified text." 402121 | pad | 402122 internalSpaces = 0 ifTrue: [ ^ 0 ]. 402123 pad := paddingWidth // internalSpaces. 402124 spaceIndex <= (paddingWidth \\ internalSpaces) 402125 ifTrue: [ ^ pad + 1 ] 402126 ifFalse: [ ^ pad ]! ! 402127 402128!TextLineInterval methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 402129justifiedTabDeltaFor: spaceIndex 402130 "Compute the delta for a tab in a line of justified text, so tab falls 402131 somewhere plausible when line is justified." 402132 | pad extraPad | 402133 internalSpaces = 0 ifTrue: [ ^ 0 ]. 402134 pad := paddingWidth // internalSpaces. 402135 extraPad := paddingWidth \\ internalSpaces. 402136 spaceIndex <= extraPad 402137 ifTrue: [ ^ spaceIndex * (pad + 1) ] 402138 ifFalse: [ ^ extraPad * (pad + 1) + ((spaceIndex - extraPad) * pad) ]! ! 402139 402140 402141!TextLineInterval methodsFor: 'updating' stamp: 'lr 7/4/2009 10:42'! 402142slide: delta 402143 "Change the starting and stopping points of the line by delta." 402144 start := start + delta. 402145 stop := stop + delta! ! 402146 402147 402148!TextLineInterval methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 402149internalSpaces: spacesInteger paddingWidth: padWidthInteger 402150 internalSpaces := spacesInteger. 402151 paddingWidth := padWidthInteger! ! 402152 402153!TextLineInterval methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 402154lineHeight: height baseline: ascent 402155 lineHeight := height. 402156 baseline := ascent! ! 402157 402158"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 402159 402160TextLineInterval class 402161 instanceVariableNames: ''! 402162 402163!TextLineInterval class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 402164start: startInteger stop: stopInteger internalSpaces: spacesInteger paddingWidth: padWidthInteger 402165 "Answer an instance of me with the arguments as the start, stop points, 402166 number of spaces in the line, and width of the padding." 402167 | newSelf | 402168 newSelf := super 402169 from: startInteger 402170 to: stopInteger 402171 by: 1. 402172 ^ newSelf 402173 internalSpaces: spacesInteger 402174 paddingWidth: padWidthInteger! ! 402175HashAndEqualsTestCase subclass: #TextLineTest 402176 instanceVariableNames: '' 402177 classVariableNames: '' 402178 poolDictionaries: '' 402179 category: 'MorphicTests-Text Support'! 402180 402181!TextLineTest methodsFor: 'initialization' stamp: 'mjr 8/20/2003 18:56'! 402182setUp 402183 super setUp. 402184 prototypes 402185 add: (TextLine 402186 start: 1 402187 stop: 50 402188 internalSpaces: 2 402189 paddingWidth: 1) ! ! 402190TextAction subclass: #TextLink 402191 instanceVariableNames: 'classAndMethod' 402192 classVariableNames: '' 402193 poolDictionaries: '' 402194 category: 'Collections-Text'! 402195 402196!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 5/1/2001 18:17'! 402197actOnClickFor: aMessageSet 402198 "Add to the end of the list. 'aClass selector', 'aClass Comment', 'aClass Definition', 'aClass Hierarchy' are the formats allowed." 402199 402200 aMessageSet addItem: classAndMethod. 402201 ^ true! ! 402202 402203!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 16:49'! 402204analyze: aString 402205 402206 | list | 402207 list := super analyze: aString. 402208 classAndMethod := list at: 1. 402209 ^ list at: 2! ! 402210 402211!TextLink methodsFor: 'as yet unclassified' stamp: 'LC 10/8/2001 10:53'! 402212analyze: aString with: nonMethod 402213 "Initalize this attribute holder with a piece text the user typed into a paragraph. Returns the text to emphesize (may be different from selection) Does not return self!!. nonMethod is what to show when clicked, i.e. the last part of specifier (Comment, Definition, or Hierarchy). May be of the form: 402214Point 402215<Point> 402216Click Here<Point> 402217<Point>Click Here 402218" 402219 "Obtain the showing text and the instructions" 402220 | b1 b2 trim | 402221 b1 := aString indexOf: $<. 402222 b2 := aString indexOf: $>. 402223 (b1 < b2) & (b1 > 0) ifFalse: ["only one part" 402224 classAndMethod := self validate: aString, ' ', nonMethod. 402225 ^ classAndMethod ifNotNil: [aString]]. 402226 "Two parts" 402227 trim := aString withBlanksTrimmed. 402228 (trim at: 1) == $< 402229 ifTrue: [(trim last) == $> 402230 ifTrue: ["only instructions" 402231 classAndMethod := self validate: (aString copyFrom: b1+1 to: b2-1), ' ', nonMethod. 402232 ^ classAndMethod ifNotNil: [classAndMethod]] 402233 ifFalse: ["at the front" 402234 classAndMethod := self validate: (aString copyFrom: b1+1 to: b2-1), ' ', nonMethod. 402235 ^ classAndMethod ifNotNil: [aString copyFrom: b2+1 to: aString size]]] 402236 ifFalse: [(trim last) == $> 402237 ifTrue: ["at the end" 402238 classAndMethod := self validate: (aString copyFrom: b1+1 to: b2-1), ' ', nonMethod. 402239 ^ classAndMethod ifNotNil: [aString copyFrom: 1 to: b1-1]] 402240 ifFalse: ["Illegal -- <> has text on both sides" 402241 ^ nil]] 402242! ! 402243 402244!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/5/97 17:09'! 402245classAndMethod: aString 402246 classAndMethod := aString! ! 402247 402248!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/30/97 10:33'! 402249info 402250 ^ classAndMethod! ! 402251 402252!TextLink methodsFor: 'as yet unclassified' stamp: 'nk 2/26/2005 09:50'! 402253validate: specString 402254 "Can this string be decoded to be Class space Method (or Comment, Definition, Hierarchy)? If so, return it in valid format, else nil" 402255 402256 | list first mid last | 402257 list := specString findTokens: ' .|'. 402258 list isEmpty ifTrue: [ ^nil ]. 402259 last := list last. 402260 last first isUppercase ifTrue: [ 402261 (#('Comment' 'Definition' 'Hierarchy') includes: last) ifFalse: [^ nil]. 402262 "Check for 'Rectangle Comment Comment' and remove last one" 402263 (list at: list size - 1 ifAbsent: [^nil]) = last ifTrue: [list := list allButLast]]. 402264 list size > 3 ifTrue: [^ nil]. 402265 list size < 2 ifTrue: [^ nil]. 402266 Symbol hasInterned: list first ifTrue: [:sym | first := sym]. 402267 first ifNil: [^ nil]. 402268 Smalltalk at: first ifAbsent: [^ nil]. 402269 mid := list size = 3 402270 ifTrue: [(list at: 2) = 'class' ifTrue: ['class '] ifFalse: [^ nil]] 402271 ifFalse: ['']. 402272 "OK if method name is not interned -- may not be defined yet" 402273 ^ first, ' ', mid, last! ! 402274 402275!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 13:44'! 402276writeScanOn: strm 402277 402278 strm nextPut: $L; nextPutAll: classAndMethod; nextPut: $;! ! 402279 402280"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 402281 402282TextLink class 402283 instanceVariableNames: ''! 402284 402285!TextLink class methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 08:53'! 402286scanFrom: strm 402287 "read a link in the funny format used by Text styles on files. LPoint +;LPoint Comment;" 402288 402289 ^ self new classAndMethod: (strm upTo: $;)! ! 402290TextAttribute subclass: #TextMessageLink 402291 instanceVariableNames: 'message' 402292 classVariableNames: '' 402293 poolDictionaries: '' 402294 category: 'Network-Url'! 402295!TextMessageLink commentStamp: '<historical>' prior: 0! 402296A link to a hidden mail message. Clicking on it allows the message to be viewed or saved to disk.! 402297 402298 402299!TextMessageLink methodsFor: 'acting' stamp: 'rbb 2/18/2005 09:33'! 402300actOnClickFor: evt 402301 | choice viewMsg | 402302 viewMsg := message containsViewableImage 402303 ifTrue: ['view this image attachment'] 402304 ifFalse: ['view this attachment']. 402305 choice := UIManager default chooseFrom: (Array with: viewMsg 402306 with: 'save this attachment' ). 402307 choice = 1 402308 ifTrue: ["open a new viewer" 402309 message viewBody]. 402310 choice = 2 402311 ifTrue: ["save the mesasge" 402312 message save]. 402313 ^ true! ! 402314 402315!TextMessageLink methodsFor: 'acting' stamp: 'ls 4/30/2000 19:03'! 402316mayActOnClick 402317 ^true! ! 402318 402319 402320!TextMessageLink methodsFor: 'appearance' stamp: 'ls 4/30/2000 20:34'! 402321emphasizeScanner: scanner 402322 scanner textColor: Color brown! ! 402323 402324 402325!TextMessageLink methodsFor: 'initialization' stamp: 'ls 4/30/2000 18:54'! 402326initialize: message0 402327 message := message0! ! 402328 402329"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 402330 402331TextMessageLink class 402332 instanceVariableNames: ''! 402333 402334!TextMessageLink class methodsFor: 'instance creation' stamp: 'ls 4/30/2000 19:00'! 402335message: aMessage 402336 ^super new initialize: aMessage! ! 402337RectangleMorph subclass: #TextMorph 402338 instanceVariableNames: 'textStyle text wrapFlag paragraph editor container predecessor successor backgroundColor margins editHistory' 402339 classVariableNames: 'CaretForm' 402340 poolDictionaries: '' 402341 category: 'Morphic-Basic'! 402342!TextMorph commentStamp: 'sd 2/20/2004 23:25' prior: 0! 402343TextMorphs support display of text with emphasis. They also support reasonable text-editing capabilities, as well as embedded hot links, and the ability to embed submorphs in the text. 402344 402345Late in life, TextMorph was made a subclass of BorderedMorph to provide border and background color if desired. In order to keep things compatible, protocols have been redirected so that color (preferably textColor) relates to the text, and backgroundColor relates to the inner fill color. 402346 402347Text display is clipped to the innerBounds of the rectangle, and text composition is normally performed within a rectangle which is innerBounds inset by the margins parameter. 402348 402349If text has been embedded in another object, one can elect to fill the owner's shape, in which case the text will be laid out in the shape of the owner's shadow image (including any submorphs other than the text). One can also elect to have the text avoid occlusions, in which case it will avoid the bounds of any sibling morphs that appear in front of it. It may be necessary to update bounds in order for the text runaround to notice the presence of a new occluding shape. 402350 402351The optional autoFitContents property enables the following feature: if the text contents changes, then the bounds of the morph will be adjusted to fit the minimum rectangle that encloses the text (plus any margins specified). Similarly, any attempt to change the size of the morph will be resisted if this parameter is set. Except... 402352 402353If the wrapFlag parameter is true, then text will be wrapped at word boundaries based on the composition width (innerBounds insetBy: margins) width. Thus an attempt to resize the morph in autofit mode, if it changes the width, will cause the text to be recomposed with the new width, and then the bounds will be reset to the minimum enclosing rectangle. Similarly, if the text contents are changed with the wrapFlag set to true, word wrap will be performed based on the current compostion width, after which the bounds will be set (or not), based on the autoFitcontents property. 402354 402355Note that fonts can only be applied to the TextMorph as a whole. While you can change the size, color, and emphasis of a subsection of the text and have it apply to only that subsection, changing the font changes the font for the entire contents of the TextMorph. 402356 402357Still a TextMorph can be composed of several texts of different fonts 402358| font1 font2 t1 t2 tMorph| 402359tMorph _ TextMorph new. 402360font1 _ (TextFontReference toFont: (StrikeFont familyName: 'Atlanta' size: 22)). 402361font2 _ (TextFontReference toFont: (StrikeFont familyName: 'Atlanta' size: 11)). 402362t1 _ 'this is font1' asText addAttribute: font1. 402363t2 _ ' and this is font2' asText addAttribute: font2. 402364tMorph contents: (t1,t2). 402365tMorph openInHand. 402366 402367 402368Yet to do: 402369Make a comprehensive control for the eyedropper, with border width and color, inner color and text color, and margin widths.! 402370 402371 402372!TextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/4/2009 11:56'! 402373optimalExtent 402374 "Create a new paragraph and answer its extent." 402375 402376 ^(self paragraphClass new 402377 compose: text 402378 style: textStyle copy 402379 from: 1 402380 in: (0@0 extent: 9999999@9999999); 402381 adjustRightX; 402382 extent) + (self borderWidth * 2) + (2@0) "FreeType kerning allowance"! ! 402383 402384!TextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/23/2006 14:48'! 402385overrideExtent: newExtent 402386 "If autoFit is on then override to false for the duration of the extent call." 402387 402388 self isAutoFit 402389 ifTrue: [self 402390 setProperty: #autoFitContents toValue: false; 402391 extent: newExtent; 402392 setProperty: #autoFitContents toValue: true]! ! 402393 402394!TextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/5/2007 16:12'! 402395takesKeyboardFocus 402396 "Answer whether the receiver can normally take keyboard focus." 402397 402398 ^true! ! 402399 402400!TextMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/5/2007 16:14'! 402401wantsKeyboardFocusNavigation 402402 "Answer whether the receiver wants to be navigated to. 402403 Answer false here (use PluggableTextMorph instead)." 402404 402405 ^false! ! 402406 402407 402408!TextMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 3/6/2008 16:57'! 402409drawNullTextOn: aCanvas 402410 "Make null text frame visible. 402411 Nicer if not shaded!!" 402412 402413 aCanvas isPostscriptCanvas ifFalse: [ 402414 aCanvas fillRectangle: bounds color: (self backgroundColor ifNil: [Color transparent])]! ! 402415 402416!TextMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/5/2007 12:34'! 402417drawOn: aCanvas 402418 "Draw the receiver on a canvas. 402419 Draw keyboard focus if appropriate." 402420 402421 | fauxBounds | 402422 self setDefaultContentsIfNil. 402423 super drawOn: aCanvas. "Border and background if any" 402424 false ifTrue: [self debugDrawLineRectsOn: aCanvas]. "show line rects for debugging" 402425 (self startingIndex > text size) 402426 ifTrue: [self drawNullTextOn: aCanvas]. 402427 "Hack here: The canvas expects bounds to carry the location of the text, but we also need to communicate clipping." 402428 fauxBounds := self bounds topLeft corner: self innerBounds bottomRight. 402429 aCanvas paragraph: self paragraph bounds: fauxBounds color: color. 402430 self hasKeyboardFocus ifTrue: [ 402431 (Preferences externalFocusForPluggableText 402432 and: [(self ownerThatIsA: PluggableTextMorph) notNil]) 402433 ifFalse: [self drawKeyboardFocusOn: aCanvas]]! ! 402434 402435!TextMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 9/6/2007 14:35'! 402436keyboardFocusChange: aBoolean 402437 "Changed to update focus indication." 402438 402439 | w ptm | 402440 paragraph isNil ifFalse:[paragraph focused: aBoolean]. 402441 aBoolean 402442 ifTrue: 402443 ["A hand is wanting to send us characters..." 402444 402445 self hasFocus ifFalse: [self editor "Forces install"]] 402446 ifFalse: 402447 ["A hand has clicked elsewhere..." 402448 402449 (w := self world) isNil 402450 ifFalse: 402451 [w handsDo: [:h | h keyboardFocus == self ifTrue: [^self]]. 402452 "Release control unless some hand is still holding on" 402453 self releaseEditor]]. 402454 (Preferences externalFocusForPluggableText 402455 and: [(ptm := self ownerThatIsA: PluggableTextMorph) notNil]) 402456 ifTrue: [ptm focusChanged] 402457 ifFalse: [self focusChanged]! ! 402458 402459!TextMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 7/30/2007 14:55'! 402460yellowButtonActivity: shiftKeyState 402461 "Invoke the text-editing menu. 402462 Check if required first!!" 402463 402464 | menu | 402465 self wantsYellowButtonMenu 402466 ifFalse: [^self]. 402467 (menu := self getMenu: shiftKeyState) 402468 ifNotNil: ["" 402469 menu setInvokingView: self editor. 402470 menu invokeModal. self changed]! ! 402471 402472 402473!TextMorph methodsFor: '*etoys-e-toy support' stamp: 'sw 9/15/2000 06:14'! 402474getNumericValue 402475 "Obtain a numeric value from the receiver; if no digits, return zero" 402476 402477 | aString | 402478 ^ [(aString := text string) asNumber] ifError: [:a :b | ^ aString asInteger ifNil: [0]]! ! 402479 402480 402481!TextMorph methodsFor: 'accessing' stamp: 'sw 1/12/98 23:40'! 402482asText 402483 ^ text! ! 402484 402485!TextMorph methodsFor: 'accessing' stamp: 'di 7/12/2001 22:25'! 402486autoFit: trueOrFalse 402487 self isAutoFit = trueOrFalse ifTrue: [^ self]. 402488 self autoFitOnOff! ! 402489 402490!TextMorph methodsFor: 'accessing' stamp: 'di 6/22/2001 09:33'! 402491backgroundColor 402492 ^ backgroundColor! ! 402493 402494!TextMorph methodsFor: 'accessing' stamp: 'di 7/23/2001 15:30'! 402495backgroundColor: newColor 402496 backgroundColor := newColor. 402497 self changed! ! 402498 402499!TextMorph methodsFor: 'accessing' stamp: 'di 7/19/2001 11:08'! 402500borderWidth: newWidth 402501 super borderWidth: newWidth. 402502 paragraph ifNotNil: [self composeToBounds].! ! 402503 402504!TextMorph methodsFor: 'accessing'! 402505contents 402506 402507 ^ text! ! 402508 402509!TextMorph methodsFor: 'accessing' stamp: 'tk 8/31/2000 14:59'! 402510contentsAsIs: stringOrText 402511 "Accept new text contents with line breaks only as in the text. 402512 Fit my width and height to the result." 402513 wrapFlag := false. 402514 container ifNotNil: [container fillsOwner ifTrue: [wrapFlag := true]]. 402515 self newContents: stringOrText! ! 402516 402517!TextMorph methodsFor: 'accessing' stamp: 'di 9/30/97 09:51'! 402518contentsWrapped: stringOrText 402519 "Accept new text contents. Lay it out, wrapping within my current width. 402520 Then fit my height to the result." 402521 wrapFlag := true. 402522 self newContents: stringOrText! ! 402523 402524!TextMorph methodsFor: 'accessing' stamp: 'di 9/30/97 15:48'! 402525contents: stringOrText 402526 ^ self contentsAsIs: stringOrText! ! 402527 402528!TextMorph methodsFor: 'accessing' stamp: 'di 4/14/98 08:33'! 402529contents: stringOrText wrappedTo: width 402530 "Accept new text contents. Lay it out, wrapping to width. 402531 Then fit my height to the result." 402532 self newContents: ''. 402533 wrapFlag := true. 402534 super extent: width truncated@self height. 402535 self newContents: stringOrText! ! 402536 402537!TextMorph methodsFor: 'accessing' stamp: 'ar 8/23/2001 21:23'! 402538crAction 402539 "Return the action to perform when encountering a CR in the input" 402540 ^self valueOfProperty: #crAction! ! 402541 402542!TextMorph methodsFor: 'accessing' stamp: 'ar 8/23/2001 21:23'! 402543crAction: aMessageSend 402544 "Return the action to perform when encountering a CR in the input" 402545 ^self setProperty: #crAction toValue: aMessageSend! ! 402546 402547!TextMorph methodsFor: 'accessing' stamp: 'sw 5/22/2003 02:39'! 402548cursor 402549 "Answer the receiver's logical cursor position" 402550 402551 | loc | 402552 loc := self valueOfProperty: #textCursorLocation ifAbsentPut: [1]. 402553 loc := loc min: text string size. 402554 ^ loc rounded 402555 ! ! 402556 402557!TextMorph methodsFor: 'accessing' stamp: 'sw 2/17/2003 18:20'! 402558cursorWrapped: aNumber 402559 "Set the cursor as indicated" 402560 402561 self setProperty: #textCursorLocation toValue: (((aNumber rounded - 1) \\ text string size) + 1) 402562 402563 ! ! 402564 402565!TextMorph methodsFor: 'accessing' stamp: 'di 10/5/1998 13:56'! 402566editor 402567 "Return my current editor, or install a new one." 402568 editor ifNotNil: [^ editor]. 402569 ^ self installEditorToReplace: nil! ! 402570 402571!TextMorph methodsFor: 'accessing' stamp: 'sw 2/18/2003 02:58'! 402572elementCount 402573 "Answer how many sub-objects are within me" 402574 402575 ^ self text string size ! ! 402576 402577!TextMorph methodsFor: 'accessing' stamp: 'nk 8/30/2004 05:43'! 402578fontName: fontName pointSize: fontSize 402579 | newTextStyle | 402580 newTextStyle := ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy. 402581 newTextStyle ifNil: [self error: 'font ', fontName, ' not found.']. 402582 402583 textStyle := newTextStyle. 402584 text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfPointSize: fontSize)). 402585 paragraph ifNotNil: [paragraph textStyle: newTextStyle]! ! 402586 402587!TextMorph methodsFor: 'accessing' stamp: 'nk 7/12/2003 08:39'! 402588fontName: fontName size: fontSize 402589 | newTextStyle | 402590 newTextStyle := ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy. 402591 textStyle := newTextStyle. 402592 text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfSize: fontSize)). 402593 paragraph ifNotNil: [paragraph textStyle: newTextStyle]! ! 402594 402595!TextMorph methodsFor: 'accessing' stamp: 'nk 10/16/2003 16:42'! 402596font: aFont 402597 | newTextStyle | 402598 newTextStyle := aFont textStyle copy ifNil: [ TextStyle fontArray: { aFont } ]. 402599 textStyle := newTextStyle. 402600 text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOf: aFont)). 402601 paragraph ifNotNil: [paragraph textStyle: newTextStyle]! ! 402602 402603!TextMorph methodsFor: 'accessing' stamp: 'sw 6/27/2001 13:45'! 402604getCharacters 402605 "obtain a string value from the receiver" 402606 402607 ^ self text string copy! ! 402608 402609!TextMorph methodsFor: 'accessing' stamp: 'kfr 9/21/2003 21:47'! 402610getFirstCharacter 402611 "obtain the first character from the receiver if it is empty, return a 402612 black dot" 402613 | aString | 402614 ^ (aString := text string) isEmpty 402615 ifTrue: ['·'] 402616 ifFalse: [aString first asString] ! ! 402617 402618!TextMorph methodsFor: 'accessing' stamp: 'sw 8/10/2004 00:53'! 402619getLastCharacter 402620 "obtain the last character from the receiver if it is empty, return a black dot" 402621 402622 | aString | 402623 ^ (aString := text string) size > 0 ifTrue: [aString last asString] ifFalse: ['·']! ! 402624 402625!TextMorph methodsFor: 'accessing' stamp: 'di 7/24/2001 11:20'! 402626hasTranslucentColor 402627 "Overridden from BorderedMorph to test backgroundColor instead of (text) color." 402628 402629 backgroundColor ifNil: [^ true]. 402630 (backgroundColor isColor and: [backgroundColor isTranslucentColor]) ifTrue: [^ true]. 402631 (borderColor isColor and: [borderColor isTranslucentColor]) ifTrue: [^ true]. 402632 ^ false 402633! ! 402634 402635!TextMorph methodsFor: 'accessing' stamp: 'di 7/12/2001 14:01'! 402636isAutoFit 402637 ^ self valueOfProperty: #autoFitContents ifAbsent: [true] 402638! ! 402639 402640!TextMorph methodsFor: 'accessing' stamp: 'RAA 8/21/2001 11:18'! 402641isWrapped 402642 402643 ^wrapFlag! ! 402644 402645!TextMorph methodsFor: 'accessing' stamp: 'RAA 8/21/2001 11:41'! 402646margins 402647 402648 ^margins! ! 402649 402650!TextMorph methodsFor: 'accessing' stamp: 'di 7/20/2001 22:44'! 402651margins: newMargins 402652 "newMargins can be a number, point or rectangle, as allowed by, eg, insetBy:." 402653 402654 margins := newMargins. 402655 self composeToBounds! ! 402656 402657!TextMorph methodsFor: 'accessing' stamp: 'BJP 12/1/2003 00:19'! 402658newContents: stringOrText 402659 "Accept new text contents." 402660 | newText embeddedMorphs | 402661 "If my text is all the same font, use the font for my new contents" 402662 newText := stringOrText isString ifTrue: [ | textSize | 402663 (text notNil 402664 and: [ (textSize := text size) > 0 402665 and: [ (text runLengthFor: 1) = textSize ]]) ifTrue: [ | attribs | 402666 attribs := text attributesAt: 1 forStyle: textStyle. 402667 Text string: stringOrText copy attributes: attribs. 402668 ] 402669 ifFalse: [ Text fromString: stringOrText copy ] 402670 ] 402671 ifFalse: [ stringOrText copy asText. "should be veryDeepCopy?" ]. 402672 402673 (text = newText and: [text runs = newText runs]) ifTrue: [^ self]. "No substantive change" 402674 text ifNotNil: [(embeddedMorphs := text embeddedMorphs) 402675 ifNotNil: 402676 [self removeAllMorphsIn: embeddedMorphs. 402677 embeddedMorphs do: [:m | m delete]]]. 402678 402679 text := newText. 402680 402681 "add all morphs off the visible region; they'll be moved into the right 402682 place when they become visible. (this can make the scrollable area too 402683 large, though)" 402684 newText embeddedMorphs do: 402685 [:m | 402686 self addMorph: m. 402687 m position: -1000 @ 0]. 402688 self releaseParagraph. 402689 "update the paragraph cache" 402690 self paragraph. 402691 "re-instantiate to set bounds" 402692 self world ifNotNil: [self world startSteppingSubmorphsOf: self]! ! 402693 402694!TextMorph methodsFor: 'accessing' stamp: 'nk 2/26/2001 12:45'! 402695selectAll 402696 self editor selectFrom: 1 to: text size! ! 402697 402698!TextMorph methodsFor: 'accessing' stamp: 'nk 2/26/2001 12:45'! 402699selectFrom: a to: b 402700 self editor selectFrom: a to: b! ! 402701 402702!TextMorph methodsFor: 'accessing' stamp: 'nk 2/26/2001 12:42'! 402703selection 402704 ^editor ifNotNil: [ editor selection ]! ! 402705 402706!TextMorph methodsFor: 'accessing' stamp: 'sw 9/1/2000 10:43'! 402707setCharacters: chars 402708 "obtain a string value from the receiver" 402709 402710 (self getCharacters = chars) ifFalse: 402711 [self newContents: chars]! ! 402712 402713!TextMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 22:32'! 402714setFirstCharacter: source 402715 "Set the first character of the receiver as indicated" 402716 | aChar chars | 402717 aChar := source asCharacter. 402718 (chars := self getCharacters) isEmpty 402719 ifTrue: [self 402720 newContents: (String with: aChar)] 402721 ifFalse: [chars first = aChar 402722 ifFalse: [self 402723 newContents: (String 402724 streamContents: [:aStream | 402725 aStream nextPut: aChar. 402726 aStream 402727 nextPutAll: (chars copyFrom: 2 to: chars size)])]] ! ! 402728 402729!TextMorph methodsFor: 'accessing' stamp: 'sw 8/10/2004 00:56'! 402730setLastCharacter: source 402731 "Set the last character of the receiver as indicated" 402732 402733 | aChar chars | 402734 aChar := source asCharacter. 402735 (chars := self getCharacters) size > 0 402736 ifFalse: 402737 [self newContents: (String with: aChar)] 402738 ifTrue: 402739 [(chars last = aChar) ifFalse: 402740 [self newContents: (String streamContents: 402741 [:aStream | 402742 aStream nextPutAll: (chars copyFrom: 1 to: (chars size - 1)). 402743 aStream nextPut: aChar])]]! ! 402744 402745!TextMorph methodsFor: 'accessing' stamp: 'tk 1/10/2001 13:52'! 402746text 402747 ^ text! ! 402748 402749!TextMorph methodsFor: 'accessing' stamp: 'nk 7/3/2003 18:33'! 402750textAlignment 402751 "Answer 1..4, representing #leftFlush, #rightFlush, #centered, or #justified" 402752 ^self editor textAlignment! ! 402753 402754!TextMorph methodsFor: 'accessing' stamp: 'nk 6/18/2003 14:28'! 402755textAlignmentSymbol 402756 "Answer one of #leftFlush, #rightFlush, #centered, or #justified" 402757 ^self editor textAlignmentSymbol! ! 402758 402759!TextMorph methodsFor: 'accessing' stamp: 'di 7/21/2001 10:37'! 402760textColor 402761 402762 ^ color! ! 402763 402764!TextMorph methodsFor: 'accessing' stamp: 'di 7/21/2001 10:35'! 402765textColor: aColor 402766 402767 color = aColor ifTrue: [^ self]. 402768 color := aColor. 402769 self changed. 402770! ! 402771 402772!TextMorph methodsFor: 'accessing' stamp: 'tk 9/1/2000 13:50'! 402773textStyle 402774 ^textStyle! ! 402775 402776!TextMorph methodsFor: 'accessing' stamp: 'tk 12/16/1998 11:58'! 402777userString 402778 "Do I have a text string to be searched on?" 402779 402780 ^ text string! ! 402781 402782!TextMorph methodsFor: 'accessing' stamp: 'di 7/27/2001 13:10'! 402783wrapFlag: aBoolean 402784 "Change whether contents are wrapped to the container." 402785 402786 aBoolean == wrapFlag ifTrue: [^ self]. 402787 wrapFlag := aBoolean. 402788 self composeToBounds! ! 402789 402790 402791!TextMorph methodsFor: 'alignment' stamp: 'di 10/25/97 19:19'! 402792centered 402793 self paragraph centered. 402794 self updateFromParagraph ! ! 402795 402796!TextMorph methodsFor: 'alignment' stamp: 'di 10/25/97 19:20'! 402797justified 402798 self paragraph justified. 402799 self updateFromParagraph! ! 402800 402801!TextMorph methodsFor: 'alignment' stamp: 'di 10/25/97 19:20'! 402802leftFlush 402803 self paragraph leftFlush. 402804 self updateFromParagraph! ! 402805 402806!TextMorph methodsFor: 'alignment' stamp: 'di 10/25/97 19:20'! 402807rightFlush 402808 self paragraph rightFlush. 402809 self updateFromParagraph! ! 402810 402811 402812!TextMorph methodsFor: 'anchors' stamp: 'ar 12/17/2001 13:38'! 402813adjustTextAnchor: aMorph 402814 "Later compute the new relative position of aMorph if it is #paragraph anchored."! ! 402815 402816!TextMorph methodsFor: 'anchors' stamp: 'ar 8/10/2003 18:19'! 402817anchorMorph: aMorph at: aPoint type: anchorType 402818 | relPt index newText block | 402819 aMorph owner == self ifTrue:[self removeMorph: aMorph]. 402820 aMorph textAnchorType: nil. 402821 aMorph relativeTextAnchorPosition: nil. 402822 self addMorphFront: aMorph. 402823 aMorph textAnchorType: anchorType. 402824 aMorph relativeTextAnchorPosition: nil. 402825 anchorType == #document ifTrue:[^self]. 402826 relPt := self transformFromWorld globalPointToLocal: aPoint. 402827 index := (self paragraph characterBlockAtPoint: relPt) stringIndex. 402828 newText := Text string: (String value: 1) attribute: (TextAnchor new anchoredMorph: aMorph). 402829 anchorType == #inline ifTrue:[ 402830 self paragraph replaceFrom: index to: index-1 with: newText displaying: false. 402831 ] ifFalse:[ 402832 index := index min: paragraph text size. 402833 index := paragraph text string lastIndexOf: Character cr startingAt: index ifAbsent:[0]. 402834 block := paragraph characterBlockForIndex: index+1. 402835 aMorph relativeTextAnchorPosition: (relPt x - bounds left) @ (relPt y - block top ). 402836 self paragraph replaceFrom: index+1 to: index with: newText displaying: false. 402837 ]. 402838 self fit.! ! 402839 402840 402841!TextMorph methodsFor: 'blinking' stamp: 'tbn 8/5/2009 09:53'! 402842blinkStart 402843 "Reset time for blink cursor after which blinking should actually start" 402844 ^self valueOfProperty: #blinkStart ifAbsent:[Time millisecondClockValue] 402845! ! 402846 402847!TextMorph methodsFor: 'blinking' stamp: 'tbn 8/5/2009 09:53'! 402848blinkStart: msecs 402849 "Reset time for blink cursor after which blinking should actually start" 402850 ^self setProperty: #blinkStart toValue: msecs 402851! ! 402852 402853!TextMorph methodsFor: 'blinking' stamp: 'tbn 8/5/2009 09:52'! 402854onBlinkCursor 402855 "Blink the cursor" 402856 | para | 402857 para := self paragraph ifNil:[^nil]. 402858 Time millisecondClockValue < self blinkStart ifTrue:[ 402859 "don't blink yet" 402860 ^para showCaret: para focused. 402861 ]. 402862 para showCaret: para showCaret not. 402863 para caretRect ifNotNilDo:[:r| self invalidRect: r].! ! 402864 402865!TextMorph methodsFor: 'blinking' stamp: 'tbn 8/5/2009 09:52'! 402866resetBlinkCursor 402867 "Reset the blinking cursor" 402868 | para | 402869 self blinkStart: Time millisecondClockValue + 500. 402870 para := self paragraph ifNil:[^self]. 402871 para showCaret = para focused ifFalse:[ 402872 para caretRect ifNotNilDo:[:r| self invalidRect: r]. 402873 para showCaret: para focused. 402874 ]. 402875! ! 402876 402877!TextMorph methodsFor: 'blinking' stamp: 'tbn 8/5/2009 09:49'! 402878startBlinking 402879 self startStepping: #onBlinkCursor 402880 at: Time millisecondClockValue 402881 arguments: nil stepTime: 500. 402882 self resetBlinkCursor. 402883! ! 402884 402885!TextMorph methodsFor: 'blinking' stamp: 'tbn 8/5/2009 09:48'! 402886stopBlinking 402887 self stopSteppingSelector: #onBlinkCursor. 402888! ! 402889 402890 402891!TextMorph methodsFor: 'caching' stamp: 'di 11/13/97 15:17'! 402892loadCachedState 402893 "Prepare for fast response -- next page of a book?" 402894 self paragraph! ! 402895 402896!TextMorph methodsFor: 'caching' stamp: 'BG 11/20/2004 12:36'! 402897releaseCachedState 402898 402899 super releaseCachedState. 402900 self releaseParagraph; paragraph. 402901! ! 402902 402903 402904!TextMorph methodsFor: 'change reporting' stamp: 'di 10/18/2004 13:50'! 402905ownerChanged 402906 | priorEditor | 402907 super ownerChanged. 402908 container ifNotNil: 402909 [editor isNil 402910 ifTrue: 402911 [self releaseParagraph. 402912 (container isKindOf: TextContainer) ifTrue: 402913 ["May need to recompose due to changes in owner" 402914 self installEditorToReplace: nil. 402915 self releaseParagraph]] 402916 ifFalse: 402917 [priorEditor := editor. 402918 self releaseParagraph. 402919 self installEditorToReplace: priorEditor]]! ! 402920 402921 402922!TextMorph methodsFor: 'classification' stamp: 'ar 12/17/2001 12:46'! 402923isTextMorph 402924 ^true! ! 402925 402926 402927!TextMorph methodsFor: 'containment' stamp: 'nk 8/18/2004 11:23'! 402928avoidsOcclusions 402929 ^container notNil and: [ container avoidsOcclusions ] 402930! ! 402931 402932!TextMorph methodsFor: 'containment' stamp: 'nk 8/18/2004 11:37'! 402933fillingOnOff 402934 "Establish a container for this text, with opposite filling status" 402935 self fillsOwner: (self fillsOwner not)! ! 402936 402937!TextMorph methodsFor: 'containment' stamp: 'nk 8/18/2004 11:21'! 402938fillsOwner 402939 "Answer true if I fill my owner's shape." 402940 ^container notNil and: [container fillsOwner]! ! 402941 402942!TextMorph methodsFor: 'containment' stamp: 'nk 8/18/2004 11:38'! 402943fillsOwner: aBoolean 402944 self fillsOwner == aBoolean 402945 ifTrue: [^ self]. 402946 self 402947 setContainer: (aBoolean 402948 ifTrue: [wrapFlag := true. 402949 container 402950 ifNil: [TextContainer new for: self minWidth: textStyle lineGrid * 2] 402951 ifNotNil: [container fillsOwner: true]] 402952 ifFalse: [self avoidsOcclusions 402953 ifFalse: [ nil ] 402954 ifTrue: [container fillsOwner: false]])! ! 402955 402956!TextMorph methodsFor: 'containment' stamp: 'di 11/4/97 15:37'! 402957occlusionsOnOff 402958 "Establish a container for this text, with opposite occlusion avoidance status" 402959 self setContainer: 402960 (container 402961 ifNil: [(TextContainer new for: self minWidth: textStyle lineGrid*2) 402962 fillsOwner: false; avoidsOcclusions: true] 402963 ifNotNil: [(container avoidsOcclusions and: [container fillsOwner not]) 402964 ifTrue: [nil "Return to simple rectangular bounds"] 402965 ifFalse: [container avoidsOcclusions: container avoidsOcclusions not]])! ! 402966 402967!TextMorph methodsFor: 'containment' stamp: 'sw 12/16/1998 09:09'! 402968recognizerArena 402969 "Answer the rectangular area, in world coordinates, that the character recognizer should regard as its tablet" 402970 402971 | outer | 402972 ^ (outer := self ownerThatIsA: PluggableTextMorph) 402973 ifNotNil: 402974 [outer boundsInWorld] 402975 ifNil: 402976 [self boundsInWorld]! ! 402977 402978!TextMorph methodsFor: 'containment' stamp: 'di 11/12/97 09:06'! 402979setContainer: newContainer 402980 "Adopt (or abandon) container shape" 402981 self changed. 402982 container := newContainer. 402983 self releaseParagraph! ! 402984 402985 402986!TextMorph methodsFor: 'copying' stamp: 'di 11/12/97 09:31'! 402987copy 402988 ^ super copy text: text copy textStyle: textStyle copy 402989 wrap: wrapFlag color: color 402990 predecessor: nil successor: nil! ! 402991 402992!TextMorph methodsFor: 'copying' stamp: 'tk 2/20/2001 18:55'! 402993veryDeepFixupWith: deepCopier 402994 "If target and arguments fields were weakly copied, fix them here. If 402995 they were in the tree being copied, fix them up, otherwise point to the 402996 originals!!" 402997 402998 super veryDeepFixupWith: deepCopier. 402999 "It makes no sense to share pointers to an existing predecessor and successor" 403000 predecessor := deepCopier references at: predecessor ifAbsent: [nil]. 403001 successor := deepCopier references at: successor ifAbsent: [nil]! ! 403002 403003!TextMorph methodsFor: 'copying' stamp: 'md 8/15/2005 11:17'! 403004veryDeepInner: deepCopier 403005 "Copy all of my instance variables. Some need to be not copied at all, but shared. 403006 Warning!!!! Every instance variable defined in this class must be handled. 403007 We must also implement veryDeepFixupWith:. See DeepCopier class comment." 403008 403009 super veryDeepInner: deepCopier. 403010 textStyle := textStyle veryDeepCopyWith: deepCopier. 403011 text := text veryDeepCopyWith: deepCopier. 403012 wrapFlag := wrapFlag veryDeepCopyWith: deepCopier. 403013 paragraph := paragraph veryDeepCopyWith: deepCopier. 403014 editor := editor veryDeepCopyWith: deepCopier. 403015 container := container veryDeepCopyWith: deepCopier. 403016 predecessor := predecessor. 403017 successor := successor. 403018 backgroundColor := backgroundColor veryDeepCopyWith: deepCopier. 403019 margins := margins veryDeepCopyWith: deepCopier. 403020 editHistory := editHistory veryDeepCopyWith: deepCopier. 403021! ! 403022 403023 403024!TextMorph methodsFor: 'drawing' stamp: 'di 7/24/2001 11:18'! 403025areasRemainingToFill: aRectangle 403026 "Overridden from BorderedMorph to test backgroundColor instead of (text) color." 403027 (backgroundColor isNil or: [backgroundColor isTranslucent]) 403028 ifTrue: [^ Array with: aRectangle]. 403029 self wantsRoundedCorners 403030 ifTrue: [(borderWidth > 0 and: [borderColor isColor and: [borderColor isTranslucent]]) 403031 ifTrue: [^ aRectangle areasOutside: (self innerBounds intersect: self boundsWithinCorners)] 403032 ifFalse: [^ aRectangle areasOutside: self boundsWithinCorners]] 403033 ifFalse: [(borderWidth > 0 and: [borderColor isColor and: [borderColor isTranslucent]]) 403034 ifTrue: [^ aRectangle areasOutside: self innerBounds] 403035 ifFalse: [^ aRectangle areasOutside: self bounds]]! ! 403036 403037!TextMorph methodsFor: 'drawing' stamp: 'di 7/12/2001 10:45'! 403038debugDrawLineRectsOn: aCanvas 403039 "Shows where text line rectangles are" 403040 self paragraph lines do: 403041 [:line | aCanvas frameRectangle: line rectangle color: Color brown] 403042! ! 403043 403044!TextMorph methodsFor: 'drawing' stamp: 'yo 1/23/2003 18:04'! 403045drawOnTest: aCanvas 403046 "Draw the receiver on a canvas" 403047 403048 | fauxBounds | 403049 self setDefaultContentsIfNil. 403050 super drawOn: aCanvas. "Border and background if any" 403051 false ifTrue: [self debugDrawLineRectsOn: aCanvas]. "show line rects for debugging" 403052 (self startingIndex > text size) 403053 ifTrue: [self drawNullTextOn: aCanvas]. 403054 "Hack here: The canvas expects bounds to carry the location of the text, but we also need to communicate clipping." 403055 fauxBounds := self bounds topLeft corner: self innerBounds bottomRight. 403056 aCanvas paragraph3: self paragraph bounds: fauxBounds color: color! ! 403057 403058 403059!TextMorph methodsFor: 'editing' stamp: 'di 4/22/1998 10:57'! 403060acceptContents 403061 "The message is sent when the user hits enter or Cmd-S. 403062 Accept the current contents and end editing. 403063 This default implementation does nothing." 403064 self updateFromParagraph! ! 403065 403066!TextMorph methodsFor: 'editing' stamp: 'sw 8/12/2002 01:10'! 403067acceptOnCR 403068 "Answer whether the receiver wants to accept when the Return key is hit. Generic TextMorph has no such feature, but subclasses may." 403069 403070 ^ false! ! 403071 403072!TextMorph methodsFor: 'editing' stamp: 'di 4/22/1998 11:00'! 403073cancelEdits 403074 "The message is sent when the user hits enter or Cmd-L. 403075 Cancel the current contents and end editing. 403076 This default implementation does nothing." 403077 self releaseParagraph! ! 403078 403079!TextMorph methodsFor: 'editing' stamp: 'di 10/5/1998 13:55'! 403080chooseAlignment 403081 self editor changeAlignment. 403082 self updateFromParagraph! ! 403083 403084!TextMorph methodsFor: 'editing' stamp: 'di 10/5/1998 13:55'! 403085chooseEmphasis 403086 self editor changeEmphasis. 403087 self updateFromParagraph! ! 403088 403089!TextMorph methodsFor: 'editing' stamp: 'sw 9/27/1999 12:13'! 403090chooseEmphasisOrAlignment 403091 self editor changeEmphasisOrAlignment. 403092 self updateFromParagraph! ! 403093 403094!TextMorph methodsFor: 'editing' stamp: 'ar 12/17/2001 13:09'! 403095chooseFont 403096 self editor changeTextFont. 403097 self updateFromParagraph.! ! 403098 403099!TextMorph methodsFor: 'editing' stamp: 'vj 9/14/2003 20:53'! 403100chooseStyle 403101 self editor changeStyle. 403102 self updateFromParagraph.! ! 403103 403104!TextMorph methodsFor: 'editing' stamp: 'ar 9/26/2001 22:45'! 403105enterClickableRegion: evt 403106 | index isLink | 403107 evt hand hasSubmorphs ifTrue:[^self]. 403108 evt hand temporaryCursor ifNotNil:[^self]. 403109 paragraph ifNotNil:[ 403110 index := (paragraph characterBlockAtPoint: evt position) stringIndex. 403111 isLink := (paragraph text attributesAt: index forStyle: paragraph textStyle) 403112 anySatisfy:[:attr| attr mayActOnClick]. 403113 isLink ifTrue:[Cursor webLink show] ifFalse:[Cursor normal show]. 403114 ]. 403115! ! 403116 403117!TextMorph methodsFor: 'editing' stamp: 'di 4/12/98 11:36'! 403118handleEdit: editBlock 403119 "Ensure that changed areas get suitably redrawn" 403120 self selectionChanged. "Note old selection" 403121 editBlock value. 403122 self selectionChanged. "Note new selection" 403123 self updateFromParagraph "Propagate changes as necessary"! ! 403124 403125!TextMorph methodsFor: 'editing' stamp: 'stephane.ducasse 7/12/2009 18:03'! 403126handleInteraction: interactionBlock 403127 "Perform the changes in interactionBlock, noting any change in selection 403128 and possibly a change in the size of the paragraph (ar 9/22/2001 - added for TextPrintIts)" 403129 "Also couple ParagraphEditor to Morphic keyboard events" 403130 | oldEditor oldParagraph oldText | 403131 oldEditor := self editor. 403132 oldParagraph := paragraph. 403133 oldText := oldParagraph text copy. 403134 403135 self selectionChanged. "Note old selection" 403136 403137 interactionBlock value. 403138 403139 (oldParagraph == paragraph) ifTrue:[ 403140 "this will not work if the paragraph changed" 403141 editor := oldEditor. "since it may have been changed while in block" 403142 ]. 403143 self selectionChanged. "Note new selection" 403144 (oldText = paragraph text and: [ oldText runs = paragraph text runs ]) 403145 ifFalse:[ self updateFromParagraph ]. 403146 self setCompositionWindow.! ! 403147 403148!TextMorph methodsFor: 'editing' stamp: 'di 4/21/1998 13:22'! 403149hasUnacceptedEdits: aBoolean 403150 "Ignored here, but noted in TextMorphForEditView" 403151! ! 403152 403153!TextMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:29'! 403154passKeyboardFocusTo: otherMorph 403155 | w | 403156 self flag: #arNote. "Do we need this?!!" 403157 (w := self world) isNil 403158 ifFalse: 403159 [w 403160 handsDo: [:h | h keyboardFocus == self ifTrue: [h newKeyboardFocus: otherMorph]]]! ! 403161 403162!TextMorph methodsFor: 'editing' stamp: 'fbs 1/7/2005 15:42'! 403163preferredKeyboardPosition 403164 403165 | default rects | 403166 default := (self bounds: self bounds in: World) topLeft. 403167 paragraph ifNil: [^ default]. 403168 rects := paragraph selectionRects. 403169 rects size = 0 ifTrue: [^ default]. 403170 ^ rects first topLeft. 403171 403172 "^ (self bounds: self bounds in: World) topLeft." 403173! ! 403174 403175!TextMorph methodsFor: 'editing' stamp: 'yo 11/7/2002 19:11'! 403176setCompositionWindow 403177 403178 | hand | 403179 hand := self primaryHand. 403180 hand ifNotNil: [hand compositionWindowManager keyboardFocusForAMorph: self]. 403181! ! 403182 403183 403184!TextMorph methodsFor: 'event handling' stamp: 'marcus.denker 11/19/2008 13:35'! 403185getMenu: shiftKeyState 403186 ^ shiftKeyState not 403187 ifTrue: [ParagraphEditor yellowButtonMenu] 403188 ifFalse: [ParagraphEditor shiftedYellowButtonMenu]! ! 403189 403190!TextMorph methodsFor: 'event handling' stamp: 'ar 10/4/2000 19:09'! 403191handlesKeyboard: evt 403192 ^true! ! 403193 403194!TextMorph methodsFor: 'event handling' stamp: 'di 7/21/2001 09:44'! 403195handlesMouseDown: evt 403196 self isPartsDonor ifTrue: [^ false]. 403197 ^ self innerBounds containsPoint: evt cursorPoint! ! 403198 403199!TextMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 19:04'! 403200hasFocus 403201 ^editor notNil! ! 403202 403203!TextMorph methodsFor: 'event handling' stamp: 'tbn 8/5/2009 16:10'! 403204keyStroke: evt 403205 "Handle a keystroke event." 403206 self resetBlinkCursor. "don't blink during type-in" 403207 ToolSet codeCompletionAround: [| action | 403208 evt keyValue = 13 ifTrue:["CR - check for special action" 403209 action := self crAction. 403210 action ifNotNil:[ 403211 "Note: Code below assumes that this was some 403212 input field reacting on CR. Break the keyboard 403213 focus so that the receiver can be safely deleted." 403214 evt hand newKeyboardFocus: nil. 403215 ^ action value]]. 403216 self handleInteraction: [editor keystroke: evt]. 403217 self updateFromParagraph. 403218 super keyStroke: evt "sends to keyStroke event handler, if any"] 403219 403220 textMorph: self keyStroke: evt! ! 403221 403222!TextMorph methodsFor: 'event handling' stamp: 'michael.rueger 2/23/2009 18:34'! 403223mouseDown: evt 403224 "Make this TextMorph be the keyboard input focus, if it isn't 403225 already, and repond to the text selection gesture. 403226 Changed to not take keyboard focus if an owner is a 403227 PluggableTextMorph that doesn't want focus." 403228 403229 evt yellowButtonPressed 403230 ifTrue: ["First check for option (menu) click" 403231 ^ self yellowButtonActivity: evt shiftPressed]. 403232 self hasKeyboardFocus 403233 ifFalse: [(self ownerThatIsA: PluggableTextMorph) 403234 ifNil: [self takeKeyboardFocus] 403235 ifNotNilDo: [:ptm | ptm wantsKeyboardFocus ifTrue: [ 403236 self takeKeyboardFocus]]]. 403237 self handleInteraction: [editor mouseDown: evt]! ! 403238 403239!TextMorph methodsFor: 'event handling' stamp: 'michael.rueger 2/23/2009 18:35'! 403240mouseMove: evt 403241 evt redButtonPressed ifFalse: [^ self enterClickableRegion: evt]. 403242 self handleInteraction: [editor mouseMove: evt]! ! 403243 403244!TextMorph methodsFor: 'event handling' stamp: 'michael.rueger 2/23/2009 18:35'! 403245mouseUp: evt 403246 self handleInteraction: [editor mouseUp: evt]! ! 403247 403248!TextMorph methodsFor: 'event handling' stamp: 'dgd 8/28/2004 13:54'! 403249wouldAcceptKeyboardFocusUponTab 403250 "Answer whether the receiver might accept keyboard focus if 403251 tab were hit in some container playfield" 403252 ^ self inPartsBin not! ! 403253 403254!TextMorph methodsFor: 'event handling' stamp: 'dgd 10/1/2004 13:24'! 403255yellowButtonActivity 403256 "Supply the normal 'code pane' menu to use its text editing 403257 commands from a menu." 403258 self yellowButtonActivity:false! ! 403259 403260 403261!TextMorph methodsFor: 'events-processing' stamp: 'sw 3/1/2001 17:16'! 403262handleKeystroke: anEvent 403263 "System level event handling." 403264 403265 | pasteUp | 403266 anEvent wasHandled ifTrue:[^self]. 403267 (self handlesKeyboard: anEvent) ifFalse: [^ self]. 403268 anEvent wasHandled: true. 403269 anEvent keyCharacter = Character tab ifTrue: 403270 ["Allow passing through text morph inside pasteups" 403271 (self wouldAcceptKeyboardFocusUponTab and: 403272 [(pasteUp := self pasteUpMorphHandlingTabAmongFields) notNil]) 403273 ifTrue:[^ pasteUp tabHitWithEvent: anEvent]]. 403274 self keyStroke: anEvent! ! 403275 403276!TextMorph methodsFor: 'events-processing' stamp: 'ar 9/26/2001 22:21'! 403277handleMouseMove: anEvent 403278 "Re-implemented to allow for mouse-up move events" 403279 anEvent wasHandled ifTrue:[^self]. "not interested" 403280 (anEvent hand hasSubmorphs) ifTrue:[^self]. 403281 anEvent wasHandled: true. 403282 self mouseMove: anEvent. 403283 (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self]. 403284 (self handlesMouseStillDown: anEvent) ifTrue:[ 403285 "Step at the new location" 403286 self startStepping: #handleMouseStillDown: 403287 at: Time millisecondClockValue 403288 arguments: {anEvent copy resetHandlerFields} 403289 stepTime: 1]. 403290! ! 403291 403292 403293!TextMorph methodsFor: 'geometry' stamp: 'di 10/8/1998 23:46'! 403294bounds 403295 container ifNil: [^ bounds]. 403296 ^ container bounds ifNil: [bounds]! ! 403297 403298!TextMorph methodsFor: 'geometry' stamp: 'di 7/19/2001 10:57'! 403299container 403300 "Return the container for composing this text. There are four cases: 403301 1. container is specified as, eg, an arbitrary shape, 403302 2. container is specified as the bound rectangle, because 403303 this morph is linked to others, 403304 3. container is nil, and wrap is true -- grow downward as necessary, 403305 4. container is nil, and wrap is false -- grow in 2D as nexessary." 403306 403307 container ifNil: 403308 [successor ifNotNil: [^ self compositionRectangle]. 403309 wrapFlag ifTrue: [^ self compositionRectangle withHeight: 9999999]. 403310 ^ self compositionRectangle topLeft extent: 9999999@9999999]. 403311 ^ container! ! 403312 403313!TextMorph methodsFor: 'geometry' stamp: 'di 8/14/1998 15:50'! 403314defaultLineHeight 403315 ^ textStyle lineGrid! ! 403316 403317!TextMorph methodsFor: 'geometry' stamp: 'nk 7/11/2004 20:07'! 403318extent: aPoint 403319 | newExtent priorEditor | 403320 bounds extent = aPoint ifTrue: [^ self]. 403321 priorEditor := editor. 403322 self isAutoFit 403323 ifTrue: [wrapFlag ifFalse: [^ self]. "full autofit can't change" 403324 newExtent := aPoint truncated max: self minimumExtent. 403325 newExtent x = self extent x ifTrue: [^ self]. "No change of wrap width" 403326 self releaseParagraphReally. "invalidate the paragraph cache" 403327 super extent: newExtent. 403328 priorEditor 403329 ifNil: [self fit] "since the width has changed..." 403330 ifNotNil: [self installEditorToReplace: priorEditor]] 403331 ifFalse: [super extent: (aPoint truncated max: self minimumExtent). 403332 wrapFlag ifFalse: [^ self]. "no effect on composition" 403333 self composeToBounds] 403334! ! 403335 403336!TextMorph methodsFor: 'geometry' stamp: 'di 7/20/2001 22:51'! 403337minimumExtent 403338 | minExt | 403339 textStyle ifNil: [^ 9@16]. 403340 borderWidth ifNil: [^ 9@16]. 403341 minExt := (9@(textStyle lineGrid+2)) + (borderWidth*2). 403342 margins ifNil: [^ minExt]. 403343 ^ ((0@0 extent: minExt) expandBy: margins) extent! ! 403344 403345!TextMorph methodsFor: 'geometry' stamp: 'dgd 2/21/2003 22:29'! 403346privateMoveBy: delta 403347 super privateMoveBy: delta. 403348 editor isNil 403349 ifTrue: [paragraph ifNotNil: [paragraph moveBy: delta]] 403350 ifFalse: 403351 ["When moving text with an active editor, save and restore all state." 403352 403353 paragraph moveBy: delta. 403354 self installEditorToReplace: editor]! ! 403355 403356!TextMorph methodsFor: 'geometry' stamp: 'di 3/1/98 11:40'! 403357textBounds 403358 ^ bounds! ! 403359 403360 403361!TextMorph methodsFor: 'geometry testing' stamp: 'di 7/12/2001 22:15'! 403362containsPoint: aPoint 403363 (super containsPoint: aPoint) ifFalse: [^ false]. "Not in my bounds" 403364 container ifNil: [^ true]. "In bounds of simple text" 403365 self startingIndex > text size ifTrue: 403366 ["make null text frame visible" 403367 ^ super containsPoint: aPoint]. 403368 "In complex text (non-rect container), test by line bounds" 403369 ^ self paragraph containsPoint: aPoint 403370! ! 403371 403372 403373!TextMorph methodsFor: 'initialization' stamp: 'di 12/29/97 14:42'! 403374beAllFont: aFont 403375 403376 textStyle := TextStyle fontArray: (Array with: aFont). 403377 self releaseCachedState; changed! ! 403378 403379!TextMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'! 403380defaultColor 403381 "answer the default color/fill style for the receiver" 403382 ^ Color black! ! 403383 403384!TextMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:12'! 403385initialize 403386 super initialize. 403387 borderWidth := 0. 403388 textStyle := TextStyle default copy. 403389 wrapFlag := true. 403390! ! 403391 403392!TextMorph methodsFor: 'initialization' stamp: 'di 11/17/2001 15:34'! 403393setTextStyle: aTextStyle 403394 403395 textStyle := aTextStyle. 403396 self releaseCachedState; changed! ! 403397 403398!TextMorph methodsFor: 'initialization' stamp: 'mir 8/2/1999 10:34'! 403399string: aString fontName: aName size: aSize 403400 403401 self string: aString fontName: aName size: aSize wrap: true! ! 403402 403403!TextMorph methodsFor: 'initialization' stamp: 'mir 8/2/1999 10:35'! 403404string: aString fontName: aName size: aSize wrap: shouldWrap 403405 403406 shouldWrap 403407 ifTrue: [self contentsWrapped: aString] 403408 ifFalse: [self contents: aString]. 403409 self fontName: aName size: aSize! ! 403410 403411 403412!TextMorph methodsFor: 'layout' stamp: 'tk 6/30/1998 17:06'! 403413acceptDroppingMorph: aMorph event: evt 403414 "This message is sent when a morph is dropped onto me." 403415 403416 self addMorphFront: aMorph fromWorldPosition: aMorph position. 403417 "Make a TextAnchor and install it in a run."! ! 403418 403419 403420!TextMorph methodsFor: 'linked frames' stamp: 'di 7/28/2001 10:34'! 403421addPredecessor: evt 403422 | newMorph | 403423 newMorph := self copy predecessor: predecessor successor: self. 403424 newMorph extent: self width @ 100. 403425 predecessor ifNotNil: [predecessor setSuccessor: newMorph]. 403426 self setPredecessor: newMorph. 403427 predecessor recomposeChain. 403428 evt hand attachMorph: newMorph! ! 403429 403430!TextMorph methodsFor: 'linked frames' stamp: 'di 7/28/2001 10:35'! 403431addSuccessor: evt 403432 | newMorph | 403433 newMorph := self copy predecessor: self successor: successor. 403434 newMorph extent: self width @ 100. 403435 successor ifNotNil: [successor setPredecessor: newMorph]. 403436 self setSuccessor: newMorph. 403437 successor recomposeChain. 403438 evt hand attachMorph: newMorph! ! 403439 403440!TextMorph methodsFor: 'linked frames' stamp: 'di 11/8/97 15:51'! 403441firstCharacterIndex 403442 ^ self paragraph firstCharacterIndex! ! 403443 403444!TextMorph methodsFor: 'linked frames' stamp: 'dgd 2/21/2003 22:26'! 403445firstInChain 403446 "Return the first morph in a chain of textMorphs" 403447 403448 | first | 403449 first := self. 403450 [first predecessor isNil] whileFalse: [first := first predecessor]. 403451 ^first! ! 403452 403453!TextMorph methodsFor: 'linked frames' stamp: 'di 11/16/97 15:15'! 403454isLinkedTo: aMorph 403455 self firstInChain withSuccessorsDo: 403456 [:m | m == aMorph ifTrue: [^ true]]. 403457 ^ false! ! 403458 403459!TextMorph methodsFor: 'linked frames' stamp: 'jm 10/28/97 18:31'! 403460lastCharacterIndex 403461 ^ self paragraph lastCharacterIndex! ! 403462 403463!TextMorph methodsFor: 'linked frames' stamp: 'jm 10/28/97 18:31'! 403464predecessor 403465 ^ predecessor! ! 403466 403467!TextMorph methodsFor: 'linked frames' stamp: 'di 11/12/97 09:10'! 403468recomposeChain 403469 "Recompose this textMorph and all that follow it." 403470 self withSuccessorsDo: 403471 [:m | m text: text textStyle: textStyle; "Propagate new style if any" 403472 releaseParagraph; "Force recomposition" 403473 fit "and propagate the change"]! ! 403474 403475!TextMorph methodsFor: 'linked frames' stamp: 'dgd 2/21/2003 22:32'! 403476startingIndex 403477 predecessor isNil 403478 ifTrue: [^ 1]. 403479 ^ predecessor lastCharacterIndex + 1 ! ! 403480 403481!TextMorph methodsFor: 'linked frames' stamp: 'jm 10/28/97 18:31'! 403482successor 403483 ^ successor! ! 403484 403485!TextMorph methodsFor: 'linked frames' stamp: 'dgd 2/21/2003 22:32'! 403486withSuccessorsDo: aBlock 403487 "Evaluate aBlock for each morph in my successor chain" 403488 403489 | each | 403490 each := self. 403491 [each isNil] whileFalse: 403492 [aBlock value: each. 403493 each := each successor]! ! 403494 403495 403496!TextMorph methodsFor: 'menu' stamp: 'adrian_lienhard 7/19/2009 17:30'! 403497addCustomMenuItems: aCustomMenu hand: aHandMorph 403498 | outer | 403499 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 403500 aCustomMenu addUpdating: #autoFitString target: self action: #autoFitOnOff. 403501 aCustomMenu addUpdating: #wrapString target: self action: #wrapOnOff. 403502 aCustomMenu add: 'text margins...' translated action: #changeMargins:. 403503 aCustomMenu add: 'add predecessor' translated action: #addPredecessor:. 403504 aCustomMenu add: 'add successor' translated action: #addSuccessor:. 403505 aCustomMenu add: 'code pane menu...' translated action: #yellowButtonActivity. 403506 aCustomMenu add: 'code pane shift menu...' translated action: #shiftedYellowButtonActivity. 403507 403508 outer := self owner. 403509 outer ifNotNil: [ 403510 outer isLineMorph ifTrue: 403511 [container isNil 403512 ifFalse: [aCustomMenu add: 'reverse direction' translated action: #reverseCurveDirection. 403513 aCustomMenu add: 'set baseline' translated action: #setCurveBaseline:]] 403514 ifFalse: 403515 [self fillsOwner 403516 ifFalse: [aCustomMenu add: 'fill owner''s shape' translated action: #fillingOnOff] 403517 ifTrue: [aCustomMenu add: 'rectangular bounds' translated action: #fillingOnOff]. 403518 self avoidsOcclusions 403519 ifFalse: [aCustomMenu add: 'avoid occlusions' translated action: #occlusionsOnOff] 403520 ifTrue: [aCustomMenu add: 'ignore occlusions' translated action: #occlusionsOnOff]]]. 403521 aCustomMenu addLine. 403522 aCustomMenu add: 'holder for characters' translated action: #holderForCharacters 403523! ! 403524 403525!TextMorph methodsFor: 'menu' stamp: 'di 7/27/2001 13:19'! 403526autoFitOnOff 403527 self setProperty: #autoFitContents toValue: self isAutoFit not. 403528 self isAutoFit ifTrue: [self fit]! ! 403529 403530!TextMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:06'! 403531autoFitString 403532 "Answer the string to put in a menu that will invite the user to 403533 switch autoFit mode" 403534 ^ (self isAutoFit 403535 ifTrue: ['<yes>'] 403536 ifFalse: ['<no>']) 403537 , 'text auto fit' translated! ! 403538 403539!TextMorph methodsFor: 'menu' stamp: 'marcus.denker 11/10/2008 10:04'! 403540changeMargins: evt 403541 | handle origin aHand oldMargin newMargin | 403542 aHand := evt ifNil: [self primaryHand] ifNotNil: [evt hand]. 403543 origin := aHand position. 403544 oldMargin := margins. 403545 handle := HandleMorph new 403546 forEachPointDo: 403547 [:newPoint | handle removeAllMorphs. 403548 handle addMorph: 403549 (LineMorph from: origin to: newPoint color: Color black width: 1). 403550 newMargin := (newPoint - origin max: 0@0) // 5. 403551 self margins: newMargin] 403552 lastPointDo: 403553 [:newPoint | handle deleteBalloon. 403554 self halo ifNotNil: [:halo | halo addHandles]. 403555 self rememberCommand: 403556 (Command new cmdWording: ('margin change for ' translated,self nameForUndoWording); 403557 undoTarget: self selector: #margins: argument: oldMargin; 403558 redoTarget: self selector: #margins: argument: newMargin; 403559 yourself)]. 403560 aHand attachMorph: handle. 403561 handle setProperty: #helpAtCenter toValue: true. 403562 handle showBalloon: 403563'Move cursor down and to the right 403564to increase margin inset. 403565Click when done.' hand: evt hand. 403566 handle startStepping! ! 403567 403568!TextMorph methodsFor: 'menu' stamp: 'sw 2/18/2003 03:20'! 403569holderForCharacters 403570 "Hand the user a Holder that is populated with individual text morphs representing my characters" 403571 403572 | aHolder | 403573 aHolder := ScriptingSystem prototypicalHolder. 403574 aHolder setNameTo: 'H', self externalName. 403575 text string do: 403576 [:aChar | 403577 aHolder addMorphBack: (TextMorph new contents: aChar asText)]. 403578 aHolder setProperty: #donorTextMorph toValue: self. 403579 aHolder fullBounds. 403580 aHolder openInHand! ! 403581 403582!TextMorph methodsFor: 'menu' stamp: 'di 12/3/97 09:40'! 403583reverseCurveDirection 403584 container textDirection: container textDirection negated. 403585 self paragraph composeAll! ! 403586 403587!TextMorph methodsFor: 'menu' stamp: 'di 12/3/97 10:25'! 403588setCurveBaseline: evt 403589 | handle origin | 403590 origin := evt cursorPoint. 403591 handle := HandleMorph new forEachPointDo: 403592 [:newPoint | handle removeAllMorphs. 403593 handle addMorph: 403594 (PolygonMorph vertices: (Array with: origin with: newPoint) 403595 color: Color black borderWidth: 1 borderColor: Color black). 403596 container baseline: (newPoint - origin) y negated asInteger // 5. 403597 self paragraph composeAll]. 403598 evt hand attachMorph: handle. 403599 handle startStepping ! ! 403600 403601!TextMorph methodsFor: 'menu' stamp: 'tk 7/14/2000 12:20'! 403602shiftedYellowButtonActivity 403603 "Supply the normal 'code pane' menu to use its text editing commands from a menu." 403604 403605 self editor pluggableYellowButtonActivity: true. 403606 self changed. 403607! ! 403608 403609!TextMorph methodsFor: 'menu' stamp: 'di 7/27/2001 13:20'! 403610wrapOnOff 403611 self wrapFlag: wrapFlag not! ! 403612 403613!TextMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:18'! 403614wrapString 403615 "Answer the string to put in a menu that will invite the user to 403616 switch autoFit mode" 403617 ^ (wrapFlag 403618 ifTrue: ['<yes>'] 403619 ifFalse: ['<no>']) 403620 , 'text wrap to bounds' translated! ! 403621 403622 403623!TextMorph methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 22:57'! 403624editHistory 403625 editHistory ifNil: [ editHistory := TextMorphCommandHistory new]. 403626 ^editHistory 403627! ! 403628 403629!TextMorph methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 16:49'! 403630editHistory: aTextMorphCommandHistory 403631 ^editHistory := aTextMorphCommandHistory 403632! ! 403633 403634 403635!TextMorph methodsFor: 'objects from disk' stamp: 'tk 11/29/2004 16:54'! 403636fixUponLoad: aProject seg: anImageSegment 403637 "We are in an old project that is being loaded from disk. 403638Fix up conventions that have changed." 403639 403640 | substituteFont | 403641 substituteFont := aProject projectParameters at: 403642#substitutedFont ifAbsent: [#none]. 403643 (substituteFont ~~ #none and: [self textStyle fontArray 403644includes: substituteFont]) 403645 ifTrue: [ self fit ]. 403646 403647 ^ super fixUponLoad: aProject seg: anImageSegment! ! 403648 403649 403650!TextMorph methodsFor: 'scripting access' stamp: 'sw 9/15/2000 06:14'! 403651getAllButFirstCharacter 403652 "Obtain all but the first character from the receiver; if that would be empty, return a black dot" 403653 403654 | aString | 403655 ^ (aString := text string) size > 1 ifTrue: [aString copyFrom: 2 to: aString size] ifFalse: ['·']! ! 403656 403657!TextMorph methodsFor: 'scripting access' stamp: 'sw 10/13/2004 19:57'! 403658insertCharacters: aSource 403659 "Insert the characters from the given source at my current cursor position" 403660 403661 | aLoc | 403662 aLoc := self cursor max: 1. 403663 paragraph replaceFrom: aLoc to: (aLoc - 1) with: aSource asText displaying: true. 403664 self updateFromParagraph ! ! 403665 403666 403667!TextMorph methodsFor: 'submorphs-add/remove' stamp: 'ar 12/17/2001 13:21'! 403668addMorphFront: aMorph fromWorldPosition: wp 403669 "Overridden for more specific re-layout and positioning" 403670 aMorph textAnchorType == #document 403671 ifFalse:[^self anchorMorph: aMorph at: wp type: aMorph textAnchorType]. 403672 self addMorphFront: aMorph. 403673! ! 403674 403675!TextMorph methodsFor: 'submorphs-add/remove' stamp: 'di 11/7/97 10:00'! 403676delete 403677 predecessor ifNotNil: [predecessor setSuccessor: successor]. 403678 successor ifNotNil: [successor setPredecessor: predecessor. 403679 successor recomposeChain]. 403680 super delete! ! 403681 403682!TextMorph methodsFor: 'submorphs-add/remove' stamp: 'di 11/16/97 16:52'! 403683goBehind 403684 "We need to save the container, as it knows about fill and run-around" 403685 | cont | 403686 container ifNil: [^ super goBehind]. 403687 self releaseParagraph. "Cause recomposition" 403688 cont := container. "Save the container" 403689 super goBehind. "This will change owner, nilling the container" 403690 container := cont. "Restore the container" 403691 self changed! ! 403692 403693 403694!TextMorph methodsFor: 'testing' stamp: 'tk 11/1/2001 14:37'! 403695basicType 403696 "Answer a symbol representing the inherent type I hold" 403697 403698 "Number String Boolean player collection sound color etc" 403699 ^ #Text! ! 403700 403701 403702!TextMorph methodsFor: 'visual properties' stamp: 'dgd 2/16/2003 20:03'! 403703fillStyle 403704 "Return the current fillStyle of the receiver." 403705 ^ self 403706 valueOfProperty: #fillStyle 403707 ifAbsent: [backgroundColor 403708 ifNil: [Color transparent]]! ! 403709 403710!TextMorph methodsFor: 'visual properties' stamp: 'di 6/22/2001 09:52'! 403711fillStyle: aFillStyle 403712 "Set the current fillStyle of the receiver." 403713 self setProperty: #fillStyle toValue: aFillStyle. 403714 "Workaround for Morphs not yet converted" 403715 backgroundColor := aFillStyle asColor. 403716 self changed.! ! 403717 403718 403719!TextMorph methodsFor: 'private' stamp: 'di 11/8/97 16:02'! 403720adjustLineIndicesBy: delta 403721 paragraph ifNotNil: [paragraph adjustLineIndicesBy: delta]! ! 403722 403723!TextMorph methodsFor: 'private' stamp: 'di 6/22/2001 09:10'! 403724clippingRectangle 403725 ^ self innerBounds! ! 403726 403727!TextMorph methodsFor: 'private' stamp: 'di 8/4/2000 16:06'! 403728composeToBounds 403729 "Compose my text to fit my bounds. 403730 If any text lies outside my bounds, it will be clipped, or 403731 if I have successors, it will be shown in the successors." 403732 | | 403733 self releaseParagraph; paragraph. 403734 container ifNotNil: 403735 [self privateBounds: container bounds truncated]. 403736 self paragraph positionWhenComposed: self position. 403737 successor ifNotNil: 403738 [successor predecessorChanged]. 403739 403740! ! 403741 403742!TextMorph methodsFor: 'private' stamp: 'di 7/20/2001 22:18'! 403743compositionRectangle 403744 | compRect | 403745 compRect := self innerBounds. 403746 margins ifNotNil: [compRect := compRect insetBy: margins]. 403747 compRect width < 9 ifTrue: [compRect := compRect withWidth: 9]. 403748 compRect height < 16 ifTrue: [compRect := compRect withHeight: 16]. 403749 ^ compRect! ! 403750 403751!TextMorph methodsFor: 'private' stamp: 'tween 8/29/2004 20:33'! 403752editorClass 403753 "Answer the class used to create the receiver's editor" 403754 403755 ^TextMorphEditor! ! 403756 403757!TextMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 14:57'! 403758fit 403759 "Adjust my bounds to fit the text. Should be a no-op if autoFit is not specified. 403760 Required after the text changes, 403761 or if wrapFlag is true and the user attempts to change the extent." 403762 403763 | newExtent para cBounds lastOfLines heightOfLast | 403764 self isAutoFit 403765 ifTrue: 403766 [newExtent := (self paragraph extent max: 9 @ textStyle lineGrid) + (0 @ 2). 403767 newExtent := newExtent + (2 * borderWidth). 403768 margins 403769 ifNotNil: [newExtent := ((0 @ 0 extent: newExtent) expandBy: margins) extent]. 403770 newExtent ~= bounds extent 403771 ifTrue: 403772 [(container isNil and: [successor isNil]) 403773 ifTrue: 403774 [para := paragraph. "Save para (layoutChanged smashes it)" 403775 super extent: newExtent. 403776 paragraph := para]]. 403777 container notNil & successor isNil 403778 ifTrue: 403779 [cBounds := container bounds truncated. 403780 "23 sept 2000 - try to allow vertical growth" 403781 lastOfLines := self paragraph lines last. 403782 heightOfLast := lastOfLines bottom - lastOfLines top. 403783 (lastOfLines last < text size 403784 and: [lastOfLines bottom + heightOfLast >= self bottom]) 403785 ifTrue: 403786 [container releaseCachedState. 403787 cBounds := cBounds origin corner: cBounds corner + (0 @ heightOfLast)]. 403788 self privateBounds: cBounds]]. 403789 403790 "These statements should be pushed back into senders" 403791 self paragraph positionWhenComposed: self position. 403792 successor ifNotNil: [successor predecessorChanged]. 403793 self changed "Too conservative: only paragraph composition 403794 should cause invalidation."! ! 403795 403796!TextMorph methodsFor: 'private' stamp: 'RAA 2/16/2001 08:15'! 403797installEditor 403798 403799 403800 self flag: #bob. "I don't see any senders (16 Feb 2001)" 403801 403802 403803 "Install an editor for my paragraph. This constitutes 'hasFocus'." 403804 editor ifNotNil: [^ editor]. 403805 ^ self installEditorToReplace: nil! ! 403806 403807!TextMorph methodsFor: 'private' stamp: 'tween 8/29/2004 20:34'! 403808installEditorToReplace: priorEditor 403809 "Install an editor for my paragraph. This constitutes 'hasFocus'. 403810 If priorEditor is not nil, then initialize the new editor from its state. 403811 We may want to rework this so it actually uses the prior editor." 403812 403813 | stateArray | 403814 priorEditor ifNotNil: [stateArray := priorEditor stateArray]. 403815 editor := self editorClass new morph: self. 403816 editor changeParagraph: self paragraph. 403817 priorEditor ifNotNil: [editor stateArrayPut: stateArray]. 403818 self selectionChanged. 403819 ^ editor! ! 403820 403821!TextMorph methodsFor: 'private' stamp: 'hpt 4/11/2004 20:35'! 403822paragraph 403823 "Paragraph instantiation is lazy -- create it only when needed" 403824 paragraph ifNotNil: [^ paragraph]. 403825 403826self setProperty: #CreatingParagraph toValue: true. 403827 403828 self setDefaultContentsIfNil. 403829 403830 "...Code here to recreate the paragraph..." 403831 paragraph := (self paragraphClass new textOwner: self owner). 403832 paragraph wantsColumnBreaks: successor notNil. 403833 paragraph 403834 compose: text 403835 style: textStyle copy 403836 from: self startingIndex 403837 in: self container. 403838 wrapFlag ifFalse: 403839 ["Was given huge container at first... now adjust" 403840 paragraph adjustRightX]. 403841 paragraph focused: (self currentHand keyboardFocus == self). 403842 self fit. 403843self removeProperty: #CreatingParagraph. 403844 403845 403846 ^ paragraph! ! 403847 403848!TextMorph methodsFor: 'private' stamp: 'yo 1/3/2003 12:21'! 403849paragraphClass 403850 container ifNil: [^ MultiNewParagraph]. 403851 ^ container paragraphClass! ! 403852 403853!TextMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 22:29'! 403854predecessorChanged 403855 | newStart oldStart | 403856 (self hasProperty: #CreatingParagraph) ifTrue: [^self]. 403857 newStart := predecessor isNil 403858 ifTrue: [1] 403859 ifFalse: [predecessor lastCharacterIndex + 1]. 403860 (self paragraph adjustedFirstCharacterIndex ~= newStart 403861 or: [newStart >= text size]) 403862 ifTrue: 403863 [paragraph composeAllStartingAt: newStart. 403864 self fit] 403865 ifFalse: 403866 ["If the offset to end of text has not changed, just slide" 403867 403868 oldStart := self firstCharacterIndex. 403869 self withSuccessorsDo: [:m | m adjustLineIndicesBy: newStart - oldStart]]! ! 403870 403871!TextMorph methodsFor: 'private' stamp: 'di 7/28/2001 10:33'! 403872predecessor: pred successor: succ 403873 "Private -- for use only in morphic duplication" 403874 predecessor := pred. 403875 successor := succ. 403876! ! 403877 403878!TextMorph methodsFor: 'private' stamp: 'tk 9/28/1999 16:50'! 403879privateOwner: newOwner 403880 "Nil the container when text gets extracted" 403881 super privateOwner: newOwner. 403882 container ifNotNil: [ 403883 newOwner ifNotNil: [ 403884 newOwner isWorldOrHandMorph ifTrue: [self setContainer: nil]]]! ! 403885 403886!TextMorph methodsFor: 'private' stamp: 'di 10/5/1998 16:39'! 403887releaseEditor 403888 "Release the editor for my paragraph. This morph no longer 'hasFocus'." 403889 editor ifNotNil: 403890 [self selectionChanged. 403891 self paragraph selectionStart: nil selectionStop: nil. 403892 editor := nil].! ! 403893 403894!TextMorph methodsFor: 'private' stamp: 'RAA 12/5/2001 11:20'! 403895releaseParagraph 403896 403897 "a slight kludge so subclasses can have a bit more control over whether the paragraph really 403898 gets released. important for GeeMail since the selection needs to be accessible even if the 403899 hand is outside me" 403900 403901 self releaseParagraphReally. 403902! ! 403903 403904!TextMorph methodsFor: 'private' stamp: 'RAA 12/5/2001 11:20'! 403905releaseParagraphReally 403906 403907 "a slight kludge so subclasses can have a bit more control over whether the paragraph really 403908 gets released. important for GeeMail since the selection needs to be accessible even if the 403909 hand is outside me" 403910 403911 "Paragraph instantiation is lazy -- it will be created only when needed" 403912 self releaseEditor. 403913 paragraph ifNotNil: 403914 [paragraph := nil]. 403915 container ifNotNil: 403916 [container releaseCachedState]! ! 403917 403918!TextMorph methodsFor: 'private' stamp: 'ar 8/10/2003 18:12'! 403919removedMorph: aMorph 403920 | range | 403921 range := text find: (TextAnchor new anchoredMorph: aMorph). 403922 range ifNotNil: 403923 [self paragraph replaceFrom: range first to: range last 403924 with: Text new displaying: false. 403925 self fit]. 403926 aMorph textAnchorType: nil. 403927 aMorph relativeTextAnchorPosition: nil. 403928 super removedMorph: aMorph.! ! 403929 403930!TextMorph methodsFor: 'private' stamp: 'nk 8/29/2004 21:40'! 403931selectionChanged 403932 "Invalidate all the selection rectangles. 403933 Make sure that any drop shadow is accounted for too." 403934 self paragraph selectionRects 403935 do: [:r | self 403936 invalidRect: (self expandFullBoundsForDropShadow: (r intersect: self fullBounds))]! ! 403937 403938!TextMorph methodsFor: 'private' stamp: 'tk 11/13/2001 01:57'! 403939setDefaultContentsIfNil 403940 "Set the default contents" 403941 403942 | toUse | 403943 text ifNil: 403944 [toUse := self valueOfProperty: #defaultContents. 403945 toUse ifNil: [toUse :='abc' asText "allBold"]. "try it plain for a while" 403946 text := toUse]! ! 403947 403948!TextMorph methodsFor: 'private' stamp: 'di 10/25/97 17:11'! 403949setPredecessor: newPredecessor 403950 predecessor := newPredecessor! ! 403951 403952!TextMorph methodsFor: 'private' stamp: 'RAA 5/6/2001 15:12'! 403953setSuccessor: newSuccessor 403954 403955 successor := newSuccessor. 403956 paragraph ifNotNil: [paragraph wantsColumnBreaks: successor notNil]. 403957! ! 403958 403959!TextMorph methodsFor: 'private' stamp: 'di 10/24/97 11:35'! 403960text: t textStyle: s 403961 "Private -- for use only in morphic duplication" 403962 text := t. 403963 textStyle := s. 403964 paragraph ifNotNil: [paragraph textStyle: s]! ! 403965 403966!TextMorph methodsFor: 'private' stamp: 'di 7/28/2001 10:34'! 403967text: t textStyle: s wrap: wrap color: c 403968 predecessor: pred successor: succ 403969 "Private -- for use only in morphic duplication" 403970 text := t. 403971 textStyle := s. 403972 wrapFlag := wrap. 403973 color := c. 403974 paragraph := editor := container := nil. 403975 self predecessor: pred successor: succ! ! 403976 403977!TextMorph methodsFor: 'private' stamp: 'Tsutomu Hiroshima 11/17/2003 08:50'! 403978updateFromParagraph 403979 "A change has taken place in my paragraph, as a result of editing and I must be updated. If a line break causes recomposition of the current paragraph, or it the selection has entered a different paragraph, then the current editor will be released, and must be reinstalled with the resulting new paragraph, while retaining any editor state, such as selection, undo state, and current typing emphasis." 403980 403981 | newStyle sel oldLast oldEditor back | 403982 paragraph ifNil: [^self]. 403983 wrapFlag ifNil: [wrapFlag := true]. 403984 editor ifNotNil: 403985 [oldEditor := editor. 403986 sel := editor selectionInterval. 403987 editor storeSelectionInParagraph]. 403988 text := paragraph text. 403989 paragraph textStyle = textStyle 403990 ifTrue: [self fit] 403991 ifFalse: 403992 ["Broadcast style changes to all morphs" 403993 403994 newStyle := paragraph textStyle. 403995 (self firstInChain text: text textStyle: newStyle) recomposeChain. 403996 editor ifNotNil: [self installEditorToReplace: editor]]. 403997 super layoutChanged. 403998 sel ifNil: [^self]. 403999 404000 "If selection is in top line, then recompose predecessor for possible ripple-back" 404001 predecessor ifNotNil: 404002 [sel first <= (self paragraph lines first last + 1) 404003 ifTrue: 404004 [oldLast := predecessor lastCharacterIndex. 404005 predecessor paragraph 404006 recomposeFrom: oldLast 404007 to: text size 404008 delta: 0. 404009 oldLast = predecessor lastCharacterIndex 404010 ifFalse: 404011 [predecessor changed. "really only last line" 404012 self predecessorChanged]]]. 404013 ((back := predecessor notNil 404014 and: [sel first <= self paragraph firstCharacterIndex]) or: 404015 [successor notNil 404016 and: [sel first > (self paragraph lastCharacterIndex + 1)]]) 404017 ifTrue: 404018 ["The selection is no longer inside this paragraph. 404019 Pass focus to the paragraph that should be in control." 404020 404021 back ifTrue: [predecessor recomposeChain] ifFalse: [self recomposeChain]. 404022 self firstInChain withSuccessorsDo: 404023 [:m | 404024 (sel first between: m firstCharacterIndex and: m lastCharacterIndex + 1) 404025 ifTrue: 404026 [m installEditorToReplace: oldEditor. 404027 ^self passKeyboardFocusTo: m]]. 404028 self error: 'Inconsistency in text editor' "Must be somewhere in the successor chain"]. 404029 editor ifNil: 404030 ["Reinstate selection after, eg, style change" 404031 404032 self installEditorToReplace: oldEditor]. 404033 "self setCompositionWindow." 404034! ! 404035 404036"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 404037 404038TextMorph class 404039 instanceVariableNames: ''! 404040 404041!TextMorph class methodsFor: '*etoys-parts bin' stamp: 'sw 6/13/2001 22:46'! 404042exampleBackgroundField 404043 "Answer a background field for a parts bin" 404044 404045 | aMorph | 404046 aMorph := TextMorph authoringPrototype. 404047 aMorph contents: 'background field' asText allBold. 404048 aMorph setProperty: #shared toValue: true. 404049 aMorph setNameTo: 'field1'. 404050 aMorph setProperty: #holdsSeparateDataForEachInstance toValue: true. 404051 ^ aMorph 404052! ! 404053 404054 404055!TextMorph class methodsFor: 'connectorstext-parts bin' stamp: 'yo 1/20/2005 12:44'! 404056boldAuthoringPrototype 404057 "TextMorph boldAuthoringPrototype openInHand" 404058 | text | 404059 text := Text string: 'Text' translated attributes: { TextEmphasis bold. }. 404060 ^self new 404061 contentsWrapped: text; 404062 fontName: 'BitstreamVeraSans' pointSize: 24; 404063 paragraph; 404064 extent: 79@36; 404065 margins: 4@0; 404066 fit; 404067 yourself 404068! ! 404069 404070 404071!TextMorph class methodsFor: 'initialization' stamp: 'nk 11/9/2003 09:58'! 404072initialize "TextMorph initialize" 404073 404074 "Initialize constants shared by classes associated with text display." 404075 404076 CaretForm := (ColorForm extent: 16@5 404077 fromArray: #(2r001100e26 2r001100e26 2r011110e26 2r111111e26 2r110011e26) 404078 offset: -2@0) 404079 colors: (Array with: Color transparent with: Preferences textHighlightColor). 404080 404081 self registerInFlapsRegistry. 404082! ! 404083 404084!TextMorph class methodsFor: 'initialization' stamp: 'asm 4/11/2003 12:04'! 404085registerInFlapsRegistry 404086 "Register the receiver in the system's flaps registry" 404087 self environment 404088 at: #Flaps 404089 ifPresent: [:cl | cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.') 404090 forFlapNamed: 'PlugIn Supplies'. 404091 cl registerQuad: #(TextMorph exampleBackgroundLabel 'Background Label' 'A piece of text that will occur on every card of the background') 404092 forFlapNamed: 'Scripting'. 404093 cl registerQuad: #(TextMorph exampleBackgroundField 'Background Field' 'A data field which will have a different value on every card of the background') 404094 forFlapNamed: 'Scripting'. 404095 cl registerQuad: #(TextMorph authoringPrototype 'Simple Text' 'Text that you can edit into anything you wish') 404096 forFlapNamed: 'Stack Tools'. 404097 cl registerQuad: #(TextMorph fancyPrototype 'Fancy Text' 'A text field with a rounded shadowed border, with a fancy font.') 404098 forFlapNamed: 'Stack Tools'. 404099 cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.') 404100 forFlapNamed: 'Supplies'.]! ! 404101 404102!TextMorph class methodsFor: 'initialization' stamp: 'asm 4/11/2003 12:41'! 404103unload 404104 "Unload the receiver from global registries" 404105 404106 self environment at: #Flaps ifPresent: [:cl | 404107 cl unregisterQuadsWithReceiver: self] ! ! 404108 404109 404110!TextMorph class methodsFor: 'parts bin' stamp: 'nk 9/2/2004 16:03'! 404111borderedPrototype 404112 404113 | t | 404114 t := self authoringPrototype. 404115 t fontName: 'BitstreamVeraSans' pointSize: 24. 404116 t autoFit: false; extent: 250@100. 404117 t borderWidth: 1; margins: 4@0. 404118 404119"Strangeness here in order to avoid two offset copies of the default contents when operating in an mvc project before cursor enters the morphic window" 404120 t paragraph. 404121 ^ t! ! 404122 404123!TextMorph class methodsFor: 'parts bin' stamp: 'sw 6/13/2001 21:58'! 404124exampleBackgroundLabel 404125 "Answer a background label for a parts bin" 404126 404127 | aTextMorph | 404128 aTextMorph := self authoringPrototype. 404129 aTextMorph contents: 'background 404130label' asText. 404131 aTextMorph beAllFont: (StrikeFont familyName: #NewYork size: 18). 404132 aTextMorph color: Color brown. 404133 aTextMorph setProperty: #shared toValue: true. 404134 ^ aTextMorph 404135! ! 404136 404137!TextMorph class methodsFor: 'parts bin' stamp: 'nk 7/12/2003 08:59'! 404138fancyPrototype 404139 404140 | t | 404141 t := self authoringPrototype. 404142 t autoFit: false; extent: 150@75. 404143 t borderWidth: 2; margins: 4@0; useRoundedCorners. "Why not rounded?" 404144 "fancy font, shadow, rounded" 404145 t fontName: Preferences standardEToysFont familyName size: 18; textColor: Color blue; backgroundColor: Color lightBrown. 404146 t addDropShadow. 404147 404148"Strangeness here in order to avoid two offset copies of the default contents when operating in an mvc project before cursor enters the morphic window" 404149 t paragraph. 404150 ^ t! ! 404151 404152 404153!TextMorph class methodsFor: 'scripting' stamp: 'yo 7/2/2004 21:27'! 404154authoringPrototype 404155 | t | 404156 t := super authoringPrototype. 404157 t contents: 'abc' translated asText. 404158 t wrapFlag: true. 404159 404160"Strangeness here in order to avoid two offset copies of the default contents when operating in an mvc project before cursor enters the morphic window" 404161 t paragraph. 404162 ^ t! ! 404163 404164!TextMorph class methodsFor: 'scripting' stamp: 'dgd 8/26/2004 12:12'! 404165defaultNameStemForInstances 404166 ^ 'Text'! ! 404167CommandHistory subclass: #TextMorphCommandHistory 404168 instanceVariableNames: '' 404169 classVariableNames: '' 404170 poolDictionaries: '' 404171 category: 'Morphic-Text Support'! 404172 404173!TextMorphCommandHistory methodsFor: 'command exec' stamp: 'sps 7/23/2003 18:57'! 404174redo 404175 ^super redoNextCommand 404176! ! 404177 404178!TextMorphCommandHistory methodsFor: 'command exec' stamp: 'sps 7/23/2003 18:58'! 404179rememberCommand: aCommand 404180 "Make the supplied command be the 'LastCommand', and mark it 'done'" 404181 404182 "Before adding the new command, remove any commands after the last #done 404183 command, and make that last #done command be lastCommand." 404184 self removeUndoneCommands. 404185 aCommand phase: #done. 404186 404187 "If we are building a compound command, just add the new command to that" 404188 history addLast: aCommand. 404189 lastCommand := aCommand. 404190"Debug dShow: ('Remember: ', commandToUse asString)." 404191 404192! ! 404193 404194!TextMorphCommandHistory methodsFor: 'command exec' stamp: 'sps 7/24/2003 16:42'! 404195removeUndoneCommands 404196"Remove all of the commands at the end of history until the first one that is not marked #undone" 404197 404198 history reversed do: [ :command | 404199 (command phase == #done) ifTrue:[ 404200 lastCommand := command. 404201 ^self 404202 ]ifFalse:[ 404203 history remove: command. 404204 ]. 404205 ]. 404206 404207 "If there were no #done commands on the stack, then get rid of lastCommand" 404208 lastCommand := nil. 404209! ! 404210 404211!TextMorphCommandHistory methodsFor: 'command exec' stamp: 'sps 7/23/2003 18:57'! 404212undo 404213 ^super undoLastCommand 404214 404215! ! 404216ParagraphEditor subclass: #TextMorphEditor 404217 instanceVariableNames: 'morph oldInterval pivotBlock' 404218 classVariableNames: '' 404219 poolDictionaries: '' 404220 category: 'Morphic-Text Support'! 404221!TextMorphEditor commentStamp: 'alain.plantec 6/8/2009 23:47' prior: 0! 404222This is the ParagraphEditor for TextMorphs. 404223! 404224 404225 404226!TextMorphEditor methodsFor: '*FreeType-addition' stamp: 'tween 9/8/2007 12:11'! 404227alphabeticalGroupsFor: familyGroupList size: maxGroupSize 404228 | alphabetDict alphabetDict2 pendingGroup pendingGroupKeys group key | 404229 alphabetDict := Dictionary new. 404230 familyGroupList do:[:each | 404231 (alphabetDict at: each familyName first ifAbsentPut:[OrderedCollection new]) 404232 add: each]. 404233 alphabetDict2 := Dictionary new. 404234 pendingGroup := OrderedCollection new. 404235 pendingGroupKeys :=OrderedCollection new. 404236 alphabetDict keys asSortedCollection do:[:char | 404237 group := alphabetDict at: char. 404238 pendingGroup size + group size <= maxGroupSize 404239 ifTrue:[ 404240 pendingGroupKeys addLast: char. 404241 pendingGroup addAll: group] 404242 ifFalse:[ 404243 pendingGroup ifNotEmpty:[ 404244 key := pendingGroupKeys first asString asUppercase. 404245 pendingGroupKeys size > 1 404246 ifTrue:[key := key, ' - ', pendingGroupKeys last asString asUppercase]. 404247 alphabetDict2 at: key put: pendingGroup]. 404248 pendingGroup := OrderedCollection withAll: group. 404249 pendingGroupKeys := OrderedCollection with: char]]. 404250 pendingGroup ifNotEmpty:[ 404251 key := pendingGroupKeys first asString asUppercase. 404252 pendingGroupKeys size > 1 404253 ifTrue:[key := key, ' - ', pendingGroupKeys last asString asUppercase]. 404254 alphabetDict2 at: key put: pendingGroup]. 404255 "need to split single char groups at this point. e,g. 'A' may have > maxGroupSize members" 404256 ^alphabetDict2 404257 ! ! 404258 404259!TextMorphEditor methodsFor: '*FreeType-addition' stamp: 'pavel.krivanek 12/3/2008 21:48'! 404260changeSelectionFontTo: aFont 404261 404262 | attr startIndex stopIndex f code textIsBold textIsItalic copy fontIsBold fontIsItalic style squeakBoldEmphasis squeakItalicEmphasis | 404263 404264 aFont ifNil:[^self]. 404265 startIndex := self startIndex. 404266 stopIndex := self stopIndex-1 min: paragraph text size. 404267 f := aFont. 404268 squeakBoldEmphasis := 1. 404269 squeakItalicEmphasis := 2. 404270 (f isKindOf: LogicalFont) 404271 ifTrue:[ 404272 copy := f copy 404273 forceNotBold; 404274 forceNotItalic; 404275 clearRealFont; 404276 yourself. 404277 LogicalFont all remove: copy ifAbsent:[]. "remove the copy from all before getting another one" 404278 f := LogicalFont 404279 familyName: copy familyName 404280 pointSize: copy pointSize 404281 stretchValue: copy stretchValue 404282 weightValue: copy weightValue 404283 slantValue: copy slantValue. 404284 "add aFont's emphasis to the text as a separate action" 404285 code := paragraph text emphasisAt: startIndex. 404286 textIsBold := code anyMask: squeakBoldEmphasis. 404287 textIsItalic := code anyMask: squeakItalicEmphasis. 404288 (aFont isBoldOrBolder ~= textIsBold) 404289 ifTrue:[self setEmphasis: #bold "toggle bold"]. 404290 (aFont isItalicOrOblique ~= textIsItalic) 404291 ifTrue:[self setEmphasis: #italic "toggle italic"]. 404292 paragraph composeAll. 404293 self recomputeSelection. ] 404294 ifFalse:["must be from a TextStyle?" 404295 style := TextStyle named: aFont familyName. 404296 style ifNil:[ 404297 style := TextStyle actualTextStyles 404298 detect: [:aStyle | 404299 (aStyle fontArray includes: aFont) or:[ 404300 (aStyle fontArray select: [:e | e derivativeFonts includes: aFont]) notEmpty]] 404301 ifNone: []]. 404302 f := style fontOfPointSize: aFont pointSize. "unemphasized" 404303 "add aFont's emphasis to the text as a separate action" 404304 code := paragraph text emphasisAt: startIndex. 404305 textIsBold := code anyMask: squeakBoldEmphasis. 404306 textIsItalic := code anyMask: squeakItalicEmphasis. 404307 fontIsBold := aFont emphasis anyMask: squeakBoldEmphasis. 404308 fontIsItalic := aFont emphasis anyMask: squeakItalicEmphasis. 404309 (fontIsBold ~= textIsBold) 404310 ifTrue:[self setEmphasis: #bold "toggle bold"]. 404311 (fontIsItalic ~= textIsItalic) 404312 ifTrue:[self setEmphasis: #italic "toggle italic"]. 404313 paragraph composeAll. 404314 self recomputeSelection. ]. 404315 attr := TextFontReference toFont: f. 404316 stopIndex >= startIndex 404317 ifTrue: [ paragraph text addAttribute: attr from: startIndex to: stopIndex ] 404318 ifFalse: [ paragraph text addAttribute: attr from: 1 to: paragraph text size. ]. 404319 paragraph composeAll. 404320 self recomputeInterval. 404321 "next bit makes it reflow and redraw correctly" 404322 morph updateFromParagraph. 404323 morph handleEdit:[] 404324! ! 404325 404326!TextMorphEditor methodsFor: '*FreeType-addition' stamp: 'tween 9/8/2007 15:12'! 404327changeTextFontAlphabeticalMenu 404328 | dict startIndex stopIndex currrentFont currentFamilyMember fontMenu fams members styleName label tag ptMenu spec newFont attr applyStart applyStop allFontFamilies removeSet unBold unSlanted unSlantedUnBold alphaMenu itemFont alphaIncludesCurrent alphaLabel | 404329 404330 startIndex := self startIndex. 404331 stopIndex := self stopIndex-1 min: paragraph text size. 404332 allFontFamilies := LogicalFontManager current allFamilies. 404333 currrentFont := paragraph text fontAt: startIndex withStyle: paragraph textStyle. 404334 currentFamilyMember := self familyMemberFor: currrentFont fromFamilies: allFontFamilies. 404335 fontMenu := MenuMorph new defaultTarget: self. 404336 dict := self alphabeticalGroupsFor: allFontFamilies size: 15. 404337 dict keys asSortedCollection do:[:k | 404338 alphaMenu := MenuMorph new defaultTarget: self. 404339 fams := dict at: k. 404340 alphaIncludesCurrent := false. 404341 fams do:[:family | 404342 members := family members reject:[:mem | mem simulated]. 404343 "reject any members that are simply bold, italic, or boldItalic versions of other members" 404344 removeSet := Set new. 404345 members do:[:mem | 404346 (mem weightValue = 700 and:[mem slantValue ~= 0]) 404347 ifTrue:[ 404348 unSlantedUnBold := family 404349 closestMemberWithStretchValue: mem stretchValue 404350 weightValue: 400 404351 slantValue: 0. 404352 unSlantedUnBold = mem ifFalse:[removeSet add: mem]] 404353 ifFalse:[ 404354 mem weightValue = 700 404355 ifTrue:[ 404356 unBold := family 404357 closestMemberWithStretchValue: mem stretchValue 404358 weightValue: 400 404359 slantValue: mem slantValue. 404360 unBold = mem ifFalse:[removeSet add: mem]]. 404361 mem slantValue ~= 0 404362 ifTrue:[ 404363 unSlanted := family 404364 closestMemberWithStretchValue: mem stretchValue 404365 weightValue: mem weightValue 404366 slantValue: 0. 404367 unSlanted = mem ifFalse:[removeSet add: mem]]]]. 404368 members := members copyWithoutAll: removeSet. 404369 members := members asSortedCollection asArray. 404370 members do:[:member | 404371 styleName := member styleName. 404372 (#('book' 'normal' 'regular' 'roman' 'upright') includes: styleName asLowercase) 404373 ifTrue:[styleName := '']. 404374 (styleName notEmpty and:[member simulated]) 404375 ifTrue:[styleName := '(', styleName, ')']. 404376 label := family familyName, ' ',styleName. 404377 self fontMenuItemsDisplayWithMenuFont ifFalse:[ 404378 itemFont := member asLogicalFontOfPointSize: Preferences standardMenuFont pointSize. 404379 (itemFont isSymbolFont or:[(itemFont hasDistinctGlyphsForAll: label) not]) 404380 ifTrue:[itemFont := nil]]. 404381 alphaIncludesCurrent := alphaIncludesCurrent or:[member = currentFamilyMember]. 404382 tag := member = currentFamilyMember ifTrue:['<on>'] ifFalse:['<off>']. 404383 label := tag , label. 404384 ptMenu := self 404385 pointSizeMenuForFamilyMember: member 404386 parentMenu:fontMenu 404387 active: member = currentFamilyMember 404388 activePointSize: currrentFont pointSize. 404389 alphaMenu add: label subMenu: ptMenu. 404390 itemFont ifNotNil:[alphaMenu lastItem font: itemFont] ]]. 404391 alphaLabel := alphaIncludesCurrent ifTrue:['<on>'] ifFalse:['<off>']. 404392 alphaLabel := alphaLabel, k. 404393 fontMenu add: alphaLabel subMenu: alphaMenu. 404394 "alphaIncludesCurrent ifTrue:[fontMenu lastItem color: Color red ]"]. 404395 spec := fontMenu invokeModalAt: ActiveHand position in: ActiveWorld allowKeyboard: true. 404396 spec ifNil:[^nil]. 404397 newFont := LogicalFont 404398 familyName: spec first family familyName 404399 pointSize: spec last 404400 stretchValue: spec first stretchValue 404401 weightValue: spec first weightValue 404402 slantValue: spec first slantValue. 404403 newFont ifNil:[^self]. 404404 attr := TextFontReference toFont: newFont. 404405 applyStart := stopIndex >= startIndex ifTrue:[startIndex] ifFalse:[1]. 404406 applyStop := stopIndex >= startIndex ifTrue:[stopIndex] ifFalse:[paragraph text size]. 404407 paragraph text addAttribute: attr from: applyStart to: applyStop. 404408 paragraph composeAll. 404409 self recomputeInterval ! ! 404410 404411!TextMorphEditor methodsFor: '*FreeType-addition' stamp: 'tween 3/2/2008 10:41'! 404412changeTextFontDialog 404413 "Present a dialog which allows the user to select a font, and if one is chosen, apply it to the current selection. If there is no selection, or the selection is empty, apply it to the whole morph." 404414 404415 "?? Should the dialog allow the user to select a bold/italic/black font. 404416 Or just the most regular member of a Font Family?" 404417 | curFont startIndex chooser newFont | 404418 startIndex := self startIndex. 404419 "stopIndex := self stopIndex-1 min: paragraph text size." 404420 curFont := (paragraph text fontAt: startIndex withStyle: paragraph textStyle). 404421 (curFont isKindOf: LogicalFont) 404422 ifTrue:[ 404423 curFont := curFont copy. 404424 ((paragraph text emphasisAt: startIndex) anyMask: 1) ifTrue:[curFont forceBold]. 404425 ((paragraph text emphasisAt: startIndex) anyMask: 2) ifTrue:[curFont forceItalicOrOblique]. 404426 curFont clearRealFont]. 404427 chooser := morph openModal: ( 404428 Cursor wait showWhile: [ 404429 FontChooser 404430 windowTitle: 'Change the selected text''s font to...' translated 404431 for: self 404432 setSelector: #changeSelectionFontTo: 404433 getSelector: curFont]). 404434 newFont := chooser result. 404435 newFont ifNotNil:[self changeSelectionFontTo: newFont].! ! 404436 404437!TextMorphEditor methodsFor: '*FreeType-addition' stamp: 'tween 9/8/2007 12:06'! 404438familyMemberFor: aFont fromFamilies: aCollection 404439 | family weightValue slantValue stretchValue | 404440 family := aCollection detect:[:each | each familyName = aFont familyName] ifNone:[]. 404441 family ifNil:[^nil]. 404442 (aFont isKindOf: LogicalFont) 404443 ifTrue:[ 404444 weightValue := aFont weightValue. 404445 slantValue := aFont slantValue. 404446 stretchValue := aFont stretchValue] 404447 ifFalse:[ 404448 weightValue := (aFont emphasis bitAnd: 1) > 0 ifTrue:[700] ifFalse:[400]. 404449 slantValue := (aFont emphasis bitAnd: 2) > 0 ifTrue:[1] ifFalse:[0]. 404450 stretchValue := 5 "normal"]. 404451 ^family closestMemberWithStretchValue: stretchValue weightValue: weightValue slantValue: slantValue 404452 ! ! 404453 404454!TextMorphEditor methodsFor: '*FreeType-addition' stamp: 'tween 9/8/2007 14:05'! 404455fontMenuItemsDisplayWithMenuFont 404456 "Answer true if menu items should display using the standard menu font, 404457 false to display them in the font that they represent" 404458 ^true! ! 404459 404460!TextMorphEditor methodsFor: '*FreeType-addition' stamp: 'DamienCassou 9/29/2009 13:13'! 404461otherFontSizeDialog: args 404462 "This is called from a modal menu and call back the menu with entered argument." 404463 | f n | 404464 f := UIManager default request: 'Enter the point size' initialAnswer: '12'. 404465 f ifNil: [f := String new]. 404466 n := f asNumber. 404467 args second ifNotNil: [args second modalSelection: {args first. n}]! ! 404468 404469!TextMorphEditor methodsFor: '*FreeType-addition' stamp: 'tween 8/26/2007 16:37'! 404470pointSizeMenuForFamilyMember: aFontFamilyMember parentMenu: aMenuMorph active: aBoolean activePointSize: aNumberOrNil 404471 404472 | ptMenu style pointSizes activePt ptLabel onLabel offLabel selector target | 404473 ptMenu := MenuMorph new defaultTarget: self. 404474 style := TextStyle named: aFontFamilyMember family familyName. 404475 pointSizes := style 404476 ifNil:[ 404477 pointSizes := #(6 8 10 11 12 15 18 20 22 24 26 28 30 36 42 52 72). 404478 aNumberOrNil ifNotNil:[ 404479 pointSizes := (pointSizes copyWith: aNumberOrNil reduce) asSet asSortedCollection] ] 404480 ifNotNil:[ 404481 pointSizes := style pointSizes]. 404482 pointSizes do:[:ptSize | 404483 activePt := aBoolean and:[ptSize = aNumberOrNil]. 404484 aNumberOrNil isNil 404485 ifTrue:[onLabel := ''. offLabel := ''] 404486 ifFalse:[onLabel := '<on>'. offLabel := '<off>']. 404487 ptLabel := activePt 404488 ifTrue:[onLabel, ptSize printString, ' pt'] 404489 ifFalse:[offLabel, ptSize printString, ' pt']. 404490 ptMenu 404491 add: ptLabel 404492 target: aMenuMorph 404493 selector: #modalSelection: 404494 argument: {aFontFamilyMember. ptSize}]. 404495 (style isNil or:[style isTTCStyle ]) ifTrue:[ 404496 selector := style 404497 ifNil:[#otherFontSizeDialog:] 404498 ifNotNil:[#addNewFontSizeDialog: ]. 404499 target := style ifNil:[self]. 404500 ptMenu 404501 addLine; 404502 add: 'Other size...' translated 404503 target: target 404504 selector: selector 404505 argument: {aFontFamilyMember. aMenuMorph}]. 404506 ^ptMenu! ! 404507 404508 404509!TextMorphEditor methodsFor: '*FreeType-override' stamp: 'tween 3/2/2008 09:17'! 404510changeTextFont 404511 "Present a menu of available fonts, and if one is chosen, apply it to the current selection. 404512 If there is no selection, or the selection is empty, apply it to the whole morph." 404513 | useDialog | 404514 useDialog := true. "make this false to use a menu" 404515 ^useDialog 404516 ifTrue:[self changeTextFontDialog] 404517 ifFalse:[self changeTextFontAlphabeticalMenu]! ! 404518 404519 404520!TextMorphEditor methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/5/2009 12:18'! 404521handleDisabledKey: anEvent 404522 "Handle a key character when the text morph is disabled." 404523 404524 super handleDisabledKey: anEvent. 404525 self storeSelectionInParagraph! ! 404526 404527 404528!TextMorphEditor methodsFor: 'accessing' stamp: 'tk 1/13/1999 07:53'! 404529morph 404530 ^ morph! ! 404531 404532!TextMorphEditor methodsFor: 'accessing' stamp: 'tk 1/13/1999 07:53'! 404533morph: aMorph 404534 "Install a link back to the morph being edited (esp for text links)" 404535 morph := aMorph ! ! 404536 404537!TextMorphEditor methodsFor: 'accessing' stamp: 'stephane.ducasse 4/14/2009 11:26'! 404538setSearch: aString 404539 "Set the FindText and ChangeText to seek aString; except if already seeking aString, leave ChangeText alone so again will repeat last replacement." 404540 404541 FindText string = aString 404542 ifFalse: [FindText := ChangeText := aString asText]! ! 404543 404544!TextMorphEditor methodsFor: 'accessing' stamp: 'ar 9/22/2001 16:16'! 404545transformFrom: owner 404546 ^morph transformFrom: owner! ! 404547 404548!TextMorphEditor methodsFor: 'accessing' stamp: 'di 4/21/1998 14:11'! 404549userHasEdited 404550 "Note that my text is free of user edits." 404551 404552 morph hasUnacceptedEdits: true! ! 404553 404554 404555!TextMorphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:41'! 404556totalTextHeight 404557 404558 ^paragraph lines last bottom! ! 404559 404560!TextMorphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:43'! 404561visibleHeight 404562 404563 ^morph owner bounds height! ! 404564 404565 404566!TextMorphEditor methodsFor: 'attributes' stamp: 'PeterHugossonMiller 9/3/2009 11:44'! 404567changeEmphasisOrAlignment 404568 | aList reply code align menuList startIndex alignSymbol | 404569 self flag: #arNote. "Move this up once we get rid of MVC" 404570 404571 startIndex := self startIndex. 404572 aList := #(#normal #bold #italic #narrow #underlined #struckOut #leftFlush #centered #rightFlush #justified ). 404573 align := paragraph text 404574 alignmentAt: startIndex 404575 ifAbsent: [paragraph textStyle alignment]. 404576 alignSymbol := TextAlignment alignmentSymbol: align. 404577 code := paragraph text emphasisAt: startIndex. 404578 menuList := Array new writeStream. 404579 menuList nextPut: (code isZero 404580 ifTrue: ['<on>'] 404581 ifFalse: ['<off>']) 404582 , 'normal' translated. 404583 menuList 404584 nextPutAll: (#(#bold #italic #underlined #struckOut ) 404585 collect: [:emph | (code anyMask: (TextEmphasis perform: emph) emphasisCode) 404586 ifTrue: ['<on>' , emph asString translated] 404587 ifFalse: ['<off>' , emph asString translated]]). 404588 ((paragraph text attributesAt: startIndex forStyle: paragraph textStyle) 404589 anySatisfy: [:attr | attr isKern 404590 and: [attr kern < 0]]) 404591 ifTrue: [menuList nextPut: '<on>' , 'narrow' translated] 404592 ifFalse: [menuList nextPut: '<off>' , 'narrow' translated]. 404593 menuList 404594 nextPutAll: (#(#leftFlush #centered #rightFlush #justified ) 404595 collect: [:type | type == alignSymbol 404596 ifTrue: ['<on>' , type asString translated] 404597 ifFalse: ['<off>' , type asString translated]]). 404598 aList := #(#normal #bold #italic #underlined #struckOut #narrow #leftFlush #centered #rightFlush #justified ). 404599 reply := UIManager default chooseFrom: menuList contents values: aList lines: #(1 6 ). 404600 reply ifNotNil: [ 404601 (#(#leftFlush #centered #rightFlush #justified ) includes: reply) 404602 ifTrue: [self setAlignment: reply. 404603 paragraph composeAll. 404604 self recomputeInterval] 404605 ifFalse: [self setEmphasis: reply. 404606 paragraph composeAll. 404607 self recomputeSelection]]. 404608 ^ true! ! 404609 404610!TextMorphEditor methodsFor: 'attributes' stamp: 'alain.plantec 2/6/2009 17:34'! 404611changeStyle 404612 "Let user change styles for the current text pane." 404613 | aList reply style theStyle menuList | 404614 self flag: #arNote. "Move this up once we get rid of MVC" 404615 aList := StrikeFont actualFamilyNames. 404616 theStyle := paragraph textStyle. 404617 menuList := aList collect:[:styleName| 404618 "Hack!! use defaultFont for comparison - we have no name that we could use for compare and the style changes with alignment so they're no longer equal." 404619 (TextConstants at: styleName) defaultFont == theStyle defaultFont 404620 ifTrue:['<on>', styleName] 404621 ifFalse:['<off>',styleName]]. 404622 theStyle = TextStyle default 404623 ifTrue:[menuList addFirst: '<on>DefaultTextStyle'] 404624 ifFalse:[menuList addFirst: '<off>DefaultTextStyle']. 404625 aList addFirst: 'DefaultTextStyle'. 404626 reply := UIManager default chooseFrom: menuList values: aList lines: #(1). 404627 reply ifNotNil: 404628 [(style := TextStyle named: reply) ifNil: [Beeper beep. ^ true]. 404629 paragraph textStyle: style copy. 404630 paragraph composeAll. 404631 self recomputeSelection. 404632 ]. 404633 ^ true! ! 404634 404635!TextMorphEditor methodsFor: 'attributes' stamp: 'alain.plantec 2/6/2009 17:36'! 404636offerFontMenu 404637 "Present a menu of available fonts, and if one is 404638 chosen, apply it to the current selection. 404639 Use only names of Fonts of this paragraph " 404640 | aList reply curFont menuList | 404641 true 404642 ifTrue: [^ self changeTextFont]. 404643 self flag: #arNote. "Move this up once we get rid of MVC" 404644 curFont := (paragraph text fontAt: self startIndex withStyle: paragraph textStyle) fontNameWithPointSize. 404645 aList := paragraph textStyle fontNamesWithPointSizes. 404646 menuList := aList 404647 collect: [:fntName | fntName = curFont 404648 ifTrue: ['<on>' , fntName] 404649 ifFalse: ['<off>' , fntName]]. 404650 reply := UIManager default chooseFrom: menuList values: aList. 404651 reply ifNotNil:[ 404652 self replaceSelectionWith: (Text 404653 string: self selection asString 404654 attribute: (TextFontChange fontNumber: (aList indexOf: reply)))]! ! 404655 404656!TextMorphEditor methodsFor: 'attributes' stamp: 'nk 7/3/2003 18:33'! 404657textAlignment 404658 "Answer 1..4, representing #leftFlush, #rightFlush, #centered, or #justified" 404659 ^paragraph text alignmentAt: startBlock stringIndex 404660 ifAbsent: [paragraph textStyle alignment]! ! 404661 404662!TextMorphEditor methodsFor: 'attributes' stamp: 'nk 7/3/2003 18:33'! 404663textAlignmentSymbol 404664 ^#(leftFlush rightFlush centered justified) at: self textAlignment 404665 ! ! 404666 404667 404668!TextMorphEditor methodsFor: 'binding' stamp: 'ls 7/24/1998 21:06'! 404669bindingOf: aString 404670 ^model bindingOf: aString! ! 404671 404672 404673!TextMorphEditor methodsFor: 'controlling' stamp: 'di 4/16/1998 11:33'! 404674controlInitialize 404675 "No-op for MVC ParagraphEditor compatibility"! ! 404676 404677!TextMorphEditor methodsFor: 'controlling' stamp: 'di 4/16/1998 11:33'! 404678controlTerminate 404679 "No-op for MVC ParagraphEditor compatibility"! ! 404680 404681 404682!TextMorphEditor methodsFor: 'current selection'! 404683select 404684 "Ignore selection redraw requests."! ! 404685 404686!TextMorphEditor methodsFor: 'current selection' stamp: 'jm 10/28/97 18:31'! 404687selectAndScroll 404688 "Ignore scroll requests."! ! 404689 404690 404691!TextMorphEditor methodsFor: 'displaying' stamp: 'di 4/22/1998 10:21'! 404692flash 404693 ^ morph flash! ! 404694 404695 404696!TextMorphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 18:13'! 404697changeEmphasis: aStream keyEvent: keyEvent 404698 "Change the emphasis of the current selection." 404699 | retval | 404700 retval := super changeEmphasis: aStream keyEvent: keyEvent. 404701 paragraph composeAll. 404702 self recomputeInterval. 404703 morph updateFromParagraph. 404704 ^retval! ! 404705 404706!TextMorphEditor methodsFor: 'editing keys' stamp: 'tk 5/7/2001 09:10'! 404707chooseColor 404708 | attribute | 404709 "Make a new Text Color Attribute, let the user pick a color, and return the attribute" 404710 404711 ColorPickerMorph new 404712 choseModalityFromPreference; 404713 sourceHand: morph activeHand; 404714 target: (attribute := TextColor color: Color black "default"); 404715 selector: #color:; 404716 originalColor: Color black; 404717 putUpFor: morph near: morph fullBoundsInWorld. 404718 ^ attribute 404719! ! 404720 404721!TextMorphEditor methodsFor: 'editing keys' stamp: 'michael.rueger 2/23/2009 13:32'! 404722inspectIt: characterStream 404723 "Inspect the selection -- invoked via cmd-i. If there is no current selection, use the current line." 404724 404725 self inspectIt. 404726 ^ true! ! 404727 404728!TextMorphEditor methodsFor: 'editing keys' stamp: 'sw 10/18/1998 10:17'! 404729tempCommand: characterStream 404730 "Experimental. Triggered by Cmd-t; put trial cmd-key commands here to see how they work, before hanging them on their own cmd accelerators." 404731 Sensor keyboard. 404732 morph tempCommand. 404733 ^ true! ! 404734 404735 404736!TextMorphEditor methodsFor: 'events' stamp: 'th 9/18/2002 11:15'! 404737mouseDown: evt 404738 "An attempt to break up the old processRedButton code into threee phases" 404739 | clickPoint | 404740 404741 oldInterval := self selectionInterval. 404742 clickPoint := evt cursorPoint. 404743 (paragraph clickAt: clickPoint for: model controller: self) ifTrue: [ 404744 pivotBlock := paragraph characterBlockAtPoint: clickPoint. 404745 self markBlock: pivotBlock. 404746 self pointBlock: pivotBlock. 404747 evt hand releaseKeyboardFocus: self. 404748 ^ self]. 404749 evt shiftPressed 404750 ifFalse: 404751 [self closeTypeIn. 404752 pivotBlock := paragraph characterBlockAtPoint: clickPoint. 404753 self markBlock: pivotBlock. 404754 self pointBlock: pivotBlock.] 404755 ifTrue: 404756 [self closeTypeIn. 404757 self mouseMove: evt]. 404758 self storeSelectionInParagraph! ! 404759 404760!TextMorphEditor methodsFor: 'events' stamp: 'th 9/17/2002 16:45'! 404761mouseMove: evt 404762 "Change the selection in response to moue-down drag" 404763 404764 pivotBlock ifNil: [^ self]. "Patched during clickAt: repair" 404765 self pointBlock: (paragraph characterBlockAtPoint: (evt cursorPoint)). 404766 self storeSelectionInParagraph! ! 404767 404768!TextMorphEditor methodsFor: 'events' stamp: 'th 9/19/2002 18:29'! 404769mouseUp: evt 404770 "An attempt to break up the old processRedButton code into threee phases" 404771 oldInterval ifNil: [^ self]. "Patched during clickAt: repair" 404772 (self hasCaret 404773 and: [oldInterval = self selectionInterval]) 404774 ifTrue: [self selectWord]. 404775 self setEmphasisHere. 404776 (self isDisjointFrom: oldInterval) ifTrue: 404777 [otherInterval := oldInterval]. 404778 self storeSelectionInParagraph! ! 404779 404780 404781!TextMorphEditor methodsFor: 'menu commands' stamp: 'sw 12/9/2001 18:55'! 404782offerMenuFromEsc: characterStream 404783 "The escape key was hit while the receiver has the keyboard focus; take action" 404784 404785 ^ ActiveEvent shiftPressed 404786 ifTrue: 404787 [self escapeToDesktop: characterStream] 404788 ifFalse: 404789 [self raiseContextMenu: characterStream]! ! 404790 404791 404792!TextMorphEditor methodsFor: 'menu messages' stamp: 'di 4/21/1998 20:30'! 404793accept 404794 "Save the current text of the text being edited as the current acceptable version for purposes of canceling. Allow my morph to take appropriate action" 404795 morph acceptContents! ! 404796 404797!TextMorphEditor methodsFor: 'menu messages' stamp: 'ar 12/17/2001 12:55'! 404798align 404799 "Align text according to the next greater alignment value, 404800 cycling among leftFlush, rightFlush, center, and justified." 404801 self changeAlignment. 404802 self recomputeInterval! ! 404803 404804!TextMorphEditor methodsFor: 'menu messages' stamp: 'di 10/9/1998 16:55'! 404805cancel 404806 "Cancel the changes made so far to this text" 404807 morph cancelEdits! ! 404808 404809!TextMorphEditor methodsFor: 'menu messages' stamp: 'di 10/5/1998 21:48'! 404810find 404811 super find. 404812 morph installEditorToReplace: self! ! 404813 404814!TextMorphEditor methodsFor: 'menu messages' stamp: 'sps 2/5/2004 13:16'! 404815zapSelectionWith: aText 404816 "**overridden to inhibit old-style display" 404817 | start stop rText rInterval isInTypeRun | 404818 self deselect. 404819 start := self startIndex. 404820 stop := self stopIndex. 404821 (aText isEmpty and: [stop > start]) ifTrue: 404822 ["If deleting, then set emphasisHere from 1st character of the deletion" 404823 emphasisHere := (paragraph text attributesAt: start forStyle: paragraph textStyle) 404824 select: [:att | att mayBeExtended]]. 404825 (start = stop and: [aText size = 0]) ifFalse: 404826 [ 404827 "===Support for multilevel undo start ===" 404828 rText := (paragraph text copyFrom: start to: (stop - 1)). 404829 rInterval := start to: (stop - 1). 404830 isInTypeRun := self isInTypeRun. 404831 "===Support for multilevel undo end ===" 404832 404833 paragraph replaceFrom: start to: stop - 1 404834 with: aText displaying: false. "** was true in super" 404835 self computeIntervalFrom: start to: start + aText size - 1. 404836 UndoInterval := otherInterval := self selectionInterval. 404837 404838 "===Support for multilevel undo start ===" 404839 (Preferences multipleTextUndo and: [isInTypeRun not])ifTrue: 404840 [ self addEditCommand: 404841 (EditCommand 404842 textMorph: morph 404843 replacedText: rText 404844 replacedTextInterval: rInterval 404845 newText: aText 404846 newTextInterval: super selectionInterval)]. 404847 "===Support for multilevel undo end ==="]. 404848 404849 self userHasEdited " -- note text now dirty"! ! 404850 404851 404852!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 18:56'! 404853addEditCommand: anEditCommand 404854 404855 self editHistory rememberCommand: anEditCommand. 404856" 404857 Debug dShow: anEditCommand newText. 404858 Debug dShow: anEditCommand replacedText. 404859" 404860 404861 404862! ! 404863 404864!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 2/5/2004 13:26'! 404865closeTypeIn 404866 404867 | begin stop rInterval nInterval newText | 404868 404869 (UndoMessage sends: #noUndoer) ifFalse:[^super closeTypeIn]. 404870 Preferences multipleTextUndo ifTrue: 404871 [ 404872 beginTypeInBlock == nil ifFalse: 404873 [ 404874 begin := self startOfTyping. 404875 stop := self stopIndex. 404876 rInterval := (begin "+ UndoMessage argument" 404877 to: begin + UndoSelection size - 1). 404878 nInterval := begin to: stop - 1. 404879 (nInterval = rInterval) ifTrue:[ ^super closeTypeIn ]. 404880 newText := nInterval size > 0 404881 ifTrue: [ paragraph text 404882 copyFrom: nInterval first 404883 to: nInterval last ] 404884 ifFalse: [ self nullText ]. 404885 self addEditCommand: 404886 (EditCommand 404887 textMorph: morph 404888 replacedText: UndoSelection copy 404889 replacedTextInterval: rInterval 404890 newText: newText 404891 newTextInterval: nInterval) 404892 ]. 404893 ]. 404894 404895 "Call the super regardless, just to keep the standard undo machine happy" 404896 ^super closeTypeIn 404897! ! 404898 404899!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 16:49'! 404900editHistory 404901 ^morph editHistory 404902! ! 404903 404904!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 12:37'! 404905isInTypeRun 404906 ^beginTypeInBlock ~~ nil 404907! ! 404908 404909!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 17:24'! 404910multiRedo 404911 ^self multiRedoWithCount: 1 404912! ! 404913 404914!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 18:52'! 404915multiRedoWithCount: count 404916 404917 | command i lastCommand newSelection saveSelection history | 404918 404919 count > 0 ifFalse:[ ^self ]. 404920 404921 history := self editHistory. 404922 (command := history nextCommand) isNil 404923 ifTrue:[ ^self multiUndoError: 'Nothing to redo']. 404924 404925 saveSelection := self selectionInterval. 404926 self deselect. 404927 i := 0. 404928 [i < count] whileTrue: 404929 [ 404930 history redo. 404931 lastCommand := command. 404932 ((i := i + 1) < count) ifTrue: 404933 [ 404934 (command := history nextCommand) ifNil:[ 404935 self multiUndoError: ('Only ', (i - 1) asString, ' commands to redo.'). 404936 i := count.]]]. 404937 404938 (newSelection := lastCommand redoSelectionInterval) isNil 404939 ifTrue:[ self selectInterval: saveSelection] 404940 ifFalse:[ self selectInterval: newSelection]. 404941 404942! ! 404943 404944!TextMorphEditor methodsFor: 'multi level undo' stamp: 'michael.rueger 2/23/2009 13:32'! 404945multiRedo: readAheadStream 404946 self closeTypeIn. 404947 self multiRedoWithCount: 1. 404948 ^true 404949! ! 404950 404951!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 17:24'! 404952multiUndo 404953 ^self multiUndoWithCount: 1 404954! ! 404955 404956!TextMorphEditor methodsFor: 'multi level undo' stamp: 'md 8/15/2005 11:18'! 404957multiUndoError: eString 404958 404959 Beeper beep 404960! ! 404961 404962!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 18:53'! 404963multiUndoWithCount: count 404964 404965 | command i lastCommand saveSelection newSelection history | 404966 404967 count > 0 ifFalse:[ ^self ]. 404968 history := self editHistory. 404969 (command := history commandToUndo) 404970 ifNil:[ ^self multiUndoError: 'Nothing to undo']. 404971 404972 saveSelection := self selectionInterval. 404973 self deselect. 404974 i := 0. 404975 [i < count] whileTrue: 404976 [history undo. 404977 lastCommand := command. 404978 ((i := i + 1) < count) ifTrue: 404979 [(command := history commandToUndo) ifNil:[ 404980 self multiUndoError: ('Only ', (i - 1) asString, ' commands to undo.'). 404981 i := count. ]]]. 404982 404983 (newSelection := lastCommand undoSelectionInterval) isNil 404984 ifTrue:[ self selectInterval: saveSelection] 404985 ifFalse:[ self selectInterval: newSelection]. 404986 404987! ! 404988 404989!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 13:45'! 404990noUndoReplace: anInterval with: aText 404991"This is the zap that multilevel undo uses to do edits. This method bypasses any undo/redo plumbing (in contrast to zapSelection:). This method is called by an EditCommand (which wants to carry out its paragraph surgery without adding another command to the editHistory)" 404992 404993 | start stop | 404994 self deselect. 404995 start := (anInterval first max: 1). 404996 stop := (anInterval last min: paragraph text size). 404997 (aText isEmpty and: [stop > start]) ifTrue: 404998 ["If deleting, then set emphasisHere from 1st character of the deletion" 404999 emphasisHere := (paragraph text attributesAt: start forStyle: paragraph textStyle) 405000 select: [:att | att mayBeExtended]]. 405001"Debug dShow: ('zap start->stop: ', (start to: stop) asString)." 405002 paragraph 405003 replaceFrom: start 405004 to: stop 405005 with: aText 405006 displaying: false. 405007 405008 UndoMessage sends: #noUndoer . "Keep the normal undo machine happy" 405009 self userHasEdited " -- note text now dirty" 405010! ! 405011 405012!TextMorphEditor methodsFor: 'multi level undo' stamp: 'sps 7/24/2003 13:34'! 405013undo 405014 "Reset the state of the paragraph prior to the previous edit. 405015 If another ParagraphEditor instance did that edit, UndoInterval is invalid; 405016 just recover the contents of the undo-buffer at the start of the paragraph." 405017 405018 Preferences multipleTextUndo 405019 ifTrue: [ ^self multiUndo ] 405020 ifFalse:[ ^super undo ]. 405021! ! 405022 405023 405024!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'th 9/20/2002 11:26'! 405025selectAndScrollToTop 405026 "Scroll until the selection is in the view and then highlight it." 405027 405028 | lineHeight deltaY rect deltaX | 405029 lineHeight := paragraph textStyle lineGrid. 405030 rect := morph owner bounds. 405031 deltaY := self stopBlock top - rect top. 405032 deltaY ~= 0 ifTrue: [ 405033 deltaX := 0. 405034 deltaY := (deltaY abs + lineHeight - 1 truncateTo: lineHeight) negated. 405035 morph editView scrollBy: deltaX@deltaY]! ! 405036 405037!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'sbw 10/14/1999 16:51'! 405038selectForTopFrom: start to: stop 405039 405040 self selectFrom: start to: stop. 405041 morph editView ifNotNil: [self selectAndScrollToTop]! ! 405042 405043!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'th 9/19/2002 18:17'! 405044storeSelectionInParagraph 405045 paragraph selectionStart: self startBlock selectionStop: self stopBlock! ! 405046 405047!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'di 4/21/1998 13:26'! 405048userHasNotEdited 405049 "Note that my text is free of user edits." 405050 405051 morph hasUnacceptedEdits: false! ! 405052 405053 405054!TextMorphEditor methodsFor: 'new selection' stamp: 'ls 11/10/2002 12:26'! 405055selectFrom: start to: stop 405056 "Select the specified characters inclusive." 405057 self selectInvisiblyFrom: start to: stop. 405058 self closeTypeIn. 405059 self storeSelectionInParagraph. 405060 self setEmphasisHere. 405061! ! 405062 405063 405064!TextMorphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'michael.rueger 2/23/2009 13:32'! 405065raiseContextMenu: characterStream 405066 (morph respondsTo: #editView) 405067 ifTrue: [morph editView yellowButtonActivity: ActiveEvent shiftPressed] 405068 ifFalse: [ 405069 morph yellowButtonActivity: false]. 405070 ^ true! ! 405071 405072 405073!TextMorphEditor methodsFor: 'scrolling' stamp: 'di 10/2/97 09:08'! 405074scrollBy: ignore 405075 "Ignore scroll requests."! ! 405076 405077 405078!TextMorphEditor methodsFor: 'typing support' stamp: 'michael.rueger 3/9/2009 22:43'! 405079dispatchOnKeyEvent: keyEvent with: typeAheadStream 405080 "Carry out the action associated with this character, if any. 405081 Type-ahead is passed so some routines can flush or use it." 405082 405083 ((keyEvent keyCharacter = Character cr) and: [morph acceptOnCR]) 405084 ifTrue: [ 405085 self closeTypeIn. 405086 ^ true]. 405087 405088 ^ super dispatchOnKeyEvent: keyEvent with: typeAheadStream! ! 405089 405090!TextMorphEditor methodsFor: 'typing support' stamp: 'michael.rueger 2/23/2009 17:40'! 405091keystroke: keyEvent 405092 super keystroke: keyEvent. 405093 self storeSelectionInParagraph! ! 405094 405095 405096!TextMorphEditor methodsFor: 'private' stamp: 'stephane.ducasse 4/14/2009 10:46'! 405097againOrSame: bool 405098 405099 super againOrSame: bool. 405100 (morph respondsTo: #editView) 405101 ifTrue: [morph editView selectionInterval: self selectionInterval]! ! 405102 405103"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 405104 405105TextMorphEditor class 405106 instanceVariableNames: ''! 405107TextMorph subclass: #TextMorphForEditView 405108 instanceVariableNames: 'editView acceptOnCR' 405109 classVariableNames: '' 405110 poolDictionaries: '' 405111 category: 'Morphic-Text Support'! 405112 405113!TextMorphForEditView methodsFor: 'accept/cancel' stamp: 'di 9/11/1998 15:42'! 405114acceptOnCR: trueOrFalse 405115 acceptOnCR := trueOrFalse! ! 405116 405117 405118!TextMorphForEditView methodsFor: 'changed' stamp: 'tbn 8/5/2009 09:48'! 405119keyboardFocusChange: aBoolean 405120 "rr 3/21/2004 22:55 : removed the #ifFalse: branch, 405121 which was responsible of the deselection of text when the 405122 paragraph lost focus. This way selection works in a more standard 405123 way, and this permits the menu keyboard control to be really effective. 405124 Changed to update focus indication." 405125 405126 |ptm| 405127 paragraph isNil ifFalse:[paragraph focused: aBoolean]. 405128 aBoolean 405129 ifTrue: 405130 ["A hand is wanting to send us characters..." 405131 405132 self hasFocus ifFalse: [self editor "Forces install"]. 405133 self startBlinking. 405134 ] ifFalse:[ 405135 self stopBlinking. 405136 ]. 405137 (Preferences externalFocusForPluggableText 405138 and: [(ptm := self ownerThatIsA: PluggableTextMorph) notNil]) 405139 ifTrue: [ptm changed] 405140 ifFalse: [self changed] 405141! ! 405142 405143 405144!TextMorphForEditView methodsFor: 'debug and other' stamp: 'sw 11/2/1998 15:51'! 405145tempCommand 405146 "Smalltalk browseAllImplementorsOf: #tempCommand" 405147 "Place your definition for tempCommand for this class here"! ! 405148 405149 405150!TextMorphForEditView methodsFor: 'drawing' stamp: 'di 6/22/1998 10:44'! 405151drawNullTextOn: aCanvas 405152 "Just run the normal code to show selection in a window" 405153 aCanvas paragraph: self paragraph bounds: bounds color: color 405154! ! 405155 405156 405157!TextMorphForEditView methodsFor: 'edit view' stamp: 'di 6/22/1998 01:31'! 405158editView 405159 ^ editView! ! 405160 405161!TextMorphForEditView methodsFor: 'edit view' stamp: 'di 4/21/1998 13:09'! 405162setEditView: editPane 405163 editView := editPane! ! 405164 405165 405166!TextMorphForEditView methodsFor: 'editing' stamp: 'di 4/22/1998 10:57'! 405167acceptContents 405168 "The message is sent when the user hits enter or Cmd-S. 405169 Accept the current contents and end editing." 405170 self updateFromParagraph. 405171 editView accept.! ! 405172 405173!TextMorphForEditView methodsFor: 'editing' stamp: 'sw 8/12/2002 00:02'! 405174acceptOnCR 405175 "Answer whether the receiver wants to accept when the Return key is hit" 405176 405177 ^ acceptOnCR == true! ! 405178 405179!TextMorphForEditView methodsFor: 'editing' stamp: 'di 4/22/1998 11:03'! 405180cancelEdits 405181 "The message is sent when the user hits enter or Cmd-L. 405182 Cancel the current contents and end editing." 405183 self releaseParagraph. 405184 editView cancel! ! 405185 405186!TextMorphForEditView methodsFor: 'editing' stamp: 'michael.rueger 2/23/2009 17:37'! 405187handleInteraction: interActionBlock 405188 "Overridden to pass along a model to the editor for, eg, link resolution, doits, etc" 405189 405190 self editor model: editView model. "For evaluateSelection, etc" 405191 ^ super handleInteraction: interActionBlock! ! 405192 405193!TextMorphForEditView methodsFor: 'editing' stamp: 'di 4/21/1998 13:23'! 405194hasUnacceptedEdits: aBoolean 405195 "Set the hasUnacceptedEdits flag in my view." 405196 405197 editView hasUnacceptedEdits: aBoolean! ! 405198 405199 405200!TextMorphForEditView methodsFor: 'event handling' stamp: 'ar 11/8/2000 15:50'! 405201autoScrollView: evt 405202 "This is kind of a hack because the PluggableTextMorph expects me to first expand the selection before auto scrolling will work." 405203 | localEvt | 405204 localEvt := evt transformedBy: (self transformedFrom: editView). 405205 super mouseMove: localEvt. 405206 editView scrollSelectionIntoView: localEvt.! ! 405207 405208!TextMorphForEditView methodsFor: 'event handling' stamp: 'michael.rueger 3/23/2009 17:03'! 405209keyStroke: evt 405210 "Handle a keystroke. Deal with navigation keys also." 405211 405212 | view | 405213 (editView scrollByKeyboard: evt) ifTrue: [^self]. 405214 (acceptOnCR not and: [evt keyCharacter = Character cr]) 405215 ifFalse: [(editView navigationKey: evt) ifTrue: [^self]]. 405216 self editor model: editView model. "For evaluateSelection" 405217 view := editView. "Copy into temp for case of a self-mutating doit" 405218 self editView enabled 405219 ifTrue: [(acceptOnCR and: [evt keyCharacter = Character cr]) 405220 ifTrue: [^ self editor accept]. 405221 super keyStroke: evt] 405222 ifFalse: ["alllow some commands" 405223 self eventHandler ifNotNil: 405224 [self eventHandler keyStroke: evt fromMorph: self]. 405225 self handleInteraction: [editor handleDisabledKey: evt.]]. 405226 view scrollSelectionIntoView! ! 405227 405228!TextMorphForEditView methodsFor: 'event handling' stamp: 'di 6/30/1998 08:50'! 405229mouseDown: event 405230 405231 event yellowButtonPressed ifTrue: [^ editView yellowButtonActivity: event shiftPressed]. 405232 ^ super mouseDown: event 405233! ! 405234 405235!TextMorphForEditView methodsFor: 'event handling' stamp: 'ar 9/26/2001 22:28'! 405236mouseMove: evt 405237 | editEvt | 405238 super mouseMove: evt. 405239 evt redButtonPressed ifFalse: [^ self]. 405240 editEvt := evt transformedBy: (self transformedFrom: editView) inverseTransformation. 405241 (editEvt position y between: editView top and: editView bottom) ifFalse:[ 405242 "Start auto-scrolling" 405243 self startStepping: #autoScrollView: 405244 at: Time millisecondClockValue 405245 arguments: (Array with: editEvt) 405246 stepTime: 100. "fast enough" 405247 ] ifTrue:[ 405248 self stopSteppingSelector: #autoScrollView:. 405249 ].! ! 405250 405251!TextMorphForEditView methodsFor: 'event handling' stamp: 'sumim 1/16/2007 19:43'! 405252mouseUp: evt 405253 super mouseUp: evt. 405254 self stopSteppingSelector: #autoScrollView:. 405255 "editView scrollSelectionIntoView: evt." 405256 editView selectionInterval: editor selectionInterval. 405257 self setCompositionWindow. 405258! ! 405259 405260!TextMorphForEditView methodsFor: 'event handling' stamp: 'fbs 1/7/2005 15:43'! 405261preferredKeyboardPosition 405262 405263 | pos | 405264 pos := super preferredKeyboardPosition. 405265 ^ pos + (self bounds: self bounds in: World) topLeft. 405266! ! 405267 405268!TextMorphForEditView methodsFor: 'event handling' stamp: 'sw 8/29/2000 15:06'! 405269wouldAcceptKeyboardFocusUponTab 405270 "Answer whether the receiver would be a happy inheritor of keyboard focus if tab were hit in an enclosing playfield under propitious circumstances. Does not make sense for this kind of morph, which is encased in a window" 405271 405272 ^ false! ! 405273 405274 405275!TextMorphForEditView methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:12'! 405276initialize 405277 super initialize. 405278 acceptOnCR := false! ! 405279 405280 405281!TextMorphForEditView methodsFor: 'macpal' stamp: 'di 11/10/1998 10:13'! 405282flash 405283 ^ editView flash! ! 405284 405285 405286!TextMorphForEditView methodsFor: 'miscellaneous' stamp: 'sw 7/27/2001 13:35'! 405287selectAll 405288 "Tell my editor to select all the text" 405289 405290 self editor selectAll! ! 405291 405292 405293!TextMorphForEditView methodsFor: 'private' stamp: 'dew 2/21/1999 03:09'! 405294updateFromParagraph 405295 super updateFromParagraph. 405296 editView setScrollDeltas.! ! 405297 405298"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 405299 405300TextMorphForEditView class 405301 instanceVariableNames: ''! 405302 405303!TextMorphForEditView class methodsFor: 'new-morph participation' stamp: 'kfr 5/1/2000 13:41'! 405304includeInNewMorphMenu 405305 "Not to be instantiated from the menu" 405306 ^ false! ! 405307TextMorphForEditView subclass: #TextMorphForEditorView 405308 instanceVariableNames: 'autoAccept acceptOnFocusChange' 405309 classVariableNames: '' 405310 poolDictionaries: '' 405311 category: 'Polymorph-Widgets'! 405312!TextMorphForEditorView commentStamp: 'gvc 5/18/2007 11:13' prior: 0! 405313Multi-line text editor with support for accepting on both each change and/or when keyboard focus changes. Also supports custom selection colour and clickable highlights From PluggableTextEditorMorph.! 405314 405315 405316!TextMorphForEditorView methodsFor: 'accessing' stamp: 'gvc 9/28/2006 12:07'! 405317acceptOnFocusChange 405318 "Answer the value of acceptOnFocusChange" 405319 405320 ^ acceptOnFocusChange! ! 405321 405322!TextMorphForEditorView methodsFor: 'accessing' stamp: 'gvc 9/28/2006 12:07'! 405323acceptOnFocusChange: anObject 405324 "Set the value of acceptOnFocusChange" 405325 405326 acceptOnFocusChange := anObject! ! 405327 405328!TextMorphForEditorView methodsFor: 'accessing' stamp: 'gvc 9/9/2006 14:02'! 405329autoAccept 405330 "Answer the value of autoAccept" 405331 405332 ^ autoAccept! ! 405333 405334!TextMorphForEditorView methodsFor: 'accessing' stamp: 'gvc 9/9/2006 14:02'! 405335autoAccept: anObject 405336 "Set the value of autoAccept" 405337 405338 autoAccept := anObject! ! 405339 405340 405341!TextMorphForEditorView methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 15:26'! 405342basicKeyStroke: evt 405343 "Do the key stroke and check to see if it should be accepted." 405344 405345 super keyStroke: evt. 405346 self autoAccept 405347 ifTrue: [self editView hasUnacceptedEdits ifTrue: [self editor accept]]! ! 405348 405349!TextMorphForEditorView methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:09'! 405350initialize 405351 "Initialize the receiver." 405352 405353 super initialize. 405354 self 405355 autoAccept: false; 405356 acceptOnFocusChange: false! ! 405357 405358!TextMorphForEditorView methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 16:21'! 405359keyStroke: evt 405360 "Don't allow editing keys if the edit view is disabled." 405361 405362 self basicKeyStroke: evt! ! 405363 405364!TextMorphForEditorView methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:09'! 405365keyboardFocusChange: aBoolean 405366 "If we are losing focus and have acceptOnFocusChange then accept." 405367 405368 super keyboardFocusChange: aBoolean. 405369 self acceptOnFocusChange 405370 ifTrue: [self editView hasUnacceptedEdits ifTrue: [self editor accept]]! ! 405371 405372!TextMorphForEditorView methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 16:11'! 405373mouseDown: evt 405374 "Pass to any highlight too." 405375 405376 |hl| 405377 super mouseDown: evt. 405378 hl := self editView highlights 405379 detect: [:h | 405380 h containsPoint: evt position 405381 in: (self bounds: self editView innerBounds from: self)] 405382 ifNone: [^self]. 405383 hl clicked: evt! ! 405384 405385!TextMorphForEditorView methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 14:05'! 405386paragraph 405387 "Answer the paragraph." 405388 405389 |p| 405390 p := super paragraph. 405391 self selectionColor: self selectionColor. 405392 ^p! ! 405393 405394!TextMorphForEditorView methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 16:13'! 405395paragraphClass 405396 "Answer an appropriate paragraph class." 405397 405398 container ifNil: [^MultiNewParagraphWithSelectionColor]. 405399 ^super paragraphClass! ! 405400 405401!TextMorphForEditorView methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 16:22'! 405402selectionColor 405403 "Answer the colour to use for the text selection." 405404 405405 ^self valueOfProperty: #selectionColor ifAbsent: [] ! ! 405406 405407!TextMorphForEditorView methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 14:05'! 405408selectionColor: aColor 405409 "Set the colour to use for the text selection." 405410 405411 aColor 405412 ifNil: [self removeProperty: #selectionColor] 405413 ifNotNil: [self setProperty: #selectionColor toValue: aColor]. 405414 paragraph ifNotNilDo: [:p | 405415 (p respondsTo: #selectionColor:) ifTrue: [ 405416 p selectionColor: aColor]]! ! 405417TextMorphForEditorView subclass: #TextMorphForFieldView 405418 instanceVariableNames: 'maxLength' 405419 classVariableNames: '' 405420 poolDictionaries: '' 405421 category: 'Polymorph-Widgets'! 405422!TextMorphForFieldView commentStamp: 'gvc 5/18/2007 12:28' prior: 0! 405423Single-line text field editor with DialogWindow key integration (return for default, escape for cancel) and keyboard focus navigation (tab/shift-tab).! 405424 405425 405426!TextMorphForFieldView methodsFor: 'accessing' stamp: 'gvc 9/18/2006 14:58'! 405427maxLength 405428 "Answer the value of maxLength" 405429 405430 ^ maxLength! ! 405431 405432!TextMorphForFieldView methodsFor: 'accessing' stamp: 'gvc 9/18/2006 14:58'! 405433maxLength: anObject 405434 "Set the value of maxLength" 405435 405436 maxLength := anObject! ! 405437 405438 405439!TextMorphForFieldView methodsFor: 'as yet unclassified' stamp: 'gvc 8/28/2009 14:00'! 405440basicKeyStroke: evt 405441 "Do the key if max length has not been reached. 405442 Don't allow tabs." 405443 405444 (self localHandleKeystroke: evt) ifTrue: [^self]. 405445 (self maxLength isNil or: [self text size < self maxLength or: [ 405446 self editor selectionInterval size > 0 or: [self isEditEvent: evt]]]) 405447 ifTrue: [evt keyCharacter = Character cr ifTrue: [self dialogWindow ifNotNilDo: [:w | ^w keyStroke: evt]]. 405448 evt keyCharacter = Character escape ifTrue: [self dialogWindow ifNotNilDo: [:w | ^w keyStroke: evt]]. 405449 super basicKeyStroke: evt]! ! 405450 405451!TextMorphForFieldView methodsFor: 'as yet unclassified' stamp: 'gvc 8/28/2009 14:00'! 405452isEditEvent: anEvent 405453 "Answer whether the given event is a key stroke that 405454 should be allowed despite the max length." 405455 405456 |key| 405457 key := anEvent keyValue asCharacter. 405458 ^key == Character cr or: [ 405459 key == Character backspace or: [ 405460 key == Character delete or: [ 405461 key == Character arrowLeft or: [ 405462 key == Character arrowRight or: [ 405463 key == Character home or: [ 405464 key == Character end or: [ 405465 anEvent commandKeyPressed and: [key = $a]]]]]]]]! ! 405466 405467!TextMorphForFieldView methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:54'! 405468keyboardFocusChange: aBoolean 405469 "If we are losing focus and have acceptOnFocusChange then accept." 405470 405471 aBoolean 405472 ifTrue: [self editView selectAll] 405473 ifFalse: [self editView selectFrom: 1 to: 0]. 405474 super keyboardFocusChange: aBoolean! ! 405475 405476!TextMorphForFieldView methodsFor: 'as yet unclassified' stamp: 'gvc 4/25/2007 16:05'! 405477localHandleKeystroke: evt 405478 "Answer whether we locally handle the keyStroke event. 405479 Disregard tabs for now." 405480 405481 evt keyCharacter = Character tab ifTrue: [ 405482 evt shiftPressed 405483 ifTrue: [(self editView respondsTo: #navigateFocusBackward) 405484 ifTrue: [self editView navigateFocusBackward]] 405485 ifFalse: [(self editView respondsTo: #navigateFocusForward) 405486 ifTrue: [self editView navigateFocusForward]]. 405487 ^true]. 405488 ^false! ! 405489 405490!TextMorphForFieldView methodsFor: 'as yet unclassified' stamp: 'gvc 10/17/2008 12:35'! 405491minExtent 405492 "Overridden to allow text to shrink to minimum extent rather than being (incorrectly) 405493 treated as rigid. Should be the same for other morphs too. Bah!!" 405494 405495 | layout minExtent extra hFit vFit | 405496 hFit := self hResizing. 405497 vFit := self vResizing. 405498 (hFit == #spaceFill or: [vFit == #spaceFill]) 405499 ifFalse: 405500 ["The receiver will not adjust to parents layout by growing or shrinking, 405501 which means that an accurate layout defines the minimum size." 405502 405503 ^self fullBounds extent]. 405504 layout := self layoutPolicy. 405505 minExtent := layout isNil 405506 ifTrue: [0 @ 0] 405507 ifFalse: [layout minExtentOf: self in: self layoutBounds]. 405508 minExtent := hFit == #rigid 405509 ifTrue: [self fullBounds extent x @ minExtent y] 405510 ifFalse: 405511 [extra := self bounds width - self layoutBounds width. 405512 (minExtent x + extra) @ minExtent y]. 405513 minExtent := vFit == #rigid 405514 ifTrue: [minExtent x @ self fullBounds extent y] 405515 ifFalse: 405516 [extra := self bounds height - self layoutBounds height. 405517 minExtent x @ (minExtent y + extra)]. 405518 minExtent := minExtent max: self minWidth @ self minHeight. 405519 ^minExtent! ! 405520 405521!TextMorphForFieldView methodsFor: 'as yet unclassified' stamp: 'gvc 6/4/2007 11:22'! 405522minHeight 405523 "Answer the height of one line." 405524 405525 ^self minimumExtent y max: super minHeight! ! 405526 405527!TextMorphForFieldView methodsFor: 'as yet unclassified' stamp: 'gvc 6/4/2007 11:22'! 405528minWidth 405529 "Answer the minimum width." 405530 405531 ^self minimumExtent x max: super minWidth! ! 405532 405533!TextMorphForFieldView methodsFor: 'as yet unclassified' stamp: 'gvc 6/4/2007 11:55'! 405534minimumExtent 405535 "Use the actual paragraph line to take font changes into account." 405536 405537 | minExt | 405538 textStyle ifNil: [^ 9@16]. 405539 borderWidth ifNil: [^ 9@16]. 405540 minExt := (9@(self paragraph lines first lineHeight ceiling)) + (borderWidth*2). 405541 margins ifNil: [^ minExt]. 405542 ^ ((0@0 extent: minExt) expandBy: margins) extent! ! 405543 405544!TextMorphForFieldView methodsFor: 'as yet unclassified' stamp: 'gvc 1/4/2007 16:05'! 405545mouseMove: evt 405546 "Allow auto scroll in any direction. 405547 Something else is preventing the left/right case." 405548 405549 | editEvt | 405550 self perform: #mouseMove: withArguments: {evt} inSuperclass: TextMorph. 405551 evt redButtonPressed ifFalse: [^ self]. 405552 editEvt := evt transformedBy: (self transformedFrom: editView) inverseTransformation. 405553 (editView bounds containsPoint: editEvt position) ifFalse:[ 405554 "Start auto-scrolling" 405555 self startStepping: #autoScrollView: 405556 at: Time millisecondClockValue 405557 arguments: (Array with: editEvt) 405558 stepTime: 100. "fast enough" 405559 ] ifTrue:[ 405560 self stopSteppingSelector: #autoScrollView:. 405561 ].! ! 405562 405563!TextMorphForFieldView methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 10:51'! 405564paragraph 405565 "Paragraph instantiation is lazy -- create it only when needed. 405566 Don't adjust rightX (as in TexMorph>>paragraph) 405567 since wrapFlag must be false for layout to work." 405568 405569 paragraph ifNotNil: [^ paragraph]. 405570 405571self setProperty: #CreatingParagraph toValue: true. 405572 405573 self setDefaultContentsIfNil. 405574 405575 "...Code here to recreate the paragraph..." 405576 paragraph := (self paragraphClass new textOwner: self owner). 405577 paragraph wantsColumnBreaks: successor notNil. 405578 paragraph 405579 compose: text 405580 style: textStyle copy 405581 from: self startingIndex 405582 in: self container. 405583 "don't adjust the right, let it scroll!!" 405584 paragraph focused: (self currentHand keyboardFocus == self). 405585 self fit. 405586self removeProperty: #CreatingParagraph. 405587 405588 self selectionColor: self selectionColor. 405589 ^ paragraph! ! 405590ClassTestCase subclass: #TextMorphTest 405591 instanceVariableNames: '' 405592 classVariableNames: '' 405593 poolDictionaries: '' 405594 category: 'MorphicTests-Basic'! 405595 405596!TextMorphTest methodsFor: 'testing' stamp: 'md 11/13/2003 10:01'! 405597testInitialize 405598 "For now, just make sure initialization doesn't throw exception" 405599 405600 self shouldnt: [TextMorph initialize] raise: Error.! ! 405601TextDoIt subclass: #TextPrintIt 405602 instanceVariableNames: '' 405603 classVariableNames: '' 405604 poolDictionaries: '' 405605 category: 'Collections-Text'! 405606 405607!TextPrintIt methodsFor: 'as yet unclassified' stamp: 'dvf 10/1/2003 13:27'! 405608actOnClickFor: anObject in: aParagraph at: clickPoint editor: editor 405609 "Note: evalString gets evaluated IN THE CONTEXT OF anObject 405610 -- meaning that self and all instVars are accessible" 405611 | result range index | 405612 result := Compiler evaluate: evalString for: anObject logged: false. 405613 result := ' ', result printString,' '. 405614 "figure out where the attribute ends in aParagraph" 405615 index := (aParagraph characterBlockAtPoint: clickPoint) stringIndex. 405616 range := aParagraph text rangeOf: self startingAt: index. 405617 editor selectFrom: range last+1 to: range last. 405618 editor zapSelectionWith: result. 405619 editor selectFrom: range last to: range last + result size. 405620 ^ true ! ! 405621 405622!TextPrintIt methodsFor: 'as yet unclassified' stamp: 'ar 9/22/2001 16:28'! 405623writeScanOn: strm 405624 405625 strm nextPut: $P; nextPutAll: evalString; nextPutAll: ';;'! ! 405626Object subclass: #TextPrinter 405627 instanceVariableNames: 'form para paperSize landscape resolution depth offset columns docTitle noHeader noFooter' 405628 classVariableNames: 'DefaultPaperSize DefaultTextPrinter' 405629 poolDictionaries: '' 405630 category: 'Graphics-Text'! 405631 405632!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'! 405633bestColor 405634 "Set the reproduction quality to true color" 405635 depth := 32.! ! 405636 405637!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'! 405638blackAndWhite 405639 "Set the reproduction quality to black and white" 405640 depth := 1.! ! 405641 405642!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:50'! 405643columns 405644 ^columns! ! 405645 405646!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:50'! 405647columns: aNumber 405648 columns := aNumber asInteger max: 1.! ! 405649 405650!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 20:14'! 405651documentTitle 405652 ^docTitle! ! 405653 405654!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 20:14'! 405655documentTitle: aString 405656 docTitle := aString! ! 405657 405658!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'! 405659goodColor 405660 "Set the reproduction quality to 8 bit color depth" 405661 depth := 8.! ! 405662 405663!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'! 405664landscape 405665 ^landscape! ! 405666 405667!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'! 405668landscape: aBoolean 405669 landscape := aBoolean! ! 405670 405671!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:23'! 405672noFooter 405673 ^noFooter! ! 405674 405675!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:22'! 405676noFooter: aBoolean 405677 "Turn off footer printing" 405678 noFooter := aBoolean.! ! 405679 405680!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:22'! 405681noHeader 405682 ^noHeader! ! 405683 405684!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:22'! 405685noHeader: aBoolean 405686 "Turn off header printing" 405687 noHeader := aBoolean.! ! 405688 405689!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:27'! 405690offsetRect 405691 ^offset! ! 405692 405693!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:27'! 405694offsetRect: aRectangle 405695 "Set the offset rectangle" 405696 offset := aRectangle! ! 405697 405698!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'! 405699paperSize 405700 ^paperSize! ! 405701 405702!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'! 405703paperSize: aPoint 405704 paperSize := aPoint! ! 405705 405706!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:43'! 405707resolution 405708 ^resolution! ! 405709 405710!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:43'! 405711resolution: aPoint 405712 resolution := aPoint! ! 405713 405714 405715!TextPrinter methodsFor: 'footer' stamp: 'ar 4/30/98 19:23'! 405716footerHeight 405717 "Return the (additional) height of the footer in inches." 405718 self noFooter ifTrue:[^0.0]. 405719 ^(self pix2in: 0@TextStyle default lineGrid) y * 2! ! 405720 405721!TextPrinter methodsFor: 'footer' stamp: 'ar 4/30/98 20:11'! 405722footerParagraph 405723 "Return a paragraph for the footer" 405724 | fPara rect | 405725 fPara := Paragraph new. 405726 fPara destinationForm: form. 405727 rect := (self in2pix: self textArea bottomLeft) corner: 405728 (self in2pix: self textArea bottomRight + (0.0@self footerHeight)). 405729 fPara clippingRectangle: rect. 405730 fPara compositionRectangle: rect. 405731 ^fPara! ! 405732 405733!TextPrinter methodsFor: 'footer' stamp: 'ar 4/30/98 19:24'! 405734printFooter: pageNumber 405735 "Print the footer for the given page number" 405736 | fPara | 405737 self noFooter ifTrue:[^self]. 405738 fPara := self footerParagraph. 405739 fPara centered. 405740 fPara text: ('Page ', pageNumber printString) asText. 405741 fPara displayOn: form.! ! 405742 405743 405744!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:25'! 405745columnRect: n 405746 "Return a rectangle describing the n-th column" 405747 | area left right | 405748 area := self textArea. 405749 left := area left + ((n-1) * self columnWidth). 405750 left := left + ((n-1) * self columnSkip). 405751 right := left + self columnWidth. 405752 ^(self in2pix: left @ area top) corner: 405753 (self in2pix: right @ area bottom)! ! 405754 405755!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:20'! 405756columnSkip 405757 "Return the separating space between two columns in inches" 405758 ^0.2! ! 405759 405760!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:21'! 405761columnWidth 405762 ^(self textWidth - ((self columns-1) * self columnSkip)) / self columns! ! 405763 405764!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:29'! 405765formatColumn: columnNum startingWith: anIndex 405766 "Format a new column starting at the given string index. Return the string index indicating the start of the next column or nil if no more columns need printing." 405767 | colRect blk | 405768 colRect := self columnRect: columnNum. 405769 anIndex > 1 ifTrue:[para text: (para text copyFrom: anIndex to: para text size)]. 405770 para compositionRectangle: colRect. 405771 para clippingRectangle: colRect. 405772 para composeAll. 405773 para displayOn: form. 405774 para visibleRectangle corner y <= colRect extent y ifTrue:[^nil]. 405775 "More columns -- find the character block of the last line and adjust clip rect" 405776 blk := para characterBlockAtPoint: para visibleRectangle bottomLeft. 405777 para clearVisibleRectangle. "Make sure that the background is clean" 405778 para clippingRectangle: (colRect topLeft corner: colRect right@blk top). 405779 para displayOn: form. 405780 ^blk stringIndex.! ! 405781 405782!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:29'! 405783formatPage: pageNum startingWith: anIndex 405784 "Format a new page starting at the given string index. Return the string index indicating the start of the next page or nil if no more pages need printing." 405785 | nextIndex | 405786 nextIndex := anIndex. 405787 1 to: self columns do:[:i| 405788 nextIndex := self formatColumn: i startingWith: nextIndex. 405789 nextIndex isNil ifTrue:[^nil]. 405790 ]. 405791 ^nextIndex! ! 405792 405793!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:58'! 405794textArea 405795 ^(self offsetRect origin + (0.0@self headerHeight)) corner: 405796 (self realPaperSize - self offsetRect corner - (0.0@self footerHeight))! ! 405797 405798!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:23'! 405799textWidth 405800 ^self textArea extent x! ! 405801 405802 405803!TextPrinter methodsFor: 'header' stamp: 'ar 4/30/98 19:23'! 405804headerHeight 405805 "Return the (additional) height of the header in inches." 405806 self noHeader ifTrue:[^0.0]. 405807 ^(self pix2in: 0@TextStyle default lineGrid) y * 2! ! 405808 405809!TextPrinter methodsFor: 'header' stamp: 'ar 4/30/98 20:11'! 405810headerParagraph 405811 "Return a paragraph for the footer" 405812 | hPara rect | 405813 hPara := Paragraph new. 405814 hPara destinationForm: form. 405815 rect := (self in2pix: self textArea topLeft - (0.0@self headerHeight)) corner: 405816 (self in2pix: self textArea topRight). 405817 hPara clippingRectangle: rect. 405818 hPara compositionRectangle: rect. 405819 ^hPara! ! 405820 405821!TextPrinter methodsFor: 'header' stamp: 'ar 4/30/98 19:23'! 405822printHeader: pageNumber 405823 "Print the header for the given page number" 405824 | fPara | 405825 self noHeader ifTrue:[^self]. 405826 fPara := self headerParagraph. 405827 fPara centered. 405828 fPara text: self documentTitle asText. 405829 fPara displayOn: form.! ! 405830 405831 405832!TextPrinter methodsFor: 'initialize' stamp: 'ar 4/30/98 19:26'! 405833defaultPaperSize 405834 "Return the default paper size (inches) for printing" 405835 ^self class defaultPaperSize! ! 405836 405837!TextPrinter methodsFor: 'initialize' stamp: 'nk 4/2/2004 11:32'! 405838defaultResolution 405839 "Return the default resolution (DPI) for printing" 405840 ^TextStyle pixelsPerInch asPoint! ! 405841 405842!TextPrinter methodsFor: 'initialize' stamp: 'adrian_lienhard 7/18/2009 16:03'! 405843initialize 405844 self paperSize: self defaultPaperSize. 405845 self resolution: self defaultResolution. 405846 self blackAndWhite. 405847 self landscape: false. 405848 self offsetRect: (1.0@1.0 corner: 1.0@1.0). 405849 self columns: 1. 405850 self noHeader: false. 405851 self noFooter: false. 405852 self documentTitle: 'Pharo Document (from ', Date today printString,')'.! ! 405853 405854 405855!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:39'! 405856in2mm: aPoint 405857 "Convert aPoint from millimeters to inches" 405858 ^aPoint * 25.4! ! 405859 405860!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:38'! 405861in2pix: aPoint 405862 "Convert aPoint from inches to actual pixels" 405863 ^(aPoint * self resolution) rounded! ! 405864 405865!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:38'! 405866mm2in: aPoint 405867 "Convert aPoint from millimeters to inches" 405868 ^aPoint / 25.4! ! 405869 405870!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:40'! 405871mm2pix: aPoint 405872 "Convert aPoint from millimeters to actual pixels" 405873 ^self in2pix: (self mm2in: aPoint)! ! 405874 405875!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:39'! 405876pix2in: aPoint 405877 "Convert aPoint from a pixel value to inches" 405878 ^aPoint / self resolution! ! 405879 405880!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:40'! 405881pix2mm: aPoint 405882 "Convert aPoint from a pixel value to millimeters" 405883 ^self in2mm: (self pix2in: aPoint)! ! 405884 405885 405886!TextPrinter methodsFor: 'printing' stamp: 'ar 4/30/98 20:41'! 405887flushPage 405888 "The current page has been set up. Send it to the printer." 405889 form primPrintHScale: self resolution x vScale: self resolution y landscape: self landscape. 405890 "Uncomment the following for testing" 405891 "form displayOn: Display. (Delay forSeconds: 5) wait." 405892! ! 405893 405894!TextPrinter methodsFor: 'printing' stamp: 'ar 4/30/98 19:19'! 405895printParagraph 405896 | pageNum nextIndex | 405897 para destinationForm: form. 405898 pageNum := 1. 405899 nextIndex := 1. 405900 [form fillColor: Color white. 405901 self printHeader: pageNum. 405902 self printFooter: pageNum. 405903 nextIndex := self formatPage: pageNum startingWith: nextIndex. 405904 self flushPage. 405905 nextIndex isNil] whileFalse:[pageNum := pageNum + 1].! ! 405906 405907!TextPrinter methodsFor: 'printing' stamp: 'ar 4/30/98 18:55'! 405908printText: aText 405909 "Print aText" 405910 form isNil ifTrue:[ 405911 form := Form extent: self pixelSize depth: depth. 405912 ]. 405913 para := Paragraph withText: aText asText. 405914 Cursor wait showWhile:[ 405915 self printParagraph. 405916 ].! ! 405917 405918 405919!TextPrinter methodsFor: 'private' stamp: 'ar 4/30/98 19:40'! 405920pixelSize 405921 "Return the size of the page in pixels" 405922 ^self in2pix: (self realPaperSize)! ! 405923 405924!TextPrinter methodsFor: 'private' stamp: 'ar 4/30/98 19:39'! 405925realPaperSize 405926 ^self landscape 405927 ifTrue:[self paperSize y @ self paperSize x] 405928 ifFalse:[self paperSize]! ! 405929 405930"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 405931 405932TextPrinter class 405933 instanceVariableNames: ''! 405934 405935!TextPrinter class methodsFor: 'accessing' stamp: 'ar 4/30/98 18:31'! 405936defaultPaperSize 405937 ^DefaultPaperSize! ! 405938 405939!TextPrinter class methodsFor: 'accessing' stamp: 'ar 4/30/98 18:31'! 405940defaultPaperSize: aPoint 405941 DefaultPaperSize := aPoint! ! 405942 405943!TextPrinter class methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 405944defaultTextPrinter 405945 "This is the global default TextPrinter instance." 405946 DefaultTextPrinter isNil ifTrue: [ DefaultTextPrinter := self new ]. 405947 ^ DefaultTextPrinter! ! 405948 405949 405950!TextPrinter class methodsFor: 'initialization' stamp: 'ar 4/30/98 18:30'! 405951initialize 405952 "TextPrinter initialize" 405953 self defaultPaperSize: self paperSizeA4.! ! 405954 405955 405956!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:30'! 405957mm2in: aPoint 405958 "Convert aPoint from millimeters to inches" 405959 ^aPoint / 25.4! ! 405960 405961!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'! 405962paperSize10x14 405963 ^10.0@14.0! ! 405964 405965!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'! 405966paperSize11x17 405967 ^11.0@17.0! ! 405968 405969!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'! 405970paperSizeA3 405971 ^self mm2in: 297@420! ! 405972 405973!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'! 405974paperSizeA4 405975 ^self mm2in: 210@297! ! 405976 405977!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'! 405978paperSizeA5 405979 ^self mm2in: 148@210! ! 405980 405981!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'! 405982paperSizeB4 405983 ^self mm2in: 250@354! ! 405984 405985!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'! 405986paperSizeB5 405987 ^self mm2in: 182@257! ! 405988 405989!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'! 405990paperSizeCSheet 405991 ^17.0@22.0! ! 405992 405993!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'! 405994paperSizeDSheet 405995 ^22.0@34.0! ! 405996 405997!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'! 405998paperSizeESheet 405999 ^34.0@44.0! ! 406000 406001!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'! 406002paperSizeEnvelope10 406003 ^4.125@9.5 406004! ! 406005 406006!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'! 406007paperSizeEnvelope11 406008 ^4.5@10.375! ! 406009 406010!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'! 406011paperSizeEnvelope12 406012 ^4.75@11! ! 406013 406014!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'! 406015paperSizeEnvelope14 406016 ^5.0@11.5! ! 406017 406018!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'! 406019paperSizeEnvelope9 406020 ^3.875@8.875! ! 406021 406022!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'! 406023paperSizeEnvelopeB4 406024 ^self mm2in: 250@353! ! 406025 406026!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'! 406027paperSizeEnvelopeB5 406028 ^self mm2in: 176@250! ! 406029 406030!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'! 406031paperSizeEnvelopeB6 406032 ^self mm2in: 176@125! ! 406033 406034!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'! 406035paperSizeEnvelopeC3 406036 ^self mm2in: 324@458! ! 406037 406038!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'! 406039paperSizeEnvelopeC4 406040 ^self mm2in: 229@324! ! 406041 406042!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'! 406043paperSizeEnvelopeC5 406044 ^self mm2in: 162@229! ! 406045 406046!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'! 406047paperSizeEnvelopeC6 406048 ^self mm2in: 114@162! ! 406049 406050!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'! 406051paperSizeEnvelopeC65 406052 ^self mm2in: 114@229! ! 406053 406054!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'! 406055paperSizeFanfoldGerman 406056 "German standard fanfold" 406057 ^8.5@12.0! ! 406058 406059!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'! 406060paperSizeFanfoldLegalGerman 406061 "German legal fanfold" 406062 ^8.5@13.0! ! 406063 406064!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'! 406065paperSizeFanfoldUS 406066 "US standard fanfold" 406067 ^14.875@11.0! ! 406068 406069!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'! 406070paperSizeFolio 406071 ^8.5@13.0! ! 406072 406073!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'! 406074paperSizeLegal 406075 ^8.5@14.0! ! 406076 406077!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'! 406078paperSizeLetter 406079 ^8.5@11.0! ! 406080 406081!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'! 406082paperSizeNote 406083 ^8.5@11.0! ! 406084 406085!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:30'! 406086paperSizeTabloid 406087 ^11.0@17.0! ! 406088Requestor subclass: #TextRequestor 406089 instanceVariableNames: 'model' 406090 classVariableNames: '' 406091 poolDictionaries: '' 406092 category: 'Services-Base-Requestors'! 406093!TextRequestor commentStamp: 'rr 7/10/2006 15:20' prior: 0! 406094A requestor for text areas, able for example to fetch the current selected text.! 406095 406096 406097!TextRequestor methodsFor: 'accessing' stamp: 'rr 8/27/2005 15:42'! 406098model: aModel 406099 model := WeakArray with: aModel! ! 406100 406101 406102!TextRequestor methodsFor: 'request' stamp: 'rr 8/27/2005 15:42'! 406103getCurrentText 406104 "returns the unnacepted text in the text morph" 406105 ^ self getModel codeTextMorph text! ! 406106 406107!TextRequestor methodsFor: 'request' stamp: 'rr 8/27/2005 15:42'! 406108getModel 406109 ^ model first! ! 406110 406111"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 406112 406113TextRequestor class 406114 instanceVariableNames: ''! 406115WriteStream subclass: #TextStream 406116 instanceVariableNames: '' 406117 classVariableNames: '' 406118 poolDictionaries: '' 406119 category: 'Collections-Streams'! 406120 406121!TextStream methodsFor: 'as yet unclassified'! 406122applyAttribute: att beginningAt: startPos 406123 collection addAttribute: att from: startPos to: self position! ! 406124 406125!TextStream methodsFor: 'as yet unclassified' stamp: 'dvf 10/1/2003 02:51'! 406126nextPutAll: aCollection 406127 "Optimized access to get around Text at:Put: overhead" 406128 | n | 406129 n := aCollection size. 406130 position + n > writeLimit 406131 ifTrue: 406132 [self growTo: position + n + 10]. 406133 collection 406134 replaceFrom: position+1 406135 to: position + n 406136 with: aCollection 406137 startingAt: 1. 406138 position := position + n! ! 406139 406140!TextStream methodsFor: 'as yet unclassified'! 406141withAttribute: att do: strmBlock 406142 | pos1 val | 406143 pos1 := self position. 406144 val := strmBlock value. 406145 collection addAttribute: att from: pos1+1 to: self position. 406146 ^ val! ! 406147 406148!TextStream methodsFor: 'as yet unclassified' stamp: 'djp 11/6/1999 20:30'! 406149withAttributes: attributes do: streamBlock 406150 | pos1 val | 406151 pos1 := self position. 406152 val := streamBlock value. 406153 attributes do: [:attribute | 406154 collection 406155 addAttribute: attribute 406156 from: pos1 + 1 406157 to: self position]. 406158 ^ val! ! 406159WidgetStub subclass: #TextStub 406160 instanceVariableNames: 'text' 406161 classVariableNames: '' 406162 poolDictionaries: '' 406163 category: 'ToolBuilder-SUnit'! 406164 406165!TextStub methodsFor: 'events' stamp: 'cwp 5/30/2005 23:11'! 406166eventAccessors 406167 ^ #(setText selection menu color)! ! 406168 406169!TextStub methodsFor: 'events' stamp: 'cwp 5/30/2005 23:10'! 406170refresh 406171 self refreshText! ! 406172 406173!TextStub methodsFor: 'events' stamp: 'stephaneducasse 2/3/2006 22:32'! 406174refreshText 406175 text := self model perform: spec getText! ! 406176 406177!TextStub methodsFor: 'events' stamp: 'cwp 5/30/2005 23:11'! 406178update: aSymbol 406179 aSymbol = spec getText ifTrue: [^ self refreshText]. 406180 super update: aSymbol! ! 406181 406182 406183!TextStub methodsFor: 'simulating' stamp: 'cwp 4/22/2005 22:49'! 406184accept: aString 406185 ^ self model perform: spec setText with: aString asText! ! 406186 406187!TextStub methodsFor: 'simulating' stamp: 'cwp 4/22/2005 22:43'! 406188color 406189 ^ self model perform: spec color! ! 406190 406191!TextStub methodsFor: 'simulating' stamp: 'cwp 5/30/2005 23:11'! 406192text 406193 ^ text! ! 406194Object subclass: #TextStyle 406195 instanceVariableNames: 'fontArray fontFamilySize lineGrid baseline alignment firstIndent restIndent rightIndent tabsArray marginTabsArray leading defaultFontIndex' 406196 classVariableNames: '' 406197 poolDictionaries: 'TextConstants' 406198 category: 'Graphics-Text'! 406199!TextStyle commentStamp: '<historical>' prior: 0! 406200A textStyle comprises the formatting information for composing and displaying a unit (usually a paragraph) of text. Typically one makes a copy of a master textStyle (such as TextStyle default), and then that copy may get altered in the process of editing. Bad things can happen if you do not copy first. 406201 406202Each of my instances consists of... 406203 fontArray An array of StrikeFonts 406204 fontFamilySize unused 406205 lineGrid An integer; default line spacing for paragraphs 406206 baseline An integer; default baseline (dist from line top to bottom of an 'a') 406207 alignment An integer; text alignment, see TextStyle alignment: 406208 firstIndent An integer; indent of first line in pixels 406209 restIndent An integer; indent of remaining lines in pixels 406210 rightIndent An integer; indent of right margin rel to section 406211 tabsArray An array of integers giving tab offsets in pixels 406212 marginTabsArray An array of margin tabs 406213 leading An integer giving default vertical line separation 406214 406215For a concrete example, look at TextStyle default copy inspect! 406216 406217 406218!TextStyle methodsFor: '*FreeType-override' stamp: 'tween 4/23/2006 22:46'! 406219addNewFontSize: pointSize 406220 "Add a font in specified size to the array of fonts." 406221 | f d newArray t isSet | 406222 fontArray first emphasis ~= 0 ifTrue: [ 406223 t := TextConstants at: self fontArray first familyName asSymbol. 406224 t fonts first emphasis = 0 ifTrue: [ 406225 ^ t addNewFontSize: pointSize. 406226 ]. 406227 ]. 406228 406229 pointSize <= 0 ifTrue: [^ nil]. 406230 fontArray do: [:s | 406231 s pointSize = pointSize ifTrue: [^ s]. 406232 ]. 406233 406234 (isSet := fontArray first isKindOf: TTCFontSet) 406235 ifTrue:[ 406236 | fonts | 406237 fonts := fontArray first fontArray collect: [ :font | 406238 | newFont | 406239 (font isNil) 406240 ifTrue: [newFont := nil] 406241 ifFalse: [ 406242 newFont := (font ttcDescription size > 256) 406243 ifTrue: [MultiTTCFont new initialize] 406244 ifFalse: [TTCFont new initialize]. 406245 newFont ttcDescription: font ttcDescription. 406246 newFont pixelSize: pointSize * 96 // 72. 406247 font derivativeFonts notEmpty ifTrue: [font derivativeFonts do: [ :proto | 406248 proto ifNotNil: [ 406249 d := proto class new initialize. 406250 d ttcDescription: proto ttcDescription. 406251 d pixelSize: newFont pixelSize. 406252 newFont derivativeFont: d]]]. 406253 ]. 406254 newFont]. 406255 f := TTCFontSet newFontArray: fonts] 406256 ifFalse: [ 406257 f := fontArray first class new initialize: fontArray first. 406258 f pointSize: pointSize. 406259 fontArray first derivativeFonts do: [:proto | 406260 proto ifNotNil: [ 406261 d := proto class new initialize: proto. 406262 d pointSize: f pointSize. 406263 f derivativeFont: d mainFont: proto. 406264 ]. 406265 ]. 406266 ]. 406267 newArray := ((fontArray copyWith: f) asSortedCollection: [:a :b | a pointSize <= b pointSize]) asArray. 406268 self newFontArray: newArray. 406269 isSet ifTrue: [ 406270 TTCFontSet register: newArray at: newArray first familyName asSymbol. 406271 ]. 406272 ^ self fontOfPointSize: pointSize 406273! ! 406274 406275 406276!TextStyle methodsFor: 'accessing'! 406277alignment 406278 "Answer the code for the current setting of the alignment." 406279 406280 ^alignment! ! 406281 406282!TextStyle methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 406283alignment: anInteger 406284 "Set the current setting of the alignment to be anInteger: 406285 0=left flush, 1=right flush, 2=centered, 3=justified." 406286 alignment := anInteger \\ (Justified + 1)! ! 406287 406288!TextStyle methodsFor: 'accessing' stamp: 'ar 9/21/2000 15:16'! 406289alignmentSymbol 406290 "Answer the symbol for the current setting of the alignment." 406291 alignment = LeftFlush ifTrue:[^#leftFlush]. 406292 alignment = Centered ifTrue:[^#centered]. 406293 alignment = RightFlush ifTrue:[^#rightFlush]. 406294 alignment = Justified ifTrue:[^#justified]. 406295 ^#leftFlush! ! 406296 406297!TextStyle methodsFor: 'accessing'! 406298baseline 406299 "Answer the distance from the top of the line to the bottom of most of the 406300 characters (by convention, bottom of the letter 'A')." 406301 406302 ^baseline! ! 406303 406304!TextStyle methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 406305baseline: anInteger 406306 "Set the distance from the top of the line to the bottom of most of the 406307 characters." 406308 baseline := anInteger! ! 406309 406310!TextStyle methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 406311centered 406312 alignment := 2! ! 406313 406314!TextStyle methodsFor: 'accessing' stamp: 'sw 12/6/1999 12:31'! 406315defaultFont 406316 ^ fontArray at: self defaultFontIndex! ! 406317 406318!TextStyle methodsFor: 'accessing'! 406319firstIndent 406320 "Answer the horizontal indenting of the first line of a paragraph in the 406321 style of the receiver." 406322 406323 ^firstIndent! ! 406324 406325!TextStyle methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 406326firstIndent: anInteger 406327 "Set the horizontal indenting of the first line of a paragraph in the style 406328 of the receiver to be the argument, anInteger." 406329 firstIndent := anInteger! ! 406330 406331!TextStyle methodsFor: 'accessing'! 406332fontNamed: fontName "TextStyle default fontNamed: 'TimesRoman10'" 406333 ^ fontArray detect: [:x | x name sameAs: fontName]! ! 406334 406335!TextStyle methodsFor: 'accessing'! 406336fontNames "TextStyle default fontNames" 406337 ^ fontArray collect: [:x | x name]! ! 406338 406339!TextStyle methodsFor: 'accessing' stamp: 'tk 6/26/1998 15:03'! 406340fontNamesAndSizes "TextStyle default fontNames" 406341 ^ fontArray collect: [:x | x name, ' ', x height printString]! ! 406342 406343!TextStyle methodsFor: 'accessing' stamp: 'ar 9/21/2000 11:53'! 406344fontNamesWithPointSizes 406345 ^ fontArray collect: 406346 [:x | x fontNameWithPointSize] 406347 406348 "TextStyle default fontNamesWithPointSizes"! ! 406349 406350!TextStyle methodsFor: 'accessing' stamp: 'ar 12/16/2001 16:58'! 406351fonts 406352 "Return a collection of fonts contained in this text style" 406353 ^fontArray! ! 406354 406355!TextStyle methodsFor: 'accessing' stamp: 'nk 6/25/2003 12:54'! 406356isTTCStyle 406357 406358 ^ fontArray first isTTCFont. 406359! ! 406360 406361!TextStyle methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 406362justified 406363 alignment := 3! ! 406364 406365!TextStyle methodsFor: 'accessing'! 406366leading 406367 "Leading (from typographers historical use of extra lead (type metal)) 406368 is the extra spacing above and beyond that needed just to accomodate 406369 the various font heights in the set." 406370 ^ leading! ! 406371 406372!TextStyle methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 406373leading: yDelta 406374 leading := yDelta! ! 406375 406376!TextStyle methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 406377leftFlush 406378 alignment := 0! ! 406379 406380!TextStyle methodsFor: 'accessing'! 406381lineGrid 406382 "Answer the relative space between lines of a paragraph in the style of 406383 the receiver." 406384 406385 ^lineGrid! ! 406386 406387!TextStyle methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 406388lineGrid: anInteger 406389 "Set the relative space between lines of a paragraph in the style of the 406390 receiver to be the argument, anInteger." 406391 lineGrid := anInteger! ! 406392 406393!TextStyle methodsFor: 'accessing' stamp: 'ar 12/16/2001 16:43'! 406394pointSizes 406395 ^ fontArray collect: 406396 [:x | x pointSize] 406397 406398 "TextStyle default fontNamesWithPointSizes"! ! 406399 406400!TextStyle methodsFor: 'accessing' stamp: 'yo 5/24/2004 22:52'! 406401printOn: aStream 406402 406403 super printOn: aStream. 406404 (fontArray first isMemberOf: StrikeFontSet) ifTrue: [ 406405 aStream space; nextPutAll: self defaultFont familySizeFace first; nextPutAll: '(FontSet)' 406406 ] ifFalse: [ 406407 aStream space; nextPutAll: self defaultFont familySizeFace first 406408 ] 406409! ! 406410 406411!TextStyle methodsFor: 'accessing'! 406412restIndent 406413 "Answer the indent for all but the first line of a paragraph in the style 406414 of the receiver." 406415 406416 ^restIndent! ! 406417 406418!TextStyle methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 406419restIndent: anInteger 406420 "Set the indent for all but the first line of a paragraph in the style of the 406421 receiver to be the argument, anInteger." 406422 restIndent := anInteger! ! 406423 406424!TextStyle methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 406425rightFlush 406426 alignment := 1! ! 406427 406428!TextStyle methodsFor: 'accessing'! 406429rightIndent 406430 "Answer the right margin indent for the lines of a paragraph in the style 406431 of the receiver." 406432 406433 ^rightIndent! ! 406434 406435!TextStyle methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! 406436rightIndent: anInteger 406437 "Answer the right margin indent for the lines of a paragraph in the style 406438 of the receiver to be the argument, anInteger." 406439 rightIndent := anInteger! ! 406440 406441 406442!TextStyle methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:18'! 406443= other 406444 406445 self species == other species ifFalse: [^ false]. 406446 1 to: self class instSize do: 406447 [:i | (self instVarAt: i) == (other instVarAt: i) ifFalse: [^ false]]. 406448 ^ true! ! 406449 406450!TextStyle methodsFor: 'comparing' stamp: 'ar 9/9/2003 22:04'! 406451hash 406452 "#hash is re-implemented because #= is re-implemented" 406453 ^fontArray hash 406454! ! 406455 406456!TextStyle methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:18'! 406457species 406458 406459 ^TextStyle! ! 406460 406461 406462!TextStyle methodsFor: 'default font' stamp: 'lr 7/4/2009 10:42'! 406463defaultFontIndex 406464 ^ defaultFontIndex ifNil: [ defaultFontIndex := 1 ]! ! 406465 406466!TextStyle methodsFor: 'default font' stamp: 'lr 7/4/2009 10:42'! 406467defaultFontIndex: anIndex 406468 defaultFontIndex := anIndex! ! 406469 406470 406471!TextStyle methodsFor: 'disk i/o' stamp: 'tk 9/25/2000 10:10'! 406472storeDataOn: aDataStream 406473 "The shared arrays in tabsArray and marginTabsArray are the globals DefaultTabsArray and DefaultMarginTabsArray. DiskProxies will be substituted for these in (Array objectForDataStream:)." 406474 406475 ^ super storeDataOn: aDataStream! ! 406476 406477!TextStyle methodsFor: 'disk i/o' stamp: 'di 11/19/1999 20:12'! 406478veryDeepCopyWith: deepCopier 406479 "All inst vars are meant to be shared" 406480 406481 self == #veryDeepCopyWith:. "to satisfy checkVariables" 406482 ^ deepCopier references at: self ifAbsent: [ 406483 deepCopier references at: self put: self clone]. "remember"! ! 406484 406485 406486!TextStyle methodsFor: 'fonts and font indexes' stamp: 'yo 5/7/2004 11:18'! 406487addLinedIfTT 406488 406489 (fontArray first isKindOf: TTCFont) ifFalse: [^ self]. 406490 406491 fontArray do: [:f | 406492 f addLined. 406493 ]. 406494! ! 406495 406496!TextStyle methodsFor: 'fonts and font indexes' stamp: 'DamienCassou 9/29/2009 13:14'! 406497addNewFontSizeDialog: args 406498 "This is called from a modal menu and call back the menu with entered argument." 406499 | f n r | 406500 f := UIManager default request: 'Enter the point size' initialAnswer: '12'. 406501 f ifNil: [f := String new]. 406502 n := f asNumber. 406503 r := self addNewFontSize: n. 406504 r ifNotNil: [ 406505 args second ifNotNil: [args second modalSelection: {args first. n}]. 406506 ]. 406507! ! 406508 406509!TextStyle methodsFor: 'fonts and font indexes' stamp: 'lr 7/4/2009 10:42'! 406510collectionFromFileNamed: fileName 406511 "Read the file. It is an TextStyle whose StrikeFonts are to be added to the system. (Written by fooling SmartRefStream, so it won't write a DiskProxy!!) These fonts will be added to the master TextSytle for this font family. 406512 To write out fonts: 406513 | ff | ff _ ReferenceStream fileNamed: 'new fonts'. 406514 TextConstants at: #forceFontWriting put: true. 406515 ff nextPut: (TextConstants at: #AFontName). 406516 'do not mix font families in the TextStyle written out'. 406517 TextConstants at: #forceFontWriting put: false. 406518 ff close. 406519 406520 To read: (TextStyle default collectionFromFileNamed: 'new fonts') 406521*** Do not remove this method *** " 406522 | ff this newName style heights | 406523 ff := ReferenceStream fileNamed: fileName. 406524 this := ff nextAndClose. "Only works if file created by special code above" 406525 newName := this fontArray first familyName. 406526 this fontArray do: 406527 [ :aFont | 406528 aFont familyName = newName ifFalse: [ self error: 'All must be same family' ] ]. 406529 style := TextConstants 406530 at: newName asSymbol 406531 ifAbsent: 406532 [ ^ TextConstants 406533 at: newName asSymbol 406534 put: this ]. "new family" 406535 this fontArray do: 406536 [ :aFont | 406537 "add new fonts" 406538 heights := style fontArray collect: [ :bFont | bFont height ]. 406539 (heights includes: aFont height) ifFalse: 406540 [ style 406541 fontAt: style fontArray size + 1 406542 put: aFont ] ]! ! 406543 406544!TextStyle methodsFor: 'fonts and font indexes' stamp: 'lr 7/4/2009 10:42'! 406545consistOnlyOf: aFont 406546 fontArray := Array with: aFont. 406547 defaultFontIndex := 1! ! 406548 406549!TextStyle methodsFor: 'fonts and font indexes' stamp: 'lr 7/4/2009 10:42'! 406550discardOtherSizes 406551 "This method trys to discard the fonts in non-standard size. If the size is still in use, there will be a problem." 406552 | newArray | 406553 self isTTCStyle ifFalse: [ ^ self ]. 406554 newArray := fontArray select: [ :s | TTCFont pointSizes includes: s pointSize ]. 406555 self newFontArray: newArray 406556 406557 "(TextConstants at: #ComicSansMS) discardOtherSizes"! ! 406558 406559!TextStyle methodsFor: 'fonts and font indexes'! 406560flushFonts 406561 "Clean out the fonts, an aid when snapshotting claims too many are 406562 holding onto Display." 406563 406564 (self confirm: 406565'flushFonts is very dangerous. 406566Are you foolish or clever enough to proceed?') 406567 ifTrue: [1 to: fontArray size do: [:index | fontArray at: index put: nil]] 406568 ifFalse: [Transcript cr; show: 'flushFonts cancelled'] 406569 406570 "TextStyle default flushFonts"! ! 406571 406572!TextStyle methodsFor: 'fonts and font indexes' stamp: 'sw 12/6/1999 13:54'! 406573fontIndexOf: aFont 406574 ^ fontArray indexOf: aFont ifAbsent: [nil]! ! 406575 406576!TextStyle methodsFor: 'fonts and font indexes' stamp: 'lr 7/4/2009 10:42'! 406577fontIndexOfPointSize: desiredPointSize 406578 "Returns an index in fontArray of the font with pointSize <= desiredPointSize" 406579 "Leading is not inluded in the comparison" 406580 | bestMatch bestIndex d | 406581 bestMatch := 9999. 406582 bestIndex := 1. 406583 1 406584 to: fontArray size 406585 do: 406586 [ :i | 406587 d := desiredPointSize - (fontArray at: i) pointSize. 406588 d = 0 ifTrue: [ ^ i ]. 406589 (d > 0 and: [ d < bestMatch ]) ifTrue: 406590 [ bestIndex := i. 406591 bestMatch := d ] ]. 406592 ^ bestIndex! ! 406593 406594!TextStyle methodsFor: 'fonts and font indexes' stamp: 'lr 7/4/2009 10:42'! 406595fontIndexOfSize: desiredHeight 406596 "Returns an index in fontArray of the font with height <= desiredHeight" 406597 "Leading is not inluded in the comparison" 406598 | bestMatch bestIndex d | 406599 bestMatch := 9999. 406600 bestIndex := 1. 406601 1 406602 to: fontArray size 406603 do: 406604 [ :i | 406605 d := desiredHeight - (fontArray at: i) height. 406606 d = 0 ifTrue: [ ^ i ]. 406607 (d > 0 and: [ d < bestMatch ]) ifTrue: 406608 [ bestIndex := i. 406609 bestMatch := d ] ]. 406610 ^ bestIndex! ! 406611 406612!TextStyle methodsFor: 'fonts and font indexes' stamp: 'nk 6/12/2004 16:33'! 406613fontOfPointSize: aPointSize 406614 ^ fontArray at: (self fontIndexOfPointSize: aPointSize)! ! 406615 406616!TextStyle methodsFor: 'fonts and font indexes' stamp: 'di 10/11/97 09:33'! 406617fontOfSize: aHeight 406618 "See fontIndexOfSize. 406619 Returns the actual font. Leading not considered." 406620 406621 ^ fontArray at: (self fontIndexOfSize: aHeight)! ! 406622 406623 406624!TextStyle methodsFor: 'make arrows' stamp: 'sps 10/15/2003 17:09'! 406625makeArrows 406626" 406627TextStyle default makeArrows. 406628" 406629 fontArray do: [ :font | 406630 (font isKindOf: StrikeFont) ifTrue:[ 406631 font 406632 makeAssignArrow; 406633 makeReturnArrow. 406634 ] 406635 ]. 406636! ! 406637 406638 406639!TextStyle methodsFor: 'mime file in/out' stamp: 'nk 8/31/2004 09:23'! 406640compressedMIMEEncodedStream 406641 "Answer a ReadWriteStream with my compressed, stored representation as Base64" 406642 406643 | s ff ffcontents s2 gzs | 406644 self fontArray do: [:f | f releaseCachedState]. 406645 s := RWBinaryOrTextStream on: ''. 406646 ff := SmartRefStream on: s reset. 406647 TextConstants at: #forceFontWriting put: true. 406648 [ff nextPut: self] 406649 ensure: [TextConstants at: #forceFontWriting put: false]. 406650 ffcontents := s contents. 406651 ff close. 406652 s2 := RWBinaryOrTextStream on: ''. 406653 gzs := GZipWriteStream on: s2. 406654 gzs nextPutAll: ffcontents. 406655 gzs close. 406656 s2 reset. 406657 s := RWBinaryOrTextStream on: (ByteArray new: 10000). 406658 Base64MimeConverter mimeEncode: s2 to: s. 406659 ^s 406660 ascii; 406661 reset; 406662 yourself! ! 406663 406664 406665!TextStyle methodsFor: 'tabs and margins'! 406666clearIndents 406667 "Reset all the margin (index) settings to be 0." 406668 406669 self firstIndent: 0. 406670 self restIndent: 0. 406671 self rightIndent: 0! ! 406672 406673!TextStyle methodsFor: 'tabs and margins'! 406674leftMarginTabAt: marginIndex 406675 "Set the 'nesting' level of left margin indents of the paragraph in the 406676 style of the receiver to be the argument, marginIndex." 406677 406678 (marginIndex > 0 and: [marginIndex < marginTabsArray size]) 406679 ifTrue: [^(marginTabsArray at: marginIndex) at: 1] 406680 ifFalse: [^0] 406681 "The marginTabsArray is an Array of tuples. The Array is indexed according 406682 to the marginIndex, the 'nesting' level of the requestor." 406683! ! 406684 406685!TextStyle methodsFor: 'tabs and margins' stamp: 'lr 7/4/2009 10:42'! 406686nextTabXFrom: anX leftMargin: leftMargin rightMargin: rightMargin 406687 "Tab stops are distances from the left margin. Set the distance into the 406688 argument, anX, normalized for the paragraph's left margin." 406689 | normalizedX tabX | 406690 normalizedX := anX - leftMargin. 406691 1 406692 to: tabsArray size 406693 do: 406694 [ :i | 406695 (tabX := tabsArray at: i) > normalizedX ifTrue: [ ^ leftMargin + tabX min: rightMargin ] ]. 406696 ^ rightMargin! ! 406697 406698!TextStyle methodsFor: 'tabs and margins'! 406699rightMarginTabAt: marginIndex 406700 "Set the 'nesting' level of right margin indents of the paragraph in the 406701 style of the receiver to be marginIndex." 406702 406703 (marginIndex > 0 and: [marginIndex < marginTabsArray size]) 406704 ifTrue: [^(marginTabsArray at: marginIndex) at: 2] 406705 ifFalse: [^0] 406706 "The marginTabsArray is an Array of tuples. The Array is indexed according 406707 to the marginIndex, the 'nesting' level of the requestor." 406708! ! 406709 406710!TextStyle methodsFor: 'tabs and margins'! 406711tabWidth 406712 "Answer the width of a tab." 406713 406714 ^DefaultTab! ! 406715 406716 406717!TextStyle methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 406718consolidate 406719 "If this style includes any fonts that are also in the default style, 406720 then replace them with references to the default ones." 406721 " 406722 TextStyle allInstancesDo: [:s | s == TextStyle default ifFalse: [s consolidate]] 406723" 406724 | defFonts font | 406725 defFonts := TextStyle default fontArray. 406726 1 406727 to: fontArray size 406728 do: 406729 [ :i | 406730 font := fontArray at: i. 406731 1 406732 to: defFonts size 406733 do: 406734 [ :j | 406735 (font name asUppercase copyWithout: $ ) = ((defFonts at: j) name asUppercase copyWithout: $ ) ifTrue: 406736 [ fontArray 406737 at: i 406738 put: (defFonts at: j) ] ] ]! ! 406739 406740!TextStyle methodsFor: 'private'! 406741fontArray 406742 "Only for writing out fonts, etc. 8/16/96 tk" 406743 ^ fontArray! ! 406744 406745!TextStyle methodsFor: 'private' stamp: 'di 3/20/1999 22:31'! 406746fontAt: index 406747 "This is private because no object outside TextStyle should depend on the 406748 representation of the font family in fontArray." 406749 406750 ^ fontArray atPin: index! ! 406751 406752!TextStyle methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 406753fontAt: index put: font 406754 "Automatically grow the array. 8/20/96 tk" 406755 index > fontArray size ifTrue: [ fontArray := fontArray , (Array new: index - fontArray size) ]. 406756 fontArray 406757 at: index 406758 put: font! ! 406759 406760!TextStyle methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 406761gridForFont: fontIndex withLead: leadInteger 406762 "Force whole style to suit one of its fonts. Assumes only one font referred 406763 to by runs." 406764 | font | 406765 font := self fontAt: fontIndex. 406766 self lineGrid: font height + leadInteger. 406767 self baseline: font ascent. 406768 self leading: leadInteger! ! 406769 406770!TextStyle methodsFor: 'private'! 406771marginTabAt: marginIndex side: sideIndex 406772 "The marginTabsArray is an Array of tuples. The Array is indexed 406773 according to the marginIndex, the 'nesting' level of the requestor. 406774 sideIndex is 1 for left, 2 for right." 406775 406776 (marginIndex > 0 and: [marginIndex < marginTabsArray size]) 406777 ifTrue: [^(marginTabsArray at: marginIndex) at: sideIndex] 406778 ifFalse: [^0]! ! 406779 406780!TextStyle methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 406781newFontArray: anArray 406782 "Currently there is no supporting protocol for changing these arrays. If an editor wishes to implement margin setting, then a copy of the default should be stored with these instance variables. 406783 , Make size depend on first font." 406784 fontArray := anArray. 406785 lineGrid := (fontArray at: 1) height + leading. "For whole family" 406786 baseline := (fontArray at: 1) ascent + leading. 406787 alignment := 0. 406788 firstIndent := 0. 406789 restIndent := 0. 406790 rightIndent := 0. 406791 tabsArray := DefaultTabsArray. 406792 marginTabsArray := DefaultMarginTabsArray 406793 " 406794TextStyle allInstancesDo: [:ts | ts newFontArray: TextStyle default fontArray]. 406795"! ! 406796 406797"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 406798 406799TextStyle class 406800 instanceVariableNames: ''! 406801 406802!TextStyle class methodsFor: '*FreeType-override' stamp: 'tween 8/10/2006 07:16'! 406803emphasisMenuForFont: font target: target selector: selector highlight: currentEmphasis 406804 "Offer a font emphasis menu for the given style. If one is selected, pass that font to target with a call to selector. The fonts will be displayed in that font. 406805 Answer nil if no derivatives exist. 406806 " 406807 406808 | aMenu derivs | 406809 derivs := font derivativeFonts. 406810 derivs isEmpty ifTrue: [ ^nil ]. 406811 aMenu := MenuMorph entitled: 'emphasis' translated. 406812 derivs := derivs asOrderedCollection. 406813 derivs addFirst: font. 406814 derivs do: [ :df | 406815 aMenu 406816 add: df emphasisString 406817 target: target 406818 selector: selector 406819 argument: df. 406820 aMenu lastItem font: df. 406821 df emphasis == currentEmphasis ifTrue: [aMenu lastItem color: Color blue darker]]. 406822 ^ aMenu! ! 406823 406824!TextStyle class methodsFor: '*FreeType-override' stamp: 'tween 3/29/2007 13:49'! 406825fontMenuForStyle: styleName target: target selector: selector highlight: currentFont 406826 "Offer a font menu for the given style. If one is selected, pass 406827 that font to target with a 406828 call to selector. The fonts will be displayed in that font." 406829 | aMenu displayFont | 406830 aMenu := MenuMorph entitled: styleName. 406831 (TextStyle named: styleName) 406832 ifNotNilDo: [:s | s isTTCStyle 406833 ifTrue: [aMenu 406834 add: 'New Size' 406835 target: self 406836 selector: #chooseTTCFontSize: 406837 argument: {styleName. target. selector}]]. 406838 (self pointSizesFor: styleName) 406839 do: [:pointSize | 406840 | font subMenu | 406841 font := (self named: styleName) 406842 fontOfPointSize: pointSize. 406843 subMenu := self 406844 emphasisMenuForFont: font 406845 target: target 406846 selector: selector 406847 highlight: (currentFont 406848 ifNotNilDo: [:cf | (cf familyName = styleName 406849 and: [cf pointSize = font pointSize]) 406850 ifTrue: [currentFont emphasis]]). 406851 subMenu 406852 ifNil: [aMenu 406853 add: pointSize asString , ' Point' 406854 target: target 406855 selector: selector 406856 argument: font] 406857 ifNotNil: [aMenu add: pointSize asString , ' Point' subMenu: subMenu]. 406858 displayFont := font. 406859 (font isSymbolFont or:[(font hasDistinctGlyphsForAll: pointSize asString , ' Point') not]) 406860 ifTrue:[ 406861 "don't use a symbol font to display its own name!!!!" 406862 displayFont := self default fontOfPointSize: pointSize]. 406863 aMenu lastItem font: displayFont. 406864 currentFont 406865 ifNotNilDo: [:cf | (cf familyName = styleName 406866 and: [cf pointSize = font pointSize]) 406867 ifTrue: [aMenu lastItem color: Color blue darker]]]. 406868 ^ aMenu! ! 406869 406870!TextStyle class methodsFor: '*FreeType-override' stamp: 'nk 9/1/2004 13:19'! 406871promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector highlight: currentFont 406872 "Morphic Only!! prompt for a font and if one is provided, send it to aTarget using a 406873 message with selector aSelector." 406874 "TextStyle promptForFont: 'Choose system font:' andSendTo: Preferences withSelector: 406875 #setSystemFontTo: " 406876 "Derived from a method written by Robin Gibson" 406877 | menu subMenu currentTextStyle | 406878 currentTextStyle := currentFont 406879 ifNotNil: [currentFont textStyleName]. 406880 menu := MenuMorph entitled: aPrompt. 406881 self actualTextStyles keysSortedSafely 406882 do: [:styleName | 406883 subMenu := self 406884 fontMenuForStyle: styleName 406885 target: aTarget 406886 selector: aSelector 406887 highlight: currentFont. 406888 menu add: styleName subMenu: subMenu. 406889 menu lastItem 406890 font: ((self named: styleName) 406891 fontOfSize: 18). 406892 styleName = currentTextStyle 406893 ifTrue: [menu lastItem color: Color blue darker]]. 406894 menu popUpInWorld: self currentWorld! ! 406895 406896 406897!TextStyle class methodsFor: 'constants'! 406898default 406899 "Answer the system default text style." 406900 406901 ^DefaultTextStyle! ! 406902 406903!TextStyle class methodsFor: 'constants' stamp: 'sw 12/6/1999 12:32'! 406904defaultFont 406905 "Answer the default system font" 406906 406907 ^ DefaultTextStyle defaultFont! ! 406908 406909!TextStyle class methodsFor: 'constants' stamp: 'lr 7/4/2009 10:42'! 406910named: familyName 406911 "Answer the TextStyle with the given name, or nil." 406912 "TextStyle named: 'NewYork'" 406913 | textStyle | 406914 textStyle := TextConstants 406915 at: familyName 406916 ifAbsent: [ ^ nil ]. 406917 (textStyle isKindOf: self) ifFalse: [ ^ nil ]. 406918 ^ textStyle! ! 406919 406920!TextStyle class methodsFor: 'constants' stamp: 'ar 1/27/2002 20:36'! 406921setDefault: aTextStyle 406922 "Answer the system default text style." 406923 406924 DefaultTextStyle := aTextStyle.! ! 406925 406926 406927!TextStyle class methodsFor: 'initialization' stamp: 'nk 3/25/2004 17:51'! 406928initialize 406929 self initializeStyleDecoder.! ! 406930 406931!TextStyle class methodsFor: 'initialization' stamp: 'nk 3/25/2004 17:53'! 406932initializeStyleDecoder 406933 TextConstants at: #StyleDecoder put: nil. 406934 self styleDecoder.! ! 406935 406936!TextStyle class methodsFor: 'initialization' stamp: 'nk 3/25/2004 17:57'! 406937styleDecoder 406938 TextConstants at: #StyleDecoder ifPresent: [ :dict | dict ifNotNil: [ ^dict ]]. 406939 ^TextConstants at: #StyleDecoder put: ( 406940 Dictionary new at: 'Regular' put: 0; 406941 at: 'Roman' put: 0; 406942 at: 'Medium' put: 0; 406943 at: 'Light' put: 0; 406944 at: 'Normal' put: 0; 406945 at: 'Plain' put: 0; 406946 at: 'Book' put: 0; 406947 at: 'Demi' put: 0; 406948 at: 'Demibold' put: 0; 406949 at: 'Semibold' put: 0; 406950 at: 'SemiBold' put: 0; 406951 at: 'ExtraBold' put: 1; 406952 at: 'SuperBold' put: 1; 406953 at: 'B' put: 1; 406954 at: 'I' put: 2; 406955 at: 'U' put: 4; 406956 at: 'X' put: 16; 406957 at: 'N' put: 8; 406958 at: 'Bold' put: 1; 406959 at: 'Italic' put: 2; 406960 at: 'Oblique' put: 2; 406961 at: 'Narrow' put: 8; 406962 at: 'Condensed' put: 8; 406963 at: 'Underlined' put: 4; 406964 yourself )! ! 406965 406966 406967!TextStyle class methodsFor: 'instance creation'! 406968fontArray: anArray 406969 "Answer an instance of me with fonts those in the argument, anArray." 406970 406971 ^self new newFontArray: anArray! ! 406972 406973!TextStyle class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 406974initDefaultFontsAndStyle 406975 "This provides the system with 10 and 12-pt basal fonts. 406976 Bold and italic versions will be automatically generated as needed" 406977 | fontArray | 406978 fontArray := Array new: 2. 406979 fontArray 406980 at: 1 406981 put: (StrikeFont new readFromStrike2: 'NewYork10.sf2'). 406982 fontArray 406983 at: 2 406984 put: (StrikeFont new readFromStrike2: 'NewYork12.sf2'). 406985 TextConstants 406986 at: #DefaultTextStyle 406987 put: (TextStyle fontArray: fontArray) 406988 406989 "TextStyle initDefaultFontsAndStyle."! ! 406990 406991!TextStyle class methodsFor: 'instance creation'! 406992new 406993 ^ super new leading: 2! ! 406994 406995 406996!TextStyle class methodsFor: 'mime file in/out' stamp: 'lr 7/4/2009 10:42'! 406997collectionFromCompressedMIMEString: aString 406998 "aString holds a compressed, Base64 representation of a SmartRefStream storage of a TextStyle. 406999 Install the TextStyle." 407000 | this newName style heights data | 407001 data := (Base64MimeConverter 407002 mimeDecode: aString 407003 as: String) unzipped. 407004 (RWBinaryOrTextStream with: data) 407005 reset; 407006 fileIn. 407007 this := SmartRefStream scannedObject. 407008 407009 "now install it" 407010 newName := this fontArray first familyName. 407011 this fontArray do: 407012 [ :aFont | 407013 aFont familyName = newName ifFalse: [ self error: 'All must be same family' ] ]. 407014 style := TextConstants 407015 at: newName asSymbol 407016 ifAbsent: 407017 [ ^ TextConstants 407018 at: newName asSymbol 407019 put: this ]. "new family" 407020 this fontArray do: 407021 [ :aFont | 407022 "add new fonts" 407023 heights := style fontArray collect: [ :bFont | bFont height ]. 407024 (heights includes: aFont height) ifFalse: 407025 [ style 407026 fontAt: style fontArray size + 1 407027 put: aFont ] ]! ! 407028 407029!TextStyle class methodsFor: 'mime file in/out' stamp: 'lr 7/4/2009 10:42'! 407030looseFontsFromFamily: familyName 407031 " 407032 TextStyle looseFontsFromFamily: 'Accuny' 407033 TextStyle looseFontsFromFamily: 'Accujen' 407034 TextStyle actualTextStyles keys collect: [ :k | TextStyle looseFontsFromFamily: k ] 407035 " 407036 | looseFonts realStyle classes | 407037 realStyle := TextStyle named: familyName. 407038 classes := ((realStyle fontArray copyWithout: nil) collect: [ :f | f class ]) asSet. 407039 classes do: [ :cls | cls allSubInstancesDo: [ :f | f releaseCachedState ] ]. 407040 Smalltalk garbageCollect. 407041 looseFonts := IdentitySet new. 407042 classes do: 407043 [ :cls | 407044 looseFonts addAll: ((cls allSubInstances select: [ :ea | ea familyName = familyName ]) reject: 407045 [ :f | 407046 realStyle fontArray anySatisfy: [ :fn | fn == f or: [ fn derivativeFonts includes: f ] ] ]) ]. 407047 ^ looseFonts! ! 407048 407049!TextStyle class methodsFor: 'mime file in/out' stamp: 'lr 7/4/2009 10:42'! 407050replaceFontsIn: oldFontArray with: newStyle 407051 " 407052 TextStyle replaceFontsIn: (TextStyle looseFontsFromFamily: #Accuny) with: (TextStyle named: #Accuny) 407053 " 407054 "Try to find corresponding fonts in newStyle and substitute them for the fonts in oldFontArray" 407055 newStyle fontArray do: [ :newFont | newFont releaseCachedState ]. 407056 oldFontArray do: 407057 [ :oldFont | 407058 | newFont | 407059 oldFont reset. 407060 newFont := (newStyle fontOfPointSize: oldFont pointSize) emphasis: oldFont emphasis. 407061 oldFont becomeForward: newFont ]. 407062 StringMorph allSubInstancesDo: [ :s | s layoutChanged ]. 407063 TextMorph allSubInstancesDo: [ :s | s layoutChanged ]. 407064 SystemWindow allInstancesDo: 407065 [ :w | 407066 [ w update: #relabel ] 407067 on: Error 407068 do: [ :ex | ] ]. 407069 World ifNotNil: [ :w | w changed ]! ! 407070 407071!TextStyle class methodsFor: 'mime file in/out' stamp: 'lr 7/4/2009 10:42'! 407072replaceStyle: oldStyle with: newStyle 407073 " 407074 TextStyle replaceStyle: (TextStyle named: #AccunyOLD) with: (TextStyle named: #Accuny) 407075 " 407076 "Try to find corresponding fonts in newStyle and substitute the fonts in oldStyle for them." 407077 | oldKeys | 407078 oldKeys := Set new. 407079 TextConstants keysAndValuesDo: [ :k :v | v = oldStyle ifTrue: [ oldKeys add: k ] ]. 407080 oldKeys removeAllFoundIn: self defaultFamilyNames. 407081 self 407082 replaceFontsIn: oldStyle fontArray 407083 with: newStyle. 407084 oldStyle becomeForward: newStyle. 407085 oldKeys do: [ :k | TextConstants removeKey: k ]! ! 407086 407087!TextStyle class methodsFor: 'mime file in/out' stamp: 'tpr 6/10/2005 18:29'! 407088writeSF2FamilyNamed: familyName inDirectory: directoryName toChangeSet: csName 407089 " 407090 TextStyle writeSF2FamilyNamed: 'Accuny' inDirectory: 'AccunyCorrectedFeb252004Beta Folder' toChangeSet: 'AccunyInstall'. 407091 " 407092 407093 | family | 407094 family := OrderedCollection new. 407095 family addAll: (StrikeFont readStrikeFont2Family: familyName fromDirectory: (FileDirectory default fullNameFor: directoryName)) . 407096 family do: [:f | f reset]. 407097 self 407098 writeStyle: (TextStyle fontArray: family asArray) 407099 named: familyName 407100 toChangeSet: csName! ! 407101 407102!TextStyle class methodsFor: 'mime file in/out' stamp: 'lr 7/4/2009 10:42'! 407103writeStyle: aTextStyle named: familyName toChangeSet: csName 407104 "Write the text style to a change set, with a postscript that will re-load it. 407105 NOTE: to do TTCFonts, you have to have a working ShortPointArray endianness conversion." 407106 " 407107 TTCFont recreateCache. 407108 TextStyle writeStyle: (TextStyle named: #Arial) named: 'Arial' toChangeSet: 'ArialInstall'. 407109 407110 TextStyle writeStyle: (TextStyle named: #Accuny) named: 'Accuny' toChangeSet: 'AccunyInstall2'. 407111 " 407112 | cs mimeStream | 407113 cs := ChangeSet basicNewNamed: csName. 407114 cs 407115 adoptSelector: #collectionFromCompressedMIMEString: 407116 forClass: self class. 407117 cs 407118 adoptSelector: #replaceStyle:with: 407119 forClass: self class. 407120 cs 407121 adoptSelector: #replaceFontsIn:with: 407122 forClass: self class. 407123 cs 407124 adoptSelector: #looseFontsFromFamily: 407125 forClass: self class. 407126 ((aTextStyle fontArray copyWithout: nil) collect: [ :f | f class ]) asSet do: 407127 [ :cls | 407128 cs 407129 adoptSelector: #derivativeFonts 407130 forClass: cls. 407131 cs 407132 adoptSelector: #releaseCachedState 407133 forClass: cls ]. 407134 cs preambleString: (String streamContents: 407135 [ :s | 407136 s 407137 nextPutAll: '"Change Set: '; 407138 nextPutAll: csName; 407139 cr; 407140 nextPutAll: 'Date: '; 407141 print: Date today; 407142 cr; 407143 nextPutAll: 'Author: '; 407144 nextPutAll: Author fullName; 407145 cr; 407146 cr; 407147 nextPutAll: 'Installs the text style '''; 407148 nextPutAll: familyName; 407149 nextPutAll: ''''; 407150 cr; 407151 nextPutAll: 'from a compressed MIME encoding in the postscript."'; 407152 cr ]). 407153 mimeStream := aTextStyle compressedMIMEEncodedStream. 407154 cs postscriptString: (String streamContents: 407155 [ :s | 407156 s 407157 nextPutAll: '"Postscript:'; 407158 cr; 407159 nextPutAll: 'Install the text style from the compressed MIME encoding, and replace the old one.'; 407160 nextPut: $"; 407161 cr; 407162 nextPutAll: 'TextConstants at: #'; 407163 nextPutAll: familyName; 407164 nextPutAll: ' ifPresent: [ :oldStyle | TextConstants at: #'; 407165 nextPutAll: familyName; 407166 nextPutAll: 'OLD put: oldStyle. TextConstants removeKey: #'; 407167 nextPutAll: familyName; 407168 nextPutAll: ' ].'; 407169 cr; 407170 nextPutAll: 'TextStyle collectionFromCompressedMIMEString: '; 407171 cr; 407172 print: mimeStream contents; 407173 nextPut: $.; 407174 cr; 407175 cr; 407176 nextPutAll: 'TextConstants at: #'; 407177 nextPutAll: familyName; 407178 nextPutAll: 'OLD ifPresent: [ :oldStyle | TextStyle replaceStyle: oldStyle with: (TextStyle named: '''; 407179 nextPutAll: familyName; 407180 nextPutAll: ''') ].'; 407181 cr; 407182 nextPutAll: 'TextStyle replaceFontsIn: (TextStyle looseFontsFromFamily: '''; 407183 nextPutAll: familyName; 407184 nextPutAll: ''') with: (TextStyle named: '''; 407185 nextPutAll: familyName; 407186 nextPutAll: ''').'; 407187 cr ]). 407188 cs fileOut! ! 407189 407190 407191!TextStyle class methodsFor: 'textconstants access' stamp: 'lr 7/4/2009 10:42'! 407192actualTextStyles 407193 "TextStyle actualTextStyles" 407194 "Answer dictionary whose keys are the names of styles in the system and whose values are the actual styles" 407195 | aDict | 407196 aDict := TextConstants select: [ :thang | thang isKindOf: self ]. 407197 self defaultFamilyNames do: [ :sym | aDict removeKey: sym ]. 407198 ^ aDict! ! 407199 407200!TextStyle class methodsFor: 'textconstants access' stamp: 'nk 9/1/2004 10:59'! 407201defaultFamilyNames 407202 ^#(DefaultTextStyle DefaultFixedTextStyle DefaultMultiStyle)! ! 407203 407204!TextStyle class methodsFor: 'textconstants access' stamp: 'nk 7/3/2003 19:06'! 407205fontArrayForStyle: aName 407206 "Answer the fonts in the style named aName, 407207 or an empty Array if no such named style." 407208 407209 "TextStyle fontArrayForStyle: #Atlanta" 407210 "TextStyle fontPointSizesFor: 'NewYork'" 407211 407212 ^ ((self named: aName) ifNil: [ ^#() ]) fontArray 407213! ! 407214 407215!TextStyle class methodsFor: 'textconstants access' stamp: 'nk 7/3/2003 18:56'! 407216fontPointSizesFor: aName 407217 "Answer the point sizes for all the fonts in the given text style" 407218 407219 "TextStyle fontPointSizesFor: 'Arial'" 407220 "TextStyle fontPointSizesFor: 'NewYork'" 407221 407222 ^ (self fontArrayForStyle: aName) collect: [:f | f pointSize] 407223! ! 407224 407225!TextStyle class methodsFor: 'textconstants access' stamp: 'nk 7/3/2003 18:58'! 407226fontSizesFor: aName 407227 "Answer the pixel sizes for all the fonts in the given text style" 407228 407229 "TextStyle fontSizesFor: 'Arial'" 407230 "TextStyle fontSizesFor: 'NewYork'" 407231 407232 ^ (self fontArrayForStyle: aName) collect: [:f | f height ] 407233! ! 407234 407235!TextStyle class methodsFor: 'textconstants access' stamp: 'nk 7/3/2003 18:58'! 407236fontWidthsFor: aName 407237 "Answer the widths for all the fonts in the given text style" 407238 407239 "TextStyle fontWidthsFor: 'ComicPlain'" 407240 ^ (self fontArrayForStyle: aName) collect: [:f | f maxWidth] 407241! ! 407242 407243!TextStyle class methodsFor: 'textconstants access' stamp: 'nk 7/3/2003 19:00'! 407244knownTextStyles 407245 "Answer the names of the known text styles, sorted in alphabetical order" 407246 407247 "TextStyle knownTextStyles" 407248 ^ (TextConstants select: [:thang | thang isKindOf: TextStyle]) keys asSortedArray 407249 407250! ! 407251 407252!TextStyle class methodsFor: 'textconstants access' stamp: 'nk 9/1/2004 11:08'! 407253knownTextStylesWithoutDefault 407254 "Answer the names of the known text styles, sorted in alphabetical order without default" 407255 407256 "TextStyle knownTextStylesWithoutDefault" 407257 | result | 407258 result := self knownTextStyles asOrderedCollection. 407259 ^ result copyWithoutAll: self defaultFamilyNames 407260 407261! ! 407262 407263!TextStyle class methodsFor: 'textconstants access' stamp: 'nk 7/3/2003 19:11'! 407264pointSizesFor: aName 407265 "Answer all the point sizes for the given text style name" 407266 407267 "TextStyle pointSizesFor: 'NewYork'" 407268 ^ (self fontArrayForStyle: aName) collect: [:f | f pointSize] 407269! ! 407270 407271 407272!TextStyle class methodsFor: 'user interface' stamp: 'DamienCassou 9/29/2009 13:14'! 407273chooseTTCFontSize: args 407274 "Prompt for a point size and, if one is given, add a new font size to the font named by the first member of args. If args' length is three, send a message with the selector equal to the third of args, and the receiver equal to the second of args, passing the selected style as an argument." 407275 407276 | f n style | 407277 f := UIManager default request: 'New Point Size' initialAnswer: '0'. 407278 f ifNil: [f := String new]. 407279 n := f asNumber. 407280 style := (TextConstants at: args first) addNewFontSize: n. 407281 style ifNotNil: [ 407282 args second ifNotNil: [args second perform: args third with: style]. 407283 ]. 407284! ! 407285 407286!TextStyle class methodsFor: 'user interface' stamp: 'laza 3/25/2004 23:12'! 407287fontMenuForStyle: styleName target: target selector: selector 407288 ^self fontMenuForStyle: styleName target: target selector: selector highlight: nil! ! 407289 407290!TextStyle class methodsFor: 'user interface' stamp: 'lr 7/4/2009 10:42'! 407291importFontsFromStyleFiles 407292 "Import any and all of the fonts found in the default directory in files named ComicBold.style, ComicPlain.style, NewYork.style, Palatino.style, Courier.style" 407293 | aName | 407294 #('ComicBold' 'ComicPlain' 'NewYork' 'Palatino' 'Courier' ) do: 407295 [ :frag | 407296 (TextStyle knownTextStyles includes: frag) ifFalse: 407297 [ (FileDirectory default fileExists: (aName := frag , '.style')) ifTrue: [ TextStyle default collectionFromFileNamed: aName ] ] ]! ! 407298 407299!TextStyle class methodsFor: 'user interface' stamp: 'alain.plantec 6/1/2008 23:09'! 407300modalStyleSelectorWithTitle: title 407301 "Presents a modal font-style choice menu, answers a TextStyle or nil." 407302 "TextStyle modalStyleSelectorWithTitle: 'testing'" 407303 | menu actualStyles | 407304 menu := MenuMorph entitled: title. 407305 actualStyles := self actualTextStyles. 407306 actualStyles keysSortedSafely 407307 do: [:styleName | 407308 | style | 407309 style := actualStyles at: styleName. 407310 menu 407311 add: styleName 407312 target: menu 407313 selector: #modalSelection: 407314 argument: style. 407315 menu lastItem 407316 font: (style fontOfSize: 18)]. 407317 ^ menu invokeModal! ! 407318 407319!TextStyle class methodsFor: 'user interface' stamp: 'laza 3/25/2004 23:12'! 407320promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector 407321 self promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector highlight: nil! ! 407322 407323 407324!TextStyle class methodsFor: 'utilities' stamp: 'nk 3/25/2004 17:55'! 407325decodeStyleName: styleName 407326 "Given a string styleName, return a collection with: 407327 407328 * [1] the probable Squeak emphasis code, which is a bit combination of: 407329 1 bold 407330 2 italic 407331 4 underlined 407332 8 narrow 407333 16 strikeout 407334 407335 * [2] the base style name without the modifiers (can be empty) 407336 * [3] the modifiers in the order they were found 407337 * [4] the codes for those modifiers, in the same order 407338 " 407339 | decoder keys modifiers modifierCodes baseName styleCode matchedKey | 407340 407341 decoder := self styleDecoder. 407342 407343 modifiers := OrderedCollection new. 407344 modifierCodes := OrderedCollection new. 407345 keys := decoder keys asArray 407346 sort: [:a :b | a size > b size]. 407347 styleCode := 0. 407348 baseName := styleName asString. 407349 [matchedKey := keys 407350 detect: [:k | baseName endsWith: k] 407351 ifNone: []. 407352 matchedKey notNil] 407353 whileTrue: [| last code | 407354 last := baseName size - matchedKey size. 407355 last > 0 407356 ifTrue: [('- ' includes: (baseName at: last)) 407357 ifTrue: [last := last - 1]]. 407358 baseName := baseName copyFrom: 1 to: last. 407359 code := decoder at: matchedKey. 407360 styleCode := styleCode + code. 407361 modifiers addFirst: matchedKey. 407362 modifierCodes addFirst: code. 407363 ]. 407364 ^ {styleCode. baseName. modifiers. modifierCodes }! ! 407365 407366!TextStyle class methodsFor: 'utilities' stamp: 'nk 4/2/2004 11:26'! 407367pixelsPerInch 407368 "Answer the nominal resolution of the screen." 407369 407370 ^TextConstants at: #pixelsPerInch ifAbsentPut: [ 96.0 ].! ! 407371 407372!TextStyle class methodsFor: 'utilities' stamp: 'nk 4/2/2004 11:24'! 407373pixelsPerInch: aNumber 407374 "Set the nominal number of pixels per inch to aNumber." 407375 TextConstants at: #pixelsPerInch put: aNumber asFloat. 407376 AbstractFont allSubInstancesDo: [ :font | font pixelsPerInchChanged ].! ! 407377 407378!TextStyle class methodsFor: 'utilities' stamp: 'nk 4/2/2004 11:23'! 407379pixelsToPoints: pixels 407380 ^pixels * 72.0 / self pixelsPerInch! ! 407381 407382!TextStyle class methodsFor: 'utilities' stamp: 'nk 4/2/2004 11:22'! 407383pointsToPixels: points 407384 ^points * self pixelsPerInch / 72.0! ! 407385FontFamilyAbstract subclass: #TextStyleAsFontFamily 407386 instanceVariableNames: 'textStyle' 407387 classVariableNames: '' 407388 poolDictionaries: '' 407389 category: 'FreeType-FontManager'! 407390 407391!TextStyleAsFontFamily methodsFor: 'accessing' stamp: 'tween 8/25/2007 14:25'! 407392members 407393 ^members ifNil:[ 407394 members := #('Regular' 'Italic' 'Bold' 'Bold Italic') 407395 collect:[:each | 407396 TextStyleAsFontFamilyMember new 407397 family: self; 407398 styleName: each; 407399 yourself]]! ! 407400 407401!TextStyleAsFontFamily methodsFor: 'accessing' stamp: 'tween 8/16/2007 22:09'! 407402textStyle 407403 "Answer the value of textStyle" 407404 407405 ^ textStyle! ! 407406 407407!TextStyleAsFontFamily methodsFor: 'accessing' stamp: 'tween 8/16/2007 22:09'! 407408textStyle: anObject 407409 "Set the value of textStyle" 407410 407411 textStyle := anObject! ! 407412FontFamilyMemberAbstract subclass: #TextStyleAsFontFamilyMember 407413 instanceVariableNames: '' 407414 classVariableNames: '' 407415 poolDictionaries: '' 407416 category: 'FreeType-FontManager'! 407417 407418!TextStyleAsFontFamilyMember methodsFor: 'LogicalFont emphasis' stamp: 'tween 9/29/2007 12:39'! 407419slantValue 407420 ^(styleName includesSubString: 'Italic') 407421 ifTrue:[LogicalFont slantItalic] 407422 ifFalse:[LogicalFont slantRegular]! ! 407423 407424!TextStyleAsFontFamilyMember methodsFor: 'LogicalFont emphasis' stamp: 'tween 9/29/2007 12:40'! 407425stretchValue 407426 ^(styleName includesSubString: 'Condensed') 407427 ifTrue:[LogicalFont stretchCompressed] 407428 ifFalse:[LogicalFont stretchRegular]! ! 407429 407430!TextStyleAsFontFamilyMember methodsFor: 'LogicalFont emphasis' stamp: 'tween 9/29/2007 12:38'! 407431weightValue 407432 ^(styleName includesSubString: 'Bold') 407433 ifTrue:[LogicalFont weightBold] 407434 ifFalse:[LogicalFont weightRegular]! ! 407435 407436 407437!TextStyleAsFontFamilyMember methodsFor: 'comparing' stamp: 'tween 8/16/2007 23:30'! 407438<= aTextStyleAsFontFamilyMember 407439 | orderedItems | 407440 orderedItems := #('Condensed' 'Condensed Italic' 'Condensed Bold' 'Condensed Bold Italic' 'Regular' 'Italic' 'Bold' 'Bold Italic'). 407441 ^(orderedItems indexOf: self styleName) <= (orderedItems indexOf: aTextStyleAsFontFamilyMember styleName)! ! 407442 407443 407444!TextStyleAsFontFamilyMember methodsFor: 'squeak emphasis' stamp: 'tween 9/29/2007 12:43'! 407445emphasisCode 407446 " Answer the squeak emphasis code (1=bold, 2=italic, 3=boldItalic etc" 407447 | answer | 407448 answer := 0. 407449 (styleName includesSubString: 'Italic') 407450 ifTrue:[answer := answer bitOr: LogicalFont squeakSlantItalic]. 407451 (styleName includesSubString: 'Condensed') 407452 ifTrue:[answer := answer bitOr: LogicalFont squeakStretchCondensed]. 407453 (styleName includesSubString: 'Bold') 407454 ifTrue:[answer := answer bitOr: LogicalFont squeakWeightBold]. 407455 ^answer! ! 407456 407457 407458!TextStyleAsFontFamilyMember methodsFor: 'testing' stamp: 'tween 8/17/2007 00:16'! 407459simulated 407460 ^false! ! 407461AbstractFontSelectorDialogWindow subclass: #TextStyleFontSelectorDialogWindow 407462 instanceVariableNames: '' 407463 classVariableNames: '' 407464 poolDictionaries: '' 407465 category: 'Polymorph-Widgets-Windows'! 407466 407467!TextStyleFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:55'! 407468defaultFontFamilies 407469 "Answer the set of available fonts families that are supported as Text objects 407470 in the font that they represent. Only includes FreeTypeFont/TTCFont." 407471 407472 ^(((TextStyle actualTextStyles 407473 select: [:ts | ts defaultFont isTTCFont]) 407474 collect: [:ts | ts defaultFont familyName]) asSet 407475 collect: [:fam | |famTs| 407476 famTs := TextStyle named: fam. 407477 self isFreeTypeInstalled ifTrue: [ 407478 (famTs defaultFont isSymbolFont or: [ 407479 (famTs defaultFont hasDistinctGlyphsForAll: fam) not]) 407480 ifTrue: [famTs := TextStyle default]]. 407481 fam asText 407482 addAttribute: (TextFontReference 407483 toFont: (famTs fontOfPointSize: self theme listFont pointSize))]) 407484 asSortedCollection: [:a :b | a asString <= b asString]! ! 407485 407486!TextStyleFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:35'! 407487matchingFont 407488 "Answer the font that matches the selections." 407489 407490 |ts fs emp| 407491 ts := (TextStyle named: self familyName) ifNil: [^TextStyle defaultFont]. 407492 fs := self fontSize ifNil: [ts defaultFont pointSize]. 407493 emp := self isBold 407494 ifTrue: [TextEmphasis bold emphasisCode] 407495 ifFalse: [TextEmphasis normal emphasisCode]. 407496 self isItalic 407497 ifTrue: [emp := emp + TextEmphasis italic emphasisCode]. 407498 self isUnderlined 407499 ifTrue: [emp := emp + TextEmphasis underlined emphasisCode]. 407500 self isStruckOut 407501 ifTrue: [emp := emp + TextEmphasis struckOut emphasisCode]. 407502 (ts fontOfPointSize: fs) pointSize ~= fs 407503 ifTrue: [ts addNewFontSize: fs]. 407504 ^(ts fontOfPointSize: fs) 407505 emphasis: emp! ! 407506 407507!TextStyleFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:20'! 407508updateFromSelectedFont 407509 "Update our state based on the selected font." 407510 407511 |font| 407512 font := self selectedFont ifNil: [TextStyle defaultFont]. 407513 fontFamilyIndex := (self fontFamilies indexOf: font familyName). 407514 fontSizeIndex := (self fontSizes indexOf: font pointSize). 407515 isBold := (font emphasis allMask: TextEmphasis bold emphasisCode). 407516 isItalic := (font emphasis allMask: TextEmphasis italic emphasisCode). 407517 isUnderlined := (font emphasis allMask: TextEmphasis underlined emphasisCode). 407518 isStruckOut := (font emphasis allMask: TextEmphasis struckOut emphasisCode). 407519 self 407520 changed: #fontFamilyIndex; 407521 changed: #fontSizeIndex; 407522 changed: #isBold; 407523 changed: #isItalic; 407524 changed: #isUnderlined; 407525 changed: #isStruckOut. 407526 self textPreviewMorph ifNotNilDo: [:tp | 407527 tp 407528 font: self selectedFont; 407529 scrollToTop]! ! 407530HashAndEqualsTestCase subclass: #TextStyleTest 407531 instanceVariableNames: '' 407532 classVariableNames: '' 407533 poolDictionaries: '' 407534 category: 'GraphicsTests-Text'! 407535 407536!TextStyleTest methodsFor: 'initialization' stamp: 'mjr 8/20/2003 18:55'! 407537setUp 407538 super setUp. 407539 prototypes add: TextStyle default ! ! 407540TextAction subclass: #TextURL 407541 instanceVariableNames: 'url' 407542 classVariableNames: '' 407543 poolDictionaries: '' 407544 category: 'Collections-Text'! 407545 407546!TextURL methodsFor: 'as yet unclassified' stamp: 'stephane.ducasse 7/10/2009 17:40'! 407547actOnClickFor: anObject 407548 "Do what you can with this URL. Later a web browser." 407549 407550 | response m | 407551 "if it's a web browser, tell it to jump" 407552 anObject isWebBrowser 407553 ifTrue: [anObject jumpToUrl: url. ^ true] 407554 ifFalse: [((anObject respondsTo: #model) and: [anObject model isWebBrowser]) 407555 ifTrue: [anObject model jumpToUrl: url. ^ true]]. 407556 407557 "if it's a morph, see if it is contained in a web browser" 407558 (anObject isKindOf: Morph) ifTrue: [ 407559 m := anObject. 407560 [ m ~= nil ] whileTrue: [ 407561 (m isWebBrowser) ifTrue: [ 407562 m jumpToUrl: url. 407563 ^true ]. 407564 (m hasProperty: #webBrowserView) ifTrue: [ 407565 m model jumpToUrl: url. 407566 ^true ]. 407567 m := m owner. ] 407568 ]. 407569 407570 "no browser in sight. ask if we should start a new browser" 407571 ((self confirm: 'open a browser to view this URL?' translated) and: [WebBrowser default notNil]) ifTrue: [ 407572 WebBrowser default openOnUrl: url. 407573 ^ true ]. 407574 407575 "couldn't display in a browser. Offer to put up just the source" 407576 407577 response := (UIManager default 407578 chooseFrom: (Array with: 'View web page as source' translated 407579 with: 'Cancel' translated) 407580 title: 'Couldn''t find a web browser. View\page as source?' withCRs translated). 407581 response = 1 ifTrue: [HTTPSocket httpShowPage: url]. 407582 ^ true! ! 407583 407584!TextURL methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 16:47'! 407585analyze: aString 407586 407587 | list | 407588 list := super analyze: aString. 407589 url := list at: 1. 407590 ^ list at: 2! ! 407591 407592!TextURL methodsFor: 'as yet unclassified' stamp: 'tk 12/30/97 10:33'! 407593info 407594 ^ url! ! 407595 407596!TextURL methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 08:55'! 407597url: aString 407598 url := aString! ! 407599 407600!TextURL methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 13:45'! 407601writeScanOn: strm 407602 407603 strm nextPut: $R; nextPutAll: url; nextPut: $;! ! 407604 407605"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 407606 407607TextURL class 407608 instanceVariableNames: ''! 407609 407610!TextURL class methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 09:24'! 407611scanFrom: strm 407612 "read a link in the funny format used by Text styles on files. Rhttp://www.disney.com;" 407613 407614 ^ self new url: (strm upTo: $;)! ! 407615Object subclass: #TheWorldMainDockingBar 407616 instanceVariableNames: '' 407617 classVariableNames: 'Instance TS' 407618 poolDictionaries: '' 407619 category: 'Morphic-DockingBar'! 407620!TheWorldMainDockingBar commentStamp: 'stephane.ducasse 3/22/2009 11:50' prior: 0! 407621To open it 407622 407623 TheWorldMainDockingBar instance openDockingBar! 407624 407625 407626!TheWorldMainDockingBar methodsFor: 'construction' stamp: 'stephane.ducasse 3/22/2009 11:51'! 407627createDockingBar 407628 "Create a docking bar from the receiver's representation" 407629 407630 | dockingBar | 407631 dockingBar := DockingBarMorph new. 407632 dockingBar adhereToTop. 407633 dockingBar color: ColorTheme current dockingBarColor. 407634 dockingBar gradientRamp: ColorTheme current dockingBarGradientRamp. 407635 dockingBar autoGradient: ColorTheme current dockingBarAutoGradient. 407636 self fillDockingBar: dockingBar. 407637 ^ dockingBar 407638 407639! ! 407640 407641!TheWorldMainDockingBar methodsFor: 'construction' stamp: 'adrian_lienhard 7/19/2009 18:03'! 407642fillDockingBar: aDockingBar 407643 "Private - fill the given docking bar" 407644 407645 self fillMenuItemsBar: aDockingBar. 407646 aDockingBar addSpacer. 407647 Preferences tinyDisplay 407648 ifFalse: [ 407649 407650 aDockingBar 407651 addMorphBack: (self 407652 createButtonIcon: self volumeIcon 407653 help: 'Change sound volume' translated 407654 selector: #changeSoundVolume)]. 407655 aDockingBar 407656 addMorphBack: (self 407657 createButtonIcon: self fullScreenIcon 407658 help: (Display isFullScreen 407659 ifTrue: ['Exit from full screen'] 407660 ifFalse: ['Switch to full screen']) 407661 selector: #toggleFullScreen). 407662 aDockingBar 407663 addMorphBack: (self 407664 createButtonIcon: (SelectedObjectThumbnail 407665 extent: 37 @ 28 407666 - (Preferences tinyDisplay 407667 ifTrue: [12] 407668 ifFalse: [0]) 407669 noSelectedThumbnail: self objectsIcon 407670 noSelectedBalloonText: 'View objects hierarchy' translated) 407671 selector: #viewSelectedObject). 407672 "" 407673 aDockingBar setProperty: #mainDockingBarTimeStamp toValue: self class timeStamp! ! 407674 407675!TheWorldMainDockingBar methodsFor: 'construction' stamp: 'stephane.ducasse 3/22/2009 11:51'! 407676fillMenuItemsBar: aDockingBar 407677 "Private - fill the given docking bar" 407678 407679 | squeakIcon homeIcon configurationIcon helpIcon squeakLabel projectLabel configurationLabel helpLabel | 407680 (aDockingBar isDockingBar not 407681 or: [Preferences tinyDisplay]) 407682 ifTrue: ["" 407683 squeakIcon := MenuIcons smallSqueakIcon. 407684 homeIcon := MenuIcons smallHomeIcon. 407685 configurationIcon := MenuIcons smallConfigurationIcon. 407686 helpIcon := MenuIcons smallHelpIcon] 407687 ifFalse: ["" 407688 squeakIcon := MenuIcons squeakIcon. 407689 homeIcon := MenuIcons homeIcon. 407690 configurationIcon := MenuIcons configurationIcon. 407691 helpIcon := MenuIcons helpIcon]. 407692 "" 407693 Preferences tinyDisplay 407694 ifTrue: ["" 407695 squeakLabel := '' . 407696 projectLabel := '' . 407697 configurationLabel := '' . 407698 helpLabel := '' ] 407699 ifFalse: ["" 407700 squeakLabel := 'Squeak' translated. 407701 projectLabel := 'Project' translated. 407702 configurationLabel := 'Configuration' translated. 407703 helpLabel := 'Help' translated]. 407704 "" 407705 aDockingBar 407706 add: squeakLabel 407707 icon: squeakIcon 407708 help: 'Options related to Squeak as a whole' translated 407709 subMenu: self squeakMenu. 407710 aDockingBar 407711 add: projectLabel 407712 icon: homeIcon 407713 help: 'Options to open things in the current project or to navigate between projects' translated 407714 subMenu: self projectMenu. 407715 aDockingBar 407716 add: configurationLabel 407717 icon: configurationIcon 407718 help: 'Options to configure Squeak' translated 407719 subMenu: self configurationMenu. 407720 aDockingBar 407721 add: helpLabel 407722 icon: helpIcon 407723 help: 'Helpful options or options to get help' translated 407724 subMenu: self helpMenu! ! 407725 407726!TheWorldMainDockingBar methodsFor: 'construction' stamp: 'dgd 9/6/2004 14:05'! 407727openDockingBar 407728 ^ self createDockingBar openInWorld ! ! 407729 407730 407731!TheWorldMainDockingBar methodsFor: 'construction - submenus' stamp: 'RobRothwell 2/23/2009 22:42'! 407732configurationMenu 407733 | menu | 407734 menu := MenuMorph new defaultTarget: self. 407735 "" 407736 self createMenuItem: {'set language...'. 'Choose the language in which Squeak should be displayed'. MenuIcons smallLanguageIcon} on: menu. 407737 menu addLine. 407738 self createMenuItem: {'update from server'. 'Update from server (Internet access is required)'. MenuIcons smallUpdateIcon} on: menu. 407739 "" 407740 menu addLine. 407741 menu addUpdating: #showWorldMainDockingBarString action: #toggleShowWorldMainDockingBar. 407742 Flaps sharedFlapsAllowed 407743 ifTrue: [menu 407744 addUpdating: #suppressFlapsString 407745 target: Project current 407746 action: #currentToggleFlapsSuppressed]. 407747 menu addLine. 407748 self createMenuItem: {'set world color...'. 'Choose a color to use as world background.'} on: menu. 407749 Display isFullScreen 407750 ifTrue: [self createMenuItem: {'exit from full screen'. 'Exit from full screen and enclose Squeak in a window'. MenuIcons smallFullScreenIcon} on: menu] 407751 ifFalse: [self createMenuItem: {'switch to full screen'. 'Switch to full screen giving the maximun display space to Squeak'. MenuIcons smallFullScreenIcon} on: menu]. 407752 "" 407753 self createMenuItem: {'change sound volume'. 'Change sound volume'. MenuIcons smallVolumeIcon} on: menu. 407754 menu addLine. 407755 Preferences useUndo 407756 ifTrue: ["" 407757 self createMenuItem: {'purge undo records'. 'Save space by removing all the undo information.'} on: menu. 407758 menu addLine]. 407759 self createMenuItem: {'preferences..'. 'Opens a "Preferences Panel" which allows you to alter many settings'. MenuIcons smallConfigurationIcon} on: menu. 407760 self createMenuItem: {'appearance...'. nil. MenuIcons smallConfigurationIcon} on: menu. 407761 self createMenuItem: {'set color theme...'. 'Choose the color theme in which Squeak should be displayed'} on: menu. 407762 menu addLine. 407763 ^ menu! ! 407764 407765!TheWorldMainDockingBar methodsFor: 'construction - submenus' stamp: 'stephane.ducasse 3/22/2009 11:54'! 407766helpMenu 407767 407768 | menu | 407769 menu := MenuMorph new defaultTarget: self. 407770 self createMenuItem: {'move objects onscreen'. 'Bring back all objects whose current coordinates keep them from being visible, so that at least a portion of each of my interior objects can be seen'} on: menu. 407771 self createMenuItem: {'unhide hidden objects'. 'If any items on the world are currently hidden, make them visible'} on: menu. 407772 407773 ^ menu! ! 407774 407775!TheWorldMainDockingBar methodsFor: 'construction - submenus' stamp: 'stephane.ducasse 3/22/2009 11:57'! 407776projectMenu 407777 | menu | 407778 menu := MenuMorph new defaultTarget: self. 407779 self createMenuItem: {'open...'. nil. MenuIcons smallOpenIcon} on: menu. 407780 self createMenuItem: {'windows...'. nil. MenuIcons smallWindowIcon} on: menu. 407781 menu addLine. 407782 407783 self createMenuItem: {'find any file'. 'Import a file into Squeak'. MenuIcons smallOpenIcon} on: menu. 407784 self createMenuItem: {'object catalog (o)'. 'A tool for finding and obtaining many kinds of objects'. MenuIcons smallObjectCatalogIcon} on: menu. 407785 menu addLine. 407786 self createMenuItem: {'view objects hierarchy'. 'A tool for discovering the objects and the relations between them'. MenuIcons smallObjectsIcon} on: menu. 407787 ^ menu! ! 407788 407789!TheWorldMainDockingBar methodsFor: 'construction - submenus' stamp: 'marcus.denker 11/19/2008 13:33'! 407790squeakMenu 407791 | menu | 407792 menu := MenuMorph new defaultTarget: self. 407793 Preferences readOnlyMode ifFalse:[ 407794 self createMenuItem: {'save'. 'Save the current state of Squeak on disk'. MenuIcons smallSaveIcon} on: menu. 407795 self createMenuItem: {'save as...'. 'Save the current state of Squeak on disk under a new name'. MenuIcons smallSaveAsIcon} on: menu. 407796 self createMenuItem: {'save as new version'. 'Save the current state of Squeak on disk under a version-stamped name'. MenuIcons smallSaveAsIcon} on: menu. 407797 menu addLine. 407798 self createMenuItem: {'save and quit'. 'Save the current state of Squeak on disk, and quit out of Squeak'. MenuIcons smallQuitIcon} on: menu]. 407799 self createMenuItem: {'quit'. 'Quit out of Squeak'. MenuIcons smallQuitIcon} on: menu. 407800 ^ menu! ! 407801 407802 407803!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'adrian_lienhard 7/19/2009 19:56'! 407804activateObjectsTool 407805 "self world activateObjectsTool"! ! 407806 407807!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 10/7/2004 17:13'! 407808appearance 407809 self worldMenu appearanceMenu popUpInWorld ! ! 407810 407811!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/4/2004 19:37'! 407812changeSoundVolume 407813 self notYetImplemented! ! 407814 407815!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:35'! 407816exitFromFullScreen 407817 self toggleFullScreen! ! 407818 407819!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'hfm 11/29/2008 20:06'! 407820findAnyFile 407821 FileList morphicViewGeneralLoaderInWorld: self world! ! 407822 407823!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/7/2004 20:52'! 407824importFile 407825 self findAnyFile! ! 407826 407827!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:13'! 407828moveObjectsOnscreen 407829 self world roundUpStrays! ! 407830 407831!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/7/2004 20:30'! 407832objectCatalog 407833 self activateObjectsTool! ! 407834 407835!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/19/2004 13:48'! 407836objectFromPasteBuffer 407837 ActiveHand pasteMorph! ! 407838 407839!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 10/7/2004 14:55'! 407840open 407841 self worldMenu openMenu popUpInWorld! ! 407842 407843!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 10/15/2004 11:49'! 407844purgeUndoRecords 407845 CommandHistory resetAllHistory! ! 407846 407847!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 11/5/2004 15:30'! 407848quit 407849 Preferences readOnlyMode 407850 ifTrue: [""(self confirm: 'REALLY quit Squeak?' translated) 407851 ifTrue: [SmalltalkImage current snapshot: false andQuit: true]] 407852 ifFalse: [| saveBeforeQuitting | 407853 saveBeforeQuitting := self 407854 confirm: 'Save changes before quitting?' translated 407855 orCancel: [^ self]. 407856 SmalltalkImage current snapshot: saveBeforeQuitting andQuit: true]! ! 407857 407858!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/7/2004 11:20'! 407859save 407860 SmalltalkImage current snapshot: true andQuit: false! ! 407861 407862!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/7/2004 11:25'! 407863saveAndQuit 407864 SmalltalkImage current snapshot: true andQuit: true! ! 407865 407866!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/7/2004 11:21'! 407867saveAs 407868 SmalltalkImage current saveAs! ! 407869 407870!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/22/2004 17:48'! 407871saveAsNewVersion 407872 SmalltalkImage current saveAsNewVersion! ! 407873 407874!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 16:23'! 407875setLanguage 407876 Project current chooseNaturalLanguage ! ! 407877 407878!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 10/7/2004 14:51'! 407879setWorldColor 407880| world | 407881world := self world. 407882 world 407883 changeColorTarget: world 407884 selector: #color: 407885 originalColor: world color 407886 hand: world activeHand! ! 407887 407888!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/20/2004 20:03'! 407889showWorldMainDockingBarString 407890 ^ self world showWorldMainDockingBarString! ! 407891 407892!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'marcus.denker 9/23/2008 21:45'! 407893suppressFlapsString 407894 "Answer the wording of the suppress-flaps item" 407895 ^ Project current suppressFlapsString! ! 407896 407897!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:36'! 407898switchToFullScreen 407899 self toggleFullScreen! ! 407900 407901!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'RobRothwell 2/23/2009 22:34'! 407902toggleFullScreen 407903 Display toggleFullScreen. 407904 self world positionSubmorphs. 407905 self class updateInstances! ! 407906 407907!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/20/2004 20:05'! 407908toggleShowWorldMainDockingBar 407909 self world toggleShowWorldMainDockingBar! ! 407910 407911!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/9/2004 18:13'! 407912unhideHiddenObjects 407913 self world showHiders! ! 407914 407915!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 9/25/2004 21:50'! 407916viewObjectsHierarchy 407917 "self world findWindow: nil" 407918 MorphHierarchy openOrDelete! ! 407919 407920!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 7/28/2005 13:04'! 407921viewSelectedObject 407922 | selected menu | 407923 selected := self world selectedObject. 407924 selected isNil 407925 ifTrue: [^ self viewObjectsHierarchy]. 407926 "" 407927 menu := selected buildYellowButtonMenu: ActiveHand. 407928 menu 407929 addTitle: selected externalName 407930 icon: (selected iconOrThumbnailOfSize: (Preferences tinyDisplay ifTrue: [16] ifFalse: [28])). 407931 menu popUpInWorld: selected currentWorld! ! 407932 407933!TheWorldMainDockingBar methodsFor: 'menu actions' stamp: 'dgd 10/7/2004 14:55'! 407934windows 407935 self worldMenu windowsMenu popUpInWorld! ! 407936 407937 407938!TheWorldMainDockingBar methodsFor: 'private' stamp: 'dgd 7/28/2005 12:52'! 407939createMenuItem: triplet on: menu 407940 | wording help selectorOrMenu | 407941 wording := triplet first. 407942 help := triplet second. 407943 selectorOrMenu := triplet size > 3 407944 ifTrue: [triplet fourth] 407945 ifFalse: [self selectorForWording: wording]. 407946 "" 407947 selectorOrMenu isSymbol 407948 ifTrue: ["" 407949 menu 407950 add: wording translated 407951 target: self 407952 selector: selectorOrMenu] 407953 ifFalse: [menu add: wording translated subMenu: selectorOrMenu]. 407954 "" 407955 help isNil 407956 ifFalse: [menu lastItem setBalloonText: help translated]."" 407957 Preferences tinyDisplay 407958 ifFalse: [triplet size > 2 407959 ifTrue: [menu lastItem icon: triplet third]]! ! 407960 407961!TheWorldMainDockingBar methodsFor: 'private' stamp: 'dgd 10/7/2004 12:12'! 407962selectorForWording: aString 407963 "Private - Create a valid smalltalk selector from an english 407964 wording. 407965 'foo' -> #foo 407966 'foo....' -> #foo 407967 'foo bar' -> #fooBar 407968 'foo bar (f)' - #fooBar 407969 " 407970 | words selector temp | 407971 temp := aString. 407972 ('*(*)*' match: temp) 407973 ifTrue: [| pre post | 407974 pre := temp copyUpTo: $(. 407975 post := temp copyAfterLast: $). 407976 temp := pre , post]. 407977 "" 407978 temp := temp 407979 collect: [:each | "" 407980 each isLetter 407981 ifTrue: [each] 407982 ifFalse: [Character space]]. 407983 words := temp subStrings: Character separators. 407984 selector := String 407985 streamContents: [:stream | "" 407986 words 407987 do: [:word | stream nextPutAll: word capitalized]]. 407988 selector at: 1 put: selector first asLowercase. 407989 "" 407990 ^ selector asSymbol! ! 407991 407992!TheWorldMainDockingBar methodsFor: 'private' stamp: 'dgd 9/6/2004 18:48'! 407993updateIfNeeded: aDockingBar 407994"Update the given docking bar if needed" 407995 | timeStamp | 407996 timeStamp := aDockingBar 407997 valueOfProperty: #mainDockingBarTimeStamp 407998 ifAbsent: [^ self]. 407999 timeStamp = self class timeStamp 408000 ifTrue: [^ self]. 408001 "" 408002 aDockingBar removeAllMorphs. 408003 self fillDockingBar: aDockingBar! ! 408004 408005!TheWorldMainDockingBar methodsFor: 'private' stamp: 'dgd 9/9/2004 18:12'! 408006world 408007^ World! ! 408008 408009!TheWorldMainDockingBar methodsFor: 'private' stamp: 'dgd 10/7/2004 14:55'! 408010worldMenu 408011 ^ TheWorldMenu new 408012 world: self world 408013 project: Project current 408014 hand: self world activeHand; yourself! ! 408015 408016 408017!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/6/2004 18:37'! 408018colorOffEvent: anEvent for: aMorph 408019 "Private - gives an off-color to the given morph" 408020 aMorph color: self offColor! ! 408021 408022!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/6/2004 18:38'! 408023colorOnEvent: anEvent for: aMorph 408024 "Private - gives an on-color to the given morph" 408025 aMorph color: self onColor! ! 408026 408027!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/10/2004 19:24'! 408028createButtonIcon: aFormOrMorph help: helpStringOrNil selector: selector 408029 "Private - Creates a button to fire an action from a docking bar" 408030 | button icon | 408031 button := RectangleMorph new. 408032 button extent: aFormOrMorph extent + 2. 408033 button borderWidth: 0. 408034 button color: self offColor. 408035 helpStringOrNil isNil 408036 408037 ifFalse: [button setBalloonText: helpStringOrNil translated]. 408038 "" 408039 icon := aFormOrMorph isMorph 408040 ifTrue: [aFormOrMorph] 408041 ifFalse: [SketchMorph withForm: aFormOrMorph]. 408042 button addMorphCentered: icon. 408043 "" 408044 button 408045 on: #mouseDown 408046 send: #perform:event:for: 408047 to: self 408048 withValue: selector. 408049 button 408050 on: #mouseEnter 408051 send: #colorOnEvent:for: 408052 to: self. 408053 button 408054 on: #mouseLeave 408055 send: #colorOffEvent:for: 408056 to: self. 408057 "" 408058 ^ button! ! 408059 408060!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/10/2004 19:33'! 408061createButtonIcon: aFormOrMorph selector: selector 408062 "Private - Creates a button to fire an action from a docking bar" 408063 ^ self 408064 createButtonIcon: aFormOrMorph 408065 help: nil 408066 selector: selector! ! 408067 408068!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/6/2004 18:38'! 408069offColor 408070 "Private - answer the off color" 408071 ^ Color black alpha: 0.01! ! 408072 408073!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/6/2004 18:38'! 408074onColor 408075"Private - answer the on color" 408076 ^ (Preferences menuSelectionColor 408077 ifNil: [Color blue]) 408078 alpha: 0.4! ! 408079 408080!TheWorldMainDockingBar methodsFor: 'private - buttons' stamp: 'dgd 9/6/2004 18:39'! 408081perform: selectorSymbol event: anEvent for: aMorph 408082 "Private - perform the given selector" 408083 aMorph color: self offColor. 408084 self perform: selectorSymbol! ! 408085 408086 408087!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:17'! 408088backIcon 408089 ^ Preferences tinyDisplay 408090 ifTrue: [MenuIcons smallBackIcon] 408091 ifFalse: [MenuIcons backIcon]! ! 408092 408093!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:19'! 408094forwardIcon 408095 ^ Preferences tinyDisplay 408096 ifTrue: [MenuIcons smallForwardIcon] 408097 ifFalse: [MenuIcons forwardIcon]! ! 408098 408099!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:26'! 408100fullScreenIcon 408101 ^ Preferences tinyDisplay 408102 ifTrue: [MenuIcons smallFullScreenIcon] 408103 ifFalse: [MenuIcons fullScreenIcon]! ! 408104 408105!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:18'! 408106jumpIcon 408107 ^ Preferences tinyDisplay 408108 ifTrue: [MenuIcons smallJumpIcon] 408109 ifFalse: [MenuIcons jumpIcon]! ! 408110 408111!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:20'! 408112objectCatalogIcon 408113 ^ Preferences tinyDisplay 408114 ifTrue: [MenuIcons smallObjectCatalogIcon] 408115 ifFalse: [MenuIcons objectCatalogIcon]! ! 408116 408117!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:27'! 408118objectsIcon 408119 ^ Preferences tinyDisplay 408120 ifTrue: [MenuIcons smallObjectsIcon] 408121 ifFalse: [MenuIcons objectsIcon]! ! 408122 408123!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:19'! 408124openIcon 408125 ^ Preferences tinyDisplay 408126 ifTrue: [MenuIcons smallOpenIcon] 408127 ifFalse: [MenuIcons openIcon]! ! 408128 408129!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:20'! 408130paintIcon 408131 ^ Preferences tinyDisplay 408132 ifTrue: [MenuIcons smallPaintIcon] 408133 ifFalse: [MenuIcons paintIcon]! ! 408134 408135!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:20'! 408136projectIcon 408137 ^ Preferences tinyDisplay 408138 ifTrue: [MenuIcons smallProjectIcon] 408139 ifFalse: [MenuIcons projectIcon]! ! 408140 408141!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:21'! 408142publishIcon 408143 ^ Preferences tinyDisplay 408144 ifTrue: [MenuIcons smallPublishIcon] 408145 ifFalse: [MenuIcons publishIcon]! ! 408146 408147!TheWorldMainDockingBar methodsFor: 'private - icons' stamp: 'dgd 7/28/2005 11:26'! 408148volumeIcon 408149 ^ Preferences tinyDisplay 408150 ifTrue: [MenuIcons smallVolumeIcon] 408151 ifFalse: [MenuIcons volumeIcon]! ! 408152 408153"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 408154 408155TheWorldMainDockingBar class 408156 instanceVariableNames: ''! 408157 408158!TheWorldMainDockingBar class methodsFor: 'as yet unclassified' stamp: 'dgd 9/9/2004 16:27'! 408159localeChanged 408160 self updateInstances! ! 408161 408162 408163!TheWorldMainDockingBar class methodsFor: 'events' stamp: 'dgd 9/7/2004 21:33'! 408164updateInstances 408165 "The class has changed, time to update the instances" 408166 408167 self setTimeStamp. 408168 Project current assureMainDockingBarPresenceMatchesPreference! ! 408169 408170!TheWorldMainDockingBar class methodsFor: 'events' stamp: 'dgd 9/7/2004 21:33'! 408171updateInstances: anEvent 408172 "The class has changed, time to update the instances" 408173 (anEvent itemClass == self 408174 or: [anEvent itemClass == self class]) 408175 ifFalse: [^ self]. 408176 "" 408177 self updateInstances! ! 408178 408179 408180!TheWorldMainDockingBar class methodsFor: 'initialization' stamp: 'dgd 9/22/2004 20:42'! 408181initialize 408182 "Initialize the receiver" 408183 Preferences 408184 addPreference: #showWorldMainDockingBar 408185 categories: #(#'docking bars' ) 408186 default: true 408187 balloonHelp: 'Whether world''s main docking bar should be shown or not.' 408188 projectLocal: true 408189 changeInformee: TheWorldMainDockingBar 408190 changeSelector: #showWorldMainDockingBarPreferenceChanged. 408191 "" 408192 SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self. 408193 SystemChangeNotifier uniqueInstance 408194 notify: self 408195 ofSystemChangesOfItem: #method 408196 using: #updateInstances:. 408197 "" 408198 Locale addLocalChangedListener: self. 408199 self setTimeStamp! ! 408200 408201 408202!TheWorldMainDockingBar class methodsFor: 'instance creation' stamp: 'dgd 9/6/2004 14:35'! 408203instance 408204 "Answer the receiver's instance" 408205 ^ Instance 408206 ifNil: [Instance := super new]! ! 408207 408208!TheWorldMainDockingBar class methodsFor: 'instance creation' stamp: 'dgd 9/6/2004 14:35'! 408209new 408210 "Singleton, use #instance" 408211 ^ self error: 'Use #instance'! ! 408212 408213 408214!TheWorldMainDockingBar class methodsFor: 'preferences' stamp: 'dgd 9/6/2004 18:48'! 408215showWorldMainDockingBarPreferenceChanged 408216 "The preference #showWorldMainDockingBar has just 408217 changed" 408218 Project current showWorldMainDockingBar: Preferences showWorldMainDockingBar! ! 408219 408220 408221!TheWorldMainDockingBar class methodsFor: 'timestamping' stamp: 'dgd 9/6/2004 14:21'! 408222setTimeStamp 408223 "Change the receiver's timeStamp" 408224 TS := UUID new! ! 408225 408226!TheWorldMainDockingBar class methodsFor: 'timestamping' stamp: 'dgd 9/6/2004 14:19'! 408227timeStamp 408228 "Answer the receiver's timeStamp" 408229 ^ TS! ! 408230Object subclass: #TheWorldMenu 408231 instanceVariableNames: 'myProject myWorld myHand' 408232 classVariableNames: 'OpenMenuRegistry' 408233 poolDictionaries: '' 408234 category: 'Morphic-Kernel'! 408235!TheWorldMenu commentStamp: 'sw 10/5/2002 00:44' prior: 0! 408236Instances of TheWorldMenu serve to present the primary Squeak menu obtained by clicking on open desktop, which is variously spoken of as the "screen menu", the "desktop menu", or the "world menu". 408237 408238myProject is the Project I pertain to. 408239myWorld is the world, a PasteUpMorph, that I pertain to. 408240myHand is the hand that invoked the menu.! 408241 408242 408243!TheWorldMenu methodsFor: '*Polymorph-ToolBuilder' stamp: 'gvc 1/24/2007 16:42'! 408244world 408245 "Answer myWorld." 408246 408247 ^myWorld! ! 408248 408249 408250!TheWorldMenu methodsFor: '*Tools' stamp: 'ar 7/16/2005 19:47'! 408251browseRecentLog 408252 ChangeList browseRecentLog! ! 408253 408254!TheWorldMenu methodsFor: '*Tools' stamp: 'sd 11/20/2005 21:26'! 408255inspectWorldModel 408256 | insp | 408257 408258 insp := InspectorBrowser openAsMorphOn: myWorld model. 408259 myWorld addMorph: insp; startStepping: insp! ! 408260 408261!TheWorldMenu methodsFor: '*Tools' stamp: 'RAA 5/26/2000 08:43'! 408262openChangeSorter1 408263 408264 ChangeSorter new morphicWindow openInWorld: myWorld! ! 408265 408266!TheWorldMenu methodsFor: '*Tools' stamp: 'RAA 5/26/2000 08:43'! 408267openChangeSorter2 408268 408269 DualChangeSorter new morphicWindow openInWorld: myWorld! ! 408270 408271!TheWorldMenu methodsFor: '*Tools' stamp: 'sw 7/28/2001 02:11'! 408272openMessageNames 408273 "Bring a MessageNames tool to the front" 408274 408275 MessageNames openMessageNames! ! 408276 408277!TheWorldMenu methodsFor: '*Tools' stamp: 'ar 7/16/2005 20:02'! 408278openProcessBrowser 408279 ProcessBrowser open! ! 408280 408281 408282!TheWorldMenu methodsFor: '*eToys-scripting' stamp: 'ar 3/17/2001 20:16'! 408283adaptedToWorld: aWorld 408284 "Can use me but need to adapt myself" 408285 self adaptToWorld: aWorld.! ! 408286 408287 408288!TheWorldMenu methodsFor: 'action' stamp: 'sw 12/4/2001 21:02'! 408289commandKeyTypedIntoMenu: evt 408290 "The user typed a command-key into the given menu; dispatch it" 408291 408292 myWorld keystrokeInWorld: evt ! ! 408293 408294!TheWorldMenu methodsFor: 'action' stamp: 'marcus.denker 6/10/2009 20:21'! 408295doMenuItem: aCollection with: event 408296 | realTarget selector nArgs | 408297 selector := aCollection second. 408298 nArgs := selector numArgs. 408299 realTarget := aCollection first. 408300 realTarget == #myWorld ifTrue: [realTarget := myWorld]. 408301 realTarget == #myHand ifTrue: [realTarget := myHand]. 408302 ^nArgs = 0 408303 ifTrue:[realTarget perform: selector] 408304 ifFalse:[realTarget perform: selector with: event]. 408305! ! 408306 408307!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 10:18'! 408308menuColorString 408309 408310 ^ Preferences menuColorString! ! 408311 408312!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 10:18'! 408313roundedCornersString 408314 408315 ^ Preferences roundedCornersString! ! 408316 408317!TheWorldMenu methodsFor: 'action' stamp: 'RAA 6/27/2000 09:04'! 408318setGradientColor 408319 408320 myWorld setGradientColor: myHand lastEvent! ! 408321 408322!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 08:35'! 408323soundEnablingString 408324 408325 ^ Preferences soundEnablingString! ! 408326 408327!TheWorldMenu methodsFor: 'action' stamp: 'RobRothwell 2/23/2009 22:42'! 408328toggleScreenString 408329 ^ Display isFullScreen 408330 ifFalse: ['Full screen on' translated] 408331 ifTrue: ['Full screen off' translated] 408332! ! 408333 408334 408335!TheWorldMenu methodsFor: 'commands' stamp: 'ar 10/5/2000 18:54'! 408336changeBackgroundColor 408337 "Let the user select a new background color for the world" 408338 408339 myWorld changeColorTarget: myWorld selector: #color: originalColor: myWorld color hand: myWorld activeHand. 408340! ! 408341 408342!TheWorldMenu methodsFor: 'commands' stamp: 'alain.plantec 2/6/2009 17:36'! 408343cleanUpWorld 408344 (self confirm: 408345'This will remove all windows except those 408346containing unsubmitted text edits, and will 408347also remove all non-window morphs (other 408348than flaps) found on the desktop. Are you 408349sure you want to do this?' translated) 408350 ifFalse: [^ self]. 408351 408352 myWorld allNonFlapRelatedSubmorphs do: 408353 [:m | m delete]. 408354 (myWorld windowsSatisfying: [:w | w model canDiscardEdits]) 408355 do: [:w | w delete]! ! 408356 408357!TheWorldMenu methodsFor: 'commands' stamp: 'nk 2/15/2004 09:37'! 408358garbageCollect 408359 "Do a garbage collection, and report results to the user." 408360 408361 Utilities garbageCollectAndReport! ! 408362 408363!TheWorldMenu methodsFor: 'commands' stamp: 'sd 5/23/2003 14:49'! 408364lookForSlips 408365 408366 ChangeSet current lookForSlips! ! 408367 408368!TheWorldMenu methodsFor: 'commands' stamp: 'ar 9/27/2005 20:33'! 408369openBrowser 408370 "Create and schedule a Browser view for browsing code." 408371 ToolSet browse: nil selector: nil! ! 408372 408373!TheWorldMenu methodsFor: 'commands' stamp: 'hfm 11/29/2008 20:06'! 408374openFileList 408375 FileList prototypicalToolWindow openInWorld: myWorld! ! 408376 408377!TheWorldMenu methodsFor: 'commands' stamp: 'RAA 5/24/2000 18:53'! 408378openTranscript 408379 408380 (Transcript openAsMorphLabel: 'Transcript') openInWorld: myWorld! ! 408381 408382!TheWorldMenu methodsFor: 'commands' stamp: 'ar 9/27/2005 20:49'! 408383openWorkspace 408384 408385 UIManager default edit: '' label: 'Workspace'! ! 408386 408387!TheWorldMenu methodsFor: 'commands' stamp: 'lr 7/5/2009 23:37'! 408388quitSession 408389 SmalltalkImage current 408390 snapshot: (self confirm: 'Save changes before quitting?' translated orCancel: [ ^ self ]) 408391 andQuit: true! ! 408392 408393!TheWorldMenu methodsFor: 'commands' stamp: 'lr 7/4/2009 19:30'! 408394saveAndQuit 408395 SmalltalkImage current snapshot: true andQuit: true! ! 408396 408397!TheWorldMenu methodsFor: 'commands' stamp: 'lr 7/4/2009 19:28'! 408398saveAs 408399 | name index | 408400 name := FileDirectory baseNameFor: (FileDirectory default localNameFor: SmalltalkImage current imageName). 408401 index := name lastIndexOf: FileDirectory extensionDelimiter ifAbsent: [ nil ]. 408402 (index notNil and: [ (name copyFrom: index + 1 to: name size) isAllDigits ]) 408403 ifTrue: [ name := name copyFrom: 1 to: index - 1 ]. 408404 name := FileDirectory default nextNameFor: name extension: FileDirectory imageSuffix. 408405 name := UIManager default 408406 request: 'New Image Named:' 408407 initialAnswer: name. 408408 name isEmptyOrNil 408409 ifTrue: [ ^ self ]. 408410 SmalltalkImage current saveAs: name! ! 408411 408412!TheWorldMenu methodsFor: 'commands' stamp: 'DamienCassou 9/23/2009 08:53'! 408413saveWorldInFile 408414 "Save the world's submorphs, model, and stepList in a file. " 408415 408416 | fileName fileStream aClass | 408417 fileName := UIManager default request: 'File name for this morph?' translated. 408418 fileName isEmptyOrNil ifTrue: [^ self]. "abort" 408419 408420 "Save only model, stepList, submorphs in this world" 408421 myWorld submorphsDo: [:m | 408422 m allMorphsDo: [:subM | subM prepareToBeSaved]]. "Amen" 408423 408424 fileStream := FileStream newFileNamed: fileName, '.morph'. 408425 aClass := myWorld model ifNil: [nil] ifNotNil: [myWorld model class]. 408426 fileStream fileOutClass: aClass andObject: myWorld. 408427! ! 408428 408429!TheWorldMenu methodsFor: 'commands' stamp: 'alain.plantec 2/6/2009 17:38'! 408430setDisplayDepth 408431 "Let the user choose a new depth for the display." 408432 | result oldDepth allDepths allLabels hasBoth | 408433 oldDepth := Display nativeDepth. 408434 allDepths := #(1 -1 2 -2 4 -4 8 -8 16 -16 32 -32 ) 408435 select: [:d | Display supportsDisplayDepth: d]. 408436 hasBoth := (allDepths 408437 anySatisfy: [:d | d > 0]) 408438 and: [allDepths 408439 anySatisfy: [:d | d < 0]]. 408440 allLabels := allDepths 408441 collect: [:d | String 408442 streamContents: [:s | 408443 s 408444 nextPutAll: (d = oldDepth 408445 ifTrue: ['<on>'] 408446 ifFalse: ['<off>']). 408447 s print: d abs. 408448 hasBoth 408449 ifTrue: [s 408450 nextPutAll: (d > 0 408451 ifTrue: [' (big endian)'] 408452 ifFalse: [' (little endian)'])]]]. 408453 result := UIManager default chooseFrom: allLabels values: allDepths title: 'Choose a display depth' translated. 408454 result 408455 ifNotNil: [Display newDepth: result]. 408456 oldDepth := oldDepth abs. 408457 Display depth < 4 ~= (oldDepth < 4) 408458 ifTrue: ["Repaint windows since they look better all white in depth < 4" 408459 (myWorld windowsSatisfying: [:w | true]) 408460 do: [:w | oldDepth < 4 408461 ifTrue: [w restoreDefaultPaneColor] 408462 ifFalse: [w updatePaneColors]]]! ! 408463 408464!TheWorldMenu methodsFor: 'commands' stamp: 'stephane.ducasse 7/20/2009 19:34'! 408465startMessageTally 408466 408467 (self confirm: 'MessageTally will start now, 408468and stop when the cursor goes 408469to the top of the screen') ifTrue: 408470 [MessageTally spyAllOn: 408471 [[Sensor peekMousePt y > 0] whileTrue: [World doOneCycle]]]! ! 408472 408473!TheWorldMenu methodsFor: 'commands' stamp: 'stephane.ducasse 7/20/2009 19:35'! 408474startThenBrowseMessageTally 408475 "Tally only the UI process" 408476 408477 (self confirm: 'MessageTally the UI process until the 408478mouse pointer goes to the top of the screen') 408479 ifTrue: [TimeProfileBrowser 408480 onBlock: [[Sensor peekMousePt y > 10] 408481 whileTrue: [World doOneCycle]]]! ! 408482 408483!TheWorldMenu methodsFor: 'commands' stamp: 'nk 2/15/2004 09:31'! 408484vmStatistics 408485 "Open a string view on a report of vm statistics" 408486 408487 (StringHolder new contents: SmalltalkImage current vmStatisticsReportString) 408488 openLabel: 'VM Statistics'! ! 408489 408490 408491!TheWorldMenu methodsFor: 'construction' stamp: 'MiguelCoba 7/25/2009 02:21'! 408492appearanceMenu 408493 "Build the appearance menu for the world." 408494 408495 ^self fillIn: (self menu: 'Preferences') from: { 408496 408497 {'Preference Browser...' . { PreferenceBrowser . #open} . 'Opens a PreferenceBrowser which allows you to alter many settings' } . 408498 {'System fonts...' . { self . #standardFontDo} . 'Choose the standard fonts to use for code, lists, menus, window titles, etc.'}. 408499 nil. 408500 {#toggleScreenString . { Display . #toggleFullScreen}.}. 408501 {#soundEnablingString . { Preferences . #toggleSoundEnabling}. 'turning sound off will completely disable Squeak''s use of sound.'}. 408502 {'Set display depth...' . {self. #setDisplayDepth} . 'choose how many bits per pixel.'}. 408503 {'Set desktop color...' . {self. #changeBackgroundColor} . 'choose a uniform color to use as desktop background.'}. 408504 {'Set gradient color...' . {self. #setGradientColor} . 'choose second color to use as gradient for desktop background.'}. 408505 {'Set author full name...' . { Author . #requestFullName }. 'supply full name to be used to identify the author of code and other content.'}. 408506 }! ! 408507 408508!TheWorldMenu methodsFor: 'construction' stamp: 'damiencassou 7/31/2009 12:10'! 408509buildWorldMenu 408510 "Build the menu that is put up when the screen-desktop is clicked on" 408511 | menu | 408512 menu := MenuMorph new defaultTarget: self. 408513 menu commandKeyHandler: self. 408514 menu addStayUpItem. 408515 408516 menu 408517 defaultTarget: ToolSet default; 408518 addList: ToolSet default mainMenuItems. 408519 menu defaultTarget: self. 408520 408521 self fillIn: menu from: {nil}. 408522 408523 menu add: 'Tools' subMenu: self openMenu. 408524 menu add: 'Windows' subMenu: self windowsMenu. 408525 menu add: 'Debug' subMenu: self debugMenu. 408526 menu add: 'System' subMenu: self systemMenu. 408527 408528 self fillIn: menu from: {nil}. 408529 408530 self fillIn: menu from: { 408531 nil. 408532 {'Save'. {SmalltalkImage current. #saveSession}. 'save the current version of the image on disk'}. 408533 {'Save As...'. {self. #saveAs}. 'save the current version of the image on disk under a new name.'}. 408534 {'Save and quit'. {self. #saveAndQuit}. 'save the current image on disk, and quit out of Pharo.'}. 408535 {'Quit'. {self. #quitSession}. 'quit out of Pharo.'} 408536 }. 408537 ^ menu! ! 408538 408539!TheWorldMenu methodsFor: 'construction' stamp: 'al 10/23/2008 20:43'! 408540changesMenu 408541 "Build the changes menu for the world." 408542 408543 | menu | 408544 menu := MenuMorph new. 408545 self fillIn: menu from: { 408546 { 'file out current change set' . { ChangeSet current . #verboseFileOut}. 408547 'Write the current change set out to a file whose name reflects the change set name and the current date & time.'}. 408548 { 'create new change set...' . { ChangeSet . #newChangeSet}. 'Create a new change set and make it the current one.'}. 408549 { 'browse changed methods' . { ChangeSet . #browseChangedMessages}. 'Open a message-list browser showing all methods in the current change set'}. 408550 { 'check change set for slips' . { self . #lookForSlips}. 408551 'Check the current change set for halts, references to the Transcript, etc., and if any such thing is found, open up a message-list browser detailing all possible slips.'}. 408552 408553 nil. 408554 { 'simple change sorter' . {self. #openChangeSorter1}. 'Open a 3-paned changed-set viewing tool'}. 408555 { 'dual change sorter' . {self. #openChangeSorter2}. 408556 'Open a change sorter that shows you two change sets at a time, making it easy to copy and move methods and classes between them.'}. 408557 { 'find a change sorter (C)' . { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window'}. 408558 nil. 408559 { 'browse recent submissions' . { Utilities . #browseRecentSubmissions}. 408560 'Open a new recent-submissions browser. A recent-submissions browser is a message-list browser that shows the most recent methods that have been submitted. If you submit changes within that browser, it will keep up-to-date, always showing the most recent submissions.'}. 408561 408562 { 'find recent submissions (R)' . { #myWorld . #openRecentSubmissionsBrowser:}. 408563 'Make an open recent-submissions browser be the front-window, expanding a collapsed one or creating a new one if necessary. A recent-submissions browser is a message-list browser that shows the most recent methods that have been submitted, latest first. If you submit changes within that browser, it will keep up-to-date, always showing the most recent submissions at the top of the browser.'}. 408564 408565 nil. 408566 { 'recently logged changes...' . { self . #browseRecentLog}.'Open a change-list browser on the latter part of the changes log. You can use this browser to recover logged changes which were not saved in your image, in the event of a crash or other interruption.'}. 408567 408568 { 'recent log file...' . { Smalltalk . #writeRecentToFile}. 408569 'Create a file holding the logged changes (going as far back as you wish), and open a window on that file.'}. 408570 408571 408572 "{ 'save world as morph file' . {self. #saveWorldInFile}. 'Save a file that, when reloaded, reconstitutes the current World.'}. 408573 nil." 408574 }. 408575 "self projectForMyWorld isIsolated ifTrue: [ 408576 self fillIn: menu from: { 408577 { 'propagate changes upward' . {self. #propagateChanges}. 408578 'The changes made in this isolated project will propagate to projects up to the next isolation layer.'}. 408579 }. 408580 ] ifFalse: [ 408581 self fillIn: menu from: { 408582 { 'isolate changes of this project' . {self. #beIsolated}. 408583 'Isolate this project and its subprojects from the rest of the system. Changes to methods here will be revoked when you leave this project.'}. 408584 }. 408585 ]". 408586 408587 ^ menu! ! 408588 408589!TheWorldMenu methodsFor: 'construction' stamp: 'stephane.ducasse 7/20/2009 19:37'! 408590debugMenu 408591 | menu | 408592 menu := MenuMorph new. 408593 self fillIn: menu from: { 408594 {'Vm statistics' . { self . #vmStatistics}. 'obtain some intriguing data about the vm.'}. 408595 {'Space left' . { self . #garbageCollect}. 'perform a full garbage-collection and report how many bytes of space remain in the image.'}. 408596 { 'Start profiling all Processes' . { self . #startMessageTally } }. 408597 { 'Start profiling UI ' . { self . #startThenBrowseMessageTally } }. 408598 nil. 408599 { 'start drawing again' . { #myWorld . #resumeAfterDrawError } }. 408600 { 'start stepping again' . { #myWorld . #resumeAfterStepError } }. 408601 nil. 408602 {'close all debuggers'. { Utilities. #closeAllDebuggers } }. 408603 {'restore display (r)'. { World. #restoreMorphicDisplay }. 'repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.' } }. 408604 self haltOnceEnabled 408605 ifTrue: [menu 408606 add: 'Disable halt/inspect once' translated 408607 target: menu 408608 action: #clearHaltOnce] 408609 ifFalse: [menu 408610 add: 'Enable halt/inspect once' translated 408611 target: menu 408612 action: #setHaltOnce]. 408613 ^menu 408614 ! ! 408615 408616!TheWorldMenu methodsFor: 'construction' stamp: 'sd 3/1/2008 21:14'! 408617fillIn: aMenu from: dataForMenu 408618 "A menu constructor utility by RAA. dataForMenu is a list of items which mean: 408619 nil Indicates to add a line 408620 408621 first element is symbol Add updating item with the symbol as the wording selector 408622 second element is a list second element has the receiver and selector 408623 408624 first element is a string Add menu item with the string as its wording 408625 second element is a list second element has the receiver and selector 408626 408627 a third element exists Use it as the balloon text 408628 a fourth element exists Use it as the enablement selector (updating case only)" 408629 | item | 408630 408631 dataForMenu do: [ :itemData | 408632 itemData ifNil: [aMenu addLine] ifNotNil: 408633 [item := (itemData first isKindOf: Symbol) 408634 ifTrue: 408635 [aMenu 408636 addUpdating: itemData first 408637 target: self 408638 selector: #doMenuItem:with: 408639 argumentList: {itemData second}] 408640 ifFalse: 408641 [aMenu 408642 add: (itemData first translated) capitalized 408643 target: self 408644 selector: #doMenuItem:with: 408645 argumentList: {itemData second}]. 408646 itemData size >= 3 ifTrue: 408647 [aMenu balloonTextForLastItem: itemData third translated. 408648 itemData size >= 4 ifTrue: 408649 [item enablementSelector: itemData fourth]]]]. 408650 408651 ^ aMenu! ! 408652 408653!TheWorldMenu methodsFor: 'construction' stamp: 'marcus.denker 9/19/2008 18:33'! 408654helpMenu 408655 "Build the help menu for the world." 408656 | menu | 408657 menu := self menu: 'Help'. 408658 self fillIn: menu from: { 408659 {'Command-key help'. { Utilities . #openCommandKeyHelp}. 'summary of keyboard shortcuts.'} 408660 }. 408661 ^menu 408662 408663! ! 408664 408665!TheWorldMenu methodsFor: 'construction' stamp: 'al 10/23/2008 20:40'! 408666openMenu 408667 "Build the open window menu for the world." 408668 408669 | menu | 408670 menu := MenuMorph new. 408671 menu defaultTarget: ToolSet default. 408672 menu addList: ToolSet menuItems. 408673 menu defaultTarget: self. 408674 ^ self fillIn: menu from: {nil. {'more...'. {self. #registeredToolsDo}}}! ! 408675 408676!TheWorldMenu methodsFor: 'construction' stamp: 'al 10/12/2008 21:26'! 408677registeredToolsMenu 408678 | menu | 408679 menu := self menu: 'Other Tools'. 408680 menu defaultTarget: self. 408681 ^ self fillIn: menu from: self class registeredOpenCommands. 408682 ! ! 408683 408684!TheWorldMenu methodsFor: 'construction' stamp: 'marcus.denker 8/1/2009 13:28'! 408685systemMenu 408686 | menu | 408687 menu := MenuMorph new. 408688 self fillIn: menu from: { 408689 {'About...'. {SmalltalkImage current. #aboutThisSystem}}. 408690 {'Software update'. {Utilities. #updateFromServer}. 'load latest code updates via the internet'}. 408691 {'Preferences...'. {self. #appearanceDo}}}. 408692 ^menu 408693 ! ! 408694 408695!TheWorldMenu methodsFor: 'construction' stamp: 'al 10/23/2008 20:40'! 408696windowsMenu 408697 "Build the windows menu for the world." 408698 408699 ^ self fillIn: MenuMorph new from: { 408700 "{ 'find window' . { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.'}. 408701 408702 { 'find changed browsers...' . { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.'}. 408703 408704 { 'find changed windows...' . { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.'}. 408705 nil. 408706 408707 { 'find a transcript (t)' . { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window'}. 408708 408709 { 'find a fileList (L)' . { #myWorld . #findAFileList: }. 'Brings an open fileList to the front, creating one if necessary, and makes it the active window'}. 408710 408711 { 'find a change sorter (C)' . { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window'}. 408712 408713 { 'find message names (W)' . { #myWorld . #findAMessageNamesWindow: }. 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window'}. 408714 408715 nil. 408716 { #staggerPolicyString . { self . #toggleWindowPolicy }. 'stagger: new windows positioned so you can see a portion of each one. 408717 tile: new windows positioned so that they do not overlap others, if possible.'}. 408718 nil. 408719 " 408720 { 'collapse all windows' . { #myWorld . #collapseAll }. 'Reduce all open windows to collapsed forms that only show titles.'}. 408721 { 'expand all windows' . { #myWorld . #expandAll }. 'Expand all collapsed windows back to their expanded forms.'}. 408722 "{ 'close top window (w)' . { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.'}." 408723 { 'send top window to back (\)' . { SystemWindow . #sendTopWindowToBack }. 'Make the topmost window become the backmost one, and activate the window just beneath it.'}. 408724 { 'move windows onscreen' . { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen'}. 408725 { 'delete unchanged windows' . { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.'}. 408726 " { 'delete non-windows' . { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.'}. 408727 { 'delete both of the above' . { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.'}." 408728 408729 }! ! 408730 408731 408732!TheWorldMenu methodsFor: 'mechanics' stamp: 'adrian_lienhard 7/21/2009 19:12'! 408733adaptToWorld: aWorld 408734 myWorld := aWorld. 408735 408736 "figure it out if and when needed. maybe make it easier to find" 408737 myProject := nil. 408738 myHand := aWorld primaryHand.! ! 408739 408740!TheWorldMenu methodsFor: 'mechanics' stamp: 'marcus.denker 9/19/2008 16:54'! 408741menu: titleString 408742 "Create a menu with the given title, ready for filling" 408743 408744 | menu | 408745 (menu := MenuMorph entitled: titleString translated capitalized) 408746 defaultTarget: self; 408747 addStayUpItem; 408748 commandKeyHandler: self. 408749 ^ menu 408750! ! 408751 408752!TheWorldMenu methodsFor: 'mechanics' stamp: 'dao 10/1/2004 13:12'! 408753suppressFlapsString 408754 "Answer the wording of the suppress-flaps item" 408755 408756 ^ Project current suppressFlapsString! ! 408757 408758!TheWorldMenu methodsFor: 'mechanics' stamp: 'RAA 5/24/2000 19:02'! 408759world: aWorld project: aProject hand: aHand 408760 408761 myWorld := aWorld. 408762 myProject := aProject. 408763 myHand := aHand.! ! 408764 408765 408766!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:25'! 408767appearanceDo 408768 "Build and show the appearance menu for the world." 408769 408770 self doPopUp: self appearanceMenu! ! 408771 408772!TheWorldMenu methodsFor: 'popups' stamp: 'stephane.ducasse 7/10/2009 15:50'! 408773commandKeyMappings 408774 ^ (self class firstCommentAt: #commandKeyMappings) translated 408775 408776"Lower-case command keys 408777(use with Cmd key on Mac and Alt key on other platforms) 408778a Select all 408779b Browse it (selection is a class name or cursor is over a class-list or message-list) 408780c Copy selection 408781d Do it (selection is a valid expression) 408782e Method strings containing it (case insensitive) 408783f Find 408784g Find again 408785h Set selection as search string for find again 408786i Inspect it (selection is a valid expression, or selection is over an inspect-ilst) 408787j Again once (do the last text-related operation again) 408788k Set font 408789l Cancel 408790m Implementors of it (selection is a message selector or cursor is over a class-list or message-list) 408791n Senders of it (selection is a message selector or cursor is over a class-list or message-list) 408792o Spawn current method 408793p Print it (selection is a valid expression) 408794q Query symbol (toggle all possible completion for a given prefix) 408795r Recognizer 408796s Save (i.e. accept) 408797t Finds a Transcript (when cursor is over the desktop) 408798u Toggle alignment 408799v Paste 408800w Delete preceding word (over text); Close-window (over morphic desktop) 408801x Cut selection 408802y Swap characters 408803z Undo 408804 408805Note: for Do it, Senders of it, etc., a null selection will be expanded to a word or to the current line in an attempt to do what you want. Also note that Senders/Implementors of it will find the outermost keyword selector in a large selection, as when you have selected a bracketed expression or an entire line. Finally note that the same cmd-m and cmd-n (and cmd-v for versions) work in the message pane of most browsers. 408806 408807Upper-case command keys 408808 (use with Shift-Cmd, or Ctrl on Mac 408809 or Shift-Alt on other platforms; sometimes Ctrl works too) 408810A Advance argument 408811B Browse it in this same browser (in System browsers only) 408812C Compare argument to clipboard 408813D Debug it 408814E Method strings containing it (case sensitive) 408815F Insert 'ifFalse:' 408816G fileIn from it (a file name) 408817H cursor TopHome: 408818I Inspect via Object Explorer 408819J Again many (apply the previous text command repeatedly until the end of the text) 408820K Set style 408821L Outdent (move selection one tab-stop left) 408822M Select current type-in 408823N References to it (selection is a class name, or cursor is over a class-list or message-list) 408824O Open single-message browser (in message lists) 408825P Make project link 408826R Indent (move selection one tab-stap right) 408827S Search 408828T Insert 'ifTrue:' 408829U Convert linefeeds to carriage returns in selection 408830V Paste author's initials 408831W Selectors containing it (in text); show-world-menu (when issued with cursor over desktop) 408832X Force selection to lowercase 408833Y Force selection to uppercase 408834Z Capitalize all words in selection 408835 408836Other special keys 408837Backspace Backward delete character 408838Del Forward delete character 408839Shift-Bksp Backward delete word 408840Shift-Del Forward delete word 408841Esc Pop up the Desktop Menu 408842\ Send top window to back 408843 408844Cursor keys 408845left, right, 408846up, down Move cursor left, right, up or down 408847Ctrl-left Move cursor left one word 408848Ctrl-right Move cursor right one word 408849Home Move cursor to begin of line or begin of text 408850End Move cursor to end of line or end of text 408851PgUp, Ctrl-up Move cursor up one page 408852PgDown, Ctrl-Dn Move cursor down one page 408853 408854Note all these keys can be used together with Shift to define or enlarge the selection. You cannot however shrink that selection again, as in some other systems. 408855 408856Other Cmd-key combinations (not available on all platforms) 408857Return Insert return followed by as many tabs as the previous line 408858 (with a further adjustment for additional brackets in that line) 408859Space Select the current word as with double clicking 408860 408861Enclose the selection in a kind of bracket. Each is a toggle. 408862 (not available on all platforms) 408863Ctrl-( Enclose within ( and ), or remove enclosing ( and ) 408864Ctrl-[ Enclose within [ and ], or remove enclosing [ and ] 408865Crtl-{ Enclose within { and }, or remove enclosing { and } 408866Ctrl-< Enclose within < and >, or remove enclosing < and > 408867Ctrl-' Enclose within ' and ', or remove enclosing ' and ' 408868Ctrl-"" Enclose within "" and "", or remove enclosing "" and "" 408869Note also that you can double-click just inside any of the above delimiters, 408870or at the beginning or end of a line, to select the text enclosed. 408871 408872Text Emphasis 408873 (not available on all platforms) 408874Cmd-1 10 point font 408875Cmd-2 12 point font 408876Cmd-3 18 point font 408877Cmd-4 24 point font 408878Cmd-5 36 point font 408879Cmd-6 color, action-on-click, link to class comment, link to method, url 408880 Brings up a menu. To remove these properties, select 408881 more than the active part and then use command-0. 408882Cmd-7 bold 408883Cmd-8 italic 408884Cmd-9 narrow (same as negative kern) 408885Cmd-0 plain text (resets all emphasis) 408886Cmd-- underlined (toggles it) 408887Cmd-= struck out (toggles it) 408888 408889Shift-Cmd-- (aka :=) negative kern (letters 1 pixel closer) 408890Shift-Cmd-+ positive kern (letters 1 pixel larger spread) 408891"! ! 408892 408893!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 6/12/2000 09:13'! 408894doPopUp: aMenu 408895 408896 aMenu popUpForHand: myHand in: myWorld. 408897! ! 408898 408899!TheWorldMenu methodsFor: 'popups' stamp: 'stephane.ducasse 7/10/2009 15:54'! 408900openCommandKeyHelp 408901 "Open a window giving command key help." 408902 408903 (StringHolder new contents: self commandKeyMappings) 408904 openLabel: 'Command Key Actions' translated 408905! ! 408906 408907!TheWorldMenu methodsFor: 'popups' stamp: 'al 10/12/2008 21:25'! 408908registeredToolsDo 408909 408910 self doPopUp: self registeredToolsMenu! ! 408911 408912!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:27'! 408913standardFontDo 408914 "Build and show the standard font menu" 408915 408916 self doPopUp: Preferences fontConfigurationMenu! ! 408917 408918"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 408919 408920TheWorldMenu class 408921 instanceVariableNames: ''! 408922 408923!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'ar 9/27/2005 20:13'! 408924loadSqueakMap 408925 "Load the externally-maintained SqueakMap package if it is not already loaded. Based on code by Göran Hultgren" 408926 408927 | server addr answer | 408928 Socket initializeNetwork. 408929 server := #('map1.squeakfoundation.org' 'map2.squeakfoundation.org' 'map.squeak.org' 'map.bluefish.se' 'marvin.bluefish.se:8000') 408930 detect: [:srv | 408931 addr := NetNameResolver addressForName: (srv upTo: $:) timeout: 5. 408932 addr notNil and: [ 408933 answer := HTTPSocket httpGet: ('http://', srv, '/sm/ping'). 408934 answer isString not and: [answer contents = 'pong']]] 408935 ifNone: [^ self inform: 'Sorry, no SqueakMap master server responding.']. 408936 server ifNotNil: ["Ok, found an SqueakMap server" 408937 ChangeSet newChangesFromStream: 408938 ((('http://', server, '/sm/packagebyname/squeakmap/downloadurl') 408939 asUrl retrieveContents content) asUrl retrieveContents content unzipped 408940 readStream) 408941 named: 'SqueakMap']! ! 408942 408943!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'sw 11/10/2002 22:56'! 408944registerOpenCommand: anArray 408945 "The array received should be of form {'A Label String'. {TargetObject. #command} 'A Help String'} ; the final element is optional but if present will be used to supply balloon help for the menu item in the Open menu. 408946 If any previous registration of the same label string is already known, delete the old one." 408947 408948 self unregisterOpenCommand: anArray first. 408949 OpenMenuRegistry addLast: anArray! ! 408950 408951!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'nk 6/29/2003 13:56'! 408952registeredOpenCommands 408953 "Answer the list of dynamic open commands, sorted by description" 408954 408955 ^self registry asArray sort: [ :a :b | a first asLowercase < b first asLowercase ]! ! 408956 408957!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'nk 6/29/2003 13:55'! 408958registry 408959 "Answer the registry of dynamic open commands" 408960 408961 ^OpenMenuRegistry ifNil: [OpenMenuRegistry := OrderedCollection new]. 408962! ! 408963 408964!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'ar 9/27/2005 21:49'! 408965removeObsolete 408966 "Remove all obsolete commands" 408967 self registry removeAllSuchThat: [:e | e second first class isObsolete].! ! 408968 408969!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'nk 6/29/2003 13:55'! 408970unregisterOpenCommand: label 408971 "Remove the open command with the given label from the registry" 408972 408973 self registry removeAllSuchThat: [:e | e first = label]! ! 408974 408975!TheWorldMenu class methodsFor: 'open-menu registry' stamp: 'nk 6/29/2003 13:55'! 408976unregisterOpenCommandWithReceiver: aReceiver 408977 "Remove the open command with the given object as receiver from the registry" 408978 408979 self registry removeAllSuchThat: [:e | e second first == aReceiver]! ! 408980Object subclass: #ThemeIcons 408981 instanceVariableNames: '' 408982 classVariableNames: '' 408983 poolDictionaries: '' 408984 category: 'Polymorph-Widgets-Themes'! 408985!ThemeIcons commentStamp: 'gvc 5/18/2007 10:25' prior: 0! 408986Some extra icons in the vein of MenuIcons.! 408987 408988 408989"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 408990 408991ThemeIcons class 408992 instanceVariableNames: 'icons'! 408993 408994!ThemeIcons class methodsFor: 'as yet unclassified' stamp: 'gvc 7/25/2006 16:33'! 408995base64ContentsOfFileNamed: aString 408996 "Private - convenient method" 408997 408998 | file base64Contents | 408999 file := FileStream readOnlyFileNamed: aString. 409000 base64Contents := (Base64MimeConverter mimeEncode: file binary) contents. 409001 file close. 409002 ^ base64Contents! ! 409003 409004!ThemeIcons class methodsFor: 'as yet unclassified' stamp: 'gvc 9/25/2008 15:41'! 409005clearIcons 409006 "Clear the forms. Will be recreated on demand." 409007 409008 icons := IdentityDictionary new! ! 409009 409010!ThemeIcons class methodsFor: 'as yet unclassified' stamp: 'gvc 9/25/2008 15:42'! 409011createIconMethodsFromDirectory: directory 409012 "Create the methods for the icons. 409013 (self createIconMethodsFromDirectory: '')." 409014 409015 | iconContentsSourceTemplate iconSourceTemplate normalSize smallSize | 409016 iconContentsSourceTemplate := '{1}IconContents 409017 "Private - Method generated with the content of the file {2}" 409018 ^ ''{3}'''. 409019 iconSourceTemplate := '{1} 409020 "Private - Generated method" 409021 ^icons 409022 at: #{1} 409023 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self {1}Contents readStream) ].'. 409024 normalSize := self normalSizeNames. 409025 smallSize := self smallSizeNames. 409026 normalSize , smallSize 409027 do: [:each | 409028 | png base64 contentsSelector selector | 409029 png := directory , each, '.png'. 409030 [base64 := self base64ContentsOfFileNamed: png.] 409031 on: Error do: [base64 := nil]. 409032 base64 ifNotNil: [ 409033 contentsSelector := (each , 'IconContents') asSymbol. 409034 ((self respondsTo: contentsSelector) 409035 and: [(self perform: contentsSelector) = base64]) 409036 ifFalse: [| contentsSource | 409037 contentsSource := iconContentsSourceTemplate format: {each. png. base64}. 409038 self class compile: contentsSource classified: 'private - icons']. 409039 selector := (each , 'Icon') asSymbol. 409040 (self respondsTo: selector) 409041 ifFalse: [| source | 409042 source := iconSourceTemplate format: {selector}. 409043 self class compile: source classified: 'private - icons']]]. 409044 self initializeIcons! ! 409045 409046!ThemeIcons class methodsFor: 'as yet unclassified' stamp: 'gvc 12/21/2006 16:02'! 409047initialize 409048 "Initialize the class." 409049 409050 self initializeIcons! ! 409051 409052!ThemeIcons class methodsFor: 'as yet unclassified' stamp: 'gvc 9/25/2008 15:41'! 409053initializeIcons 409054 "self initializeIcons" 409055 409056 | methods | 409057 icons := IdentityDictionary new. 409058 methods := self class selectors 409059 select: [:each | '*Icon' match: each asString]. 409060 methods 409061 do: [:each | icons 409062 at: each 409063 put: (self perform: each)]! ! 409064 409065!ThemeIcons class methodsFor: 'as yet unclassified' stamp: 'gvc 7/23/2008 13:01'! 409066normalSizeNames 409067 "Answer the names of the normal icons" 409068 409069 ^#('error' 'info' 'lock' 'question' 'warning' 'upArrow' 'downArrow' 'backspaceArrow')! ! 409070 409071!ThemeIcons class methodsFor: 'as yet unclassified' stamp: 'gvc 3/6/2009 13:04'! 409072smallSizeNames 409073 "Answer the names of the small icons" 409074 409075 ^#('smallError' 'smallInfo' 'smallLock' 'smallQuestion' 'smallWarning' 'smallPushpin' 409076 'smallBold' 'smallItalic' 'smallUnderline' 'smallStrikeOut' 'smallBarcode' 409077 'smallHierarchyBrowser' 'smallSystemBrowser')! ! 409078 409079 409080!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:42'! 409081backspaceArrowIcon 409082 "Private - Generated method" 409083 ^icons 409084 at: #backspaceArrowIcon 409085 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self backspaceArrowIconContents readStream) ].! ! 409086 409087!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 7/23/2008 13:20'! 409088backspaceArrowIconContents 409089 "Private - Method generated with the content of the file graphics\icons\backspaceArrow.png" 409090 ^ 'iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAYAAADgdz34AAAABGdBTUEAALGPC/xhBQAAABh0 409091RVh0U29mdHdhcmUAUGFpbnQuTkVUIHYzLjMxN4N3hgAAAHJJREFUSEvtU1sKACAIq5t5NG/e 4090926yOilyEO+nAQBOGmy8VUEJCoAkgEJHlzxwUkB/6wiIikRo/v1wlKPGpG2tFiW8nMndhUYOzY 4090934t5zYEG241iCZi10TDLsD+ZNgW3RLATLgXb3xzp9gh7VXUA0yi0SLcpPYbE3TaR0wwAAAABJ 409094RU5ErkJggg=='! ! 409095 409096!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:43'! 409097downArrowIcon 409098 "Private - Generated method" 409099 ^icons 409100 at: #downArrowIcon 409101 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self downArrowIconContents readStream) ].! ! 409102 409103!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 3/18/2009 13:39'! 409104downArrowIconContents 409105 "Private - Method generated with the content of the file graphics\icons\downArrow.png" 409106 ^ 'iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAYAAADgdz34AAAABGdBTUEAALGPC/xhBQAAABh0 409107RVh0U29mdHdhcmUAUGFpbnQuTkVUIHYzLjM2qefiJQAAAHxJREFUSEvtVFsOgCAM05vtaLu5 409108UtREjNDuQ+LHmpBAGPQB2boVLF8CBCqKDoipQ4VeeThNgnGyGRH9eRlRRvSaAO1FZtb0oPtP 409109whz7I1CCs513SdjD/YOg54Kpr+eUItS4exMT1gpkgqcL5fKQgykEF4mqPuxgCkFEPWp3+R+x 409110NwMbsR8AAAAASUVORK5CYII='! ! 409111 409112!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:44'! 409113errorIcon 409114 "Private - Generated method" 409115 ^icons 409116 at: #errorIcon 409117 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self errorIconContents readStream) ].! ! 409118 409119!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/29/2007 12:43'! 409120errorIconContents 409121 "Private - Method generated with the content of the file icons\base\error.png" 409122 ^ 'iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAYAAABXAvmHAAAABHNCSVQICAgIfAhkiAAAAAlw 409123SFlzAAAN1wAADdcBQiibeAAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 409124AArUSURBVGiBxZltcFTVGcd/597NbpZsdskLYEhCcORFUqwgKjp+kCkzteqgtZUMU2sraqdV 409125B3zDTsdROtMPTrVWodDWsRZHK6MzpVPEqcWpUqliQytVQwhWEkiCFbJJNiG7d1/uyzn9cO9N 409126NmHJO+2dOXP32Xt37+//nOc85znnCqUUUzn6hLhYW7r0biKRBaK0tIRIJEI4HEHTNJnJpFQq 409127ZchkMqUM45TV2vqiNIyD1VN9aN4hJvNfA5WVK8X8+RtEXV190erV84INDRWisnL4TUqBEENm 409128KkV2z55k5vXXT9odHcfsL77YMbezc8//VECypKReLFu2tei221YEv/vdMlFSgh2Pk21uxmxv 409129x04ksHt7sXt7UZaFVlKCiEbRo1GCtbWUXHklxQsWoEyTzJ49meT27c32iROPVnd2vn1eBSSF 409130mK1dfvmvAmvWXBP84Q8vUJZF+sABsocPY546hbJtlG0jvXMh2/+sz5xJZOVKym+9lVBtLckd 409131O/qSO3YcyjU1bbwwlTo67QJS1dVXaStWvBR+6aVFlJSQPnAAY/9+ZDpdEHA0+EFbStA0ytas 409132Yc5dd6FHIvQ88EBH6q23Nl/Y1vbytAkwliz5nn799ZuLn366JvfZZyTfeAOnrw/lOEjLGhf8 409133WWKkRCk12AiFmHvvvcxqaKD/17/u7tm2befCo0cfVkrJKQkwli//aXDjxu8VrV9fnv7b30jt 40913424cyzbPgx/T2KPBKSqT3ufzGG5n/6KNkGhsz/9mw4S83NDWtbQVLjREiBQUY9fV3BzdtejLw 409135ne+Up15/nUxT0xDEeYD37Rlf+hKLnn0Wq7U1d2z9+leWffrpBiA3Wm9oI79IVVev1K+77sdF 409136d955NrwP5Diu7Z2nA14qRfLwYY7edx/Fy5aFqh9++Jt76+ruB0qEEPq4BCSFqNRWrHi5+Oc/ 409137r0m/997Z8JblwluWC+/ZMk/UZOF9O9XSwrHHH6fy7rtnXrxmzYNPxmJfBSJCiMCYArSVK7eF 409138X3xxkXnsGKl33ins+ZHweaIGxUwS3rfjb77JyRdeoOaZZ2avXrLkJ8AF5+qJQQHJ0tJFgRtu 409139uJZolIE9e1ygQqHhe7oQfP74yAebALxvn9i6lVRnJ1UbNlz0zOzZ64HZQFgIoRUUoC1b9ovg 409140I49UpT/4AKe/f1zpUY0Ukwc/0vsTgVdSIk2T9i1bKLnxxtDVCxfeFoY6oAIICjFUo2gAyWh0 409141WdG6dVcoKTH27594bs8XVAh+gmL8e3r27mXgk0+Yu2nT3Ceqqu4AqoAoEBgmQCxceH/Rt79d 409142nm5sRBrGxOH9UJJybPh8exR43/7it78lcOWVWv2cOVcB1cCs/FByBcyd+2URi5E9fPi8wqsJ 409143wiulONPYiGUYlC5YUFEJNd6AHuwFrV+IxfqqVbVOXx/myZOTC5txwo+EGwteKoXM5Tjz978T 409144+8Y3ordHo1d7PVABFAshREBbvHh9cN26WZnm5uEDVNcRmgaaBrru2roOug6BAJp/nwev+Q+H 4091454XYekPCFeGI0TyjefUg52KRhDP524L33qHjgAW1lVdWlDAzsB8qBLiAdENHoQq26GnPfPpRt 409146I4JBZj30EKGLLio0b0z6cBwHy7IGm2maw+yRzezsJLd9O6qzk3RLCzEpKY5GZwAlQBlQCpzR 409147iEZLAXcRYtuEr7hi2uFt28Y0zWHtLOCR1ysqkKtWIZXC6u3Ftm0CxcUhIIQ7BmJAMEBpaQTA 4091487ulB2jaiqGja4cfj8UL3OJrmhtmZMzjZLIFQKAgU4fZCKRDSmDGjFMDq6UHZthuD03QU8uxo 409149baQg2xtjSily8TiislKfCxEgCISBYAAhBEq5tb73g6keSqkJe7tQU7ZNwBvglmki3WJIw02h 409150ISAYUOl0EiHQSktxDAPlONMCP5mQGdmEZQ2mU2Ix7K4u53PI4IooAoo0mUqlAPRYzM3tpjlp 409151eCnllEJm5HUnl0MqhSguxtF1coZhKRCeAB3QNTUwkATQYjGUbTPw7rvYfX0ThnccZ0JwY4pL 409152pQh++KEb0rEYtm2Ty2SsvEcKQARkMnlSJhIE581D2TZWVxfH1q4lWFMDmjZ85oThs6hny7zJ 409153SToOjjc5yfxr52hKSjQpCUiJLiUh/7vubndcKoWorcVxHDKGkc3vcEAGrJaWl7K7d99esnp1 409154WfcLLwyWCNm2tnEVX+OtLM9loxR4s7KSEuFfz3uutnw5qrVVfRKPt4M72QM2YGkXKPWv3J// 4091553BGqq0OfNWswE/0v4M9p5z9X02DpUnJvvZX6fTJ51BPgABZgaQB2R8enyjSJXHXV/x9+RBML 409156FuAUF5Nqa0uedjOQ8ryfA0xXQHv785ldu5Llt9wCuj6pBci0wef9n1QKcd11qPZ29Vl3d6cX 409157Oo4HbwwKqIrH/2o891xTcM4cZt5006hl8bR6epT1glQKsXgxaulSzJdf7tuSSPzDgzeBFHAG 409158yA2uic1//3tT8pe/7J1z552IcLgw/MgHTqOnz7KVQlu7Fo4ccQ4eP37EcL3uAFkPfmCwBwCq 409159u7oajdde+6deVETVPfec5Z0xt0imE15KxKpVODU1mK++mtg+MPBh3sBNAQnvbA/bojA/+uje 4091603vvua5+1di3lN988apyPOi6mCr9oETQ0IHbtSv+hs/MD2x20NpAGeoFuwFBKyWEC5mWzJ7IH 409161Dz7Y/7Ofddf96EdELrtsUhlovDFeyKaiAnHPPfDRR1bTvn3Nf8xmW/OyTj/uSizhjYWz90Zr 409162jh7dndy587nM22+nFz79NCWXXjpl+HPBFoS//37o71c9r7zS8URf3/sevAkkPfhTQEop5RQU 409163AFD78cebezdv3m0eOpSt/81vmLVmzXmHF4sXoz32GMK2VXrr1lOPdHW9mQef8uBPeiGU81lH 409164fcHRcdllT0XvuOOuso0byz/fsYPjW7YgTXN64ZVC/8pXoKEBDh2y4zt3tj9y+vSfst5E5cGf 409165Bo4BbUBCKTVY1I35iun4JZd8K3zNNU9dsG1bda6ri+PPPsvpN94YykpTgNfq69FuvRVZU4PY 409166tSvz8TvvND2RSOSHjQHEgeMefLdSKpfPN66XfM21tZeG6+qeK//BDy6JrltX0t/cTMfzz9O3 409167fz+2YYxZzwyzdR2tvp7A176GuvhiVFOTk3nttd5dnZ0HdqfT/oD1PR8H2r3WDWTVCOBxv2YV 409168Qmjv19U1lM+f/1jFQw8tDF17bTCXTtPf2Eji3XdJHzmC2dWFmUi4sB4wkQiirAy9rg59+XLE 4091690qXYgQCqrU1lfve7xIHjx5u29/d/qNw872ebAdyY78CN+0Qh+AkJ8EVUQPiVefO+X1ZVtTZ0 4091704YXzSm+5Zba+YkXAwV3EW9ksuXgcO5tFzZyJo2nYto1tWciWFpXZuzeZPHFioKW7+8TWROJg 4091712p2c/BIhjZsqTwOf42acM4BZCH7CAjwRAndXILIAqr8fiXx9SXX19YFYrFwrLg7r4XCxFo2G 409172lK6LXE+PlTUMK5dOm5mBgdzH8Xjrq4bREnerSr8wM3G9nsTNMKe91os7Wdmj8kxUQJ4Qf2eg 409173FHerrwKYCcTKoCwEM067IaHjLv/8QzK0IMkyVJglgB6GygRTjeNV66QFeCIEQ1scYU9M1DuH 409174ve+L8kT4tbwf6wZDhZmBG0KmP0mNi2EqAkYIGdzqyAP3my/A97yNG/t++FiAPR6PnxcBw/7Q 409175FeML0vI+g9sD/ppW+va5Buh4jv8CDd/IyOYopYAAAAAASUVORK5CYII='! ! 409176 409177!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:45'! 409178infoIcon 409179 "Private - Generated method" 409180 ^icons 409181 at: #infoIcon 409182 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self infoIconContents readStream) ].! ! 409183 409184!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/29/2007 12:43'! 409185infoIconContents 409186 "Private - Method generated with the content of the file icons\base\info.png" 409187 ^ 'iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAYAAABXAvmHAAAABHNCSVQICAgIfAhkiAAAAAlw 409188SFlzAAAN1wAADdcBQiibeAAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 409189AAuwSURBVGiBtZl7cFTXfcc/5660D1YP9ECykIRMgoQtwOZlHqaeOKYTSDxOGtcwnqStTcDj 409190Gsdx3IS0k6Z0JjN1GscOdqGtmweOXXucmZIGQ2yTGMcFBwyYhw3ijUAPjJ4rCe3z3nvuOf1j 40919170oraSWtRLIzZ/aeK83ez/d3fq9zrtBacyMfsb73lrmVxoY8P7PyfSKY5yMv4CXPACNuq0gk 409192oaPhhIpEE7rtUqf9UtRUh/UvKm/soenPn4yA0if7l95cKp6oKRb1K+tzZ6y9w1tSmieG/I8G 4091930u9EEppdJxLhN47HW5tD8uK1Xrm9Zcv0XTeGP0EBwY3h+vnV4oWvLstd9NCd3qKgT9DZL2lo 409194TdDUZdETkYQiklBYYktN0GdQEBAUBDxUl3hZMivIrAo/ltTsOh6Pb3sn3HClS3635fnKvX9S 409195AeKRcNniGuM/7rs9Z8V3Vntvsh3NgfMxTrUkaOuzkI5GKo10VPJ6YKih10ozdYqHpbV5PLCs 409196mOpSH9v3hXu37wsfO9lqfiPys5ln/+gCKjdFli2aYbz88vpAXdALBy7E2Hc2SsxUg4BZwqfm 409197SikMAfctLmL9ynLy/B6++Wp3828/jmxu3DLzlT+agFs3Rx/5/BzP5mfX+qsutJvsPhamN+rg 409198OBp7CNQY8MPEKaXQWg8MXw5sXD2dtSum8Z97+7q27ul+7exztd/SWqtsBOSM9ocF34/+63dW 409199eR9ZtyK3eP+5GL9viGA5OgP80FE4xeDmUj9CQGOHyZXOxKjwSmtipuJHO1s40xrhuw/cPG1O 409200lffRJ4wLnxJTa9dw/ZKtx3GRjCtQvzm64duf8/7wb5bnFL9xLMLJlvgAxEj4Qes+eGcR9y4s 409201xGMM5p/3TvfzL7/6hITljIDXaYKU1sypmsKW9XVc6rDNdVsvvnpu6/wnAHOs1TCG36jcFFm6 409202ao7nn7/2Z7kj4KVKwjvu3EmDv7s+jy8unjoEHuCzcwrYuKp8XHitFKeawzz+X2eZX+P3fetL 409203lX9Z89CeJ4GgEMKTlQDxSLh00QzjlefW+qvePx8bAW8PuFASPjWXjmJ5Xd6oy7xyXsG48Kn5 409204mdYI//TaRTasLJ163123PFV4zw8/B+QJITK6+xABS2caW19aF6i72G7x7qnIYBAq5Vp8JLzt 409205KByl8eWKTL8PgC/XQDA+fGr+1tFOfva7Vn78UFXZrYtWfh+4abSVGBCQ/3i47gvzcj5TEIBd 409206x/qxR0mPKbdJh7cdzcdNsVEFnLgcRars4FPzF3ZfoaUzwhP3Vny6bPWP1wFlQEAIMcToA5P5 4092071ca/bVrlrTh4IUZf1Bk/tyuNo/SAmFf2d3P2k/gI+I7rNs/sbJ0QvNIay1Y8/0YT984P+mpv 409208W/5VcgI1QAngFUIMLLfQWlPw9fD8H9zve/fhFTnFz/2mm6ilxoUfXqhsR6OV5p55Bcye7ifX 409209I2hsT/DmsRDRhBwaxOOJSbv388fr6IlqtfHp/3297a2ntgGXgV6ttQ1uHagtE0/+1fLc4kMX 409210o2PDq9HhHSf58D0nenn7eGbYicIrrfn53mv84CvVRnlN/bI2+DUQBhJCCEdrrQyA6UXitsKA 4092114FRrYmz4DC1COvxYsEMAs4TXWnPo/HWiCZtZlfklBEqr3IAuSBk/R2zom/3sGn91b9ShNWRN 409212CF6mwc+tDvDZuQUk62Ly4WjQaM60RvnN0e4RcOPBa6UwHc0H565z/5LCgt/d9tfL+w9v6QC6 409213gX4hhJ0zu9xY9+AS77SG1viE4WWa5WsrfKy9szRjFtr9YRe7j3SOCzva/P1z/XxzdYlRUbf0 4092149v7D7AOKgQ4gZhQERG1lkUFTlzVp+KQlM6dQpRTSticNnyxuMZQjKQj6pwBBoAjIB3KNAj/5 409215AKGwvAF4TXIPNhLeNE2ktAddZoLwWilCYRspJX5fjg/wuTFQCHhz8v3kAXSH5aThM62A1hrL 409216srAsC9uWI4J2ImKuxxQJy8HnzfECue4q5AM+Y4o3uQLd/fak4VMPTIc3TRPTNLEsCynlmIUr 409217m4Du7DMpDQoPwel5gBcIAF5DCIQGrBuBd++lPinLW5aFaZrYtj0q/HDg0YZl2wiUQHgMN4X6 409218AK8RM3VYAPl+IwO8ngB8UkDK8ulDSjmh3J9pXhiAjuvSIXo1TrIFygVyjUhCRQAKp3gyFzE1 409219Mm9ndoOhlh8ybOuG4P25Ag8O0bhpo7VwBXgAj9Ef1+GkACMzvMquBZBSZrS+ZVlIW44UnyW8 4092200prCAEgpiSdMOy1PCEAY4YRq7YkqZpR605q1icFrpVCOk9H6pmlipwXxROG11lQXCxzHIRqL 409221J9KzNKCMM9fsl3ceT/Qu+XRwEN6ZGLzWGuk4Ga1vmuakClm62y6oMrjUpXXnlY+b3GBTgARs 409222Q7900/G3T5rNNdN8TCv0TApeuy6UyfrJNGpPGt4QmrnT4benzEj49P+cdQU4gA3YBkBztzxn 409223Sc2y2rxJwQ+PgRR86tpOxUCWbpQ+Zk0T+D0OjW2RMLH2uCtAAiZgGQBNXfInOz6Mh7+8pBiP 409224wcgqm0UPr5QzwvJD6sBEY8C9t+pWQVNI666rF1pc13Fc+OiAgM5tFe+9+F70ZHmhly8unjo0 409225Y4wnxr0n5RgxkF4HRoPNAD+7XDC3QvPKB1ZvzwfPH3HhLSACXAfMgT3x+WvWt/99bzj0tXvK 409226CXhFRviR/U9aEI8RA7Y9Rgxk8HutFBrNmoUGp9twLp85fBo7aroCEi58/8AKAHRsqzz0y0PR 409227D3NzPDy2qmKkdcaowsOz0IgYSHWjWcIrrbm7VlBV6PD6Eaun/8i2o2mBGwF63G855IjiRLO1 4092288fGXQ01r7pzGl+4ozry0o8SBcuSoMSDtDHVgDPi6MsHaBbDjIxFrOfqrgygp3cCNASGgC4jq 4092291J449Ulsn3Hl8KXEUz96s6/rH+6vYeGn8rI+jBorBuzhMTAGfEkQHrtLcOIq9u8PnmxInP/1 409230pbSs00dyJ9bjxsLIs9Gzz1TtfO1A+MW9p+OxZx+u5faaYFbp1BkrBiwra/gn7xb0xdGv7u9u 4092317n3/6T+48BbJ04gOoA2IaK2djAIAPnq6evPmHaGdx5qsxE+/Xs99d0wbdyVCUcW5NofzHZpL 4092323QaNIYPGkIemPi/d8dxx4WeXC7632kAqoV94J9bWsWfTW2nwERe+1XUhM8U65guOhf/Y/MzD 409233dxWs/8bqouLt71zl+V2XsWw1pphsLD0829wz28PaBXCsFfna/s6m9rc3vYmTMNPg24GLQCPQ 409234o91DrXEFAMz7+8tfWVEXeGbrwzdVdvSabHnjMruPtKMcdcPw9RUGDyw0qCpU7Dgh4u8e/Ohk 409235z/4hbhMFOkmexjUCXVprM50vq5d81Y813F5TFnjxb/+8eN6DywuCDU19/GRPM/tO9yaPDcfp 409236Z9LnHqGprzBYPSeHW8o1Jz/Rzi8Px0MtH+44EDu/MxWwKct3Ak3u6AISehhw1q9ZhRBGzYY/ 409237rL15evH3/u4LJbWfucXnjcVNDl3o4/9O9XC6NUZHn0VP2EKlbYLyvFAUFNSUeFgww8PcCkGO 409238kDR2af3fB+M9lxsOnOw7su0oyaBMZZt+kj7fTNLvezLBT0hASgT+ksCMNa8+WlFWtGZmuW/G 409239lxfnly2q8eSgHWzbJmHZdPaZJEzJ1IDGwEFKiS0lZ64pvedUPHylLdzf1XLmSs8HLxxGxmwG 409240W4QYyVTZDlwlmXGuA1Ym+AkLcEUIkqcCeRTOqsxb+OhfVM689fOFU3KK/V4jEPB6/AUBw+cR 409241WnT3m3Y0nrBjMdPqj8bNzisfXYo2vH6GeGecwcbMImn1MMkM0+6OEMliJcfkmaiANCGpk4F8 409242kkd9JcBUoBBfUREe3xRi7ZLk3jX99Y1icEOSYLAx6yF55plqEyydxavWSQtwRQgGjzgCrpgC 4092439zvg3s9NE5Hq5VO+HmWwMYuSdCErVaSyYrgRAcOEDBx1pIGnRkpAyvKSZGOWch8bkNlY/E8i 409244YMgPJsWkBBlp15BcgdSeVqXmowVoNp//B5V52MnTW/VPAAAAAElFTkSuQmCC'! ! 409245 409246!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:45'! 409247lockIcon 409248 "Private - Generated method" 409249 ^icons 409250 at: #lockIcon 409251 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self lockIconContents readStream) ].! ! 409252 409253!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/29/2007 12:43'! 409254lockIconContents 409255 "Private - Method generated with the content of the file icons\base\lock.png" 409256 ^ 'iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAYAAABXAvmHAAAABHNCSVQICAgIfAhkiAAAAAlw 409257SFlzAAAN1wAADdcBQiibeAAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 409258AAfRSURBVGiBzZldaBzXFcf/59yZXWm1sta2pFRyFZlNHFNwwSAFhUACog3FoaW16xIKJYFA 409259SF/ah771qe+lL30qhL43OKUUYjB9UdPU1LFxm0Bdl7TGsVPJH2qMJUXSKpq55/Rh5s7Handm 409260VxJUgkFz75m987v3nq97hlQV586dmwbwJhO9YUVGAUBVoaoou+/n2d2MAehnqvi1Meaty5cv 409261343EiRB09uzZ4wBuATAnn27o1GSdVCUeQKEqUMncu8FVoJm+SB61oem9In426dNIDs2/QxVQ 4092627BjvP/cD/fh2SKoa+r5/qlarLY6MjAQA7IULF6wH4IcAzE9/PIMTzUMxvEDVRi+WtO1kaGt3 40926360vGSC7NtBVAN1l24hX61ycBfv7WuqeqPxkdHf2FiGxsbm5+Pj8/32IieuPkUw090Ty088X/ 409264d/hIdmKa0XzSaBgGrxDRSSJqVqvVJ5rN5iCLyJGpY/UDuPJ52bFxkIjUVXWKiKZ9358Mw/CQ 409265FxnNwYZPfwswc11VPQCbQRAse6lx7Q/89rbg3rJFq2UxMQ4M13Tf4FUVIuIzMwDUiGjAcxa/ 409266V/jFByHeXdjGvYcWYWghIrDWol5TzM8xnjttMhPoFz5+b7QDRqM/n4j8VIX2AL9wZRvvXwsQ 4092672gjawVtr8XhV8M4li49uMn7wbR+1QewSPokNJo4DRlUpUiHRXcP//eMA710NICLwjOCFWcaX 409268nyBUfcbdJcKfr29h+ZHg5q0Ab18M8fr5at/wrh2FEPWYWVWVAXCiQruB/3wjxMWFbVhrMXoY 409269ePU7HkbqbjGAJycN5k4P4DfvbuLqRxZ/vRHgq88AM6fMLuA1q0ICwIgIcd4L9Wew/7xlsb5p 409270AQjOf4Mz8CmAZxSvvDyAIyOAtRbvX2v1DY+8CjEAA4CNMcSpF+rfVd5dilRnckwxMYauAL4n 409271mDllICK4s7TdN3x2F1TVIyImIlbVdAK78fObLcHkuOL4se7w7tnJcWD8KFCvKR78N9gVPADE 4092724MZNwoscbP/wqop7D0N89jjE5BgjsqluAILaILB4fzvyUNIvvFMhEBF5RCSqakQk9kK5wXqD 409273V824TEEPQUoT96piocp9wKdeKNb/xAaiCUB7hr+7ZHFnKcTKaojWlkDF4vanFr/7QwgRCxGF 409274iE0mGEVPi5XVEL4XGfXFhQ1MjhOeOe7hqWnTA7zE8IRYfQwRsYiQlx4giuGttXjnUoAPb27n 409275gpVINKnbn+b72gOaiCTXex8ESd8Lz1bx5veHQIQCeHdWSHaAATARMedSiYKVX7iyEz57dYLu 409276BN/e98crG/jtpfUSeKcdCmY2zGwAGGZ2cUAL4VUV128EfUN3gs+23fWnDzZL4TMJnXFeKE0l 4092772oy4HT4ILR49DjtCt69qv/AigsUHQSm8RvqfM2JmjiaA3CR2ehuo7hq+CDwrK4RXiW2Akgkk 409278O5A14s7wEnuX3qC77UARvEgJPMTBg4hMnIkaImKvDN61y6B3s+rZq9SNgqN4EqtP4kZdHCiC 409279B4pXupdVL9uR4hiQKclE3seoKideqAxeVTpC7xe8tR12H+1MSS2rkxdqz0h3hvhe9L5f+HYj 4092807g6f7gJHp5lEjbxe4J0N9APf76SK4fNxwHminBcqK30UGW2/6tLNiIvhUxtwqUSHONAtM+zs 409281hfYLvt2N7oBPVYjiRM4AYBGJDzTJ7DrBpzawF5UpkxfCI1UhZ8TJDiQqVAAP6g65l1V3MvQE 409282n1OhNJ3oeLTLtqHwWDF2BH2vatFuZWVTE6YQPsuWVSFNzsS5Gn0e3rW/9vzAvqlLe9+3Xhoq 409283hHc75FTInYfb0unict/Xn6/im/MDUN1bwMq2DSte++4hnH1pqATeJXOas4FcIOul3Pe9l2uY 409284f66Kf9/ZwqPHAazEh+0YDgDccTKK3hr/t1BRSAIjOHqY8ZWnfYwdplL4VI00SebcTuxMp0uK 409285TkcPA0caFah6O+JHaUpc5ipL4J0KOQOWtDLX/j2rM3xv1YP9h89W5twOJDaQuKgDDJ/GqVwq 409286kTfigw0f7UDWC8UqxAzoFytr9kDDqwpW1xnMrBx9nnGulFhE3/7bP7Z1ZU0OLvwa4catQYyO 409287jrWyKgQAHoBfWauv/eyXa/Lisz4fG3f+NrX+1D4yqXcu+Ll+xHrqDuCufMjJoTwam+Nx3Ufx 409288dOyszqsKlh56uPxhHSLA9PT0Rrz6FOuUkKpibm7uPBF+JKIvZowF3e7L5PsxRvav0WhsTU1N 409289bU5MTHwRd60AuK6qvyf38OzsrD88PDxTqVROe543xcwNIqoSkVFVV4/nXB4SVcgos6XZK5ER 409290EWlUvjbMTIiiaVIezJTMSdPSOQEwlUpFh4aGbMxBAAIiug/gL2EYXkomQER85syZeqPRmDTG 409291HBeRLxHRMBH5GUB3FjXMTKpqjDEsIskRLwPfrZ2dbOJRMgvDzlDbniMAoqrrAD5R1asArnlu 409292m1RVZmdnW/V6fZmILBGtGGPqqlqJSxgcrx7Hq0fGGBKR5GtJtA7RvVtFJ48nTIj9t4g4V0ix 409293zD2T/D47TrzIIRGtWmsXiehWq9Vapqy+ERHNzMx4zWazCmBwcHCwAsCEYUgiQr7vEwBYa8la 409294SwMDA7DWkogQAHieRwAgIuTurbWJzD0nIlSpVJLfVioVZGXGmOTe9/1ERkTWWtvyPG+t1Wqt 409295bW1tbf0PbTmNGWgyP0wAAAAASUVORK5CYII='! ! 409296 409297!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:45'! 409298questionIcon 409299 "Private - Generated method" 409300 ^icons 409301 at: #questionIcon 409302 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self questionIconContents readStream) ].! ! 409303 409304!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/29/2007 12:43'! 409305questionIconContents 409306 "Private - Method generated with the content of the file icons\base\question.png" 409307 ^ 'iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAYAAABXAvmHAAAABHNCSVQICAgIfAhkiAAAAAlw 409308SFlzAAAN1wAADdcBQiibeAAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 409309AAyGSURBVGiBtZp7cFzVfcc/9+5qtatdvWXJetgyjiUZY8BvbEMCjSk4PAKh2CFtCjU2MwEK 409310blLcaZkJk5AZSkoaA3HqDKUmBgx04rTGQOMhgtQ2fr9AtmzLlm29bL21q33vfZzTP/auvCut 409311pJXt3pkz9/7u7Fx9vr/zvb9z7jlSpJRczaGs9s6cXamu8TiZkZutuD3ZeFwOPCqoEV0Eg1EZ 409312CkRFMBSVnc09+luhmDggf1t5dX80+e9fiYCStf5bppUoz1QXKbOWzcqaunKho7jEo6T8RgLJ 409313d4JRyfZj0cCHRyPtrf3G2UteY1Pb+ortV4c/QQHupwKz5kxRXvurxVnzH1vqKHRnK/T4DU60 409314R2np1RgIGvQHDfoDBrohcWer5LkU8lw2phQ7WDTDzYxyJ5oh2X40Etnwx0DjhV7jn9peraz/ 409315fxWgPBEoXVCt/tv9N9tv/Yfljsm6KdnTFOZ4W5ROn4ZhSgwhMUwRvx5qIvVaSApybNxS4+Hh 409316xUVMKclm086Ad9NO/9GvWsPPhjbVnLzmAirXBRfPn6pu3rzaVet2wJ4zYXaeChGOicuAGcIn 409317YiEEqgL3Lyhk9bIyPE4bf/duX+uOo96fXPhV3dtSSnFNBFz/QuiJb91ge+EXK51VZ7pifHQk 409318gDdkYpoSPQVqDPhh4oQQSCmHWrYdnlpewcpbJ7Gx3tf3+h+63zv9y5nPAYbMwB6jCpj7Yujl 409319Z5c5nlh1a1bRrtNhPj8RRDNlGvg02c4QXkiJtO7dO7+I5x+exv7mSOSZTe31DRu+8QiRnpiU 4093200pywgFkvhNY8d5fj548usRd9eCRIQ1tkCCIdvCkkNZOzKS/IotBtozjXTqHHhj9scmlA4+KA 409321xvG2ME0Xw2nhE/ENVTmsX11Lc7ceW/X66fdPb5i/FoiM1RsjBFSuC96ycoF96/rvOqt+fzCQ 409322Am8IgT7UC5LSXBuLa90srfVQ5LGN19vsbfLzxqddnLoYHgGfiOsqc9i8djbv7h7w/WzzwVfa 4093233rl3IxAC9HQi1BQ1TwRK5k9V3/7Xlc6q3U3hMeFNU/D08kncNy8/I3iApXV5/PaZWu6bVzhq 409324T5xsD/LjLWdZs6yk4Nu337A2746X7gTyAIeiKMrwZ6YIuOU69VdvrXLVnu3S+Ox48LKPRdzH 409325yfC6KTlwNpQR+PDjh/dNpmayI62NpBD8z+Ee3vy0nV8+VlU6a+FdPwFKAQ+QNVzEkIDcpwO1 40932699xovz3PBduP+NFHKY+meVnM3qbghOGllCB0nrmrYFQbSSl57aMLtPUEefbeiumly9c/CkwC 4093273IA9rYA5U9TX193tKN97JowvZI5f24XkXHeULp8OQJ/fYNepAFt29/FGfQ8fH/YSjo0s57qu 409328o+s6lQUK2XZGfaE1XfDqhy3cMyfHWXvTkr/E7qoEigCnoihDnrUD5P1tYM4/P5S9UEjJzpOh 409329jOAT8e/2DRCKmnx2wo+mC4S8XC43fd7F28/W4nHahrKvaRqapmEaOtOKFRovpbGRJWjH0T5W 409330LCniuQcqKs81vvxY5ydrNwJRQFcURUgppQpQU6qs/f6SrKL9Z8OENDE6vBhpq4+PePm0YXAE 409331vJSSSwMx9jX5h7KvadpQD2iahoIYFT4R/0f9JRZOs6mTq69fApQBxUAOYBuyUEWhclO+S+F4 409332e3Rs+DSDVqIyDYeXVpyc/QR4QsQlrzEmvJSS/U2DhKI6X6vwlOCaVAGUkFSVVGWNr+6OWtsU 409333b8ikvV+bELwxDnyey8b8r+UOZT8Br2kajR1R+oJjw0shiOmCfacHeWhRfl7ezY8utXqgAHAC 409334NrWuTF31yCLHpBPt0QnDG2PAg+TF703DYVeGsp/cA9uOxsaFT8S7T/u5qVJRy2sWzQPyLQFu 409335wK7muZSaykKVll7tmsFLKVlzZzlLZ+aPyL6u63zRFOGrDjMj+PjgFkaYBrnubLcFno81Lqh5 409336TnIB+gPGNYNfUpfHmj+vSPF+IvutvTHe3B3JGF4KQX9AxzAMXNn2bMs6uZaAbHuuEw9AX8C4 409337OnjrXJafxc++dx2qwojs9/tjvPSxn1Asc3gpJYNhQVQzcTrsDsBhVSE34FBzHPEe6PPrVwdv 4093383fv7B6aQ77aPyH4spvHKJ166B80RA1e6RAwX0+OLUexWbLgrPJYIJ+BQFQVFAto1gK+tcPFn 409339Nxam1P1E9v/r0CDHO/T0858xBCWapusoCAXFbrcGYAfgUMMxGVCAXKeaBl5mDC+lTIFPzn5r 409340T5h3vgiMCz9WnO+C7kHDJNQRsQYxO2BXg1ERBMjPsaUfxETSg8aAF1JyU7U7bfYPNYeIGeOP 409341uqPFziwFGyahSExHCsUagG2ATfVHZCAuQE0PL1IrzGjwUghK8x0ACCFSKs+ZrlhGPk8XCynJ 409342d4FhGESiMZ3LhwIoaiAq2gdCgqkljqTJ2sThpZQkZurDpwwXerSMK85weCklU4oUTNMkFI5E 409343kwRIQNhPXtI3bzsa/etlM92Fb9b3Dn28TBReSsmPtzTjygLTFJimgabrCNOkY0C/YngpJXOr 409344VJp7pey58FVLAhwwAMMu35p8dMWvva2Pf72wcFK+jfY+84rghZQcbfZdkU3GglcVyewKeHd/ 409345LBho/N0pC94EdMCwA7T2Gac1Q85ZXOOhtaf/iuClENhUeGBRCTNK7cRiUU62hdjREEITExOT 4093463GaUKjhtJuc6gwHCXWFLgA5ogGYHaOk13th6KHLvdxYV5W7d14+mD3vQePBS4nHa+PenZ1JV 409347AKFQiHBYsqDKYOk0nRc/jhCMTrBnrHt3X2+npV/K3o4zbUnWiQFhQFMBejaU/+k3fwo1lOU7 409348+PaCgtSKMTwro5TCHz04jemljhGzzpIcgwdnj/MODH+e9Zu6MoXZ5ZK392negX2vHrSsoxFf 409349ZgkBsaFv4qZL2nO/rg/0P/7NMlwOJS38CDFJMLfNzBsx60xc15Xo42Z6eCyRrJin0tiJef7k 409350gUb0UMyyTgTwA4GhHgDo3lC5/4P9oUNZdhtP3l0+MjtjjMIgcWWJEeCJazupn4/jwQspuaNG 409351oSrf5P2D2oD/4IbDlnU0IAgMWj2gp6wLHWvVnnp6c3/LiqWTeGBhUfquTfMemELS1O4fAZ6I 409352L3rjC8KZwteWKqycC1u/VMJth3+/F2EYVvZDgBcYsK6NFAHRTVMvHGiO/vCVT3y9//hQNfOm 409353ezKuQBt3XByR/USrb3ZkDF/shie/rnCsA/3zvQ0nok3/3ZxknUGgD/ABMSmlSBEAcOpfqrZt 4093542RP4TX1jJPyLv6nh5mp3RuV0z2k/P93aSZ9fG8r+YMjgP7+009DpyBh+7R0Kvgjy3V19rd7d 409355L31hwUct3/cAvZaNdBhjeX3RC+3vvfzd4u/cVud0/vT9c2w70J1RT4CkMAekMOkLgTDTww6P 40935668oUfnCbgjeMfL0+3Nm+7amtmNGIBe8DOoDzQDvgk1KOLQBg3vMtrzz2jfzH1y4vLNr0xw5e 4093573X5+aP1nNDGZwA6vNt+ss7FyLhxpx9iyq6el6w/rPsGMRpMy3wW0AG1APxCVFvi4W0w3rjvz 409358/aV1np9vWFVe0e2Nsf7D83x0sAthiquGn1Wu8vA8lap8wdZjSuSzvV82DOxKsU3Ask2b1fqA 409359sEzaghpXgKIoSuXq/XOmVRZv/MGdxbMfWZLnPtHi440drexs9BKKGuPOZ5JjmyKZVa6y/AY7 409360M8skDRel+cGBSH/boa17wk3bkl/YAHG/d1it14JP2bHJbJcyvqRtr1712cppU8qf/9E9xTNu 409361n5ntCEdi7D/j43+PD9DYHqbbpzEQ0BBJH0EeBxS6FaqLbcydamN2uYJdMTjXK+U7eyMD50/s 409362afAd3HAYKROlMlFteoGLQKdlm4iM/yaVLRMBySJw5LqnrHhvTfnkSX8xvSx76oMLcictqLZl 409363IU10XSeq6fT4YkRjBgUuiYqJYRjohsHJS0LuOB4JXOgM+HvbTl4Y2PfafoywboEn5jc+4rbp 409364ss4+4p5Pu1c2oY1uS4QNyAZyyZte7pn/5P2V1836Vn6OvcDpUHJc2TZXnsvmsClC6RuMGaFI 409365TAtHopo/GI31XDjWHDrxQSOR7gjxeU1idI0QL41e4j7vta4DgCbH2Ha9on81UBRFBbIAF/FF 409366pgKrxVfMsgsLsTldhDsNS3DyeJM8n48RH1EDxDPttc5B4i/xuFutVyTAEpH4uM4ivkaTQ3y1 409367zG2dncSXPuyWCIX415TByMwHLSFhS5QxmmWumYA0QuyWGEdSy0oSgCUgYZ3ER0nMOieEyfGy 409368fk0FDBOSaCqXlz4SceIQ6dpEoJOP/wO5FlMEYbMDfQAAAABJRU5ErkJggg=='! ! 409369 409370!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:45'! 409371smallBarcodeIcon 409372 "Private - Generated method" 409373 ^icons 409374 at: #smallBarcodeIcon 409375 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallBarcodeIconContents readStream) ].! ! 409376 409377!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 12/21/2006 16:37'! 409378smallBarcodeIconContents 409379 "Private - Method generated with the content of the file smallBarcode.png" 409380 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAAAXNSR0IArs4c6QAAAARnQU1B 409381AACxjwv8YQUAAAAgY0hSTQAAeiYAAICEAAD6AAAAgOgAAHUwAADqYAAAOpgAABdwnLpRPAAA 409382ABh0RVh0U29mdHdhcmUAUGFpbnQuTkVUIHYyLjcyclqEXQAAAIRJREFUOE/tUkkOgCAMLBef 409383qSZePPMIn+MLMbWjbWgaT8BRksmwDNNCm5g5EREL2oYYUA8QFdF7gATahj39uY2FsZ/Hsw9t 409384vfgbDPpEX1CrRixyqNiAPujqRC7HxCWTsAAcscseYBroKvRgU5EJwXPA8mqus0KM1MCieIbp 4093856qJbZj6DTDcgu0pIJUVp4QAAAABJRU5ErkJggg=='! ! 409386 409387!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:45'! 409388smallBoldIcon 409389 "Private - Generated method" 409390 ^icons 409391 at: #smallBoldIcon 409392 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallBoldIconContents readStream) ].! ! 409393 409394!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 7/25/2006 16:39'! 409395smallBoldIconContents 409396 "Private - Method generated with the content of the file smallBold.png" 409397 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0 409398RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAAELSURBVDiNndOxLkRREAbgb5Bg 409399RaJQqZREISERrYYH2JYQiUIlwWOotCqFROEFtpGIUsMb2BCRaESlWEaxe5Objb2b3UkmmTPz 409400n3PmP/+ZwA5OVFsLTTzhPDM/y8Vj5AD+geXMlJlG+tz8n83iqliM9QBd4BbjWMM+Jkr1pYiY 409401y8y3Xgc8ZOZ1J76MiBr2ujA19KcQEaNY7Eq/4LmKwlFE1Dttr2C6VHvHbma2isQgKnxhs1Bg 409402GBWm0YiIm4iYpPcbnGGj44faipStjtMqCgflNjGD7y7M4yAU5rX/RNmm6K3CdkSsduIFrP+D 409403ua+i0M9/sDXsLPxiPzMbBYVX3FVsSHziTXucG5nZLIp/7M1/esa2s1kAAAAASUVORK5CYII='! ! 409404 409405!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:44'! 409406smallErrorIcon 409407 "Private - Generated method" 409408 ^icons 409409 at: #smallErrorIcon 409410 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallErrorIconContents readStream) ].! ! 409411 409412!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/29/2007 12:43'! 409413smallErrorIconContents 409414 "Private - Method generated with the content of the file icons\base\smallError.png" 409415 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAAAlw 409416SFlzAAAEnQAABJ0BfDRroQAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 409417AAKQSURBVDiNbZPRS1NhGMaf7zvb3PJigzZrC46BoIbWRSSVoYmKgkj/gBdCGnklgjcSXnkr 409418giLZhfQnGIVBSKkX6dC5BYJJI7cIczbTuePO8ezM95yvC91w6gMvL+/F732/74GHCSFwXsbE 409419xAteVfWYTk7uk64HJKfzJwciRjg86x4Z+YwLYvkFRn9/JW9rm9J1vUVdXcVJKgVSVZCqgtnt 4094208HR2ktNuf5OenBySI5HjogXZvr5K3tW1rASD3tzOTgE0zzoRgYjgqq2Fr6lp5V9395M7QlgA 409421wDOMMd7S8loJBr25RAKkaafwWc/DJhHSkQj2wuFHfwYH3+ZfwB3Dw71ZoDWXSBSuXoJNE2Sa 409422ICLszc3hVnl51/OKimcAwHld3UM1FIKZzcIyDJi53GkxBotzCEmCJUkwOYfFOUgIHIZC9uuy 4094233MsYc9jIZnvgqK5GoKfnosEAACKCoihQFAXpdBpKMomj0VH4ZdkP4J7NNIybktt9JZzL5Yph 409424RYGi67A0DSUulxvAXZvkcPxILSzcsMsyhBCFMgwDqqpC0zRkMhmoqno67++jlDFsb2+nAXhs 4094257Pj4WzYWexofGIBJVDAr73x+NokgEeEaEVBfj3g0egDgLzdWVmY9HR103mnzCpjOZhPAUSCg 409426fYnH4wAS3D02tuiSpClnTU3x1atgIojWVjEzP790SJQCEOYAcDQ9PeRvbv7qaWy8/IU8LATQ 4094273i5CyeTGx62t7wA+CSG0QhaijHHf+PirlN0+fLC2VqKsr0Pf3QX8fghZRsbnU2cWF5c+xGIb 409428AJaFEO+LwpRXtKHh9oLX+5LKyhpLSks9v2Ox9K/NzYO5eDyesqwkgHdCiOilNF6KKWMMgBdA 409429AEAWQBKAIi4A/wHla+UnnITGTwAAAABJRU5ErkJggg=='! ! 409430 409431!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:46'! 409432smallHierarchyBrowserIcon 409433 "Private - Generated method" 409434 ^icons 409435 at: #smallHierarchyBrowserIcon 409436 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallHierarchyBrowserIconContents readStream) ].! ! 409437 409438!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 4/16/2007 17:00'! 409439smallHierarchyBrowserIconContents 409440 "Private - Method generated with the content of the file smallHierarchyBrowser.png" 409441 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAALGPC/xhBQAAABh0 409442RVh0U29mdHdhcmUAUGFpbnQuTkVUIHYyLjcyclqEXQAAAJlJREFUOE+lU4sOgCAI1B/tI/r9 409443HAQkzhdoxcYaKcfBYQhkKaWAiCHGyCGQo+HPBQC5zy6mPxSADgbLwAIw2A4AgTOzhkEu+DAo 409444AYU7DJqcHmA1A23bYlC3WGj3fXsM3gNUGZ6EKu1ciQxiUt48lyXyKkzPra1DGhQNWvR3N3Mm 409445OydoteVemABwnSz1H4BjD2DRoz8DfZZfvzfCeW5hrgHmOgAAAABJRU5ErkJggg=='! ! 409446 409447!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:46'! 409448smallInfoIcon 409449 "Private - Generated method" 409450 ^icons 409451 at: #smallInfoIcon 409452 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallInfoIconContents readStream) ].! ! 409453 409454!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/29/2007 12:43'! 409455smallInfoIconContents 409456 "Private - Method generated with the content of the file icons\base\smallInfo.png" 409457 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAAAlw 409458SFlzAAAEnQAABJ0BfDRroQAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 409459AALNSURBVDiNZZNNaFxVGIafezIzmbTQjDqxndRMLUI0pooWfyLSUm1RUXFTNxpElBYFwY2b 409460IsWFdCsoYhXFlaALrShVS2s1C5u25qdRiNJJJhNjbHTS3Dt35p7Jnen9To6LzkyT9Nsenu97 4094613gOvY61l9bx3un7w9s3qocjIzrAu3cl42zSo8bHZ+vG393f+yLpxmgte/6Le+1i/OhqG4d5f 409462pzWejtChoEMhHnN4emdK4onkh++f8g+NH8kur1nw6me13sEH1PDZXDl9qXQFHQrbu+L0bU3y 4094631TmPvy8vIyLsyHawZ0fX+Rc/vvyw/bxvBUA5BwNn7x3qg7O5cnqhdIVq4+pLe9I8O3Aj+wdS 409464iAhiDOPTPmO5xYE3Bv75tGmgDj+VOMBKbd9C47KuGao1w0eninx/ocSXw4sYYzAiiAgnJxbZ 4094651rN18LZdLz8DoO7fph4cyesW3MxdrQnnLvrElL1q0LAQEUamSvFs900HHMdJqJiS+7wgWgNH 409466Irz2xBaOPL+dR+7csAY2IkzOBWRvyWSAu1U9MlvWw2IMFkulUkEHAdKIYBpvRb9OR7K9E7gr 409467loi1XdShbNa1a7ARQesqbWFAoHUrf9Mis8kyPz/vAym1HDkX4jGIomuwiFD2fVzXvWqwChYR 409468elIr5GcKLvCfOp+vH3/y3pSs/mkxBq/ksbS0RNCI0MyPNXR3VKqFidMFYEG981znUFu842h/ 409469T7IFGxF8v4zrugRat2Axhn291v70w7EzEpY8YEwBfDJUOfToPZlfdvenWhaTcxV++6vKJS/C 409470iGCt4fE+bDE/Mpkf/e4P4IS1ttrqgjOYU+++0PVmPPIOj0657b/PlvnXC8lsguwNlq5EoIdO 409471HDszM/rtJDBsrf1mTZmas+ut3K1p/+dXbt4ouzduaE/NFOb8P6dm3cLEycJK6BWBr621ueva 409472eF1NHccB0kA3UAOKQNmuA/4HsoMEebPS9UsAAAAASUVORK5CYII='! ! 409473 409474!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:46'! 409475smallItalicIcon 409476 "Private - Generated method" 409477 ^icons 409478 at: #smallItalicIcon 409479 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallItalicIconContents readStream) ].! ! 409480 409481!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 7/25/2006 16:39'! 409482smallItalicIconContents 409483 "Private - Method generated with the content of the file smallItalic.png" 409484 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0 409485RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAACmSURBVDiNpZIxDsIwEASHFKlo 409486qCPRRqmo4Al8g5fkT3yBFlLkFYgGCdFBwVLE7nJny7FkXbO78uwZSVgXOAEj0FuaCv8cgR3w 409487tASpgEOYV1PhPH8DCPgAdQnCPsxR0rcEIQbcHM3yAK+DO1MHnbtqw9wE8xuovAALIa5vkPQr 4094886SCP3wlIf6B4ZvhXwIupg63HP1si0AbzI2W2SszmtzpYAxfgnBPwB0Q6/v9KP2ylAAAAAElF 409489TkSuQmCC'! ! 409490 409491!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:46'! 409492smallLockIcon 409493 "Private - Generated method" 409494 ^icons 409495 at: #smallLockIcon 409496 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallLockIconContents readStream) ].! ! 409497 409498!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/29/2007 12:43'! 409499smallLockIconContents 409500 "Private - Method generated with the content of the file icons\base\smallLock.png" 409501 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAAAlw 409502SFlzAAAEnQAABJ0BfDRroQAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 409503AAIoSURBVDiNhVI9a1RRED133stuREMQ0aCC34KBdAlYCAs24h+QdIIGbAVReyuxsLMTFCzt 409504xEILQbTRICFqMEWaYBA1Gy3Edfd+zRmLt/uSDYLFcC5zOTNzzoy7fu3SowMTO1rGLFSFMoPM 409505oG5FdWT/TxU9n/3qWrj99Nn8w3L/vtHWxQtHDzNHqAZQA6ibb9UEagIZ+5hAFdy5zxuzs7PL 409506JUxlO7nnAxaWulhZDZg6oZg8rjAOyAmqCQ4sRWSyGntb51fzXfz+E3H2NDH/voNPK70hMhlB 409507mohIUypdw2N/b3u0pg17d2ecbwkWljrDZE0wY1EURbOsjKrI3W7Au489rG94PHmRkVJArxvw 409508+UsPbxcjpqfcpg/mxDnXLKm57vz8dRcv33TgvceHZY8QQh3zixG3ru7CySNVEeNIISINYV+C 409509akL7h4f3VYQQaowxIoSAb21fSzGjABhMUBmUYhgqMCDGGBFjhOYGVK2SQBaVBGq95xD+TR5g 409510zg2QBmqEmYlzrlEV6DvrXKw1D7puLVKWo2B/AjOKmQ22UDl77kyJ9Taw8dMQApESEaMhJ8Ox 409511Q03MTBX1PZhZ0fdA6+TBCcPNKztBbWw7nARqHMoZKSLSKEPMgSpDR/I/smpC1kJINsu1r+ne 4095123Qf5sgPGSRMzEdqIGAshm2JGoVGMLMzMkSyyCsb3nOqIyC9nZpibmxvz3s+QHCvLckRESgA1 409513OudqNLPSOVc657KqPv4Lpk1zsB8BOCQAAAAASUVORK5CYII='! ! 409514 409515!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 3/6/2009 13:10'! 409516smallPushpinIcon 409517 "Private - Generated method" 409518 ^icons 409519 at: #smallPushpinIcon 409520 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallPushpinIconContents readStream) ].! ! 409521 409522!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 3/6/2009 13:10'! 409523smallPushpinIconContents 409524 "Private - Method generated with the content of the file icons\Loading\smallPushpin.png" 409525 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAAAlw 409526SFlzAAAN1wAADdcBQiibeAAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 409527AAI9SURBVDiNldPPS1RRFMDx7/XN+KuevtQZFS0cRFsUtJLwR9CixYThPloMRP+AU0E7MQIX 4095285SxyF5Iu27Vp4aJdqASBgaLkpFJpKNn45t038+b3aZFa/gjtwIEL957PvedyLyLCSTk6Olr9 409529rzklIhwXsVisswhPQfUYSENRqW2EGQN5EI1G43vrjgWGh4fvCLzcqjbVz0Czv1hrUZlJU7e5 409530ka93bFFIZGho6NWxQDQa7RBYWGo6X57pvERDfT2maQKC1i5qfo7WlaWcErkci8XiZYd333H0 4095316OciaquxlaqqKkzTJBgIEAwEME0Tt72TdaNc2Vo/AzgCaO1cW6s2/ajdHhWg9gYAis26oN/R 409532ugfA93dxOBy2AMvGoCabw8t4OFr/wV2N53k4Pj9nbLshHA5XHwCmpqbsq729dnF7y3KDjVRU 409533lAOQTqURwPM8kskkme8b7Gi9/X56On0AADDKjG8VK8u1iZYLCiCbze1D2WwO13Xxzc/ltePM 409534HGlhZGSk6tbNcOWL8XFVqjnHj0tXSKVT+P2/gXwuR+njB85+WpS8yMMjgFLqcV9fX0c2m+X5 4095352BisxkW3X1RFqw4juYM/vpT3rX8Rp1S6m0wmlw8Ag4ODoa6urtsAiUSC5qamrbXVuJtfXKin 409536WLBKhmHnlXpHoXBfRPZf4j5gWdaTtra2lomJCT07O/smlUo98lz36+7JLCkU7MP3BYCIEIlE 409537bkxOTtoDAwNvQ6HQ9dN8sL1EROjv73/d3d19738KT/yNp41f+BNzbRFTe1QAAAAASUVORK5C 409538YII='! ! 409539 409540!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:46'! 409541smallQuestionIcon 409542 "Private - Generated method" 409543 ^icons 409544 at: #smallQuestionIcon 409545 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallQuestionIconContents readStream) ].! ! 409546 409547!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/29/2007 12:43'! 409548smallQuestionIconContents 409549 "Private - Method generated with the content of the file icons\base\smallQuestion.png" 409550 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAAAlw 409551SFlzAAAEnQAABJ0BfDRroQAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 409552AALxSURBVDiNZdNfbFN1GMbx7zltT1cGroORsdV2iSYjcbsBFSGZYuLChSzeqBdmJkadxguj 4095533hgSWCIYEq/QGBNiYkyWGENEiUGMpgyEiwobfzaHy2LZVjK7MTpYe7odenp63l9/XAzKgPf6 409554/Tx53ovX0Fqzer4+5b23udnc4SvZ6nrSWhcKTIJ5+dI178TnrzYM8tAY9wI+OuK17+owD7uu 409555+9LwpEPe8XFcwXGFUNCgZ2tUQlbdt9+ctPdcPpgoPRDwwQ/l9t5t5t/n0sWmuUIFKwDx9UFa 409556GkNcmSkxlLZZul2hMxHhxc6mobf6f+zSqU8UgEHfknH0/fDJzHyx+3qhguMKB15v4fENVq3m 409557QtFn98F/qFSEnU81YHlzA4c+3vWu1rpq9u+2+qiWa9gpKwbO3qL/SJbvT+fQGtYEPLbEQERI 409558ji7QFo/1PtH1do9hGIb5bJv53IUpp4YdVxgcs/nr3wJHUzl8VcW2bWYXy4hSiAgXrhZCbbGN 4095597wBhM2jKM/llv4YdV/BFEBH2vZagUi7xUyrH9M0VrEQYn1kmHmuOAZ2m56tNj2ClSDRZvNAR 409560ZfZGnoHUMuouFqXI2R6RunAD0GlawcB/K/XvYyVCz9PrcRyHX87lcMsrje6d0LxOk81mbSAa 409561LPnGSCjITt+/j0WE75L/8/sQTGSdB7CIEI8apMczi0DOHJryTry8JSpqFRal+OLNNj57pZ7t 409562ca+GlQhoRWtk6XZm9NQ0cN089EbDmUAocrgjXlfDSoRAtYRt25jKrWFRiu52rU//cSwlbuEW 409563MGJordm+fy7yYXd9cnhi/vnBkRwiwlqrSus6n7FZn0pFobWiezM6Nzk8fvbnL5PAr8D52i8Y 409564vWnzq94N/Zay9168uhgeu1ZkPu/S8hgkGjUbrWXnzJ/HUtMXj18BzgO/aa2rxsPfuOPT4Sc3 409565eSN9zWtVV/2acONUZsaeSGcWM6PJTNXN3wCOA2l9Fz4SAGAYhgGYQBPQApSBBaCotVard+8A 409566JLDt2W5OLJMAAAAASUVORK5CYII='! ! 409567 409568!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:46'! 409569smallStrikeOutIcon 409570 "Private - Generated method" 409571 ^icons 409572 at: #smallStrikeOutIcon 409573 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallStrikeOutIconContents readStream) ].! ! 409574 409575!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 7/25/2006 16:39'! 409576smallStrikeOutIconContents 409577 "Private - Method generated with the content of the file smallStrikeOut.png" 409578 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0 409579RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAAE9SURBVDiNldO/K/5RFMDxF49f 409580iUHf/JhkkUkpPwaD7BaTkk3Z/AUGizIp5S+wyGy0UQaFRd9MFrFQnkgIcQ2f8+jj6fOQW6d7 409581u+ec9zn33HOklFQE3VjHHsq4wz42MJa3/fLJOY/gEgkPOMP/OCd8YKkQgBJuwnAZzTlwAxbw 409582FvqhIsBEKE9RV5gqq2Gzkr9vkK3+2C9SWBesbQzi5dtt2PcG/R0zRRnUkjp0YACLmAvuNQ5D 409583jvBYkNFJSukNpiP6X6WnUoNyfFcpR29BO9riXFlPuMIzXr9q8JPgH+bjWQkHVXolTGH2F1BX 409584RH5HZ3Uf3Ad98BfIXthNVgN2QrGJ+hrOrbK2fpDv1FCORlESdjGMptA1YlzWpQlbtYZpLqpc 409585+aYXnOfACcfoKAQEpA9rEa0sG6Bb2UgvoFT9tE9NmYDjaYSwiQAAAABJRU5ErkJggg=='! ! 409586 409587!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:46'! 409588smallSystemBrowserIcon 409589 "Private - Generated method" 409590 ^icons 409591 at: #smallSystemBrowserIcon 409592 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallSystemBrowserIconContents readStream) ].! ! 409593 409594!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 4/16/2007 17:00'! 409595smallSystemBrowserIconContents 409596 "Private - Method generated with the content of the file smallSystemBrowser.png" 409597 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAALGPC/xhBQAAABh0 409598RVh0U29mdHdhcmUAUGFpbnQuTkVUIHYyLjcyclqEXQAAAINJREFUOE+9UgkOwCAIg/8/GsWI 409599q45qlmUzIVG5SqmKiFXLjppdLlVlcVLj5hNFvUCY/9G4nuAd0EZyR9LyI2bcscvSMS2AKAbS 409600Vwi2s/3GQUcxzbxyQ5ECw66FdRPxbj66BUxku/4eAdPDUYlPObgJKQqgRDO1bTlAmEyVdEOn 4096012U/+Aq6qHwNt2ojQAAAAAElFTkSuQmCC'! ! 409602 409603!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:46'! 409604smallUnderlineIcon 409605 "Private - Generated method" 409606 ^icons 409607 at: #smallUnderlineIcon 409608 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallUnderlineIconContents readStream) ].! ! 409609 409610!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 7/25/2006 16:39'! 409611smallUnderlineIconContents 409612 "Private - Method generated with the content of the file smallUnderline.png" 409613 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAABl0 409614RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoAAADaSURBVDiN7dMxSkNBEAbgb8UY 409615wUrwADZ2QsAbWIl4AcGzeI9gZSmpbFJ7Am1jE4hYCAoWWoiCGYs3Jk94SYRYOjDMzuw//+6w 409616/0ILl+mtiDDLcZa47VrNOiK9vYBglLjOd23FkvZP8EcEH6qngc0F+I2M7xOCiBjjJfOdWZ2l 409617lDVsZfpcvwHcZNybc/p+xvuIeJxUU2EnqjHecNigwF3cJub0x14N1DWV9AP6Kt1f4zPrPaw2 409618EiTJAc4xwFPOOsAFjpr+R0FBZ87sTTaMiFfZ3MZdrn9rxxFxBV+mVKeTcAXyQwAAAABJRU5E 409619rkJggg=='! ! 409620 409621!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:45'! 409622smallWarningIcon 409623 "Private - Generated method" 409624 ^icons 409625 at: #smallWarningIcon 409626 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallWarningIconContents readStream) ].! ! 409627 409628!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/29/2007 12:43'! 409629smallWarningIconContents 409630 "Private - Method generated with the content of the file icons\base\smallWarning.png" 409631 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAAAlw 409632SFlzAAAEnQAABJ0BfDRroQAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 409633AAJBSURBVDiNpVPNS1RxFD331/tqpim1/ECG0E1qlOEsKkhwMy3bJASFjaILQRBxY4YiLc2W 409634gvtwWUKg4B8gCH4NuHFqnNLJQd7D/Bj0Nb/nzPvdVkrhKIEHLufCvRzOPXCJmXEZiPMGh0TP 409635DoPBuQOiWxcqMPOZygLWvmlu7xmG+lpaOtPf33+12B4zFxfYA4b2Kio8b3aWHSHUx0ik478F 409636fgHVO5omDyYnOZlM8m5raz5RVva9s7OzupjAmQx8w/ggIhGaIcLw8DDWYjEtcHRU83RpaYiI 4096376MIQHaKHfqHwMjQxYQgh4LouAuEwQoOD4sHm5uuBtrYn54a4DdC2ZcV3OzoKzMzLy8scjUY5 409638l8uxcl1er6w8/lxXN9fb22sWPcEHXvlC3LsxOnoFAOrr61FbWwvLsuAqBX1kRL+zsfG4NJ3u 409639OuPgJxBIm+bOwdgY/43p6Wl2HIdTqRTH43FeaWg4/lJTk+np6an6x4EvxFtUVYWu9/UBAPL5 409640PBYWFjA1NYVUKgXbtmHbNrZiMT2cTleHk8n3pyH+ILrtC/Hm5vi4CV1HNpuF4zhIJBJYXFxE 409641JpOBbdtwHAfpQABbTU2qcXX1RXd39yMAoHXL+oRg8Pm1gQEhpUTO8yClRE5KeJ6HnJSQJywl 409642sL+PhpUVzDc3r7nR6H36VlIy8puoq0Ckk+97PkAKIJ+ZTnoFQDELH4AiEiyENt/SEnLKy2PE 409643zGhvb2/Udf0uAFMIYRCRqZQyAZhEdMpKKZOIDAAGAGia9o4u+85/AMNcgUUP6yM5AAAAAElF 409644TkSuQmCC'! ! 409645 409646!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:46'! 409647upArrowIcon 409648 "Private - Generated method" 409649 ^icons 409650 at: #upArrowIcon 409651 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self upArrowIconContents readStream) ].! ! 409652 409653!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 3/18/2009 13:39'! 409654upArrowIconContents 409655 "Private - Method generated with the content of the file graphics\icons\upArrow.png" 409656 ^ 'iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAYAAADgdz34AAAABGdBTUEAALGPC/xhBQAAABh0 409657RVh0U29mdHdhcmUAUGFpbnQuTkVUIHYzLjM2qefiJQAAAH1JREFUSEtj/A8EDLQEIAtIAUC3 409658kKL8P2mqIb6lnQUgw2GYWFtIcg5NLWhoaIC7HmQRiE8MINoHyK4nJZiIsgCb4cRaMvAWODg4 409659oIQ9um9A8vgAUT6AGUDTVAQtUoZwPhj1ATG5HiW5EqUBVPoSq3A0DogKqdGcTFQwkaoIAGEN 409660sTct/gBTAAAAAElFTkSuQmCC'! ! 409661 409662!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 9/25/2008 15:45'! 409663warningIcon 409664 "Private - Generated method" 409665 ^icons 409666 at: #warningIcon 409667 ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self warningIconContents readStream) ].! ! 409668 409669!ThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/29/2007 12:43'! 409670warningIconContents 409671 "Private - Method generated with the content of the file icons\base\warning.png" 409672 ^ 'iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAYAAABXAvmHAAAABHNCSVQICAgIfAhkiAAAAAlw 409673SFlzAAAN1wAADdcBQiibeAAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 409674AAncSURBVGiB1VptbFRVGn7ec+98dDr9mHaA0o+hDst0ZkrpFkrtSt2UFaENEnfRQaKRiIk1 409675QRfiGiSuqzExIqkCKYn/9K8aN1nc/asJJEqKNqhhhS6slbqYUnewRWZop3PvPe/+mLmXmX7N 409676wAzZeJKTc+49zznnfd7zvu85584QM+OXnMT/W4BC0x0jECOy3amxM1PRCcSIemNE3wH44TrR 409677/cUef05i5qLl64D7OjD2M8A/A3wNmPiny7Wsu7tbBSCKOZeZi7oCDPyZgeWcqoMBj1fTDjU0 409678NFTt2bPHtWPHDqWY8wFFNKHrRHcx8KcM4cEAHJq2a9u5c/fpur4MQAkRFVVpRRuMgbcYcMwm 409679wIDoGB4+YBhGTUVFRWVvb29RnbsoBK4RbWRguyk0NTRABIMWidLp6dbIqVM9QoiltbW1pcVc 409680hYIHukakMDCQqfWS/n64jh7NWonmkZGnSqemaoUQ3r6+Pmeh85qpYAIM9DHQYgqqdHXBsXMn 409681bD09sG3dahGwadqyh06ceFRKWQOgYuPGjWqhcwMFEpgg8jDwmqVpIVA6MGC1u48cgbTZLBJ3 409682XbnyB/+PPwYMw6gJBAKlREQFSY8CCTDwKgPVVsTZvRvq2rVWuxIIwLV3r0WApHT2Dg7uVhSl 409683Vtf16t7eXntB0qMAAj8RhRjYYwqH8nKUHjxotUspAQDuV14BLV1qkVj600+/WX/uXIcQoq6m 409684pqa8UIe+bTtk4Cin+zOA0pdfhuHx4IP33sOpU6cwPT2NcDiMJ598EmWvv47Jp54y+9GGr7/e 409685NRQK/YuFmHz88cenANy4XTlui32U6AEGtphaFatWoWTvXhw/fhwff/wxYrEYZmZmMDQ0hEOH 409686DsH5xBNQ1661VsF940bj5tOne4jI53A4PIU49C0TiBLZGTiSGSLLjhwB2e04efIkDMOAruvQ 409687dR2GYeDixYsYuXQJlQMDWWF1zYULvy+bnvYDqC/EoW+ZAAN7GVhlCmLfsgWOBx5AMplEPB63 409688BM8kEY/H4ejqQskjj4ABSAA2TSvv+eyz7UTUSERLb9ehb4nAj0RLGXjZ0qSqouzoUQCA3W6H 409689z+ezhDcMA4ZhgIgQCoUAAJX9/UBJibUK/suX7/WNj7cIIVZ4vd6K23HoW+rAwEEGyk0BXM88 409690AzUtHACsXr3a0ryZw+EwnM7Uxqv6fCh/4YXMsKpuHBzcLqX0O53O2s2bN5fcMQLjRGsZ2G1N 4096917vWi7NVXszCtra1Z2td1He3t7VmYygMHoDQ0WCSWXb0abDl//h4AK+vq6qpu1aHzJpA+7wjL 409692cV97DaKyMgsTCATgdDqz7L+joyMLQyUlqO7vz3Lozq++2qpKuYqIVlRWVrpvxaHzIjBG9AgD 409693XeaE6po1KE3H9cykKArC4bClfY/HA5/PNwfn3rkTzq6um2E1Hvd2DQ1tEkI0VVVVLYtEInkf 409694uXMSGCMqYaA/U2OVAwOAMv/lqqmpydJ+c3PzvBhmhufwYbAQ1pirh4c3VExNhYQQK91ud94O 409695nRPEwAsM+MyJnA89BEd394L4YDBomdB8BHRdRyKRgAyF4Hz00czTqvO3g4NbhBAhAA3btm3L 40969668i9KIEfiBrSBFLnHacTlW+9teiAwWAQzAxd19HS0mK9NwwDMzMzSCQSVqnu3w+43dbe4B8d 409697DdddudJms9mCXq+3Op879KIE0qbjshz3+eehNjYuOqDT6cSKFStgs9nQ1NQEKSWSySQSicSc 409698nCwrA/bssVYBzGLD6dO/Y+aQEOIuu92ec4dekMBlog0M7LTCZl0dKl58cVHhzRQKhRAMBiGl 409699tLS9UE7u2AHp81kklkSjy5svXLiHiFpcLldNLoeel8B/iIR5TZTpgT2HDoFKS/MiEA6HEQ6H 409700kUgkMD09nWU2s8uEYWD62Wezwmr7mTN324FmAEGPx7PokXveBgaeYGCddd7p7IT7scdyCm7a 409701eSAQsAjkWoGZmRnE163DTHv7zY8AN26Urh8aupeIWjVN80UiEUfeBL4nKmfgoKl5JkL1sWPA 409702IqbIzEgmk5awQgj4/X5MTU0tKnxmvrp7N6SiWCRC588Hy+LxNYqirK6oqFjQoecQYOAvDCyz 409703Npldu+BYv35B4TVNyxLk3XffxYMPPoienh7s27cP8Xg8LwIxrxcTmzZZBFRNUzsHB+8RQrQR 4097040cqysjLXfA6dReAS0a8Y2Gc5rtuNqjfemFdwwzDmmMjnn3+Ot99+G5qmQdd1fPHFF3jnnXfm 4097052v0C+fLWrdDSYZUB+EZHa5dfubKOiNoURVne19c355yURYCBIxKwWzvuSy9BXb48q8PsyJLp 409706pOPj41kHOV3XEYvF5rX7+QjdEAKjvb2ZYRUdp0//mojamDmUSCTKZ6+CReA7os0MbLOW0O9H 4097075XPP3SSXtvOFhEkkEqivr4fD4ci61DQ0NOQ0n0xC37e14XpNjUWiOhotCwwP301E7Tabzdfd 4097083e2YQ2CESE1f0q2O3sOHQY4U1tz+c+Xq6mocOHAATU1NqK+vR19fHzo7OxfV+uw8nUzi7P33 409709Z4XV1jNn/DZNWyeEaPX7/VWZYZWYGd8S/ZGBY2kzguu++1D/yScwDMOy5/nKxdpy9ck1VsdH 409710H6H+229N08Y3ra3//bKz828A3p+YmPjyww8/jAMAXQSqAfybAY8J9r75JpRgEIauQ8+wacMw 409711rGdj1rOegZ2vbaG+1gVIyixcyeQk7v70U4uAoar8j4cfPhMrL//AMIy/j4yMjJ44cUJXGXgR 409712gIdvOjKi+/cj89ksZ78DUh+GFAD2HNh8ysXahK5T29BQ6NNNmzpVVb3Y2Nh4lYh+VhlYU4wJ 4097137iTWTFVXr5YwcwhAp91uH41EIlOCgeOZDjNfljnabxebK89Ol1auNIiohojWMXOzx+MpJ2bG 409714N0RdMbc7GF2yZEXM7a7VhHAxkUAq6EoAzIDglPeTTB32FOtd6llIQJAQglN356w2BgSIhEyX 409715nIqAqXomJvVOYYAohVchhH2yuto+UVWlAjCIaJSZ/5pMJt9TAaAFOLVr+/Zhu93eqihKgJkr 409716iUhlZpWZlXTYMs1dYWaViObUTUy6r5KuK8yszlO3MGkFCwBkzmFiiUgwsyAiI61MDUCCmQ1F 409717UTj1cZaZn3766WkAY8xcIoSIAbAZhqEoiqIg9ROpQkQi/U4wsyKlVIQQIj2pVaYFE2mCmfU5 4097182AyMAkAIIRQppSAiJUN4pMlxWvgRZv5S07RJMv8rQUQiEom4lixZ4p6ZmXEQkZBSkqqqZBgG 409719qapKUsqsOgAoikJSSpJSklnPfGez2TC7PR+MWc72A0VRdCnldU3Txs+ePXvNIpAmQQAoEoks 409720eo2LRqN5fbfp7u7G2NhY3t94Jicn88JGo1F58uRJycwyi8AvMf3i/63yP7O9OwbOgQFkAAAA 409721AElFTkSuQmCC'! ! 409722Model subclass: #ThemeSettings 409723 instanceVariableNames: 'windowColor selectionColor autoSelectionColor buttonColor scrollbarColor standardColorsOnly progressBarColor progressBarProgressColor menuColor menuTitleColor' 409724 classVariableNames: '' 409725 poolDictionaries: '' 409726 category: 'Polymorph-Widgets-Themes'! 409727!ThemeSettings commentStamp: 'gvc 5/18/2007 10:23' prior: 0! 409728Configurable basic settings for themes.! 409729 409730 409731!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 4/18/2007 11:45'! 409732autoSelectionColor 409733 "Answer the value of autoSelectionColor" 409734 409735 ^autoSelectionColor ifNil: [^true]! ! 409736 409737!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 10/12/2006 14:04'! 409738autoSelectionColor: anObject 409739 "Set the value of autoSelectionColor" 409740 409741 autoSelectionColor := anObject. 409742 self 409743 changed: #autoSelectionColor; 409744 changed: #manualSelectionColor; 409745 changed: #selectionColor! ! 409746 409747!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 9/17/2007 14:14'! 409748basicSelectionColor 409749 "Answer the recorded selection color rather than derived." 409750 409751 ^selectionColor! ! 409752 409753!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 4/16/2007 13:39'! 409754buttonColor 409755 "Answer the value of buttonColor" 409756 409757 ^buttonColor ifNil: [self windowColor]! ! 409758 409759!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 4/13/2007 17:05'! 409760buttonColor: anObject 409761 "Set the value of buttonColor" 409762 409763 buttonColor := anObject! ! 409764 409765!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 10/16/2008 16:12'! 409766menuColor 409767 "Answer the value of menuColor" 409768 409769 ^menuColor! ! 409770 409771!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 10/16/2008 16:12'! 409772menuColor: anObject 409773 "Set the value of menuColor" 409774 409775 menuColor := anObject! ! 409776 409777!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 10/16/2008 16:12'! 409778menuTitleColor 409779 "Answer the value of menuTitleColor" 409780 409781 ^menuTitleColor! ! 409782 409783!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 10/16/2008 16:12'! 409784menuTitleColor: anObject 409785 "Set the value of menuTitleColor" 409786 409787 menuTitleColor := anObject! ! 409788 409789!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 4/24/2007 11:50'! 409790progressBarColor 409791 "Answer the value of progressBarColor" 409792 409793 ^progressBarColor ifNil: [Preferences menuColor muchLighter]! ! 409794 409795!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 4/23/2007 17:20'! 409796progressBarColor: anObject 409797 "Set the value of progressBarColor" 409798 409799 progressBarColor := anObject! ! 409800 409801!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 4/24/2007 11:50'! 409802progressBarProgressColor 409803 "Answer the value of progressBarProgressColor" 409804 409805 ^progressBarProgressColor ifNil: [Preferences menuTitleColor]! ! 409806 409807!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 4/24/2007 11:45'! 409808progressBarProgressColor: anObject 409809 "Set the value of progressBarProgressColor" 409810 409811 progressBarProgressColor := anObject! ! 409812 409813!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 4/16/2007 13:40'! 409814scrollbarColor 409815 "Answer the value of scrollbarColor" 409816 409817 ^scrollbarColor ifNil: [self windowColor]! ! 409818 409819!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 4/16/2007 13:00'! 409820scrollbarColor: anObject 409821 "Set the value of scrollbarColor" 409822 409823 scrollbarColor := anObject! ! 409824 409825!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 10/26/2006 16:18'! 409826selectionColor 409827 "Answer the value of selectionColor" 409828 409829 ^self autoSelectionColor 409830 ifTrue: [self derivedSelectionColor] 409831 ifFalse: [selectionColor ifNil: [Preferences textHighlightColor]]! ! 409832 409833!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 9/22/2006 17:47'! 409834selectionColor: anObject 409835 "Set the value of selectionColor" 409836 409837 selectionColor := anObject! ! 409838 409839!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 4/18/2007 11:45'! 409840standardColorsOnly 409841 "Answer the value of standardColorsOnly" 409842 409843 ^standardColorsOnly ifNil: [^false]! ! 409844 409845!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 4/13/2007 17:01'! 409846standardColorsOnly: anObject 409847 "Set the value of standardColorsOnly" 409848 409849 standardColorsOnly := anObject! ! 409850 409851!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 9/22/2006 17:13'! 409852windowColor 409853 "Answer the value of windowColor" 409854 409855 ^ windowColor! ! 409856 409857!ThemeSettings methodsFor: 'accessing' stamp: 'gvc 10/12/2006 14:06'! 409858windowColor: anObject 409859 "Set the value of windowColor" 409860 409861 windowColor := anObject. 409862 self changed: #windowColor. 409863 self autoSelectionColor ifTrue: [self changed: #selectionColor]! ! 409864 409865 409866!ThemeSettings methodsFor: 'as yet unclassified' stamp: 'gvc 10/18/2006 12:11'! 409867applySettingsFrom: aThemeSettings 409868 "Change the settings to be those of aThemeSettings." 409869 409870 self 409871 windowColor: aThemeSettings windowColor; 409872 selectionColor: aThemeSettings selectionColor; 409873 autoSelectionColor: aThemeSettings autoSelectionColor! ! 409874 409875!ThemeSettings methodsFor: 'as yet unclassified' stamp: 'gvc 4/13/2007 17:06'! 409876defaultButtonColor 409877 "Answer the default button colour." 409878 409879 ^Color gray! ! 409880 409881!ThemeSettings methodsFor: 'as yet unclassified' stamp: 'gvc 4/16/2007 13:01'! 409882defaultScrollbarColor 409883 "Answer the default scrollbar colour." 409884 409885 ^Color gray! ! 409886 409887!ThemeSettings methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 17:48'! 409888defaultSelectionColor 409889 "Answer the default selection colour." 409890 409891 ^self defaultWindowColor! ! 409892 409893!ThemeSettings methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 17:14'! 409894defaultWindowColor 409895 "Answer the default window colour." 409896 409897 ^Color r: 0.501 g: 0.533 b: 0.976! ! 409898 409899!ThemeSettings methodsFor: 'as yet unclassified' stamp: 'gvc 10/12/2006 14:39'! 409900derivedSelectionColor 409901 "Answer a selection colour based on the window color." 409902 409903 ^self windowColor whiter lighter! ! 409904 409905!ThemeSettings methodsFor: 'as yet unclassified' stamp: 'gvc 10/12/2006 13:37'! 409906fromConfiguration: tree 409907 "Update the settings from the given tree." 409908 409909 (tree at: #windowColor ifAbsent: []) ifNotNilDo: [:v | self windowColor: v]. 409910 (tree at: #autoSelectionColor ifAbsent: []) ifNotNilDo: [:v | self autoSelectionColor: v]. 409911 (tree at: #selectionColor ifAbsent: []) ifNotNilDo: [:v | self selectionColor: v]! ! 409912 409913!ThemeSettings methodsFor: 'as yet unclassified' stamp: 'gvc 4/16/2007 13:00'! 409914initialize 409915 "Initialize the receiver." 409916 409917 super initialize. 409918 self 409919 autoSelectionColor: true; 409920 windowColor: self defaultWindowColor; 409921 selectionColor: self defaultSelectionColor; 409922 buttonColor: self defaultButtonColor; 409923 scrollbarColor: self defaultScrollbarColor; 409924 standardColorsOnly: false! ! 409925 409926!ThemeSettings methodsFor: 'as yet unclassified' stamp: 'gvc 10/12/2006 13:41'! 409927manualSelectionColor 409928 "Answer the inverse of autoSelectionColor." 409929 409930 ^self autoSelectionColor not! ! 409931 409932!ThemeSettings methodsFor: 'as yet unclassified' stamp: 'gvc 9/17/2007 14:14'! 409933toConfiguration: tree 409934 "Update the tree from the receiver." 409935 409936 tree at: #windowColor put: self windowColor. 409937 tree at: #autoSelectionColor put: self autoSelectionColor. 409938 tree at: #selectionColor put: self basicSelectionColor! ! 409939Object subclass: #ThirtyTwoBitRegister 409940 instanceVariableNames: 'hi low' 409941 classVariableNames: '' 409942 poolDictionaries: '' 409943 category: 'System-Digital Signatures'! 409944!ThirtyTwoBitRegister commentStamp: '<historical>' prior: 0! 409945I represent a 32-bit register. An instance of me can hold any non-negative integer in the range [0..(2^32 - 1)]. Operations are performed on my contents in place, like a hardware register, and results are always modulo 2^32. 409946 409947This class is primarily meant for use by the SecureHashAlgorithm class. 409948! 409949 409950 409951!ThirtyTwoBitRegister methodsFor: '*system-hashing-core' stamp: 'len 8/7/2002 17:37'! 409952asByteArray 409953 ^ ByteArray with: (low bitAnd: 16rFF) with: (low bitShift: -8) with: (hi bitAnd: 16rFF) with: (hi bitShift: -8)! ! 409954 409955!ThirtyTwoBitRegister methodsFor: '*system-hashing-core' stamp: 'DSM 1/20/2000 17:17'! 409956asReverseInteger 409957 "Answer the byte-swapped integer value of my current contents." 409958 409959 ^ ((low bitAnd: 16rFF) bitShift: 24) + 409960 ((low bitAnd: 16rFF00) bitShift: 8) + 409961 ((hi bitAnd: 16rFF) bitShift: 8) + 409962 (hi bitShift: -8) 409963! ! 409964 409965!ThirtyTwoBitRegister methodsFor: '*system-hashing-core' stamp: 'RJT 10/28/2005 15:42'! 409966bitShift: anInteger 409967 "Replace my contents with the bitShift of anInteger." 409968 self load: (self asInteger bitShift: anInteger). ! ! 409969 409970!ThirtyTwoBitRegister methodsFor: '*system-hashing-core' stamp: 'adrian_lienhard 7/21/2009 19:49'! 409971byte1: hi1 byte2: hi2 byte3: low1 byte4: low2 409972 hi := (hi1 bitShift: 8) + hi2. 409973 low := (low1 bitShift: 8) + low2.! ! 409974 409975!ThirtyTwoBitRegister methodsFor: '*system-hashing-core' stamp: 'len 8/15/2002 01:34'! 409976byteAt: anInteger 409977 anInteger = 1 ifTrue: [^ hi bitShift: -8]. 409978 anInteger = 2 ifTrue: [^ hi bitAnd: 16rFF]. 409979 anInteger = 3 ifTrue: [^ low bitShift: -8]. 409980 anInteger = 4 ifTrue: [^ low bitAnd: 16rFF]! ! 409981 409982!ThirtyTwoBitRegister methodsFor: '*system-hashing-core' stamp: 'adrian_lienhard 7/21/2009 19:49'! 409983reverseLoadFrom: aByteArray at: index 409984 "Load my 32-bit value from the four bytes of the given ByteArray 409985starting at the given index. Consider the first byte to contain the most 409986significant bits of the word (i.e., use big-endian byte ordering)." 409987 409988 hi := ((aByteArray at: index + 3) bitShift: 8) + ( aByteArray at: index + 2). 409989 low := ((aByteArray at: index + 1) bitShift: 8) + ( aByteArray at: index). 409990! ! 409991 409992!ThirtyTwoBitRegister methodsFor: '*system-hashing-core' stamp: 'len 8/15/2002 01:29'! 409993storeInto: aByteArray at: index 409994 "Store my 32-bit value into the four bytes of the given ByteArray starting at the given index. Consider the first byte to contain the most significant bits of the word (i.e., use big-endian byte ordering)." 409995 409996 aByteArray at: index put: (hi bitShift: -8). 409997 aByteArray at: index + 1 put: (hi bitAnd: 16rFF). 409998 aByteArray at: index + 2 put: (low bitShift: -8). 409999 aByteArray at: index + 3 put: (low bitAnd: 16rFF)! ! 410000 410001 410002!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/14/1999 16:03'! 410003asInteger 410004 "Answer the integer value of my current contents." 410005 410006 ^ (hi bitShift: 16) + low 410007! ! 410008 410009!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/7/1999 15:26'! 410010hi 410011 410012 ^ hi 410013! ! 410014 410015!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/14/1999 16:07'! 410016load: anInteger 410017 "Set my contents to the value of given integer." 410018 410019 low := anInteger bitAnd: 16rFFFF. 410020 hi := (anInteger bitShift: -16) bitAnd: 16rFFFF. 410021 self asInteger = anInteger 410022 ifFalse: [self error: 'out of range: ', anInteger printString]. 410023! ! 410024 410025!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/14/1999 16:07'! 410026loadFrom: aByteArray at: index 410027 "Load my 32-bit value from the four bytes of the given ByteArray starting at the given index. Consider the first byte to contain the most significant bits of the word (i.e., use big-endian byte ordering)." 410028 410029 hi := ((aByteArray at: index) bitShift: 8) + ( aByteArray at: index + 1). 410030 low := ((aByteArray at: index + 2) bitShift: 8) + ( aByteArray at: index + 3). 410031! ! 410032 410033!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/7/1999 15:26'! 410034low 410035 410036 ^ low! ! 410037 410038 410039!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:36'! 410040+= aThirtTwoBitRegister 410041 "Replace my contents with the sum of the given register and my current contents." 410042 410043 | lowSum | 410044 lowSum := low + aThirtTwoBitRegister low. 410045 hi := (hi + aThirtTwoBitRegister hi + (lowSum bitShift: -16)) bitAnd: 16rFFFF. 410046 low := lowSum bitAnd: 16rFFFF. 410047! ! 410048 410049!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:41'! 410050bitAnd: aThirtTwoBitRegister 410051 "Replace my contents with the bitwise AND of the given register and my current contents." 410052 410053 hi := hi bitAnd: aThirtTwoBitRegister hi. 410054 low := low bitAnd: aThirtTwoBitRegister low. 410055! ! 410056 410057!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:40'! 410058bitInvert 410059 "Replace my contents with the bitwise inverse my current contents." 410060 410061 hi := hi bitXor: 16rFFFF. 410062 low := low bitXor: 16rFFFF. 410063! ! 410064 410065!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:40'! 410066bitOr: aThirtTwoBitRegister 410067 "Replace my contents with the bitwise OR of the given register and my current contents." 410068 410069 hi := hi bitOr: aThirtTwoBitRegister hi. 410070 low := low bitOr: aThirtTwoBitRegister low. 410071! ! 410072 410073!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:38'! 410074bitXor: aThirtTwoBitRegister 410075 "Replace my contents with the bitwise exclusive OR of the given register and my current contents." 410076 410077 hi := hi bitXor: aThirtTwoBitRegister hi. 410078 low := low bitXor: aThirtTwoBitRegister low. 410079! ! 410080 410081!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 23:09'! 410082leftRotateBy: bits 410083 "Rotate my contents left by the given number of bits, retaining exactly 32 bits." 410084 "Details: Perform this operation with as little LargeInteger arithmetic as possible." 410085 410086 | bitCount s1 s2 newHi | 410087 "ensure bitCount is in range [0..32]" 410088 bitCount := bits \\ 32. 410089 bitCount < 0 ifTrue: [bitCount := bitCount + 32]. 410090 410091 bitCount > 16 410092 ifTrue: [ 410093 s1 := bitCount - 16. 410094 s2 := s1 - 16. 410095 newHi := ((low bitShift: s1) bitAnd: 16rFFFF) bitOr: (hi bitShift: s2). 410096 low := ((hi bitShift: s1) bitAnd: 16rFFFF) bitOr: (low bitShift: s2). 410097 hi := newHi] 410098 ifFalse: [ 410099 s1 := bitCount. 410100 s2 := s1 - 16. 410101 newHi := ((hi bitShift: s1) bitAnd: 16rFFFF) bitOr: (low bitShift: s2). 410102 low := ((low bitShift: s1) bitAnd: 16rFFFF) bitOr: (hi bitShift: s2). 410103 hi := newHi] 410104! ! 410105 410106 410107!ThirtyTwoBitRegister methodsFor: 'copying' stamp: 'jm 12/7/1999 15:26'! 410108copy 410109 "Use the clone primitive for speed." 410110 410111 <primitive: 148> 410112 ^ super copy 410113! ! 410114 410115 410116!ThirtyTwoBitRegister methodsFor: 'printing' stamp: 'laza 3/29/2004 12:22'! 410117printOn: aStream 410118 "Print my contents in hex with a leading 'R' to show that it is a register object being printed." 410119 410120 aStream nextPutAll: 'R:'. 410121 self asInteger storeOn: aStream base: 16. 410122! ! 410123 410124"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 410125 410126ThirtyTwoBitRegister class 410127 instanceVariableNames: ''! 410128 410129!ThirtyTwoBitRegister class methodsFor: 'instance creation' stamp: 'jm 12/14/1999 16:05'! 410130new 410131 "Answer a new instance whose initial contents is zero." 410132 410133 ^ super new load: 0 410134! ! 410135Object subclass: #ThreadSafeTranscript 410136 instanceVariableNames: 'stream accessSemaphore' 410137 classVariableNames: '' 410138 poolDictionaries: '' 410139 category: 'Tools-Transcript'! 410140!ThreadSafeTranscript commentStamp: 'stephane.ducasse 4/1/2009 21:25' prior: 0! 410141I'm an output device. 410142 410143Ultimately I can replace TranscripterStream since I'm thread safe and TranscripterStream. 410144 410145ThreadSafeTranscript can be installed as the default transcript using 410146ThreadSafeTranscript installThreadSafeAsTranscript 410147 410148It can be installed as another Transcript accessible using STranscript 410149ThreadSafeTranscript installThreadSafeAsSTranscript 410150! 410151 410152 410153!ThreadSafeTranscript methodsFor: 'color' stamp: 'sd 5/18/2007 22:33'! 410154black 410155 "copied from Transcripter" 410156 410157 Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"]. 410158 ^ Color black! ! 410159 410160!ThreadSafeTranscript methodsFor: 'color' stamp: 'sd 5/18/2007 22:33'! 410161white 410162 "copied from Transcripter" 410163 410164 Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"]. 410165 ^ Color white! ! 410166 410167 410168!ThreadSafeTranscript methodsFor: 'initialize' stamp: 'stephane.ducasse 4/1/2009 20:20'! 410169initialize 410170 410171 super initialize. 410172 accessSemaphore := Mutex new. 410173 stream := String new writeStream.! ! 410174 410175 410176!ThreadSafeTranscript methodsFor: 'printing' stamp: 'stephane.ducasse 3/31/2009 19:29'! 410177isSelfEvaluating 410178 410179 self == Transcript ifTrue: [^true]. 410180 ^super isSelfEvaluating! ! 410181 410182!ThreadSafeTranscript methodsFor: 'printing' stamp: 'stephane.ducasse 3/31/2009 19:33'! 410183printOn: aStream 410184 410185 self == Transcript ifFalse: [^super printOn: aStream]. 410186 aStream nextPutAll: 'Transcript'! ! 410187 410188 410189!ThreadSafeTranscript methodsFor: 'protected low level' stamp: 'lr 4/1/2009 10:23'! 410190contents 410191 ^ accessSemaphore critical: [ stream contents ]! ! 410192 410193!ThreadSafeTranscript methodsFor: 'protected low level' stamp: 'stephane.ducasse 3/28/2009 21:21'! 410194space 410195 410196 accessSemaphore 410197 critical: [stream space]. 410198! ! 410199 410200!ThreadSafeTranscript methodsFor: 'protected low level' stamp: 'sd 5/19/2007 10:36'! 410201tab 410202 410203 accessSemaphore 410204 critical: [stream tab]. 410205! ! 410206 410207 410208!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'NouryBouraqadi 10/18/2009 18:15'! 410209<< aString 410210 410211 self show: aString! ! 410212 410213!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'sd 5/19/2007 10:33'! 410214characterLimit 410215 410216 ^ 20000! ! 410217 410218!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'lr 4/1/2009 10:23'! 410219clear 410220 "Clear all characters and redisplay the view" 410221 410222 self changed: #clearText. 410223 accessSemaphore 410224 critical: [ stream reset ]! ! 410225 410226!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'lr 4/1/2009 10:25'! 410227close 410228 self flush. 410229 accessSemaphore critical: [ stream close ] 410230 ! ! 410231 410232!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'sd 5/18/2007 15:05'! 410233cr 410234 410235 accessSemaphore 410236 critical: [stream cr]. 410237! ! 410238 410239!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'NouryBouraqadi 10/18/2009 18:12'! 410240crShow: anObject 410241 410242 self cr; show: anObject! ! 410243 410244!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'DaleHenrichs 8/9/2009 09:15'! 410245endEntry 410246 "Display all the characters since the last endEntry, and reset the 410247 stream " 410248 410249 accessSemaphore critical: [ 410250 self changed: #appendEntry. 410251 World displayWorldSafely. 410252 stream resetContents]! ! 410253 410254!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'sd 5/18/2007 22:58'! 410255flush 410256 self endEntry 410257! ! 410258 410259!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'sd 5/18/2007 15:04'! 410260nextPut: value 410261 410262 accessSemaphore 410263 critical: [stream nextPut: value]. 410264 ^value! ! 410265 410266!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'sd 5/18/2007 22:31'! 410267nextPutAll: value 410268 410269 accessSemaphore 410270 critical: [stream nextPutAll: value]. 410271 ^value! ! 410272 410273!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'sd 3/27/2009 08:43'! 410274pastEndPut: anObject 410275 "If the stream reaches its limit, just output the contents and reset." 410276 410277 self endEntry. 410278 ^ self nextPut: anObject! ! 410279 410280!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'NouryBouraqadi 10/2/2009 15:59'! 410281print: anObject 410282 410283 self nextPutAll: anObject asString! ! 410284 410285!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'stephane.ducasse 3/28/2009 21:32'! 410286reset 410287 ! ! 410288 410289!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'NouryBouraqadi 10/2/2009 15:59'! 410290show: anObject 410291 410292 self print: anObject ; endEntry! ! 410293 410294!ThreadSafeTranscript methodsFor: 'streaming' stamp: 'lr 4/1/2009 10:24'! 410295with: aBlock 410296 ^ accessSemaphore critical: [ aBlock value: stream ]! ! 410297 410298 410299!ThreadSafeTranscript methodsFor: 'ui building' stamp: 'damiencassou 8/8/2009 19:28'! 410300buildWith: builder 410301 410302 ^ self buildWith: builder labeled: self title! ! 410303 410304!ThreadSafeTranscript methodsFor: 'ui building' stamp: 'damiencassou 8/8/2009 19:28'! 410305buildWith: builder labeled: aString 410306 410307 | windowSpec textSpec | 410308 windowSpec := builder pluggableWindowSpec new. 410309 windowSpec model: self. 410310 windowSpec label: aString. 410311 windowSpec children: OrderedCollection new. 410312 410313 textSpec := builder pluggableTextSpec new. 410314 textSpec 410315 model: self; 410316 menu: #codePaneMenu:shifted:; 410317 frame: (0@0corner: 1@1). 410318 windowSpec children add: textSpec. 410319 410320 ^builder build: windowSpec! ! 410321 410322!ThreadSafeTranscript methodsFor: 'ui building' stamp: 'stephane.ducasse 3/28/2009 22:00'! 410323closeAllViews 410324 "self new closeAllViews" 410325 410326 self dependents do: 410327 [:d | (d isSystemWindow) ifTrue: [d delete]]! ! 410328 410329!ThreadSafeTranscript methodsFor: 'ui building' stamp: 'NouryBouraqadi 10/18/2009 17:47'! 410330initialExtent 410331 410332 ^447@300! ! 410333 410334!ThreadSafeTranscript methodsFor: 'ui building' stamp: 'damiencassou 8/8/2009 19:30'! 410335open 410336 "self new open" 410337 ^ self openAsMorphLabel: self title 410338! ! 410339 410340!ThreadSafeTranscript methodsFor: 'ui building' stamp: 'damiencassou 8/8/2009 19:29'! 410341openAsMorphLabel: aString 410342 ^ (self buildWith: ToolBuilder default labeled: aString) 410343 openInWorld; 410344 yourself! ! 410345 410346!ThreadSafeTranscript methodsFor: 'ui building' stamp: 'lr 9/22/2009 11:40'! 410347title 410348 410349 ^ 'Transcript'! ! 410350 410351 410352!ThreadSafeTranscript methodsFor: 'model protocol' stamp: 'yann.monclair 9/4/2009 16:26'! 410353codePaneMenu: aMenu shifted: shifted 410354 "Copied from TranscriptStream>>#codePaneMenu:shifted:" 410355 ^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted 410356! ! 410357 410358"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 410359 410360ThreadSafeTranscript class 410361 instanceVariableNames: ''! 410362 410363!ThreadSafeTranscript class methodsFor: 'color' stamp: 'lr 9/22/2009 11:39'! 410364windowColorSpecification 410365 "Answer a WindowColorSpec object that declares my preference" 410366 410367 ^ WindowColorSpec classSymbol: self name wording: 'Transcript' brightColor: #lightBlue pastelColor: #paleOrange helpMessage: 'The system transcript'! ! 410368 410369 410370!ThreadSafeTranscript class methodsFor: 'declare' stamp: 'sd 3/27/2009 08:47'! 410371install 410372 410373 self installThreadSafeAsTranscript! ! 410374 410375!ThreadSafeTranscript class methodsFor: 'declare' stamp: 'sd 3/27/2009 08:48'! 410376installThreadSafeAsSTranscript 410377 410378 Smalltalk at: #STranscript put: (self new) 410379 410380 "ThreadSafeTranscript open"! ! 410381 410382!ThreadSafeTranscript class methodsFor: 'declare' stamp: 'sd 3/27/2009 08:46'! 410383installThreadSafeAsTranscript 410384 410385 Smalltalk at: #Transcript put: (self new) 410386 410387 "ThreadSafeTranscript open"! ! 410388 410389 410390!ThreadSafeTranscript class methodsFor: 'examples' stamp: 'stephane.ducasse 3/28/2009 21:37'! 410391examples 410392 "self examples" 410393 410394 | tt | 410395 Smalltalk at: #STranscript ifAbsent: [self installThreadSafeAsSTranscript]. 410396 tt := (Smalltalk at: #STranscript). 410397 tt open. 410398 tt nextPutAll: 'Pharo'; flush; cr; tab. 410399 tt show: ' is cool' ; cr. 410400 tt reset. 410401 tt clear. 410402 tt nextPutAll: 'Pharo'; flush; cr; tab. 410403 tt show: ' is really cool' ; cr.! ! 410404 410405!ThreadSafeTranscript class methodsFor: 'examples' stamp: 'stephane.ducasse 3/28/2009 21:49'! 410406examplesConcurrent 410407 "self examplesConcurrent" 410408 410409 | tt | 410410 Smalltalk at: #STranscript ifAbsent: [self installThreadSafeAsSTranscript]. 410411 tt := (Smalltalk at: #STranscript). 410412 tt open. 410413 [1 to: 10 do: [:i | tt nextPutAll: i printString; nextPutAll: '*'. 410414 Processor yield ]. 410415 tt flush ] fork. 410416 [100 to: 110 do: [:i | tt nextPutAll: i printString; nextPutAll: '-'. 410417 Processor yield ]. 410418 tt flush ] fork.! ! 410419 410420!ThreadSafeTranscript class methodsFor: 'examples' stamp: 'DaleHenrichs 8/9/2009 09:28'! 410421examplesForegroundUpdate 410422 "self examplesForegroundUpdate" 410423 410424 | tt length | 410425 Smalltalk at: #STranscript ifAbsent: [self installThreadSafeAsSTranscript]. 410426 tt := (Smalltalk at: #STranscript). 410427 tt open. 410428 length := 20. 410429 tt cr; show: 'STARTING----->'. 410430 "Foreground updates" 410431 1000 410432 to: 1000 + length 410433 do: [:i | 410434 tt show: '---' , i printString , '---'. 410435 (Delay forSeconds: 1) wait ]! ! 410436 410437!ThreadSafeTranscript class methodsFor: 'examples' stamp: 'DaleHenrichs 8/9/2009 09:33'! 410438examplesHighlyConcurrent 410439 "self examplesHighlyConcurrent" 410440 410441 | tt length | 410442 Smalltalk at: #STranscript ifAbsent: [self installThreadSafeAsSTranscript]. 410443 tt := (Smalltalk at: #STranscript). 410444 tt open. 410445 length := 20. 410446 tt cr; show: 'STARTING----->'. 410447 length 410448 timesRepeat: [[ 410449 "Background updates" 410450 [0 410451 to: 0 + length 410452 do: [:i | 410453 tt nextPutAll: '[' , i printString , ']'; 410454 nextPutAll: '*'; 410455 flush. 410456 Processor yield]] fork. 410457 "Background updates" 410458 [500 410459 to: 500 + length 410460 do: [:i | 410461 tt nextPutAll: '{' , i printString , '}'; 410462 nextPutAll: '-'; 410463 flush. 410464 Processor yield]] fork] fork]. 410465 "Display updates" 410466 length 410467 timesRepeat: [[[length timesRepeat: [World displayWorldSafely] fork]] fork]. 410468 "Foreground updates" 410469 1000 410470 to: 1000 + length 410471 do: [:i | 410472 tt show: '---' , i printString , '---'. 410473 Processor yield]! ! 410474 410475 410476!ThreadSafeTranscript class methodsFor: 'toolbuilder' stamp: 'sd 3/27/2009 07:49'! 410477buildWith: aBuilder 410478 "(self buildWith: MorphicToolBuilder new) openInWorld" 410479 ^self new buildWith: aBuilder! ! 410480 410481!ThreadSafeTranscript class methodsFor: 'toolbuilder' stamp: 'stephane.ducasse 3/28/2009 21:33'! 410482open 410483 "self open" 410484 410485 ^ self new open ! ! 410486ImageMorph subclass: #ThreePhaseButtonMorph 410487 instanceVariableNames: 'offImage pressedImage state target actionSelector arguments actWhen' 410488 classVariableNames: 'AuthorModeOwner' 410489 poolDictionaries: '' 410490 category: 'Morphic-Widgets'! 410491!ThreePhaseButtonMorph commentStamp: '<historical>' prior: 0! 410492A button morph with separate images for on, off, and pressed with the mouse. 410493 410494When the event actWhen occurs, send actionSelector with 'arguments' to target. For other events, default to my eventHandler. The current event is not supplied in the arguments to the actionSelector. 410495 410496image (a.k.a. onImage) may not be nil. offImage and pressedImage may be nil. nil there means be transparent and show the underlying object. 410497 410498Tools for debugging: 410499Display the images momentarily under program control (for positioning) (self is an instance). 410500 self state: #on. self state: #off. 410501 self state: #pressed. self state: #off. 410502Display a rectangle where the button is. 410503 Display fillWithColor: bounds + (self world viewBox origin). 410504 self invalidRect: bounds.! 410505 410506 410507!ThreePhaseButtonMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 8/27/2009 16:08'! 410508onImage: aForm 410509 "The main image is used when on. 410510 Go through ImageMorph method to set extent." 410511 410512 self image: aForm! ! 410513 410514 410515!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:49'! 410516actionSelector 410517 410518 ^ actionSelector 410519! ! 410520 410521!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:49'! 410522actionSelector: aSymbolOrString 410523 410524 (nil = aSymbolOrString or: 410525 ['nil' = aSymbolOrString or: 410526 [aSymbolOrString isEmpty]]) 410527 ifTrue: [^ actionSelector := nil]. 410528 410529 actionSelector := aSymbolOrString asSymbol. 410530! ! 410531 410532!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 7/1/97 12:39'! 410533arguments 410534 ^ arguments! ! 410535 410536!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 7/1/97 08:39'! 410537arguments: aCollection 410538 410539 arguments := aCollection asArray copy. 410540! ! 410541 410542!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 10/19/97 15:02'! 410543offImage 410544 ^ offImage! ! 410545 410546!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:08'! 410547offImage: aForm 410548 offImage := aForm. 410549 self invalidRect: self bounds.! ! 410550 410551!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 10/19/97 15:02'! 410552onImage 410553 ^ image! ! 410554 410555!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 10/19/97 15:02'! 410556pressedImage 410557 ^ pressedImage! ! 410558 410559!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:09'! 410560pressedImage: aForm 410561 pressedImage := aForm. 410562 self invalidRect: self bounds.! ! 410563 410564!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 11:01'! 410565state: newState 410566 "Change the image and invalidate the rect." 410567 410568 newState == state ifTrue: [^ self]. 410569 state := newState. 410570 self invalidRect: bounds. "All three images must be the same size"! ! 410571 410572!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:50'! 410573target 410574 410575 ^ target 410576! ! 410577 410578!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:50'! 410579target: anObject 410580 410581 target := anObject 410582! ! 410583 410584 410585!ThreePhaseButtonMorph methodsFor: 'button' stamp: 'dgd 2/22/2003 18:45'! 410586doButtonAction 410587 "Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments." 410588 410589 (target notNil and: [actionSelector notNil]) 410590 ifTrue: 410591 [Cursor normal 410592 showWhile: [target perform: actionSelector withArguments: arguments]. 410593 target isMorph ifTrue: [target changed]]! ! 410594 410595 410596!ThreePhaseButtonMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:02'! 410597veryDeepFixupWith: deepCopier 410598 "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 410599 410600super veryDeepFixupWith: deepCopier. 410601target := deepCopier references at: target ifAbsent: [target]. 410602arguments := arguments collect: [:each | 410603 deepCopier references at: each ifAbsent: [each]]. 410604! ! 410605 410606!ThreePhaseButtonMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:01'! 410607veryDeepInner: deepCopier 410608 "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." 410609 410610super veryDeepInner: deepCopier. 410611offImage := offImage veryDeepCopyWith: deepCopier. 410612pressedImage := pressedImage veryDeepCopyWith: deepCopier. 410613state := state veryDeepCopyWith: deepCopier. 410614"target := target. Weakly copied" 410615"actionSelector := actionSelector. Symbol" 410616"arguments := arguments. Weakly copied" 410617actWhen := actWhen. "Symbol"! ! 410618 410619 410620!ThreePhaseButtonMorph methodsFor: 'drawing' stamp: 'tk 10/9/2002 10:20'! 410621drawOn: aCanvas 410622 410623 state == #off ifTrue: [ 410624 offImage ifNotNil: [aCanvas translucentImage: offImage at: bounds origin]]. 410625 state == #pressed ifTrue: [ 410626 pressedImage ifNotNil: [aCanvas translucentImage: pressedImage at: bounds origin]]. 410627 state == #on ifTrue: [ 410628 image ifNotNil: [aCanvas translucentImage: image at: bounds origin]].! ! 410629 410630 410631!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'RAA 8/15/2000 16:27'! 410632doButtonAction: evt 410633 | moreArgs | 410634 "Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments." 410635 410636 target ifNil: [^self]. 410637 actionSelector ifNil: [^self]. 410638 Cursor normal showWhile: [ 410639 moreArgs := actionSelector numArgs > arguments size ifTrue: [ 410640 arguments copyWith: evt 410641 ] ifFalse: [ 410642 arguments 410643 ]. 410644 target perform: actionSelector withArguments: moreArgs 410645 ]! ! 410646 410647!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'tk 6/30/97 10:52'! 410648handlesMouseDown: evt 410649 410650 ^ true 410651! ! 410652 410653!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:18'! 410654handlesMouseStillDown: evt 410655 ^actWhen == #whilePressed! ! 410656 410657!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:16'! 410658mouseDown: evt 410659 | now dt | 410660 self state: #pressed. 410661 actWhen == #buttonDown 410662 ifTrue: 410663 [self doButtonAction] 410664 ifFalse: 410665 [now := Time millisecondClockValue. 410666 super mouseDown: evt. 410667 "Allow on:send:to: to set the response to events other than actWhen" 410668 dt := Time millisecondClockValue - now max: 0. "Time it took to do" 410669 dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]]. 410670 self mouseStillDown: evt.! ! 410671 410672!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:18'! 410673mouseMove: evt 410674 (self containsPoint: evt cursorPoint) 410675 ifTrue: [self state: #pressed. 410676 super mouseMove: evt] 410677 "Allow on:send:to: to set the response to events other than actWhen" 410678 ifFalse: [self state: #off]. 410679! ! 410680 410681!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:17'! 410682mouseStillDown: evt 410683 actWhen == #whilePressed ifFalse:[^self]. 410684 (self containsPoint: evt cursorPoint) ifTrue:[self doButtonAction].! ! 410685 410686!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:17'! 410687mouseUp: evt 410688 "Allow on:send:to: to set the response to events other than actWhen" 410689 actWhen == #buttonUp ifFalse: [^super mouseUp: evt]. 410690 410691 (self containsPoint: evt cursorPoint) ifTrue: [ 410692 self state: #on. 410693 self doButtonAction: evt 410694 ] ifFalse: [ 410695 self state: #off. 410696 target ifNotNil: [target mouseUpBalk: evt] 410697 ]. 410698 "Allow owner to keep it selected for radio buttons" 410699! ! 410700 410701 410702!ThreePhaseButtonMorph methodsFor: 'geometry' stamp: 'tk 7/1/97 09:14'! 410703extent: aPoint 410704 "Do it normally" 410705 410706 self changed. 410707 bounds := bounds topLeft extent: aPoint. 410708 self layoutChanged. 410709 self changed. 410710! ! 410711 410712 410713!ThreePhaseButtonMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:13'! 410714initialize 410715 410716 super initialize. 410717 state := #off. 410718 target := nil. 410719 actionSelector := #flash. 410720 arguments := EmptyArray. 410721 actWhen := #buttonUp. 410722 410723 "self on: #mouseStillDown send: #dragIfAuthoring: to: self." 410724 "real move should include a call on dragIfAuthoring: "! ! 410725 410726 410727!ThreePhaseButtonMorph methodsFor: 'printing' stamp: 'dgd 2/22/2003 18:45'! 410728printOn: aStream 410729 | string | 410730 aStream nextPutAll: '3PButton'. 410731 arguments notEmpty 410732 ifTrue: [string := arguments at: (2 min: arguments size)]. 410733 aStream nextPutAll: '('. 410734 (string notNil and: [string ~~ self]) 410735 ifTrue: 410736 [aStream 410737 print: string; 410738 space] 410739 ifFalse: 410740 [aStream 410741 print: actionSelector; 410742 space]. 410743 aStream 410744 print: self identityHash; 410745 nextPutAll: ')'! ! 410746 410747 410748!ThreePhaseButtonMorph methodsFor: 'stepping and presenter' stamp: 'ar 10/11/2000 14:05'! 410749step 410750 (self hasProperty: #doesButtonAction) ifTrue:[ 410751 self doButtonAction. 410752 self setProperty: #didButtonAction toValue: true. 410753 ].! ! 410754 410755 410756!ThreePhaseButtonMorph methodsFor: 'submorphs-add/remove' stamp: 'tk 6/30/97 10:49'! 410757actWhen: condition 410758 "Accepts symbols: #buttonDown, #buttonUp, and #whilePressed" 410759 actWhen := condition! ! 410760 410761 410762!ThreePhaseButtonMorph methodsFor: 'testing' stamp: 'sw 3/8/1999 13:56'! 410763isOn 410764 ^ state == #on! ! 410765 410766!ThreePhaseButtonMorph methodsFor: 'testing' stamp: 'ar 10/11/2000 14:05'! 410767stepTime 410768 (self hasProperty: #doesButtonAction) ifTrue:[^1]. 410769 ^super stepTime! ! 410770 410771!ThreePhaseButtonMorph methodsFor: 'testing' stamp: 'ar 10/11/2000 14:06'! 410772wantsSteps 410773 ^(self hasProperty: #doesButtonAction) or:[super wantsSteps]! ! 410774 410775"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 410776 410777ThreePhaseButtonMorph class 410778 instanceVariableNames: ''! 410779 410780!ThreePhaseButtonMorph class methodsFor: 'initialization' stamp: 'ar 5/25/2000 18:01'! 410781initialize 410782 "ThreePhaseButtonMorph initialize" 410783 | extent inset | 410784 extent := 12@12. 410785 inset := 3. 410786 410787 #('CheckBoxOff' 'CheckBoxOn' 'CheckBoxPressed') do: [:button | 410788 | f r | 410789 f := ColorForm extent: extent depth: 1. 410790 f colors: {Color transparent. Color black}. 410791 f borderWidth: 1. 410792 r := f boundingBox insetBy: inset. 410793 button = 'CheckBoxPressed' ifTrue: [f border: r width: 1]. 410794 button = 'CheckBoxOn' ifTrue: [f fillBlack: r]. 410795 ScriptingSystem saveForm: f atKey: button]. 410796 410797 #('RadioButtonOff' 'RadioButtonOn' 'RadioButtonPressed') do: [:button | 410798 | f r c | 410799 f := ColorForm extent: extent depth: 1. 410800 f colors: {Color transparent. Color black}. 410801 r := f boundingBox. 410802 c := f getCanvas. 410803 c frameOval: r color: Color black. 410804 r := r insetBy: inset. 410805 button = 'RadioButtonPressed' ifTrue: 410806 [c frameOval: r color: Color black]. 410807 button = 'RadioButtonOn' ifTrue: 410808 [c fillOval: r color: Color black]. 410809 ScriptingSystem saveForm: f atKey: button]! ! 410810 410811 410812!ThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: 'bf 10/8/1999 15:23'! 410813checkBox 410814 "Answer a button pre-initialized with checkbox images." 410815 | f | 410816 ^self new 410817 onImage: (f := ScriptingSystem formAtKey: 'CheckBoxOn'); 410818 pressedImage: (ScriptingSystem formAtKey: 'CheckBoxPressed'); 410819 offImage: (ScriptingSystem formAtKey: 'CheckBoxOff'); 410820 extent: f extent + (2@0); 410821 yourself 410822! ! 410823 410824!ThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: 'bf 10/8/1999 15:14'! 410825radioButton 410826 "Answer a button pre-initialized with radiobutton images." 410827 | f | 410828 ^self new 410829 onImage: (f := ScriptingSystem formAtKey: 'RadioButtonOn'); 410830 pressedImage: (ScriptingSystem formAtKey: 'RadioButtonPressed'); 410831 offImage: (ScriptingSystem formAtKey: 'RadioButtonOff'); 410832 extent: f extent + (2@0); 410833 yourself 410834! ! 410835ImageMorph subclass: #ThumbnailImageMorph 410836 instanceVariableNames: 'imagePopupMorph desiredExtent isPopup' 410837 classVariableNames: '' 410838 poolDictionaries: '' 410839 category: 'Morphic-Basic'! 410840!ThumbnailImageMorph commentStamp: 'wiz 2/19/2006 18:10' prior: 0! 410841A ThumbnailImageMorph is variant of Lex Spoon's CDScreenShotMorph. It displays a thumbnail of the image stored in imagePopupMorph. As a super class of PopupThumbnail morph it is meant to be a thumbnail w/o the popup action. Basicly it provides a scalable thumbnail with the usual morph event behaviors. 410842 410843A menu item allows for "photographing" any morph on the screen to become the subject of our images. 410844 410845Instance Variables 410846 imagePopupMorph: <anImageMorph> 410847 image: <aForm> 410848 desiredExtent <aPoint> 410849 isPopup <aBool> 410850imagePopupMorph 410851 - an ImageMorph containing the full sized image. 410852 - it can be set from a morph image via the sight target menu item. 410853image 410854 - holds the scaled thumbnail form of our imagePopupMorph image. 410855desiredExtent 410856 - holds the desired extent that the thumbnail is expected to fit within. 410857 - it is guarded to be positive and non-zero. 410858 - it can be set by extent: so that the yellow halo handle works. 410859isPopup 410860 - true when popup feature is on. 410861 - toggled from red halo menu 410862 410863Setting the size of the thumbnail works somewhat excentrically because the extent of the thumbnail depends both on the desiredExtent and the aspect ratio of the current popup image. 410864 410865With the popup feature off this morph can be picked up and dropped with the mouse. 410866When the feature is on, a full sized snapshot will be seen when the mouse is pressed. 410867Since the mouse can't be used for two things at once, moving the morph must be done with the grab halo or brown move halo.! 410868 410869 410870!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 9/14/2005 23:53'! 410871extent: anExtentPoint 410872"Set the desired extetnt for the thumbnail. It is guarenteed to fit within the desired extent. 410873The desitedExtent is guarded to prevent deviant forms from being attempted." 410874 410875self changed . "We might be bigger before we change." 410876desiredExtent := anExtentPoint guarded. 410877self newThumbnail: imagePopupMorph image . 410878! ! 410879 410880!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 9/14/2005 23:55'! 410881newImage: aForm 410882 "Use aForm as the new popupImage and update the thumbnail image." 410883 410884 imagePopupMorph 410885 ifNil: [ imagePopupMorph := aForm asMorph] 410886 ifNotNil: [ imagePopupMorph image: aForm ] . 410887 410888 self newThumbnail: aForm 410889 410890 ! ! 410891 410892!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 2/19/2006 14:12'! 410893newThumbnail: aForm 410894 "Use aForm as the new popupImage and update the thumbnail image." 410895 | scale thumbForm border smoothing | 410896 410897 scale := aForm extent scaleTo: desiredExtent . 410898 smoothing := (scale x < 1.0 or: [ scale y < 1.0 ]) ifTrue: [ 2 ] ifFalse: [ 1 ] . 410899 410900 thumbForm := aForm magnify: aForm boundingBox by: scale smoothing: smoothing . 410901 410902 self image: thumbForm . "heres where we put in a thumbnail" 410903 "We need the following to keep the border the right size. Otherwise it will shrink." 410904 (border := self borderStyle) == BorderStyle default ifFalse: [ self borderStyle: border ] . 410905 410906 "We have changed clear the old and show the new" 410907 self invalidRect: self bounds . ! ! 410908 410909!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 2/19/2006 14:48'! 410910popupFeatureString 410911 "Answer the string to be shown in a menu to represent the 410912 stickiness status" 410913 ^ (self yesNoStringFor: (isPopup == true ) ) 410914 , 'Popup feature' translated! ! 410915 410916!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 11/3/2005 01:17'! 410917target: aMorph 410918 "Snap aMorphs current image and show its thumbnail" 410919 410920 self newImage: aMorph imageForm fixAlpha . 410921 ! ! 410922 410923!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 2/19/2006 14:49'! 410924togglePopupFeature 410925 "Change the popup behaviour. Return the new boolean value." 410926 410927 ^isPopup := isPopup ~~ true . 410928 ! ! 410929 410930!ThumbnailImageMorph methodsFor: 'accessing' stamp: 'wiz 2/19/2006 14:21'! 410931yesNoStringFor: aBool 410932 "Answer the string to be shown in a menu to represent the 410933 yes/no status" 410934 ^ (aBool 410935 ifTrue: ['<yes>'] 410936 ifFalse: ['<no>']) 410937 ! ! 410938 410939 410940!ThumbnailImageMorph methodsFor: 'event handling' stamp: 'wiz 2/19/2006 12:51'! 410941handlesMouseDown: evt 410942 ^isPopup == true! ! 410943 410944!ThumbnailImageMorph methodsFor: 'event handling' stamp: 'wiz 2/19/2006 12:51'! 410945mouseDown: evt 410946 410947 410948 imagePopupMorph center: (self localPointToGlobal: evt position). 410949 imagePopupMorph bounds: (imagePopupMorph bounds translatedAndSquishedToBeWithin: World bounds). 410950 imagePopupMorph openInWorld 410951! ! 410952 410953!ThumbnailImageMorph methodsFor: 'event handling' stamp: 'wiz 2/19/2006 12:50'! 410954mouseUp: evt 410955 imagePopupMorph ifNotNil: [ 410956 imagePopupMorph delete . 410957 ]! ! 410958 410959 410960!ThumbnailImageMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:13'! 410961initialize 410962 super initialize. 410963 desiredExtent := 90 asPoint. 410964 self newImage: DefaultForm! ! 410965 410966!ThumbnailImageMorph methodsFor: 'initialization' stamp: 'wiz 9/21/2005 22:26'! 410967initializeWithDisplay 410968super initialize . 410969desiredExtent := 90 asPoint. 410970self newImage: Display! ! 410971 410972 410973!ThumbnailImageMorph methodsFor: 'menu commands' stamp: 'wiz 2/19/2006 14:38'! 410974addCustomMenuItems: aCustomMenu hand: aHandMorph 410975 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 410976 self addWorldTargetSightingItems: aCustomMenu hand: aHandMorph . 410977 self addPopupMenuItems: aCustomMenu hand: aHandMorph! ! 410978 410979!ThumbnailImageMorph methodsFor: 'menu commands' stamp: 'wiz 2/19/2006 14:41'! 410980addPopupMenuItems: aCustomMenu hand: aHandMorph 410981" Show and toggle the popUp boolean menu item." 410982 410983 aCustomMenu addLine. 410984 410985 aCustomMenu addUpdating: #popupFeatureString target: self 410986 selector: #togglePopupFeature argumentList: #() . 410987 410988 ! ! 410989 410990"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 410991 410992ThumbnailImageMorph class 410993 instanceVariableNames: ''! 410994 410995!ThumbnailImageMorph class methodsFor: 'examples' stamp: 'wiz 9/21/2005 22:31'! 410996ofDisplay 410997"ThumbnailImageMorph ofDisplay openInHand" 410998^self new initializeWithDisplay .! ! 410999RectangleMorph subclass: #ThumbnailMorph 411000 instanceVariableNames: 'objectToView viewSelector lastSketchForm lastFormShown drawTime' 411001 classVariableNames: 'EccentricityThreshhold RecursionDepth RecursionMax' 411002 poolDictionaries: '' 411003 category: 'Morphic-Basic'! 411004!ThumbnailMorph commentStamp: 'sw 1/6/2005 03:47' prior: 0! 411005A Morph that views another morph, its objectToView.! 411006 411007 411008!ThumbnailMorph methodsFor: 'accessing' stamp: 'sw 1/6/2005 01:46'! 411009getSelector 411010 "Answer the selector I send to my target to retrieve my value" 411011 411012 ^ viewSelector! ! 411013 411014!ThumbnailMorph methodsFor: 'accessing' stamp: 'sw 1/6/2005 17:03'! 411015getSelector: aSelector 411016 "Set the selector used to obtain my value" 411017 411018 self objectToView: objectToView viewSelector: aSelector! ! 411019 411020!ThumbnailMorph methodsFor: 'accessing' stamp: 'sw 1/6/2005 17:06'! 411021putSelector 411022 "Answer the selector used for the receiver to send a fresh value back to its target" 411023 411024 ^ nil! ! 411025 411026!ThumbnailMorph methodsFor: 'accessing' stamp: 'sw 1/6/2005 01:39'! 411027target 411028 "Answer the object on which I act" 411029 411030 ^ objectToView! ! 411031 411032 411033!ThumbnailMorph methodsFor: 'caching' stamp: 'ar 3/3/2001 19:37'! 411034releaseCachedState 411035 super releaseCachedState. 411036 lastSketchForm := lastFormShown := nil.! ! 411037 411038 411039!ThumbnailMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 14:57'! 411040veryDeepFixupWith: deepCopier 411041 "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 411042 411043super veryDeepFixupWith: deepCopier. 411044objectToView := deepCopier references at: objectToView ifAbsent: [objectToView].! ! 411045 411046!ThumbnailMorph methodsFor: 'copying' stamp: 'ar 10/26/2000 23:55'! 411047veryDeepInner: deepCopier 411048 "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." 411049 411050super veryDeepInner: deepCopier. 411051"objectToView := objectToView. Weakly copied" 411052viewSelector := viewSelector veryDeepCopyWith: deepCopier. 411053lastSketchForm := lastSketchForm veryDeepCopyWith: deepCopier. 411054lastFormShown := lastFormShown veryDeepCopyWith: deepCopier. 411055drawTime := drawTime veryDeepCopyWith: deepCopier. 411056! ! 411057 411058 411059!ThumbnailMorph methodsFor: 'display' stamp: 'wiz 8/6/2005 22:01'! 411060drawForForm: aForm on: aCanvas 411061 "Draw a small view of the given form on the canvas" 411062 411063 | scale shrunkForm viewedObjectBox interimCanvas | 411064 viewedObjectBox := aForm boundingBox. 411065 scale := self scaleFor: viewedObjectBox in: self innerBounds. 411066 interimCanvas := Display defaultCanvasClass extent: viewedObjectBox extent depth: aCanvas depth. 411067 interimCanvas translateBy: viewedObjectBox topLeft negated 411068 during: [:tempCanvas | tempCanvas drawImage: aForm at: 0@0]. 411069 shrunkForm := interimCanvas form magnify: interimCanvas form boundingBox by: scale smoothing: 1. 411070 lastFormShown := shrunkForm. 411071 411072 aCanvas paintImage: shrunkForm at: self center - shrunkForm boundingBox center! ! 411073 411074!ThumbnailMorph methodsFor: 'display' stamp: 'wiz 8/6/2005 22:11'! 411075drawMeOn: aCanvas 411076 "Draw a small view of a morph in another place. Guard against infinite recursion if that morph has a thumbnail of itself inside. Now also works if the thing to draw is a plain Form rather than a morph." 411077 411078 | viewedMorphBox scale c shrunkForm aWorld aFormOrMorph | 411079 super drawOn: aCanvas. 411080 ((aFormOrMorph := self formOrMorphToView) isForm) 411081 ifTrue: [^self drawForForm: aFormOrMorph on: aCanvas]. 411082 (((aFormOrMorph notNil and: [(aWorld := aFormOrMorph world) notNil]) 411083 and: [aWorld ~~ aFormOrMorph or: [lastFormShown isNil]]) 411084 and: [RecursionDepth + 1 < RecursionMax]) 411085 ifTrue: 411086 [RecursionDepth := RecursionDepth + 1. 411087 viewedMorphBox := aFormOrMorph fullBounds. 411088 scale := self scaleFor: viewedMorphBox in: self innerBounds. 411089 c := Display defaultCanvasClass extent: viewedMorphBox extent 411090 depth: aCanvas depth. 411091 c translateBy: viewedMorphBox topLeft negated 411092 during: 411093 [:tempCanvas | 411094 "recursion happens here" 411095 tempCanvas fullDrawMorph: aFormOrMorph]. 411096 shrunkForm := c form 411097 magnify: c form boundingBox 411098 by: scale 411099 smoothing: 1. 411100 lastFormShown := shrunkForm. 411101 RecursionDepth := RecursionDepth - 1] 411102 ifFalse: 411103 ["This branch used if we've recurred, or if the thumbnail views a World that's already been rendered once, or if the referent is not in a world at the moment" 411104 lastFormShown ifNotNil: [shrunkForm := lastFormShown]]. 411105 shrunkForm ifNotNil: 411106 [aCanvas paintImage: shrunkForm 411107 at: self center - shrunkForm boundingBox center]! ! 411108 411109!ThumbnailMorph methodsFor: 'display' stamp: 'wiz 8/6/2005 21:58'! 411110scaleFor: viewedMorphBox in: myBox 411111 "Compute the proper scale for the thumbnail." 411112 411113 | scale scaleX scaleY ratio factor | 411114scaleX := myBox width asFloat / viewedMorphBox width. 411115 scaleY := myBox height asFloat / viewedMorphBox height. 411116 ratio := scaleX / scaleY. 411117 factor := 1.0 / EccentricityThreshhold. 411118 ratio < factor 411119 ifTrue: 411120 [scale := (scaleX) @ (factor * scaleY)] 411121 ifFalse: 411122 [ratio > EccentricityThreshhold 411123 ifTrue: 411124 [scale := (factor * scaleX) @ scaleY] 411125 ifFalse: 411126 [scale := scaleX min: scaleY]]. 411127^ scale 411128! ! 411129 411130 411131!ThumbnailMorph methodsFor: 'drawing' stamp: 'ar 10/26/2000 23:45'! 411132drawOn: aCanvas 411133 "Draw a small view of a morph in another place. Guard against infinite recursion if that morph has a thumbnail of itself inside." 411134 | time | 411135 time := Time millisecondClockValue. 411136 self drawMeOn: aCanvas. 411137 drawTime := Time millisecondClockValue - time. 411138 drawTime < 0 ifTrue:[drawTime := nil]. 411139! ! 411140 411141 411142!ThumbnailMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:57'! 411143defaultBorderWidth 411144"answer the default border width for the receiver" 411145 ^ 1! ! 411146 411147!ThumbnailMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:56'! 411148defaultColor 411149"answer the default color/fill style for the receiver" 411150 ^ Color 411151 r: 0.781 411152 g: 0.781 411153 b: 0.781! ! 411154 411155!ThumbnailMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:57'! 411156initialize 411157 "Initialize the receiver, obeying a #nominalExtent property if I 411158 have one" 411159 | anExtent | 411160 super initialize. 411161 "" 411162 anExtent := self 411163 valueOfProperty: #nominalExtent 411164 ifAbsent: [25 @ 25]. 411165 self 411166 extent: (anExtent 411167 )! ! 411168 411169!ThumbnailMorph methodsFor: 'initialization' stamp: 'sw 6/9/2000 18:35'! 411170objectToView: objectOrNil 411171 (objectOrNil isMorph and: [objectOrNil allMorphs includes: self]) ifTrue: 411172 ["cannot view a morph containing myself or drawOn: goes into infinite recursion" 411173 objectToView := nil. 411174 ^ self]. 411175 objectToView := objectOrNil! ! 411176 411177!ThumbnailMorph methodsFor: 'initialization' stamp: 'sw 6/9/2000 18:35'! 411178objectToView: objectOrNil viewSelector: aSelector 411179 self objectToView: objectOrNil. 411180 viewSelector := aSelector! ! 411181 411182 411183!ThumbnailMorph methodsFor: 'stepping and presenter' stamp: 'nk 6/14/2004 16:47'! 411184step 411185 "Optimization: Don't redraw if we're viewing some kind of SketchMorph and its rotated Form hasn't changed." 411186 411187 | viewee f | 411188 viewee := self actualViewee. 411189 viewee ifNil: [ self stopStepping. ^self ]. 411190 (viewee isSketchMorph) ifTrue: [ 411191 f := viewee rotatedForm. 411192 f == lastSketchForm ifTrue: [^ self]. 411193 lastSketchForm := f]. 411194 self changed. 411195! ! 411196 411197!ThumbnailMorph methodsFor: 'stepping and presenter' stamp: 'marcus.denker 2/23/2009 11:20'! 411198stepTime 411199 "Adjust my step time to the time it takes drawing my referent" 411200 drawTime ifNil:[^ 250]. 411201 ^(20 * drawTime) max: 250.! ! 411202 411203 411204!ThumbnailMorph methodsFor: 'what to view' stamp: 'stephane.ducasse 10/28/2008 18:29'! 411205actualViewee 411206 "Return the actual morph to be viewed, or nil if there isn't an appropriate morph to view." 411207 411208 | aMorph actualViewee | 411209 aMorph := self morphToView ifNil: [^ nil]. 411210 aMorph isInWorld ifFalse: [^ nil]. 411211 actualViewee := viewSelector ifNil: [aMorph] ifNotNil: [objectToView perform: viewSelector]. 411212 actualViewee == 0 ifTrue: [^ nil]. 411213 actualViewee ifNil: [actualViewee := objectToView]. 411214 (actualViewee isMorph and: 411215 [actualViewee isFlexMorph and: [actualViewee submorphs size = 1]]) 411216 ifTrue: [actualViewee := actualViewee firstSubmorph]. 411217 ^ actualViewee! ! 411218 411219!ThumbnailMorph methodsFor: 'what to view' stamp: 'stephane.ducasse 10/28/2008 18:29'! 411220formOrMorphToView 411221 "Answer the form to be viewed, or the morph to be viewed, or nil" 411222 411223 | actualViewee | 411224 (objectToView isForm) ifTrue: [^objectToView]. 411225 actualViewee := viewSelector ifNil: [objectToView] 411226 ifNotNil: [objectToView perform: viewSelector]. 411227 ^actualViewee == 0 411228 ifTrue: [nil] 411229 ifFalse: [actualViewee]! ! 411230 411231!ThumbnailMorph methodsFor: 'what to view' stamp: 'stephane.ducasse 10/28/2008 18:28'! 411232morphToView 411233 "If the receiver is viewing some object, answer a morph can be thought of as being viewed; A gesture is made toward generalizing this beyond the morph/player regime, in that a plain blue rectangle is returned rather than simply failing if the referent is not itself displayable." 411234 411235 objectToView ifNil: [^ nil]. 411236 ^ objectToView isMorph 411237 ifTrue: 411238 [objectToView] 411239 ifFalse: 411240 [RectangleMorph new color: Color blue] 411241! ! 411242 411243"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 411244 411245ThumbnailMorph class 411246 instanceVariableNames: ''! 411247 411248!ThumbnailMorph class methodsFor: 'as yet unclassified' stamp: 'sw 5/3/1998 19:12'! 411249recursionReset 411250 "ThumbnailMorph recursionReset" 411251 "Reset the RecursionDepth counter in case the user interrupted 411252during a thumbnail being drawn. Do this just once in a while when no 411253drawOn: is being called. tk 9/8/97" 411254 411255 RecursionDepth := 0.! ! 411256 411257 411258!ThumbnailMorph class methodsFor: 'example' stamp: 'stephane.ducasse 12/23/2008 22:37'! 411259example1 411260 "Create a thumbnail representing another Morph. The thumbnail is continously updated." 411261 "self example1" 411262 | t r | 411263 r := RectangleMorph new. 411264 r position: 100@200. 411265 t := ThumbnailMorph new objectToView: r viewSelector: #openInWorld. 411266 t openInWorld! ! 411267 411268 411269!ThumbnailMorph class methodsFor: 'initialization' stamp: 'sw 12/30/2004 00:47'! 411270initialize 411271 "Initialize the class variables of ThumbnailMorph" 411272 411273 RecursionMax := 2. 411274 RecursionDepth := 0. 411275 EccentricityThreshhold := Float pi 411276 411277"ThumbnailMorph initialize"! ! 411278Magnitude subclass: #Time 411279 instanceVariableNames: 'seconds nanos' 411280 classVariableNames: '' 411281 poolDictionaries: 'ChronologyConstants' 411282 category: 'Kernel-Chronology'! 411283!Time commentStamp: 'dew 10/23/2004 17:58' prior: 0! 411284This represents a particular point in time during any given day. For example, '5:19:45 pm'. 411285 411286If you need a point in time on a particular day, use DateAndTime. If you need a duration of time, use Duration. 411287! 411288 411289 411290!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 15:54'! 411291< aTime 411292 411293 ^ self asDuration < aTime asDuration! ! 411294 411295!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:11'! 411296= aTime 411297 411298 ^ [ self ticks = aTime ticks ] 411299 on: MessageNotUnderstood do: [false]! ! 411300 411301!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:32'! 411302duration 411303 411304 ^ Duration zero ! ! 411305 411306!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:11'! 411307hash 411308 411309 ^ self ticks hash ! ! 411310 411311!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:10'! 411312hour 411313 411314 ^ self hour24 ! ! 411315 411316!Time methodsFor: 'ansi protocol' stamp: 'avi 2/21/2004 18:45'! 411317hour12 411318 "Answer an <integer> between 1 and 12, inclusive, representing the hour 411319 of the day in the 12-hour clock of the local time of the receiver." 411320 ^ self hour24 - 1 \\ 12 + 1! ! 411321 411322!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:17'! 411323hour24 411324 411325 ^ self asDuration hours ! ! 411326 411327!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:41'! 411328meridianAbbreviation 411329 411330 ^ self hour < 12 ifTrue: ['AM'] ifFalse: ['PM']. ! ! 411331 411332!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 22:08'! 411333minute 411334 411335 ^ self asDuration minutes! ! 411336 411337!Time methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 19:19'! 411338second 411339 411340 ^ self asDuration seconds! ! 411341 411342 411343!Time methodsFor: 'printing' stamp: 'BP 3/30/2001 15:25'! 411344hhmm24 411345 "Return a string of the form 1123 (for 11:23 am), 2154 (for 9:54 pm), of exactly 4 digits" 411346 411347 ^(String streamContents: 411348 [ :aStream | self print24: true showSeconds: false on: aStream ]) 411349 copyWithout: $:! ! 411350 411351!Time methodsFor: 'printing' stamp: 'BP 3/30/2001 15:25'! 411352print24 411353 "Return as 8-digit string 'hh:mm:ss', with leading zeros if needed" 411354 411355 ^String streamContents: 411356 [ :aStream | self print24: true on: aStream ] 411357 411358 ! ! 411359 411360!Time methodsFor: 'printing' stamp: 'BP 3/30/2001 15:25'! 411361print24: hr24 on: aStream 411362 "Format is 'hh:mm:ss' or 'h:mm:ss am' " 411363 411364 self print24: hr24 showSeconds: true on: aStream 411365 ! ! 411366 411367!Time methodsFor: 'printing' stamp: 'dtl 6/25/2009 19:24'! 411368print24: hr24 showSeconds: showSeconds on: aStream 411369 "Format is 'hh:mm:ss' or 'h:mm:ss am' or, if showSeconds is false, 'hh:mm' or 'h:mm am'" 411370 411371 | h m s | 411372 h := self hour. m := self minute. s := self second. 411373 hr24 411374 ifTrue: 411375 [ h < 10 ifTrue: [ aStream nextPutAll: '0' ]. 411376 h printOn: aStream ] 411377 ifFalse: 411378 [ h > 12 411379 ifTrue: [h - 12 printOn: aStream] 411380 ifFalse: 411381 [h < 1 411382 ifTrue: [ 12 printOn: aStream ] 411383 ifFalse: [ h printOn: aStream ]]]. 411384 411385 aStream nextPutAll: (m < 10 ifTrue: [':0'] ifFalse: [':']). 411386 m printOn: aStream. 411387 411388 showSeconds ifTrue: 411389 [ aStream nextPutAll: (s < 10 ifTrue: [':0'] ifFalse: [':']). 411390 self nanoSecond == 0 411391 ifTrue: [s asInteger printOn: aStream] 411392 ifFalse: [(s + (self nanoSecond / NanosInSecond) asFloat) printOn: aStream]]. 411393 411394 hr24 ifFalse: 411395 [ aStream nextPutAll: (h < 12 ifTrue: [' am'] ifFalse: [' pm']) ]. 411396! ! 411397 411398!Time methodsFor: 'printing' stamp: 'BP 3/30/2001 15:25'! 411399printMinutes 411400 "Return as string 'hh:mm pm' " 411401 411402 ^String streamContents: 411403 [ :aStream | self print24: false showSeconds: false on: aStream ] 411404 ! ! 411405 411406!Time methodsFor: 'printing' stamp: 'dtl 6/25/2009 19:13'! 411407printOn: aStream 411408 411409 self print24: false 411410 showSeconds: (self seconds ~= 0 411411 or: [self nanoSecond ~= 0]) 411412 on: aStream! ! 411413 411414!Time methodsFor: 'printing' stamp: 'BP 3/30/2001 15:25'! 411415storeOn: aStream 411416 411417 aStream print: self printString; nextPutAll: ' asTime'! ! 411418 411419 411420!Time methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 19:02'! 411421addSeconds: nSeconds 411422 "Answer a Time that is nSeconds after the receiver." 411423 411424 ^ self class seconds: self asSeconds + nSeconds! ! 411425 411426!Time methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 19:02'! 411427addTime: timeAmount 411428 "Answer a Time that is timeInterval after the receiver. timeInterval is an 411429 instance of Date or Time." 411430 411431 ^ self class seconds: self asSeconds + timeAmount asSeconds! ! 411432 411433!Time methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 15:55'! 411434asSeconds 411435 "Answer the number of seconds since midnight of the receiver." 411436 411437 ^ seconds! ! 411438 411439!Time methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:29'! 411440hours 411441 411442 ^ self hour! ! 411443 411444!Time methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 19:24'! 411445intervalString 411446 "Treat the time as a difference. Give it in hours and minutes with two digits of accuracy." 411447 411448 | d | 411449 d := self asDuration. 411450 ^ String streamContents: [ :s | 411451 d hours > 0 ifTrue: [s print: d hours; nextPutAll: ' hours']. 411452 d minutes > 0 ifTrue: [s space; print: d minutes; nextPutAll: ' minutes']. 411453 d seconds > 0 ifTrue: [s space; print: d seconds; nextPutAll: ' seconds'] ]. 411454 411455! ! 411456 411457!Time methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:07'! 411458minutes 411459 411460 ^ self asDuration minutes! ! 411461 411462!Time methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 18:18'! 411463seconds 411464 411465 ^ self second! ! 411466 411467!Time methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 19:03'! 411468subtractTime: timeAmount 411469 "Answer a Time that is timeInterval before the receiver. timeInterval is 411470 an instance of Date or Time." 411471 411472 ^ self class seconds: self asSeconds - timeAmount asSeconds! ! 411473 411474 411475!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 23:58'! 411476asDate 411477 411478 ^ Date today! ! 411479 411480!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:26'! 411481asDateAndTime 411482 411483 ^ DateAndTime today + self! ! 411484 411485!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:01'! 411486asDuration 411487 "Answer the duration since midnight" 411488 411489 ^ Duration seconds: seconds nanoSeconds: nanos ! ! 411490 411491!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:29'! 411492asMonth 411493 411494 ^ self asDateAndTime asMonth! ! 411495 411496!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:29'! 411497asNanoSeconds 411498 "Answer the number of nanoseconds since midnight" 411499 411500 ^ self asDuration asNanoSeconds ! ! 411501 411502!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:08'! 411503asTime 411504 411505 ^ self! ! 411506 411507!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:27'! 411508asTimeStamp 411509 411510 ^ self asDateAndTime asTimeStamp! ! 411511 411512!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:28'! 411513asWeek 411514 411515 ^ self asDateAndTime asWeek! ! 411516 411517!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:43'! 411518asYear 411519 411520 ^ self asDateAndTime asYear! ! 411521 411522!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:33'! 411523nanoSecond 411524 411525 ^ nanos ! ! 411526 411527!Time methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:35'! 411528to: anEnd 411529 "Answer a Timespan. anEnd must respond to #asDateAndTime" 411530 411531 ^ self asDateAndTime to: anEnd! ! 411532 411533 411534!Time methodsFor: 'private' stamp: 'adrian_lienhard 1/7/2009 18:18'! 411535seconds: secondCount 411536 "Private - only used by Time class." 411537 411538 seconds := secondCount. 411539 nanos := 0! ! 411540 411541!Time methodsFor: 'private' stamp: 'adrian_lienhard 1/7/2009 18:19'! 411542seconds: secondCount nanoSeconds: nanoCount 411543 "Private - only used by Time class." 411544 411545 seconds := secondCount. 411546 nanos := nanoCount! ! 411547 411548!Time methodsFor: 'private' stamp: 'brp 8/23/2003 22:38'! 411549ticks 411550 "Answer an Array: { seconds. nanoSeconds }" 411551 411552 ^ Array with: 0 with: seconds with: nanos.! ! 411553 411554!Time methodsFor: 'private' stamp: 'adrian_lienhard 1/7/2009 18:20'! 411555ticks: anArray 411556 "ticks is an Array: { days. seconds. nanoSeconds }" 411557 411558 seconds := anArray at: 2. 411559 nanos := anArray at: 3! ! 411560 411561"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 411562 411563Time class 411564 instanceVariableNames: ''! 411565 411566!Time class methodsFor: '*monticello' stamp: 'PeterHugossonMiller 9/2/2009 16:01'! 411567fromString: aString 411568 ^ self readFrom: aString readStream. 411569! ! 411570 411571 411572!Time class methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 18:56'! 411573now 411574 "Answer a Time representing the time right now - this is a 24 hour clock." 411575 411576 ^ self seconds: self totalSeconds \\ 86400. 411577! ! 411578 411579 411580!Time class methodsFor: 'benchmarks' stamp: 'brp 8/24/2003 00:06'! 411581benchmarkMillisecondClock "Time benchmarkMillisecondClock" 411582 "Benchmark the time spent in a call to Time>>millisecondClockValue. 411583 On the VM level this tests the efficiency of calls to ioMSecs()." 411584 "PII/400 Windows 98: 0.725 microseconds per call" 411585 | temp1 temp2 temp3 delayTime nLoops time | 411586 delayTime := 5000. "Time to run benchmark is approx. 2*delayTime" 411587 411588 "Don't run the benchmark if we have an active delay since 411589 we will measure the additional penalty in the primitive dispatch 411590 mechanism (see #benchmarkPrimitiveResponseDelay)." 411591 Delay anyActive ifTrue:[ 411592 ^self notify:'Some delay is currently active. 411593Running this benchmark will not give any useful result.']. 411594 411595 "Flush the cache for this benchmark so we will have 411596 a clear cache hit for each send to #millisecondClockValue below" 411597 Object flushCache. 411598 temp1 := 0. 411599 temp2 := self. "e.g., temp1 == Time" 411600 temp3 := self millisecondClockValue + delayTime. 411601 411602 "Now check how often we can run the following loop in the given time" 411603 [temp2 millisecondClockValue < temp3] 411604 whileTrue:[temp1 := temp1 + 1]. 411605 411606 nLoops := temp1. "Remember the loops we have run during delayTime" 411607 411608 "Setup the second loop" 411609 temp1 := 0. 411610 temp3 := nLoops. 411611 411612 "Now measure how much time we spend without sending #millisecondClockValue" 411613 time := Time millisecondClockValue. 411614 [temp1 < temp3] 411615 whileTrue:[temp1 := temp1 + 1]. 411616 time := Time millisecondClockValue - time. 411617 411618 "And compute the number of microseconds spent per call to #millisecondClockValue" 411619 ^((delayTime - time * 1000.0 / nLoops) truncateTo: 0.001) printString, 411620 ' microseconds per call to Time>>millisecondClockValue'! ! 411621 411622!Time class methodsFor: 'benchmarks' stamp: 'BP 3/30/2001 15:25'! 411623benchmarkPrimitiveResponseDelay "Time benchmarkPrimitiveResponseDelay" 411624 "Benchmark the overhead for primitive dispatches with an active Delay. 411625 On the VM level, this tests the efficiency of ioLowResMSecs." 411626 411627 "PII/400 Windows98: 0.128 microseconds per prim" 411628 411629 "ar 9/6/1999: This value is *extremely* important for stuff like sockets etc. 411630 I had a bad surprise when Michael pointed this particular problem out: 411631 Using the hardcoded clock() call for ioLowResMSecs on Win32 resulted in an overhead 411632 of 157.4 microseconds per primitive call - meaning you can't get no more than 411633 approx. 6000 primitives per second on my 400Mhz PII system with an active delay!! 411634 BTW, it finally explains why Squeak seemed soooo slow when running PWS or 411635 other socket stuff. The new version (not using clock() but some Windows function) 411636 looks a lot better (see above; approx. 8,000,000 prims per sec with an active delay)." 411637 411638 | nLoops bb index baseTime actualTime delayTime | 411639 delayTime := 5000. "Time to run this test is approx. 3*delayTime" 411640 411641 Delay anyActive ifTrue:[ 411642 ^self notify:'Some delay is currently active. 411643Running this benchmark will not give any useful result.']. 411644 411645 bb := Array new: 1. "The object we send the prim message to" 411646 411647 "Compute the # of loops we'll run in a decent amount of time" 411648 [(Delay forMilliseconds: delayTime) wait] 411649 forkAt: Processor userInterruptPriority. 411650 411651 nLoops := 0. 411652 [Delay anyActive] whileTrue:[ 411653 bb basicSize; basicSize; basicSize; basicSize; basicSize; 411654 basicSize; basicSize; basicSize; basicSize; basicSize. 411655 nLoops := nLoops + 1. 411656 ]. 411657 411658 "Flush the cache and make sure #basicSize is in there" 411659 Object flushCache. 411660 bb basicSize. 411661 411662 "Now run the loop without any active delay 411663 for getting an idea about its actual speed." 411664 baseTime := self millisecondClockValue. 411665 index := nLoops. 411666 [index > 0] whileTrue:[ 411667 bb basicSize; basicSize; basicSize; basicSize; basicSize; 411668 basicSize; basicSize; basicSize; basicSize; basicSize. 411669 index := index - 1. 411670 ]. 411671 baseTime := self millisecondClockValue - baseTime. 411672 411673 "Setup the active delay but try to never make it active" 411674 [(Delay forMilliseconds: delayTime + delayTime) wait] 411675 forkAt: Processor userInterruptPriority. 411676 411677 "And run the loop" 411678 actualTime := self millisecondClockValue. 411679 index := nLoops. 411680 [index > 0] whileTrue:[ 411681 bb basicSize; basicSize; basicSize; basicSize; basicSize; 411682 basicSize; basicSize; basicSize; basicSize; basicSize. 411683 index := index - 1. 411684 ]. 411685 actualTime := self millisecondClockValue - actualTime. 411686 411687 "And get us some result" 411688 ^((actualTime - baseTime) * 1000 asFloat / (nLoops * 10) truncateTo: 0.001) printString, 411689 ' microseconds overhead per primitive call'! ! 411690 411691 411692!Time class methodsFor: 'general inquiries' stamp: 'BP 3/30/2001 15:25'! 411693condenseBunches: aCollectionOfSeconds 411694 | secArray pause now out prev bunchEnd ago | 411695 "Identify the major intervals in a bunch of numbers. 411696 Each number is a seconds since 1901 that represents a date and time. 411697 We want the last event in a bunch. Return array of seconds for: 411698 411699 Every event in the last half hour. 411700 Every bunch separated by 30 min in the last 24 hours. 411701 411702 Every bunch separated by two hours before that." 411703 411704 "Time condenseBunches: 411705 (#(20 400 401 20000 20200 20300 40000 45000 200000 201000 202000) 411706 collect: [ :tt | self totalSeconds - tt]) 411707" 411708 411709 secArray := aCollectionOfSeconds asSortedCollection. 411710 pause := 1. 411711 now := self totalSeconds. 411712 out := OrderedCollection new. 411713 prev := 0. 411714 bunchEnd := nil. 411715 secArray reverseDo: [:secs | "descending" 411716 ago := now - secs. 411717 ago > (60*30) ifTrue: [pause := "60*30" 1800]. 411718 ago > (60*60*24) ifTrue: [pause := "60*120" 7200]. 411719 ago - prev >= pause ifTrue: [out add: bunchEnd. bunchEnd := secs]. 411720 prev := ago]. 411721 out add: bunchEnd. 411722 out removeFirst. 411723 ^ out! ! 411724 411725!Time class methodsFor: 'general inquiries' stamp: 'brp 8/23/2003 23:59'! 411726humanWordsForSecondsAgo: secs 411727 | date today | 411728 "Return natural language for this date and time in the past." 411729 411730 secs <= 1 ifTrue: [^ 'a second ago']. 411731 secs < 45 ifTrue: [^ secs printString, ' seconds ago']. 411732 secs < 90 ifTrue: [^ 'a minute ago']. 411733 secs < "45*60" 2700 ifTrue: [^ (secs//60) printString, ' minutes ago']. 411734 secs < "90*60" 5400 ifTrue: [^ 'an hour ago']. 411735 secs < "18*60*60" 64800 ifTrue: [^ (secs//3600) printString, ' hours ago']. 411736 date := Date fromSeconds: self totalSeconds - secs. "now work with dates" 411737 today := Date today. 411738 date > (today subtractDays: 2) ifTrue: [^ 'yesterday']. 411739 date > (today subtractDays: 8) ifTrue: [^ 'last ', date dayOfWeekName]. 411740 date > (today subtractDays: 13) ifTrue: [^ 'a week ago']. 411741 date > (today subtractDays: 28) ifTrue: [ 411742 ^ ((today subtractDate: date)//7) printString, ' weeks ago']. 411743 date > (today subtractDays: 45) ifTrue: [^ 'a month ago']. 411744 date > (today subtractDays: 300) ifTrue: [^ 'last ', date monthName]. 411745 ^ date monthName, ', ', date year printString 411746 411747"Example 411748#(0.5 30 62 130 4000 10000 60000 90000 345600 864000 1728000 3456000 17280000 34560000 345600000) 411749 collect: [:ss | Time humanWordsForSecondsAgo: ss]. 411750"! ! 411751 411752!Time class methodsFor: 'general inquiries' stamp: 'nk 3/8/2004 12:05'! 411753millisecondClockValue 411754 "Answer the number of milliseconds since the millisecond clock was last reset or rolled over. 411755 Answer 0 if the primitive fails." 411756 411757 <primitive: 135> 411758 ^ 0! ! 411759 411760!Time class methodsFor: 'general inquiries' stamp: 'ar 11/25/2004 11:26'! 411761millisecondsToRun: timedBlock 411762 "Answer the number of milliseconds timedBlock takes to return its value." 411763 411764 | initialMilliseconds | 411765 initialMilliseconds := self millisecondClockValue. 411766 timedBlock value. 411767 ^self millisecondsSince: initialMilliseconds! ! 411768 411769!Time class methodsFor: 'general inquiries' stamp: 'BP 3/30/2001 15:25'! 411770namesForTimes: arrayOfSeconds 411771 | simpleEnglish prev final prevPair myPair | 411772 "Return English descriptions of the times in the array. They are each seconds since 1901. If two names are the same, append the date and time to distinguish them." 411773 411774 simpleEnglish := arrayOfSeconds collect: [:secsAgo | 411775 self humanWordsForSecondsAgo: self totalSeconds - secsAgo]. 411776 prev := ''. 411777 final := simpleEnglish copy. 411778 simpleEnglish withIndexDo: [:eng :ind | 411779 eng = prev ifFalse: [eng] 411780 ifTrue: ["both say 'a month ago'" 411781 prevPair := self dateAndTimeFromSeconds: 411782 (arrayOfSeconds at: ind-1). 411783 myPair := self dateAndTimeFromSeconds: 411784 (arrayOfSeconds at: ind). 411785 (final at: ind-1) = prev ifTrue: ["only has 'a month ago'" 411786 final at: ind-1 put: 411787 (final at: ind-1), ', ', prevPair first mmddyyyy]. 411788 final at: ind put: 411789 (final at: ind), ', ', myPair first mmddyyyy. 411790 prevPair first = myPair first 411791 ifTrue: [ 411792 (final at: ind-1) last == $m ifFalse: ["date but no time" 411793 final at: ind-1 put: 411794 (final at: ind-1), ', ', prevPair second printMinutes]. 411795 final at: ind put: 411796 (final at: ind), ', ', myPair second printMinutes]]. 411797 prev := eng]. 411798 ^ final! ! 411799 411800 411801!Time class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 23:59'! 411802dateAndTimeFromSeconds: secondCount 411803 411804 ^ Array 411805 with: (Date fromSeconds: secondCount) 411806 with: (Time fromSeconds: secondCount \\ 86400) 411807 ! ! 411808 411809!Time class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 19:50'! 411810dateAndTimeNow 411811 "Answer a two-element Array of (Date today, Time now)." 411812 411813 ^ self dateAndTimeFromSeconds: self totalSeconds! ! 411814 411815!Time class methodsFor: 'smalltalk-80' stamp: 'dtl 6/25/2009 07:43'! 411816fromSeconds: secondCount 411817 "Answer an instance of me that is secondCount number of seconds since midnight." 411818 411819 | integerSeconds nanos | 411820 integerSeconds := secondCount truncated. 411821 integerSeconds = secondCount 411822 ifTrue: [nanos := 0] 411823 ifFalse: [nanos := (secondCount - integerSeconds * NanosInSecond) asInteger]. 411824 ^ self seconds: integerSeconds nanoSeconds: nanos 411825! ! 411826 411827!Time class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 20:01'! 411828new 411829 "Answer a Time representing midnight" 411830 411831 ^ self midnight! ! 411832 411833!Time class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:01'! 411834primMillisecondClock 411835 "Primitive. Answer the number of milliseconds since the millisecond clock 411836 was last reset or rolled over. Answer zero if the primitive fails. 411837 Optional. See Object documentation whatIsAPrimitive." 411838 411839 <primitive: 135> 411840 ^ 0! ! 411841 411842!Time class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:01'! 411843primSecondsClock 411844 "Answer the number of seconds since 00:00 on the morning of 411845 January 1, 1901 (a 32-bit unsigned number). 411846 Essential. See Object documentation whatIsAPrimitive. " 411847 411848 <primitive: 137> 411849 self primitiveFailed! ! 411850 411851!Time class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 20:07'! 411852readFrom: aStream 411853 "Read a Time from the stream in the form: 411854 <hour>:<minute>:<second> <am/pm> 411855 411856 <minute>, <second> or <am/pm> may be omitted. e.g. 1:59:30 pm; 8AM; 15:30" 411857 411858 | hour minute second ampm | 411859 hour := Integer readFrom: aStream. 411860 minute := 0. 411861 second := 0. 411862 (aStream peekFor: $:) ifTrue: 411863 411864 [ minute := Integer readFrom: aStream. 411865 (aStream peekFor: $:) ifTrue: [ second := Integer readFrom: aStream ]]. 411866 aStream skipSeparators. 411867 (aStream atEnd not and: [aStream peek isLetter]) ifTrue: 411868 [ampm := aStream next asLowercase. 411869 411870 (ampm = $p and: [hour < 12]) ifTrue: [hour := hour + 12]. 411871 (ampm = $a and: [hour = 12]) ifTrue: [hour := 0]. 411872 411873 (aStream peekFor: $m) ifFalse: [aStream peekFor: $M ]]. 411874 411875 ^ self hour: hour minute: minute second: second 411876 411877 "Time readFrom: (ReadStream on: '2:23:09 pm')" 411878! ! 411879 411880!Time class methodsFor: 'smalltalk-80' stamp: 'dtl 10/11/2004 22:15'! 411881totalSeconds 411882 "Answer the total seconds since the Squeak epoch: 1 January 1901." 411883 411884 ^ self primSecondsClock! ! 411885 411886 411887!Time class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 19:46'! 411888current 411889 411890 ^ self now! ! 411891 411892!Time class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:05'! 411893hour: hour minute: minute second: second 411894 "Answer a Time" 411895 411896 ^ self hour: hour minute: minute second: second nanoSecond: 0! ! 411897 411898!Time class methodsFor: 'squeak protocol' stamp: 'brp` 8/24/2003 19:26'! 411899hour: hour minute: minute second: second nanoSecond: nanoCount 411900 "Answer a Time - only second precision for now" 411901 411902 ^ self 411903 seconds: (hour * SecondsInHour) + (minute * SecondsInMinute) + second 411904 nanoSeconds: nanoCount! ! 411905 411906!Time class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:01'! 411907midnight 411908 411909 ^ self seconds: 0 411910! ! 411911 411912!Time class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 18:58'! 411913milliseconds: currentTime since: lastTime 411914 "Answer the elapsed time since last recorded in milliseconds. 411915 Compensate for rollover." 411916 411917 | delta | 411918 delta := currentTime - lastTime. 411919 ^ delta < 0 411920 ifTrue: [SmallInteger maxVal + delta] 411921 ifFalse: [delta] 411922! ! 411923 411924!Time class methodsFor: 'squeak protocol' stamp: 'BP 3/30/2001 15:25'! 411925millisecondsSince: lastTime 411926 "Answer the elapsed time since last recorded in milliseconds. 411927 Compensate for rollover." 411928 411929 ^self milliseconds: self millisecondClockValue since: lastTime! ! 411930 411931!Time class methodsFor: 'squeak protocol' stamp: 'brp` 8/24/2003 19:26'! 411932noon 411933 411934 ^ self seconds: (SecondsInDay / 2) 411935! ! 411936 411937!Time class methodsFor: 'squeak protocol' stamp: 'gk 8/31/2006 00:39'! 411938seconds: seconds 411939 "Answer a Time from midnight." 411940 411941 ^ self basicNew ticks: (Duration seconds: seconds) ticks! ! 411942 411943!Time class methodsFor: 'squeak protocol' stamp: 'adrian_lienhard 1/7/2009 18:19'! 411944seconds: seconds nanoSeconds: nanoCount 411945 "Answer a Time from midnight." 411946 411947 ^ self basicNew 411948 ticks: (Duration seconds: seconds nanoSeconds: nanoCount) ticks! ! 411949TestCase subclass: #TimeMeasuringTest 411950 instanceVariableNames: 'realTime shouldProfile' 411951 classVariableNames: '' 411952 poolDictionaries: '' 411953 category: 'Tests-Traits'! 411954 411955!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'md 2/22/2006 14:27'! 411956debug 411957 self resources do: [:res | 411958 res isAvailable ifFalse: [^res signalInitializationError]]. 411959 [(self class selector: testSelector) setToDebug; runCase] 411960 ensure: [self resources do: [:each | each reset]] 411961 ! ! 411962 411963!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 11:13'! 411964initialize 411965 super initialize. 411966 shouldProfile := false.! ! 411967 411968!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 16:07'! 411969measure: measuredBlock 411970 shouldProfile 411971 ifTrue: [TimeProfileBrowser onBlock: [10 timesRepeat: measuredBlock]]. 411972 realTime := measuredBlock timeToRun! ! 411973 411974!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 15:09'! 411975openDebuggerOnFailingTestMethod 411976 shouldProfile := true! ! 411977 411978!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'pmm 7/4/2009 11:58'! 411979reportPerformance 411980 | str | 411981 str := (MultiByteFileStream fileNamed: 'performanceReports.txt') ascii; wantsLineEndConversion: true; yourself. 411982 str setToEnd; 411983 nextPutAll: ' test: ', testSelector; 411984 nextPutAll: ' time: ', realTime asString; 411985 nextPutAll: ' version: ', self versionInformation; 411986 cr; 411987 close! ! 411988 411989!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 14:58'! 411990runCase 411991 [super runCase] ensure: [self reportPerformance]! ! 411992 411993!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 15:13'! 411994setToDebug 411995 shouldProfile := true 411996! ! 411997 411998!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 14:59'! 411999versionInfoForWorkingCopiesThat: wcPredicate 412000 ^(MCWorkingCopy allManagers select: wcPredicate) inject: '' 412001 into: [:s :e | s , e description]! ! 412002 412003!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 14:48'! 412004versionInformation 412005 | wcPredicate | 412006 wcPredicate := self workingCopyPredicate. 412007 ^self versionInfoForWorkingCopiesThat: wcPredicate! ! 412008 412009!TimeMeasuringTest methodsFor: 'as yet unclassified' stamp: 'dvf 8/31/2005 14:48'! 412010workingCopyPredicate 412011 ^[:e | '*Traits*' match: e package name]! ! 412012MessageSet subclass: #TimeProfileBrowser 412013 instanceVariableNames: 'selectedClass selectedSelector block tally' 412014 classVariableNames: 'TextMenu' 412015 poolDictionaries: '' 412016 category: 'Tools-Debugger'! 412017!TimeProfileBrowser commentStamp: '<historical>' prior: 0! 412018A TimeProfileBrowser is a browser visualizing the runtime profile of an executed Smalltalk block. It is useful for finding performance bottlenecks in code. When optimizing code it can 412019be hard to know what methods actually constitute the bulk of the execution time. Is it a few 412020methods that take very long time to execute or is it perhaps a single method that gets executed a thousand times? 412021 412022The block is first spied on using a MessageTally instance (which has even more funtionality than used by the TimeProfileBrowser) which samples the block during it's execution and collects the amount of time approximately spent in the methods executed. Then the methods are shown in the browser with their relative execution time in percent. 412023 412024Example: 412025TimeProfileBrowser onBlock: [20 timesRepeat: [Transcript show: 100 factorial printString]] 412026! 412027 412028 412029!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'! 412030selectedClass 412031 "Answer the receiver's 'selectedClass'." 412032 412033 ^selectedClass! ! 412034 412035!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'! 412036selectedClass: anObject 412037 "Set the receiver's instance variable 'selectedClass' to be anObject." 412038 412039 selectedClass := anObject! ! 412040 412041!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'! 412042selectedSelector 412043 "Answer the receiver's 'selectedSelector'." 412044 412045 ^selectedSelector! ! 412046 412047!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'! 412048selectedSelector: anObject 412049 "Set the receiver's instance variable 'selectedSelector' to be anObject." 412050 412051 selectedSelector := anObject! ! 412052 412053!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'! 412054tally 412055 "Answer the receiver's 'tally'." 412056 412057 ^tally! ! 412058 412059!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'! 412060tally: anObject 412061 "Set the receiver's instance variable 'tally' to be anObject." 412062 412063 tally := anObject! ! 412064 412065 412066!TimeProfileBrowser methodsFor: 'message list' stamp: 'alain.plantec 5/18/2009 16:01'! 412067selectedMessage 412068 "Answer the source method for the currently selected message." 412069 412070 | source | 412071 self setClassAndSelectorIn: 412072 [:class :selector | 412073 source := class sourceMethodAt: selector ifAbsent: [^'Missing']. 412074 Preferences browseWithPrettyPrint 412075 ifTrue: 412076 [source := class prettyPrinterClass 412077 format: source 412078 in: class 412079 notifying: nil]. 412080 self selectedClass: class. 412081 self selectedSelector: selector. 412082 ^source asText makeSelectorBoldIn: class]. 412083 ^''! ! 412084 412085 412086!TimeProfileBrowser methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! 412087initializeMessageList: anArray 412088 messageList := anArray. 412089 messageListIndex := 0. 412090 contents := ''! ! 412091 412092!TimeProfileBrowser methodsFor: 'private' stamp: 'nk 3/8/2004 13:22'! 412093messageListKey: aChar from: view 412094 "Respond to a Command key. Cmd-D means re-run block." 412095 412096 aChar == $d ifTrue: [^Cursor execute showWhile: [ block value ]]. 412097 ^super messageListKey: aChar from: view! ! 412098 412099!TimeProfileBrowser methodsFor: 'private' stamp: 'stp 05/08/1999 15:27'! 412100messageListMenu: aMenu shifted: shifted 412101 "Add a menu to the inherited one." 412102 412103 | menu | 412104 menu := super messageListMenu: aMenu shifted: shifted. 412105" menu addItem: (0)." 412106 ^menu! ! 412107 412108!TimeProfileBrowser methodsFor: 'private' stamp: 'nk 3/8/2004 12:51'! 412109runBlock: aBlock 412110 ^self runBlock: aBlock pollingEvery: MessageTally defaultPollPeriod! ! 412111 412112!TimeProfileBrowser methodsFor: 'private' stamp: 'jmv 9/24/2009 16:12'! 412113runBlock: aBlock pollingEvery: pollPeriod 412114 | stream list result | 412115 block := MessageSend 412116 receiver: self 412117 selector: #runBlock:pollingEvery: 412118 arguments: { 412119 aBlock. 412120 pollPeriod}. "so we can re-run it" 412121 tally := MessageTally new. 412122 tally 412123 reportOtherProcesses: false; 412124 maxClassNameSize: 1000; 412125 maxClassPlusSelectorSize: 1000; 412126 maxTabs: 100. 412127 result := tally spyEvery: pollPeriod on: aBlock. 412128 stream := ReadWriteStream 412129 with: (String streamContents: 412130 [:s | 412131 tally 412132 report: s; 412133 close]). 412134 stream reset. 412135 list := OrderedCollection new. 412136 [stream atEnd] whileFalse: [list add: stream nextLine]. 412137 self initializeMessageList: list. 412138 self changed: #messageList. 412139 self changed: #messageListIndex. 412140 ^result! ! 412141 412142!TimeProfileBrowser methodsFor: 'private' stamp: 'jmv 9/24/2009 16:13'! 412143runProcess: aProcess forMilliseconds: msecDuration pollingEvery: pollPeriod 412144 | stream list result | 412145 block := MessageSend 412146 receiver: self 412147 selector: #runProcess:forMilliseconds:pollingEvery: 412148 arguments: { 412149 aProcess. 412150 msecDuration. 412151 pollPeriod}. "so we can re-run it" 412152 tally := MessageTally new. 412153 tally 412154 reportOtherProcesses: false; 412155 maxClassNameSize: 1000; 412156 maxClassPlusSelectorSize: 1000; 412157 maxTabs: 100. 412158 result := tally 412159 spyEvery: pollPeriod 412160 onProcess: aProcess 412161 forMilliseconds: msecDuration. 412162 stream := ReadWriteStream 412163 with: (String streamContents: 412164 [:s | 412165 tally 412166 report: s; 412167 close]). 412168 stream reset. 412169 list := OrderedCollection new. 412170 [stream atEnd] whileFalse: [list add: stream nextLine]. 412171 self initializeMessageList: list. 412172 self changed: #messageList. 412173 self changed: #messageListIndex. 412174 ^result! ! 412175 412176!TimeProfileBrowser methodsFor: 'private' stamp: 'damiencassou 5/30/2008 16:29'! 412177setClassAndSelectorIn: csBlock 412178 "Decode strings of the form <selectorName> (<className> [class]) " 412179 | string strm class sel parens | 412180 self flag: #mref. "fix for faster references to methods" 412181 412182 [ string := self selection asString. 412183 string first == $* ifTrue: [ ^ contents := nil ]. "Ignore lines starting with *" 412184 parens := string includes: $(. "Does it have open-paren?" 412185 strm := string readStream. 412186 parens 412187 ifTrue: 412188 [ strm skipTo: $(. "easy case" 412189 class := strm upTo: $). 412190 strm next: 2. 412191 sel := strm upToEnd ] 412192 ifFalse: 412193 [ strm position: (string findString: ' class>>'). 412194 strm position > 0 412195 ifFalse: [ strm position: (string findLast: [ :ch | ch == $ ]) ] 412196 ifTrue: 412197 [ "find the next to last space character" 412198 | subString | 412199 subString := strm contents 412200 copyFrom: 1 412201 to: (string findLast: [ :ch | ch == $ ]) - 1. 412202 strm position: (subString findLast: [ :ch | ch == $ ]) ]. 412203 "ifFalse: [strm position: (string findLast: [ :ch | ch == $ ])." 412204 class := strm upTo: $>. 412205 strm next. 412206 sel := strm upToEnd ]. 412207 ^ MessageSet 412208 parse: class , ' ' , sel 412209 toClassAndSelector: csBlock ] 412210 on: Error 412211 do: [ :ex | ^ contents := nil ]! ! 412212 412213"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 412214 412215TimeProfileBrowser class 412216 instanceVariableNames: ''! 412217 412218!TimeProfileBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 412219onBlock: block 412220 "Open a profile browser on the given block, thereby running the block and 412221 collecting the message tally." 412222 "TimeProfileBrowser onBlock: [20 timesRepeat: 412223 [Transcript show: 100 factorial printString]]" 412224 412225 | inst result | 412226 inst := self new. 412227 result := inst runBlock: block. 412228 self open: inst name: 'Time Profile'. 412229 ^ result! ! 412230 412231!TimeProfileBrowser class methodsFor: 'instance creation' stamp: 'nk 3/8/2004 12:46'! 412232spyOn: block 412233 "Open a profile browser on the given block, thereby running the block and 412234 collecting the message tally." 412235 "TimeProfileBrowser spyOn: [20 timesRepeat: 412236 [Transcript show: 100 factorial printString]]" 412237 412238 ^self onBlock: block! ! 412239 412240!TimeProfileBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 412241spyOnProcess: aProcess forMilliseconds: msecDuration 412242 "Run aProcess for msecDuration milliseconds, then open a TimeProfileBrowser on the results." 412243 412244 "| p | 412245 p := [100000 timesRepeat: [3.14159 printString]] fork. 412246 (Delay forMilliseconds: 100) wait. 412247 TimeProfileBrowser spyOnProcess: p forMilliseconds: 1000" 412248 412249 | inst | 412250 inst := self new. 412251 inst runProcess: aProcess forMilliseconds: msecDuration pollingEvery: MessageTally defaultPollPeriod. 412252 self open: inst name: (String streamContents: [ :s | s nextPutAll: 'Time Profile for '; print: msecDuration; nextPutAll: ' msec' ]). 412253 ^ inst! ! 412254DateAndTime subclass: #TimeStamp 412255 instanceVariableNames: '' 412256 classVariableNames: '' 412257 poolDictionaries: '' 412258 category: 'Kernel-Chronology'! 412259!TimeStamp commentStamp: '<historical>' prior: 0! 412260This represents a duration of 0 length that marks a particular point in time.! 412261 412262 412263!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:13'! 412264asTimeStamp 412265 "Answer the receiver as an instance of TimeStamp." 412266 412267 ^ self! ! 412268 412269!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:14'! 412270date 412271 "Answer the date of the receiver." 412272 412273 ^ self asDate! ! 412274 412275!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:17'! 412276dateAndTime 412277 "Answer a two element Array containing the receiver's date and time." 412278 412279 ^ Array with: self date with: self time! ! 412280 412281!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:19'! 412282minusDays: anInteger 412283 "Answer a TimeStamp which is anInteger days before the receiver." 412284 412285 ^ self - (anInteger days)! ! 412286 412287!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:19'! 412288minusSeconds: anInteger 412289 "Answer a TimeStamp which is anInteger number of seconds before the receiver." 412290 412291 ^ self - (anInteger seconds)! ! 412292 412293!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:18'! 412294plusDays: anInteger 412295 "Answer a TimeStamp which is anInteger days after the receiver." 412296 412297 ^ self + (anInteger days)! ! 412298 412299!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:19'! 412300plusSeconds: anInteger 412301 "Answer a TimeStamp which is anInteger number of seconds after the receiver." 412302 412303 ^ self + (anInteger seconds)! ! 412304 412305!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:17'! 412306printOn: aStream 412307 "Print receiver's date and time on aStream." 412308 412309 aStream 412310 nextPutAll: self date printString; 412311 space; 412312 nextPutAll: self time printString.! ! 412313 412314!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:17'! 412315storeOn: aStream 412316 412317 aStream 412318 print: self printString; 412319 nextPutAll: ' asTimeStamp'! ! 412320 412321!TimeStamp methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:15'! 412322time 412323 "Answer the time of the receiver." 412324 412325 ^ self asTime! ! 412326 412327"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 412328 412329TimeStamp class 412330 instanceVariableNames: ''! 412331 412332!TimeStamp class methodsFor: '*monticello-instance creation' stamp: 'PeterHugossonMiller 9/2/2009 16:03'! 412333fromMethodTimeStamp: aString 412334 | stream | 412335 (stream := aString readStream) 412336 skipSeparators; 412337 skipTo: Character space. 412338 ^self readFrom: stream.! ! 412339 412340!TimeStamp class methodsFor: '*monticello-instance creation' stamp: 'PeterHugossonMiller 9/2/2009 16:03'! 412341fromString: aString 412342 "Answer a new instance for the value given by aString. 412343 412344 TimeStamp fromString: '1-10-2000 11:55:00 am'. 412345 " 412346 412347 ^self readFrom: aString readStream.! ! 412348 412349!TimeStamp class methodsFor: '*monticello-instance creation' stamp: 'stephaneducasse 2/4/2006 20:47'! 412350readFrom: stream 412351 | date time | 412352 stream skipSeparators. 412353 date := Date readFrom: stream. 412354 stream skipSeparators. 412355 time := Time readFrom: stream. 412356 ^self 412357 date: date 412358 time: time! ! 412359 412360 412361!TimeStamp class methodsFor: 'ansi protocol' stamp: 'fbs 4/20/2004 14:22'! 412362now 412363 "Answer the current date and time as a TimeStamp." 412364 412365 ^self current! ! 412366 412367 412368!TimeStamp class methodsFor: 'squeak protocol' stamp: 'fbs 4/20/2004 14:21'! 412369current 412370 412371 | ts ticks | 412372 ts := super now. 412373 412374 ticks := ts ticks. 412375 ticks at: 3 put: 0. 412376 ts ticks: ticks offset: ts offset. 412377 412378 ^ ts 412379 412380! ! 412381ClassTestCase subclass: #TimeStampTest 412382 instanceVariableNames: 'timestamp aTimeStamp' 412383 classVariableNames: '' 412384 poolDictionaries: '' 412385 category: 'KernelTests-Chronology'! 412386!TimeStampTest commentStamp: 'brp 7/26/2003 22:44' prior: 0! 412387This is the unit test for the class TimeStamp.! 412388 412389 412390!TimeStampTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 13:50'! 412391classToBeTested 412392 412393 ^ self timestampClass! ! 412394 412395!TimeStampTest methodsFor: 'Coverage' stamp: 'brp 1/30/2005 09:13'! 412396selectorsToBeIgnored 412397 412398 | deprecated private special | 412399 412400 deprecated := #(). 412401 private := #( #printOn: ). 412402 special := #(). 412403 412404 ^ super selectorsToBeIgnored, deprecated, private, special.! ! 412405 412406 412407!TimeStampTest methodsFor: 'Running' stamp: 'brp 1/21/2004 18:41'! 412408setUp 412409 412410 timestamp := self timestampClass date: ('1-10-2000' asDate) time: ('11:55:00 am' asTime). 412411 412412 aTimeStamp := TimeStamp readFrom: '1-02-2004 12:34:56 am' readStream! ! 412413 412414!TimeStampTest methodsFor: 'Running' stamp: 'brp 7/26/2003 21:53'! 412415tearDown 412416 412417 timestamp := nil.! ! 412418 412419 412420!TimeStampTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 21:56'! 412421testAccessing 412422 412423 | d t | 412424 d := '1-10-2000' asDate. 412425 t := '11:55:00 am' asTime. 412426 412427 self 412428 assert: timestamp date = d; 412429 assert: timestamp time = t. 412430! ! 412431 412432!TimeStampTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:05'! 412433testArithmetic 412434 412435 | ts | 412436 ts := timestamp minusDays: 123. "9 September 1999, 11:55 am" 412437 ts := ts minusSeconds: 1056. "9 September 1999, 11:37:24 am" 412438 ts := ts plusDays: 123. "10 January 2000, 11:37:24 am" 412439 ts := ts plusSeconds: 1056. "10 January 2000, 11:55 am" 412440 self 412441 assert: ts = timestamp. 412442 412443 ! ! 412444 412445!TimeStampTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 06:34'! 412446testArithmeticAcrossDateBoundary 412447 412448 | ts | 412449 ts := timestamp minusSeconds: ((11*3600) + (55*60) + 1). 412450 self 412451 assert: ts = ('1-9-2000 11:59:59 pm' asTimeStamp). 412452 412453 ! ! 412454 412455!TimeStampTest methodsFor: 'Tests' stamp: 'brp 3/12/2004 15:54'! 412456testComparing 412457 412458 | ts1 ts2 ts3 c1 c2 le | 412459 ts1 := self timestampClass date: ('01-10-2000' asDate) time: ('11:55:00 am' asTime). 412460 ts2 := self timestampClass date: ('07-26-2003' asDate) time: ('22:09:45 am' asTime). 412461 ts3 := self timestampClass date: ('05-28-1972' asDate) time: ('04:31:14 pm' asTime). 412462 412463 self 412464 assert: ts1 = timestamp; 412465 assert: ts1 hash = timestamp hash; 412466 assert: timestamp = timestamp copy; 412467 assert: ts1 < ts2; 412468 deny: ts1 < ts3. 412469 412470 c1 := self timestampClass current. 412471 c2 := self timestampClass current. 412472 le := (c1 <= c2). 412473 self assert: le. 412474 412475! ! 412476 412477!TimeStampTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:19'! 412478testConverting 412479 412480 | d t | 412481 d := '1-10-2000' asDate. 412482 t := '11:55:00 am' asTime. 412483 412484 self 412485 assert: timestamp asSeconds = (d asSeconds + t asSeconds); 412486 assert: timestamp asDate = d; 412487 assert: timestamp asTime = t; 412488 assert: timestamp asTimeStamp == timestamp; 412489 assert: timestamp dateAndTime = {d. t}. 412490! ! 412491 412492!TimeStampTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:55'! 412493testFromSeconds 412494 412495 self 412496 assert: (self timestampClass fromSeconds: 3124958100) = timestamp.! ! 412497 412498!TimeStampTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 15:02'! 412499testFromString 412500 "This should signal an exception in 3.6beta as Time>>fromString: does not exist." 412501 412502 self should: [ timestamp = (self timestampClass fromString: '1-10-2000 11:55:00 am') ] 412503 412504! ! 412505 412506!TimeStampTest methodsFor: 'Tests' stamp: 'brp 1/30/2005 09:12'! 412507testInstanceCreation 412508 412509 self 412510 should: [ self timestampClass midnight asDuration = (0 hours) ]; 412511 should: [ self timestampClass noon asDuration = (12 hours) ]. 412512! ! 412513 412514!TimeStampTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 15:02'! 412515testPrinting 412516 412517 self 412518 assert: timestamp printString = '10 January 2000 11:55 am'. 412519! ! 412520 412521!TimeStampTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 17:47'! 412522testSorting 412523 412524 | c1 c2 | 412525 c1 := self timestampClass current. 412526 c2 := self timestampClass current. 412527 412528 self 412529 assert: (self timestampClass current) <= (self timestampClass current); 412530 assert: (c1 <= c2). 412531 412532 412533! ! 412534 412535 412536!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'! 412537testDate 412538 self assert: aTimeStamp date = '01-02-2004' asDate! ! 412539 412540!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'! 412541testDateAndTime 412542 self assert: aTimeStamp dateAndTime 412543 = (Array with: '01-02-2004' asDate with: '00:34:56' asTime)! ! 412544 412545!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'! 412546testMinusDays 412547 self assert: (aTimeStamp minusDays: 5) dateAndTime 412548 = (Array with: '12-28-2003' asDate with: '00:34:56' asTime)! ! 412549 412550!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'! 412551testMinusSeconds 412552 self assert: (aTimeStamp minusSeconds: 34 * 60 + 56) dateAndTime 412553 = (Array with: '01-02-2004' asDate with: '00:00:00' asTime)! ! 412554 412555!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'! 412556testMinusSecondsOverMidnight 412557 self assert: (aTimeStamp minusSeconds: 34 * 60 + 57) dateAndTime 412558 = (Array with: '01-01-2004' asDate with: '23:59:59' asTime) 412559 "Bug The results are actual results are: #(1 January 2005 11:25:03 pm)"! ! 412560 412561!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'! 412562testPlusDays 412563 self assert: (aTimeStamp plusDays: 366) dateAndTime 412564 = (Array with: '01-02-2005' asDate with: '00:34:56' asTime)! ! 412565 412566!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'! 412567testPlusSeconds 412568 self assert: (aTimeStamp plusSeconds: 60 * 60 ) dateAndTime 412569 = (Array with: '01-02-2004' asDate with: '01:34:56' asTime)! ! 412570 412571!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'! 412572testPlusSecondsOverMidnight 412573 self assert: (aTimeStamp plusSeconds: 24 * 60 * 60 + 1) dateAndTime 412574 = (Array with: '01-03-2004' asDate with: '00:34:57' asTime)! ! 412575 412576!TimeStampTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 412577testPrintOn 412578 | cs rw | 412579 cs := '2 January 2004 12:34:56 am' readStream. 412580 rw := ReadWriteStream on: ''. 412581 aTimeStamp printOn: rw. 412582 self assert: rw contents = cs contents! ! 412583 412584!TimeStampTest methodsFor: 'testing' stamp: 'cbc 2/4/2004 21:18'! 412585testReadFromA1 412586 |ts| 412587 ts := TimeStamp current. 412588 self assert: (ts = (TimeStamp fromString: ts asString)).! ! 412589 412590!TimeStampTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 412591testStoreOn 412592 | cs rw | 412593 cs := '''2 January 2004 12:34:56 am'' asTimeStamp' readStream. 412594 rw := ReadWriteStream on: ''. 412595 aTimeStamp storeOn: rw. 412596 self assert: rw contents = cs contents! ! 412597 412598!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'! 412599testTime 412600 self assert: aTimeStamp time = '00:34:56' asTime! ! 412601 412602!TimeStampTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:41'! 412603testTimeStamp 412604 self assert: aTimeStamp = aTimeStamp asTimeStamp 412605! ! 412606 412607 412608!TimeStampTest methodsFor: 'Private' stamp: 'brp 7/27/2003 13:50'! 412609timestampClass 412610 412611 ^ TimeStamp! ! 412612ClassTestCase subclass: #TimeTest 412613 instanceVariableNames: 'time aTime localTimeZoneToRestore' 412614 classVariableNames: '' 412615 poolDictionaries: '' 412616 category: 'KernelTests-Chronology'! 412617!TimeTest commentStamp: '<historical>' prior: 0! 412618This is the unit test for the class Time. 412619 412620! 412621 412622 412623!TimeTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 13:31'! 412624classToBeTested 412625 412626 ^ self timeClass! ! 412627 412628!TimeTest methodsFor: 'Coverage' stamp: 'brp 1/30/2005 09:09'! 412629selectorsToBeIgnored 412630 412631 | deprecated private special primitives timing benchmarks | 412632 412633 deprecated := #(). 412634 private := #( #print24:on: #print24:showSeconds:on: ). 412635 special := #( #< #= #new #printOn: #storeOn: ). 412636 primitives := #( #primMillisecondClock #primSecondsClock ). 412637 timing := #( #millisecondClockValue #milliseconds:since: #millisecondsSince: ). 412638 benchmarks := #( #benchmarkMillisecondClock #benchmarkPrimitiveResponseDelay ). 412639 412640 ^ super selectorsToBeIgnored, deprecated, private, special, primitives, timing, benchmarks.! ! 412641 412642 412643!TimeTest methodsFor: 'Running' stamp: 'nk 3/30/2004 09:40'! 412644setUp 412645 412646 localTimeZoneToRestore := DateAndTime localTimeZone. 412647 DateAndTime localTimeZone: TimeZone default. 412648 time := self timeClass fromSeconds: 14567. "4:02:47 am" 412649 aTime := Time readFrom: '12:34:56 pm' readStream 412650! ! 412651 412652!TimeTest methodsFor: 'Running' stamp: 'nk 3/30/2004 09:40'! 412653tearDown 412654 DateAndTime localTimeZone: localTimeZoneToRestore. 412655! ! 412656 412657 412658!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:33'! 412659testAccessing 412660 412661 self 412662 assert: time hours = 4; 412663 assert: time minutes = 2; 412664 assert: time seconds = 47; 412665 assert: time asSeconds = 14567. 412666! ! 412667 412668!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:35'! 412669testArithmetic 412670 | t1 t2 t3 | 412671 t1 := time addSeconds: 70. "4:03:57 am" 412672 self 412673 assert: t1 hours = 4; 412674 assert: t1 minutes = 3; 412675 assert: t1 seconds = 57. 412676 412677 t2 := t1 addTime: (self timeClass fromSeconds: (60*60*5)). 412678 self 412679 assert: t2 hours = 9; 412680 assert: t2 minutes = 3; 412681 assert: t2 seconds = 57. 412682 412683 t3 := t2 subtractTime: (self timeClass fromSeconds: (60*60*5) + 70). 412684 self 412685 assert: t3 = time. 412686! ! 412687 412688!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:36'! 412689testComparing 412690 | t1 t2 t3 | 412691 t1 := self timeClass fromSeconds: 14567. "4:02:47 am" 412692 t2 := self timeClass fromSeconds: 5000. "1:23:20 am" 412693 t3 := self timeClass fromSeconds: 80000. "10:13:20 pm" 412694 412695 self 412696 assert: time = t1; 412697 assert: time hash = t1 hash; 412698 assert: time = time copy. 412699 self 412700 deny: t1 < t2; 412701 assert: t1 < t3.! ! 412702 412703!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:37'! 412704testConverting 412705 412706 self 412707 assert: time asSeconds = 14567.! ! 412708 412709!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:38'! 412710testFromSeconds 412711 | t | 412712 t := self timeClass fromSeconds: 14567. 412713 self 412714 assert: t = time 412715! ! 412716 412717!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:52'! 412718testGeneralInquiries 412719 | now d t dt | 412720 412721 now := self timeClass dateAndTimeNow. 412722 self 412723 assert: now size = 2; 412724 assert: now last <= self timeClass now. 412725 412726 self should: [ self timeClass timeWords ] raise: MessageNotUnderstood. 412727 412728 d := '2 June 1973' asDate. 412729 t := '4:02:47 am' asTime. 412730 dt := self timeClass dateAndTimeFromSeconds: (2285280000 + 14567). 412731 self 412732 assert: dt = {d. t.}. 412733! ! 412734 412735!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:44'! 412736testNew 412737 412738 self assert: self timeClass new asSeconds = 0! ! 412739 412740!TimeTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 22:27'! 412741testPrinting 412742 412743 self 412744 assert: time printString = '4:02:47 am'; 412745 assert: time intervalString = '4 hours 2 minutes 47 seconds'; 412746 assert: time print24 = '04:02:47'; 412747 assert: time printMinutes = '4:02 am'; 412748 assert: time hhmm24 = '0402'. 412749! ! 412750 412751!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:46'! 412752testReadFrom 412753 412754 | string t | 412755 string := '4:02:47 am'. 412756 t := self timeClass readFrom: string readStream. 412757 412758 self 412759 assert: time = t. 412760! ! 412761 412762!TimeTest methodsFor: 'Tests' stamp: 'gk 8/31/2006 00:47'! 412763testSqueakInquiries 412764 | timewords totalseconds condensed corrected | 412765 self assert: 412766 (self timeClass namesForTimes: #(2 10000023 10000026)) 412767 = #('January, 1901' 'April, 1901, 4/26/1901, 5:47 pm' 'April, 1901, 4/26/1901, 5:47 pm'). 412768 412769 timewords := #(0.5 30 62 130 4000 10000 60000 86401) 412770 collect: [ :ss | self timeClass humanWordsForSecondsAgo: ss ]. 412771 self assert: 412772 timewords = #('a second ago' '30 seconds ago' 'a minute ago' '2 minutes ago' 412773 'an hour ago' '2 hours ago' '16 hours ago' 'yesterday'). 412774 412775 totalseconds := self timeClass totalSeconds. 412776 condensed := self timeClass condenseBunches: 412777 (#(20 400 401 20000 20200 20300 40000 45000 200000 201000 202000) 412778 collect: [:tt | totalseconds - tt]). 412779 corrected := condensed collect: [ :e | totalseconds - e ]. 412780 self 412781 assert: (corrected includesAllOf: #(20 400 401 20000 40000 45000 200000)). 412782! ! 412783 412784!TimeTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:47'! 412785testStoring 412786 412787 self 412788 assert: time storeString = '''4:02:47 am'' asTime'; 412789 assert: time = ('4:02:47 am' asTime). 412790! ! 412791 412792 412793!TimeTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 412794testAddSeconds 412795 self assert: (aTime addSeconds: 1) = (Time readFrom: '12:34:57' readStream). 412796 self assert: (aTime addSeconds: 60) = (Time readFrom: '12:35:56' readStream). 412797 self assert: (aTime addSeconds: 3600) = (Time readFrom: '13:34:56' readStream). 412798 self assert: (aTime addSeconds: 24 * 60 * 60) = (Time readFrom: '12:34:56' readStream)! ! 412799 412800!TimeTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 412801testAddTime 412802 self assert: (aTime addTime: aTime) = (Time readFrom: '01:09:52' readStream)! ! 412803 412804!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412805testAsDate 412806 self assert: (aTime asDate) = (Date current) 412807! ! 412808 412809!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412810testAsDateAndTime 412811 self assert: (aTime asDateAndTime) = (DateAndTime current midnight + aTime) 412812! ! 412813 412814!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412815testAsDuration 412816 self assert: (aTime asDuration) = (Duration days: 0 hours: 12 minutes: 34 seconds: 56) 412817! ! 412818 412819!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412820testAsNanoSeconds 412821 self assert: (aTime asNanoSeconds) = 45296000000000 412822 412823! ! 412824 412825!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412826testAsSeconds 412827 self assert: (aTime asSeconds) = 45296 412828! ! 412829 412830!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412831testAsTime 412832 self assert: (aTime asTime) = aTime 412833 412834! ! 412835 412836!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412837testAsTimeStamp 412838 self assert: (aTime asTimeStamp) = (DateAndTime current midnight + aTime) asTimeStamp 412839! ! 412840 412841!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412842testAsWeek 412843 self assert: aTime asWeek = (DateAndTime current midnight + aTime) asWeek 412844! ! 412845 412846!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412847testAsYear 412848 self assert: aTime asYear = (DateAndTime current midnight + aTime) asYear 412849! ! 412850 412851!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412852testDuration 412853 self assert: aTime duration = 0 seconds! ! 412854 412855!TimeTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 412856testEqual 412857 self assert: aTime = (Time readFrom: '12:34:56' readStream)! ! 412858 412859!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412860testHhmm24 412861 self assert: aTime hhmm24 = '1234'! ! 412862 412863!TimeTest methodsFor: 'testing' stamp: 'nk 3/30/2004 09:42'! 412864testHour 412865 self assert: aTime hour = 12. 412866 self assert: aTime hour12 = 12. 412867 self assert: aTime hour24 = 12. 412868 self assert: aTime hours = 12.! ! 412869 412870!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412871testHumanWordsForSecondsAgo 412872 self assert: (Time humanWordsForSecondsAgo: 0.999999999) 412873 = 'a second ago'. 412874 self assert: (Time humanWordsForSecondsAgo: 44.99999999) 412875 = '44.99999999 seconds ago'. 412876 self assert: (Time humanWordsForSecondsAgo: 89.999999999) 412877 = 'a minute ago'. 412878 self assert: (Time humanWordsForSecondsAgo: 2699.999999999) 412879 = '44 minutes ago'. 412880 self assert: (Time humanWordsForSecondsAgo: 5399.999999999) 412881 = 'an hour ago'. 412882 self assert: (Time humanWordsForSecondsAgo: 64799.999999999) 412883 = '17 hours ago'. 412884 ! ! 412885 412886!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412887testHumanWordsForSecondsAgoWithDays 412888 412889 self assert: (Time humanWordsForSecondsAgo: 18 * 60 * 60) 412890 = 'yesterday'. 412891 self assert: (Time humanWordsForSecondsAgo: 24 * 60 * 60) 412892 = 'yesterday'. 412893! ! 412894 412895!TimeTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 412896testLessThan 412897 self assert: aTime < (Time readFrom: '12:34:57' readStream)! ! 412898 412899!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412900testMeridianAbbreviation 412901 self assert: aTime meridianAbbreviation = 'PM'. 412902! ! 412903 412904!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412905testMinute 412906 self assert: aTime minute = 34. 412907 self assert: aTime minutes = 34 412908! ! 412909 412910!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412911testNanoSecond 412912 self assert: aTime nanoSecond = 0 412913 "Right now all times all seconds" 412914! ! 412915 412916!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412917testPrint24 412918 self assert: aTime print24 = '12:34:56'! ! 412919 412920!TimeTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 412921testPrint24On 412922 | cs rw | 412923 cs := '12:34:56' readStream. 412924 rw := ReadWriteStream on: ''. 412925 aTime 412926 print24: true 412927 on: rw. 412928 self assert: rw contents = cs contents! ! 412929 412930!TimeTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 412931testPrint24OnWithPM 412932 | cs rw | 412933 cs := '12:34:56 pm' readStream. 412934 rw := ReadWriteStream on: ''. 412935 aTime 412936 print24: false 412937 on: rw. 412938 ^ self assert: rw contents = cs contents! ! 412939 412940!TimeTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 412941testPrint24OnWithoutSeconds 412942 | cs rw | 412943 cs := '12:34:56' readStream. 412944 rw := ReadWriteStream on: ''. 412945 aTime 412946 print24: true 412947 showSeconds: true 412948 on: rw. 412949 self assert: rw contents = cs contents! ! 412950 412951!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412952testPrintMinutes 412953 self assert: aTime printMinutes = '12:34 pm'! ! 412954 412955!TimeTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 412956testPrintOn 412957 | cs rw | 412958 cs := '12:34:56 pm' readStream. 412959 rw := ReadWriteStream on: ''. 412960 aTime printOn: rw. 412961 self assert: rw contents = cs contents! ! 412962 412963!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412964testSecond 412965 self assert: aTime second = 56. 412966 self assert: aTime seconds = 56 412967! ! 412968 412969!TimeTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 412970testStoreOn 412971 | cs rw | 412972 cs := '''12:34:56 pm'' asTime' readStream. 412973 rw := ReadWriteStream on: ''. 412974 aTime storeOn: rw. 412975 self assert: rw contents = cs contents! ! 412976 412977!TimeTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 412978testSubtractTime 412979 self assert: (aTime subtractTime: aTime) = (Time readFrom: '00:00:00' readStream)! ! 412980 412981!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412982testTicks 412983 self assert: aTime ticks = #(0 45296 0). 412984 self assert: aTime = (Time new ticks: #(0 45296 0))! ! 412985 412986!TimeTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:52'! 412987testTimeStamp 412988 self assert: aTime = aTime asTimeStamp asTime! ! 412989 412990 412991!TimeTest methodsFor: 'Private' stamp: 'brp 7/27/2003 13:32'! 412992timeClass 412993 412994 ^ Time! ! 412995Object subclass: #TimeZone 412996 instanceVariableNames: 'offset abbreviation name' 412997 classVariableNames: '' 412998 poolDictionaries: 'ChronologyConstants' 412999 category: 'Kernel-Chronology'! 413000!TimeZone commentStamp: 'brp 9/4/2003 06:32' prior: 0! 413001TimeZone is a simple class to colect the information identifying a UTC time zone. 413002 413003offset - Duration - the time zone's offset from UTC 413004abbreviation - String - the abbreviated name for the time zone. 413005name - String - the name of the time zone. 413006 413007TimeZone class >> #timeZones returns an array of the known time zones 413008TimeZone class >> #default returns the default time zone (Grenwich Mean Time)! 413009 413010 413011!TimeZone methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:28'! 413012abbreviation 413013 413014 ^ abbreviation 413015 ! ! 413016 413017!TimeZone methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:28'! 413018abbreviation: aString 413019 413020 abbreviation := aString 413021! ! 413022 413023!TimeZone methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:29'! 413024name 413025 413026 ^ name 413027 ! ! 413028 413029!TimeZone methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:28'! 413030name: aString 413031 413032 name := aString 413033! ! 413034 413035!TimeZone methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:28'! 413036offset 413037 413038 ^ offset! ! 413039 413040!TimeZone methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:28'! 413041offset: aDuration 413042 413043 offset := aDuration! ! 413044 413045 413046!TimeZone methodsFor: 'private' stamp: 'brp 9/4/2003 06:37'! 413047printOn: aStream 413048 413049 super printOn: aStream. 413050 aStream 413051 nextPut: $(; 413052 nextPutAll: self abbreviation; 413053 nextPut: $).! ! 413054 413055"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 413056 413057TimeZone class 413058 instanceVariableNames: ''! 413059 413060!TimeZone class methodsFor: 'accessing' stamp: 'brp 9/4/2003 06:38'! 413061default 413062 "Answer the default time zone - GMT" 413063 413064 ^ self timeZones detect: [ :tz | tz offset = Duration zero ] 413065 ! ! 413066 413067!TimeZone class methodsFor: 'accessing' stamp: 'brp 1/30/2005 09:35'! 413068timeZones 413069 413070 ^ { 413071 self offset: 0 hours name: 'Universal Time' abbreviation: 'UTC'. 413072 self offset: 0 hours name: 'Greenwich Mean Time' abbreviation: 'GMT'. 413073 self offset: 1 hours name: 'British Summer Time' abbreviation: 'BST'. 413074 self offset: 2 hours name: 'South African Standard Time' abbreviation: 'SAST'. 413075 self offset: -8 hours name: 'Pacific Standard Time' abbreviation: 'PST'. 413076 self offset: -7 hours name: 'Pacific Daylight Time' abbreviation: 'PDT'. 413077 } 413078 413079! ! 413080 413081 413082!TimeZone class methodsFor: 'instance creation' stamp: 'brp 9/4/2003 06:33'! 413083offset: aDuration name: aName abbreviation: anAbbreviation 413084 413085 ^ self new 413086 offset: aDuration; 413087 name: aName; 413088 abbreviation: anAbbreviation; 413089 yourself! ! 413090Notification subclass: #TimedOut 413091 instanceVariableNames: '' 413092 classVariableNames: '' 413093 poolDictionaries: '' 413094 category: 'Exceptions-Kernel'! 413095!TimedOut commentStamp: 'brp 10/21/2004 17:47' prior: 0! 413096I am signalled by #duration:timeoutDo: if the receiving block takes too long to execute. 413097 413098I am signalled by a watchdog process spawned by #duration:timeoutDo: and caught in the same method. 413099 413100I am not intended to be used elsewhere.! 413101 413102Magnitude subclass: #Timespan 413103 instanceVariableNames: 'start duration' 413104 classVariableNames: '' 413105 poolDictionaries: '' 413106 category: 'Kernel-Chronology'! 413107!Timespan commentStamp: 'brp 5/13/2003 08:07' prior: 0! 413108I represent a duration starting on a specific DateAndTime. 413109! 413110 413111 413112!Timespan methodsFor: 'ansi protocol' stamp: 'brp 9/15/2003 14:05'! 413113+ operand 413114 "operand conforms to protocol Duration" 413115 413116 ^ self class starting: (self start + operand) duration: self duration 413117! ! 413118 413119!Timespan methodsFor: 'ansi protocol' stamp: 'brp 9/15/2003 14:07'! 413120- operand 413121 "operand conforms to protocol DateAndTime or protocol Duration" 413122 413123 ^ (operand respondsTo: #asDateAndTime) 413124 ifTrue: [ self start - operand ] 413125 ifFalse: [ self + (operand negated) ]. ! ! 413126 413127!Timespan methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:43'! 413128< comparand 413129 413130 ^ self start < comparand ! ! 413131 413132!Timespan methodsFor: 'ansi protocol' stamp: 'sd 3/16/2008 15:37'! 413133= comparand 413134 ^ self class = comparand class 413135 and: [ self start = comparand start ] 413136 and: [ self duration = comparand duration ] 413137! ! 413138 413139!Timespan methodsFor: 'ansi protocol' stamp: 'brp 7/27/2003 17:49'! 413140dayOfMonth 413141 "Answer the day of the month represented by the receiver." 413142 413143 ^ start dayOfMonth! ! 413144 413145!Timespan methodsFor: 'ansi protocol' stamp: 'brp 8/6/2003 18:42'! 413146dayOfWeek 413147 "Answer the day of the week represented by the receiver." 413148 413149 ^ start dayOfWeek! ! 413150 413151!Timespan methodsFor: 'ansi protocol' stamp: 'brp 8/6/2003 18:42'! 413152dayOfWeekName 413153 "Answer the day of the week represented by the receiver." 413154 413155 ^ start dayOfWeekName! ! 413156 413157!Timespan methodsFor: 'ansi protocol' stamp: 'brp 8/24/2003 11:50'! 413158dayOfYear 413159 "Answer the day of the year represented by the receiver." 413160 413161 ^ start dayOfYear! ! 413162 413163!Timespan methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:44'! 413164hash 413165 413166 ^ start hash + duration hash ! ! 413167 413168!Timespan methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:44'! 413169isLeapYear 413170 413171 ^ start isLeapYear ! ! 413172 413173!Timespan methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:44'! 413174month 413175 413176 ^ start month ! ! 413177 413178!Timespan methodsFor: 'ansi protocol' stamp: 'brp 1/7/2004 16:25'! 413179monthAbbreviation 413180 413181 ^ start monthAbbreviation ! ! 413182 413183!Timespan methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:44'! 413184monthName 413185 413186 ^ start monthName ! ! 413187 413188!Timespan methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:44'! 413189year 413190 413191 ^ start year ! ! 413192 413193 413194!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:49'! 413195dates 413196 413197 413198 | dates | 413199 413200 dates := OrderedCollection new. 413201 self datesDo: [ :m | dates add: m ]. 413202 ^ dates asArray.! ! 413203 413204!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:49'! 413205datesDo: aBlock 413206 413207 self do: aBlock with: start asDate. ! ! 413208 413209!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:50'! 413210every: aDuration do: aBlock 413211 413212 | element end | 413213 element := self start. 413214 end := self end. 413215 [ element <= end ] whileTrue: 413216 413217 [ aBlock value: element. 413218 element := element + aDuration. ] 413219! ! 413220 413221!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:50'! 413222months 413223 413224 | months | 413225 months := OrderedCollection new: 12. 413226 self monthsDo: [ :m | months add: m ]. 413227 ^ months asArray.! ! 413228 413229!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:50'! 413230monthsDo: aBlock 413231 413232 self do: aBlock with: start asMonth.! ! 413233 413234!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:51'! 413235weeks 413236 413237 413238 | weeks | 413239 weeks := OrderedCollection new. 413240 self weeksDo: [ :m | weeks add: m ]. 413241 ^ weeks asArray.! ! 413242 413243!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:51'! 413244weeksDo: aBlock 413245 413246 self do: aBlock with: self asWeek.! ! 413247 413248!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:51'! 413249workDatesDo: aBlock 413250 "Exclude Saturday and Sunday" 413251 413252 self do: aBlock with: start asDate when: [ :d | d dayOfWeek < 6 ]. ! ! 413253 413254!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:51'! 413255years 413256 413257 413258 | years | 413259 years := OrderedCollection new. 413260 self yearsDo: [ :m | years add: m ]. 413261 ^ years asArray.! ! 413262 413263!Timespan methodsFor: 'enumerating' stamp: 'brp 5/13/2003 08:58'! 413264yearsDo: aBlock 413265 413266 self do: aBlock with: start asYear.! ! 413267 413268 413269!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 14:09'! 413270day 413271 "Answer the day of the year represented by the receiver." 413272 ^ self dayOfYear! ! 413273 413274!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 08:45'! 413275daysInMonth 413276 413277 ^ start daysInMonth ! ! 413278 413279!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 08:45'! 413280daysInYear 413281 "Answer the number of days in the month represented by the receiver." 413282 413283 ^ start daysInYear ! ! 413284 413285!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 17:50'! 413286daysLeftInYear 413287 ^ start daysLeftInYear! ! 413288 413289!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 17:55'! 413290firstDayOfMonth 413291 413292 ^ start firstDayOfMonth! ! 413293 413294!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 08:47'! 413295monthIndex 413296 413297 ^ self month ! ! 413298 413299!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 08:47'! 413300next 413301 413302 ^ self class starting: (start + duration) duration: duration ! ! 413303 413304!Timespan methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 08:48'! 413305previous 413306 413307 ^ self class starting: (start - duration) duration: duration ! ! 413308 413309 413310!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:44'! 413311asDate 413312 413313 ^ start asDate ! ! 413314 413315!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:44'! 413316asDateAndTime 413317 413318 ^ start ! ! 413319 413320!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/30/2003 00:10'! 413321asDuration 413322 413323 ^ self duration! ! 413324 413325!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:45'! 413326asMonth 413327 413328 ^ start asMonth ! ! 413329 413330!Timespan methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:45'! 413331asTime 413332 413333 ^ start asTime! ! 413334 413335!Timespan methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:25'! 413336asTimeStamp 413337 413338 ^ start asTimeStamp! ! 413339 413340!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:45'! 413341asWeek 413342 413343 ^ start asWeek ! ! 413344 413345!Timespan methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:45'! 413346asYear 413347 413348 ^ start asYear! ! 413349 413350!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:45'! 413351duration 413352 "Answer the Duration of this timespan" 413353 413354 ^ duration ! ! 413355 413356!Timespan methodsFor: 'squeak protocol' stamp: 'brp 9/23/2004 09:53'! 413357end 413358 413359 ^ self duration asNanoSeconds = 0 413360 ifTrue: [ self start ] 413361 ifFalse: [ self next start - DateAndTime clockPrecision ]! ! 413362 413363!Timespan methodsFor: 'squeak protocol' stamp: 'brp 1/7/2004 16:05'! 413364includes: aDateAndTime 413365 413366 ^ (aDateAndTime isKindOf: Timespan) 413367 ifTrue: [ (self includes: aDateAndTime start) 413368 and: [ self includes: aDateAndTime end ] ] 413369 ifFalse: [ aDateAndTime asDateAndTime between: start and: self end ] 413370! ! 413371 413372!Timespan methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:54'! 413373includesAllOf: aCollection 413374 "Answer whether all the elements of aCollection are in the receiver." 413375 413376 aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]]. 413377 ^ true 413378! ! 413379 413380!Timespan methodsFor: 'squeak protocol' stamp: 'brp 1/7/2004 15:59'! 413381includesAnyOf: aCollection 413382 "Answer whether any element of aCollection is included in the receiver" 413383 413384 aCollection do: [ :elem | (self includes: elem) ifTrue: [^ true]]. 413385 ^false 413386! ! 413387 413388!Timespan methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:47'! 413389intersection: aTimespan 413390 413391 "Return the Timespan both have in common, or nil" 413392 413393 | aBegin anEnd | 413394 aBegin := self start max: aTimespan start. 413395 anEnd := self end min: aTimespan end. 413396 anEnd < aBegin ifTrue: [^nil]. 413397 413398 ^ self class starting: aBegin ending: anEnd. 413399! ! 413400 413401!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:47'! 413402julianDayNumber 413403 413404 ^ start julianDayNumber ! ! 413405 413406!Timespan methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 09:17'! 413407printOn: aStream 413408 413409 super printOn: aStream. 413410 aStream 413411 nextPut: $(; 413412 print: start; 413413 nextPut: $D; 413414 print: duration; 413415 nextPut: $). 413416! ! 413417 413418!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:48'! 413419start 413420 "Answer the start DateAndTime of this timespan" 413421 413422 ^ start ! ! 413423 413424!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:48'! 413425start: aDateAndTime 413426 "Store the start DateAndTime of this timespan" 413427 413428 start := aDateAndTime asDateAndTime 413429! ! 413430 413431!Timespan methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:49'! 413432to: anEnd 413433 "Answer an Timespan. anEnd must be aDateAndTime or a Timespan" 413434 413435 ^ Timespan starting: (self start) ending: (anEnd asDateAndTime). ! ! 413436 413437!Timespan methodsFor: 'squeak protocol' stamp: 'brp 1/9/2004 16:46'! 413438union: aTimespan 413439 "Return the Timespan spanned by both" 413440 413441 | aBegin anEnd | 413442 413443 aBegin := self start min: aTimespan start. 413444 anEnd := self end max: aTimespan end. 413445 ^ Timespan starting: aBegin ending: (anEnd + DateAndTime clockPrecision). 413446! ! 413447 413448 413449!Timespan methodsFor: 'private' stamp: 'brp 5/13/2003 08:58'! 413450do: aBlock with: aFirstElement 413451 413452 self do: aBlock with: aFirstElement when: [ :t | true ]. ! ! 413453 413454!Timespan methodsFor: 'private' stamp: 'brp 5/13/2003 08:59'! 413455do: aBlock with: aFirstElement when: aConditionBlock 413456 413457 | element end | 413458 element := aFirstElement. 413459 end := self end. 413460 [ element start <= end ] whileTrue: 413461 413462 [(aConditionBlock value: element) 413463 ifTrue: [ aBlock value: element ]. 413464 element := element next. ]! ! 413465 413466!Timespan methodsFor: 'private' stamp: 'brp 5/13/2003 08:59'! 413467duration: aDuration 413468 "Set the Duration of this timespan" 413469 413470 duration := aDuration 413471! ! 413472 413473"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 413474 413475Timespan class 413476 instanceVariableNames: ''! 413477 413478!Timespan class methodsFor: 'squeak protocol' stamp: 'brp 5/21/2003 08:35'! 413479current 413480 413481 ^ self starting: DateAndTime now ! ! 413482 413483!Timespan class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 18:49'! 413484new 413485 "Answer a Timespan starting on the Squeak epoch: 1 January 1901" 413486 413487 ^ self starting: DateAndTime new 413488! ! 413489 413490!Timespan class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:42'! 413491starting: aDateAndTime 413492 413493 ^ self starting: aDateAndTime duration: Duration zero ! ! 413494 413495!Timespan class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 18:48'! 413496starting: aDateAndTime duration: aDuration 413497 413498 ^ self basicNew 413499 start: aDateAndTime asDateAndTime; 413500 duration: aDuration; 413501 yourself.! ! 413502 413503!Timespan class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:16'! 413504starting: startDateAndTime ending: endDateAndTime 413505 413506 ^ self 413507 starting: startDateAndTime 413508 duration: (endDateAndTime asDateAndTime - startDateAndTime). ! ! 413509TestCase subclass: #TimespanDoSpanAYearTest 413510 instanceVariableNames: 'aTimespan aDuration aDate' 413511 classVariableNames: '' 413512 poolDictionaries: '' 413513 category: 'KernelTests-Chronology'! 413514!TimespanDoSpanAYearTest commentStamp: 'tlk 1/6/2004 17:55' prior: 0! 413515I am one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. See DateAndTimeEpochTestCase for a complete list. tlk. 413516My fixtures include a Timespan that crosses over a year boundary: 413517aDate = December 25, 2004, midnight 413518aDuration = 91 days 413519aTimeSpan= 91 days, starting December 25, 2004, midnight! 413520 413521 413522!TimespanDoSpanAYearTest methodsFor: 'running' stamp: 'brp 9/26/2004 18:59'! 413523setUp 413524 aDate := DateAndTime year: 2004 month: 12 day: 25 hour: 0 minute: 0 second: 0. 413525 aDuration := Duration days: 91 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0. 413526 413527 aTimespan := Timespan starting: aDate duration: aDuration! ! 413528 413529 413530!TimespanDoSpanAYearTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:55'! 413531testMonthsDo 413532 413533 | monthArray | 413534 413535 monthArray := Array 413536 with: (Month starting: (DateAndTime year: 2004 day: 355) duration: 31 days) 413537 with: (Month starting: (DateAndTime year: 2005 day: 1) duration: 31 days) 413538 with: (Month starting: (DateAndTime year: 2005 day: 32) duration: 29 days) 413539 with: (Month starting: (DateAndTime year: 2005 day: 61) duration: 31 days). 413540 413541 self assert: aTimespan months = monthArray! ! 413542 413543!TimespanDoSpanAYearTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:55'! 413544testNext 413545 413546 self assert: aTimespan next 413547 = (Timespan 413548 starting: (DateAndTime 413549 year: 2005 413550 month: 3 413551 day: 26 413552 hour: 0 413553 minute: 0 413554 second: 0) 413555 duration: aDuration)! ! 413556 413557!TimespanDoSpanAYearTest methodsFor: 'testing' stamp: 'brp 9/26/2004 19:06'! 413558testWeeksDo 413559 | weeks weekArray | 413560 weeks := aTimespan weeks. 413561 self assert: weeks size = ((aDuration days / 7.0) ceiling + 1). 413562 413563 weekArray := OrderedCollection new. 413564 weekArray 413565 addLast: (Week starting: (DateAndTime year: 2004 month: 12 day: 19) duration: 7 days); 413566 addLast: (Week starting: (DateAndTime year: 2004 month: 12 day: 26) duration: 7 days). 413567 413568 2 to: 79 by: 7 do: 413569 [ :i | weekArray 413570 addLast: (Week starting: (DateAndTime year: 2005 day: i) duration: 7 days) ]. 413571 413572 weekArray := weekArray asArray. 413573 self assert: aTimespan weeks = weekArray 413574! ! 413575 413576!TimespanDoSpanAYearTest methodsFor: 'testing' stamp: 'nk 3/30/2004 11:08'! 413577testYearsDo 413578 | yearArray | 413579 yearArray := Array 413580 with: (Year 413581 starting: (DateAndTime 413582 year: 2004 413583 month: 12 413584 day: 25) 413585 duration: 366 days). 413586 self assert: aTimespan years = yearArray 413587! ! 413588TestCase subclass: #TimespanDoTest 413589 instanceVariableNames: 'aTimespan aDuration aDate' 413590 classVariableNames: '' 413591 poolDictionaries: '' 413592 category: 'KernelTests-Chronology'! 413593!TimespanDoTest commentStamp: 'tlk 1/6/2004 17:55' prior: 0! 413594I am one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. See DateAndTimeEpochTestCase for a complete list. tlk. 413595My fixtures are: 413596aDate = January 8, 2003, midnight 413597aDuration = 91 days 413598aTimeSpan= 91 days, starting January 8, 2003, midnight 413599! 413600 413601 413602!TimespanDoTest methodsFor: 'running' stamp: 'tlk 1/5/2004 13:01'! 413603setUp 413604 aDate := DateAndTime 413605 year: 2003 413606 month: 01 413607 day: 07 413608 hour: 0 413609 minute: 0 413610 second: 0. 413611 aDuration := Duration 413612 days: 91 413613 hours: 0 413614 minutes: 0 413615 seconds: 0 413616 nanoSeconds: 0. 413617 aTimespan := Timespan starting: aDate duration: aDuration! ! 413618 413619 413620!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 18:00'! 413621testDatesDo 413622 | dateArray | 413623 dateArray := OrderedCollection new. 413624 7 413625 to: 97 413626 do: [:each | dateArray 413627 addLast: (Date year: 2003 day: each)]. 413628 dateArray := dateArray asArray. 413629 self assert: aTimespan dates = dateArray! ! 413630 413631!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 16:36'! 413632testDoWith 413633 | count | 413634 count := 0. 413635 aTimespan 413636 do: [:each | count := count + 1] 413637 with: (Timespan 413638 starting: aDate 413639 duration: 7 days). 413640 self assert: count = 13! ! 413641 413642!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 16:39'! 413643testDoWithWhen 413644 | count | 413645 count := 0. 413646 aTimespan 413647 do: [:each | count := count + 1] 413648 with: (Timespan starting: aDate duration: 7 days) 413649 when: [:each | count < 5]. 413650 self assert: count = 5 413651! ! 413652 413653!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 15:39'! 413654testEveryDo 413655 |count duration | 413656 count := 0. 413657 duration := 7 days. 413658 (aTimespan 413659 every: duration 413660 do: [:each | count := count + 1]). 413661 self assert: count = 13 413662 ! ! 413663 413664!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 13:05'! 413665testMonthsDo 413666 | monthArray | 413667 monthArray := Array 413668 with: (Month 413669 starting: (DateAndTime year: 2003 day: 1) 413670 duration: 31 days) 413671 with: (Month 413672 starting: (DateAndTime year: 2003 day: 32) 413673 duration: 28 days) 413674 with: (Month 413675 starting: (DateAndTime year: 2003 day: 60) 413676 duration: 31 days) 413677 with: (Month 413678 starting: (DateAndTime year: 2003 day: 91) 413679 duration: 30 days). 413680 self assert: aTimespan months = monthArray! ! 413681 413682!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 16:09'! 413683testNext 413684 self assert: aTimespan next 413685 = (Timespan 413686 starting: (DateAndTime 413687 year: 2003 413688 month: 4 413689 day: 8 413690 hour: 0 413691 minute: 0 413692 second: 0) 413693 duration: aDuration)! ! 413694 413695!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 13:07'! 413696testWeeksDo 413697 | weekArray | 413698 weekArray := OrderedCollection new. 413699 7 413700 to: 98 413701 by: 7 413702 do: [:each | weekArray 413703 addLast: (Week 413704 starting: (DateAndTime year: 2003 day: each) 413705 duration: 7 days)]. 413706 weekArray := weekArray asArray. 413707 self assert: aTimespan weeks = weekArray 413708! ! 413709 413710!TimespanDoTest methodsFor: 'testing' stamp: 'tlk 1/5/2004 13:09'! 413711testYearsDo 413712 | yearArray | 413713 yearArray := Array 413714 with: (Year 413715 starting: (DateAndTime year: 2003 day: 7) 413716 duration: 365 days). 413717 self assert: aTimespan years contents = yearArray contents! ! 413718ClassTestCase subclass: #TimespanTest 413719 instanceVariableNames: 'timespan aTimespan anOverlappingTimespan anIncludedTimespan aDisjointTimespan aDay aWeek dec31 jan01 jan08 localTimeZoneToRestore' 413720 classVariableNames: '' 413721 poolDictionaries: '' 413722 category: 'KernelTests-Chronology'! 413723 413724!TimespanTest methodsFor: 'Coverage' stamp: 'brp 9/15/2003 14:15'! 413725classToBeTested 413726 413727 ^ Timespan 413728! ! 413729 413730 413731!TimespanTest methodsFor: 'Running' stamp: 'nk 3/30/2004 09:21'! 413732setUp 413733 413734 localTimeZoneToRestore := DateAndTime localTimeZone. 413735 DateAndTime localTimeZone: TimeZone default. 413736 413737 "100 hours starting noon 22 March 2003" 413738 timespan := Timespan starting: 413739 (DateAndTime year: 2003 month: 03 day: 22 hour: 12 minute: 0 second: 0) 413740 duration: (Duration hours: 100). 413741 413742 dec31 := (DateAndTime year: 2004 month: 12 day: 31 hour: 0 minute: 0 second: 0). 413743 jan01 := (DateAndTime year: 2005 month: 1 day: 1 hour: 0 minute: 0 second: 0). 413744 jan08 := (DateAndTime year: 2005 month: 1 day: 8 hour: 0 minute: 0 second:0). 413745 aDay := Duration days: 1 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0. 413746 aWeek := Duration days: 7 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0. 413747 aTimespan := Timespan starting: jan01 duration: aWeek. 413748 anOverlappingTimespan := Timespan starting: dec31 duration: aWeek. 413749 anIncludedTimespan := Timespan starting: jan01 duration: aDay. 413750 aDisjointTimespan := Timespan starting: jan08 duration: aWeek. 413751 413752 413753 413754! ! 413755 413756!TimespanTest methodsFor: 'Running' stamp: 'nk 3/30/2004 09:22'! 413757tearDown 413758 DateAndTime localTimeZone: localTimeZoneToRestore. 413759 timespan := nil 413760! ! 413761 413762 413763!TimespanTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 16:25'! 413764testAccessing 413765 413766 self 413767 assert: (timespan start = 413768 (DateAndTime year: 2003 month: 03 day: 22 hour: 12 minute: 0 second: 0)); 413769 assert: timespan duration = (Duration hours: 100); 413770 assert: timespan month = 3; 413771 assert: timespan monthName = 'March'; 413772 assert: timespan monthAbbreviation = 'Mar' 413773 413774 413775! ! 413776 413777!TimespanTest methodsFor: 'Tests' stamp: 'brp 9/15/2003 14:29'! 413778testArithmetic 413779 413780 | ts1 ts2 d | 413781 ts1 := timespan + 2 days. 413782 ts2 := ts1 - 2 days. 413783 d := ts1 - (DateAndTime year: 2003 month: 03 day: 20). 413784 413785 self 413786 assert: (ts1 start = 413787 (DateAndTime year: 2003 month: 03 day: 24 hour: 12 minute: 0 second: 0)); 413788 assert: (ts1 duration = timespan duration); 413789 assert: (ts2 start = timespan start); 413790 assert: (ts2 duration = timespan duration). 413791 413792 self 413793 assert: d = (Duration days: 4 hours: 12 minutes: 0 seconds: 0) 413794 413795! ! 413796 413797!TimespanTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 06:43'! 413798testInclusion 413799 413800 | t1 t2 t3 t4 | 413801 t1 := timespan start. 413802 t2 := timespan start + (timespan duration / 2). 413803 t3 := timespan end. 413804 t4 := timespan start + (timespan duration). 413805 413806 self 413807 assert: (timespan includes: t1); 413808 assert: (timespan includes: t2); 413809 assert: (timespan includes: t3)"; 413810 deny: (timespan includes: t4). 413811 self 413812 assert: (timespan includes: (t1 to: t2)); 413813 assert: (timespan includes: (t1 to: t4)); 413814 deny: (timespan includes: (Timespan starting: t2 duration: (timespan duration * 2))). 413815 self 413816 assert: (timespan includesAllOf: { t1. t2. t3 } ); 413817 deny: (timespan includesAllOf: { t1. t2. t3. t4} ). 413818 self 413819 assert: (timespan includesAnyOf: { t1. t2. t3 } ); 413820 deny: (timespan includesAnyOf: { t4 } ). 413821"! ! 413822 413823!TimespanTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 16:49'! 413824testUnion 413825 413826 | union | 413827 union := timespan union: timespan. 413828 413829 self 413830 assert: (union start = timespan start); 413831 assert: (union duration = timespan duration) 413832! ! 413833 413834 413835!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413836testAsDate 413837 self assert: aTimespan asDate = jan01 asDate. 413838 "MessageNotUnderstood: Date class>>starting:" 413839! ! 413840 413841!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413842testAsDateAndTime 413843 self assert: aTimespan asDateAndTime = jan01. 413844 "MessageNotUnderstood: Date class>>starting:" 413845 413846! ! 413847 413848!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413849testAsDuration 413850 self assert: aTimespan asDuration = aWeek. 413851 413852 413853 413854! ! 413855 413856!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413857testAsMonth 413858 self assert: aTimespan asMonth = jan01 asMonth. 413859! ! 413860 413861!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413862testAsTime 413863 self assert: aTimespan asTime = jan01 asTime 413864 "MessageNotUnderstood: Time class>>seconds:nanoSeconds:" 413865 ! ! 413866 413867!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413868testAsTimeStamp 413869 self assert: aTimespan asTimeStamp = ((TimeStamp readFrom: '1-01-2005 0:00 am' readStream) offset: 0 hours). 413870! ! 413871 413872!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413873testAsWeek 413874 self assert: aTimespan asWeek = jan01 asWeek. 413875 "DateAndTime new asWeek 413876 MessageNotUnderstood: Week class>>starting:" 413877! ! 413878 413879!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413880testAsYear 413881 self assert: aTimespan asYear = jan01 asYear. 413882 413883! ! 413884 413885!TimespanTest methodsFor: 'testing' stamp: 'brp 9/23/2004 09:58'! 413886testClockPrecisionDuration 413887 | ts | 413888 ts := Timespan starting: Date today duration: DateAndTime clockPrecision. 413889 self 413890 assert: ts start = ts end! ! 413891 413892!TimespanTest methodsFor: 'testing' stamp: 'nk 3/30/2004 09:26'! 413893testCurrent 413894 self assert: (Timespan starting: DateAndTime current) 413895 <= Timespan current. 413896 self assert: Timespan current 413897 <= (Timespan starting: DateAndTime current)! ! 413898 413899!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413900testDay 413901 self assert: aTimespan day = jan01 day 413902! ! 413903 413904!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413905testDayOfMonth 413906 self assert: aTimespan dayOfMonth = 1. 413907! ! 413908 413909!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413910testDayOfWeek 413911 self assert: aTimespan dayOfWeek = 7. 413912 self assert: aTimespan dayOfWeekName = 'Saturday'. 413913! ! 413914 413915!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413916testDayOfYear 413917 self assert: aTimespan dayOfYear = 1. 413918 "MessageNotUnderstood: UndefinedObject>>year:, Undefined object is Year class" 413919! ! 413920 413921!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413922testDaysInMonth 413923 self assert: aTimespan daysInMonth = 31. 413924 "MessageNotUnderstood: Month class>>starting:" 413925! ! 413926 413927!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413928testDaysInYear 413929 self assert: aTimespan daysInYear = 365. 413930 "MessageNotUnderstood: UndefinedObject>>starting: UndefinedObject is Year class" 413931! ! 413932 413933!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413934testDaysLeftInYear 413935 self assert: aTimespan daysLeftInYear = 364. 413936 "MessageNotUnderstood: UndefinedObject>>starting: UndefinedObject is Year class" 413937! ! 413938 413939!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413940testDoWith 413941 | count | 413942 count := 0. 413943 aTimespan 413944 do: [:each | count := count + 1] 413945 with: (Timespan starting: jan01 duration: aDay). 413946 self assert: count = 7! ! 413947 413948!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413949testDoWithWhen 413950 | count | 413951 count := 0. 413952 aTimespan 413953 do: [:each | count := count + 1] 413954 with: (Timespan starting: jan01 duration: aDay) 413955 when: [:each | count < 5]. 413956 self assert: count = 5! ! 413957 413958!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413959testDuration 413960 self assert: aTimespan duration = aWeek. 413961 aTimespan duration: aDay. 413962 self assert: aTimespan duration = aDay. 413963 413964! ! 413965 413966!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413967testEnd 413968 self assert: aTimespan end + (Duration nanoSeconds:1) = aDisjointTimespan 413969 "self assert: aTimespan end (DateAndTime year: 2005 month: 1 day: 7 hour: 23 minute: 59 second: 59 nanoSecond: 999999999 offset: 0 hours). " 413970 "This should work once DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset: is fixed" 413971 413972! ! 413973 413974!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413975testEveryDo 413976 | count duration | 413977 count := 0. 413978 duration := 7 days. 413979 aTimespan 413980 every: duration 413981 do: [:each | count := count + 1]. 413982 self assert: count = 1! ! 413983 413984!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413985testFirstDayOfMonth 413986 self assert: aTimespan firstDayOfMonth = 1. 413987 self assert: aDisjointTimespan firstDayOfMonth = 1 413988! ! 413989 413990!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413991testIncludes 413992 self assert: (aTimespan includes: jan01). 413993 self deny: (aTimespan includes: jan08) 413994! ! 413995 413996!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 413997testIncludesAllOf 413998 self assert: (aTimespan includesAllOf: (Bag with: jan01)). 413999 self deny: (aTimespan includesAllOf: (Bag with: jan01 with: jan08)) 414000! ! 414001 414002!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414003testIncludesAnyOf 414004 self deny: (aTimespan includesAnyOf: (Bag with: dec31)). 414005 self assert: (aTimespan includesAnyOf: (Bag with: jan01 with: jan08)) 414006 "Error is due to bug in Timespan 414007includesAnyOf: aCollection " 414008 "Answer whether any element of aCollection is included in the receiver" 414009 "aCollection do: [ :elem | (self includes: elem) ifTrue: [^ true]]. 414010Shouldn't this return false if none are included? 414011" 414012! ! 414013 414014!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414015testIntersectionWithDisjoint 414016 self assert: (aTimespan intersection: aDisjointTimespan) isNil. 414017! ! 414018 414019!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414020testIntersectionWithIncluded 414021 self assert: (aTimespan intersection: anIncludedTimespan) = 414022 (Timespan starting: jan01 duration: (Duration days: 0 hours: 23 minutes: 59 seconds: 59 nanoSeconds: 999999999)). 414023 self deny: (aTimespan intersection: anIncludedTimespan) = anIncludedTimespan 414024! ! 414025 414026!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414027testIntersectionWithOverlapping 414028 self assert: (aTimespan intersection: anOverlappingTimespan) = 414029 (Timespan starting: jan01 duration: (Duration days: 5 hours: 23 minutes: 59 seconds: 59 nanoSeconds: 999999999)). 414030 414031! ! 414032 414033!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414034testIntersectionWithSelf 414035 self assert: (aTimespan intersection: aTimespan) = 414036 (Timespan starting: jan01 duration: (Duration days: 6 hours: 23 minutes: 59 seconds: 59 nanoSeconds: 999999999)). 414037 self deny: (aTimespan intersection: anIncludedTimespan) = aTimespan 414038! ! 414039 414040!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414041testIntersectionWithSeparate 414042 self assert: (aTimespan intersection: aDisjointTimespan) isNil. 414043 self deny: (aTimespan intersection: anOverlappingTimespan) isNil. 414044 self assert: (aTimespan intersection: anIncludedTimespan) = 414045 (Timespan starting: jan01 duration: (Duration days: 0 hours: 23 minutes: 59 seconds: 59 nanoSeconds: 999999999)). 414046 self deny: (aTimespan intersection: anIncludedTimespan) = anIncludedTimespan 414047! ! 414048 414049!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414050testIsLeapYear 414051 "self assert: anOverlappingTimespan isLeapYear." 414052 "not sure why this fails" 414053 self deny: aTimespan isLeapYear 414054! ! 414055 414056!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414057testJulianDayNumber 414058 self assert: aTimespan julianDayNumber = (jan01 julianDayNumber). 414059! ! 414060 414061!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414062testLessThan 414063 self assert: aTimespan < aDisjointTimespan. 414064 self deny: anIncludedTimespan < aTimespan 414065 ! ! 414066 414067!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414068testMinusADateAndTime 414069 "It appears that subtracting a date from a Timespan gives you a duration = to the difference between the start of the timespan and the date " 414070 self assert: aTimespan - dec31 = aDay. 414071 self assert: aDisjointTimespan - jan01 = aWeek. 414072 414073 414074! ! 414075 414076!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414077testMinusADuration 414078 "It appears that subtracting a duration from a Timespan gives you a Timespan shifted by the duration" 414079 self assert: aTimespan - aDay = anOverlappingTimespan. 414080 self assert: aDisjointTimespan - aWeek = aTimespan. 414081 414082 414083! ! 414084 414085!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414086testMonth 414087 self assert: aTimespan month = 1. 414088 self assert: aTimespan monthName = 'January'. 414089 self assert: aTimespan monthIndex = 1.! ! 414090 414091!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414092testNew 414093 self assert: Timespan new = (Timespan starting: '01-01-1901' asDate)! ! 414094 414095!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414096testNext 414097 self assert: aTimespan next = aDisjointTimespan 414098! ! 414099 414100!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414101testPlus 414102 self assert: aTimespan + aWeek = aDisjointTimespan. 414103 self assert: anOverlappingTimespan + aDay = aTimespan. 414104! ! 414105 414106!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414107testPrevious 414108 self assert: aTimespan = aDisjointTimespan previous. 414109 self assert: aTimespan next previous = aTimespan 414110! ! 414111 414112!TimespanTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 414113testPrintOn 414114 | cs rw | 414115 cs := 'a Timespan(2005-01-01T00:00:00+00:00D7:00:00:00)' readStream. 414116 rw := ReadWriteStream on: ''. 414117 aTimespan printOn: rw. 414118 self assert: rw contents = cs contents! ! 414119 414120!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414121testStart 414122 self assert: aTimespan start = jan01. 414123 aTimespan start: jan08. 414124 self assert: aTimespan start = jan08.! ! 414125 414126!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414127testStartingEnding 414128 self assert: aTimespan = (Timespan starting: jan01 ending: jan08) 414129! ! 414130 414131!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414132testTo 414133 self assert: (anIncludedTimespan to: jan08) = aTimespan 414134! ! 414135 414136!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414137testUnionWithDisjoint 414138 414139 self assert: (aTimespan union: aDisjointTimespan) = 414140 (Timespan starting: jan01 duration: (14 days)). 414141 414142! ! 414143 414144!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414145testUnionWithIncluded 414146 414147 self 414148 assert: (aTimespan union: anIncludedTimespan) = aTimespan ! ! 414149 414150!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414151testUnionWithOverlapping 414152 414153 self 414154 assert: (aTimespan union: anOverlappingTimespan) = 414155 (Timespan starting: dec31 duration: (8 days))! ! 414156 414157!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414158testUnionWithSelf 414159 self assert: (aTimespan union: aTimespan) = aTimespan 414160 ! ! 414161 414162!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414163testUnionWithSeparate 414164 414165 self 414166 assert: (anOverlappingTimespan union: aDisjointTimespan) = 414167 (Timespan 414168 starting: anOverlappingTimespan start 414169 ending: (aDisjointTimespan end + DateAndTime clockPrecision)) 414170 414171! ! 414172 414173!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414174testWorkDatesDo 414175 | count | 414176 count := 0. 414177 aTimespan 414178 workDatesDo: [:each | count := count + 1]. 414179 self assert: count = 5! ! 414180 414181!TimespanTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:31'! 414182testYear 414183 self assert: aTimespan year = 2005. 414184 414185 ! ! 414186 414187!TimespanTest methodsFor: 'testing' stamp: 'brp 9/23/2004 09:57'! 414188testZeroDuration 414189 | ts | 414190 ts := Timespan starting: Date today duration: Duration zero. 414191 self 414192 assert: ts start = ts end! ! 414193MenuItemMorph subclass: #ToggleMenuItemMorph 414194 instanceVariableNames: 'getStateSelector enablementSelector keyText' 414195 classVariableNames: '' 414196 poolDictionaries: '' 414197 category: 'Polymorph-Widgets'! 414198!ToggleMenuItemMorph commentStamp: 'gvc 5/18/2007 10:22' prior: 0! 414199A menu item that supports on/off state (using standard icons), enablement and display of "accelerator" key text.! 414200 414201 414202!ToggleMenuItemMorph methodsFor: 'accessing' stamp: 'gvc 6/9/2006 09:35'! 414203enablementSelector 414204 "Answer the value of enablementSelector" 414205 414206 ^ enablementSelector! ! 414207 414208!ToggleMenuItemMorph methodsFor: 'accessing' stamp: 'gvc 6/9/2006 09:35'! 414209enablementSelector: anObject 414210 "Set the value of enablementSelector" 414211 414212 enablementSelector := anObject! ! 414213 414214!ToggleMenuItemMorph methodsFor: 'accessing' stamp: 'gvc 6/9/2006 09:16'! 414215getStateSelector 414216 "Answer the value of getStateSelector" 414217 414218 ^ getStateSelector! ! 414219 414220!ToggleMenuItemMorph methodsFor: 'accessing' stamp: 'gvc 6/9/2006 09:16'! 414221getStateSelector: anObject 414222 "Set the value of getStateSelector" 414223 414224 getStateSelector := anObject! ! 414225 414226!ToggleMenuItemMorph methodsFor: 'accessing' stamp: 'gvc 6/9/2006 16:13'! 414227keyText 414228 "Answer the value of keyText" 414229 414230 ^ keyText! ! 414231 414232!ToggleMenuItemMorph methodsFor: 'accessing' stamp: 'gvc 6/9/2006 16:13'! 414233keyText: anObject 414234 "Set the value of keyText" 414235 414236 keyText := anObject! ! 414237 414238 414239!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2009 18:17'! 414240adjacentTo 414241 "Adjusted to line up more nicely." 414242 414243 self isInDockingBar 414244 ifFalse: [^{self bounds topRight + (5 @ 0). self bounds topLeft + (2@0)}]. 414245 self owner isFloating 414246 ifTrue: [^ {self bounds bottomLeft + (4 @ 5)}]. 414247 self owner isAdheringToTop 414248 ifTrue: [^ {self bounds bottomLeft + (5 @ 5)}]. 414249 self owner isAdheringToLeft 414250 ifTrue: [^ {self bounds topRight + (5 @ 5)}]. 414251 self owner isAdheringToBottom 414252 ifTrue: [^ {self bounds topLeft + (5 @ 5)}]. 414253 self owner isAdheringToRight 414254 ifTrue: [^ {self bounds topLeft + (5 @ -5)}]. 414255 ^ {self bounds bottomLeft + (3 @ 5)}! ! 414256 414257!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/29/2007 16:25'! 414258adoptPaneColor: paneColor 414259 "Pass on to submenu too." 414260 414261 super adoptPaneColor: paneColor. 414262 self hasSubMenu ifTrue: [self subMenu adoptPaneColor: paneColor]! ! 414263 414264!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/7/2009 11:22'! 414265basicDrawOn: aCanvas 414266 "Draw on the canvas. Taken from MenuItemMorph for minor refactoring." 414267 414268 | stringColor stringBounds| 414269 stringColor := self stringColorToUse. 414270 stringBounds := self stringBoundsToUse. 414271 self isSelected & self isEnabled ifTrue: [ 414272 aCanvas 414273 fillRectangle: self bounds 414274 fillStyle: self selectionFillStyle 414275 borderStyle: self selectionBorderStyle]. 414276 self hasIcon ifTrue: [|iconForm| 414277 iconForm := self icon. 414278 self drawIcon: iconForm on: aCanvas in: stringBounds. 414279 stringBounds := stringBounds left: stringBounds left + iconForm width + 2]. 414280 self hasMarker ifTrue: [ 414281 stringBounds := stringBounds left: stringBounds left + self submorphBounds width + 8]. 414282 stringBounds := stringBounds top: stringBounds top + stringBounds bottom - self fontToUse height // 2. 414283 self drawText: contents on: aCanvas in: stringBounds. 414284 self hasSubMenu ifTrue: [|subMenuMarker| 414285 subMenuMarker := self subMenuMarker deepCopy mapColor: Color black to: stringColor. 414286 self drawSubMenuMarker: subMenuMarker on: aCanvas in: stringBounds]! ! 414287 414288!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/17/2008 14:05'! 414289drawIcon: aForm on: aCanvas in: aRectangle 414290 "Draw the icon on the canvas within the given bounds." 414291 414292 |iconForm| 414293 self isEnabled 414294 ifTrue: [iconForm := aForm] 414295 ifFalse: [iconForm := Form extent: aForm extent depth: 32. 414296 iconForm fillColor: (Color white alpha: 0.003922). 414297 (iconForm getCanvas asAlphaBlendingCanvas: 0.5) 414298 drawImage: aForm 414299 at: 0@0]. 414300 aCanvas 414301 translucentImage: iconForm 414302 at: aRectangle topLeft + (0@(aRectangle height - iconForm height // 2))! ! 414303 414304!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/17/2008 13:40'! 414305drawKeyTextOn: aCanvas 414306 "Draw the key text on the canvas." 414307 414308 |ktp ktw b| 414309 self keyText ifNil: [^self]. 414310 ktp := self hasSubMenu ifTrue: [self right - self subMenuMarker width] ifFalse: [self right]. 414311 ktp := ktp - (ktw := self fontToUse widthOfString: self keyText). 414312 b := (ktp @ (self bounds top + self bounds bottom - self fontToUse height // 2) extent: ktw @ self height). 414313 self drawText: self keyText on: aCanvas in: b! ! 414314 414315!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/12/2006 15:30'! 414316drawOn: aCanvas 414317 "Need to check isEnabled here." 414318 414319 self 414320 isEnabled; 414321 basicDrawOn: aCanvas; 414322 drawKeyTextOn: aCanvas! ! 414323 414324!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/17/2008 14:11'! 414325drawSubMenuMarker: aForm on: aCanvas in: aRectangle 414326 "Draw the submenu marker on the canvas within the given bounds." 414327 414328 |markerRect| 414329 markerRect := aRectangle topRight + (aForm width negated @ (aRectangle height - aForm height // 2)) extent: aForm extent. 414330 self isInDockingBar ifTrue: [markerRect translateBy: -4@1]. 414331 self drawIcon: aForm on: aCanvas in: markerRect! ! 414332 414333!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/17/2008 13:39'! 414334drawText: aStringOrText on: aCanvas in: aRectangle 414335 "Draw the text on the canvas within the given bounds." 414336 414337 self isEnabled 414338 ifTrue: [aCanvas 414339 drawString: aStringOrText 414340 in: aRectangle 414341 font: self fontToUse 414342 color: self stringColorToUse] 414343 ifFalse: [self theme disabledItemStyle = #inset 414344 ifTrue: [aCanvas 414345 drawString: aStringOrText 414346 in: (aRectangle translateBy: -1) 414347 font: self fontToUse 414348 color: self owner color muchDarker; 414349 drawString: aStringOrText 414350 in: aRectangle 414351 font: self fontToUse 414352 color: self owner color lighter] 414353 ifFalse: [aCanvas 414354 drawString: aStringOrText 414355 in: aRectangle 414356 font: self fontToUse 414357 color: self owner color muchDarker]].! ! 414358 414359!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/17/2008 15:47'! 414360icon 414361 "Answer the receiver's icon. Handle legacy case 414362 of wording-based mechanism." 414363 414364 |state| 414365 self getStateSelector ifNil: [^super icon]. 414366 state := (MessageSend receiver: self target selector: self getStateSelector) 414367 valueWithEnoughArguments: self arguments . 414368 (state = true or: [state isString and: [(state beginsWith: '<yes>') or: [state beginsWith: '<on>']]]) 414369 ifTrue: [^self onIcon]. 414370 (state = false or: [state isString and: [(state beginsWith: '<no>') or: [state beginsWith: '<off>']]]) 414371 ifTrue: [^self offIcon]. 414372 ^super icon! ! 414373 414374!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/24/2008 12:57'! 414375isEnabled 414376 "Answer whether the item is enabled." 414377 414378 |state| 414379 self enablementSelector ifNil: [^super isEnabled]. 414380 state := self enablementSelector isSymbol 414381 ifTrue: [self target perform: self enablementSelector] 414382 ifFalse: [self enablementSelector value]. 414383 self isEnabled: state. 414384 ^state! ! 414385 414386!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/17/2008 14:44'! 414387isEnabled: aBoolean 414388 414389 isEnabled = aBoolean ifTrue: [^ self]. 414390 isEnabled := aBoolean. 414391 self changed! ! 414392 414393!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/9/2006 16:18'! 414394minWidth 414395 "Plus the key text if any." 414396 414397 |w| 414398 w := super minWidth. 414399 self keyText ifNotNil: [w := w + (self fontToUse widthOfString: self keyText) + 12]. 414400 ^w! ! 414401 414402!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/6/2008 14:33'! 414403mouseEnter: evt 414404 "The mouse entered the receiver. 414405 Handle the case when in an EmbeddedMenuMorph." 414406 414407 super mouseEnter: evt. 414408 (owner notNil and: [owner isKindOf: EmbeddedMenuMorph]) ifTrue:[ 414409 owner selectedItem ~~ self 414410 ifTrue: [owner selectItem: self event: evt]]! ! 414411 414412!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/6/2008 14:36'! 414413mouseLeave: evt 414414 "The mouse left the receiver. 414415 Handle the case when in an EmbeddedMenuMorph." 414416 414417 super mouseLeave: evt. 414418 (owner notNil and: [owner isKindOf: EmbeddedMenuMorph]) ifTrue:[ 414419 owner selectedItem == self 414420 ifTrue: [owner selectItem: nil event: evt]]! ! 414421 414422!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/3/2007 16:51'! 414423offIcon 414424 "Answer the off icon." 414425 414426 |m form| 414427 m := CheckboxButtonMorph new 414428 privateOwner: self owner; 414429 adoptPaneColor: self paneColor; 414430 selected: false. 414431 form := Form extent: m extent depth: 32. 414432 form fillColor: (Color white alpha: 0.003922). 414433 form getCanvas fullDrawMorph: m. 414434 ^form! ! 414435 414436!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/24/2009 16:48'! 414437offImage 414438 "Return the form to be used for indicating an '<off>' marker." 414439 414440 ^self offIcon! ! 414441 414442!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/3/2007 16:50'! 414443onIcon 414444 "Answer the on icon." 414445 414446 |m form| 414447 m := CheckboxButtonMorph new 414448 privateOwner: self owner; 414449 adoptPaneColor: self paneColor; 414450 selected: true. 414451 form := Form extent: m extent depth: 32. 414452 form fillColor: (Color white alpha: 0.003922). 414453 form getCanvas fullDrawMorph: m. 414454 ^form! ! 414455 414456!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/24/2009 16:48'! 414457onImage 414458 "Return the form to be used for indicating an '<on>' marker." 414459 414460 ^self onIcon! ! 414461 414462!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/9/2006 15:07'! 414463select: evt 414464 "Don't if not enabled." 414465 414466 self isEnabled ifFalse: [^self]. 414467 ^super select: evt! ! 414468 414469!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/4/2007 13:03'! 414470selectionBorderStyle 414471 "Answer the border style to use with the receiver is the selected element." 414472 414473 ^self isInDockingBar 414474 ifTrue: [self theme menuItemInDockingBarSelectedBorderStyleFor: self] 414475 ifFalse: [self theme menuItemSelectedBorderStyleFor: self]! ! 414476 414477!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/4/2007 12:55'! 414478selectionFillStyle 414479 "Answer the fill style to use with the receiver is the selected element." 414480 414481 ^self isInDockingBar 414482 ifTrue: [self theme menuItemInDockingBarSelectedFillStyleFor: self] 414483 ifFalse: [self theme menuItemSelectedFillStyleFor: self]! ! 414484 414485!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/12/2006 15:28'! 414486selectionTextColor 414487 "Answer the color to use for text when selected." 414488 414489 ^self color! ! 414490 414491!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/17/2008 13:34'! 414492stringBoundsToUse 414493 "Answer the bounds to use when drawing the item text." 414494 414495 ^self isInDockingBar 414496 ifTrue: [self bounds 414497 left: self left+ (Preferences tinyDisplay 414498 ifTrue: [1] 414499 ifFalse: [4])] 414500 ifFalse: [self bounds]! ! 414501 414502!ToggleMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/17/2008 13:43'! 414503stringColorToUse 414504 "Answer the state dependent color to use for drawing text." 414505 414506 ^self isEnabled 414507 ifTrue: [self isSelected 414508 ifTrue: [((self selectionTextColor luminance - self selectionFillStyle asColor luminance) abs < 0.6) 414509 ifTrue: [self selectionFillStyle asColor darker contrastingColor] 414510 ifFalse: [self selectionTextColor]] 414511 ifFalse: [((self color luminance - self owner paneColor luminance) abs < 0.3) 414512 ifTrue: [self owner paneColor contrastingColor] 414513 ifFalse: [self color]]] 414514 ifFalse: [((self color luminance - self owner paneColor luminance) abs < 0.3) 414515 ifTrue: [self owner color contrastingColor] 414516 ifFalse: [self color]]! ! 414517Object subclass: #ToolBuilder 414518 instanceVariableNames: 'parent' 414519 classVariableNames: 'Default' 414520 poolDictionaries: '' 414521 category: 'ToolBuilder-Kernel'! 414522!ToolBuilder commentStamp: '<historical>' prior: 0! 414523I am a tool builder, that is an object which knows how to create concrete widgets from abstract specifications. Those specifications are used by tools which want to be able to function in diverse user interface paradigms, such as MVC, Morphic, Tweak, wxWidgets etc. 414524 414525The following five specs must be supported by all implementations: 414526 * PluggableButton 414527 * PluggableList 414528 * PluggableText 414529 * PluggablePanel 414530 * PluggableWindow 414531 414532The following specs are optional: 414533 * PluggableTree: If not supported, the tool builder must answer nil when asked for a pluggableTreeSpec. Substitution will require client support so clients must be aware that some tool builders may not support trees (MVC for example, or Seaside). See examples in FileListPlus or TestRunnerPlus. 414534 * PluggableMultiSelectionList: If multi-selection lists are not supported, tool builder will silently support regular single selection lists. 414535 * PluggableInputField: Intended as a HINT for the builder that this widget will be used as a single line input field. Unless explicitly supported it will be automatically substituted by PluggableText. 414536 * PluggableActionButton: Intended as a HINT for the builder that this widget will be used as push (action) button. Unless explicitly supported it will be automatically substituted by PluggableButton. 414537 * PluggableRadioButton: Intended as a HINT for the builder that this widget will be used as radio button. Unless explicitly supported it will be automatically substituted by PluggableButton. 414538 * PluggableCheckBox: Intended as a HINT for the builder that this widget will be used as check box. Unless explicitly supported it will be automatically substituted by PluggableButton. 414539! 414540 414541 414542!ToolBuilder methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:54'! 414543parent 414544 ^parent! ! 414545 414546!ToolBuilder methodsFor: 'accessing' stamp: 'ar 2/9/2005 18:54'! 414547parent: aWidget 414548 parent := aWidget! ! 414549 414550!ToolBuilder methodsFor: 'accessing' stamp: 'ar 7/14/2005 22:23'! 414551widgetAt: widgetID 414552 "Answer the widget with the given ID" 414553 ^self widgetAt: widgetID ifAbsent:[nil]! ! 414554 414555!ToolBuilder methodsFor: 'accessing' stamp: 'ar 7/14/2005 22:23'! 414556widgetAt: widgetID ifAbsent: aBlock 414557 "Answer the widget with the given ID" 414558 ^aBlock value! ! 414559 414560 414561!ToolBuilder methodsFor: 'building' stamp: 'ar 6/5/2005 12:35'! 414562buildAll: aList in: newParent 414563 "Build the given set of widgets in the new parent" 414564 | prior | 414565 aList ifNil:[^self]. 414566 prior := parent. 414567 parent := newParent. 414568 aList do:[:each| each buildWith: self]. 414569 parent := prior. 414570! ! 414571 414572!ToolBuilder methodsFor: 'building' stamp: 'ar 6/5/2005 12:35'! 414573build: anObject 414574 "Build the given object using this tool builder" 414575 ^anObject buildWith: self! ! 414576 414577 414578!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/12/2005 14:18'! 414579pluggableActionButtonSpec 414580 ^PluggableActionButtonSpec! ! 414581 414582!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/10/2005 00:31'! 414583pluggableButtonSpec 414584 ^PluggableButtonSpec! ! 414585 414586!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/12/2005 14:18'! 414587pluggableCheckBoxSpec 414588 ^PluggableCheckBoxSpec! ! 414589 414590!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/11/2005 16:41'! 414591pluggableInputFieldSpec 414592 ^PluggableInputFieldSpec! ! 414593 414594!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/10/2005 00:30'! 414595pluggableListSpec 414596 ^PluggableListSpec! ! 414597 414598!ToolBuilder methodsFor: 'defaults' stamp: 'cwp 6/8/2005 23:24'! 414599pluggableMenuSpec 414600 ^ PluggableMenuSpec! ! 414601 414602!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/12/2005 13:43'! 414603pluggableMultiSelectionListSpec 414604 ^PluggableMultiSelectionListSpec! ! 414605 414606!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/10/2005 00:30'! 414607pluggablePanelSpec 414608 ^PluggablePanelSpec! ! 414609 414610!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/12/2005 14:18'! 414611pluggableRadioButtonSpec 414612 ^PluggableRadioButtonSpec! ! 414613 414614!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/10/2005 00:31'! 414615pluggableTextSpec 414616 ^PluggableTextSpec! ! 414617 414618!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/12/2005 16:53'! 414619pluggableTreeSpec 414620 ^PluggableTreeSpec! ! 414621 414622!ToolBuilder methodsFor: 'defaults' stamp: 'ar 2/10/2005 00:30'! 414623pluggableWindowSpec 414624 ^PluggableWindowSpec! ! 414625 414626 414627!ToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:37'! 414628close: aWidget 414629 "Close a previously opened widget" 414630 ^self subclassResponsibility! ! 414631 414632!ToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:38'! 414633open: anObject 414634 "Build and open the object. Answer the widget opened." 414635 ^self subclassResponsibility! ! 414636 414637!ToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:38'! 414638open: anObject label: aString 414639 "Build an open the object, labeling it appropriately. Answer the widget opened." 414640 ^self subclassResponsibility! ! 414641 414642!ToolBuilder methodsFor: 'opening' stamp: 'ar 6/5/2005 12:39'! 414643runModal: aWidget 414644 "Run the (previously opened) widget modally, e.g., 414645 do not return control to the sender before the user has responded." 414646 ^self subclassResponsibility! ! 414647 414648 414649!ToolBuilder methodsFor: 'widgets optional' stamp: 'ar 2/12/2005 14:05'! 414650buildPluggableActionButton: spec 414651 ^self buildPluggableButton: spec! ! 414652 414653!ToolBuilder methodsFor: 'widgets optional' stamp: 'ar 2/12/2005 14:05'! 414654buildPluggableCheckBox: spec 414655 ^self buildPluggableButton: spec! ! 414656 414657!ToolBuilder methodsFor: 'widgets optional' stamp: 'ar 2/12/2005 18:39'! 414658buildPluggableInputField: aSpec 414659 ^self buildPluggableText: aSpec! ! 414660 414661!ToolBuilder methodsFor: 'widgets optional' stamp: 'ar 2/12/2005 14:06'! 414662buildPluggableMultiSelectionList: aSpec 414663 ^self buildPluggableList: aSpec! ! 414664 414665!ToolBuilder methodsFor: 'widgets optional' stamp: 'ar 2/12/2005 14:05'! 414666buildPluggableRadioButton: spec 414667 ^self buildPluggableButton: spec! ! 414668 414669 414670!ToolBuilder methodsFor: 'widgets required' stamp: 'ar 2/9/2005 18:46'! 414671buildPluggableButton: aSpec 414672 ^self subclassResponsibility! ! 414673 414674!ToolBuilder methodsFor: 'widgets required' stamp: 'ar 2/9/2005 18:47'! 414675buildPluggableList: aSpec 414676 ^self subclassResponsibility! ! 414677 414678!ToolBuilder methodsFor: 'widgets required' stamp: 'ar 6/5/2005 12:30'! 414679buildPluggablePanel: aSpec 414680 ^self subclassResponsibility! ! 414681 414682!ToolBuilder methodsFor: 'widgets required' stamp: 'ar 2/9/2005 18:47'! 414683buildPluggableText: aSpec 414684 ^self subclassResponsibility! ! 414685 414686!ToolBuilder methodsFor: 'widgets required' stamp: 'ar 2/12/2005 00:36'! 414687buildPluggableTree: aSpec 414688 ^self subclassResponsibility! ! 414689 414690!ToolBuilder methodsFor: 'widgets required' stamp: 'ar 2/9/2005 18:47'! 414691buildPluggableWindow: aSpec 414692 ^self subclassResponsibility! ! 414693 414694"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 414695 414696ToolBuilder class 414697 instanceVariableNames: ''! 414698 414699!ToolBuilder class methodsFor: 'accessing' stamp: 'ar 2/11/2005 15:55'! 414700default 414701 "Answer the default tool builder" 414702 | builderClass | 414703 ^Default ifNil:[ 414704 "Note: The way the following is phrased ensures that you can always make 'more specific' builders merely by subclassing a tool builder and implementing a more specific way of reacting to #isActiveBuilder. For example, a BobsUIToolBuilder can subclass MorphicToolBuilder and (if enabled, say Preferences useBobsUITools) will be considered before the parent (generic MorphicToolBuilder)." 414705 builderClass := self allSubclasses 414706 detect:[:any| any isActiveBuilder and:[ 414707 any subclasses noneSatisfy:[:sub| sub isActiveBuilder]]] ifNone:[nil]. 414708 builderClass ifNotNil:[builderClass new]]! ! 414709 414710!ToolBuilder class methodsFor: 'accessing' stamp: 'ar 2/11/2005 15:21'! 414711default: aToolBuilder 414712 "Set a new default tool builder" 414713 Default := aToolBuilder.! ! 414714 414715!ToolBuilder class methodsFor: 'accessing' stamp: 'ar 2/11/2005 15:23'! 414716isActiveBuilder 414717 "Answer whether I am the currently active builder" 414718 ^false! ! 414719 414720 414721!ToolBuilder class methodsFor: 'instance creation' stamp: 'KR 4/28/2006 21:05'! 414722build: aClass 414723 ^self default build: aClass! ! 414724 414725!ToolBuilder class methodsFor: 'instance creation' stamp: 'ar 2/11/2005 18:15'! 414726open: aClass 414727 ^self default open: aClass! ! 414728 414729!ToolBuilder class methodsFor: 'instance creation' stamp: 'ar 2/11/2005 18:15'! 414730open: aClass label: aString 414731 ^self default open: aClass label: aString! ! 414732Object subclass: #ToolBuilderSpec 414733 instanceVariableNames: 'name' 414734 classVariableNames: '' 414735 poolDictionaries: '' 414736 category: 'ToolBuilder-Kernel'! 414737!ToolBuilderSpec commentStamp: 'ar 2/11/2005 14:59' prior: 0! 414738I am an abstract widget specification. I can be rendered using many different UI frameworks.! 414739 414740 414741!ToolBuilderSpec methodsFor: 'accessing' stamp: 'cwp 4/25/2005 03:42'! 414742name 414743 ^ name! ! 414744 414745!ToolBuilderSpec methodsFor: 'accessing' stamp: 'cwp 4/25/2005 03:40'! 414746name: anObject 414747 name := anObject! ! 414748 414749 414750!ToolBuilderSpec methodsFor: 'building' stamp: 'ar 2/12/2005 18:17'! 414751buildWith: aBuilder 414752 ^self subclassResponsibility! ! 414753TestCase subclass: #ToolBuilderTests 414754 instanceVariableNames: 'builder widget queries' 414755 classVariableNames: '' 414756 poolDictionaries: '' 414757 category: 'Tests-ToolBuilder'! 414758!ToolBuilderTests commentStamp: 'ar 2/11/2005 15:01' prior: 0! 414759Some tests to make sure ToolBuilder does what it says.! 414760 414761 414762!ToolBuilderTests methodsFor: 'support' stamp: 'cwp 7/14/2006 10:59'! 414763acceptWidgetText 414764 "accept text in widget" 414765 ^ self subclassResponsibility! ! 414766 414767!ToolBuilderTests methodsFor: 'support' stamp: 'cwp 7/14/2006 11:27'! 414768buttonWidgetEnabled 414769 "Answer whether the current widget (a button) is currently enabled" 414770 414771 ^ widget getModelState! ! 414772 414773!ToolBuilderTests methodsFor: 'support' stamp: 'cwp 7/14/2006 11:00'! 414774changeListWidget 414775 "Change the list widget's selection index" 414776 self subclassResponsibility! ! 414777 414778!ToolBuilderTests methodsFor: 'support' stamp: 'cwp 7/14/2006 11:00'! 414779fireButtonWidget 414780 "Fire the widget, e.g., perform what is needed for the guy to trigger its action" 414781 self subclassResponsibility! ! 414782 414783!ToolBuilderTests methodsFor: 'support' stamp: 'ar 6/21/2005 11:00'! 414784returnFalse 414785 ^false! ! 414786 414787!ToolBuilderTests methodsFor: 'support' stamp: 'ar 6/21/2005 10:57'! 414788returnTrue 414789 ^true! ! 414790 414791!ToolBuilderTests methodsFor: 'support' stamp: 'ar 2/11/2005 14:46'! 414792setUp 414793 queries := IdentitySet new.! ! 414794 414795!ToolBuilderTests methodsFor: 'support' stamp: 'ar 2/10/2005 21:04'! 414796shutDown 414797 self myDependents: nil! ! 414798 414799!ToolBuilderTests methodsFor: 'support' stamp: 'ar 2/12/2005 02:54'! 414800waitTick 414801 ^nil! ! 414802 414803!ToolBuilderTests methodsFor: 'support' stamp: 'cwp 7/14/2006 11:00'! 414804widgetColor 414805 "Answer color from widget" 414806 self subclassResponsibility 414807 414808 "NOTE: You can bail out if you don't know how to get the color from the widget: 414809 ^self getColor 414810 will work."! ! 414811 414812 414813!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 16:56'! 414814fireButton 414815 queries add: #fireButton.! ! 414816 414817!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 14:53'! 414818getEnabled 414819 queries add: #getEnabled. 414820 ^true! ! 414821 414822!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 14:54'! 414823getLabel 414824 queries add: #getLabel. 414825 ^'TestLabel'! ! 414826 414827!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 14:53'! 414828getState 414829 queries add: #getState. 414830 ^true! ! 414831 414832!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/10/2005 21:02'! 414833makeButton 414834 | spec | 414835 spec := self makeButtonSpec. 414836 widget := builder build: spec. 414837 ^widget! ! 414838 414839!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 7/14/2005 22:14'! 414840makeButtonSpec 414841 | spec | 414842 spec := builder pluggableButtonSpec new. 414843 spec name: #button. 414844 spec model: self. 414845 spec label: #getLabel. 414846 spec color: #getColor. 414847 spec state: #getState. 414848 spec enabled: #getEnabled. 414849 ^spec! ! 414850 414851!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 16:54'! 414852testButtonFiresBlock 414853 | spec | 414854 spec := builder pluggableButtonSpec new. 414855 spec model: self. 414856 spec action: [self fireButton]. 414857 widget := builder build: spec. 414858 queries := IdentitySet new. 414859 self fireButtonWidget. 414860 self assert: (queries includes: #fireButton).! ! 414861 414862!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 16:53'! 414863testButtonFiresMessage 414864 | spec | 414865 spec := builder pluggableButtonSpec new. 414866 spec model: self. 414867 spec action: (MessageSend receiver: self selector: #fireButton arguments: #()). 414868 widget := builder build: spec. 414869 queries := IdentitySet new. 414870 self fireButtonWidget. 414871 self assert: (queries includes: #fireButton).! ! 414872 414873!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 16:53'! 414874testButtonFiresSymbol 414875 | spec | 414876 spec := builder pluggableButtonSpec new. 414877 spec model: self. 414878 spec action: #fireButton. 414879 widget := builder build: spec. 414880 queries := IdentitySet new. 414881 self fireButtonWidget. 414882 self assert: (queries includes: #fireButton).! ! 414883 414884!ToolBuilderTests methodsFor: 'tests-button' stamp: 'cwp 7/14/2006 11:15'! 414885testButtonInitiallyDisabled 414886 | spec | 414887 spec := builder pluggableButtonSpec new. 414888 spec model: self. 414889 spec label: #getLabel. 414890 spec color: #getColor. 414891 spec state: #getState. 414892 spec enabled: #returnFalse. 414893 widget := builder build: spec. 414894 self deny: (self buttonWidgetEnabled)! ! 414895 414896!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 6/21/2005 10:57'! 414897testButtonInitiallyDisabledSelector 414898 | spec | 414899 spec := builder pluggableButtonSpec new. 414900 spec model: self. 414901 spec label: #getLabel. 414902 spec color: #getColor. 414903 spec state: #getState. 414904 spec enabled: #returnFalse. 414905 widget := builder build: spec. 414906 self deny: (self buttonWidgetEnabled)! ! 414907 414908!ToolBuilderTests methodsFor: 'tests-button' stamp: 'cwp 7/14/2006 11:18'! 414909testButtonInitiallyEnabled 414910 | spec | 414911 spec := builder pluggableButtonSpec new. 414912 spec model: self. 414913 spec label: #getLabel. 414914 spec color: #getColor. 414915 spec state: #getState. 414916 spec enabled: #returnTrue. 414917 widget := builder build: spec. 414918 self assert: (self buttonWidgetEnabled)! ! 414919 414920!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 6/21/2005 10:57'! 414921testButtonInitiallyEnabledSelector 414922 | spec | 414923 spec := builder pluggableButtonSpec new. 414924 spec model: self. 414925 spec label: #getLabel. 414926 spec color: #getColor. 414927 spec state: #getState. 414928 spec enabled: #returnTrue. 414929 widget := builder build: spec. 414930 self assert: (self buttonWidgetEnabled)! ! 414931 414932!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 7/14/2005 22:22'! 414933testButtonWidgetID 414934 self makeButton. 414935 self assert: (builder widgetAt: #button) == widget.! ! 414936 414937!ToolBuilderTests methodsFor: 'tests-button' stamp: 'AdrianLienhard 10/11/2009 14:48'! 414938testGetButtonColor 414939 self makeButton. 414940 queries := IdentitySet new. 414941 self changed: #getColor. 414942 self assert: (queries includes: #getColor). 414943 self assert: self widgetColor = self getColor. 414944 ! ! 414945 414946!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 14:57'! 414947testGetButtonEnabled 414948 self makeButton. 414949 queries := IdentitySet new. 414950 self changed: #getEnabled. 414951 self assert: (queries includes: #getEnabled).! ! 414952 414953!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 14:57'! 414954testGetButtonLabel 414955 self makeButton. 414956 queries := IdentitySet new. 414957 self changed: #getLabel. 414958 self assert: (queries includes: #getLabel).! ! 414959 414960!ToolBuilderTests methodsFor: 'tests-button' stamp: 'AdrianLienhard 10/11/2009 17:03'! 414961testGetButtonSideEffectFree 414962 self makeButton. 414963 queries := IdentitySet new. 414964 self changed: #testSignalWithNoDiscernableEffect. 414965 self assert: (queries copyWithout: #getState) isEmpty.! ! 414966 414967!ToolBuilderTests methodsFor: 'tests-button' stamp: 'ar 2/11/2005 14:57'! 414968testGetButtonState 414969 self makeButton. 414970 queries := IdentitySet new. 414971 self changed: #getState. 414972 self assert: (queries includes: #getState).! ! 414973 414974 414975!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 2/12/2005 02:35'! 414976makeInputField 414977 | spec | 414978 spec := self makeInputFieldSpec. 414979 widget := builder build: spec.! ! 414980 414981!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 7/14/2005 22:19'! 414982makeInputFieldSpec 414983 | spec | 414984 spec := builder pluggableInputFieldSpec new. 414985 spec name: #input. 414986 spec model: self. 414987 spec getText: #getText. 414988 spec selection: #getTextSelection. 414989 spec color: #getColor. 414990 "<-- the following cannot be tested very well -->" 414991 spec setText: #setText:. 414992 spec menu: #getMenu:. 414993 ^spec! ! 414994 414995!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 2/12/2005 02:35'! 414996testGetInputFieldColor 414997 self makeInputField. 414998 queries := IdentitySet new. 414999 self changed: #getColor. 415000 self assert: (queries includes: #getColor). 415001 self assert: self widgetColor = self getColor.! ! 415002 415003!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 2/12/2005 02:35'! 415004testGetInputFieldSelection 415005 self makeInputField. 415006 queries := IdentitySet new. 415007 self changed: #getTextSelection. 415008 self assert: (queries includes: #getTextSelection).! ! 415009 415010!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 2/12/2005 02:35'! 415011testGetInputFieldSideEffectFree 415012 self makeInputField. 415013 queries := IdentitySet new. 415014 self changed: #testSignalWithNoDiscernableEffect. 415015 self assert: queries isEmpty.! ! 415016 415017!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 2/12/2005 02:35'! 415018testGetInputFieldText 415019 self makeInputField. 415020 queries := IdentitySet new. 415021 self changed: #getText. 415022 self assert: (queries includes: #getText).! ! 415023 415024!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 7/14/2005 22:19'! 415025testInputWidgetID 415026 self makeInputField. 415027 self assert: (builder widgetAt: #input) == widget.! ! 415028 415029!ToolBuilderTests methodsFor: 'tests-input' stamp: 'ar 2/12/2005 02:35'! 415030testSetInputField 415031 self makeInputField. 415032 queries := IdentitySet new. 415033 self acceptWidgetText. 415034 self assert: (queries includes: #setText).! ! 415035 415036 415037!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:54'! 415038getList 415039 queries add: #getList. 415040 ^(1 to: 100) collect:[:i| i printString].! ! 415041 415042!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:54'! 415043getListIndex 415044 queries add: #getListIndex. 415045 ^13! ! 415046 415047!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:54'! 415048getListSelection 415049 queries add: #getListSelection. 415050 ^'55'! ! 415051 415052!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/12/2005 02:44'! 415053getMenu: aMenu 415054 queries add: #getMenu. 415055 ^aMenu! ! 415056 415057!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/12/2005 02:45'! 415058keyPress: key 415059 queries add: #keyPress.! ! 415060 415061!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/10/2005 22:35'! 415062makeItemList 415063 | spec | 415064 spec := self makeItemListSpec. 415065 widget := builder build: spec.! ! 415066 415067!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 7/14/2005 22:17'! 415068makeItemListSpec 415069 | spec | 415070 spec := builder pluggableListSpec new. 415071 spec name: #list. 415072 spec model: self. 415073 spec list: #getList. 415074 spec getSelected: #getListSelection. 415075 "<-- the following cannot be tested very well -->" 415076 spec setSelected: #setListSelection:. 415077 spec menu: #getMenu:. 415078 spec keyPress: #keyPress:. 415079 ^spec! ! 415080 415081!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/10/2005 21:03'! 415082makeList 415083 | spec | 415084 spec := self makeListSpec. 415085 widget := builder build: spec.! ! 415086 415087!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 7/14/2005 22:18'! 415088makeListSpec 415089 | spec | 415090 spec := builder pluggableListSpec new. 415091 spec name: #list. 415092 spec model: self. 415093 spec list: #getList. 415094 spec getIndex: #getListIndex. 415095 "<-- the following cannot be tested very well -->" 415096 spec setIndex: #setListIndex:. 415097 spec menu: #getMenu:. 415098 spec keyPress: #keyPress:. 415099 ^spec! ! 415100 415101!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 19:18'! 415102setListIndex: index 415103 queries add: #setListIndex.! ! 415104 415105!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:54'! 415106setListSelection: newIndex 415107 queries add: #setListSelection.! ! 415108 415109!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:56'! 415110testGetItemListSideEffectFree 415111 self makeItemList. 415112 queries := IdentitySet new. 415113 self changed: #testSignalWithNoDiscernableEffect. 415114 self assert: queries isEmpty.! ! 415115 415116!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:56'! 415117testGetList 415118 self makeList. 415119 queries := IdentitySet new. 415120 self changed: #getList. 415121 self assert: (queries includes: #getList).! ! 415122 415123!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:57'! 415124testGetListIndex 415125 self makeList. 415126 queries := IdentitySet new. 415127 self changed: #getListIndex. 415128 self assert: (queries includes: #getListIndex).! ! 415129 415130!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:57'! 415131testGetListSelection 415132 self makeItemList. 415133 queries := IdentitySet new. 415134 self changed: #getListSelection. 415135 self assert: (queries includes: #getListSelection).! ! 415136 415137!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 14:57'! 415138testGetListSideEffectFree 415139 self makeList. 415140 queries := IdentitySet new. 415141 self changed: #testSignalWithNoDiscernableEffect. 415142 self assert: queries isEmpty.! ! 415143 415144!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 7/14/2005 22:18'! 415145testItemListWidgetID 415146 self makeItemList. 415147 self assert: (builder widgetAt: #list) == widget.! ! 415148 415149!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 7/14/2005 22:18'! 415150testListWidgetID 415151 self makeList. 415152 self assert: (builder widgetAt: #list) == widget.! ! 415153 415154!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 19:19'! 415155testSetListIndex 415156 self makeList. 415157 queries := IdentitySet new. 415158 self changeListWidget. 415159 self assert: (queries includes: #setListIndex).! ! 415160 415161!ToolBuilderTests methodsFor: 'tests-lists' stamp: 'ar 2/11/2005 19:19'! 415162testSetListSelection 415163 self makeItemList. 415164 queries := IdentitySet new. 415165 self changeListWidget. 415166 self assert: (queries includes: #setListSelection).! ! 415167 415168 415169!ToolBuilderTests methodsFor: 'tests-menus' stamp: 'cwp 6/9/2005 08:25'! 415170assertItemFiresWith: aBlock 415171 | spec | 415172 spec := builder pluggableMenuSpec new. 415173 spec model: self. 415174 aBlock value: spec. 415175 widget := builder build: spec. 415176 queries := IdentitySet new. 415177 self fireMenuItemWidget. 415178 self assert: (queries includes: #fireMenuAction)! ! 415179 415180!ToolBuilderTests methodsFor: 'tests-menus' stamp: 'cwp 6/8/2005 23:25'! 415181fireMenuAction 415182 queries add: #fireMenuAction! ! 415183 415184!ToolBuilderTests methodsFor: 'tests-menus' stamp: 'cwp 6/9/2005 00:08'! 415185fireMenuItemWidget 415186 self subclassResponsibility! ! 415187 415188!ToolBuilderTests methodsFor: 'tests-menus' stamp: 'cwp 6/9/2005 08:28'! 415189testAddTargetSelectorArgumentList 415190 self assertItemFiresWith: 415191 [:spec | spec 415192 add: 'Menu Item' 415193 target: self 415194 selector: #fireMenuAction 415195 argumentList: #()]! ! 415196 415197 415198!ToolBuilderTests methodsFor: 'tests-panel' stamp: 'ar 2/11/2005 14:54'! 415199getChildren 415200 queries add: #getChildren. 415201 ^#()! ! 415202 415203!ToolBuilderTests methodsFor: 'tests-panel' stamp: 'ar 2/10/2005 21:03'! 415204makePanel 415205 | spec | 415206 spec := self makePanelSpec. 415207 widget := builder build: spec.! ! 415208 415209!ToolBuilderTests methodsFor: 'tests-panel' stamp: 'ar 7/14/2005 22:15'! 415210makePanelSpec 415211 | spec | 415212 spec := builder pluggablePanelSpec new. 415213 spec name: #panel. 415214 spec model: self. 415215 spec children: #getChildren. 415216 ^spec! ! 415217 415218!ToolBuilderTests methodsFor: 'tests-panel' stamp: 'ar 2/11/2005 14:56'! 415219testGetPanelChildren 415220 self makePanel. 415221 queries := IdentitySet new. 415222 self changed: #getChildren. 415223 self assert: (queries includes: #getChildren).! ! 415224 415225!ToolBuilderTests methodsFor: 'tests-panel' stamp: 'ar 2/11/2005 14:56'! 415226testGetPanelSideEffectFree 415227 self makePanel. 415228 queries := IdentitySet new. 415229 self changed: #testSignalWithNoDiscernableEffect. 415230 self assert: queries isEmpty.! ! 415231 415232!ToolBuilderTests methodsFor: 'tests-panel' stamp: 'ar 7/14/2005 22:22'! 415233testPanelWidgetID 415234 self makePanel. 415235 self assert: (builder widgetAt: #panel) == widget.! ! 415236 415237 415238!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 21:41'! 415239getColor 415240 queries add: #getColor. 415241 ^Color tan! ! 415242 415243!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 14:53'! 415244getText 415245 queries add: #getText. 415246 ^Text new! ! 415247 415248!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 14:54'! 415249getTextSelection 415250 queries add: #getTextSelection. 415251 ^(1 to: 0)! ! 415252 415253!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/10/2005 21:03'! 415254makeText 415255 | spec | 415256 spec := self makeTextSpec. 415257 widget := builder build: spec.! ! 415258 415259!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 7/14/2005 22:17'! 415260makeTextSpec 415261 | spec | 415262 spec := builder pluggableTextSpec new. 415263 spec name: #text. 415264 spec model: self. 415265 spec getText: #getText. 415266 spec selection: #getTextSelection. 415267 spec color: #getColor. 415268 "<-- the following cannot be tested very well -->" 415269 spec setText: #setText:. 415270 spec menu: #getMenu:. 415271 ^spec! ! 415272 415273!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 19:29'! 415274setText: newText 415275 queries add: #setText. 415276 ^false! ! 415277 415278!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 21:41'! 415279testGetText 415280 self makeText. 415281 queries := IdentitySet new. 415282 self changed: #getText. 415283 self assert: (queries includes: #getText).! ! 415284 415285!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 21:41'! 415286testGetTextColor 415287 self makeText. 415288 queries := IdentitySet new. 415289 self changed: #getColor. 415290 self assert: (queries includes: #getColor). 415291 self assert: self widgetColor = self getColor.! ! 415292 415293!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 14:56'! 415294testGetTextSelection 415295 self makeText. 415296 queries := IdentitySet new. 415297 self changed: #getTextSelection. 415298 self assert: (queries includes: #getTextSelection).! ! 415299 415300!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 14:57'! 415301testGetTextSideEffectFree 415302 self makeText. 415303 queries := IdentitySet new. 415304 self changed: #testSignalWithNoDiscernableEffect. 415305 self assert: queries isEmpty.! ! 415306 415307!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 2/11/2005 19:23'! 415308testSetText 415309 self makeText. 415310 queries := IdentitySet new. 415311 self acceptWidgetText. 415312 self assert: (queries includes: #setText).! ! 415313 415314!ToolBuilderTests methodsFor: 'tests-text' stamp: 'ar 7/14/2005 22:17'! 415315testTextWidgetID 415316 self makeText. 415317 self assert: (builder widgetAt: #text) == widget! ! 415318 415319 415320!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:43'! 415321getChildrenOf: item 415322 queries add: #getChildrenOf. 415323 ^(1 to: 9) asArray! ! 415324 415325!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:44'! 415326getHelpOf: item 415327 ^'help'! ! 415328 415329!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:43'! 415330getIconOf: item 415331 queries add: #getIconOf. 415332 ^nil! ! 415333 415334!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:47'! 415335getLabelOf: item 415336 queries add: #getLabelOf. 415337 ^item asString! ! 415338 415339!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:41'! 415340getRoots 415341 queries add: #getRoots. 415342 ^(1 to: 9) asArray! ! 415343 415344!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 03:38'! 415345getTreeSelectionPath 415346 queries add: #getTreeSelectionPath. 415347 ^{2. 4. 3}! ! 415348 415349!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:43'! 415350hasChildren: item 415351 queries add: #hasChildren. 415352 ^true! ! 415353 415354!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 7/14/2005 22:15'! 415355makeTree 415356 | spec | 415357 spec := self makeTreeSpec. 415358 widget := builder build: spec.! ! 415359 415360!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 7/14/2005 22:15'! 415361makeTreeSpec 415362 | spec | 415363 spec := builder pluggableTreeSpec new. 415364 spec name: #tree. 415365 spec model: self. 415366 spec roots: #getRoots. 415367 "<-- the following cannot be tested very well -->" 415368 spec getSelectedPath: #getTreeSelectionPath. 415369 spec getChildren: #getChildrenOf:. 415370 spec hasChildren: #hasChildren:. 415371 spec label: #getLabelOf:. 415372 spec icon: #getIconOf:. 415373 spec help: #getHelpOf:. 415374 spec setSelected: #setTreeSelection:. 415375 spec menu: #getMenu:. 415376 spec keyPress: #keyPress:. 415377 ^spec! ! 415378 415379!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:44'! 415380setTreeSelection: node 415381 queries add: #setTreeSelection.! ! 415382 415383!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 03:51'! 415384testTreeExpandPath 415385 "@@@@: REMOVE THIS - it's a hack (changed: #openPath)" 415386 self makeTree. 415387 queries := IdentitySet new. 415388 self changed: {#openPath. '4'. '2'. '3'}. 415389 self waitTick. 415390 self assert: (queries includes: #getChildrenOf). 415391 self assert: (queries includes: #setTreeSelection). 415392 self assert: (queries includes: #getLabelOf). 415393! ! 415394 415395!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 03:51'! 415396testTreeExpandPathFirst 415397 "@@@@: REMOVE THIS - it's a hack (changed: #openPath)" 415398 self makeTree. 415399 queries := IdentitySet new. 415400 self changed: {#openPath. '1'. '2'. '2'}. 415401 self waitTick. 415402 self assert: (queries includes: #getChildrenOf). 415403 self assert: (queries includes: #setTreeSelection). 415404 self assert: (queries includes: #getLabelOf). 415405! ! 415406 415407!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 03:49'! 415408testTreeGetSelectionPath 415409 self makeTree. 415410 queries := IdentitySet new. 415411 self changed: #getTreeSelectionPath. 415412 self waitTick. 415413 self assert: (queries includes: #getTreeSelectionPath). 415414 self assert: (queries includes: #getChildrenOf). 415415 self assert: (queries includes: #setTreeSelection). 415416! ! 415417 415418!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 2/12/2005 02:48'! 415419testTreeRoots 415420 self makeTree. 415421 queries := IdentitySet new. 415422 self changed: #getRoots. 415423 self assert: (queries includes: #getRoots).! ! 415424 415425!ToolBuilderTests methodsFor: 'tests-trees' stamp: 'ar 7/14/2005 22:22'! 415426testTreeWidgetID 415427 self makeTree. 415428 self assert: (builder widgetAt: #tree) == widget.! ! 415429 415430 415431!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 2/10/2005 21:04'! 415432makeWindow 415433 | spec | 415434 spec := self makeWindowSpec. 415435 widget := builder build: spec.! ! 415436 415437!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 9/17/2005 21:02'! 415438makeWindowSpec 415439 | spec | 415440 spec := builder pluggableWindowSpec new. 415441 spec name: #window. 415442 spec model: self. 415443 spec children: #getChildren. 415444 spec label: #getLabel. 415445 spec closeAction: #noteWindowClosed. 415446 ^spec! ! 415447 415448!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 9/17/2005 21:02'! 415449noteWindowClosed 415450 queries add: #noteWindowClosed.! ! 415451 415452!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 9/17/2005 21:04'! 415453openWindow 415454 | spec | 415455 spec := self makeWindowSpec. 415456 widget := builder open: spec.! ! 415457 415458!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 2/11/2005 14:56'! 415459testGetWindowChildren 415460 self makeWindow. 415461 queries := IdentitySet new. 415462 self changed: #getChildren. 415463 self assert: (queries includes: #getChildren).! ! 415464 415465!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 2/11/2005 14:56'! 415466testGetWindowLabel 415467 self makeWindow. 415468 queries := IdentitySet new. 415469 self changed: #getLabel. 415470 self assert: (queries includes: #getLabel).! ! 415471 415472!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 2/11/2005 14:57'! 415473testGetWindowSideEffectFree 415474 self makeWindow. 415475 queries := IdentitySet new. 415476 self changed: #testSignalWithNoDiscernableEffect. 415477 self assert: queries isEmpty.! ! 415478 415479!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 9/17/2005 21:05'! 415480testWindowCloseAction 415481 self openWindow. 415482 builder close: widget. 415483 self assert: (queries includes: #noteWindowClosed).! ! 415484 415485!ToolBuilderTests methodsFor: 'tests-window' stamp: 'ar 7/14/2005 22:20'! 415486testWindowID 415487 self makeWindow. 415488 self assert: (builder widgetAt: #window) == widget.! ! 415489 415490"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 415491 415492ToolBuilderTests class 415493 instanceVariableNames: ''! 415494 415495!ToolBuilderTests class methodsFor: 'testing' stamp: 'ar 2/11/2005 14:36'! 415496isAbstract 415497 ^self == ToolBuilderTests! ! 415498DockingBarMorph subclass: #ToolDockingBarMorph 415499 instanceVariableNames: '' 415500 classVariableNames: '' 415501 poolDictionaries: '' 415502 category: 'Polymorph-Widgets'! 415503!ToolDockingBarMorph commentStamp: 'gvc 5/18/2007 10:20' prior: 0! 415504A non user-moveable docking bar that uses theme-based fill styles.! 415505 415506 415507!ToolDockingBarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/14/2007 13:28'! 415508gradientRamp 415509 "If not set answer based on orininal color." 415510 415511 ^self normalFillStyle colorRamp! ! 415512 415513!ToolDockingBarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 14:28'! 415514normalFillStyle 415515 "Return the normal fillStyle of the receiver." 415516 415517 ^self theme dockingBarNormalFillStyleFor: self! ! 415518 415519!ToolDockingBarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/14/2007 13:29'! 415520updateColor 415521 "private - update the receiver's color" 415522 415523 self autoGradient 415524 ifFalse: [^ self]. 415525 self fillStyle: self normalFillStyle! ! 415526 415527!ToolDockingBarMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/16/2006 14:27'! 415528wantsYellowButtonMenu 415529 "Answer true if the receiver wants a yellow button menu." 415530 415531 ^false! ! 415532AppRegistry subclass: #ToolSet 415533 instanceVariableNames: '' 415534 classVariableNames: '' 415535 poolDictionaries: '' 415536 category: 'System-Applications'! 415537!ToolSet commentStamp: 'ar 7/15/2005 17:58' prior: 0! 415538ToolSet defines an interface that clients can use to request programmer facilities such as browsers, inspectors, debuggers, message sets etc.! 415539 415540 415541"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 415542 415543ToolSet class 415544 instanceVariableNames: ''! 415545 415546!ToolSet class methodsFor: 'accessing' stamp: 'ar 7/17/2005 10:47'! 415547askForDefault 415548 "Ask for the default implementor" 415549 self registeredClasses isEmpty 415550 ifTrue:[^ default := nil]. 415551 self registeredClasses size = 1 415552 ifTrue:[^ default := self registeredClasses anyOne]. 415553 default := UIManager default 415554 chooseFrom: (self registeredClasses collect:[:each| each name printString]) 415555 values: self registeredClasses 415556 title: 'Which ', self appName, ' would you prefer?'. 415557 ^default.! ! 415558 415559 415560!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 10:54'! 415561browseChangeSetsWithClass: aClass selector: aSelector 415562 "Browse all the change sets with the given class/selector" 415563 self default ifNil:[^self inform: 'No ChangeSorter present']. 415564 ^self default browseChangeSetsWithClass: aClass selector: aSelector! ! 415565 415566!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 11:14'! 415567browseHierarchy: aClass selector: aSelector 415568 "Open a browser" 415569 self default ifNil:[^self inform: 'No browser present']. 415570 ^self default browseHierarchy: aClass selector: aSelector! ! 415571 415572!ToolSet class methodsFor: 'browsing' stamp: 'davidroethlisberger 2/11/2009 12:06'! 415573browseImplementorsOf: aSymbol name: titleString autoSelect: autoSelectString 415574 "Open a implementors browser" 415575 self default ifNil:[^self inform: 'Cannot open ImplementorsBrowser']. 415576 ^self default browseImplementorsOf: aSymbol name: titleString autoSelect: autoSelectString! ! 415577 415578!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 11:12'! 415579browseMessageNames: aString 415580 "Open a MessageNames browser" 415581 self default ifNil:[^self inform: 'No MessageNames present']. 415582 ^self default browseMessageNames: aString! ! 415583 415584!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 11:13'! 415585browseMessageSet: messageList name: title autoSelect: autoSelectString 415586 "Open a message set browser" 415587 self default ifNil:[^self inform: 'Cannot open MessageSet']. 415588 ^self default browseMessageSet: messageList name: title autoSelect: autoSelectString! ! 415589 415590!ToolSet class methodsFor: 'browsing' stamp: 'davidroethlisberger 2/11/2009 12:06'! 415591browseSendersOf: aSymbol name: titleString autoSelect: autoSelectString 415592 "Open a senders browser" 415593 self default ifNil:[^self inform: 'Cannot open SendersBrowser']. 415594 ^self default browseSendersOf: aSymbol name: titleString autoSelect: autoSelectString! ! 415595 415596!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 10:54'! 415597browseVersionsOf: aClass selector: aSelector 415598 "Open a browser" 415599 self default ifNil:[^self inform: 'Cannot open Browser']. 415600 ^self default browseVersionsOf: aClass selector: aSelector! ! 415601 415602!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 10:54'! 415603browse: aClass selector: aSelector 415604 "Open a browser" 415605 self default ifNil:[^self inform: 'Cannot open Browser']. 415606 ^self default browse: aClass selector: aSelector! ! 415607 415608!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 10:44'! 415609openChangedMessageSet: aChangeSet 415610 "Open a ChangedMessageSet for aChangeSet" 415611 self default ifNil:[^self inform: 'Cannot open MessageSet']. 415612 ^self default openChangedMessageSet: aChangeSet! ! 415613 415614!ToolSet class methodsFor: 'browsing' stamp: 'ar 7/17/2005 10:44'! 415615openClassListBrowser: anArray title: aString 415616 "Open a class list browser" 415617 self default ifNil:[^self inform: 'Cannot open ClassListBrowser']. 415618 ^self default openClassListBrowser: anArray title: aString! ! 415619 415620 415621!ToolSet class methodsFor: 'completion' stamp: 'damiencassou 7/29/2009 16:24'! 415622codeCompletionAround: aBlock textMorph: aTextMorph keyStroke: evt 415623 self default ifNil: [aBlock value. ^ self]. 415624 self default codeCompletionAround: aBlock textMorph: aTextMorph keyStroke: evt! ! 415625 415626 415627!ToolSet class methodsFor: 'debugging' stamp: 'ar 7/17/2005 10:37'! 415628debugContext: aContext label: aString contents: contents 415629 "Open a debugger on the given context." 415630 self default ifNil:[ 415631 (self confirm: 'Debugger request -- proceed?') 415632 ifFalse:[Processor terminateActive]. 415633 ^self]. 415634 ^self default debugContext: aContext label: aString contents: contents! ! 415635 415636!ToolSet class methodsFor: 'debugging' stamp: 'adrian_lienhard 7/18/2009 16:03'! 415637debugError: anError 415638 "Handle an otherwise unhandled error" 415639 self default ifNil:[ | ctx | 415640 Smalltalk 415641 logError: anError description 415642 inContext: (ctx := anError signalerContext) 415643 to: 'PharoDebug.log'. 415644 self inform: (anError description, String cr, ctx shortStack). 415645 ^anError return]. 415646 ^self default debugError: anError! ! 415647 415648!ToolSet class methodsFor: 'debugging' stamp: 'ar 9/27/2005 19:12'! 415649debugSyntaxError: anError 415650 "Handle a syntax error" 415651 self default ifNil:[^self debugError: anError]. "handle as usual error" 415652 ^self default debugSyntaxError: anError! ! 415653 415654!ToolSet class methodsFor: 'debugging' stamp: 'ar 7/17/2005 10:37'! 415655debug: aProcess context: aContext label: aString contents: contents fullView: aBool 415656 "Open a debugger on the given process and context." 415657 self default ifNil:[ 415658 (self confirm: 'Debugger request -- proceed?') 415659 ifFalse:[Processor terminateActive]. 415660 ^self]. 415661 ^self default debug: aProcess context: aContext label: aString contents: contents fullView: aBool! ! 415662 415663!ToolSet class methodsFor: 'debugging' stamp: 'ar 7/17/2005 10:37'! 415664interrupt: aProcess label: aString 415665 "Open a debugger on the given process and context." 415666 self default ifNil:[ 415667 (self confirm: 'Debugger request -- proceed?') 415668 ifFalse:[aProcess terminate]. 415669 ^self]. 415670 ^self default interrupt: aProcess label: aString! ! 415671 415672 415673!ToolSet class methodsFor: 'inspecting' stamp: 'ar 7/17/2005 10:54'! 415674basicInspect: anObject 415675 "Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides." 415676 self default ifNil:[^self inform: 'Cannot inspect -- no Inspector present']. 415677 ^self default basicInspect: anObject! ! 415678 415679!ToolSet class methodsFor: 'inspecting' stamp: 'al 11/28/2005 20:32'! 415680explore: anObject 415681 "Open an explorer on the given object." 415682 self default ifNil:[^self inform: 'Cannot explore - no ToolSet present']. 415683 ^self default explore: anObject! ! 415684 415685!ToolSet class methodsFor: 'inspecting' stamp: 'ar 7/17/2005 10:43'! 415686inspectorClassOf: anObject 415687 "Answer the inspector class for the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides." 415688 self default ifNil:[^nil]. 415689 ^self default inspectorClassOf: anObject! ! 415690 415691!ToolSet class methodsFor: 'inspecting' stamp: 'ar 7/17/2005 10:55'! 415692inspect: anObject 415693 "Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides." 415694 self default ifNil:[^self inform: 'Cannot inspect - no ToolSet present']. 415695 ^self default inspect: anObject! ! 415696 415697!ToolSet class methodsFor: 'inspecting' stamp: 'ar 7/17/2005 10:55'! 415698inspect: anObject label: aString 415699 "Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides." 415700 self default ifNil:[^self inform: 'Cannot inspect - no ToolSet present']. 415701 ^self default inspect: anObject label: aString! ! 415702 415703 415704!ToolSet class methodsFor: 'menu' stamp: 'ar 7/17/2005 13:19'! 415705menuItems 415706 "Answer the menu items available for this tool set" 415707 self default ifNil:[^#()]. 415708 ^self default menuItems! ! 415709CornerGripMorph subclass: #TopLeftGripMorph 415710 instanceVariableNames: '' 415711 classVariableNames: '' 415712 poolDictionaries: '' 415713 category: 'Morphic-Windows'! 415714!TopLeftGripMorph commentStamp: 'jmv 1/29/2006 17:18' prior: 0! 415715I am the handle in the left top of windows used for resizing them.! 415716 415717 415718!TopLeftGripMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/12/2007 10:53'! 415719containsPoint: aPoint 415720 "Answer true only if on edges." 415721 415722 |w| 415723 ^(super containsPoint: aPoint) and: [ 415724 w := SystemWindow borderWidth. 415725 ((self bounds translateBy: w@w) 415726 containsPoint: aPoint) not]! ! 415727 415728 415729!TopLeftGripMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/13/2008 10:21'! 415730drawOn: aCanvas 415731 "Draw the grip on the given canvas." 415732 415733 | dotBounds alphaCanvas windowBorderWidth dotBounds2 | 415734 415735 self shouldDraw ifFalse: [^self]. 415736 415737 windowBorderWidth := SystemWindow borderWidth. 415738 alphaCanvas := aCanvas asAlphaBlendingCanvas: 0.7. 415739 "alphaCanvas 415740 frameRectangle: bounds color: Color blue." 415741 415742 dotBounds := self bounds. 415743 dotBounds2 := dotBounds right: (dotBounds left + windowBorderWidth). 415744 dotBounds2 := dotBounds2 bottom: (dotBounds2 top + windowBorderWidth). 415745 alphaCanvas 415746 fillRectangle: dotBounds2 415747 color: self handleColor. 415748 415749 dotBounds2 := dotBounds left: (dotBounds left + windowBorderWidth). 415750 dotBounds2 := dotBounds2 bottom: (dotBounds2 top + windowBorderWidth). 415751 alphaCanvas 415752 fillRectangle: dotBounds2 415753 color: self handleColor. 415754 415755 dotBounds2 := dotBounds2 left: (dotBounds2 left + 7). 415756 dotBounds2 := dotBounds2 right: (dotBounds2 right - 7). 415757 alphaCanvas 415758 fillRectangle: dotBounds2 415759 color: self dotColor. 415760 415761 dotBounds2 := dotBounds right: (dotBounds left + windowBorderWidth). 415762 dotBounds2 := dotBounds2 top: (dotBounds2 top + windowBorderWidth). 415763 alphaCanvas 415764 fillRectangle: dotBounds2 415765 color: self handleColor. 415766 415767 dotBounds2 := dotBounds2 top: (dotBounds2 top + 7). 415768 dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - 7). 415769 alphaCanvas 415770 fillRectangle: dotBounds2 415771 color: self dotColor! ! 415772 415773 415774!TopLeftGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:47'! 415775gripLayoutFrame 415776 ^ LayoutFrame 415777 fractions: (0 @ 0 corner: 0 @ 0) 415778 offsets: (0 @ -27 corner: self defaultWidth @ 0)! ! 415779 415780!TopLeftGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:52'! 415781resizeCursor 415782 415783 ^ Cursor resizeForEdge: #topLeft! ! 415784 415785 415786!TopLeftGripMorph methodsFor: 'target resize' stamp: 'jmv 1/29/2006 18:02'! 415787apply: delta 415788 | oldBounds | 415789 oldBounds := target bounds. 415790 target 415791 bounds: (oldBounds origin + delta corner: oldBounds corner)! ! 415792 415793!TopLeftGripMorph methodsFor: 'target resize' stamp: 'md 2/24/2006 22:44'! 415794ptName 415795 ^#topLeft! ! 415796CornerGripMorph subclass: #TopRightGripMorph 415797 instanceVariableNames: '' 415798 classVariableNames: '' 415799 poolDictionaries: '' 415800 category: 'Morphic-Windows'! 415801!TopRightGripMorph commentStamp: 'jmv 1/29/2006 17:18' prior: 0! 415802I am the handle in the right top of windows used for resizing them.! 415803 415804 415805!TopRightGripMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/12/2007 10:53'! 415806containsPoint: aPoint 415807 "Answer true only if on edges." 415808 415809 |w| 415810 ^(super containsPoint: aPoint) and: [ 415811 w := SystemWindow borderWidth. 415812 ((self bounds translateBy: w negated@w) 415813 containsPoint: aPoint) not]! ! 415814 415815 415816!TopRightGripMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 5/13/2008 10:21'! 415817drawOn: aCanvas 415818 "Draw the grip on the given canvas." 415819 415820 | dotBounds alphaCanvas windowBorderWidth dotBounds2 | 415821 415822 self shouldDraw ifFalse: [^self]. 415823 415824 windowBorderWidth := SystemWindow borderWidth. 415825 alphaCanvas := aCanvas asAlphaBlendingCanvas: 0.7. 415826 "alphaCanvas 415827 frameRectangle: bounds color: Color blue." 415828 415829 dotBounds := self bounds. 415830 dotBounds2 := dotBounds left: (dotBounds right - windowBorderWidth). 415831 dotBounds2 := dotBounds2 bottom: (dotBounds2 top + windowBorderWidth). 415832 alphaCanvas 415833 fillRectangle: dotBounds2 415834 color: self handleColor. 415835 415836 dotBounds2 := dotBounds right: (dotBounds right - windowBorderWidth). 415837 dotBounds2 := dotBounds2 bottom: (dotBounds2 top + windowBorderWidth). 415838 alphaCanvas 415839 fillRectangle: dotBounds2 415840 color: self handleColor. 415841 415842 dotBounds2 := dotBounds2 left: (dotBounds2 left + 7). 415843 dotBounds2 := dotBounds2 right: (dotBounds2 right - 7). 415844 alphaCanvas 415845 fillRectangle: dotBounds2 415846 color: self dotColor. 415847 415848 dotBounds2 := dotBounds left: (dotBounds right - windowBorderWidth). 415849 dotBounds2 := dotBounds2 top: (dotBounds2 top + windowBorderWidth). 415850 alphaCanvas 415851 fillRectangle: dotBounds2 415852 color: self handleColor. 415853 415854 dotBounds2 := dotBounds2 top: (dotBounds2 top + 7). 415855 dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - 7). 415856 alphaCanvas 415857 fillRectangle: dotBounds2 415858 color: self dotColor! ! 415859 415860 415861!TopRightGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:47'! 415862gripLayoutFrame 415863 ^ LayoutFrame 415864 fractions: (1 @ 0 corner: 1 @ 0) 415865 offsets: (0 - self defaultWidth @ -27 corner: 0 @ 0)! ! 415866 415867!TopRightGripMorph methodsFor: 'accessing' stamp: 'md 2/24/2006 22:44'! 415868ptName 415869 ^#topRight! ! 415870 415871!TopRightGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:52'! 415872resizeCursor 415873 415874 ^ Cursor resizeForEdge: #topRight! ! 415875 415876 415877!TopRightGripMorph methodsFor: 'target resize' stamp: 'jmv 1/29/2006 18:05'! 415878apply: delta 415879 | oldBounds | 415880 oldBounds := target bounds. 415881 target 415882 bounds: (oldBounds origin + (0@delta y) corner: oldBounds corner + (delta x @ 0))! ! 415883TraitDescription subclass: #Trait 415884 uses: TBehaviorCategorization 415885 instanceVariableNames: 'name environment classTrait category' 415886 classVariableNames: '' 415887 poolDictionaries: '' 415888 category: 'Traits-Kernel'! 415889!Trait commentStamp: '<historical>' prior: 0! 415890Each trait in the system is represented as an instance of me. Like Class, I concretize my superclass by providing instance variables for the name and the environment. Since traits do not define variables, I not provide facilities for pool variables. However, I declare an instance variable to hold the associated classtrait, which is an instance of the class ClassTrait. ! 415891 415892 415893!Trait methodsFor: '*monticello' stamp: 'al 3/26/2006 21:44'! 415894asClassDefinition 415895 ^ MCTraitDefinition 415896 name: self name 415897 traitComposition: self traitCompositionString 415898 category: self category 415899 comment: self organization classComment asString 415900 commentStamp: self organization commentStamp.! ! 415901 415902!Trait methodsFor: '*monticello' stamp: 'al 3/26/2006 21:45'! 415903classDefinitions 415904 | definitions | 415905 definitions := OrderedCollection with: self asClassDefinition. 415906 (self hasClassTrait 415907 and: [self classTrait hasTraitComposition] 415908 and: [self classTrait traitComposition isEmpty not]) 415909 ifTrue: [definitions add: self classTrait asMCDefinition]. 415910 ^definitions asArray! ! 415911 415912 415913!Trait methodsFor: 'accessing' stamp: 'al 3/18/2006 13:23'! 415914basicCategory 415915 ^category! ! 415916 415917!Trait methodsFor: 'accessing' stamp: 'al 3/18/2006 13:22'! 415918basicCategory: aSymbol 415919 category := aSymbol! ! 415920 415921!Trait methodsFor: 'accessing' stamp: 'al 7/17/2004 14:16'! 415922environment 415923 ^environment! ! 415924 415925!Trait methodsFor: 'accessing' stamp: 'al 7/17/2004 14:16'! 415926environment: anObject 415927 environment := anObject! ! 415928 415929!Trait methodsFor: 'accessing' stamp: 'al 7/17/2004 14:16'! 415930name 415931 ^name! ! 415932 415933!Trait methodsFor: 'accessing' stamp: 'al 7/17/2004 14:16'! 415934name: aSymbol 415935 name := aSymbol! ! 415936 415937!Trait methodsFor: 'accessing' stamp: 'dvf 9/6/2005 13:11'! 415938requirements 415939 ^self requiredSelectors! ! 415940 415941 415942!Trait methodsFor: 'accessing parallel hierarchy' stamp: 'al 7/17/2004 14:16'! 415943baseTrait 415944 ^self! ! 415945 415946!Trait methodsFor: 'accessing parallel hierarchy' stamp: 'al 7/17/2004 14:16'! 415947classTrait 415948 ^classTrait! ! 415949 415950!Trait methodsFor: 'accessing parallel hierarchy' stamp: 'al 7/17/2004 14:16'! 415951classTrait: aTrait 415952 "Assigns the class trait associated with the receiver." 415953 415954 self assert: aTrait isClassTrait. 415955 classTrait := aTrait! ! 415956 415957!Trait methodsFor: 'accessing parallel hierarchy' stamp: 'al 7/17/2004 14:16'! 415958hasClassTrait 415959 ^classTrait notNil! ! 415960 415961!Trait methodsFor: 'accessing parallel hierarchy' stamp: 'al 7/17/2004 14:16'! 415962isBaseTrait 415963 ^true! ! 415964 415965!Trait methodsFor: 'accessing parallel hierarchy' stamp: 'al 7/17/2004 14:16'! 415966isClassTrait 415967 ^false! ! 415968 415969 415970!Trait methodsFor: 'compiling' stamp: 'md 3/5/2006 23:47'! 415971binding 415972 415973 ^ Smalltalk associationAt: name ifAbsent: [nil -> self] 415974! ! 415975 415976!Trait methodsFor: 'compiling' stamp: 'eem 7/18/2008 18:05'! 415977variablesAndOffsetsDo: aBinaryBlock 415978 "This is the interface between the compiler and a class's instance or field names. The 415979 class should enumerate aBinaryBlock with the field definitions (with nil offsets) followed 415980 by the instance variable name strings and their integer offsets (1-relative). The order is 415981 important; names evaluated later will override the same names occurring earlier." 415982 415983 "Since Traits don't confer state there is nothing to do here."! ! 415984 415985 415986!Trait methodsFor: 'copying' stamp: 'dvf 8/30/2005 16:49'! 415987copy 415988 | newTrait | 415989 newTrait := self class basicNew initialize 415990 name: self name 415991 traitComposition: self traitComposition copyTraitExpression 415992 methodDict: self methodDict copy 415993 localSelectors: self localSelectors copy 415994 organization: self organization copy. 415995 415996 newTrait classTrait initializeFrom: self classTrait. 415997 ^newTrait! ! 415998 415999 416000!Trait methodsFor: 'filein/out' stamp: 'al 12/1/2005 16:29'! 416001fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex 416002 "This is just copied from Class.. the whole fileout is a mess." 416003 ^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! ! 416004 416005!Trait methodsFor: 'filein/out' stamp: 'al 12/1/2005 16:28'! 416006fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool 416007 "File a description of the receiver on aFileStream. If the boolean argument, 416008 moveSource, is true, then set the trailing bytes to the position of aFileStream and 416009 to fileIndex in order to indicate where to find the source code." 416010 416011 Transcript cr; show: name. 416012 super 416013 fileOutOn: aFileStream 416014 moveSource: moveSource 416015 toFile: fileIndex. 416016 self hasClassTrait ifTrue: [ 416017 aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr. 416018 self classTrait 416019 fileOutOn: aFileStream 416020 moveSource: moveSource 416021 toFile: fileIndex]! ! 416022 416023 416024!Trait methodsFor: 'initialization' stamp: 'al 7/17/2004 14:16'! 416025initialize 416026 super initialize. 416027 classTrait := ClassTrait for: self! ! 416028 416029!Trait methodsFor: 'initialization' stamp: 'al 7/17/2004 23:00'! 416030name: aString traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization 416031 416032 "Used by copy" 416033 416034 self name: aString. 416035 localSelectors := aSet. 416036 methodDict := aMethodDict. 416037 traitComposition := aComposition. 416038 self organization: aClassOrganization 416039 416040 ! ! 416041 416042!Trait methodsFor: 'initialization' stamp: 'al 7/29/2004 16:48'! 416043obsolete 416044 self name: ('AnObsolete' , self name) asSymbol. 416045 self hasClassTrait ifTrue: [ 416046 self classTrait obsolete]. 416047 super obsolete! ! 416048 416049!Trait methodsFor: 'initialization' stamp: 'al 7/17/2004 14:16'! 416050removeFromSystem 416051 self removeFromSystem: true! ! 416052 416053!Trait methodsFor: 'initialization' stamp: 'al 7/17/2004 14:16'! 416054removeFromSystem: logged 416055 self environment forgetClass: self logged: logged. 416056 self obsolete! ! 416057 416058 416059!Trait methodsFor: 'organization'! 416060category 416061 "Answer the system organization category for the receiver. First check whether the 416062 category name stored in the ivar is still correct and only if this fails look it up 416063 (latter is much more expensive)" 416064 416065 | result | 416066 self basicCategory ifNotNil: [ :symbol | 416067 ((SystemOrganization listAtCategoryNamed: symbol) includes: self name) 416068 ifTrue: [ ^symbol ] ]. 416069 self basicCategory: (result := SystemOrganization categoryOfElement: self name). 416070 ^result! ! 416071 416072!Trait methodsFor: 'organization'! 416073category: aString 416074 "Categorize the receiver under the system category, aString, removing it from 416075 any previous categorization." 416076 416077 | oldCategory | 416078 oldCategory := self basicCategory. 416079 aString isString 416080 ifTrue: [ 416081 self basicCategory: aString asSymbol. 416082 SystemOrganization classify: self name under: self basicCategory ] 416083 ifFalse: [self errorCategoryName]. 416084 SystemChangeNotifier uniqueInstance 416085 class: self recategorizedFrom: oldCategory to: self basicCategory! ! 416086 416087 416088!Trait methodsFor: 'testing' stamp: 'al 7/17/2004 14:16'! 416089isObsolete 416090 "Return true if the receiver is obsolete." 416091 ^(self environment at: name ifAbsent: [nil]) ~~ self! ! 416092 416093 416094!Trait methodsFor: 'private' stamp: 'al 7/17/2004 14:16'! 416095applyChangesOfNewTraitCompositionReplacing: oldComposition 416096 "Duplicated on Class" 416097 416098 | changedSelectors | 416099 changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. 416100 self classSide 416101 noteNewBaseTraitCompositionApplied: self traitComposition. 416102 ^ changedSelectors! ! 416103 416104!Trait methodsFor: 'private' stamp: 'al 7/17/2004 14:16'! 416105isValidTraitName: aSymbol 416106 ^(aSymbol isEmptyOrNil 416107 or: [aSymbol first isLetter not] 416108 or: [aSymbol anySatisfy: [:character | character isAlphaNumeric not]]) not! ! 416109 416110!Trait methodsFor: 'private' stamp: 'al 7/17/2004 14:16'! 416111rename: aString 416112 "The new name of the receiver is the argument, aString." 416113 416114 | newName | 416115 (newName := aString asSymbol) ~= self name 416116 ifFalse: [^ self]. 416117 (self environment includesKey: newName) 416118 ifTrue: [^ self error: newName , ' already exists']. 416119 (Undeclared includesKey: newName) 416120 ifTrue: [self inform: 'There are references to, ' , aString printString , ' 416121from Undeclared. Check them after this change.']. 416122 self environment renameClass: self as: newName. 416123 name := newName! ! 416124 416125!Trait methodsFor: 'private' stamp: 'al 7/17/2004 14:16'! 416126setName: aSymbol andRegisterInCategory: categorySymbol environment: aSystemDictionary 416127 (self isValidTraitName: aSymbol) ifFalse: [TraitException signal: 'Invalid trait name']. 416128 416129 (self environment == aSystemDictionary 416130 and: [self name = aSymbol 416131 and: [self category = categorySymbol]]) ifTrue: [^self]. 416132 416133 ((aSystemDictionary includes: aSymbol) and: [(aSystemDictionary at: aSymbol) ~~ self]) 416134 ifTrue: [TraitException signal: 'The name ''' , aSymbol , ''' is already used']. 416135 416136 (self environment notNil and: [self name notNil and: [self name ~= aSymbol]]) ifTrue: [ 416137 self environment renameClass: self as: aSymbol]. 416138 416139 self name: aSymbol. 416140 self environment: aSystemDictionary. 416141 self environment at: self name put: self. 416142 self environment organization classify: self name under: categorySymbol. 416143 ^ true! ! 416144 416145"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 416146 416147Trait class 416148 uses: TBehaviorCategorization classTrait 416149 instanceVariableNames: ''! 416150 416151!Trait class methodsFor: 'instance creation' stamp: 'al 12/7/2003 16:00'! 416152defaultEnvironment 416153 ^Smalltalk! ! 416154 416155!Trait class methodsFor: 'instance creation' stamp: 'md 3/3/2006 11:05'! 416156named: aSymbol uses: aTraitCompositionOrCollection category: aString 416157 | env | 416158 env := self environment. 416159 ^self 416160 named: aSymbol 416161 uses: aTraitCompositionOrCollection 416162 category: aString 416163 env: env! ! 416164 416165!Trait class methodsFor: 'instance creation' stamp: 'al 3/18/2006 13:48'! 416166named: aSymbol uses: aTraitCompositionOrCollection category: aString env: anEnvironment 416167 | trait oldTrait systemCategory | 416168 systemCategory := aString asSymbol. 416169 trait := anEnvironment 416170 at: aSymbol 416171 ifAbsent: [nil]. 416172 oldTrait := trait copy. 416173 trait := trait ifNil: [super new]. 416174 416175 (trait isKindOf: Trait) ifFalse: [ 416176 ^self error: trait name , ' is not a Trait']. 416177 trait 416178 setName: aSymbol 416179 andRegisterInCategory: systemCategory 416180 environment: anEnvironment. 416181 416182 trait setTraitComposition: aTraitCompositionOrCollection asTraitComposition. 416183 416184 "... notify interested clients ..." 416185 oldTrait isNil ifTrue: [ 416186 SystemChangeNotifier uniqueInstance classAdded: trait inCategory: systemCategory. 416187 ^ trait]. 416188 SystemChangeNotifier uniqueInstance traitDefinitionChangedFrom: oldTrait to: trait. 416189 systemCategory ~= oldTrait category 416190 ifTrue: [SystemChangeNotifier uniqueInstance class: trait recategorizedFrom: oldTrait category to: systemCategory]. 416191 416192 ^ trait! ! 416193 416194!Trait class methodsFor: 'instance creation' stamp: 'al 12/19/2003 15:03'! 416195new 416196 self shouldNotImplement! ! 416197 416198 416199!Trait class methodsFor: 'printing' stamp: 'al 2/9/2004 22:23'! 416200newTemplateIn: categoryString 416201 ^String streamContents: [:stream | 416202 stream 416203 nextPutAll: self name; 416204 nextPutAll: ' named: #NameOfTrait'; 416205 cr; tab; 416206 nextPutAll: 'uses: {}'; 416207 cr; tab; 416208 nextPutAll: 'category: '; 416209 nextPut: $'; 416210 nextPutAll: categoryString; 416211 nextPut: $' ]! ! 416212Trait named: #Trait1 416213 uses: {} 416214 category: 'Tests-Traits-MOP'! 416215 416216!Trait1 methodsFor: 'trait1 - c' stamp: 'stephane.ducasse 10/6/2008 21:25'! 416217c 416218 416219 ^ 'Trait1>>c'! ! 416220 416221!Trait1 methodsFor: 'trait1 - c' stamp: 'stephane.ducasse 10/7/2008 15:26'! 416222c1 416223 416224 ^ 'Trait1>>c1'! ! 416225 416226"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 416227 416228Trait1 classTrait 416229 uses: {}! 416230Trait named: #Trait2 416231 uses: {} 416232 category: 'Tests-Traits-MOP'! 416233 416234!Trait2 methodsFor: 'trait2 - c' stamp: 'stephane.ducasse 10/6/2008 22:35'! 416235c 416236 416237 ^ 'Trait2>>c'! ! 416238 416239!Trait2 methodsFor: 'trait2 - c' stamp: 'stephane.ducasse 10/7/2008 15:26'! 416240c2 416241 416242 ^ 'Trait2>>c2'! ! 416243 416244"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 416245 416246Trait2 classTrait 416247 uses: {}! 416248Trait named: #Trait3 416249 uses: Trait2 416250 category: 'Tests-Traits-MOP'! 416251 416252!Trait3 methodsFor: 'local' stamp: 'stephane.ducasse 10/7/2008 16:31'! 416253c 416254 416255 ^ 'Trait3>>c'! ! 416256 416257!Trait3 methodsFor: 'local' stamp: 'stephane.ducasse 10/7/2008 16:32'! 416258c3 416259 416260 ^ 'Trait3>>c3'! ! 416261 416262 416263!Trait3 methodsFor: 'trait2 - c'! 416264c2 416265 416266 ^ 'Trait2>>c2'! ! 416267 416268"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 416269 416270Trait3 classTrait 416271 uses: Trait2 classTrait! 416272TraitTransformation subclass: #TraitAlias 416273 instanceVariableNames: 'aliases' 416274 classVariableNames: 'AliasMethodCache' 416275 poolDictionaries: '' 416276 category: 'Traits-Composition'! 416277!TraitAlias commentStamp: '<historical>' prior: 0! 416278See comment of my superclass TraitTransformation.! 416279 416280 416281!TraitAlias methodsFor: 'accessing' stamp: 'al 3/12/2004 16:43'! 416282aliases 416283 "Collection of associations where key is the 416284 alias and value the original selector." 416285 416286 ^aliases! ! 416287 416288!TraitAlias methodsFor: 'accessing' stamp: 'al 3/17/2004 15:22'! 416289aliases: anArrayOfAssociations 416290 | newNames | 416291 newNames := (anArrayOfAssociations collect: [:each | each key]) asIdentitySet. 416292 newNames size < anArrayOfAssociations size ifTrue: [ 416293 TraitCompositionException signal: 'Cannot use the same alias name twice']. 416294 anArrayOfAssociations do: [:each | 416295 (newNames includes: each value) ifTrue: [ 416296 TraitCompositionException signal: 'Cannot define an alias for an alias']]. 416297 aliases := anArrayOfAssociations! ! 416298 416299 416300!TraitAlias methodsFor: 'composition' stamp: 'al 4/10/2004 23:51'! 416301removeAlias: aSymbol 416302 self aliases: (self aliases 416303 reject: [:each | each key = aSymbol])! ! 416304 416305!TraitAlias methodsFor: 'composition' stamp: 'al 3/3/2004 19:49'! 416306- anArrayOfSelectors 416307 ^TraitExclusion 416308 with: self 416309 exclusions: anArrayOfSelectors! ! 416310 416311 416312!TraitAlias methodsFor: 'copying' stamp: 'al 4/9/2004 21:27'! 416313copy 416314 ^super copy 416315 aliases: self aliases copy; 416316 yourself! ! 416317 416318!TraitAlias methodsFor: 'copying' stamp: 'dvf 8/25/2005 16:07'! 416319copyTraitExpression 416320 ^super copyTraitExpression 416321 aliases: self aliases deepCopy; 416322 yourself! ! 416323 416324 416325!TraitAlias methodsFor: 'enquiries' stamp: 'al 3/12/2004 17:10'! 416326aliasesForSelector: aSymbol 416327 | selectors | 416328 selectors := self aliases 416329 select: [:association | association value = aSymbol] 416330 thenCollect: [:association | association key]. 416331 ^(super aliasesForSelector: aSymbol) 416332 addAll: selectors; 416333 yourself 416334 ! ! 416335 416336!TraitAlias methodsFor: 'enquiries' stamp: 'al 7/13/2004 16:53'! 416337allAliasesDict 416338 | dict | 416339 dict := super allAliasesDict. 416340 self aliases do: [:assoc | 416341 dict at: assoc key put: assoc value]. 416342 ^dict! ! 416343 416344!TraitAlias methodsFor: 'enquiries' stamp: 'al 3/7/2004 23:26'! 416345allSelectors 416346 ^self subject allSelectors 416347 addAll: (self aliases collect: [:each | each key]) asSet; 416348 yourself! ! 416349 416350!TraitAlias methodsFor: 'enquiries' stamp: 'al 4/7/2004 21:16'! 416351collectMethodsFor: aSelector into: methodDescription 416352 | originalSelector association | 416353 self subject 416354 collectMethodsFor: aSelector 416355 into: methodDescription. 416356 association := self aliasNamed: aSelector ifAbsent: [nil]. 416357 association notNil ifTrue: [ 416358 originalSelector := association value. 416359 self subject 416360 collectMethodsFor: originalSelector 416361 into: methodDescription]! ! 416362 416363 416364!TraitAlias methodsFor: 'enumeration' stamp: 'al 4/7/2004 21:14'! 416365aliasNamed: aSymbol ifAbsent: aBlock 416366 ^self aliases 416367 detect: [:association | association key = aSymbol] 416368 ifNone: aBlock! ! 416369 416370 416371!TraitAlias methodsFor: 'printing' stamp: 'al 2/22/2004 21:45'! 416372printOn: aStream 416373 super printOn: aStream. 416374 aStream 416375 space; 416376 nextPut: $@; 416377 space; 416378 nextPut: ${. 416379 self aliases do: [:each | aStream print: each] 416380 separatedBy: [aStream nextPutAll: '. ']. 416381 aStream nextPut: $}! ! 416382 416383 416384!TraitAlias methodsFor: 'testing' stamp: 'al 4/10/2004 23:57'! 416385isEmpty 416386 ^self aliases isEmpty! ! 416387 416388"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 416389 416390TraitAlias class 416391 instanceVariableNames: ''! 416392 416393!TraitAlias class methodsFor: 'instance creation' stamp: 'al 3/17/2004 15:22'! 416394assertValidAliasDefinition: anArrayOfAssociations 416395 "Throw an exceptions if the alias definition is not valid. 416396 It is expected to be a collection of associations and 416397 the number of arguments of the alias selector has to 416398 be the same as the original selector." 416399 416400 ((anArrayOfAssociations isKindOf: Collection) and: [ 416401 anArrayOfAssociations allSatisfy: [:each | 416402 each isKindOf: Association]]) ifFalse: [ 416403 TraitCompositionException signal: 'Invalid alias definition: Not a collection of associations.']. 416404 416405 (anArrayOfAssociations allSatisfy: [:association | 416406 (association key numArgs = association value numArgs and: [ 416407 (association key numArgs = -1) not])]) ifFalse: [ 416408 TraitCompositionException signal: 'Invalid alias definition: Alias and original selector have to have the same number of arguments.']! ! 416409 416410!TraitAlias class methodsFor: 'instance creation' stamp: 'al 3/12/2004 16:24'! 416411with: aTraitComposition aliases: anArrayOfAssociations 416412 self assertValidAliasDefinition: anArrayOfAssociations. 416413 ^self new 416414 subject: aTraitComposition; 416415 aliases: anArrayOfAssociations; 416416 yourself! ! 416417Object subclass: #TraitBehavior 416418 uses: TPureBehavior @ {#pureRemoveSelector:->#removeSelector:. #pureAddSelectorSilently:withMethod:->#addSelectorSilently:withMethod:} 416419 instanceVariableNames: 'methodDict traitComposition localSelectors users' 416420 classVariableNames: '' 416421 poolDictionaries: '' 416422 category: 'Traits-Kernel'! 416423!TraitBehavior commentStamp: 'apb 3/2/2006 17:49' prior: 0! 416424I declare the instance variables methodDict, traitComposition and localSelectors that normally would be defined on PureBehavior (see class comment of PureBehavior). Furthermore I keep track of where I am used and I provide compatibility methods to make me useable in tools where originally a class was expected.! 416425 416426 416427!TraitBehavior methodsFor: '*tools-browser' stamp: 'al 2/4/2006 11:43'! 416428browse 416429 self systemNavigation browseClass: self! ! 416430 416431 416432!TraitBehavior methodsFor: '*traits'! 416433providedSelectors 416434 ^ProvidedSelectors current for: self! ! 416435 416436 416437!TraitBehavior methodsFor: 'accessing class hierarchy'! 416438withAllSubclassesDo: aBlock 416439 | temp | 416440 temp := self allSubclassesDo: aBlock. 416441 aBlock value: self! ! 416442 416443!TraitBehavior methodsFor: 'accessing class hierarchy'! 416444withAllSuperclasses 416445 "Answer an OrderedCollection of the receiver and the receiver's 416446 superclasses. The first element is the receiver, 416447 followed by its superclass; the last element is Object." 416448 416449 | temp | 416450 temp := self allSuperclasses. 416451 temp addFirst: self. 416452 ^ temp! ! 416453 416454 416455!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/20/2005 21:24'! 416456addSelectorSilently: selector withMethod: compiledMethod 416457 self pureAddSelectorSilently: selector withMethod: compiledMethod. 416458 self notifyUsersOfChangedSelector: selector.! ! 416459 416460!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/6/2004 12:24'! 416461allSelectors 416462 ^ self selectors! ! 416463 416464!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/6/2004 09:02'! 416465basicLocalSelectors 416466 "Direct accessor for the instance variable localSelectors. 416467 Since localSelectors is lazily initialized, this may 416468 return nil, which means that all selectors are local." 416469 416470 ^ localSelectors! ! 416471 416472!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'NS 3/30/2004 13:26'! 416473basicLocalSelectors: aSetOrNil 416474 localSelectors := aSetOrNil! ! 416475 416476!TraitBehavior methodsFor: 'accessing method dictionary'! 416477changeRecordsAt: selector 416478 "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." 416479 416480 "(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]" 416481 ^ChangeSet 416482 scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil]) 416483 class: self meta: self isMeta 416484 category: (self whichCategoryIncludesSelector: selector) 416485 selector: selector.! ! 416486 416487!TraitBehavior methodsFor: 'accessing method dictionary'! 416488classAndMethodFor: aSymbol do: binaryBlock ifAbsent: absentBlock 416489 "Looks up the selector aSymbol in this class/trait. If it is found, binaryBlock is evaluated 416490 with this class/trait and the associated method. Otherwise absentBlock is evaluated. 416491 Note that this implementation is very simple because PureBehavior does not know 416492 about inheritance (cf. implementation in Behavior)" 416493 416494 ^ binaryBlock value: self value: (self compiledMethodAt: aSymbol ifAbsent: [^ absentBlock value]).! ! 416495 416496!TraitBehavior methodsFor: 'accessing method dictionary'! 416497compiledMethodAt: selector 416498 "Answer the compiled method associated with the argument, selector (a 416499 Symbol), a message selector in the receiver's method dictionary. If the 416500 selector is not in the dictionary, create an error notification." 416501 416502 ^ self methodDict at: selector! ! 416503 416504!TraitBehavior methodsFor: 'accessing method dictionary'! 416505compiledMethodAt: selector ifAbsent: aBlock 416506 "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock" 416507 416508 ^ self methodDict at: selector ifAbsent: [aBlock value]! ! 416509 416510!TraitBehavior methodsFor: 'accessing method dictionary'! 416511compress 416512 "Compact the method dictionary of the receiver." 416513 416514 self methodDict rehash! ! 416515 416516!TraitBehavior methodsFor: 'accessing method dictionary'! 416517compressedSourceCodeAt: selector 416518 "(Paragraph compressedSourceCodeAt: #displayLines:affectedRectangle:) size 721 1921 416519 Paragraph selectors inject: 0 into: [:tot :sel | tot + (Paragraph compressedSourceCodeAt: sel) size] 13606 31450" 416520 | rawText parse | 416521 rawText := (self sourceCodeAt: selector) asString. 416522 parse := self compilerClass new parse: rawText in: self notifying: nil. 416523 ^ rawText compressWithTable: 416524 ((selector keywords , 416525 parse tempNames , 416526 self instVarNames , 416527 #(self super ifTrue: ifFalse:) , 416528 ((0 to: 7) collect: 416529 [:i | String streamContents: 416530 [:s | s cr. i timesRepeat: [s tab]]]) , 416531 (self compiledMethodAt: selector) literalStrings) 416532 asSortedCollection: [:a :b | a size > b size])! ! 416533 416534!TraitBehavior methodsFor: 'accessing method dictionary'! 416535deregisterLocalSelector: aSymbol 416536 self basicLocalSelectors notNil ifTrue: [ 416537 self basicLocalSelectors remove: aSymbol ifAbsent: []]! ! 416538 416539!TraitBehavior methodsFor: 'accessing method dictionary'! 416540firstCommentAt: selector 416541 "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote." 416542 416543 |someComments| 416544 someComments := self commentsAt: selector. 416545 ^someComments isEmpty ifTrue: [''] ifFalse: [someComments first] 416546 416547 416548"Behavior firstCommentAt: #firstCommentAt:"! ! 416549 416550!TraitBehavior methodsFor: 'accessing method dictionary'! 416551firstPrecodeCommentFor: selector 416552 "If there is a comment in the source code at the given selector that preceeds the body of the method, return it here, else return nil" 416553 416554 | parser source tree | 416555 "Behavior firstPrecodeCommentFor: #firstPrecodeCommentFor:" 416556 (#(Comment Definition Hierarchy) includes: selector) 416557 ifTrue: 416558 ["Not really a selector" 416559 ^ nil]. 416560 source := self sourceCodeAt: selector asSymbol ifAbsent: [^ nil]. 416561 parser := self parserClass new. 416562 tree := 416563 parser 416564 parse: source readStream 416565 class: self 416566 noPattern: false 416567 context: nil 416568 notifying: nil 416569 ifFail: [^ nil]. 416570 ^ (tree comment ifNil: [^ nil]) first! ! 416571 416572!TraitBehavior methodsFor: 'accessing method dictionary'! 416573"popeye" formalHeaderPartsFor: "olive oil" aSelector 416574 "RELAX!! The warning you may have just seen about possibly having a bad source file does not apply here, because this method *intends* to have its source code start with a comment. 416575 This method returns a collection giving the parts in the formal declaration for aSelector. This parse is in support of schemes in which adjutant properties of a method can be declared via special comments secreted in the formal header 416576 The result will have 416577 3 elements for a simple, argumentless selector. 416578 5 elements for a single-argument selector 416579 9 elements for a two-argument selector 416580 13 elements for a three-argument, selector 416581 etc... 416582 416583 The syntactic elements are: 416584 416585 1 comment preceding initial selector fragment 416586 416587 2 first selector fragment 416588 3 comment following first selector fragment (nil if selector has no arguments) 416589 416590 ---------------------- (ends here for, e.g., #copy) 416591 416592 4 first formal argument 416593 5 comment following first formal argument (nil if selector has only one argument) 416594 416595 ---------------------- (ends here for, e.g., #copyFrom:) 416596 416597 6 second keyword 416598 7 comment following second keyword 416599 8 second formal argument 416600 9 comment following second formal argument (nil if selector has only two arguments) 416601 416602 ---------------------- (ends here for, e.g., #copyFrom:to:) 416603 416604 Any nil element signifies an absent comment. 416605 NOTE: The comment following the final formal argument is *not* successfully retrieved by this method in its current form, though it can be obtained, if needed, by other means (e.g. calling #firstPrecodeCommentFor:). Thus, the *final* element in the structure returned by this method is always going to be nil." 416606 416607 ^ Scanner new scanMessageParts: (self methodHeaderFor: aSelector) 416608 416609" 416610 Behavior class formalHeaderPartsFor: #formalHeaderPartsFor: 416611" 416612 416613 416614 ! ! 416615 416616!TraitBehavior methodsFor: 'accessing method dictionary'! 416617formalParametersAt: aSelector 416618 "Return the names of the arguments used in this method." 416619 416620 | source parser message list params | 416621 source := self sourceCodeAt: aSelector ifAbsent: [^ #()]. "for now" 416622 (parser := self parserClass new) parseSelector: source. 416623 message := source copyFrom: 1 to: (parser endOfLastToken min: source size). 416624 list := message string findTokens: Character separators. 416625 params := OrderedCollection new. 416626 list withIndexDo: [:token :ind | ind even ifTrue: [params addLast: token]]. 416627 ^ params! ! 416628 416629!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'al 12/10/2003 10:02'! 416630lookupSelector: selector 416631 ^(self includesSelector: selector) 416632 ifTrue: [self compiledMethodAt: selector] 416633 ifFalse: [nil]! ! 416634 416635!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'NS 12/9/2003 10:51'! 416636methodDict 416637 ^ methodDict! ! 416638 416639!TraitBehavior methodsFor: 'accessing method dictionary'! 416640methodDictionary 416641 "Convenience" 416642 ^self methodDict! ! 416643 416644!TraitBehavior methodsFor: 'accessing method dictionary'! 416645methodDictionary: aDictionary 416646 self methodDict: aDictionary! ! 416647 416648!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'NS 12/9/2003 10:50'! 416649methodDict: aDictionary 416650 methodDict := aDictionary! ! 416651 416652!TraitBehavior methodsFor: 'accessing method dictionary'! 416653methodHeaderFor: selector 416654 "Answer the string corresponding to the method header for the given selector" 416655 416656 | sourceString parser | 416657 sourceString := self ultimateSourceCodeAt: selector ifAbsent: [self standardMethodHeaderFor: selector]. 416658 (parser := self parserClass new) parseSelector: sourceString. 416659 ^ sourceString asString copyFrom: 1 to: (parser endOfLastToken min: sourceString size) 416660 416661 "Behavior methodHeaderFor: #methodHeaderFor: " 416662! ! 416663 416664!TraitBehavior methodsFor: 'accessing method dictionary'! 416665methodsDo: aBlock 416666 "Evaluate aBlock for all the compiled methods in my method dictionary." 416667 416668 ^ self methodDict valuesDo: aBlock! ! 416669 416670!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'al 7/17/2004 14:31'! 416671precodeCommentOrInheritedCommentFor: aSelector 416672 ^self firstPrecodeCommentFor: aSelector 416673 ! ! 416674 416675!TraitBehavior methodsFor: 'accessing method dictionary'! 416676registerLocalSelector: aSymbol 416677 self basicLocalSelectors notNil ifTrue: [ 416678 self basicLocalSelectors add: aSymbol]! ! 416679 416680!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'al 9/20/2005 21:24'! 416681removeSelector: selector 416682 self pureRemoveSelector: selector. 416683 self notifyUsersOfChangedSelector: selector.! ! 416684 416685!TraitBehavior methodsFor: 'accessing method dictionary'! 416686selectors 416687 "Answer a Set of all the message selectors specified in the receiver's 416688 method dictionary." 416689 416690 ^ self methodDict keys! ! 416691 416692!TraitBehavior methodsFor: 'accessing method dictionary'! 416693selectorsAndMethodsDo: aBlock 416694 "Evaluate selectorBlock for all the message selectors in my method dictionary." 416695 416696 ^ self methodDict keysAndValuesDo: aBlock! ! 416697 416698!TraitBehavior methodsFor: 'accessing method dictionary'! 416699selectorsDo: selectorBlock 416700 "Evaluate selectorBlock for all the message selectors in my method dictionary." 416701 416702 ^ self methodDict keysDo: selectorBlock! ! 416703 416704!TraitBehavior methodsFor: 'accessing method dictionary'! 416705selectorsWithArgs: numberOfArgs 416706 "Return all selectors defined in this class that take this number of arguments. Could use String.keywords. Could see how compiler does this." 416707 416708 | list num | 416709 list := OrderedCollection new. 416710 self selectorsDo: [:aSel | 416711 num := aSel count: [:char | char == $:]. 416712 num = 0 ifTrue: [aSel last isLetter ifFalse: [num := 1]]. 416713 num = numberOfArgs ifTrue: [list add: aSel]]. 416714 ^ list! ! 416715 416716!TraitBehavior methodsFor: 'accessing method dictionary'! 416717sourceCodeAt: selector 416718 416719 ^ (self methodDict at: selector) getSourceFor: selector in: self! ! 416720 416721!TraitBehavior methodsFor: 'accessing method dictionary'! 416722sourceCodeAt: selector ifAbsent: aBlock 416723 416724 ^ (self methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self! ! 416725 416726!TraitBehavior methodsFor: 'accessing method dictionary'! 416727sourceMethodAt: selector 416728 "Answer the paragraph corresponding to the source code for the 416729 argument." 416730 416731 ^(self sourceCodeAt: selector) asText makeSelectorBoldIn: self! ! 416732 416733!TraitBehavior methodsFor: 'accessing method dictionary'! 416734sourceMethodAt: selector ifAbsent: aBlock 416735 "Answer the paragraph corresponding to the source code for the 416736 argument." 416737 416738 ^ (self sourceCodeAt: selector ifAbsent: [^ aBlock value]) asText makeSelectorBoldIn: self! ! 416739 416740!TraitBehavior methodsFor: 'accessing method dictionary'! 416741standardMethodHeaderFor: aSelector 416742 | args | 416743 args := (1 to: aSelector numArgs) collect:[:i| 'arg', i printString]. 416744 args size = 0 ifTrue:[^aSelector asString]. 416745 args size = 1 ifTrue:[^aSelector,' arg1']. 416746 ^String streamContents:[:s| 416747 (aSelector findTokens:':') with: args do:[:tok :arg| 416748 s nextPutAll: tok; nextPutAll:': '; nextPutAll: arg; nextPutAll:' '. 416749 ]. 416750 ]. 416751! ! 416752 416753!TraitBehavior methodsFor: 'accessing method dictionary'! 416754ultimateSourceCodeAt: selector ifAbsent: aBlock 416755 "Return the source code at selector" 416756 416757 ^self 416758 sourceCodeAt: selector 416759 ifAbsent: aBlock! ! 416760 416761!TraitBehavior methodsFor: 'accessing method dictionary' stamp: 'al 2/8/2004 19:08'! 416762zapAllMethods 416763 "Remove all methods in this trait which is assumed to be obsolete" 416764 416765 methodDict := MethodDictionary new. 416766 self hasClassTrait ifTrue: [self classTrait zapAllMethods]! ! 416767 416768!TraitBehavior methodsFor: 'accessing method dictionary'! 416769>> selector 416770 "Answer the compiled method associated with the argument, selector (a 416771 Symbol), a message selector in the receiver's method dictionary. If the 416772 selector is not in the dictionary, create an error notification." 416773 416774 ^self compiledMethodAt: selector 416775! ! 416776 416777 416778!TraitBehavior methodsFor: 'adding/removing methods'! 416779addSelector: selector withMethod: compiledMethod 416780 ^ self addSelector: selector withMethod: compiledMethod notifying: nil! ! 416781 416782!TraitBehavior methodsFor: 'adding/removing methods'! 416783addSelector: selector withMethod: compiledMethod notifying: requestor 416784 ^ self addSelectorSilently: selector withMethod: compiledMethod! ! 416785 416786!TraitBehavior methodsFor: 'adding/removing methods'! 416787basicAddSelector: selector withMethod: compiledMethod 416788 "Add the message selector with the corresponding compiled method to the 416789 receiver's method dictionary. 416790 Do this without sending system change notifications" 416791 416792 | oldMethodOrNil | 416793 oldMethodOrNil := self lookupSelector: selector. 416794 self methodDict at: selector put: compiledMethod. 416795 compiledMethod methodClass: self. 416796 compiledMethod selector: selector. 416797 416798 "Now flush Squeak's method cache, either by selector or by method" 416799 oldMethodOrNil ifNotNil: [oldMethodOrNil flushCache]. 416800 selector flushCache.! ! 416801 416802!TraitBehavior methodsFor: 'adding/removing methods'! 416803basicRemoveSelector: selector 416804 "Assuming that the argument, selector (a Symbol), is a message selector 416805 in my method dictionary, remove it and its method." 416806 416807 | oldMethod | 416808 oldMethod := self methodDict at: selector ifAbsent: [^ self]. 416809 self methodDict removeKey: selector. 416810 416811 "Now flush Squeak's method cache, either by selector or by method" 416812 oldMethod flushCache. 416813 selector flushCache! ! 416814 416815!TraitBehavior methodsFor: 'adding/removing methods'! 416816localSelectors 416817 "Return a set of selectors defined locally. 416818 The instance variable is lazily initialized. If it is nil then there 416819 are no non-local selectors" 416820 416821 ^ self basicLocalSelectors isNil 416822 ifTrue: [self selectors] 416823 ifFalse: [self basicLocalSelectors].! ! 416824 416825!TraitBehavior methodsFor: 'adding/removing methods'! 416826methodDictAddSelectorSilently: selector withMethod: compiledMethod 416827 self basicAddSelector: selector withMethod: compiledMethod! ! 416828 416829!TraitBehavior methodsFor: 'adding/removing methods'! 416830pureAddSelectorSilently: selector withMethod: compiledMethod 416831 self methodDictAddSelectorSilently: selector withMethod: compiledMethod. 416832 self registerLocalSelector: selector! ! 416833 416834!TraitBehavior methodsFor: 'adding/removing methods'! 416835pureRemoveSelector: aSelector 416836 "Assuming that the argument, selector (a Symbol), is a message selector 416837 in my method dictionary, remove it and its method. 416838 416839 If the method to remove will be replaced by a method from my trait composition, 416840 the current method does not have to be removed because we mark it as non-local. 416841 If it is not identical to the actual method from the trait it will be replaced automatically 416842 by #noteChangedSelectors:. 416843 416844 This is useful to avoid bootstrapping problems when moving methods to a trait 416845 (e.g., from TPureBehavior to TMethodDictionaryBehavior). Manual moving (implementing 416846 the method in the trait and then remove it from the class) does not work if the methods 416847 themselves are used for this process (such as compiledMethodAt:, includesLocalSelector: or 416848 addTraitSelector:withMethod:)" 416849 416850 | changeFromLocalToTraitMethod | 416851 changeFromLocalToTraitMethod := (self includesLocalSelector: aSelector) 416852 and: [self hasTraitComposition] 416853 and: [self traitComposition includesMethod: aSelector]. 416854 416855 changeFromLocalToTraitMethod 416856 ifFalse: [self basicRemoveSelector: aSelector] 416857 ifTrue: [self ensureLocalSelectors]. 416858 self deregisterLocalSelector: aSelector. 416859 self noteChangedSelectors: (Array with: aSelector) 416860 416861! ! 416862 416863!TraitBehavior methodsFor: 'adding/removing methods'! 416864removeSelectorSilently: selector 416865 "Remove selector without sending system change notifications" 416866 416867 ^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].! ! 416868 416869 416870!TraitBehavior methodsFor: 'class compatibility' stamp: 'dc 5/8/2007 13:51'! 416871allClassVarNames 416872 ^#()! ! 416873 416874!TraitBehavior methodsFor: 'class compatibility' stamp: 'NS 4/12/2004 14:36'! 416875allInstVarNames 416876 ^ #()! ! 416877 416878!TraitBehavior methodsFor: 'class compatibility' stamp: 'dc 7/23/2007 11:13'! 416879allSubclasses 416880 ^ Array new! ! 416881 416882!TraitBehavior methodsFor: 'class compatibility' stamp: 'NS 4/12/2004 14:34'! 416883allSubclassesDo: aBlock! ! 416884 416885!TraitBehavior methodsFor: 'class compatibility' stamp: 'al 12/31/2005 13:41'! 416886allSuperclasses 416887 ^ OrderedCollection new! ! 416888 416889!TraitBehavior methodsFor: 'class compatibility' stamp: 'NS 4/12/2004 14:34'! 416890allSuperclassesDo: aBlock! ! 416891 416892!TraitBehavior methodsFor: 'class compatibility' stamp: 'dc 7/26/2007 16:51'! 416893classVarNames 416894 ^#()! ! 416895 416896!TraitBehavior methodsFor: 'class compatibility' stamp: 'al 7/29/2004 15:03'! 416897inheritsFrom: aClass 416898 "Used by RB" 416899 416900 ^false! ! 416901 416902!TraitBehavior methodsFor: 'class compatibility' stamp: 'NS 4/12/2004 14:33'! 416903instSize 416904 ^0! ! 416905 416906!TraitBehavior methodsFor: 'class compatibility' stamp: 'NS 4/12/2004 14:36'! 416907instVarNames 416908 ^#()! ! 416909 416910!TraitBehavior methodsFor: 'class compatibility' stamp: 'damiencassou 2/19/2009 15:09'! 416911poolDictionaryNames 416912 ^ #()! ! 416913 416914!TraitBehavior methodsFor: 'class compatibility' stamp: 'NS 4/12/2004 14:34'! 416915subclassDefinerClass 416916 ^nil subclassDefinerClass ! ! 416917 416918!TraitBehavior methodsFor: 'class compatibility' stamp: 'dc 7/23/2007 11:13'! 416919subclasses 416920 ^ Array new! ! 416921 416922!TraitBehavior methodsFor: 'class compatibility' stamp: 'al 7/17/2004 14:35'! 416923whichClassIncludesSelector: aSymbol 416924 "Traits compatibile implementation for: 416925 416926 Answer the class on the receiver's superclass chain where the 416927 argument, aSymbol (a message selector), will be found. Answer nil if none found." 416928 416929 ^(self includesSelector: aSymbol) 416930 ifTrue: [self] 416931 ifFalse: [nil]! ! 416932 416933!TraitBehavior methodsFor: 'class compatibility' stamp: 'damiencassou 3/13/2009 19:27'! 416934withAllSubclasses 416935 ^ Array with: self! ! 416936 416937 416938!TraitBehavior methodsFor: 'compiling'! 416939binding 416940 ^ nil -> self! ! 416941 416942!TraitBehavior methodsFor: 'compiling'! 416943bindingOf: varName 416944 416945 "Answer the binding of some variable resolved in the scope of the receiver" 416946 | aSymbol binding | 416947 aSymbol := varName asSymbol. 416948 416949 "Look in declared environment." 416950 binding := self environment bindingOf: aSymbol. 416951 ^binding! ! 416952 416953!TraitBehavior methodsFor: 'compiling'! 416954compileAll 416955 ^ self compileAllFrom: self! ! 416956 416957!TraitBehavior methodsFor: 'compiling'! 416958compileAllFrom: oldClass 416959 "Compile all the methods in the receiver's method dictionary. 416960 This validates sourceCode and variable references and forces 416961 all methods to use the current bytecode set" 416962 "ar 7/10/1999: Use oldClass selectors not self selectors" 416963 416964 oldClass selectorsDo: [:sel | self recompile: sel from: oldClass]. 416965 self environment currentProjectDo: [:proj | proj compileAllIsolated: self from: oldClass].! ! 416966 416967!TraitBehavior methodsFor: 'compiling'! 416968compilerClass 416969 "Answer a compiler class appropriate for source methods of this class." 416970 416971 ^Compiler! ! 416972 416973!TraitBehavior methodsFor: 'compiling'! 416974compile: code 416975 "Compile the argument, code, as source code in the context of the 416976 receiver. Create an error notification if the code can not be compiled. 416977 The argument is either a string or an object that converts to a string or a 416978 PositionableStream on an object that converts to a string." 416979 416980 ^self compile: code notifying: nil! ! 416981 416982!TraitBehavior methodsFor: 'compiling'! 416983compile: code classified: category notifying: requestor trailer: bytes ifFail: failBlock 416984 "Compile code without logging the source in the changes file" 416985 416986 | methodNode | 416987 methodNode := self compilerClass new 416988 compile: code 416989 in: self 416990 classified: category 416991 notifying: requestor 416992 ifFail: failBlock. 416993 ^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! ! 416994 416995!TraitBehavior methodsFor: 'compiling'! 416996compile: code notifying: requestor 416997 "Compile the argument, code, as source code in the context of the 416998 receiver and insEtall the result in the receiver's method dictionary. The 416999 second argument, requestor, is to be notified if an error occurs. The 417000 argument code is either a string or an object that converts to a string or 417001 a PositionableStream. This method also saves the source code." 417002 417003 | methodAndNode | 417004 methodAndNode := self 417005 compile: code "a Text" 417006 classified: nil 417007 notifying: requestor 417008 trailer: self defaultMethodTrailer 417009 ifFail: [^nil]. 417010 methodAndNode method putSource: code fromParseNode: methodAndNode node inFile: 2 417011 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr]. 417012 self addSelector: methodAndNode selector withMethod: methodAndNode method notifying: requestor. 417013 ^ methodAndNode selector! ! 417014 417015!TraitBehavior methodsFor: 'compiling'! 417016decompilerClass 417017 "Answer a decompiler class appropriate for compiled methods of this class." 417018 417019 ^ self compilerClass decompilerClass! ! 417020 417021!TraitBehavior methodsFor: 'compiling'! 417022decompile: selector 417023 "Find the compiled code associated with the argument, selector, as a 417024 message selector in the receiver's method dictionary and decompile it. 417025 Answer the resulting source code as a string. Create an error notification 417026 if the selector is not in the receiver's method dictionary." 417027 417028 ^self decompilerClass new decompile: selector in: self! ! 417029 417030!TraitBehavior methodsFor: 'compiling'! 417031defaultMethodTrailer 417032 ^ #(0 0 0 0)! ! 417033 417034!TraitBehavior methodsFor: 'compiling'! 417035evaluatorClass 417036 "Answer an evaluator class appropriate for evaluating expressions in the 417037 context of this class." 417038 417039 ^Compiler! ! 417040 417041!TraitBehavior methodsFor: 'compiling'! 417042parserClass 417043 "Answer a parser class to use for parsing method headers." 417044 417045 ^self compilerClass parserClass! ! 417046 417047!TraitBehavior methodsFor: 'compiling'! 417048recompileChanges 417049 "Compile all the methods that are in the changes file. 417050 This validates sourceCode and variable references and forces 417051 methods to use the current bytecode set" 417052 417053 self selectorsDo: 417054 [:sel | (self compiledMethodAt: sel) fileIndex > 1 ifTrue: 417055 [self recompile: sel from: self]]! ! 417056 417057!TraitBehavior methodsFor: 'compiling'! 417058recompileNonResidentMethod: method atSelector: selector from: oldClass 417059 "Recompile the method supplied in the context of this class." 417060 417061 | trailer methodNode | 417062 trailer := method trailer. 417063 methodNode := self compilerClass new 417064 compile: (method getSourceFor: selector in: oldClass) 417065 in: self 417066 notifying: nil 417067 ifFail: ["We're in deep doo-doo if this fails (syntax error). 417068 Presumably the user will correct something and proceed, 417069 thus installing the result in this methodDict. We must 417070 retrieve that new method, and restore the original (or remove) 417071 and then return the method we retrieved." 417072 ^ self error: 'see comment']. 417073 selector == methodNode selector ifFalse: [self error: 'selector changed!!']. 417074 ^ methodNode generate: trailer 417075! ! 417076 417077!TraitBehavior methodsFor: 'compiling'! 417078recompile: selector 417079 "Compile the method associated with selector in the receiver's method dictionary." 417080 ^self recompile: selector from: self! ! 417081 417082!TraitBehavior methodsFor: 'compiling' stamp: 'al 7/30/2004 22:03'! 417083recompile: selector from: oldClass 417084 "Compile the method associated with selector in the receiver's method dictionary." 417085 "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" 417086 | method trailer methodNode | 417087 method := oldClass compiledMethodAt: selector. 417088 trailer := method trailer. 417089 methodNode := self compilerClass new 417090 compile: (oldClass sourceCodeAt: selector) 417091 in: self 417092 notifying: nil 417093 ifFail: [^ self]. "Assume OK after proceed from SyntaxError" 417094 selector == methodNode selector ifFalse: [self error: 'selector changed!!']. 417095 self basicAddSelector: selector withMethod: (methodNode generate: trailer). 417096! ! 417097 417098!TraitBehavior methodsFor: 'compiling'! 417099sourceCodeTemplate 417100 "Answer an expression to be edited and evaluated in order to define 417101 methods in this class or trait." 417102 417103 ^'message selector and argument names 417104 "comment stating purpose of message" 417105 417106 | temporary variable names | 417107 statements'! ! 417108 417109 417110!TraitBehavior methodsFor: 'copying'! 417111copy 417112 "Answer a copy of the receiver without a list of subclasses." 417113 417114 | myCopy | 417115 myCopy := self shallowCopy. 417116 ^myCopy methodDictionary: self copyOfMethodDictionary! ! 417117 417118!TraitBehavior methodsFor: 'copying'! 417119copyOfMethodDictionary 417120 "Return a copy of the receiver's method dictionary" 417121 417122 ^ self methodDict copy! ! 417123 417124!TraitBehavior methodsFor: 'copying'! 417125deepCopy 417126 "Classes should only be shallowCopied or made anew." 417127 417128 ^ self shallowCopy! ! 417129 417130 417131!TraitBehavior methodsFor: 'initialization'! 417132emptyMethodDictionary 417133 417134 ^ MethodDictionary new! ! 417135 417136!TraitBehavior methodsFor: 'initialization'! 417137obsolete 417138 "Invalidate and recycle local methods, 417139 e.g., zap the method dictionary if can be done safely." 417140 self canZapMethodDictionary 417141 ifTrue: [self methodDict: self emptyMethodDictionary]. 417142 self hasTraitComposition ifTrue: [ 417143 self traitComposition traits do: [:each | 417144 each removeUser: self]]! ! 417145 417146 417147!TraitBehavior methodsFor: 'initialize-release' stamp: 'al 4/21/2004 21:56'! 417148forgetDoIts 417149 "get rid of old DoIt methods" 417150 self 417151 basicRemoveSelector: #DoIt; 417152 basicRemoveSelector: #DoItIn:! ! 417153 417154!TraitBehavior methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 11:14'! 417155initialize 417156 super initialize. 417157 self methodDict: MethodDictionary new. 417158 self traitComposition: nil. 417159 users := IdentitySet new.! ! 417160 417161 417162!TraitBehavior methodsFor: 'naming'! 417163environment 417164 "Return the environment in which the receiver is visible" 417165 ^Smalltalk! ! 417166 417167!TraitBehavior methodsFor: 'naming'! 417168name 417169 ^ self explicitRequirement! ! 417170 417171 417172!TraitBehavior methodsFor: 'newcompiler'! 417173parseScope 417174 417175 ^ Smalltalk at: #ClassScope ifPresent: [:class | class new class: self]! ! 417176 417177 417178!TraitBehavior methodsFor: 'printing'! 417179defaultNameStemForInstances 417180 "Answer a basis for external names for default instances of the receiver. 417181 For classees, the class-name itself is a good one." 417182 417183 ^ self name! ! 417184 417185!TraitBehavior methodsFor: 'printing'! 417186literalScannedAs: scannedLiteral notifying: requestor 417187 "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote). 417188 If scannedLiteral is not an association, answer it. 417189 Else, if it is of the form: 417190 nil->#NameOfMetaclass 417191 answer nil->theMetaclass, if any has that name, else report an error. 417192 Else, if it is of the form: 417193 #NameOfGlobalVariable->anythiEng 417194 answer the global, class, or pool association with that nameE, if any, else 417195 add it to Undeclared a answer the new Association." 417196 417197 | key value | 417198 (scannedLiteral isVariableBinding) 417199 ifFalse: [^ scannedLiteral]. 417200 key := scannedLiteral key. 417201 value := scannedLiteral value. 417202 key isNil 417203 ifTrue: "###<metaclass soleInstance name>" 417204 [(self bindingOf: value) ifNotNil:[:assoc| 417205 (assoc value isKindOf: Behavior) 417206 ifTrue: [^ nil->assoc value class]]. 417207 requestor notify: 'No such metaclass'. 417208 ^false]. 417209 (key isSymbol) 417210 ifTrue: "##<global var name>" 417211 [(self bindingOf: key) ifNotNil:[:assoc | ^assoc]. 417212 Undeclared at: key put: nil. 417213 ^Undeclared bindingOf: key]. 417214 requestor notify: '## must be followed by a non-local variable name'. 417215 ^false 417216 417217" Form literalScannedAs: 14 notifying: nil 14 417218 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm 417219 Form literalScannedAs: ##OneBitForm notifying: nil OneBitForm->a Form 417220 Form literalScannedAs: ##Form notifying: nil Form->Form 417221 Form literalScannedAs: ###Form notifying: nil nilE->Form class 417222"! ! 417223 417224!TraitBehavior methodsFor: 'printing'! 417225longPrintOn: aStream 417226 "Append to the argument, aStream, the names and values of all of the receiver's instance variables. But, not useful for a class with a method dictionary." 417227 417228 aStream nextPutAll: '<<too complex to show>>'; cr.! ! 417229 417230!TraitBehavior methodsFor: 'printing'! 417231prettyPrinterClass 417232 ^ PrettyPrinting prettyPrinterClassFor: self! ! 417233 417234!TraitBehavior methodsFor: 'printing'! 417235storeLiteral: aCodeLiteral on: aStream 417236 "Store aCodeLiteral on aStream, changing an Association to ##GlobalName 417237 or ###MetaclassSoleInstanceName format if appropriate" 417238 | key value | 417239 (aCodeLiteral isVariableBinding) 417240 ifFalse: 417241 [aCodeLiteral storeOn: aStream. 417242 ^self]. 417243 key := aCodeLiteral key. 417244 (key isNil and: [(value := aCodeLiteral value) isMemberOf: Metaclass]) 417245 ifTrue: 417246 [aStream nextPutAll: '###'; nextPutAll: value soleInstance name. 417247 ^self]. 417248 (key isSymbol and: [(self bindingOf: key) notNil]) 417249 ifTrue: 417250 [aStream nextPutAll: '##'; nextPutAll: key. 417251 ^self]. 417252 aCodeLiteral storeOn: aStream! ! 417253 417254 417255!TraitBehavior methodsFor: 'remove me later' stamp: 'apb 8/22/2005 15:28'! 417256classPool 417257 ^ Dictionary new! ! 417258 417259!TraitBehavior methodsFor: 'remove me later' stamp: 'apb 8/22/2005 15:29'! 417260sharedPools 417261 ^ Dictionary new! ! 417262 417263 417264!TraitBehavior methodsFor: 'send caches'! 417265clearSendCaches 417266 LocalSends current clearOut: self! ! 417267 417268!TraitBehavior methodsFor: 'send caches'! 417269hasRequiredSelectors 417270 ^ self requiredSelectors notEmpty! ! 417271 417272!TraitBehavior methodsFor: 'send caches' stamp: 'dvf 9/6/2005 14:12'! 417273requiredSelectors 417274 | sss selfSentNotProvided otherRequired | 417275 sss := self selfSentSelectorsFromSelectors: self allSelectors. 417276 selfSentNotProvided := sss copyWithoutAll: (self allSelectors select: [:e | (self >> e) isProvided]). 417277 otherRequired := self allSelectors select: [:e | (self >> e) isRequired]. 417278 ^(selfSentNotProvided, otherRequired) asSet 417279! ! 417280 417281!TraitBehavior methodsFor: 'send caches'! 417282requirements 417283 ^ self requiredSelectorsCache 417284 ifNil: [#()] 417285 ifNotNilDo: [:rsc | rsc requirements]! ! 417286 417287!TraitBehavior methodsFor: 'send caches' stamp: 'dvf 9/1/2005 16:40'! 417288sendCaches 417289 ^LocalSends current for: self! ! 417290 417291!TraitBehavior methodsFor: 'send caches'! 417292sendCaches: aSendCaches 417293 ^ self explicitRequirement! ! 417294 417295!TraitBehavior methodsFor: 'send caches'! 417296setRequiredStatusOf: selector to: aBoolean 417297 aBoolean 417298 ifTrue: [self requiredSelectorsCache addRequirement: selector] 417299 ifFalse: [self requiredSelectorsCache removeRequirement: selector].! ! 417300 417301!TraitBehavior methodsFor: 'send caches'! 417302superRequirements 417303 ^ self requiredSelectorsCache superRequirements! ! 417304 417305!TraitBehavior methodsFor: 'send caches' stamp: 'dvf 8/9/2005 17:22'! 417306updateRequires 417307 | sss aTrait | 417308 sss := self selfSentSelectorsInTrait: aTrait. 417309 ^sss copyWithoutAll: aTrait allSelectors.! ! 417310 417311 417312!TraitBehavior methodsFor: 'testing'! 417313canZapMethodDictionary 417314 "Return true if it is safe to zap the method dictionary on #obsolete" 417315 ^true! ! 417316 417317!TraitBehavior methodsFor: 'testing'! 417318includesBehavior: aBehavior 417319 ^self == aBehavior! ! 417320 417321!TraitBehavior methodsFor: 'testing' stamp: 'al 2/9/2004 22:29'! 417322isTrait 417323 ^true! ! 417324 417325 417326!TraitBehavior methodsFor: 'testing method dictionary'! 417327canUnderstand: selector 417328 "Answer whether the receiver can respond to the message whose selector 417329 is the argument." 417330 417331 ^ self classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false].! ! 417332 417333!TraitBehavior methodsFor: 'testing method dictionary'! 417334hasMethods 417335 "Answer whether the receiver has any methods in its method dictionary." 417336 417337 ^ self methodDict notEmpty! ! 417338 417339!TraitBehavior methodsFor: 'testing method dictionary'! 417340includesLocalSelector: aSymbol 417341 ^self basicLocalSelectors isNil 417342 ifTrue: [self includesSelector: aSymbol] 417343 ifFalse: [self localSelectors includes: aSymbol]! ! 417344 417345!TraitBehavior methodsFor: 'testing method dictionary'! 417346includesSelector: aSymbol 417347 "Answer whether the message whose selector is the argument is in the 417348 method dictionary of the receiver's class." 417349 417350 ^ self methodDict includesKey: aSymbol! ! 417351 417352!TraitBehavior methodsFor: 'testing method dictionary'! 417353isAliasSelector: aSymbol 417354 "Return true if the selector aSymbol is an alias defined 417355 in my or in another composition somewhere deeper in 417356 the tree of traits compositions." 417357 417358 ^(self includesLocalSelector: aSymbol) not 417359 and: [self hasTraitComposition] 417360 and: [self traitComposition isAliasSelector: aSymbol]! ! 417361 417362!TraitBehavior methodsFor: 'testing method dictionary'! 417363isDisabledSelector: selector 417364 ^ self classAndMethodFor: selector do: [:c :m | m isDisabled] ifAbsent: [false]! ! 417365 417366!TraitBehavior methodsFor: 'testing method dictionary'! 417367isLocalAliasSelector: aSymbol 417368 "Return true if the selector aSymbol is an alias defined 417369 in my trait composition." 417370 417371 ^(self includesLocalSelector: aSymbol) not 417372 and: [self hasTraitComposition] 417373 and: [self traitComposition isLocalAliasSelector: aSymbol]! ! 417374 417375!TraitBehavior methodsFor: 'testing method dictionary'! 417376isProvidedSelector: selector 417377 ^ ProvidedSelectors current isSelector: selector providedIn: self 417378! ! 417379 417380!TraitBehavior methodsFor: 'testing method dictionary' stamp: 'G.C 10/22/2008 09:59'! 417381thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte 417382 "Answer a set of selectors whose methods access the argument as a 417383 literal. Dives into the compact literal notation, making it slow but 417384 thorough " 417385 | selectors | 417386 selectors := IdentitySet new. 417387 self selectorsAndMethodsDo: 417388 [ :sel :method | 417389 ((method refersToLiteral: literal) or: [ specialFlag and: [ method scanFor: specialByte ] ]) ifTrue: [ selectors add: sel ] ]. 417390 ^ selectors! ! 417391 417392!TraitBehavior methodsFor: 'testing method dictionary'! 417393whichSelectorsReferTo: literal 417394 "Answer a Set of selectors whose methods access the argument as a 417395literal." 417396 417397 | special byte | 417398 special := self environment hasSpecialSelector: literal ifTrueSetByte: [:b | 417399byte := b]. 417400 ^self whichSelectorsReferTo: literal special: special byte: byte 417401 417402 "Rectangle whichSelectorsReferTo: #+."! ! 417403 417404!TraitBehavior methodsFor: 'testing method dictionary'! 417405whichSelectorsReferTo: literal special: specialFlag byte: specialByte 417406 "Answer a set of selectors whose methods access the argument as a literal." 417407 417408 | who | 417409 who := IdentitySet new. 417410 self selectorsAndMethodsDo: 417411 [:sel :method | 417412 ((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]]) 417413 ifTrue: 417414 [((literal isVariableBinding) not 417415 or: [method literals allButLast includes: literal]) 417416 ifTrue: [who add: sel]]]. 417417 ^ who! ! 417418 417419 417420!TraitBehavior methodsFor: 'traits'! 417421addExclusionOf: aSymbol to: aTrait 417422 self setTraitComposition: ( 417423 self traitComposition copyWithExclusionOf: aSymbol to: aTrait)! ! 417424 417425!TraitBehavior methodsFor: 'traits'! 417426addToComposition: aTrait 417427 self setTraitComposition: (self traitComposition copyTraitExpression 417428 add: aTrait; 417429 yourself)! ! 417430 417431!TraitBehavior methodsFor: 'traits'! 417432addTraitSelector: aSymbol withMethod: aCompiledMethod 417433 "Add aMethod with selector aSymbol to my 417434 methodDict. aMethod must not be defined locally." 417435 417436 | source methodAndNode | 417437 self assert: [(self includesLocalSelector: aSymbol) not]. 417438 self ensureLocalSelectors. 417439 417440 source := aCompiledMethod getSourceReplacingSelectorWith: aSymbol. 417441 methodAndNode := self 417442 compile: source 417443 classified: nil 417444 notifying: nil 417445 trailer: #(0 0 0 0) 417446 ifFail: [^nil]. 417447 methodAndNode method putSource: source fromParseNode: methodAndNode node inFile: 2 417448 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Trait method'; cr]. 417449 417450 self basicAddSelector: aSymbol withMethod: methodAndNode method! ! 417451 417452!TraitBehavior methodsFor: 'traits' stamp: 'NS 4/12/2004 14:16'! 417453addUser: aClassOrTrait 417454 users add: aClassOrTrait! ! 417455 417456!TraitBehavior methodsFor: 'traits'! 417457applyChangesOfNewTraitCompositionReplacing: oldComposition 417458 | changedSelectors | 417459 changedSelectors := self traitComposition 417460 changedSelectorsComparedTo: oldComposition. 417461 changedSelectors isEmpty ifFalse: [ 417462 self noteChangedSelectors: changedSelectors]. 417463 self traitComposition isEmpty ifTrue: [ 417464 self purgeLocalSelectors]. 417465 ^changedSelectors! ! 417466 417467!TraitBehavior methodsFor: 'traits' stamp: 'dvf 9/9/2005 19:39'! 417468classesComposedWithMe 417469 ^users gather: [:u | u classesComposedWithMe] 417470! ! 417471 417472!TraitBehavior methodsFor: 'traits'! 417473ensureLocalSelectors 417474 "Ensures that the instance variable localSelectors is effectively used to maintain 417475 the set of local selectors. 417476 This method must be called before any non-local selectors are added to the 417477 method dictionary!!" 417478 417479 self basicLocalSelectors isNil 417480 ifTrue: [self basicLocalSelectors: self selectors]! ! 417481 417482!TraitBehavior methodsFor: 'traits'! 417483flattenDown: aTrait 417484 | selectors | 417485 self assert: [self hasTraitComposition and: [self traitComposition allTraits includes: aTrait]]. 417486 selectors := (self traitComposition transformationOfTrait: aTrait) selectors. 417487 self basicLocalSelectors: self basicLocalSelectors , selectors. 417488 self removeFromComposition: aTrait.! ! 417489 417490!TraitBehavior methodsFor: 'traits'! 417491flattenDownAllTraits 417492 self traitComposition allTraits do: [:each | self flattenDown: each]. 417493 self assert: [ self traitComposition isEmpty ]. 417494 self traitComposition: nil.! ! 417495 417496!TraitBehavior methodsFor: 'traits' stamp: 'al 7/21/2004 20:57'! 417497hasTraitComposition 417498 ^traitComposition notNil! ! 417499 417500!TraitBehavior methodsFor: 'traits'! 417501noteChangedSelectors: aCollection 417502 "Start update of my methodDict (after changes to traits in traitComposition 417503 or after a local method was removed from my methodDict). The argument 417504 is a collection of method selectors that may have been changed. Most of the time 417505 aCollection only holds one selector. But when there are aliases involved 417506 there may be several method changes that have to be propagated to users." 417507 417508 | affectedSelectors | 417509 affectedSelectors := IdentitySet new. 417510 aCollection do: [:selector | 417511 affectedSelectors addAll: (self updateMethodDictionarySelector: selector)]. 417512 self notifyUsersOfChangedSelectors: affectedSelectors. 417513 ^ affectedSelectors! ! 417514 417515!TraitBehavior methodsFor: 'traits'! 417516notifyUsersOfChangedSelectors: aCollection! ! 417517 417518!TraitBehavior methodsFor: 'traits'! 417519notifyUsersOfChangedSelector: aSelector 417520 self notifyUsersOfChangedSelectors: (Array with: aSelector)! ! 417521 417522!TraitBehavior methodsFor: 'traits'! 417523purgeLocalSelectors 417524 self basicLocalSelectors: nil! ! 417525 417526!TraitBehavior methodsFor: 'traits'! 417527removeAlias: aSymbol of: aTrait 417528 self setTraitComposition: ( 417529 self traitComposition copyWithoutAlias: aSymbol of: aTrait)! ! 417530 417531!TraitBehavior methodsFor: 'traits'! 417532removeFromComposition: aTrait 417533 self setTraitComposition: (self traitComposition copyTraitExpression 417534 removeFromComposition: aTrait)! ! 417535 417536!TraitBehavior methodsFor: 'traits' stamp: 'al 4/20/2004 09:33'! 417537removeFromTraitCompositionOfUsers 417538 self users do: [:each | 417539 each removeFromComposition: self ]! ! 417540 417541!TraitBehavior methodsFor: 'traits'! 417542removeTraitSelector: aSymbol 417543 self assert: [(self includesLocalSelector: aSymbol) not]. 417544 self basicRemoveSelector: aSymbol! ! 417545 417546!TraitBehavior methodsFor: 'traits' stamp: 'NS 4/12/2004 14:17'! 417547removeUser: aClassOrTrait 417548 users remove: aClassOrTrait ifAbsent: []! ! 417549 417550!TraitBehavior methodsFor: 'traits'! 417551selfSentSelectorsFromSelectors: interestingSelectors 417552 | m result info | 417553 result := IdentitySet new. 417554 interestingSelectors collect: 417555 [:sel | 417556 m := self compiledMethodAt: sel ifAbsent: []. 417557 m ifNotNil: 417558 [info := (SendInfo on: m) collectSends. 417559 info selfSentSelectors do: [:sentSelector | result add: sentSelector]]]. 417560 ^result! ! 417561 417562!TraitBehavior methodsFor: 'traits'! 417563setTraitCompositionFrom: aTraitExpression 417564 ^ self setTraitComposition: aTraitExpression asTraitComposition! ! 417565 417566!TraitBehavior methodsFor: 'traits'! 417567setTraitComposition: aTraitComposition 417568 | oldComposition | 417569 (self hasTraitComposition not and: [aTraitComposition isEmpty]) ifTrue: [^self]. 417570 aTraitComposition assertValidUser: self. 417571 417572 oldComposition := self traitComposition. 417573 self traitComposition: aTraitComposition. 417574 self applyChangesOfNewTraitCompositionReplacing: oldComposition. 417575 417576 oldComposition traits do: [:each | each removeUser: self]. 417577 aTraitComposition traits do: [:each | each addUser: self]! ! 417578 417579!TraitBehavior methodsFor: 'traits' stamp: 'al 12/12/2003 21:42'! 417580traitComposition 417581 traitComposition ifNil: [traitComposition := TraitComposition new]. 417582 ^traitComposition! ! 417583 417584!TraitBehavior methodsFor: 'traits'! 417585traitCompositionIncludes: aTrait 417586 ^self == aTrait or: 417587 [self hasTraitComposition and: 417588 [self traitComposition allTraits includes: aTrait]]! ! 417589 417590!TraitBehavior methodsFor: 'traits'! 417591traitCompositionString 417592 ^self hasTraitComposition 417593 ifTrue: [self traitComposition asString] 417594 ifFalse: ['{}']! ! 417595 417596!TraitBehavior methodsFor: 'traits' stamp: 'NS 12/11/2003 16:35'! 417597traitComposition: aTraitComposition 417598 traitComposition := aTraitComposition! ! 417599 417600!TraitBehavior methodsFor: 'traits'! 417601traitOrClassOfSelector: aSymbol 417602 "Return the trait or the class which originally defines the method aSymbol 417603 or return self if locally defined or if it is a conflict marker method. 417604 This is primarly used by Debugger to determin the behavior in which a recompiled 417605 method should be put. If a conflict method is recompiled it should be put into 417606 the class, thus return self. Also see TraitComposition>>traitProvidingSelector:" 417607 417608 ((self includesLocalSelector: aSymbol) or: [ 417609 self hasTraitComposition not]) ifTrue: [^self]. 417610 ^(self traitComposition traitProvidingSelector: aSymbol) ifNil: [self]! ! 417611 417612!TraitBehavior methodsFor: 'traits'! 417613traits 417614 "Returns a collection of all traits used by the receiver" 417615 ^ self traitComposition traits! ! 417616 417617!TraitBehavior methodsFor: 'traits'! 417618traitsProvidingSelector: aSymbol 417619 | result | 417620 result := OrderedCollection new. 417621 self hasTraitComposition ifFalse: [^result]. 417622 (self traitComposition methodDescriptionsForSelector: aSymbol) 417623 do: [:methodDescription | methodDescription selector = aSymbol ifTrue: [ 417624 result addAll: (methodDescription locatedMethods 417625 collect: [:each | each location])]]. 417626 ^result! ! 417627 417628!TraitBehavior methodsFor: 'traits'! 417629traitTransformations 417630 ^ self traitComposition transformations ! ! 417631 417632!TraitBehavior methodsFor: 'traits'! 417633updateMethodDictionarySelector: aSymbol 417634 "A method with selector aSymbol in myself or my traitComposition has been changed. 417635 Do the appropriate update to my methodDict (remove or update method) and 417636 return all affected selectors of me so that my useres get notified." 417637 417638 | effectiveMethod modifiedSelectors descriptions selector | 417639 modifiedSelectors := IdentitySet new. 417640 descriptions := self hasTraitComposition 417641 ifTrue: [ self traitComposition methodDescriptionsForSelector: aSymbol ] 417642 ifFalse: [ #() ]. 417643 descriptions do: [:methodDescription | 417644 selector := methodDescription selector. 417645 (self includesLocalSelector: selector) ifFalse: [ 417646 methodDescription isEmpty 417647 ifTrue: [ 417648 self removeTraitSelector: selector. 417649 modifiedSelectors add: selector] 417650 ifFalse: [ 417651 effectiveMethod := methodDescription effectiveMethod. 417652 self addTraitSelector: selector withMethod: effectiveMethod. 417653 modifiedSelectors add: selector]]]. 417654 ^modifiedSelectors! ! 417655 417656!TraitBehavior methodsFor: 'traits' stamp: 'NS 4/12/2004 14:17'! 417657users 417658 ^users! ! 417659 417660 417661!TraitBehavior methodsFor: 'user interface'! 417662crossReference 417663 "Answer an Array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included." 417664 417665 ^self selectors asSortedCollection asArray collect: [:x | Array 417666 with: (String with: Character cr), x 417667 with: (self whichSelectorsReferTo: x)] 417668 417669 "Point crossReference."! ! 417670 417671 417672!TraitBehavior methodsFor: 'private'! 417673spaceUsed 417674 "Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables." 417675 417676 | space | 417677 space := 0. 417678 self selectorsDo: [:sel | | method | 417679 space := space + 16. "dict and org'n space" 417680 method := self compiledMethodAt: sel. 417681 space := space + (method size + 6 "hdr + avg pad"). 417682 method literalsDo: [:lit | 417683 (lit isMemberOf: Array) ifTrue: [space := space + ((lit size + 1) * 4)]. 417684 (lit isMemberOf: Float) ifTrue: [space := space + 12]. 417685 (lit isMemberOf: ByteString) ifTrue: [space := space + (lit size + 6)]. 417686 (lit isMemberOf: LargeNegativeInteger) ifTrue: [space := space + ((lit size + 1) * 4)]. 417687 (lit isMemberOf: LargePositiveInteger) ifTrue: [space := space + ((lit size + 1) * 4)]]]. 417688 ^ space! ! 417689 417690"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 417691 417692TraitBehavior class 417693 uses: TPureBehavior classTrait 417694 instanceVariableNames: ''! 417695Object subclass: #TraitComposition 417696 instanceVariableNames: 'transformations' 417697 classVariableNames: '' 417698 poolDictionaries: '' 417699 category: 'Traits-Composition'! 417700!TraitComposition commentStamp: '<historical>' prior: 0! 417701I hold a collection of trait transformations and provide important facilities to query the trait composition. For each trait in the composition clause there exists exactly one transformation in the collection. 417702 417703Note, that directly manipulating the composition of a class or trait does not effect changes automatically. Use PureBehavior>>setTraitComposition: to do this. You have to make a copy of the old trait composition before changing it because only the difference between the new and the old composition is updated!!! 417704 417705 417706!TraitComposition methodsFor: 'accessing' stamp: 'al 3/18/2004 14:10'! 417707add: aTraitTransformation 417708 self errorIfNotAddable: aTraitTransformation. 417709 self transformations addLast: aTraitTransformation! ! 417710 417711!TraitComposition methodsFor: 'accessing' stamp: 'al 3/26/2006 22:03'! 417712allTraits 417713 ^self traits gather: [:trait | 417714 trait hasTraitComposition 417715 ifTrue: [trait traitComposition allTraits copyWith: trait] 417716 ifFalse: [Array with: trait]]! ! 417717 417718!TraitComposition methodsFor: 'accessing' stamp: 'al 4/9/2004 17:12'! 417719removeFromComposition: aTrait 417720 self remove: 417721 (self transformationOfTrait: aTrait)! ! 417722 417723!TraitComposition methodsFor: 'accessing' stamp: 'al 4/9/2004 17:12'! 417724remove: aTransformation 417725 self transformations 417726 remove: aTransformation! ! 417727 417728!TraitComposition methodsFor: 'accessing' stamp: 'al 1/18/2004 19:29'! 417729size 417730 ^transformations size! ! 417731 417732!TraitComposition methodsFor: 'accessing' stamp: 'al 4/13/2004 15:30'! 417733traits 417734 ^self transformations collect: [:each | 417735 each trait]! ! 417736 417737!TraitComposition methodsFor: 'accessing' stamp: 'al 3/7/2004 22:31'! 417738transformationOfTrait: aTrait 417739 "Return the transformation which holds aTrait 417740 or nil if this composition doesn't include aTrait." 417741 417742 ^self transformations 417743 detect: [:each | each trait = aTrait] 417744 ifNone: [nil]! ! 417745 417746!TraitComposition methodsFor: 'accessing' stamp: 'al 3/17/2004 19:34'! 417747transformations 417748 ^transformations! ! 417749 417750 417751!TraitComposition methodsFor: 'composition' stamp: 'apb 8/22/2005 17:28'! 417752addOnTheLeft: aTrait 417753 self errorIfNotAddable: aTrait. 417754 self transformations addFirst: aTrait! ! 417755 417756!TraitComposition methodsFor: 'composition' stamp: 'al 4/10/2004 00:08'! 417757normalizeTransformations 417758 self transformations: ( 417759 self transformations collect: [:each | 417760 each normalized])! ! 417761 417762!TraitComposition methodsFor: 'composition' stamp: 'apb 8/22/2005 17:52'! 417763+ aTraitExpression 417764 ^ aTraitExpression addCompositionOnLeft: self. 417765! ! 417766 417767!TraitComposition methodsFor: 'composition' stamp: 'al 12/15/2003 20:56'! 417768- anArray 417769 "the modifier operators #@ and #- bind stronger than +. 417770 Thus, #@ or #- sent to a sum will only affect the most right summand" 417771 417772 self transformations 417773 addLast: (self transformations removeLast - anArray)! ! 417774 417775!TraitComposition methodsFor: 'composition' stamp: 'al 12/15/2003 20:56'! 417776@ anArrayOfAssociations 417777 "the modifier operators #@ and #- bind stronger than +. 417778 Thus, #@ or #- sent to a sum will only affect the most right summand" 417779 417780 self transformations 417781 addLast: (self transformations removeLast @ anArrayOfAssociations)! ! 417782 417783 417784!TraitComposition methodsFor: 'converting' stamp: 'al 1/18/2004 19:35'! 417785asTraitComposition 417786 ^self! ! 417787 417788 417789!TraitComposition methodsFor: 'copying' stamp: 'apb 8/24/2005 17:13'! 417790copy 417791 self error: 'should not be called'. 417792 ^super copy 417793 transformations: (self transformations collect: [:each | each copy]); 417794 yourself! ! 417795 417796!TraitComposition methodsFor: 'copying' stamp: 'stephane.ducasse 4/13/2009 20:32'! 417797copyTraitExpression 417798 | newCopy | 417799 newCopy := self shallowCopy. 417800 newCopy transformations: (self transformations collect: [ :each | each copyTraitExpression ]). 417801 ^ newCopy 417802! ! 417803 417804!TraitComposition methodsFor: 'copying' stamp: 'al 12/7/2005 20:49'! 417805copyWithExclusionOf: aSymbol to: aTrait 417806 | composition transformation | 417807 composition := self copyTraitExpression. 417808 transformation := (composition transformationOfTrait: aTrait). 417809 ^composition 417810 remove: transformation; 417811 add: (transformation addExclusionOf: aSymbol); 417812 yourself! ! 417813 417814!TraitComposition methodsFor: 'copying' stamp: 'al 12/7/2005 20:50'! 417815copyWithoutAlias: aSymbol of: aTrait 417816 | composition transformation | 417817 composition := self copyTraitExpression. 417818 transformation := (composition transformationOfTrait: aTrait). 417819 ^composition 417820 remove: transformation; 417821 add: (transformation removeAlias: aSymbol); 417822 normalizeTransformations; 417823 yourself! ! 417824 417825 417826!TraitComposition methodsFor: 'enquiries' stamp: 'apb 8/22/2005 14:48'! 417827changedSelectorsComparedTo: oldComposition 417828 | changedSelectors oldTransformation traits newTransformation | 417829 changedSelectors := IdentitySet new. 417830 traits := self traits asIdentitySet addAll: oldComposition traits asIdentitySet; yourself. 417831 traits do: [:each | 417832 newTransformation := self transformationOfTrait: each. 417833 oldTransformation := oldComposition transformationOfTrait: each. 417834 (newTransformation isNil or: [oldTransformation isNil]) 417835 ifTrue: [ 417836 changedSelectors addAll: each selectors] 417837 ifFalse: [ 417838 changedSelectors addAll: 417839 (newTransformation changedSelectorsComparedTo: oldTransformation)]]. 417840 ^changedSelectors! ! 417841 417842!TraitComposition methodsFor: 'enquiries' stamp: 'al 7/21/2004 21:03'! 417843methodDescriptionForSelector: aSymbol 417844 "Return a TraitMethodDescription for the selector aSymbol." 417845 417846 | description | 417847 description := TraitMethodDescription selector: aSymbol. 417848 self transformations do: [:each | 417849 each collectMethodsFor: aSymbol into: description]. 417850 ^description! ! 417851 417852!TraitComposition methodsFor: 'enquiries' stamp: 'al 7/21/2004 21:03'! 417853methodDescriptionsForSelector: aSymbol 417854 "Return a collection of TraitMethodDescriptions for aSymbol and all the 417855 aliases of aSymbol." 417856 417857 | selectors collection | 417858 selectors := IdentitySet with: aSymbol. 417859 self transformations do: [:each | 417860 selectors addAll: (each aliasesForSelector: aSymbol)]. 417861 collection := OrderedCollection new: selectors size. 417862 selectors do: [:each | 417863 collection add: (self methodDescriptionForSelector: each)]. 417864 ^collection! ! 417865 417866!TraitComposition methodsFor: 'enquiries' stamp: 'al 7/22/2004 15:35'! 417867traitProvidingSelector: aSymbol 417868 "Return the trait which originally provides the method aSymbol or return nil 417869 if trait composition does not provide this selector or there is a conflict. 417870 Take aliases into account. Return the trait which the aliased method is defined in." 417871 417872 | methodDescription locatedMethod | 417873 methodDescription := self methodDescriptionForSelector: aSymbol. 417874 (methodDescription isProvided not or: [methodDescription isConflict]) 417875 ifTrue: [^nil]. 417876 locatedMethod := methodDescription providedLocatedMethod. 417877 ^locatedMethod location traitOrClassOfSelector: locatedMethod selector! ! 417878 417879 417880!TraitComposition methodsFor: 'error-handling' stamp: 'al 3/18/2004 14:19'! 417881assertValidUser: aBehavior 417882 "Assert that this trait composition set for aBehavior 417883 does not introduce a cycle." 417884 417885 (self allTraits includes: aBehavior) ifTrue: [ 417886 TraitCompositionException signal: 'Cycle in compositions: The composition (in)directly includes this trait!!']! ! 417887 417888!TraitComposition methodsFor: 'error-handling' stamp: 'al 3/17/2004 15:22'! 417889errorIfNotAddable: aTraitTransformation 417890 (self includesTrait: aTraitTransformation trait) ifTrue: [ 417891 ^TraitCompositionException 417892 signal: 'Trait ' , aTraitTransformation trait asString, ' already in composition']! ! 417893 417894 417895!TraitComposition methodsFor: 'initialization' stamp: 'al 3/12/2004 17:06'! 417896initialize 417897 super initialize. 417898 transformations := OrderedCollection new! ! 417899 417900 417901!TraitComposition methodsFor: 'printing' stamp: 'al 12/16/2003 22:06'! 417902printOn: aStream 417903 self transformations isEmptyOrNil 417904 ifFalse: [ 417905 self transformations 417906 do: [:each | aStream print: each] 417907 separatedBy: [aStream nextPutAll: ' + '] ] 417908 ifTrue: [aStream nextPutAll: '{}'] 417909 ! ! 417910 417911!TraitComposition methodsFor: 'printing' stamp: 'al 12/16/2003 22:16'! 417912printString 417913 ^String streamContents: [:stream | 417914 self printOn: stream]! ! 417915 417916 417917!TraitComposition methodsFor: 'testing' stamp: 'al 7/30/2004 15:50'! 417918includesMethod: aSelector 417919 ^(self methodDescriptionForSelector: aSelector) isEmpty not! ! 417920 417921!TraitComposition methodsFor: 'testing' stamp: 'al 1/18/2004 19:32'! 417922includesTrait: aTrait 417923 ^self traits includes: aTrait! ! 417924 417925!TraitComposition methodsFor: 'testing' stamp: 'al 4/10/2004 23:25'! 417926isAliasSelector: aSymbol 417927 "Return true if the selector aSymbol is an alias defined 417928 in this or in another composition somewhere deeper in 417929 the tree of traits compositions." 417930 417931 | methodDescription | 417932 methodDescription := (self methodDescriptionsForSelector: aSymbol) 417933 detect: [:each | each selector = aSymbol]. 417934 ^methodDescription isAliasSelector! ! 417935 417936!TraitComposition methodsFor: 'testing' stamp: 'al 3/6/2004 19:05'! 417937isEmpty 417938 ^self transformations isEmpty! ! 417939 417940!TraitComposition methodsFor: 'testing' stamp: 'al 4/10/2004 23:34'! 417941isLocalAliasSelector: aSymbol 417942 "Return true if the selector aSymbol is an alias defined 417943 in this composition." 417944 417945 | methodDescription | 417946 methodDescription := (self methodDescriptionsForSelector: aSymbol) 417947 detect: [:each | each selector = aSymbol]. 417948 ^methodDescription isLocalAliasSelector! ! 417949 417950!TraitComposition methodsFor: 'testing' stamp: 'al 3/6/2004 19:05'! 417951notEmpty 417952 ^self isEmpty not! ! 417953 417954 417955!TraitComposition methodsFor: 'private' stamp: 'stephane.ducasse 4/13/2009 20:33'! 417956addCompositionOnLeft: aTraitComposition 417957 self transformations do: [ :each | aTraitComposition add: each ]. 417958 ^ aTraitComposition! ! 417959 417960!TraitComposition methodsFor: 'private' stamp: 'al 3/19/2004 10:30'! 417961transformations: aCollection 417962 transformations := aCollection! ! 417963 417964"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 417965 417966TraitComposition class 417967 instanceVariableNames: ''! 417968 417969!TraitComposition class methodsFor: 'instance creation' stamp: 'al 12/12/2003 18:24'! 417970with: aTraitTransformation 417971 ^self new 417972 add: aTraitTransformation; 417973 yourself! ! 417974 417975!TraitComposition class methodsFor: 'instance creation' stamp: 'al 12/12/2003 18:24'! 417976with: aTraitTransformation with: anotherTraitTransformation 417977 ^self new 417978 add: aTraitTransformation; 417979 add: anotherTraitTransformation; 417980 yourself! ! 417981TraitException subclass: #TraitCompositionException 417982 instanceVariableNames: '' 417983 classVariableNames: '' 417984 poolDictionaries: '' 417985 category: 'Traits-Composition'! 417986!TraitCompositionException commentStamp: '<historical>' prior: 0! 417987Signal invalid trait compositions.! 417988 417989 417990"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 417991 417992TraitCompositionException class 417993 instanceVariableNames: ''! 417994TraitsTestCase subclass: #TraitCompositionTest 417995 instanceVariableNames: '' 417996 classVariableNames: '' 417997 poolDictionaries: '' 417998 category: 'Tests-Traits'! 417999 418000!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'dvf 8/26/2005 14:31'! 418001testAliasCompositions 418002 "unary" 418003 418004 self 418005 shouldnt: [self t2 setTraitCompositionFrom: self t1 @ { (#aliasM11 -> #m11) }] 418006 raise: TraitCompositionException. 418007 self 418008 should: [self t2 setTraitCompositionFrom: self t1 @ { (#alias: -> #m11) }] 418009 raise: TraitCompositionException. 418010 self 418011 should: [self t2 setTraitCompositionFrom: self t1 @ { (#alias:x:y: -> #m11) }] 418012 raise: TraitCompositionException. 418013 418014 "binary" 418015 self t1 compile: '= anObject'. 418016 self 418017 shouldnt: [self t2 setTraitCompositionFrom: self t1 @ { (#equals: -> #=) }] 418018 raise: TraitCompositionException. 418019 self shouldnt: [self t2 setTraitCompositionFrom: self t1 @ { (#% -> #=) }] 418020 raise: TraitCompositionException. 418021 self 418022 should: [self t2 setTraitCompositionFrom: self t1 @ { (#equals -> #=) }] 418023 raise: TraitCompositionException. 418024 self 418025 should: [self t2 setTraitCompositionFrom: self t1 @ { (#equals:x: -> #=) }] 418026 raise: TraitCompositionException. 418027 418028 "keyword" 418029 self t1 compile: 'x: a y: b z: c'. 418030 self 418031 should: [self t2 setTraitCompositionFrom: self t1 @ { (#'==' -> #x:y:z:) }] 418032 raise: TraitCompositionException. 418033 self 418034 should: [self t2 setTraitCompositionFrom: self t1 @ { (#x -> #x:y:z:) }] 418035 raise: TraitCompositionException. 418036 self 418037 should: [self t2 setTraitCompositionFrom: self t1 @ { (#x: -> #x:y:z:) }] 418038 raise: TraitCompositionException. 418039 self 418040 should: [self t2 setTraitCompositionFrom: self t1 @ { (#x:y: -> #x:y:z:) }] 418041 raise: TraitCompositionException. 418042 self shouldnt: 418043 [self t2 setTraitCompositionFrom: self t1 @ { (#myX:y:z: -> #x:y:z:) }] 418044 raise: TraitCompositionException. 418045 418046 "alias same as selector" 418047 self 418048 should: [self t2 setTraitCompositionFrom: self t1 @ { (#m11 -> #m11) }] 418049 raise: TraitCompositionException. 418050 418051 "same alias name used twice" 418052 self should: 418053 [self t2 418054 setTraitCompositionFrom: self t1 @ { (#alias -> #m11). (#alias -> #m12) }] 418055 raise: TraitCompositionException. 418056 418057 "aliasing an alias" 418058 self should: 418059 [self t2 418060 setTraitCompositionFrom: self t1 @ { (#alias -> #m11). (#alias2 -> #alias) }] 418061 raise: TraitCompositionException! ! 418062 418063!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'dvf 8/30/2005 14:07'! 418064testCompositionFromArray 418065 | composition | 418066 composition := { (self t1) } asTraitComposition. 418067 self assert: (composition isKindOf: TraitComposition). 418068 self assert: (composition traits includes: self t1). 418069 self assert: composition traits size = 1. 418070 composition := { (self t1). self t2 } asTraitComposition. 418071 self assert: (composition isKindOf: TraitComposition). 418072 self assert: (composition traits includes: self t1). 418073 self assert: (composition traits includes: self t2). 418074 self assert: composition traits size = 2! ! 418075 418076!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'al 12/15/2003 20:51'! 418077testEmptyTrait 418078 | composition | 418079 composition := {} asTraitComposition. 418080 418081 self assert: (composition isKindOf: TraitComposition). 418082 self assert: composition transformations isEmpty. 418083 self assert: composition traits isEmpty! ! 418084 418085!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'dvf 8/26/2005 14:31'! 418086testInvalidComposition 418087 self should: [self t1 @ { (#a -> #b) } @ { (#x -> #y) }] 418088 raise: TraitCompositionException. 418089 self should: [(self t1 + self t2) @ { (#a -> #b) } @ { (#x -> #y) }] 418090 raise: TraitCompositionException. 418091 self should: [self t1 - { #a } - { #b }] raise: TraitCompositionException. 418092 self should: [self t1 + self t2 - { #a } - { #b }] 418093 raise: TraitCompositionException. 418094 self should: [(self t1 - { #x }) @ { (#a -> #b) }] 418095 raise: TraitCompositionException. 418096 self should: [(self t1 + self t2 - { #x }) @ { (#a -> #b) }] 418097 raise: TraitCompositionException. 418098 self should: [self t1 + self t1] raise: TraitCompositionException. 418099 self should: [(self t1 + self t2) @ { (#a -> #b) } + self t1] 418100 raise: TraitCompositionException. 418101 self should: [self t1 @ { (#a -> #m11). (#a -> #m12) }] 418102 raise: TraitCompositionException. 418103 self should: [self t1 @ { (#a -> #m11). (#b -> #a) }] 418104 raise: TraitCompositionException! ! 418105 418106!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'dvf 8/26/2005 14:31'! 418107testPrinting 418108 | composition1 composition2 | 418109 composition1 := ((self t1 - { #a } + self t2) @ { (#z -> #c) } - { #b. #c } 418110 + self t3 - { #d. #e } 418111 + self t4) @ { (#x -> #a). (#y -> #b) }. 418112 composition2 := self t4 @ { (#x -> #a). (#y -> #b) } + self t1 - { #a } 418113 + self t3 - { #d. #e } 418114 + self t2 - { #b. #c }. 418115 self assertPrints: composition1 printString 418116 like: 'T1 - {#a} + T2 @ {#z->#c} - {#b. #c} + T3 - {#d. #e} + T4 @ {#x->#a. #y->#b}'. 418117 self assertPrints: composition2 printString 418118 like: 'T4 @ {#x->#a. #y->#b} + T1 - {#a} + T3 - {#d. #e} + T2 - {#b. #c}'! ! 418119 418120!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'dvf 8/26/2005 14:31'! 418121testSum 418122 | composition | 418123 composition := self t1 + self t2 + self t3. 418124 self assert: (composition isKindOf: TraitComposition). 418125 self assert: (composition traits includes: self t1). 418126 self assert: (composition traits includes: self t2). 418127 self assert: (composition traits includes: self t3). 418128 self assert: composition traits size = 3! ! 418129 418130!TraitCompositionTest methodsFor: 'testing-basic' stamp: 'dvf 8/26/2005 14:31'! 418131testSumWithParenthesis 418132 | composition | 418133 composition := self t1 + (self t2 + self t3). 418134 self assert: (composition isKindOf: TraitComposition). 418135 self assert: (composition traits includes: self t1). 418136 self assert: (composition traits includes: self t2). 418137 self assert: (composition traits includes: self t3). 418138 self assert: composition traits size = 3. 418139 self assert: composition size = 3! ! 418140 418141 418142!TraitCompositionTest methodsFor: 'testing-enquiries' stamp: 'dvf 8/26/2005 14:31'! 418143testClassMethodsTakePrecedenceOverTraitsMethods 418144 | keys | 418145 keys := Set new. 418146 self t4 methodDict bindingsDo: [:each | keys add: each key]. 418147 self assert: keys size = 6. 418148 self 418149 assert: (keys includesAllOf: #( 418150 #m12 418151 #m13 418152 #m13 418153 #m21 418154 #m22 418155 #m11 418156 #m42 418157 )). 418158 self assert: (self t4 methodDict at: #m11) decompileString = 'm11 418159 ^ 41'! ! 418160 418161!TraitCompositionTest methodsFor: 'testing-enquiries' stamp: 'dvf 8/26/2005 14:31'! 418162testProvidedMethodBindingsWithConflicts 418163 | traitWithConflict methodDict | 418164 traitWithConflict := self createTraitNamed: #TraitWithConflict 418165 uses: self t1 + self t4. 418166 methodDict := traitWithConflict methodDict. 418167 self assert: methodDict size = 6. 418168 self 418169 assert: (methodDict keys includesAllOf: #( 418170 #m11 418171 #m12 418172 #m13 418173 #m21 418174 #m22 418175 #m42 418176 )). 418177 self 418178 assert: (methodDict at: #m11) decompileString = 'm11 418179 self traitConflict'! ! 418180TraitBehavior subclass: #TraitDescription 418181 uses: TClassAndTraitDescription + TComposingDescription + TTransformationCompatibility 418182 instanceVariableNames: 'organization' 418183 classVariableNames: '' 418184 poolDictionaries: '' 418185 category: 'Traits-Kernel'! 418186!TraitDescription commentStamp: '<historical>' prior: 0! 418187I add a number of facilities (most defined by traits which are also used in ClassDescription): 418188 Category organization for methods 418189 The maintenance of a ChangeSet, and logging changes on a file 418190 Most of the mechanism for fileOut. 418191 Copying of methods to other traits/classes 418192 Operators to create trait compositions! 418193 418194 418195!TraitDescription methodsFor: 'accessing' stamp: 'NS 12/9/2003 11:00'! 418196traitVersion 418197 "Default. Any class may return a later version to inform readers that use ReferenceStream. 8/17/96 tk" 418198 "This method allows you to distinguish between class versions when the shape of the class 418199 hasn't changed (when there's no change in the instVar names). 418200 In the conversion methods you usually can tell by the inst var names 418201 what old version you have. In a few cases, though, the same inst var 418202 names were kept but their interpretation changed (like in the layoutFrame). 418203 By changing the class version when you keep the same instVars you can 418204 warn older and newer images that they have to convert." 418205 ^ 0! ! 418206 418207!TraitDescription methodsFor: 'accessing' stamp: 'NS 12/9/2003 15:12'! 418208version 418209 "Allows polymoprhism with ClassDescription>>version" 418210 418211 ^ self traitVersion! ! 418212 418213 418214!TraitDescription methodsFor: 'accessing comment' stamp: 'PeterHugossonMiller 9/3/2009 11:45'! 418215classCommentBlank 418216 418217 | existingComment stream | 418218 existingComment := self instanceSide organization classComment. 418219 existingComment isEmpty 418220 ifFalse: [^existingComment]. 418221 418222 stream := (String new: 100) writeStream. 418223 stream 418224 nextPutAll: 'A'; 418225 nextPutAll: (self name first isVowel ifTrue: ['n '] ifFalse: [' ']); 418226 nextPutAll: self name; 418227 nextPutAll: ' is xxxxxxxxx.'. 418228 stream cr. 418229 ^stream contents! ! 418230 418231!TraitDescription methodsFor: 'accessing comment'! 418232comment 418233 "Answer the receiver's comment. (If missing, supply a template) " 418234 | aString | 418235 aString := self instanceSide organization classComment. 418236 aString isEmpty ifFalse: [^ aString]. 418237 ^self classCommentBlank! ! 418238 418239!TraitDescription methodsFor: 'accessing comment'! 418240comment: aStringOrText 418241 "Set the receiver's comment to be the argument, aStringOrText." 418242 418243 self instanceSide classComment: aStringOrText.! ! 418244 418245!TraitDescription methodsFor: 'accessing comment'! 418246comment: aStringOrText stamp: aStamp 418247 "Set the receiver's comment to be the argument, aStringOrText." 418248 418249 self instanceSide classComment: aStringOrText stamp: aStamp.! ! 418250 418251!TraitDescription methodsFor: 'accessing comment'! 418252hasComment 418253 "return whether this class truly has a comment other than the default" 418254 | org | 418255 org := self instanceSide organization. 418256 ^org classComment isEmptyOrNil not! ! 418257 418258 418259!TraitDescription methodsFor: 'accessing method dictionary'! 418260addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor 418261 | priorMethodOrNil oldProtocol newProtocol | 418262 priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil]. 418263 self addSelectorSilently: selector withMethod: compiledMethod. 418264 oldProtocol := self organization categoryOfElement: selector. 418265 SystemChangeNotifier uniqueInstance 418266 doSilently: [self organization classify: selector under: category]. 418267 newProtocol := self organization categoryOfElement: selector. 418268 priorMethodOrNil isNil 418269 ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: self requestor: requestor] 418270 ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self oldProtocol: oldProtocol newProtocol: newProtocol requestor: requestor].! ! 418271 418272!TraitDescription methodsFor: 'accessing method dictionary'! 418273addSelectorSilently: selector withMethod: compiledMethod 418274 super addSelectorSilently: selector withMethod: compiledMethod. 418275 self instanceSide noteAddedSelector: selector meta: self isMeta.! ! 418276 418277!TraitDescription methodsFor: 'accessing method dictionary'! 418278addSelector: selector withMethod: compiledMethod notifying: requestor 418279 | priorMethodOrNil | 418280 priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil]. 418281 self addSelectorSilently: selector withMethod: compiledMethod. 418282 priorMethodOrNil isNil 418283 ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inClass: self requestor: requestor] 418284 ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! ! 418285 418286!TraitDescription methodsFor: 'accessing method dictionary' stamp: 'al 6/29/2004 21:42'! 418287allMethodsInCategory: aName 418288 "Answer a list of all the method categories of the receiver" 418289 418290 | aColl | 418291 aColl := aName = ClassOrganizer allCategory 418292 ifTrue: [self organization allMethodSelectors] 418293 ifFalse: [self organization listAtCategoryNamed: aName]. 418294 ^aColl asSet asSortedArray 418295 418296 "TileMorph allMethodsInCategory: #initialization"! ! 418297 418298!TraitDescription methodsFor: 'accessing method dictionary' stamp: 'nice 3/22/2008 01:22'! 418299methodsInCategory: aName 418300 "Answer a list of the methods of the receiver that are in category named aName" 418301 418302 | aColl | 418303 aColl := aName = ClassOrganizer allCategory 418304 ifTrue: [self organization allMethodSelectors] 418305 ifFalse: [self organization listAtCategoryNamed: aName]. 418306 ^aColl asSet asSortedArray 418307 418308 "TileMorph allMethodsInCategory: #initialization"! ! 418309 418310!TraitDescription methodsFor: 'accessing method dictionary'! 418311noteAddedSelector: aSelector meta: isMeta 418312 "A hook allowing some classes to react to adding of certain selectors"! ! 418313 418314!TraitDescription methodsFor: 'accessing method dictionary'! 418315removeCategory: aString 418316 "Remove each of the messages categorized under aString in the method 418317 dictionary of the receiver. Then remove the category aString." 418318 | categoryName | 418319 categoryName := aString asSymbol. 418320 (self organization listAtCategoryNamed: categoryName) do: 418321 [:sel | self removeSelector: sel]. 418322 self organization removeCategory: categoryName! ! 418323 418324!TraitDescription methodsFor: 'accessing method dictionary'! 418325removeSelector: selector 418326 "Remove the message whose selector is given from the method 418327 dictionary of the receiver, if it is there. Answer nil otherwise." 418328 418329 | priorMethod priorProtocol | 418330 priorMethod := self compiledMethodAt: selector ifAbsent: [^ nil]. 418331 priorProtocol := self whichCategoryIncludesSelector: selector. 418332 super removeSelector: selector. 418333 SystemChangeNotifier uniqueInstance 418334 doSilently: [self updateOrganizationSelector: selector oldCategory: priorProtocol newCategory: nil]. 418335 SystemChangeNotifier uniqueInstance 418336 methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! ! 418337 418338 418339!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 4/21/2004 10:01'! 418340baseTrait 418341 self subclassResponsibility! ! 418342 418343!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'NS 4/12/2004 15:05'! 418344classSide 418345 ^self classTrait! ! 418346 418347!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 4/21/2004 10:01'! 418348classTrait 418349 self subclassResponsibility! ! 418350 418351!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 4/21/2004 10:02'! 418352hasClassTrait 418353 self subclassResponsibility! ! 418354 418355!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'NS 4/12/2004 15:05'! 418356instanceSide 418357 ^self baseTrait! ! 418358 418359!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:47'! 418360isBaseTrait 418361 self subclassResponsibility! ! 418362 418363!TraitDescription methodsFor: 'accessing parallel hierarchy'! 418364isClassSide 418365 ^self == self classSide! ! 418366 418367!TraitDescription methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:47'! 418368isClassTrait 418369 self subclassResponsibility! ! 418370 418371!TraitDescription methodsFor: 'accessing parallel hierarchy'! 418372isInstanceSide 418373 ^self isClassSide not! ! 418374 418375!TraitDescription methodsFor: 'accessing parallel hierarchy'! 418376isMeta 418377 ^self isClassSide! ! 418378 418379 418380!TraitDescription methodsFor: 'class compatibility' stamp: 'NS 12/9/2003 11:18'! 418381theMetaClass 418382 ^ self classTrait! ! 418383 418384!TraitDescription methodsFor: 'class compatibility' stamp: 'al 12/10/2003 00:07'! 418385theNonMetaClass 418386 ^ self baseTrait! ! 418387 418388 418389!TraitDescription methodsFor: 'closure support' stamp: 'sd 3/22/2009 21:59'! 418390variablesAndOffsetsDo: aBlock 418391 418392 ^self! ! 418393 418394 418395!TraitDescription methodsFor: 'compiling'! 418396acceptsLoggingOfCompilation 418397 "Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set. The metaclass follows the rule of the class itself. 6/18/96 sw" 418398 "weird name is so that it will come lexically before #compile, so that a clean build can make it through. 7/7/96 sw" 418399 418400 ^ true! ! 418401 418402!TraitDescription methodsFor: 'compiling'! 418403compileSilently: code classified: category 418404 "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." 418405 418406 ^ self compileSilently: code classified: category notifying: nil.! ! 418407 418408!TraitDescription methodsFor: 'compiling'! 418409compileSilently: code classified: category notifying: requestor 418410 "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." 418411 418412 ^ SystemChangeNotifier uniqueInstance 418413 doSilently: [self compile: code classified: category withStamp: nil notifying: requestor logSource: false].! ! 418414 418415!TraitDescription methodsFor: 'compiling'! 418416compile: code classified: heading 418417 "Compile the argument, code, as source code in the context of the 418418 receiver and install the result in the receiver's method dictionary under 418419 the classification indicated by the second argument, heading. nil is to be 418420 notified if an error occurs. The argument code is either a string or an 418421 object that converts to a string or a PositionableStream on an object that 418422 converts to a string." 418423 418424 ^self 418425 compile: code 418426 classified: heading 418427 notifying: nil! ! 418428 418429!TraitDescription methodsFor: 'compiling'! 418430compile: text classified: category notifying: requestor 418431 | stamp | 418432 stamp := self acceptsLoggingOfCompilation ifTrue: [Utilities changeStamp] ifFalse: [nil]. 418433 ^ self compile: text classified: category 418434 withStamp: stamp notifying: requestor! ! 418435 418436!TraitDescription methodsFor: 'compiling'! 418437compile: text classified: category withStamp: changeStamp notifying: requestor 418438 ^ self compile: text classified: category withStamp: changeStamp notifying: requestor logSource: self acceptsLoggingOfCompilation! ! 418439 418440!TraitDescription methodsFor: 'compiling'! 418441compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource 418442 | methodAndNode | 418443 methodAndNode := self compile: text asString classified: category notifying: requestor 418444 trailer: self defaultMethodTrailer ifFail: [^nil]. 418445 logSource ifTrue: [ 418446 self logMethodSource: text forMethodWithNode: methodAndNode 418447 inCategory: category withStamp: changeStamp notifying: requestor. 418448 ]. 418449 self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode 418450 method inProtocol: category notifying: requestor. 418451 self instanceSide noteCompilationOf: methodAndNode selector meta: self isClassSide. 418452 ^ methodAndNode selector! ! 418453 418454!TraitDescription methodsFor: 'compiling'! 418455compile: code notifying: requestor 418456 "Refer to the comment in Behavior|compile:notifying:." 418457 418458 ^self compile: code 418459 classified: ClassOrganizer default 418460 notifying: requestor! ! 418461 418462!TraitDescription methodsFor: 'compiling'! 418463doneCompiling 418464 "A ClassBuilder has finished the compilation of the receiver. 418465 This message is a notification for a class that needs to do some 418466 cleanup / reinitialization after it has been recompiled."! ! 418467 418468!TraitDescription methodsFor: 'compiling'! 418469noteCompilationOf: aSelector meta: isMeta 418470 "A hook allowing some classes to react to recompilation of certain selectors"! ! 418471 418472!TraitDescription methodsFor: 'compiling'! 418473reformatAll 418474 "Reformat all methods in this class. 418475 Leaves old code accessible to version browsing" 418476 self selectorsDo: [:sel | self reformatMethodAt: sel]! ! 418477 418478!TraitDescription methodsFor: 'compiling'! 418479reformatMethodAt: selector 418480 | newCodeString method | 418481 newCodeString := self prettyPrinterClass 418482 format: (self sourceCodeAt: selector) 418483 in: self 418484 notifying: nil. 418485 method := self compiledMethodAt: selector. 418486 method 418487 putSource: newCodeString 418488 fromParseNode: nil 418489 class: self 418490 category: (self organization categoryOfElement: selector) 418491 inFile: 2 418492 priorMethod: method 418493! ! 418494 418495!TraitDescription methodsFor: 'compiling'! 418496wantsChangeSetLogging 418497 "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism. 7/12/96 sw" 418498 418499 ^ true! ! 418500 418501!TraitDescription methodsFor: 'compiling'! 418502wantsRecompilationProgressReported 418503 "Answer whether the receiver would like progress of its recompilation reported interactively to the user." 418504 418505 ^ true! ! 418506 418507 418508!TraitDescription methodsFor: 'composition' stamp: 'al 12/7/2005 21:00'! 418509addExclusionOf: aSymbol 418510 ^self - {aSymbol}! ! 418511 418512!TraitDescription methodsFor: 'composition'! 418513+ aTraitOrTraitComposition 418514 "Use double dispatch to avoid having nested composition in cases where 418515 parenthesis are used, such as T1 + (T2 + T3)" 418516 418517 ^aTraitOrTraitComposition addOnTheLeft: self! ! 418518 418519!TraitDescription methodsFor: 'composition'! 418520- anArrayOfSelectors 418521 ^TraitExclusion 418522 with: self 418523 exclusions: anArrayOfSelectors! ! 418524 418525!TraitDescription methodsFor: 'composition'! 418526@ anArrayOfAssociations 418527 ^ TraitAlias with: self aliases: anArrayOfAssociations! ! 418528 418529 418530!TraitDescription methodsFor: 'converting'! 418531asTraitComposition 418532 ^TraitComposition with: self! ! 418533 418534 418535!TraitDescription methodsFor: 'copying'! 418536copyAllCategoriesFrom: aClass 418537 "Specify that the categories of messages for the receiver include all of 418538 those found in the class, aClass. Install each of the messages found in 418539 these categories into the method dictionary of the receiver, classified 418540 under the appropriate categories." 418541 418542 aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! ! 418543 418544!TraitDescription methodsFor: 'copying'! 418545copyAll: selArray from: class 418546 "Install all the methods found in the method dictionary of the second 418547 argument, class, as the receiver's methods. Classify the messages under 418548 -As yet not classified-." 418549 418550 self copyAll: selArray 418551 from: class 418552 classified: nil! ! 418553 418554!TraitDescription methodsFor: 'copying'! 418555copyAll: selArray from: class classified: cat 418556 "Install all the methods found in the method dictionary of the second 418557 argument, class, as the receiver's methods. Classify the messages under 418558 the third argument, cat." 418559 418560 selArray do: 418561 [:s | self copy: s 418562 from: class 418563 classified: cat]! ! 418564 418565!TraitDescription methodsFor: 'copying'! 418566copyCategory: cat from: class 418567 "Specify that one of the categories of messages for the receiver is cat, as 418568 found in the class, class. Copy each message found in this category." 418569 418570 self copyCategory: cat 418571 from: class 418572 classified: cat! ! 418573 418574!TraitDescription methodsFor: 'copying'! 418575copyCategory: cat from: aClass classified: newCat 418576 "Specify that one of the categories of messages for the receiver is the 418577 third argument, newCat. Copy each message found in the category cat in 418578 class aClass into this new category." 418579 418580 self copyAll: (aClass organization listAtCategoryNamed: cat) 418581 from: aClass 418582 classified: newCat! ! 418583 418584!TraitDescription methodsFor: 'copying'! 418585copyMethodDictionaryFrom: donorClass 418586 "Copy the method dictionary of the donor class over to the receiver" 418587 418588 self methodDict: donorClass copyOfMethodDictionary. 418589 self organization: donorClass organization deepCopy.! ! 418590 418591!TraitDescription methodsFor: 'copying' stamp: 'dvf 9/22/2005 17:54'! 418592copyTraitExpression 418593 "When recursively copying a trait expression, the primitive traits should NOT be copied 418594because they are globally named 'well-known' objects" 418595 ^ self ! ! 418596 418597!TraitDescription methodsFor: 'copying'! 418598copy: sel from: class 418599 "Install the method associated with the first argument, sel, a message 418600 selector, found in the method dictionary of the second argument, class, 418601 as one of the receiver's methods. Classify the message under -As yet not 418602 classified-." 418603 418604 self copy: sel 418605 from: class 418606 classified: nil! ! 418607 418608!TraitDescription methodsFor: 'copying' stamp: 'marcus.denker 9/14/2008 19:06'! 418609copy: sel from: class classified: cat 418610 "Install the method associated with the first arugment, sel, a message 418611 selector, found in the method dictionary of the second argument, class, 418612 as one of the receiver's methods. Classify the message under the third 418613 argument, cat." 418614 418615 | code category | 418616 "Useful when modifying an existing class" 418617 code := class sourceMethodAt: sel. 418618 code ifNotNil: 418619 [cat 418620 ifNil: [category := class organization categoryOfElement: sel] 418621 ifNotNil: [category := cat]. 418622 (self includesSelector: sel) 418623 ifTrue: [code asString = (self sourceMethodAt: sel) asString 418624 ifFalse: [self error: self name 418625 , ' ' 418626 , sel 418627 , ' will be redefined if you proceed.']]. 418628 self compile: code classified: category]! ! 418629 418630 418631!TraitDescription methodsFor: 'enquiries'! 418632aliasesForSelector: aSelector 418633 ^ OrderedCollection new 418634! ! 418635 418636!TraitDescription methodsFor: 'enquiries'! 418637allAliasesDict 418638 ^IdentityDictionary new 418639! ! 418640 418641!TraitDescription methodsFor: 'enquiries'! 418642changedSelectorsComparedTo: aTraitTransformation 418643 | selectors otherSelectors changedSelectors aliases otherAliases | 418644 selectors := self allSelectors asIdentitySet. 418645 otherSelectors := aTraitTransformation allSelectors asIdentitySet. 418646 changedSelectors := IdentitySet withAll: ( 418647 (selectors difference: otherSelectors) union: (otherSelectors difference: selectors)). 418648 aliases := self allAliasesDict. 418649 otherAliases := aTraitTransformation allAliasesDict. 418650 aliases keysAndValuesDo: [:key :value | 418651 (value ~~ (otherAliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]]. 418652 otherAliases keysAndValuesDo: [:key :value | 418653 (value ~~ (aliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]]. 418654 ^ changedSelectors. 418655! ! 418656 418657!TraitDescription methodsFor: 'enquiries'! 418658collectMethodsFor: aSelector into: methodDescription 418659 (self includesSelector: aSelector) ifTrue: [ 418660 methodDescription addLocatedMethod: ( 418661 LocatedMethod 418662 location: self 418663 selector: aSelector)] 418664! ! 418665 418666!TraitDescription methodsFor: 'enquiries'! 418667subject 418668 "for compatibility with TraitTransformations" 418669 ^ self 418670! ! 418671 418672!TraitDescription methodsFor: 'enquiries'! 418673trait 418674 "for compatibility with TraitTransformations" 418675 ^ self 418676! ! 418677 418678 418679!TraitDescription methodsFor: 'fileIn/Out'! 418680classComment: aString stamp: aStamp 418681 "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." 418682 418683 | ptr header file oldCommentRemoteStr oldComment oldStamp | 418684 oldComment := self organization classComment. 418685 oldStamp := self organization commentStamp. 418686 (aString isKindOf: RemoteString) ifTrue: 418687 [SystemChangeNotifier uniqueInstance class: self oldComment: oldComment newComment: aString string oldStamp: oldStamp newStamp: aStamp. 418688 ^ self organization classComment: aString stamp: aStamp]. 418689 418690 oldCommentRemoteStr := self organization commentRemoteStr. 418691 (aString size = 0) & (oldCommentRemoteStr isNil) ifTrue: [^ self organization classComment: nil]. 418692 "never had a class comment, no need to write empty string out" 418693 418694 ptr := oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. 418695 SourceFiles ifNotNil: [(file := SourceFiles at: 2) ifNotNil: 418696 [file setToEnd; cr; nextPut: $!!. "directly" 418697 "Should be saying (file command: 'H3') for HTML, but ignoring it here" 418698 header := String streamContents: [:strm | strm nextPutAll: self name; 418699 nextPutAll: ' commentStamp: '. 418700 aStamp storeOn: strm. 418701 strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. 418702 file nextChunkPut: header]]. 418703 self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. 418704 SystemChangeNotifier uniqueInstance class: self oldComment: oldComment newComment: aString oldStamp: oldStamp newStamp: aStamp! ! 418705 418706!TraitDescription methodsFor: 'fileIn/Out' stamp: 'al 3/26/2006 21:50'! 418707definitionST80 418708 ^String streamContents: [:stream | 418709 stream nextPutAll: self class name. 418710 stream nextPutAll: ' named: '; 418711 store: self name. 418712 stream cr; tab; nextPutAll: 'uses: '; 418713 nextPutAll: self traitCompositionString. 418714 stream cr; tab; nextPutAll: 'category: '; 418715 store: self category asString].! ! 418716 418717!TraitDescription methodsFor: 'fileIn/Out' stamp: 'PeterHugossonMiller 9/3/2009 11:45'! 418718fileOut 418719 "Create a file whose name is the name of the receiver with '.st' as the 418720 extension, and file a description of the receiver onto it." 418721 418722 | internalStream | 418723 internalStream := (String new: 100) writeStream. 418724 internalStream header; timeStamp. 418725 418726 self fileOutOn: internalStream moveSource: false toFile: 0. 418727 internalStream trailer. 418728 418729 FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true! ! 418730 418731!TraitDescription methodsFor: 'fileIn/Out'! 418732fileOutCategory: aSymbol on: aFileStream moveSource: moveSource toFile: fileIndex 418733 "File a description of the receiver's category, aString, onto aFileStream. If 418734 moveSource, is true, then set the method source pointer to the new file position. 418735 Note when this method is called with moveSource=true, it is condensing the 418736 .sources file, and should only write one preamble per method category." 418737 418738 | selectors | 418739 aFileStream cr. 418740 selectors := (aSymbol asString = ClassOrganizer allCategory) 418741 ifTrue: [ self organization allMethodSelectors ] 418742 ifFalse: [ self organization listAtCategoryNamed: aSymbol ]. 418743 418744 "Overridden to preserve author stamps in sources file regardless" 418745 selectors do: [:sel | 418746 self printMethodChunk: sel 418747 withPreamble: true 418748 on: aFileStream 418749 moveSource: moveSource 418750 toFile: fileIndex]. 418751 ^ self! ! 418752 418753!TraitDescription methodsFor: 'fileIn/Out'! 418754moveChangesTo: newFile 418755 "Used in the process of condensing changes, this message requests that 418756 the source code of all methods of the receiver that have been changed 418757 should be moved to newFile." 418758 418759 | changes | 418760 changes := self methodDict keys select: [:sel | 418761 (self compiledMethodAt: sel) fileIndex > 1 ]. 418762 self 418763 fileOutChangedMessages: changes 418764 on: newFile 418765 moveSource: true 418766 toFile: 2! ! 418767 418768!TraitDescription methodsFor: 'fileIn/Out' stamp: 'marcus.denker 9/14/2008 19:04'! 418769printMethodChunk: selector withPreamble: doPreamble on: outStream 418770 moveSource: moveSource toFile: fileIndex 418771 "Copy the source code for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." 418772 | preamble method oldPos newPos sourceFile endPos | 418773 doPreamble 418774 ifTrue: [preamble := self name , ' methodsFor: ' , 418775 (self organization categoryOfElement: selector) asString printString] 418776 ifFalse: [preamble := '']. 418777 method := self methodDict at: selector ifAbsent: 418778 [outStream nextPutAll: selector; cr. 418779 outStream tab; nextPutAll: '** ERROR!! THIS SCRIPT IS MISSING ** ' translated; cr; cr. 418780 outStream nextPutAll: ' '. 418781 ^ outStream]. 418782 418783 ((method fileIndex = 0 418784 or: [(SourceFiles at: method fileIndex) isNil]) 418785 or: [(oldPos := method filePosition) = 0]) 418786 ifTrue: 418787 ["The source code is not accessible. We must decompile..." 418788 preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr]. 418789 outStream nextChunkPut: method decompileString] 418790 ifFalse: 418791 [sourceFile := SourceFiles at: method fileIndex. 418792 preamble size > 0 418793 ifTrue: "Copy the preamble" 418794 [outStream copyPreamble: preamble from: sourceFile at: oldPos] 418795 ifFalse: 418796 [sourceFile position: oldPos]. 418797 "Copy the method chunk" 418798 newPos := outStream position. 418799 outStream copyMethodChunkFrom: sourceFile. 418800 sourceFile skipSeparators. "The following chunk may have ]style[" 418801 sourceFile peek == $] ifTrue: [ 418802 outStream cr; copyMethodChunkFrom: sourceFile]. 418803 moveSource ifTrue: "Set the new method source pointer" 418804 [endPos := outStream position. 418805 method checkOKToAdd: endPos - newPos at: newPos. 418806 method setSourcePosition: newPos inFile: fileIndex]]. 418807 preamble size > 0 ifTrue: [outStream nextChunkPut: ' ']. 418808 ^ outStream cr! ! 418809 418810 418811!TraitDescription methodsFor: 'filein/out'! 418812classComment: aString 418813 "Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing. Empty string gets stored only if had a non-empty one before." 418814 ^ self classComment: aString stamp: '<historical>'! ! 418815 418816!TraitDescription methodsFor: 'filein/out'! 418817commentStamp: changeStamp 418818 self organization commentStamp: changeStamp. 418819 ^ self commentStamp: changeStamp prior: 0! ! 418820 418821!TraitDescription methodsFor: 'filein/out'! 418822commentStamp: changeStamp prior: indexAndOffset 418823 "Prior source link ignored when filing in." 418824 418825 ^ ClassCommentReader new setClass: self 418826 category: #Comment 418827 changeStamp: changeStamp! ! 418828 418829!TraitDescription methodsFor: 'filein/out'! 418830definition 418831 "Answer a String that defines the receiver in good old ST-80." 418832 418833 ^ self definitionST80! ! 418834 418835!TraitDescription methodsFor: 'filein/out'! 418836fileOutCategory: catName 418837 418838 | internalStream | 418839 internalStream := (String new: 1000) writeStream. 418840 internalStream header; timeStamp. 418841 self fileOutCategory: catName on: internalStream moveSource: false toFile: 0. 418842 internalStream trailer. 418843 418844 ^ FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , catName) isSt: true.! ! 418845 418846!TraitDescription methodsFor: 'filein/out'! 418847fileOutChangedMessages: aSet on: aFileStream 418848 "File a description of the messages of the receiver that have been 418849 changed (i.e., are entered into the argument, aSet) onto aFileStream." 418850 418851 self fileOutChangedMessages: aSet 418852 on: aFileStream 418853 moveSource: false 418854 toFile: 0! ! 418855 418856!TraitDescription methodsFor: 'filein/out'! 418857fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex 418858 "File a description of the messages of this class that have been 418859 changed (i.e., are entered into the argument, aSet) onto aFileStream. If 418860 moveSource, is true, then set the method source pointer to the new file position. 418861 Note when this method is called with moveSource=true, it is condensing the 418862 .changes file, and should only write a preamble for every method." 418863 | org sels | 418864 (org := self organization) categories do: 418865 [:cat | 418866 sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. 418867 sels do: 418868 [:sel | self printMethodChunk: sel withPreamble: true on: aFileStream 418869 moveSource: moveSource toFile: fileIndex]]! ! 418870 418871!TraitDescription methodsFor: 'filein/out'! 418872fileOutMethod: selector 418873 "Write source code of a single method on a file. Make up a name for the file." 418874 418875 | internalStream | 418876 (selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.']. 418877 (self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found']. 418878 internalStream := (String new: 1000) writeStream. 418879 internalStream header; timeStamp. 418880 self printMethodChunk: selector withPreamble: true 418881 on: internalStream moveSource: false toFile: 0. 418882 418883 FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true.! ! 418884 418885!TraitDescription methodsFor: 'filein/out'! 418886fileOutOn: aFileStream 418887 "File a description of the receiver on aFileStream." 418888 418889 self fileOutOn: aFileStream 418890 moveSource: false 418891 toFile: 0! ! 418892 418893!TraitDescription methodsFor: 'filein/out'! 418894fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex 418895 "File a description of the receiver on aFileStream. If the boolean 418896 argument, moveSource, is true, then set the trailing bytes to the position 418897 of aFileStream and to fileIndex in order to indicate where to find the 418898 source code." 418899 418900 aFileStream nextChunkPut: self definition. 418901 418902 self organization 418903 putCommentOnFile: aFileStream 418904 numbered: fileIndex 418905 moveSource: moveSource 418906 forClass: self. 418907 self organization categories do: 418908 [:heading | 418909 self fileOutCategory: heading 418910 on: aFileStream 418911 moveSource: moveSource 418912 toFile: fileIndex]! ! 418913 418914!TraitDescription methodsFor: 'filein/out'! 418915fileOutOrganizationOn: aFileStream 418916 "File a description of the receiver's organization on aFileStream." 418917 418918 aFileStream cr; nextPut: $!!. 418919 aFileStream nextChunkPut: self name, ' reorganize'; cr. 418920 aFileStream nextChunkPut: self organization printString; cr! ! 418921 418922!TraitDescription methodsFor: 'filein/out'! 418923localMethods 418924 "returns the methods of classes including the ones of the traits that the class uses" 418925 418926 ^ self methods select: [:each | self includesLocalSelector: each selector].! ! 418927 418928!TraitDescription methodsFor: 'filein/out'! 418929methods 418930 "returns the methods of classes including the ones of the traits that the class uses" 418931 418932 ^ self methodDict values ! ! 418933 418934!TraitDescription methodsFor: 'filein/out'! 418935methodsFor: categoryName 418936 "Answer a ClassCategoryReader for compiling the messages in the category, categoryName, of the receiver." 418937 418938 ^ ClassCategoryReader new setClass: self category: categoryName asSymbol 418939 418940 "(False methodsFor: 'logical operations') inspect"! ! 418941 418942!TraitDescription methodsFor: 'filein/out'! 418943methodsFor: aString priorSource: sourcePosition inFile: fileIndex 418944 "Prior source pointer ignored when filing in." 418945 ^ self methodsFor: aString! ! 418946 418947!TraitDescription methodsFor: 'filein/out'! 418948methodsFor: categoryName stamp: changeStamp 418949 ^ self methodsFor: categoryName stamp: (Utilities fixStamp: changeStamp) prior: 0! ! 418950 418951!TraitDescription methodsFor: 'filein/out'! 418952methodsFor: categoryName stamp: changeStamp prior: indexAndOffset 418953 "Prior source link ignored when filing in." 418954 ^ ClassCategoryReader new setClass: self 418955 category: categoryName asSymbol 418956 changeStamp: changeStamp 418957 418958"Most importantly, return the new ClassCategoryReader, so a fileIn will let it seize control. So method will be placed in the proper category. See the transfer of control where ReadWriteStream fileIn calls scanFrom:"! ! 418959 418960!TraitDescription methodsFor: 'filein/out'! 418961printCategoryChunk: categoryName on: aFileStream 418962 ^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream! ! 418963 418964!TraitDescription methodsFor: 'filein/out'! 418965printCategoryChunk: category on: aFileStream priorMethod: priorMethod 418966 ^ self printCategoryChunk: category on: aFileStream 418967 withStamp: Utilities changeStamp priorMethod: priorMethod! ! 418968 418969!TraitDescription methodsFor: 'filein/out'! 418970printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod 418971 "Print a method category preamble. This must have a category name. 418972 It may have an author/date stamp, and it may have a prior source link. 418973 If it has a prior source link, it MUST have a stamp, even if it is empty." 418974 418975"The current design is that changeStamps and prior source links are preserved in the changes file. All fileOuts include changeStamps. Condensing sources, however, eliminates all stamps (and links, natch)." 418976 418977 aFileStream cr; nextPut: $!!. 418978 aFileStream nextChunkPut: (String streamContents: 418979 [:strm | 418980 strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString. 418981 (changeStamp ~~ nil and: 418982 [changeStamp size > 0 or: [priorMethod ~~ nil]]) ifTrue: 418983 [strm nextPutAll: ' stamp: '; print: changeStamp]. 418984 priorMethod ~~ nil ifTrue: 418985 [strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]]). 418986 ! ! 418987 418988!TraitDescription methodsFor: 'filein/out'! 418989printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream 418990 ^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp 418991 priorMethod: nil! ! 418992 418993!TraitDescription methodsFor: 'filein/out'! 418994putClassCommentToCondensedChangesFile: aFileStream 418995 "Called when condensing changes. If the receiver has a class comment, and if that class comment does not reside in the .sources file, then write it to the given filestream, with the resulting RemoteString being reachable from the source file #2. Note that any existing backpointer into the .sources file is lost by this process -- a situation that maybe should be fixed someday." 418996 418997 | header aStamp aCommentRemoteStr | 418998 self isMeta ifTrue: [^ self]. "bulletproofing only" 418999 ((aCommentRemoteStr := self organization commentRemoteStr) isNil or: 419000 [aCommentRemoteStr sourceFileNumber == 1]) ifTrue: [^ self]. 419001 419002 aFileStream cr; nextPut: $!!. 419003 header := String streamContents: [:strm | strm nextPutAll: self name; 419004 nextPutAll: ' commentStamp: '. 419005 (aStamp := self organization commentStamp ifNil: ['<historical>']) storeOn: strm. 419006 strm nextPutAll: ' prior: 0']. 419007 aFileStream nextChunkPut: header. 419008 aFileStream cr. 419009 self organization classComment: (RemoteString newString: self organization classComment onFileNumber: 2 toFile: aFileStream) stamp: aStamp! ! 419010 419011 419012!TraitDescription methodsFor: 'initialization' stamp: 'NS 4/8/2004 10:59'! 419013forgetDoIts 419014 "get rid of old DoIt methods and bogus entries in the ClassOrganizer." 419015 SystemChangeNotifier uniqueInstance doSilently: [ 419016 self organization 419017 removeElement: #DoIt; 419018 removeElement: #DoItIn:. 419019 ]. 419020 super forgetDoIts.! ! 419021 419022!TraitDescription methodsFor: 'initialization' stamp: 'NS 4/8/2004 11:01'! 419023obsolete 419024 "Make the receiver obsolete." 419025 self organization: nil. 419026 super obsolete! ! 419027 419028 419029!TraitDescription methodsFor: 'organization' stamp: 'al 3/18/2006 14:10'! 419030category 419031 self subclassResponsibility! ! 419032 419033!TraitDescription methodsFor: 'organization' stamp: 'al 3/18/2006 14:10'! 419034category: aString 419035 self subclassResponsibility! ! 419036 419037!TraitDescription methodsFor: 'organization'! 419038methodReferencesInCategory: aCategoryName 419039 ^(self organization listAtCategoryNamed: aCategoryName) 419040 collect: [:ea | MethodReference new 419041 setClassSymbol: self theNonMetaClass name 419042 classIsMeta: self isMeta 419043 methodSymbol: ea 419044 stringVersion: ''] 419045! ! 419046 419047!TraitDescription methodsFor: 'organization' stamp: 'NS 4/8/2004 11:03'! 419048organization 419049 "Answer the instance of ClassOrganizer that represents the organization 419050 of the messages of the receiver." 419051 419052 organization ifNil: 419053 [self organization: (ClassOrganizer defaultList: self methodDict keys asSortedCollection asArray)]. 419054 (organization isMemberOf: Array) ifTrue: 419055 [self recoverFromMDFaultWithTrace]. 419056 419057 "Making sure that subject is set correctly. It should not be necessary." 419058 organization ifNotNil: [organization setSubject: self]. 419059 ^ organization! ! 419060 419061!TraitDescription methodsFor: 'organization' stamp: 'NS 4/8/2004 11:04'! 419062organization: aClassOrg 419063 "Install an instance of ClassOrganizer that represents the organization of the messages of the receiver." 419064 419065 aClassOrg ifNotNil: [aClassOrg setSubject: self]. 419066 organization := aClassOrg! ! 419067 419068!TraitDescription methodsFor: 'organization'! 419069reorganize 419070 "During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization. See the transfer of control where ReadWriteStream fileIn calls scanFrom:" 419071 419072 ^self organization! ! 419073 419074!TraitDescription methodsFor: 'organization'! 419075whichCategoryIncludesSelector: aSelector 419076 "Answer the category of the argument, aSelector, in the organization of 419077 the receiver, or answer nil if the receiver does not inlcude this selector." 419078 419079 (self includesSelector: aSelector) 419080 ifTrue: [^ self organization categoryOfElement: aSelector] 419081 ifFalse: [^nil]! ! 419082 419083!TraitDescription methodsFor: 'organization'! 419084zapOrganization 419085 "Remove the organization of this class by message categories. 419086 This is typically done to save space in small systems. Classes and methods 419087 created or filed in subsequently will, nonetheless, be organized" 419088 419089 self organization: nil. 419090 self isClassSide ifFalse: [self classSide zapOrganization]! ! 419091 419092 419093!TraitDescription methodsFor: 'organization updating'! 419094applyChangesOfNewTraitCompositionReplacing: oldComposition 419095 | changedSelectors | 419096 changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. 419097 self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition. 419098 ^ changedSelectors.! ! 419099 419100!TraitDescription methodsFor: 'organization updating'! 419101noteRecategorizedSelectors: aCollection oldComposition: aTraitComposition 419102 | oldCategory newCategory | 419103 aCollection do: [:each | 419104 oldCategory := self organization categoryOfElement: each. 419105 newCategory := (self traitComposition methodDescriptionForSelector: each) effectiveMethodCategory. 419106 self noteRecategorizedSelector: each from: oldCategory to: newCategory]! ! 419107 419108!TraitDescription methodsFor: 'organization updating'! 419109noteRecategorizedSelector: aSymbol from: oldCategoryOrNil to: newCategoryOrNil 419110 | changedCategories | 419111 changedCategories := self updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil. 419112 changedCategories do: [:each | 419113 (self organization isEmptyCategoryNamed: each) ifTrue: [self organization removeCategory: each]]! ! 419114 419115!TraitDescription methodsFor: 'organization updating' stamp: 'al 12/1/2005 15:50'! 419116notifyOfRecategorizedSelector: element from: oldCategory to: newCategory 419117 SystemChangeNotifier uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self. 419118 SystemChangeNotifier uniqueInstance 419119 doSilently: [self notifyUsersOfRecategorizedSelector: element from: oldCategory to: newCategory].! ! 419120 419121!TraitDescription methodsFor: 'organization updating'! 419122updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil 419123 | currentCategory effectiveCategory sel changedCategories composition | 419124 changedCategories := IdentitySet new. 419125 composition := self hasTraitComposition 419126 ifTrue: [self traitComposition] 419127 ifFalse: [TraitComposition new]. 419128 (composition methodDescriptionsForSelector: aSymbol) do: [:each | 419129 sel := each selector. 419130 (self includesLocalSelector: sel) ifFalse: [ 419131 currentCategory := self organization categoryOfElement: sel. 419132 effectiveCategory := each effectiveMethodCategoryCurrent: currentCategory new: newCategoryOrNil. 419133 effectiveCategory isNil ifTrue: [ 419134 currentCategory ifNotNil: [changedCategories add: currentCategory]. 419135 self organization removeElement: sel. 419136 ] ifFalse: [ 419137 ((currentCategory isNil or: [currentCategory == ClassOrganizer ambiguous or: [currentCategory == oldCategoryOrNil]]) and: [currentCategory ~~ effectiveCategory]) ifTrue: [ 419138 currentCategory ifNotNil: [changedCategories add: currentCategory]. 419139 self organization 419140 classify: sel 419141 under: effectiveCategory 419142 suppressIfDefault: false]]]]. 419143 ^ changedCategories! ! 419144 419145 419146!TraitDescription methodsFor: 'printing'! 419147printOnStream: aStream 419148 aStream print: self name! ! 419149 419150!TraitDescription methodsFor: 'printing'! 419151printOn: aStream 419152 aStream nextPutAll: self name! ! 419153 419154!TraitDescription methodsFor: 'printing'! 419155storeOn: aStream 419156 "Classes and Metaclasses have global names." 419157 419158 aStream nextPutAll: self name! ! 419159 419160 419161!TraitDescription methodsFor: 'testing' stamp: 'al 4/9/2004 15:28'! 419162isTestCase 419163 ^false! ! 419164 419165 419166!TraitDescription methodsFor: 'users notification' stamp: 'NS 4/12/2004 15:45'! 419167notifyUsersOfChangedSelectors: aCollection 419168 self users do: [:each | 419169 each noteChangedSelectors: aCollection]! ! 419170 419171!TraitDescription methodsFor: 'users notification' stamp: 'NS 4/12/2004 21:46'! 419172notifyUsersOfRecategorizedSelector: element from: oldCategory to: newCategory 419173 self users do: [:each | 419174 each noteRecategorizedSelector: element from: oldCategory to: newCategory]! ! 419175 419176 419177!TraitDescription methodsFor: 'private'! 419178addCompositionOnLeft: aTraitComposition 419179 ^ aTraitComposition add: self! ! 419180 419181!TraitDescription methodsFor: 'private'! 419182addOnTheLeft: aTraitExpression 419183 ^TraitComposition with: aTraitExpression with: self! ! 419184 419185!TraitDescription methodsFor: 'private'! 419186errorCategoryName 419187 self error: 'Category name must be a String'! ! 419188 419189!TraitDescription methodsFor: 'private' stamp: 'marcus.denker 8/25/2008 12:05'! 419190linesOfCode 419191 "An approximate measure of lines of code. 419192 Includes comments, but excludes blank lines." 419193 | lines | 419194 lines := self localMethods inject: 0 into: [:sum :each | sum + each linesOfCode]. 419195 self isMeta 419196 ifTrue: [^ lines] 419197 ifFalse: [^ lines + self class linesOfCode]! ! 419198 419199!TraitDescription methodsFor: 'private' stamp: 'alain.plantec 5/18/2009 08:41'! 419200logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor 419201 aCompiledMethodWithNode method 419202 putSource: aText 419203 fromParseNode: aCompiledMethodWithNode node 419204 class: self 419205 category: category 419206 withStamp: changeStamp 419207 inFile: 2 419208 priorMethod: (self 419209 compiledMethodAt: aCompiledMethodWithNode selector 419210 ifAbsent: [])! ! 419211 419212!TraitDescription methodsFor: 'private' stamp: 'md 8/11/2006 14:38'! 419213numberOfMethods 419214 "cound all methods that are local (not comming from a trait)" 419215 | num | 419216 num := (methodDict values select: [:each | self includesLocalSelector: each selector]) size. 419217 self isMeta 419218 ifTrue: [^ num] 419219 ifFalse: [^ num + self class numberOfMethods]! ! 419220 419221!TraitDescription methodsFor: 'private' stamp: 'al 7/30/2004 11:49'! 419222spaceUsed 419223 ^super spaceUsed + (self hasClassTrait 419224 ifTrue: [self classTrait spaceUsed] 419225 ifFalse: [0])! ! 419226 419227 419228!TraitDescription methodsFor: 'deprecated'! 419229commentFollows 419230 "Answer a ClassCommentReader that will scan in the comment." 419231 self deprecated: 'Use a ClassCommentReader instead.'. 419232 419233 ^ ClassCommentReader forClass: self 419234! ! 419235 419236"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 419237 419238TraitDescription class 419239 uses: TComposingDescription classTrait + TTransformationCompatibility classTrait + TClassAndTraitDescription classTrait 419240 instanceVariableNames: ''! 419241Error subclass: #TraitException 419242 instanceVariableNames: '' 419243 classVariableNames: '' 419244 poolDictionaries: '' 419245 category: 'Traits-Kernel'! 419246!TraitException commentStamp: '<historical>' prior: 0! 419247General exception used for example to signal invalid trait compositions! 419248 419249 419250"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 419251 419252TraitException class 419253 instanceVariableNames: ''! 419254TraitTransformation subclass: #TraitExclusion 419255 instanceVariableNames: 'exclusions' 419256 classVariableNames: '' 419257 poolDictionaries: '' 419258 category: 'Traits-Composition'! 419259!TraitExclusion commentStamp: '<historical>' prior: 0! 419260See comment of my superclass TraitTransformation.! 419261 419262 419263!TraitExclusion methodsFor: 'accessing' stamp: 'al 12/7/2003 11:58'! 419264exclusions 419265 ^exclusions! ! 419266 419267!TraitExclusion methodsFor: 'accessing' stamp: 'al 12/7/2003 11:58'! 419268exclusions: aCollection 419269 exclusions := aCollection! ! 419270 419271!TraitExclusion methodsFor: 'accessing' stamp: 'dvf 8/19/2005 12:25'! 419272methodReferencesInCategory: aCategoryName 419273 ^(self organization listAtCategoryNamed: aCategoryName) 419274 collect: [:ea | MethodReference new 419275 setClassSymbol: self theNonMetaClass name 419276 classIsMeta: self isMeta 419277 methodSymbol: ea 419278 stringVersion: ''] 419279! ! 419280 419281 419282!TraitExclusion methodsFor: 'composition' stamp: 'al 4/9/2004 16:55'! 419283addExclusionOf: aSymbol 419284 self exclusions: (self exclusions copyWith: aSymbol)! ! 419285 419286 419287!TraitExclusion methodsFor: 'copying' stamp: 'al 4/9/2004 19:12'! 419288copy 419289 ^super copy 419290 exclusions: self exclusions copy; 419291 yourself! ! 419292 419293!TraitExclusion methodsFor: 'copying' stamp: 'dvf 8/25/2005 16:07'! 419294copyTraitExpression 419295 ^super copyTraitExpression 419296 exclusions: self exclusions deepCopy; 419297 yourself! ! 419298 419299 419300!TraitExclusion methodsFor: 'enquiries' stamp: 'al 3/7/2004 22:48'! 419301allSelectors 419302 | selectors | 419303 selectors := self subject allSelectors. 419304 self exclusions do: [:each | 419305 selectors remove: each ifAbsent: []]. 419306 ^selectors! ! 419307 419308!TraitExclusion methodsFor: 'enquiries' stamp: 'al 3/4/2004 16:35'! 419309collectMethodsFor: aSelector into: methodDescription 419310 (self exclusions includes: aSelector) ifFalse: [ 419311 self subject 419312 collectMethodsFor: aSelector 419313 into: methodDescription]! ! 419314 419315 419316!TraitExclusion methodsFor: 'printing' stamp: 'al 2/22/2004 21:45'! 419317printOn: aStream 419318 super printOn: aStream. 419319 aStream 419320 space; 419321 nextPut: $-; 419322 space; 419323 nextPut: ${. 419324 self exclusions do: [:each | aStream print: each] 419325 separatedBy: [aStream nextPutAll: '. ']. 419326 aStream nextPut: $}! ! 419327 419328 419329!TraitExclusion methodsFor: 'testing' stamp: 'al 4/10/2004 23:56'! 419330isEmpty 419331 ^self exclusions isEmpty! ! 419332 419333"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 419334 419335TraitExclusion class 419336 instanceVariableNames: ''! 419337 419338!TraitExclusion class methodsFor: 'instance creation' stamp: 'dvf 8/18/2005 17:36'! 419339with: aTraitComposition exclusions: anArrayOfSelectors 419340 ^self new 419341 subject: aTraitComposition; 419342 exclusions: anArrayOfSelectors; 419343 yourself 419344! ! 419345TraitsTestCase subclass: #TraitFileOutTest 419346 instanceVariableNames: 'ca cb ta tb tc td' 419347 classVariableNames: '' 419348 poolDictionaries: '' 419349 category: 'Tests-Traits'! 419350 419351!TraitFileOutTest methodsFor: 'running' stamp: 'al 4/25/2004 16:29'! 419352categoryName 419353 ^'Traits-Tests-FileOut'! ! 419354 419355!TraitFileOutTest methodsFor: 'running' stamp: 'al 4/25/2004 13:26'! 419356setUp 419357 super setUp. 419358 SystemOrganization addCategory: self categoryName. 419359 419360 td := self createTraitNamed: #TD uses: {}. 419361 td compile: 'd' classified: #cat1. 419362 tc := self createTraitNamed: #TC uses: td. 419363 tc compile: 'c' classified: #cat1. 419364 tb := self createTraitNamed: #TB uses: td. 419365 tb compile: 'b' classified: #cat1. 419366 ta := self createTraitNamed: #TA uses: tb + tc @ {#cc->#c} - {#c}. 419367 ta compile: 'a' classified: #cat1. 419368 419369 ca := self createClassNamed: #CA superclass: Object uses: {}. 419370 ca compile: 'ca' classified: #cat1. 419371 cb := self createClassNamed: #CB superclass: ca uses: ta. 419372 cb compile: 'cb' classified: #cat1. 419373 419374 "make the class of cb also use tc:" 419375 cb class uses: ta classTrait + tc instanceVariableNames: ''.! ! 419376 419377!TraitFileOutTest methodsFor: 'running' stamp: 'dvf 8/30/2005 15:07'! 419378tearDown 419379 | dir | 419380 dir := FileDirectory default. 419381 self createdClassesAndTraits, self resourceClassesAndTraits do: [:each | 419382 dir deleteFileNamed: each asString , '.st' ifAbsent: []]. 419383 dir deleteFileNamed: self categoryName , '.st' ifAbsent: []. 419384 SystemOrganization removeSystemCategory: self categoryName. 419385 super tearDown! ! 419386 419387 419388!TraitFileOutTest methodsFor: 'testing' stamp: 'al 7/19/2004 20:50'! 419389testFileOutCategory 419390 "File out whole system category, delete all classes and traits and then 419391 file them in again." 419392 419393 "self run: #testFileOutCategory" 419394 419395 | file | 419396 SystemOrganization fileOutCategory: self categoryName. 419397 SystemOrganization removeSystemCategory: self categoryName. 419398 self deny: (Smalltalk keys includesAnyOf: #(CA CB TA TB TC TD)). 419399 [ file := FileStream readOnlyFileNamed: self categoryName , '.st'. 419400 file fileIn] 419401 ensure: [file close]. 419402 419403 self assert: (Smalltalk keys includesAllOf: #(CA CB TA TB TC TD)). 419404 419405 ta := Smalltalk at: #TA. 419406 self assert: ta traitComposition asString = 'TB + TC @ {#cc->#c} - {#c}'. 419407 self assert: (ta methodDict keys includesAllOf: #(a b cc)). 419408 419409 cb := Smalltalk at: #CB. 419410 self assert: cb traitComposition asString = 'TA'. 419411 self assert: (cb methodDict keys includesAllOf: #(cb a b cc)). 419412 419413 "test classSide traitComposition of CB" 419414 419415 self assert: cb classSide traitComposition asString = 'TA classTrait + TC'. 419416 self assert: (cb classSide methodDict keys includesAllOf: #(d c)) 419417 ! ! 419418 419419!TraitFileOutTest methodsFor: 'testing' stamp: 'al 12/1/2005 16:30'! 419420testFileOutTrait 419421 "fileOut trait T6, remove it from system and then file it in again" 419422 419423 "self run: #testFileOutTrait" 419424 419425 | fileName file | 419426 self t6 compile: 'localMethod: argument ^argument'. 419427 self t6 classSide compile: 'localClassSideMethod: argument ^argument'. 419428 self t6 fileOut. 419429 fileName := self t6 asString , '.st'. 419430 self resourceClassesAndTraits remove: self t6. 419431 self t6 removeFromSystem. 419432 419433 [file := FileStream readOnlyFileNamed: fileName. 419434 file fileIn] 419435 ensure: [file close]. 419436 self assert: (Smalltalk includesKey: #T6). 419437 TraitsResource current t6: (Smalltalk at: #T6). 419438 self resourceClassesAndTraits add: self t6. 419439 self 419440 assert: self t6 traitComposition asString = 'T1 + T2 @ {#m22Alias->#m22}'. 419441 self 419442 assert: (self t6 methodDict keys includesAllOf: #( 419443 #localMethod: 419444 #m11 419445 #m12 419446 #m13 419447 #m21 419448 #m22 419449 #m22Alias 419450 )). 419451 self assert: self t6 classSide methodDict size = 2. 419452 self 419453 assert: (self t6 classSide methodDict keys includesAllOf: #(#localClassSideMethod: #m2ClassSide: ))! ! 419454 419455!TraitFileOutTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'! 419456testRemovingMethods 419457 "When removing a local method, assure that the method 419458 from the trait is installed instead and that the users are 419459 updated." 419460 419461 "self run: #testRemovingMethods" 419462 419463 "Classes" 419464 419465 self c2 compile: 'm12 ^0' classified: #xxx. 419466 self assert: (self c2 includesLocalSelector: #m12). 419467 self c2 removeSelector: #m12. 419468 self deny: (self c2 includesLocalSelector: #m12). 419469 self assert: (self c2 selectors includes: #m12). 419470 419471 "Traits" 419472 self t5 compile: 'm12 ^0' classified: #xxx. 419473 self assert: self c2 new m12 = 0. 419474 self t5 removeSelector: #m12. 419475 self deny: (self t5 includesLocalSelector: #m12). 419476 self assert: (self t5 selectors includes: #m12). 419477 self assert: self c2 new m12 = 12! ! 419478Object subclass: #TraitMethodDescription 419479 instanceVariableNames: 'selector locatedMethods' 419480 classVariableNames: '' 419481 poolDictionaries: '' 419482 category: 'Traits-Composition'! 419483!TraitMethodDescription commentStamp: '<historical>' prior: 0! 419484Used by TraitComposition to encapsulates a collection of methods for one particular selector when querying for changes. According to the number and kind of those methods a provided method exists, there is a conflict or there are no provided nor conflicting methods at all. I provide the interface to query for those situations, e.g., effectiveMethod returns the provided method or the conflict marker method. 419485! 419486 419487 419488!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 1/23/2004 10:20'! 419489addLocatedMethod: aLocatedMethod 419490 locatedMethods add: aLocatedMethod! ! 419491 419492!TraitMethodDescription methodsFor: 'accessing' stamp: 'AdrianLienhard 10/18/2009 14:04'! 419493conflictMethod 419494 | method argumentNames binary numberOfArguments | 419495 self isConflict ifFalse: [^nil]. 419496 argumentNames := self getArgumentNames. 419497 binary := self isBinarySelector. 419498 numberOfArguments := binary 419499 ifTrue: [1] 419500 ifFalse: [argumentNames size + 2]. 419501 ^self 419502 generateMethod: self selector 419503 withMarker: CompiledMethod conflictMarker 419504 forArgs: argumentNames size 419505 binary: binary! ! 419506 419507!TraitMethodDescription methodsFor: 'accessing' stamp: 'NS 4/19/2004 16:13'! 419508effectiveMethod 419509 "Return the effective compiled method of this method description." 419510 419511 | locatedMethod method | 419512 method := self providedMethod. 419513 method isNil ifFalse: [^ method]. 419514 method := self conflictMethod. 419515 method isNil ifFalse: [^ method]. 419516 ^ self requiredMethod.! ! 419517 419518!TraitMethodDescription methodsFor: 'accessing' stamp: 'NS 4/16/2004 15:06'! 419519effectiveMethodCategory 419520 ^ self effectiveMethodCategoryCurrent: nil new: nil! ! 419521 419522!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 7/22/2004 14:50'! 419523effectiveMethodCategoryCurrent: currentCategoryOrNil new: newCategoryOrNil 419524 | isCurrent result cat size isConflict | 419525 size := self size. 419526 size = 0 ifTrue: [^ nil]. 419527 result := self locatedMethods anyOne category. 419528 size = 1 ifTrue: [^ result]. 419529 419530 isCurrent := currentCategoryOrNil isNil. 419531 isConflict := false. 419532 self locatedMethods do: [:each | 419533 cat := each category. 419534 isCurrent := isCurrent or: [cat == currentCategoryOrNil]. 419535 isConflict := isConflict or: [cat ~~ result]]. 419536 isConflict ifFalse: [^ result]. 419537 (isCurrent not and: [newCategoryOrNil notNil]) ifTrue: [^ newCategoryOrNil]. 419538 ^ ClassOrganizer ambiguous.! ! 419539 419540!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 1/23/2004 10:20'! 419541locatedMethods 419542 ^locatedMethods! ! 419543 419544!TraitMethodDescription methodsFor: 'accessing' stamp: 'ab 4/15/2009 00:20'! 419545providedLocatedMethod 419546 | locatedMethod aLocatedMethod refOrigin | 419547 locatedMethod := nil. 419548 self locatedMethods ifEmpty: [ ^ nil]. 419549 419550 self locatedMethods size > 1 419551 ifTrue: [ aLocatedMethod := self locatedMethods anyOne. 419552 refOrigin := (aLocatedMethod location >> aLocatedMethod selector) origin. 419553 (self locatedMethods 419554 allSatisfy: [:each | each method origin == refOrigin]) 419555 ifTrue: [^ aLocatedMethod]. ]. 419556 419557 self locatedMethods do: [:each | 419558 each method isProvided ifTrue: [ 419559 locatedMethod isNil ifFalse: [^nil]. 419560 locatedMethod := each]]. 419561 ^locatedMethod! ! 419562 419563!TraitMethodDescription methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! 419564providedMethod 419565 ^self providedLocatedMethod ifNotNil: [:locatedMethod | locatedMethod method]! ! 419566 419567!TraitMethodDescription methodsFor: 'accessing' stamp: 'adrian_lienhard 1/31/2009 21:33'! 419568requiredMethod 419569 | templateMethod argumentNames numberOfArguments binary | 419570 self isRequired ifFalse: [^nil]. 419571 self size = 1 ifTrue: [^self locatedMethods anyOne method]. 419572 419573 argumentNames := self getArgumentNames. 419574 binary := self isBinarySelector. 419575 numberOfArguments := binary 419576 ifTrue: [1] 419577 ifFalse: [argumentNames size + 2]. 419578 templateMethod := self 419579 generateMethod: self selector 419580 withMarker: CompiledMethod implicitRequirementMarker 419581 forArgs: argumentNames size 419582 binary: binary. 419583 ^templateMethod copyWithTempNames: argumentNames! ! 419584 419585!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 1/23/2004 10:19'! 419586selector 419587 ^selector! ! 419588 419589!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 1/23/2004 10:19'! 419590selector: aSymbol 419591 selector := aSymbol! ! 419592 419593!TraitMethodDescription methodsFor: 'accessing' stamp: 'al 1/23/2004 12:54'! 419594size 419595 ^self locatedMethods size! ! 419596 419597 419598!TraitMethodDescription methodsFor: 'enumeration' stamp: 'al 7/22/2004 14:50'! 419599methodsDo: aBlock 419600 self locatedMethods do: [:each | 419601 aBlock value: each method]! ! 419602 419603 419604!TraitMethodDescription methodsFor: 'initialization' stamp: 'NS 3/30/2004 16:12'! 419605initialize 419606 super initialize. 419607 locatedMethods := Set new! ! 419608 419609 419610!TraitMethodDescription methodsFor: 'testing' stamp: 'al 4/10/2004 23:29'! 419611isAliasSelector 419612 "Return true if the selector is an alias (if it is different 419613 from the original selector) or already an aliased method 419614 in the original location (recursively search the compositions). 419615 Return false, if not or if we have a conflict." 419616 419617 | locatedMethod | 419618 ^self size = 1 and: [ 419619 locatedMethod := self locatedMethods anyOne. 419620 (locatedMethod selector ~= self selector) or: [ 419621 locatedMethod location isAliasSelector: self selector]]! ! 419622 419623!TraitMethodDescription methodsFor: 'testing' stamp: 'al 2/20/2004 22:18'! 419624isBinarySelector 419625 ^self locatedMethods anyOne 419626 isBinarySelector! ! 419627 419628!TraitMethodDescription methodsFor: 'testing' stamp: 'ab 4/15/2009 00:19'! 419629isConflict 419630 | count originMethodReferenciel | 419631 count := 0. 419632 419633 self locatedMethods size > 1 419634 ifTrue: 419635 ["If they are more than 1 located method, then check whether these methods have the same origin" 419636 originMethodReferenciel := self locatedMethods anyOne method origin. 419637 ((self locatedMethods collect: [:lm | lm method]) allSatisfy: [:each | each method origin == originMethodReferenciel]) 419638 ifTrue: [ ^ false ]]. 419639 419640 self methodsDo: [:each | 419641 each isProvided ifTrue: [ 419642 count := count + 1. 419643 count > 1 ifTrue: [^true]]]. 419644 ^false! ! 419645 419646!TraitMethodDescription methodsFor: 'testing' stamp: 'al 1/23/2004 10:31'! 419647isEmpty 419648 ^self size = 0! ! 419649 419650!TraitMethodDescription methodsFor: 'testing' stamp: 'al 4/10/2004 23:34'! 419651isLocalAliasSelector 419652 "Return true if the selector is an alias (if it is different 419653 from the original selector). Return false, if not or if we 419654 have a conflict." 419655 419656 ^self size = 1 and: [ 419657 (self locatedMethods anyOne selector ~= self selector)]! ! 419658 419659!TraitMethodDescription methodsFor: 'testing' stamp: 'NS 4/19/2004 16:10'! 419660isProvided 419661 ^ self providedMethod notNil! ! 419662 419663!TraitMethodDescription methodsFor: 'testing' stamp: 'NS 4/21/2004 12:29'! 419664isRequired 419665 self isEmpty ifTrue: [^ false]. 419666 ^ self locatedMethods allSatisfy: [:each | each method isRequired]! ! 419667 419668 419669!TraitMethodDescription methodsFor: 'private' stamp: 'AdrianLienhard 10/18/2009 14:00'! 419670generateMethod: aSelector withMarker: aSymbol forArgs: aNumber binary: aBoolean 419671 | source node | 419672 source := String streamContents: [:stream | 419673 aNumber < 1 419674 ifTrue: [stream nextPutAll: 'selector'] 419675 ifFalse: [aBoolean 419676 ifTrue: [ 419677 stream nextPutAll: '* anObject'] 419678 ifFalse: [ 419679 1 to: aNumber do: [:argumentNumber | 419680 stream 419681 nextPutAll: 'with:'; space; 419682 nextPutAll: 'arg'; nextPutAll: argumentNumber asString; space]]]. 419683 stream cr; tab; nextPutAll: 'self '; nextPutAll: aSymbol]. 419684 419685 node := self class compilerClass new 419686 compile: source 419687 in: self class 419688 notifying: nil 419689 ifFail: []. 419690 ^(node generate) selector: aSelector; yourself! ! 419691 419692!TraitMethodDescription methodsFor: 'private' stamp: 'al 3/12/2004 17:04'! 419693getArgumentNames 419694 | argumentNamesCollection names defaultName | 419695 defaultName := 'arg'. 419696 argumentNamesCollection := self locatedMethods 419697 collect: [:each | each argumentNames ]. 419698 names := Array new: argumentNamesCollection anyOne size. 419699 argumentNamesCollection do: [:collection | 419700 1 to: names size do: [:index | 419701 (names at: index) isNil 419702 ifTrue: [names at: index put: (collection at: index)] 419703 ifFalse: [(names at: index) ~= (collection at: index) 419704 ifTrue: [names at: index put: defaultName, index asString]]]]. 419705 ^names 419706 ! ! 419707 419708"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 419709 419710TraitMethodDescription class 419711 instanceVariableNames: ''! 419712 419713!TraitMethodDescription class methodsFor: 'instance creation' stamp: 'al 1/23/2004 12:52'! 419714new 419715 ^super new 419716 initialize; 419717 yourself! ! 419718 419719!TraitMethodDescription class methodsFor: 'instance creation' stamp: 'al 1/23/2004 13:04'! 419720selector: aSymbol 419721 ^self new 419722 selector: aSymbol 419723 yourself! ! 419724 419725 419726!TraitMethodDescription class methodsFor: 'private' stamp: 'NS 4/19/2004 16:26'! 419727maxArguments 419728 ^30! ! 419729TraitsTestCase subclass: #TraitMethodDescriptionTest 419730 instanceVariableNames: '' 419731 classVariableNames: '' 419732 poolDictionaries: '' 419733 category: 'Tests-Traits'! 419734 419735!TraitMethodDescriptionTest methodsFor: 'running' stamp: 'AdrianLienhard 10/18/2009 14:04'! 419736testArgumentNames 419737 self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. 419738 self t2 compile: 'zork1: myArgument zork2: somethingElse ^false'. 419739 self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString 419740 beginsWith: 'zork1: t1 zork2: t2'). 419741 self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. 419742 self t2 compile: 'zork1: somethingElse zork2: myArgument ^false'. 419743 self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString 419744 beginsWith: 'zork1: t1 zork2: t2')! ! 419745 419746!TraitMethodDescriptionTest methodsFor: 'running' stamp: 'dvf 8/26/2005 14:33'! 419747testCategories 419748 self assert: (self t4 organization categoryOfElement: #m21) = #cat1. 419749 self assert: (self t4 organization categoryOfElement: #m22) = #cat2. 419750 self assert: (self t4 organization categoryOfElement: #m11) = #catX. 419751 self assert: (self t4 organization categoryOfElement: #m12) = #cat2. 419752 self assert: (self t4 organization categoryOfElement: #m13) = #cat3. 419753 self assert: (self t6 organization categoryOfElement: #m22Alias) = #cat2. 419754 self t2 organization classify: #m22 under: #catX. 419755 self assert: (self t4 organization categoryOfElement: #m22) = #catX. 419756 self assert: (self t6 organization categoryOfElement: #m22Alias) = #catX. 419757 self t6 organization classify: #m22 under: #catY. 419758 self t6 organization classify: #m22Alias under: #catY. 419759 self t2 organization classify: #m22 under: #catZ. 419760 self assert: (self t6 organization categoryOfElement: #m22) = #catY. 419761 self assert: (self t6 organization categoryOfElement: #m22Alias) = #catY. 419762 self t1 compile: 'mA' classified: #catA. 419763 self assert: (self t4 organization categoryOfElement: #mA) = #catA. 419764 self t1 organization classify: #mA under: #cat1. 419765 self assert: (self t4 organization categories includes: #catA) not! ! 419766 419767!TraitMethodDescriptionTest methodsFor: 'running' stamp: 'dvf 8/26/2005 14:31'! 419768testConflictingCategories 419769 | t7 t8 | 419770 self t2 compile: 'm11' classified: #catY. 419771 self assert: (self t4 organization categoryOfElement: #m11) = #catX. 419772 self assert: (self t5 organization categoryOfElement: #m11) = #cat1. 419773 t7 := self createTraitNamed: #T7 uses: self t1 + self t2. 419774 self assert: (t7 organization categoryOfElement: #m11) 419775 = ClassOrganizer ambiguous. 419776 self t1 removeSelector: #m11. 419777 self assert: (self t4 organization categoryOfElement: #m11) = #catX. 419778 self assert: (self t5 organization categoryOfElement: #m11) = #catY. 419779 self assert: (t7 organization categoryOfElement: #m11) = #catY. 419780 self 419781 assert: (t7 organization categories includes: ClassOrganizer ambiguous) not. 419782 self t1 compile: 'm11' classified: #cat1. 419783 t8 := self createTraitNamed: #T8 uses: self t1 + self t2. 419784 t8 organization classify: #m11 under: #cat1. 419785 self t1 organization classify: #m11 under: #catZ. 419786 self assert: (self t4 organization categoryOfElement: #m11) = #catX. 419787 self assert: (self t5 organization categoryOfElement: #m11) = #catY. 419788 self assert: (t8 organization categoryOfElement: #m11) = #catZ! ! 419789 419790!TraitMethodDescriptionTest methodsFor: 'running' stamp: 'AdrianLienhard 10/18/2009 14:03'! 419791testConflictMethodCreation 419792 "Generate conflicting methods between t1 and t2 419793 and check the resulting method in Trait t5 (or c2). 419794 Also test selectors like foo:x (without space) or selectors with CRs." 419795 419796 "unary" 419797 419798 self t2 compile: 'm12 ^false'. 419799 self assert: ((self t5 sourceCodeAt: #m12) asString beginsWith: 'm12'). 419800 self should: [self c2 new m12] raise: Error. 419801 419802 "binary" 419803 self t1 compile: '@ myArgument ^true'. 419804 self t2 compile: '@myArgument ^false'. 419805 self 419806 assert: ((self t5 sourceCodeAt: #@) asString beginsWith: '@ t1'). 419807 self should: [self c2 new @ 17] raise: Error. 419808 419809 "keyword" 419810 self t1 compile: 'zork: myArgument 419811 ^true'. 419812 self t2 compile: 'zork: myArgument ^false'. 419813 self assert: ((self t5 sourceCodeAt: #zork:) asString 419814 beginsWith: 'zork: t1'). 419815 self should: [self c2 new zork: 17] raise: Error. 419816 self t1 compile: 'zork:myArgument ^true'. 419817 self t2 compile: 'zork:myArgument ^false'. 419818 self assert: ((self t5 sourceCodeAt: #zork:) asString 419819 beginsWith: 'zork: t1'). 419820 self should: [self c2 new zork: 17] raise: Error. 419821 self t1 compile: 'zork1: t1 zork2: t2 ^true'. 419822 self t2 compile: 'zork1: anObject zork2: anotherObject ^false'. 419823 self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString 419824 beginsWith: 'zork1: t1 zork2: t2'). 419825 self should: [self c2 new zork1: 1 zork2: 2] raise: Error! ! 419826 419827!TraitMethodDescriptionTest methodsFor: 'running' stamp: 'al 1/23/2004 12:57'! 419828testInitialize 419829 | empty | 419830 empty := TraitMethodDescription new. 419831 self assert: empty isEmpty. 419832 self deny: empty isConflict. 419833 self deny: empty isProvided. 419834 self deny: empty isRequired! ! 419835TraitsTestCase subclass: #TraitTest 419836 instanceVariableNames: '' 419837 classVariableNames: '' 419838 poolDictionaries: '' 419839 category: 'Tests-Traits'! 419840 419841!TraitTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'! 419842testAddAndRemoveMethodsFromSubtraits 419843 | aC2 | 419844 aC2 := self c2 new. 419845 self assert: aC2 m51. 419846 self t5 removeSelector: #m51. 419847 self should: [aC2 m51] raise: MessageNotUnderstood. 419848 self t1 compile: 'foo ^true'. 419849 self deny: aC2 foo. 419850 self t1 compile: 'm51 ^self'. 419851 self shouldnt: [aC2 m51] raise: MessageNotUnderstood. 419852 self assert: aC2 m51 == aC2! ! 419853 419854!TraitTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:32'! 419855testAddAndRemoveMethodsInClassOrTrait 419856 | aC2 | 419857 aC2 := self c2 new. 419858 self assert: aC2 m51. 419859 self c2 compile: 'm51 ^123'. 419860 self assert: aC2 m51 = 123. 419861 self c2 removeSelector: #m51. 419862 self shouldnt: [aC2 m51] raise: MessageNotUnderstood. 419863 self assert: aC2 m51. 419864 self t4 removeSelector: #m11. 419865 self assert: (self t4 methodDict includesKey: #m11)! ! 419866 419867!TraitTest methodsFor: 'testing' stamp: 'ms 5/8/2007 19:23'! 419868testAllClassVarNames 419869 419870 419871 self assert: self t1 allClassVarNames isEmpty! ! 419872 419873!TraitTest methodsFor: 'testing' stamp: 'dvf 8/30/2005 14:10'! 419874testCompositionCopy 419875 | t6compositionCopyFirst c2compositionCopy | 419876 self assert: (self t1 + self t2) allTraits 419877 = (self t1 + self t2) copyTraitExpression allTraits. 419878 self assert: (self t1 classTrait + self t2 classTrait) allTraits 419879 = (self t1 classTrait + self t2 classTrait) copyTraitExpression allTraits. 419880 self assert: self t6 traitComposition allTraits 419881 = self t6 traitComposition copyTraitExpression allTraits. 419882 self 419883 assert: self t6 asTraitComposition copyTraitExpression allTraits = { (self t1). (self t2). (self t6) }. 419884 "make no undue sharing happens of exclusions and aliases after an expression copy" 419885 t6compositionCopyFirst := self t6 traitComposition copyTraitExpression. 419886 t6compositionCopyFirst transformations at: 1 put: #m22Alias -> #m33. 419887 self 419888 assert: self t6 traitComposition transformations second aliases first value 419889 = #m22. 419890 c2compositionCopy := self c2 traitComposition copyTraitExpression. 419891 c2compositionCopy transformations first exclusions at: 1 put: #m4. 419892 self c2 traitComposition transformations first exclusions = #(#m11 )! ! 419893 419894!TraitTest methodsFor: 'testing' stamp: 'Alexandre.Bergel 7/4/2009 13:56'! 419895testErrorClassCreation 419896 | tmpCategory trait cls2 | 419897 tmpCategory := 'TemporaryGeneratedClasses'. 419898 419899 Smalltalk at: #AClass ifPresent: [:v | v removeFromSystem]. 419900 Smalltalk at: #AClass2 ifPresent: [:v | v removeFromSystem]. 419901 Smalltalk at: #TMyTrait ifPresent: [:v | v removeFromSystem]. 419902 419903 trait := Trait named: #TMyTrait uses: {} category: tmpCategory. 419904 419905 "----------------" 419906" Object subclass: #AClass 419907 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: tmpCategory. 419908" 419909 "----------------" 419910 nil subclass: #AClass 419911 instanceVariableNames: '' 419912 classVariableNames: '' poolDictionaries: '' category: tmpCategory. 419913 419914 "----------------" 419915 cls2 := (Smalltalk at: #AClass) subclass: #AClass2 419916 uses: trait 419917 instanceVariableNames: '' 419918 classVariableNames: '' poolDictionaries: '' category: tmpCategory. 419919 "----------------" 419920 419921 Object subclass: #AClass 419922 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: tmpCategory. 419923 419924 419925 self assert: (trait users asArray = {cls2}). 419926 self assert: (cls2 traits asArray = {trait}). 419927 419928 "----------------" 419929 419930 Smalltalk at: #AClass ifPresent: [:v | v removeFromSystem]. 419931 Smalltalk at: #AClass2 ifPresent: [:v | v removeFromSystem]. 419932 Smalltalk at: #TMyTrait ifPresent: [:v | v removeFromSystem]. 419933! ! 419934 419935!TraitTest methodsFor: 'testing' stamp: 'al 10/13/2006 13:54'! 419936testExplicitRequirement 419937 "self run: #testExplicitRequirement" 419938 419939 self t1 compile: 'm self explicitRequirement'. 419940 self t2 compile: 'm ^true'. 419941 self deny: self t4 >> #m == (self t2 >> #m). 419942 self assert: self c2 new m. 419943 self t2 removeSelector: #m. 419944 self deny: self t5 >> #m == (self t1 >> #m). 419945 self should: [self c2 new m] raise: Error! ! 419946 419947!TraitTest methodsFor: 'testing' stamp: 'marcus.denker 11/10/2008 10:04'! 419948testLocalMethodWithSameCodeInTrait 419949 "Note, takes all behaviors (classes and traits) into account" 419950 419951 SystemNavigation default allBehaviorsDo: [ :each | 419952 each hasTraitComposition ifTrue: [ 419953 each methodDict keys do: [ :selector | 419954 (each includesLocalSelector: selector) ifTrue: [ 419955 (each traitComposition traitProvidingSelector: selector) ifNotNil: [ :trait | 419956 self deny: (trait >> selector = (each >> selector)) ] ] ] ] ].! ! 419957 419958!TraitTest methodsFor: 'testing' stamp: 'al 2/13/2006 17:41'! 419959testMarkerMethods 419960 "self debug: #testMarkerMethods" 419961 419962 self t1 compile: 'm1 self foo bar'. 419963 self assert: (self t1 >> #m1) markerOrNil isNil. 419964 419965 419966 self t1 compile: 'm2 self requirement'. 419967 self assert: (self t1 >> #m2) markerOrNil == #requirement. 419968 419969 self t1 compile: 'm3 ^self requirement'. 419970 self assert: (self t1 >> #m3) markerOrNil == #requirement.! ! 419971 419972!TraitTest methodsFor: 'testing' stamp: 'ab 4/15/2009 00:36'! 419973testOrigin 419974 | tr1 tr2 tr3 tr23 aMethodDescription | 419975 tr1 := self createTraitNamed: #TTT1 uses: {}. 419976 tr2 := self createTraitNamed: #TTT2 uses: {tr1}. 419977 tr3 := self createTraitNamed: #TTT3 uses: {tr1}. 419978 tr23 := self createTraitNamed: #TTT23 uses: {tr3 + tr2}. 419979 419980 tr1 compile: 'foo ^ 4'. 419981 self assert: (tr1 >> #foo) origin == tr1. 419982 self assert: (tr2 >> #foo) origin == tr1. 419983 self assert: (tr3 >> #foo) origin == tr1. 419984 419985 "-----------" 419986 "For TR2" 419987 aMethodDescription := tr2 traitComposition methodDescriptionForSelector: #foo. 419988 self assert: (aMethodDescription locatedMethods size = 1). 419989 self assert: (aMethodDescription locatedMethods 419990 includes: (LocatedMethod location: tr1 selector: #foo)). 419991 419992 self assert: (aMethodDescription providedLocatedMethod notNil). 419993 "The method is provided, it cannot be nil" 419994 self assert: (aMethodDescription providedMethod notNil). 419995 self assert: (aMethodDescription isProvided). 419996 419997 self assert: (tr2 traitComposition traitProvidingSelector: #foo) == tr1. 419998 self assert: (tr2 >> #foo) origin == tr1. 419999 "-----------" 420000 420001 "-----------" 420002 "For TR23" 420003 aMethodDescription := tr23 traitComposition methodDescriptionForSelector: #foo. 420004 self assert: (aMethodDescription locatedMethods size = 2). 420005 self assert: (aMethodDescription locatedMethods 420006 includes: (LocatedMethod location: tr2 selector: #foo)). 420007 self assert: (aMethodDescription locatedMethods 420008 includes: (LocatedMethod location: tr3 selector: #foo)). 420009 420010 self assert: (aMethodDescription providedLocatedMethod notNil). 420011 "The method is provided, it cannot be nil" 420012 self assert: (aMethodDescription providedMethod notNil). 420013 420014 self assert: (aMethodDescription isProvided). 420015 420016 self assert: (tr23 traitComposition traitProvidingSelector: #foo) == tr1. 420017 self assert: (tr23 >> #foo) origin == tr1. 420018 "-----------"! ! 420019 420020!TraitTest methodsFor: 'testing' stamp: 'marcus.denker 9/6/2009 15:38'! 420021testPrinting 420022 self assertPrints: self t6 definition 420023 like: 'Trait named: #T6 420024 uses: T1 + T2 @ {#m22Alias->#m22} 420025 category: ''Tests-Traits'''! ! 420026 420027!TraitTest methodsFor: 'testing' stamp: 'md 8/15/2008 16:56'! 420028testPrintingClassSide 420029 "self run: #testPrintingClassSide" 420030 420031 self assertPrints: self t6 classSide definition 420032 like: 'T6 classTrait 420033 uses: T1 classTrait + T2 classTrait'! ! 420034 420035!TraitTest methodsFor: 'testing' stamp: 'dvf 8/26/2005 14:31'! 420036testRemoveFromSystem 420037 self t4 removeFromSystem. 420038 self deny: (Smalltalk includesKey: #T4). 420039 self assert: self t4 name = 'AnObsoleteT4'. 420040 self assert: self t4 methodDict isEmpty. 420041 self deny: (self t1 users includes: self t4)! ! 420042 420043!TraitTest methodsFor: 'testing' stamp: 'al 10/13/2006 13:54'! 420044testRequirement 420045 "self debug: #testRequirement" 420046 420047 self t1 compile: 'm self requirement'. 420048 self t2 compile: 'm ^true'. 420049 self assert: self c2 new m. 420050 self t2 removeSelector: #m. 420051 self should: [self c2 new m] raise: Error! ! 420052 420053!TraitTest methodsFor: 'testing' stamp: 'adrian_lienhard 2/21/2009 13:49'! 420054testTraitsMethodClassSanity 420055 "self debug: #testTraitsMethodClassSanity" 420056 420057 (Smalltalk allTraits gather: #users) asSet do: [ :each | 420058 each selectorsDo: [ :selector | 420059 self assert: [ (each >> selector) methodClass == each ] ] ]! ! 420060 420061!TraitTest methodsFor: 'testing' stamp: 'Alexandre.Bergel 7/4/2009 11:53'! 420062testTraitsUsersSanity 420063 "This documents bug http://code.google.com/p/pharo/issues/detail?id=443" 420064 "self debug: #testTraitsUsersSanity" 420065 420066 Smalltalk allClassesAndTraits do: [ :each | 420067 self assert: (each traits allSatisfy: [ :t | t users includes: each ]) ]. 420068 420069 Smalltalk allTraits do: [ :each | 420070 self assert: (each users allSatisfy: [ :b | b traits includes: each ]) ]! ! 420071 420072!TraitTest methodsFor: 'testing' stamp: 'dvf 8/30/2005 14:55'! 420073testUsers 420074 self assert: self t1 users size = 3. 420075 self assert: (self t1 users includesAllOf: {self t4. self t5. self t6 }). 420076 self assert: self t3 users isEmpty. 420077 self assert: self t5 users size = 1. 420078 self assert: self t5 users anyOne = self c2. 420079 self c2 setTraitCompositionFrom: self t1 + self t5. 420080 self assert: self t5 users size = 1. 420081 self assert: self t5 users anyOne = self c2. 420082 self c2 setTraitComposition: self t2 asTraitComposition. 420083 self assert: self t5 users isEmpty! ! 420084 420085!TraitTest methodsFor: 'testing' stamp: 'adrian_lienhard 1/17/2009 14:04'! 420086testUsersWithClassChanges 420087 "This documents bug http://code.google.com/p/pharo/issues/detail?id=443" 420088 "self debug: #testUsersWithClassChanges" 420089 420090 self c2 setTraitCompositionFrom: self t5. 420091 self assert: self t5 users size = 1. 420092 self assert: self t5 classSide users size = 1. 420093 self assert: self c2 traits size = 1. 420094 self assert: self c2 class traits size = 1. 420095 420096 "Change class definition" 420097 self c2 addInstVarName: 'foo'. 420098 self assert: self t5 users size = 1. 420099 self assert: self t5 classSide users size = 1. 420100 self assert: self c2 traits size = 1. 420101 self assert: self c2 class traits size = 1. 420102 420103 "Change metaclass definition" 420104 self c2 class instanceVariableNames: 'bar'. 420105 self assert: self t5 users size = 1. 420106 self assert: self t5 classSide users size = 1. 420107 self assert: self c2 traits size = 1. 420108 self assert: self c2 class traits size = 1.! ! 420109Object subclass: #TraitTransformation 420110 uses: TComposingDescription 420111 instanceVariableNames: 'subject' 420112 classVariableNames: '' 420113 poolDictionaries: '' 420114 category: 'Traits-Composition'! 420115!TraitTransformation commentStamp: 'apb 8/25/2005 11:54' prior: 0! 420116A trait transformation is an instance of one of my concrete subclasses, TraitAlias or TraitExclusion. These represent a transformation of a trait, specified by the alias and exclusion operators. 420117 420118I define an instance variable named subject which holds the object that is transformed. Thus, an alias transformation has as its subject a trait, and a trait exclusion has as its subject either a trait alias or a trait. Each of the concrete transformation classes implement the method allSelectors according to the transformation it represents. 420119 420120(There was formerly a subclass called TraitHolder, which was the identity transformation and which did not modify the trait. This was clearly redundant, and was removed.)! 420121 420122 420123!TraitTransformation methodsFor: 'accessing' stamp: 'al 4/10/2004 00:06'! 420124normalized 420125 ^self isEmpty 420126 ifFalse: [ 420127 self subject: self subject normalized. 420128 self] 420129 ifTrue: [self subject normalized] 420130 420131 ! ! 420132 420133!TraitTransformation methodsFor: 'accessing' stamp: 'NS 12/11/2003 15:13'! 420134subject 420135 ^subject! ! 420136 420137!TraitTransformation methodsFor: 'accessing' stamp: 'al 4/9/2004 18:23'! 420138subject: aTraitTransformation 420139 subject := aTraitTransformation! ! 420140 420141 420142!TraitTransformation methodsFor: 'accessing parallel hierarchy' stamp: 'dvf 8/18/2005 18:29'! 420143isMeta 420144 ^self subject isMeta! ! 420145 420146!TraitTransformation methodsFor: 'accessing parallel hierarchy' stamp: 'dvf 8/18/2005 18:28'! 420147theNonMetaClass 420148 ^ self subject theNonMetaClass ! ! 420149 420150 420151!TraitTransformation methodsFor: 'browser support' stamp: 'dvf 8/18/2005 18:31'! 420152sourceCodeTemplate 420153 ^ self subject sourceCodeTemplate! ! 420154 420155 420156!TraitTransformation methodsFor: 'composition' stamp: 'al 4/9/2004 17:01'! 420157addExclusionOf: aSymbol 420158 ^self - {aSymbol}! ! 420159 420160!TraitTransformation methodsFor: 'composition' stamp: 'al 4/10/2004 23:48'! 420161removeAlias: aSymbol 420162 self subject removeAlias: aSymbol! ! 420163 420164!TraitTransformation methodsFor: 'composition'! 420165+ aTraitOrTraitComposition 420166 "Use double dispatch to avoid having nested composition in cases where 420167 parenthesis are used, such as T1 + (T2 + T3)" 420168 420169 ^aTraitOrTraitComposition addOnTheLeft: self! ! 420170 420171!TraitTransformation methodsFor: 'composition' stamp: 'al 12/7/2005 21:19'! 420172- anArray 420173 TraitCompositionException signal: 'Invalid trait exclusion. Exclusions have to be specified after aliases.'! ! 420174 420175!TraitTransformation methodsFor: 'composition' stamp: 'al 12/7/2005 21:20'! 420176@ anArrayOfAssociations 420177 TraitCompositionException signal: 'Invalid trait exclusion. Aliases have to be specified before exclusions.'! ! 420178 420179 420180!TraitTransformation methodsFor: 'converting'! 420181asTraitComposition 420182 ^TraitComposition with: self! ! 420183 420184 420185!TraitTransformation methodsFor: 'copying' stamp: 'apb 8/24/2005 17:13'! 420186copy 420187 self error: 'should not be called'. 420188 ^super copy 420189 subject: self subject copy; 420190 yourself! ! 420191 420192!TraitTransformation methodsFor: 'copying' stamp: 'dvf 8/25/2005 16:06'! 420193copyTraitExpression 420194 ^self shallowCopy 420195 subject: self subject copyTraitExpression; 420196 yourself! ! 420197 420198 420199!TraitTransformation methodsFor: 'enquiries' stamp: 'al 3/11/2004 21:49'! 420200aliasesForSelector: aSymbol 420201 "Return a collection of alias selectors that are defined in this transformation." 420202 420203 ^self subject aliasesForSelector: aSymbol! ! 420204 420205!TraitTransformation methodsFor: 'enquiries' stamp: 'NS 4/16/2004 13:40'! 420206allAliasesDict 420207 "Return a dictionary with all alias associations that are defined in this transformation." 420208 420209 ^self subject allAliasesDict! ! 420210 420211!TraitTransformation methodsFor: 'enquiries' stamp: 'al 3/7/2004 22:36'! 420212allSelectors 420213 ^self subclassResponsibility! ! 420214 420215!TraitTransformation methodsFor: 'enquiries' stamp: 'NS 4/16/2004 14:20'! 420216changedSelectorsComparedTo: aTraitTransformation 420217 | selectors otherSelectors changedSelectors aliases otherAliases | 420218 selectors := self allSelectors asIdentitySet. 420219 otherSelectors := aTraitTransformation allSelectors asIdentitySet. 420220 changedSelectors := IdentitySet withAll: ( 420221 (selectors difference: otherSelectors) union: (otherSelectors difference: selectors)). 420222 aliases := self allAliasesDict. 420223 otherAliases := aTraitTransformation allAliasesDict. 420224 aliases keysAndValuesDo: [:key :value | 420225 (value ~~ (otherAliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]]. 420226 otherAliases keysAndValuesDo: [:key :value | 420227 (value ~~ (aliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]]. 420228 ^ changedSelectors.! ! 420229 420230!TraitTransformation methodsFor: 'enquiries' stamp: 'al 3/6/2004 18:51'! 420231collectMethodsFor: aSelector into: methodDescription 420232 "Collect instances of LocatedMethod into methodDescription 420233 for each method that has the selector aSelector and is not excluded 420234 or for which aSelector is an alias." 420235 420236 self subclassResponsibility! ! 420237 420238!TraitTransformation methodsFor: 'enquiries' stamp: 'dvf 8/18/2005 18:39'! 420239selectors 420240 ^self allSelectors! ! 420241 420242!TraitTransformation methodsFor: 'enquiries' stamp: 'al 12/12/2003 18:00'! 420243trait 420244 ^self subject trait! ! 420245 420246!TraitTransformation methodsFor: 'enquiries' stamp: 'dvf 8/16/2005 17:35'! 420247traitTransformations 420248 ^ { subject }! ! 420249 420250 420251!TraitTransformation methodsFor: 'printing' stamp: 'al 12/12/2003 18:29'! 420252printOn: aStream 420253 aStream print: self subject! ! 420254 420255 420256!TraitTransformation methodsFor: 'testing' stamp: 'al 4/10/2004 23:56'! 420257isEmpty 420258 self subclassResponsibility! ! 420259 420260 420261!TraitTransformation methodsFor: 'private'! 420262addCompositionOnLeft: aTraitComposition 420263 ^ aTraitComposition add: self! ! 420264 420265!TraitTransformation methodsFor: 'private'! 420266addOnTheLeft: aTraitExpression 420267 ^TraitComposition with: aTraitExpression with: self! ! 420268 420269"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 420270 420271TraitTransformation class 420272 uses: TComposingDescription classTrait 420273 instanceVariableNames: ''! 420274TestResource subclass: #TraitsResource 420275 instanceVariableNames: 'createdClassesAndTraits t1 t2 t3 t4 t5 t6 c1 c2 c3 c4 c5 c6 c7 c8 dirty' 420276 classVariableNames: 'SetUpCount' 420277 poolDictionaries: '' 420278 category: 'Tests-Traits'! 420279 420280!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420281c1 420282 ^c1! ! 420283 420284!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420285c1: anObject 420286 ^c1 := anObject! ! 420287 420288!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420289c2 420290 ^c2! ! 420291 420292!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420293c2: anObject 420294 ^c2 := anObject! ! 420295 420296!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420297c3 420298 ^c3! ! 420299 420300!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420301c3: anObject 420302 ^c3 := anObject! ! 420303 420304!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420305c4 420306 ^c4! ! 420307 420308!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420309c4: anObject 420310 ^c4 := anObject! ! 420311 420312!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420313c5 420314 ^c5! ! 420315 420316!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420317c5: anObject 420318 ^c5 := anObject! ! 420319 420320!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420321c6 420322 ^c6! ! 420323 420324!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420325c6: anObject 420326 ^c6 := anObject! ! 420327 420328!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420329c7 420330 ^c7! ! 420331 420332!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:00'! 420333c7: anObject 420334 ^c7 := anObject! ! 420335 420336!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:01'! 420337c8 420338 ^c8! ! 420339 420340!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 14:01'! 420341c8: anObject 420342 ^c8 := anObject! ! 420343 420344!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 15:19'! 420345isDirty 420346 ^dirty! ! 420347 420348!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 15:19'! 420349setDirty 420350 dirty := true! ! 420351 420352!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:58'! 420353t1 420354 ^t1! ! 420355 420356!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:58'! 420357t1: anObject 420358 ^t1 := anObject! ! 420359 420360!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'! 420361t2 420362 ^t2! ! 420363 420364!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'! 420365t2: anObject 420366 ^t2 := anObject! ! 420367 420368!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'! 420369t3 420370 ^t3! ! 420371 420372!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'! 420373t3: anObject 420374 ^t3 := anObject! ! 420375 420376!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'! 420377t4 420378 ^t4! ! 420379 420380!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'! 420381t4: anObject 420382 ^t4 := anObject! ! 420383 420384!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'! 420385t5 420386 ^t5! ! 420387 420388!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'! 420389t5: anObject 420390 ^t5 := anObject! ! 420391 420392!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'! 420393t6 420394 ^t6! ! 420395 420396!TraitsResource methodsFor: 'accessing' stamp: 'dvf 8/30/2005 13:59'! 420397t6: anObject 420398 ^t6 := anObject! ! 420399 420400 420401!TraitsResource methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 11:47'! 420402categoryName 420403 ^self class category! ! 420404 420405!TraitsResource methodsFor: 'as yet unclassified' stamp: 'al 10/10/2005 10:37'! 420406codeChangedEvent: anEvent 420407 420408 (anEvent isDoIt not 420409 and: [anEvent itemClass notNil] 420410 and: [self createdClassesAndTraits includes: anEvent itemClass instanceSide]) ifTrue: [self setDirty] ! ! 420411 420412!TraitsResource methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 11:47'! 420413createClassNamed: aSymbol superclass: aClass uses: aTraitComposition 420414 | class | 420415 class := aClass 420416 subclass: aSymbol 420417 uses: aTraitComposition 420418 instanceVariableNames: '' 420419 classVariableNames: '' 420420 poolDictionaries: '' 420421 category: self categoryName. 420422 self createdClassesAndTraits add: class. 420423 ^class! ! 420424 420425!TraitsResource methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 11:47'! 420426createdClassesAndTraits 420427 createdClassesAndTraits ifNil: [ 420428 createdClassesAndTraits := OrderedCollection new]. 420429 ^createdClassesAndTraits! ! 420430 420431!TraitsResource methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 11:47'! 420432createTraitNamed: aSymbol uses: aTraitComposition 420433 | trait | 420434 trait := Trait 420435 named: aSymbol 420436 uses: aTraitComposition 420437 category: self categoryName. 420438 self createdClassesAndTraits add: trait. 420439 ^trait! ! 420440 420441!TraitsResource methodsFor: 'as yet unclassified' stamp: 'al 9/16/2005 11:52'! 420442setUp 420443 "Please note, that most tests rely on this setup of traits and 420444 classes - and that especially the order of the definitions matters." 420445 "SetUpCount := SetUpCount + 1." 420446 420447 dirty := false. 420448 SystemChangeNotifier uniqueInstance doSilently: 420449 [self t1: (self createTraitNamed: #T1 420450 uses: { }). 420451 self t1 comment: 'I am the trait T1'. 420452 self t2: (self createTraitNamed: #T2 420453 uses: { }). 420454 self t2 compile: 'm21 ^21' classified: #cat1. 420455 self t2 compile: 'm22 ^22' classified: #cat2. 420456 self t2 classSide compile: 'm2ClassSide: a ^a'. 420457 self t3: (self createTraitNamed: #T3 420458 uses: { }). 420459 self t3 compile: 'm31 ^31' classified: #cat1. 420460 self t3 compile: 'm32 ^32' classified: #cat2. 420461 self t3 compile: 'm33 ^33' classified: #cat3. 420462 self t4: (self createTraitNamed: #T4 420463 uses: { (self t1). (self t2) }). 420464 self t4 compile: 'm11 ^41' classified: #catX. "overrides T1>>m11" 420465 self t4 compile: 'm42 ^42' classified: #cat2. 420466 self t5: (self createTraitNamed: #T5 uses: self t1 + self t2). 420467 self t5 compile: 'm51 ^super foo' classified: #cat1. 420468 self t5 compile: 'm52 ^ self class bar' classified: #cat1. 420469 self t5 compile: 'm53 ^ self class bar' classified: #cat1. 420470 self t6: (self createTraitNamed: #T6 420471 uses: (self t1 + self t2) @ { (#m22Alias -> #m22) }). 420472 self c1: (self 420473 createClassNamed: #C1 420474 superclass: Object 420475 uses: { }). 420476 self c1 compile: 'foo ^true' classified: #accessing. 420477 self t1 compile: 'm11 ^11' classified: #cat1. 420478 self t1 compile: 'm12 ^12' classified: #cat2. 420479 self t1 compile: 'm13 ^self m12' classified: #cat3. 420480 self c2: (self 420481 createClassNamed: #C2 420482 superclass: self c1 420483 uses: self t5 - { #m11 }). 420484 self c2 compile: 'foo ^false' classified: #private. 420485 self c2 compile: 'bar ^self foo' classified: #private. 420486 self setUpTrivialRequiresFixture. 420487 self setUpTwoLevelRequiresFixture. 420488 self setUpTranslatingRequiresFixture]. 420489 SystemChangeNotifier uniqueInstance notify: self ofAllSystemChangesUsing: #codeChangedEvent:! ! 420490 420491!TraitsResource methodsFor: 'as yet unclassified' stamp: 'noha 6/11/2008 18:41'! 420492setUpTranslatingRequiresFixture 420493 self c6: (self 420494 createClassNamed: #C6 420495 superclass: ProtoObject 420496 uses: { }). 420497 ProtoObject removeSubclass: self c6. 420498 self c6 superclass: nil. 420499 self c7: (self 420500 createClassNamed: #C7 420501 superclass: self c6 420502 uses: { }). 420503 self c8: (self 420504 createClassNamed: #C8 420505 superclass: self c7 420506 uses: { }). 420507 self c6 compile: 'foo ^self x' classified: #accessing. 420508 self c7 compile: 'foo ^3' classified: #accessing. 420509 self c7 compile: 'bar ^super foo' classified: #accessing. 420510 self c8 compile: 'bar ^self blah' classified: #accessing! ! 420511 420512!TraitsResource methodsFor: 'as yet unclassified' stamp: 'noha 6/11/2008 18:42'! 420513setUpTrivialRequiresFixture 420514 self c3: (self 420515 createClassNamed: #C3 420516 superclass: ProtoObject 420517 uses: { }). 420518 ProtoObject removeSubclass: self c3. 420519 self c3 superclass: nil. 420520 self c3 compile: 'foo ^self bla' classified: #accessing! ! 420521 420522!TraitsResource methodsFor: 'as yet unclassified' stamp: 'noha 6/11/2008 18:42'! 420523setUpTwoLevelRequiresFixture 420524 self c4: (self 420525 createClassNamed: #C4 420526 superclass: ProtoObject 420527 uses: { }). 420528 ProtoObject removeSubclass: self c4. 420529 self c4 superclass: nil. 420530 self c5: (self 420531 createClassNamed: #C5 420532 superclass: self c4 420533 uses: { }). 420534 self c4 compile: 'foo ^self blew' classified: #accessing. 420535 self c5 compile: 'foo ^self blah' classified: #accessing! ! 420536 420537!TraitsResource methodsFor: 'as yet unclassified' stamp: 'AdrianLienhard 10/18/2009 10:57'! 420538tearDown 420539 | behaviorName | 420540 SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self. 420541 self createdClassesAndTraits do: 420542 [:aClassOrTrait | 420543 RequiredSelectors current clearOut: aClassOrTrait. 420544 behaviorName := aClassOrTrait name. 420545 Smalltalk at: behaviorName 420546 ifPresent: [:classOrTrait | classOrTrait removeFromSystem]. 420547 ChangeSet current removeClassChanges: behaviorName]. 420548 createdClassesAndTraits := self t1: (self 420549 t2: (self t3: (self 420550 t4: (self t5: (self 420551 t6: (self c1: (self 420552 c2: (self c3: (self c4: (self c5: (self c6: (self c7: (self c8: nil)))))))))))))! ! 420553 420554"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 420555 420556TraitsResource class 420557 instanceVariableNames: ''! 420558 420559!TraitsResource class methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 16:57'! 420560resetIfDirty 420561 self current isDirty ifTrue: [self reset]! ! 420562TestCase subclass: #TraitsTestCase 420563 instanceVariableNames: 'createdClassesAndTraits' 420564 classVariableNames: '' 420565 poolDictionaries: '' 420566 category: 'Tests-Traits'! 420567 420568!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'! 420569c1 420570 ^TraitsResource current c1! ! 420571 420572!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'! 420573c2 420574 ^TraitsResource current c2! ! 420575 420576!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'! 420577c3 420578 ^TraitsResource current c3! ! 420579 420580!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'! 420581c4 420582 ^TraitsResource current c4! ! 420583 420584!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'! 420585c5 420586 ^TraitsResource current c5! ! 420587 420588!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'! 420589c6 420590 ^TraitsResource current c6! ! 420591 420592!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'! 420593c7 420594 ^TraitsResource current c7! ! 420595 420596!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'! 420597c8 420598 ^TraitsResource current c8! ! 420599 420600!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'! 420601t1 420602 ^TraitsResource current t1! ! 420603 420604!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:44'! 420605t2 420606 ^TraitsResource current t2! ! 420607 420608!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:45'! 420609t3 420610 ^TraitsResource current t3! ! 420611 420612!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:45'! 420613t4 420614 ^TraitsResource current t4! ! 420615 420616!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:45'! 420617t5 420618 ^TraitsResource current t5! ! 420619 420620!TraitsTestCase methodsFor: 'accessing' stamp: 'dvf 8/30/2005 11:45'! 420621t6 420622 ^TraitsResource current t6! ! 420623 420624 420625!TraitsTestCase methodsFor: 'running' stamp: 'al 4/25/2004 16:31'! 420626categoryName 420627 ^self class category! ! 420628 420629!TraitsTestCase methodsFor: 'running' stamp: 'AdrianLienhard 10/18/2009 10:57'! 420630tearDown 420631 | behaviorName | 420632 TraitsResource resetIfDirty. 420633 self createdClassesAndTraits do: 420634 [:aClassOrTrait | 420635 RequiredSelectors current clearOut: aClassOrTrait. 420636 behaviorName := aClassOrTrait name. 420637 Smalltalk at: behaviorName 420638 ifPresent: [:classOrTrait | classOrTrait removeFromSystem]. 420639 ChangeSet current removeClassChanges: behaviorName]. 420640 createdClassesAndTraits := nil! ! 420641 420642 420643!TraitsTestCase methodsFor: 'utility' stamp: 'al 12/16/2003 22:16'! 420644assertPrints: aString like: anotherString 420645 self assert: (aString copyWithout: $ ) 420646 = (anotherString copyWithout: $ )! ! 420647 420648!TraitsTestCase methodsFor: 'utility' stamp: 'dvf 8/30/2005 14:44'! 420649createClassNamed: aSymbol superclass: aClass uses: aTraitComposition 420650 | class | 420651 class := aClass 420652 subclass: aSymbol 420653 uses: aTraitComposition 420654 instanceVariableNames: '' 420655 classVariableNames: '' 420656 poolDictionaries: '' 420657 category: self categoryName. 420658 self createdClassesAndTraits add: class. 420659 ^class! ! 420660 420661!TraitsTestCase methodsFor: 'utility' stamp: 'dvf 8/30/2005 14:44'! 420662createdClassesAndTraits 420663 createdClassesAndTraits ifNil: [ 420664 createdClassesAndTraits := OrderedCollection new]. 420665 ^createdClassesAndTraits! ! 420666 420667!TraitsTestCase methodsFor: 'utility' stamp: 'dvf 8/30/2005 14:44'! 420668createTraitNamed: aSymbol uses: aTraitComposition 420669 | trait | 420670 trait := Trait 420671 named: aSymbol 420672 uses: aTraitComposition 420673 category: self categoryName. 420674 self createdClassesAndTraits add: trait. 420675 ^trait! ! 420676 420677!TraitsTestCase methodsFor: 'utility' stamp: 'dvf 8/30/2005 14:49'! 420678resourceClassesAndTraits 420679 ^TraitsResource current createdClassesAndTraits! ! 420680 420681"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 420682 420683TraitsTestCase class 420684 instanceVariableNames: ''! 420685 420686!TraitsTestCase class methodsFor: 'as yet unclassified' stamp: 'dvf 8/30/2005 11:41'! 420687resources 420688 ^{TraitsResource}! ! 420689WriteStream subclass: #TranscriptStream 420690 instanceVariableNames: '' 420691 classVariableNames: 'AccessSema' 420692 poolDictionaries: '' 420693 category: 'Collections-Streams'! 420694!TranscriptStream commentStamp: '<historical>' prior: 0! 420695This class is a much simpler implementation of Transcript protocol that supports multiple views and very simple conversion to morphic. Because it inherits from Stream, it is automatically compatible with code that is designe to write to streams.! 420696 420697 420698!TranscriptStream methodsFor: 'access' stamp: 'di 3/16/1999 21:38'! 420699characterLimit 420700 "Tell the views how much to retain on screen" 420701 ^ 20000! ! 420702 420703 420704!TranscriptStream methodsFor: 'initialization' stamp: 'al 9/21/2008 20:16'! 420705initialExtent 420706 ^ 447@200! ! 420707 420708!TranscriptStream methodsFor: 'initialization' stamp: 'alain.plantec 6/11/2008 11:32'! 420709open 420710 | openCount | 420711 openCount := 0. 420712 self dependents 420713 do: [:d | (d isSystemWindow) 420714 ifTrue: [openCount := openCount + 1]]. 420715 openCount = 0 420716 ifTrue: [self openLabel: 'Transcript'] 420717 ifFalse: [self openLabel: 'Transcript #' , (openCount + 1) printString]! ! 420718 420719!TranscriptStream methodsFor: 'initialization' stamp: 'al 9/21/2008 20:15'! 420720openAsMorph 420721 "Answer a morph viewing this transcriptStream" 420722 420723 ^ (self openAsMorphLabel: 'Transcript') extent: self initialExtent! ! 420724 420725!TranscriptStream methodsFor: 'initialization' stamp: 'di 5/27/1998 16:36'! 420726openAsMorphLabel: labelString 420727 "Build a morph viewing this transcriptStream" 420728 | window | 420729 window := (SystemWindow labelled: labelString) model: self. 420730 window addMorph: (PluggableTextMorph on: self text: nil accept: nil 420731 readSelection: nil menu: #codePaneMenu:shifted:) 420732 frame: (0@0 corner: 1@1). 420733 ^ window! ! 420734 420735!TranscriptStream methodsFor: 'initialization' stamp: 'alain.plantec 6/1/2008 23:11'! 420736openLabel: aString 420737 "Open a window on this transcriptStream" 420738 ^ (self openAsMorphLabel: aString) openInWorld! ! 420739 420740 420741!TranscriptStream methodsFor: 'model protocol' stamp: 'di 5/27/1998 16:44'! 420742codePaneMenu: aMenu shifted: shifted 420743 "Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items" 420744 ^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted 420745! ! 420746 420747!TranscriptStream methodsFor: 'model protocol' stamp: 'di 5/29/1998 17:13'! 420748perform: selector orSendTo: otherTarget 420749 "Selector was just chosen from a menu by a user. If can respond, then 420750perform it on myself. If not, send it to otherTarget, presumably the 420751editPane from which the menu was invoked." 420752 420753 (self respondsTo: selector) 420754 ifTrue: [^ self perform: selector] 420755 ifFalse: [^ otherTarget perform: selector]! ! 420756 420757!TranscriptStream methodsFor: 'model protocol' stamp: 'di 5/3/1999 22:49'! 420758release 420759 420760 self dependents do: 420761 [:view | (view isMorph and: [view isInWorld not]) 420762 ifTrue: [self removeDependent: view]]! ! 420763 420764!TranscriptStream methodsFor: 'model protocol' stamp: 'sw 3/2/2001 10:18'! 420765step 420766 "Objects that may be models of SystemWindows need to respond to this, albeit vacuously"! ! 420767 420768 420769!TranscriptStream methodsFor: 'printing' stamp: 'Noury 8/26/2008 08:53'! 420770isSelfEvaluating 420771 self == Transcript ifTrue: [^true]. 420772 ^super isSelfEvaluating! ! 420773 420774!TranscriptStream methodsFor: 'printing' stamp: 'Noury 7/19/2008 00:27'! 420775printOn: aStream 420776 self == Transcript ifFalse: [^super printOn: aStream]. 420777 aStream nextPutAll: 'Transcript'! ! 420778 420779 420780!TranscriptStream methodsFor: 'stream extensions' stamp: 'sma 3/15/2000 21:28'! 420781bs 420782 self position > 0 ifTrue: [^ self skip: -1]. 420783 self changed: #bs! ! 420784 420785!TranscriptStream methodsFor: 'stream extensions' stamp: 'gvc 7/6/2007 11:50'! 420786clear 420787 "Clear all characters and redisplay the view." 420788 420789 self changed: #clearText. 420790 "clear the buffer entirely since it may become quite large and hang around" 420791 self on: (String new: 1000)! ! 420792 420793!TranscriptStream methodsFor: 'stream extensions' stamp: 'Noury 8/3/2008 20:04'! 420794close 420795 super close. 420796 self flush ! ! 420797 420798!TranscriptStream methodsFor: 'stream extensions' stamp: 'mir 1/11/2000 11:41'! 420799endEntry 420800 "Display all the characters since the last endEntry, and reset the stream" 420801 self semaphore critical:[ 420802 self changed: #appendEntry. 420803 self reset. 420804 ].! ! 420805 420806!TranscriptStream methodsFor: 'stream extensions' stamp: 'md 8/2/2005 23:09'! 420807flush 420808 self endEntry 420809! ! 420810 420811!TranscriptStream methodsFor: 'stream extensions' stamp: 'di 5/8/1998 12:35'! 420812pastEndPut: anObject 420813 "If the stream reaches its limit, just output the contents and reset." 420814 self endEntry. 420815 ^ self nextPut: anObject! ! 420816 420817!TranscriptStream methodsFor: 'stream extensions' stamp: 'sma 2/26/2000 19:31'! 420818show: anObject "TextCollector compatibility" 420819 self nextPutAll: anObject asString; endEntry! ! 420820 420821 420822!TranscriptStream methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 20:36'! 420823buildWith: builder 420824 | windowSpec textSpec | 420825 windowSpec := builder pluggableWindowSpec new. 420826 windowSpec model: self. 420827 windowSpec label: 'Transcript'. 420828 windowSpec children: OrderedCollection new. 420829 420830 textSpec := builder pluggableTextSpec new. 420831 textSpec 420832 model: self; 420833 menu: #codePaneMenu:shifted:; 420834 frame: (0@0corner: 1@1). 420835 windowSpec children add: textSpec. 420836 420837 ^builder build: windowSpec! ! 420838 420839 420840!TranscriptStream methodsFor: 'private' stamp: 'mir 1/11/2000 11:41'! 420841semaphore 420842 ^AccessSema ifNil:[AccessSema := Semaphore forMutualExclusion]! ! 420843 420844"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 420845 420846TranscriptStream class 420847 instanceVariableNames: ''! 420848 420849!TranscriptStream class methodsFor: 'as yet unclassified' stamp: 'di 5/8/1998 13:51'! 420850new 420851 ^ self on: (String new: 1000) 420852" 420853INSTALLING: 420854TextCollector allInstances do: 420855 [:t | t breakDependents. 420856 t become: TranscriptStream new]. 420857 420858TESTING: (Execute this text in a workspace) 420859Do this first... 420860 tt := TranscriptStream new. 420861 tt openLabel: 'Transcript test 1'. 420862Then this will open a second view -- ooooh... 420863 tt openLabel: 'Transcript test 2'. 420864And finally make them do something... 420865 tt clear. 420866 [Sensor anyButtonPressed] whileFalse: 420867 [1 to: 20 do: [:i | tt print: (2 raisedTo: i-1); cr; endEntry]]. 420868"! ! 420869 420870!TranscriptStream class methodsFor: 'as yet unclassified' stamp: 'di 5/8/1998 12:44'! 420871newTranscript: aTextCollector 420872 "Store aTextCollector as the value of the system global Transcript." 420873 Smalltalk at: #Transcript put: aTextCollector! ! 420874 420875!TranscriptStream class methodsFor: 'as yet unclassified' stamp: 'sw 1/29/2002 19:56'! 420876openMorphicTranscript 420877 "Have the current project's transcript open up as a morph" 420878 420879 ^ Transcript openAsMorph! ! 420880 420881 420882!TranscriptStream class methodsFor: 'initialization' stamp: 'asm 4/11/2003 12:05'! 420883initialize 420884 420885 self registerInFlapsRegistry. ! ! 420886 420887!TranscriptStream class methodsFor: 'initialization' stamp: 'asm 4/11/2003 12:06'! 420888registerInFlapsRegistry 420889 "Register the receiver in the system's flaps registry" 420890 self environment 420891 at: #Flaps 420892 ifPresent: [:cl | cl registerQuad: #(TranscriptStream openMorphicTranscript 'Transcript' 'A Transcript is a window usable for logging and debugging; browse references to #Transcript for examples of how to write to it.') 420893 forFlapNamed: 'Tools'] 420894! ! 420895 420896!TranscriptStream class methodsFor: 'initialization' stamp: 'asm 4/11/2003 12:41'! 420897unload 420898 "Unload the receiver from global registries" 420899 420900 self environment at: #Flaps ifPresent: [:cl | 420901 cl unregisterQuadsWithReceiver: self] ! ! 420902 420903 420904!TranscriptStream class methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 18:10'! 420905buildWith: aBuilder 420906 ^self new buildWith: aBuilder! ! 420907 420908 420909!TranscriptStream class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:46'! 420910windowColorSpecification 420911 "Answer a WindowColorSpec object that declares my preference" 420912 420913 ^ WindowColorSpec classSymbol: self name wording: 'Transcript' brightColor: #lightOrange pastelColor: #paleOrange helpMessage: 'The system transcript'! ! 420914TestCase subclass: #TranscriptTest 420915 instanceVariableNames: '' 420916 classVariableNames: '' 420917 poolDictionaries: '' 420918 category: 'CollectionsTests-Streams'! 420919 420920!TranscriptTest methodsFor: 'testing' stamp: 'nes 7/4/2009 15:56'! 420921testCloseCauseFlushing 420922 |transcriptStr| 420923 transcriptStr := TranscriptStream new. 420924 transcriptStr cr; space; tab; nextPut: $A; nextPutAll: 'B'. 420925 self assert: transcriptStr size = 5. 420926 transcriptStr close. 420927 self assert: transcriptStr position = 0! ! 420928 420929!TranscriptTest methodsFor: 'testing' stamp: 'Noury 7/19/2008 00:26'! 420930testOtherInstancesOfTranscriptStreamAsString 420931 self deny: TranscriptStream new asString = 'Transcript'! ! 420932 420933!TranscriptTest methodsFor: 'testing' stamp: 'Noury 7/19/2008 00:25'! 420934testOtherInstancesOfTranscriptStreamPrintString 420935 self deny: TranscriptStream new printString = 'Transcript'! ! 420936 420937!TranscriptTest methodsFor: 'testing' stamp: 'Noury 8/26/2008 08:56'! 420938testOtherInstancesOfTranscriptStreamSelfEvaluating 420939 self deny: TranscriptStream new isSelfEvaluating! ! 420940 420941!TranscriptTest methodsFor: 'testing' stamp: 'Noury 7/19/2008 00:26'! 420942testTranscriptAsString 420943 self assert: Transcript asString = 'Transcript'! ! 420944 420945!TranscriptTest methodsFor: 'testing' stamp: 'Noury 7/19/2008 00:24'! 420946testTranscriptPrintString 420947 self assert: Transcript printString = 'Transcript'! ! 420948 420949!TranscriptTest methodsFor: 'testing' stamp: 'Noury 8/26/2008 08:55'! 420950testTranscriptisSelfEvaluating 420951 self assert: Transcript isSelfEvaluating! ! 420952ReadWriteStream subclass: #Transcripter 420953 instanceVariableNames: 'frame para' 420954 classVariableNames: '' 420955 poolDictionaries: '' 420956 category: 'Collections-Streams'! 420957!Transcripter commentStamp: '<historical>' prior: 0! 420958Transcripter is a dog-simple scrolling stream with display. It is intended to operate with no support from MVC or color in a minimal, or headless version of Squeak. No attention has been paid to appearance or performance.! 420959 420960 420961!Transcripter methodsFor: 'accessing' stamp: 'di 8/14/97 12:41'! 420962clear 420963 Display fill: (frame insetBy: -2) fillColor: self black; 420964 fill: frame fillColor: self white. 420965 self on: (String new: 100); endEntry! ! 420966 420967!Transcripter methodsFor: 'accessing' stamp: 'di 8/14/97 12:44'! 420968endEntry 420969 | c d cb | 420970 c := self contents. 420971 Display extent ~= DisplayScreen actualScreenSize ifTrue: 420972 ["Handle case of user resizing physical window" 420973 DisplayScreen startUp. 420974 frame := frame intersect: Display boundingBox. 420975 ^ self clear; show: c]. 420976 para setWithText: c asText 420977 style: TextStyle default 420978 compositionRectangle: ((frame insetBy: 4) withHeight: 9999) 420979 clippingRectangle: frame 420980 foreColor: self black backColor: self white. 420981 d := para compositionRectangle bottom - frame bottom. 420982 d > 0 ifTrue: 420983 ["Scroll up to keep all contents visible" 420984 cb := para characterBlockAtPoint: para compositionRectangle topLeft 420985 + (0@(d+para lineGrid)). 420986 self on: (c copyFrom: cb stringIndex to: c size). 420987 readLimit:= position:= collection size. 420988 ^ self endEntry]. 420989 para display! ! 420990 420991!Transcripter methodsFor: 'accessing' stamp: 'sma 2/26/2000 19:35'! 420992show: anObject 420993 self nextPutAll: anObject asString; endEntry! ! 420994 420995 420996!Transcripter methodsFor: 'command line' stamp: 'di 8/12/97 22:11'! 420997confirm: queryString 420998 | choice | 420999 [true] 421000 whileTrue: 421001 [choice := self request: queryString , ' 421002Please type yes or no followed by return'. 421003 choice first asUppercase = $Y ifTrue: [^ true]. 421004 choice first asUppercase = $N ifTrue: [^ false]]! ! 421005 421006!Transcripter methodsFor: 'command line' stamp: 'di 11/3/2000 18:52'! 421007readEvalPrint 421008 | line okToRevert | 421009 okToRevert := true. 421010 [#('quit' 'exit' 'done' ) includes: (line := self request: '>')] 421011 whileFalse: 421012 [line = 'revert' 421013 ifTrue: [okToRevert 421014 ifTrue: [Utilities revertLastMethodSubmission. 421015 self cr; show: 'reverted: ' , Utilities mostRecentlySubmittedMessage. 421016 okToRevert := false] 421017 ifFalse: [self cr; show: 'Only one level of revert currently supported']] 421018 ifFalse: [self cr; show: ([Compiler evaluate: line] ifError: [:err :ex | err])]]! ! 421019 421020!Transcripter methodsFor: 'command line' stamp: 'sma 2/26/2000 19:39'! 421021request: prompt 421022 | startPos char contents | 421023 self cr; show: prompt. 421024 startPos := position. 421025 [[Sensor keyboardPressed] whileFalse. 421026 (char := Sensor keyboard) = Character cr] 421027 whileFalse: 421028 [char = Character backspace 421029 ifTrue: [readLimit := position := (position - 1 max: startPos)] 421030 ifFalse: [self nextPut: char]. 421031 self endEntry]. 421032 contents := self contents. 421033 ^ contents copyFrom: startPos + 1 to: contents size! ! 421034 421035 421036!Transcripter methodsFor: 'initialization' stamp: 'di 8/14/97 12:44'! 421037initInFrame: rect 421038 frame := rect insetBy: 2. "Leave room for border" 421039 para := Paragraph withText: self contents asText 421040 style: TextStyle default 421041 compositionRectangle: ((frame insetBy: 4) withHeight: 9999) 421042 clippingRectangle: frame 421043 foreColor: self black backColor: self white! ! 421044 421045 421046!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12'! 421047black 421048 Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"]. 421049 ^ Color black! ! 421050 421051!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12'! 421052white 421053 Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"]. 421054 ^ Color white! ! 421055 421056"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 421057 421058Transcripter class 421059 instanceVariableNames: ''! 421060 421061!Transcripter class methodsFor: 'instance creation' stamp: 'di 8/14/97 12:09'! 421062newInFrame: frame 421063" 421064(Transcripter newInFrame: (0@0 extent: 100@200)) 421065 nextPutAll: 'Hello there'; endEntry; 421066 cr; print: 355.0/113; endEntry; 421067 readEvalPrint. 421068" 421069 | transcript | 421070 transcript := self on: (String new: 100). 421071 transcript initInFrame: frame. 421072 ^ transcript clear! ! 421073 421074!Transcripter class methodsFor: 'instance creation' stamp: 'ar 11/16/1999 20:16'! 421075startTranscriptProcess "Transcripter startTranscriptProcess" 421076 | activeProcess | 421077 Transcript := self newInFrame: Display boundingBox. 421078 activeProcess := [Transcript readEvalPrint. 421079 Smalltalk processShutDownList: true; quitPrimitive] 421080 newProcess 421081 priority: Processor userSchedulingPriority. 421082 activeProcess resume. 421083 Processor terminateActive 421084! ! 421085 421086 421087!Transcripter class methodsFor: 'utilities' stamp: 'di 11/3/2000 18:47'! 421088emergencyEvaluator 421089 (Transcripter newInFrame: (0@0 corner: 320@200)) 421090 show: 'Type ''revert'' to revert your last method change. 421091Type ''exit'' to exit the emergency evaluator.'; 421092 readEvalPrint! ! 421093Morph subclass: #TransferMorph 421094 instanceVariableNames: 'transferType passenger draggedMorph source dropNotifyRecipient accepted resultRecipient copy dragHand' 421095 classVariableNames: 'CopyPlusIcon' 421096 poolDictionaries: '' 421097 category: 'Morphic-Support'! 421098!TransferMorph commentStamp: 'nk 6/16/2003 16:52' prior: 0! 421099This is a Morph that is used to visually indicate the progress of a drag operation, and also as a container for various bits of drag state information. 421100 421101It polls the shift state in its step method to update its copy state (shift pressed = should copy). 421102 421103And if you hit the Escape key while dragging, it aborts the drag operation.! 421104 421105 421106!TransferMorph methodsFor: 'accessing' stamp: 'ar 12/22/2008 11:56'! 421107dragHand 421108 "The hand dragging this morph" 421109 ^dragHand! ! 421110 421111!TransferMorph methodsFor: 'accessing' stamp: 'ar 12/22/2008 11:55'! 421112dragHand: aHandMorph 421113 "The hand dragging this morph" 421114 dragHand := aHandMorph! ! 421115 421116!TransferMorph methodsFor: 'accessing' stamp: 'panda 4/28/2000 16:11'! 421117dragTransferType: aSymbol 421118 transferType := aSymbol! ! 421119 421120!TransferMorph methodsFor: 'accessing' stamp: 'mir 5/5/2000 17:34'! 421121draggedMorph 421122 draggedMorph ifNil: [self initDraggedMorph]. 421123 ^draggedMorph! ! 421124 421125!TransferMorph methodsFor: 'accessing' stamp: 'panda 4/25/2000 16:31'! 421126draggedMorph: aMorph 421127 draggedMorph := aMorph! ! 421128 421129!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 18:52'! 421130dropNotifyRecipient 421131 ^dropNotifyRecipient! ! 421132 421133!TransferMorph methodsFor: 'accessing' stamp: 'panda 4/25/2000 16:14'! 421134dropNotifyRecipient: anObject 421135 dropNotifyRecipient := anObject! ! 421136 421137!TransferMorph methodsFor: 'accessing' stamp: 'mir 5/5/2000 14:39'! 421138move 421139 copy := false! ! 421140 421141!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 18:52'! 421142passenger 421143 ^passenger! ! 421144 421145!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 18:53'! 421146passenger: anObject 421147 passenger := anObject! ! 421148 421149!TransferMorph methodsFor: 'accessing' stamp: 'mir 5/5/2000 14:39'! 421150shouldCopy 421151 ^copy! ! 421152 421153!TransferMorph methodsFor: 'accessing' stamp: 'nk 6/16/2003 16:29'! 421154shouldCopy: aBoolean 421155 copy := aBoolean.! ! 421156 421157!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 11:55'! 421158source 421159 ^source! ! 421160 421161!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 18:53'! 421162source: anObject 421163 source := anObject! ! 421164 421165 421166!TransferMorph methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:11'! 421167dragTransferType 421168 ^transferType! ! 421169 421170 421171!TransferMorph methodsFor: 'dropping/grabbing' stamp: 'nk 6/16/2003 16:51'! 421172aboutToBeGrabbedBy: aHand 421173 "The receiver is being grabbed by a hand. 421174 Perform necessary adjustments (if any) and return the actual morph 421175 that should be added to the hand." 421176 "Since this morph has been initialized automatically with bounds origin 421177 0@0, we have to move it to aHand position." 421178 super aboutToBeGrabbedBy: aHand. 421179 self draggedMorph. 421180 self align: self bottomLeft with: aHand position. 421181 aHand newKeyboardFocus: self.! ! 421182 421183!TransferMorph methodsFor: 'dropping/grabbing'! 421184justDroppedInto: targetMorph event: anEvent 421185 "If only world wants this TransferMorph, treat it as unaccepted (see also >>delete)." 421186 421187 super justDroppedInto: targetMorph event: anEvent. 421188 accepted := targetMorph ~= self world. 421189 self animationForMoveSuccess: accepted. 421190 accepted ifTrue: [self dropNotifyRecipient ifNotNil: [self dropNotifyRecipient dropAcceptedMorph: self from: targetMorph]]. 421191 self delete! ! 421192 421193!TransferMorph methodsFor: 'dropping/grabbing' stamp: 'sr 4/16/2000 18:53'! 421194result: result 421195 ^ self result: result from: nil! ! 421196 421197!TransferMorph methodsFor: 'dropping/grabbing' stamp: 'lr 10/29/2008 22:00'! 421198result: aResult from: aResultGenerator 421199 "Send aResult of the drop operation computed by aResultGenerator to a 421200 resultRecipient, if it exists."! ! 421201 421202!TransferMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/6/2000 17:30'! 421203undoGrabCommand 421204 ^nil! ! 421205 421206 421207!TransferMorph methodsFor: 'event handling' stamp: 'nk 6/16/2003 16:51'! 421208keyStroke: evt 421209 "Abort the drag on an escape" 421210 evt keyCharacter ~= Character escape ifTrue: [ ^self ]. 421211 self delete.! ! 421212 421213 421214!TransferMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:00'! 421215defaultColor 421216"answer the default color/fill style for the receiver" 421217 ^ Color blue alpha: 0.4! ! 421218 421219!TransferMorph methodsFor: 'initialization' stamp: 'nk 6/16/2003 16:50'! 421220initialize 421221 "initialize the state of the receiver" 421222 super initialize. 421223 self layoutPolicy: TableLayout new. 421224 self listDirection: #leftToRight; 421225 hResizing: #shrinkWrap; 421226 vResizing: #shrinkWrap; 421227 layoutInset: 3; 421228 wrapCentering: #center; 421229 cellPositioning: #leftCenter. 421230 accepted := false. 421231 copy := false. 421232 self on: #keyStroke send: #keyStroke: to: self! ! 421233 421234 421235!TransferMorph methodsFor: 'stepping and presenter' stamp: 'ar 12/22/2008 11:57'! 421236step 421237 self shouldCopy: dragHand shiftPressed. 421238 self updateCopyIcon! ! 421239 421240!TransferMorph methodsFor: 'stepping and presenter' stamp: 'nk 6/16/2003 16:42'! 421241stepTime 421242 ^100! ! 421243 421244 421245!TransferMorph methodsFor: 'submorphs-add/remove' stamp: 'mir 5/15/2000 18:05'! 421246delete 421247 "See also >>justDroppedInto:event:." 421248 accepted ifFalse: [self dropNotifyRecipient ifNotNil: [self dropNotifyRecipient dropRejectedMorph: self]]. 421249 self changed: #deleted. 421250 self breakDependents. 421251 super delete! ! 421252 421253 421254!TransferMorph methodsFor: 'private' stamp: 'sr 6/6/2000 07:19'! 421255animationForMoveSuccess: success 421256 | start stop slideForm | 421257 success 421258 ifTrue: [^ self] 421259 ifFalse: 421260 [start := self fullBounds origin. 421261 stop := self source bounds origin]. 421262 start = stop ifTrue: [^ self]. 421263 slideForm := self imageFormForRectangle: ((self fullBounds origin corner: self fullBounds corner + self activeHand shadowOffset) 421264 merge: self activeHand bounds). 421265 slideForm offset: 0 @ 0. 421266 slideForm 421267 slideWithFirstFrom: start 421268 to: stop 421269 nSteps: 12 421270 delay: 20! ! 421271 421272!TransferMorph methodsFor: 'private' stamp: 'nk 6/16/2003 16:49'! 421273initDraggedMorph 421274 draggedMorph ifNotNil: [^self]. 421275 draggedMorph := self passenger asDraggableMorph. 421276 self addMorphBack: draggedMorph. 421277 self updateCopyIcon. 421278 self changed; fullBounds! ! 421279 421280!TransferMorph methodsFor: 'private' stamp: 'mir 5/14/2000 00:11'! 421281privateFullMoveBy: delta 421282 super privateFullMoveBy: delta. 421283 self changed: #position! ! 421284 421285!TransferMorph methodsFor: 'private' stamp: 'nk 6/16/2003 16:34'! 421286updateCopyIcon 421287 | copyIcon | 421288 copyIcon := self submorphWithProperty: #tmCopyIcon. 421289 (self shouldCopy and: [ copyIcon isNil ]) ifTrue: [ 421290 ^self addMorphFront: ((ImageMorph new image: CopyPlusIcon) setProperty: #tmCopyIcon toValue: true) 421291 ]. 421292 (self shouldCopy not and: [ copyIcon notNil ]) ifTrue: [ 421293 copyIcon delete 421294 ]! ! 421295 421296"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 421297 421298TransferMorph class 421299 instanceVariableNames: ''! 421300 421301!TransferMorph class methodsFor: 'initialization' stamp: 'mir 5/5/2000 14:49'! 421302initIcons 421303 "TransferMorph initIcons" 421304 421305 CopyPlusIcon := Form 421306 extent: 16@16 421307 depth: 8 421308 fromArray: #( 0 0 65535 0 0 0 16768220 4278190080 0 0 16768220 4278190080 0 255 4294958300 4294967040 0 65500 3705461980 3705462015 0 65500 3705461980 3705462015 0 255 4294958300 4294967295 0 0 16768220 4278190080 0 0 16768220 4278190080 0 0 65535 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 421309 offset: 0@0! ! 421310 421311!TransferMorph class methodsFor: 'initialization' stamp: 'mir 5/5/2000 14:48'! 421312initialize 421313 "TransferMorph initialize" 421314 421315 self initIcons! ! 421316 421317 421318!TransferMorph class methodsFor: 'instance creation' stamp: 'sr 4/13/2000 21:52'! 421319withPassenger: anObject 421320 ^ self withPassenger: anObject from: nil! ! 421321 421322!TransferMorph class methodsFor: 'instance creation' stamp: 'ar 12/22/2008 11:57'! 421323withPassenger: anObject from: source 421324 ^self withPassenger: anObject from: source hand: nil! ! 421325 421326!TransferMorph class methodsFor: 'instance creation' stamp: 'ar 12/22/2008 11:57'! 421327withPassenger: anObject from: source hand: dragHand 421328 | ddm | 421329 ddm := self new. 421330 ddm passenger: anObject. 421331 ddm source: source. 421332 "If the client hasn't provided a hand use the currently active hand" 421333 ddm dragHand: (dragHand ifNil:[ActiveHand]). 421334 ddm shouldCopy: ddm dragHand shiftPressed. 421335 ^ ddm! ! 421336Morph subclass: #TransferMorphAnimation 421337 instanceVariableNames: 'transferMorph' 421338 classVariableNames: '' 421339 poolDictionaries: '' 421340 category: 'Morphic-Support'! 421341 421342!TransferMorphAnimation methodsFor: 'accessing' stamp: 'mir 5/14/2000 00:10'! 421343transferMorph 421344 ^transferMorph! ! 421345 421346 421347!TransferMorphAnimation methodsFor: 'initialization' stamp: 'ar 3/17/2001 23:43'! 421348on: aTransferMorph 421349 421350 self flag: #bob. "there was a reference to World, but the class seems to be unused" 421351 421352 self color: Color transparent. 421353 transferMorph := aTransferMorph. 421354 transferMorph addDependent: self. 421355 ActiveWorld addMorph: self "or perhaps aTransferMorph world"! ! 421356 421357 421358!TransferMorphAnimation methodsFor: 'update' stamp: 'mir 5/15/2000 18:02'! 421359updateAnimation! ! 421360 421361 421362!TransferMorphAnimation methodsFor: 'updating' stamp: 'mir 5/15/2000 18:05'! 421363update: aSymbol 421364 aSymbol == #deleted 421365 ifTrue: [self delete]. 421366 aSymbol == #position 421367 ifTrue: [self updateAnimation]. 421368 self changed! ! 421369 421370"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 421371 421372TransferMorphAnimation class 421373 instanceVariableNames: ''! 421374 421375!TransferMorphAnimation class methodsFor: 'instance creation' stamp: 'mir 5/14/2000 00:07'! 421376on: aTransferMorph 421377 ^self new on: aTransferMorph! ! 421378TransferMorphAnimation subclass: #TransferMorphLineAnimation 421379 instanceVariableNames: 'polygon' 421380 classVariableNames: '' 421381 poolDictionaries: '' 421382 category: 'Morphic-Support'! 421383 421384!TransferMorphLineAnimation methodsFor: 'initialization' stamp: 'di 9/9/2000 09:59'! 421385initPolygon 421386 polygon := (LineMorph from: self transferMorph source bounds center 421387 to: self transferMorph bounds center 421388 color: Color black width: 2) 421389 dashedBorder: {10. 10. Color white}. 421390 self addMorph: polygon 421391! ! 421392 421393!TransferMorphLineAnimation methodsFor: 'initialization' stamp: 'mir 5/14/2000 00:12'! 421394on: aTransferMorph 421395 super on: aTransferMorph. 421396 self initPolygon! ! 421397 421398 421399!TransferMorphLineAnimation methodsFor: 'update' stamp: 'di 9/9/2000 09:46'! 421400updateAnimation 421401 polygon verticesAt: 2 put: self transferMorph center! ! 421402Morph subclass: #TransformMorph 421403 instanceVariableNames: 'transform smoothing localBounds' 421404 classVariableNames: '' 421405 poolDictionaries: '' 421406 category: 'Morphic-Basic'! 421407!TransformMorph commentStamp: 'wiz 11/6/2005 15:59' prior: 0! 421408A TransformMorph introduces a 2-D transformation between its (global) coordinates and the (local) coordinates of its submorphs, while also clipping all display to its bounds. Specifically, with no offset, angle or scaling, a submorph with coordinates (0@0) will appear exactly at the topLeft of the windowMorph (its position). Rotation and scaling are relative to the local origin, (0@0). 421409 421410instance var type description 421411 transform MorphicTransform The coordinate transform between my coordinates and the 421412 local coordinates of my submorphs. 421413 smoothing anInteger in 1..3 Perform smoothing of my contents during drawing 421414 1 No smoothing (#smoothingOff) 421415 2 Smoothing w/ edge adjacent pixels (#smoothingOn) 421416 3 Smoothing w/ edge and corner adj pixels 421417 421418 localBounds Rectangle or nil caches the value of #localSubmorphBounds for performance 421419 421420TransformMorphs operate with two different display strategies, depending on whether the transformation is a pure translation or not. If so, then they simply use a clipping canvas and display their submorphs with the appropriate offset. If the transformation includes scaling or rotation, then a caching canvas is used, whose active area covers the fullBounds of the submorphs intersected with the source quadrilateral corresponding to the window bounds.! 421421 421422 421423!TransformMorph methodsFor: '*FreeType-override' stamp: 'Henrik Sperre Johansen 5/19/2009 21:48'! 421424drawSubmorphsOn: aCanvas 421425 421426 aCanvas transformBy: transform 421427 clippingTo: (aCanvas clipRect intersect: self clippingBounds) 421428 during: [:myCanvas | 421429 (self angle ~= 0.0 or: [self scale ~= 1.0]) 421430 ifTrue:[ 421431 FreeTypeSettings current forceNonSubPixelDuring:[ 421432 submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] ] 421433 ifFalse:[ 421434 submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] ] 421435 smoothing: smoothing! ! 421436 421437 421438!TransformMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 11/17/2006 10:12'! 421439clipSubmorphs 421440 "Answer true since we do!! 421441 This avoids the senseless over-invalidation 421442 with lists etc." 421443 421444 ^true! ! 421445 421446!TransformMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/16/2007 11:35'! 421447extent: aPoint 421448 "Changed to not cause layoutChanged on the receiver." 421449 421450 bounds extent = aPoint ifTrue: [^ self]. 421451 self changed. 421452 bounds := (bounds topLeft extent: aPoint) rounded. 421453 super layoutChanged. "skip submorph bounds recalculation" 421454 self changed. 421455! ! 421456 421457 421458!TransformMorph methodsFor: 'accessing'! 421459angle 421460 ^ transform angle! ! 421461 421462!TransformMorph methodsFor: 'accessing' stamp: 'ar 1/30/2001 23:20'! 421463angle: newAngle 421464 421465 self changed. 421466 transform := transform withAngle: newAngle. 421467 self layoutChanged. 421468 self changed! ! 421469 421470!TransformMorph methodsFor: 'accessing' stamp: 'di 2/23/98 14:44'! 421471colorForInsets 421472 ^ owner ifNil: [color] ifNotNil: [owner color]! ! 421473 421474!TransformMorph methodsFor: 'accessing'! 421475offset 421476 ^ transform offset + self innerBounds topLeft! ! 421477 421478!TransformMorph methodsFor: 'accessing'! 421479offset: newOffset 421480 421481 transform := transform withOffset: newOffset - self innerBounds topLeft. 421482 self changed! ! 421483 421484!TransformMorph methodsFor: 'accessing'! 421485scale 421486 ^ transform scale! ! 421487 421488!TransformMorph methodsFor: 'accessing' stamp: 'jm 4/17/1998 05:23'! 421489scale: newScale 421490 421491 self changed. 421492 transform := transform withScale: newScale. 421493 self layoutChanged. 421494 self changed. 421495! ! 421496 421497!TransformMorph methodsFor: 'accessing'! 421498setOffset: newOffset angle: newAngle scale: newScale 421499 421500 transform := MorphicTransform offset: newOffset angle: newAngle scale: newScale. 421501 self changed! ! 421502 421503!TransformMorph methodsFor: 'accessing' stamp: 'sps 11/29/2002 17:03'! 421504smoothing 421505 ^smoothing 421506! ! 421507 421508!TransformMorph methodsFor: 'accessing'! 421509smoothing: cellSize 421510 smoothing := cellSize. 421511 self changed! ! 421512 421513!TransformMorph methodsFor: 'accessing'! 421514smoothingOff 421515 smoothing := 1. 421516 self changed! ! 421517 421518!TransformMorph methodsFor: 'accessing'! 421519smoothingOn 421520 smoothing := 2. 421521 self changed! ! 421522 421523!TransformMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 18:04'! 421524transform 421525 ^transform! ! 421526 421527!TransformMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 18:04'! 421528transform: aTransform 421529 transform := aTransform.! ! 421530 421531 421532!TransformMorph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:49'! 421533invalidRect: damageRect from: aMorph 421534 "Translate damage reports from submorphs by the scrollOffset." 421535 aMorph == self 421536 ifTrue:[super invalidRect: damageRect from: self] 421537 ifFalse:[super invalidRect: (((transform localBoundsToGlobal: damageRect) intersect: bounds) expandBy: 1) from: self].! ! 421538 421539 421540!TransformMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/22/2000 18:00'! 421541grabTransform 421542 "Return the transform for the receiver which should be applied during grabbing" 421543 ^owner ifNil:[self transform] ifNotNil:[owner grabTransform composedWithLocal: self transform]! ! 421544 421545 421546!TransformMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:52'! 421547transformFrom: uberMorph 421548 "Return a transform to map coorinates of uberMorph, a morph above me in my owner chain, into the coordinates of my submorphs." 421549 421550 (self == uberMorph or: [owner isNil]) ifTrue: [^transform]. 421551 ^(owner transformFrom: uberMorph) composedWithLocal: transform! ! 421552 421553 421554!TransformMorph methodsFor: 'geometry' stamp: 'efc 7/24/2003 16:43'! 421555layoutChanged 421556 421557 "A submorph could have moved, thus changing my localBounds. Invalidate the cache." 421558 localBounds := nil. 421559 421560 ^super layoutChanged! ! 421561 421562!TransformMorph methodsFor: 'geometry' stamp: 'efc 7/24/2003 16:41'! 421563localSubmorphBounds 421564 "Answer, in my coordinate system, the bounds of all my submorphs (or nil if no submorphs). We will cache this value for performance. The value is invalidated upon recieving #layoutChanged." 421565 421566 localBounds ifNil:[ 421567 self submorphsDo:[:m | 421568 localBounds ifNil: [localBounds := m fullBounds] 421569 ifNotNil: [localBounds := localBounds quickMerge: m fullBounds]]. 421570 ]. 421571 421572 ^ localBounds! ! 421573 421574!TransformMorph methodsFor: 'geometry' stamp: 'nk 4/12/2002 14:02'! 421575localVisibleSubmorphBounds 421576 "Answer, in my coordinate system, the bounds of all my visible submorphs (or nil if no visible submorphs)" 421577 | subBounds | 421578 subBounds := nil. 421579 self submorphsDo: [:m | 421580 (m visible) ifTrue: [ 421581 subBounds 421582 ifNil: [subBounds := m fullBounds copy] 421583 ifNotNil: [subBounds := subBounds quickMerge: m fullBounds]] 421584 ]. 421585 ^subBounds! ! 421586 421587!TransformMorph methodsFor: 'geometry' stamp: 'nk 3/8/2004 11:05'! 421588numberOfItemsInView 421589 "Answer the number of my submorphs whose (transformed) bounds intersect mine. 421590 This includes items that are only partially visible. 421591 Ignore visibility of submorphs." 421592 421593 ^(submorphs select: [ :ea | self innerBounds intersects: (transform localBoundsToGlobal: ea bounds) ]) size! ! 421594 421595!TransformMorph methodsFor: 'geometry' stamp: 'GabrielOmarCotelli 6/8/2009 23:06'! 421596numberOfItemsPotentiallyInView 421597 421598 "Answer the number of items that could potentially be viewed in full, 421599 computed as my visible height divided by the average height of my submorphs. 421600 Ignore visibility of submorphs." 421601 421602 ^ self numberOfItemsPotentiallyInViewWith: self submorphCount! ! 421603 421604!TransformMorph methodsFor: 'geometry' stamp: 'GabrielOmarCotelli 6/8/2009 23:14'! 421605numberOfItemsPotentiallyInViewWith: listSize 421606 "This is a refactoring for numberOfItemsPotentiallyInView because in some cases the numberOfSubmorhps 421607 needs to be passed from the outside. " 421608 ^ self innerBounds height // (self localSubmorphBounds height / listSize)! ! 421609 421610 421611!TransformMorph methodsFor: 'geometry testing' stamp: 'wiz 11/6/2005 15:53'! 421612containsPoint: aPoint 421613 (bounds containsPoint: aPoint) ifFalse: [^ false]. 421614 self hasSubmorphs 421615 ifTrue: [ | localPoint | localPoint := (transform globalPointToLocal: aPoint) . 421616 self submorphsDo: 421617 [:m | (m containsPoint: localPoint) 421618 ifTrue: [^ true]]. 421619 ^ false] 421620 ifFalse: [^ true]! ! 421621 421622 421623!TransformMorph methodsFor: 'halos and balloon help' stamp: 'sw 12/29/1999 15:51'! 421624wantsHaloFromClick 421625 ^ false! ! 421626 421627 421628!TransformMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:31'! 421629defaultColor 421630 "answer the default color/fill style for the receiver" 421631 ^ Color lightGreen! ! 421632 421633!TransformMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:39'! 421634initialize 421635 "initialize the state of the receiver" 421636 super initialize. 421637 "" 421638 421639 smoothing := 1. 421640 transform := MorphicTransform identity! ! 421641 421642 421643!TransformMorph methodsFor: 'layout' stamp: 'di 11/20/2000 11:54'! 421644fullBounds 421645 "Overridden to clip submorph hit detection to my bounds." 421646 "It might be better to override doLayoutIn:, and remove this method" 421647 421648 fullBounds ifNotNil:[^ fullBounds]. 421649 fullBounds := bounds. 421650 submorphs do: [:m| m ownerChanged]. 421651 ^ fullBounds! ! 421652 421653!TransformMorph methodsFor: 'layout' stamp: 'nk 4/12/2002 14:03'! 421654submorphBounds 421655 "Answer, in owner coordinates, the bounds of my visible submorphs, or my bounds" 421656 | box | 421657 box := self localVisibleSubmorphBounds. 421658 ^(box ifNotNil: [ transform localBoundsToGlobal: box ] ifNil: [ self bounds ]) truncated. 421659! ! 421660 421661 421662!TransformMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 22:20'! 421663addCustomMenuItems: aCustomMenu hand: aHandMorph 421664 super addCustomMenuItems: aCustomMenu hand: aHandMorph. 421665 smoothing = 1 421666 ifTrue: [aCustomMenu add: 'turn on smoothing' translated action: #smoothingOn] 421667 ifFalse: [aCustomMenu add: 'turn off smoothing' translated action: #smoothingOff]! ! 421668 421669 421670!TransformMorph methodsFor: 'private' stamp: 'kfr 8/7/2004 18:48'! 421671privateFullMoveBy: delta 421672 "Private!! Relocate me, but not my subMorphs." 421673 421674 self privateMoveBy: delta. 421675 transform := (transform asMorphicTransform) withOffset: (transform offset - delta). 421676! ! 421677TransformMorph subclass: #TransformWithLayoutMorph 421678 instanceVariableNames: '' 421679 classVariableNames: '' 421680 poolDictionaries: '' 421681 category: 'Polymorph-Widgets'! 421682!TransformWithLayoutMorph commentStamp: 'gvc 5/18/2007 10:18' prior: 0! 421683A transform morph that allows the use of a layout policy to arrange submorphs.! 421684 421685 421686!TransformWithLayoutMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/1/2006 16:06'! 421687doLayoutIn: layoutBounds 421688 "Compute a new layout based on the given layout bounds." 421689 421690 "Note: Testing for #bounds or #layoutBounds would be sufficient to 421691 figure out if we need an invalidation afterwards but #outerBounds 421692 is what we need for all leaf nodes so we use that." 421693 421694 | layout box priorBounds | 421695 priorBounds := self outerBounds. 421696 submorphs isEmpty ifTrue: [^fullBounds := priorBounds]. 421697 "Send #ownerChanged to our children" 421698 submorphs do: [:m | m ownerChanged]. 421699 layout := self layoutPolicy. 421700 layout ifNotNil: [layout layout: self in: (0@0 extent: layoutBounds extent // self scale)]. 421701 self adjustLayoutBounds. 421702 fullBounds := self privateFullBounds. 421703 box := self outerBounds. 421704 box = priorBounds 421705 ifFalse: [self invalidRect: (priorBounds quickMerge: box)]! ! 421706 421707!TransformWithLayoutMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/29/2006 14:56'! 421708fullBounds 421709 "Do the ordinary thing. See comment in superclass." 421710 421711 ^self perform: #fullBounds withArguments: #() inSuperclass: Morph! ! 421712TransformMorph subclass: #TransformationMorph 421713 instanceVariableNames: '' 421714 classVariableNames: '' 421715 poolDictionaries: '' 421716 category: 'Morphic-Basic'! 421717!TransformationMorph commentStamp: 'mk 8/16/2005 11:58' prior: 0! 421718A TransformationMorph is like a transformMorph, except that it does not clip, and its bounds include its entire submorph. TransformationMorphs are assumed to have only one submorph -- the idea is that it is a wrapper that enables its submorph to scale and rotate. A TMorph may come to have more than one submorph if, eg, a menu sprouts a sub menu, using the transformationMorph temporarily as its world, but this ability is only sparsely supported (as in layoutChanged). 421719 421720See TransformationMorph class example1 method.! 421721 421722 421723!TransformationMorph methodsFor: 'accessing' stamp: 'wiz 12/7/2006 19:10'! 421724forwardDirection 421725 "Return the rendee's forward direction. 421726 If I have no rendee then return 0.0 degrees " 421727 | rendee | 421728 ( rendee := self renderedMorph) == self ifTrue: [ ^ 0.0 ] . 421729 421730 ^ rendee forwardDirection! ! 421731 421732!TransformationMorph methodsFor: 'accessing' stamp: 'jm 4/25/1998 05:55'! 421733hasNoScaleOrRotation 421734 421735 ^ transform isPureTranslation 421736! ! 421737 421738!TransformationMorph methodsFor: 'accessing' stamp: 'ar 9/22/2000 14:17'! 421739rotationDegrees: degrees 421740 self adjustAfter:[self angle: degrees degreesToRadians negated]! ! 421741 421742!TransformationMorph methodsFor: 'accessing' stamp: 'sw 2/15/2002 02:27'! 421743scaleFactor 421744 "Answer the scaleFactor" 421745 421746 ^ transform scale! ! 421747 421748 421749!TransformationMorph methodsFor: 'classification' stamp: 'jm 4/17/1998 00:44'! 421750isFlexMorph 421751 421752 ^ true 421753! ! 421754 421755!TransformationMorph methodsFor: 'classification' stamp: 'jm 5/7/1998 13:46'! 421756isRenderer 421757 421758 ^ true 421759! ! 421760 421761!TransformationMorph methodsFor: 'classification' stamp: 'wiz 12/7/2006 14:05'! 421762renderedMorph 421763"We are a renderer. Answer appropriately." 421764 421765submorphs isEmpty ifTrue: [^self]. 421766 ^self firstSubmorph renderedMorph! ! 421767 421768 421769!TransformationMorph methodsFor: 'drawing' stamp: 'di 2/23/98 19:59'! 421770drawOn: aCanvas 421771 submorphs isEmpty ifTrue: [super drawOn: aCanvas]! ! 421772 421773 421774!TransformationMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/22/2000 18:26'! 421775grabTransform 421776 "Return the transform for the receiver which should be applied during grabbing" 421777 self renderedMorph isWorldMorph 421778 ifTrue:[^owner ifNil:[IdentityTransform new] ifNotNil:[owner grabTransform]]. 421779 ^owner ifNil:[self transform] ifNotNil:[owner grabTransform composedWithLocal: self transform]! ! 421780 421781 421782!TransformationMorph methodsFor: 'geometry' stamp: 'ar 11/21/2000 17:00'! 421783computeBounds 421784 self hasSubmorphs ifTrue: 421785 [bounds := (transform localBoundsToGlobal: 421786 (Rectangle merging: 421787 (self submorphs collect: [:m | m fullBounds]))) truncated 421788 expandBy: 1]. 421789 fullBounds := bounds.! ! 421790 421791!TransformationMorph methodsFor: 'geometry' stamp: 'ar 4/18/2000 16:21'! 421792extent: newExtent 421793 | scaleFactor | 421794 self adjustAfter: 421795 [scaleFactor := (self scale * newExtent r / self fullBounds extent r) max: 0.1. 421796 self scale: (scaleFactor detentBy: 0.1 atMultiplesOf: 1.0 snap: false)]! ! 421797 421798!TransformationMorph methodsFor: 'geometry' stamp: 'ar 10/25/2000 16:24'! 421799transformedBy: aTransform 421800 self changed. 421801 self transform: (self transform composedWithGlobal: aTransform). 421802 self computeBounds. 421803 self changed.! ! 421804 421805 421806!TransformationMorph methodsFor: 'geometry etoy' stamp: 'di 10/1/2000 11:48'! 421807degreesOfFlex 421808 "Return any rotation due to flexing" 421809 ^ self rotationDegrees! ! 421810 421811!TransformationMorph methodsFor: 'geometry etoy' stamp: 'wiz 12/7/2006 19:10'! 421812forwardDirection: degrees 421813 "If we have a rendee set its forward direction. Else do nothing." 421814 421815| rendee | 421816( rendee := self renderedMorph) == self ifTrue: [ ^ self ] . 421817 ^rendee forwardDirection: degrees! ! 421818 421819!TransformationMorph methodsFor: 'geometry etoy' stamp: 'wiz 12/7/2006 16:30'! 421820heading 421821 "End recusion when necessary." 421822 | rendee | 421823 (rendee := self renderedMorph) == self ifTrue: [ ^0.0 ] . 421824 ^ rendee heading! ! 421825 421826!TransformationMorph methodsFor: 'geometry etoy' stamp: 'al 7/22/2008 20:25'! 421827heading: newHeading 421828 "If we have a rendee set its heading. Else do nothing." 421829 421830 | rendee | 421831 (rendee := self renderedMorph) == self ifTrue: [ ^self ]. 421832 ^rendee heading: newHeading! ! 421833 421834!TransformationMorph methodsFor: 'geometry etoy' stamp: 'sw 3/28/2001 14:24'! 421835referencePosition 421836 "Answer the receiver's reference position, bullet-proofed against infinite recursion in the unlikely but occasionally-seen case that I am my own renderee" 421837 421838 | rendered | 421839 ^ (rendered := self renderedMorph) == self 421840 ifTrue: 421841 [super referencePosition] 421842 ifFalse: 421843 [transform localPointToGlobal: rendered referencePosition]! ! 421844 421845!TransformationMorph methodsFor: 'geometry etoy' stamp: 'ar 6/12/2001 05:23'! 421846setDirectionFrom: aPoint 421847 | delta degrees inner | 421848 inner := self renderedMorph. 421849 inner == self ifTrue:[^self]. 421850 delta := (inner transformFromWorld globalPointToLocal: aPoint) - inner referencePosition. 421851 degrees := delta degrees + 90.0. 421852 self forwardDirection: (degrees \\ 360) rounded. 421853! ! 421854 421855!TransformationMorph methodsFor: 'geometry etoy' stamp: 'sw 10/6/2004 11:33'! 421856visible: aBoolean 421857 "Set the receiver's visibility property" 421858 421859 super visible: aBoolean. 421860 submorphs isEmptyOrNil ifFalse: [submorphs first visible: aBoolean]! ! 421861 421862 421863!TransformationMorph methodsFor: 'initialization' stamp: 'di 2/21/98 14:35'! 421864asFlexOf: aMorph 421865 "Initialize me with position and bounds of aMorph, 421866 and with an offset that provides centered rotation." 421867 | pos | 421868 pos := aMorph position. 421869 self addMorph: aMorph. 421870 aMorph position: (aMorph extent // 2) negated. 421871 self position: pos. 421872 transform := transform withOffset: aMorph position - pos 421873! ! 421874 421875!TransformationMorph methodsFor: 'initialization' stamp: 'di 9/30/1998 23:12'! 421876flexing: aMorph byTransformation: tfm 421877 "Initialize me with position and bounds of aMorph, 421878 and with an offset that provides centered rotation." 421879 421880 (aMorph isKindOf: TransformationMorph) 421881 ifTrue: [aMorph submorphsDo: [:m | self addMorph: m clone]] 421882 ifFalse: [self addMorph: aMorph]. 421883 transform := tfm. 421884 self chooseSmoothing. 421885 self layoutChanged.! ! 421886 421887 421888!TransformationMorph methodsFor: 'layout' stamp: 'ar 10/25/2000 16:21'! 421889layoutChanged 421890 "Recompute bounds as a result of change" 421891 self computeBounds. 421892 super layoutChanged! ! 421893 421894 421895!TransformationMorph methodsFor: 'menu' stamp: 'stephane.ducasse 11/8/2008 19:33'! 421896removeFlexShell 421897 "Remove the shell used to make a morph rotatable and scalable." 421898 421899 | oldHalo unflexed myWorld refPos aPosition | 421900 refPos := self referencePosition. 421901 myWorld := self world. 421902 oldHalo := self halo. 421903 submorphs isEmpty ifTrue: [^ self delete]. 421904 aPosition := (owner submorphIndexOf: self) ifNil: [1]. 421905 unflexed := self firstSubmorph. 421906 self submorphs do: [:m | 421907 m position: self center - (m extent // 2). 421908 owner addMorph: m asElementNumber: aPosition]. 421909 oldHalo ifNotNil: [oldHalo setTarget: unflexed]. 421910 myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: unflexed]. 421911 self delete. 421912 unflexed referencePosition: refPos. 421913 ^ unflexed! ! 421914 421915 421916!TransformationMorph methodsFor: 'naming' stamp: 'sw 5/13/1998 10:32'! 421917innocuousName 421918 | r | 421919 ^ (r := self renderedMorph) == self 421920 ifTrue: [super innocuousName] ifFalse: [r innocuousName]! ! 421921 421922 421923!TransformationMorph methodsFor: 'nil' stamp: 'ar 9/23/2000 13:40'! 421924scaleToMatch: aPoint 421925 | scaleFactor tfm originalScale | 421926 tfm := transform withScale: 1.0. 421927 originalScale := ((tfm localBoundsToGlobal: self renderedMorph fullBounds) corner - 421928 (tfm localPointToGlobal: self renderedMorph referencePosition)) r. 421929 "Catch cases where the reference point is on fullBounds corner" 421930 originalScale < 1.0 ifTrue:[originalScale := 1.0]. 421931 scaleFactor := (aPoint - self referencePosition) r / originalScale. 421932 scaleFactor := scaleFactor < 1.0 421933 ifTrue: [scaleFactor detentBy: 0.05 atMultiplesOf: 0.25 snap: false] 421934 ifFalse: [scaleFactor detentBy: 0.1 atMultiplesOf: 0.5 snap: false]. 421935 self adjustAfter:[self scale: ((scaleFactor min: 8.0) max: 0.1)].! ! 421936 421937 421938!TransformationMorph methodsFor: 'printing' stamp: 'dgd 2/21/2003 22:42'! 421939printOn: aStream 421940 super printOn: aStream. 421941 submorphs isEmpty 421942 ifTrue: [aStream nextPutAll: ' with no transformee!!'] 421943 ifFalse: [aStream nextPutAll: ' on ' , submorphs first printString]! ! 421944 421945 421946!TransformationMorph methodsFor: 'rotate scale and flex' stamp: 'di 2/20/98 14:53'! 421947rotationDegrees 421948 ^ self angle radiansToDegrees negated! ! 421949 421950 421951!TransformationMorph methodsFor: 'submorphs-add/remove' stamp: 'di 11/18/1999 15:44'! 421952replaceSubmorph: oldMorph by: newMorph 421953 | t b | 421954 t := transform. 421955 b := bounds. 421956 super replaceSubmorph: oldMorph by: newMorph. 421957 transform := t. 421958 bounds := b. 421959 self layoutChanged! ! 421960 421961 421962!TransformationMorph methodsFor: 'testing' stamp: 'marcus.denker 9/17/2008 19:13'! 421963isSticky 421964 submorphs isEmpty ifFalse: [^ submorphs first isSticky]. 421965 ^false! ! 421966 421967!TransformationMorph methodsFor: 'testing' stamp: 'mdr 10/3/2000 11:28'! 421968stepTime 421969 "Answer the stepTime of my rendered morph if posible" 421970 421971 | rendered | 421972 rendered := self renderedMorph. 421973 rendered = self ifTrue: [^super stepTime]. "Hack to avoid infinite recursion" 421974 ^rendered stepTime. 421975 ! ! 421976 421977 421978!TransformationMorph methodsFor: 'private' stamp: 'stephane.ducasse 10/16/2008 17:27'! 421979adjustAfter: changeBlock 421980 "Cause this morph to remain cetered where it was before, and 421981 choose appropriate smoothing, after a change of scale or rotation." 421982 | oldRefPos | 421983 oldRefPos := self referencePosition. 421984 changeBlock value. 421985 self chooseSmoothing. 421986 self layoutChanged. 421987 owner ifNotNil: [owner invalidRect: bounds] 421988! ! 421989 421990!TransformationMorph methodsFor: 'private' stamp: 'aoy 2/17/2003 01:02'! 421991chooseSmoothing 421992 "Choose appropriate smoothing, after a change of scale or rotation." 421993 421994 smoothing := (self scale < 1.0 or: [self angle ~= (self angle roundTo: Float pi / 2.0)]) 421995 ifTrue: [ 2] 421996 ifFalse: [1]! ! 421997 421998"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 421999 422000TransformationMorph class 422001 instanceVariableNames: ''! 422002 422003!TransformationMorph class methodsFor: 'example' stamp: 'mk 8/14/2005 16:07'! 422004example1 422005 | stringMorph transformationMorph | 422006 stringMorph := 'vertical text' asMorph. 422007 transformationMorph := TransformationMorph new asFlexOf: stringMorph. 422008 transformationMorph angle: Float pi / 2. 422009 transformationMorph position: 5@5. 422010 transformationMorph openInWorld.! ! 422011Object subclass: #TranslatedReceiverFinder 422012 instanceVariableNames: '' 422013 classVariableNames: '' 422014 poolDictionaries: '' 422015 category: 'Multilingual-Editor'! 422016 422017!TranslatedReceiverFinder methodsFor: 'as yet unclassified' stamp: 'yo 8/2/2004 17:22'! 422018searchBlockNode: aBlockNode addTo: aCollection 422019 422020 aBlockNode statements do: [:e | 422021 (e isMemberOf: MessageNode) ifTrue: [self searchMessageNode: e addTo: aCollection]. 422022 (e isMemberOf: ReturnNode) ifTrue: [self searchReturnNode: e addTo: aCollection]. 422023 ]. 422024! ! 422025 422026!TranslatedReceiverFinder methodsFor: 'as yet unclassified' stamp: 'yo 8/2/2004 17:23'! 422027searchMessageNode: aMessageNode addTo: aCollection 422028 422029 ((aMessageNode receiver isMemberOf: LiteralNode) and: [(aMessageNode selector isMemberOf: SelectorNode) and: [aMessageNode selector key = #translated]]) ifTrue: [ 422030 aCollection add: aMessageNode receiver key. 422031 ]. 422032 422033 (aMessageNode receiver isMemberOf: BlockNode) ifTrue: [self searchBlockNode: aMessageNode receiver addTo: aCollection]. 422034 (aMessageNode receiver isMemberOf: MessageNode) ifTrue: [self searchMessageNode: aMessageNode receiver addTo: aCollection]. 422035 (aMessageNode receiver isMemberOf: ReturnNode) ifTrue: [self searchReturnNode: aMessageNode receiver addTo: aCollection]. 422036 422037 aMessageNode arguments do: [:a | 422038 (a isMemberOf: BlockNode) ifTrue: [self searchBlockNode: a addTo: aCollection]. 422039 (a isMemberOf: MessageNode) ifTrue: [self searchMessageNode: a addTo: aCollection]. 422040 (a isMemberOf: ReturnNode) ifTrue: [self searchReturnNode: a addTo: aCollection]. 422041 ]. 422042! ! 422043 422044!TranslatedReceiverFinder methodsFor: 'as yet unclassified' stamp: 'yo 8/2/2004 17:22'! 422045searchMethodNode: aMethodNode addTo: aCollection 422046 422047 (aMethodNode block isMemberOf: BlockNode) ifTrue: [self searchBlockNode: aMethodNode block addTo: aCollection]. 422048 (aMethodNode block isMemberOf: MessageNode) ifTrue: [self searchMessageNode: aMethodNode block addTo: aCollection]. 422049 (aMethodNode block isMemberOf: ReturnNode) ifTrue: [self searchReturnNode: aMethodNode block addTo: aCollection]. 422050! ! 422051 422052!TranslatedReceiverFinder methodsFor: 'as yet unclassified' stamp: 'yo 8/2/2004 17:21'! 422053searchReturnNode: aReturnNode addTo: aCollection 422054 422055 (aReturnNode expr isMemberOf: BlockNode) ifTrue: [self searchBlockNode: aReturnNode expr addTo: aCollection]. 422056 (aReturnNode expr isMemberOf: MessageNode) ifTrue: [self searchMessageNode: aReturnNode expr addTo: aCollection]. 422057! ! 422058 422059!TranslatedReceiverFinder methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:21'! 422060senders 422061 422062 | m o | 422063 m := SystemNavigation default allCallsOn: #translated. 422064 m := m collect: [:e | 422065 e classIsMeta ifTrue: [ 422066 (Smalltalk at: e classSymbol) class decompile: e methodSymbol. 422067 ] ifFalse: [ 422068 (Smalltalk at: e classSymbol) decompile: e methodSymbol. 422069 ] 422070 ]. 422071 422072 o := SortedCollection new. 422073 m do: [:e | self searchMethodNode: e addTo: o]. 422074 ^ o. 422075! ! 422076 422077"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 422078 422079TranslatedReceiverFinder class 422080 instanceVariableNames: ''! 422081 422082!TranslatedReceiverFinder class methodsFor: 'as yet unclassified' stamp: 'dgd 4/3/2006 13:24'! 422083makeJapaneseTranslationFile 422084 | t n | 422085 NaturalLanguageTranslator initializeKnownPhrases. 422086 t := TranslatedReceiverFinder new senders. 422087 n := NaturalLanguageTranslator 422088 localeID: (LocaleID isoLanguage: 'ja'). 422089 t 422090 do: [:w | 422091 NaturalLanguageTranslator registerPhrase: w. 422092 self 422093 at: w 422094 ifPresent: [:k | n phrase: w translation: k]]. 422095 n saveToFileNamed: 'ja.translation'! ! 422096Color subclass: #TranslucentColor 422097 instanceVariableNames: 'alpha' 422098 classVariableNames: '' 422099 poolDictionaries: '' 422100 category: 'Graphics-Primitives'! 422101!TranslucentColor commentStamp: '<historical>' prior: 0! 422102A TranslucentColor behaves just like a normal color, except that it will pack its alpha value into the high byte of a 32-bit pixelValue. This allows creating forms with translucency for use with the alpha blend function of BitBlt. An alpha of zero is transparent, and 1.0 is opaque.! 422103 422104 422105!TranslucentColor methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 14:13'! 422106pixelWord32 422107 "Returns an integer representing the bits that appear in a single pixel of this color in a Form of depth 32. 422108 Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue. 422109 Just a little quicker if we are dealing with RGBA colors at 32 bit depth." 422110 422111 | val | 422112 val := super pixelWord32. 422113 val at: 4 put: alpha. 422114 ^val 422115! ! 422116 422117 422118!TranslucentColor methodsFor: 'accessing'! 422119alpha 422120 "Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque." 422121 422122 ^ alpha asFloat / 255.0 422123! ! 422124 422125 422126!TranslucentColor methodsFor: 'conversions' stamp: 'di 1/15/1999 11:44'! 422127alpha: alphaValue 422128 alphaValue = 1.0 ifTrue: 422129 [^ Color basicNew 422130 setPrivateRed: self privateRed 422131 green: self privateGreen 422132 blue: self privateBlue]. 422133 ^ super alpha: alphaValue! ! 422134 422135!TranslucentColor methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'! 422136asNontranslucentColor 422137 ^ self alpha: 1.0! ! 422138 422139!TranslucentColor methodsFor: 'conversions' stamp: 'di 3/25/2000 17:56'! 422140balancedPatternForDepth: depth 422141 "Return an appropriate bit pattern or stipple. This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency." 422142 422143 alpha = 0 ifTrue: [^ Bitmap with: 0]. 422144 ^ super balancedPatternForDepth: depth! ! 422145 422146!TranslucentColor methodsFor: 'conversions' stamp: 'di 1/14/1999 20:05'! 422147bitPatternForDepth: depth 422148 "Return an appropriate bit pattern or stipple. This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency." 422149 422150 alpha = 0 ifTrue: [^ Bitmap with: 0]. 422151 ^ super bitPatternForDepth: depth! ! 422152 422153!TranslucentColor methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 422154pixelValueForDepth: d 422155 "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." 422156 | basicPixelWord | 422157 alpha = 0 ifTrue: [ ^ 0 ]. 422158 basicPixelWord := super pixelValueForDepth: d. 422159 d < 32 422160 ifTrue: [ ^ basicPixelWord ] 422161 ifFalse: [ ^ (basicPixelWord bitAnd: 16777215) bitOr: (alpha bitShift: 24) ]! ! 422162 422163!TranslucentColor methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 422164pixelWordForDepth: depth 422165 "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." 422166 | basicPixelWord | 422167 alpha = 0 ifTrue: [ ^ 0 ]. 422168 basicPixelWord := super pixelWordForDepth: depth. 422169 depth < 32 422170 ifTrue: [ ^ basicPixelWord ] 422171 ifFalse: [ ^ (basicPixelWord bitAnd: 16777215) bitOr: (alpha bitShift: 24) ]! ! 422172 422173!TranslucentColor methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 422174scaledPixelValue32 422175 "Return the alpha scaled pixel value for depth 32" 422176 | pv32 a b g r | 422177 pv32 := super scaledPixelValue32. 422178 a := (self alpha * 255.0) rounded. 422179 b := (pv32 bitAnd: 255) * a // 256. 422180 g := ((pv32 bitShift: -8) bitAnd: 255) * a // 256. 422181 r := ((pv32 bitShift: -16) bitAnd: 255) * a // 256. 422182 ^ b + (g bitShift: 8) + (r bitShift: 16) + (a bitShift: 24)! ! 422183 422184 422185!TranslucentColor methodsFor: 'equality'! 422186hash 422187 422188 ^ rgb bitXor: alpha 422189! ! 422190 422191 422192!TranslucentColor methodsFor: 'printing' stamp: 'mir 7/21/1999 11:43'! 422193storeArrayValuesOn: aStream 422194 422195 self isTransparent ifTrue: [ 422196 ^ aStream space]. 422197 super storeArrayValuesOn: aStream. 422198 422199 aStream space. 422200 (self alpha roundTo: 0.001) storeOn: aStream. 422201 422202! ! 422203 422204!TranslucentColor methodsFor: 'printing' stamp: 'di 9/27/2000 13:33'! 422205storeOn: aStream 422206 422207 self isTransparent ifTrue: [^ aStream nextPutAll: '(Color transparent)']. 422208 super storeOn: aStream. 422209 aStream 422210 skip: -1; "get rid of trailing )" 422211 nextPutAll: ' alpha: '; 422212 print: (self alpha roundTo: 0.001); 422213 nextPutAll: ')'. 422214! ! 422215 422216 422217!TranslucentColor methodsFor: 'queries' stamp: 'ar 4/20/2001 04:33'! 422218isOpaque 422219 ^alpha = 255! ! 422220 422221!TranslucentColor methodsFor: 'queries' stamp: 'di 12/30/1998 14:33'! 422222isTranslucent 422223 ^ alpha < 255! ! 422224 422225!TranslucentColor methodsFor: 'queries' stamp: 'di 1/3/1999 12:22'! 422226isTranslucentColor 422227 "This means: self isTranslucent, but isTransparent not" 422228 ^ alpha > 0! ! 422229 422230!TranslucentColor methodsFor: 'queries' stamp: 'di 12/30/1998 14:33'! 422231isTransparent 422232 ^ alpha = 0! ! 422233 422234 422235!TranslucentColor methodsFor: 'private'! 422236privateAlpha 422237 "Return my raw alpha value, an integer in the range 0..255. Used for fast equality testing." 422238 422239 ^ alpha 422240! ! 422241 422242!TranslucentColor methodsFor: 'private' stamp: 'marcus.denker 9/14/2008 19:04'! 422243setRgb: rgbValue alpha: alphaValue 422244 "Set the state of this translucent color. Alpha is represented internally by an integer in the range 0..255." 422245 422246 rgb ifNotNil: [self attemptToMutateError]. 422247 rgb := rgbValue. 422248 alpha := (255.0 * alphaValue) asInteger min: 255 max: 0. 422249! ! 422250Morph subclass: #TranslucentProgessMorph 422251 instanceVariableNames: 'opaqueBackgroundColor' 422252 classVariableNames: '' 422253 poolDictionaries: '' 422254 category: 'Morphic-Windows'! 422255 422256!TranslucentProgessMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/29/2000 11:35'! 422257opaqueBackgroundColor: aColor 422258 422259 opaqueBackgroundColor := aColor! ! 422260 422261!TranslucentProgessMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/23/2000 11:19'! 422262revealingStyle 422263 422264">>>> 422265 1 = original, no change after 100% 422266 2 = hold at last 25% and blink until done 422267 3 = wrap around from 100% back to 0 and go again. change color after first 422268<<<<" 422269 ^3 422270! ! 422271 422272 422273!TranslucentProgessMorph methodsFor: 'drawing' stamp: 'nk 7/12/2003 08:59'! 422274drawOn: aCanvas 422275 422276 | revealPercentage revealingStyle revealingColor revealingBounds revealToggle x baseColor revealTimes secondsRemaining stringToDraw where fontToUse innerBounds | 422277 422278 innerBounds := bounds. 422279 opaqueBackgroundColor ifNotNil: [ 422280 aCanvas 422281 frameAndFillRectangle: bounds 422282 fillColor: opaqueBackgroundColor 422283 borderWidth: 8 422284 borderColor: Color blue. 422285 innerBounds := innerBounds insetBy: 8. 422286 ]. 422287 revealTimes := (self valueOfProperty: #revealTimes) ifNil: [^self]. 422288 revealPercentage := (revealTimes first / revealTimes second) asFloat. 422289 revealingStyle := self revealingStyle. 422290 x := self valueOfProperty: #progressStageNumber ifAbsent: [1]. 422291 baseColor := Color perform: (#(red blue green magenta cyan yellow) atPin: x). 422292 revealingColor := baseColor alpha: 0.2. 422293 revealingStyle = 3 ifTrue: [ "wrap and change color" 422294 revealPercentage > 1.0 ifTrue: [ 422295 revealingColor := baseColor alpha: (0.2 + (revealingStyle / 10) min: 0.5). 422296 ]. 422297 revealPercentage := revealPercentage fractionPart. 422298 ]. 422299 revealingStyle = 2 ifTrue: [ "peg at 75 and blink" 422300 revealPercentage > 0.75 ifTrue: [ 422301 revealToggle := self valueOfProperty: #revealToggle ifAbsent: [true]. 422302 self setProperty: #revealToggle toValue: revealToggle not. 422303 revealToggle ifTrue: [revealingColor := baseColor alpha: 0.8.]. 422304 ]. 422305 revealPercentage := revealPercentage min: 0.75. 422306 ]. 422307 revealingBounds := innerBounds withLeft: innerBounds left + (innerBounds width * revealPercentage) truncated. 422308 aCanvas 422309 fillRectangle: revealingBounds 422310 color: revealingColor. 422311 secondsRemaining := (revealTimes second - revealTimes first / 1000) rounded. 422312 secondsRemaining > 0 ifTrue: [ 422313 fontToUse := StrikeFont familyName: Preferences standardEToysFont familyName size: 24. 422314 stringToDraw := secondsRemaining printString. 422315 where := innerBounds corner - ((fontToUse widthOfString: stringToDraw) @ fontToUse height). 422316 aCanvas 422317 drawString: stringToDraw 422318 in: (where corner: innerBounds corner) 422319 font: fontToUse 422320 color: Color black. 422321 aCanvas 422322 drawString: stringToDraw 422323 in: (where - (1@1) corner: innerBounds corner) 422324 font: fontToUse 422325 color: Color white. 422326 ]. 422327 422328 422329! ! 422330 422331 422332!TranslucentProgessMorph methodsFor: 'wiw support' stamp: 'RAA 7/19/2000 18:52'! 422333morphicLayerNumber 422334 422335 "helpful for insuring some morphs always appear in front of or behind others. 422336 smaller numbers are in front" 422337 422338 ^self valueOfProperty: #morphicLayerNumber ifAbsent: [12]. 422339 422340 "progress morphs are behind menus and balloons, but in front of most other stuff"! ! 422341SimpleHierarchicalListMorph subclass: #TreeListMorph 422342 instanceVariableNames: 'font enabled' 422343 classVariableNames: '' 422344 poolDictionaries: '' 422345 category: 'Polymorph-Widgets'! 422346!TreeListMorph commentStamp: 'gvc 5/18/2007 10:15' prior: 0! 422347A SimpleHierarchicalListMorph subclass supporting alternative fonts for all items.! 422348 422349 422350!TreeListMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:01'! 422351font 422352 "Answer the value of font" 422353 422354 ^font ifNil: [TextStyle defaultFont]! ! 422355 422356!TreeListMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:00'! 422357font: anObject 422358 "Set the value of font" 422359 422360 font := anObject! ! 422361 422362 422363!TreeListMorph methodsFor: 'private' stamp: 'gvc 5/15/2007 16:23'! 422364addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean 422365 "Update the font on each morph." 422366 422367 |answer| 422368 answer := super addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean. 422369 self scroller submorphsDo: [:i | 422370 i 422371 font: self font; 422372 extent: i minWidth @ i minHeight]. 422373 ^answer! ! 422374 422375!TreeListMorph methodsFor: 'private' stamp: 'gvc 5/15/2007 16:16'! 422376insertNewMorphs: morphList 422377 "Update the font on each morph." 422378 422379 morphList do: [:m | 422380 m 422381 font: self font; 422382 extent: m minWidth @ m minHeight]. 422383 ^super insertNewMorphs: morphList! ! 422384 422385!TreeListMorph methodsFor: 'private' stamp: 'gvc 1/29/2009 16:34'! 422386layoutBounds: aRectangle 422387 "Set the bounds for laying out children of the receiver. 422388 Update the scroller and scrollbars now since bounds set directly 422389 (not via #extent:)." 422390 422391 super layoutBounds: aRectangle. 422392 self 422393 resizeScroller; 422394 setScrollDeltas! ! 422395WidgetStub subclass: #TreeNodeStub 422396 instanceVariableNames: 'item' 422397 classVariableNames: '' 422398 poolDictionaries: '' 422399 category: 'ToolBuilder-SUnit'! 422400 422401!TreeNodeStub methodsFor: 'events' stamp: 'stephaneducasse 2/3/2006 22:32'! 422402openPath: anArray 422403 | child | 422404 anArray isEmpty 422405 ifTrue: [self select] 422406 ifFalse: [child := self children 422407 detect: [:ea | ea matches: anArray first] 422408 ifNone: [^ self select]. 422409 child openPath: anArray allButFirst] 422410 ! ! 422411 422412 422413!TreeNodeStub methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:32'! 422414setSpec: aSpec item: anObject 422415 super setSpec: aSpec. 422416 item := anObject! ! 422417 422418 422419!TreeNodeStub methodsFor: 'printing' stamp: 'cwp 4/23/2005 00:54'! 422420printOn: aStream 422421 aStream 422422 print: self class; 422423 nextPut: $<; 422424 print: item; 422425 nextPut: $>! ! 422426 422427 422428!TreeNodeStub methodsFor: 'simulating' stamp: 'cwp 4/23/2005 00:50'! 422429children 422430 ^ (self model perform: spec getChildren with: item) 422431 collect: [:ea | TreeNodeStub fromSpec: spec item: ea]! ! 422432 422433!TreeNodeStub methodsFor: 'simulating' stamp: 'cwp 4/23/2005 00:49'! 422434item 422435 ^ item! ! 422436 422437!TreeNodeStub methodsFor: 'simulating' stamp: 'cwp 4/23/2005 00:57'! 422438label 422439 ^ self model perform: spec label with: item! ! 422440 422441!TreeNodeStub methodsFor: 'simulating' stamp: 'cwp 4/23/2005 00:23'! 422442select 422443 self model perform: spec setSelected with: item! ! 422444 422445 422446!TreeNodeStub methodsFor: 'private' stamp: 'cwp 4/23/2005 00:56'! 422447matches: aString 422448 ^ self label = aString! ! 422449 422450!TreeNodeStub methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:32'! 422451selectPath: anArray 422452 | child | 422453 anArray isEmpty ifTrue: [^ self select]. 422454 child := self children detect: [:ea | ea matches: anArray first] ifNone: [^ self select]. 422455 child selectPath: anArray allButFirst.! ! 422456 422457"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 422458 422459TreeNodeStub class 422460 instanceVariableNames: ''! 422461 422462!TreeNodeStub class methodsFor: 'instance creation' stamp: 'cwp 4/23/2005 00:15'! 422463fromSpec: aSpec item: anObject 422464 ^ self new setSpec: aSpec item: anObject! ! 422465WidgetStub subclass: #TreeStub 422466 instanceVariableNames: 'roots' 422467 classVariableNames: '' 422468 poolDictionaries: '' 422469 category: 'ToolBuilder-SUnit'! 422470 422471!TreeStub methodsFor: 'events' stamp: 'cwp 4/22/2005 22:40'! 422472eventAccessors 422473 ^ #(roots getSelectedPath setSelected getChildren hasChildren label icon help menu keyPress)! ! 422474 422475!TreeStub methodsFor: 'events' stamp: 'cwp 4/23/2005 01:00'! 422476updateRoots 422477 ^ self roots: (self model perform: spec roots) 422478! ! 422479 422480!TreeStub methodsFor: 'events' stamp: 'stephaneducasse 2/3/2006 22:32'! 422481updateSelectedPath 422482 | path first | 422483 path := self model perform: spec getSelectedPath. 422484 first := roots detect: [:ea | ea item = path first] ifNone: [^ self]. 422485 first selectPath: path allButFirst.! ! 422486 422487!TreeStub methodsFor: 'events' stamp: 'cwp 4/23/2005 01:00'! 422488update: anObject 422489 anObject == spec roots ifTrue: [^ self updateRoots]. 422490 anObject == spec getSelectedPath ifTrue: [^ self updateSelectedPath]. 422491 (anObject isKindOf: Array) ifTrue: [^ self openPath: anObject allButFirst]. 422492 super update: anObject 422493 ! ! 422494 422495 422496!TreeStub methodsFor: 'initialization' stamp: 'cwp 4/23/2005 00:28'! 422497setSpec: aSpec 422498 super setSpec: aSpec. 422499 self update: spec roots! ! 422500 422501 422502!TreeStub methodsFor: 'simulating' stamp: 'cwp 6/7/2005 00:31'! 422503select: anArray 422504 self openPath: anArray! ! 422505 422506 422507!TreeStub methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:32'! 422508openPath: anArray 422509 | first | 422510 first := roots detect: [:ea | ea matches: anArray first] ifNone: [^ self]. 422511 first openPath: anArray allButFirst! ! 422512 422513!TreeStub methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:32'! 422514roots: anArray 422515 roots := anArray collect: [:ea | TreeNodeStub fromSpec: spec item: ea]. 422516! ! 422517Boolean subclass: #True 422518 instanceVariableNames: '' 422519 classVariableNames: '' 422520 poolDictionaries: '' 422521 category: 'Kernel-Objects'! 422522!True commentStamp: '<historical>' prior: 0! 422523True defines the behavior of its single instance, true -- logical assertion. Notice how the truth-value checks become direct message sends, without the need for explicit testing. 422524 422525Be aware however that most of these methods are not sent as real messages in normal use. Most are inline coded by the compiler as test and jump bytecodes - avoiding the overhead of the full message sends. So simply redefining these methods here will have no effect.! 422526 422527 422528!True methodsFor: 'controlling'! 422529and: alternativeBlock 422530 "Nonevaluating conjunction -- answer the value of alternativeBlock since 422531 the receiver is true." 422532 422533 ^alternativeBlock value! ! 422534 422535!True methodsFor: 'controlling'! 422536ifFalse: alternativeBlock 422537 "Since the condition is true, the value is the true alternative, which is nil. 422538 Execution does not actually reach here because the expression is compiled 422539 in-line." 422540 422541 ^nil! ! 422542 422543!True methodsFor: 'controlling'! 422544ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock 422545 "Answer the value of trueAlternativeBlock. Execution does not 422546 actually reach here because the expression is compiled in-line." 422547 422548 ^trueAlternativeBlock value! ! 422549 422550!True methodsFor: 'controlling'! 422551ifTrue: alternativeBlock 422552 "Answer the value of alternativeBlock. Execution does not actually 422553 reach here because the expression is compiled in-line." 422554 422555 ^alternativeBlock value! ! 422556 422557!True methodsFor: 'controlling'! 422558ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock 422559 "Answer with the value of trueAlternativeBlock. Execution does not 422560 actually reach here because the expression is compiled in-line." 422561 422562 ^trueAlternativeBlock value! ! 422563 422564!True methodsFor: 'controlling'! 422565or: alternativeBlock 422566 "Nonevaluating disjunction -- answer true since the receiver is true." 422567 422568 ^self! ! 422569 422570 422571!True methodsFor: 'logical operations' stamp: 'md 7/30/2005 18:04'! 422572& aBoolean 422573 "Evaluating conjunction -- answer aBoolean since receiver is true." 422574 422575 ^aBoolean! ! 422576 422577!True methodsFor: 'logical operations'! 422578not 422579 "Negation--answer false since the receiver is true." 422580 422581 ^false! ! 422582 422583!True methodsFor: 'logical operations' stamp: 'em 3/24/2009 14:05'! 422584xor: aBoolean 422585 "Posted by Eliot Miranda to squeak-dev on 3/24/2009" 422586 422587 ^aBoolean not! ! 422588 422589!True methodsFor: 'logical operations'! 422590| aBoolean 422591 "Evaluating disjunction (OR) -- answer true since the receiver is true." 422592 422593 ^self! ! 422594 422595 422596!True methodsFor: 'printing' stamp: 'ajh 7/1/2004 10:36'! 422597asBit 422598 422599 ^ 1! ! 422600 422601!True methodsFor: 'printing'! 422602printOn: aStream 422603 422604 aStream nextPutAll: 'true'! ! 422605 422606"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 422607 422608True class 422609 instanceVariableNames: ''! 422610 422611!True class methodsFor: 'as yet unclassified' stamp: 'sw 5/8/2000 11:09'! 422612initializedInstance 422613 ^ true! ! 422614ClassTestCase subclass: #TrueTest 422615 instanceVariableNames: '' 422616 classVariableNames: '' 422617 poolDictionaries: '' 422618 category: 'KernelTests-Objects'! 422619 422620!TrueTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:06'! 422621testAND 422622 422623 self assert: (true & true) = true. 422624 self assert: (true & false) = false.! ! 422625 422626!TrueTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:06'! 422627testInMemory 422628 422629 self assert: (false isInMemory = true).! ! 422630 422631!TrueTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:06'! 422632testNew 422633 422634 self should: [True new] raise: Error. ! ! 422635 422636!TrueTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:06'! 422637testNot 422638 422639 self assert: (false not = true).! ! 422640 422641!TrueTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:06'! 422642testPrintOn 422643 422644 self assert: (String streamContents: [:stream | true printOn: stream]) = 'true'. ! ! 422645 422646!TrueTest methodsFor: 'testing' stamp: 'NikoSchwarz 10/17/2009 18:21'! 422647testXor 422648 self assert: (true xor: true) = false. 422649 self assert: (true xor: false) = true. 422650 422651 self 422652 should: [(true xor: [true]) 422653 ifTrue: ["This should never be true, do not signal an Error and let the test fail"] 422654 ifFalse: [self error: 'OK, this should be false, raise an Error']] 422655 raise: Error 422656 description: 'a Block argument is not allowed. If it were, answer would be false'.! ! 422657Object subclass: #TwoLevelDictionary 422658 instanceVariableNames: 'firstLevel' 422659 classVariableNames: '' 422660 poolDictionaries: '' 422661 category: 'System-FilePackage'! 422662!TwoLevelDictionary commentStamp: '<historical>' prior: 0! 422663A simple dictionary for the use of the TextDiffBuilder. Keys are presumed to be Points and a significant speed advantage is gained by using a dictionary of dictionaries. The first is keyed by the x-values and the second by the y-values. Only the minimum necessary protocol is implemented.! 422664 422665 422666!TwoLevelDictionary methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:42'! 422667at: aPoint 422668 422669 ^(firstLevel at: aPoint x ifAbsent: [^nil]) at: aPoint y ifAbsent: [^nil] 422670! ! 422671 422672!TwoLevelDictionary methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:37'! 422673at: aPoint put: anObject 422674 422675 (firstLevel at: aPoint x ifAbsentPut: [Dictionary new]) at: aPoint y put: anObject 422676! ! 422677 422678!TwoLevelDictionary methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 11:14'! 422679initialize 422680 422681 super initialize. 422682 firstLevel := Dictionary new.! ! 422683 422684!TwoLevelDictionary methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:40'! 422685keysDo: aBlock 422686 422687 firstLevel keysAndValuesDo: [ :x :v | 422688 v keysDo: [ :y | aBlock value: x@y] 422689 ].! ! 422690 422691!TwoLevelDictionary methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:40'! 422692twoLevelKeys 422693 422694 | twoLevelSet | 422695 422696 twoLevelSet := TwoLevelSet new. 422697 self keysDo: [ :each | twoLevelSet add: each]. 422698 ^twoLevelSet 422699! ! 422700Object subclass: #TwoLevelSet 422701 instanceVariableNames: 'firstLevel' 422702 classVariableNames: '' 422703 poolDictionaries: '' 422704 category: 'System-FilePackage'! 422705!TwoLevelSet commentStamp: '<historical>' prior: 0! 422706A simple set for the use of the TextDiffBuilder. Elements are presumed to be Points and a significant speed advantage is gained by using a dictionary of sets. The first is keyed by the x-values and the second contains the y-values. Only the minimum necessary protocol is implemented.! 422707 422708 422709!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:18'! 422710add: aPoint 422711 422712 (firstLevel at: aPoint x ifAbsentPut: [Set new]) add: aPoint y 422713! ! 422714 422715!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:18'! 422716copy 422717 422718 | answer | 422719 422720 answer := self class new initialize. 422721 self do: [ :each | 422722 answer add: each 422723 ]. 422724 ^answer! ! 422725 422726!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 09:26'! 422727detect: aBlock 422728 422729 firstLevel keysAndValuesDo: [ :x :v | 422730 v do: [ :y | (aBlock value: x@y) ifTrue: [^x@y]] 422731 ]. 422732 ^nil! ! 422733 422734!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:15'! 422735do: aBlock 422736 422737 firstLevel keysAndValuesDo: [ :x :v | 422738 v do: [ :y | aBlock value: x@y] 422739 ].! ! 422740 422741!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:19'! 422742includes: aPoint 422743 422744 ^(firstLevel at: aPoint x ifAbsent: [^false]) includes: aPoint y! ! 422745 422746!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 11:15'! 422747initialize 422748 422749 super initialize. 422750 firstLevel := Dictionary new.! ! 422751 422752!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:13'! 422753isEmpty 422754 422755 ^firstLevel isEmpty! ! 422756 422757!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:22'! 422758remove: aPoint 422759 422760 | lev2 | 422761 422762 lev2 := firstLevel at: aPoint x ifAbsent: [^self]. 422763 lev2 remove: aPoint y ifAbsent: []. 422764 lev2 isEmpty ifTrue: [firstLevel removeKey: aPoint x]. 422765 422766! ! 422767 422768!TwoLevelSet methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 23:28'! 422769removeAllXAndY: aPoint 422770 422771 | deletes | 422772 422773 deletes := OrderedCollection new. 422774 firstLevel removeKey: aPoint x ifAbsent: []. 422775 firstLevel keysAndValuesDo: [ :x :lev2 | 422776 lev2 remove: aPoint y ifAbsent: []. 422777 lev2 isEmpty ifTrue: [deletes add: x]. 422778 ]. 422779 deletes do: [ :each | firstLevel removeKey: each ifAbsent: []].! ! 422780Object subclass: #UCSTable 422781 instanceVariableNames: '' 422782 classVariableNames: 'GB2312Table JISX0208Table KSX1001Table Latin1Table' 422783 poolDictionaries: '' 422784 category: 'Multilingual-Encodings'! 422785!UCSTable commentStamp: 'yo 10/19/2004 19:54' prior: 0! 422786This class represents the Unicode conversion table from/to the domestic encodings and Unicode. 422787! 422788 422789 422790"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 422791 422792UCSTable class 422793 instanceVariableNames: ''! 422794 422795!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:36'! 422796gb2312Table 422797 422798 ^ GB2312Table. 422799! ! 422800 422801!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:41'! 422802initialize 422803" 422804 self initialize 422805" 422806 422807 self initializeGB2312Table. 422808 self initializeJISX0208Table. 422809 self initializeKSX1001Table. 422810 self initializeLatin1Table. 422811! ! 422812 422813!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:33'! 422814initializeGB2312Table 422815 "UCSTable initializeGB2312Table" 422816 422817 | table size gb2312 unicode gb23122 code uIndex u | 422818 table := #(16r2121 16r3000 16r2122 16r3001 16r2123 16r3002 16r2124 16r30FB 16r2125 16r02C9 16r2126 16r02C7 16r2127 16r00A8 16r2128 16r3003 16r2129 16r3005 16r212A 16r2015 16r212B 16rFF5E 16r212C 16r2016 16r212D 16r2026 16r212E 16r2018 16r212F 16r2019 16r2130 16r201C 16r2131 16r201D 16r2132 16r3014 16r2133 16r3015 16r2134 16r3008 16r2135 16r3009 16r2136 16r300A 16r2137 16r300B 16r2138 16r300C 16r2139 16r300D 16r213A 16r300E 16r213B 16r300F 16r213C 16r3016 16r213D 16r3017 16r213E 16r3010 16r213F 16r3011 16r2140 16r00B1 16r2141 16r00D7 16r2142 16r00F7 16r2143 16r2236 16r2144 16r2227 16r2145 16r2228 16r2146 16r2211 16r2147 16r220F 16r2148 16r222A 16r2149 16r2229 16r214A 16r2208 16r214B 16r2237 16r214C 16r221A 16r214D 16r22A5 16r214E 16r2225 16r214F 16r2220 16r2150 16r2312 16r2151 16r2299 16r2152 16r222B 16r2153 16r222E 16r2154 16r2261 16r2155 16r224C 16r2156 16r2248 16r2157 16r223D 16r2158 16r221D 16r2159 16r2260 16r215A 16r226E 16r215B 16r226F 16r215C 16r2264 16r215D 16r2265 16r215E 16r221E 16r215F 16r2235 16r2160 16r2234 16r2161 16r2642 16r2162 16r2640 16r2163 16r00B0 16r2164 16r2032 16r2165 16r2033 16r2166 16r2103 16r2167 16rFF04 16r2168 16r00A4 16r2169 16rFFE0 16r216A 16rFFE1 16r216B 16r2030 16r216C 16r00A7 16r216D 16r2116 16r216E 16r2606 16r216F 16r2605 16r2170 16r25CB 16r2171 16r25CF 16r2172 16r25CE 16r2173 16r25C7 16r2174 16r25C6 16r2175 16r25A1 16r2176 16r25A0 16r2177 16r25B3 16r2178 16r25B2 16r2179 16r203B 16r217A 16r2192 16r217B 16r2190 16r217C 16r2191 16r217D 16r2193 16r217E 16r3013 16r2231 16r2488 16r2232 16r2489 16r2233 16r248A 16r2234 16r248B 16r2235 16r248C 16r2236 16r248D 16r2237 16r248E 16r2238 16r248F 16r2239 16r2490 16r223A 16r2491 16r223B 16r2492 16r223C 16r2493 16r223D 16r2494 16r223E 16r2495 16r223F 16r2496 16r2240 16r2497 16r2241 16r2498 16r2242 16r2499 16r2243 16r249A 16r2244 16r249B 16r2245 16r2474 16r2246 16r2475 16r2247 16r2476 16r2248 16r2477 16r2249 16r2478 16r224A 16r2479 16r224B 16r247A 16r224C 16r247B 16r224D 16r247C 16r224E 16r247D 16r224F 16r247E 16r2250 16r247F 16r2251 16r2480 16r2252 16r2481 16r2253 16r2482 16r2254 16r2483 16r2255 16r2484 16r2256 16r2485 16r2257 16r2486 16r2258 16r2487 16r2259 16r2460 16r225A 16r2461 16r225B 16r2462 16r225C 16r2463 16r225D 16r2464 16r225E 16r2465 16r225F 16r2466 16r2260 16r2467 16r2261 16r2468 16r2262 16r2469 16r2265 16r3220 16r2266 16r3221 16r2267 16r3222 16r2268 16r3223 16r2269 16r3224 16r226A 16r3225 16r226B 16r3226 16r226C 16r3227 16r226D 16r3228 16r226E 16r3229 16r2271 16r2160 16r2272 16r2161 16r2273 16r2162 16r2274 16r2163 16r2275 16r2164 16r2276 16r2165 16r2277 16r2166 16r2278 16r2167 16r2279 16r2168 16r227A 16r2169 16r227B 16r216A 16r227C 16r216B 16r2321 16rFF01 16r2322 16rFF02 16r2323 16rFF03 16r2324 16rFFE5 16r2325 16rFF05 16r2326 16rFF06 16r2327 16rFF07 16r2328 16rFF08 16r2329 16rFF09 16r232A 16rFF0A 16r232B 16rFF0B 16r232C 16rFF0C 16r232D 16rFF0D 16r232E 16rFF0E 16r232F 16rFF0F 16r2330 16rFF10 16r2331 16rFF11 16r2332 16rFF12 16r2333 16rFF13 16r2334 16rFF14 16r2335 16rFF15 16r2336 16rFF16 16r2337 16rFF17 16r2338 16rFF18 16r2339 16rFF19 16r233A 16rFF1A 16r233B 16rFF1B 16r233C 16rFF1C 16r233D 16rFF1D 16r233E 16rFF1E 16r233F 16rFF1F 16r2340 16rFF20 16r2341 16rFF21 16r2342 16rFF22 16r2343 16rFF23 16r2344 16rFF24 16r2345 16rFF25 16r2346 16rFF26 16r2347 16rFF27 16r2348 16rFF28 16r2349 16rFF29 16r234A 16rFF2A 16r234B 16rFF2B 16r234C 16rFF2C 16r234D 16rFF2D 16r234E 16rFF2E 16r234F 16rFF2F 16r2350 16rFF30 16r2351 16rFF31 16r2352 16rFF32 16r2353 16rFF33 16r2354 16rFF34 16r2355 16rFF35 16r2356 16rFF36 16r2357 16rFF37 16r2358 16rFF38 16r2359 16rFF39 16r235A 16rFF3A 16r235B 16rFF3B 16r235C 16rFF3C 16r235D 16rFF3D 16r235E 16rFF3E 16r235F 16rFF3F 16r2360 16rFF40 16r2361 16rFF41 16r2362 16rFF42 16r2363 16rFF43 16r2364 16rFF44 16r2365 16rFF45 16r2366 16rFF46 16r2367 16rFF47 16r2368 16rFF48 16r2369 16rFF49 16r236A 16rFF4A 16r236B 16rFF4B 16r236C 16rFF4C 16r236D 16rFF4D 16r236E 16rFF4E 16r236F 16rFF4F 16r2370 16rFF50 16r2371 16rFF51 16r2372 16rFF52 16r2373 16rFF53 16r2374 16rFF54 16r2375 16rFF55 16r2376 16rFF56 16r2377 16rFF57 16r2378 16rFF58 16r2379 16rFF59 16r237A 16rFF5A 16r237B 16rFF5B 16r237C 16rFF5C 16r237D 16rFF5D 16r237E 16rFFE3 16r2421 16r3041 16r2422 16r3042 16r2423 16r3043 16r2424 16r3044 16r2425 16r3045 16r2426 16r3046 16r2427 16r3047 16r2428 16r3048 16r2429 16r3049 16r242A 16r304A 16r242B 16r304B 16r242C 16r304C 16r242D 16r304D 16r242E 16r304E 16r242F 16r304F 16r2430 16r3050 16r2431 16r3051 16r2432 16r3052 16r2433 16r3053 16r2434 16r3054 16r2435 16r3055 16r2436 16r3056 16r2437 16r3057 16r2438 16r3058 16r2439 16r3059 16r243A 16r305A 16r243B 16r305B 16r243C 16r305C 16r243D 16r305D 16r243E 16r305E 16r243F 16r305F 16r2440 16r3060 16r2441 16r3061 16r2442 16r3062 16r2443 16r3063 16r2444 16r3064 16r2445 16r3065 16r2446 16r3066 16r2447 16r3067 16r2448 16r3068 16r2449 16r3069 16r244A 16r306A 16r244B 16r306B 16r244C 16r306C 16r244D 16r306D 16r244E 16r306E 16r244F 16r306F 16r2450 16r3070 16r2451 16r3071 16r2452 16r3072 16r2453 16r3073 16r2454 16r3074 16r2455 16r3075 16r2456 16r3076 16r2457 16r3077 16r2458 16r3078 16r2459 16r3079 16r245A 16r307A 16r245B 16r307B 16r245C 16r307C 16r245D 16r307D 16r245E 16r307E 16r245F 16r307F 16r2460 16r3080 16r2461 16r3081 16r2462 16r3082 16r2463 16r3083 16r2464 16r3084 16r2465 16r3085 16r2466 16r3086 16r2467 16r3087 16r2468 16r3088 16r2469 16r3089 16r246A 16r308A 16r246B 16r308B 16r246C 16r308C 16r246D 16r308D 16r246E 16r308E 16r246F 16r308F 16r2470 16r3090 16r2471 16r3091 16r2472 16r3092 16r2473 16r3093 16r2521 16r30A1 16r2522 16r30A2 16r2523 16r30A3 16r2524 16r30A4 16r2525 16r30A5 16r2526 16r30A6 16r2527 16r30A7 16r2528 16r30A8 16r2529 16r30A9 16r252A 16r30AA 16r252B 16r30AB 16r252C 16r30AC 16r252D 16r30AD 16r252E 16r30AE 16r252F 16r30AF 16r2530 16r30B0 16r2531 16r30B1 16r2532 16r30B2 16r2533 16r30B3 16r2534 16r30B4 16r2535 16r30B5 16r2536 16r30B6 16r2537 16r30B7 16r2538 16r30B8 16r2539 16r30B9 16r253A 16r30BA 16r253B 16r30BB 16r253C 16r30BC 16r253D 16r30BD 16r253E 16r30BE 16r253F 16r30BF 16r2540 16r30C0 16r2541 16r30C1 16r2542 16r30C2 16r2543 16r30C3 16r2544 16r30C4 16r2545 16r30C5 16r2546 16r30C6 16r2547 16r30C7 16r2548 16r30C8 16r2549 16r30C9 16r254A 16r30CA 16r254B 16r30CB 16r254C 16r30CC 16r254D 16r30CD 16r254E 16r30CE 16r254F 16r30CF 16r2550 16r30D0 16r2551 16r30D1 16r2552 16r30D2 16r2553 16r30D3 16r2554 16r30D4 16r2555 16r30D5 16r2556 16r30D6 16r2557 16r30D7 16r2558 16r30D8 16r2559 16r30D9 16r255A 16r30DA 16r255B 16r30DB 16r255C 16r30DC 16r255D 16r30DD 16r255E 16r30DE 16r255F 16r30DF 16r2560 16r30E0 16r2561 16r30E1 16r2562 16r30E2 16r2563 16r30E3 16r2564 16r30E4 16r2565 16r30E5 16r2566 16r30E6 16r2567 16r30E7 16r2568 16r30E8 16r2569 16r30E9 16r256A 16r30EA 16r256B 16r30EB 16r256C 16r30EC 16r256D 16r30ED 16r256E 16r30EE 16r256F 16r30EF 16r2570 16r30F0 16r2571 16r30F1 16r2572 16r30F2 16r2573 16r30F3 16r2574 16r30F4 16r2575 16r30F5 16r2576 16r30F6 16r2621 16r0391 16r2622 16r0392 16r2623 16r0393 16r2624 16r0394 16r2625 16r0395 16r2626 16r0396 16r2627 16r0397 16r2628 16r0398 16r2629 16r0399 16r262A 16r039A 16r262B 16r039B 16r262C 16r039C 16r262D 16r039D 16r262E 16r039E 16r262F 16r039F 16r2630 16r03A0 16r2631 16r03A1 16r2632 16r03A3 16r2633 16r03A4 16r2634 16r03A5 16r2635 16r03A6 16r2636 16r03A7 16r2637 16r03A8 16r2638 16r03A9 16r2641 16r03B1 16r2642 16r03B2 16r2643 16r03B3 16r2644 16r03B4 16r2645 16r03B5 16r2646 16r03B6 16r2647 16r03B7 16r2648 16r03B8 16r2649 16r03B9 16r264A 16r03BA 16r264B 16r03BB 16r264C 16r03BC 16r264D 16r03BD 16r264E 16r03BE 16r264F 16r03BF 16r2650 16r03C0 16r2651 16r03C1 16r2652 16r03C3 16r2653 16r03C4 16r2654 16r03C5 16r2655 16r03C6 16r2656 16r03C7 16r2657 16r03C8 16r2658 16r03C9 16r2721 16r0410 16r2722 16r0411 16r2723 16r0412 16r2724 16r0413 16r2725 16r0414 16r2726 16r0415 16r2727 16r0401 16r2728 16r0416 16r2729 16r0417 16r272A 16r0418 16r272B 16r0419 16r272C 16r041A 16r272D 16r041B 16r272E 16r041C 16r272F 16r041D 16r2730 16r041E 16r2731 16r041F 16r2732 16r0420 16r2733 16r0421 16r2734 16r0422 16r2735 16r0423 16r2736 16r0424 16r2737 16r0425 16r2738 16r0426 16r2739 16r0427 16r273A 16r0428 16r273B 16r0429 16r273C 16r042A 16r273D 16r042B 16r273E 16r042C 16r273F 16r042D 16r2740 16r042E 16r2741 16r042F 16r2751 16r0430 16r2752 16r0431 16r2753 16r0432 16r2754 16r0433 16r2755 16r0434 16r2756 16r0435 16r2757 16r0451 16r2758 16r0436 16r2759 16r0437 16r275A 16r0438 16r275B 16r0439 16r275C 16r043A 16r275D 16r043B 16r275E 16r043C 16r275F 16r043D 16r2760 16r043E 16r2761 16r043F 16r2762 16r0440 16r2763 16r0441 16r2764 16r0442 16r2765 16r0443 16r2766 16r0444 16r2767 16r0445 16r2768 16r0446 16r2769 16r0447 16r276A 16r0448 16r276B 16r0449 16r276C 16r044A 16r276D 16r044B 16r276E 16r044C 16r276F 16r044D 16r2770 16r044E 16r2771 16r044F 16r2821 16r0101 16r2822 16r00E1 16r2823 16r01CE 16r2824 16r00E0 16r2825 16r0113 16r2826 16r00E9 16r2827 16r011B 16r2828 16r00E8 16r2829 16r012B 16r282A 16r00ED 16r282B 16r01D0 16r282C 16r00EC 16r282D 16r014D 16r282E 16r00F3 16r282F 16r01D2 16r2830 16r00F2 16r2831 16r016B 16r2832 16r00FA 16r2833 16r01D4 16r2834 16r00F9 16r2835 16r01D6 16r2836 16r01D8 16r2837 16r01DA 16r2838 16r01DC 16r2839 16r00FC 16r283A 16r00EA 16r2845 16r3105 16r2846 16r3106 16r2847 16r3107 16r2848 16r3108 16r2849 16r3109 16r284A 16r310A 16r284B 16r310B 16r284C 16r310C 16r284D 16r310D 16r284E 16r310E 16r284F 16r310F 16r2850 16r3110 16r2851 16r3111 16r2852 16r3112 16r2853 16r3113 16r2854 16r3114 16r2855 16r3115 16r2856 16r3116 16r2857 16r3117 16r2858 16r3118 16r2859 16r3119 16r285A 16r311A 16r285B 16r311B 16r285C 16r311C 16r285D 16r311D 16r285E 16r311E 16r285F 16r311F 16r2860 16r3120 16r2861 16r3121 16r2862 16r3122 16r2863 16r3123 16r2864 16r3124 16r2865 16r3125 16r2866 16r3126 16r2867 16r3127 16r2868 16r3128 16r2869 16r3129 16r2924 16r2500 16r2925 16r2501 16r2926 16r2502 16r2927 16r2503 16r2928 16r2504 16r2929 16r2505 16r292A 16r2506 16r292B 16r2507 16r292C 16r2508 16r292D 16r2509 16r292E 16r250A 16r292F 16r250B 16r2930 16r250C 16r2931 16r250D 16r2932 16r250E 16r2933 16r250F 16r2934 16r2510 16r2935 16r2511 16r2936 16r2512 16r2937 16r2513 16r2938 16r2514 16r2939 16r2515 16r293A 16r2516 16r293B 16r2517 16r293C 16r2518 16r293D 16r2519 16r293E 16r251A 16r293F 16r251B 16r2940 16r251C 16r2941 16r251D 16r2942 16r251E 16r2943 16r251F 16r2944 16r2520 16r2945 16r2521 16r2946 16r2522 16r2947 16r2523 16r2948 16r2524 16r2949 16r2525 16r294A 16r2526 16r294B 16r2527 16r294C 16r2528 16r294D 16r2529 16r294E 16r252A 16r294F 16r252B 16r2950 16r252C 16r2951 16r252D 16r2952 16r252E 16r2953 16r252F 16r2954 16r2530 16r2955 16r2531 16r2956 16r2532 16r2957 16r2533 16r2958 16r2534 16r2959 16r2535 16r295A 16r2536 16r295B 16r2537 16r295C 16r2538 16r295D 16r2539 16r295E 16r253A 16r295F 16r253B 16r2960 16r253C 16r2961 16r253D 16r2962 16r253E 16r2963 16r253F 16r2964 16r2540 16r2965 16r2541 16r2966 16r2542 16r2967 16r2543 16r2968 16r2544 16r2969 16r2545 16r296A 16r2546 16r296B 16r2547 16r296C 16r2548 16r296D 16r2549 16r296E 16r254A 16r296F 16r254B 16r3021 16r554A 16r3022 16r963F 16r3023 16r57C3 16r3024 16r6328 16r3025 16r54CE 16r3026 16r5509 16r3027 16r54C0 16r3028 16r7691 16r3029 16r764C 16r302A 16r853C 16r302B 16r77EE 16r302C 16r827E 16r302D 16r788D 16r302E 16r7231 16r302F 16r9698 16r3030 16r978D 16r3031 16r6C28 16r3032 16r5B89 16r3033 16r4FFA 16r3034 16r6309 16r3035 16r6697 16r3036 16r5CB8 16r3037 16r80FA 16r3038 16r6848 16r3039 16r80AE 16r303A 16r6602 16r303B 16r76CE 16r303C 16r51F9 16r303D 16r6556 16r303E 16r71AC 16r303F 16r7FF1 16r3040 16r8884 16r3041 16r50B2 16r3042 16r5965 16r3043 16r61CA 16r3044 16r6FB3 16r3045 16r82AD 16r3046 16r634C 16r3047 16r6252 16r3048 16r53ED 16r3049 16r5427 16r304A 16r7B06 16r304B 16r516B 16r304C 16r75A4 16r304D 16r5DF4 16r304E 16r62D4 16r304F 16r8DCB 16r3050 16r9776 16r3051 16r628A 16r3052 16r8019 16r3053 16r575D 16r3054 16r9738 16r3055 16r7F62 16r3056 16r7238 16r3057 16r767D 16r3058 16r67CF 16r3059 16r767E 16r305A 16r6446 16r305B 16r4F70 16r305C 16r8D25 16r305D 16r62DC 16r305E 16r7A17 16r305F 16r6591 16r3060 16r73ED 16r3061 16r642C 16r3062 16r6273 16r3063 16r822C 16r3064 16r9881 16r3065 16r677F 16r3066 16r7248 16r3067 16r626E 16r3068 16r62CC 16r3069 16r4F34 16r306A 16r74E3 16r306B 16r534A 16r306C 16r529E 16r306D 16r7ECA 16r306E 16r90A6 16r306F 16r5E2E 16r3070 16r6886 16r3071 16r699C 16r3072 16r8180 16r3073 16r7ED1 16r3074 16r68D2 16r3075 16r78C5 16r3076 16r868C 16r3077 16r9551 16r3078 16r508D 16r3079 16r8C24 16r307A 16r82DE 16r307B 16r80DE 16r307C 16r5305 16r307D 16r8912 16r307E 16r5265 16r3121 16r8584 16r3122 16r96F9 16r3123 16r4FDD 16r3124 16r5821 16r3125 16r9971 16r3126 16r5B9D 16r3127 16r62B1 16r3128 16r62A5 16r3129 16r66B4 16r312A 16r8C79 16r312B 16r9C8D 16r312C 16r7206 16r312D 16r676F 16r312E 16r7891 16r312F 16r60B2 16r3130 16r5351 16r3131 16r5317 16r3132 16r8F88 16r3133 16r80CC 16r3134 16r8D1D 16r3135 16r94A1 16r3136 16r500D 16r3137 16r72C8 16r3138 16r5907 16r3139 16r60EB 16r313A 16r7119 16r313B 16r88AB 16r313C 16r5954 16r313D 16r82EF 16r313E 16r672C 16r313F 16r7B28 16r3140 16r5D29 16r3141 16r7EF7 16r3142 16r752D 16r3143 16r6CF5 16r3144 16r8E66 16r3145 16r8FF8 16r3146 16r903C 16r3147 16r9F3B 16r3148 16r6BD4 16r3149 16r9119 16r314A 16r7B14 16r314B 16r5F7C 16r314C 16r78A7 16r314D 16r84D6 16r314E 16r853D 16r314F 16r6BD5 16r3150 16r6BD9 16r3151 16r6BD6 16r3152 16r5E01 16r3153 16r5E87 16r3154 16r75F9 16r3155 16r95ED 16r3156 16r655D 16r3157 16r5F0A 16r3158 16r5FC5 16r3159 16r8F9F 16r315A 16r58C1 16r315B 16r81C2 16r315C 16r907F 16r315D 16r965B 16r315E 16r97AD 16r315F 16r8FB9 16r3160 16r7F16 16r3161 16r8D2C 16r3162 16r6241 16r3163 16r4FBF 16r3164 16r53D8 16r3165 16r535E 16r3166 16r8FA8 16r3167 16r8FA9 16r3168 16r8FAB 16r3169 16r904D 16r316A 16r6807 16r316B 16r5F6A 16r316C 16r8198 16r316D 16r8868 16r316E 16r9CD6 16r316F 16r618B 16r3170 16r522B 16r3171 16r762A 16r3172 16r5F6C 16r3173 16r658C 16r3174 16r6FD2 16r3175 16r6EE8 16r3176 16r5BBE 16r3177 16r6448 16r3178 16r5175 16r3179 16r51B0 16r317A 16r67C4 16r317B 16r4E19 16r317C 16r79C9 16r317D 16r997C 16r317E 16r70B3 16r3221 16r75C5 16r3222 16r5E76 16r3223 16r73BB 16r3224 16r83E0 16r3225 16r64AD 16r3226 16r62E8 16r3227 16r94B5 16r3228 16r6CE2 16r3229 16r535A 16r322A 16r52C3 16r322B 16r640F 16r322C 16r94C2 16r322D 16r7B94 16r322E 16r4F2F 16r322F 16r5E1B 16r3230 16r8236 16r3231 16r8116 16r3232 16r818A 16r3233 16r6E24 16r3234 16r6CCA 16r3235 16r9A73 16r3236 16r6355 16r3237 16r535C 16r3238 16r54FA 16r3239 16r8865 16r323A 16r57E0 16r323B 16r4E0D 16r323C 16r5E03 16r323D 16r6B65 16r323E 16r7C3F 16r323F 16r90E8 16r3240 16r6016 16r3241 16r64E6 16r3242 16r731C 16r3243 16r88C1 16r3244 16r6750 16r3245 16r624D 16r3246 16r8D22 16r3247 16r776C 16r3248 16r8E29 16r3249 16r91C7 16r324A 16r5F69 16r324B 16r83DC 16r324C 16r8521 16r324D 16r9910 16r324E 16r53C2 16r324F 16r8695 16r3250 16r6B8B 16r3251 16r60ED 16r3252 16r60E8 16r3253 16r707F 16r3254 16r82CD 16r3255 16r8231 16r3256 16r4ED3 16r3257 16r6CA7 16r3258 16r85CF 16r3259 16r64CD 16r325A 16r7CD9 16r325B 16r69FD 16r325C 16r66F9 16r325D 16r8349 16r325E 16r5395 16r325F 16r7B56 16r3260 16r4FA7 16r3261 16r518C 16r3262 16r6D4B 16r3263 16r5C42 16r3264 16r8E6D 16r3265 16r63D2 16r3266 16r53C9 16r3267 16r832C 16r3268 16r8336 16r3269 16r67E5 16r326A 16r78B4 16r326B 16r643D 16r326C 16r5BDF 16r326D 16r5C94 16r326E 16r5DEE 16r326F 16r8BE7 16r3270 16r62C6 16r3271 16r67F4 16r3272 16r8C7A 16r3273 16r6400 16r3274 16r63BA 16r3275 16r8749 16r3276 16r998B 16r3277 16r8C17 16r3278 16r7F20 16r3279 16r94F2 16r327A 16r4EA7 16r327B 16r9610 16r327C 16r98A4 16r327D 16r660C 16r327E 16r7316 16r3321 16r573A 16r3322 16r5C1D 16r3323 16r5E38 16r3324 16r957F 16r3325 16r507F 16r3326 16r80A0 16r3327 16r5382 16r3328 16r655E 16r3329 16r7545 16r332A 16r5531 16r332B 16r5021 16r332C 16r8D85 16r332D 16r6284 16r332E 16r949E 16r332F 16r671D 16r3330 16r5632 16r3331 16r6F6E 16r3332 16r5DE2 16r3333 16r5435 16r3334 16r7092 16r3335 16r8F66 16r3336 16r626F 16r3337 16r64A4 16r3338 16r63A3 16r3339 16r5F7B 16r333A 16r6F88 16r333B 16r90F4 16r333C 16r81E3 16r333D 16r8FB0 16r333E 16r5C18 16r333F 16r6668 16r3340 16r5FF1 16r3341 16r6C89 16r3342 16r9648 16r3343 16r8D81 16r3344 16r886C 16r3345 16r6491 16r3346 16r79F0 16r3347 16r57CE 16r3348 16r6A59 16r3349 16r6210 16r334A 16r5448 16r334B 16r4E58 16r334C 16r7A0B 16r334D 16r60E9 16r334E 16r6F84 16r334F 16r8BDA 16r3350 16r627F 16r3351 16r901E 16r3352 16r9A8B 16r3353 16r79E4 16r3354 16r5403 16r3355 16r75F4 16r3356 16r6301 16r3357 16r5319 16r3358 16r6C60 16r3359 16r8FDF 16r335A 16r5F1B 16r335B 16r9A70 16r335C 16r803B 16r335D 16r9F7F 16r335E 16r4F88 16r335F 16r5C3A 16r3360 16r8D64 16r3361 16r7FC5 16r3362 16r65A5 16r3363 16r70BD 16r3364 16r5145 16r3365 16r51B2 16r3366 16r866B 16r3367 16r5D07 16r3368 16r5BA0 16r3369 16r62BD 16r336A 16r916C 16r336B 16r7574 16r336C 16r8E0C 16r336D 16r7A20 16r336E 16r6101 16r336F 16r7B79 16r3370 16r4EC7 16r3371 16r7EF8 16r3372 16r7785 16r3373 16r4E11 16r3374 16r81ED 16r3375 16r521D 16r3376 16r51FA 16r3377 16r6A71 16r3378 16r53A8 16r3379 16r8E87 16r337A 16r9504 16r337B 16r96CF 16r337C 16r6EC1 16r337D 16r9664 16r337E 16r695A 16r3421 16r7840 16r3422 16r50A8 16r3423 16r77D7 16r3424 16r6410 16r3425 16r89E6 16r3426 16r5904 16r3427 16r63E3 16r3428 16r5DDD 16r3429 16r7A7F 16r342A 16r693D 16r342B 16r4F20 16r342C 16r8239 16r342D 16r5598 16r342E 16r4E32 16r342F 16r75AE 16r3430 16r7A97 16r3431 16r5E62 16r3432 16r5E8A 16r3433 16r95EF 16r3434 16r521B 16r3435 16r5439 16r3436 16r708A 16r3437 16r6376 16r3438 16r9524 16r3439 16r5782 16r343A 16r6625 16r343B 16r693F 16r343C 16r9187 16r343D 16r5507 16r343E 16r6DF3 16r343F 16r7EAF 16r3440 16r8822 16r3441 16r6233 16r3442 16r7EF0 16r3443 16r75B5 16r3444 16r8328 16r3445 16r78C1 16r3446 16r96CC 16r3447 16r8F9E 16r3448 16r6148 16r3449 16r74F7 16r344A 16r8BCD 16r344B 16r6B64 16r344C 16r523A 16r344D 16r8D50 16r344E 16r6B21 16r344F 16r806A 16r3450 16r8471 16r3451 16r56F1 16r3452 16r5306 16r3453 16r4ECE 16r3454 16r4E1B 16r3455 16r51D1 16r3456 16r7C97 16r3457 16r918B 16r3458 16r7C07 16r3459 16r4FC3 16r345A 16r8E7F 16r345B 16r7BE1 16r345C 16r7A9C 16r345D 16r6467 16r345E 16r5D14 16r345F 16r50AC 16r3460 16r8106 16r3461 16r7601 16r3462 16r7CB9 16r3463 16r6DEC 16r3464 16r7FE0 16r3465 16r6751 16r3466 16r5B58 16r3467 16r5BF8 16r3468 16r78CB 16r3469 16r64AE 16r346A 16r6413 16r346B 16r63AA 16r346C 16r632B 16r346D 16r9519 16r346E 16r642D 16r346F 16r8FBE 16r3470 16r7B54 16r3471 16r7629 16r3472 16r6253 16r3473 16r5927 16r3474 16r5446 16r3475 16r6B79 16r3476 16r50A3 16r3477 16r6234 16r3478 16r5E26 16r3479 16r6B86 16r347A 16r4EE3 16r347B 16r8D37 16r347C 16r888B 16r347D 16r5F85 16r347E 16r902E 16r3521 16r6020 16r3522 16r803D 16r3523 16r62C5 16r3524 16r4E39 16r3525 16r5355 16r3526 16r90F8 16r3527 16r63B8 16r3528 16r80C6 16r3529 16r65E6 16r352A 16r6C2E 16r352B 16r4F46 16r352C 16r60EE 16r352D 16r6DE1 16r352E 16r8BDE 16r352F 16r5F39 16r3530 16r86CB 16r3531 16r5F53 16r3532 16r6321 16r3533 16r515A 16r3534 16r8361 16r3535 16r6863 16r3536 16r5200 16r3537 16r6363 16r3538 16r8E48 16r3539 16r5012 16r353A 16r5C9B 16r353B 16r7977 16r353C 16r5BFC 16r353D 16r5230 16r353E 16r7A3B 16r353F 16r60BC 16r3540 16r9053 16r3541 16r76D7 16r3542 16r5FB7 16r3543 16r5F97 16r3544 16r7684 16r3545 16r8E6C 16r3546 16r706F 16r3547 16r767B 16r3548 16r7B49 16r3549 16r77AA 16r354A 16r51F3 16r354B 16r9093 16r354C 16r5824 16r354D 16r4F4E 16r354E 16r6EF4 16r354F 16r8FEA 16r3550 16r654C 16r3551 16r7B1B 16r3552 16r72C4 16r3553 16r6DA4 16r3554 16r7FDF 16r3555 16r5AE1 16r3556 16r62B5 16r3557 16r5E95 16r3558 16r5730 16r3559 16r8482 16r355A 16r7B2C 16r355B 16r5E1D 16r355C 16r5F1F 16r355D 16r9012 16r355E 16r7F14 16r355F 16r98A0 16r3560 16r6382 16r3561 16r6EC7 16r3562 16r7898 16r3563 16r70B9 16r3564 16r5178 16r3565 16r975B 16r3566 16r57AB 16r3567 16r7535 16r3568 16r4F43 16r3569 16r7538 16r356A 16r5E97 16r356B 16r60E6 16r356C 16r5960 16r356D 16r6DC0 16r356E 16r6BBF 16r356F 16r7889 16r3570 16r53FC 16r3571 16r96D5 16r3572 16r51CB 16r3573 16r5201 16r3574 16r6389 16r3575 16r540A 16r3576 16r9493 16r3577 16r8C03 16r3578 16r8DCC 16r3579 16r7239 16r357A 16r789F 16r357B 16r8776 16r357C 16r8FED 16r357D 16r8C0D 16r357E 16r53E0 16r3621 16r4E01 16r3622 16r76EF 16r3623 16r53EE 16r3624 16r9489 16r3625 16r9876 16r3626 16r9F0E 16r3627 16r952D 16r3628 16r5B9A 16r3629 16r8BA2 16r362A 16r4E22 16r362B 16r4E1C 16r362C 16r51AC 16r362D 16r8463 16r362E 16r61C2 16r362F 16r52A8 16r3630 16r680B 16r3631 16r4F97 16r3632 16r606B 16r3633 16r51BB 16r3634 16r6D1E 16r3635 16r515C 16r3636 16r6296 16r3637 16r6597 16r3638 16r9661 16r3639 16r8C46 16r363A 16r9017 16r363B 16r75D8 16r363C 16r90FD 16r363D 16r7763 16r363E 16r6BD2 16r363F 16r728A 16r3640 16r72EC 16r3641 16r8BFB 16r3642 16r5835 16r3643 16r7779 16r3644 16r8D4C 16r3645 16r675C 16r3646 16r9540 16r3647 16r809A 16r3648 16r5EA6 16r3649 16r6E21 16r364A 16r5992 16r364B 16r7AEF 16r364C 16r77ED 16r364D 16r953B 16r364E 16r6BB5 16r364F 16r65AD 16r3650 16r7F0E 16r3651 16r5806 16r3652 16r5151 16r3653 16r961F 16r3654 16r5BF9 16r3655 16r58A9 16r3656 16r5428 16r3657 16r8E72 16r3658 16r6566 16r3659 16r987F 16r365A 16r56E4 16r365B 16r949D 16r365C 16r76FE 16r365D 16r9041 16r365E 16r6387 16r365F 16r54C6 16r3660 16r591A 16r3661 16r593A 16r3662 16r579B 16r3663 16r8EB2 16r3664 16r6735 16r3665 16r8DFA 16r3666 16r8235 16r3667 16r5241 16r3668 16r60F0 16r3669 16r5815 16r366A 16r86FE 16r366B 16r5CE8 16r366C 16r9E45 16r366D 16r4FC4 16r366E 16r989D 16r366F 16r8BB9 16r3670 16r5A25 16r3671 16r6076 16r3672 16r5384 16r3673 16r627C 16r3674 16r904F 16r3675 16r9102 16r3676 16r997F 16r3677 16r6069 16r3678 16r800C 16r3679 16r513F 16r367A 16r8033 16r367B 16r5C14 16r367C 16r9975 16r367D 16r6D31 16r367E 16r4E8C 16r3721 16r8D30 16r3722 16r53D1 16r3723 16r7F5A 16r3724 16r7B4F 16r3725 16r4F10 16r3726 16r4E4F 16r3727 16r9600 16r3728 16r6CD5 16r3729 16r73D0 16r372A 16r85E9 16r372B 16r5E06 16r372C 16r756A 16r372D 16r7FFB 16r372E 16r6A0A 16r372F 16r77FE 16r3730 16r9492 16r3731 16r7E41 16r3732 16r51E1 16r3733 16r70E6 16r3734 16r53CD 16r3735 16r8FD4 16r3736 16r8303 16r3737 16r8D29 16r3738 16r72AF 16r3739 16r996D 16r373A 16r6CDB 16r373B 16r574A 16r373C 16r82B3 16r373D 16r65B9 16r373E 16r80AA 16r373F 16r623F 16r3740 16r9632 16r3741 16r59A8 16r3742 16r4EFF 16r3743 16r8BBF 16r3744 16r7EBA 16r3745 16r653E 16r3746 16r83F2 16r3747 16r975E 16r3748 16r5561 16r3749 16r98DE 16r374A 16r80A5 16r374B 16r532A 16r374C 16r8BFD 16r374D 16r5420 16r374E 16r80BA 16r374F 16r5E9F 16r3750 16r6CB8 16r3751 16r8D39 16r3752 16r82AC 16r3753 16r915A 16r3754 16r5429 16r3755 16r6C1B 16r3756 16r5206 16r3757 16r7EB7 16r3758 16r575F 16r3759 16r711A 16r375A 16r6C7E 16r375B 16r7C89 16r375C 16r594B 16r375D 16r4EFD 16r375E 16r5FFF 16r375F 16r6124 16r3760 16r7CAA 16r3761 16r4E30 16r3762 16r5C01 16r3763 16r67AB 16r3764 16r8702 16r3765 16r5CF0 16r3766 16r950B 16r3767 16r98CE 16r3768 16r75AF 16r3769 16r70FD 16r376A 16r9022 16r376B 16r51AF 16r376C 16r7F1D 16r376D 16r8BBD 16r376E 16r5949 16r376F 16r51E4 16r3770 16r4F5B 16r3771 16r5426 16r3772 16r592B 16r3773 16r6577 16r3774 16r80A4 16r3775 16r5B75 16r3776 16r6276 16r3777 16r62C2 16r3778 16r8F90 16r3779 16r5E45 16r377A 16r6C1F 16r377B 16r7B26 16r377C 16r4F0F 16r377D 16r4FD8 16r377E 16r670D 16r3821 16r6D6E 16r3822 16r6DAA 16r3823 16r798F 16r3824 16r88B1 16r3825 16r5F17 16r3826 16r752B 16r3827 16r629A 16r3828 16r8F85 16r3829 16r4FEF 16r382A 16r91DC 16r382B 16r65A7 16r382C 16r812F 16r382D 16r8151 16r382E 16r5E9C 16r382F 16r8150 16r3830 16r8D74 16r3831 16r526F 16r3832 16r8986 16r3833 16r8D4B 16r3834 16r590D 16r3835 16r5085 16r3836 16r4ED8 16r3837 16r961C 16r3838 16r7236 16r3839 16r8179 16r383A 16r8D1F 16r383B 16r5BCC 16r383C 16r8BA3 16r383D 16r9644 16r383E 16r5987 16r383F 16r7F1A 16r3840 16r5490 16r3841 16r5676 16r3842 16r560E 16r3843 16r8BE5 16r3844 16r6539 16r3845 16r6982 16r3846 16r9499 16r3847 16r76D6 16r3848 16r6E89 16r3849 16r5E72 16r384A 16r7518 16r384B 16r6746 16r384C 16r67D1 16r384D 16r7AFF 16r384E 16r809D 16r384F 16r8D76 16r3850 16r611F 16r3851 16r79C6 16r3852 16r6562 16r3853 16r8D63 16r3854 16r5188 16r3855 16r521A 16r3856 16r94A2 16r3857 16r7F38 16r3858 16r809B 16r3859 16r7EB2 16r385A 16r5C97 16r385B 16r6E2F 16r385C 16r6760 16r385D 16r7BD9 16r385E 16r768B 16r385F 16r9AD8 16r3860 16r818F 16r3861 16r7F94 16r3862 16r7CD5 16r3863 16r641E 16r3864 16r9550 16r3865 16r7A3F 16r3866 16r544A 16r3867 16r54E5 16r3868 16r6B4C 16r3869 16r6401 16r386A 16r6208 16r386B 16r9E3D 16r386C 16r80F3 16r386D 16r7599 16r386E 16r5272 16r386F 16r9769 16r3870 16r845B 16r3871 16r683C 16r3872 16r86E4 16r3873 16r9601 16r3874 16r9694 16r3875 16r94EC 16r3876 16r4E2A 16r3877 16r5404 16r3878 16r7ED9 16r3879 16r6839 16r387A 16r8DDF 16r387B 16r8015 16r387C 16r66F4 16r387D 16r5E9A 16r387E 16r7FB9 16r3921 16r57C2 16r3922 16r803F 16r3923 16r6897 16r3924 16r5DE5 16r3925 16r653B 16r3926 16r529F 16r3927 16r606D 16r3928 16r9F9A 16r3929 16r4F9B 16r392A 16r8EAC 16r392B 16r516C 16r392C 16r5BAB 16r392D 16r5F13 16r392E 16r5DE9 16r392F 16r6C5E 16r3930 16r62F1 16r3931 16r8D21 16r3932 16r5171 16r3933 16r94A9 16r3934 16r52FE 16r3935 16r6C9F 16r3936 16r82DF 16r3937 16r72D7 16r3938 16r57A2 16r3939 16r6784 16r393A 16r8D2D 16r393B 16r591F 16r393C 16r8F9C 16r393D 16r83C7 16r393E 16r5495 16r393F 16r7B8D 16r3940 16r4F30 16r3941 16r6CBD 16r3942 16r5B64 16r3943 16r59D1 16r3944 16r9F13 16r3945 16r53E4 16r3946 16r86CA 16r3947 16r9AA8 16r3948 16r8C37 16r3949 16r80A1 16r394A 16r6545 16r394B 16r987E 16r394C 16r56FA 16r394D 16r96C7 16r394E 16r522E 16r394F 16r74DC 16r3950 16r5250 16r3951 16r5BE1 16r3952 16r6302 16r3953 16r8902 16r3954 16r4E56 16r3955 16r62D0 16r3956 16r602A 16r3957 16r68FA 16r3958 16r5173 16r3959 16r5B98 16r395A 16r51A0 16r395B 16r89C2 16r395C 16r7BA1 16r395D 16r9986 16r395E 16r7F50 16r395F 16r60EF 16r3960 16r704C 16r3961 16r8D2F 16r3962 16r5149 16r3963 16r5E7F 16r3964 16r901B 16r3965 16r7470 16r3966 16r89C4 16r3967 16r572D 16r3968 16r7845 16r3969 16r5F52 16r396A 16r9F9F 16r396B 16r95FA 16r396C 16r8F68 16r396D 16r9B3C 16r396E 16r8BE1 16r396F 16r7678 16r3970 16r6842 16r3971 16r67DC 16r3972 16r8DEA 16r3973 16r8D35 16r3974 16r523D 16r3975 16r8F8A 16r3976 16r6EDA 16r3977 16r68CD 16r3978 16r9505 16r3979 16r90ED 16r397A 16r56FD 16r397B 16r679C 16r397C 16r88F9 16r397D 16r8FC7 16r397E 16r54C8 16r3A21 16r9AB8 16r3A22 16r5B69 16r3A23 16r6D77 16r3A24 16r6C26 16r3A25 16r4EA5 16r3A26 16r5BB3 16r3A27 16r9A87 16r3A28 16r9163 16r3A29 16r61A8 16r3A2A 16r90AF 16r3A2B 16r97E9 16r3A2C 16r542B 16r3A2D 16r6DB5 16r3A2E 16r5BD2 16r3A2F 16r51FD 16r3A30 16r558A 16r3A31 16r7F55 16r3A32 16r7FF0 16r3A33 16r64BC 16r3A34 16r634D 16r3A35 16r65F1 16r3A36 16r61BE 16r3A37 16r608D 16r3A38 16r710A 16r3A39 16r6C57 16r3A3A 16r6C49 16r3A3B 16r592F 16r3A3C 16r676D 16r3A3D 16r822A 16r3A3E 16r58D5 16r3A3F 16r568E 16r3A40 16r8C6A 16r3A41 16r6BEB 16r3A42 16r90DD 16r3A43 16r597D 16r3A44 16r8017 16r3A45 16r53F7 16r3A46 16r6D69 16r3A47 16r5475 16r3A48 16r559D 16r3A49 16r8377 16r3A4A 16r83CF 16r3A4B 16r6838 16r3A4C 16r79BE 16r3A4D 16r548C 16r3A4E 16r4F55 16r3A4F 16r5408 16r3A50 16r76D2 16r3A51 16r8C89 16r3A52 16r9602 16r3A53 16r6CB3 16r3A54 16r6DB8 16r3A55 16r8D6B 16r3A56 16r8910 16r3A57 16r9E64 16r3A58 16r8D3A 16r3A59 16r563F 16r3A5A 16r9ED1 16r3A5B 16r75D5 16r3A5C 16r5F88 16r3A5D 16r72E0 16r3A5E 16r6068 16r3A5F 16r54FC 16r3A60 16r4EA8 16r3A61 16r6A2A 16r3A62 16r8861 16r3A63 16r6052 16r3A64 16r8F70 16r3A65 16r54C4 16r3A66 16r70D8 16r3A67 16r8679 16r3A68 16r9E3F 16r3A69 16r6D2A 16r3A6A 16r5B8F 16r3A6B 16r5F18 16r3A6C 16r7EA2 16r3A6D 16r5589 16r3A6E 16r4FAF 16r3A6F 16r7334 16r3A70 16r543C 16r3A71 16r539A 16r3A72 16r5019 16r3A73 16r540E 16r3A74 16r547C 16r3A75 16r4E4E 16r3A76 16r5FFD 16r3A77 16r745A 16r3A78 16r58F6 16r3A79 16r846B 16r3A7A 16r80E1 16r3A7B 16r8774 16r3A7C 16r72D0 16r3A7D 16r7CCA 16r3A7E 16r6E56 16r3B21 16r5F27 16r3B22 16r864E 16r3B23 16r552C 16r3B24 16r62A4 16r3B25 16r4E92 16r3B26 16r6CAA 16r3B27 16r6237 16r3B28 16r82B1 16r3B29 16r54D7 16r3B2A 16r534E 16r3B2B 16r733E 16r3B2C 16r6ED1 16r3B2D 16r753B 16r3B2E 16r5212 16r3B2F 16r5316 16r3B30 16r8BDD 16r3B31 16r69D0 16r3B32 16r5F8A 16r3B33 16r6000 16r3B34 16r6DEE 16r3B35 16r574F 16r3B36 16r6B22 16r3B37 16r73AF 16r3B38 16r6853 16r3B39 16r8FD8 16r3B3A 16r7F13 16r3B3B 16r6362 16r3B3C 16r60A3 16r3B3D 16r5524 16r3B3E 16r75EA 16r3B3F 16r8C62 16r3B40 16r7115 16r3B41 16r6DA3 16r3B42 16r5BA6 16r3B43 16r5E7B 16r3B44 16r8352 16r3B45 16r614C 16r3B46 16r9EC4 16r3B47 16r78FA 16r3B48 16r8757 16r3B49 16r7C27 16r3B4A 16r7687 16r3B4B 16r51F0 16r3B4C 16r60F6 16r3B4D 16r714C 16r3B4E 16r6643 16r3B4F 16r5E4C 16r3B50 16r604D 16r3B51 16r8C0E 16r3B52 16r7070 16r3B53 16r6325 16r3B54 16r8F89 16r3B55 16r5FBD 16r3B56 16r6062 16r3B57 16r86D4 16r3B58 16r56DE 16r3B59 16r6BC1 16r3B5A 16r6094 16r3B5B 16r6167 16r3B5C 16r5349 16r3B5D 16r60E0 16r3B5E 16r6666 16r3B5F 16r8D3F 16r3B60 16r79FD 16r3B61 16r4F1A 16r3B62 16r70E9 16r3B63 16r6C47 16r3B64 16r8BB3 16r3B65 16r8BF2 16r3B66 16r7ED8 16r3B67 16r8364 16r3B68 16r660F 16r3B69 16r5A5A 16r3B6A 16r9B42 16r3B6B 16r6D51 16r3B6C 16r6DF7 16r3B6D 16r8C41 16r3B6E 16r6D3B 16r3B6F 16r4F19 16r3B70 16r706B 16r3B71 16r83B7 16r3B72 16r6216 16r3B73 16r60D1 16r3B74 16r970D 16r3B75 16r8D27 16r3B76 16r7978 16r3B77 16r51FB 16r3B78 16r573E 16r3B79 16r57FA 16r3B7A 16r673A 16r3B7B 16r7578 16r3B7C 16r7A3D 16r3B7D 16r79EF 16r3B7E 16r7B95 16r3C21 16r808C 16r3C22 16r9965 16r3C23 16r8FF9 16r3C24 16r6FC0 16r3C25 16r8BA5 16r3C26 16r9E21 16r3C27 16r59EC 16r3C28 16r7EE9 16r3C29 16r7F09 16r3C2A 16r5409 16r3C2B 16r6781 16r3C2C 16r68D8 16r3C2D 16r8F91 16r3C2E 16r7C4D 16r3C2F 16r96C6 16r3C30 16r53CA 16r3C31 16r6025 16r3C32 16r75BE 16r3C33 16r6C72 16r3C34 16r5373 16r3C35 16r5AC9 16r3C36 16r7EA7 16r3C37 16r6324 16r3C38 16r51E0 16r3C39 16r810A 16r3C3A 16r5DF1 16r3C3B 16r84DF 16r3C3C 16r6280 16r3C3D 16r5180 16r3C3E 16r5B63 16r3C3F 16r4F0E 16r3C40 16r796D 16r3C41 16r5242 16r3C42 16r60B8 16r3C43 16r6D4E 16r3C44 16r5BC4 16r3C45 16r5BC2 16r3C46 16r8BA1 16r3C47 16r8BB0 16r3C48 16r65E2 16r3C49 16r5FCC 16r3C4A 16r9645 16r3C4B 16r5993 16r3C4C 16r7EE7 16r3C4D 16r7EAA 16r3C4E 16r5609 16r3C4F 16r67B7 16r3C50 16r5939 16r3C51 16r4F73 16r3C52 16r5BB6 16r3C53 16r52A0 16r3C54 16r835A 16r3C55 16r988A 16r3C56 16r8D3E 16r3C57 16r7532 16r3C58 16r94BE 16r3C59 16r5047 16r3C5A 16r7A3C 16r3C5B 16r4EF7 16r3C5C 16r67B6 16r3C5D 16r9A7E 16r3C5E 16r5AC1 16r3C5F 16r6B7C 16r3C60 16r76D1 16r3C61 16r575A 16r3C62 16r5C16 16r3C63 16r7B3A 16r3C64 16r95F4 16r3C65 16r714E 16r3C66 16r517C 16r3C67 16r80A9 16r3C68 16r8270 16r3C69 16r5978 16r3C6A 16r7F04 16r3C6B 16r8327 16r3C6C 16r68C0 16r3C6D 16r67EC 16r3C6E 16r78B1 16r3C6F 16r7877 16r3C70 16r62E3 16r3C71 16r6361 16r3C72 16r7B80 16r3C73 16r4FED 16r3C74 16r526A 16r3C75 16r51CF 16r3C76 16r8350 16r3C77 16r69DB 16r3C78 16r9274 16r3C79 16r8DF5 16r3C7A 16r8D31 16r3C7B 16r89C1 16r3C7C 16r952E 16r3C7D 16r7BAD 16r3C7E 16r4EF6 16r3D21 16r5065 16r3D22 16r8230 16r3D23 16r5251 16r3D24 16r996F 16r3D25 16r6E10 16r3D26 16r6E85 16r3D27 16r6DA7 16r3D28 16r5EFA 16r3D29 16r50F5 16r3D2A 16r59DC 16r3D2B 16r5C06 16r3D2C 16r6D46 16r3D2D 16r6C5F 16r3D2E 16r7586 16r3D2F 16r848B 16r3D30 16r6868 16r3D31 16r5956 16r3D32 16r8BB2 16r3D33 16r5320 16r3D34 16r9171 16r3D35 16r964D 16r3D36 16r8549 16r3D37 16r6912 16r3D38 16r7901 16r3D39 16r7126 16r3D3A 16r80F6 16r3D3B 16r4EA4 16r3D3C 16r90CA 16r3D3D 16r6D47 16r3D3E 16r9A84 16r3D3F 16r5A07 16r3D40 16r56BC 16r3D41 16r6405 16r3D42 16r94F0 16r3D43 16r77EB 16r3D44 16r4FA5 16r3D45 16r811A 16r3D46 16r72E1 16r3D47 16r89D2 16r3D48 16r997A 16r3D49 16r7F34 16r3D4A 16r7EDE 16r3D4B 16r527F 16r3D4C 16r6559 16r3D4D 16r9175 16r3D4E 16r8F7F 16r3D4F 16r8F83 16r3D50 16r53EB 16r3D51 16r7A96 16r3D52 16r63ED 16r3D53 16r63A5 16r3D54 16r7686 16r3D55 16r79F8 16r3D56 16r8857 16r3D57 16r9636 16r3D58 16r622A 16r3D59 16r52AB 16r3D5A 16r8282 16r3D5B 16r6854 16r3D5C 16r6770 16r3D5D 16r6377 16r3D5E 16r776B 16r3D5F 16r7AED 16r3D60 16r6D01 16r3D61 16r7ED3 16r3D62 16r89E3 16r3D63 16r59D0 16r3D64 16r6212 16r3D65 16r85C9 16r3D66 16r82A5 16r3D67 16r754C 16r3D68 16r501F 16r3D69 16r4ECB 16r3D6A 16r75A5 16r3D6B 16r8BEB 16r3D6C 16r5C4A 16r3D6D 16r5DFE 16r3D6E 16r7B4B 16r3D6F 16r65A4 16r3D70 16r91D1 16r3D71 16r4ECA 16r3D72 16r6D25 16r3D73 16r895F 16r3D74 16r7D27 16r3D75 16r9526 16r3D76 16r4EC5 16r3D77 16r8C28 16r3D78 16r8FDB 16r3D79 16r9773 16r3D7A 16r664B 16r3D7B 16r7981 16r3D7C 16r8FD1 16r3D7D 16r70EC 16r3D7E 16r6D78 16r3E21 16r5C3D 16r3E22 16r52B2 16r3E23 16r8346 16r3E24 16r5162 16r3E25 16r830E 16r3E26 16r775B 16r3E27 16r6676 16r3E28 16r9CB8 16r3E29 16r4EAC 16r3E2A 16r60CA 16r3E2B 16r7CBE 16r3E2C 16r7CB3 16r3E2D 16r7ECF 16r3E2E 16r4E95 16r3E2F 16r8B66 16r3E30 16r666F 16r3E31 16r9888 16r3E32 16r9759 16r3E33 16r5883 16r3E34 16r656C 16r3E35 16r955C 16r3E36 16r5F84 16r3E37 16r75C9 16r3E38 16r9756 16r3E39 16r7ADF 16r3E3A 16r7ADE 16r3E3B 16r51C0 16r3E3C 16r70AF 16r3E3D 16r7A98 16r3E3E 16r63EA 16r3E3F 16r7A76 16r3E40 16r7EA0 16r3E41 16r7396 16r3E42 16r97ED 16r3E43 16r4E45 16r3E44 16r7078 16r3E45 16r4E5D 16r3E46 16r9152 16r3E47 16r53A9 16r3E48 16r6551 16r3E49 16r65E7 16r3E4A 16r81FC 16r3E4B 16r8205 16r3E4C 16r548E 16r3E4D 16r5C31 16r3E4E 16r759A 16r3E4F 16r97A0 16r3E50 16r62D8 16r3E51 16r72D9 16r3E52 16r75BD 16r3E53 16r5C45 16r3E54 16r9A79 16r3E55 16r83CA 16r3E56 16r5C40 16r3E57 16r5480 16r3E58 16r77E9 16r3E59 16r4E3E 16r3E5A 16r6CAE 16r3E5B 16r805A 16r3E5C 16r62D2 16r3E5D 16r636E 16r3E5E 16r5DE8 16r3E5F 16r5177 16r3E60 16r8DDD 16r3E61 16r8E1E 16r3E62 16r952F 16r3E63 16r4FF1 16r3E64 16r53E5 16r3E65 16r60E7 16r3E66 16r70AC 16r3E67 16r5267 16r3E68 16r6350 16r3E69 16r9E43 16r3E6A 16r5A1F 16r3E6B 16r5026 16r3E6C 16r7737 16r3E6D 16r5377 16r3E6E 16r7EE2 16r3E6F 16r6485 16r3E70 16r652B 16r3E71 16r6289 16r3E72 16r6398 16r3E73 16r5014 16r3E74 16r7235 16r3E75 16r89C9 16r3E76 16r51B3 16r3E77 16r8BC0 16r3E78 16r7EDD 16r3E79 16r5747 16r3E7A 16r83CC 16r3E7B 16r94A7 16r3E7C 16r519B 16r3E7D 16r541B 16r3E7E 16r5CFB 16r3F21 16r4FCA 16r3F22 16r7AE3 16r3F23 16r6D5A 16r3F24 16r90E1 16r3F25 16r9A8F 16r3F26 16r5580 16r3F27 16r5496 16r3F28 16r5361 16r3F29 16r54AF 16r3F2A 16r5F00 16r3F2B 16r63E9 16r3F2C 16r6977 16r3F2D 16r51EF 16r3F2E 16r6168 16r3F2F 16r520A 16r3F30 16r582A 16r3F31 16r52D8 16r3F32 16r574E 16r3F33 16r780D 16r3F34 16r770B 16r3F35 16r5EB7 16r3F36 16r6177 16r3F37 16r7CE0 16r3F38 16r625B 16r3F39 16r6297 16r3F3A 16r4EA2 16r3F3B 16r7095 16r3F3C 16r8003 16r3F3D 16r62F7 16r3F3E 16r70E4 16r3F3F 16r9760 16r3F40 16r5777 16r3F41 16r82DB 16r3F42 16r67EF 16r3F43 16r68F5 16r3F44 16r78D5 16r3F45 16r9897 16r3F46 16r79D1 16r3F47 16r58F3 16r3F48 16r54B3 16r3F49 16r53EF 16r3F4A 16r6E34 16r3F4B 16r514B 16r3F4C 16r523B 16r3F4D 16r5BA2 16r3F4E 16r8BFE 16r3F4F 16r80AF 16r3F50 16r5543 16r3F51 16r57A6 16r3F52 16r6073 16r3F53 16r5751 16r3F54 16r542D 16r3F55 16r7A7A 16r3F56 16r6050 16r3F57 16r5B54 16r3F58 16r63A7 16r3F59 16r62A0 16r3F5A 16r53E3 16r3F5B 16r6263 16r3F5C 16r5BC7 16r3F5D 16r67AF 16r3F5E 16r54ED 16r3F5F 16r7A9F 16r3F60 16r82E6 16r3F61 16r9177 16r3F62 16r5E93 16r3F63 16r88E4 16r3F64 16r5938 16r3F65 16r57AE 16r3F66 16r630E 16r3F67 16r8DE8 16r3F68 16r80EF 16r3F69 16r5757 16r3F6A 16r7B77 16r3F6B 16r4FA9 16r3F6C 16r5FEB 16r3F6D 16r5BBD 16r3F6E 16r6B3E 16r3F6F 16r5321 16r3F70 16r7B50 16r3F71 16r72C2 16r3F72 16r6846 16r3F73 16r77FF 16r3F74 16r7736 16r3F75 16r65F7 16r3F76 16r51B5 16r3F77 16r4E8F 16r3F78 16r76D4 16r3F79 16r5CBF 16r3F7A 16r7AA5 16r3F7B 16r8475 16r3F7C 16r594E 16r3F7D 16r9B41 16r3F7E 16r5080 16r4021 16r9988 16r4022 16r6127 16r4023 16r6E83 16r4024 16r5764 16r4025 16r6606 16r4026 16r6346 16r4027 16r56F0 16r4028 16r62EC 16r4029 16r6269 16r402A 16r5ED3 16r402B 16r9614 16r402C 16r5783 16r402D 16r62C9 16r402E 16r5587 16r402F 16r8721 16r4030 16r814A 16r4031 16r8FA3 16r4032 16r5566 16r4033 16r83B1 16r4034 16r6765 16r4035 16r8D56 16r4036 16r84DD 16r4037 16r5A6A 16r4038 16r680F 16r4039 16r62E6 16r403A 16r7BEE 16r403B 16r9611 16r403C 16r5170 16r403D 16r6F9C 16r403E 16r8C30 16r403F 16r63FD 16r4040 16r89C8 16r4041 16r61D2 16r4042 16r7F06 16r4043 16r70C2 16r4044 16r6EE5 16r4045 16r7405 16r4046 16r6994 16r4047 16r72FC 16r4048 16r5ECA 16r4049 16r90CE 16r404A 16r6717 16r404B 16r6D6A 16r404C 16r635E 16r404D 16r52B3 16r404E 16r7262 16r404F 16r8001 16r4050 16r4F6C 16r4051 16r59E5 16r4052 16r916A 16r4053 16r70D9 16r4054 16r6D9D 16r4055 16r52D2 16r4056 16r4E50 16r4057 16r96F7 16r4058 16r956D 16r4059 16r857E 16r405A 16r78CA 16r405B 16r7D2F 16r405C 16r5121 16r405D 16r5792 16r405E 16r64C2 16r405F 16r808B 16r4060 16r7C7B 16r4061 16r6CEA 16r4062 16r68F1 16r4063 16r695E 16r4064 16r51B7 16r4065 16r5398 16r4066 16r68A8 16r4067 16r7281 16r4068 16r9ECE 16r4069 16r7BF1 16r406A 16r72F8 16r406B 16r79BB 16r406C 16r6F13 16r406D 16r7406 16r406E 16r674E 16r406F 16r91CC 16r4070 16r9CA4 16r4071 16r793C 16r4072 16r8389 16r4073 16r8354 16r4074 16r540F 16r4075 16r6817 16r4076 16r4E3D 16r4077 16r5389 16r4078 16r52B1 16r4079 16r783E 16r407A 16r5386 16r407B 16r5229 16r407C 16r5088 16r407D 16r4F8B 16r407E 16r4FD0 16r4121 16r75E2 16r4122 16r7ACB 16r4123 16r7C92 16r4124 16r6CA5 16r4125 16r96B6 16r4126 16r529B 16r4127 16r7483 16r4128 16r54E9 16r4129 16r4FE9 16r412A 16r8054 16r412B 16r83B2 16r412C 16r8FDE 16r412D 16r9570 16r412E 16r5EC9 16r412F 16r601C 16r4130 16r6D9F 16r4131 16r5E18 16r4132 16r655B 16r4133 16r8138 16r4134 16r94FE 16r4135 16r604B 16r4136 16r70BC 16r4137 16r7EC3 16r4138 16r7CAE 16r4139 16r51C9 16r413A 16r6881 16r413B 16r7CB1 16r413C 16r826F 16r413D 16r4E24 16r413E 16r8F86 16r413F 16r91CF 16r4140 16r667E 16r4141 16r4EAE 16r4142 16r8C05 16r4143 16r64A9 16r4144 16r804A 16r4145 16r50DA 16r4146 16r7597 16r4147 16r71CE 16r4148 16r5BE5 16r4149 16r8FBD 16r414A 16r6F66 16r414B 16r4E86 16r414C 16r6482 16r414D 16r9563 16r414E 16r5ED6 16r414F 16r6599 16r4150 16r5217 16r4151 16r88C2 16r4152 16r70C8 16r4153 16r52A3 16r4154 16r730E 16r4155 16r7433 16r4156 16r6797 16r4157 16r78F7 16r4158 16r9716 16r4159 16r4E34 16r415A 16r90BB 16r415B 16r9CDE 16r415C 16r6DCB 16r415D 16r51DB 16r415E 16r8D41 16r415F 16r541D 16r4160 16r62CE 16r4161 16r73B2 16r4162 16r83F1 16r4163 16r96F6 16r4164 16r9F84 16r4165 16r94C3 16r4166 16r4F36 16r4167 16r7F9A 16r4168 16r51CC 16r4169 16r7075 16r416A 16r9675 16r416B 16r5CAD 16r416C 16r9886 16r416D 16r53E6 16r416E 16r4EE4 16r416F 16r6E9C 16r4170 16r7409 16r4171 16r69B4 16r4172 16r786B 16r4173 16r998F 16r4174 16r7559 16r4175 16r5218 16r4176 16r7624 16r4177 16r6D41 16r4178 16r67F3 16r4179 16r516D 16r417A 16r9F99 16r417B 16r804B 16r417C 16r5499 16r417D 16r7B3C 16r417E 16r7ABF 16r4221 16r9686 16r4222 16r5784 16r4223 16r62E2 16r4224 16r9647 16r4225 16r697C 16r4226 16r5A04 16r4227 16r6402 16r4228 16r7BD3 16r4229 16r6F0F 16r422A 16r964B 16r422B 16r82A6 16r422C 16r5362 16r422D 16r9885 16r422E 16r5E90 16r422F 16r7089 16r4230 16r63B3 16r4231 16r5364 16r4232 16r864F 16r4233 16r9C81 16r4234 16r9E93 16r4235 16r788C 16r4236 16r9732 16r4237 16r8DEF 16r4238 16r8D42 16r4239 16r9E7F 16r423A 16r6F5E 16r423B 16r7984 16r423C 16r5F55 16r423D 16r9646 16r423E 16r622E 16r423F 16r9A74 16r4240 16r5415 16r4241 16r94DD 16r4242 16r4FA3 16r4243 16r65C5 16r4244 16r5C65 16r4245 16r5C61 16r4246 16r7F15 16r4247 16r8651 16r4248 16r6C2F 16r4249 16r5F8B 16r424A 16r7387 16r424B 16r6EE4 16r424C 16r7EFF 16r424D 16r5CE6 16r424E 16r631B 16r424F 16r5B6A 16r4250 16r6EE6 16r4251 16r5375 16r4252 16r4E71 16r4253 16r63A0 16r4254 16r7565 16r4255 16r62A1 16r4256 16r8F6E 16r4257 16r4F26 16r4258 16r4ED1 16r4259 16r6CA6 16r425A 16r7EB6 16r425B 16r8BBA 16r425C 16r841D 16r425D 16r87BA 16r425E 16r7F57 16r425F 16r903B 16r4260 16r9523 16r4261 16r7BA9 16r4262 16r9AA1 16r4263 16r88F8 16r4264 16r843D 16r4265 16r6D1B 16r4266 16r9A86 16r4267 16r7EDC 16r4268 16r5988 16r4269 16r9EBB 16r426A 16r739B 16r426B 16r7801 16r426C 16r8682 16r426D 16r9A6C 16r426E 16r9A82 16r426F 16r561B 16r4270 16r5417 16r4271 16r57CB 16r4272 16r4E70 16r4273 16r9EA6 16r4274 16r5356 16r4275 16r8FC8 16r4276 16r8109 16r4277 16r7792 16r4278 16r9992 16r4279 16r86EE 16r427A 16r6EE1 16r427B 16r8513 16r427C 16r66FC 16r427D 16r6162 16r427E 16r6F2B 16r4321 16r8C29 16r4322 16r8292 16r4323 16r832B 16r4324 16r76F2 16r4325 16r6C13 16r4326 16r5FD9 16r4327 16r83BD 16r4328 16r732B 16r4329 16r8305 16r432A 16r951A 16r432B 16r6BDB 16r432C 16r77DB 16r432D 16r94C6 16r432E 16r536F 16r432F 16r8302 16r4330 16r5192 16r4331 16r5E3D 16r4332 16r8C8C 16r4333 16r8D38 16r4334 16r4E48 16r4335 16r73AB 16r4336 16r679A 16r4337 16r6885 16r4338 16r9176 16r4339 16r9709 16r433A 16r7164 16r433B 16r6CA1 16r433C 16r7709 16r433D 16r5A92 16r433E 16r9541 16r433F 16r6BCF 16r4340 16r7F8E 16r4341 16r6627 16r4342 16r5BD0 16r4343 16r59B9 16r4344 16r5A9A 16r4345 16r95E8 16r4346 16r95F7 16r4347 16r4EEC 16r4348 16r840C 16r4349 16r8499 16r434A 16r6AAC 16r434B 16r76DF 16r434C 16r9530 16r434D 16r731B 16r434E 16r68A6 16r434F 16r5B5F 16r4350 16r772F 16r4351 16r919A 16r4352 16r9761 16r4353 16r7CDC 16r4354 16r8FF7 16r4355 16r8C1C 16r4356 16r5F25 16r4357 16r7C73 16r4358 16r79D8 16r4359 16r89C5 16r435A 16r6CCC 16r435B 16r871C 16r435C 16r5BC6 16r435D 16r5E42 16r435E 16r68C9 16r435F 16r7720 16r4360 16r7EF5 16r4361 16r5195 16r4362 16r514D 16r4363 16r52C9 16r4364 16r5A29 16r4365 16r7F05 16r4366 16r9762 16r4367 16r82D7 16r4368 16r63CF 16r4369 16r7784 16r436A 16r85D0 16r436B 16r79D2 16r436C 16r6E3A 16r436D 16r5E99 16r436E 16r5999 16r436F 16r8511 16r4370 16r706D 16r4371 16r6C11 16r4372 16r62BF 16r4373 16r76BF 16r4374 16r654F 16r4375 16r60AF 16r4376 16r95FD 16r4377 16r660E 16r4378 16r879F 16r4379 16r9E23 16r437A 16r94ED 16r437B 16r540D 16r437C 16r547D 16r437D 16r8C2C 16r437E 16r6478 16r4421 16r6479 16r4422 16r8611 16r4423 16r6A21 16r4424 16r819C 16r4425 16r78E8 16r4426 16r6469 16r4427 16r9B54 16r4428 16r62B9 16r4429 16r672B 16r442A 16r83AB 16r442B 16r58A8 16r442C 16r9ED8 16r442D 16r6CAB 16r442E 16r6F20 16r442F 16r5BDE 16r4430 16r964C 16r4431 16r8C0B 16r4432 16r725F 16r4433 16r67D0 16r4434 16r62C7 16r4435 16r7261 16r4436 16r4EA9 16r4437 16r59C6 16r4438 16r6BCD 16r4439 16r5893 16r443A 16r66AE 16r443B 16r5E55 16r443C 16r52DF 16r443D 16r6155 16r443E 16r6728 16r443F 16r76EE 16r4440 16r7766 16r4441 16r7267 16r4442 16r7A46 16r4443 16r62FF 16r4444 16r54EA 16r4445 16r5450 16r4446 16r94A0 16r4447 16r90A3 16r4448 16r5A1C 16r4449 16r7EB3 16r444A 16r6C16 16r444B 16r4E43 16r444C 16r5976 16r444D 16r8010 16r444E 16r5948 16r444F 16r5357 16r4450 16r7537 16r4451 16r96BE 16r4452 16r56CA 16r4453 16r6320 16r4454 16r8111 16r4455 16r607C 16r4456 16r95F9 16r4457 16r6DD6 16r4458 16r5462 16r4459 16r9981 16r445A 16r5185 16r445B 16r5AE9 16r445C 16r80FD 16r445D 16r59AE 16r445E 16r9713 16r445F 16r502A 16r4460 16r6CE5 16r4461 16r5C3C 16r4462 16r62DF 16r4463 16r4F60 16r4464 16r533F 16r4465 16r817B 16r4466 16r9006 16r4467 16r6EBA 16r4468 16r852B 16r4469 16r62C8 16r446A 16r5E74 16r446B 16r78BE 16r446C 16r64B5 16r446D 16r637B 16r446E 16r5FF5 16r446F 16r5A18 16r4470 16r917F 16r4471 16r9E1F 16r4472 16r5C3F 16r4473 16r634F 16r4474 16r8042 16r4475 16r5B7D 16r4476 16r556E 16r4477 16r954A 16r4478 16r954D 16r4479 16r6D85 16r447A 16r60A8 16r447B 16r67E0 16r447C 16r72DE 16r447D 16r51DD 16r447E 16r5B81 16r4521 16r62E7 16r4522 16r6CDE 16r4523 16r725B 16r4524 16r626D 16r4525 16r94AE 16r4526 16r7EBD 16r4527 16r8113 16r4528 16r6D53 16r4529 16r519C 16r452A 16r5F04 16r452B 16r5974 16r452C 16r52AA 16r452D 16r6012 16r452E 16r5973 16r452F 16r6696 16r4530 16r8650 16r4531 16r759F 16r4532 16r632A 16r4533 16r61E6 16r4534 16r7CEF 16r4535 16r8BFA 16r4536 16r54E6 16r4537 16r6B27 16r4538 16r9E25 16r4539 16r6BB4 16r453A 16r85D5 16r453B 16r5455 16r453C 16r5076 16r453D 16r6CA4 16r453E 16r556A 16r453F 16r8DB4 16r4540 16r722C 16r4541 16r5E15 16r4542 16r6015 16r4543 16r7436 16r4544 16r62CD 16r4545 16r6392 16r4546 16r724C 16r4547 16r5F98 16r4548 16r6E43 16r4549 16r6D3E 16r454A 16r6500 16r454B 16r6F58 16r454C 16r76D8 16r454D 16r78D0 16r454E 16r76FC 16r454F 16r7554 16r4550 16r5224 16r4551 16r53DB 16r4552 16r4E53 16r4553 16r5E9E 16r4554 16r65C1 16r4555 16r802A 16r4556 16r80D6 16r4557 16r629B 16r4558 16r5486 16r4559 16r5228 16r455A 16r70AE 16r455B 16r888D 16r455C 16r8DD1 16r455D 16r6CE1 16r455E 16r5478 16r455F 16r80DA 16r4560 16r57F9 16r4561 16r88F4 16r4562 16r8D54 16r4563 16r966A 16r4564 16r914D 16r4565 16r4F69 16r4566 16r6C9B 16r4567 16r55B7 16r4568 16r76C6 16r4569 16r7830 16r456A 16r62A8 16r456B 16r70F9 16r456C 16r6F8E 16r456D 16r5F6D 16r456E 16r84EC 16r456F 16r68DA 16r4570 16r787C 16r4571 16r7BF7 16r4572 16r81A8 16r4573 16r670B 16r4574 16r9E4F 16r4575 16r6367 16r4576 16r78B0 16r4577 16r576F 16r4578 16r7812 16r4579 16r9739 16r457A 16r6279 16r457B 16r62AB 16r457C 16r5288 16r457D 16r7435 16r457E 16r6BD7 16r4621 16r5564 16r4622 16r813E 16r4623 16r75B2 16r4624 16r76AE 16r4625 16r5339 16r4626 16r75DE 16r4627 16r50FB 16r4628 16r5C41 16r4629 16r8B6C 16r462A 16r7BC7 16r462B 16r504F 16r462C 16r7247 16r462D 16r9A97 16r462E 16r98D8 16r462F 16r6F02 16r4630 16r74E2 16r4631 16r7968 16r4632 16r6487 16r4633 16r77A5 16r4634 16r62FC 16r4635 16r9891 16r4636 16r8D2B 16r4637 16r54C1 16r4638 16r8058 16r4639 16r4E52 16r463A 16r576A 16r463B 16r82F9 16r463C 16r840D 16r463D 16r5E73 16r463E 16r51ED 16r463F 16r74F6 16r4640 16r8BC4 16r4641 16r5C4F 16r4642 16r5761 16r4643 16r6CFC 16r4644 16r9887 16r4645 16r5A46 16r4646 16r7834 16r4647 16r9B44 16r4648 16r8FEB 16r4649 16r7C95 16r464A 16r5256 16r464B 16r6251 16r464C 16r94FA 16r464D 16r4EC6 16r464E 16r8386 16r464F 16r8461 16r4650 16r83E9 16r4651 16r84B2 16r4652 16r57D4 16r4653 16r6734 16r4654 16r5703 16r4655 16r666E 16r4656 16r6D66 16r4657 16r8C31 16r4658 16r66DD 16r4659 16r7011 16r465A 16r671F 16r465B 16r6B3A 16r465C 16r6816 16r465D 16r621A 16r465E 16r59BB 16r465F 16r4E03 16r4660 16r51C4 16r4661 16r6F06 16r4662 16r67D2 16r4663 16r6C8F 16r4664 16r5176 16r4665 16r68CB 16r4666 16r5947 16r4667 16r6B67 16r4668 16r7566 16r4669 16r5D0E 16r466A 16r8110 16r466B 16r9F50 16r466C 16r65D7 16r466D 16r7948 16r466E 16r7941 16r466F 16r9A91 16r4670 16r8D77 16r4671 16r5C82 16r4672 16r4E5E 16r4673 16r4F01 16r4674 16r542F 16r4675 16r5951 16r4676 16r780C 16r4677 16r5668 16r4678 16r6C14 16r4679 16r8FC4 16r467A 16r5F03 16r467B 16r6C7D 16r467C 16r6CE3 16r467D 16r8BAB 16r467E 16r6390 16r4721 16r6070 16r4722 16r6D3D 16r4723 16r7275 16r4724 16r6266 16r4725 16r948E 16r4726 16r94C5 16r4727 16r5343 16r4728 16r8FC1 16r4729 16r7B7E 16r472A 16r4EDF 16r472B 16r8C26 16r472C 16r4E7E 16r472D 16r9ED4 16r472E 16r94B1 16r472F 16r94B3 16r4730 16r524D 16r4731 16r6F5C 16r4732 16r9063 16r4733 16r6D45 16r4734 16r8C34 16r4735 16r5811 16r4736 16r5D4C 16r4737 16r6B20 16r4738 16r6B49 16r4739 16r67AA 16r473A 16r545B 16r473B 16r8154 16r473C 16r7F8C 16r473D 16r5899 16r473E 16r8537 16r473F 16r5F3A 16r4740 16r62A2 16r4741 16r6A47 16r4742 16r9539 16r4743 16r6572 16r4744 16r6084 16r4745 16r6865 16r4746 16r77A7 16r4747 16r4E54 16r4748 16r4FA8 16r4749 16r5DE7 16r474A 16r9798 16r474B 16r64AC 16r474C 16r7FD8 16r474D 16r5CED 16r474E 16r4FCF 16r474F 16r7A8D 16r4750 16r5207 16r4751 16r8304 16r4752 16r4E14 16r4753 16r602F 16r4754 16r7A83 16r4755 16r94A6 16r4756 16r4FB5 16r4757 16r4EB2 16r4758 16r79E6 16r4759 16r7434 16r475A 16r52E4 16r475B 16r82B9 16r475C 16r64D2 16r475D 16r79BD 16r475E 16r5BDD 16r475F 16r6C81 16r4760 16r9752 16r4761 16r8F7B 16r4762 16r6C22 16r4763 16r503E 16r4764 16r537F 16r4765 16r6E05 16r4766 16r64CE 16r4767 16r6674 16r4768 16r6C30 16r4769 16r60C5 16r476A 16r9877 16r476B 16r8BF7 16r476C 16r5E86 16r476D 16r743C 16r476E 16r7A77 16r476F 16r79CB 16r4770 16r4E18 16r4771 16r90B1 16r4772 16r7403 16r4773 16r6C42 16r4774 16r56DA 16r4775 16r914B 16r4776 16r6CC5 16r4777 16r8D8B 16r4778 16r533A 16r4779 16r86C6 16r477A 16r66F2 16r477B 16r8EAF 16r477C 16r5C48 16r477D 16r9A71 16r477E 16r6E20 16r4821 16r53D6 16r4822 16r5A36 16r4823 16r9F8B 16r4824 16r8DA3 16r4825 16r53BB 16r4826 16r5708 16r4827 16r98A7 16r4828 16r6743 16r4829 16r919B 16r482A 16r6CC9 16r482B 16r5168 16r482C 16r75CA 16r482D 16r62F3 16r482E 16r72AC 16r482F 16r5238 16r4830 16r529D 16r4831 16r7F3A 16r4832 16r7094 16r4833 16r7638 16r4834 16r5374 16r4835 16r9E4A 16r4836 16r69B7 16r4837 16r786E 16r4838 16r96C0 16r4839 16r88D9 16r483A 16r7FA4 16r483B 16r7136 16r483C 16r71C3 16r483D 16r5189 16r483E 16r67D3 16r483F 16r74E4 16r4840 16r58E4 16r4841 16r6518 16r4842 16r56B7 16r4843 16r8BA9 16r4844 16r9976 16r4845 16r6270 16r4846 16r7ED5 16r4847 16r60F9 16r4848 16r70ED 16r4849 16r58EC 16r484A 16r4EC1 16r484B 16r4EBA 16r484C 16r5FCD 16r484D 16r97E7 16r484E 16r4EFB 16r484F 16r8BA4 16r4850 16r5203 16r4851 16r598A 16r4852 16r7EAB 16r4853 16r6254 16r4854 16r4ECD 16r4855 16r65E5 16r4856 16r620E 16r4857 16r8338 16r4858 16r84C9 16r4859 16r8363 16r485A 16r878D 16r485B 16r7194 16r485C 16r6EB6 16r485D 16r5BB9 16r485E 16r7ED2 16r485F 16r5197 16r4860 16r63C9 16r4861 16r67D4 16r4862 16r8089 16r4863 16r8339 16r4864 16r8815 16r4865 16r5112 16r4866 16r5B7A 16r4867 16r5982 16r4868 16r8FB1 16r4869 16r4E73 16r486A 16r6C5D 16r486B 16r5165 16r486C 16r8925 16r486D 16r8F6F 16r486E 16r962E 16r486F 16r854A 16r4870 16r745E 16r4871 16r9510 16r4872 16r95F0 16r4873 16r6DA6 16r4874 16r82E5 16r4875 16r5F31 16r4876 16r6492 16r4877 16r6D12 16r4878 16r8428 16r4879 16r816E 16r487A 16r9CC3 16r487B 16r585E 16r487C 16r8D5B 16r487D 16r4E09 16r487E 16r53C1 16r4921 16r4F1E 16r4922 16r6563 16r4923 16r6851 16r4924 16r55D3 16r4925 16r4E27 16r4926 16r6414 16r4927 16r9A9A 16r4928 16r626B 16r4929 16r5AC2 16r492A 16r745F 16r492B 16r8272 16r492C 16r6DA9 16r492D 16r68EE 16r492E 16r50E7 16r492F 16r838E 16r4930 16r7802 16r4931 16r6740 16r4932 16r5239 16r4933 16r6C99 16r4934 16r7EB1 16r4935 16r50BB 16r4936 16r5565 16r4937 16r715E 16r4938 16r7B5B 16r4939 16r6652 16r493A 16r73CA 16r493B 16r82EB 16r493C 16r6749 16r493D 16r5C71 16r493E 16r5220 16r493F 16r717D 16r4940 16r886B 16r4941 16r95EA 16r4942 16r9655 16r4943 16r64C5 16r4944 16r8D61 16r4945 16r81B3 16r4946 16r5584 16r4947 16r6C55 16r4948 16r6247 16r4949 16r7F2E 16r494A 16r5892 16r494B 16r4F24 16r494C 16r5546 16r494D 16r8D4F 16r494E 16r664C 16r494F 16r4E0A 16r4950 16r5C1A 16r4951 16r88F3 16r4952 16r68A2 16r4953 16r634E 16r4954 16r7A0D 16r4955 16r70E7 16r4956 16r828D 16r4957 16r52FA 16r4958 16r97F6 16r4959 16r5C11 16r495A 16r54E8 16r495B 16r90B5 16r495C 16r7ECD 16r495D 16r5962 16r495E 16r8D4A 16r495F 16r86C7 16r4960 16r820C 16r4961 16r820D 16r4962 16r8D66 16r4963 16r6444 16r4964 16r5C04 16r4965 16r6151 16r4966 16r6D89 16r4967 16r793E 16r4968 16r8BBE 16r4969 16r7837 16r496A 16r7533 16r496B 16r547B 16r496C 16r4F38 16r496D 16r8EAB 16r496E 16r6DF1 16r496F 16r5A20 16r4970 16r7EC5 16r4971 16r795E 16r4972 16r6C88 16r4973 16r5BA1 16r4974 16r5A76 16r4975 16r751A 16r4976 16r80BE 16r4977 16r614E 16r4978 16r6E17 16r4979 16r58F0 16r497A 16r751F 16r497B 16r7525 16r497C 16r7272 16r497D 16r5347 16r497E 16r7EF3 16r4A21 16r7701 16r4A22 16r76DB 16r4A23 16r5269 16r4A24 16r80DC 16r4A25 16r5723 16r4A26 16r5E08 16r4A27 16r5931 16r4A28 16r72EE 16r4A29 16r65BD 16r4A2A 16r6E7F 16r4A2B 16r8BD7 16r4A2C 16r5C38 16r4A2D 16r8671 16r4A2E 16r5341 16r4A2F 16r77F3 16r4A30 16r62FE 16r4A31 16r65F6 16r4A32 16r4EC0 16r4A33 16r98DF 16r4A34 16r8680 16r4A35 16r5B9E 16r4A36 16r8BC6 16r4A37 16r53F2 16r4A38 16r77E2 16r4A39 16r4F7F 16r4A3A 16r5C4E 16r4A3B 16r9A76 16r4A3C 16r59CB 16r4A3D 16r5F0F 16r4A3E 16r793A 16r4A3F 16r58EB 16r4A40 16r4E16 16r4A41 16r67FF 16r4A42 16r4E8B 16r4A43 16r62ED 16r4A44 16r8A93 16r4A45 16r901D 16r4A46 16r52BF 16r4A47 16r662F 16r4A48 16r55DC 16r4A49 16r566C 16r4A4A 16r9002 16r4A4B 16r4ED5 16r4A4C 16r4F8D 16r4A4D 16r91CA 16r4A4E 16r9970 16r4A4F 16r6C0F 16r4A50 16r5E02 16r4A51 16r6043 16r4A52 16r5BA4 16r4A53 16r89C6 16r4A54 16r8BD5 16r4A55 16r6536 16r4A56 16r624B 16r4A57 16r9996 16r4A58 16r5B88 16r4A59 16r5BFF 16r4A5A 16r6388 16r4A5B 16r552E 16r4A5C 16r53D7 16r4A5D 16r7626 16r4A5E 16r517D 16r4A5F 16r852C 16r4A60 16r67A2 16r4A61 16r68B3 16r4A62 16r6B8A 16r4A63 16r6292 16r4A64 16r8F93 16r4A65 16r53D4 16r4A66 16r8212 16r4A67 16r6DD1 16r4A68 16r758F 16r4A69 16r4E66 16r4A6A 16r8D4E 16r4A6B 16r5B70 16r4A6C 16r719F 16r4A6D 16r85AF 16r4A6E 16r6691 16r4A6F 16r66D9 16r4A70 16r7F72 16r4A71 16r8700 16r4A72 16r9ECD 16r4A73 16r9F20 16r4A74 16r5C5E 16r4A75 16r672F 16r4A76 16r8FF0 16r4A77 16r6811 16r4A78 16r675F 16r4A79 16r620D 16r4A7A 16r7AD6 16r4A7B 16r5885 16r4A7C 16r5EB6 16r4A7D 16r6570 16r4A7E 16r6F31 16r4B21 16r6055 16r4B22 16r5237 16r4B23 16r800D 16r4B24 16r6454 16r4B25 16r8870 16r4B26 16r7529 16r4B27 16r5E05 16r4B28 16r6813 16r4B29 16r62F4 16r4B2A 16r971C 16r4B2B 16r53CC 16r4B2C 16r723D 16r4B2D 16r8C01 16r4B2E 16r6C34 16r4B2F 16r7761 16r4B30 16r7A0E 16r4B31 16r542E 16r4B32 16r77AC 16r4B33 16r987A 16r4B34 16r821C 16r4B35 16r8BF4 16r4B36 16r7855 16r4B37 16r6714 16r4B38 16r70C1 16r4B39 16r65AF 16r4B3A 16r6495 16r4B3B 16r5636 16r4B3C 16r601D 16r4B3D 16r79C1 16r4B3E 16r53F8 16r4B3F 16r4E1D 16r4B40 16r6B7B 16r4B41 16r8086 16r4B42 16r5BFA 16r4B43 16r55E3 16r4B44 16r56DB 16r4B45 16r4F3A 16r4B46 16r4F3C 16r4B47 16r9972 16r4B48 16r5DF3 16r4B49 16r677E 16r4B4A 16r8038 16r4B4B 16r6002 16r4B4C 16r9882 16r4B4D 16r9001 16r4B4E 16r5B8B 16r4B4F 16r8BBC 16r4B50 16r8BF5 16r4B51 16r641C 16r4B52 16r8258 16r4B53 16r64DE 16r4B54 16r55FD 16r4B55 16r82CF 16r4B56 16r9165 16r4B57 16r4FD7 16r4B58 16r7D20 16r4B59 16r901F 16r4B5A 16r7C9F 16r4B5B 16r50F3 16r4B5C 16r5851 16r4B5D 16r6EAF 16r4B5E 16r5BBF 16r4B5F 16r8BC9 16r4B60 16r8083 16r4B61 16r9178 16r4B62 16r849C 16r4B63 16r7B97 16r4B64 16r867D 16r4B65 16r968B 16r4B66 16r968F 16r4B67 16r7EE5 16r4B68 16r9AD3 16r4B69 16r788E 16r4B6A 16r5C81 16r4B6B 16r7A57 16r4B6C 16r9042 16r4B6D 16r96A7 16r4B6E 16r795F 16r4B6F 16r5B59 16r4B70 16r635F 16r4B71 16r7B0B 16r4B72 16r84D1 16r4B73 16r68AD 16r4B74 16r5506 16r4B75 16r7F29 16r4B76 16r7410 16r4B77 16r7D22 16r4B78 16r9501 16r4B79 16r6240 16r4B7A 16r584C 16r4B7B 16r4ED6 16r4B7C 16r5B83 16r4B7D 16r5979 16r4B7E 16r5854 16r4C21 16r736D 16r4C22 16r631E 16r4C23 16r8E4B 16r4C24 16r8E0F 16r4C25 16r80CE 16r4C26 16r82D4 16r4C27 16r62AC 16r4C28 16r53F0 16r4C29 16r6CF0 16r4C2A 16r915E 16r4C2B 16r592A 16r4C2C 16r6001 16r4C2D 16r6C70 16r4C2E 16r574D 16r4C2F 16r644A 16r4C30 16r8D2A 16r4C31 16r762B 16r4C32 16r6EE9 16r4C33 16r575B 16r4C34 16r6A80 16r4C35 16r75F0 16r4C36 16r6F6D 16r4C37 16r8C2D 16r4C38 16r8C08 16r4C39 16r5766 16r4C3A 16r6BEF 16r4C3B 16r8892 16r4C3C 16r78B3 16r4C3D 16r63A2 16r4C3E 16r53F9 16r4C3F 16r70AD 16r4C40 16r6C64 16r4C41 16r5858 16r4C42 16r642A 16r4C43 16r5802 16r4C44 16r68E0 16r4C45 16r819B 16r4C46 16r5510 16r4C47 16r7CD6 16r4C48 16r5018 16r4C49 16r8EBA 16r4C4A 16r6DCC 16r4C4B 16r8D9F 16r4C4C 16r70EB 16r4C4D 16r638F 16r4C4E 16r6D9B 16r4C4F 16r6ED4 16r4C50 16r7EE6 16r4C51 16r8404 16r4C52 16r6843 16r4C53 16r9003 16r4C54 16r6DD8 16r4C55 16r9676 16r4C56 16r8BA8 16r4C57 16r5957 16r4C58 16r7279 16r4C59 16r85E4 16r4C5A 16r817E 16r4C5B 16r75BC 16r4C5C 16r8A8A 16r4C5D 16r68AF 16r4C5E 16r5254 16r4C5F 16r8E22 16r4C60 16r9511 16r4C61 16r63D0 16r4C62 16r9898 16r4C63 16r8E44 16r4C64 16r557C 16r4C65 16r4F53 16r4C66 16r66FF 16r4C67 16r568F 16r4C68 16r60D5 16r4C69 16r6D95 16r4C6A 16r5243 16r4C6B 16r5C49 16r4C6C 16r5929 16r4C6D 16r6DFB 16r4C6E 16r586B 16r4C6F 16r7530 16r4C70 16r751C 16r4C71 16r606C 16r4C72 16r8214 16r4C73 16r8146 16r4C74 16r6311 16r4C75 16r6761 16r4C76 16r8FE2 16r4C77 16r773A 16r4C78 16r8DF3 16r4C79 16r8D34 16r4C7A 16r94C1 16r4C7B 16r5E16 16r4C7C 16r5385 16r4C7D 16r542C 16r4C7E 16r70C3 16r4D21 16r6C40 16r4D22 16r5EF7 16r4D23 16r505C 16r4D24 16r4EAD 16r4D25 16r5EAD 16r4D26 16r633A 16r4D27 16r8247 16r4D28 16r901A 16r4D29 16r6850 16r4D2A 16r916E 16r4D2B 16r77B3 16r4D2C 16r540C 16r4D2D 16r94DC 16r4D2E 16r5F64 16r4D2F 16r7AE5 16r4D30 16r6876 16r4D31 16r6345 16r4D32 16r7B52 16r4D33 16r7EDF 16r4D34 16r75DB 16r4D35 16r5077 16r4D36 16r6295 16r4D37 16r5934 16r4D38 16r900F 16r4D39 16r51F8 16r4D3A 16r79C3 16r4D3B 16r7A81 16r4D3C 16r56FE 16r4D3D 16r5F92 16r4D3E 16r9014 16r4D3F 16r6D82 16r4D40 16r5C60 16r4D41 16r571F 16r4D42 16r5410 16r4D43 16r5154 16r4D44 16r6E4D 16r4D45 16r56E2 16r4D46 16r63A8 16r4D47 16r9893 16r4D48 16r817F 16r4D49 16r8715 16r4D4A 16r892A 16r4D4B 16r9000 16r4D4C 16r541E 16r4D4D 16r5C6F 16r4D4E 16r81C0 16r4D4F 16r62D6 16r4D50 16r6258 16r4D51 16r8131 16r4D52 16r9E35 16r4D53 16r9640 16r4D54 16r9A6E 16r4D55 16r9A7C 16r4D56 16r692D 16r4D57 16r59A5 16r4D58 16r62D3 16r4D59 16r553E 16r4D5A 16r6316 16r4D5B 16r54C7 16r4D5C 16r86D9 16r4D5D 16r6D3C 16r4D5E 16r5A03 16r4D5F 16r74E6 16r4D60 16r889C 16r4D61 16r6B6A 16r4D62 16r5916 16r4D63 16r8C4C 16r4D64 16r5F2F 16r4D65 16r6E7E 16r4D66 16r73A9 16r4D67 16r987D 16r4D68 16r4E38 16r4D69 16r70F7 16r4D6A 16r5B8C 16r4D6B 16r7897 16r4D6C 16r633D 16r4D6D 16r665A 16r4D6E 16r7696 16r4D6F 16r60CB 16r4D70 16r5B9B 16r4D71 16r5A49 16r4D72 16r4E07 16r4D73 16r8155 16r4D74 16r6C6A 16r4D75 16r738B 16r4D76 16r4EA1 16r4D77 16r6789 16r4D78 16r7F51 16r4D79 16r5F80 16r4D7A 16r65FA 16r4D7B 16r671B 16r4D7C 16r5FD8 16r4D7D 16r5984 16r4D7E 16r5A01 16r4E21 16r5DCD 16r4E22 16r5FAE 16r4E23 16r5371 16r4E24 16r97E6 16r4E25 16r8FDD 16r4E26 16r6845 16r4E27 16r56F4 16r4E28 16r552F 16r4E29 16r60DF 16r4E2A 16r4E3A 16r4E2B 16r6F4D 16r4E2C 16r7EF4 16r4E2D 16r82C7 16r4E2E 16r840E 16r4E2F 16r59D4 16r4E30 16r4F1F 16r4E31 16r4F2A 16r4E32 16r5C3E 16r4E33 16r7EAC 16r4E34 16r672A 16r4E35 16r851A 16r4E36 16r5473 16r4E37 16r754F 16r4E38 16r80C3 16r4E39 16r5582 16r4E3A 16r9B4F 16r4E3B 16r4F4D 16r4E3C 16r6E2D 16r4E3D 16r8C13 16r4E3E 16r5C09 16r4E3F 16r6170 16r4E40 16r536B 16r4E41 16r761F 16r4E42 16r6E29 16r4E43 16r868A 16r4E44 16r6587 16r4E45 16r95FB 16r4E46 16r7EB9 16r4E47 16r543B 16r4E48 16r7A33 16r4E49 16r7D0A 16r4E4A 16r95EE 16r4E4B 16r55E1 16r4E4C 16r7FC1 16r4E4D 16r74EE 16r4E4E 16r631D 16r4E4F 16r8717 16r4E50 16r6DA1 16r4E51 16r7A9D 16r4E52 16r6211 16r4E53 16r65A1 16r4E54 16r5367 16r4E55 16r63E1 16r4E56 16r6C83 16r4E57 16r5DEB 16r4E58 16r545C 16r4E59 16r94A8 16r4E5A 16r4E4C 16r4E5B 16r6C61 16r4E5C 16r8BEC 16r4E5D 16r5C4B 16r4E5E 16r65E0 16r4E5F 16r829C 16r4E60 16r68A7 16r4E61 16r543E 16r4E62 16r5434 16r4E63 16r6BCB 16r4E64 16r6B66 16r4E65 16r4E94 16r4E66 16r6342 16r4E67 16r5348 16r4E68 16r821E 16r4E69 16r4F0D 16r4E6A 16r4FAE 16r4E6B 16r575E 16r4E6C 16r620A 16r4E6D 16r96FE 16r4E6E 16r6664 16r4E6F 16r7269 16r4E70 16r52FF 16r4E71 16r52A1 16r4E72 16r609F 16r4E73 16r8BEF 16r4E74 16r6614 16r4E75 16r7199 16r4E76 16r6790 16r4E77 16r897F 16r4E78 16r7852 16r4E79 16r77FD 16r4E7A 16r6670 16r4E7B 16r563B 16r4E7C 16r5438 16r4E7D 16r9521 16r4E7E 16r727A 16r4F21 16r7A00 16r4F22 16r606F 16r4F23 16r5E0C 16r4F24 16r6089 16r4F25 16r819D 16r4F26 16r5915 16r4F27 16r60DC 16r4F28 16r7184 16r4F29 16r70EF 16r4F2A 16r6EAA 16r4F2B 16r6C50 16r4F2C 16r7280 16r4F2D 16r6A84 16r4F2E 16r88AD 16r4F2F 16r5E2D 16r4F30 16r4E60 16r4F31 16r5AB3 16r4F32 16r559C 16r4F33 16r94E3 16r4F34 16r6D17 16r4F35 16r7CFB 16r4F36 16r9699 16r4F37 16r620F 16r4F38 16r7EC6 16r4F39 16r778E 16r4F3A 16r867E 16r4F3B 16r5323 16r4F3C 16r971E 16r4F3D 16r8F96 16r4F3E 16r6687 16r4F3F 16r5CE1 16r4F40 16r4FA0 16r4F41 16r72ED 16r4F42 16r4E0B 16r4F43 16r53A6 16r4F44 16r590F 16r4F45 16r5413 16r4F46 16r6380 16r4F47 16r9528 16r4F48 16r5148 16r4F49 16r4ED9 16r4F4A 16r9C9C 16r4F4B 16r7EA4 16r4F4C 16r54B8 16r4F4D 16r8D24 16r4F4E 16r8854 16r4F4F 16r8237 16r4F50 16r95F2 16r4F51 16r6D8E 16r4F52 16r5F26 16r4F53 16r5ACC 16r4F54 16r663E 16r4F55 16r9669 16r4F56 16r73B0 16r4F57 16r732E 16r4F58 16r53BF 16r4F59 16r817A 16r4F5A 16r9985 16r4F5B 16r7FA1 16r4F5C 16r5BAA 16r4F5D 16r9677 16r4F5E 16r9650 16r4F5F 16r7EBF 16r4F60 16r76F8 16r4F61 16r53A2 16r4F62 16r9576 16r4F63 16r9999 16r4F64 16r7BB1 16r4F65 16r8944 16r4F66 16r6E58 16r4F67 16r4E61 16r4F68 16r7FD4 16r4F69 16r7965 16r4F6A 16r8BE6 16r4F6B 16r60F3 16r4F6C 16r54CD 16r4F6D 16r4EAB 16r4F6E 16r9879 16r4F6F 16r5DF7 16r4F70 16r6A61 16r4F71 16r50CF 16r4F72 16r5411 16r4F73 16r8C61 16r4F74 16r8427 16r4F75 16r785D 16r4F76 16r9704 16r4F77 16r524A 16r4F78 16r54EE 16r4F79 16r56A3 16r4F7A 16r9500 16r4F7B 16r6D88 16r4F7C 16r5BB5 16r4F7D 16r6DC6 16r4F7E 16r6653 16r5021 16r5C0F 16r5022 16r5B5D 16r5023 16r6821 16r5024 16r8096 16r5025 16r5578 16r5026 16r7B11 16r5027 16r6548 16r5028 16r6954 16r5029 16r4E9B 16r502A 16r6B47 16r502B 16r874E 16r502C 16r978B 16r502D 16r534F 16r502E 16r631F 16r502F 16r643A 16r5030 16r90AA 16r5031 16r659C 16r5032 16r80C1 16r5033 16r8C10 16r5034 16r5199 16r5035 16r68B0 16r5036 16r5378 16r5037 16r87F9 16r5038 16r61C8 16r5039 16r6CC4 16r503A 16r6CFB 16r503B 16r8C22 16r503C 16r5C51 16r503D 16r85AA 16r503E 16r82AF 16r503F 16r950C 16r5040 16r6B23 16r5041 16r8F9B 16r5042 16r65B0 16r5043 16r5FFB 16r5044 16r5FC3 16r5045 16r4FE1 16r5046 16r8845 16r5047 16r661F 16r5048 16r8165 16r5049 16r7329 16r504A 16r60FA 16r504B 16r5174 16r504C 16r5211 16r504D 16r578B 16r504E 16r5F62 16r504F 16r90A2 16r5050 16r884C 16r5051 16r9192 16r5052 16r5E78 16r5053 16r674F 16r5054 16r6027 16r5055 16r59D3 16r5056 16r5144 16r5057 16r51F6 16r5058 16r80F8 16r5059 16r5308 16r505A 16r6C79 16r505B 16r96C4 16r505C 16r718A 16r505D 16r4F11 16r505E 16r4FEE 16r505F 16r7F9E 16r5060 16r673D 16r5061 16r55C5 16r5062 16r9508 16r5063 16r79C0 16r5064 16r8896 16r5065 16r7EE3 16r5066 16r589F 16r5067 16r620C 16r5068 16r9700 16r5069 16r865A 16r506A 16r5618 16r506B 16r987B 16r506C 16r5F90 16r506D 16r8BB8 16r506E 16r84C4 16r506F 16r9157 16r5070 16r53D9 16r5071 16r65ED 16r5072 16r5E8F 16r5073 16r755C 16r5074 16r6064 16r5075 16r7D6E 16r5076 16r5A7F 16r5077 16r7EEA 16r5078 16r7EED 16r5079 16r8F69 16r507A 16r55A7 16r507B 16r5BA3 16r507C 16r60AC 16r507D 16r65CB 16r507E 16r7384 16r5121 16r9009 16r5122 16r7663 16r5123 16r7729 16r5124 16r7EDA 16r5125 16r9774 16r5126 16r859B 16r5127 16r5B66 16r5128 16r7A74 16r5129 16r96EA 16r512A 16r8840 16r512B 16r52CB 16r512C 16r718F 16r512D 16r5FAA 16r512E 16r65EC 16r512F 16r8BE2 16r5130 16r5BFB 16r5131 16r9A6F 16r5132 16r5DE1 16r5133 16r6B89 16r5134 16r6C5B 16r5135 16r8BAD 16r5136 16r8BAF 16r5137 16r900A 16r5138 16r8FC5 16r5139 16r538B 16r513A 16r62BC 16r513B 16r9E26 16r513C 16r9E2D 16r513D 16r5440 16r513E 16r4E2B 16r513F 16r82BD 16r5140 16r7259 16r5141 16r869C 16r5142 16r5D16 16r5143 16r8859 16r5144 16r6DAF 16r5145 16r96C5 16r5146 16r54D1 16r5147 16r4E9A 16r5148 16r8BB6 16r5149 16r7109 16r514A 16r54BD 16r514B 16r9609 16r514C 16r70DF 16r514D 16r6DF9 16r514E 16r76D0 16r514F 16r4E25 16r5150 16r7814 16r5151 16r8712 16r5152 16r5CA9 16r5153 16r5EF6 16r5154 16r8A00 16r5155 16r989C 16r5156 16r960E 16r5157 16r708E 16r5158 16r6CBF 16r5159 16r5944 16r515A 16r63A9 16r515B 16r773C 16r515C 16r884D 16r515D 16r6F14 16r515E 16r8273 16r515F 16r5830 16r5160 16r71D5 16r5161 16r538C 16r5162 16r781A 16r5163 16r96C1 16r5164 16r5501 16r5165 16r5F66 16r5166 16r7130 16r5167 16r5BB4 16r5168 16r8C1A 16r5169 16r9A8C 16r516A 16r6B83 16r516B 16r592E 16r516C 16r9E2F 16r516D 16r79E7 16r516E 16r6768 16r516F 16r626C 16r5170 16r4F6F 16r5171 16r75A1 16r5172 16r7F8A 16r5173 16r6D0B 16r5174 16r9633 16r5175 16r6C27 16r5176 16r4EF0 16r5177 16r75D2 16r5178 16r517B 16r5179 16r6837 16r517A 16r6F3E 16r517B 16r9080 16r517C 16r8170 16r517D 16r5996 16r517E 16r7476 16r5221 16r6447 16r5222 16r5C27 16r5223 16r9065 16r5224 16r7A91 16r5225 16r8C23 16r5226 16r59DA 16r5227 16r54AC 16r5228 16r8200 16r5229 16r836F 16r522A 16r8981 16r522B 16r8000 16r522C 16r6930 16r522D 16r564E 16r522E 16r8036 16r522F 16r7237 16r5230 16r91CE 16r5231 16r51B6 16r5232 16r4E5F 16r5233 16r9875 16r5234 16r6396 16r5235 16r4E1A 16r5236 16r53F6 16r5237 16r66F3 16r5238 16r814B 16r5239 16r591C 16r523A 16r6DB2 16r523B 16r4E00 16r523C 16r58F9 16r523D 16r533B 16r523E 16r63D6 16r523F 16r94F1 16r5240 16r4F9D 16r5241 16r4F0A 16r5242 16r8863 16r5243 16r9890 16r5244 16r5937 16r5245 16r9057 16r5246 16r79FB 16r5247 16r4EEA 16r5248 16r80F0 16r5249 16r7591 16r524A 16r6C82 16r524B 16r5B9C 16r524C 16r59E8 16r524D 16r5F5D 16r524E 16r6905 16r524F 16r8681 16r5250 16r501A 16r5251 16r5DF2 16r5252 16r4E59 16r5253 16r77E3 16r5254 16r4EE5 16r5255 16r827A 16r5256 16r6291 16r5257 16r6613 16r5258 16r9091 16r5259 16r5C79 16r525A 16r4EBF 16r525B 16r5F79 16r525C 16r81C6 16r525D 16r9038 16r525E 16r8084 16r525F 16r75AB 16r5260 16r4EA6 16r5261 16r88D4 16r5262 16r610F 16r5263 16r6BC5 16r5264 16r5FC6 16r5265 16r4E49 16r5266 16r76CA 16r5267 16r6EA2 16r5268 16r8BE3 16r5269 16r8BAE 16r526A 16r8C0A 16r526B 16r8BD1 16r526C 16r5F02 16r526D 16r7FFC 16r526E 16r7FCC 16r526F 16r7ECE 16r5270 16r8335 16r5271 16r836B 16r5272 16r56E0 16r5273 16r6BB7 16r5274 16r97F3 16r5275 16r9634 16r5276 16r59FB 16r5277 16r541F 16r5278 16r94F6 16r5279 16r6DEB 16r527A 16r5BC5 16r527B 16r996E 16r527C 16r5C39 16r527D 16r5F15 16r527E 16r9690 16r5321 16r5370 16r5322 16r82F1 16r5323 16r6A31 16r5324 16r5A74 16r5325 16r9E70 16r5326 16r5E94 16r5327 16r7F28 16r5328 16r83B9 16r5329 16r8424 16r532A 16r8425 16r532B 16r8367 16r532C 16r8747 16r532D 16r8FCE 16r532E 16r8D62 16r532F 16r76C8 16r5330 16r5F71 16r5331 16r9896 16r5332 16r786C 16r5333 16r6620 16r5334 16r54DF 16r5335 16r62E5 16r5336 16r4F63 16r5337 16r81C3 16r5338 16r75C8 16r5339 16r5EB8 16r533A 16r96CD 16r533B 16r8E0A 16r533C 16r86F9 16r533D 16r548F 16r533E 16r6CF3 16r533F 16r6D8C 16r5340 16r6C38 16r5341 16r607F 16r5342 16r52C7 16r5343 16r7528 16r5344 16r5E7D 16r5345 16r4F18 16r5346 16r60A0 16r5347 16r5FE7 16r5348 16r5C24 16r5349 16r7531 16r534A 16r90AE 16r534B 16r94C0 16r534C 16r72B9 16r534D 16r6CB9 16r534E 16r6E38 16r534F 16r9149 16r5350 16r6709 16r5351 16r53CB 16r5352 16r53F3 16r5353 16r4F51 16r5354 16r91C9 16r5355 16r8BF1 16r5356 16r53C8 16r5357 16r5E7C 16r5358 16r8FC2 16r5359 16r6DE4 16r535A 16r4E8E 16r535B 16r76C2 16r535C 16r6986 16r535D 16r865E 16r535E 16r611A 16r535F 16r8206 16r5360 16r4F59 16r5361 16r4FDE 16r5362 16r903E 16r5363 16r9C7C 16r5364 16r6109 16r5365 16r6E1D 16r5366 16r6E14 16r5367 16r9685 16r5368 16r4E88 16r5369 16r5A31 16r536A 16r96E8 16r536B 16r4E0E 16r536C 16r5C7F 16r536D 16r79B9 16r536E 16r5B87 16r536F 16r8BED 16r5370 16r7FBD 16r5371 16r7389 16r5372 16r57DF 16r5373 16r828B 16r5374 16r90C1 16r5375 16r5401 16r5376 16r9047 16r5377 16r55BB 16r5378 16r5CEA 16r5379 16r5FA1 16r537A 16r6108 16r537B 16r6B32 16r537C 16r72F1 16r537D 16r80B2 16r537E 16r8A89 16r5421 16r6D74 16r5422 16r5BD3 16r5423 16r88D5 16r5424 16r9884 16r5425 16r8C6B 16r5426 16r9A6D 16r5427 16r9E33 16r5428 16r6E0A 16r5429 16r51A4 16r542A 16r5143 16r542B 16r57A3 16r542C 16r8881 16r542D 16r539F 16r542E 16r63F4 16r542F 16r8F95 16r5430 16r56ED 16r5431 16r5458 16r5432 16r5706 16r5433 16r733F 16r5434 16r6E90 16r5435 16r7F18 16r5436 16r8FDC 16r5437 16r82D1 16r5438 16r613F 16r5439 16r6028 16r543A 16r9662 16r543B 16r66F0 16r543C 16r7EA6 16r543D 16r8D8A 16r543E 16r8DC3 16r543F 16r94A5 16r5440 16r5CB3 16r5441 16r7CA4 16r5442 16r6708 16r5443 16r60A6 16r5444 16r9605 16r5445 16r8018 16r5446 16r4E91 16r5447 16r90E7 16r5448 16r5300 16r5449 16r9668 16r544A 16r5141 16r544B 16r8FD0 16r544C 16r8574 16r544D 16r915D 16r544E 16r6655 16r544F 16r97F5 16r5450 16r5B55 16r5451 16r531D 16r5452 16r7838 16r5453 16r6742 16r5454 16r683D 16r5455 16r54C9 16r5456 16r707E 16r5457 16r5BB0 16r5458 16r8F7D 16r5459 16r518D 16r545A 16r5728 16r545B 16r54B1 16r545C 16r6512 16r545D 16r6682 16r545E 16r8D5E 16r545F 16r8D43 16r5460 16r810F 16r5461 16r846C 16r5462 16r906D 16r5463 16r7CDF 16r5464 16r51FF 16r5465 16r85FB 16r5466 16r67A3 16r5467 16r65E9 16r5468 16r6FA1 16r5469 16r86A4 16r546A 16r8E81 16r546B 16r566A 16r546C 16r9020 16r546D 16r7682 16r546E 16r7076 16r546F 16r71E5 16r5470 16r8D23 16r5471 16r62E9 16r5472 16r5219 16r5473 16r6CFD 16r5474 16r8D3C 16r5475 16r600E 16r5476 16r589E 16r5477 16r618E 16r5478 16r66FE 16r5479 16r8D60 16r547A 16r624E 16r547B 16r55B3 16r547C 16r6E23 16r547D 16r672D 16r547E 16r8F67 16r5521 16r94E1 16r5522 16r95F8 16r5523 16r7728 16r5524 16r6805 16r5525 16r69A8 16r5526 16r548B 16r5527 16r4E4D 16r5528 16r70B8 16r5529 16r8BC8 16r552A 16r6458 16r552B 16r658B 16r552C 16r5B85 16r552D 16r7A84 16r552E 16r503A 16r552F 16r5BE8 16r5530 16r77BB 16r5531 16r6BE1 16r5532 16r8A79 16r5533 16r7C98 16r5534 16r6CBE 16r5535 16r76CF 16r5536 16r65A9 16r5537 16r8F97 16r5538 16r5D2D 16r5539 16r5C55 16r553A 16r8638 16r553B 16r6808 16r553C 16r5360 16r553D 16r6218 16r553E 16r7AD9 16r553F 16r6E5B 16r5540 16r7EFD 16r5541 16r6A1F 16r5542 16r7AE0 16r5543 16r5F70 16r5544 16r6F33 16r5545 16r5F20 16r5546 16r638C 16r5547 16r6DA8 16r5548 16r6756 16r5549 16r4E08 16r554A 16r5E10 16r554B 16r8D26 16r554C 16r4ED7 16r554D 16r80C0 16r554E 16r7634 16r554F 16r969C 16r5550 16r62DB 16r5551 16r662D 16r5552 16r627E 16r5553 16r6CBC 16r5554 16r8D75 16r5555 16r7167 16r5556 16r7F69 16r5557 16r5146 16r5558 16r8087 16r5559 16r53EC 16r555A 16r906E 16r555B 16r6298 16r555C 16r54F2 16r555D 16r86F0 16r555E 16r8F99 16r555F 16r8005 16r5560 16r9517 16r5561 16r8517 16r5562 16r8FD9 16r5563 16r6D59 16r5564 16r73CD 16r5565 16r659F 16r5566 16r771F 16r5567 16r7504 16r5568 16r7827 16r5569 16r81FB 16r556A 16r8D1E 16r556B 16r9488 16r556C 16r4FA6 16r556D 16r6795 16r556E 16r75B9 16r556F 16r8BCA 16r5570 16r9707 16r5571 16r632F 16r5572 16r9547 16r5573 16r9635 16r5574 16r84B8 16r5575 16r6323 16r5576 16r7741 16r5577 16r5F81 16r5578 16r72F0 16r5579 16r4E89 16r557A 16r6014 16r557B 16r6574 16r557C 16r62EF 16r557D 16r6B63 16r557E 16r653F 16r5621 16r5E27 16r5622 16r75C7 16r5623 16r90D1 16r5624 16r8BC1 16r5625 16r829D 16r5626 16r679D 16r5627 16r652F 16r5628 16r5431 16r5629 16r8718 16r562A 16r77E5 16r562B 16r80A2 16r562C 16r8102 16r562D 16r6C41 16r562E 16r4E4B 16r562F 16r7EC7 16r5630 16r804C 16r5631 16r76F4 16r5632 16r690D 16r5633 16r6B96 16r5634 16r6267 16r5635 16r503C 16r5636 16r4F84 16r5637 16r5740 16r5638 16r6307 16r5639 16r6B62 16r563A 16r8DBE 16r563B 16r53EA 16r563C 16r65E8 16r563D 16r7EB8 16r563E 16r5FD7 16r563F 16r631A 16r5640 16r63B7 16r5641 16r81F3 16r5642 16r81F4 16r5643 16r7F6E 16r5644 16r5E1C 16r5645 16r5CD9 16r5646 16r5236 16r5647 16r667A 16r5648 16r79E9 16r5649 16r7A1A 16r564A 16r8D28 16r564B 16r7099 16r564C 16r75D4 16r564D 16r6EDE 16r564E 16r6CBB 16r564F 16r7A92 16r5650 16r4E2D 16r5651 16r76C5 16r5652 16r5FE0 16r5653 16r949F 16r5654 16r8877 16r5655 16r7EC8 16r5656 16r79CD 16r5657 16r80BF 16r5658 16r91CD 16r5659 16r4EF2 16r565A 16r4F17 16r565B 16r821F 16r565C 16r5468 16r565D 16r5DDE 16r565E 16r6D32 16r565F 16r8BCC 16r5660 16r7CA5 16r5661 16r8F74 16r5662 16r8098 16r5663 16r5E1A 16r5664 16r5492 16r5665 16r76B1 16r5666 16r5B99 16r5667 16r663C 16r5668 16r9AA4 16r5669 16r73E0 16r566A 16r682A 16r566B 16r86DB 16r566C 16r6731 16r566D 16r732A 16r566E 16r8BF8 16r566F 16r8BDB 16r5670 16r9010 16r5671 16r7AF9 16r5672 16r70DB 16r5673 16r716E 16r5674 16r62C4 16r5675 16r77A9 16r5676 16r5631 16r5677 16r4E3B 16r5678 16r8457 16r5679 16r67F1 16r567A 16r52A9 16r567B 16r86C0 16r567C 16r8D2E 16r567D 16r94F8 16r567E 16r7B51 16r5721 16r4F4F 16r5722 16r6CE8 16r5723 16r795D 16r5724 16r9A7B 16r5725 16r6293 16r5726 16r722A 16r5727 16r62FD 16r5728 16r4E13 16r5729 16r7816 16r572A 16r8F6C 16r572B 16r64B0 16r572C 16r8D5A 16r572D 16r7BC6 16r572E 16r6869 16r572F 16r5E84 16r5730 16r88C5 16r5731 16r5986 16r5732 16r649E 16r5733 16r58EE 16r5734 16r72B6 16r5735 16r690E 16r5736 16r9525 16r5737 16r8FFD 16r5738 16r8D58 16r5739 16r5760 16r573A 16r7F00 16r573B 16r8C06 16r573C 16r51C6 16r573D 16r6349 16r573E 16r62D9 16r573F 16r5353 16r5740 16r684C 16r5741 16r7422 16r5742 16r8301 16r5743 16r914C 16r5744 16r5544 16r5745 16r7740 16r5746 16r707C 16r5747 16r6D4A 16r5748 16r5179 16r5749 16r54A8 16r574A 16r8D44 16r574B 16r59FF 16r574C 16r6ECB 16r574D 16r6DC4 16r574E 16r5B5C 16r574F 16r7D2B 16r5750 16r4ED4 16r5751 16r7C7D 16r5752 16r6ED3 16r5753 16r5B50 16r5754 16r81EA 16r5755 16r6E0D 16r5756 16r5B57 16r5757 16r9B03 16r5758 16r68D5 16r5759 16r8E2A 16r575A 16r5B97 16r575B 16r7EFC 16r575C 16r603B 16r575D 16r7EB5 16r575E 16r90B9 16r575F 16r8D70 16r5760 16r594F 16r5761 16r63CD 16r5762 16r79DF 16r5763 16r8DB3 16r5764 16r5352 16r5765 16r65CF 16r5766 16r7956 16r5767 16r8BC5 16r5768 16r963B 16r5769 16r7EC4 16r576A 16r94BB 16r576B 16r7E82 16r576C 16r5634 16r576D 16r9189 16r576E 16r6700 16r576F 16r7F6A 16r5770 16r5C0A 16r5771 16r9075 16r5772 16r6628 16r5773 16r5DE6 16r5774 16r4F50 16r5775 16r67DE 16r5776 16r505A 16r5777 16r4F5C 16r5778 16r5750 16r5779 16r5EA7 16r5821 16r4E8D 16r5822 16r4E0C 16r5823 16r5140 16r5824 16r4E10 16r5825 16r5EFF 16r5826 16r5345 16r5827 16r4E15 16r5828 16r4E98 16r5829 16r4E1E 16r582A 16r9B32 16r582B 16r5B6C 16r582C 16r5669 16r582D 16r4E28 16r582E 16r79BA 16r582F 16r4E3F 16r5830 16r5315 16r5831 16r4E47 16r5832 16r592D 16r5833 16r723B 16r5834 16r536E 16r5835 16r6C10 16r5836 16r56DF 16r5837 16r80E4 16r5838 16r9997 16r5839 16r6BD3 16r583A 16r777E 16r583B 16r9F17 16r583C 16r4E36 16r583D 16r4E9F 16r583E 16r9F10 16r583F 16r4E5C 16r5840 16r4E69 16r5841 16r4E93 16r5842 16r8288 16r5843 16r5B5B 16r5844 16r556C 16r5845 16r560F 16r5846 16r4EC4 16r5847 16r538D 16r5848 16r539D 16r5849 16r53A3 16r584A 16r53A5 16r584B 16r53AE 16r584C 16r9765 16r584D 16r8D5D 16r584E 16r531A 16r584F 16r53F5 16r5850 16r5326 16r5851 16r532E 16r5852 16r533E 16r5853 16r8D5C 16r5854 16r5366 16r5855 16r5363 16r5856 16r5202 16r5857 16r5208 16r5858 16r520E 16r5859 16r522D 16r585A 16r5233 16r585B 16r523F 16r585C 16r5240 16r585D 16r524C 16r585E 16r525E 16r585F 16r5261 16r5860 16r525C 16r5861 16r84AF 16r5862 16r527D 16r5863 16r5282 16r5864 16r5281 16r5865 16r5290 16r5866 16r5293 16r5867 16r5182 16r5868 16r7F54 16r5869 16r4EBB 16r586A 16r4EC3 16r586B 16r4EC9 16r586C 16r4EC2 16r586D 16r4EE8 16r586E 16r4EE1 16r586F 16r4EEB 16r5870 16r4EDE 16r5871 16r4F1B 16r5872 16r4EF3 16r5873 16r4F22 16r5874 16r4F64 16r5875 16r4EF5 16r5876 16r4F25 16r5877 16r4F27 16r5878 16r4F09 16r5879 16r4F2B 16r587A 16r4F5E 16r587B 16r4F67 16r587C 16r6538 16r587D 16r4F5A 16r587E 16r4F5D 16r5921 16r4F5F 16r5922 16r4F57 16r5923 16r4F32 16r5924 16r4F3D 16r5925 16r4F76 16r5926 16r4F74 16r5927 16r4F91 16r5928 16r4F89 16r5929 16r4F83 16r592A 16r4F8F 16r592B 16r4F7E 16r592C 16r4F7B 16r592D 16r4FAA 16r592E 16r4F7C 16r592F 16r4FAC 16r5930 16r4F94 16r5931 16r4FE6 16r5932 16r4FE8 16r5933 16r4FEA 16r5934 16r4FC5 16r5935 16r4FDA 16r5936 16r4FE3 16r5937 16r4FDC 16r5938 16r4FD1 16r5939 16r4FDF 16r593A 16r4FF8 16r593B 16r5029 16r593C 16r504C 16r593D 16r4FF3 16r593E 16r502C 16r593F 16r500F 16r5940 16r502E 16r5941 16r502D 16r5942 16r4FFE 16r5943 16r501C 16r5944 16r500C 16r5945 16r5025 16r5946 16r5028 16r5947 16r507E 16r5948 16r5043 16r5949 16r5055 16r594A 16r5048 16r594B 16r504E 16r594C 16r506C 16r594D 16r507B 16r594E 16r50A5 16r594F 16r50A7 16r5950 16r50A9 16r5951 16r50BA 16r5952 16r50D6 16r5953 16r5106 16r5954 16r50ED 16r5955 16r50EC 16r5956 16r50E6 16r5957 16r50EE 16r5958 16r5107 16r5959 16r510B 16r595A 16r4EDD 16r595B 16r6C3D 16r595C 16r4F58 16r595D 16r4F65 16r595E 16r4FCE 16r595F 16r9FA0 16r5960 16r6C46 16r5961 16r7C74 16r5962 16r516E 16r5963 16r5DFD 16r5964 16r9EC9 16r5965 16r9998 16r5966 16r5181 16r5967 16r5914 16r5968 16r52F9 16r5969 16r530D 16r596A 16r8A07 16r596B 16r5310 16r596C 16r51EB 16r596D 16r5919 16r596E 16r5155 16r596F 16r4EA0 16r5970 16r5156 16r5971 16r4EB3 16r5972 16r886E 16r5973 16r88A4 16r5974 16r4EB5 16r5975 16r8114 16r5976 16r88D2 16r5977 16r7980 16r5978 16r5B34 16r5979 16r8803 16r597A 16r7FB8 16r597B 16r51AB 16r597C 16r51B1 16r597D 16r51BD 16r597E 16r51BC 16r5A21 16r51C7 16r5A22 16r5196 16r5A23 16r51A2 16r5A24 16r51A5 16r5A25 16r8BA0 16r5A26 16r8BA6 16r5A27 16r8BA7 16r5A28 16r8BAA 16r5A29 16r8BB4 16r5A2A 16r8BB5 16r5A2B 16r8BB7 16r5A2C 16r8BC2 16r5A2D 16r8BC3 16r5A2E 16r8BCB 16r5A2F 16r8BCF 16r5A30 16r8BCE 16r5A31 16r8BD2 16r5A32 16r8BD3 16r5A33 16r8BD4 16r5A34 16r8BD6 16r5A35 16r8BD8 16r5A36 16r8BD9 16r5A37 16r8BDC 16r5A38 16r8BDF 16r5A39 16r8BE0 16r5A3A 16r8BE4 16r5A3B 16r8BE8 16r5A3C 16r8BE9 16r5A3D 16r8BEE 16r5A3E 16r8BF0 16r5A3F 16r8BF3 16r5A40 16r8BF6 16r5A41 16r8BF9 16r5A42 16r8BFC 16r5A43 16r8BFF 16r5A44 16r8C00 16r5A45 16r8C02 16r5A46 16r8C04 16r5A47 16r8C07 16r5A48 16r8C0C 16r5A49 16r8C0F 16r5A4A 16r8C11 16r5A4B 16r8C12 16r5A4C 16r8C14 16r5A4D 16r8C15 16r5A4E 16r8C16 16r5A4F 16r8C19 16r5A50 16r8C1B 16r5A51 16r8C18 16r5A52 16r8C1D 16r5A53 16r8C1F 16r5A54 16r8C20 16r5A55 16r8C21 16r5A56 16r8C25 16r5A57 16r8C27 16r5A58 16r8C2A 16r5A59 16r8C2B 16r5A5A 16r8C2E 16r5A5B 16r8C2F 16r5A5C 16r8C32 16r5A5D 16r8C33 16r5A5E 16r8C35 16r5A5F 16r8C36 16r5A60 16r5369 16r5A61 16r537A 16r5A62 16r961D 16r5A63 16r9622 16r5A64 16r9621 16r5A65 16r9631 16r5A66 16r962A 16r5A67 16r963D 16r5A68 16r963C 16r5A69 16r9642 16r5A6A 16r9649 16r5A6B 16r9654 16r5A6C 16r965F 16r5A6D 16r9667 16r5A6E 16r966C 16r5A6F 16r9672 16r5A70 16r9674 16r5A71 16r9688 16r5A72 16r968D 16r5A73 16r9697 16r5A74 16r96B0 16r5A75 16r9097 16r5A76 16r909B 16r5A77 16r909D 16r5A78 16r9099 16r5A79 16r90AC 16r5A7A 16r90A1 16r5A7B 16r90B4 16r5A7C 16r90B3 16r5A7D 16r90B6 16r5A7E 16r90BA 16r5B21 16r90B8 16r5B22 16r90B0 16r5B23 16r90CF 16r5B24 16r90C5 16r5B25 16r90BE 16r5B26 16r90D0 16r5B27 16r90C4 16r5B28 16r90C7 16r5B29 16r90D3 16r5B2A 16r90E6 16r5B2B 16r90E2 16r5B2C 16r90DC 16r5B2D 16r90D7 16r5B2E 16r90DB 16r5B2F 16r90EB 16r5B30 16r90EF 16r5B31 16r90FE 16r5B32 16r9104 16r5B33 16r9122 16r5B34 16r911E 16r5B35 16r9123 16r5B36 16r9131 16r5B37 16r912F 16r5B38 16r9139 16r5B39 16r9143 16r5B3A 16r9146 16r5B3B 16r520D 16r5B3C 16r5942 16r5B3D 16r52A2 16r5B3E 16r52AC 16r5B3F 16r52AD 16r5B40 16r52BE 16r5B41 16r54FF 16r5B42 16r52D0 16r5B43 16r52D6 16r5B44 16r52F0 16r5B45 16r53DF 16r5B46 16r71EE 16r5B47 16r77CD 16r5B48 16r5EF4 16r5B49 16r51F5 16r5B4A 16r51FC 16r5B4B 16r9B2F 16r5B4C 16r53B6 16r5B4D 16r5F01 16r5B4E 16r755A 16r5B4F 16r5DEF 16r5B50 16r574C 16r5B51 16r57A9 16r5B52 16r57A1 16r5B53 16r587E 16r5B54 16r58BC 16r5B55 16r58C5 16r5B56 16r58D1 16r5B57 16r5729 16r5B58 16r572C 16r5B59 16r572A 16r5B5A 16r5733 16r5B5B 16r5739 16r5B5C 16r572E 16r5B5D 16r572F 16r5B5E 16r575C 16r5B5F 16r573B 16r5B60 16r5742 16r5B61 16r5769 16r5B62 16r5785 16r5B63 16r576B 16r5B64 16r5786 16r5B65 16r577C 16r5B66 16r577B 16r5B67 16r5768 16r5B68 16r576D 16r5B69 16r5776 16r5B6A 16r5773 16r5B6B 16r57AD 16r5B6C 16r57A4 16r5B6D 16r578C 16r5B6E 16r57B2 16r5B6F 16r57CF 16r5B70 16r57A7 16r5B71 16r57B4 16r5B72 16r5793 16r5B73 16r57A0 16r5B74 16r57D5 16r5B75 16r57D8 16r5B76 16r57DA 16r5B77 16r57D9 16r5B78 16r57D2 16r5B79 16r57B8 16r5B7A 16r57F4 16r5B7B 16r57EF 16r5B7C 16r57F8 16r5B7D 16r57E4 16r5B7E 16r57DD 16r5C21 16r580B 16r5C22 16r580D 16r5C23 16r57FD 16r5C24 16r57ED 16r5C25 16r5800 16r5C26 16r581E 16r5C27 16r5819 16r5C28 16r5844 16r5C29 16r5820 16r5C2A 16r5865 16r5C2B 16r586C 16r5C2C 16r5881 16r5C2D 16r5889 16r5C2E 16r589A 16r5C2F 16r5880 16r5C30 16r99A8 16r5C31 16r9F19 16r5C32 16r61FF 16r5C33 16r8279 16r5C34 16r827D 16r5C35 16r827F 16r5C36 16r828F 16r5C37 16r828A 16r5C38 16r82A8 16r5C39 16r8284 16r5C3A 16r828E 16r5C3B 16r8291 16r5C3C 16r8297 16r5C3D 16r8299 16r5C3E 16r82AB 16r5C3F 16r82B8 16r5C40 16r82BE 16r5C41 16r82B0 16r5C42 16r82C8 16r5C43 16r82CA 16r5C44 16r82E3 16r5C45 16r8298 16r5C46 16r82B7 16r5C47 16r82AE 16r5C48 16r82CB 16r5C49 16r82CC 16r5C4A 16r82C1 16r5C4B 16r82A9 16r5C4C 16r82B4 16r5C4D 16r82A1 16r5C4E 16r82AA 16r5C4F 16r829F 16r5C50 16r82C4 16r5C51 16r82CE 16r5C52 16r82A4 16r5C53 16r82E1 16r5C54 16r8309 16r5C55 16r82F7 16r5C56 16r82E4 16r5C57 16r830F 16r5C58 16r8307 16r5C59 16r82DC 16r5C5A 16r82F4 16r5C5B 16r82D2 16r5C5C 16r82D8 16r5C5D 16r830C 16r5C5E 16r82FB 16r5C5F 16r82D3 16r5C60 16r8311 16r5C61 16r831A 16r5C62 16r8306 16r5C63 16r8314 16r5C64 16r8315 16r5C65 16r82E0 16r5C66 16r82D5 16r5C67 16r831C 16r5C68 16r8351 16r5C69 16r835B 16r5C6A 16r835C 16r5C6B 16r8308 16r5C6C 16r8392 16r5C6D 16r833C 16r5C6E 16r8334 16r5C6F 16r8331 16r5C70 16r839B 16r5C71 16r835E 16r5C72 16r832F 16r5C73 16r834F 16r5C74 16r8347 16r5C75 16r8343 16r5C76 16r835F 16r5C77 16r8340 16r5C78 16r8317 16r5C79 16r8360 16r5C7A 16r832D 16r5C7B 16r833A 16r5C7C 16r8333 16r5C7D 16r8366 16r5C7E 16r8365 16r5D21 16r8368 16r5D22 16r831B 16r5D23 16r8369 16r5D24 16r836C 16r5D25 16r836A 16r5D26 16r836D 16r5D27 16r836E 16r5D28 16r83B0 16r5D29 16r8378 16r5D2A 16r83B3 16r5D2B 16r83B4 16r5D2C 16r83A0 16r5D2D 16r83AA 16r5D2E 16r8393 16r5D2F 16r839C 16r5D30 16r8385 16r5D31 16r837C 16r5D32 16r83B6 16r5D33 16r83A9 16r5D34 16r837D 16r5D35 16r83B8 16r5D36 16r837B 16r5D37 16r8398 16r5D38 16r839E 16r5D39 16r83A8 16r5D3A 16r83BA 16r5D3B 16r83BC 16r5D3C 16r83C1 16r5D3D 16r8401 16r5D3E 16r83E5 16r5D3F 16r83D8 16r5D40 16r5807 16r5D41 16r8418 16r5D42 16r840B 16r5D43 16r83DD 16r5D44 16r83FD 16r5D45 16r83D6 16r5D46 16r841C 16r5D47 16r8438 16r5D48 16r8411 16r5D49 16r8406 16r5D4A 16r83D4 16r5D4B 16r83DF 16r5D4C 16r840F 16r5D4D 16r8403 16r5D4E 16r83F8 16r5D4F 16r83F9 16r5D50 16r83EA 16r5D51 16r83C5 16r5D52 16r83C0 16r5D53 16r8426 16r5D54 16r83F0 16r5D55 16r83E1 16r5D56 16r845C 16r5D57 16r8451 16r5D58 16r845A 16r5D59 16r8459 16r5D5A 16r8473 16r5D5B 16r8487 16r5D5C 16r8488 16r5D5D 16r847A 16r5D5E 16r8489 16r5D5F 16r8478 16r5D60 16r843C 16r5D61 16r8446 16r5D62 16r8469 16r5D63 16r8476 16r5D64 16r848C 16r5D65 16r848E 16r5D66 16r8431 16r5D67 16r846D 16r5D68 16r84C1 16r5D69 16r84CD 16r5D6A 16r84D0 16r5D6B 16r84E6 16r5D6C 16r84BD 16r5D6D 16r84D3 16r5D6E 16r84CA 16r5D6F 16r84BF 16r5D70 16r84BA 16r5D71 16r84E0 16r5D72 16r84A1 16r5D73 16r84B9 16r5D74 16r84B4 16r5D75 16r8497 16r5D76 16r84E5 16r5D77 16r84E3 16r5D78 16r850C 16r5D79 16r750D 16r5D7A 16r8538 16r5D7B 16r84F0 16r5D7C 16r8539 16r5D7D 16r851F 16r5D7E 16r853A 16r5E21 16r8556 16r5E22 16r853B 16r5E23 16r84FF 16r5E24 16r84FC 16r5E25 16r8559 16r5E26 16r8548 16r5E27 16r8568 16r5E28 16r8564 16r5E29 16r855E 16r5E2A 16r857A 16r5E2B 16r77A2 16r5E2C 16r8543 16r5E2D 16r8572 16r5E2E 16r857B 16r5E2F 16r85A4 16r5E30 16r85A8 16r5E31 16r8587 16r5E32 16r858F 16r5E33 16r8579 16r5E34 16r85AE 16r5E35 16r859C 16r5E36 16r8585 16r5E37 16r85B9 16r5E38 16r85B7 16r5E39 16r85B0 16r5E3A 16r85D3 16r5E3B 16r85C1 16r5E3C 16r85DC 16r5E3D 16r85FF 16r5E3E 16r8627 16r5E3F 16r8605 16r5E40 16r8629 16r5E41 16r8616 16r5E42 16r863C 16r5E43 16r5EFE 16r5E44 16r5F08 16r5E45 16r593C 16r5E46 16r5941 16r5E47 16r8037 16r5E48 16r5955 16r5E49 16r595A 16r5E4A 16r5958 16r5E4B 16r530F 16r5E4C 16r5C22 16r5E4D 16r5C25 16r5E4E 16r5C2C 16r5E4F 16r5C34 16r5E50 16r624C 16r5E51 16r626A 16r5E52 16r629F 16r5E53 16r62BB 16r5E54 16r62CA 16r5E55 16r62DA 16r5E56 16r62D7 16r5E57 16r62EE 16r5E58 16r6322 16r5E59 16r62F6 16r5E5A 16r6339 16r5E5B 16r634B 16r5E5C 16r6343 16r5E5D 16r63AD 16r5E5E 16r63F6 16r5E5F 16r6371 16r5E60 16r637A 16r5E61 16r638E 16r5E62 16r63B4 16r5E63 16r636D 16r5E64 16r63AC 16r5E65 16r638A 16r5E66 16r6369 16r5E67 16r63AE 16r5E68 16r63BC 16r5E69 16r63F2 16r5E6A 16r63F8 16r5E6B 16r63E0 16r5E6C 16r63FF 16r5E6D 16r63C4 16r5E6E 16r63DE 16r5E6F 16r63CE 16r5E70 16r6452 16r5E71 16r63C6 16r5E72 16r63BE 16r5E73 16r6445 16r5E74 16r6441 16r5E75 16r640B 16r5E76 16r641B 16r5E77 16r6420 16r5E78 16r640C 16r5E79 16r6426 16r5E7A 16r6421 16r5E7B 16r645E 16r5E7C 16r6484 16r5E7D 16r646D 16r5E7E 16r6496 16r5F21 16r647A 16r5F22 16r64B7 16r5F23 16r64B8 16r5F24 16r6499 16r5F25 16r64BA 16r5F26 16r64C0 16r5F27 16r64D0 16r5F28 16r64D7 16r5F29 16r64E4 16r5F2A 16r64E2 16r5F2B 16r6509 16r5F2C 16r6525 16r5F2D 16r652E 16r5F2E 16r5F0B 16r5F2F 16r5FD2 16r5F30 16r7519 16r5F31 16r5F11 16r5F32 16r535F 16r5F33 16r53F1 16r5F34 16r53FD 16r5F35 16r53E9 16r5F36 16r53E8 16r5F37 16r53FB 16r5F38 16r5412 16r5F39 16r5416 16r5F3A 16r5406 16r5F3B 16r544B 16r5F3C 16r5452 16r5F3D 16r5453 16r5F3E 16r5454 16r5F3F 16r5456 16r5F40 16r5443 16r5F41 16r5421 16r5F42 16r5457 16r5F43 16r5459 16r5F44 16r5423 16r5F45 16r5432 16r5F46 16r5482 16r5F47 16r5494 16r5F48 16r5477 16r5F49 16r5471 16r5F4A 16r5464 16r5F4B 16r549A 16r5F4C 16r549B 16r5F4D 16r5484 16r5F4E 16r5476 16r5F4F 16r5466 16r5F50 16r549D 16r5F51 16r54D0 16r5F52 16r54AD 16r5F53 16r54C2 16r5F54 16r54B4 16r5F55 16r54D2 16r5F56 16r54A7 16r5F57 16r54A6 16r5F58 16r54D3 16r5F59 16r54D4 16r5F5A 16r5472 16r5F5B 16r54A3 16r5F5C 16r54D5 16r5F5D 16r54BB 16r5F5E 16r54BF 16r5F5F 16r54CC 16r5F60 16r54D9 16r5F61 16r54DA 16r5F62 16r54DC 16r5F63 16r54A9 16r5F64 16r54AA 16r5F65 16r54A4 16r5F66 16r54DD 16r5F67 16r54CF 16r5F68 16r54DE 16r5F69 16r551B 16r5F6A 16r54E7 16r5F6B 16r5520 16r5F6C 16r54FD 16r5F6D 16r5514 16r5F6E 16r54F3 16r5F6F 16r5522 16r5F70 16r5523 16r5F71 16r550F 16r5F72 16r5511 16r5F73 16r5527 16r5F74 16r552A 16r5F75 16r5567 16r5F76 16r558F 16r5F77 16r55B5 16r5F78 16r5549 16r5F79 16r556D 16r5F7A 16r5541 16r5F7B 16r5555 16r5F7C 16r553F 16r5F7D 16r5550 16r5F7E 16r553C 16r6021 16r5537 16r6022 16r5556 16r6023 16r5575 16r6024 16r5576 16r6025 16r5577 16r6026 16r5533 16r6027 16r5530 16r6028 16r555C 16r6029 16r558B 16r602A 16r55D2 16r602B 16r5583 16r602C 16r55B1 16r602D 16r55B9 16r602E 16r5588 16r602F 16r5581 16r6030 16r559F 16r6031 16r557E 16r6032 16r55D6 16r6033 16r5591 16r6034 16r557B 16r6035 16r55DF 16r6036 16r55BD 16r6037 16r55BE 16r6038 16r5594 16r6039 16r5599 16r603A 16r55EA 16r603B 16r55F7 16r603C 16r55C9 16r603D 16r561F 16r603E 16r55D1 16r603F 16r55EB 16r6040 16r55EC 16r6041 16r55D4 16r6042 16r55E6 16r6043 16r55DD 16r6044 16r55C4 16r6045 16r55EF 16r6046 16r55E5 16r6047 16r55F2 16r6048 16r55F3 16r6049 16r55CC 16r604A 16r55CD 16r604B 16r55E8 16r604C 16r55F5 16r604D 16r55E4 16r604E 16r8F94 16r604F 16r561E 16r6050 16r5608 16r6051 16r560C 16r6052 16r5601 16r6053 16r5624 16r6054 16r5623 16r6055 16r55FE 16r6056 16r5600 16r6057 16r5627 16r6058 16r562D 16r6059 16r5658 16r605A 16r5639 16r605B 16r5657 16r605C 16r562C 16r605D 16r564D 16r605E 16r5662 16r605F 16r5659 16r6060 16r565C 16r6061 16r564C 16r6062 16r5654 16r6063 16r5686 16r6064 16r5664 16r6065 16r5671 16r6066 16r566B 16r6067 16r567B 16r6068 16r567C 16r6069 16r5685 16r606A 16r5693 16r606B 16r56AF 16r606C 16r56D4 16r606D 16r56D7 16r606E 16r56DD 16r606F 16r56E1 16r6070 16r56F5 16r6071 16r56EB 16r6072 16r56F9 16r6073 16r56FF 16r6074 16r5704 16r6075 16r570A 16r6076 16r5709 16r6077 16r571C 16r6078 16r5E0F 16r6079 16r5E19 16r607A 16r5E14 16r607B 16r5E11 16r607C 16r5E31 16r607D 16r5E3B 16r607E 16r5E3C 16r6121 16r5E37 16r6122 16r5E44 16r6123 16r5E54 16r6124 16r5E5B 16r6125 16r5E5E 16r6126 16r5E61 16r6127 16r5C8C 16r6128 16r5C7A 16r6129 16r5C8D 16r612A 16r5C90 16r612B 16r5C96 16r612C 16r5C88 16r612D 16r5C98 16r612E 16r5C99 16r612F 16r5C91 16r6130 16r5C9A 16r6131 16r5C9C 16r6132 16r5CB5 16r6133 16r5CA2 16r6134 16r5CBD 16r6135 16r5CAC 16r6136 16r5CAB 16r6137 16r5CB1 16r6138 16r5CA3 16r6139 16r5CC1 16r613A 16r5CB7 16r613B 16r5CC4 16r613C 16r5CD2 16r613D 16r5CE4 16r613E 16r5CCB 16r613F 16r5CE5 16r6140 16r5D02 16r6141 16r5D03 16r6142 16r5D27 16r6143 16r5D26 16r6144 16r5D2E 16r6145 16r5D24 16r6146 16r5D1E 16r6147 16r5D06 16r6148 16r5D1B 16r6149 16r5D58 16r614A 16r5D3E 16r614B 16r5D34 16r614C 16r5D3D 16r614D 16r5D6C 16r614E 16r5D5B 16r614F 16r5D6F 16r6150 16r5D5D 16r6151 16r5D6B 16r6152 16r5D4B 16r6153 16r5D4A 16r6154 16r5D69 16r6155 16r5D74 16r6156 16r5D82 16r6157 16r5D99 16r6158 16r5D9D 16r6159 16r8C73 16r615A 16r5DB7 16r615B 16r5DC5 16r615C 16r5F73 16r615D 16r5F77 16r615E 16r5F82 16r615F 16r5F87 16r6160 16r5F89 16r6161 16r5F8C 16r6162 16r5F95 16r6163 16r5F99 16r6164 16r5F9C 16r6165 16r5FA8 16r6166 16r5FAD 16r6167 16r5FB5 16r6168 16r5FBC 16r6169 16r8862 16r616A 16r5F61 16r616B 16r72AD 16r616C 16r72B0 16r616D 16r72B4 16r616E 16r72B7 16r616F 16r72B8 16r6170 16r72C3 16r6171 16r72C1 16r6172 16r72CE 16r6173 16r72CD 16r6174 16r72D2 16r6175 16r72E8 16r6176 16r72EF 16r6177 16r72E9 16r6178 16r72F2 16r6179 16r72F4 16r617A 16r72F7 16r617B 16r7301 16r617C 16r72F3 16r617D 16r7303 16r617E 16r72FA 16r6221 16r72FB 16r6222 16r7317 16r6223 16r7313 16r6224 16r7321 16r6225 16r730A 16r6226 16r731E 16r6227 16r731D 16r6228 16r7315 16r6229 16r7322 16r622A 16r7339 16r622B 16r7325 16r622C 16r732C 16r622D 16r7338 16r622E 16r7331 16r622F 16r7350 16r6230 16r734D 16r6231 16r7357 16r6232 16r7360 16r6233 16r736C 16r6234 16r736F 16r6235 16r737E 16r6236 16r821B 16r6237 16r5925 16r6238 16r98E7 16r6239 16r5924 16r623A 16r5902 16r623B 16r9963 16r623C 16r9967 16r623D 16r9968 16r623E 16r9969 16r623F 16r996A 16r6240 16r996B 16r6241 16r996C 16r6242 16r9974 16r6243 16r9977 16r6244 16r997D 16r6245 16r9980 16r6246 16r9984 16r6247 16r9987 16r6248 16r998A 16r6249 16r998D 16r624A 16r9990 16r624B 16r9991 16r624C 16r9993 16r624D 16r9994 16r624E 16r9995 16r624F 16r5E80 16r6250 16r5E91 16r6251 16r5E8B 16r6252 16r5E96 16r6253 16r5EA5 16r6254 16r5EA0 16r6255 16r5EB9 16r6256 16r5EB5 16r6257 16r5EBE 16r6258 16r5EB3 16r6259 16r8D53 16r625A 16r5ED2 16r625B 16r5ED1 16r625C 16r5EDB 16r625D 16r5EE8 16r625E 16r5EEA 16r625F 16r81BA 16r6260 16r5FC4 16r6261 16r5FC9 16r6262 16r5FD6 16r6263 16r5FCF 16r6264 16r6003 16r6265 16r5FEE 16r6266 16r6004 16r6267 16r5FE1 16r6268 16r5FE4 16r6269 16r5FFE 16r626A 16r6005 16r626B 16r6006 16r626C 16r5FEA 16r626D 16r5FED 16r626E 16r5FF8 16r626F 16r6019 16r6270 16r6035 16r6271 16r6026 16r6272 16r601B 16r6273 16r600F 16r6274 16r600D 16r6275 16r6029 16r6276 16r602B 16r6277 16r600A 16r6278 16r603F 16r6279 16r6021 16r627A 16r6078 16r627B 16r6079 16r627C 16r607B 16r627D 16r607A 16r627E 16r6042 16r6321 16r606A 16r6322 16r607D 16r6323 16r6096 16r6324 16r609A 16r6325 16r60AD 16r6326 16r609D 16r6327 16r6083 16r6328 16r6092 16r6329 16r608C 16r632A 16r609B 16r632B 16r60EC 16r632C 16r60BB 16r632D 16r60B1 16r632E 16r60DD 16r632F 16r60D8 16r6330 16r60C6 16r6331 16r60DA 16r6332 16r60B4 16r6333 16r6120 16r6334 16r6126 16r6335 16r6115 16r6336 16r6123 16r6337 16r60F4 16r6338 16r6100 16r6339 16r610E 16r633A 16r612B 16r633B 16r614A 16r633C 16r6175 16r633D 16r61AC 16r633E 16r6194 16r633F 16r61A7 16r6340 16r61B7 16r6341 16r61D4 16r6342 16r61F5 16r6343 16r5FDD 16r6344 16r96B3 16r6345 16r95E9 16r6346 16r95EB 16r6347 16r95F1 16r6348 16r95F3 16r6349 16r95F5 16r634A 16r95F6 16r634B 16r95FC 16r634C 16r95FE 16r634D 16r9603 16r634E 16r9604 16r634F 16r9606 16r6350 16r9608 16r6351 16r960A 16r6352 16r960B 16r6353 16r960C 16r6354 16r960D 16r6355 16r960F 16r6356 16r9612 16r6357 16r9615 16r6358 16r9616 16r6359 16r9617 16r635A 16r9619 16r635B 16r961A 16r635C 16r4E2C 16r635D 16r723F 16r635E 16r6215 16r635F 16r6C35 16r6360 16r6C54 16r6361 16r6C5C 16r6362 16r6C4A 16r6363 16r6CA3 16r6364 16r6C85 16r6365 16r6C90 16r6366 16r6C94 16r6367 16r6C8C 16r6368 16r6C68 16r6369 16r6C69 16r636A 16r6C74 16r636B 16r6C76 16r636C 16r6C86 16r636D 16r6CA9 16r636E 16r6CD0 16r636F 16r6CD4 16r6370 16r6CAD 16r6371 16r6CF7 16r6372 16r6CF8 16r6373 16r6CF1 16r6374 16r6CD7 16r6375 16r6CB2 16r6376 16r6CE0 16r6377 16r6CD6 16r6378 16r6CFA 16r6379 16r6CEB 16r637A 16r6CEE 16r637B 16r6CB1 16r637C 16r6CD3 16r637D 16r6CEF 16r637E 16r6CFE 16r6421 16r6D39 16r6422 16r6D27 16r6423 16r6D0C 16r6424 16r6D43 16r6425 16r6D48 16r6426 16r6D07 16r6427 16r6D04 16r6428 16r6D19 16r6429 16r6D0E 16r642A 16r6D2B 16r642B 16r6D4D 16r642C 16r6D2E 16r642D 16r6D35 16r642E 16r6D1A 16r642F 16r6D4F 16r6430 16r6D52 16r6431 16r6D54 16r6432 16r6D33 16r6433 16r6D91 16r6434 16r6D6F 16r6435 16r6D9E 16r6436 16r6DA0 16r6437 16r6D5E 16r6438 16r6D93 16r6439 16r6D94 16r643A 16r6D5C 16r643B 16r6D60 16r643C 16r6D7C 16r643D 16r6D63 16r643E 16r6E1A 16r643F 16r6DC7 16r6440 16r6DC5 16r6441 16r6DDE 16r6442 16r6E0E 16r6443 16r6DBF 16r6444 16r6DE0 16r6445 16r6E11 16r6446 16r6DE6 16r6447 16r6DDD 16r6448 16r6DD9 16r6449 16r6E16 16r644A 16r6DAB 16r644B 16r6E0C 16r644C 16r6DAE 16r644D 16r6E2B 16r644E 16r6E6E 16r644F 16r6E4E 16r6450 16r6E6B 16r6451 16r6EB2 16r6452 16r6E5F 16r6453 16r6E86 16r6454 16r6E53 16r6455 16r6E54 16r6456 16r6E32 16r6457 16r6E25 16r6458 16r6E44 16r6459 16r6EDF 16r645A 16r6EB1 16r645B 16r6E98 16r645C 16r6EE0 16r645D 16r6F2D 16r645E 16r6EE2 16r645F 16r6EA5 16r6460 16r6EA7 16r6461 16r6EBD 16r6462 16r6EBB 16r6463 16r6EB7 16r6464 16r6ED7 16r6465 16r6EB4 16r6466 16r6ECF 16r6467 16r6E8F 16r6468 16r6EC2 16r6469 16r6E9F 16r646A 16r6F62 16r646B 16r6F46 16r646C 16r6F47 16r646D 16r6F24 16r646E 16r6F15 16r646F 16r6EF9 16r6470 16r6F2F 16r6471 16r6F36 16r6472 16r6F4B 16r6473 16r6F74 16r6474 16r6F2A 16r6475 16r6F09 16r6476 16r6F29 16r6477 16r6F89 16r6478 16r6F8D 16r6479 16r6F8C 16r647A 16r6F78 16r647B 16r6F72 16r647C 16r6F7C 16r647D 16r6F7A 16r647E 16r6FD1 16r6521 16r6FC9 16r6522 16r6FA7 16r6523 16r6FB9 16r6524 16r6FB6 16r6525 16r6FC2 16r6526 16r6FE1 16r6527 16r6FEE 16r6528 16r6FDE 16r6529 16r6FE0 16r652A 16r6FEF 16r652B 16r701A 16r652C 16r7023 16r652D 16r701B 16r652E 16r7039 16r652F 16r7035 16r6530 16r704F 16r6531 16r705E 16r6532 16r5B80 16r6533 16r5B84 16r6534 16r5B95 16r6535 16r5B93 16r6536 16r5BA5 16r6537 16r5BB8 16r6538 16r752F 16r6539 16r9A9E 16r653A 16r6434 16r653B 16r5BE4 16r653C 16r5BEE 16r653D 16r8930 16r653E 16r5BF0 16r653F 16r8E47 16r6540 16r8B07 16r6541 16r8FB6 16r6542 16r8FD3 16r6543 16r8FD5 16r6544 16r8FE5 16r6545 16r8FEE 16r6546 16r8FE4 16r6547 16r8FE9 16r6548 16r8FE6 16r6549 16r8FF3 16r654A 16r8FE8 16r654B 16r9005 16r654C 16r9004 16r654D 16r900B 16r654E 16r9026 16r654F 16r9011 16r6550 16r900D 16r6551 16r9016 16r6552 16r9021 16r6553 16r9035 16r6554 16r9036 16r6555 16r902D 16r6556 16r902F 16r6557 16r9044 16r6558 16r9051 16r6559 16r9052 16r655A 16r9050 16r655B 16r9068 16r655C 16r9058 16r655D 16r9062 16r655E 16r905B 16r655F 16r66B9 16r6560 16r9074 16r6561 16r907D 16r6562 16r9082 16r6563 16r9088 16r6564 16r9083 16r6565 16r908B 16r6566 16r5F50 16r6567 16r5F57 16r6568 16r5F56 16r6569 16r5F58 16r656A 16r5C3B 16r656B 16r54AB 16r656C 16r5C50 16r656D 16r5C59 16r656E 16r5B71 16r656F 16r5C63 16r6570 16r5C66 16r6571 16r7FBC 16r6572 16r5F2A 16r6573 16r5F29 16r6574 16r5F2D 16r6575 16r8274 16r6576 16r5F3C 16r6577 16r9B3B 16r6578 16r5C6E 16r6579 16r5981 16r657A 16r5983 16r657B 16r598D 16r657C 16r59A9 16r657D 16r59AA 16r657E 16r59A3 16r6621 16r5997 16r6622 16r59CA 16r6623 16r59AB 16r6624 16r599E 16r6625 16r59A4 16r6626 16r59D2 16r6627 16r59B2 16r6628 16r59AF 16r6629 16r59D7 16r662A 16r59BE 16r662B 16r5A05 16r662C 16r5A06 16r662D 16r59DD 16r662E 16r5A08 16r662F 16r59E3 16r6630 16r59D8 16r6631 16r59F9 16r6632 16r5A0C 16r6633 16r5A09 16r6634 16r5A32 16r6635 16r5A34 16r6636 16r5A11 16r6637 16r5A23 16r6638 16r5A13 16r6639 16r5A40 16r663A 16r5A67 16r663B 16r5A4A 16r663C 16r5A55 16r663D 16r5A3C 16r663E 16r5A62 16r663F 16r5A75 16r6640 16r80EC 16r6641 16r5AAA 16r6642 16r5A9B 16r6643 16r5A77 16r6644 16r5A7A 16r6645 16r5ABE 16r6646 16r5AEB 16r6647 16r5AB2 16r6648 16r5AD2 16r6649 16r5AD4 16r664A 16r5AB8 16r664B 16r5AE0 16r664C 16r5AE3 16r664D 16r5AF1 16r664E 16r5AD6 16r664F 16r5AE6 16r6650 16r5AD8 16r6651 16r5ADC 16r6652 16r5B09 16r6653 16r5B17 16r6654 16r5B16 16r6655 16r5B32 16r6656 16r5B37 16r6657 16r5B40 16r6658 16r5C15 16r6659 16r5C1C 16r665A 16r5B5A 16r665B 16r5B65 16r665C 16r5B73 16r665D 16r5B51 16r665E 16r5B53 16r665F 16r5B62 16r6660 16r9A75 16r6661 16r9A77 16r6662 16r9A78 16r6663 16r9A7A 16r6664 16r9A7F 16r6665 16r9A7D 16r6666 16r9A80 16r6667 16r9A81 16r6668 16r9A85 16r6669 16r9A88 16r666A 16r9A8A 16r666B 16r9A90 16r666C 16r9A92 16r666D 16r9A93 16r666E 16r9A96 16r666F 16r9A98 16r6670 16r9A9B 16r6671 16r9A9C 16r6672 16r9A9D 16r6673 16r9A9F 16r6674 16r9AA0 16r6675 16r9AA2 16r6676 16r9AA3 16r6677 16r9AA5 16r6678 16r9AA7 16r6679 16r7E9F 16r667A 16r7EA1 16r667B 16r7EA3 16r667C 16r7EA5 16r667D 16r7EA8 16r667E 16r7EA9 16r6721 16r7EAD 16r6722 16r7EB0 16r6723 16r7EBE 16r6724 16r7EC0 16r6725 16r7EC1 16r6726 16r7EC2 16r6727 16r7EC9 16r6728 16r7ECB 16r6729 16r7ECC 16r672A 16r7ED0 16r672B 16r7ED4 16r672C 16r7ED7 16r672D 16r7EDB 16r672E 16r7EE0 16r672F 16r7EE1 16r6730 16r7EE8 16r6731 16r7EEB 16r6732 16r7EEE 16r6733 16r7EEF 16r6734 16r7EF1 16r6735 16r7EF2 16r6736 16r7F0D 16r6737 16r7EF6 16r6738 16r7EFA 16r6739 16r7EFB 16r673A 16r7EFE 16r673B 16r7F01 16r673C 16r7F02 16r673D 16r7F03 16r673E 16r7F07 16r673F 16r7F08 16r6740 16r7F0B 16r6741 16r7F0C 16r6742 16r7F0F 16r6743 16r7F11 16r6744 16r7F12 16r6745 16r7F17 16r6746 16r7F19 16r6747 16r7F1C 16r6748 16r7F1B 16r6749 16r7F1F 16r674A 16r7F21 16r674B 16r7F22 16r674C 16r7F23 16r674D 16r7F24 16r674E 16r7F25 16r674F 16r7F26 16r6750 16r7F27 16r6751 16r7F2A 16r6752 16r7F2B 16r6753 16r7F2C 16r6754 16r7F2D 16r6755 16r7F2F 16r6756 16r7F30 16r6757 16r7F31 16r6758 16r7F32 16r6759 16r7F33 16r675A 16r7F35 16r675B 16r5E7A 16r675C 16r757F 16r675D 16r5DDB 16r675E 16r753E 16r675F 16r9095 16r6760 16r738E 16r6761 16r7391 16r6762 16r73AE 16r6763 16r73A2 16r6764 16r739F 16r6765 16r73CF 16r6766 16r73C2 16r6767 16r73D1 16r6768 16r73B7 16r6769 16r73B3 16r676A 16r73C0 16r676B 16r73C9 16r676C 16r73C8 16r676D 16r73E5 16r676E 16r73D9 16r676F 16r987C 16r6770 16r740A 16r6771 16r73E9 16r6772 16r73E7 16r6773 16r73DE 16r6774 16r73BA 16r6775 16r73F2 16r6776 16r740F 16r6777 16r742A 16r6778 16r745B 16r6779 16r7426 16r677A 16r7425 16r677B 16r7428 16r677C 16r7430 16r677D 16r742E 16r677E 16r742C 16r6821 16r741B 16r6822 16r741A 16r6823 16r7441 16r6824 16r745C 16r6825 16r7457 16r6826 16r7455 16r6827 16r7459 16r6828 16r7477 16r6829 16r746D 16r682A 16r747E 16r682B 16r749C 16r682C 16r748E 16r682D 16r7480 16r682E 16r7481 16r682F 16r7487 16r6830 16r748B 16r6831 16r749E 16r6832 16r74A8 16r6833 16r74A9 16r6834 16r7490 16r6835 16r74A7 16r6836 16r74D2 16r6837 16r74BA 16r6838 16r97EA 16r6839 16r97EB 16r683A 16r97EC 16r683B 16r674C 16r683C 16r6753 16r683D 16r675E 16r683E 16r6748 16r683F 16r6769 16r6840 16r67A5 16r6841 16r6787 16r6842 16r676A 16r6843 16r6773 16r6844 16r6798 16r6845 16r67A7 16r6846 16r6775 16r6847 16r67A8 16r6848 16r679E 16r6849 16r67AD 16r684A 16r678B 16r684B 16r6777 16r684C 16r677C 16r684D 16r67F0 16r684E 16r6809 16r684F 16r67D8 16r6850 16r680A 16r6851 16r67E9 16r6852 16r67B0 16r6853 16r680C 16r6854 16r67D9 16r6855 16r67B5 16r6856 16r67DA 16r6857 16r67B3 16r6858 16r67DD 16r6859 16r6800 16r685A 16r67C3 16r685B 16r67B8 16r685C 16r67E2 16r685D 16r680E 16r685E 16r67C1 16r685F 16r67FD 16r6860 16r6832 16r6861 16r6833 16r6862 16r6860 16r6863 16r6861 16r6864 16r684E 16r6865 16r6862 16r6866 16r6844 16r6867 16r6864 16r6868 16r6883 16r6869 16r681D 16r686A 16r6855 16r686B 16r6866 16r686C 16r6841 16r686D 16r6867 16r686E 16r6840 16r686F 16r683E 16r6870 16r684A 16r6871 16r6849 16r6872 16r6829 16r6873 16r68B5 16r6874 16r688F 16r6875 16r6874 16r6876 16r6877 16r6877 16r6893 16r6878 16r686B 16r6879 16r68C2 16r687A 16r696E 16r687B 16r68FC 16r687C 16r691F 16r687D 16r6920 16r687E 16r68F9 16r6921 16r6924 16r6922 16r68F0 16r6923 16r690B 16r6924 16r6901 16r6925 16r6957 16r6926 16r68E3 16r6927 16r6910 16r6928 16r6971 16r6929 16r6939 16r692A 16r6960 16r692B 16r6942 16r692C 16r695D 16r692D 16r6984 16r692E 16r696B 16r692F 16r6980 16r6930 16r6998 16r6931 16r6978 16r6932 16r6934 16r6933 16r69CC 16r6934 16r6987 16r6935 16r6988 16r6936 16r69CE 16r6937 16r6989 16r6938 16r6966 16r6939 16r6963 16r693A 16r6979 16r693B 16r699B 16r693C 16r69A7 16r693D 16r69BB 16r693E 16r69AB 16r693F 16r69AD 16r6940 16r69D4 16r6941 16r69B1 16r6942 16r69C1 16r6943 16r69CA 16r6944 16r69DF 16r6945 16r6995 16r6946 16r69E0 16r6947 16r698D 16r6948 16r69FF 16r6949 16r6A2F 16r694A 16r69ED 16r694B 16r6A17 16r694C 16r6A18 16r694D 16r6A65 16r694E 16r69F2 16r694F 16r6A44 16r6950 16r6A3E 16r6951 16r6AA0 16r6952 16r6A50 16r6953 16r6A5B 16r6954 16r6A35 16r6955 16r6A8E 16r6956 16r6A79 16r6957 16r6A3D 16r6958 16r6A28 16r6959 16r6A58 16r695A 16r6A7C 16r695B 16r6A91 16r695C 16r6A90 16r695D 16r6AA9 16r695E 16r6A97 16r695F 16r6AAB 16r6960 16r7337 16r6961 16r7352 16r6962 16r6B81 16r6963 16r6B82 16r6964 16r6B87 16r6965 16r6B84 16r6966 16r6B92 16r6967 16r6B93 16r6968 16r6B8D 16r6969 16r6B9A 16r696A 16r6B9B 16r696B 16r6BA1 16r696C 16r6BAA 16r696D 16r8F6B 16r696E 16r8F6D 16r696F 16r8F71 16r6970 16r8F72 16r6971 16r8F73 16r6972 16r8F75 16r6973 16r8F76 16r6974 16r8F78 16r6975 16r8F77 16r6976 16r8F79 16r6977 16r8F7A 16r6978 16r8F7C 16r6979 16r8F7E 16r697A 16r8F81 16r697B 16r8F82 16r697C 16r8F84 16r697D 16r8F87 16r697E 16r8F8B 16r6A21 16r8F8D 16r6A22 16r8F8E 16r6A23 16r8F8F 16r6A24 16r8F98 16r6A25 16r8F9A 16r6A26 16r8ECE 16r6A27 16r620B 16r6A28 16r6217 16r6A29 16r621B 16r6A2A 16r621F 16r6A2B 16r6222 16r6A2C 16r6221 16r6A2D 16r6225 16r6A2E 16r6224 16r6A2F 16r622C 16r6A30 16r81E7 16r6A31 16r74EF 16r6A32 16r74F4 16r6A33 16r74FF 16r6A34 16r750F 16r6A35 16r7511 16r6A36 16r7513 16r6A37 16r6534 16r6A38 16r65EE 16r6A39 16r65EF 16r6A3A 16r65F0 16r6A3B 16r660A 16r6A3C 16r6619 16r6A3D 16r6772 16r6A3E 16r6603 16r6A3F 16r6615 16r6A40 16r6600 16r6A41 16r7085 16r6A42 16r66F7 16r6A43 16r661D 16r6A44 16r6634 16r6A45 16r6631 16r6A46 16r6636 16r6A47 16r6635 16r6A48 16r8006 16r6A49 16r665F 16r6A4A 16r6654 16r6A4B 16r6641 16r6A4C 16r664F 16r6A4D 16r6656 16r6A4E 16r6661 16r6A4F 16r6657 16r6A50 16r6677 16r6A51 16r6684 16r6A52 16r668C 16r6A53 16r66A7 16r6A54 16r669D 16r6A55 16r66BE 16r6A56 16r66DB 16r6A57 16r66DC 16r6A58 16r66E6 16r6A59 16r66E9 16r6A5A 16r8D32 16r6A5B 16r8D33 16r6A5C 16r8D36 16r6A5D 16r8D3B 16r6A5E 16r8D3D 16r6A5F 16r8D40 16r6A60 16r8D45 16r6A61 16r8D46 16r6A62 16r8D48 16r6A63 16r8D49 16r6A64 16r8D47 16r6A65 16r8D4D 16r6A66 16r8D55 16r6A67 16r8D59 16r6A68 16r89C7 16r6A69 16r89CA 16r6A6A 16r89CB 16r6A6B 16r89CC 16r6A6C 16r89CE 16r6A6D 16r89CF 16r6A6E 16r89D0 16r6A6F 16r89D1 16r6A70 16r726E 16r6A71 16r729F 16r6A72 16r725D 16r6A73 16r7266 16r6A74 16r726F 16r6A75 16r727E 16r6A76 16r727F 16r6A77 16r7284 16r6A78 16r728B 16r6A79 16r728D 16r6A7A 16r728F 16r6A7B 16r7292 16r6A7C 16r6308 16r6A7D 16r6332 16r6A7E 16r63B0 16r6B21 16r643F 16r6B22 16r64D8 16r6B23 16r8004 16r6B24 16r6BEA 16r6B25 16r6BF3 16r6B26 16r6BFD 16r6B27 16r6BF5 16r6B28 16r6BF9 16r6B29 16r6C05 16r6B2A 16r6C07 16r6B2B 16r6C06 16r6B2C 16r6C0D 16r6B2D 16r6C15 16r6B2E 16r6C18 16r6B2F 16r6C19 16r6B30 16r6C1A 16r6B31 16r6C21 16r6B32 16r6C29 16r6B33 16r6C24 16r6B34 16r6C2A 16r6B35 16r6C32 16r6B36 16r6535 16r6B37 16r6555 16r6B38 16r656B 16r6B39 16r724D 16r6B3A 16r7252 16r6B3B 16r7256 16r6B3C 16r7230 16r6B3D 16r8662 16r6B3E 16r5216 16r6B3F 16r809F 16r6B40 16r809C 16r6B41 16r8093 16r6B42 16r80BC 16r6B43 16r670A 16r6B44 16r80BD 16r6B45 16r80B1 16r6B46 16r80AB 16r6B47 16r80AD 16r6B48 16r80B4 16r6B49 16r80B7 16r6B4A 16r80E7 16r6B4B 16r80E8 16r6B4C 16r80E9 16r6B4D 16r80EA 16r6B4E 16r80DB 16r6B4F 16r80C2 16r6B50 16r80C4 16r6B51 16r80D9 16r6B52 16r80CD 16r6B53 16r80D7 16r6B54 16r6710 16r6B55 16r80DD 16r6B56 16r80EB 16r6B57 16r80F1 16r6B58 16r80F4 16r6B59 16r80ED 16r6B5A 16r810D 16r6B5B 16r810E 16r6B5C 16r80F2 16r6B5D 16r80FC 16r6B5E 16r6715 16r6B5F 16r8112 16r6B60 16r8C5A 16r6B61 16r8136 16r6B62 16r811E 16r6B63 16r812C 16r6B64 16r8118 16r6B65 16r8132 16r6B66 16r8148 16r6B67 16r814C 16r6B68 16r8153 16r6B69 16r8174 16r6B6A 16r8159 16r6B6B 16r815A 16r6B6C 16r8171 16r6B6D 16r8160 16r6B6E 16r8169 16r6B6F 16r817C 16r6B70 16r817D 16r6B71 16r816D 16r6B72 16r8167 16r6B73 16r584D 16r6B74 16r5AB5 16r6B75 16r8188 16r6B76 16r8182 16r6B77 16r8191 16r6B78 16r6ED5 16r6B79 16r81A3 16r6B7A 16r81AA 16r6B7B 16r81CC 16r6B7C 16r6726 16r6B7D 16r81CA 16r6B7E 16r81BB 16r6C21 16r81C1 16r6C22 16r81A6 16r6C23 16r6B24 16r6C24 16r6B37 16r6C25 16r6B39 16r6C26 16r6B43 16r6C27 16r6B46 16r6C28 16r6B59 16r6C29 16r98D1 16r6C2A 16r98D2 16r6C2B 16r98D3 16r6C2C 16r98D5 16r6C2D 16r98D9 16r6C2E 16r98DA 16r6C2F 16r6BB3 16r6C30 16r5F40 16r6C31 16r6BC2 16r6C32 16r89F3 16r6C33 16r6590 16r6C34 16r9F51 16r6C35 16r6593 16r6C36 16r65BC 16r6C37 16r65C6 16r6C38 16r65C4 16r6C39 16r65C3 16r6C3A 16r65CC 16r6C3B 16r65CE 16r6C3C 16r65D2 16r6C3D 16r65D6 16r6C3E 16r7080 16r6C3F 16r709C 16r6C40 16r7096 16r6C41 16r709D 16r6C42 16r70BB 16r6C43 16r70C0 16r6C44 16r70B7 16r6C45 16r70AB 16r6C46 16r70B1 16r6C47 16r70E8 16r6C48 16r70CA 16r6C49 16r7110 16r6C4A 16r7113 16r6C4B 16r7116 16r6C4C 16r712F 16r6C4D 16r7131 16r6C4E 16r7173 16r6C4F 16r715C 16r6C50 16r7168 16r6C51 16r7145 16r6C52 16r7172 16r6C53 16r714A 16r6C54 16r7178 16r6C55 16r717A 16r6C56 16r7198 16r6C57 16r71B3 16r6C58 16r71B5 16r6C59 16r71A8 16r6C5A 16r71A0 16r6C5B 16r71E0 16r6C5C 16r71D4 16r6C5D 16r71E7 16r6C5E 16r71F9 16r6C5F 16r721D 16r6C60 16r7228 16r6C61 16r706C 16r6C62 16r7118 16r6C63 16r7166 16r6C64 16r71B9 16r6C65 16r623E 16r6C66 16r623D 16r6C67 16r6243 16r6C68 16r6248 16r6C69 16r6249 16r6C6A 16r793B 16r6C6B 16r7940 16r6C6C 16r7946 16r6C6D 16r7949 16r6C6E 16r795B 16r6C6F 16r795C 16r6C70 16r7953 16r6C71 16r795A 16r6C72 16r7962 16r6C73 16r7957 16r6C74 16r7960 16r6C75 16r796F 16r6C76 16r7967 16r6C77 16r797A 16r6C78 16r7985 16r6C79 16r798A 16r6C7A 16r799A 16r6C7B 16r79A7 16r6C7C 16r79B3 16r6C7D 16r5FD1 16r6C7E 16r5FD0 16r6D21 16r603C 16r6D22 16r605D 16r6D23 16r605A 16r6D24 16r6067 16r6D25 16r6041 16r6D26 16r6059 16r6D27 16r6063 16r6D28 16r60AB 16r6D29 16r6106 16r6D2A 16r610D 16r6D2B 16r615D 16r6D2C 16r61A9 16r6D2D 16r619D 16r6D2E 16r61CB 16r6D2F 16r61D1 16r6D30 16r6206 16r6D31 16r8080 16r6D32 16r807F 16r6D33 16r6C93 16r6D34 16r6CF6 16r6D35 16r6DFC 16r6D36 16r77F6 16r6D37 16r77F8 16r6D38 16r7800 16r6D39 16r7809 16r6D3A 16r7817 16r6D3B 16r7818 16r6D3C 16r7811 16r6D3D 16r65AB 16r6D3E 16r782D 16r6D3F 16r781C 16r6D40 16r781D 16r6D41 16r7839 16r6D42 16r783A 16r6D43 16r783B 16r6D44 16r781F 16r6D45 16r783C 16r6D46 16r7825 16r6D47 16r782C 16r6D48 16r7823 16r6D49 16r7829 16r6D4A 16r784E 16r6D4B 16r786D 16r6D4C 16r7856 16r6D4D 16r7857 16r6D4E 16r7826 16r6D4F 16r7850 16r6D50 16r7847 16r6D51 16r784C 16r6D52 16r786A 16r6D53 16r789B 16r6D54 16r7893 16r6D55 16r789A 16r6D56 16r7887 16r6D57 16r789C 16r6D58 16r78A1 16r6D59 16r78A3 16r6D5A 16r78B2 16r6D5B 16r78B9 16r6D5C 16r78A5 16r6D5D 16r78D4 16r6D5E 16r78D9 16r6D5F 16r78C9 16r6D60 16r78EC 16r6D61 16r78F2 16r6D62 16r7905 16r6D63 16r78F4 16r6D64 16r7913 16r6D65 16r7924 16r6D66 16r791E 16r6D67 16r7934 16r6D68 16r9F9B 16r6D69 16r9EF9 16r6D6A 16r9EFB 16r6D6B 16r9EFC 16r6D6C 16r76F1 16r6D6D 16r7704 16r6D6E 16r770D 16r6D6F 16r76F9 16r6D70 16r7707 16r6D71 16r7708 16r6D72 16r771A 16r6D73 16r7722 16r6D74 16r7719 16r6D75 16r772D 16r6D76 16r7726 16r6D77 16r7735 16r6D78 16r7738 16r6D79 16r7750 16r6D7A 16r7751 16r6D7B 16r7747 16r6D7C 16r7743 16r6D7D 16r775A 16r6D7E 16r7768 16r6E21 16r7762 16r6E22 16r7765 16r6E23 16r777F 16r6E24 16r778D 16r6E25 16r777D 16r6E26 16r7780 16r6E27 16r778C 16r6E28 16r7791 16r6E29 16r779F 16r6E2A 16r77A0 16r6E2B 16r77B0 16r6E2C 16r77B5 16r6E2D 16r77BD 16r6E2E 16r753A 16r6E2F 16r7540 16r6E30 16r754E 16r6E31 16r754B 16r6E32 16r7548 16r6E33 16r755B 16r6E34 16r7572 16r6E35 16r7579 16r6E36 16r7583 16r6E37 16r7F58 16r6E38 16r7F61 16r6E39 16r7F5F 16r6E3A 16r8A48 16r6E3B 16r7F68 16r6E3C 16r7F74 16r6E3D 16r7F71 16r6E3E 16r7F79 16r6E3F 16r7F81 16r6E40 16r7F7E 16r6E41 16r76CD 16r6E42 16r76E5 16r6E43 16r8832 16r6E44 16r9485 16r6E45 16r9486 16r6E46 16r9487 16r6E47 16r948B 16r6E48 16r948A 16r6E49 16r948C 16r6E4A 16r948D 16r6E4B 16r948F 16r6E4C 16r9490 16r6E4D 16r9494 16r6E4E 16r9497 16r6E4F 16r9495 16r6E50 16r949A 16r6E51 16r949B 16r6E52 16r949C 16r6E53 16r94A3 16r6E54 16r94A4 16r6E55 16r94AB 16r6E56 16r94AA 16r6E57 16r94AD 16r6E58 16r94AC 16r6E59 16r94AF 16r6E5A 16r94B0 16r6E5B 16r94B2 16r6E5C 16r94B4 16r6E5D 16r94B6 16r6E5E 16r94B7 16r6E5F 16r94B8 16r6E60 16r94B9 16r6E61 16r94BA 16r6E62 16r94BC 16r6E63 16r94BD 16r6E64 16r94BF 16r6E65 16r94C4 16r6E66 16r94C8 16r6E67 16r94C9 16r6E68 16r94CA 16r6E69 16r94CB 16r6E6A 16r94CC 16r6E6B 16r94CD 16r6E6C 16r94CE 16r6E6D 16r94D0 16r6E6E 16r94D1 16r6E6F 16r94D2 16r6E70 16r94D5 16r6E71 16r94D6 16r6E72 16r94D7 16r6E73 16r94D9 16r6E74 16r94D8 16r6E75 16r94DB 16r6E76 16r94DE 16r6E77 16r94DF 16r6E78 16r94E0 16r6E79 16r94E2 16r6E7A 16r94E4 16r6E7B 16r94E5 16r6E7C 16r94E7 16r6E7D 16r94E8 16r6E7E 16r94EA 16r6F21 16r94E9 16r6F22 16r94EB 16r6F23 16r94EE 16r6F24 16r94EF 16r6F25 16r94F3 16r6F26 16r94F4 16r6F27 16r94F5 16r6F28 16r94F7 16r6F29 16r94F9 16r6F2A 16r94FC 16r6F2B 16r94FD 16r6F2C 16r94FF 16r6F2D 16r9503 16r6F2E 16r9502 16r6F2F 16r9506 16r6F30 16r9507 16r6F31 16r9509 16r6F32 16r950A 16r6F33 16r950D 16r6F34 16r950E 16r6F35 16r950F 16r6F36 16r9512 16r6F37 16r9513 16r6F38 16r9514 16r6F39 16r9515 16r6F3A 16r9516 16r6F3B 16r9518 16r6F3C 16r951B 16r6F3D 16r951D 16r6F3E 16r951E 16r6F3F 16r951F 16r6F40 16r9522 16r6F41 16r952A 16r6F42 16r952B 16r6F43 16r9529 16r6F44 16r952C 16r6F45 16r9531 16r6F46 16r9532 16r6F47 16r9534 16r6F48 16r9536 16r6F49 16r9537 16r6F4A 16r9538 16r6F4B 16r953C 16r6F4C 16r953E 16r6F4D 16r953F 16r6F4E 16r9542 16r6F4F 16r9535 16r6F50 16r9544 16r6F51 16r9545 16r6F52 16r9546 16r6F53 16r9549 16r6F54 16r954C 16r6F55 16r954E 16r6F56 16r954F 16r6F57 16r9552 16r6F58 16r9553 16r6F59 16r9554 16r6F5A 16r9556 16r6F5B 16r9557 16r6F5C 16r9558 16r6F5D 16r9559 16r6F5E 16r955B 16r6F5F 16r955E 16r6F60 16r955F 16r6F61 16r955D 16r6F62 16r9561 16r6F63 16r9562 16r6F64 16r9564 16r6F65 16r9565 16r6F66 16r9566 16r6F67 16r9567 16r6F68 16r9568 16r6F69 16r9569 16r6F6A 16r956A 16r6F6B 16r956B 16r6F6C 16r956C 16r6F6D 16r956F 16r6F6E 16r9571 16r6F6F 16r9572 16r6F70 16r9573 16r6F71 16r953A 16r6F72 16r77E7 16r6F73 16r77EC 16r6F74 16r96C9 16r6F75 16r79D5 16r6F76 16r79ED 16r6F77 16r79E3 16r6F78 16r79EB 16r6F79 16r7A06 16r6F7A 16r5D47 16r6F7B 16r7A03 16r6F7C 16r7A02 16r6F7D 16r7A1E 16r6F7E 16r7A14 16r7021 16r7A39 16r7022 16r7A37 16r7023 16r7A51 16r7024 16r9ECF 16r7025 16r99A5 16r7026 16r7A70 16r7027 16r7688 16r7028 16r768E 16r7029 16r7693 16r702A 16r7699 16r702B 16r76A4 16r702C 16r74DE 16r702D 16r74E0 16r702E 16r752C 16r702F 16r9E20 16r7030 16r9E22 16r7031 16r9E28 16r7032 16r9E29 16r7033 16r9E2A 16r7034 16r9E2B 16r7035 16r9E2C 16r7036 16r9E32 16r7037 16r9E31 16r7038 16r9E36 16r7039 16r9E38 16r703A 16r9E37 16r703B 16r9E39 16r703C 16r9E3A 16r703D 16r9E3E 16r703E 16r9E41 16r703F 16r9E42 16r7040 16r9E44 16r7041 16r9E46 16r7042 16r9E47 16r7043 16r9E48 16r7044 16r9E49 16r7045 16r9E4B 16r7046 16r9E4C 16r7047 16r9E4E 16r7048 16r9E51 16r7049 16r9E55 16r704A 16r9E57 16r704B 16r9E5A 16r704C 16r9E5B 16r704D 16r9E5C 16r704E 16r9E5E 16r704F 16r9E63 16r7050 16r9E66 16r7051 16r9E67 16r7052 16r9E68 16r7053 16r9E69 16r7054 16r9E6A 16r7055 16r9E6B 16r7056 16r9E6C 16r7057 16r9E71 16r7058 16r9E6D 16r7059 16r9E73 16r705A 16r7592 16r705B 16r7594 16r705C 16r7596 16r705D 16r75A0 16r705E 16r759D 16r705F 16r75AC 16r7060 16r75A3 16r7061 16r75B3 16r7062 16r75B4 16r7063 16r75B8 16r7064 16r75C4 16r7065 16r75B1 16r7066 16r75B0 16r7067 16r75C3 16r7068 16r75C2 16r7069 16r75D6 16r706A 16r75CD 16r706B 16r75E3 16r706C 16r75E8 16r706D 16r75E6 16r706E 16r75E4 16r706F 16r75EB 16r7070 16r75E7 16r7071 16r7603 16r7072 16r75F1 16r7073 16r75FC 16r7074 16r75FF 16r7075 16r7610 16r7076 16r7600 16r7077 16r7605 16r7078 16r760C 16r7079 16r7617 16r707A 16r760A 16r707B 16r7625 16r707C 16r7618 16r707D 16r7615 16r707E 16r7619 16r7121 16r761B 16r7122 16r763C 16r7123 16r7622 16r7124 16r7620 16r7125 16r7640 16r7126 16r762D 16r7127 16r7630 16r7128 16r763F 16r7129 16r7635 16r712A 16r7643 16r712B 16r763E 16r712C 16r7633 16r712D 16r764D 16r712E 16r765E 16r712F 16r7654 16r7130 16r765C 16r7131 16r7656 16r7132 16r766B 16r7133 16r766F 16r7134 16r7FCA 16r7135 16r7AE6 16r7136 16r7A78 16r7137 16r7A79 16r7138 16r7A80 16r7139 16r7A86 16r713A 16r7A88 16r713B 16r7A95 16r713C 16r7AA6 16r713D 16r7AA0 16r713E 16r7AAC 16r713F 16r7AA8 16r7140 16r7AAD 16r7141 16r7AB3 16r7142 16r8864 16r7143 16r8869 16r7144 16r8872 16r7145 16r887D 16r7146 16r887F 16r7147 16r8882 16r7148 16r88A2 16r7149 16r88C6 16r714A 16r88B7 16r714B 16r88BC 16r714C 16r88C9 16r714D 16r88E2 16r714E 16r88CE 16r714F 16r88E3 16r7150 16r88E5 16r7151 16r88F1 16r7152 16r891A 16r7153 16r88FC 16r7154 16r88E8 16r7155 16r88FE 16r7156 16r88F0 16r7157 16r8921 16r7158 16r8919 16r7159 16r8913 16r715A 16r891B 16r715B 16r890A 16r715C 16r8934 16r715D 16r892B 16r715E 16r8936 16r715F 16r8941 16r7160 16r8966 16r7161 16r897B 16r7162 16r758B 16r7163 16r80E5 16r7164 16r76B2 16r7165 16r76B4 16r7166 16r77DC 16r7167 16r8012 16r7168 16r8014 16r7169 16r8016 16r716A 16r801C 16r716B 16r8020 16r716C 16r8022 16r716D 16r8025 16r716E 16r8026 16r716F 16r8027 16r7170 16r8029 16r7171 16r8028 16r7172 16r8031 16r7173 16r800B 16r7174 16r8035 16r7175 16r8043 16r7176 16r8046 16r7177 16r804D 16r7178 16r8052 16r7179 16r8069 16r717A 16r8071 16r717B 16r8983 16r717C 16r9878 16r717D 16r9880 16r717E 16r9883 16r7221 16r9889 16r7222 16r988C 16r7223 16r988D 16r7224 16r988F 16r7225 16r9894 16r7226 16r989A 16r7227 16r989B 16r7228 16r989E 16r7229 16r989F 16r722A 16r98A1 16r722B 16r98A2 16r722C 16r98A5 16r722D 16r98A6 16r722E 16r864D 16r722F 16r8654 16r7230 16r866C 16r7231 16r866E 16r7232 16r867F 16r7233 16r867A 16r7234 16r867C 16r7235 16r867B 16r7236 16r86A8 16r7237 16r868D 16r7238 16r868B 16r7239 16r86AC 16r723A 16r869D 16r723B 16r86A7 16r723C 16r86A3 16r723D 16r86AA 16r723E 16r8693 16r723F 16r86A9 16r7240 16r86B6 16r7241 16r86C4 16r7242 16r86B5 16r7243 16r86CE 16r7244 16r86B0 16r7245 16r86BA 16r7246 16r86B1 16r7247 16r86AF 16r7248 16r86C9 16r7249 16r86CF 16r724A 16r86B4 16r724B 16r86E9 16r724C 16r86F1 16r724D 16r86F2 16r724E 16r86ED 16r724F 16r86F3 16r7250 16r86D0 16r7251 16r8713 16r7252 16r86DE 16r7253 16r86F4 16r7254 16r86DF 16r7255 16r86D8 16r7256 16r86D1 16r7257 16r8703 16r7258 16r8707 16r7259 16r86F8 16r725A 16r8708 16r725B 16r870A 16r725C 16r870D 16r725D 16r8709 16r725E 16r8723 16r725F 16r873B 16r7260 16r871E 16r7261 16r8725 16r7262 16r872E 16r7263 16r871A 16r7264 16r873E 16r7265 16r8748 16r7266 16r8734 16r7267 16r8731 16r7268 16r8729 16r7269 16r8737 16r726A 16r873F 16r726B 16r8782 16r726C 16r8722 16r726D 16r877D 16r726E 16r877E 16r726F 16r877B 16r7270 16r8760 16r7271 16r8770 16r7272 16r874C 16r7273 16r876E 16r7274 16r878B 16r7275 16r8753 16r7276 16r8763 16r7277 16r877C 16r7278 16r8764 16r7279 16r8759 16r727A 16r8765 16r727B 16r8793 16r727C 16r87AF 16r727D 16r87A8 16r727E 16r87D2 16r7321 16r87C6 16r7322 16r8788 16r7323 16r8785 16r7324 16r87AD 16r7325 16r8797 16r7326 16r8783 16r7327 16r87AB 16r7328 16r87E5 16r7329 16r87AC 16r732A 16r87B5 16r732B 16r87B3 16r732C 16r87CB 16r732D 16r87D3 16r732E 16r87BD 16r732F 16r87D1 16r7330 16r87C0 16r7331 16r87CA 16r7332 16r87DB 16r7333 16r87EA 16r7334 16r87E0 16r7335 16r87EE 16r7336 16r8816 16r7337 16r8813 16r7338 16r87FE 16r7339 16r880A 16r733A 16r881B 16r733B 16r8821 16r733C 16r8839 16r733D 16r883C 16r733E 16r7F36 16r733F 16r7F42 16r7340 16r7F44 16r7341 16r7F45 16r7342 16r8210 16r7343 16r7AFA 16r7344 16r7AFD 16r7345 16r7B08 16r7346 16r7B03 16r7347 16r7B04 16r7348 16r7B15 16r7349 16r7B0A 16r734A 16r7B2B 16r734B 16r7B0F 16r734C 16r7B47 16r734D 16r7B38 16r734E 16r7B2A 16r734F 16r7B19 16r7350 16r7B2E 16r7351 16r7B31 16r7352 16r7B20 16r7353 16r7B25 16r7354 16r7B24 16r7355 16r7B33 16r7356 16r7B3E 16r7357 16r7B1E 16r7358 16r7B58 16r7359 16r7B5A 16r735A 16r7B45 16r735B 16r7B75 16r735C 16r7B4C 16r735D 16r7B5D 16r735E 16r7B60 16r735F 16r7B6E 16r7360 16r7B7B 16r7361 16r7B62 16r7362 16r7B72 16r7363 16r7B71 16r7364 16r7B90 16r7365 16r7BA6 16r7366 16r7BA7 16r7367 16r7BB8 16r7368 16r7BAC 16r7369 16r7B9D 16r736A 16r7BA8 16r736B 16r7B85 16r736C 16r7BAA 16r736D 16r7B9C 16r736E 16r7BA2 16r736F 16r7BAB 16r7370 16r7BB4 16r7371 16r7BD1 16r7372 16r7BC1 16r7373 16r7BCC 16r7374 16r7BDD 16r7375 16r7BDA 16r7376 16r7BE5 16r7377 16r7BE6 16r7378 16r7BEA 16r7379 16r7C0C 16r737A 16r7BFE 16r737B 16r7BFC 16r737C 16r7C0F 16r737D 16r7C16 16r737E 16r7C0B 16r7421 16r7C1F 16r7422 16r7C2A 16r7423 16r7C26 16r7424 16r7C38 16r7425 16r7C41 16r7426 16r7C40 16r7427 16r81FE 16r7428 16r8201 16r7429 16r8202 16r742A 16r8204 16r742B 16r81EC 16r742C 16r8844 16r742D 16r8221 16r742E 16r8222 16r742F 16r8223 16r7430 16r822D 16r7431 16r822F 16r7432 16r8228 16r7433 16r822B 16r7434 16r8238 16r7435 16r823B 16r7436 16r8233 16r7437 16r8234 16r7438 16r823E 16r7439 16r8244 16r743A 16r8249 16r743B 16r824B 16r743C 16r824F 16r743D 16r825A 16r743E 16r825F 16r743F 16r8268 16r7440 16r887E 16r7441 16r8885 16r7442 16r8888 16r7443 16r88D8 16r7444 16r88DF 16r7445 16r895E 16r7446 16r7F9D 16r7447 16r7F9F 16r7448 16r7FA7 16r7449 16r7FAF 16r744A 16r7FB0 16r744B 16r7FB2 16r744C 16r7C7C 16r744D 16r6549 16r744E 16r7C91 16r744F 16r7C9D 16r7450 16r7C9C 16r7451 16r7C9E 16r7452 16r7CA2 16r7453 16r7CB2 16r7454 16r7CBC 16r7455 16r7CBD 16r7456 16r7CC1 16r7457 16r7CC7 16r7458 16r7CCC 16r7459 16r7CCD 16r745A 16r7CC8 16r745B 16r7CC5 16r745C 16r7CD7 16r745D 16r7CE8 16r745E 16r826E 16r745F 16r66A8 16r7460 16r7FBF 16r7461 16r7FCE 16r7462 16r7FD5 16r7463 16r7FE5 16r7464 16r7FE1 16r7465 16r7FE6 16r7466 16r7FE9 16r7467 16r7FEE 16r7468 16r7FF3 16r7469 16r7CF8 16r746A 16r7D77 16r746B 16r7DA6 16r746C 16r7DAE 16r746D 16r7E47 16r746E 16r7E9B 16r746F 16r9EB8 16r7470 16r9EB4 16r7471 16r8D73 16r7472 16r8D84 16r7473 16r8D94 16r7474 16r8D91 16r7475 16r8DB1 16r7476 16r8D67 16r7477 16r8D6D 16r7478 16r8C47 16r7479 16r8C49 16r747A 16r914A 16r747B 16r9150 16r747C 16r914E 16r747D 16r914F 16r747E 16r9164 16r7521 16r9162 16r7522 16r9161 16r7523 16r9170 16r7524 16r9169 16r7525 16r916F 16r7526 16r917D 16r7527 16r917E 16r7528 16r9172 16r7529 16r9174 16r752A 16r9179 16r752B 16r918C 16r752C 16r9185 16r752D 16r9190 16r752E 16r918D 16r752F 16r9191 16r7530 16r91A2 16r7531 16r91A3 16r7532 16r91AA 16r7533 16r91AD 16r7534 16r91AE 16r7535 16r91AF 16r7536 16r91B5 16r7537 16r91B4 16r7538 16r91BA 16r7539 16r8C55 16r753A 16r9E7E 16r753B 16r8DB8 16r753C 16r8DEB 16r753D 16r8E05 16r753E 16r8E59 16r753F 16r8E69 16r7540 16r8DB5 16r7541 16r8DBF 16r7542 16r8DBC 16r7543 16r8DBA 16r7544 16r8DC4 16r7545 16r8DD6 16r7546 16r8DD7 16r7547 16r8DDA 16r7548 16r8DDE 16r7549 16r8DCE 16r754A 16r8DCF 16r754B 16r8DDB 16r754C 16r8DC6 16r754D 16r8DEC 16r754E 16r8DF7 16r754F 16r8DF8 16r7550 16r8DE3 16r7551 16r8DF9 16r7552 16r8DFB 16r7553 16r8DE4 16r7554 16r8E09 16r7555 16r8DFD 16r7556 16r8E14 16r7557 16r8E1D 16r7558 16r8E1F 16r7559 16r8E2C 16r755A 16r8E2E 16r755B 16r8E23 16r755C 16r8E2F 16r755D 16r8E3A 16r755E 16r8E40 16r755F 16r8E39 16r7560 16r8E35 16r7561 16r8E3D 16r7562 16r8E31 16r7563 16r8E49 16r7564 16r8E41 16r7565 16r8E42 16r7566 16r8E51 16r7567 16r8E52 16r7568 16r8E4A 16r7569 16r8E70 16r756A 16r8E76 16r756B 16r8E7C 16r756C 16r8E6F 16r756D 16r8E74 16r756E 16r8E85 16r756F 16r8E8F 16r7570 16r8E94 16r7571 16r8E90 16r7572 16r8E9C 16r7573 16r8E9E 16r7574 16r8C78 16r7575 16r8C82 16r7576 16r8C8A 16r7577 16r8C85 16r7578 16r8C98 16r7579 16r8C94 16r757A 16r659B 16r757B 16r89D6 16r757C 16r89DE 16r757D 16r89DA 16r757E 16r89DC 16r7621 16r89E5 16r7622 16r89EB 16r7623 16r89EF 16r7624 16r8A3E 16r7625 16r8B26 16r7626 16r9753 16r7627 16r96E9 16r7628 16r96F3 16r7629 16r96EF 16r762A 16r9706 16r762B 16r9701 16r762C 16r9708 16r762D 16r970F 16r762E 16r970E 16r762F 16r972A 16r7630 16r972D 16r7631 16r9730 16r7632 16r973E 16r7633 16r9F80 16r7634 16r9F83 16r7635 16r9F85 16r7636 16r9F86 16r7637 16r9F87 16r7638 16r9F88 16r7639 16r9F89 16r763A 16r9F8A 16r763B 16r9F8C 16r763C 16r9EFE 16r763D 16r9F0B 16r763E 16r9F0D 16r763F 16r96B9 16r7640 16r96BC 16r7641 16r96BD 16r7642 16r96CE 16r7643 16r96D2 16r7644 16r77BF 16r7645 16r96E0 16r7646 16r928E 16r7647 16r92AE 16r7648 16r92C8 16r7649 16r933E 16r764A 16r936A 16r764B 16r93CA 16r764C 16r938F 16r764D 16r943E 16r764E 16r946B 16r764F 16r9C7F 16r7650 16r9C82 16r7651 16r9C85 16r7652 16r9C86 16r7653 16r9C87 16r7654 16r9C88 16r7655 16r7A23 16r7656 16r9C8B 16r7657 16r9C8E 16r7658 16r9C90 16r7659 16r9C91 16r765A 16r9C92 16r765B 16r9C94 16r765C 16r9C95 16r765D 16r9C9A 16r765E 16r9C9B 16r765F 16r9C9E 16r7660 16r9C9F 16r7661 16r9CA0 16r7662 16r9CA1 16r7663 16r9CA2 16r7664 16r9CA3 16r7665 16r9CA5 16r7666 16r9CA6 16r7667 16r9CA7 16r7668 16r9CA8 16r7669 16r9CA9 16r766A 16r9CAB 16r766B 16r9CAD 16r766C 16r9CAE 16r766D 16r9CB0 16r766E 16r9CB1 16r766F 16r9CB2 16r7670 16r9CB3 16r7671 16r9CB4 16r7672 16r9CB5 16r7673 16r9CB6 16r7674 16r9CB7 16r7675 16r9CBA 16r7676 16r9CBB 16r7677 16r9CBC 16r7678 16r9CBD 16r7679 16r9CC4 16r767A 16r9CC5 16r767B 16r9CC6 16r767C 16r9CC7 16r767D 16r9CCA 16r767E 16r9CCB 16r7721 16r9CCC 16r7722 16r9CCD 16r7723 16r9CCE 16r7724 16r9CCF 16r7725 16r9CD0 16r7726 16r9CD3 16r7727 16r9CD4 16r7728 16r9CD5 16r7729 16r9CD7 16r772A 16r9CD8 16r772B 16r9CD9 16r772C 16r9CDC 16r772D 16r9CDD 16r772E 16r9CDF 16r772F 16r9CE2 16r7730 16r977C 16r7731 16r9785 16r7732 16r9791 16r7733 16r9792 16r7734 16r9794 16r7735 16r97AF 16r7736 16r97AB 16r7737 16r97A3 16r7738 16r97B2 16r7739 16r97B4 16r773A 16r9AB1 16r773B 16r9AB0 16r773C 16r9AB7 16r773D 16r9E58 16r773E 16r9AB6 16r773F 16r9ABA 16r7740 16r9ABC 16r7741 16r9AC1 16r7742 16r9AC0 16r7743 16r9AC5 16r7744 16r9AC2 16r7745 16r9ACB 16r7746 16r9ACC 16r7747 16r9AD1 16r7748 16r9B45 16r7749 16r9B43 16r774A 16r9B47 16r774B 16r9B49 16r774C 16r9B48 16r774D 16r9B4D 16r774E 16r9B51 16r774F 16r98E8 16r7750 16r990D 16r7751 16r992E 16r7752 16r9955 16r7753 16r9954 16r7754 16r9ADF 16r7755 16r9AE1 16r7756 16r9AE6 16r7757 16r9AEF 16r7758 16r9AEB 16r7759 16r9AFB 16r775A 16r9AED 16r775B 16r9AF9 16r775C 16r9B08 16r775D 16r9B0F 16r775E 16r9B13 16r775F 16r9B1F 16r7760 16r9B23 16r7761 16r9EBD 16r7762 16r9EBE 16r7763 16r7E3B 16r7764 16r9E82 16r7765 16r9E87 16r7766 16r9E88 16r7767 16r9E8B 16r7768 16r9E92 16r7769 16r93D6 16r776A 16r9E9D 16r776B 16r9E9F 16r776C 16r9EDB 16r776D 16r9EDC 16r776E 16r9EDD 16r776F 16r9EE0 16r7770 16r9EDF 16r7771 16r9EE2 16r7772 16r9EE9 16r7773 16r9EE7 16r7774 16r9EE5 16r7775 16r9EEA 16r7776 16r9EEF 16r7777 16r9F22 16r7778 16r9F2C 16r7779 16r9F2F 16r777A 16r9F39 16r777B 16r9F37 16r777C 16r9F3D 16r777D 16r9F3E 16r777E 16r9F44). 422819 table size even ifFalse: [^ self error: 'given table size must be even']. 422820 size := table size / 2. 422821 gb2312 := Array new: size. 422822 unicode := Array new: size. 422823 1 to: table size by: 2 do: [:index | 422824 | tableIndex | 422825 tableIndex := index + 1 / 2. 422826 gb2312 at: tableIndex put: (table at: index). 422827 unicode at: tableIndex put: (table at: index + 1)]. 422828 gb23122 := Array new: 94*94 withAll: -1. 422829 gb2312 withIndexDo: [:elem :index | 422830 code := (elem // 256 - 33) * 94 + (elem \\ 256 - 33) + 1. 422831 (gb23122 at: code) ~= -1 ifTrue: [self halt]. 422832 uIndex := gb2312 indexOf: elem. 422833 uIndex = 0 ifFalse: [ 422834 u := unicode at: uIndex. 422835 gb23122 at: code put: u. 422836 ]. 422837 ]. 422838 GB2312Table := gb23122. 422839! ! 422840 422841!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 1/17/2004 00:33'! 422842initializeJISX0208Table 422843 "self halt. UCSTable initializeJISX0208Table" 422844 422845 | table size jisX0208 unicode jisX02082 code uIndex u | 422846 table := #(16r2121 16r3000 16r2122 16r3001 16r2123 16r3002 16r2124 16rFF0C 16r2125 16rFF0E 16r2126 16r30FB 16r2127 16rFF1A 16r2128 16rFF1B 16r2129 16rFF1F 16r212A 16rFF01 16r212B 16r309B 16r212C 16r309C 16r212D 16rB4 16r212E 16rFF40 16r212F 16rA8 16r2130 16rFF3E 16r2131 16rFFE3 16r2132 16rFF3F 16r2133 16r30FD 16r2134 16r30FE 16r2135 16r309D 16r2136 16r309E 16r2137 16r3003 16r2138 16r4EDD 16r2139 16r3005 16r213A 16r3006 16r213B 16r3007 16r213C 16r30FC 16r213D 16r2015 16r213E 16r2010 16r213F 16rFF0F 16r2140 16r5C 16r2141 16r301C 16r2142 16r2016 16r2143 16rFF5C 16r2144 16r2026 16r2145 16r2025 16r2146 16r2018 16r2147 16r2019 16r2148 16r201C 16r2149 16r201D 16r214A 16rFF08 16r214B 16rFF09 16r214C 16r3014 16r214D 16r3015 16r214E 16rFF3B 16r214F 16rFF3D 16r2150 16rFF5B 16r2151 16rFF5D 16r2152 16r3008 16r2153 16r3009 16r2154 16r300A 16r2155 16r300B 16r2156 16r300C 16r2157 16r300D 16r2158 16r300E 16r2159 16r300F 16r215A 16r3010 16r215B 16r3011 16r215C 16rFF0B 16r215D 16r2212 16r215E 16rB1 16r215F 16rD7 16r2160 16rF7 16r2161 16rFF1D 16r2162 16r2260 16r2163 16rFF1C 16r2164 16rFF1E 16r2165 16r2266 16r2166 16r2267 16r2167 16r221E 16r2168 16r2234 16r2169 16r2642 16r216A 16r2640 16r216B 16rB0 16r216C 16r2032 16r216D 16r2033 16r216E 16r2103 16r216F 16rFFE5 16r2170 16rFF04 16r2171 16rA2 16r2172 16rA3 16r2173 16rFF05 16r2174 16rFF03 16r2175 16rFF06 16r2176 16rFF0A 16r2177 16rFF20 16r2178 16rA7 16r2179 16r2606 16r217A 16r2605 16r217B 16r25CB 16r217C 16r25CF 16r217D 16r25CE 16r217E 16r25C7 16r2221 16r25C6 16r2222 16r25A1 16r2223 16r25A0 16r2224 16r25B3 16r2225 16r25B2 16r2226 16r25BD 16r2227 16r25BC 16r2228 16r203B 16r2229 16r3012 16r222A 16r2192 16r222B 16r2190 16r222C 16r2191 16r222D 16r2193 16r222E 16r3013 16r223A 16r2208 16r223B 16r220B 16r223C 16r2286 16r223D 16r2287 16r223E 16r2282 16r223F 16r2283 16r2240 16r222A 16r2241 16r2229 16r224A 16r2227 16r224B 16r2228 16r224C 16rAC 16r224D 16r21D2 16r224E 16r21D4 16r224F 16r2200 16r2250 16r2203 16r225C 16r2220 16r225D 16r22A5 16r225E 16r2312 16r225F 16r2202 16r2260 16r2207 16r2261 16r2261 16r2262 16r2252 16r2263 16r226A 16r2264 16r226B 16r2265 16r221A 16r2266 16r223D 16r2267 16r221D 16r2268 16r2235 16r2269 16r222B 16r226A 16r222C 16r2272 16r212B 16r2273 16r2030 16r2274 16r266F 16r2275 16r266D 16r2276 16r266A 16r2277 16r2020 16r2278 16r2021 16r2279 16rB6 16r227E 16r25EF 16r2330 16rFF10 16r2331 16rFF11 16r2332 16rFF12 16r2333 16rFF13 16r2334 16rFF14 16r2335 16rFF15 16r2336 16rFF16 16r2337 16rFF17 16r2338 16rFF18 16r2339 16rFF19 16r2341 16rFF21 16r2342 16rFF22 16r2343 16rFF23 16r2344 16rFF24 16r2345 16rFF25 16r2346 16rFF26 16r2347 16rFF27 16r2348 16rFF28 16r2349 16rFF29 16r234A 16rFF2A 16r234B 16rFF2B 16r234C 16rFF2C 16r234D 16rFF2D 16r234E 16rFF2E 16r234F 16rFF2F 16r2350 16rFF30 16r2351 16rFF31 16r2352 16rFF32 16r2353 16rFF33 16r2354 16rFF34 16r2355 16rFF35 16r2356 16rFF36 16r2357 16rFF37 16r2358 16rFF38 16r2359 16rFF39 16r235A 16rFF3A 16r2361 16rFF41 16r2362 16rFF42 16r2363 16rFF43 16r2364 16rFF44 16r2365 16rFF45 16r2366 16rFF46 16r2367 16rFF47 16r2368 16rFF48 16r2369 16rFF49 16r236A 16rFF4A 16r236B 16rFF4B 16r236C 16rFF4C 16r236D 16rFF4D 16r236E 16rFF4E 16r236F 16rFF4F 16r2370 16rFF50 16r2371 16rFF51 16r2372 16rFF52 16r2373 16rFF53 16r2374 16rFF54 16r2375 16rFF55 16r2376 16rFF56 16r2377 16rFF57 16r2378 16rFF58 16r2379 16rFF59 16r237A 16rFF5A 16r2421 16r3041 16r2422 16r3042 16r2423 16r3043 16r2424 16r3044 16r2425 16r3045 16r2426 16r3046 16r2427 16r3047 16r2428 16r3048 16r2429 16r3049 16r242A 16r304A 16r242B 16r304B 16r242C 16r304C 16r242D 16r304D 16r242E 16r304E 16r242F 16r304F 16r2430 16r3050 16r2431 16r3051 16r2432 16r3052 16r2433 16r3053 16r2434 16r3054 16r2435 16r3055 16r2436 16r3056 16r2437 16r3057 16r2438 16r3058 16r2439 16r3059 16r243A 16r305A 16r243B 16r305B 16r243C 16r305C 16r243D 16r305D 16r243E 16r305E 16r243F 16r305F 16r2440 16r3060 16r2441 16r3061 16r2442 16r3062 16r2443 16r3063 16r2444 16r3064 16r2445 16r3065 16r2446 16r3066 16r2447 16r3067 16r2448 16r3068 16r2449 16r3069 16r244A 16r306A 16r244B 16r306B 16r244C 16r306C 16r244D 16r306D 16r244E 16r306E 16r244F 16r306F 16r2450 16r3070 16r2451 16r3071 16r2452 16r3072 16r2453 16r3073 16r2454 16r3074 16r2455 16r3075 16r2456 16r3076 16r2457 16r3077 16r2458 16r3078 16r2459 16r3079 16r245A 16r307A 16r245B 16r307B 16r245C 16r307C 16r245D 16r307D 16r245E 16r307E 16r245F 16r307F 16r2460 16r3080 16r2461 16r3081 16r2462 16r3082 16r2463 16r3083 16r2464 16r3084 16r2465 16r3085 16r2466 16r3086 16r2467 16r3087 16r2468 16r3088 16r2469 16r3089 16r246A 16r308A 16r246B 16r308B 16r246C 16r308C 16r246D 16r308D 16r246E 16r308E 16r246F 16r308F 16r2470 16r3090 16r2471 16r3091 16r2472 16r3092 16r2473 16r3093 16r2521 16r30A1 16r2522 16r30A2 16r2523 16r30A3 16r2524 16r30A4 16r2525 16r30A5 16r2526 16r30A6 16r2527 16r30A7 16r2528 16r30A8 16r2529 16r30A9 16r252A 16r30AA 16r252B 16r30AB 16r252C 16r30AC 16r252D 16r30AD 16r252E 16r30AE 16r252F 16r30AF 16r2530 16r30B0 16r2531 16r30B1 16r2532 16r30B2 16r2533 16r30B3 16r2534 16r30B4 16r2535 16r30B5 16r2536 16r30B6 16r2537 16r30B7 16r2538 16r30B8 16r2539 16r30B9 16r253A 16r30BA 16r253B 16r30BB 16r253C 16r30BC 16r253D 16r30BD 16r253E 16r30BE 16r253F 16r30BF 16r2540 16r30C0 16r2541 16r30C1 16r2542 16r30C2 16r2543 16r30C3 16r2544 16r30C4 16r2545 16r30C5 16r2546 16r30C6 16r2547 16r30C7 16r2548 16r30C8 16r2549 16r30C9 16r254A 16r30CA 16r254B 16r30CB 16r254C 16r30CC 16r254D 16r30CD 16r254E 16r30CE 16r254F 16r30CF 16r2550 16r30D0 16r2551 16r30D1 16r2552 16r30D2 16r2553 16r30D3 16r2554 16r30D4 16r2555 16r30D5 16r2556 16r30D6 16r2557 16r30D7 16r2558 16r30D8 16r2559 16r30D9 16r255A 16r30DA 16r255B 16r30DB 16r255C 16r30DC 16r255D 16r30DD 16r255E 16r30DE 16r255F 16r30DF 16r2560 16r30E0 16r2561 16r30E1 16r2562 16r30E2 16r2563 16r30E3 16r2564 16r30E4 16r2565 16r30E5 16r2566 16r30E6 16r2567 16r30E7 16r2568 16r30E8 16r2569 16r30E9 16r256A 16r30EA 16r256B 16r30EB 16r256C 16r30EC 16r256D 16r30ED 16r256E 16r30EE 16r256F 16r30EF 16r2570 16r30F0 16r2571 16r30F1 16r2572 16r30F2 16r2573 16r30F3 16r2574 16r30F4 16r2575 16r30F5 16r2576 16r30F6 16r2621 16r391 16r2622 16r392 16r2623 16r393 16r2624 16r394 16r2625 16r395 16r2626 16r396 16r2627 16r397 16r2628 16r398 16r2629 16r399 16r262A 16r39A 16r262B 16r39B 16r262C 16r39C 16r262D 16r39D 16r262E 16r39E 16r262F 16r39F 16r2630 16r3A0 16r2631 16r3A1 16r2632 16r3A3 16r2633 16r3A4 16r2634 16r3A5 16r2635 16r3A6 16r2636 16r3A7 16r2637 16r3A8 16r2638 16r3A9 16r2641 16r3B1 16r2642 16r3B2 16r2643 16r3B3 16r2644 16r3B4 16r2645 16r3B5 16r2646 16r3B6 16r2647 16r3B7 16r2648 16r3B8 16r2649 16r3B9 16r264A 16r3BA 16r264B 16r3BB 16r264C 16r3BC 16r264D 16r3BD 16r264E 16r3BE 16r264F 16r3BF 16r2650 16r3C0 16r2651 16r3C1 16r2652 16r3C3 16r2653 16r3C4 16r2654 16r3C5 16r2655 16r3C6 16r2656 16r3C7 16r2657 16r3C8 16r2658 16r3C9 16r2721 16r410 16r2722 16r411 16r2723 16r412 16r2724 16r413 16r2725 16r414 16r2726 16r415 16r2727 16r401 16r2728 16r416 16r2729 16r417 16r272A 16r418 16r272B 16r419 16r272C 16r41A 16r272D 16r41B 16r272E 16r41C 16r272F 16r41D 16r2730 16r41E 16r2731 16r41F 16r2732 16r420 16r2733 16r421 16r2734 16r422 16r2735 16r423 16r2736 16r424 16r2737 16r425 16r2738 16r426 16r2739 16r427 16r273A 16r428 16r273B 16r429 16r273C 16r42A 16r273D 16r42B 16r273E 16r42C 16r273F 16r42D 16r2740 16r42E 16r2741 16r42F 16r2751 16r430 16r2752 16r431 16r2753 16r432 16r2754 16r433 16r2755 16r434 16r2756 16r435 16r2757 16r451 16r2758 16r436 16r2759 16r437 16r275A 16r438 16r275B 16r439 16r275C 16r43A 16r275D 16r43B 16r275E 16r43C 16r275F 16r43D 16r2760 16r43E 16r2761 16r43F 16r2762 16r440 16r2763 16r441 16r2764 16r442 16r2765 16r443 16r2766 16r444 16r2767 16r445 16r2768 16r446 16r2769 16r447 16r276A 16r448 16r276B 16r449 16r276C 16r44A 16r276D 16r44B 16r276E 16r44C 16r276F 16r44D 16r2770 16r44E 16r2771 16r44F 16r2821 16r2500 16r2822 16r2502 16r2823 16r250C 16r2824 16r2510 16r2825 16r2518 16r2826 16r2514 16r2827 16r251C 16r2828 16r252C 16r2829 16r2524 16r282A 16r2534 16r282B 16r253C 16r282C 16r2501 16r282D 16r2503 16r282E 16r250F 16r282F 16r2513 16r2830 16r251B 16r2831 16r2517 16r2832 16r2523 16r2833 16r2533 16r2834 16r252B 16r2835 16r253B 16r2836 16r254B 16r2837 16r2520 16r2838 16r252F 16r2839 16r2528 16r283A 16r2537 16r283B 16r253F 16r283C 16r251D 16r283D 16r2530 16r283E 16r2525 16r283F 16r2538 16r2840 16r2542 16r3021 16r4E9C 16r3022 16r5516 16r3023 16r5A03 16r3024 16r963F 16r3025 16r54C0 16r3026 16r611B 16r3027 16r6328 16r3028 16r59F6 16r3029 16r9022 16r302A 16r8475 16r302B 16r831C 16r302C 16r7A50 16r302D 16r60AA 16r302E 16r63E1 16r302F 16r6E25 16r3030 16r65ED 16r3031 16r8466 16r3032 16r82A6 16r3033 16r9BF5 16r3034 16r6893 16r3035 16r5727 16r3036 16r65A1 16r3037 16r6271 16r3038 16r5B9B 16r3039 16r59D0 16r303A 16r867B 16r303B 16r98F4 16r303C 16r7D62 16r303D 16r7DBE 16r303E 16r9B8E 16r303F 16r6216 16r3040 16r7C9F 16r3041 16r88B7 16r3042 16r5B89 16r3043 16r5EB5 16r3044 16r6309 16r3045 16r6697 16r3046 16r6848 16r3047 16r95C7 16r3048 16r978D 16r3049 16r674F 16r304A 16r4EE5 16r304B 16r4F0A 16r304C 16r4F4D 16r304D 16r4F9D 16r304E 16r5049 16r304F 16r56F2 16r3050 16r5937 16r3051 16r59D4 16r3052 16r5A01 16r3053 16r5C09 16r3054 16r60DF 16r3055 16r610F 16r3056 16r6170 16r3057 16r6613 16r3058 16r6905 16r3059 16r70BA 16r305A 16r754F 16r305B 16r7570 16r305C 16r79FB 16r305D 16r7DAD 16r305E 16r7DEF 16r305F 16r80C3 16r3060 16r840E 16r3061 16r8863 16r3062 16r8B02 16r3063 16r9055 16r3064 16r907A 16r3065 16r533B 16r3066 16r4E95 16r3067 16r4EA5 16r3068 16r57DF 16r3069 16r80B2 16r306A 16r90C1 16r306B 16r78EF 16r306C 16r4E00 16r306D 16r58F1 16r306E 16r6EA2 16r306F 16r9038 16r3070 16r7A32 16r3071 16r8328 16r3072 16r828B 16r3073 16r9C2F 16r3074 16r5141 16r3075 16r5370 16r3076 16r54BD 16r3077 16r54E1 16r3078 16r56E0 16r3079 16r59FB 16r307A 16r5F15 16r307B 16r98F2 16r307C 16r6DEB 16r307D 16r80E4 16r307E 16r852D 16r3121 16r9662 16r3122 16r9670 16r3123 16r96A0 16r3124 16r97FB 16r3125 16r540B 16r3126 16r53F3 16r3127 16r5B87 16r3128 16r70CF 16r3129 16r7FBD 16r312A 16r8FC2 16r312B 16r96E8 16r312C 16r536F 16r312D 16r9D5C 16r312E 16r7ABA 16r312F 16r4E11 16r3130 16r7893 16r3131 16r81FC 16r3132 16r6E26 16r3133 16r5618 16r3134 16r5504 16r3135 16r6B1D 16r3136 16r851A 16r3137 16r9C3B 16r3138 16r59E5 16r3139 16r53A9 16r313A 16r6D66 16r313B 16r74DC 16r313C 16r958F 16r313D 16r5642 16r313E 16r4E91 16r313F 16r904B 16r3140 16r96F2 16r3141 16r834F 16r3142 16r990C 16r3143 16r53E1 16r3144 16r55B6 16r3145 16r5B30 16r3146 16r5F71 16r3147 16r6620 16r3148 16r66F3 16r3149 16r6804 16r314A 16r6C38 16r314B 16r6CF3 16r314C 16r6D29 16r314D 16r745B 16r314E 16r76C8 16r314F 16r7A4E 16r3150 16r9834 16r3151 16r82F1 16r3152 16r885B 16r3153 16r8A60 16r3154 16r92ED 16r3155 16r6DB2 16r3156 16r75AB 16r3157 16r76CA 16r3158 16r99C5 16r3159 16r60A6 16r315A 16r8B01 16r315B 16r8D8A 16r315C 16r95B2 16r315D 16r698E 16r315E 16r53AD 16r315F 16r5186 16r3160 16r5712 16r3161 16r5830 16r3162 16r5944 16r3163 16r5BB4 16r3164 16r5EF6 16r3165 16r6028 16r3166 16r63A9 16r3167 16r63F4 16r3168 16r6CBF 16r3169 16r6F14 16r316A 16r708E 16r316B 16r7114 16r316C 16r7159 16r316D 16r71D5 16r316E 16r733F 16r316F 16r7E01 16r3170 16r8276 16r3171 16r82D1 16r3172 16r8597 16r3173 16r9060 16r3174 16r925B 16r3175 16r9D1B 16r3176 16r5869 16r3177 16r65BC 16r3178 16r6C5A 16r3179 16r7525 16r317A 16r51F9 16r317B 16r592E 16r317C 16r5965 16r317D 16r5F80 16r317E 16r5FDC 16r3221 16r62BC 16r3222 16r65FA 16r3223 16r6A2A 16r3224 16r6B27 16r3225 16r6BB4 16r3226 16r738B 16r3227 16r7FC1 16r3228 16r8956 16r3229 16r9D2C 16r322A 16r9D0E 16r322B 16r9EC4 16r322C 16r5CA1 16r322D 16r6C96 16r322E 16r837B 16r322F 16r5104 16r3230 16r5C4B 16r3231 16r61B6 16r3232 16r81C6 16r3233 16r6876 16r3234 16r7261 16r3235 16r4E59 16r3236 16r4FFA 16r3237 16r5378 16r3238 16r6069 16r3239 16r6E29 16r323A 16r7A4F 16r323B 16r97F3 16r323C 16r4E0B 16r323D 16r5316 16r323E 16r4EEE 16r323F 16r4F55 16r3240 16r4F3D 16r3241 16r4FA1 16r3242 16r4F73 16r3243 16r52A0 16r3244 16r53EF 16r3245 16r5609 16r3246 16r590F 16r3247 16r5AC1 16r3248 16r5BB6 16r3249 16r5BE1 16r324A 16r79D1 16r324B 16r6687 16r324C 16r679C 16r324D 16r67B6 16r324E 16r6B4C 16r324F 16r6CB3 16r3250 16r706B 16r3251 16r73C2 16r3252 16r798D 16r3253 16r79BE 16r3254 16r7A3C 16r3255 16r7B87 16r3256 16r82B1 16r3257 16r82DB 16r3258 16r8304 16r3259 16r8377 16r325A 16r83EF 16r325B 16r83D3 16r325C 16r8766 16r325D 16r8AB2 16r325E 16r5629 16r325F 16r8CA8 16r3260 16r8FE6 16r3261 16r904E 16r3262 16r971E 16r3263 16r868A 16r3264 16r4FC4 16r3265 16r5CE8 16r3266 16r6211 16r3267 16r7259 16r3268 16r753B 16r3269 16r81E5 16r326A 16r82BD 16r326B 16r86FE 16r326C 16r8CC0 16r326D 16r96C5 16r326E 16r9913 16r326F 16r99D5 16r3270 16r4ECB 16r3271 16r4F1A 16r3272 16r89E3 16r3273 16r56DE 16r3274 16r584A 16r3275 16r58CA 16r3276 16r5EFB 16r3277 16r5FEB 16r3278 16r602A 16r3279 16r6094 16r327A 16r6062 16r327B 16r61D0 16r327C 16r6212 16r327D 16r62D0 16r327E 16r6539 16r3321 16r9B41 16r3322 16r6666 16r3323 16r68B0 16r3324 16r6D77 16r3325 16r7070 16r3326 16r754C 16r3327 16r7686 16r3328 16r7D75 16r3329 16r82A5 16r332A 16r87F9 16r332B 16r958B 16r332C 16r968E 16r332D 16r8C9D 16r332E 16r51F1 16r332F 16r52BE 16r3330 16r5916 16r3331 16r54B3 16r3332 16r5BB3 16r3333 16r5D16 16r3334 16r6168 16r3335 16r6982 16r3336 16r6DAF 16r3337 16r788D 16r3338 16r84CB 16r3339 16r8857 16r333A 16r8A72 16r333B 16r93A7 16r333C 16r9AB8 16r333D 16r6D6C 16r333E 16r99A8 16r333F 16r86D9 16r3340 16r57A3 16r3341 16r67FF 16r3342 16r86CE 16r3343 16r920E 16r3344 16r5283 16r3345 16r5687 16r3346 16r5404 16r3347 16r5ED3 16r3348 16r62E1 16r3349 16r64B9 16r334A 16r683C 16r334B 16r6838 16r334C 16r6BBB 16r334D 16r7372 16r334E 16r78BA 16r334F 16r7A6B 16r3350 16r899A 16r3351 16r89D2 16r3352 16r8D6B 16r3353 16r8F03 16r3354 16r90ED 16r3355 16r95A3 16r3356 16r9694 16r3357 16r9769 16r3358 16r5B66 16r3359 16r5CB3 16r335A 16r697D 16r335B 16r984D 16r335C 16r984E 16r335D 16r639B 16r335E 16r7B20 16r335F 16r6A2B 16r3360 16r6A7F 16r3361 16r68B6 16r3362 16r9C0D 16r3363 16r6F5F 16r3364 16r5272 16r3365 16r559D 16r3366 16r6070 16r3367 16r62EC 16r3368 16r6D3B 16r3369 16r6E07 16r336A 16r6ED1 16r336B 16r845B 16r336C 16r8910 16r336D 16r8F44 16r336E 16r4E14 16r336F 16r9C39 16r3370 16r53F6 16r3371 16r691B 16r3372 16r6A3A 16r3373 16r9784 16r3374 16r682A 16r3375 16r515C 16r3376 16r7AC3 16r3377 16r84B2 16r3378 16r91DC 16r3379 16r938C 16r337A 16r565B 16r337B 16r9D28 16r337C 16r6822 16r337D 16r8305 16r337E 16r8431 16r3421 16r7CA5 16r3422 16r5208 16r3423 16r82C5 16r3424 16r74E6 16r3425 16r4E7E 16r3426 16r4F83 16r3427 16r51A0 16r3428 16r5BD2 16r3429 16r520A 16r342A 16r52D8 16r342B 16r52E7 16r342C 16r5DFB 16r342D 16r559A 16r342E 16r582A 16r342F 16r59E6 16r3430 16r5B8C 16r3431 16r5B98 16r3432 16r5BDB 16r3433 16r5E72 16r3434 16r5E79 16r3435 16r60A3 16r3436 16r611F 16r3437 16r6163 16r3438 16r61BE 16r3439 16r63DB 16r343A 16r6562 16r343B 16r67D1 16r343C 16r6853 16r343D 16r68FA 16r343E 16r6B3E 16r343F 16r6B53 16r3440 16r6C57 16r3441 16r6F22 16r3442 16r6F97 16r3443 16r6F45 16r3444 16r74B0 16r3445 16r7518 16r3446 16r76E3 16r3447 16r770B 16r3448 16r7AFF 16r3449 16r7BA1 16r344A 16r7C21 16r344B 16r7DE9 16r344C 16r7F36 16r344D 16r7FF0 16r344E 16r809D 16r344F 16r8266 16r3450 16r839E 16r3451 16r89B3 16r3452 16r8ACC 16r3453 16r8CAB 16r3454 16r9084 16r3455 16r9451 16r3456 16r9593 16r3457 16r9591 16r3458 16r95A2 16r3459 16r9665 16r345A 16r97D3 16r345B 16r9928 16r345C 16r8218 16r345D 16r4E38 16r345E 16r542B 16r345F 16r5CB8 16r3460 16r5DCC 16r3461 16r73A9 16r3462 16r764C 16r3463 16r773C 16r3464 16r5CA9 16r3465 16r7FEB 16r3466 16r8D0B 16r3467 16r96C1 16r3468 16r9811 16r3469 16r9854 16r346A 16r9858 16r346B 16r4F01 16r346C 16r4F0E 16r346D 16r5371 16r346E 16r559C 16r346F 16r5668 16r3470 16r57FA 16r3471 16r5947 16r3472 16r5B09 16r3473 16r5BC4 16r3474 16r5C90 16r3475 16r5E0C 16r3476 16r5E7E 16r3477 16r5FCC 16r3478 16r63EE 16r3479 16r673A 16r347A 16r65D7 16r347B 16r65E2 16r347C 16r671F 16r347D 16r68CB 16r347E 16r68C4 16r3521 16r6A5F 16r3522 16r5E30 16r3523 16r6BC5 16r3524 16r6C17 16r3525 16r6C7D 16r3526 16r757F 16r3527 16r7948 16r3528 16r5B63 16r3529 16r7A00 16r352A 16r7D00 16r352B 16r5FBD 16r352C 16r898F 16r352D 16r8A18 16r352E 16r8CB4 16r352F 16r8D77 16r3530 16r8ECC 16r3531 16r8F1D 16r3532 16r98E2 16r3533 16r9A0E 16r3534 16r9B3C 16r3535 16r4E80 16r3536 16r507D 16r3537 16r5100 16r3538 16r5993 16r3539 16r5B9C 16r353A 16r622F 16r353B 16r6280 16r353C 16r64EC 16r353D 16r6B3A 16r353E 16r72A0 16r353F 16r7591 16r3540 16r7947 16r3541 16r7FA9 16r3542 16r87FB 16r3543 16r8ABC 16r3544 16r8B70 16r3545 16r63AC 16r3546 16r83CA 16r3547 16r97A0 16r3548 16r5409 16r3549 16r5403 16r354A 16r55AB 16r354B 16r6854 16r354C 16r6A58 16r354D 16r8A70 16r354E 16r7827 16r354F 16r6775 16r3550 16r9ECD 16r3551 16r5374 16r3552 16r5BA2 16r3553 16r811A 16r3554 16r8650 16r3555 16r9006 16r3556 16r4E18 16r3557 16r4E45 16r3558 16r4EC7 16r3559 16r4F11 16r355A 16r53CA 16r355B 16r5438 16r355C 16r5BAE 16r355D 16r5F13 16r355E 16r6025 16r355F 16r6551 16r3560 16r673D 16r3561 16r6C42 16r3562 16r6C72 16r3563 16r6CE3 16r3564 16r7078 16r3565 16r7403 16r3566 16r7A76 16r3567 16r7AAE 16r3568 16r7B08 16r3569 16r7D1A 16r356A 16r7CFE 16r356B 16r7D66 16r356C 16r65E7 16r356D 16r725B 16r356E 16r53BB 16r356F 16r5C45 16r3570 16r5DE8 16r3571 16r62D2 16r3572 16r62E0 16r3573 16r6319 16r3574 16r6E20 16r3575 16r865A 16r3576 16r8A31 16r3577 16r8DDD 16r3578 16r92F8 16r3579 16r6F01 16r357A 16r79A6 16r357B 16r9B5A 16r357C 16r4EA8 16r357D 16r4EAB 16r357E 16r4EAC 16r3621 16r4F9B 16r3622 16r4FA0 16r3623 16r50D1 16r3624 16r5147 16r3625 16r7AF6 16r3626 16r5171 16r3627 16r51F6 16r3628 16r5354 16r3629 16r5321 16r362A 16r537F 16r362B 16r53EB 16r362C 16r55AC 16r362D 16r5883 16r362E 16r5CE1 16r362F 16r5F37 16r3630 16r5F4A 16r3631 16r602F 16r3632 16r6050 16r3633 16r606D 16r3634 16r631F 16r3635 16r6559 16r3636 16r6A4B 16r3637 16r6CC1 16r3638 16r72C2 16r3639 16r72ED 16r363A 16r77EF 16r363B 16r80F8 16r363C 16r8105 16r363D 16r8208 16r363E 16r854E 16r363F 16r90F7 16r3640 16r93E1 16r3641 16r97FF 16r3642 16r9957 16r3643 16r9A5A 16r3644 16r4EF0 16r3645 16r51DD 16r3646 16r5C2D 16r3647 16r6681 16r3648 16r696D 16r3649 16r5C40 16r364A 16r66F2 16r364B 16r6975 16r364C 16r7389 16r364D 16r6850 16r364E 16r7C81 16r364F 16r50C5 16r3650 16r52E4 16r3651 16r5747 16r3652 16r5DFE 16r3653 16r9326 16r3654 16r65A4 16r3655 16r6B23 16r3656 16r6B3D 16r3657 16r7434 16r3658 16r7981 16r3659 16r79BD 16r365A 16r7B4B 16r365B 16r7DCA 16r365C 16r82B9 16r365D 16r83CC 16r365E 16r887F 16r365F 16r895F 16r3660 16r8B39 16r3661 16r8FD1 16r3662 16r91D1 16r3663 16r541F 16r3664 16r9280 16r3665 16r4E5D 16r3666 16r5036 16r3667 16r53E5 16r3668 16r533A 16r3669 16r72D7 16r366A 16r7396 16r366B 16r77E9 16r366C 16r82E6 16r366D 16r8EAF 16r366E 16r99C6 16r366F 16r99C8 16r3670 16r99D2 16r3671 16r5177 16r3672 16r611A 16r3673 16r865E 16r3674 16r55B0 16r3675 16r7A7A 16r3676 16r5076 16r3677 16r5BD3 16r3678 16r9047 16r3679 16r9685 16r367A 16r4E32 16r367B 16r6ADB 16r367C 16r91E7 16r367D 16r5C51 16r367E 16r5C48 16r3721 16r6398 16r3722 16r7A9F 16r3723 16r6C93 16r3724 16r9774 16r3725 16r8F61 16r3726 16r7AAA 16r3727 16r718A 16r3728 16r9688 16r3729 16r7C82 16r372A 16r6817 16r372B 16r7E70 16r372C 16r6851 16r372D 16r936C 16r372E 16r52F2 16r372F 16r541B 16r3730 16r85AB 16r3731 16r8A13 16r3732 16r7FA4 16r3733 16r8ECD 16r3734 16r90E1 16r3735 16r5366 16r3736 16r8888 16r3737 16r7941 16r3738 16r4FC2 16r3739 16r50BE 16r373A 16r5211 16r373B 16r5144 16r373C 16r5553 16r373D 16r572D 16r373E 16r73EA 16r373F 16r578B 16r3740 16r5951 16r3741 16r5F62 16r3742 16r5F84 16r3743 16r6075 16r3744 16r6176 16r3745 16r6167 16r3746 16r61A9 16r3747 16r63B2 16r3748 16r643A 16r3749 16r656C 16r374A 16r666F 16r374B 16r6842 16r374C 16r6E13 16r374D 16r7566 16r374E 16r7A3D 16r374F 16r7CFB 16r3750 16r7D4C 16r3751 16r7D99 16r3752 16r7E4B 16r3753 16r7F6B 16r3754 16r830E 16r3755 16r834A 16r3756 16r86CD 16r3757 16r8A08 16r3758 16r8A63 16r3759 16r8B66 16r375A 16r8EFD 16r375B 16r981A 16r375C 16r9D8F 16r375D 16r82B8 16r375E 16r8FCE 16r375F 16r9BE8 16r3760 16r5287 16r3761 16r621F 16r3762 16r6483 16r3763 16r6FC0 16r3764 16r9699 16r3765 16r6841 16r3766 16r5091 16r3767 16r6B20 16r3768 16r6C7A 16r3769 16r6F54 16r376A 16r7A74 16r376B 16r7D50 16r376C 16r8840 16r376D 16r8A23 16r376E 16r6708 16r376F 16r4EF6 16r3770 16r5039 16r3771 16r5026 16r3772 16r5065 16r3773 16r517C 16r3774 16r5238 16r3775 16r5263 16r3776 16r55A7 16r3777 16r570F 16r3778 16r5805 16r3779 16r5ACC 16r377A 16r5EFA 16r377B 16r61B2 16r377C 16r61F8 16r377D 16r62F3 16r377E 16r6372 16r3821 16r691C 16r3822 16r6A29 16r3823 16r727D 16r3824 16r72AC 16r3825 16r732E 16r3826 16r7814 16r3827 16r786F 16r3828 16r7D79 16r3829 16r770C 16r382A 16r80A9 16r382B 16r898B 16r382C 16r8B19 16r382D 16r8CE2 16r382E 16r8ED2 16r382F 16r9063 16r3830 16r9375 16r3831 16r967A 16r3832 16r9855 16r3833 16r9A13 16r3834 16r9E78 16r3835 16r5143 16r3836 16r539F 16r3837 16r53B3 16r3838 16r5E7B 16r3839 16r5F26 16r383A 16r6E1B 16r383B 16r6E90 16r383C 16r7384 16r383D 16r73FE 16r383E 16r7D43 16r383F 16r8237 16r3840 16r8A00 16r3841 16r8AFA 16r3842 16r9650 16r3843 16r4E4E 16r3844 16r500B 16r3845 16r53E4 16r3846 16r547C 16r3847 16r56FA 16r3848 16r59D1 16r3849 16r5B64 16r384A 16r5DF1 16r384B 16r5EAB 16r384C 16r5F27 16r384D 16r6238 16r384E 16r6545 16r384F 16r67AF 16r3850 16r6E56 16r3851 16r72D0 16r3852 16r7CCA 16r3853 16r88B4 16r3854 16r80A1 16r3855 16r80E1 16r3856 16r83F0 16r3857 16r864E 16r3858 16r8A87 16r3859 16r8DE8 16r385A 16r9237 16r385B 16r96C7 16r385C 16r9867 16r385D 16r9F13 16r385E 16r4E94 16r385F 16r4E92 16r3860 16r4F0D 16r3861 16r5348 16r3862 16r5449 16r3863 16r543E 16r3864 16r5A2F 16r3865 16r5F8C 16r3866 16r5FA1 16r3867 16r609F 16r3868 16r68A7 16r3869 16r6A8E 16r386A 16r745A 16r386B 16r7881 16r386C 16r8A9E 16r386D 16r8AA4 16r386E 16r8B77 16r386F 16r9190 16r3870 16r4E5E 16r3871 16r9BC9 16r3872 16r4EA4 16r3873 16r4F7C 16r3874 16r4FAF 16r3875 16r5019 16r3876 16r5016 16r3877 16r5149 16r3878 16r516C 16r3879 16r529F 16r387A 16r52B9 16r387B 16r52FE 16r387C 16r539A 16r387D 16r53E3 16r387E 16r5411 16r3921 16r540E 16r3922 16r5589 16r3923 16r5751 16r3924 16r57A2 16r3925 16r597D 16r3926 16r5B54 16r3927 16r5B5D 16r3928 16r5B8F 16r3929 16r5DE5 16r392A 16r5DE7 16r392B 16r5DF7 16r392C 16r5E78 16r392D 16r5E83 16r392E 16r5E9A 16r392F 16r5EB7 16r3930 16r5F18 16r3931 16r6052 16r3932 16r614C 16r3933 16r6297 16r3934 16r62D8 16r3935 16r63A7 16r3936 16r653B 16r3937 16r6602 16r3938 16r6643 16r3939 16r66F4 16r393A 16r676D 16r393B 16r6821 16r393C 16r6897 16r393D 16r69CB 16r393E 16r6C5F 16r393F 16r6D2A 16r3940 16r6D69 16r3941 16r6E2F 16r3942 16r6E9D 16r3943 16r7532 16r3944 16r7687 16r3945 16r786C 16r3946 16r7A3F 16r3947 16r7CE0 16r3948 16r7D05 16r3949 16r7D18 16r394A 16r7D5E 16r394B 16r7DB1 16r394C 16r8015 16r394D 16r8003 16r394E 16r80AF 16r394F 16r80B1 16r3950 16r8154 16r3951 16r818F 16r3952 16r822A 16r3953 16r8352 16r3954 16r884C 16r3955 16r8861 16r3956 16r8B1B 16r3957 16r8CA2 16r3958 16r8CFC 16r3959 16r90CA 16r395A 16r9175 16r395B 16r9271 16r395C 16r783F 16r395D 16r92FC 16r395E 16r95A4 16r395F 16r964D 16r3960 16r9805 16r3961 16r9999 16r3962 16r9AD8 16r3963 16r9D3B 16r3964 16r525B 16r3965 16r52AB 16r3966 16r53F7 16r3967 16r5408 16r3968 16r58D5 16r3969 16r62F7 16r396A 16r6FE0 16r396B 16r8C6A 16r396C 16r8F5F 16r396D 16r9EB9 16r396E 16r514B 16r396F 16r523B 16r3970 16r544A 16r3971 16r56FD 16r3972 16r7A40 16r3973 16r9177 16r3974 16r9D60 16r3975 16r9ED2 16r3976 16r7344 16r3977 16r6F09 16r3978 16r8170 16r3979 16r7511 16r397A 16r5FFD 16r397B 16r60DA 16r397C 16r9AA8 16r397D 16r72DB 16r397E 16r8FBC 16r3A21 16r6B64 16r3A22 16r9803 16r3A23 16r4ECA 16r3A24 16r56F0 16r3A25 16r5764 16r3A26 16r58BE 16r3A27 16r5A5A 16r3A28 16r6068 16r3A29 16r61C7 16r3A2A 16r660F 16r3A2B 16r6606 16r3A2C 16r6839 16r3A2D 16r68B1 16r3A2E 16r6DF7 16r3A2F 16r75D5 16r3A30 16r7D3A 16r3A31 16r826E 16r3A32 16r9B42 16r3A33 16r4E9B 16r3A34 16r4F50 16r3A35 16r53C9 16r3A36 16r5506 16r3A37 16r5D6F 16r3A38 16r5DE6 16r3A39 16r5DEE 16r3A3A 16r67FB 16r3A3B 16r6C99 16r3A3C 16r7473 16r3A3D 16r7802 16r3A3E 16r8A50 16r3A3F 16r9396 16r3A40 16r88DF 16r3A41 16r5750 16r3A42 16r5EA7 16r3A43 16r632B 16r3A44 16r50B5 16r3A45 16r50AC 16r3A46 16r518D 16r3A47 16r6700 16r3A48 16r54C9 16r3A49 16r585E 16r3A4A 16r59BB 16r3A4B 16r5BB0 16r3A4C 16r5F69 16r3A4D 16r624D 16r3A4E 16r63A1 16r3A4F 16r683D 16r3A50 16r6B73 16r3A51 16r6E08 16r3A52 16r707D 16r3A53 16r91C7 16r3A54 16r7280 16r3A55 16r7815 16r3A56 16r7826 16r3A57 16r796D 16r3A58 16r658E 16r3A59 16r7D30 16r3A5A 16r83DC 16r3A5B 16r88C1 16r3A5C 16r8F09 16r3A5D 16r969B 16r3A5E 16r5264 16r3A5F 16r5728 16r3A60 16r6750 16r3A61 16r7F6A 16r3A62 16r8CA1 16r3A63 16r51B4 16r3A64 16r5742 16r3A65 16r962A 16r3A66 16r583A 16r3A67 16r698A 16r3A68 16r80B4 16r3A69 16r54B2 16r3A6A 16r5D0E 16r3A6B 16r57FC 16r3A6C 16r7895 16r3A6D 16r9DFA 16r3A6E 16r4F5C 16r3A6F 16r524A 16r3A70 16r548B 16r3A71 16r643E 16r3A72 16r6628 16r3A73 16r6714 16r3A74 16r67F5 16r3A75 16r7A84 16r3A76 16r7B56 16r3A77 16r7D22 16r3A78 16r932F 16r3A79 16r685C 16r3A7A 16r9BAD 16r3A7B 16r7B39 16r3A7C 16r5319 16r3A7D 16r518A 16r3A7E 16r5237 16r3B21 16r5BDF 16r3B22 16r62F6 16r3B23 16r64AE 16r3B24 16r64E6 16r3B25 16r672D 16r3B26 16r6BBA 16r3B27 16r85A9 16r3B28 16r96D1 16r3B29 16r7690 16r3B2A 16r9BD6 16r3B2B 16r634C 16r3B2C 16r9306 16r3B2D 16r9BAB 16r3B2E 16r76BF 16r3B2F 16r6652 16r3B30 16r4E09 16r3B31 16r5098 16r3B32 16r53C2 16r3B33 16r5C71 16r3B34 16r60E8 16r3B35 16r6492 16r3B36 16r6563 16r3B37 16r685F 16r3B38 16r71E6 16r3B39 16r73CA 16r3B3A 16r7523 16r3B3B 16r7B97 16r3B3C 16r7E82 16r3B3D 16r8695 16r3B3E 16r8B83 16r3B3F 16r8CDB 16r3B40 16r9178 16r3B41 16r9910 16r3B42 16r65AC 16r3B43 16r66AB 16r3B44 16r6B8B 16r3B45 16r4ED5 16r3B46 16r4ED4 16r3B47 16r4F3A 16r3B48 16r4F7F 16r3B49 16r523A 16r3B4A 16r53F8 16r3B4B 16r53F2 16r3B4C 16r55E3 16r3B4D 16r56DB 16r3B4E 16r58EB 16r3B4F 16r59CB 16r3B50 16r59C9 16r3B51 16r59FF 16r3B52 16r5B50 16r3B53 16r5C4D 16r3B54 16r5E02 16r3B55 16r5E2B 16r3B56 16r5FD7 16r3B57 16r601D 16r3B58 16r6307 16r3B59 16r652F 16r3B5A 16r5B5C 16r3B5B 16r65AF 16r3B5C 16r65BD 16r3B5D 16r65E8 16r3B5E 16r679D 16r3B5F 16r6B62 16r3B60 16r6B7B 16r3B61 16r6C0F 16r3B62 16r7345 16r3B63 16r7949 16r3B64 16r79C1 16r3B65 16r7CF8 16r3B66 16r7D19 16r3B67 16r7D2B 16r3B68 16r80A2 16r3B69 16r8102 16r3B6A 16r81F3 16r3B6B 16r8996 16r3B6C 16r8A5E 16r3B6D 16r8A69 16r3B6E 16r8A66 16r3B6F 16r8A8C 16r3B70 16r8AEE 16r3B71 16r8CC7 16r3B72 16r8CDC 16r3B73 16r96CC 16r3B74 16r98FC 16r3B75 16r6B6F 16r3B76 16r4E8B 16r3B77 16r4F3C 16r3B78 16r4F8D 16r3B79 16r5150 16r3B7A 16r5B57 16r3B7B 16r5BFA 16r3B7C 16r6148 16r3B7D 16r6301 16r3B7E 16r6642 16r3C21 16r6B21 16r3C22 16r6ECB 16r3C23 16r6CBB 16r3C24 16r723E 16r3C25 16r74BD 16r3C26 16r75D4 16r3C27 16r78C1 16r3C28 16r793A 16r3C29 16r800C 16r3C2A 16r8033 16r3C2B 16r81EA 16r3C2C 16r8494 16r3C2D 16r8F9E 16r3C2E 16r6C50 16r3C2F 16r9E7F 16r3C30 16r5F0F 16r3C31 16r8B58 16r3C32 16r9D2B 16r3C33 16r7AFA 16r3C34 16r8EF8 16r3C35 16r5B8D 16r3C36 16r96EB 16r3C37 16r4E03 16r3C38 16r53F1 16r3C39 16r57F7 16r3C3A 16r5931 16r3C3B 16r5AC9 16r3C3C 16r5BA4 16r3C3D 16r6089 16r3C3E 16r6E7F 16r3C3F 16r6F06 16r3C40 16r75BE 16r3C41 16r8CEA 16r3C42 16r5B9F 16r3C43 16r8500 16r3C44 16r7BE0 16r3C45 16r5072 16r3C46 16r67F4 16r3C47 16r829D 16r3C48 16r5C61 16r3C49 16r854A 16r3C4A 16r7E1E 16r3C4B 16r820E 16r3C4C 16r5199 16r3C4D 16r5C04 16r3C4E 16r6368 16r3C4F 16r8D66 16r3C50 16r659C 16r3C51 16r716E 16r3C52 16r793E 16r3C53 16r7D17 16r3C54 16r8005 16r3C55 16r8B1D 16r3C56 16r8ECA 16r3C57 16r906E 16r3C58 16r86C7 16r3C59 16r90AA 16r3C5A 16r501F 16r3C5B 16r52FA 16r3C5C 16r5C3A 16r3C5D 16r6753 16r3C5E 16r707C 16r3C5F 16r7235 16r3C60 16r914C 16r3C61 16r91C8 16r3C62 16r932B 16r3C63 16r82E5 16r3C64 16r5BC2 16r3C65 16r5F31 16r3C66 16r60F9 16r3C67 16r4E3B 16r3C68 16r53D6 16r3C69 16r5B88 16r3C6A 16r624B 16r3C6B 16r6731 16r3C6C 16r6B8A 16r3C6D 16r72E9 16r3C6E 16r73E0 16r3C6F 16r7A2E 16r3C70 16r816B 16r3C71 16r8DA3 16r3C72 16r9152 16r3C73 16r9996 16r3C74 16r5112 16r3C75 16r53D7 16r3C76 16r546A 16r3C77 16r5BFF 16r3C78 16r6388 16r3C79 16r6A39 16r3C7A 16r7DAC 16r3C7B 16r9700 16r3C7C 16r56DA 16r3C7D 16r53CE 16r3C7E 16r5468 16r3D21 16r5B97 16r3D22 16r5C31 16r3D23 16r5DDE 16r3D24 16r4FEE 16r3D25 16r6101 16r3D26 16r62FE 16r3D27 16r6D32 16r3D28 16r79C0 16r3D29 16r79CB 16r3D2A 16r7D42 16r3D2B 16r7E4D 16r3D2C 16r7FD2 16r3D2D 16r81ED 16r3D2E 16r821F 16r3D2F 16r8490 16r3D30 16r8846 16r3D31 16r8972 16r3D32 16r8B90 16r3D33 16r8E74 16r3D34 16r8F2F 16r3D35 16r9031 16r3D36 16r914B 16r3D37 16r916C 16r3D38 16r96C6 16r3D39 16r919C 16r3D3A 16r4EC0 16r3D3B 16r4F4F 16r3D3C 16r5145 16r3D3D 16r5341 16r3D3E 16r5F93 16r3D3F 16r620E 16r3D40 16r67D4 16r3D41 16r6C41 16r3D42 16r6E0B 16r3D43 16r7363 16r3D44 16r7E26 16r3D45 16r91CD 16r3D46 16r9283 16r3D47 16r53D4 16r3D48 16r5919 16r3D49 16r5BBF 16r3D4A 16r6DD1 16r3D4B 16r795D 16r3D4C 16r7E2E 16r3D4D 16r7C9B 16r3D4E 16r587E 16r3D4F 16r719F 16r3D50 16r51FA 16r3D51 16r8853 16r3D52 16r8FF0 16r3D53 16r4FCA 16r3D54 16r5CFB 16r3D55 16r6625 16r3D56 16r77AC 16r3D57 16r7AE3 16r3D58 16r821C 16r3D59 16r99FF 16r3D5A 16r51C6 16r3D5B 16r5FAA 16r3D5C 16r65EC 16r3D5D 16r696F 16r3D5E 16r6B89 16r3D5F 16r6DF3 16r3D60 16r6E96 16r3D61 16r6F64 16r3D62 16r76FE 16r3D63 16r7D14 16r3D64 16r5DE1 16r3D65 16r9075 16r3D66 16r9187 16r3D67 16r9806 16r3D68 16r51E6 16r3D69 16r521D 16r3D6A 16r6240 16r3D6B 16r6691 16r3D6C 16r66D9 16r3D6D 16r6E1A 16r3D6E 16r5EB6 16r3D6F 16r7DD2 16r3D70 16r7F72 16r3D71 16r66F8 16r3D72 16r85AF 16r3D73 16r85F7 16r3D74 16r8AF8 16r3D75 16r52A9 16r3D76 16r53D9 16r3D77 16r5973 16r3D78 16r5E8F 16r3D79 16r5F90 16r3D7A 16r6055 16r3D7B 16r92E4 16r3D7C 16r9664 16r3D7D 16r50B7 16r3D7E 16r511F 16r3E21 16r52DD 16r3E22 16r5320 16r3E23 16r5347 16r3E24 16r53EC 16r3E25 16r54E8 16r3E26 16r5546 16r3E27 16r5531 16r3E28 16r5617 16r3E29 16r5968 16r3E2A 16r59BE 16r3E2B 16r5A3C 16r3E2C 16r5BB5 16r3E2D 16r5C06 16r3E2E 16r5C0F 16r3E2F 16r5C11 16r3E30 16r5C1A 16r3E31 16r5E84 16r3E32 16r5E8A 16r3E33 16r5EE0 16r3E34 16r5F70 16r3E35 16r627F 16r3E36 16r6284 16r3E37 16r62DB 16r3E38 16r638C 16r3E39 16r6377 16r3E3A 16r6607 16r3E3B 16r660C 16r3E3C 16r662D 16r3E3D 16r6676 16r3E3E 16r677E 16r3E3F 16r68A2 16r3E40 16r6A1F 16r3E41 16r6A35 16r3E42 16r6CBC 16r3E43 16r6D88 16r3E44 16r6E09 16r3E45 16r6E58 16r3E46 16r713C 16r3E47 16r7126 16r3E48 16r7167 16r3E49 16r75C7 16r3E4A 16r7701 16r3E4B 16r785D 16r3E4C 16r7901 16r3E4D 16r7965 16r3E4E 16r79F0 16r3E4F 16r7AE0 16r3E50 16r7B11 16r3E51 16r7CA7 16r3E52 16r7D39 16r3E53 16r8096 16r3E54 16r83D6 16r3E55 16r848B 16r3E56 16r8549 16r3E57 16r885D 16r3E58 16r88F3 16r3E59 16r8A1F 16r3E5A 16r8A3C 16r3E5B 16r8A54 16r3E5C 16r8A73 16r3E5D 16r8C61 16r3E5E 16r8CDE 16r3E5F 16r91A4 16r3E60 16r9266 16r3E61 16r937E 16r3E62 16r9418 16r3E63 16r969C 16r3E64 16r9798 16r3E65 16r4E0A 16r3E66 16r4E08 16r3E67 16r4E1E 16r3E68 16r4E57 16r3E69 16r5197 16r3E6A 16r5270 16r3E6B 16r57CE 16r3E6C 16r5834 16r3E6D 16r58CC 16r3E6E 16r5B22 16r3E6F 16r5E38 16r3E70 16r60C5 16r3E71 16r64FE 16r3E72 16r6761 16r3E73 16r6756 16r3E74 16r6D44 16r3E75 16r72B6 16r3E76 16r7573 16r3E77 16r7A63 16r3E78 16r84B8 16r3E79 16r8B72 16r3E7A 16r91B8 16r3E7B 16r9320 16r3E7C 16r5631 16r3E7D 16r57F4 16r3E7E 16r98FE 16r3F21 16r62ED 16r3F22 16r690D 16r3F23 16r6B96 16r3F24 16r71ED 16r3F25 16r7E54 16r3F26 16r8077 16r3F27 16r8272 16r3F28 16r89E6 16r3F29 16r98DF 16r3F2A 16r8755 16r3F2B 16r8FB1 16r3F2C 16r5C3B 16r3F2D 16r4F38 16r3F2E 16r4FE1 16r3F2F 16r4FB5 16r3F30 16r5507 16r3F31 16r5A20 16r3F32 16r5BDD 16r3F33 16r5BE9 16r3F34 16r5FC3 16r3F35 16r614E 16r3F36 16r632F 16r3F37 16r65B0 16r3F38 16r664B 16r3F39 16r68EE 16r3F3A 16r699B 16r3F3B 16r6D78 16r3F3C 16r6DF1 16r3F3D 16r7533 16r3F3E 16r75B9 16r3F3F 16r771F 16r3F40 16r795E 16r3F41 16r79E6 16r3F42 16r7D33 16r3F43 16r81E3 16r3F44 16r82AF 16r3F45 16r85AA 16r3F46 16r89AA 16r3F47 16r8A3A 16r3F48 16r8EAB 16r3F49 16r8F9B 16r3F4A 16r9032 16r3F4B 16r91DD 16r3F4C 16r9707 16r3F4D 16r4EBA 16r3F4E 16r4EC1 16r3F4F 16r5203 16r3F50 16r5875 16r3F51 16r58EC 16r3F52 16r5C0B 16r3F53 16r751A 16r3F54 16r5C3D 16r3F55 16r814E 16r3F56 16r8A0A 16r3F57 16r8FC5 16r3F58 16r9663 16r3F59 16r976D 16r3F5A 16r7B25 16r3F5B 16r8ACF 16r3F5C 16r9808 16r3F5D 16r9162 16r3F5E 16r56F3 16r3F5F 16r53A8 16r3F60 16r9017 16r3F61 16r5439 16r3F62 16r5782 16r3F63 16r5E25 16r3F64 16r63A8 16r3F65 16r6C34 16r3F66 16r708A 16r3F67 16r7761 16r3F68 16r7C8B 16r3F69 16r7FE0 16r3F6A 16r8870 16r3F6B 16r9042 16r3F6C 16r9154 16r3F6D 16r9310 16r3F6E 16r9318 16r3F6F 16r968F 16r3F70 16r745E 16r3F71 16r9AC4 16r3F72 16r5D07 16r3F73 16r5D69 16r3F74 16r6570 16r3F75 16r67A2 16r3F76 16r8DA8 16r3F77 16r96DB 16r3F78 16r636E 16r3F79 16r6749 16r3F7A 16r6919 16r3F7B 16r83C5 16r3F7C 16r9817 16r3F7D 16r96C0 16r3F7E 16r88FE 16r4021 16r6F84 16r4022 16r647A 16r4023 16r5BF8 16r4024 16r4E16 16r4025 16r702C 16r4026 16r755D 16r4027 16r662F 16r4028 16r51C4 16r4029 16r5236 16r402A 16r52E2 16r402B 16r59D3 16r402C 16r5F81 16r402D 16r6027 16r402E 16r6210 16r402F 16r653F 16r4030 16r6574 16r4031 16r661F 16r4032 16r6674 16r4033 16r68F2 16r4034 16r6816 16r4035 16r6B63 16r4036 16r6E05 16r4037 16r7272 16r4038 16r751F 16r4039 16r76DB 16r403A 16r7CBE 16r403B 16r8056 16r403C 16r58F0 16r403D 16r88FD 16r403E 16r897F 16r403F 16r8AA0 16r4040 16r8A93 16r4041 16r8ACB 16r4042 16r901D 16r4043 16r9192 16r4044 16r9752 16r4045 16r9759 16r4046 16r6589 16r4047 16r7A0E 16r4048 16r8106 16r4049 16r96BB 16r404A 16r5E2D 16r404B 16r60DC 16r404C 16r621A 16r404D 16r65A5 16r404E 16r6614 16r404F 16r6790 16r4050 16r77F3 16r4051 16r7A4D 16r4052 16r7C4D 16r4053 16r7E3E 16r4054 16r810A 16r4055 16r8CAC 16r4056 16r8D64 16r4057 16r8DE1 16r4058 16r8E5F 16r4059 16r78A9 16r405A 16r5207 16r405B 16r62D9 16r405C 16r63A5 16r405D 16r6442 16r405E 16r6298 16r405F 16r8A2D 16r4060 16r7A83 16r4061 16r7BC0 16r4062 16r8AAC 16r4063 16r96EA 16r4064 16r7D76 16r4065 16r820C 16r4066 16r8749 16r4067 16r4ED9 16r4068 16r5148 16r4069 16r5343 16r406A 16r5360 16r406B 16r5BA3 16r406C 16r5C02 16r406D 16r5C16 16r406E 16r5DDD 16r406F 16r6226 16r4070 16r6247 16r4071 16r64B0 16r4072 16r6813 16r4073 16r6834 16r4074 16r6CC9 16r4075 16r6D45 16r4076 16r6D17 16r4077 16r67D3 16r4078 16r6F5C 16r4079 16r714E 16r407A 16r717D 16r407B 16r65CB 16r407C 16r7A7F 16r407D 16r7BAD 16r407E 16r7DDA 16r4121 16r7E4A 16r4122 16r7FA8 16r4123 16r817A 16r4124 16r821B 16r4125 16r8239 16r4126 16r85A6 16r4127 16r8A6E 16r4128 16r8CCE 16r4129 16r8DF5 16r412A 16r9078 16r412B 16r9077 16r412C 16r92AD 16r412D 16r9291 16r412E 16r9583 16r412F 16r9BAE 16r4130 16r524D 16r4131 16r5584 16r4132 16r6F38 16r4133 16r7136 16r4134 16r5168 16r4135 16r7985 16r4136 16r7E55 16r4137 16r81B3 16r4138 16r7CCE 16r4139 16r564C 16r413A 16r5851 16r413B 16r5CA8 16r413C 16r63AA 16r413D 16r66FE 16r413E 16r66FD 16r413F 16r695A 16r4140 16r72D9 16r4141 16r758F 16r4142 16r758E 16r4143 16r790E 16r4144 16r7956 16r4145 16r79DF 16r4146 16r7C97 16r4147 16r7D20 16r4148 16r7D44 16r4149 16r8607 16r414A 16r8A34 16r414B 16r963B 16r414C 16r9061 16r414D 16r9F20 16r414E 16r50E7 16r414F 16r5275 16r4150 16r53CC 16r4151 16r53E2 16r4152 16r5009 16r4153 16r55AA 16r4154 16r58EE 16r4155 16r594F 16r4156 16r723D 16r4157 16r5B8B 16r4158 16r5C64 16r4159 16r531D 16r415A 16r60E3 16r415B 16r60F3 16r415C 16r635C 16r415D 16r6383 16r415E 16r633F 16r415F 16r63BB 16r4160 16r64CD 16r4161 16r65E9 16r4162 16r66F9 16r4163 16r5DE3 16r4164 16r69CD 16r4165 16r69FD 16r4166 16r6F15 16r4167 16r71E5 16r4168 16r4E89 16r4169 16r75E9 16r416A 16r76F8 16r416B 16r7A93 16r416C 16r7CDF 16r416D 16r7DCF 16r416E 16r7D9C 16r416F 16r8061 16r4170 16r8349 16r4171 16r8358 16r4172 16r846C 16r4173 16r84BC 16r4174 16r85FB 16r4175 16r88C5 16r4176 16r8D70 16r4177 16r9001 16r4178 16r906D 16r4179 16r9397 16r417A 16r971C 16r417B 16r9A12 16r417C 16r50CF 16r417D 16r5897 16r417E 16r618E 16r4221 16r81D3 16r4222 16r8535 16r4223 16r8D08 16r4224 16r9020 16r4225 16r4FC3 16r4226 16r5074 16r4227 16r5247 16r4228 16r5373 16r4229 16r606F 16r422A 16r6349 16r422B 16r675F 16r422C 16r6E2C 16r422D 16r8DB3 16r422E 16r901F 16r422F 16r4FD7 16r4230 16r5C5E 16r4231 16r8CCA 16r4232 16r65CF 16r4233 16r7D9A 16r4234 16r5352 16r4235 16r8896 16r4236 16r5176 16r4237 16r63C3 16r4238 16r5B58 16r4239 16r5B6B 16r423A 16r5C0A 16r423B 16r640D 16r423C 16r6751 16r423D 16r905C 16r423E 16r4ED6 16r423F 16r591A 16r4240 16r592A 16r4241 16r6C70 16r4242 16r8A51 16r4243 16r553E 16r4244 16r5815 16r4245 16r59A5 16r4246 16r60F0 16r4247 16r6253 16r4248 16r67C1 16r4249 16r8235 16r424A 16r6955 16r424B 16r9640 16r424C 16r99C4 16r424D 16r9A28 16r424E 16r4F53 16r424F 16r5806 16r4250 16r5BFE 16r4251 16r8010 16r4252 16r5CB1 16r4253 16r5E2F 16r4254 16r5F85 16r4255 16r6020 16r4256 16r614B 16r4257 16r6234 16r4258 16r66FF 16r4259 16r6CF0 16r425A 16r6EDE 16r425B 16r80CE 16r425C 16r817F 16r425D 16r82D4 16r425E 16r888B 16r425F 16r8CB8 16r4260 16r9000 16r4261 16r902E 16r4262 16r968A 16r4263 16r9EDB 16r4264 16r9BDB 16r4265 16r4EE3 16r4266 16r53F0 16r4267 16r5927 16r4268 16r7B2C 16r4269 16r918D 16r426A 16r984C 16r426B 16r9DF9 16r426C 16r6EDD 16r426D 16r7027 16r426E 16r5353 16r426F 16r5544 16r4270 16r5B85 16r4271 16r6258 16r4272 16r629E 16r4273 16r62D3 16r4274 16r6CA2 16r4275 16r6FEF 16r4276 16r7422 16r4277 16r8A17 16r4278 16r9438 16r4279 16r6FC1 16r427A 16r8AFE 16r427B 16r8338 16r427C 16r51E7 16r427D 16r86F8 16r427E 16r53EA 16r4321 16r53E9 16r4322 16r4F46 16r4323 16r9054 16r4324 16r8FB0 16r4325 16r596A 16r4326 16r8131 16r4327 16r5DFD 16r4328 16r7AEA 16r4329 16r8FBF 16r432A 16r68DA 16r432B 16r8C37 16r432C 16r72F8 16r432D 16r9C48 16r432E 16r6A3D 16r432F 16r8AB0 16r4330 16r4E39 16r4331 16r5358 16r4332 16r5606 16r4333 16r5766 16r4334 16r62C5 16r4335 16r63A2 16r4336 16r65E6 16r4337 16r6B4E 16r4338 16r6DE1 16r4339 16r6E5B 16r433A 16r70AD 16r433B 16r77ED 16r433C 16r7AEF 16r433D 16r7BAA 16r433E 16r7DBB 16r433F 16r803D 16r4340 16r80C6 16r4341 16r86CB 16r4342 16r8A95 16r4343 16r935B 16r4344 16r56E3 16r4345 16r58C7 16r4346 16r5F3E 16r4347 16r65AD 16r4348 16r6696 16r4349 16r6A80 16r434A 16r6BB5 16r434B 16r7537 16r434C 16r8AC7 16r434D 16r5024 16r434E 16r77E5 16r434F 16r5730 16r4350 16r5F1B 16r4351 16r6065 16r4352 16r667A 16r4353 16r6C60 16r4354 16r75F4 16r4355 16r7A1A 16r4356 16r7F6E 16r4357 16r81F4 16r4358 16r8718 16r4359 16r9045 16r435A 16r99B3 16r435B 16r7BC9 16r435C 16r755C 16r435D 16r7AF9 16r435E 16r7B51 16r435F 16r84C4 16r4360 16r9010 16r4361 16r79E9 16r4362 16r7A92 16r4363 16r8336 16r4364 16r5AE1 16r4365 16r7740 16r4366 16r4E2D 16r4367 16r4EF2 16r4368 16r5B99 16r4369 16r5FE0 16r436A 16r62BD 16r436B 16r663C 16r436C 16r67F1 16r436D 16r6CE8 16r436E 16r866B 16r436F 16r8877 16r4370 16r8A3B 16r4371 16r914E 16r4372 16r92F3 16r4373 16r99D0 16r4374 16r6A17 16r4375 16r7026 16r4376 16r732A 16r4377 16r82E7 16r4378 16r8457 16r4379 16r8CAF 16r437A 16r4E01 16r437B 16r5146 16r437C 16r51CB 16r437D 16r558B 16r437E 16r5BF5 16r4421 16r5E16 16r4422 16r5E33 16r4423 16r5E81 16r4424 16r5F14 16r4425 16r5F35 16r4426 16r5F6B 16r4427 16r5FB4 16r4428 16r61F2 16r4429 16r6311 16r442A 16r66A2 16r442B 16r671D 16r442C 16r6F6E 16r442D 16r7252 16r442E 16r753A 16r442F 16r773A 16r4430 16r8074 16r4431 16r8139 16r4432 16r8178 16r4433 16r8776 16r4434 16r8ABF 16r4435 16r8ADC 16r4436 16r8D85 16r4437 16r8DF3 16r4438 16r929A 16r4439 16r9577 16r443A 16r9802 16r443B 16r9CE5 16r443C 16r52C5 16r443D 16r6357 16r443E 16r76F4 16r443F 16r6715 16r4440 16r6C88 16r4441 16r73CD 16r4442 16r8CC3 16r4443 16r93AE 16r4444 16r9673 16r4445 16r6D25 16r4446 16r589C 16r4447 16r690E 16r4448 16r69CC 16r4449 16r8FFD 16r444A 16r939A 16r444B 16r75DB 16r444C 16r901A 16r444D 16r585A 16r444E 16r6802 16r444F 16r63B4 16r4450 16r69FB 16r4451 16r4F43 16r4452 16r6F2C 16r4453 16r67D8 16r4454 16r8FBB 16r4455 16r8526 16r4456 16r7DB4 16r4457 16r9354 16r4458 16r693F 16r4459 16r6F70 16r445A 16r576A 16r445B 16r58F7 16r445C 16r5B2C 16r445D 16r7D2C 16r445E 16r722A 16r445F 16r540A 16r4460 16r91E3 16r4461 16r9DB4 16r4462 16r4EAD 16r4463 16r4F4E 16r4464 16r505C 16r4465 16r5075 16r4466 16r5243 16r4467 16r8C9E 16r4468 16r5448 16r4469 16r5824 16r446A 16r5B9A 16r446B 16r5E1D 16r446C 16r5E95 16r446D 16r5EAD 16r446E 16r5EF7 16r446F 16r5F1F 16r4470 16r608C 16r4471 16r62B5 16r4472 16r633A 16r4473 16r63D0 16r4474 16r68AF 16r4475 16r6C40 16r4476 16r7887 16r4477 16r798E 16r4478 16r7A0B 16r4479 16r7DE0 16r447A 16r8247 16r447B 16r8A02 16r447C 16r8AE6 16r447D 16r8E44 16r447E 16r9013 16r4521 16r90B8 16r4522 16r912D 16r4523 16r91D8 16r4524 16r9F0E 16r4525 16r6CE5 16r4526 16r6458 16r4527 16r64E2 16r4528 16r6575 16r4529 16r6EF4 16r452A 16r7684 16r452B 16r7B1B 16r452C 16r9069 16r452D 16r93D1 16r452E 16r6EBA 16r452F 16r54F2 16r4530 16r5FB9 16r4531 16r64A4 16r4532 16r8F4D 16r4533 16r8FED 16r4534 16r9244 16r4535 16r5178 16r4536 16r586B 16r4537 16r5929 16r4538 16r5C55 16r4539 16r5E97 16r453A 16r6DFB 16r453B 16r7E8F 16r453C 16r751C 16r453D 16r8CBC 16r453E 16r8EE2 16r453F 16r985B 16r4540 16r70B9 16r4541 16r4F1D 16r4542 16r6BBF 16r4543 16r6FB1 16r4544 16r7530 16r4545 16r96FB 16r4546 16r514E 16r4547 16r5410 16r4548 16r5835 16r4549 16r5857 16r454A 16r59AC 16r454B 16r5C60 16r454C 16r5F92 16r454D 16r6597 16r454E 16r675C 16r454F 16r6E21 16r4550 16r767B 16r4551 16r83DF 16r4552 16r8CED 16r4553 16r9014 16r4554 16r90FD 16r4555 16r934D 16r4556 16r7825 16r4557 16r783A 16r4558 16r52AA 16r4559 16r5EA6 16r455A 16r571F 16r455B 16r5974 16r455C 16r6012 16r455D 16r5012 16r455E 16r515A 16r455F 16r51AC 16r4560 16r51CD 16r4561 16r5200 16r4562 16r5510 16r4563 16r5854 16r4564 16r5858 16r4565 16r5957 16r4566 16r5B95 16r4567 16r5CF6 16r4568 16r5D8B 16r4569 16r60BC 16r456A 16r6295 16r456B 16r642D 16r456C 16r6771 16r456D 16r6843 16r456E 16r68BC 16r456F 16r68DF 16r4570 16r76D7 16r4571 16r6DD8 16r4572 16r6E6F 16r4573 16r6D9B 16r4574 16r706F 16r4575 16r71C8 16r4576 16r5F53 16r4577 16r75D8 16r4578 16r7977 16r4579 16r7B49 16r457A 16r7B54 16r457B 16r7B52 16r457C 16r7CD6 16r457D 16r7D71 16r457E 16r5230 16r4621 16r8463 16r4622 16r8569 16r4623 16r85E4 16r4624 16r8A0E 16r4625 16r8B04 16r4626 16r8C46 16r4627 16r8E0F 16r4628 16r9003 16r4629 16r900F 16r462A 16r9419 16r462B 16r9676 16r462C 16r982D 16r462D 16r9A30 16r462E 16r95D8 16r462F 16r50CD 16r4630 16r52D5 16r4631 16r540C 16r4632 16r5802 16r4633 16r5C0E 16r4634 16r61A7 16r4635 16r649E 16r4636 16r6D1E 16r4637 16r77B3 16r4638 16r7AE5 16r4639 16r80F4 16r463A 16r8404 16r463B 16r9053 16r463C 16r9285 16r463D 16r5CE0 16r463E 16r9D07 16r463F 16r533F 16r4640 16r5F97 16r4641 16r5FB3 16r4642 16r6D9C 16r4643 16r7279 16r4644 16r7763 16r4645 16r79BF 16r4646 16r7BE4 16r4647 16r6BD2 16r4648 16r72EC 16r4649 16r8AAD 16r464A 16r6803 16r464B 16r6A61 16r464C 16r51F8 16r464D 16r7A81 16r464E 16r6934 16r464F 16r5C4A 16r4650 16r9CF6 16r4651 16r82EB 16r4652 16r5BC5 16r4653 16r9149 16r4654 16r701E 16r4655 16r5678 16r4656 16r5C6F 16r4657 16r60C7 16r4658 16r6566 16r4659 16r6C8C 16r465A 16r8C5A 16r465B 16r9041 16r465C 16r9813 16r465D 16r5451 16r465E 16r66C7 16r465F 16r920D 16r4660 16r5948 16r4661 16r90A3 16r4662 16r5185 16r4663 16r4E4D 16r4664 16r51EA 16r4665 16r8599 16r4666 16r8B0E 16r4667 16r7058 16r4668 16r637A 16r4669 16r934B 16r466A 16r6962 16r466B 16r99B4 16r466C 16r7E04 16r466D 16r7577 16r466E 16r5357 16r466F 16r6960 16r4670 16r8EDF 16r4671 16r96E3 16r4672 16r6C5D 16r4673 16r4E8C 16r4674 16r5C3C 16r4675 16r5F10 16r4676 16r8FE9 16r4677 16r5302 16r4678 16r8CD1 16r4679 16r8089 16r467A 16r8679 16r467B 16r5EFF 16r467C 16r65E5 16r467D 16r4E73 16r467E 16r5165 16r4721 16r5982 16r4722 16r5C3F 16r4723 16r97EE 16r4724 16r4EFB 16r4725 16r598A 16r4726 16r5FCD 16r4727 16r8A8D 16r4728 16r6FE1 16r4729 16r79B0 16r472A 16r7962 16r472B 16r5BE7 16r472C 16r8471 16r472D 16r732B 16r472E 16r71B1 16r472F 16r5E74 16r4730 16r5FF5 16r4731 16r637B 16r4732 16r649A 16r4733 16r71C3 16r4734 16r7C98 16r4735 16r4E43 16r4736 16r5EFC 16r4737 16r4E4B 16r4738 16r57DC 16r4739 16r56A2 16r473A 16r60A9 16r473B 16r6FC3 16r473C 16r7D0D 16r473D 16r80FD 16r473E 16r8133 16r473F 16r81BF 16r4740 16r8FB2 16r4741 16r8997 16r4742 16r86A4 16r4743 16r5DF4 16r4744 16r628A 16r4745 16r64AD 16r4746 16r8987 16r4747 16r6777 16r4748 16r6CE2 16r4749 16r6D3E 16r474A 16r7436 16r474B 16r7834 16r474C 16r5A46 16r474D 16r7F75 16r474E 16r82AD 16r474F 16r99AC 16r4750 16r4FF3 16r4751 16r5EC3 16r4752 16r62DD 16r4753 16r6392 16r4754 16r6557 16r4755 16r676F 16r4756 16r76C3 16r4757 16r724C 16r4758 16r80CC 16r4759 16r80BA 16r475A 16r8F29 16r475B 16r914D 16r475C 16r500D 16r475D 16r57F9 16r475E 16r5A92 16r475F 16r6885 16r4760 16r6973 16r4761 16r7164 16r4762 16r72FD 16r4763 16r8CB7 16r4764 16r58F2 16r4765 16r8CE0 16r4766 16r966A 16r4767 16r9019 16r4768 16r877F 16r4769 16r79E4 16r476A 16r77E7 16r476B 16r8429 16r476C 16r4F2F 16r476D 16r5265 16r476E 16r535A 16r476F 16r62CD 16r4770 16r67CF 16r4771 16r6CCA 16r4772 16r767D 16r4773 16r7B94 16r4774 16r7C95 16r4775 16r8236 16r4776 16r8584 16r4777 16r8FEB 16r4778 16r66DD 16r4779 16r6F20 16r477A 16r7206 16r477B 16r7E1B 16r477C 16r83AB 16r477D 16r99C1 16r477E 16r9EA6 16r4821 16r51FD 16r4822 16r7BB1 16r4823 16r7872 16r4824 16r7BB8 16r4825 16r8087 16r4826 16r7B48 16r4827 16r6AE8 16r4828 16r5E61 16r4829 16r808C 16r482A 16r7551 16r482B 16r7560 16r482C 16r516B 16r482D 16r9262 16r482E 16r6E8C 16r482F 16r767A 16r4830 16r9197 16r4831 16r9AEA 16r4832 16r4F10 16r4833 16r7F70 16r4834 16r629C 16r4835 16r7B4F 16r4836 16r95A5 16r4837 16r9CE9 16r4838 16r567A 16r4839 16r5859 16r483A 16r86E4 16r483B 16r96BC 16r483C 16r4F34 16r483D 16r5224 16r483E 16r534A 16r483F 16r53CD 16r4840 16r53DB 16r4841 16r5E06 16r4842 16r642C 16r4843 16r6591 16r4844 16r677F 16r4845 16r6C3E 16r4846 16r6C4E 16r4847 16r7248 16r4848 16r72AF 16r4849 16r73ED 16r484A 16r7554 16r484B 16r7E41 16r484C 16r822C 16r484D 16r85E9 16r484E 16r8CA9 16r484F 16r7BC4 16r4850 16r91C6 16r4851 16r7169 16r4852 16r9812 16r4853 16r98EF 16r4854 16r633D 16r4855 16r6669 16r4856 16r756A 16r4857 16r76E4 16r4858 16r78D0 16r4859 16r8543 16r485A 16r86EE 16r485B 16r532A 16r485C 16r5351 16r485D 16r5426 16r485E 16r5983 16r485F 16r5E87 16r4860 16r5F7C 16r4861 16r60B2 16r4862 16r6249 16r4863 16r6279 16r4864 16r62AB 16r4865 16r6590 16r4866 16r6BD4 16r4867 16r6CCC 16r4868 16r75B2 16r4869 16r76AE 16r486A 16r7891 16r486B 16r79D8 16r486C 16r7DCB 16r486D 16r7F77 16r486E 16r80A5 16r486F 16r88AB 16r4870 16r8AB9 16r4871 16r8CBB 16r4872 16r907F 16r4873 16r975E 16r4874 16r98DB 16r4875 16r6A0B 16r4876 16r7C38 16r4877 16r5099 16r4878 16r5C3E 16r4879 16r5FAE 16r487A 16r6787 16r487B 16r6BD8 16r487C 16r7435 16r487D 16r7709 16r487E 16r7F8E 16r4921 16r9F3B 16r4922 16r67CA 16r4923 16r7A17 16r4924 16r5339 16r4925 16r758B 16r4926 16r9AED 16r4927 16r5F66 16r4928 16r819D 16r4929 16r83F1 16r492A 16r8098 16r492B 16r5F3C 16r492C 16r5FC5 16r492D 16r7562 16r492E 16r7B46 16r492F 16r903C 16r4930 16r6867 16r4931 16r59EB 16r4932 16r5A9B 16r4933 16r7D10 16r4934 16r767E 16r4935 16r8B2C 16r4936 16r4FF5 16r4937 16r5F6A 16r4938 16r6A19 16r4939 16r6C37 16r493A 16r6F02 16r493B 16r74E2 16r493C 16r7968 16r493D 16r8868 16r493E 16r8A55 16r493F 16r8C79 16r4940 16r5EDF 16r4941 16r63CF 16r4942 16r75C5 16r4943 16r79D2 16r4944 16r82D7 16r4945 16r9328 16r4946 16r92F2 16r4947 16r849C 16r4948 16r86ED 16r4949 16r9C2D 16r494A 16r54C1 16r494B 16r5F6C 16r494C 16r658C 16r494D 16r6D5C 16r494E 16r7015 16r494F 16r8CA7 16r4950 16r8CD3 16r4951 16r983B 16r4952 16r654F 16r4953 16r74F6 16r4954 16r4E0D 16r4955 16r4ED8 16r4956 16r57E0 16r4957 16r592B 16r4958 16r5A66 16r4959 16r5BCC 16r495A 16r51A8 16r495B 16r5E03 16r495C 16r5E9C 16r495D 16r6016 16r495E 16r6276 16r495F 16r6577 16r4960 16r65A7 16r4961 16r666E 16r4962 16r6D6E 16r4963 16r7236 16r4964 16r7B26 16r4965 16r8150 16r4966 16r819A 16r4967 16r8299 16r4968 16r8B5C 16r4969 16r8CA0 16r496A 16r8CE6 16r496B 16r8D74 16r496C 16r961C 16r496D 16r9644 16r496E 16r4FAE 16r496F 16r64AB 16r4970 16r6B66 16r4971 16r821E 16r4972 16r8461 16r4973 16r856A 16r4974 16r90E8 16r4975 16r5C01 16r4976 16r6953 16r4977 16r98A8 16r4978 16r847A 16r4979 16r8557 16r497A 16r4F0F 16r497B 16r526F 16r497C 16r5FA9 16r497D 16r5E45 16r497E 16r670D 16r4A21 16r798F 16r4A22 16r8179 16r4A23 16r8907 16r4A24 16r8986 16r4A25 16r6DF5 16r4A26 16r5F17 16r4A27 16r6255 16r4A28 16r6CB8 16r4A29 16r4ECF 16r4A2A 16r7269 16r4A2B 16r9B92 16r4A2C 16r5206 16r4A2D 16r543B 16r4A2E 16r5674 16r4A2F 16r58B3 16r4A30 16r61A4 16r4A31 16r626E 16r4A32 16r711A 16r4A33 16r596E 16r4A34 16r7C89 16r4A35 16r7CDE 16r4A36 16r7D1B 16r4A37 16r96F0 16r4A38 16r6587 16r4A39 16r805E 16r4A3A 16r4E19 16r4A3B 16r4F75 16r4A3C 16r5175 16r4A3D 16r5840 16r4A3E 16r5E63 16r4A3F 16r5E73 16r4A40 16r5F0A 16r4A41 16r67C4 16r4A42 16r4E26 16r4A43 16r853D 16r4A44 16r9589 16r4A45 16r965B 16r4A46 16r7C73 16r4A47 16r9801 16r4A48 16r50FB 16r4A49 16r58C1 16r4A4A 16r7656 16r4A4B 16r78A7 16r4A4C 16r5225 16r4A4D 16r77A5 16r4A4E 16r8511 16r4A4F 16r7B86 16r4A50 16r504F 16r4A51 16r5909 16r4A52 16r7247 16r4A53 16r7BC7 16r4A54 16r7DE8 16r4A55 16r8FBA 16r4A56 16r8FD4 16r4A57 16r904D 16r4A58 16r4FBF 16r4A59 16r52C9 16r4A5A 16r5A29 16r4A5B 16r5F01 16r4A5C 16r97AD 16r4A5D 16r4FDD 16r4A5E 16r8217 16r4A5F 16r92EA 16r4A60 16r5703 16r4A61 16r6355 16r4A62 16r6B69 16r4A63 16r752B 16r4A64 16r88DC 16r4A65 16r8F14 16r4A66 16r7A42 16r4A67 16r52DF 16r4A68 16r5893 16r4A69 16r6155 16r4A6A 16r620A 16r4A6B 16r66AE 16r4A6C 16r6BCD 16r4A6D 16r7C3F 16r4A6E 16r83E9 16r4A6F 16r5023 16r4A70 16r4FF8 16r4A71 16r5305 16r4A72 16r5446 16r4A73 16r5831 16r4A74 16r5949 16r4A75 16r5B9D 16r4A76 16r5CF0 16r4A77 16r5CEF 16r4A78 16r5D29 16r4A79 16r5E96 16r4A7A 16r62B1 16r4A7B 16r6367 16r4A7C 16r653E 16r4A7D 16r65B9 16r4A7E 16r670B 16r4B21 16r6CD5 16r4B22 16r6CE1 16r4B23 16r70F9 16r4B24 16r7832 16r4B25 16r7E2B 16r4B26 16r80DE 16r4B27 16r82B3 16r4B28 16r840C 16r4B29 16r84EC 16r4B2A 16r8702 16r4B2B 16r8912 16r4B2C 16r8A2A 16r4B2D 16r8C4A 16r4B2E 16r90A6 16r4B2F 16r92D2 16r4B30 16r98FD 16r4B31 16r9CF3 16r4B32 16r9D6C 16r4B33 16r4E4F 16r4B34 16r4EA1 16r4B35 16r508D 16r4B36 16r5256 16r4B37 16r574A 16r4B38 16r59A8 16r4B39 16r5E3D 16r4B3A 16r5FD8 16r4B3B 16r5FD9 16r4B3C 16r623F 16r4B3D 16r66B4 16r4B3E 16r671B 16r4B3F 16r67D0 16r4B40 16r68D2 16r4B41 16r5192 16r4B42 16r7D21 16r4B43 16r80AA 16r4B44 16r81A8 16r4B45 16r8B00 16r4B46 16r8C8C 16r4B47 16r8CBF 16r4B48 16r927E 16r4B49 16r9632 16r4B4A 16r5420 16r4B4B 16r982C 16r4B4C 16r5317 16r4B4D 16r50D5 16r4B4E 16r535C 16r4B4F 16r58A8 16r4B50 16r64B2 16r4B51 16r6734 16r4B52 16r7267 16r4B53 16r7766 16r4B54 16r7A46 16r4B55 16r91E6 16r4B56 16r52C3 16r4B57 16r6CA1 16r4B58 16r6B86 16r4B59 16r5800 16r4B5A 16r5E4C 16r4B5B 16r5954 16r4B5C 16r672C 16r4B5D 16r7FFB 16r4B5E 16r51E1 16r4B5F 16r76C6 16r4B60 16r6469 16r4B61 16r78E8 16r4B62 16r9B54 16r4B63 16r9EBB 16r4B64 16r57CB 16r4B65 16r59B9 16r4B66 16r6627 16r4B67 16r679A 16r4B68 16r6BCE 16r4B69 16r54E9 16r4B6A 16r69D9 16r4B6B 16r5E55 16r4B6C 16r819C 16r4B6D 16r6795 16r4B6E 16r9BAA 16r4B6F 16r67FE 16r4B70 16r9C52 16r4B71 16r685D 16r4B72 16r4EA6 16r4B73 16r4FE3 16r4B74 16r53C8 16r4B75 16r62B9 16r4B76 16r672B 16r4B77 16r6CAB 16r4B78 16r8FC4 16r4B79 16r4FAD 16r4B7A 16r7E6D 16r4B7B 16r9EBF 16r4B7C 16r4E07 16r4B7D 16r6162 16r4B7E 16r6E80 16r4C21 16r6F2B 16r4C22 16r8513 16r4C23 16r5473 16r4C24 16r672A 16r4C25 16r9B45 16r4C26 16r5DF3 16r4C27 16r7B95 16r4C28 16r5CAC 16r4C29 16r5BC6 16r4C2A 16r871C 16r4C2B 16r6E4A 16r4C2C 16r84D1 16r4C2D 16r7A14 16r4C2E 16r8108 16r4C2F 16r5999 16r4C30 16r7C8D 16r4C31 16r6C11 16r4C32 16r7720 16r4C33 16r52D9 16r4C34 16r5922 16r4C35 16r7121 16r4C36 16r725F 16r4C37 16r77DB 16r4C38 16r9727 16r4C39 16r9D61 16r4C3A 16r690B 16r4C3B 16r5A7F 16r4C3C 16r5A18 16r4C3D 16r51A5 16r4C3E 16r540D 16r4C3F 16r547D 16r4C40 16r660E 16r4C41 16r76DF 16r4C42 16r8FF7 16r4C43 16r9298 16r4C44 16r9CF4 16r4C45 16r59EA 16r4C46 16r725D 16r4C47 16r6EC5 16r4C48 16r514D 16r4C49 16r68C9 16r4C4A 16r7DBF 16r4C4B 16r7DEC 16r4C4C 16r9762 16r4C4D 16r9EBA 16r4C4E 16r6478 16r4C4F 16r6A21 16r4C50 16r8302 16r4C51 16r5984 16r4C52 16r5B5F 16r4C53 16r6BDB 16r4C54 16r731B 16r4C55 16r76F2 16r4C56 16r7DB2 16r4C57 16r8017 16r4C58 16r8499 16r4C59 16r5132 16r4C5A 16r6728 16r4C5B 16r9ED9 16r4C5C 16r76EE 16r4C5D 16r6762 16r4C5E 16r52FF 16r4C5F 16r9905 16r4C60 16r5C24 16r4C61 16r623B 16r4C62 16r7C7E 16r4C63 16r8CB0 16r4C64 16r554F 16r4C65 16r60B6 16r4C66 16r7D0B 16r4C67 16r9580 16r4C68 16r5301 16r4C69 16r4E5F 16r4C6A 16r51B6 16r4C6B 16r591C 16r4C6C 16r723A 16r4C6D 16r8036 16r4C6E 16r91CE 16r4C6F 16r5F25 16r4C70 16r77E2 16r4C71 16r5384 16r4C72 16r5F79 16r4C73 16r7D04 16r4C74 16r85AC 16r4C75 16r8A33 16r4C76 16r8E8D 16r4C77 16r9756 16r4C78 16r67F3 16r4C79 16r85AE 16r4C7A 16r9453 16r4C7B 16r6109 16r4C7C 16r6108 16r4C7D 16r6CB9 16r4C7E 16r7652 16r4D21 16r8AED 16r4D22 16r8F38 16r4D23 16r552F 16r4D24 16r4F51 16r4D25 16r512A 16r4D26 16r52C7 16r4D27 16r53CB 16r4D28 16r5BA5 16r4D29 16r5E7D 16r4D2A 16r60A0 16r4D2B 16r6182 16r4D2C 16r63D6 16r4D2D 16r6709 16r4D2E 16r67DA 16r4D2F 16r6E67 16r4D30 16r6D8C 16r4D31 16r7336 16r4D32 16r7337 16r4D33 16r7531 16r4D34 16r7950 16r4D35 16r88D5 16r4D36 16r8A98 16r4D37 16r904A 16r4D38 16r9091 16r4D39 16r90F5 16r4D3A 16r96C4 16r4D3B 16r878D 16r4D3C 16r5915 16r4D3D 16r4E88 16r4D3E 16r4F59 16r4D3F 16r4E0E 16r4D40 16r8A89 16r4D41 16r8F3F 16r4D42 16r9810 16r4D43 16r50AD 16r4D44 16r5E7C 16r4D45 16r5996 16r4D46 16r5BB9 16r4D47 16r5EB8 16r4D48 16r63DA 16r4D49 16r63FA 16r4D4A 16r64C1 16r4D4B 16r66DC 16r4D4C 16r694A 16r4D4D 16r69D8 16r4D4E 16r6D0B 16r4D4F 16r6EB6 16r4D50 16r7194 16r4D51 16r7528 16r4D52 16r7AAF 16r4D53 16r7F8A 16r4D54 16r8000 16r4D55 16r8449 16r4D56 16r84C9 16r4D57 16r8981 16r4D58 16r8B21 16r4D59 16r8E0A 16r4D5A 16r9065 16r4D5B 16r967D 16r4D5C 16r990A 16r4D5D 16r617E 16r4D5E 16r6291 16r4D5F 16r6B32 16r4D60 16r6C83 16r4D61 16r6D74 16r4D62 16r7FCC 16r4D63 16r7FFC 16r4D64 16r6DC0 16r4D65 16r7F85 16r4D66 16r87BA 16r4D67 16r88F8 16r4D68 16r6765 16r4D69 16r83B1 16r4D6A 16r983C 16r4D6B 16r96F7 16r4D6C 16r6D1B 16r4D6D 16r7D61 16r4D6E 16r843D 16r4D6F 16r916A 16r4D70 16r4E71 16r4D71 16r5375 16r4D72 16r5D50 16r4D73 16r6B04 16r4D74 16r6FEB 16r4D75 16r85CD 16r4D76 16r862D 16r4D77 16r89A7 16r4D78 16r5229 16r4D79 16r540F 16r4D7A 16r5C65 16r4D7B 16r674E 16r4D7C 16r68A8 16r4D7D 16r7406 16r4D7E 16r7483 16r4E21 16r75E2 16r4E22 16r88CF 16r4E23 16r88E1 16r4E24 16r91CC 16r4E25 16r96E2 16r4E26 16r9678 16r4E27 16r5F8B 16r4E28 16r7387 16r4E29 16r7ACB 16r4E2A 16r844E 16r4E2B 16r63A0 16r4E2C 16r7565 16r4E2D 16r5289 16r4E2E 16r6D41 16r4E2F 16r6E9C 16r4E30 16r7409 16r4E31 16r7559 16r4E32 16r786B 16r4E33 16r7C92 16r4E34 16r9686 16r4E35 16r7ADC 16r4E36 16r9F8D 16r4E37 16r4FB6 16r4E38 16r616E 16r4E39 16r65C5 16r4E3A 16r865C 16r4E3B 16r4E86 16r4E3C 16r4EAE 16r4E3D 16r50DA 16r4E3E 16r4E21 16r4E3F 16r51CC 16r4E40 16r5BEE 16r4E41 16r6599 16r4E42 16r6881 16r4E43 16r6DBC 16r4E44 16r731F 16r4E45 16r7642 16r4E46 16r77AD 16r4E47 16r7A1C 16r4E48 16r7CE7 16r4E49 16r826F 16r4E4A 16r8AD2 16r4E4B 16r907C 16r4E4C 16r91CF 16r4E4D 16r9675 16r4E4E 16r9818 16r4E4F 16r529B 16r4E50 16r7DD1 16r4E51 16r502B 16r4E52 16r5398 16r4E53 16r6797 16r4E54 16r6DCB 16r4E55 16r71D0 16r4E56 16r7433 16r4E57 16r81E8 16r4E58 16r8F2A 16r4E59 16r96A3 16r4E5A 16r9C57 16r4E5B 16r9E9F 16r4E5C 16r7460 16r4E5D 16r5841 16r4E5E 16r6D99 16r4E5F 16r7D2F 16r4E60 16r985E 16r4E61 16r4EE4 16r4E62 16r4F36 16r4E63 16r4F8B 16r4E64 16r51B7 16r4E65 16r52B1 16r4E66 16r5DBA 16r4E67 16r601C 16r4E68 16r73B2 16r4E69 16r793C 16r4E6A 16r82D3 16r4E6B 16r9234 16r4E6C 16r96B7 16r4E6D 16r96F6 16r4E6E 16r970A 16r4E6F 16r9E97 16r4E70 16r9F62 16r4E71 16r66A6 16r4E72 16r6B74 16r4E73 16r5217 16r4E74 16r52A3 16r4E75 16r70C8 16r4E76 16r88C2 16r4E77 16r5EC9 16r4E78 16r604B 16r4E79 16r6190 16r4E7A 16r6F23 16r4E7B 16r7149 16r4E7C 16r7C3E 16r4E7D 16r7DF4 16r4E7E 16r806F 16r4F21 16r84EE 16r4F22 16r9023 16r4F23 16r932C 16r4F24 16r5442 16r4F25 16r9B6F 16r4F26 16r6AD3 16r4F27 16r7089 16r4F28 16r8CC2 16r4F29 16r8DEF 16r4F2A 16r9732 16r4F2B 16r52B4 16r4F2C 16r5A41 16r4F2D 16r5ECA 16r4F2E 16r5F04 16r4F2F 16r6717 16r4F30 16r697C 16r4F31 16r6994 16r4F32 16r6D6A 16r4F33 16r6F0F 16r4F34 16r7262 16r4F35 16r72FC 16r4F36 16r7BED 16r4F37 16r8001 16r4F38 16r807E 16r4F39 16r874B 16r4F3A 16r90CE 16r4F3B 16r516D 16r4F3C 16r9E93 16r4F3D 16r7984 16r4F3E 16r808B 16r4F3F 16r9332 16r4F40 16r8AD6 16r4F41 16r502D 16r4F42 16r548C 16r4F43 16r8A71 16r4F44 16r6B6A 16r4F45 16r8CC4 16r4F46 16r8107 16r4F47 16r60D1 16r4F48 16r67A0 16r4F49 16r9DF2 16r4F4A 16r4E99 16r4F4B 16r4E98 16r4F4C 16r9C10 16r4F4D 16r8A6B 16r4F4E 16r85C1 16r4F4F 16r8568 16r4F50 16r6900 16r4F51 16r6E7E 16r4F52 16r7897 16r4F53 16r8155 16r5021 16r5F0C 16r5022 16r4E10 16r5023 16r4E15 16r5024 16r4E2A 16r5025 16r4E31 16r5026 16r4E36 16r5027 16r4E3C 16r5028 16r4E3F 16r5029 16r4E42 16r502A 16r4E56 16r502B 16r4E58 16r502C 16r4E82 16r502D 16r4E85 16r502E 16r8C6B 16r502F 16r4E8A 16r5030 16r8212 16r5031 16r5F0D 16r5032 16r4E8E 16r5033 16r4E9E 16r5034 16r4E9F 16r5035 16r4EA0 16r5036 16r4EA2 16r5037 16r4EB0 16r5038 16r4EB3 16r5039 16r4EB6 16r503A 16r4ECE 16r503B 16r4ECD 16r503C 16r4EC4 16r503D 16r4EC6 16r503E 16r4EC2 16r503F 16r4ED7 16r5040 16r4EDE 16r5041 16r4EED 16r5042 16r4EDF 16r5043 16r4EF7 16r5044 16r4F09 16r5045 16r4F5A 16r5046 16r4F30 16r5047 16r4F5B 16r5048 16r4F5D 16r5049 16r4F57 16r504A 16r4F47 16r504B 16r4F76 16r504C 16r4F88 16r504D 16r4F8F 16r504E 16r4F98 16r504F 16r4F7B 16r5050 16r4F69 16r5051 16r4F70 16r5052 16r4F91 16r5053 16r4F6F 16r5054 16r4F86 16r5055 16r4F96 16r5056 16r5118 16r5057 16r4FD4 16r5058 16r4FDF 16r5059 16r4FCE 16r505A 16r4FD8 16r505B 16r4FDB 16r505C 16r4FD1 16r505D 16r4FDA 16r505E 16r4FD0 16r505F 16r4FE4 16r5060 16r4FE5 16r5061 16r501A 16r5062 16r5028 16r5063 16r5014 16r5064 16r502A 16r5065 16r5025 16r5066 16r5005 16r5067 16r4F1C 16r5068 16r4FF6 16r5069 16r5021 16r506A 16r5029 16r506B 16r502C 16r506C 16r4FFE 16r506D 16r4FEF 16r506E 16r5011 16r506F 16r5006 16r5070 16r5043 16r5071 16r5047 16r5072 16r6703 16r5073 16r5055 16r5074 16r5050 16r5075 16r5048 16r5076 16r505A 16r5077 16r5056 16r5078 16r506C 16r5079 16r5078 16r507A 16r5080 16r507B 16r509A 16r507C 16r5085 16r507D 16r50B4 16r507E 16r50B2 16r5121 16r50C9 16r5122 16r50CA 16r5123 16r50B3 16r5124 16r50C2 16r5125 16r50D6 16r5126 16r50DE 16r5127 16r50E5 16r5128 16r50ED 16r5129 16r50E3 16r512A 16r50EE 16r512B 16r50F9 16r512C 16r50F5 16r512D 16r5109 16r512E 16r5101 16r512F 16r5102 16r5130 16r5116 16r5131 16r5115 16r5132 16r5114 16r5133 16r511A 16r5134 16r5121 16r5135 16r513A 16r5136 16r5137 16r5137 16r513C 16r5138 16r513B 16r5139 16r513F 16r513A 16r5140 16r513B 16r5152 16r513C 16r514C 16r513D 16r5154 16r513E 16r5162 16r513F 16r7AF8 16r5140 16r5169 16r5141 16r516A 16r5142 16r516E 16r5143 16r5180 16r5144 16r5182 16r5145 16r56D8 16r5146 16r518C 16r5147 16r5189 16r5148 16r518F 16r5149 16r5191 16r514A 16r5193 16r514B 16r5195 16r514C 16r5196 16r514D 16r51A4 16r514E 16r51A6 16r514F 16r51A2 16r5150 16r51A9 16r5151 16r51AA 16r5152 16r51AB 16r5153 16r51B3 16r5154 16r51B1 16r5155 16r51B2 16r5156 16r51B0 16r5157 16r51B5 16r5158 16r51BD 16r5159 16r51C5 16r515A 16r51C9 16r515B 16r51DB 16r515C 16r51E0 16r515D 16r8655 16r515E 16r51E9 16r515F 16r51ED 16r5160 16r51F0 16r5161 16r51F5 16r5162 16r51FE 16r5163 16r5204 16r5164 16r520B 16r5165 16r5214 16r5166 16r520E 16r5167 16r5227 16r5168 16r522A 16r5169 16r522E 16r516A 16r5233 16r516B 16r5239 16r516C 16r524F 16r516D 16r5244 16r516E 16r524B 16r516F 16r524C 16r5170 16r525E 16r5171 16r5254 16r5172 16r526A 16r5173 16r5274 16r5174 16r5269 16r5175 16r5273 16r5176 16r527F 16r5177 16r527D 16r5178 16r528D 16r5179 16r5294 16r517A 16r5292 16r517B 16r5271 16r517C 16r5288 16r517D 16r5291 16r517E 16r8FA8 16r5221 16r8FA7 16r5222 16r52AC 16r5223 16r52AD 16r5224 16r52BC 16r5225 16r52B5 16r5226 16r52C1 16r5227 16r52CD 16r5228 16r52D7 16r5229 16r52DE 16r522A 16r52E3 16r522B 16r52E6 16r522C 16r98ED 16r522D 16r52E0 16r522E 16r52F3 16r522F 16r52F5 16r5230 16r52F8 16r5231 16r52F9 16r5232 16r5306 16r5233 16r5308 16r5234 16r7538 16r5235 16r530D 16r5236 16r5310 16r5237 16r530F 16r5238 16r5315 16r5239 16r531A 16r523A 16r5323 16r523B 16r532F 16r523C 16r5331 16r523D 16r5333 16r523E 16r5338 16r523F 16r5340 16r5240 16r5346 16r5241 16r5345 16r5242 16r4E17 16r5243 16r5349 16r5244 16r534D 16r5245 16r51D6 16r5246 16r535E 16r5247 16r5369 16r5248 16r536E 16r5249 16r5918 16r524A 16r537B 16r524B 16r5377 16r524C 16r5382 16r524D 16r5396 16r524E 16r53A0 16r524F 16r53A6 16r5250 16r53A5 16r5251 16r53AE 16r5252 16r53B0 16r5253 16r53B6 16r5254 16r53C3 16r5255 16r7C12 16r5256 16r96D9 16r5257 16r53DF 16r5258 16r66FC 16r5259 16r71EE 16r525A 16r53EE 16r525B 16r53E8 16r525C 16r53ED 16r525D 16r53FA 16r525E 16r5401 16r525F 16r543D 16r5260 16r5440 16r5261 16r542C 16r5262 16r542D 16r5263 16r543C 16r5264 16r542E 16r5265 16r5436 16r5266 16r5429 16r5267 16r541D 16r5268 16r544E 16r5269 16r548F 16r526A 16r5475 16r526B 16r548E 16r526C 16r545F 16r526D 16r5471 16r526E 16r5477 16r526F 16r5470 16r5270 16r5492 16r5271 16r547B 16r5272 16r5480 16r5273 16r5476 16r5274 16r5484 16r5275 16r5490 16r5276 16r5486 16r5277 16r54C7 16r5278 16r54A2 16r5279 16r54B8 16r527A 16r54A5 16r527B 16r54AC 16r527C 16r54C4 16r527D 16r54C8 16r527E 16r54A8 16r5321 16r54AB 16r5322 16r54C2 16r5323 16r54A4 16r5324 16r54BE 16r5325 16r54BC 16r5326 16r54D8 16r5327 16r54E5 16r5328 16r54E6 16r5329 16r550F 16r532A 16r5514 16r532B 16r54FD 16r532C 16r54EE 16r532D 16r54ED 16r532E 16r54FA 16r532F 16r54E2 16r5330 16r5539 16r5331 16r5540 16r5332 16r5563 16r5333 16r554C 16r5334 16r552E 16r5335 16r555C 16r5336 16r5545 16r5337 16r5556 16r5338 16r5557 16r5339 16r5538 16r533A 16r5533 16r533B 16r555D 16r533C 16r5599 16r533D 16r5580 16r533E 16r54AF 16r533F 16r558A 16r5340 16r559F 16r5341 16r557B 16r5342 16r557E 16r5343 16r5598 16r5344 16r559E 16r5345 16r55AE 16r5346 16r557C 16r5347 16r5583 16r5348 16r55A9 16r5349 16r5587 16r534A 16r55A8 16r534B 16r55DA 16r534C 16r55C5 16r534D 16r55DF 16r534E 16r55C4 16r534F 16r55DC 16r5350 16r55E4 16r5351 16r55D4 16r5352 16r5614 16r5353 16r55F7 16r5354 16r5616 16r5355 16r55FE 16r5356 16r55FD 16r5357 16r561B 16r5358 16r55F9 16r5359 16r564E 16r535A 16r5650 16r535B 16r71DF 16r535C 16r5634 16r535D 16r5636 16r535E 16r5632 16r535F 16r5638 16r5360 16r566B 16r5361 16r5664 16r5362 16r562F 16r5363 16r566C 16r5364 16r566A 16r5365 16r5686 16r5366 16r5680 16r5367 16r568A 16r5368 16r56A0 16r5369 16r5694 16r536A 16r568F 16r536B 16r56A5 16r536C 16r56AE 16r536D 16r56B6 16r536E 16r56B4 16r536F 16r56C2 16r5370 16r56BC 16r5371 16r56C1 16r5372 16r56C3 16r5373 16r56C0 16r5374 16r56C8 16r5375 16r56CE 16r5376 16r56D1 16r5377 16r56D3 16r5378 16r56D7 16r5379 16r56EE 16r537A 16r56F9 16r537B 16r5700 16r537C 16r56FF 16r537D 16r5704 16r537E 16r5709 16r5421 16r5708 16r5422 16r570B 16r5423 16r570D 16r5424 16r5713 16r5425 16r5718 16r5426 16r5716 16r5427 16r55C7 16r5428 16r571C 16r5429 16r5726 16r542A 16r5737 16r542B 16r5738 16r542C 16r574E 16r542D 16r573B 16r542E 16r5740 16r542F 16r574F 16r5430 16r5769 16r5431 16r57C0 16r5432 16r5788 16r5433 16r5761 16r5434 16r577F 16r5435 16r5789 16r5436 16r5793 16r5437 16r57A0 16r5438 16r57B3 16r5439 16r57A4 16r543A 16r57AA 16r543B 16r57B0 16r543C 16r57C3 16r543D 16r57C6 16r543E 16r57D4 16r543F 16r57D2 16r5440 16r57D3 16r5441 16r580A 16r5442 16r57D6 16r5443 16r57E3 16r5444 16r580B 16r5445 16r5819 16r5446 16r581D 16r5447 16r5872 16r5448 16r5821 16r5449 16r5862 16r544A 16r584B 16r544B 16r5870 16r544C 16r6BC0 16r544D 16r5852 16r544E 16r583D 16r544F 16r5879 16r5450 16r5885 16r5451 16r58B9 16r5452 16r589F 16r5453 16r58AB 16r5454 16r58BA 16r5455 16r58DE 16r5456 16r58BB 16r5457 16r58B8 16r5458 16r58AE 16r5459 16r58C5 16r545A 16r58D3 16r545B 16r58D1 16r545C 16r58D7 16r545D 16r58D9 16r545E 16r58D8 16r545F 16r58E5 16r5460 16r58DC 16r5461 16r58E4 16r5462 16r58DF 16r5463 16r58EF 16r5464 16r58FA 16r5465 16r58F9 16r5466 16r58FB 16r5467 16r58FC 16r5468 16r58FD 16r5469 16r5902 16r546A 16r590A 16r546B 16r5910 16r546C 16r591B 16r546D 16r68A6 16r546E 16r5925 16r546F 16r592C 16r5470 16r592D 16r5471 16r5932 16r5472 16r5938 16r5473 16r593E 16r5474 16r7AD2 16r5475 16r5955 16r5476 16r5950 16r5477 16r594E 16r5478 16r595A 16r5479 16r5958 16r547A 16r5962 16r547B 16r5960 16r547C 16r5967 16r547D 16r596C 16r547E 16r5969 16r5521 16r5978 16r5522 16r5981 16r5523 16r599D 16r5524 16r4F5E 16r5525 16r4FAB 16r5526 16r59A3 16r5527 16r59B2 16r5528 16r59C6 16r5529 16r59E8 16r552A 16r59DC 16r552B 16r598D 16r552C 16r59D9 16r552D 16r59DA 16r552E 16r5A25 16r552F 16r5A1F 16r5530 16r5A11 16r5531 16r5A1C 16r5532 16r5A09 16r5533 16r5A1A 16r5534 16r5A40 16r5535 16r5A6C 16r5536 16r5A49 16r5537 16r5A35 16r5538 16r5A36 16r5539 16r5A62 16r553A 16r5A6A 16r553B 16r5A9A 16r553C 16r5ABC 16r553D 16r5ABE 16r553E 16r5ACB 16r553F 16r5AC2 16r5540 16r5ABD 16r5541 16r5AE3 16r5542 16r5AD7 16r5543 16r5AE6 16r5544 16r5AE9 16r5545 16r5AD6 16r5546 16r5AFA 16r5547 16r5AFB 16r5548 16r5B0C 16r5549 16r5B0B 16r554A 16r5B16 16r554B 16r5B32 16r554C 16r5AD0 16r554D 16r5B2A 16r554E 16r5B36 16r554F 16r5B3E 16r5550 16r5B43 16r5551 16r5B45 16r5552 16r5B40 16r5553 16r5B51 16r5554 16r5B55 16r5555 16r5B5A 16r5556 16r5B5B 16r5557 16r5B65 16r5558 16r5B69 16r5559 16r5B70 16r555A 16r5B73 16r555B 16r5B75 16r555C 16r5B78 16r555D 16r6588 16r555E 16r5B7A 16r555F 16r5B80 16r5560 16r5B83 16r5561 16r5BA6 16r5562 16r5BB8 16r5563 16r5BC3 16r5564 16r5BC7 16r5565 16r5BC9 16r5566 16r5BD4 16r5567 16r5BD0 16r5568 16r5BE4 16r5569 16r5BE6 16r556A 16r5BE2 16r556B 16r5BDE 16r556C 16r5BE5 16r556D 16r5BEB 16r556E 16r5BF0 16r556F 16r5BF6 16r5570 16r5BF3 16r5571 16r5C05 16r5572 16r5C07 16r5573 16r5C08 16r5574 16r5C0D 16r5575 16r5C13 16r5576 16r5C20 16r5577 16r5C22 16r5578 16r5C28 16r5579 16r5C38 16r557A 16r5C39 16r557B 16r5C41 16r557C 16r5C46 16r557D 16r5C4E 16r557E 16r5C53 16r5621 16r5C50 16r5622 16r5C4F 16r5623 16r5B71 16r5624 16r5C6C 16r5625 16r5C6E 16r5626 16r4E62 16r5627 16r5C76 16r5628 16r5C79 16r5629 16r5C8C 16r562A 16r5C91 16r562B 16r5C94 16r562C 16r599B 16r562D 16r5CAB 16r562E 16r5CBB 16r562F 16r5CB6 16r5630 16r5CBC 16r5631 16r5CB7 16r5632 16r5CC5 16r5633 16r5CBE 16r5634 16r5CC7 16r5635 16r5CD9 16r5636 16r5CE9 16r5637 16r5CFD 16r5638 16r5CFA 16r5639 16r5CED 16r563A 16r5D8C 16r563B 16r5CEA 16r563C 16r5D0B 16r563D 16r5D15 16r563E 16r5D17 16r563F 16r5D5C 16r5640 16r5D1F 16r5641 16r5D1B 16r5642 16r5D11 16r5643 16r5D14 16r5644 16r5D22 16r5645 16r5D1A 16r5646 16r5D19 16r5647 16r5D18 16r5648 16r5D4C 16r5649 16r5D52 16r564A 16r5D4E 16r564B 16r5D4B 16r564C 16r5D6C 16r564D 16r5D73 16r564E 16r5D76 16r564F 16r5D87 16r5650 16r5D84 16r5651 16r5D82 16r5652 16r5DA2 16r5653 16r5D9D 16r5654 16r5DAC 16r5655 16r5DAE 16r5656 16r5DBD 16r5657 16r5D90 16r5658 16r5DB7 16r5659 16r5DBC 16r565A 16r5DC9 16r565B 16r5DCD 16r565C 16r5DD3 16r565D 16r5DD2 16r565E 16r5DD6 16r565F 16r5DDB 16r5660 16r5DEB 16r5661 16r5DF2 16r5662 16r5DF5 16r5663 16r5E0B 16r5664 16r5E1A 16r5665 16r5E19 16r5666 16r5E11 16r5667 16r5E1B 16r5668 16r5E36 16r5669 16r5E37 16r566A 16r5E44 16r566B 16r5E43 16r566C 16r5E40 16r566D 16r5E4E 16r566E 16r5E57 16r566F 16r5E54 16r5670 16r5E5F 16r5671 16r5E62 16r5672 16r5E64 16r5673 16r5E47 16r5674 16r5E75 16r5675 16r5E76 16r5676 16r5E7A 16r5677 16r9EBC 16r5678 16r5E7F 16r5679 16r5EA0 16r567A 16r5EC1 16r567B 16r5EC2 16r567C 16r5EC8 16r567D 16r5ED0 16r567E 16r5ECF 16r5721 16r5ED6 16r5722 16r5EE3 16r5723 16r5EDD 16r5724 16r5EDA 16r5725 16r5EDB 16r5726 16r5EE2 16r5727 16r5EE1 16r5728 16r5EE8 16r5729 16r5EE9 16r572A 16r5EEC 16r572B 16r5EF1 16r572C 16r5EF3 16r572D 16r5EF0 16r572E 16r5EF4 16r572F 16r5EF8 16r5730 16r5EFE 16r5731 16r5F03 16r5732 16r5F09 16r5733 16r5F5D 16r5734 16r5F5C 16r5735 16r5F0B 16r5736 16r5F11 16r5737 16r5F16 16r5738 16r5F29 16r5739 16r5F2D 16r573A 16r5F38 16r573B 16r5F41 16r573C 16r5F48 16r573D 16r5F4C 16r573E 16r5F4E 16r573F 16r5F2F 16r5740 16r5F51 16r5741 16r5F56 16r5742 16r5F57 16r5743 16r5F59 16r5744 16r5F61 16r5745 16r5F6D 16r5746 16r5F73 16r5747 16r5F77 16r5748 16r5F83 16r5749 16r5F82 16r574A 16r5F7F 16r574B 16r5F8A 16r574C 16r5F88 16r574D 16r5F91 16r574E 16r5F87 16r574F 16r5F9E 16r5750 16r5F99 16r5751 16r5F98 16r5752 16r5FA0 16r5753 16r5FA8 16r5754 16r5FAD 16r5755 16r5FBC 16r5756 16r5FD6 16r5757 16r5FFB 16r5758 16r5FE4 16r5759 16r5FF8 16r575A 16r5FF1 16r575B 16r5FDD 16r575C 16r60B3 16r575D 16r5FFF 16r575E 16r6021 16r575F 16r6060 16r5760 16r6019 16r5761 16r6010 16r5762 16r6029 16r5763 16r600E 16r5764 16r6031 16r5765 16r601B 16r5766 16r6015 16r5767 16r602B 16r5768 16r6026 16r5769 16r600F 16r576A 16r603A 16r576B 16r605A 16r576C 16r6041 16r576D 16r606A 16r576E 16r6077 16r576F 16r605F 16r5770 16r604A 16r5771 16r6046 16r5772 16r604D 16r5773 16r6063 16r5774 16r6043 16r5775 16r6064 16r5776 16r6042 16r5777 16r606C 16r5778 16r606B 16r5779 16r6059 16r577A 16r6081 16r577B 16r608D 16r577C 16r60E7 16r577D 16r6083 16r577E 16r609A 16r5821 16r6084 16r5822 16r609B 16r5823 16r6096 16r5824 16r6097 16r5825 16r6092 16r5826 16r60A7 16r5827 16r608B 16r5828 16r60E1 16r5829 16r60B8 16r582A 16r60E0 16r582B 16r60D3 16r582C 16r60B4 16r582D 16r5FF0 16r582E 16r60BD 16r582F 16r60C6 16r5830 16r60B5 16r5831 16r60D8 16r5832 16r614D 16r5833 16r6115 16r5834 16r6106 16r5835 16r60F6 16r5836 16r60F7 16r5837 16r6100 16r5838 16r60F4 16r5839 16r60FA 16r583A 16r6103 16r583B 16r6121 16r583C 16r60FB 16r583D 16r60F1 16r583E 16r610D 16r583F 16r610E 16r5840 16r6147 16r5841 16r613E 16r5842 16r6128 16r5843 16r6127 16r5844 16r614A 16r5845 16r613F 16r5846 16r613C 16r5847 16r612C 16r5848 16r6134 16r5849 16r613D 16r584A 16r6142 16r584B 16r6144 16r584C 16r6173 16r584D 16r6177 16r584E 16r6158 16r584F 16r6159 16r5850 16r615A 16r5851 16r616B 16r5852 16r6174 16r5853 16r616F 16r5854 16r6165 16r5855 16r6171 16r5856 16r615F 16r5857 16r615D 16r5858 16r6153 16r5859 16r6175 16r585A 16r6199 16r585B 16r6196 16r585C 16r6187 16r585D 16r61AC 16r585E 16r6194 16r585F 16r619A 16r5860 16r618A 16r5861 16r6191 16r5862 16r61AB 16r5863 16r61AE 16r5864 16r61CC 16r5865 16r61CA 16r5866 16r61C9 16r5867 16r61F7 16r5868 16r61C8 16r5869 16r61C3 16r586A 16r61C6 16r586B 16r61BA 16r586C 16r61CB 16r586D 16r7F79 16r586E 16r61CD 16r586F 16r61E6 16r5870 16r61E3 16r5871 16r61F6 16r5872 16r61FA 16r5873 16r61F4 16r5874 16r61FF 16r5875 16r61FD 16r5876 16r61FC 16r5877 16r61FE 16r5878 16r6200 16r5879 16r6208 16r587A 16r6209 16r587B 16r620D 16r587C 16r620C 16r587D 16r6214 16r587E 16r621B 16r5921 16r621E 16r5922 16r6221 16r5923 16r622A 16r5924 16r622E 16r5925 16r6230 16r5926 16r6232 16r5927 16r6233 16r5928 16r6241 16r5929 16r624E 16r592A 16r625E 16r592B 16r6263 16r592C 16r625B 16r592D 16r6260 16r592E 16r6268 16r592F 16r627C 16r5930 16r6282 16r5931 16r6289 16r5932 16r627E 16r5933 16r6292 16r5934 16r6293 16r5935 16r6296 16r5936 16r62D4 16r5937 16r6283 16r5938 16r6294 16r5939 16r62D7 16r593A 16r62D1 16r593B 16r62BB 16r593C 16r62CF 16r593D 16r62FF 16r593E 16r62C6 16r593F 16r64D4 16r5940 16r62C8 16r5941 16r62DC 16r5942 16r62CC 16r5943 16r62CA 16r5944 16r62C2 16r5945 16r62C7 16r5946 16r629B 16r5947 16r62C9 16r5948 16r630C 16r5949 16r62EE 16r594A 16r62F1 16r594B 16r6327 16r594C 16r6302 16r594D 16r6308 16r594E 16r62EF 16r594F 16r62F5 16r5950 16r6350 16r5951 16r633E 16r5952 16r634D 16r5953 16r641C 16r5954 16r634F 16r5955 16r6396 16r5956 16r638E 16r5957 16r6380 16r5958 16r63AB 16r5959 16r6376 16r595A 16r63A3 16r595B 16r638F 16r595C 16r6389 16r595D 16r639F 16r595E 16r63B5 16r595F 16r636B 16r5960 16r6369 16r5961 16r63BE 16r5962 16r63E9 16r5963 16r63C0 16r5964 16r63C6 16r5965 16r63E3 16r5966 16r63C9 16r5967 16r63D2 16r5968 16r63F6 16r5969 16r63C4 16r596A 16r6416 16r596B 16r6434 16r596C 16r6406 16r596D 16r6413 16r596E 16r6426 16r596F 16r6436 16r5970 16r651D 16r5971 16r6417 16r5972 16r6428 16r5973 16r640F 16r5974 16r6467 16r5975 16r646F 16r5976 16r6476 16r5977 16r644E 16r5978 16r652A 16r5979 16r6495 16r597A 16r6493 16r597B 16r64A5 16r597C 16r64A9 16r597D 16r6488 16r597E 16r64BC 16r5A21 16r64DA 16r5A22 16r64D2 16r5A23 16r64C5 16r5A24 16r64C7 16r5A25 16r64BB 16r5A26 16r64D8 16r5A27 16r64C2 16r5A28 16r64F1 16r5A29 16r64E7 16r5A2A 16r8209 16r5A2B 16r64E0 16r5A2C 16r64E1 16r5A2D 16r62AC 16r5A2E 16r64E3 16r5A2F 16r64EF 16r5A30 16r652C 16r5A31 16r64F6 16r5A32 16r64F4 16r5A33 16r64F2 16r5A34 16r64FA 16r5A35 16r6500 16r5A36 16r64FD 16r5A37 16r6518 16r5A38 16r651C 16r5A39 16r6505 16r5A3A 16r6524 16r5A3B 16r6523 16r5A3C 16r652B 16r5A3D 16r6534 16r5A3E 16r6535 16r5A3F 16r6537 16r5A40 16r6536 16r5A41 16r6538 16r5A42 16r754B 16r5A43 16r6548 16r5A44 16r6556 16r5A45 16r6555 16r5A46 16r654D 16r5A47 16r6558 16r5A48 16r655E 16r5A49 16r655D 16r5A4A 16r6572 16r5A4B 16r6578 16r5A4C 16r6582 16r5A4D 16r6583 16r5A4E 16r8B8A 16r5A4F 16r659B 16r5A50 16r659F 16r5A51 16r65AB 16r5A52 16r65B7 16r5A53 16r65C3 16r5A54 16r65C6 16r5A55 16r65C1 16r5A56 16r65C4 16r5A57 16r65CC 16r5A58 16r65D2 16r5A59 16r65DB 16r5A5A 16r65D9 16r5A5B 16r65E0 16r5A5C 16r65E1 16r5A5D 16r65F1 16r5A5E 16r6772 16r5A5F 16r660A 16r5A60 16r6603 16r5A61 16r65FB 16r5A62 16r6773 16r5A63 16r6635 16r5A64 16r6636 16r5A65 16r6634 16r5A66 16r661C 16r5A67 16r664F 16r5A68 16r6644 16r5A69 16r6649 16r5A6A 16r6641 16r5A6B 16r665E 16r5A6C 16r665D 16r5A6D 16r6664 16r5A6E 16r6667 16r5A6F 16r6668 16r5A70 16r665F 16r5A71 16r6662 16r5A72 16r6670 16r5A73 16r6683 16r5A74 16r6688 16r5A75 16r668E 16r5A76 16r6689 16r5A77 16r6684 16r5A78 16r6698 16r5A79 16r669D 16r5A7A 16r66C1 16r5A7B 16r66B9 16r5A7C 16r66C9 16r5A7D 16r66BE 16r5A7E 16r66BC 16r5B21 16r66C4 16r5B22 16r66B8 16r5B23 16r66D6 16r5B24 16r66DA 16r5B25 16r66E0 16r5B26 16r663F 16r5B27 16r66E6 16r5B28 16r66E9 16r5B29 16r66F0 16r5B2A 16r66F5 16r5B2B 16r66F7 16r5B2C 16r670F 16r5B2D 16r6716 16r5B2E 16r671E 16r5B2F 16r6726 16r5B30 16r6727 16r5B31 16r9738 16r5B32 16r672E 16r5B33 16r673F 16r5B34 16r6736 16r5B35 16r6741 16r5B36 16r6738 16r5B37 16r6737 16r5B38 16r6746 16r5B39 16r675E 16r5B3A 16r6760 16r5B3B 16r6759 16r5B3C 16r6763 16r5B3D 16r6764 16r5B3E 16r6789 16r5B3F 16r6770 16r5B40 16r67A9 16r5B41 16r677C 16r5B42 16r676A 16r5B43 16r678C 16r5B44 16r678B 16r5B45 16r67A6 16r5B46 16r67A1 16r5B47 16r6785 16r5B48 16r67B7 16r5B49 16r67EF 16r5B4A 16r67B4 16r5B4B 16r67EC 16r5B4C 16r67B3 16r5B4D 16r67E9 16r5B4E 16r67B8 16r5B4F 16r67E4 16r5B50 16r67DE 16r5B51 16r67DD 16r5B52 16r67E2 16r5B53 16r67EE 16r5B54 16r67B9 16r5B55 16r67CE 16r5B56 16r67C6 16r5B57 16r67E7 16r5B58 16r6A9C 16r5B59 16r681E 16r5B5A 16r6846 16r5B5B 16r6829 16r5B5C 16r6840 16r5B5D 16r684D 16r5B5E 16r6832 16r5B5F 16r684E 16r5B60 16r68B3 16r5B61 16r682B 16r5B62 16r6859 16r5B63 16r6863 16r5B64 16r6877 16r5B65 16r687F 16r5B66 16r689F 16r5B67 16r688F 16r5B68 16r68AD 16r5B69 16r6894 16r5B6A 16r689D 16r5B6B 16r689B 16r5B6C 16r6883 16r5B6D 16r6AAE 16r5B6E 16r68B9 16r5B6F 16r6874 16r5B70 16r68B5 16r5B71 16r68A0 16r5B72 16r68BA 16r5B73 16r690F 16r5B74 16r688D 16r5B75 16r687E 16r5B76 16r6901 16r5B77 16r68CA 16r5B78 16r6908 16r5B79 16r68D8 16r5B7A 16r6922 16r5B7B 16r6926 16r5B7C 16r68E1 16r5B7D 16r690C 16r5B7E 16r68CD 16r5C21 16r68D4 16r5C22 16r68E7 16r5C23 16r68D5 16r5C24 16r6936 16r5C25 16r6912 16r5C26 16r6904 16r5C27 16r68D7 16r5C28 16r68E3 16r5C29 16r6925 16r5C2A 16r68F9 16r5C2B 16r68E0 16r5C2C 16r68EF 16r5C2D 16r6928 16r5C2E 16r692A 16r5C2F 16r691A 16r5C30 16r6923 16r5C31 16r6921 16r5C32 16r68C6 16r5C33 16r6979 16r5C34 16r6977 16r5C35 16r695C 16r5C36 16r6978 16r5C37 16r696B 16r5C38 16r6954 16r5C39 16r697E 16r5C3A 16r696E 16r5C3B 16r6939 16r5C3C 16r6974 16r5C3D 16r693D 16r5C3E 16r6959 16r5C3F 16r6930 16r5C40 16r6961 16r5C41 16r695E 16r5C42 16r695D 16r5C43 16r6981 16r5C44 16r696A 16r5C45 16r69B2 16r5C46 16r69AE 16r5C47 16r69D0 16r5C48 16r69BF 16r5C49 16r69C1 16r5C4A 16r69D3 16r5C4B 16r69BE 16r5C4C 16r69CE 16r5C4D 16r5BE8 16r5C4E 16r69CA 16r5C4F 16r69DD 16r5C50 16r69BB 16r5C51 16r69C3 16r5C52 16r69A7 16r5C53 16r6A2E 16r5C54 16r6991 16r5C55 16r69A0 16r5C56 16r699C 16r5C57 16r6995 16r5C58 16r69B4 16r5C59 16r69DE 16r5C5A 16r69E8 16r5C5B 16r6A02 16r5C5C 16r6A1B 16r5C5D 16r69FF 16r5C5E 16r6B0A 16r5C5F 16r69F9 16r5C60 16r69F2 16r5C61 16r69E7 16r5C62 16r6A05 16r5C63 16r69B1 16r5C64 16r6A1E 16r5C65 16r69ED 16r5C66 16r6A14 16r5C67 16r69EB 16r5C68 16r6A0A 16r5C69 16r6A12 16r5C6A 16r6AC1 16r5C6B 16r6A23 16r5C6C 16r6A13 16r5C6D 16r6A44 16r5C6E 16r6A0C 16r5C6F 16r6A72 16r5C70 16r6A36 16r5C71 16r6A78 16r5C72 16r6A47 16r5C73 16r6A62 16r5C74 16r6A59 16r5C75 16r6A66 16r5C76 16r6A48 16r5C77 16r6A38 16r5C78 16r6A22 16r5C79 16r6A90 16r5C7A 16r6A8D 16r5C7B 16r6AA0 16r5C7C 16r6A84 16r5C7D 16r6AA2 16r5C7E 16r6AA3 16r5D21 16r6A97 16r5D22 16r8617 16r5D23 16r6ABB 16r5D24 16r6AC3 16r5D25 16r6AC2 16r5D26 16r6AB8 16r5D27 16r6AB3 16r5D28 16r6AAC 16r5D29 16r6ADE 16r5D2A 16r6AD1 16r5D2B 16r6ADF 16r5D2C 16r6AAA 16r5D2D 16r6ADA 16r5D2E 16r6AEA 16r5D2F 16r6AFB 16r5D30 16r6B05 16r5D31 16r8616 16r5D32 16r6AFA 16r5D33 16r6B12 16r5D34 16r6B16 16r5D35 16r9B31 16r5D36 16r6B1F 16r5D37 16r6B38 16r5D38 16r6B37 16r5D39 16r76DC 16r5D3A 16r6B39 16r5D3B 16r98EE 16r5D3C 16r6B47 16r5D3D 16r6B43 16r5D3E 16r6B49 16r5D3F 16r6B50 16r5D40 16r6B59 16r5D41 16r6B54 16r5D42 16r6B5B 16r5D43 16r6B5F 16r5D44 16r6B61 16r5D45 16r6B78 16r5D46 16r6B79 16r5D47 16r6B7F 16r5D48 16r6B80 16r5D49 16r6B84 16r5D4A 16r6B83 16r5D4B 16r6B8D 16r5D4C 16r6B98 16r5D4D 16r6B95 16r5D4E 16r6B9E 16r5D4F 16r6BA4 16r5D50 16r6BAA 16r5D51 16r6BAB 16r5D52 16r6BAF 16r5D53 16r6BB2 16r5D54 16r6BB1 16r5D55 16r6BB3 16r5D56 16r6BB7 16r5D57 16r6BBC 16r5D58 16r6BC6 16r5D59 16r6BCB 16r5D5A 16r6BD3 16r5D5B 16r6BDF 16r5D5C 16r6BEC 16r5D5D 16r6BEB 16r5D5E 16r6BF3 16r5D5F 16r6BEF 16r5D60 16r9EBE 16r5D61 16r6C08 16r5D62 16r6C13 16r5D63 16r6C14 16r5D64 16r6C1B 16r5D65 16r6C24 16r5D66 16r6C23 16r5D67 16r6C5E 16r5D68 16r6C55 16r5D69 16r6C62 16r5D6A 16r6C6A 16r5D6B 16r6C82 16r5D6C 16r6C8D 16r5D6D 16r6C9A 16r5D6E 16r6C81 16r5D6F 16r6C9B 16r5D70 16r6C7E 16r5D71 16r6C68 16r5D72 16r6C73 16r5D73 16r6C92 16r5D74 16r6C90 16r5D75 16r6CC4 16r5D76 16r6CF1 16r5D77 16r6CD3 16r5D78 16r6CBD 16r5D79 16r6CD7 16r5D7A 16r6CC5 16r5D7B 16r6CDD 16r5D7C 16r6CAE 16r5D7D 16r6CB1 16r5D7E 16r6CBE 16r5E21 16r6CBA 16r5E22 16r6CDB 16r5E23 16r6CEF 16r5E24 16r6CD9 16r5E25 16r6CEA 16r5E26 16r6D1F 16r5E27 16r884D 16r5E28 16r6D36 16r5E29 16r6D2B 16r5E2A 16r6D3D 16r5E2B 16r6D38 16r5E2C 16r6D19 16r5E2D 16r6D35 16r5E2E 16r6D33 16r5E2F 16r6D12 16r5E30 16r6D0C 16r5E31 16r6D63 16r5E32 16r6D93 16r5E33 16r6D64 16r5E34 16r6D5A 16r5E35 16r6D79 16r5E36 16r6D59 16r5E37 16r6D8E 16r5E38 16r6D95 16r5E39 16r6FE4 16r5E3A 16r6D85 16r5E3B 16r6DF9 16r5E3C 16r6E15 16r5E3D 16r6E0A 16r5E3E 16r6DB5 16r5E3F 16r6DC7 16r5E40 16r6DE6 16r5E41 16r6DB8 16r5E42 16r6DC6 16r5E43 16r6DEC 16r5E44 16r6DDE 16r5E45 16r6DCC 16r5E46 16r6DE8 16r5E47 16r6DD2 16r5E48 16r6DC5 16r5E49 16r6DFA 16r5E4A 16r6DD9 16r5E4B 16r6DE4 16r5E4C 16r6DD5 16r5E4D 16r6DEA 16r5E4E 16r6DEE 16r5E4F 16r6E2D 16r5E50 16r6E6E 16r5E51 16r6E2E 16r5E52 16r6E19 16r5E53 16r6E72 16r5E54 16r6E5F 16r5E55 16r6E3E 16r5E56 16r6E23 16r5E57 16r6E6B 16r5E58 16r6E2B 16r5E59 16r6E76 16r5E5A 16r6E4D 16r5E5B 16r6E1F 16r5E5C 16r6E43 16r5E5D 16r6E3A 16r5E5E 16r6E4E 16r5E5F 16r6E24 16r5E60 16r6EFF 16r5E61 16r6E1D 16r5E62 16r6E38 16r5E63 16r6E82 16r5E64 16r6EAA 16r5E65 16r6E98 16r5E66 16r6EC9 16r5E67 16r6EB7 16r5E68 16r6ED3 16r5E69 16r6EBD 16r5E6A 16r6EAF 16r5E6B 16r6EC4 16r5E6C 16r6EB2 16r5E6D 16r6ED4 16r5E6E 16r6ED5 16r5E6F 16r6E8F 16r5E70 16r6EA5 16r5E71 16r6EC2 16r5E72 16r6E9F 16r5E73 16r6F41 16r5E74 16r6F11 16r5E75 16r704C 16r5E76 16r6EEC 16r5E77 16r6EF8 16r5E78 16r6EFE 16r5E79 16r6F3F 16r5E7A 16r6EF2 16r5E7B 16r6F31 16r5E7C 16r6EEF 16r5E7D 16r6F32 16r5E7E 16r6ECC 16r5F21 16r6F3E 16r5F22 16r6F13 16r5F23 16r6EF7 16r5F24 16r6F86 16r5F25 16r6F7A 16r5F26 16r6F78 16r5F27 16r6F81 16r5F28 16r6F80 16r5F29 16r6F6F 16r5F2A 16r6F5B 16r5F2B 16r6FF3 16r5F2C 16r6F6D 16r5F2D 16r6F82 16r5F2E 16r6F7C 16r5F2F 16r6F58 16r5F30 16r6F8E 16r5F31 16r6F91 16r5F32 16r6FC2 16r5F33 16r6F66 16r5F34 16r6FB3 16r5F35 16r6FA3 16r5F36 16r6FA1 16r5F37 16r6FA4 16r5F38 16r6FB9 16r5F39 16r6FC6 16r5F3A 16r6FAA 16r5F3B 16r6FDF 16r5F3C 16r6FD5 16r5F3D 16r6FEC 16r5F3E 16r6FD4 16r5F3F 16r6FD8 16r5F40 16r6FF1 16r5F41 16r6FEE 16r5F42 16r6FDB 16r5F43 16r7009 16r5F44 16r700B 16r5F45 16r6FFA 16r5F46 16r7011 16r5F47 16r7001 16r5F48 16r700F 16r5F49 16r6FFE 16r5F4A 16r701B 16r5F4B 16r701A 16r5F4C 16r6F74 16r5F4D 16r701D 16r5F4E 16r7018 16r5F4F 16r701F 16r5F50 16r7030 16r5F51 16r703E 16r5F52 16r7032 16r5F53 16r7051 16r5F54 16r7063 16r5F55 16r7099 16r5F56 16r7092 16r5F57 16r70AF 16r5F58 16r70F1 16r5F59 16r70AC 16r5F5A 16r70B8 16r5F5B 16r70B3 16r5F5C 16r70AE 16r5F5D 16r70DF 16r5F5E 16r70CB 16r5F5F 16r70DD 16r5F60 16r70D9 16r5F61 16r7109 16r5F62 16r70FD 16r5F63 16r711C 16r5F64 16r7119 16r5F65 16r7165 16r5F66 16r7155 16r5F67 16r7188 16r5F68 16r7166 16r5F69 16r7162 16r5F6A 16r714C 16r5F6B 16r7156 16r5F6C 16r716C 16r5F6D 16r718F 16r5F6E 16r71FB 16r5F6F 16r7184 16r5F70 16r7195 16r5F71 16r71A8 16r5F72 16r71AC 16r5F73 16r71D7 16r5F74 16r71B9 16r5F75 16r71BE 16r5F76 16r71D2 16r5F77 16r71C9 16r5F78 16r71D4 16r5F79 16r71CE 16r5F7A 16r71E0 16r5F7B 16r71EC 16r5F7C 16r71E7 16r5F7D 16r71F5 16r5F7E 16r71FC 16r6021 16r71F9 16r6022 16r71FF 16r6023 16r720D 16r6024 16r7210 16r6025 16r721B 16r6026 16r7228 16r6027 16r722D 16r6028 16r722C 16r6029 16r7230 16r602A 16r7232 16r602B 16r723B 16r602C 16r723C 16r602D 16r723F 16r602E 16r7240 16r602F 16r7246 16r6030 16r724B 16r6031 16r7258 16r6032 16r7274 16r6033 16r727E 16r6034 16r7282 16r6035 16r7281 16r6036 16r7287 16r6037 16r7292 16r6038 16r7296 16r6039 16r72A2 16r603A 16r72A7 16r603B 16r72B9 16r603C 16r72B2 16r603D 16r72C3 16r603E 16r72C6 16r603F 16r72C4 16r6040 16r72CE 16r6041 16r72D2 16r6042 16r72E2 16r6043 16r72E0 16r6044 16r72E1 16r6045 16r72F9 16r6046 16r72F7 16r6047 16r500F 16r6048 16r7317 16r6049 16r730A 16r604A 16r731C 16r604B 16r7316 16r604C 16r731D 16r604D 16r7334 16r604E 16r732F 16r604F 16r7329 16r6050 16r7325 16r6051 16r733E 16r6052 16r734E 16r6053 16r734F 16r6054 16r9ED8 16r6055 16r7357 16r6056 16r736A 16r6057 16r7368 16r6058 16r7370 16r6059 16r7378 16r605A 16r7375 16r605B 16r737B 16r605C 16r737A 16r605D 16r73C8 16r605E 16r73B3 16r605F 16r73CE 16r6060 16r73BB 16r6061 16r73C0 16r6062 16r73E5 16r6063 16r73EE 16r6064 16r73DE 16r6065 16r74A2 16r6066 16r7405 16r6067 16r746F 16r6068 16r7425 16r6069 16r73F8 16r606A 16r7432 16r606B 16r743A 16r606C 16r7455 16r606D 16r743F 16r606E 16r745F 16r606F 16r7459 16r6070 16r7441 16r6071 16r745C 16r6072 16r7469 16r6073 16r7470 16r6074 16r7463 16r6075 16r746A 16r6076 16r7476 16r6077 16r747E 16r6078 16r748B 16r6079 16r749E 16r607A 16r74A7 16r607B 16r74CA 16r607C 16r74CF 16r607D 16r74D4 16r607E 16r73F1 16r6121 16r74E0 16r6122 16r74E3 16r6123 16r74E7 16r6124 16r74E9 16r6125 16r74EE 16r6126 16r74F2 16r6127 16r74F0 16r6128 16r74F1 16r6129 16r74F8 16r612A 16r74F7 16r612B 16r7504 16r612C 16r7503 16r612D 16r7505 16r612E 16r750C 16r612F 16r750E 16r6130 16r750D 16r6131 16r7515 16r6132 16r7513 16r6133 16r751E 16r6134 16r7526 16r6135 16r752C 16r6136 16r753C 16r6137 16r7544 16r6138 16r754D 16r6139 16r754A 16r613A 16r7549 16r613B 16r755B 16r613C 16r7546 16r613D 16r755A 16r613E 16r7569 16r613F 16r7564 16r6140 16r7567 16r6141 16r756B 16r6142 16r756D 16r6143 16r7578 16r6144 16r7576 16r6145 16r7586 16r6146 16r7587 16r6147 16r7574 16r6148 16r758A 16r6149 16r7589 16r614A 16r7582 16r614B 16r7594 16r614C 16r759A 16r614D 16r759D 16r614E 16r75A5 16r614F 16r75A3 16r6150 16r75C2 16r6151 16r75B3 16r6152 16r75C3 16r6153 16r75B5 16r6154 16r75BD 16r6155 16r75B8 16r6156 16r75BC 16r6157 16r75B1 16r6158 16r75CD 16r6159 16r75CA 16r615A 16r75D2 16r615B 16r75D9 16r615C 16r75E3 16r615D 16r75DE 16r615E 16r75FE 16r615F 16r75FF 16r6160 16r75FC 16r6161 16r7601 16r6162 16r75F0 16r6163 16r75FA 16r6164 16r75F2 16r6165 16r75F3 16r6166 16r760B 16r6167 16r760D 16r6168 16r7609 16r6169 16r761F 16r616A 16r7627 16r616B 16r7620 16r616C 16r7621 16r616D 16r7622 16r616E 16r7624 16r616F 16r7634 16r6170 16r7630 16r6171 16r763B 16r6172 16r7647 16r6173 16r7648 16r6174 16r7646 16r6175 16r765C 16r6176 16r7658 16r6177 16r7661 16r6178 16r7662 16r6179 16r7668 16r617A 16r7669 16r617B 16r766A 16r617C 16r7667 16r617D 16r766C 16r617E 16r7670 16r6221 16r7672 16r6222 16r7676 16r6223 16r7678 16r6224 16r767C 16r6225 16r7680 16r6226 16r7683 16r6227 16r7688 16r6228 16r768B 16r6229 16r768E 16r622A 16r7696 16r622B 16r7693 16r622C 16r7699 16r622D 16r769A 16r622E 16r76B0 16r622F 16r76B4 16r6230 16r76B8 16r6231 16r76B9 16r6232 16r76BA 16r6233 16r76C2 16r6234 16r76CD 16r6235 16r76D6 16r6236 16r76D2 16r6237 16r76DE 16r6238 16r76E1 16r6239 16r76E5 16r623A 16r76E7 16r623B 16r76EA 16r623C 16r862F 16r623D 16r76FB 16r623E 16r7708 16r623F 16r7707 16r6240 16r7704 16r6241 16r7729 16r6242 16r7724 16r6243 16r771E 16r6244 16r7725 16r6245 16r7726 16r6246 16r771B 16r6247 16r7737 16r6248 16r7738 16r6249 16r7747 16r624A 16r775A 16r624B 16r7768 16r624C 16r776B 16r624D 16r775B 16r624E 16r7765 16r624F 16r777F 16r6250 16r777E 16r6251 16r7779 16r6252 16r778E 16r6253 16r778B 16r6254 16r7791 16r6255 16r77A0 16r6256 16r779E 16r6257 16r77B0 16r6258 16r77B6 16r6259 16r77B9 16r625A 16r77BF 16r625B 16r77BC 16r625C 16r77BD 16r625D 16r77BB 16r625E 16r77C7 16r625F 16r77CD 16r6260 16r77D7 16r6261 16r77DA 16r6262 16r77DC 16r6263 16r77E3 16r6264 16r77EE 16r6265 16r77FC 16r6266 16r780C 16r6267 16r7812 16r6268 16r7926 16r6269 16r7820 16r626A 16r792A 16r626B 16r7845 16r626C 16r788E 16r626D 16r7874 16r626E 16r7886 16r626F 16r787C 16r6270 16r789A 16r6271 16r788C 16r6272 16r78A3 16r6273 16r78B5 16r6274 16r78AA 16r6275 16r78AF 16r6276 16r78D1 16r6277 16r78C6 16r6278 16r78CB 16r6279 16r78D4 16r627A 16r78BE 16r627B 16r78BC 16r627C 16r78C5 16r627D 16r78CA 16r627E 16r78EC 16r6321 16r78E7 16r6322 16r78DA 16r6323 16r78FD 16r6324 16r78F4 16r6325 16r7907 16r6326 16r7912 16r6327 16r7911 16r6328 16r7919 16r6329 16r792C 16r632A 16r792B 16r632B 16r7940 16r632C 16r7960 16r632D 16r7957 16r632E 16r795F 16r632F 16r795A 16r6330 16r7955 16r6331 16r7953 16r6332 16r797A 16r6333 16r797F 16r6334 16r798A 16r6335 16r799D 16r6336 16r79A7 16r6337 16r9F4B 16r6338 16r79AA 16r6339 16r79AE 16r633A 16r79B3 16r633B 16r79B9 16r633C 16r79BA 16r633D 16r79C9 16r633E 16r79D5 16r633F 16r79E7 16r6340 16r79EC 16r6341 16r79E1 16r6342 16r79E3 16r6343 16r7A08 16r6344 16r7A0D 16r6345 16r7A18 16r6346 16r7A19 16r6347 16r7A20 16r6348 16r7A1F 16r6349 16r7980 16r634A 16r7A31 16r634B 16r7A3B 16r634C 16r7A3E 16r634D 16r7A37 16r634E 16r7A43 16r634F 16r7A57 16r6350 16r7A49 16r6351 16r7A61 16r6352 16r7A62 16r6353 16r7A69 16r6354 16r9F9D 16r6355 16r7A70 16r6356 16r7A79 16r6357 16r7A7D 16r6358 16r7A88 16r6359 16r7A97 16r635A 16r7A95 16r635B 16r7A98 16r635C 16r7A96 16r635D 16r7AA9 16r635E 16r7AC8 16r635F 16r7AB0 16r6360 16r7AB6 16r6361 16r7AC5 16r6362 16r7AC4 16r6363 16r7ABF 16r6364 16r9083 16r6365 16r7AC7 16r6366 16r7ACA 16r6367 16r7ACD 16r6368 16r7ACF 16r6369 16r7AD5 16r636A 16r7AD3 16r636B 16r7AD9 16r636C 16r7ADA 16r636D 16r7ADD 16r636E 16r7AE1 16r636F 16r7AE2 16r6370 16r7AE6 16r6371 16r7AED 16r6372 16r7AF0 16r6373 16r7B02 16r6374 16r7B0F 16r6375 16r7B0A 16r6376 16r7B06 16r6377 16r7B33 16r6378 16r7B18 16r6379 16r7B19 16r637A 16r7B1E 16r637B 16r7B35 16r637C 16r7B28 16r637D 16r7B36 16r637E 16r7B50 16r6421 16r7B7A 16r6422 16r7B04 16r6423 16r7B4D 16r6424 16r7B0B 16r6425 16r7B4C 16r6426 16r7B45 16r6427 16r7B75 16r6428 16r7B65 16r6429 16r7B74 16r642A 16r7B67 16r642B 16r7B70 16r642C 16r7B71 16r642D 16r7B6C 16r642E 16r7B6E 16r642F 16r7B9D 16r6430 16r7B98 16r6431 16r7B9F 16r6432 16r7B8D 16r6433 16r7B9C 16r6434 16r7B9A 16r6435 16r7B8B 16r6436 16r7B92 16r6437 16r7B8F 16r6438 16r7B5D 16r6439 16r7B99 16r643A 16r7BCB 16r643B 16r7BC1 16r643C 16r7BCC 16r643D 16r7BCF 16r643E 16r7BB4 16r643F 16r7BC6 16r6440 16r7BDD 16r6441 16r7BE9 16r6442 16r7C11 16r6443 16r7C14 16r6444 16r7BE6 16r6445 16r7BE5 16r6446 16r7C60 16r6447 16r7C00 16r6448 16r7C07 16r6449 16r7C13 16r644A 16r7BF3 16r644B 16r7BF7 16r644C 16r7C17 16r644D 16r7C0D 16r644E 16r7BF6 16r644F 16r7C23 16r6450 16r7C27 16r6451 16r7C2A 16r6452 16r7C1F 16r6453 16r7C37 16r6454 16r7C2B 16r6455 16r7C3D 16r6456 16r7C4C 16r6457 16r7C43 16r6458 16r7C54 16r6459 16r7C4F 16r645A 16r7C40 16r645B 16r7C50 16r645C 16r7C58 16r645D 16r7C5F 16r645E 16r7C64 16r645F 16r7C56 16r6460 16r7C65 16r6461 16r7C6C 16r6462 16r7C75 16r6463 16r7C83 16r6464 16r7C90 16r6465 16r7CA4 16r6466 16r7CAD 16r6467 16r7CA2 16r6468 16r7CAB 16r6469 16r7CA1 16r646A 16r7CA8 16r646B 16r7CB3 16r646C 16r7CB2 16r646D 16r7CB1 16r646E 16r7CAE 16r646F 16r7CB9 16r6470 16r7CBD 16r6471 16r7CC0 16r6472 16r7CC5 16r6473 16r7CC2 16r6474 16r7CD8 16r6475 16r7CD2 16r6476 16r7CDC 16r6477 16r7CE2 16r6478 16r9B3B 16r6479 16r7CEF 16r647A 16r7CF2 16r647B 16r7CF4 16r647C 16r7CF6 16r647D 16r7CFA 16r647E 16r7D06 16r6521 16r7D02 16r6522 16r7D1C 16r6523 16r7D15 16r6524 16r7D0A 16r6525 16r7D45 16r6526 16r7D4B 16r6527 16r7D2E 16r6528 16r7D32 16r6529 16r7D3F 16r652A 16r7D35 16r652B 16r7D46 16r652C 16r7D73 16r652D 16r7D56 16r652E 16r7D4E 16r652F 16r7D72 16r6530 16r7D68 16r6531 16r7D6E 16r6532 16r7D4F 16r6533 16r7D63 16r6534 16r7D93 16r6535 16r7D89 16r6536 16r7D5B 16r6537 16r7D8F 16r6538 16r7D7D 16r6539 16r7D9B 16r653A 16r7DBA 16r653B 16r7DAE 16r653C 16r7DA3 16r653D 16r7DB5 16r653E 16r7DC7 16r653F 16r7DBD 16r6540 16r7DAB 16r6541 16r7E3D 16r6542 16r7DA2 16r6543 16r7DAF 16r6544 16r7DDC 16r6545 16r7DB8 16r6546 16r7D9F 16r6547 16r7DB0 16r6548 16r7DD8 16r6549 16r7DDD 16r654A 16r7DE4 16r654B 16r7DDE 16r654C 16r7DFB 16r654D 16r7DF2 16r654E 16r7DE1 16r654F 16r7E05 16r6550 16r7E0A 16r6551 16r7E23 16r6552 16r7E21 16r6553 16r7E12 16r6554 16r7E31 16r6555 16r7E1F 16r6556 16r7E09 16r6557 16r7E0B 16r6558 16r7E22 16r6559 16r7E46 16r655A 16r7E66 16r655B 16r7E3B 16r655C 16r7E35 16r655D 16r7E39 16r655E 16r7E43 16r655F 16r7E37 16r6560 16r7E32 16r6561 16r7E3A 16r6562 16r7E67 16r6563 16r7E5D 16r6564 16r7E56 16r6565 16r7E5E 16r6566 16r7E59 16r6567 16r7E5A 16r6568 16r7E79 16r6569 16r7E6A 16r656A 16r7E69 16r656B 16r7E7C 16r656C 16r7E7B 16r656D 16r7E83 16r656E 16r7DD5 16r656F 16r7E7D 16r6570 16r8FAE 16r6571 16r7E7F 16r6572 16r7E88 16r6573 16r7E89 16r6574 16r7E8C 16r6575 16r7E92 16r6576 16r7E90 16r6577 16r7E93 16r6578 16r7E94 16r6579 16r7E96 16r657A 16r7E8E 16r657B 16r7E9B 16r657C 16r7E9C 16r657D 16r7F38 16r657E 16r7F3A 16r6621 16r7F45 16r6622 16r7F4C 16r6623 16r7F4D 16r6624 16r7F4E 16r6625 16r7F50 16r6626 16r7F51 16r6627 16r7F55 16r6628 16r7F54 16r6629 16r7F58 16r662A 16r7F5F 16r662B 16r7F60 16r662C 16r7F68 16r662D 16r7F69 16r662E 16r7F67 16r662F 16r7F78 16r6630 16r7F82 16r6631 16r7F86 16r6632 16r7F83 16r6633 16r7F88 16r6634 16r7F87 16r6635 16r7F8C 16r6636 16r7F94 16r6637 16r7F9E 16r6638 16r7F9D 16r6639 16r7F9A 16r663A 16r7FA3 16r663B 16r7FAF 16r663C 16r7FB2 16r663D 16r7FB9 16r663E 16r7FAE 16r663F 16r7FB6 16r6640 16r7FB8 16r6641 16r8B71 16r6642 16r7FC5 16r6643 16r7FC6 16r6644 16r7FCA 16r6645 16r7FD5 16r6646 16r7FD4 16r6647 16r7FE1 16r6648 16r7FE6 16r6649 16r7FE9 16r664A 16r7FF3 16r664B 16r7FF9 16r664C 16r98DC 16r664D 16r8006 16r664E 16r8004 16r664F 16r800B 16r6650 16r8012 16r6651 16r8018 16r6652 16r8019 16r6653 16r801C 16r6654 16r8021 16r6655 16r8028 16r6656 16r803F 16r6657 16r803B 16r6658 16r804A 16r6659 16r8046 16r665A 16r8052 16r665B 16r8058 16r665C 16r805A 16r665D 16r805F 16r665E 16r8062 16r665F 16r8068 16r6660 16r8073 16r6661 16r8072 16r6662 16r8070 16r6663 16r8076 16r6664 16r8079 16r6665 16r807D 16r6666 16r807F 16r6667 16r8084 16r6668 16r8086 16r6669 16r8085 16r666A 16r809B 16r666B 16r8093 16r666C 16r809A 16r666D 16r80AD 16r666E 16r5190 16r666F 16r80AC 16r6670 16r80DB 16r6671 16r80E5 16r6672 16r80D9 16r6673 16r80DD 16r6674 16r80C4 16r6675 16r80DA 16r6676 16r80D6 16r6677 16r8109 16r6678 16r80EF 16r6679 16r80F1 16r667A 16r811B 16r667B 16r8129 16r667C 16r8123 16r667D 16r812F 16r667E 16r814B 16r6721 16r968B 16r6722 16r8146 16r6723 16r813E 16r6724 16r8153 16r6725 16r8151 16r6726 16r80FC 16r6727 16r8171 16r6728 16r816E 16r6729 16r8165 16r672A 16r8166 16r672B 16r8174 16r672C 16r8183 16r672D 16r8188 16r672E 16r818A 16r672F 16r8180 16r6730 16r8182 16r6731 16r81A0 16r6732 16r8195 16r6733 16r81A4 16r6734 16r81A3 16r6735 16r815F 16r6736 16r8193 16r6737 16r81A9 16r6738 16r81B0 16r6739 16r81B5 16r673A 16r81BE 16r673B 16r81B8 16r673C 16r81BD 16r673D 16r81C0 16r673E 16r81C2 16r673F 16r81BA 16r6740 16r81C9 16r6741 16r81CD 16r6742 16r81D1 16r6743 16r81D9 16r6744 16r81D8 16r6745 16r81C8 16r6746 16r81DA 16r6747 16r81DF 16r6748 16r81E0 16r6749 16r81E7 16r674A 16r81FA 16r674B 16r81FB 16r674C 16r81FE 16r674D 16r8201 16r674E 16r8202 16r674F 16r8205 16r6750 16r8207 16r6751 16r820A 16r6752 16r820D 16r6753 16r8210 16r6754 16r8216 16r6755 16r8229 16r6756 16r822B 16r6757 16r8238 16r6758 16r8233 16r6759 16r8240 16r675A 16r8259 16r675B 16r8258 16r675C 16r825D 16r675D 16r825A 16r675E 16r825F 16r675F 16r8264 16r6760 16r8262 16r6761 16r8268 16r6762 16r826A 16r6763 16r826B 16r6764 16r822E 16r6765 16r8271 16r6766 16r8277 16r6767 16r8278 16r6768 16r827E 16r6769 16r828D 16r676A 16r8292 16r676B 16r82AB 16r676C 16r829F 16r676D 16r82BB 16r676E 16r82AC 16r676F 16r82E1 16r6770 16r82E3 16r6771 16r82DF 16r6772 16r82D2 16r6773 16r82F4 16r6774 16r82F3 16r6775 16r82FA 16r6776 16r8393 16r6777 16r8303 16r6778 16r82FB 16r6779 16r82F9 16r677A 16r82DE 16r677B 16r8306 16r677C 16r82DC 16r677D 16r8309 16r677E 16r82D9 16r6821 16r8335 16r6822 16r8334 16r6823 16r8316 16r6824 16r8332 16r6825 16r8331 16r6826 16r8340 16r6827 16r8339 16r6828 16r8350 16r6829 16r8345 16r682A 16r832F 16r682B 16r832B 16r682C 16r8317 16r682D 16r8318 16r682E 16r8385 16r682F 16r839A 16r6830 16r83AA 16r6831 16r839F 16r6832 16r83A2 16r6833 16r8396 16r6834 16r8323 16r6835 16r838E 16r6836 16r8387 16r6837 16r838A 16r6838 16r837C 16r6839 16r83B5 16r683A 16r8373 16r683B 16r8375 16r683C 16r83A0 16r683D 16r8389 16r683E 16r83A8 16r683F 16r83F4 16r6840 16r8413 16r6841 16r83EB 16r6842 16r83CE 16r6843 16r83FD 16r6844 16r8403 16r6845 16r83D8 16r6846 16r840B 16r6847 16r83C1 16r6848 16r83F7 16r6849 16r8407 16r684A 16r83E0 16r684B 16r83F2 16r684C 16r840D 16r684D 16r8422 16r684E 16r8420 16r684F 16r83BD 16r6850 16r8438 16r6851 16r8506 16r6852 16r83FB 16r6853 16r846D 16r6854 16r842A 16r6855 16r843C 16r6856 16r855A 16r6857 16r8484 16r6858 16r8477 16r6859 16r846B 16r685A 16r84AD 16r685B 16r846E 16r685C 16r8482 16r685D 16r8469 16r685E 16r8446 16r685F 16r842C 16r6860 16r846F 16r6861 16r8479 16r6862 16r8435 16r6863 16r84CA 16r6864 16r8462 16r6865 16r84B9 16r6866 16r84BF 16r6867 16r849F 16r6868 16r84D9 16r6869 16r84CD 16r686A 16r84BB 16r686B 16r84DA 16r686C 16r84D0 16r686D 16r84C1 16r686E 16r84C6 16r686F 16r84D6 16r6870 16r84A1 16r6871 16r8521 16r6872 16r84FF 16r6873 16r84F4 16r6874 16r8517 16r6875 16r8518 16r6876 16r852C 16r6877 16r851F 16r6878 16r8515 16r6879 16r8514 16r687A 16r84FC 16r687B 16r8540 16r687C 16r8563 16r687D 16r8558 16r687E 16r8548 16r6921 16r8541 16r6922 16r8602 16r6923 16r854B 16r6924 16r8555 16r6925 16r8580 16r6926 16r85A4 16r6927 16r8588 16r6928 16r8591 16r6929 16r858A 16r692A 16r85A8 16r692B 16r856D 16r692C 16r8594 16r692D 16r859B 16r692E 16r85EA 16r692F 16r8587 16r6930 16r859C 16r6931 16r8577 16r6932 16r857E 16r6933 16r8590 16r6934 16r85C9 16r6935 16r85BA 16r6936 16r85CF 16r6937 16r85B9 16r6938 16r85D0 16r6939 16r85D5 16r693A 16r85DD 16r693B 16r85E5 16r693C 16r85DC 16r693D 16r85F9 16r693E 16r860A 16r693F 16r8613 16r6940 16r860B 16r6941 16r85FE 16r6942 16r85FA 16r6943 16r8606 16r6944 16r8622 16r6945 16r861A 16r6946 16r8630 16r6947 16r863F 16r6948 16r864D 16r6949 16r4E55 16r694A 16r8654 16r694B 16r865F 16r694C 16r8667 16r694D 16r8671 16r694E 16r8693 16r694F 16r86A3 16r6950 16r86A9 16r6951 16r86AA 16r6952 16r868B 16r6953 16r868C 16r6954 16r86B6 16r6955 16r86AF 16r6956 16r86C4 16r6957 16r86C6 16r6958 16r86B0 16r6959 16r86C9 16r695A 16r8823 16r695B 16r86AB 16r695C 16r86D4 16r695D 16r86DE 16r695E 16r86E9 16r695F 16r86EC 16r6960 16r86DF 16r6961 16r86DB 16r6962 16r86EF 16r6963 16r8712 16r6964 16r8706 16r6965 16r8708 16r6966 16r8700 16r6967 16r8703 16r6968 16r86FB 16r6969 16r8711 16r696A 16r8709 16r696B 16r870D 16r696C 16r86F9 16r696D 16r870A 16r696E 16r8734 16r696F 16r873F 16r6970 16r8737 16r6971 16r873B 16r6972 16r8725 16r6973 16r8729 16r6974 16r871A 16r6975 16r8760 16r6976 16r875F 16r6977 16r8778 16r6978 16r874C 16r6979 16r874E 16r697A 16r8774 16r697B 16r8757 16r697C 16r8768 16r697D 16r876E 16r697E 16r8759 16r6A21 16r8753 16r6A22 16r8763 16r6A23 16r876A 16r6A24 16r8805 16r6A25 16r87A2 16r6A26 16r879F 16r6A27 16r8782 16r6A28 16r87AF 16r6A29 16r87CB 16r6A2A 16r87BD 16r6A2B 16r87C0 16r6A2C 16r87D0 16r6A2D 16r96D6 16r6A2E 16r87AB 16r6A2F 16r87C4 16r6A30 16r87B3 16r6A31 16r87C7 16r6A32 16r87C6 16r6A33 16r87BB 16r6A34 16r87EF 16r6A35 16r87F2 16r6A36 16r87E0 16r6A37 16r880F 16r6A38 16r880D 16r6A39 16r87FE 16r6A3A 16r87F6 16r6A3B 16r87F7 16r6A3C 16r880E 16r6A3D 16r87D2 16r6A3E 16r8811 16r6A3F 16r8816 16r6A40 16r8815 16r6A41 16r8822 16r6A42 16r8821 16r6A43 16r8831 16r6A44 16r8836 16r6A45 16r8839 16r6A46 16r8827 16r6A47 16r883B 16r6A48 16r8844 16r6A49 16r8842 16r6A4A 16r8852 16r6A4B 16r8859 16r6A4C 16r885E 16r6A4D 16r8862 16r6A4E 16r886B 16r6A4F 16r8881 16r6A50 16r887E 16r6A51 16r889E 16r6A52 16r8875 16r6A53 16r887D 16r6A54 16r88B5 16r6A55 16r8872 16r6A56 16r8882 16r6A57 16r8897 16r6A58 16r8892 16r6A59 16r88AE 16r6A5A 16r8899 16r6A5B 16r88A2 16r6A5C 16r888D 16r6A5D 16r88A4 16r6A5E 16r88B0 16r6A5F 16r88BF 16r6A60 16r88B1 16r6A61 16r88C3 16r6A62 16r88C4 16r6A63 16r88D4 16r6A64 16r88D8 16r6A65 16r88D9 16r6A66 16r88DD 16r6A67 16r88F9 16r6A68 16r8902 16r6A69 16r88FC 16r6A6A 16r88F4 16r6A6B 16r88E8 16r6A6C 16r88F2 16r6A6D 16r8904 16r6A6E 16r890C 16r6A6F 16r890A 16r6A70 16r8913 16r6A71 16r8943 16r6A72 16r891E 16r6A73 16r8925 16r6A74 16r892A 16r6A75 16r892B 16r6A76 16r8941 16r6A77 16r8944 16r6A78 16r893B 16r6A79 16r8936 16r6A7A 16r8938 16r6A7B 16r894C 16r6A7C 16r891D 16r6A7D 16r8960 16r6A7E 16r895E 16r6B21 16r8966 16r6B22 16r8964 16r6B23 16r896D 16r6B24 16r896A 16r6B25 16r896F 16r6B26 16r8974 16r6B27 16r8977 16r6B28 16r897E 16r6B29 16r8983 16r6B2A 16r8988 16r6B2B 16r898A 16r6B2C 16r8993 16r6B2D 16r8998 16r6B2E 16r89A1 16r6B2F 16r89A9 16r6B30 16r89A6 16r6B31 16r89AC 16r6B32 16r89AF 16r6B33 16r89B2 16r6B34 16r89BA 16r6B35 16r89BD 16r6B36 16r89BF 16r6B37 16r89C0 16r6B38 16r89DA 16r6B39 16r89DC 16r6B3A 16r89DD 16r6B3B 16r89E7 16r6B3C 16r89F4 16r6B3D 16r89F8 16r6B3E 16r8A03 16r6B3F 16r8A16 16r6B40 16r8A10 16r6B41 16r8A0C 16r6B42 16r8A1B 16r6B43 16r8A1D 16r6B44 16r8A25 16r6B45 16r8A36 16r6B46 16r8A41 16r6B47 16r8A5B 16r6B48 16r8A52 16r6B49 16r8A46 16r6B4A 16r8A48 16r6B4B 16r8A7C 16r6B4C 16r8A6D 16r6B4D 16r8A6C 16r6B4E 16r8A62 16r6B4F 16r8A85 16r6B50 16r8A82 16r6B51 16r8A84 16r6B52 16r8AA8 16r6B53 16r8AA1 16r6B54 16r8A91 16r6B55 16r8AA5 16r6B56 16r8AA6 16r6B57 16r8A9A 16r6B58 16r8AA3 16r6B59 16r8AC4 16r6B5A 16r8ACD 16r6B5B 16r8AC2 16r6B5C 16r8ADA 16r6B5D 16r8AEB 16r6B5E 16r8AF3 16r6B5F 16r8AE7 16r6B60 16r8AE4 16r6B61 16r8AF1 16r6B62 16r8B14 16r6B63 16r8AE0 16r6B64 16r8AE2 16r6B65 16r8AF7 16r6B66 16r8ADE 16r6B67 16r8ADB 16r6B68 16r8B0C 16r6B69 16r8B07 16r6B6A 16r8B1A 16r6B6B 16r8AE1 16r6B6C 16r8B16 16r6B6D 16r8B10 16r6B6E 16r8B17 16r6B6F 16r8B20 16r6B70 16r8B33 16r6B71 16r97AB 16r6B72 16r8B26 16r6B73 16r8B2B 16r6B74 16r8B3E 16r6B75 16r8B28 16r6B76 16r8B41 16r6B77 16r8B4C 16r6B78 16r8B4F 16r6B79 16r8B4E 16r6B7A 16r8B49 16r6B7B 16r8B56 16r6B7C 16r8B5B 16r6B7D 16r8B5A 16r6B7E 16r8B6B 16r6C21 16r8B5F 16r6C22 16r8B6C 16r6C23 16r8B6F 16r6C24 16r8B74 16r6C25 16r8B7D 16r6C26 16r8B80 16r6C27 16r8B8C 16r6C28 16r8B8E 16r6C29 16r8B92 16r6C2A 16r8B93 16r6C2B 16r8B96 16r6C2C 16r8B99 16r6C2D 16r8B9A 16r6C2E 16r8C3A 16r6C2F 16r8C41 16r6C30 16r8C3F 16r6C31 16r8C48 16r6C32 16r8C4C 16r6C33 16r8C4E 16r6C34 16r8C50 16r6C35 16r8C55 16r6C36 16r8C62 16r6C37 16r8C6C 16r6C38 16r8C78 16r6C39 16r8C7A 16r6C3A 16r8C82 16r6C3B 16r8C89 16r6C3C 16r8C85 16r6C3D 16r8C8A 16r6C3E 16r8C8D 16r6C3F 16r8C8E 16r6C40 16r8C94 16r6C41 16r8C7C 16r6C42 16r8C98 16r6C43 16r621D 16r6C44 16r8CAD 16r6C45 16r8CAA 16r6C46 16r8CBD 16r6C47 16r8CB2 16r6C48 16r8CB3 16r6C49 16r8CAE 16r6C4A 16r8CB6 16r6C4B 16r8CC8 16r6C4C 16r8CC1 16r6C4D 16r8CE4 16r6C4E 16r8CE3 16r6C4F 16r8CDA 16r6C50 16r8CFD 16r6C51 16r8CFA 16r6C52 16r8CFB 16r6C53 16r8D04 16r6C54 16r8D05 16r6C55 16r8D0A 16r6C56 16r8D07 16r6C57 16r8D0F 16r6C58 16r8D0D 16r6C59 16r8D10 16r6C5A 16r9F4E 16r6C5B 16r8D13 16r6C5C 16r8CCD 16r6C5D 16r8D14 16r6C5E 16r8D16 16r6C5F 16r8D67 16r6C60 16r8D6D 16r6C61 16r8D71 16r6C62 16r8D73 16r6C63 16r8D81 16r6C64 16r8D99 16r6C65 16r8DC2 16r6C66 16r8DBE 16r6C67 16r8DBA 16r6C68 16r8DCF 16r6C69 16r8DDA 16r6C6A 16r8DD6 16r6C6B 16r8DCC 16r6C6C 16r8DDB 16r6C6D 16r8DCB 16r6C6E 16r8DEA 16r6C6F 16r8DEB 16r6C70 16r8DDF 16r6C71 16r8DE3 16r6C72 16r8DFC 16r6C73 16r8E08 16r6C74 16r8E09 16r6C75 16r8DFF 16r6C76 16r8E1D 16r6C77 16r8E1E 16r6C78 16r8E10 16r6C79 16r8E1F 16r6C7A 16r8E42 16r6C7B 16r8E35 16r6C7C 16r8E30 16r6C7D 16r8E34 16r6C7E 16r8E4A 16r6D21 16r8E47 16r6D22 16r8E49 16r6D23 16r8E4C 16r6D24 16r8E50 16r6D25 16r8E48 16r6D26 16r8E59 16r6D27 16r8E64 16r6D28 16r8E60 16r6D29 16r8E2A 16r6D2A 16r8E63 16r6D2B 16r8E55 16r6D2C 16r8E76 16r6D2D 16r8E72 16r6D2E 16r8E7C 16r6D2F 16r8E81 16r6D30 16r8E87 16r6D31 16r8E85 16r6D32 16r8E84 16r6D33 16r8E8B 16r6D34 16r8E8A 16r6D35 16r8E93 16r6D36 16r8E91 16r6D37 16r8E94 16r6D38 16r8E99 16r6D39 16r8EAA 16r6D3A 16r8EA1 16r6D3B 16r8EAC 16r6D3C 16r8EB0 16r6D3D 16r8EC6 16r6D3E 16r8EB1 16r6D3F 16r8EBE 16r6D40 16r8EC5 16r6D41 16r8EC8 16r6D42 16r8ECB 16r6D43 16r8EDB 16r6D44 16r8EE3 16r6D45 16r8EFC 16r6D46 16r8EFB 16r6D47 16r8EEB 16r6D48 16r8EFE 16r6D49 16r8F0A 16r6D4A 16r8F05 16r6D4B 16r8F15 16r6D4C 16r8F12 16r6D4D 16r8F19 16r6D4E 16r8F13 16r6D4F 16r8F1C 16r6D50 16r8F1F 16r6D51 16r8F1B 16r6D52 16r8F0C 16r6D53 16r8F26 16r6D54 16r8F33 16r6D55 16r8F3B 16r6D56 16r8F39 16r6D57 16r8F45 16r6D58 16r8F42 16r6D59 16r8F3E 16r6D5A 16r8F4C 16r6D5B 16r8F49 16r6D5C 16r8F46 16r6D5D 16r8F4E 16r6D5E 16r8F57 16r6D5F 16r8F5C 16r6D60 16r8F62 16r6D61 16r8F63 16r6D62 16r8F64 16r6D63 16r8F9C 16r6D64 16r8F9F 16r6D65 16r8FA3 16r6D66 16r8FAD 16r6D67 16r8FAF 16r6D68 16r8FB7 16r6D69 16r8FDA 16r6D6A 16r8FE5 16r6D6B 16r8FE2 16r6D6C 16r8FEA 16r6D6D 16r8FEF 16r6D6E 16r9087 16r6D6F 16r8FF4 16r6D70 16r9005 16r6D71 16r8FF9 16r6D72 16r8FFA 16r6D73 16r9011 16r6D74 16r9015 16r6D75 16r9021 16r6D76 16r900D 16r6D77 16r901E 16r6D78 16r9016 16r6D79 16r900B 16r6D7A 16r9027 16r6D7B 16r9036 16r6D7C 16r9035 16r6D7D 16r9039 16r6D7E 16r8FF8 16r6E21 16r904F 16r6E22 16r9050 16r6E23 16r9051 16r6E24 16r9052 16r6E25 16r900E 16r6E26 16r9049 16r6E27 16r903E 16r6E28 16r9056 16r6E29 16r9058 16r6E2A 16r905E 16r6E2B 16r9068 16r6E2C 16r906F 16r6E2D 16r9076 16r6E2E 16r96A8 16r6E2F 16r9072 16r6E30 16r9082 16r6E31 16r907D 16r6E32 16r9081 16r6E33 16r9080 16r6E34 16r908A 16r6E35 16r9089 16r6E36 16r908F 16r6E37 16r90A8 16r6E38 16r90AF 16r6E39 16r90B1 16r6E3A 16r90B5 16r6E3B 16r90E2 16r6E3C 16r90E4 16r6E3D 16r6248 16r6E3E 16r90DB 16r6E3F 16r9102 16r6E40 16r9112 16r6E41 16r9119 16r6E42 16r9132 16r6E43 16r9130 16r6E44 16r914A 16r6E45 16r9156 16r6E46 16r9158 16r6E47 16r9163 16r6E48 16r9165 16r6E49 16r9169 16r6E4A 16r9173 16r6E4B 16r9172 16r6E4C 16r918B 16r6E4D 16r9189 16r6E4E 16r9182 16r6E4F 16r91A2 16r6E50 16r91AB 16r6E51 16r91AF 16r6E52 16r91AA 16r6E53 16r91B5 16r6E54 16r91B4 16r6E55 16r91BA 16r6E56 16r91C0 16r6E57 16r91C1 16r6E58 16r91C9 16r6E59 16r91CB 16r6E5A 16r91D0 16r6E5B 16r91D6 16r6E5C 16r91DF 16r6E5D 16r91E1 16r6E5E 16r91DB 16r6E5F 16r91FC 16r6E60 16r91F5 16r6E61 16r91F6 16r6E62 16r921E 16r6E63 16r91FF 16r6E64 16r9214 16r6E65 16r922C 16r6E66 16r9215 16r6E67 16r9211 16r6E68 16r925E 16r6E69 16r9257 16r6E6A 16r9245 16r6E6B 16r9249 16r6E6C 16r9264 16r6E6D 16r9248 16r6E6E 16r9295 16r6E6F 16r923F 16r6E70 16r924B 16r6E71 16r9250 16r6E72 16r929C 16r6E73 16r9296 16r6E74 16r9293 16r6E75 16r929B 16r6E76 16r925A 16r6E77 16r92CF 16r6E78 16r92B9 16r6E79 16r92B7 16r6E7A 16r92E9 16r6E7B 16r930F 16r6E7C 16r92FA 16r6E7D 16r9344 16r6E7E 16r932E 16r6F21 16r9319 16r6F22 16r9322 16r6F23 16r931A 16r6F24 16r9323 16r6F25 16r933A 16r6F26 16r9335 16r6F27 16r933B 16r6F28 16r935C 16r6F29 16r9360 16r6F2A 16r937C 16r6F2B 16r936E 16r6F2C 16r9356 16r6F2D 16r93B0 16r6F2E 16r93AC 16r6F2F 16r93AD 16r6F30 16r9394 16r6F31 16r93B9 16r6F32 16r93D6 16r6F33 16r93D7 16r6F34 16r93E8 16r6F35 16r93E5 16r6F36 16r93D8 16r6F37 16r93C3 16r6F38 16r93DD 16r6F39 16r93D0 16r6F3A 16r93C8 16r6F3B 16r93E4 16r6F3C 16r941A 16r6F3D 16r9414 16r6F3E 16r9413 16r6F3F 16r9403 16r6F40 16r9407 16r6F41 16r9410 16r6F42 16r9436 16r6F43 16r942B 16r6F44 16r9435 16r6F45 16r9421 16r6F46 16r943A 16r6F47 16r9441 16r6F48 16r9452 16r6F49 16r9444 16r6F4A 16r945B 16r6F4B 16r9460 16r6F4C 16r9462 16r6F4D 16r945E 16r6F4E 16r946A 16r6F4F 16r9229 16r6F50 16r9470 16r6F51 16r9475 16r6F52 16r9477 16r6F53 16r947D 16r6F54 16r945A 16r6F55 16r947C 16r6F56 16r947E 16r6F57 16r9481 16r6F58 16r947F 16r6F59 16r9582 16r6F5A 16r9587 16r6F5B 16r958A 16r6F5C 16r9594 16r6F5D 16r9596 16r6F5E 16r9598 16r6F5F 16r9599 16r6F60 16r95A0 16r6F61 16r95A8 16r6F62 16r95A7 16r6F63 16r95AD 16r6F64 16r95BC 16r6F65 16r95BB 16r6F66 16r95B9 16r6F67 16r95BE 16r6F68 16r95CA 16r6F69 16r6FF6 16r6F6A 16r95C3 16r6F6B 16r95CD 16r6F6C 16r95CC 16r6F6D 16r95D5 16r6F6E 16r95D4 16r6F6F 16r95D6 16r6F70 16r95DC 16r6F71 16r95E1 16r6F72 16r95E5 16r6F73 16r95E2 16r6F74 16r9621 16r6F75 16r9628 16r6F76 16r962E 16r6F77 16r962F 16r6F78 16r9642 16r6F79 16r964C 16r6F7A 16r964F 16r6F7B 16r964B 16r6F7C 16r9677 16r6F7D 16r965C 16r6F7E 16r965E 16r7021 16r965D 16r7022 16r965F 16r7023 16r9666 16r7024 16r9672 16r7025 16r966C 16r7026 16r968D 16r7027 16r9698 16r7028 16r9695 16r7029 16r9697 16r702A 16r96AA 16r702B 16r96A7 16r702C 16r96B1 16r702D 16r96B2 16r702E 16r96B0 16r702F 16r96B4 16r7030 16r96B6 16r7031 16r96B8 16r7032 16r96B9 16r7033 16r96CE 16r7034 16r96CB 16r7035 16r96C9 16r7036 16r96CD 16r7037 16r894D 16r7038 16r96DC 16r7039 16r970D 16r703A 16r96D5 16r703B 16r96F9 16r703C 16r9704 16r703D 16r9706 16r703E 16r9708 16r703F 16r9713 16r7040 16r970E 16r7041 16r9711 16r7042 16r970F 16r7043 16r9716 16r7044 16r9719 16r7045 16r9724 16r7046 16r972A 16r7047 16r9730 16r7048 16r9739 16r7049 16r973D 16r704A 16r973E 16r704B 16r9744 16r704C 16r9746 16r704D 16r9748 16r704E 16r9742 16r704F 16r9749 16r7050 16r975C 16r7051 16r9760 16r7052 16r9764 16r7053 16r9766 16r7054 16r9768 16r7055 16r52D2 16r7056 16r976B 16r7057 16r9771 16r7058 16r9779 16r7059 16r9785 16r705A 16r977C 16r705B 16r9781 16r705C 16r977A 16r705D 16r9786 16r705E 16r978B 16r705F 16r978F 16r7060 16r9790 16r7061 16r979C 16r7062 16r97A8 16r7063 16r97A6 16r7064 16r97A3 16r7065 16r97B3 16r7066 16r97B4 16r7067 16r97C3 16r7068 16r97C6 16r7069 16r97C8 16r706A 16r97CB 16r706B 16r97DC 16r706C 16r97ED 16r706D 16r9F4F 16r706E 16r97F2 16r706F 16r7ADF 16r7070 16r97F6 16r7071 16r97F5 16r7072 16r980F 16r7073 16r980C 16r7074 16r9838 16r7075 16r9824 16r7076 16r9821 16r7077 16r9837 16r7078 16r983D 16r7079 16r9846 16r707A 16r984F 16r707B 16r984B 16r707C 16r986B 16r707D 16r986F 16r707E 16r9870 16r7121 16r9871 16r7122 16r9874 16r7123 16r9873 16r7124 16r98AA 16r7125 16r98AF 16r7126 16r98B1 16r7127 16r98B6 16r7128 16r98C4 16r7129 16r98C3 16r712A 16r98C6 16r712B 16r98E9 16r712C 16r98EB 16r712D 16r9903 16r712E 16r9909 16r712F 16r9912 16r7130 16r9914 16r7131 16r9918 16r7132 16r9921 16r7133 16r991D 16r7134 16r991E 16r7135 16r9924 16r7136 16r9920 16r7137 16r992C 16r7138 16r992E 16r7139 16r993D 16r713A 16r993E 16r713B 16r9942 16r713C 16r9949 16r713D 16r9945 16r713E 16r9950 16r713F 16r994B 16r7140 16r9951 16r7141 16r9952 16r7142 16r994C 16r7143 16r9955 16r7144 16r9997 16r7145 16r9998 16r7146 16r99A5 16r7147 16r99AD 16r7148 16r99AE 16r7149 16r99BC 16r714A 16r99DF 16r714B 16r99DB 16r714C 16r99DD 16r714D 16r99D8 16r714E 16r99D1 16r714F 16r99ED 16r7150 16r99EE 16r7151 16r99F1 16r7152 16r99F2 16r7153 16r99FB 16r7154 16r99F8 16r7155 16r9A01 16r7156 16r9A0F 16r7157 16r9A05 16r7158 16r99E2 16r7159 16r9A19 16r715A 16r9A2B 16r715B 16r9A37 16r715C 16r9A45 16r715D 16r9A42 16r715E 16r9A40 16r715F 16r9A43 16r7160 16r9A3E 16r7161 16r9A55 16r7162 16r9A4D 16r7163 16r9A5B 16r7164 16r9A57 16r7165 16r9A5F 16r7166 16r9A62 16r7167 16r9A65 16r7168 16r9A64 16r7169 16r9A69 16r716A 16r9A6B 16r716B 16r9A6A 16r716C 16r9AAD 16r716D 16r9AB0 16r716E 16r9ABC 16r716F 16r9AC0 16r7170 16r9ACF 16r7171 16r9AD1 16r7172 16r9AD3 16r7173 16r9AD4 16r7174 16r9ADE 16r7175 16r9ADF 16r7176 16r9AE2 16r7177 16r9AE3 16r7178 16r9AE6 16r7179 16r9AEF 16r717A 16r9AEB 16r717B 16r9AEE 16r717C 16r9AF4 16r717D 16r9AF1 16r717E 16r9AF7 16r7221 16r9AFB 16r7222 16r9B06 16r7223 16r9B18 16r7224 16r9B1A 16r7225 16r9B1F 16r7226 16r9B22 16r7227 16r9B23 16r7228 16r9B25 16r7229 16r9B27 16r722A 16r9B28 16r722B 16r9B29 16r722C 16r9B2A 16r722D 16r9B2E 16r722E 16r9B2F 16r722F 16r9B32 16r7230 16r9B44 16r7231 16r9B43 16r7232 16r9B4F 16r7233 16r9B4D 16r7234 16r9B4E 16r7235 16r9B51 16r7236 16r9B58 16r7237 16r9B74 16r7238 16r9B93 16r7239 16r9B83 16r723A 16r9B91 16r723B 16r9B96 16r723C 16r9B97 16r723D 16r9B9F 16r723E 16r9BA0 16r723F 16r9BA8 16r7240 16r9BB4 16r7241 16r9BC0 16r7242 16r9BCA 16r7243 16r9BB9 16r7244 16r9BC6 16r7245 16r9BCF 16r7246 16r9BD1 16r7247 16r9BD2 16r7248 16r9BE3 16r7249 16r9BE2 16r724A 16r9BE4 16r724B 16r9BD4 16r724C 16r9BE1 16r724D 16r9C3A 16r724E 16r9BF2 16r724F 16r9BF1 16r7250 16r9BF0 16r7251 16r9C15 16r7252 16r9C14 16r7253 16r9C09 16r7254 16r9C13 16r7255 16r9C0C 16r7256 16r9C06 16r7257 16r9C08 16r7258 16r9C12 16r7259 16r9C0A 16r725A 16r9C04 16r725B 16r9C2E 16r725C 16r9C1B 16r725D 16r9C25 16r725E 16r9C24 16r725F 16r9C21 16r7260 16r9C30 16r7261 16r9C47 16r7262 16r9C32 16r7263 16r9C46 16r7264 16r9C3E 16r7265 16r9C5A 16r7266 16r9C60 16r7267 16r9C67 16r7268 16r9C76 16r7269 16r9C78 16r726A 16r9CE7 16r726B 16r9CEC 16r726C 16r9CF0 16r726D 16r9D09 16r726E 16r9D08 16r726F 16r9CEB 16r7270 16r9D03 16r7271 16r9D06 16r7272 16r9D2A 16r7273 16r9D26 16r7274 16r9DAF 16r7275 16r9D23 16r7276 16r9D1F 16r7277 16r9D44 16r7278 16r9D15 16r7279 16r9D12 16r727A 16r9D41 16r727B 16r9D3F 16r727C 16r9D3E 16r727D 16r9D46 16r727E 16r9D48 16r7321 16r9D5D 16r7322 16r9D5E 16r7323 16r9D64 16r7324 16r9D51 16r7325 16r9D50 16r7326 16r9D59 16r7327 16r9D72 16r7328 16r9D89 16r7329 16r9D87 16r732A 16r9DAB 16r732B 16r9D6F 16r732C 16r9D7A 16r732D 16r9D9A 16r732E 16r9DA4 16r732F 16r9DA9 16r7330 16r9DB2 16r7331 16r9DC4 16r7332 16r9DC1 16r7333 16r9DBB 16r7334 16r9DB8 16r7335 16r9DBA 16r7336 16r9DC6 16r7337 16r9DCF 16r7338 16r9DC2 16r7339 16r9DD9 16r733A 16r9DD3 16r733B 16r9DF8 16r733C 16r9DE6 16r733D 16r9DED 16r733E 16r9DEF 16r733F 16r9DFD 16r7340 16r9E1A 16r7341 16r9E1B 16r7342 16r9E1E 16r7343 16r9E75 16r7344 16r9E79 16r7345 16r9E7D 16r7346 16r9E81 16r7347 16r9E88 16r7348 16r9E8B 16r7349 16r9E8C 16r734A 16r9E92 16r734B 16r9E95 16r734C 16r9E91 16r734D 16r9E9D 16r734E 16r9EA5 16r734F 16r9EA9 16r7350 16r9EB8 16r7351 16r9EAA 16r7352 16r9EAD 16r7353 16r9761 16r7354 16r9ECC 16r7355 16r9ECE 16r7356 16r9ECF 16r7357 16r9ED0 16r7358 16r9ED4 16r7359 16r9EDC 16r735A 16r9EDE 16r735B 16r9EDD 16r735C 16r9EE0 16r735D 16r9EE5 16r735E 16r9EE8 16r735F 16r9EEF 16r7360 16r9EF4 16r7361 16r9EF6 16r7362 16r9EF7 16r7363 16r9EF9 16r7364 16r9EFB 16r7365 16r9EFC 16r7366 16r9EFD 16r7367 16r9F07 16r7368 16r9F08 16r7369 16r76B7 16r736A 16r9F15 16r736B 16r9F21 16r736C 16r9F2C 16r736D 16r9F3E 16r736E 16r9F4A 16r736F 16r9F52 16r7370 16r9F54 16r7371 16r9F63 16r7372 16r9F5F 16r7373 16r9F60 16r7374 16r9F61 16r7375 16r9F66 16r7376 16r9F67 16r7377 16r9F6C 16r7378 16r9F6A 16r7379 16r9F77 16r737A 16r9F72 16r737B 16r9F76 16r737C 16r9F95 16r737D 16r9F9C 16r737E 16r9FA0 16r7421 16r582F 16r7422 16r69C7 16r7423 16r9059 16r7424 16r7464 16r7425 16r51DC 16r7426 16r7199). 422847 table size even ifFalse: [^ self error: 'given table size must be even']. 422848 size := table size / 2. 422849 jisX0208 := Array new: size. 422850 unicode := Array new: size. 422851 1 to: table size by: 2 do: [:index | 422852 | tableIndex | 422853 tableIndex := index + 1 / 2. 422854 jisX0208 at: tableIndex put: (table at: index). 422855 unicode at: tableIndex put: (table at: index + 1)]. 422856 jisX02082 := Array new: 94*94 withAll: -1. 422857 jisX0208 withIndexDo: [:elem :index | 422858 code := (elem // 256 - 33) * 94 + (elem \\ 256 - 33) + 1. 422859 (jisX02082 at: code) ~= -1 ifTrue: [self halt]. 422860 uIndex := jisX0208 indexOf: elem. 422861 uIndex = 0 ifFalse: [ 422862 u := unicode at: uIndex. 422863 jisX02082 at: code put: u. 422864 ]. 422865 ]. 422866 JISX0208Table := jisX02082. 422867! ! 422868 422869!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:35'! 422870initializeKSX1001Table 422871 "UCSTable initializeKSX1001Table" 422872 422873 | table size ksX1001 unicode ksX10012 code uIndex u | 422874 table := #(16r2121 16r3000 16r2122 16r3001 16r2123 16r3002 16r2124 16r00B7 16r2125 16r2025 16r2126 16r2026 16r2127 16r00A8 16r2128 16r3003 16r2129 16r00AD 16r212A 16r2015 16r212B 16r2225 16r212C 16rFF3C 16r212D 16r223C 16r212E 16r2018 16r212F 16r2019 16r2130 16r201C 16r2131 16r201D 16r2132 16r3014 16r2133 16r3015 16r2134 16r3008 16r2135 16r3009 16r2136 16r300A 16r2137 16r300B 16r2138 16r300C 16r2139 16r300D 16r213A 16r300E 16r213B 16r300F 16r213C 16r3010 16r213D 16r3011 16r213E 16r00B1 16r213F 16r00D7 16r2140 16r00F7 16r2141 16r2260 16r2142 16r2264 16r2143 16r2265 16r2144 16r221E 16r2145 16r2234 16r2146 16r00B0 16r2147 16r2032 16r2148 16r2033 16r2149 16r2103 16r214A 16r212B 16r214B 16rFFE0 16r214C 16rFFE1 16r214D 16rFFE5 16r214E 16r2642 16r214F 16r2640 16r2150 16r2220 16r2151 16r22A5 16r2152 16r2312 16r2153 16r2202 16r2154 16r2207 16r2155 16r2261 16r2156 16r2252 16r2157 16r00A7 16r2158 16r203B 16r2159 16r2606 16r215A 16r2605 16r215B 16r25CB 16r215C 16r25CF 16r215D 16r25CE 16r215E 16r25C7 16r215F 16r25C6 16r2160 16r25A1 16r2161 16r25A0 16r2162 16r25B3 16r2163 16r25B2 16r2164 16r25BD 16r2165 16r25BC 16r2166 16r2192 16r2167 16r2190 16r2168 16r2191 16r2169 16r2193 16r216A 16r2194 16r216B 16r3013 16r216C 16r226A 16r216D 16r226B 16r216E 16r221A 16r216F 16r223D 16r2170 16r221D 16r2171 16r2235 16r2172 16r222B 16r2173 16r222C 16r2174 16r2208 16r2175 16r220B 16r2176 16r2286 16r2177 16r2287 16r2178 16r2282 16r2179 16r2283 16r217A 16r222A 16r217B 16r2229 16r217C 16r2227 16r217D 16r2228 16r217E 16rFFE2 16r2221 16r21D2 16r2222 16r21D4 16r2223 16r2200 16r2224 16r2203 16r2225 16r00B4 16r2226 16rFF5E 16r2227 16r02C7 16r2228 16r02D8 16r2229 16r02DD 16r222A 16r02DA 16r222B 16r02D9 16r222C 16r00B8 16r222D 16r02DB 16r222E 16r00A1 16r222F 16r00BF 16r2230 16r02D0 16r2231 16r222E 16r2232 16r2211 16r2233 16r220F 16r2234 16r00A4 16r2235 16r2109 16r2236 16r2030 16r2237 16r25C1 16r2238 16r25C0 16r2239 16r25B7 16r223A 16r25B6 16r223B 16r2664 16r223C 16r2660 16r223D 16r2661 16r223E 16r2665 16r223F 16r2667 16r2240 16r2663 16r2241 16r2299 16r2242 16r25C8 16r2243 16r25A3 16r2244 16r25D0 16r2245 16r25D1 16r2246 16r2592 16r2247 16r25A4 16r2248 16r25A5 16r2249 16r25A8 16r224A 16r25A7 16r224B 16r25A6 16r224C 16r25A9 16r224D 16r2668 16r224E 16r260F 16r224F 16r260E 16r2250 16r261C 16r2251 16r261E 16r2252 16r00B6 16r2253 16r2020 16r2254 16r2021 16r2255 16r2195 16r2256 16r2197 16r2257 16r2199 16r2258 16r2196 16r2259 16r2198 16r225A 16r266D 16r225B 16r2669 16r225C 16r266A 16r225D 16r266C 16r225E 16r327F 16r225F 16r321C 16r2260 16r2116 16r2261 16r33C7 16r2262 16r2122 16r2263 16r33C2 16r2264 16r33D8 16r2265 16r2121 16r2321 16rFF01 16r2322 16rFF02 16r2323 16rFF03 16r2324 16rFF04 16r2325 16rFF05 16r2326 16rFF06 16r2327 16rFF07 16r2328 16rFF08 16r2329 16rFF09 16r232A 16rFF0A 16r232B 16rFF0B 16r232C 16rFF0C 16r232D 16rFF0D 16r232E 16rFF0E 16r232F 16rFF0F 16r2330 16rFF10 16r2331 16rFF11 16r2332 16rFF12 16r2333 16rFF13 16r2334 16rFF14 16r2335 16rFF15 16r2336 16rFF16 16r2337 16rFF17 16r2338 16rFF18 16r2339 16rFF19 16r233A 16rFF1A 16r233B 16rFF1B 16r233C 16rFF1C 16r233D 16rFF1D 16r233E 16rFF1E 16r233F 16rFF1F 16r2340 16rFF20 16r2341 16rFF21 16r2342 16rFF22 16r2343 16rFF23 16r2344 16rFF24 16r2345 16rFF25 16r2346 16rFF26 16r2347 16rFF27 16r2348 16rFF28 16r2349 16rFF29 16r234A 16rFF2A 16r234B 16rFF2B 16r234C 16rFF2C 16r234D 16rFF2D 16r234E 16rFF2E 16r234F 16rFF2F 16r2350 16rFF30 16r2351 16rFF31 16r2352 16rFF32 16r2353 16rFF33 16r2354 16rFF34 16r2355 16rFF35 16r2356 16rFF36 16r2357 16rFF37 16r2358 16rFF38 16r2359 16rFF39 16r235A 16rFF3A 16r235B 16rFF3B 16r235C 16rFFE6 16r235D 16rFF3D 16r235E 16rFF3E 16r235F 16rFF3F 16r2360 16rFF40 16r2361 16rFF41 16r2362 16rFF42 16r2363 16rFF43 16r2364 16rFF44 16r2365 16rFF45 16r2366 16rFF46 16r2367 16rFF47 16r2368 16rFF48 16r2369 16rFF49 16r236A 16rFF4A 16r236B 16rFF4B 16r236C 16rFF4C 16r236D 16rFF4D 16r236E 16rFF4E 16r236F 16rFF4F 16r2370 16rFF50 16r2371 16rFF51 16r2372 16rFF52 16r2373 16rFF53 16r2374 16rFF54 16r2375 16rFF55 16r2376 16rFF56 16r2377 16rFF57 16r2378 16rFF58 16r2379 16rFF59 16r237A 16rFF5A 16r237B 16rFF5B 16r237C 16rFF5C 16r237D 16rFF5D 16r237E 16rFFE3 16r2421 16r3131 16r2422 16r3132 16r2423 16r3133 16r2424 16r3134 16r2425 16r3135 16r2426 16r3136 16r2427 16r3137 16r2428 16r3138 16r2429 16r3139 16r242A 16r313A 16r242B 16r313B 16r242C 16r313C 16r242D 16r313D 16r242E 16r313E 16r242F 16r313F 16r2430 16r3140 16r2431 16r3141 16r2432 16r3142 16r2433 16r3143 16r2434 16r3144 16r2435 16r3145 16r2436 16r3146 16r2437 16r3147 16r2438 16r3148 16r2439 16r3149 16r243A 16r314A 16r243B 16r314B 16r243C 16r314C 16r243D 16r314D 16r243E 16r314E 16r243F 16r314F 16r2440 16r3150 16r2441 16r3151 16r2442 16r3152 16r2443 16r3153 16r2444 16r3154 16r2445 16r3155 16r2446 16r3156 16r2447 16r3157 16r2448 16r3158 16r2449 16r3159 16r244A 16r315A 16r244B 16r315B 16r244C 16r315C 16r244D 16r315D 16r244E 16r315E 16r244F 16r315F 16r2450 16r3160 16r2451 16r3161 16r2452 16r3162 16r2453 16r3163 16r2454 16r3164 16r2455 16r3165 16r2456 16r3166 16r2457 16r3167 16r2458 16r3168 16r2459 16r3169 16r245A 16r316A 16r245B 16r316B 16r245C 16r316C 16r245D 16r316D 16r245E 16r316E 16r245F 16r316F 16r2460 16r3170 16r2461 16r3171 16r2462 16r3172 16r2463 16r3173 16r2464 16r3174 16r2465 16r3175 16r2466 16r3176 16r2467 16r3177 16r2468 16r3178 16r2469 16r3179 16r246A 16r317A 16r246B 16r317B 16r246C 16r317C 16r246D 16r317D 16r246E 16r317E 16r246F 16r317F 16r2470 16r3180 16r2471 16r3181 16r2472 16r3182 16r2473 16r3183 16r2474 16r3184 16r2475 16r3185 16r2476 16r3186 16r2477 16r3187 16r2478 16r3188 16r2479 16r3189 16r247A 16r318A 16r247B 16r318B 16r247C 16r318C 16r247D 16r318D 16r247E 16r318E 16r2521 16r2170 16r2522 16r2171 16r2523 16r2172 16r2524 16r2173 16r2525 16r2174 16r2526 16r2175 16r2527 16r2176 16r2528 16r2177 16r2529 16r2178 16r252A 16r2179 16r2530 16r2160 16r2531 16r2161 16r2532 16r2162 16r2533 16r2163 16r2534 16r2164 16r2535 16r2165 16r2536 16r2166 16r2537 16r2167 16r2538 16r2168 16r2539 16r2169 16r2541 16r0391 16r2542 16r0392 16r2543 16r0393 16r2544 16r0394 16r2545 16r0395 16r2546 16r0396 16r2547 16r0397 16r2548 16r0398 16r2549 16r0399 16r254A 16r039A 16r254B 16r039B 16r254C 16r039C 16r254D 16r039D 16r254E 16r039E 16r254F 16r039F 16r2550 16r03A0 16r2551 16r03A1 16r2552 16r03A3 16r2553 16r03A4 16r2554 16r03A5 16r2555 16r03A6 16r2556 16r03A7 16r2557 16r03A8 16r2558 16r03A9 16r2561 16r03B1 16r2562 16r03B2 16r2563 16r03B3 16r2564 16r03B4 16r2565 16r03B5 16r2566 16r03B6 16r2567 16r03B7 16r2568 16r03B8 16r2569 16r03B9 16r256A 16r03BA 16r256B 16r03BB 16r256C 16r03BC 16r256D 16r03BD 16r256E 16r03BE 16r256F 16r03BF 16r2570 16r03C0 16r2571 16r03C1 16r2572 16r03C3 16r2573 16r03C4 16r2574 16r03C5 16r2575 16r03C6 16r2576 16r03C7 16r2577 16r03C8 16r2578 16r03C9 16r2621 16r2500 16r2622 16r2502 16r2623 16r250C 16r2624 16r2510 16r2625 16r2518 16r2626 16r2514 16r2627 16r251C 16r2628 16r252C 16r2629 16r2524 16r262A 16r2534 16r262B 16r253C 16r262C 16r2501 16r262D 16r2503 16r262E 16r250F 16r262F 16r2513 16r2630 16r251B 16r2631 16r2517 16r2632 16r2523 16r2633 16r2533 16r2634 16r252B 16r2635 16r253B 16r2636 16r254B 16r2637 16r2520 16r2638 16r252F 16r2639 16r2528 16r263A 16r2537 16r263B 16r253F 16r263C 16r251D 16r263D 16r2530 16r263E 16r2525 16r263F 16r2538 16r2640 16r2542 16r2641 16r2512 16r2642 16r2511 16r2643 16r251A 16r2644 16r2519 16r2645 16r2516 16r2646 16r2515 16r2647 16r250E 16r2648 16r250D 16r2649 16r251E 16r264A 16r251F 16r264B 16r2521 16r264C 16r2522 16r264D 16r2526 16r264E 16r2527 16r264F 16r2529 16r2650 16r252A 16r2651 16r252D 16r2652 16r252E 16r2653 16r2531 16r2654 16r2532 16r2655 16r2535 16r2656 16r2536 16r2657 16r2539 16r2658 16r253A 16r2659 16r253D 16r265A 16r253E 16r265B 16r2540 16r265C 16r2541 16r265D 16r2543 16r265E 16r2544 16r265F 16r2545 16r2660 16r2546 16r2661 16r2547 16r2662 16r2548 16r2663 16r2549 16r2664 16r254A 16r2721 16r3395 16r2722 16r3396 16r2723 16r3397 16r2724 16r2113 16r2725 16r3398 16r2726 16r33C4 16r2727 16r33A3 16r2728 16r33A4 16r2729 16r33A5 16r272A 16r33A6 16r272B 16r3399 16r272C 16r339A 16r272D 16r339B 16r272E 16r339C 16r272F 16r339D 16r2730 16r339E 16r2731 16r339F 16r2732 16r33A0 16r2733 16r33A1 16r2734 16r33A2 16r2735 16r33CA 16r2736 16r338D 16r2737 16r338E 16r2738 16r338F 16r2739 16r33CF 16r273A 16r3388 16r273B 16r3389 16r273C 16r33C8 16r273D 16r33A7 16r273E 16r33A8 16r273F 16r33B0 16r2740 16r33B1 16r2741 16r33B2 16r2742 16r33B3 16r2743 16r33B4 16r2744 16r33B5 16r2745 16r33B6 16r2746 16r33B7 16r2747 16r33B8 16r2748 16r33B9 16r2749 16r3380 16r274A 16r3381 16r274B 16r3382 16r274C 16r3383 16r274D 16r3384 16r274E 16r33BA 16r274F 16r33BB 16r2750 16r33BC 16r2751 16r33BD 16r2752 16r33BE 16r2753 16r33BF 16r2754 16r3390 16r2755 16r3391 16r2756 16r3392 16r2757 16r3393 16r2758 16r3394 16r2759 16r2126 16r275A 16r33C0 16r275B 16r33C1 16r275C 16r338A 16r275D 16r338B 16r275E 16r338C 16r275F 16r33D6 16r2760 16r33C5 16r2761 16r33AD 16r2762 16r33AE 16r2763 16r33AF 16r2764 16r33DB 16r2765 16r33A9 16r2766 16r33AA 16r2767 16r33AB 16r2768 16r33AC 16r2769 16r33DD 16r276A 16r33D0 16r276B 16r33D3 16r276C 16r33C3 16r276D 16r33C9 16r276E 16r33DC 16r276F 16r33C6 16r2821 16r00C6 16r2822 16r00D0 16r2823 16r00AA 16r2824 16r0126 16r2826 16r0132 16r2828 16r013F 16r2829 16r0141 16r282A 16r00D8 16r282B 16r0152 16r282C 16r00BA 16r282D 16r00DE 16r282E 16r0166 16r282F 16r014A 16r2831 16r3260 16r2832 16r3261 16r2833 16r3262 16r2834 16r3263 16r2835 16r3264 16r2836 16r3265 16r2837 16r3266 16r2838 16r3267 16r2839 16r3268 16r283A 16r3269 16r283B 16r326A 16r283C 16r326B 16r283D 16r326C 16r283E 16r326D 16r283F 16r326E 16r2840 16r326F 16r2841 16r3270 16r2842 16r3271 16r2843 16r3272 16r2844 16r3273 16r2845 16r3274 16r2846 16r3275 16r2847 16r3276 16r2848 16r3277 16r2849 16r3278 16r284A 16r3279 16r284B 16r327A 16r284C 16r327B 16r284D 16r24D0 16r284E 16r24D1 16r284F 16r24D2 16r2850 16r24D3 16r2851 16r24D4 16r2852 16r24D5 16r2853 16r24D6 16r2854 16r24D7 16r2855 16r24D8 16r2856 16r24D9 16r2857 16r24DA 16r2858 16r24DB 16r2859 16r24DC 16r285A 16r24DD 16r285B 16r24DE 16r285C 16r24DF 16r285D 16r24E0 16r285E 16r24E1 16r285F 16r24E2 16r2860 16r24E3 16r2861 16r24E4 16r2862 16r24E5 16r2863 16r24E6 16r2864 16r24E7 16r2865 16r24E8 16r2866 16r24E9 16r2867 16r2460 16r2868 16r2461 16r2869 16r2462 16r286A 16r2463 16r286B 16r2464 16r286C 16r2465 16r286D 16r2466 16r286E 16r2467 16r286F 16r2468 16r2870 16r2469 16r2871 16r246A 16r2872 16r246B 16r2873 16r246C 16r2874 16r246D 16r2875 16r246E 16r2876 16r00BD 16r2877 16r2153 16r2878 16r2154 16r2879 16r00BC 16r287A 16r00BE 16r287B 16r215B 16r287C 16r215C 16r287D 16r215D 16r287E 16r215E 16r2921 16r00E6 16r2922 16r0111 16r2923 16r00F0 16r2924 16r0127 16r2925 16r0131 16r2926 16r0133 16r2927 16r0138 16r2928 16r0140 16r2929 16r0142 16r292A 16r00F8 16r292B 16r0153 16r292C 16r00DF 16r292D 16r00FE 16r292E 16r0167 16r292F 16r014B 16r2930 16r0149 16r2931 16r3200 16r2932 16r3201 16r2933 16r3202 16r2934 16r3203 16r2935 16r3204 16r2936 16r3205 16r2937 16r3206 16r2938 16r3207 16r2939 16r3208 16r293A 16r3209 16r293B 16r320A 16r293C 16r320B 16r293D 16r320C 16r293E 16r320D 16r293F 16r320E 16r2940 16r320F 16r2941 16r3210 16r2942 16r3211 16r2943 16r3212 16r2944 16r3213 16r2945 16r3214 16r2946 16r3215 16r2947 16r3216 16r2948 16r3217 16r2949 16r3218 16r294A 16r3219 16r294B 16r321A 16r294C 16r321B 16r294D 16r249C 16r294E 16r249D 16r294F 16r249E 16r2950 16r249F 16r2951 16r24A0 16r2952 16r24A1 16r2953 16r24A2 16r2954 16r24A3 16r2955 16r24A4 16r2956 16r24A5 16r2957 16r24A6 16r2958 16r24A7 16r2959 16r24A8 16r295A 16r24A9 16r295B 16r24AA 16r295C 16r24AB 16r295D 16r24AC 16r295E 16r24AD 16r295F 16r24AE 16r2960 16r24AF 16r2961 16r24B0 16r2962 16r24B1 16r2963 16r24B2 16r2964 16r24B3 16r2965 16r24B4 16r2966 16r24B5 16r2967 16r2474 16r2968 16r2475 16r2969 16r2476 16r296A 16r2477 16r296B 16r2478 16r296C 16r2479 16r296D 16r247A 16r296E 16r247B 16r296F 16r247C 16r2970 16r247D 16r2971 16r247E 16r2972 16r247F 16r2973 16r2480 16r2974 16r2481 16r2975 16r2482 16r2976 16r00B9 16r2977 16r00B2 16r2978 16r00B3 16r2979 16r2074 16r297A 16r207F 16r297B 16r2081 16r297C 16r2082 16r297D 16r2083 16r297E 16r2084 16r2A21 16r3041 16r2A22 16r3042 16r2A23 16r3043 16r2A24 16r3044 16r2A25 16r3045 16r2A26 16r3046 16r2A27 16r3047 16r2A28 16r3048 16r2A29 16r3049 16r2A2A 16r304A 16r2A2B 16r304B 16r2A2C 16r304C 16r2A2D 16r304D 16r2A2E 16r304E 16r2A2F 16r304F 16r2A30 16r3050 16r2A31 16r3051 16r2A32 16r3052 16r2A33 16r3053 16r2A34 16r3054 16r2A35 16r3055 16r2A36 16r3056 16r2A37 16r3057 16r2A38 16r3058 16r2A39 16r3059 16r2A3A 16r305A 16r2A3B 16r305B 16r2A3C 16r305C 16r2A3D 16r305D 16r2A3E 16r305E 16r2A3F 16r305F 16r2A40 16r3060 16r2A41 16r3061 16r2A42 16r3062 16r2A43 16r3063 16r2A44 16r3064 16r2A45 16r3065 16r2A46 16r3066 16r2A47 16r3067 16r2A48 16r3068 16r2A49 16r3069 16r2A4A 16r306A 16r2A4B 16r306B 16r2A4C 16r306C 16r2A4D 16r306D 16r2A4E 16r306E 16r2A4F 16r306F 16r2A50 16r3070 16r2A51 16r3071 16r2A52 16r3072 16r2A53 16r3073 16r2A54 16r3074 16r2A55 16r3075 16r2A56 16r3076 16r2A57 16r3077 16r2A58 16r3078 16r2A59 16r3079 16r2A5A 16r307A 16r2A5B 16r307B 16r2A5C 16r307C 16r2A5D 16r307D 16r2A5E 16r307E 16r2A5F 16r307F 16r2A60 16r3080 16r2A61 16r3081 16r2A62 16r3082 16r2A63 16r3083 16r2A64 16r3084 16r2A65 16r3085 16r2A66 16r3086 16r2A67 16r3087 16r2A68 16r3088 16r2A69 16r3089 16r2A6A 16r308A 16r2A6B 16r308B 16r2A6C 16r308C 16r2A6D 16r308D 16r2A6E 16r308E 16r2A6F 16r308F 16r2A70 16r3090 16r2A71 16r3091 16r2A72 16r3092 16r2A73 16r3093 16r2B21 16r30A1 16r2B22 16r30A2 16r2B23 16r30A3 16r2B24 16r30A4 16r2B25 16r30A5 16r2B26 16r30A6 16r2B27 16r30A7 16r2B28 16r30A8 16r2B29 16r30A9 16r2B2A 16r30AA 16r2B2B 16r30AB 16r2B2C 16r30AC 16r2B2D 16r30AD 16r2B2E 16r30AE 16r2B2F 16r30AF 16r2B30 16r30B0 16r2B31 16r30B1 16r2B32 16r30B2 16r2B33 16r30B3 16r2B34 16r30B4 16r2B35 16r30B5 16r2B36 16r30B6 16r2B37 16r30B7 16r2B38 16r30B8 16r2B39 16r30B9 16r2B3A 16r30BA 16r2B3B 16r30BB 16r2B3C 16r30BC 16r2B3D 16r30BD 16r2B3E 16r30BE 16r2B3F 16r30BF 16r2B40 16r30C0 16r2B41 16r30C1 16r2B42 16r30C2 16r2B43 16r30C3 16r2B44 16r30C4 16r2B45 16r30C5 16r2B46 16r30C6 16r2B47 16r30C7 16r2B48 16r30C8 16r2B49 16r30C9 16r2B4A 16r30CA 16r2B4B 16r30CB 16r2B4C 16r30CC 16r2B4D 16r30CD 16r2B4E 16r30CE 16r2B4F 16r30CF 16r2B50 16r30D0 16r2B51 16r30D1 16r2B52 16r30D2 16r2B53 16r30D3 16r2B54 16r30D4 16r2B55 16r30D5 16r2B56 16r30D6 16r2B57 16r30D7 16r2B58 16r30D8 16r2B59 16r30D9 16r2B5A 16r30DA 16r2B5B 16r30DB 16r2B5C 16r30DC 16r2B5D 16r30DD 16r2B5E 16r30DE 16r2B5F 16r30DF 16r2B60 16r30E0 16r2B61 16r30E1 16r2B62 16r30E2 16r2B63 16r30E3 16r2B64 16r30E4 16r2B65 16r30E5 16r2B66 16r30E6 16r2B67 16r30E7 16r2B68 16r30E8 16r2B69 16r30E9 16r2B6A 16r30EA 16r2B6B 16r30EB 16r2B6C 16r30EC 16r2B6D 16r30ED 16r2B6E 16r30EE 16r2B6F 16r30EF 16r2B70 16r30F0 16r2B71 16r30F1 16r2B72 16r30F2 16r2B73 16r30F3 16r2B74 16r30F4 16r2B75 16r30F5 16r2B76 16r30F6 16r2C21 16r0410 16r2C22 16r0411 16r2C23 16r0412 16r2C24 16r0413 16r2C25 16r0414 16r2C26 16r0415 16r2C27 16r0401 16r2C28 16r0416 16r2C29 16r0417 16r2C2A 16r0418 16r2C2B 16r0419 16r2C2C 16r041A 16r2C2D 16r041B 16r2C2E 16r041C 16r2C2F 16r041D 16r2C30 16r041E 16r2C31 16r041F 16r2C32 16r0420 16r2C33 16r0421 16r2C34 16r0422 16r2C35 16r0423 16r2C36 16r0424 16r2C37 16r0425 16r2C38 16r0426 16r2C39 16r0427 16r2C3A 16r0428 16r2C3B 16r0429 16r2C3C 16r042A 16r2C3D 16r042B 16r2C3E 16r042C 16r2C3F 16r042D 16r2C40 16r042E 16r2C41 16r042F 16r2C51 16r0430 16r2C52 16r0431 16r2C53 16r0432 16r2C54 16r0433 16r2C55 16r0434 16r2C56 16r0435 16r2C57 16r0451 16r2C58 16r0436 16r2C59 16r0437 16r2C5A 16r0438 16r2C5B 16r0439 16r2C5C 16r043A 16r2C5D 16r043B 16r2C5E 16r043C 16r2C5F 16r043D 16r2C60 16r043E 16r2C61 16r043F 16r2C62 16r0440 16r2C63 16r0441 16r2C64 16r0442 16r2C65 16r0443 16r2C66 16r0444 16r2C67 16r0445 16r2C68 16r0446 16r2C69 16r0447 16r2C6A 16r0448 16r2C6B 16r0449 16r2C6C 16r044A 16r2C6D 16r044B 16r2C6E 16r044C 16r2C6F 16r044D 16r2C70 16r044E 16r2C71 16r044F 16r3021 16rAC00 16r3022 16rAC01 16r3023 16rAC04 16r3024 16rAC07 16r3025 16rAC08 16r3026 16rAC09 16r3027 16rAC0A 16r3028 16rAC10 16r3029 16rAC11 16r302A 16rAC12 16r302B 16rAC13 16r302C 16rAC14 16r302D 16rAC15 16r302E 16rAC16 16r302F 16rAC17 16r3030 16rAC19 16r3031 16rAC1A 16r3032 16rAC1B 16r3033 16rAC1C 16r3034 16rAC1D 16r3035 16rAC20 16r3036 16rAC24 16r3037 16rAC2C 16r3038 16rAC2D 16r3039 16rAC2F 16r303A 16rAC30 16r303B 16rAC31 16r303C 16rAC38 16r303D 16rAC39 16r303E 16rAC3C 16r303F 16rAC40 16r3040 16rAC4B 16r3041 16rAC4D 16r3042 16rAC54 16r3043 16rAC58 16r3044 16rAC5C 16r3045 16rAC70 16r3046 16rAC71 16r3047 16rAC74 16r3048 16rAC77 16r3049 16rAC78 16r304A 16rAC7A 16r304B 16rAC80 16r304C 16rAC81 16r304D 16rAC83 16r304E 16rAC84 16r304F 16rAC85 16r3050 16rAC86 16r3051 16rAC89 16r3052 16rAC8A 16r3053 16rAC8B 16r3054 16rAC8C 16r3055 16rAC90 16r3056 16rAC94 16r3057 16rAC9C 16r3058 16rAC9D 16r3059 16rAC9F 16r305A 16rACA0 16r305B 16rACA1 16r305C 16rACA8 16r305D 16rACA9 16r305E 16rACAA 16r305F 16rACAC 16r3060 16rACAF 16r3061 16rACB0 16r3062 16rACB8 16r3063 16rACB9 16r3064 16rACBB 16r3065 16rACBC 16r3066 16rACBD 16r3067 16rACC1 16r3068 16rACC4 16r3069 16rACC8 16r306A 16rACCC 16r306B 16rACD5 16r306C 16rACD7 16r306D 16rACE0 16r306E 16rACE1 16r306F 16rACE4 16r3070 16rACE7 16r3071 16rACE8 16r3072 16rACEA 16r3073 16rACEC 16r3074 16rACEF 16r3075 16rACF0 16r3076 16rACF1 16r3077 16rACF3 16r3078 16rACF5 16r3079 16rACF6 16r307A 16rACFC 16r307B 16rACFD 16r307C 16rAD00 16r307D 16rAD04 16r307E 16rAD06 16r3121 16rAD0C 16r3122 16rAD0D 16r3123 16rAD0F 16r3124 16rAD11 16r3125 16rAD18 16r3126 16rAD1C 16r3127 16rAD20 16r3128 16rAD29 16r3129 16rAD2C 16r312A 16rAD2D 16r312B 16rAD34 16r312C 16rAD35 16r312D 16rAD38 16r312E 16rAD3C 16r312F 16rAD44 16r3130 16rAD45 16r3131 16rAD47 16r3132 16rAD49 16r3133 16rAD50 16r3134 16rAD54 16r3135 16rAD58 16r3136 16rAD61 16r3137 16rAD63 16r3138 16rAD6C 16r3139 16rAD6D 16r313A 16rAD70 16r313B 16rAD73 16r313C 16rAD74 16r313D 16rAD75 16r313E 16rAD76 16r313F 16rAD7B 16r3140 16rAD7C 16r3141 16rAD7D 16r3142 16rAD7F 16r3143 16rAD81 16r3144 16rAD82 16r3145 16rAD88 16r3146 16rAD89 16r3147 16rAD8C 16r3148 16rAD90 16r3149 16rAD9C 16r314A 16rAD9D 16r314B 16rADA4 16r314C 16rADB7 16r314D 16rADC0 16r314E 16rADC1 16r314F 16rADC4 16r3150 16rADC8 16r3151 16rADD0 16r3152 16rADD1 16r3153 16rADD3 16r3154 16rADDC 16r3155 16rADE0 16r3156 16rADE4 16r3157 16rADF8 16r3158 16rADF9 16r3159 16rADFC 16r315A 16rADFF 16r315B 16rAE00 16r315C 16rAE01 16r315D 16rAE08 16r315E 16rAE09 16r315F 16rAE0B 16r3160 16rAE0D 16r3161 16rAE14 16r3162 16rAE30 16r3163 16rAE31 16r3164 16rAE34 16r3165 16rAE37 16r3166 16rAE38 16r3167 16rAE3A 16r3168 16rAE40 16r3169 16rAE41 16r316A 16rAE43 16r316B 16rAE45 16r316C 16rAE46 16r316D 16rAE4A 16r316E 16rAE4C 16r316F 16rAE4D 16r3170 16rAE4E 16r3171 16rAE50 16r3172 16rAE54 16r3173 16rAE56 16r3174 16rAE5C 16r3175 16rAE5D 16r3176 16rAE5F 16r3177 16rAE60 16r3178 16rAE61 16r3179 16rAE65 16r317A 16rAE68 16r317B 16rAE69 16r317C 16rAE6C 16r317D 16rAE70 16r317E 16rAE78 16r3221 16rAE79 16r3222 16rAE7B 16r3223 16rAE7C 16r3224 16rAE7D 16r3225 16rAE84 16r3226 16rAE85 16r3227 16rAE8C 16r3228 16rAEBC 16r3229 16rAEBD 16r322A 16rAEBE 16r322B 16rAEC0 16r322C 16rAEC4 16r322D 16rAECC 16r322E 16rAECD 16r322F 16rAECF 16r3230 16rAED0 16r3231 16rAED1 16r3232 16rAED8 16r3233 16rAED9 16r3234 16rAEDC 16r3235 16rAEE8 16r3236 16rAEEB 16r3237 16rAEED 16r3238 16rAEF4 16r3239 16rAEF8 16r323A 16rAEFC 16r323B 16rAF07 16r323C 16rAF08 16r323D 16rAF0D 16r323E 16rAF10 16r323F 16rAF2C 16r3240 16rAF2D 16r3241 16rAF30 16r3242 16rAF32 16r3243 16rAF34 16r3244 16rAF3C 16r3245 16rAF3D 16r3246 16rAF3F 16r3247 16rAF41 16r3248 16rAF42 16r3249 16rAF43 16r324A 16rAF48 16r324B 16rAF49 16r324C 16rAF50 16r324D 16rAF5C 16r324E 16rAF5D 16r324F 16rAF64 16r3250 16rAF65 16r3251 16rAF79 16r3252 16rAF80 16r3253 16rAF84 16r3254 16rAF88 16r3255 16rAF90 16r3256 16rAF91 16r3257 16rAF95 16r3258 16rAF9C 16r3259 16rAFB8 16r325A 16rAFB9 16r325B 16rAFBC 16r325C 16rAFC0 16r325D 16rAFC7 16r325E 16rAFC8 16r325F 16rAFC9 16r3260 16rAFCB 16r3261 16rAFCD 16r3262 16rAFCE 16r3263 16rAFD4 16r3264 16rAFDC 16r3265 16rAFE8 16r3266 16rAFE9 16r3267 16rAFF0 16r3268 16rAFF1 16r3269 16rAFF4 16r326A 16rAFF8 16r326B 16rB000 16r326C 16rB001 16r326D 16rB004 16r326E 16rB00C 16r326F 16rB010 16r3270 16rB014 16r3271 16rB01C 16r3272 16rB01D 16r3273 16rB028 16r3274 16rB044 16r3275 16rB045 16r3276 16rB048 16r3277 16rB04A 16r3278 16rB04C 16r3279 16rB04E 16r327A 16rB053 16r327B 16rB054 16r327C 16rB055 16r327D 16rB057 16r327E 16rB059 16r3321 16rB05D 16r3322 16rB07C 16r3323 16rB07D 16r3324 16rB080 16r3325 16rB084 16r3326 16rB08C 16r3327 16rB08D 16r3328 16rB08F 16r3329 16rB091 16r332A 16rB098 16r332B 16rB099 16r332C 16rB09A 16r332D 16rB09C 16r332E 16rB09F 16r332F 16rB0A0 16r3330 16rB0A1 16r3331 16rB0A2 16r3332 16rB0A8 16r3333 16rB0A9 16r3334 16rB0AB 16r3335 16rB0AC 16r3336 16rB0AD 16r3337 16rB0AE 16r3338 16rB0AF 16r3339 16rB0B1 16r333A 16rB0B3 16r333B 16rB0B4 16r333C 16rB0B5 16r333D 16rB0B8 16r333E 16rB0BC 16r333F 16rB0C4 16r3340 16rB0C5 16r3341 16rB0C7 16r3342 16rB0C8 16r3343 16rB0C9 16r3344 16rB0D0 16r3345 16rB0D1 16r3346 16rB0D4 16r3347 16rB0D8 16r3348 16rB0E0 16r3349 16rB0E5 16r334A 16rB108 16r334B 16rB109 16r334C 16rB10B 16r334D 16rB10C 16r334E 16rB110 16r334F 16rB112 16r3350 16rB113 16r3351 16rB118 16r3352 16rB119 16r3353 16rB11B 16r3354 16rB11C 16r3355 16rB11D 16r3356 16rB123 16r3357 16rB124 16r3358 16rB125 16r3359 16rB128 16r335A 16rB12C 16r335B 16rB134 16r335C 16rB135 16r335D 16rB137 16r335E 16rB138 16r335F 16rB139 16r3360 16rB140 16r3361 16rB141 16r3362 16rB144 16r3363 16rB148 16r3364 16rB150 16r3365 16rB151 16r3366 16rB154 16r3367 16rB155 16r3368 16rB158 16r3369 16rB15C 16r336A 16rB160 16r336B 16rB178 16r336C 16rB179 16r336D 16rB17C 16r336E 16rB180 16r336F 16rB182 16r3370 16rB188 16r3371 16rB189 16r3372 16rB18B 16r3373 16rB18D 16r3374 16rB192 16r3375 16rB193 16r3376 16rB194 16r3377 16rB198 16r3378 16rB19C 16r3379 16rB1A8 16r337A 16rB1CC 16r337B 16rB1D0 16r337C 16rB1D4 16r337D 16rB1DC 16r337E 16rB1DD 16r3421 16rB1DF 16r3422 16rB1E8 16r3423 16rB1E9 16r3424 16rB1EC 16r3425 16rB1F0 16r3426 16rB1F9 16r3427 16rB1FB 16r3428 16rB1FD 16r3429 16rB204 16r342A 16rB205 16r342B 16rB208 16r342C 16rB20B 16r342D 16rB20C 16r342E 16rB214 16r342F 16rB215 16r3430 16rB217 16r3431 16rB219 16r3432 16rB220 16r3433 16rB234 16r3434 16rB23C 16r3435 16rB258 16r3436 16rB25C 16r3437 16rB260 16r3438 16rB268 16r3439 16rB269 16r343A 16rB274 16r343B 16rB275 16r343C 16rB27C 16r343D 16rB284 16r343E 16rB285 16r343F 16rB289 16r3440 16rB290 16r3441 16rB291 16r3442 16rB294 16r3443 16rB298 16r3444 16rB299 16r3445 16rB29A 16r3446 16rB2A0 16r3447 16rB2A1 16r3448 16rB2A3 16r3449 16rB2A5 16r344A 16rB2A6 16r344B 16rB2AA 16r344C 16rB2AC 16r344D 16rB2B0 16r344E 16rB2B4 16r344F 16rB2C8 16r3450 16rB2C9 16r3451 16rB2CC 16r3452 16rB2D0 16r3453 16rB2D2 16r3454 16rB2D8 16r3455 16rB2D9 16r3456 16rB2DB 16r3457 16rB2DD 16r3458 16rB2E2 16r3459 16rB2E4 16r345A 16rB2E5 16r345B 16rB2E6 16r345C 16rB2E8 16r345D 16rB2EB 16r345E 16rB2EC 16r345F 16rB2ED 16r3460 16rB2EE 16r3461 16rB2EF 16r3462 16rB2F3 16r3463 16rB2F4 16r3464 16rB2F5 16r3465 16rB2F7 16r3466 16rB2F8 16r3467 16rB2F9 16r3468 16rB2FA 16r3469 16rB2FB 16r346A 16rB2FF 16r346B 16rB300 16r346C 16rB301 16r346D 16rB304 16r346E 16rB308 16r346F 16rB310 16r3470 16rB311 16r3471 16rB313 16r3472 16rB314 16r3473 16rB315 16r3474 16rB31C 16r3475 16rB354 16r3476 16rB355 16r3477 16rB356 16r3478 16rB358 16r3479 16rB35B 16r347A 16rB35C 16r347B 16rB35E 16r347C 16rB35F 16r347D 16rB364 16r347E 16rB365 16r3521 16rB367 16r3522 16rB369 16r3523 16rB36B 16r3524 16rB36E 16r3525 16rB370 16r3526 16rB371 16r3527 16rB374 16r3528 16rB378 16r3529 16rB380 16r352A 16rB381 16r352B 16rB383 16r352C 16rB384 16r352D 16rB385 16r352E 16rB38C 16r352F 16rB390 16r3530 16rB394 16r3531 16rB3A0 16r3532 16rB3A1 16r3533 16rB3A8 16r3534 16rB3AC 16r3535 16rB3C4 16r3536 16rB3C5 16r3537 16rB3C8 16r3538 16rB3CB 16r3539 16rB3CC 16r353A 16rB3CE 16r353B 16rB3D0 16r353C 16rB3D4 16r353D 16rB3D5 16r353E 16rB3D7 16r353F 16rB3D9 16r3540 16rB3DB 16r3541 16rB3DD 16r3542 16rB3E0 16r3543 16rB3E4 16r3544 16rB3E8 16r3545 16rB3FC 16r3546 16rB410 16r3547 16rB418 16r3548 16rB41C 16r3549 16rB420 16r354A 16rB428 16r354B 16rB429 16r354C 16rB42B 16r354D 16rB434 16r354E 16rB450 16r354F 16rB451 16r3550 16rB454 16r3551 16rB458 16r3552 16rB460 16r3553 16rB461 16r3554 16rB463 16r3555 16rB465 16r3556 16rB46C 16r3557 16rB480 16r3558 16rB488 16r3559 16rB49D 16r355A 16rB4A4 16r355B 16rB4A8 16r355C 16rB4AC 16r355D 16rB4B5 16r355E 16rB4B7 16r355F 16rB4B9 16r3560 16rB4C0 16r3561 16rB4C4 16r3562 16rB4C8 16r3563 16rB4D0 16r3564 16rB4D5 16r3565 16rB4DC 16r3566 16rB4DD 16r3567 16rB4E0 16r3568 16rB4E3 16r3569 16rB4E4 16r356A 16rB4E6 16r356B 16rB4EC 16r356C 16rB4ED 16r356D 16rB4EF 16r356E 16rB4F1 16r356F 16rB4F8 16r3570 16rB514 16r3571 16rB515 16r3572 16rB518 16r3573 16rB51B 16r3574 16rB51C 16r3575 16rB524 16r3576 16rB525 16r3577 16rB527 16r3578 16rB528 16r3579 16rB529 16r357A 16rB52A 16r357B 16rB530 16r357C 16rB531 16r357D 16rB534 16r357E 16rB538 16r3621 16rB540 16r3622 16rB541 16r3623 16rB543 16r3624 16rB544 16r3625 16rB545 16r3626 16rB54B 16r3627 16rB54C 16r3628 16rB54D 16r3629 16rB550 16r362A 16rB554 16r362B 16rB55C 16r362C 16rB55D 16r362D 16rB55F 16r362E 16rB560 16r362F 16rB561 16r3630 16rB5A0 16r3631 16rB5A1 16r3632 16rB5A4 16r3633 16rB5A8 16r3634 16rB5AA 16r3635 16rB5AB 16r3636 16rB5B0 16r3637 16rB5B1 16r3638 16rB5B3 16r3639 16rB5B4 16r363A 16rB5B5 16r363B 16rB5BB 16r363C 16rB5BC 16r363D 16rB5BD 16r363E 16rB5C0 16r363F 16rB5C4 16r3640 16rB5CC 16r3641 16rB5CD 16r3642 16rB5CF 16r3643 16rB5D0 16r3644 16rB5D1 16r3645 16rB5D8 16r3646 16rB5EC 16r3647 16rB610 16r3648 16rB611 16r3649 16rB614 16r364A 16rB618 16r364B 16rB625 16r364C 16rB62C 16r364D 16rB634 16r364E 16rB648 16r364F 16rB664 16r3650 16rB668 16r3651 16rB69C 16r3652 16rB69D 16r3653 16rB6A0 16r3654 16rB6A4 16r3655 16rB6AB 16r3656 16rB6AC 16r3657 16rB6B1 16r3658 16rB6D4 16r3659 16rB6F0 16r365A 16rB6F4 16r365B 16rB6F8 16r365C 16rB700 16r365D 16rB701 16r365E 16rB705 16r365F 16rB728 16r3660 16rB729 16r3661 16rB72C 16r3662 16rB72F 16r3663 16rB730 16r3664 16rB738 16r3665 16rB739 16r3666 16rB73B 16r3667 16rB744 16r3668 16rB748 16r3669 16rB74C 16r366A 16rB754 16r366B 16rB755 16r366C 16rB760 16r366D 16rB764 16r366E 16rB768 16r366F 16rB770 16r3670 16rB771 16r3671 16rB773 16r3672 16rB775 16r3673 16rB77C 16r3674 16rB77D 16r3675 16rB780 16r3676 16rB784 16r3677 16rB78C 16r3678 16rB78D 16r3679 16rB78F 16r367A 16rB790 16r367B 16rB791 16r367C 16rB792 16r367D 16rB796 16r367E 16rB797 16r3721 16rB798 16r3722 16rB799 16r3723 16rB79C 16r3724 16rB7A0 16r3725 16rB7A8 16r3726 16rB7A9 16r3727 16rB7AB 16r3728 16rB7AC 16r3729 16rB7AD 16r372A 16rB7B4 16r372B 16rB7B5 16r372C 16rB7B8 16r372D 16rB7C7 16r372E 16rB7C9 16r372F 16rB7EC 16r3730 16rB7ED 16r3731 16rB7F0 16r3732 16rB7F4 16r3733 16rB7FC 16r3734 16rB7FD 16r3735 16rB7FF 16r3736 16rB800 16r3737 16rB801 16r3738 16rB807 16r3739 16rB808 16r373A 16rB809 16r373B 16rB80C 16r373C 16rB810 16r373D 16rB818 16r373E 16rB819 16r373F 16rB81B 16r3740 16rB81D 16r3741 16rB824 16r3742 16rB825 16r3743 16rB828 16r3744 16rB82C 16r3745 16rB834 16r3746 16rB835 16r3747 16rB837 16r3748 16rB838 16r3749 16rB839 16r374A 16rB840 16r374B 16rB844 16r374C 16rB851 16r374D 16rB853 16r374E 16rB85C 16r374F 16rB85D 16r3750 16rB860 16r3751 16rB864 16r3752 16rB86C 16r3753 16rB86D 16r3754 16rB86F 16r3755 16rB871 16r3756 16rB878 16r3757 16rB87C 16r3758 16rB88D 16r3759 16rB8A8 16r375A 16rB8B0 16r375B 16rB8B4 16r375C 16rB8B8 16r375D 16rB8C0 16r375E 16rB8C1 16r375F 16rB8C3 16r3760 16rB8C5 16r3761 16rB8CC 16r3762 16rB8D0 16r3763 16rB8D4 16r3764 16rB8DD 16r3765 16rB8DF 16r3766 16rB8E1 16r3767 16rB8E8 16r3768 16rB8E9 16r3769 16rB8EC 16r376A 16rB8F0 16r376B 16rB8F8 16r376C 16rB8F9 16r376D 16rB8FB 16r376E 16rB8FD 16r376F 16rB904 16r3770 16rB918 16r3771 16rB920 16r3772 16rB93C 16r3773 16rB93D 16r3774 16rB940 16r3775 16rB944 16r3776 16rB94C 16r3777 16rB94F 16r3778 16rB951 16r3779 16rB958 16r377A 16rB959 16r377B 16rB95C 16r377C 16rB960 16r377D 16rB968 16r377E 16rB969 16r3821 16rB96B 16r3822 16rB96D 16r3823 16rB974 16r3824 16rB975 16r3825 16rB978 16r3826 16rB97C 16r3827 16rB984 16r3828 16rB985 16r3829 16rB987 16r382A 16rB989 16r382B 16rB98A 16r382C 16rB98D 16r382D 16rB98E 16r382E 16rB9AC 16r382F 16rB9AD 16r3830 16rB9B0 16r3831 16rB9B4 16r3832 16rB9BC 16r3833 16rB9BD 16r3834 16rB9BF 16r3835 16rB9C1 16r3836 16rB9C8 16r3837 16rB9C9 16r3838 16rB9CC 16r3839 16rB9CE 16r383A 16rB9CF 16r383B 16rB9D0 16r383C 16rB9D1 16r383D 16rB9D2 16r383E 16rB9D8 16r383F 16rB9D9 16r3840 16rB9DB 16r3841 16rB9DD 16r3842 16rB9DE 16r3843 16rB9E1 16r3844 16rB9E3 16r3845 16rB9E4 16r3846 16rB9E5 16r3847 16rB9E8 16r3848 16rB9EC 16r3849 16rB9F4 16r384A 16rB9F5 16r384B 16rB9F7 16r384C 16rB9F8 16r384D 16rB9F9 16r384E 16rB9FA 16r384F 16rBA00 16r3850 16rBA01 16r3851 16rBA08 16r3852 16rBA15 16r3853 16rBA38 16r3854 16rBA39 16r3855 16rBA3C 16r3856 16rBA40 16r3857 16rBA42 16r3858 16rBA48 16r3859 16rBA49 16r385A 16rBA4B 16r385B 16rBA4D 16r385C 16rBA4E 16r385D 16rBA53 16r385E 16rBA54 16r385F 16rBA55 16r3860 16rBA58 16r3861 16rBA5C 16r3862 16rBA64 16r3863 16rBA65 16r3864 16rBA67 16r3865 16rBA68 16r3866 16rBA69 16r3867 16rBA70 16r3868 16rBA71 16r3869 16rBA74 16r386A 16rBA78 16r386B 16rBA83 16r386C 16rBA84 16r386D 16rBA85 16r386E 16rBA87 16r386F 16rBA8C 16r3870 16rBAA8 16r3871 16rBAA9 16r3872 16rBAAB 16r3873 16rBAAC 16r3874 16rBAB0 16r3875 16rBAB2 16r3876 16rBAB8 16r3877 16rBAB9 16r3878 16rBABB 16r3879 16rBABD 16r387A 16rBAC4 16r387B 16rBAC8 16r387C 16rBAD8 16r387D 16rBAD9 16r387E 16rBAFC 16r3921 16rBB00 16r3922 16rBB04 16r3923 16rBB0D 16r3924 16rBB0F 16r3925 16rBB11 16r3926 16rBB18 16r3927 16rBB1C 16r3928 16rBB20 16r3929 16rBB29 16r392A 16rBB2B 16r392B 16rBB34 16r392C 16rBB35 16r392D 16rBB36 16r392E 16rBB38 16r392F 16rBB3B 16r3930 16rBB3C 16r3931 16rBB3D 16r3932 16rBB3E 16r3933 16rBB44 16r3934 16rBB45 16r3935 16rBB47 16r3936 16rBB49 16r3937 16rBB4D 16r3938 16rBB4F 16r3939 16rBB50 16r393A 16rBB54 16r393B 16rBB58 16r393C 16rBB61 16r393D 16rBB63 16r393E 16rBB6C 16r393F 16rBB88 16r3940 16rBB8C 16r3941 16rBB90 16r3942 16rBBA4 16r3943 16rBBA8 16r3944 16rBBAC 16r3945 16rBBB4 16r3946 16rBBB7 16r3947 16rBBC0 16r3948 16rBBC4 16r3949 16rBBC8 16r394A 16rBBD0 16r394B 16rBBD3 16r394C 16rBBF8 16r394D 16rBBF9 16r394E 16rBBFC 16r394F 16rBBFF 16r3950 16rBC00 16r3951 16rBC02 16r3952 16rBC08 16r3953 16rBC09 16r3954 16rBC0B 16r3955 16rBC0C 16r3956 16rBC0D 16r3957 16rBC0F 16r3958 16rBC11 16r3959 16rBC14 16r395A 16rBC15 16r395B 16rBC16 16r395C 16rBC17 16r395D 16rBC18 16r395E 16rBC1B 16r395F 16rBC1C 16r3960 16rBC1D 16r3961 16rBC1E 16r3962 16rBC1F 16r3963 16rBC24 16r3964 16rBC25 16r3965 16rBC27 16r3966 16rBC29 16r3967 16rBC2D 16r3968 16rBC30 16r3969 16rBC31 16r396A 16rBC34 16r396B 16rBC38 16r396C 16rBC40 16r396D 16rBC41 16r396E 16rBC43 16r396F 16rBC44 16r3970 16rBC45 16r3971 16rBC49 16r3972 16rBC4C 16r3973 16rBC4D 16r3974 16rBC50 16r3975 16rBC5D 16r3976 16rBC84 16r3977 16rBC85 16r3978 16rBC88 16r3979 16rBC8B 16r397A 16rBC8C 16r397B 16rBC8E 16r397C 16rBC94 16r397D 16rBC95 16r397E 16rBC97 16r3A21 16rBC99 16r3A22 16rBC9A 16r3A23 16rBCA0 16r3A24 16rBCA1 16r3A25 16rBCA4 16r3A26 16rBCA7 16r3A27 16rBCA8 16r3A28 16rBCB0 16r3A29 16rBCB1 16r3A2A 16rBCB3 16r3A2B 16rBCB4 16r3A2C 16rBCB5 16r3A2D 16rBCBC 16r3A2E 16rBCBD 16r3A2F 16rBCC0 16r3A30 16rBCC4 16r3A31 16rBCCD 16r3A32 16rBCCF 16r3A33 16rBCD0 16r3A34 16rBCD1 16r3A35 16rBCD5 16r3A36 16rBCD8 16r3A37 16rBCDC 16r3A38 16rBCF4 16r3A39 16rBCF5 16r3A3A 16rBCF6 16r3A3B 16rBCF8 16r3A3C 16rBCFC 16r3A3D 16rBD04 16r3A3E 16rBD05 16r3A3F 16rBD07 16r3A40 16rBD09 16r3A41 16rBD10 16r3A42 16rBD14 16r3A43 16rBD24 16r3A44 16rBD2C 16r3A45 16rBD40 16r3A46 16rBD48 16r3A47 16rBD49 16r3A48 16rBD4C 16r3A49 16rBD50 16r3A4A 16rBD58 16r3A4B 16rBD59 16r3A4C 16rBD64 16r3A4D 16rBD68 16r3A4E 16rBD80 16r3A4F 16rBD81 16r3A50 16rBD84 16r3A51 16rBD87 16r3A52 16rBD88 16r3A53 16rBD89 16r3A54 16rBD8A 16r3A55 16rBD90 16r3A56 16rBD91 16r3A57 16rBD93 16r3A58 16rBD95 16r3A59 16rBD99 16r3A5A 16rBD9A 16r3A5B 16rBD9C 16r3A5C 16rBDA4 16r3A5D 16rBDB0 16r3A5E 16rBDB8 16r3A5F 16rBDD4 16r3A60 16rBDD5 16r3A61 16rBDD8 16r3A62 16rBDDC 16r3A63 16rBDE9 16r3A64 16rBDF0 16r3A65 16rBDF4 16r3A66 16rBDF8 16r3A67 16rBE00 16r3A68 16rBE03 16r3A69 16rBE05 16r3A6A 16rBE0C 16r3A6B 16rBE0D 16r3A6C 16rBE10 16r3A6D 16rBE14 16r3A6E 16rBE1C 16r3A6F 16rBE1D 16r3A70 16rBE1F 16r3A71 16rBE44 16r3A72 16rBE45 16r3A73 16rBE48 16r3A74 16rBE4C 16r3A75 16rBE4E 16r3A76 16rBE54 16r3A77 16rBE55 16r3A78 16rBE57 16r3A79 16rBE59 16r3A7A 16rBE5A 16r3A7B 16rBE5B 16r3A7C 16rBE60 16r3A7D 16rBE61 16r3A7E 16rBE64 16r3B21 16rBE68 16r3B22 16rBE6A 16r3B23 16rBE70 16r3B24 16rBE71 16r3B25 16rBE73 16r3B26 16rBE74 16r3B27 16rBE75 16r3B28 16rBE7B 16r3B29 16rBE7C 16r3B2A 16rBE7D 16r3B2B 16rBE80 16r3B2C 16rBE84 16r3B2D 16rBE8C 16r3B2E 16rBE8D 16r3B2F 16rBE8F 16r3B30 16rBE90 16r3B31 16rBE91 16r3B32 16rBE98 16r3B33 16rBE99 16r3B34 16rBEA8 16r3B35 16rBED0 16r3B36 16rBED1 16r3B37 16rBED4 16r3B38 16rBED7 16r3B39 16rBED8 16r3B3A 16rBEE0 16r3B3B 16rBEE3 16r3B3C 16rBEE4 16r3B3D 16rBEE5 16r3B3E 16rBEEC 16r3B3F 16rBF01 16r3B40 16rBF08 16r3B41 16rBF09 16r3B42 16rBF18 16r3B43 16rBF19 16r3B44 16rBF1B 16r3B45 16rBF1C 16r3B46 16rBF1D 16r3B47 16rBF40 16r3B48 16rBF41 16r3B49 16rBF44 16r3B4A 16rBF48 16r3B4B 16rBF50 16r3B4C 16rBF51 16r3B4D 16rBF55 16r3B4E 16rBF94 16r3B4F 16rBFB0 16r3B50 16rBFC5 16r3B51 16rBFCC 16r3B52 16rBFCD 16r3B53 16rBFD0 16r3B54 16rBFD4 16r3B55 16rBFDC 16r3B56 16rBFDF 16r3B57 16rBFE1 16r3B58 16rC03C 16r3B59 16rC051 16r3B5A 16rC058 16r3B5B 16rC05C 16r3B5C 16rC060 16r3B5D 16rC068 16r3B5E 16rC069 16r3B5F 16rC090 16r3B60 16rC091 16r3B61 16rC094 16r3B62 16rC098 16r3B63 16rC0A0 16r3B64 16rC0A1 16r3B65 16rC0A3 16r3B66 16rC0A5 16r3B67 16rC0AC 16r3B68 16rC0AD 16r3B69 16rC0AF 16r3B6A 16rC0B0 16r3B6B 16rC0B3 16r3B6C 16rC0B4 16r3B6D 16rC0B5 16r3B6E 16rC0B6 16r3B6F 16rC0BC 16r3B70 16rC0BD 16r3B71 16rC0BF 16r3B72 16rC0C0 16r3B73 16rC0C1 16r3B74 16rC0C5 16r3B75 16rC0C8 16r3B76 16rC0C9 16r3B77 16rC0CC 16r3B78 16rC0D0 16r3B79 16rC0D8 16r3B7A 16rC0D9 16r3B7B 16rC0DB 16r3B7C 16rC0DC 16r3B7D 16rC0DD 16r3B7E 16rC0E4 16r3C21 16rC0E5 16r3C22 16rC0E8 16r3C23 16rC0EC 16r3C24 16rC0F4 16r3C25 16rC0F5 16r3C26 16rC0F7 16r3C27 16rC0F9 16r3C28 16rC100 16r3C29 16rC104 16r3C2A 16rC108 16r3C2B 16rC110 16r3C2C 16rC115 16r3C2D 16rC11C 16r3C2E 16rC11D 16r3C2F 16rC11E 16r3C30 16rC11F 16r3C31 16rC120 16r3C32 16rC123 16r3C33 16rC124 16r3C34 16rC126 16r3C35 16rC127 16r3C36 16rC12C 16r3C37 16rC12D 16r3C38 16rC12F 16r3C39 16rC130 16r3C3A 16rC131 16r3C3B 16rC136 16r3C3C 16rC138 16r3C3D 16rC139 16r3C3E 16rC13C 16r3C3F 16rC140 16r3C40 16rC148 16r3C41 16rC149 16r3C42 16rC14B 16r3C43 16rC14C 16r3C44 16rC14D 16r3C45 16rC154 16r3C46 16rC155 16r3C47 16rC158 16r3C48 16rC15C 16r3C49 16rC164 16r3C4A 16rC165 16r3C4B 16rC167 16r3C4C 16rC168 16r3C4D 16rC169 16r3C4E 16rC170 16r3C4F 16rC174 16r3C50 16rC178 16r3C51 16rC185 16r3C52 16rC18C 16r3C53 16rC18D 16r3C54 16rC18E 16r3C55 16rC190 16r3C56 16rC194 16r3C57 16rC196 16r3C58 16rC19C 16r3C59 16rC19D 16r3C5A 16rC19F 16r3C5B 16rC1A1 16r3C5C 16rC1A5 16r3C5D 16rC1A8 16r3C5E 16rC1A9 16r3C5F 16rC1AC 16r3C60 16rC1B0 16r3C61 16rC1BD 16r3C62 16rC1C4 16r3C63 16rC1C8 16r3C64 16rC1CC 16r3C65 16rC1D4 16r3C66 16rC1D7 16r3C67 16rC1D8 16r3C68 16rC1E0 16r3C69 16rC1E4 16r3C6A 16rC1E8 16r3C6B 16rC1F0 16r3C6C 16rC1F1 16r3C6D 16rC1F3 16r3C6E 16rC1FC 16r3C6F 16rC1FD 16r3C70 16rC200 16r3C71 16rC204 16r3C72 16rC20C 16r3C73 16rC20D 16r3C74 16rC20F 16r3C75 16rC211 16r3C76 16rC218 16r3C77 16rC219 16r3C78 16rC21C 16r3C79 16rC21F 16r3C7A 16rC220 16r3C7B 16rC228 16r3C7C 16rC229 16r3C7D 16rC22B 16r3C7E 16rC22D 16r3D21 16rC22F 16r3D22 16rC231 16r3D23 16rC232 16r3D24 16rC234 16r3D25 16rC248 16r3D26 16rC250 16r3D27 16rC251 16r3D28 16rC254 16r3D29 16rC258 16r3D2A 16rC260 16r3D2B 16rC265 16r3D2C 16rC26C 16r3D2D 16rC26D 16r3D2E 16rC270 16r3D2F 16rC274 16r3D30 16rC27C 16r3D31 16rC27D 16r3D32 16rC27F 16r3D33 16rC281 16r3D34 16rC288 16r3D35 16rC289 16r3D36 16rC290 16r3D37 16rC298 16r3D38 16rC29B 16r3D39 16rC29D 16r3D3A 16rC2A4 16r3D3B 16rC2A5 16r3D3C 16rC2A8 16r3D3D 16rC2AC 16r3D3E 16rC2AD 16r3D3F 16rC2B4 16r3D40 16rC2B5 16r3D41 16rC2B7 16r3D42 16rC2B9 16r3D43 16rC2DC 16r3D44 16rC2DD 16r3D45 16rC2E0 16r3D46 16rC2E3 16r3D47 16rC2E4 16r3D48 16rC2EB 16r3D49 16rC2EC 16r3D4A 16rC2ED 16r3D4B 16rC2EF 16r3D4C 16rC2F1 16r3D4D 16rC2F6 16r3D4E 16rC2F8 16r3D4F 16rC2F9 16r3D50 16rC2FB 16r3D51 16rC2FC 16r3D52 16rC300 16r3D53 16rC308 16r3D54 16rC309 16r3D55 16rC30C 16r3D56 16rC30D 16r3D57 16rC313 16r3D58 16rC314 16r3D59 16rC315 16r3D5A 16rC318 16r3D5B 16rC31C 16r3D5C 16rC324 16r3D5D 16rC325 16r3D5E 16rC328 16r3D5F 16rC329 16r3D60 16rC345 16r3D61 16rC368 16r3D62 16rC369 16r3D63 16rC36C 16r3D64 16rC370 16r3D65 16rC372 16r3D66 16rC378 16r3D67 16rC379 16r3D68 16rC37C 16r3D69 16rC37D 16r3D6A 16rC384 16r3D6B 16rC388 16r3D6C 16rC38C 16r3D6D 16rC3C0 16r3D6E 16rC3D8 16r3D6F 16rC3D9 16r3D70 16rC3DC 16r3D71 16rC3DF 16r3D72 16rC3E0 16r3D73 16rC3E2 16r3D74 16rC3E8 16r3D75 16rC3E9 16r3D76 16rC3ED 16r3D77 16rC3F4 16r3D78 16rC3F5 16r3D79 16rC3F8 16r3D7A 16rC408 16r3D7B 16rC410 16r3D7C 16rC424 16r3D7D 16rC42C 16r3D7E 16rC430 16r3E21 16rC434 16r3E22 16rC43C 16r3E23 16rC43D 16r3E24 16rC448 16r3E25 16rC464 16r3E26 16rC465 16r3E27 16rC468 16r3E28 16rC46C 16r3E29 16rC474 16r3E2A 16rC475 16r3E2B 16rC479 16r3E2C 16rC480 16r3E2D 16rC494 16r3E2E 16rC49C 16r3E2F 16rC4B8 16r3E30 16rC4BC 16r3E31 16rC4E9 16r3E32 16rC4F0 16r3E33 16rC4F1 16r3E34 16rC4F4 16r3E35 16rC4F8 16r3E36 16rC4FA 16r3E37 16rC4FF 16r3E38 16rC500 16r3E39 16rC501 16r3E3A 16rC50C 16r3E3B 16rC510 16r3E3C 16rC514 16r3E3D 16rC51C 16r3E3E 16rC528 16r3E3F 16rC529 16r3E40 16rC52C 16r3E41 16rC530 16r3E42 16rC538 16r3E43 16rC539 16r3E44 16rC53B 16r3E45 16rC53D 16r3E46 16rC544 16r3E47 16rC545 16r3E48 16rC548 16r3E49 16rC549 16r3E4A 16rC54A 16r3E4B 16rC54C 16r3E4C 16rC54D 16r3E4D 16rC54E 16r3E4E 16rC553 16r3E4F 16rC554 16r3E50 16rC555 16r3E51 16rC557 16r3E52 16rC558 16r3E53 16rC559 16r3E54 16rC55D 16r3E55 16rC55E 16r3E56 16rC560 16r3E57 16rC561 16r3E58 16rC564 16r3E59 16rC568 16r3E5A 16rC570 16r3E5B 16rC571 16r3E5C 16rC573 16r3E5D 16rC574 16r3E5E 16rC575 16r3E5F 16rC57C 16r3E60 16rC57D 16r3E61 16rC580 16r3E62 16rC584 16r3E63 16rC587 16r3E64 16rC58C 16r3E65 16rC58D 16r3E66 16rC58F 16r3E67 16rC591 16r3E68 16rC595 16r3E69 16rC597 16r3E6A 16rC598 16r3E6B 16rC59C 16r3E6C 16rC5A0 16r3E6D 16rC5A9 16r3E6E 16rC5B4 16r3E6F 16rC5B5 16r3E70 16rC5B8 16r3E71 16rC5B9 16r3E72 16rC5BB 16r3E73 16rC5BC 16r3E74 16rC5BD 16r3E75 16rC5BE 16r3E76 16rC5C4 16r3E77 16rC5C5 16r3E78 16rC5C6 16r3E79 16rC5C7 16r3E7A 16rC5C8 16r3E7B 16rC5C9 16r3E7C 16rC5CA 16r3E7D 16rC5CC 16r3E7E 16rC5CE 16r3F21 16rC5D0 16r3F22 16rC5D1 16r3F23 16rC5D4 16r3F24 16rC5D8 16r3F25 16rC5E0 16r3F26 16rC5E1 16r3F27 16rC5E3 16r3F28 16rC5E5 16r3F29 16rC5EC 16r3F2A 16rC5ED 16r3F2B 16rC5EE 16r3F2C 16rC5F0 16r3F2D 16rC5F4 16r3F2E 16rC5F6 16r3F2F 16rC5F7 16r3F30 16rC5FC 16r3F31 16rC5FD 16r3F32 16rC5FE 16r3F33 16rC5FF 16r3F34 16rC600 16r3F35 16rC601 16r3F36 16rC605 16r3F37 16rC606 16r3F38 16rC607 16r3F39 16rC608 16r3F3A 16rC60C 16r3F3B 16rC610 16r3F3C 16rC618 16r3F3D 16rC619 16r3F3E 16rC61B 16r3F3F 16rC61C 16r3F40 16rC624 16r3F41 16rC625 16r3F42 16rC628 16r3F43 16rC62C 16r3F44 16rC62D 16r3F45 16rC62E 16r3F46 16rC630 16r3F47 16rC633 16r3F48 16rC634 16r3F49 16rC635 16r3F4A 16rC637 16r3F4B 16rC639 16r3F4C 16rC63B 16r3F4D 16rC640 16r3F4E 16rC641 16r3F4F 16rC644 16r3F50 16rC648 16r3F51 16rC650 16r3F52 16rC651 16r3F53 16rC653 16r3F54 16rC654 16r3F55 16rC655 16r3F56 16rC65C 16r3F57 16rC65D 16r3F58 16rC660 16r3F59 16rC66C 16r3F5A 16rC66F 16r3F5B 16rC671 16r3F5C 16rC678 16r3F5D 16rC679 16r3F5E 16rC67C 16r3F5F 16rC680 16r3F60 16rC688 16r3F61 16rC689 16r3F62 16rC68B 16r3F63 16rC68D 16r3F64 16rC694 16r3F65 16rC695 16r3F66 16rC698 16r3F67 16rC69C 16r3F68 16rC6A4 16r3F69 16rC6A5 16r3F6A 16rC6A7 16r3F6B 16rC6A9 16r3F6C 16rC6B0 16r3F6D 16rC6B1 16r3F6E 16rC6B4 16r3F6F 16rC6B8 16r3F70 16rC6B9 16r3F71 16rC6BA 16r3F72 16rC6C0 16r3F73 16rC6C1 16r3F74 16rC6C3 16r3F75 16rC6C5 16r3F76 16rC6CC 16r3F77 16rC6CD 16r3F78 16rC6D0 16r3F79 16rC6D4 16r3F7A 16rC6DC 16r3F7B 16rC6DD 16r3F7C 16rC6E0 16r3F7D 16rC6E1 16r3F7E 16rC6E8 16r4021 16rC6E9 16r4022 16rC6EC 16r4023 16rC6F0 16r4024 16rC6F8 16r4025 16rC6F9 16r4026 16rC6FD 16r4027 16rC704 16r4028 16rC705 16r4029 16rC708 16r402A 16rC70C 16r402B 16rC714 16r402C 16rC715 16r402D 16rC717 16r402E 16rC719 16r402F 16rC720 16r4030 16rC721 16r4031 16rC724 16r4032 16rC728 16r4033 16rC730 16r4034 16rC731 16r4035 16rC733 16r4036 16rC735 16r4037 16rC737 16r4038 16rC73C 16r4039 16rC73D 16r403A 16rC740 16r403B 16rC744 16r403C 16rC74A 16r403D 16rC74C 16r403E 16rC74D 16r403F 16rC74F 16r4040 16rC751 16r4041 16rC752 16r4042 16rC753 16r4043 16rC754 16r4044 16rC755 16r4045 16rC756 16r4046 16rC757 16r4047 16rC758 16r4048 16rC75C 16r4049 16rC760 16r404A 16rC768 16r404B 16rC76B 16r404C 16rC774 16r404D 16rC775 16r404E 16rC778 16r404F 16rC77C 16r4050 16rC77D 16r4051 16rC77E 16r4052 16rC783 16r4053 16rC784 16r4054 16rC785 16r4055 16rC787 16r4056 16rC788 16r4057 16rC789 16r4058 16rC78A 16r4059 16rC78E 16r405A 16rC790 16r405B 16rC791 16r405C 16rC794 16r405D 16rC796 16r405E 16rC797 16r405F 16rC798 16r4060 16rC79A 16r4061 16rC7A0 16r4062 16rC7A1 16r4063 16rC7A3 16r4064 16rC7A4 16r4065 16rC7A5 16r4066 16rC7A6 16r4067 16rC7AC 16r4068 16rC7AD 16r4069 16rC7B0 16r406A 16rC7B4 16r406B 16rC7BC 16r406C 16rC7BD 16r406D 16rC7BF 16r406E 16rC7C0 16r406F 16rC7C1 16r4070 16rC7C8 16r4071 16rC7C9 16r4072 16rC7CC 16r4073 16rC7CE 16r4074 16rC7D0 16r4075 16rC7D8 16r4076 16rC7DD 16r4077 16rC7E4 16r4078 16rC7E8 16r4079 16rC7EC 16r407A 16rC800 16r407B 16rC801 16r407C 16rC804 16r407D 16rC808 16r407E 16rC80A 16r4121 16rC810 16r4122 16rC811 16r4123 16rC813 16r4124 16rC815 16r4125 16rC816 16r4126 16rC81C 16r4127 16rC81D 16r4128 16rC820 16r4129 16rC824 16r412A 16rC82C 16r412B 16rC82D 16r412C 16rC82F 16r412D 16rC831 16r412E 16rC838 16r412F 16rC83C 16r4130 16rC840 16r4131 16rC848 16r4132 16rC849 16r4133 16rC84C 16r4134 16rC84D 16r4135 16rC854 16r4136 16rC870 16r4137 16rC871 16r4138 16rC874 16r4139 16rC878 16r413A 16rC87A 16r413B 16rC880 16r413C 16rC881 16r413D 16rC883 16r413E 16rC885 16r413F 16rC886 16r4140 16rC887 16r4141 16rC88B 16r4142 16rC88C 16r4143 16rC88D 16r4144 16rC894 16r4145 16rC89D 16r4146 16rC89F 16r4147 16rC8A1 16r4148 16rC8A8 16r4149 16rC8BC 16r414A 16rC8BD 16r414B 16rC8C4 16r414C 16rC8C8 16r414D 16rC8CC 16r414E 16rC8D4 16r414F 16rC8D5 16r4150 16rC8D7 16r4151 16rC8D9 16r4152 16rC8E0 16r4153 16rC8E1 16r4154 16rC8E4 16r4155 16rC8F5 16r4156 16rC8FC 16r4157 16rC8FD 16r4158 16rC900 16r4159 16rC904 16r415A 16rC905 16r415B 16rC906 16r415C 16rC90C 16r415D 16rC90D 16r415E 16rC90F 16r415F 16rC911 16r4160 16rC918 16r4161 16rC92C 16r4162 16rC934 16r4163 16rC950 16r4164 16rC951 16r4165 16rC954 16r4166 16rC958 16r4167 16rC960 16r4168 16rC961 16r4169 16rC963 16r416A 16rC96C 16r416B 16rC970 16r416C 16rC974 16r416D 16rC97C 16r416E 16rC988 16r416F 16rC989 16r4170 16rC98C 16r4171 16rC990 16r4172 16rC998 16r4173 16rC999 16r4174 16rC99B 16r4175 16rC99D 16r4176 16rC9C0 16r4177 16rC9C1 16r4178 16rC9C4 16r4179 16rC9C7 16r417A 16rC9C8 16r417B 16rC9CA 16r417C 16rC9D0 16r417D 16rC9D1 16r417E 16rC9D3 16r4221 16rC9D5 16r4222 16rC9D6 16r4223 16rC9D9 16r4224 16rC9DA 16r4225 16rC9DC 16r4226 16rC9DD 16r4227 16rC9E0 16r4228 16rC9E2 16r4229 16rC9E4 16r422A 16rC9E7 16r422B 16rC9EC 16r422C 16rC9ED 16r422D 16rC9EF 16r422E 16rC9F0 16r422F 16rC9F1 16r4230 16rC9F8 16r4231 16rC9F9 16r4232 16rC9FC 16r4233 16rCA00 16r4234 16rCA08 16r4235 16rCA09 16r4236 16rCA0B 16r4237 16rCA0C 16r4238 16rCA0D 16r4239 16rCA14 16r423A 16rCA18 16r423B 16rCA29 16r423C 16rCA4C 16r423D 16rCA4D 16r423E 16rCA50 16r423F 16rCA54 16r4240 16rCA5C 16r4241 16rCA5D 16r4242 16rCA5F 16r4243 16rCA60 16r4244 16rCA61 16r4245 16rCA68 16r4246 16rCA7D 16r4247 16rCA84 16r4248 16rCA98 16r4249 16rCABC 16r424A 16rCABD 16r424B 16rCAC0 16r424C 16rCAC4 16r424D 16rCACC 16r424E 16rCACD 16r424F 16rCACF 16r4250 16rCAD1 16r4251 16rCAD3 16r4252 16rCAD8 16r4253 16rCAD9 16r4254 16rCAE0 16r4255 16rCAEC 16r4256 16rCAF4 16r4257 16rCB08 16r4258 16rCB10 16r4259 16rCB14 16r425A 16rCB18 16r425B 16rCB20 16r425C 16rCB21 16r425D 16rCB41 16r425E 16rCB48 16r425F 16rCB49 16r4260 16rCB4C 16r4261 16rCB50 16r4262 16rCB58 16r4263 16rCB59 16r4264 16rCB5D 16r4265 16rCB64 16r4266 16rCB78 16r4267 16rCB79 16r4268 16rCB9C 16r4269 16rCBB8 16r426A 16rCBD4 16r426B 16rCBE4 16r426C 16rCBE7 16r426D 16rCBE9 16r426E 16rCC0C 16r426F 16rCC0D 16r4270 16rCC10 16r4271 16rCC14 16r4272 16rCC1C 16r4273 16rCC1D 16r4274 16rCC21 16r4275 16rCC22 16r4276 16rCC27 16r4277 16rCC28 16r4278 16rCC29 16r4279 16rCC2C 16r427A 16rCC2E 16r427B 16rCC30 16r427C 16rCC38 16r427D 16rCC39 16r427E 16rCC3B 16r4321 16rCC3C 16r4322 16rCC3D 16r4323 16rCC3E 16r4324 16rCC44 16r4325 16rCC45 16r4326 16rCC48 16r4327 16rCC4C 16r4328 16rCC54 16r4329 16rCC55 16r432A 16rCC57 16r432B 16rCC58 16r432C 16rCC59 16r432D 16rCC60 16r432E 16rCC64 16r432F 16rCC66 16r4330 16rCC68 16r4331 16rCC70 16r4332 16rCC75 16r4333 16rCC98 16r4334 16rCC99 16r4335 16rCC9C 16r4336 16rCCA0 16r4337 16rCCA8 16r4338 16rCCA9 16r4339 16rCCAB 16r433A 16rCCAC 16r433B 16rCCAD 16r433C 16rCCB4 16r433D 16rCCB5 16r433E 16rCCB8 16r433F 16rCCBC 16r4340 16rCCC4 16r4341 16rCCC5 16r4342 16rCCC7 16r4343 16rCCC9 16r4344 16rCCD0 16r4345 16rCCD4 16r4346 16rCCE4 16r4347 16rCCEC 16r4348 16rCCF0 16r4349 16rCD01 16r434A 16rCD08 16r434B 16rCD09 16r434C 16rCD0C 16r434D 16rCD10 16r434E 16rCD18 16r434F 16rCD19 16r4350 16rCD1B 16r4351 16rCD1D 16r4352 16rCD24 16r4353 16rCD28 16r4354 16rCD2C 16r4355 16rCD39 16r4356 16rCD5C 16r4357 16rCD60 16r4358 16rCD64 16r4359 16rCD6C 16r435A 16rCD6D 16r435B 16rCD6F 16r435C 16rCD71 16r435D 16rCD78 16r435E 16rCD88 16r435F 16rCD94 16r4360 16rCD95 16r4361 16rCD98 16r4362 16rCD9C 16r4363 16rCDA4 16r4364 16rCDA5 16r4365 16rCDA7 16r4366 16rCDA9 16r4367 16rCDB0 16r4368 16rCDC4 16r4369 16rCDCC 16r436A 16rCDD0 16r436B 16rCDE8 16r436C 16rCDEC 16r436D 16rCDF0 16r436E 16rCDF8 16r436F 16rCDF9 16r4370 16rCDFB 16r4371 16rCDFD 16r4372 16rCE04 16r4373 16rCE08 16r4374 16rCE0C 16r4375 16rCE14 16r4376 16rCE19 16r4377 16rCE20 16r4378 16rCE21 16r4379 16rCE24 16r437A 16rCE28 16r437B 16rCE30 16r437C 16rCE31 16r437D 16rCE33 16r437E 16rCE35 16r4421 16rCE58 16r4422 16rCE59 16r4423 16rCE5C 16r4424 16rCE5F 16r4425 16rCE60 16r4426 16rCE61 16r4427 16rCE68 16r4428 16rCE69 16r4429 16rCE6B 16r442A 16rCE6D 16r442B 16rCE74 16r442C 16rCE75 16r442D 16rCE78 16r442E 16rCE7C 16r442F 16rCE84 16r4430 16rCE85 16r4431 16rCE87 16r4432 16rCE89 16r4433 16rCE90 16r4434 16rCE91 16r4435 16rCE94 16r4436 16rCE98 16r4437 16rCEA0 16r4438 16rCEA1 16r4439 16rCEA3 16r443A 16rCEA4 16r443B 16rCEA5 16r443C 16rCEAC 16r443D 16rCEAD 16r443E 16rCEC1 16r443F 16rCEE4 16r4440 16rCEE5 16r4441 16rCEE8 16r4442 16rCEEB 16r4443 16rCEEC 16r4444 16rCEF4 16r4445 16rCEF5 16r4446 16rCEF7 16r4447 16rCEF8 16r4448 16rCEF9 16r4449 16rCF00 16r444A 16rCF01 16r444B 16rCF04 16r444C 16rCF08 16r444D 16rCF10 16r444E 16rCF11 16r444F 16rCF13 16r4450 16rCF15 16r4451 16rCF1C 16r4452 16rCF20 16r4453 16rCF24 16r4454 16rCF2C 16r4455 16rCF2D 16r4456 16rCF2F 16r4457 16rCF30 16r4458 16rCF31 16r4459 16rCF38 16r445A 16rCF54 16r445B 16rCF55 16r445C 16rCF58 16r445D 16rCF5C 16r445E 16rCF64 16r445F 16rCF65 16r4460 16rCF67 16r4461 16rCF69 16r4462 16rCF70 16r4463 16rCF71 16r4464 16rCF74 16r4465 16rCF78 16r4466 16rCF80 16r4467 16rCF85 16r4468 16rCF8C 16r4469 16rCFA1 16r446A 16rCFA8 16r446B 16rCFB0 16r446C 16rCFC4 16r446D 16rCFE0 16r446E 16rCFE1 16r446F 16rCFE4 16r4470 16rCFE8 16r4471 16rCFF0 16r4472 16rCFF1 16r4473 16rCFF3 16r4474 16rCFF5 16r4475 16rCFFC 16r4476 16rD000 16r4477 16rD004 16r4478 16rD011 16r4479 16rD018 16r447A 16rD02D 16r447B 16rD034 16r447C 16rD035 16r447D 16rD038 16r447E 16rD03C 16r4521 16rD044 16r4522 16rD045 16r4523 16rD047 16r4524 16rD049 16r4525 16rD050 16r4526 16rD054 16r4527 16rD058 16r4528 16rD060 16r4529 16rD06C 16r452A 16rD06D 16r452B 16rD070 16r452C 16rD074 16r452D 16rD07C 16r452E 16rD07D 16r452F 16rD081 16r4530 16rD0A4 16r4531 16rD0A5 16r4532 16rD0A8 16r4533 16rD0AC 16r4534 16rD0B4 16r4535 16rD0B5 16r4536 16rD0B7 16r4537 16rD0B9 16r4538 16rD0C0 16r4539 16rD0C1 16r453A 16rD0C4 16r453B 16rD0C8 16r453C 16rD0C9 16r453D 16rD0D0 16r453E 16rD0D1 16r453F 16rD0D3 16r4540 16rD0D4 16r4541 16rD0D5 16r4542 16rD0DC 16r4543 16rD0DD 16r4544 16rD0E0 16r4545 16rD0E4 16r4546 16rD0EC 16r4547 16rD0ED 16r4548 16rD0EF 16r4549 16rD0F0 16r454A 16rD0F1 16r454B 16rD0F8 16r454C 16rD10D 16r454D 16rD130 16r454E 16rD131 16r454F 16rD134 16r4550 16rD138 16r4551 16rD13A 16r4552 16rD140 16r4553 16rD141 16r4554 16rD143 16r4555 16rD144 16r4556 16rD145 16r4557 16rD14C 16r4558 16rD14D 16r4559 16rD150 16r455A 16rD154 16r455B 16rD15C 16r455C 16rD15D 16r455D 16rD15F 16r455E 16rD161 16r455F 16rD168 16r4560 16rD16C 16r4561 16rD17C 16r4562 16rD184 16r4563 16rD188 16r4564 16rD1A0 16r4565 16rD1A1 16r4566 16rD1A4 16r4567 16rD1A8 16r4568 16rD1B0 16r4569 16rD1B1 16r456A 16rD1B3 16r456B 16rD1B5 16r456C 16rD1BA 16r456D 16rD1BC 16r456E 16rD1C0 16r456F 16rD1D8 16r4570 16rD1F4 16r4571 16rD1F8 16r4572 16rD207 16r4573 16rD209 16r4574 16rD210 16r4575 16rD22C 16r4576 16rD22D 16r4577 16rD230 16r4578 16rD234 16r4579 16rD23C 16r457A 16rD23D 16r457B 16rD23F 16r457C 16rD241 16r457D 16rD248 16r457E 16rD25C 16r4621 16rD264 16r4622 16rD280 16r4623 16rD281 16r4624 16rD284 16r4625 16rD288 16r4626 16rD290 16r4627 16rD291 16r4628 16rD295 16r4629 16rD29C 16r462A 16rD2A0 16r462B 16rD2A4 16r462C 16rD2AC 16r462D 16rD2B1 16r462E 16rD2B8 16r462F 16rD2B9 16r4630 16rD2BC 16r4631 16rD2BF 16r4632 16rD2C0 16r4633 16rD2C2 16r4634 16rD2C8 16r4635 16rD2C9 16r4636 16rD2CB 16r4637 16rD2D4 16r4638 16rD2D8 16r4639 16rD2DC 16r463A 16rD2E4 16r463B 16rD2E5 16r463C 16rD2F0 16r463D 16rD2F1 16r463E 16rD2F4 16r463F 16rD2F8 16r4640 16rD300 16r4641 16rD301 16r4642 16rD303 16r4643 16rD305 16r4644 16rD30C 16r4645 16rD30D 16r4646 16rD30E 16r4647 16rD310 16r4648 16rD314 16r4649 16rD316 16r464A 16rD31C 16r464B 16rD31D 16r464C 16rD31F 16r464D 16rD320 16r464E 16rD321 16r464F 16rD325 16r4650 16rD328 16r4651 16rD329 16r4652 16rD32C 16r4653 16rD330 16r4654 16rD338 16r4655 16rD339 16r4656 16rD33B 16r4657 16rD33C 16r4658 16rD33D 16r4659 16rD344 16r465A 16rD345 16r465B 16rD37C 16r465C 16rD37D 16r465D 16rD380 16r465E 16rD384 16r465F 16rD38C 16r4660 16rD38D 16r4661 16rD38F 16r4662 16rD390 16r4663 16rD391 16r4664 16rD398 16r4665 16rD399 16r4666 16rD39C 16r4667 16rD3A0 16r4668 16rD3A8 16r4669 16rD3A9 16r466A 16rD3AB 16r466B 16rD3AD 16r466C 16rD3B4 16r466D 16rD3B8 16r466E 16rD3BC 16r466F 16rD3C4 16r4670 16rD3C5 16r4671 16rD3C8 16r4672 16rD3C9 16r4673 16rD3D0 16r4674 16rD3D8 16r4675 16rD3E1 16r4676 16rD3E3 16r4677 16rD3EC 16r4678 16rD3ED 16r4679 16rD3F0 16r467A 16rD3F4 16r467B 16rD3FC 16r467C 16rD3FD 16r467D 16rD3FF 16r467E 16rD401 16r4721 16rD408 16r4722 16rD41D 16r4723 16rD440 16r4724 16rD444 16r4725 16rD45C 16r4726 16rD460 16r4727 16rD464 16r4728 16rD46D 16r4729 16rD46F 16r472A 16rD478 16r472B 16rD479 16r472C 16rD47C 16r472D 16rD47F 16r472E 16rD480 16r472F 16rD482 16r4730 16rD488 16r4731 16rD489 16r4732 16rD48B 16r4733 16rD48D 16r4734 16rD494 16r4735 16rD4A9 16r4736 16rD4CC 16r4737 16rD4D0 16r4738 16rD4D4 16r4739 16rD4DC 16r473A 16rD4DF 16r473B 16rD4E8 16r473C 16rD4EC 16r473D 16rD4F0 16r473E 16rD4F8 16r473F 16rD4FB 16r4740 16rD4FD 16r4741 16rD504 16r4742 16rD508 16r4743 16rD50C 16r4744 16rD514 16r4745 16rD515 16r4746 16rD517 16r4747 16rD53C 16r4748 16rD53D 16r4749 16rD540 16r474A 16rD544 16r474B 16rD54C 16r474C 16rD54D 16r474D 16rD54F 16r474E 16rD551 16r474F 16rD558 16r4750 16rD559 16r4751 16rD55C 16r4752 16rD560 16r4753 16rD565 16r4754 16rD568 16r4755 16rD569 16r4756 16rD56B 16r4757 16rD56D 16r4758 16rD574 16r4759 16rD575 16r475A 16rD578 16r475B 16rD57C 16r475C 16rD584 16r475D 16rD585 16r475E 16rD587 16r475F 16rD588 16r4760 16rD589 16r4761 16rD590 16r4762 16rD5A5 16r4763 16rD5C8 16r4764 16rD5C9 16r4765 16rD5CC 16r4766 16rD5D0 16r4767 16rD5D2 16r4768 16rD5D8 16r4769 16rD5D9 16r476A 16rD5DB 16r476B 16rD5DD 16r476C 16rD5E4 16r476D 16rD5E5 16r476E 16rD5E8 16r476F 16rD5EC 16r4770 16rD5F4 16r4771 16rD5F5 16r4772 16rD5F7 16r4773 16rD5F9 16r4774 16rD600 16r4775 16rD601 16r4776 16rD604 16r4777 16rD608 16r4778 16rD610 16r4779 16rD611 16r477A 16rD613 16r477B 16rD614 16r477C 16rD615 16r477D 16rD61C 16r477E 16rD620 16r4821 16rD624 16r4822 16rD62D 16r4823 16rD638 16r4824 16rD639 16r4825 16rD63C 16r4826 16rD640 16r4827 16rD645 16r4828 16rD648 16r4829 16rD649 16r482A 16rD64B 16r482B 16rD64D 16r482C 16rD651 16r482D 16rD654 16r482E 16rD655 16r482F 16rD658 16r4830 16rD65C 16r4831 16rD667 16r4832 16rD669 16r4833 16rD670 16r4834 16rD671 16r4835 16rD674 16r4836 16rD683 16r4837 16rD685 16r4838 16rD68C 16r4839 16rD68D 16r483A 16rD690 16r483B 16rD694 16r483C 16rD69D 16r483D 16rD69F 16r483E 16rD6A1 16r483F 16rD6A8 16r4840 16rD6AC 16r4841 16rD6B0 16r4842 16rD6B9 16r4843 16rD6BB 16r4844 16rD6C4 16r4845 16rD6C5 16r4846 16rD6C8 16r4847 16rD6CC 16r4848 16rD6D1 16r4849 16rD6D4 16r484A 16rD6D7 16r484B 16rD6D9 16r484C 16rD6E0 16r484D 16rD6E4 16r484E 16rD6E8 16r484F 16rD6F0 16r4850 16rD6F5 16r4851 16rD6FC 16r4852 16rD6FD 16r4853 16rD700 16r4854 16rD704 16r4855 16rD711 16r4856 16rD718 16r4857 16rD719 16r4858 16rD71C 16r4859 16rD720 16r485A 16rD728 16r485B 16rD729 16r485C 16rD72B 16r485D 16rD72D 16r485E 16rD734 16r485F 16rD735 16r4860 16rD738 16r4861 16rD73C 16r4862 16rD744 16r4863 16rD747 16r4864 16rD749 16r4865 16rD750 16r4866 16rD751 16r4867 16rD754 16r4868 16rD756 16r4869 16rD757 16r486A 16rD758 16r486B 16rD759 16r486C 16rD760 16r486D 16rD761 16r486E 16rD763 16r486F 16rD765 16r4870 16rD769 16r4871 16rD76C 16r4872 16rD770 16r4873 16rD774 16r4874 16rD77C 16r4875 16rD77D 16r4876 16rD781 16r4877 16rD788 16r4878 16rD789 16r4879 16rD78C 16r487A 16rD790 16r487B 16rD798 16r487C 16rD799 16r487D 16rD79B 16r487E 16rD79D 16r4A21 16r4F3D 16r4A22 16r4F73 16r4A23 16r5047 16r4A24 16r50F9 16r4A25 16r52A0 16r4A26 16r53EF 16r4A27 16r5475 16r4A28 16r54E5 16r4A29 16r5609 16r4A2A 16r5AC1 16r4A2B 16r5BB6 16r4A2C 16r6687 16r4A2D 16r67B6 16r4A2E 16r67B7 16r4A2F 16r67EF 16r4A30 16r6B4C 16r4A31 16r73C2 16r4A32 16r75C2 16r4A33 16r7A3C 16r4A34 16r82DB 16r4A35 16r8304 16r4A36 16r8857 16r4A37 16r8888 16r4A38 16r8A36 16r4A39 16r8CC8 16r4A3A 16r8DCF 16r4A3B 16r8EFB 16r4A3C 16r8FE6 16r4A3D 16r99D5 16r4A3E 16r523B 16r4A3F 16r5374 16r4A40 16r5404 16r4A41 16r606A 16r4A42 16r6164 16r4A43 16r6BBC 16r4A44 16r73CF 16r4A45 16r811A 16r4A46 16r89BA 16r4A47 16r89D2 16r4A48 16r95A3 16r4A49 16r4F83 16r4A4A 16r520A 16r4A4B 16r58BE 16r4A4C 16r5978 16r4A4D 16r59E6 16r4A4E 16r5E72 16r4A4F 16r5E79 16r4A50 16r61C7 16r4A51 16r63C0 16r4A52 16r6746 16r4A53 16r67EC 16r4A54 16r687F 16r4A55 16r6F97 16r4A56 16r764E 16r4A57 16r770B 16r4A58 16r78F5 16r4A59 16r7A08 16r4A5A 16r7AFF 16r4A5B 16r7C21 16r4A5C 16r809D 16r4A5D 16r826E 16r4A5E 16r8271 16r4A5F 16r8AEB 16r4A60 16r9593 16r4A61 16r4E6B 16r4A62 16r559D 16r4A63 16r66F7 16r4A64 16r6E34 16r4A65 16r78A3 16r4A66 16r7AED 16r4A67 16r845B 16r4A68 16r8910 16r4A69 16r874E 16r4A6A 16r97A8 16r4A6B 16r52D8 16r4A6C 16r574E 16r4A6D 16r582A 16r4A6E 16r5D4C 16r4A6F 16r611F 16r4A70 16r61BE 16r4A71 16r6221 16r4A72 16r6562 16r4A73 16r67D1 16r4A74 16r6A44 16r4A75 16r6E1B 16r4A76 16r7518 16r4A77 16r75B3 16r4A78 16r76E3 16r4A79 16r77B0 16r4A7A 16r7D3A 16r4A7B 16r90AF 16r4A7C 16r9451 16r4A7D 16r9452 16r4A7E 16r9F95 16r4B21 16r5323 16r4B22 16r5CAC 16r4B23 16r7532 16r4B24 16r80DB 16r4B25 16r9240 16r4B26 16r9598 16r4B27 16r525B 16r4B28 16r5808 16r4B29 16r59DC 16r4B2A 16r5CA1 16r4B2B 16r5D17 16r4B2C 16r5EB7 16r4B2D 16r5F3A 16r4B2E 16r5F4A 16r4B2F 16r6177 16r4B30 16r6C5F 16r4B31 16r757A 16r4B32 16r7586 16r4B33 16r7CE0 16r4B34 16r7D73 16r4B35 16r7DB1 16r4B36 16r7F8C 16r4B37 16r8154 16r4B38 16r8221 16r4B39 16r8591 16r4B3A 16r8941 16r4B3B 16r8B1B 16r4B3C 16r92FC 16r4B3D 16r964D 16r4B3E 16r9C47 16r4B3F 16r4ECB 16r4B40 16r4EF7 16r4B41 16r500B 16r4B42 16r51F1 16r4B43 16r584F 16r4B44 16r6137 16r4B45 16r613E 16r4B46 16r6168 16r4B47 16r6539 16r4B48 16r69EA 16r4B49 16r6F11 16r4B4A 16r75A5 16r4B4B 16r7686 16r4B4C 16r76D6 16r4B4D 16r7B87 16r4B4E 16r82A5 16r4B4F 16r84CB 16r4B50 16rF900 16r4B51 16r93A7 16r4B52 16r958B 16r4B53 16r5580 16r4B54 16r5BA2 16r4B55 16r5751 16r4B56 16rF901 16r4B57 16r7CB3 16r4B58 16r7FB9 16r4B59 16r91B5 16r4B5A 16r5028 16r4B5B 16r53BB 16r4B5C 16r5C45 16r4B5D 16r5DE8 16r4B5E 16r62D2 16r4B5F 16r636E 16r4B60 16r64DA 16r4B61 16r64E7 16r4B62 16r6E20 16r4B63 16r70AC 16r4B64 16r795B 16r4B65 16r8DDD 16r4B66 16r8E1E 16r4B67 16rF902 16r4B68 16r907D 16r4B69 16r9245 16r4B6A 16r92F8 16r4B6B 16r4E7E 16r4B6C 16r4EF6 16r4B6D 16r5065 16r4B6E 16r5DFE 16r4B6F 16r5EFA 16r4B70 16r6106 16r4B71 16r6957 16r4B72 16r8171 16r4B73 16r8654 16r4B74 16r8E47 16r4B75 16r9375 16r4B76 16r9A2B 16r4B77 16r4E5E 16r4B78 16r5091 16r4B79 16r6770 16r4B7A 16r6840 16r4B7B 16r5109 16r4B7C 16r528D 16r4B7D 16r5292 16r4B7E 16r6AA2 16r4C21 16r77BC 16r4C22 16r9210 16r4C23 16r9ED4 16r4C24 16r52AB 16r4C25 16r602F 16r4C26 16r8FF2 16r4C27 16r5048 16r4C28 16r61A9 16r4C29 16r63ED 16r4C2A 16r64CA 16r4C2B 16r683C 16r4C2C 16r6A84 16r4C2D 16r6FC0 16r4C2E 16r8188 16r4C2F 16r89A1 16r4C30 16r9694 16r4C31 16r5805 16r4C32 16r727D 16r4C33 16r72AC 16r4C34 16r7504 16r4C35 16r7D79 16r4C36 16r7E6D 16r4C37 16r80A9 16r4C38 16r898B 16r4C39 16r8B74 16r4C3A 16r9063 16r4C3B 16r9D51 16r4C3C 16r6289 16r4C3D 16r6C7A 16r4C3E 16r6F54 16r4C3F 16r7D50 16r4C40 16r7F3A 16r4C41 16r8A23 16r4C42 16r517C 16r4C43 16r614A 16r4C44 16r7B9D 16r4C45 16r8B19 16r4C46 16r9257 16r4C47 16r938C 16r4C48 16r4EAC 16r4C49 16r4FD3 16r4C4A 16r501E 16r4C4B 16r50BE 16r4C4C 16r5106 16r4C4D 16r52C1 16r4C4E 16r52CD 16r4C4F 16r537F 16r4C50 16r5770 16r4C51 16r5883 16r4C52 16r5E9A 16r4C53 16r5F91 16r4C54 16r6176 16r4C55 16r61AC 16r4C56 16r64CE 16r4C57 16r656C 16r4C58 16r666F 16r4C59 16r66BB 16r4C5A 16r66F4 16r4C5B 16r6897 16r4C5C 16r6D87 16r4C5D 16r7085 16r4C5E 16r70F1 16r4C5F 16r749F 16r4C60 16r74A5 16r4C61 16r74CA 16r4C62 16r75D9 16r4C63 16r786C 16r4C64 16r78EC 16r4C65 16r7ADF 16r4C66 16r7AF6 16r4C67 16r7D45 16r4C68 16r7D93 16r4C69 16r8015 16r4C6A 16r803F 16r4C6B 16r811B 16r4C6C 16r8396 16r4C6D 16r8B66 16r4C6E 16r8F15 16r4C6F 16r9015 16r4C70 16r93E1 16r4C71 16r9803 16r4C72 16r9838 16r4C73 16r9A5A 16r4C74 16r9BE8 16r4C75 16r4FC2 16r4C76 16r5553 16r4C77 16r583A 16r4C78 16r5951 16r4C79 16r5B63 16r4C7A 16r5C46 16r4C7B 16r60B8 16r4C7C 16r6212 16r4C7D 16r6842 16r4C7E 16r68B0 16r4D21 16r68E8 16r4D22 16r6EAA 16r4D23 16r754C 16r4D24 16r7678 16r4D25 16r78CE 16r4D26 16r7A3D 16r4D27 16r7CFB 16r4D28 16r7E6B 16r4D29 16r7E7C 16r4D2A 16r8A08 16r4D2B 16r8AA1 16r4D2C 16r8C3F 16r4D2D 16r968E 16r4D2E 16r9DC4 16r4D2F 16r53E4 16r4D30 16r53E9 16r4D31 16r544A 16r4D32 16r5471 16r4D33 16r56FA 16r4D34 16r59D1 16r4D35 16r5B64 16r4D36 16r5C3B 16r4D37 16r5EAB 16r4D38 16r62F7 16r4D39 16r6537 16r4D3A 16r6545 16r4D3B 16r6572 16r4D3C 16r66A0 16r4D3D 16r67AF 16r4D3E 16r69C1 16r4D3F 16r6CBD 16r4D40 16r75FC 16r4D41 16r7690 16r4D42 16r777E 16r4D43 16r7A3F 16r4D44 16r7F94 16r4D45 16r8003 16r4D46 16r80A1 16r4D47 16r818F 16r4D48 16r82E6 16r4D49 16r82FD 16r4D4A 16r83F0 16r4D4B 16r85C1 16r4D4C 16r8831 16r4D4D 16r88B4 16r4D4E 16r8AA5 16r4D4F 16rF903 16r4D50 16r8F9C 16r4D51 16r932E 16r4D52 16r96C7 16r4D53 16r9867 16r4D54 16r9AD8 16r4D55 16r9F13 16r4D56 16r54ED 16r4D57 16r659B 16r4D58 16r66F2 16r4D59 16r688F 16r4D5A 16r7A40 16r4D5B 16r8C37 16r4D5C 16r9D60 16r4D5D 16r56F0 16r4D5E 16r5764 16r4D5F 16r5D11 16r4D60 16r6606 16r4D61 16r68B1 16r4D62 16r68CD 16r4D63 16r6EFE 16r4D64 16r7428 16r4D65 16r889E 16r4D66 16r9BE4 16r4D67 16r6C68 16r4D68 16rF904 16r4D69 16r9AA8 16r4D6A 16r4F9B 16r4D6B 16r516C 16r4D6C 16r5171 16r4D6D 16r529F 16r4D6E 16r5B54 16r4D6F 16r5DE5 16r4D70 16r6050 16r4D71 16r606D 16r4D72 16r62F1 16r4D73 16r63A7 16r4D74 16r653B 16r4D75 16r73D9 16r4D76 16r7A7A 16r4D77 16r86A3 16r4D78 16r8CA2 16r4D79 16r978F 16r4D7A 16r4E32 16r4D7B 16r5BE1 16r4D7C 16r6208 16r4D7D 16r679C 16r4D7E 16r74DC 16r4E21 16r79D1 16r4E22 16r83D3 16r4E23 16r8A87 16r4E24 16r8AB2 16r4E25 16r8DE8 16r4E26 16r904E 16r4E27 16r934B 16r4E28 16r9846 16r4E29 16r5ED3 16r4E2A 16r69E8 16r4E2B 16r85FF 16r4E2C 16r90ED 16r4E2D 16rF905 16r4E2E 16r51A0 16r4E2F 16r5B98 16r4E30 16r5BEC 16r4E31 16r6163 16r4E32 16r68FA 16r4E33 16r6B3E 16r4E34 16r704C 16r4E35 16r742F 16r4E36 16r74D8 16r4E37 16r7BA1 16r4E38 16r7F50 16r4E39 16r83C5 16r4E3A 16r89C0 16r4E3B 16r8CAB 16r4E3C 16r95DC 16r4E3D 16r9928 16r4E3E 16r522E 16r4E3F 16r605D 16r4E40 16r62EC 16r4E41 16r9002 16r4E42 16r4F8A 16r4E43 16r5149 16r4E44 16r5321 16r4E45 16r58D9 16r4E46 16r5EE3 16r4E47 16r66E0 16r4E48 16r6D38 16r4E49 16r709A 16r4E4A 16r72C2 16r4E4B 16r73D6 16r4E4C 16r7B50 16r4E4D 16r80F1 16r4E4E 16r945B 16r4E4F 16r5366 16r4E50 16r639B 16r4E51 16r7F6B 16r4E52 16r4E56 16r4E53 16r5080 16r4E54 16r584A 16r4E55 16r58DE 16r4E56 16r602A 16r4E57 16r6127 16r4E58 16r62D0 16r4E59 16r69D0 16r4E5A 16r9B41 16r4E5B 16r5B8F 16r4E5C 16r7D18 16r4E5D 16r80B1 16r4E5E 16r8F5F 16r4E5F 16r4EA4 16r4E60 16r50D1 16r4E61 16r54AC 16r4E62 16r55AC 16r4E63 16r5B0C 16r4E64 16r5DA0 16r4E65 16r5DE7 16r4E66 16r652A 16r4E67 16r654E 16r4E68 16r6821 16r4E69 16r6A4B 16r4E6A 16r72E1 16r4E6B 16r768E 16r4E6C 16r77EF 16r4E6D 16r7D5E 16r4E6E 16r7FF9 16r4E6F 16r81A0 16r4E70 16r854E 16r4E71 16r86DF 16r4E72 16r8F03 16r4E73 16r8F4E 16r4E74 16r90CA 16r4E75 16r9903 16r4E76 16r9A55 16r4E77 16r9BAB 16r4E78 16r4E18 16r4E79 16r4E45 16r4E7A 16r4E5D 16r4E7B 16r4EC7 16r4E7C 16r4FF1 16r4E7D 16r5177 16r4E7E 16r52FE 16r4F21 16r5340 16r4F22 16r53E3 16r4F23 16r53E5 16r4F24 16r548E 16r4F25 16r5614 16r4F26 16r5775 16r4F27 16r57A2 16r4F28 16r5BC7 16r4F29 16r5D87 16r4F2A 16r5ED0 16r4F2B 16r61FC 16r4F2C 16r62D8 16r4F2D 16r6551 16r4F2E 16r67B8 16r4F2F 16r67E9 16r4F30 16r69CB 16r4F31 16r6B50 16r4F32 16r6BC6 16r4F33 16r6BEC 16r4F34 16r6C42 16r4F35 16r6E9D 16r4F36 16r7078 16r4F37 16r72D7 16r4F38 16r7396 16r4F39 16r7403 16r4F3A 16r77BF 16r4F3B 16r77E9 16r4F3C 16r7A76 16r4F3D 16r7D7F 16r4F3E 16r8009 16r4F3F 16r81FC 16r4F40 16r8205 16r4F41 16r820A 16r4F42 16r82DF 16r4F43 16r8862 16r4F44 16r8B33 16r4F45 16r8CFC 16r4F46 16r8EC0 16r4F47 16r9011 16r4F48 16r90B1 16r4F49 16r9264 16r4F4A 16r92B6 16r4F4B 16r99D2 16r4F4C 16r9A45 16r4F4D 16r9CE9 16r4F4E 16r9DD7 16r4F4F 16r9F9C 16r4F50 16r570B 16r4F51 16r5C40 16r4F52 16r83CA 16r4F53 16r97A0 16r4F54 16r97AB 16r4F55 16r9EB4 16r4F56 16r541B 16r4F57 16r7A98 16r4F58 16r7FA4 16r4F59 16r88D9 16r4F5A 16r8ECD 16r4F5B 16r90E1 16r4F5C 16r5800 16r4F5D 16r5C48 16r4F5E 16r6398 16r4F5F 16r7A9F 16r4F60 16r5BAE 16r4F61 16r5F13 16r4F62 16r7A79 16r4F63 16r7AAE 16r4F64 16r828E 16r4F65 16r8EAC 16r4F66 16r5026 16r4F67 16r5238 16r4F68 16r52F8 16r4F69 16r5377 16r4F6A 16r5708 16r4F6B 16r62F3 16r4F6C 16r6372 16r4F6D 16r6B0A 16r4F6E 16r6DC3 16r4F6F 16r7737 16r4F70 16r53A5 16r4F71 16r7357 16r4F72 16r8568 16r4F73 16r8E76 16r4F74 16r95D5 16r4F75 16r673A 16r4F76 16r6AC3 16r4F77 16r6F70 16r4F78 16r8A6D 16r4F79 16r8ECC 16r4F7A 16r994B 16r4F7B 16rF906 16r4F7C 16r6677 16r4F7D 16r6B78 16r4F7E 16r8CB4 16r5021 16r9B3C 16r5022 16rF907 16r5023 16r53EB 16r5024 16r572D 16r5025 16r594E 16r5026 16r63C6 16r5027 16r69FB 16r5028 16r73EA 16r5029 16r7845 16r502A 16r7ABA 16r502B 16r7AC5 16r502C 16r7CFE 16r502D 16r8475 16r502E 16r898F 16r502F 16r8D73 16r5030 16r9035 16r5031 16r95A8 16r5032 16r52FB 16r5033 16r5747 16r5034 16r7547 16r5035 16r7B60 16r5036 16r83CC 16r5037 16r921E 16r5038 16rF908 16r5039 16r6A58 16r503A 16r514B 16r503B 16r524B 16r503C 16r5287 16r503D 16r621F 16r503E 16r68D8 16r503F 16r6975 16r5040 16r9699 16r5041 16r50C5 16r5042 16r52A4 16r5043 16r52E4 16r5044 16r61C3 16r5045 16r65A4 16r5046 16r6839 16r5047 16r69FF 16r5048 16r747E 16r5049 16r7B4B 16r504A 16r82B9 16r504B 16r83EB 16r504C 16r89B2 16r504D 16r8B39 16r504E 16r8FD1 16r504F 16r9949 16r5050 16rF909 16r5051 16r4ECA 16r5052 16r5997 16r5053 16r64D2 16r5054 16r6611 16r5055 16r6A8E 16r5056 16r7434 16r5057 16r7981 16r5058 16r79BD 16r5059 16r82A9 16r505A 16r887E 16r505B 16r887F 16r505C 16r895F 16r505D 16rF90A 16r505E 16r9326 16r505F 16r4F0B 16r5060 16r53CA 16r5061 16r6025 16r5062 16r6271 16r5063 16r6C72 16r5064 16r7D1A 16r5065 16r7D66 16r5066 16r4E98 16r5067 16r5162 16r5068 16r77DC 16r5069 16r80AF 16r506A 16r4F01 16r506B 16r4F0E 16r506C 16r5176 16r506D 16r5180 16r506E 16r55DC 16r506F 16r5668 16r5070 16r573B 16r5071 16r57FA 16r5072 16r57FC 16r5073 16r5914 16r5074 16r5947 16r5075 16r5993 16r5076 16r5BC4 16r5077 16r5C90 16r5078 16r5D0E 16r5079 16r5DF1 16r507A 16r5E7E 16r507B 16r5FCC 16r507C 16r6280 16r507D 16r65D7 16r507E 16r65E3 16r5121 16r671E 16r5122 16r671F 16r5123 16r675E 16r5124 16r68CB 16r5125 16r68C4 16r5126 16r6A5F 16r5127 16r6B3A 16r5128 16r6C23 16r5129 16r6C7D 16r512A 16r6C82 16r512B 16r6DC7 16r512C 16r7398 16r512D 16r7426 16r512E 16r742A 16r512F 16r7482 16r5130 16r74A3 16r5131 16r7578 16r5132 16r757F 16r5133 16r7881 16r5134 16r78EF 16r5135 16r7941 16r5136 16r7947 16r5137 16r7948 16r5138 16r797A 16r5139 16r7B95 16r513A 16r7D00 16r513B 16r7DBA 16r513C 16r7F88 16r513D 16r8006 16r513E 16r802D 16r513F 16r808C 16r5140 16r8A18 16r5141 16r8B4F 16r5142 16r8C48 16r5143 16r8D77 16r5144 16r9321 16r5145 16r9324 16r5146 16r98E2 16r5147 16r9951 16r5148 16r9A0E 16r5149 16r9A0F 16r514A 16r9A65 16r514B 16r9E92 16r514C 16r7DCA 16r514D 16r4F76 16r514E 16r5409 16r514F 16r62EE 16r5150 16r6854 16r5151 16r91D1 16r5152 16r55AB 16r5153 16r513A 16r5154 16rF90B 16r5155 16rF90C 16r5156 16r5A1C 16r5157 16r61E6 16r5158 16rF90D 16r5159 16r62CF 16r515A 16r62FF 16r515B 16rF90E 16r515C 16rF90F 16r515D 16rF910 16r515E 16rF911 16r515F 16rF912 16r5160 16rF913 16r5161 16r90A3 16r5162 16rF914 16r5163 16rF915 16r5164 16rF916 16r5165 16rF917 16r5166 16rF918 16r5167 16r8AFE 16r5168 16rF919 16r5169 16rF91A 16r516A 16rF91B 16r516B 16rF91C 16r516C 16r6696 16r516D 16rF91D 16r516E 16r7156 16r516F 16rF91E 16r5170 16rF91F 16r5171 16r96E3 16r5172 16rF920 16r5173 16r634F 16r5174 16r637A 16r5175 16r5357 16r5176 16rF921 16r5177 16r678F 16r5178 16r6960 16r5179 16r6E73 16r517A 16rF922 16r517B 16r7537 16r517C 16rF923 16r517D 16rF924 16r517E 16rF925 16r5221 16r7D0D 16r5222 16rF926 16r5223 16rF927 16r5224 16r8872 16r5225 16r56CA 16r5226 16r5A18 16r5227 16rF928 16r5228 16rF929 16r5229 16rF92A 16r522A 16rF92B 16r522B 16rF92C 16r522C 16r4E43 16r522D 16rF92D 16r522E 16r5167 16r522F 16r5948 16r5230 16r67F0 16r5231 16r8010 16r5232 16rF92E 16r5233 16r5973 16r5234 16r5E74 16r5235 16r649A 16r5236 16r79CA 16r5237 16r5FF5 16r5238 16r606C 16r5239 16r62C8 16r523A 16r637B 16r523B 16r5BE7 16r523C 16r5BD7 16r523D 16r52AA 16r523E 16rF92F 16r523F 16r5974 16r5240 16r5F29 16r5241 16r6012 16r5242 16rF930 16r5243 16rF931 16r5244 16rF932 16r5245 16r7459 16r5246 16rF933 16r5247 16rF934 16r5248 16rF935 16r5249 16rF936 16r524A 16rF937 16r524B 16rF938 16r524C 16r99D1 16r524D 16rF939 16r524E 16rF93A 16r524F 16rF93B 16r5250 16rF93C 16r5251 16rF93D 16r5252 16rF93E 16r5253 16rF93F 16r5254 16rF940 16r5255 16rF941 16r5256 16rF942 16r5257 16rF943 16r5258 16r6FC3 16r5259 16rF944 16r525A 16rF945 16r525B 16r81BF 16r525C 16r8FB2 16r525D 16r60F1 16r525E 16rF946 16r525F 16rF947 16r5260 16r8166 16r5261 16rF948 16r5262 16rF949 16r5263 16r5C3F 16r5264 16rF94A 16r5265 16rF94B 16r5266 16rF94C 16r5267 16rF94D 16r5268 16rF94E 16r5269 16rF94F 16r526A 16rF950 16r526B 16rF951 16r526C 16r5AE9 16r526D 16r8A25 16r526E 16r677B 16r526F 16r7D10 16r5270 16rF952 16r5271 16rF953 16r5272 16rF954 16r5273 16rF955 16r5274 16rF956 16r5275 16rF957 16r5276 16r80FD 16r5277 16rF958 16r5278 16rF959 16r5279 16r5C3C 16r527A 16r6CE5 16r527B 16r533F 16r527C 16r6EBA 16r527D 16r591A 16r527E 16r8336 16r5321 16r4E39 16r5322 16r4EB6 16r5323 16r4F46 16r5324 16r55AE 16r5325 16r5718 16r5326 16r58C7 16r5327 16r5F56 16r5328 16r65B7 16r5329 16r65E6 16r532A 16r6A80 16r532B 16r6BB5 16r532C 16r6E4D 16r532D 16r77ED 16r532E 16r7AEF 16r532F 16r7C1E 16r5330 16r7DDE 16r5331 16r86CB 16r5332 16r8892 16r5333 16r9132 16r5334 16r935B 16r5335 16r64BB 16r5336 16r6FBE 16r5337 16r737A 16r5338 16r75B8 16r5339 16r9054 16r533A 16r5556 16r533B 16r574D 16r533C 16r61BA 16r533D 16r64D4 16r533E 16r66C7 16r533F 16r6DE1 16r5340 16r6E5B 16r5341 16r6F6D 16r5342 16r6FB9 16r5343 16r75F0 16r5344 16r8043 16r5345 16r81BD 16r5346 16r8541 16r5347 16r8983 16r5348 16r8AC7 16r5349 16r8B5A 16r534A 16r931F 16r534B 16r6C93 16r534C 16r7553 16r534D 16r7B54 16r534E 16r8E0F 16r534F 16r905D 16r5350 16r5510 16r5351 16r5802 16r5352 16r5858 16r5353 16r5E62 16r5354 16r6207 16r5355 16r649E 16r5356 16r68E0 16r5357 16r7576 16r5358 16r7CD6 16r5359 16r87B3 16r535A 16r9EE8 16r535B 16r4EE3 16r535C 16r5788 16r535D 16r576E 16r535E 16r5927 16r535F 16r5C0D 16r5360 16r5CB1 16r5361 16r5E36 16r5362 16r5F85 16r5363 16r6234 16r5364 16r64E1 16r5365 16r73B3 16r5366 16r81FA 16r5367 16r888B 16r5368 16r8CB8 16r5369 16r968A 16r536A 16r9EDB 16r536B 16r5B85 16r536C 16r5FB7 16r536D 16r60B3 16r536E 16r5012 16r536F 16r5200 16r5370 16r5230 16r5371 16r5716 16r5372 16r5835 16r5373 16r5857 16r5374 16r5C0E 16r5375 16r5C60 16r5376 16r5CF6 16r5377 16r5D8B 16r5378 16r5EA6 16r5379 16r5F92 16r537A 16r60BC 16r537B 16r6311 16r537C 16r6389 16r537D 16r6417 16r537E 16r6843 16r5421 16r68F9 16r5422 16r6AC2 16r5423 16r6DD8 16r5424 16r6E21 16r5425 16r6ED4 16r5426 16r6FE4 16r5427 16r71FE 16r5428 16r76DC 16r5429 16r7779 16r542A 16r79B1 16r542B 16r7A3B 16r542C 16r8404 16r542D 16r89A9 16r542E 16r8CED 16r542F 16r8DF3 16r5430 16r8E48 16r5431 16r9003 16r5432 16r9014 16r5433 16r9053 16r5434 16r90FD 16r5435 16r934D 16r5436 16r9676 16r5437 16r97DC 16r5438 16r6BD2 16r5439 16r7006 16r543A 16r7258 16r543B 16r72A2 16r543C 16r7368 16r543D 16r7763 16r543E 16r79BF 16r543F 16r7BE4 16r5440 16r7E9B 16r5441 16r8B80 16r5442 16r58A9 16r5443 16r60C7 16r5444 16r6566 16r5445 16r65FD 16r5446 16r66BE 16r5447 16r6C8C 16r5448 16r711E 16r5449 16r71C9 16r544A 16r8C5A 16r544B 16r9813 16r544C 16r4E6D 16r544D 16r7A81 16r544E 16r4EDD 16r544F 16r51AC 16r5450 16r51CD 16r5451 16r52D5 16r5452 16r540C 16r5453 16r61A7 16r5454 16r6771 16r5455 16r6850 16r5456 16r68DF 16r5457 16r6D1E 16r5458 16r6F7C 16r5459 16r75BC 16r545A 16r77B3 16r545B 16r7AE5 16r545C 16r80F4 16r545D 16r8463 16r545E 16r9285 16r545F 16r515C 16r5460 16r6597 16r5461 16r675C 16r5462 16r6793 16r5463 16r75D8 16r5464 16r7AC7 16r5465 16r8373 16r5466 16rF95A 16r5467 16r8C46 16r5468 16r9017 16r5469 16r982D 16r546A 16r5C6F 16r546B 16r81C0 16r546C 16r829A 16r546D 16r9041 16r546E 16r906F 16r546F 16r920D 16r5470 16r5F97 16r5471 16r5D9D 16r5472 16r6A59 16r5473 16r71C8 16r5474 16r767B 16r5475 16r7B49 16r5476 16r85E4 16r5477 16r8B04 16r5478 16r9127 16r5479 16r9A30 16r547A 16r5587 16r547B 16r61F6 16r547C 16rF95B 16r547D 16r7669 16r547E 16r7F85 16r5521 16r863F 16r5522 16r87BA 16r5523 16r88F8 16r5524 16r908F 16r5525 16rF95C 16r5526 16r6D1B 16r5527 16r70D9 16r5528 16r73DE 16r5529 16r7D61 16r552A 16r843D 16r552B 16rF95D 16r552C 16r916A 16r552D 16r99F1 16r552E 16rF95E 16r552F 16r4E82 16r5530 16r5375 16r5531 16r6B04 16r5532 16r6B12 16r5533 16r703E 16r5534 16r721B 16r5535 16r862D 16r5536 16r9E1E 16r5537 16r524C 16r5538 16r8FA3 16r5539 16r5D50 16r553A 16r64E5 16r553B 16r652C 16r553C 16r6B16 16r553D 16r6FEB 16r553E 16r7C43 16r553F 16r7E9C 16r5540 16r85CD 16r5541 16r8964 16r5542 16r89BD 16r5543 16r62C9 16r5544 16r81D8 16r5545 16r881F 16r5546 16r5ECA 16r5547 16r6717 16r5548 16r6D6A 16r5549 16r72FC 16r554A 16r7405 16r554B 16r746F 16r554C 16r8782 16r554D 16r90DE 16r554E 16r4F86 16r554F 16r5D0D 16r5550 16r5FA0 16r5551 16r840A 16r5552 16r51B7 16r5553 16r63A0 16r5554 16r7565 16r5555 16r4EAE 16r5556 16r5006 16r5557 16r5169 16r5558 16r51C9 16r5559 16r6881 16r555A 16r6A11 16r555B 16r7CAE 16r555C 16r7CB1 16r555D 16r7CE7 16r555E 16r826F 16r555F 16r8AD2 16r5560 16r8F1B 16r5561 16r91CF 16r5562 16r4FB6 16r5563 16r5137 16r5564 16r52F5 16r5565 16r5442 16r5566 16r5EEC 16r5567 16r616E 16r5568 16r623E 16r5569 16r65C5 16r556A 16r6ADA 16r556B 16r6FFE 16r556C 16r792A 16r556D 16r85DC 16r556E 16r8823 16r556F 16r95AD 16r5570 16r9A62 16r5571 16r9A6A 16r5572 16r9E97 16r5573 16r9ECE 16r5574 16r529B 16r5575 16r66C6 16r5576 16r6B77 16r5577 16r701D 16r5578 16r792B 16r5579 16r8F62 16r557A 16r9742 16r557B 16r6190 16r557C 16r6200 16r557D 16r6523 16r557E 16r6F23 16r5621 16r7149 16r5622 16r7489 16r5623 16r7DF4 16r5624 16r806F 16r5625 16r84EE 16r5626 16r8F26 16r5627 16r9023 16r5628 16r934A 16r5629 16r51BD 16r562A 16r5217 16r562B 16r52A3 16r562C 16r6D0C 16r562D 16r70C8 16r562E 16r88C2 16r562F 16r5EC9 16r5630 16r6582 16r5631 16r6BAE 16r5632 16r6FC2 16r5633 16r7C3E 16r5634 16r7375 16r5635 16r4EE4 16r5636 16r4F36 16r5637 16r56F9 16r5638 16rF95F 16r5639 16r5CBA 16r563A 16r5DBA 16r563B 16r601C 16r563C 16r73B2 16r563D 16r7B2D 16r563E 16r7F9A 16r563F 16r7FCE 16r5640 16r8046 16r5641 16r901E 16r5642 16r9234 16r5643 16r96F6 16r5644 16r9748 16r5645 16r9818 16r5646 16r9F61 16r5647 16r4F8B 16r5648 16r6FA7 16r5649 16r79AE 16r564A 16r91B4 16r564B 16r96B7 16r564C 16r52DE 16r564D 16rF960 16r564E 16r6488 16r564F 16r64C4 16r5650 16r6AD3 16r5651 16r6F5E 16r5652 16r7018 16r5653 16r7210 16r5654 16r76E7 16r5655 16r8001 16r5656 16r8606 16r5657 16r865C 16r5658 16r8DEF 16r5659 16r8F05 16r565A 16r9732 16r565B 16r9B6F 16r565C 16r9DFA 16r565D 16r9E75 16r565E 16r788C 16r565F 16r797F 16r5660 16r7DA0 16r5661 16r83C9 16r5662 16r9304 16r5663 16r9E7F 16r5664 16r9E93 16r5665 16r8AD6 16r5666 16r58DF 16r5667 16r5F04 16r5668 16r6727 16r5669 16r7027 16r566A 16r74CF 16r566B 16r7C60 16r566C 16r807E 16r566D 16r5121 16r566E 16r7028 16r566F 16r7262 16r5670 16r78CA 16r5671 16r8CC2 16r5672 16r8CDA 16r5673 16r8CF4 16r5674 16r96F7 16r5675 16r4E86 16r5676 16r50DA 16r5677 16r5BEE 16r5678 16r5ED6 16r5679 16r6599 16r567A 16r71CE 16r567B 16r7642 16r567C 16r77AD 16r567D 16r804A 16r567E 16r84FC 16r5721 16r907C 16r5722 16r9B27 16r5723 16r9F8D 16r5724 16r58D8 16r5725 16r5A41 16r5726 16r5C62 16r5727 16r6A13 16r5728 16r6DDA 16r5729 16r6F0F 16r572A 16r763B 16r572B 16r7D2F 16r572C 16r7E37 16r572D 16r851E 16r572E 16r8938 16r572F 16r93E4 16r5730 16r964B 16r5731 16r5289 16r5732 16r65D2 16r5733 16r67F3 16r5734 16r69B4 16r5735 16r6D41 16r5736 16r6E9C 16r5737 16r700F 16r5738 16r7409 16r5739 16r7460 16r573A 16r7559 16r573B 16r7624 16r573C 16r786B 16r573D 16r8B2C 16r573E 16r985E 16r573F 16r516D 16r5740 16r622E 16r5741 16r9678 16r5742 16r4F96 16r5743 16r502B 16r5744 16r5D19 16r5745 16r6DEA 16r5746 16r7DB8 16r5747 16r8F2A 16r5748 16r5F8B 16r5749 16r6144 16r574A 16r6817 16r574B 16rF961 16r574C 16r9686 16r574D 16r52D2 16r574E 16r808B 16r574F 16r51DC 16r5750 16r51CC 16r5751 16r695E 16r5752 16r7A1C 16r5753 16r7DBE 16r5754 16r83F1 16r5755 16r9675 16r5756 16r4FDA 16r5757 16r5229 16r5758 16r5398 16r5759 16r540F 16r575A 16r550E 16r575B 16r5C65 16r575C 16r60A7 16r575D 16r674E 16r575E 16r68A8 16r575F 16r6D6C 16r5760 16r7281 16r5761 16r72F8 16r5762 16r7406 16r5763 16r7483 16r5764 16rF962 16r5765 16r75E2 16r5766 16r7C6C 16r5767 16r7F79 16r5768 16r7FB8 16r5769 16r8389 16r576A 16r88CF 16r576B 16r88E1 16r576C 16r91CC 16r576D 16r91D0 16r576E 16r96E2 16r576F 16r9BC9 16r5770 16r541D 16r5771 16r6F7E 16r5772 16r71D0 16r5773 16r7498 16r5774 16r85FA 16r5775 16r8EAA 16r5776 16r96A3 16r5777 16r9C57 16r5778 16r9E9F 16r5779 16r6797 16r577A 16r6DCB 16r577B 16r7433 16r577C 16r81E8 16r577D 16r9716 16r577E 16r782C 16r5821 16r7ACB 16r5822 16r7B20 16r5823 16r7C92 16r5824 16r6469 16r5825 16r746A 16r5826 16r75F2 16r5827 16r78BC 16r5828 16r78E8 16r5829 16r99AC 16r582A 16r9B54 16r582B 16r9EBB 16r582C 16r5BDE 16r582D 16r5E55 16r582E 16r6F20 16r582F 16r819C 16r5830 16r83AB 16r5831 16r9088 16r5832 16r4E07 16r5833 16r534D 16r5834 16r5A29 16r5835 16r5DD2 16r5836 16r5F4E 16r5837 16r6162 16r5838 16r633D 16r5839 16r6669 16r583A 16r66FC 16r583B 16r6EFF 16r583C 16r6F2B 16r583D 16r7063 16r583E 16r779E 16r583F 16r842C 16r5840 16r8513 16r5841 16r883B 16r5842 16r8F13 16r5843 16r9945 16r5844 16r9C3B 16r5845 16r551C 16r5846 16r62B9 16r5847 16r672B 16r5848 16r6CAB 16r5849 16r8309 16r584A 16r896A 16r584B 16r977A 16r584C 16r4EA1 16r584D 16r5984 16r584E 16r5FD8 16r584F 16r5FD9 16r5850 16r671B 16r5851 16r7DB2 16r5852 16r7F54 16r5853 16r8292 16r5854 16r832B 16r5855 16r83BD 16r5856 16r8F1E 16r5857 16r9099 16r5858 16r57CB 16r5859 16r59B9 16r585A 16r5A92 16r585B 16r5BD0 16r585C 16r6627 16r585D 16r679A 16r585E 16r6885 16r585F 16r6BCF 16r5860 16r7164 16r5861 16r7F75 16r5862 16r8CB7 16r5863 16r8CE3 16r5864 16r9081 16r5865 16r9B45 16r5866 16r8108 16r5867 16r8C8A 16r5868 16r964C 16r5869 16r9A40 16r586A 16r9EA5 16r586B 16r5B5F 16r586C 16r6C13 16r586D 16r731B 16r586E 16r76F2 16r586F 16r76DF 16r5870 16r840C 16r5871 16r51AA 16r5872 16r8993 16r5873 16r514D 16r5874 16r5195 16r5875 16r52C9 16r5876 16r68C9 16r5877 16r6C94 16r5878 16r7704 16r5879 16r7720 16r587A 16r7DBF 16r587B 16r7DEC 16r587C 16r9762 16r587D 16r9EB5 16r587E 16r6EC5 16r5921 16r8511 16r5922 16r51A5 16r5923 16r540D 16r5924 16r547D 16r5925 16r660E 16r5926 16r669D 16r5927 16r6927 16r5928 16r6E9F 16r5929 16r76BF 16r592A 16r7791 16r592B 16r8317 16r592C 16r84C2 16r592D 16r879F 16r592E 16r9169 16r592F 16r9298 16r5930 16r9CF4 16r5931 16r8882 16r5932 16r4FAE 16r5933 16r5192 16r5934 16r52DF 16r5935 16r59C6 16r5936 16r5E3D 16r5937 16r6155 16r5938 16r6478 16r5939 16r6479 16r593A 16r66AE 16r593B 16r67D0 16r593C 16r6A21 16r593D 16r6BCD 16r593E 16r6BDB 16r593F 16r725F 16r5940 16r7261 16r5941 16r7441 16r5942 16r7738 16r5943 16r77DB 16r5944 16r8017 16r5945 16r82BC 16r5946 16r8305 16r5947 16r8B00 16r5948 16r8B28 16r5949 16r8C8C 16r594A 16r6728 16r594B 16r6C90 16r594C 16r7267 16r594D 16r76EE 16r594E 16r7766 16r594F 16r7A46 16r5950 16r9DA9 16r5951 16r6B7F 16r5952 16r6C92 16r5953 16r5922 16r5954 16r6726 16r5955 16r8499 16r5956 16r536F 16r5957 16r5893 16r5958 16r5999 16r5959 16r5EDF 16r595A 16r63CF 16r595B 16r6634 16r595C 16r6773 16r595D 16r6E3A 16r595E 16r732B 16r595F 16r7AD7 16r5960 16r82D7 16r5961 16r9328 16r5962 16r52D9 16r5963 16r5DEB 16r5964 16r61AE 16r5965 16r61CB 16r5966 16r620A 16r5967 16r62C7 16r5968 16r64AB 16r5969 16r65E0 16r596A 16r6959 16r596B 16r6B66 16r596C 16r6BCB 16r596D 16r7121 16r596E 16r73F7 16r596F 16r755D 16r5970 16r7E46 16r5971 16r821E 16r5972 16r8302 16r5973 16r856A 16r5974 16r8AA3 16r5975 16r8CBF 16r5976 16r9727 16r5977 16r9D61 16r5978 16r58A8 16r5979 16r9ED8 16r597A 16r5011 16r597B 16r520E 16r597C 16r543B 16r597D 16r554F 16r597E 16r6587 16r5A21 16r6C76 16r5A22 16r7D0A 16r5A23 16r7D0B 16r5A24 16r805E 16r5A25 16r868A 16r5A26 16r9580 16r5A27 16r96EF 16r5A28 16r52FF 16r5A29 16r6C95 16r5A2A 16r7269 16r5A2B 16r5473 16r5A2C 16r5A9A 16r5A2D 16r5C3E 16r5A2E 16r5D4B 16r5A2F 16r5F4C 16r5A30 16r5FAE 16r5A31 16r672A 16r5A32 16r68B6 16r5A33 16r6963 16r5A34 16r6E3C 16r5A35 16r6E44 16r5A36 16r7709 16r5A37 16r7C73 16r5A38 16r7F8E 16r5A39 16r8587 16r5A3A 16r8B0E 16r5A3B 16r8FF7 16r5A3C 16r9761 16r5A3D 16r9EF4 16r5A3E 16r5CB7 16r5A3F 16r60B6 16r5A40 16r610D 16r5A41 16r61AB 16r5A42 16r654F 16r5A43 16r65FB 16r5A44 16r65FC 16r5A45 16r6C11 16r5A46 16r6CEF 16r5A47 16r739F 16r5A48 16r73C9 16r5A49 16r7DE1 16r5A4A 16r9594 16r5A4B 16r5BC6 16r5A4C 16r871C 16r5A4D 16r8B10 16r5A4E 16r525D 16r5A4F 16r535A 16r5A50 16r62CD 16r5A51 16r640F 16r5A52 16r64B2 16r5A53 16r6734 16r5A54 16r6A38 16r5A55 16r6CCA 16r5A56 16r73C0 16r5A57 16r749E 16r5A58 16r7B94 16r5A59 16r7C95 16r5A5A 16r7E1B 16r5A5B 16r818A 16r5A5C 16r8236 16r5A5D 16r8584 16r5A5E 16r8FEB 16r5A5F 16r96F9 16r5A60 16r99C1 16r5A61 16r4F34 16r5A62 16r534A 16r5A63 16r53CD 16r5A64 16r53DB 16r5A65 16r62CC 16r5A66 16r642C 16r5A67 16r6500 16r5A68 16r6591 16r5A69 16r69C3 16r5A6A 16r6CEE 16r5A6B 16r6F58 16r5A6C 16r73ED 16r5A6D 16r7554 16r5A6E 16r7622 16r5A6F 16r76E4 16r5A70 16r76FC 16r5A71 16r78D0 16r5A72 16r78FB 16r5A73 16r792C 16r5A74 16r7D46 16r5A75 16r822C 16r5A76 16r87E0 16r5A77 16r8FD4 16r5A78 16r9812 16r5A79 16r98EF 16r5A7A 16r52C3 16r5A7B 16r62D4 16r5A7C 16r64A5 16r5A7D 16r6E24 16r5A7E 16r6F51 16r5B21 16r767C 16r5B22 16r8DCB 16r5B23 16r91B1 16r5B24 16r9262 16r5B25 16r9AEE 16r5B26 16r9B43 16r5B27 16r5023 16r5B28 16r508D 16r5B29 16r574A 16r5B2A 16r59A8 16r5B2B 16r5C28 16r5B2C 16r5E47 16r5B2D 16r5F77 16r5B2E 16r623F 16r5B2F 16r653E 16r5B30 16r65B9 16r5B31 16r65C1 16r5B32 16r6609 16r5B33 16r678B 16r5B34 16r699C 16r5B35 16r6EC2 16r5B36 16r78C5 16r5B37 16r7D21 16r5B38 16r80AA 16r5B39 16r8180 16r5B3A 16r822B 16r5B3B 16r82B3 16r5B3C 16r84A1 16r5B3D 16r868C 16r5B3E 16r8A2A 16r5B3F 16r8B17 16r5B40 16r90A6 16r5B41 16r9632 16r5B42 16r9F90 16r5B43 16r500D 16r5B44 16r4FF3 16r5B45 16rF963 16r5B46 16r57F9 16r5B47 16r5F98 16r5B48 16r62DC 16r5B49 16r6392 16r5B4A 16r676F 16r5B4B 16r6E43 16r5B4C 16r7119 16r5B4D 16r76C3 16r5B4E 16r80CC 16r5B4F 16r80DA 16r5B50 16r88F4 16r5B51 16r88F5 16r5B52 16r8919 16r5B53 16r8CE0 16r5B54 16r8F29 16r5B55 16r914D 16r5B56 16r966A 16r5B57 16r4F2F 16r5B58 16r4F70 16r5B59 16r5E1B 16r5B5A 16r67CF 16r5B5B 16r6822 16r5B5C 16r767D 16r5B5D 16r767E 16r5B5E 16r9B44 16r5B5F 16r5E61 16r5B60 16r6A0A 16r5B61 16r7169 16r5B62 16r71D4 16r5B63 16r756A 16r5B64 16rF964 16r5B65 16r7E41 16r5B66 16r8543 16r5B67 16r85E9 16r5B68 16r98DC 16r5B69 16r4F10 16r5B6A 16r7B4F 16r5B6B 16r7F70 16r5B6C 16r95A5 16r5B6D 16r51E1 16r5B6E 16r5E06 16r5B6F 16r68B5 16r5B70 16r6C3E 16r5B71 16r6C4E 16r5B72 16r6CDB 16r5B73 16r72AF 16r5B74 16r7BC4 16r5B75 16r8303 16r5B76 16r6CD5 16r5B77 16r743A 16r5B78 16r50FB 16r5B79 16r5288 16r5B7A 16r58C1 16r5B7B 16r64D8 16r5B7C 16r6A97 16r5B7D 16r74A7 16r5B7E 16r7656 16r5C21 16r78A7 16r5C22 16r8617 16r5C23 16r95E2 16r5C24 16r9739 16r5C25 16rF965 16r5C26 16r535E 16r5C27 16r5F01 16r5C28 16r8B8A 16r5C29 16r8FA8 16r5C2A 16r8FAF 16r5C2B 16r908A 16r5C2C 16r5225 16r5C2D 16r77A5 16r5C2E 16r9C49 16r5C2F 16r9F08 16r5C30 16r4E19 16r5C31 16r5002 16r5C32 16r5175 16r5C33 16r5C5B 16r5C34 16r5E77 16r5C35 16r661E 16r5C36 16r663A 16r5C37 16r67C4 16r5C38 16r68C5 16r5C39 16r70B3 16r5C3A 16r7501 16r5C3B 16r75C5 16r5C3C 16r79C9 16r5C3D 16r7ADD 16r5C3E 16r8F27 16r5C3F 16r9920 16r5C40 16r9A08 16r5C41 16r4FDD 16r5C42 16r5821 16r5C43 16r5831 16r5C44 16r5BF6 16r5C45 16r666E 16r5C46 16r6B65 16r5C47 16r6D11 16r5C48 16r6E7A 16r5C49 16r6F7D 16r5C4A 16r73E4 16r5C4B 16r752B 16r5C4C 16r83E9 16r5C4D 16r88DC 16r5C4E 16r8913 16r5C4F 16r8B5C 16r5C50 16r8F14 16r5C51 16r4F0F 16r5C52 16r50D5 16r5C53 16r5310 16r5C54 16r535C 16r5C55 16r5B93 16r5C56 16r5FA9 16r5C57 16r670D 16r5C58 16r798F 16r5C59 16r8179 16r5C5A 16r832F 16r5C5B 16r8514 16r5C5C 16r8907 16r5C5D 16r8986 16r5C5E 16r8F39 16r5C5F 16r8F3B 16r5C60 16r99A5 16r5C61 16r9C12 16r5C62 16r672C 16r5C63 16r4E76 16r5C64 16r4FF8 16r5C65 16r5949 16r5C66 16r5C01 16r5C67 16r5CEF 16r5C68 16r5CF0 16r5C69 16r6367 16r5C6A 16r68D2 16r5C6B 16r70FD 16r5C6C 16r71A2 16r5C6D 16r742B 16r5C6E 16r7E2B 16r5C6F 16r84EC 16r5C70 16r8702 16r5C71 16r9022 16r5C72 16r92D2 16r5C73 16r9CF3 16r5C74 16r4E0D 16r5C75 16r4ED8 16r5C76 16r4FEF 16r5C77 16r5085 16r5C78 16r5256 16r5C79 16r526F 16r5C7A 16r5426 16r5C7B 16r5490 16r5C7C 16r57E0 16r5C7D 16r592B 16r5C7E 16r5A66 16r5D21 16r5B5A 16r5D22 16r5B75 16r5D23 16r5BCC 16r5D24 16r5E9C 16r5D25 16rF966 16r5D26 16r6276 16r5D27 16r6577 16r5D28 16r65A7 16r5D29 16r6D6E 16r5D2A 16r6EA5 16r5D2B 16r7236 16r5D2C 16r7B26 16r5D2D 16r7C3F 16r5D2E 16r7F36 16r5D2F 16r8150 16r5D30 16r8151 16r5D31 16r819A 16r5D32 16r8240 16r5D33 16r8299 16r5D34 16r83A9 16r5D35 16r8A03 16r5D36 16r8CA0 16r5D37 16r8CE6 16r5D38 16r8CFB 16r5D39 16r8D74 16r5D3A 16r8DBA 16r5D3B 16r90E8 16r5D3C 16r91DC 16r5D3D 16r961C 16r5D3E 16r9644 16r5D3F 16r99D9 16r5D40 16r9CE7 16r5D41 16r5317 16r5D42 16r5206 16r5D43 16r5429 16r5D44 16r5674 16r5D45 16r58B3 16r5D46 16r5954 16r5D47 16r596E 16r5D48 16r5FFF 16r5D49 16r61A4 16r5D4A 16r626E 16r5D4B 16r6610 16r5D4C 16r6C7E 16r5D4D 16r711A 16r5D4E 16r76C6 16r5D4F 16r7C89 16r5D50 16r7CDE 16r5D51 16r7D1B 16r5D52 16r82AC 16r5D53 16r8CC1 16r5D54 16r96F0 16r5D55 16rF967 16r5D56 16r4F5B 16r5D57 16r5F17 16r5D58 16r5F7F 16r5D59 16r62C2 16r5D5A 16r5D29 16r5D5B 16r670B 16r5D5C 16r68DA 16r5D5D 16r787C 16r5D5E 16r7E43 16r5D5F 16r9D6C 16r5D60 16r4E15 16r5D61 16r5099 16r5D62 16r5315 16r5D63 16r532A 16r5D64 16r5351 16r5D65 16r5983 16r5D66 16r5A62 16r5D67 16r5E87 16r5D68 16r60B2 16r5D69 16r618A 16r5D6A 16r6249 16r5D6B 16r6279 16r5D6C 16r6590 16r5D6D 16r6787 16r5D6E 16r69A7 16r5D6F 16r6BD4 16r5D70 16r6BD6 16r5D71 16r6BD7 16r5D72 16r6BD8 16r5D73 16r6CB8 16r5D74 16rF968 16r5D75 16r7435 16r5D76 16r75FA 16r5D77 16r7812 16r5D78 16r7891 16r5D79 16r79D5 16r5D7A 16r79D8 16r5D7B 16r7C83 16r5D7C 16r7DCB 16r5D7D 16r7FE1 16r5D7E 16r80A5 16r5E21 16r813E 16r5E22 16r81C2 16r5E23 16r83F2 16r5E24 16r871A 16r5E25 16r88E8 16r5E26 16r8AB9 16r5E27 16r8B6C 16r5E28 16r8CBB 16r5E29 16r9119 16r5E2A 16r975E 16r5E2B 16r98DB 16r5E2C 16r9F3B 16r5E2D 16r56AC 16r5E2E 16r5B2A 16r5E2F 16r5F6C 16r5E30 16r658C 16r5E31 16r6AB3 16r5E32 16r6BAF 16r5E33 16r6D5C 16r5E34 16r6FF1 16r5E35 16r7015 16r5E36 16r725D 16r5E37 16r73AD 16r5E38 16r8CA7 16r5E39 16r8CD3 16r5E3A 16r983B 16r5E3B 16r6191 16r5E3C 16r6C37 16r5E3D 16r8058 16r5E3E 16r9A01 16r5E3F 16r4E4D 16r5E40 16r4E8B 16r5E41 16r4E9B 16r5E42 16r4ED5 16r5E43 16r4F3A 16r5E44 16r4F3C 16r5E45 16r4F7F 16r5E46 16r4FDF 16r5E47 16r50FF 16r5E48 16r53F2 16r5E49 16r53F8 16r5E4A 16r5506 16r5E4B 16r55E3 16r5E4C 16r56DB 16r5E4D 16r58EB 16r5E4E 16r5962 16r5E4F 16r5A11 16r5E50 16r5BEB 16r5E51 16r5BFA 16r5E52 16r5C04 16r5E53 16r5DF3 16r5E54 16r5E2B 16r5E55 16r5F99 16r5E56 16r601D 16r5E57 16r6368 16r5E58 16r659C 16r5E59 16r65AF 16r5E5A 16r67F6 16r5E5B 16r67FB 16r5E5C 16r68AD 16r5E5D 16r6B7B 16r5E5E 16r6C99 16r5E5F 16r6CD7 16r5E60 16r6E23 16r5E61 16r7009 16r5E62 16r7345 16r5E63 16r7802 16r5E64 16r793E 16r5E65 16r7940 16r5E66 16r7960 16r5E67 16r79C1 16r5E68 16r7BE9 16r5E69 16r7D17 16r5E6A 16r7D72 16r5E6B 16r8086 16r5E6C 16r820D 16r5E6D 16r838E 16r5E6E 16r84D1 16r5E6F 16r86C7 16r5E70 16r88DF 16r5E71 16r8A50 16r5E72 16r8A5E 16r5E73 16r8B1D 16r5E74 16r8CDC 16r5E75 16r8D66 16r5E76 16r8FAD 16r5E77 16r90AA 16r5E78 16r98FC 16r5E79 16r99DF 16r5E7A 16r9E9D 16r5E7B 16r524A 16r5E7C 16rF969 16r5E7D 16r6714 16r5E7E 16rF96A 16r5F21 16r5098 16r5F22 16r522A 16r5F23 16r5C71 16r5F24 16r6563 16r5F25 16r6C55 16r5F26 16r73CA 16r5F27 16r7523 16r5F28 16r759D 16r5F29 16r7B97 16r5F2A 16r849C 16r5F2B 16r9178 16r5F2C 16r9730 16r5F2D 16r4E77 16r5F2E 16r6492 16r5F2F 16r6BBA 16r5F30 16r715E 16r5F31 16r85A9 16r5F32 16r4E09 16r5F33 16rF96B 16r5F34 16r6749 16r5F35 16r68EE 16r5F36 16r6E17 16r5F37 16r829F 16r5F38 16r8518 16r5F39 16r886B 16r5F3A 16r63F7 16r5F3B 16r6F81 16r5F3C 16r9212 16r5F3D 16r98AF 16r5F3E 16r4E0A 16r5F3F 16r50B7 16r5F40 16r50CF 16r5F41 16r511F 16r5F42 16r5546 16r5F43 16r55AA 16r5F44 16r5617 16r5F45 16r5B40 16r5F46 16r5C19 16r5F47 16r5CE0 16r5F48 16r5E38 16r5F49 16r5E8A 16r5F4A 16r5EA0 16r5F4B 16r5EC2 16r5F4C 16r60F3 16r5F4D 16r6851 16r5F4E 16r6A61 16r5F4F 16r6E58 16r5F50 16r723D 16r5F51 16r7240 16r5F52 16r72C0 16r5F53 16r76F8 16r5F54 16r7965 16r5F55 16r7BB1 16r5F56 16r7FD4 16r5F57 16r88F3 16r5F58 16r89F4 16r5F59 16r8A73 16r5F5A 16r8C61 16r5F5B 16r8CDE 16r5F5C 16r971C 16r5F5D 16r585E 16r5F5E 16r74BD 16r5F5F 16r8CFD 16r5F60 16r55C7 16r5F61 16rF96C 16r5F62 16r7A61 16r5F63 16r7D22 16r5F64 16r8272 16r5F65 16r7272 16r5F66 16r751F 16r5F67 16r7525 16r5F68 16rF96D 16r5F69 16r7B19 16r5F6A 16r5885 16r5F6B 16r58FB 16r5F6C 16r5DBC 16r5F6D 16r5E8F 16r5F6E 16r5EB6 16r5F6F 16r5F90 16r5F70 16r6055 16r5F71 16r6292 16r5F72 16r637F 16r5F73 16r654D 16r5F74 16r6691 16r5F75 16r66D9 16r5F76 16r66F8 16r5F77 16r6816 16r5F78 16r68F2 16r5F79 16r7280 16r5F7A 16r745E 16r5F7B 16r7B6E 16r5F7C 16r7D6E 16r5F7D 16r7DD6 16r5F7E 16r7F72 16r6021 16r80E5 16r6022 16r8212 16r6023 16r85AF 16r6024 16r897F 16r6025 16r8A93 16r6026 16r901D 16r6027 16r92E4 16r6028 16r9ECD 16r6029 16r9F20 16r602A 16r5915 16r602B 16r596D 16r602C 16r5E2D 16r602D 16r60DC 16r602E 16r6614 16r602F 16r6673 16r6030 16r6790 16r6031 16r6C50 16r6032 16r6DC5 16r6033 16r6F5F 16r6034 16r77F3 16r6035 16r78A9 16r6036 16r84C6 16r6037 16r91CB 16r6038 16r932B 16r6039 16r4ED9 16r603A 16r50CA 16r603B 16r5148 16r603C 16r5584 16r603D 16r5B0B 16r603E 16r5BA3 16r603F 16r6247 16r6040 16r657E 16r6041 16r65CB 16r6042 16r6E32 16r6043 16r717D 16r6044 16r7401 16r6045 16r7444 16r6046 16r7487 16r6047 16r74BF 16r6048 16r766C 16r6049 16r79AA 16r604A 16r7DDA 16r604B 16r7E55 16r604C 16r7FA8 16r604D 16r817A 16r604E 16r81B3 16r604F 16r8239 16r6050 16r861A 16r6051 16r87EC 16r6052 16r8A75 16r6053 16r8DE3 16r6054 16r9078 16r6055 16r9291 16r6056 16r9425 16r6057 16r994D 16r6058 16r9BAE 16r6059 16r5368 16r605A 16r5C51 16r605B 16r6954 16r605C 16r6CC4 16r605D 16r6D29 16r605E 16r6E2B 16r605F 16r820C 16r6060 16r859B 16r6061 16r893B 16r6062 16r8A2D 16r6063 16r8AAA 16r6064 16r96EA 16r6065 16r9F67 16r6066 16r5261 16r6067 16r66B9 16r6068 16r6BB2 16r6069 16r7E96 16r606A 16r87FE 16r606B 16r8D0D 16r606C 16r9583 16r606D 16r965D 16r606E 16r651D 16r606F 16r6D89 16r6070 16r71EE 16r6071 16rF96E 16r6072 16r57CE 16r6073 16r59D3 16r6074 16r5BAC 16r6075 16r6027 16r6076 16r60FA 16r6077 16r6210 16r6078 16r661F 16r6079 16r665F 16r607A 16r7329 16r607B 16r73F9 16r607C 16r76DB 16r607D 16r7701 16r607E 16r7B6C 16r6121 16r8056 16r6122 16r8072 16r6123 16r8165 16r6124 16r8AA0 16r6125 16r9192 16r6126 16r4E16 16r6127 16r52E2 16r6128 16r6B72 16r6129 16r6D17 16r612A 16r7A05 16r612B 16r7B39 16r612C 16r7D30 16r612D 16rF96F 16r612E 16r8CB0 16r612F 16r53EC 16r6130 16r562F 16r6131 16r5851 16r6132 16r5BB5 16r6133 16r5C0F 16r6134 16r5C11 16r6135 16r5DE2 16r6136 16r6240 16r6137 16r6383 16r6138 16r6414 16r6139 16r662D 16r613A 16r68B3 16r613B 16r6CBC 16r613C 16r6D88 16r613D 16r6EAF 16r613E 16r701F 16r613F 16r70A4 16r6140 16r71D2 16r6141 16r7526 16r6142 16r758F 16r6143 16r758E 16r6144 16r7619 16r6145 16r7B11 16r6146 16r7BE0 16r6147 16r7C2B 16r6148 16r7D20 16r6149 16r7D39 16r614A 16r852C 16r614B 16r856D 16r614C 16r8607 16r614D 16r8A34 16r614E 16r900D 16r614F 16r9061 16r6150 16r90B5 16r6151 16r92B7 16r6152 16r97F6 16r6153 16r9A37 16r6154 16r4FD7 16r6155 16r5C6C 16r6156 16r675F 16r6157 16r6D91 16r6158 16r7C9F 16r6159 16r7E8C 16r615A 16r8B16 16r615B 16r8D16 16r615C 16r901F 16r615D 16r5B6B 16r615E 16r5DFD 16r615F 16r640D 16r6160 16r84C0 16r6161 16r905C 16r6162 16r98E1 16r6163 16r7387 16r6164 16r5B8B 16r6165 16r609A 16r6166 16r677E 16r6167 16r6DDE 16r6168 16r8A1F 16r6169 16r8AA6 16r616A 16r9001 16r616B 16r980C 16r616C 16r5237 16r616D 16rF970 16r616E 16r7051 16r616F 16r788E 16r6170 16r9396 16r6171 16r8870 16r6172 16r91D7 16r6173 16r4FEE 16r6174 16r53D7 16r6175 16r55FD 16r6176 16r56DA 16r6177 16r5782 16r6178 16r58FD 16r6179 16r5AC2 16r617A 16r5B88 16r617B 16r5CAB 16r617C 16r5CC0 16r617D 16r5E25 16r617E 16r6101 16r6221 16r620D 16r6222 16r624B 16r6223 16r6388 16r6224 16r641C 16r6225 16r6536 16r6226 16r6578 16r6227 16r6A39 16r6228 16r6B8A 16r6229 16r6C34 16r622A 16r6D19 16r622B 16r6F31 16r622C 16r71E7 16r622D 16r72E9 16r622E 16r7378 16r622F 16r7407 16r6230 16r74B2 16r6231 16r7626 16r6232 16r7761 16r6233 16r79C0 16r6234 16r7A57 16r6235 16r7AEA 16r6236 16r7CB9 16r6237 16r7D8F 16r6238 16r7DAC 16r6239 16r7E61 16r623A 16r7F9E 16r623B 16r8129 16r623C 16r8331 16r623D 16r8490 16r623E 16r84DA 16r623F 16r85EA 16r6240 16r8896 16r6241 16r8AB0 16r6242 16r8B90 16r6243 16r8F38 16r6244 16r9042 16r6245 16r9083 16r6246 16r916C 16r6247 16r9296 16r6248 16r92B9 16r6249 16r968B 16r624A 16r96A7 16r624B 16r96A8 16r624C 16r96D6 16r624D 16r9700 16r624E 16r9808 16r624F 16r9996 16r6250 16r9AD3 16r6251 16r9B1A 16r6252 16r53D4 16r6253 16r587E 16r6254 16r5919 16r6255 16r5B70 16r6256 16r5BBF 16r6257 16r6DD1 16r6258 16r6F5A 16r6259 16r719F 16r625A 16r7421 16r625B 16r74B9 16r625C 16r8085 16r625D 16r83FD 16r625E 16r5DE1 16r625F 16r5F87 16r6260 16r5FAA 16r6261 16r6042 16r6262 16r65EC 16r6263 16r6812 16r6264 16r696F 16r6265 16r6A53 16r6266 16r6B89 16r6267 16r6D35 16r6268 16r6DF3 16r6269 16r73E3 16r626A 16r76FE 16r626B 16r77AC 16r626C 16r7B4D 16r626D 16r7D14 16r626E 16r8123 16r626F 16r821C 16r6270 16r8340 16r6271 16r84F4 16r6272 16r8563 16r6273 16r8A62 16r6274 16r8AC4 16r6275 16r9187 16r6276 16r931E 16r6277 16r9806 16r6278 16r99B4 16r6279 16r620C 16r627A 16r8853 16r627B 16r8FF0 16r627C 16r9265 16r627D 16r5D07 16r627E 16r5D27 16r6321 16r5D69 16r6322 16r745F 16r6323 16r819D 16r6324 16r8768 16r6325 16r6FD5 16r6326 16r62FE 16r6327 16r7FD2 16r6328 16r8936 16r6329 16r8972 16r632A 16r4E1E 16r632B 16r4E58 16r632C 16r50E7 16r632D 16r52DD 16r632E 16r5347 16r632F 16r627F 16r6330 16r6607 16r6331 16r7E69 16r6332 16r8805 16r6333 16r965E 16r6334 16r4F8D 16r6335 16r5319 16r6336 16r5636 16r6337 16r59CB 16r6338 16r5AA4 16r6339 16r5C38 16r633A 16r5C4E 16r633B 16r5C4D 16r633C 16r5E02 16r633D 16r5F11 16r633E 16r6043 16r633F 16r65BD 16r6340 16r662F 16r6341 16r6642 16r6342 16r67BE 16r6343 16r67F4 16r6344 16r731C 16r6345 16r77E2 16r6346 16r793A 16r6347 16r7FC5 16r6348 16r8494 16r6349 16r84CD 16r634A 16r8996 16r634B 16r8A66 16r634C 16r8A69 16r634D 16r8AE1 16r634E 16r8C55 16r634F 16r8C7A 16r6350 16r57F4 16r6351 16r5BD4 16r6352 16r5F0F 16r6353 16r606F 16r6354 16r62ED 16r6355 16r690D 16r6356 16r6B96 16r6357 16r6E5C 16r6358 16r7184 16r6359 16r7BD2 16r635A 16r8755 16r635B 16r8B58 16r635C 16r8EFE 16r635D 16r98DF 16r635E 16r98FE 16r635F 16r4F38 16r6360 16r4F81 16r6361 16r4FE1 16r6362 16r547B 16r6363 16r5A20 16r6364 16r5BB8 16r6365 16r613C 16r6366 16r65B0 16r6367 16r6668 16r6368 16r71FC 16r6369 16r7533 16r636A 16r795E 16r636B 16r7D33 16r636C 16r814E 16r636D 16r81E3 16r636E 16r8398 16r636F 16r85AA 16r6370 16r85CE 16r6371 16r8703 16r6372 16r8A0A 16r6373 16r8EAB 16r6374 16r8F9B 16r6375 16rF971 16r6376 16r8FC5 16r6377 16r5931 16r6378 16r5BA4 16r6379 16r5BE6 16r637A 16r6089 16r637B 16r5BE9 16r637C 16r5C0B 16r637D 16r5FC3 16r637E 16r6C81 16r6421 16rF972 16r6422 16r6DF1 16r6423 16r700B 16r6424 16r751A 16r6425 16r82AF 16r6426 16r8AF6 16r6427 16r4EC0 16r6428 16r5341 16r6429 16rF973 16r642A 16r96D9 16r642B 16r6C0F 16r642C 16r4E9E 16r642D 16r4FC4 16r642E 16r5152 16r642F 16r555E 16r6430 16r5A25 16r6431 16r5CE8 16r6432 16r6211 16r6433 16r7259 16r6434 16r82BD 16r6435 16r83AA 16r6436 16r86FE 16r6437 16r8859 16r6438 16r8A1D 16r6439 16r963F 16r643A 16r96C5 16r643B 16r9913 16r643C 16r9D09 16r643D 16r9D5D 16r643E 16r580A 16r643F 16r5CB3 16r6440 16r5DBD 16r6441 16r5E44 16r6442 16r60E1 16r6443 16r6115 16r6444 16r63E1 16r6445 16r6A02 16r6446 16r6E25 16r6447 16r9102 16r6448 16r9354 16r6449 16r984E 16r644A 16r9C10 16r644B 16r9F77 16r644C 16r5B89 16r644D 16r5CB8 16r644E 16r6309 16r644F 16r664F 16r6450 16r6848 16r6451 16r773C 16r6452 16r96C1 16r6453 16r978D 16r6454 16r9854 16r6455 16r9B9F 16r6456 16r65A1 16r6457 16r8B01 16r6458 16r8ECB 16r6459 16r95BC 16r645A 16r5535 16r645B 16r5CA9 16r645C 16r5DD6 16r645D 16r5EB5 16r645E 16r6697 16r645F 16r764C 16r6460 16r83F4 16r6461 16r95C7 16r6462 16r58D3 16r6463 16r62BC 16r6464 16r72CE 16r6465 16r9D28 16r6466 16r4EF0 16r6467 16r592E 16r6468 16r600F 16r6469 16r663B 16r646A 16r6B83 16r646B 16r79E7 16r646C 16r9D26 16r646D 16r5393 16r646E 16r54C0 16r646F 16r57C3 16r6470 16r5D16 16r6471 16r611B 16r6472 16r66D6 16r6473 16r6DAF 16r6474 16r788D 16r6475 16r827E 16r6476 16r9698 16r6477 16r9744 16r6478 16r5384 16r6479 16r627C 16r647A 16r6396 16r647B 16r6DB2 16r647C 16r7E0A 16r647D 16r814B 16r647E 16r984D 16r6521 16r6AFB 16r6522 16r7F4C 16r6523 16r9DAF 16r6524 16r9E1A 16r6525 16r4E5F 16r6526 16r503B 16r6527 16r51B6 16r6528 16r591C 16r6529 16r60F9 16r652A 16r63F6 16r652B 16r6930 16r652C 16r723A 16r652D 16r8036 16r652E 16rF974 16r652F 16r91CE 16r6530 16r5F31 16r6531 16rF975 16r6532 16rF976 16r6533 16r7D04 16r6534 16r82E5 16r6535 16r846F 16r6536 16r84BB 16r6537 16r85E5 16r6538 16r8E8D 16r6539 16rF977 16r653A 16r4F6F 16r653B 16rF978 16r653C 16rF979 16r653D 16r58E4 16r653E 16r5B43 16r653F 16r6059 16r6540 16r63DA 16r6541 16r6518 16r6542 16r656D 16r6543 16r6698 16r6544 16rF97A 16r6545 16r694A 16r6546 16r6A23 16r6547 16r6D0B 16r6548 16r7001 16r6549 16r716C 16r654A 16r75D2 16r654B 16r760D 16r654C 16r79B3 16r654D 16r7A70 16r654E 16rF97B 16r654F 16r7F8A 16r6550 16rF97C 16r6551 16r8944 16r6552 16rF97D 16r6553 16r8B93 16r6554 16r91C0 16r6555 16r967D 16r6556 16rF97E 16r6557 16r990A 16r6558 16r5704 16r6559 16r5FA1 16r655A 16r65BC 16r655B 16r6F01 16r655C 16r7600 16r655D 16r79A6 16r655E 16r8A9E 16r655F 16r99AD 16r6560 16r9B5A 16r6561 16r9F6C 16r6562 16r5104 16r6563 16r61B6 16r6564 16r6291 16r6565 16r6A8D 16r6566 16r81C6 16r6567 16r5043 16r6568 16r5830 16r6569 16r5F66 16r656A 16r7109 16r656B 16r8A00 16r656C 16r8AFA 16r656D 16r5B7C 16r656E 16r8616 16r656F 16r4FFA 16r6570 16r513C 16r6571 16r56B4 16r6572 16r5944 16r6573 16r63A9 16r6574 16r6DF9 16r6575 16r5DAA 16r6576 16r696D 16r6577 16r5186 16r6578 16r4E88 16r6579 16r4F59 16r657A 16rF97F 16r657B 16rF980 16r657C 16rF981 16r657D 16r5982 16r657E 16rF982 16r6621 16rF983 16r6622 16r6B5F 16r6623 16r6C5D 16r6624 16rF984 16r6625 16r74B5 16r6626 16r7916 16r6627 16rF985 16r6628 16r8207 16r6629 16r8245 16r662A 16r8339 16r662B 16r8F3F 16r662C 16r8F5D 16r662D 16rF986 16r662E 16r9918 16r662F 16rF987 16r6630 16rF988 16r6631 16rF989 16r6632 16r4EA6 16r6633 16rF98A 16r6634 16r57DF 16r6635 16r5F79 16r6636 16r6613 16r6637 16rF98B 16r6638 16rF98C 16r6639 16r75AB 16r663A 16r7E79 16r663B 16r8B6F 16r663C 16rF98D 16r663D 16r9006 16r663E 16r9A5B 16r663F 16r56A5 16r6640 16r5827 16r6641 16r59F8 16r6642 16r5A1F 16r6643 16r5BB4 16r6644 16rF98E 16r6645 16r5EF6 16r6646 16rF98F 16r6647 16rF990 16r6648 16r6350 16r6649 16r633B 16r664A 16rF991 16r664B 16r693D 16r664C 16r6C87 16r664D 16r6CBF 16r664E 16r6D8E 16r664F 16r6D93 16r6650 16r6DF5 16r6651 16r6F14 16r6652 16rF992 16r6653 16r70DF 16r6654 16r7136 16r6655 16r7159 16r6656 16rF993 16r6657 16r71C3 16r6658 16r71D5 16r6659 16rF994 16r665A 16r784F 16r665B 16r786F 16r665C 16rF995 16r665D 16r7B75 16r665E 16r7DE3 16r665F 16rF996 16r6660 16r7E2F 16r6661 16rF997 16r6662 16r884D 16r6663 16r8EDF 16r6664 16rF998 16r6665 16rF999 16r6666 16rF99A 16r6667 16r925B 16r6668 16rF99B 16r6669 16r9CF6 16r666A 16rF99C 16r666B 16rF99D 16r666C 16rF99E 16r666D 16r6085 16r666E 16r6D85 16r666F 16rF99F 16r6670 16r71B1 16r6671 16rF9A0 16r6672 16rF9A1 16r6673 16r95B1 16r6674 16r53AD 16r6675 16rF9A2 16r6676 16rF9A3 16r6677 16rF9A4 16r6678 16r67D3 16r6679 16rF9A5 16r667A 16r708E 16r667B 16r7130 16r667C 16r7430 16r667D 16r8276 16r667E 16r82D2 16r6721 16rF9A6 16r6722 16r95BB 16r6723 16r9AE5 16r6724 16r9E7D 16r6725 16r66C4 16r6726 16rF9A7 16r6727 16r71C1 16r6728 16r8449 16r6729 16rF9A8 16r672A 16rF9A9 16r672B 16r584B 16r672C 16rF9AA 16r672D 16rF9AB 16r672E 16r5DB8 16r672F 16r5F71 16r6730 16rF9AC 16r6731 16r6620 16r6732 16r668E 16r6733 16r6979 16r6734 16r69AE 16r6735 16r6C38 16r6736 16r6CF3 16r6737 16r6E36 16r6738 16r6F41 16r6739 16r6FDA 16r673A 16r701B 16r673B 16r702F 16r673C 16r7150 16r673D 16r71DF 16r673E 16r7370 16r673F 16rF9AD 16r6740 16r745B 16r6741 16rF9AE 16r6742 16r74D4 16r6743 16r76C8 16r6744 16r7A4E 16r6745 16r7E93 16r6746 16rF9AF 16r6747 16rF9B0 16r6748 16r82F1 16r6749 16r8A60 16r674A 16r8FCE 16r674B 16rF9B1 16r674C 16r9348 16r674D 16rF9B2 16r674E 16r9719 16r674F 16rF9B3 16r6750 16rF9B4 16r6751 16r4E42 16r6752 16r502A 16r6753 16rF9B5 16r6754 16r5208 16r6755 16r53E1 16r6756 16r66F3 16r6757 16r6C6D 16r6758 16r6FCA 16r6759 16r730A 16r675A 16r777F 16r675B 16r7A62 16r675C 16r82AE 16r675D 16r85DD 16r675E 16r8602 16r675F 16rF9B6 16r6760 16r88D4 16r6761 16r8A63 16r6762 16r8B7D 16r6763 16r8C6B 16r6764 16rF9B7 16r6765 16r92B3 16r6766 16rF9B8 16r6767 16r9713 16r6768 16r9810 16r6769 16r4E94 16r676A 16r4F0D 16r676B 16r4FC9 16r676C 16r50B2 16r676D 16r5348 16r676E 16r543E 16r676F 16r5433 16r6770 16r55DA 16r6771 16r5862 16r6772 16r58BA 16r6773 16r5967 16r6774 16r5A1B 16r6775 16r5BE4 16r6776 16r609F 16r6777 16rF9B9 16r6778 16r61CA 16r6779 16r6556 16r677A 16r65FF 16r677B 16r6664 16r677C 16r68A7 16r677D 16r6C5A 16r677E 16r6FB3 16r6821 16r70CF 16r6822 16r71AC 16r6823 16r7352 16r6824 16r7B7D 16r6825 16r8708 16r6826 16r8AA4 16r6827 16r9C32 16r6828 16r9F07 16r6829 16r5C4B 16r682A 16r6C83 16r682B 16r7344 16r682C 16r7389 16r682D 16r923A 16r682E 16r6EAB 16r682F 16r7465 16r6830 16r761F 16r6831 16r7A69 16r6832 16r7E15 16r6833 16r860A 16r6834 16r5140 16r6835 16r58C5 16r6836 16r64C1 16r6837 16r74EE 16r6838 16r7515 16r6839 16r7670 16r683A 16r7FC1 16r683B 16r9095 16r683C 16r96CD 16r683D 16r9954 16r683E 16r6E26 16r683F 16r74E6 16r6840 16r7AA9 16r6841 16r7AAA 16r6842 16r81E5 16r6843 16r86D9 16r6844 16r8778 16r6845 16r8A1B 16r6846 16r5A49 16r6847 16r5B8C 16r6848 16r5B9B 16r6849 16r68A1 16r684A 16r6900 16r684B 16r6D63 16r684C 16r73A9 16r684D 16r7413 16r684E 16r742C 16r684F 16r7897 16r6850 16r7DE9 16r6851 16r7FEB 16r6852 16r8118 16r6853 16r8155 16r6854 16r839E 16r6855 16r8C4C 16r6856 16r962E 16r6857 16r9811 16r6858 16r66F0 16r6859 16r5F80 16r685A 16r65FA 16r685B 16r6789 16r685C 16r6C6A 16r685D 16r738B 16r685E 16r502D 16r685F 16r5A03 16r6860 16r6B6A 16r6861 16r77EE 16r6862 16r5916 16r6863 16r5D6C 16r6864 16r5DCD 16r6865 16r7325 16r6866 16r754F 16r6867 16rF9BA 16r6868 16rF9BB 16r6869 16r50E5 16r686A 16r51F9 16r686B 16r582F 16r686C 16r592D 16r686D 16r5996 16r686E 16r59DA 16r686F 16r5BE5 16r6870 16rF9BC 16r6871 16rF9BD 16r6872 16r5DA2 16r6873 16r62D7 16r6874 16r6416 16r6875 16r6493 16r6876 16r64FE 16r6877 16rF9BE 16r6878 16r66DC 16r6879 16rF9BF 16r687A 16r6A48 16r687B 16rF9C0 16r687C 16r71FF 16r687D 16r7464 16r687E 16rF9C1 16r6921 16r7A88 16r6922 16r7AAF 16r6923 16r7E47 16r6924 16r7E5E 16r6925 16r8000 16r6926 16r8170 16r6927 16rF9C2 16r6928 16r87EF 16r6929 16r8981 16r692A 16r8B20 16r692B 16r9059 16r692C 16rF9C3 16r692D 16r9080 16r692E 16r9952 16r692F 16r617E 16r6930 16r6B32 16r6931 16r6D74 16r6932 16r7E1F 16r6933 16r8925 16r6934 16r8FB1 16r6935 16r4FD1 16r6936 16r50AD 16r6937 16r5197 16r6938 16r52C7 16r6939 16r57C7 16r693A 16r5889 16r693B 16r5BB9 16r693C 16r5EB8 16r693D 16r6142 16r693E 16r6995 16r693F 16r6D8C 16r6940 16r6E67 16r6941 16r6EB6 16r6942 16r7194 16r6943 16r7462 16r6944 16r7528 16r6945 16r752C 16r6946 16r8073 16r6947 16r8338 16r6948 16r84C9 16r6949 16r8E0A 16r694A 16r9394 16r694B 16r93DE 16r694C 16rF9C4 16r694D 16r4E8E 16r694E 16r4F51 16r694F 16r5076 16r6950 16r512A 16r6951 16r53C8 16r6952 16r53CB 16r6953 16r53F3 16r6954 16r5B87 16r6955 16r5BD3 16r6956 16r5C24 16r6957 16r611A 16r6958 16r6182 16r6959 16r65F4 16r695A 16r725B 16r695B 16r7397 16r695C 16r7440 16r695D 16r76C2 16r695E 16r7950 16r695F 16r7991 16r6960 16r79B9 16r6961 16r7D06 16r6962 16r7FBD 16r6963 16r828B 16r6964 16r85D5 16r6965 16r865E 16r6966 16r8FC2 16r6967 16r9047 16r6968 16r90F5 16r6969 16r91EA 16r696A 16r9685 16r696B 16r96E8 16r696C 16r96E9 16r696D 16r52D6 16r696E 16r5F67 16r696F 16r65ED 16r6970 16r6631 16r6971 16r682F 16r6972 16r715C 16r6973 16r7A36 16r6974 16r90C1 16r6975 16r980A 16r6976 16r4E91 16r6977 16rF9C5 16r6978 16r6A52 16r6979 16r6B9E 16r697A 16r6F90 16r697B 16r7189 16r697C 16r8018 16r697D 16r82B8 16r697E 16r8553 16r6A21 16r904B 16r6A22 16r9695 16r6A23 16r96F2 16r6A24 16r97FB 16r6A25 16r851A 16r6A26 16r9B31 16r6A27 16r4E90 16r6A28 16r718A 16r6A29 16r96C4 16r6A2A 16r5143 16r6A2B 16r539F 16r6A2C 16r54E1 16r6A2D 16r5713 16r6A2E 16r5712 16r6A2F 16r57A3 16r6A30 16r5A9B 16r6A31 16r5AC4 16r6A32 16r5BC3 16r6A33 16r6028 16r6A34 16r613F 16r6A35 16r63F4 16r6A36 16r6C85 16r6A37 16r6D39 16r6A38 16r6E72 16r6A39 16r6E90 16r6A3A 16r7230 16r6A3B 16r733F 16r6A3C 16r7457 16r6A3D 16r82D1 16r6A3E 16r8881 16r6A3F 16r8F45 16r6A40 16r9060 16r6A41 16rF9C6 16r6A42 16r9662 16r6A43 16r9858 16r6A44 16r9D1B 16r6A45 16r6708 16r6A46 16r8D8A 16r6A47 16r925E 16r6A48 16r4F4D 16r6A49 16r5049 16r6A4A 16r50DE 16r6A4B 16r5371 16r6A4C 16r570D 16r6A4D 16r59D4 16r6A4E 16r5A01 16r6A4F 16r5C09 16r6A50 16r6170 16r6A51 16r6690 16r6A52 16r6E2D 16r6A53 16r7232 16r6A54 16r744B 16r6A55 16r7DEF 16r6A56 16r80C3 16r6A57 16r840E 16r6A58 16r8466 16r6A59 16r853F 16r6A5A 16r875F 16r6A5B 16r885B 16r6A5C 16r8918 16r6A5D 16r8B02 16r6A5E 16r9055 16r6A5F 16r97CB 16r6A60 16r9B4F 16r6A61 16r4E73 16r6A62 16r4F91 16r6A63 16r5112 16r6A64 16r516A 16r6A65 16rF9C7 16r6A66 16r552F 16r6A67 16r55A9 16r6A68 16r5B7A 16r6A69 16r5BA5 16r6A6A 16r5E7C 16r6A6B 16r5E7D 16r6A6C 16r5EBE 16r6A6D 16r60A0 16r6A6E 16r60DF 16r6A6F 16r6108 16r6A70 16r6109 16r6A71 16r63C4 16r6A72 16r6538 16r6A73 16r6709 16r6A74 16rF9C8 16r6A75 16r67D4 16r6A76 16r67DA 16r6A77 16rF9C9 16r6A78 16r6961 16r6A79 16r6962 16r6A7A 16r6CB9 16r6A7B 16r6D27 16r6A7C 16rF9CA 16r6A7D 16r6E38 16r6A7E 16rF9CB 16r6B21 16r6FE1 16r6B22 16r7336 16r6B23 16r7337 16r6B24 16rF9CC 16r6B25 16r745C 16r6B26 16r7531 16r6B27 16rF9CD 16r6B28 16r7652 16r6B29 16rF9CE 16r6B2A 16rF9CF 16r6B2B 16r7DAD 16r6B2C 16r81FE 16r6B2D 16r8438 16r6B2E 16r88D5 16r6B2F 16r8A98 16r6B30 16r8ADB 16r6B31 16r8AED 16r6B32 16r8E30 16r6B33 16r8E42 16r6B34 16r904A 16r6B35 16r903E 16r6B36 16r907A 16r6B37 16r9149 16r6B38 16r91C9 16r6B39 16r936E 16r6B3A 16rF9D0 16r6B3B 16rF9D1 16r6B3C 16r5809 16r6B3D 16rF9D2 16r6B3E 16r6BD3 16r6B3F 16r8089 16r6B40 16r80B2 16r6B41 16rF9D3 16r6B42 16rF9D4 16r6B43 16r5141 16r6B44 16r596B 16r6B45 16r5C39 16r6B46 16rF9D5 16r6B47 16rF9D6 16r6B48 16r6F64 16r6B49 16r73A7 16r6B4A 16r80E4 16r6B4B 16r8D07 16r6B4C 16rF9D7 16r6B4D 16r9217 16r6B4E 16r958F 16r6B4F 16rF9D8 16r6B50 16rF9D9 16r6B51 16rF9DA 16r6B52 16rF9DB 16r6B53 16r807F 16r6B54 16r620E 16r6B55 16r701C 16r6B56 16r7D68 16r6B57 16r878D 16r6B58 16rF9DC 16r6B59 16r57A0 16r6B5A 16r6069 16r6B5B 16r6147 16r6B5C 16r6BB7 16r6B5D 16r8ABE 16r6B5E 16r9280 16r6B5F 16r96B1 16r6B60 16r4E59 16r6B61 16r541F 16r6B62 16r6DEB 16r6B63 16r852D 16r6B64 16r9670 16r6B65 16r97F3 16r6B66 16r98EE 16r6B67 16r63D6 16r6B68 16r6CE3 16r6B69 16r9091 16r6B6A 16r51DD 16r6B6B 16r61C9 16r6B6C 16r81BA 16r6B6D 16r9DF9 16r6B6E 16r4F9D 16r6B6F 16r501A 16r6B70 16r5100 16r6B71 16r5B9C 16r6B72 16r610F 16r6B73 16r61FF 16r6B74 16r64EC 16r6B75 16r6905 16r6B76 16r6BC5 16r6B77 16r7591 16r6B78 16r77E3 16r6B79 16r7FA9 16r6B7A 16r8264 16r6B7B 16r858F 16r6B7C 16r87FB 16r6B7D 16r8863 16r6B7E 16r8ABC 16r6C21 16r8B70 16r6C22 16r91AB 16r6C23 16r4E8C 16r6C24 16r4EE5 16r6C25 16r4F0A 16r6C26 16rF9DD 16r6C27 16rF9DE 16r6C28 16r5937 16r6C29 16r59E8 16r6C2A 16rF9DF 16r6C2B 16r5DF2 16r6C2C 16r5F1B 16r6C2D 16r5F5B 16r6C2E 16r6021 16r6C2F 16rF9E0 16r6C30 16rF9E1 16r6C31 16rF9E2 16r6C32 16rF9E3 16r6C33 16r723E 16r6C34 16r73E5 16r6C35 16rF9E4 16r6C36 16r7570 16r6C37 16r75CD 16r6C38 16rF9E5 16r6C39 16r79FB 16r6C3A 16rF9E6 16r6C3B 16r800C 16r6C3C 16r8033 16r6C3D 16r8084 16r6C3E 16r82E1 16r6C3F 16r8351 16r6C40 16rF9E7 16r6C41 16rF9E8 16r6C42 16r8CBD 16r6C43 16r8CB3 16r6C44 16r9087 16r6C45 16rF9E9 16r6C46 16rF9EA 16r6C47 16r98F4 16r6C48 16r990C 16r6C49 16rF9EB 16r6C4A 16rF9EC 16r6C4B 16r7037 16r6C4C 16r76CA 16r6C4D 16r7FCA 16r6C4E 16r7FCC 16r6C4F 16r7FFC 16r6C50 16r8B1A 16r6C51 16r4EBA 16r6C52 16r4EC1 16r6C53 16r5203 16r6C54 16r5370 16r6C55 16rF9ED 16r6C56 16r54BD 16r6C57 16r56E0 16r6C58 16r59FB 16r6C59 16r5BC5 16r6C5A 16r5F15 16r6C5B 16r5FCD 16r6C5C 16r6E6E 16r6C5D 16rF9EE 16r6C5E 16rF9EF 16r6C5F 16r7D6A 16r6C60 16r8335 16r6C61 16rF9F0 16r6C62 16r8693 16r6C63 16r8A8D 16r6C64 16rF9F1 16r6C65 16r976D 16r6C66 16r9777 16r6C67 16rF9F2 16r6C68 16rF9F3 16r6C69 16r4E00 16r6C6A 16r4F5A 16r6C6B 16r4F7E 16r6C6C 16r58F9 16r6C6D 16r65E5 16r6C6E 16r6EA2 16r6C6F 16r9038 16r6C70 16r93B0 16r6C71 16r99B9 16r6C72 16r4EFB 16r6C73 16r58EC 16r6C74 16r598A 16r6C75 16r59D9 16r6C76 16r6041 16r6C77 16rF9F4 16r6C78 16rF9F5 16r6C79 16r7A14 16r6C7A 16rF9F6 16r6C7B 16r834F 16r6C7C 16r8CC3 16r6C7D 16r5165 16r6C7E 16r5344 16r6D21 16rF9F7 16r6D22 16rF9F8 16r6D23 16rF9F9 16r6D24 16r4ECD 16r6D25 16r5269 16r6D26 16r5B55 16r6D27 16r82BF 16r6D28 16r4ED4 16r6D29 16r523A 16r6D2A 16r54A8 16r6D2B 16r59C9 16r6D2C 16r59FF 16r6D2D 16r5B50 16r6D2E 16r5B57 16r6D2F 16r5B5C 16r6D30 16r6063 16r6D31 16r6148 16r6D32 16r6ECB 16r6D33 16r7099 16r6D34 16r716E 16r6D35 16r7386 16r6D36 16r74F7 16r6D37 16r75B5 16r6D38 16r78C1 16r6D39 16r7D2B 16r6D3A 16r8005 16r6D3B 16r81EA 16r6D3C 16r8328 16r6D3D 16r8517 16r6D3E 16r85C9 16r6D3F 16r8AEE 16r6D40 16r8CC7 16r6D41 16r96CC 16r6D42 16r4F5C 16r6D43 16r52FA 16r6D44 16r56BC 16r6D45 16r65AB 16r6D46 16r6628 16r6D47 16r707C 16r6D48 16r70B8 16r6D49 16r7235 16r6D4A 16r7DBD 16r6D4B 16r828D 16r6D4C 16r914C 16r6D4D 16r96C0 16r6D4E 16r9D72 16r6D4F 16r5B71 16r6D50 16r68E7 16r6D51 16r6B98 16r6D52 16r6F7A 16r6D53 16r76DE 16r6D54 16r5C91 16r6D55 16r66AB 16r6D56 16r6F5B 16r6D57 16r7BB4 16r6D58 16r7C2A 16r6D59 16r8836 16r6D5A 16r96DC 16r6D5B 16r4E08 16r6D5C 16r4ED7 16r6D5D 16r5320 16r6D5E 16r5834 16r6D5F 16r58BB 16r6D60 16r58EF 16r6D61 16r596C 16r6D62 16r5C07 16r6D63 16r5E33 16r6D64 16r5E84 16r6D65 16r5F35 16r6D66 16r638C 16r6D67 16r66B2 16r6D68 16r6756 16r6D69 16r6A1F 16r6D6A 16r6AA3 16r6D6B 16r6B0C 16r6D6C 16r6F3F 16r6D6D 16r7246 16r6D6E 16rF9FA 16r6D6F 16r7350 16r6D70 16r748B 16r6D71 16r7AE0 16r6D72 16r7CA7 16r6D73 16r8178 16r6D74 16r81DF 16r6D75 16r81E7 16r6D76 16r838A 16r6D77 16r846C 16r6D78 16r8523 16r6D79 16r8594 16r6D7A 16r85CF 16r6D7B 16r88DD 16r6D7C 16r8D13 16r6D7D 16r91AC 16r6D7E 16r9577 16r6E21 16r969C 16r6E22 16r518D 16r6E23 16r54C9 16r6E24 16r5728 16r6E25 16r5BB0 16r6E26 16r624D 16r6E27 16r6750 16r6E28 16r683D 16r6E29 16r6893 16r6E2A 16r6E3D 16r6E2B 16r6ED3 16r6E2C 16r707D 16r6E2D 16r7E21 16r6E2E 16r88C1 16r6E2F 16r8CA1 16r6E30 16r8F09 16r6E31 16r9F4B 16r6E32 16r9F4E 16r6E33 16r722D 16r6E34 16r7B8F 16r6E35 16r8ACD 16r6E36 16r931A 16r6E37 16r4F47 16r6E38 16r4F4E 16r6E39 16r5132 16r6E3A 16r5480 16r6E3B 16r59D0 16r6E3C 16r5E95 16r6E3D 16r62B5 16r6E3E 16r6775 16r6E3F 16r696E 16r6E40 16r6A17 16r6E41 16r6CAE 16r6E42 16r6E1A 16r6E43 16r72D9 16r6E44 16r732A 16r6E45 16r75BD 16r6E46 16r7BB8 16r6E47 16r7D35 16r6E48 16r82E7 16r6E49 16r83F9 16r6E4A 16r8457 16r6E4B 16r85F7 16r6E4C 16r8A5B 16r6E4D 16r8CAF 16r6E4E 16r8E87 16r6E4F 16r9019 16r6E50 16r90B8 16r6E51 16r96CE 16r6E52 16r9F5F 16r6E53 16r52E3 16r6E54 16r540A 16r6E55 16r5AE1 16r6E56 16r5BC2 16r6E57 16r6458 16r6E58 16r6575 16r6E59 16r6EF4 16r6E5A 16r72C4 16r6E5B 16rF9FB 16r6E5C 16r7684 16r6E5D 16r7A4D 16r6E5E 16r7B1B 16r6E5F 16r7C4D 16r6E60 16r7E3E 16r6E61 16r7FDF 16r6E62 16r837B 16r6E63 16r8B2B 16r6E64 16r8CCA 16r6E65 16r8D64 16r6E66 16r8DE1 16r6E67 16r8E5F 16r6E68 16r8FEA 16r6E69 16r8FF9 16r6E6A 16r9069 16r6E6B 16r93D1 16r6E6C 16r4F43 16r6E6D 16r4F7A 16r6E6E 16r50B3 16r6E6F 16r5168 16r6E70 16r5178 16r6E71 16r524D 16r6E72 16r526A 16r6E73 16r5861 16r6E74 16r587C 16r6E75 16r5960 16r6E76 16r5C08 16r6E77 16r5C55 16r6E78 16r5EDB 16r6E79 16r609B 16r6E7A 16r6230 16r6E7B 16r6813 16r6E7C 16r6BBF 16r6E7D 16r6C08 16r6E7E 16r6FB1 16r6F21 16r714E 16r6F22 16r7420 16r6F23 16r7530 16r6F24 16r7538 16r6F25 16r7551 16r6F26 16r7672 16r6F27 16r7B4C 16r6F28 16r7B8B 16r6F29 16r7BAD 16r6F2A 16r7BC6 16r6F2B 16r7E8F 16r6F2C 16r8A6E 16r6F2D 16r8F3E 16r6F2E 16r8F49 16r6F2F 16r923F 16r6F30 16r9293 16r6F31 16r9322 16r6F32 16r942B 16r6F33 16r96FB 16r6F34 16r985A 16r6F35 16r986B 16r6F36 16r991E 16r6F37 16r5207 16r6F38 16r622A 16r6F39 16r6298 16r6F3A 16r6D59 16r6F3B 16r7664 16r6F3C 16r7ACA 16r6F3D 16r7BC0 16r6F3E 16r7D76 16r6F3F 16r5360 16r6F40 16r5CBE 16r6F41 16r5E97 16r6F42 16r6F38 16r6F43 16r70B9 16r6F44 16r7C98 16r6F45 16r9711 16r6F46 16r9B8E 16r6F47 16r9EDE 16r6F48 16r63A5 16r6F49 16r647A 16r6F4A 16r8776 16r6F4B 16r4E01 16r6F4C 16r4E95 16r6F4D 16r4EAD 16r6F4E 16r505C 16r6F4F 16r5075 16r6F50 16r5448 16r6F51 16r59C3 16r6F52 16r5B9A 16r6F53 16r5E40 16r6F54 16r5EAD 16r6F55 16r5EF7 16r6F56 16r5F81 16r6F57 16r60C5 16r6F58 16r633A 16r6F59 16r653F 16r6F5A 16r6574 16r6F5B 16r65CC 16r6F5C 16r6676 16r6F5D 16r6678 16r6F5E 16r67FE 16r6F5F 16r6968 16r6F60 16r6A89 16r6F61 16r6B63 16r6F62 16r6C40 16r6F63 16r6DC0 16r6F64 16r6DE8 16r6F65 16r6E1F 16r6F66 16r6E5E 16r6F67 16r701E 16r6F68 16r70A1 16r6F69 16r738E 16r6F6A 16r73FD 16r6F6B 16r753A 16r6F6C 16r775B 16r6F6D 16r7887 16r6F6E 16r798E 16r6F6F 16r7A0B 16r6F70 16r7A7D 16r6F71 16r7CBE 16r6F72 16r7D8E 16r6F73 16r8247 16r6F74 16r8A02 16r6F75 16r8AEA 16r6F76 16r8C9E 16r6F77 16r912D 16r6F78 16r914A 16r6F79 16r91D8 16r6F7A 16r9266 16r6F7B 16r92CC 16r6F7C 16r9320 16r6F7D 16r9706 16r6F7E 16r9756 16r7021 16r975C 16r7022 16r9802 16r7023 16r9F0E 16r7024 16r5236 16r7025 16r5291 16r7026 16r557C 16r7027 16r5824 16r7028 16r5E1D 16r7029 16r5F1F 16r702A 16r608C 16r702B 16r63D0 16r702C 16r68AF 16r702D 16r6FDF 16r702E 16r796D 16r702F 16r7B2C 16r7030 16r81CD 16r7031 16r85BA 16r7032 16r88FD 16r7033 16r8AF8 16r7034 16r8E44 16r7035 16r918D 16r7036 16r9664 16r7037 16r969B 16r7038 16r973D 16r7039 16r984C 16r703A 16r9F4A 16r703B 16r4FCE 16r703C 16r5146 16r703D 16r51CB 16r703E 16r52A9 16r703F 16r5632 16r7040 16r5F14 16r7041 16r5F6B 16r7042 16r63AA 16r7043 16r64CD 16r7044 16r65E9 16r7045 16r6641 16r7046 16r66FA 16r7047 16r66F9 16r7048 16r671D 16r7049 16r689D 16r704A 16r68D7 16r704B 16r69FD 16r704C 16r6F15 16r704D 16r6F6E 16r704E 16r7167 16r704F 16r71E5 16r7050 16r722A 16r7051 16r74AA 16r7052 16r773A 16r7053 16r7956 16r7054 16r795A 16r7055 16r79DF 16r7056 16r7A20 16r7057 16r7A95 16r7058 16r7C97 16r7059 16r7CDF 16r705A 16r7D44 16r705B 16r7E70 16r705C 16r8087 16r705D 16r85FB 16r705E 16r86A4 16r705F 16r8A54 16r7060 16r8ABF 16r7061 16r8D99 16r7062 16r8E81 16r7063 16r9020 16r7064 16r906D 16r7065 16r91E3 16r7066 16r963B 16r7067 16r96D5 16r7068 16r9CE5 16r7069 16r65CF 16r706A 16r7C07 16r706B 16r8DB3 16r706C 16r93C3 16r706D 16r5B58 16r706E 16r5C0A 16r706F 16r5352 16r7070 16r62D9 16r7071 16r731D 16r7072 16r5027 16r7073 16r5B97 16r7074 16r5F9E 16r7075 16r60B0 16r7076 16r616B 16r7077 16r68D5 16r7078 16r6DD9 16r7079 16r742E 16r707A 16r7A2E 16r707B 16r7D42 16r707C 16r7D9C 16r707D 16r7E31 16r707E 16r816B 16r7121 16r8E2A 16r7122 16r8E35 16r7123 16r937E 16r7124 16r9418 16r7125 16r4F50 16r7126 16r5750 16r7127 16r5DE6 16r7128 16r5EA7 16r7129 16r632B 16r712A 16r7F6A 16r712B 16r4E3B 16r712C 16r4F4F 16r712D 16r4F8F 16r712E 16r505A 16r712F 16r59DD 16r7130 16r80C4 16r7131 16r546A 16r7132 16r5468 16r7133 16r55FE 16r7134 16r594F 16r7135 16r5B99 16r7136 16r5DDE 16r7137 16r5EDA 16r7138 16r665D 16r7139 16r6731 16r713A 16r67F1 16r713B 16r682A 16r713C 16r6CE8 16r713D 16r6D32 16r713E 16r6E4A 16r713F 16r6F8D 16r7140 16r70B7 16r7141 16r73E0 16r7142 16r7587 16r7143 16r7C4C 16r7144 16r7D02 16r7145 16r7D2C 16r7146 16r7DA2 16r7147 16r821F 16r7148 16r86DB 16r7149 16r8A3B 16r714A 16r8A85 16r714B 16r8D70 16r714C 16r8E8A 16r714D 16r8F33 16r714E 16r9031 16r714F 16r914E 16r7150 16r9152 16r7151 16r9444 16r7152 16r99D0 16r7153 16r7AF9 16r7154 16r7CA5 16r7155 16r4FCA 16r7156 16r5101 16r7157 16r51C6 16r7158 16r57C8 16r7159 16r5BEF 16r715A 16r5CFB 16r715B 16r6659 16r715C 16r6A3D 16r715D 16r6D5A 16r715E 16r6E96 16r715F 16r6FEC 16r7160 16r710C 16r7161 16r756F 16r7162 16r7AE3 16r7163 16r8822 16r7164 16r9021 16r7165 16r9075 16r7166 16r96CB 16r7167 16r99FF 16r7168 16r8301 16r7169 16r4E2D 16r716A 16r4EF2 16r716B 16r8846 16r716C 16r91CD 16r716D 16r537D 16r716E 16r6ADB 16r716F 16r696B 16r7170 16r6C41 16r7171 16r847A 16r7172 16r589E 16r7173 16r618E 16r7174 16r66FE 16r7175 16r62EF 16r7176 16r70DD 16r7177 16r7511 16r7178 16r75C7 16r7179 16r7E52 16r717A 16r84B8 16r717B 16r8B49 16r717C 16r8D08 16r717D 16r4E4B 16r717E 16r53EA 16r7221 16r54AB 16r7222 16r5730 16r7223 16r5740 16r7224 16r5FD7 16r7225 16r6301 16r7226 16r6307 16r7227 16r646F 16r7228 16r652F 16r7229 16r65E8 16r722A 16r667A 16r722B 16r679D 16r722C 16r67B3 16r722D 16r6B62 16r722E 16r6C60 16r722F 16r6C9A 16r7230 16r6F2C 16r7231 16r77E5 16r7232 16r7825 16r7233 16r7949 16r7234 16r7957 16r7235 16r7D19 16r7236 16r80A2 16r7237 16r8102 16r7238 16r81F3 16r7239 16r829D 16r723A 16r82B7 16r723B 16r8718 16r723C 16r8A8C 16r723D 16rF9FC 16r723E 16r8D04 16r723F 16r8DBE 16r7240 16r9072 16r7241 16r76F4 16r7242 16r7A19 16r7243 16r7A37 16r7244 16r7E54 16r7245 16r8077 16r7246 16r5507 16r7247 16r55D4 16r7248 16r5875 16r7249 16r632F 16r724A 16r6422 16r724B 16r6649 16r724C 16r664B 16r724D 16r686D 16r724E 16r699B 16r724F 16r6B84 16r7250 16r6D25 16r7251 16r6EB1 16r7252 16r73CD 16r7253 16r7468 16r7254 16r74A1 16r7255 16r755B 16r7256 16r75B9 16r7257 16r76E1 16r7258 16r771E 16r7259 16r778B 16r725A 16r79E6 16r725B 16r7E09 16r725C 16r7E1D 16r725D 16r81FB 16r725E 16r852F 16r725F 16r8897 16r7260 16r8A3A 16r7261 16r8CD1 16r7262 16r8EEB 16r7263 16r8FB0 16r7264 16r9032 16r7265 16r93AD 16r7266 16r9663 16r7267 16r9673 16r7268 16r9707 16r7269 16r4F84 16r726A 16r53F1 16r726B 16r59EA 16r726C 16r5AC9 16r726D 16r5E19 16r726E 16r684E 16r726F 16r74C6 16r7270 16r75BE 16r7271 16r79E9 16r7272 16r7A92 16r7273 16r81A3 16r7274 16r86ED 16r7275 16r8CEA 16r7276 16r8DCC 16r7277 16r8FED 16r7278 16r659F 16r7279 16r6715 16r727A 16rF9FD 16r727B 16r57F7 16r727C 16r6F57 16r727D 16r7DDD 16r727E 16r8F2F 16r7321 16r93F6 16r7322 16r96C6 16r7323 16r5FB5 16r7324 16r61F2 16r7325 16r6F84 16r7326 16r4E14 16r7327 16r4F98 16r7328 16r501F 16r7329 16r53C9 16r732A 16r55DF 16r732B 16r5D6F 16r732C 16r5DEE 16r732D 16r6B21 16r732E 16r6B64 16r732F 16r78CB 16r7330 16r7B9A 16r7331 16rF9FE 16r7332 16r8E49 16r7333 16r8ECA 16r7334 16r906E 16r7335 16r6349 16r7336 16r643E 16r7337 16r7740 16r7338 16r7A84 16r7339 16r932F 16r733A 16r947F 16r733B 16r9F6A 16r733C 16r64B0 16r733D 16r6FAF 16r733E 16r71E6 16r733F 16r74A8 16r7340 16r74DA 16r7341 16r7AC4 16r7342 16r7C12 16r7343 16r7E82 16r7344 16r7CB2 16r7345 16r7E98 16r7346 16r8B9A 16r7347 16r8D0A 16r7348 16r947D 16r7349 16r9910 16r734A 16r994C 16r734B 16r5239 16r734C 16r5BDF 16r734D 16r64E6 16r734E 16r672D 16r734F 16r7D2E 16r7350 16r50ED 16r7351 16r53C3 16r7352 16r5879 16r7353 16r6158 16r7354 16r6159 16r7355 16r61FA 16r7356 16r65AC 16r7357 16r7AD9 16r7358 16r8B92 16r7359 16r8B96 16r735A 16r5009 16r735B 16r5021 16r735C 16r5275 16r735D 16r5531 16r735E 16r5A3C 16r735F 16r5EE0 16r7360 16r5F70 16r7361 16r6134 16r7362 16r655E 16r7363 16r660C 16r7364 16r6636 16r7365 16r66A2 16r7366 16r69CD 16r7367 16r6EC4 16r7368 16r6F32 16r7369 16r7316 16r736A 16r7621 16r736B 16r7A93 16r736C 16r8139 16r736D 16r8259 16r736E 16r83D6 16r736F 16r84BC 16r7370 16r50B5 16r7371 16r57F0 16r7372 16r5BC0 16r7373 16r5BE8 16r7374 16r5F69 16r7375 16r63A1 16r7376 16r7826 16r7377 16r7DB5 16r7378 16r83DC 16r7379 16r8521 16r737A 16r91C7 16r737B 16r91F5 16r737C 16r518A 16r737D 16r67F5 16r737E 16r7B56 16r7421 16r8CAC 16r7422 16r51C4 16r7423 16r59BB 16r7424 16r60BD 16r7425 16r8655 16r7426 16r501C 16r7427 16rF9FF 16r7428 16r5254 16r7429 16r5C3A 16r742A 16r617D 16r742B 16r621A 16r742C 16r62D3 16r742D 16r64F2 16r742E 16r65A5 16r742F 16r6ECC 16r7430 16r7620 16r7431 16r810A 16r7432 16r8E60 16r7433 16r965F 16r7434 16r96BB 16r7435 16r4EDF 16r7436 16r5343 16r7437 16r5598 16r7438 16r5929 16r7439 16r5DDD 16r743A 16r64C5 16r743B 16r6CC9 16r743C 16r6DFA 16r743D 16r7394 16r743E 16r7A7F 16r743F 16r821B 16r7440 16r85A6 16r7441 16r8CE4 16r7442 16r8E10 16r7443 16r9077 16r7444 16r91E7 16r7445 16r95E1 16r7446 16r9621 16r7447 16r97C6 16r7448 16r51F8 16r7449 16r54F2 16r744A 16r5586 16r744B 16r5FB9 16r744C 16r64A4 16r744D 16r6F88 16r744E 16r7DB4 16r744F 16r8F1F 16r7450 16r8F4D 16r7451 16r9435 16r7452 16r50C9 16r7453 16r5C16 16r7454 16r6CBE 16r7455 16r6DFB 16r7456 16r751B 16r7457 16r77BB 16r7458 16r7C3D 16r7459 16r7C64 16r745A 16r8A79 16r745B 16r8AC2 16r745C 16r581E 16r745D 16r59BE 16r745E 16r5E16 16r745F 16r6377 16r7460 16r7252 16r7461 16r758A 16r7462 16r776B 16r7463 16r8ADC 16r7464 16r8CBC 16r7465 16r8F12 16r7466 16r5EF3 16r7467 16r6674 16r7468 16r6DF8 16r7469 16r807D 16r746A 16r83C1 16r746B 16r8ACB 16r746C 16r9751 16r746D 16r9BD6 16r746E 16rFA00 16r746F 16r5243 16r7470 16r66FF 16r7471 16r6D95 16r7472 16r6EEF 16r7473 16r7DE0 16r7474 16r8AE6 16r7475 16r902E 16r7476 16r905E 16r7477 16r9AD4 16r7478 16r521D 16r7479 16r527F 16r747A 16r54E8 16r747B 16r6194 16r747C 16r6284 16r747D 16r62DB 16r747E 16r68A2 16r7521 16r6912 16r7522 16r695A 16r7523 16r6A35 16r7524 16r7092 16r7525 16r7126 16r7526 16r785D 16r7527 16r7901 16r7528 16r790E 16r7529 16r79D2 16r752A 16r7A0D 16r752B 16r8096 16r752C 16r8278 16r752D 16r82D5 16r752E 16r8349 16r752F 16r8549 16r7530 16r8C82 16r7531 16r8D85 16r7532 16r9162 16r7533 16r918B 16r7534 16r91AE 16r7535 16r4FC3 16r7536 16r56D1 16r7537 16r71ED 16r7538 16r77D7 16r7539 16r8700 16r753A 16r89F8 16r753B 16r5BF8 16r753C 16r5FD6 16r753D 16r6751 16r753E 16r90A8 16r753F 16r53E2 16r7540 16r585A 16r7541 16r5BF5 16r7542 16r60A4 16r7543 16r6181 16r7544 16r6460 16r7545 16r7E3D 16r7546 16r8070 16r7547 16r8525 16r7548 16r9283 16r7549 16r64AE 16r754A 16r50AC 16r754B 16r5D14 16r754C 16r6700 16r754D 16r589C 16r754E 16r62BD 16r754F 16r63A8 16r7550 16r690E 16r7551 16r6978 16r7552 16r6A1E 16r7553 16r6E6B 16r7554 16r76BA 16r7555 16r79CB 16r7556 16r82BB 16r7557 16r8429 16r7558 16r8ACF 16r7559 16r8DA8 16r755A 16r8FFD 16r755B 16r9112 16r755C 16r914B 16r755D 16r919C 16r755E 16r9310 16r755F 16r9318 16r7560 16r939A 16r7561 16r96DB 16r7562 16r9A36 16r7563 16r9C0D 16r7564 16r4E11 16r7565 16r755C 16r7566 16r795D 16r7567 16r7AFA 16r7568 16r7B51 16r7569 16r7BC9 16r756A 16r7E2E 16r756B 16r84C4 16r756C 16r8E59 16r756D 16r8E74 16r756E 16r8EF8 16r756F 16r9010 16r7570 16r6625 16r7571 16r693F 16r7572 16r7443 16r7573 16r51FA 16r7574 16r672E 16r7575 16r9EDC 16r7576 16r5145 16r7577 16r5FE0 16r7578 16r6C96 16r7579 16r87F2 16r757A 16r885D 16r757B 16r8877 16r757C 16r60B4 16r757D 16r81B5 16r757E 16r8403 16r7621 16r8D05 16r7622 16r53D6 16r7623 16r5439 16r7624 16r5634 16r7625 16r5A36 16r7626 16r5C31 16r7627 16r708A 16r7628 16r7FE0 16r7629 16r805A 16r762A 16r8106 16r762B 16r81ED 16r762C 16r8DA3 16r762D 16r9189 16r762E 16r9A5F 16r762F 16r9DF2 16r7630 16r5074 16r7631 16r4EC4 16r7632 16r53A0 16r7633 16r60FB 16r7634 16r6E2C 16r7635 16r5C64 16r7636 16r4F88 16r7637 16r5024 16r7638 16r55E4 16r7639 16r5CD9 16r763A 16r5E5F 16r763B 16r6065 16r763C 16r6894 16r763D 16r6CBB 16r763E 16r6DC4 16r763F 16r71BE 16r7640 16r75D4 16r7641 16r75F4 16r7642 16r7661 16r7643 16r7A1A 16r7644 16r7A49 16r7645 16r7DC7 16r7646 16r7DFB 16r7647 16r7F6E 16r7648 16r81F4 16r7649 16r86A9 16r764A 16r8F1C 16r764B 16r96C9 16r764C 16r99B3 16r764D 16r9F52 16r764E 16r5247 16r764F 16r52C5 16r7650 16r98ED 16r7651 16r89AA 16r7652 16r4E03 16r7653 16r67D2 16r7654 16r6F06 16r7655 16r4FB5 16r7656 16r5BE2 16r7657 16r6795 16r7658 16r6C88 16r7659 16r6D78 16r765A 16r741B 16r765B 16r7827 16r765C 16r91DD 16r765D 16r937C 16r765E 16r87C4 16r765F 16r79E4 16r7660 16r7A31 16r7661 16r5FEB 16r7662 16r4ED6 16r7663 16r54A4 16r7664 16r553E 16r7665 16r58AE 16r7666 16r59A5 16r7667 16r60F0 16r7668 16r6253 16r7669 16r62D6 16r766A 16r6736 16r766B 16r6955 16r766C 16r8235 16r766D 16r9640 16r766E 16r99B1 16r766F 16r99DD 16r7670 16r502C 16r7671 16r5353 16r7672 16r5544 16r7673 16r577C 16r7674 16rFA01 16r7675 16r6258 16r7676 16rFA02 16r7677 16r64E2 16r7678 16r666B 16r7679 16r67DD 16r767A 16r6FC1 16r767B 16r6FEF 16r767C 16r7422 16r767D 16r7438 16r767E 16r8A17 16r7721 16r9438 16r7722 16r5451 16r7723 16r5606 16r7724 16r5766 16r7725 16r5F48 16r7726 16r619A 16r7727 16r6B4E 16r7728 16r7058 16r7729 16r70AD 16r772A 16r7DBB 16r772B 16r8A95 16r772C 16r596A 16r772D 16r812B 16r772E 16r63A2 16r772F 16r7708 16r7730 16r803D 16r7731 16r8CAA 16r7732 16r5854 16r7733 16r642D 16r7734 16r69BB 16r7735 16r5B95 16r7736 16r5E11 16r7737 16r6E6F 16r7738 16rFA03 16r7739 16r8569 16r773A 16r514C 16r773B 16r53F0 16r773C 16r592A 16r773D 16r6020 16r773E 16r614B 16r773F 16r6B86 16r7740 16r6C70 16r7741 16r6CF0 16r7742 16r7B1E 16r7743 16r80CE 16r7744 16r82D4 16r7745 16r8DC6 16r7746 16r90B0 16r7747 16r98B1 16r7748 16rFA04 16r7749 16r64C7 16r774A 16r6FA4 16r774B 16r6491 16r774C 16r6504 16r774D 16r514E 16r774E 16r5410 16r774F 16r571F 16r7750 16r8A0E 16r7751 16r615F 16r7752 16r6876 16r7753 16rFA05 16r7754 16r75DB 16r7755 16r7B52 16r7756 16r7D71 16r7757 16r901A 16r7758 16r5806 16r7759 16r69CC 16r775A 16r817F 16r775B 16r892A 16r775C 16r9000 16r775D 16r9839 16r775E 16r5078 16r775F 16r5957 16r7760 16r59AC 16r7761 16r6295 16r7762 16r900F 16r7763 16r9B2A 16r7764 16r615D 16r7765 16r7279 16r7766 16r95D6 16r7767 16r5761 16r7768 16r5A46 16r7769 16r5DF4 16r776A 16r628A 16r776B 16r64AD 16r776C 16r64FA 16r776D 16r6777 16r776E 16r6CE2 16r776F 16r6D3E 16r7770 16r722C 16r7771 16r7436 16r7772 16r7834 16r7773 16r7F77 16r7774 16r82AD 16r7775 16r8DDB 16r7776 16r9817 16r7777 16r5224 16r7778 16r5742 16r7779 16r677F 16r777A 16r7248 16r777B 16r74E3 16r777C 16r8CA9 16r777D 16r8FA6 16r777E 16r9211 16r7821 16r962A 16r7822 16r516B 16r7823 16r53ED 16r7824 16r634C 16r7825 16r4F69 16r7826 16r5504 16r7827 16r6096 16r7828 16r6557 16r7829 16r6C9B 16r782A 16r6D7F 16r782B 16r724C 16r782C 16r72FD 16r782D 16r7A17 16r782E 16r8987 16r782F 16r8C9D 16r7830 16r5F6D 16r7831 16r6F8E 16r7832 16r70F9 16r7833 16r81A8 16r7834 16r610E 16r7835 16r4FBF 16r7836 16r504F 16r7837 16r6241 16r7838 16r7247 16r7839 16r7BC7 16r783A 16r7DE8 16r783B 16r7FE9 16r783C 16r904D 16r783D 16r97AD 16r783E 16r9A19 16r783F 16r8CB6 16r7840 16r576A 16r7841 16r5E73 16r7842 16r67B0 16r7843 16r840D 16r7844 16r8A55 16r7845 16r5420 16r7846 16r5B16 16r7847 16r5E63 16r7848 16r5EE2 16r7849 16r5F0A 16r784A 16r6583 16r784B 16r80BA 16r784C 16r853D 16r784D 16r9589 16r784E 16r965B 16r784F 16r4F48 16r7850 16r5305 16r7851 16r530D 16r7852 16r530F 16r7853 16r5486 16r7854 16r54FA 16r7855 16r5703 16r7856 16r5E03 16r7857 16r6016 16r7858 16r629B 16r7859 16r62B1 16r785A 16r6355 16r785B 16rFA06 16r785C 16r6CE1 16r785D 16r6D66 16r785E 16r75B1 16r785F 16r7832 16r7860 16r80DE 16r7861 16r812F 16r7862 16r82DE 16r7863 16r8461 16r7864 16r84B2 16r7865 16r888D 16r7866 16r8912 16r7867 16r900B 16r7868 16r92EA 16r7869 16r98FD 16r786A 16r9B91 16r786B 16r5E45 16r786C 16r66B4 16r786D 16r66DD 16r786E 16r7011 16r786F 16r7206 16r7870 16rFA07 16r7871 16r4FF5 16r7872 16r527D 16r7873 16r5F6A 16r7874 16r6153 16r7875 16r6753 16r7876 16r6A19 16r7877 16r6F02 16r7878 16r74E2 16r7879 16r7968 16r787A 16r8868 16r787B 16r8C79 16r787C 16r98C7 16r787D 16r98C4 16r787E 16r9A43 16r7921 16r54C1 16r7922 16r7A1F 16r7923 16r6953 16r7924 16r8AF7 16r7925 16r8C4A 16r7926 16r98A8 16r7927 16r99AE 16r7928 16r5F7C 16r7929 16r62AB 16r792A 16r75B2 16r792B 16r76AE 16r792C 16r88AB 16r792D 16r907F 16r792E 16r9642 16r792F 16r5339 16r7930 16r5F3C 16r7931 16r5FC5 16r7932 16r6CCC 16r7933 16r73CC 16r7934 16r7562 16r7935 16r758B 16r7936 16r7B46 16r7937 16r82FE 16r7938 16r999D 16r7939 16r4E4F 16r793A 16r903C 16r793B 16r4E0B 16r793C 16r4F55 16r793D 16r53A6 16r793E 16r590F 16r793F 16r5EC8 16r7940 16r6630 16r7941 16r6CB3 16r7942 16r7455 16r7943 16r8377 16r7944 16r8766 16r7945 16r8CC0 16r7946 16r9050 16r7947 16r971E 16r7948 16r9C15 16r7949 16r58D1 16r794A 16r5B78 16r794B 16r8650 16r794C 16r8B14 16r794D 16r9DB4 16r794E 16r5BD2 16r794F 16r6068 16r7950 16r608D 16r7951 16r65F1 16r7952 16r6C57 16r7953 16r6F22 16r7954 16r6FA3 16r7955 16r701A 16r7956 16r7F55 16r7957 16r7FF0 16r7958 16r9591 16r7959 16r9592 16r795A 16r9650 16r795B 16r97D3 16r795C 16r5272 16r795D 16r8F44 16r795E 16r51FD 16r795F 16r542B 16r7960 16r54B8 16r7961 16r5563 16r7962 16r558A 16r7963 16r6ABB 16r7964 16r6DB5 16r7965 16r7DD8 16r7966 16r8266 16r7967 16r929C 16r7968 16r9677 16r7969 16r9E79 16r796A 16r5408 16r796B 16r54C8 16r796C 16r76D2 16r796D 16r86E4 16r796E 16r95A4 16r796F 16r95D4 16r7970 16r965C 16r7971 16r4EA2 16r7972 16r4F09 16r7973 16r59EE 16r7974 16r5AE6 16r7975 16r5DF7 16r7976 16r6052 16r7977 16r6297 16r7978 16r676D 16r7979 16r6841 16r797A 16r6C86 16r797B 16r6E2F 16r797C 16r7F38 16r797D 16r809B 16r797E 16r822A 16r7A21 16rFA08 16r7A22 16rFA09 16r7A23 16r9805 16r7A24 16r4EA5 16r7A25 16r5055 16r7A26 16r54B3 16r7A27 16r5793 16r7A28 16r595A 16r7A29 16r5B69 16r7A2A 16r5BB3 16r7A2B 16r61C8 16r7A2C 16r6977 16r7A2D 16r6D77 16r7A2E 16r7023 16r7A2F 16r87F9 16r7A30 16r89E3 16r7A31 16r8A72 16r7A32 16r8AE7 16r7A33 16r9082 16r7A34 16r99ED 16r7A35 16r9AB8 16r7A36 16r52BE 16r7A37 16r6838 16r7A38 16r5016 16r7A39 16r5E78 16r7A3A 16r674F 16r7A3B 16r8347 16r7A3C 16r884C 16r7A3D 16r4EAB 16r7A3E 16r5411 16r7A3F 16r56AE 16r7A40 16r73E6 16r7A41 16r9115 16r7A42 16r97FF 16r7A43 16r9909 16r7A44 16r9957 16r7A45 16r9999 16r7A46 16r5653 16r7A47 16r589F 16r7A48 16r865B 16r7A49 16r8A31 16r7A4A 16r61B2 16r7A4B 16r6AF6 16r7A4C 16r737B 16r7A4D 16r8ED2 16r7A4E 16r6B47 16r7A4F 16r96AA 16r7A50 16r9A57 16r7A51 16r5955 16r7A52 16r7200 16r7A53 16r8D6B 16r7A54 16r9769 16r7A55 16r4FD4 16r7A56 16r5CF4 16r7A57 16r5F26 16r7A58 16r61F8 16r7A59 16r665B 16r7A5A 16r6CEB 16r7A5B 16r70AB 16r7A5C 16r7384 16r7A5D 16r73B9 16r7A5E 16r73FE 16r7A5F 16r7729 16r7A60 16r774D 16r7A61 16r7D43 16r7A62 16r7D62 16r7A63 16r7E23 16r7A64 16r8237 16r7A65 16r8852 16r7A66 16rFA0A 16r7A67 16r8CE2 16r7A68 16r9249 16r7A69 16r986F 16r7A6A 16r5B51 16r7A6B 16r7A74 16r7A6C 16r8840 16r7A6D 16r9801 16r7A6E 16r5ACC 16r7A6F 16r4FE0 16r7A70 16r5354 16r7A71 16r593E 16r7A72 16r5CFD 16r7A73 16r633E 16r7A74 16r6D79 16r7A75 16r72F9 16r7A76 16r8105 16r7A77 16r8107 16r7A78 16r83A2 16r7A79 16r92CF 16r7A7A 16r9830 16r7A7B 16r4EA8 16r7A7C 16r5144 16r7A7D 16r5211 16r7A7E 16r578B 16r7B21 16r5F62 16r7B22 16r6CC2 16r7B23 16r6ECE 16r7B24 16r7005 16r7B25 16r7050 16r7B26 16r70AF 16r7B27 16r7192 16r7B28 16r73E9 16r7B29 16r7469 16r7B2A 16r834A 16r7B2B 16r87A2 16r7B2C 16r8861 16r7B2D 16r9008 16r7B2E 16r90A2 16r7B2F 16r93A3 16r7B30 16r99A8 16r7B31 16r516E 16r7B32 16r5F57 16r7B33 16r60E0 16r7B34 16r6167 16r7B35 16r66B3 16r7B36 16r8559 16r7B37 16r8E4A 16r7B38 16r91AF 16r7B39 16r978B 16r7B3A 16r4E4E 16r7B3B 16r4E92 16r7B3C 16r547C 16r7B3D 16r58D5 16r7B3E 16r58FA 16r7B3F 16r597D 16r7B40 16r5CB5 16r7B41 16r5F27 16r7B42 16r6236 16r7B43 16r6248 16r7B44 16r660A 16r7B45 16r6667 16r7B46 16r6BEB 16r7B47 16r6D69 16r7B48 16r6DCF 16r7B49 16r6E56 16r7B4A 16r6EF8 16r7B4B 16r6F94 16r7B4C 16r6FE0 16r7B4D 16r6FE9 16r7B4E 16r705D 16r7B4F 16r72D0 16r7B50 16r7425 16r7B51 16r745A 16r7B52 16r74E0 16r7B53 16r7693 16r7B54 16r795C 16r7B55 16r7CCA 16r7B56 16r7E1E 16r7B57 16r80E1 16r7B58 16r82A6 16r7B59 16r846B 16r7B5A 16r84BF 16r7B5B 16r864E 16r7B5C 16r865F 16r7B5D 16r8774 16r7B5E 16r8B77 16r7B5F 16r8C6A 16r7B60 16r93AC 16r7B61 16r9800 16r7B62 16r9865 16r7B63 16r60D1 16r7B64 16r6216 16r7B65 16r9177 16r7B66 16r5A5A 16r7B67 16r660F 16r7B68 16r6DF7 16r7B69 16r6E3E 16r7B6A 16r743F 16r7B6B 16r9B42 16r7B6C 16r5FFD 16r7B6D 16r60DA 16r7B6E 16r7B0F 16r7B6F 16r54C4 16r7B70 16r5F18 16r7B71 16r6C5E 16r7B72 16r6CD3 16r7B73 16r6D2A 16r7B74 16r70D8 16r7B75 16r7D05 16r7B76 16r8679 16r7B77 16r8A0C 16r7B78 16r9D3B 16r7B79 16r5316 16r7B7A 16r548C 16r7B7B 16r5B05 16r7B7C 16r6A3A 16r7B7D 16r706B 16r7B7E 16r7575 16r7C21 16r798D 16r7C22 16r79BE 16r7C23 16r82B1 16r7C24 16r83EF 16r7C25 16r8A71 16r7C26 16r8B41 16r7C27 16r8CA8 16r7C28 16r9774 16r7C29 16rFA0B 16r7C2A 16r64F4 16r7C2B 16r652B 16r7C2C 16r78BA 16r7C2D 16r78BB 16r7C2E 16r7A6B 16r7C2F 16r4E38 16r7C30 16r559A 16r7C31 16r5950 16r7C32 16r5BA6 16r7C33 16r5E7B 16r7C34 16r60A3 16r7C35 16r63DB 16r7C36 16r6B61 16r7C37 16r6665 16r7C38 16r6853 16r7C39 16r6E19 16r7C3A 16r7165 16r7C3B 16r74B0 16r7C3C 16r7D08 16r7C3D 16r9084 16r7C3E 16r9A69 16r7C3F 16r9C25 16r7C40 16r6D3B 16r7C41 16r6ED1 16r7C42 16r733E 16r7C43 16r8C41 16r7C44 16r95CA 16r7C45 16r51F0 16r7C46 16r5E4C 16r7C47 16r5FA8 16r7C48 16r604D 16r7C49 16r60F6 16r7C4A 16r6130 16r7C4B 16r614C 16r7C4C 16r6643 16r7C4D 16r6644 16r7C4E 16r69A5 16r7C4F 16r6CC1 16r7C50 16r6E5F 16r7C51 16r6EC9 16r7C52 16r6F62 16r7C53 16r714C 16r7C54 16r749C 16r7C55 16r7687 16r7C56 16r7BC1 16r7C57 16r7C27 16r7C58 16r8352 16r7C59 16r8757 16r7C5A 16r9051 16r7C5B 16r968D 16r7C5C 16r9EC3 16r7C5D 16r532F 16r7C5E 16r56DE 16r7C5F 16r5EFB 16r7C60 16r5F8A 16r7C61 16r6062 16r7C62 16r6094 16r7C63 16r61F7 16r7C64 16r6666 16r7C65 16r6703 16r7C66 16r6A9C 16r7C67 16r6DEE 16r7C68 16r6FAE 16r7C69 16r7070 16r7C6A 16r736A 16r7C6B 16r7E6A 16r7C6C 16r81BE 16r7C6D 16r8334 16r7C6E 16r86D4 16r7C6F 16r8AA8 16r7C70 16r8CC4 16r7C71 16r5283 16r7C72 16r7372 16r7C73 16r5B96 16r7C74 16r6A6B 16r7C75 16r9404 16r7C76 16r54EE 16r7C77 16r5686 16r7C78 16r5B5D 16r7C79 16r6548 16r7C7A 16r6585 16r7C7B 16r66C9 16r7C7C 16r689F 16r7C7D 16r6D8D 16r7C7E 16r6DC6 16r7D21 16r723B 16r7D22 16r80B4 16r7D23 16r9175 16r7D24 16r9A4D 16r7D25 16r4FAF 16r7D26 16r5019 16r7D27 16r539A 16r7D28 16r540E 16r7D29 16r543C 16r7D2A 16r5589 16r7D2B 16r55C5 16r7D2C 16r5E3F 16r7D2D 16r5F8C 16r7D2E 16r673D 16r7D2F 16r7166 16r7D30 16r73DD 16r7D31 16r9005 16r7D32 16r52DB 16r7D33 16r52F3 16r7D34 16r5864 16r7D35 16r58CE 16r7D36 16r7104 16r7D37 16r718F 16r7D38 16r71FB 16r7D39 16r85B0 16r7D3A 16r8A13 16r7D3B 16r6688 16r7D3C 16r85A8 16r7D3D 16r55A7 16r7D3E 16r6684 16r7D3F 16r714A 16r7D40 16r8431 16r7D41 16r5349 16r7D42 16r5599 16r7D43 16r6BC1 16r7D44 16r5F59 16r7D45 16r5FBD 16r7D46 16r63EE 16r7D47 16r6689 16r7D48 16r7147 16r7D49 16r8AF1 16r7D4A 16r8F1D 16r7D4B 16r9EBE 16r7D4C 16r4F11 16r7D4D 16r643A 16r7D4E 16r70CB 16r7D4F 16r7566 16r7D50 16r8667 16r7D51 16r6064 16r7D52 16r8B4E 16r7D53 16r9DF8 16r7D54 16r5147 16r7D55 16r51F6 16r7D56 16r5308 16r7D57 16r6D36 16r7D58 16r80F8 16r7D59 16r9ED1 16r7D5A 16r6615 16r7D5B 16r6B23 16r7D5C 16r7098 16r7D5D 16r75D5 16r7D5E 16r5403 16r7D5F 16r5C79 16r7D60 16r7D07 16r7D61 16r8A16 16r7D62 16r6B20 16r7D63 16r6B3D 16r7D64 16r6B46 16r7D65 16r5438 16r7D66 16r6070 16r7D67 16r6D3D 16r7D68 16r7FD5 16r7D69 16r8208 16r7D6A 16r50D6 16r7D6B 16r51DE 16r7D6C 16r559C 16r7D6D 16r566B 16r7D6E 16r56CD 16r7D6F 16r59EC 16r7D70 16r5B09 16r7D71 16r5E0C 16r7D72 16r6199 16r7D73 16r6198 16r7D74 16r6231 16r7D75 16r665E 16r7D76 16r66E6 16r7D77 16r7199 16r7D78 16r71B9 16r7D79 16r71BA 16r7D7A 16r72A7 16r7D7B 16r79A7 16r7D7C 16r7A00 16r7D7D 16r7FB2 16r7D7E 16r8A70). 422875 table size even ifFalse: [^ self error: 'given table size must be even']. 422876 size := table size / 2. 422877 ksX1001 := Array new: size. 422878 unicode := Array new: size. 422879 1 to: table size by: 2 do: [:index | 422880 | tableIndex | 422881 tableIndex := index + 1 / 2. 422882 ksX1001 at: tableIndex put: (table at: index). 422883 unicode at: tableIndex put: (table at: index + 1)]. 422884 ksX10012 := Array new: 94*94 withAll: -1. 422885 ksX1001 withIndexDo: [:elem :index | 422886 code := (elem // 256 - 33) * 94 + (elem \\ 256 - 33) + 1. 422887 (ksX10012 at: code) ~= -1 ifTrue: [self halt]. 422888 uIndex := ksX1001 indexOf: elem. 422889 uIndex = 0 ifFalse: [ 422890 u := unicode at: uIndex. 422891 ksX10012 at: code put: u. 422892 ]. 422893 ]. 422894 KSX1001Table := ksX10012 422895! ! 422896 422897!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:41'! 422898initializeLatin1Table 422899 "UCSTable initializeLatin1Table" 422900 422901 Latin1Table := (0 to: 255) asArray. 422902! ! 422903 422904!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 09:38'! 422905jisx0208Table 422906 422907 ^ JISX0208Table. 422908! ! 422909 422910!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:36'! 422911ksx1001Table 422912 422913 ^ KSX1001Table. 422914! ! 422915 422916!UCSTable class methodsFor: 'accessing - table' stamp: 'yo 10/14/2003 10:36'! 422917latin1Table 422918 422919 ^ Latin1Table. 422920! ! 422921Object subclass: #UIManager 422922 instanceVariableNames: '' 422923 classVariableNames: 'Default' 422924 poolDictionaries: '' 422925 category: 'ToolBuilder-Kernel'! 422926!UIManager commentStamp: 'ar 12/27/2004 08:39' prior: 0! 422927UIManager is a dispatcher for various UI requests.! 422928 422929 422930!UIManager methodsFor: '*Polymorph-ToolBuilder' stamp: 'gvc 2/6/2009 12:45'! 422931chooseFrom: aList lines: linesArray message: messageString 422932 "Choose an item from the given list. Answer the index of the selected item." 422933 422934 ^self chooseFrom: aList lines: linesArray message: messageString title: ''! ! 422935 422936!UIManager methodsFor: '*Polymorph-ToolBuilder' stamp: 'gvc 2/6/2009 12:47'! 422937chooseFrom: aList lines: linesArray message: messageString title: aString 422938 "Choose an item from the given list. Answer the selected item." 422939 422940 ^self 422941 chooseFrom: aList 422942 lines: linesArray 422943 title: (aString 422944 ifEmpty: [messageString] 422945 ifNotEmpty: [aString, String cr, messageString])! ! 422946 422947!UIManager methodsFor: '*Polymorph-ToolBuilder' stamp: 'gvc 2/6/2009 12:45'! 422948chooseFrom: aList message: messageString 422949 "Choose an item from the given list. Answer the index of the selected item." 422950 422951 ^self chooseFrom: aList lines: #() message: messageString! ! 422952 422953!UIManager methodsFor: '*Polymorph-ToolBuilder' stamp: 'gvc 2/6/2009 12:44'! 422954chooseFrom: aList message: messageString title: aString 422955 "Choose an item from the given list. Answer the index of the selected item." 422956 422957 ^self chooseFrom: aList lines: #() message: messageString title: aString! ! 422958 422959!UIManager methodsFor: '*Polymorph-ToolBuilder' stamp: 'gvc 2/6/2009 12:50'! 422960chooseFrom: aList values: valueList lines: linesArray message: messageString 422961 "Choose an item from the given list. Answer the index of the selected item." 422962 422963 ^self chooseFrom: aList values: valueList lines: linesArray message: messageString title: ''! ! 422964 422965!UIManager methodsFor: '*Polymorph-ToolBuilder' stamp: 'gvc 2/6/2009 12:52'! 422966chooseFrom: labelList values: valueList lines: linesArray message: messageString title: aString 422967 "Choose an item from the given list. Answer the selected item." 422968 422969 ^self 422970 chooseFrom: labelList 422971 values: valueList 422972 lines: linesArray 422973 title: (aString 422974 ifEmpty: [messageString] 422975 ifNotEmpty: [aString, String cr, messageString])! ! 422976 422977!UIManager methodsFor: '*Polymorph-ToolBuilder' stamp: 'gvc 2/6/2009 12:49'! 422978chooseFrom: aList values: valueList message: messageString 422979 "Choose an item from the given list. Answer the index of the selected item." 422980 422981 ^self chooseFrom: aList values: valueList lines: #() message: messageString! ! 422982 422983!UIManager methodsFor: '*Polymorph-ToolBuilder' stamp: 'gvc 2/6/2009 12:50'! 422984chooseFrom: aList values: valueList message: messageString title: aString 422985 "Choose an item from the given list. Answer the index of the selected item." 422986 422987 ^self chooseFrom: aList values: valueList lines: #() message: messageString title: aString! ! 422988 422989 422990!UIManager methodsFor: 'bitBlt' stamp: 'Pavel.Krivanek 10/28/2008 11:02'! 422991grafPort 422992 422993 ^ Display defaultBitBltClass current! ! 422994 422995 422996!UIManager methodsFor: 'display' stamp: 'Pavel.Krivanek 10/28/2008 11:05'! 422997checkForNewDisplaySize 422998 422999 self subclassResponsibility ! ! 423000 423001!UIManager methodsFor: 'display' stamp: 'Pavel.Krivanek 10/28/2008 11:05'! 423002newDisplayDepthNoRestore: pixelSize 423003 423004 self subclassResponsibility ! ! 423005 423006!UIManager methodsFor: 'display' stamp: 'Pavel.Krivanek 10/28/2008 11:05'! 423007restoreDisplay 423008 423009 self subclassResponsibility ! ! 423010 423011!UIManager methodsFor: 'display' stamp: 'Pavel.Krivanek 10/28/2008 11:05'! 423012restoreDisplayAfter: aBlock 423013 423014 self subclassResponsibility ! ! 423015 423016 423017!UIManager methodsFor: 'events' stamp: 'Pavel.Krivanek 10/28/2008 11:01'! 423018onDebug: process context: context title: title full: bool! ! 423019 423020!UIManager methodsFor: 'events' stamp: 'Pavel.Krivanek 10/28/2008 11:22'! 423021onEventSensorStartup: anEventSensor 423022 423023! ! 423024 423025!UIManager methodsFor: 'events' stamp: 'Pavel.Krivanek 10/28/2008 11:01'! 423026onPrimitiveError: aString ! ! 423027 423028!UIManager methodsFor: 'events' stamp: 'Pavel.Krivanek 10/28/2008 11:01'! 423029onSnapshot ! ! 423030 423031 423032!UIManager methodsFor: 'paragraph' stamp: 'Pavel.Krivanek 10/28/2008 11:06'! 423033composeFormFor: aDisplayText 423034 423035 ^ aDisplayText asParagraph asForm! ! 423036 423037 423038!UIManager methodsFor: 'settings' stamp: 'Pavel.Krivanek 10/28/2008 10:49'! 423039interactiveParserFor: requestor 423040 423041 ^ false! ! 423042 423043 423044!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 19:35'! 423045chooseDirectory 423046 "Let the user choose a directory" 423047 ^self chooseDirectoryFrom: FileDirectory default! ! 423048 423049!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 19:36'! 423050chooseDirectoryFrom: dir 423051 "Let the user choose a directory" 423052 ^self chooseDirectory: nil from: dir! ! 423053 423054!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 19:36'! 423055chooseDirectory: label 423056 "Let the user choose a directory" 423057 ^self chooseDirectory: label from: FileDirectory default! ! 423058 423059!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 19:36'! 423060chooseDirectory: label from: dir 423061 "Let the user choose a directory" 423062 ^self subclassResponsibility! ! 423063 423064!UIManager methodsFor: 'ui requests' stamp: 'ar 7/17/2005 00:26'! 423065chooseFileMatching: patterns 423066 "Let the user choose a file matching the given patterns" 423067 ^self chooseFileMatching: patterns label: nil! ! 423068 423069!UIManager methodsFor: 'ui requests' stamp: 'ar 7/17/2005 00:26'! 423070chooseFileMatching: patterns label: labelString 423071 "Let the user choose a file matching the given patterns" 423072 ^self subclassResponsibility! ! 423073 423074!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 10:44'! 423075chooseFrom: aList 423076 "Choose an item from the given list. Answer the index of the selected item." 423077 ^self chooseFrom: aList lines: #()! ! 423078 423079!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 10:45'! 423080chooseFrom: aList lines: linesArray 423081 "Choose an item from the given list. Answer the index of the selected item." 423082 ^self chooseFrom: aList lines: linesArray title: ''! ! 423083 423084!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 09:37'! 423085chooseFrom: aList lines: linesArray title: aString 423086 "Choose an item from the given list. Answer the index of the selected item." 423087 ^self subclassResponsibility! ! 423088 423089!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 10:44'! 423090chooseFrom: aList title: aString 423091 "Choose an item from the given list. Answer the index of the selected item." 423092 ^self chooseFrom: aList lines: #() title: aString! ! 423093 423094!UIManager methodsFor: 'ui requests' stamp: 'ar 7/15/2005 23:42'! 423095chooseFrom: labelList values: valueList 423096 "Choose an item from the given list. Answer the selected item." 423097 ^self chooseFrom: labelList values: valueList lines: #()! ! 423098 423099!UIManager methodsFor: 'ui requests' stamp: 'ar 7/15/2005 23:43'! 423100chooseFrom: labelList values: valueList lines: linesArray 423101 "Choose an item from the given list. Answer the selected item." 423102 ^self chooseFrom: labelList values: valueList lines: linesArray title: ''! ! 423103 423104!UIManager methodsFor: 'ui requests' stamp: 'ar 7/15/2005 23:43'! 423105chooseFrom: labelList values: valueList lines: linesArray title: aString 423106 "Choose an item from the given list. Answer the selected item." 423107 ^self subclassResponsibility! ! 423108 423109!UIManager methodsFor: 'ui requests' stamp: 'ar 7/15/2005 23:43'! 423110chooseFrom: labelList values: valueList title: aString 423111 "Choose an item from the given list. Answer the selected item." 423112 ^self chooseFrom: labelList values: valueList lines: #() title: aString! ! 423113 423114!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:39'! 423115confirm: queryString 423116 "Put up a yes/no menu with caption queryString. Answer true if the 423117 response is yes, false if no. This is a modal question--the user must 423118 respond yes or no." 423119 ^self subclassResponsibility! ! 423120 423121!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 09:49'! 423122confirm: aString orCancel: cancelBlock 423123 "Put up a yes/no/cancel menu with caption aString. Answer true if 423124 the response is yes, false if no. If cancel is chosen, evaluate 423125 cancelBlock. This is a modal question--the user must respond yes or no." 423126 ^self subclassResponsibility! ! 423127 423128!UIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 17:10'! 423129displayProgress: titleString at: aPoint from: minVal to: maxVal during: workBlock 423130 "Display titleString as a caption over a progress bar while workBlock is evaluated." 423131 ^self subclassResponsibility! ! 423132 423133!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 18:56'! 423134edit: aText 423135 "Open an editor on the given string/text" 423136 ^self edit: aText label: nil! ! 423137 423138!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 18:56'! 423139edit: aText label: labelString 423140 "Open an editor on the given string/text" 423141 ^self edit: aText label: labelString accept: nil! ! 423142 423143!UIManager methodsFor: 'ui requests' stamp: 'ar 7/16/2005 18:56'! 423144edit: aText label: labelString accept: anAction 423145 "Open an editor on the given string/text" 423146 ^self subclassResponsibility! ! 423147 423148!UIManager methodsFor: 'ui requests' stamp: 'Pavel.Krivanek 10/28/2008 10:45'! 423149fontFromUser: priorFont 423150 423151 self subclassResponsibility! ! 423152 423153!UIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 17:06'! 423154informUserDuring: aBlock 423155 "Display a message above (or below if insufficient room) the cursor 423156 during execution of the given block. 423157 UIManager default informUserDuring:[:bar| 423158 #(one two three) do:[:info| 423159 bar value: info. 423160 (Delay forSeconds: 1) wait]]" 423161 ^self subclassResponsibility! ! 423162 423163!UIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 20:40'! 423164informUser: aString during: aBlock 423165 "Display a message above (or below if insufficient room) the cursor 423166 during execution of the given block. 423167 UIManager default informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait]. 423168 " 423169 ^self informUserDuring:[:bar| bar value: aString. aBlock value].! ! 423170 423171!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:46'! 423172inform: aString 423173 "Display a message for the user to read and then dismiss" 423174 ^self subclassResponsibility! ! 423175 423176!UIManager methodsFor: 'ui requests' stamp: 'ar 2/28/2005 17:05'! 423177multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight 423178 "Create a multi-line instance of me whose question is queryString with 423179 the given initial answer. Invoke it centered at the given point, and 423180 answer the string the user accepts. Answer nil if the user cancels. An 423181 empty string returned means that the ussr cleared the editing area and 423182 then hit 'accept'. Because multiple lines are invited, we ask that the user 423183 use the ENTER key, or (in morphic anyway) hit the 'accept' button, to 423184 submit; that way, the return key can be typed to move to the next line." 423185 ^self subclassResponsibility! ! 423186 423187!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:47'! 423188requestPassword: queryString 423189 "Create an instance of me whose question is queryString. Invoke it centered 423190 at the cursor, and answer the string the user accepts. Answer the empty 423191 string if the user cancels." 423192 ^self subclassResponsibility! ! 423193 423194!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:41'! 423195request: queryString 423196 "Create an instance of me whose question is queryString. Invoke it 423197 centered at the cursor, and answer the string the user accepts. Answer 423198 the empty string if the user cancels." 423199 ^self request: queryString initialAnswer: ''! ! 423200 423201!UIManager methodsFor: 'ui requests' stamp: 'ar 12/27/2004 08:41'! 423202request: queryString initialAnswer: defaultAnswer 423203 "Create an instance of me whose question is queryString with the given 423204 initial answer. Invoke it centered at the given point, and answer the 423205 string the user accepts. Answer the empty string if the user cancels." 423206 ^self subclassResponsibility! ! 423207 423208"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 423209 423210UIManager class 423211 instanceVariableNames: ''! 423212 423213!UIManager class methodsFor: 'initialization' stamp: 'ar 2/11/2005 15:55'! 423214default 423215 | mgrClass | 423216 ^Default ifNil:[ 423217 "Note: The way the following is phrased ensures that you can always make 'more specific' managers merely by subclassing a tool builder and implementing a more specific way of reacting to #isActiveManager. For example, a BobsUIManager can subclass MorphicUIManager and (if enabled, say Preferences useBobsUI) will be considered before the parent (generic MorphicUIManager)." 423218 mgrClass := self allSubclasses 423219 detect:[:any| any isActiveManager and:[ 423220 any subclasses noneSatisfy:[:sub| sub isActiveManager]]] ifNone:[nil]. 423221 mgrClass ifNotNil:[mgrClass new] 423222 ].! ! 423223 423224!UIManager class methodsFor: 'initialization' stamp: 'ar 12/27/2004 09:34'! 423225default: aUIManager 423226 Default := aUIManager! ! 423227 423228!UIManager class methodsFor: 'initialization' stamp: 'ar 2/11/2005 15:41'! 423229isActiveManager 423230 "Answer whether I should act as the active ui manager" 423231 ^false! ! 423232 423233 423234!UIManager class methodsFor: 'utils' stamp: 'stephane.ducasse 7/10/2009 16:34'! 423235createPageTestWorkspace 423236 "Used to generate a workspace window for testing page up and page down stuff." 423237 "self createPageTestWorkspace" 423238 423239 | numberOfLines maxStringLength minLineCounterSize lineCounterSize offsetSize stream headerConstant prevStart prevStrLen prevLineNumber stringLen lineNumber start log pad charIndex char | 423240 numberOfLines := 400. 423241 maxStringLength := 22. 423242 minLineCounterSize := 3. 423243 lineCounterSize := (numberOfLines log asInteger + 1) max: minLineCounterSize. 423244 offsetSize := 5. 423245 stream := ReadWriteStream on: ''. 423246 headerConstant := lineCounterSize + 1 + offsetSize + 1. 423247 prevStart := headerConstant negated. 423248 prevStrLen := 0. 423249 prevLineNumber := 0. 423250 numberOfLines timesRepeat: [ 423251 stringLen := maxStringLength atRandom max: 1. 423252 lineNumber := prevLineNumber + 1. 423253 start := prevStart + prevStrLen + headerConstant + 1. 423254 prevStart := start. 423255 prevStrLen := stringLen. 423256 prevLineNumber := lineNumber. 423257 log := lineNumber log asInteger. 423258 pad := lineCounterSize - log - 1. 423259 pad timesRepeat: [stream nextPutAll: '0']. 423260 stream nextPutAll: lineNumber printString. 423261 stream space. 423262 log := start log asInteger. 423263 pad := offsetSize - log - 1. 423264 pad timesRepeat: [stream nextPutAll: '0']. 423265 stream nextPutAll: start printString. 423266 stream space. 423267 charIndex := 'a' first asInteger. 423268 stringLen timesRepeat: [ 423269 char := Character value: charIndex. 423270 charIndex := charIndex + 1. 423271 stream nextPut: char]. 423272 lineNumber = numberOfLines ifFalse: [stream cr] 423273 ]. 423274 self default edit: stream contents label: 'Test Data'. 423275! ! 423276Object subclass: #UITheme 423277 instanceVariableNames: 'settings forms soundTheme focusIndicator' 423278 classVariableNames: 'Builder Current' 423279 poolDictionaries: '' 423280 category: 'Polymorph-Widgets-Themes'! 423281!UITheme commentStamp: 'StephaneDucasse 10/2/2009 16:15' prior: 0! 423282Common superclass for User Interface themes. Provides methods for creating new morphs in a standard way, various "services" like a file dialog, message dialogs etc. and also methods for customising aspects of the appearance of various morphs. 423283Though conceptually abstract, no code is "missing". Subclasses, therefore, should override the aspects they wish to change. 423284 423285UITheme exampleBasicControls 423286UITheme exampleBuilder 423287UITheme exampleColorControls 423288UITheme exampleDialogs 423289UITheme exampleGroups 423290UITheme exampleOtherControls 423291UITheme exampleWindowWithToolbars! 423292 423293 423294!UITheme methodsFor: 'accessing' stamp: 'gvc 9/12/2007 14:40'! 423295focusIndicator 423296 "Answer the value of focusIndicator" 423297 423298 ^ focusIndicator! ! 423299 423300!UITheme methodsFor: 'accessing' stamp: 'gvc 9/12/2007 14:40'! 423301focusIndicator: anObject 423302 "Set the value of focusIndicator" 423303 423304 focusIndicator := anObject! ! 423305 423306!UITheme methodsFor: 'accessing' stamp: 'gvc 5/14/2007 11:39'! 423307forms 423308 "Answer the value of forms" 423309 423310 ^ forms! ! 423311 423312!UITheme methodsFor: 'accessing' stamp: 'gvc 5/14/2007 11:39'! 423313forms: anObject 423314 "Set the value of forms" 423315 423316 forms := anObject! ! 423317 423318!UITheme methodsFor: 'accessing' stamp: 'gvc 9/22/2006 17:19'! 423319settings 423320 "Answer the value of settings" 423321 423322 ^ settings! ! 423323 423324!UITheme methodsFor: 'accessing' stamp: 'gvc 9/22/2006 17:19'! 423325settings: anObject 423326 "Set the value of settings" 423327 423328 settings := anObject! ! 423329 423330!UITheme methodsFor: 'accessing' stamp: 'gvc 7/30/2009 18:34'! 423331soundTheme 423332 "Answer the sound theme to use, if not specified 423333 use the default sound theme." 423334 423335 ^soundTheme ifNil: [self defaultSoundTheme]! ! 423336 423337!UITheme methodsFor: 'accessing' stamp: 'gvc 7/30/2009 18:32'! 423338soundTheme: anObject 423339 "Set the sound theme specific to this instance of ui theme," 423340 423341 soundTheme := anObject! ! 423342 423343 423344!UITheme methodsFor: 'basic-colors' stamp: 'gvc 4/16/2007 12:57'! 423345buttonColorFor: aButton 423346 "Answer the colour for the given button." 423347 423348 ^self settings standardColorsOnly 423349 ifTrue: [self settings buttonColor] 423350 ifFalse: [aButton colorToUse]! ! 423351 423352!UITheme methodsFor: 'basic-colors' stamp: 'gvc 4/23/2007 17:22'! 423353progressBarColorFor: aProgressBar 423354 "Answer the colour for the given progress bar." 423355 423356 ^self settings progressBarColor! ! 423357 423358!UITheme methodsFor: 'basic-colors' stamp: 'gvc 4/24/2007 11:45'! 423359progressBarProgressColorFor: aProgressBar 423360 "Answer the colour for the progress part of the given progress bar." 423361 423362 ^self settings progressBarProgressColor! ! 423363 423364!UITheme methodsFor: 'basic-colors' stamp: 'gvc 4/16/2007 12:59'! 423365scrollbarColorFor: aScrollbar 423366 "Answer the colour for the given scrollbar." 423367 423368 ^self settings standardColorsOnly 423369 ifTrue: [self settings scrollbarColor] 423370 ifFalse: [(aScrollbar valueOfProperty: #lastPaneColor) 423371 ifNil: [Color white]]! ! 423372 423373!UITheme methodsFor: 'basic-colors' stamp: 'gvc 1/16/2008 13:35'! 423374subgroupColorFrom: paneColor 423375 "Answer the colour for a subgroup given the pane colour." 423376 423377 ^paneColor whiter whiter! ! 423378 423379!UITheme methodsFor: 'basic-colors' stamp: 'gvc 5/9/2007 15:33'! 423380taskbarActiveButtonColorFor: aButton 423381 "Answer the colour for the given active taskbar button." 423382 423383 ^(self taskbarButtonColorFor: aButton) twiceDarker! ! 423384 423385!UITheme methodsFor: 'basic-colors' stamp: 'gvc 5/9/2007 15:33'! 423386taskbarButtonColorFor: aButton 423387 "Answer the colour for the given taskbar button." 423388 423389 ^self settings standardColorsOnly 423390 ifTrue: [self settings buttonColor] 423391 ifFalse: [(aButton model valueOfProperty: #paneColor) ifNil: [aButton model defaultColor]]! ! 423392 423393!UITheme methodsFor: 'basic-colors' stamp: 'gvc 5/9/2007 15:17'! 423394taskbarButtonLabelColorFor: aButton 423395 "Answer the colour for the label of the given taskbar button." 423396 423397 ^Color black! ! 423398 423399!UITheme methodsFor: 'basic-colors' stamp: 'gvc 5/9/2007 15:11'! 423400taskbarMinimizedButtonColorFor: aButton 423401 "Answer the colour for the given minimized taskbar button." 423402 423403 ^self taskbarButtonColorFor: aButton! ! 423404 423405!UITheme methodsFor: 'basic-colors' stamp: 'gvc 9/5/2007 15:04'! 423406treeLineColorsFrom: aColor 423407 "Answer the colours to use for the tree lines. 423408 The given colour is the preferred colour." 423409 423410 ^{aColor. Color transparent}! ! 423411 423412!UITheme methodsFor: 'basic-colors' stamp: 'gvc 9/5/2007 15:05'! 423413treeLineDashes 423414 "Answer the dash lengths to use for the tree lines." 423415 423416 ^#(1 1)! ! 423417 423418!UITheme methodsFor: 'basic-colors' stamp: 'gvc 9/5/2007 15:08'! 423419treeLineWidth 423420 "Answer the width of the tree lines." 423421 423422 ^1! ! 423423 423424!UITheme methodsFor: 'basic-colors' stamp: 'gvc 2/14/2009 17:37'! 423425windowColorFor: aWindowOrModel 423426 "Answer the colour for the given window." 423427 423428 |c| 423429 self settings standardColorsOnly 423430 ifTrue: [^self settings windowColor]. 423431 c := (aWindowOrModel isSystemWindow) 423432 ifTrue: [Color colorFrom: (Preferences 423433 windowColorFor: aWindowOrModel class name)] 423434 ifFalse: [aWindowOrModel defaultBackgroundColor]. 423435 ^c = Color white 423436 ifTrue: [self settings windowColor] 423437 ifFalse: [c duller]! ! 423438 423439!UITheme methodsFor: 'basic-colors' stamp: 'gvc 5/13/2008 15:12'! 423440worldMainDockingBarColorFor: aDockingBar 423441 "Answer the base colour to use for a world main docking bar in this theme." 423442 423443 ^ColorTheme current dockingBarColor! ! 423444 423445 423446!UITheme methodsFor: 'border-styles' stamp: 'gvc 6/2/2009 11:30'! 423447configureWindowBorderFor: aWindow 423448 "Configure the border for the given window." 423449 423450 aWindow roundedCorners: #(1 2 3 4). 423451 aWindow borderStyle: (BorderStyle 423452 width: 1 color: Color lightGray)! ! 423453 423454!UITheme methodsFor: 'border-styles' stamp: 'gvc 2/9/2009 17:12'! 423455configureWindowDropShadowFor: aWindow 423456 "Configure the drop shadow for the given window." 423457 423458 aWindow 423459 addDropShadow; 423460 shadowColor: self windowShadowColor; 423461 shadowOffset: 1@1! ! 423462 423463!UITheme methodsFor: 'border-styles' stamp: 'gvc 6/2/2009 10:58'! 423464drawTabGroupFinishingFor: aTabGroupMorph on: aCanvas 423465 "Patch up any visuals for the selected tab."! ! 423466 423467!UITheme methodsFor: 'border-styles' stamp: 'gvc 9/1/2009 15:26'! 423468drawTextAdornmentFor: aPluggableTextMorph color: aColor on: aCanvas 423469 "Indicate edit status for the given morph." 423470 423471 aCanvas frameRectangle: aPluggableTextMorph innerBounds width: 2 color: aColor! ! 423472 423473!UITheme methodsFor: 'border-styles' stamp: 'gvc 9/1/2009 15:39'! 423474drawTextAdornmentsFor: aPluggableTextMorph on: aCanvas 423475 "Indicate edit status for the given morph." 423476 423477 (aPluggableTextMorph model notNil and: [aPluggableTextMorph model refusesToAcceptCode]) 423478 ifTrue: "Put up feedback showing that code cannot be submitted in this state" 423479 [self drawTextAdornmentFor: aPluggableTextMorph color: Color tan on: aCanvas] 423480 ifFalse: 423481 [aPluggableTextMorph hasEditingConflicts 423482 ifTrue: 423483 [self drawTextAdornmentFor: aPluggableTextMorph color: Color red on: aCanvas] 423484 ifFalse: 423485 [aPluggableTextMorph hasUnacceptedEdits 423486 ifTrue: 423487 [aPluggableTextMorph model wantsDiffFeedback 423488 ifTrue: 423489 [self drawTextAdornmentFor: aPluggableTextMorph color: Color yellow darker on: aCanvas] 423490 ifFalse: 423491 [self drawTextAdornmentFor: aPluggableTextMorph color: Color orange on: aCanvas]] 423492 ifFalse: 423493 [aPluggableTextMorph model wantsDiffFeedback 423494 ifTrue: 423495 [self drawTextAdornmentFor: aPluggableTextMorph color: Color green on: aCanvas]]]]! ! 423496 423497!UITheme methodsFor: 'border-styles' stamp: 'gvc 2/16/2009 17:21'! 423498drawWindowActiveDropShadowFor: aSystemWindow on: aCanvas 423499 "Draw the active drop shadow for the given window." 423500 423501 423502 ^self windowActiveDropShadowStyle == #diffuse 423503 ifTrue: [self drawWindowDiffuseDropShadowFor: aSystemWindow on: aCanvas] 423504 ifFalse: [self drawWindowPlainDropShadowFor: aSystemWindow on: aCanvas]! ! 423505 423506!UITheme methodsFor: 'border-styles' stamp: 'gvc 3/4/2009 15:09'! 423507drawWindowDiffuseDropShadowFor: aSystemWindow on: aCanvas 423508 "Draw the diffuse drop shadow for the given window." 423509 423510 |or b r o gc| 423511 or := self windowActiveDropShadowOffsetRectangleFor: aSystemWindow. 423512 o := or bottom. 423513 b := aSystemWindow bounds expandBy: or. 423514 gc := {Color black alpha: 0.6. Color transparent}. 423515 r := b topLeft extent: o asPoint. 423516 aCanvas 423517 fillRectangle: r 423518 fillStyle: ((GradientFillStyle colors: gc) 423519 origin: r bottomRight; 423520 direction: o@0; 423521 radial: true). 423522 r := b topLeft + (o@0) extent: (b width - o - o @ o). 423523 aCanvas 423524 fillRectangle: r 423525 fillStyle: ((GradientFillStyle colors: gc) 423526 origin: r bottomLeft; 423527 direction: 0@o negated). 423528 r := b topRight - (o@0) extent: o asPoint. 423529 aCanvas 423530 fillRectangle: r 423531 fillStyle: ((GradientFillStyle colors: gc) 423532 origin: r bottomLeft; 423533 direction: o@0; 423534 radial: true). 423535 r := b topRight + (o negated@o) extent: (o @ (b height - o - o)). 423536 aCanvas 423537 fillRectangle: r 423538 fillStyle: ((GradientFillStyle colors: gc) 423539 origin: r topLeft; 423540 direction: o@0). 423541 r := b bottomRight - o asPoint extent: o asPoint. 423542 aCanvas 423543 fillRectangle: r 423544 fillStyle: ((GradientFillStyle colors: gc) 423545 origin: r topLeft; 423546 direction: o@0; 423547 radial: true). 423548 r := b bottomLeft + (o@o negated) extent: (b width - o - o @ o). 423549 aCanvas 423550 fillRectangle: r 423551 fillStyle: ((GradientFillStyle colors: gc) 423552 origin: r topLeft; 423553 direction: 0@o). 423554 r := b bottomLeft - (0@o) extent: o asPoint. 423555 aCanvas 423556 fillRectangle: r 423557 fillStyle: ((GradientFillStyle colors: gc) 423558 origin: r topRight; 423559 direction: o@0; 423560 radial: true). 423561 r := b topLeft + (0@o) extent: (o @ (b height - o - o)). 423562 aCanvas 423563 fillRectangle: r 423564 fillStyle: ((GradientFillStyle colors: gc) 423565 origin: r topRight; 423566 direction: o negated@0)! ! 423567 423568!UITheme methodsFor: 'border-styles' stamp: 'gvc 2/16/2009 17:21'! 423569drawWindowInactiveDropShadowFor: aSystemWindow on: aCanvas 423570 "Draw the inactive drop shadow for the given window." 423571 423572 self drawWindowPlainDropShadowFor: aSystemWindow on: aCanvas! ! 423573 423574!UITheme methodsFor: 'border-styles' stamp: 'gvc 2/16/2009 17:20'! 423575drawWindowPlainDropShadowFor: aSystemWindow on: aCanvas 423576 "Draw the plain drop shadow for the given window." 423577 423578 |blOffset brOffset trOffset| 423579 (aSystemWindow owner notNil and: [aSystemWindow owner isHandMorph]) 423580 ifTrue: [^self]. "skip if being dragged" 423581 blOffset := (aSystemWindow wantsRoundedCorners and: [aSystemWindow roundedCorners includes: 2]) 423582 ifTrue: [7] ifFalse: [1]. 423583 brOffset := (aSystemWindow wantsRoundedCorners and: [aSystemWindow roundedCorners includes: 3]) 423584 ifTrue: [7] ifFalse: [1]. 423585 trOffset := (aSystemWindow wantsRoundedCorners and: [aSystemWindow roundedCorners includes: 4]) 423586 ifTrue: [7] ifFalse: [1]. 423587 aCanvas 423588 fillRectangle: (aSystemWindow bounds bottomLeft + (blOffset @ 0) 423589 corner: aSystemWindow bounds bottomRight - (brOffset @ -1)) 423590 fillStyle: aSystemWindow shadowColor; 423591 fillRectangle: (aSystemWindow bounds topRight + (0 @ trOffset) 423592 corner: aSystemWindow bounds bottomRight + (1 @ brOffset negated)) 423593 fillStyle: aSystemWindow shadowColor. 423594 aCanvas 423595 clipBy: (aSystemWindow bounds bottomRight - brOffset 423596 corner: aSystemWindow bounds bottomRight + (1@1)) 423597 during: [:c | ((RoundedBorder new 423598 baseColor: aSystemWindow shadowColor; 423599 width: 1) cornerRadius: brOffset - 1) 423600 frameRectangle: (aSystemWindow bounds translateBy: 1) 423601 on: c]! ! 423602 423603!UITheme methodsFor: 'border-styles' stamp: 'gvc 8/7/2007 12:41'! 423604dropListDisabledBorderStyleFor: aDropList 423605 "Return the disabled borderStyle for the given drop list." 423606 423607 ^self dropListNormalBorderStyleFor: aDropList! ! 423608 423609!UITheme methodsFor: 'border-styles' stamp: 'gvc 8/7/2007 12:42'! 423610dropListNormalBorderStyleFor: aDropList 423611 "Return the normal borderStyle for the given drop list" 423612 423613 ^BorderStyle inset 423614 width: 1; 423615 baseColor: aDropList paneColor! ! 423616 423617!UITheme methodsFor: 'border-styles' stamp: 'gvc 1/13/2009 14:00'! 423618dropListNormalListBorderStyleFor: aDropList 423619 "Return the normal borderStyle for the list of the given given drop list" 423620 423621 ^BorderStyle inset 423622 width: 1; 423623 baseColor: aDropList paneColor! ! 423624 423625!UITheme methodsFor: 'border-styles' stamp: 'gvc 1/25/2008 14:43'! 423626groupLabelBorderStyleFor: aGroupPanel 423627 "Answer the normal border style for a group label." 423628 423629 ^BorderStyle simple 423630 width: 0; 423631 baseColor: Color transparent! ! 423632 423633!UITheme methodsFor: 'border-styles' stamp: 'gvc 1/16/2008 13:44'! 423634groupPanelBorderStyleFor: aGroupPanel 423635 "Answer the normal border style for a group panel." 423636 423637 ^BorderStyle simple 423638 width: 0; 423639 baseColor: Color transparent! ! 423640 423641!UITheme methodsFor: 'border-styles' stamp: 'gvc 2/23/2009 13:32'! 423642handlesWindowDropShadowInHandFor: aSystemWindow 423643 "Answer whether the receiver will handle drop shadow drawing 423644 for a window when picked up in the hand. We will when diffuse." 423645 423646 ^self windowActiveDropShadowStyle == #diffuse and: [ 423647 aSystemWindow isActive]! ! 423648 423649!UITheme methodsFor: 'border-styles' stamp: 'gvc 8/7/2007 12:41'! 423650listDisabledBorderStyleFor: aList 423651 "Return the disabled borderStyle for the given list." 423652 423653 ^self listNormalBorderStyleFor: aList! ! 423654 423655!UITheme methodsFor: 'border-styles' stamp: 'gvc 6/1/2009 15:18'! 423656listFocusBoundsFor: aListMorph 423657 "Answer the bounds for drawing the focus indication." 423658 423659 ^aListMorph bounds! ! 423660 423661!UITheme methodsFor: 'border-styles' stamp: 'gvc 8/7/2007 12:42'! 423662listNormalBorderStyleFor: aList 423663 "Return the normal borderStyle for the given list" 423664 423665 ^BorderStyle inset 423666 width: 1; 423667 baseColor: aList paneColor! ! 423668 423669!UITheme methodsFor: 'border-styles' stamp: 'gvc 1/17/2008 11:44'! 423670plainGroupPanelBorderStyleFor: aGroupPanel 423671 "Answer the normal border style for a plain group panel." 423672 423673 ^BorderStyle simple 423674 width: 0; 423675 baseColor: Color transparent! ! 423676 423677!UITheme methodsFor: 'border-styles' stamp: 'gvc 4/25/2007 17:17'! 423678progressBarBorderStyleFor: aProgressBar 423679 "Return the progress bar borderStyle for the given progress bar." 423680 423681 |c| 423682 c := self progressBarColorFor: aProgressBar. 423683 ^BorderStyle simple 423684 width: 1; 423685 baseColor: c darker! ! 423686 423687!UITheme methodsFor: 'border-styles' stamp: 'gvc 1/27/2009 16:43'! 423688scrollPaneDisabledBorderStyleFor: aScrollPane 423689 "Return the disabled borderStyle for the given scroll pane." 423690 423691 ^self scrollPaneNormalBorderStyleFor: aScrollPane! ! 423692 423693!UITheme methodsFor: 'border-styles' stamp: 'gvc 1/27/2009 16:43'! 423694scrollPaneNormalBorderStyleFor: aScrollPane 423695 "Return the normal borderStyle for the given scroll pane" 423696 423697 ^BorderStyle inset 423698 width: 1; 423699 baseColor: aScrollPane paneColor! ! 423700 423701!UITheme methodsFor: 'border-styles' stamp: 'gvc 8/3/2007 15:25'! 423702sliderDisabledBorderStyleFor: aSlider 423703 "Return the disabled slider borderStyle for the given text editor." 423704 423705 ^self sliderNormalBorderStyleFor: aSlider! ! 423706 423707!UITheme methodsFor: 'border-styles' stamp: 'gvc 8/3/2007 15:26'! 423708sliderNormalBorderStyleFor: aSlider 423709 "Return the normal slider borderStyle for the given text editor." 423710 423711 ^BorderStyle inset 423712 width: 1; 423713 baseColor: aSlider paneColor twiceDarker! ! 423714 423715!UITheme methodsFor: 'border-styles' stamp: 'gvc 1/17/2008 11:29'! 423716tabGroupCornerStyleIn: aThemedMorph 423717 "Allow for themes to override default behaviour." 423718 423719 ^aThemedMorph 423720 ifNil: [#square] 423721 ifNotNilDo: [:tm | tm preferredCornerStyle]! ! 423722 423723!UITheme methodsFor: 'border-styles' stamp: 'gvc 1/7/2008 11:19'! 423724tabLabelNormalBorderStyleFor: aTabLabel 423725 "Answer the normal border style for a tab label." 423726 423727 ^BorderStyle simple 423728 width: 0; 423729 baseColor: Color transparent! ! 423730 423731!UITheme methodsFor: 'border-styles' stamp: 'gvc 1/7/2008 11:19'! 423732tabLabelSelectedBorderStyleFor: aTabLabel 423733 "Answer the selected border style for a tab label." 423734 423735 ^self tabLabelNormalBorderStyleFor: aTabLabel! ! 423736 423737!UITheme methodsFor: 'border-styles' stamp: 'gvc 1/7/2008 14:12'! 423738tabPanelBorderStyleFor: aTabPanel 423739 "Answer the normal border style for a tab panel." 423740 423741 ^BorderStyle simple 423742 width: 0; 423743 baseColor: Color transparent! ! 423744 423745!UITheme methodsFor: 'border-styles' stamp: 'gvc 3/2/2009 12:27'! 423746taskbarThumbnailCornerStyleFor: aMorph 423747 "Answer the corner style for the taskbar thumbnail/tasklist." 423748 423749 ^#rounded! ! 423750 423751!UITheme methodsFor: 'border-styles' stamp: 'gvc 4/18/2007 11:48'! 423752taskbarThumbnailNormalBorderStyleFor: aWindow 423753 "Return the normal thumbnail borderStyle for the given button." 423754 423755 |c| 423756 c := self windowColorFor: aWindow. 423757 ^BorderStyle raised 423758 width: 1; 423759 baseColor: c! ! 423760 423761!UITheme methodsFor: 'border-styles' stamp: 'gvc 5/23/2007 13:10'! 423762textEditorDisabledBorderStyleFor: aTextEditor 423763 "Return the disabled text editor borderStyle for the given text editor." 423764 423765 ^self textEditorNormalBorderStyleFor: aTextEditor! ! 423766 423767!UITheme methodsFor: 'border-styles' stamp: 'gvc 5/23/2007 13:10'! 423768textEditorNormalBorderStyleFor: aTextEditor 423769 "Return the normal text editor borderStyle for the given text editor." 423770 423771 ^BorderStyle inset 423772 width: 1; 423773 baseColor: aTextEditor paneColor! ! 423774 423775!UITheme methodsFor: 'border-styles' stamp: 'gvc 5/23/2007 13:11'! 423776textFieldDisabledBorderStyleFor: aTextField 423777 "Return the disabled text field borderStyle for the given text field." 423778 423779 ^self textEditorDisabledBorderStyleFor: aTextField! ! 423780 423781!UITheme methodsFor: 'border-styles' stamp: 'gvc 5/23/2007 13:11'! 423782textFieldNormalBorderStyleFor: aTextField 423783 "Return the normal text field borderStyle for the given text field." 423784 423785 ^self textEditorNormalBorderStyleFor: aTextField! ! 423786 423787!UITheme methodsFor: 'border-styles' stamp: 'gvc 6/2/2009 12:16'! 423788textFocusBoundsFor: aPluggableTextMorph 423789 "Answer the bounds for drawing the focus indication." 423790 423791 ^aPluggableTextMorph bounds! ! 423792 423793!UITheme methodsFor: 'border-styles' stamp: 'gvc 2/16/2009 17:19'! 423794windowActiveDropShadowOffsetRectangleFor: aSystemWindow 423795 "Answer a rectangle describing the offsets for each corner 423796 of the the active window bounds for the drop shadow area." 423797 423798 ^self windowActiveDropShadowStyle == #diffuse 423799 ifTrue: [self windowDiffuseDropShadowOffsetRectangleFor: aSystemWindow] 423800 ifFalse: [self windowPlainDropShadowOffsetRectangleFor: aSystemWindow]! ! 423801 423802!UITheme methodsFor: 'border-styles' stamp: 'gvc 2/16/2009 17:18'! 423803windowActiveDropShadowStyle 423804 "Answer the style of drop shadow to use for active windows." 423805 423806 ^#plain! ! 423807 423808!UITheme methodsFor: 'border-styles' stamp: 'gvc 2/16/2009 17:17'! 423809windowDiffuseDropShadowOffsetRectangleFor: aSystemWindow 423810 "Answer a rectangle describing the offsets for each corner 423811 of the the active window bounds for the drop shadow area 423812 when the difuse style is used." 423813 423814 ^8@4 corner: 8@10! ! 423815 423816!UITheme methodsFor: 'border-styles' stamp: 'gvc 2/16/2009 17:22'! 423817windowInactiveDropShadowOffsetRectangleFor: aSystemWindow 423818 "Answer a rectangle describing the offsets for each corner 423819 of the the inactive window bounds for the drop shadow area." 423820 423821 ^self windowPlainDropShadowOffsetRectangleFor: aSystemWindow! ! 423822 423823!UITheme methodsFor: 'border-styles' stamp: 'gvc 12/1/2008 15:29'! 423824windowPaneBorderStyleFor: aMorph in: aSystemWindow 423825 "Answer the border style for a morph that is to be added 423826 as a pane in the given system window," 423827 423828 ^BorderStyle inset 423829 color: aSystemWindow paneColor; 423830 width: (aMorph borderWidth = 0 ifTrue: [0] ifFalse: [1])! ! 423831 423832!UITheme methodsFor: 'border-styles' stamp: 'gvc 2/16/2009 17:16'! 423833windowPlainDropShadowOffsetRectangleFor: aSystemWindow 423834 "Answer a rectangle describing the offsets for each corner 423835 of the the active window bounds for the drop shadow area 423836 when the plain style is used." 423837 423838 ^aSystemWindow shadowOffset negated corner: aSystemWindow shadowOffset! ! 423839 423840!UITheme methodsFor: 'border-styles' stamp: 'gvc 5/13/2008 15:17'! 423841worldMainDockingBarBorderStyleFor: aDockingBar 423842 "Return the world main docking bar borderStyle for the given docking bar." 423843 423844 ^BorderStyle raised 423845 width: 2; 423846 color: aDockingBar color! ! 423847 423848 423849!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 1/27/2009 13:49'! 423850buttonCornerStyleIn: aThemedMorph 423851 "Allow for themes to override default behaviour." 423852 423853 ^aThemedMorph 423854 ifNil: [#square] 423855 ifNotNilDo: [:tm | 423856 tm preferredButtonCornerStyle 423857 ifNil: [tm preferredCornerStyle] 423858 ifNotNilDo: [:bcs | bcs]]! ! 423859 423860!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 4/25/2007 17:27'! 423861buttonDisabledBorderStyleFor: aButton 423862 "Return the disabled button borderStyle for the given button." 423863 423864 ^self buttonNormalBorderStyleFor: aButton! ! 423865 423866!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 12/4/2007 16:22'! 423867buttonFocusBoundsFor: aButton 423868 "Answer the bounds for drawing the focus indication for the 423869 given button." 423870 423871 ^(aButton bounds extent min < 6) 423872 ifTrue: [aButton bounds] 423873 ifFalse: [aButton bounds insetBy: aButton borderWidth + 423874 (aButton label isMorph ifTrue: [1] ifFalse: [2])]! ! 423875 423876!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 3/23/2007 17:16'! 423877buttonMouseOverBorderStyleFor: aButton 423878 "Return the mouse over button borderStyle for the given button." 423879 423880 ^self buttonNormalBorderStyleFor: aButton! ! 423881 423882!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 4/25/2007 17:25'! 423883buttonNormalBorderStyleFor: aButton 423884 "Return the normal button borderStyle for the given button." 423885 423886 |c| 423887 c := aButton colorToUse. 423888 aButton isDefault 423889 ifTrue: [c := c alphaMixed: 0.5 with: Color black]. 423890 ^BorderStyle simple 423891 width: 1; 423892 baseColor: c! ! 423893 423894!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 4/25/2007 18:12'! 423895buttonPressedBorderStyleFor: aButton 423896 "Return the pressed button borderStyle for the given button." 423897 423898 ^self buttonSelectedBorderStyleFor: aButton! ! 423899 423900!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 4/25/2007 17:27'! 423901buttonSelectedBorderStyleFor: aButton 423902 "Return the selected button borderStyle for the given button." 423903 423904 ^self buttonNormalBorderStyleFor: aButton! ! 423905 423906!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 4/25/2007 17:29'! 423907buttonSelectedDisabledBorderStyleFor: aButton 423908 "Return the selecteddisabled button borderStyle for the given button." 423909 423910 ^self buttonSelectedBorderStyleFor: aButton! ! 423911 423912!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 3/23/2007 17:19'! 423913buttonSelectedMouseOverBorderStyleFor: aButton 423914 "Return the selected mouse over button borderStyle for the given button." 423915 423916 ^self buttonSelectedBorderStyleFor: aButton! ! 423917 423918!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 3/23/2007 17:19'! 423919buttonSelectedPressedBorderStyleFor: aButton 423920 "Return the selected pressed button borderStyle for the given button." 423921 423922 ^self buttonNormalBorderStyleFor: aButton! ! 423923 423924!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 5/23/2007 12:26'! 423925checkboxButtonDisabledBorderStyleFor: aCheckboxButton 423926 "Return the disabled checkbox button borderStyle for the given button." 423927 423928 ^BorderStyle simple 423929 width: 1; 423930 baseColor: aCheckboxButton paneColor darker! ! 423931 423932!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 5/23/2007 12:28'! 423933checkboxButtonNormalBorderStyleFor: aCheckboxButton 423934 "Return the normal checkbox button borderStyle for the given button." 423935 423936 ^BorderStyle simple 423937 width: 1; 423938 baseColor: aCheckboxButton paneColor twiceDarker! ! 423939 423940!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 2/29/2008 22:00'! 423941checkboxButtonSelectedBorderStyleFor: aCheckboxButton 423942 "Return the selected checkbox button borderStyle for the given button." 423943 423944 ^self checkboxButtonNormalBorderStyleFor: aCheckboxButton! ! 423945 423946!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 2/29/2008 22:00'! 423947checkboxButtonSelectedDisabledBorderStyleFor: aCheckboxButton 423948 "Return the selected disabled checkbox button borderStyle for the given button." 423949 423950 ^self checkboxButtonDisabledBorderStyleFor: aCheckboxButton! ! 423951 423952!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 12/8/2008 19:17'! 423953checkboxCornerStyleFor: aCheckbox 423954 "Answer the corner style for checkbox buttons." 423955 423956 ^#square! ! 423957 423958!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 11/13/2007 11:33'! 423959controlButtonDisabledBorderStyleFor: aButton 423960 "Return the disabled control button borderStyle for the given button. 423961 Control buttons are generally used for drop-lists and expanders." 423962 423963 ^self buttonDisabledBorderStyleFor: aButton! ! 423964 423965!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 11/13/2007 11:33'! 423966controlButtonMouseOverBorderStyleFor: aButton 423967 "Return the mouse over control button borderStyle for the given button. 423968 Control buttons are generally used for drop-lists and expanders." 423969 423970 ^self buttonMouseOverBorderStyleFor: aButton! ! 423971 423972!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 11/13/2007 11:32'! 423973controlButtonNormalBorderStyleFor: aButton 423974 "Return the normal control button borderStyle for the given button. 423975 Control buttons are generally used for drop-lists and expanders." 423976 423977 ^self buttonNormalBorderStyleFor: aButton! ! 423978 423979!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 11/13/2007 11:58'! 423980controlButtonPressedBorderStyleFor: aButton 423981 "Return the pressed control button borderStyle for the given button. 423982 Control buttons are generally used for drop-lists and expanders." 423983 423984 ^self buttonPressedBorderStyleFor: aButton! ! 423985 423986!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 11/13/2007 11:33'! 423987controlButtonSelectedDisabledBorderStyleFor: aButton 423988 "Return the selected disabled control button borderStyle for the given button. 423989 Control buttons are generally used for drop-lists and expanders." 423990 423991 ^self buttonSelectedDisabledBorderStyleFor: aButton! ! 423992 423993!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 11/13/2007 11:34'! 423994controlButtonSelectedMouseOverBorderStyleFor: aButton 423995 "Return the selected mouse over control button borderStyle for the given button. 423996 Control buttons are generally used for drop-lists and expanders." 423997 423998 ^self buttonSelectedMouseOverBorderStyleFor: aButton! ! 423999 424000!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 11/13/2007 11:34'! 424001controlButtonSelectedPressedBorderStyleFor: aButton 424002 "Return the selected pressed control button borderStyle for the given button. 424003 Control buttons are generally used for drop-lists and expanders." 424004 424005 ^self buttonSelectedPressedBorderStyleFor: aButton! ! 424006 424007!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 1/23/2009 12:27'! 424008dropListFocusBoundsFor: aDropList 424009 "Answer the bounds for drawing the focus indication for the 424010 given drop list." 424011 424012 ^(aDropList innerBounds 424013 insetBy: (0@0 corner: aDropList buttonMorph width@0)) 424014 insetBy: aDropList layoutInset! ! 424015 424016!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 6/4/2007 13:05'! 424017menuItemInDockingBarSelectedBorderStyleFor: aMenuItem 424018 "Return the selected menu item borderStyle when in a docking bar for the given menu item." 424019 424020 ^self menuItemSelectedBorderStyleFor: aMenuItem! ! 424021 424022!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 6/4/2007 13:03'! 424023menuItemSelectedBorderStyleFor: aMenuItem 424024 "Return the selected menu item borderStyle for the given menu item." 424025 424026 ^BorderStyle simple 424027 width: 0! ! 424028 424029!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 12/8/2008 19:17'! 424030radioButtonCornerStyleFor: aRadioButton 424031 "Answer the corner style for radio buttons." 424032 424033 ^#rounded! ! 424034 424035!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 8/10/2007 10:14'! 424036radioButtonDisabledBorderStyleFor: aRadioButton 424037 "Return the disabled radio button borderStyle for the given button." 424038 424039 ^self checkboxButtonDisabledBorderStyleFor: aRadioButton! ! 424040 424041!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 8/10/2007 10:14'! 424042radioButtonNormalBorderStyleFor: aRadioButton 424043 "Return the disabled radio button borderStyle for the given button." 424044 424045 ^self checkboxButtonNormalBorderStyleFor: aRadioButton! ! 424046 424047!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 2/29/2008 22:08'! 424048radioButtonSelectedBorderStyleFor: aRadioButton 424049 "Return the selected radio button borderStyle for the given button." 424050 424051 ^self radioButtonNormalBorderStyleFor: aRadioButton! ! 424052 424053!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 2/29/2008 22:01'! 424054radioButtonSelectedDisabledBorderStyleFor: aRadioButton 424055 "Return the selecteddisabled radio button borderStyle for the given button." 424056 424057 ^self radioButtonDisabledBorderStyleFor: aRadioButton! ! 424058 424059!UITheme methodsFor: 'border-styles-buttons' stamp: 'gvc 1/27/2009 14:04'! 424060textEntryCornerStyleIn: aThemedMorph 424061 "Answer the corner style to use for text entry morphs." 424062 424063 ^aThemedMorph 424064 ifNil: [#square] 424065 ifNotNilDo: [:tm | tm preferredCornerStyle]! ! 424066 424067 424068!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 10/24/2007 15:14'! 424069scrollbarButtonCornerStyleIn: aThemedMorph 424070 "Allow for themes to override default behaviour." 424071 424072 ^#square! ! 424073 424074!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 6/4/2007 15:15'! 424075scrollbarMouseOverBarButtonBorderStyleFor: aScrollbar 424076 "Return the button borderStyle for the given scrollbar when 424077 the mouse is over the bar." 424078 424079 ^self scrollbarNormalButtonBorderStyleFor: aScrollbar! ! 424080 424081!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 6/4/2007 15:41'! 424082scrollbarMouseOverBarThumbBorderStyleFor: aScrollbar 424083 "Return the thumb borderStyle for the given scrollbar when 424084 the mouse is over the bar." 424085 424086 ^self scrollbarNormalThumbBorderStyleFor: aScrollbar! ! 424087 424088!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 3/30/2007 10:16'! 424089scrollbarMouseOverBorderStyleFor: aScrollbar 424090 "Return the mouse over borderStyle for the given scrollbar." 424091 424092 ^self scrollbarNormalBorderStyleFor: aScrollbar! ! 424093 424094!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 3/30/2007 10:16'! 424095scrollbarMouseOverButtonBorderStyleFor: aScrollbar 424096 "Return the mouse over button borderStyle for the given scrollbar." 424097 424098 ^self scrollbarNormalButtonBorderStyleFor: aScrollbar! ! 424099 424100!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 3/30/2007 10:16'! 424101scrollbarMouseOverThumbBorderStyleFor: aScrollbar 424102 "Return the mouse over thumb borderStyle for the given scrollbar." 424103 424104 ^self scrollbarNormalThumbBorderStyleFor: aScrollbar! ! 424105 424106!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 6/4/2007 15:50'! 424107scrollbarMouseOverThumbButtonBorderStyleFor: aScrollbar 424108 "Return the button borderStyle for the given scrollbar when 424109 the mouse is over the thumb." 424110 424111 ^self scrollbarMouseOverBarButtonBorderStyleFor: aScrollbar! ! 424112 424113!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 3/30/2007 10:30'! 424114scrollbarNormalBorderStyleFor: aScrollbar 424115 "Return the normal button borderStyle for the given scrollbar." 424116 424117 ^BorderStyle simple 424118 width: 0; 424119 baseColor: Color transparent! ! 424120 424121!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 3/30/2007 10:27'! 424122scrollbarNormalButtonBorderStyleFor: aScrollbar 424123 "Return the normal button borderStyle for the given scrollbar." 424124 424125 ^self scrollbarNormalThumbBorderStyleFor: aScrollbar! ! 424126 424127!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 4/25/2007 17:15'! 424128scrollbarNormalThumbBorderStyleFor: aScrollbar 424129 "Return the normal thumb borderStyle for the given scrollbar." 424130 424131 |aColor| 424132 aColor := self scrollbarColorFor: aScrollbar. 424133 ^BorderStyle simple 424134 width: 1; 424135 baseColor: aColor twiceDarker! ! 424136 424137!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 10/24/2007 15:04'! 424138scrollbarPagingAreaCornerStyleIn: aThemedMorph 424139 "Allow for themes to override default behaviour." 424140 424141 ^#square! ! 424142 424143!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 4/5/2007 14:24'! 424144scrollbarPressedBorderStyleFor: aScrollbar 424145 "Return the pressed borderStyle for the given scrollbar." 424146 424147 ^self scrollbarNormalBorderStyleFor: aScrollbar! ! 424148 424149!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 4/2/2007 14:04'! 424150scrollbarPressedButtonBorderStyleFor: aScrollbar 424151 "Return the pressed button borderStyle for the given scrollbar." 424152 424153 ^self scrollbarPressedThumbBorderStyleFor: aScrollbar! ! 424154 424155!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 4/25/2007 17:11'! 424156scrollbarPressedThumbBorderStyleFor: aScrollbar 424157 "Return the pressed thumb borderStyle for the given scrollbar." 424158 424159 ^self scrollbarNormalThumbBorderStyleFor: aScrollbar! ! 424160 424161!UITheme methodsFor: 'border-styles-scrollbars' stamp: 'gvc 10/24/2007 15:05'! 424162scrollbarThumbCornerStyleIn: aThemedMorph 424163 "Allow for themes to override default behaviour." 424164 424165 ^#square! ! 424166 424167 424168!UITheme methodsFor: 'copying' stamp: 'gvc 9/22/2006 17:20'! 424169postCopy 424170 "Copy the settings too." 424171 424172 super postCopy. 424173 self settings: self settings copy! ! 424174 424175 424176!UITheme methodsFor: 'defaults' stamp: 'gvc 1/9/2009 17:45'! 424177buttonFocusIndicatorCornerRadiusFor: aButton 424178 "Answer the default corner radius preferred for the focus indicator 424179 for the button for themes that support this." 424180 424181 ^self focusIndicatorCornerRadiusFor: aButton! ! 424182 424183!UITheme methodsFor: 'defaults' stamp: 'gvc 12/1/2008 11:36'! 424184buttonFont 424185 "Answer the button font to use." 424186 424187 ^Preferences standardButtonFont! ! 424188 424189!UITheme methodsFor: 'defaults' stamp: 'gvc 12/5/2008 14:56'! 424190buttonLabelInsetFor: aButton 424191 "Answer the inset to use for a button's label." 424192 424193 ^2! ! 424194 424195!UITheme methodsFor: 'defaults' stamp: 'gvc 12/3/2008 17:22'! 424196buttonMinHeight 424197 "Answer the minumum height of a button for this theme." 424198 424199 ^16! ! 424200 424201!UITheme methodsFor: 'defaults' stamp: 'gvc 12/3/2008 17:22'! 424202buttonMinWidth 424203 "Answer the minumum width of a button for this theme." 424204 424205 ^16! ! 424206 424207!UITheme methodsFor: 'defaults' stamp: 'gvc 6/8/2009 14:20'! 424208buttonPressedLabelInsetFor: aButton 424209 "Answer the inset to use for a button's label when pressed." 424210 424211 ^self buttonLabelInsetFor: aButton! ! 424212 424213!UITheme methodsFor: 'defaults' stamp: 'gvc 12/5/2008 16:54'! 424214controlButtonLabelInsetFor: aButton 424215 "Answer the inset to use for a control button's label." 424216 424217 ^self buttonLabelInsetFor: aButton! ! 424218 424219!UITheme methodsFor: 'defaults' stamp: 'gvc 2/22/2008 21:28'! 424220defaultButtonBorderColor 424221 "Answer the color to use for a 'default' button." 424222 424223 ^self settings selectionColor! ! 424224 424225!UITheme methodsFor: 'defaults' stamp: 'gvc 10/16/2008 14:09'! 424226defaultMenuColor 424227 "Answer the default color to use for a menu 424228 in the absence of an override in settings." 424229 424230 ^Preferences menuColor! ! 424231 424232!UITheme methodsFor: 'defaults' stamp: 'gvc 10/16/2008 15:06'! 424233defaultMenuTitleColor 424234 "Answer the default color to use for a menu title 424235 in the absence of an override in settings." 424236 424237 ^Preferences menuTitleColor! ! 424238 424239!UITheme methodsFor: 'defaults' stamp: 'gvc 6/2/2009 10:18'! 424240dialogWindowPreferredCornerStyleFor: aDialogWindow 424241 "Answer the preferred corner style for the given dialog." 424242 424243 ^#rounded! ! 424244 424245!UITheme methodsFor: 'defaults' stamp: 'gvc 1/28/2009 17:07'! 424246dropListControlButtonWidth 424247 "Answer the width of a drop list control button for this theme." 424248 424249 ^self buttonMinWidth! ! 424250 424251!UITheme methodsFor: 'defaults' stamp: 'gvc 1/20/2009 16:39'! 424252dropListFocusIndicatorCornerRadiusFor: aDropList 424253 "Answer the default corner radius preferred for the focus indicator 424254 for the drop list for themes that support this." 424255 424256 ^self focusIndicatorCornerRadiusFor: aDropList! ! 424257 424258!UITheme methodsFor: 'defaults' stamp: 'gvc 12/19/2006 13:10'! 424259dropListFont 424260 "Answer the drop list font to use." 424261 424262 ^self textFont! ! 424263 424264!UITheme methodsFor: 'defaults' stamp: 'gvc 2/23/2008 16:29'! 424265dropListInsetFor: aDropList 424266 "Answer the inset to use for drop-list layout." 424267 424268 ^(0@0 corner: -1@0)! ! 424269 424270!UITheme methodsFor: 'defaults' stamp: 'gvc 1/28/2009 17:08'! 424271expanderTitleControlButtonWidth 424272 "Answer the width of an expander title control button for this theme." 424273 424274 ^self buttonMinWidth! ! 424275 424276!UITheme methodsFor: 'defaults' stamp: 'gvc 12/5/2008 14:55'! 424277expanderTitleInsetFor: anExpanderTitle 424278 "Answer the inset to use for expander title layout." 424279 424280 ^anExpanderTitle borderWidth negated! ! 424281 424282!UITheme methodsFor: 'defaults' stamp: 'gvc 1/20/2009 17:00'! 424283focusIndicatorCornerRadiusFor: aMorph 424284 "Answer the default corner radius preferred for the focus indicator 424285 for the morph for themes that support this." 424286 424287 ^aMorph wantsRoundedCorners 424288 ifTrue: [6] 424289 ifFalse: [2]! ! 424290 424291!UITheme methodsFor: 'defaults' stamp: 'gvc 9/8/2006 13:59'! 424292labelFont 424293 "Answer the label font to use." 424294 424295 ^self textFont! ! 424296 424297!UITheme methodsFor: 'defaults' stamp: 'gvc 12/1/2008 11:34'! 424298listFont 424299 "Answer the list font to use." 424300 424301 ^Preferences standardListFont! ! 424302 424303!UITheme methodsFor: 'defaults' stamp: 'gvc 9/13/2006 11:26'! 424304menuBarFont 424305 "Answer the menu bar font to use." 424306 424307 ^self textFont! ! 424308 424309!UITheme methodsFor: 'defaults' stamp: 'gvc 10/26/2006 16:48'! 424310menuColor 424311 "Answer the menu color to use." 424312 424313 ^self settings menuColor! ! 424314 424315!UITheme methodsFor: 'defaults' stamp: 'gvc 12/1/2008 11:35'! 424316menuFont 424317 "Answer the menu font to use." 424318 424319 ^Preferences standardMenuFont! ! 424320 424321!UITheme methodsFor: 'defaults' stamp: 'gvc 10/16/2008 16:21'! 424322menuTitleColor 424323 "Answer the menu title color to use." 424324 424325 ^self settings menuTitleColor! ! 424326 424327!UITheme methodsFor: 'defaults' stamp: 'gvc 10/7/2008 11:45'! 424328scrollbarMinimumThumbThickness 424329 "Answer the minumum width or height of a scrollbar thumb 424330 as appropriate to its orientation." 424331 424332 ^7! ! 424333 424334!UITheme methodsFor: 'defaults' stamp: 'gvc 10/3/2008 13:04'! 424335scrollbarThickness 424336 "Answer the width or height of a scrollbar as appropriate to 424337 its orientation." 424338 424339 ^Preferences scrollBarsNarrow 424340 ifTrue: [10] 424341 ifFalse: [14]! ! 424342 424343!UITheme methodsFor: 'defaults' stamp: 'gvc 10/12/2006 14:01'! 424344selectionColor 424345 "Answer the selection color to use.." 424346 424347 ^self settings selectionColor! ! 424348 424349!UITheme methodsFor: 'defaults' stamp: 'gvc 6/1/2009 12:42'! 424350setSystemProgressMorphDefaultParameters: aProgressMorph 424351 "Set up the given progress morph." 424352 424353 | colorFromMenu worldColor menuColor | 424354 colorFromMenu := Preferences menuColorFromWorld 424355 and: [Display depth > 4] 424356 and: [(worldColor := aProgressMorph currentWorld color) isColor]. 424357 menuColor := colorFromMenu 424358 ifTrue: [worldColor luminance > 0.7 424359 ifTrue: [worldColor mixed: 0.85 with: Color black] 424360 ifFalse: [worldColor mixed: 0.4 with: Color white]] 424361 ifFalse: [Preferences menuColor]. 424362 aProgressMorph color: menuColor. 424363 Preferences roundedMenuCorners 424364 ifTrue: [aProgressMorph useRoundedCorners]. 424365 aProgressMorph borderWidth: Preferences menuBorderWidth. 424366 Preferences menuAppearance3d 424367 ifTrue: [aProgressMorph borderStyle: BorderStyle thinGray. 424368 aProgressMorph 424369 addDropShadow; 424370 shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.666); 424371 shadowOffset: 1 @ 1] 424372 ifFalse: [| menuBorderColor | 424373 menuBorderColor := colorFromMenu 424374 ifTrue: [worldColor muchDarker] 424375 ifFalse: [Preferences menuBorderColor]. 424376 aProgressMorph borderColor: menuBorderColor]. 424377 aProgressMorph 424378 updateColor: aProgressMorph 424379 color: aProgressMorph color 424380 intensity: 1! ! 424381 424382!UITheme methodsFor: 'defaults' stamp: 'gvc 12/1/2008 11:40'! 424383statusFont 424384 "Answer the status font to use." 424385 424386 ^((TextStyle named: #BitstreamVeraSansMono) ifNil: [TextStyle default]) 424387 fontOfPointSize: 8! ! 424388 424389!UITheme methodsFor: 'defaults' stamp: 'gvc 1/14/2009 15:27'! 424390tabLabelInsetFor: aButton 424391 "Answer the inset to use for a tab label." 424392 424393 ^4@2 corner: 4@0! ! 424394 424395!UITheme methodsFor: 'defaults' stamp: 'gvc 6/2/2009 10:56'! 424396tabSelectorMorphMinExtentFor: aTabSelectorMorph 424397 "Answer the min extent of the given tab selector." 424398 424399 ^aTabSelectorMorph basicMinExtent + (8@1)! ! 424400 424401!UITheme methodsFor: 'defaults' stamp: 'gvc 12/1/2008 11:37'! 424402textFont 424403 "Answer the text font to use." 424404 424405 ^Preferences standardDefaultTextFont! ! 424406 424407!UITheme methodsFor: 'defaults' stamp: 'gvc 10/12/2006 14:53'! 424408windowColor 424409 "Answer the window color to use." 424410 424411 ^self settings windowColor! ! 424412 424413!UITheme methodsFor: 'defaults' stamp: 'gvc 6/2/2009 10:34'! 424414windowPreferredCornerStyleFor: aWindow 424415 "Answer the preferred corner style for the given window." 424416 424417 ^(Preferences roundedWindowCorners or: [ 424418 aWindow cornerStyle == #rounded]) 424419 ifTrue: [#rounded] 424420 ifFalse: [#square]! ! 424421 424422!UITheme methodsFor: 'defaults' stamp: 'gvc 2/9/2009 17:12'! 424423windowShadowColor 424424 "Answer the window shadow color to use." 424425 424426 ^Color black alpha: 0.5! ! 424427 424428 424429!UITheme methodsFor: 'fill-styles' stamp: 'gvc 11/13/2007 12:41'! 424430desktopFillStyleFor: aWorld 424431 "Answer the desktop fill style for the given world. 424432 Answer nil for no change." 424433 424434 |filename| 424435 filename := FileDirectory fileName: self class themeName extension: 'jpg'. 424436 ^(FileDirectory default fileExists: filename) ifTrue: [ 424437 BitmapFillStyle 424438 fromForm: (ImageReadWriter formFromFileNamed: filename)]! ! 424439 424440!UITheme methodsFor: 'fill-styles' stamp: 'gvc 4/26/2007 09:53'! 424441dialogWindowActiveFillStyleFor: aWindow 424442 "Return the dialog window active fillStyle for the given window." 424443 424444 ^aWindow paneColorToUse lighter! ! 424445 424446!UITheme methodsFor: 'fill-styles' stamp: 'gvc 4/26/2007 09:52'! 424447dialogWindowInactiveFillStyleFor: aWindow 424448 "Return the dialog window inactive fillStyle for the given window." 424449 424450 ^Preferences fadedBackgroundWindows 424451 ifTrue: [aWindow paneColorToUse lighter 424452 alphaMixed: 0.9 424453 with: (Color white alpha: aWindow paneColorToUse alpha)] 424454 ifFalse: [aWindow paneColorToUse lighter]! ! 424455 424456!UITheme methodsFor: 'fill-styles' stamp: 'gvc 7/30/2009 14:11'! 424457dockingBarNormalFillStyleFor: aToolDockingBar 424458 "Return the normal docking bar fillStyle for the given color." 424459 424460 |aColor| 424461 aColor := aToolDockingBar originalColor. 424462 ^(GradientFillStyle ramp: { 424463 0.0->aColor whiter whiter. 0.2->aColor lighter. 424464 0.8->aColor darker. 1.0->aColor blacker}) 424465 origin: aToolDockingBar topLeft; 424466 direction: (aToolDockingBar isVertical 424467 ifTrue: [aToolDockingBar width @ 0] 424468 ifFalse: [0 @ aToolDockingBar height]); 424469 radial: false! ! 424470 424471!UITheme methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 10:56'! 424472dropListDisabledFillStyleFor: aDropList 424473 "Return the disabled fillStyle for the given drop list." 424474 424475 ^aDropList paneColor alphaMixed: 0.3 with: Color white! ! 424476 424477!UITheme methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 10:56'! 424478dropListNormalFillStyleFor: aDropList 424479 "Return the normal fillStyle for the given drop list." 424480 424481 ^Color white! ! 424482 424483!UITheme methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 11:07'! 424484dropListNormalListFillStyleFor: aDropList 424485 "Return the normal fillStyle for the list of the given drop list." 424486 424487 ^Color white! ! 424488 424489!UITheme methodsFor: 'fill-styles' stamp: 'gvc 5/23/2007 14:25'! 424490expanderTitleNormalFillStyleFor: anExpanderTitle 424491 "Return the normal expander title fillStyle for the given expander title." 424492 424493 ^anExpanderTitle paneColor! ! 424494 424495!UITheme methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 12:39'! 424496listDisabledFillStyleFor: aList 424497 "Return the disabled fillStyle for the given list." 424498 424499 ^aList paneColor alphaMixed: 0.3 with: Color white! ! 424500 424501!UITheme methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 12:39'! 424502listNormalFillStyleFor: aList 424503 "Return the normal fillStyle for the given list." 424504 424505 ^Color white! ! 424506 424507!UITheme methodsFor: 'fill-styles' stamp: 'gvc 10/16/2008 15:38'! 424508menuColorFor: aThemedMorph 424509 "Answer the menu color to use." 424510 424511 |w| 424512 ^self menuColor ifNil: [ 424513 aThemedMorph ifNil: [^self defaultMenuColor]. 424514 w := aThemedMorph isSystemWindow 424515 ifTrue: [aThemedMorph] 424516 ifFalse: [aThemedMorph ownerThatIsA: SystemWindow]. 424517 w isNil 424518 ifTrue: [self defaultMenuColor] 424519 ifFalse: [(w valueOfProperty: #paneColor) ifNil: [self defaultMenuColor]]]! ! 424520 424521!UITheme methodsFor: 'fill-styles' stamp: 'gvc 10/16/2008 15:51'! 424522menuTitleColorFor: aThemedMorph 424523 "Answer the menu titlecolor to use." 424524 424525 |w| 424526 ^self menuTitleColor ifNil: [ 424527 aThemedMorph ifNil: [^self defaultMenuTitleColor]. 424528 w := aThemedMorph isSystemWindow 424529 ifTrue: [aThemedMorph] 424530 ifFalse: [aThemedMorph ownerThatIsA: SystemWindow]. 424531 w isNil 424532 ifTrue: [self defaultMenuTitleColor] 424533 ifFalse: [(w valueOfProperty: #paneColor) darker ifNil: [self defaultMenuTitleColor]]]! ! 424534 424535!UITheme methodsFor: 'fill-styles' stamp: 'gvc 1/28/2009 18:00'! 424536multiFormFillStyleFrom: anArray cornerWidths: widthArray in: aRectangle 424537 "Answer a composite fill style from the given forms and central colour 424538 in the given bounds. Use the widths specified for the portion of the 424539 corner forms to display." 424540 424541 |tl tm tr ml mr bl bm br c tlw trw blw brw| 424542 tl := anArray first. tlw:= widthArray first. 424543 tm := anArray second. 424544 tr := anArray third. trw := widthArray second. 424545 ml := anArray fourth. 424546 c := anArray fifth. 424547 mr := anArray sixth. 424548 bl := anArray seventh. blw := widthArray third. 424549 bm := anArray eighth. 424550 br := anArray ninth. brw := widthArray fourth. 424551 ^CompositeFillStyle fillStyles: { 424552 (ImageFillStyle form: tl) 424553 origin: aRectangle topLeft; 424554 extent: tlw@tl height. 424555 (AlphaInfiniteForm with: tm) 424556 origin: aRectangle topLeft + (tlw@0); 424557 extent: (aRectangle width - trw - tlw)@tm height. 424558 (ImageFillStyle form: tr) 424559 origin: aRectangle topRight - (tr width@0); 424560 extent: trw@tr height; 424561 offset: (tr width - trw)@0. 424562 (AlphaInfiniteForm with: ml) 424563 origin: aRectangle topLeft + (0@tl height); 424564 extent: ml width@(aRectangle height - tl height - bl height). 424565 (ColorFillStyle color: c) 424566 origin: aRectangle topLeft + (tlw@tl height); 424567 extent: aRectangle extent - (tlw@tl height) - (brw@br height). 424568 (AlphaInfiniteForm with: mr) 424569 origin: aRectangle topRight + (trw negated@tr height); 424570 extent: mr width@(aRectangle height - tr height - br height). 424571 (ImageFillStyle form: bl) 424572 origin: aRectangle bottomLeft - (0@bl height); 424573 extent: blw@bl height. 424574 (AlphaInfiniteForm with: bm) 424575 origin: aRectangle bottomLeft - (blw negated@bl height); 424576 extent: (aRectangle width - blw - brw)@bm height. 424577 (ImageFillStyle form: br) 424578 origin: aRectangle bottomRight - br extent; 424579 extent: brw@br height; 424580 offset: (br width - brw)@0}! ! 424581 424582!UITheme methodsFor: 'fill-styles' stamp: 'gvc 1/28/2009 17:43'! 424583multiFormFillStyleFrom: anArray in: aRectangle 424584 "Answer a composite fill style from the given forms and central colour 424585 in the given bounds." 424586 424587 |tl tm tr ml mr bl bm br c| 424588 tl := anArray first. 424589 tm := anArray second. 424590 tr := anArray third. 424591 ml := anArray fourth. 424592 c := anArray fifth. 424593 mr := anArray sixth. 424594 bl := anArray seventh. 424595 bm := anArray eighth. 424596 br := anArray ninth. 424597 ^CompositeFillStyle fillStyles: { 424598 (ImageFillStyle form: tl) origin: aRectangle topLeft. 424599 (AlphaInfiniteForm with: tm) 424600 origin: aRectangle topLeft + (tl width@0); 424601 extent: (aRectangle width - tl width - tr width)@tm height. 424602 (ImageFillStyle form: tr) 424603 origin: aRectangle topRight - (tr width@0). 424604 (AlphaInfiniteForm with: ml) 424605 origin: aRectangle topLeft + (0@tl height); 424606 extent: ml width@(aRectangle height - tl height - bl height). 424607 (ColorFillStyle color: c) 424608 origin: aRectangle topLeft + tl extent; 424609 extent: aRectangle extent - tl extent - br extent. 424610 (AlphaInfiniteForm with: mr) 424611 origin: aRectangle topRight + (tr width negated@tr height); 424612 extent: mr width@(aRectangle height - tr height - br height). 424613 (ImageFillStyle form: bl) origin: aRectangle bottomLeft - (0@bl height). 424614 (AlphaInfiniteForm with: bm) 424615 origin: aRectangle bottomLeft - (bl width negated@bl height); 424616 extent: (aRectangle width - bl width - br width)@bm height. 424617 (ImageFillStyle form: br) 424618 origin: aRectangle bottomRight - br extent}! ! 424619 424620!UITheme methodsFor: 'fill-styles' stamp: 'gvc 1/12/2009 18:23'! 424621multiFormTopFillStyleFrom: anArray in: aRectangle 424622 "Answer a composite fill style from the given forms and central colour 424623 in the given bounds. Only top and middle sections are considered." 424624 424625 |tl tm tr ml mr c| 424626 tl := anArray first. 424627 tm := anArray second. 424628 tr := anArray third. 424629 ml := anArray fourth. 424630 c := anArray fifth. 424631 mr := anArray sixth. 424632 ^CompositeFillStyle fillStyles: { 424633 (ImageFillStyle form: tl) origin: aRectangle topLeft. 424634 (AlphaInfiniteForm with: tm) 424635 origin: aRectangle topLeft + (tl width@0); 424636 extent: (aRectangle width - tl width - tr width)@tm height. 424637 (ImageFillStyle form: tr) 424638 origin: aRectangle topRight - (tr width@0). 424639 (AlphaInfiniteForm with: ml) 424640 origin: aRectangle topLeft + (0@tr height); 424641 extent: ml width@(aRectangle height - tl height). 424642 (ColorFillStyle color: c) 424643 origin: aRectangle topLeft + tl extent; 424644 extent: aRectangle extent - tl extent - (mr width @0). 424645 (AlphaInfiniteForm with: mr) 424646 origin: aRectangle topRight + (tr width negated@tr height); 424647 extent: mr width@(aRectangle height - tr height)}! ! 424648 424649!UITheme methodsFor: 'fill-styles' stamp: 'gvc 4/24/2007 11:44'! 424650progressBarFillStyleFor: aProgressBar 424651 "Return the progress bar fillStyle for the given progress bar." 424652 424653 |aColor area| 424654 aColor := self progressBarColorFor: aProgressBar. 424655 area := aProgressBar bounds. 424656 ^(GradientFillStyle ramp: { 424657 0.0->aColor darker duller. 0.2-> aColor darker. 424658 0.8->aColor twiceLighter. 1.0->aColor}) 424659 origin: area origin; 424660 direction: 0@area height; 424661 radial: false! ! 424662 424663!UITheme methodsFor: 'fill-styles' stamp: 'gvc 4/24/2007 11:47'! 424664progressBarProgressFillStyleFor: aProgressBar 424665 "Return the progress bar progress fillStyle for the given progress bar." 424666 424667 |aColor area| 424668 aColor := self progressBarProgressColorFor: aProgressBar. 424669 area := aProgressBar innerBounds. 424670 ^(GradientFillStyle ramp: { 424671 0.0->(aColor alphaMixed: 0.3 with: (Color white alpha: aColor alpha)). 424672 0.2-> aColor twiceLighter. 424673 0.8->aColor darker. 424674 1.0->aColor darker duller}) 424675 origin: area origin; 424676 direction: 0@area height; 424677 radial: false! ! 424678 424679!UITheme methodsFor: 'fill-styles' stamp: 'gvc 3/27/2008 21:35'! 424680resizerGripNormalFillStyleFor: aResizer 424681 "Return the normal fillStyle for the given resizer. 424682 For the moment, answer a transparent colour for no drawing, 424683 non transparent to draw as normal." 424684 424685 ^Color white! ! 424686 424687!UITheme methodsFor: 'fill-styles' stamp: 'gvc 1/12/2009 13:11'! 424688separatorFillStyleFor: aSeparator 424689 "Return the separator fillStyle for the given separator." 424690 424691 |aColor| 424692 aColor := aSeparator paneColor. 424693 ^(GradientFillStyle ramp: { 424694 0.0->aColor whiter whiter. 0.2->aColor lighter. 424695 0.8->aColor darker. 1.0->aColor blacker}) 424696 origin: aSeparator topLeft; 424697 direction: (aSeparator bounds isWide 424698 ifTrue: [0 @ aSeparator height] 424699 ifFalse: [aSeparator width @ 0]); 424700 radial: false! ! 424701 424702!UITheme methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 11:38'! 424703sliderDisabledFillStyleFor: aSlider 424704 "Return the disabled fillStyle for the given slider." 424705 424706 ^aSlider paneColor alphaMixed: 0.3 with: Color white! ! 424707 424708!UITheme methodsFor: 'fill-styles' stamp: 'gvc 8/3/2007 15:27'! 424709sliderNormalFillStyleFor: aSlider 424710 "Return the normal fillStyle for the given slider." 424711 424712 ^Color white! ! 424713 424714!UITheme methodsFor: 'fill-styles' stamp: 'gvc 4/26/2007 10:12'! 424715splitterNormalFillStyleFor: aSplitter 424716 "Return the normal splitter fillStyle for the given splitter." 424717 424718 |aColor| 424719 aColor := aSplitter paneColor. 424720 ^(GradientFillStyle ramp: { 424721 0.0->aColor whiter whiter. 0.2->aColor lighter. 424722 0.8->aColor darker. 1.0->aColor blacker}) 424723 origin: aSplitter topLeft; 424724 direction: (aSplitter splitsTopAndBottom 424725 ifTrue: [0 @ aSplitter height] 424726 ifFalse: [aSplitter width @ 0]); 424727 radial: false! ! 424728 424729!UITheme methodsFor: 'fill-styles' stamp: 'gvc 4/26/2007 10:14'! 424730splitterPressedFillStyleFor: aSplitter 424731 "Return the pressed splitter fillStyle for the given splitter." 424732 424733 |aColor| 424734 aColor := aSplitter paneColor twiceDarker. 424735 ^(GradientFillStyle ramp: { 424736 0.0->Color white. 0.4-> aColor twiceLighter. 424737 1.0->aColor darker duller}) 424738 origin: aSplitter topLeft; 424739 direction: (aSplitter splitsTopAndBottom 424740 ifTrue: [0 @ aSplitter height] 424741 ifFalse: [aSplitter width @ 0]); 424742 radial: false! ! 424743 424744!UITheme methodsFor: 'fill-styles' stamp: 'gvc 1/7/2008 11:13'! 424745tabLabelNormalFillStyleFor: aTabLabel 424746 "Return the normal fillStyle for the given tab label." 424747 424748 ^aTabLabel paneColor lighter! ! 424749 424750!UITheme methodsFor: 'fill-styles' stamp: 'gvc 1/7/2008 11:14'! 424751tabLabelSelectedFillStyleFor: aTabLabel 424752 "Return the selected fillStyle for the given tab label." 424753 424754 ^aTabLabel paneColor! ! 424755 424756!UITheme methodsFor: 'fill-styles' stamp: 'gvc 3/14/2007 13:06'! 424757taskbarFillStyleFor: aTaskbar 424758 "Return the taskbar fillStyle for the given taskbar." 424759 424760 |aColor| 424761 aColor := aTaskbar color. 424762 ^(GradientFillStyle ramp: { 424763 0.0->(aColor alphaMixed: 0.3 with: (Color white alpha: aColor alpha)). 424764 0.2-> aColor twiceLighter. 424765 0.8->aColor darker. 424766 1.0->aColor darker duller}) 424767 origin: aTaskbar position; 424768 direction: 0@27; 424769 radial: false! ! 424770 424771!UITheme methodsFor: 'fill-styles' stamp: 'gvc 4/20/2007 10:46'! 424772tasklistFillStyleFor: aTasklist 424773 "Return the tasklist fillStyle for the given tasklist." 424774 424775 |aColor| 424776 aColor := aTasklist color. 424777 ^(GradientFillStyle ramp: { 424778 0.0->aColor whiter whiter. 0.2->aColor lighter. 424779 0.8->aColor darker. 1.0->aColor blacker}) 424780 origin: aTasklist topLeft; 424781 direction: 0 @ aTasklist height; 424782 radial: false! ! 424783 424784!UITheme methodsFor: 'fill-styles' stamp: 'gvc 5/23/2007 13:13'! 424785textEditorDisabledFillStyleFor: aTextEditor 424786 "Return the disabled fillStyle for the given text editor." 424787 424788 ^aTextEditor paneColor alphaMixed: 0.3 with: Color white! ! 424789 424790!UITheme methodsFor: 'fill-styles' stamp: 'gvc 5/23/2007 12:56'! 424791textEditorNormalFillStyleFor: aTextEditor 424792 "Return the normal fillStyle for the given text editor." 424793 424794 ^Color white! ! 424795 424796!UITheme methodsFor: 'fill-styles' stamp: 'gvc 5/23/2007 13:06'! 424797textFieldDisabledFillStyleFor: aTextField 424798 "Return the disabled fillStyle for the given text field." 424799 424800 ^self textEditorDisabledFillStyleFor: aTextField! ! 424801 424802!UITheme methodsFor: 'fill-styles' stamp: 'gvc 5/23/2007 13:06'! 424803textFieldNormalFillStyleFor: aTextField 424804 "Return the normal fillStyle for the given text field." 424805 424806 ^self textEditorNormalFillStyleFor: aTextField! ! 424807 424808!UITheme methodsFor: 'fill-styles' stamp: 'gvc 4/25/2007 18:01'! 424809windowActiveFillStyleFor: aWindow 424810 "Return the window active fillStyle for the given window." 424811 424812 ^aWindow paneColorToUse! ! 424813 424814!UITheme methodsFor: 'fill-styles' stamp: 'gvc 5/22/2007 11:16'! 424815windowActiveLabelFillStyleFor: aWindow 424816 "Return the window active label fillStyle for the given window." 424817 424818 ^Color black! ! 424819 424820!UITheme methodsFor: 'fill-styles' stamp: 'gvc 4/25/2007 17:32'! 424821windowActiveTitleFillStyleFor: aWindow 424822 "Return the window active title fillStyle for the given color." 424823 424824 ^Color transparent! ! 424825 424826!UITheme methodsFor: 'fill-styles' stamp: 'gvc 10/1/2007 14:22'! 424827windowEdgeNormalFillStyleFor: anEdgeGrip 424828 "Return the normal window edge fillStyle for the given edge grip." 424829 424830 ^Color transparent! ! 424831 424832!UITheme methodsFor: 'fill-styles' stamp: 'gvc 10/1/2007 14:21'! 424833windowEdgePressedFillStyleFor: anEdgeGrip 424834 "Return the pressed window edge fillStyle for the given edge grip." 424835 424836 ^self windowEdgeNormalFillStyleFor: anEdgeGrip! ! 424837 424838!UITheme methodsFor: 'fill-styles' stamp: 'gvc 6/2/2009 16:04'! 424839windowExtentChangedFor: aWindow 424840 "Update any extent related visuals." 424841! ! 424842 424843!UITheme methodsFor: 'fill-styles' stamp: 'gvc 4/25/2007 18:04'! 424844windowInactiveFillStyleFor: aWindow 424845 "Return the window inactive fillStyle for the given window." 424846 424847 ^Preferences fadedBackgroundWindows 424848 ifTrue: [aWindow paneColorToUse 424849 alphaMixed: 0.9 424850 with: (Color white alpha: aWindow paneColorToUse alpha)] 424851 ifFalse: [aWindow paneColorToUse]! ! 424852 424853!UITheme methodsFor: 'fill-styles' stamp: 'gvc 5/22/2007 11:21'! 424854windowInactiveLabelFillStyleFor: aWindow 424855 "Return the window inactive label fillStyle for the given window." 424856 424857 ^Preferences fadedBackgroundWindows 424858 ifTrue: [aWindow paneColorToUse alphaMixed: 0.6 with: Color black] 424859 ifFalse: [self windowActiveLabelFillStyleFor: aWindow]! ! 424860 424861!UITheme methodsFor: 'fill-styles' stamp: 'gvc 5/22/2007 10:53'! 424862windowInactiveTitleFillStyleFor: aWindow 424863 "Return the window inactive title fillStyle for the given color." 424864 424865 ^self windowActiveTitleFillStyleFor: aWindow! ! 424866 424867!UITheme methodsFor: 'fill-styles' stamp: 'gvc 10/24/2007 11:34'! 424868worldMainDockingBarNormalFillStyleFor: aDockingBar 424869 "Return the world main docking bar fillStyle for the given docking bar." 424870 424871 |aColor| 424872 aColor := aDockingBar originalColor. 424873 ^(GradientFillStyle ramp: {0.0 -> aColor muchLighter. 1.0 -> aColor}) 424874 origin: aDockingBar topLeft; 424875 direction: (aDockingBar isVertical 424876 ifTrue: [aDockingBar width @ 0] 424877 ifFalse: [0 @ aDockingBar height]); 424878 radial: false! ! 424879 424880 424881!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/26/2007 09:58'! 424882buttonDisabledFillStyleFor: aButton 424883 "Return the disabled button fillStyle for the given color." 424884 424885 ^self buttonNormalFillStyleFor: aButton! ! 424886 424887!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 18:54'! 424888buttonMouseOverFillStyleFor: aButton 424889 "Return the button mouse over fillStyle for the given color." 424890 424891 ^self buttonNormalFillStyleFor: aButton! ! 424892 424893!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 18:24'! 424894buttonNormalFillStyleFor: aButton 424895 "Return the normal button fillStyle for the given button." 424896 424897 ^self buttonColorFor: aButton! ! 424898 424899!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 3/14/2007 15:06'! 424900buttonPanelNormalFillStyleFor: aPanel 424901 "Return the normal panel fillStyle for the given panel." 424902 424903 ^aPanel paneColor! ! 424904 424905!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 18:52'! 424906buttonPressedFillStyleFor: aButton 424907 "Return the button pressed fillStyle for the given color." 424908 424909 ^self buttonMouseOverFillStyleFor: aButton! ! 424910 424911!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 18:53'! 424912buttonSelectedDisabledFillStyleFor: aButton 424913 "Return the button selected disabled fillStyle for the given color." 424914 424915 ^self buttonSelectedFillStyleFor: aButton! ! 424916 424917!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 18:53'! 424918buttonSelectedFillStyleFor: aButton 424919 "Return the button selected fillStyle for the given color." 424920 424921 ^self buttonNormalFillStyleFor: aButton! ! 424922 424923!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 18:53'! 424924buttonSelectedMouseOverFillStyleFor: aButton 424925 "Return the button selected mouse over fillStyle for the given color." 424926 424927 ^self buttonSelectedFillStyleFor: aButton! ! 424928 424929!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 18:52'! 424930buttonSelectedPressedFillStyleFor: aButton 424931 "Return the button selected pressed fillStyle for the given color." 424932 424933 ^self buttonSelectedMouseOverFillStyleFor: aButton! ! 424934 424935!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 5/23/2007 12:17'! 424936checkboxButtonDisabledFillStyleFor: aCheckboxButton 424937 "Return the disabled checkbox button fillStyle for the given button." 424938 424939 ^aCheckboxButton paneColor 424940 alphaMixed: 0.3 424941 with: Color white! ! 424942 424943!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 5/23/2007 12:03'! 424944checkboxButtonNormalFillStyleFor: aCheckboxButton 424945 "Return the normal checkbox button fillStyle for the given button." 424946 424947 ^Color white! ! 424948 424949!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 2/29/2008 21:47'! 424950checkboxButtonSelectedDisabledFillStyleFor: aCheckboxButton 424951 "Return the selected disabled checkbox button fillStyle for the given button." 424952 424953 ^self checkboxButtonDisabledFillStyleFor: aCheckboxButton! ! 424954 424955!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 2/29/2008 21:48'! 424956checkboxButtonSelectedFillStyleFor: aCheckboxButton 424957 "Return the selected checkbox button fillStyle for the given button." 424958 424959 ^self checkboxButtonNormalFillStyleFor: aCheckboxButton! ! 424960 424961!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 11/13/2007 11:29'! 424962controlButtonDisabledFillStyleFor: aButton 424963 "Return the disabled control button fillStyle for the given button. 424964 Control buttons are generally used for drop-lists and expanders." 424965 424966 ^self buttonDisabledFillStyleFor: aButton! ! 424967 424968!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 11/13/2007 11:29'! 424969controlButtonMouseOverFillStyleFor: aButton 424970 "Return the mouse over control button fillStyle for the given button. 424971 Control buttons are generally used for drop-lists and expanders." 424972 424973 ^self buttonMouseOverFillStyleFor: aButton! ! 424974 424975!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 10/28/2007 16:53'! 424976controlButtonNormalFillStyleFor: aButton 424977 "Return the normal control button fillStyle for the given button. 424978 Control buttons are generally used for drop-lists and expanders." 424979 424980 ^self buttonNormalFillStyleFor: aButton! ! 424981 424982!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 11/13/2007 11:59'! 424983controlButtonPressedFillStyleFor: aButton 424984 "Return the pressed button fillStyle for the given button. 424985 Control buttons are generally used for drop-lists and expanders." 424986 424987 ^self buttonPressedFillStyleFor: aButton! ! 424988 424989!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 11/13/2007 11:30'! 424990controlButtonSelectedDisabledFillStyleFor: aButton 424991 "Return the selected disabled control button fillStyle for the given button. 424992 Control buttons are generally used for drop-lists and expanders." 424993 424994 ^self buttonSelectedDisabledFillStyleFor: aButton! ! 424995 424996!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 12/9/2008 13:05'! 424997controlButtonSelectedFillStyleFor: aButton 424998 "Return the selected control button fillStyle for the given button. 424999 Control buttons are generally used for drop-lists and expanders." 425000 425001 ^self buttonSelectedFillStyleFor: aButton! ! 425002 425003!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 11/13/2007 11:30'! 425004controlButtonSelectedMouseOverFillStyleFor: aButton 425005 "Return the selected mouse over control button fillStyle for the given button. 425006 Control buttons are generally used for drop-lists and expanders." 425007 425008 ^self buttonSelectedMouseOverFillStyleFor: aButton! ! 425009 425010!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 11/13/2007 11:31'! 425011controlButtonSelectedPressedFillStyleFor: aButton 425012 "Return the selected pressed button fillStyle for the given button. 425013 Control buttons are generally used for drop-lists and expanders." 425014 425015 ^self buttonSelectedPressedFillStyleFor: aButton! ! 425016 425017!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 6/4/2007 12:53'! 425018menuItemInDockingBarSelectedFillStyleFor: aMenuItem 425019 "Answer the selected fill style to use for the given menu item that is in a docking bar." 425020 425021 | fill baseColor preferenced | 425022 Display depth <= 2 425023 ifTrue: [^ Color gray]. 425024 preferenced := Preferences menuSelectionColor. 425025 preferenced notNil ifTrue: [^preferenced]. 425026 baseColor := aMenuItem owner color negated. 425027 Preferences gradientMenu 425028 ifFalse: [^baseColor]. 425029 fill := GradientFillStyle ramp: {0.0 -> baseColor twiceLighter . 1 -> baseColor twiceDarker}. 425030 fill origin: aMenuItem topLeft. 425031 aMenuItem owner isVertical not 425032 ifTrue: [fill direction: 0 @ aMenuItem height] 425033 ifFalse: [fill direction: aMenuItem width @ 0]. 425034 ^ fill! ! 425035 425036!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 6/4/2007 12:55'! 425037menuItemSelectedFillStyleFor: aMenuItem 425038 "Answer the selected fill style to use for the given menu item." 425039 425040 | fill baseColor preferenced | 425041 Display depth <= 2 425042 ifTrue: [^ Color gray]. 425043 preferenced := Preferences menuSelectionColor. 425044 preferenced notNil ifTrue: [^preferenced]. 425045 baseColor := aMenuItem owner color negated. 425046 Preferences gradientMenu 425047 ifFalse: [^baseColor]. 425048 fill := GradientFillStyle ramp: {0.0 -> baseColor twiceLighter . 1 -> baseColor twiceDarker}. 425049 fill 425050 origin: aMenuItem topLeft; 425051 direction: aMenuItem width @ 0. 425052 ^ fill! ! 425053 425054!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 8/10/2007 11:48'! 425055radioButtonDisabledFillStyleFor: aRadioButton 425056 "Return the disabled radio button fillStyle for the given button." 425057 425058 ^self checkboxButtonDisabledFillStyleFor: aRadioButton! ! 425059 425060!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 8/10/2007 11:48'! 425061radioButtonNormalFillStyleFor: aRadioButton 425062 "Return the normal radio button fillStyle for the given button." 425063 425064 ^self checkboxButtonNormalFillStyleFor: aRadioButton! ! 425065 425066!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 2/29/2008 21:50'! 425067radioButtonSelectedDisabledFillStyleFor: aRadioButton 425068 "Return the selected disabled radio button fillStyle for the given button." 425069 425070 ^self checkboxButtonSelectedDisabledFillStyleFor: aRadioButton! ! 425071 425072!UITheme methodsFor: 'fill-styles-buttons' stamp: 'gvc 2/29/2008 21:50'! 425073radioButtonSelectedFillStyleFor: aRadioButton 425074 "Return the selected radio button fillStyle for the given button." 425075 425076 ^self checkboxButtonSelectedFillStyleFor: aRadioButton! ! 425077 425078 425079!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 4/26/2007 14:02'! 425080scrollbarImageColorFor: aScrollbar 425081 "Return the scrollbar image colour (on buttons) for the given scrollbar." 425082 425083 ^self scrollbarColorFor: aScrollbar! ! 425084 425085!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 6/4/2007 15:15'! 425086scrollbarMouseOverBarButtonFillStyleFor: aScrollbar 425087 "Return the button fillStyle for the given scrollbar when 425088 the mouse is over the bar." 425089 425090 ^self scrollbarNormalButtonFillStyleFor: aScrollbar! ! 425091 425092!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 6/4/2007 15:42'! 425093scrollbarMouseOverBarThumbFillStyleFor: aScrollbar 425094 "Return the thumb fillStyle for the given scrollbar when 425095 the mouse is over the bar." 425096 425097 ^self scrollbarNormalThumbFillStyleFor: aScrollbar! ! 425098 425099!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 3/30/2007 10:09'! 425100scrollbarMouseOverButtonFillStyleFor: aScrollbar 425101 "Return the scrollbar mouse over button fillStyle for the given color." 425102 425103 ^self scrollbarNormalButtonFillStyleFor: aScrollbar! ! 425104 425105!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 3/30/2007 10:08'! 425106scrollbarMouseOverFillStyleFor: aScrollbar 425107 "Return the scrollbar mouse over fillStyle for the given color." 425108 425109 ^self scrollbarNormalFillStyleFor: aScrollbar! ! 425110 425111!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 6/4/2007 15:51'! 425112scrollbarMouseOverThumbButtonFillStyleFor: aScrollbar 425113 "Return the button fillStyle for the given scrollbar when 425114 the mouse is over the thumb." 425115 425116 ^self scrollbarMouseOverBarButtonFillStyleFor: aScrollbar! ! 425117 425118!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 3/30/2007 10:15'! 425119scrollbarMouseOverThumbFillStyleFor: aScrollbar 425120 "Return the scrollbar mouse over thumb fillStyle for the given color." 425121 425122 ^self scrollbarNormalThumbFillStyleFor: aScrollbar! ! 425123 425124!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 3/30/2007 10:28'! 425125scrollbarNormalButtonFillStyleFor: aScrollbar 425126 "Return the normal scrollbar button fillStyle for the given scrollbar." 425127 425128 ^self scrollbarNormalThumbFillStyleFor: aScrollbar! ! 425129 425130!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 4/17/2007 11:36'! 425131scrollbarNormalFillStyleFor: aScrollbar 425132 "Return the normal scrollbar fillStyle for the given scrollbar." 425133 425134 |aColor| 425135 aColor := self scrollbarColorFor: aScrollbar. 425136 ^(aColor alphaMixed: 0.4 with: Color white) 425137 alphaMixed: 0.9 with: Color black! ! 425138 425139!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 4/25/2007 18:21'! 425140scrollbarNormalThumbFillStyleFor: aScrollbar 425141 "Return the normal scrollbar thumb fillStyle for the given scrollbar." 425142 425143 ^self scrollbarColorFor: aScrollbar! ! 425144 425145!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 3/30/2007 10:42'! 425146scrollbarPressedButtonFillStyleFor: aScrollbar 425147 "Return the pressed scrollbar button fillStyle for the given scrollbar." 425148 425149 ^self scrollbarPressedThumbFillStyleFor: aScrollbar! ! 425150 425151!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 3/30/2007 10:29'! 425152scrollbarPressedFillStyleFor: aScrollbar 425153 "Return the pressed scrollbar fillStyle for the given scrollbar." 425154 425155 ^self scrollbarNormalFillStyleFor: aScrollbar ! ! 425156 425157!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 4/25/2007 18:22'! 425158scrollbarPressedThumbFillStyleFor: aScrollbar 425159 "Return the pressed scrollbar thumb fillStyle for the given scrollbar." 425160 425161 ^self scrollbarNormalThumbFillStyleFor: aScrollbar! ! 425162 425163!UITheme methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 2/22/2008 21:17'! 425164useScrollbarThumbShadow 425165 "Answer whether a shadow morph should be displayed when 425166 dragging a scrollbar thumb." 425167 425168 ^true! ! 425169 425170 425171!UITheme methodsFor: 'icons' stamp: 'gvc 5/18/2007 14:48'! 425172errorIcon 425173 "Answer an error icon." 425174 425175 ^ThemeIcons errorIcon! ! 425176 425177!UITheme methodsFor: 'icons' stamp: 'gvc 5/18/2007 10:32'! 425178infoIcon 425179 "Answer an information icon." 425180 425181 ^ThemeIcons infoIcon! ! 425182 425183!UITheme methodsFor: 'icons' stamp: 'gvc 5/18/2007 10:27'! 425184lockIcon 425185 "Answer a lock icon." 425186 425187 ^ThemeIcons lockIcon! ! 425188 425189!UITheme methodsFor: 'icons' stamp: 'gvc 5/18/2007 10:27'! 425190questionIcon 425191 "Answer a question icon." 425192 425193 ^ThemeIcons questionIcon! ! 425194 425195!UITheme methodsFor: 'icons' stamp: 'gvc 5/18/2007 10:39'! 425196smallBarcodeIcon 425197 "Answer a small barcode icon." 425198 425199 ^ThemeIcons smallBarcodeIcon! ! 425200 425201!UITheme methodsFor: 'icons' stamp: 'gvc 5/18/2007 10:28'! 425202smallBoldIcon 425203 "Answer a small bold text icon." 425204 425205 ^ThemeIcons smallBoldIcon! ! 425206 425207!UITheme methodsFor: 'icons' stamp: 'gvc 5/22/2007 10:44'! 425208smallDebugIcon 425209 "Answer a small debug icon." 425210 425211 ^self smallErrorIcon! ! 425212 425213!UITheme methodsFor: 'icons' stamp: 'gvc 5/21/2007 12:44'! 425214smallErrorIcon 425215 "Answer a small error icon." 425216 425217 ^ThemeIcons smallErrorIcon! ! 425218 425219!UITheme methodsFor: 'icons' stamp: 'gvc 5/18/2007 10:33'! 425220smallHierarchyBrowserIcon 425221 "Answer a small hierarchy browser icon." 425222 425223 ^ThemeIcons smallHierarchyBrowserIcon! ! 425224 425225!UITheme methodsFor: 'icons' stamp: 'gvc 5/21/2007 13:08'! 425226smallInfoIcon 425227 "Answer a small information icon." 425228 425229 ^ThemeIcons smallInfoIcon! ! 425230 425231!UITheme methodsFor: 'icons' stamp: 'gvc 5/18/2007 10:28'! 425232smallItalicIcon 425233 "Answer a small italic text icon." 425234 425235 ^ThemeIcons smallItalicIcon! ! 425236 425237!UITheme methodsFor: 'icons' stamp: 'gvc 5/21/2007 12:45'! 425238smallLockIcon 425239 "Answer a small lock icon." 425240 425241 ^ThemeIcons smallLockIcon! ! 425242 425243!UITheme methodsFor: 'icons' stamp: 'gvc 5/21/2007 12:45'! 425244smallQuestionIcon 425245 "Answer a small question icon." 425246 425247 ^ThemeIcons smallQuestionIcon! ! 425248 425249!UITheme methodsFor: 'icons' stamp: 'gvc 5/18/2007 10:29'! 425250smallStrikeOutIcon 425251 "Answer a small strike text icon." 425252 425253 ^ThemeIcons smallStrikeOutIcon! ! 425254 425255!UITheme methodsFor: 'icons' stamp: 'gvc 5/18/2007 10:31'! 425256smallSystemBrowserIcon 425257 "Answer a small browser icon." 425258 425259 ^ThemeIcons smallSystemBrowserIcon! ! 425260 425261!UITheme methodsFor: 'icons' stamp: 'gvc 5/18/2007 10:29'! 425262smallUnderlineIcon 425263 "Answer a small underlined text icon." 425264 425265 ^ThemeIcons smallUnderlineIcon! ! 425266 425267!UITheme methodsFor: 'icons' stamp: 'gvc 5/21/2007 12:45'! 425268smallWarningIcon 425269 "Answer a small warning icon." 425270 425271 ^ThemeIcons smallWarningIcon! ! 425272 425273!UITheme methodsFor: 'icons' stamp: 'gvc 5/18/2007 10:27'! 425274warningIcon 425275 "Answer a warning icon." 425276 425277 ^ThemeIcons warningIcon! ! 425278 425279 425280!UITheme methodsFor: 'initialize-release' stamp: 'gvc 10/16/2008 16:18'! 425281defaultSettings 425282 "Answer the default settings." 425283 425284 ^self class defaultSettings copy! ! 425285 425286!UITheme methodsFor: 'initialize-release' stamp: 'gvc 7/30/2009 18:33'! 425287defaultSoundTheme 425288 "Answer the default sound theme. 425289 Answer the system sound theme by default." 425290 425291 ^SoundTheme current! ! 425292 425293!UITheme methodsFor: 'initialize-release' stamp: 'gvc 7/30/2009 18:32'! 425294initialize 425295 "Initialize the receiver." 425296 425297 super initialize. 425298 self 425299 initializeForms; 425300 settings: self defaultSettings! ! 425301 425302!UITheme methodsFor: 'initialize-release' stamp: 'gvc 10/25/2007 17:02'! 425303initializeForms 425304 "Initialize the receiver's image forms." 425305 425306 self forms: Dictionary new. 425307 self forms 425308 at: #checkboxMarker put: self newCheckboxMarkerForm; 425309 at: #radioButtonMarker put: self newRadioButtonMarkerForm; 425310 at: #treeExpanded put: self newTreeExpandedForm; 425311 at: #treeUnexpanded put: self newTreeUnexpandedForm; 425312 at: #windowClose put: self newWindowCloseForm; 425313 at: #windowMinimize put: self newWindowMinimizeForm; 425314 at: #windowMaximize put: self newWindowMaximizeForm; 425315 at: #windowMenu put: self newWindowMenuForm! ! 425316 425317!UITheme methodsFor: 'initialize-release' stamp: 'gvc 10/25/2007 17:47'! 425318newCheckboxMarkerForm 425319 "Answer a new checkbox marker form." 425320 425321 ^(Form 425322 extent: 12@12 425323 depth: 32 425324 fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1342177280 1610612736 134217728 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3338665984 4278190080 1476395008 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 671088640 4278190080 4009754624 134217728 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2147483648 4278190080 2533359616 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3607101440 4278190080 1207959552 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1073741824 4278190080 3875536896 16777215 16777215 16777215 16777215 16777215 1207959552 3204448256 134217728 16777215 2801795072 4278190080 2147483648 16777215 16777215 16777215 16777215 134217728 3607101440 4278190080 2936012800 268435456 4143972352 4278190080 536870912 16777215 16777215 16777215 16777215 16777215 536870912 4009754624 4278190080 3607101440 4278190080 3070230528 16777215 16777215 16777215 16777215 16777215 16777215 16777215 805306368 4009754624 4278190080 4278190080 1342177280 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 671088640 2936012800 2801795072 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) 425325 offset: 0@0)! ! 425326 425327!UITheme methodsFor: 'initialize-release' stamp: 'gvc 10/25/2007 17:27'! 425328newRadioButtonMarkerForm 425329 "Answer a new radio button marker form." 425330 425331 ^(Form 425332 extent: 12@12 425333 depth: 32 425334 fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1207959552 2533359616 2533359616 1207959552 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2399141888 4278190080 4278190080 4278190080 4009754624 2399141888 16777215 16777215 16777215 16777215 16777215 1207959552 4278190080 4278190080 4278190080 4278190080 4278190080 4143972352 1207959552 16777215 16777215 16777215 16777215 2533359616 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 2533359616 16777215 16777215 16777215 16777215 2533359616 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 2399141888 16777215 16777215 16777215 16777215 1207959552 4278190080 4278190080 4278190080 4278190080 4143972352 4278190080 1073741824 16777215 16777215 16777215 16777215 16777215 2399141888 4278190080 4278190080 4278190080 4278190080 2399141888 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1207959552 2533359616 2533359616 1207959552 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) 425335 offset: 0@0)! ! 425336 425337!UITheme methodsFor: 'initialize-release' stamp: 'gvc 5/14/2007 11:44'! 425338newTreeExpandedForm 425339 "Answer a new form for an expanded tree item." 425340 425341 ^(Form 425342 extent: 9@9 425343 depth: 32 425344 fromArray: #( 3749280121 4285822068 4285822068 4285822068 4285822068 4285822068 4285822068 4285822068 3816191606 4218778997 4293256677 4293322470 4292861919 4292401368 4291940817 4291546059 4290953922 4285822068 4218778997 4293059298 4293125091 4292664540 4292203989 4291743438 4291282887 4290624957 4285822068 4218778997 4292664540 4292664540 4292203989 4291743438 4291282887 4290822336 4290164406 4285822068 4218778997 4291809231 4278519045 4278519045 4278519045 4278519045 4278519045 4289769648 4285822068 4218778997 4291743438 4291743438 4291282887 4290822336 4290361785 4289901234 4289309097 4285822068 4218778997 4291348680 4291282887 4290822336 4290361785 4289901234 4289440683 4288848546 4285822068 4218778997 4290559164 4290493371 4290032820 4289638062 4289177511 4288716960 4288256409 4285822068 3665262455 4218713204 4218713204 4218713204 4218713204 4218713204 4218713204 4218713204 3749016949) 425345 offset: 0@0) 425346 asFormOfDepth: Display depth; 425347 replaceColor: Color white withColor: Color transparent; 425348 yourself! ! 425349 425350!UITheme methodsFor: 'initialize-release' stamp: 'gvc 5/14/2007 11:44'! 425351newTreeUnexpandedForm 425352 "Answer a new form for an unexpanded tree item." 425353 425354 ^(Form 425355 extent: 9@9 425356 depth: 32 425357 fromArray: #( 3749280121 4285822068 4285822068 4285822068 4285822068 4285822068 4285822068 4285822068 3816191606 4218778997 4293256677 4293322470 4292861919 4292401368 4291940817 4291546059 4290953922 4285822068 4218778997 4293059298 4293125091 4292203989 4278519045 4291348680 4291282887 4290624957 4285822068 4218778997 4292664540 4292664540 4291743438 4278190080 4290822336 4290822336 4290164406 4285822068 4218778997 4291809231 4278519045 4278519045 4278190080 4278519045 4278519045 4289769648 4285822068 4218778997 4291743438 4291743438 4290822336 4278190080 4289967027 4289901234 4289309097 4285822068 4218778997 4291348680 4291282887 4290361785 4278190080 4289506476 4289440683 4288848546 4285822068 4218778997 4290559164 4290493371 4290032820 4289638062 4289177511 4288716960 4288256409 4285822068 3665262455 4218713204 4218713204 4218713204 4218713204 4218713204 4218713204 4218713204 3749016949) 425358 offset: 0@0) 425359 asFormOfDepth: Display depth; 425360 replaceColor: Color white withColor: Color transparent; 425361 yourself! ! 425362 425363!UITheme methodsFor: 'initialize-release' stamp: 'gvc 5/24/2007 10:11'! 425364newWindowCloseForm 425365 "Answer a new form for a window close box." 425366 425367 ^Form 425368 extent: 10@10 425369 depth: 32 425370 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 3326099520 3330310272 0 0 0 0 0 0 0 0 4144038145 3326099520 3330310272 0 0 0 4144038145 3326099520 0 0 0 4227924225 3326099520 3330310272 0 4144038145 3326099520 3330310272 0 0 0 0 4144038145 3326099520 4144038145 3326099520 3330310272 3336494814 0 0 0 0 0 4227924225 3326099520 3330310272 3336494814 0 0 0 0 0 4144038145 3326099520 4144038145 3326099520 3330310272 3336494814 0 0 0 4144038145 3326099520 3330310272 3336494814 4144038145 3326099520 3330310272 0 0 4144038145 3326099520 3330310272 3336494814 0 0 4144038145 3326099520 0 0 0 3330310272 3336494814 0 0 0 0 0 0) 425371 offset: 0@0! ! 425372 425373!UITheme methodsFor: 'initialize-release' stamp: 'gvc 5/24/2007 10:11'! 425374newWindowMaximizeForm 425375 "Answer a new form for a window maximize box." 425376 425377 ^Form 425378 extent: 10@10 425379 depth: 32 425380 fromArray: #( 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 0 0 0 0 3875602689 0 0 0 0 4127260929 3877181721 3877181721 3875602689 0 3875602689 0 0 0 0 3875602689 3212869760 0 3875602689 3212869760 3875602689 0 0 0 0 3875602689 3212869760 0 3875602689 3212869760 3875602689 0 0 0 0 3875602689 3212869760 0 3875602689 3212869760 3875602689 4127260929 3875602689 3875602689 3875602689 3875602689 3212869760 0 3875602689 3212869760 0 3877181721 3212869760 3212869760 3212869760 3212869760 3212869760 0 3875602689 3212869760 0 3877181721 0 0 0 0 0 0 3875602689 3212869760 0 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 3875602689 3212869760 0 0 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760) 425381 offset: 0@0! ! 425382 425383!UITheme methodsFor: 'initialize-release' stamp: 'gvc 5/24/2007 10:12'! 425384newWindowMenuForm 425385 "Answer a new form for a window menu box." 425386 425387 ^Form 425388 extent: 10@10 425389 depth: 32 425390 fromArray: #( 4227858432 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4227858432 0 4127195136 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4227858432 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 3212869760 4127195136 3212869760 0 0 0 0 0 0 4127195136 3212869760 4227858432 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4127195136 4227858432 3212869760 0 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760) 425391 offset: 0@0! ! 425392 425393!UITheme methodsFor: 'initialize-release' stamp: 'gvc 5/24/2007 10:11'! 425394newWindowMinimizeForm 425395 "Answer a new form for a window minimize box." 425396 425397 ^Form 425398 extent: 10@10 425399 depth: 32 425400 fromArray: #( 0 0 4127260929 4127260929 4127260929 4127260929 4127260929 0 0 0 0 3875602689 3212869760 3212869760 3212869760 3212869760 3212869760 4227924225 0 0 4127260929 3212869760 3212869760 0 0 0 0 3212869760 4127260929 0 4127260929 3212869760 0 0 0 0 0 0 4127260929 3212869760 4127260929 3212869760 0 0 0 0 0 0 4127260929 3212869760 4127260929 3212869760 0 0 0 0 0 0 4127260929 3212869760 4128708375 3212869760 0 0 0 0 0 0 4127260929 3212869760 0 4127260929 3212869760 0 0 0 0 4127260929 3208659008 3212869760 0 3208659008 4127260929 4127260929 4127260929 4127260929 4127260929 3208659008 3212869760 0 0 0 3212869760 3212869760 3212869760 3212869760 3212869760 3212869760 0 0) 425401 offset: 0@0! ! 425402 425403!UITheme methodsFor: 'initialize-release' stamp: 'gvc 2/14/2009 17:38'! 425404updateWorldDockingBars 425405 "Update the world docking bar gradients." 425406 425407 World mainDockingBars do: [:d | 425408 d 425409 color: (self worldMainDockingBarColorFor: d); 425410 gradientRamp: (self class current 425411 worldMainDockingBarNormalFillStyleFor: d) colorRamp; 425412 borderStyle: (self worldMainDockingBarBorderStyleFor: d)]! ! 425413 425414 425415!UITheme methodsFor: 'label-styles' stamp: 'gvc 5/13/2009 13:24'! 425416buttonLabelFor: aButton 425417 "Answer the label to use for the given button." 425418 425419 |label| 425420 label := self buttonLabelForText: aButton label. 425421 (label respondsTo: #enabled:) ifTrue: [ 425422 label enabled: aButton enabled]. 425423 label font: Preferences standardButtonFont. 425424 ^label! ! 425425 425426!UITheme methodsFor: 'label-styles' stamp: 'gvc 6/15/2009 13:00'! 425427buttonLabelForText: aTextOrString 425428 "Answer the label to use for the given text." 425429 425430 ^aTextOrString isString 425431 ifTrue: [(LabelMorph contents: aTextOrString) 425432 disabledStyle: self disabledItemStyle] 425433 ifFalse: [|t| 425434 t := TextMorph new newContents: aTextOrString. 425435 t 425436 extent: t optimalExtent; 425437 margins: (0@0 corner: 0@1); 425438 lock]! ! 425439 425440!UITheme methodsFor: 'label-styles' stamp: 'gvc 8/2/2007 16:01'! 425441checkboxLabelFor: aCheckbox 425442 "Answer the label to use for the given checkbox." 425443 425444 ^self checkboxLabelForText: aCheckbox label! ! 425445 425446!UITheme methodsFor: 'label-styles' stamp: 'gvc 6/15/2009 12:58'! 425447checkboxLabelForText: aTextOrString 425448 "Answer the label to use for the given text." 425449 425450 |morph| 425451 morph := aTextOrString isString 425452 ifTrue: [(LabelMorph contents: aTextOrString) 425453 disabledStyle: self disabledItemStyle] 425454 ifFalse: [|t| 425455 t := TextMorph new newContents: aTextOrString. 425456 t extent: t optimalExtent]. 425457 ^morph 425458 vResizing: #shrinkWrap; 425459 hResizing: #spaceFill; 425460 lock! ! 425461 425462!UITheme methodsFor: 'label-styles' stamp: 'gvc 10/25/2007 17:06'! 425463checkboxMarkerForm 425464 "Answer the form to use for a checkbox marker." 425465 425466 ^self forms at: #checkboxMarker ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 425467 425468!UITheme methodsFor: 'label-styles' stamp: 'gvc 6/1/2009 12:20'! 425469configureDialogWindowLabelAreaFrameFor: aWindow 425470 "Configure the layout frame for the label area for the given dialog window." 425471 425472 |frame| 425473 self configureWindowLabelAreaFrameFor: aWindow. 425474 aWindow labelArea ifNil: [^ self]. 425475 frame := aWindow labelArea layoutFrame. 425476 frame 425477 leftOffset: 0; 425478 rightOffset: 0! ! 425479 425480!UITheme methodsFor: 'label-styles' stamp: 'gvc 3/27/2008 21:43'! 425481configureWindowLabelAreaFor: aWindow 425482 "Configure the label area for the given window." 425483 425484 aWindow labelArea 425485 addMorphBack: (Morph new extent: aWindow class borderWidth @ 0). 425486 aWindow hasCloseBox ifTrue: [aWindow addCloseBox]. 425487 aWindow hasMenuBox ifTrue: [aWindow addMenuControl]. 425488 aWindow labelArea 425489 addMorphBack: (Morph new extent: aWindow class borderWidth @ 0). 425490 aWindow basicLabel ifNotNilDo: [:label | 425491 label hResizing: #spaceFill. 425492 aWindow labelArea addMorphBack: label]. 425493 aWindow hasExpandBox ifTrue: [aWindow addExpandBox]. 425494 aWindow hasCollapseBox ifTrue: [aWindow addCollapseBox]. 425495 aWindow labelArea 425496 addMorphBack: (Morph new extent: aWindow class borderWidth @ 0)! ! 425497 425498!UITheme methodsFor: 'label-styles' stamp: 'gvc 6/1/2009 12:05'! 425499configureWindowLabelAreaFrameFor: aWindow 425500 "Configure the layout frame for the label area for the given window." 425501 425502 |frame windowBorderWidth| 425503 aWindow labelArea ifNil: [^ self]. 425504 windowBorderWidth := aWindow class borderWidth. 425505 aWindow labelArea 425506 layoutPolicy: RowLayout new; 425507 cellPositioning: #topCenter; 425508 hResizing: #spaceFill; 425509 wrapCentering: #topLeft; 425510 layoutInset: (0@windowBorderWidth corner: 0@1). 425511 frame := LayoutFrame 425512 fractions: (0@0 corner: 1@0) 425513 offsets: (0 @ (aWindow labelHeight negated) 425514 corner: 0 @ 0). 425515 aWindow labelArea layoutFrame: frame! ! 425516 425517!UITheme methodsFor: 'label-styles' stamp: 'gvc 10/22/2008 12:17'! 425518createCloseBoxFor: aSystemWindow 425519 "Answer a button for closing the window." 425520 425521 ^aSystemWindow createBox 425522 labelGraphic: self windowCloseForm; 425523 extent: aSystemWindow boxExtent; 425524 actionSelector: #closeBoxHit; 425525 setBalloonText: 'close this window' translated! ! 425526 425527!UITheme methodsFor: 'label-styles' stamp: 'gvc 10/22/2008 12:18'! 425528createCollapseBoxFor: aSystemWindow 425529 "Answer a button for minimising the window." 425530 425531 ^aSystemWindow createBox 425532 labelGraphic: self windowMinimizeForm; 425533 extent: aSystemWindow boxExtent; 425534 actionSelector: #collapseBoxHit; 425535 setBalloonText: 'collapse this window' translated! ! 425536 425537!UITheme methodsFor: 'label-styles' stamp: 'gvc 10/22/2008 12:18'! 425538createExpandBoxFor: aSystemWindow 425539 "Answer a button for maximising/restoring the window." 425540 425541 ^aSystemWindow createBox 425542 labelGraphic: self windowMaximizeForm; 425543 extent: aSystemWindow boxExtent; 425544 actionSelector: #expandBoxHit; 425545 setBalloonText: 'expand to full screen' translated! ! 425546 425547!UITheme methodsFor: 'label-styles' stamp: 'gvc 6/1/2009 12:47'! 425548createMenuBoxFor: aSystemWindow 425549 "Answer a button for the window menu." 425550 425551 ^aSystemWindow createBox 425552 labelGraphic: (self windowMenuIconFor: aSystemWindow); 425553 extent: aSystemWindow boxExtent; 425554 actWhen: #buttonDown; 425555 actionSelector: #offerWindowMenu; 425556 setBalloonText: 'window menu' translated! ! 425557 425558!UITheme methodsFor: 'label-styles' stamp: 'gvc 10/17/2008 12:19'! 425559disabledItemStyle 425560 "Answer either #plain or #inset to determine how 425561 diabled text is drawn." 425562 425563 ^#plain! ! 425564 425565!UITheme methodsFor: 'label-styles' stamp: 'gvc 6/1/2009 11:40'! 425566dropListButtonLabelFor: aDropList 425567 "Answer the label for the button of the given drop list." 425568 425569 ^AlphaImageMorph new 425570 image: (ScrollBar 425571 arrowOfDirection: #bottom 425572 size: aDropList buttonWidth - 3 425573 color: aDropList paneColor darker); 425574 enabled: aDropList enabled! ! 425575 425576!UITheme methodsFor: 'label-styles' stamp: 'gvc 2/10/2009 12:55'! 425577menuCloseForm 425578 "Answer the form to use for the close button of a menu." 425579 425580 ^self windowCloseForm! ! 425581 425582!UITheme methodsFor: 'label-styles' stamp: 'gvc 3/6/2009 13:10'! 425583menuPinForm 425584 "Answer the form to use for the pin button of a menu." 425585 425586 ^ThemeIcons smallPushpinIcon! ! 425587 425588!UITheme methodsFor: 'label-styles' stamp: 'gvc 10/25/2007 17:06'! 425589radioButtonMarkerForm 425590 "Answer the form to use for a radio button marker." 425591 425592 ^self forms at: #radioButtonMarker ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 425593 425594!UITheme methodsFor: 'label-styles' stamp: 'gvc 5/11/2007 16:04'! 425595scrollbarArrowOfDirection: aSymbol size: finalSizeInteger color: aColor 425596 "Answer a new scrollbar arrow form (normally cached by Scrollbar)." 425597 425598 ^ScrollBar basicCreateArrowOfDirection: aSymbol size: finalSizeInteger color: aColor! ! 425599 425600!UITheme methodsFor: 'label-styles' stamp: 'gvc 1/7/2008 14:54'! 425601tabSelectorCellInsetFor: aTabSelector 425602 "Answer the cell inset to use for the given tab selector." 425603 425604 ^2@0! ! 425605 425606!UITheme methodsFor: 'label-styles' stamp: 'gvc 5/14/2007 11:49'! 425607treeExpandedForm 425608 "Answer the form to use for an expanded tree item." 425609 425610 ^self forms at: #treeExpanded ifAbsent: [Form extent: 10@9 depth: Display depth]! ! 425611 425612!UITheme methodsFor: 'label-styles' stamp: 'gvc 5/14/2007 11:49'! 425613treeUnexpandedForm 425614 "Answer the form to use for an unexpanded tree item." 425615 425616 ^self forms at: #treeUnexpanded ifAbsent: [Form extent: 10@9 depth: Display depth]! ! 425617 425618!UITheme methodsFor: 'label-styles' stamp: 'gvc 5/15/2007 10:01'! 425619windowCloseForm 425620 "Answer the form to use for the close button of a window." 425621 425622 ^self forms at: #windowClose ifAbsent: [Form extent: 10@10 depth: Display depth]! ! 425623 425624!UITheme methodsFor: 'label-styles' stamp: 'gvc 5/7/2007 12:50'! 425625windowLabelFor: aWindow 425626 "Answer the label to use for the given window." 425627 425628 ^self windowLabelForText: aWindow labelString! ! 425629 425630!UITheme methodsFor: 'label-styles' stamp: 'gvc 10/25/2007 16:56'! 425631windowLabelForText: aTextOrString 425632 "Answer the window label to use for the given text." 425633 425634 ^LabelMorph new 425635 contents: aTextOrString; 425636 font: Preferences windowTitleFont emphasis: 0! ! 425637 425638!UITheme methodsFor: 'label-styles' stamp: 'gvc 5/15/2007 10:00'! 425639windowMaximizeForm 425640 "Answer the form to use for the maximize button of a window." 425641 425642 ^self forms at: #windowMaximize ifAbsent: [Form extent: 10@10 depth: Display depth]! ! 425643 425644!UITheme methodsFor: 'label-styles' stamp: 'gvc 5/15/2007 10:01'! 425645windowMenuForm 425646 "Answer the form to use for the menu button of a window." 425647 425648 ^self forms at: #windowMenu ifAbsent: [Form extent: 10@10 depth: Display depth]! ! 425649 425650!UITheme methodsFor: 'label-styles' stamp: 'gvc 5/25/2007 10:01'! 425651windowMenuIconFor: aWindow 425652 "Answer the menu icon for the given window." 425653 425654 ^aWindow taskbarIcon ifNil: [self windowMenuForm]! ! 425655 425656!UITheme methodsFor: 'label-styles' stamp: 'gvc 5/15/2007 10:00'! 425657windowMinimizeForm 425658 "Answer the form to use for the minimize button of a window." 425659 425660 ^self forms at: #windowMinimize ifAbsent: [Form extent: 10@10 depth: Display depth]! ! 425661 425662 425663!UITheme methodsFor: 'morph creation' stamp: 'gvc 1/20/2009 11:09'! 425664focusIndicatorMorphFor: aMorph 425665 "Answer a (cached) focus indicator for the given morph." 425666 425667 (self focusIndicator isNil or: [ 425668 self focusIndicator isMorph 425669 ifTrue: [self focusIndicator ~~ aMorph] 425670 ifFalse: [self focusIndicator key ~~ aMorph]]) 425671 ifTrue: [self focusIndicator: aMorph ->(self newFocusIndicatorMorphFor: aMorph)]. 425672 ^self focusIndicator value 425673 privateBounds: aMorph focusBounds! ! 425674 425675!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/8/2007 15:16'! 425676newAlphaImageIn: aThemedMorph image: aForm help: helpText 425677 "Answer an alpha image morph." 425678 425679 |answer| 425680 answer := AlphaImageMorph new 425681 hResizing: #rigid; 425682 vResizing: #rigid; 425683 setBalloonText: helpText. 425684 aForm ifNotNil: [answer image: aForm]. 425685 ^answer! ! 425686 425687!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/2/2009 12:39'! 425688newAlphaSelectorIn: aThemedMorph for: aModel getAlpha: getSel setAlpha: setSel help: helpText 425689 "Answer an alpha selector ." 425690 425691 ^(AColorSelectorMorph 425692 on: aModel 425693 getValue: getSel 425694 setValue: setSel) 425695 hResizing: #spaceFill; 425696 vResizing: #spaceFill; 425697 setBalloonText: helpText! ! 425698 425699!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/28/2009 11:38'! 425700newAutoAcceptTextEditorIn: aThemedMorph for: aModel getText: getSel setText: setSel getEnabled: enabledSel 425701 "Answer a text editor for the given model." 425702 425703 ^PluggableTextEditorMorph new 425704 autoAccept: true; 425705 on: aModel 425706 text: getSel 425707 accept: setSel 425708 readSelection: nil 425709 menu: nil; 425710 getEnabledSelector: enabledSel; 425711 font: self textFont; 425712 cornerStyle: aThemedMorph preferredCornerStyle; 425713 hResizing: #spaceFill; 425714 vResizing: #spaceFill; 425715 borderStyle: (BorderStyle inset width: 1); 425716 color: Color white; 425717 selectionColor: self selectionColor! ! 425718 425719!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/28/2009 11:38'! 425720newAutoAcceptTextEntryIn: aThemedMorph for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText 425721 "Answer a text entry for the given model. 425722 Object conversion will be automatic based on the class of 425723 object returned after performing the get selector, aClass 425724 is provided in case of initial nil returns." 425725 425726 |pt| 425727 pt := PluggableTextFieldMorph new 425728 autoAccept: true; 425729 alwaysAccept: true; 425730 convertTo: aClass; 425731 on: aModel 425732 text: getSel 425733 accept: setSel 425734 readSelection: nil 425735 menu: nil; 425736 acceptOnCR: true; 425737 getEnabledSelector: enabledSel; 425738 font: aFont; 425739 cornerStyle: (self textEntryCornerStyleIn: aThemedMorph); 425740 hResizing: #spaceFill; 425741 vResizing: #rigid; 425742 borderStyle: (BorderStyle inset width: 1); 425743 color: Color white; 425744 selectionColor: self selectionColor; 425745 hideScrollBarsIndefinitely; 425746 extent: 24@(aFont height + 8); 425747 setBalloonText: helpText. 425748 pt textMorph 425749 autoFit: true; 425750 wrapFlag: false; 425751 margins: (2@1 corner: 2@1). 425752 ^pt 425753! ! 425754 425755!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/28/2009 11:38'! 425756newAutoAcceptTextEntryIn: aThemedMorph for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText 425757 "Answer a text entry for the given model. 425758 Object conversion will be automatic based on the class of 425759 object returned after performing the get selector, aClass 425760 is provided in case of initial nil returns." 425761 425762 ^self 425763 newAutoAcceptTextEntryIn: aThemedMorph 425764 for: aModel 425765 get: getSel 425766 set: setSel 425767 class: aClass 425768 getEnabled: enabledSel 425769 font: self textFont 425770 help: helpText! ! 425771 425772!UITheme methodsFor: 'morph creation' stamp: 'gvc 1/30/2009 15:09'! 425773newBalloonHelpIn: aThemedMorph contents: aTextStringOrMorph for: aMorph corner: cornerSymbol 425774 "Answer a new balloon help morph with the given text 425775 and positioning for aMorph." 425776 425777 ^SimpleBalloonMorph 425778 string: aTextStringOrMorph 425779 for: aMorph 425780 corner: cornerSymbol! ! 425781 425782!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/8/2009 13:09'! 425783newBracketSliderIn: aThemedMorph for: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText 425784 "Answer a bracket slider." 425785 425786 ^(BracketSliderMorph 425787 on: aModel 425788 getValue: getSel 425789 setValue: setSel 425790 min: minValue 425791 max: maxValue 425792 quantum: quantum) 425793 getEnabledSelector: enabledSel; 425794 hResizing: #spaceFill; 425795 vResizing: #spaceFill; 425796 setBalloonText: helpText! ! 425797 425798!UITheme methodsFor: 'morph creation' stamp: 'gvc 12/3/2008 17:33'! 425799newButtonIn: aThemedMorph for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText 425800 "Answer a new button." 425801 425802 |b| 425803 b := PluggableButtonMorphPlus 425804 on: aModel 425805 getState: stateSel 425806 action: actionSel 425807 label: labelSel. 425808 b 425809 arguments: (args ifNil: [{b}]); 425810 getEnabledSelector: enabledSel; 425811 cornerStyle: (self buttonCornerStyleIn: aThemedMorph); 425812 hResizing: #shrinkWrap; 425813 vResizing: #shrinkWrap; 425814 setBalloonText: helpText; 425815 extent: b minExtent. 425816 ^b! ! 425817 425818!UITheme methodsFor: 'morph creation' stamp: 'gvc 12/5/2008 14:04'! 425819newButtonIn: aThemedMorph for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: label help: helpText 425820 "Answer a new button." 425821 425822 |b| 425823 b := PluggableButtonMorphPlus 425824 on: aModel getState: stateSel action: actionSel. 425825 b 425826 arguments: (args ifNil: [{b}]); 425827 getEnabledSelector: enabledSel; 425828 cornerStyle: (self buttonCornerStyleIn: aThemedMorph); 425829 hResizing: #shrinkWrap; 425830 vResizing: #shrinkWrap; 425831 label: label font: self buttonFont; 425832 setBalloonText: helpText; 425833 extent: b minExtent; 425834 hResizing: #rigid; 425835 vResizing: #rigid. 425836 ^b! ! 425837 425838!UITheme methodsFor: 'morph creation' stamp: 'gvc 2/2/2009 15:11'! 425839newCancelButtonIn: aThemedMorph for: aModel 425840 "Answer a new cancel button." 425841 425842 ^self 425843 newButtonIn: aThemedMorph 425844 for: aModel 425845 getState: nil 425846 action: #cancel 425847 arguments: nil 425848 getEnabled: nil 425849 label: 'Cancel' translated 425850 help: 'Cancel changes and close the window' translated! ! 425851 425852!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/18/2006 16:27'! 425853newCheckboxIn: aThemedMorph for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: label help: helpText 425854 "Answer a checkbox with the given label ." 425855 425856 ^(CheckboxMorph 425857 on: aModel selected: getSel changeSelected: setSel) 425858 getEnabledSelector: enabledSel; 425859 font: self labelFont; 425860 label: label; 425861 hResizing: #shrinkWrap; 425862 vResizing: #shrinkWrap; 425863 setBalloonText: helpText! ! 425864 425865!UITheme methodsFor: 'morph creation' stamp: 'gvc 2/2/2009 15:11'! 425866newCloseButtonIn: aThemedMorph for: aModel 425867 "Answer a new close button." 425868 425869 ^self 425870 newButtonIn: aThemedMorph 425871 for: aModel 425872 getState: nil 425873 action: #close 425874 arguments: nil 425875 getEnabled: nil 425876 label: 'Close' translated 425877 help: 'Close the window' translated! ! 425878 425879!UITheme methodsFor: 'morph creation' stamp: 'gvc 5/22/2007 11:43'! 425880newColorChooserIn: aThemedMorph for: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText 425881 "Answer a color chooser ." 425882 425883 ^(ColorChooserMorph 425884 on: aModel color: getSel changeColor: setSel) 425885 getEnabledSelector: enabledSel; 425886 hResizing: #spaceFill; 425887 vResizing: #spaceFIll; 425888 setBalloonText: helpText! ! 425889 425890!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/25/2006 10:29'! 425891newColorPickerIn: aThemedMorph for: target getter: getterSymbol setter: setterSymbol 425892 "Answer a color picker for the given morph and accessors." 425893 425894 ^PanelMorph new 425895 borderStyle: (BorderStyle inset width: 1); 425896 fillStyle: Color white; 425897 changeTableLayout; 425898 hResizing: #shrinkWrap; 425899 vResizing: #shrinkWrap; 425900 addMorph: (ColorPickerMorph new 425901 initializeForPropertiesPanel; 425902 target: target; 425903 selector: setterSymbol; 425904 originalColor: (target perform: getterSymbol)); 425905 yourself! ! 425906 425907!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/22/2006 09:45'! 425908newColorPresenterIn: aThemedMorph for: aModel getColor: getSel help: helpText 425909 "Answer a color presenter." 425910 425911 ^(ColorPresenterMorph 425912 on: aModel color: getSel) 425913 hResizing: #spaceFill; 425914 vResizing: #spaceFIll; 425915 setBalloonText: helpText! ! 425916 425917!UITheme methodsFor: 'morph creation' stamp: 'gvc 4/16/2007 11:08'! 425918newColumnIn: aThemedMorph for: controls 425919 "Answer a morph laid out with a column of controls." 425920 425921 |answer| 425922 answer := PanelMorph new 425923 hResizing: #spaceFill; 425924 vResizing: #spaceFill; 425925 fillStyle: Color transparent; "non pane color tracking" 425926 changeTableLayout; 425927 cellInset: 8. 425928 controls do: [:m | answer addMorphBack: m]. 425929 ^answer 425930 ! ! 425931 425932!UITheme methodsFor: 'morph creation' stamp: 'gvc 5/15/2007 17:41'! 425933newDialogPanelIn: aThemedMorph 425934 "Answer a new (main) dialog panel." 425935 425936 ^self newPanelIn: aThemedMorph! ! 425937 425938!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/8/2007 16:03'! 425939newDropListIn: aThemedMorph for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 425940 "Answer a drop list for the given model." 425941 425942 ^(DropListMorph 425943 on: aModel 425944 list: listSel 425945 selected: getSel 425946 changeSelected: setSel 425947 useIndex: useIndex) 425948 selectionColor: self selectionColor; 425949 getEnabledSelector: enabledSel; 425950 font: self dropListFont; 425951 cornerStyle: aThemedMorph preferredCornerStyle; 425952 hResizing: #spaceFill; 425953 vResizing: #shrinkWrap; 425954 setBalloonText: helpText! ! 425955 425956!UITheme methodsFor: 'morph creation' stamp: 'gvc 1/16/2007 14:15'! 425957newEmbeddedMenuIn: aThemedMorph for: aModel 425958 "Answer a new menu." 425959 425960 ^EmbeddedMenuMorph new 425961 defaultTarget: aModel; 425962 color: (self menuColorFor: aThemedMorph)! ! 425963 425964!UITheme methodsFor: 'morph creation' stamp: 'gvc 7/30/2009 14:12'! 425965newExpanderIn: aThemedMorph label: aString forAll: controls 425966 "Answer an expander with the given label and controls." 425967 425968 |answer| 425969 answer := ExpanderMorph new 425970 font: self menuFont; 425971 titleText: aString; 425972 fillStyle: Color white. 425973 controls do: [:m | 425974 answer addMorphBack: m]. 425975 ^answer! ! 425976 425977!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/6/2007 15:27'! 425978newFocusIndicatorMorphFor: aMorph 425979 "Answer a new focus indicator for the given morph." 425980 425981 ^BorderedMorph new 425982 fillStyle: Color transparent; 425983 borderStyle: (DashedBorder 425984 width: 1 425985 dashColors: {aMorph focusColor. Color transparent} dashLengths: #(1 1)); 425986 bounds: aMorph focusBounds! ! 425987 425988!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/26/2008 15:33'! 425989newFontSelector 425990 "Answer a new font selector dialog as appropriate to 425991 the font support present in the image." 425992 425993 ^(Smalltalk hasClassNamed: #FreeTypeFontFamily) 425994 ifTrue: [FreeTypeFontSelectorDialogWindow new] 425995 ifFalse: [TextStyleFontSelectorDialogWindow new]! ! 425996 425997!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/9/2007 12:57'! 425998newFuzzyLabelIn: aThemedMorph for: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel 425999 "Answer a new fuzzy label." 426000 426001 ^(FuzzyLabelMorph contents: aString font: self labelFont) 426002 offset: offset; 426003 alpha: alpha; 426004 model: aModel; 426005 getEnabledSelector: enabledSel ! ! 426006 426007!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/25/2006 15:55'! 426008newGroupboxIn: aThemedMorph 426009 "Answer a plain groupbox." 426010 426011 ^PlainGroupboxMorph new 426012 cornerStyle: aThemedMorph preferredCornerStyle; 426013 hResizing: #spaceFill; 426014 vResizing: #spaceFill; 426015 yourself! ! 426016 426017!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/19/2006 09:59'! 426018newGroupboxIn: aThemedMorph for: control 426019 "Answer a plain groupbox." 426020 426021 ^(self newGroupboxIn: aThemedMorph) 426022 addMorph: control! ! 426023 426024!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/9/2007 16:19'! 426025newGroupboxIn: aThemedMorph forAll: controls 426026 "Answer a plain groupbox." 426027 426028 ^self 426029 newGroupboxIn: aThemedMorph 426030 for: (self newColumnIn: aThemedMorph for: controls)! ! 426031 426032!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/8/2006 14:57'! 426033newGroupboxIn: aThemedMorph label: aString 426034 "Answer a groupbox with the given label." 426035 426036 ^GroupboxMorph new 426037 font: self labelFont; 426038 cornerStyle: aThemedMorph preferredCornerStyle; 426039 hResizing: #spaceFill; 426040 vResizing: #spaceFill; 426041 label: aString; 426042 yourself! ! 426043 426044!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/25/2006 10:12'! 426045newGroupboxIn: aThemedMorph label: aString for: control 426046 "Answer a groupbox with the given label and control." 426047 426048 ^(self newGroupboxIn: aThemedMorph label: aString) 426049 addContentMorph: control; 426050 yourself! ! 426051 426052!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/25/2006 14:36'! 426053newGroupboxIn: aThemedMorph label: aString forAll: controls 426054 "Answer a groupbox with the given label and controls." 426055 426056 ^(self newGroupboxIn: aThemedMorph label: aString) 426057 addContentMorph: (self newColumnIn: aThemedMorph for: controls); 426058 yourself! ! 426059 426060!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/8/2007 14:59'! 426061newHSVASelectorIn: aThemedMorph color: aColor help: helpText 426062 "Answer a hue-saturation-volume-alpha selector." 426063 426064 ^HSVAColorSelectorMorph new 426065 selectedColor: aColor; 426066 hResizing: #spaceFill; 426067 vResizing: #spaceFIll; 426068 setBalloonText: helpText! ! 426069 426070!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/8/2007 14:46'! 426071newHSVSelectorIn: aThemedMorph color: aColor help: helpText 426072 "Answer a hue-saturation-volume selector." 426073 426074 ^HSVColorSelectorMorph new 426075 selectedColor: aColor; 426076 hResizing: #spaceFill; 426077 vResizing: #spaceFIll; 426078 setBalloonText: helpText! ! 426079 426080!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/2/2009 13:00'! 426081newHueSelectorIn: aThemedMorph for: aModel getHue: getSel setHue: setSel help: helpText 426082 "Answer a hue selector ." 426083 426084 ^(HColorSelectorMorph 426085 on: aModel 426086 getValue: getSel 426087 setValue: setSel) 426088 hResizing: #spaceFill; 426089 vResizing: #spaceFill; 426090 setBalloonText: helpText! ! 426091 426092!UITheme methodsFor: 'morph creation' stamp: 'gvc 10/11/2006 13:12'! 426093newImageIn: aThemedMorph form: aForm 426094 "Answer a new text label." 426095 426096 ^self 426097 newImageIn: aThemedMorph 426098 form: aForm 426099 size: aForm extent! ! 426100 426101!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/3/2009 15:35'! 426102newImageIn: aThemedMorph form: aForm size: aPoint 426103 "Answer a new image morph." 426104 426105 ^AlphaImageMorph new 426106 cornerStyle: aThemedMorph preferredCornerStyle; 426107 borderStyle: (BorderStyle inset width: 0); 426108 image: aForm size: aPoint! ! 426109 426110!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/8/2009 13:17'! 426111newIncrementalSliderIn: aThemedMorph for: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText 426112 "Answer a slider inrement/decrement buttons." 426113 426114 ^(IncrementalSliderMorph 426115 on: aModel 426116 getValue: getSel 426117 setValue: setSel 426118 min: min 426119 max: max 426120 quantum: quantum) 426121 getEnabledSelector: enabledSel; 426122 hResizing: #spaceFill; 426123 vResizing: #spaceFill; 426124 setBalloonText: helpText! ! 426125 426126!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/9/2007 13:21'! 426127newLabelGroupIn: aThemedMorph for: labelsAndControls spaceFill: spaceFill 426128 "Answer a morph laid out with a column of labels and a column of associated controls. 426129 If spaceFill is tru then each row will share available space to pad." 426130 426131 |answer labels labelWidth row lc| 426132 lc := labelsAndControls collect: [:a | 426133 (a key isMorph 426134 ifTrue: [a key] 426135 ifFalse: [self newLabelIn: aThemedMorph label: a key]) 426136 -> a value]. 426137 answer := Morph new 426138 hResizing: #spaceFill; 426139 vResizing: #spaceFill; 426140 color: Color transparent; 426141 changeTableLayout; 426142 cellInset: 4. 426143 labels := Morph new 426144 hResizing: #shrinkWrap; 426145 vResizing: #spaceFill; 426146 changeTableLayout. 426147 lc do: [:a | 426148 labels addMorphBack: a key]. 426149 labelWidth := labels minExtent x. 426150 lc do: [:a | 426151 a key hResizing: #rigid; extent: labelWidth@ a key height. 426152 row := self newRowIn: aThemedMorph for: {a key. a value}. 426153 row vResizing: (spaceFill ifTrue: [#spaceFill] ifFalse: [#shrinkWrap]). 426154 answer addMorphBack: row]. 426155 ^answer 426156 ! ! 426157 426158!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/27/2009 12:02'! 426159newLabelGroupIn: aThemedMorph for: labelsAndControls spaceFill: spaceFill font: aFont labelColor: aColor 426160 "Answer a morph laid out with a column of labels and a column of associated controls. 426161 If spaceFill is tru then each row will share available space to pad." 426162 426163 |answer labels labelWidth row lc| 426164 lc := labelsAndControls collect: [:a | 426165 (a key isMorph 426166 ifTrue: [a key] 426167 ifFalse: [(self newLabelIn: aThemedMorph label: a key) 426168 font: aFont; 426169 color: aColor]) 426170 -> a value]. 426171 answer := Morph new 426172 hResizing: #spaceFill; 426173 vResizing: #spaceFill; 426174 color: Color transparent; 426175 changeTableLayout; 426176 cellInset: 4. 426177 labels := Morph new 426178 hResizing: #shrinkWrap; 426179 vResizing: #spaceFill; 426180 changeTableLayout. 426181 lc do: [:a | 426182 labels addMorphBack: a key]. 426183 labelWidth := labels minExtent x. 426184 lc do: [:a | 426185 a key hResizing: #rigid; extent: labelWidth@ a key height. 426186 row := self newRowIn: aThemedMorph for: {a key. a value}. 426187 row vResizing: (spaceFill ifTrue: [#spaceFill] ifFalse: [#shrinkWrap]). 426188 answer addMorphBack: row]. 426189 ^answer 426190 426191! ! 426192 426193!UITheme methodsFor: 'morph creation' stamp: 'gvc 1/16/2007 15:49'! 426194newLabelIn: aThemedMorph for: aModel label: aString getEnabled: enabledSel 426195 "Answer a new text label." 426196 426197 ^(LabelMorph contents: aString font: self labelFont) 426198 model: aModel; 426199 getEnabledSelector: enabledSel! ! 426200 426201!UITheme methodsFor: 'morph creation' stamp: 'gvc 1/16/2007 15:49'! 426202newLabelIn: aThemedMorph label: aString 426203 "Answer a new text label." 426204 426205 ^self 426206 newLabelIn: aThemedMorph 426207 for: nil 426208 label: aString 426209 getEnabled: nil! ! 426210 426211!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/7/2007 11:43'! 426212newListIn: aThemedMorph for: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText 426213 "Answer a list for the given model." 426214 426215 ^PluggableListMorph new 426216 selectionColor: self selectionColor; 426217 font: self listFont; 426218 on: aModel 426219 list: listSelector 426220 selected: getSelector 426221 changeSelected: setSelector 426222 menu: nil 426223 keystroke: nil; 426224 autoDeselect: false; 426225 cornerStyle: aThemedMorph preferredCornerStyle; 426226 color: Color white; 426227 borderStyle: (BorderStyle inset width: 1); 426228 hResizing: #spaceFill; 426229 vResizing: #spaceFill; 426230 getEnabledSelector: enabledSel; 426231 setBalloonText: helpText! ! 426232 426233!UITheme methodsFor: 'morph creation' stamp: 'gvc 10/26/2006 16:48'! 426234newMenuIn: aThemedMorph for: aModel 426235 "Answer a new menu." 426236 426237 ^MenuMorph new 426238 defaultTarget: aModel; 426239 color: (self menuColorFor: aThemedMorph)! ! 426240 426241!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/9/2007 13:16'! 426242newMorphDropListIn: aThemedMorph for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText 426243 "Answer a morph drop list for the given model." 426244 426245 ^self 426246 newMorphDropListIn: aThemedMorph 426247 for: aModel 426248 list: listSel 426249 getSelected: getSel 426250 setSelected: setSel 426251 getEnabled: enabledSel 426252 useIndex: true 426253 help: helpText! ! 426254 426255!UITheme methodsFor: 'morph creation' stamp: 'gvc 6/1/2009 13:18'! 426256newMorphDropListIn: aThemedMorph for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 426257 "Answer a morph drop list for the given model." 426258 426259 ^(MorphDropListMorph 426260 on: aModel 426261 list: listSel 426262 selected: getSel 426263 changeSelected: setSel 426264 useIndex: useIndex) 426265 selectionColor: self selectionColor; 426266 getEnabledSelector: enabledSel; 426267 cornerStyle: aThemedMorph preferredCornerStyle; 426268 hResizing: #spaceFill; 426269 vResizing: #shrinkWrap; 426270 setBalloonText: helpText! ! 426271 426272!UITheme methodsFor: 'morph creation' stamp: 'gvc 10/1/2007 12:16'! 426273newMorphListIn: aThemedMorph for: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText 426274 "Answer a morph list for the given model." 426275 426276 ^(PluggableMorphListMorph 426277 on: aModel 426278 list: listSelector 426279 selected: getSelector 426280 changeSelected: setSelector 426281 menu: nil 426282 keystroke: nil) 426283 selectionColor: self selectionColor; 426284 autoDeselect: false; 426285 cornerStyle: aThemedMorph preferredCornerStyle; 426286 color: Color white; 426287 borderStyle: (BorderStyle inset width: 1); 426288 hResizing: #spaceFill; 426289 vResizing: #spaceFill; 426290 getEnabledSelector: enabledSel; 426291 setBalloonText: helpText 426292 ! ! 426293 426294!UITheme methodsFor: 'morph creation' stamp: 'gvc 3/16/2007 15:51'! 426295newNoButtonIn: aThemedMorph for: aModel 426296 "Answer a new No button." 426297 426298 ^(self 426299 newButtonIn: aThemedMorph 426300 for: aModel 426301 getState: nil 426302 action: #no 426303 arguments: nil 426304 getEnabled: nil 426305 label: 'No' translated 426306 help: 'Answer no and close the window' translated) 426307 hResizing: #rigid; 426308 vResizing: #rigid! ! 426309 426310!UITheme methodsFor: 'morph creation' stamp: 'gvc 3/23/2007 15:57'! 426311newOKButtonIn: aThemedMorph for: aModel getEnabled: enabledSel 426312 "Answer a new OK button." 426313 426314 ^(self 426315 newButtonIn: aThemedMorph 426316 for: aModel 426317 getState: nil 426318 action: #ok 426319 arguments: nil 426320 getEnabled: enabledSel 426321 label: 'OK' translated 426322 help: 'Apply changes and close the window' translated) 426323 hResizing: #rigid; 426324 vResizing: #rigid! ! 426325 426326!UITheme methodsFor: 'morph creation' stamp: 'gvc 1/4/2007 11:54'! 426327newPanelIn: aThemedMorph 426328 "Answer a new panel." 426329 426330 ^PanelMorph new 426331 changeTableLayout; 426332 layoutInset: 4; 426333 cellInset: 8; 426334 cornerStyle: aThemedMorph preferredCornerStyle; 426335 yourself! ! 426336 426337!UITheme methodsFor: 'morph creation' stamp: 'gvc 7/30/2009 14:12'! 426338newPluggableDialogWindowIn: aThemedMorph title: title for: contentMorph 426339 "Answer a new pluggable dialog panel with the given content." 426340 426341 |answer| 426342 answer := PluggableDialogWindow new 426343 setWindowColor: aThemedMorph paneColor; 426344 title: title; 426345 contentMorph: contentMorph. 426346 contentMorph ifNotNil: [answer model: nil]. 426347 ^answer! ! 426348 426349!UITheme methodsFor: 'morph creation' stamp: 'gvc 5/22/2007 15:39'! 426350newRadioButtonIn: aThemedMorph for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: label help: helpText 426351 "Answer a checkbox (radio button appearance) with the given label ." 426352 426353 ^(CheckboxMorph 426354 on: aModel selected: getSel changeSelected: setSel) 426355 getEnabledSelector: enabledSel; 426356 font: self labelFont; 426357 label: label; 426358 hResizing: #shrinkWrap; 426359 vResizing: #shrinkWrap; 426360 setBalloonText: helpText; 426361 beRadioButton! ! 426362 426363!UITheme methodsFor: 'morph creation' stamp: 'gvc 4/24/2007 10:31'! 426364newRowIn: aThemedMorph for: controls 426365 "Answer a morph laid out with a row of controls." 426366 426367 |answer| 426368 answer := PanelMorph new 426369 hResizing: #spaceFill; 426370 vResizing: #shrinkWrap; 426371 fillStyle: Color transparent; "non pane color tracking" 426372 changeTableLayout; 426373 listDirection: #leftToRight; 426374 cellInset: 8. 426375 controls do: [:m | answer addMorphBack: m]. 426376 ^answer 426377 ! ! 426378 426379!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/8/2007 14:38'! 426380newSVSelectorIn: aThemedMorph color: aColor help: helpText 426381 "Answer a saturation-volume selector." 426382 426383 ^SVColorSelectorMorph new 426384 color: aColor; 426385 selectedColor: aColor; 426386 hResizing: #spaceFill; 426387 vResizing: #spaceFIll; 426388 setBalloonText: helpText! ! 426389 426390!UITheme methodsFor: 'morph creation' stamp: 'gvc 1/23/2007 16:25'! 426391newSeparatorIn: aThemedMorph 426392 "Answer a new horizontal separator." 426393 426394 ^SeparatorMorph new 426395 fillStyle: Color transparent; 426396 borderStyle: (BorderStyle inset baseColor: Color blue; width: 1); 426397 extent: 2@2; 426398 hResizing: #spaceFill! ! 426399 426400!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/8/2009 13:08'! 426401newSliderIn: aThemedMorph for: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText 426402 "Answer a slider." 426403 426404 ^(PluggableSliderMorph 426405 on: aModel 426406 getValue: getSel 426407 setValue: setSel 426408 min: min 426409 max: max 426410 quantum: quantum) 426411 getEnabledSelector: enabledSel; 426412 hResizing: #spaceFill; 426413 vResizing: #spaceFill; 426414 setBalloonText: helpText! ! 426415 426416!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/9/2007 11:41'! 426417newStringIn: aThemedMorph label: aStringOrText font: aFont style: aStyle 426418 "Answer a new string/text morph." 426419 426420 ^(EmbossedStringMorph contents: aStringOrText font: aFont) 426421 style: aStyle! ! 426422 426423!UITheme methodsFor: 'morph creation' stamp: 'gvc 1/17/2008 11:28'! 426424newTabGroupIn: aThemedMorph for: labelsAndControls 426425 "Answer a tab group morph with the given tab labels and associated pages." 426426 426427 ^(TabGroupMorph new 426428 font: self labelFont; 426429 cornerStyle: (self tabGroupCornerStyleIn: aThemedMorph); 426430 hResizing: #spaceFill; 426431 vResizing: #spaceFill; 426432 labelsAndPages: labelsAndControls) 426433 selectedPageIndex: (labelsAndControls isEmpty ifTrue: [0] ifFalse: [1])! ! 426434 426435!UITheme methodsFor: 'morph creation' stamp: 'gvc 1/31/2009 15:57'! 426436newTaskbarButtonIn: aTaskbar for: aWindow 426437 "Answer a taskbar button morph for the given window." 426438 426439 |lm lab button labSize| 426440 labSize := (150 // (aTaskbar tasks size + 1) max: 10) min: 30. 426441 lab := (self buttonLabelForText: (aWindow taskbarLabel truncateWithElipsisTo: labSize)). 426442 lm := self 426443 newRowIn: aTaskbar 426444 for: {(aWindow taskbarIcon ifNil: [^nil]) asMorph. lab}. 426445 lm cellInset: 2. 426446 button := self 426447 newButtonIn: aTaskbar 426448 for: aWindow 426449 getState: #isCollapsed 426450 action: #taskbarButtonClicked 426451 arguments: #() 426452 getEnabled: nil 426453 label: lm 426454 help: nil. 426455 button 426456 onColor: (self taskbarMinimizedButtonColorFor: button) 426457 offColor: (aWindow isActive 426458 ifTrue: [self taskbarActiveButtonColorFor: button] 426459 ifFalse: [self taskbarButtonColorFor: button]); 426460 wantsYellowButtonMenu: true; 426461 getMenuSelector: #taskbarButtonMenu:; 426462 on: #mouseEnter send: #taskbarButtonEntered:event:in: to: aWindow withValue: button; 426463 on: #mouseLeave send: #taskbarButtonLeft:event:in: to: aWindow withValue: button. 426464 lab color: (self taskbarButtonLabelColorFor: button). 426465 ^button! ! 426466 426467!UITheme methodsFor: 'morph creation' stamp: 'gvc 3/2/2009 12:31'! 426468newTaskbarThumbnailIn: aThemedMorph for: aWindow 426469 "Answer a taskbar thumbnail morph for the given window." 426470 426471 |answer thumb| 426472 thumb := aWindow taskbarThumbnail. 426473 answer := PanelMorph new 426474 hResizing: #shrinkWrap; 426475 vResizing: #shrinkWrap; 426476 changeTableLayout; 426477 layoutInset: 8; 426478 cellInset: 4; 426479 addMorphBack: thumb; 426480 addMorphBack: (self 426481 buttonLabelForText: (aWindow labelString truncateWithElipsisTo: 50)). 426482 answer 426483 extent: answer minExtent; 426484 fillStyle: (self tasklistFillStyleFor: answer); 426485 borderStyle: (self taskbarThumbnailNormalBorderStyleFor: aWindow); 426486 cornerStyle: (self taskbarThumbnailCornerStyleFor: answer). 426487 ^answer! ! 426488 426489!UITheme methodsFor: 'morph creation' stamp: 'gvc 3/2/2009 12:17'! 426490newTasklistButtonIn: aTasklist for: aTask 426491 "Answer a tasklist button morph for the given task." 426492 426493 |lm lab button| 426494 lab := (self buttonLabelForText: aTask label). 426495 lm := self 426496 newRowIn: aTasklist 426497 for: {(aTask icon ifNil: [MenuIcons smallWindowIcon]) asMorph. lab}. 426498 button := self 426499 newButtonIn: aTasklist 426500 for: aTask morph 426501 getState: #isActive 426502 action: #buttonClickedForTasklist: 426503 arguments: {aTasklist} 426504 getEnabled: nil 426505 label: lm 426506 help: nil. 426507 button 426508 useSquareCorners; 426509 onColor: (self taskbarMinimizedButtonColorFor: button) 426510 offColor: (aTask isActive 426511 ifTrue: [self taskbarActiveButtonColorFor: button] 426512 ifFalse: [self taskbarButtonColorFor: button]); 426513 hResizing: #spaceFill. 426514 lab color: (self taskbarButtonLabelColorFor: button). 426515 button model: aTask. 426516 ^button! ! 426517 426518!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/28/2009 11:39'! 426519newTextEditorIn: aThemedMorph for: aModel getText: getSel setText: setSel getEnabled: enabledSel 426520 "Answer a text editor for the given model." 426521 426522 ^PluggableTextEditorMorph new 426523 on: aModel 426524 text: getSel 426525 accept: setSel 426526 readSelection: nil 426527 menu: nil; 426528 getEnabledSelector: enabledSel; 426529 font: self textFont; 426530 cornerStyle: aThemedMorph preferredCornerStyle; 426531 hResizing: #spaceFill; 426532 vResizing: #spaceFill; 426533 borderStyle: (BorderStyle inset width: 1); 426534 color: Color white; 426535 selectionColor: self selectionColor! ! 426536 426537!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/28/2009 11:39'! 426538newTextEntryIn: aThemedMorph for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText 426539 "Answer a text entry for the given model." 426540 426541 |pt| 426542 pt := PluggableTextFieldMorph new 426543 convertTo: aClass; 426544 alwaysAccept: true; 426545 on: aModel 426546 text: getSel 426547 accept: setSel 426548 readSelection: nil 426549 menu: nil; 426550 acceptOnCR: true; 426551 getEnabledSelector: enabledSel; 426552 font: self textFont; 426553 cornerStyle: (self textEntryCornerStyleIn: aThemedMorph); 426554 hResizing: #spaceFill; 426555 vResizing: #rigid; 426556 borderStyle: (BorderStyle inset width: 1); 426557 color: Color white; 426558 selectionColor: self selectionColor; 426559 hideScrollBarsIndefinitely; 426560 extent: 24@(self textFont height + 8); 426561 setBalloonText: helpText. 426562 pt textMorph 426563 autoFit: true; 426564 wrapFlag: false; 426565 margins: (2@1 corner: 2@1). 426566 ^pt! ! 426567 426568!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/11/2006 09:46'! 426569newTextIn: aThemedMorph text: aStringOrText 426570 "Answer a new text." 426571 426572 ^TextMorph new 426573 wrapFlag: true; 426574 contents: aStringOrText; 426575 font: self textFont; 426576 autoFit: true; 426577 lock; 426578 hResizing: #shrinkWrap; 426579 vResizing: #shrinkWrap! ! 426580 426581!UITheme methodsFor: 'morph creation' stamp: 'gvc 8/25/2006 14:38'! 426582newTitleIn: aThemedMorph label: aString for: control 426583 "Answer a morph laid out with a column with the title and control aligned to the left." 426584 426585 ^(self newColumnIn: aThemedMorph for: { 426586 self newLabelIn: aThemedMorph label: aString. 426587 control}) 426588 cellPositioning: #leftCenter; 426589 cellInset: 2! ! 426590 426591!UITheme methodsFor: 'morph creation' stamp: 'gvc 6/20/2007 09:37'! 426592newToolDockingBarIn: aThemedMorph 426593 "Answer a new tool docking bar." 426594 426595 ^ToolDockingBarMorph new 426596 borderWidth: 0; 426597 hResizing: #spaceFill; 426598 vResizing: #shrinkWrap; 426599 clipSubmorphs: true! ! 426600 426601!UITheme methodsFor: 'morph creation' stamp: 'gvc 9/19/2006 10:03'! 426602newToolSpacerIn: aThemedMorph 426603 "Answer a new tool spacer." 426604 426605 ^Morph new 426606 borderWidth: 0; 426607 color: Color transparent; 426608 extent: 3@3! ! 426609 426610!UITheme methodsFor: 'morph creation' stamp: 'gvc 4/16/2007 11:08'! 426611newToolbarHandleIn: aThemedMorph 426612 "Answer a new toolbar handle." 426613 426614 ^PanelMorph new 426615 fillStyle: Color transparent; "non pane color tracking" 426616 borderStyle: (BorderStyle raised baseColor: Color blue; width: 1); 426617 extent: 4@3; 426618 vResizing: #spaceFill! ! 426619 426620!UITheme methodsFor: 'morph creation' stamp: 'gvc 2/21/2008 15:22'! 426621newToolbarIn: aThemedMorph 426622 "Answer a new toolbar." 426623 426624 |bar| 426625 bar := Morph new 426626 borderWidth: 0; 426627 color: Color transparent; 426628 changeTableLayout; 426629 layoutInset: (0@1 corner: 0@1); 426630 listDirection: #leftToRight; 426631 hResizing: #shrinkWrap; 426632 vResizing: #shrinkWrap. 426633 bar 426634 addMorphBack: (self newToolSpacerIn: aThemedMorph); 426635 addMorphBack: (self newToolbarHandleIn: aThemedMorph); 426636 addMorphBack: (self newToolSpacerIn: aThemedMorph). 426637 ^bar! ! 426638 426639!UITheme methodsFor: 'morph creation' stamp: 'gvc 7/30/2009 14:12'! 426640newToolbarIn: aThemedMorph for: controls 426641 "Answer a new toolbar with the given controls." 426642 426643 |answer| 426644 answer := self newToolbarIn: aThemedMorph. 426645 controls do: [:m | answer addMorphBack: m]. 426646 ^answer! ! 426647 426648!UITheme methodsFor: 'morph creation' stamp: 'gvc 10/17/2006 12:27'! 426649newTreeIn: aThemedMorph for: aModel list: listSelector selected: getSelector changeSelected: setSelector 426650 "Answer a new tree morph." 426651 426652 ^TreeListMorph new 426653 selectionColor: self selectionColor; 426654 font: self listFont; 426655 on: aModel 426656 list: listSelector 426657 selected: getSelector 426658 changeSelected: setSelector 426659 menu: nil 426660 keystroke: nil; 426661 cornerStyle: aThemedMorph preferredCornerStyle; 426662 color: Color white; 426663 borderStyle: (BorderStyle inset width: 1); 426664 hResizing: #spaceFill; 426665 vResizing: #spaceFill; 426666 autoDeselect: false; 426667 yourself 426668 ! ! 426669 426670!UITheme methodsFor: 'morph creation' stamp: 'gvc 1/23/2007 16:39'! 426671newVerticalSeparatorIn: aThemedMorph 426672 "Answer a new vertical separator." 426673 426674 ^SeparatorMorph new 426675 fillStyle: Color transparent; 426676 borderStyle: (BorderStyle inset baseColor: Color blue; width: 1); 426677 extent: 2@2; 426678 vResizing: #spaceFill! ! 426679 426680!UITheme methodsFor: 'morph creation' stamp: 'gvc 3/16/2007 15:51'! 426681newYesButtonIn: aThemedMorph for: aModel 426682 "Answer a new Yes button." 426683 426684 ^(self 426685 newButtonIn: aThemedMorph 426686 for: aModel 426687 getState: nil 426688 action: #yes 426689 arguments: nil 426690 getEnabled: nil 426691 label: 'Yes' translated 426692 help: 'Answer yes and close the window' translated) 426693 hResizing: #rigid; 426694 vResizing: #rigid! ! 426695 426696 426697!UITheme methodsFor: 'services' stamp: 'gvc 7/30/2009 18:14'! 426698abortIn: aThemedMorph text: aStringOrText title: aString 426699 "Answer the result of an error dialog (true) with the given label and title." 426700 426701 self abortSound play. 426702 ^(aThemedMorph openModal: ( 426703 ErrorDialogWindow new 426704 textFont: self textFont; 426705 title: aString; 426706 text: aStringOrText)) cancelled not! ! 426707 426708!UITheme methodsFor: 'services' stamp: 'gvc 8/12/2009 18:14'! 426709alertIn: aThemedMorph text: aStringOrText title: aString configure: aBlock 426710 "Answer the result of an alert dialog (true) with the given label and title." 426711 426712 |dialog| 426713 Preferences useThemeSounds ifTrue: [self alertSound play]. 426714 dialog := AlertDialogWindow new 426715 textFont: self textFont; 426716 title: aString; 426717 text: aStringOrText. 426718 aBlock value: dialog. 426719 aThemedMorph openModal: dialog. 426720 ^dialog cancelled not! ! 426721 426722!UITheme methodsFor: 'services' stamp: 'gvc 9/22/2006 11:01'! 426723chooseColorIn: aThemedMorph title: aString color: aColor 426724 "Answer the result of a color selector dialog with the given title and initial color." 426725 426726 |d| 426727 d := aThemedMorph openModal: ( 426728 ColorSelectorDialogWindow new 426729 title: aString; 426730 selectedColor: aColor). 426731 ^d cancelled 426732 ifFalse: [d selectedColor]! ! 426733 426734!UITheme methodsFor: 'services' stamp: 'gvc 1/15/2007 14:44'! 426735chooseDirectoryIn: aThemedMorph title: title path: path 426736 "Answer the result of a file dialog with the given title, choosing directories only." 426737 426738 |fd| 426739 fd := FileDialogWindow basicNew 426740 initialize; 426741 title: title; 426742 answerDirectory. 426743 path ifNotNil: [fd selectPathName: path]. 426744 ^(aThemedMorph openModal: fd) answer! ! 426745 426746!UITheme methodsFor: 'services' stamp: 'gvc 1/12/2007 14:21'! 426747chooseDropListIn: aThemedMorph text: aStringOrText title: aString list: aList 426748 "Answer the result of a drop list chooser with the given label, title and list." 426749 426750 ^(aThemedMorph openModal: ( 426751 ChooseDropListDialogWindow new 426752 textFont: self textFont; 426753 title: aString; 426754 text: aStringOrText; 426755 list: aList)) selectedItem! ! 426756 426757!UITheme methodsFor: 'services' stamp: 'gvc 4/4/2007 16:07'! 426758chooseFileIn: aThemedMorph title: title extensions: exts path: path preview: preview 426759 "Answer the result of a file open dialog with the given title, extensions path and preview type. 426760 Answer nil or a filename." 426761 426762 |fd| 426763 fd := FileDialogWindow basicNew 426764 previewType: preview; 426765 initialize; 426766 title: title; 426767 answerFileEntry. 426768 exts ifNotNil: [fd validExtensions: exts]. 426769 path ifNotNil: [fd selectPathName: path]. 426770 ^(aThemedMorph openModal: fd) answer! ! 426771 426772!UITheme methodsFor: 'services' stamp: 'gvc 4/4/2007 16:07'! 426773chooseFileNameIn: aThemedMorph title: title extensions: exts path: path preview: preview 426774 "Answer the result of a file name chooser dialog with the given title, extensions 426775 path and preview type. 426776 Answer nil or a filename." 426777 426778 |fd| 426779 fd := FileDialogWindow basicNew 426780 previewType: preview; 426781 initialize; 426782 title: title; 426783 answerFileName. 426784 exts ifNotNil: [fd validExtensions: exts]. 426785 path ifNotNil: [fd selectPathName: path]. 426786 ^(aThemedMorph openModal: fd) answer! ! 426787 426788!UITheme methodsFor: 'services' stamp: 'gvc 9/26/2008 14:36'! 426789chooseFontIn: aThemedMorph title: aString font: aFont 426790 "Answer the result of a font selector dialog with the given title and initial font." 426791 426792 |d| 426793 d := aThemedMorph openModal: ( 426794 Cursor wait showWhile: [ 426795 self newFontSelector 426796 title: aString; 426797 selectedFont: aFont]). 426798 ^d cancelled 426799 ifFalse: [d selectedFont]! ! 426800 426801!UITheme methodsFor: 'services' stamp: 'gvc 1/17/2007 15:48'! 426802chooseIn: aThemedMorph title: title labels: labels values: values lines: lines 426803 "Answer the result of a popup choice with the given title, labels, values and lines." 426804 426805 |pd| 426806 pd := PopupChoiceDialogWindow new 426807 title: (title isEmpty ifTrue: ['Choose' translated] ifFalse: [title asString]); 426808 labels: labels; 426809 lines: (lines ifNil: [#()]); 426810 model: values. 426811 ^(aThemedMorph openModal: pd) choice! ! 426812 426813!UITheme methodsFor: 'services' stamp: 'alain.plantec 2/6/2009 10:06'! 426814chooseIn: aThemedMorph title: title message: aMessage labels: labels values: values lines: lines 426815 "Answer the result of a popup choice with the given title, labels, values and lines." 426816 426817 |pd| 426818 pd := PopupChoiceDialogWindowWithMessage new 426819 title: (title isEmpty ifTrue: ['Choose' translated] ifFalse: [title asString]); 426820 textFont: self textFont; 426821 message: aMessage; 426822 labels: labels; 426823 lines: (lines ifNil: [#()]); 426824 model: values. 426825 ^(aThemedMorph openModal: pd) choice! ! 426826 426827!UITheme methodsFor: 'services' stamp: 'gvc 7/30/2009 18:14'! 426828customQuestionIn: aThemedMorph text: labelText yesText: yesText noText: noText title: aString 426829 "Answer the result of a question dialog with the given label, button labels and title." 426830 426831 self questionSound play. 426832 ^(aThemedMorph openModal: ( 426833 CustomQuestionDialogWindow new 426834 textFont: self textFont; 426835 title: aString; 426836 text: labelText; 426837 yesText: yesText help: nil; 426838 noText: noText help: nil)) answer! ! 426839 426840!UITheme methodsFor: 'services' stamp: 'gvc 7/30/2009 18:14'! 426841denyIn: aThemedMorph text: aStringOrText title: aString 426842 "Answer the result of an deny dialog (true) with the given label and title." 426843 426844 self denySound play. 426845 ^(aThemedMorph openModal: ( 426846 DenyDialogWindow new 426847 textFont: self textFont; 426848 title: aString; 426849 text: aStringOrText)) cancelled not! ! 426850 426851!UITheme methodsFor: 'services' stamp: 'gvc 9/27/2006 13:43'! 426852fileOpenIn: aThemedMorph title: title extensions: exts path: path preview: preview 426853 "Answer the result of a file open dialog with the given title, extensions path and preview type." 426854 426855 |fd| 426856 fd := FileDialogWindow basicNew 426857 previewType: preview; 426858 initialize; 426859 title: title; 426860 answerOpenFile. 426861 exts ifNotNil: [fd validExtensions: exts]. 426862 path ifNotNil: [fd selectPathName: path]. 426863 ^(aThemedMorph openModal: fd) answer! ! 426864 426865!UITheme methodsFor: 'services' stamp: 'gvc 8/31/2006 15:29'! 426866fileSaveIn: aThemedMorph title: title extensions: exts path: path 426867 "Answer the result of a file save dialog with the given title, extensions and path." 426868 426869 |fd| 426870 fd := FileDialogWindow new 426871 title: title; 426872 answerSaveFile. 426873 exts ifNotNil: [fd validExtensions: exts]. 426874 path ifNotNil: [fd selectPathName: path]. 426875 ^(aThemedMorph openModal: fd) answer! ! 426876 426877!UITheme methodsFor: 'services' stamp: 'gvc 7/30/2009 18:15'! 426878longMessageIn: aThemedMorph text: aStringOrText title: aString 426879 "Answer the result of a (potentially long) message dialog (true) with the given label and title." 426880 426881 self messageSound play. 426882 ^(aThemedMorph openModal: ( 426883 LongMessageDialogWindow new 426884 textFont: self textFont; 426885 title: aString; 426886 text: aStringOrText)) cancelled not! ! 426887 426888!UITheme methodsFor: 'services' stamp: 'gvc 7/30/2009 18:15'! 426889messageIn: aThemedMorph text: aStringOrText title: aString 426890 "Answer the result of a message dialog (true) with the given label and title." 426891 426892 self messageSound play. 426893 ^(aThemedMorph openModal: ( 426894 MessageDialogWindow new 426895 textFont: self textFont; 426896 title: aString; 426897 text: aStringOrText)) cancelled not! ! 426898 426899!UITheme methodsFor: 'services' stamp: 'gvc 4/20/2007 15:04'! 426900openTasklist: event 426901 "Open a tasklist to choose a window. 426902 Answer true if handled, false otherwise." 426903 426904 Sensor commandKeyPressed ifFalse: [^false]. 426905 event keyCharacter = Character arrowLeft 426906 ifTrue: [TasklistMorph new openAsIs selectPreviousTask. 426907 ^true]. 426908 event keyCharacter = Character arrowRight 426909 ifTrue: [TasklistMorph new openAsIs selectNextTask. 426910 ^true]. 426911 ^false! ! 426912 426913!UITheme methodsFor: 'services' stamp: 'gvc 12/3/2008 14:07'! 426914passwordEntryIn: aThemedMorph text: aStringOrText title: aString entryText: defaultEntryText 426915 "Answer the result of a password entry dialog (a string or nil if cancelled) 426916 with the given label and title." 426917 426918 ^(aThemedMorph openModal: ( 426919 PasswordDialogWindow new 426920 textFont: self textFont; 426921 title: aString; 426922 text: aStringOrText; 426923 entryText: defaultEntryText)) entryText! ! 426924 426925!UITheme methodsFor: 'services' stamp: 'gvc 7/30/2009 18:15'! 426926proceedIn: aThemedMorph text: aStringOrText title: aString 426927 "Answer the result of a proceed dialog with the given label and title." 426928 426929 self questionSound play. 426930 ^(aThemedMorph openModal: ( 426931 ProceedDialogWindow new 426932 textFont: self textFont; 426933 title: aString; 426934 text: aStringOrText)) cancelled not! ! 426935 426936!UITheme methodsFor: 'services' stamp: 'gvc 7/30/2009 18:15'! 426937questionIn: aThemedMorph text: aStringOrText title: aString 426938 "Answer the result of a question dialog with the given label and title." 426939 426940 self questionSound play. 426941 ^(aThemedMorph openModal: ( 426942 QuestionDialogWindow new 426943 textFont: self textFont; 426944 title: aString; 426945 text: aStringOrText)) answer! ! 426946 426947!UITheme methodsFor: 'services' stamp: 'gvc 7/30/2009 18:15'! 426948questionWithoutCancelIn: aThemedMorph text: aStringOrText title: aString 426949 "Answer the result of a question dialog with the given label and title." 426950 426951 self questionSound play. 426952 ^(aThemedMorph openModal: ( 426953 QuestionWithoutCancelDialogWindow new 426954 textFont: self textFont; 426955 title: aString; 426956 text: aStringOrText)) answer! ! 426957 426958!UITheme methodsFor: 'services' stamp: 'gvc 5/1/2007 11:32'! 426959textEditorIn: aThemedMorph text: aStringOrText title: aString entryText: defaultEntryText 426960 "Answer the result of a text editor (multiline) dialog ( a string or nil if cancelled) 426961 with the given label and title." 426962 426963 ^self 426964 textEditorIn: aThemedMorph 426965 text: aStringOrText 426966 title: aString 426967 entryText: defaultEntryText 426968 entryHeight: 64! ! 426969 426970!UITheme methodsFor: 'services' stamp: 'gvc 7/30/2009 18:15'! 426971textEditorIn: aThemedMorph text: aStringOrText title: aString entryText: defaultEntryText entryHeight: entryHeight 426972 "Answer the result of a text editor (multiline) dialog ( a string or nil if cancelled) 426973 with the given label and title." 426974 426975 self questionSound play. 426976 ^(aThemedMorph openModal: ( 426977 TextEditorDialogWindow new 426978 textFont: self textFont; 426979 title: aString; 426980 text: aStringOrText; 426981 entryText: defaultEntryText; 426982 entryHeight: entryHeight)) entryText! ! 426983 426984!UITheme methodsFor: 'services' stamp: 'gvc 7/30/2009 18:15'! 426985textEntryIn: aThemedMorph text: aStringOrText title: aString entryText: defaultEntryText 426986 "Answer the result of a text entry dialog ( a string or nil if cancelled) 426987 with the given label and title." 426988 426989 self questionSound play. 426990 ^(aThemedMorph openModal: ( 426991 TextEntryDialogWindow new 426992 textFont: self textFont; 426993 title: aString; 426994 text: aStringOrText; 426995 entryText: defaultEntryText)) entryText! ! 426996 426997 426998!UITheme methodsFor: 'sounds' stamp: 'gvc 9/12/2007 14:45'! 426999abortSound 427000 "Answer the abort sound." 427001 427002 ^self soundTheme abortSound! ! 427003 427004!UITheme methodsFor: 'sounds' stamp: 'gvc 9/12/2007 14:45'! 427005alertSound 427006 "Answer the alert sound." 427007 427008 ^self soundTheme alertSound! ! 427009 427010!UITheme methodsFor: 'sounds' stamp: 'gvc 9/12/2007 14:45'! 427011denySound 427012 "Answer the deny sound." 427013 427014 ^self soundTheme denySound! ! 427015 427016!UITheme methodsFor: 'sounds' stamp: 'gvc 9/12/2007 14:45'! 427017messageSound 427018 "Answer the message sound." 427019 427020 ^self soundTheme messageSound! ! 427021 427022!UITheme methodsFor: 'sounds' stamp: 'gvc 9/12/2007 14:43'! 427023questionSound 427024 "Answer the question sound." 427025 427026 ^self soundTheme questionSound! ! 427027 427028!UITheme methodsFor: 'sounds' stamp: 'gvc 9/12/2007 14:40'! 427029windowCloseSound 427030 "Answer the window close sound." 427031 427032 ^self soundTheme windowCloseSound! ! 427033 427034!UITheme methodsFor: 'sounds' stamp: 'gvc 9/12/2007 14:45'! 427035windowMaximizeSound 427036 "Answer the window maximize sound." 427037 427038 ^self soundTheme windowMaximizeSound! ! 427039 427040!UITheme methodsFor: 'sounds' stamp: 'gvc 9/12/2007 14:46'! 427041windowMinimizeSound 427042 "Answer the window minimize sound." 427043 427044 ^self soundTheme windowMinimizeSound! ! 427045 427046!UITheme methodsFor: 'sounds' stamp: 'gvc 9/12/2007 17:49'! 427047windowOpenSound 427048 "Answer the window open sound." 427049 427050 ^self soundTheme windowOpenSound! ! 427051 427052!UITheme methodsFor: 'sounds' stamp: 'gvc 9/12/2007 14:46'! 427053windowRestoreDownSound 427054 "Answer the window restore down sound." 427055 427056 ^self soundTheme windowRestoreDownSound! ! 427057 427058!UITheme methodsFor: 'sounds' stamp: 'gvc 9/12/2007 14:46'! 427059windowRestoreUpSound 427060 "Answer the window restore up sound." 427061 427062 ^self soundTheme windowRestoreUpSound! ! 427063 427064"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 427065 427066UITheme class 427067 instanceVariableNames: 'defaultSettings'! 427068 427069!UITheme class methodsFor: 'accessing' stamp: 'gvc 10/16/2008 16:04'! 427070defaultSettings 427071 "Answer the default settings for the theme." 427072 427073 ^defaultSettings ifNil: [ 427074 self defaultSettings: self newDefaultSettings. 427075 defaultSettings]! ! 427076 427077!UITheme class methodsFor: 'accessing' stamp: 'gvc 10/16/2008 16:05'! 427078defaultSettings: aThemeSettings 427079 "Set the default settings for the theme." 427080 427081 defaultSettings := aThemeSettings! ! 427082 427083 427084!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 12/1/2008 15:43'! 427085allThemeClasses 427086 "Answer the subclasses of the receiver that are considered to be 427087 concrete (useable as a theme)." 427088 427089 ^(self allSubclasses reject: [:c | c isAbstract]) asSortedCollection: [:a :b | 427090 a themeName <= b themeName]! ! 427091 427092!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 6/22/2007 14:25'! 427093beCurrent 427094 "Make a new instance of the receiver be the current theme." 427095 427096 self isAbstract ifTrue: [^self error: self name, ' is abstract, send #beCurrent to a subclass.']. 427097 self current: self newDefault! ! 427098 427099!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 2/6/2007 11:43'! 427100builder 427101 "Answer a morph that has the TEasilyThemed trait." 427102 427103 ^Builder ifNil: [Builder := self newBuilder. Builder]! ! 427104 427105!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 9/5/2007 13:06'! 427106current 427107 "Answer the current ui theme." 427108 427109 ^Current ifNil: [Current := UIThemeSoftSqueak newDefault. Current]! ! 427110 427111!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 18:26'! 427112current: aUITheme 427113 "Set the current ui theme." 427114 427115 Current := aUITheme. 427116 UITheme allThemeClasses do: [:c | c changed: #isCurrent]. 427117 SystemProgressMorph reset. "reset to use new fill styles" 427118 ScrollBar initializeImagesCache. "reset to use new arrows" 427119 aUITheme updateWorldDockingBars. 427120 World themeChanged! ! 427121 427122!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 18:09'! 427123initialize 427124 "Set up ui enhancement preferences here." 427125 427126 Preferences 427127 addPreference: #showTextEditingState 427128 categories: #(morphic) 427129 default: false 427130 balloonHelp: 'When enabled the editing state of PluggableTextMorphs is shown as a colored inset border.' translated; 427131 addPreference: #externalFocusForPluggableText 427132 categories: #(morphic) 427133 default: true 427134 balloonHelp: 'When enabled the focus indication for PluggableTextMorphs will be drawn in the border rather than around the embedded TextMorph.' translated; 427135 addPreference: #mouseClickForKeyboardFocus 427136 categories: #(morphic) 427137 default: false 427138 balloonHelp: 'When enabled the mouse button must be clicked within a morph for it to take the keyboard focus.' translated; 427139 addPreference: #gradientScrollbarLook 427140 categories: #(scrolling windows) 427141 default: true 427142 balloonHelp: 'Scrollbars have a nicer appearance using UITheme.' translated; 427143 addPreference: #gradientButtonLook 427144 categories: #(buttons windows) 427145 default: true 427146 balloonHelp: 'Buttons have a nicer appearance using UITheme.' translated; 427147 addPreference: #windowsActiveOnFirstClick 427148 categories: #(windows) 427149 default: false 427150 balloonHelp: 'When disabled, the first click of an inactive window will only activate it rather than also controlling a submorph.' translated; 427151 addPreference: #fadedBackgroundWindows 427152 categories: #(windows) 427153 default: true 427154 balloonHelp: 'Background windows appear more "washed out" to distinguish from the active window.' translated; 427155 addPreference: #windowAnimation 427156 categories: #(windows) 427157 default: true 427158 balloonHelp: 'Animate the minimising, restoring, expanding and (optionally) closing of windows.' translated; 427159 addPreference: #noWindowAnimationForClosing 427160 categories: #(windows) 427161 default: false 427162 balloonHelp: 'Don''t animate the closing of windows.' translated; 427163 addNumericPreference: #windowAnimationDelay 427164 categories: #(windows) 427165 default: 10 427166 balloonHelp: 'The delay between each step of the window animation in milliseconds.' translated; 427167 addNumericPreference: #windowAnimationSteps 427168 categories: #(windows) 427169 default: 15 427170 balloonHelp: 'The number of steps in the window animation.' translated. 427171 self current class = UITheme ifTrue: [self current: nil] "due to change to being abstract". 427172 Smalltalk addToStartUpList: self! ! 427173 427174!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 6/22/2007 14:24'! 427175isAbstract 427176 "Answer whether the receiver is considered to be abstract." 427177 427178 ^true! ! 427179 427180!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 6/22/2007 15:19'! 427181isCurrent 427182 "Answer whether an instance of the receiver is the current theme." 427183 427184 ^Current class == self! ! 427185 427186!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 2/6/2007 11:44'! 427187newBuilder 427188 "Answer a new builder morph." 427189 427190 ^ComposableMorph new! ! 427191 427192!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 8/24/2006 18:28'! 427193newDefault 427194 "Answer a new default ui theme." 427195 427196 ^self new! ! 427197 427198!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 10/16/2008 16:08'! 427199newDefaultSettings 427200 "Answer a new original default settings." 427201 427202 ^ThemeSettings new 427203 buttonColor: Color gray; 427204 scrollbarColor: Color gray! ! 427205 427206!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 10/16/2008 16:16'! 427207resetDefaultSettings 427208 "Reset the default settings to use the original values." 427209 427210 self defaultSettings: nil! ! 427211 427212!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 5/10/2007 10:14'! 427213startUp 427214 "Reset the system progress morph in case of font changes." 427215 427216 SystemProgressMorph reset! ! 427217 427218!UITheme class methodsFor: 'as yet unclassified' stamp: 'gvc 6/22/2007 15:18'! 427219themeName 427220 "Answer the friendly name of the theme." 427221 427222 self subclassResponsibility! ! 427223 427224 427225!UITheme class methodsFor: 'examples' stamp: 'gvc 8/28/2007 17:26'! 427226closeExampleDialogs 427227 "Close the example dialogs." 427228 427229 DialogWindow allSubInstances do: [:d | d cancel]! ! 427230 427231!UITheme class methodsFor: 'examples' stamp: 'StephaneDucasse 10/2/2009 15:40'! 427232exampleBasicControls 427233 "Open a window with examples of each of the basic controls." 427234 "self exampleBasicControls" 427235 427236 |dialog builder radioModel treeModel| 427237 builder := self exampleBuilder. 427238 dialog := (builder newPluggableDialogWindow: 'Example basic controls') useDefaultOKButton. 427239 radioModel := ExampleRadioButtonModel new. 427240 treeModel := ValueHolder new contents: TextStyle actualTextStyles explorerContents. 427241 dialog contentMorph: (dialog newRow: { 427242 dialog newLabelGroup: { 427243 'Normal Label'->(dialog newLabel: 'A Label'). 427244 'Disabled Label'->(dialog newLabel: 'A Disabled Label') disable. 427245 'Normal Button'->(dialog newButtonFor: nil action: nil label: 'A Button' help: 'This is a button'). 427246 'Default Button'->((dialog newButtonFor: nil action: nil label: 'Default Button' help: 'This is a default button') isDefault: true). 427247 'Disabled Button'->(dialog newButtonFor: nil action: nil label: 'Disabled Button' 427248 help: 'This is a disabled button') disable. 427249 'Selected Button'->(dialog newButtonFor: (ValueHolder new contents: true) getState: #contents 427250 action: nil arguments: #() getEnabled: nil label: 'A Button' help: 'This is a selected button'). 427251 'Selected Disabled Button'->(dialog newButtonFor: (ValueHolder new contents: true) getState: #contents 427252 action: nil arguments: #() getEnabled: nil label: 'Disabled Button' 427253 help: 'This is a selected disabled button') disable. 427254 'Checkbox'->(dialog newCheckboxFor: (ValueHolder new contents: true) 427255 getSelected: #contents setSelected: #contents: label: 'A Checkbox' help: 'This is a checkbox'). 427256 'Disabled Checkbox'->(dialog newCheckboxFor: (ValueHolder new contents: true) 427257 getSelected: #contents setSelected: #contents: 427258 label: 'A Disabled Checkbox' help: 'This is a disabled checkbox') disable. 427259 'Radio Buttons'->(dialog newColumn: { 427260 (dialog newRadioButtonFor: radioModel 427261 getSelected: #isLeft setSelected: #beLeft label: 'Left' help: 'This is a radio buton'). 427262 (dialog newRadioButtonFor: radioModel 427263 getSelected: #isCenter setSelected: #beCenter label: 'Center' help: 'This is a radio buton'). 427264 (dialog newRadioButtonFor: radioModel 427265 getSelected: #isRight setSelected: #beRight label: 'Right' help: 'This is a radio buton')}). 427266 'Disabled Radio Button'->(dialog newRadioButtonFor: radioModel 427267 getSelected: #isRight setSelected: #beRight label: 'Right' 427268 help: 'This is a disabled radio buton') disable. 427269 'Text Entry'->(dialog newTextEntryFor: (ValueHolder new contents: 'Hello') 427270 getText: #contents setText: #contents: help: 'This is a text entry'). 427271 'Disabled Text Entry'->(dialog newTextEntryFor: (ValueHolder new contents: 'Hello') 427272 getText: #contents setText: #contents: help: 'This is a disabled text entry') disable. 427273 'Slider'->(dialog newSliderFor: (ValueHolder new contents: 0.5) 427274 getValue: #contents setValue: #contents: help: 'This is a slider'). 427275 'Disabled Slider'->(dialog newSliderFor: (ValueHolder new contents: 0.75) 427276 getValue: #contents setValue: #contents: help: 'This is a disabled slider') disable}. 427277 dialog newVerticalSeparator. 427278 dialog newLabelGroupSpread: { 427279 'Drop List'->(dialog newDropListFor: (ListModel new list: #('One' 'Two' 'Three' 'Four')) 427280 list: #list getSelected: #selectionIndex setSelected: #selectionIndex: help: 'This is a drop list'). 427281 'Disabled Drop List'->(dialog newDropListFor: (ListModel new list: #('One' 'Two' 'Three' 'Four'); selectionIndex: 3) 427282 list: #list getSelected: #selectionIndex setSelected: #selectionIndex: 427283 help: 'This is a disabled drop list') disable. 427284 'Morph Drop List'->(dialog newMorphDropListFor: (ListModel new list: ({Color red. Color green. Color blue} 427285 collect: [:c | Morph new extent: 60@12; color: c])) 427286 list: #list getSelected: #selectionIndex setSelected: #selectionIndex: 427287 help: 'This is a morph drop list'). 427288 'Normal List'->((dialog newListFor: (ListModel new list: #('One' 'Two' 'Three' 'Four'); selectionIndex: 3) 427289 list: #list selected: #selectionIndex changeSelected: #selectionIndex: 427290 help: 'This is a list') minWidth: 120). 427291 'Disabled List'->(dialog newListFor: (ListModel new list: #('One' 'Two' 'Three' 'Four'); selectionIndex: 3) 427292 list: #list selected: #selectionIndex changeSelected: #selectionIndex: 427293 help: 'This is a disabled list') disable. 427294 'Morph List'->(dialog newMorphListFor: (ListModel new list: ((Color wheel: 20) 427295 collect: [:c | Morph new extent: 80@12; color: c])) 427296 list: #list getSelected: #selectionIndex setSelected: #selectionIndex: 427297 help: 'This is a morph list'). 427298 'Tree'->((dialog newTreeFor: treeModel list: #contents selected: nil changeSelected: nil) minHeight: 100)}. 427299 dialog newVerticalSeparator. 427300 dialog newColumn: { 427301 dialog newTitle: 'Text Editor' for: ( 427302 (dialog newTextEditorFor: (ValueHolder new contents: 'Hello') 427303 getText: #contents setText: #contents:) minWidth: 100). 427304 dialog newTitle: 'Disabled Text Editor' for: ( 427305 (dialog newTextEditorFor: (ValueHolder new contents: 'Hello') 427306 getText: #contents setText: #contents:) disable)}}); 427307 model: nil. 427308 builder openModal: dialog! ! 427309 427310!UITheme class methodsFor: 'examples' stamp: 'StephaneDucasse 10/2/2009 16:17'! 427311exampleBuilder 427312 "Answer a morph that implements TEasilyThemed but without honouring modality 427313 for the example dialogs." 427314"self exampleBuilder" 427315 427316 ^ExampleBuilderMorph new! ! 427317 427318!UITheme class methodsFor: 'examples' stamp: 'StephaneDucasse 10/2/2009 16:18'! 427319exampleColorControls 427320 "Open a window with examples of each of the color controls." 427321 "self exampleColorControls" 427322 427323 |dialog builder| 427324 builder := self exampleBuilder. 427325 dialog := (builder newPluggableDialogWindow: 'Example color controls') useDefaultOKButton. 427326 dialog contentMorph: (dialog newRow: { 427327 dialog newLabelGroup: { 427328 'Alpha Selector'->(dialog newAlphaSelector: (ValueHolder new contents: 0) 427329 getAlpha: #contents setAlpha: #contents: help: 'This is an alpha channel selector'). 427330 'Hue Selector'->(dialog newHueSelector: (ValueHolder new contents: 0) 427331 getHue: #contents setHue: #contents: help: 'This is a hue selector'). 427332 'SV Color Selector'->((dialog newSVSelector: Color yellow 427333 help: 'This is a saturation-volume selector') minHeight: 80). 427334 'HSV Color Selector'->((dialog newHSVSelector: Color green 427335 help: 'This is a hue-saturation-volume selector') minHeight: 80; minWidth: 120)}. 427336 dialog newVerticalSeparator. 427337 dialog newTitle: 'HSVA Color Selector' for: 427338 ((dialog newHSVASelector: Color cyan 427339 help: 'This is a hue-saturation-volume-alpha selector') 427340 minHeight: 184; minWidth: 184)}); 427341 model: nil. 427342 builder openModal: dialog! ! 427343 427344!UITheme class methodsFor: 'examples' stamp: 'StephaneDucasse 10/2/2009 16:18'! 427345exampleDialogs 427346 "Open an example of each services dialog. 427347 (self exampleDialogs)." 427348 "self exampleDialogs" 427349 427350 self exampleBuilder 427351 chooseFont: TextStyle default defaultFont; 427352 chooseColor: (Color r: 0.529 g: 0.611 b: 0.004); 427353 chooseDirectory: 'Choose folder'; 427354 chooseFileName: 'Pick a file name' extensions: nil path: nil preview: nil; 427355 textEntry: 'Choose a name for the project' title: 'Save project' entryText: 'My Project'; 427356 chooseDropList: 'Pick one!!' list: #('One' 'Two' 'Three' 'Four'); 427357 deny: 'Opening the safe is not possible!!'; 427358 message: 'Hello!!'; 427359 proceed: 'Save image?'; 427360 alert: 'Danger!!'; 427361 abort: 'Something has gone wrong...'; 427362 question: 'Save the file?' title: 'Exiting application'; 427363 questionWithoutCancel: 'Save image as well?' title: 'Exiting application'! ! 427364 427365!UITheme class methodsFor: 'examples' stamp: 'StephaneDucasse 10/2/2009 16:18'! 427366exampleGroups 427367 "Open a window with examples of each of the group type morphs." 427368 "self exampleGroups" 427369 427370 |dialog builder| 427371 builder := self exampleBuilder. 427372 dialog := (builder newPluggableDialogWindow: 'Example groups') useDefaultOKButton. 427373 dialog contentMorph: (dialog newRow: { 427374 dialog newLabelGroup: { 427375 'Plain Groupbox'->(dialog newGroupboxForAll: { 427376 dialog newButtonFor: nil action: nil label: 'A Button' help: 'This is a button'. 427377 dialog newButtonFor: nil action: nil label: 'A Button' help: 'This is a button'}). 427378 'Groupbox'->(dialog newGroupbox: 'A groupbox' forAll: { 427379 dialog newButtonFor: nil action: nil label: 'A Button' help: 'This is a button'. 427380 dialog newButtonFor: nil action: nil label: 'A Button' help: 'This is a button'})}. 427381 dialog newLabelGroup: { 427382 'Tab Group'->(dialog newTabGroup: { 427383 'Page 1'->(dialog newGroupbox: 'A groupbox' forAll: { 427384 dialog newButtonFor: nil action: nil label: 'A Button' help: 'This is a button'. 427385 dialog newButtonFor: nil action: nil label: 'A Button' help: 'This is a button'}). 427386 'Page 2'->(dialog newCheckboxFor: (ValueHolder new contents: true) 427387 getSelected: #contents setSelected: #contents: label: 'A Checkbox' 427388 help: 'This is a checkbox')})}}); 427389 model: nil. 427390 builder openModal: dialog! ! 427391 427392!UITheme class methodsFor: 'examples' stamp: 'StephaneDucasse 10/2/2009 15:43'! 427393exampleOtherControls 427394 "Open a window with examples of each of the other controls." 427395 "self exampleOtherControls" 427396 427397 |dialog builder image emboss fuzzy| 427398 builder := self exampleBuilder. 427399 dialog := (builder newPluggableDialogWindow: 'Example other controls') useDefaultOKButton. 427400 emboss := (dialog newString: 'Hello there') trackPaneColor: false. 427401 fuzzy := (dialog newFuzzyLabel: 'A Fuzzy Label') minHeight: 40; minWidth: 160. 427402 dialog contentMorph: (dialog newRow: { 427403 dialog newTitle: 'Alpha Image' for: ( 427404 dialog newColumn: { 427405 ((image := dialog newAlphaImage: nil help: 'This is an alpha image') 427406 borderWidth: 1; 427407 extent: 160@160). 427408 dialog newLabelGroup: { 427409 'Scale'->((dialog newSliderFor: image getValue: #scale setValue: #scale: 427410 min: 0 max: 4 quantum: nil 427411 getEnabled: nil help: 'The image scale 0..1') 427412 minHeight: 16). 427413 'Alpha'->((dialog newAlphaSelector: image getAlpha: #alpha setAlpha: #alpha: help: 'The image alpha') 427414 minHeight: 16). 427415 'Layout'->(dialog newDropListFor: image list: #layoutSymbols 427416 getSelected: #layout setSelected: #layout: 427417 getEnabled: nil useIndex: false help: 'The image layout')}}). 427418 dialog newVerticalSeparator. 427419 dialog newLabelGroup: { 427420 'Color presenter'->(dialog newColorPresenterFor: (ValueHolder new contents: (Color blue alpha: 0.6)) 427421 getColor: #contents help: 'This is a color presenter'). 427422 'Color chooser'->(dialog newColorChooserFor: emboss 427423 getColor: #color setColor: #color: help: 'This is a color chooser'). 427424 'Row with dashed border'->((dialog newRow: {dialog newLabel: 'I have a dashed border!!'}) 427425 borderStyle: (DashedBorder width: 3 427426 dashColors: {Color red. Color green. Color blue} dashLengths: #(1 2 3))). 427427 'Embossed string'->emboss. 427428 'Style'->(dialog newDropListFor: emboss list: #styleSymbols 427429 getSelected: #style setSelected: #style: 427430 getEnabled: nil useIndex: false help: 'The embossed string style'). 427431 'Fuzzy label'->fuzzy. 427432 'Offset'->((dialog newSliderFor: fuzzy getValue: #offset setValue: #offset: 427433 min: 0 max: 5 quantum: 1 427434 getEnabled: nil help: 'The fuzzy label offset') 427435 minHeight: 16). 427436 'Alpha'->((dialog newAlphaSelector: fuzzy getAlpha: #alpha setAlpha: #alpha: 427437 help: 'The fuzzy label alpha') 427438 minHeight: 16)}. 427439 dialog newVerticalSeparator. 427440 dialog newTitle: 'Expanders' for: ( 427441 (dialog newColumn: { 427442 (dialog newExpander: 'An Expander' forAll: { 427443 dialog newLabel: 'Expanded!!'. 427444 builder newMorphListFor: (ListModel new list: ((Color wheel: 15) 427445 collect: [:c | Morph new extent: 80@12; color: c])) 427446 list: #list getSelected: #selectionIndex setSelected: #selectionIndex: 427447 help: 'This is a morph drop list'}) minWidth: 100. 427448 dialog newExpander: 'Another' forAll: { 427449 dialog newLabel: 'Expanded!!'. 427450 builder newMorphDropListFor: (ListModel new list: ((Color wheel: 8) 427451 collect: [:c | Morph new extent: 80@12; color: c])) 427452 list: #list getSelected: #selectionIndex setSelected: #selectionIndex: 427453 help: 'This is a morph drop list'}}) 427454 cellInset: 0; 427455 borderStyle: (BorderStyle inset baseColor: dialog paneColor; width: 1))}); 427456 model: nil. 427457 builder openModal: dialog! ! 427458 427459!UITheme class methodsFor: 'examples' stamp: 'StephaneDucasse 10/2/2009 16:19'! 427460exampleWindowWithToolbars 427461 "Open an example window with toolbars." 427462 "self exampleWindowWithToolbars" 427463 427464 |win fileMenu tools dock text holder| 427465 win := StandardWindow new. 427466 fileMenu := win newMenu. 427467 fileMenu 427468 addToggle: 'Open' translated 427469 target: nil "would be model" 427470 selector: #openFile. 427471 fileMenu lastItem 427472 font: win theme menuFont; 427473 icon: MenuIcons smallOpenIcon; 427474 keyText: 'Ctrl+O'. 427475 fileMenu 427476 addToggle: 'Save' translated 427477 target: nil 427478 selector: #saveFile 427479 getStateSelector: nil 427480 enablementSelector: nil. 427481 fileMenu lastItem 427482 font: win theme menuFont; 427483 keyText: 'Ctrl+S'. 427484 fileMenu 427485 addToggle: 'Print...' translated 427486 target: nil 427487 selector: #print. 427488 fileMenu lastItem 427489 font: win theme menuFont; 427490 icon: MenuIcons smallPrintIcon; 427491 keyText: 'Ctrl+P'. 427492 tools := win newToolbar: {win 427493 newButtonFor: nil "if we had a model it would go here" 427494 getState: nil 427495 action: #openFile 427496 arguments: nil 427497 getEnabled: nil 427498 labelForm: MenuIcons smallOpenIcon 427499 help: 'Open file' translated. 427500 win 427501 newButtonFor: nil 427502 getState: nil 427503 action: #saveFile 427504 arguments: nil 427505 getEnabled: nil 427506 labelForm: MenuIcons smallSaveIcon 427507 help: 'Save file' translated. 427508 win 427509 newButtonFor: nil 427510 getState: nil 427511 action: #print 427512 arguments: nil 427513 getEnabled: nil 427514 labelForm: MenuIcons smallPrintIcon 427515 help: 'Print' translated}. 427516 holder := StringHolder new. 427517 text := win 427518 newTextEditorFor: holder 427519 getText: #contents 427520 setText: #contents: 427521 getEnabled: nil. 427522 dock := win newToolDockingBar. 427523 dock 427524 add: 'File' translated 427525 font: win theme menuBarFont 427526 icon: MenuIcons smallOpenIcon 427527 help: 'File operations' translated 427528 subMenu: fileMenu; 427529 addMorphBack: tools. 427530 win 427531 addMorph: dock 427532 fullFrame: (LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0 @ dock minExtent y)); 427533 addMorph: text 427534 fullFrame: (LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@dock minExtent y corner: 0 @ 0)). 427535 win 427536 themeChanged; 427537 openInWorld 427538 427539 ! ! 427540UITheme subclass: #UIThemeSoftSqueak 427541 instanceVariableNames: '' 427542 classVariableNames: '' 427543 poolDictionaries: '' 427544 category: 'Polymorph-Widgets-Themes'! 427545!UIThemeSoftSqueak commentStamp: 'gvc 5/18/2007 10:05' prior: 0! 427546A soft gradient-based UI theme. Do UIThemeSoftSqueak beCurrent to use.! 427547 427548 427549!UIThemeSoftSqueak methodsFor: 'border-styles' stamp: 'gvc 4/25/2007 17:16'! 427550progressBarBorderStyleFor: aProgressBar 427551 "Return the progress bar borderStyle for the given progress bar." 427552 427553 |c| 427554 c := self progressBarColorFor: aProgressBar. 427555 ^BorderStyle inset 427556 width: 1; 427557 baseColor: c! ! 427558 427559 427560!UIThemeSoftSqueak methodsFor: 'border-styles-buttons' stamp: 'gvc 4/25/2007 16:54'! 427561buttonDisabledBorderStyleFor: aButton 427562 "Return the disabled button borderStyle for the given button." 427563 427564 |c| 427565 c := aButton colorToUse darker. 427566 aButton isDefault 427567 ifTrue: [c := c alphaMixed: 0.5 with: Color black]. 427568 ^BorderStyle raised 427569 width: 1; 427570 baseColor: c! ! 427571 427572!UIThemeSoftSqueak methodsFor: 'border-styles-buttons' stamp: 'gvc 4/25/2007 16:54'! 427573buttonNormalBorderStyleFor: aButton 427574 "Return the normal button borderStyle for the given button." 427575 427576 |c| 427577 c := aButton colorToUse. 427578 aButton isDefault 427579 ifTrue: [c := c alphaMixed: 0.5 with: Color black]. 427580 ^BorderStyle raised 427581 width: 1; 427582 baseColor: c! ! 427583 427584!UIThemeSoftSqueak methodsFor: 'border-styles-buttons' stamp: 'gvc 4/25/2007 16:54'! 427585buttonSelectedBorderStyleFor: aButton 427586 "Return the selected button borderStyle for the given button." 427587 427588 |c| 427589 c := aButton colorToUse. 427590 aButton isDefault 427591 ifTrue: [c := c alphaMixed: 0.5 with: Color black]. 427592 ^BorderStyle inset 427593 width: 1; 427594 baseColor: c! ! 427595 427596!UIThemeSoftSqueak methodsFor: 'border-styles-buttons' stamp: 'gvc 4/25/2007 16:55'! 427597buttonSelectedDisabledBorderStyleFor: aButton 427598 "Return the selecteddisabled button borderStyle for the given button." 427599 427600 |c| 427601 c := aButton colorToUse darker. 427602 aButton isDefault 427603 ifTrue: [c := c alphaMixed: 0.5 with: Color black]. 427604 ^BorderStyle inset 427605 width: 1; 427606 baseColor: c! ! 427607 427608!UIThemeSoftSqueak methodsFor: 'border-styles-buttons' stamp: 'gvc 8/10/2007 10:15'! 427609checkboxButtonDisabledBorderStyleFor: aCheckboxButton 427610 "Return the disabled checkbox button borderStyle for the given button." 427611 427612 ^BorderStyle inset 427613 width: 1; 427614 baseColor: aCheckboxButton paneColor darker! ! 427615 427616!UIThemeSoftSqueak methodsFor: 'border-styles-buttons' stamp: 'gvc 5/23/2007 12:29'! 427617checkboxButtonNormalBorderStyleFor: aCheckboxButton 427618 "Return the normal checkbox button borderStyle for the given button." 427619 427620 ^BorderStyle inset 427621 width: 1; 427622 baseColor: aCheckboxButton paneColor darker! ! 427623 427624!UIThemeSoftSqueak methodsFor: 'border-styles-buttons' stamp: 'gvc 7/30/2009 14:10'! 427625menuItemSelectedBorderStyleFor: aMenuItem 427626 "Return the selected menu item borderStyle for the given menu item." 427627 427628 |c| 427629 c := aMenuItem owner color isTransparent 427630 ifTrue: [aMenuItem paneColor darker] 427631 ifFalse: [aMenuItem owner color darker]. 427632 Display depth <= 2 ifTrue: [c := Color black]. 427633 ^BorderStyle raised 427634 width: 1; 427635 baseColor: c! ! 427636 427637 427638!UIThemeSoftSqueak methodsFor: 'border-styles-scrollbars' stamp: 'gvc 4/25/2007 17:10'! 427639scrollbarNormalThumbBorderStyleFor: aScrollbar 427640 "Return the normal thumb borderStyle for the given scrollbar." 427641 427642 |aColor| 427643 aColor := self scrollbarColorFor: aScrollbar. 427644 ^BorderStyle raised 427645 width: 1; 427646 baseColor: aColor twiceDarker! ! 427647 427648!UIThemeSoftSqueak methodsFor: 'border-styles-scrollbars' stamp: 'gvc 4/25/2007 17:10'! 427649scrollbarPressedThumbBorderStyleFor: aScrollbar 427650 "Return the pressed thumb borderStyle for the given scrollbar." 427651 427652 |aColor| 427653 aColor := self scrollbarColorFor: aScrollbar. 427654 ^BorderStyle inset 427655 width: 1; 427656 baseColor: aColor twiceDarker! ! 427657 427658 427659!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 12:22'! 427660dropListDisabledFillStyleFor: aDropList 427661 "Return the disabled fillStyle for the given dropList." 427662 427663 |c| 427664 c := aDropList paneColor alphaMixed: 0.3 with: Color white. 427665 ^(GradientFillStyle ramp: { 427666 0.0->c darker duller. 427667 0.2-> c darker. 427668 0.8->c twiceLighter. 427669 1.0->c darker}) 427670 origin: aDropList topLeft; 427671 direction: 0 @ aDropList height; 427672 radial: false! ! 427673 427674!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 12:22'! 427675dropListNormalFillStyleFor: aDropList 427676 "Return the normal fillStyle for the given drop list." 427677 427678 |c| 427679 c := aDropList paneColor alphaMixed: 0.1 with: Color white. 427680 ^(GradientFillStyle ramp: { 427681 0.0->c darker duller. 427682 0.2-> c lighter. 427683 0.8->c twiceLighter. 427684 1.0->c darker}) 427685 origin: aDropList topLeft; 427686 direction: 0 @ aDropList height; 427687 radial: false! ! 427688 427689!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 4/25/2007 16:59'! 427690expanderTitleNormalFillStyleFor: anExpanderTitle 427691 "Return the normal expander title fillStyle for the given expander title." 427692 427693 |aColor| 427694 aColor := anExpanderTitle paneColor. 427695 ^(GradientFillStyle ramp: { 427696 0.0->Color white. 0.2-> aColor twiceLighter. 427697 0.8->aColor darker. 1.0->aColor darker duller}) 427698 origin: anExpanderTitle topLeft; 427699 direction: 0 @ anExpanderTitle height; 427700 radial: false! ! 427701 427702!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 12:23'! 427703sliderDisabledFillStyleFor: aSlider 427704 "Return the disabled fillStyle for the given slider." 427705 427706 |c| 427707 c := aSlider paneColor alphaMixed: 0.3 with: Color white. 427708 ^(GradientFillStyle ramp: { 427709 0.0->c darker duller. 427710 0.2-> c darker. 427711 0.8->c twiceLighter. 427712 1.0->c darker}) 427713 origin: aSlider topLeft; 427714 direction: 0 @ aSlider height; 427715 radial: false! ! 427716 427717!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 12:23'! 427718sliderNormalFillStyleFor: aSlider 427719 "Return the normal fillStyle for the given slider." 427720 427721 |c| 427722 c := aSlider paneColor alphaMixed: 0.1 with: Color white. 427723 ^(GradientFillStyle ramp: { 427724 0.0->c darker duller. 427725 0.2-> c lighter. 427726 0.8->c twiceLighter. 427727 1.0->c darker}) 427728 origin: aSlider topLeft; 427729 direction: 0 @ aSlider height; 427730 radial: false! ! 427731 427732!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 6/2/2009 15:58'! 427733tasklistFillStyleFor: aTasklist 427734 "Return the tasklist fillStyle for the given tasklist." 427735 427736 ^Color gray alpha: 0.8! ! 427737 427738!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 5/23/2007 13:15'! 427739textEditorDisabledFillStyleFor: aTextEditor 427740 "Return the disabled fillStyle for the given text editor." 427741 427742 |c| 427743 c := aTextEditor paneColor alphaMixed: 0.3 with: Color white. 427744 ^(GradientFillStyle ramp: { 427745 0.0->c darker duller. 427746 0.1-> c darker. 427747 0.9->c twiceLighter. 427748 1.0->c darker}) 427749 origin: aTextEditor topLeft; 427750 direction: 0 @ aTextEditor height; 427751 radial: false! ! 427752 427753!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 5/23/2007 12:57'! 427754textEditorNormalFillStyleFor: aTextEditor 427755 "Return the normal fillStyle for the given text editor." 427756 427757 |c| 427758 c := aTextEditor paneColor alphaMixed: 0.1 with: Color white. 427759 ^(GradientFillStyle ramp: { 427760 0.0->c darker duller. 427761 0.1-> c lighter. 427762 0.9->c twiceLighter. 427763 1.0->c darker}) 427764 origin: aTextEditor topLeft; 427765 direction: 0 @ aTextEditor height; 427766 radial: false! ! 427767 427768!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 5/23/2007 13:16'! 427769textFieldDisabledFillStyleFor: aTextField 427770 "Return the disabled fillStyle for the given text field." 427771 427772 |c| 427773 c := aTextField paneColor alphaMixed: 0.3 with: Color white. 427774 ^(GradientFillStyle ramp: { 427775 0.0->c darker duller. 427776 0.2-> c darker. 427777 0.8->c twiceLighter. 427778 1.0->c darker}) 427779 origin: aTextField topLeft; 427780 direction: 0 @ aTextField height; 427781 radial: false! ! 427782 427783!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 5/23/2007 13:13'! 427784textFieldNormalFillStyleFor: aTextField 427785 "Return the normal fillStyle for the given text field." 427786 427787 |c| 427788 c := aTextField paneColor alphaMixed: 0.1 with: Color white. 427789 ^(GradientFillStyle ramp: { 427790 0.0->c darker duller. 427791 0.2-> c lighter. 427792 0.8->c twiceLighter. 427793 1.0->c darker}) 427794 origin: aTextField topLeft; 427795 direction: 0 @ aTextField height; 427796 radial: false! ! 427797 427798!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 7/18/2007 14:34'! 427799windowActiveLabelFillStyleFor: aWindow 427800 "Return the window active label fillStyle for the given window." 427801 427802 ^aWindow paneColorToUse alphaMixed: 0.3 with: Color black! ! 427803 427804!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 10/26/2007 21:26'! 427805windowActiveTitleFillStyleFor: aWindow 427806 "Return the window active title fillStyle for the given window." 427807 427808 |aColor| 427809 aColor := aWindow paneColorToUse. 427810 ^(GradientFillStyle ramp: { 427811 0.0->(aColor alphaMixed: 0.3 with: (Color white alpha: aColor alpha)). 427812 0.2-> aColor twiceLighter. 427813 0.8->aColor darker. 427814 1.0->aColor darker duller}) 427815 origin: aWindow labelArea topLeft; 427816 direction: 0 @ aWindow labelHeight; 427817 radial: false! ! 427818 427819!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 10/1/2007 14:54'! 427820windowEdgeNormalFillStyleFor: anEdgeGrip 427821 "Return the normal window edge fillStyle for the given edge grip." 427822 427823 |aColor| 427824 anEdgeGrip edgeName == #top ifTrue: [ 427825 ^Color transparent]. 427826 aColor := anEdgeGrip paneColor. 427827 ^(GradientFillStyle ramp: { 427828 0.0->aColor whiter whiter. 0.2->aColor lighter. 427829 0.8->aColor darker. 1.0->aColor blacker}) 427830 origin: anEdgeGrip topLeft; 427831 direction: (anEdgeGrip isHorizontal 427832 ifTrue: [0 @ anEdgeGrip height] 427833 ifFalse: [anEdgeGrip width @ 0]); 427834 radial: false! ! 427835 427836!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 7/18/2007 14:34'! 427837windowInactiveLabelFillStyleFor: aWindow 427838 "Return the window inactive label fillStyle for the given window." 427839 427840 ^aWindow paneColorToUse alphaMixed: 0.6 with: Color black! ! 427841 427842!UIThemeSoftSqueak methodsFor: 'fill-styles' stamp: 'gvc 4/26/2007 15:51'! 427843worldMainDockingBarNormalFillStyleFor: aDockingBar 427844 "Return the world main docking bar fillStyle for the given docking bar." 427845 427846 |aColor| 427847 aColor := aDockingBar originalColor. 427848 ^(GradientFillStyle ramp: { 427849 0.0->(aColor alphaMixed: 0.3 with: (Color white alpha: aColor alpha)). 427850 0.2-> aColor twiceLighter. 427851 0.8->aColor darker. 427852 1.0->aColor darker duller}) 427853 origin: aDockingBar topLeft; 427854 direction: (aDockingBar isVertical 427855 ifTrue: [aDockingBar width @ 0] 427856 ifFalse: [0 @ aDockingBar height]); 427857 radial: false! ! 427858 427859 427860!UIThemeSoftSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 17:00'! 427861buttonDisabledFillStyleFor: aButton 427862 "Return the disabled button fillStyle for the given color." 427863 427864 |c| 427865 c := aButton colorToUse twiceLighter whiter. 427866 ^(GradientFillStyle ramp: { 427867 0.0->Color white. 427868 0.2->c twiceLighter. 427869 0.8->c darker. 427870 1.0->c darker duller}) 427871 origin: aButton bounds origin; 427872 direction: 0 @ aButton height; 427873 radial: false! ! 427874 427875!UIThemeSoftSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 17:00'! 427876buttonMouseOverFillStyleFor: aButton 427877 "Return the button mouse over fillStyle for the given color." 427878 427879 |aColor c| 427880 aColor := aButton colorToUse. 427881 c := aColor luminance > 0.3 427882 ifTrue: [aColor blacker] 427883 ifFalse: [aColor whiter]. 427884 ^(GradientFillStyle ramp: { 427885 0.0->Color white. 427886 0.2->c twiceLighter. 427887 0.8->c darker. 427888 1.0->c darker duller}) 427889 origin: aButton bounds origin; 427890 direction: 0 @ aButton height; 427891 radial: false! ! 427892 427893!UIThemeSoftSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 17:00'! 427894buttonNormalFillStyleFor: aButton 427895 "Return the normal button fillStyle for the given button." 427896 427897 |aColor| 427898 aColor := self buttonColorFor: aButton. 427899 ^(GradientFillStyle ramp: { 427900 0.0->Color white. 427901 0.2->aColor twiceLighter. 427902 0.8->aColor darker. 427903 1.0->aColor darker duller}) 427904 origin: aButton bounds origin; 427905 direction: 0 @ aButton height; 427906 radial: false! ! 427907 427908!UIThemeSoftSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 17:00'! 427909buttonPressedFillStyleFor: aButton 427910 "Return the button pressed fillStyle for the given color." 427911 427912 |aColor c| 427913 aColor := aButton colorToUse. 427914 c := aColor luminance > 0.3 427915 ifTrue: [aColor blacker] 427916 ifFalse: [aColor whiter]. 427917 ^(GradientFillStyle ramp: { 427918 0.0->c darker duller. 0.2->c darker. 0.8->c twiceLighter. 1.0->Color white}) 427919 origin: aButton bounds origin; 427920 direction: 0 @ aButton height; 427921 radial: false! ! 427922 427923!UIThemeSoftSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 17:01'! 427924buttonSelectedDisabledFillStyleFor: aButton 427925 "Return the button selected disabled fillStyle for the given color." 427926 427927 |aColor c| 427928 aColor := aButton colorToUse. 427929 c := aColor twiceLighter whiter. 427930 ^(GradientFillStyle ramp: { 427931 0.0->c darker duller. 0.2->c darker. 427932 0.8->c twiceLighter. 1.0->Color white}) 427933 origin: aButton bounds origin; 427934 direction: 0 @ aButton height; 427935 radial: false! ! 427936 427937!UIThemeSoftSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 17:01'! 427938buttonSelectedFillStyleFor: aButton 427939 "Return the button selected fillStyle for the given color." 427940 427941 |aColor| 427942 aColor := aButton colorToUse. 427943 ^(GradientFillStyle ramp: { 427944 0.0->aColor darker duller. 0.2->aColor darker. 427945 0.8->aColor twiceLighter. 1.0->Color white}) 427946 origin: aButton bounds origin; 427947 direction: 0 @ aButton height; 427948 radial: false! ! 427949 427950!UIThemeSoftSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 17:01'! 427951buttonSelectedMouseOverFillStyleFor: aButton 427952 "Return the button selected mouse over fillStyle for the given color." 427953 427954 |aColor c| 427955 aColor := aButton colorToUse. 427956 c := aColor luminance > 0.3 427957 ifTrue: [aColor blacker] 427958 ifFalse: [aColor whiter]. 427959 ^(GradientFillStyle ramp: { 427960 0.0->c darker duller. 0.2->c darker. 427961 0.8->c twiceLighter. 1.0->Color white}) 427962 origin: aButton bounds origin; 427963 direction: 0 @ aButton height; 427964 radial: false! ! 427965 427966!UIThemeSoftSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 17:01'! 427967buttonSelectedPressedFillStyleFor: aButton 427968 "Return the button selected pressed fillStyle for the given color." 427969 427970 |aColor c| 427971 aColor := aButton colorToUse. 427972 c := aColor luminance > 0.3 427973 ifTrue: [aColor blacker] 427974 ifFalse: [aColor whiter]. 427975 ^(GradientFillStyle ramp: { 427976 0.0->Color white. 0.2->c twiceLighter. 427977 0.8->c darker. 1.0->c darker duller}) 427978 origin: aButton bounds origin; 427979 direction: 0 @ aButton height; 427980 radial: false! ! 427981 427982!UIThemeSoftSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 5/23/2007 12:17'! 427983checkboxButtonDisabledFillStyleFor: aCheckboxButton 427984 "Return the disabled checkbox button fillStyle for the given button." 427985 427986 |c| 427987 c := aCheckboxButton colorToUse 427988 alphaMixed: 0.3 427989 with: Color white. 427990 ^(GradientFillStyle ramp: { 427991 0.0->c darker duller. 427992 0.2->c darker. 427993 0.8->c twiceLighter. 427994 1.0->c}) 427995 origin: aCheckboxButton bounds origin; 427996 direction: 0 @ aCheckboxButton height; 427997 radial: false! ! 427998 427999!UIThemeSoftSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 5/23/2007 12:12'! 428000checkboxButtonNormalFillStyleFor: aCheckboxButton 428001 "Return the normal checkbox button fillStyle for the given button." 428002 428003 |c| 428004 c := aCheckboxButton colorToUse 428005 alphaMixed: 0.1 428006 with: Color white. 428007 ^(GradientFillStyle ramp: { 428008 0.0->c darker duller. 428009 0.2->c darker. 428010 0.8->c twiceLighter. 428011 1.0->c}) 428012 origin: aCheckboxButton bounds origin; 428013 direction: 0 @ aCheckboxButton height; 428014 radial: false! ! 428015 428016!UIThemeSoftSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 6/4/2007 12:57'! 428017menuItemInDockingBarSelectedFillStyleFor: aMenuItem 428018 "Answer the selected fill style to use for the given menu item that is in a docking bar." 428019 428020 |c fill| 428021 Display depth <= 2 ifTrue: [^ Color gray]. 428022 c := aMenuItem owner color isTransparent 428023 ifTrue: [aMenuItem paneColor darker] 428024 ifFalse: [aMenuItem owner color darker]. 428025 fill := GradientFillStyle ramp: { 428026 0.0->Color white. 428027 0.2->c lighter. 428028 1.0->Color white}. 428029 fill origin: aMenuItem topLeft. 428030 aMenuItem owner isVertical 428031 ifTrue: [fill direction: aMenuItem width @ 0] 428032 ifFalse: [fill direction: 0 @ aMenuItem height]. 428033 ^ fill! ! 428034 428035!UIThemeSoftSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 6/4/2007 13:06'! 428036menuItemSelectedFillStyleFor: aMenuItem 428037 "Answer the selected fill style to use for the given menu item." 428038 428039 |c| 428040 Display depth <= 2 ifTrue: [^ Color gray]. 428041 c := aMenuItem owner color isTransparent 428042 ifTrue: [aMenuItem paneColor darker] 428043 ifFalse: [aMenuItem owner color darker]. 428044 ^(GradientFillStyle ramp: { 428045 0.0->Color white. 428046 0.2->c twiceLighter. 428047 0.8->c darker. 428048 1.0->c darker duller}) 428049 origin: aMenuItem topLeft; 428050 direction: 0 @ aMenuItem height! ! 428051 428052 428053!UIThemeSoftSqueak methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 4/25/2007 16:59'! 428054scrollbarNormalThumbFillStyleFor: aScrollbar 428055 "Return the normal scrollbar thumb fillStyle for the given scrollbar." 428056 428057 |aColor| 428058 aColor := self scrollbarColorFor: aScrollbar. 428059 ^(GradientFillStyle ramp: { 428060 0.0->Color white. 0.2-> aColor twiceLighter. 428061 0.8->aColor darker. 1.0->aColor darker duller}) 428062 origin: aScrollbar topLeft; 428063 direction: (aScrollbar bounds isWide 428064 ifTrue: [0 @ aScrollbar height] 428065 ifFalse: [aScrollbar width @ 0]); 428066 radial: false! ! 428067 428068!UIThemeSoftSqueak methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 4/25/2007 16:59'! 428069scrollbarPressedThumbFillStyleFor: aScrollbar 428070 "Return the pressed scrollbar thumb fillStyle for the given scrollbar." 428071 428072 |aColor| 428073 aColor := self scrollbarColorFor: aScrollbar. 428074 ^(GradientFillStyle ramp: { 428075 0.0->aColor darker duller. 0.2-> aColor darker. 428076 0.8->aColor twiceLighter. 1.0->Color white}) 428077 origin: aScrollbar topLeft; 428078 direction: (aScrollbar bounds isWide 428079 ifTrue: [0 @ aScrollbar height] 428080 ifFalse: [aScrollbar width @ 0]); 428081 radial: false! ! 428082 428083 428084!UIThemeSoftSqueak methodsFor: 'label-styles' stamp: 'gvc 10/17/2008 12:19'! 428085disabledItemStyle 428086 "Answer either #plain or #inset to determine how 428087 diabled text is drawn." 428088 428089 ^#inset! ! 428090 428091!UIThemeSoftSqueak methodsFor: 'label-styles' stamp: 'gvc 5/7/2007 12:49'! 428092windowLabelForText: aStringOrText 428093 "Answer the window label to use for the given text." 428094 428095 ^StringMorph new 428096 contents: aStringOrText; 428097 font: Preferences windowTitleFont emphasis: 1; 428098 shadowColor: Color white; 428099 shadowOffset: 1@1; 428100 hasDropShadow: true.! ! 428101 428102 428103!UIThemeSoftSqueak methodsFor: 'morph creation' stamp: 'gvc 5/15/2007 17:42'! 428104newDialogPanelIn: aThemedMorph 428105 "Answer a new (main) dialog panel." 428106 428107 ^(super 428108 newDialogPanelIn: aThemedMorph) 428109 roundedCorners: #(2 3) "only bottom edge"! ! 428110 428111!UIThemeSoftSqueak methodsFor: 'morph creation' stamp: 'gvc 8/7/2007 12:05'! 428112newLabelIn: aThemedMorph for: aModel label: aString getEnabled: enabledSel 428113 "Answer a new text label." 428114 428115 ^(super newLabelIn: aThemedMorph for: aModel label: aString getEnabled: enabledSel) 428116 disabledStyle: #inset! ! 428117 428118"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 428119 428120UIThemeSoftSqueak class 428121 instanceVariableNames: ''! 428122 428123!UIThemeSoftSqueak class methodsFor: 'as yet unclassified' stamp: 'gvc 6/22/2007 14:25'! 428124isAbstract 428125 "Answer whether the receiver is considered to be abstract." 428126 428127 ^false! ! 428128 428129!UIThemeSoftSqueak class methodsFor: 'as yet unclassified' stamp: 'gvc 6/22/2007 15:18'! 428130themeName 428131 "Answer the friendly name of the theme." 428132 428133 ^'Soft Squeak'! ! 428134UITheme subclass: #UIThemeStandardSqueak 428135 instanceVariableNames: '' 428136 classVariableNames: '' 428137 poolDictionaries: '' 428138 category: 'Polymorph-Widgets-Themes'! 428139!UIThemeStandardSqueak commentStamp: 'gvc 5/18/2007 10:04' prior: 0! 428140A UI theme that tries to make things look like a standard (3.9) Squeak image. Do UIThemeStandardSqueak beCurrent to use.! 428141 428142 428143!UIThemeStandardSqueak methodsFor: 'border-styles' stamp: 'gvc 2/9/2009 17:10'! 428144configureWindowDropShadowFor: aWindow 428145 "Configure the drop shadow for the given window." 428146 428147 Preferences menuAppearance3d 428148 ifTrue: [super configureWindowDropShadowFor: aWindow]! ! 428149 428150!UIThemeStandardSqueak methodsFor: 'border-styles' stamp: 'gvc 9/2/2009 11:50'! 428151drawTextAdornmentsFor: aPluggableTextMorph on: aCanvas 428152 "Indicate edit status for the given morph. 428153 Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" 428154 428155 aPluggableTextMorph wantsFrameAdornments ifTrue: 428156 [(aPluggableTextMorph model notNil and: [aPluggableTextMorph model refusesToAcceptCode]) 428157 ifTrue: "Put up feedback showing that code cannot be submitted in this state" 428158 [aCanvas frameRectangle: aPluggableTextMorph innerBounds width: 2 color: Color tan] 428159 ifFalse: 428160 [aPluggableTextMorph hasEditingConflicts 428161 ifTrue: 428162 [aCanvas frameRectangle: aPluggableTextMorph innerBounds width: 3 color: Color red] 428163 ifFalse: 428164 [aPluggableTextMorph hasUnacceptedEdits 428165 ifTrue: 428166 [aPluggableTextMorph model wantsDiffFeedback 428167 ifTrue: 428168 [aCanvas frameRectangle: aPluggableTextMorph innerBounds width: 3 color: Color green] 428169 ifFalse: 428170 [aCanvas frameRectangle: aPluggableTextMorph innerBounds width: 1 color: Color red]] 428171 ifFalse: 428172 [aPluggableTextMorph model wantsDiffFeedback 428173 ifTrue: 428174 [aCanvas frameRectangle: aPluggableTextMorph innerBounds width: 1 color: Color green]]]]]! ! 428175 428176!UIThemeStandardSqueak methodsFor: 'border-styles' stamp: 'gvc 2/10/2009 13:37'! 428177drawWindowDropShadowFor: aSystemWindow on: aCanvas 428178 "Draw the drop shadow for the given window." 428179 428180 aCanvas 428181 translateBy: aSystemWindow shadowOffset 428182 during: [ :shadowCanvas | 428183 shadowCanvas shadowColor: aSystemWindow shadowColor. 428184 shadowCanvas roundCornersOf: aSystemWindow during: [ 428185 (shadowCanvas isVisible: aSystemWindow bounds) ifTrue: [ 428186 shadowCanvas drawMorph: aSystemWindow]]] 428187! ! 428188 428189!UIThemeStandardSqueak methodsFor: 'border-styles' stamp: 'gvc 4/25/2007 17:19'! 428190progressBarBorderStyleFor: aProgressBar 428191 "Return the progress bar borderStyle for the given progress bar." 428192 428193 ^BorderStyle simple 428194 width: 1; 428195 baseColor: Preferences menuBorderColor! ! 428196 428197!UIThemeStandardSqueak methodsFor: 'border-styles' stamp: 'gvc 4/25/2007 17:21'! 428198taskbarThumbnailNormalBorderStyleFor: aWindow 428199 "Return the normal thumbnail borderStyle for the given button." 428200 428201 ^BorderStyle simple 428202 width: 1; 428203 baseColor: Preferences menuBorderColor! ! 428204 428205 428206!UIThemeStandardSqueak methodsFor: 'border-styles-buttons' stamp: 'gvc 5/15/2007 17:54'! 428207buttonNormalBorderStyleFor: aButton 428208 "Return the normal button borderStyle for the given button." 428209 428210 ^aButton borderStyle isComposite 428211 ifTrue: [aButton borderStyle borders first] 428212 ifFalse: [aButton borderStyle]! ! 428213 428214!UIThemeStandardSqueak methodsFor: 'border-styles-buttons' stamp: 'gvc 5/15/2007 17:55'! 428215buttonPressedBorderStyleFor: aButton 428216 "Return the pressed button borderStyle for the given button." 428217 428218 aButton borderStyle isComposite 428219 ifTrue: [^aButton borderStyle]. 428220 ^(CompositeBorder new width: 1) 428221 borders: {aButton borderStyle. 428222 BorderStyle simple 428223 color: Color red; 428224 width: 2}! ! 428225 428226!UIThemeStandardSqueak methodsFor: 'border-styles-buttons' stamp: 'gvc 5/15/2007 17:53'! 428227buttonSelectedPressedBorderStyleFor: aButton 428228 "Return the selected pressed button borderStyle for the given button." 428229 428230 aButton borderStyle isComposite 428231 ifTrue: [^aButton borderStyle]. 428232 ^(CompositeBorder new width: 1) 428233 borders: {aButton borderStyle. 428234 BorderStyle simple 428235 color: Color red; 428236 width: 2}! ! 428237 428238 428239!UIThemeStandardSqueak methodsFor: 'border-styles-scrollbars' stamp: 'gvc 4/25/2007 17:16'! 428240scrollbarNormalThumbBorderStyleFor: aScrollbar 428241 "Return the normal thumb borderStyle for the given scrollbar." 428242 428243 ^BorderStyle simple 428244 width: 1; 428245 baseColor: Color lightGray! ! 428246 428247!UIThemeStandardSqueak methodsFor: 'border-styles-scrollbars' stamp: 'gvc 6/4/2007 16:36'! 428248scrollbarPressedButtonBorderStyleFor: aScrollbar 428249 "Return the pressed button borderStyle for the given scrollbar." 428250 428251 ^BorderStyle inset 428252 width: 1! ! 428253 428254 428255!UIThemeStandardSqueak methodsFor: 'defaults' stamp: 'gvc 2/9/2009 17:12'! 428256windowShadowColor 428257 "Answer the window shadow color to use." 428258 428259 ^Color black alpha: 0.333! ! 428260 428261 428262!UIThemeStandardSqueak methodsFor: 'fill-styles' stamp: 'gvc 4/26/2007 09:54'! 428263dialogWindowActiveFillStyleFor: aWindow 428264 "Return the dialog window active fillStyle for the given window." 428265 428266 ^self windowActiveFillStyleFor: aWindow! ! 428267 428268!UIThemeStandardSqueak methodsFor: 'fill-styles' stamp: 'gvc 4/26/2007 09:54'! 428269dialogWindowInactiveFillStyleFor: aWindow 428270 "Return the dialog window inactive fillStyle for the given window." 428271 428272 ^self windowInactiveFillStyleFor: aWindow! ! 428273 428274!UIThemeStandardSqueak methodsFor: 'fill-styles' stamp: 'gvc 10/16/2008 16:27'! 428275menuColorFor: aThemedMorph 428276 "Answer the menu color to use." 428277 428278 ^self defaultMenuColor! ! 428279 428280!UIThemeStandardSqueak methodsFor: 'fill-styles' stamp: 'gvc 10/16/2008 16:27'! 428281menuTitleColorFor: aThemedMorph 428282 "Answer the menu title color to use." 428283 428284 ^self defaultMenuTitleColor! ! 428285 428286!UIThemeStandardSqueak methodsFor: 'fill-styles' stamp: 'gvc 6/4/2007 14:25'! 428287progressBarFillStyleFor: aProgressBar 428288 "Return the progress bar fillStyle for the given progress bar." 428289 428290 ^self progressBarColorFor: aProgressBar! ! 428291 428292!UIThemeStandardSqueak methodsFor: 'fill-styles' stamp: 'gvc 6/4/2007 14:24'! 428293progressBarProgressFillStyleFor: aProgressBar 428294 "Return the progress bar progress fillStyle for the given progress bar." 428295 428296 ^self progressBarProgressColorFor: aProgressBar! ! 428297 428298!UIThemeStandardSqueak methodsFor: 'fill-styles' stamp: 'gvc 4/26/2007 10:19'! 428299splitterNormalFillStyleFor: aSplitter 428300 "Return the normal splitter fillStyle for the given splitter." 428301 428302 ^aSplitter getOldColor! ! 428303 428304!UIThemeStandardSqueak methodsFor: 'fill-styles' stamp: 'gvc 4/26/2007 10:19'! 428305splitterPressedFillStyleFor: aSplitter 428306 "Return the pressed splitter fillStyle for the given splitter." 428307 428308 ^Color black! ! 428309 428310!UIThemeStandardSqueak methodsFor: 'fill-styles' stamp: 'gvc 4/26/2007 09:41'! 428311taskbarFillStyleFor: aTaskbar 428312 "Return the taskbar fillStyle for the given taskbar." 428313 428314 ^Preferences menuColor! ! 428315 428316!UIThemeStandardSqueak methodsFor: 'fill-styles' stamp: 'gvc 4/26/2007 09:41'! 428317tasklistFillStyleFor: aTasklist 428318 "Return the tasklist fillStyle for the given tasklist." 428319 428320 ^Preferences menuColor! ! 428321 428322!UIThemeStandardSqueak methodsFor: 'fill-styles' stamp: 'gvc 5/22/2007 11:04'! 428323windowActiveFillStyleFor: aWindow 428324 "Return the window active fillStyle for the given window." 428325 428326 ^aWindow 428327 gradientWithColor: aWindow paneColorToUse lighter lighter lighter! ! 428328 428329!UIThemeStandardSqueak methodsFor: 'fill-styles' stamp: 'gvc 5/22/2007 11:04'! 428330windowInactiveFillStyleFor: aWindow 428331 "Return the window inactive fillStyle for the given window." 428332 428333 ^aWindow 428334 gradientWithColor: aWindow paneColorToUse duller! ! 428335 428336!UIThemeStandardSqueak methodsFor: 'fill-styles' stamp: 'gvc 4/26/2007 15:56'! 428337worldMainDockingBarNormalFillStyleFor: aDockingBar 428338 "Return the world main docking bar fillStyle for the given docking bar." 428339 428340 |aColor| 428341 aColor := aDockingBar originalColor. 428342 ^(GradientFillStyle ramp: {0.0 -> aColor muchLighter. 1.0 -> aColor twiceDarker}) 428343 origin: aDockingBar topLeft; 428344 direction: (aDockingBar isVertical 428345 ifTrue: [aDockingBar width @ 0] 428346 ifFalse: [0 @ aDockingBar height]); 428347 radial: false! ! 428348 428349 428350!UIThemeStandardSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/26/2007 09:58'! 428351buttonDisabledFillStyleFor: aButton 428352 "Return the disabled button fillStyle for the given color." 428353 428354 ^aButton offColor 428355 ifNil: [Color darkGray] 428356 ifNotNil: [aButton offColor muchDarker]! ! 428357 428358!UIThemeStandardSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 18:30'! 428359buttonMouseOverFillStyleFor: aButton 428360 "Return the button mouse over fillStyle for the given color." 428361 428362 ^(self buttonNormalFillStyleFor: aButton) adjustBrightness: -0.09375! ! 428363 428364!UIThemeStandardSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 5/15/2007 17:44'! 428365buttonNormalFillStyleFor: aButton 428366 "Return the normal button fillStyle for the given button." 428367 428368 ^aButton offColor 428369 ifNil: [Color transparent] 428370 ifNotNil: [aButton offColor]! ! 428371 428372!UIThemeStandardSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 18:37'! 428373buttonPanelNormalFillStyleFor: aPanel 428374 "Return the normal panel fillStyle for the given panel." 428375 428376 ^Color white! ! 428377 428378!UIThemeStandardSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 18:48'! 428379buttonSelectedFillStyleFor: aButton 428380 "Return the button selected fillStyle for the given color." 428381 428382 ^aButton onColor 428383 ifNil: [Color white darker darker] 428384 ifNotNil: [aButton onColor]! ! 428385 428386!UIThemeStandardSqueak methodsFor: 'fill-styles-buttons' stamp: 'gvc 4/25/2007 18:49'! 428387buttonSelectedMouseOverFillStyleFor: aButton 428388 "Return the button selected mouse over fillStyle for the given color." 428389 428390 ^(self buttonSelectedFillStyleFor: aButton) adjustBrightness: -0.09375! ! 428391 428392 428393!UIThemeStandardSqueak methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 4/26/2007 14:26'! 428394scrollbarImageColorFor: aScrollbar 428395 "Return the scrollbar image colour (on buttons) for the given scrollbar." 428396 428397 ^((self scrollbarColorFor: aScrollbar) 428398 alphaMixed: 0.5 with: (Color gray: 0.95)) twiceDarker darker! ! 428399 428400!UIThemeStandardSqueak methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 4/25/2007 18:58'! 428401scrollbarNormalFillStyleFor: aScrollbar 428402 "Return the normal scrollbar fillStyle for the given scrollbar." 428403 428404 ^aScrollbar sliderColor alphaMixed: 0.3 with: Color white! ! 428405 428406!UIThemeStandardSqueak methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 4/26/2007 14:04'! 428407scrollbarNormalThumbFillStyleFor: aScrollbar 428408 "Return the normal scrollbar thumb fillStyle for the given scrollbar." 428409 428410 ^aScrollbar sliderColor 428411 alphaMixed: 0.5 with: (Color gray: 0.95)! ! 428412 428413 428414!UIThemeStandardSqueak methodsFor: 'icons' stamp: 'gvc 5/22/2007 10:45'! 428415smallDebugIcon 428416 "Answer a small debug icon." 428417 428418 ^MenuIcons smallDebugIcon! ! 428419 428420 428421!UIThemeStandardSqueak methodsFor: 'initialize-release' stamp: 'gvc 5/14/2007 11:43'! 428422newTreeExpandedForm 428423 "Answer a new form for an expanded tree item." 428424 428425 ^(Form 428426 extent: 10@9 428427 depth: 8 428428 fromArray: #( 4294967295 4294967295 4294901760 4294967295 4294967295 4294901760 4278255873 16843009 16842752 4294902089 1229539657 33488896 4294967041 1229539585 4294901760 4294967295 21561855 4294901760 4294967295 4278321151 4294901760 4294967295 4294967295 4294901760 4294967295 4294967295 4294901760) 428429 offset: 0@0) 428430 asFormOfDepth: Display depth; 428431 replaceColor: Color white withColor: Color transparent; 428432 yourself! ! 428433 428434!UIThemeStandardSqueak methodsFor: 'initialize-release' stamp: 'gvc 5/14/2007 11:43'! 428435newTreeUnexpandedForm 428436 "Answer a new form for an unexpanded tree item." 428437 428438 ^(Form 428439 extent: 10@9 428440 depth: 8 428441 fromArray: #( 4294967041 4294967295 4294901760 4294967041 33554431 4294901760 4294967041 1224867839 4294901760 4294967041 1229521407 4294901760 4294967041 1229539585 4294901760 4294967041 1229521407 4294901760 4294967041 1224867839 4294901760 4294967041 33554431 4294901760 4294967041 4294967295 4294901760) 428442 offset: 0@0) 428443 asFormOfDepth: Display depth; 428444 replaceColor: Color white withColor: Color transparent; 428445 yourself! ! 428446 428447 428448!UIThemeStandardSqueak methodsFor: 'label-styles' stamp: 'gvc 3/6/2009 13:30'! 428449menuPinForm 428450 "Answer the form to use for the pin button of a menu." 428451 428452 ^MenuMorph pushPinImage! ! 428453 428454!UIThemeStandardSqueak methodsFor: 'label-styles' stamp: 'gvc 5/25/2007 10:02'! 428455windowMenuIconFor: aWindow 428456 "Answer the menu icon for the given window." 428457 428458 ^self windowMenuForm! ! 428459 428460 428461!UIThemeStandardSqueak methodsFor: 'morph creation' stamp: 'gvc 1/30/2009 14:23'! 428462newBalloonHelpIn: aThemedMorph contents: aTextStringOrMorph for: aMorph corner: cornerSymbol 428463 "Answer a new balloon help morph with the given text 428464 and positioning for aMorph." 428465 428466 ^BalloonMorph 428467 string: aTextStringOrMorph 428468 for: aMorph 428469 corner: cornerSymbol! ! 428470 428471"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 428472 428473UIThemeStandardSqueak class 428474 instanceVariableNames: ''! 428475 428476!UIThemeStandardSqueak class methodsFor: 'as yet unclassified' stamp: 'gvc 6/22/2007 14:26'! 428477isAbstract 428478 "Answer whether the receiver is considered to be abstract." 428479 428480 ^false! ! 428481 428482!UIThemeStandardSqueak class methodsFor: 'as yet unclassified' stamp: 'gvc 6/22/2007 15:19'! 428483themeName 428484 "Answer the friendly name of the theme." 428485 428486 ^'Standard Squeak'! ! 428487UITheme subclass: #UIThemeVistary 428488 instanceVariableNames: '' 428489 classVariableNames: '' 428490 poolDictionaries: '' 428491 category: 'Polymorph-Widgets-Themes'! 428492!UIThemeVistary commentStamp: 'gvc 5/18/2007 10:02' prior: 0! 428493A Vista-style UI theme. Do UIThemeVistary beCurrent to use.! 428494 428495 428496!UIThemeVistary methodsFor: 'basic-colors' stamp: 'gvc 1/16/2008 13:38'! 428497subgroupColorFrom: paneColor 428498 "Answer the colour for a subgroup given the pane colour." 428499 428500 ^paneColor! ! 428501 428502!UIThemeVistary methodsFor: 'basic-colors' stamp: 'gvc 5/9/2007 15:21'! 428503taskbarActiveButtonColorFor: aButton 428504 "Answer the colour for the given active taskbar button." 428505 428506 ^self selectionColor! ! 428507 428508!UIThemeVistary methodsFor: 'basic-colors' stamp: 'gvc 5/9/2007 15:19'! 428509taskbarButtonColorFor: aButton 428510 "Answer the colour for the given taskbar button." 428511 428512 ^Color black! ! 428513 428514!UIThemeVistary methodsFor: 'basic-colors' stamp: 'gvc 5/9/2007 15:20'! 428515taskbarButtonLabelColorFor: aButton 428516 "Answer the colour for the label of the given taskbar button." 428517 428518 ^Color white! ! 428519 428520!UIThemeVistary methodsFor: 'basic-colors' stamp: 'gvc 5/9/2007 15:20'! 428521taskbarMinimizedButtonColorFor: aButton 428522 "Answer the colour for the given minimized taskbar button." 428523 428524 ^Color darkGray! ! 428525 428526!UIThemeVistary methodsFor: 'basic-colors' stamp: 'gvc 10/9/2007 15:01'! 428527windowFillStyleAlpha 428528 "Answer the alpha value for the window background." 428529 428530 ^0.6! ! 428531 428532!UIThemeVistary methodsFor: 'basic-colors' stamp: 'gvc 5/13/2008 15:14'! 428533worldMainDockingBarColorFor: aDockingBar 428534 "Answer the base colour to use for a world main docking bar in this theme." 428535 428536 ^(Color r: 0.607 g: 0.694 b: 0.066) alpha: 0.3! ! 428537 428538 428539!UIThemeVistary methodsFor: 'border-styles' stamp: 'gvc 1/25/2008 14:44'! 428540groupLabelBorderStyleFor: aGroupPanel 428541 "Answer the normal border style for a group label." 428542 428543 ^BorderStyle simple 428544 width: 1; 428545 baseColor: (aGroupPanel paneColor lighter alphaMixed: 0.8 with: Color black)! ! 428546 428547!UIThemeVistary methodsFor: 'border-styles' stamp: 'gvc 1/25/2008 14:38'! 428548groupPanelBorderStyleFor: aGroupPanel 428549 "Answer the normal border style for a group panel." 428550 428551 ^TabPanelBorder new 428552 width: 1; 428553 baseColor: (aGroupPanel paneColor lighter alphaMixed: 0.8 with: Color black); 428554 tabSelector: aGroupPanel! ! 428555 428556!UIThemeVistary methodsFor: 'border-styles' stamp: 'gvc 1/17/2008 11:45'! 428557plainGroupPanelBorderStyleFor: aGroupPanel 428558 "Answer the normal border style for a plain group panel." 428559 428560 ^BorderStyle simple 428561 width: 1; 428562 baseColor: (aGroupPanel paneColor lighter alphaMixed: 0.8 with: Color black)! ! 428563 428564!UIThemeVistary methodsFor: 'border-styles' stamp: 'gvc 2/29/2008 21:32'! 428565progressBarBorderStyleFor: aProgressBar 428566 "Return the progress bar borderStyle for the given progress bar." 428567 428568 |pc mc ic| 428569 pc := self progressBarColorFor: aProgressBar. 428570 mc := pc alphaMixed: 0.7 with: Color black. 428571 ic := Color white alpha: 0.3. 428572 ^(CompositeBorder new width: 1) 428573 borders: {RoundedBorder new 428574 cornerRadius: 1; 428575 width: 1; 428576 baseColor: mc. 428577 BorderStyle simple 428578 width: 1; 428579 baseColor: ic}! ! 428580 428581!UIThemeVistary methodsFor: 'border-styles' stamp: 'gvc 1/17/2008 11:29'! 428582tabGroupCornerStyleIn: aThemedMorph 428583 "Allow for themes to override default behaviour." 428584 428585 ^#square! ! 428586 428587!UIThemeVistary methodsFor: 'border-styles' stamp: 'gvc 1/17/2008 10:42'! 428588tabLabelNormalBorderStyleFor: aTabLabel 428589 "Answer the normal border style for a tab label." 428590 428591 |pc mc ic| 428592 pc := aTabLabel paneColor lighter. 428593 mc := pc alphaMixed: 0.8 with: Color black. 428594 ic := Color white alpha: 0.3. 428595 ^(CompositeBorder new width: 1) 428596 borders: {BorderStyle simple 428597 width: 1; 428598 baseColor: mc. 428599 BorderStyle simple 428600 width: 1; 428601 baseColor: ic}! ! 428602 428603!UIThemeVistary methodsFor: 'border-styles' stamp: 'gvc 1/17/2008 10:43'! 428604tabLabelSelectedBorderStyleFor: aTabLabel 428605 "Answer the selected border style for a tab label." 428606 428607 ^BorderStyle simple 428608 width: 1; 428609 baseColor: (aTabLabel paneColor lighter alphaMixed: 0.8 with: Color black)! ! 428610 428611!UIThemeVistary methodsFor: 'border-styles' stamp: 'gvc 1/17/2008 10:43'! 428612tabPanelBorderStyleFor: aTabGroup 428613 "Answer the normal border style for a tab group." 428614 428615 ^TabPanelBorder new 428616 width: 1; 428617 baseColor: (aTabGroup paneColor lighter alphaMixed: 0.8 with: Color black); 428618 tabSelector: aTabGroup tabSelectorMorph! ! 428619 428620!UIThemeVistary methodsFor: 'border-styles' stamp: 'gvc 3/2/2009 12:27'! 428621taskbarThumbnailCornerStyleFor: aMorph 428622 "Answer the corner style for the taskbar thumbnail/tasklist." 428623 428624 ^#square! ! 428625 428626!UIThemeVistary methodsFor: 'border-styles' stamp: 'gvc 2/23/2008 16:54'! 428627taskbarThumbnailNormalBorderStyleFor: aWindow 428628 "Return the normal thumbnail borderStyle for the given button." 428629 428630 |pc oc mc ic| 428631 pc := self windowColorFor: aWindow. 428632 oc := (pc alphaMixed: 0.4 with: Color white) alpha: 0.4. 428633 mc := pc alphaMixed: 0.7 with: Color black. 428634 ic := Color white alpha: 0.3. 428635 ^(CompositeBorder new width: 2) 428636 borders: {RoundedBorder new 428637 cornerRadius: 2; 428638 width: 1; 428639 baseColor: oc. 428640 RoundedBorder new 428641 cornerRadius: 1; 428642 width: 1; 428643 baseColor: mc. 428644 BorderStyle simple 428645 width: 1; 428646 baseColor: ic}! ! 428647 428648!UIThemeVistary methodsFor: 'border-styles' stamp: 'gvc 5/13/2008 15:15'! 428649worldMainDockingBarBorderStyleFor: aDockingBar 428650 "Return the world main docking bar borderStyle for the given docking bar." 428651 428652 ^BorderStyle simple 428653 width: 0; 428654 color: Color transparent! ! 428655 428656 428657!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 3/14/2007 15:58'! 428658buttonCornerStyleIn: aThemedMorph 428659 "Allow for themes to override default behaviour." 428660 428661 ^#square! ! 428662 428663!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 2/22/2008 17:47'! 428664buttonDisabledBorderStyleFor: aButton 428665 "Return the disabled button borderStyle for the given button." 428666 428667 |pc mc ic| 428668 pc := self buttonColorFor: aButton. 428669 mc := (pc alphaMixed: 0.6 with: Color black) alpha: 0.5. 428670 ic := Color white alpha: 0.3. 428671 ^(CompositeBorder new width: 1) 428672 borders: {RoundedBorder new 428673 cornerRadius: 2; 428674 width: 1; 428675 baseColor: mc. 428676 RoundedBorder new 428677 cornerRadius: 1; 428678 width: 1; 428679 baseColor: ic}! ! 428680 428681!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 2/22/2008 17:47'! 428682buttonMouseOverBorderStyleFor: aButton 428683 "Return the mouse over button borderStyle for the given button." 428684 428685 |pc mc ic selcol| 428686 pc := self buttonColorFor: aButton. 428687 selcol := (self selectionColor adjustSaturation: 0.3 brightness: 0.5). 428688 mc := pc alphaMixed: 0.4 with: (Color black alphaMixed: 0.3 with: selcol). 428689 ic := (Color white alphaMixed: 0.7 with: selcol) alpha: 0.3. 428690 ^(CompositeBorder new width: 1) 428691 borders: {RoundedBorder new 428692 cornerRadius: 2; 428693 width: 1; 428694 baseColor: mc. 428695 RoundedBorder new 428696 cornerRadius: 1; 428697 width: 1; 428698 baseColor: ic}! ! 428699 428700!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 2/22/2008 21:32'! 428701buttonNormalBorderStyleFor: aButton 428702 "Return the normal button borderStyle for the given button." 428703 428704 |pc mc ic| 428705 pc := self buttonColorFor: aButton. 428706 mc := aButton isDefault 428707 ifTrue: [self defaultButtonBorderColor] 428708 ifFalse: [pc alphaMixed: 0.7 with: Color black]. 428709 ic := aButton isDefault 428710 ifTrue: [self defaultButtonBorderColor alpha: 0.5] 428711 ifFalse: [Color white alpha: 0.3]. 428712 ^(CompositeBorder new width: 1) 428713 borders: {RoundedBorder new 428714 cornerRadius: 2; 428715 width: 1; 428716 baseColor: mc. 428717 RoundedBorder new 428718 cornerRadius: 1; 428719 width: 1; 428720 baseColor: ic}! ! 428721 428722!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 2/22/2008 17:47'! 428723buttonSelectedBorderStyleFor: aButton 428724 "Return the selected borderStyle for the given button." 428725 428726 |pc mc ic selcol| 428727 pc := self buttonColorFor: aButton. 428728 selcol := (self selectionColor adjustSaturation: 0.3 brightness: 0.5). 428729 mc := pc alphaMixed: 0.4 with: (Color black alphaMixed: 0.2 with: selcol). 428730 ic := (Color white alphaMixed: 0.6 with: selcol) alpha: 0.3. 428731 ^(CompositeBorder new width: 1) 428732 borders: {RoundedBorder new 428733 cornerRadius: 2; 428734 width: 1; 428735 baseColor: mc. 428736 RoundedBorder new 428737 cornerRadius: 1; 428738 width: 1; 428739 baseColor: ic}! ! 428740 428741!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 4/30/2007 15:10'! 428742buttonSelectedMouseOverBorderStyleFor: aButton 428743 "Return the selected mouse over button borderStyle for the given button." 428744 428745 ^self buttonMouseOverBorderStyleFor: aButton! ! 428746 428747!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 2/22/2008 21:50'! 428748checkboxButtonDisabledBorderStyleFor: aCheckboxButton 428749 "Return the disabled checkbox button borderStyle for the given button." 428750 428751 |pc oc mc ic| 428752 pc := aCheckboxButton paneColor lighter. 428753 oc := pc twiceDarker. 428754 mc := (pc alphaMixed: 0.4 with: Color white). 428755 ic := pc lighter. 428756 ^(CompositeBorder new width: 2) 428757 borders: {BorderStyle simple 428758 width: 1; 428759 baseColor: oc. 428760 BorderStyle simple 428761 width: 1; 428762 baseColor: mc. 428763 BorderStyle inset 428764 width: 1; 428765 baseColor: ic}! ! 428766 428767!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 9/5/2007 13:40'! 428768checkboxButtonNormalBorderStyleFor: aCheckboxButton 428769 "Return the normal checkbox button borderStyle for the given button." 428770 428771 |pc oc mc ic| 428772 pc := self buttonColorFor: aCheckboxButton. 428773 oc := pc twiceDarker. 428774 mc := (pc alphaMixed: 0.4 with: Color white). 428775 ic := pc lighter. 428776 ^(CompositeBorder new width: 2) 428777 borders: {BorderStyle simple 428778 width: 1; 428779 baseColor: oc. 428780 BorderStyle simple 428781 width: 1; 428782 baseColor: mc. 428783 BorderStyle inset 428784 width: 1; 428785 baseColor: ic}! ! 428786 428787!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 2/21/2008 15:11'! 428788controlButtonDisabledBorderStyleFor: aButton 428789 "Return the disabled button borderStyle for the given control button." 428790 428791 |pc mc ic| 428792 pc := self buttonColorFor: aButton. 428793 mc := (pc alphaMixed: 0.6 with: Color black) alpha: 0.5. 428794 ic := Color white alpha: 0.3. 428795 ^(CompositeBorder new width: 1) 428796 borders: {BorderStyle simple 428797 width: 1; 428798 baseColor: mc. 428799 BorderStyle simple 428800 width: 1; 428801 baseColor: ic}! ! 428802 428803!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 2/21/2008 15:11'! 428804controlButtonMouseOverBorderStyleFor: aButton 428805 "Return the mouse over button borderStyle for the given control button." 428806 428807 |pc mc ic selcol| 428808 pc := self buttonColorFor: aButton. 428809 selcol := (self selectionColor adjustSaturation: 0.3 brightness: 0.5). 428810 mc := pc alphaMixed: 0.4 with: (Color black alphaMixed: 0.3 with: selcol). 428811 ic := (Color white alphaMixed: 0.7 with: selcol) alpha: 0.3. 428812 ^(CompositeBorder new width: 1) 428813 borders: {BorderStyle simple 428814 width: 1; 428815 baseColor: mc. 428816 BorderStyle simple 428817 width: 1; 428818 baseColor: ic}! ! 428819 428820!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 2/21/2008 15:10'! 428821controlButtonNormalBorderStyleFor: aButton 428822 "Return the normal button borderStyle for the given control button." 428823 428824 |pc mc ic| 428825 pc := self buttonColorFor: aButton. 428826 mc := pc alphaMixed: 0.7 with: Color black. 428827 ic := Color white alpha: 0.3. 428828 ^(CompositeBorder new width: 1) 428829 borders: {BorderStyle simple 428830 width: 1; 428831 baseColor: mc. 428832 BorderStyle simple 428833 width: 1; 428834 baseColor: ic}! ! 428835 428836!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 2/23/2008 16:25'! 428837controlButtonPressedBorderStyleFor: aButton 428838 "Return the pressed control button borderStyle for the given button. 428839 Control buttons are generally used for drop-lists and expanders." 428840 428841 ^self controlButtonSelectedBorderStyleFor: aButton! ! 428842 428843!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 2/21/2008 15:10'! 428844controlButtonSelectedBorderStyleFor: aButton 428845 "Return the selected borderStyle for the given control button." 428846 428847 |pc mc ic selcol| 428848 pc := self buttonColorFor: aButton. 428849 selcol := (self selectionColor adjustSaturation: 0.3 brightness: 0.5). 428850 mc := pc alphaMixed: 0.4 with: (Color black alphaMixed: 0.2 with: selcol). 428851 ic := (Color white alphaMixed: 0.6 with: selcol) alpha: 0.3. 428852 ^(CompositeBorder new width: 1) 428853 borders: {BorderStyle simple 428854 width: 1; 428855 baseColor: mc. 428856 BorderStyle simple 428857 width: 1; 428858 baseColor: ic}! ! 428859 428860!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 2/22/2008 22:08'! 428861radioButtonDisabledBorderStyleFor: aRadioButton 428862 "Return the disabled radio button borderStyle for the given button." 428863 428864 |pc| 428865 pc := self buttonColorFor: aRadioButton. 428866 ^BorderStyle simple 428867 width: 1; 428868 baseColor: (pc twiceDarker alphaMixed: 0.7 with: Color white).! ! 428869 428870!UIThemeVistary methodsFor: 'border-styles-buttons' stamp: 'gvc 9/5/2007 13:37'! 428871radioButtonNormalBorderStyleFor: aRadioButton 428872 "Return the disabled radio button borderStyle for the given button." 428873 428874 |pc| 428875 pc := self buttonColorFor: aRadioButton. 428876 ^BorderStyle simple 428877 width: 1; 428878 baseColor: pc twiceDarker! ! 428879 428880 428881!UIThemeVistary methodsFor: 'border-styles-scrollbars' stamp: 'gvc 6/4/2007 15:48'! 428882scrollbarMouseOverBarButtonBorderStyleFor: aScrollbar 428883 "Return the button borderStyle for the given scrollbar when 428884 the mouse is over the bar." 428885 428886 ^self scrollbarNormalThumbBorderStyleFor: aScrollbar! ! 428887 428888!UIThemeVistary methodsFor: 'border-styles-scrollbars' stamp: 'gvc 6/4/2007 15:20'! 428889scrollbarMouseOverButtonBorderStyleFor: aScrollbar 428890 "Return the mouse over button borderStyle for the given scrollbar." 428891 428892 ^self scrollbarMouseOverThumbBorderStyleFor: aScrollbar! ! 428893 428894!UIThemeVistary methodsFor: 'border-styles-scrollbars' stamp: 'gvc 2/22/2008 21:01'! 428895scrollbarMouseOverThumbBorderStyleFor: aScrollbar 428896 "Return the mouse over thumb borderStyle for the given scrollbar." 428897 428898 |aColor oc ic| 428899 aColor := self scrollbarColorFor: aScrollbar. 428900 oc := (aColor alphaMixed: 0.2 with: aColor darker) 428901 alphaMixed: 0.6 with: self selectionColor. 428902 ic := Color white alpha: 0.3. 428903 ^(CompositeBorder new width: 1) 428904 borders: {RoundedBorder new 428905 cornerRadius: 1; 428906 width: 1; 428907 baseColor: oc. 428908 BorderStyle simple 428909 width: 1; 428910 baseColor: ic}! ! 428911 428912!UIThemeVistary methodsFor: 'border-styles-scrollbars' stamp: 'gvc 6/4/2007 14:55'! 428913scrollbarNormalButtonBorderStyleFor: aScrollbar 428914 "Return the normal button borderStyle for the given scrollbar." 428915 428916 ^BorderStyle simple 428917 width: 0! ! 428918 428919!UIThemeVistary methodsFor: 'border-styles-scrollbars' stamp: 'gvc 2/22/2008 17:49'! 428920scrollbarNormalThumbBorderStyleFor: aScrollbar 428921 "Return the normal thumb borderStyle for the given scrollbar." 428922 428923 |aColor oc ic| 428924 aColor := self scrollbarColorFor: aScrollbar. 428925 oc := aColor alphaMixed: 0.2 with: aColor darker. 428926 ic := Color white alpha: 0.3. 428927 ^(CompositeBorder new width: 1) 428928 borders: {RoundedBorder new 428929 cornerRadius: 1; 428930 width: 1; 428931 baseColor: oc. 428932 BorderStyle simple 428933 width: 1; 428934 baseColor: ic}! ! 428935 428936 428937!UIThemeVistary methodsFor: 'defaults' stamp: 'gvc 2/22/2008 21:31'! 428938defaultButtonBorderColor 428939 "Answer the color to use for a 'default' button." 428940 428941 ^Color r: 0.005 g: 0.619 b: 0.736! ! 428942 428943!UIThemeVistary methodsFor: 'defaults' stamp: 'gvc 2/23/2008 16:29'! 428944dropListInsetFor: aDropList 428945 "Answer the inset to use for drop-list layout." 428946 428947 ^0! ! 428948 428949!UIThemeVistary methodsFor: 'defaults' stamp: 'gvc 2/23/2008 16:30'! 428950expanderTitleInsetFor: aDropList 428951 "Answer the inset to use for expander title layout." 428952 428953 ^(0@0 corner: -1@0)! ! 428954 428955!UIThemeVistary methodsFor: 'defaults' stamp: 'gvc 9/5/2007 15:11'! 428956treeLineWidth 428957 "Answer the width of the tree lines." 428958 428959 ^0! ! 428960 428961 428962!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 3/14/2007 13:38'! 428963dockingBarNormalFillStyleFor: aToolDockingBar 428964 "Return the normal docking bar fillStyle for the given color." 428965 428966 |aColor c cm cd cb| 428967 aColor := aToolDockingBar originalColor. 428968 c := aColor alphaMixed: 0.7 with: Color white. 428969 cm := aColor alphaMixed: 0.8 with: Color white. 428970 cd := aColor alphaMixed: 0.6 with: Color black. 428971 cb := aColor alphaMixed: 0.7 with: Color white. 428972 ^(GradientFillStyle ramp: {0.0->c. 0.50->cm. 0.51->cd. 1.0->cb}) 428973 origin: aToolDockingBar topLeft; 428974 direction: (aToolDockingBar isVertical 428975 ifTrue: [aToolDockingBar width @ 0] 428976 ifFalse: [0 @ aToolDockingBar height]); 428977 radial: false! ! 428978 428979!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 11:12'! 428980dropListDisabledFillStyleFor: aDropList 428981 "Return the disabled fillStyle for the given drop list." 428982 428983 |c inner| 428984 c := aDropList paneColor alphaMixed: 0.3 with: Color white. 428985 inner := aDropList innerBounds. 428986 ^(GradientFillStyle ramp: { 428987 0.0->c darker duller. 428988 0.1-> c darker. 428989 0.9->c twiceLighter. 428990 1.0->c darker}) 428991 origin: inner topLeft; 428992 direction: 0 @ inner height; 428993 radial: false! ! 428994 428995!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 11:11'! 428996dropListNormalFillStyleFor: aDropList 428997 "Return the normal fillStyle for the given drop list." 428998 428999 |c inner| 429000 c := aDropList paneColor alphaMixed: 0.1 with: Color white. 429001 inner := aDropList innerBounds. 429002 ^(GradientFillStyle ramp: { 429003 0.0->c darker duller. 429004 0.15-> c darker. 429005 0.8->c twiceLighter. 429006 1.0->c darker}) 429007 origin: inner topLeft; 429008 direction: 0 @ inner height; 429009 radial: false! ! 429010 429011!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 11:18'! 429012dropListNormalListFillStyleFor: aDropList 429013 "Return the normal fillStyle for the list of the given drop list." 429014 429015 |c inner| 429016 c := aDropList paneColor alphaMixed: 0.1 with: Color white. 429017 inner := aDropList listMorph innerBounds. 429018 ^(GradientFillStyle ramp: { 429019 0.0->c darker duller. 429020 0.1-> c darker. 429021 0.9->c twiceLighter. 429022 1.0->c darker}) 429023 origin: inner topLeft; 429024 direction: 0 @ inner height; 429025 radial: false! ! 429026 429027!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 2/23/2008 16:33'! 429028expanderTitleNormalFillStyleFor: anExpanderTitle 429029 "Return the normal expander title fillStyle for the given expander title." 429030 429031 |aColor c cm cd cb| 429032 aColor := anExpanderTitle paneColor. 429033 c := aColor alphaMixed: 0.1 with: Color white. 429034 cm := aColor alphaMixed: 0.9 with: Color white. 429035 cd := cm alphaMixed: 0.9 with: Color black. 429036 cb := aColor alphaMixed: 0.6 with: Color black. 429037 ^(GradientFillStyle ramp: {0.0->c. 0.50->cm. 0.51->cd. 1.0->cb}) 429038 origin: anExpanderTitle topLeft; 429039 direction: 0 @ anExpanderTitle height; 429040 radial: false! ! 429041 429042!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 7/3/2007 12:30'! 429043progressBarFillStyleFor: aProgressBar 429044 "Return the progress bar fillStyle for the given progress bar." 429045 429046 |aColor area c cm cd cb| 429047 aColor := self progressBarColorFor: aProgressBar. 429048 area := aProgressBar bounds. 429049 c := aColor alphaMixed: 0.1 with: Color white. 429050 cm := aColor alphaMixed: 0.8 with: Color white. 429051 cd := aColor alphaMixed: 0.6 with: Color black. 429052 cb := aColor alphaMixed: 0.7 with: Color white. 429053 ^(GradientFillStyle ramp: {0.0->c. 0.49->cm. 0.5->cd. 1.0->cb}) 429054 origin: area origin; 429055 direction: 0@area height; 429056 radial: false! ! 429057 429058!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 4/24/2007 11:57'! 429059progressBarProgressFillStyleFor: aProgressBar 429060 "Return the progress bar progress fillStyle for the given progress bar." 429061 429062 |aColor area c cm cd cb| 429063 aColor := self progressBarProgressColorFor: aProgressBar. 429064 area := aProgressBar innerBounds. 429065 c := aColor alphaMixed: 0.1 with: Color white. 429066 cm := aColor alphaMixed: 0.8 with: Color white. 429067 cd := aColor alphaMixed: 0.6 with: Color black. 429068 cb := aColor alphaMixed: 0.7 with: Color white. 429069 ^(GradientFillStyle ramp: {0.0->c. 0.49->cm. 0.5->cd. 1.0->cb}) 429070 origin: area origin; 429071 direction: 0@area height; 429072 radial: false! ! 429073 429074!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 3/27/2008 21:35'! 429075resizerGripNormalFillStyleFor: aResizer 429076 "Return the normal fillStyle for the given resizer. 429077 For the moment, answer a transparent colour for no drawing, 429078 non transparent to draw as normal." 429079 429080 ^Color transparent! ! 429081 429082!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 11:38'! 429083sliderDisabledFillStyleFor: aSlider 429084 "Return the disabled fillStyle for the given slider." 429085 429086 |c inner| 429087 c := aSlider paneColor alphaMixed: 0.3 with: Color white. 429088 inner := aSlider innerBounds. 429089 ^(GradientFillStyle ramp: { 429090 0.0->c darker duller. 429091 0.15-> c darker. 429092 0.8->c twiceLighter. 429093 1.0->c darker}) 429094 origin: inner topLeft; 429095 direction: 0 @ inner height; 429096 radial: false! ! 429097 429098!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 11:37'! 429099sliderNormalFillStyleFor: aSlider 429100 "Return the normal fillStyle for the given slider." 429101 429102 |c inner| 429103 c := aSlider paneColor alphaMixed: 0.1 with: Color white. 429104 inner := aSlider innerBounds. 429105 ^(GradientFillStyle ramp: { 429106 0.0->c darker duller. 429107 0.15-> c darker. 429108 0.8->c twiceLighter. 429109 1.0->c darker}) 429110 origin: inner topLeft; 429111 direction: 0 @ inner height; 429112 radial: false! ! 429113 429114!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 1/7/2008 14:59'! 429115tabLabelNormalFillStyleFor: aTabLabel 429116 "Return the normal fillStyle for the given tab label." 429117 429118 |aColor c cm cd cb| 429119 aColor := aTabLabel paneColor lighter. 429120 c := aColor alphaMixed: 0.1 with: Color white. 429121 cm := aColor alphaMixed: 0.8 with: Color white. 429122 cd := aColor alphaMixed: 0.8 with: Color black. 429123 cb := aColor alphaMixed: 0.8 with: Color white. 429124 ^(GradientFillStyle ramp: {0.0->c. 0.5->cm. 0.51->cd. 1.0->cb}) 429125 origin: aTabLabel bounds origin; 429126 direction: 0 @ aTabLabel height; 429127 radial: false! ! 429128 429129!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 4/16/2007 12:11'! 429130taskbarFillStyleFor: aTaskbar 429131 "Return the taskbar fillStyle for the given taskbar." 429132 429133 |aColor c cm cd cb| 429134 aColor := aTaskbar color. 429135 c := aColor alphaMixed: 0.1 with: Color white. 429136 cm := aColor alphaMixed: 0.8 with: Color white. 429137 cd := aColor alphaMixed: 0.6 with: Color black. 429138 cb := aColor alphaMixed: 0.7 with: Color white. 429139 ^(GradientFillStyle ramp: {0.0->c. 0.49->cm. 0.5->cd. 1.0->cb}) 429140 origin: aTaskbar position; 429141 direction: 0@27; 429142 radial: false 429143 ! ! 429144 429145!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 4/20/2007 11:26'! 429146tasklistFillStyleFor: aTasklist 429147 "Return the tasklist fillStyle for the given tasklist." 429148 429149 |aColor c cm cd cb| 429150 aColor := aTasklist color. 429151 c := aColor alphaMixed: 0.7 with: Color white. 429152 cm := aColor alphaMixed: 0.8 with: Color white. 429153 cd := aColor alphaMixed: 0.6 with: Color black. 429154 cb := aColor alphaMixed: 0.7 with: Color white. 429155 ^(GradientFillStyle ramp: {0.0->c. 0.50->cm. 0.51->cd. 1.0->cb}) 429156 origin: aTasklist topLeft; 429157 direction: 0 @ aTasklist height; 429158 radial: false! ! 429159 429160!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 10:46'! 429161textEditorDisabledFillStyleFor: aTextEditor 429162 "Return the disabled fillStyle for the given text editor." 429163 429164 |c inner| 429165 c := aTextEditor paneColor alphaMixed: 0.3 with: Color white. 429166 inner := aTextEditor innerBounds. 429167 ^(GradientFillStyle ramp: { 429168 0.0->c darker duller. 429169 0.1-> c darker. 429170 0.9->c twiceLighter. 429171 1.0->c darker}) 429172 origin: inner topLeft; 429173 direction: 0 @ inner height; 429174 radial: false! ! 429175 429176!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 10:46'! 429177textEditorNormalFillStyleFor: aTextEditor 429178 "Return the normal fillStyle for the given text editor." 429179 429180 |c inner| 429181 c := aTextEditor paneColor alphaMixed: 0.1 with: Color white. 429182 inner := aTextEditor innerBounds. 429183 ^(GradientFillStyle ramp: { 429184 0.0->c darker duller. 429185 0.1-> c lighter. 429186 0.9->c twiceLighter. 429187 1.0->c darker}) 429188 origin: inner topLeft; 429189 direction: 0 @ inner height; 429190 radial: false! ! 429191 429192!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 11:02'! 429193textFieldDisabledFillStyleFor: aTextField 429194 "Return the disabled fillStyle for the given text field." 429195 429196 |c inner| 429197 c := aTextField paneColor alphaMixed: 0.3 with: Color white. 429198 inner := aTextField innerBounds. 429199 ^(GradientFillStyle ramp: { 429200 0.0->c darker duller. 429201 0.15-> c darker. 429202 0.8->c twiceLighter. 429203 1.0->c darker}) 429204 origin: inner topLeft; 429205 direction: 0 @ inner height; 429206 radial: false! ! 429207 429208!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 8/7/2007 11:02'! 429209textFieldNormalFillStyleFor: aTextField 429210 "Return the normal fillStyle for the given text field." 429211 429212 |c inner| 429213 c := aTextField paneColor alphaMixed: 0.1 with: Color white. 429214 inner := aTextField innerBounds. 429215 ^(GradientFillStyle ramp: { 429216 0.0->c darker duller. 429217 0.15-> c darker. 429218 0.8->c twiceLighter. 429219 1.0->c darker}) 429220 origin: inner topLeft; 429221 direction: 0 @ inner height; 429222 radial: false! ! 429223 429224!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 10/9/2007 14:50'! 429225windowActiveFillStyleFor: aWindow 429226 "Return the window active fillStyle for the given window." 429227 429228 ^aWindow paneColorToUse alpha: self windowFillStyleAlpha! ! 429229 429230!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 5/22/2007 11:24'! 429231windowActiveLabelFillStyleFor: aWindow 429232 "Return the window active label fillStyle for the given window." 429233 429234 ^aWindow paneColorToUse alphaMixed: 0.3 with: Color black! ! 429235 429236!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 10/9/2007 14:52'! 429237windowActiveTitleFillStyleFor: aWindow 429238 "Return the window active title fillStyle for the given window." 429239 429240 |aColor c cm cd cb| 429241 aColor := aWindow paneColorToUse alpha: self windowFillStyleAlpha / 2. 429242 c := aColor alphaMixed: 0.1 with: Color white. 429243 cm := aColor alphaMixed: 0.8 with: Color white. 429244 cd := aColor alphaMixed: 0.6 with: Color black. 429245 cb := aColor alphaMixed: 0.7 with: Color white. 429246 ^(GradientFillStyle ramp: {0.0->c. 0.46->cm. 0.47->cd. 1.0->cb}) 429247 origin: aWindow labelArea topLeft; 429248 direction: 0 @ aWindow labelHeight; 429249 radial: false 429250 ! ! 429251 429252!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 10/9/2007 14:49'! 429253windowInactiveFillStyleFor: aWindow 429254 "Return the window inactive fillStyle for the given window." 429255 429256 ^Preferences fadedBackgroundWindows 429257 ifTrue: [(aWindow paneColorToUse alpha: self windowFillStyleAlpha) 429258 alphaMixed: 0.9 429259 with: (Color white alpha: aWindow paneColorToUse alpha)] 429260 ifFalse: [aWindow paneColorToUse alpha: self windowFillStyleAlpha]! ! 429261 429262!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 7/18/2007 14:22'! 429263windowInactiveLabelFillStyleFor: aWindow 429264 "Return the window inactive label fillStyle for the given window." 429265 429266 ^aWindow paneColorToUse alphaMixed: 0.6 with: Color black! ! 429267 429268!UIThemeVistary methodsFor: 'fill-styles' stamp: 'gvc 4/26/2007 15:31'! 429269worldMainDockingBarNormalFillStyleFor: aDockingBar 429270 "Return the world main docking bar fillStyle for the given docking bar." 429271 429272 |aColor c cm cd cb| 429273 aColor := aDockingBar originalColor. 429274 c := aColor alphaMixed: 0.1 with: Color white. 429275 cm := aColor alphaMixed: 0.8 with: Color white. 429276 cd := aColor alphaMixed: 0.6 with: Color black. 429277 cb := aColor alphaMixed: 0.7 with: Color white. 429278 ^(GradientFillStyle ramp: {0.0->c. 0.49->cm. 0.5->cd. 1.0->cb}) 429279 origin: aDockingBar topLeft; 429280 direction: (aDockingBar isVertical 429281 ifTrue: [aDockingBar width @ 0] 429282 ifFalse: [0 @ aDockingBar height]); 429283 radial: false! ! 429284 429285 429286!UIThemeVistary methodsFor: 'fill-styles-buttons' stamp: 'gvc 6/13/2007 10:16'! 429287buttonDisabledFillStyleFor: aButton 429288 "Return the disabled button fillStyle for the given color." 429289 429290 ^aButton colorToUse lighter whiter alpha: 0.6! ! 429291 429292!UIThemeVistary methodsFor: 'fill-styles-buttons' stamp: 'gvc 3/28/2007 14:53'! 429293buttonMouseOverFillStyleFor: aButton 429294 "Return the button mouse over fillStyle for the given color." 429295 429296 |aColor c cm cd cb selcol| 429297 aColor := aButton colorToUse. 429298 selcol := (self selectionColor adjustSaturation: 0.2 brightness: 0.5). 429299 c := aColor alphaMixed: 0.1 with: Color white. 429300 cm := aColor alphaMixed: 0.7 with: selcol. 429301 cd := aColor alphaMixed: 0.6 with: Color black. 429302 cb := aColor alphaMixed: 0.3 with: (self selectionColor adjustSaturation: 0.7 brightness: 1.0) whiter. 429303 ^(GradientFillStyle ramp: { 429304 0.0->c. 0.5->cm. 0.51->cd. 0.8->cb. 1.0->Color white}) 429305 origin: aButton bounds origin; 429306 direction: 0 @ aButton height; 429307 radial: false! ! 429308 429309!UIThemeVistary methodsFor: 'fill-styles-buttons' stamp: 'gvc 2/22/2008 21:21'! 429310buttonNormalFillStyleFor: aButton 429311 "Return the normal button fillStyle for the given color." 429312 429313 |aColor c cm cd cb| 429314 aColor := self buttonColorFor: aButton. 429315 c := aColor alphaMixed: 0.1 with: Color white. 429316 cm := aColor alphaMixed: 0.8 with: Color white. 429317 cd := aColor alphaMixed: 0.6 with: Color black. 429318 cb := aColor alphaMixed: 0.8 with: Color white. 429319 ^(GradientFillStyle ramp: {0.0->c. 0.5->cm. 0.51->cd. 1.0->cb}) 429320 origin: aButton bounds origin; 429321 direction: 0 @ aButton height; 429322 radial: false! ! 429323 429324!UIThemeVistary methodsFor: 'fill-styles-buttons' stamp: 'gvc 3/14/2007 15:15'! 429325buttonPanelNormalFillStyleFor: aPanel 429326 "Return the normal panel fillStyle for the given panel." 429327 429328 |aColor c cm cd cb| 429329 aColor := aPanel paneColor. 429330 c := aColor alphaMixed: 0.7 with: Color white. 429331 cm := aColor alphaMixed: 0.8 with: Color white. 429332 cd := aColor alphaMixed: 0.6 with: Color black. 429333 cb := aColor alphaMixed: 0.7 with: Color white. 429334 ^(GradientFillStyle ramp: {0.0->c. 0.50->cm. 0.51->cd. 1.0->cb}) 429335 origin: aPanel topLeft; 429336 direction: 0 @ aPanel height; 429337 radial: false! ! 429338 429339!UIThemeVistary methodsFor: 'fill-styles-buttons' stamp: 'gvc 3/14/2007 13:24'! 429340buttonPressedFillStyleFor: aButton 429341 "Return the button pressed fillStyle for the given button." 429342 429343 ^self buttonSelectedFillStyleFor: aButton! ! 429344 429345!UIThemeVistary methodsFor: 'fill-styles-buttons' stamp: 'gvc 3/14/2007 12:40'! 429346buttonSelectedDisabledFillStyleFor: aButton 429347 "Return the button selected disabled fillStyle for the given color." 429348 429349 |aColor selcol| 429350 aColor := aButton colorToUse. 429351 selcol := (aColor mixed: 0.5 with: self selectionColor) lighter whiter. 429352 ^(GradientFillStyle ramp: {0.0->selcol. 1.0->selcol}) 429353 origin: aButton bounds origin; 429354 direction: 0 @ aButton height; 429355 radial: false! ! 429356 429357!UIThemeVistary methodsFor: 'fill-styles-buttons' stamp: 'gvc 3/28/2007 14:52'! 429358buttonSelectedFillStyleFor: aButton 429359 "Return the button selected fillStyle for the given button." 429360 429361 |aColor c cm cd cb selcol| 429362 aColor := aButton colorToUse. 429363 selcol := (self selectionColor adjustSaturation: 0.2 brightness: 0.5). 429364 c := aColor alphaMixed: 0.1 with: Color white. 429365 cm := aColor alphaMixed: 0.4 with: selcol. 429366 cd := aColor alphaMixed: 0.6 with: Color black. 429367 cb := aColor alphaMixed: 0.1 with: (self selectionColor adjustSaturation: 0.7 brightness: 1.0) whiter. 429368 ^(GradientFillStyle ramp: { 429369 0.0->c. 0.5->cm. 0.51->cd. 0.8->cb. 1.0->Color white}) 429370 origin: aButton bounds origin; 429371 direction: 0 @ aButton height; 429372 radial: false! ! 429373 429374!UIThemeVistary methodsFor: 'fill-styles-buttons' stamp: 'gvc 3/14/2007 13:23'! 429375buttonSelectedMouseOverFillStyleFor: aButton 429376 "Return the button selected mouse over fillStyle for the given button." 429377 429378 ^self buttonMouseOverFillStyleFor: aButton! ! 429379 429380!UIThemeVistary methodsFor: 'fill-styles-buttons' stamp: 'gvc 3/14/2007 13:24'! 429381buttonSelectedPressedFillStyleFor: aButton 429382 "Return the button selected pressed fillStyle for the given button." 429383 429384 ^self buttonNormalFillStyleFor: aButton! ! 429385 429386!UIThemeVistary methodsFor: 'fill-styles-buttons' stamp: 'gvc 10/9/2007 11:35'! 429387checkboxButtonDisabledFillStyleFor: aCheckboxButton 429388 "Return the disabled checkbox button fillStyle for the given button." 429389 429390 |c ib| 429391 c := aCheckboxButton colorToUse 429392 alphaMixed: 0.3 429393 with: Color white. 429394 ib := aCheckboxButton innerBounds. 429395 ^(GradientFillStyle ramp: { 429396 0.0->c darker duller. 429397 0.2->c darker. 429398 0.5->c lighter. 429399 1.0->c twiceLighter}) 429400 origin: aCheckboxButton innerBounds origin; 429401 direction: ib extent; 429402 radial: false! ! 429403 429404!UIThemeVistary methodsFor: 'fill-styles-buttons' stamp: 'gvc 10/9/2007 11:34'! 429405checkboxButtonNormalFillStyleFor: aCheckboxButton 429406 "Return the normal checkbox button fillStyle for the given button." 429407 429408 |c ib| 429409 c := aCheckboxButton colorToUse 429410 alphaMixed: 0.2 429411 with: Color white. 429412 ib := aCheckboxButton innerBounds. 429413 ^(GradientFillStyle ramp: { 429414 0.0->c darker duller. 429415 0.2->c darker. 429416 0.5->c lighter. 429417 1.0->c twiceLighter}) 429418 origin: aCheckboxButton innerBounds origin; 429419 direction: ib extent; 429420 radial: false! ! 429421 429422!UIThemeVistary methodsFor: 'fill-styles-buttons' stamp: 'gvc 6/4/2007 12:54'! 429423menuItemInDockingBarSelectedFillStyleFor: aMenuItem 429424 "Answer the selected fill style to use for the given menu item that is in a docking bar." 429425 429426 |c fill| 429427 Display depth <= 2 ifTrue: [^ Color gray]. 429428 c := aMenuItem owner color isTransparent 429429 ifTrue: [aMenuItem paneColor darker] 429430 ifFalse: [aMenuItem owner color darker]. 429431 fill := GradientFillStyle ramp: { 429432 0.0->Color white. 429433 0.2->c lighter. 429434 1.0->Color white}. 429435 fill origin: aMenuItem topLeft. 429436 aMenuItem owner isVertical 429437 ifTrue: [fill direction: aMenuItem width @ 0] 429438 ifFalse: [fill direction: 0 @ aMenuItem height]. 429439 ^ fill! ! 429440 429441!UIThemeVistary methodsFor: 'fill-styles-buttons' stamp: 'gvc 6/4/2007 12:59'! 429442menuItemSelectedFillStyleFor: aMenuItem 429443 "Answer the selected fill style to use for the given menu item." 429444 429445 |c aColor selcol cm cd cb| 429446 Display depth <= 2 ifTrue: [^ Color gray]. 429447 aColor := aMenuItem owner color isTransparent 429448 ifTrue: [aMenuItem paneColor darker] 429449 ifFalse: [aMenuItem owner color darker]. 429450 selcol := (self selectionColor adjustSaturation: 0.2 brightness: 0.5). 429451 c := aColor alphaMixed: 0.1 with: Color white. 429452 cm := aColor alphaMixed: 0.4 with: selcol. 429453 cd := aColor alphaMixed: 0.6 with: Color black. 429454 cb := aColor alphaMixed: 0.1 with: (self selectionColor adjustSaturation: 0.7 brightness: 1.0) whiter. 429455 ^(GradientFillStyle ramp: { 429456 0.0->c. 0.5->cm. 0.51->cd. 0.8->cb. 1.0->Color white}) 429457 origin: aMenuItem topLeft; 429458 direction: 0 @ aMenuItem height! ! 429459 429460 429461!UIThemeVistary methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 6/4/2007 15:47'! 429462scrollbarMouseOverBarButtonFillStyleFor: aScrollbar 429463 "Return the button fillStyle for the given scrollbar when 429464 the mouse is over the bar." 429465 429466 ^self scrollbarNormalThumbFillStyleFor: aScrollbar! ! 429467 429468!UIThemeVistary methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 4/5/2007 14:23'! 429469scrollbarMouseOverButtonFillStyleFor: aScrollbar 429470 "Return the mouse over scrollbar button fillStyle for the given scrollbar." 429471 429472 ^self scrollbarMouseOverThumbFillStyleFor: aScrollbar! ! 429473 429474!UIThemeVistary methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 5/27/2008 21:07'! 429475scrollbarMouseOverThumbFillStyleFor: aScrollbar 429476 "Return the scrollbar mouse over thumb fillStyle for the given color." 429477 429478 |aColor c cm cd cb selcol thumb grad offset| 429479 aColor := self scrollbarColorFor: aScrollbar. 429480 selcol := (self selectionColor adjustSaturation: 0.2 brightness: 0.5). 429481 c := aColor alphaMixed: 0.1 with: Color white. 429482 cm := aColor alphaMixed: 0.5 with: selcol. 429483 cd := aColor alphaMixed: 0.9 with: Color black. 429484 cb := aColor alphaMixed: 0.3 with: (self selectionColor adjustSaturation: 0.7 brightness: 1.0) whiter. 429485 grad := (GradientFillStyle ramp: {0.0->c. 0.48->cm. 0.49->cd. 1.0->cb}) 429486 origin: aScrollbar topLeft; 429487 direction: (aScrollbar bounds isWide 429488 ifTrue: [0 @ aScrollbar height] 429489 ifFalse: [aScrollbar width @ 0]); 429490 radial: false. 429491 aScrollbar bounds isWide 429492 ifTrue: [thumb := self hThumbForm. 429493 offset := thumb extent // 2 + (0@1)] 429494 ifFalse: [thumb := self vThumbForm. 429495 offset := thumb extent // 2 + (1@0)]. 429496 ^((aScrollbar slider bounds isWide and: [aScrollbar slider width > (thumb width * 2)]) or: [ 429497 aScrollbar slider bounds isWide not and: [aScrollbar slider height > (thumb height * 2)]]) 429498 ifTrue: [CompositeFillStyle fillStyles: { 429499 grad. 429500 (ImageFillStyle 429501 form: thumb) 429502 origin: aScrollbar slider bounds center - offset; 429503 direction: thumb width@0}] 429504 ifFalse: [grad]! ! 429505 429506!UIThemeVistary methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 4/17/2007 16:19'! 429507scrollbarNormalButtonFillStyleFor: aScrollbar 429508 "Return the normal scrollbar button fillStyle for the given scrollbar." 429509 429510 ^self scrollbarNormalFillStyleFor: aScrollbar! ! 429511 429512!UIThemeVistary methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 6/4/2007 14:53'! 429513scrollbarNormalFillStyleFor: aScrollbar 429514 "Return the normal scrollbar fillStyle for the given scrollbar." 429515 429516 |aColor c| 429517 aColor := (self scrollbarColorFor: aScrollbar) alphaMixed: 0.3 with: Color white. 429518 c := aColor alphaMixed: 0.9 with: Color black. 429519 ^(GradientFillStyle ramp: {0.0->c. 0.15->aColor. 0.9->aColor. 1.0->c}) 429520 origin: aScrollbar topLeft; 429521 direction: (aScrollbar bounds isWide 429522 ifTrue: [0 @ aScrollbar height] 429523 ifFalse: [aScrollbar width @ 0]); 429524 radial: false! ! 429525 429526!UIThemeVistary methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 5/27/2008 21:07'! 429527scrollbarNormalThumbFillStyleFor: aScrollbar 429528 "Return the normal scrollbar thumb fillStyle for the given scrollbar." 429529 429530 |aColor c cm cd cb thumb grad offset| 429531 aColor := self scrollbarColorFor: aScrollbar. 429532 c := aColor alphaMixed: 0.1 with: Color white. 429533 cm := aColor alphaMixed: 0.9 with: Color white. 429534 cd := cm alphaMixed: 0.9 with: Color black. 429535 cb := aColor alphaMixed: 0.6 with: Color black. 429536 grad := (GradientFillStyle ramp: {0.0->c. 0.48->cm. 0.49->cd. 1.0->cb}) 429537 origin: aScrollbar topLeft; 429538 direction: (aScrollbar bounds isWide 429539 ifTrue: [0 @ aScrollbar height] 429540 ifFalse: [aScrollbar width @ 0]); 429541 radial: false. 429542 aScrollbar bounds isWide 429543 ifTrue: [thumb := self hThumbForm. 429544 offset := thumb extent // 2 + (0@1)] 429545 ifFalse: [thumb := self vThumbForm. 429546 offset := thumb extent // 2 + (1@0)]. 429547 ^((aScrollbar slider bounds isWide and: [aScrollbar slider width > (thumb width * 2)]) or: [ 429548 aScrollbar slider bounds isWide not and: [aScrollbar slider height > (thumb height * 2)]]) 429549 ifTrue: [CompositeFillStyle fillStyles: { 429550 grad. 429551 (ImageFillStyle 429552 form: thumb) 429553 origin: aScrollbar slider bounds center - offset; 429554 direction: thumb width@0}] 429555 ifFalse: [grad]! ! 429556 429557!UIThemeVistary methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 4/16/2007 13:05'! 429558scrollbarPressedFillStyleFor: aScrollbar 429559 "Return the pressed scrollbar fillStyle for the given scrollbar." 429560 429561 |aColor| 429562 aColor := self scrollbarColorFor: aScrollbar. 429563 ^aColor alphaMixed: 0.6 with: Color white! ! 429564 429565!UIThemeVistary methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 5/27/2008 21:08'! 429566scrollbarPressedThumbFillStyleFor: aScrollbar 429567 "Return the pressed scrollbar thumb fillStyle for the given scrollbar." 429568 429569 |aColor c cm cd cb selcol thumb grad offset| 429570 aColor := self scrollbarColorFor: aScrollbar. 429571 selcol := (self selectionColor adjustSaturation: 0.2 brightness: 0.5). 429572 c := aColor alphaMixed: 0.1 with: Color white. 429573 cm := aColor alphaMixed: 0.4 with: selcol. 429574 cd := aColor alphaMixed: 0.6 with: Color black. 429575 cb := aColor alphaMixed: 0.1 with: (self selectionColor adjustSaturation: 0.7 brightness: 1.0) whiter. 429576 grad := (GradientFillStyle ramp: {0.0->c. 0.48->cm. 0.49->cd. 1.0->cb}) 429577 origin: aScrollbar topLeft; 429578 direction: (aScrollbar bounds isWide 429579 ifTrue: [0 @ aScrollbar height] 429580 ifFalse: [aScrollbar width @ 0]); 429581 radial: false. 429582 aScrollbar bounds isWide 429583 ifTrue: [thumb := self hThumbForm. 429584 offset := thumb extent // 2 + (0@1)] 429585 ifFalse: [thumb := self vThumbForm. 429586 offset := thumb extent // 2 + (1@0)]. 429587 ^((aScrollbar slider bounds isWide and: [aScrollbar slider width > (thumb width * 2)]) or: [ 429588 aScrollbar slider bounds isWide not and: [aScrollbar slider height > (thumb height * 2)]]) 429589 ifTrue: [CompositeFillStyle fillStyles: { 429590 grad. 429591 (ImageFillStyle 429592 form: thumb) 429593 origin: aScrollbar slider bounds center - offset; 429594 direction: thumb width@0}] 429595 ifFalse: [grad]! ! 429596 429597!UIThemeVistary methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 2/22/2008 21:17'! 429598useScrollbarThumbShadow 429599 "Answer whether a shadow morph should be displayed when 429600 dragging a scrollbar thumb." 429601 429602 ^false! ! 429603 429604 429605!UIThemeVistary methodsFor: 'icons' stamp: 'gvc 5/18/2007 14:49'! 429606errorIcon 429607 "Answer an error icon." 429608 429609 ^VistaryThemeIcons errorIcon! ! 429610 429611!UIThemeVistary methodsFor: 'icons' stamp: 'gvc 5/18/2007 14:49'! 429612infoIcon 429613 "Answer an information icon." 429614 429615 ^VistaryThemeIcons infoIcon! ! 429616 429617!UIThemeVistary methodsFor: 'icons' stamp: 'gvc 5/18/2007 14:49'! 429618lockIcon 429619 "Answer a lock icon." 429620 429621 ^VistaryThemeIcons lockIcon! ! 429622 429623!UIThemeVistary methodsFor: 'icons' stamp: 'gvc 5/18/2007 14:47'! 429624questionIcon 429625 "Answer a question icon." 429626 429627 ^VistaryThemeIcons questionIcon! ! 429628 429629!UIThemeVistary methodsFor: 'icons' stamp: 'gvc 5/22/2007 10:45'! 429630smallDebugIcon 429631 "Answer a small debug icon." 429632 429633 ^self smallWarningIcon! ! 429634 429635!UIThemeVistary methodsFor: 'icons' stamp: 'gvc 5/21/2007 12:53'! 429636smallErrorIcon 429637 "Answer a small error icon." 429638 429639 ^VistaryThemeIcons smallErrorIcon! ! 429640 429641!UIThemeVistary methodsFor: 'icons' stamp: 'gvc 5/21/2007 13:08'! 429642smallInfoIcon 429643 "Answer a small information icon." 429644 429645 ^VistaryThemeIcons smallInfoIcon! ! 429646 429647!UIThemeVistary methodsFor: 'icons' stamp: 'gvc 5/21/2007 12:53'! 429648smallLockIcon 429649 "Answer a small lock icon." 429650 429651 ^VistaryThemeIcons smallLockIcon! ! 429652 429653!UIThemeVistary methodsFor: 'icons' stamp: 'gvc 5/21/2007 12:53'! 429654smallQuestionIcon 429655 "Answer a small question icon." 429656 429657 ^VistaryThemeIcons smallQuestionIcon! ! 429658 429659!UIThemeVistary methodsFor: 'icons' stamp: 'gvc 5/21/2007 12:53'! 429660smallWarningIcon 429661 "Answer a small warning icon." 429662 429663 ^VistaryThemeIcons smallWarningIcon! ! 429664 429665!UIThemeVistary methodsFor: 'icons' stamp: 'gvc 5/18/2007 14:49'! 429666warningIcon 429667 "Answer a warning icon." 429668 429669 ^VistaryThemeIcons warningIcon! ! 429670 429671 429672!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 10/28/2008 15:37'! 429673initializeForms 429674 "Initialize the receiver's image forms." 429675 429676 super initializeForms. 429677 self forms 429678 at: #vThumb put: self newVThumbForm; 429679 at: #hThumb put: self newHThumbForm; 429680 at: #windowCloseOver put: self newWindowCloseOverForm; 429681 at: #windowCloseDown put: self newWindowCloseDownForm; 429682 at: #windowClosePassive put: self newWindowClosePassiveForm; 429683 at: #windowMinimizeOver put: self newWindowMinimizeOverForm; 429684 at: #windowMinimizeDown put: self newWindowMinimizeDownForm; 429685 at: #windowMaximizeOver put: self newWindowMaximizeOverForm; 429686 at: #windowMaximizeDown put: self newWindowMaximizeDownForm! ! 429687 429688!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 3/26/2008 19:40'! 429689newHThumbForm 429690 "Answer a new form for a horizontal thumb (mostly for scrollbars)." 429691 429692 ^Form 429693 extent: 10@9 429694 depth: 32 429695 fromArray: #( 0 2164260863 2164260863 150994943 2164260863 2164260863 33554431 2164260863 2164260863 33554431 2164260863 2147483648 2151694400 2164260863 2147483648 2151694400 2164260863 2147483648 2151694400 2164260863 2164260863 2147483648 2155905152 2164260863 2147483648 2155905152 2164260863 2147483648 2155905152 2164260863 2164260863 2147483648 2155905152 2164260863 2147483648 2155905152 2164260863 2147483648 2155905152 2164260863 2164260863 2147483648 2155905152 2164260863 2147483648 2155905152 2164260863 2147483648 2155905152 2164260863 2164260863 2147483648 2155905152 2164260863 2147483648 2155905152 2164260863 2147483648 2155905152 2164260863 2164260863 2147483648 2155905152 2164260863 2147483648 2155905152 2164260863 2147483648 2155905152 2164260863 2164260863 2151694400 2155905152 2164260863 2151694400 2155905152 2164260863 2151694400 2155905152 2164260863 0 2164260863 2164260863 0 2164260863 2164260863 0 2164260863 2164260863 0) 429696 offset: 0@0! ! 429697 429698!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 9/5/2007 14:51'! 429699newTreeExpandedForm 429700 "Answer a new form for an expanded tree item." 429701 429702 ^(Form 429703 extent: 9@9 429704 depth: 32 429705 fromArray: #( 16777215 16777215 16777215 16777215 16777215 805306368 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1006961930 4026795016 50331648 16777215 16777215 16777215 16777215 16777215 301989888 3725726500 4046204508 973078528 16777215 16777215 16777215 16777215 16777216 3255701277 4283585959 4282533261 2533951764 16777215 16777215 16777215 16777215 2265779739 4114629505 4283849140 4282730394 3590850580 16777215 16777215 16777215 1091045392 3928237641 4284046778 4282993825 4282006408 3859549217 335544320 16777215 369098752 3993372173 4012715870 3995609688 3995083083 3994490942 4077389851 1577058307 16777215 419430400 939524096 939524096 939524096 939524096 939524096 939524096 486539264 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) 429706 offset: 0@0)! ! 429707 429708!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 9/5/2007 14:57'! 429709newTreeUnexpandedForm 429710 "Answer a new form for an unexpanded tree item." 429711 429712 ^(Form 429713 extent: 9@9 429714 depth: 32 429715 fromArray: #( 16777215 134217728 270409246 16777215 16777215 16777215 16777215 16777215 16777215 16777215 402653184 3565586054 1045582418 16777215 16777215 16777215 16777215 16777215 16777215 402653184 4191606486 3973371092 2003068004 16777215 16777215 16777215 16777215 16777215 402653184 4191606486 4294967295 4243714545 2860153466 270409246 16777215 16777215 16777215 402653184 4191606486 4294967295 4294967295 4294901502 2975620188 16777215 16777215 16777215 402653184 4191606486 4294967295 4226739950 2659090046 167772160 16777215 16777215 16777215 402653184 4191606486 3905933263 1785293161 16777215 16777215 16777215 16777215 16777215 402653184 3531505278 928207699 16777215 16777215 16777215 16777215 16777215 16777215 117440512 202642452 16777215 16777215 16777215 16777215 16777215 16777215) 429716 offset: 0@0)! ! 429717 429718!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 3/26/2008 19:39'! 429719newVThumbForm 429720 "Answer a new form for a vertical thumb (mostly for scrollbars)." 429721 429722 ^Form 429723 extent: 9@10 429724 depth: 32 429725 fromArray: #( 0 2164260863 2164260863 2164260863 2164260863 2164260863 2164260863 2164260863 0 2164260863 2147483648 2147483648 2147483648 2147483648 2147483648 2147483648 2151694400 2164260863 2164260863 2151694400 2155905152 2155905152 2155905152 2155905152 2155905152 2155905152 2164260863 150994943 2164260863 2164260863 2164260863 2164260863 2164260863 2164260863 2164260863 0 2164260863 2147483648 2147483648 2147483648 2147483648 2147483648 2147483648 2151694400 2164260863 2164260863 2151694400 2155905152 2155905152 2155905152 2155905152 2155905152 2155905152 2164260863 33554431 2164260863 2164260863 2164260863 2164260863 2164260863 2164260863 2164260863 0 2164260863 2147483648 2147483648 2147483648 2147483648 2147483648 2147483648 2151694400 2164260863 2164260863 2151694400 2155905152 2155905152 2155905152 2155905152 2155905152 2155905152 2164260863 33554431 2164260863 2164260863 2164260863 2164260863 2164260863 2164260863 2164260863 0) 429726 offset: 0@0! ! 429727 429728!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 10/27/2008 13:49'! 429729newWindowCloseDownForm 429730 "Answer a new form for a window close box in mouse down over state." 429731 429732 ^(Form 429733 extent: 18@18 429734 depth: 32 429735 fromArray: #( 150863872 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 117309440 1711144960 1711144960 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2818441216 2717777920 2717777920 1711144960 1711144960 1711144960 2717777920 4288710531 4288841603 4288841345 4288841345 4288841345 4288841345 4288841345 4288841345 4288841345 4288841345 4288841345 4288841345 4288841345 4288841603 2717777920 1711144960 1711144960 2717777920 4288709760 4288709760 4288709502 4288709502 4288709502 4288709502 4288709502 4288709502 4288709502 4288709502 4288709502 4288709502 4288709502 4288709760 2717777920 1711144960 1711144960 2717777920 4288577403 4288577403 4284898397 4282269510 4282269510 4282269510 4284898140 4288577403 4284897884 4282269510 4282269510 4282269510 4284898397 4288577403 2717777920 1711144960 1711144960 2717777920 4288313975 4288445302 4282269510 4290624957 4290624957 4290624957 4282269510 4284897626 4282269510 4290624957 4290624957 4290624957 4282269510 4288445302 2717777920 1711144960 1711144960 2717777920 4288247410 4288247152 4284700247 4282269510 4290427578 4290624957 4290427578 4282269510 4290427578 4290624957 4290624957 4282401352 4284700247 4288313202 2717777920 1711144960 1711144960 2717777920 4287917673 4287917673 4287917673 4284699733 4282269510 4290361785 4290427578 4290361785 4290427578 4290427578 4282401352 4284568148 4287917416 4287917673 2717777920 1711144960 1711144960 2717777920 4287456094 4287456093 4287587422 4287587422 4284436047 4282269510 4289440683 4289638062 4289638062 4282401352 4284436048 4287456093 4287587422 4287456093 2717777920 1711144960 1711144960 2717777920 4286201912 4286201912 4286267961 4286267961 4283908416 4282269510 4289440683 4289638062 4289638062 4282269510 4283908160 4286267961 4286267961 4286267961 2717777920 1711144960 1711144960 2717777920 4285938482 4286069811 4286069811 4283907903 4282269510 4289243304 4289243304 4289243304 4289243304 4289243304 4282269510 4283907903 4286069811 4286069554 2717777920 1711144960 1711144960 2717777920 4286070840 4286202425 4283908416 4282269510 4288848546 4288980132 4288980132 4282335302 4288848546 4288980132 4288848546 4282269510 4283908416 4286202425 2717777920 1711144960 1711144960 2717777920 4286270016 4286269759 4282269510 4288585374 4288716960 4288716960 4282335302 4283909186 4282269510 4288585374 4288716960 4288585374 4282269510 4286269759 2717777920 1711144960 1711144960 2717777920 4286534216 4286534216 4284041287 4282269510 4282269510 4282269510 4284041030 4286665032 4284172360 4282269510 4282269510 4282269510 4284041287 4286534216 2717777920 1711144960 1711144960 2717777920 4286930260 4286930258 4286930260 4286930258 4286930258 4286930258 4286930258 4287061588 4286930258 4286930258 4286930258 4287061588 4286930258 4286930260 2717777920 1711144960 1711144960 2717777920 4287194716 4287194716 4287325531 4287456861 4287456861 4287456861 4287456861 4287456861 4287456861 4287456861 4287457117 4287456861 4287456861 4287194716 2717777920 1711144960 1711144960 1711144960 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 1711144960 1711144960 50200576 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 184418304) 429736 offset: 0@0)! ! 429737 429738!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 5/15/2007 10:47'! 429739newWindowCloseForm 429740 "Answer a new form for a window close box." 429741 429742 ^Form 429743 extent: 14@14 429744 depth: 32 429745 fromArray: #( 4293504934 4293636006 4293701540 4293767076 4293767076 4293767076 4293767076 4293767076 4293767076 4293767076 4293767076 4293767076 4293701540 4293636006 4293503392 4293503392 4293634976 4293634976 4293634976 4293634976 4293634976 4293634976 4293634976 4293634976 4293634976 4293634976 4293634976 4293503392 4293436828 4293502364 4287789179 4283717479 4283717479 4283717479 4287854715 4293567642 4287920252 4283717479 4283717479 4283717479 4287789179 4293502364 4293238164 4293369236 4283651686 4294835709 4294901502 4294901502 4283717479 4287788409 4283651686 4294835709 4294901502 4294901502 4283717479 4293369236 4293105548 4293171084 4287590772 4283717479 4294769916 4294835709 4294769916 4283717479 4294704123 4294835709 4294835709 4283783272 4287590772 4293236620 4292840319 4292905855 4292840062 4287589743 4283717479 4294572537 4294638330 4294572537 4294638330 4294638330 4283783272 4287523951 4292905597 4292971391 4292443503 4292509039 4292574575 4292574575 4287391593 4283717479 4293454056 4293519849 4293519849 4283783272 4287391337 4292508782 4292574575 4292509039 4291316278 4291447350 4291578934 4291644470 4286993233 4283651686 4293454056 4293519849 4293519849 4283717479 4286927441 4291513398 4291644470 4291512886 4291117870 4291248942 4291380270 4286926926 4283651686 4292927714 4293059298 4293059298 4293059298 4292993506 4283717478 4286926670 4291380270 4291380014 4291185719 4291317047 4286927697 4283651686 4292532956 4292664540 4292664540 4283783270 4292598748 4292664540 4292598748 4283717478 4286927697 4291382583 4291188800 4291319872 4283651686 4292204247 4292335575 4292335575 4283783270 4286863189 4283717478 4292269783 4292335575 4292270039 4283717478 4291385408 4291454286 4291454286 4286930267 4283717478 4283717478 4283717478 4286995803 4291585101 4287061339 4283717478 4283717478 4283717478 4286930267 4291454286 4291655006 4291720542 4291655006 4291851614 4291851614 4291851614 4291851614 4291917150 4291851614 4291851614 4291851614 4291851870 4291786334 4291720798 4291985771 4291985771 4292182378 4292247914 4292247914 4292247914 4292247914 4292247914 4292247914 4292247914 4292248170 4292248171 4292248171 4291986026) 429746 offset: 0@0! ! 429747 429748!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 10/27/2008 13:48'! 429749newWindowCloseOverForm 429750 "Answer a new form for a window close box in mouse over state." 429751 429752 ^(Form 429753 extent: 18@18 429754 depth: 32 429755 fromArray: #( 150863872 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 117309440 1711144960 1711144960 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2818441216 2717777920 2717777920 1711144960 1711144960 1711144960 2717777920 4293504934 4293636006 4293701540 4293767076 4293767076 4293767076 4293767076 4293767076 4293767076 4193103780 4293767076 4293767076 4293701540 4293636006 2717777920 1711144960 1711144960 2717777920 4293503392 4293503392 4293634976 4293634976 4293634976 4293634976 4293634976 4293634976 4293634976 4293634976 4293634976 4293634976 4293634976 4293503392 2717777920 1711144960 1711144960 2717777920 4293436828 4293502364 4287789179 4283717479 4283717479 4283717479 4287854715 4293567642 4287920252 4283717479 4283717479 4283717479 4287789179 4293502364 2717777920 1711144960 1711144960 2717777920 4293238164 4293369236 4283651686 4294835709 4294901502 4294901502 4283717479 4287788409 4283651686 4294835709 4294901502 4294901502 4283717479 4293369236 2717777920 1711144960 1711144960 2717777920 4293105548 4293171084 4287590772 4283717479 4294769916 4294835709 4294769916 4283717479 4294704123 4294835709 4294835709 4283783272 4287590772 4293236620 2717777920 1711144960 1711144960 2717777920 4292840319 4292905855 4292840062 4287589743 4283717479 4294572537 4294638330 4294572537 4294638330 4294638330 4283783272 4287523951 4292905597 4292971391 2717777920 1711144960 1711144960 2717777920 4292443503 4292509039 4292574575 4292574575 4287391593 4283717479 4293454056 4293519849 4293519849 4283783272 4287391337 4292508782 4292574575 4292509039 2717777920 1711144960 1711144960 2717777920 4291316278 4291447350 4291578934 4291644470 4286993233 4283651686 4293454056 4293519849 4293519849 4283717479 4286927441 4291513398 4291644470 4291512886 2717777920 1711144960 1711144960 2717777920 4291117870 4291248942 4291380270 4286926926 4283651686 4292927714 4293059298 4293059298 4293059298 4292993506 4283717478 4286926670 4291380270 4291380014 2717777920 1711144960 1711144960 2717777920 4291185719 4291317047 4286927697 4283651686 4292532956 4292664540 4292664540 4283783270 4292598748 4292664540 4292598748 4283717478 4286927697 4291382583 2717777920 1711144960 1711144960 2717777920 4291188800 4291319872 4283651686 4292204247 4292335575 4292335575 4283783270 4286863189 4283717478 4292269783 4292335575 4292270039 4283717478 4291385408 2717777920 1711144960 1711144960 2717777920 4291454286 4291454286 4286930267 4283717478 4283717478 4283717478 4286995803 4291585101 4287061339 4283717478 4283717478 4283717478 4286930267 4291454286 2717777920 1711144960 1711144960 2717777920 4291655006 4291720542 4291655006 4291851614 4291851614 4291851614 4291851614 4291917150 4291851614 4291851614 4291851614 4291851870 4291786334 4291720798 2717777920 1711144960 1711144960 2717777920 4291985771 4291985771 4292182378 4292247914 4292247914 4292247914 4292247914 4292247914 4292247914 4292247914 4292248170 4292248171 4292248171 4291986026 2717777920 1711144960 1711144960 1711144960 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 2717777920 1711144960 1711144960 50200576 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 1711144960 184418304) 429756 offset: 0@0)! ! 429757 429758!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 10/22/2008 15:08'! 429759newWindowClosePassiveForm 429760 "Answer a new form for a passive window close box." 429761 429762 ^(Form 429763 extent: 14@14 429764 depth: 32 429765 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4287789179 4283717479 4283717479 4283717479 4287854715 0 4287920252 4283717479 4283717479 4283717479 4287789179 0 0 0 4283651686 4294835709 4294901502 4294901502 4283717479 4287788409 4283651686 4294835709 4294901502 4294901502 4283717479 0 0 0 4287590772 4283717479 4294769916 4294835709 4294769916 4283717479 4294704123 4294835709 4294835709 4283783272 4287590772 0 0 0 0 4287589743 4283717479 4294572537 4294638330 4294572537 4294638330 4294638330 4283783272 4287523951 0 0 0 0 0 0 4287391593 4283717479 4293454056 4293519849 4293519849 4283783272 4287391337 0 0 0 0 0 0 0 4286993233 4283651686 4293454056 4293519849 4293519849 4283717479 4286927441 0 0 0 0 0 0 4286926926 4283651686 4292927714 4293059298 4293059298 4293059298 4292993506 4283717478 4286926670 0 0 0 0 4286927697 4283651686 4292532956 4292664540 4292664540 4283783270 4292598748 4292664540 4292598748 4283717478 4286927697 0 0 0 4283651686 4292204247 4292335575 4292335575 4283783270 4286863189 4283717478 4292269783 4292335575 4292270039 4283717478 0 0 0 4286930267 4283717478 4283717478 4283717478 4286995803 0 4287061339 4283717478 4283717478 4283717478 4286930267 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 429766 offset: 0@0)! ! 429767 429768!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 10/28/2008 15:35'! 429769newWindowMaximizeDownForm 429770 "Answer a new form for a mouse down window maximize box." 429771 429772 ^(Form 429773 extent: 18@18 429774 depth: 32 429775 fromArray: #( 50331647 50331647 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 167772159 33554431 33554431 33554431 33554431 55175422 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 38398206 33554431 33554431 1699342590 1682434302 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 1682434302 1699342590 33554431 33554431 1699342590 2705844222 3375444796 4281414460 4281414460 4281414460 4281414460 4281414460 4281414460 4281414460 4281414460 4281414460 4281414460 3408999228 2705844222 1699342590 33554431 33554431 1699342590 2705844222 4281414460 4287927444 4287927444 4287927444 4287927444 4287927444 4287927444 4287927444 4287927444 4287927444 4287927444 4281414460 2705844222 1699342590 33554431 33554431 1699342590 2705844222 4281414460 4287927444 4287927444 4287927444 4287927444 4287927444 4287927444 4287927444 4287927444 4287927444 4287927444 4281414460 2705844222 1699342590 33554431 33554431 1699342590 2705844222 4281414460 4287927444 4287927444 4281414460 4281414460 4281414460 4281414460 4281414460 4281414460 4287927444 4287927444 4281414460 2705844222 1699342590 33554431 33554431 1699342590 2705844222 4281414460 4287137928 4287269514 4281414460 2705844222 2705844222 2705844222 2705844222 4281414460 4287137928 4287269514 4281414460 2705844222 1699342590 33554431 33554431 1699342590 2705844222 4281414460 4287137928 4287269514 4281414460 2705844222 2705844222 2705844222 2705844222 4281414460 4287137928 4287269514 4281414460 2705844222 1699342590 33554431 33554431 1699342590 2705844222 4281414460 4286940549 4286940549 4281479996 4281414460 4281414460 4281414460 4281414460 4281414460 4286940549 4286940549 4281479996 2705844222 1699342590 452984831 33554431 1699342590 2705844222 4281414460 4286743170 4286743170 4286743170 4286743170 4286743170 4286743170 4286743170 4286743170 4286743170 4286743170 4281479996 2705844222 1699342590 33554431 33554431 2154819071 2705844222 4281414460 4286545791 4286545791 4286545791 4286545791 4286545791 4286545791 4286545791 4286545791 4286545791 4286545791 4281479996 2705844222 1699342590 33554431 33554431 1716250879 2705844222 3375444796 4281479996 4281479996 4281479996 4281479996 4281479996 4281479996 4281479996 4281479996 4281479996 4281479996 3375444796 2705844222 1699342590 33554431 33554431 1699342590 1682434302 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 1682434302 1699342590 33554431 33554431 38398206 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 71952638 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431) 429776 offset: 0@0)! ! 429777 429778!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 5/15/2007 11:08'! 429779newWindowMaximizeForm 429780 "Answer a new form for a window maximize box." 429781 429782 ^Form 429783 extent: 14@14 429784 depth: 32 429785 fromArray: #( 14410989 14476525 14476525 14410989 14410989 14410989 14476525 14410989 14279659 14213610 14016230 13950180 13818594 13687007 14476525 14476525 14476525 14476525 14476525 14410989 14410989 14410988 14279403 14213610 14016230 13950180 13818594 13687007 14476525 3377747815 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 3411302247 13687007 14345195 4283717479 4294638330 4294704123 4294704123 4294704123 4294704123 4294704123 4294704123 4294704123 4294704123 4294704123 4283717479 13358300 14082024 4283717479 4294704123 4294769916 4294769916 4294769916 4294769916 4294769916 4294769916 4294769916 4294769916 4294769916 4283717479 13029336 13490402 4283717479 4294704123 4294769916 4283783272 4283717479 4283717479 4283717479 4283717479 4283717479 4294704123 4294769916 4283717479 12371663 12964315 4283717479 4293454056 4293519849 4283717479 12503765 12569302 12437973 12306386 4283717479 4293454056 4293519849 4283717479 11582405 10859972 4283717479 4293454056 4293519849 4283717479 10399422 10464959 10268092 10070713 4283717479 4293454056 4293519849 4283717479 9017253 10662339 4283717479 4292993506 4293059298 4283717478 4283717479 4283717479 4283717479 4283717479 4283651686 4292993506 4293059298 4283717478 8688033 10728391 4283717479 4292598748 4292664540 4292598748 4292598748 4292598748 4292598748 4292598748 4292598748 4292664540 4292664540 4283717478 8819620 10794440 4283717479 4292269783 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4283717478 8951720 11057614 3377747815 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 3377747815 9280942 11517651 11583187 11517393 11385807 11320015 11122893 11057101 10925514 10662598 10531013 10267583 10070204 9938105 9806517 11978203 12175067 12043738 11846616 11846359 11649237 11583445 11451859 11188943 11122893 10793928 10662084 10529986 10201789) 429786 offset: 0@0! ! 429787 429788!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 10/27/2008 16:50'! 429789newWindowMaximizeOverForm 429790 "Answer a new form for a mouse over window maximize box." 429791 429792 ^(Form 429793 extent: 18@18 429794 depth: 32 429795 fromArray: #( 50331647 50331647 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 167772159 33554431 33554431 33554431 33554431 55175422 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 38398206 33554431 33554431 1699342590 1682434302 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 1682434302 1699342590 33554431 33554431 1699342590 2705844222 3377747815 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 3411302247 2705844222 1699342590 33554431 33554431 1699342590 2705844222 4283717479 4294638330 4294704123 4294704123 4294704123 4294704123 4294704123 4294704123 4294704123 4294704123 4294704123 4283717479 2705844222 1699342590 33554431 33554431 1699342590 2705844222 4283717479 4294704123 4294769916 4294769916 4294769916 4294769916 4294769916 4294769916 4294769916 4294769916 4294769916 4283717479 2705844222 1699342590 33554431 33554431 1699342590 2705844222 4283717479 4294704123 4294769916 4283783272 4283717479 4283717479 4283717479 4283717479 4283717479 4294704123 4294769916 4283717479 2705844222 1699342590 33554431 33554431 1699342590 2705844222 4283717479 4293454056 4293519849 4283717479 2705844222 2705844222 2705844222 2705844222 4283717479 4293454056 4293519849 4283717479 2705844222 1699342590 33554431 33554431 1699342590 2705844222 4283717479 4293454056 4293519849 4283717479 2705844222 2705844222 2705844222 2705844222 4283717479 4293454056 4293519849 4283717479 2705844222 1699342590 33554431 33554431 1699342590 2705844222 4283717479 4292993506 4293059298 4283717478 4283717479 4283717479 4283717479 4283717479 4283651686 4292993506 4293059298 4283717478 2705844222 1699342590 452984831 33554431 1699342590 2705844222 4283717479 4292598748 4292664540 4292598748 4292598748 4292598748 4292598748 4292598748 4292598748 4292664540 4292664540 4283717478 2705844222 1699342590 33554431 33554431 2154819071 2705844222 4283717479 4292269783 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4283717478 2705844222 1699342590 33554431 33554431 1716250879 2705844222 3377747815 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 3377747815 2705844222 1699342590 33554431 33554431 1699342590 1682434302 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 1682434302 1699342590 33554431 33554431 38398206 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 71952638 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431 33554431) 429796 offset: 0@0)! ! 429797 429798!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 5/15/2007 11:09'! 429799newWindowMenuForm 429800 "Answer a new form for a window menu box." 429801 429802 ^Form 429803 extent: 14@14 429804 depth: 32 429805 fromArray: #( 14410989 14476525 14476525 14410989 14410989 14410989 14476525 14410989 14279659 14213610 14016230 13950180 13818594 13687007 14476525 14476525 14476525 14476525 14476525 14410989 14410989 14410988 14279403 14213610 14016230 13950180 13818594 13687007 14476525 3360970599 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 3360970599 13687007 14345195 4283717479 4294638330 4294704123 4294704123 4294704123 4294704123 4294704123 4294704123 4294704123 4294704123 4294704123 4283717479 13358300 14082024 4283717479 4294704123 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4294769916 4294769916 4294769916 4283717479 13029336 13490402 4283717479 4294704123 4294769916 4294769916 4294769916 4294769916 4294769916 4294769916 4294769916 4294769916 4294769916 4283717479 12371663 12964315 4283717479 4293454056 4283717479 4283717479 4283717479 4293519849 4283717479 4283717479 4283717479 4293454056 4293519849 4283717479 11582405 10859972 4283717479 4293454056 4293519849 4293519849 4293519849 4293519849 4293519849 4293519849 4293519849 4293454056 4293519849 4283717479 9017253 10662339 4283717479 4292993506 4283717479 4283717479 4292993506 4283717479 4283717479 4292993506 4283717479 4292993506 4293059298 4283717478 8688033 10728391 4283717479 4292598748 4292664540 4292598748 4292598748 4292598748 4292598748 4292598748 4292598748 4292664540 4292664540 4283717478 8819620 10794440 4283717479 4292269783 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4283717478 8951720 11057614 3377747815 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 3411302247 9280942 11517651 11583187 11517393 11385807 11320015 11122893 11057101 10925514 10662598 10531013 10267583 10070204 9938105 9806517 11978203 12175067 12043738 11846616 11846359 11649237 11583445 11451859 11188943 11122893 10793928 10662084 10529986 10201789) 429806 offset: 0@0! ! 429807 429808!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 10/28/2008 15:35'! 429809newWindowMinimizeDownForm 429810 "Answer a new form for a mouse down window minimize box." 429811 429812 ^(Form 429813 extent: 18@18 429814 depth: 32 429815 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 55044350 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 55044350 0 0 1682434302 1682434302 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 1682434302 1682434302 0 0 1682434302 2705844222 3358667580 4281414460 4281414460 4281414460 4281414460 4281414460 4281414460 4281414460 4281414460 4281414460 4281414460 3408999228 2705844222 1682434302 0 0 1682434302 2705844222 4281414460 4288059030 4288059030 4288059030 4288059030 4288059030 4288059030 4288059030 4288059030 4288059030 4288059030 4281414460 2705844222 1682434302 0 0 1682434302 2705844222 4281414460 4286743170 4286743170 4286743170 4286743170 4286743170 4286743170 4286743170 4286743170 4286743170 4286743170 4281479996 2705844222 1682434302 0 0 1682434302 2705844222 4281414460 4286545791 4286545791 4286545791 4286545791 4286545791 4286545791 4286545791 4286545791 4286545791 4286545791 4281479996 2705844222 1682434302 0 0 1682434302 2705844222 3492885308 4281479996 4281479996 4281479996 4281479996 4281479996 4281479996 4281479996 4281479996 4281479996 4281479996 3560059966 2705844222 1682434302 0 0 1682434302 1682434302 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 1682434302 1682434302 0 0 71821566 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 105375998 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 429816 offset: 0@0)! ! 429817 429818!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 5/15/2007 11:09'! 429819newWindowMinimizeForm 429820 "Answer a new form for a window minimize box." 429821 429822 ^Form 429823 extent: 14@14 429824 depth: 32 429825 fromArray: #( 14345196 14345452 14345452 14410989 14410989 14410989 14410989 14410989 14410989 14410989 14410989 14410989 14410989 14410989 14410989 14410989 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14476525 14345196 14345196 14345196 14345196 14345196 14345196 14345196 14345196 14345196 14345196 14345196 14345196 14345196 14279660 14147817 14147817 14147817 14147817 14147817 14147817 14147817 14147817 14213353 14213353 14147817 14147817 14147817 14082025 13687523 13687523 13687523 13687523 13687523 13687523 13687523 13687523 13687524 13687524 13687523 13621731 13555939 13490403 13095901 13161437 13161437 13161437 13161437 13161437 13161437 13161437 13161437 13161181 13161181 13030109 12964316 12832988 11188679 3360970599 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 3411302247 10728645 10991559 4283651686 4294835709 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4283717479 10399940 11188940 4283651686 4292598748 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4283717478 10465992 11320526 4283651686 4292269783 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4283717478 10465993 11583699 3495188327 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 3562363241 10532044 11912409 11912152 11912152 11912152 11912152 11912152 11912151 11912151 11846358 11715030 11517909 11189203 10992082 10860754 12372960 12372960 12438496 12438496 12438496 12438496 12372703 12372703 12241375 12109789 11978204 11583963 11452377 11255513) 429826 offset: 0@0! ! 429827 429828!UIThemeVistary methodsFor: 'initialize-release' stamp: 'gvc 10/27/2008 13:36'! 429829newWindowMinimizeOverForm 429830 "Answer a new form for a mouse over window minimize box." 429831 429832 ^(Form 429833 extent: 18@18 429834 depth: 32 429835 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 55044350 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 55044350 0 0 1682434302 1682434302 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 1682434302 1682434302 0 0 1682434302 2705844222 3360970599 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 4283717479 3411302247 2705844222 1682434302 0 0 1682434302 2705844222 4283651686 4294835709 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4294901502 4283717479 2705844222 1682434302 0 0 1682434302 2705844222 4283651686 4292598748 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4283717478 2705844222 1682434302 0 0 1682434302 2705844222 4283651686 4292269783 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4283717478 2705844222 1682434302 0 0 1682434302 2705844222 3495188327 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 4283717478 3562363241 2705844222 1682434302 0 0 1682434302 1682434302 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 2705844222 1682434302 1682434302 0 0 71821566 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 1682434302 105375998 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 429836 offset: 0@0)! ! 429837 429838 429839!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 4/16/2007 11:14'! 429840buttonLabelForText: aTextOrString 429841 "Answer the label to use for the given text." 429842 429843 ^aTextOrString isString 429844 ifTrue: [(FuzzyLabelMorph contents: aTextOrString) 429845 alpha: 0.3] 429846 ifFalse: [super buttonLabelForText: aTextOrString]! ! 429847 429848!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 3/27/2008 21:43'! 429849configureWindowLabelAreaFor: aWindow 429850 "Configure the label area for the given window." 429851 429852 aWindow labelArea 429853 addMorphBack: (Morph new extent: aWindow class borderWidth @ 0). 429854 aWindow hasMenuBox ifTrue: [aWindow addMenuControl]. 429855 aWindow labelArea 429856 addMorphBack: (Morph new extent: aWindow class borderWidth @ 0). 429857 aWindow basicLabel ifNotNilDo: [:label | 429858 label hResizing: #spaceFill. 429859 aWindow labelArea addMorphBack: label]. 429860 aWindow hasCollapseBox ifTrue: [aWindow addCollapseBox]. 429861 aWindow hasExpandBox ifTrue: [aWindow addExpandBox]. 429862 aWindow hasCloseBox ifTrue: [aWindow addCloseBox]. 429863 aWindow labelArea 429864 addMorphBack: (Morph new extent: aWindow class borderWidth @ 0)! ! 429865 429866!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 4/21/2009 16:41'! 429867createCloseBoxFor: aSystemWindow 429868 "Answer a button for closing the window." 429869 429870 |form msb| 429871 form := self windowCloseForm. 429872 msb := MultistateButtonMorph new extent: form extent. 429873 msb activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 429874 form := self windowClosePassiveForm. 429875 msb extent: form extent. 429876 msb activeDisabledNotOverUpFillStyle: (ImageFillStyle form: form). 429877 msb passiveDisabledNotOverUpFillStyle: (ImageFillStyle form: form). 429878 msb passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 429879 form := self windowCloseOverForm. 429880 msb extent: form extent. 429881 msb 429882 activeEnabledOverUpFillStyle: (ImageFillStyle form: form); 429883 passiveEnabledOverUpFillStyle: (ImageFillStyle form: form). 429884 form := self windowCloseDownForm. 429885 msb 429886 extent: form extent; 429887 activeEnabledOverDownFillStyle: (ImageFillStyle form: form); 429888 passiveEnabledOverDownFillStyle: (ImageFillStyle form: form); 429889 addUpAction: [aSystemWindow closeBoxHit]; 429890 setBalloonText: 'close this window' translated; 429891 extent: aSystemWindow boxExtent. 429892 ^msb! ! 429893 429894!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 4/21/2009 16:14'! 429895createCollapseBoxFor: aSystemWindow 429896 "Answer a button for minimising the window." 429897 429898 |form msb| 429899 form := self windowMinimizeForm. 429900 msb := MultistateButtonMorph new extent: form extent. 429901 msb 429902 activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form); 429903 passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 429904 form := self windowMinimizeOverForm. 429905 msb extent: form extent. 429906 msb 429907 activeEnabledOverUpFillStyle: (ImageFillStyle form: form); 429908 passiveEnabledOverUpFillStyle: (ImageFillStyle form: form). 429909 form := self windowMinimizeDownForm. 429910 msb 429911 extent: form extent; 429912 activeEnabledOverDownFillStyle: (ImageFillStyle form: form); 429913 passiveEnabledOverDownFillStyle: (ImageFillStyle form: form); 429914 addUpAction: [aSystemWindow collapseBoxHit]; 429915 setBalloonText: 'collapse this window' translated; 429916 extent: aSystemWindow boxExtent. 429917 ^msb! ! 429918 429919!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 4/21/2009 16:14'! 429920createExpandBoxFor: aSystemWindow 429921 "Answer a button for maximising/restoring the window." 429922 429923 |form msb| 429924 form := self windowMaximizeForm. 429925 msb := MultistateButtonMorph new extent: form extent. 429926 msb 429927 activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form); 429928 passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 429929 form := self windowMaximizeOverForm. 429930 msb extent: form extent. 429931 msb 429932 activeEnabledOverUpFillStyle: (ImageFillStyle form: form); 429933 passiveEnabledOverUpFillStyle: (ImageFillStyle form: form). 429934 form := self windowMaximizeDownForm. 429935 msb 429936 extent: form extent; 429937 activeEnabledOverDownFillStyle: (ImageFillStyle form: form); 429938 passiveEnabledOverDownFillStyle: (ImageFillStyle form: form); 429939 addUpAction: [aSystemWindow expandBoxHit]; 429940 setBalloonText: 'expand to full screen' translated; 429941 extent: aSystemWindow boxExtent. 429942 ^msb! ! 429943 429944!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 10/17/2008 12:19'! 429945disabledItemStyle 429946 "Answer either #plain or #inset to determine how 429947 diabled text is drawn." 429948 429949 ^#inset! ! 429950 429951!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 3/26/2008 17:56'! 429952hThumbForm 429953 "Answer the form to use for horizontal thumbs." 429954 429955 ^self forms at: #hThumb ifAbsent: [Form extent: 10@10 depth: Display depth]! ! 429956 429957!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 1/7/2008 14:54'! 429958tabSelectorCellInsetFor: aTabSelector 429959 "Answer the cell inset to use for the given tab selector." 429960 429961 ^0! ! 429962 429963!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 3/26/2008 17:56'! 429964vThumbForm 429965 "Answer the form to use for vertical thumbs." 429966 429967 ^self forms at: #vThumb ifAbsent: [Form extent: 10@10 depth: Display depth]! ! 429968 429969!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 10/22/2008 13:39'! 429970windowCloseDownForm 429971 "Answer the form to use for window close buttons with mouse down and over." 429972 429973 ^self forms at: #windowCloseDown ifAbsent: [Form extent: 18@18 depth: Display depth]! ! 429974 429975!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 10/22/2008 13:38'! 429976windowCloseOverForm 429977 "Answer the form to use for window close buttons with mouse over." 429978 429979 ^self forms at: #windowCloseOver ifAbsent: [Form extent: 18@18 depth: Display depth]! ! 429980 429981!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 10/22/2008 14:46'! 429982windowClosePassiveForm 429983 "Answer the form to use for passive (background) window close buttons" 429984 429985 ^self forms at: #windowClosePassive ifAbsent: [Form extent: 14@14 depth: Display depth]! ! 429986 429987!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 5/7/2007 12:49'! 429988windowLabelForText: aStringOrText 429989 "Answer the window label to use for the given text." 429990 429991 ^FuzzyLabelMorph new 429992 contents: aStringOrText; 429993 font: Preferences windowTitleFont emphasis: 1! ! 429994 429995!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 10/28/2008 15:37'! 429996windowMaximizeDownForm 429997 "Answer the form to use for window maximise buttons with mouse down." 429998 429999 ^self forms at: #windowMaximizeDown ifAbsent: [Form extent: 18@18 depth: Display depth]! ! 430000 430001!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 10/27/2008 16:51'! 430002windowMaximizeOverForm 430003 "Answer the form to use for window maximise buttons with mouse over." 430004 430005 ^self forms at: #windowMaximizeOver ifAbsent: [Form extent: 18@18 depth: Display depth]! ! 430006 430007!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 10/28/2008 15:37'! 430008windowMinimizeDownForm 430009 "Answer the form to use for window minimise buttons with mouse down." 430010 430011 ^self forms at: #windowMinimizeDown ifAbsent: [Form extent: 18@18 depth: Display depth]! ! 430012 430013!UIThemeVistary methodsFor: 'label-styles' stamp: 'gvc 10/27/2008 13:38'! 430014windowMinimizeOverForm 430015 "Answer the form to use for window minimise buttons with mouse over." 430016 430017 ^self forms at: #windowMinimizeOver ifAbsent: [Form extent: 18@18 depth: Display depth]! ! 430018 430019 430020!UIThemeVistary methodsFor: 'morph creation' stamp: 'gvc 8/8/2007 16:56'! 430021newDropListIn: aThemedMorph for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 430022 "Answer a drop list for the given model." 430023 430024 ^(super 430025 newDropListIn: aThemedMorph 430026 for: aModel 430027 list: listSel 430028 getSelected: getSel 430029 setSelected: setSel 430030 getEnabled: enabledSel 430031 useIndex: useIndex 430032 help: helpText) 430033 roundedCorners: #(1 2)! ! 430034 430035!UIThemeVistary methodsFor: 'morph creation' stamp: 'gvc 8/8/2007 16:57'! 430036newMorphDropListIn: aThemedMorph for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 430037 "Answer a morph drop list for the given model." 430038 430039 ^(super 430040 newMorphDropListIn: aThemedMorph 430041 for: aModel 430042 list: listSel 430043 getSelected: getSel 430044 setSelected: setSel 430045 getEnabled: enabledSel 430046 useIndex: useIndex 430047 help: helpText) 430048 roundedCorners: #(1 2)! ! 430049 430050!UIThemeVistary methodsFor: 'morph creation' stamp: 'gvc 3/2/2009 12:31'! 430051newTaskbarThumbnailIn: aThemedMorph for: aWindow 430052 "Answer a taskbar thumbnail morph for the given window." 430053 430054 |answer thumb| 430055 thumb := aWindow taskbarThumbnail. 430056 answer := PanelMorph new 430057 hResizing: #shrinkWrap; 430058 vResizing: #shrinkWrap; 430059 changeTableLayout; 430060 layoutInset: 8; 430061 cellInset: 4; 430062 addMorphBack: thumb; 430063 addMorphBack: ((self 430064 buttonLabelForText: (aWindow labelString truncateWithElipsisTo: 50)) 430065 color: Color white). 430066 answer 430067 extent: answer minExtent; 430068 fillStyle: (self tasklistFillStyleFor: answer); 430069 borderStyle: (self taskbarThumbnailNormalBorderStyleFor: aWindow); 430070 cornerStyle: (self taskbarThumbnailCornerStyleFor: answer). 430071 ^answer 430072 ! ! 430073 430074"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 430075 430076UIThemeVistary class 430077 instanceVariableNames: ''! 430078 430079!UIThemeVistary class methodsFor: 'as yet unclassified' stamp: 'gvc 6/22/2007 14:26'! 430080isAbstract 430081 "Answer whether the receiver is considered to be abstract." 430082 430083 ^false! ! 430084 430085!UIThemeVistary class methodsFor: 'as yet unclassified' stamp: 'gvc 10/16/2008 16:08'! 430086newDefaultSettings 430087 "Answer a new original default settings." 430088 430089 ^super newDefaultSettings 430090 autoSelectionColor: false; 430091 windowColor: (Color r: 0.675 g: 0.76 b: 0.838); 430092 selectionColor: (Color r: 62 g: 142 b: 220 range: 255); 430093 buttonColor: Color black; 430094 scrollbarColor: Color black; 430095 progressBarProgressColor: (Color r: 0.544 g: 0.819 b: 0.09)! ! 430096 430097!UIThemeVistary class methodsFor: 'as yet unclassified' stamp: 'gvc 6/22/2007 15:19'! 430098themeName 430099 "Answer the friendly name of the theme." 430100 430101 ^'Vistary'! ! 430102UITheme subclass: #UIThemeW2K 430103 instanceVariableNames: '' 430104 classVariableNames: '' 430105 poolDictionaries: '' 430106 category: 'Polymorph-Widgets-Themes'! 430107 430108!UIThemeW2K methodsFor: 'basic-colors' stamp: 'SS 1/1/2009 07:33'! 430109backgroundColor 430110 430111 ^Color h: 40.0 s: 0.06 v: 0.83! ! 430112 430113!UIThemeW2K methodsFor: 'basic-colors' stamp: 'SS 1/1/2009 10:46'! 430114dialogWindowActiveFillStyleFor: aWindow 430115 "Return the dialog window active fillStyle for the given window." 430116 430117 ^self backgroundColor! ! 430118 430119!UIThemeW2K methodsFor: 'basic-colors' stamp: 'SS 1/1/2009 10:47'! 430120dialogWindowInactiveFillStyleFor: aWindow 430121 "Return the dialog window active fillStyle for the given window." 430122 430123 ^self backgroundColor! ! 430124 430125!UIThemeW2K methodsFor: 'basic-colors' stamp: 'SS 1/1/2009 11:44'! 430126paneColor 430127 ^self backgroundColor! ! 430128 430129!UIThemeW2K methodsFor: 'basic-colors' stamp: 'SS 1/1/2009 16:01'! 430130resizerGripNormalFillStyleFor: aResizer 430131 "Return the normal fillStyle for the given resizer. 430132 For the moment, answer a transparent colour for no drawing, 430133 non transparent to draw as normal." 430134 430135 ^Color transparent! ! 430136 430137!UIThemeW2K methodsFor: 'basic-colors' stamp: 'SS 1/1/2009 16:29'! 430138scrollbarColorFor: aScrollbar 430139 "Answer the colour for the given scrollbar." 430140 430141 ^self backgroundColor.! ! 430142 430143!UIThemeW2K methodsFor: 'basic-colors' stamp: 'SS 1/1/2009 11:48'! 430144selectionColor 430145 "Answer the window color to use." 430146 430147 ^self backgroundColor! ! 430148 430149!UIThemeW2K methodsFor: 'basic-colors' stamp: 'SS 1/1/2009 13:14'! 430150subgroupColorFrom: paneColor 430151 "Answer the colour for a subgroup given the pane colour." 430152 430153 ^paneColor! ! 430154 430155!UIThemeW2K methodsFor: 'basic-colors' stamp: 'SS 1/1/2009 11:47'! 430156windowColor 430157 "Answer the window color to use." 430158 430159 ^self backgroundColor! ! 430160 430161!UIThemeW2K methodsFor: 'basic-colors' stamp: 'SS 1/1/2009 09:59'! 430162windowColorFor: aWindowOrModel 430163 "Answer the colour for the given window." 430164 430165 "^self class windowColor." 430166 ^self backgroundColor! ! 430167 430168 430169!UIThemeW2K methodsFor: 'border-styles' stamp: 'SS 1/1/2009 10:58'! 430170configureWindowBorderFor: aWindow 430171 "Configure the border for the given window." 430172 430173 "aWindow roundedCorners: #(1 2 3 4)" 430174 | aStyle | 430175 430176 430177 aStyle := BorderStyle complexRaised. 430178 aStyle width: 2. 430179 aStyle color: self backgroundColor. 430180 aStyle baseColor: self backgroundColor. 430181 430182 aWindow borderStyle: aStyle. 430183 430184 430185! ! 430186 430187!UIThemeW2K methodsFor: 'border-styles' stamp: 'gvc 6/2/2009 12:22'! 430188dropListNormalBorderStyleFor: aDropList 430189 "Return the normal borderStyle for the given drop list" 430190 430191 | aStyle | 430192 aStyle := BorderStyle complexInset. 430193 aStyle width: 2. 430194 aStyle color: self backgroundColor. 430195 aStyle baseColor: self backgroundColor. 430196 ^aStyle! ! 430197 430198!UIThemeW2K methodsFor: 'border-styles' stamp: 'gvc 6/2/2009 12:18'! 430199dropListNormalListBorderStyleFor: aDropList 430200 "Return the normal borderStyle for the given drop list" 430201 430202 ^BorderStyle inset 430203 width: 1; 430204 baseColor: Color black! ! 430205 430206!UIThemeW2K methodsFor: 'border-styles' stamp: 'gvc 6/1/2009 15:19'! 430207listFocusBoundsFor: aListMorph 430208 "Answer the bounds for drawing the focus indication." 430209 430210 ^aListMorph innerBounds! ! 430211 430212!UIThemeW2K methodsFor: 'border-styles' stamp: 'gvc 6/2/2009 13:22'! 430213listNormalBorderStyleFor: aList 430214 "Return the normal borderStyle for the given list" 430215 430216 | aStyle | 430217 aStyle := BorderStyle complexInset. 430218 aStyle width: 2. 430219 aStyle color: self backgroundColor. 430220 aStyle baseColor: self backgroundColor. 430221 ^aStyle! ! 430222 430223!UIThemeW2K methodsFor: 'border-styles' stamp: 'SS 1/1/2009 11:14'! 430224textEditorNormalBorderStyleFor: aTextEditor 430225 "Return the normal text editor borderStyle for the given text editor." 430226 430227 | aStyle | 430228 aStyle := BorderStyle complexInset. 430229 aStyle width: 2. 430230 aStyle color: self backgroundColor. 430231 aStyle baseColor: self backgroundColor. 430232 ^aStyle! ! 430233 430234!UIThemeW2K methodsFor: 'border-styles' stamp: 'SS 1/1/2009 11:58'! 430235textEntryCornerStyleIn: aThemedMorph 430236 "Answer the corner style to use for text entry morphs." 430237 430238 ^#square! ! 430239 430240!UIThemeW2K methodsFor: 'border-styles' stamp: 'gvc 6/2/2009 12:16'! 430241textFocusBoundsFor: aPluggableTextMorph 430242 "Answer the bounds for drawing the focus indication." 430243 430244 ^aPluggableTextMorph innerBounds! ! 430245 430246!UIThemeW2K methodsFor: 'border-styles' stamp: 'SS 1/1/2009 11:45'! 430247windowShadowColor 430248 "Answer the window shadow color to use." 430249 430250 ^Color transparent.! ! 430251 430252 430253!UIThemeW2K methodsFor: 'border-styles-buttons' stamp: 'SS 1/1/2009 09:20'! 430254buttonCornerStyleIn: aThemedMorph 430255 "Allow for themes to override default behaviour." 430256 430257 ^#square! ! 430258 430259!UIThemeW2K methodsFor: 'border-styles-buttons' stamp: 'gvc 6/15/2009 12:12'! 430260buttonNormalBorderStyleFor: aButton 430261 "Return the normal button borderStyle for the given button." 430262 430263 | aStyle | 430264 aButton isDefault ifTrue: [^self buttonNormalDefaultBorderStyle]. 430265 aStyle := BorderStyle complexRaised. 430266 aStyle width: 2. 430267 aStyle color: self backgroundColor. 430268 ^aStyle.! ! 430269 430270!UIThemeW2K methodsFor: 'border-styles-buttons' stamp: 'gvc 6/15/2009 12:15'! 430271buttonNormalDefaultBorderStyle 430272 "Answer the border style for default buttons." 430273 430274 | aComp theBorders | 430275 aComp := CompositeBorder new. 430276 aComp width: 2. 430277 theBorders := OrderedCollection new. 430278 theBorders add: (SimpleBorder color: Color black width: 1). 430279 theBorders add: (BorderStyle raised color: (Color gray: 0.80); width: 1). 430280 aComp borders: theBorders. 430281 ^aComp! ! 430282 430283!UIThemeW2K methodsFor: 'border-styles-buttons' stamp: 'SS 1/1/2009 10:12'! 430284buttonPressedBorderStyleFor: aButton 430285 "Return the normal button borderStyle for the given button." 430286 430287 | aStyle | 430288 aStyle := BorderStyle complexInset. 430289 aStyle width: 2. 430290 aStyle color: self backgroundColor. 430291 ^aStyle.! ! 430292 430293!UIThemeW2K methodsFor: 'border-styles-buttons' stamp: 'gvc 6/15/2009 12:14'! 430294buttonSelectedBorderStyleFor: aButton 430295 "Return the selected button borderStyle for the given button." 430296 430297 aButton isDefault ifTrue: [^self buttonSelectedDefaultBorderStyle]. 430298 ^self buttonPressedBorderStyleFor: aButton! ! 430299 430300!UIThemeW2K methodsFor: 'border-styles-buttons' stamp: 'gvc 6/15/2009 12:10'! 430301buttonSelectedDefaultBorderStyle 430302 "Answer the border style for selected default buttons." 430303 430304 | aComp theBorders | 430305 aComp := CompositeBorder new. 430306 aComp width: 2. 430307 theBorders := OrderedCollection new. 430308 theBorders add: (SimpleBorder color: Color black width: 1). 430309 theBorders add: (BorderStyle inset color: (Color gray: 0.50); width: 1). 430310 aComp borders: theBorders. 430311 ^aComp! ! 430312 430313!UIThemeW2K methodsFor: 'border-styles-buttons' stamp: 'SS 1/1/2009 11:42'! 430314checkboxButtonDisabledBorderStyleFor: aCheckboxButton 430315 "Return the disabled checkbox button borderStyle for the given button." 430316 430317 ^self checkboxButtonNormalBorderStyleFor: aCheckboxButton.! ! 430318 430319!UIThemeW2K methodsFor: 'border-styles-buttons' stamp: 'gvc 6/2/2009 16:11'! 430320checkboxButtonNormalBorderStyleFor: aCheckboxButton 430321 "Return the normal checkbox button borderStyle for the given button." 430322 430323 | aStyle | 430324 aStyle := BorderStyle complexInset. 430325 aStyle width: 2. 430326 aStyle color: self backgroundColor. 430327 aStyle baseColor: self backgroundColor. 430328 ^aStyle! ! 430329 430330!UIThemeW2K methodsFor: 'border-styles-buttons' stamp: 'gvc 6/2/2009 16:15'! 430331radioButtonDisabledBorderStyleFor: aRadioButton 430332 "Return the disabled radio button borderStyle for the given button." 430333 430334 ^self radioButtonNormalBorderStyleFor: aRadioButton! ! 430335 430336!UIThemeW2K methodsFor: 'border-styles-buttons' stamp: 'SS 1/1/2009 11:51'! 430337radioButtonNormalBorderStyleFor: aRadioButton 430338 "Return the disabled radio button borderStyle for the given button." 430339 430340 ^BorderStyle simple 430341 width: 1; 430342 baseColor: Color black! ! 430343 430344 430345!UIThemeW2K methodsFor: 'border-styles-scrollbars' stamp: 'gvc 6/15/2009 12:13'! 430346scrollbarNormalThumbBorderStyleFor: aScrollbar 430347 "Return the normal button borderStyle for the given scrollbar." 430348 430349 | aStyle | 430350 aStyle := BorderStyle complexRaised. 430351 aStyle width: 2. 430352 aStyle color: self backgroundColor. 430353 ^aStyle! ! 430354 430355!UIThemeW2K methodsFor: 'border-styles-scrollbars' stamp: 'gvc 6/15/2009 12:13'! 430356scrollbarPressedButtonBorderStyleFor: aScrollbar 430357 "Return the pressed button borderStyle for the given scrollbar." 430358 430359 | aStyle | 430360 aStyle := BorderStyle complexInset. 430361 aStyle width: 2. 430362 aStyle color: self backgroundColor. 430363 ^aStyle! ! 430364 430365 430366!UIThemeW2K methodsFor: 'defaults' stamp: 'gvc 6/15/2009 12:20'! 430367buttonLabelInsetFor: aButton 430368 "Answer the inset to use for a button's label." 430369 430370 ^(aButton showSelectionFeedback xor: aButton getModelState) 430371 ifTrue: [3@3 corner: 1@1] 430372 ifFalse: [2]! ! 430373 430374!UIThemeW2K methodsFor: 'defaults' stamp: 'gvc 6/2/2009 10:19'! 430375dialogWindowPreferredCornerStyleFor: aDialogWindow 430376 "Answer the preferred corner style for the given dialog." 430377 430378 ^#square! ! 430379 430380!UIThemeW2K methodsFor: 'defaults' stamp: 'gvc 6/2/2009 16:32'! 430381dropListControlButtonWidth 430382 "Answer the width of a drop list control button for this theme." 430383 430384 ^17! ! 430385 430386!UIThemeW2K methodsFor: 'defaults' stamp: 'gvc 6/1/2009 13:28'! 430387expanderTitleControlButtonWidth 430388 "Answer the width of an expander title control button for this theme." 430389 430390 ^19! ! 430391 430392!UIThemeW2K methodsFor: 'defaults' stamp: 'gvc 6/2/2009 10:19'! 430393windowPreferredCornerStyleFor: aWindow 430394 "Answer the preferred corner style for the given window." 430395 430396 ^#square! ! 430397 430398 430399!UIThemeW2K methodsFor: 'fill-styles' stamp: 'gvc 6/2/2009 16:03'! 430400tasklistFillStyleFor: aTasklist 430401 "Return the tasklist fillStyle for the given tasklist." 430402 430403 ^Color r: 0.478 g: 0.611 b: 0.796! ! 430404 430405!UIThemeW2K methodsFor: 'fill-styles' stamp: 'SS 1/1/2009 12:04'! 430406windowActiveFillStyleFor: aWindow 430407 "Return the window inactive fillStyle for the given window." 430408 430409 ^self windowColorFor: aWindow! ! 430410 430411!UIThemeW2K methodsFor: 'fill-styles' stamp: 'gvc 6/15/2009 13:05'! 430412windowActiveLabelFillStyleFor: aWindow 430413 "Return the window active label fillStyle for the given window." 430414 430415 ^Color white! ! 430416 430417!UIThemeW2K methodsFor: 'fill-styles' stamp: 'SS 1/1/2009 11:31'! 430418windowActiveTitleFillStyleFor: aWindow 430419 "Return the window active title fillStyle for the given window." 430420 430421 |aColor aLColor | 430422 aColor := Color h: 224 s: 0.91 v: 0.42. 430423 aLColor := Color h: 211 s: 0.31 v: 0.94. 430424 ^(GradientFillStyle ramp: {0.0 -> aColor. 1.0 -> aLColor }) 430425 origin: aWindow topLeft; 430426 direction: aWindow width @ 0; 430427 radial: false 430428! ! 430429 430430!UIThemeW2K methodsFor: 'fill-styles' stamp: 'gvc 6/2/2009 16:07'! 430431windowExtentChangedFor: aWindow 430432 "Update any extent related visuals." 430433 430434 aWindow setStripeColorsFrom: aWindow paneColor! ! 430435 430436!UIThemeW2K methodsFor: 'fill-styles' stamp: 'SS 1/1/2009 12:04'! 430437windowInactiveFillStyleFor: aWindow 430438 "Return the window inactive fillStyle for the given window." 430439 430440 ^self windowActiveFillStyleFor: aWindow! ! 430441 430442!UIThemeW2K methodsFor: 'fill-styles' stamp: 'gvc 6/15/2009 13:06'! 430443windowInactiveLabelFillStyleFor: aWindow 430444 "Return the window inactive label fillStyle for the given window." 430445 430446 ^Color gray: 0.8! ! 430447 430448!UIThemeW2K methodsFor: 'fill-styles' stamp: 'SS 1/1/2009 11:31'! 430449windowInactiveTitleFillStyleFor: aWindow 430450 "Return the window inactive title fillStyle for the given window." 430451 430452 |aColor aLColor | 430453 430454 aColor := Color gray. 430455 aLColor := Color h: 0 s: 0 v: 0.75. 430456 ^(GradientFillStyle ramp: {0.0 -> aColor. 1.0 -> aLColor }) 430457 origin: aWindow topLeft; 430458 direction: aWindow width @ 0; 430459 radial: false 430460! ! 430461 430462 430463!UIThemeW2K methodsFor: 'fill-styles-buttons' stamp: 'SS 1/1/2009 09:57'! 430464buttonSelectedFillStyleFor: aButton 430465 "Return the button selected fillStyle for the given color." 430466 430467 ^Color gray lighter lighter lighter lighter! ! 430468 430469!UIThemeW2K methodsFor: 'fill-styles-buttons' stamp: 'gvc 6/15/2009 15:45'! 430470menuItemInDockingBarSelectedFillStyleFor: aMenuItem 430471 "Answer the selected fill style to use for the given menu item that is in a docking bar." 430472 430473 ^self menuItemSelectedFillStyleFor: aMenuItem! ! 430474 430475!UIThemeW2K methodsFor: 'fill-styles-buttons' stamp: 'gvc 6/15/2009 12:50'! 430476menuItemSelectedFillStyleFor: aMenuItem 430477 "Answer the selected fill style to use for the given menu item." 430478 430479 ^Color h: 224 s: 0.91 v: 0.42! ! 430480 430481 430482!UIThemeW2K methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 6/15/2009 11:51'! 430483scrollbarNormalFillStyleFor: aScrollbar 430484 "Return the normal scrollbar fillStyle for the given scrollbar." 430485 430486 |aColor| 430487 aColor := self scrollbarColorFor: aScrollbar. 430488 ^aColor alphaMixed: 0.4 with: Color white! ! 430489 430490!UIThemeW2K methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 6/15/2009 11:52'! 430491useScrollbarThumbShadow 430492 "Answer whether a shadow morph should be displayed when 430493 dragging a scrollbar thumb." 430494 430495 ^false! ! 430496 430497 430498!UIThemeW2K methodsFor: 'groupbox' stamp: 'SS 1/1/2009 13:25'! 430499newGroupboxIn: aThemedMorph 430500 "Answer a plain groupbox." 430501 430502 ^PlainGroupboxMorph new 430503 cornerStyle: #square; 430504 hResizing: #spaceFill; 430505 vResizing: #spaceFill; 430506 yourself! ! 430507 430508!UIThemeW2K methodsFor: 'groupbox' stamp: 'gvc 6/2/2009 11:52'! 430509newGroupboxIn: aThemedMorph label: aString 430510 "Answer a groupbox with the given label." 430511 430512 |aMorph | 430513 430514 aMorph := W2KGroupboxMorph new 430515 font: self labelFont; 430516 cornerStyle: #square; 430517 hResizing: #spaceFill; 430518 vResizing: #spaceFill; 430519 label: aString; 430520 yourself. 430521 430522 aMorph borderStyle: W2KGroupBorder new. 430523 ^aMorph! ! 430524 430525!UIThemeW2K methodsFor: 'groupbox' stamp: 'gvc 6/2/2009 11:51'! 430526plainGroupPanelBorderStyleFor: aGroupPanel 430527 "Answer the normal border style for a plain group panel." 430528 430529 ^W2KGroupBorder new! ! 430530 430531 430532!UIThemeW2K methodsFor: 'icons' stamp: 'gvc 6/1/2009 13:01'! 430533dropListButtonLabelFor: aDropList 430534 "Answer the label for the button." 430535 430536 |aMorph| 430537 aMorph := AlphaImageMorph new image: (self dropListDownArrowForm). 430538 aMorph enabled: aDropList enabled. 430539 ^aMorph 430540! ! 430541 430542!UIThemeW2K methodsFor: 'icons' stamp: 'gvc 6/1/2009 13:02'! 430543dropListDownArrowForm 430544 "Answer the form to use for window close buttons with mouse down and over." 430545 430546 ^self forms at: #dropListDownArrow ifAbsent: [Form extent: 7@7 depth: Display depth]! ! 430547 430548!UIThemeW2K methodsFor: 'icons' stamp: 'gvc 6/1/2009 12:58'! 430549initializeForms 430550 "Initialize the receiver's image forms." 430551 430552 super initializeForms. 430553 self forms 430554 at: #windowCloseDown put: self newWindowCloseDownForm; 430555 at: #windowMinimizeDown put: self newWindowMinimizeDownForm; 430556 at: #windowMaximizeDown put: self newWindowMaximizeDownForm; 430557 at: #dropListDownArrow put: self newDropListDownArrowForm! ! 430558 430559!UIThemeW2K methodsFor: 'icons' stamp: 'gvc 6/8/2009 15:31'! 430560newDropListDownArrowForm 430561 "Answer a new black down arrow." 430562 430563 ^self scrollbarArrowOfDirection: #bottom size: 15 color: Color black! ! 430564 430565!UIThemeW2K methodsFor: 'icons' stamp: 'SS 1/1/2009 11:21'! 430566newWindowCloseDownForm 430567 430568 ^((ColorForm 430569 extent: 16@14 430570 depth: 8 430571 fromArray: #( 16843009 16843009 16843009 16843012 16908802 33686018 33686018 33686276 16909059 50529027 50529027 50529028 16909059 50529027 50529027 50529028 16909059 50331651 50529024 197380 16909059 50528256 50528256 50529028 16909059 50529024 3 50529028 16909059 50529027 771 50529028 16909059 50529024 3 50529028 16909059 50528256 50528256 50529028 16909059 50331651 50529024 197380 16909059 50529027 50529027 50529028 16974595 50529027 50529027 50529028 67372036 67372036 67372036 67372036) 430572 offset: 0@0) 430573 colorsFromArray: #(#(0.0 0.0 0.0) #(0.25 0.25 0.25) #(0.501 0.501 0.501) #(0.831 0.815 0.784) #(1.0 1.0 1.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))! ! 430574 430575!UIThemeW2K methodsFor: 'icons' stamp: 'SS 1/1/2009 10:57'! 430576newWindowCloseForm 430577 ^((ColorForm 430578 extent: 16@14 430579 depth: 8 430580 fromArray: #( 67372036 67372036 67372036 67372033 67306243 50529027 50529027 50528769 67306243 50529027 50529027 50528769 67306243 771 50528256 50528769 67306243 50331651 50331651 50528769 67306243 50528256 771 50528769 67306243 50529024 197379 50528769 67306243 50528256 771 50528769 67306243 50331651 50331651 50528769 67306243 771 50528256 50528769 67306243 50529027 50529027 50528769 67306243 50529027 50529027 50528769 67240450 33686018 33686018 33686017 16843009 16843009 16843009 16843009) 430581 offset: 0@0) 430582 colorsFromArray: #(#(0.0 0.0 0.0) #(0.25 0.25 0.25) #(0.501 0.501 0.501) #(0.831 0.815 0.784) #(1.0 1.0 1.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))! ! 430583 430584!UIThemeW2K methodsFor: 'icons' stamp: 'SS 1/1/2009 11:49'! 430585newWindowMaximizeDownForm 430586 430587 ^((ColorForm 430588 extent: 16@14 430589 depth: 8 430590 fromArray: #( 16843009 16843009 16843009 16843012 16908802 33686018 33686018 33686276 16909059 50529027 50529027 50529028 16909059 0 0 197380 16909059 0 0 197380 16909059 197379 50529027 197380 16909059 197379 50529027 197380 16909059 197379 50529027 197380 16909059 197379 50529027 197380 16909059 197379 50529027 197380 16909059 197379 50529027 197380 16909059 0 0 197380 16974595 50529027 50529027 50529028 67372036 67372036 67372036 67372036) 430591 offset: 0@0) 430592 colorsFromArray: #(#(0.0 0.0 0.0) #(0.25 0.25 0.25) #(0.501 0.501 0.501) #(0.831 0.815 0.784) #(1.0 1.0 1.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))! ! 430593 430594!UIThemeW2K methodsFor: 'icons' stamp: 'SS 1/1/2009 12:17'! 430595newWindowMaximizeForm 430596 430597 ^((ColorForm 430598 extent: 16@14 430599 depth: 8 430600 fromArray: #( 67372036 67372036 67372036 67372033 67306243 50529027 50529027 50528769 67306240 0 0 50528769 67306240 0 0 50528769 67306240 50529027 50529024 50528769 67306240 50529027 50529024 50528769 67306240 50529027 50529024 50528769 67306240 50529027 50529024 50528769 67306240 50529027 50529024 50528769 67306240 50529027 50529024 50528769 67306240 0 0 50528769 67306243 50529027 50529027 50528769 67240450 33686018 33686018 33686017 16843009 16843009 16843009 16843009) 430601 offset: 0@0) 430602 colorsFromArray: #(#(0.0 0.0 0.0) #(0.25 0.25 0.25) #(0.501 0.501 0.501) #(0.831 0.815 0.784) #(1.0 1.0 1.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))! ! 430603 430604!UIThemeW2K methodsFor: 'icons' stamp: 'SS 1/1/2009 12:09'! 430605newWindowMinimizeDownForm 430606 430607 ^((ColorForm 430608 extent: 16@14 430609 depth: 8 430610 fromArray: #( 16843009 16843009 16843009 16843012 16908802 33686018 33686018 33686276 16909059 50529027 50529027 50529028 16909059 50529027 50529027 50529028 16909059 50529027 50529027 50529028 16909059 50529027 50529027 50529028 16909059 50529027 50529027 50529028 16909059 50529027 50529027 50529028 16909059 50529027 50529027 50529028 16909059 50529027 50529027 50529028 16909059 50331648 3 50529028 16909059 50331648 3 50529028 16974595 50529027 50529027 50529028 67372036 67372036 67372036 67372036) 430611 offset: 0@0) 430612 colorsFromArray: #(#(0.0 0.0 0.0) #(0.25 0.25 0.25) #(0.501 0.501 0.501) #(0.831 0.815 0.784) #(1.0 1.0 1.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))! ! 430613 430614!UIThemeW2K methodsFor: 'icons' stamp: 'SS 1/1/2009 12:13'! 430615newWindowMinimizeForm 430616 430617 ^((ColorForm 430618 extent: 16@14 430619 depth: 8 430620 fromArray: #( 67372036 67372036 67372036 67372033 67306243 50529027 50529027 50528769 67306243 50529027 50529027 50528769 67306243 50529027 50529027 50528769 67306243 50529027 50529027 50528769 67306243 50529027 50529027 50528769 67306243 50529027 50529027 50528769 67306243 50529027 50529027 50528769 67306243 50529027 50529027 50528769 67306243 0 771 50528769 67306243 0 771 50528769 67306243 50529027 50529027 50528769 67240450 33686018 33686018 33686017 16843009 16843009 16843009 16843009) 430621 offset: 0@0) 430622 colorsFromArray: #(#(0.0 0.0 0.0) #(0.25 0.25 0.25) #(0.501 0.501 0.501) #(0.831 0.815 0.784) #(1.0 1.0 1.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))! ! 430623 430624!UIThemeW2K methodsFor: 'icons' stamp: 'SS 1/1/2009 11:16'! 430625windowCloseDownForm 430626 "Answer the form to use for window close buttons with mouse down and over." 430627 430628 ^self forms at: #windowCloseDown ifAbsent: [Form extent: 18@18 depth: Display depth]! ! 430629 430630!UIThemeW2K methodsFor: 'icons' stamp: 'SS 1/1/2009 11:53'! 430631windowMaximizeDownForm 430632 "Answer the form to use for window close buttons with mouse down and over." 430633 430634 ^self forms at: #windowMaximizeDown ifAbsent: [Form extent: 18@18 depth: Display depth]! ! 430635 430636!UIThemeW2K methodsFor: 'icons' stamp: 'SS 1/1/2009 11:53'! 430637windowMinimizeDownForm 430638 "Answer the form to use for window close buttons with mouse down and over." 430639 430640 ^self forms at: #windowMinimizeDown ifAbsent: [Form extent: 18@18 depth: Display depth]! ! 430641 430642 430643!UIThemeW2K methodsFor: 'initialize-release' stamp: 'gvc 6/1/2009 11:58'! 430644initializeLabelAreaFor: aWindow 430645 430646 | windowBorderWidth frame | 430647 super initializeLabelAreaFor: aWindow. 430648 windowBorderWidth := aWindow class borderWidth. 430649 aWindow labelArea 430650 layoutInset: (0@windowBorderWidth corner: 1@1). 430651 frame := LayoutFrame 430652 fractions: (0@0 corner: 1@0) 430653 offsets: (0 @ (aWindow labelHeight negated + 1) corner: -2 @ windowBorderWidth negated). 430654 aWindow labelArea layoutFrame: frame! ! 430655 430656 430657!UIThemeW2K methodsFor: 'label-styles' stamp: 'gvc 6/2/2009 10:49'! 430658configureDialogWindowLabelAreaFrameFor: aWindow 430659 "Configure the layout frame for the label area for the given dialog window." 430660 430661 |frame| 430662 self configureWindowLabelAreaFrameFor: aWindow. 430663 aWindow labelArea ifNil: [^ self]. 430664 frame := aWindow labelArea layoutFrame. 430665 frame 430666 leftOffset: -1; 430667 rightOffset: -1! ! 430668 430669!UIThemeW2K methodsFor: 'label-styles' stamp: 'gvc 6/1/2009 13:33'! 430670configureWindowLabelAreaFor: aWindow 430671 "Configure the label area for the given window." 430672 430673 aWindow labelArea 430674 addMorphBack: (Morph new extent: aWindow class borderWidth @ 0). 430675 aWindow hasMenuBox ifTrue: [aWindow addMenuControl]. 430676 aWindow labelArea 430677 addMorphBack: (Morph new extent: aWindow class borderWidth @ 0). 430678 aWindow basicLabel ifNotNilDo: [:label | 430679 label hResizing: #spaceFill. 430680 aWindow labelArea addMorphBack: label]. 430681 aWindow hasCollapseBox ifTrue: [aWindow addCollapseBox]. 430682 aWindow hasExpandBox ifTrue: [aWindow addExpandBox]. 430683 aWindow hasCloseBox ifTrue: [ 430684 aWindow labelArea 430685 addMorphBack: (Morph new extent: 2@0). 430686 aWindow addCloseBox]. 430687 aWindow labelArea 430688 addMorphBack: (Morph new extent: aWindow class borderWidth @ 0)! ! 430689 430690!UIThemeW2K methodsFor: 'label-styles' stamp: 'gvc 6/1/2009 12:15'! 430691configureWindowLabelAreaFrameFor: aWindow 430692 "Configure the layout frame for the label area for the given window." 430693 430694 | windowBorderWidth frame | 430695 super configureWindowLabelAreaFrameFor: aWindow. 430696 windowBorderWidth := aWindow class borderWidth. 430697 aWindow labelArea 430698 cellPositioning: #center; 430699 layoutInset: (0@2 corner: -2@1). 430700 frame := LayoutFrame 430701 fractions: (0@0 corner: 1@0) 430702 offsets: (0 @ (aWindow labelHeight negated + 1) corner: -2 @ windowBorderWidth negated). 430703 aWindow labelArea layoutFrame: frame! ! 430704 430705!UIThemeW2K methodsFor: 'label-styles' stamp: 'SS 1/1/2009 11:35'! 430706createCloseBoxFor: aSystemWindow 430707 "Answer a button for closing the window." 430708 430709 |form msb| 430710 form := self windowCloseForm. 430711 msb := MultistateButtonMorph new extent: form extent. 430712 msb activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 430713 msb passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 430714 msb activeEnabledOverUpFillStyle: (ImageFillStyle form: form). 430715 msb passiveEnabledOverUpFillStyle: (ImageFillStyle form: form). 430716 430717 form := self windowCloseDownForm. 430718 msb activeEnabledOverDownFillStyle: (ImageFillStyle form: form). 430719 msb passiveEnabledOverDownFillStyle: (ImageFillStyle form: form). 430720 msb addUpAction: [aSystemWindow closeBoxHit]. 430721 msb setBalloonText: 'close' translated. 430722 " extent: aSystemWindow boxExtent." 430723 ^msb! ! 430724 430725!UIThemeW2K methodsFor: 'label-styles' stamp: 'SS 1/1/2009 12:00'! 430726createCollapseBoxFor: aSystemWindow 430727 "Answer a button for closing the window." 430728 430729 |form msb| 430730 form := self windowMinimizeForm. 430731 msb := MultistateButtonMorph new extent: form extent. 430732 msb activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 430733 msb passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 430734 msb activeEnabledOverUpFillStyle: (ImageFillStyle form: form). 430735 msb passiveEnabledOverUpFillStyle: (ImageFillStyle form: form). 430736 430737 form := self windowMinimizeDownForm. 430738 msb activeEnabledOverDownFillStyle: (ImageFillStyle form: form). 430739 msb passiveEnabledOverDownFillStyle: (ImageFillStyle form: form). 430740 msb addUpAction: [aSystemWindow collapseBoxHit ]. 430741 msb setBalloonText: 'minimize' translated. 430742 " extent: aSystemWindow boxExtent." 430743 ^msb! ! 430744 430745!UIThemeW2K methodsFor: 'label-styles' stamp: 'SS 1/1/2009 12:04'! 430746createExpandBoxFor: aSystemWindow 430747 "Answer a button for closing the window." 430748 430749 |form msb| 430750 form := self windowMaximizeForm. 430751 msb := MultistateButtonMorph new extent: form extent. 430752 msb activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 430753 msb passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 430754 msb activeEnabledOverUpFillStyle: (ImageFillStyle form: form). 430755 msb passiveEnabledOverUpFillStyle: (ImageFillStyle form: form). 430756 430757 form := self windowMaximizeDownForm. 430758 msb activeEnabledOverDownFillStyle: (ImageFillStyle form: form). 430759 msb passiveEnabledOverDownFillStyle: (ImageFillStyle form: form). 430760 msb addUpAction: [aSystemWindow expandBoxHit]. 430761 msb setBalloonText: 'maximize' translated. 430762 " extent: aSystemWindow boxExtent." 430763 ^msb! ! 430764 430765!UIThemeW2K methodsFor: 'label-styles' stamp: 'gvc 6/15/2009 12:55'! 430766disabledItemStyle 430767 "Answer either #plain or #inset to determine how 430768 disabled text is drawn." 430769 430770 ^#inset! ! 430771 430772 430773!UIThemeW2K methodsFor: 'menus' stamp: 'SW 5/22/2009 13:25'! 430774menuColor 430775 "Answer the menu color to use." 430776 430777 ^self backgroundColor! ! 430778 430779!UIThemeW2K methodsFor: 'menus' stamp: 'SW 5/22/2009 13:25'! 430780menuColorFor: aThemedMorph 430781 "Answer the menu color to use." 430782 430783 |w| 430784 ^self backgroundColor! ! 430785 430786!UIThemeW2K methodsFor: 'menus' stamp: 'SW 5/22/2009 14:09'! 430787menuTitleColor 430788 "Answer the menu title color to use." 430789 430790 ^Color h: 0 s: 0 v: 0.65.! ! 430791 430792!UIThemeW2K methodsFor: 'menus' stamp: 'SW 5/22/2009 14:07'! 430793menuTitleColorFor: aThemedMorph 430794 "Answer the menu titlecolor to use." 430795 ^self menuTitleColor! ! 430796 430797 430798!UIThemeW2K methodsFor: 'morph creation' stamp: 'SS 1/1/2009 12:10'! 430799newDropListIn: aThemedMorph for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 430800 "Answer a drop list for the given model." 430801 430802 ^(DropListMorph 430803 on: aModel 430804 list: listSel 430805 selected: getSel 430806 changeSelected: setSel 430807 useIndex: useIndex) 430808 selectionColor: self selectionColor; 430809 getEnabledSelector: enabledSel; 430810 font: self dropListFont; 430811 cornerStyle: #square; 430812 hResizing: #spaceFill; 430813 vResizing: #shrinkWrap; 430814 setBalloonText: helpText! ! 430815 430816!UIThemeW2K methodsFor: 'morph creation' stamp: 'gvc 6/15/2009 12:53'! 430817newLabelIn: aThemedMorph for: aModel label: aString getEnabled: enabledSel 430818 "Answer a new text label." 430819 430820 ^(super newLabelIn: aThemedMorph for: aModel label: aString getEnabled: enabledSel) 430821 disabledStyle: #inset! ! 430822 430823!UIThemeW2K methodsFor: 'morph creation' stamp: 'SS 1/1/2009 11:54'! 430824newListIn: aThemedMorph for: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText 430825 "Answer a list for the given model." 430826 430827 ^PluggableListMorph new 430828 selectionColor: self selectionColor; 430829 font: self listFont; 430830 on: aModel 430831 list: listSelector 430832 selected: getSelector 430833 changeSelected: setSelector 430834 menu: nil 430835 keystroke: nil; 430836 autoDeselect: false; 430837 cornerStyle: #square; 430838 color: Color white; 430839 borderStyle: (BorderStyle inset width: 1; baseColor: Color black); 430840 hResizing: #spaceFill; 430841 vResizing: #spaceFill; 430842 getEnabledSelector: enabledSel; 430843 setBalloonText: helpText! ! 430844 430845!UIThemeW2K methodsFor: 'morph creation' stamp: 'gvc 6/1/2009 13:22'! 430846newMorphDropListIn: aThemedMorph for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText 430847 "Answer a morph drop list for the given model." 430848 430849 ^(super newMorphDropListIn: aThemedMorph for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText) 430850 useSquareCorners! ! 430851 430852!UIThemeW2K methodsFor: 'morph creation' stamp: 'SS 1/1/2009 11:54'! 430853newMorphListIn: aThemedMorph for: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText 430854 "Answer a morph list for the given model." 430855 430856 ^(PluggableMorphListMorph 430857 on: aModel 430858 list: listSelector 430859 selected: getSelector 430860 changeSelected: setSelector 430861 menu: nil 430862 keystroke: nil) 430863 selectionColor: self selectionColor; 430864 autoDeselect: false; 430865 cornerStyle: #square; 430866 color: Color white; 430867 borderStyle: (BorderStyle inset width: 1; baseColor: Color black); 430868 hResizing: #spaceFill; 430869 vResizing: #spaceFill; 430870 getEnabledSelector: enabledSel; 430871 setBalloonText: helpText 430872 ! ! 430873 430874!UIThemeW2K methodsFor: 'morph creation' stamp: 'SS 1/1/2009 12:41'! 430875newPanelIn: aThemedMorph 430876 "Answer a new panel." 430877 430878 ^PanelMorph new 430879 changeTableLayout; 430880 layoutInset: 4; 430881 cellInset: 8; 430882 cornerStyle: #square; 430883 yourself! ! 430884 430885!UIThemeW2K methodsFor: 'morph creation' stamp: 'SS 1/1/2009 10:41'! 430886newPluggableDialogWindowIn: aThemedMorph title: title for: contentMorph 430887 "Answer a new pluggable dialog panel with the given content." 430888 430889 |answer| 430890 answer := PluggableDialogWindow new 430891 setWindowColor: self backgroundColor; 430892 title: title; 430893 contentMorph: contentMorph. 430894 contentMorph ifNotNil: [answer model: nil]. 430895 answer color: self backgroundColor. 430896 ^answer! ! 430897 430898!UIThemeW2K methodsFor: 'morph creation' stamp: 'SS 1/1/2009 11:53'! 430899newTextEditorIn: aThemedMorph for: aModel getText: getSel setText: setSel getEnabled: enabledSel 430900 "Answer a text editor for the given model." 430901 430902 ^PluggableTextEditorMorph new 430903 on: aModel 430904 text: getSel 430905 accept: setSel 430906 readSelection: nil 430907 menu: nil; 430908 getEnabledSelector: enabledSel; 430909 font: self textFont; 430910 cornerStyle: #square; 430911 hResizing: #spaceFill; 430912 vResizing: #spaceFill; 430913 borderStyle: (BorderStyle inset width: 1); 430914 color: Color white! ! 430915 430916!UIThemeW2K methodsFor: 'morph creation' stamp: 'SS 1/1/2009 11:53'! 430917newTreeIn: aThemedMorph for: aModel list: listSelector selected: getSelector changeSelected: setSelector 430918 "Answer a new tree morph." 430919 430920 ^TreeListMorph new 430921 selectionColor: self selectionColor; 430922 font: self listFont; 430923 on: aModel 430924 list: listSelector 430925 selected: getSelector 430926 changeSelected: setSelector 430927 menu: nil 430928 keystroke: nil; 430929 cornerStyle: #square; 430930 color: Color white; 430931 borderStyle: (BorderStyle inset width: 1; baseColor: Color black); 430932 hResizing: #spaceFill; 430933 vResizing: #spaceFill; 430934 autoDeselect: false; 430935 yourself! ! 430936 430937 430938!UIThemeW2K methodsFor: 'progressbar' stamp: 'SW 5/22/2009 13:20'! 430939progressBarBorderStyleFor: aProgressBar 430940 "Return the progress bar borderStyle for the given progress bar." 430941 430942 | aStyle | 430943 aStyle := BorderStyle complexInset. 430944 aStyle width: 2. 430945 aStyle color: self backgroundColor. 430946 ^aStyle.! ! 430947 430948!UIThemeW2K methodsFor: 'progressbar' stamp: 'SW 5/22/2009 13:20'! 430949progressBarColorFor: aProgressBar 430950 "Answer the colour for the given progress bar." 430951 430952 ^self backgroundColor! ! 430953 430954!UIThemeW2K methodsFor: 'progressbar' stamp: 'SW 5/22/2009 13:23'! 430955progressBarFillStyleFor: aProgressBar 430956 "Return the progress bar fillStyle for the given progress bar." 430957 430958 ^self backgroundColor! ! 430959 430960!UIThemeW2K methodsFor: 'progressbar' stamp: 'SW 5/22/2009 13:49'! 430961progressBarProgressColorFor: aProgressBar 430962 "Answer the colour for the progress part of the given progress bar." 430963 430964 ^Color r: 0.227 g: 0.431 b: 0.646! ! 430965 430966!UIThemeW2K methodsFor: 'progressbar' stamp: 'SW 5/22/2009 20:12'! 430967setSystemProgressMorphDefaultParameters: aProgressMorph 430968 430969 aProgressMorph color: self backgroundColor. 430970 aProgressMorph borderWidth: Preferences menuBorderWidth. 430971 aProgressMorph borderStyle: BorderStyle thinGray. 430972 aProgressMorph 430973 addDropShadow; 430974 shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.666); 430975 shadowOffset: 1 @ 1! ! 430976 430977 430978!UIThemeW2K methodsFor: 'scrollbars' stamp: 'gvc 6/4/2009 13:59'! 430979basicCreateArrowOfDirection: aSymbol size: finalSizeInteger color: aColor 430980 430981 | form | 430982 form := Form extent: finalSizeInteger asPoint depth: Display depth. 430983 form fillColor: Color transparent. 430984 430985 aSymbol == #right 430986 ifTrue: [self drawRightArrowIn: form boundingBox on: form getCanvas. ]. 430987 aSymbol == #bottom 430988 ifTrue: [self drawDownArrowIn: form boundingBox on: form getCanvas. ]. 430989 aSymbol == #left 430990 ifTrue: [self drawLeftArrowIn: form boundingBox on: form getCanvas. ]. 430991 aSymbol == #top 430992 ifTrue: [self drawUpArrowIn: form boundingBox on: form getCanvas. ]. 430993 430994 ^form copy: (form boundingBox insetBy: 3)! ! 430995 430996!UIThemeW2K methodsFor: 'scrollbars' stamp: 'SS 1/1/2009 12:26'! 430997drawDownArrowIn: aRectangle on: aCanvas 430998 430999 | aHeight aHalfWidth aTriangleRect aSlope theCenter anEnabledColor | 431000 431001 anEnabledColor := Color black. 431002 aHeight := ((aRectangle height) * 0.5) asInteger. 431003 aHalfWidth := (aHeight) asInteger. 431004 aHalfWidth <= 0 ifTrue:[^nil]. 431005 theCenter := aRectangle center. 431006 aTriangleRect := (Rectangle origin: theCenter extent: 0@0) translateBy: (0@((aHalfWidth/3.5) asInteger)). 431007 aSlope := aHeight/aHalfWidth. 431008 [aTriangleRect width < aHeight] whileTrue: 431009 [ 431010 aCanvas line: aTriangleRect topLeft to: aTriangleRect topRight color: anEnabledColor. 431011 aTriangleRect := aTriangleRect outsetBy: (1 min: ((aSlope + 0.5) asInteger)). 431012 ]. 431013 aCanvas line: aTriangleRect center to: aTriangleRect center color: anEnabledColor. 431014 ! ! 431015 431016!UIThemeW2K methodsFor: 'scrollbars' stamp: 'SS 1/1/2009 12:26'! 431017drawLeftArrowIn: aRectangle on: aCanvas 431018 431019 | aTriangleRect aSlope theCenter aWidth aHalfHeight anEnabledColor | 431020 431021 anEnabledColor := Color black. 431022 431023 aWidth := ((aRectangle width) * 0.5) asInteger. 431024 aHalfHeight := (aWidth) asInteger. 431025 aHalfHeight <= 0 ifTrue:[^nil]. 431026 theCenter := aRectangle center. 431027 aTriangleRect := (Rectangle origin: theCenter extent: 0@0) translateBy: (((aHalfHeight/3) asInteger negated)@0). 431028 aSlope := aWidth/aHalfHeight. 431029 [aTriangleRect height < aWidth] whileTrue: 431030 [ 431031 aCanvas line: aTriangleRect bottomRight to: aTriangleRect topRight color: anEnabledColor. 431032 aTriangleRect := aTriangleRect outsetBy: (1 min: ((aSlope + 0.5) asInteger)). 431033 ]. 431034 aCanvas line: aTriangleRect center to: aTriangleRect center color: anEnabledColor. 431035 ! ! 431036 431037!UIThemeW2K methodsFor: 'scrollbars' stamp: 'SS 1/1/2009 12:27'! 431038drawRightArrowIn: aRectangle on: aCanvas 431039 431040 | aTriangleRect aSlope theCenter aWidth aHalfHeight anEnabledColor | 431041 431042 anEnabledColor := Color black. 431043 431044 aWidth := ((aRectangle width) * 0.5) asInteger. 431045 aHalfHeight := (aWidth) asInteger. 431046 aHalfHeight <= 0 ifTrue:[^nil]. 431047 theCenter := aRectangle center. 431048 "aTriangleRect := (Rectangle origin: theCenter extent: 0@0) translateBy: (((aHalfHeight/4) asInteger negated)@0)." 431049 aTriangleRect := (Rectangle origin: theCenter extent: 0@0) translateBy: (((aHalfHeight/3) asInteger)@0). 431050 aSlope := aWidth/aHalfHeight. 431051 [aTriangleRect height < aWidth] whileTrue: 431052 [ 431053 aCanvas line: aTriangleRect bottomLeft to: aTriangleRect topLeft color: anEnabledColor. 431054 aTriangleRect := aTriangleRect outsetBy: (1 min: ((aSlope + 0.5) asInteger)). 431055 ]. 431056 aCanvas line: aTriangleRect center to: aTriangleRect center color: anEnabledColor. 431057 ! ! 431058 431059!UIThemeW2K methodsFor: 'scrollbars' stamp: 'SS 1/1/2009 12:17'! 431060drawUpArrowIn: aRectangle on: aCanvas 431061 431062 | aHeight aHalfWidth aTriangleRect aSlope theCenter anEnabledColor | 431063 431064 anEnabledColor := Color black. 431065 aHeight := ((aRectangle height) * 0.5) asInteger. 431066 aHalfWidth := (aHeight) asInteger. 431067 aHalfWidth <= 0 ifTrue:[^nil]. 431068 theCenter := aRectangle center. 431069 aTriangleRect := (Rectangle origin: theCenter extent: 0@0) translateBy: (0@((aHalfWidth/3.5) asInteger negated)). 431070 aSlope := aHeight/aHalfWidth. 431071 [aTriangleRect width < aHeight] whileTrue: 431072 [ 431073 aCanvas line: aTriangleRect bottomLeft to: aTriangleRect bottomRight color: anEnabledColor. 431074 aTriangleRect := aTriangleRect outsetBy: (1 min: ((aSlope + 0.5) asInteger)). 431075 ]. 431076 aCanvas line: aTriangleRect center to: aTriangleRect center color: anEnabledColor. 431077 ! ! 431078 431079!UIThemeW2K methodsFor: 'scrollbars' stamp: 'SS 1/1/2009 12:09'! 431080scrollbarArrowOfDirection: aSymbol size: finalSizeInteger color: aColor 431081 "Answer a new scrollbar arrow form (normally cached by Scrollbar)." 431082 431083 ^self basicCreateArrowOfDirection: aSymbol size: finalSizeInteger color: aColor! ! 431084 431085!UIThemeW2K methodsFor: 'scrollbars' stamp: 'SS 1/1/2009 12:01'! 431086scrollbarMinimumThumbThickness 431087 "Answer the minumum width or height of a scrollbar thumb 431088 as appropriate to its orientation." 431089 431090 ^8! ! 431091 431092!UIThemeW2K methodsFor: 'scrollbars' stamp: 'SS 1/1/2009 11:58'! 431093scrollbarThickness 431094 431095 ^16! ! 431096 431097 431098!UIThemeW2K methodsFor: 'tabs' stamp: 'gvc 6/2/2009 11:03'! 431099drawTabGroupFinishingFor: aTabGroupMorph on: aCanvas 431100 "Patch up any visuals for the selected tab." 431101 431102 | aSTB aCover myOrigin sOrigin sExtent aContentMorph aBW| 431103 431104 aSTB := aTabGroupMorph selectedTabBounds. 431105 aContentMorph := aTabGroupMorph contentMorph. 431106 aBW := aContentMorph borderWidth. 431107 myOrigin := aContentMorph bounds origin. 431108 sOrigin := aSTB bottomLeft. 431109 sExtent := aSTB bottomRight. 431110 431111 aCover := Rectangle origin: (((sOrigin x) + aBW)@ myOrigin y) corner: (sExtent x @ ((myOrigin y) + (aBW))). 431112 431113 aCanvas fillRectangle: aCover color: self backgroundColor 431114 431115! ! 431116 431117!UIThemeW2K methodsFor: 'tabs' stamp: 'SW 5/22/2009 20:34'! 431118tabGroupCornerStyleIn: aThemedMorph 431119 "Allow for themes to override default behaviour." 431120 431121 ^#square! ! 431122 431123!UIThemeW2K methodsFor: 'tabs' stamp: 'gvc 6/2/2009 11:51'! 431124tabLabelNormalBorderStyleFor: aTabLabel 431125 "Answer the normal border style for a tab label." 431126 431127 | aStyle | 431128 aStyle := W2KComplexTabBorder new. 431129 aStyle width: 1. 431130 aStyle color: self backgroundColor. 431131 ^aStyle.! ! 431132 431133!UIThemeW2K methodsFor: 'tabs' stamp: 'SW 5/22/2009 20:43'! 431134tabLabelNormalFillStyleFor: aTabLabel 431135 "Return the normal fillStyle for the given tab label." 431136 431137 ^self tabLabelSelectedFillStyleFor: aTabLabel! ! 431138 431139!UIThemeW2K methodsFor: 'tabs' stamp: 'gvc 6/2/2009 11:51'! 431140tabLabelSelectedBorderStyleFor: aTabLabel 431141 "Answer the normal border style for a tab panel." 431142 431143 | aStyle | 431144 aStyle := W2KComplexTabBorder new. 431145 aStyle width: 2. 431146 aStyle color: self backgroundColor. 431147 ^aStyle.! ! 431148 431149!UIThemeW2K methodsFor: 'tabs' stamp: 'SW 5/22/2009 20:42'! 431150tabLabelSelectedFillStyleFor: aTabLabel 431151 "Return the selected fillStyle for the given tab label." 431152 431153 ^self backgroundColor! ! 431154 431155!UIThemeW2K methodsFor: 'tabs' stamp: 'SW 5/22/2009 20:39'! 431156tabPanelBorderStyleFor: aTabPanel 431157 "Answer the normal border style for a tab panel." 431158 431159 | aStyle | 431160 aStyle := BorderStyle complexRaised. 431161 aStyle width: 2. 431162 aStyle color: self backgroundColor. 431163 ^aStyle.! ! 431164 431165!UIThemeW2K methodsFor: 'tabs' stamp: 'SW 5/23/2009 17:16'! 431166tabSelectorCellInsetFor: aTabSelector 431167 "Answer the cell inset to use for the given tab selector." 431168 431169 ^0@0! ! 431170 431171!UIThemeW2K methodsFor: 'tabs' stamp: 'gvc 6/2/2009 11:39'! 431172tabSelectorMorphMinExtentFor: aTabSelectorMorph 431173 "Answer the min extent of the given tab selector." 431174 431175 ^aTabSelectorMorph basicMinExtent + (0@-1)! ! 431176 431177"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 431178 431179UIThemeW2K class 431180 instanceVariableNames: 'windowColor'! 431181 431182!UIThemeW2K class methodsFor: 'accessing' stamp: 'SS 1/1/2009 06:56'! 431183windowColor 431184 "UIThemeWatery3 windowColor: nil." 431185 windowColor ifNil: [self windowColor: (Color gray: 0.5)]. 431186 ^windowColor! ! 431187 431188!UIThemeW2K class methodsFor: 'accessing' stamp: 'SS 1/1/2009 06:56'! 431189windowColor: aColor 431190 "UIThemeWatery3 windowColor:nil." 431191 windowColor := aColor.! ! 431192 431193!UIThemeW2K class methodsFor: 'accessing' stamp: 'SS 1/1/2009 07:26'! 431194world 431195 431196 ^World! ! 431197 431198 431199!UIThemeW2K class methodsFor: 'as yet unclassified' stamp: 'SS 1/1/2009 05:52'! 431200isAbstract 431201 "Answer whether the receiver is considered to be abstract." 431202 431203 ^false! ! 431204 431205!UIThemeW2K class methodsFor: 'as yet unclassified' stamp: 'gvc 6/2/2009 11:53'! 431206themeName 431207 "Answer the friendly name of the theme." 431208 431209 ^'W2K'! ! 431210 431211 431212!UIThemeW2K class methodsFor: 'defaults' stamp: 'SW 5/17/2009 21:41'! 431213setup 431214 431215 "self setup" 431216 "setup the fonts/background color ala a real desktop.. this assumes these fonts exist on your system" 431217 431218 | aStandardFont aBoldFont | 431219 431220 aStandardFont := LogicalFont familyName: 'Arial' pointSize: 9 stretchValue: 5 weightValue: 400 slantValue: 0. 431221 aBoldFont := LogicalFont familyName: 'Arial' pointSize: 9 stretchValue: 5 weightValue: 700 slantValue: 0. 431222 431223 Preferences setWindowTitleFontTo: aBoldFont. 431224 Preferences setEToysTitleFontTo: aBoldFont. 431225 Preferences setFlapsFontTo: aBoldFont. 431226 431227 Preferences setBalloonHelpFontTo: aStandardFont. 431228 Preferences setButtonFontTo: aStandardFont. 431229 Preferences setCodeFontTo: aStandardFont. 431230 Preferences setEToysFontTo: aStandardFont. 431231 Preferences setHaloLabelFontTo: aStandardFont. 431232 Preferences setListFontTo: aStandardFont. 431233 Preferences setMenuFontTo: aStandardFont. 431234 Preferences setPaintBoxButtonFontTo: aStandardFont. 431235 Preferences setSystemFontTo: aStandardFont. 431236 431237 self world color: (Color r: 0.227 g: 0.431 b: 0.646). 431238 self beCurrent.! ! 431239UITheme subclass: #UIThemeWatery 431240 instanceVariableNames: '' 431241 classVariableNames: '' 431242 poolDictionaries: '' 431243 category: 'Polymorph-Widgets-Themes'! 431244!UIThemeWatery commentStamp: 'gvc 11/5/2007 14:54' prior: 0! 431245An OSX-style UI theme. Do UIThemeWatery beCurrent to use.! 431246 431247 431248!UIThemeWatery methodsFor: 'basic-colors' stamp: 'gvc 11/5/2007 14:52'! 431249taskbarActiveButtonColorFor: aButton 431250 "Answer the colour for the given active taskbar button." 431251 431252 ^self settings scrollbarColor alphaMixed: 0.7 with: Color white! ! 431253 431254!UIThemeWatery methodsFor: 'basic-colors' stamp: 'gvc 11/5/2007 14:50'! 431255taskbarMinimizedButtonColorFor: aButton 431256 "Answer the colour for the given minimized taskbar button." 431257 431258 ^Color transparent! ! 431259 431260 431261!UIThemeWatery methodsFor: 'border-styles' stamp: 'gvc 6/2/2009 11:31'! 431262configureWindowBorderFor: aWindow 431263 "Configure the border for the given window." 431264 431265 super configureWindowBorderFor: aWindow. 431266 aWindow roundedCorners: #(1 4) "just top"! ! 431267 431268!UIThemeWatery methodsFor: 'border-styles' stamp: 'gvc 9/1/2009 15:37'! 431269drawTextAdornmentFor: aPluggableTextMorph color: aColor on: aCanvas 431270 "Indicate edit status for the given morph." 431271 431272 |bounds size fillStyle| 431273 bounds := aPluggableTextMorph innerBounds. 431274 size := 25. 431275 fillStyle := (GradientFillStyle ramp: { 431276 0.0->(Color white alpha: 0.01). 431277 0.8->aColor. 431278 1.0->aColor}) 431279 origin: bounds topRight - (size@0); 431280 direction: (size @ size negated) // 4; 431281 radial: false. 431282 aCanvas 431283 drawPolygon: {bounds topRight. bounds topRight + (0@size). bounds topRight - (size@0)} 431284 fillStyle: fillStyle! ! 431285 431286!UIThemeWatery methodsFor: 'border-styles' stamp: 'gvc 1/12/2009 17:38'! 431287windowPaneBorderStyleFor: aMorph in: aSystemWindow 431288 "Answer the border style for a morph that is to be added 431289 as a pane in the given system window," 431290 431291 ^BorderStyle simple 431292 color: aSystemWindow paneColor; 431293 width: (aMorph borderWidth = 0 ifTrue: [0] ifFalse: [1])! ! 431294 431295!UIThemeWatery methodsFor: 'border-styles' stamp: 'gvc 5/13/2008 15:17'! 431296worldMainDockingBarBorderStyleFor: aDockingBar 431297 "Return the world main docking bar borderStyle for the given docking bar." 431298 431299 ^BorderStyle simple 431300 width: 0; 431301 color: Color transparent! ! 431302 431303 431304!UIThemeWatery methodsFor: 'border-styles-buttons' stamp: 'gvc 1/27/2009 13:50'! 431305buttonCornerStyleIn: aThemedMorph 431306 "Allow for themes to override default behaviour." 431307 431308 ^aThemedMorph 431309 ifNil: [#rounded] 431310 ifNotNilDo: [:tm | 431311 tm preferredButtonCornerStyle 431312 ifNil: [#rounded] 431313 ifNotNilDo: [:bcs | bcs]]! ! 431314 431315!UIThemeWatery methodsFor: 'border-styles-buttons' stamp: 'gvc 10/24/2007 13:34'! 431316buttonNormalBorderStyleFor: aButton 431317 "Return the normal button borderStyle for the given button." 431318 431319 |c| 431320 c := aButton colorToUse darker. 431321 aButton isDefault 431322 ifTrue: [c := c alphaMixed: 0.5 with: Color black]. 431323 ^BorderStyle simple 431324 width: 1; 431325 baseColor: c! ! 431326 431327!UIThemeWatery methodsFor: 'border-styles-buttons' stamp: 'gvc 2/29/2008 22:06'! 431328checkboxButtonNormalBorderStyleFor: aCheckboxButton 431329 "Return the normal checkbox button borderStyle for the given button." 431330 431331 |c| 431332 c := Color white twiceDarker alphaMixed: 0.7 with: Color black. 431333 ^(CompositeBorder new width: 1) 431334 borders: {BorderStyle simple 431335 width: 1; 431336 baseColor: (Color black alpha: 0.1). 431337 BorderStyle simple 431338 width: 1; 431339 baseColor: c}! ! 431340 431341!UIThemeWatery methodsFor: 'border-styles-buttons' stamp: 'gvc 2/29/2008 22:06'! 431342checkboxButtonSelectedBorderStyleFor: aCheckboxButton 431343 "Return the normal checkbox button borderStyle for the given button." 431344 431345 |c| 431346 c := self settings scrollbarColor alphaMixed: 0.7 with: Color black. 431347 ^(CompositeBorder new width: 1) 431348 borders: {BorderStyle simple 431349 width: 1; 431350 baseColor: (Color black alpha: 0.1). 431351 BorderStyle simple 431352 width: 1; 431353 baseColor: c}! ! 431354 431355!UIThemeWatery methodsFor: 'border-styles-buttons' stamp: 'gvc 1/27/2009 14:04'! 431356textEntryCornerStyleIn: aThemedMorph 431357 "Answer the corner style to use for text entry morphs." 431358 431359 ^#square! ! 431360 431361 431362!UIThemeWatery methodsFor: 'border-styles-scrollbars' stamp: 'gvc 10/24/2007 14:33'! 431363scrollbarNormalButtonBorderStyleFor: aScrollbar 431364 "Return the normal button borderStyle for the given scrollbar." 431365 431366 ^BorderStyle simple 431367 width: 0! ! 431368 431369!UIThemeWatery methodsFor: 'border-styles-scrollbars' stamp: 'gvc 11/5/2007 14:38'! 431370scrollbarNormalThumbBorderStyleFor: aScrollbar 431371 "Return the normal thumb borderStyle for the given scrollbar." 431372 431373 |c| 431374 c := self settings scrollbarColor alphaMixed: 0.7 with: Color black. 431375 ^(CompositeBorder new width: 2) 431376 borders: {BorderStyle simple 431377 width: 1; 431378 baseColor: c. 431379 BorderStyle simple 431380 width: 1; 431381 baseColor: c twiceLighter}! ! 431382 431383!UIThemeWatery methodsFor: 'border-styles-scrollbars' stamp: 'gvc 10/24/2007 15:05'! 431384scrollbarPagingAreaCornerStyleIn: aThemedMorph 431385 "Allow for themes to override default behaviour." 431386 431387 ^#rounded! ! 431388 431389!UIThemeWatery methodsFor: 'border-styles-scrollbars' stamp: 'gvc 10/24/2007 15:13'! 431390scrollbarPressedButtonBorderStyleFor: aScrollbar 431391 "Return the pressed button borderStyle for the given scrollbar." 431392 431393 ^self scrollbarNormalButtonBorderStyleFor: aScrollbar! ! 431394 431395!UIThemeWatery methodsFor: 'border-styles-scrollbars' stamp: 'gvc 10/24/2007 15:05'! 431396scrollbarThumbCornerStyleIn: aThemedMorph 431397 "Allow for themes to override default behaviour." 431398 431399 ^#rounded! ! 431400 431401 431402!UIThemeWatery methodsFor: 'defaults' stamp: 'gvc 10/7/2008 11:49'! 431403scrollbarMinimumThumbThickness 431404 "Answer the minumum width or height of a scrollbar thumb 431405 as appropriate to its orientation." 431406 431407 ^15! ! 431408 431409!UIThemeWatery methodsFor: 'defaults' stamp: 'gvc 1/14/2009 15:28'! 431410tabLabelInsetFor: aButton 431411 "Answer the inset to use for a tab label." 431412 431413 ^8@2 corner: 8@2! ! 431414 431415!UIThemeWatery methodsFor: 'defaults' stamp: 'gvc 10/28/2007 16:42'! 431416treeLineWidth 431417 "Answer the width of the tree lines." 431418 431419 ^0! ! 431420 431421 431422!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 11/12/2007 15:39'! 431423buttonPanelNormalFillStyleFor: aPanel 431424 "Return the normal panel fillStyle for the given panel." 431425 431426 ^(BitmapFillStyle fromForm: self stripesForm) 431427 origin: aPanel topLeft! ! 431428 431429!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 11/13/2007 12:05'! 431430dialogWindowActiveFillStyleFor: aWindow 431431 "Return the dialog window active fillStyle for the given window." 431432 431433 ^(BitmapFillStyle fromForm: self stripesForm) 431434 origin: aWindow topLeft! ! 431435 431436!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 11/13/2007 12:06'! 431437dialogWindowInactiveFillStyleFor: aWindow 431438 "Return the dialog window inactive fillStyle for the given window." 431439 431440 ^self dialogWindowActiveFillStyleFor: aWindow! ! 431441 431442!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 10/25/2007 17:51'! 431443dockingBarNormalFillStyleFor: aToolDockingBar 431444 "Return the normal docking bar fillStyle for the given bar." 431445 431446 ^(BitmapFillStyle fromForm: self stripesForm) 431447 origin: aToolDockingBar topLeft! ! 431448 431449!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 1/13/2009 13:57'! 431450dropListNormalFillStyleFor: aDropList 431451 "Return the normal fillStyle for the given drop list." 431452 431453 |c| 431454 c := self windowColor. 431455 ^(GradientFillStyle ramp: { 431456 0.0->c twiceDarker. 431457 0.05-> c lighter. 431458 0.15-> Color white. 431459 1.0->Color white}) 431460 origin: aDropList topLeft; 431461 direction: 0 @ aDropList height; 431462 radial: false! ! 431463 431464!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 1/23/2009 12:31'! 431465expanderTitleNormalFillStyleFor: anExpanderTitle 431466 "Return the normal expander title fillStyle for the given expander title." 431467 431468 |aColor| 431469 aColor := anExpanderTitle paneColor. 431470 ^(GradientFillStyle ramp: { 431471 0.0->Color white. 431472 0.05-> aColor lighter. 431473 1.0->aColor darker}) 431474 origin: anExpanderTitle topLeft; 431475 direction: 0 @ anExpanderTitle height; 431476 radial: false! ! 431477 431478!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 11/13/2007 13:06'! 431479progressBarFillStyleFor: aProgressBar 431480 "Return the progress bar fillStyle for the given progress bar." 431481 431482 |area c| 431483 c := self progressBarColorFor: aProgressBar. 431484 area := aProgressBar bounds. 431485 ^(GradientFillStyle ramp: { 431486 0.0->c twiceDarker. 431487 0.2->c twiceLighter lighter. 431488 0.3->c twiceLighter lighter. 431489 0.4->c darker. 431490 0.6->c twiceLighter lighter. 431491 1.0->Color white}) 431492 origin: area origin; 431493 direction: 0@area height; 431494 radial: false! ! 431495 431496!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 11/13/2007 13:06'! 431497progressBarProgressFillStyleFor: aProgressBar 431498 "Return the progress bar progress fillStyle for the given progress bar." 431499 431500 |area c| 431501 c := self progressBarProgressColorFor: aProgressBar. 431502 area := aProgressBar bounds. 431503 ^(GradientFillStyle ramp: { 431504 0.0->c twiceDarker. 431505 0.2->c twiceLighter lighter. 431506 0.3->c twiceLighter lighter. 431507 0.4->c darker. 431508 0.6->c twiceLighter lighter. 431509 1.0->Color white}) 431510 origin: area origin; 431511 direction: 0@area height; 431512 radial: false! ! 431513 431514!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 3/27/2008 21:36'! 431515resizerGripNormalFillStyleFor: aResizer 431516 "Return the normal fillStyle for the given resizer. 431517 For the moment, answer a transparent colour for no drawing, 431518 non transparent to draw as normal." 431519 431520 ^Color transparent! ! 431521 431522!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 1/12/2009 13:16'! 431523splitterNormalFillStyleFor: aSplitter 431524 "Return the normal splitter fillStyle for the given splitter." 431525 431526 |aColor| 431527 aColor := aSplitter paneColor. 431528 ^(GradientFillStyle ramp: { 431529 0.0->aColor twiceLighter. 1.0->aColor darker}) 431530 origin: aSplitter topLeft; 431531 direction: (aSplitter splitsTopAndBottom 431532 ifTrue: [0 @ aSplitter height] 431533 ifFalse: [aSplitter width @ 0]); 431534 radial: false! ! 431535 431536!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 1/12/2009 13:14'! 431537splitterPressedFillStyleFor: aSplitter 431538 "Return the pressed splitter fillStyle for the given splitter." 431539 431540 |aColor| 431541 aColor := aSplitter paneColor duller. 431542 ^(GradientFillStyle ramp: { 431543 0.0->aColor twiceLighter. 1.0->aColor twiceDarker}) 431544 origin: aSplitter topLeft; 431545 direction: (aSplitter splitsTopAndBottom 431546 ifTrue: [0 @ aSplitter height] 431547 ifFalse: [aSplitter width @ 0]); 431548 radial: false! ! 431549 431550!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 10/24/2007 12:18'! 431551stripesForm 431552 "Answer the form to use for the stripes of various elements." 431553 431554 ^self forms at: #stripes ifAbsent: [Form extent: 32@32 depth: Display depth]! ! 431555 431556!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 1/7/2008 11:27'! 431557tabLabelNormalFillStyleFor: aTabLabel 431558 "Return the normal fillStyle for the given tab label." 431559 431560 |aColor| 431561 aColor := aTabLabel paneColor. 431562 ^(GradientFillStyle ramp: { 431563 0.0->Color white. 431564 0.3->Color white. 431565 0.4->aColor. 431566 0.6->Color white. 431567 1.0->Color white}) 431568 origin: aTabLabel bounds origin; 431569 direction: 0 @ aTabLabel height; 431570 radial: false! ! 431571 431572!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 1/7/2008 15:16'! 431573tabLabelSelectedFillStyleFor: aTabLabel 431574 "Return the selected fillStyle for the given tab label." 431575 431576 |aColor| 431577 aColor := self settings scrollbarColor. 431578 ^(GradientFillStyle ramp: { 431579 0.0->aColor twiceLighter. 431580 0.3->aColor twiceLighter. 431581 0.4->aColor darker. 431582 0.7->aColor twiceLighter. 431583 1.0->Color white}) 431584 origin: aTabLabel bounds origin; 431585 direction: 0 @ aTabLabel height; 431586 radial: false! ! 431587 431588!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 11/13/2007 12:30'! 431589taskbarFillStyleFor: aTaskbar 431590 "Return the taskbar fillStyle for the given taskbar." 431591 431592 |aColor c cm cd cb| 431593 aColor := self settings scrollbarColor alphaMixed: 0.5 with: aTaskbar color. 431594 c := aColor alphaMixed: 0.3 with: Color white. 431595 cm := aColor alphaMixed: 0.8 with: Color white. 431596 cd := aColor alphaMixed: 0.6 with: Color black. 431597 cb := aColor alphaMixed: 0.7 with: Color white. 431598 ^(GradientFillStyle ramp: {0.0->c. 0.1->cm. 0.9->cd. 1.0->cb}) 431599 origin: aTaskbar position; 431600 direction: 0@27; 431601 radial: false! ! 431602 431603!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 8/28/2009 11:49'! 431604textEditorDisabledFillStyleFor: aTextEditor 431605 "Return the disabled fillStyle for the given text editor." 431606 431607 ^self windowColor darker! ! 431608 431609!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 1/13/2009 13:58'! 431610textFieldNormalFillStyleFor: aTextField 431611 "Return the normal fillStyle for the given text field." 431612 431613 |c| 431614 c := self windowColor. 431615 ^(GradientFillStyle ramp: { 431616 0.0->c twiceDarker. 431617 0.05-> c lighter. 431618 0.15-> Color white. 431619 1.0->Color white}) 431620 origin: aTextField topLeft; 431621 direction: 0 @ aTextField height; 431622 radial: false! ! 431623 431624!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 10/26/2007 21:25'! 431625windowActiveFillStyleFor: aWindow 431626 "Return the window active fillStyle for the given window." 431627 431628 ^self windowColor! ! 431629 431630!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 10/26/2007 21:29'! 431631windowActiveTitleFillStyleFor: aWindow 431632 "Return the window active title fillStyle for the given window." 431633 431634 |aColor| 431635 aColor := self windowColor. 431636 ^(GradientFillStyle ramp: { 431637 0.0->Color white. 431638 0.03->Color white. 431639 0.05-> aColor lighter. 431640 1.0->aColor darker}) 431641 origin: aWindow labelArea topLeft; 431642 direction: 0 @ aWindow labelHeight; 431643 radial: false! ! 431644 431645!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 10/24/2007 12:54'! 431646windowInactiveFillStyleFor: aWindow 431647 "Return the window inactive fillStyle for the given window." 431648 431649 ^self windowActiveFillStyleFor: aWindow! ! 431650 431651!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 10/26/2007 21:25'! 431652windowInactiveTitleFillStyleFor: aWindow 431653 "Return the window inactive title fillStyle for the given window." 431654 431655 ^(BitmapFillStyle fromForm: self stripesForm) 431656 origin: aWindow topLeft! ! 431657 431658!UIThemeWatery methodsFor: 'fill-styles' stamp: 'gvc 11/13/2007 12:31'! 431659worldMainDockingBarNormalFillStyleFor: aDockingBar 431660 "Return the world main docking bar fillStyle for the given docking bar." 431661 431662 |aColor| 431663 aColor := aDockingBar originalColor alpha: 0.7. 431664 ^(GradientFillStyle ramp: { 431665 0.0->(aColor alphaMixed: 0.3 with: (Color white alpha: aColor alpha)). 431666 0.8->aColor darker. 431667 1.0->aColor darker duller}) 431668 origin: aDockingBar topLeft; 431669 direction: (aDockingBar isVertical 431670 ifTrue: [aDockingBar width @ 0] 431671 ifFalse: [0 @ aDockingBar height]); 431672 radial: false! ! 431673 431674 431675!UIThemeWatery methodsFor: 'fill-styles-buttons' stamp: 'gvc 1/23/2009 13:00'! 431676buttonFocusBoundsFor: aButton 431677 "Answer the bounds for drawing the focus indication for the 431678 given button." 431679 431680 ^aButton bounds! ! 431681 431682!UIThemeWatery methodsFor: 'fill-styles-buttons' stamp: 'gvc 10/9/2008 17:44'! 431683buttonNormalFillStyleFor: aButton 431684 "Return the normal button fillStyle for the given button." 431685 431686 |aColor| 431687 aColor := aButton colorToUse. 431688 aColor = aButton paneColor ifTrue: [aColor := self buttonColorFor: aButton]. 431689 ^(GradientFillStyle ramp: { 431690 0.0->Color white. 431691 0.3->Color white. 431692 0.4->aColor. 431693 0.6->Color white. 431694 1.0->Color white}) 431695 origin: aButton bounds origin; 431696 direction: 0 @ aButton height; 431697 radial: false! ! 431698 431699!UIThemeWatery methodsFor: 'fill-styles-buttons' stamp: 'gvc 10/28/2007 16:41'! 431700buttonPressedFillStyleFor: aButton 431701 "Return the button pressed fillStyle for the given button." 431702 431703 ^self buttonSelectedFillStyleFor: aButton! ! 431704 431705!UIThemeWatery methodsFor: 'fill-styles-buttons' stamp: 'gvc 10/28/2007 16:38'! 431706buttonSelectedFillStyleFor: aButton 431707 "Return the button selected fillStyle for the given button." 431708 431709 |c| 431710 c := (aButton onColor isNil or: [aButton onColor isTransparent]) 431711 ifTrue: [self settings scrollbarColor] 431712 ifFalse: [aButton colorToUse]. 431713 ^(GradientFillStyle ramp: { 431714 0.0->c twiceLighter. 431715 0.3->c twiceLighter. 431716 0.4->c darker. 431717 0.7->c twiceLighter. 431718 1.0->Color white}) 431719 origin: aButton topLeft; 431720 direction: 0 @ aButton height; 431721 radial: false! ! 431722 431723!UIThemeWatery methodsFor: 'fill-styles-buttons' stamp: 'gvc 1/12/2009 13:20'! 431724buttonSelectedPressedFillStyleFor: aButton 431725 "Return the button selected pressed fillStyle for the given color." 431726 431727 ^self buttonNormalFillStyleFor: aButton! ! 431728 431729!UIThemeWatery methodsFor: 'fill-styles-buttons' stamp: 'gvc 2/29/2008 21:57'! 431730checkboxButtonNormalFillStyleFor: aCheckboxButton 431731 "Return the normal checkbox button fillStyle for the given button." 431732 431733 |c ib| 431734 c := Color white twiceDarker. 431735 ib := aCheckboxButton innerBounds. 431736 ^(GradientFillStyle ramp: { 431737 0.0->(c alphaMixed: 0.4 with: Color white). 431738 0.3->(c alphaMixed: 0.4 with: Color white). 431739 0.4->c. 431740 1.0->Color white}) 431741 origin: aCheckboxButton innerBounds origin; 431742 direction: 0@ib height; 431743 radial: false! ! 431744 431745!UIThemeWatery methodsFor: 'fill-styles-buttons' stamp: 'gvc 2/29/2008 21:54'! 431746checkboxButtonSelectedFillStyleFor: aCheckboxButton 431747 "Return the selected checkbox button fillStyle for the given button." 431748 431749 |c ib| 431750 c := self settings scrollbarColor. 431751 ib := aCheckboxButton innerBounds. 431752 ^(GradientFillStyle ramp: { 431753 0.0->(c alphaMixed: 0.4 with: Color white). 431754 0.3->(c alphaMixed: 0.4 with: Color white). 431755 0.4->c. 431756 1.0->Color white}) 431757 origin: aCheckboxButton innerBounds origin; 431758 direction: 0@ib height; 431759 radial: false! ! 431760 431761!UIThemeWatery methodsFor: 'fill-styles-buttons' stamp: 'gvc 11/13/2007 11:55'! 431762controlButtonMouseOverFillStyleFor: aButton 431763 "Return the mouse over control button fillStyle for the given button. 431764 Control buttons are generally used for drop-lists and expanders." 431765 431766 ^self controlButtonNormalFillStyleFor: aButton! ! 431767 431768!UIThemeWatery methodsFor: 'fill-styles-buttons' stamp: 'gvc 10/28/2007 16:53'! 431769controlButtonNormalFillStyleFor: aButton 431770 "Return the control button normal fillStyle for the given button." 431771 431772 |c| 431773 c := (aButton onColor isNil or: [aButton onColor isTransparent]) 431774 ifTrue: [self settings scrollbarColor] 431775 ifFalse: [aButton colorToUse]. 431776 ^(GradientFillStyle ramp: { 431777 0.0->c twiceLighter. 431778 0.3->c twiceLighter. 431779 0.4->c darker. 431780 0.7->c twiceLighter. 431781 1.0->Color white}) 431782 origin: aButton topLeft; 431783 direction: 0 @ aButton height; 431784 radial: false! ! 431785 431786!UIThemeWatery methodsFor: 'fill-styles-buttons' stamp: 'gvc 11/13/2007 12:00'! 431787controlButtonPressedFillStyleFor: aButton 431788 "Return the pressed button fillStyle for the given button. 431789 Control buttons are generally used for drop-lists and expanders." 431790 431791 ^self buttonNormalFillStyleFor: aButton! ! 431792 431793!UIThemeWatery methodsFor: 'fill-styles-buttons' stamp: 'gvc 1/12/2009 18:00'! 431794menuItemInDockingBarSelectedFillStyleFor: aMenuItem 431795 "Answer the selected fill style to use for the given menu item that is in a docking bar." 431796 431797 | fill baseColor | 431798 Display depth <= 2 431799 ifTrue: [^ Color gray]. 431800 baseColor := self menuColor. 431801 Preferences gradientMenu 431802 ifFalse: [^baseColor]. 431803 fill := GradientFillStyle ramp: {0.0 -> baseColor twiceDarker . 1 -> baseColor twiceLighter}. 431804 fill 431805 origin: aMenuItem topLeft; 431806 direction: 0@aMenuItem height. 431807 ^ fill! ! 431808 431809!UIThemeWatery methodsFor: 'fill-styles-buttons' stamp: 'gvc 10/17/2008 12:24'! 431810menuItemSelectedFillStyleFor: aMenuItem 431811 "Answer the selected fill style to use for the given menu item." 431812 431813 | fill baseColor preferenced | 431814 Display depth <= 2 431815 ifTrue: [^ Color gray]. 431816 preferenced := Preferences menuSelectionColor. 431817 baseColor := preferenced isNil 431818 ifTrue: [aMenuItem owner color negated] 431819 ifFalse: [preferenced]. 431820 Preferences gradientMenu 431821 ifFalse: [^baseColor]. 431822 fill := GradientFillStyle ramp: {0.0 -> baseColor twiceLighter . 1 -> baseColor twiceDarker}. 431823 fill 431824 origin: aMenuItem topLeft; 431825 direction: 0@aMenuItem height. 431826 ^ fill! ! 431827 431828 431829!UIThemeWatery methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 10/24/2007 14:28'! 431830scrollbarImageColorFor: aScrollbar 431831 "Return the scrollbar image colour (on buttons) for the given scrollbar." 431832 431833 ^Color darkGray! ! 431834 431835!UIThemeWatery methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 10/25/2007 16:16'! 431836scrollbarNormalButtonFillStyleFor: aScrollbar 431837 "Return the normal scrollbar button fillStyle for the given scrollbar." 431838 431839 | c| 431840 c := Color lightGray twiceLighter. 431841 ^(GradientFillStyle ramp: {0.0->c. 0.1->Color white. 0.3->Color white. 431842 0.5->c. 0.7-> Color white. 1.0->Color white}) 431843 origin: aScrollbar topLeft; 431844 direction: (aScrollbar bounds isWide 431845 ifTrue: [0 @ aScrollbar height] 431846 ifFalse: [aScrollbar width @ 0]); 431847 radial: false! ! 431848 431849!UIThemeWatery methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 10/24/2007 14:11'! 431850scrollbarNormalFillStyleFor: aScrollbar 431851 "Return the normal scrollbar fillStyle for the given scrollbar." 431852 431853 |aColor c| 431854 aColor := Color lightGray twiceLighter. 431855 c := aColor alphaMixed: 0.9 with: Color black. 431856 ^(GradientFillStyle ramp: {0.0->c. 0.15->aColor. 0.7-> Color white. 1.0->Color white}) 431857 origin: aScrollbar topLeft; 431858 direction: (aScrollbar bounds isWide 431859 ifTrue: [0 @ aScrollbar height] 431860 ifFalse: [aScrollbar width @ 0]); 431861 radial: false! ! 431862 431863!UIThemeWatery methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 11/5/2007 14:38'! 431864scrollbarNormalThumbFillStyleFor: aScrollbar 431865 "Return the normal scrollbar thumb fillStyle for the given scrollbar." 431866 431867 |c| 431868 c := self scrollbarColorFor: aScrollbar. 431869 ^(GradientFillStyle ramp: { 431870 0.0->c twiceLighter. 431871 0.3->c twiceLighter. 431872 0.4->c darker. 431873 0.6->c twiceLighter. 431874 1.0->Color white}) 431875 origin: aScrollbar topLeft; 431876 direction: (aScrollbar bounds isWide 431877 ifTrue: [0 @ aScrollbar height] 431878 ifFalse: [aScrollbar width @ 0]); 431879 radial: false! ! 431880 431881!UIThemeWatery methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 10/3/2008 13:11'! 431882useScrollbarThumbShadow 431883 "Answer whether a shadow morph should be displayed when 431884 dragging a scrollbar thumb." 431885 431886 ^false! ! 431887 431888 431889!UIThemeWatery methodsFor: 'initialize-release' stamp: 'gvc 4/21/2009 16:15'! 431890initializeForms 431891 "Initialize the receiver's image forms." 431892 431893 |inactiveForm| 431894 super initializeForms. 431895 inactiveForm := self newWindowInactiveControlForm. 431896 self forms 431897 at: #stripes put: self newStripesForm; 431898 at: #windowClosePassive put: inactiveForm; 431899 at: #windowMinimizePassive put: inactiveForm; 431900 at: #windowMaximizePassive put: inactiveForm! ! 431901 431902!UIThemeWatery methodsFor: 'initialize-release' stamp: 'gvc 11/5/2007 15:16'! 431903newCheckboxMarkerForm 431904 "Answer a new checkbox marker form." 431905 431906 ^(Form 431907 extent: 12@14 431908 depth: 32 431909 fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1342177280 1610612736 134217728 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3338665984 4278190080 1476395008 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 671088640 4278190080 4009754624 134217728 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2147483648 4278190080 2533359616 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3607101440 4278190080 1207959552 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1073741824 4278190080 3875536896 16777215 16777215 16777215 16777215 16777215 1207959552 3204448256 134217728 16777215 2801795072 4278190080 2147483648 16777215 16777215 16777215 16777215 134217728 3607101440 4278190080 2936012800 268435456 4143972352 4278190080 536870912 16777215 16777215 16777215 16777215 16777215 536870912 4009754624 4278190080 3607101440 4278190080 3070230528 16777215 16777215 16777215 16777215 16777215 16777215 16777215 805306368 4009754624 4278190080 4278190080 1342177280 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 671088640 2936012800 2801795072 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) 431910 offset: 0@0)! ! 431911 431912!UIThemeWatery methodsFor: 'initialize-release' stamp: 'gvc 10/25/2007 17:26'! 431913newRadioButtonMarkerForm 431914 "Answer a new radio button marker form." 431915 431916 ^(Form 431917 extent: 12@12 431918 depth: 32 431919 fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 0 0 0 0 0 0 0 0 16777215 16777215 16777215 16777215 0 0 268435456 1392508928 1392508928 268435456 0 0 16777215 16777215 16777215 16777215 0 268435456 3439329280 4278190080 4211081216 3355443200 268435456 0 16777215 16777215 16777215 16777215 0 1392508928 4278190080 4278190080 4278190080 4244635648 1392508928 0 16777215 16777215 16777215 16777215 0 1392508928 4278190080 4278190080 4261412864 4261412864 1308622848 0 16777215 16777215 16777215 16777215 0 268435456 3439329280 4278190080 4261412864 3422552064 234881024 0 16777215 16777215 16777215 16777215 0 0 268435456 1392508928 1392508928 268435456 0 0 16777215 16777215 16777215 16777215 0 0 0 0 0 0 0 0 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) 431920 offset: 0@0)! ! 431921 431922!UIThemeWatery methodsFor: 'initialize-release' stamp: 'gvc 10/24/2007 12:16'! 431923newStripesForm 431924 "Answer the form for the stripes in panels etc." 431925 431926 ^(Form 431927 extent: 32@32 431928 depth: 32 431929 fromArray: #( 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884) 431930 offset: 0@0)! ! 431931 431932!UIThemeWatery methodsFor: 'initialize-release' stamp: 'gvc 11/5/2007 15:08'! 431933newTreeExpandedForm 431934 "Answer a new form for an expanded tree item." 431935 431936 ^(Form 431937 extent: 9@9 431938 depth: 32 431939 fromArray: #( 1049135240 2290649224 2290649224 2290649224 2290649224 2290649224 2290649224 2290649224 1200130184 478709896 4169697416 4287137928 4287137928 4287137928 4287137928 4287137928 4236806280 646482056 16777215 2508753032 4287137928 4287137928 4287137928 4287137928 4287137928 2726856840 16777215 16777215 495487112 4186474632 4287137928 4287137928 4287137928 4236806280 612927624 16777215 16777215 16777215 2542307464 4287137928 4287137928 4287137928 2676525192 16777215 16777215 16777215 16777215 478709896 4169697416 4287137928 4220029064 579373192 16777215 16777215 16777215 16777215 16777215 2424866952 4287137928 2626193544 16777215 16777215 16777215 16777215 16777215 16777215 394823816 4018702472 529041544 16777215 16777215 16777215 16777215 16777215 16777215 16777215 864585864 16777215 16777215 16777215 16777215) 431940 offset: 0@0)! ! 431941 431942!UIThemeWatery methodsFor: 'initialize-release' stamp: 'gvc 11/5/2007 15:08'! 431943newTreeUnexpandedForm 431944 "Answer a new form for an unexpanded tree item." 431945 431946 ^(Form 431947 extent: 9@9 431948 depth: 32 431949 fromArray: #( 1049135240 461932680 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2324203656 4152920200 2458421384 428378248 16777215 16777215 16777215 16777215 16777215 2357758088 4287137928 4287137928 4152920200 2408089736 394823816 16777215 16777215 16777215 2391312520 4287137928 4287137928 4287137928 4287137928 4119365768 2324203656 344492168 16777215 2408089736 4287137928 4287137928 4287137928 4287137928 4287137928 4287137928 3968370824 780699784 2391312520 4287137928 4287137928 4287137928 4287137928 4236806280 2659747976 529041544 16777215 2357758088 4287137928 4287137928 4253583496 2810742920 646482056 16777215 16777215 16777215 2324203656 4253583496 2777188488 696813704 16777215 16777215 16777215 16777215 16777215 1200130184 663259272 16777215 16777215 16777215 16777215 16777215 16777215 16777215) 431950 offset: 0@0)! ! 431951 431952!UIThemeWatery methodsFor: 'initialize-release' stamp: 'gvc 10/24/2007 12:42'! 431953newWindowCloseForm 431954 "Answer a new form for a window close box." 431955 431956 ^(Form 431957 extent: 16@16 431958 depth: 32 431959 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4290361785 4285822068 4282071867 4279440147 4279440147 4282071867 4285822068 4290361785 0 0 0 0 0 0 0 4287335307 4281808438 4283254086 4286543478 4288254096 4288188560 4286543478 4283254086 4281808438 4287335307 0 0 0 0 0 4287138185 4280425243 4285027670 4289633180 4292135884 4293254878 4293320928 4292267469 4289567644 4285093206 4280490779 4287203978 0 0 0 4290164406 4282134834 4284233271 4288637549 4291401881 4292653234 4292850869 4292785333 4292653234 4291467161 4288637549 4284364600 4282266163 4290230199 0 0 4286545534 4283178015 4287182138 4289281086 4290597711 4290995037 4291126110 4291126109 4290929244 4290662991 4289281086 4287182394 4283309344 4286611327 0 0 4283383359 4285867306 4288685092 4289799715 4290590512 4290856252 4290988611 4291054147 4290922044 4290590256 4289930531 4288619300 4285867562 4283711040 0 0 4282782229 4287833644 4289996837 4290787376 4291381825 4291909968 4292173910 4292239446 4292106833 4291578692 4290984239 4290193702 4287833644 4283044630 0 0 4284026900 4289014315 4291051835 4291973448 4292633434 4293226345 4293556336 4293622129 4293358699 4292896092 4292236105 4291445307 4289014058 4284092436 0 0 4285414719 4289343786 4291712331 4293027933 4293949038 4294280317 4294479236 4294479236 4294346110 4294015086 4293224799 4291974475 4289343785 4285545791 0 0 4287264888 4288555300 4292239449 4293818479 4294542716 4294546314 4294614419 4294614676 4294546828 4294543230 4293884271 4292501850 4288751652 4287330424 0 0 4290558650 4286658615 4291253841 4293951868 4294481292 4294615447 4294617247 4294618017 4294616217 4294481550 4294214781 4291779154 4286789430 4290493114 0 0 4292664540 4288385426 4287573545 4292374633 4293892240 4294289824 4294555050 4294555308 4294356387 4293958547 4292835183 4287836460 4288385426 4292664540 0 0 0 4292993505 4288320403 4286993487 4289421400 4291463295 4292845463 4293043354 4291660419 4289684573 4287256400 4288254867 4292993505 0 0 0 0 0 4292927712 4291282630 4287858566 4286996058 4286533190 4286598726 4287324509 4287858309 4291348680 4292927712 0 0 0 0 0 0 0 4292401368 4293125091 4293454056 4293190884 4293190884 4293190884 4293125091 4292401368 0 0 0 0) 431960 offset: 0@0)! ! 431961 431962!UIThemeWatery methodsFor: 'initialize-release' stamp: 'gvc 4/21/2009 15:59'! 431963newWindowInactiveControlForm 431964 "Answer a new form for an inactive window control box." 431965 431966 ^(Form 431967 extent: 16@16 431968 depth: 32 431969 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4291677645 4288585374 4286085240 4284243036 4284243036 4286085240 4288585374 4291677645 0 0 0 0 0 0 0 4289572269 4285756275 4286479998 4288716960 4289835441 4289835441 4288716960 4286479998 4285756275 4289572269 0 0 0 0 0 4289506476 4284835173 4287335307 4290559164 4292598747 4293322470 4293322470 4292598747 4290559164 4287335307 4284703587 4289506476 0 0 0 4291546059 4285493103 4286414205 4288980132 4291217094 4292335575 4292598747 4292598747 4292335575 4291282887 4288980132 4286282619 4285493103 4291546059 0 0 4288980132 4285361517 4287466893 4288782753 4289835441 4290295992 4290295992 4290427578 4290164406 4289835441 4288782753 4287466893 4285361517 4288980132 0 0 4286282619 4286611584 4288059030 4288716960 4289177511 4289572269 4289835441 4289835441 4289703855 4289374890 4288782753 4288059030 4286611584 4286282619 0 0 4285164138 4287664272 4288782753 4289374890 4289835441 4290427578 4290624957 4290624957 4290559164 4290032820 4289374890 4288914339 4287664272 4285164138 0 0 4285361517 4288322202 4289703855 4290295992 4290822336 4291414473 4291677645 4291677645 4291414473 4291085508 4290427578 4289703855 4288453788 4285624689 0 0 4287072135 4288716960 4290427578 4291217094 4291677645 4292203989 4292598747 4292598747 4292335575 4291809231 4291217094 4290427578 4288716960 4287203721 0 0 4288980132 4288256409 4290624957 4291677645 4292335575 4292927712 4293256677 4293256677 4293059298 4292598747 4291809231 4290822336 4288256409 4289177511 0 0 4291677645 4287664272 4290295992 4292006610 4293059298 4293454056 4293585642 4293585642 4293454056 4293125091 4292203989 4290427578 4287730065 4291677645 0 0 4293256677 4290032820 4288124823 4291217094 4292796126 4293322470 4293717228 4293717228 4293454056 4292927712 4291677645 4288256409 4290032820 4293256677 0 0 0 4293454056 4290032820 4288322202 4289967027 4291546059 4292598747 4292664540 4291677645 4290295992 4288716960 4290032820 4293454056 0 0 0 0 0 4293322470 4292203989 4289835441 4288782753 4288322202 4288453788 4288980132 4289835441 4292335575 4293322470 0 0 0 0 0 0 0 4293059298 4293585642 4293717228 4293585642 4293585642 4293585642 4293585642 4293059298 0 0 0 0) 431970 offset: 0@0)! ! 431971 431972!UIThemeWatery methodsFor: 'initialize-release' stamp: 'gvc 10/24/2007 12:43'! 431973newWindowMaximizeForm 431974 "Answer a new form for a window maximize box." 431975 431976 ^(Form 431977 extent: 16@16 431978 depth: 32 431979 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4290295992 4285822068 4282071867 4279440147 4279440147 4282071867 4285822068 4290295992 0 0 0 0 0 0 0 4287269514 4281611316 4282795590 4285953654 4287664528 4287730320 4285953654 4282861383 4281611316 4287269514 0 0 0 0 0 4287137928 4280360481 4283914839 4288455580 4291547084 4292731360 4292796894 4291547341 4288390044 4283980376 4280294689 4287203721 0 0 0 4290164406 4281348144 4282010170 4285369453 4288527772 4290565299 4291025080 4291025080 4290630835 4288593820 4285303917 4282009913 4281348144 4290164406 0 0 4286479998 4280431648 4282282296 4283995198 4286033222 4286821198 4286952786 4287018578 4286755662 4285967429 4284060735 4282216504 4280497696 4286545791 0 0 4282402111 4281097769 4282549797 4283800345 4284982554 4285771048 4285903149 4285837356 4285771304 4285114397 4283866393 4282484773 4281097769 4282402111 0 0 4279972116 4282219307 4283997212 4285114906 4285969451 4286824254 4287152961 4287218498 4286890301 4286167084 4285246490 4284260124 4282219308 4280037908 0 0 4279975186 4283600171 4285640744 4286561842 4287547718 4288336981 4288731227 4288731228 4288402775 4287614279 4286627889 4285772072 4283600683 4280172817 0 0 4282736189 4284126245 4286692666 4287877449 4288797275 4289586536 4290112367 4290112368 4289718377 4288863579 4287877448 4286758970 4284126756 4282803005 0 0 4286284920 4283533850 4287283524 4288731993 4289718632 4290507893 4291099774 4291165055 4290705785 4289850729 4288797788 4287415878 4283599642 4286350968 0 0 4290362041 4283331374 4286560575 4289322854 4290770809 4291559299 4291952522 4292083595 4291690372 4290903163 4289455464 4286889281 4283462959 4290362040 0 0 4292664540 4287928465 4283793702 4288007509 4290572412 4291689100 4292607381 4292607382 4291885710 4290900861 4288666201 4284122406 4287928465 4292664540 0 0 0 4292993505 4288059538 4284842051 4286688328 4289384043 4290962050 4291224710 4289646450 4287083084 4285171781 4287928466 4292993505 0 0 0 0 0 4292927712 4291217093 4287402885 4285630033 4284907832 4284973881 4285893715 4287468677 4291348680 4292927712 0 0 0 0 0 0 0 4292401368 4293125091 4293454056 4293190884 4293190884 4293190884 4293125091 4292401368 0 0 0 0) 431980 offset: 0@0)! ! 431981 431982!UIThemeWatery methodsFor: 'initialize-release' stamp: 'gvc 10/24/2007 12:47'! 431983newWindowMenuForm 431984 "Answer a new form for a window menu box." 431985 431986 ^(Form 431987 extent: 24@16 431988 depth: 32 431989 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4293125091 4287335307 4283453520 4281150765 4280690214 4280821800 4280821800 4280821800 4280821800 4280821800 4280821800 4280821800 4280821800 4280690214 4281150765 4283453520 4287335307 4293125091 0 0 0 0 0 4293059298 4285493103 4282795590 4287072135 4289638062 4290493371 4290822336 4290756543 4290756543 4290822336 4290822336 4290756543 4290756543 4290822336 4290493371 4289638062 4287072135 4282795590 4285493103 4293059298 0 0 0 0 4287335307 4282598211 4288322202 4291875024 4292927712 4293322470 4293519849 4293519849 4293519849 4293519849 4293519849 4293519849 4293519849 4293519849 4293322470 4292927712 4291875024 4288322202 4282598211 4287401100 0 0 0 0 4283585106 4285953654 4289967027 4291677645 4292269782 4292401368 4292401368 4292401368 4292335575 4292335575 4292335575 4292335575 4292401368 4292401368 4292401368 4292269782 4291677645 4289967027 4285953654 4283585106 0 0 0 0 4281742902 4287861651 4290493371 4291085508 4291480266 4291546059 4291611852 4291611852 4291546059 4291480266 4291480266 4291546059 4291611852 4291611852 4291546059 4291480266 4291085508 4290493371 4287861651 4281742902 0 0 0 0 4281940281 4288782753 4291414473 4292203989 4292664540 4292796126 4292927712 4292796126 4292861919 4292927712 4292927712 4292861919 4292796126 4292927712 4292796126 4292664540 4292203989 4291414473 4288782753 4281874488 0 0 0 0 4284045657 4288256409 4291546059 4293190884 4294177779 4294572537 4294440951 4294572537 4294506744 4294572537 4294572537 4294506744 4294572537 4294440951 4294572537 4294177779 4293190884 4291546059 4288256409 4284045657 0 0 0 0 4287269514 4283914071 4290624957 4293190884 4294638330 4294769916 4294835709 4294835709 4294835709 4294835709 4294835709 4294835709 4294835709 4294835709 4294769916 4294638330 4293190884 4290624957 4283914071 4287269514 0 0 0 0 4292467161 4286414205 4283387727 4287993237 4291019715 4292269782 4292467161 4292467161 4292467161 4292467161 4292467161 4292467161 4292467161 4292467161 4292598747 4291611852 4287993237 4283387727 4286414205 4292467161 0 0 0 0 4292401368 4292467161 4288124823 4284177243 4281150765 4280229663 4280361249 4280361249 4280361249 4280361249 4280361249 4280361249 4280361249 4280361249 4280229663 4281282351 4284177243 4288124823 4292467161 4292401368 0 0 0 0 0 4292203989 4292203989 4292335575 4292401368 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292664540 4292401368 4292335575 4292269782 4292203989 0 0 0 0 0 0 0 4292006610 4292401368 4292467161 4292730333 4292730333 4292730333 4292730333 4292730333 4292730333 4292730333 4292730333 4292730333 4292796126 4292467161 4292401368 4292006610 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 431990 offset: 0@0)! ! 431991 431992!UIThemeWatery methodsFor: 'initialize-release' stamp: 'gvc 10/24/2007 12:44'! 431993newWindowMinimizeForm 431994 "Answer a new form for a window minimize box." 431995 431996 ^(Form 431997 extent: 16@16 431998 depth: 32 431999 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4290295992 4285953140 4282726971 4280619283 4280619283 4282661434 4285953140 4290295992 0 0 0 0 0 0 0 4287400586 4282921779 4284629572 4287526262 4288909456 4288974992 4287591798 4284761414 4282856243 4287400586 0 0 0 0 0 4287334536 4282588703 4286796631 4290682268 4292529868 4293385950 4293385950 4292529612 4290682268 4286731095 4282654242 4287400329 0 0 0 4290164406 4283247407 4286332215 4290281068 4292457116 4293447349 4293579448 4293579447 4293447349 4292457116 4290346605 4286660409 4283771952 4290164406 0 0 4287004286 4284555291 4289551160 4291461439 4292647750 4292978252 4292978510 4292978510 4292912459 4292516422 4291461695 4289485625 4285736224 4287004543 0 0 4284694079 4287316261 4291129383 4292379927 4292907543 4293237538 4293434920 4293369896 4293303330 4293104407 4292380439 4291130151 4288301098 4284694078 0 0 4285013269 4289947179 4292577049 4293498387 4293959974 4294159159 4294291774 4294357567 4294291256 4294091813 4293695508 4292774682 4290144044 4285013782 0 0 4286197779 4291263275 4293565218 4294486826 4294752322 4294754384 4294624599 4294756183 4294755663 4294753345 4294618155 4293828129 4291395115 4286263315 0 0 4286797373 4291592487 4294093364 4294753602 4294822482 4294825059 4294826346 4294826603 4294825828 4294822740 4294753602 4294225462 4291855399 4286928446 0 0 4287791736 4290870043 4294029633 4294691156 4294826081 4294894447 4294962297 4294963066 4294895474 4294892130 4294691669 4294096449 4291001115 4287857272 0 0 4290558649 4287916079 4292847677 4294431071 4294829938 4294964349 4294965892 4294966661 4294964606 4294896499 4294563169 4292980029 4287981872 4290558648 0 0 4292664540 4288452497 4288312611 4292590416 4294239351 4294636933 4294835601 4294835346 4294637704 4294306681 4293052245 4288576291 4288452497 4292664540 0 0 0 4292993505 4288321426 4287199810 4289700930 4291873639 4293321856 4293387137 4292005738 4290096709 4287463236 4288321426 4292993505 0 0 0 0 0 4292927712 4291282629 4287861124 4287137103 4286939445 4286939701 4287532112 4287926916 4291348680 4292927712 0 0 0 0 0 0 0 4292401368 4293125091 4293454056 4293190884 4293190884 4293190884 4293125091 4292401368 0 0 0 0) 432000 offset: 0@0)! ! 432001 432002 432003!UIThemeWatery methodsFor: 'label-styles' stamp: 'gvc 11/13/2007 13:17'! 432004buttonLabelForText: aTextOrString 432005 "Answer the label to use for the given text." 432006 432007 ^aTextOrString isString 432008 ifTrue: [(FuzzyLabelMorph contents: aTextOrString) 432009 alpha: 0.3] 432010 ifFalse: [super buttonLabelForText: aTextOrString]! ! 432011 432012!UIThemeWatery methodsFor: 'label-styles' stamp: 'gvc 3/27/2008 21:44'! 432013configureWindowLabelAreaFor: aWindow 432014 "Configure the label area for the given window." 432015 432016 |padding| 432017 padding := 0. 432018 aWindow labelArea 432019 addMorphBack: (Morph new extent: aWindow class borderWidth @ 0). 432020 aWindow hasCloseBox ifTrue: [aWindow addCloseBox. padding := padding + 1]. 432021 aWindow hasCollapseBox ifTrue: [aWindow addCollapseBox. padding := padding + 1]. 432022 aWindow hasExpandBox ifTrue: [aWindow addExpandBox. padding := padding + 1]. 432023 aWindow hasMenuBox ifTrue: [padding := padding - 1]. 432024 aWindow labelArea 432025 addMorphBack: (Morph new extent: aWindow class borderWidth @ 0; hResizing: #spaceFill). 432026 aWindow basicLabel ifNotNilDo: [:label | aWindow labelArea addMorphBack: label; hResizing: #shrinkWrap]. 432027 aWindow labelArea 432028 addMorphBack: (Morph new extent: aWindow class borderWidth @ 0; hResizing: #spaceFill). 432029 padding > 0 ifTrue: [ 432030 aWindow labelArea 432031 addMorphBack: (Morph new extent: (aWindow boxExtent x * padding) @ 0)]. 432032 aWindow hasMenuBox ifTrue: [aWindow addMenuControl]. 432033 aWindow labelArea 432034 addMorphBack: (Morph new extent: aWindow class borderWidth @ 0)! ! 432035 432036!UIThemeWatery methodsFor: 'label-styles' stamp: 'gvc 4/21/2009 16:35'! 432037createCloseBoxFor: aSystemWindow 432038 "Answer a button for closing the window." 432039 432040 |form msb| 432041 form := self windowCloseForm. 432042 msb := MultistateButtonMorph new extent: form extent. 432043 msb activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 432044 form := self windowClosePassiveForm. 432045 msb extent: form extent. 432046 msb activeDisabledNotOverUpFillStyle: (ImageFillStyle form: form). 432047 msb passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 432048 msb passiveDisabledNotOverUpFillStyle: (ImageFillStyle form: form). 432049 form := self windowCloseForm. 432050 msb extent: form extent. 432051 msb 432052 activeEnabledOverUpFillStyle: (ImageFillStyle form: form); 432053 passiveEnabledOverUpFillStyle: (ImageFillStyle form: form). 432054 form := self windowClosePassiveForm. 432055 msb 432056 extent: form extent; 432057 activeEnabledOverDownFillStyle: (ImageFillStyle form: form); 432058 passiveEnabledOverDownFillStyle: (ImageFillStyle form: form); 432059 addUpAction: [aSystemWindow closeBoxHit]; 432060 setBalloonText: 'close this window' translated; 432061 extent: aSystemWindow boxExtent. 432062 ^msb! ! 432063 432064!UIThemeWatery methodsFor: 'label-styles' stamp: 'gvc 4/21/2009 16:14'! 432065createCollapseBoxFor: aSystemWindow 432066 "Answer a button for minimising the window." 432067 432068 |form msb| 432069 form := self windowMinimizeForm. 432070 msb := MultistateButtonMorph new extent: form extent. 432071 msb activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 432072 form := self windowMinimizePassiveForm. 432073 msb extent: form extent. 432074 msb passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 432075 form := self windowMinimizeForm. 432076 msb extent: form extent. 432077 msb 432078 activeEnabledOverUpFillStyle: (ImageFillStyle form: form); 432079 passiveEnabledOverUpFillStyle: (ImageFillStyle form: form). 432080 form := self windowMinimizePassiveForm. 432081 msb 432082 extent: form extent; 432083 activeEnabledOverDownFillStyle: (ImageFillStyle form: form); 432084 passiveEnabledOverDownFillStyle: (ImageFillStyle form: form); 432085 addUpAction: [aSystemWindow collapseBoxHit]; 432086 setBalloonText: 'collapse this window' translated; 432087 extent: aSystemWindow boxExtent. 432088 ^msb! ! 432089 432090!UIThemeWatery methodsFor: 'label-styles' stamp: 'gvc 4/21/2009 16:19'! 432091createExpandBoxFor: aSystemWindow 432092 "Answer a button for maximising/restoring the window." 432093 432094 |form msb| 432095 form := self windowMaximizeForm. 432096 msb := MultistateButtonMorph new extent: form extent. 432097 msb activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 432098 form := self windowMaximizePassiveForm. 432099 msb extent: form extent. 432100 msb passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form). 432101 form := self windowMaximizeForm. 432102 msb extent: form extent. 432103 msb 432104 activeEnabledOverUpFillStyle: (ImageFillStyle form: form); 432105 passiveEnabledOverUpFillStyle: (ImageFillStyle form: form). 432106 form := self windowMaximizePassiveForm. 432107 msb 432108 extent: form extent; 432109 activeEnabledOverDownFillStyle: (ImageFillStyle form: form); 432110 passiveEnabledOverDownFillStyle: (ImageFillStyle form: form); 432111 addUpAction: [aSystemWindow expandBoxHit]; 432112 setBalloonText: 'expand to full screen' translated; 432113 extent: aSystemWindow boxExtent. 432114 ^msb! ! 432115 432116!UIThemeWatery methodsFor: 'label-styles' stamp: 'gvc 4/21/2009 16:03'! 432117windowClosePassiveForm 432118 "Answer the form to use for passive (background) window close buttons" 432119 432120 ^self forms at: #windowClosePassive ifAbsent: [Form extent: 16@16 depth: Display depth]! ! 432121 432122!UIThemeWatery methodsFor: 'label-styles' stamp: 'gvc 4/21/2009 16:17'! 432123windowMaximizePassiveForm 432124 "Answer the form to use for passive (background) window maximize/restore buttons" 432125 432126 ^self forms at: #windowMaximizePassive ifAbsent: [Form extent: 16@16 depth: Display depth]! ! 432127 432128!UIThemeWatery methodsFor: 'label-styles' stamp: 'gvc 10/24/2007 12:45'! 432129windowMenuIconFor: aWindow 432130 "Answer the menu icon for the given window." 432131 432132 ^self windowMenuForm! ! 432133 432134!UIThemeWatery methodsFor: 'label-styles' stamp: 'gvc 4/21/2009 16:17'! 432135windowMinimizePassiveForm 432136 "Answer the form to use for passive (background) window minimize buttons" 432137 432138 ^self forms at: #windowMinimizePassive ifAbsent: [Form extent: 16@16 depth: Display depth]! ! 432139 432140 432141!UIThemeWatery methodsFor: 'morph creation' stamp: 'gvc 11/13/2007 12:09'! 432142newDialogPanelIn: aThemedMorph 432143 "Answer a new (main) dialog panel." 432144 432145 ^(super 432146 newDialogPanelIn: aThemedMorph) 432147 fillStyle: (SolidFillStyle color: Color transparent) "no pane colour tracking"! ! 432148 432149!UIThemeWatery methodsFor: 'morph creation' stamp: 'gvc 1/9/2009 17:41'! 432150newFocusIndicatorMorphFor: aMorph 432151 "Answer a new focus indicator for the given morph." 432152 432153 |radius| 432154 radius := aMorph focusIndicatorCornerRadius. 432155 ^BorderedMorph new 432156 fillStyle: Color transparent; 432157 borderStyle: ((CompositeBorder new width: radius) 432158 borders: {RoundedBorder new 432159 cornerRadius: radius; 432160 width: 1; 432161 baseColor: self settings scrollbarColor. 432162 RoundedBorder new 432163 cornerRadius: radius - 1; 432164 width: 1; 432165 baseColor: (self settings scrollbarColor alpha: 0.4)}); 432166 bounds: aMorph focusBounds! ! 432167 432168!UIThemeWatery methodsFor: 'morph creation' stamp: 'gvc 3/2/2009 12:31'! 432169newTaskbarThumbnailIn: aThemedMorph for: aWindow 432170 "Answer a taskbar thumbnail morph for the given window." 432171 432172 |answer thumb| 432173 thumb := aWindow taskbarThumbnail. 432174 answer := PanelMorph new 432175 hResizing: #shrinkWrap; 432176 vResizing: #shrinkWrap; 432177 changeTableLayout; 432178 layoutInset: 8; 432179 cellInset: 4; 432180 addMorphBack: thumb; 432181 addMorphBack: ((self 432182 buttonLabelForText: (aWindow labelString truncateWithElipsisTo: 50)) 432183 color: Color white). 432184 answer 432185 extent: answer minExtent; 432186 fillStyle: (self tasklistFillStyleFor: answer); 432187 borderStyle: (self taskbarThumbnailNormalBorderStyleFor: aWindow); 432188 cornerStyle: (self taskbarThumbnailCornerStyleFor: answer). 432189 ^answer 432190 ! ! 432191 432192"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 432193 432194UIThemeWatery class 432195 instanceVariableNames: ''! 432196 432197!UIThemeWatery class methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2007 11:31'! 432198isAbstract 432199 "Answer whether the receiver is considered to be abstract." 432200 432201 ^false! ! 432202 432203!UIThemeWatery class methodsFor: 'as yet unclassified' stamp: 'gvc 10/16/2008 16:09'! 432204newDefaultSettings 432205 "Answer a new original default settings." 432206 432207 ^super newDefaultSettings 432208 standardColorsOnly: true; 432209 autoSelectionColor: false; 432210 buttonColor: (Color r: 232 g: 232 b: 232 range: 255); 432211 windowColor: (Color r: 232 g: 232 b: 232 range: 255); 432212 scrollbarColor: (Color r: 62 g: 142 b: 220 range: 255); 432213 selectionColor: (Color r: 62 g: 142 b: 220 range: 255); 432214 progressBarColor: (Color r: 232 g: 232 b: 232 range: 255); 432215 progressBarProgressColor: (Color r: 62 g: 142 b: 220 range: 255)! ! 432216 432217!UIThemeWatery class methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2007 11:46'! 432218themeName 432219 "Answer the friendly name of the theme." 432220 432221 ^'Watery'! ! 432222UIThemeWatery subclass: #UIThemeWatery2 432223 instanceVariableNames: 'windowActiveDropShadowStyle' 432224 classVariableNames: '' 432225 poolDictionaries: '' 432226 category: 'Polymorph-Widgets-Themes'! 432227 432228!UIThemeWatery2 methodsFor: 'accessing' stamp: 'gvc 2/16/2009 17:24'! 432229windowActiveDropShadowStyle 432230 "Answer the style of drop shadow to use for active windows." 432231 432232 ^windowActiveDropShadowStyle! ! 432233 432234!UIThemeWatery2 methodsFor: 'accessing' stamp: 'gvc 2/16/2009 17:22'! 432235windowActiveDropShadowStyle: anObject 432236 "Set the value of windowActiveDropShadowStyle" 432237 432238 windowActiveDropShadowStyle := anObject! ! 432239 432240 432241!UIThemeWatery2 methodsFor: 'border-styles' stamp: 'gvc 12/9/2008 12:08'! 432242listNormalBorderStyleFor: aList 432243 "Return the normal borderStyle for the given list" 432244 432245 ^BorderStyle simple 432246 width: 1; 432247 baseColor: aList paneColor! ! 432248 432249!UIThemeWatery2 methodsFor: 'border-styles' stamp: 'gvc 1/27/2009 16:44'! 432250scrollPaneNormalBorderStyleFor: aScrollPane 432251 "Return the normal borderStyle for the given scroll pane." 432252 432253 ^BorderStyle simple 432254 width: 1; 432255 baseColor: aScrollPane paneColor! ! 432256 432257!UIThemeWatery2 methodsFor: 'border-styles' stamp: 'gvc 1/12/2009 18:28'! 432258tabPanelBorderStyleFor: aTabGroup 432259 "Answer the normal border style for a tab group." 432260 432261 ^TabPanelBorder new 432262 width: 1; 432263 baseColor: (aTabGroup paneColor alphaMixed: 0.8 with: Color black); 432264 tabSelector: aTabGroup tabSelectorMorph! ! 432265 432266 432267!UIThemeWatery2 methodsFor: 'border-styles-buttons' stamp: 'gvc 12/5/2008 14:33'! 432268buttonNormalBorderStyleFor: aButton 432269 "Return the normal button borderStyle for the given button." 432270 432271 ^BorderStyle simple 432272 width: 0; 432273 baseColor: Color transparent! ! 432274 432275!UIThemeWatery2 methodsFor: 'border-styles-buttons' stamp: 'gvc 12/9/2008 13:06'! 432276checkboxButtonDisabledBorderStyleFor: aCheckboxButton 432277 "Return the disabled checkbox button borderStyle for the given button." 432278 432279 ^self checkboxButtonNormalBorderStyleFor: aCheckboxButton! ! 432280 432281!UIThemeWatery2 methodsFor: 'border-styles-buttons' stamp: 'gvc 12/9/2008 12:46'! 432282checkboxButtonNormalBorderStyleFor: aChecboxButton 432283 "Return the normal checkbox button borderStyle for the given button." 432284 432285 ^BorderStyle simple 432286 width: 1; 432287 baseColor: Color transparent! ! 432288 432289!UIThemeWatery2 methodsFor: 'border-styles-buttons' stamp: 'gvc 12/9/2008 13:06'! 432290checkboxButtonSelectedBorderStyleFor: aCheckboxButton 432291 "Return the selected checkbox button borderStyle for the given button." 432292 432293 ^self checkboxButtonNormalBorderStyleFor: aCheckboxButton! ! 432294 432295!UIThemeWatery2 methodsFor: 'border-styles-buttons' stamp: 'gvc 1/28/2009 17:09'! 432296dropListControlButtonWidth 432297 "Answer the width of a drop list control button for this theme." 432298 432299 ^20! ! 432300 432301!UIThemeWatery2 methodsFor: 'border-styles-buttons' stamp: 'gvc 1/28/2009 17:11'! 432302expanderTitleControlButtonWidth 432303 "Answer the width of an expander title control button for this theme." 432304 432305 ^20! ! 432306 432307!UIThemeWatery2 methodsFor: 'border-styles-buttons' stamp: 'gvc 12/8/2008 19:15'! 432308radioButtonCornerStyleFor: aRadioButton 432309 "Answer the corner style for radio buttons. 432310 Answer square when not disabled since the form is rounded." 432311 432312 ^aRadioButton enabled 432313 ifTrue: [#square] 432314 ifFalse: [#rounded]! ! 432315 432316 432317!UIThemeWatery2 methodsFor: 'border-styles-scrollbars' stamp: 'gvc 10/3/2008 11:45'! 432318scrollbarNormalThumbBorderStyleFor: aScrollbar 432319 "Return the normal thumb borderStyle for the given scrollbar." 432320 432321 ^BorderStyle simple width: 0! ! 432322 432323!UIThemeWatery2 methodsFor: 'border-styles-scrollbars' stamp: 'gvc 10/3/2008 12:30'! 432324scrollbarThumbCornerStyleIn: aThemedMorph 432325 "Allow for themes to override default behaviour." 432326 432327 ^#square! ! 432328 432329 432330!UIThemeWatery2 methodsFor: 'defaults' stamp: 'gvc 1/9/2009 17:52'! 432331buttonFocusIndicatorCornerRadiusFor: aButton 432332 "Answer the default corner radius preferred for the focus indicator 432333 for the button for themes that support this." 432334 432335 ^aButton wantsRoundedCorners 432336 ifTrue: [7] 432337 ifFalse: [2]! ! 432338 432339!UIThemeWatery2 methodsFor: 'defaults' stamp: 'gvc 2/19/2009 11:34'! 432340buttonLabelInsetFor: aButton 432341 "Answer the inset to use for a button's label." 432342 432343 |left right| 432344 ^aButton wantsRoundedCorners 432345 ifTrue: [left := ((aButton roundedCorners includesAnyOf: #(1 2)) ifTrue: [8] ifFalse: [4]). 432346 right := ((aButton roundedCorners includesAnyOf: #(3 4)) ifTrue: [8] ifFalse: [4]). 432347 left@2 corner: right@2] 432348 ifFalse: [3@2]! ! 432349 432350!UIThemeWatery2 methodsFor: 'defaults' stamp: 'gvc 12/3/2008 17:23'! 432351buttonMinHeight 432352 "Answer the minumum height of a button for this theme." 432353 432354 ^24! ! 432355 432356!UIThemeWatery2 methodsFor: 'defaults' stamp: 'gvc 1/23/2009 12:23'! 432357buttonMinWidth 432358 "Answer the minumum width of a button for this theme." 432359 432360 ^24! ! 432361 432362!UIThemeWatery2 methodsFor: 'defaults' stamp: 'gvc 12/5/2008 14:58'! 432363controlButtonLabelInsetFor: aButton 432364 "Answer the inset to use for a control button's label." 432365 432366 ^2! ! 432367 432368!UIThemeWatery2 methodsFor: 'defaults' stamp: 'gvc 1/20/2009 16:39'! 432369dropListFocusIndicatorCornerRadiusFor: aDropList 432370 "Answer the default corner radius preferred for the focus indicator 432371 for the drop list for themes that support this." 432372 432373 ^aDropList wantsRoundedCorners 432374 ifTrue: [4] 432375 ifFalse: [2]! ! 432376 432377!UIThemeWatery2 methodsFor: 'defaults' stamp: 'gvc 3/13/2009 12:46'! 432378dropListInsetFor: aDropList 432379 "Answer the inset to use for drop-list layout." 432380 432381 ^0! ! 432382 432383!UIThemeWatery2 methodsFor: 'defaults' stamp: 'gvc 1/23/2009 12:35'! 432384expanderTitleInsetFor: aDropList 432385 "Answer the inset to use for expander title layout." 432386 432387 ^0! ! 432388 432389!UIThemeWatery2 methodsFor: 'defaults' stamp: 'gvc 10/3/2008 13:05'! 432390scrollbarThickness 432391 "Answer the width or height of a scrollbar as appropriate to 432392 its orientation." 432393 432394 ^13! ! 432395 432396!UIThemeWatery2 methodsFor: 'defaults' stamp: 'gvc 1/14/2009 15:32'! 432397tabSelectorCellInsetFor: aTabSelector 432398 "Answer the cell inset to use for the given tab selector." 432399 432400 ^0! ! 432401 432402 432403!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 12/8/2008 13:59'! 432404buttonBottomLeftForm 432405 "Answer the form to use for the bottom left of a button." 432406 432407 ^self forms at: #buttonBottomLeft ifAbsent: [Form extent: 11@11 depth: Display depth]! ! 432408 432409!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 12/8/2008 14:00'! 432410buttonBottomMiddleForm 432411 "Answer the form to use for the bottom middle of a button." 432412 432413 ^self forms at: #buttonBottomMiddle ifAbsent: [Form extent: 1@11 depth: Display depth]! ! 432414 432415!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 12/8/2008 14:00'! 432416buttonBottomRightForm 432417 "Answer the form to use for the bottom right of a button." 432418 432419 ^self forms at: #buttonBottomRight ifAbsent: [Form extent: 11@11 depth: Display depth]! ! 432420 432421!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 12/8/2008 14:00'! 432422buttonMiddleLeftForm 432423 "Answer the form to use for the middle left of a button." 432424 432425 ^self forms at: #buttonMiddleLeft ifAbsent: [Form extent: 11@1 depth: Display depth]! ! 432426 432427!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 12/8/2008 14:00'! 432428buttonMiddleRightForm 432429 "Answer the form to use for the middle right of a button." 432430 432431 ^self forms at: #buttonMiddleRight ifAbsent: [Form extent: 11@1 depth: Display depth]! ! 432432 432433!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 10/9/2008 13:23'! 432434buttonPanelNormalFillStyleFor: aPanel 432435 "Return the normal panel fillStyle for the given panel." 432436 432437 ^aPanel paneColor! ! 432438 432439!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 14:30'! 432440buttonSelectedBottomLeftForm 432441 "Answer the form to use for the bottom left of a selected button." 432442 432443 ^self forms at: #buttonSelectedBottomLeft ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 432444 432445!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 14:30'! 432446buttonSelectedBottomMiddleForm 432447 "Answer the form to use for the bottom middle of a selected button." 432448 432449 ^self forms at: #buttonSelectedBottomMiddle ifAbsent: [Form extent: 1@12 depth: Display depth]! ! 432450 432451!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 14:30'! 432452buttonSelectedBottomRightForm 432453 "Answer the form to use for the bottom right of a selected button." 432454 432455 ^self forms at: #buttonSelectedBottomRight ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 432456 432457!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 14:30'! 432458buttonSelectedMiddleLeftForm 432459 "Answer the form to use for the middle left of a selected button." 432460 432461 ^self forms at: #buttonSelectedMiddleLeft ifAbsent: [Form extent: 12@1 depth: Display depth]! ! 432462 432463!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 14:30'! 432464buttonSelectedMiddleRightForm 432465 "Answer the form to use for the middle right of a selected button." 432466 432467 ^self forms at: #buttonSelectedMiddleRight ifAbsent: [Form extent: 12@1 depth: Display depth]! ! 432468 432469!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 14:30'! 432470buttonSelectedTopLeftForm 432471 "Answer the form to use for the top left of a selected button." 432472 432473 ^self forms at: #buttonSelectedTopLeft ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 432474 432475!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 12/8/2008 12:41'! 432476buttonSelectedTopMiddleForm 432477 "Answer the form to use for the top middle of a selected button." 432478 432479 ^self forms at: #buttonSelectedTopMiddle ifAbsent: [Form extent: 1@12 depth: Display depth]! ! 432480 432481!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 14:31'! 432482buttonSelectedTopRightForm 432483 "Answer the form to use for the top right of a selected button." 432484 432485 ^self forms at: #buttonSelectedTopRight ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 432486 432487!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 15:22'! 432488buttonSquareBottomLeftForm 432489 "Answer the form to use for the bottom left of a square button." 432490 432491 ^self forms at: #buttonSquareBottomLeft ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 432492 432493!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 15:23'! 432494buttonSquareBottomRightForm 432495 "Answer the form to use for the bottom right of a square button." 432496 432497 ^self forms at: #buttonSquareBottomRight ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 432498 432499!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 14:37'! 432500buttonSquareSelectedBottomLeftForm 432501 "Answer the form to use for the bottom left of a selected square button." 432502 432503 ^self forms at: #buttonSquareSelectedBottomLeft ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 432504 432505!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 14:38'! 432506buttonSquareSelectedBottomRightForm 432507 "Answer the form to use for the bottom right of a selected square button." 432508 432509 ^self forms at: #buttonSquareSelectedBottomRight ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 432510 432511!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 14:38'! 432512buttonSquareSelectedTopLeftForm 432513 "Answer the form to use for the top left of a selected square button." 432514 432515 ^self forms at: #buttonSquareSelectedTopLeft ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 432516 432517!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 14:38'! 432518buttonSquareSelectedTopRightForm 432519 "Answer the form to use for the top right of a selected square button." 432520 432521 ^self forms at: #buttonSquareSelectedTopRight ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 432522 432523!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 15:24'! 432524buttonSquareTopLeftForm 432525 "Answer the form to use for the top left of a square button." 432526 432527 ^self forms at: #buttonSquareTopLeft ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 432528 432529!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 1/22/2009 15:24'! 432530buttonSquareTopRightForm 432531 "Answer the form to use for the top right of a square button." 432532 432533 ^self forms at: #buttonSquareTopRight ifAbsent: [Form extent: 12@12 depth: Display depth]! ! 432534 432535!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 12/8/2008 14:00'! 432536buttonTopLeftForm 432537 "Answer the form to use for the top left of a button." 432538 432539 ^self forms at: #buttonTopLeft ifAbsent: [Form extent: 11@12 depth: Display depth]! ! 432540 432541!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 12/8/2008 14:00'! 432542buttonTopMiddleForm 432543 "Answer the form to use for the top middle of a button." 432544 432545 ^self forms at: #buttonTopMiddle ifAbsent: [Form extent: 1@12 depth: Display depth]! ! 432546 432547!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 12/8/2008 14:01'! 432548buttonTopRightForm 432549 "Answer the form to use for the top right of a button." 432550 432551 ^self forms at: #buttonTopRight ifAbsent: [Form extent: 11@12 depth: Display depth]! ! 432552 432553!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 12/9/2008 12:43'! 432554checkboxForm 432555 "Answer the form to use for a normal checkbox." 432556 432557 ^self forms at: #checkbox ifAbsent: [Form extent: 14@14 depth: Display depth]! ! 432558 432559!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 12/9/2008 12:43'! 432560checkboxSelectedForm 432561 "Answer the form to use for a selected checkbox." 432562 432563 ^self forms at: #checkboxSelected ifAbsent: [Form extent: 14@14 depth: Display depth]! ! 432564 432565!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 10/9/2008 17:25'! 432566dialogWindowActiveFillStyleFor: aWindow 432567 "Return the window active fillStyle for the given window." 432568 432569 ^self windowActiveFillStyleFor: aWindow! ! 432570 432571!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 10/9/2008 17:25'! 432572dialogWindowInactiveFillStyleFor: aWindow 432573 "Return the window active fillStyle for the given window." 432574 432575 ^self windowInactiveFillStyleFor: aWindow! ! 432576 432577!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 10/9/2008 13:26'! 432578dockingBarNormalFillStyleFor: aToolDockingBar 432579 "Return the normal docking bar fillStyle for the given color." 432580 432581 ^aToolDockingBar paneColor! ! 432582 432583!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 3/13/2009 12:34'! 432584dropListNormalFillStyleFor: aDropList 432585 "Return the normal fillStyle for the given drop list." 432586 432587 |c| 432588 c := self windowColor. 432589 ^(BoundedGradientFillStyle ramp: { 432590 0.0->c twiceDarker. 432591 0.05-> c lighter. 432592 0.15-> Color white. 432593 1.0->Color white}) 432594 origin: aDropList topLeft; 432595 extent: aDropList width - aDropList buttonMorph width @ aDropList height; 432596 direction: 0 @ aDropList height; 432597 radial: false! ! 432598 432599!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 12/8/2008 18:40'! 432600radioButtonForm 432601 "Answer the form to use for a normal radio button." 432602 432603 ^self forms at: #radioButton ifAbsent: [Form extent: 14@14 depth: Display depth]! ! 432604 432605!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 12/8/2008 18:40'! 432606radioButtonSelectedForm 432607 "Answer the form to use for a selected radio button." 432608 432609 ^self forms at: #radioButtonSelected ifAbsent: [Form extent: 14@14 depth: Display depth]! ! 432610 432611!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 10/3/2008 13:28'! 432612scrollbarThumbBottomForm 432613 "Answer the form to use for the bottom of a vertical scrollbar." 432614 432615 ^self forms at: #sbVThumbBottom ifAbsent: [Form extent: 13@7 depth: Display depth]! ! 432616 432617!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 10/3/2008 13:28'! 432618scrollbarThumbHorizontalMiddleForm 432619 "Answer the form to use for the middle of a horizontal scrollbar." 432620 432621 ^self forms at: #sbHThumbMiddle ifAbsent: [Form extent: 1@13 depth: Display depth]! ! 432622 432623!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 10/3/2008 13:26'! 432624scrollbarThumbLeftForm 432625 "Answer the form to use for the left of a horizontal scrollbar." 432626 432627 ^self forms at: #sbHThumbLeft ifAbsent: [Form extent: 7@13 depth: Display depth]! ! 432628 432629!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 10/3/2008 13:27'! 432630scrollbarThumbRightForm 432631 "Answer the form to use for the right of a horizontal scrollbar." 432632 432633 ^self forms at: #sbHThumbRight ifAbsent: [Form extent: 7@13 depth: Display depth]! ! 432634 432635!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 10/3/2008 13:28'! 432636scrollbarThumbTopForm 432637 "Answer the form to use for the top of a vertical scrollbar." 432638 432639 ^self forms at: #sbVThumbTop ifAbsent: [Form extent: 13@7 depth: Display depth]! ! 432640 432641!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 10/3/2008 13:28'! 432642scrollbarThumbVerticalMiddleForm 432643 "Answer the form to use for the middle of a vertical scrollbar." 432644 432645 ^self forms at: #sbVThumbMiddle ifAbsent: [Form extent: 13@1 depth: Display depth]! ! 432646 432647!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 10/7/2008 12:26'! 432648windowActiveTitleFillStyleFor: aWindow 432649 "Return the window active title fillStyle for the given window." 432650 432651 |aColor| 432652 aColor := self windowColor. 432653 ^(GradientFillStyle ramp: { 432654 0.0->aColor twiceLighter. 432655 1.0->aColor}) 432656 origin: aWindow labelArea topLeft; 432657 direction: 0 @ aWindow labelHeight; 432658 radial: false! ! 432659 432660!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 10/9/2008 17:24'! 432661windowInactiveFillStyleFor: aWindow 432662 "Return the window inactive fillStyle for the given window." 432663 432664 ^self windowColor twiceLighter! ! 432665 432666!UIThemeWatery2 methodsFor: 'fill-styles' stamp: 'gvc 10/9/2008 17:23'! 432667windowInactiveTitleFillStyleFor: aWindow 432668 "Return the window inactive title fillStyle for the given window." 432669 432670 |aColor| 432671 aColor := self windowColor twiceLighter. 432672 ^(GradientFillStyle ramp: { 432673 0.0->aColor twiceLighter. 432674 1.0->aColor}) 432675 origin: aWindow labelArea topLeft; 432676 direction: 0 @ aWindow labelHeight; 432677 radial: false! ! 432678 432679 432680!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 1/22/2009 15:24'! 432681buttonNormalFillStyleFor: aButton 432682 "Return the normal button fillStyle for the given button." 432683 432684 |round roundCorners tl t tr l m r bl b br| 432685 round := aButton wantsRoundedCorners. 432686 roundCorners := aButton roundedCorners. 432687 tl := (round and: [roundCorners includes: 1]) ifTrue: [self buttonTopLeftForm] ifFalse: [self buttonSquareTopLeftForm]. 432688 t := self buttonTopMiddleForm. 432689 tr:= (round and: [roundCorners includes: 4]) ifTrue: [self buttonTopRightForm] ifFalse: [self buttonSquareTopRightForm]. 432690 l := self buttonMiddleLeftForm. m := Color r: 211 g: 211 b: 211 range: 255. r := self buttonMiddleRightForm. 432691 bl := (round and: [roundCorners includes: 2]) ifTrue: [self buttonBottomLeftForm] ifFalse: [self buttonSquareBottomLeftForm]. 432692 b := self buttonBottomMiddleForm. 432693 br := (round and: [roundCorners includes: 3]) ifTrue: [self buttonBottomRightForm] ifFalse: [self buttonSquareBottomRightForm]. 432694 ^self 432695 multiFormFillStyleFrom: {tl. t. tr. l. m. r. bl. b. br} 432696 in: aButton bounds! ! 432697 432698!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 1/22/2009 14:40'! 432699buttonSelectedFillStyleFor: aButton 432700 "Return the selected button fillStyle for the given button." 432701 432702 |round roundCorners tl t tr l m r bl b br| 432703 round := aButton wantsRoundedCorners. 432704 roundCorners := aButton roundedCorners. 432705 tl := (round and: [roundCorners includes: 1]) ifTrue: [self buttonSelectedTopLeftForm] ifFalse: [self buttonSquareSelectedTopLeftForm]. 432706 t := self buttonSelectedTopMiddleForm. 432707 tr:= (round and: [roundCorners includes: 4]) ifTrue: [self buttonSelectedTopRightForm] ifFalse: [self buttonSquareSelectedTopRightForm]. 432708 l := self buttonSelectedMiddleLeftForm. m := Color r: 102 g: 127 b: 168 range: 255. r := self buttonSelectedMiddleRightForm. 432709 bl := (round and: [roundCorners includes: 2]) ifTrue: [self buttonSelectedBottomLeftForm] ifFalse: [self buttonSquareSelectedBottomLeftForm]. 432710 b := self buttonSelectedBottomMiddleForm. 432711 br := (round and: [roundCorners includes: 3]) ifTrue: [self buttonSelectedBottomRightForm] ifFalse: [self buttonSquareSelectedBottomRightForm]. 432712 ^self 432713 multiFormFillStyleFrom: {tl. t. tr. l. m. r. bl. b. br} 432714 in: aButton bounds! ! 432715 432716!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 12/9/2008 13:08'! 432717checkboxButtonDisabledFillStyleFor: aCheckboxButton 432718 "Return the disabled checkbox button fillStyle for the given button." 432719 432720 ^self checkboxButtonNormalFillStyleFor: aCheckboxButton! ! 432721 432722!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 12/9/2008 12:45'! 432723checkboxButtonNormalFillStyleFor: aCheckboxButton 432724 "Return the normal checkbox button fillStyle for the given checkbox button." 432725 432726 ^(ImageFillStyle form: self checkboxForm) origin: aCheckboxButton topLeft! ! 432727 432728!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 12/9/2008 12:45'! 432729checkboxButtonSelectedFillStyleFor: aCheckboxButton 432730 "Return the selected checkbox button fillStyle for the given checkbox button." 432731 432732 ^(ImageFillStyle form: self checkboxSelectedForm) origin: aCheckboxButton topLeft! ! 432733 432734!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 1/28/2009 17:52'! 432735controlButtonDisabledFillStyleFor: aButton 432736 "Return the disabled control button fillStyle for the given button. 432737 Control buttons are generally used for drop-lists and expanders." 432738 432739 ^self controlButtonNormalFillStyleFor: aButton! ! 432740 432741!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 1/28/2009 17:58'! 432742controlButtonNormalFillStyleFor: aButton 432743 "Return the normal control button fillStyle for the given button. 432744 Control buttons are generally used for drop-lists and expanders." 432745 432746 |round roundCorners tl t tr l m r bl b br tlw trw blw brw| 432747 round := aButton wantsRoundedCorners. 432748 roundCorners := aButton roundedCorners. 432749 tl := (round and: [roundCorners includes: 1]) ifTrue: [self buttonSelectedTopLeftForm] ifFalse: [self buttonSquareSelectedTopLeftForm]. 432750 tlw := (round and: [roundCorners includes: 1]) ifTrue: [tl width] ifFalse: [4]. 432751 t := self buttonSelectedTopMiddleForm. 432752 tr := (round and: [roundCorners includes: 4]) ifTrue: [self buttonSelectedTopRightForm] ifFalse: [self buttonSquareSelectedTopRightForm]. 432753 trw := (round and: [roundCorners includes: 4]) ifTrue: [tr width] ifFalse: [4]. 432754 l := self buttonSelectedMiddleLeftForm. m := Color r: 102 g: 127 b: 168 range: 255. r := self buttonSelectedMiddleRightForm. 432755 bl := (round and: [roundCorners includes: 2]) ifTrue: [self buttonSelectedBottomLeftForm] ifFalse: [self buttonSquareSelectedBottomLeftForm]. 432756 blw := (round and: [roundCorners includes: 2]) ifTrue: [bl width] ifFalse: [4]. 432757 b := self buttonSelectedBottomMiddleForm. 432758 br := (round and: [roundCorners includes: 3]) ifTrue: [self buttonSelectedBottomRightForm] ifFalse: [self buttonSquareSelectedBottomRightForm]. 432759 brw := (round and: [roundCorners includes: 3]) ifTrue: [br width] ifFalse: [4]. 432760 ^self 432761 multiFormFillStyleFrom: {tl. t. tr. l. m. r. bl. b. br} 432762 cornerWidths: {tlw. trw. blw. brw} 432763 in: aButton bounds! ! 432764 432765!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 1/28/2009 17:55'! 432766controlButtonPressedFillStyleFor: aButton 432767 "Return the pressed button fillStyle for the given button. 432768 Control buttons are generally used for drop-lists and expanders." 432769 432770 ^self controlButtonSelectedFillStyleFor: aButton! ! 432771 432772!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 1/28/2009 17:53'! 432773controlButtonSelectedDisabledFillStyleFor: aButton 432774 "Return the selected disabled control button fillStyle for the given button. 432775 Control buttons are generally used for drop-lists and expanders." 432776 432777 ^self controlButtonSelectedFillStyleFor: aButton! ! 432778 432779!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 1/28/2009 18:02'! 432780controlButtonSelectedFillStyleFor: aButton 432781 "Return the selected control button fillStyle for the given button. 432782 Control buttons are generally used for drop-lists and expanders." 432783 432784 |round roundCorners tl t tr l m r bl b br tlw trw blw brw| 432785 round := aButton wantsRoundedCorners. 432786 roundCorners := aButton roundedCorners. 432787 tl := (round and: [roundCorners includes: 1]) ifTrue: [self buttonTopLeftForm] ifFalse: [self buttonSquareTopLeftForm]. 432788 tlw := (round and: [roundCorners includes: 1]) ifTrue: [tl width] ifFalse: [4]. 432789 t := self buttonTopMiddleForm. 432790 tr := (round and: [roundCorners includes: 4]) ifTrue: [self buttonTopRightForm] ifFalse: [self buttonSquareTopRightForm]. 432791 trw := (round and: [roundCorners includes: 4]) ifTrue: [tr width] ifFalse: [4]. 432792 l := self buttonMiddleLeftForm. m := Color r: 102 g: 127 b: 168 range: 255. r := self buttonMiddleRightForm. 432793 bl := (round and: [roundCorners includes: 2]) ifTrue: [self buttonBottomLeftForm] ifFalse: [self buttonSquareBottomLeftForm]. 432794 blw := (round and: [roundCorners includes: 2]) ifTrue: [bl width] ifFalse: [4]. 432795 b := self buttonBottomMiddleForm. 432796 br := (round and: [roundCorners includes: 3]) ifTrue: [self buttonBottomRightForm] ifFalse: [self buttonSquareBottomRightForm]. 432797 brw := (round and: [roundCorners includes: 3]) ifTrue: [br width] ifFalse: [4]. 432798 ^self 432799 multiFormFillStyleFrom: {tl. t. tr. l. m. r. bl. b. br} 432800 cornerWidths: {tlw. trw. blw. brw} 432801 in: aButton bounds! ! 432802 432803!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 1/28/2009 17:54'! 432804controlButtonSelectedMouseOverFillStyleFor: aButton 432805 "Return the selected mouse over control button fillStyle for the given button. 432806 Control buttons are generally used for drop-lists and expanders." 432807 432808 ^self controlButtonSelectedFillStyleFor: aButton! ! 432809 432810!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 1/28/2009 17:54'! 432811controlButtonSelectedPressedFillStyleFor: aButton 432812 "Return the selected pressed button fillStyle for the given button. 432813 Control buttons are generally used for drop-lists and expanders." 432814 432815 ^self buttonSelectedFillStyleFor: aButton! ! 432816 432817!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 12/9/2008 13:10'! 432818radioButtonDisabledFillStyleFor: aRadioButton 432819 "Return the disabled radio button fillStyle for the given button." 432820 432821 ^self radioButtonNormalFillStyleFor: aRadioButton! ! 432822 432823!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 12/8/2008 18:41'! 432824radioButtonNormalFillStyleFor: aRadioButton 432825 "Return the normal radio button fillStyle for the given button." 432826 432827 ^(ImageFillStyle form: self radioButtonForm) origin: aRadioButton topLeft! ! 432828 432829!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 12/9/2008 13:11'! 432830radioButtonSelectedDisabledFillStyleFor: aRadioButton 432831 "Return the selected disabled radio button fillStyle for the given button." 432832 432833 ^self radioButtonNormalFillStyleFor: aRadioButton! ! 432834 432835!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 12/8/2008 18:42'! 432836radioButtonSelectedFillStyleFor: aRadioButton 432837 "Return the selected radio button fillStyle for the given button." 432838 432839 ^(ImageFillStyle form: self radioButtonSelectedForm) origin: aRadioButton topLeft! ! 432840 432841!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 2/14/2009 18:49'! 432842tabLabelNormalFillStyleFor: aTabLabel 432843 "Return the normal fillStyle for the given tab label." 432844 432845 |round roundCorners tl t tr l m r| 432846 round := aTabLabel wantsRoundedCorners. 432847 roundCorners := aTabLabel roundedCorners. 432848 tl := (round and: [roundCorners includes: 1]) ifTrue: [self buttonTopLeftForm] ifFalse: [self buttonSquareTopLeftForm]. 432849 t := self buttonTopMiddleForm. 432850 tr := (round and: [roundCorners includes: 4]) ifTrue: [self buttonTopRightForm] ifFalse: [self buttonSquareTopRightForm]. 432851 l := self buttonMiddleLeftForm. m := Color r: 211 g: 211 b: 211 range: 255. r := self buttonMiddleRightForm. 432852 ^self 432853 multiFormTopFillStyleFrom: {tl. t. tr. l. m. r} 432854 in: aTabLabel bounds! ! 432855 432856!UIThemeWatery2 methodsFor: 'fill-styles-buttons' stamp: 'gvc 2/14/2009 18:49'! 432857tabLabelSelectedFillStyleFor: aTabLabel 432858 "Return the selected fillStyle for the given tab label." 432859 432860 |round roundCorners tl t tr l m r| 432861 round := aTabLabel wantsRoundedCorners. 432862 roundCorners := aTabLabel roundedCorners. 432863 tl := (round and: [roundCorners includes: 1]) ifTrue: [self buttonSelectedTopLeftForm] ifFalse: [self buttonSquareSelectedTopLeftForm]. 432864 t := self buttonSelectedTopMiddleForm. 432865 tr := (round and: [roundCorners includes: 4]) ifTrue: [self buttonSelectedTopRightForm] ifFalse: [self buttonSquareSelectedTopRightForm]. 432866 l := self buttonSelectedMiddleLeftForm. m := Color r: 102 g: 127 b: 168 range: 255. r := self buttonSelectedMiddleRightForm. 432867 ^self 432868 multiFormTopFillStyleFrom: {tl. t. tr. l. m. r} 432869 in: aTabLabel bounds! ! 432870 432871 432872!UIThemeWatery2 methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 2/3/2009 14:28'! 432873baseScrollbarColorFor: aScrollbar 432874 "Return the scrollbar last pane colour or that of our settings if unavailable" 432875 432876 ^(aScrollbar valueOfProperty: #lastPaneColor) ifNil: [self settings scrollbarColor]! ! 432877 432878!UIThemeWatery2 methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 2/3/2009 14:28'! 432879scrollbarImageColorFor: aScrollbar 432880 "Return the scrollbar image colour (on buttons) for the given scrollbar." 432881 432882 ^(self baseScrollbarColorFor: aScrollbar) darker! ! 432883 432884!UIThemeWatery2 methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 2/3/2009 14:28'! 432885scrollbarNormalButtonFillStyleFor: aScrollbar 432886 "Return the normal scrollbar button fillStyle for the given scrollbar." 432887 432888 |c| 432889 c := self baseScrollbarColorFor: aScrollbar. 432890 ^(GradientFillStyle ramp: {0.0->c twiceLighter. 1.0->c darker}) 432891 origin: aScrollbar topLeft; 432892 direction: (aScrollbar bounds isWide 432893 ifTrue: [0 @ aScrollbar height] 432894 ifFalse: [aScrollbar width @ 0]); 432895 radial: false! ! 432896 432897!UIThemeWatery2 methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 2/3/2009 14:29'! 432898scrollbarNormalFillStyleFor: aScrollbar 432899 "Return the normal scrollbar fillStyle for the given scrollbar." 432900 432901 |aColor c| 432902 aColor := (self baseScrollbarColorFor: aScrollbar) muchLighter. 432903 c := aColor alphaMixed: 0.9 with: Color black. 432904 ^(GradientFillStyle ramp: {0.0->c. 0.15->aColor. 0.75-> aColor lighter. 1.0->c}) 432905 origin: aScrollbar topLeft; 432906 direction: (aScrollbar bounds isWide 432907 ifTrue: [0 @ aScrollbar height] 432908 ifFalse: [aScrollbar width @ 0]); 432909 radial: false! ! 432910 432911!UIThemeWatery2 methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 10/3/2008 13:32'! 432912scrollbarNormalHorizontalThumbFillStyleFor: aScrollbar 432913 "Return the normal scrollbar horizontal thumb fillStyle for the given scrollbar." 432914 432915 |s l m r| 432916 s := aScrollbar slider. 432917 l := self scrollbarThumbLeftForm. 432918 m := self scrollbarThumbHorizontalMiddleForm. 432919 r := self scrollbarThumbRightForm. 432920 ^CompositeFillStyle fillStyles: { 432921 (ImageFillStyle form: l) origin: s topLeft. 432922 (AlphaInfiniteForm with: m) 432923 origin: s topLeft + (l width@0); 432924 extent: (s width - l width - r width)@m height. 432925 (ImageFillStyle form: r) 432926 origin: s topRight - (r width@0)}! ! 432927 432928!UIThemeWatery2 methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 10/3/2008 13:33'! 432929scrollbarNormalThumbFillStyleFor: aScrollbar 432930 "Return the normal scrollbar thumb fillStyle for the given scrollbar." 432931 432932 ^aScrollbar bounds isWide 432933 ifTrue: [self scrollbarNormalHorizontalThumbFillStyleFor: aScrollbar] 432934 ifFalse: [self scrollbarNormalVerticalThumbFillStyleFor: aScrollbar]! ! 432935 432936!UIThemeWatery2 methodsFor: 'fill-styles-scrollbars' stamp: 'gvc 10/3/2008 13:30'! 432937scrollbarNormalVerticalThumbFillStyleFor: aScrollbar 432938 "Return the normal scrollbar vertical thumb fillStyle for the given scrollbar." 432939 432940 |s t m b| 432941 s := aScrollbar slider. 432942 t := self scrollbarThumbTopForm. 432943 m := self scrollbarThumbVerticalMiddleForm. 432944 b := self scrollbarThumbBottomForm. 432945 ^CompositeFillStyle fillStyles: { 432946 (ImageFillStyle form: t) origin: s topLeft. 432947 (AlphaInfiniteForm with: m) 432948 origin: s topLeft + (0@t height); 432949 extent: m width@(s height - t height - b height). 432950 (ImageFillStyle form: b) 432951 origin: s bottomLeft - (0@b height)}! ! 432952 432953 432954!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 2/16/2009 17:22'! 432955initialize 432956 "Initialize the receiver." 432957 432958 super initialize. 432959 self windowActiveDropShadowStyle: #diffuse! ! 432960 432961!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 15:22'! 432962initializeForms 432963 "Initialize the receiver's image forms." 432964 432965 super initializeForms. 432966 self forms 432967 at: #sbHThumbLeft put: self newScrollbarThumbLeftForm; 432968 at: #sbHThumbMiddle put: self newScrollbarThumbHorizontalMiddleForm; 432969 at: #sbHThumbRight put: self newScrollbarThumbRightForm; 432970 at: #sbVThumbTop put: self newScrollbarThumbTopForm; 432971 at: #sbVThumbMiddle put: self newScrollbarThumbVerticalMiddleForm; 432972 at: #sbVThumbBottom put: self newScrollbarThumbBottomForm; 432973 at: #buttonTopLeft put: self newButtonTopLeftForm; 432974 at: #buttonTopMiddle put: self newButtonTopMiddleForm; 432975 at: #buttonTopRight put: self newButtonTopRightForm; 432976 at: #buttonMiddleLeft put: self newButtonMiddleLeftForm; 432977 at: #buttonMiddleRight put: self newButtonMiddleRightForm; 432978 at: #buttonBottomLeft put: self newButtonBottomLeftForm; 432979 at: #buttonBottomMiddle put: self newButtonBottomMiddleForm; 432980 at: #buttonBottomRight put: self newButtonBottomRightForm; 432981 at: #buttonSquareTopLeft put: self newButtonSquareTopLeftForm; 432982 at: #buttonSquareTopRight put: self newButtonSquareTopRightForm; 432983 at: #buttonSquareBottomLeft put: self newButtonSquareBottomLeftForm; 432984 at: #buttonSquareBottomRight put: self newButtonSquareBottomRightForm; 432985 at: #buttonSelectedTopLeft put: self newButtonSelectedTopLeftForm; 432986 at: #buttonSelectedTopMiddle put: self newButtonSelectedTopMiddleForm; 432987 at: #buttonSelectedTopRight put: self newButtonSelectedTopRightForm; 432988 at: #buttonSelectedMiddleLeft put: self newButtonSelectedMiddleLeftForm; 432989 at: #buttonSelectedMiddleRight put: self newButtonSelectedMiddleRightForm; 432990 at: #buttonSelectedBottomLeft put: self newButtonSelectedBottomLeftForm; 432991 at: #buttonSelectedBottomMiddle put: self newButtonSelectedBottomMiddleForm; 432992 at: #buttonSelectedBottomRight put: self newButtonSelectedBottomRightForm; 432993 at: #buttonSquareSelectedTopLeft put: self newButtonSquareSelectedTopLeftForm; 432994 at: #buttonSquareSelectedTopRight put: self newButtonSquareSelectedTopRightForm; 432995 at: #buttonSquareSelectedBottomLeft put: self newButtonSquareSelectedBottomLeftForm; 432996 at: #buttonSquareSelectedBottomRight put: self newButtonSquareSelectedBottomRightForm; 432997 at: #radioButton put: self newRadioButtonForm; 432998 at: #radioButtonSelected put: self newRadioButtonSelectedForm; 432999 at: #checkbox put: self newCheckboxForm; 433000 at: #checkboxSelected put: self newCheckboxSelectedForm! ! 433001 433002!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 15:17'! 433003newButtonBottomLeftForm 433004 "Answer the form for the bottom left of a button." 433005 433006 ^(Form 433007 extent: 12@12 433008 depth: 32 433009 fromArray: #( 3716317826 4291743438 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 2842718320 4290953922 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 1784635231 4255886251 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 978802519 4170157967 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 374427985 3815599469 4291611852 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 41975936 1699499084 4168973693 4293190884 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 0 154745145 2891010385 4271873951 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 0 16777216 675299392 3764280926 4290098613 4293980400 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 0 0 33554432 1295332661 3595850836 4253583496 4292993505 4294309365 4294309365 4294309365 4294309365 4294309365 0 0 0 33554432 640626479 2688433726 4083574374 4289835441 4293125091 4294506744 4294572537 4294572537 0 0 0 0 16777216 138428480 1546267178 3510780482 3981989976 4184895600 4270360712 4288651167 0 0 0 0 0 0 33554432 338044454 941629472 1511989023 2268016431 3124575549) 433010 offset: 0@0)! ! 433011 433012!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 15:17'! 433013newButtonBottomMiddleForm 433014 "Answer the form for the bottom middle of a button." 433015 433016 ^(Form 433017 extent: 1@12 433018 depth: 32 433019 fromArray: #( 4292072403 4292401368 4292664540 4292927712 4293190884 4293454056 4293717228 4294046193 4294309365 4294572537 4289506476 3443342653) 433020 offset: 0@0)! ! 433021 433022!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 15:18'! 433023newButtonBottomRightForm 433024 "Answer the form for the bottom right of a button." 433025 433026 ^(Form 433027 extent: 12@12 433028 depth: 32 433029 fromArray: #( 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4291282887 3548216701 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4290230199 2607574124 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4238187933 1616731485 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4119365768 962156889 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4290756543 3697895785 374427985 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4292730333 4118378873 1666010445 41975936 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4254175633 2790215503 154745145 0 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4293848814 4289177511 3663288665 675299392 16777216 0 4294309365 4294309365 4294309365 4294309365 4294309365 4292467161 4253188738 3545453395 1295332661 33554432 0 0 4294572537 4294572537 4294440951 4292861919 4289309097 4066797158 2655010880 640626479 33554432 0 0 0 4288519581 4270294919 4168052591 3965081174 3477291843 1546267178 138428480 16777216 0 0 0 0 3107864126 2268016431 1511989023 941629472 338044454 33554432 0 0 0 0 0 0) 433030 offset: 0@0)! ! 433031 433032!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 15:18'! 433033newButtonMiddleLeftForm 433034 "Answer the form for the middle left of a button." 433035 433036 ^(Form 433037 extent: 12@1 433038 depth: 32 433039 fromArray: #( 3968305031 4292138196 4292138196 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403) 433040 offset: 0@0)! ! 433041 433042!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 15:18'! 433043newButtonMiddleRightForm 433044 "Answer the form for the middle right of a button." 433045 433046 ^(Form 433047 extent: 12@1 433048 depth: 32 433049 fromArray: #( 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 3934750599) 433050 offset: 0@0)! ! 433051 433052!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 14:28'! 433053newButtonSelectedBottomLeftForm 433054 "Answer the form for the bottom left of a selected button." 433055 433056 ^(Form 433057 extent: 12@12 433058 depth: 32 433059 fromArray: #( 3713688967 4284841382 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 2840812155 4284841122 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 1783452780 4251022487 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 977750885 4166608772 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 373704285 3813365101 4285499564 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 33554560 1698382676 4166082166 4286224317 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 0 154745173 2889761365 4267668108 4286685125 4286685125 4286685125 4286685125 4286685125 4286685125 4286685125 4286685125 0 16777216 674444102 3762375258 4285103772 4286948554 4286948554 4286948554 4286948554 4286948554 4286948554 4286948554 0 0 33554432 1294675516 3594273360 4250231929 4286619071 4287277775 4287277775 4287277775 4287277775 4287277775 0 0 0 33554432 640165935 2687513663 4081274461 4285169818 4286882243 4287606740 4287606740 4287606740 0 0 0 0 16777216 134234176 1545872426 3509597758 3980150095 4182267235 4267009399 4284642698 0 0 0 0 0 0 33554432 338044454 941629472 1511791647 2267424813 3123524408) 433060 offset: 0@0)! ! 433061 433062!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 14:28'! 433063newButtonSelectedBottomMiddleForm 433064 "Answer the form for the bottom middle of a selected button." 433065 433066 ^(Form 433067 extent: 1@12 433068 depth: 32 433069 fromArray: #( 4284907432 4285171117 4285500082 4285763767 4286092732 4286356417 4286685381 4286948810 4287278031 4287606996 4285038229 3442226232) 433070 offset: 0@0)! ! 433071 433072!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 14:28'! 433073newButtonSelectedBottomRightForm 433074 "Answer the form for the bottom right of a selected button." 433075 433076 ^(Form 433077 extent: 12@12 433078 depth: 32 433079 fromArray: #( 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284775331 3545850757 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4285170861 4284643228 2605931385 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4285499826 4233915791 1615745901 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4116079488 961039463 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4286092476 4285169827 3695858538 373704285 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286092472 4115618674 1664828245 33554560 4286685125 4286685125 4286685125 4286685125 4286685125 4286685125 4286685125 4286685125 4250495363 2789098069 154745173 0 4286948554 4286948554 4286948554 4286948554 4286948554 4286948554 4286882504 4284642962 3661580376 674444102 16777216 0 4287277775 4287277775 4287277775 4287277775 4287277775 4286421177 4250034292 3543876175 1294675516 33554432 0 0 4287606740 4287606740 4287540947 4286750399 4284906131 4064496988 2654025280 640165935 33554432 0 0 0 4284445576 4266943863 4165424226 3963307086 3476109119 1545872426 134234176 16777216 0 0 0 0 3106812728 2267424813 1511791647 941629472 338044454 33554432 0 0 0 0 0 0) 433080 offset: 0@0)! ! 433081 433082!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 14:28'! 433083newButtonSelectedMiddleLeftForm 433084 "Answer the form for the middle left of a selected button." 433085 433086 ^(Form 433087 extent: 12@1 433088 depth: 32 433089 fromArray: #( 3965347464 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432) 433090 offset: 0@0)! ! 433091 433092!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 14:28'! 433093newButtonSelectedMiddleRightForm 433094 "Answer the form for the middle right of a selected button." 433095 433096 ^(Form 433097 extent: 12@1 433098 depth: 32 433099 fromArray: #( 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 3931727240) 433100 offset: 0@0)! ! 433101 433102!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 14:29'! 433103newButtonSelectedTopLeftForm 433104 "Answer the form for the top left of a selected button." 433105 433106 ^(Form 433107 extent: 12@12 433108 depth: 32 433109 fromArray: #( 0 0 0 0 0 0 33554431 362719975 1268031205 2541850575 3279521477 3765271736 0 0 0 0 0 111848191 2407633100 4049957547 4266548622 4284838039 4287271854 4290099916 0 0 0 16777471 814060743 3581116602 4266877583 4288982209 4292730856 4292994026 4292994026 4292994026 0 0 16777471 1903987394 4099960739 4285430685 4291349978 4292270819 4292270819 4292270819 4292270819 4292270819 0 0 713067455 4083709352 4288259003 4291547356 4291547356 4291547356 4291547356 4291547356 4291547356 4291547356 0 75464703 3580787373 4287535542 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 33554431 2389802158 4251744930 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 258373546 4016337568 4286878386 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 1097823911 4200558234 4287207349 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 2070376603 4284182168 4286155693 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 3160435603 4284314525 4284577696 4287668413 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 3780930190 4284578211 4284578211 4285301417 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587) 433110 offset: 0@0)! ! 433111 433112!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 14:29'! 433113newButtonSelectedTopMiddleForm 433114 "Answer the form for the top middle of a selected button." 433115 433116 ^(Form 433117 extent: 1@12 433118 depth: 32 433119 fromArray: #( 3966269361 4291941599 4292994026 4292205027 4291547356 4290889943 4290297809 4289640652 4289114568 4288588740 4288128705 4286353587) 433120 offset: 0@0)! ! 433121 433122!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 14:29'! 433123newButtonSelectedTopRightForm 433124 "Answer the form for the top right of a selected button." 433125 433126 ^(Form 433127 extent: 12@12 433128 depth: 32 433129 fromArray: #( 3748625849 3262810310 2441121744 1184342758 295085538 33554431 0 0 0 0 0 0 4290099916 4287271854 4284904087 4266680208 4016534958 2156237519 75464703 0 0 0 0 0 4292994026 4292994026 4292994026 4292730856 4288981953 4250297491 3463873727 646616786 16777471 0 0 0 4292270819 4292270819 4292270819 4292270819 4292270819 4291284185 4285233565 4066800809 1551994565 16777471 0 0 4291547356 4291547356 4291547356 4291547356 4291547356 4291547356 4291547356 4287929784 4016798124 545033153 0 0 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4287009457 3379658160 61516543 0 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 4290297809 4290166480 4234639009 2003992240 33554431 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4286286508 3949425826 258373546 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4286747057 4167135387 896300710 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4288654276 4285760937 4250693017 1785229980 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4287471035 4284446367 4284314268 2841668498 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4285038503 4284578211 4284578211 3663554701) 433130 offset: 0@0)! ! 433131 433132!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 15:19'! 433133newButtonSquareBottomLeftForm 433134 "Answer the form for the bottom left of a square button." 433135 433136 ^(Form 433137 extent: 12@12 433138 depth: 32 433139 fromArray: #( 3968305031 4292138196 4292138196 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 3967976066 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 3967778687 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 3967449722 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 3967252343 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 3966923378 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 3966660206 4293783021 4293783021 4293783021 4293783021 4293783021 4293783021 4293783021 4293783021 4293717228 4293717228 4293717228 3966397034 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 3966133862 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 3830929239 4293783021 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 2502963248 4252596601 4289309097 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 622599196 2352034097 3409854014 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653) 433140 offset: 0@0)! ! 433141 433142!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 15:20'! 433143newButtonSquareBottomRightForm 433144 "Answer the form for the bottom right of a square button." 433145 433146 ^(Form 433147 extent: 12@12 433148 depth: 32 433149 fromArray: #( 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 4292072403 3934750599 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292401368 4292335575 3934421634 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 3934158462 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 3933895290 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 3933632118 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 4293454056 3933368946 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 3933039981 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 4294046193 3932776809 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 3932447844 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4294572537 4293388263 3780400212 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289506476 4289243304 4235556213 2452565807 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3443342653 3393076798 2352034097 622599196) 433150 offset: 0@0)! ! 433151 433152!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 14:35'! 433153newButtonSquareSelectedBottomLeftForm 433154 "Answer the form for the bottom left of a selected square button." 433155 433156 ^(Form 433157 extent: 12@12 433158 depth: 32 433159 fromArray: #( 3965347464 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 3965215874 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 3964952703 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 3964821113 4285763767 4285763767 4285763767 4285763767 4285763767 4285763767 4285763767 4285763767 4285763767 4285763767 4285763767 3964623476 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 3964426350 4286421953 4286421953 4286421953 4286421953 4286356417 4286356417 4286356417 4286356417 4286356417 4286356417 4286356417 3964294248 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685381 4286685381 4286685381 3964097124 4287014602 4287014602 4287014602 4287014346 4287014346 4287014346 4287014346 4287014346 4287014346 4287014346 4287014346 3963833950 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 3829154896 4287211978 4287607252 4287606996 4287606996 4287606996 4287606996 4287606996 4287606996 4287606996 4287606996 4287606996 2502502958 4249705579 4284972435 4285038229 4285038229 4285038229 4285038229 4285038229 4285038229 4285038229 4285038229 4285038229 622599196 2351311407 3408802615 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232) 433160 offset: 0@0)! ! 433161 433162!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 14:35'! 433163newButtonSquareSelectedBottomRightForm 433164 "Answer the form for the bottom right of a selected square button." 433165 433166 ^(Form 433167 extent: 12@12 433168 depth: 32 433169 fromArray: #( 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 4284907432 3931727240 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285171117 4285170861 3931595651 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 3931464061 4285763767 4285763767 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 4285763511 3931200888 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 3931003251 4286356417 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 4286356160 3930871661 4286685381 4286685381 4286685381 4286685381 4286685381 4286685381 4286685381 4286685381 4286685381 4286685381 4286685381 3930674280 4286948810 4286948810 4286948810 4286948810 4286948810 4286948810 4286948810 4286948810 4286948810 4286948810 4286948810 3930476899 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 3930345054 4287606996 4287606996 4287606996 4287606996 4287606996 4287606996 4287606996 4287541460 4287541460 4287541460 4286948549 3778691918 4285038229 4285038229 4285038229 4285038485 4285038485 4285038485 4285038485 4285038485 4285038485 4284841105 4232796519 2452040237 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3442226232 3392025400 2351311407 622599196) 433170 offset: 0@0)! ! 433171 433172!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 14:36'! 433173newButtonSquareSelectedTopLeftForm 433174 "Answer the form for the top left of a selected square button." 433175 433176 ^(Form 433177 extent: 12@12 433178 depth: 32 433179 fromArray: #( 630892779 3329853638 3949492146 3966269361 3966269361 3966269361 3966269361 3966269361 3966269361 3966269361 3966269361 3966269361 3028455632 4282141565 4285561500 4291744478 4291876062 4291876062 4291876062 4291876062 4291876062 4291876062 4291876062 4291876062 3916792766 4281944439 4289771209 4292928234 4292928234 4292928234 4292928234 4292928234 4292994026 4292994026 4292994026 4292994026 3966992312 4282207868 4289705673 4292139234 4292205027 4292205027 4292205027 4292205027 4292205027 4292205027 4292205027 4292205027 3966860723 4282537089 4289311174 4291481564 4291481564 4291481564 4291481564 4291481564 4291481564 4291547356 4291547356 4291547356 3966598062 4282800518 4288785346 4290889686 4290889686 4290889686 4290889686 4290889686 4290889686 4290889686 4290889686 4290889686 3966334888 4283129739 4288456639 4290232273 4290232273 4290232273 4290232273 4290232273 4290297809 4290297809 4290297809 4290297809 3966268835 4283393168 4288062397 4289640396 4289640652 4289640652 4289640652 4289640652 4289640652 4289640652 4289640652 4289640652 3966071197 4283722133 4287799227 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 3965874072 4283985818 4287405242 4288523204 4288523204 4288588740 4288588740 4288588740 4288588740 4288588740 4288588740 4288588740 3965741971 4284314782 4287208120 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 3965544845 4284578467 4285893551 4286288050 4286288050 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587) 433180 offset: 0@0)! ! 433181 433182!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 14:36'! 433183newButtonSquareSelectedTopRightForm 433184 "Answer the form for the top right of a selected square button." 433185 433186 ^(Form 433187 extent: 12@12 433188 depth: 32 433189 fromArray: #( 3966269361 3966269361 3966269361 3966269361 3966269361 3966269105 3966269105 3966269105 3966269105 3949492146 3246098890 547072752 4291941599 4291941599 4291941599 4291941599 4291941599 4291941599 4291941599 4291941599 4291810270 4285298585 4282338943 2927923665 4292994026 4292994026 4292994026 4292994026 4292994026 4292994283 4292994283 4292994283 4292994283 4289442502 4281878647 3883238334 4292205027 4292270819 4292270819 4292270819 4292270819 4292270819 4292270819 4292270819 4292270819 4289442758 4282207868 3933503928 4291547356 4291547356 4291547356 4291547356 4291547356 4291547356 4291612893 4291612893 4291612893 4289048003 4282471297 3933240756 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4290889943 4288653760 4282800518 3933043629 4290297809 4290297809 4290297809 4290297809 4290297809 4290298066 4290298066 4290298066 4290298066 4288325054 4283063947 3932911528 4289640652 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4289706189 4287930812 4283393168 3932714660 4289114568 4289114568 4289114568 4289114568 4289114568 4289114568 4289180360 4289180360 4289180360 4287602105 4283656596 3932516765 4288588740 4288588740 4288654532 4288654532 4288654532 4288654532 4288654532 4288654532 4288654532 4287339448 4283985817 3932319385 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288128705 4288194497 4288194497 4287142327 4284314782 3932187795 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4286353587 4285827758 4284578467 3931924878) 433190 offset: 0@0)! ! 433191 433192!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 15:21'! 433193newButtonSquareTopLeftForm 433194 "Answer the form for the top left of a square button." 433195 433196 ^(Form 433197 extent: 12@12 433198 depth: 32 433199 fromArray: #( 633520834 3333994680 3954422707 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3032004792 4289243304 4290822336 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 3920736689 4289374890 4292730333 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 3970805165 4289638062 4292796126 4293783021 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 3970476200 4289901234 4292664540 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 3970278821 4290164406 4292532954 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 3970015649 4290493371 4292532954 4293190884 4293190884 4293190884 4293125091 4293125091 4293190884 4293190884 4293190884 4293190884 3969686684 4290756543 4292467161 4292993505 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 3969423512 4291019715 4292467161 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 3969160340 4291282887 4292467161 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 3968831375 4291546059 4292467161 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 3968568203 4291809231 4292203989 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575) 433200 offset: 0@0)! ! 433201 433202!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 15:21'! 433203newButtonSquareTopRightForm 433204 "Answer the form for the top right of a square button." 433205 433206 ^(Form 433207 extent: 12@12 433208 depth: 32 433209 fromArray: #( 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3971199923 3954422707 3250240186 549042617 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293585642 4290690750 4289243304 2931341496 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4292598747 4289374890 3887182257 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 4293848814 4292664540 4289638062 3937184940 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4292532954 4289901234 3936987561 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4292467161 4290164406 3936658596 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4292401368 4290427578 3936329631 4293059298 4293059298 4293059298 4293059298 4293059298 4292993505 4292993505 4292993505 4292993505 4292335575 4290690750 3936132252 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292401368 4291019715 3935803287 4292796126 4292796126 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292401368 4291282887 3935540115 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292467161 4291546059 3935276943 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292203989 4291809231 3935013771) 433210 offset: 0@0)! ! 433211 433212!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 15:19'! 433213newButtonTopLeftForm 433214 "Answer the form for the top left of a button." 433215 433216 ^(Form 433217 extent: 12@12 433218 depth: 32 433219 fromArray: #( 0 0 0 0 0 0 33554431 365151171 1270791870 2545662907 3283663032 3770004917 0 0 0 0 0 111848106 2411247800 4054954417 4272729260 4290427578 4291546059 4292796126 0 0 0 33554431 817083315 3585192369 4273058225 4292401368 4293980400 4294111986 4294111986 4294111986 0 0 33554431 1907076011 4105022893 4290953922 4293454056 4293848814 4293848814 4293848814 4293848814 4293848814 0 0 715696296 4088179884 4292269782 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 0 79675327 3584402853 4291940817 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 33554431 2392628380 4256938939 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 261724569 4020281504 4292006610 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 1099795853 4205488810 4292269782 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 2072413830 4290361785 4292006610 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 3163196042 4291217094 4291611852 4292664540 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 3784150413 4291809231 4291809231 4292006610 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575) 433220 offset: 0@0)! ! 433221 433222!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 15:19'! 433223newButtonTopMiddleForm 433224 "Answer the form for the top middle of a button." 433225 433226 ^(Form 433227 extent: 1@12 433228 depth: 32 433229 fromArray: #( 3971199923 4293585642 4294111986 4293848814 4293585642 4293322470 4293190884 4293059298 4292927712 4292796126 4292796126 4292335575) 433230 offset: 0@0)! ! 433231 433232!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 1/22/2009 15:19'! 433233newButtonTopRightForm 433234 "Answer the form for the top right of a button." 433235 433236 ^(Form 433237 extent: 12@12 433238 depth: 32 433239 fromArray: #( 3753227701 3266885816 2445065404 1187103169 298042307 33554431 0 0 0 0 0 0 4292796126 4291546059 4290427578 4272729260 4021334192 2159655353 75464575 0 0 0 0 0 4294111986 4294111986 4294111986 4293980400 4292401368 4256346802 3467817650 649113776 33554431 0 0 0 4293848814 4293848814 4293848814 4293848814 4293848814 4293388263 4290822336 4071534254 1554886061 33554431 0 0 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4292072403 4020873641 548055722 0 0 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4293388263 4291611852 3382944675 67108863 0 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293125091 4239701172 2006686619 33554431 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4291809231 3953041054 261724569 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292927712 4292072403 4171473827 898206089 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4291875024 4256215216 1787069572 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292796126 4292532954 4291611852 4290822336 2843968387 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4292335575 4291940817 4291809231 4291677645 3666380936) 433240 offset: 0@0)! ! 433241 433242!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 12/11/2008 16:38'! 433243newCheckboxForm 433244 "Answer the form for a normal checkbox." 433245 433246 ^(Form 433247 extent: 14@14 433248 depth: 32 433249 fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 594242411 3918960278 4138774704 4138774704 4138774704 4138774704 4138774704 4138774704 4138774704 4138774704 4138774704 4138774704 3919026071 594242411 2575072380 4292467161 4294177779 4294177779 4294177779 4294177779 4294177779 4294177779 4294177779 4294177779 4294177779 4294177779 4292467161 2524806525 2658695288 4292664540 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4292664540 2608429433 2658432116 4292532954 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4293322470 4292532954 2608232054 2658366323 4292467161 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4293059298 4292467161 2608100468 2658037358 4292532954 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292532954 2607771503 2657839979 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 4292138196 2607639917 2657642600 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 2607442538 2657313635 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 4293190884 2607113573 2657116256 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 4293717228 2606850401 2606455643 4294046193 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294309365 4294046193 2556255581 1311978291 4237003659 4289967027 4289967027 4289967027 4289967027 4289967027 4289967027 4289967027 4289967027 4289967027 4289967027 4237003659 1278555445 50331648 1210986030 1647917369 1647917369 1647917369 1647917369 1647917369 1647917369 1647917369 1647917369 1647917369 1647917369 1210986030 50331648) 433250 offset: 0@0)! ! 433251 433252!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 12/11/2008 16:38'! 433253newCheckboxSelectedForm 433254 "Answer the form for a selected checkbox." 433255 433256 ^(Form 433257 extent: 14@14 433258 depth: 32 433259 fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 591416973 3914425236 4134435746 4134435746 4134435746 4134435746 4134435746 4134435746 4134435746 4134435746 4134435746 4134435746 3914425236 591416973 2571195527 4289245124 4293125612 4293125612 4293125612 4293125612 4293125612 4293125612 4293125612 4293125612 4293125612 4293125612 4289245124 2520929417 2655015551 4289114053 4291744479 4291744479 4291744479 4291744479 4291744479 4291744479 4291744479 4291744479 4291744479 4291744479 4289114053 2604684160 2654949242 4288456640 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4288456640 2604748668 2654817654 4287799485 4289443276 4289443276 4289443276 4289443276 4289443276 4289443276 4289443276 4289443276 4289443276 4289443276 4287799485 2604486007 2654686063 4287273914 4288457669 4288457669 4288457669 4288457669 4288457669 4288457669 4288457669 4288457669 4288457669 4288457669 4287273914 2604420207 2654816618 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 4284907433 2604484971 2654619492 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 2604353637 2654684509 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 4286092732 2604352863 2654487128 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 4286685382 2604221017 2603892560 4287146187 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287278031 4287146187 2553626706 1310531626 4232599666 4284512149 4284512149 4284512149 4284512149 4284512149 4284512149 4284512149 4284512149 4284512149 4284512149 4232599666 1276977451 50331648 1210064935 1646208047 1646208047 1646208047 1646208047 1646208047 1646208047 1646208047 1646208047 1646208047 1646208047 1210064935 50331648) 433260 offset: 0@0)! ! 433261 433262!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 12/8/2008 18:37'! 433263newRadioButtonForm 433264 "Answer the form for a normal radio button." 433265 433266 ^(Form 433267 extent: 14@14 433268 depth: 32 433269 fromArray: #( 16777215 16777215 16777215 198234320 2645865652 3568415153 4072521149 4055875519 3551637937 2578756788 164021958 16777215 16777215 16777215 16777215 16777215 1437906100 4038506166 4292598747 4293914607 4294111986 4294111986 4293914607 4292598747 4021728950 1303556786 16777215 16777215 16777215 1386916522 4257465283 4293388263 4293651435 4293651435 4293651435 4293651435 4293651435 4293651435 4293388263 4240556481 1219144362 16777215 195207842 4038177201 4293125091 4293256677 4293256677 4293256677 4293256677 4293256677 4293256677 4293256677 4293256677 4293059298 3987713967 144678815 2627640990 4291875024 4292993505 4292993505 4292993505 4292993505 4292993505 4292993505 4292993505 4292993505 4292993505 4292993505 4291743438 2459803037 3584139681 4292072403 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292861919 4292006610 3500056222 3970476200 4291809231 4292467161 4292532954 4292532954 4292532954 4292532954 4292532954 4292532954 4292532954 4292532954 4292467161 4291809231 3919947173 3919749794 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 4292203989 3869154974 3515846543 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 4292664540 3431697291 2289333364 4291480266 4293125091 4293125091 4293125091 4293125091 4293125091 4293125091 4293125091 4293125091 4293125091 4293125091 4291151301 2154918257 189154886 3817178501 4293256677 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293585642 4293059298 3766583681 189154886 16777215 960906822 4120221077 4293322470 4294111986 4294111986 4294111986 4294111986 4294111986 4294111986 4293256677 4103180689 927549769 16777215 16777215 16777215 910048830 3682039671 4290756543 4293256677 4294572537 4294506744 4293190884 4273847741 3648287860 893337407 16777215 16777215 16777215 16777215 16777215 169482778 1799570243 3042202708 3681710706 3664867697 3025359699 1799636036 169482778 16777215 16777215 16777215) 433270 offset: 0@0)! ! 433271 433272!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 12/8/2008 18:38'! 433273newRadioButtonSelectedForm 433274 "Answer the form for a selected radio button." 433275 433276 ^(Form 433277 extent: 14@14 433278 depth: 32 433279 fromArray: #( 16777215 16777215 16777215 195273727 2641329849 3563221416 4067918510 4051207088 3546444457 2574352313 160337634 16777215 16777215 16777215 16777215 16777215 1433764797 4033509543 4289442502 4292467941 4292928234 4292928234 4292467941 4289442502 4016797863 1299613120 16777215 16777215 16777215 1383498170 4252665514 4291152600 4291744478 4291744478 4291744478 4291744478 4291744478 4291744478 4291087064 4235822507 1216120505 16777215 192187321 4033181089 4290232016 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290560980 4290100687 3982914979 140541887 2623959968 4286746800 4289574859 4289574859 4289574859 4289574859 4289574859 4289574859 4289574859 4289574859 4289574859 4289574859 4286549679 2456319395 3579801242 4286353071 4288654533 4288654533 4288654533 4288654533 4288654533 4288654533 4288654533 4288654533 4288654533 4288654533 4286089901 3495980954 3965612183 4284709539 4286944951 4287011000 4287011000 4287011000 4287011000 4287011000 4287011000 4287011000 4287011000 4286813622 4284643746 3915280279 3915345555 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 4284973226 3864947858 3512362887 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 4285500082 3428345476 2286835828 4285433514 4286026683 4286026683 4286026683 4286026683 4286026683 4286026683 4286026683 4286026683 4286026683 4286026683 4285235879 2152552048 187582022 3813958010 4286421439 4286553283 4286553283 4286553283 4286553283 4286553283 4286553283 4286553283 4286553283 4286355645 3763494776 187582022 16777215 959790667 4116343939 4286685122 4287014603 4287014603 4287014603 4287014603 4287014603 4287014603 4286619329 4099500930 926039117 16777215 16777215 16777215 908735550 3679148137 4285630628 4286882500 4287541204 4287541204 4286816707 4268787875 3645527655 892024127 16777215 16777215 16777215 16777215 16777215 169482778 1798387264 3040494156 3679082084 3662239075 3023716940 1798452800 169482778 16777215 16777215 16777215) 433280 offset: 0@0)! ! 433281 433282!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 10/3/2008 13:22'! 433283newScrollbarThumbBottomForm 433284 "Answer the form for the bottom of a scrollbar thumb." 433285 433286 ^(Form 433287 extent: 13@7 433288 depth: 32 433289 fromArray: #( 4284182411 4287142063 4287931577 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4284577427 4282669690 4284182411 4286287012 4287931577 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4284182670 4282669690 2906411633 4284445326 4287536820 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4283261825 3023720303 2033601901 4284182411 4285037205 4287339698 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4283919242 4282801275 2503363949 1149473452 2755548019 4284050825 4284248204 4285958562 4286681770 4286484649 4286155685 4285037464 4283656069 4282998397 3023720559 1262704758 0 422725477 2083867754 2671004523 4283787654 4283656068 4283656325 4283392897 4283195776 3023786609 2688176497 926700403 73298833 0 0 0 1345735788 1999981163 2671004523 2671004523 2671004523 2167753578 1580616556 171134054 0 0) 433290 offset: 0@0)! ! 433291 433292!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 10/3/2008 13:22'! 433293newScrollbarThumbHorizontalMiddleForm 433294 "Answer the form for the middle of a horizontal scrollbar thumb." 433295 433296 ^(Form 433297 extent: 1@13 433298 depth: 32 433299 fromArray: #( 4284182411 4288326078 4287931577 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4284709013 4282669690) 433300 offset: 0@0)! ! 433301 433302!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 10/3/2008 13:22'! 433303newScrollbarThumbLeftForm 433304 "Answer the form for the left hand side of a scrollbar thumb." 433305 433306 ^(Form 433307 extent: 7@13 433308 depth: 32 433309 fromArray: #( 0 0 1149473452 2033601901 2906411633 4284182411 4284182411 0 422725477 2755548019 4284182411 4284445326 4286287012 4287142063 0 2083867754 4284050825 4285037205 4287536820 4287931577 4287931577 1345735788 2671004523 4284248204 4287339698 4287602613 4287602613 4287602613 1999981163 4283787654 4285958562 4287208113 4287208113 4287208113 4287208113 2671004523 4283656068 4286681770 4286879149 4286879149 4286879149 4286879149 2671004523 4283656325 4286484649 4286484649 4286484649 4286484649 4286484649 2671004523 4283392897 4286155685 4286155685 4286155685 4286155685 4286155685 2167753578 4283195776 4285037464 4285761185 4285761185 4285761185 4285761185 1580616556 3023786609 4283656069 4285432221 4285432221 4285432221 4285432221 171134054 2688176497 4282998397 4283919242 4285103257 4285103257 4285103257 0 926700403 3023720559 4282801275 4283261825 4284182670 4284577427 0 73298833 1262704758 2503363949 3023720303 4282669690 4282669690) 433310 offset: 0@0)! ! 433311 433312!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 10/3/2008 13:22'! 433313newScrollbarThumbRightForm 433314 "Answer the form for the right hand side of a scrollbar thumb." 433315 433316 ^(Form 433317 extent: 7@13 433318 depth: 32 433319 fromArray: #( 4284182411 4284182411 2587118699 1396330353 211462590 0 0 4287010734 4285629341 4284182411 4284182411 2033601901 0 0 4287931577 4287931577 4286682026 4284313740 4284050825 1261587049 0 4287602613 4287602613 4287602613 4286418855 4283919239 2587118699 422725477 4287208113 4287208113 4287208113 4287208113 4284971669 4283787654 1345735788 4286879149 4286879149 4286879149 4286879149 4285629597 4283656068 1832209003 4286484649 4286484649 4286484649 4286484649 4285695391 4283458947 1999981163 4286155685 4286155685 4286155685 4286155685 4285169048 4283392897 1916095595 4285761185 4285761185 4285761185 4285761185 4284379535 4283195776 1345735788 4285432221 4285432221 4285432221 4285037464 4283195775 2671004523 758270315 4285103257 4285103257 4284905878 4283327362 4282998397 1664502380 0 4284380048 4283853961 4282932861 4282801275 2419477869 171134054 0 4282669690 4282669690 2755021932 2436846708 322261099 0 0) 433320 offset: 0@0)! ! 433321 433322!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 10/3/2008 13:22'! 433323newScrollbarThumbTopForm 433324 "Answer the form for the top of a scrollbar thumb." 433325 433326 ^(Form 433327 extent: 13@7 433328 depth: 32 433329 fromArray: #( 0 0 0 422725477 1345735788 1832209003 1999981163 1916095595 1345735788 758270315 0 0 0 0 0 1261587049 2587118699 4283787654 4283656068 4283458947 4283392897 4283195776 2671004523 1664502380 171134054 0 211462590 2033601901 4284050825 4283919239 4284971669 4285629597 4285695391 4285169048 4284379535 4283195775 4282998397 2419477869 322261099 1396330353 4284182411 4284313740 4286418855 4287208113 4286879149 4286484649 4286155685 4285761185 4285037464 4283327362 4282801275 2436846708 2587118699 4284182411 4286682026 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4284905878 4282932861 2755021932 4284182411 4285629341 4287931577 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4283853961 4282669690 4284182411 4287010734 4287931577 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4284380048 4282669690) 433330 offset: 0@0)! ! 433331 433332!UIThemeWatery2 methodsFor: 'initialize-release' stamp: 'gvc 10/3/2008 13:22'! 433333newScrollbarThumbVerticalMiddleForm 433334 "Answer the form for the middle of a vertical scrollbar thumb." 433335 433336 ^(Form 433337 extent: 13@1 433338 depth: 32 433339 fromArray: #( 4284182411 4288326078 4287931577 4287602613 4287208113 4286879149 4286484649 4286155685 4285761185 4285432221 4285103257 4284709013 4282669690) 433340 offset: 0@0)! ! 433341 433342 433343!UIThemeWatery2 methodsFor: 'basic-colors' stamp: 'gvc 9/17/2009 13:58'! 433344taskbarButtonLabelColorFor: aButton 433345 "Answer the colour for the label of the given taskbar button." 433346 433347 ^aButton model 433348 ifNil: [super taskbarButtonLabelColorFor: aButton] 433349 ifNotNilDo: [:win | 433350 win isActive 433351 ifTrue: [self selectionColor darker] 433352 ifFalse: [super taskbarButtonLabelColorFor: aButton]]! ! 433353 433354"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 433355 433356UIThemeWatery2 class 433357 instanceVariableNames: ''! 433358 433359!UIThemeWatery2 class methodsFor: 'as yet unclassified' stamp: 'gvc 10/16/2008 16:23'! 433360newDefaultSettings 433361 "Answer a new original default settings." 433362 433363 ^super newDefaultSettings 433364 windowColor: (Color r: 170 g: 170 b: 170 range: 255); 433365 menuColor: (Color r: 200 g: 200 b: 200 range: 255); 433366 menuTitleColor: (Color r: 190 g: 190 b: 190 range: 255)! ! 433367 433368!UIThemeWatery2 class methodsFor: 'as yet unclassified' stamp: 'gvc 10/3/2008 11:25'! 433369themeName 433370 "Answer the friendly name of the theme." 433371 433372 ^'Watery 2'! ! 433373Object subclass: #URI 433374 instanceVariableNames: 'fragment scheme schemeSpecificPart' 433375 classVariableNames: 'ClientClasses' 433376 poolDictionaries: '' 433377 category: 'Network-URI'! 433378!URI commentStamp: 'mir 2/20/2002 15:17' prior: 0! 433379A Uniform Resource Identifier (URI) is a compact string of characters for identifying an abstract or physical resource. 433380This implementation is based on http://www.ietf.org/rfc/rfc2396.txt. 433381 433382! 433383 433384 433385!URI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:26'! 433386fragment 433387 ^fragment! ! 433388 433389!URI methodsFor: 'accessing' stamp: 'mir 6/10/2007 19:00'! 433390mimeType 433391 ^MIMEType forExtension: self extension! ! 433392 433393!URI methodsFor: 'accessing' stamp: 'mir 2/26/2002 19:17'! 433394resolveRelativeURI: relativeURI 433395 self shouldNotImplement! ! 433396 433397!URI methodsFor: 'accessing' stamp: 'mir 2/20/2002 16:53'! 433398scheme 433399 ^scheme! ! 433400 433401!URI methodsFor: 'accessing' stamp: 'JMM 2/16/2008 11:22'! 433402schemeIsFile 433403 self scheme ifNil: [^false]. 433404 ^self scheme asLowercase = 'file'! ! 433405 433406!URI methodsFor: 'accessing' stamp: 'JMM 2/16/2008 11:22'! 433407schemeIsHttp 433408 self scheme ifNil: [^false]. 433409 ^self scheme asLowercase = 'http'! ! 433410 433411 433412!URI methodsFor: 'content retrieval' stamp: 'mir 4/16/2007 18:56'! 433413retrieveContentsEncoding: stringEncoding 433414 ^self openStream: #read forceNew: false encoding: stringEncoding! ! 433415 433416 433417!URI methodsFor: 'converting' stamp: 'mir 3/6/2002 14:54'! 433418asText 433419 ^self asString asText! ! 433420 433421!URI methodsFor: 'converting' stamp: 'mir 2/26/2002 15:15'! 433422asURI 433423 ^self! ! 433424 433425!URI methodsFor: 'converting' stamp: 'JMM 8/2/2007 16:59'! 433426asURIForceEncoding 433427 ^self! ! 433428 433429!URI methodsFor: 'converting' stamp: 'tb 5/24/2006 22:04'! 433430asUrl 433431 433432 ^self asString asUrl! ! 433433 433434 433435!URI methodsFor: 'printing' stamp: 'mir 2/26/2002 14:56'! 433436printOn: stream 433437 self isAbsolute 433438 ifTrue: [ 433439 stream nextPutAll: self scheme. 433440 stream nextPut: $: ]. 433441 self printSchemeSpecificPartOn: stream. 433442 fragment 433443 ifNotNil: [ 433444 stream nextPut: $# . 433445 stream nextPutAll: self fragment] 433446! ! 433447 433448!URI methodsFor: 'printing' stamp: 'mir 2/26/2002 14:55'! 433449printSchemeSpecificPartOn: stream 433450 stream nextPutAll: self schemeSpecificPart! ! 433451 433452 433453!URI methodsFor: 'retrieval' stamp: 'mir 10/20/2003 16:31'! 433454contentStream 433455 ^self clientClass contentStreamForURI: self! ! 433456 433457!URI methodsFor: 'retrieval' stamp: 'JMM 7/20/2006 00:51'! 433458contentUTF8Stream 433459 ^self clientClass contentUTF8StreamForURI: self! ! 433460 433461!URI methodsFor: 'retrieval' stamp: 'JMM 7/20/2006 00:52'! 433462contentUTF8WriteableStream 433463 ^self clientClass contentUTF8WriteableStreamForURI: self! ! 433464 433465!URI methodsFor: 'retrieval' stamp: 'mir 3/22/2005 22:44'! 433466retrieveMIMEDocument 433467 ^self clientClass retrieveMIMEDocument: self! ! 433468 433469 433470!URI methodsFor: 'stream creation' stamp: 'mir 4/16/2007 21:36'! 433471openStream: readWrite 433472 ^self openStream: readWrite forceNew: false! ! 433473 433474!URI methodsFor: 'stream creation' stamp: 'mir 4/16/2007 18:41'! 433475openStream: readWrite forceNew: forceNew 433476 ^self openStream: readWrite forceNew: forceNew encoding: nil! ! 433477 433478!URI methodsFor: 'stream creation' stamp: 'mir 6/10/2007 18:38'! 433479openStream: readWrite forceNew: forceNew encoding: stringEncoding 433480 ^self directory openStream: self name mode: readWrite forceNew: forceNew encoding: stringEncoding! ! 433481 433482!URI methodsFor: 'stream creation' stamp: 'mir 4/16/2007 15:28'! 433483readStream 433484 ^self openStream: #read! ! 433485 433486!URI methodsFor: 'stream creation' stamp: 'mir 4/16/2007 15:29'! 433487readWriteStream 433488 ^self openStream: #readWrite! ! 433489 433490!URI methodsFor: 'stream creation' stamp: 'mir 4/16/2007 15:29'! 433491writeStream 433492 ^self openStream: #write! ! 433493 433494 433495!URI methodsFor: 'testing' stamp: 'bf 1/26/2004 14:40'! 433496hash 433497 ^ self asString hash! ! 433498 433499!URI methodsFor: 'testing' stamp: 'mir 2/20/2002 16:55'! 433500isAbsolute 433501 ^self scheme notNil! ! 433502 433503!URI methodsFor: 'testing' stamp: 'mir 2/20/2002 16:55'! 433504isOpaque 433505 ^false! ! 433506 433507!URI methodsFor: 'testing' stamp: 'mir 2/20/2002 16:55'! 433508isRelative 433509 ^self isAbsolute not! ! 433510 433511!URI methodsFor: 'testing' stamp: 'bf 1/26/2004 14:40'! 433512= otherURI 433513 ^ self class = otherURI class 433514 and: [self asString = otherURI asString]! ! 433515 433516!URI methodsFor: 'testing' stamp: 'JMM 7/13/2006 10:55'! 433517isURI 433518 ^true! ! 433519 433520 433521!URI methodsFor: 'private' stamp: 'mir 2/20/2002 17:18'! 433522absoluteFromString: remainder scheme: schemeName 433523 scheme := schemeName. 433524 self extractSchemeSpecificPartAndFragment: remainder! ! 433525 433526!URI methodsFor: 'private' stamp: 'mir 3/22/2005 23:02'! 433527clientClass 433528 ^Smalltalk at: (ClientClasses at: self scheme ifAbsent: [ClientClasses at: 'file'])! ! 433529 433530!URI methodsFor: 'private' stamp: 'mir 2/27/2002 14:18'! 433531extractSchemeSpecificPartAndFragment: remainder 433532 | fragmentIndex | 433533 fragmentIndex := remainder indexOf: $# . 433534 fragmentIndex > 0 433535 ifTrue: [ 433536 schemeSpecificPart := remainder copyFrom: 1 to: fragmentIndex-1. 433537 fragment := remainder copyFrom: fragmentIndex+1 to: remainder size] 433538 ifFalse: [schemeSpecificPart := remainder]! ! 433539 433540!URI methodsFor: 'private' stamp: 'mir 2/25/2002 16:10'! 433541schemeSpecificPart 433542 ^schemeSpecificPart! ! 433543 433544"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 433545 433546URI class 433547 instanceVariableNames: ''! 433548 433549!URI class methodsFor: 'initialization' stamp: 'mir 3/1/2002 15:18'! 433550initialize 433551 "URI initialize" 433552 433553 ClientClasses := Dictionary new. 433554 ClientClasses 433555 at: 'http' put: #HTTPClient; 433556 at: 'ftp' put: #FTPClient; 433557 at: 'file' put: #FileDirectory 433558! ! 433559 433560 433561!URI class methodsFor: 'instance creation' stamp: 'mir 4/15/2007 21:22'! 433562fromString: aString 433563 | parseString scheme | 433564 parseString := aString withBlanksTrimmed. 433565 scheme := self extractSchemeFrom: parseString. 433566 ^scheme 433567 ifNil: [aString size > 1 433568 ifTrue: [(aString last = $/ 433569 ifTrue: [DirectoryURI] 433570 ifFalse: [HierarchicalURI]) new relativeFromString: aString] 433571 ifFalse: [HierarchicalURI new relativeFromString: aString]] 433572 ifNotNil: [self absoluteFromString: aString scheme: scheme] 433573! ! 433574 433575!URI class methodsFor: 'instance creation' stamp: 'JMM 8/2/2007 12:10'! 433576fromStringForceEncoding: aString 433577 ^aString asURIForceEncoding! ! 433578 433579 433580!URI class methodsFor: 'private' stamp: 'mir 4/15/2007 21:26'! 433581absoluteFromString: aString scheme: scheme 433582 | remainder | 433583 remainder := aString copyFrom: scheme size+2 to: aString size. 433584 remainder isEmpty 433585 ifTrue: [(IllegalURIException new uriString: aString) signal: 'Invalid absolute URI']. 433586 ^(remainder first = $/ 433587 ifTrue: [(aString last = $/ 433588 ifTrue: [DirectoryURI] 433589 ifFalse: [HierarchicalURI])] 433590 ifFalse: [OpaqueURI]) new absoluteFromString: remainder scheme: scheme! ! 433591 433592!URI class methodsFor: 'private' stamp: 'mir 2/20/2002 17:23'! 433593extractSchemeFrom: aString 433594 | colonIndex slashIndex | 433595 colonIndex := aString indexOf: $: . 433596 ^colonIndex > 0 433597 ifTrue: [ 433598 slashIndex := aString indexOf: $/ . 433599 (slashIndex == 0 433600 or: [colonIndex < slashIndex]) 433601 ifTrue: [aString copyFrom: 1 to: colonIndex-1] 433602 ifFalse: [nil]] 433603 ifFalse: [nil]! ! 433604Object subclass: #URIAuthority 433605 instanceVariableNames: 'host port userInfo' 433606 classVariableNames: '' 433607 poolDictionaries: '' 433608 category: 'Network-URI'! 433609 433610!URIAuthority methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:27'! 433611host 433612 ^host! ! 433613 433614!URIAuthority methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:27'! 433615port 433616 ^port! ! 433617 433618!URIAuthority methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:28'! 433619userInfo 433620 ^userInfo! ! 433621 433622 433623!URIAuthority methodsFor: 'printing' stamp: 'mir 2/26/2002 14:52'! 433624printOn: stream 433625 userInfo 433626 ifNotNil: [ 433627 stream nextPut: $@ . 433628 stream nextPutAll: userInfo]. 433629 stream nextPutAll: host. 433630 port 433631 ifNotNil: [ 433632 stream nextPut: $: . 433633 port printOn: stream] ! ! 433634 433635 433636!URIAuthority methodsFor: 'private' stamp: 'mir 2/25/2002 19:04'! 433637fromString: authorityString 433638 | userInfoEnd remainder hostEnd | 433639 userInfoEnd := authorityString indexOf: $@. 433640 remainder := userInfoEnd > 0 433641 ifTrue: [ 433642 userInfo := authorityString copyFrom: 1 to: userInfoEnd-1. 433643 authorityString copyFrom: userInfoEnd+1 to: authorityString size] 433644 ifFalse: [authorityString]. 433645 hostEnd := remainder indexOf: $: . 433646 hostEnd > 0 433647 ifTrue: [ 433648 host := remainder copyFrom: 1 to: hostEnd-1. 433649 port := (remainder copyFrom: hostEnd+1 to: remainder size) asNumber] 433650 ifFalse: [host := remainder]! ! 433651 433652"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 433653 433654URIAuthority class 433655 instanceVariableNames: ''! 433656 433657!URIAuthority class methodsFor: 'instance creation'! 433658fromString: authorityString 433659 ^self new fromString: authorityString! ! 433660TextConverter subclass: #UTF16TextConverter 433661 instanceVariableNames: 'useLittleEndian useByteOrderMark byteOrderMarkDone' 433662 classVariableNames: '' 433663 poolDictionaries: '' 433664 category: 'Multilingual-TextConversion'! 433665!UTF16TextConverter commentStamp: '<historical>' prior: 0! 433666Text converter for UTF-16. It supports the endianness and byte order mark.! 433667 433668 433669!UTF16TextConverter methodsFor: 'accessing' stamp: 'yo 1/12/2004 17:00'! 433670useByteOrderMark 433671 433672 ^ useByteOrderMark ifNil: [^ false]. 433673! ! 433674 433675!UTF16TextConverter methodsFor: 'accessing' stamp: 'yo 1/12/2004 13:54'! 433676useByteOrderMark: aBoolean 433677 433678 useByteOrderMark := aBoolean. 433679! ! 433680 433681!UTF16TextConverter methodsFor: 'accessing' stamp: 'yo 1/12/2004 17:00'! 433682useLittleEndian 433683 433684 ^ useLittleEndian ifNil: [false]. 433685! ! 433686 433687!UTF16TextConverter methodsFor: 'accessing' stamp: 'yo 1/12/2004 14:02'! 433688useLittleEndian: aBoolean 433689 433690 useLittleEndian := aBoolean. 433691! ! 433692 433693 433694!UTF16TextConverter methodsFor: 'conversion' stamp: 'yo 1/12/2004 17:06'! 433695nextFromStream: aStream 433696 433697 | character1 character2 readBOM charValue | 433698 aStream isBinary ifTrue: [^ aStream basicNext]. 433699 character1 := aStream basicNext. 433700 character1 isNil ifTrue: [^ nil]. 433701 character2 := aStream basicNext. 433702 character2 isNil ifTrue: [^ nil]. 433703 433704 readBOM := false. 433705 (character1 asciiValue = 16rFF and: [character2 asciiValue = 16rFE]) ifTrue: [ 433706 self useByteOrderMark: true. 433707 self useLittleEndian: true. 433708 readBOM := true. 433709 ]. 433710 (character1 asciiValue = 16rFE and: [character2 asciiValue = 16rFF]) ifTrue: [ 433711 self useByteOrderMark: true. 433712 self useLittleEndian: false. 433713 readBOM := true. 433714 ]. 433715 433716 readBOM ifTrue: [ 433717 character1 := aStream basicNext. 433718 character1 isNil ifTrue: [^ nil]. 433719 character2 := aStream basicNext. 433720 character2 isNil ifTrue: [^ nil]. 433721 ]. 433722 433723 self useLittleEndian ifTrue: [ 433724 charValue := character2 charCode << 8 + character1 charCode. 433725 ] ifFalse: [ 433726 charValue := character1 charCode << 8 + character2 charCode. 433727 ]. 433728 433729 ^ self charFromStream: aStream withFirst: charValue. 433730! ! 433731 433732!UTF16TextConverter methodsFor: 'conversion' stamp: 'yo 1/13/2004 12:56'! 433733nextPut: aCharacter toStream: aStream 433734 433735 | v low high | 433736 (self useByteOrderMark and: [byteOrderMarkDone isNil]) ifTrue: [ 433737 self next16BitValue: (16rFEFF) toStream: aStream. 433738 byteOrderMarkDone := true. 433739 ]. 433740 433741 v := aCharacter charCode. 433742 v > 16rFFFF ifFalse: [ 433743 self next16BitValue: v toStream: aStream. 433744 ^ self. 433745 ] ifTrue: [ 433746 v := v - 16r10000. 433747 low := (v \\ 16r400) + 16rDC00. 433748 high := (v // 16r400) + 16rD800. 433749 self next16BitValue: high toStream: aStream. 433750 self next16BitValue: low toStream: aStream. 433751 ]! ! 433752 433753 433754!UTF16TextConverter methodsFor: 'private' stamp: 'yo 1/12/2004 17:07'! 433755charFromStream: aStream withFirst: firstValue 433756 433757 | character1 character2 tmp n secondValue | 433758 (16rD800 <= firstValue and: [firstValue <= 16rDBFF]) ifTrue: [ 433759 character1 := aStream basicNext. 433760 character1 isNil ifTrue: [^ nil]. 433761 character2 := aStream basicNext. 433762 character2 isNil ifTrue: [^ nil]. 433763 self useLittleEndian ifTrue: [ 433764 tmp := character1. 433765 character1 := character2. 433766 character2 := tmp 433767 ]. 433768 secondValue := (character1 charCode << 8) + (character2 charCode). 433769 n := (firstValue - 16rD800) * 16r400 + (secondValue - 16rDC00) + 16r10000. 433770 ^ Unicode value: n 433771 ]. 433772 433773 ^ Unicode value: firstValue 433774! ! 433775 433776!UTF16TextConverter methodsFor: 'private' stamp: 'yo 1/13/2004 12:59'! 433777next16BitValue: value toStream: aStream 433778 433779 | v1 v2 | 433780 v1 := (value >> 8) bitAnd: 16rFF. 433781 v2 := value bitAnd: 16rFF. 433782 433783 self useLittleEndian ifTrue: [ 433784 aStream basicNextPut: (Character value: v2). 433785 aStream basicNextPut: (Character value: v1). 433786 ] ifFalse: [ 433787 aStream basicNextPut: (Character value: v1). 433788 aStream basicNextPut: (Character value: v2). 433789 ]. 433790! ! 433791 433792"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 433793 433794UTF16TextConverter class 433795 instanceVariableNames: ''! 433796 433797!UTF16TextConverter class methodsFor: 'utilities' stamp: 'yo 2/10/2004 05:23'! 433798encodingNames 433799 433800 ^ #('utf-16' 'utf16' 'utf-16-le' 'utf-16-be') copy. 433801! ! 433802UTF8TextConverter subclass: #UTF8DecomposedTextConverter 433803 instanceVariableNames: 'combinedChar' 433804 classVariableNames: '' 433805 poolDictionaries: '' 433806 category: 'Multilingual-TextConversion'! 433807!UTF8DecomposedTextConverter commentStamp: 'michael.rueger 3/2/2009 13:51' prior: 0! 433808An UTF8DecomposedTextConverter converts from decomposed UTF8 using the UnicodeCompositionStream. 433809 433810Instance Variables 433811! 433812 433813 433814!UTF8DecomposedTextConverter methodsFor: 'conversion' stamp: 'michael.rueger 3/2/2009 14:12'! 433815nextFromStream: aStream 433816 433817 | char resultChar | 433818 char := super nextFromStream: aStream. 433819 (CombinedChar isCompositionCharacter: char charCode) 433820 ifFalse: [^char]. 433821 combinedChar 433822 ifNil: [ 433823 combinedChar := CombinedChar new. 433824 combinedChar simpleAdd: char] 433825 ifNotNil: [ 433826 [combinedChar simpleAdd: char] 433827 whileFalse: [char := super nextFromStream: aStream]. 433828 resultChar := combinedChar combined. 433829 combinedChar := CombinedChar new. 433830 combinedChar simpleAdd: char. 433831 ^resultChar] 433832! ! 433833 433834!UTF8DecomposedTextConverter methodsFor: 'conversion' stamp: 'michael.rueger 3/2/2009 14:13'! 433835nextPut: aCharacter toStream: aStream 433836 "we don't decompose for now" 433837 super nextPut: aCharacter toStream: aStream ! ! 433838 433839"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 433840 433841UTF8DecomposedTextConverter class 433842 instanceVariableNames: ''! 433843 433844!UTF8DecomposedTextConverter class methodsFor: 'utilities' stamp: 'michael.rueger 3/31/2009 16:38'! 433845encodingNames 433846 433847 ^Array new 433848! ! 433849TextConverter subclass: #UTF8TextConverter 433850 instanceVariableNames: '' 433851 classVariableNames: '' 433852 poolDictionaries: '' 433853 category: 'Multilingual-TextConversion'! 433854!UTF8TextConverter commentStamp: '<historical>' prior: 0! 433855Text converter for UTF-8. Since the BOM is used to distinguish the MacRoman code and UTF-8 code, BOM is written for UTF-8 by #writeBOMOn: which is called by client.! 433856 433857 433858!UTF8TextConverter methodsFor: 'conversion' stamp: 'ar 4/6/2006 10:15'! 433859errorMalformedInput 433860 ^self error: 'Invalid utf8 input detected'! ! 433861 433862!UTF8TextConverter methodsFor: 'conversion' stamp: 'michael.rueger 3/2/2009 13:50'! 433863nextFromStream: aStream 433864 433865 | character1 value1 character2 value2 unicode character3 value3 character4 value4 | 433866 aStream isBinary ifTrue: [^ aStream basicNext]. 433867 character1 := aStream basicNext. 433868 character1 isNil ifTrue: [^ nil]. 433869 value1 := character1 asciiValue. 433870 value1 <= 127 ifTrue: [ 433871 "1-byte character" 433872 ^ character1 433873 ]. 433874 433875 "at least 2-byte character" 433876 character2 := aStream basicNext. 433877 character2 = nil ifTrue: [^self errorMalformedInput]. 433878 value2 := character2 asciiValue. 433879 433880 (value1 bitAnd: 16rE0) = 192 ifTrue: [ 433881 ^ Unicode value: ((value1 bitAnd: 31) bitShift: 6) + (value2 bitAnd: 63). 433882 ]. 433883 433884 "at least 3-byte character" 433885 character3 := aStream basicNext. 433886 character3 = nil ifTrue: [^self errorMalformedInput]. 433887 value3 := character3 asciiValue. 433888 (value1 bitAnd: 16rF0) = 224 ifTrue: [ 433889 unicode := ((value1 bitAnd: 15) bitShift: 12) + ((value2 bitAnd: 63) bitShift: 6) 433890 + (value3 bitAnd: 63). 433891 ]. 433892 433893 (value1 bitAnd: 16rF8) = 240 ifTrue: [ 433894 "4-byte character" 433895 character4 := aStream basicNext. 433896 character4 = nil ifTrue: [^self errorMalformedInput]. 433897 value4 := character4 asciiValue. 433898 unicode := ((value1 bitAnd: 16r7) bitShift: 18) + 433899 ((value2 bitAnd: 63) bitShift: 12) + 433900 ((value3 bitAnd: 63) bitShift: 6) + 433901 (value4 bitAnd: 63). 433902 ]. 433903 433904 unicode isNil ifTrue: [^self errorMalformedInput]. 433905 unicode > 16r10FFFD ifTrue: [^self errorMalformedInput]. 433906 433907 unicode = 16rFEFF ifTrue: [^ self nextFromStream: aStream]. 433908 ^ Unicode value: unicode. 433909! ! 433910 433911!UTF8TextConverter methodsFor: 'conversion' stamp: 'ar 4/9/2005 22:29'! 433912nextPut: aCharacter toStream: aStream 433913 | leadingChar nBytes mask shift ucs2code | 433914 aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream]. 433915 leadingChar := aCharacter leadingChar. 433916 (leadingChar = 0 and: [aCharacter asciiValue < 128]) ifTrue: [ 433917 aStream basicNextPut: aCharacter. 433918 ^ aStream. 433919 ]. 433920 433921 "leadingChar > 3 ifTrue: [^ aStream]." 433922 433923 ucs2code := aCharacter asUnicode. 433924 ucs2code ifNil: [^ aStream]. 433925 433926 nBytes := ucs2code highBit + 3 // 5. 433927 mask := #(128 192 224 240 248 252 254 255) at: nBytes. 433928 shift := nBytes - 1 * -6. 433929 aStream basicNextPut: (Character value: (ucs2code bitShift: shift) + mask). 433930 2 to: nBytes do: [:i | 433931 shift := shift + 6. 433932 aStream basicNextPut: (Character value: ((ucs2code bitShift: shift) bitAnd: 63) + 128). 433933 ]. 433934 433935 ^ aStream. 433936! ! 433937 433938 433939!UTF8TextConverter methodsFor: 'friend' stamp: 'yo 11/8/2002 16:17'! 433940leadingChar 433941 433942 ^ self shouldNotImplement 433943! ! 433944 433945"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 433946 433947UTF8TextConverter class 433948 instanceVariableNames: ''! 433949 433950!UTF8TextConverter class methodsFor: 'accessing' stamp: 'tak 1/12/2005 13:22'! 433951writeBOMOn: aStream 433952 "Write Byte Order Mark" 433953 aStream nextPut: 16rEF. 433954 aStream nextPut: 16rBB. 433955 aStream nextPut: 16rBF. 433956! ! 433957 433958 433959!UTF8TextConverter class methodsFor: 'utilities' stamp: 'yo 12/19/2003 22:01'! 433960encodingNames 433961 433962 ^ #('utf-8' 'utf8') copy. 433963! ! 433964ByteArray variableByteSubclass: #UUID 433965 instanceVariableNames: '' 433966 classVariableNames: '' 433967 poolDictionaries: '' 433968 category: 'Network-UUID'! 433969!UUID commentStamp: '<historical>' prior: 0! 433970A class to generate UUID 433971by John M McIntosh johnmci@smalltalkconsulting.com 433972 433973See http://www.webdav.org/specs/draft-leach-uuids-guids-01.txt 433974 433975If a plugin does not exist then we generate a UUID version 4 type GUUID! 433976 433977 433978!UUID methodsFor: 'comparing' stamp: 'JMM 11/22/2001 17:36'! 433979< aMagnitude 433980 "Answer whether the receiver is less than the argument." 433981 433982 1 to: self size do: [:i | 433983 (self at: i) < (aMagnitude at: i) ifTrue: [^true]]. 433984 ^false.! ! 433985 433986!UUID methodsFor: 'comparing' stamp: 'JMM 11/22/2001 17:30'! 433987<= aMagnitude 433988 "Answer whether the receiver is less than or equal to the argument." 433989 433990 ^(self > aMagnitude) not! ! 433991 433992!UUID methodsFor: 'comparing' stamp: 'JMM 11/22/2001 17:30'! 433993> aMagnitude 433994 "Answer whether the receiver is greater than the argument." 433995 433996 ^aMagnitude < self! ! 433997 433998!UUID methodsFor: 'comparing' stamp: 'JMM 11/22/2001 17:30'! 433999>= aMagnitude 434000 "Answer whether the receiver is greater than or equal to the argument." 434001 434002 ^(self < aMagnitude) not! ! 434003 434004 434005!UUID methodsFor: 'converting' stamp: 'PeterHugossonMiller 9/3/2009 11:46'! 434006asString 434007 | result data | 434008 data := String new: 36. 434009 result := data writeStream. 434010 1 to: 4 do:[:i| self printHexAt: i to: result]. 434011 result nextPut: $-. 434012 5 to: 6 do:[:i| self printHexAt: i to: result]. 434013 result nextPut: $-. 434014 7 to: 8 do:[:i| self printHexAt: i to: result]. 434015 result nextPut: $-. 434016 9 to: 10 do:[:i| self printHexAt: i to: result]. 434017 result nextPut: $-. 434018 11 to: 16 do:[:i| self printHexAt: i to: result]. 434019 ^data. 434020 ! ! 434021 434022!UUID methodsFor: 'converting' stamp: 'gk 4/18/2006 22:15'! 434023asString36 434024 "Encode the UUID as a base 36 string using 0-9 and lowercase a-z. 434025 This is the shortest representation still being able to work as 434026 filenames etc since it does not depend on case nor characters 434027 that might cause problems, and it fits into short filenames like on 434028 the old MacOS HFS filesystem. The check for 36r is to make this code 434029 work in versions before Squeak 3.8." 434030 434031 | num candidate | 434032 num := 0. 434033 1 to: self size do: [:i | num := num + ((256 raisedTo: i - 1) * (self at: i))]. 434034 candidate := num printStringBase: 36. 434035 ^((candidate beginsWith: '36r') 434036 ifTrue: [candidate copyFrom: 4 to: candidate size] 434037 ifFalse: [candidate]) asLowercase! ! 434038 434039!UUID methodsFor: 'converting' stamp: 'damiencassou 5/30/2008 15:52'! 434040asUUID: aString 434041 | stream token byte | 434042 stream := (aString 434043 copyReplaceAll: '-' 434044 with: '') asUppercase readStream. 434045 1 434046 to: stream size / 2 434047 do: 434048 [ :i | 434049 token := stream next: 2. 434050 byte := Integer 434051 readFrom: token readStream 434052 base: 16. 434053 self 434054 at: i 434055 put: byte ]. 434056 ^ self! ! 434057 434058!UUID methodsFor: 'converting' stamp: 'PeterHugossonMiller 9/3/2009 11:46'! 434059createStringStartingAt: index for: bytes 434060 434061 | results candidate data | 434062 data := String new: bytes*2. 434063 results := data writeStream. 434064 index to: index+bytes -1 do: 434065 [:i | 434066 candidate := ((self at: i) printStringBase: 16) last: 2. 434067 candidate first = $r ifTrue: [candidate := String with: $0 with: candidate last]. 434068 results nextPutAll: candidate]. 434069 ^data asLowercase! ! 434070 434071!UUID methodsFor: 'converting' stamp: 'ar 2/8/2004 12:16'! 434072printHexAt: index to: aStream 434073 | map v | 434074 map := '0123456789abcdef'. 434075 v := self at: index. 434076 aStream nextPut: (map at: (v bitShift: -4) + 1). 434077 aStream nextPut: (map at: (v bitAnd: 15) + 1). 434078! ! 434079 434080 434081!UUID methodsFor: 'initalize-release' stamp: 'alain.plantec 5/28/2009 11:15'! 434082initialize 434083 super initialize. 434084 self primMakeUUID.! ! 434085 434086 434087!UUID methodsFor: 'printing' stamp: 'JMM 10/9/2001 14:46'! 434088printOn: aStream 434089 aStream nextPutAll: 'an UUID('. 434090 self asString printOn: aStream. 434091 aStream nextPutAll: ')'! ! 434092 434093!UUID methodsFor: 'printing' stamp: 'ar 2/8/2004 12:16'! 434094printString 434095 ^self asString! ! 434096 434097 434098!UUID methodsFor: 'system primitives' stamp: 'ar 2/3/2002 19:42'! 434099primMakeUUID 434100 <primitive: 'primitiveMakeUUID' module: 'UUIDPlugin'> 434101 UUIDGenerator default generateBytes: self forVersion: 4.! ! 434102 434103 434104!UUID methodsFor: 'testing' stamp: 'JMM 10/9/2001 14:17'! 434105isNilUUID 434106 1 to: self size do: [:i | (self at: i) ~= 0 ifTrue: [^false]]. 434107 ^true.! ! 434108 434109"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 434110 434111UUID class 434112 instanceVariableNames: ''! 434113 434114!UUID class methodsFor: 'instance creation' stamp: 'dvf 9/10/2004 23:11'! 434115fromString36: aString 434116 "Decode the UUID from a base 36 string using 0-9 and lowercase a-z. 434117 This is the shortest representation still being able to work as 434118 filenames etc since it does not depend on case nor characters 434119 that might cause problems." 434120 434121 | object num | 434122 object := self nilUUID. 434123 num := Integer readFrom: aString asUppercase readStream base: 36. 434124 16 to: 1 by: -1 do: [:i | 434125 num size < i 434126 ifTrue: [object at: i put: 0] 434127 ifFalse: [object at: i put: (num digitAt: i)]]. 434128 ^object! ! 434129 434130!UUID class methodsFor: 'instance creation' stamp: 'dvf 9/10/2004 23:10'! 434131fromString: aString 434132 | object | 434133 aString size ~= 36 ifTrue: [Error signal]. 434134 object := self nilUUID. 434135 object asUUID: aString. 434136 ^object! ! 434137 434138!UUID class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:49'! 434139new 434140 ^(self new: 16)! ! 434141 434142!UUID class methodsFor: 'instance creation' stamp: 'nk 6/28/2004 16:10'! 434143nilUUID 434144 "Must call basicNew: here because I have a non-trivial initialize method." 434145 434146 ^self basicNew: 16! ! 434147Object subclass: #UUIDGenerator 434148 instanceVariableNames: 'timeLow timeMid timeHiAndVersion clockSeqHiAndReserved clockSeqLow node randomCounter randomGenerator semaphoreForGenerator' 434149 classVariableNames: 'Default' 434150 poolDictionaries: '' 434151 category: 'Network-UUID'! 434152!UUIDGenerator commentStamp: '<historical>' prior: 0! 434153This class generates a pseudo-random UUID 434154by John M McIntosh johnmci@smalltalkconsulting.com 434155 434156See http://www.webdav.org/specs/draft-leach-uuids-guids-01.txt! 434157 434158 434159!UUIDGenerator methodsFor: 'accessors and mutators' stamp: 'JMM 11/21/2001 14:28'! 434160randomCounter 434161 ^randomCounter! ! 434162 434163!UUIDGenerator methodsFor: 'accessors and mutators' stamp: 'JMM 11/21/2001 14:29'! 434164randomCounter: aNumber 434165 randomCounter := aNumber 434166! ! 434167 434168!UUIDGenerator methodsFor: 'accessors and mutators' stamp: 'JMM 11/21/2001 14:27'! 434169randomGenerator 434170 ^randomGenerator 434171! ! 434172 434173!UUIDGenerator methodsFor: 'accessors and mutators' stamp: 'JMM 11/21/2001 14:27'! 434174randomGenerator: aGenerator 434175 randomGenerator := aGenerator 434176! ! 434177 434178!UUIDGenerator methodsFor: 'accessors and mutators' stamp: 'JMM 11/21/2001 14:29'! 434179semaphoreForGenerator 434180 ^semaphoreForGenerator! ! 434181 434182!UUIDGenerator methodsFor: 'accessors and mutators' stamp: 'JMM 11/21/2001 14:29'! 434183semaphoreForGenerator: aSema 434184 semaphoreForGenerator := aSema 434185! ! 434186 434187 434188!UUIDGenerator methodsFor: 'generator' stamp: 'JMM 11/22/2001 13:51'! 434189generateOneOrZero 434190 | result | 434191 self semaphoreForGenerator 434192 critical: [| value | 434193 value := self randomGenerator next. 434194 self randomCounter: self randomCounter + 1. 434195 self randomCounter > 100000 434196 ifTrue: [self setupRandom]. 434197 result := value < 0.5 434198 ifTrue: [0] 434199 ifFalse: [1]]. 434200 ^ result! ! 434201 434202!UUIDGenerator methodsFor: 'generator' stamp: 'JMM 11/21/2001 15:12'! 434203generateRandomBitsOfLength: aNumberOfBits 434204| target | 434205 target := 0. 434206 aNumberOfBits isZero ifTrue: [^target]. 434207 target := self generateOneOrZero. 434208 (aNumberOfBits - 1) timesRepeat: 434209 [target := (target bitShift: 1) bitOr: self generateOneOrZero]. 434210 ^target! ! 434211 434212 434213!UUIDGenerator methodsFor: 'instance creation' stamp: 'JMM 11/22/2001 13:45'! 434214generateBytes: aPlaceHolder forVersion: aVersion 434215 aVersion = 4 ifTrue: [self generateFieldsVersion4] 434216 ifFalse: [self error: 'Unsupported version']. 434217 self placeFields: aPlaceHolder.! ! 434218 434219!UUIDGenerator methodsFor: 'instance creation' stamp: 'JMM 11/22/2001 23:13'! 434220generateFieldsVersion4 434221 434222 timeLow := self generateRandomBitsOfLength: 32. 434223 timeMid := self generateRandomBitsOfLength: 16. 434224 timeHiAndVersion := 16r4000 bitOr: (self generateRandomBitsOfLength: 12). 434225 clockSeqHiAndReserved := 16r80 bitOr: (self generateRandomBitsOfLength: 6). 434226 clockSeqLow := self generateRandomBitsOfLength: 8. 434227 node := self generateRandomBitsOfLength: 48. 434228 ! ! 434229 434230!UUIDGenerator methodsFor: 'instance creation' stamp: 'alain.plantec 5/28/2009 11:15'! 434231initialize 434232 super initialize. 434233 self setupRandom. 434234 semaphoreForGenerator := Semaphore forMutualExclusion. 434235 ! ! 434236 434237!UUIDGenerator methodsFor: 'instance creation' stamp: 'JMM 11/22/2001 23:12'! 434238placeFields: aByteArray 434239 434240 aByteArray at: 1 put: ((timeLow bitShift: -24) bitAnd: 16rFF). 434241 aByteArray at: 2 put: ((timeLow bitShift: -16) bitAnd: 16rFF). 434242 aByteArray at: 3 put: ((timeLow bitShift: -8) bitAnd: 16rFF). 434243 aByteArray at: 4 put: (timeLow bitAnd: 16rFF). 434244 aByteArray at: 5 put: ((timeMid bitShift: -8) bitAnd: 16rFF). 434245 aByteArray at: 6 put: (timeMid bitAnd: 16rFF). 434246 aByteArray at: 7 put: ((timeHiAndVersion bitShift: -8) bitAnd: 16rFF). 434247 aByteArray at: 8 put: (timeHiAndVersion bitAnd: 16rFF). 434248 aByteArray at: 9 put: clockSeqHiAndReserved. 434249 aByteArray at: 10 put: clockSeqLow. 434250 0 to: 5 do: [:i | 434251 aByteArray at: 11 + i put: ((node bitShift: (-8*i)) bitAnd: 16rFF)] 434252! ! 434253 434254!UUIDGenerator methodsFor: 'instance creation' stamp: 'CdG 11/19/2002 21:30'! 434255setupRandom 434256 randomCounter := 0. 434257 randomGenerator := Random seed: self makeSeed.! ! 434258 434259 434260!UUIDGenerator methodsFor: 'random seed' stamp: 'dew 2/8/2003 00:28'! 434261makeSeed 434262 "Try various methods of getting good seeds" 434263 | seed | 434264 seed := self makeUnixSeed. 434265 seed ifNotNil: [^seed]. 434266 434267 "not sure if this is reliably random... commented out for now. -dew" 434268 "seed := self makeSeedFromSound. 434269 seed ifNotNil: [^seed]." 434270 434271 "default" 434272 [seed := (Time millisecondClockValue bitAnd: 16r3FFFFFFF) bitXor: self hash. 434273 seed := seed bitXor: (Time totalSeconds bitAnd: 16r3FFFFFFF). 434274 seed = 0] whileTrue: ["Try again if ever get a seed = 0"]. 434275 434276 ^seed 434277! ! 434278 434279!UUIDGenerator methodsFor: 'random seed' stamp: 'gk 2/23/2004 21:09'! 434280makeSeedFromSound 434281 | answer | 434282 [answer := SoundService default randomBitsFromSoundInput: 32 434283 ] ifError: [answer := nil]. 434284 ^answer! ! 434285 434286!UUIDGenerator methodsFor: 'random seed' stamp: 'nk 2/22/2005 13:54'! 434287makeUnixSeed 434288 | strm answer | 434289 [strm := (FileStream readOnlyFileNamed: '/dev/urandom') binary. 434290 strm converter: Latin1TextConverter new. 434291 answer := Integer 434292 byte1: strm next 434293 byte2: strm next 434294 byte3: strm next 434295 byte4: strm next. 434296 strm close. 434297 ] on: FileStreamException do: [answer := nil]. 434298 ^answer! ! 434299 434300"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 434301 434302UUIDGenerator class 434303 instanceVariableNames: ''! 434304 434305!UUIDGenerator class methodsFor: 'initialization' stamp: 'CdG 11/19/2002 21:06'! 434306initialize 434307 Smalltalk addToStartUpList: self after: nil.! ! 434308 434309!UUIDGenerator class methodsFor: 'initialization' stamp: 'CdG 11/19/2002 21:07'! 434310startUp 434311 Default := nil! ! 434312 434313 434314!UUIDGenerator class methodsFor: 'instance creation' stamp: 'JMM 11/22/2001 13:41'! 434315default 434316 Default ifNil: [self generateDefault]. 434317 ^Default! ! 434318 434319!UUIDGenerator class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:51'! 434320generateDefault 434321 Default := self new! ! 434322TestCase subclass: #UUIDPrimitivesTest 434323 instanceVariableNames: '' 434324 classVariableNames: 'Default' 434325 poolDictionaries: '' 434326 category: 'NetworkTests-UUID'! 434327 434328!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 17:14'! 434329testCreation 434330 | uuid | 434331 uuid := UUID new. 434332 self should: [uuid size = 16]. 434333 self shouldnt: [uuid isNilUUID]. 434334 self should: [uuid asString size = 36]. 434335! ! 434336 434337!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 17:27'! 434338testCreationEquality 434339 | uuid1 uuid2 | 434340 uuid1 := UUID new. 434341 uuid2 := UUID new. 434342 self should: [uuid1 = uuid1]. 434343 self should: [uuid2 = uuid2]. 434344 self shouldnt: [uuid1 = uuid2]. 434345 self shouldnt: [uuid1 hash = uuid2 hash]. 434346! ! 434347 434348!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 17:17'! 434349testCreationFromString 434350 | uuid string | 434351 string := UUID nilUUID asString. 434352 uuid := UUID fromString: string. 434353 self should: [uuid size = 16]. 434354 self should: [uuid = UUID nilUUID]. 434355 self should: [uuid isNilUUID]. 434356 self should: [uuid asString size = 36]. 434357 self should: [uuid asArray asSet size = 1]. 434358 self should: [(uuid asArray asSet asArray at: 1) = 0]. 434359! ! 434360 434361!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 17:18'! 434362testCreationFromStringNotNil 434363 | uuid string | 434364 string := UUID new asString. 434365 uuid := UUID fromString: string. 434366 self should: [uuid size = 16]. 434367 self should: [uuid asString size = 36]. 434368 434369! ! 434370 434371!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 17:16'! 434372testCreationNil 434373 | uuid | 434374 uuid := UUID nilUUID. 434375 self should: [uuid size = 16]. 434376 self should: [uuid isNilUUID]. 434377 self should: [uuid asString size = 36]. 434378 self should: [uuid asArray asSet size = 1]. 434379 self should: [(uuid asArray asSet asArray at: 1) = 0]. 434380! ! 434381 434382!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 23:24'! 434383testCreationNodeBased 434384 | uuid | 434385 434386 (UUID new asString last: 12) = (UUID new asString last: 12) ifFalse: [^self]. 434387 1000 timesRepeat: 434388 [uuid := UUID new. 434389 self should: [((uuid at: 7) bitAnd: 16rF0) = 16r10]. 434390 self should: [((uuid at: 9) bitAnd: 16rC0) = 16r80]] 434391! ! 434392 434393!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 22:38'! 434394testDuplicationsKinda 434395 |check uuid size | 434396 434397 size := 5000. 434398 check := Set new: size. 434399 size timesRepeat: 434400 [uuid := UUID new. 434401 self shouldnt: [check includes: uuid]. 434402 check add: uuid]. 434403 ! ! 434404 434405!UUIDPrimitivesTest methodsFor: 'tests' stamp: 'JMM 11/22/2001 17:37'! 434406testOrder 434407 | uuid1 uuid2 | 434408 100 timesRepeat: 434409 [uuid1 := UUID new. 434410 uuid2 := UUID new. 434411 (uuid1 asString last: 12) = (uuid2 asString last: 12) ifTrue: 434412 [self should: [uuid1 < uuid2]. 434413 self should: [uuid2 > uuid1]. 434414 self shouldnt: [uuid1 = uuid2]]] 434415! ! 434416ParserNotification subclass: #UndeclaredVariable 434417 instanceVariableNames: 'parser interval' 434418 classVariableNames: '' 434419 poolDictionaries: '' 434420 category: 'Compiler-Exceptions'! 434421 434422!UndeclaredVariable methodsFor: 'as yet unclassified' stamp: 'eem 9/5/2009 14:41'! 434423openMenuIn: aBlock 434424 | alternatives labels actions lines caption choice | 434425 alternatives := parser possibleVariablesFor: name. 434426 labels := OrderedCollection new. 434427 actions := OrderedCollection new. 434428 lines := OrderedCollection new. 434429 name first isLowercase 434430 ifTrue: 434431 [labels add: 'declare temp'. 434432 actions add: [parser declareTempAndPaste: name]. 434433 labels add: 'declare instance'. 434434 actions add: [parser declareInstVar: name]] 434435 ifFalse: 434436 [labels add: 'define new class'. 434437 actions add: [parser defineClass: name]. 434438 labels add: 'declare global'. 434439 actions add: [parser declareGlobal: name]. 434440 parser canDeclareClassVariable 434441 ifTrue: 434442 [labels add: 'declare class variable'. 434443 actions add: [parser declareClassVar: name]]]. 434444 lines add: labels size. 434445 alternatives do: 434446 [:each | 434447 labels add: each. 434448 actions add: [parser substituteVariable: each atInterval: interval] fixTemps]. 434449 lines add: labels size. 434450 labels add: 'cancel'. 434451 caption := 'Unknown variable: ' , name , ' please correct, or cancel:'. 434452 choice := aBlock value: labels value: lines value: caption. 434453 self resume: (actions at: choice ifAbsent: [nil])! ! 434454 434455!UndeclaredVariable methodsFor: 'as yet unclassified' stamp: 'cwp 10/15/2007 23:04'! 434456setParser: aParser name: aString range: anInterval 434457 parser := aParser. 434458 name := aString. 434459 interval := anInterval! ! 434460 434461"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 434462 434463UndeclaredVariable class 434464 instanceVariableNames: ''! 434465 434466!UndeclaredVariable class methodsFor: 'as yet unclassified' stamp: 'cwp 10/15/2007 22:37'! 434467signalFor: aParser name: aString inRange: anInterval 434468 ^ (self new setParser: aParser name: aString range: anInterval) signal! ! 434469Notification subclass: #UndeclaredVariableReference 434470 instanceVariableNames: 'parser varName varStart varEnd' 434471 classVariableNames: '' 434472 poolDictionaries: '' 434473 category: 'Compiler-Support'! 434474Warning subclass: #UndeclaredVariableWarning 434475 instanceVariableNames: 'name selector class' 434476 classVariableNames: '' 434477 poolDictionaries: '' 434478 category: 'Compiler-Support'! 434479 434480!UndeclaredVariableWarning methodsFor: 'exceptionDescription' stamp: 'bgf 3/10/2009 19:03'! 434481defaultAction 434482 "The user should be notified of the occurrence of an exceptional occurrence and 434483 given an option of continuing or aborting the computation. The description of the 434484 occurrence should include any text specified as the argument of the #signal: message." 434485 434486 selector ifNotNil: [Transcript cr; nextPutAll: class name, '>>', selector, ' '] 434487 ifNil: [Transcript cr ]. 434488 Transcript show: '(' , name , ' is Undeclared) '. 434489 ^true! ! 434490 434491 434492!UndeclaredVariableWarning methodsFor: 'initialize-release' stamp: 'eem 7/27/2008 17:37'! 434493name: aString selector: aSymbolOrNil class: aBehavior 434494 name := aString. 434495 selector := aSymbolOrNil. 434496 class := aBehavior! ! 434497Object subclass: #UndefinedObject 434498 instanceVariableNames: '' 434499 classVariableNames: '' 434500 poolDictionaries: '' 434501 category: 'Kernel-Objects'! 434502!UndefinedObject commentStamp: '<historical>' prior: 0! 434503I describe the behavior of my sole instance, nil. nil represents a prior value for variables that have not been initialized, or for results which are meaningless.! 434504 434505 434506!UndefinedObject methodsFor: 'bottom context' stamp: 'ajh 2/1/2003 01:31'! 434507canHandleSignal: exception 434508 "When no more handler (on:do:) context left in sender chain this gets called" 434509 434510 ^ false! ! 434511 434512!UndefinedObject methodsFor: 'bottom context' stamp: 'ajh 2/1/2003 01:31'! 434513handleSignal: exception 434514 "When no more handler (on:do:) context left in sender chain this gets called. Return from signal with default action." 434515 434516 ^ exception resumeUnchecked: exception defaultAction! ! 434517 434518 434519!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 16:49'! 434520addSubclass: aClass 434521 "Ignored -- necessary to support disjoint class hierarchies"! ! 434522 434523!UndefinedObject methodsFor: 'class hierarchy' stamp: 'dvf 8/9/2005 16:49'! 434524allSuperclassesDo: aBlockContext 434525 self shouldBeImplemented! ! 434526 434527!UndefinedObject methodsFor: 'class hierarchy' stamp: 'sd 3/28/2003 15:16'! 434528environment 434529 "Necessary to support disjoint class hierarchies." 434530 434531 ^self class environment! ! 434532 434533!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ajh 1/27/2003 17:48'! 434534literalScannedAs: scannedLiteral notifying: requestor 434535 ^ scannedLiteral! ! 434536 434537!UndefinedObject methodsFor: 'class hierarchy' stamp: 'dvf 9/22/2005 20:10'! 434538removeObsoleteSubclass: aClass 434539 "Ignored -- necessary to support disjoint class hierarchies"! ! 434540 434541!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ikp 9/26/97 14:45'! 434542removeSubclass: aClass 434543 "Ignored -- necessary to support disjoint class hierarchies"! ! 434544 434545!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 8/29/1999 12:49'! 434546subclassDefinerClass 434547 "For disjunct class hierarchies -- how should subclasses of nil be evaluated" 434548 ^Compiler! ! 434549 434550!UndefinedObject methodsFor: 'class hierarchy' stamp: 'PeterHugossonMiller 9/3/2009 11:46'! 434551subclasses 434552 "Return all the subclasses of nil" 434553 | classList | 434554 classList := Array new writeStream. 434555 self subclassesDo:[:class| classList nextPut: class]. 434556 ^classList contents! ! 434557 434558!UndefinedObject methodsFor: 'class hierarchy' stamp: 'tk 8/18/1999 17:46'! 434559subclassesDoGently: aBlock 434560 "Evaluate aBlock with all subclasses of nil. Others are not direct subclasses of Class." 434561 434562 ^ Class subclassesDoGently: [:cl | 434563 cl isMeta ifTrue: [aBlock value: cl soleInstance]].! ! 434564 434565!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 15:44'! 434566subclassesDo: aBlock 434567 "Evaluate aBlock with all subclasses of nil." 434568 ^Class subclassesDo:[:cl| 434569 cl isMeta ifTrue:[aBlock value: cl soleInstance]].! ! 434570 434571!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ls 10/9/2001 00:11'! 434572subclass: nameOfClass 434573 instanceVariableNames: instVarNames 434574 classVariableNames: classVarNames 434575 poolDictionaries: poolDictnames 434576 category: category 434577 "Calling this method is now considered an accident. If you really want to create a class with a nil superclass, then create the class and then set the superclass using #superclass:" 434578 Transcript show: ('Attempt to create ', nameOfClass, ' as a subclass of nil. Possibly a class is being loaded before its superclass.'); cr. 434579 ^ProtoObject 434580 subclass: nameOfClass 434581 instanceVariableNames: instVarNames 434582 classVariableNames: classVarNames 434583 poolDictionaries: poolDictnames 434584 category: category 434585! ! 434586 434587!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/13/1999 06:08'! 434588typeOfClass 434589 "Necessary to support disjoint class hierarchies." 434590 ^#normal! ! 434591 434592 434593!UndefinedObject methodsFor: 'compiling' stamp: 'md 2/20/2006 18:47'! 434594parserClass 434595 434596 ^ Compiler parserClass! ! 434597 434598 434599!UndefinedObject methodsFor: 'copying' stamp: 'tk 6/26/1998 11:35'! 434600clone 434601 "Only one instance of UndefinedObject should ever be made, so answer 434602 with self."! ! 434603 434604!UndefinedObject methodsFor: 'copying'! 434605deepCopy 434606 "Only one instance of UndefinedObject should ever be made, so answer 434607 with self."! ! 434608 434609!UndefinedObject methodsFor: 'copying'! 434610shallowCopy 434611 "Only one instance of UndefinedObject should ever be made, so answer 434612 with self."! ! 434613 434614!UndefinedObject methodsFor: 'copying' stamp: 'tk 8/20/1998 16:07'! 434615veryDeepCopyWith: deepCopier 434616 "Return self. I can't be copied. Do not record me."! ! 434617 434618 434619!UndefinedObject methodsFor: 'dependents access'! 434620addDependent: ignored 434621 "Refer to the comment in Object|dependents." 434622 434623 self error: 'Nil should not have dependents'! ! 434624 434625!UndefinedObject methodsFor: 'dependents access'! 434626release 434627 "Nil release is a no-op"! ! 434628 434629!UndefinedObject methodsFor: 'dependents access'! 434630suspend 434631 "Kills off processes that didn't terminate properly" 434632 "Display reverse; reverse." "<-- So we can catch the suspend bug" 434633 Processor terminateActive! ! 434634 434635 434636!UndefinedObject methodsFor: 'printing'! 434637printOn: aStream 434638 "Refer to the comment in Object|printOn:." 434639 434640 aStream nextPutAll: 'nil'! ! 434641 434642!UndefinedObject methodsFor: 'printing'! 434643storeOn: aStream 434644 "Refer to the comment in Object|storeOn:." 434645 434646 aStream nextPutAll: 'nil'! ! 434647 434648 434649!UndefinedObject methodsFor: 'testing' stamp: 'sw 1/12/98 18:09'! 434650haltIfNil 434651 self halt! ! 434652 434653!UndefinedObject methodsFor: 'testing'! 434654ifNil: aBlock 434655 "A convenient test, in conjunction with Object ifNil:" 434656 434657 ^ aBlock value! ! 434658 434659!UndefinedObject methodsFor: 'testing' stamp: 'md 10/7/2004 15:41'! 434660ifNil: nilBlock ifNotNilDo: ifNotNilBlock 434661 "Evaluate the block for nil because I'm == nil" 434662 434663 ^ nilBlock value! ! 434664 434665!UndefinedObject methodsFor: 'testing'! 434666ifNil: nilBlock ifNotNil: ifNotNilBlock 434667 "Evaluate the block for nil because I'm == nil" 434668 434669 ^ nilBlock value! ! 434670 434671!UndefinedObject methodsFor: 'testing' stamp: 'di 11/8/2000 21:22'! 434672ifNotNilDo: aBlock 434673 "Override to do nothing." 434674 434675 ^ self 434676! ! 434677 434678!UndefinedObject methodsFor: 'testing' stamp: 'md 10/7/2004 15:39'! 434679ifNotNilDo: ifNotNilBlock ifNil: nilBlock 434680 "If I got here, I am nil, so evaluate the block nilBlock" 434681 434682 ^ nilBlock value! ! 434683 434684!UndefinedObject methodsFor: 'testing'! 434685ifNotNil: aBlock 434686 "A convenient test, in conjunction with Object ifNotNil:" 434687 434688 ^ self! ! 434689 434690!UndefinedObject methodsFor: 'testing'! 434691ifNotNil: ifNotNilBlock ifNil: nilBlock 434692 "If I got here, I am nil, so evaluate the block nilBlock" 434693 434694 ^ nilBlock value! ! 434695 434696!UndefinedObject methodsFor: 'testing' stamp: 'sw 4/7/1999 17:44'! 434697isEmptyOrNil 434698 "Answer whether the receiver contains any elements, or is nil. Useful in numerous situations where one wishes the same reaction to an empty collection or to nil" 434699 ^ true! ! 434700 434701!UndefinedObject methodsFor: 'testing' stamp: 'sma 6/6/2000 22:53'! 434702isLiteral 434703 ^ true! ! 434704 434705!UndefinedObject methodsFor: 'testing'! 434706isNil 434707 "Refer to the comment in Object|isNil." 434708 434709 ^true! ! 434710 434711!UndefinedObject methodsFor: 'testing'! 434712notNil 434713 "Refer to the comment in Object|notNil." 434714 434715 ^false! ! 434716 434717 434718"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 434719 434720UndefinedObject class 434721 instanceVariableNames: ''! 434722 434723!UndefinedObject class methodsFor: 'instance creation' stamp: 'sw 5/5/2000 09:32'! 434724initializedInstance 434725 ^ nil! ! 434726 434727!UndefinedObject class methodsFor: 'instance creation'! 434728new 434729 self error: 'You may not create any more undefined objects--use nil'! ! 434730ClassTestCase subclass: #UndefinedObjectTest 434731 instanceVariableNames: '' 434732 classVariableNames: '' 434733 poolDictionaries: '' 434734 category: 'KernelTests-Objects'! 434735!UndefinedObjectTest commentStamp: '<historical>' prior: 0! 434736This is the unit test for the class UndefinedObject. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 434737 - http://www.c2.com/cgi/wiki?UnitTest 434738 - http://minnow.cc.gatech.edu/squeak/1547 434739 - the sunit class category! 434740 434741 434742!UndefinedObjectTest methodsFor: 'tests - Class Methods' stamp: 'sd 6/5/2005 09:08'! 434743testInitializedInstance 434744 434745 self assert: ( UndefinedObject initializedInstance class == UndefinedObject).! ! 434746 434747!UndefinedObjectTest methodsFor: 'tests - Class Methods' stamp: 'sd 6/5/2005 09:09'! 434748testNew 434749 434750 self should: [ UndefinedObject new] raise: Error.! ! 434751 434752 434753!UndefinedObjectTest methodsFor: 'tests - copying' stamp: 'sd 6/5/2005 09:07'! 434754testClone 434755 434756 self assert: ( nil clone = nil).! ! 434757 434758!UndefinedObjectTest methodsFor: 'tests - copying' stamp: 'sd 6/5/2005 09:07'! 434759testDeepCopy 434760 434761 self assert: (nil deepCopy = nil).! ! 434762 434763!UndefinedObjectTest methodsFor: 'tests - copying' stamp: 'sd 6/5/2005 09:07'! 434764testShallowCopy 434765 434766 self assert: (nil shallowCopy = nil).! ! 434767 434768!UndefinedObjectTest methodsFor: 'tests - copying' stamp: 'sd 6/5/2005 09:07'! 434769testVeryDeepCopyWith 434770 434771 self assert: ((nil veryDeepCopyWith: nil) = nil).! ! 434772 434773 434774!UndefinedObjectTest methodsFor: 'tests - printing' stamp: 'sd 6/5/2005 09:09'! 434775testPrintOn 434776 434777 | string | 434778 string := String streamContents: [:stream | nil printOn: stream]. 434779 self assert: (string = 'nil').! ! 434780 434781!UndefinedObjectTest methodsFor: 'tests - printing' stamp: 'sd 6/5/2005 09:09'! 434782testStoreOn 434783 434784 | string | 434785 string := String streamContents: [:stream | nil storeOn: stream]. 434786 self assert: ((Compiler evaluate: string) = nil).! ! 434787 434788 434789!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:07'! 434790testHaltIfNil 434791 434792 self should: [ nil haltIfNil] raise: Halt.! ! 434793 434794!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:07'! 434795testIfNil 434796 434797 self should: [ nil ifNil: [self halt]] raise: Halt. 434798 434799 434800! ! 434801 434802!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'! 434803testIfNilIfNotNil 434804 434805 self should: [ nil ifNil: [self halt] ifNotNil: [self error] ] raise: Halt. 434806 434807 434808! ! 434809 434810!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'! 434811testIfNotNil 434812 434813 self shouldnt: [ nil ifNotNil: [self halt]] raise: Halt. 434814 434815 434816! ! 434817 434818!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'marcus.denker 11/10/2008 10:04'! 434819testIfNotNilDo 434820 434821 self shouldnt: [ nil ifNotNil: [self halt]] raise: Halt. 434822! ! 434823 434824!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'! 434825testIfNotNilIfNil 434826 434827 self should: [ nil ifNotNil: [self error] ifNil: [self halt] ] raise: Halt. 434828 434829 434830! ! 434831 434832!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'! 434833testIsEmptyOrNil 434834 434835 self assert: (nil isEmptyOrNil).! ! 434836 434837!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'! 434838testIsLiteral 434839 434840 self assert: (nil isLiteral).! ! 434841 434842!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'! 434843testIsNil 434844 434845 self assert: (nil isNil).! ! 434846 434847!UndefinedObjectTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 09:08'! 434848testNotNil 434849 434850 self deny: (nil notNil).! ! 434851ParserNotification subclass: #UndefinedVariable 434852 instanceVariableNames: '' 434853 classVariableNames: '' 434854 poolDictionaries: '' 434855 category: 'Compiler-Exceptions'! 434856 434857!UndefinedVariable methodsFor: 'as yet unclassified' stamp: 'cwp 10/17/2007 22:39/eem 9/5/2009 11:10 - => :='! 434858openMenuIn: aBlock 434859 | labels caption index | 434860 labels := #('yes' 'no'). 434861 caption := name, ' appears to be 434862undefined at this point. 434863Proceed anyway?'. 434864 434865 index := aBlock value: labels value: #() value: caption. 434866 ^ self resume: index = 1! ! 434867Exception subclass: #UnhandledError 434868 instanceVariableNames: 'exception' 434869 classVariableNames: '' 434870 poolDictionaries: '' 434871 category: 'Exceptions-Kernel'! 434872 434873!UnhandledError methodsFor: 'as yet unclassified' stamp: 'ajh 9/4/2002 19:15'! 434874exception 434875 434876 ^ exception! ! 434877 434878!UnhandledError methodsFor: 'as yet unclassified' stamp: 'ajh 9/4/2002 19:15'! 434879exception: anError 434880 434881 exception := anError! ! 434882 434883 434884!UnhandledError methodsFor: 'priv handling' stamp: 'ar 9/27/2005 19:53'! 434885defaultAction 434886 "The current computation is terminated. The cause of the error should be logged or reported to the user. If the program is operating in an interactive debugging environment the computation should be suspended and the debugger activated." 434887 ^ToolSet debugError: exception.! ! 434888 434889!UnhandledError methodsFor: 'priv handling' stamp: 'ajh 2/1/2003 00:56'! 434890isResumable 434891 434892 ^ false! ! 434893 434894"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 434895 434896UnhandledError class 434897 instanceVariableNames: ''! 434898 434899!UnhandledError class methodsFor: 'as yet unclassified' stamp: 'ajh 9/4/2002 19:17'! 434900signalForException: anError 434901 434902 ^ self new 434903 exception: anError; 434904 signal! ! 434905EncodedCharSet subclass: #Unicode 434906 instanceVariableNames: '' 434907 classVariableNames: 'Cc Cf Cn Co Cs DecimalProperty GeneralCategory Ll Lm Lo Lt Lu Mc Me Mn Nd Nl No Pc Pd Pe Pf Pi Po Ps Sc Sk Sm So Zl Zp Zs' 434908 poolDictionaries: '' 434909 category: 'Multilingual-Encodings'! 434910!Unicode commentStamp: 'yo 10/19/2004 20:44' prior: 0! 434911This class holds the entry points for the utility functions around characters. 434912! 434913 434914 434915"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 434916 434917Unicode class 434918 instanceVariableNames: ''! 434919 434920!Unicode class methodsFor: 'accessing - displaying' stamp: 'yo 1/2/2003 14:25'! 434921scanSelector 434922 434923 ^ #scanMultiCharactersCombiningFrom:to:in:rightX:stopConditions:kern:. 434924 "^ #scanMultiCharactersFrom:to:in:rightX:stopConditions:kern:." 434925! ! 434926 434927 434928!Unicode class methodsFor: 'character classification' stamp: 'kwl 6/30/2006 02:55'! 434929isDigit: char 434930 | value | 434931 value := char charCode. 434932 value > (GeneralCategory size - 1) 434933 ifTrue: [^ false]. 434934 ^ (GeneralCategory at: value + 1) 434935 = Nd! ! 434936 434937!Unicode class methodsFor: 'character classification' stamp: 'kwl 6/30/2006 02:56'! 434938isLetter: char 434939 | value codeCat | 434940 value := char charCode. 434941 value > (GeneralCategory size - 1) 434942 ifTrue: [^ false]. 434943 ^ (codeCat := GeneralCategory at: value + 1) >= Ll 434944 and: [codeCat <= Lu]! ! 434945 434946!Unicode class methodsFor: 'character classification' stamp: 'kwl 6/30/2006 02:57'! 434947isLowercase: char 434948 | value | 434949 value := char charCode. 434950 value > (GeneralCategory size - 1) 434951 ifTrue: [^ false]. 434952 ^ (GeneralCategory at: value + 1) 434953 = Ll! ! 434954 434955!Unicode class methodsFor: 'character classification' stamp: 'kwl 6/30/2006 02:58'! 434956isUppercase: char 434957 | value | 434958 value := char charCode. 434959 value > (GeneralCategory size - 1) 434960 ifTrue: [^ false]. 434961 ^ (GeneralCategory at: value + 1) 434962 = Lu! ! 434963 434964 434965!Unicode class methodsFor: 'class initialization' stamp: 'kwl 6/30/2006 02:53'! 434966initialize 434967 " Unicode initialize " 434968 (self classPool keys 434969 select: [:sym | sym size = 2 and: sym first isUppercase and: sym last isLowercase]) asSortedCollection 434970 inject: 1 434971 into: [:index :sym | sym = #Cn 434972 ifTrue: [self classPool at: sym put: 0. index] 434973 ifFalse: [self classPool at: sym put: index. index + 1]]! ! 434974 434975 434976!Unicode class methodsFor: 'class methods' stamp: 'yo 12/24/2002 07:49'! 434977compoundTextFinalChar 434978 434979 self shouldNotImplement. 434980! ! 434981 434982!Unicode class methodsFor: 'class methods' stamp: 'yo 12/24/2002 08:03'! 434983compoundTextSequence 434984 434985 self subclassResponsibility. 434986! ! 434987 434988!Unicode class methodsFor: 'class methods' stamp: 'yo 1/19/2005 10:58'! 434989digitValue: char 434990 434991 | value | 434992 value := char charCode. 434993 value <= $9 asciiValue 434994 ifTrue: [^value - $0 asciiValue]. 434995 value >= $A asciiValue 434996 ifTrue: [value <= $Z asciiValue ifTrue: [^value - $A asciiValue + 10]]. 434997 434998 value > (DecimalProperty size - 1) ifTrue: [^ -1]. 434999 ^ (DecimalProperty at: value+1) 435000! ! 435001 435002!Unicode class methodsFor: 'class methods' stamp: 'yo 2/20/2004 14:12'! 435003generalCategory 435004 435005 ^ GeneralCategory. 435006 435007! ! 435008 435009!Unicode class methodsFor: 'class methods' stamp: 'yo 8/5/2003 16:12'! 435010generalCategoryComment 435011" 435012Lu Letter, Uppercase 435013Ll Letter, Lowercase 435014Lt Letter, Titlecase 435015Lm Letter, Modifier 435016Lo Letter, Other 435017Mn Mark, Non-Spacing 435018Mc Mark, Spacing Combining 435019Me Mark, Enclosing 435020Nd Number, Decimal 435021Nl Number, Letter 435022No Number, Other 435023Pc Punctuation, Connector 435024Pd Punctuation, Dash 435025Ps Punctuation, Open 435026Pe Punctuation, Close 435027Pi Punctuation, Initial quote (may behave like Ps or Pe depending on usage) 435028Pf Punctuation, Final quote (may behave like Ps or Pe depending on usage) 435029Po Punctuation, Other 435030Sm Symbol, Math 435031Sc Symbol, Currency 435032Sk Symbol, Modifier 435033So Symbol, Other 435034Zs Separator, Space 435035Zl Separator, Line 435036Zp Separator, Paragraph 435037Cc Other, Control 435038Cf Other, Format 435039Cs Other, Surrogate 435040Co Other, Private Use 435041Cn Other, Not Assigned (no characters in the file have this property) 435042"! ! 435043 435044!Unicode class methodsFor: 'class methods' stamp: 'yo 12/4/2004 22:47'! 435045isCharset 435046 435047 ^ false. 435048! ! 435049 435050!Unicode class methodsFor: 'class methods' stamp: 'yo 8/4/2003 11:50'! 435051leadingChar 435052 435053 ^ 255. 435054! ! 435055 435056!Unicode class methodsFor: 'class methods' stamp: 'yo 1/15/2004 17:23'! 435057parseUnicodeDataFrom: stream 435058" 435059 self halt. 435060 self parseUnicodeDataFile 435061" 435062 435063 | line fieldEnd point fieldStart toNumber generalCategory decimalProperty | 435064 435065 toNumber := [:quad | ('16r', quad) asNumber]. 435066 435067 GeneralCategory := SparseLargeTable new: 16rE0080 chunkSize: 1024 arrayClass: Array base: 1 defaultValue: 'Cn'. 435068 DecimalProperty := SparseLargeTable new: 16rE0080 chunkSize: 32 arrayClass: Array base: 1 defaultValue: -1. 435069 435070 16r3400 to: 16r4DB5 do: [:i | GeneralCategory at: i+1 put: 'Lo']. 435071 16r4E00 to: 16r9FA5 do: [:i | GeneralCategory at: i+1 put: 'Lo']. 435072 16rAC00 to: 16rD7FF do: [:i | GeneralCategory at: i+1 put: 'Lo']. 435073 435074 [(line := stream upTo: Character cr) size > 0] whileTrue: [ 435075 fieldEnd := line indexOf: $; startingAt: 1. 435076 point := toNumber value: (line copyFrom: 1 to: fieldEnd - 1). 435077 point > 16rE007F ifTrue: [ 435078 GeneralCategory zapDefaultOnlyEntries. 435079 DecimalProperty zapDefaultOnlyEntries. 435080 ^ self]. 435081 2 to: 3 do: [:i | 435082 fieldStart := fieldEnd + 1. 435083 fieldEnd := line indexOf: $; startingAt: fieldStart. 435084 ]. 435085 generalCategory := line copyFrom: fieldStart to: fieldEnd - 1. 435086 GeneralCategory at: point+1 put: generalCategory. 435087 generalCategory = 'Nd' ifTrue: [ 435088 4 to: 7 do: [:i | 435089 fieldStart := fieldEnd + 1. 435090 fieldEnd := line indexOf: $; startingAt: fieldStart. 435091 ]. 435092 decimalProperty := line copyFrom: fieldStart to: fieldEnd - 1. 435093 DecimalProperty at: point+1 put: decimalProperty asNumber. 435094 ]. 435095 ]. 435096 GeneralCategory zapDefaultOnlyEntries. 435097 DecimalProperty zapDefaultOnlyEntries. 435098! ! 435099 435100 435101!Unicode class methodsFor: 'comments' stamp: 'yo 12/23/2002 13:04'! 435102blocks320Comment 435103 435104"# Blocks-3.2.0.txt 435105# Correlated with Unicode 3.2 435106# Start Code..End Code; Block Name 4351070000..007F; Basic Latin 4351080080..00FF; Latin-1 Supplement 4351090100..017F; Latin Extended-A 4351100180..024F; Latin Extended-B 4351110250..02AF; IPA Extensions 43511202B0..02FF; Spacing Modifier Letters 4351130300..036F; Combining Diacritical Marks 4351140370..03FF; Greek and Coptic 4351150400..04FF; Cyrillic 4351160500..052F; Cyrillic Supplementary 4351170530..058F; Armenian 4351180590..05FF; Hebrew 4351190600..06FF; Arabic 4351200700..074F; Syriac 4351210780..07BF; Thaana 4351220900..097F; Devanagari 4351230980..09FF; Bengali 4351240A00..0A7F; Gurmukhi 4351250A80..0AFF; Gujarati 4351260B00..0B7F; Oriya 4351270B80..0BFF; Tamil 4351280C00..0C7F; Telugu 4351290C80..0CFF; Kannada 4351300D00..0D7F; Malayalam 4351310D80..0DFF; Sinhala 4351320E00..0E7F; Thai 4351330E80..0EFF; Lao 4351340F00..0FFF; Tibetan 4351351000..109F; Myanmar 43513610A0..10FF; Georgian 4351371100..11FF; Hangul Jamo 4351381200..137F; Ethiopic 43513913A0..13FF; Cherokee 4351401400..167F; Unified Canadian Aboriginal Syllabics 4351411680..169F; Ogham 43514216A0..16FF; Runic 4351431700..171F; Tagalog 4351441720..173F; Hanunoo 4351451740..175F; Buhid 4351461760..177F; Tagbanwa 4351471780..17FF; Khmer 4351481800..18AF; Mongolian 4351491E00..1EFF; Latin Extended Additional 4351501F00..1FFF; Greek Extended 4351512000..206F; General Punctuation 4351522070..209F; Superscripts and Subscripts 43515320A0..20CF; Currency Symbols 43515420D0..20FF; Combining Diacritical Marks for Symbols 4351552100..214F; Letterlike Symbols 4351562150..218F; Number Forms 4351572190..21FF; Arrows 4351582200..22FF; Mathematical Operators 4351592300..23FF; Miscellaneous Technical 4351602400..243F; Control Pictures 4351612440..245F; Optical Character Recognition 4351622460..24FF; Enclosed Alphanumerics 4351632500..257F; Box Drawing 4351642580..259F; Block Elements 43516525A0..25FF; Geometric Shapes 4351662600..26FF; Miscellaneous Symbols 4351672700..27BF; Dingbats 43516827C0..27EF; Miscellaneous Mathematical Symbols-A 43516927F0..27FF; Supplemental Arrows-A 4351702800..28FF; Braille Patterns 4351712900..297F; Supplemental Arrows-B 4351722980..29FF; Miscellaneous Mathematical Symbols-B 4351732A00..2AFF; Supplemental Mathematical Operators 4351742E80..2EFF; CJK Radicals Supplement 4351752F00..2FDF; Kangxi Radicals 4351762FF0..2FFF; Ideographic Description Characters 4351773000..303F; CJK Symbols and Punctuation 4351783040..309F; Hiragana 43517930A0..30FF; Katakana 4351803100..312F; Bopomofo 4351813130..318F; Hangul Compatibility Jamo 4351823190..319F; Kanbun 43518331A0..31BF; Bopomofo Extended 43518431F0..31FF; Katakana Phonetic Extensions 4351853200..32FF; Enclosed CJK Letters and Months 4351863300..33FF; CJK Compatibility 4351873400..4DBF; CJK Unified Ideographs Extension A 4351884E00..9FFF; CJK Unified Ideographs 435189A000..A48F; Yi Syllables 435190A490..A4CF; Yi Radicals 435191AC00..D7AF; Hangul Syllables 435192D800..DB7F; High Surrogates 435193DB80..DBFF; High Private Use Surrogates 435194DC00..DFFF; Low Surrogates 435195E000..F8FF; Private Use Area 435196F900..FAFF; CJK Compatibility Ideographs 435197FB00..FB4F; Alphabetic Presentation Forms 435198FB50..FDFF; Arabic Presentation Forms-A 435199FE00..FE0F; Variation Selectors 435200FE20..FE2F; Combining Half Marks 435201FE30..FE4F; CJK Compatibility Forms 435202FE50..FE6F; Small Form Variants 435203FE70..FEFF; Arabic Presentation Forms-B 435204FF00..FFEF; Halfwidth and Fullwidth Forms 435205FFF0..FFFF; Specials 43520610300..1032F; Old Italic 43520710330..1034F; Gothic 43520810400..1044F; Deseret 4352091D000..1D0FF; Byzantine Musical Symbols 4352101D100..1D1FF; Musical Symbols 4352111D400..1D7FF; Mathematical Alphanumeric Symbols 43521220000..2A6DF; CJK Unified Ideographs Extension B 4352132F800..2FA1F; CJK Compatibility Ideographs Supplement 435214E0000..E007F; Tags 435215F0000..FFFFF; Supplementary Private Use Area-A 435216100000..10FFFF; Supplementary Private Use Area-B 435217 435218 435219"! ! 435220 435221!Unicode class methodsFor: 'comments' stamp: 'yo 3/17/2004 23:38'! 435222blocks320Comment2 435223 435224"# Blocks-3.2.0.txt 435225# Correlated with Unicode 3.2 435226# Start Code..End Code; Block Name 4352270000..007F; Basic Latin 4352280080..00FF; Latin-1 Supplement 435229 435230 => Latin 1 435231 4352320100..017F; Latin Extended-A 4352330180..024F; Latin Extended-B 4352340250..02AF; IPA Extensions 435235 435236 => LatinExtended1 435237 43523802B0..02FF; Spacing Modifier Letters 4352390300..036F; Combining Diacritical Marks 435240 435241 => Modifiers 435242 4352430370..03FF; Greek and Coptic 4352440400..04FF; Cyrillic 4352450500..052F; Cyrillic Supplementary 4352460530..058F; Armenian 435247 435248 => EuropeanAlphabetic1 435249 4352500590..05FF; Hebrew 4352510600..06FF; Arabic 4352520700..074F; Syriac 4352530780..07BF; Thaana 435254 435255 => MiddleEastern 435256 4352570900..097F; Devanagari 4352580980..09FF; Bengali 4352590A00..0A7F; Gurmukhi 4352600A80..0AFF; Gujarati 4352610B00..0B7F; Oriya 4352620B80..0BFF; Tamil 4352630C00..0C7F; Telugu 4352640C80..0CFF; Kannada 4352650D00..0D7F; Malayalam 4352660D80..0DFF; Sinhala 435267 435268 => South Asian1 435269 435270 4352710E00..0E7F; Thai 4352720E80..0EFF; Lao 435273 435274 => Southeastern 1 435275 4352760F00..0FFF; Tibetan 435277 435278 => South Asian1 435279 4352801000..109F; Myanmar 435281 435282 => Southeastern 1 435283 435284 43528510A0..10FF; Georgian 435286 435287 => European Alphabetic 2 435288 4352891100..11FF; Hangul Jamo 435290 435291 => Korean 435292 4352931200..137F; Ethiopic 43529413A0..13FF; Cherokee 4352951400..167F; Unified Canadian Aboriginal Syllabics 435296 435297 => Additional1 435298 4352991680..169F; Ogham 43530016A0..16FF; Runic 435301 435302 => European Alphabetic 3 435303 4353041700..171F; Tagalog 4353051720..173F; Hanunoo 4353061740..175F; Buhid 4353071760..177F; Tagbanwa 4353081780..17FF; Khmer 435309 435310 => Southeastern2 435311 4353121800..18AF; Mongolian 435313 435314 => Additional2 435315 4353161E00..1EFF; Latin Extended Additional 4353171F00..1FFF; Greek Extended 435318 435319 => EuropeanAlphabetic4 435320 4353212000..206F; General Punctuation 4353222070..209F; Superscripts and Subscripts 43532320A0..20CF; Currency Symbols 43532420D0..20FF; Combining Diacritical Marks for Symbols 4353252100..214F; Letterlike Symbols 4353262150..218F; Number Forms 4353272190..21FF; Arrows 4353282200..22FF; Mathematical Operators 4353292300..23FF; Miscellaneous Technical 4353302400..243F; Control Pictures 4353312440..245F; Optical Character Recognition 4353322460..24FF; Enclosed Alphanumerics 4353332500..257F; Box Drawing 4353342580..259F; Block Elements 43533525A0..25FF; Geometric Shapes 4353362600..26FF; Miscellaneous Symbols 4353372700..27BF; Dingbats 43533827C0..27EF; Miscellaneous Mathematical Symbols-A 43533927F0..27FF; Supplemental Arrows-A 4353402800..28FF; Braille Patterns 4353412900..297F; Supplemental Arrows-B 4353422980..29FF; Miscellaneous Mathematical Symbols-B 4353432A00..2AFF; Supplemental Mathematical Operators 435344 435345 => Symbols2 435346 4353472E80..2EFF; CJK Radicals Supplement 4353482F00..2FDF; Kangxi Radicals 4353492FF0..2FFF; Ideographic Description Characters 4353503000..303F; CJK Symbols and Punctuation 4353513040..309F; Hiragana 43535230A0..30FF; Katakana 4353533100..312F; Bopomofo 4353543130..318F; Hangul Compatibility Jamo 4353553190..319F; Kanbun 43535631A0..31BF; Bopomofo Extended 43535731F0..31FF; Katakana Phonetic Extensions 4353583200..32FF; Enclosed CJK Letters and Months 4353593300..33FF; CJK Compatibility 4353603400..4DBF; CJK Unified Ideographs Extension A 4353614E00..9FFF; CJK Unified Ideographs 435362A000..A48F; Yi Syllables 435363A490..A4CF; Yi Radicals 435364 435365 => CJK 435366 435367AC00..D7AF; Hangul Syllables 435368 435369 => Korean 435370 435371D800..DB7F; High Surrogates 435372DB80..DBFF; High Private Use Surrogates 435373DC00..DFFF; Low Surrogates 435374E000..F8FF; Private Use Area 435375 435376F900..FAFF; CJK Compatibility Ideographs 435377 435378 => CJK 435379 435380FB00..FB4F; Alphabetic Presentation Forms 435381FB50..FDFF; Arabic Presentation Forms-A 435382 435383 => Middle Eastern 2 435384 435385FE00..FE0F; Variation Selectors 435386FE20..FE2F; Combining Half Marks 435387 435388FE30..FE4F; CJK Compatibility Forms 435389 435390 => CJK 435391 435392FE50..FE6F; Small Form Variants 435393 435394 => Symbol3 435395 435396FE70..FEFF; Arabic Presentation Forms-B 435397 435398 => Middle Eastern 3 435399 435400FF00..FFEF; Halfwidth and Fullwidth Forms 435401FFF0..FFFF; Specials 435402 435403 => Specials 435404 43540510300..1032F; Old Italic 43540610330..1034F; Gothic 43540710400..1044F; Deseret 435408 435409 => European 435410 4354111D000..1D0FF; Byzantine Musical Symbols 4354121D100..1D1FF; Musical Symbols 4354131D400..1D7FF; Mathematical Alphanumeric Symbols 435414 435415 => Symbols 435416 43541720000..2A6DF; CJK Unified Ideographs Extension B 4354182F800..2FA1F; CJK Compatibility Ideographs Supplement 435419 435420 => CJK 435421 435422E0000..E007F; Tags 435423F0000..FFFFF; Supplementary Private Use Area-A 435424100000..10FFFF; Supplementary Private Use Area-B 435425 435426 => Special 435427 435428"! ! 435429 435430 435431!Unicode class methodsFor: 'instance creation' stamp: 'ar 4/9/2005 22:33'! 435432charFromUnicode: uniCode 435433 435434 ^ Character leadingChar: self leadingChar code: uniCode 435435! ! 435436 435437!Unicode class methodsFor: 'instance creation' stamp: 'ar 4/9/2005 22:33'! 435438value: code 435439 435440 | l | 435441 code < 256 ifTrue: [^ Character value: code]. 435442 l := Locale currentPlatform languageEnvironment leadingChar. 435443 l = 0 ifTrue: [l := 255]. 435444 ^ Character leadingChar: l code: code. 435445! ! 435446 435447 435448!Unicode class methodsFor: 'subencodings' stamp: 'yo 1/12/2004 18:11'! 435449isJapanese: code 435450 435451 ^ code > 255 and: [(JISX0208 charFromUnicode: code) notNil]. 435452! ! 435453 435454!Unicode class methodsFor: 'subencodings' stamp: 'yo 1/12/2004 18:11'! 435455isKorean: code 435456 435457 ^ code > 255 and: [(KSX1001 charFromUnicode: code) notNil] 435458 435459! ! 435460 435461!Unicode class methodsFor: 'subencodings' stamp: 'yo 1/12/2004 18:11'! 435462isSimplifiedChinese: code 435463 435464 ^ code > 255 and: [(GB2312 charFromUnicode: code) notNil] 435465 435466 435467! ! 435468 435469!Unicode class methodsFor: 'subencodings' stamp: 'yo 1/12/2004 18:00'! 435470isTraditionalChinese: code 435471 435472 ^ false. 435473! ! 435474 435475!Unicode class methodsFor: 'subencodings' stamp: 'yo 1/12/2004 17:55'! 435476isUnifiedKanji: code 435477 435478 ^ ((((16r2E80 <= code and: [code <= 16rA4CF]) 435479 or: [16rF900 <= code and: [code <= 16rFAFF]]) 435480 or: [16rFE30 <= code and: [code <= 16rFE4F]]) 435481 or: [16rFF00 <= code and: [code <= 16rFFEF]]) 435482 or: [16r20000 <= code and: [code <= 16r2FA1F]]. 435483! ! 435484FileDirectory subclass: #UnixFileDirectory 435485 instanceVariableNames: '' 435486 classVariableNames: '' 435487 poolDictionaries: '' 435488 category: 'Files-Directories'! 435489!UnixFileDirectory commentStamp: '<historical>' prior: 0! 435490I represent a Unix FileDirectory. 435491! 435492 435493 435494!UnixFileDirectory methodsFor: 'file names' stamp: 'yo 12/19/2003 21:15'! 435495fullPathFor: path 435496 "Return the fully-qualified path name for the given file." 435497 path isEmpty ifTrue: [^ pathName asSqueakPathName]. 435498 path first = $/ ifTrue: [^ path]. 435499 ^ pathName asSqueakPathName = '/' "Only root dir ends with a slash" 435500 ifTrue: ['/' , path] 435501 ifFalse: [pathName asSqueakPathName , '/' , path]! ! 435502 435503!UnixFileDirectory methodsFor: 'file names' stamp: 'ar 10/18/2004 10:58'! 435504pathFromUrl: aFileUrl 435505 ^'/', (super pathFromUrl: aFileUrl)! ! 435506 435507 435508!UnixFileDirectory methodsFor: 'testing' stamp: 'sr 5/8/2000 12:58'! 435509directoryExists: filenameOrPath 435510 "Handles the special case of testing for the root dir: there isn't a 435511 possibility to express the root dir as full pathname like '/foo'." 435512 435513 ^ filenameOrPath = '/' or: [super directoryExists: filenameOrPath]! ! 435514 435515!UnixFileDirectory methodsFor: 'testing' stamp: 'sr 5/8/2000 13:03'! 435516fileOrDirectoryExists: filenameOrPath 435517 "Handles the special case of testing for the root dir: there isn't a 435518 possibility to express the root dir as full pathname like '/foo'." 435519 435520 ^ filenameOrPath = '/' or: [super fileOrDirectoryExists: filenameOrPath]! ! 435521 435522 435523!UnixFileDirectory methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:32'! 435524setPathName: pathString 435525 "Unix path names start with a leading delimiter character." 435526 435527 (pathString isEmpty or: [pathString first ~= self pathNameDelimiter]) 435528 ifTrue: [pathName := FilePath pathName: (self pathNameDelimiter asString, pathString)] 435529 ifFalse: [pathName := FilePath pathName: pathString]. 435530! ! 435531 435532"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 435533 435534UnixFileDirectory class 435535 instanceVariableNames: ''! 435536 435537!UnixFileDirectory class methodsFor: 'platform specific' stamp: 'yo 2/4/1999 06:40'! 435538maxFileNameLength 435539 435540 ^ 255! ! 435541 435542!UnixFileDirectory class methodsFor: 'platform specific' stamp: 'jm 9/17/97 15:48'! 435543pathNameDelimiter 435544 435545 ^ $/ 435546! ! 435547OSPlatform subclass: #UnixPlatform 435548 instanceVariableNames: '' 435549 classVariableNames: '' 435550 poolDictionaries: '' 435551 category: 'System-Platforms'! 435552 435553!UnixPlatform methodsFor: 'accessing' stamp: 'michael.rueger 2/25/2009 18:18'! 435554platformFamily 435555 ^#Unix! ! 435556 435557"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 435558 435559UnixPlatform class 435560 instanceVariableNames: ''! 435561 435562!UnixPlatform class methodsFor: 'private' stamp: 'michael.rueger 2/25/2009 18:22'! 435563isActivePlatform 435564 ^SmalltalkImage current platformName = 'unix'! ! 435565ParserNotification subclass: #UnknownSelector 435566 instanceVariableNames: '' 435567 classVariableNames: '' 435568 poolDictionaries: '' 435569 category: 'Compiler-Exceptions'! 435570 435571!UnknownSelector methodsFor: 'as yet unclassified' stamp: 'cwp 10/17/2007 23:34/eem 9/5/2009 11:10 - => :='! 435572openMenuIn: aBlock 435573 | alternatives labels lines caption choice | 435574 alternatives := Symbol possibleSelectorsFor: name. 435575 labels := Array streamContents: 435576 [:s | s nextPut: name; nextPutAll: alternatives; nextPut: 'cancel']. 435577 lines := {1. alternatives size + 1}. 435578 caption := 'Unknown selector, please\confirm, correct, or cancel' withCRs. 435579 435580 choice := aBlock value: labels value: lines value: caption. 435581 choice = 0 ifTrue: [self resume: nil]. 435582 choice = 1 ifTrue: [self resume: name asSymbol]. 435583 choice = labels size ifTrue: [self resume: nil]. 435584 self resume: (alternatives at: choice - 1)! ! 435585ParserNotification subclass: #UnusedVariable 435586 instanceVariableNames: '' 435587 classVariableNames: '' 435588 poolDictionaries: '' 435589 category: 'Compiler-Exceptions'! 435590 435591!UnusedVariable methodsFor: 'as yet unclassified' stamp: 'eem 9/5/2009 11:10'! 435592openMenuIn: aBlock 435593 | index | 435594 index := aBlock value: #('yes' 'no') 435595 value: #() 435596 value: name, ' appears to be\unused in this method.\OK to remove it?' withCRs. 435597 self resume: index = 1! ! 435598MenuItemMorph subclass: #UpdatingMenuItemMorph 435599 instanceVariableNames: 'wordingProvider wordingSelector enablementSelector wordingArgument' 435600 classVariableNames: '' 435601 poolDictionaries: '' 435602 category: 'Morphic-Menus'! 435603!UpdatingMenuItemMorph commentStamp: '<historical>' prior: 0! 435604A menu item whose textual label and whose enablement are updatable. The wordingProvider provides the current wording, upon being being sent the wordingSelector. 435605 435606The item can also dynamically update whether or not it should be enabled; to do this, give it an enablementSelector, which is also sent to the wordingProvider..! 435607 435608 435609!UpdatingMenuItemMorph methodsFor: 'enablement' stamp: 'ajh 1/21/2003 13:17'! 435610enablement 435611 435612 enablementSelector isBlock 435613 ifTrue: [^ enablementSelector value] 435614 ifFalse: [enablementSelector numArgs = 0 435615 ifTrue: [^ wordingProvider perform: enablementSelector] 435616 ifFalse: [^ wordingProvider perform: enablementSelector 435617 withArguments: arguments]]! ! 435618 435619!UpdatingMenuItemMorph methodsFor: 'enablement' stamp: 'eem 7/21/2008 12:07'! 435620enablementSelector: aSelector 435621 enablementSelector := aSelector isBlock 435622 ifTrue: [aSelector copyForSaving] 435623 ifFalse: [aSelector] ! ! 435624 435625 435626!UpdatingMenuItemMorph methodsFor: 'stepping and presenter' stamp: 'ar 10/7/2000 15:35'! 435627arrangeToStartSteppingIn: aWorld 435628 super arrangeToStartSteppingIn: aWorld. 435629 self updateContents.! ! 435630 435631!UpdatingMenuItemMorph methodsFor: 'stepping and presenter' stamp: 'ar 10/7/2000 15:34'! 435632step 435633 super step. 435634 self updateContents.! ! 435635 435636 435637!UpdatingMenuItemMorph methodsFor: 'testing' stamp: 'sw 6/11/1999 18:31'! 435638stepTime 435639 ^ 1200! ! 435640 435641 435642!UpdatingMenuItemMorph methodsFor: 'wording' stamp: 'sw 11/6/2000 09:55'! 435643wordingArgument: anArgument 435644 "Set the receiver's wordingArgument as indicated" 435645 435646 wordingArgument := anArgument! ! 435647 435648!UpdatingMenuItemMorph methodsFor: 'wording' stamp: 'sw 6/11/1999 15:12'! 435649wordingProvider: aProvider wordingSelector: aSelector 435650 wordingProvider := aProvider. 435651 wordingSelector := aSelector! ! 435652 435653 435654!UpdatingMenuItemMorph methodsFor: 'world' stamp: 'nk 4/13/2004 15:38'! 435655updateContents 435656 "Update the receiver's contents" 435657 435658 | newString enablement nArgs | 435659 ((wordingProvider isNil) or: [wordingSelector isNil]) ifTrue: [^ self]. 435660 nArgs := wordingSelector numArgs. 435661 newString := nArgs == 0 435662 ifTrue: 435663 [wordingProvider perform: wordingSelector] 435664 ifFalse: 435665 [(nArgs == 1 and: [wordingArgument notNil]) 435666 ifTrue: 435667 [wordingProvider perform: wordingSelector with: wordingArgument] 435668 ifFalse: 435669 [nArgs == arguments size ifTrue: 435670 [wordingProvider perform: wordingSelector withArguments: arguments]]]. 435671 newString = (self contentString ifNil: [ contents ]) 435672 ifFalse: [self contents: newString. 435673 MenuIcons decorateMenu: owner ]. 435674 enablementSelector ifNotNil: 435675 [(enablement := self enablement) == isEnabled 435676 ifFalse: [self isEnabled: enablement]]! ! 435677MenuMorph subclass: #UpdatingMenuMorph 435678 instanceVariableNames: 'updater updateSelector' 435679 classVariableNames: '' 435680 poolDictionaries: '' 435681 category: 'Morphic-Menus'! 435682 435683!UpdatingMenuMorph methodsFor: 'initialization' stamp: 'sw 4/23/2001 11:02'! 435684updater: anObject updateSelector: aSelector 435685 "Set the receiver's updater and updateSelector" 435686 435687 updater := anObject. 435688 updateSelector := aSelector! ! 435689 435690 435691!UpdatingMenuMorph methodsFor: 'update' stamp: 'sw 4/23/2001 11:13'! 435692updateMenu 435693 "Reconstitute the menu by first removing the contents and then building it afresh" 435694 435695 self removeAllMorphs. 435696 updater perform: updateSelector with: self 435697 435698! ! 435699RectangleMorph subclass: #UpdatingRectangleMorph 435700 instanceVariableNames: 'target lastValue getSelector putSelector contents' 435701 classVariableNames: '' 435702 poolDictionaries: '' 435703 category: 'PreferenceBrowser'! 435704!UpdatingRectangleMorph commentStamp: '<historical>' prior: 0! 435705Intended for use as a color swatch coupled to a color obtained from the target, but made just slightly more general than that.! 435706 435707 435708!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 9/4/97 21:43'! 435709contents 435710 ^ contents! ! 435711 435712!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 9/4/97 21:43'! 435713contents: c 435714 contents := c! ! 435715 435716!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 1/6/2005 16:31'! 435717getSelector 435718 "Answer the getSelector" 435719 435720 ^ getSelector! ! 435721 435722!UpdatingRectangleMorph methodsFor: 'accessing'! 435723getSelector: aSymbol 435724 435725 getSelector := aSymbol. 435726! ! 435727 435728!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 10/30/97 00:55'! 435729putSelector 435730 ^ putSelector! ! 435731 435732!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 10/30/97 00:55'! 435733putSelector: aSymbol 435734 putSelector := aSymbol! ! 435735 435736!UpdatingRectangleMorph methodsFor: 'accessing'! 435737target 435738 435739 ^ target 435740! ! 435741 435742!UpdatingRectangleMorph methodsFor: 'accessing'! 435743target: anObject 435744 435745 target := anObject. 435746! ! 435747 435748!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 11/15/2001 16:22'! 435749userEditsAllowed 435750 "Answer whether it is suitable for a user to change the value represented by this readout" 435751 435752 ^ putSelector notNil! ! 435753 435754 435755!UpdatingRectangleMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 17:17'! 435756veryDeepFixupWith: deepCopier 435757 "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 435758 435759super veryDeepFixupWith: deepCopier. 435760target := deepCopier references at: target ifAbsent: [target].! ! 435761 435762!UpdatingRectangleMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 17:17'! 435763veryDeepInner: deepCopier 435764 "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." 435765 435766super veryDeepInner: deepCopier. 435767"target := target. Weakly copied" 435768lastValue := lastValue veryDeepCopyWith: deepCopier. 435769"getSelector := getSelector. a Symbol" 435770"putSelector := putSelector. a Symbol" 435771contents := contents veryDeepCopyWith: deepCopier.! ! 435772 435773 435774!UpdatingRectangleMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 18:45'! 435775handlesMouseDown: evt 435776 ^putSelector notNil! ! 435777 435778!UpdatingRectangleMorph methodsFor: 'event handling' stamp: 'ar 10/5/2000 18:54'! 435779mouseUp: evt 435780 435781 self changeColorTarget: self selector: #setTargetColor: originalColor: color hand: evt hand.! ! 435782 435783 435784!UpdatingRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'! 435785defaultBorderColor 435786 "answer the default border color/fill style for the receiver" 435787 ^ Color lightGray lighter! ! 435788 435789 435790!UpdatingRectangleMorph methodsFor: 'setting' stamp: 'sw 3/23/2001 23:26'! 435791setTargetColor: aColor 435792 "Set my target's color as indicated" 435793 435794 putSelector ifNotNil: 435795 [self color: aColor. 435796 contents := aColor. 435797 self valueProvider perform: self putSelector withArguments: (Array with: aColor)] 435798! ! 435799 435800!UpdatingRectangleMorph methodsFor: 'setting' stamp: 'HenrikSperreJohansen 9/10/2009 15:07'! 435801valueProvider 435802 "Answer the object to which my get/set messages should be sent. This is inefficient and contorted in order to support grandfathered content for an earlier design" 435803 435804 ^ target ! ! 435805 435806 435807!UpdatingRectangleMorph methodsFor: 'stepping and presenter' stamp: 'sw 7/15/1999 07:27'! 435808step 435809 | s | 435810 super step. 435811 s := self readFromTarget. 435812 s = contents ifFalse: 435813 [self contents: s. 435814 self color: s] 435815! ! 435816 435817 435818!UpdatingRectangleMorph methodsFor: 'target access' stamp: 'dgd 2/22/2003 14:40'! 435819readFromTarget 435820 "Read the color value from my target" 435821 435822 | v | 435823 (target isNil or: [getSelector isNil]) ifTrue: [^contents]. 435824 target isMorph ifTrue: [target isInWorld ifFalse: [^contents]]. 435825 v := self valueProvider perform: getSelector. 435826 lastValue := v. 435827 ^v! ! 435828 435829 435830!UpdatingRectangleMorph methodsFor: 'testing'! 435831stepTime 435832 435833 ^ 50! ! 435834SimpleButtonMorph subclass: #UpdatingSimpleButtonMorph 435835 instanceVariableNames: 'wordingProvider wordingSelector' 435836 classVariableNames: '' 435837 poolDictionaries: '' 435838 category: 'Morphic-Widgets'! 435839!UpdatingSimpleButtonMorph commentStamp: '<historical>' prior: 0! 435840Adds to SimpleButtonMorph the ability to keep its own wording up to date by send a given message (indicated by its wordingSelector) to a given object (indicated by its wordingTarget, and normally the same as its target.)! 435841 435842 435843!UpdatingSimpleButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 6/11/1999 18:30'! 435844wordingSelector: aSelector 435845 wordingSelector := aSelector. 435846 wordingProvider ifNil: [wordingProvider := target]! ! 435847 435848 435849!UpdatingSimpleButtonMorph methodsFor: 'stepping and presenter' stamp: 'sw 10/30/2000 08:56'! 435850step 435851 "If appropriate update the receiver's label" 435852 435853 | newString | 435854 super step. 435855 wordingProvider ifNotNil: 435856 [newString := wordingProvider perform: wordingSelector. 435857 newString = self label ifFalse: [self labelString: newString; changed]]! ! 435858 435859 435860!UpdatingSimpleButtonMorph methodsFor: 'testing' stamp: 'sw 10/30/2000 08:57'! 435861stepTime 435862 "Answer the desired time between steps in milliseconds. If the receiver has a wordingProvider that may dynamically provide changed wording for the label, step once every 1.5 seconds" 435863 435864 ^ wordingProvider ifNotNil: [1500] ifNil: [super stepTime]! ! 435865 435866!UpdatingSimpleButtonMorph methodsFor: 'testing' stamp: 'sw 10/30/2000 08:55'! 435867wantsSteps 435868 "Answer whether the receiver wishes to be sent the #step message. In the current case, this decision depends on whether there is a wordingProvider which can dynamically provide fresh wording for the button's label" 435869 435870 ^ wordingProvider notNil! ! 435871StringMorph subclass: #UpdatingStringMorph 435872 instanceVariableNames: 'format target lastValue getSelector putSelector floatPrecision growable stepTime autoAcceptOnFocusLoss minimumWidth maximumWidth' 435873 classVariableNames: '' 435874 poolDictionaries: '' 435875 category: 'Morphic-Widgets'! 435876!UpdatingStringMorph commentStamp: 'marcus.denker 9/14/2008 19:03' prior: 0! 435877A StringMorph that constantly tries to show the current data from the target object. When sent #step, it shows what the target objects has (target perform: getSelector). When edited (with shift-click), it writes back to the target. 435878 435879floatPrecision = 1. to round to integer. 435880floatPrecision = .1 to round to 1 decimal place, etc. 435881 435882Even when ((target isNil) or: [getSelector == nil]), the user would still like to edit the string with shift-click.! 435883 435884 435885!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/9/1999 16:47'! 435886autoAcceptOnFocusLoss 435887 ^ autoAcceptOnFocusLoss ~~ false! ! 435888 435889!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/8/1999 10:45'! 435890autoAcceptOnFocusLoss: aBoolean 435891 autoAcceptOnFocusLoss := aBoolean! ! 435892 435893!UpdatingStringMorph methodsFor: 'accessing' stamp: 'aoy 2/17/2003 01:15'! 435894contents: newContents 435895 "This is the original StringMorph implementation of #contents:, restored down in UpdatingStringMorph because a recent 'optimization' of the StringMorph version of this method broke UpdatingStringMorphs." 435896 435897 contents := newContents isText 435898 ifTrue: 435899 [emphasis := newContents emphasisAt: 1. 435900 newContents string] 435901 ifFalse: 435902 [contents = newContents ifTrue: [^self]. "no substantive change" 435903 newContents]. 435904 self fitContents. 435905 self changed! ! 435906 435907!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/13/2002 17:55'! 435908decimalPlaces 435909 "Answer the number of decimal places to show." 435910 435911 | places | 435912 (places := self valueOfProperty: #decimalPlaces) ifNotNil: [^ places]. 435913 self setProperty: #decimalPlaces toValue: (places := Utilities decimalPlacesForFloatPrecision: self floatPrecision). 435914 ^ places! ! 435915 435916!UpdatingStringMorph methodsFor: 'accessing' stamp: 'stephane.ducasse 11/27/2008 21:43'! 435917decimalPlaces: aNumber 435918 "Set the receiver's number of decimal places to be shown. If my target is a morph or a player, tell it about the change, in case it wants to remember it." 435919 435920 | constrained | 435921 self setProperty: #decimalPlaces toValue: (constrained := aNumber min: 11). 435922 self pvtFloatPrecision: (Utilities floatPrecisionForDecimalPlaces: constrained). 435923 (target isKindOf: Morph) ifTrue: 435924 [target noteDecimalPlaces: constrained forGetter: getSelector]! ! 435925 435926!UpdatingStringMorph methodsFor: 'accessing' stamp: 'ar 12/30/2001 20:48'! 435927fitContents 435928 435929 | newExtent f | 435930 f := self fontToUse. 435931 newExtent := (((f widthOfString: contents) max: self minimumWidth) min: self maximumWidth) @ f height. 435932 (self extent = newExtent) ifFalse: 435933 [self extent: newExtent. 435934 self changed] 435935! ! 435936 435937!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 7/27/2001 18:20'! 435938floatPrecision 435939 "Answer the floatPrecision to use: 435940 1.0 -> show whole number 435941 0.1 -> show one digit of precision 435942 .01 -> show two digits of precision 435943 etc. 435944 Initialize the floatPrecision to 1 if it is not already defined" 435945 435946 floatPrecision isNumber ifFalse: 435947 [self target: target]. "Fixes up errant cases from earlier bug" 435948 ^ floatPrecision 435949! ! 435950 435951!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/11/2002 14:44'! 435952format 435953 "Answer the receiver's format: #default or #string" 435954 435955 ^ format ifNil: [format := #default]! ! 435956 435957!UpdatingStringMorph methodsFor: 'accessing'! 435958getSelector 435959 435960 ^ getSelector 435961! ! 435962 435963!UpdatingStringMorph methodsFor: 'accessing'! 435964getSelector: aSymbol 435965 435966 getSelector := aSymbol. 435967! ! 435968 435969!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 5/26/1999 16:21'! 435970growable 435971 435972 ^ growable ~~ false 435973! ! 435974 435975!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 5/26/1999 16:22'! 435976growable: aBoolean 435977 435978 growable := aBoolean. 435979! ! 435980 435981!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/10/1999 10:07'! 435982maximumWidth 435983 "Answer the maximum width that the receiver can have. A nil value means no maximum, and for practical purposes results in a value of 99999 here temporarily, for help in future debugging" 435984 435985 ^ maximumWidth ifNil: [99999]! ! 435986 435987!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/10/1999 09:59'! 435988minimumWidth 435989 "Answer the minimum width that the receiver can have. A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!! Obeyed by fitContents." 435990 435991 ^ minimumWidth ifNil: [minimumWidth := 8]! ! 435992 435993!UpdatingStringMorph methodsFor: 'accessing' stamp: 'tk 12/1/2000 15:08'! 435994minimumWidth: aWidth 435995 "Set the minimum width that the receiver can have. A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!! Obeyed by fitContents." 435996 435997 minimumWidth := aWidth! ! 435998 435999!UpdatingStringMorph methodsFor: 'accessing'! 436000putSelector 436001 436002 ^ putSelector 436003! ! 436004 436005!UpdatingStringMorph methodsFor: 'accessing'! 436006putSelector: aSymbol 436007 436008 putSelector := aSymbol. 436009! ! 436010 436011!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/13/2002 17:58'! 436012pvtFloatPrecision: aNumber 436013 "Private - Set the floatPrecision instance variable to the given number" 436014 436015 floatPrecision := aNumber! ! 436016 436017!UpdatingStringMorph methodsFor: 'accessing'! 436018target 436019 436020 ^ target 436021! ! 436022 436023!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 3/11/2000 20:05'! 436024target: anObject 436025 436026 target := anObject. 436027 getSelector ifNotNil: [floatPrecision := anObject defaultFloatPrecisionFor: getSelector] 436028! ! 436029 436030!UpdatingStringMorph methodsFor: 'accessing' stamp: 'marcus.denker 12/12/2008 19:05'! 436031valueFromContents 436032 "Return a new value from the current contents string." 436033 436034 format = #symbol ifTrue: [^ lastValue]. 436035 format = #string ifTrue: [^ contents]. 436036 ^ Compiler evaluate: contents 436037! ! 436038 436039 436040!UpdatingStringMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 15:37'! 436041veryDeepFixupWith: deepCopier 436042 "If target field is weakly copied, fix it here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" 436043 436044super veryDeepFixupWith: deepCopier. 436045target := deepCopier references at: target ifAbsent: [target]. 436046! ! 436047 436048!UpdatingStringMorph methodsFor: 'copying' stamp: 'tk 9/26/2001 05:09'! 436049veryDeepInner: deepCopier 436050 "Copy all of my instance variables. Some need to be not copied at all, but shared." 436051 436052 super veryDeepInner: deepCopier. 436053 format := format veryDeepCopyWith: deepCopier. 436054 target := target. "Weakly copied" 436055 lastValue := lastValue veryDeepCopyWith: deepCopier. 436056 getSelector := getSelector. "Symbol" 436057 putSelector := putSelector. "Symbol" 436058 floatPrecision := floatPrecision veryDeepCopyWith: deepCopier. 436059 growable := growable veryDeepCopyWith: deepCopier. 436060 stepTime := stepTime veryDeepCopyWith: deepCopier. 436061 autoAcceptOnFocusLoss := autoAcceptOnFocusLoss veryDeepCopyWith: deepCopier. 436062 minimumWidth := minimumWidth veryDeepCopyWith: deepCopier. 436063 maximumWidth := maximumWidth veryDeepCopyWith: deepCopier. 436064! ! 436065 436066 436067!UpdatingStringMorph methodsFor: 'editing'! 436068acceptContents 436069 436070 self informTarget. 436071! ! 436072 436073!UpdatingStringMorph methodsFor: 'editing' stamp: 'stephane.ducasse 10/28/2008 18:18'! 436074acceptValue: aValue 436075 436076 self updateContentsFrom: (self acceptValueFromTarget: aValue). 436077! ! 436078 436079!UpdatingStringMorph methodsFor: 'editing' stamp: 'dgd 8/30/2003 22:21'! 436080addCustomMenuItems: menu hand: aHandMorph 436081 | prefix | 436082 super addCustomMenuItems: menu hand: aHandMorph. 436083 prefix := (self growable 436084 ifTrue: ['stop being growable'] 436085 ifFalse: ['start being growable']) translated. 436086 menu add: prefix action: #toggleGrowability. 436087 menu add: 'decimal places...' translated action: #setPrecision. 436088 menu add: 'font size...' translated action: #setFontSize. 436089 menu add: 'font style...' translated action: #setFontStyle! ! 436090 436091!UpdatingStringMorph methodsFor: 'editing' stamp: 'nk 1/11/2004 15:29'! 436092doneWithEdits 436093 "If in a SyntaxMorph, shrink min width after editing" 436094 436095 | editor | 436096 super doneWithEdits. 436097 (owner respondsTo: #parseNode) ifTrue: [minimumWidth := 8]. 436098 editor := (submorphs detect: [ :sm | sm isKindOf: StringMorphEditor ] ifNone: [ ^self ]). 436099 editor delete.! ! 436100 436101!UpdatingStringMorph methodsFor: 'editing' stamp: 'tk 11/29/2000 13:54'! 436102lostFocusWithoutAccepting 436103 "The message is sent when the user, having been in an editing episode on the receiver, changes the keyboard focus -- typically by clicking on some editable text somewhere else -- without having accepted the current edits." 436104 436105 self autoAcceptOnFocusLoss ifTrue: [self doneWithEdits; acceptContents]! ! 436106 436107!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 9/11/2002 09:57'! 436108setDecimalPlaces: places 436109 "Set the number of decimal places, and update the display." 436110 436111 self decimalPlaces: places. 436112 self acceptValueFromTarget: lastValue! ! 436113 436114!UpdatingStringMorph methodsFor: 'editing' stamp: 'alain.plantec 2/6/2009 17:39'! 436115setFontSize 436116 | sizes reply family | 436117 family := font 436118 ifNil: [TextStyle default] 436119 ifNotNil: [font textStyle]. 436120 family 436121 ifNil: [family := TextStyle default]. 436122 "safety net -- this line SHOULD be unnecessary now " 436123 sizes := family fontNamesWithPointSizes. 436124 reply := UIManager default chooseFrom: sizes values: sizes. 436125 reply 436126 ifNotNil: [self 436127 font: (family 436128 fontAt: (sizes indexOf: reply))]! ! 436129 436130!UpdatingStringMorph methodsFor: 'editing' stamp: 'alain.plantec 2/6/2009 17:40'! 436131setFontStyle 436132 | aList reply style | 436133 aList := (TextConstants select: [:anItem | anItem isKindOf: TextStyle]) 436134 keys asOrderedCollection. 436135 reply := UIManager default chooseFrom: aList values: aList. 436136 reply ifNotNil: 436137 [(style := TextStyle named: reply) ifNil: 436138 [Beeper beep. 436139 ^true]. 436140 self font: style defaultFont]! ! 436141 436142!UpdatingStringMorph methodsFor: 'editing' stamp: 'dgd 10/17/2003 22:50'! 436143setPrecision 436144 "Allow the user to specify a number of decimal places. This UI is invoked from a menu. Nowadays the precision can be set by simple type-in, making this menu approach mostly obsolete. However, it's still useful for read-only readouts, where type-in is not allowed." 436145 436146 | aMenu | 436147 aMenu := MenuMorph new. 436148 aMenu addTitle: ('How many decimal places? (currently {1})' translated format: {self decimalPlaces}). 436149 0 to: 5 do: 436150 [:places | 436151 aMenu add: places asString target: self selector: #setDecimalPlaces: argument: places]. 436152 aMenu popUpInWorld! ! 436153 436154!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 11/15/2001 20:20'! 436155setToAllowTextEdit 436156 "Set up the receiver so that it will be receptive to text editing, even if there is no putSelector provided" 436157 436158 self setProperty: #okToTextEdit toValue: true! ! 436159 436160!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 6/26/1998 07:47'! 436161toggleGrowability 436162 growable := self growable not. 436163 self updateContentsFrom: self readFromTarget. 436164 growable ifTrue: [self fitContents]! ! 436165 436166!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 11/15/2001 09:43'! 436167userEditsAllowed 436168 "Answer whether user-edits are allowed to this field" 436169 436170 ^ putSelector notNil or: [self hasProperty: #okToTextEdit]! ! 436171 436172 436173!UpdatingStringMorph methodsFor: 'event handling' stamp: 'ar 10/6/2000 00:17'! 436174handlesMouseDown: evt 436175 (owner wantsKeyboardFocusFor: self) 436176 ifTrue:[^true]. 436177 ^ super handlesMouseDown: evt! ! 436178 436179!UpdatingStringMorph methodsFor: 'event handling' stamp: 'sw 11/15/2001 10:15'! 436180mouseDown: evt 436181 "The mouse went down over the receiver. If appropriate, launch a mini-editor so that the user can commence text-editing here" 436182 436183 (owner wantsKeyboardFocusFor: self) ifTrue: 436184 [self userEditsAllowed ifTrue: 436185 [(owner respondsTo: #parseNode) 436186 ifTrue: "leave space for editing" 436187 [minimumWidth := (49 max: minimumWidth)]. 436188 self launchMiniEditor: evt]]! ! 436189 436190!UpdatingStringMorph methodsFor: 'event handling' stamp: 'sw 5/6/1998 12:59'! 436191wouldAcceptKeyboardFocus 436192 ^ (self hasProperty: #okToTextEdit) or: [super wouldAcceptKeyboardFocus]! ! 436193 436194 436195!UpdatingStringMorph methodsFor: 'events-processing' stamp: 'sw 11/15/2001 18:17'! 436196handlerForMouseDown: evt 436197 "Answer an object to field the mouseDown event provided, or nil if none" 436198 436199 | aHandler | 436200 aHandler := super handlerForMouseDown: evt. 436201 aHandler == self ifTrue: [^ self]. "I would get it anyways" 436202 "Note: This is a hack to allow value editing in viewers" 436203 ((owner wantsKeyboardFocusFor: self) and: 436204 [self userEditsAllowed]) ifTrue: [^ self]. 436205 ^ aHandler! ! 436206 436207 436208!UpdatingStringMorph methodsFor: 'formats'! 436209useDefaultFormat 436210 "Use the object's own printString format." 436211 436212 format := #default. 436213! ! 436214 436215!UpdatingStringMorph methodsFor: 'formats'! 436216useStringFormat 436217 436218 format := #string.! ! 436219 436220!UpdatingStringMorph methodsFor: 'formats' stamp: 'yo 1/12/2005 14:28'! 436221useSymbolFormat 436222 436223 format := #symbol.! ! 436224 436225 436226!UpdatingStringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:44'! 436227initialize 436228 "Initialie the receiver to have default values in its instance 436229 variables " 436230 super initialize. 436231"" 436232 format := #default. 436233 "formats: #string, #default" 436234 target := getSelector := putSelector := nil. 436235 floatPrecision := 1. 436236 growable := true. 436237 stepTime := 50. 436238 autoAcceptOnFocusLoss := true. 436239 minimumWidth := 8. 436240 maximumWidth := 300! ! 436241 436242 436243!UpdatingStringMorph methodsFor: 'stepping' stamp: 'jm 5/26/1999 16:23'! 436244stepTime: mSecsPerStep 436245 436246 stepTime := mSecsPerStep truncated. 436247! ! 436248 436249!UpdatingStringMorph methodsFor: 'stepping' stamp: 'sw 6/26/1998 07:31'! 436250updateContentsFrom: aValue 436251 self growable 436252 ifTrue: 436253 [self contents: aValue] 436254 ifFalse: 436255 [self contentsClipped: aValue]! ! 436256 436257 436258!UpdatingStringMorph methodsFor: 'stepping and presenter' stamp: 'sw 7/15/1999 07:28'! 436259step 436260 | s | 436261 super step. 436262 hasFocus ifFalse: 436263 ["update contents, but only if user isn't editing this string" 436264 s := self readFromTarget. 436265 s = contents ifFalse: 436266 [self updateContentsFrom: s]] 436267! ! 436268 436269 436270!UpdatingStringMorph methodsFor: 'target access' stamp: 'sw 3/10/2005 01:53'! 436271acceptValueFromTarget: v 436272 "Accept a value from the target" 436273 436274 lastValue := v. 436275 self format == #string ifTrue: [^ v asString]. 436276 self format == #symbol ifTrue: [^ v asString translated]. 436277 (format == #default and: [v isNumber]) ifTrue: 436278 [^ self stringForNumericValue: v]. 436279 ^ v printString translated! ! 436280 436281!UpdatingStringMorph methodsFor: 'target access' stamp: 'yo 6/7/2004 21:35'! 436282checkTarget 436283 "" 436284 getSelector ifNil: [^ true]. 436285 ^ getSelector numArgs = 0. 436286! ! 436287 436288!UpdatingStringMorph methodsFor: 'target access' stamp: 'dgd 2/22/2003 19:01'! 436289informTarget 436290 "Obtain a value from my contents, and tell my target about it. The putSelector can take one argument (traditional) or two (as used by Croquet)" 436291 436292 | newValue typeIn | 436293 (target notNil and: [putSelector notNil]) 436294 ifTrue: 436295 [typeIn := contents. 436296 (newValue := self valueFromContents) ifNotNil: 436297 [self checkTarget. 436298 putSelector numArgs = 1 436299 ifTrue: [target perform: putSelector with: newValue]. 436300 putSelector numArgs = 2 436301 ifTrue: 436302 [target 436303 perform: putSelector 436304 with: newValue 436305 with: self]. 436306 target isMorph ifTrue: [target changed]]. 436307 self fitContents. 436308 (format == #default and: [newValue isNumber]) 436309 ifTrue: [self setDecimalPlacesFromTypeIn: typeIn]]! ! 436310 436311!UpdatingStringMorph methodsFor: 'target access' stamp: 'yo 6/9/2004 07:09'! 436312readFromTarget 436313 "Update my readout from my target" 436314 436315 | v ret | 436316 (target isNil or: [getSelector isNil]) ifTrue: [^contents]. 436317 ret := self checkTarget. 436318 ret ifFalse: [^ '0']. 436319 v := target perform: getSelector. "scriptPerformer" 436320 (v isKindOf: Text) ifTrue: [v := v asString]. 436321 ^self acceptValueFromTarget: v! ! 436322 436323!UpdatingStringMorph methodsFor: 'target access' stamp: 'sw 3/3/2005 02:55'! 436324setDecimalPlacesFromTypeIn: typeIn 436325 "The user has typed in a number as the new value of the receiver. Glean off decimal-places-preference from the type-in" 436326 436327 | decimalPointPosition tail places | 436328 (typeIn includes: $e) ifTrue: [^ self]. 436329 decimalPointPosition := typeIn indexOf: $. ifAbsent: [nil]. 436330 places := 0. 436331 decimalPointPosition 436332 ifNotNil: 436333 [tail := typeIn copyFrom: decimalPointPosition + 1 to: typeIn size. 436334 [places < tail size and: [(tail at: (places + 1)) isDigit]] 436335 whileTrue: 436336 [places := places + 1]]. 436337 436338 self decimalPlaces: places! ! 436339 436340!UpdatingStringMorph methodsFor: 'target access' stamp: 'sw 3/3/2005 02:53'! 436341stringForNumericValue: aValue 436342 "Answer a suitably-formatted string representing the value." 436343 436344 | barePrintString | 436345 ((barePrintString := aValue printString) includes: $e) ifTrue: [^ barePrintString]. 436346 ^ aValue printShowingDecimalPlaces: self decimalPlaces! ! 436347 436348 436349!UpdatingStringMorph methodsFor: 'testing' stamp: 'jm 5/26/1999 16:17'! 436350stepTime 436351 436352 ^ stepTime ifNil: [50] 436353! ! 436354 436355 436356!UpdatingStringMorph methodsFor: 'watchIt' stamp: 'hfm 1/11/2009 10:41'! 436357maximumWidth: aNumber 436358 " Set the maximum width that the receiver can have. 436359 A nil value means no maximum, and for practical purposes 436360 results in a value of 99999 here temporarily, for help in future debugging" 436361 436362 maximumWidth := aNumber! ! 436363 436364"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 436365 436366UpdatingStringMorph class 436367 instanceVariableNames: ''! 436368 436369!UpdatingStringMorph class methodsFor: 'instance creation' stamp: 'sw 3/10/2000 17:27'! 436370on: targetObject selector: aSymbol 436371 436372 ^ self new 436373 getSelector: aSymbol; 436374 target: targetObject 436375 436376! ! 436377ThreePhaseButtonMorph subclass: #UpdatingThreePhaseButtonMorph 436378 instanceVariableNames: 'getSelector' 436379 classVariableNames: '' 436380 poolDictionaries: '' 436381 category: 'Morphic-Widgets'! 436382 436383!UpdatingThreePhaseButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 3/8/1999 13:50'! 436384getSelector: sel 436385 getSelector := sel! ! 436386 436387 436388!UpdatingThreePhaseButtonMorph methodsFor: 'button' stamp: 'bf 10/8/1999 15:08'! 436389doButtonAction 436390 "Since the action likely changes our state, do a step so we're updated immediately" 436391 super doButtonAction. 436392 self step 436393! ! 436394 436395 436396!UpdatingThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'bf 10/14/1999 21:11'! 436397mouseUp: evt 436398 "Since mouseUp likely changes our state, do a step so we're updated immediately" 436399 super mouseUp: evt. 436400 self step! ! 436401 436402 436403!UpdatingThreePhaseButtonMorph methodsFor: 'stepping and presenter' stamp: 'tk 7/14/2000 15:27'! 436404step 436405 | newBoolean | 436406 super step. 436407 state == #pressed ifTrue: [^ self]. 436408 newBoolean := target perform: getSelector. 436409 newBoolean == self isOn 436410 ifFalse: 436411 [self state: (newBoolean == true ifTrue: [#on] ifFalse: [#off])]! ! 436412 436413 436414!UpdatingThreePhaseButtonMorph methodsFor: 'testing' stamp: 'sw 3/8/1999 13:50'! 436415wantsSteps 436416 ^ true! ! 436417Object subclass: #Url 436418 instanceVariableNames: 'fragment' 436419 classVariableNames: '' 436420 poolDictionaries: '' 436421 category: 'Network-Url'! 436422!Url commentStamp: '<historical>' prior: 0! 436423A Uniform Resource Locator. It specifies the location of a document on the Internet. The base class is abstract; child classes break different types of URLs down in ways appropriate for that type.! 436424 436425 436426!Url methodsFor: 'accessing' stamp: 'mir 2/22/2000 18:05'! 436427authority 436428 ^''! ! 436429 436430 436431!Url methodsFor: 'classification' stamp: 'ar 2/27/2001 22:07'! 436432hasRemoteContents 436433 "Return true if the receiver describes some remotely accessible content. 436434 Typically, this should only return if we could retrieve the contents 436435 on an arbitrary place in the outside world using a standard browser. 436436 In other words: If you can get to it from the next Internet Cafe, 436437 return true, else return false." 436438 ^false! ! 436439 436440!Url methodsFor: 'classification' stamp: 'ls 6/16/1998 16:22'! 436441scheme 436442 "return a string with the scheme of this URL. For instance, HTTP" 436443 ^self subclassResponsibility! ! 436444 436445!Url methodsFor: 'classification' stamp: 'ls 7/3/1998 21:11'! 436446schemeName 436447 "return a lowercase string with the scheme of this URL. For instance, 'http'" 436448 ^self subclassResponsibility! ! 436449 436450 436451!Url methodsFor: 'converting' stamp: 'ls 7/14/1998 03:17'! 436452asText 436453 ^self asString asText! ! 436454 436455!Url methodsFor: 'converting' stamp: 'tb 5/24/2006 22:05'! 436456asURI 436457 ^self asString asURI! ! 436458 436459!Url methodsFor: 'converting' stamp: 'ls 6/29/1998 00:36'! 436460asUrl 436461 ^self! ! 436462 436463!Url methodsFor: 'converting' stamp: 'ls 7/3/1998 21:11'! 436464asUrlRelativeTo: aUrl 436465 ^self! ! 436466 436467!Url methodsFor: 'converting' stamp: 'fbs 2/2/2005 13:24'! 436468downloadUrl 436469 ^self asString! ! 436470 436471 436472!Url methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:41'! 436473activate 436474 "spawn an external handler for this URL" 436475 ! ! 436476 436477!Url methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:40'! 436478hasContents 436479 "whether this URL can download contents to be displayed; if not, it fundamentally requires an outside application to deal with it. For example, mailto: and telnet: urls" 436480 ^false! ! 436481 436482!Url methodsFor: 'downloading' stamp: 'ls 7/23/1998 20:14'! 436483retrieveContents 436484 "return a MIMEObject with the object's contents, or nil if the object could not be retrieved" 436485 ^nil! ! 436486 436487!Url methodsFor: 'downloading' stamp: 'ls 7/23/1998 20:14'! 436488retrieveContentsForBrowser: aBrowser 436489 "return a MIMEObject with the object's contents, or nil if the object could not be retrieved. Since aBrowser is specified, this could do browser specific things" 436490 ^self retrieveContents! ! 436491 436492 436493!Url methodsFor: 'fragment' stamp: 'ls 8/4/1998 01:41'! 436494fragment 436495 ^fragment! ! 436496 436497!Url methodsFor: 'fragment' stamp: 'ls 8/4/1998 01:02'! 436498privateFragment: aString 436499 fragment := aString! ! 436500 436501!Url methodsFor: 'fragment' stamp: 'ls 6/1/2000 16:19'! 436502withFragment: newFragment 436503 "return a URL which is the same except that it has a different fragment" 436504 ^self copy privateFragment: newFragment; yourself! ! 436505 436506!Url methodsFor: 'fragment' stamp: 'ls 6/1/2000 16:26'! 436507withoutFragment 436508 "return a URL which is identical to the receiver except that it has no fragment associated with it" 436509 ^self withFragment: nil! ! 436510 436511 436512!Url methodsFor: 'parsing' stamp: 'marcus.denker 9/14/2008 21:11'! 436513newFromRelativeText: aString 436514 "return a URL relative to the current one, given by aString. For instance, if self is 'http://host/dir/file', and aString is '/dir2/file2', then the return will be a Url for 'http://host/dir2/file2'" 436515 436516 "if the scheme is the same, or not specified, then use the same class" 436517 436518 | newSchemeName remainder fragmentStart newFragment newUrl bare | 436519 436520 bare := aString withBlanksTrimmed. 436521 newSchemeName := Url schemeNameForString: bare. 436522 (newSchemeName notNil and: [ newSchemeName ~= self schemeName ]) ifTrue: [ 436523 "different scheme -- start from scratch" 436524 ^Url absoluteFromText: aString ]. 436525 436526 remainder := bare. 436527 436528 "remove the fragment, if any" 436529 fragmentStart := remainder indexOf: $#. 436530 fragmentStart > 0 ifTrue: [ 436531 newFragment := remainder copyFrom: fragmentStart+1 to: remainder size. 436532 remainder := remainder copyFrom: 1 to: fragmentStart-1]. 436533 436534 "remove the scheme name" 436535 newSchemeName ifNotNil: [ 436536 remainder := remainder copyFrom: (newSchemeName size + 2) to: remainder size ]. 436537 436538 "create and initialize the new url" 436539 newUrl := self class new privateInitializeFromText: remainder relativeTo: self. 436540 436541 436542 "set the fragment" 436543 newUrl privateFragment: newFragment. 436544 436545 436546 ^newUrl! ! 436547 436548!Url methodsFor: 'parsing' stamp: 'ls 8/4/1998 00:50'! 436549privateInitializeFromText: aString 436550 ^self subclassResponsibility! ! 436551 436552!Url methodsFor: 'parsing' stamp: 'ls 8/4/1998 00:55'! 436553privateInitializeFromText: aString relativeTo: aUrl 436554 "initialize from the given string, as a relative URL. aString will have had the scheme name removed, if it was present to begin with. If it was, then the scheme name was the same as the receiver's scheme name" 436555 436556 "by default, just do regular initialization" 436557 ^self privateInitializeFromText: aString! ! 436558 436559 436560!Url methodsFor: 'printing' stamp: 'fbs 2/2/2005 13:26'! 436561printOn: aStream 436562 ^self subclassResponsibility! ! 436563 436564!Url methodsFor: 'printing' stamp: 'KLC 10/20/2005 15:37'! 436565toText 436566 self deprecated: 'Use Url>>asText instead'. 436567 ^ self asString.! ! 436568 436569"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 436570 436571Url class 436572 instanceVariableNames: ''! 436573 436574!Url class methodsFor: 'parsing' stamp: 'gk 10/21/2005 10:45'! 436575absoluteFromFileNameOrUrlString: aString 436576 "Return a URL from and handle Strings without schemes 436577 as local relative FileUrls instead of defaulting to a HttpUrl 436578 as absoluteFromText: does." 436579 436580 ^(Url schemeNameForString: aString) 436581 ifNil: [aString asUrlRelativeTo: FileDirectory default asUrl] 436582 ifNotNil: [Url absoluteFromText: aString]! ! 436583 436584!Url class methodsFor: 'parsing' stamp: 'gk 10/21/2005 10:47'! 436585absoluteFromText: aString 436586 "Return a URL from a string and handle 436587 a String without a scheme as a HttpUrl." 436588 436589 "Url absoluteFromText: 'http://chaos.resnet.gatech.edu:8000/docs/java/index.html?A%20query%20#part'" 436590 "Url absoluteFromText: 'msw://chaos.resnet.gatech.edu:9000/testbook?top'" 436591 "Url absoluteFromText: 'telnet:chaos.resnet.gatech.edu'" 436592 "Url absoluteFromText: 'file:/etc/passwd'" 436593 436594 | remainder index scheme fragment newUrl | 436595 "trim surrounding whitespace" 436596 remainder := aString withBlanksTrimmed. 436597 436598 "extract the fragment, if any" 436599 index := remainder indexOf: $#. 436600 index > 0 ifTrue: [ 436601 fragment := remainder copyFrom: index + 1 to: remainder size. 436602 remainder := remainder copyFrom: 1 to: index - 1]. 436603 436604 "choose class based on the scheme name, and let that class do the bulk of the parsing" 436605 scheme := self schemeNameForString: remainder. 436606 newUrl := (self urlClassForScheme: scheme) new privateInitializeFromText: remainder. 436607 newUrl privateFragment: fragment. 436608 ^newUrl! ! 436609 436610!Url class methodsFor: 'parsing' stamp: 'st 9/27/2004 15:47'! 436611combine: baseURL withRelative: relURL 436612 "Take two URL as string form, combine them and return the corresponding URL in string form" 436613 436614 ^((self absoluteFromText: baseURL) newFromRelativeText: relURL) asString! ! 436615 436616!Url class methodsFor: 'parsing' stamp: 'gk 10/21/2005 10:41'! 436617schemeNameForString: aString 436618 "Get the scheme name from a string, or return nil if it's not specified. 436619 Used in internal parsing routines - an outsider may as well use asUrl. 436620 Return scheme in lowercases." 436621 436622 "Url schemeNameForString: 'http://www.yahoo.com'" 436623 "Url schemeNameForString: '/etc/passwed'" 436624 "Url schemeNameForString: '/etc/testing:1.2.3'" 436625 436626 | index schemeName | 436627 index := aString indexOf: $: ifAbsent: [^ nil]. 436628 schemeName := aString first: index - 1. 436629 (schemeName allSatisfy: [:each | each isLetter]) ifFalse: [^ nil]. 436630 ^ schemeName asLowercase! ! 436631 436632!Url class methodsFor: 'parsing' stamp: 'gk 10/21/2005 09:28'! 436633urlClassForScheme: scheme 436634 (scheme isNil or: [scheme = 'http']) ifTrue: [^HttpUrl]. 436635 scheme = 'ftp' ifTrue: [^FtpUrl]. 436636 scheme = 'file' ifTrue: [^FileUrl]. 436637 scheme = 'mailto' ifTrue: [^MailtoUrl]. 436638 scheme = 'browser' ifTrue: [^BrowserUrl]. 436639 ^GenericUrl! ! 436640OrderedCollection subclass: #UrlArgumentList 436641 instanceVariableNames: '' 436642 classVariableNames: '' 436643 poolDictionaries: '' 436644 category: 'Network-Url'! 436645 436646!UrlArgumentList methodsFor: 'adding' stamp: 'mir 7/27/1999 16:19'! 436647add: argName value: argValue 436648 | argAssociation | 436649 argAssociation := self argumentNamed: argName. 436650 argAssociation isNil 436651 ifTrue: [self add: (argName -> (OrderedCollection with: argValue))] 436652 ifFalse: [argAssociation value add: argValue]! ! 436653 436654 436655!UrlArgumentList methodsFor: 'enumerating' stamp: 'mir 7/27/1999 16:01'! 436656associationsDo: aBlock 436657 self do: [:each | 436658 aBlock value: each]! ! 436659 436660 436661!UrlArgumentList methodsFor: 'private' stamp: 'mir 7/27/1999 16:20'! 436662argumentNamed: argName 436663 ^self 436664 detect: [:each | each key = argName] 436665 ifNone: [nil]! ! 436666 436667"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 436668 436669UrlArgumentList class 436670 instanceVariableNames: ''! 436671 436672!UrlArgumentList class methodsFor: 'instance creation' stamp: 'mir 7/27/1999 16:25'! 436673with: argAssoc 436674 | argList | 436675 argList := self new. 436676 argList add: argAssoc key value: argAssoc value. 436677 ^argList! ! 436678 436679!UrlArgumentList class methodsFor: 'instance creation' stamp: 'mir 7/27/1999 16:26'! 436680with: firstArgAssoc with: secondArgAssoc 436681 | argList | 436682 argList := self with: firstArgAssoc. 436683 argList add: secondArgAssoc key value: secondArgAssoc value. 436684 ^argList! ! 436685 436686!UrlArgumentList class methodsFor: 'instance creation' stamp: 'mir 7/27/1999 16:26'! 436687with: firstArgAssoc with: secondArgAssoc with: thirdArgAssoc 436688 | argList | 436689 argList := self with: firstArgAssoc with: secondArgAssoc. 436690 argList add: thirdArgAssoc key value: thirdArgAssoc value. 436691 ^argList! ! 436692ClassTestCase subclass: #UrlTest 436693 instanceVariableNames: 'url baseUrl expected string' 436694 classVariableNames: '' 436695 poolDictionaries: '' 436696 category: 'NetworkTests-Url'! 436697!UrlTest commentStamp: '<historical>' prior: 0! 436698This is the unit test for the class Url. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 436699 - http://www.c2.com/cgi/wiki?UnitTest 436700 - http://minnow.cc.gatech.edu/squeak/1547 436701 - the sunit class category! 436702 436703 436704!UrlTest methodsFor: 'testing' stamp: 'bp 2/12/2005 20:21'! 436705testFromFileNameOrUrlString 436706 436707 url := Url absoluteFromFileNameOrUrlString: 'asdf'. 436708 self assert: url schemeName = 'file'. 436709 self assert: url fragment isNil. 436710 self assert: url class = FileUrl. 436711 436712 url := Url absoluteFromFileNameOrUrlString: 'http://209.143.91.36/super/SuperSwikiProj/AAEmptyTest.001.pr'. 436713 self assert: url schemeName = 'http'. 436714 self assert: url fragment isNil. 436715 self assert: url class = HttpUrl.! ! 436716 436717 436718!UrlTest methodsFor: 'tests' stamp: 'md 4/21/2003 13:58'! 436719testAbsoluteBrowser 436720 436721 url := Url absoluteFromText: 'browser:bookmarks#mainPart'. 436722 436723 self assert: url schemeName = 'browser'. 436724 self assert: url locator = 'bookmarks'. 436725 self assert:url fragment = 'mainPart'. 436726 self assert: url class = BrowserUrl. 436727 ! ! 436728 436729!UrlTest methodsFor: 'tests' stamp: 'md 4/21/2003 13:29'! 436730testAbsoluteFILE 436731 436732 url := Url absoluteFromText: 'file:/etc/passwd#foo'. 436733 436734 self assert: url schemeName = 'file'. 436735 self assert: url path first = 'etc'. 436736 self assert: url path size = 2. 436737 self assert: url fragment = 'foo'.! ! 436738 436739!UrlTest methodsFor: 'tests' stamp: 'md 4/21/2003 13:32'! 436740testAbsoluteFILE2 436741 436742 url := 'fILE:/foo/bar//zookie/?fakequery/#fragger' asUrl. 436743 436744 self assert: url schemeName = 'file'. 436745 self assert: url class = FileUrl. 436746 self assert: url path first ='foo'. 436747 self assert: url path size = 5. 436748 self assert: url fragment = 'fragger'.! ! 436749 436750!UrlTest methodsFor: 'tests' stamp: 'gk 2/12/2004 21:30'! 436751testAbsoluteFILE3 436752 "Just a few selected tests for FileUrl, not complete by any means." 436753 436754 436755 {'file:'. 'file:/'. 'file://'} do: [:s | 436756 url := FileUrl absoluteFromText: s. 436757 self assert: (url asString = 'file:///'). 436758 self assert: (url host = ''). 436759 self assert: url isAbsolute]. 436760 436761 url := FileUrl absoluteFromText: 'file://localhost/dir/file.txt'. 436762 self assert: (url asString = 'file://localhost/dir/file.txt'). 436763 self assert: (url host = 'localhost'). 436764 436765 url := FileUrl absoluteFromText: 'file://localhost/dir/file.txt'. 436766 self assert: (url asString = 'file://localhost/dir/file.txt'). 436767 self assert: (url host = 'localhost'). 436768 self assert: url isAbsolute. 436769 436770 url := FileUrl absoluteFromText: 'file:///dir/file.txt'. 436771 self assert: (url asString = 'file:///dir/file.txt'). 436772 self assert: (url host = ''). 436773 self assert: url isAbsolute. 436774 436775 url := FileUrl absoluteFromText: '/dir/file.txt'. 436776 self assert: (url asString = 'file:///dir/file.txt'). 436777 self assert: url isAbsolute. 436778 436779 url := FileUrl absoluteFromText: 'dir/file.txt'. 436780 self assert: (url asString = 'file:///dir/file.txt'). 436781 self deny: url isAbsolute. 436782 436783 url := FileUrl absoluteFromText: 'c:/dir/file.txt'. 436784 self assert: (url asString = 'file:///c%3A/dir/file.txt'). 436785 self assert: url isAbsolute. 436786 436787 "Only a drive letter doesn't refer to a directory." 436788 url := FileUrl absoluteFromText: 'c:'. 436789 self assert: (url asString = 'file:///c%3A/'). 436790 self assert: url isAbsolute. 436791 436792 url := FileUrl absoluteFromText: 'c:/'. 436793 self assert: (url asString = 'file:///c%3A/'). 436794 self assert: url isAbsolute! ! 436795 436796!UrlTest methodsFor: 'tests' stamp: 'md 4/21/2003 13:05'! 436797testAbsoluteFTP 436798 436799 url := 'ftP://some.server/some/directory/' asUrl. 436800 436801 self assert: url schemeName = 'ftp'. 436802 self assert: url class = FtpUrl. 436803 self assert: url authority = 'some.server'. 436804 self assert: url path first = 'some'. 436805 self assert: url path size = 3. 436806 ! ! 436807 436808!UrlTest methodsFor: 'tests' stamp: 'md 4/21/2003 13:05'! 436809testAbsoluteHTTP 436810 436811 url := 'hTTp://chaos.resnet.gatech.edu:8000/docs/java/index.html?A%20query%20#part' asUrl. 436812 436813 self assert: url schemeName = 'http'. 436814 self assert: url authority = 'chaos.resnet.gatech.edu'. 436815 self assert: url path first = 'docs'. 436816 self assert: url path size = 3. 436817 self assert: url query = 'A%20query%20'. 436818 self assert: url fragment = 'part'.! ! 436819 436820!UrlTest methodsFor: 'tests' stamp: 'md 1/5/2004 14:51'! 436821testAbsolutePortErrorFix 436822 436823 self shouldnt: [Url absoluteFromText: 'http://swikis.ddo.jp:8823/'] raise: Error. 436824 436825 self should: [Url absoluteFromText: 'http://swikis.ddo.jp:-1/'] raise: Error. 436826 self should: [Url absoluteFromText: 'http://swikis.ddo.jp:65536/'] raise: Error. 436827 self should: [Url absoluteFromText: 'http://swikis.ddo.jp:auau/'] raise: Error.! ! 436828 436829!UrlTest methodsFor: 'tests' stamp: 'md 4/21/2003 13:08'! 436830testAbsoluteTELNET 436831 436832 url := 'telNet:chaos.resnet.gatech.edu#goo' asUrl. 436833 436834 self assert: url schemeName = 'telnet'. 436835 self assert: url locator = 'chaos.resnet.gatech.edu'. 436836 self assert: url fragment = 'goo'. 436837! ! 436838 436839!UrlTest methodsFor: 'tests' stamp: 'st 9/27/2004 15:48'! 436840testCombineWithRelative 436841 #(#('http://www.rfc1149.net/' 'foo.html' 'http://www.rfc1149.net/foo.html') #('http://www.rfc1149.net/index.html' 'foo.html' 'http://www.rfc1149.net/foo.html') #('http://www.rfc1149.net/devel/' '../sam/' 'http://www.rfc1149.net/sam/') #('http://www.rfc1149.net/devel/index.html' '../sam/' 'http://www.rfc1149.net/sam/')) 436842 do: [:a | self assert: (Url combine: a first withRelative: a second) = a third]! ! 436843 436844!UrlTest methodsFor: 'tests' stamp: 'fbs 2/2/2005 13:21'! 436845testRelativeFILE 436846 436847 | url2 | 436848 baseUrl := 'file:/some/dir#fragment1' asUrl. 436849 url := baseUrl newFromRelativeText: 'file:../another/dir/#fragment2'. 436850 self assert: url asText = 'file:///another/dir/#fragment2'. 436851 436852 url := FileUrl absoluteFromText: 'file://localhost/dir/dir2/file.txt'. 436853 url2 := FileUrl absoluteFromText: 'file://hostname/flip/file.txt'. 436854 url2 privateInitializeFromText: '../file2.txt' relativeTo: url. 436855 self assert: (url2 asString = 'file://localhost/dir/file2.txt'). 436856 self assert: (url2 host = 'localhost'). 436857 self assert: url2 isAbsolute. 436858 436859 url := FileUrl absoluteFromText: 'file://localhost/dir/dir2/file.txt'. 436860 url2 := FileUrl absoluteFromText: 'flip/file.txt'. 436861 self deny: url2 isAbsolute. 436862 url2 privateInitializeFromText: '.././flip/file.txt' relativeTo: url. 436863 self assert: (url2 asString = 'file://localhost/dir/flip/file.txt'). 436864 self assert: (url2 host = 'localhost'). 436865 self assert: url2 isAbsolute. 436866 436867! ! 436868 436869!UrlTest methodsFor: 'tests' stamp: 'fbs 2/2/2005 13:21'! 436870testRelativeFTP 436871 436872 baseUrl := 'ftp://somewhere/some/dir/?query#fragment' asUrl. 436873 url := baseUrl newFromRelativeText: 'ftp://a.b'. 436874 436875 self assert: url asString = 'ftp://a.b/'.! ! 436876 436877!UrlTest methodsFor: 'tests' stamp: 'fbs 2/2/2005 13:21'! 436878testRelativeFTP2 436879 436880 baseUrl := 'ftp://somewhere/some/dir/?query#fragment' asUrl. 436881 url := baseUrl newFromRelativeText: 'ftp:xyz'. 436882 436883 436884 self assert: url asString = 'ftp://somewhere/some/dir/xyz'.! ! 436885 436886!UrlTest methodsFor: 'tests' stamp: 'fbs 2/2/2005 13:21'! 436887testRelativeFTP3 436888 436889 baseUrl := 'ftp://somewhere/some/dir/?query#fragment' asUrl. 436890 url := baseUrl newFromRelativeText: 'http:xyz'. 436891 436892 self assert: url asString = 'http://xyz/'.! ! 436893 436894!UrlTest methodsFor: 'tests' stamp: 'fbs 2/2/2005 13:21'! 436895testRelativeHTTP 436896 436897 baseUrl := 'http://some.where/some/dir?query1#fragment1' asUrl. 436898 url := baseUrl newFromRelativeText: '../another/dir/?query2#fragment2'. 436899 436900 self assert: url asString = 'http://some.where/another/dir/?query2#fragment2'.! ! 436901 436902!UrlTest methodsFor: 'tests' stamp: 'gk 2/12/2004 21:31'! 436903testRoundTripFILE 436904 "File URLs should round-trip OK. This test should ultimately be 436905 tested on all platforms." 436906 436907 | fileName | 436908 fileName := FileDirectory default fullNameFor: 'xxx.st'. 436909 url := FileDirectory urlForFileNamed: fileName. 436910 self assert: (url pathForFile = fileName) description: 'fileName didn''t round-trip'.! ! 436911 436912!UrlTest methodsFor: 'tests' stamp: 'md 7/21/2003 10:48'! 436913testUsernamePassword 436914 436915 "basic case with a username+password specified" 436916 url := 'http://user:pword@someserver.blah:8000/root/index.html' asUrl. 436917 self should: [ url schemeName = 'http' ]. 436918 self should: [ url authority = 'someserver.blah' ]. 436919 self should: [ url port = 8000 ]. 436920 self should: [ url path first = 'root' ]. 436921 self should: [ url username = 'user' ]. 436922 self should: [ url password = 'pword' ]. 436923 436924 "basic case for a relative url" 436925 baseUrl := 'http://anotherserver.blah:9999/somedir/someotherdir/stuff/' asUrl. 436926 url := 'http://user:pword@someserver.blah:8000/root/index.html' asUrlRelativeTo: baseUrl. 436927 self should: [ url schemeName = 'http' ]. 436928 self should: [ url authority = 'someserver.blah' ]. 436929 self should: [ url port = 8000 ]. 436930 self should: [ url path first = 'root' ]. 436931 self should: [ url username = 'user' ]. 436932 self should: [ url password = 'pword' ]. 436933 436934 "a true relative test that should keep the username and password from the base URL" 436935 baseUrl := 'http://user:pword@someserver.blah:8000/root/index.html' asUrl. 436936 url := '/anotherdir/stuff/' asUrlRelativeTo: baseUrl. 436937 self should: [ url schemeName = 'http' ]. 436938 self should: [ url authority = 'someserver.blah' ]. 436939 self should: [ url port = 8000 ]. 436940 self should: [ url path first = 'anotherdir' ]. 436941 self should: [ url username = 'user' ]. 436942 self should: [ url password = 'pword' ]. 436943 436944 436945 436946 "just a username specified" 436947 url := 'http://user@someserver.blah:8000/root/index.html' asUrl. 436948 self should: [ url schemeName = 'http' ]. 436949 self should: [ url authority = 'someserver.blah' ]. 436950 self should: [ url port = 8000 ]. 436951 self should: [ url path first = 'root' ]. 436952 self should: [ url username = 'user' ]. 436953 self should: [ url password = nil ]. 436954 436955 436956 "the port is not specified" 436957 url := 'http://user:pword@someserver.blah/root/index.html' asUrl. 436958 self should: [ url schemeName = 'http' ]. 436959 self should: [ url authority = 'someserver.blah' ]. 436960 self should: [ url port = nil ]. 436961 self should: [ url path first = 'root' ]. 436962 self should: [ url username = 'user' ]. 436963 self should: [ url password = 'pword' ]. 436964 436965 436966 "neither a path nor a port is specified" 436967 url := 'http://user:pword@someserver.blah' asUrl. 436968 self should: [ url schemeName = 'http' ]. 436969 self should: [ url authority = 'someserver.blah' ]. 436970 self should: [ url port = nil ]. 436971 self should: [ url username = 'user' ]. 436972 self should: [ url password = 'pword' ]. 436973 436974 436975 "relative URL where the username+password should be forgotten" 436976 baseUrl := 'http://user:pword@someserver.blah' asUrl. 436977 url := 'http://anotherserver.blah' asUrlRelativeTo: baseUrl. 436978 self should: [ url username = nil ]. 436979 self should: [ url password = nil ]. 436980 436981! ! 436982 436983!UrlTest methodsFor: 'tests' stamp: 'fbs 2/2/2005 13:22'! 436984testUsernamePasswordPrinting 436985 436986 #( 'http://user:pword@someserver.blah:8000/root/index.html' 436987 'http://user@someserver.blah:8000/root/index.html' 436988 'http://user:pword@someserver.blah/root/index.html' 436989 ) do: [ :urlText | 436990 self should: [ urlText = urlText asUrl asString ] ]. 436991 436992! ! 436993MorphicEvent subclass: #UserInputEvent 436994 instanceVariableNames: 'type buttons position handler wasHandled' 436995 classVariableNames: '' 436996 poolDictionaries: 'EventSensorConstants' 436997 category: 'Morphic-Events'! 436998 436999!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:45'! 437000buttons 437001 "Return the a word encoding the mouse and modifier buttons for this event." 437002 437003 ^ buttons! ! 437004 437005!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:54'! 437006handler 437007 ^handler! ! 437008 437009!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:54'! 437010handler: anObject 437011 handler := anObject! ! 437012 437013!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 22:45'! 437014position 437015 ^position! ! 437016 437017!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:45'! 437018type 437019 "Return a symbol indicating the type this event." 437020 437021 ^ type! ! 437022 437023!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:54'! 437024wasHandled 437025 ^wasHandled! ! 437026 437027!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:54'! 437028wasHandled: aBool 437029 wasHandled := aBool.! ! 437030 437031 437032!UserInputEvent methodsFor: 'initialize' stamp: 'ar 9/13/2000 15:54'! 437033copyHandlerState: anEvent 437034 "Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events." 437035 handler := anEvent handler. 437036 wasHandled := anEvent wasHandled.! ! 437037 437038!UserInputEvent methodsFor: 'initialize' stamp: 'ar 9/13/2000 15:54'! 437039resetHandlerFields 437040 "Reset anything that is used to cross-communicate between two eventual handlers during event dispatch" 437041 handler := nil. 437042 wasHandled := false.! ! 437043 437044 437045!UserInputEvent methodsFor: 'modifier state' stamp: 'ar 9/13/2000 15:43'! 437046anyModifierKeyPressed 437047 "ignore, however, the shift keys 'cause that's not REALLY a command key " 437048 437049 ^ self buttons anyMask: 16r70 "cmd | opt | ctrl"! ! 437050 437051!UserInputEvent methodsFor: 'modifier state' stamp: 'ar 9/13/2000 15:43'! 437052commandKeyPressed 437053 "Answer true if the command key on the keyboard was being held down when this event occurred." 437054 437055 ^ buttons anyMask: 64! ! 437056 437057!UserInputEvent methodsFor: 'modifier state' stamp: 'ar 9/13/2000 15:44'! 437058controlKeyPressed 437059 "Answer true if the control key on the keyboard was being held down when this event occurred." 437060 437061 ^ buttons anyMask: 16! ! 437062 437063!UserInputEvent methodsFor: 'modifier state' stamp: 'michael.rueger 2/23/2009 18:09'! 437064leftShiftDown 437065 "Answer true if the shift key on the keyboard was being held down when this event occurred." 437066 437067 ^ buttons anyMask: 8 437068! ! 437069 437070!UserInputEvent methodsFor: 'modifier state' stamp: 'ar 9/13/2000 15:44'! 437071shiftPressed 437072 "Answer true if the shift key on the keyboard was being held down when this event occurred." 437073 437074 ^ buttons anyMask: 8 437075! ! 437076 437077 437078!UserInputEvent methodsFor: 'printing' stamp: 'ar 10/7/2000 21:57'! 437079buttonString 437080 "Return a string identifying the currently pressed buttons" 437081 | string | 437082 string := ''. 437083 self redButtonPressed ifTrue:[string := string,'red ']. 437084 self yellowButtonPressed ifTrue:[string := string,'yellow ']. 437085 self blueButtonPressed ifTrue:[string := string,'blue ']. 437086 ^string! ! 437087 437088!UserInputEvent methodsFor: 'printing' stamp: 'ar 10/7/2000 21:56'! 437089modifierString 437090 "Return a string identifying the currently pressed modifiers" 437091 | string | 437092 string := ''. 437093 self commandKeyPressed ifTrue:[string := string,'CMD ']. 437094 self shiftPressed ifTrue:[string := string,'SHIFT ']. 437095 self controlKeyPressed ifTrue:[string := string,'CTRL ']. 437096 ^string! ! 437097 437098 437099!UserInputEvent methodsFor: 'transforming' stamp: 'ar 10/9/2000 00:38'! 437100transformBy: aMorphicTransform 437101 "Transform the receiver into a local coordinate system." 437102 position := aMorphicTransform globalPointToLocal: position.! ! 437103 437104!UserInputEvent methodsFor: 'transforming' stamp: 'ar 10/9/2000 00:38'! 437105transformedBy: aMorphicTransform 437106 "Return the receiver transformed by the given transform into a local coordinate system." 437107 ^self shallowCopy transformBy: aMorphicTransform! ! 437108 437109!UserInputEvent methodsFor: 'transforming' stamp: 'ar 10/9/2000 00:37'! 437110translateBy: delta 437111 "add delta to cursorPoint, and return the new event" 437112 position := position + delta.! ! 437113 437114!UserInputEvent methodsFor: 'transforming' stamp: 'ar 10/9/2000 00:38'! 437115translatedBy: delta 437116 "add delta to cursorPoint, and return the new event" 437117 ^self shallowCopy translateBy: delta! ! 437118 437119 437120!UserInputEvent methodsFor: 'private' stamp: 'ar 10/24/2000 16:33'! 437121setPosition: aPoint 437122 position := aPoint! ! 437123InputEventHandler subclass: #UserInterruptHandler 437124 instanceVariableNames: 'interruptKey' 437125 classVariableNames: '' 437126 poolDictionaries: 'EventSensorConstants' 437127 category: 'Kernel-Processes'! 437128!UserInterruptHandler commentStamp: 'michael.rueger 4/22/2009 12:01' prior: 0! 437129An UserInterruptHandler watches incoming input events and checks for the user interrupt key. 437130If encountered it interrupts the current process and opens a notifier.. 437131 437132Instance Variables 437133 interruptKey: <Object> 437134 437135interruptKey 437136 - definition of the user interrupt key 437137! 437138 437139 437140!UserInterruptHandler methodsFor: 'events' stamp: 'mir 11/20/2008 11:56'! 437141handleEvent: evt 437142 "Store the event in the queue if there's any" 437143 | type | 437144 type := evt at: 1. 437145 type = EventTypeKeyboard 437146 ifTrue: [ 437147 "Check if the event is a user interrupt" 437148 ((evt at: 4) = 0 437149 and: [((evt at: 3) 437150 bitOr: (((evt at: 5) 437151 bitAnd: 8) 437152 bitShift: 8)) 437153 = interruptKey]) 437154 ifTrue: [ 437155 Display deferUpdates: false. 437156 SoundService default shutDown. 437157 self handleUserInterrupt]. 437158 ^self ]. 437159 ! ! 437160 437161 437162!UserInterruptHandler methodsFor: 'initialize-release' stamp: 'mir 11/19/2008 14:41'! 437163setInterruptKeyValue: anInt 437164 interruptKey := anInt 437165! ! 437166 437167 437168!UserInterruptHandler methodsFor: 'private' stamp: 'mir 11/20/2008 11:50'! 437169handleUserInterrupt 437170" [Project interruptName: 'User Interrupt' preemptedProcess: Project uiProcess] fork" 437171 [Project uiProcess debugWithTitle: 'User Interrupt'] fork! ! 437172 437173"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 437174 437175UserInterruptHandler class 437176 instanceVariableNames: ''! 437177 437178!UserInterruptHandler class methodsFor: 'instance creation' stamp: 'mir 11/19/2008 14:41'! 437179new 437180 ^super new setInterruptKeyValue: ($. asciiValue bitOr: 16r0800)! ! 437181Object subclass: #Utilities 437182 instanceVariableNames: '' 437183 classVariableNames: 'LastStats RecentSubmissions ScrapsBook UpdateDownloader UpdateUrlLists' 437184 poolDictionaries: '' 437185 category: 'System-Support'! 437186!Utilities commentStamp: '<historical>' prior: 0! 437187A repository for general and miscellaneous utilities; much of what is here are in effect global methods that don't naturally attach to anything else. 1/96 sw! 437188 437189 437190!Utilities methodsFor: 'look in class' stamp: 'sw 10/13/1998 13:14'! 437191seeClassSide 437192 "All the code for Utilitites is on the class side"! ! 437193 437194"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 437195 437196Utilities class 437197 instanceVariableNames: ''! 437198 437199!Utilities class methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 437200browseRecentSubmissions 437201 "Open up a browser on the most recent methods submitted in the image. 5/96 sw." 437202 437203 "Utilities browseRecentSubmissions" 437204 437205 | recentMessages | 437206 437207 self recentMethodSubmissions size == 0 ifTrue: 437208 [^ self inform: 'There are no recent submissions']. 437209 437210 recentMessages := RecentSubmissions copy reversed. 437211 RecentMessageSet 437212 openMessageList: recentMessages 437213 name: 'Recent submissions -- youngest first ' 437214 autoSelect: nil! ! 437215 437216!Utilities class methodsFor: '*tools' stamp: 'alain.plantec 6/1/2008 23:14'! 437217closeAllDebuggers 437218 "Utilities closeAllDebuggers" 437219 (SystemWindow allSubInstances select: [:w | w model isKindOf: Debugger]) 437220 do: [:w | w delete]! ! 437221 437222!Utilities class methodsFor: '*tools' stamp: 'sw 7/4/2001 12:07'! 437223openRecentSubmissionsBrowser 437224 "Open up a browser on the most recent methods submitted in the image; reuse any existing one found in the world." 437225 437226 self currentWorld openRecentSubmissionsBrowser: nil! ! 437227 437228!Utilities class methodsFor: '*tools' stamp: 'sd 11/20/2005 21:26'! 437229recentSubmissionsWindow 437230 "Answer a SystemWindow holding recent submissions" 437231 437232 | recentMessages messageSet | 437233 recentMessages := RecentSubmissions copy reversed. 437234 messageSet := RecentMessageSet messageList: recentMessages. 437235 messageSet autoSelectString: nil. 437236 ^ (messageSet inMorphicWindowLabeled: 'Recent submissions -- youngest first') applyModelExtent 437237 437238 "Utilities recentSubmissionsWindow openInHand" 437239 437240! ! 437241 437242 437243!Utilities class methodsFor: 'debugging' stamp: 'sw 4/29/2001 23:42'! 437244doesNotUnderstand: aMessage 437245 "A temporary expedient for revectoring various messages formerly sent to Utilities that now are instead implemented by Flaps; this is only for the benefit of pre-existing buttons and menu items that were set up to call the old interface" 437246 437247 | aSelector | 437248 aSelector := aMessage selector. 437249 (#(addLocalFlap explainFlaps addMenuFlap addPaintingFlap addStackToolsFlap addGlobalFlap offerGlobalFlapsMenu toggleWhetherToUseGlobalFlaps ) includes: aSelector) 437250 ifTrue: 437251 [^ self inform: 437252'Sorry, this is an obsolete menu. Please 437253dismiss it and get a fresh one. Thank you']. 437254 437255 ^ super doesNotUnderstand: aMessage! ! 437256 437257 437258!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'MiguelCoba 7/25/2009 02:05'! 437259authorInitials 437260 self deprecated: 'use instead: Author fullName'. 437261 ^ Author fullName 437262! ! 437263 437264!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'MiguelCoba 7/25/2009 02:19'! 437265authorInitialsPerSe 437266 self deprecated: 'use instead: Author fullNamePerSe'. 437267 ^ Author fullNamePerSe 437268! ! 437269 437270!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'on 5/10/2008 14:53'! 437271authorName 437272 self deprecated: 'use instead: Author fullName'. 437273 ^ Author fullName 437274! ! 437275 437276!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'on 5/10/2008 14:54'! 437277authorName: aString 437278 self deprecated: 'use instead: Author fullName:'. 437279 ^ Author fullName: aString! ! 437280 437281!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'MiguelCoba 7/25/2009 02:28'! 437282authorNamePerSe 437283 self deprecated: 'use instead: Author fullNamePerSe'. 437284 ^ Author fullNamePerSe 437285! ! 437286 437287!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'AndrewBlack 9/3/2009 01:30'! 437288commandKeyMappings 437289 437290 self deprecated: 'Use ''TheWorldMenu new commandKeyMappings'' instead.' on: '10 July 2009' in: #Pharo1.0 . 437291 ^ TheWorldMenu commandKeyMappings 437292 ! ! 437293 437294!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'AndrewBlack 9/3/2009 01:21'! 437295convertCRtoLF: fileName 437296 "Convert the given file to LF line endings. Put the result in a file with the extention '.lf'" 437297 437298 self deprecated: 'Use ''FileStream convertCRtoLF: fileName'' instead.' 437299 on: '10 July 2009' in: #Pharo1.0 . 437300 FileStream convertCRtoLF: fileName! ! 437301 437302!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'AndrewBlack 9/3/2009 01:21'! 437303createPageTestWorkspace 437304 "Used to generate a workspace window for testing page up and page down stuff." 437305 "Utilities createPageTestWorkspace" 437306 437307 self deprecated: 'Use ''UIManager createPageTestWorkspace'' instead.' on: '10 July 2009' in: #Pharo1.0. 437308 UIManager createPageTestWorkspace 437309 ! ! 437310 437311!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'AndrewBlack 9/3/2009 01:23'! 437312decommissionTheAllCategory 437313 "Utilities decommissionTheAllCategory" 437314 "Moves all methods that are in a category named 'all' into the default 'as yet unclassified' category" 437315 437316 | org aCategory methodCount classCount any | 437317 self deprecated: 'No alternative is suggested.' on: '10 July 2009' in: #Pharo1.0. 437318 437319 methodCount := 0. 437320 classCount := 0. 437321 self systemNavigation allBehaviorsDo: 437322 [:aClass | org := aClass organization. 437323 any := false. 437324 aClass selectorsDo: 437325 [:aSelector | 437326 aCategory := org categoryOfElement: aSelector. 437327 aCategory = #all ifTrue: 437328 [org classify: aSelector under: ClassOrganizer default suppressIfDefault: false. 437329 methodCount := methodCount + 1. 437330 any := true]]. 437331 any ifTrue: [classCount := classCount + 1]. 437332 org removeEmptyCategories]. 437333 Transcript cr; show: methodCount printString, ' methods in ', classCount printString, ' classes moved 437334from "all" to "as yet unclassified"' 437335! ! 437336 437337!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'AndrewBlack 9/3/2009 01:23'! 437338informUser: aString during: aBlock 437339 "Display the message as progress during execution of the given block." 437340 "UIManager default informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait]" 437341 437342 self deprecated: 'Use ''UIManager default informUser: during:'' instead.' on: '10 July 2009' in: #Pharo1.0. 437343 ^ UIManager default informUser: aString during: aBlock! ! 437344 437345!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'AndrewBlack 9/3/2009 01:24'! 437346informUserDuring: aBlock 437347 "Display a message as progress during execution of the given block." 437348 437349 self deprecated: 'Use ''UIManager default informUserDuring:'' instead' on: '10 July 2009' in: #Pharo1.0. 437350 ^ UIManager default informUserDuring: aBlock! ! 437351 437352!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'AndrewBlack 9/3/2009 01:25'! 437353inspectCollection: aCollection notifying: aView 437354 437355 self deprecated: 'No replacement is suggested.' on: '10 July 2009' in: #Pharo1.0. 437356 437357 aCollection size = 0 437358 ifTrue: [aView notNil 437359 ifTrue: [^ aView flash] 437360 ifFalse: [^ self]]. 437361 aCollection size = 1 437362 ifTrue: [aCollection first inspect] 437363 ifFalse: [aCollection asArray inspect]! ! 437364 437365!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'stephane.ducasse 7/10/2009 15:53'! 437366openCommandKeyHelp 437367 "Open a window giving command key help." 437368 437369 self deprecated: 'Use TheWorldMenu version instead' on: '10 July 2009' in: #Pharo1.0.! ! 437370 437371!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'AndrewBlack 9/3/2009 01:32'! 437372pointersTo: anObject 437373 "Find all occurrences in the system of pointers to the argument anObject." 437374 "(Utilities pointersTo: Browser) inspect." 437375 437376 self deprecated: 'Use ''PointerFinder pointersTo:'' instead.' on: '10 July 2009' in: #Pharo1.0. 437377 ^ PointerFinder pointersTo: anObject except: #() 437378! ! 437379 437380!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'AndrewBlack 9/3/2009 01:32'! 437381pointersTo: anObject except: objectsToExclude 437382 "Find all occurrences in the system of pointers to the argument 437383 anObject. Remove objects in the exclusion list from the 437384 results. " 437385 self deprecated: 'Use ''PointerFinder pointersTo:except:'' instead.' on: '10 July 2009' in: #Pharo1.0. 437386 437387 ^ PointerFinder pointersTo: anObject except: objectsToExclude ! ! 437388 437389!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'stephane.ducasse 7/10/2009 16:01'! 437390pointersToItem: index of: anArray 437391 "Find all occurrences in the system of pointers to the given element of the given array. This is useful for tracing up a pointer chain from an inspector on the results of a previous call of pointersTo:. To find out who points to the second element of the results, one would evaluate: 437392 437393 Utilities pointersToItem: 2 of: self 437394 437395in the inspector." 437396 437397 self deprecated: 'Please, use PointerFinder class>>pointersToItem:of: instead' on: '10 July 2009' in: #Pharo1.0. 437398 ^ PointerFinder pointersTo: (anArray at: index) except: (Array with: anArray)! ! 437399 437400!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'AndrewBlack 9/3/2009 02:18'! 437401reportSenderCountsFor: selectorList 437402 "Produce a report on the number of senders of each of the selectors in 437403 the list. 1/27/96 sw" 437404 437405 self deprecated: 'Use ''SystemNavigation default reportSenderCountsFor:'' instead.' on: '10 July 2009' in: #Pharo1.0. 437406 ^ SystemNavigation default reportSenderCountsFor: selectorList! ! 437407 437408!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'MiguelCoba 7/25/2009 02:22'! 437409setAuthorInitials 437410 self deprecated: 'use instead: Author requestFullName'. 437411 ^ Author requestFullName! ! 437412 437413!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'MiguelCoba 7/25/2009 02:13'! 437414setAuthorInitials: aString 437415 self deprecated: 'use instead: Author fullName:'. 437416 ^ Author fullName: aString.! ! 437417 437418!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'MiguelCoba 7/25/2009 02:23'! 437419setAuthorName 437420 self deprecated: 'use instead: Author requestFullName'. 437421 ^ Author requestFullName 437422! ! 437423 437424!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'AndrewBlack 9/3/2009 02:18'! 437425showFormsAcrossTopOfScreen: aFormList 437426 "Display the given array of forms across the top of the screen, wrapping to subsequent lines if needed. Useful for example for looking at sets of rotations and animations. 6/10/96 sw" 437427 "self showFormsAcrossTopOfScreen: {Cursor currentCursor asCursorForm}" 437428 437429 self deprecated: 'Use ''Form showFormsAcrossTopOfScreen:'' instead.' on: '10 July 2009' in: #Pharo1.0. 437430 ^ Form showFormsAcrossTopOfScreen: aFormList! ! 437431 437432!Utilities class methodsFor: 'deprecated-Pharo-1.0' stamp: 'AndrewBlack 9/3/2009 02:19'! 437433showFormsDictAcrossTopOfScreen: formDict 437434 "Display the given Dictionary of forms across the top of the screen, wrapping to subsequent lines if needed. Beneath each, put the name of the associated key." 437435 437436 " 437437 | dict methods | 437438 dict := Dictionary new. 437439 methods := MenuIcons class selectors select: [:each | '*Icon' match: each asString]. 437440 methods do: [:each | dict at: each put: (MenuIcons perform: each)]. 437441 Form showFormsDictAcrossTopOfScreen: dict" 437442 437443 self deprecated: 'Use ''Form showFormsDictAcrossTopOfScreen:'' instead.' on: '10 July 2009' in: #Pharo1.0. 437444 ^ Form showFormsDictAcrossTopOfScreen: formDict 437445 437446! ! 437447 437448 437449!Utilities class methodsFor: 'fetching updates' stamp: 'sr 2/12/2001 03:38'! 437450applyUpdatesFromDisk 437451 "Utilities applyUpdatesFromDisk" 437452 "compute highest update number" 437453 | updateDirectory updateNumbers | 437454 updateDirectory := self getUpdateDirectoryOrNil. 437455 updateDirectory 437456 ifNil: [^ self]. 437457 updateNumbers := updateDirectory fileNames 437458 collect: [:fn | fn initialIntegerOrNil] 437459 thenSelect: [:fn | fn notNil]. 437460 self 437461 applyUpdatesFromDiskToUpdateNumber: (updateNumbers 437462 inject: 0 437463 into: [:max :num | max max: num]) 437464 stopIfGap: false! ! 437465 437466!Utilities class methodsFor: 'fetching updates' stamp: 'ar 9/27/2005 20:15'! 437467applyUpdatesFromDiskToUpdateNumber: lastUpdateNumber stopIfGap: stopIfGapFlag 437468 "To use this mechanism, be sure all updates you want to have considered 437469 are in a folder named 'updates' which resides in the same directory as 437470 your image. Having done that, simply evaluate: 437471 437472 Utilities applyUpdatesFromDiskToUpdateNumber: 1234 stopIfGap: false 437473 437474 and all numbered updates <= lastUpdateNumber not yet in the image will 437475 be loaded in numerical order." 437476 | previousHighest currentUpdateNumber done fileNames aMessage updateDirectory loaded | 437477 updateDirectory := self getUpdateDirectoryOrNil. 437478 updateDirectory ifNil: [^ self]. 437479 previousHighest := SystemVersion current highestUpdate. 437480 currentUpdateNumber := previousHighest. 437481 done := false. 437482 loaded := 0. 437483 [done] 437484 whileFalse: [currentUpdateNumber := currentUpdateNumber + 1. 437485 currentUpdateNumber > lastUpdateNumber 437486 ifTrue: [done := true] 437487 ifFalse: [fileNames := updateDirectory fileNamesMatching: currentUpdateNumber printString , '*'. 437488 fileNames size > 1 437489 ifTrue: [^ self inform: 'ambiguity -- two files both start with ' , currentUpdateNumber printString , ' 437490(at this point it is probably best to remedy 437491the situation on disk, then try again.)']. 437492 fileNames size == 0 437493 ifTrue: [Transcript cr; show: 'gap in updates from disk for update number '; print: currentUpdateNumber; show: ' found...'. 437494 done := stopIfGapFlag] 437495 ifFalse: [ChangeSet 437496 newChangesFromStream: (updateDirectory readOnlyFileNamed: fileNames first) 437497 named: fileNames first. 437498 SystemVersion current registerUpdate: currentUpdateNumber. 437499 loaded := loaded + 1]]]. 437500 aMessage := loaded = 0 437501 ifTrue: ['No new updates found.'] 437502 ifFalse: [loaded printString , ' update(s) loaded.']. 437503 self inform: aMessage , ' 437504Highest numbered update is now ' , (currentUpdateNumber - 1) printString , '.'! ! 437505 437506!Utilities class methodsFor: 'fetching updates' stamp: 'md 9/11/2004 12:06'! 437507assureAbsenceOfUnstableUpdateStream 437508 "Check to see if the unstable Updates stream is in the list; if it is, *remove* it. This is the *opposite* of #assureAvailabilityOfUnstableUpdateStream" 437509 437510 UpdateUrlLists ifNil: [UpdateUrlLists := OrderedCollection new]. 437511 UpdateUrlLists := UpdateUrlLists select: 437512 [:pair | pair first ~= 'Unstable Updates*'] 437513 437514 437515"Utilities assureAbsenceOfUnstableUpdateStream"! ! 437516 437517!Utilities class methodsFor: 'fetching updates' stamp: 'md 9/11/2004 12:07'! 437518assureAvailabilityOfUnstableUpdateStream 437519 "Check to see if the unstable Updates stream is in the list; if not, add it" 437520 437521 UpdateUrlLists ifNil: [UpdateUrlLists := OrderedCollection new]. 437522 UpdateUrlLists do: 437523 [:pair | (pair first = 'Unstable Updates*') ifTrue: [^ self]]. 437524 437525 UpdateUrlLists addFirst: #('Unstable Updates*' #('squeak.cs.uiuc.edu/Squeak2.0/' 'update.squeakfoundation.org/external/')) 437526 437527"Utilities assureAvailabilityOfUnstableUpdateStream"! ! 437528 437529!Utilities class methodsFor: 'fetching updates' stamp: 'alain.plantec 2/6/2009 17:40'! 437530broadcastUpdatesFrom: n1 to: n2 except: skipList 437531" 437532 Note: This method takes its list of files from the directory named 'updates', 437533 which will have been created and filled by, eg, 437534 Utilities readServerUpdatesSaveLocally: true updateImage: true. 437535 These can then be rebroadcast to any server using, eg, 437536 Utilities broadcastUpdatesFrom: 1 to: 9999 except: #(223 224). 437537 If the files are already on the server, and it is only a matter 437538 of copying them to the index for a different version, then use... 437539 (ServerDirectory serverInGroupNamed: 'SqC Internal Updates*') 437540 exportUpdatesExcept: #(). 437541" 437542 | fileNames fileNamesInOrder names choice file updateDirectory | 437543 updateDirectory := FileDirectory default directoryNamed: 'updates'. 437544 fileNames := updateDirectory fileNames select: 437545 [:n | n first isDigit 437546 and: [(n initialIntegerOrNil between: n1 and: n2) 437547 and: [(skipList includes: n initialIntegerOrNil) not]]]. 437548 (file := fileNames select: [:n | (n occurrencesOf: $.) > 1]) size > 0 437549 ifTrue: [self halt: file first , ' has multiple periods']. 437550 fileNamesInOrder := fileNames asSortedCollection: 437551 [:a :b | a initialIntegerOrNil < b initialIntegerOrNil]. 437552 437553 names := ServerDirectory groupNames asSortedArray. 437554 choice := UIManager default chooseFrom: names values: names. 437555 choice ifNil: [^ self]. 437556 (ServerDirectory serverInGroupNamed: choice) 437557 putUpdateMulti: fileNamesInOrder fromDirectory: updateDirectory 437558! ! 437559 437560!Utilities class methodsFor: 'fetching updates' stamp: 'CdG 10/17/2005 19:36'! 437561chooseUpdateList 437562 "When there is more than one set of update servers, let the user choose which we will update from. Put it at the front of the list. Return false if the user aborted. If the preference #promptForUpdateServer is false, then suppress that prompt, in effect using the same server choice that was used the previous time (a convenience for those of us who always answer the same thing to the prompt.)" 437563 437564 | index him | 437565 ((UpdateUrlLists size > 1) and: [Preferences promptForUpdateServer]) 437566 ifTrue: 437567 [index := UIManager default 437568 chooseFrom: (UpdateUrlLists collect: [:each | each first]) 437569 lines: #() 437570 title: 'Choose a group of servers\from which to fetch updates.' translated withCRs. 437571 index > 0 ifTrue: 437572 [him := UpdateUrlLists at: index. 437573 UpdateUrlLists removeAt: index. 437574 UpdateUrlLists addFirst: him]. 437575 ^ index > 0]. 437576 ^ true! ! 437577 437578!Utilities class methodsFor: 'fetching updates' stamp: 'di 4/29/2001 22:26'! 437579extractThisVersion: list 437580 "Pull out the part of the list that applies to this version." 437581 437582 | listContents version versIndex | 437583 listContents := self parseListContents: list. 437584 version := SystemVersion current version. 437585 versIndex := (listContents collect: [:pair | pair first]) indexOf: version. 437586 versIndex = 0 ifTrue: [^ Array new]. "abort" 437587 ^ (listContents at: versIndex) last! ! 437588 437589!Utilities class methodsFor: 'fetching updates' stamp: 'sw 2/26/2002 23:19'! 437590fileInFromUpdatesFolder: numberList 437591 "File in a series of updates with the given updates numbers, from the updates folder in the default directory. The file-ins are done in numeric order, even if numberList was not sorted upon entry. 437592 This is useful for test-driving the retrofitting of a possibly discontinguous list of updates from an alpha version back to a stable release. 437593 437594 Utilities fileInFromUpdatesFolder: #(4745 4746 4747 4748 4749 4750 4751 4752 4754 4755 4761 4762 4767 4769). 437595" 437596 | fileNames fileNamesInOrder file updateDirectory | 437597 updateDirectory := FileDirectory default directoryNamed: 'updates'. 437598 fileNames := updateDirectory fileNames select: 437599 [:n | n first isDigit 437600 and: [numberList includes: n initialIntegerOrNil]]. 437601 (file := fileNames select: [:n | (n occurrencesOf: $.) > 1]) size > 0 437602 ifTrue: [self error: file first , ' has multiple periods']. 437603 fileNamesInOrder := fileNames asSortedCollection: 437604 [:a :b | a initialIntegerOrNil < b initialIntegerOrNil]. 437605 437606 fileNamesInOrder do: 437607 [:aFileName | (updateDirectory readOnlyFileNamed: aFileName) fileIntoNewChangeSet]! ! 437608 437609!Utilities class methodsFor: 'fetching updates' stamp: 'sr 2/12/2001 03:36'! 437610getUpdateDirectoryOrNil 437611 ^ (FileDirectory default directoryNames includes: 'updates') 437612 ifTrue: [FileDirectory default directoryNamed: 'updates'] 437613 ifFalse: [self inform: 'Error: cannot find "updates" folder'. 437614 nil]! ! 437615 437616!Utilities class methodsFor: 'fetching updates' stamp: 'tk 2/16/98 16:16'! 437617lastUpdateNum: updatesFileStrm 437618 "Look in the Updates file and see what the last sequence number is. Warn the user if the version it is under is not this image's version." 437619 437620 | verIndex seqIndex char ver seqNum | 437621 verIndex := seqIndex := 0. "last # starting a line and last digit starting a line" 437622 seqNum := 0. 437623 updatesFileStrm reset; ascii. 437624 [char := updatesFileStrm next. 437625 updatesFileStrm atEnd] whileFalse: [ 437626 char == Character cr ifTrue: [ 437627 updatesFileStrm peek == $# ifTrue: [verIndex := updatesFileStrm position +1. 437628 seqIndex = 0 ifFalse: ["See if last num of old version if biggest so far" 437629 updatesFileStrm position: seqIndex. 437630 ver := SmallInteger readFrom: updatesFileStrm. 437631 seqNum := seqNum max: ver. 437632 updatesFileStrm position: verIndex-1]]. 437633 updatesFileStrm peek isDigit ifTrue: [seqIndex := updatesFileStrm position]]]. 437634 437635 seqIndex = 0 ifFalse: ["See if last num of old version if biggest so far" 437636 updatesFileStrm position: seqIndex. 437637 ver := SmallInteger readFrom: updatesFileStrm. 437638 seqNum := seqNum max: ver. 437639 updatesFileStrm setToEnd]. 437640 ^ seqNum! ! 437641 437642!Utilities class methodsFor: 'fetching updates' stamp: 'marcus.denker 9/14/2008 19:03'! 437643newUpdatesOn: serverList special: indexPrefix throughNumber: aNumber 437644 "Return a list of fully formed URLs of update files we do not yet have. Go to the listed servers and look at the file 'updates.list' for the names of the last N update files. We look backwards for the first one we have, and make the list from there. tk 9/10/97 437645 No updates numbered higher than aNumber (if it is not nil) are returned " 437646 437647 | existing doc list out ff raw char maxNumber itsNumber | 437648 maxNumber := aNumber ifNil: [99999]. 437649 out := OrderedCollection new. 437650 existing := SystemVersion current updates. 437651 serverList do: [:server | 437652 doc := HTTPClient httpGet: 'http://' , server,indexPrefix,'updates.list'. 437653 "test here for server being up" 437654 doc class == RWBinaryOrTextStream ifTrue: 437655 [raw := doc reset; contents. "one file name per line" 437656 list := self extractThisVersion: raw. 437657 list reverseDo: [:fileName | 437658 ff := (fileName findTokens: '/') last. "allow subdirectories" 437659 itsNumber := ff initialIntegerOrNil. 437660 (existing includes: itsNumber) 437661 ifFalse: 437662 [ 437663 (itsNumber isNil or: [itsNumber <= maxNumber]) 437664 ifTrue: 437665 [out addFirst: 'http://' , server, fileName]] 437666 ifTrue: [^ out]]. 437667 ((out size > 0) or: [char := doc reset; skipSeparators; next. 437668 (char == $*) | (char == $#)]) ifTrue: 437669 [^ out "we have our list"]]. "else got error msg instead of file" 437670 "Server was down, try next one"]. 437671 self inform: 'All code update servers seem to be unavailable'. 437672 ^ out! ! 437673 437674!Utilities class methodsFor: 'fetching updates' stamp: 'StephaneDucasse 10/18/2009 17:53'! 437675objectStrmFromUpdates: fileName 437676 "Go to the known servers and look for this file in the updates folder. It is an auxillery file, like .morph or a .gif. Return a RWBinaryOrTextStream on it. Meant to be called from during the getting of updates from the server. That assures that (Utilities serverUrls) returns the right group of servers." 437677 437678 | urls doc | 437679 Cursor wait showWhile: 437680 [urls := Utilities serverUrls collect: [:url | url, 'updates/','pharo', ScriptLoader currentMajorVersionNumber asString,'/', fileName]. 437681 urls do: [:aUrl | 437682 doc := HTTPSocket httpGet: aUrl accept: 'application/octet-stream'. 437683 "test here for server being up" 437684 doc class == RWBinaryOrTextStream ifTrue: [^ doc reset]]]. 437685 437686 self inform: 'All update servers are unavailable, or bad file name'. 437687 ^ nil! ! 437688 437689!Utilities class methodsFor: 'fetching updates' stamp: 'dc 5/30/2008 10:17'! 437690parseListContents: listContents 437691 "Parse the contents of updates.list into {{vers. {fileNames*}}*}, and return it." 437692 | sections vers strm line fileNames | 437693 sections := OrderedCollection new. 437694 fileNames := OrderedCollection new: 1000. 437695 vers := nil. 437696 strm := listContents readStream. 437697 [ strm atEnd ] whileFalse: 437698 [ line := strm upTo: Character cr. 437699 line size > 0 ifTrue: 437700 [ line first = $# 437701 ifTrue: 437702 [ vers ifNotNil: [ sections addLast: { vers. (fileNames asArray) } ]. 437703 "Start a new section" 437704 vers := line allButFirst. 437705 fileNames resetTo: 1 ] 437706 ifFalse: [ line first = $* ifFalse: [ fileNames addLast: line ] ] ] ]. 437707 vers ifNotNil: [ sections addLast: { vers. (fileNames asArray) } ]. 437708 ^ sections asArray 437709 " TEST: 437710 | list | 437711list := Utilities parseListContents: (FileStream oldFileNamed: 'updates.list') contentsOfEntireFile. 437712list = (Utilities parseListContents: (String streamContents: [:s | Utilities writeList: list toStream: s])) 437713 ifFalse: [self error: 'test failed'] 437714 ifTrue: [self inform: 'test OK'] 437715"! ! 437716 437717!Utilities class methodsFor: 'fetching updates' stamp: 'mir 4/2/2001 16:34'! 437718position: updateStrm atVersion: version 437719 "Set the stream to the end of the last line of updates names for this version. Usually the end of the file. We will add a new update name. Return the contents of the rest of the file." 437720 437721 | char foundIt where data | 437722 updateStrm reset; ascii. 437723 foundIt := false. 437724 [char := updateStrm next. 437725 updateStrm atEnd] whileFalse: [ 437726 (char == Character cr or: [char == Character lf]) ifTrue: [ 437727 updateStrm peek == $# ifTrue: [ 437728 foundIt ifTrue: ["Next section" 437729 where := updateStrm position. 437730 data := updateStrm upTo: (255 asCharacter). 437731 updateStrm position: where. 437732 ^ data]. "won't be found -- copy all the way to the end" 437733 updateStrm next. 437734 (updateStrm nextMatchAll: version) ifTrue: [ 437735 (updateStrm atEnd or: [(updateStrm peek = Character cr) | 437736 (updateStrm peek = Character lf)]) ifTrue: [ 437737 foundIt := true 437738 ]]]]]. 437739 foundIt ifTrue: [ 437740 updateStrm setToEnd. 437741 ^ '']. 437742 self error: 'The current version does not have a section in the Updates file'. 437743! ! 437744 437745!Utilities class methodsFor: 'fetching updates' stamp: 'ar 9/27/2005 20:15'! 437746readNextUpdateFromServer 437747 "Utilities readNextUpdateFromServer" 437748 self updateFromServerThroughUpdateNumber: (ChangeSet highestNumberedChangeSet + 1)! ! 437749 437750!Utilities class methodsFor: 'fetching updates' stamp: 'ar 9/27/2005 20:15'! 437751readNextUpdatesFromDisk: n 437752 "Read the updates up through the current highest-update-number plus n. Thus, 437753 Utilities readNextUpdatesFromDisk: 7 437754will read the next seven updates from disk" 437755 437756 self applyUpdatesFromDiskToUpdateNumber: ChangeSet highestNumberedChangeSet + n 437757 stopIfGap: false! ! 437758 437759!Utilities class methodsFor: 'fetching updates' stamp: 'StephaneDucasse 10/18/2009 18:48'! 437760readServer: serverList special: indexPrefix updatesThrough: maxNumber saveLocally: saveLocally updateImage: updateImage 437761 "Scan the update server(s) for unassimilated updates. If maxNumber is not nil, it represents the highest-numbered update to load. This makes it possible to update only up to a particular point. If saveLocally is true, then save local copies of the update files on disc. If updateImage is true, then absorb the updates into the current image." 437762 437763"Utilities readServer: Utilities serverUrls updatesThrough: 828 saveLocally: true updateImage: true" 437764 437765 | urls failed loaded docQueue this nextDoc docQueueSema str updateName | 437766 Cursor wait showWhile: [ 437767 437768 urls := self newUpdatesOn: (serverList collect: [:url | url, 'updates/','pharo', ScriptLoader currentMajorVersionNumber asString, '/']) 437769 special: indexPrefix 437770 throughNumber: maxNumber. 437771 loaded := 0. 437772 failed := nil. 437773 437774 "send downloaded documents throuh this queue" 437775 docQueue := SharedQueue new. 437776 437777 "this semaphore keeps too many documents from beeing queueed up at a time" 437778 docQueueSema := Semaphore new. 437779 5 timesRepeat: [ docQueueSema signal ]. 437780 437781 "fork a process to download the updates" 437782 self retrieveUrls: urls ontoQueue: docQueue withWaitSema: docQueueSema. 437783 437784 "process downloaded updates in the foreground" 437785 'Processing updates' displayProgressAt: Sensor cursorPoint from: 0 to: urls size during: [:bar | 437786 [ this := docQueue next. 437787 nextDoc := docQueue next. 437788 nextDoc = #failed ifTrue: [ failed := this ]. 437789 (failed isNil and: [ nextDoc ~= #finished ]) 437790 ] whileTrue: [ 437791 failed ifNil: [ 437792 nextDoc reset; text. 437793 nextDoc size = 0 ifTrue: [ failed := this ]. ]. 437794 failed ifNil: [ 437795 nextDoc peek asciiValue = 4 "pure object file" 437796 ifTrue: [failed := this]]. "Must be fileIn, not pure object file" 437797 failed ifNil: [ 437798 "(this endsWith: '.html') ifTrue: [doc := doc asHtml]." 437799 "HTML source code not supported here yet" 437800 updateImage 437801 ifTrue: [ 437802 updateName := (this findTokens: '/') last. 437803 ChangeSet newChangesFromStream: nextDoc named: updateName. 437804 SystemVersion current registerUpdate: updateName initialIntegerOrNil]. 437805 saveLocally ifTrue: 437806 [self saveUpdate: nextDoc onFile: (this findTokens: '/') last]. "if wanted" 437807 loaded := loaded + 1. 437808 bar value: loaded]. 437809 437810 docQueueSema signal]. 437811 ]]. 437812 437813 failed ~~ nil & (urls size - loaded > 0) ifTrue: [ 437814 str := loaded printString ,' new update file(s) processed.'. 437815 str := str, '\Could not load ' withCRs, 437816 (urls size - loaded) printString ,' update file(s).', 437817 '\Starting with "' withCRs, failed, '".'. 437818 self inform: str]. 437819 ^ Array with: failed with: loaded 437820! ! 437821 437822!Utilities class methodsFor: 'fetching updates' stamp: 'sw 1/10/1999 02:02'! 437823readServerUpdatesSaveLocally: saveLocally updateImage: updateImage 437824 ^ self readServerUpdatesThrough: nil saveLocally: saveLocally updateImage: updateImage! ! 437825 437826!Utilities class methodsFor: 'fetching updates' stamp: 'rbb 2/18/2005 13:16'! 437827readServerUpdatesThrough: maxNumber saveLocally: saveLocally updateImage: updateImage 437828 "Scan the update server(s) for unassimilated updates. If maxNumber is not nil, it represents the highest-numbered update to load. This makes it possible to update only up to a particular point. If saveLocally is true, then save local copies of the update files on disc. If updateImage is true, then absorb the updates into the current image. 437829 437830A file on the server called updates.list has the names of the last N update files. We look backwards for the first one we do not have, and start there" 437831"* To add a new update: Name it starting with a new two-digit code. 437832* Do not use %, /, *, space, or more than one period in the name of an update file. 437833* The update name does not need to have any relation to the version name. 437834* Figure out which versions of the system the update makes sense for. 437835* Add the name of the file to each version's category below. 437836* Put this file and the update file on all of the servers. 437837* 437838* To make a new version of the system: Pick a name for it (no restrictions) 437839* Put # and exactly that name on a new line at the end of this file. 437840* During the release process, fill in exactly that name in the dialog box. 437841* Put this file on the server." 437842"When two sets of updates need to use the same directory, one of them has a * in its 437843serverUrls description. When that is true, the first word of the description is put on 437844the front of 'updates.list', and that is the index file used." 437845 437846"Utilities readServerUpdatesThrough: 3922 saveLocally: true updateImage: true" 437847 437848 | failed loaded str res servers triple tryAgain indexPrefix | 437849 Utilities chooseUpdateList ifFalse: [^ self]. "ask the user which kind of updates" 437850 437851 servers := Utilities serverUrls copy. 437852 indexPrefix := (Utilities updateUrlLists first first includes: $*) 437853 ifTrue: [(Utilities updateUrlLists first first findTokens: ' ') first] 437854 "special for internal updates" 437855 ifFalse: ['']. "normal" 437856 [servers isEmpty] whileFalse: [ 437857 triple := self readServer: servers special: indexPrefix 437858 updatesThrough: maxNumber 437859 saveLocally: saveLocally updateImage: updateImage. 437860 437861 "report to user" 437862 failed := triple first. 437863 loaded := triple second. 437864 tryAgain := false. 437865 failed ifNil: ["is OK" 437866 loaded = 0 ifTrue: ["found no updates" 437867 servers size > 1 ifTrue: ["not the last server" 437868 res := UIManager default 437869 chooseFrom: #('Stop looking' 'Try next server') 437870 title: 437871'No new updates on the server 437872', servers first, ' 437873Would you like to try the next server? 437874(Normally, all servers are identical, but sometimes a 437875server won''t let us store new files, and gets out of date.)' 437876 . 437877 res = 2 ifFalse: [^ self] 437878 ifTrue: [servers := servers allButFirst. "try the next server" 437879 tryAgain := true]]]]. 437880 tryAgain ifFalse: [ 437881 str := loaded printString ,' new update file(s) processed.'. 437882 ^ self inform: str]. 437883 ].! ! 437884 437885!Utilities class methodsFor: 'fetching updates' stamp: 'laza 8/28/2005 04:55'! 437886retrieveUrls: urls ontoQueue: queue withWaitSema: waitSema 437887 "download the given list of URLs. The queue will be loaded alternately 437888 with url's and with the retrieved contents. If a download fails, the 437889 contents will be #failed. If all goes well, a special pair with an empty 437890 URL and the contents #finished will be put on the queue. waitSema is 437891 waited on every time before a new document is downloaded; this keeps 437892 the downloader from getting too far ahead of the main process" 437893 "kill the existing downloader if there is one" 437894 | doc canPeek front updateCounter | 437895 UpdateDownloader 437896 ifNotNil: [UpdateDownloader terminate]. 437897 updateCounter := 0. 437898 "fork a new downloading process" 437899 UpdateDownloader := [ 437900 'Downloading updates' displayProgressAt: Sensor cursorPoint from: 0 to: urls size during: [:bar | 437901 urls 437902 do: [:url | 437903 waitSema wait. 437904 queue nextPut: url. 437905 doc := HTTPClient httpGet: url. 437906 doc isString 437907 ifTrue: [queue nextPut: #failed. 437908 UpdateDownloader := nil. 437909 Processor activeProcess terminate] 437910 ifFalse: [canPeek := 120 min: doc size. 437911 front := doc next: canPeek. doc skip: -1 * canPeek. 437912 (front beginsWith: '<!!DOCTYPE') ifTrue: [ 437913 (front includesSubString: 'Not Found') ifTrue: [ 437914 queue nextPut: #failed. 437915 UpdateDownloader := nil. 437916 Processor activeProcess terminate]]]. 437917 UpdateDownloader ifNotNil: [queue nextPut: doc. updateCounter := updateCounter + 1. bar value: updateCounter]]]. 437918 queue nextPut: ''. 437919 queue nextPut: #finished. 437920 UpdateDownloader := nil] newProcess. 437921 UpdateDownloader priority: Processor userInterruptPriority. 437922 "start the process running" 437923 UpdateDownloader resume! ! 437924 437925!Utilities class methodsFor: 'fetching updates' stamp: 'th 4/25/2000 12:59'! 437926saveUpdate: doc onFile: fileName 437927 "Save the update on a local file. With or without the update number on the front, depending on the preference #updateRemoveSequenceNum" 437928 437929 | file fName pos updateDirectory | 437930 437931 (FileDirectory default directoryNames includes: 'updates') ifFalse: 437932 [FileDirectory default createDirectory: 'updates']. 437933 updateDirectory := FileDirectory default directoryNamed: 'updates'. 437934 437935 fName := fileName. 437936 (Preferences valueOfFlag: #updateRemoveSequenceNum) ifTrue: 437937 [pos := fName findFirst: [:c | c isDigit not]. 437938 fName := fName copyFrom: pos to: fName size]. 437939 doc reset; ascii. 437940 (updateDirectory fileExists: fName) ifFalse: 437941 [file := updateDirectory newFileNamed: fName. 437942 file nextPutAll: doc contents. 437943 file close]. 437944! ! 437945 437946!Utilities class methodsFor: 'fetching updates' stamp: 'nk 6/26/2003 21:12'! 437947serverUrls 437948 "Return the current list of server URLs. For code updates. Format of UpdateUrlLists is 437949#( ('squeak updates' ('url1' 'url2')) 437950 ('some other updates' ('url3' 'url4')))" 437951 437952 | list | 437953 list := UpdateUrlLists first last. 437954 437955 "If there is a dead server, return a copy with that server last" 437956 Socket deadServer ifNotNil: [ 437957 list clone withIndexDo: [:aName :ind | 437958 (aName beginsWith: Socket deadServer) ifTrue: [ 437959 list := list asOrderedCollection. "and it's a copy" 437960 list removeAt: ind. 437961 list addLast: aName]] 437962 ]. 437963 437964 ^ list asArray! ! 437965 437966!Utilities class methodsFor: 'fetching updates' stamp: 'mir 8/10/2001 12:30'! 437967setUpdateServer: groupName 437968 "Utilities setUpdateServer: 'Squeakland' " 437969 | entry index | 437970 437971 437972 entry := UpdateUrlLists detect: [:each | each first = groupName] ifNone: [^self]. 437973 index := UpdateUrlLists indexOf: entry. 437974 UpdateUrlLists removeAt: index. 437975 UpdateUrlLists addFirst: entry! ! 437976 437977!Utilities class methodsFor: 'fetching updates' stamp: 'ar 9/27/2005 20:15'! 437978summariesForUpdates: startNumber through: stopNumber 437979 "Answer the concatenation of summary strings for updates numbered in the given range" 437980 437981 ^ String streamContents: [:aStream | 437982 ((ChangeSet changeSetsNamedSuchThat: 437983 [:aName | aName first isDigit and: 437984 [aName initialIntegerOrNil >= startNumber] and: 437985 [aName initialIntegerOrNil <= stopNumber]]) asSortedCollection: 437986 [:a :b | a name < b name]) do: 437987 [:aChangeSet | aStream cr; nextPutAll: aChangeSet summaryString]] 437988 437989"Utilities summariesForUpdates: 4899 through: 4903" 437990 437991! ! 437992 437993!Utilities class methodsFor: 'fetching updates' stamp: 'di 4/30/2001 11:28'! 437994updateComment 437995"The following used to be at the beginning of the update file. 437996 Now it is here to simplify parsing the file... 437997 437998* To add a new update: Name it starting with a new four-digit code. 437999* Do not use %, /, *, space, or more than one period in the name of an update file. 438000* The update name does not need to have any relation to the version name. 438001* Figure out which versions of the system the update makes sense for. 438002* Add the name of the file to each version's category below. 438003* Put this file and the update file on all of the servers. 438004* 438005* To make a new version of the system: Pick a name for it (no restrictions) 438006* Put # and exactly that name on a new line at the end of this file. 438007* During the release process, fill in exactly that name in the dialog box. 438008* Put a copy of updates.list on the server. 438009* 438010* Special file with a different name for Disney Internal Updates. 438011* No need to move or rename files to release them to external updates. 438012"! ! 438013 438014!Utilities class methodsFor: 'fetching updates' stamp: 'sw 10/13/1998 16:03'! 438015updateFromServer 438016 "Update the image by loading all pending updates from the server. Also save local copies of the update files if the #updateSavesFile preference is set to true" 438017 438018 self readServerUpdatesSaveLocally: Preferences updateSavesFile updateImage: true! ! 438019 438020!Utilities class methodsFor: 'fetching updates' stamp: 'sw 1/10/1999 01:59'! 438021updateFromServerThroughUpdateNumber: aNumber 438022 "Update the image by loading all pending updates from the server. Also save local copies of the update files if the #updateSavesFile preference is set to true" 438023 438024 self readServerUpdatesThrough: aNumber saveLocally: Preferences updateSavesFile updateImage: true! ! 438025 438026!Utilities class methodsFor: 'fetching updates' stamp: 'tk 5/7/1998 17:03'! 438027updateUrlLists 438028 438029 UpdateUrlLists ifNil: [UpdateUrlLists := OrderedCollection new]. 438030 ^ UpdateUrlLists! ! 438031 438032!Utilities class methodsFor: 'fetching updates' stamp: 'di 4/29/2001 14:04'! 438033writeList: listContents toStream: strm 438034 "Write a parsed updates.list out as text. 438035 This is the inverse of parseListContents:" 438036 438037 | fileNames version | 438038 strm reset. 438039 listContents do: 438040 [:pair | version := pair first. fileNames := pair last. 438041 strm nextPut: $#; nextPutAll: version; cr. 438042 fileNames do: [:fileName | strm nextPutAll: fileName; cr]]. 438043 strm close! ! 438044 438045!Utilities class methodsFor: 'fetching updates' stamp: 'RAA 12/17/2000 16:19'! 438046zapUpdateDownloader 438047 438048 UpdateDownloader ifNotNil: [UpdateDownloader terminate]. 438049 UpdateDownloader := nil.! ! 438050 438051 438052!Utilities class methodsFor: 'identification' stamp: 'MiguelCoba 7/25/2009 02:08'! 438053changeStamp 438054 "Answer a string to be pasted into source code to mark who changed it and when." 438055 ^ Author fullName , ' ' , Date today mmddyyyy, ' ', 438056 ((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! ! 438057 438058!Utilities class methodsFor: 'identification' stamp: 'MiguelCoba 7/25/2009 02:19'! 438059changeStampPerSe 438060 "Answer a string to be pasted into source code to mark who changed it and when." 438061 438062 ^ (Author fullNamePerSe ifNil: ['.']) , ' ' , Date today mmddyyyy, ' ', 438063 ((String streamContents: [:s | Time now print24: true on: s]) 438064 copyFrom: 1 to: 5)! ! 438065 438066!Utilities class methodsFor: 'identification' stamp: 'tk 4/10/1998 07:16'! 438067dateStamp 438068 "Utilities dateStamp" 438069 ^ Date today mmddyyyy, ' ', 438070 ((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! ! 438071 438072!Utilities class methodsFor: 'identification' stamp: 'marcus.denker 11/18/2008 11:18'! 438073dateTimeSuffix 438074 "Answer a string which indicates the date and time, intended for use in building fileout filenames, etc." 438075 438076 ^self monthDayTime24StringFrom: Time primSecondsClock! ! 438077 438078!Utilities class methodsFor: 'identification' stamp: 'di 6/13/97 13:52'! 438079fixStamp: changeStamp 438080 | parts | 438081 parts := changeStamp findTokens: ' '. 438082 (parts size > 0 and: [parts last first isLetter]) ifTrue: 438083 ["Put initials first in all time stamps..." 438084 ^ String streamContents: 438085 [:s | s nextPutAll: parts last. 438086 parts allButLast do: [:p | s space; nextPutAll: p]]]. 438087 ^ changeStamp! ! 438088 438089!Utilities class methodsFor: 'identification' stamp: 'stephane.ducasse 5/23/2009 14:04'! 438090methodsWithInitials: targetInitials 438091 "Based on a do-it contributed to the Squeak mailing list by Goran Hultgen: 438092 Browse methods whose initials (in the time-stamp, as logged to disk) match the given initials. 438093 Print out the complete time-stamp table to the Transcript. 438094 Answer a list of (initials -> count) associations. 438095 438096CAUTION: It may take several minutes for this to complete." 438097 438098 "Time millisecondsToRun: [Utilities methodsWithInitials: 'bf']" 438099 438100 | initials timeStamp allSubmitters | 438101 initials := ''. 438102 timeStamp := ''. 438103 allSubmitters := Bag new. 438104 self systemNavigation 438105 browseAllSelect: 438106 [:cm | 438107 timeStamp := Utilities timeStampForMethod: cm. 438108 initials := timeStamp isEmpty 438109 ifTrue: 438110 [''] 438111 ifFalse: 438112 [timeStamp substrings first]. 438113 initials := initials isEmpty 438114 ifTrue: 438115 ['<no time stamp>'] 438116 ifFalse: 438117 [initials first isDigit 438118 ifTrue: 438119 ['<date>'] 438120 ifFalse: 438121 [initials]]. 438122 allSubmitters add: initials. 438123 (initials = targetInitials)] 438124 name: ('Methods with initials ', targetInitials) 438125 autoSelect: nil. 438126 438127 allSubmitters sortedCounts do: [:elem | Transcript cr; show: elem asString]. 438128 ^ allSubmitters 438129! ! 438130 438131!Utilities class methodsFor: 'identification' stamp: 'sw 11/13/1999 23:03'! 438132monthDayTime24StringFrom: aSecondCount 438133 | aDate aTime | 438134 "From the date/time represented by aSecondCount, produce a string which indicates the date and time in the compact form 438135 ddMMMhhmm where dd is a two-digit day-of-month, MMM is the alpha month abbreviation and hhmm is the time on a 24-hr clock. 438136 438137 Utilities monthDayTime24StringFrom: Time primSecondsClock 438138" 438139 438140 aDate := Date fromSeconds: aSecondCount. 438141 aTime := Time fromSeconds: aSecondCount \\ 86400. 438142 438143 ^ (aDate dayOfMonth asTwoCharacterString), 438144 (aDate monthName copyFrom: 1 to: 3), 438145 (aTime hhmm24)! ! 438146 438147!Utilities class methodsFor: 'identification' stamp: 'sw 11/13/1999 23:03'! 438148monthDayTimeStringFrom: aSecondCount 438149 | aDate aTime | 438150 "From the date/time represented by aSecondCount, produce a string which indicates the date and time in the form: 438151 ddMMMhhmmPP where: 438152 dd is a two-digit day-of-month, 438153 MMM is the alpha month abbreviation, 438154 hhmm is the time, 438155 PP is either am or pm 438156 438157 Utilities monthDayTimeStringFrom: Time primSecondsClock 438158" 438159 438160 aDate := Date fromSeconds: aSecondCount. 438161 aTime := Time fromSeconds: aSecondCount \\ 86400. 438162 438163 ^ (aDate dayOfMonth asTwoCharacterString), 438164 (aDate monthName copyFrom: 1 to: 3), 438165 ((aTime hours \\ 12) asTwoCharacterString), 438166 (aTime minutes asTwoCharacterString), 438167 (aTime hours > 12 ifTrue: ['pm'] ifFalse: ['am'])! ! 438168 438169 438170!Utilities class methodsFor: 'initialization' stamp: 'adrian_lienhard 3/7/2009 17:40'! 438171initialize 438172 RecentSubmissions := OrderedCollection new. 438173 self registerInFlapsRegistry. 438174 438175 (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [ 438176 TheWorldMenu registerOpenCommand: {'Recent Submissions'. {self. #browseRecentSubmissions}}]! ! 438177 438178!Utilities class methodsFor: 'initialization' stamp: 'asm 4/11/2003 12:12'! 438179registerInFlapsRegistry 438180 "Register the receiver in the system's flaps registry" 438181 self environment 438182 at: #Flaps 438183 ifPresent: [:cl | cl registerQuad: #(Utilities recentSubmissionsWindow 'Recent' 'A message browser that tracks the most recently-submitted methods') 438184 forFlapNamed: 'Tools'.]! ! 438185 438186!Utilities class methodsFor: 'initialization' stamp: 'NS 1/26/2004 09:52'! 438187startUp 438188 SystemChangeNotifier uniqueInstance notify: self ofAllSystemChangesUsing: #event:.! ! 438189 438190!Utilities class methodsFor: 'initialization' stamp: 'asm 4/11/2003 12:42'! 438191unload 438192 "Unload the receiver from global registries" 438193 438194 self environment at: #Flaps ifPresent: [:cl | 438195 cl unregisterQuadsWithReceiver: self] ! ! 438196 438197 438198!Utilities class methodsFor: 'miscellaneous'! 438199awaitMouseUpIn: box repeating: doBlock ifSucceed: succBlock 438200 "The mouse has gone down in box; track the mouse, inverting the box while it's within, and if, on mouse up, the cursor was still within the box, execute succBlock. While waiting for the mouse to come up, repeatedly execute doBlock. 5/11/96 sw 438201 6/10/96 sw: call new method that adds extra feature" 438202 438203 ^ self awaitMouseUpIn: box whileMouseDownDo: doBlock whileMouseDownInsideDo: [] ifSucceed: succBlock! ! 438204 438205!Utilities class methodsFor: 'miscellaneous' stamp: 'JMM 3/31/2000 20:41'! 438206awaitMouseUpIn: box whileMouseDownDo: doBlock1 whileMouseDownInsideDo: doBlock2 ifSucceed: succBlock 438207 "The mouse has gone down in box; track the mouse, inverting the box while it's within, and if, on mouse up, the cursor was still within the box, execute succBlock. While waiting for the mouse to come up, repeatedly execute doBlock1, and also, if the cursor is within the box, execute doBlock2. 6/10/96 sw 4382083/31/00 JMM added logic to stop multiple redraws" 438209 438210 | p inside lightForm darkForm isLight | 438211 438212 p := Sensor cursorPoint. 438213 inside := box insetBy: 1. 438214 isLight := true. 438215 lightForm := Form fromDisplay: inside. 438216 darkForm := lightForm deepCopy reverse. 438217 [Sensor anyButtonPressed] whileTrue: 438218 [doBlock1 value. 438219 (box containsPoint: (p := Sensor cursorPoint)) 438220 ifTrue: [doBlock2 value. 438221 isLight ifTrue: 438222 [isLight := false. 438223 darkForm displayAt: inside origin]] 438224 ifFalse: [isLight ifFalse: 438225 [isLight := true. 438226 lightForm displayAt: inside origin]]]. 438227 (box containsPoint: p) 438228 ifTrue: [lightForm displayAt: inside origin. 438229 ^ succBlock value] 438230! ! 438231 438232!Utilities class methodsFor: 'miscellaneous' stamp: 'alain.plantec 6/1/2008 23:13'! 438233cleanseOtherworldlySteppers 438234 "If the current project is a morphic one, then remove from its steplist 438235 those morphs that are not really in the world" 438236 "Utilities cleanseOtherworldlySteppers" 438237 | old delta | 438238 old := self currentWorld stepListSize. 438239 self currentWorld steppingMorphsNotInWorld 438240 do: [:m | m delete]. 438241 self currentWorld cleanseStepList. 438242 (delta := old - self currentWorld stepListSize) > 0 438243 ifTrue: [Transcript cr; show: delta asString , ' morphs removed from steplist']! ! 438244 438245!Utilities class methodsFor: 'miscellaneous' stamp: 'nk 5/18/2003 13:03'! 438246decimalPlacesForFloatPrecision: precision 438247 "Answer the number of decimal places that correspond to the given floatPrecision" 438248 438249 ^ (#(1 0.1 0.01 0.001 0.0001 0.00001 0.000001 0.0000001 0.00000001 0.000000001) indexOf: precision ifAbsent: [ ^precision log negated floor ]) - 1 438250 438251" 438252#(1 0.1 0.01 0.001 0.0001 0.00001 0.000001 0.0000001 0.00000001 0.000000001) collect: [:prec | Utilities decimalPlacesForFloatPrecision: prec] 438253"! ! 438254 438255!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 11/21/2001 10:58'! 438256doesMethod: aSelector forClass: aClass bearInitials: initials 438257 "Answer whether a method bears the given initials at the head of its time stamp" 438258 438259 | aTimeStamp implementingClass aMethod | 438260 implementingClass := aClass whichClassIncludesSelector: aSelector. 438261 implementingClass ifNil: [^ false]. 438262 (aMethod := implementingClass compiledMethodAt: aSelector) 438263 ifNil: [^ false]. 438264 ^ (aTimeStamp := self timeStampForMethod: aMethod) notNil and: 438265 [aTimeStamp beginsWith: initials]! ! 438266 438267!Utilities class methodsFor: 'miscellaneous' stamp: 'alain.plantec 6/1/2008 23:15'! 438268emergencyCollapse 438269 ^ self 438270! ! 438271 438272!Utilities class methodsFor: 'miscellaneous' stamp: 'sd 4/17/2003 21:04'! 438273fixUpProblemsWithAllCategory 438274 "Moves all methods that are in formally classified a category named '-- all --' into the default 'as yet unclassified' category" 438275 438276 "Utilities fixUpProblemsWithAllCategory" 438277 438278 | org aCategory methodCount classCount any | 438279 self flag: #ShouldBeMovedInClassOrganization. 438280 methodCount := 0. 438281 classCount := 0. 438282 self systemNavigation allBehaviorsDo: 438283 [:aClass | org := aClass organization. 438284 (org categories includes: #'-- all --') ifTrue: 438285 [any := false. 438286 aClass selectorsDo: 438287 [:aSelector | 438288 aCategory := org categoryOfElement: aSelector. 438289 aCategory = #'-- all --' ifTrue: 438290 [org classify: aSelector under: ClassOrganizer default suppressIfDefault: false. 438291 Transcript cr; show: aClass name, ' >> ', aSelector. 438292 methodCount := methodCount + 1. 438293 any := true]]. 438294 any ifTrue: [classCount := classCount + 1]. 438295 org removeEmptyCategories]]. 438296 Transcript cr; show: methodCount printString, ' methods in ', classCount printString, ' classes moved from "-- all --" to "as yet unclassified"' 438297! ! 438298 438299!Utilities class methodsFor: 'miscellaneous' stamp: 'dtl 11/25/2004 22:10'! 438300floatPrecisionForDecimalPlaces: places 438301 "Answer the floatPrecision that corresponds to the given number of decimal places" 438302 438303 ^ places caseOf: 438304 {[0]->[1] . 438305 [1]->[0.1] . 438306 [2]->[0.01] . 438307 [3]->[0.001] . 438308 [4]->[0.0001] . 438309 [5]->[0.00001] . 438310 [6]->[0.000001] . 438311 [7]->[0.0000001] . 438312 [8]->[0.00000001] . 438313 [9]->[0.000000001]} 438314 otherwise: 438315 [(10.0 raisedTo: places negated) asFloat] 438316 438317" 438318(0 to: 6) collect: [:i | Utilities floatPrecisionForDecimalPlaces: i] 438319(-10 to: 20) collect: [:i | Utilities floatPrecisionForDecimalPlaces: i] 438320"! ! 438321 438322!Utilities class methodsFor: 'miscellaneous' stamp: 'nk 2/15/2004 09:36'! 438323garbageCollectAndReport 438324 "Do a garbage collection, and report results to the user." 438325 438326 | cc reportString | 438327 reportString := String streamContents: 438328 [:aStream | 438329 aStream nextPutAll: Smalltalk bytesLeftString. 438330 Smalltalk at: #Command ifPresent: 438331 [:cmdClass | 438332 (cc := cmdClass instanceCount) > 0 ifTrue: 438333 [aStream cr; nextPutAll: 438334 ('(note: there are ', cc printString, 438335 ' undo record(s) present in your 438336system; purging them may free up more space.)')]]]. 438337 438338 self inform: reportString 438339! ! 438340 438341!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 11/16/2001 14:43'! 438342getterSelectorFor: identifier 438343 "Answer the corresponding getter. Two idiosyncratic vectorings herein... " 438344 438345 "Utilities getterSelectorFor: #elvis" 438346 438347 | aSymbol | 438348 (aSymbol := identifier asSymbol) == #isOverColor: ifTrue: [^ #seesColor:]. 438349 aSymbol == #copy ifTrue: [^ #getNewClone]. 438350 438351 ^ ('get', (identifier asString capitalized)) asSymbol! ! 438352 438353!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 5/19/2000 16:04'! 438354inherentSelectorForGetter: aGetterSelector 438355 "Given a selector of the form #getAbc, return the inherent slotname selector that corresponds, which is to say, getterSelector with the leading 'get' removed and with the next character forced to lower case; this is the inverse of #getterSelectorFor:" 438356 438357 "Utilities inherentSelectorForGetter: #getWidth" 438358 ((aGetterSelector size < 4) or: [(aGetterSelector beginsWith: 'get') not]) 438359 ifTrue: [ ^ aGetterSelector]. 438360 ^ ((aGetterSelector at: 4) asLowercase asString, (aGetterSelector copyFrom: 5 to: aGetterSelector size)) asSymbol! ! 438361 438362!Utilities class methodsFor: 'miscellaneous' stamp: 'mdr 9/4/2000 11:07'! 438363instanceComparisonsBetween: fileName1 and: fileName2 438364 "For differential results, run printSpaceAnalysis twice with different fileNames, 438365 then run this method... 438366 Smalltalk printSpaceAnalysis: 0 on: 'STspace.text1'. 438367 --- do something that uses space here --- 438368 Smalltalk printSpaceAnalysis: 0 on: 'STspace.text2'. 438369 Smalltalk instanceComparisonsBetween: 'STspace.text1' and 'STspace.text2'" 438370 438371 | instCountDict report f aString items className newInstCount oldInstCount newSpace oldPair oldSpace | 438372 instCountDict := Dictionary new. 438373 report := ReadWriteStream on: ''. 438374 f := FileStream readOnlyFileNamed: fileName1. 438375 [f atEnd] whileFalse: 438376 [aString := f upTo: Character cr. 438377 items := aString findTokens: ' '. 438378 (items size == 4 or: [items size == 5]) ifTrue: 438379 [instCountDict at: items first put: (Array with: items third asNumber with: items fourth asNumber)]]. 438380 f close. 438381 438382 f := FileStream readOnlyFileNamed: fileName2. 438383 [f atEnd] whileFalse: 438384 [aString := f upTo: Character cr. 438385 items := aString findTokens: ' '. 438386 (items size == 4 or: [items size == 5]) ifTrue: 438387 [className := items first. 438388 newInstCount := items third asNumber. 438389 newSpace := items fourth asNumber. 438390 oldPair := instCountDict at: className ifAbsent: [nil]. 438391 oldInstCount := oldPair ifNil: [0] ifNotNil: [oldPair first]. 438392 oldSpace := oldPair ifNil: [0] ifNotNil: [oldPair second]. 438393 oldInstCount ~= newInstCount ifTrue: 438394 [report nextPutAll: (newInstCount - oldInstCount) printString; tab; nextPutAll: (newSpace - oldSpace) printString; tab; nextPutAll: className asString; cr]]]. 438395 f close. 438396 438397 (StringHolder new contents: report contents) 438398 openLabel: 'Instance count differentials between ', fileName1, ' and ', fileName2! ! 438399 438400!Utilities class methodsFor: 'miscellaneous'! 438401keyLike: aString satisfying: aBlock 438402 "Return a key like aString that satisfies aBlock. The block should provide a test for acceptability -- typically the test is about whether the key is already in use. aBlock should return a boolean. 8/11/96 sw" 438403 438404 | stemAndSuffix suffix stem newKey | 438405 (aBlock value: aString) ifTrue: [^ aString]. 438406 stemAndSuffix := aString stemAndNumericSuffix. 438407 suffix := stemAndSuffix last + 1. 438408 stem := stemAndSuffix first. 438409 [aBlock value: (newKey := stem, suffix printString)] 438410 whileFalse: 438411 [suffix := suffix + 1]. 438412 ^ newKey 438413! ! 438414 438415!Utilities class methodsFor: 'miscellaneous'! 438416keyLike: aString withTrailing: trailerString satisfying: aBlock 438417 "Return a key like (aString, trailerString) that satisfies aBlock. The block should provide a test for acceptability -- typically the test is about whether the key is already in use. aBlock should return a boolean. 8/11/96 sw" 438418 438419 | stemAndSuffix suffix stem composite | 438420 composite := aString, trailerString. 438421 (aBlock value: composite) ifTrue: [^ composite]. 438422 stemAndSuffix := aString stemAndNumericSuffix. 438423 suffix := stemAndSuffix last + 1. 438424 stem := stemAndSuffix first. 438425 [aBlock value: (composite := stem, suffix printString, trailerString)] 438426 whileFalse: 438427 [suffix := suffix + 1]. 438428 ^ composite 438429! ! 438430 438431!Utilities class methodsFor: 'miscellaneous' stamp: 'md 11/14/2003 18:02'! 438432methodDiffFor: aString class: aClass selector: aSelector prettyDiffs: prettyDiffBoolean 438433 "Return a string comprising a source-code diff between an existing method and the source-code in aString. DO prettyDiff if prettyDiffBoolean is true." 438434 438435 ^ (aClass notNil and: [aClass includesSelector: aSelector]) 438436 ifTrue: 438437 [TextDiffBuilder 438438 buildDisplayPatchFrom: (aClass sourceCodeAt: aSelector) 438439 to: aString 438440 inClass: aClass 438441 prettyDiffs: prettyDiffBoolean] 438442 ifFalse: 438443 [aString copy]! ! 438444 438445!Utilities class methodsFor: 'miscellaneous'! 438446nextClockwiseSideAfter: aSide 438447 aSide == #left ifTrue: 438448 [^ #top]. 438449 aSide == #right ifTrue: 438450 [^ #bottom]. 438451 aSide == #top ifTrue: 438452 [^ #right]. 438453 ^ #left! ! 438454 438455!Utilities class methodsFor: 'miscellaneous'! 438456oppositeCornerFrom: aCorner 438457 "Answer the corner diagonally opposite to aCorner. 6/27/96 sw" 438458 438459 aCorner == #topLeft 438460 ifTrue: 438461 [^ #bottomRight]. 438462 aCorner == #topRight 438463 ifTrue: 438464 [^ #bottomLeft]. 438465 aCorner == #bottomLeft 438466 ifTrue: 438467 [^ #topRight]. 438468 ^ #topLeft! ! 438469 438470!Utilities class methodsFor: 'miscellaneous'! 438471oppositeModeTo: aMode 438472 aMode == #readOnly ifTrue: [^ #writeOnly]. 438473 aMode == #writeOnly ifTrue: [^ #readOnly]. 438474 ^ aMode! ! 438475 438476!Utilities class methodsFor: 'miscellaneous'! 438477oppositeSideTo: aSide 438478 aSide == #left ifTrue: 438479 [^ #right]. 438480 aSide == #right ifTrue: 438481 [^ #left]. 438482 aSide == #top ifTrue: 438483 [^ #bottom]. 438484 ^ #top! ! 438485 438486!Utilities class methodsFor: 'miscellaneous' stamp: 'jmv 5/10/2009 09:22'! 438487reconstructTextWindowsFromFileNamed: aName 438488 "Utilities reconstructTextWindowsFromFileNamed: 'TextWindows'" 438489 | aReferenceStream aDict | 438490 aReferenceStream := ReferenceStream fileNamed: aName. 438491 aDict := aReferenceStream next. 438492 aReferenceStream close. 438493 aDict associationsDo: 438494 [:assoc | 438495 (StringHolder new contents: assoc value) openAsMorphLabel: assoc key ]! ! 438496 438497!Utilities class methodsFor: 'miscellaneous' stamp: 'dc 5/30/2008 10:17'! 438498setClassAndSelectorFrom: messageIDString in: csBlock 438499 "Decode strings of the form <className> [class] <selectorName>. If <className> does not exist as a class, use nil for the class in the block" 438500 | aStream aClass maybeClass sel | 438501 (messageIDString isKindOf: MethodReference) ifTrue: [ ^ messageIDString setClassAndSelectorIn: csBlock ]. 438502 aStream := messageIDString readStream. 438503 aClass := Smalltalk 438504 at: (aStream upTo: $ ) asSymbol 438505 ifAbsent: [ nil ]. 438506 maybeClass := aStream upTo: $ . 438507 sel := aStream upTo: $ . 438508 maybeClass = 'class' & (sel size ~= 0) 438509 ifTrue: 438510 [ aClass 438511 ifNil: 438512 [ csBlock 438513 value: nil 438514 value: sel asSymbol ] 438515 ifNotNil: 438516 [ csBlock 438517 value: aClass class 438518 value: sel asSymbol ] ] 438519 ifFalse: 438520 [ csBlock 438521 value: aClass 438522 value: maybeClass asSymbol 438523 438524 438525 " 438526Utilities setClassAndSelectorFrom: 'Utilities class oppositeModeTo:' in: [:aClass :aSelector | Transcript cr; show: 'Class = ', aClass name printString, ' selector = ', aSelector printString]. 438527 438528Utilities setClassAndSelectorFrom: 'MessageSet setClassAndSelectorIn:' in: [:aClass :aSelector | Transcript cr; show: 'Class = ', aClass name printString, ' selector = ', aSelector printString]. 438529" ]! ! 438530 438531!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 1/30/98 15:12'! 438532setterSelectorFor: aName 438533 "Utilities setterSelectorFor: #elvis" 438534 ^ (('set', (aName asString capitalized)), ':') asSymbol! ! 438535 438536!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 2/16/1999 18:07'! 438537simpleSetterFor: aSymbol 438538 "Utilities simpleSetterFor: #right" 438539 ^ (aSymbol, ':') asSymbol! ! 438540 438541!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 9/8/2000 10:02'! 438542steplistToolsWorkspace 438543 ^ ((StringHolder new contents: 'self currentWorld listOfSteppingMorphs asArray inspectWithLabel: ''stepping morphs''. 438544Utilities cleanseOtherworldlySteppers. 438545self currentWorld steppingMorphsNotInWorld do: [:m | m delete]. 438546self currentWorld stepListSummary. 438547self currentWorld stepListSize. 438548self currentHand attachMorph: FrameRateMorph new') embeddedInMorphicWindowLabeled: 'Steplist workspace') 438549 438550setWindowColor: (Color r: 0.9 g: 0.7 b: 0.5); 438551 openInWorld: self currentWorld extent: (550 @ 140) 438552 438553"Utilities steplistToolsWorkspace"! ! 438554 438555!Utilities class methodsFor: 'miscellaneous' stamp: 'alain.plantec 6/1/2008 23:21'! 438556storeTextWindowContentsToFileNamed: aName 438557 "Utilities storeTextWindowContentsToFileNamed: 'TextWindows'" 438558 "there is a reference to World, but this method seems to be unused" 438559 | windows aDict assoc aRefStream | 438560 aDict := Dictionary new. 438561 windows := World submorphs 438562 select: [:m | m isSystemWindow]. 438563 windows 438564 do: [:w | 438565 assoc := w titleAndPaneText. 438566 assoc 438567 ifNotNil: [w holdsTranscript 438568 ifFalse: [aDict add: assoc]]]. 438569 aDict size = 0 438570 ifTrue: [^ self inform: 'no windows found to export.']. 438571 aRefStream := ReferenceStream fileNamed: aName. 438572 aRefStream nextPut: aDict. 438573 aRefStream close. 438574 self inform: 'Done!! ' , aDict size printString , ' window(s) exported.'! ! 438575 438576!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 7/29/2002 02:23'! 438577timeStampForMethod: method 438578 "Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available." 438579 "Utilities timeStampForMethod: (Utilities class compiledMethodAt: #timeStampForMethod:)" 438580 438581 ^ method timeStamp! ! 438582 438583 438584!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 7/29/2002 02:18'! 438585assureMostRecentSubmissionExists 438586 "Make certain that the most recent submission exists" 438587 438588 [RecentSubmissions size > 0 and: 438589 [RecentSubmissions last isValid not]] whileTrue: 438590 [RecentSubmissions removeLast].! ! 438591 438592!Utilities class methodsFor: 'recent method submissions' stamp: 'nk 8/30/2004 08:02'! 438593dumpAnyOldStyleRecentSubmissions 438594 438595 "simplify conversion by purging those recent submissions which are still Strings" 438596 438597 RecentSubmissions := self recentMethodSubmissions reject: [ :each | 438598 each isString 438599 ].! ! 438600 438601!Utilities class methodsFor: 'recent method submissions' stamp: 'NS 4/12/2004 22:47'! 438602event: anEvent 438603 "Hook for SystemChangeNotifier" 438604 438605 (anEvent isCommented and: [anEvent itemKind = SystemChangeNotifier classKind]) 438606 ifTrue: [self noteMethodSubmission: #Comment forClass: anEvent item]. 438607 ((anEvent isAdded or: [anEvent isModified]) and: [anEvent itemKind = SystemChangeNotifier methodKind]) 438608 ifTrue: [anEvent itemRequestor ifNotNil: [self noteMethodSubmission: anEvent itemSelector forClass: anEvent itemClass]]. 438609 ((anEvent isAdded or: [anEvent isModified]) and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue:[ 438610 InMidstOfFileinNotification signal 438611 ifFalse: [Utilities changed: #recentMethodSubmissions]. 438612 ].! ! 438613 438614!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 7/29/2002 02:12'! 438615mostRecentlySubmittedMessage 438616 "Answer a string indicating the most recently submitted method that is still extant" 438617 438618 self flag: #mref. "fix for faster references to methods" 438619 438620 self assureMostRecentSubmissionExists. 438621 ^ RecentSubmissions last asStringOrText asString! ! 438622 438623!Utilities class methodsFor: 'recent method submissions' stamp: 'RAA 5/28/2001 10:53'! 438624noteMethodSubmission: selectorName forClass: class 438625 438626 | submission | 438627 438628 self flag: #mref. "fix for faster references to methods" 438629 438630 self recentMethodSubmissions. "ensure it is valid" 438631 class wantsChangeSetLogging ifFalse: [^ self]. 438632 self purgeRecentSubmissionsOfMissingMethods. 438633 submission := class name asString, ' ', selectorName. 438634 RecentSubmissions removeAllSuchThat: [ :each | 438635 each asStringOrText = submission 438636 ]. 438637 RecentSubmissions size >= self numberOfRecentSubmissionsToStore ifTrue: [ 438638 RecentSubmissions removeFirst 438639 ]. 438640 RecentSubmissions addLast: ( 438641 MethodReference new 438642 setClass: class 438643 methodSymbol: selectorName 438644 stringVersion: submission 438645 ) 438646! ! 438647 438648!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 7/28/2002 23:20'! 438649numberOfRecentSubmissionsToStore 438650 "Answer how many methods back the 'recent method submissions' history should store" 438651 438652 ^ Preferences parameterAt: #numberOfRecentSubmissionsToStore ifAbsentPut: [30]! ! 438653 438654!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 7/28/2002 23:52'! 438655numberOfRecentSubmissionsToStore: aNumber 438656 "Set the number of Recent Submissions to store" 438657 438658 Preferences setParameter: #numberOfRecentSubmissionsToStore to: aNumber! ! 438659 438660!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 9/26/2002 19:16'! 438661purgeFromRecentSubmissions: aMethodReference 438662 "Purge any reference found in RecentSubmissions to the method supplied" 438663 438664 RecentSubmissions := RecentSubmissions select: 438665 [:aSubmission | 438666 Utilities setClassAndSelectorFrom: aSubmission in: 438667 [:aClass :aSelector | (aClass ~~ aMethodReference actualClass) or: [aSelector ~~ aMethodReference methodSymbol]]]! ! 438668 438669!Utilities class methodsFor: 'recent method submissions' stamp: 'marcus.denker 9/14/2008 19:02'! 438670purgeRecentSubmissionsOfMissingMethods 438671 "Utilities purgeRecentSubmissionsOfMissingMethods" 438672 438673 | keep | 438674 RecentSubmissions := RecentSubmissions select: 438675 [:aSubmission | 438676 Utilities setClassAndSelectorFrom: aSubmission in: 438677 [:aClass :aSelector | 438678 keep := aClass notNil 438679 and: [aClass isInMemory 438680 and: [aSelector == #Comment or: [(aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil]]]]. 438681 keep]! ! 438682 438683!Utilities class methodsFor: 'recent method submissions' stamp: 'marcus.denker 9/14/2008 19:02'! 438684recentMethodSubmissions 438685 "Answer the list of recent method submissions, in order. 5/16/96 sw" 438686 438687 RecentSubmissions ifNil: [RecentSubmissions := OrderedCollection new]. 438688 ^ RecentSubmissions! ! 438689 438690!Utilities class methodsFor: 'recent method submissions' stamp: 'nb 6/17/2003 12:25'! 438691revertLastMethodSubmission 438692 | changeRecords lastSubmission theClass theSelector | 438693 "If the most recent method submission was a method change, revert 438694 that change, and if it was a submission of a brand-new method, 438695 remove that method." 438696 438697 RecentSubmissions isEmptyOrNil ifTrue: [^ Beeper beep]. 438698 lastSubmission := RecentSubmissions last. 438699 theClass := lastSubmission actualClass ifNil: [^ Beeper beep]. 438700 theSelector := lastSubmission methodSymbol. 438701 changeRecords := theClass changeRecordsAt: theSelector. 438702 changeRecords isEmptyOrNil ifTrue: [^ Beeper beep]. 438703 changeRecords size == 1 438704 ifTrue: 438705 ["method has no prior version, so reverting in this case means removing" 438706 theClass removeSelector: theSelector] 438707 ifFalse: 438708 [changeRecords second fileIn]. 438709 438710"Utilities revertLastMethodSubmission"! ! 438711 438712 438713 438714!Utilities class methodsFor: 'summer97 additions' stamp: 'alain.plantec 2/6/2009 17:42'! 438715chooseFileWithSuffix: aSuffix 438716 "Utilities chooseFileWithSuffix: '.gif'" 438717 | aList | 438718 aList := FileDirectory default fileNamesMatching: '*', aSuffix. 438719 aList size > 0 438720 ifTrue: 438721 [^ UIManager default chooseFrom: aList values: aList title: 'Choose a file' translated] 438722 ifFalse: 438723 [self inform: 'Sorry, there are no files 438724whose names end with' translated, ' "', aSuffix, '".'. 438725 ^ nil]! ! 438726 438727!Utilities class methodsFor: 'summer97 additions' stamp: 'alain.plantec 2/6/2009 17:43'! 438728chooseFileWithSuffixFromList: aSuffixList withCaption: aCaption 438729 "Pop up a list of all files in the default directory which have a suffix in the list. Return #none if there are none; return nil if the user backs out of the menu without making a choice." 438730 "Utilities chooseFileWithSuffixFromList: #('.gif' '.jpg')" 438731 | aList | 438732 aList := OrderedCollection new. 438733 aSuffixList do: 438734 [:aSuffix | aList addAll: (FileDirectory default fileNamesMatching: '*', aSuffix)]. 438735 ^ aList size > 0 438736 ifTrue: 438737 [ UIManager default chooseFrom: aList values: aList title:aCaption] 438738 ifFalse: 438739 [#none]! ! 438740 438741!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 9/13/97 20:44'! 438742classCategoriesStartingWith: aPrefix 438743 "Answer a list of system class categories beginning with the given prefix" 438744 438745 "Utilities classCategoriesStartingWith: 'Files'" 438746 438747 ^ SystemOrganization categories select: 438748 [:aCat | (aCat asString findString: aPrefix startingAt: 1) = 1]! ! 438749 438750!Utilities class methodsFor: 'summer97 additions' stamp: 'stephane.ducasse 1/23/2009 21:37'! 438751classFromPattern: pattern withCaption: aCaption 438752 "If there is a class whose name exactly given by pattern, return it. 438753 If there is only one class in the system whose name matches pattern, return it. 438754 Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen. 438755 This method ignores tab, space, & cr characters in the pattern" 438756 438757 self deprecated: 'Use SystemNavigation>>classFromPattern: pattern withCaption: aCaption'. 438758 ^ SystemNavigation default classFromPattern: pattern withCaption: aCaption.! ! 438759 438760!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 10/6/1998 14:09'! 438761graphicsFileSuffixes 438762 "Answer a list of filename suffixes which signal file content which we are able to internalize" 438763 438764 ^#('.gif' '.bmp' '.jpg' '.jpeg' '.jpe', '.form')! ! 438765 438766 438767!Utilities class methodsFor: 'closure support' stamp: 'MikeRoberts 9/20/2009 12:45'! 438768compileUsingClosures "Utilities compileUsingClosures" 438769 "Recompile the system and do some minimal clean-ups" 438770 | classes compilationErrors | 438771 Preferences setPreference: #allowBlockArgumentAssignment toValue: true. 438772 compilationErrors := Set new. 438773 classes := Smalltalk forgetDoIts allClasses reject: [:c| c name == #GeniePlugin]. 438774 438775 'Recompiling The System' displayProgressAt: Sensor cursorPoint 438776 from: 0 to: classes size during:[:bar | 438777 classes withIndexDo:[:c :i| 438778 bar value: i. 438779 { c. c class } do:[:b| 438780 "Transcript cr; print: b; endEntry." 438781 b selectors "asSortedCollection" do:[:s| 438782 "Transcript cr; show: b asString, '>>', s." 438783 [b recompile: s from: b] on: Error do:[:ex| 438784 Transcript 438785 cr; nextPutAll: 'COMPILATION ERROR: '; 438786 print: b; nextPutAll: '>>'; nextPutAll: s; flush. 438787 compilationErrors add: (MethodReference class: b selector: s)]]]]]. 438788 438789 (Smalltalk respondsTo: #allTraits) ifTrue:[ 438790 'Recompiling Traits' displayProgressAt: Sensor cursorPoint 438791 from: 0 to: Smalltalk allTraits size during:[:bar | 438792 Smalltalk allTraits do:[:t| 438793 t selectors do:[:s| 438794 [t recompile: s] on: Error do:[:ex| 438795 Transcript 438796 cr; nextPutAll: 'COMPILATION ERROR: '; 438797 print: t; nextPutAll: '>>'; nextPutAll: s; flush. 438798 compilationErrors add: (MethodReference class: t selector: s)]]]]]. 438799 438800 compilationErrors notEmpty ifTrue:[ 438801 SystemNavigation default 438802 browseMessageList: compilationErrors asSortedCollection 438803 name: 'Compilation Errors'].! ! 438804 438805!Utilities class methodsFor: 'closure support' stamp: 'MikeRoberts 9/20/2009 12:45'! 438806initializeClosures "Utilities initializeClosures" 438807 "Eliminate the prototype BlockContext from the specialObjectsArray. The VM doesn't use it. This paves the way for removing BlockCOntext altogether and merging ContextPart and MethodContext into e.g. Context." 438808 (Smalltalk specialObjectsArray at: 38) class == BlockContext 438809 ifTrue:[Smalltalk specialObjectsArray at: 38 put: nil]. 438810 "Remove unused class vars from CompiledMethod since we can't redefine its class definition directly. Add the new BlockClosure to the specialObjectsArray" 438811 (#( BlockNodeCache MethodProperties SpecialConstants) 438812 intersection: CompiledMethod classPool keys) 438813 do:[:classVarName| CompiledMethod removeClassVarName: classVarName]. 438814 Smalltalk recreateSpecialObjectsArray. 438815 "Recompile methods in ContextPart, superclasses and subclasses that access inst vars" 438816 ContextPart withAllSuperclasses, ContextPart allSubclasses asArray do:[:class| 438817 class instSize > 0 ifTrue:[ 438818 class allInstVarNames do:[:ivn| 438819 (class whichSelectorsAccess: ivn) do:[:sel| class recompile: sel]]]]! ! 438820 438821 438822!Utilities class methodsFor: 'pharo' stamp: 'MarcusDenker 10/2/2009 10:29'! 438823addUpdateServer: aSpec 438824 "Utilities addUpdateServer: #('Pharo Updates' #('pharo.gforge.inria.fr/'))" 438825 438826 UpdateUrlLists addFirst: aSpec! ! 438827 438828!Utilities class methodsFor: 'pharo' stamp: 'sd 3/11/2008 21:33'! 438829resetServers 438830 438831 UpdateUrlLists := OrderedCollection new.! ! 438832Model subclass: #ValueHolder 438833 instanceVariableNames: 'contents' 438834 classVariableNames: '' 438835 poolDictionaries: '' 438836 category: 'ST80-Kernel-Remnants'! 438837 438838!ValueHolder methodsFor: 'as yet unclassified' stamp: 'ls 8/5/1998 07:49'! 438839contents 438840 ^contents! ! 438841 438842!ValueHolder methodsFor: 'as yet unclassified' stamp: 'alain.plantec 6/11/2008 15:40'! 438843contents: newContents 438844 contents := newContents. 438845 self contentsChanged! ! 438846LeafNode subclass: #VariableNode 438847 instanceVariableNames: 'name' 438848 classVariableNames: '' 438849 poolDictionaries: '' 438850 category: 'Compiler-ParseNodes'! 438851!VariableNode commentStamp: '<historical>' prior: 0! 438852I am a parse tree leaf representing a variable. Note that my name and key are different for pool variables: the key is the Object Reference.! 438853 438854 438855!VariableNode methodsFor: 'accessing' stamp: 'tk 1/30/2001 13:45'! 438856name 438857 ^ name! ! 438858 438859 438860!VariableNode methodsFor: 'code generation' stamp: 'ar 3/26/2004 15:46'! 438861emitForReturn: stack on: strm 438862 438863 (code >= LdSelf and: [code <= LdNil]) 438864 ifTrue: 438865 ["short returns" 438866 strm nextPut: EndMethod - 4 + (code - LdSelf). 438867 stack push: 1 "doesnt seem right"] 438868 ifFalse: 438869 [super emitForReturn: stack on: strm]! ! 438870 438871!VariableNode methodsFor: 'code generation' stamp: 'ar 3/26/2004 15:46'! 438872emitForValue: stack on: strm 438873 438874 code < 256 438875 ifTrue: 438876 [strm nextPut: (code = LdSuper ifTrue: [LdSelf] ifFalse: [code]). 438877 stack push: 1] 438878 ifFalse: 438879 [self emitLong: LoadLong on: strm. 438880 stack push: 1]! ! 438881 438882!VariableNode methodsFor: 'code generation' stamp: 'ar 8/14/2001 23:14'! 438883emitLoad: stack on: strm 438884 "Do nothing"! ! 438885 438886!VariableNode methodsFor: 'code generation'! 438887emitStore: stack on: strm 438888 438889 self emitLong: Store on: strm! ! 438890 438891!VariableNode methodsFor: 'code generation' stamp: 'ar 3/26/2004 15:46'! 438892emitStorePop: stack on: strm 438893 (code between: 0 and: 7) 438894 ifTrue: 438895 [strm nextPut: ShortStoP + code "short stopop inst"] 438896 ifFalse: 438897 [(code between: 16 and: 23) 438898 ifTrue: [strm nextPut: ShortStoP + 8 + code - 16 "short stopop temp"] 438899 ifFalse: [(code >= 256 and: [code \\ 256 > 63 and: [code // 256 = 4]]) 438900 ifTrue: [self emitLong: Store on: strm. strm nextPut: Pop] 438901 ifFalse: [self emitLong: StorePop on: strm]]]. 438902 stack pop: 1! ! 438903 438904!VariableNode methodsFor: 'code generation' stamp: 'eem 9/5/2008 18:14'! 438905fieldOffset 438906 "Return temp or instVar offset for this variable" 438907 ^index ifNil: [code < 256 438908 ifTrue: [code \\ 16] 438909 ifFalse: [code \\ 256]]! ! 438910 438911!VariableNode methodsFor: 'code generation' stamp: 'ar 3/26/2004 15:46'! 438912sizeForReturn: encoder 438913 438914 (code >= LdSelf and: [code <= LdNil]) 438915 ifTrue: ["short returns" ^1]. 438916 ^super sizeForReturn: encoder! ! 438917 438918!VariableNode methodsFor: 'code generation' stamp: 'ar 3/26/2004 15:46'! 438919sizeForStore: encoder 438920 self reserve: encoder. 438921 code < 256 ifTrue: [^ 2]. 438922 (code \\ 256) <= 63 ifTrue: [^ 2]. 438923 ^ 3! ! 438924 438925!VariableNode methodsFor: 'code generation' stamp: 'ar 3/26/2004 15:46'! 438926sizeForStorePop: encoder 438927 self reserve: encoder. 438928 (code < 24 and: [code noMask: 8]) ifTrue: [^ 1]. 438929 code < 256 ifTrue: [^ 2]. 438930 code \\ 256 <= 63 ifTrue: [^ 2]. "extended StorePop" 438931 code // 256 = 1 ifTrue: [^ 3]. "dbl extended StorePopInst" 438932 code // 256 = 4 ifTrue: [^ 4]. "dbl extended StoreLitVar , Pop" 438933 self halt. "Shouldn't get here"! ! 438934 438935 438936!VariableNode methodsFor: 'code generation (closures)' stamp: 'eem 7/20/2009 10:38'! 438937beingAssignedToAnalyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" assignmentPools: assignmentPools "<Dictionary>" 438938 "No-op overridden by TempVariableNode"! ! 438939 438940 438941!VariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 14:52'! 438942emitCodeForLoad: stack encoder: encoder 438943 "Do nothing"! ! 438944 438945!VariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:41'! 438946emitCodeForReturn: stack encoder: encoder 438947 encoder 438948 if: code 438949 isSpecialLiteralForReturn: 438950 [:specialLiteral| 438951 "short returns" 438952 encoder genReturnSpecialLiteral: specialLiteral. 438953 stack push: 1 "doesnt seem right". 438954 ^self]. 438955 (self code = LdSelf or: [self code = LdSuper]) ifTrue: 438956 ["short returns" 438957 encoder genReturnReceiver. 438958 stack push: 1 "doesnt seem right". 438959 ^self]. 438960 super emitCodeForReturn: stack encoder: encoder! ! 438961 438962!VariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:08'! 438963emitCodeForStore: stack encoder: encoder 438964 438965 self shouldNotImplement! ! 438966 438967!VariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:41'! 438968emitCodeForStorePop: stack encoder: encoder 438969 self type ~= 1 ifTrue: 438970 [self halt]. 438971 encoder genStorePopInstVar: index. 438972 stack pop: 1! ! 438973 438974!VariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:07'! 438975emitCodeForValue: stack encoder: encoder 438976 stack push: 1. 438977 encoder 438978 if: code 438979 isSpecialLiteralForPush: 438980 [:specialLiteral| 438981 ^encoder genPushSpecialLiteral: specialLiteral]. 438982 (code = LdSelf or: [code = LdSuper]) ifTrue: 438983 [^encoder genPushReceiver]. 438984 code = LdThisContext ifTrue: 438985 [^encoder genPushThisContext]. 438986 self flag: 'probably superfluous'. 438987 self halt. 438988 ^encoder genPushInstVar: index! ! 438989 438990!VariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 16:58'! 438991sizeCodeForReturn: encoder 438992 encoder 438993 if: code 438994 isSpecialLiteralForPush: 438995 [:specialLiteral| 438996 ^encoder sizeReturnSpecialLiteral: specialLiteral]. 438997 (self code = LdSelf or: [self code = LdSuper]) ifTrue: 438998 [^encoder sizeReturnReceiver]. 438999 ^super sizeCodeForReturn: encoder! ! 439000 439001!VariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:09'! 439002sizeCodeForStore: encoder 439003 self shouldNotImplement! ! 439004 439005!VariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 18:09'! 439006sizeCodeForStorePop: encoder 439007 self shouldNotImplement! ! 439008 439009!VariableNode methodsFor: 'code generation (new scheme)' stamp: 'eem 5/14/2008 17:54'! 439010sizeCodeForValue: encoder 439011 self reserve: encoder. 439012 encoder 439013 if: code 439014 isSpecialLiteralForPush: 439015 [:specialLiteral| "i.e. the pseudo-variables nil true & false" 439016 ^encoder sizePushSpecialLiteral: specialLiteral]. 439017 (code = LdSelf or: [code = LdSuper]) ifTrue: 439018 [^encoder sizePushReceiver]. 439019 code = LdThisContext ifTrue: 439020 [^encoder sizePushThisContext]. 439021 self flag: 'probably superfluous'. 439022 self halt. 439023 ^encoder sizePushInstVar: index! ! 439024 439025 439026!VariableNode methodsFor: 'initialize-release'! 439027asStorableNode: encoder 439028 ^ self! ! 439029 439030!VariableNode methodsFor: 'initialize-release' stamp: 'eem 12/1/2008 13:51'! 439031name: string 439032 "Change name" 439033 439034 name := string! ! 439035 439036!VariableNode methodsFor: 'initialize-release' stamp: 'eem 5/14/2008 09:33'! 439037name: varName index: i type: type 439038 "Only used for initting instVar refs" 439039 ^self name: varName key: varName index: i type: type! ! 439040 439041!VariableNode methodsFor: 'initialize-release' stamp: 'ar 3/26/2004 15:46'! 439042name: string key: object code: byte 439043 "Only used for initting std variables, nil, true, false, self, etc." 439044 name := string. 439045 key := object. 439046 code := byte! ! 439047 439048!VariableNode methodsFor: 'initialize-release' stamp: 'eem 5/14/2008 16:01'! 439049name: varName key: objRef index: i type: type 439050 "Only used for initting global (litInd) variables" 439051 ^self name: varName key: objRef code: (self code: (index := i) type: type)! ! 439052 439053 439054!VariableNode methodsFor: 'printing' stamp: 'eem 5/6/2008 14:37'! 439055printOn: aStream indent: level 439056 439057 aStream nextPutAll: name! ! 439058 439059!VariableNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! 439060printWithClosureAnalysisOn: aStream indent: level 439061 439062 aStream nextPutAll: name! ! 439063 439064 439065!VariableNode methodsFor: 'testing' stamp: 'eem 5/14/2008 09:11'! 439066assignmentCheck: encoder at: location 439067 ^(encoder cantStoreInto: name) ifTrue: [location] ifFalse: [-1]! ! 439068 439069!VariableNode methodsFor: 'testing' stamp: 'ar 3/26/2004 15:46'! 439070canBeSpecialArgument 439071 "Can I be an argument of (e.g.) ifTrue:?" 439072 439073 ^code < LdNil! ! 439074 439075!VariableNode methodsFor: 'testing' stamp: 'eem 5/21/2008 11:06'! 439076index 439077 "This code attempts to reconstruct the index from its encoding in code." 439078 code < 0 ifTrue:[^nil]. 439079 code > 256 ifTrue: 439080 [self assert: index = (code \\ 256). 439081 ^code \\ 256]. 439082 code >= (CodeBases at: self type) ifTrue: 439083 [self assert: index = (code - (CodeBases at: self type)). 439084 ^code - (CodeBases at: self type)]. 439085 self assert: index = (code - self type). 439086 ^code - self type! ! 439087 439088!VariableNode methodsFor: 'testing' stamp: 'eem 5/14/2008 09:13'! 439089isSelfPseudoVariable 439090 "Answer if this ParseNode represents the 'self' pseudo-variable." 439091 439092 ^ key = 'self' or: [name = '{{self}}']! ! 439093 439094!VariableNode methodsFor: 'testing' stamp: 'ar 11/19/2002 14:58'! 439095isVariableNode 439096 ^true! ! 439097 439098!VariableNode methodsFor: 'testing'! 439099isVariableReference 439100 439101 ^true! ! 439102 439103!VariableNode methodsFor: 'testing' stamp: 'marcus.denker 2/21/2009 15:04'! 439104returns 439105 ^false ! ! 439106 439107!VariableNode methodsFor: 'testing' stamp: 'eem 5/14/2008 09:18'! 439108type 439109 "This code attempts to reconstruct the type from its encoding in code. 439110 This allows one to test, for instance, (aNode type = LdInstType)." 439111 | type | 439112 code < 0 ifTrue: [^code negated]. 439113 code >= 256 ifTrue: [^code // 256]. 439114 type := CodeBases findFirst: [:one | code < one]. 439115 ^type = 0 ifTrue: [5] ifFalse: [type - 1]! ! 439116 439117 439118!VariableNode methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:32'! 439119accept: aVisitor 439120 aVisitor visitVariableNode: self! ! 439121 439122 439123!VariableNode methodsFor: 'tiles' stamp: 'RAA 8/24/1999 16:34'! 439124currentValueIn: aContext 439125 439126 aContext ifNil: [^nil]. 439127 ^((self variableGetterBlockIn: aContext) ifNil: [^nil]) value printString 439128 439129 439130! ! 439131 439132!VariableNode methodsFor: 'tiles' stamp: 'ab 7/13/2004 13:54'! 439133variableGetterBlockIn: aContext 439134 439135 | temps index ivars | 439136 439137 (self type = 4 and: [self key isVariableBinding]) ifTrue: [ 439138 ^[self key value] 439139 ]. 439140 aContext ifNil: [^nil]. 439141 self isSelfPseudoVariable ifTrue: [^[aContext receiver]]. 439142 self type = 1 ifTrue: [ 439143 ivars := aContext receiver class allInstVarNames. 439144 index := ivars indexOf: self name ifAbsent: [^nil]. 439145 ^[aContext receiver instVarAt: index] 439146 ]. 439147 self type = 2 ifTrue: [ 439148 temps := aContext tempNames. 439149 index := temps indexOf: self name ifAbsent: [^nil]. 439150 ^[aContext tempAt: index] 439151 ]. 439152 ^nil 439153! ! 439154 439155"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 439156 439157VariableNode class 439158 instanceVariableNames: ''! 439159 439160!VariableNode class methodsFor: 'initialization'! 439161initialize "VariableNode initialize. Decompiler initialize" 439162 | encoder | 439163 encoder := Encoder new. 439164 StdVariables := Dictionary new: 16. 439165 encoder 439166 fillDict: StdVariables 439167 with: VariableNode 439168 mapping: #('self' 'thisContext' 'super' 'nil' 'false' 'true' ) 439169 to: (Array with: LdSelf with: LdThisContext with: LdSuper) 439170 , (Array with: LdNil with: LdFalse with: LdTrue). 439171 StdSelectors := Dictionary new: 64. 439172 encoder 439173 fillDict: StdSelectors 439174 with: SelectorNode 439175 mapping: ((1 to: Smalltalk specialSelectorSize) collect: 439176 [:i | Smalltalk specialSelectorAt: i]) 439177 to: (SendPlus to: SendPlus + 31). 439178 StdLiterals := LiteralDictionary new: 16. 439179 encoder 439180 fillDict: StdLiterals 439181 with: LiteralNode 439182 mapping: #(-1 0 1 2 ) 439183 to: (LdMinus1 to: LdMinus1 + 3). 439184 encoder initScopeAndLiteralTables. 439185 439186 NodeNil := encoder encodeVariable: 'nil'. 439187 NodeTrue := encoder encodeVariable: 'true'. 439188 NodeFalse := encoder encodeVariable: 'false'. 439189 NodeSelf := encoder encodeVariable: 'self'. 439190 NodeThisContext := encoder encodeVariable: 'thisContext'. 439191 NodeSuper := encoder encodeVariable: 'super'! ! 439192ChangeList subclass: #VersionsBrowser 439193 instanceVariableNames: 'classOfMethod selectorOfMethod addedChangeRecord' 439194 classVariableNames: '' 439195 poolDictionaries: '' 439196 category: 'Tools-Changes'! 439197!VersionsBrowser commentStamp: 'nk 11/25/2003 10:04' prior: 0! 439198VersionsBrowser shows all the versions of a particular method, and lets you compare them, revert to selected versions, and so on.! 439199 439200 439201!VersionsBrowser methodsFor: '*Polymorph-Tools-Diff-override' stamp: 'gvc 2/9/2009 12:45'! 439202compareToOtherVersion 439203 "Prompt the user for a reference version, then spawn a window 439204 showing the diffs between the older and the newer of the current 439205 version and the reference version as text." 439206 439207 | change1 change2 s1 s2 | 439208 change1 := changeList at: listIndex ifAbsent: [^self]. 439209 change2 := UIManager default 439210 chooseFrom: (list copyWithoutIndex: listIndex) 439211 values: (changeList copyWithoutIndex: listIndex). 439212 change2 ifNil: [^self]. 439213 s1 := change1 string. 439214 s2 := change2 string. 439215 s1 = s2 ifTrue: [^self inform: 'Exact Match' translated]. 439216 (DiffMorph 439217 from: s1 439218 to: s2 439219 contextClass: change1 methodClass) 439220 openInWindowLabeled: (('Comparison from {1} to {2}' translated) format: {change1 stamp. change2 stamp})! ! 439221 439222 439223!VersionsBrowser methodsFor: 'init & update' stamp: 'nk 1/7/2004 10:10'! 439224addedChangeRecord 439225 ^addedChangeRecord! ! 439226 439227!VersionsBrowser methodsFor: 'init & update' stamp: 'sd 11/20/2005 21:27'! 439228addedChangeRecord: aChangeRecord 439229 addedChangeRecord := aChangeRecord. 439230 self reformulateList.! ! 439231 439232!VersionsBrowser methodsFor: 'init & update' stamp: 'sw 5/6/2000 01:16'! 439233changeListButtonSpecs 439234 439235 ^#( 439236 ('compare to current' 439237 compareToCurrentVersion 439238 'opens a separate window which shows the text differences between the selected version and the current version') 439239 439240 ('revert' 439241 fileInSelections 439242 'reverts the method to the version selected') 439243 439244 ('remove from changes' 439245 removeMethodFromChanges 439246 'remove this method from the current change set') 439247 439248 ('help' 439249 offerVersionsHelp 439250 'further explanation about use of Versions browsers') 439251 )! ! 439252 439253!VersionsBrowser methodsFor: 'init & update' stamp: 'sd 11/20/2005 21:27'! 439254reformulateList 439255 | aMethod | 439256 "Some uncertainty about how to deal with lost methods here" 439257 aMethod := classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ self]. 439258 439259 self scanVersionsOf: aMethod class: classOfMethod theNonMetaClass meta: classOfMethod isMeta category: (classOfMethod whichCategoryIncludesSelector: selectorOfMethod) selector: selectorOfMethod. 439260 self changed: #list. "for benefit of mvc" 439261 listIndex := 1. 439262 self changed: #listIndex. 439263 self contentsChanged 439264! ! 439265 439266!VersionsBrowser methodsFor: 'init & update' stamp: 'marcus.denker 11/10/2008 10:04'! 439267scanVersionsOf: method class: class meta: meta category: category selector: selector 439268 | position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp cat | 439269 selectorOfMethod := selector. 439270 currentCompiledMethod := method. 439271 classOfMethod := meta ifTrue: [class class] ifFalse: [class]. 439272 cat := category ifNil: ['']. 439273 changeList := OrderedCollection new. 439274 list := OrderedCollection new. 439275 self addedChangeRecord ifNotNil: [ :change | 439276 self addItem: change text: ('{1} (in {2})' translated format: { change stamp. change fileName }) ]. 439277 listIndex := 0. 439278 position := method filePosition. 439279 sourceFilesCopy := SourceFiles collect: 439280 [:x | x isNil ifTrue: [ nil ] 439281 ifFalse: [x readOnlyCopy]]. 439282 method fileIndex == 0 ifTrue: [^ nil]. 439283 file := sourceFilesCopy at: method fileIndex. 439284 439285 [position notNil & file notNil] 439286 whileTrue: 439287 [file position: (0 max: position-150). "Skip back to before the preamble" 439288 preamble := method getPreambleFrom: file at: (0 max: position - 3). 439289 439290 "Preamble is likely a linked method preamble, if we're in 439291 a changes file (not the sources file). Try to parse it 439292 for prior source position and file index" 439293 prevPos := nil. 439294 stamp := ''. 439295 (preamble findString: 'methodsFor:' startingAt: 1) > 0 439296 ifTrue: [tokens := Scanner new scanTokens: preamble] 439297 ifFalse: [tokens := Array new "ie cant be back ref"]. 439298 ((tokens size between: 7 and: 8) 439299 and: [(tokens at: tokens size-5) = #methodsFor:]) 439300 ifTrue: 439301 [(tokens at: tokens size-3) = #stamp: 439302 ifTrue: ["New format gives change stamp and unified prior pointer" 439303 stamp := tokens at: tokens size-2. 439304 prevPos := tokens last. 439305 prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos. 439306 prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos] 439307 ifFalse: ["Old format gives no stamp; prior pointer in two parts" 439308 prevPos := tokens at: tokens size-2. 439309 prevFileIndex := tokens last]. 439310 cat := tokens at: tokens size-4. 439311 (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos := nil]]. 439312 ((tokens size between: 5 and: 6) 439313 and: [(tokens at: tokens size-3) = #methodsFor:]) 439314 ifTrue: 439315 [(tokens at: tokens size-1) = #stamp: 439316 ifTrue: ["New format gives change stamp and unified prior pointer" 439317 stamp := tokens at: tokens size]. 439318 cat := tokens at: tokens size-2]. 439319 self addItem: 439320 (ChangeRecord new file: file position: position type: #method 439321 class: class name category: category meta: meta stamp: stamp) 439322 text: stamp , ' ' , class name , (meta ifTrue: [' class '] ifFalse: [' ']) , selector, ' {', cat, '}'. 439323 position := prevPos. 439324 prevPos notNil ifTrue: 439325 [file := sourceFilesCopy at: prevFileIndex]]. 439326 sourceFilesCopy do: [:x | x notNil ifTrue: [x close]]. 439327 listSelections := Array new: list size withAll: false! ! 439328 439329!VersionsBrowser methodsFor: 'init & update' stamp: 'sd 11/20/2005 21:27'! 439330updateListsAndCodeIn: aWindow 439331 | aMethod | 439332 aMethod := classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ false]. 439333 aMethod == currentCompiledMethod 439334 ifFalse: 439335 ["Do not attempt to formulate if there is no source pointer. 439336 It probably means it has been recompiled, but the source hasn't been written 439337 (as during a display of the 'save text simply?' confirmation)." 439338 aMethod last ~= 0 ifTrue: [self reformulateList]]. 439339 ^ true 439340! ! 439341 439342 439343!VersionsBrowser methodsFor: 'menu' stamp: 'sw 2/27/2001 08:46'! 439344changeListKey: aChar from: view 439345 "Respond to a Command key in the list pane. of the versions browser" 439346 439347 ^ self messageListKey: aChar from: view! ! 439348 439349!VersionsBrowser methodsFor: 'menu' stamp: 'sw 10/12/1999 17:51'! 439350fileInSelections 439351 super fileInSelections. 439352 self reformulateList! ! 439353 439354!VersionsBrowser methodsFor: 'menu' stamp: 'sd 11/20/2005 21:27'! 439355findOriginalChangeSet 439356 | changeSet | 439357 self currentChange ifNil: [^ self]. 439358 changeSet := self currentChange originalChangeSetForSelector: self selectedMessageName. 439359 changeSet = #sources ifTrue: 439360 [^ self inform: 'This version is in the .sources file.']. 439361 changeSet ifNil: 439362 [^ self inform: 'This version was not found in any changeset nor in the .sources file.']. 439363 (ChangeSorter new myChangeSet: changeSet) open! ! 439364 439365!VersionsBrowser methodsFor: 'menu' stamp: 'sw 10/12/1999 22:49'! 439366offerVersionsHelp 439367 (StringHolder new contents: self versionsHelpString) 439368 openLabel: 'Versions Browsers'! ! 439369 439370!VersionsBrowser methodsFor: 'menu' stamp: 'sd 5/23/2003 14:50'! 439371removeMethodFromChanges 439372 "Remove my method from the current change set" 439373 439374 ChangeSet current removeSelectorChanges: selectorOfMethod class: classOfMethod. 439375 self changed: #annotation 439376! ! 439377 439378!VersionsBrowser methodsFor: 'menu' stamp: 'sd 11/20/2005 21:27'! 439379versionFrom: secsSince1901 439380 | strings vTime | 439381 "Return changeRecord of the version in effect at that time. Accept in the VersionsBrowser does not use this code." 439382 439383 changeList do: [:cngRec | 439384 (strings := cngRec stamp findTokens: ' ') size > 2 ifTrue: [ 439385 vTime := strings second asDate asSeconds + 439386 strings third asTime asSeconds. 439387 vTime <= secsSince1901 ifTrue: ["this one" 439388 ^ cngRec == changeList first ifTrue: [nil] ifFalse: [cngRec]]]]. 439389 "was not defined that early. Don't delete the method." 439390 ^ changeList last "earliest one may be OK" ! ! 439391 439392!VersionsBrowser methodsFor: 'menu' stamp: 'nk 11/25/2003 10:19'! 439393versionsHelpString 439394 ^ 'Each entry in the list pane represents a version of the source code for the same method; the topmost entry is the current version, the next entry is the next most recent, etc. 439395 439396To revert to an earlier version, select it (in the list pane) and then do any of the following: 439397 * Choose "revert to this version" from the list pane menu. 439398 * Hit the "revert" button, 439399 * Type ENTER in the code pane 439400 * Type cmd-s (alt-s) in the code pane. 439401 439402The code pane shows the source for the selected version. If "diffing" is in effect, then differences betwen the selected version and the version before it are pointed out in the pane. Turn diffing on and off by choosing "toggle diffing" from the list pane menu, or hitting the "diffs" button, or hitting cmd-D when the cursor is over the list pane. 439403 439404To get a comparison between the selected version and the current version, choose "compare to current" from the list pane menu or hit the "compare to current" button. (This is meaningless if the current version is selected, and is unnecessary if you''re interested in diffs from between the current version and the next-most-recent version, since the standard in-pane "diff" feature will give you that.) 439405 439406You can also compare the selected version with any other version using the "compare to version..." menu choice. 439407 439408If further versions of the method in question have been submitted elsewhere since you launched a particular Versions Browser, it will still stay nicely up-to-date if you''re in Morphic and have asked that smart updating be maintained; if you''re in mvc or in morphic but with smart-updating turned off, a versions browser is only brought up to date when you activate its window (and when you issue "revert" from within it, of course,) and you can also use the "update list" command to make certain the versions list is up to date. 439409 439410Hit the "remove from changes" button, or choose the corresponding command in the list pane menu, to have the method in question deleted from the current change set. This is useful if you''ve put debugging code into a method, and now want to strip it out and cleanse your current change set of all memory of the excursion. 439411 439412Note: the annotation pane in versions browsers shows information about the *current* version of the method in the image, not about the selected version.'! ! 439413 439414!VersionsBrowser methodsFor: 'menu' stamp: 'alain.plantec 6/1/2008 23:22'! 439415versionsMenu: aMenu 439416 "Fill aMenu with menu items appropriate to the receiver" 439417 439418 aMenu title: 'Versions' translated. 439419 aMenu addStayUpItemSpecial. 439420 439421 listIndex > 0 ifTrue:[ 439422 (list size > 1 ) ifTrue: [ aMenu addTranslatedList: #( 439423 ('compare to current' compareToCurrentVersion 'compare selected version to the current version') 439424 ('compare to version...' compareToOtherVersion 'compare selected version to another selected version'))]. 439425 "Note: Revert to selected should be visible for lists of length one for having the ability to revert to an accidentally deleted method" 439426 aMenu addTranslatedList: #( 439427 ('revert to selected version' fileInSelections 'resubmit the selected version, so that it becomes the current version') )]. 439428 439429 aMenu addTranslatedList: #( 439430 ('remove from changes' removeMethodFromChanges 'remove this method from the current change set, if present') 439431 ('edit current method (O)' openSingleMessageBrowser 'open a single-message browser on the current version of this method') 439432 ('find original change set' findOriginalChangeSet 'locate the changeset which originally contained this version') 439433 - 439434 ('toggle diffing (D)' toggleDiffing 'toggle whether or not diffs should be shown here') 439435 ('update list' reformulateList 'reformulate the list of versions, in case it somehow got out of synch with reality') 439436 - 439437 ('senders (n)' browseSenders 'browse all senders of this selector') 439438 ('implementors (m)' browseImplementors 'browse all implementors of this selector') 439439 - 439440 ('help...' offerVersionsHelp 'provide an explanation of the use of this tool')). 439441 439442 ^aMenu! ! 439443 439444 439445!VersionsBrowser methodsFor: 'misc' stamp: 'sw 2/27/2001 08:17'! 439446addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream 439447 "Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior versions are seen in a versions browser -- in this case, the inherited version of this method will not work." 439448 439449 (aClass includesSelector: aSelector) ifTrue: 439450 [^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. 439451 439452 aStream nextPutAll: 439453 ((changeList size > 0 439454 ifTrue: 439455 [changeList size == 1 439456 ifTrue: 439457 ['Deleted - one prior version'] 439458 ifFalse: 439459 ['Deleted - ', changeList size printString, ' prior versions']] 439460 ifFalse: 439461 ['surprisingly, no prior versions']), self annotationSeparator)! ! 439462 439463!VersionsBrowser methodsFor: 'misc' stamp: 'sw 1/25/2001 07:03'! 439464selectedClass 439465 "Answer the class currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane" 439466 439467 ^ classOfMethod theNonMetaClass! ! 439468 439469!VersionsBrowser methodsFor: 'misc' stamp: 'sw 1/25/2001 06:26'! 439470selectedClassOrMetaClass 439471 "Answer the class or metaclass currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane" 439472 439473 ^ classOfMethod! ! 439474 439475!VersionsBrowser methodsFor: 'misc' stamp: 'sw 1/25/2001 06:10'! 439476selectedMessageName 439477 "Answer the message name currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane" 439478 439479 ^ selectorOfMethod! ! 439480 439481!VersionsBrowser methodsFor: 'misc' stamp: 'sw 10/19/1999 15:04'! 439482showsVersions 439483 ^ true! ! 439484 439485"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 439486 439487VersionsBrowser class 439488 instanceVariableNames: ''! 439489 439490!VersionsBrowser class methodsFor: 'instance creation' stamp: 'sd 3/30/2005 21:53'! 439491browseVersionsForClass: aClass selector: aSelector 439492 self 439493 browseVersionsOf: (aClass compiledMethodAt: aSelector) 439494 class: aClass 439495 meta: aClass isMeta 439496 category: (aClass organization categoryOfElement: aSelector) 439497 selector: aSelector! ! 439498 439499!VersionsBrowser class methodsFor: 'instance creation' stamp: 'di 1/11/2000 12:45'! 439500browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector 439501 ^ self browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: nil! ! 439502 439503!VersionsBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 439504browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: sourcePointer 439505 | changeList browser | 439506 Cursor read showWhile: 439507 [changeList := (browser := self new) 439508 scanVersionsOf: method class: class meta: meta 439509 category: msgCategory selector: selector]. 439510 changeList ifNil: [ self inform: 'No versions available'. ^nil ]. 439511 439512 sourcePointer ifNotNil: 439513 [changeList setLostMethodPointer: sourcePointer]. 439514 439515 self open: changeList name: 'Recent versions of ' , 439516selector multiSelect: false. 439517 439518 ^browser! ! 439519 439520!VersionsBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 439521timeStampFor: aSelector class: aClass reverseOrdinal: anInteger 439522 "Answer the time stamp corresponding to some version of the given method, nil if none. The reverseOrdinal parameter is interpreted as: 1 = current version; 2 = last-but-one version, etc." 439523 439524 | method aChangeList | 439525 method := aClass compiledMethodAt: aSelector ifAbsent: [^ nil]. 439526 aChangeList := self new 439527 scanVersionsOf: method class: aClass meta: aClass isMeta 439528 category: nil selector: aSelector. 439529 ^ aChangeList ifNil: [nil] ifNotNil: 439530 [aChangeList list size >= anInteger 439531 ifTrue: 439532 [(aChangeList changeList at: anInteger) stamp] 439533 ifFalse: 439534 [nil]]! ! 439535 439536!VersionsBrowser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 439537versionCountForSelector: aSelector class: aClass 439538 "Answer the number of versions known to the system for the given class and method, including the current version. A result of greater than one means that there is at least one superseded version. Answer zero if no logged version can be obtained." 439539 439540 | method aChangeList | 439541 method := aClass compiledMethodAt: aSelector ifAbsent: [^ 0]. 439542 aChangeList := self new 439543 scanVersionsOf: method class: aClass meta: aClass isMeta 439544 category: nil selector: aSelector. 439545 ^ aChangeList ifNil: [0] ifNotNil: [aChangeList list size]! ! 439546 439547 439548!VersionsBrowser class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:48'! 439549windowColorSpecification 439550 "Answer a WindowColorSpec object that declares my preference" 439551 439552 ^ WindowColorSpec classSymbol: self name wording: 'Versions Browser' brightColor: #(0.869 0.753 1.0) pastelColor: #(0.919 0.853 1.0) helpMessage: 'A tool for viewing prior versions of a method.'! ! 439553ThemeIcons subclass: #VistaryThemeIcons 439554 instanceVariableNames: '' 439555 classVariableNames: '' 439556 poolDictionaries: '' 439557 category: 'Polymorph-Widgets-Themes'! 439558!VistaryThemeIcons commentStamp: 'gvc 9/23/2008 12:07' prior: 0! 439559Vistary theme specific icons.! 439560 439561 439562"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 439563 439564VistaryThemeIcons class 439565 instanceVariableNames: ''! 439566 439567!VistaryThemeIcons class methodsFor: 'as yet unclassified' stamp: 'gvc 5/21/2007 16:24'! 439568initialize 439569 "Initialize the class." 439570 439571 self initializeIcons! ! 439572 439573!VistaryThemeIcons class methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 14:41'! 439574normalSizeNames 439575 "Answer the names of the normal icons" 439576 439577 ^#('error' 'info' 'lock' 'question' 'warning')! ! 439578 439579!VistaryThemeIcons class methodsFor: 'as yet unclassified' stamp: 'gvc 5/21/2007 12:31'! 439580smallSizeNames 439581 "Answer the names of the small icons" 439582 439583 ^#('smallError' 'smallInfo' 'smallLock' 'smallQuestion' 'smallWarning')! ! 439584 439585 439586!VistaryThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/28/2007 17:08'! 439587errorIconContents 439588 "Private - Method generated with the content of the file icons\new\error.png" 439589 ^ 'iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAYAAABXAvmHAAAABHNCSVQICAgIfAhkiAAAAAlw 439590SFlzAAAN1wAADdcBQiibeAAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 439591AA7ESURBVGiBvZp7cFRVnsc/59zb3Uk63QmPSIIkJEQU5CWwUjwKtnTAcbZmnJlSynWqZhZr 439592fNDlUjPW4mo5u1Lq+JydWccZvBIdp8aaYUoEldVRdBFxVnlDYgCNECQBEiAEO6/udN/X2T/6 4395933k53Hgq6O7fq1L3nJPfe7/f3+/5+53fObaGU4uschmEIYB5wHTARGJ/TBNCe004AW4GdsVjM 439594/Vov9g7xVQgYhiE9wN8TQtxQUVFRUVVVRSQSoaioiHA4TFFREQCJRIJkMkkikaC7u5vW1lY6 439595OjrOAW8Am4G/xGIx+29GwDCMfwAer6qqmlFbW0t1dTVaPE5/QwNmaytWZyfW2bNYHR24pomM 439596RJDRKPqYMYRqaoguXoxbUUFLSwvNzc20tbUdBf4NeDkWi120NS+YgGEYfwc8WVFRcc2CBQsY 439597AyR37SJ54ABmezuuaeJaFso0s9euaaIsC9d1s00pRWD8eEqWLKHs+9/nfCDArl276OjoOADc 439598F4vF/vv/nIBhGPeUlJQ8vnDhQlk1ejS977xDYudO3FRqALQHOI+IZeE6ThZ4loTr4iqFAsbe 439599cAOVsRgn+/rYsWMHfX19v/CIXFCMfCEBwzCCwLrKysoV1y1divXhh/Rt346TSAxYdxD4vDHb 439600Hhb44D6BAON/+EPG3X4772zdyunTp98CbonFYt1fmYBhGGOAzTNnzly0YPZsejZsINXUNKzF 439601hxCxLJRtfynwwdcl8+Zx5VNPsevgQT7++OMjwDdjsVjLRRPwLL918eLFi6eWl9P1pz9hnz2b 439602J5E84INl4+k+1/ojySiv77qEJkzgqro6Pu3tZc+ePZ8A82OxWM9IBOQI48/OnDlz8dSKCuLP 439603P58B7wFTto2yrAz4QWPZvlL5YHP6yicyTF8pRbK1ld3LlzNl1CimTJkyFdhkGIZ2wQQMw/iX 439604ysrKWxfMmUP3+vU4vb0ZLfuy8LQ93JgarPkLBZ7rEaUw43H2/uhHLJw1i/Hjxy8VQjx1QQQM 439605w5hdUlLy5HVLl9K7cSPW2bNDrZvTBo99XeC5/b7jx9l3220su/ZaioqK/tkwjG9ciAeeXLhw 439606obT37CF95MhQ6/rWtyxEQQGRxYuRRUWZMce5YOAFEyZQftNNyGh0AHiOjHwS53bs4ERdHfPm 439607zQN43itbhidgGMZ1FRUVS6vKykj89a8DEsm1tjemlZZS+ctfUr56NVW//z1y0qQB4D6JYfrK 439608dYnMns2cV1/liocfZu6bbxKcOPELvfHpb37DxFGjGDt2bLVS6sfDEvCYPbFgwQIS27fjJpN5 439609oHMDVZaWcunDDxO45BIAQpEI1b/9Lfrll3+p/ouvuooZ69aheXVSuKyMua+8Qqi6elgZKaWw 439610ens5/PjjLFy4ECHEfxiGUTCcB66pqqq6amwwSHL37qEZJ0c2lz74IIFx4/KsUFBUxKS1a9Gv 439611uGJEGRXPnMmMujq0cDjv3nBJCVe/9hpaWVkecD+tukrx2YsvEk2lGDduXIkQ4h+HI/C92tpa 439612UvX1uKnU0OziySh89dUEysuHiyVCRUVMfvZZ9KlTh+i/ePp0pnvglVKk02m6uro4c+YMbW1t 439613nO/uxozFaLdt2iyLE5ZFi21z0rZpt21Op9N8sn49tbW1KKVWDyEghPhudXU1/Y2NeYGal4Fs 439614m8T+/dimOSwBgFBhIVPWrSMwbVrWA4XTplH9618T7+/n5MmTHDt2jJaWFs6cOUM8Hqenp4fO 439615zk7a+vpIK0XadbE94qZSpFyXhFJ8tGkTNTU1AFNzZSQNw5hTXl5eFUgmMU+cyLP4YCmlT53i 4396162COPYFvWF5KYWleHc+WVJCdNovhnP6Ozt5euri6SySROTrZSStHf3099fT3WG29kM5mTEw+O 4396171z/T1ITb0cHYsWOlEGKl/z4dWDZx4kRShw7lp8rBE5VHytm2jSOOw+Q1awgEAnngTdOkt7eX 439618vr4+LlmzBmwbrbAwGxNAHvhUKkV9fT3Jl17COXAAZ5D+c/uOUjS99hoTFi2is7PzZuApX0JV 439619kUgEq7196ETlS8kn4hVo9rZtfPrAA1ieJxKJBO3t7bS1tdHd3Y1t22iBAFphYTYrAXnZybd8 439620csMGnP37s8HrA/f7Tk5gdzY3E4lEAKbkemB8UVERdjw+rP7zxnJf8u67HLQsyn7ykyGyGKn5 439621JFKpFA0NDSRffhln375stnGVQgkBUoKuI4RAh4wnbJue9naKi4sBIrlBPD4cDmN//vkX6j83 439622NbpK0W3bnHr7bQ4+9BBmOn1R4D9qaCC5cSPO3r0Z4EIgdB0RCiGLitCLitAKC9ELCxGFhegF 439623BQTCYfricZ+A9swzzxTneaD3/PmR9Z+T0/sdh7hpZjKFUvR/+CGf2jaX33svmq6PqHelFKZp 4396240tDQQGLjRty9e1GahpASTddB05BCoIRAAULKzNl7ngAS8TjhgXmkGjik+z3lOPmFmS+bnJwe 439625N00SjoPra9P7G+3tYFm4UmatPZIXRH09qr4eUVCA1DTQ9YxkvOYCCAFK4cIACdtGDwZxHMeH 439626fKlPoD2RSEyQxcVDJy9vPeu4Ll2WlQGfM0O6ShGsqmLyY48hQqE8qfgkcq81TWPWihU0njpF 4396274vBhhKaBpiGEwJUShMh4wbtHeM8SSiGkJDxmDMlkMqN9KbMx0J5MJpGRSFY2WQ94QM+bJomc 439628vuMBC1VWMvmRR5DFxXkB7pMYLvtous70++8nOncuMhRCBoPIYBA9EEDXdXRNQw8EkLqO9K41 439629XUfTdYpHjyaRSPgGOZ0lkEgk0KLR/AzkyeRcOk06xxOOFw+hykoue/RRtGh0iFQGF3O53vBJ 439630XPHTn1I8a1YGYCCArmloXpOahiYlAS8u/PFIjgds284SONnT00NgwoS8hYntOHSm05iOMwDc 439631AxH0wMtIZMSsY1kWpld2DOcNTdepXbmS8LRp6FJmQEqJJiW6EGhSZsFLT1qjL7uM7u5uAHfV 439632qlWdPoGtLS0tFM+fn7cY/9yySHvAfb073qK79uc/R2YmlGHBm6ZJfX09jS+9RCqVGlFeuq5T 439633fdtthKZORfdSoqYUWu4ZMgSkZOqNN9La2grQ6cU3Etjf0dFxygyHKZg8GaUUPZZFv23nAVeu 439634C0JQs2YNWknJEG37136qTG3dir1lC01PP03amydy7/GvpaYxYcUKVGkpmk/CdQeAeyBLR4/G 439635LSmhq6sL4C9+KpLefuR/tbS0ULxkCabj0GNZ+VseXuCqggK0UaNGDNZ0Os1HH31Eets2gocP 439636I4NBnCNHOGoYpNPpYWPDdV2EECRnzkRznAx4z/pSqUwGEoJL587l+PHjvtdfzRLwzq81Nzcz 4396376vrr+Vwp7Nx6PscDVm8vLRs2DBus6XSaxsZG0tu2oR86hPQzia6jmptpqavLeiL3ftd1aW5u 439638hs5OdMdBs22k66K5LlIpJKAJwaxbb838H5jpdHrrYALvtre3H+ywLC654QaUTyIn5/uV4bk/ 439639/pHm118fErCNjY30b9uGdugQWjCI8NKg1DSklIhjxzj13HOkB8XE0aNHSTY0UL5/P9KykJ4X 439640lOuCJ7WJc+fyua7T2dkJ8Pbdd9/dn0fA20i9d+fOnVy+ciUUFIBS2D7wQfn/3Nq1HN28Gcdx 439641srLpf+89AgcPIr2JSXrZQwiB5mlZa27m7HPP0Z9I4DgOzc3N9NfXU/Xuu2ipVMb6jgOOk5EP 439642oGsa8x94gN27d/uYHyXnyNtaNAxj67Jly76R2rKFj9euHQCek0Jtn5DrwoIFWDNmIA4fJtDU 439643lJWNkBLpp8HMS9CUQrou0raxo1E658wh2NFBxa5dSNvGBRxNw9Z1bE3LXGsatd/6FiU/+AHv 439644v/8+wMZYLLY8l4BO/nHPzp079924YoU8d+AApz/4YCCIvTqdnDmBffvQGxsRwWCmaRpIiZAy 4396454wUfPGTAWxa64xA4e5aazZuRpom0rEwBp+soKTPltBC4QjBqwgRm3HsvGzdtArA1TbtvEN78 439646ja1YLFbf19d33ztbtzL/V7+i2NvuyC4qfA94JTC6jggEEJ5sssCFQGTSRSaLOA7CttFcF2FZ 4396476JaVAZ9KoXmB7UqJ0jRcry4KRSJc88ILvLVlC/39/QD/eccddxz7QgIeiV+cPn36xd0NDSx5 4396489lkCJSUD2cjzgL+nL7wyGP/sA/ceLAHhuuC6mbPjIFwX5TjguiAlZiiEFQxi6zqOJx1CIa5d 439649t44P9u/3A3d7R0fH/YOxDkvAO+745JNPdh2Lx7l+40aKa2ry5oNs+vQqSCBz9ptHFKXyrnP3 439650fWxNIx0KYRUWYodCOIEAlq4TiEZZ9sILNHV1cezYMYBW13VvWrNmzbAfAoclEIvF0sB39+zZ 439651s7ehtZXvvPoq5YsWDZTSgGNZGat7dbzwgPvSUTBAAq/kAFzADgSwQiHsUAgzFMIMBLACAYor 439652K/nmK6+wr62NhoYGgIQQ4tt33XXX+REMPaIHiMViHcCSpqaml7e89x5Lf/c7Zt99N1o4nMlG 439653pjmwhoWMrITIfvvyFySu9zcbcKTE1nUsr5me1d1gkKply/j79et5c/t23/InHMdZsHLlykMj 439654YYQL/8j37+Fw+MF58+aJS0tL2fHEExz+858RgQCFZWWZ9ElmGSgHZR/h6V54C5OsRwA0jbIZ 439655M5j30EOc6O1l7969fsD+j23bN65atercl2G7mM+si4DnR48ePWX+/PmELYvGP/yBU3v2kIzH 439656M3kfMtmITBWJUgivJMhdZRVGo4ydPp3pt99OVzjM7t27/TLZUUqtLSsru2f58uUjbwF+FQI5 439657RG4Bni4rKxs7adIkampqcDo7aX79dbqOHycVj5Pu7cVMJBCOQ7CggFBhIQXRKCWVlVx+882o 439658igqOHz/OZ599xvnzWXm/Atwfi8U+vRg8X/WnBjpwC/CvwJWlpaWyqqqKaDRKOBzONshsevX1 4396599WV/anDixAl6erLf7EwhxNtCiMfuvPPOnRcN5KsSGERGE0L8WCn1T8A0IAoM+ZLiH0qpuBDi 439660LaXUpmQy+fbq1asTX+f9X5vAcM+sq6sbY5pmhZSyQilVCJwJBAKnR40adeZCtX3BL/t/IPA3 439661Pf4XvU9EdugvtU8AAAAASUVORK5CYII='! ! 439662 439663!VistaryThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/28/2007 17:08'! 439664infoIconContents 439665 "Private - Method generated with the content of the file icons\new\info.png" 439666 ^ 'iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAYAAABXAvmHAAAABHNCSVQICAgIfAhkiAAAAAlw 439667SFlzAAAN1wAADdcBQiibeAAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 439668AA5iSURBVGiBvZp7cFzVfcc/55x7d1daPWxZAsvY8otkTArmORrb1JSXTSelJjHjEP4oTUqB 4396697IA7w8QQkjaZ9JmUdFLaDiwwTCelk7RNeQQI4xgMQ9PGb4h5BjvCkgy2sSxZD2tX0r33nF// 439670uHfv7ko2GGizM3d2770jne/3+/v+HvfsKhHhk7yKxaICuoG1wEJgXs2hgMM1x0FgK7C9UCi4 439671T7Rw8lIfh0CxWNQJ4M8ppdZ1dnZ2dnV10dzcTGNjI/l8nsbGRgBKpRLlcplSqcTo6Cj9/f0M 439672DAwcA34KPAU8WygUot8YgWKx+Fngu11dXectXbqURYsWMVwy7N0/Qf/7AYMjIUePhwwMhgSh 439673o7lR05LXzGnxWHxWltUXtdDZ5ujr66Onp4dDhw79Gvgz4D8LhcJHVvO0CRSLxUuAezs7O69Y 439674uXIlZOaw480yr+wrc/hYQBA6wtARhEIQVD47wlBwzuGswzmHOGFeh89lF7fy+Ss78Blix44d 439675DAwMvALcUygUnv8/J1AsFu9qbW397qpVq3TbGV08t/sE218vMRlUQYehIwhcHZEwdNga4BUS 439676zgniHCCsu7ydwhcXMD7yLtu2bWN8fPx7CZHTypEPJFAsFjPAQwsWLPjS1WvW8os3Q17aO06p 439677bFN1U8CBm3EtihLgrh74dCK+B3+wbh63XH8mW7c+x5EjRzYDNxYKhdGPTaBYLM4Bnlq+fPml 439678F16ykh+/NMbb/ZP1iifApxMJQ0dkZyp+ciLVe93LW7nv65/h9Vd38NZbb+0HrikUCn0fmUCi 439679/NbVq1evntt1Dj/cOsLRoSgGHNb4O5Bp14QodJz/qUbW/c4sAJ58cZDte0erNppOooaIc475 439680Z2Z5+C8v4MTxfezatetXwIpCoTB2KgL6FNcfXL58+erOrnN45Nlhjh6PCCNHGDmiSAjD5Khc 439681q5yHjpXLm/j+Vxdy+SWtXH5JK/9w91J++8IWRKQGeG1EBBFBJCbYf6jMho07mX3GMpYtW3YO 4396828HixWDSnTaBYLH51wYIFX77okpX86IVRTpQtUeQII0nAx95OryVEooTcDWvmzFjkjz7fWQd0 439683JhFJ7jtEHMNjATdt2s35F65i3rx5Vyul7jstAsVi8cLW1tZ7r16zlsd+foKjw2EMOgEehjHo 439684sPZaVL3mnCOXVSdd6GSKp8CdqyfiHL3vjvPHX9/DlVetobGx8Y5isXjV6UTg3lWrVuld+yL2 439685vzdVVTx0KZEoSpI0lLpr1sYWePLFoRmL/PCZIzMUlxrFa+9JDYltLx/j4X8/SHd3N8Ajydhy 439686cgLFYnFtZ2fn1R1zu/j5a6XUItUjsU1YPa/khLWSJugz/zXEdx45yP7+Mq/tH+fb9x9gy7bB 439687GUDdNCJOTh6Nf/rBPmbPWUh7e/siEbl5OgElIpWB7JX169dfsKevkV+8Vj5lxUnLZyiEQUyi 439688rsLYaeenqDi1JFwKOjm3tSQcN61fxKabO3n66adHgbmFQmFyegSu6OrquiCTb2fnm+X6ilOT 439689qLV+jxL/i5MasBV/f3jF+SD/i0gSkfjeo48dYDJq4cwzz2xVSn2xNgJe8v65pUuX8stfT8bj 439690QW3FCWtB11+rAnWnBnoS69gowEUT2GgK5ywuihBncTaKz12EuAjnFCIKJ4ofPfEr1l25lKNH 439691j24CflAXAaXUdYsWLeK1dybqE3W6/6Nq4p6u4s5G2KhEODVMUB4gKB0iLB8hnDyODU5gw3Fc 439692VMbaMs5O4ewUYqNElABnJ5GoxOPPvsrixYsBzikWi7k0AsVi8aLOzs6ucuBz8GgQqzs9UZNG 439693FSXnztYDlRrFCxvaWX/VLLSOC4Z1wn/8tJ+/e+QNnItwlhrbuMQyNj5PxBBnE1GSz87x9v73 439694GTjuaG9v10NDQ18B7qtEYM3ChQt5o3cy8bpUG1U40//WSmKLmf53UcD6q2Zx4MA77Nmzh927 439695d9N74B1uuHYhzlnEgYit87eIrfF/lYgTl5zH+SAu4ieb32b+/PmIyA21Fupqbm7m8GBYl6Sp 439696lWqsE0X1ileI2KBMUB5gqnwUEcfo6Ghqq2PHjmG0SojaKlCxNaXV1fSAakTiNWx6r+fAIM3N 439697zQDLapN4XmNjI8NjUbW6JI2qruKEJ1M8JJgcxoaT8cI2Hgyr5TMGEV+zyd9H9Y0rSfQKCYWg 439698NXgaFArwELFEoXD4yBhNTU0AzbURmJfP5zk+FtVVnDr/R7WKxwtHk6NMlY9iw6ma0NuUQG1y 439699A1U1RaCSAwlwJQ7PV2RzisYGTWPOoyFnaGjwaMgpcjmPfN5neGS8QsA88MADTXURGBo5cUr/ 43970011YYG00QTA4jUYTY2KfOkfo1BVsTBaBKMlFdxGGUoDMKTxuMAmU0CgEErRQ4QVDx/3CK4bES 439701+Xy+Iv4i4I1KH8A6qebAKSpOMDmMnSolQGyioCQkYo9PB1+1UDVxjRK8rMIYjadBa9AqfgeH 439702UiACSdYjThE5RybjYa2tQD6rQuBwqVSa35TT1UY1o+JYwokRbFCqaVwutY2TagWZbiFjTBoB 439703owQvo/E88AwYrTAGlFZo5VACSmkcyUOWqFgkq9CimNOWp1wux96P2eIBh8vlMs2Nuq5RVSuO 439704I5gYqiaqq9imtpRWS2OthbTW5HJxz8n4Ct+PFfdMDLyivDIKhY63wQCTPuCAQeO0Q0TRNruJ 439705UqlUWeNISqBUKtGSb01tE0VJtbGWoDwYt/5E7emlr5of8b1KBAAaGhpoaGiIP+d0DNxTeFrF 4397064LVCaRLLKFAV5R3OKdAGJzYuw6KY09acRiCKopTAu2NjY8w/oz19VHTOYV3EVHkQFwVJ/bbp 4397071khl/JW0NNqUVCUC+XyeXC6XEshmTex3E3u/AlypZJ5U8d+hQJxG6zi6piKIwNmL2xgdHQVw 439708GzduHKyU0a19fX2sOLepbjQOJ47Hs0nibbEOZ5MktS6eVyodU6okABobG1P1s9lsTMDXZDIG 439709P+NhPI3nGUySDMo3oD3wPEQZMAbRJk4UbVBGo5Xm+s+eQ39/P8AgxImigZcHBgbey2cDPrUg 439710F4OfGiMKJ5IyWak4AhLbquJ5sdXSWGn9SikaGhrI5XJks1kymUzs64zB8w3G02gvBqm0RmkP 439711lIcYDTom4lT1PlqD0rS1zaK1yTEyMgLwbKUU6WQ/8um+vj4uu6gJawPCybFY8WmJahOfi4vB 439712x4lr0wqkEw9XwGezWXzfB8D3NMokahoPtEGMj2iNVQanPCwGpxL1MYjSiFIopbj4vLPo7e2t 439713WPTJlEDy/pOenh5+d9VsJDgez+NSm6i2PnHrciAmqZH0gb5CwPf9lABao4xOFNaINlhlsMrD 439714ao+I+HOkDQ4dE0EDGqUNX/7C+fT09AAEU1NTW6cTeOHw4cOvhxMDrLvijGTeieqnxjRha0up 439715pB01m9H4fqxWJpMhk8nUEVCJ6miD014MFo8QQyiGCJ9QNFZi8E5JavKLz12IJ8cZHBwE2HLn 439716nXdO1BFINlK/tn37dr5yw6fJZZMm6KJ0/BU5Sf0XCwK+r8n4kPGqBDzPw/O8tJGhYmCW+AjF 439717IxRDKD6BeASi4yiIxgqIxGXKKI9vbVzBzp07K5j/hppXuitRKBQ2Hzt27IXhoUPcdN2SOALp 4397181Fgzl6cPH3H9j4GD7ys8T6OUwvf9FLxSsa2c0jilidCx6hgC8ZgSQ+A8QmewTjN9o3PNqqUM 439719D/ZXkvexQqGw46QEktdd27dvd19av4SVF3Qkitt0lo9HYdIZPeuBb8DzK91VISJ16ldavlOa 4397200OnYNk4z5TwmnEfZ+kw5g0URj26CAhSO+WfM5mu3nMeuXbsAImPMPdPw1hMoFAq/HB8fv2fr 43972188/x/T9dwaKzmtIkrm5IRYgTlHJ4HviewmgVzzNaIQK+79er74RIFA5D6BQhHoHTTFrNVGQQ 439722EbQ4TDx7onE0N2T557++gp/9bDMTExMAf3/rrbe+84EEEhLfO3LkyKN7X9nJg391Ga3NfuL/ 4397232tHZ4dfMNPFgBkrDMy/2opSuA//US+/hRGEFHCoeEl28eNYEZFSIpyOMijMkq+Ghb1/Jy7v/ 439724p5K4Lw0MDHxjOlY49fZ6Fnipu7t7xeyOJdx89/P09I1Um5aN90DzDQY/o/E8hWc0xtNp8xFt 439725QGksySGGEE3kNIEYnAAi8YSKxSiLR0hLzufBb13O2OA+9u7dC9DvnLv49ttvn7lnebIIJFGY 439726Aq7btWvX7v539vLkQ7/PpRfPrT6giCMMLaYyxwNKxY8iVN5FcJL0ewFJHlTA4RORVSFZHZFV 439727Ab4K8CVkQXsTT9x3DYd691TAl5RS154K/CkjUBOJHPDo3LlzN6xdew0PPPoqD/7rXk6UphBx 439728zG3PkckajNForTCeiSc0rRFlEKVwSqel0WGqpJKE1Tg8BVd2d/HNW89jy5bNFdsctNZee8cd 439729d7x+SoAfRqCGyDfz+fyfd3d3q1ltZ/G392/j3556E98oOjoa8D0NCQmlEgspBSquLi45xCmk 439730sr8sglFw3tkd/MWfdHPi+EF2795dSdj/jqLo+o0bNx77MGwf5WvWS4FH2tralq1YsYLQ5fmX 439731H7/Grr3vMXyijFYxCRXPyKBMYhiFKB0PgwBK0ZJv4Nyz27nlC+eS90bYuXNnZUy2InJ/R0fH 439732XRs2bAhOB9fH+aL7RuAfOzo62pcsWcLixYsZHLE880IPve+OMDw2yYnxKUoTARZFLpOhoSFL 439733Sz7Hgnmt3PB7n6azTejt7eXAgQMMDaX2fgL4RqFQ2PdR8Hzcnxp4wI3A3cBnZs2apbu6umhp 439734aSGfz6cHxD81GB8fT39qcPDgQcbG0u/sAqXUFqXUd2677bbtHxnIxyUwjYxRSt0sIn8I/BbQ 439735Qvp0O/MlIsNKqc0i8ni5XN6yadOm0idZ/xMTONn/fPjhh+cEQdCpte4UkQbgfd/3j8yePfv9 4397360/X2aS/2/0DgN/r6X3TaUFhYoyx/AAAAAElFTkSuQmCC'! ! 439737 439738!VistaryThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/28/2007 17:08'! 439739lockIconContents 439740 "Private - Method generated with the content of the file icons\new\lock.png" 439741 ^ 'iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAYAAABXAvmHAAAABHNCSVQICAgIfAhkiAAAAAlw 439742SFlzAAAN1wAADdcBQiibeAAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 439743AA2HSURBVGiB1Zl5jF3Vfcc/Z7n3rbO88YwXjCc2DC5xgKTYJQgiJ6IoBSGhQmNDaNKUqCVJ 439744F1VEUEGlgkxLTKCiqgyqILIN1DJJLWxEXURwHGKiqqhicSpPUR05NVZsPAvjmTdvu/ds/eO+ 4397452ewBbIypeqQz77y57573/d7f+X7P73eeCCHw/7npM71h06ZNffV6/ctpmn7VGPN5a61IkgRj 439746TMNa++MkSZ7dsmXLT88F2PmaON0IPPHEE6uSJNmRJMmiZrOZt9aWZl93ztFqtajVauPNZnN/ 439747rVa7ZefOncPnBPWsdloENm/efGuSJJtGRkZ6S6USK1eupL+/n0qlQhRFeO8ZGxvj6NGjHDp0 439748iEOHDrmhoaETSZL82XPPPfej/zMCO3bsUI1G4x8ajcZXJyYmeq6++mouv/xy0jTl+PHjvPXW 439749W1Sr1bBo0SKxfPlyli1bRqVS4c0332Tfvn3s379/vFqt/nz16tW/e//99/tPnMD27dufHh0d 439750valcLndcd911RFHE888/Hw4cOJBKKV0cx68LIQa11lcqpVbEcVxatGgR119/fVQqlXj55Zd5 4397518cUXa8ePH3/4pZde+ptPlMDu3bsvHxsb2+O971m3bh3Hjh3jySefNN774d7e3mvuvffegyff 439752c/fdd5c6Ojr2lsvlz11xxRW5q666ip07d/L000+PVavVL+zbt+/tj5uAfJ//iyRJtlWr1Z4b 439753b7yRQ4cOsXHjRqO1/klnZ+fy+cADPPLII/X77rvvypGRkW/v378/ffXVV7nppptYu3ZtTxzH 439754O9evX68+bgLz2ugLL7zw7YmJiaVr166lXq+zefNme/755z//wAMPrD+dSTdu3PjUPffc0/Le 439755P7106dJ4/fr17N+/f9nRo0fvB+77OAnMFwERQnggjuPOlStX8tprrzE5OZlUKpVvnMnEDz30 4397560A8bjcbre/bssV1dXaxbt64EfOfjjsIpBPbu3fvpZrMpLrvsMo4dO8auXbvSVatW3XHnnXc2 439757z3Ty4eHha7XW7uDBg6xZs4aenh51+PDhL30syNvtFAIhhM83Go3yypUreeedd4iiKNx1113b 439758P8rkjz76aLNare4fHBykr6+PVatWVbTW3zx72DPtFAKtVut38vl8zlrL4OAg3d3d/3M2XzAx 439759MbGjXq+3JiYmuPTSSxFCrD6b+U5us0S8QXKYONKrr+rsLNJoVDly5Fd+8eLKS4cP356fc9fh 439760k6c5fOqoPdDp4me1Xvi92uQ4y85fjFb0/OypFXmAkdJhs25dcGdDINsHxv78lgB/j0xlksR9 439761aeIxxtGoJUILO2YSa73zBO8JwRFCAD/1PhCCx1mDsxZrDc45vAsE7/He07JRb5okwnuPs45Y 439762mdHUmGCM99a6737lriM//KgENEAQ4Xt0vLgEYTAOJsYCJ4YD40OBE8Nhwfgw5GNFsaAp5BXF 439763vM56IRvnc5LU1DBJjTSZREmJ0hqd0+hIZ2OdjZ33jI1XF743XiU1hmPjCx8CPjKBTAPCdSAM 439764ACYFk7R7mnUBKCWQUqCkQKl2lxIpBd47grd4byEEhBBZl9mrnDU2xpIai7EGKT0yuPymTRfl 439765zioCNvUypAGbQqseaDUDaQvSVsAkoQ0elATZHksBQoKQAecMrk1ACAEyA4xo9zZ4BBhncd4h 439766BOhIggyiY8yKsyIwPDSiakdbmAQaVWhMQLMaaNQE1gZ0JBEqEKTHB4fxksQpMIogFN62cD4l 439767hIDUGqEUTkmEEjiVkRTCEwigA4WSJi6U0VpQT5Wu1j4q/DaBQrEQpFI0JgS2FUh09qXeB7wV 439768KK1RUqKlRmtFrBSxVuQjhZbghIDgcd4hpUIiUGRLR4mpscQaR5pYGo0UhMM5aLSis0qzNUB3 439769pcP5Usy4CngLphloioA3IQMgNJFSxFqT15pCrCnmFYW8RoQU4yD1HkFAtSfVQqCQaBRaaLRQ 439770tNKUeq3F+EQNrUHrQLWaPysblQDBB0wCaQImCe21nwlYyhnBzhbwlKCDd9Minle8Ymr9C9K2 439771gKekId4vFz5TAj4ETAq27T42BdMWdQZ+lvtIMU1KEPDeth3IZaDlDOhpMlKQGkNqDGaKgAwI 439772AWd7KJLtxD5g7IxtTtnotG3OA15JgW8D984CYfrJnxyJKfs0U/apZgxqqm3ZsmW99/4RpdQd 439773t99++4/PiMDRo0N65L0G9WrmQs0qtFqZZQapcMJhvKVlJcEovFAYLyEYgkvw1oHUeKHwbeF6 439774EfDBo4PDB7DCERcVFV0m0gIdQRwr3qvp6JcT13V2F4tby+VycXJy8tkNGzb0nm4NLQG0VkFp 439775iZQSgSAEgTcCKVXbfRRaKSKtMweKMkFrAQKPCA4pQAqBRKJE5jpTPfiANY4kMTjrsNZirSUE 439776iUkJXedd/eCSJUuKSnmWLFlSGRgY+MvTjYAE6K5UXGVBjnJHTC6OESGCEBHJmJzOk49yFOM8 4397775XyBjmKRrmKJjnxMIVLkBEQ48gJyAnJKkJOSnFTklCanIoINtBopE+N1apMNapN1apN1ktRz 439778oprzfQsXf61U3M2XvvgN8vlBuru7v7thw4bTkngmYuuydd+aWf8z6cKMBmanElNrfz73OVkH 439779xlrSdpI35T5KK+I4h154c6mrS+cvveQHFPLjXLjiH1m8eHHfqlWrvnXaBDIbDZg0TAt5jnjn 439780gJfTAs4s1H4g+BBC24HsNHghIIpyCN3DslU3F7o6nyKXmwCgr2+QfO4/6OnpuYcsDTuNCHg/ 439781y30CznCS88g570PwBGenScznPlN2OgXeGNsGH9oEYt41N9Bd0WL58h1zQPUueJz+/v7+Xbt2 4397823fJhBDTAyNAJPXQ0oVEN1OuAEHjhsd6ROIuwGlKJFwrrFVI6nGnhnSEEiQ4KGyQ6CFwIOO+x 439783zqEEpNaAgnwpRuu4vQML8uUl1DpvRvAwx456Dh7smQZ15ZX/zfDoHkqlgfv5kFRbAjjvcBas 439784ybpU2S4q209SCtpjkBKCd+3Cxref+ixfz/5M78TOO5zL0oypzyit+XXrenK5Fhes+Bf+/bU+ 439785fvqzP2bvK3/Ezue/wvHjEZXOx+jv779427ZtN3xoBCoLKnbkeIypBxoOcrGiEGsKuXbxUmgX 439786MHmVFS+tGiZJSJ3NNKEEWku0VqcUL7Zlmaw2MDZB64COIBeWkeu/BcJfE0UJnR0tpJTUajUa 439787jTqR9PR0vc3Q8F66uz/1IPCvHxiBYGfEK8RM+qDb4GYLesp5vHdAOEXA71e8zBbwKL+H0qNc 439788dNFeADq7UkZHRxgdHWV8fBQRPEkdiupxBgYGPrt169ZrP5CA96GdyDEnaTu1ApsneZNzk7bZ 439789ZFJrMdbivZ8GH+Lz6Or/feLo+yhl8A5ykZsmkCR1sJ6kAR35t6mOvUJvb+/DH0rAJqFNYB7w 439790syzUtysv7+Z3n6mxc346gRMSpAhIARPR15HqCBcsf5W0BUkdIuGpTowRQqBY1AQbSBrZtVB7 439791nIGBgd/cunXrNe+rgRNj42pyMsVYUEpjvEPZrItEElA4FK0UrG3ibIK3HqUV2gu0E2gJ1gU0 439792Ho3Feo/1HhkpSnEercDpZfRdeBuRvAPT8tgUnAGJQ0iPtZY4inGJx7RNpSgGOTG8j97epd8H 439793fmveCJjUiDTxCBEADwQg4IPDB48LHus8iUkx1mKsxwfR7tkdLpBZaAg4ILUWF7I5tVboSDFR 439794+CbODrK49zWSOiQNaDVAOM+BAwepVqvkcyXSJtMRSBrQePcxBgYG1jzzzDOnaKFdkVWMFnlk 439795JGeOTPJq2n0KeUWpoLFpnbRlSROPIPNzFakMoG4fn0QaKRVps0Wz3qLRbKA1uNzF9K68AZH+ 439796AWkj2yxtmj1lbKCzs0yxWCSf1yQNcOmMrUfpICO//jl9fcs2Aj85JQJAlaDnLV6UytwoBJ/l 439797PycJeD4NGDtr920XL0nlT7HJG1RKb8x5ukkDfOq54FNl+npLdBYn51ybGr938DFWrFixZufO 439798nXP2BRFC4Jf/tu5mZ9LHrTHaO5+lCqF98tbu3jucMVhncdbhncO3T96889kBgMs+Z50jTQ02 439799NZkDda6OL7nm7zpj84eUc7+YfvJTUXAG6nVJmkicCUTSzYnA1Lh3zRYSsezAtddee+kcAuey 439800CSHE7t27f7Wg69Dyhfm/yECfBMwYyT/vuYIjQz3cdE3CougVrBE4K7ApeCNwTkD5Mi7+8hYG 439801BwdvvfXWW38EH+GH7jNt27Zt+1ZHR8fyDrULH34D304whRAIJZAe3h2q8MKedwlhiO7KF/ja 439802Fz+LjDzeQpTLUpPsJs+JY29QLvc+CJx7Ahs2bJCXXHLJ34b0F5S7enBuASGAYOb0Tio4b4mi 439803t6dKtWZYubyDQvnTBD8FejYBQXP8dbrOu+XC7du3f/222277p3NKYOnSpd9RSi3wtoGIPoNW 439804EqkheIFyAu+zcVQQ/OCRz3CiGujpkEh5fnuG2ZV/+3WyicnOX/8KOLcEnHO/nSQJrdxl/NcR 439805yMcJcRQjpSKO82itkEojkCgh6V2QAZXttNX7gA8BZx1JmmKMhy6Jtxbn3HI4x0sol8v9yeTk 4398065H8mSfK5QqGQa2ptpTQWjIWWE0JYKaUTQljnnBNCeO99CCEE732QUuKcEz77HULYDHiw1o54 4398077/fCJ+BC57r9L8W3oJnRdqB5AAAAAElFTkSuQmCC'! ! 439808 439809!VistaryThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/28/2007 17:08'! 439810questionIconContents 439811 "Private - Method generated with the content of the file icons\new\question.png" 439812 ^ 'iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAYAAABXAvmHAAAABHNCSVQICAgIfAhkiAAAAAlw 439813SFlzAAAN1wAADdcBQiibeAAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 439814AA8fSURBVGiBvZp5cBzVncc/73XPjKTRZVmyJR/yxWWwHcCgkk2ZAmIMxWZNdimuojaBYjlm 439815sbeKikkgS9h7AyTZZcnCgJeQLCSBynKEcDjGppYNrA+ZQ4YY2yBbh21J1u2RZkbT3e+9/aO7 439816RzOyDBh201Wv1NNTmvf9/n7f7+/93psRxhi+zJVMJgXQBKwB5gGzCoYAugtGF7AV2J5IJPSX 439817mji4xBchkEwmZQD460KItQ0NDQ2NjY1UVFRQVlZGPB6nrKwMgHQ6TSaTIZ1Oc+zYMTo7O+nr 4398186+sHXgFeAl5NJBLeH4xAMpm8Ari/sbFx6aJFi5g/fz7DaYvWj7N09joMjLgcHXLpG3BxXE1F 439819maQyLpleabNgdoxV51bSUKPp6Oigra2NI0eOfALcC/xnIpE46Wh+bgLJZPI84MGGhoaLV6xY 439820AdHp7NiT4b39Gbr7HRxX47oaxzU4TnivcV2D1hqtNFprjDbMqotw4fIq/uSSOiIMsmPHDvr6 439821+t4D7k4kElv+zwkkk8m7qqqq7l+5cqWsmdHI67tG2f5hmnFnArTrahxHFxFxXY0qAB6S0Npg 439822tAYMay+qJXHdXMZGDrFt2zbGxsZ+EBD5XB75VALJZDIKPD537twbV1+6hv/Z4/Jm6xjpjMpH 439823Nw/Y0cc987wAuC4GPplIxIY/WzuLW66aydatr9PT07MJuD6RSBz7wgSSyeR04KVly5ZdcM55 439824K/jVmyn2dY4XRzwAPpmI62o8dXzEpyYy8V7TsioeuudMPty9g48++uhj4LJEItFx0gSCyG9d 439825tWrVqvrGxfxi6whHBz0fsFugb8dMemZwHY3rFchmkv6PI1FARGvNnJkxNv792YwO7aelpWUv 4398260JxIJFInS+DJZcuW3XTG0mb+/dVhUmlVZMpirWu0B6fMjbJgVozGmVGmVdqUlUhyrqa7L0dP 439827f46unnH+e9cQ2XE1dTa0RiufRGXc4sVkM51tLezbt28rcHkikVBTEbCnAP+tuXPn3nTueSt4 4398284rURRjMKz9O4nsHzTF7b4bPF80q458ZZxEvlCWJUkb8bHGnkpy8e4dnXuslkDSYP3vhEjMYY 439829zXBK8Y0Nu/jN4ytJpVKre3p6HgLWT/XpRbMmk8lzqqqqHlx96Rqe+90oR4ddH3QA3HV90G7B 439830s/rpkU8BX3xNr46w4ab5vPDwOVSVWxPAtS4mojXth8b483ve4ZKvXkpZWdm6ZDL51c8kADy4 439831cuVK2bLf4+PDuYmIuzpPxPMCk7p+RpQ++ZW8saGUh+89E9sCY0IZhUQmSGx7t5+Nz3bR1NQE 4398328ETQtkxNIJlMrmloaFhdV9/I7z5I5yUyMQLZuBOvXU+jp1TmZ1/nL6nmhrWzfeBGo83U2fjx 439833z/Yzbfo8amtr5xtjbp6SQMDsgRUrVvDm7jSZbADUDbXuR9x1TZH+PdcwlHIBGBn1ePv9FM9s 4398346uPHvzzMz1/ppatn/DNIVBXL6DgihtExl/uTe1i5ciVCiB8mk8mSws8ITXxxY2Pj2dF4LTv3 439835DOSjm5eNOxFxN//Mf93WNc79Tx7mtbeHGM+potL4o5928K/3nM6F502bksDZi6um1L8xJiDi 439836v/fUcwdZ983TmTlzZlVfX991wM8mE/j6okWLeP+Tcb89KKw4biHo4mfGGDq7s7QfThdUlEDT 439837AYBnN/UUETDG4DgO2WyWocFR3NwA2vMwWqGVh9YKrT2M9tBaYIxAG8EvX9jL2ksWcfTo0Q2F 439838BCSAEOLK+fPn88GBbLFRJ+s/JOaZIqAh2EIzhq8r44KxsTH6+/s5dOgQBw4coKOjg97eXlr3 439839HEG5Y2gvg1IZtMqhVQ6jvCD6DlqNY7w0z7+6mwULFgAsLpSRTCaT59bX1zdmnAhdRx0/upOM 439840Wqh/37jFQE2eiM6nXTkZ3EwfS+al6e3tZWRkhEwmg1IqT3rLW0cxSmNMID3jy8dolZeVf6/Y 43984193EvfUOa2tpaKYS4vTADl86bN4/ft48HWi8wqnu8/pUyaFMAXE9EX3sOXm6EXLoHZ3yQ1c3l 439842NH+lOp+hUELGGHr6smx5uwdjVIH+QyL+HP5r3w9Ge/x60z7mzJmDMebaQgKNFRUVdA+4RSbN 439843S6lAOp5XHPGQiHIyOJk+cpmjuLkxtPI4fX4p626Yl28ZAP9/gyrzwON7yY57RaUzDEaYEX8O 439844lX+v7eAAFRUVAGcUmnhWWVkZwylvoroEC1VRxXGniriLMz6Mcsf9iZUfxepKm3tvPwVLTkQ8 4398457Lm01mx85iDv7xkuKJ06T0JgkBJsCQIB2Bij8FxDd0+K8vJyKOhPJDArHo8zlPKKKk6R/r3C 439846iPsR88aPkcscRbm5gtQrbBvuSyyipsqeEvzzmw/z7MudE5rXGmE0dkQQKxGUlUrKSmxKSyxK 439847S21KSwQlJTbxeIThkbGQgPXoo4+WF2VgcGT0hPovrDDKy+KMD2M8zzegVmhNXq9XXVbPqfNK 439848i8CHY9fuIR55+pPArBpLGGRUYEsLS4CwJAIDGKQQoA0G4UtQC4ZTaeLxeBj8+cDv892o0mbC 439849AyeoOM74MCqXDiqECiJoAhKGWBSuWjOjyKzhGBl1eGDjXrTygdsxgWVJbAlSghT+X9AIAcYA 439850RoMxGC3wtCYatVEq37vMDgl0p9PpOeUlcmKhOq7iKNzsCMpJ502ZX0GNCqqE4vyzqiktsYoq 439851Tnj/0E8+ZuRYjpKoxLbBtsCSAssCIQVSaIQBISSaoEE0wg+SEkgjmF4TJ5PJ+Nr32WID3ZlM 439852hooyWbRQTVQcjZMdnDCqDmVTWEp9EosXxo+rOACO4/HuniFKSy1sCbblAw8jLyyBQPrHYIAV 439853rClGg4VES40xgppp5aTT6TA4PXkC6XSaynjVROPmBdVGKZzMAMpzfMBGFbS/YQ8zseDUVEem 4398541H774Qy2BbYlsWyBLYUPXgqEJJCMABFGXqO1AGmhjcKSfksxvaYinwHP8/IEDqVSKebMqA06 439855UD/tSnvkMgNozwn6E5U/Ggm7xtC4oQfgePAAHYfHiMX86EvL134IXIigoxe+5BBgtERKP7tW 439856kE0MnLKghmPHjgHo9evXD4QEtnZ0dHx/1cXL+JHXk5eFmx3ye5NQNuHG3AQkAtkULv9Pv9jF 439857y290Y4x/VGJLsGzByDGHWERiWcKvNMKPPkKghfAzoP0MGG3A8o2LNKD994WCq65YzLa3XgUY 439858AN8oNvBuX1/f4XjMmXPq3BL2Hkzj5lJ4bjYok2HFMWB8WYXgTdDX6KCmt3WOIjDEIoJIVBC1 439859BbYtsG2JFbWwpQhE7w8BCGH5qrEmdnbaaLAEwgR21oaamkqqyjUjIyMAr+YXsuA88jcdHR1c 439860eG45Sjm446l8xAuNqrQKzOWD93t2lV/IpDBc1DydxA0L+NbNp3LNFXNomFGKbQsitkRYFsKS 439861SMsGaWGsCEZKlLDQwkZhoYWFkRZgYYTECIEQguVLZ9Pe3h4a+MWQQLgO/Lqtre0vLl91Go88 439862vdvvx02hUVWxcYs84JO0Jfz1+sUsX1JdVEZXX1DLz18+Quv+UYSUGCHRCIwQaPx7LYTvIQFG 439863GIQGIQTCXwwQEm665ivsfmcLgJPL5bbmMxD8faO7u/tDN9vH2otnBP2OV7QrmjBsYSk1+RX1 439864mitmc+5ZVceVUdsSXHd5PdOqYiAtv7JIGyVsPGxcLFxj4RHBNRJlJFpYaGF8+UhYvmQethli 439865YGAAYPOdd96ZLSIQHKR+Z/v27dx+7WmUxIJFUHt+u5uvy5Pqv1FgIBKRnL+0umhzE5LQWhON 439866ShY1xtHCQuEP19i4xsI1ERxj4xiJh4UyEmXAGL9MWcLmvvXN7Ny5M8T8TxRc+VOJRCKxqb+/ 439867/43hwSN848qFfgbyO6yCvrxg86G1IRqBqA0VcauofBYuZFprykottJB4SD/qWDjGJmcsHG3j 439868agulJZMPaS5duYjhgc7QvM8lEokdUxIIrru2b9+ub/zThaw4uy6IeABeq2CfSr5Hj9kQscCO 439869wOGj2SkXsTAbRwZdXC192WhJTttktU1GRchpC4XAb92MX53QzJkxje/cspSWlhYAz7Ksuyfh 439870LSaQSCTeHxsbu3vrltf5579qZv7s8ryJJ7Z4HkYbhNDYNkRsgSUFr/xXL46rpiRx4Mg4ew+5 439871aCxcLXCxcbRkXElynp85aTSW33si0VSUxnjyHy/mt7/dRDabBfiXW2+99cCnEghI/KCnp+ep 4398721vd28tg/XEhVRSTQf2HrrIkU9DS2Bb39Wf7tF+309I/ngStleGdfmp+8NozSAmVAI/wmUfuT 439873xyyHqHCxpYclfIfEJDz+N5fw7q63Q+O+2dfX993JWOHEp9Mx4M2mpqbmaXULufnbW2jrGCk6 4398748ymJCeKlFpGo9BcrS2LZEiElsRKbaIlNOguOFigkyli4SDwtcYyF33kYv7VGYQmFjUtlSYTH 4398757ruI1MB+WltbATq11svvuOOOwakITHkqm0gkcsCVLS0tuzoPtPLi43/MBcvrJ/a3RuO6Civs 4398764/HrtgEQgnFHkxr1cFVQCg2YYKMCmggeMeESkx4x4RARDhHjMre2nBceuowj7e+E4NNCiK+d 439877CPwJM1CQiRLgqfr6+qvXrLmMR5/azWNPtzKazmGMpr62hGjMwrIkUgos2yJodDDC8hcrIfOl 439878UeNH3p/RN6xEYwu4pKmR7926lM2bN4Wy6VJKfW3dunUfnhDgZxEoIPK9eDz+t01NTaK6ZjYP 439879PLKNZ17aQ8QS1NWVErElBCSEkAEBAcKvLjoYRgtMeL5sDJaApafU8Xd/2cToUBe7du0KDfuW 43988053lXrV+/vv+zsJ3M16wXAE/U1NSc0dzcjKvj/MevPqCl9TDDoxmk8EkIETZrViAY4bcP4TxC 439881UBkvZckptdxyzRLi9gg7d+4M22RljHmkrq7urquvvtr5PLi+yBfd1wMP19XV1S5cuJAFCxYw 439882MKJ4+Y022g+NMJwaZ3QsRzrroBCURKOUlsaojJcwd1YV1/7RaTTUGNrb2zl48CCDg3l5vwB8 439883N5FI7D8ZPF/0pwY2cD3wbeDM6upq2djYSGVlJfF4PD/A/6nB2NhY/qcGXV1dpFL57+wcIcRm 439884IcT3b7vttu0nDeSLEphExhJC3GyM+SZwFlBJfnd7/GWMGRZCbDLGPJ/JZDZv2LAh/WXm/9IE 439885pvrMjRs3Tnccp0FK2WCMKQV6I5FIz7Rp03o/r7Y/92T/DwT+oNf/AkoNR+wGvYlRAAAAAElF 439886TkSuQmCC'! ! 439887 439888!VistaryThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/28/2007 17:08'! 439889smallErrorIconContents 439890 "Private - Method generated with the content of the file icons\new\smallError.png" 439891 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAAAlw 439892SFlzAAAEnQAABJ0BfDRroQAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 439893AAMiSURBVDiNXZPPSxx3HIafnRl3nTVmo3Gprlus7opBYtSGtoLQWv+AkqSF9BiQIHMQc8oh 439894gSTnECGkkG0PIaJQgreWeJRGTDAQbRGNtoZWXaG4uuvY2dnZHzPf+fZgK5oPvLf3fT6nJyCl 4398955PhNTEwMxGKx6/Wq2l9jWc2OphUPdP3XzO7uT6ZpfmcYhne8H/gfkEqlwu2JxESP635dnp2l 439896tLGBa5pUHAe/qopwXx/ZgQFzOZ3+cnh4eOkEIJVK6f1dXdvNS0tnnZUVXNM8HNs2rusehXCY 439897+hs35Hyx+O3Q0NAUgALQnkhMxFdWzhZXV/HyebxCAbdQwPO8owjfx8lm2bpzJ9DV0PBjKpWK 439898ACiTk5Nf9CrKN8XVVTzbpm50lJZnzyCZPBxKSceTJ3wyP4+WTFKxbayHD9V4LPYCQGlqarru 439899vX59+Nm20Ts7CdXUkHz8mMC5c3wwNoZsbSVnWWQvXmSjXOa3hQUi+Xw3QGBxbu7PhqdP2yoH 439900B7imiUgmaR0bo+y67OdyCN9HCMHb2Vm2796lXCxScV0+u3mTjaamPqXWcT5083k8y8Itldh7 43990184Zfrl1jb2/vaLy+sMD2vXtUymXQdbQzZ7C2tgCuaI6q2tWWVVdxHDLFIrbnEbt6FSklQgiE 439902EMQ6Otjt7aWUTiNVFSElNdEoOcgpB5q24CsK2WKRfKVC461bRC5cwPM83i0u4hQKqJpG5+3b 4399031HZ0ENZ1wtXVhFtaAKaVTCbzs9/dzT+VCq7rEohG8TyPtZcv+fv+fdYePKCQz+NLSSAaJez7 439904nNI03HjcB9bUwcHBxUhPz4g9N6eXHIedmRkyuRwHU1MEdR2tVMJZXsZcX6fu1StUIWi+fJk/ 4399054AfDMJ4rhmGIt+l0/0cjI9JVFMr7++Snp1GDQdRgkCohqN7cJDozQ8iyON3WxlYikZFSjpxw 439906YXx8/Er76dNTm48eqfs7O4QiEYKKQkgIgo5DUAjqL11i8/z5HcuyPjcM490JwH9CnYo1Nr6o 439907tayP5fZ2oJxOEwyFqIrHKScS/l/Z7PdSytHjRgbe1/kY7FPgK8ACngO/G4bhv9/7FxuHuWxf 4399081Q6XAAAAAElFTkSuQmCC'! ! 439909 439910!VistaryThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/28/2007 17:08'! 439911smallInfoIconContents 439912 "Private - Method generated with the content of the file icons\new\smallInfo.png" 439913 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAAAlw 439914SFlzAAAEnQAABJ0BfDRroQAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 439915AAMMSURBVDiNXZPNbxR1GMc/Mzvd2dntbku3LtsXInFpxFiCepCSmgIHEkPiS8pF48WkwWYO 439916RP8C/wCPeBj1VHvwwE2DB29iMJqIJWhFoilLXwid0ul2Z9p5+/1mfh4Wk5bn/P18nuc5fDWl 439917FAdncXHx/Ojo6JWCOTTtJ5UxQ4WRVdhd2tpyv+10Op/bti0P5rX/BY7jlFsnJhZF5ZXLN+8k 439918tDdiOl1BGKb06TlTk2XOT2531tp/Xpifn797SOA4jnXq1en1u4/H6ssrIZ1dQRhKZi8M8sMt 439919j/srPiIVlE345IMhFXm/vDc3N3cdQAdonZhYXH4yXr/XjvADiR8IxoYNPnyrwaU3jiCERKSS 439920bS/k02ur2vDIqW8cxxkAKLRarXO1YzOf3fojxvclXV/gB5JHbsTPSx1u3NwiChOkEEghiSLB 439921yrrSL54tv3ny5Itf6iMjI1d+vScJAom/14OlkJBnVC1BzdwnCT2SvU3iYJ0kaHP7tzsE8cBp 439922AL1UGTrbfpTgBz1YpJI0STjzUs47U0/4aLZKEnqkcReR7CNFhEhD/mmHmuM4Z/RQVo8FT+E4 439923EkT7HlF3AyX3ieMYlESKFClS8izFKsJg1WB1wweYNQqEe35QOhJGKdGeSxoGPUBKhBDougGZ 439924YLCmUzLLFDSFUhnPDVcAzzOMfPe2TuNiFGyThgEiTREiJZcZ9Xqdnb0+mo0SZqmArmsoDfI8 4399254/nRMmR8r7uu+93pVk4adhFC9LanCVkmaDQaGH0G/bUSRtlCWRXyYhnD6mf8qMiBv3XP85xz 439926L+92rJIiEyky7f1rlTRqtRqaXkCZFnGhQkA/kWZxaeY47uMHX9m2neu2bWdr7b+mr75/XOmq 439927d4FVVLTXuvy+vMNPS5vEmHRkGV+avNCs0RpadZVSVw91YWFhYbZWn7h+7euHhc2tHQYGTHSz 439928SKabhBTJKPLu1BCTRx9u+r4/Y9v2v4cETwvV32yO/ujH1dfWXaWtuQlmqch4o49WM8m33Qdf 439929KKU+PthI7dk6H5C9DrwN+MAN4L5t2/mzuf8Ad6/AAZ+lo8QAAAAASUVORK5CYII='! ! 439930 439931!VistaryThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/28/2007 17:08'! 439932smallLockIconContents 439933 "Private - Method generated with the content of the file icons\new\smallLock.png" 439934 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAAAlw 439935SFlzAAAEnQAABJ0BfDRroQAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 439936AALVSURBVDiNfdM/aBNhGAbw57vvu/tyd8m1Gmtr26Bp1QoqCBlMUUREHNwcuiiIqKCD0EUc 439937XFwiFapYCGJ1EcQKWQpWcCmIQkBBaa3oIlSrNbWpNndJ7nJ3uX9OLWKtz/7+eJ8XXhJFEVYy 439938NDSU1nX9nOM43Y7jLFSr1XyhUPiB/4SsAMPDw8d0XR/VNK27t7f3M6U0WSwWjbm5ucHx8fFn 4399396wECAExMTKi2bd/MZDIN0zQHBwYGdk1NTWV6enr0/v7+G9lstuW/QKlUutjZ2blnenr6Xi6X 439940uwsAuVzuW6lUupVOp/va2trOr1shNE5vff9p82OrpqRl+/V1LkaRRCMETQuubWJ6fsdl360t 439941blE/Xjt+aWFyDRCYRx7o1U9n3j0PoM9TpLaoSHWocM0SqBAinogjJAQfZpe+HL5Q71lToWqY 439942LQuzHvSfPiQegbEQQejC9RwQkQFMgOXYSCToP+8gaK3cCX0Ks0Kh8hgSigwaeZAEAolSSEzE 4399430i8DVsP18vn8vnw+H/sTYIvzllye98C5ACoGiIgHs1EHZQwhpfCiAFJMgMJlsU/Z8NoP1CKA 439944o6sbiIzbzQaDwjk0RUZSUyEENjijiDGGes2C6zowYmdj2exVvn37iyOFQiGxCpS/N+TKkgfK 439945QoD4qNYNeBEQChQhIbAcB4mEjPZeSR4Z2Y2Zd5MklUreWQUESDaNJGiqjI2aCon4kEUBssgg 439946cwkVvQorfg7t7ffJ3FcbetkEx9NTY2NjMgAIy2U7RlkIQnz4oYe6ZcIHhQ8CvW5CiSvQUiJc 439947YwlfZktgaEWz/Ejo6kzeBgDy5smhE3bVHGhRKRQeoa4vgjEGyiiW9RqaHVcObu26kfLMZbx8 439948tQ3drRUIbg1IDoaWdCBB/vzGvzM6Osr39v20N6szpNmgmPoooUOLEJcJvJDD33TyIVt3GgAh 439949hFTMfW897JclKWbvzDAXIAEIAfUDVjeM4m+dHTsKS7Yv+wAAAABJRU5ErkJggg=='! ! 439950 439951!VistaryThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/28/2007 17:08'! 439952smallQuestionIconContents 439953 "Private - Method generated with the content of the file icons\new\smallQuestion.png" 439954 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAAAlw 439955SFlzAAAEnQAABJ0BfDRroQAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 439956AAMdSURBVDiNXZPNbxR1HIefmV129qVd2i2026VQdOVkBeFA0SalHrxooogkajxwaGozB6IH 439957/gMvXkx8OSzxVNsbniQSk4qk6kENiCFUFIt9p+1sup3dme3Mzu83Mz8PRdPyPX+eJ9/Loyml 4399582H2Tk5MjpVJpLGEUhpwgdyipPD+TqN+pVq2vbdv+3DTNcPde+09QqVSy5WeOTcrc82/+8HvA 439959wmoLuyHxPME+PebMQJaRgU17eeHeS+Pj43f3CCqVSua5k0Mrd9cPdc3+42HXJXZD4nuSli+Q 439960QiKFJGvAB+8WlF/7+e3R0dGr/wumv7vx1Xzr1IV7cx71hqS/O8l7b3TT32uwarW4+esWH12Z 439961IwgCdCI+vtwVrS391mWaZkOfmpo6q3eevHB/3sd1QxxXopQiVoqNTcHhYpqLr5cYPN5OKEOa 439962TcEnU06iVOqbAUj29vaO/XI/3IGbEscN+fGWzfRPVVIJycSHZQp5jWKnS8tdQQY+t29J3HOD 439963JwCS6VzhhYVHAY67A0sRErQCgm2bp/ojYmmzth4yPfMQGWwTygApBH8veFqlUhnUvbD9sPsY 439964bvkSf7uG31glrbtcvngEFUd8OvGAxeUGcSTIpKCjPcnSqgNwPpnAazpuutPzBX7TQnguoRQM 439965v1igPaexZm3z7ffLdOR10kaWhKZQKuLggRxQqyWTcf22TvfLvruJ8FykEEgpsKrbXLvxiNkH 439966Wxw8YGCkE+i6htIgjiP6S1mIuK5blnXtRDlGeA2klIRSEIoA3w/It2mEcUxbPk0ym0FlcsSp 439967LMlMG309Mgb+1Gu1WuXss3U7k1ZEUhAKQSgFY28d4fTxDl4d6UEZGVqJHC5t+FqGV4aPYq3P 439968f2GaZqybphktL/wxdOmdo0pXOx9kUorrN9eYnWswc8ehhYEdZnFCg6eLecqFJUspdWlPCxMT 439969E+fzXceufvblYmKjusX+/Qa6kSLSDTxSRKQ4d6bAQM/ihuM4w6Zpzu0RPA6qrVgszTit9lMr 439970ltKWrQAjnaKvex/lYhBvWvNXlFLv7y5SezLnXbLTwGuAA3wD/GWaZvzk7l+B2cIZLVTLdwAA 439971AABJRU5ErkJggg=='! ! 439972 439973!VistaryThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/28/2007 17:08'! 439974smallWarningIconContents 439975 "Private - Method generated with the content of the file icons\new\smallWarning.png" 439976 ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiAAAAAlw 439977SFlzAAAEnQAABJ0BfDRroQAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 439978AAJtSURBVDiNjZBNSFRhFIaf77v3juV1dMYZf2auTqb9CGVBEkhta9uqheFCUIqIaFOr9gXh 439979oiRCZjRxITrgKG5aBC2CFFuUtHAhRcgglObYjD/3jqNz79fKWjhKB87m8Lwv73lRSnHYxuPx 439980F4lEovcoRiilKDUjIyNXQqHQjFJqL5vNBrq7u/OlOFlSDUQikcHWs0Oiwfrs8/v9Tw7jSsZK 439981JpMd8/PDnnKF2t6sU3NzH+xkMmmUYksmiMViryL1AwIUprlKqPptuWmaD/7rhcnJycvB4LdL 4399826fR37t3vovf2DWprBqmvr32cSqUO8AcOlmUNVPr7MHSFzxfGcSQGq/i0N9Wu63YdaTA1NdVR 439983UfGlPRpZwDy+QzqdZmNjBTsHZd4QTU0n+kZHR8WhBpZlxasD/eQ3QbgujrNFVaUPOwei8ANR 439984eFenadrNkgbT09PX/eanC6axiJ0Dr+CxuPgVwwiynQU7B/mVBM3NJ59nMpmDBtFoNO6jHzsL 4399852zko2h6R+jDBSomdAzsL7tYyO+vvrdnZ2c59nVBKMTEx0Xm6eXk8qD1kdwd281DIw+paDIo5 439986ythkdwf28pB3m2i5lvrZ3t4e/ZsgEAi81AvjFByLgtPAbqERO3+RR8/KmZ65ilLNQAtSP4VZ 439987ZuD8+hhJpVK9APrw8PDdpkYtXGGewy2exyclmiGQhkZb6wJtZ8JU1saA/fIFtrNEMNj6FHgt 4399884vH4WDQSvlXtX0EXAil1pNBRSuK5ChAIKQCJ8jyKrsceVWw4OmtrazW6pml3VlZ/j2XWy49p 439989mlYUQrhAUUrpAp5SyvvXl8TzQKlN4bruUk9PT+YPUsxAEGFWxzgAAAAASUVORK5CYII='! ! 439990 439991!VistaryThemeIcons class methodsFor: 'private - icons' stamp: 'gvc 8/28/2007 17:08'! 439992warningIconContents 439993 "Private - Method generated with the content of the file icons\new\warning.png" 439994 ^ 'iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAYAAABXAvmHAAAABHNCSVQICAgIfAhkiAAAAAlw 439995SFlzAAAN1wAADdcBQiibeAAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBlLm9yZ5vuPBoA 439996AAsgSURBVGiB1ZprbBzXeYafc+ayV4riRdyluFwuL6JoUraIRGjQ1nbQFikgo4CAIFURpHDR 439997ypdYgY3EsSOjaAIjCQq0P9oASX7YrlRFslTrZsu0fJPsJJbkOHZjy3IdJqoulCjKIi2aWpJ7 43999835lz8mMv3CUpuZCWBjrAh7Mz55v53vd739mdM6TQWrNU2xNPPBEDLt1///35paohloLA1q1b 439999BXAI+HMgrrW+45577jlT80KAuRQXNQzjEWC9EEIAYeAF4JalqFVzBXbt2uVRSl2oq6sL1dXV 440000kc1mmZqaQin1N3fffffemhYDZK0vCDwaDAZDoVAIv99PQ0MDjY2NGIbxvSWoVVsCzz77rNcw 440001jM3hcJh0Os3Y2BjxeJyWlhZs2+7fvXv3+lrWgxoTcBzn2/X19a2maeK6v2bd539CwP8GmUyG 4400025uZmYRjG47WsBzUk8OKLL/qEEJtXrlzJ9PRp7rz9X+mMHeX2P/03crnfEAqFsCxr3b59++6s 440003VU2oIYF0Ov1wY2PjSiEE0fbdeDzThQIyT9/qXSSTSUKhkAQer1VNqBGBY8eO+YUQD8RiMa5e 440004/S3dXYer5le2vksm8zbRaBTbtu/cv3//52tRF2pE4JNPPnkoHA63aa2JtO3AMOb/8Go6Y7tI 440005JBJEIhHDMIzv1qIu1IDAa6+95pdSbl61ahWXL79NZ+y1RfMibW8zOXmUzs5OpJR3DQ0N9d1s 440006bagBgWQyuTkcDrdnMhlWtm5DSucamZpo+07i8TjRaNRyHOcfb7Y23CSBd99916+1fmj16tWM 440007jLxOV+cb182Ptr/FhQtH6O3tRWu98aWXXuq4mfpwkwQuXrx4fyQSaZ+enibStg0h3OvmC6Fo 440008j+xkcnKSjo4OTyKRePRm6sNNPAsdPXrUf+XKlVPr16+P/OpX/8lf/NlDCKH4yU/bmJkxFuRL 440009CY9tGUUpyZHXf8odd9zNwYMHk4FAoHvDhg0TN0rghp9GJyYm7ovFYpHx8XFiHT9DCAXA8Tc7 440010aGi4DQClFFprHMdhYmKUx7aMIqUi2r6bycm7iMVigbNnz34LeOxGcdyQhYaGhgKO4zwyMDDA 4400116dMH6e76TXkuGITW1lZaW1sJh8M0NjayfPlyAgGJ1uA60NXxFsPDh7nttttwXfeBPXv2NHym 440012BGZnZ+/r6elpu3TpEr2rdiHEnA39vixaa7LZLMlkklQqRTKZxDDSuHlw86Bdh1DTLuLxOD09 440013PctSqdSDnxmBw4cPB5RS3xkYGODcuWfpjJ2omvf5smXQlaNlZHFylCPW/iYffvg6a9euRQjx 440014zW3bttV9JgQuX778QH9/f3h0dJS+1buB6i8Bvz+zAHwymcTjyeLkKYd28iz3P83s7CxdXV0N 440015wDeWnMALL7xQZxjGlv7+fi5c2EdH9IMFOYHA4grY1pwCJStFQ0f5nw9+UVLh4SeffNK/pAQm 440016JycfXLNmTfPIyAgD/Xuq5pRbABfwu6RSBdClyGQyBPxuGXiJiHZzeMVO0uk0nZ2dK0zT/PqS 440017ERgaGmqwbfuRvr4+xsb2EGn77RzwCmt4bZdUarbcfaUUlmUR8Ltz90BFflvjLzl54g3Wrl0L 4400188Oj27du9S0JgZmbm4VtvvbXhzJkzrBnYg1IVQErWyIHHVmSzKXK5HKZpYlkWpmni9eYX5ucB 440019lUVkd5DP54nFYmGl1L01J7B///4W27Yf6u3t5aOPdtPSfKoM2K3wtJMH23KRQpeBl0j4PU6V 440020/yutFF72C068d4zBwUGA7xw4cMCuKQHXdbcMDAwsO3XqFP29e8ug53fUyYFtKmxbYJomUkqU 440021Ukgp8NpuFehKK+GmyU/vQClFNBqNxOPxv68ZgUOHDrXbtv317u5uJsafpqnhbDXofHVYhuL0 4400226fOcPHmSc+fOkUgkMAwDU7oL8yus1+J9nRPvvcng4CBCiMeeeuopqyYEcrncP/X39/uHh4fp 44002369m/AIQ7z0qmVMTjs7iui2VZ5TClKoN251spD9pJkhjfgZSSSCQSCwQC/3DTBF599dXVHo/n 44002476LRKJMf76Q+eL5QtAL0/I5KoQgEvNi2XREmplRVgBezUoM8wvvv/ZrBwUG01luOHz/+qSpc 440025l0A6nX581apVnlOnfk9v7EAB8DVsUDpuCIXXa1V33zQwpV4UdKUq5GeZPL8d27YJh8Od4+Pj 440026m26YwKFDhz7n8Xi+Eg6HuTq5k6Dv4kLQlVYqKmOg8fvtagUsA6nVda1XOl6XP8zJ9/+bNWvW 440027ADz68ssvX1eFaxJwXfcH3d3d5tmzp4m17lsc9CJWElrR2W4QWbmMxuU2fp/GY80iUIsCnt8Q 440028nZ9m/NQOfD4fTU1NXZlM5r7rEVh0RXbw4MEvejyen69bt07+7oN/pifyI5QL2i388pZDzdt3 440029IZORjI37cJ3CvusKXAdWNGQIeJwF+fOvoV1waaTlj5+jI9bNO++8M9LX19d7yy23LPq2YIEC 440030r7zyilBK/bCtrU2OjJxhZeOeuS5/iv+dPBgo2lckibYkiYaSdIQSxMIJfKbzqSqWlHEzU4x9 440031+DRer5f6+vrO4eHhzf9nCyUSibts2/6TYDBIZua/sMTla8o93/8lK41ebmbo2Fp+9spf8cvh 440032rzGT6f9U6y2w0scHOf2/v6e9vR0hxMNHjhxZuNBm3pr4ueeeE0qpH7S0tMjR0XOE6w/gOmZR 440033XlGWWysxd6xoA60K8+m0yb/8RwNXZ1L4fKP0XO0hx5f5o4jA1udLzq0YCp+FFAgNhgBDCCDH 440034peG9tP3lI/h8vo54PP4g8KPrEshmsxu9Xu+g1+sldXUndh0o1YIuFdSFgloDQhRqSxBaoEUB 440035y6HjdVyZSuE4Dkoprly5Qnx6lunolwiJ5xFKoAQgBUKBMEAqUbEuEnOAMm9zfuQc4XCYM2fO 440036fOv555//8YYNG6re3ZQJPPPMMxL4fnNzs5iYGCPW/D5ChCj8mQu0EAijhLnQbVkiJEAogRTw 440037SVwDqQVSKxow7XDhPCXQikJUABZlZeaOTY0epulzX8Pj8USLa+cqFcoEcrncJr/f32sYBj55 440038FMsMot1gEXHh0loVpEaAFAVSFO2jBSgJa/rgrROzxUdoLytWrKC+vp6gncC0W9BaoN1Sw4v2 440039qQBcpYAQSHWB8fFxmpqaSCaT3967d++PN27cWFbBBNi+fbshhPhuXV0dU1NTxJqnEDIEgCza 440040Q8tCl7WiAKLYQakLlip19otfEFwYDzIyliQYDNLW1kZ3RwPhZR8jZXhxq1wDPIAXwcXJs8RW 440041rcO27Ugmk6lSwQRQSt1nWVa7ZVlMT08TiC5DSomWRaDlsdhtTeE+KBHRRVtoMC3BPX/dwuiE 440042JJGxaKq3aa6bQrJigT0qAc+psJCEnb5KMpnE5/ORSqW+uYCA67p/6/f7yzfe+Y+aCDXl8Hk9 440043mJYHrTRKaQQSpXSBgCreG7r0LaQBiVYay4SuKOVztLbRaKSQaHRZBa01Qgi01iBAaNBotC7U 440044yOXypHMw60YIui62baO1bt+6dWt406ZN45UK3Oo4Dvl8nvr6eqYz/Vy9qJBSLhqGYSCEQEqJ 440045EKIcJVBAQUEKAKubujBXa41SCle55deRSikQYPgNwsFCHdd1cV1XAl8F/r1MABhNp9MDpmkS 440046CATw+/0VT5Jzy0LDMDAMAyllea60XyJVAjcfZCXQUhQB4ThOOUrHXNcln89Tauzs7CwzMzNo 440047rbVS6kiVhYQQXwK+l0gkbk+lUh4ppQCUEEIJIXRp1ForKaUuzmmttRKFt7qqeB1FwSClUes5 440048BuWxaJuKKURppzSUPmutS3M5pdRHQojt995774eVJ/L/eVuKfzX4TLc/ADVWmsQ0jTygAAAA 440049AElFTkSuQmCC'! ! 440050ComplexBorder subclass: #W2KComplexTabBorder 440051 instanceVariableNames: '' 440052 classVariableNames: '' 440053 poolDictionaries: '' 440054 category: 'Polymorph-Widgets'! 440055 440056!W2KComplexTabBorder methodsFor: 'drawing' stamp: 'SW 5/22/2009 20:52'! 440057drawLineFrom: startPoint to: stopPoint on: aCanvas ! ! 440058 440059!W2KComplexTabBorder methodsFor: 'drawing' stamp: 'SW 5/22/2009 20:51'! 440060drawPolyPatchFrom: startPoint to: stopPoint on: aCanvas usingEnds: endsArray! ! 440061 440062!W2KComplexTabBorder methodsFor: 'drawing' stamp: 'SW 5/22/2009 20:51'! 440063framePolygon2: vertices on: aCanvas! ! 440064 440065!W2KComplexTabBorder methodsFor: 'drawing' stamp: 'SW 5/22/2009 20:50'! 440066framePolygon: vertices on: aCanvas! ! 440067 440068!W2KComplexTabBorder methodsFor: 'drawing' stamp: 'SW 5/23/2009 14:33'! 440069frameRectangle: aRectangle on: aCanvas 440070 "Note: This uses BitBlt since it's roughly a factor of two faster for rectangles" 440071 | w h r | 440072 self colors ifNil:[^super frameRectangle: aRectangle on: aCanvas]. 440073 w := self width. 440074 w isPoint ifTrue:[h := w y. w := w x] ifFalse:[h := w]. 440075 1 to: h do:[:i| "top/bottom" 440076 r := (aRectangle topLeft + (i-1)) extent: (aRectangle width - (i-1*2))@1. "top" 440077 aCanvas fillRectangle: r color: (colors at: i). 440078 "r := (aRectangle bottomLeft + (i @ (0-i))) extent: (aRectangle width - (i-1*2) - 1)@0. 440079 aCanvas fillRectangle: r color: (colors at: colors size - i + 1)." 440080 ]. 440081 1 to: w do:[:i| "left/right" 440082 r := (aRectangle topLeft + (i-1)) extent: 1@(aRectangle height - (i-1*2)). "left" 440083 aCanvas fillRectangle: r color: (colors at: i). 440084 r := aRectangle topRight + ((0-i)@i) extent: 1@(aRectangle height - (i-1*2) ). "right" 440085 aCanvas fillRectangle: r color: (colors at: colors size - i + 1). 440086 ].! ! 440087 440088 440089!W2KComplexTabBorder methodsFor: 'initialize' stamp: 'SW 5/22/2009 21:02'! 440090initialize 440091 super initialize. 440092 self style: #complexRaised! ! 440093SimpleBorder subclass: #W2KGroupBorder 440094 instanceVariableNames: '' 440095 classVariableNames: '' 440096 poolDictionaries: '' 440097 category: 'Polymorph-Widgets'! 440098 440099!W2KGroupBorder methodsFor: 'accessing' stamp: 'SS 1/1/2009 03:32'! 440100width 440101 ^3! ! 440102 440103 440104!W2KGroupBorder methodsFor: 'drawing' stamp: 'SS 1/1/2009 01:51'! 440105drawLineFrom: startPoint to: stopPoint on: aCanvas! ! 440106 440107!W2KGroupBorder methodsFor: 'drawing' stamp: 'SS 1/1/2009 02:17'! 440108frameOval: aRectangle on: aCanvas! ! 440109 440110!W2KGroupBorder methodsFor: 'drawing' stamp: 'SS 1/1/2009 02:17'! 440111framePolygon: vertices on: aCanvas! ! 440112 440113!W2KGroupBorder methodsFor: 'drawing' stamp: 'SS 1/1/2009 02:19'! 440114framePolyline: vertices on: aCanvas ! ! 440115 440116!W2KGroupBorder methodsFor: 'drawing' stamp: 'SS 1/1/2009 03:09'! 440117frameRectangle: aRectangle on: aCanvas 440118 440119 aCanvas frameRectangle: (aRectangle insetOriginBy: (0@0) cornerBy: (0@0)) color: Color white. 440120 aCanvas frameRectangle: (aRectangle insetOriginBy: (1@1) cornerBy: (0@0)) color: Color white. 440121 aCanvas frameRectangle: (aRectangle insetOriginBy: (0@0) cornerBy: (1@1)) color: Color gray.! ! 440122 440123 440124!W2KGroupBorder methodsFor: 'initialize' stamp: 'SS 1/1/2009 03:26'! 440125initialize 440126 super initialize.! ! 440127GroupboxMorph subclass: #W2KGroupboxMorph 440128 instanceVariableNames: '' 440129 classVariableNames: '' 440130 poolDictionaries: '' 440131 category: 'Polymorph-Widgets'! 440132 440133!W2KGroupboxMorph methodsFor: 'drawing' stamp: 'SS 1/1/2009 01:47'! 440134drawOn: aCanvas 440135 440136 | aSmallerRect | 440137 aCanvas fillRectangle: self bounds fillStyle: self fillStyle. 440138 aSmallerRect := self bounds copy. 440139 aSmallerRect := aSmallerRect top: (aSmallerRect top + (self labelMorph bounds height / 1.5) asInteger). 440140 self borderStyle frameRectangle: aSmallerRect on: aCanvas. 440141 ! ! 440142Notification subclass: #Warning 440143 instanceVariableNames: '' 440144 classVariableNames: '' 440145 poolDictionaries: '' 440146 category: 'Exceptions-Kernel'! 440147!Warning commentStamp: '<historical>' prior: 0! 440148A Warning is a Notification which by default should be brought to the attention of the user.! 440149 440150 440151!Warning methodsFor: 'exceptiondescription' stamp: 'ar 9/27/2005 19:54'! 440152defaultAction 440153 "The user should be notified of the occurrence of an exceptional occurrence and given an option of continuing or aborting the computation. The description of the occurrence should include any text specified as the argument of the #signal: message." 440154 ToolSet 440155 debugContext: thisContext 440156 label: 'Warning' 440157 contents: self messageText, '\\Select Proceed to continue, or close this window to cancel the operation.' withCRs. 440158 self resume. 440159! ! 440160BitBlt subclass: #WarpBlt 440161 instanceVariableNames: 'p1x p1y p1z p2x p2y p2z p3x p3y p3z p4x p4y p4z cellSize sourceRGBmap' 440162 classVariableNames: '' 440163 poolDictionaries: '' 440164 category: 'Graphics-Primitives'! 440165!WarpBlt commentStamp: '<historical>' prior: 0! 440166WarpBlt is a little warp-drive added on to BitBlt. It takes a quadrilateral as its source specification, while its destination is traversed and combined just like any other call to copyBits. 440167 440168The source quadrilateral is specified as an array of points starting with the corner that wants to end up in the topLeft, and proceding to the successive points that want to follow CCW around the destination rectangle. Note that in specifying a plain old rectangle source, its non topLeft points must be actual pixels, not outside by 1, as with rectangle bottmRight, eg. See the method Rectangle asQuad. 440169 440170WarpBlt does a fast job of rotation, reflection and scaling, and it can even produce a semblance of perspective. Depth parameters are included for future improvements in this direction. but the primitve does not support this yet.! 440171 440172 440173!WarpBlt methodsFor: 'primitives'! 440174copyQuad: pts toRect: destRect 440175 self sourceQuad: pts destRect: destRect. 440176 self warpBits! ! 440177 440178!WarpBlt methodsFor: 'primitives' stamp: 'lr 7/4/2009 10:42'! 440179deltaFrom: x1 to: x2 nSteps: n 440180 "Utility routine for computing Warp increments. 440181 x1 is starting pixel, x2 is ending pixel; assumes n >= 1" 440182 | fixedPtOne | 440183 fixedPtOne := 16384. "1.0 in fixed-pt representation" 440184 x2 > x1 440185 ifTrue: [ ^ (x2 - x1 + fixedPtOne) // (n + 1) + 1 ] 440186 ifFalse: 440187 [ x2 = x1 ifTrue: [ ^ 0 ]. 440188 ^ 0 - ((x1 - x2 + fixedPtOne) // (n + 1) + 1) ]! ! 440189 440190!WarpBlt methodsFor: 'primitives' stamp: 'lr 7/4/2009 10:42'! 440191sourceForm: srcForm destRect: dstRectangle 440192 "Set up a WarpBlt from the entire source Form to the given destination rectangle." 440193 | w h | 440194 sourceForm := srcForm. 440195 sourceX := sourceY := 0. 440196 destX := dstRectangle left. 440197 destY := dstRectangle top. 440198 width := dstRectangle width. 440199 height := dstRectangle height. 440200 w := 16384 * (srcForm width - 1). 440201 h := 16384 * (srcForm height - 1). 440202 p1x := 0. 440203 p2x := 0. 440204 p3x := w. 440205 p4x := w. 440206 p1y := 0. 440207 p2y := h. 440208 p3y := h. 440209 p4y := 0. 440210 p1z := p2z := p3z := p4z := 16384 "z-warp ignored for now"! ! 440211 440212!WarpBlt methodsFor: 'primitives' stamp: 'lr 7/4/2009 10:42'! 440213sourceQuad: pts destRect: aRectangle 440214 | fixedPt1 | 440215 sourceX := sourceY := 0. 440216 self destRect: aRectangle. 440217 fixedPt1 := (pts at: 1) x isInteger 440218 ifTrue: [ 16384 ] 440219 ifFalse: [ 16384.0 ]. 440220 p1x := (pts at: 1) x * fixedPt1. 440221 p2x := (pts at: 2) x * fixedPt1. 440222 p3x := (pts at: 3) x * fixedPt1. 440223 p4x := (pts at: 4) x * fixedPt1. 440224 p1y := (pts at: 1) y * fixedPt1. 440225 p2y := (pts at: 2) y * fixedPt1. 440226 p3y := (pts at: 3) y * fixedPt1. 440227 p4y := (pts at: 4) y * fixedPt1. 440228 p1z := p2z := p3z := p4z := 16384 "z-warp ignored for now"! ! 440229 440230!WarpBlt methodsFor: 'primitives'! 440231startFrom: x1 to: x2 offset: sumOfDeltas 440232 "Utility routine for computing Warp increments." 440233 x2 >= x1 440234 ifTrue: [^ x1] 440235 ifFalse: [^ x2 - sumOfDeltas]! ! 440236 440237!WarpBlt methodsFor: 'primitives' stamp: 'nk 11/3/2004 09:26'! 440238warpBits 440239 "Move those pixels!!" 440240 440241 cellSize < 1 ifTrue: [ ^self error: 'cellSize must be >= 1' ]. 440242 440243 self warpBitsSmoothing: cellSize 440244 sourceMap: (sourceForm colormapIfNeededForDepth: 32). 440245! ! 440246 440247!WarpBlt methodsFor: 'primitives' stamp: 'lr 7/4/2009 10:42'! 440248warpBitsSmoothing: n sourceMap: sourceMap 440249 | deltaP12 deltaP43 pA pB deltaPAB sp fixedPtOne picker poker pix nSteps | 440250 <primitive: 'primitiveWarpBits' module: 'BitBltPlugin'> 440251 (sourceForm isForm and: 440252 [ "Check for compressed source, destination or halftone forms" 440253 sourceForm unhibernate ]) ifTrue: 440254 [ ^ self 440255 warpBitsSmoothing: n 440256 sourceMap: sourceMap ]. 440257 (destForm isForm and: [ destForm unhibernate ]) ifTrue: 440258 [ ^ self 440259 warpBitsSmoothing: n 440260 sourceMap: sourceMap ]. 440261 (halftoneForm isForm and: [ halftoneForm unhibernate ]) ifTrue: 440262 [ ^ self 440263 warpBitsSmoothing: n 440264 sourceMap: sourceMap ]. 440265 width < 1 | (height < 1) ifTrue: [ ^ self ]. 440266 fixedPtOne := 16384. "1.0 in fixed-pt representation" 440267 n > 1 ifTrue: 440268 [ (destForm depth < 16 and: [ colorMap == nil ]) ifTrue: 440269 [ "color map is required to smooth non-RGB dest" 440270 ^ self primitiveFailed ]. 440271 pix := Array new: n * n ]. 440272 nSteps := height - 1 max: 1. 440273 deltaP12 := (self 440274 deltaFrom: p1x 440275 to: p2x 440276 nSteps: nSteps) @ (self 440277 deltaFrom: p1y 440278 to: p2y 440279 nSteps: nSteps). 440280 pA := (self 440281 startFrom: p1x 440282 to: p2x 440283 offset: nSteps * deltaP12 x) @ (self 440284 startFrom: p1y 440285 to: p2y 440286 offset: nSteps * deltaP12 y). 440287 deltaP43 := (self 440288 deltaFrom: p4x 440289 to: p3x 440290 nSteps: nSteps) @ (self 440291 deltaFrom: p4y 440292 to: p3y 440293 nSteps: nSteps). 440294 pB := (self 440295 startFrom: p4x 440296 to: p3x 440297 offset: nSteps * deltaP43 x) @ (self 440298 startFrom: p4y 440299 to: p3y 440300 offset: nSteps * deltaP43 y). 440301 picker := BitBlt current bitPeekerFromForm: sourceForm. 440302 poker := BitBlt current bitPokerToForm: destForm. 440303 poker clipRect: self clipRect. 440304 nSteps := width - 1 max: 1. 440305 destY 440306 to: destY + height - 1 440307 do: 440308 [ :y | 440309 deltaPAB := (self 440310 deltaFrom: pA x 440311 to: pB x 440312 nSteps: nSteps) @ (self 440313 deltaFrom: pA y 440314 to: pB y 440315 nSteps: nSteps). 440316 sp := (self 440317 startFrom: pA x 440318 to: pB x 440319 offset: nSteps * deltaPAB x) @ (self 440320 startFrom: pA y 440321 to: pB y 440322 offset: nSteps * deltaPAB x). 440323 destX 440324 to: destX + width - 1 440325 do: 440326 [ :x | 440327 n = 1 440328 ifTrue: 440329 [ poker 440330 pixelAt: x @ y 440331 put: (picker pixelAt: sp // fixedPtOne asPoint) ] 440332 ifFalse: 440333 [ 0 440334 to: n - 1 440335 do: 440336 [ :dx | 440337 0 440338 to: n - 1 440339 do: 440340 [ :dy | 440341 pix 440342 at: dx * n + dy + 1 440343 put: (picker pixelAt: (sp + (deltaPAB * dx // n) + (deltaP12 * dy // n)) // fixedPtOne asPoint) ] ]. 440344 poker 440345 pixelAt: x @ y 440346 put: (self 440347 mixPix: pix 440348 sourceMap: sourceMap 440349 destMap: colorMap) ]. 440350 sp := sp + deltaPAB ]. 440351 pA := pA + deltaP12. 440352 pB := pB + deltaP43 ]! ! 440353 440354 440355!WarpBlt methodsFor: 'setup'! 440356cellSize 440357 ^ cellSize! ! 440358 440359!WarpBlt methodsFor: 'setup' stamp: 'lr 7/4/2009 10:42'! 440360cellSize: s 440361 cellSize := s. 440362 cellSize = 1 ifTrue: [ ^ self ]. 440363 colorMap := Color 440364 colorMapIfNeededFrom: 32 440365 to: destForm depth! ! 440366 440367 440368!WarpBlt methodsFor: 'smoothing' stamp: 'lr 7/4/2009 10:42'! 440369mixPix: pix sourceMap: sourceMap destMap: destMap 440370 "Average the pixels in array pix to produce a destination pixel. 440371 First average the RGB values either from the pixels directly, 440372 or as supplied in the sourceMap. Then return either the resulting 440373 RGB value directly, or use it to index the destination color map." 440374 | r g b rgb nPix bitsPerColor d | 440375 nPix := pix size. 440376 r := 0. 440377 g := 0. 440378 b := 0. 440379 1 440380 to: nPix 440381 do: 440382 [ :i | 440383 "Sum R, G, B values for each pixel" 440384 rgb := sourceForm depth <= 8 440385 ifTrue: [ sourceMap at: (pix at: i) + 1 ] 440386 ifFalse: 440387 [ sourceForm depth = 32 440388 ifTrue: [ pix at: i ] 440389 ifFalse: 440390 [ self 440391 rgbMap: (pix at: i) 440392 from: 5 440393 to: 8 ] ]. 440394 r := r + ((rgb bitShift: -16) bitAnd: 255). 440395 g := g + ((rgb bitShift: -8) bitAnd: 255). 440396 b := b + ((rgb bitShift: 0) bitAnd: 255) ]. 440397 destMap == nil 440398 ifTrue: 440399 [ bitsPerColor := 3. "just in case eg depth <= 8 and no map" 440400 destForm depth = 16 ifTrue: [ bitsPerColor := 5 ]. 440401 destForm depth = 32 ifTrue: [ bitsPerColor := 8 ] ] 440402 ifFalse: 440403 [ destMap size = 512 ifTrue: [ bitsPerColor := 3 ]. 440404 destMap size = 4096 ifTrue: [ bitsPerColor := 4 ]. 440405 destMap size = 32768 ifTrue: [ bitsPerColor := 5 ] ]. 440406 d := bitsPerColor - 8. 440407 rgb := ((r // nPix bitShift: d) bitShift: bitsPerColor * 2) + ((g // nPix bitShift: d) bitShift: bitsPerColor) + ((b // nPix bitShift: d) bitShift: 0). 440408 destMap == nil 440409 ifTrue: [ ^ rgb ] 440410 ifFalse: [ ^ destMap at: rgb + 1 ]! ! 440411 440412!WarpBlt methodsFor: 'smoothing' stamp: 'lr 7/4/2009 10:42'! 440413rgbMap: sourcePixel from: nBitsIn to: nBitsOut 440414 "NOTE: This code is copied verbatim from BitBltSimulation so that it 440415 may be removed from the system" 440416 "Convert the given pixel value with nBitsIn bits for each color component to a pixel value with nBitsOut bits for each color component. Typical values for nBitsIn/nBitsOut are 3, 5, or 8." 440417 | mask d srcPix destPix | 440418 self inline: true. 440419 (d := nBitsOut - nBitsIn) > 0 440420 ifTrue: 440421 [ "Expand to more bits by zero-fill" 440422 mask := (1 << nBitsIn) - 1. "Transfer mask" 440423 srcPix := sourcePixel << d. 440424 mask := mask << d. 440425 destPix := srcPix bitAnd: mask. 440426 mask := mask << nBitsOut. 440427 srcPix := srcPix << d. 440428 ^ destPix + (srcPix bitAnd: mask) + (srcPix << d bitAnd: mask << nBitsOut) ] 440429 ifFalse: 440430 [ "Compress to fewer bits by truncation" 440431 d = 0 ifTrue: [ ^ sourcePixel ]. "no compression" 440432 sourcePixel = 0 ifTrue: [ ^ sourcePixel ]. "always map 0 (transparent) to 0" 440433 d := nBitsIn - nBitsOut. 440434 mask := (1 << nBitsOut) - 1. "Transfer mask" 440435 srcPix := sourcePixel >> d. 440436 destPix := srcPix bitAnd: mask. 440437 mask := mask << nBitsOut. 440438 srcPix := srcPix >> d. 440439 destPix := destPix + (srcPix bitAnd: mask) + (srcPix >> d bitAnd: mask << nBitsOut). 440440 destPix = 0 ifTrue: [ ^ 1 ]. "Dont fall into transparent by truncation" 440441 ^ destPix ]! ! 440442 440443"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 440444 440445WarpBlt class 440446 instanceVariableNames: ''! 440447 440448!WarpBlt class methodsFor: 'examples' stamp: 'alain.plantec 2/8/2009 22:52'! 440449test1 440450 "Display restoreAfter: [WarpBlt test1]" 440451 "Demonstrates variable scale and rotate" 440452 | warp pts r1 p0 p ext | 440453 UIManager default 440454 informUser: 'Choose a rectangle with interesting stuff' translated 440455 during: 440456 [ r1 := Rectangle originFromUser: 50 @ 50. 440457 Sensor waitNoButton ]. 440458 UIManager default 440459 informUser: 'Now click down and up 440460and move the mouse around the dot' translated 440461 during: 440462 [ p0 := Sensor waitClickButton. 440463 (Form dotOfSize: 8) displayAt: p0 ]. 440464 warp := (self toForm: Display) 440465 clipRect: (0 @ 0 extent: r1 extent * 5); 440466 sourceForm: Display; 440467 combinationRule: Form over. 440468 [ Sensor anyButtonPressed ] whileFalse: 440469 [ p := Sensor cursorPoint. 440470 pts := { 440471 (r1 topLeft). 440472 (r1 bottomLeft). 440473 (r1 bottomRight). 440474 (r1 topRight) 440475 } collect: 440476 [ :pt | 440477 pt 440478 rotateBy: (p - p0) theta 440479 about: r1 center ]. 440480 ext := (r1 extent * ((p - p0) r / 20.0 max: 0.1)) asIntegerPoint. 440481 warp 440482 copyQuad: pts 440483 toRect: ((r1 extent * 5 - ext) // 2 extent: ext) ]! ! 440484 440485!WarpBlt class methodsFor: 'examples' stamp: 'alain.plantec 2/8/2009 22:53'! 440486test12 440487 "Display restoreAfter: [WarpBlt test12]" 440488 "Just like test1, but comparing smooth to non-smooth warps" 440489 | warp pts r1 p0 p ext warp2 | 440490 UIManager default 440491 informUser: 'Choose a rectangle with interesting stuff' translated 440492 during: 440493 [ r1 := Rectangle originFromUser: 50 @ 50. 440494 Sensor waitNoButton ]. 440495 UIManager default 440496 informUser: 'Now click down and up 440497and move the mouse around the dot' translated 440498 during: 440499 [ p0 := Sensor waitClickButton. 440500 (Form dotOfSize: 8) displayAt: p0 ]. 440501 warp := (self toForm: Display) 440502 cellSize: 2; 440503 clipRect: (0 @ 0 extent: r1 extent * 5); 440504 sourceForm: Display; 440505 combinationRule: Form over. "installs a colormap" 440506 warp2 := (self toForm: Display) 440507 clipRect: ((0 @ 0 extent: r1 extent * 5) translateBy: 250 @ 0); 440508 sourceForm: Display; 440509 combinationRule: Form over. 440510 [ Sensor anyButtonPressed ] whileFalse: 440511 [ p := Sensor cursorPoint. 440512 pts := { 440513 (r1 topLeft). 440514 (r1 bottomLeft). 440515 (r1 bottomRight). 440516 (r1 topRight) 440517 } collect: 440518 [ :pt | 440519 pt 440520 rotateBy: (p - p0) theta 440521 about: r1 center ]. 440522 ext := (r1 extent * ((p - p0) r / 20.0 max: 0.1)) asIntegerPoint. 440523 warp 440524 copyQuad: pts 440525 toRect: ((r1 extent * 5 - ext) // 2 extent: ext). 440526 warp2 440527 copyQuad: pts 440528 toRect: (((r1 extent * 5 - ext) // 2 extent: ext) translateBy: 250 @ 0) ]! ! 440529 440530!WarpBlt class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 440531test3 440532 "Display restoreAfter: [WarpBlt test3]" 440533 "The Squeak Release Mandala - 9/23/96 di" 440534 "Move the mouse near the center of the square. 440535 Up and down affects shrink/grow 440536 Left and right affect rotation angle" 440537 | warp pts p0 p box map d t | 440538 box := 100 @ 100 extent: 300 @ 300. 440539 Display 440540 border: (box expandBy: 2) 440541 width: 2. 440542 440543 "Make a color map that steps through the color space" 440544 map := (Display depth > 8 440545 ifTrue: 440546 [ "RGB is a bit messy..." 440547 d := Display depth = 16 440548 ifTrue: [ 5 ] 440549 ifFalse: [ 8 ]. 440550 (1 to: 512) collect: 440551 [ :i | 440552 t := i bitAnd: 511. 440553 ((t bitAnd: 7) bitShift: d - 3) + ((t bitAnd: 56) bitShift: (d - 3) * 2) + ((t bitAnd: 448) bitShift: (d - 3) * 3) ] ] 440554 ifFalse: 440555 [ "otherwise simple" 440556 1 to: (1 bitShift: Display depth) ]) as: Bitmap. 440557 warp := (WarpBlt toForm: Display) 440558 clipRect: box; 440559 sourceForm: Display; 440560 colorMap: map; 440561 combinationRule: Form over. 440562 p0 := box center. 440563 [ Sensor anyButtonPressed ] whileFalse: 440564 [ p := Sensor cursorPoint. 440565 pts := (box insetBy: p y - p0 y) innerCorners collect: 440566 [ :pt | 440567 pt 440568 rotateBy: (p x - p0 x) / 50.0 440569 about: p0 ]. 440570 warp 440571 copyQuad: pts 440572 toRect: box ]! ! 440573 440574!WarpBlt class methodsFor: 'examples' stamp: 'lr 7/4/2009 10:42'! 440575test4 440576 "Display restoreAfter: [WarpBlt test4]" 440577 "The Squeak Release Mandala - 9/23/96 di 440578 This version does smoothing" 440579 "Move the mouse near the center ofhe square. 440580 Up and dn affects shrink/grow 440581 Left and right affect rotation angle" 440582 | warp pts p0 p box | 440583 box := 100 @ 100 extent: 300 @ 300. 440584 Display 440585 border: (box expandBy: 2) 440586 width: 2. 440587 warp := (WarpBlt toForm: Display) 440588 clipRect: box; 440589 sourceForm: Display; 440590 cellSize: 2; 440591 combinationRule: Form over. "installs a colormap" 440592 p0 := box center. 440593 [ Sensor anyButtonPressed ] whileFalse: 440594 [ p := Sensor cursorPoint. 440595 pts := (box insetBy: p y - p0 y) innerCorners collect: 440596 [ :pt | 440597 pt 440598 rotateBy: (p x - p0 x) / 50.0 440599 about: p0 ]. 440600 warp 440601 copyQuad: pts 440602 toRect: box ]! ! 440603 440604!WarpBlt class methodsFor: 'examples' stamp: 'alain.plantec 2/8/2009 22:53'! 440605test5 440606 "Display restoreAfter: [WarpBlt test5]" 440607 "Demonstrates variable scale and rotate" 440608 | warp pts r1 p0 p | 440609 UIManager default 440610 informUser: 'Choose a rectangle with interesting stuff' translated 440611 during: 440612 [ r1 := Rectangle fromUser. 440613 Sensor waitNoButton ]. 440614 UIManager default 440615 informUser: 'Now click down and up 440616and move the mouse around the dot' translated 440617 during: 440618 [ p0 := Sensor waitClickButton. 440619 (Form dotOfSize: 8) displayAt: p0 ]. 440620 warp := (self toForm: Display) 440621 cellSize: 1; 440622 sourceForm: Display; 440623 cellSize: 2; 440624 combinationRule: Form over. "installs a colormap" 440625 [ Sensor anyButtonPressed ] whileFalse: 440626 [ p := Sensor cursorPoint. 440627 pts := { 440628 (r1 topLeft). 440629 (r1 bottomLeft). 440630 (r1 bottomRight). 440631 (r1 topRight) 440632 } collect: 440633 [ :pt | 440634 pt 440635 rotateBy: (p - p0) theta 440636 about: r1 center ]. 440637 warp 440638 copyQuad: pts 440639 toRect: (r1 translateBy: r1 width @ 0) ]! ! 440640 440641 440642!WarpBlt class methodsFor: 'form rotation' stamp: 'lr 7/4/2009 10:42'! 440643rotate: srcForm degrees: angleInDegrees center: aPoint scaleBy: scalePoint smoothing: cellSize 440644 "Rotate the given Form the given number of degrees about the given center and scale its width and height by x and y of the given scale point. Smooth using the given cell size, an integer between 1 and 3, where 1 means no smoothing. Return a pair where the first element is the rotated Form and the second is the position offset required to align the center of the rotated Form with that of the original. Note that the dimensions of the resulting Form generally differ from those of the original." 440645 | srcRect center radians dstOrigin dstCorner p dstRect inverseScale quad dstForm newCenter warpSrc | 440646 srcRect := srcForm boundingBox. 440647 center := srcRect center. 440648 radians := angleInDegrees degreesToRadians. 440649 dstOrigin := dstCorner := center. 440650 srcRect corners do: 440651 [ :corner | 440652 "find the limits of a rectangle that just encloses the rotated 440653 original; in general, this rectangle will be larger than the 440654 original (e.g., consider a square rotated by 45 degrees)" 440655 p := (corner - center scaleBy: scalePoint) + center. 440656 p := (p 440657 rotateBy: radians 440658 about: center) rounded. 440659 dstOrigin := dstOrigin min: p. 440660 dstCorner := dstCorner max: p ]. 440661 440662 "rotate the enclosing rectangle back to get the source quadrilateral" 440663 dstRect := dstOrigin corner: dstCorner. 440664 inverseScale := (1.0 / scalePoint x) @ (1.0 / scalePoint y). 440665 quad := dstRect innerCorners collect: 440666 [ :corner | 440667 p := corner 440668 rotateBy: radians negated 440669 about: center. 440670 (p - center scaleBy: inverseScale) + center ]. 440671 440672 "make a Form to hold the result and do the rotation" 440673 warpSrc := srcForm. 440674 srcForm isColorForm 440675 ifTrue: 440676 [ cellSize > 1 | true 440677 ifTrue: 440678 [ "ar 12/27/2001: Always enable - else sketches won't work" 440679 warpSrc := Form 440680 extent: srcForm extent 440681 depth: 16. 440682 srcForm displayOn: warpSrc. 440683 dstForm := Form 440684 extent: dstRect extent 440685 depth: 16 "use 16-bit depth to allow smoothing" ] 440686 ifFalse: 440687 [ dstForm := srcForm class 440688 extent: dstRect extent 440689 depth: srcForm depth ] ] 440690 ifFalse: 440691 [ dstForm := srcForm class 440692 extent: dstRect extent 440693 depth: srcForm depth ]. 440694 (WarpBlt toForm: dstForm) 440695 sourceForm: warpSrc; 440696 colorMap: (warpSrc colormapIfNeededFor: dstForm); 440697 cellSize: cellSize; 440698 combinationRule: Form paint; 440699 copyQuad: quad 440700 toRect: dstForm boundingBox. "installs a new colormap if cellSize > 1" 440701 dstForm isColorForm ifTrue: [ dstForm colors: srcForm colors copy ]. 440702 newCenter := (center 440703 rotateBy: radians 440704 about: aPoint) truncated. 440705 ^ Array 440706 with: dstForm 440707 with: dstRect origin + (newCenter - center)! ! 440708 440709 440710!WarpBlt class methodsFor: 'initialization'! 440711toForm: destinationForm 440712 "Default cell size is 1 (no pixel smoothing)" 440713 ^ (super toForm: destinationForm) cellSize: 1! ! 440714 440715 440716!WarpBlt class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:00'! 440717current 440718 "Return the class currently to be used for WarpBlt" 440719 ^Display defaultWarpBltClass! ! 440720ThemeIcons subclass: #WateryThemeIcons 440721 instanceVariableNames: '' 440722 classVariableNames: '' 440723 poolDictionaries: '' 440724 category: 'Polymorph-Widgets-Themes'! 440725!WateryThemeIcons commentStamp: 'gvc 9/23/2008 12:07' prior: 0! 440726Watery theme specific icons.! 440727 440728 440729"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 440730 440731WateryThemeIcons class 440732 instanceVariableNames: ''! 440733 440734!WateryThemeIcons class methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2007 11:43'! 440735normalSizeNames 440736 "Answer the names of the normal icons" 440737 440738 ^#('error' 'info' 'lock' 'question' 'warning')! ! 440739 440740!WateryThemeIcons class methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2007 11:38'! 440741smallSizeNames 440742 "Answer the names of the small icons" 440743 440744 ^#('smallError' 'smallInfo' 'smallLock' 'smallQuestion' 'smallWarning')! ! 440745Array variableSubclass: #WeakActionSequence 440746 instanceVariableNames: '' 440747 classVariableNames: '' 440748 poolDictionaries: '' 440749 category: 'Kernel-Objects'! 440750 440751!WeakActionSequence methodsFor: 'converting' stamp: 'rw 4/27/2002 07:44'! 440752asActionSequence 440753 440754 ^self! ! 440755 440756!WeakActionSequence methodsFor: 'converting' stamp: 'rw 7/20/2003 16:03'! 440757asActionSequenceTrappingErrors 440758 440759 ^WeakActionSequenceTrappingErrors withAll: self! ! 440760 440761!WeakActionSequence methodsFor: 'converting' stamp: 'nk 7/21/2003 15:16'! 440762asMinimalRepresentation 440763 440764 | valid | 440765 valid := self select: [:e | e isValid ]. 440766 valid size = 0 440767 ifTrue: [^nil]. 440768 valid size = 1 440769 ifTrue: [^valid first]. 440770 ^valid! ! 440771 440772 440773!WeakActionSequence methodsFor: 'evaluating' stamp: 'nk 7/21/2003 15:17'! 440774value 440775 "Answer the result of evaluating the elements of the receiver. 440776 Actually, return just the last result." 440777 440778 | answer | 440779 self do: 440780 [:each | each isValid ifTrue: [answer := each value]]. 440781 ^answer! ! 440782 440783!WeakActionSequence methodsFor: 'evaluating' stamp: 'nk 7/21/2003 15:17'! 440784valueWithArguments: anArray 440785 440786 "Return the last result" 440787 440788 | answer | 440789 self do: 440790 [:each | 440791 each isValid ifTrue: [answer := each valueWithArguments: anArray]]. 440792 ^answer! ! 440793 440794 440795!WeakActionSequence methodsFor: 'printing' stamp: 'rw 4/27/2002 07:46'! 440796printOn: aStream 440797 440798 self size < 2 ifTrue: [^super printOn: aStream]. 440799 aStream nextPutAll: '#('. 440800 self 440801 do: [:each | each printOn: aStream] 440802 separatedBy: [aStream cr]. 440803 aStream nextPut: $)! ! 440804 440805"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 440806 440807WeakActionSequence class 440808 instanceVariableNames: ''! 440809WeakActionSequence variableSubclass: #WeakActionSequenceTrappingErrors 440810 instanceVariableNames: '' 440811 classVariableNames: '' 440812 poolDictionaries: '' 440813 category: 'System-Change Notification'! 440814 440815!WeakActionSequenceTrappingErrors methodsFor: 'converting' stamp: 'rw 7/20/2003 16:03'! 440816asActionSequenceTrappingErrors 440817 440818 ^self! ! 440819 440820 440821!WeakActionSequenceTrappingErrors methodsFor: 'evaluating' stamp: 'rw 8/6/2003 12:09'! 440822value 440823 "Do the same as my parent, but make sure that all actions that do not 440824 give errors are evaluated before resignaling the ones that gave errors 440825 (giving the chance to clients to handle them)." 440826 440827 ^self valueStartingFrom: 1! ! 440828 440829!WeakActionSequenceTrappingErrors methodsFor: 'evaluating' stamp: 'nk 9/6/2004 08:22'! 440830valueStartingFrom: startIndex 440831 "Do the same as my parent, but make sure that all actions that do not 440832 give errors are evaluated before resignaling the ones that gave errors 440833 (giving the chance to clients to handle them)." 440834 440835 "Note: I currently trap Halt,Error so that I am sure to get a Halt event in case of a Halt. This is being fixed in the exception system - when the fix is done it will be enough to capture only Error." 440836 440837 | each answer | 440838 startIndex to: self size do: [:index | 440839 each := self at: index. 440840 each isReceiverOrAnyArgumentGarbage ifFalse: [ 440841 [answer := each value] 440842 on: Halt, Error 440843 do: [:exc | 440844 self valueStartingFrom: index + 1. 440845 exc pass]]]. 440846 ^ answer! ! 440847 440848!WeakActionSequenceTrappingErrors methodsFor: 'evaluating' stamp: 'rw 8/6/2003 12:07'! 440849valueWithArguments: anArray 440850 "Do the same as my parent, but make sure that all actions that do not 440851 give errors are evaluated before resignaling the ones that gave errors 440852 (giving the chance to clients to handle them)." 440853 440854 ^self valueWithArguments: anArray startingFrom: 1! ! 440855 440856!WeakActionSequenceTrappingErrors methodsFor: 'evaluating' stamp: 'nk 9/6/2004 08:22'! 440857valueWithArguments: anArray startingFrom: startIndex 440858 "Do the same as my parent, but make sure that all actions that do not 440859 give errors are evaluated before resignaling the ones that gave errors 440860 (giving the chance to clients to handle them)." 440861 440862 "Note: I currently trap Halt,Error so that I am sure to get a Halt event in case of a Halt. This is being fixed in the exception system - when the fix is done it will be enough to capture only Error." 440863 440864 | each answer | 440865 startIndex to: self size do: [:index | 440866 each := self at: index. 440867 each isReceiverOrAnyArgumentGarbage ifFalse: [ 440868 [answer := each valueWithArguments: anArray] 440869 on: Halt, Error 440870 do: [:exc | 440871 self valueWithArguments: anArray startingFrom: index + 1. 440872 exc pass]]]. 440873 ^ answer! ! 440874Array weakSubclass: #WeakArray 440875 instanceVariableNames: '' 440876 classVariableNames: 'FinalizationDependents FinalizationLock FinalizationProcess FinalizationSemaphore IsFinalizationSupported' 440877 poolDictionaries: '' 440878 category: 'Collections-Weak'! 440879!WeakArray commentStamp: '<historical>' prior: 0! 440880WeakArray is an array which holds only weakly on its elements. This means whenever an object is only referenced by instances of WeakArray it will be garbage collected.! 440881 440882 440883"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 440884 440885WeakArray class 440886 instanceVariableNames: ''! 440887 440888!WeakArray class methodsFor: 'accessing' stamp: 'marcus.denker 9/14/2008 21:04'! 440889addWeakDependent: anObject 440890 | finished index weakDependent | 440891 self isFinalizationSupported ifFalse:[^self]. 440892 FinalizationLock critical:[ 440893 finished := false. 440894 index := 0. 440895 [index := index + 1. 440896 finished not and:[index <= FinalizationDependents size]] whileTrue:[ 440897 weakDependent := FinalizationDependents at: index. 440898 weakDependent ifNil: [ 440899 FinalizationDependents at: index put: anObject. 440900 finished := true. 440901 ]. 440902 ]. 440903 finished ifFalse:[ 440904 "Grow linearly" 440905 FinalizationDependents := FinalizationDependents, (WeakArray new: 10). 440906 FinalizationDependents at: index put: anObject. 440907 ]. 440908 ] ifError:[:msg :rcvr| rcvr error: msg].! ! 440909 440910!WeakArray class methodsFor: 'accessing' stamp: 'stephane.ducasse 5/17/2009 23:26'! 440911isFinalizationSupported 440912 440913 ^IsFinalizationSupported := true! ! 440914 440915!WeakArray class methodsFor: 'accessing' stamp: 'ar 10/8/1998 11:17'! 440916removeWeakDependent: anObject 440917 self isFinalizationSupported ifFalse:[^self]. 440918 FinalizationLock critical:[ 440919 1 to: FinalizationDependents size do:[:i| 440920 ((FinalizationDependents at: i) == anObject) ifTrue:[ 440921 FinalizationDependents at: i put: nil. 440922 ]. 440923 ]. 440924 ] ifError:[:msg :rcvr| rcvr error: msg].! ! 440925 440926!WeakArray class methodsFor: 'accessing' stamp: 'nk 10/28/2000 20:26'! 440927runningFinalizationProcess 440928 "Answer the FinalizationProcess I am running, if any" 440929 ^FinalizationProcess! ! 440930 440931 440932!WeakArray class methodsFor: 'initialization' stamp: 'nk 6/21/2004 10:22'! 440933initialize 440934 "WeakArray initialize" 440935 440936 "Do we need to initialize specialObjectsArray?" 440937 Smalltalk specialObjectsArray size < 42 440938 ifTrue:[Smalltalk recreateSpecialObjectsArray]. 440939 440940 Smalltalk addToStartUpList: self. 440941 self restartFinalizationProcess.! ! 440942 440943 440944!WeakArray class methodsFor: 'nil' stamp: 'nice 4/16/2009 19:01'! 440945finalizationProcess 440946 440947 [true] whileTrue: 440948 [FinalizationSemaphore wait. 440949 FinalizationLock critical: 440950 [FinalizationDependents do: 440951 [:weakDependent | 440952 weakDependent ifNotNil: 440953 [weakDependent finalizeValues]]] 440954 ifError: 440955 [:msg :rcvr | rcvr error: msg]. 440956 ]. 440957! ! 440958 440959 440960!WeakArray class methodsFor: 'system startup' stamp: 'nk 6/21/2004 09:22'! 440961startUp: resuming 440962 resuming ifFalse: [ ^self ]. 440963 self restartFinalizationProcess.! ! 440964 440965 440966!WeakArray class methodsFor: 'private' stamp: 'ar 10/7/1998 15:24'! 440967pvtCreateTemporaryObjectIn: tempObject 440968 "We have to create the temporary object in a separate stack frame" 440969 tempObject at: 1 put: Object new! ! 440970 440971!WeakArray class methodsFor: 'private' stamp: 'nk 6/21/2004 10:22'! 440972restartFinalizationProcess 440973 "kill any old process, just in case" 440974 FinalizationProcess 440975 ifNotNil: [FinalizationProcess terminate. 440976 FinalizationProcess := nil]. 440977 440978 "Check if Finalization is supported by this VM" 440979 IsFinalizationSupported := nil. 440980 self isFinalizationSupported 440981 ifFalse: [^ self]. 440982 440983 FinalizationSemaphore := Smalltalk specialObjectsArray at: 42. 440984 FinalizationDependents ifNil: [FinalizationDependents := WeakArray new: 10]. 440985 FinalizationLock := Semaphore forMutualExclusion. 440986 FinalizationProcess := [self finalizationProcess] 440987 forkAt: Processor userInterruptPriority! ! 440988WeakKeyDictionary subclass: #WeakIdentityKeyDictionary 440989 instanceVariableNames: '' 440990 classVariableNames: '' 440991 poolDictionaries: '' 440992 category: 'Collections-Weak'! 440993!WeakIdentityKeyDictionary commentStamp: '<historical>' prior: 0! 440994This class represents an identity dictionary with weak keys.! 440995 440996 440997!WeakIdentityKeyDictionary methodsFor: 'private' stamp: 'md 10/5/2005 15:44'! 440998scanFor: anObject 440999 "ar 10/21/2000: The method has been copied to this location to indicate that whenever #scanFor: changes #scanForNil: must be changed in the receiver as well." 441000 "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 441001 | element start finish hash | 441002 finish := array size. 441003 finish > 4096 441004 ifTrue: [hash := anObject identityHash * (finish // 4096)] 441005 ifFalse: [hash := anObject identityHash]. 441006 start := (hash \\ finish) + 1. 441007 441008 "Search from (hash mod size) to the end." 441009 start to: finish do: 441010 [:index | ((element := array at: index) == nil or: [element key == anObject]) 441011 ifTrue: [^ index ]]. 441012 441013 "Search from 1 to where we started." 441014 1 to: start-1 do: 441015 [:index | ((element := array at: index) == nil or: [element key == anObject]) 441016 ifTrue: [^ index ]]. 441017 441018 ^ 0 "No match AND no empty slot"! ! 441019 441020!WeakIdentityKeyDictionary methodsFor: 'private' stamp: 'ar 7/1/2003 15:15'! 441021scanForNil: anObject 441022 "Private. Scan the key array for the first slot containing nil (indicating an empty slot). Answer the index of that slot." 441023 | start finish hash | 441024 finish := array size. 441025 finish > 4096 441026 ifTrue: [hash := anObject identityHash * (finish // 4096)] 441027 ifFalse: [hash := anObject identityHash]. 441028 start := (hash \\ array size) + 1. 441029 441030 "Search from (hash mod size) to the end." 441031 start to: finish do: 441032 [:index | (array at: index) == nil ifTrue: [^ index ]]. 441033 441034 "Search from 1 to where we started." 441035 1 to: start-1 do: 441036 [:index | (array at: index) == nil ifTrue: [^ index ]]. 441037 441038 ^ 0 "No match AND no empty slot"! ! 441039WeakKeyDictionaryTest subclass: #WeakIdentityKeyDictionaryTest 441040 instanceVariableNames: '' 441041 classVariableNames: '' 441042 poolDictionaries: '' 441043 category: 'CollectionsTests-Weak'! 441044 441045!WeakIdentityKeyDictionaryTest methodsFor: 'errors - specific behavior' stamp: 'cyrille.delaunay 7/17/2009 11:50'! 441046testAtPutNil 441047 "self run: #testAtPut" 441048 "self debug: #testAtPut" 441049 441050 | dict keyIn | 441051 dict := self nonEmpty . 441052 keyIn := dict keys anyOne. 441053 441054 "WeakIdentityKeyDictionary seems to not accept nil key :" 441055 "dict at: nil put: 'new'. 441056 self assert: (dict at: nil) = 'new'." 441057 441058 dict at: keyIn put: nil. 441059 self assert: (dict at: keyIn ) isNil. 441060 441061 dict at: self keyNotIn put: nil. 441062 self assert: ( dict at: self keyNotIn ) isNil. 441063 441064 "dict at: nil put: nil. 441065 self assert: (dict at: nil) isNil."! ! 441066 441067 441068!WeakIdentityKeyDictionaryTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 7/1/2009 16:12'! 441069classToBeTested 441070 441071^WeakIdentityKeyDictionary ! ! 441072 441073 441074!WeakIdentityKeyDictionaryTest methodsFor: 'tests' stamp: 'sd 7/21/2009 10:46'! 441075testNoNils 441076 | d | 441077 d := WeakIdentityKeyDictionary new 441078 at: 'hello' copy put: 'world'; 441079 yourself. 441080 Smalltalk garbageCollect. 441081 self deny: (d keys includes: nil)! ! 441082 441083"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 441084 441085WeakIdentityKeyDictionaryTest class 441086 instanceVariableNames: ''! 441087 441088!WeakIdentityKeyDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 7/1/2009 16:13'! 441089shouldInheritSelectors 441090 441091^true! ! 441092Association subclass: #WeakKeyAssociation 441093 instanceVariableNames: '' 441094 classVariableNames: '' 441095 poolDictionaries: '' 441096 category: 'Collections-Support'! 441097!WeakKeyAssociation commentStamp: '<historical>' prior: 0! 441098I am an association holding only weakly on my key.! 441099 441100 441101!WeakKeyAssociation methodsFor: 'accessing' stamp: 'ar 3/21/98 15:54'! 441102key 441103 ^key isNil 441104 ifTrue:[nil] 441105 ifFalse:[key at: 1]! ! 441106 441107!WeakKeyAssociation methodsFor: 'accessing' stamp: 'ar 3/21/98 15:45'! 441108key: aKey 441109 key := WeakArray with: aKey! ! 441110 441111!WeakKeyAssociation methodsFor: 'accessing' stamp: 'raok 11/29/2002 14:49'! 441112key: aKey value: anObject 441113 key := WeakArray with: aKey. 441114 value := anObject.! ! 441115 441116 441117!WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:45'! 441118< aLookupKey 441119 "Refer to the comment in Magnitude|<." 441120 441121 ^self key < aLookupKey key! ! 441122 441123!WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:46'! 441124= aLookupKey 441125 441126 self species = aLookupKey species 441127 ifTrue: [^self key = aLookupKey key] 441128 ifFalse: [^false]! ! 441129 441130!WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:46'! 441131hash 441132 "Hash is reimplemented because = is implemented." 441133 441134 ^self key hash! ! 441135 441136 441137!WeakKeyAssociation methodsFor: 'printing' stamp: 'ar 3/21/98 15:53'! 441138printOn: aStream 441139 self key printOn: aStream. 441140 aStream nextPutAll: '->'. 441141 self value printOn: aStream! ! 441142 441143!WeakKeyAssociation methodsFor: 'printing' stamp: 'ar 3/21/98 15:53'! 441144storeOn: aStream 441145 aStream 441146 nextPut: $(; 441147 nextPutAll: self class name; 441148 nextPutAll:' key: '. 441149 self key storeOn: aStream. 441150 aStream nextPutAll: ' value: '. 441151 self value storeOn: aStream. 441152 aStream nextPut: $)! ! 441153Dictionary subclass: #WeakKeyDictionary 441154 instanceVariableNames: '' 441155 classVariableNames: '' 441156 poolDictionaries: '' 441157 category: 'Collections-Weak'! 441158!WeakKeyDictionary commentStamp: '<historical>' prior: 0! 441159I am a dictionary holding only weakly on my keys. This is a bit dangerous since at any time my keys can go away. Clients are responsible to register my instances by WeakArray such that the appropriate actions can be taken upon loss of any keys. 441160 441161See WeakRegistry for an example of use. 441162! 441163 441164 441165!WeakKeyDictionary methodsFor: 'accessing' stamp: 'marcus.denker 9/14/2008 21:04'! 441166at: key put: anObject 441167 "Set the value at key to be anObject. If key is not found, create a new 441168 entry for key and set is value to anObject. Answer anObject." 441169 | index element | 441170 key ifNil: [^anObject]. 441171 index := self findElementOrNil: key. 441172 element := array at: index. 441173 element 441174 ifNil: [self atNewIndex: index put: (WeakKeyAssociation key: key value: anObject)] 441175 ifNotNil: [element value: anObject]. 441176 ^ anObject! ! 441177 441178!WeakKeyDictionary methodsFor: 'accessing' stamp: 'ar 2/11/2001 02:21'! 441179keysDo: aBlock 441180 "Evaluate aBlock for each of the receiver's keys." 441181 self associationsDo: [:association | 441182 association key ifNotNil:[aBlock value: association key]].! ! 441183 441184 441185!WeakKeyDictionary methodsFor: 'adding' stamp: 'ar 3/21/98 16:00'! 441186add: anAssociation 441187 self at: anAssociation key put: anAssociation value. 441188 ^ anAssociation! ! 441189 441190 441191!WeakKeyDictionary methodsFor: 'finalization' stamp: 'ar 10/21/2000 20:00'! 441192finalizeValues 441193 "remove all nil keys and rehash the receiver afterwards" 441194 | assoc | 441195 1 to: array size do:[:i| 441196 assoc := array at: i. 441197 (assoc notNil and:[assoc key == nil]) ifTrue:[array at: i put: nil]. 441198 ]. 441199 self rehash.! ! 441200 441201!WeakKeyDictionary methodsFor: 'finalization' stamp: 'ar 10/21/2000 20:01'! 441202finalizeValues: finiObjects 441203 "Remove all associations with key == nil and value is in finiObjects. 441204 This method is folded with #rehash for efficiency." 441205 | oldArray assoc newIndex | 441206 oldArray := array. 441207 array := Array new: oldArray size. 441208 tally := 0. 441209 1 to: array size do:[:i| 441210 assoc := oldArray at: i. 441211 assoc ifNotNil:[ 441212 (assoc key == nil and:[finiObjects includes: assoc value]) ifFalse:[ 441213 newIndex := self scanForNil: assoc key. 441214 self atNewIndex: newIndex put: assoc]. 441215 ]. 441216 ].! ! 441217 441218 441219!WeakKeyDictionary methodsFor: 'private' stamp: 'ar 10/21/2000 19:58'! 441220fixCollisionsFrom: oldIndex 441221 "The element at index has been removed and replaced by nil." 441222 self rehash. "Do it the hard way - we may have any number of nil keys and #rehash deals with them"! ! 441223 441224!WeakKeyDictionary methodsFor: 'private' stamp: 'ar 10/21/2000 19:56'! 441225rehash 441226 "Rehash the receiver. Reimplemented to allow for multiple nil keys" 441227 | oldArray assoc newIndex | 441228 oldArray := array. 441229 array := Array new: oldArray size. 441230 tally := 0. 441231 1 to: array size do:[:i| 441232 assoc := oldArray at: i. 441233 assoc ifNotNil:[ 441234 newIndex := self scanForNil: assoc key. 441235 self atNewIndex: newIndex put: assoc. 441236 ]. 441237 ].! ! 441238 441239!WeakKeyDictionary methodsFor: 'private' stamp: 'md 10/5/2005 15:44'! 441240scanFor: anObject 441241 "ar 10/21/2000: The method has been copied to this location to indicate that whenever #scanFor: changes #scanForNil: must be changed in the receiver as well." 441242 "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 441243 | element start finish | 441244 finish := array size. 441245 start := (anObject hash \\ finish) + 1. 441246 441247 "Search from (hash mod size) to the end." 441248 start to: finish do: 441249 [:index | ((element := array at: index) == nil or: [element key = anObject]) 441250 ifTrue: [^ index ]]. 441251 441252 "Search from 1 to where we started." 441253 1 to: start-1 do: 441254 [:index | ((element := array at: index) == nil or: [element key = anObject]) 441255 ifTrue: [^ index ]]. 441256 441257 ^ 0 "No match AND no empty slot"! ! 441258 441259!WeakKeyDictionary methodsFor: 'private' stamp: 'ar 10/21/2000 19:46'! 441260scanForNil: anObject 441261 "Private. Scan the key array for the first slot containing nil (indicating an empty slot). Answer the index of that slot." 441262 | start finish | 441263 start := (anObject hash \\ array size) + 1. 441264 finish := array size. 441265 441266 "Search from (hash mod size) to the end." 441267 start to: finish do: 441268 [:index | (array at: index) == nil ifTrue: [^ index ]]. 441269 441270 "Search from 1 to where we started." 441271 1 to: start-1 do: 441272 [:index | (array at: index) == nil ifTrue: [^ index ]]. 441273 441274 ^ 0 "No match AND no empty slot"! ! 441275DictionaryTest subclass: #WeakKeyDictionaryTest 441276 instanceVariableNames: '' 441277 classVariableNames: '' 441278 poolDictionaries: '' 441279 category: 'CollectionsTests-Weak'! 441280 441281!WeakKeyDictionaryTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 7/1/2009 12:15'! 441282classToBeTested 441283 441284^ SystemDictionary! ! 441285 441286"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 441287 441288WeakKeyDictionaryTest class 441289 instanceVariableNames: ''! 441290 441291!WeakKeyDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 7/1/2009 12:15'! 441292shouldInheritSelectors 441293 441294^true! ! 441295WeakIdentityKeyDictionary subclass: #WeakKeyToCollectionDictionary 441296 instanceVariableNames: '' 441297 classVariableNames: '' 441298 poolDictionaries: '' 441299 category: 'Collections-Weak'! 441300!WeakKeyToCollectionDictionary commentStamp: '<historical>' prior: 0! 441301This class represents an identity dictionary with weak keys, whose values are collections. 441302Keys not in the dictionary are mapped to the empty collection. Conversely, if a collection becomes empty, the mapping can be removed to save time and space. However, because this requires re-hashing, it does not pay to do this to eagerly.! 441303 441304 441305!WeakKeyToCollectionDictionary methodsFor: 'finalization' stamp: 'apb 7/12/2004 23:47'! 441306finalizeValues 441307 self rehash! ! 441308 441309 441310!WeakKeyToCollectionDictionary methodsFor: 'private' stamp: 'apb 7/13/2004 00:17'! 441311rehash 441312 "Rehash the receiver. Reimplemented to remove nils from the collections 441313 that appear as values, and to entirely remove associations with empty collections 441314 as values." 441315 | oldArray assoc cleanedValue newIndex | 441316 oldArray := array. 441317 array := Array new: oldArray size. 441318 tally := 0. 441319 1 to: array size do: [:i | 441320 assoc := oldArray at: i. 441321 (assoc notNil 441322 and: [(cleanedValue := assoc value copyWithout: nil) notEmpty]) 441323 ifTrue: [newIndex := self scanForNil: assoc key. 441324 assoc value: cleanedValue. 441325 self atNewIndex: newIndex put: assoc]]! ! 441326WeakIdentityKeyDictionaryTest subclass: #WeakKeyToCollectionDictionaryTest 441327 instanceVariableNames: '' 441328 classVariableNames: '' 441329 poolDictionaries: '' 441330 category: 'CollectionsTests-Weak'! 441331 441332!WeakKeyToCollectionDictionaryTest methodsFor: 'errors - those methods should be tested with collection keys' stamp: 'cyrille.delaunay 7/3/2009 13:49'! 441333testKeysAndValuesRemove 441334 " should be tested with collection keys" 441335 441336 "| oldSize collection keyIn | 441337 441338 441339 collection := self nonEmptyDict . 441340 oldSize := collection size. 441341 keyIn := collection keys anyOne. 441342 441343 collection keysAndValuesRemove: [:key :value | key == self keyNotInNonEmptyDict ]. 441344 self assert: (collection size = (oldSize )). 441345 441346 collection keysAndValuesRemove: [:key :value | key == keyIn ]. 441347 self assert: (collection size = (oldSize - 1)). 441348 self should: [ collection at: keyIn ] raise: Error."! ! 441349 441350!WeakKeyToCollectionDictionaryTest methodsFor: 'errors - those methods should be tested with collection keys' stamp: 'cyrille.delaunay 7/3/2009 13:48'! 441351testRemoveKey 441352 "self debug: #testRemoveKey" 441353 441354" | collection oldSize keyIn | 441355 collection := self nonEmptyDict . 441356 oldSize := collection size. 441357 keyIn := collection keys anyOne. 441358 441359 collection removeKey: keyIn . 441360 self assert: (collection size = (oldSize - 1)). 441361 self should: [ (collection at: keyIn )] raise: Error. 441362 441363 self should: [collection removeKey: self keyNotInNonEmptyDict ] raise: Error"! ! 441364 441365!WeakKeyToCollectionDictionaryTest methodsFor: 'errors - those methods should be tested with collection keys' stamp: 'cyrille.delaunay 7/3/2009 11:02'! 441366testRemoveKeyIfAbsent 441367 441368 "| collection oldSize keyIn value result | 441369 collection := self nonEmptyDict . 441370 oldSize := collection size. 441371 keyIn := collection keys anyOne. 441372 value := collection at: keyIn . 441373 441374 result := collection removeKey: keyIn ifAbsent: [888]. 441375 441376 self assert: result = value. 441377 self assert: (collection size = (oldSize - 1)). 441378 self should: [ (collection at: keyIn )] raise: Error. 441379 441380 self assert: (collection removeKey: self keyNotInNonEmptyDict ifAbsent: [888] ) = 888."! ! 441381 441382 441383!WeakKeyToCollectionDictionaryTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 7/3/2009 10:59'! 441384classToBeTested 441385 ^ WeakKeyToCollectionDictionary! ! 441386 441387"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 441388 441389WeakKeyToCollectionDictionaryTest class 441390 instanceVariableNames: ''! 441391 441392!WeakKeyToCollectionDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 7/3/2009 11:00'! 441393shouldInheritSelectors 441394 441395^true! ! 441396Object weakSubclass: #WeakMessageSend 441397 instanceVariableNames: 'selector shouldBeNil arguments' 441398 classVariableNames: '' 441399 poolDictionaries: '' 441400 category: 'Kernel-Objects'! 441401!WeakMessageSend commentStamp: 'tlk 5/5/2006 12:39' prior: 0! 441402Instances of WeakMessageSend encapsulate message sends to objects, like MessageSend. Unlike MessageSend it is not necessarily a valid mesage. A request to value only results in a send if infact it is valid. 441403 441404See MessageSendComments also. WeakMessageSend is used primarily for event regristration. 441405 441406Unlike MessageSend WeakMessageSend stoes receiver (object receiving the message send) as a the first and only element of its array as opposed to a named ivar. 441407But like MessageSend, it does have 441408 selector Symbol -- message selector 441409 arguments Array -- bound arguments 441410and it also has 441411 shouldBeNil Boolean -- used to ensure array of arguments is not all nils! 441412 441413 441414!WeakMessageSend methodsFor: 'accessing' stamp: 'nk 4/25/2002 09:54'! 441415arguments 441416 ^arguments ifNil: [ Array new ] 441417! ! 441418 441419!WeakMessageSend methodsFor: 'accessing' stamp: 'nk 4/25/2002 09:38'! 441420arguments: anArray 441421 arguments := WeakArray withAll: anArray. 441422 "no reason this should be a WeakArray" 441423 shouldBeNil := Array withAll: (anArray collect: [ :ea | ea isNil ]). 441424! ! 441425 441426!WeakMessageSend methodsFor: 'accessing' stamp: 'nk 4/25/2002 07:54'! 441427receiver 441428 ^self at: 1 441429! ! 441430 441431!WeakMessageSend methodsFor: 'accessing' stamp: 'nk 4/25/2002 07:54'! 441432receiver: anObject 441433 self at: 1 put: anObject 441434! ! 441435 441436!WeakMessageSend methodsFor: 'accessing' stamp: 'nk 4/25/2002 07:54'! 441437selector 441438 ^selector 441439! ! 441440 441441!WeakMessageSend methodsFor: 'accessing' stamp: 'nk 4/25/2002 07:55'! 441442selector: aSymbol 441443 selector := aSymbol 441444! ! 441445 441446 441447!WeakMessageSend methodsFor: 'comparing' stamp: 'nk 4/25/2002 08:05'! 441448= anObject 441449 "Compare equal to equivalent MessageSend" 441450 ^ anObject isMessageSend 441451 and: [self receiver == anObject receiver 441452 and: [selector == anObject selector 441453 and: [(Array withAll: arguments) = (Array withAll: anObject arguments)]]] 441454! ! 441455 441456!WeakMessageSend methodsFor: 'comparing' stamp: 'nk 4/25/2002 09:31'! 441457hash 441458 "work like MessageSend>>hash" 441459 ^self receiver hash bitXor: selector hash 441460! ! 441461 441462 441463!WeakMessageSend methodsFor: 'converting' stamp: 'nk 4/25/2002 09:33'! 441464asMessageSend 441465 ^MessageSend receiver: self receiver selector: selector arguments: (Array withAll: self arguments) 441466! ! 441467 441468!WeakMessageSend methodsFor: 'converting' stamp: 'rww 10/20/2002 19:56'! 441469asMinimalRepresentation 441470 441471 self isReceiverOrAnyArgumentGarbage 441472 ifTrue: [^nil] 441473 ifFalse:[^self].! ! 441474 441475 441476!WeakMessageSend methodsFor: 'evaluating' stamp: 'nk 12/8/2002 12:15'! 441477value 441478 ^ arguments isNil 441479 ifTrue: [self ensureReceiver 441480 ifTrue: [self receiver perform: selector] ifFalse: []] 441481 ifFalse: [self ensureReceiverAndArguments 441482 ifTrue: [self receiver 441483 perform: selector 441484 withArguments: (Array withAll: arguments)] ifFalse: []]! ! 441485 441486!WeakMessageSend methodsFor: 'evaluating' stamp: 'nk 12/8/2002 12:15'! 441487valueWithArguments: anArray 441488 self ensureReceiverAndArguments ifFalse: [ ^nil ]. 441489 ^ self receiver 441490 perform: selector 441491 withArguments: (self collectArguments: anArray)! ! 441492 441493!WeakMessageSend methodsFor: 'evaluating' stamp: 'nk 12/8/2002 12:15'! 441494valueWithEnoughArguments: anArray 441495 "call the selector with enough arguments from arguments and anArray" 441496 | args | 441497 self ensureReceiverAndArguments ifFalse: [ ^nil ]. 441498 args := Array new: selector numArgs. 441499 args replaceFrom: 1 441500 to: ( arguments size min: args size) 441501 with: arguments 441502 startingAt: 1. 441503 args size > arguments size ifTrue: [ 441504 args replaceFrom: arguments size + 1 441505 to: (arguments size + anArray size min: args size) 441506 with: anArray 441507 startingAt: 1. 441508 ]. 441509 ^ self receiver perform: selector withArguments: args 441510! ! 441511 441512 441513!WeakMessageSend methodsFor: 'printing' stamp: 'nk 4/25/2002 09:36'! 441514printOn: aStream 441515 441516 aStream 441517 nextPutAll: self class name; 441518 nextPut: $(. 441519 selector printOn: aStream. 441520 aStream nextPutAll: ' -> '. 441521 self receiver printOn: aStream. 441522 aStream nextPut: $) 441523! ! 441524 441525 441526!WeakMessageSend methodsFor: 'testing' stamp: 'nk 4/25/2002 08:04'! 441527isMessageSend 441528 ^true 441529! ! 441530 441531!WeakMessageSend methodsFor: 'testing' stamp: 'nk 8/24/2003 01:12'! 441532isValid 441533 ^self isReceiverOrAnyArgumentGarbage not 441534! ! 441535 441536 441537!WeakMessageSend methodsFor: 'private' stamp: 'nk 4/25/2002 09:49'! 441538collectArguments: anArgArray 441539 "Private" 441540 | staticArgs | 441541 staticArgs := self arguments. 441542 ^(anArgArray size = staticArgs size) 441543 ifTrue: [anArgArray] 441544 ifFalse: 441545 [(staticArgs isEmpty 441546 ifTrue: [ staticArgs := Array new: selector numArgs] 441547 ifFalse: [staticArgs copy] ) 441548 replaceFrom: 1 441549 to: (anArgArray size min: staticArgs size) 441550 with: anArgArray 441551 startingAt: 1] 441552! ! 441553 441554!WeakMessageSend methodsFor: 'private' stamp: 'nk 12/8/2002 12:13'! 441555ensureArguments 441556 "Return true if my arguments haven't gone away" 441557 arguments ifNotNil: [ 441558 arguments with: shouldBeNil do: [ :arg :flag | 441559 arg ifNil: [ flag ifFalse: [ ^false ]] 441560 ] 441561 ]. 441562 ^true 441563! ! 441564 441565!WeakMessageSend methodsFor: 'private' stamp: 'nk 12/8/2002 12:13'! 441566ensureReceiver 441567 "Return true if my receiver hasn't gone away" 441568 ^self receiver notNil 441569! ! 441570 441571!WeakMessageSend methodsFor: 'private' stamp: 'nk 12/8/2002 12:13'! 441572ensureReceiverAndArguments 441573 441574 "Return true if my receiver hasn't gone away" 441575 self receiver ifNil: [ ^false ]. 441576 441577 "Make sure that my arguments haven't gone away" 441578 arguments ifNotNil: [ 441579 arguments with: shouldBeNil do: [ :arg :flag | 441580 arg ifNil: [ flag ifFalse: [ ^false ]] 441581 ] 441582 ]. 441583 441584 ^true 441585! ! 441586 441587!WeakMessageSend methodsFor: 'private' stamp: 'rw 4/27/2002 07:33'! 441588isAnyArgumentGarbage 441589 "Make sure that my arguments haven't gone away" 441590 arguments ifNotNil: [ 441591 arguments with: shouldBeNil do: [ :arg :flag | 441592 (flag not and: [arg isNil]) 441593 ifTrue: [^true] 441594 ] 441595 ]. 441596 ^false 441597! ! 441598 441599!WeakMessageSend methodsFor: 'private' stamp: 'rw 4/27/2002 07:31'! 441600isReceiverGarbage 441601 "Make sure that my receiver hasn't gone away" 441602 ^self receiver isNil 441603! ! 441604 441605!WeakMessageSend methodsFor: 'private' stamp: 'rw 4/27/2002 07:34'! 441606isReceiverOrAnyArgumentGarbage 441607 "Make sure that my receiver hasn't gone away" 441608 ^self isReceiverGarbage 441609 or: [self isAnyArgumentGarbage] 441610! ! 441611 441612"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 441613 441614WeakMessageSend class 441615 instanceVariableNames: ''! 441616 441617!WeakMessageSend class methodsFor: 'instance creation' stamp: 'nk 4/25/2002 10:00'! 441618new 441619 ^self new: 1 441620! ! 441621 441622!WeakMessageSend class methodsFor: 'instance creation' stamp: 'nk 4/25/2002 09:37'! 441623receiver: anObject selector: aSymbol 441624 ^ self receiver: anObject selector: aSymbol arguments: #() 441625! ! 441626 441627!WeakMessageSend class methodsFor: 'instance creation' stamp: 'nk 4/25/2002 09:37'! 441628receiver: anObject selector: aSymbol argument: aParameter 441629 ^ self receiver: anObject selector: aSymbol arguments: (Array with: aParameter) 441630! ! 441631 441632!WeakMessageSend class methodsFor: 'instance creation' stamp: 'nk 4/25/2002 09:37'! 441633receiver: anObject selector: aSymbol arguments: anArray 441634 ^ self new 441635 receiver: anObject; 441636 selector: aSymbol; 441637 arguments: anArray 441638! ! 441639ClassTestCase subclass: #WeakMessageSendTest 441640 instanceVariableNames: '' 441641 classVariableNames: '' 441642 poolDictionaries: '' 441643 category: 'KernelTests-Objects'! 441644 441645!WeakMessageSendTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:10'! 441646testNoArguments 441647 "self run: #testNoArguments" 441648 441649 | m | 441650 m := WeakMessageSend 441651 receiver: true 441652 selector: #yourself. 441653 self assert: (m value). 441654! ! 441655 441656!WeakMessageSendTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:11'! 441657testOneArgument 441658 "self run: #testOneArgument" 441659 441660 | m | 441661 m := WeakMessageSend 441662 receiver: Array 441663 selector: #with: 441664 argument: 1. 441665 Smalltalk garbageCollectMost. 441666 self assert: (m value = { 1 }) 441667! ! 441668 441669!WeakMessageSendTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:11'! 441670testOneArgumentWithGC 441671 441672 | m | 441673 m := WeakMessageSend 441674 receiver: Array 441675 selector: #with: 441676 arguments: { Object new }. 441677 Smalltalk garbageCollectMost. 441678 self assert: (m value isNil)! ! 441679 441680!WeakMessageSendTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:11'! 441681testReceiverWithGC 441682 441683 | m | 441684 m := WeakMessageSend 441685 receiver: Object new 441686 selector: #isNil. 441687 Smalltalk garbageCollectMost. 441688 self assert: (m value isNil).! ! 441689 441690!WeakMessageSendTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:11'! 441691testTwoArguments 441692 441693 | m | 441694 m := WeakMessageSend 441695 receiver: Array 441696 selector: #with:with: 441697 arguments: { 1 . 2 }. 441698 Smalltalk garbageCollectMost. 441699 self assert: (m value = { 1 . 2 }). 441700! ! 441701Collection subclass: #WeakRegistry 441702 instanceVariableNames: 'valueDictionary accessLock' 441703 classVariableNames: 'Default' 441704 poolDictionaries: '' 441705 category: 'Collections-Weak'! 441706!WeakRegistry commentStamp: '<historical>' prior: 0! 441707I am a registry for objects needing finalization. When an object is added the object as well as its executor is stored. When the object is garbage collected, the executor can take the appropriate action for any resources associated with the object. 441708 441709See also: 441710 Object executor 441711 Object actAsExecutor 441712 Object finalize 441713! 441714 441715 441716!WeakRegistry methodsFor: 'accessing' stamp: 'ar 12/12/2001 16:00'! 441717keys 441718 ^self protected:[ 441719 Array streamContents:[:s| valueDictionary keysDo:[:key| s nextPut: key]]].! ! 441720 441721!WeakRegistry methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:40'! 441722size 441723 ^ self protected: [valueDictionary size]! ! 441724 441725!WeakRegistry methodsFor: 'accessing' stamp: 'ar 3/20/98 19:31'! 441726species 441727 ^Set! ! 441728 441729 441730!WeakRegistry methodsFor: 'adding' stamp: 'ar 3/21/98 16:33'! 441731add: anObject 441732 "Add anObject to the receiver. Store the object as well as the associated executor." 441733 | executor | 441734 executor := anObject executor. 441735 self protected:[ 441736 valueDictionary at: anObject put: executor. 441737 ]. 441738 ^anObject! ! 441739 441740!WeakRegistry methodsFor: 'adding' stamp: 'ar 5/19/2003 20:08'! 441741add: anObject executor: anExecutor 441742 "Add anObject to the receiver. Store the object as well as the associated executor." 441743 self protected:[ 441744 valueDictionary at: anObject put: anExecutor. 441745 ]. 441746 ^anObject! ! 441747 441748 441749!WeakRegistry methodsFor: 'enumerating' stamp: 'ar 3/21/98 18:36'! 441750do: aBlock 441751 ^self protected:[ 441752 valueDictionary keysDo: aBlock. 441753 ]. 441754! ! 441755 441756 441757!WeakRegistry methodsFor: 'finalization' stamp: 'marcus.denker 9/14/2008 21:03'! 441758finalizeValues 441759 "Some of our elements may have gone away. Look for those and activate the associated executors." 441760 | finiObjects | 441761 finiObjects := nil. 441762 "First collect the objects." 441763 self protected:[ 441764 valueDictionary associationsDo: [:assoc| 441765 assoc key ifNil: [ 441766 finiObjects 441767 ifNil: [finiObjects := OrderedCollection with: assoc value] 441768 ifNotNil: [finiObjects add: assoc value]] 441769 ]. 441770 finiObjects ifNotNil: [valueDictionary finalizeValues: finiObjects asArray]. 441771 ]. 441772 "Then do the finalization" 441773 finiObjects ifNil: [^self]. 441774 finiObjects do:[:each| each finalize]. 441775! ! 441776 441777 441778!WeakRegistry methodsFor: 'initialize' stamp: 'NorbertHartl 6/18/2008 19:23'! 441779initialize: n 441780 valueDictionary := WeakIdentityKeyDictionary new: n. 441781 accessLock := Semaphore forMutualExclusion.! ! 441782 441783 441784!WeakRegistry methodsFor: 'printing' stamp: 'tk 12/5/2001 09:42'! 441785printElementsOn: aStream 441786 aStream nextPut: $(. 441787 accessLock 441788 ifNil: [self do: [:element | aStream print: element; space]] 441789 ifNotNil: [aStream nextPutAll: '<this WeakRegistry is locked>; space']. 441790 self isEmpty ifFalse: [aStream skip: -1]. 441791 aStream nextPut: $)! ! 441792 441793 441794!WeakRegistry methodsFor: 'removing' stamp: 'marcus.denker 9/14/2008 21:02'! 441795remove: oldObject ifAbsent: exceptionBlock 441796 "Remove oldObject as one of the receiver's elements." 441797 | removedObject | 441798 oldObject ifNil: [^oldObject]. 441799 self protected:[ 441800 removedObject := valueDictionary removeKey: oldObject ifAbsent: [nil]. 441801 ]. 441802 ^removedObject 441803 ifNil: [exceptionBlock value] 441804 ifNotNil: [removedObject]. 441805! ! 441806 441807!WeakRegistry methodsFor: 'removing' stamp: 'nice 1/10/2009 00:44'! 441808removeAll 441809 "See super" 441810 441811 self protected:[ 441812 valueDictionary removeAll. 441813 ].! ! 441814 441815 441816!WeakRegistry methodsFor: 'private' stamp: 'ar 10/8/1998 11:18'! 441817protected: aBlock 441818 "Execute aBlock protected by the accessLock" 441819 ^accessLock isNil 441820 ifTrue:[aBlock value] 441821 ifFalse:[accessLock critical: aBlock ifError:[:msg :rcvr| rcvr error: msg]]! ! 441822 441823"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 441824 441825WeakRegistry class 441826 instanceVariableNames: ''! 441827 441828!WeakRegistry class methodsFor: 'accessing' stamp: 'ar 5/19/2003 20:10'! 441829default 441830 ^Default ifNil:[Default := self new]! ! 441831 441832 441833!WeakRegistry class methodsFor: 'instance creation' stamp: 'ar 3/21/98 15:32'! 441834new 441835 ^self new: 5! ! 441836 441837!WeakRegistry class methodsFor: 'instance creation' stamp: 'ar 3/21/98 15:33'! 441838new: n 441839 | registry | 441840 registry := super new initialize: n. 441841 WeakArray addWeakDependent: registry. 441842 ^registry! ! 441843Set subclass: #WeakSet 441844 instanceVariableNames: 'flag' 441845 classVariableNames: '' 441846 poolDictionaries: '' 441847 category: 'Collections-Weak'! 441848 441849!WeakSet methodsFor: '*tools-inspector' stamp: 'ar 9/27/2005 18:33'! 441850inspectorClass 441851 ^ WeakSetInspector! ! 441852 441853 441854!WeakSet methodsFor: 'public' stamp: 'SqR 8/30/2000 13:15'! 441855add: newObject 441856 "Include newObject as one of the receiver's elements, but only if 441857 not already present. Answer newObject" 441858 441859 | index | 441860 newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element']. 441861 index := self findElementOrNil: newObject. 441862 ((array at: index) == flag or: [(array at: index) isNil]) 441863 ifTrue: [self atNewIndex: index put: newObject]. 441864 ^newObject! ! 441865 441866!WeakSet methodsFor: 'public' stamp: 'nk 3/11/2002 20:35'! 441867collect: aBlock 441868 | each newSet | 441869 newSet := self species new: self size. 441870 tally = 0 ifTrue: [^newSet ]. 441871 1 to: array size do: 441872 [:index | 441873 ((each := array at: index) == nil or: [each == flag]) 441874 ifFalse: [newSet add: (aBlock value: each)] 441875 ]. 441876 ^newSet! ! 441877 441878!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 15:46'! 441879do: aBlock 441880 | each | 441881 441882 tally = 0 ifTrue: [^self]. 441883 1 to: array size do: 441884 [:index | 441885 ((each := array at: index) == nil or: [each == flag]) 441886 ifFalse: [aBlock value: each] 441887 ]! ! 441888 441889!WeakSet methodsFor: 'public' stamp: 'SqR 8/30/2000 13:13'! 441890do: aBlock after: anElement 441891 | each startIndex | 441892 441893 tally = 0 ifTrue: [^self]. 441894 startIndex := anElement ifNil: [1] ifNotNil: 441895 [self findElementOrNil: anElement]. 441896 startIndex + 1 to: array size do: 441897 [:index | 441898 ((each := array at: index) == nil or: [each == flag]) 441899 ifFalse: [aBlock value: each] 441900 ]! ! 441901 441902!WeakSet methodsFor: 'public' stamp: 'SqR 8/30/2000 13:15'! 441903includes: anObject 441904 ^(array at: (self findElementOrNil: anObject)) ~~ flag! ! 441905 441906!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 16:02'! 441907like: anObject 441908 "Answer an object in the receiver that is equal to anObject, 441909 nil if no such object is found. Relies heavily on hash properties" 441910 441911 | index element | 441912 441913 ^(index := self scanFor: anObject) = 0 441914 ifFalse: [(element := array at: index) == flag ifFalse: [element]]! ! 441915 441916!WeakSet methodsFor: 'public' stamp: 'di 2/3/2001 16:46'! 441917printElementsOn: aStream 441918 | oldPos | 441919 aStream nextPut: $(. 441920 oldPos := aStream position. 441921 self do: [:element | aStream print: element; space]. 441922 aStream position > oldPos ifTrue: [aStream skip: -1 "remove the extra space"]. 441923 aStream nextPut: $)! ! 441924 441925!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 15:08'! 441926remove: oldObject ifAbsent: aBlock 441927 441928 | index | 441929 index := self findElementOrNil: oldObject. 441930 (array at: index) == flag ifTrue: [ ^ aBlock value ]. 441931 array at: index put: flag. 441932 tally := tally - 1. 441933 self fixCollisionsFrom: index. 441934 ^oldObject! ! 441935 441936!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 15:12'! 441937size 441938 "Careful!! Answer the maximum amount 441939 of elements in the receiver, not the 441940 exact amount" 441941 441942 ^tally! ! 441943 441944!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 15:17'! 441945slowSize 441946 "Careful!! Answer the maximum amount 441947 of elements in the receiver, not the 441948 exact amount" 441949 441950 tally := array inject: 0 into: 441951 [:total :each | (each == nil or: [each == flag]) 441952 ifTrue: [total] ifFalse: [total + 1]]. 441953 ^tally! ! 441954 441955 441956!WeakSet methodsFor: 'private' stamp: 'SqR 8/23/2000 14:30'! 441957fixCollisionsFrom: index 441958 "The element at index has been removed and replaced by nil. 441959 This method moves forward from there, relocating any entries 441960 that had been placed below due to collisions with this one" 441961 441962 | length oldIndex newIndex element | 441963 441964 oldIndex := index. 441965 length := array size. 441966 [oldIndex = length 441967 ifTrue: [oldIndex := 1] 441968 ifFalse: [oldIndex := oldIndex + 1]. 441969 (element := self keyAt: oldIndex) == flag] 441970 whileFalse: 441971 [newIndex := self findElementOrNil: element. 441972 oldIndex = newIndex ifFalse: [self swap: oldIndex with: newIndex]]! ! 441973 441974!WeakSet methodsFor: 'private' stamp: 'HenrikSperreJohansen 8/19/2009 16:30'! 441975grow 441976 "Grow the elements array if needed. 441977 Since WeakSets just nil their slots, alot of the occupied (in the eyes of the set) slots are usually empty. Doubling size if unneeded can lead to BAD performance, therefore we see if reassigning the <live> elements to a Set of similiar size leads to a sufficiently (50% used here) empty set first. 441978 and reinsert the old elements" 441979 |oldTally| 441980 oldTally := tally. 441981 self growTo: array size. 441982 oldTally >> 1 < tally ifTrue: [ 441983 self growTo: array size + self growSize]! ! 441984 441985!WeakSet methodsFor: 'private' stamp: 'SqR 8/23/2000 15:43'! 441986growTo: anInteger 441987 "Grow the elements array and reinsert the old elements" 441988 441989 | oldElements | 441990 441991 oldElements := array. 441992 array := WeakArray new: anInteger. 441993 array atAllPut: flag. 441994 tally := 0. 441995 oldElements do: 441996 [:each | (each == flag or: [each == nil]) ifFalse: [self noCheckAdd: each]]! ! 441997 441998!WeakSet methodsFor: 'private' stamp: 'nice 4/4/2006 22:09'! 441999initialize: n 442000 "Initialize array to an array size of n" 442001 442002 flag := Object new. 442003 array := WeakArray new: n. 442004 array atAllPut: flag. 442005 tally := 0! ! 442006 442007!WeakSet methodsFor: 'private' stamp: 'SqR 8/23/2000 15:43'! 442008rehash 442009 self growTo: array size! ! 442010 442011!WeakSet methodsFor: 'private' stamp: 'md 10/5/2005 15:44'! 442012scanFor: anObject 442013 "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements" 442014 442015 | element start finish | 442016 442017 finish := array size. 442018 start := (anObject hash \\ finish) + 1. 442019 442020 "Search from (hash mod size) to the end." 442021 start to: finish do: 442022 [:index | ((element := array at: index) == flag or: [element = anObject]) 442023 ifTrue: [^ index ]]. 442024 442025 "Search from 1 to where we started." 442026 1 to: start-1 do: 442027 [:index | ((element := array at: index) == flag or: [element = anObject]) 442028 ifTrue: [^ index ]]. 442029 442030 ^ 0 "No match AND no empty slot"! ! 442031 442032!WeakSet methodsFor: 'private' stamp: 'yo 11/11/2002 23:10'! 442033scanForLoadedSymbol: anObject 442034 "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements" 442035 442036 | element start finish | 442037 442038 start := (anObject hash \\ array size) + 1. 442039 finish := array size. 442040 442041 "Search from (hash mod size) to the end." 442042 start to: finish do: 442043 [:index | ((element := array at: index) == flag or: [element asString = anObject asString]) 442044 ifTrue: [^ index ]]. 442045 442046 "Search from 1 to where we started." 442047 1 to: start-1 do: 442048 [:index | ((element := array at: index) == flag or: [element asString = anObject asString]) 442049 ifTrue: [^ index ]]. 442050 442051 ^ 0 "No match AND no empty slot"! ! 442052SetInspector subclass: #WeakSetInspector 442053 instanceVariableNames: 'flagObject' 442054 classVariableNames: '' 442055 poolDictionaries: '' 442056 category: 'Tools-Inspector'! 442057!WeakSetInspector commentStamp: '<historical>' prior: 0! 442058A verison of the SetInspector specialized for inspecting WeakSets. It knows about the flag object used to indicate empty locations in the hash table.! 442059 442060 442061!WeakSetInspector methodsFor: 'accessing' stamp: 'nice 12/15/2007 11:59'! 442062fieldList 442063 | slotIndices | 442064 object ifNil: [^ Set new]. 442065 442066 "Implementation note: do not use objectArray withIndexCollect: as super 442067 because this might collect indices in a WeakArray, leading to constantly changing fieldList 442068 as explained at http://bugs.squeak.org/view.php?id=6812" 442069 442070 slotIndices := (Array new: object size) writeStream. 442071 object array withIndexDo: [:each :i | 442072 (each notNil and: [each ~= flagObject]) ifTrue: [slotIndices nextPut: i printString]]. 442073 442074 ^ self baseFieldList 442075 , slotIndices contents! ! 442076 442077 442078!WeakSetInspector methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! 442079initialize 442080 super initialize. 442081 flagObject := object instVarNamed: 'flag'. ! ! 442082TestCase subclass: #WeakSetInspectorTest 442083 instanceVariableNames: '' 442084 classVariableNames: '' 442085 poolDictionaries: '' 442086 category: 'ToolsTest-Inspector'! 442087 442088!WeakSetInspectorTest methodsFor: 'testing' stamp: 'nice 12/15/2007 11:51'! 442089testSymbolTableM6812 442090 "this test is related to http://bugs.squeak.org/view.php?id=6812" 442091 442092 | aWeakSet anInspector fieldSize | 442093 aWeakSet := (Symbol classPool at: #SymbolTable). 442094 anInspector := (ToolSet inspectorClassOf: aWeakSet) inspect: aWeakSet. 442095 442096 fieldSize := anInspector fieldList size. 442097 3 timesRepeat: 442098 [Smalltalk garbageCollect. 442099 self assert: fieldSize = anInspector fieldList size.] 442100 ! ! 442101SetTest subclass: #WeakSetTest 442102 instanceVariableNames: '' 442103 classVariableNames: '' 442104 poolDictionaries: '' 442105 category: 'CollectionsTests-Weak'! 442106 442107!WeakSetTest methodsFor: 'problems' stamp: 'cyrille.delaunay 6/29/2009 12:25'! 442108testClassComment 442109 "this test doesn't pass :" 442110 "self shouldnt: [self targetClass organization hasNoComment]."! ! 442111 442112 442113!WeakSetTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 11:43'! 442114classToBeTested 442115 442116^ WeakSet! ! 442117 442118"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 442119 442120WeakSetTest class 442121 instanceVariableNames: ''! 442122 442123!WeakSetTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 11:28'! 442124shouldInheritSelectors 442125 442126^true! ! 442127LookupKey weakSubclass: #WeakValueAssociation 442128 instanceVariableNames: '' 442129 classVariableNames: '' 442130 poolDictionaries: '' 442131 category: 'Collections-Support'! 442132!WeakValueAssociation commentStamp: '<historical>' prior: 0! 442133I am a lookup key (acting like an association but) holding only weakly on my value.! 442134 442135 442136!WeakValueAssociation methodsFor: 'accessing' stamp: 'r++ 5/27/2000 18:11'! 442137key: aKey value: anObject 442138 "Store the arguments as the variables of the receiver." 442139 442140 key := aKey. 442141 self value: anObject! ! 442142 442143!WeakValueAssociation methodsFor: 'accessing' stamp: 'r++ 5/27/2000 18:08'! 442144value 442145 ^self at: 1! ! 442146 442147!WeakValueAssociation methodsFor: 'accessing' stamp: 'r++ 5/27/2000 18:08'! 442148value: anObject 442149 "Store the argument, anObject, as the value of the receiver." 442150 442151 self at: 1 put: anObject! ! 442152 442153"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 442154 442155WeakValueAssociation class 442156 instanceVariableNames: ''! 442157 442158!WeakValueAssociation class methodsFor: 'as yet unclassified' stamp: 'r++ 5/27/2000 18:12'! 442159new 442160 ^ self new: 1! ! 442161 442162 442163!WeakValueAssociation class methodsFor: 'instance creation' stamp: 'r++ 5/27/2000 18:07'! 442164key: anObject value: bObject 442165 ^ self new key: anObject value: bObject! ! 442166Dictionary subclass: #WeakValueDictionary 442167 instanceVariableNames: '' 442168 classVariableNames: '' 442169 poolDictionaries: '' 442170 category: 'Collections-Weak'! 442171!WeakValueDictionary commentStamp: '<historical>' prior: 0! 442172I am a dictionary holding only weakly on my values. Clients may expect to get a nil value for any object they request.! 442173 442174 442175!WeakValueDictionary methodsFor: 'accessing' stamp: 'ar 3/21/98 16:01'! 442176at: key put: anObject 442177 "Set the value at key to be anObject. If key is not found, create a new 442178 entry for key and set is value to anObject. Answer anObject." 442179 | index element | 442180 index := self findElementOrNil: key. 442181 element := array at: index. 442182 element == nil 442183 ifTrue: [self atNewIndex: index put: (WeakValueAssociation key: key value: anObject)] 442184 ifFalse: [element value: anObject]. 442185 ^ anObject! ! 442186 442187 442188!WeakValueDictionary methodsFor: 'adding' stamp: 'ar 3/21/98 16:02'! 442189add: anAssociation 442190 self at: anAssociation key put: anAssociation value. 442191 ^ anAssociation! ! 442192DictionaryTest subclass: #WeakValueDictionaryTest 442193 instanceVariableNames: '' 442194 classVariableNames: '' 442195 poolDictionaries: '' 442196 category: 'CollectionsTests-Weak'! 442197 442198!WeakValueDictionaryTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 7/1/2009 16:25'! 442199classToBeTested 442200 442201^ WeakValueDictionary! ! 442202 442203"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 442204 442205WeakValueDictionaryTest class 442206 instanceVariableNames: ''! 442207 442208!WeakValueDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 7/1/2009 16:25'! 442209shouldInheritSelectors 442210 442211^true! ! 442212AppRegistry subclass: #WebBrowser 442213 instanceVariableNames: '' 442214 classVariableNames: '' 442215 poolDictionaries: '' 442216 category: 'System-Applications'! 442217Timespan subclass: #Week 442218 instanceVariableNames: '' 442219 classVariableNames: 'StartDay' 442220 poolDictionaries: 'ChronologyConstants' 442221 category: 'Kernel-Chronology'! 442222!Week commentStamp: 'brp 5/13/2003 09:48' prior: 0! 442223I represent a week.! 442224 442225 442226!Week methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:36'! 442227asWeek 442228 442229 ^ self ! ! 442230 442231!Week methodsFor: 'squeak protocol' stamp: 'brp 1/30/2005 09:31'! 442232index 442233 442234 ^ self asMonth dayOfWeek + self dayOfMonth - 2 // 7 + 1 442235! ! 442236 442237!Week methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:37'! 442238printOn: aStream 442239 442240 aStream nextPutAll: 'a Week starting: '. 442241 self start printOn: aStream. ! ! 442242 442243"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 442244 442245Week class 442246 instanceVariableNames: ''! 442247 442248!Week class methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 09:34'! 442249nameOfDay: anIndex 442250 442251 ^ DayNames at: anIndex ! ! 442252 442253 442254!Week class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:34'! 442255dayNames 442256 442257 ^ DayNames ! ! 442258 442259!Week class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:34'! 442260indexOfDay: aSymbol 442261 442262 ^ DayNames indexOf: aSymbol ! ! 442263 442264!Week class methodsFor: 'squeak protocol' stamp: 'brp 1/30/2005 09:17'! 442265startDay 442266 442267 ^ StartDay ifNil: [ StartDay 442268 := DayNames first ]! ! 442269 442270!Week class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 09:30'! 442271startDay: aSymbol 442272 442273 (DayNames includes: aSymbol) 442274 ifTrue: [ StartDay := aSymbol ] 442275 ifFalse: [ self error: aSymbol, ' is not a recognised day name' ] 442276! ! 442277 442278!Week class methodsFor: 'squeak protocol' stamp: 'adrian_lienhard 1/7/2009 18:18'! 442279starting: aDateAndTime duration: aDuration 442280 "Override - the duration is always one week. 442281 Week will start from the Week class>>startDay" 442282 442283 | midnight delta adjusted | 442284 midnight := aDateAndTime asDateAndTime midnight. 442285 delta := ((midnight dayOfWeek + 7 - (DayNames indexOf: self startDay)) rem: 7) abs. 442286 adjusted := midnight - (Duration days: delta seconds: 0). 442287 442288 ^ super starting: adjusted duration: (Duration weeks: 1).! ! 442289ClassTestCase subclass: #WeekTest 442290 instanceVariableNames: 'week restoredStartDay' 442291 classVariableNames: '' 442292 poolDictionaries: '' 442293 category: 'KernelTests-Chronology'! 442294 442295!WeekTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 12:42'! 442296classToBeTested 442297 442298 ^ Week! ! 442299 442300!WeekTest methodsFor: 'Coverage' stamp: 'brp 1/30/2005 09:21'! 442301selectorsToBeIgnored 442302 442303 | deprecated private special | 442304 442305 deprecated := #(). 442306 private := #( #printOn: ). 442307 special := #( #next #do: ). 442308 442309 ^ super selectorsToBeIgnored, deprecated, private, special.! ! 442310 442311 442312!WeekTest methodsFor: 'Running' stamp: 'brp 9/26/2004 18:52'! 442313setUp 442314 "June 1998, 5th week" 442315 442316 super setUp. 442317 restoredStartDay := Week startDay. 442318 Week startDay: #Sunday. 442319 week := Week starting: '4 July 1998' asDate! ! 442320 442321!WeekTest methodsFor: 'Running' stamp: 'brp 9/26/2004 18:53'! 442322tearDown 442323 442324 super tearDown. 442325 Week startDay: restoredStartDay. 442326 week := nil. 442327 442328! ! 442329 442330 442331!WeekTest methodsFor: 'Tests' stamp: 'brp 1/30/2005 09:32'! 442332testEnumerating 442333 442334 | days | 442335 days := OrderedCollection new. 442336 0 to: 6 do: [ :i | days add: ('28 June 1998' asDate addDays: i) ]. 442337 442338 week datesDo: [ :d | days remove: d ]. 442339 442340 self assert: days isEmpty. 442341! ! 442342 442343!WeekTest methodsFor: 'Tests' stamp: 'brp 1/30/2005 09:30'! 442344testInquiries 442345 442346 self 442347 assert: week start asDate = '28 June 1998' asDate; 442348 assert: week end asDate = '4 July 1998' asDate; 442349 assert: week index = 5; 442350 assert: week duration = (7 days). 442351! ! 442352 442353!WeekTest methodsFor: 'Tests' stamp: 'nk 7/30/2004 17:52'! 442354testPreviousNext 442355 self 442356 assert: week next = (Week starting: '6 July 1998' asDate); 442357 assert: week previous = (Week starting: '22 June 1998' asDate)! ! 442358Collection subclass: #WideCharacterSet 442359 instanceVariableNames: 'map' 442360 classVariableNames: '' 442361 poolDictionaries: '' 442362 category: 'Collections-Support'! 442363!WideCharacterSet commentStamp: 'nice 5/9/2006 23:33' prior: 0! 442364WideCharacterSet is used to store a Set of WideCharacter with fast access and inclusion test. 442365 442366Implementation should be efficient in memory if sets are sufficently sparse. 442367 442368Wide Characters are at most 32bits. 442369We split them into 16 highBits and 16 lowBits. 442370 442371map is a dictionary key: 16 highBits value: map of 16 lowBits. 442372 442373Maps of lowBits are stored as arrays of bits in a WordArray. 442374If a bit is set to 1, this indicate that corresponding character is present. 442375Only 2048 entries are necessary in each lowmap. 442376And only lowmap corresponding to a present high value are stored.! 442377 442378 442379!WideCharacterSet methodsFor: 'collection ops' stamp: 'nice 5/9/2006 22:45'! 442380add: aCharacter 442381 | val high low lowmap | 442382 val := aCharacter asciiValue. 442383 high := val bitShift: -16. 442384 low := val bitAnd: 16rFFFF. 442385 lowmap := map at: high ifAbsentPut: [WordArray new: 2048]. 442386 self setBitmap: lowmap at: low. 442387 ^ aCharacter! ! 442388 442389!WideCharacterSet methodsFor: 'collection ops' stamp: 'nice 5/10/2006 00:21'! 442390do: aBlock 442391 map 442392 keysAndValuesDo: [:high :lowmap | self 442393 bitmap: lowmap 442394 do: [:low | aBlock 442395 value: (Character value: ((high bitShift: 16) bitOr: low))]]! ! 442396 442397!WideCharacterSet methodsFor: 'collection ops' stamp: 'nice 5/9/2006 23:49'! 442398includes: aCharacter 442399 | val high low | 442400 val := aCharacter asciiValue. 442401 high := val bitShift: -16. 442402 low := val bitAnd: 16rFFFF. 442403 ^(self 442404 bitmap: (map 442405 at: high 442406 ifAbsent: [^ false]) 442407 at: low) isZero not! ! 442408 442409!WideCharacterSet methodsFor: 'collection ops' stamp: 'nice 9/25/2007 21:01'! 442410remove: aCharacter 442411 | val high low lowmap | 442412 val := aCharacter asciiValue. 442413 high := val bitShift: -16. 442414 low := val bitAnd: 16rFFFF. 442415 lowmap := map 442416 at: high 442417 ifAbsent: [^ aCharacter]. 442418 self clearBitmap: lowmap at: low. 442419 lowmap max = 0 442420 ifTrue: [map removeKey: high]. 442421 ^ aCharacter! ! 442422 442423!WideCharacterSet methodsFor: 'collection ops' stamp: 'nice 1/10/2009 00:45'! 442424removeAll 442425 map removeAll! ! 442426 442427!WideCharacterSet methodsFor: 'collection ops' stamp: 'nice 5/9/2006 23:00'! 442428size 442429 | size | 442430 size := 0. 442431 map 442432 keysAndValuesDo: [:high :lowmap | self 442433 bitmap: lowmap 442434 do: [:low | size := size + 1]]. 442435 ^ size! ! 442436 442437 442438!WideCharacterSet methodsFor: 'comparing' stamp: 'nice 5/9/2006 23:29'! 442439= anObject 442440 ^self species == anObject species and: [ 442441 self wideCharacterMap = anObject wideCharacterMap ]! ! 442442 442443!WideCharacterSet methodsFor: 'comparing' stamp: 'nice 5/10/2006 00:26'! 442444byteArrayMap 442445 "return a ByteArray mapping each ascii value to a 1 if that ascii value is in the set, and a 0 if it isn't. 442446 Intended for use by primitives only. (and comparison) 442447 This version will answer a subset with only byte characters" 442448 442449 | aMap lowmap | 442450 aMap := ByteArray new: 256. 442451 lowmap := map at: 0 ifAbsent: [^aMap]. 442452 lowmap := lowmap copyFrom: 1 to: 8. "Keep first 8*32=256 bits..." 442453 self bitmap: lowmap do: [:code | aMap at: code + 1 put: 1]. 442454 ^aMap! ! 442455 442456!WideCharacterSet methodsFor: 'comparing' stamp: 'nice 11/15/2007 21:26'! 442457hash 442458 "Answer a hash code aimed at storing and retrieving the receiver in a Set or Dictionary. 442459 Two equal objects should have equal hash. 442460 Note: as the receiver can be equal to an ordinary CharacterSet, 442461 the hash code must reflect this" 442462 442463 ^self hasWideCharacters 442464 ifTrue: [map hash] 442465 ifFalse: [self asCharacterSet hash]! ! 442466 442467!WideCharacterSet methodsFor: 'comparing' stamp: 'nice 5/9/2006 23:29'! 442468species 442469 ^self hasWideCharacters 442470 ifTrue: [WideCharacterSet] 442471 ifFalse: [CharacterSet]! ! 442472 442473!WideCharacterSet methodsFor: 'comparing' stamp: 'nice 5/9/2006 23:14'! 442474wideCharacterMap 442475 ^map! ! 442476 442477 442478!WideCharacterSet methodsFor: 'converting' stamp: 'nice 11/20/2007 00:19'! 442479complement 442480 "return a character set containing precisely the characters the receiver does not" 442481 442482 ^CharacterSetComplement of: self copy! ! 442483 442484 442485!WideCharacterSet methodsFor: 'copying' stamp: 'nice 11/20/2007 00:57'! 442486postCopy 442487 map := map collect: [:each | each copy]! ! 442488 442489 442490!WideCharacterSet methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:16'! 442491initialize 442492 super initialize. 442493 map := Dictionary new.! ! 442494 442495 442496!WideCharacterSet methodsFor: 'testing' stamp: 'nice 5/9/2006 23:25'! 442497hasWideCharacters 442498 "Answer true if i contain any wide character" 442499 442500 self do: [:e | e asciiValue >= 256 ifTrue: [^true]]. 442501 ^false! ! 442502 442503 442504!WideCharacterSet methodsFor: 'private' stamp: 'nice 5/9/2006 22:46'! 442505bitmap: aMap at: shortInteger 442506 "access a single bit in aMap. 442507 shortInteger should be between: 0 and: 16rFFFF" 442508 442509 | collecIndex bitIndex | 442510 collecIndex := shortInteger bitShift: -5. 442511 bitIndex := shortInteger bitAnd: 16r1F. 442512 ^(aMap at: collecIndex + 1) bitAnd: (1 bitShift: bitIndex)! ! 442513 442514!WideCharacterSet methodsFor: 'private' stamp: 'nice 5/10/2006 00:10'! 442515bitmap: aMap do: aBlock 442516 "Execute a block with each value (0 based) corresponding to set bits" 442517 442518 0 to: 31 do: [:shift | 442519 | mask | 442520 mask := 1 bitShift: shift. 442521 1 to: aMap size do: [:i | 442522 ((aMap at: i) bitAnd: mask) isZero ifFalse: [aBlock value: ((i - 1 bitShift: 5) bitOr: shift)]]]! ! 442523 442524!WideCharacterSet methodsFor: 'private' stamp: 'nice 5/9/2006 22:46'! 442525clearBitmap: aMap at: shortInteger 442526 "clear a single bit in aMap. 442527 shortInteger should be between: 0 and: 16rFFFF" 442528 442529 | collecIndex bitIndex | 442530 collecIndex := shortInteger bitShift: -5. 442531 bitIndex := shortInteger bitAnd: 16r1F. 442532 ^aMap at: collecIndex + 1 put: ((aMap at: collecIndex + 1) bitClear: (1 bitShift: bitIndex))! ! 442533 442534!WideCharacterSet methodsFor: 'private' stamp: 'nice 5/9/2006 22:47'! 442535setBitmap: aMap at: shortInteger 442536 "set a single bit in aMap. 442537 shortInteger should be between: 0 and: 16rFFFF" 442538 442539 | collecIndex bitIndex | 442540 collecIndex := shortInteger bitShift: -5. 442541 bitIndex := shortInteger bitAnd: 16r1F. 442542 ^aMap at: collecIndex + 1 put: ((aMap at: collecIndex + 1) bitOr: (1 bitShift: bitIndex))! ! 442543 442544"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 442545 442546WideCharacterSet class 442547 instanceVariableNames: ''! 442548 442549!WideCharacterSet class methodsFor: 'instance creation' stamp: 'nice 11/15/2007 22:38'! 442550newFrom: aCollection 442551 | newCollection | 442552 newCollection := self new. 442553 newCollection addAll: aCollection. 442554 ^newCollection! ! 442555TestCase subclass: #WideCharacterSetTest 442556 instanceVariableNames: '' 442557 classVariableNames: '' 442558 poolDictionaries: '' 442559 category: 'CollectionsTests-Support'! 442560!WideCharacterSetTest commentStamp: 'nice 11/19/2007 22:45' prior: 0! 442561WideCharacterSetTest holds tests for WideCharacterSet! 442562 442563 442564!WideCharacterSetTest methodsFor: 'testing' stamp: 'nice 11/19/2007 23:36'! 442565testAddingToCharacterSet 442566 442567 | cs wcs wc | 442568 cs := CharacterSet newFrom: 'aeiouy'. 442569 wcs := cs copy. 442570 wc := 4452 asCharacter. 442571 442572 self shouldnt: [wcs add: wc] raise: Error description: 'adding a WideCharacter to an ordinary CharacterSet should turn it into a WideCharacterSet'. 442573 442574 self should: [wcs size = (cs size + 1)] description: 'We just added a Character, size should be increased by one'. 442575 self shouldnt: [wcs = cs] description: 'We just added a Character, sets should not be equal'. 442576 self shouldnt: [cs = wcs] description: 'We just added a Character, sets should not be equal'. 442577 self should: [cs allSatisfy: [:char | wcs includes: char]] description: 'Each character of the original CharacterSet should be included in the WideCharacterSet'. 442578 self should: [wcs hasWideCharacters] description: 'We just added a WideCharacter, so this WideCharacterSet definitely has one'. 442579 self should: [wcs includes: wc] description: 'We just added this WideCharacter, so this WideCharacterSet should include it'. 442580 442581 wcs add: wc. 442582 self should: [wcs size = (cs size + 1)] description: 'We just added a Character already included in the set, size should be unchanged'. 442583 442584 wcs remove: wc. 442585 self should: [wcs size = cs size] description: 'We added then removed a Character, now size should be equal to original'. 442586 self shouldnt: [wcs hasWideCharacters] description: 'We just removed the only WideCharacter, so this WideCharacterSet definitely has no WideCharacter'. 442587 442588 self should: [wcs = cs] description: 'A WideCharacterSet can be equal to an Ordinary CharacterSet'. 442589 self should: [cs = wcs] description: 'An ordinary CharacterSet can be equal to a WideCharacterSet'. 442590 self should: [cs hash = wcs hash] description: 'If some objects are equal, then they should have same hash code'. 442591 442592 ! ! 442593 442594!WideCharacterSetTest methodsFor: 'testing' stamp: 'nice 11/20/2007 00:52'! 442595testCopy 442596 | theOriginal theCopy | 442597 theOriginal := WideCharacterSet newFrom: ('abc' copyWith: 300 asCharacter). 442598 theCopy := theOriginal copy. 442599 theCopy remove: $a. 442600 ^self should: [theOriginal includes: $a] description: 'Changing the copy should not change the original'.! ! 442601 442602!WideCharacterSetTest methodsFor: 'testing' stamp: 'nice 11/19/2007 23:34'! 442603testCreation 442604 "By now, only creation method is newFrom:" 442605 442606 | cs1 wcs1 cs2 wcs2 byteString wideString | 442607 byteString := 'aeiouy'. 442608 wideString := 'aeiouy' copyWith: 340 asCharacter. 442609 442610 cs1 := CharacterSet newFrom: byteString. 442611 wcs1 := WideCharacterSet newFrom: byteString. 442612 self should: [wcs1 = cs1]. 442613 self should: [wcs1 size = byteString "asSet" size]. 442614 442615 cs2 := CharacterSet newFrom: wideString. 442616 wcs2 := WideCharacterSet newFrom: wideString. 442617 self should: [wcs2 = cs2]. 442618 self should: [wcs2 size = wideString "asSet" size]. 442619 442620 self should: [(byteString indexOfAnyOf: wcs1) = 1] description: 'This should used optimized byteArrayMap method'. 442621 self should: [(byteString indexOfAnyOf: wcs2) = 1] description: 'This should used optimized byteArrayMap method'. 442622 442623 self should: [('bcd' indexOfAnyOf: wcs1) = 0] description: 'This should used optimized byteArrayMap method'. 442624 self should: [('bcd' indexOfAnyOf: wcs2) = 0] description: 'This should used optimized byteArrayMap method'.! ! 442625String variableWordSubclass: #WideString 442626 instanceVariableNames: '' 442627 classVariableNames: '' 442628 poolDictionaries: '' 442629 category: 'Collections-Strings'! 442630!WideString commentStamp: 'yo 10/19/2004 22:34' prior: 0! 442631This class represents the array of 32 bit wide characters. 442632! 442633 442634 442635!WideString methodsFor: 'accessing' stamp: 'ar 4/10/2005 17:14'! 442636at: index 442637 "Answer the Character stored in the field of the receiver indexed by the argument." 442638 ^ Character value: (self wordAt: index). 442639! ! 442640 442641!WideString methodsFor: 'accessing' stamp: 'nice 4/2/2008 23:53'! 442642at: index put: aCharacter 442643 "Store the Character in the field of the receiver indicated by the index." 442644 aCharacter isCharacter ifFalse:[self errorImproperStore]. 442645 self wordAt: index put: aCharacter asInteger. 442646 ^aCharacter! ! 442647 442648!WideString methodsFor: 'accessing' stamp: 'yo 10/31/2002 22:29'! 442649byteAt: index 442650 442651 | d r | 442652 d := (index + 3) // 4. 442653 r := (index - 1) \\ 4 + 1. 442654 ^ (self wordAt: d) digitAt: ((4 - r) + 1). 442655! ! 442656 442657!WideString methodsFor: 'accessing' stamp: 'yo 11/3/2002 13:19'! 442658byteAt: index put: aByte 442659 442660 | d r w | 442661 d := (index + 3) // 4. 442662 r := (index - 1) \\ 4 + 1. 442663 w := (self wordAt: d) bitAnd: ((16rFF<<((4 - r)*8)) bitInvert32). 442664 w := w + (aByte<<((4 - r)*8)). 442665 self basicAt: d put: w. 442666 ^ aByte. 442667! ! 442668 442669!WideString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:22'! 442670byteSize 442671 442672 ^ self size * 4. 442673! ! 442674 442675!WideString methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:36'! 442676replaceFrom: start to: stop with: replacement startingAt: repStart 442677 442678 <primitive: 105> 442679 replacement class == String ifTrue: [ 442680 ^ self replaceFrom: start to: stop with: (replacement asWideString) startingAt: repStart. 442681 ]. 442682 442683 ^ super replaceFrom: start to: stop with: replacement startingAt: repStart. 442684! ! 442685 442686!WideString methodsFor: 'accessing' stamp: 'ar 4/10/2005 17:14'! 442687wordAt: index 442688 <primitive: 60> 442689 ^ (self basicAt: index). 442690! ! 442691 442692!WideString methodsFor: 'accessing' stamp: 'ar 4/10/2005 17:14'! 442693wordAt: index put: anInteger 442694 <primitive: 61> 442695 self basicAt: index put: anInteger. 442696! ! 442697 442698 442699!WideString methodsFor: 'converting' stamp: 'yo 8/28/2002 14:46'! 442700asFourCode 442701 442702 | result | 442703 self size = 1 ifFalse: [^self error: 'must be exactly four octets']. 442704 result := self basicAt: 1. 442705 (result bitAnd: 16r80000000) = 0 442706 ifFalse: [self error: 'cannot resolve fourcode']. 442707 (result bitAnd: 16r40000000) = 0 ifFalse: [^result - 16r80000000]. 442708 ^ result 442709! ! 442710 442711!WideString methodsFor: 'converting' stamp: 'stephane.ducasse 3/31/2009 21:31'! 442712asPacked 442713 442714 self inject: 0 into: [:pack :next | pack * 16r100000000 + next asInteger]. 442715! ! 442716 442717!WideString methodsFor: 'converting' stamp: 'yo 3/14/2005 11:41'! 442718copyFrom: start to: stop 442719 442720 | n | 442721 n := super copyFrom: start to: stop. 442722 n isOctetString ifTrue: [^ n asOctetString]. 442723 ^ n. 442724! ! 442725 442726 442727!WideString methodsFor: 'testing' stamp: 'yo 7/29/2003 14:10'! 442728includesUnifiedCharacter 442729 442730 ^ self isUnicodeStringWithCJK 442731! ! 442732 442733!WideString methodsFor: 'testing' stamp: 'ar 4/12/2005 14:10'! 442734isUnicodeStringWithCJK 442735 442736 self do: [:c | 442737 (c isTraditionalDomestic not and: [Unicode isUnifiedKanji: c charCode]) ifTrue: [ 442738 ^ true 442739 ]. 442740 ]. 442741 442742 ^ false. 442743! ! 442744 442745!WideString methodsFor: 'testing' stamp: 'ar 4/12/2005 19:52'! 442746isWideString 442747 "Answer whether the receiver is a WideString" 442748 ^true! ! 442749 442750 442751!WideString methodsFor: 'private' stamp: 'ar 4/9/2005 22:31'! 442752mutateJISX0208StringToUnicode 442753 442754 | c | 442755 1 to: self size do: [:i | 442756 c := self at: i. 442757 (c leadingChar = JISX0208 leadingChar or: [ 442758 c leadingChar = (JISX0208 leadingChar bitShift: 2)]) ifTrue: [ 442759 self basicAt: i put: (Character leadingChar: JapaneseEnvironment leadingChar code: (c asUnicode)) asciiValue. 442760 ] 442761 ]. 442762! ! 442763 442764"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 442765 442766WideString class 442767 instanceVariableNames: ''! 442768 442769!WideString class methodsFor: 'enumeration' stamp: 'yo 8/12/2003 17:14'! 442770allMultiStringMethods 442771 "Answer a SortedCollection of all the methods that implement the message 442772 aSelector." 442773 442774 | list adder num i | 442775 list := Set new. 442776 adder := [ :mrClass :mrSel | 442777 list add: ( 442778 MethodReference new 442779 setStandardClass: mrClass 442780 methodSymbol: mrSel 442781 ) 442782 ]. 442783 442784 num := CompiledMethod allInstances size. 442785 i := 0. 442786 'processing...' displayProgressAt: Sensor cursorPoint from: 0 to: num during: [:bar | 442787 SystemNavigation new allBehaviorsDo: [ :class | 442788 class selectors do: [:s | 442789 bar value: (i := i + 1). 442790 ((class sourceCodeAt: s) asString isOctetString) ifFalse: [ 442791 adder value: class value: s. 442792 ] 442793 ] 442794 ] 442795 ]. 442796 442797 ^ list. 442798! ! 442799 442800!WideString class methodsFor: 'enumeration' stamp: 'yo 8/27/2003 07:00'! 442801allNonAsciiMethods 442802 "Answer a SortedCollection of all the methods that implement the message 442803 aSelector." 442804 442805 | list adder num i | 442806 list := Set new. 442807 adder := [ :mrClass :mrSel | 442808 list add: ( 442809 MethodReference new 442810 setStandardClass: mrClass 442811 methodSymbol: mrSel 442812 ) 442813 ]. 442814 442815 num := CompiledMethod allInstances size. 442816 i := 0. 442817 'processing...' displayProgressAt: Sensor cursorPoint from: 0 to: num during: [:bar | 442818 SystemNavigation new allBehaviorsDo: [ :class | 442819 class selectors do: [:s | 442820 bar value: (i := i + 1). 442821 ((class sourceCodeAt: s) asString isAsciiString) ifFalse: [ 442822 adder value: class value: s. 442823 ] 442824 ] 442825 ] 442826 ]. 442827 442828 ^ list. 442829! ! 442830 442831 442832!WideString class methodsFor: 'instance creation' stamp: 'ar 4/10/2005 19:38'! 442833fromByteArray: aByteArray 442834 442835 | inst | 442836 aByteArray size \\ 4 = 0 ifFalse: [^ ByteString fromByteArray: aByteArray ]. 442837 inst := self new: aByteArray size // 4. 442838 4 to: aByteArray size by: 4 do: [:i | 442839 inst basicAt: i // 4 442840 put: ((aByteArray at: i - 3) << 24) + 442841 ((aByteArray at: i - 2) << 16) + 442842 ((aByteArray at: i - 1) << 8) + 442843 (aByteArray at: i) 442844 ]. 442845 442846 ^ inst 442847! ! 442848 442849!WideString class methodsFor: 'instance creation' stamp: 'ar 4/12/2005 19:58'! 442850fromPacked: aLong 442851 "Convert from a longinteger to a String of length 4." 442852 442853 | s val | 442854 s := self new: 1. 442855 val := (((aLong digitAt: 4) << 24) bitOr:((aLong digitAt: 3) << 16)) 442856 bitOr: (((aLong digitAt: 2) << 8) bitOr: (aLong digitAt: 1)). 442857 s basicAt: 1 put: val. 442858 ^ s. 442859 442860"WideString fromPacked: 'TEXT' asPacked" 442861! ! 442862 442863!WideString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:39'! 442864fromString: aString 442865 "Answer an instance of me that is a copy of the argument, aString." 442866 442867 | inst | 442868 (aString isMemberOf: self) ifTrue: [ 442869 ^ aString copy. 442870 ]. 442871 inst := self new: aString size. 442872 1 to: aString size do: [:pos | 442873 inst basicAt: pos put: (aString basicAt: pos). 442874 ]. 442875 ^ inst. 442876! ! 442877 442878!WideString class methodsFor: 'instance creation' stamp: 'ar 4/12/2005 20:00'! 442879from: aString 442880 442881 | newString | 442882 (aString isMemberOf: self) 442883 ifTrue: [^ aString copy]. 442884 newString := self new: aString size. 442885 1 to: aString size do: [:index | newString basicAt: index put: (aString basicAt: index)]. 442886 ^ newString 442887! ! 442888ClassTestCase subclass: #WideStringTest 442889 instanceVariableNames: '' 442890 classVariableNames: '' 442891 poolDictionaries: '' 442892 category: 'CollectionsTests-Text'! 442893!WideStringTest commentStamp: '<historical>' prior: 0! 442894This is the unit test for the class String. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 442895 - http://www.c2.com/cgi/wiki?UnitTest 442896 - http://minnow.cc.gatech.edu/squeak/1547 442897 - the sunit class category! 442898 442899 442900!WideStringTest methodsFor: 'testing' stamp: 'nice 4/2/2008 23:49'! 442901testAtPut 442902 "Non regression test for http://bugs.squeak.org/view.php?id=6998" 442903 442904 | w1 | 442905 w1 := WideString with: (Unicode value: 402) with: $a with: (Unicode value: 400) with: $b. 442906 self assert: (w1 at: 2 put: $b) = $b description: 'at:put: should return the put-object' 442907! ! 442908 442909 442910!WideStringTest methodsFor: 'tests - beginswith' stamp: 'nice 7/28/2007 23:29'! 442911testBeginsWith 442912 "from johnmci at http://bugs.squeak.org/view.php?id=5331" 442913 442914 | w1 w2 | 442915 self assert: ('abc' beginsWith: 'ab'). 442916 self assert: ('abc' beginsWith: 'ab' asWideString). 442917 self assert: ('abc' asWideString beginsWith: 'ab'). 442918 self assert: ('abc' beginsWith: 'aX') not . 442919 self assert: ('abc' beginsWith: 'AB') not. 442920 self assert: ('abc' beginsWith: 'AB' asWideString) not . 442921 self assert: ('ABC' asWideString beginsWith: 'ab') not. 442922 442923 w1 := WideString with: (Unicode value: 402) with: $a with: (Unicode value: 400) with: $b. 442924 w2 := WideString with: (Unicode value: 402). 442925 w1 beginsWith: w2. 442926! ! 442927 442928 442929!WideStringTest methodsFor: 'tests - compare' stamp: 'nice 7/28/2007 23:19'! 442930testCompare 442931 "from johnmci at http://bugs.squeak.org/view.php?id=5331" 442932 442933 self assert: ('abc' compare: 'abc') = 2. 442934 self assert: ('abc' compare: 'abd') = 1. 442935 self assert: ('abd' compare: 'abc') = 3. 442936 self assert: ('abc' compare: 'abC') = 2. 442937 self assert: ('abc' compare: 'abD') = 1. 442938 self assert: ('abd' compare: 'abC') = 3. 442939 self assert: ('aBc' compare: 'abC') = 2. 442940 self assert: ('aBc' compare: 'abD') = 1. 442941 self assert: ('aDd' compare: 'abC') = 3. 442942 442943 442944 self assert: ('abc' compare: 'abc' asWideString) = 2. 442945 self assert: ('abc' compare: 'abd' asWideString) = 1. 442946 self assert: ('abd' compare: 'abc' asWideString) = 3. 442947 self assert: ('abc' compare: 'abC' asWideString) = 2. 442948 self assert: ('abc' compare: 'abD' asWideString) = 1. 442949 self assert: ('abd' compare: 'abC' asWideString) = 3. 442950 self assert: ('aBc' compare: 'abC' asWideString) = 2. 442951 self assert: ('aBc' compare: 'abD' asWideString) = 1. 442952 self assert: ('aDd' compare: 'abC' asWideString) = 3. 442953 442954 self assert: ('abc' asWideString compare: 'abc') = 2. 442955 self assert: ('abc' asWideString compare: 'abd') = 1. 442956 self assert: ('abd' asWideString compare: 'abc') = 3. 442957 self assert: ('abc' asWideString compare: 'abC') = 2. 442958 self assert: ('abc' asWideString compare: 'abD') = 1. 442959 self assert: ('abd' asWideString compare: 'abC') = 3. 442960 self assert: ('aBc' asWideString compare: 'abC') = 2. 442961 self assert: ('aBc' asWideString compare: 'abD') = 1. 442962 self assert: ('aDd' asWideString compare: 'abC') = 3. 442963 442964 self assert: ('abc' asWideString compare: 'abc' asWideString) = 2. 442965 self assert: ('abc' asWideString compare: 'abd' asWideString) = 1. 442966 self assert: ('abd' asWideString compare: 'abc' asWideString) = 3. 442967 self assert: ('abc' asWideString compare: 'abC' asWideString) = 2. 442968 self assert: ('abc' asWideString compare: 'abD' asWideString) = 1. 442969 self assert: ('abd' asWideString compare: 'abC' asWideString) = 3. 442970 self assert: ('aBc' asWideString compare: 'abC' asWideString) = 2. 442971 self assert: ('aBc' asWideString compare: 'abD' asWideString) = 1. 442972 self assert: ('aDd' asWideString compare: 'abC' asWideString) = 3. 442973 442974 self assert: ('abc' compare: 'abc' caseSensitive: true) = 2. 442975 self assert: ('abc' compare: 'abC' caseSensitive: false) = 2. 442976 self assert: ('abc' compare: 'abc' asWideString caseSensitive: true) = 2. 442977 self assert: ('abc' compare: 'abC' asWideString caseSensitive: false) = 2. 442978 self assert: ('abc' asWideString compare: 'abc' caseSensitive: true) = 2. 442979 self assert: ('abc' asWideString compare: 'abC' caseSensitive: false) = 2. 442980 self assert: ('abc' asWideString compare: 'abc' asWideString caseSensitive: true) = 2. 442981 self assert: ('abc' asWideString compare: 'abC' asWideString caseSensitive: false) = 2.! ! 442982 442983!WideStringTest methodsFor: 'tests - compare' stamp: 'nice 7/28/2007 23:24'! 442984testEqual 442985 "from johnmci at http://bugs.squeak.org/view.php?id=5331" 442986 442987 self assert: 'abc' = 'abc'. 442988 self assert: 'abc' = 'abc' asWideString. 442989 self assert: 'abc' asWideString = 'abc'. 442990 self assert: 'abc' asWideString = 'abc' asWideString. 442991 self assert: ('abc' = 'ABC') not. 442992 self assert: ('abc' = 'ABC' asWideString) not. 442993 self assert: ('abc' asWideString = 'ABC') not. 442994 self assert: ('abc' asWideString = 'abc' asWideString). 442995 self assert: ((ByteArray with: 97 with: 0 with: 0 with: 0) asString ~= 'a000' asWideString). 442996 self assert: ('a000' asWideString ~= (ByteArray with: 97 with: 0 with: 0 with: 0) asString).! ! 442997 442998!WideStringTest methodsFor: 'tests - compare' stamp: 'nice 7/28/2007 23:25'! 442999testSameAs 443000 "from johnmci at http://bugs.squeak.org/view.php?id=5331" 443001 443002 self assert: ('abc' sameAs: 'aBc' asWideString). 443003 self assert: ('aBc' asWideString sameAs: 'abc'). 443004 self assert: ((ByteArray with: 97 with: 0 with: 0 with: 0) asString sameAs: 'Abcd' asWideString) not. 443005 self assert: ('a000' asWideString sameAs: (ByteArray with: 97 with: 0 with: 0 with: 0) asString) not. 443006 ! ! 443007 443008 443009!WideStringTest methodsFor: 'tests - converting' stamp: 'ar 4/12/2005 17:36'! 443010testAsInteger 443011 self assert: '1796exportFixes-tkMX' asWideString asInteger = 1796. 443012 self assert: 'donald' asWideString asInteger isNil. 443013 self assert: 'abc234def567' asWideString asInteger = 234. 443014 self assert: '-94' asWideString asInteger = -94. 443015 self assert: 'foo-bar-92' asWideString asInteger = -92. 443016 443017 self assert: '1796exportFixes-tkMX' asWideString asSignedInteger = 1796. 443018 self assert: 'donald' asWideString asSignedInteger isNil. 443019 self assert: 'abc234def567' asWideString asSignedInteger = 234. 443020 self assert: '-94' asWideString asSignedInteger = -94. 443021 self assert: 'foo-bar-92' asWideString asSignedInteger = -92. 443022 443023 self assert: '1796exportFixes-tkMX' asWideString asUnsignedInteger = 1796. 443024 self assert: 'donald' asWideString asUnsignedInteger isNil. 443025 self assert: 'abc234def567' asWideString asUnsignedInteger = 234. 443026 self assert: '-94' asWideString asUnsignedInteger = 94. 443027 self assert: 'foo-bar-92' asWideString asUnsignedInteger = 92! ! 443028 443029 443030!WideStringTest methodsFor: 'tests - endswith' stamp: 'nice 7/28/2007 23:30'! 443031testEndsWith 443032 "from johnmci at http://bugs.squeak.org/view.php?id=5331" 443033 443034 self assert: ('abc' endsWith: 'bc'). 443035 self assert: ('abc' endsWith: 'bc' asWideString). 443036 self assert: ('abc' asWideString endsWith: 'bc'). 443037 self assert: ('abc' endsWith: 'bX') not . 443038 self assert: ('abc' endsWith: 'BC') not. 443039 self assert: ('abc' endsWith: 'BC' asWideString) not . 443040 self assert: ('ABC' asWideString endsWith: 'bc') not. 443041 443042! ! 443043 443044 443045!WideStringTest methodsFor: 'tests - match' stamp: 'nice 7/28/2007 23:22'! 443046testCharactersExactlyMatching 443047 "from johnmci at http://bugs.squeak.org/view.php?id=5331" 443048 443049 self assert: ('abc' charactersExactlyMatching: 'abc') = 3. 443050 self assert: ('abd' charactersExactlyMatching: 'abc') = 2. 443051 self assert: ('abc' charactersExactlyMatching: 'abc' asWideString) = 3. 443052 self assert: ('abd' charactersExactlyMatching: 'abc' asWideString) = 2. 443053 self assert: ('abc' asWideString charactersExactlyMatching: 'abc') = 3. 443054 self assert: ('abd' asWideString charactersExactlyMatching: 'abc') = 2. 443055 self assert: ('abc' asWideString charactersExactlyMatching: 'abc' asWideString) = 3. 443056 self assert: ('abd' asWideString charactersExactlyMatching: 'abc' asWideString)= 2. 443057 self assert: ('abc' charactersExactlyMatching: 'ABC') = 0. 443058 443059! ! 443060 443061!WideStringTest methodsFor: 'tests - match' stamp: 'nice 7/28/2007 23:16'! 443062testMatch 443063 "from johnmci at http://bugs.squeak.org/view.php?id=5331" 443064 443065 self assert: ('*baz' match: 'mobaz' ). 443066 self assert: ('*foo#zort' match: 'afoo3zortthenfoo3zort' ). 443067 self assert: ('*baz' match: 'mobaz' ). 443068 self assert: ('*foo#zort' match: 'afoo3zortthenfoo3zort' ). 443069 443070 self assert: ('*baz' match: 'mobaz' asWideString). 443071 self assert: ('*foo#zort' match: 'afoo3zortthenfoo3zort' asWideString). 443072 self assert: ('*baz' match: 'mobaz' asWideString). 443073 self assert: ('*foo#zort' match: 'afoo3zortthenfoo3zort' asWideString). 443074 443075 self assert: ('*baz' asWideString match: 'mobaz' ). 443076 self assert: ('*foo#zort' asWideString match: 'afoo3zortthenfoo3zort' ). 443077 self assert: ('*baz' asWideString match: 'mobaz' ). 443078 self assert: ('*foo#zort' asWideString match: 'afoo3zortthenfoo3zort' ). 443079 443080 self assert: ('*baz' asWideString match: 'mobaz' asWideString). 443081 self assert: ('*foo#zort' asWideString match: 'afoo3zortthenfoo3zort' asWideString). 443082 self assert: ('*baz' asWideString match: 'mobaz' asWideString). 443083 self assert: ('*foo#zort' asWideString match: 'afoo3zortthenfoo3zort' asWideString).! ! 443084 443085 443086!WideStringTest methodsFor: 'tests - relation order' stamp: 'nice 7/28/2007 23:14'! 443087testRelationOrder 443088 "from johnmci at http://bugs.squeak.org/view.php?id=5331" 443089 443090 self assert: ('aa' < 'ab'). 443091 self assert: ('aa' <= 'ab'). 443092 self assert: ('aa' <= 'aa'). 443093 self assert: ('ab' > 'aa'). 443094 self assert: ('ab' >= 'aa'). 443095 self assert: ('aa' >= 'aa'). 443096 443097 self assert: ('aa' < 'ab' asWideString). 443098 self assert: ('aa' <= 'ab' asWideString). 443099 self assert: ('aa' <= 'aa' asWideString). 443100 self assert: ('ab' > 'aa' asWideString). 443101 self assert: ('ab' >= 'aa' asWideString). 443102 self assert: ('aa' >= 'aa' asWideString). 443103 443104 self assert: ('aa' asWideString < 'ab'). 443105 self assert: ('aa' asWideString <= 'ab'). 443106 self assert: ('aa' asWideString <= 'aa'). 443107 self assert: ('ab' asWideString > 'aa'). 443108 self assert: ('ab' asWideString >= 'aa'). 443109 self assert: ('aa' asWideString >= 'aa'). 443110 443111 self assert: ('aa' asWideString< 'ab' asWideString). 443112 self assert: ('aa' asWideString<= 'ab' asWideString). 443113 self assert: ('aa' asWideString<= 'aa' asWideString). 443114 self assert: ('ab' asWideString> 'aa' asWideString). 443115 self assert: ('ab' asWideString >= 'aa' asWideString). 443116 self assert: ('aa' asWideString>= 'aa' asWideString).! ! 443117 443118!WideStringTest methodsFor: 'tests - relation order' stamp: 'nice 7/28/2007 23:21'! 443119testRelationOrderWithCase 443120 "from johnmci at http://bugs.squeak.org/view.php?id=5331" 443121 443122 self assert: ('ABC' caseInsensitiveLessOrEqual: 'abc'). 443123 self assert: ('ABC' caseInsensitiveLessOrEqual: 'abd'). 443124 self assert: ('ABD' caseInsensitiveLessOrEqual: 'abc') not. 443125 self assert: ('ABC' caseInsensitiveLessOrEqual: 'abc' asWideString). 443126 self assert: ('ABC' caseInsensitiveLessOrEqual: 'abd' asWideString). 443127 self assert: ('ABD' caseInsensitiveLessOrEqual: 'abc' asWideString) not. 443128 self assert: ('ABC' asWideString caseInsensitiveLessOrEqual: 'abc'). 443129 self assert: ('ABC' asWideString caseInsensitiveLessOrEqual: 'abd'). 443130 self assert: ('ABD' asWideString caseInsensitiveLessOrEqual: 'abc') not. 443131 self assert: ('ABC' asWideString caseInsensitiveLessOrEqual: 'abc' asWideString). 443132 self assert: ('ABC' asWideString caseInsensitiveLessOrEqual: 'abd' asWideString). 443133 self assert: ('ABD' asWideString caseInsensitiveLessOrEqual: 'abc' asWideString) not. 443134 443135 443136 self assert: ('abc' caseSensitiveLessOrEqual: 'abc'). 443137 self assert: ('abc' caseSensitiveLessOrEqual: 'abd'). 443138 self assert: ('abd' caseSensitiveLessOrEqual: 'abc') not. 443139 self assert: ('abc' caseSensitiveLessOrEqual: 'abc' asWideString). 443140 self assert: ('abc' caseSensitiveLessOrEqual: 'abd' asWideString). 443141 self assert: ('abd' caseSensitiveLessOrEqual: 'abc' asWideString) not. 443142 self assert: ('abc' asWideString caseSensitiveLessOrEqual: 'abc'). 443143 self assert: ('abc' asWideString caseSensitiveLessOrEqual: 'abd'). 443144 self assert: ('abd' asWideString caseSensitiveLessOrEqual: 'abc') not. 443145 self assert: ('abc' caseSensitiveLessOrEqual: 'ABC') not. 443146 ! ! 443147 443148 443149!WideStringTest methodsFor: 'tests - substrings' stamp: 'nice 7/28/2007 00:46'! 443150testFindSubstring 443151 "This is related to http://bugs.squeak.org/view.php?id=6366 443152 finding substring in a WideString was broken because matchTable are byte-wise" 443153 443154 | ws1 ws2 | 443155 443156 self assert: ('abcd' findString: 'bc' startingAt: 1) = 2. 443157 self assert: ('abcd' asWideString findString: 'bc' startingAt: 1) = 2. 443158 self assert: ('abcd' findString: 'bc' asWideString startingAt: 1) = 2. 443159 self assert: ('abcd' asWideString findString: 'bc' asWideString startingAt: 1) = 2. 443160 443161 ws1 := 'A' , (WideString with: (Unicode value: 530)) , 'BCD'. 443162 self assert: (ws1 findString: 'bc' startingAt: 1 caseSensitive: true) = 0. 443163 self assert: (ws1 findString: 'bc' startingAt: 1 caseSensitive: false) = 3. 443164 443165 ws2 := (WideString with: (Unicode value: 530)) , 'b'. 443166 self assert: (ws1 findString: ws2 startingAt: 1 caseSensitive: true) = 0. 443167 self assert: (ws1 findString: ws2 startingAt: 1 caseSensitive: false) = 2. 443168 443169 self assert: ('abc' findString: ws2 startingAt: 1 caseSensitive: true) = 0. 443170 self assert: ('abc' findString: ws2 startingAt: 1 caseSensitive: false) = 0.! ! 443171 443172!WideStringTest methodsFor: 'tests - substrings' stamp: 'nice 3/23/2007 01:52'! 443173testSubstrings 443174 "this is related to http://bugs.squeak.org/view.php?id=6367" 443175 443176 | w1 w2 | 443177 w1 := WideString with: 401 asCharacter with: $a with: 402 asCharacter with: $b. 443178 w2 := WideString with: 403 asCharacter with: 404 asCharacter. 443179 443180 self assert: w1 substrings first = w1. 443181 self assert: (w1 , ' ' , w2) substrings size = 2. 443182 self assert: (w1 , ' ' , w2) substrings last = w2.! ! 443183Symbol variableWordSubclass: #WideSymbol 443184 instanceVariableNames: '' 443185 classVariableNames: '' 443186 poolDictionaries: '' 443187 category: 'Collections-Strings'! 443188!WideSymbol commentStamp: '<historical>' prior: 0! 443189This class represents the symbols containing 32bit characters.! 443190 443191 443192!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 23:38'! 443193at: index 443194 "Answer the Character stored in the field of the receiver indexed by the argument." 443195 ^ Character value: (self wordAt: index). 443196! ! 443197 443198!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 23:38'! 443199byteAt: index 443200 443201 | d r | 443202 d := (index + 3) // 4. 443203 r := (index - 1) \\ 4 + 1. 443204 ^ (self wordAt: d) digitAt: ((4 - r) + 1). 443205! ! 443206 443207!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 23:38'! 443208byteAt: index put: aByte 443209 self errorNoModification.! ! 443210 443211!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 23:38'! 443212byteSize 443213 443214 ^ self size * 4. 443215! ! 443216 443217!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:34'! 443218species 443219 "Answer the preferred class for reconstructing the receiver." 443220 ^WideString 443221! ! 443222 443223!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 23:38'! 443224wordAt: index 443225 <primitive: 60> 443226 ^ (self basicAt: index). 443227! ! 443228 443229!WideSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 23:39'! 443230wordAt: index put: anInteger 443231 self errorNoModification.! ! 443232 443233 443234!WideSymbol methodsFor: 'testing' stamp: 'ar 4/12/2005 19:52'! 443235isWideString 443236 "Answer whether the receiver is a WideString" 443237 ^true! ! 443238 443239 443240!WideSymbol methodsFor: 'private' stamp: 'ar 4/12/2005 14:12'! 443241fixUponLoad: aProject seg: anImageSegment 443242 "We are in an old project that is being loaded from disk. 443243 Fix up conventions that have changed." 443244 | ms | 443245 "Yoshiki did not put MultiSymbols into outPointers in older images!! 443246 When all old images are gone, remove this method." 443247 ms := Symbol intern: self asString. 443248 self == ms ifFalse: [ 443249 "For a project from older m17n image, this is necessary." 443250 self becomeForward: ms. 443251 aProject projectParameters at: #MultiSymbolInWrongPlace put: true 443252 ]. 443253 443254 "MultiString>>capitalized was not implemented correctly. 443255 Fix eventual accessors and mutators here." 443256 ((self beginsWith: 'get') 443257 and:[(self at: 4) asInteger < 256 443258 and:[(self at: 4) isLowercase]]) ifTrue:[ 443259 ms := self asString. 443260 ms at: 4 put: (ms at: 4) asUppercase. 443261 ms := ms asSymbol. 443262 self becomeForward: ms. 443263 aProject projectParameters at: #MultiSymbolInWrongPlace put: true. 443264 ]. 443265 ((self beginsWith: 'set') 443266 and:[(self at: 4) asInteger < 256 443267 and:[(self at: 4) isLowercase 443268 and:[self last = $: 443269 and:[(self occurrencesOf: $:) = 1]]]]) ifTrue:[ 443270 ms := self asString. 443271 ms at: 4 put: (ms at: 4) asUppercase. 443272 ms := ms asSymbol. 443273 self becomeForward: ms. 443274 aProject projectParameters at: #MultiSymbolInWrongPlace put: true. 443275 ]. 443276 ^ super fixUponLoad: aProject seg: anImageSegment "me, not the label" 443277! ! 443278 443279!WideSymbol methodsFor: 'private' stamp: 'yo 7/29/2005 21:53'! 443280mutateJISX0208StringToUnicode 443281 443282 | c | 443283 1 to: self size do: [:i | 443284 c := self at: i. 443285 (c leadingChar = JISX0208 leadingChar or: [ 443286 c leadingChar = (JISX0208 leadingChar bitShift: 2)]) ifTrue: [ 443287 self basicAt: i put: (Character leadingChar: JapaneseEnvironment leadingChar code: (c asUnicode)) asciiValue. 443288 ] 443289 ]. 443290! ! 443291 443292!WideSymbol methodsFor: 'private' stamp: 'ar 4/11/2005 00:09'! 443293pvtAt: index put: aCharacter 443294 "Primitive. Store the Character in the field of the receiver indicated by 443295 the index. Fail if the index is not an Integer or is out of bounds, or if 443296 the argument is not a Character. Essential. See Object documentation 443297 whatIsAPrimitive." 443298 443299 <primitive: 61> 443300 index isInteger 443301 ifTrue: [self errorSubscriptBounds: index] 443302 ifFalse: [self errorNonIntegerIndex]! ! 443303 443304!WideSymbol methodsFor: 'private' stamp: 'ar 4/10/2005 23:58'! 443305string: aString 443306 1 to: aString size do: [:j | self pvtAt: j put: (aString at: j) asInteger]. 443307 ^self! ! 443308 443309"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 443310 443311WideSymbol class 443312 instanceVariableNames: ''! 443313 443314!WideSymbol class methodsFor: 'initialization' stamp: 'ar 4/10/2005 23:55'! 443315initialize 443316 Smalltalk removeFromShutDownList: self. "@@@ Remove this later @@@"! ! 443317Object subclass: #WidgetStub 443318 instanceVariableNames: 'spec' 443319 classVariableNames: '' 443320 poolDictionaries: '' 443321 category: 'ToolBuilder-SUnit'! 443322 443323!WidgetStub methodsFor: 'accessing' stamp: 'cwp 5/26/2005 08:48'! 443324name 443325 ^ spec name ifNil: [' ']! ! 443326 443327!WidgetStub methodsFor: 'accessing' stamp: 'cwp 4/25/2005 04:41'! 443328spec 443329 ^ spec! ! 443330 443331!WidgetStub methodsFor: 'accessing' stamp: 'cwp 4/25/2005 03:57'! 443332widgetNamed: aString 443333 ^ self name = aString 443334 ifTrue: [self] 443335 ifFalse: [nil]! ! 443336 443337 443338!WidgetStub methodsFor: 'events' stamp: 'cwp 4/22/2005 22:01'! 443339eventAccessors 443340 ^ #()! ! 443341 443342!WidgetStub methodsFor: 'events' stamp: 'cwp 5/26/2005 08:39'! 443343refresh! ! 443344 443345!WidgetStub methodsFor: 'events' stamp: 'stephaneducasse 2/3/2006 22:32'! 443346update: aSelector 443347 | recognized | 443348 recognized := self eventAccessors collect: [:ea | spec perform: ea]. 443349 (recognized includes: aSelector) 443350 ifTrue: [spec model perform: aSelector]! ! 443351 443352 443353!WidgetStub methodsFor: 'initialization' stamp: 'stephaneducasse 2/3/2006 22:32'! 443354setSpec: aSpec 443355 spec := aSpec. 443356 spec model addDependent: self. 443357 self refresh.! ! 443358 443359 443360!WidgetStub methodsFor: 'printing' stamp: 'cwp 4/25/2005 03:56'! 443361printOn: aStream 443362 aStream 443363 print: self class; 443364 nextPut: $<; 443365 nextPutAll: self name; 443366 nextPut: $>! ! 443367 443368 443369!WidgetStub methodsFor: 'simulating' stamp: 'cwp 4/22/2005 22:30'! 443370model 443371 ^ spec model! ! 443372 443373"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 443374 443375WidgetStub class 443376 instanceVariableNames: ''! 443377 443378!WidgetStub class methodsFor: 'instance creation' stamp: 'cwp 4/22/2005 21:41'! 443379fromSpec: aSpec 443380 ^ self new setSpec: aSpec! ! 443381OSPlatform subclass: #Win32Platform 443382 instanceVariableNames: '' 443383 classVariableNames: '' 443384 poolDictionaries: '' 443385 category: 'System-Platforms'! 443386 443387!Win32Platform methodsFor: 'accessing' stamp: 'michael.rueger 2/25/2009 18:18'! 443388platformFamily 443389 ^#Windows! ! 443390 443391"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 443392 443393Win32Platform class 443394 instanceVariableNames: ''! 443395 443396!Win32Platform class methodsFor: 'accessing' stamp: 'michael.rueger 3/2/2009 11:20'! 443397virtualKey: virtualKeyCode 443398 "Win32Platform virtualKey: $C charCode" 443399 443400 (virtualKeyCode <= 90 "$Z charCode" 443401 and: [virtualKeyCode >= 65 "$A "]) 443402 ifFalse: [^nil]. 443403 "#($a $b $c $d $e $f $g $h $i $j $k $l $m $n $o $p $q $r $s $t $u $v $w $x $y $z)" 443404 443405 ^(#($a nil $c $d nil $f $g nil nil nil nil $l $m $n nil $p nil nil $s nil nil $v nil $x nil $z) 443406 at: virtualKeyCode-64) ifNotNil: [:char | char charCode]! ! 443407 443408 443409!Win32Platform class methodsFor: 'private' stamp: 'michael.rueger 2/25/2009 18:22'! 443410isActivePlatform 443411 "Answer whether the receiver is the active platform" 443412 ^SmalltalkImage current platformName = 'Win32'! ! 443413Object subclass: #WindowColorRegistry 443414 instanceVariableNames: '' 443415 classVariableNames: '' 443416 poolDictionaries: '' 443417 category: 'System-Support'! 443418!WindowColorRegistry commentStamp: 'hpt 10/9/2005 22:54' prior: 0! 443419I provide to the applications developer a place where they can register their WindowColorSpecification for their application's windows. 443420! 443421 443422 443423!WindowColorRegistry methodsFor: 'notes' stamp: 'hpt 10/9/2005 22:54'! 443424seeClassSide 443425 "All the code for WindowColorRegistry is on the class side."! ! 443426 443427"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 443428 443429WindowColorRegistry class 443430 instanceVariableNames: 'registry'! 443431 443432!WindowColorRegistry class methodsFor: 'registry' stamp: 'hpt 10/9/2005 23:11'! 443433initialize 443434 self refresh.! ! 443435 443436!WindowColorRegistry class methodsFor: 'registry' stamp: 'sd 9/14/2006 20:07'! 443437refresh 443438 "This is a one-time only method for bootstraping the new registry. Here we will scan all classes for #windowColorSpecification methods and register those to the registry" 443439 443440 registry := nil. 443441 ((self systemNavigation allClassesImplementing: #windowColorSpecification) 443442 collect: [:aClass | aClass theNonMetaClass windowColorSpecification]) 443443 do: [:spec | self registerColorSpecification: spec toClassNamed: spec classSymbol ].! ! 443444 443445!WindowColorRegistry class methodsFor: 'registry' stamp: 'hpt 10/9/2005 23:08'! 443446registerColorSpecification: aColorSpec toClassNamed: aClassName 443447 self registry at: aClassName asSymbol put: aColorSpec.! ! 443448 443449!WindowColorRegistry class methodsFor: 'registry' stamp: 'hpt 10/9/2005 23:23'! 443450registeredWindowColorSpecFor: aClassName 443451 "Return the Window Color Spec for the given class. " 443452 ^self registry at: aClassName asSymbol ifAbsent: []. 443453! ! 443454 443455!WindowColorRegistry class methodsFor: 'registry' stamp: 'hpt 10/9/2005 23:17'! 443456registeredWindowColorSpecs 443457 ^self registry values! ! 443458 443459!WindowColorRegistry class methodsFor: 'registry' stamp: 'sd 9/14/2006 20:11'! 443460registry 443461 ^registry ifNil: [registry := Dictionary new].! ! 443462 443463!WindowColorRegistry class methodsFor: 'registry' stamp: 'sd 9/14/2006 20:11'! 443464unregisterColorSpecificationForClassNamed: aClassName 443465 443466 self registry removeKey: aClassName asSymbol ! ! 443467Object subclass: #WindowColorSpec 443468 instanceVariableNames: 'classSymbol wording brightColor pastelColor helpMessage' 443469 classVariableNames: '' 443470 poolDictionaries: '' 443471 category: 'Morphic-Windows'! 443472 443473!WindowColorSpec methodsFor: 'access' stamp: 'sw 2/26/2002 15:00'! 443474brightColor 443475 "Answer the brightColor" 443476 443477 ^ brightColor! ! 443478 443479!WindowColorSpec methodsFor: 'access' stamp: 'sw 2/26/2002 14:59'! 443480classSymbol 443481 "Answer the classSymbol" 443482 443483 ^ classSymbol! ! 443484 443485!WindowColorSpec methodsFor: 'access' stamp: 'sw 2/26/2002 15:00'! 443486helpMessage 443487 "Answer the helpMessage" 443488 443489 ^ helpMessage! ! 443490 443491!WindowColorSpec methodsFor: 'access' stamp: 'sw 2/26/2002 15:00'! 443492pastelColor 443493 "Answer the pastelColor" 443494 443495 ^ pastelColor! ! 443496 443497!WindowColorSpec methodsFor: 'access' stamp: 'sw 2/26/2002 14:59'! 443498wording 443499 "Answer the wording" 443500 443501 ^ wording! ! 443502 443503 443504!WindowColorSpec methodsFor: 'initialization' stamp: 'sw 2/26/2002 13:39'! 443505classSymbol: sym wording: wrd brightColor: brCol pastelColor: paCol helpMessage: hlpMsg 443506 "Initialize the receiver's instance variables" 443507 443508 classSymbol := sym. 443509 wording := wrd. 443510 brightColor := brCol. 443511 pastelColor := paCol. 443512 helpMessage := hlpMsg! ! 443513 443514 443515!WindowColorSpec methodsFor: 'printing' stamp: 'sw 4/21/2002 07:42'! 443516printOn: aStream 443517 "Print the receiver on a stream" 443518 443519 super printOn: aStream. 443520 classSymbol printOn: aStream. 443521 aStream nextPutAll: ' bright: ', brightColor printString, ' pastel: ', pastelColor printString! ! 443522 443523"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 443524 443525WindowColorSpec class 443526 instanceVariableNames: ''! 443527 443528!WindowColorSpec class methodsFor: 'instance creation' stamp: 'sw 2/26/2002 13:40'! 443529classSymbol: sym wording: wrd brightColor: brCol pastelColor: paCol helpMessage: hlpMsg 443530 "Answer a new instance of the receiver with the given slots filled in" 443531 443532 ^ self new classSymbol: sym wording: wrd brightColor: brCol pastelColor: paCol helpMessage: hlpMsg! ! 443533EdgeGripMorph subclass: #WindowEdgeGripMorph 443534 instanceVariableNames: '' 443535 classVariableNames: '' 443536 poolDictionaries: '' 443537 category: 'Polymorph-Widgets'! 443538!WindowEdgeGripMorph commentStamp: 'gvc 9/23/2008 11:47' prior: 0! 443539Window edge gripper allowing resizing of a window by a particular side.! 443540 443541 443542!WindowEdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/5/2007 15:11'! 443543mouseDown: anEvent 443544 "Activate the window if not currently so." 443545 443546 (self bounds containsPoint: anEvent cursorPoint) 443547 ifTrue: [self window ifNotNilDo: [:w | w activate]]. 443548 ^super mouseDown: anEvent! ! 443549 443550!WindowEdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:17'! 443551normalFillStyle 443552 "Return the normal fillStyle of the receiver." 443553 443554 ^self theme windowEdgeNormalFillStyleFor: self! ! 443555 443556!WindowEdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:17'! 443557pressedFillStyle 443558 "Return the pressed fillStyle of the receiver." 443559 443560 ^self theme windowEdgePressedFillStyleFor: self! ! 443561MorphicEvent subclass: #WindowEvent 443562 instanceVariableNames: 'action rectangle' 443563 classVariableNames: '' 443564 poolDictionaries: '' 443565 category: 'Morphic-Events'! 443566 443567!WindowEvent methodsFor: 'accessing' stamp: 'JMM 10/6/2004 21:11'! 443568action 443569 ^action! ! 443570 443571!WindowEvent methodsFor: 'accessing' stamp: 'JMM 10/6/2004 21:10'! 443572action: aValue 443573 action := aValue.! ! 443574 443575!WindowEvent methodsFor: 'accessing' stamp: 'JMM 10/6/2004 21:12'! 443576rectangle 443577 ^rectangle! ! 443578 443579!WindowEvent methodsFor: 'accessing' stamp: 'JMM 10/6/2004 21:12'! 443580rectangle: aValue 443581 rectangle := aValue.! ! 443582 443583 443584!WindowEvent methodsFor: 'as yet unclassified' stamp: 'JMM 10/6/2004 21:22'! 443585type 443586 ^#windowEvent! ! 443587 443588 443589!WindowEvent methodsFor: 'testing' stamp: 'JMM 10/6/2004 21:35'! 443590isWindowEvent 443591 ^true! ! 443592CompositeStub subclass: #WindowStub 443593 instanceVariableNames: '' 443594 classVariableNames: '' 443595 poolDictionaries: '' 443596 category: 'ToolBuilder-SUnit'! 443597 443598!WindowStub methodsFor: 'events' stamp: 'cwp 4/25/2005 03:50'! 443599eventAccessors 443600 ^ super eventAccessors, #(label)! ! 443601 443602 443603!WindowStub methodsFor: 'simulating' stamp: 'cwp 7/14/2006 10:58'! 443604close 443605 spec model perform: spec closeAction! ! 443606ArrayedCollection variableWordSubclass: #WordArray 443607 instanceVariableNames: '' 443608 classVariableNames: '' 443609 poolDictionaries: '' 443610 category: 'Collections-Arrayed'! 443611!WordArray commentStamp: '<historical>' prior: 0! 443612WordArrays store 32-bit unsigned Integer values. 443613! 443614 443615 443616!WordArray methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:47'! 443617atAllPut: value 443618 "Fill the receiver with the given value" 443619 443620 <primitive: 145> 443621 super atAllPut: value! ! 443622 443623!WordArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:18'! 443624byteSize 443625 ^self size * 4! ! 443626 443627!WordArray methodsFor: 'accessing' stamp: 'tk 3/13/2000 14:46'! 443628bytesPerElement 443629 "Number of bytes in each item. This multiplied by (self size)*8 gives the number of bits stored." 443630 ^ 4! ! 443631 443632!WordArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! 443633defaultElement 443634 "Return the default element of the receiver" 443635 ^0! ! 443636 443637 443638!WordArray methodsFor: 'array arithmetic' stamp: 'yo 10/25/2004 15:52'! 443639* other 443640 443641 | result | 443642 other isNumber ifTrue: [ 443643 other isFloat ifTrue: [ 443644 result := KedamaFloatArray new: self size. 443645 ^ self primMulScalar: self and: other into: result. 443646 ] ifFalse: [ 443647 result := WordArray new: self size. 443648 ^ self primMulScalar: self and: other into: result. 443649 ]. 443650 ]. 443651 (other isMemberOf: WordArray) ifTrue: [ 443652 result := WordArray new: self size. 443653 ^ self primMulArray: self and: other into: result. 443654 ]. 443655 (other isMemberOf: KedamaFloatArray) ifTrue: [ 443656 result := KedamaFloatArray new: self size. 443657 ^ self primMulArray: self and: other into: result. 443658 ]. 443659 ^ super * other. 443660! ! 443661 443662!WordArray methodsFor: 'array arithmetic' stamp: 'yo 10/25/2004 14:58'! 443663+ other 443664 443665 | result | 443666 other isNumber ifTrue: [ 443667 other isFloat ifTrue: [ 443668 result := KedamaFloatArray new: self size. 443669 ^ self primAddScalar: self and: other into: result. 443670 ] ifFalse: [ 443671 result := WordArray new: self size. 443672 ^ self primAddScalar: self and: other into: result. 443673 ]. 443674 ]. 443675 (other isMemberOf: WordArray) ifTrue: [ 443676 result := WordArray new: self size. 443677 ^ self primAddArray: self and: other into: result. 443678 ]. 443679 (other isMemberOf: KedamaFloatArray) ifTrue: [ 443680 result := KedamaFloatArray new: self size. 443681 ^ self primAddArray: self and: other into: result. 443682 ]. 443683 ^ super + other. 443684! ! 443685 443686!WordArray methodsFor: 'array arithmetic' stamp: 'yo 10/25/2004 15:52'! 443687- other 443688 443689 | result | 443690 other isNumber ifTrue: [ 443691 other isFloat ifTrue: [ 443692 result := KedamaFloatArray new: self size. 443693 ^ self primSubScalar: self and: other into: result. 443694 ] ifFalse: [ 443695 result := WordArray new: self size. 443696 ^ self primSubScalar: self and: other into: result. 443697 ]. 443698 ]. 443699 (other isMemberOf: WordArray) ifTrue: [ 443700 result := WordArray new: self size. 443701 ^ self primSubArray: self and: other into: result. 443702 ]. 443703 (other isMemberOf: KedamaFloatArray) ifTrue: [ 443704 result := KedamaFloatArray new: self size. 443705 ^ self primSubArray: self and: other into: result. 443706 ]. 443707 ^ super - other. 443708! ! 443709 443710!WordArray methodsFor: 'array arithmetic' stamp: 'yo 10/25/2004 15:53'! 443711/ other 443712 443713 | result | 443714 other isNumber ifTrue: [ 443715 other isFloat ifTrue: [ 443716 result := KedamaFloatArray new: self size. 443717 ^ self primDivScalar: self and: other into: result. 443718 ] ifFalse: [ 443719 result := WordArray new: self size. 443720 ^ self primDivScalar: self and: other into: result. 443721 ]. 443722 ]. 443723 (other isMemberOf: WordArray) ifTrue: [ 443724 result := WordArray new: self size. 443725 ^ self primDivArray: self and: other into: result. 443726 ]. 443727 (other isMemberOf: KedamaFloatArray) ifTrue: [ 443728 result := KedamaFloatArray new: self size. 443729 ^ self primDivArray: self and: other into: result. 443730 ]. 443731 ^ super / other. 443732! ! 443733 443734 443735!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:50'! 443736primAddArray: rcvr and: other into: result 443737 443738 <primitive: 'primitiveAddArrays' module:'KedamaPlugin'> 443739 "^ KedamaPlugin doPrimitive: #primitiveAddArrays." 443740 443741 1 to: rcvr size do: [:i | 443742 result at: i put: (rcvr at: i) + (other at: i) 443743 ]. 443744 ^ result. 443745! ! 443746 443747!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:10'! 443748primAddScalar: rcvr and: other into: result 443749 443750 <primitive: 'primitiveAddScalar' module:'KedamaPlugin'> 443751 "^ KedamaPlugin doPrimitive: #primitiveAddScalar." 443752 443753 1 to: rcvr size do: [:i | 443754 result at: i put: (rcvr at: i) + other. 443755 ]. 443756 ^ result. 443757! ! 443758 443759!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:51'! 443760primDivArray: rcvr and: other into: result 443761 443762 <primitive: 'primitiveDivArrays' module:'KedamaPlugin'> 443763 "^ KedamaPlugin doPrimitive: #primitiveDivArrays." 443764 443765 1 to: rcvr size do: [:i | 443766 result at: i put: (rcvr at: i) / (other at: i) 443767 ]. 443768 ^ result. 443769! ! 443770 443771!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:49'! 443772primDivScalar: rcvr and: other into: result 443773 443774 <primitive: 'primitiveDivScalar' module:'KedamaPlugin'> 443775 "^ KedamaPlugin doPrimitive: #primitiveDivScalar." 443776 443777 1 to: rcvr size do: [:i | 443778 result at: i put: (rcvr at: i) / other. 443779 ]. 443780 ^ result. 443781! ! 443782 443783!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:51'! 443784primMulArray: rcvr and: other into: result 443785 443786 <primitive: 'primitiveMulArrays' module:'KedamaPlugin'> 443787 "^ KedamaPlugin doPrimitive: #primitiveMulArrays." 443788 443789 1 to: rcvr size do: [:i | 443790 result at: i put: (rcvr at: i) * (other at: i) 443791 ]. 443792 ^ result. 443793! ! 443794 443795!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:49'! 443796primMulScalar: rcvr and: other into: result 443797 443798 <primitive: 'primitiveMulScalar' module:'KedamaPlugin'> 443799 "^ KedamaPlugin doPrimitive: #primitiveMulScalar." 443800 443801 1 to: rcvr size do: [:i | 443802 result at: i put: (rcvr at: i) * other. 443803 ]. 443804 ^ result. 443805! ! 443806 443807!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:50'! 443808primSubArray: rcvr and: other into: result 443809 443810 <primitive: 'primitiveSubArrays' module:'KedamaPlugin'> 443811 "^ KedamaPlugin doPrimitive: #primitiveSubArrays." 443812 443813 1 to: rcvr size do: [:i | 443814 result at: i put: (rcvr at: i) - (other at: i) 443815 ]. 443816 ^ result. 443817! ! 443818 443819!WordArray methodsFor: 'array arithmetic primitives' stamp: 'yo 10/25/2004 15:49'! 443820primSubScalar: rcvr and: other into: result 443821 443822 <primitive: 'primitiveSubScalar' module:'KedamaPlugin'> 443823 "^ KedamaPlugin doPrimitive: #primitiveSubScalar." 443824 443825 1 to: rcvr size do: [:i | 443826 result at: i put: (rcvr at: i) - other. 443827 ]. 443828 ^ result. 443829! ! 443830 443831 443832!WordArray methodsFor: 'converting' stamp: 'ar 9/14/1998 23:46'! 443833asWordArray 443834 ^self! ! 443835 443836 443837!WordArray methodsFor: 'private' stamp: 'ar 2/15/1999 00:51'! 443838replaceFrom: start to: stop with: replacement startingAt: repStart 443839 <primitive: 105> 443840 ^super replaceFrom: start to: stop with: replacement startingAt: repStart ! ! 443841 443842"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 443843 443844WordArray class 443845 instanceVariableNames: ''! 443846 443847!WordArray class methodsFor: 'as yet unclassified' stamp: 'RAA 5/17/2001 16:07'! 443848bobsTest 443849 | wa s1 s2 wa2 answer rawData | 443850" 443851WordArray bobsTest 443852" 443853 answer := OrderedCollection new. 443854 wa := WordArray with: 16r01020304 with: 16r05060708. 443855 {false. true} do: [ :pad | 443856 0 to: 3 do: [ :skip | 443857 s1 := RWBinaryOrTextStream on: ByteArray new. 443858 443859 s1 next: skip put: 0. "start at varying positions" 443860 wa writeOn: s1. 443861 pad ifTrue: [s1 next: 4-skip put: 0]. "force length to be multiple of 4" 443862 443863 rawData := s1 contents. 443864 s2 := RWBinaryOrTextStream with: rawData. 443865 s2 reset. 443866 s2 skip: skip. "get to beginning of object" 443867 wa2 := WordArray newFromStream: s2. 443868 answer add: { 443869 rawData size. 443870 skip. 443871 wa2 = wa. 443872 wa2 asArray collect: [ :each | each radix: 16] 443873 } 443874 ]. 443875 ]. 443876 ^answer explore! ! 443877WordArray variableWordSubclass: #WordArrayForSegment 443878 instanceVariableNames: '' 443879 classVariableNames: '' 443880 poolDictionaries: '' 443881 category: 'Collections-Arrayed'! 443882 443883!WordArrayForSegment methodsFor: 'as yet unclassified' stamp: 'tk 1/24/2000 23:22'! 443884restoreEndianness 443885 "This word object was just read in from a stream. Do not correct the Endianness because the load primitive will reverse bytes as needed." 443886 443887 "^ self" 443888! ! 443889 443890!WordArrayForSegment methodsFor: 'as yet unclassified' stamp: 'tk 1/24/2000 23:22'! 443891writeOn: aByteStream 443892 "Write quickly and disregard the endianness of the words. Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed)." 443893 443894 aByteStream nextInt32Put: self size. "4 bytes" 443895 aByteStream nextPutAll: self 443896! ! 443897BorderedMorph subclass: #WorkAreaMorph 443898 instanceVariableNames: '' 443899 classVariableNames: '' 443900 poolDictionaries: '' 443901 category: 'Polymorph-Widgets'! 443902!WorkAreaMorph commentStamp: 'gvc 5/18/2007 09:56' prior: 0! 443903This class is designed to be used as the container for morphs that are placed at absolute positions and is placed within a scroller. 443904An example would be the background behind a page view in a word processor. 443905Optimises #layoutChanged to not propagate to owner (assumed to be in a scroller).! 443906 443907 443908!WorkAreaMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 14:24'! 443909adoptPaneColor: paneColor 443910 "Make the receiver's color a bit whiter than the pane color." 443911 443912 super adoptPaneColor: paneColor. 443913 paneColor ifNil: [^self]. 443914 self color: (paneColor alphaMixed: 0.4 with: Color white)! ! 443915 443916!WorkAreaMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/30/2006 10:16'! 443917layoutChanged 443918 "Don't pass to owner, since the receiver doesn't care!! Improves frame rate." 443919 443920 fullBounds := nil. 443921 self layoutPolicy ifNotNilDo:[:l | l flushLayoutCache].! ! 443922StringHolder subclass: #Workspace 443923 instanceVariableNames: 'bindings acceptDroppedMorphs acceptAction mustDeclareVariables' 443924 classVariableNames: 'LastContents' 443925 poolDictionaries: '' 443926 category: 'Tools-Base'! 443927!Workspace commentStamp: 'ls 10/14/2003 12:13' prior: 0! 443928A Workspace is a text area plus a lot of support for executable code. It is a great place to execute top-level commands to compute something useful, and it is a great place to develop bits of a program before those bits get put into class methods. 443929 443930To open a new workspace, execute: 443931 443932 Workspace open 443933 443934 443935A workspace can have its own variables, called "workspace variables", to hold intermediate results. For example, if you type into a workspace "x := 5" and do-it, then later you could type in "y := x * 2" and y would become 10. 443936 443937Additionally, in Morphic, a workspace can gain access to morphs that are on the screen. If acceptDroppedMorphss is turned on, then whenever a morph is dropped on the workspace, a variable will be created which references that morph. This functionality is toggled with the window-wide menu of a workspace. 443938 443939 443940The instance variables of this class are: 443941 443942 bindings - holds the workspace variables for this workspace 443943 443944 acceptDroppedMorphss - whether dropped morphs should create new variables! 443945 443946 443947!Workspace methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:56'! 443948acceptAction 443949 ^acceptAction! ! 443950 443951!Workspace methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:56'! 443952acceptAction: anAction 443953 acceptAction := anAction.! ! 443954 443955!Workspace methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:58'! 443956acceptContents: aString 443957 acceptAction ifNotNil:[acceptAction value: aString]. 443958 ^super acceptContents: aString.! ! 443959 443960!Workspace methodsFor: 'accessing' stamp: 'AlexandreBergel 1/16/2009 10:33'! 443961lastContents 443962 LastContents ifNil: [LastContents := OrderedCollection new]. 443963 ^ LastContents! ! 443964 443965!Workspace methodsFor: 'accessing' stamp: 'sd 3/20/2004 15:17'! 443966mustDeclareVariables: aBoolean 443967 443968 mustDeclareVariables := aBoolean! ! 443969 443970!Workspace methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! 443971setBindings: aDictionary 443972 "Sets the Workspace to use the specified dictionary as its namespace" 443973 443974 bindings := aDictionary. 443975! ! 443976 443977 443978!Workspace methodsFor: 'as yet unclassified' stamp: 'em 3/24/2005 11:21'! 443979acceptDroppedMorphsWording 443980 443981 ^ self acceptsDroppingMorphForReference 443982 ifTrue: ['<yes> create textual references to dropped morphs' translated] 443983 ifFalse: ['<no> create textual references to dropped morphs' translated] 443984! ! 443985 443986 443987!Workspace methodsFor: 'binding' stamp: 'sd 3/20/2004 15:20'! 443988bindingOf: aString 443989 443990 mustDeclareVariables ifTrue: [^ nil]. 443991 "I want to have workspace that force the user to declare 443992 variables. Still subclasses may want to do something else" 443993 bindings isNil 443994 ifTrue: [self initializeBindings]. 443995 (bindings includesKey: aString) 443996 ifFalse: [bindings at: aString put: nil]. 443997 ^ bindings associationAt: aString! ! 443998 443999!Workspace methodsFor: 'binding' stamp: 'sd 3/20/2004 14:31'! 444000initializeBindings 444001 444002 bindings := Dictionary new! ! 444003 444004 444005!Workspace methodsFor: 'configuration' stamp: 'AlexandreBergel 1/16/2009 10:32'! 444006historyLength 444007 "Number of contents being stored" 444008 ^ 5! ! 444009 444010 444011!Workspace methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:27'! 444012acceptDroppingMorph: dropee event: evt inMorph: targetMorph 444013 "Return the dropee to its old position, and add a reference to it at the cursor point." 444014 444015 | bindingName externalName | 444016 externalName := dropee externalName. 444017 externalName := externalName isOctetString 444018 ifTrue: [externalName] ifFalse: ['a' , externalName]. 444019 bindingName := externalName translateToLowercase, dropee identityHash printString. 444020 targetMorph correctSelectionWithString: bindingName, ' '. 444021 (self bindingOf: bindingName) value: dropee. 444022 dropee rejectDropMorphEvent: evt. 444023 ^ true "success" 444024! ! 444025 444026!Workspace methodsFor: 'drag and drop' stamp: 'jcg 7/8/2000 00:10'! 444027acceptsDroppingMorphForReference 444028 444029 ^ acceptDroppedMorphs 444030 444031! ! 444032 444033!Workspace methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:27'! 444034acceptsDroppingMorphForReference: trueFalse 444035 444036 acceptDroppedMorphs := trueFalse 444037 444038! ! 444039 444040!Workspace methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:27'! 444041toggleDroppingMorphForReference 444042 444043 acceptDroppedMorphs := acceptDroppedMorphs not. 444044 444045! ! 444046 444047!Workspace methodsFor: 'drag and drop' stamp: 'jcg 7/7/2000 11:16'! 444048wantsDroppedMorph: dropee event: evt inMorph: target 444049 444050 ^ acceptDroppedMorphs 444051 444052! ! 444053 444054 444055!Workspace methodsFor: 'history' stamp: 'AlexandreBergel 1/16/2009 10:36'! 444056okToChange 444057 "This method is called by SystemWindow just before closing a workspace window. 444058 The caller of this method is SystemWindow>>delete" 444059 444060 | textMorphs textMorph contentAsString | 444061 textMorphs := self dependents select: [:c | c isKindOf: PluggableTextMorph]. 444062 textMorphs ifEmpty: [ ^ true ]. "This case should normally not happen" 444063 444064 textMorph := textMorphs first. 444065 contentAsString := (textMorph text) asString. 444066 self lastContents addFirst: contentAsString. 444067 self trimHistoryIfNecessary. 444068 ^ true! ! 444069 444070!Workspace methodsFor: 'history' stamp: 'AlexandreBergel 1/16/2009 17:05'! 444071selectPreviousContent 444072 444073 | trimmedContents newContentOrNil | 444074 trimmedContents := self lastContents collect: [:c | c copyFrom: 1 to: (c size min: 20)]. 444075 newContentOrNil := UIManager default chooseFrom: trimmedContents values: self lastContents. 444076 444077 "newContentOrNil may be nil if the user cancel" 444078 newContentOrNil ifNil: [ newContentOrNil := '' ]. 444079 444080 self setContent: newContentOrNil! ! 444081 444082!Workspace methodsFor: 'history' stamp: 'AlexandreBergel 1/16/2009 16:53'! 444083setContent: aString 444084 | textMorphs textMorph | 444085 textMorphs := self dependents select: [:c | c isKindOf: PluggableTextMorph]. 444086 textMorphs ifEmpty: [ ^ true ]. "This case should normally not happen" 444087 444088 textMorph := textMorphs first. 444089 textMorph setText: aString! ! 444090 444091!Workspace methodsFor: 'history' stamp: 'AlexandreBergel 1/16/2009 10:35'! 444092trimHistoryIfNecessary 444093 (self lastContents size > self historyLength) 444094 ifTrue: [ LastContents := LastContents copyFrom: 1 to: self historyLength ]! ! 444095 444096 444097!Workspace methodsFor: 'initialization' stamp: 'md 3/7/2006 10:25'! 444098embeddedInMorphicWindowLabeled: labelString 444099 | window pane | 444100 window := (SystemWindow labelled: labelString) model: self. 444101 pane := PluggableTextMorph on: self text: #contents accept: #acceptContents: 444102 readSelection: nil menu: #codePaneMenu:shifted:. 444103 pane font: Preferences standardCodeFont. 444104 window addMorph: pane frame: (0@0 corner: 1@1). 444105 ^ window! ! 444106 444107!Workspace methodsFor: 'initialization' stamp: 'wiz 2/13/2006 21:18'! 444108initialExtent 444109 "Start small. Window aspect ratio is 5 sqrt::1 . Good asthetics. -wiz" 444110 444111 ^ 447@200! ! 444112 444113!Workspace methodsFor: 'initialization' stamp: 'sd 3/20/2004 14:36'! 444114initialize 444115 444116 super initialize. 444117 acceptDroppedMorphs := false. 444118 mustDeclareVariables := false! ! 444119 444120 444121!Workspace methodsFor: 'menu commands' stamp: 'AlexandreBergel 1/16/2009 10:43'! 444122addModelItemsToWindowMenu: aMenu 444123 aMenu addLine. 444124 aMenu 444125 add: 'reset variables' 444126 target: self 444127 action: #initializeBindings. 444128 aMenu 444129 addUpdating: #mustDeclareVariableWording 444130 target: self 444131 action: #toggleVariableDeclarationMode. 444132 aMenu 444133 addUpdating: #acceptDroppedMorphsWording 444134 target: self 444135 action: #toggleDroppingMorphForReference. 444136 444137 aMenu 444138 add: 'previous contents...' 444139 target: self 444140 selector: #selectPreviousContent! ! 444141 444142!Workspace methodsFor: 'menu commands' stamp: 'hfm 11/29/2008 20:05'! 444143appendContentsOfFile 444144 "Prompt for a file, and if one is obtained, append its contents to the contents of the receiver. Caution: as currently implemented this abandons any custom style information previously in the workspace. Someone should fix this. Also, for best results you should accept the contents of the workspace before requesting this." 444145 444146 | aFileStream | 444147 (aFileStream := FileList modalFileSelector) ifNil: [^ self]. 444148 contents := (contents ifNil: ['']) asString, aFileStream contentsOfEntireFile. 444149 aFileStream close. 444150 self changed: #contents! ! 444151 444152 444153!Workspace methodsFor: 'variable declarations' stamp: 'sumim 11/26/2006 03:52'! 444154mustDeclareVariableWording 444155 444156 ^ mustDeclareVariables 444157 ifTrue: ['<yes> automatically create variable declaration' translated] 444158 ifFalse: ['<no> automatically create variable declaration' translated]! ! 444159 444160!Workspace methodsFor: 'variable declarations' stamp: 'sd 3/20/2004 14:39'! 444161toggleVariableDeclarationMode 444162 444163 mustDeclareVariables := mustDeclareVariables not! ! 444164 444165"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 444166 444167Workspace class 444168 instanceVariableNames: ''! 444169 444170!Workspace class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! 444171prototypicalToolWindow 444172 "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" 444173 444174 | aWorkspace | 444175 aWorkspace := self new embeddedInMorphicWindowLabeled: 'Workspace'. 444176 aWorkspace applyModelExtent. 444177 ^ aWorkspace! ! 444178ServiceProvider subclass: #WorldMenuProvider 444179 instanceVariableNames: '' 444180 classVariableNames: '' 444181 poolDictionaries: '' 444182 category: 'Services-Base-Providers'! 444183!WorldMenuProvider commentStamp: 'rr 7/10/2006 15:19' prior: 0! 444184I define services and categories: 444185- The world menu category (identifier: world), where services and categories can be put to be displayed in the world menu. 444186- The preferencesMenu category, where services about services and preferences can be put 444187- th open menu! 444188 444189 444190!WorldMenuProvider methodsFor: 'accessing' stamp: 'rr 7/10/2006 16:00'! 444191servicesHelpText 444192 ^ ' 444193 This is an overview of the main concepts of the services framework. More details are available in class comments. The aim is to help you defining services step by step. The three main classes are: 444194 444195-ServiceAction 444196-ServiceCategory 444197-ServiceProvider 444198 444199Alongside them, a tool to use is the Services Browser. It can be found in the world menu, under the ''Preferences & Services'' menu heading (in which you found this text). 444200 444201 ServiceAction are executable objects in various contexts. 444202They can be displayed as buttons or menu items or bounded to keyboard shortcuts. 444203 444204 ServiceCategory are categories of services. They are also services, so a ServiceCategory can be included in another, forming a tree of Services. ServiceCategories can be displayed with menus, or button bars. 444205 444206 A ServiceProvider references services that are relevant to a given application. 444207Each application that wishes to use the Services framework must subclass a ServiceProvider. 444208This class must define a ''services'' method category. 444209Each method implemented in this category will be automatically called by the framework. 444210Each of these method should be a unary message (taking no argument), and return a fully initialised instance of ServiceAction or ServiceCategory. There are three possible patterns: 444211 4442121) 444213serviceIdentifierAndMethodName 444214 ^ ServiceAction 444215 text: ''Menu item text'' 444216 button:''Button text'' 444217 description: ''Longer text that appears in help balloons'' 444218 action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"] 444219 4442202) 444221serviceIdentifierAndMethodName 444222 ^ ServiceAction 444223 text: ''Menu item text'' 444224 button: ''Button text'' 444225 description: ''Longer text that appears in help balloons'' 444226 action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"] 444227 condition: [:r | "second block returning true if the service can be used at the time being, false otherwise. Data can still be fetched from the requestor instance"] 444228 4442293) 444230methodNameAndServiceCategoryId 444231 ^ ServiceCategory 444232 text: ''Menu text'' 444233 button: ''Button text'' 444234 description: ''Longer descriptive text appearing in help balloons'' 444235 444236The block given to the ServiceActions can take an instance of the Requestor class as parameter. You can fetch data from these. The generic format is to call methods starting with ''get'' on the requestor, like getClass, getMessageName for services related to the browser. 444237 444238The organisation of services into categories, and the services bound to keyboard shortcuts are 444239specified using the Services Browser, based on the Preference Browser by Hernan Tylim. When editing preferences, they are saved as methods on the ServiceProvider, all defined in the ''saved preferences'' method category. 444240 444241When opening the Services Browser you see a list of preference categories on the left, and the preferences inside this category on the right. The main preference categories for services are: 444242 444243-- keyboard shortcuts -- : several text preferences, one per keyboard shortcuts. To edit them, enter a service identifier (equal to the method name under which it is defined in its ServiceProvider), and accept with alt-s or enter 444244 444245-- menu contents -- : All the service categories in the image have a text preference under here. To edit it, enter the services identifiers you wish to put in this category, separating them with a single space character. The order is important: it defines the order of the items in menus. 444246 444247-- settings -- : general boolean preferences. 444248 444249Then there is a preference category for each provider in the image. Under each, you will find: 444250A boolean preference for each service in the image. If it is false, the service will not appear in menus. 444251The text preference for each service category defined by the service provider. This is the same as the one appearing in the menu contents preference category. 444252 444253Some identifiers of categories already appearing in the UI are: 444254- world : the world menu 444255- preferencesMenu 444256- browserClasssCategoryMenu 444257- browserClassMenu 444258- browserMethodCategoryMenu 444259- browserMethodMenu 444260- browserCodePaneMenu 444261- browserButtonBar 444262 444263After editing these preferences to match the services and categories you defined for your application, you should be done. 444264 444265 Romain Robbes'! ! 444266 444267 444268!WorldMenuProvider methodsFor: 'saved preferences'! 444269browserMethodMenucreateNewService 444270 ^ #(#'Items in browserMethodMenu:' #createNewService 1 )! ! 444271 444272!WorldMenuProvider methodsFor: 'saved preferences'! 444273preferencesMenuhelpOnServices 444274 ^ #(#'Items in preferencesMenu:' #helpOnServices 3 )! ! 444275 444276!WorldMenuProvider methodsFor: 'saved preferences'! 444277preferencesMenupreferencesBrowser 444278 ^ #(#'Items in preferencesMenu:' #preferencesBrowser 1 )! ! 444279 444280!WorldMenuProvider methodsFor: 'saved preferences'! 444281preferencesMenurebuildRegistry 444282 ^ #(#'Items in preferencesMenu:' #rebuildRegistry 4 )! ! 444283 444284!WorldMenuProvider methodsFor: 'saved preferences'! 444285preferencesMenuservicesBrowser 444286 ^ #(#'Items in preferencesMenu:' #servicesBrowser 2 )! ! 444287 444288!WorldMenuProvider methodsFor: 'saved preferences'! 444289preferencesMenushortcut 444290 ^ #(#'Shortcut for preferencesMenu:' '' 1000 )! ! 444291 444292!WorldMenuProvider methodsFor: 'saved preferences'! 444293worldpreferencesMenu 444294 ^ #(#'Items in world:' #preferencesMenu 1 )! ! 444295 444296!WorldMenuProvider methodsFor: 'saved preferences'! 444297worldshortcut 444298 ^ #(#'Shortcut for world:' '' 1000 )! ! 444299 444300 444301!WorldMenuProvider methodsFor: 'service registering' stamp: 'rr 3/25/2005 14:23'! 444302convertOpenCommand: array 444303 | description | 444304 description := array size > 2 444305 ifTrue: [array third] 444306 ifFalse: ['none available']. 444307 ^ServiceAction 444308 id: array first asSymbol 444309 text: array first 444310 button: array first 444311 description: description 444312 action: [array second first perform: array second second]! ! 444313 444314 444315!WorldMenuProvider methodsFor: 'services' stamp: 'rr 3/11/2006 19:11'! 444316closeTopWindow 444317 ^ ServiceAction 444318 text: 'Close top window' 444319 button: 'close window' 444320 description: 'Closes the focused window' 444321 action: [:r | SystemWindow topWindow delete]! ! 444322 444323!WorldMenuProvider methodsFor: 'services' stamp: 'rr 1/10/2006 10:41'! 444324createNewService 444325 ^ ServiceAction 444326 text: 'Create new service' 444327 button: 'new service' 444328 description: 'Define a new service provided by this package' 444329 action: [:r | | s p | 444330 s := r caption: 'enter service identifier'; getSymbol. 444331 p := r getPackageProvider. 444332 p compile: s, ' 444333 ^ ServiceAction 444334 "Open the service browser to set the menu position and the keyboard shortcut" 444335 text: ''fill menu label'' 444336 button: ''short button text'' 444337 description: ''longer text for balloon help'' 444338 action: [:r | "action block"] 444339 condition: [:r | "optional condition block"]' classified: 'services'. 444340 r getBrowser browseReference: (MethodReference class: p selector: s)]! ! 444341 444342!WorldMenuProvider methodsFor: 'services' stamp: 'rr 7/10/2006 15:43'! 444343helpOnServices 444344 ^ ServiceAction 444345 text: 'Help on Services' 444346 button: 'services help' 444347 description: 'Introductory text about services' 444348 action: [StringHolder new contents: self servicesHelpText; openLabel: 'Introduction to Services'].! ! 444349 444350!WorldMenuProvider methodsFor: 'services' stamp: 'rr 3/11/2006 19:10'! 444351nextWindow 444352 ^ ServiceAction text: 'Switch to next window' button: 'next window' description: 'Switches to the next window' action: [:r | SystemWindow sendTopWindowToBack]! ! 444353 444354!WorldMenuProvider methodsFor: 'services' stamp: 'rr 10/20/2005 22:50'! 444355openMenu 444356 ^ ServiceCategory text: 'Open' button: 'open' description: 'The open menu'! ! 444357 444358!WorldMenuProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:15'! 444359preferencesBrowser 444360 ^ ServiceAction text: 'Preference Browser' button: 'pref. browser' description: 'Open the preference browser to edit various Squeak settings' action: [PreferenceBrowser open].! ! 444361 444362!WorldMenuProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:14'! 444363preferencesMenu 444364 ^ ServiceCategory text: 'Preferences & Services' button: 'preferences' description: 'Menu related to editing preferences'! ! 444365 444366!WorldMenuProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:18'! 444367rebuildRegistry 444368 ^ ServiceAction text: 'Rebuild service registry' button: 'rebuild registry' description: 'Rebuilds the service registry to scan for newly defined services' action: [ServiceRegistry rebuild].! ! 444369 444370!WorldMenuProvider methodsFor: 'services' stamp: 'rr 1/9/2006 19:16'! 444371servicesBrowser 444372 ^ ServiceAction text: 'Services Browser' button: 'services' description: 'Open a preference browser to edit several Squeak menus' action: [PreferenceBrowser openForServices].! ! 444373 444374!WorldMenuProvider methodsFor: 'services' stamp: 'rr 10/20/2005 22:49'! 444375world 444376 ^ ServiceCategory text: 'World' button: 'world' description: 'The world menu'! ! 444377 444378"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 444379 444380WorldMenuProvider class 444381 instanceVariableNames: ''! 444382 444383!WorldMenuProvider class methodsFor: 'initialization' stamp: 'rr 1/10/2006 12:53'! 444384initialize 444385 ServiceRegistry current buildProvider: self new! ! 444386Object subclass: #WorldState 444387 instanceVariableNames: 'hands viewBox canvas damageRecorder stepList lastStepTime lastStepMessage lastCycleTime commandHistory alarms lastAlarmTime' 444388 classVariableNames: 'CanSurrenderToOS DeferredUIMessages DisableDeferredUpdates LastCycleTime MinCycleLapse' 444389 poolDictionaries: '' 444390 category: 'Morphic-Worlds'! 444391!WorldState commentStamp: 'ls 7/10/2003 19:30' prior: 0! 444392The state of a Morphic world. (This needs some serious commenting!!!!) 444393 444394 444395The MinCycleLapse variable holds the minimum amount of time that a morphic cycle is allowed to take. If a cycle takes less than this, then interCyclePause: will wait until the full time has been used up.! 444396 444397 444398!WorldState methodsFor: 'alarms' stamp: 'ar 9/11/2000 16:43'! 444399addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime 444400 "Add a new alarm with the given set of parameters" 444401 self alarms add: 444402 (MorphicAlarm 444403 scheduledAt: scheduledTime 444404 receiver: aTarget 444405 selector: aSelector 444406 arguments: argArray).! ! 444407 444408!WorldState methodsFor: 'alarms' stamp: 'ar 9/11/2000 17:11'! 444409adjustAlarmTimes: nowTime 444410 "Adjust the alarm times after some clock weirdness (such as roll-over, image-startup etc)" 444411 | deltaTime | 444412 deltaTime := nowTime - lastAlarmTime. 444413 self alarms do:[:alarm| alarm scheduledTime: alarm scheduledTime + deltaTime].! ! 444414 444415!WorldState methodsFor: 'alarms' stamp: 'RAA 1/5/2001 10:46'! 444416alarms 444417 444418 ^alarms ifNil: [alarms := Heap sortBlock: self alarmSortBlock]! ! 444419 444420!WorldState methodsFor: 'alarms' stamp: 'dgd 2/22/2003 13:31'! 444421removeAlarm: aSelector for: aTarget 444422 "Remove the alarm with the given selector" 444423 444424 | alarm | 444425 alarm := self alarms 444426 detect: [:any | any receiver == aTarget and: [any selector == aSelector]] 444427 ifNone: [nil]. 444428 alarm isNil ifFalse: [self alarms remove: alarm]! ! 444429 444430!WorldState methodsFor: 'alarms' stamp: 'ar 10/22/2000 16:55'! 444431triggerAlarmsBefore: nowTime 444432 "Trigger all pending alarms that are to be executed before nowTime." 444433 | pending | 444434 lastAlarmTime ifNil:[lastAlarmTime := nowTime]. 444435 (nowTime < lastAlarmTime or:[nowTime - lastAlarmTime > 10000]) 444436 ifTrue:[self adjustAlarmTimes: nowTime]. 444437 pending := self alarms. 444438 [pending isEmpty not and:[pending first scheduledTime < nowTime]] 444439 whileTrue:[pending removeFirst value: nowTime]. 444440 lastAlarmTime := nowTime.! ! 444441 444442 444443!WorldState methodsFor: 'canvas' stamp: 'stephane.ducasse 9/25/2008 18:10'! 444444assuredCanvas 444445 444446 (canvas isNil or: [(canvas extent ~= viewBox extent) or: [canvas form depth ~= Display depth]]) 444447 ifTrue: 444448 ["allocate a new offscreen canvas the size of the window" 444449 self canvas: (Display defaultCanvasClass extent: viewBox extent)]. 444450 ^ self canvas! ! 444451 444452!WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44'! 444453canvas 444454 444455 ^ canvas! ! 444456 444457!WorldState methodsFor: 'canvas' stamp: 'dgd 2/22/2003 13:29'! 444458canvas: x 444459 canvas := x. 444460 damageRecorder isNil 444461 ifTrue: [damageRecorder := DamageRecorder new] 444462 ifFalse: [damageRecorder doFullRepaint]! ! 444463 444464!WorldState methodsFor: 'canvas' stamp: 'RAA 5/25/2000 15:12'! 444465doFullRepaint 444466 444467 damageRecorder doFullRepaint 444468! ! 444469 444470!WorldState methodsFor: 'canvas' stamp: 'ar 1/30/2001 23:25'! 444471recordDamagedRect: damageRect 444472 444473 damageRecorder ifNotNil: [damageRecorder recordInvalidRect: damageRect truncated] 444474! ! 444475 444476!WorldState methodsFor: 'canvas' stamp: 'RAA 5/25/2000 15:10'! 444477resetDamageRecorder 444478 444479 damageRecorder reset 444480! ! 444481 444482!WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44'! 444483viewBox 444484 444485 ^ viewBox! ! 444486 444487!WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:58'! 444488viewBox: x 444489 444490 viewBox := x! ! 444491 444492 444493!WorldState methodsFor: 'hands' stamp: 'ar 1/22/2001 14:26'! 444494activeHand 444495 444496 ^ ActiveHand! ! 444497 444498!WorldState methodsFor: 'hands' stamp: 'ar 10/26/2000 14:51'! 444499addHand: aHandMorph 444500 "Add the given hand to the list of hands for this world." 444501 444502 hands := (hands copyWithout: aHandMorph) copyWith: aHandMorph. 444503! ! 444504 444505!WorldState methodsFor: 'hands' stamp: 'di 6/7/1999 17:40'! 444506hands 444507 444508 ^ hands! ! 444509 444510!WorldState methodsFor: 'hands' stamp: 'RAA 5/24/2000 10:13'! 444511handsDo: aBlock 444512 444513 ^ hands do: aBlock! ! 444514 444515!WorldState methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:09'! 444516handsReverseDo: aBlock 444517 444518 ^ hands reverseDo: aBlock! ! 444519 444520!WorldState methodsFor: 'hands' stamp: 'ar 1/22/2001 14:26'! 444521removeHand: aHandMorph 444522 "Remove the given hand from the list of hands for this world." 444523 444524 (hands includes: aHandMorph) ifFalse: [^self]. 444525 hands := hands copyWithout: aHandMorph. 444526 ActiveHand == aHandMorph ifTrue: [ActiveHand := nil]. 444527! ! 444528 444529!WorldState methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:56'! 444530selectHandsToDrawForDamage: damageList 444531 "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." 444532 444533 | result hBnds | 444534 result := OrderedCollection new. 444535 hands do: [:h | 444536 h needsToBeDrawn ifTrue: [ 444537 h hasChanged 444538 ifTrue: [result add: h] 444539 ifFalse: [ 444540 hBnds := h fullBounds. 444541 (damageList detect: [:r | r intersects: hBnds] ifNone: [nil]) 444542 ifNotNil: [result add: h]]]]. 444543 ^ result 444544! ! 444545 444546 444547!WorldState methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:16'! 444548initialize 444549 444550 super initialize. 444551 hands := Array new. 444552 damageRecorder:= DamageRecorder new. 444553 stepList := Heap sortBlock: self stepListSortBlock. 444554 lastStepTime := 0. 444555 lastAlarmTime := 0.! ! 444556 444557!WorldState methodsFor: 'initialization' stamp: 'sw 9/5/2000 06:39'! 444558stepListSize 444559 ^ stepList size! ! 444560 444561 444562!WorldState methodsFor: 'nil' stamp: 'nice 4/16/2009 19:03'! 444563alarmSortBlock 444564 ^[ :alarm1 :alarm2 | 444565 alarm1 scheduledTime < alarm2 scheduledTime. 444566 ]! ! 444567 444568!WorldState methodsFor: 'nil' stamp: 'nice 4/16/2009 19:03'! 444569stepListSortBlock 444570 ^[ :stepMsg1 :stepMsg2 | 444571 stepMsg1 scheduledTime <= stepMsg2 scheduledTime 444572 ]! ! 444573 444574 444575!WorldState methodsFor: 'object filein' stamp: 'RAA 1/5/2001 10:51'! 444576convertAlarms 444577 444578 alarms ifNotNil: [alarms sortBlock: self alarmSortBlock]. "ensure cleaner block" 444579 444580! ! 444581 444582!WorldState methodsFor: 'object filein' stamp: 'dgd 2/22/2003 13:30'! 444583convertStepList 444584 "Convert the old-style step list (an Array of Arrays) into the new-style StepMessage heap" 444585 444586 | newList wakeupTime morphToStep | 444587 (stepList isKindOf: Heap) 444588 ifTrue: 444589 [^stepList sortBlock: self stepListSortBlock "ensure that we have a cleaner block"]. 444590 newList := Heap sortBlock: self stepListSortBlock. 444591 stepList do: 444592 [:entry | 444593 wakeupTime := entry second. 444594 morphToStep := entry first. 444595 newList add: (StepMessage 444596 scheduledAt: wakeupTime 444597 stepTime: nil 444598 receiver: morphToStep 444599 selector: #stepAt: 444600 arguments: nil)]. 444601 stepList := newList! ! 444602 444603 444604!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:23'! 444605adjustWakeupTimes: now 444606 "Fix the wakeup times in my step list. This is necessary when this world has been restarted after a pause, say because some other view had control, after a snapshot, or because the millisecond clock has wrapped around. (The latter is a rare occurence with a 32-bit clock!!)" 444607 | deltaTime | 444608 deltaTime := now - lastStepTime. 444609 stepList do:[:entry| entry scheduledTime: entry scheduledTime + deltaTime]. 444610 lastStepTime := now. 444611! ! 444612 444613!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 15:22'! 444614adjustWakeupTimesIfNecessary 444615 "Fix the wakeup times in my step list if necessary. This is needed after a snapshot, after a long pause (say because some other view had control or because the user was selecting from an MVC-style menu) or when the millisecond clock wraps around (a very rare occurence with a 32-bit clock!!)." 444616 444617 | now | 444618 now := Time millisecondClockValue. 444619 ((now < lastStepTime) or: [(now - lastStepTime) > 5000]) 444620 ifTrue: [self adjustWakeupTimes: now]. "clock slipped" 444621! ! 444622 444623!WorldState methodsFor: 'stepping' stamp: 'ar 2/23/2001 21:14'! 444624cleanseStepListForWorld: aWorld 444625 "Remove morphs from the step list that are not in this World. Often were in a flap that has moved on to another world." 444626 444627 | deletions morphToStep | 444628 deletions := nil. 444629 stepList do: [:entry | 444630 morphToStep := entry receiver. 444631 morphToStep world == aWorld ifFalse:[ 444632 deletions ifNil: [deletions := OrderedCollection new]. 444633 deletions addLast: entry]]. 444634 444635 deletions ifNotNil:[ 444636 deletions do: [:entry| 444637 self stopStepping: entry receiver]]. 444638 444639 self alarms copy do:[:entry| 444640 morphToStep := entry receiver. 444641 (morphToStep isMorph and:[morphToStep world == aWorld]) 444642 ifFalse:[self removeAlarm: entry selector for: entry receiver]].! ! 444643 444644!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:09'! 444645isStepping: aMorph 444646 "Return true if the given morph is in the step list." 444647 lastStepMessage ifNotNil:[(lastStepMessage receiver == aMorph) ifTrue:[^true]]. 444648 stepList do:[:entry| entry receiver == aMorph ifTrue:[^true]]. 444649 ^ false! ! 444650 444651!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:09'! 444652isStepping: aMorph selector: aSelector 444653 "Return true if the given morph is in the step list." 444654 lastStepMessage ifNotNil:[ 444655 (lastStepMessage receiver == aMorph and:[lastStepMessage selector == aSelector]) 444656 ifTrue:[^true]]. 444657 stepList do:[:entry| (entry receiver == aMorph and:[entry selector == aSelector]) ifTrue:[^true]]. 444658 ^ false! ! 444659 444660!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:05'! 444661listOfSteppingMorphs 444662 ^stepList collect:[:entry| entry receiver]. 444663! ! 444664 444665!WorldState methodsFor: 'stepping' stamp: 'dgd 2/22/2003 13:31'! 444666runLocalStepMethodsIn: aWorld 444667 "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world. 444668 ar 3/13/1999: Remove buggy morphs from the step list so that they don't raise repeated errors." 444669 444670 | now morphToStep stepTime priorWorld | 444671 now := Time millisecondClockValue. 444672 priorWorld := ActiveWorld. 444673 ActiveWorld := aWorld. 444674 self triggerAlarmsBefore: now. 444675 stepList isEmpty 444676 ifTrue: 444677 [ActiveWorld := priorWorld. 444678 ^self]. 444679 (now < lastStepTime or: [now - lastStepTime > 5000]) 444680 ifTrue: [self adjustWakeupTimes: now]. "clock slipped" 444681 [stepList isEmpty not and: [stepList first scheduledTime < now]] 444682 whileTrue: 444683 [lastStepMessage := stepList removeFirst. 444684 morphToStep := lastStepMessage receiver. 444685 (morphToStep shouldGetStepsFrom: aWorld) 444686 ifTrue: 444687 [lastStepMessage value: now. 444688 lastStepMessage ifNotNil: 444689 [stepTime := lastStepMessage stepTime ifNil: [morphToStep stepTime]. 444690 lastStepMessage scheduledTime: now + (stepTime max: 1). 444691 stepList add: lastStepMessage]]. 444692 lastStepMessage := nil]. 444693 lastStepTime := now. 444694 ActiveWorld := priorWorld! ! 444695 444696!WorldState methodsFor: 'stepping' stamp: 'GabrielOmarCotelli 6/8/2009 22:30'! 444697runStepMethodsIn: aWorld 444698 "Perform periodic activity inbetween event cycles" 444699 | queue nextInQueue| 444700 444701 "If available dispatch some deferred UI Message" 444702 queue := self class deferredUIMessages. 444703 nextInQueue := queue nextOrNil. 444704 nextInQueue ifNotNil: [ nextInQueue value]. 444705 444706 self runLocalStepMethodsIn: aWorld.! ! 444707 444708!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:36'! 444709startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime 444710 "Add the given morph to the step list. Do nothing if it is already being stepped." 444711 444712 self stopStepping: aMorph selector: aSelector. 444713 self adjustWakeupTimesIfNecessary. 444714 stepList add:( 444715 StepMessage 444716 scheduledAt: scheduledTime 444717 stepTime: stepTime 444718 receiver: aMorph 444719 selector: aSelector 444720 arguments: args)! ! 444721 444722!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:10'! 444723stopStepping: aMorph 444724 "Remove the given morph from the step list." 444725 lastStepMessage ifNotNil:[ 444726 (lastStepMessage receiver == aMorph) ifTrue:[lastStepMessage := nil]]. 444727 stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph]). 444728! ! 444729 444730!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:10'! 444731stopStepping: aMorph selector: aSelector 444732 "Remove the given morph from the step list." 444733 lastStepMessage ifNotNil:[ 444734 (lastStepMessage receiver == aMorph and:[lastStepMessage selector == aSelector]) 444735 ifTrue:[lastStepMessage := nil]]. 444736 stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and:[stepMsg selector == aSelector]]).! ! 444737 444738 444739!WorldState methodsFor: 'undo' stamp: 'ar 8/31/2000 22:57'! 444740commandHistory 444741 ^commandHistory ifNil:[commandHistory := CommandHistory new]! ! 444742 444743 444744!WorldState methodsFor: 'undo support' stamp: 'RAA 9/21/2000 20:05'! 444745clearCommandHistory 444746 444747 "useful prior to project saves" 444748 commandHistory := nil! ! 444749 444750 444751!WorldState methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 13:13'! 444752checkIfUpdateNeeded 444753 444754 damageRecorder updateIsNeeded ifTrue: [^true]. 444755 hands do: [:h | (h hasChanged and: [h needsToBeDrawn]) ifTrue: [^true]]. 444756 ^false "display is already up-to-date" 444757! ! 444758 444759!WorldState methodsFor: 'update cycle' stamp: 'ar 4/25/2001 17:01'! 444760displayWorld: aWorld submorphs: submorphs 444761 "Update this world's display." 444762 444763 | deferredUpdateMode worldDamageRects handsToDraw handDamageRects allDamage | 444764 444765 submorphs do: [:m | m fullBounds]. "force re-layout if needed" 444766 self checkIfUpdateNeeded ifFalse: [^ self]. "display is already up-to-date" 444767 444768 deferredUpdateMode := self doDeferredUpdatingFor: aWorld. 444769 deferredUpdateMode ifFalse: [self assuredCanvas]. 444770 canvas roundCornersOf: aWorld during:[ 444771 worldDamageRects := self drawWorld: aWorld submorphs: submorphs invalidAreasOn: canvas. "repair world's damage on canvas" 444772 "self handsDo:[:h| h noticeDamageRects: worldDamageRects]." 444773 handsToDraw := self selectHandsToDrawForDamage: worldDamageRects. 444774 handDamageRects := handsToDraw collect: [:h | h savePatchFrom: canvas]. 444775 allDamage := worldDamageRects, handDamageRects. 444776 444777 handsToDraw reverseDo: [:h | canvas fullDrawMorph: h]. "draw hands onto world canvas" 444778 ]. 444779 "*make this true to flash damaged areas for testing*" 444780 Preferences debugShowDamage ifTrue: [aWorld flashRects: allDamage color: Color black]. 444781 444782 canvas finish. 444783 "quickly copy altered rects of canvas to Display:" 444784 deferredUpdateMode 444785 ifTrue: [self forceDamageToScreen: allDamage] 444786 ifFalse: [canvas showAt: aWorld viewBox origin invalidRects: allDamage]. 444787 handsToDraw do: [:h | h restoreSavedPatchOn: canvas]. "restore world canvas under hands" 444788 Display deferUpdates: false; forceDisplayUpdate. 444789! ! 444790 444791!WorldState methodsFor: 'update cycle' stamp: 'ar 6/28/2003 01:07'! 444792displayWorldSafely: aWorld 444793 "Update this world's display and keep track of errors during draw methods." 444794 444795 [aWorld displayWorld] ifError: [:err :rcvr | 444796 "Handle a drawing error" 444797 | errCtx errMorph | 444798 errCtx := thisContext. 444799 [ 444800 errCtx := errCtx sender. 444801 "Search the sender chain to find the morph causing the problem" 444802 [errCtx notNil and:[(errCtx receiver isMorph) not]] 444803 whileTrue:[errCtx := errCtx sender]. 444804 "If we're at the root of the context chain then we have a fatal drawing problem" 444805 errCtx ifNil:[^self handleFatalDrawingError: err]. 444806 errMorph := errCtx receiver. 444807 "If the morph causing the problem has already the #drawError flag set, 444808 then search for the next morph above in the caller chain." 444809 errMorph hasProperty: #errorOnDraw 444810 ] whileTrue. 444811 errMorph setProperty: #errorOnDraw toValue: true. 444812 "Install the old error handler, so we can re-raise the error" 444813 rcvr error: err. 444814 ].! ! 444815 444816!WorldState methodsFor: 'update cycle' stamp: 'stephane.ducasse 10/18/2008 21:51'! 444817doDeferredUpdatingFor: aWorld 444818 "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, do nothing and answer false. One can set the class variable DisableDeferredUpdates to true to completely disable the deferred updating feature." 444819 | properDisplay | 444820 PasteUpMorph disableDeferredUpdates ifTrue: [^ false]. 444821 (Display deferUpdates: true) ifNil: [^ false]. "deferred updates not supported" 444822 properDisplay := canvas notNil and: [canvas form == Display]. 444823 aWorld == World ifTrue: [ "this world fills the entire Display" 444824 properDisplay ifFalse: [ 444825 aWorld viewBox: Display boundingBox. "do first since it may clear canvas" 444826 self canvas: (Display getCanvas copyClipRect: Display boundingBox). 444827 ] 444828 ] ifFalse: [ "this world is inside an MVC window" 444829 (properDisplay and: [canvas clipRect = aWorld viewBox]) ifFalse: [ 444830 self canvas: 444831 (Display getCanvas copyOffset: 0@0 clipRect: aWorld viewBox) 444832 ] 444833 ]. 444834 ^ true 444835! ! 444836 444837!WorldState methodsFor: 'update cycle' stamp: 'adrian_lienhard 7/18/2009 15:30'! 444838doOneCycleFor: aWorld 444839 "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. This is a moderately private method; a better alternative is usually either to wait for events or to check the state of things from #step methods." 444840 444841 self interCyclePause: MinCycleLapse. 444842 self doOneCycleNowFor: aWorld.! ! 444843 444844!WorldState methodsFor: 'update cycle' stamp: 'md 4/30/2008 16:33'! 444845doOneCycleNowFor: aWorld 444846 "Immediately do one cycle of the interaction loop. 444847 This should not be called directly, but only via doOneCycleFor:" 444848 444849 DisplayScreen checkForNewScreenSize. 444850 444851 "process user input events" 444852 LastCycleTime := Time millisecondClockValue. 444853 self handsDo: [:h | 444854 ActiveHand := h. 444855 h processEvents. 444856 ActiveHand := nil 444857 ]. 444858 444859 "the default is the primary hand" 444860 ActiveHand := self hands first. 444861 444862 aWorld runStepMethods. "there are currently some variations here" 444863 self displayWorldSafely: aWorld.! ! 444864 444865!WorldState methodsFor: 'update cycle' stamp: 'ar 1/22/2001 14:26'! 444866doOneSubCycleFor: aWorld 444867 "Like doOneCycle, but preserves activeHand." 444868 444869 | currentHand | 444870 currentHand := ActiveHand. 444871 self doOneCycleFor: aWorld. 444872 ActiveHand := currentHand! ! 444873 444874!WorldState methodsFor: 'update cycle' stamp: 'Henrik Sperre Johansen 2/25/2009 13:52'! 444875drawWorld: aWorld submorphs: submorphs invalidAreasOn: aCanvas 444876 "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that 444877were redrawn." 444878 444879 | rectList c i n mm morphs rects rectToFill remnants remnantIntersects rect validList | 444880 rectList := damageRecorder invalidRectsFullBounds: aWorld viewBox. 444881 "sort by areas to draw largest portions first" 444882 rectList := rectList asArray sort: [:r1 :r2 | r1 area > r2 area]. 444883 damageRecorder reset. 444884 n := submorphs size. 444885 morphs := OrderedCollection new: n * 2. 444886 rects := OrderedCollection new: n * 2. 444887 validList := OrderedCollection new: n * 2. 444888 rectList do: 444889 [:dirtyRect | 444890 dirtyRect allAreasOutsideList: validList 444891 do: 444892 [:r | 444893 "Experimental top-down drawing -- 444894 Traverses top to bottom, stopping if the entire area is filled. 444895 If only a single rectangle remains, then continue with the reduced rectangle." 444896 444897 rectToFill := r. 444898 remnants := OrderedCollection with: r. 444899 i := 1. 444900 [remnants isEmpty or: [i > n]] whileFalse: 444901 [mm := submorphs at: i. 444902 ((remnantIntersects := remnants select: [:each | (mm fullBounds intersects: each)]) notEmpty and: [mm visible]) 444903 ifTrue: 444904 [morphs addLast: mm. 444905 444906 rects addLast: (Rectangle merging: (remnantIntersects collect: [:each | mm fullBounds intersect: each])). 444907 remnants removeAll: remnantIntersects. 444908 remnantIntersects do: [:eachIntersect | remnants addAll: (mm areasRemainingToFill: eachIntersect)]. 444909 remnants size = 1 ifTrue: [rectToFill := remnants first]. 444910 remnants isEmpty ifTrue: [rectToFill := nil]]. 444911 i := i + 1]. 444912 "Now paint from bottom to top, but using the reduced rectangles." 444913 rectToFill 444914 ifNotNil: [aWorld drawOn: (c := aCanvas copyClipRect: rectToFill)]. 444915 [morphs isEmpty] whileFalse: 444916 [(rect := rects removeLast) == rectToFill 444917 ifFalse: [c := aCanvas copyClipRect: (rectToFill := rect)]. 444918 c fullDrawMorph: morphs removeLast]. 444919 morphs reset. 444920 rects reset. 444921 validList add: r]]. 444922 ^validList! ! 444923 444924!WorldState methodsFor: 'update cycle' stamp: 'stephane.ducasse 9/25/2008 18:11'! 444925forceDamageToScreen: allDamage 444926 444927 Display forceDamageToScreen: allDamage. 444928 ! ! 444929 444930!WorldState methodsFor: 'update cycle' stamp: 'alain.plantec 6/2/2008 08:45'! 444931handleFatalDrawingError: errMsg 444932 "Handle a fatal drawing error." 444933 Display deferUpdates: false. "Just in case" 444934 self primitiveError: errMsg. 444935 444936 "Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"! ! 444937 444938!WorldState methodsFor: 'update cycle' stamp: 'al 7/31/2007 16:12'! 444939interCyclePause: milliSecs 444940 "delay enough that the previous cycle plus the amount of delay will equal milliSecs. If the cycle is already expensive, then no delay occurs. However, if the system is idly waiting for interaction from the user, the method will delay for a proportionally long time and cause the overall CPU usage of Squeak to be low. 444941 If the preference #serverMode is enabled, always do a complete delay of 50ms, independant of my argument. This prevents the freezing problem described in Mantis #6581" 444942 444943 | currentTime wait | 444944 Preferences serverMode 444945 ifFalse: [ 444946 (lastCycleTime notNil and: [CanSurrenderToOS ~~ false]) ifTrue: [ 444947 currentTime := Time millisecondClockValue. 444948 wait := lastCycleTime + milliSecs - currentTime. 444949 (wait > 0 and: [ wait <= milliSecs ] ) ifTrue: [ 444950 (Delay forMilliseconds: wait) wait ] ] ] 444951 ifTrue: [ (Delay forMilliseconds: 50) wait ]. 444952 444953 lastCycleTime := Time millisecondClockValue. 444954 CanSurrenderToOS := true.! ! 444955 444956"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 444957 444958WorldState class 444959 instanceVariableNames: ''! 444960 444961!WorldState class methodsFor: 'accessing' stamp: 'RAA 1/7/2001 16:32'! 444962classVersion 444963 444964 ^1 "force cleanup of alarms and stepList"! ! 444965 444966 444967!WorldState class methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 16:40'! 444968canSurrenderToOS: aBoolean 444969 444970 CanSurrenderToOS := aBoolean! ! 444971 444972!WorldState class methodsFor: 'as yet unclassified' stamp: 'RAA 7/23/2000 17:28'! 444973lastCycleTime 444974 444975 ^LastCycleTime! ! 444976 444977 444978!WorldState class methodsFor: 'initialization' stamp: 'RAA 7/15/2000 12:58'! 444979addDeferredUIMessage: valuableObject 444980 444981 self deferredUIMessages nextPut: valuableObject. 444982 444983! ! 444984 444985!WorldState class methodsFor: 'initialization' stamp: 'RAA 7/15/2000 12:58'! 444986deferredUIMessages 444987 444988 ^DeferredUIMessages ifNil: [DeferredUIMessages := SharedQueue new]. 444989! ! 444990 444991!WorldState class methodsFor: 'initialization' stamp: 'RAA 7/15/2000 12:56'! 444992initialize 444993 "WorldState initialize" 444994 444995 MinCycleLapse := 20. "allows 50 frames per second..." 444996 DisableDeferredUpdates := false. 444997 DeferredUIMessages := SharedQueue new.! ! 444998PositionableStream subclass: #WriteStream 444999 instanceVariableNames: 'writeLimit' 445000 classVariableNames: '' 445001 poolDictionaries: '' 445002 category: 'Collections-Streams'! 445003!WriteStream commentStamp: '<historical>' prior: 0! 445004I represent an accessor for a sequence of objects that can only store objects in the sequence.! 445005 445006 445007!WriteStream methodsFor: 'accessing'! 445008contents 445009 445010 readLimit := readLimit max: position. 445011 ^collection copyFrom: 1 to: position! ! 445012 445013!WriteStream methodsFor: 'accessing' stamp: 'dc 2/11/2007 14:18'! 445014ensureEndsWith: anObject 445015 "Append anObject to the receiver IFF there is not one on the end." 445016 445017 (position > 0 and: [(collection at: position) = anObject]) ifTrue: [^self]. 445018 self nextPut: anObject! ! 445019 445020!WriteStream methodsFor: 'accessing'! 445021next 445022 445023 self shouldNotImplement! ! 445024 445025!WriteStream methodsFor: 'accessing' stamp: 'yo 2/18/2004 14:41'! 445026next: anInteger putAll: aCollection startingAt: startIndex 445027 "Store the next anInteger elements from the given collection." 445028 445029 | newEnd numPut | 445030 collection class == aCollection class ifFalse: 445031 [^ super next: anInteger putAll: aCollection startingAt: startIndex ]. 445032 445033 numPut := anInteger min: (aCollection size - startIndex + 1). 445034 newEnd := position + numPut. 445035 newEnd > writeLimit ifTrue: 445036 [^ super next: anInteger putAll: aCollection startingAt: startIndex "Trigger normal pastEndPut: logic"]. 445037 445038 collection replaceFrom: position+1 to: newEnd with: aCollection startingAt: startIndex. 445039 position := newEnd. 445040! ! 445041 445042!WriteStream methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:34'! 445043nextPut: anObject 445044 "Primitive. Insert the argument at the next position in the Stream 445045 represented by the receiver. Fail if the collection of this stream is not an 445046 Array or a String. Fail if the stream is positioned at its end, or if the 445047 position is out of bounds in the collection. Fail if the argument is not 445048 of the right type for the collection. Optional. See Object documentation 445049 whatIsAPrimitive." 445050 445051 <primitive: 66> 445052 ((collection class == ByteString) and: [ 445053 anObject isCharacter and:[anObject isOctetCharacter not]]) ifTrue: [ 445054 collection := (WideString from: collection). 445055 ^self nextPut: anObject. 445056 ]. 445057 position >= writeLimit 445058 ifTrue: [^ self pastEndPut: anObject] 445059 ifFalse: 445060 [position := position + 1. 445061 ^collection at: position put: anObject]! ! 445062 445063!WriteStream methodsFor: 'accessing' stamp: 'BG 5/24/2003 20:41'! 445064nextPutAll: aCollection 445065 445066 | newEnd | 445067 collection class == aCollection class ifFalse: 445068 [^ super nextPutAll: aCollection ]. 445069 445070 newEnd := position + aCollection size. 445071 newEnd > writeLimit ifTrue: 445072 [self growTo: newEnd + 10]. 445073 445074 collection replaceFrom: position+1 to: newEnd with: aCollection startingAt: 1. 445075 position := newEnd.! ! 445076 445077!WriteStream methodsFor: 'accessing'! 445078size 445079 445080 ^readLimit := readLimit max: position! ! 445081 445082 445083!WriteStream methodsFor: 'character writing'! 445084cr 445085 "Append a return character to the receiver." 445086 445087 self nextPut: Character cr! ! 445088 445089!WriteStream methodsFor: 'character writing'! 445090crtab 445091 "Append a return character, followed by a single tab character, to the 445092 receiver." 445093 445094 self nextPut: Character cr. 445095 self nextPut: Character tab! ! 445096 445097!WriteStream methodsFor: 'character writing'! 445098crtab: anInteger 445099 "Append a return character, followed by anInteger tab characters, to the 445100 receiver." 445101 445102 self nextPut: Character cr. 445103 anInteger timesRepeat: [self nextPut: Character tab]! ! 445104 445105!WriteStream methodsFor: 'character writing' stamp: 'RAA 3/5/2001 10:26'! 445106ensureASpace 445107 "Append a space character to the receiver IFF there is not one on the end." 445108 445109 (position > 0 and: [(collection at: position) = Character space]) ifTrue: [^self]. 445110 self nextPut: Character space! ! 445111 445112!WriteStream methodsFor: 'character writing' stamp: 'tk 9/23/2001 01:16'! 445113ensureNoSpace 445114 "If there is not one on the end, remove it." 445115 445116 (position > 0 and: [(collection at: position) = Character space]) 445117 ifTrue: [self skip: -1].! ! 445118 445119!WriteStream methodsFor: 'character writing' stamp: 'di 6/7/2000 22:43'! 445120nextPutKeyword: keyword withArg: argValue 445121 "Emit a keyword/value pair in the alternate syntax" 445122 445123 self nextPutAll: (keyword copyWithout: $:); 445124 nextPut: $(; 445125 store: argValue; 445126 nextPut: $)! ! 445127 445128!WriteStream methodsFor: 'character writing' stamp: 'tk 10/19/2001 11:12'! 445129peekLast 445130 "Return that item just put at the end of the stream" 445131 445132 ^ position > 0 445133 ifTrue: [collection at: position] 445134 ifFalse: [nil]! ! 445135 445136!WriteStream methodsFor: 'character writing'! 445137space 445138 "Append a space character to the receiver." 445139 445140 self nextPut: Character space! ! 445141 445142!WriteStream methodsFor: 'character writing' stamp: 'JF 7/31/2003 13:01'! 445143space: anInteger 445144 "Append anInteger space characters to the receiver." 445145 445146 anInteger timesRepeat: [self space]! ! 445147 445148!WriteStream methodsFor: 'character writing'! 445149tab 445150 "Append a tab character to the receiver." 445151 445152 self nextPut: Character tab! ! 445153 445154!WriteStream methodsFor: 'character writing' stamp: 'JF 7/31/2003 13:00'! 445155tab: anInteger 445156 "Append anInteger tab characters to the receiver." 445157 445158 anInteger timesRepeat: [self tab]! ! 445159 445160 445161!WriteStream methodsFor: 'filein/out' stamp: 'yo 8/13/2003 12:18'! 445162nextChunkPut: aString 445163 "Append the argument, aString, to the receiver, doubling embedded terminators." 445164 445165 | i remainder terminator | 445166 terminator := $!!. 445167 remainder := aString. 445168 [(i := remainder indexOf: terminator) = 0] whileFalse: 445169 [self nextPutAll: (remainder copyFrom: 1 to: i). 445170 self nextPut: terminator. "double imbedded terminators" 445171 remainder := remainder copyFrom: i+1 to: remainder size]. 445172 self nextPutAll: remainder. 445173 aString includesUnifiedCharacter ifTrue: [ 445174 self nextPut: terminator. 445175 self nextPutAll: ']lang['. 445176 aString writeLeadingCharRunsOn: self. 445177 ]. 445178 self nextPut: terminator. 445179! ! 445180 445181!WriteStream methodsFor: 'filein/out' stamp: 'yo 8/28/2002 16:13'! 445182nextChunkPutWithStyle: aStringOrText 445183 "Append the argument, aText, to the receiver, doubling embedded terminators. Put out one chunk for the string and one for the style runs. Mark the style with ]style[." 445184 445185 aStringOrText isString ifTrue: [^ self nextChunkPut: aStringOrText]. 445186 aStringOrText runs coalesce. 445187 aStringOrText unembellished ifTrue: [^ self nextChunkPut: aStringOrText asString]. 445188 445189 self nextChunkPut: aStringOrText asString. 445190 self cr; nextPutAll: ']style['. 445191 self nextChunkPut: 445192 (String streamContents: [:strm | 445193 aStringOrText runs writeScanOn: strm]). 445194! ! 445195 445196!WriteStream methodsFor: 'filein/out' stamp: 'nk 7/29/2004 10:11'! 445197timeStamp 445198 "Append the current time to the receiver as a String." 445199 self nextChunkPut: "double string quotes and !!s" 445200 (String streamContents: [:s | SmalltalkImage current timeStamp: s]) printString. 445201 self cr! ! 445202 445203 445204!WriteStream methodsFor: 'positioning'! 445205position: anInteger 445206 "Refer to the comment in PositionableStream|position:." 445207 445208 readLimit := readLimit max: position. 445209 super position: anInteger! ! 445210 445211!WriteStream methodsFor: 'positioning'! 445212reset 445213 "Refer to the comment in PositionableStream|reset." 445214 445215 readLimit := readLimit max: position. 445216 position := 0! ! 445217 445218!WriteStream methodsFor: 'positioning' stamp: 'ar 11/12/1998 21:27'! 445219resetToStart 445220 readLimit := position := 0.! ! 445221 445222!WriteStream methodsFor: 'positioning' stamp: 'ajh 5/25/2001 20:19'! 445223setToEnd 445224 "Refer to the comment in PositionableStream|setToEnd." 445225 445226 readLimit := readLimit max: position. 445227 super setToEnd.! ! 445228 445229 445230!WriteStream methodsFor: 'printing' stamp: 'kph 11/2/2008 01:16'! 445231<< aCollection 445232 "we want a readable version of nextPutAll however it may be difficult to fully recreate nextPutAll: 445233 for all the different types of stream. Rather then simply send to nextPutAll: 445234 we handle the String (or ByteArray) argument 445235 as fast as possible - the rest we delegate to putOn: This means that we handle single characters and bytes 445236 whereas nextPutAll: is only for sequencable collections. 445237 . 445238 Note this may not work in every case that nextPutAll: does subject to extensive testing, 445239 but it should work in the important cases" 445240 445241 | newEnd | 445242 collection class == aCollection class ifFalse: 445243 [ aCollection putOn: self. ^ self ]. 445244 445245 newEnd := position + aCollection size. 445246 newEnd > writeLimit ifTrue: 445247 [self growTo: newEnd + 10]. 445248 445249 collection replaceFrom: position+1 to: newEnd with: aCollection startingAt: 1. 445250 position := newEnd. 445251 445252! ! 445253 445254!WriteStream methodsFor: 'printing'! 445255store: anObject 445256 "Have anObject print on the receiver for purposes of rereading." 445257 445258 anObject storeOn: self! ! 445259 445260 445261!WriteStream methodsFor: 'private' stamp: 'di 11/18/1999 22:55'! 445262braceArray 445263 "This method is used in compilation of brace constructs. 445264 It MUST NOT be deleted or altered." 445265 445266 ^ collection! ! 445267 445268!WriteStream methodsFor: 'private' stamp: 'di 11/18/1999 22:50'! 445269braceArray: anArray 445270 "This method is used in compilation of brace constructs. 445271 It MUST NOT be deleted or altered." 445272 445273 collection := anArray. 445274 position := 0. 445275 readLimit := 0. 445276 writeLimit := anArray size.! ! 445277 445278!WriteStream methodsFor: 'private' stamp: 'BG 5/24/2003 22:49'! 445279growTo: anInteger 445280 445281 " anInteger is the required minimal new size of the collection " 445282 | oldSize grownCollection newSize | 445283 oldSize := collection size. 445284 newSize := anInteger + (oldSize // 4 max: 20). 445285 grownCollection := collection class new: newSize. 445286 collection := grownCollection replaceFrom: 1 to: oldSize with: collection startingAt: 1. 445287 writeLimit := collection size. 445288 ! ! 445289 445290!WriteStream methodsFor: 'private'! 445291on: aCollection 445292 445293 super on: aCollection. 445294 readLimit := 0. 445295 writeLimit := aCollection size! ! 445296 445297!WriteStream methodsFor: 'private'! 445298on: aCollection from: firstIndex to: lastIndex 445299 445300 | len | 445301 collection := aCollection. 445302 readLimit := 445303 writeLimit := lastIndex > (len := collection size) 445304 ifTrue: [len] 445305 ifFalse: [lastIndex]. 445306 position := firstIndex <= 1 445307 ifTrue: [0] 445308 ifFalse: [firstIndex - 1]! ! 445309 445310!WriteStream methodsFor: 'private' stamp: 'nice 2/26/2009 11:26'! 445311pastEndPut: anObject 445312 "Grow the collection by doubling the size, but keeping the growth between 20 and 1000000. 445313 Then put <anObject> at the current write position." 445314 445315 collection := collection grownBy: ((collection size max: 20) min: 1000000). 445316 writeLimit := collection size. 445317 collection at: (position := position + 1) put: anObject. 445318 ^ anObject! ! 445319 445320!WriteStream methodsFor: 'private'! 445321with: aCollection 445322 445323 super on: aCollection. 445324 position := readLimit := writeLimit := aCollection size! ! 445325 445326!WriteStream methodsFor: 'private'! 445327withAttribute: att do: strmBlock 445328 "No-op here is overriden in TextStream for font emphasis" 445329 ^ strmBlock value! ! 445330 445331!WriteStream methodsFor: 'private' stamp: 'djp 11/6/1999 23:15'! 445332withAttributes: attributes do: strmBlock 445333 "No-op here is overriden in TextStream for font emphasis" 445334 ^ strmBlock value! ! 445335 445336"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 445337 445338WriteStream class 445339 instanceVariableNames: ''! 445340 445341!WriteStream class methodsFor: 'instance creation'! 445342on: aCollection from: firstIndex to: lastIndex 445343 "Answer an instance of me on a copy of the argument, aCollection, 445344 determined by the indices firstIndex and lastIndex. Position the instance 445345 at the beginning of the collection." 445346 445347 ^self basicNew 445348 on: aCollection 445349 from: firstIndex 445350 to: lastIndex! ! 445351 445352!WriteStream class methodsFor: 'instance creation'! 445353with: aCollection 445354 "Answer an instance of me on the argument, aCollection, positioned to 445355 store objects at the end of aCollection." 445356 445357 ^self basicNew with: aCollection! ! 445358 445359!WriteStream class methodsFor: 'instance creation'! 445360with: aCollection from: firstIndex to: lastIndex 445361 "Answer an instance of me on the subcollection of the argument, 445362 aCollection, determined by the indices firstIndex and lastIndex. Position 445363 the instance to store at the end of the subcollection." 445364 445365 ^self basicNew with: (aCollection copyFrom: firstIndex to: lastIndex)! ! 445366ClassTestCase subclass: #WriteStreamTest 445367 instanceVariableNames: '' 445368 classVariableNames: '' 445369 poolDictionaries: '' 445370 category: 'CollectionsTests-Streams'! 445371 445372!WriteStreamTest methodsFor: 'testing' stamp: 'PeterHugossonMiller 9/3/2009 11:47'! 445373testEnsureASpace 445374 "self debug: #testEnsureASpace" 445375 | stream | 445376 stream := String new writeStream. 445377 stream nextPutAll: 'this is a test'. 445378 stream ensureASpace. 445379 stream nextPutAll: 'for WriteStreamTest'. 445380 self assert: stream contents = 'this is a test for WriteStreamTest'. 445381 445382 "Manually put a space and verify there are no 2 consecutive spaces" 445383 stream := String new writeStream. 445384 stream nextPutAll: 'this is a test '. 445385 stream ensureASpace. 445386 stream nextPutAll: 'for WriteStreamTest'. 445387 self assert: stream contents = 'this is a test for WriteStreamTest'.! ! 445388 445389!WriteStreamTest methodsFor: 'testing' stamp: 'PeterHugossonMiller 9/3/2009 11:47'! 445390testEnsureASpace2 445391 "self debug: #testEnsureASpace2" 445392 | stream | 445393 stream := String new writeStream. 445394 stream ensureASpace. 445395 self assert: stream contents = ' '. 445396 ! ! 445397 445398!WriteStreamTest methodsFor: 'testing' stamp: 'PeterHugossonMiller 9/3/2009 11:48'! 445399testEnsureEndsWith 445400 "self debug: #testEnsureEndsWith" 445401 | stream | 445402 stream := String new writeStream. 445403 stream nextPutAll: 'this is a test'. 445404 stream ensureEndsWith: Character cr. 445405 stream nextPutAll: 'for WriteStreamTest'. 445406 self assert: stream contents = (('this is a test' copyWith: Character cr), 'for WriteStreamTest'). 445407 445408 "Manually put a new line and verify there are no 2 new lines" 445409 stream := String new writeStream. 445410 stream nextPutAll: ('this is a test' copyWith: Character cr). 445411 stream ensureEndsWith: Character cr. 445412 stream nextPutAll: 'for WriteStreamTest'. 445413 self assert: stream contents = (('this is a test' copyWith: Character cr), 'for WriteStreamTest').! ! 445414 445415!WriteStreamTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:24'! 445416testNew 445417 445418 self should: [WriteStream new] raise: Error. ! ! 445419 445420!WriteStreamTest methodsFor: 'testing' stamp: 'sd 6/5/2005 09:24'! 445421testSetToEnd 445422 445423 | string stream | 445424 string := 'hello'. 445425 stream := WriteStream with: ''. 445426 stream nextPutAll: string. 445427 self assert: stream position = string size. 445428 stream setToEnd. 445429 self assert: stream position = string size. 445430 self assert: stream contents = string! ! 445431 445432 445433!WriteStreamTest methodsFor: 'tests - testing' stamp: 'PeterHugossonMiller 9/3/2009 11:48'! 445434testIsEmpty 445435 | stream | 445436 stream := String new writeStream. 445437 self assert: stream isEmpty. 445438 stream nextPut: $a. 445439 self deny: stream isEmpty. 445440 stream reset. 445441 self deny: stream isEmpty.! ! 445442Object subclass: #X11Encoding 445443 instanceVariableNames: '' 445444 classVariableNames: '' 445445 poolDictionaries: '' 445446 category: 'Multilingual-ImmPlugin'! 445447 445448"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 445449 445450X11Encoding class 445451 instanceVariableNames: ''! 445452 445453!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:21'! 445454encoding 445455 445456 | enc | 445457 enc := self getEncoding. 445458 enc ifNil: [ ^ nil ]. 445459 ^ enc asLowercase.! ! 445460 445461!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:09'! 445462getEncoding 445463 <primitive: 'primGetEncoding' module: 'ImmX11Plugin'> 445464 ^ nil 445465! ! 445466 445467!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445468getLocaleEncoding 445469 <primitive: 'primGetLocaleEncoding' module: 'ImmX11Plugin'> 445470 ^ nil 445471! ! 445472 445473!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445474getPathEnc 445475 <primitive: 'primGetPathEnc' module: 'ImmX11Plugin'> 445476 ^ nil 445477! ! 445478 445479!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445480getTextEnc 445481 <primitive: 'primGetTextEnc' module: 'ImmX11Plugin'> 445482 ^ nil 445483! ! 445484 445485!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445486getXWinEnc 445487 <primitive: 'primGetXWinEnc' module: 'ImmX11Plugin'> 445488 ^ nil 445489! ! 445490 445491!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445492requestUTF8 445493 <primitive: 'primIsTextEncUTF8' module: 'ImmX11Plugin'> 445494 ^ nil 445495! ! 445496 445497!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445498requestUTF8: bool 445499 <primitive: 'primSetTextEncUTF8' module: 'ImmX11Plugin'> 445500 ^ nil 445501! ! 445502 445503!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445504setEncoding: encoding 445505 <primitive: 'primSetEncoding' module: 'ImmX11Plugin'> 445506 ^ nil 445507! ! 445508 445509!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445510setEncodingToLocale 445511 <primitive: 'primSetEncodingToLocale' module: 'ImmX11Plugin'> 445512 ^ nil 445513! ! 445514 445515!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445516setPathEnc: encoding 445517 <primitive: 'primSetPathEnc' module: 'ImmX11Plugin'> 445518 ^ nil 445519! ! 445520 445521!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445522setPathEncToLocale 445523 <primitive: 'primSetPathEncToLocale' module: 'ImmX11Plugin'> 445524 ^ nil 445525! ! 445526 445527!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445528setTextEnc: encoding 445529 <primitive: 'primSetTextEnc' module: 'ImmX11Plugin'> 445530 ^ nil 445531! ! 445532 445533!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445534setTextEncToLocale 445535 <primitive: 'primSetTextEncToLocale' module: 'ImmX11Plugin'> 445536 ^ nil 445537! ! 445538 445539!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445540setXWinEnc: encoding 445541 <primitive: 'primSetXWinEnc' module: 'ImmX11Plugin'> 445542 ^ nil 445543! ! 445544 445545!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 12/5/2003 15:07'! 445546setXWinEncToLocale 445547 <primitive: 'primSetXWinEncToLocale' module: 'ImmX11Plugin'> 445548 ^ nil 445549! ! 445550 445551!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'mir 7/15/2004 18:57'! 445552useEncoding: encoding 445553 445554 self setEncoding: encoding. 445555 LanguageEnvironment startUp. 445556 ^ self encoding.! ! 445557 445558!X11Encoding class methodsFor: 'as yet unclassified' stamp: 'mir 7/15/2004 18:57'! 445559useLocaleEncoding 445560 445561 self setEncodingToLocale. 445562 LanguageEnvironment startUp. 445563 ^ self encoding.! ! 445564Object subclass: #XTableForFixedFont 445565 instanceVariableNames: 'width maxCode' 445566 classVariableNames: '' 445567 poolDictionaries: '' 445568 category: 'Multilingual-Display'! 445569 445570!XTableForFixedFont methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 16:14'! 445571at: anInteger 445572 445573 (anInteger < 1 or: [maxCode + 2 < anInteger]) ifTrue: [ 445574 self error: 'subscript out of bounds'. 445575 ]. 445576 ^(anInteger - 1) * width. 445577! ! 445578 445579!XTableForFixedFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 445580maxAscii: anInteger 445581 445582 maxCode := anInteger. 445583! ! 445584 445585!XTableForFixedFont methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 16:14'! 445586maxCode 445587 445588 ^ maxCode. 445589! ! 445590 445591!XTableForFixedFont methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 16:14'! 445592size 445593 445594 ^ maxCode. 445595! ! 445596 445597!XTableForFixedFont methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 16:15'! 445598width 445599 445600 ^ width. 445601! ! 445602 445603!XTableForFixedFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 445604width: anInteger 445605 445606 width := anInteger. 445607! ! 445608Object subclass: #XTableForUnicodeFont 445609 instanceVariableNames: 'ranges xTables' 445610 classVariableNames: '' 445611 poolDictionaries: '' 445612 category: 'Multilingual-Display'! 445613 445614!XTableForUnicodeFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 445615at: indexPlusOne 445616 445617 | index | 445618 index := indexPlusOne. 445619 ranges with: xTables do: [:range :xTable | 445620 (range first <= index and: [index <= range last]) ifTrue: [ 445621 ^ xTable at: index - range first + 1. 445622 ]. 445623 ]. 445624 ^ 0. 445625! ! 445626 445627!XTableForUnicodeFont methodsFor: 'as yet unclassified' stamp: 'yo 12/28/2002 21:40'! 445628at: index put: value 445629 445630 ranges with: xTables do: [:range :xTable | 445631 (range first <= index and: [index <= range last]) ifTrue: [ 445632 ^ xTable at: index - range first + 1 put: value. 445633 ]. 445634 ]. 445635 ^ 0. 445636! ! 445637 445638!XTableForUnicodeFont methodsFor: 'as yet unclassified' stamp: 'sd 2/4/2008 21:20'! 445639ranges: pairArray 445640 445641 xTables := Array new: 0. 445642 pairArray do: [:range | 445643 xTables := xTables copyWith: (Array new: range last - range first + 1 withAll: 0). 445644 ]. 445645 ranges := pairArray. 445646! ! 445647 445648!XTableForUnicodeFont methodsFor: 'as yet unclassified' stamp: 'yo 12/29/2002 00:04'! 445649size 445650 445651 ^ ranges last last - ranges first first + 1. 445652! ! 445653Timespan subclass: #Year 445654 instanceVariableNames: '' 445655 classVariableNames: '' 445656 poolDictionaries: '' 445657 category: 'Kernel-Chronology'! 445658!Year commentStamp: 'marcus.denker 6/5/2009 11:24' prior: 0! 445659I represent a year.! 445660 445661 445662!Year methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:01'! 445663asYear 445664 445665 ^ self ! ! 445666 445667!Year methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:01'! 445668daysInMonth 445669 445670 self shouldNotImplement ! ! 445671 445672!Year methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:01'! 445673daysInYear 445674 445675 ^ self duration days.! ! 445676 445677!Year methodsFor: 'squeak protocol' stamp: 'brp 5/21/2003 08:38'! 445678printOn: aStream 445679 445680 aStream nextPutAll: 'a Year ('. 445681 self start year printOn: aStream. 445682 aStream nextPutAll: ')'. 445683! ! 445684 445685"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 445686 445687Year class 445688 instanceVariableNames: ''! 445689 445690!Year class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:52'! 445691daysInYear: yearInteger 445692 445693 ^ 365 + ((self isLeapYear: yearInteger) ifTrue: [1] ifFalse: [0]). 445694! ! 445695 445696!Year class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:55'! 445697leapYear: yearInteger 445698 445699 ^ (self isLeapYear: yearInteger) 445700 ifTrue: [1] 445701 ifFalse: [0]! ! 445702 445703 445704!Year class methodsFor: 'squeak protocol' stamp: 'brp 9/11/2003 14:05'! 445705current 445706 445707 ^ self year: (DateAndTime now year) 445708! ! 445709 445710!Year class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:00'! 445711isLeapYear: aYearInteger 445712 445713 445714 | adjustedYear | 445715 adjustedYear := aYearInteger > 0 445716 ifTrue: [aYearInteger] 445717 ifFalse: [(aYearInteger + 1) negated]. 445718 445719 "There was no year 0" 445720 ^ ((adjustedYear \\ 4 ~= 0) or: [(adjustedYear \\ 100 = 0) and: [adjustedYear \\ 400 ~= 0]]) not.! ! 445721 445722!Year class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 13:53'! 445723starting: aDateAndTime duration: aDuration 445724 "Override - start from midnight" 445725 | midnight | 445726 midnight := aDateAndTime asDateAndTime midnight. 445727 445728 ^ super 445729 starting: midnight 445730 duration: (Duration days: (self daysInYear: midnight year)).! ! 445731 445732!Year class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:00'! 445733year: aYear 445734 445735 ^ self starting: (DateAndTime year: aYear month: 1 day: 1).! ! 445736TestCase subclass: #YearMonthWeekTest 445737 instanceVariableNames: 'restoredStartDay restoredTimeZone' 445738 classVariableNames: '' 445739 poolDictionaries: '' 445740 category: 'KernelTests-Chronology'! 445741!YearMonthWeekTest commentStamp: 'tlk 1/6/2004 17:55' prior: 0! 445742I am one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. See DateAndEpochTestCase for a complete list. tlk. 445743I have no fixtures but do make sure to restore anything I change.! 445744 445745 445746!YearMonthWeekTest methodsFor: 'running' stamp: 'brp 9/26/2004 19:26'! 445747setUp 445748 restoredStartDay := Week startDay. 445749 restoredTimeZone := DateAndTime localTimeZone. 445750 445751 Week startDay: #Sunday. 445752 DateAndTime localTimeZone: (TimeZone timeZones detect: [:tz | tz abbreviation = 'GMT']).! ! 445753 445754!YearMonthWeekTest methodsFor: 'running' stamp: 'brp 9/26/2004 19:27'! 445755tearDown 445756 Week startDay: restoredStartDay. 445757 DateAndTime localTimeZone: restoredTimeZone.! ! 445758 445759 445760!YearMonthWeekTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 12:51'! 445761testDaysInMonth 445762 self assert: (Month daysInMonth: 2 forYear: 2000) = 29. 445763 self assert: (Month daysInMonth: 2 forYear: 2001) = 28. 445764 self assert: (Month daysInMonth: 2 forYear: 2004) = 29. 445765 self assert: (Month daysInMonth: 2 forYear: 2100) = 28. 445766 445767 self assert: (Month daysInMonth: 'January' forYear: 2003) = 31. 445768 self assert: (Month daysInMonth: 'February' forYear: 2003) = 28. 445769 self assert: (Month daysInMonth: 'March' forYear: 2003) = 31. 445770 self assert: (Month daysInMonth: 'April' forYear: 2003) = 30. 445771 self assert: (Month daysInMonth: 'May' forYear: 2003) = 31. 445772 self assert: (Month daysInMonth: 'June' forYear: 2003) = 30. 445773 self assert: (Month daysInMonth: 'July' forYear: 2003) = 31. 445774 self assert: (Month daysInMonth: 'August' forYear: 2003) = 31. 445775 self assert: (Month daysInMonth: 'September' forYear: 2003) = 30. 445776 self assert: (Month daysInMonth: 'October' forYear: 2003) = 31. 445777 self assert: (Month daysInMonth: 'November' forYear: 2003) = 30. 445778 self assert: (Month daysInMonth: 'December' forYear: 2003) = 31.! ! 445779 445780!YearMonthWeekTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 12:37'! 445781testDaysInYear 445782 self assert: (Year daysInYear: 2000) = 366. 445783 self assert: (Year daysInYear: 2001) = 365. 445784 self assert: (Year daysInYear: 2004) = 366. 445785 self assert: (Year daysInYear: 2100) = 365. 445786 self assert: (Year daysInYear: 2003) = 365.! ! 445787 445788!YearMonthWeekTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 13:37'! 445789testIndexOfDay 445790 self assert: (Week indexOfDay: 'Friday') = 6. 445791 445792! ! 445793 445794!YearMonthWeekTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 12:33'! 445795testIsLeapYear 445796 self assert: (Year isLeapYear: 2000). 445797 self deny: (Year isLeapYear: 2001). 445798 self assert: (Year isLeapYear: 2004). 445799 self deny: (Year isLeapYear: 2100). 445800 self deny: (Year isLeapYear: 2002).! ! 445801 445802!YearMonthWeekTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 445803testMonthPrintOn 445804 | aMonth cs rw | 445805 aMonth := Month 445806 starting: DateAndTime new 445807 duration: 31 days. 445808 cs := 'January 1901' readStream. 445809 rw := ReadWriteStream on: ''. 445810 aMonth printOn: rw. 445811 self assert: rw contents = cs contents! ! 445812 445813!YearMonthWeekTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 13:34'! 445814testStartDay 445815 Week startDay: 'Wednesday'. 445816 self assert: Week startDay = 'Wednesday'. 445817 Week startDay: 'Thursday'. 445818 self assert: Week startDay = 'Thursday'. 445819 445820! ! 445821 445822!YearMonthWeekTest methodsFor: 'testing' stamp: 'PeterHugossonMiller 9/3/2009 11:51'! 445823testWeekPrintOn 445824 | aWeek cs rw | 445825 aWeek := Week starting: (DateAndTime year: 1900 month: 12 day: 31). 445826 cs := 'a Week starting: 1900-12-30T00:00:00+00:00'. 445827 rw := String new writeStream. 445828 aWeek printOn: rw. 445829 self assert: rw contents = cs! ! 445830 445831!YearMonthWeekTest methodsFor: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! 445832testYearPrintOn 445833 | aYear cs rw | 445834 aYear := Year 445835 starting: DateAndTime new 445836 duration: 365 days. 445837 cs := 'a Year (1901)' readStream. 445838 rw := ReadWriteStream on: ''. 445839 aYear printOn: rw. 445840 self assert: rw contents = cs contents! ! 445841ClassTestCase subclass: #YearTest 445842 instanceVariableNames: '' 445843 classVariableNames: '' 445844 poolDictionaries: '' 445845 category: 'KernelTests-Chronology'! 445846 445847!YearTest methodsFor: 'Coverage' stamp: 'brp 9/11/2003 14:31'! 445848classToBeTested 445849 445850 ^ Year! ! 445851 445852 445853!YearTest methodsFor: 'Tests' stamp: 'brp 9/11/2003 14:30'! 445854testCurrent 445855 445856 | yyyy | 445857 445858 yyyy := DateAndTime now year. 445859 445860 self assert: Year current start = (DateAndTime year: yyyy month: 1 day: 1)! ! 445861FastInflateStream subclass: #ZLibReadStream 445862 instanceVariableNames: '' 445863 classVariableNames: '' 445864 poolDictionaries: '' 445865 category: 'Compression-Streams'! 445866 445867!ZLibReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 03:30'! 445868updateCrc: oldCrc from: start to: stop in: aCollection 445869 "Answer an updated CRC for the range of bytes in aCollection" 445870 ^ZLibWriteStream updateAdler32: oldCrc from: start to: stop in: aCollection.! ! 445871 445872!ZLibReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:21'! 445873verifyCrc 445874 | stored | 445875 stored := 0. 445876 24 to: 0 by: -8 do: [ :i | 445877 sourcePos >= sourceLimit ifTrue: [ ^ self crcError: 'No checksum (proceed to ignore)' ]. 445878 stored := stored + (self nextByte bitShift: i) ]. 445879 stored = crc ifFalse: [ ^ self crcError: 'Wrong checksum (proceed to ignore)' ]. 445880 ^stored! ! 445881 445882 445883!ZLibReadStream methodsFor: 'initialize' stamp: 'ar 2/29/2004 03:31'! 445884on: aCollection from: firstIndex to: lastIndex 445885 "Check the header of the ZLib stream." 445886 | method byte | 445887 super on: aCollection from: firstIndex to: lastIndex. 445888 crc := 1. 445889 method := self nextBits: 8. 445890 (method bitAnd: 15) = 8 ifFalse:[^self error:'Unknown compression method']. 445891 (method bitShift: -4) + 8 > 15 ifTrue:[^self error:'Invalid window size']. 445892 byte := self nextBits: 8. 445893 (method bitShift: 8) + byte \\ 31 = 0 ifFalse:[^self error:'Incorrect header']. 445894 (byte anyMask: 32) ifTrue:[^self error:'Need preset dictionary']. 445895! ! 445896ZipWriteStream subclass: #ZLibWriteStream 445897 instanceVariableNames: '' 445898 classVariableNames: '' 445899 poolDictionaries: '' 445900 category: 'Compression-Streams'! 445901 445902!ZLibWriteStream methodsFor: 'initialization' stamp: 'nk 2/17/2004 16:28'! 445903on: aCollectionOrStream 445904 super on: aCollectionOrStream. 445905 crc := 1.! ! 445906 445907!ZLibWriteStream methodsFor: 'initialization' stamp: 'nk 2/17/2004 16:53'! 445908updateCrc: adler from: start to: stop in: aCollection 445909 "Update crc using the Adler32 checksum technique from RFC1950" 445910 ^self class updateAdler32: adler from: start to: stop in: aCollection! ! 445911 445912!ZLibWriteStream methodsFor: 'initialization' stamp: 'ar 2/29/2004 04:40'! 445913writeFooter 445914 "Store the Adler32 checksum as the last 4 bytes." 445915 3 to: 0 by: -1 do:[:i| encoder nextBytePut: (crc >> (i*8) bitAnd: 255)].! ! 445916 445917!ZLibWriteStream methodsFor: 'initialization' stamp: 'nk 2/17/2004 18:23'! 445918writeHeader 445919 "Write header information" 445920 encoder nextBits: 8 put: 120. "deflate method with 15bit window size" 445921 encoder nextBits: 8 put: 94. "checksum; no preset; fast (flevel=1) compression"! ! 445922 445923"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 445924 445925ZLibWriteStream class 445926 instanceVariableNames: ''! 445927 445928!ZLibWriteStream class methodsFor: 'crc' stamp: 'ar 2/29/2004 04:40'! 445929updateAdler32: adler from: start to: stop in: aCollection 445930 "Update crc using the Adler32 checksum technique from RFC1950" 445931" 445932 unsigned long s1 = adler & 0xffff; 445933 unsigned long s2 = (adler >> 16) & 0xffff; 445934 int n; 445935 445936 for (n = 0; n < len; n++) { 445937 s1 = (s1 + buf[n]) % BASE; 445938 s2 = (s2 + s1) % BASE; 445939 } 445940 return (s2 << 16) + s1; 445941" 445942 | s1 s2 | 445943 s1 := adler bitAnd: 16rFFFF. 445944 s2 := (adler bitShift: -16) bitAnd: 16rFFFF. 445945 start to: stop do: [ :n | | b | 445946 b := aCollection byteAt: n. 445947 s1 := (s1 + b) \\ 65521. 445948 s2 := (s2 + s1) \\ 65521. ]. 445949 ^(s2 bitShift: 16) + s1! ! 445950ArithmeticError subclass: #ZeroDivide 445951 instanceVariableNames: 'dividend' 445952 classVariableNames: '' 445953 poolDictionaries: '' 445954 category: 'Exceptions-Kernel'! 445955!ZeroDivide commentStamp: '<historical>' prior: 0! 445956ZeroDivide may be signaled when a mathematical division by 0 is attempted.! 445957 445958 445959!ZeroDivide methodsFor: 'exceptionbuilder' stamp: 'pnm 8/16/2000 15:05'! 445960dividend: argument 445961 "Specify the number that was being divided by zero." 445962 445963 dividend := argument! ! 445964 445965 445966!ZeroDivide methodsFor: 'exceptiondescription' stamp: 'tfei 6/5/1999 17:29'! 445967dividend 445968 "Answer the number that was being divided by zero." 445969 445970 ^dividend! ! 445971 445972!ZeroDivide methodsFor: 'exceptiondescription' stamp: 'pnm 8/16/2000 15:05'! 445973isResumable 445974 "Determine whether an exception is resumable." 445975 445976 ^true! ! 445977 445978"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 445979 445980ZeroDivide class 445981 instanceVariableNames: ''! 445982 445983!ZeroDivide class methodsFor: 'exceptioninstantiator' stamp: 'bf 9/27/1999 17:26'! 445984dividend: argument 445985 ^self new dividend: argument; yourself! ! 445986 445987 445988!ZeroDivide class methodsFor: 'signaling' stamp: 'GabrielOmarCotelli 6/6/2009 17:12'! 445989signalWithDividend: aDividend 445990 445991 ^(self dividend: aDividend) signal! ! 445992Archive subclass: #ZipArchive 445993 instanceVariableNames: 'centralDirectorySize centralDirectoryOffsetWRTStartingDiskNumber zipFileComment writeCentralDirectoryOffset writeEOCDOffset' 445994 classVariableNames: '' 445995 poolDictionaries: 'ZipFileConstants' 445996 category: 'Compression-Archives'! 445997!ZipArchive commentStamp: '<historical>' prior: 0! 445998A ZipArchive represents an archive that is read and/or written using the PKZIP file format. 445999 446000ZipArchive instances know how to read and write such archives; their members are subinstances of ZipArchiveMember.! 446001 446002 446003!ZipArchive methodsFor: 'accessing' stamp: 'ar 3/1/2006 23:21'! 446004hasMemberSuchThat: aBlock 446005 "Answer whether we have a member satisfying the given condition" 446006 ^self members anySatisfy: aBlock! ! 446007 446008!ZipArchive methodsFor: 'accessing' stamp: 'nk 3/27/2002 11:23'! 446009prependedDataSize 446010 "Answer the size of whatever data exists before my first member. 446011 Assumes that I was read from a file or stream (i.e. the first member is a ZipFileMember)" 446012 ^members isEmpty 446013 ifFalse: [ members first localHeaderRelativeOffset ] 446014 ifTrue: [ centralDirectoryOffsetWRTStartingDiskNumber ]! ! 446015 446016!ZipArchive methodsFor: 'accessing' stamp: 'nk 2/24/2001 13:44'! 446017zipFileComment 446018 ^zipFileComment asString! ! 446019 446020!ZipArchive methodsFor: 'accessing' stamp: 'nk 2/24/2001 13:43'! 446021zipFileComment: aString 446022 zipFileComment := aString! ! 446023 446024 446025!ZipArchive methodsFor: 'archive operations' stamp: 'ar 3/1/2006 23:21'! 446026addDeflateString: aString as: aFileName 446027 "Add a verbatim string under the given file name" 446028 | mbr | 446029 mbr := self addString: aString as: aFileName. 446030 mbr desiredCompressionMethod: CompressionDeflated. 446031 ^mbr! ! 446032 446033!ZipArchive methodsFor: 'archive operations' stamp: 'sd 3/28/2008 11:03'! 446034extractAllTo: aDirectory 446035 "Extract all elements to the given directory" 446036 UIManager default informUserDuring: 446037 [ :bar | 446038 self 446039 extractAllTo: aDirectory 446040 informing: bar ]! ! 446041 446042!ZipArchive methodsFor: 'archive operations' stamp: 'ar 2/6/2004 13:20'! 446043extractAllTo: aDirectory informing: bar 446044 "Extract all elements to the given directory" 446045 ^self extractAllTo: aDirectory informing: bar overwrite: false! ! 446046 446047!ZipArchive methodsFor: 'archive operations' stamp: 'ar 2/6/2004 13:20'! 446048extractAllTo: aDirectory informing: bar overwrite: allOverwrite 446049 "Extract all elements to the given directory" 446050 | dir overwriteAll response | 446051 overwriteAll := allOverwrite. 446052 self members do:[:entry| 446053 entry isDirectory ifTrue:[ 446054 bar ifNotNil:[bar value: 'Creating ', entry fileName]. 446055 dir := (entry fileName findTokens:'/') 446056 inject: aDirectory into:[:base :part| base directoryNamed: part]. 446057 dir assureExistence. 446058 ]. 446059 ]. 446060 self members do:[:entry| 446061 entry isDirectory ifFalse:[ 446062 bar ifNotNil:[bar value: 'Extracting ', entry fileName]. 446063 response := entry extractInDirectory: aDirectory overwrite: overwriteAll. 446064 response == #retryWithOverwrite ifTrue:[ 446065 overwriteAll := true. 446066 response := entry extractInDirectory: aDirectory overwrite: overwriteAll. 446067 ]. 446068 response == #abort ifTrue:[^self]. 446069 response == #failed ifTrue:[ 446070 (self confirm: 'Failed to extract ', entry fileName, '. Proceed?') ifFalse:[^self]. 446071 ]. 446072 ]. 446073 ]. 446074! ! 446075 446076 446077!ZipArchive methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:47'! 446078close 446079 self members do:[:m| m close].! ! 446080 446081!ZipArchive methodsFor: 'initialization' stamp: 'nk 2/22/2001 17:20'! 446082initialize 446083 super initialize. 446084 writeEOCDOffset := writeCentralDirectoryOffset := 0. 446085 zipFileComment := ''. 446086! ! 446087 446088 446089!ZipArchive methodsFor: 'reading' stamp: 'nk 12/16/2002 17:09'! 446090readFrom: aStreamOrFileName 446091 | stream name eocdPosition | 446092 stream := aStreamOrFileName isStream 446093 ifTrue: [name := aStreamOrFileName name. aStreamOrFileName] 446094 ifFalse: [StandardFileStream readOnlyFileNamed: (name := aStreamOrFileName)]. 446095 stream binary. 446096 eocdPosition := self class findEndOfCentralDirectoryFrom: stream. 446097 eocdPosition <= 0 ifTrue: [self error: 'can''t find EOCD position']. 446098 self readEndOfCentralDirectoryFrom: stream. 446099 stream position: eocdPosition - centralDirectorySize. 446100 self readMembersFrom: stream named: name! ! 446101 446102 446103!ZipArchive methodsFor: 'writing' stamp: 'nk 2/23/2001 10:29'! 446104writeTo: stream 446105 stream binary. 446106 members do: [ :member | 446107 member writeTo: stream. 446108 member endRead. 446109 ]. 446110 writeCentralDirectoryOffset := stream position. 446111 self writeCentralDirectoryTo: stream. 446112 ! ! 446113 446114!ZipArchive methodsFor: 'writing' stamp: 'nk 3/27/2002 10:42'! 446115writeTo: stream prepending: aString 446116 stream binary. 446117 stream nextPutAll: aString. 446118 members do: [ :member | 446119 member writeTo: stream. 446120 member endRead. 446121 ]. 446122 writeCentralDirectoryOffset := stream position. 446123 self writeCentralDirectoryTo: stream. 446124 ! ! 446125 446126!ZipArchive methodsFor: 'writing' stamp: 'nk 3/27/2002 12:41'! 446127writeTo: stream prependingFileNamed: aFileName 446128 | prepended buffer | 446129 stream binary. 446130 prepended := StandardFileStream readOnlyFileNamed: aFileName. 446131 prepended binary. 446132 buffer := ByteArray new: (prepended size min: 32768). 446133 [ prepended atEnd ] whileFalse: [ | bytesRead | 446134 bytesRead := prepended readInto: buffer startingAt: 1 count: buffer size. 446135 stream next: bytesRead putAll: buffer startingAt: 1 446136 ]. 446137 members do: [ :member | 446138 member writeTo: stream. 446139 member endRead. 446140 ]. 446141 writeCentralDirectoryOffset := stream position. 446142 self writeCentralDirectoryTo: stream. 446143 ! ! 446144 446145!ZipArchive methodsFor: 'writing' stamp: 'nk 3/27/2002 12:45'! 446146writeToFileNamed: aFileName prepending: aString 446147 | stream | 446148 "Catch attempts to overwrite existing zip file" 446149 (self canWriteToFileNamed: aFileName) 446150 ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ]. 446151 stream := StandardFileStream forceNewFileNamed: aFileName. 446152 self writeTo: stream prepending: aString. 446153 stream close.! ! 446154 446155!ZipArchive methodsFor: 'writing' stamp: 'nk 3/27/2002 12:58'! 446156writeToFileNamed: aFileName prependingFileNamed: anotherFileName 446157 | stream | 446158 "Catch attempts to overwrite existing zip file" 446159 (self canWriteToFileNamed: aFileName) 446160 ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ]. 446161 stream := StandardFileStream forceNewFileNamed: aFileName. 446162 self writeTo: stream prependingFileNamed: anotherFileName. 446163 stream close.! ! 446164 446165 446166!ZipArchive methodsFor: 'private' stamp: 'nk 2/21/2001 18:26'! 446167memberClass 446168 ^ZipArchiveMember! ! 446169 446170!ZipArchive methodsFor: 'private' stamp: 'nk 2/22/2001 17:19'! 446171readEndOfCentralDirectoryFrom: aStream 446172 "Read EOCD, starting from position before signature." 446173 | signature zipFileCommentLength | 446174 signature := self readSignatureFrom: aStream. 446175 signature = EndOfCentralDirectorySignature ifFalse: [ ^self error: 'bad signature at ', aStream position printString ]. 446176 446177 aStream nextLittleEndianNumber: 2. "# of this disk" 446178 aStream nextLittleEndianNumber: 2. "# of disk with central dir start" 446179 aStream nextLittleEndianNumber: 2. "# of entries in central dir on this disk" 446180 aStream nextLittleEndianNumber: 2. "total # of entries in central dir" 446181 centralDirectorySize := aStream nextLittleEndianNumber: 4. "size of central directory" 446182 centralDirectoryOffsetWRTStartingDiskNumber := aStream nextLittleEndianNumber: 4. "offset of start of central directory" 446183 zipFileCommentLength := aStream nextLittleEndianNumber: 2. "zip file comment" 446184 zipFileComment := aStream next: zipFileCommentLength. 446185! ! 446186 446187!ZipArchive methodsFor: 'private' stamp: 'BG 3/16/2005 08:28'! 446188readMembersFrom: stream named: fileName 446189 | newMember signature | 446190 [ 446191 newMember := self memberClass newFromZipFile: stream named: fileName. 446192 signature := self readSignatureFrom: stream. 446193 signature = EndOfCentralDirectorySignature ifTrue: [ ^self ]. 446194 signature = CentralDirectoryFileHeaderSignature 446195 ifFalse: [ self error: 'bad CD signature at ', (stream position - 4) printStringHex ]. 446196 newMember readFrom: stream. 446197 newMember looksLikeDirectory ifTrue: [ newMember := newMember asDirectory ]. 446198 self addMember: newMember. 446199 ] repeat.! ! 446200 446201!ZipArchive methodsFor: 'private' stamp: 'nk 8/21/2004 15:22'! 446202readSignatureFrom: stream 446203 "Returns next signature from given stream, leaves stream positioned afterwards." 446204 446205 | signatureData | 446206 signatureData := ByteArray new: 4. 446207 stream next: 4 into: signatureData. 446208 ({ CentralDirectoryFileHeaderSignature . LocalFileHeaderSignature . EndOfCentralDirectorySignature } 446209 includes: signatureData) 446210 ifFalse: [ ^self error: 'bad signature ', signatureData asString asHex, ' at position ', (stream position - 4) asString ]. 446211 ^signatureData 446212! ! 446213 446214!ZipArchive methodsFor: 'private' stamp: 'nk 2/21/2001 20:19'! 446215writeCentralDirectoryTo: aStream 446216 | offset | 446217 offset := writeCentralDirectoryOffset. 446218 members do: [ :member | 446219 member writeCentralDirectoryFileHeaderTo: aStream. 446220 offset := offset + member centralDirectoryHeaderSize. 446221 ]. 446222 writeEOCDOffset := offset. 446223 self writeEndOfCentralDirectoryTo: aStream. 446224 446225! ! 446226 446227!ZipArchive methodsFor: 'private' stamp: 'nk 2/21/2001 21:02'! 446228writeEndOfCentralDirectoryTo: aStream 446229 446230 aStream nextPutAll: EndOfCentralDirectorySignature. 446231 aStream nextLittleEndianNumber: 2 put: 0. "diskNumber" 446232 aStream nextLittleEndianNumber: 2 put: 0. "diskNumberWithStartOfCentralDirectory" 446233 aStream nextLittleEndianNumber: 2 put: members size. "numberOfCentralDirectoriesOnThisDisk" 446234 aStream nextLittleEndianNumber: 2 put: members size. "numberOfCentralDirectories" 446235 aStream nextLittleEndianNumber: 4 put: writeEOCDOffset - writeCentralDirectoryOffset. "size of central dir" 446236 aStream nextLittleEndianNumber: 4 put: writeCentralDirectoryOffset. "offset of central dir" 446237 aStream nextLittleEndianNumber: 2 put: zipFileComment size. "zip file comment" 446238 zipFileComment isEmpty ifFalse: [ aStream nextPutAll: zipFileComment ]. 446239 446240! ! 446241 446242"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 446243 446244ZipArchive class 446245 instanceVariableNames: ''! 446246 446247!ZipArchive class methodsFor: 'constants' stamp: 'nk 2/22/2001 14:13'! 446248compressionDeflated 446249 ^CompressionDeflated! ! 446250 446251!ZipArchive class methodsFor: 'constants' stamp: 'nk 2/22/2001 14:12'! 446252compressionLevelDefault 446253 ^CompressionLevelDefault! ! 446254 446255!ZipArchive class methodsFor: 'constants' stamp: 'nk 2/22/2001 14:12'! 446256compressionLevelNone 446257 ^CompressionLevelNone ! ! 446258 446259!ZipArchive class methodsFor: 'constants' stamp: 'nk 2/22/2001 14:13'! 446260compressionStored 446261 ^CompressionStored! ! 446262 446263!ZipArchive class methodsFor: 'constants' stamp: 'nk 8/21/2004 15:19'! 446264findEndOfCentralDirectoryFrom: stream 446265 "Seek in the given stream to the end, then read backwards until we find the 446266 signature of the central directory record. Leave the file positioned right 446267 before the signature. 446268 446269 Answers the file position of the EOCD, or 0 if not found." 446270 446271 | data fileLength seekOffset pos maxOffset | 446272 stream setToEnd. 446273 fileLength := stream position. 446274 "If the file length is less than 18 for the EOCD length plus 4 for the signature, we have a problem" 446275 fileLength < 22 ifTrue: [^ self error: 'file is too short']. 446276 446277 seekOffset := 0. 446278 pos := 0. 446279 data := ByteArray new: 4100. 446280 maxOffset := 40960 min: fileLength. "limit search range to 40K" 446281 446282 [ 446283 seekOffset := (seekOffset + 4096) min: fileLength. 446284 stream position: fileLength - seekOffset. 446285 data := stream next: (4100 min: seekOffset) into: data startingAt: 1. 446286 pos := data lastIndexOfPKSignature: EndOfCentralDirectorySignature. 446287 pos = 0 and: [seekOffset < maxOffset] 446288 ] whileTrue. 446289 446290 ^ pos > 0 446291 ifTrue: [ | newPos | stream position: (newPos := (stream position + pos - seekOffset - 1)). newPos] 446292 ifFalse: [0]! ! 446293 446294!ZipArchive class methodsFor: 'constants' stamp: 'ar 2/27/2001 13:38'! 446295validSignatures 446296 "Return the valid signatures for a zip file" 446297 ^Array 446298 with: LocalFileHeaderSignature 446299 with: CentralDirectoryFileHeaderSignature 446300 with: EndOfCentralDirectorySignature! ! 446301 446302 446303!ZipArchive class methodsFor: 'file format' stamp: 'di 3/6/2002 21:20'! 446304isZipArchive: aStreamOrFileName 446305 "Answer whether the given filename represents a valid zip file." 446306 446307 | stream eocdPosition | 446308 stream := aStreamOrFileName isStream 446309 ifTrue: [aStreamOrFileName] 446310 ifFalse: [StandardFileStream oldFileNamed: aStreamOrFileName]. 446311 stream ifNil: [^ false]. 446312 "nil happens sometimes somehow" 446313 stream size < 22 ifTrue: [^ false]. 446314 stream binary. 446315 eocdPosition := self findEndOfCentralDirectoryFrom: stream. 446316 stream ~= aStreamOrFileName ifTrue: [stream close]. 446317 ^ eocdPosition > 0! ! 446318ArchiveMember subclass: #ZipArchiveMember 446319 instanceVariableNames: 'lastModFileDateTime fileAttributeFormat versionMadeBy versionNeededToExtract bitFlag compressionMethod desiredCompressionMethod desiredCompressionLevel internalFileAttributes externalFileAttributes cdExtraField localExtraField fileComment crc32 compressedSize uncompressedSize writeLocalHeaderRelativeOffset readDataRemaining' 446320 classVariableNames: '' 446321 poolDictionaries: 'ZipFileConstants' 446322 category: 'Compression-Archives'! 446323!ZipArchiveMember commentStamp: '<historical>' prior: 0! 446324Subinstances of me are members in a ZipArchive. 446325They represent different data sources: 446326 * ZipDirectoryMember -- a directory to be added to a zip file 446327 * ZipFileMember -- a file or directory that is already in a zip file 446328 * ZipNewFilemember -- a file that is to be added to a zip file 446329 * ZipStringMember -- a string that is to be added to a zip file 446330 446331They can write their data to another stream either copying, compressing, 446332or decompressing as desired.! 446333 446334 446335!ZipArchiveMember methodsFor: 'accessing' stamp: 'yo 2/24/2005 18:34'! 446336centralDirectoryHeaderSize 446337 446338 | systemFileName systemFileComment systemCdExtraField | 446339 systemFileName := fileName asVmPathName. 446340 systemFileComment := fileComment convertToSystemString. 446341 systemCdExtraField := cdExtraField. 446342 ^ 46 + systemFileName size + systemCdExtraField size + systemFileComment size 446343! ! 446344 446345!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/23/2001 08:00'! 446346clearExtraFields 446347 cdExtraField := ''. 446348 localExtraField := ''.! ! 446349 446350!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:38'! 446351compressedSize 446352 "Return the compressed size for this member. 446353 This will not be set for members that were constructed from strings 446354 or external files until after the member has been written." 446355 ^compressedSize! ! 446356 446357!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 22:02'! 446358compressionMethod 446359 "Returns my compression method. This is the method that is 446360 currently being used to compress my data. 446361 446362 This will be CompressionStored for added string or file members, 446363 or CompressionStored or CompressionDeflated (others are possible but not handled)" 446364 446365 ^compressionMethod! ! 446366 446367!ZipArchiveMember methodsFor: 'accessing' stamp: 'mir 8/5/2004 11:00'! 446368contentStream 446369 "Answer my contents as a text stream. 446370 Default is no conversion, since we don't know what the bytes mean." 446371 446372 | s | 446373 s := MultiByteBinaryOrTextStream on: (String new: self uncompressedSize). 446374 s converter: Latin1TextConverter new. 446375 self extractTo: s. 446376 s reset. 446377 ^ s. 446378! ! 446379 446380!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:28'! 446381crc32 446382 ^crc32! ! 446383 446384!ZipArchiveMember methodsFor: 'accessing' stamp: 'BG 3/16/2005 08:19'! 446385crc32String 446386 | hexString | 446387 hexString := crc32 storeStringHex. 446388 ^('00000000' copyFrom: 1 to: 11 - (hexString size)) , (hexString copyFrom: 4 to: hexString size)! ! 446389 446390!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 22:10'! 446391desiredCompressionLevel 446392 ^desiredCompressionLevel! ! 446393 446394!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 22:14'! 446395desiredCompressionLevel: aNumber 446396 "Set my desiredCompressionLevel 446397 This is the method that will be used to write. 446398 Returns prior desiredCompressionLevel. 446399 446400 Valid arguments are 0 (CompressionLevelNone) through 9, 446401 including 6 (CompressionLevelDefault). 446402 446403 0 (CompressionLevelNone) will change the desiredCompressionMethod 446404 to CompressionStored. All other arguments will change the 446405 desiredCompressionMethod to CompressionDeflated." 446406 446407 | old | 446408 old := desiredCompressionLevel. 446409 desiredCompressionLevel := aNumber. 446410 desiredCompressionMethod := (aNumber > 0) 446411 ifTrue: [ CompressionDeflated ] 446412 ifFalse: [ CompressionStored ]. 446413 ^old! ! 446414 446415!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 22:03'! 446416desiredCompressionMethod 446417 "Get my desiredCompressionMethod. 446418 This is the method that will be used to write" 446419 446420 ^desiredCompressionMethod! ! 446421 446422!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/23/2001 11:25'! 446423desiredCompressionMethod: aNumber 446424 "Set my desiredCompressionMethod 446425 This is the method that will be used to write. 446426 Answers prior desiredCompressionMethod. 446427 446428 Only CompressionDeflated or CompressionStored are valid arguments. 446429 446430 Changing to CompressionStored will change my desiredCompressionLevel 446431 to CompressionLevelNone; changing to CompressionDeflated will change my 446432 desiredCompressionLevel to CompressionLevelDefault." 446433 446434 | old | 446435 old := desiredCompressionMethod. 446436 desiredCompressionMethod := aNumber. 446437 desiredCompressionLevel := (aNumber = CompressionDeflated) 446438 ifTrue: [ CompressionLevelDefault ] 446439 ifFalse: [ CompressionLevelNone ]. 446440 compressionMethod = CompressionStored ifTrue: [ compressedSize := uncompressedSize ]. 446441 ^old.! ! 446442 446443!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/26/2003 13:06'! 446444extractToFileNamed: aLocalFileName inDirectory: dir 446445 | stream fullName fullDir | 446446 self isEncrypted ifTrue: [ ^self error: 'encryption unsupported' ]. 446447 fullName := dir fullNameFor: aLocalFileName. 446448 fullDir := FileDirectory forFileName: fullName. 446449 fullDir assureExistence. 446450 self isDirectory ifFalse: [ 446451 stream := fullDir forceNewFileNamed: (FileDirectory localNameFor: fullName). 446452 self extractTo: stream. 446453 stream close. 446454 ] ifTrue: [ fullDir assureExistence ] 446455! ! 446456 446457!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:25'! 446458fileComment 446459 ^fileComment! ! 446460 446461!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:25'! 446462fileComment: aString 446463 fileComment := aString! ! 446464 446465!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/24/2001 14:34'! 446466lastModTime 446467 "Return my last modification date/time stamp, 446468 converted to Squeak seconds" 446469 446470 ^self unixToSqueakTime: (self dosToUnixTime: lastModFileDateTime)! ! 446471 446472!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 3/13/2003 09:23'! 446473localFileName 446474 "Answer my fileName in terms of the local directory naming convention" 446475 | localName | 446476 localName := fileName copyReplaceAll: '/' with: FileDirectory slash. 446477 ^(fileName first = $/) 446478 ifTrue: [ FileDirectory default class makeAbsolute: localName ] 446479 ifFalse: [ FileDirectory default class makeRelative: localName ]! ! 446480 446481!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 23:39'! 446482setLastModFileDateTimeFrom: aSmalltalkTime 446483 | unixTime | 446484 unixTime := aSmalltalkTime - 2177424000. "PST?" 446485 lastModFileDateTime := self unixToDosTime: unixTime! ! 446486 446487!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 11/11/2002 21:03'! 446488splitFileName 446489 "Answer my name split on slash boundaries. A directory will have a trailing empty string." 446490 ^ fileName findTokens: '/'.! ! 446491 446492!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:38'! 446493uncompressedSize 446494 "Return the uncompressed size for this member." 446495 ^uncompressedSize! ! 446496 446497!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:18'! 446498unixFileAttributes 446499 ^self mapPermissionsToUnix: externalFileAttributes.! ! 446500 446501!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:24'! 446502unixFileAttributes: perms 446503 | oldPerms newPerms | 446504 oldPerms := self mapPermissionsToUnix: externalFileAttributes. 446505 newPerms := self isDirectory 446506 ifTrue: [ (perms bitAnd: FileAttrib bitInvert) bitOr: DirectoryAttrib ] 446507 ifFalse: [ (perms bitAnd: DirectoryAttrib bitInvert) bitOr: FileAttrib ]. 446508 externalFileAttributes := self mapPermissionsFromUnix: newPerms. 446509 ^oldPerms.! ! 446510 446511 446512!ZipArchiveMember methodsFor: 'extraction' stamp: 'nk 12/20/2002 14:49'! 446513extractInDirectory: dir 446514 self extractToFileNamed: self localFileName inDirectory: dir 446515! ! 446516 446517!ZipArchiveMember methodsFor: 'extraction' stamp: 'rbb 2/18/2005 14:42'! 446518extractInDirectory: aDirectory overwrite: overwriteAll 446519 "Extract this entry into the given directory. Answer #okay, #failed, #abort, or #retryWithOverwrite." 446520 | path fileDir file index localName | 446521 path := fileName findTokens:'/'. 446522 localName := path last. 446523 fileDir := path allButLast inject: aDirectory into:[:base :part| base directoryNamed: part]. 446524 fileDir assureExistence. 446525 file := [fileDir newFileNamed: localName] on: FileExistsException do:[:ex| ex return: nil]. 446526 file ifNil:[ 446527 overwriteAll ifFalse:[ 446528 [index := UIManager default chooseFrom: { 446529 'Yes, overwrite'. 446530 'No, don''t overwrite'. 446531 'Overwrite ALL files'. 446532 'Cancel operation' 446533 } lines: #(2) title: fileName, ' already exists. Overwrite?'. 446534 index == nil] whileTrue. 446535 index = 4 ifTrue:[^#abort]. 446536 index = 3 ifTrue:[^#retryWithOverwrite]. 446537 index = 2 ifTrue:[^#okay]. 446538 ]. 446539 file := [fileDir forceNewFileNamed: localName] on: Error do:[:ex| ex return]. 446540 file ifNil:[^#failed]. 446541 ]. 446542 self extractTo: file. 446543 file close. 446544 ^#okay! ! 446545 446546!ZipArchiveMember methodsFor: 'extraction' stamp: 'nk 2/22/2001 18:03'! 446547extractTo: aStream 446548 | oldCompression | 446549 self isEncrypted ifTrue: [ self error: 'encryption is unsupported' ]. 446550 aStream binary. 446551 oldCompression := self desiredCompressionMethod: CompressionStored. 446552 self rewindData. 446553 self writeDataTo: aStream. 446554 self desiredCompressionMethod: oldCompression. 446555 self endRead.! ! 446556 446557!ZipArchiveMember methodsFor: 'extraction' stamp: 'nk 2/24/2001 18:03'! 446558extractTo: aStream from: start to: finish 446559 | oldCompression | 446560 self isEncrypted ifTrue: [ self error: 'encryption is unsupported' ]. 446561 aStream binary. 446562 oldCompression := self desiredCompressionMethod: CompressionStored. 446563 self rewindData. 446564 self writeDataTo: aStream from: start to: finish. 446565 self desiredCompressionMethod: oldCompression. 446566 self endRead.! ! 446567 446568!ZipArchiveMember methodsFor: 'extraction' stamp: 'nk 11/11/2002 14:08'! 446569extractToFileNamed: aFileName 446570 self extractToFileNamed: aFileName inDirectory: FileDirectory default.! ! 446571 446572 446573!ZipArchiveMember methodsFor: 'initialization' stamp: 'nk 2/24/2001 16:16'! 446574initialize 446575 super initialize. 446576 lastModFileDateTime := 0. 446577 fileAttributeFormat := FaUnix. 446578 versionMadeBy := 20. 446579 versionNeededToExtract := 20. 446580 bitFlag := 0. 446581 compressionMethod := CompressionStored. 446582 desiredCompressionMethod := CompressionDeflated. 446583 desiredCompressionLevel := CompressionLevelDefault. 446584 internalFileAttributes := 0. 446585 externalFileAttributes := 0. 446586 fileName := ''. 446587 cdExtraField := ''. 446588 localExtraField := ''. 446589 fileComment := ''. 446590 crc32 := 0. 446591 compressedSize := 0. 446592 uncompressedSize := 0. 446593 self unixFileAttributes: DefaultFilePermissions.! ! 446594 446595 446596!ZipArchiveMember methodsFor: 'reading' stamp: 'nk 2/24/2001 22:28'! 446597contents 446598 "Answer my contents as a string." 446599 | s | 446600 s := RWBinaryOrTextStream on: (String new: self uncompressedSize). 446601 self extractTo: s. 446602 s text. 446603 ^s contents! ! 446604 446605!ZipArchiveMember methodsFor: 'reading' stamp: 'nk 2/24/2001 23:53'! 446606contentsFrom: start to: finish 446607 "Answer my contents as a string." 446608 | s | 446609 s := RWBinaryOrTextStream on: (String new: finish - start + 1). 446610 self extractTo: s from: start to: finish. 446611 s text. 446612 ^s contents! ! 446613 446614 446615!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:40'! 446616hasDataDescriptor 446617 ^ (bitFlag bitAnd: 8) ~= 0 "GPBF:=HAS:=DATA:=DESCRIPTOR:=MASK"! ! 446618 446619!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:00'! 446620isDirectory 446621 ^false! ! 446622 446623!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:39'! 446624isEncrypted 446625 "Return true if this member is encrypted (this is unsupported)" 446626 ^ (bitFlag bitAnd: 1) ~= 0! ! 446627 446628!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:41'! 446629isTextFile 446630 "Returns true if I am a text file. 446631 Note that this module does not currently do anything with this flag 446632 upon extraction or storage. 446633 That is, bytes are stored in native format whether or not they came 446634 from a text file." 446635 ^ (internalFileAttributes bitAnd: 1) ~= 0 446636! ! 446637 446638!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:43'! 446639isTextFile: aBoolean 446640 "Set whether I am a text file. 446641 Note that this module does not currently do anything with this flag 446642 upon extraction or storage. 446643 That is, bytes are stored in native format whether or not they came 446644 from a text file." 446645 internalFileAttributes := aBoolean 446646 ifTrue: [ internalFileAttributes bitOr: 1 ] 446647 ifFalse: [ internalFileAttributes bitAnd: 1 bitInvert ] 446648! ! 446649 446650!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/21/2001 20:38'! 446651looksLikeDirectory 446652 ^false! ! 446653 446654 446655!ZipArchiveMember methodsFor: 'writing' stamp: 'nk 2/23/2001 11:28'! 446656writeTo: aStream 446657 self rewindData. 446658 writeLocalHeaderRelativeOffset := aStream position. 446659 self writeLocalFileHeaderTo: aStream. 446660 self writeDataTo: aStream. 446661 self refreshLocalFileHeaderTo: aStream.! ! 446662 446663 446664!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/21/2001 21:55'! 446665asDirectory 446666 ^ZipDirectoryMember new copyFrom: self! ! 446667 446668!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/21/2001 23:54'! 446669dosToUnixTime: dt 446670 "DOS years start at 1980, Unix at 1970, and Smalltalk at 1901. 446671 So the Smalltalk seconds will be high by 69 years when used as Unix time:=t values. 446672 So shift 1980 back to 1911..." 446673 | year mon mday hour min sec date time | 446674 446675 year := (( dt bitShift: -25 ) bitAnd: 16r7F ) + 1911. 446676 mon := (( dt bitShift: -21 ) bitAnd: 16r0F ). 446677 mday := (( dt bitShift: -16 ) bitAnd: 16r1F ). 446678 date := Date newDay: mday month: mon year: year. 446679 446680 hour := (( dt bitShift: -11 ) bitAnd: 16r1F ). 446681 min := (( dt bitShift: -5 ) bitAnd: 16r3F ). 446682 sec := (( dt bitShift: 1 ) bitAnd: 16r3E ). 446683 time := ((( hour * 60 ) + min ) * 60 ) + sec. 446684 446685 ^date asSeconds + time 446686 446687 ! ! 446688 446689!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/23/2001 08:24'! 446690endRead 446691 readDataRemaining := 0.! ! 446692 446693!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/21/2001 23:57'! 446694mapPermissionsFromUnix: unixPerms 446695 ^ unixPerms bitShift: 16.! ! 446696 446697!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/21/2001 23:58'! 446698mapPermissionsToUnix: dosPerms 446699 ^ dosPerms bitShift: -16.! ! 446700 446701!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/22/2001 20:42'! 446702readRawChunk: n 446703 self subclassResponsibility! ! 446704 446705!ZipArchiveMember methodsFor: 'private' stamp: 'nk 4/28/2002 21:53'! 446706rewindData 446707 readDataRemaining := (desiredCompressionMethod = CompressionDeflated 446708 and: [ compressionMethod = CompressionDeflated ]) 446709 ifTrue: [ compressedSize ] 446710 ifFalse: [ uncompressedSize ]. 446711! ! 446712 446713!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/22/2001 17:13'! 446714unixToDosTime: unixTime 446715 | dosTime dateTime secs | 446716 secs := self unixToSqueakTime: unixTime. "Squeak time (PST?)" 446717 dateTime := Time dateAndTimeFromSeconds: secs. 446718 dosTime := (dateTime second seconds) bitShift: -1. 446719 dosTime := dosTime + ((dateTime second minutes) bitShift: 5). 446720 dosTime := dosTime + ((dateTime second hours) bitShift: 11). 446721 dosTime := dosTime + ((dateTime first dayOfMonth) bitShift: 16). 446722 dosTime := dosTime + ((dateTime first monthIndex) bitShift: 21). 446723 dosTime := dosTime + (((dateTime first year) - 1980) bitShift: 25). 446724 ^dosTime 446725! ! 446726 446727!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/22/2001 13:22'! 446728unixToSqueakTime: unixTime 446729 ^unixTime + 2177424000. "Squeak time (PST?)"! ! 446730 446731 446732!ZipArchiveMember methodsFor: 'private-writing' stamp: 'ar 2/28/2001 14:01'! 446733compressDataTo: aStream 446734 "Copy my deflated data to the given stream." 446735 | encoder startPos endPos | 446736 446737 encoder := ZipWriteStream on: aStream. 446738 startPos := aStream position. 446739 446740 [ readDataRemaining > 0 ] whileTrue: [ | data | 446741 data := self readRawChunk: (4096 min: readDataRemaining). 446742 encoder nextPutAll: data asByteArray. 446743 readDataRemaining := readDataRemaining - data size. 446744 ]. 446745 encoder finish. "not close!!" 446746 endPos := aStream position. 446747 compressedSize := endPos - startPos. 446748 crc32 := encoder crc. 446749! ! 446750 446751!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 11:04'! 446752copyDataTo: aStream 446753 446754 compressionMethod = CompressionStored ifTrue: [ ^self copyDataWithCRCTo: aStream ]. 446755 446756 self copyRawDataTo: aStream.! ! 446757 446758!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 3/7/2004 15:42'! 446759copyDataWithCRCTo: aStream 446760 "Copy my data to aStream. Also set the CRC-32. 446761 Only used when compressionMethod = desiredCompressionMethod = CompressionStored" 446762 446763 uncompressedSize := compressedSize := readDataRemaining. 446764 446765 crc32 := 16rFFFFFFFF. 446766 446767 [ readDataRemaining > 0 ] whileTrue: [ | data | 446768 data := self readRawChunk: (4096 min: readDataRemaining). 446769 aStream nextPutAll: data. 446770 crc32 := ZipWriteStream updateCrc: crc32 from: 1 to: data size in: data. 446771 readDataRemaining := readDataRemaining - data size. 446772 ]. 446773 446774 crc32 := crc32 bitXor: 16rFFFFFFFF. 446775! ! 446776 446777!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 11:04'! 446778copyRawDataTo: aStream 446779 446780 [ readDataRemaining > 0 ] whileTrue: [ | data | 446781 data := self readRawChunk: (4096 min: readDataRemaining). 446782 aStream nextPutAll: data. 446783 readDataRemaining := readDataRemaining - data size. 446784 ]. 446785! ! 446786 446787!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/24/2001 17:57'! 446788copyRawDataTo: aStream from: start to: finish 446789 446790 readDataRemaining := readDataRemaining min: finish - start + 1. 446791 446792 self readRawChunk: start - 1. 446793 446794 [ readDataRemaining > 0 ] whileTrue: [ | data | 446795 data := self readRawChunk: (32768 min: readDataRemaining). 446796 aStream nextPutAll: data. 446797 readDataRemaining := readDataRemaining - data size. 446798 ]. 446799! ! 446800 446801!ZipArchiveMember methodsFor: 'private-writing' stamp: 'yo 2/24/2005 18:34'! 446802refreshLocalFileHeaderTo: aStream 446803 "Re-writes my local header to the given stream. 446804 To be called after writing the data stream. 446805 Assumes that fileName and localExtraField sizes didn't change since last written." 446806 446807 | here systemFileName | 446808 here := aStream position. 446809 systemFileName := fileName asVmPathName. 446810 aStream position: writeLocalHeaderRelativeOffset. 446811 446812 aStream nextPutAll: LocalFileHeaderSignature. 446813 aStream nextLittleEndianNumber: 2 put: versionNeededToExtract. 446814 aStream nextLittleEndianNumber: 2 put: bitFlag. 446815 aStream nextLittleEndianNumber: 2 put: desiredCompressionMethod. 446816 aStream nextLittleEndianNumber: 4 put: lastModFileDateTime. 446817 aStream nextLittleEndianNumber: 4 put: crc32. 446818 aStream nextLittleEndianNumber: 4 put: (desiredCompressionMethod = CompressionStored 446819 ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]). 446820 aStream nextLittleEndianNumber: 4 put: uncompressedSize. 446821 aStream nextLittleEndianNumber: 2 put: systemFileName size. 446822 aStream nextLittleEndianNumber: 2 put: localExtraField size. 446823 446824 aStream position: here. 446825! ! 446826 446827!ZipArchiveMember methodsFor: 'private-writing' stamp: 'yo 2/24/2005 18:34'! 446828writeCentralDirectoryFileHeaderTo: aStream 446829 "C2 v3 V4 v5 V2" 446830 446831 | systemFileName systemFileComment systemCdExtraField | 446832 systemFileName := fileName asVmPathName. 446833 systemFileComment := fileComment convertToSystemString. 446834 systemCdExtraField := cdExtraField. 446835 aStream nextPutAll: CentralDirectoryFileHeaderSignature. 446836 aStream nextLittleEndianNumber: 1 put: versionMadeBy. 446837 aStream nextLittleEndianNumber: 1 put: fileAttributeFormat. 446838 446839 aStream nextLittleEndianNumber: 2 put: versionNeededToExtract. 446840 aStream nextLittleEndianNumber: 2 put: bitFlag. 446841 aStream nextLittleEndianNumber: 2 put: desiredCompressionMethod. 446842 446843 aStream nextLittleEndianNumber: 4 put: lastModFileDateTime. 446844 446845 "These next 3 should have been updated during the write of the data" 446846 aStream nextLittleEndianNumber: 4 put: crc32. 446847 aStream nextLittleEndianNumber: 4 put: (desiredCompressionMethod = CompressionStored 446848 ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]). 446849 aStream nextLittleEndianNumber: 4 put: uncompressedSize. 446850 446851 aStream nextLittleEndianNumber: 2 put: systemFileName size. 446852 aStream nextLittleEndianNumber: 2 put: systemCdExtraField size. 446853 aStream nextLittleEndianNumber: 2 put: systemFileComment size. 446854 aStream nextLittleEndianNumber: 2 put: 0. "diskNumberStart" 446855 aStream nextLittleEndianNumber: 2 put: internalFileAttributes. 446856 446857 aStream nextLittleEndianNumber: 4 put: externalFileAttributes. 446858 aStream nextLittleEndianNumber: 4 put: writeLocalHeaderRelativeOffset. 446859 446860 aStream nextPutAll: systemFileName asByteArray. 446861 aStream nextPutAll: systemCdExtraField asByteArray. 446862 aStream nextPutAll: systemFileComment asByteArray.! ! 446863 446864!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/22/2001 21:53'! 446865writeDataDescriptorTo: aStream 446866 "This writes a data descriptor to the given stream. 446867 Assumes that crc32, writeOffset, and uncompressedSize are 446868 set correctly (they should be after a write). 446869 Further, the local file header should have the 446870 GPBF:=HAS:=DATA:=DESCRIPTOR:=MASK (8) bit set." 446871 446872 aStream nextLittleEndianNumber: 4 put: crc32. 446873 aStream nextLittleEndianNumber: 4 put: compressedSize. 446874 aStream nextLittleEndianNumber: 4 put: uncompressedSize.! ! 446875 446876!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/22/2001 20:41'! 446877writeDataTo: aStream 446878 "Copy my (possibly inflated or deflated) data to the given stream. 446879 This might do compression, decompression, or straight copying, depending 446880 on the values of compressionMethod and desiredCompressionMethod" 446881 446882 uncompressedSize = 0 ifTrue: [ ^self ]. "nothing to do because no data" 446883 446884 (compressionMethod = CompressionStored and: [ desiredCompressionMethod = CompressionDeflated ]) 446885 ifTrue: [ ^self compressDataTo: aStream ]. 446886 446887 (compressionMethod = CompressionDeflated and: [ desiredCompressionMethod = CompressionStored ]) 446888 ifTrue: [ ^self uncompressDataTo: aStream ]. 446889 446890 self copyDataTo: aStream.! ! 446891 446892!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/24/2001 18:01'! 446893writeDataTo: aStream from: start to: finish 446894 "Copy my (possibly inflated or deflated) data to the given stream. 446895 But only the specified byte range. 446896 This might do decompression, or straight copying, depending 446897 on the values of compressionMethod and desiredCompressionMethod" 446898 446899 uncompressedSize = 0 ifTrue: [ ^self ]. "nothing to do because no data" 446900 start > finish ifTrue: [ ^self ]. 446901 start > uncompressedSize ifTrue: [ ^self ]. 446902 446903 (compressionMethod = CompressionStored and: [ desiredCompressionMethod = CompressionDeflated ]) 446904 ifTrue: [ ^self error: 'only supports uncompression or copying right now' ]. 446905 446906 (compressionMethod = CompressionDeflated and: [ desiredCompressionMethod = CompressionStored ]) 446907 ifTrue: [ ^self uncompressDataTo: aStream from: start to: finish ]. 446908 446909 self copyRawDataTo: aStream from: start to: finish.! ! 446910 446911!ZipArchiveMember methodsFor: 'private-writing' stamp: 'yo 2/24/2005 18:34'! 446912writeLocalFileHeaderTo: aStream 446913 "Write my local header to a file handle. 446914 Stores the offset to the start of the header in my 446915 writeLocalHeaderRelativeOffset member." 446916 446917 | systemFileName | 446918 systemFileName := fileName asVmPathName. 446919 aStream nextPutAll: LocalFileHeaderSignature. 446920 aStream nextLittleEndianNumber: 2 put: versionNeededToExtract. 446921 aStream nextLittleEndianNumber: 2 put: bitFlag. 446922 aStream nextLittleEndianNumber: 2 put: desiredCompressionMethod. 446923 446924 aStream nextLittleEndianNumber: 4 put: lastModFileDateTime. 446925 aStream nextLittleEndianNumber: 4 put: crc32. 446926 aStream nextLittleEndianNumber: 4 put: (desiredCompressionMethod = CompressionStored 446927 ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]). 446928 aStream nextLittleEndianNumber: 4 put: uncompressedSize. 446929 446930 aStream nextLittleEndianNumber: 2 put: systemFileName size. 446931 aStream nextLittleEndianNumber: 2 put: localExtraField size. 446932 446933 aStream nextPutAll: systemFileName asByteArray. 446934 aStream nextPutAll: localExtraField asByteArray. 446935! ! 446936 446937"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 446938 446939ZipArchiveMember class 446940 instanceVariableNames: ''! 446941 446942!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nk 2/22/2001 17:27'! 446943newFromDirectory: aFileName 446944 ^ZipDirectoryMember newNamed: aFileName! ! 446945 446946!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nk 2/22/2001 17:27'! 446947newFromFile: aFileName 446948 ^ZipNewFileMember newNamed: aFileName! ! 446949 446950!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nk 2/22/2001 17:25'! 446951newFromString: aString named: aFileName 446952 ^ZipStringMember newFrom: aString named: aFileName! ! 446953 446954!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nk 2/21/2001 20:40'! 446955newFromZipFile: stream named: fileName 446956 ^ZipFileMember newFrom: stream named: fileName! ! 446957SharedPool subclass: #ZipConstants 446958 instanceVariableNames: '' 446959 classVariableNames: 'BaseDistance BaseLength BitLengthOrder DistanceCodes DynamicBlock EndBlock ExtraBitLengthBits ExtraDistanceBits ExtraLengthBits FixedBlock FixedDistanceTree FixedLiteralTree HashBits HashMask HashShift MatchLengthCodes MaxBitLengthBits MaxBitLengthCodes MaxBits MaxDistCodes MaxDistance MaxLengthCodes MaxLiteralCodes MaxMatch MinMatch NumLiterals Repeat11To138 Repeat3To10 Repeat3To6 StoredBlock WindowMask WindowSize' 446960 poolDictionaries: '' 446961 category: 'Compression-Streams'! 446962 446963"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 446964 446965ZipConstants class 446966 instanceVariableNames: ''! 446967 446968!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:09'! 446969initialize 446970 "ZipConstants initialize" 446971 self initializeDeflateConstants. 446972 self initializeWriteStreamConstants.! ! 446973 446974!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:06'! 446975initializeDeflateConstants 446976 446977 WindowSize := 16r8000. 446978 WindowMask := WindowSize - 1. 446979 MaxDistance := WindowSize. 446980 446981 MinMatch := 3. 446982 MaxMatch := 258. 446983 446984 HashBits := 15. 446985 HashMask := (1 << HashBits) - 1. 446986 HashShift := (HashBits + MinMatch - 1) // MinMatch. 446987! ! 446988 446989!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:08'! 446990initializeDistanceCodes 446991 | dist | 446992 BaseDistance := WordArray new: MaxDistCodes. 446993 DistanceCodes := WordArray new: 512. 446994 dist := 0. 446995 1 to: 16 do:[:code| 446996 BaseDistance at: code put: dist. 446997 1 to: (1 bitShift: (ExtraDistanceBits at: code)) do:[:n| 446998 dist := dist + 1. 446999 DistanceCodes at: dist put: code-1]]. 447000 dist = 256 ifFalse:[self error:'Whoops?!!']. 447001 dist := dist >> 7. 447002 17 to: MaxDistCodes do:[:code| 447003 BaseDistance at: code put: dist << 7. 447004 1 to: (1 bitShift: (ExtraDistanceBits at: code)-7) do:[:n| 447005 dist := dist + 1. 447006 DistanceCodes at: 256 + dist put: code-1]]. 447007! ! 447008 447009!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:07'! 447010initializeExtraBits 447011 ExtraLengthBits := 447012 WordArray withAll: #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0). 447013 ExtraDistanceBits := 447014 WordArray withAll: #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13). 447015 ExtraBitLengthBits := 447016 WordArray withAll: #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 3 7). 447017 BitLengthOrder := 447018 WordArray withAll: #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15). 447019! ! 447020 447021!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:08'! 447022initializeFixedTrees 447023 "ZipWriteStream initializeFixedTrees" 447024 | counts nodes | 447025 FixedLiteralTree := ZipEncoderTree new. 447026 FixedLiteralTree maxCode: 287. 447027 counts := WordArray new: MaxBits+1. 447028 counts at: 7+1 put: 24. 447029 counts at: 8+1 put: 144+8. 447030 counts at: 9+1 put: 112. 447031 nodes := Array new: 288. 447032 1 to: 288 do:[:i| nodes at: i put: (ZipEncoderNode value: i-1 frequency: 0 height: 0)]. 447033 0 to: 143 do:[:i| (nodes at: i+1) setBitLengthTo: 8]. 447034 144 to: 255 do:[:i| (nodes at: i+1) setBitLengthTo: 9]. 447035 256 to: 279 do:[:i| (nodes at: i+1) setBitLengthTo: 7]. 447036 280 to: 287 do:[:i| (nodes at: i+1) setBitLengthTo: 8]. 447037 FixedLiteralTree buildCodes: nodes counts: counts maxDepth: MaxBits. 447038 FixedLiteralTree setValuesFrom: nodes. 447039 447040 FixedDistanceTree := ZipEncoderTree new. 447041 FixedDistanceTree maxCode: MaxDistCodes. 447042 FixedDistanceTree 447043 bitLengths: ((WordArray new: MaxDistCodes+1) atAllPut: 5) 447044 codes: ((0 to: MaxDistCodes) collect:[:i| FixedDistanceTree reverseBits: i length: 5]).! ! 447045 447046!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:07'! 447047initializeLengthCodes 447048 | length | 447049 BaseLength := WordArray new: MaxLengthCodes. 447050 MatchLengthCodes := WordArray new: MaxMatch - MinMatch + 1. 447051 length := 0. 447052 1 to: MaxLengthCodes - 1 do:[:code| 447053 BaseLength at: code put: length. 447054 1 to: (1 bitShift: (ExtraLengthBits at: code)) do:[:n| 447055 length := length + 1. 447056 MatchLengthCodes at: length put: NumLiterals + code]]. 447057! ! 447058 447059!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:09'! 447060initializeWriteStreamConstants 447061 447062 MaxBits := 15. 447063 MaxBitLengthBits := 7. 447064 EndBlock := 256. 447065 447066 StoredBlock := 0. 447067 FixedBlock := 1. 447068 DynamicBlock := 2. 447069 447070 NumLiterals := 256. 447071 MaxLengthCodes := 29. 447072 MaxDistCodes := 30. 447073 MaxBitLengthCodes := 19. 447074 MaxLiteralCodes := NumLiterals + MaxLengthCodes + 1. "+ End of Block" 447075 447076 Repeat3To6 := 16. "Repeat previous bit length 3-6 times (2 bits repeat count)" 447077 Repeat3To10 := 17. "Repeat previous bit length 3-10 times (3 bits repeat count)" 447078 Repeat11To138 := 18. "Repeat previous bit length 11-138 times (7 bits repeat count)" 447079 447080 self initializeExtraBits. 447081 self initializeLengthCodes. 447082 self initializeDistanceCodes. 447083 self initializeFixedTrees. 447084! ! 447085TestCase subclass: #ZipCrcTests 447086 instanceVariableNames: '' 447087 classVariableNames: '' 447088 poolDictionaries: '' 447089 category: 'Tests-Compression'! 447090 447091!ZipCrcTests methodsFor: 'tests' stamp: 'ar 2/29/2004 04:43'! 447092testInvalidGZipCrc 447093 "See that a wrong CRC raises an appropriate error" 447094 | reader writer bytes crcByte | 447095 writer := GZipWriteStream on: String new. 447096 writer nextPutAll: 'Hello World'. 447097 writer close. 447098 447099 bytes := writer encodedStream contents. 447100 crcByte := bytes byteAt: bytes size-5. "before the length" 447101 bytes byteAt: bytes size-5 put: (crcByte + 1 bitAnd: 255). 447102 447103 reader := GZipReadStream on: bytes. 447104 self should:[reader upToEnd] raise: CRCError. 447105 447106 reader := GZipReadStream on: bytes. 447107 self should:[reader contents] raise: CRCError. 447108 447109 reader := GZipReadStream on: bytes. 447110 self should:[reader next: 100] raise: CRCError. 447111! ! 447112 447113!ZipCrcTests methodsFor: 'tests' stamp: 'ar 2/29/2004 04:43'! 447114testInvalidZLibCrc 447115 "See that a wrong CRC raises an appropriate error" 447116 | reader writer bytes crcByte | 447117 writer := ZLibWriteStream on: String new. 447118 writer nextPutAll: 'Hello World'. 447119 writer close. 447120 447121 bytes := writer encodedStream contents. 447122 crcByte := bytes byteAt: bytes size-2. 447123 bytes byteAt: bytes size-2 put: (crcByte + 1 bitAnd: 255). 447124 447125 reader := ZLibReadStream on: bytes. 447126 self should:[reader upToEnd] raise: CRCError. 447127 447128 reader := ZLibReadStream on: bytes. 447129 self should:[reader contents] raise: CRCError. 447130 447131 reader := ZLibReadStream on: bytes. 447132 self should:[reader next: 100] raise: CRCError. 447133! ! 447134 447135!ZipCrcTests methodsFor: 'tests' stamp: 'nk 3/7/2004 18:37'! 447136testInvalidZipCrc 447137 "See that a wrong CRC raises an appropriate error" 447138 | reader writer bytes | 447139 writer := ZipWriteStream on: String new. 447140 writer nextPutAll: 'Hello World'. 447141 writer close. 447142 447143 bytes := writer encodedStream contents. 447144 447145 reader := ZipReadStream on: bytes. 447146 reader expectedCrc: writer crc - 1. 447147 self should:[reader upToEnd] raise: CRCError. 447148 447149 reader := ZipReadStream on: bytes. 447150 reader expectedCrc: writer crc - 1. 447151 self should:[reader contents] raise: CRCError. 447152 447153 reader := ZipReadStream on: bytes. 447154 reader expectedCrc: writer crc - 1. 447155 self should:[reader next: 100] raise: CRCError. 447156! ! 447157 447158!ZipCrcTests methodsFor: 'tests' stamp: 'ar 2/29/2004 04:42'! 447159testMissingGZipCrc 447160 "See that the lack of a CRC raises an appropriate error" 447161 | reader writer bytes | 447162 writer := GZipWriteStream on: String new. 447163 writer nextPutAll: 'Hello World'. 447164 writer close. 447165 447166 bytes := writer encodedStream contents. 447167 bytes := bytes copyFrom: 1 to: bytes size-6. 447168 447169 reader := GZipReadStream on: bytes. 447170 self should:[reader upToEnd] raise: CRCError. 447171 447172 reader := GZipReadStream on: bytes. 447173 self should:[reader contents] raise: CRCError. 447174 447175 reader := GZipReadStream on: bytes. 447176 self should:[reader next: 100] raise: CRCError. 447177! ! 447178 447179!ZipCrcTests methodsFor: 'tests' stamp: 'ar 2/29/2004 04:42'! 447180testMissingZLibCrc 447181 "See that the lack of a CRC raises an appropriate error" 447182 | reader writer bytes | 447183 writer := ZLibWriteStream on: String new. 447184 writer nextPutAll: 'Hello World'. 447185 writer close. 447186 447187 bytes := writer encodedStream contents. 447188 bytes := bytes copyFrom: 1 to: bytes size-2. 447189 447190 reader := ZLibReadStream on: bytes. 447191 self should:[reader upToEnd] raise: CRCError. 447192 447193 reader := ZLibReadStream on: bytes. 447194 self should:[reader contents] raise: CRCError. 447195 447196 reader := ZLibReadStream on: bytes. 447197 self should:[reader next: 100] raise: CRCError. 447198! ! 447199 447200!ZipCrcTests methodsFor: 'tests' stamp: 'nk 3/7/2004 18:49'! 447201testMissingZipCrc 447202 "See that the lack of a CRC does not raise an error" 447203 | reader writer bytes readBytes | 447204 writer := ZipWriteStream on: String new. 447205 writer nextPutAll: 'Hello World'. 447206 writer close. 447207 447208 bytes := writer encodedStream contents. 447209 447210 reader := ZipReadStream on: bytes. 447211 self shouldnt:[readBytes := reader upToEnd] raise: CRCError. 447212 self assert: readBytes = 'Hello World'. 447213 447214 reader := ZipReadStream on: bytes. 447215 self shouldnt:[reader contents] raise: CRCError. 447216 447217 reader := ZipReadStream on: bytes. 447218 self shouldnt:[reader next: 100] raise: CRCError. 447219! ! 447220 447221!ZipCrcTests methodsFor: 'tests' stamp: 'ar 2/29/2004 04:42'! 447222testValidGZipCrc 447223 | reader writer bytes | 447224 writer := GZipWriteStream on: String new. 447225 writer nextPutAll: 'Hello World'. 447226 writer close. 447227 447228 bytes := writer encodedStream contents. 447229 reader := GZipReadStream on: bytes. 447230 self assert: reader upToEnd = 'Hello World'.! ! 447231 447232!ZipCrcTests methodsFor: 'tests' stamp: 'nk 3/7/2004 18:46'! 447233testValidZLibCrc 447234 | reader writer bytes | 447235 writer := ZLibWriteStream on: String new. 447236 writer nextPutAll: 'Hello World'. 447237 writer close. 447238 447239 bytes := writer encodedStream contents. 447240 reader := ZLibReadStream on: bytes. 447241 self assert: reader upToEnd = 'Hello World'. 447242 447243 bytes := writer encodedStream contents. 447244 reader := ZLibReadStream on: bytes. 447245 self assert: (reader next: 100) = 'Hello World'.! ! 447246 447247!ZipCrcTests methodsFor: 'tests' stamp: 'nk 3/7/2004 18:43'! 447248testValidZipCrc 447249 "See that a correct CRC does not raise an error and that we can read what we wrote." 447250 | reader writer bytes readBytes | 447251 writer := ZipWriteStream on: String new. 447252 writer nextPutAll: 'Hello World'. 447253 writer close. 447254 447255 bytes := writer encodedStream contents. 447256 447257 reader := ZipReadStream on: bytes. 447258 reader expectedCrc: writer crc. 447259 self shouldnt:[ readBytes := reader upToEnd] raise: CRCError. 447260 self assert: readBytes = 'Hello World'. 447261 447262 reader := ZipReadStream on: bytes. 447263 reader expectedCrc: writer crc. 447264 self shouldnt:[ readBytes := reader contents] raise: CRCError. 447265 self assert: readBytes = 'Hello World'. 447266 447267 reader := ZipReadStream on: bytes. 447268 reader expectedCrc: writer crc. 447269 self shouldnt:[ readBytes := reader next: 11 ] raise: CRCError. 447270 self assert: readBytes = 'Hello World'. 447271 447272 reader := ZipReadStream on: bytes. 447273 reader expectedCrc: writer crc. 447274 self shouldnt:[ readBytes := reader next: 100 ] raise: CRCError. 447275 self assert: readBytes = 'Hello World'.! ! 447276ZipFileMember subclass: #ZipDirectoryMember 447277 instanceVariableNames: '' 447278 classVariableNames: '' 447279 poolDictionaries: '' 447280 category: 'Compression-Archives'! 447281!ZipDirectoryMember commentStamp: '<historical>' prior: 0! 447282ZipFileMember instances represent directories inside ZipArchives. 447283They don't do much other than hold names and permissions (and extra fields). 447284 447285You can add files in subdirectories to a ZipArchive without using any ZipDirectoryMembers.! 447286 447287 447288!ZipDirectoryMember methodsFor: 'accessing' stamp: 'nk 2/23/2001 10:00'! 447289desiredCompressionMethod: aNumber! ! 447290 447291!ZipDirectoryMember methodsFor: 'accessing' stamp: 'nk 12/20/2002 14:45'! 447292localFileName: aString 447293 | dir entry parent | 447294 super localFileName: aString. 447295 fileName last = $/ ifFalse: [ fileName := fileName, '/' ]. 447296 parent := FileDirectory default. 447297 (parent directoryExists: fileName) ifTrue: [ 447298 dir := FileDirectory on: (parent fullNameFor: fileName). 447299 entry := dir directoryEntry. 447300 self setLastModFileDateTimeFrom: entry modificationTime 447301 ] 447302! ! 447303 447304 447305!ZipDirectoryMember methodsFor: 'initialization' stamp: 'nk 2/23/2001 10:01'! 447306initialize 447307 super initialize. 447308 super desiredCompressionMethod: CompressionStored.! ! 447309 447310 447311!ZipDirectoryMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:00'! 447312isDirectory 447313 ^true! ! 447314 447315!ZipDirectoryMember methodsFor: 'testing' stamp: 'nk 3/27/2002 11:29'! 447316usesFileNamed: aName 447317 ^false! ! 447318 447319 447320!ZipDirectoryMember methodsFor: 'private' stamp: 'nk 2/21/2001 21:55'! 447321asDirectory 447322 ^self! ! 447323 447324!ZipDirectoryMember methodsFor: 'private' stamp: 'nk 3/27/2002 11:30'! 447325rewindData! ! 447326 447327"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 447328 447329ZipDirectoryMember class 447330 instanceVariableNames: ''! 447331 447332!ZipDirectoryMember class methodsFor: 'as yet unclassified' stamp: 'nk 12/20/2002 14:57'! 447333newNamed: aFileName 447334 ^(self new) localFileName: aFileName; yourself! ! 447335WriteStream subclass: #ZipEncoder 447336 instanceVariableNames: 'bitBuffer bitPosition encodedStream' 447337 classVariableNames: '' 447338 poolDictionaries: 'ZipConstants' 447339 category: 'Compression-Streams'! 447340 447341!ZipEncoder methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:45'! 447342bitPosition 447343 ^encodedStream position + position * 8 + bitPosition.! ! 447344 447345!ZipEncoder methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:37'! 447346encodedStream 447347 ^encodedStream! ! 447348 447349!ZipEncoder methodsFor: 'accessing' stamp: 'ar 1/2/2000 16:34'! 447350nextBits: nBits put: value 447351 "Store a value of nBits" 447352 "self assert:[value >= 0 and:[(1 bitShift: nBits) > value]]." 447353 bitBuffer := bitBuffer bitOr: (value bitShift: bitPosition). 447354 bitPosition := bitPosition + nBits. 447355 [bitPosition >= 8] whileTrue:[ 447356 self nextBytePut: (bitBuffer bitAnd: 255). 447357 bitBuffer := bitBuffer bitShift: -8. 447358 bitPosition := bitPosition - 8].! ! 447359 447360!ZipEncoder methodsFor: 'accessing' stamp: 'ar 1/2/2000 16:34'! 447361nextBytePut: anObject 447362 "Primitive. Insert the argument at the next position in the Stream 447363 represented by the receiver. Fail if the collection of this stream is not an 447364 Array or a String. Fail if the stream is positioned at its end, or if the 447365 position is out of bounds in the collection. Fail if the argument is not 447366 of the right type for the collection. Optional. See Object documentation 447367 whatIsAPrimitive." 447368 447369 <primitive: 66> 447370 position >= writeLimit 447371 ifTrue: [^ self pastEndPut: anObject] 447372 ifFalse: 447373 [position := position + 1. 447374 ^collection byteAt: position put: anObject]! ! 447375 447376 447377!ZipEncoder methodsFor: 'block encoding' stamp: 'ar 12/30/1999 18:39'! 447378sendBlock: literalStream with: distanceStream with: litTree with: distTree 447379 "Send the current block using the encodings from the given literal/length and distance tree" 447380 | result | 447381 result := 0. 447382 [literalStream atEnd] whileFalse:[ 447383 result := result + (self privateSendBlock: literalStream 447384 with: distanceStream with: litTree with: distTree). 447385 self commit. 447386 ]. 447387 self nextBits: (litTree bitLengthAt: EndBlock) put: (litTree codeAt: EndBlock). 447388 ^result! ! 447389 447390 447391!ZipEncoder methodsFor: 'initialization' stamp: 'sd 1/30/2004 15:24'! 447392close 447393 self flush. 447394 encodedStream close.! ! 447395 447396!ZipEncoder methodsFor: 'initialization' stamp: 'ar 12/30/1999 15:51'! 447397commit 447398 encodedStream next: position putAll: collection. 447399 position := readLimit := 0.! ! 447400 447401!ZipEncoder methodsFor: 'initialization' stamp: 'ar 12/30/1999 15:51'! 447402flush 447403 self flushBits. 447404 self commit.! ! 447405 447406!ZipEncoder methodsFor: 'initialization' stamp: 'ar 1/2/2000 16:35'! 447407flushBits 447408 "Flush currently unsent bits" 447409 [bitPosition > 0] whileTrue:[ 447410 self nextBytePut: (bitBuffer bitAnd: 255). 447411 bitBuffer := bitBuffer bitShift: -8. 447412 bitPosition := bitPosition - 8]. 447413 bitPosition := 0.! ! 447414 447415!ZipEncoder methodsFor: 'initialization' stamp: 'PeterHugossonMiller 9/3/2009 11:52'! 447416on: aCollectionOrStream 447417 aCollectionOrStream isStream 447418 ifTrue:[encodedStream := aCollectionOrStream] 447419 ifFalse:[ encodedStream := aCollectionOrStream writeStream]. 447420 encodedStream isBinary 447421 ifTrue:[super on: (ByteArray new: 4096)] 447422 ifFalse:[super on: (String new: 4096)]. 447423 bitPosition := bitBuffer := 0.! ! 447424 447425 447426!ZipEncoder methodsFor: 'private' stamp: 'ar 1/2/2000 16:38'! 447427pastEndPut: anObject 447428 "Flush the current buffer and store the new object at the beginning" 447429 self commit. 447430 ^self nextBytePut: anObject asInteger! ! 447431 447432!ZipEncoder methodsFor: 'private' stamp: 'ar 2/2/2001 15:47'! 447433privateSendBlock: literalStream with: distanceStream with: litTree with: distTree 447434 "Send the current block using the encodings from the given literal/length and distance tree" 447435 | lit dist code extra sum | 447436 <primitive: 'primitiveZipSendBlock' module: 'ZipPlugin'> 447437 sum := 0. 447438 [lit := literalStream next. 447439 dist := distanceStream next. 447440 lit == nil] whileFalse:[ 447441 dist = 0 ifTrue:["lit is a literal" 447442 sum := sum + 1. 447443 self nextBits: (litTree bitLengthAt: lit) 447444 put: (litTree codeAt: lit). 447445 ] ifFalse:["lit is match length" 447446 sum := sum + lit + MinMatch. 447447 code := (MatchLengthCodes at: lit + 1). 447448 self nextBits: (litTree bitLengthAt: code) 447449 put: (litTree codeAt: code). 447450 extra := ExtraLengthBits at: code-NumLiterals. 447451 extra = 0 ifFalse:[ 447452 lit := lit - (BaseLength at: code-NumLiterals). 447453 self nextBits: extra put: lit. 447454 ]. 447455 dist := dist - 1. 447456 dist < 256 447457 ifTrue:[code := DistanceCodes at: dist + 1] 447458 ifFalse:[code := DistanceCodes at: 257 + (dist bitShift: -7)]. 447459 "self assert:[code < MaxDistCodes]." 447460 self nextBits: (distTree bitLengthAt: code) 447461 put: (distTree codeAt: code). 447462 extra := ExtraDistanceBits at: code+1. 447463 extra = 0 ifFalse:[ 447464 dist := dist - (BaseDistance at: code+1). 447465 self nextBits: extra put: dist. 447466 ]. 447467 ]. 447468 ]. 447469 ^sum! ! 447470Object subclass: #ZipEncoderNode 447471 instanceVariableNames: 'value frequency height bitLength code parent left right' 447472 classVariableNames: '' 447473 poolDictionaries: '' 447474 category: 'Compression-Streams'! 447475!ZipEncoderNode commentStamp: '<historical>' prior: 0! 447476ZipEncoderNode represents a node in a huffman tree for encoding ZipStreams. 447477 447478Instance variables: 447479 value <Integer> - Encoded value 447480 frequency <Integer> - Number of occurences of the encoded value 447481 height <Integer> - Height of the node in the tree 447482 bitLength <Integer> - bit length of the code 447483 code <Integer> - Assigned code for this node 447484 parent <ZipEncoderNode> - Parent of this node 447485 left <ZipEncoderNode> - First child of this node 447486 right <ZipEncoderNode> - Second child of this node 447487! 447488 447489 447490!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 19:41'! 447491bitLength 447492 ^bitLength ifNil:[0]! ! 447493 447494!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/30/1999 14:28'! 447495code 447496 ^code ifNil:[0]! ! 447497 447498!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 21:51'! 447499code: aCode 447500 self assert:[aCode >= 0 and:[(1 bitShift: bitLength) > aCode]]. 447501 code := aCode.! ! 447502 447503!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:36'! 447504frequency 447505 ^frequency! ! 447506 447507!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/28/1999 00:56'! 447508frequency: aNumber 447509 frequency := aNumber! ! 447510 447511!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/26/1999 10:44'! 447512height 447513 ^height! ! 447514 447515!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! 447516left 447517 ^left! ! 447518 447519!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 20:06'! 447520left: aNode 447521 aNode parent: self. 447522 left := aNode.! ! 447523 447524!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! 447525parent 447526 ^parent! ! 447527 447528!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! 447529parent: aNode 447530 parent := aNode! ! 447531 447532!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! 447533right 447534 ^right! ! 447535 447536!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 20:06'! 447537right: aNode 447538 aNode parent: self. 447539 right := aNode.! ! 447540 447541!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! 447542value 447543 ^value! ! 447544 447545 447546!ZipEncoderNode methodsFor: 'encoding' stamp: 'marcus.denker 9/14/2008 19:01'! 447547encodeBitLength: blCounts from: aTree 447548 | index | 447549 "Note: If bitLength is not nil then the tree must be broken" 447550 bitLength isNil ifFalse:[self error:'Huffman tree is broken']. 447551 parent 447552 ifNil: [bitLength := 0] 447553 ifNotNil:[bitLength := parent bitLength + 1]. 447554 self isLeaf ifTrue:[ 447555 index := bitLength + 1. 447556 blCounts at: index put: (blCounts at: index) + 1. 447557 ] ifFalse:[ 447558 left encodeBitLength: blCounts from: aTree. 447559 right encodeBitLength: blCounts from: aTree. 447560 ].! ! 447561 447562!ZipEncoderNode methodsFor: 'encoding' stamp: 'ar 12/27/1999 14:27'! 447563rotateToHeight: maxHeight 447564 "Rotate the tree to achieve maxHeight depth" 447565 | newParent | 447566 height < 4 ifTrue:[^self]. 447567 self left: (left rotateToHeight: maxHeight-1). 447568 self right: (right rotateToHeight: maxHeight-1). 447569 height := (left height max: right height) + 1. 447570 height <= maxHeight ifTrue:[^self]. 447571 (left height - right height) abs <= 2 ifTrue:[^self]. 447572 left height < right height ifTrue:[ 447573 right right height >= right left height ifTrue:[ 447574 newParent := right. 447575 self right: newParent left. 447576 newParent left: self. 447577 ] ifFalse:[ 447578 newParent := right left. 447579 right left: newParent right. 447580 newParent right: right. 447581 self right: newParent left. 447582 newParent left: self. 447583 ]. 447584 ] ifFalse:[ 447585 left left height >= left right height ifTrue:[ 447586 newParent := left. 447587 self left: newParent right. 447588 newParent right: self. 447589 ] ifFalse:[ 447590 newParent := left right. 447591 left right: newParent left. 447592 newParent left: left. 447593 self left: newParent right. 447594 newParent right: self. 447595 ]. 447596 ]. 447597 parent computeHeight. 447598 ^parent! ! 447599 447600 447601!ZipEncoderNode methodsFor: 'printing' stamp: 'ar 12/26/1999 10:46'! 447602printOn: aStream 447603 super printOn: aStream. 447604 aStream nextPut:$(; 447605 nextPutAll:'value = '; print: value; 447606 nextPutAll:', freq = '; print: frequency; 447607 nextPutAll:', bitLength = '; print: bitLength; 447608 nextPutAll:', code = '; print: code; 447609 nextPutAll:', height = '; print: height; 447610 nextPut:$).! ! 447611 447612 447613!ZipEncoderNode methodsFor: 'testing' stamp: 'marcus.denker 9/14/2008 19:00'! 447614isLeaf 447615 ^left isNil! ! 447616 447617 447618!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 10:45'! 447619computeHeight 447620 ^self isLeaf 447621 ifTrue:[height := 0] 447622 ifFalse:[height := (left computeHeight max: right computeHeight) + 1].! ! 447623 447624!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/25/1999 18:14'! 447625leafNodes 447626 self isLeaf 447627 ifTrue:[^Array with: self] 447628 ifFalse:[^left leafNodes, right leafNodes]! ! 447629 447630!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 12:05'! 447631setBitLengthTo: bl 447632 bitLength := bl! ! 447633 447634!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 10:46'! 447635setValue: v frequency: f height: h 447636 value := v. 447637 frequency := f. 447638 height := h.! ! 447639 447640"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 447641 447642ZipEncoderNode class 447643 instanceVariableNames: ''! 447644 447645!ZipEncoderNode class methodsFor: 'instance creation' stamp: 'ar 12/26/1999 10:47'! 447646value: v frequency: f height: h 447647 ^self new setValue: v frequency: f height: h! ! 447648Object subclass: #ZipEncoderTree 447649 instanceVariableNames: 'bitLengths codes maxCode' 447650 classVariableNames: '' 447651 poolDictionaries: '' 447652 category: 'Compression-Streams'! 447653!ZipEncoderTree commentStamp: '<historical>' prior: 0! 447654ZipEncoderTree represents a huffman tree for encoding ZipStreams. 447655 447656Instance variables: 447657 bitLengths <WordArray> - Bit lengths of each generated code 447658 codes <WordArray> - Codes for each value 447659 maxCode <Integer> - Maximum value with non-zero frequency! 447660 447661 447662!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:43'! 447663bitLengthAt: index 447664 ^bitLengths at: index+1! ! 447665 447666!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:32'! 447667bitLengths 447668 "Return an array of all bitLength values for valid codes" 447669 ^bitLengths! ! 447670 447671!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:04'! 447672codeAt: index 447673 ^codes at: index+1! ! 447674 447675!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:24'! 447676codes 447677 "Return an array of all valid codes" 447678 ^codes! ! 447679 447680!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/25/1999 17:15'! 447681maxCode 447682 ^maxCode! ! 447683 447684!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/25/1999 21:45'! 447685maxCode: aNumber 447686 maxCode := aNumber.! ! 447687 447688 447689!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 01:34'! 447690buildCodes: nodeList counts: blCounts maxDepth: depth 447691 "Build the codes for all nodes" 447692 | nextCode code node length | 447693 nextCode := WordArray new: depth+1. 447694 code := 0. 447695 1 to: depth do:[:bits| 447696 code := (code + (blCounts at: bits)) << 1. 447697 nextCode at: bits+1 put: code]. 447698 self assert:[(code + (blCounts at: depth+1) - 1) = (1 << depth - 1)]. 447699 0 to: maxCode do:[:n| 447700 node := nodeList at: n+1. 447701 length := node bitLength. 447702 length = 0 ifFalse:[ 447703 code := nextCode at: length+1. 447704 node code: (self reverseBits: code length: length). 447705 nextCode at: length+1 put: code+1. 447706 ]. 447707 ].! ! 447708 447709!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/26/1999 10:42'! 447710buildHierarchyFrom: aHeap 447711 "Build the node hierarchy based on the leafs in aHeap" 447712 | left right parent | 447713 [aHeap size > 1] whileTrue:[ 447714 left := aHeap removeFirst. 447715 right := aHeap removeFirst. 447716 parent := ZipEncoderNode value: -1 447717 frequency: (left frequency + right frequency) 447718 height: (left height max: right height) + 1. 447719 left parent: parent. 447720 right parent: parent. 447721 parent left: left. 447722 parent right: right. 447723 aHeap add: parent]. 447724 ^aHeap removeFirst 447725! ! 447726 447727!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 14:19'! 447728buildTree: nodeList maxDepth: depth 447729 "Build either the literal or the distance tree" 447730 | heap rootNode blCounts | 447731 heap := Heap new: nodeList size // 3. 447732 heap sortBlock: self nodeSortBlock. 447733 "Find all nodes with non-zero frequency and add to heap" 447734 maxCode := 0. 447735 nodeList do:[:dNode| 447736 dNode frequency = 0 ifFalse:[ 447737 maxCode := dNode value. 447738 heap add: dNode]]. 447739 "The pkzip format requires that at least one distance code exists, 447740 and that at least one bit should be sent even if there is only one 447741 possible code. So to avoid special checks later on we force at least 447742 two codes of non zero frequency." 447743 heap size = 0 ifTrue:[ 447744 self assert:[maxCode = 0]. 447745 heap add: nodeList first. 447746 heap add: nodeList second. 447747 maxCode := 1]. 447748 heap size = 1 ifTrue:[ 447749 nodeList first frequency = 0 447750 ifTrue:[heap add: nodeList first] 447751 ifFalse:[heap add: nodeList second]. 447752 maxCode := maxCode max: 1]. 447753 rootNode := self buildHierarchyFrom: heap. 447754 rootNode height > depth ifTrue:[ 447755 rootNode := rootNode rotateToHeight: depth. 447756 rootNode height > depth ifTrue:[self error:'Cannot encode tree']]. 447757 blCounts := WordArray new: depth+1. 447758 rootNode encodeBitLength: blCounts from: self. 447759 self buildCodes: nodeList counts: blCounts maxDepth: depth. 447760 self setValuesFrom: nodeList.! ! 447761 447762!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 01:24'! 447763buildTreeFrom: frequencies maxDepth: depth 447764 "Build the receiver from the given frequency values" 447765 | nodeList | 447766 nodeList := Array new: frequencies size. 447767 1 to: frequencies size do:[:i| 447768 nodeList at: i put: (ZipEncoderNode value: i-1 frequency: (frequencies at: i) height: 0) 447769 ]. 447770 self buildTree: nodeList maxDepth: depth.! ! 447771 447772!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/26/1999 10:42'! 447773nodeSortBlock 447774 ^[:n1 :n2| 447775 n1 frequency = n2 frequency 447776 ifTrue:[n1 height <= n2 height] 447777 ifFalse:[n1 frequency <= n2 frequency]].! ! 447778 447779 447780!ZipEncoderTree methodsFor: 'private' stamp: 'ar 12/30/1999 14:26'! 447781bitLengths: blArray codes: codeArray 447782 bitLengths := blArray as: WordArray. 447783 codes := codeArray as: WordArray. 447784 self assert:[(self bitLengthAt: maxCode) > 0].! ! 447785 447786!ZipEncoderTree methodsFor: 'private' stamp: 'ar 12/26/1999 11:02'! 447787reverseBits: code length: length 447788 "Bit reverse the given code" 447789 | result bit bits | 447790 result := 0. 447791 bits := code. 447792 1 to: length do:[:i| 447793 bit := bits bitAnd: 1. 447794 result := result << 1 bitOr: bit. 447795 bits := bits >> 1]. 447796 ^result! ! 447797 447798!ZipEncoderTree methodsFor: 'private' stamp: 'sma 6/1/2000 11:52'! 447799setValuesFrom: nodeList 447800 self bitLengths: (nodeList 447801 collect: [:n | n bitLength] 447802 from: 1 447803 to: maxCode + 1) 447804 codes: (nodeList 447805 collect: [:n | n code] 447806 from: 1 447807 to: maxCode + 1)! ! 447808 447809"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 447810 447811ZipEncoderTree class 447812 instanceVariableNames: ''! 447813 447814!ZipEncoderTree class methodsFor: 'instance creation' stamp: 'ar 12/30/1999 01:25'! 447815buildTreeFrom: frequencies maxDepth: depth 447816 ^self new buildTreeFrom: frequencies maxDepth: depth! ! 447817SharedPool subclass: #ZipFileConstants 447818 instanceVariableNames: '' 447819 classVariableNames: 'CentralDirectoryFileHeaderSignature CompressionDeflated CompressionLevelDefault CompressionLevelNone CompressionStored DataDescriptorLength DefaultDirectoryPermissions DefaultFilePermissions DeflatingCompressionFast DeflatingCompressionMaximum DeflatingCompressionNormal DeflatingCompressionSuperFast DirectoryAttrib EndOfCentralDirectorySignature FaMsdos FaUnix FileAttrib IfaBinaryFile IfaTextFile LocalFileHeaderSignature' 447820 poolDictionaries: '' 447821 category: 'Compression-Archives'! 447822 447823"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 447824 447825ZipFileConstants class 447826 instanceVariableNames: ''! 447827 447828!ZipFileConstants class methodsFor: 'pool initialization' stamp: 'nk 8/21/2004 15:50'! 447829initialize 447830 "ZipFileConstants initialize" 447831 FaMsdos := 0. 447832 FaUnix := 3. 447833 DeflatingCompressionNormal := 0. 447834 DeflatingCompressionMaximum := 2. 447835 DeflatingCompressionFast := 4. 447836 DeflatingCompressionSuperFast := 6. 447837 CompressionStored := 0. 447838 CompressionDeflated := 8. 447839 CompressionLevelNone := 0. 447840 CompressionLevelDefault := 6. 447841 IfaTextFile := 1. 447842 IfaBinaryFile := 0. 447843 DataDescriptorLength := 12. 447844 447845 "Unix permission bits" 447846 DefaultDirectoryPermissions := 8r040755. 447847 DefaultFilePermissions := 8r0100666. 447848 DirectoryAttrib := 8r040000. 447849 FileAttrib := 8r0100000. 447850 447851 CentralDirectoryFileHeaderSignature := 447852 (ByteArray with: 16r50 with: 16r4B with: 16r01 with: 16r02). 447853 LocalFileHeaderSignature := 447854 (ByteArray with: 16r50 with: 16r4B with: 16r03 with: 16r04). 447855 EndOfCentralDirectorySignature := 447856 (ByteArray with: 16r50 with: 16r4B with: 16r05 with: 16r06).! ! 447857ZipArchiveMember subclass: #ZipFileMember 447858 instanceVariableNames: 'externalFileName stream localHeaderRelativeOffset dataOffset' 447859 classVariableNames: '' 447860 poolDictionaries: '' 447861 category: 'Compression-Archives'! 447862!ZipFileMember commentStamp: '<historical>' prior: 0! 447863ZipNewFileMember instances are used to represent files that have been read from a ZipArchive. 447864Their data stays in the file on disk, so the original Zip file cannot be directly overwritten.! 447865 447866 447867!ZipFileMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'! 447868close 447869 stream ifNotNil:[stream close].! ! 447870 447871!ZipFileMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:52'! 447872initialize 447873 super initialize. 447874 crc32 := 0. 447875 localHeaderRelativeOffset := 0. 447876 dataOffset := 0.! ! 447877 447878!ZipFileMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:51'! 447879stream: aStream externalFileName: aFileName 447880 stream := aStream. 447881 externalFileName := aFileName.! ! 447882 447883 447884!ZipFileMember methodsFor: 'testing' stamp: 'nk 2/21/2001 21:52'! 447885looksLikeDirectory 447886 ^fileName last = $/ 447887 and: [ uncompressedSize = 0 ]! ! 447888 447889!ZipFileMember methodsFor: 'testing' stamp: 'nk 2/24/2001 14:07'! 447890usesFileNamed: aFileName 447891 "Do I require aFileName? That is, do I care if it's clobbered?" 447892 ^(FileDirectory default fullNameFor: externalFileName) = (FileDirectory default fullNameFor: aFileName)! ! 447893 447894 447895!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 11/11/2002 21:46'! 447896canonicalizeFileName 447897 "For security reasons, make all paths relative and remove any ../ portions" 447898 447899 [fileName beginsWith: '/'] whileTrue: [fileName := fileName allButFirst]. 447900 fileName := fileName copyReplaceAll: '../' with: ''! ! 447901 447902!ZipFileMember methodsFor: 'private-reading' stamp: 'yo 12/19/2003 21:15'! 447903readCentralDirectoryFileHeaderFrom: aStream 447904 "Assumes aStream positioned after signature" 447905 447906 | fileNameLength extraFieldLength fileCommentLength | 447907 447908 versionMadeBy := aStream nextLittleEndianNumber: 1. 447909 fileAttributeFormat := aStream nextLittleEndianNumber: 1. 447910 447911 versionNeededToExtract := aStream nextLittleEndianNumber: 2. 447912 bitFlag := aStream nextLittleEndianNumber: 2. 447913 compressionMethod := aStream nextLittleEndianNumber: 2. 447914 447915 lastModFileDateTime := aStream nextLittleEndianNumber: 4. 447916 crc32 := aStream nextLittleEndianNumber: 4. 447917 compressedSize := aStream nextLittleEndianNumber: 4. 447918 uncompressedSize := aStream nextLittleEndianNumber: 4. 447919 447920 fileNameLength := aStream nextLittleEndianNumber: 2. 447921 extraFieldLength := aStream nextLittleEndianNumber: 2. 447922 fileCommentLength := aStream nextLittleEndianNumber: 2. 447923 aStream nextLittleEndianNumber: 2. "disk number start" 447924 internalFileAttributes := aStream nextLittleEndianNumber: 2. 447925 447926 externalFileAttributes := aStream nextLittleEndianNumber: 4. 447927 localHeaderRelativeOffset := aStream nextLittleEndianNumber: 4. 447928 447929 fileName := (aStream next: fileNameLength) asString asSqueakPathName. 447930 cdExtraField := (aStream next: extraFieldLength) asByteArray asString. 447931 fileComment := (aStream next: fileCommentLength) asString convertFromSystemString. 447932 447933 self desiredCompressionMethod: compressionMethod! ! 447934 447935!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 11/11/2002 21:48'! 447936readFrom: aStream 447937 "assumes aStream positioned after CD header; leaves stream positioned after my CD entry" 447938 447939 self readCentralDirectoryFileHeaderFrom: aStream. 447940 self readLocalDirectoryFileHeaderFrom: aStream. 447941 self endRead. 447942 self canonicalizeFileName. 447943! ! 447944 447945!ZipFileMember methodsFor: 'private-reading' stamp: 'BG 3/16/2005 08:28'! 447946readLocalDirectoryFileHeaderFrom: aStream 447947 "Positions stream as necessary. Will return stream to its original position" 447948 447949 | fileNameLength extraFieldLength xcrc32 xcompressedSize xuncompressedSize sig oldPos | 447950 447951 oldPos := aStream position. 447952 447953 aStream position: localHeaderRelativeOffset. 447954 447955 sig := aStream next: 4. 447956 sig = LocalFileHeaderSignature asByteArray 447957 ifFalse: [ aStream position: oldPos. 447958 ^self error: 'bad LH signature at ', localHeaderRelativeOffset printStringHex ]. 447959 447960 versionNeededToExtract := aStream nextLittleEndianNumber: 2. 447961 bitFlag := aStream nextLittleEndianNumber: 2. 447962 compressionMethod := aStream nextLittleEndianNumber: 2. 447963 447964 lastModFileDateTime := aStream nextLittleEndianNumber: 4. 447965 xcrc32 := aStream nextLittleEndianNumber: 4. 447966 xcompressedSize := aStream nextLittleEndianNumber: 4. 447967 xuncompressedSize := aStream nextLittleEndianNumber: 4. 447968 447969 fileNameLength := aStream nextLittleEndianNumber: 2. 447970 extraFieldLength := aStream nextLittleEndianNumber: 2. 447971 447972 fileName := (aStream next: fileNameLength) asString asSqueakPathName. 447973 localExtraField := (aStream next: extraFieldLength) asByteArray. 447974 447975 dataOffset := aStream position. 447976 447977 "Don't trash these fields if we already got them from the central directory" 447978 self hasDataDescriptor ifFalse: [ 447979 crc32 := xcrc32. 447980 compressedSize := xcompressedSize. 447981 uncompressedSize := xuncompressedSize. 447982 ]. 447983 447984 aStream position: oldPos.! ! 447985 447986!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 2/22/2001 20:46'! 447987readRawChunk: n 447988 ^stream next: n! ! 447989 447990!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 2/23/2001 09:56'! 447991rewindData 447992 super rewindData. 447993 (stream isNil or: [ stream closed ]) 447994 ifTrue: [ self error: 'stream missing or closed' ]. 447995 stream position: (localHeaderRelativeOffset + 4). 447996 self skipLocalDirectoryFileHeaderFrom: stream.! ! 447997 447998!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 2/23/2001 09:56'! 447999skipLocalDirectoryFileHeaderFrom: aStream 448000 "Assumes that stream is positioned after signature." 448001 448002 | extraFieldLength fileNameLength | 448003 aStream next: 22. 448004 fileNameLength := aStream nextLittleEndianNumber: 2. 448005 extraFieldLength := aStream nextLittleEndianNumber: 2. 448006 aStream next: fileNameLength. 448007 aStream next: extraFieldLength. 448008 dataOffset := aStream position. 448009! ! 448010 448011 448012!ZipFileMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 11:04'! 448013copyDataTo: aStream 448014 448015 self copyRawDataTo: aStream.! ! 448016 448017!ZipFileMember methodsFor: 'private-writing' stamp: 'nk 3/27/2002 11:20'! 448018localHeaderRelativeOffset 448019 ^localHeaderRelativeOffset! ! 448020 448021!ZipFileMember methodsFor: 'private-writing' stamp: 'nk 3/7/2004 16:08'! 448022uncompressDataTo: aStream 448023 448024 | decoder buffer chunkSize crcErrorMessage | 448025 decoder := ZipReadStream on: stream. 448026 decoder expectedCrc: self crc32. 448027 buffer := ByteArray new: (32768 min: readDataRemaining). 448028 crcErrorMessage := nil. 448029 448030 [[ readDataRemaining > 0 ] whileTrue: [ 448031 chunkSize := 32768 min: readDataRemaining. 448032 buffer := decoder next: chunkSize into: buffer startingAt: 1. 448033 aStream next: chunkSize putAll: buffer startingAt: 1. 448034 readDataRemaining := readDataRemaining - chunkSize. 448035 ]] on: CRCError do: [ :ex | crcErrorMessage := ex messageText. ex proceed ]. 448036 448037 crcErrorMessage ifNotNil: [ self isCorrupt: true. CRCError signal: crcErrorMessage ] 448038 448039! ! 448040 448041!ZipFileMember methodsFor: 'private-writing' stamp: 'nk 2/24/2001 17:52'! 448042uncompressDataTo: aStream from: start to: finish 448043 448044 | decoder buffer chunkSize | 448045 decoder := FastInflateStream on: stream. 448046 readDataRemaining := readDataRemaining min: finish - start + 1. 448047 buffer := ByteArray new: (32768 min: readDataRemaining). 448048 decoder next: start - 1. 448049 448050 [ readDataRemaining > 0 ] whileTrue: [ 448051 chunkSize := 32768 min: readDataRemaining. 448052 buffer := decoder next: chunkSize into: buffer startingAt: 1. 448053 aStream next: chunkSize putAll: buffer startingAt: 1. 448054 readDataRemaining := readDataRemaining - chunkSize. 448055 ]. 448056! ! 448057 448058"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 448059 448060ZipFileMember class 448061 instanceVariableNames: ''! 448062 448063!ZipFileMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/22/2001 17:31'! 448064newFrom: stream named: fileName 448065 ^(self new) stream: stream externalFileName: fileName! ! 448066ZipArchiveMember subclass: #ZipNewFileMember 448067 instanceVariableNames: 'externalFileName stream' 448068 classVariableNames: '' 448069 poolDictionaries: '' 448070 category: 'Compression-Archives'! 448071!ZipNewFileMember commentStamp: '<historical>' prior: 0! 448072ZipNewFileMember instances are used to represent files that are going to be written to a ZipArchive. 448073Their data comes from external file streams.! 448074 448075 448076!ZipNewFileMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:50'! 448077close 448078 stream ifNotNil:[stream close].! ! 448079 448080!ZipNewFileMember methodsFor: 'initialization' stamp: 'nk 12/20/2002 15:01'! 448081from: aFileName 448082 | entry | 448083 compressionMethod := CompressionStored. 448084 "Now get the size, attributes, and timestamps, and see if the file exists" 448085 stream := StandardFileStream readOnlyFileNamed: aFileName. 448086 self localFileName: (externalFileName := stream name). 448087 entry := stream directoryEntry. 448088 compressedSize := uncompressedSize := entry fileSize. 448089 desiredCompressionMethod := compressedSize > 0 ifTrue: [ CompressionDeflated ] ifFalse: [ CompressionStored ]. 448090 self setLastModFileDateTimeFrom: entry modificationTime 448091! ! 448092 448093!ZipNewFileMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:56'! 448094initialize 448095 super initialize. 448096 externalFileName := ''.! ! 448097 448098 448099!ZipNewFileMember methodsFor: 'testing' stamp: 'nk 2/24/2001 15:03'! 448100usesFileNamed: aFileName 448101 "Do I require aFileName? That is, do I care if it's clobbered?" 448102 ^(FileDirectory default fullNameFor: externalFileName) = (FileDirectory default fullNameFor: aFileName)! ! 448103 448104 448105!ZipNewFileMember methodsFor: 'private' stamp: 'nk 2/22/2001 20:48'! 448106readRawChunk: n 448107 ^stream next: n! ! 448108 448109 448110!ZipNewFileMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 09:58'! 448111rewindData 448112 super rewindData. 448113 readDataRemaining := stream size. 448114 stream position: 0.! ! 448115 448116"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 448117 448118ZipNewFileMember class 448119 instanceVariableNames: ''! 448120 448121!ZipNewFileMember class methodsFor: 'instance creation' stamp: 'nk 2/22/2001 17:27'! 448122newNamed: aFileName 448123 ^(self new) from: aFileName! ! 448124FastInflateStream subclass: #ZipReadStream 448125 instanceVariableNames: 'expectedCrc' 448126 classVariableNames: '' 448127 poolDictionaries: '' 448128 category: 'Compression-Streams'! 448129!ZipReadStream commentStamp: 'nk 3/7/2004 18:54' prior: 0! 448130ZipReadStream is intended for uncompressing the compressed contents of Zip archive members. 448131 448132Since Zip archive members keep their expected CRC value separately in Zip headers, this class does not attempt to read the CRC from its input stream. 448133 448134Instead, if you want the CRC verification to work you have to call #expectedCrc: with the expected CRC-32 value from the Zip member header.! 448135 448136 448137!ZipReadStream methodsFor: 'crc' stamp: 'nk 3/7/2004 18:55'! 448138expectedCrc: aNumberOrNil 448139 "If expectedCrc is set, it will be compared against the calculated CRC32 in verifyCrc. 448140 This number should be the number read from the Zip header (which is the bitwise complement of my crc if all is working correctly)" 448141 expectedCrc := aNumberOrNil! ! 448142 448143!ZipReadStream methodsFor: 'crc' stamp: 'nk 3/7/2004 15:32'! 448144updateCrc: oldCrc from: start to: stop in: aCollection 448145 ^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection! ! 448146 448147!ZipReadStream methodsFor: 'crc' stamp: 'BG 3/16/2005 08:28'! 448148verifyCrc 448149 "Verify the CRC-32 checksum calculated from the input against the expected CRC-32, if any. 448150 Answer the calculated CRC-32 in any case. 448151 Note that the CRC-32 used in Zip files is actually the bit inverse of the calculated value, so that is what is returned." 448152 448153 | invertedCrc | 448154 invertedCrc := crc bitXor: 16rFFFFFFFF. 448155 (expectedCrc notNil and: [ expectedCrc ~= invertedCrc ]) 448156 ifTrue: [ ^ self crcError: ('Wrong CRC-32 (expected {1} got {2}) (proceed to ignore)' translated format: { expectedCrc printStringHex. invertedCrc printStringHex }) ]. 448157 ^invertedCrc! ! 448158 448159 448160!ZipReadStream methodsFor: 'initialize' stamp: 'nk 3/7/2004 15:31'! 448161on: aCollection from: firstIndex to: lastIndex 448162 super on: aCollection from: firstIndex to: lastIndex. 448163 crc := 16rFFFFFFFF. 448164 expectedCrc := nil.! ! 448165ZipArchiveMember subclass: #ZipStringMember 448166 instanceVariableNames: 'contents stream' 448167 classVariableNames: '' 448168 poolDictionaries: '' 448169 category: 'Compression-Archives'! 448170!ZipStringMember commentStamp: '<historical>' prior: 0! 448171ZipStringMember instances are used to represent files that are going to be written to a ZipArchive. 448172Their data comes from in-image strings, though.! 448173 448174 448175!ZipStringMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:47'! 448176contents 448177 ^contents! ! 448178 448179!ZipStringMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 20:50'! 448180contents: aString 448181 contents := aString. 448182 compressedSize := uncompressedSize := aString size. 448183 "set the file date to now" 448184 self setLastModFileDateTimeFrom: Time totalSeconds! ! 448185 448186!ZipStringMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 20:50'! 448187initialize 448188 super initialize. 448189 self contents: ''. 448190 compressionMethod := desiredCompressionMethod := CompressionStored. 448191! ! 448192 448193 448194!ZipStringMember methodsFor: 'private' stamp: 'nk 2/22/2001 20:51'! 448195readRawChunk: n 448196 ^stream next: n! ! 448197 448198 448199!ZipStringMember methodsFor: 'private-writing' stamp: 'damiencassou 5/30/2008 16:16'! 448200rewindData 448201 super rewindData. 448202 stream := contents readStream. 448203 readDataRemaining := contents size! ! 448204 448205"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 448206 448207ZipStringMember class 448208 instanceVariableNames: ''! 448209 448210!ZipStringMember class methodsFor: 'as yet unclassified' stamp: 'nk 12/20/2002 15:06'! 448211newFrom: aString named: aFileName 448212 ^(self new) contents: aString; localFileName: aFileName; yourself! ! 448213DeflateStream subclass: #ZipWriteStream 448214 instanceVariableNames: 'literals distances literalFreq distanceFreq litCount matchCount encoder crc crcPosition bytesWritten' 448215 classVariableNames: 'CrcTable VerboseLevel' 448216 poolDictionaries: 'ZipConstants' 448217 category: 'Compression-Streams'! 448218 448219!ZipWriteStream methodsFor: 'accessing' stamp: 'ar 2/24/2001 19:46'! 448220crc 448221 ^crc! ! 448222 448223!ZipWriteStream methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:37'! 448224encodedStream 448225 ^encoder encodedStream! ! 448226 448227!ZipWriteStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 18:32'! 448228forcedMethod 448229 "Return a symbol describing an enforced method or nil if the method should 448230 be chosen adaptively. Valid symbols are 448231 #stored - store blocks (do not compress) 448232 #fixed - use fixed huffman trees 448233 #dynamic - use dynamic huffman trees." 448234 ^nil! ! 448235 448236 448237!ZipWriteStream methodsFor: 'deflating' stamp: 'ar 2/2/2001 15:47'! 448238deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch 448239 "^DeflatePlugin doPrimitive:#primitiveDeflateBlock" 448240 <primitive: 'primitiveDeflateBlock' module: 'ZipPlugin'> 448241 ^super deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch! ! 448242 448243 448244!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 01:55'! 448245dynamicBlockSizeFor: lTree and: dTree using: blTree and: blFreq 448246 "Compute the length for the current block using dynamic huffman trees" 448247 | bits index extra treeBits freq | 448248 bits := 3 "block type" + 5 "literal codes length" + 5 "distance codes length". 448249 448250 "Compute the # of bits for sending the bit length tree" 448251 treeBits := 4. "Max index for bit length tree" 448252 index := MaxBitLengthCodes. 448253 [index >= 4] whileTrue:[ 448254 (index = 4 or:[(blFreq at: (BitLengthOrder at: index)+1) > 0]) 448255 ifTrue:[treeBits := treeBits + (index * 3). 448256 index := -1] 448257 ifFalse:[index := index - 1]]. 448258 448259 "Compute the # of bits for sending the literal/distance tree. 448260 Note: The frequency are already stored in the blTree" 448261 0 to: 15 do:[:i| "First, the non-repeating values" 448262 freq := blFreq at: i+1. 448263 freq > 0 ifTrue:[treeBits := treeBits + (freq * (blTree bitLengthAt: i))]]. 448264 "Now the repeating values" 448265 (Repeat3To6 to: Repeat11To138) with: #(2 3 7) do:[:i :addl| 448266 freq := blFreq at: i+1. 448267 freq > 0 ifTrue:[ 448268 treeBits := treeBits + (freq * ((blTree bitLengthAt: i) + addl "addl bits"))]]. 448269 VerboseLevel > 1 ifTrue:[ 448270 Transcript show:'['; print: treeBits; show:' bits for dynamic tree]']. 448271 bits := bits + treeBits. 448272 448273 "Compute the size of the compressed block" 448274 0 to: NumLiterals do:[:i| "encoding of literals" 448275 freq := literalFreq at: i+1. 448276 freq > 0 ifTrue:[bits := bits + (freq * (lTree bitLengthAt: i))]]. 448277 NumLiterals+1 to: lTree maxCode do:[:i| "encoding of match lengths" 448278 freq := literalFreq at: i+1. 448279 extra := ExtraLengthBits at: i-NumLiterals. 448280 freq > 0 ifTrue:[bits := bits + (freq * ((lTree bitLengthAt: i) + extra))]]. 448281 0 to: dTree maxCode do:[:i| "encoding of distances" 448282 freq := distanceFreq at: i+1. 448283 extra := ExtraDistanceBits at: i+1. 448284 freq > 0 ifTrue:[bits := bits + (freq * ((dTree bitLengthAt: i) + extra))]]. 448285 448286 ^bits! ! 448287 448288!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:55'! 448289scanBitLength: bitLength repeatCount: repeatCount into: anArray 448290 "Update the frequency for the aTree based on the given values" 448291 | count | 448292 count := repeatCount. 448293 bitLength = 0 ifTrue:[ 448294 [count >= 11] whileTrue:[ 448295 anArray at: Repeat11To138+1 put: (anArray at: Repeat11To138+1) + 1. 448296 count := (count - 138) max: 0]. 448297 [count >= 3] whileTrue:[ 448298 anArray at: Repeat3To10+1 put: (anArray at: Repeat3To10+1) + 1. 448299 count := (count - 10) max: 0]. 448300 count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count]. 448301 ] ifFalse:[ 448302 anArray at: bitLength+1 put: (anArray at: bitLength+1) + 1. 448303 count := count - 1. 448304 [count >= 3] whileTrue:[ 448305 anArray at: Repeat3To6+1 put: (anArray at: Repeat3To6+1) + 1. 448306 count := (count - 6) max: 0]. 448307 count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count]. 448308 ].! ! 448309 448310!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:55'! 448311scanBitLengths: bits into: anArray 448312 "Scan the trees and determine the frequency of the bit lengths. 448313 For repeating codes, emit a repeat count." 448314 | lastValue lastCount value | 448315 bits size = 0 ifTrue:[^self]. 448316 lastValue := bits at: 1. 448317 lastCount := 1. 448318 2 to: bits size do:[:i| 448319 value := bits at: i. 448320 value = lastValue 448321 ifTrue:[lastCount := lastCount + 1] 448322 ifFalse:[self scanBitLength: lastValue repeatCount: lastCount into: anArray. 448323 lastValue := value. 448324 lastCount := 1]]. 448325 self scanBitLength: lastValue repeatCount: lastCount into: anArray.! ! 448326 448327!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'! 448328sendBitLength: bitLength repeatCount: repeatCount tree: aTree 448329 "Send the given bitLength, repeating repeatCount times" 448330 | count | 448331 count := repeatCount. 448332 bitLength = 0 ifTrue:[ 448333 [count >= 11] whileTrue:[ 448334 self sendBitLength: Repeat11To138 tree: aTree. 448335 encoder nextBits: 7 put: (count min: 138) - 11. 448336 count := (count - 138) max: 0]. 448337 [count >= 3] whileTrue:[ 448338 self sendBitLength: Repeat3To10 tree: aTree. 448339 encoder nextBits: 3 put: (count min: 10) - 3. 448340 count := (count - 10) max: 0]. 448341 count timesRepeat:[self sendBitLength: bitLength tree: aTree]. 448342 ] ifFalse:[ 448343 self sendBitLength: bitLength tree: aTree. 448344 count := count - 1. 448345 [count >= 3] whileTrue:[ 448346 self sendBitLength: Repeat3To6 tree: aTree. 448347 encoder nextBits: 2 put: (count min: 6) - 3. 448348 count := (count - 6) max: 0]. 448349 count timesRepeat:[self sendBitLength: bitLength tree: aTree]. 448350 ].! ! 448351 448352!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'! 448353sendBitLength: bitLength tree: aTree 448354 "Send the given bitLength" 448355 encoder nextBits: (aTree bitLengthAt: bitLength) 448356 put: (aTree codeAt: bitLength).! ! 448357 448358!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'! 448359sendBitLengthTree: blTree 448360 "Send the bit length tree" 448361 | blIndex bitLength | 448362 MaxBitLengthCodes to: 4 by: -1 do:[:maxIndex| 448363 blIndex := BitLengthOrder at: maxIndex. 448364 bitLength := blIndex <= blTree maxCode 448365 ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0]. 448366 (maxIndex = 4 or:[bitLength > 0]) ifTrue:[ 448367 encoder nextBits: 4 put: maxIndex - 4. 448368 1 to: maxIndex do:[:j| 448369 blIndex := BitLengthOrder at: j. 448370 bitLength := blIndex <= blTree maxCode 448371 ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0]. 448372 encoder nextBits: 3 put: bitLength]. 448373 ^self]].! ! 448374 448375!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 00:48'! 448376sendCompressedBlock: litTree with: distTree 448377 "Send the current block using the encodings from the given literal/length and distance tree" 448378 | sum | 448379 sum := encoder 448380 sendBlock: (ReadStream on: literals from: 1 to: litCount) 448381 with: (ReadStream on: distances from: 1 to: litCount) 448382 with: litTree 448383 with: distTree. 448384 sum = (blockPosition - blockStart) ifFalse:[self error:'Wrong number of bytes'].! ! 448385 448386!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/29/1999 18:19'! 448387sendDynamicBlock: blTree literalTree: lTree distanceTree: dTree bitLengths: bits 448388 "Send a block using dynamic huffman trees" 448389 self sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits. 448390 self sendCompressedBlock: lTree with: dTree.! ! 448391 448392!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'! 448393sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits 448394 "Send all the trees needed for dynamic huffman tree encoding" 448395 | lastValue lastCount value | 448396 encoder nextBits: 5 put: (lTree maxCode - 256). 448397 encoder nextBits: 5 put: (dTree maxCode). 448398 self sendBitLengthTree: blTree. 448399 bits size = 0 ifTrue:[^self]. 448400 lastValue := bits at: 1. 448401 lastCount := 1. 448402 2 to: bits size do:[:i| 448403 value := bits at: i. 448404 value = lastValue 448405 ifTrue:[lastCount := lastCount + 1] 448406 ifFalse:[self sendBitLength: lastValue repeatCount: lastCount tree: blTree. 448407 lastValue := value. 448408 lastCount := 1]]. 448409 self sendBitLength: lastValue repeatCount: lastCount tree: blTree.! ! 448410 448411 448412!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:05'! 448413encodeLiteral: lit 448414 "Encode the given literal" 448415 litCount := litCount + 1. 448416 literals at: litCount put: lit. 448417 distances at: litCount put: 0. 448418 literalFreq at: lit+1 put: (literalFreq at: lit+1) + 1. 448419 ^self shouldFlush! ! 448420 448421!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:05'! 448422encodeMatch: length distance: dist 448423 "Encode the given match of length length starting at dist bytes ahead" 448424 | literal distance | 448425 dist > 0 448426 ifFalse:[^self error:'Distance must be positive']. 448427 length < MinMatch 448428 ifTrue:[^self error:'Match length must be at least ', MinMatch printString]. 448429 litCount := litCount + 1. 448430 matchCount := matchCount + 1. 448431 literals at: litCount put: length - MinMatch. 448432 distances at: litCount put: dist. 448433 literal := (MatchLengthCodes at: length - MinMatch + 1). 448434 literalFreq at: literal+1 put: (literalFreq at: literal+1) + 1. 448435 dist < 257 448436 ifTrue:[distance := DistanceCodes at: dist] 448437 ifFalse:[distance := DistanceCodes at: 257 + (dist - 1 bitShift: -7)]. 448438 distanceFreq at: distance+1 put: (distanceFreq at: distance+1) + 1. 448439 ^self shouldFlush! ! 448440 448441!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:08'! 448442flushBlock 448443 ^self flushBlock: false! ! 448444 448445!ZipWriteStream methodsFor: 'encoding' stamp: 'marcus.denker 9/14/2008 21:02'! 448446flushBlock: lastBlock 448447 "Send the current block" 448448 | lastFlag bitsRequired method bitsSent 448449 storedLength fixedLength dynamicLength 448450 blTree lTree dTree blBits blFreq | 448451 448452 lastFlag := lastBlock ifTrue:[1] ifFalse:[0]. 448453 448454 "Compute the literal/length and distance tree" 448455 lTree := ZipEncoderTree buildTreeFrom: literalFreq maxDepth: MaxBits. 448456 dTree := ZipEncoderTree buildTreeFrom: distanceFreq maxDepth: MaxBits. 448457 448458 "Compute the bit length tree" 448459 blBits := lTree bitLengths, dTree bitLengths. 448460 blFreq := WordArray new: MaxBitLengthCodes. 448461 self scanBitLengths: blBits into: blFreq. 448462 blTree := ZipEncoderTree buildTreeFrom: blFreq maxDepth: MaxBitLengthBits. 448463 448464 "Compute the bit length for the current block. 448465 Note: Most of this could be computed on the fly but it's getting 448466 really ugly in this case so we do it afterwards." 448467 storedLength := self storedBlockSize. 448468 fixedLength := self fixedBlockSizeFor: lTree and: dTree. 448469 dynamicLength := self dynamicBlockSizeFor: lTree and: dTree 448470 using: blTree and: blFreq. 448471 VerboseLevel > 1 ifTrue:[ 448472 Transcript cr; show:'Block sizes (S/F/D):'; 448473 space; print: storedLength // 8; 448474 nextPut:$/; print: fixedLength // 8; 448475 nextPut:$/; print: dynamicLength // 8; space; endEntry]. 448476 448477 "Check which method to use" 448478 method := self forcedMethod. 448479 method ifNil:[ 448480 method := (storedLength < fixedLength and:[storedLength < dynamicLength]) 448481 ifTrue:[#stored] 448482 ifFalse:[fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]]]. 448483 (method == #stored and:[blockStart < 0]) ifTrue:[ 448484 "Cannot use #stored if the block is not available" 448485 method := fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]]. 448486 448487 bitsSent := encoder bitPosition. "# of bits sent before this block" 448488 bitsRequired := nil. 448489 448490 (method == #stored) ifTrue:[ 448491 VerboseLevel > 0 ifTrue:[Transcript show:'S']. 448492 bitsRequired := storedLength. 448493 encoder nextBits: 3 put: StoredBlock << 1 + lastFlag. 448494 self sendStoredBlock]. 448495 448496 (method == #fixed) ifTrue:[ 448497 VerboseLevel > 0 ifTrue:[Transcript show:'F']. 448498 bitsRequired := fixedLength. 448499 encoder nextBits: 3 put: FixedBlock << 1 + lastFlag. 448500 self sendFixedBlock]. 448501 448502 (method == #dynamic) ifTrue:[ 448503 VerboseLevel > 0 ifTrue:[Transcript show:'D']. 448504 bitsRequired := dynamicLength. 448505 encoder nextBits: 3 put: DynamicBlock << 1 + lastFlag. 448506 self sendDynamicBlock: blTree 448507 literalTree: lTree 448508 distanceTree: dTree 448509 bitLengths: blBits]. 448510 448511 bitsRequired = (encoder bitPosition - bitsSent) 448512 ifFalse:[self error:'Bits size mismatch']. 448513 448514 lastBlock 448515 ifTrue:[self release] 448516 ifFalse:[self initializeNewBlock].! ! 448517 448518!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:08'! 448519shouldFlush 448520 "Check if we should flush the current block. 448521 Flushing can be useful if the input characteristics change." 448522 | nLits | 448523 litCount = literals size ifTrue:[^true]. "We *must* flush" 448524 (litCount bitAnd: 16rFFF) = 0 ifFalse:[^false]. "Only check every N kbytes" 448525 matchCount * 10 <= litCount ifTrue:[ 448526 "This is basically random data. 448527 There is no need to flush early since the overhead 448528 for encoding the trees will add to the overall size" 448529 ^false]. 448530 "Try to adapt to the input data. 448531 We flush if the ratio between matches and literals 448532 changes beyound a certain threshold" 448533 nLits := litCount - matchCount. 448534 nLits <= matchCount ifTrue:[^false]. "whow!! so many matches" 448535 ^nLits * 4 <= matchCount! ! 448536 448537 448538!ZipWriteStream methodsFor: 'fixed blocks' stamp: 'ar 12/29/1999 18:18'! 448539fixedBlockSizeFor: lTree and: dTree 448540 "Compute the length for the current block using fixed huffman trees" 448541 | bits extra | 448542 bits := 3 "block type". 448543 "Compute the size of the compressed block" 448544 0 to: NumLiterals do:[:i| "encoding of literals" 448545 bits := bits + ((literalFreq at: i+1) * (FixedLiteralTree bitLengthAt: i))]. 448546 NumLiterals+1 to: lTree maxCode+1 do:[:i| "Encoding of match lengths" 448547 extra := ExtraLengthBits at: i-NumLiterals. 448548 bits := bits + ((literalFreq at: i+1) * ((FixedLiteralTree bitLengthAt: i) + extra))]. 448549 0 to: dTree maxCode do:[:i| "encoding of distances" 448550 extra := ExtraDistanceBits at: i+1. 448551 bits := bits + ((distanceFreq at: i+1) * ((FixedDistanceTree bitLengthAt: i) + extra))]. 448552 448553 ^bits! ! 448554 448555!ZipWriteStream methodsFor: 'fixed blocks' stamp: 'ar 12/29/1999 18:18'! 448556sendFixedBlock 448557 "Send a block using fixed huffman trees" 448558 self sendCompressedBlock: FixedLiteralTree with: FixedDistanceTree.! ! 448559 448560 448561!ZipWriteStream methodsFor: 'initialization' stamp: 'ar 2/28/2001 13:39'! 448562close 448563 self deflateBlock. 448564 self flushBlock: true. 448565 encoder close.! ! 448566 448567!ZipWriteStream methodsFor: 'initialization' stamp: 'ar 2/27/2001 13:23'! 448568finish 448569 "Finish pending operation. Do not close output stream." 448570 self deflateBlock. 448571 self flushBlock: true. 448572 encoder flush.! ! 448573 448574!ZipWriteStream methodsFor: 'initialization' stamp: 'ar 12/30/1999 00:40'! 448575initialize 448576 super initialize. 448577 literals := ByteArray new: WindowSize. 448578 distances := WordArray new: WindowSize. 448579 literalFreq := WordArray new: MaxLiteralCodes. 448580 distanceFreq := WordArray new: MaxDistCodes. 448581 self initializeNewBlock. 448582! ! 448583 448584!ZipWriteStream methodsFor: 'initialization' stamp: 'ar 12/29/1999 18:29'! 448585initializeNewBlock 448586 "Initialize the encoder for a new block of data" 448587 literalFreq atAllPut: 0. 448588 distanceFreq atAllPut: 0. 448589 literalFreq at: EndBlock+1 put: 1. 448590 litCount := 0. 448591 matchCount := 0.! ! 448592 448593!ZipWriteStream methodsFor: 'initialization' stamp: 'ar 2/24/2001 19:43'! 448594on: aCollectionOrStream 448595 crc := 16rFFFFFFFF. 448596 crcPosition := 1. 448597 bytesWritten := 0. 448598 encoder := ZipEncoder on: aCollectionOrStream. 448599 encoder isBinary 448600 ifTrue:[super on: ByteArray new] 448601 ifFalse:[super on: String new]. 448602 self writeHeader. 448603! ! 448604 448605!ZipWriteStream methodsFor: 'initialization' stamp: 'nk 2/17/2004 16:31'! 448606release 448607 "We're done with compression. Do some cleanup." 448608 literals := distances := literalFreq := distanceFreq := nil. 448609 self updateCrc. 448610 encoder flushBits. 448611 self writeFooter.! ! 448612 448613!ZipWriteStream methodsFor: 'initialization' stamp: 'nk 2/17/2004 16:30'! 448614writeFooter 448615 "Write footer information if necessary" 448616 crc := crc bitXor: 16rFFFFFFFF.! ! 448617 448618!ZipWriteStream methodsFor: 'initialization' stamp: 'ar 2/24/2001 19:44'! 448619writeHeader 448620 "Write header information if necessary"! ! 448621 448622 448623!ZipWriteStream methodsFor: 'stored blocks' stamp: 'ar 1/2/2000 16:36'! 448624sendStoredBlock 448625 "Send an uncompressed block" 448626 | inBytes | 448627 inBytes := blockPosition - blockStart. 448628 encoder flushBits. "Skip to byte boundary" 448629 encoder nextBits: 16 put: inBytes. 448630 encoder nextBits: 16 put: (inBytes bitXor: 16rFFFF). 448631 encoder flushBits. 448632 1 to: inBytes do:[:i| 448633 encoder nextBytePut: (collection byteAt: blockStart+i)].! ! 448634 448635!ZipWriteStream methodsFor: 'stored blocks' stamp: 'ar 12/30/1999 00:42'! 448636storedBlockSize 448637 "Compute the length for the current block when stored as is" 448638 ^3 "block type bits" 448639 + (8 - (encoder bitPosition + 3 bitAnd: 7) bitAnd: 7)"skipped bits to byte boundary" 448640 + 32 "byte length + chksum" 448641 + (blockPosition - blockStart * 8) "actual data bits".! ! 448642 448643 448644!ZipWriteStream methodsFor: 'private' stamp: 'ar 2/24/2001 19:45'! 448645moveContentsToFront 448646 "Need to update crc here" 448647 self updateCrc. 448648 super moveContentsToFront. 448649 crcPosition := position + 1.! ! 448650 448651!ZipWriteStream methodsFor: 'private' stamp: 'ar 2/24/2001 19:45'! 448652updateCrc 448653 crcPosition <= position ifTrue:[ 448654 bytesWritten := bytesWritten + position - crcPosition + 1. 448655 crc := self updateCrc: crc from: crcPosition to: position in: collection. 448656 crcPosition := position + 1].! ! 448657 448658!ZipWriteStream methodsFor: 'private' stamp: 'nk 2/17/2004 16:51'! 448659updateCrc: oldCrc from: start to: stop in: aCollection 448660 ^self class updateCrc: oldCrc from: start to: stop in: aCollection! ! 448661 448662"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! 448663 448664ZipWriteStream class 448665 instanceVariableNames: ''! 448666 448667!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'! 448668baseDistance 448669 ^BaseDistance! ! 448670 448671!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'! 448672baseLength 448673 ^BaseLength! ! 448674 448675!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 2/24/2001 19:42'! 448676crcTable 448677 ^CrcTable! ! 448678 448679!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:42'! 448680distanceCodes 448681 ^DistanceCodes! ! 448682 448683!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'! 448684extraDistanceBits 448685 ^ExtraDistanceBits! ! 448686 448687!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'! 448688extraLengthBits 448689 ^ExtraLengthBits! ! 448690 448691!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:42'! 448692matchLengthCodes 448693 ^MatchLengthCodes! ! 448694 448695!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:53'! 448696maxDistanceCodes 448697 ^MaxDistCodes! ! 448698 448699!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:53'! 448700maxLiteralCodes 448701 ^MaxLiteralCodes! ! 448702 448703 448704!ZipWriteStream class methodsFor: 'crc' stamp: 'nk 2/17/2004 16:50'! 448705updateCrc: oldCrc from: start to: stop in: aCollection 448706 | newCrc | 448707 <primitive: 'primitiveUpdateGZipCrc32' module: 'ZipPlugin'> 448708 newCrc := oldCrc. 448709 start to: stop do:[:i| 448710 newCrc := (CrcTable at: ((newCrc bitXor: (aCollection byteAt: i)) 448711 bitAnd: 255) + 1) bitXor: (newCrc bitShift: -8). 448712 ]. 448713 ^newCrc! ! 448714 448715 448716!ZipWriteStream class methodsFor: 'initialization' stamp: 'ar 5/18/2003 19:10'! 448717initialize 448718 "ZipWriteStream initialize" 448719 VerboseLevel := 0. 448720 self initializeCrcTable.! ! 448721 448722!ZipWriteStream class methodsFor: 'initialization' stamp: 'ar 2/24/2001 19:42'! 448723initializeCrcTable 448724 "ZipWriteStream initialize" 448725 CrcTable := #(16r00000000 16r77073096 16rEE0E612C 16r990951BA 16r076DC419 448726 16r706AF48F 16rE963A535 16r9E6495A3 16r0EDB8832 16r79DCB8A4 448727 16rE0D5E91E 16r97D2D988 16r09B64C2B 16r7EB17CBD 16rE7B82D07 448728 16r90BF1D91 16r1DB71064 16r6AB020F2 16rF3B97148 16r84BE41DE 448729 16r1ADAD47D 16r6DDDE4EB 16rF4D4B551 16r83D385C7 16r136C9856 448730 16r646BA8C0 16rFD62F97A 16r8A65C9EC 16r14015C4F 16r63066CD9 448731 16rFA0F3D63 16r8D080DF5 16r3B6E20C8 16r4C69105E 16rD56041E4 448732 16rA2677172 16r3C03E4D1 16r4B04D447 16rD20D85FD 16rA50AB56B 448733 16r35B5A8FA 16r42B2986C 16rDBBBC9D6 16rACBCF940 16r32D86CE3 448734 16r45DF5C75 16rDCD60DCF 16rABD13D59 16r26D930AC 16r51DE003A 448735 16rC8D75180 16rBFD06116 16r21B4F4B5 16r56B3C423 16rCFBA9599 448736 16rB8BDA50F 16r2802B89E 16r5F058808 16rC60CD9B2 16rB10BE924 448737 16r2F6F7C87 16r58684C11 16rC1611DAB 16rB6662D3D 16r76DC4190 448738 16r01DB7106 16r98D220BC 16rEFD5102A 16r71B18589 16r06B6B51F 448739 16r9FBFE4A5 16rE8B8D433 16r7807C9A2 16r0F00F934 16r9609A88E 448740 16rE10E9818 16r7F6A0DBB 16r086D3D2D 16r91646C97 16rE6635C01 448741 16r6B6B51F4 16r1C6C6162 16r856530D8 16rF262004E 16r6C0695ED 448742 16r1B01A57B 16r8208F4C1 16rF50FC457 16r65B0D9C6 16r12B7E950 448743 16r8BBEB8EA 16rFCB9887C 16r62DD1DDF 16r15DA2D49 16r8CD37CF3 448744 16rFBD44C65 16r4DB26158 16r3AB551CE 16rA3BC0074 16rD4BB30E2 448745 16r4ADFA541 16r3DD895D7 16rA4D1C46D 16rD3D6F4FB 16r4369E96A 448746 16r346ED9FC 16rAD678846 16rDA60B8D0 16r44042D73 16r33031DE5 448747 16rAA0A4C5F 16rDD0D7CC9 16r5005713C 16r270241AA 16rBE0B1010 448748 16rC90C2086 16r5768B525 16r206F85B3 16rB966D409 16rCE61E49F 448749 16r5EDEF90E 16r29D9C998 16rB0D09822 16rC7D7A8B4 16r59B33D17 448750 16r2EB40D81 16rB7BD5C3B 16rC0BA6CAD 16rEDB88320 16r9ABFB3B6 448751 16r03B6E20C 16r74B1D29A 16rEAD54739 16r9DD277AF 16r04DB2615 448752 16r73DC1683 16rE3630B12 16r94643B84 16r0D6D6A3E 16r7A6A5AA8 448753 16rE40ECF0B 16r9309FF9D 16r0A00AE27 16r7D079EB1 16rF00F9344 448754 16r8708A3D2 16r1E01F268 16r6906C2FE 16rF762575D 16r806567CB 448755 16r196C3671 16r6E6B06E7 16rFED41B76 16r89D32BE0 16r10DA7A5A 448756 16r67DD4ACC 16rF9B9DF6F 16r8EBEEFF9 16r17B7BE43 16r60B08ED5 448757 16rD6D6A3E8 16rA1D1937E 16r38D8C2C4 16r4FDFF252 16rD1BB67F1 448758 16rA6BC5767 16r3FB506DD 16r48B2364B 16rD80D2BDA 16rAF0A1B4C 448759 16r36034AF6 16r41047A60 16rDF60EFC3 16rA867DF55 16r316E8EEF 448760 16r4669BE79 16rCB61B38C 16rBC66831A 16r256FD2A0 16r5268E236 448761 16rCC0C7795 16rBB0B4703 16r220216B9 16r5505262F 16rC5BA3BBE 448762 16rB2BD0B28 16r2BB45A92 16r5CB36A04 16rC2D7FFA7 16rB5D0CF31 448763 16r2CD99E8B 16r5BDEAE1D 16r9B64C2B0 16rEC63F226 16r756AA39C 448764 16r026D930A 16r9C0906A9 16rEB0E363F 16r72076785 16r05005713 448765 16r95BF4A82 16rE2B87A14 16r7BB12BAE 16r0CB61B38 16r92D28E9B 448766 16rE5D5BE0D 16r7CDCEFB7 16r0BDBDF21 16r86D3D2D4 16rF1D4E242 448767 16r68DDB3F8 16r1FDA836E 16r81BE16CD 16rF6B9265B 16r6FB077E1 448768 16r18B74777 16r88085AE6 16rFF0F6A70 16r66063BCA 16r11010B5C 448769 16r8F659EFF 16rF862AE69 16r616BFFD3 16r166CCF45 16rA00AE278 448770 16rD70DD2EE 16r4E048354 16r3903B3C2 16rA7672661 16rD06016F7 448771 16r4969474D 16r3E6E77DB 16rAED16A4A 16rD9D65ADC 16r40DF0B66 448772 16r37D83BF0 16rA9BCAE53 16rDEBB9EC5 16r47B2CF7F 16r30B5FFE9 448773 16rBDBDF21C 16rCABAC28A 16r53B39330 16r24B4A3A6 16rBAD03605 448774 16rCDD70693 16r54DE5729 16r23D967BF 16rB3667A2E 16rC4614AB8 448775 16r5D681B02 16r2A6F2B94 16rB40BBE37 16rC30C8EA1 16r5A05DF1B 448776 16r2D02EF8D 448777).! ! 448778 448779 448780!ZipWriteStream class methodsFor: 'regression test' stamp: 'marcus.denker 9/14/2008 19:00'! 448781compressAndDecompress: aFile using: tempName stats: stats 448782 | fileSize tempFile result | 448783 aFile ifNil: [^nil]. 448784 fileSize := aFile size. 448785 (fileSize < 1"00000" "or:[fileSize > 1000000]") ifTrue:[aFile close. ^nil]. 448786 Transcript cr; show:'Testing ', aFile name,' ... '. 448787 tempFile := StandardFileStream new open: tempName forWrite: true. 448788 'Compressing ', aFile name,'...' displayProgressAt: Sensor cursorPoint 448789 from: 1 to: aFile size during:[:bar| 448790 result := self regressionCompress: aFile into: tempFile notifiying: bar stats: stats]. 448791 result ifTrue:[ 448792 'Validating ', aFile name,'...' displayProgressAt: Sensor cursorPoint 448793 from: 0 to: aFile size during:[:bar| 448794 result := self regressionDecompress: aFile from: tempFile notifying: bar stats: stats]]. 448795 aFile close. 448796 tempFile close. 448797 FileDirectory default deleteFileNamed: tempName ifAbsent:[]. 448798 result ~~ false ifTrue:[ 448799 Transcript show:' ok (', (result * 100 truncateTo: 0.01) printString,')']. 448800 ^result! ! 448801 448802!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 21:11'! 448803logProblem: reason for: aFile 448804 | errFile | 448805 errFile := FileStream fileNamed:'problems.log'. 448806 errFile position: errFile size. 448807 errFile cr; nextPutAll: aFile name; 448808 cr; nextPutAll: reason. 448809 errFile close. 448810 Transcript show:' failed (', reason,')'. 448811 aFile close. 448812 ^false! ! 448813 448814!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/31/1999 17:48'! 448815printRegressionStats: stats from: fd 448816 | raw compressed numFiles | 448817 raw := stats at: #rawSize ifAbsent:[0]. 448818 raw = 0 ifTrue:[^self]. 448819 compressed := stats at: #compressedSize ifAbsent:[0]. 448820 numFiles := stats at: #numFiles ifAbsent:[0]. 448821 Transcript cr; nextPutAll: fd pathName. 448822 Transcript crtab; nextPutAll:'Files compressed: ', numFiles asStringWithCommas. 448823 Transcript crtab; nextPutAll:'Bytes compressed: ', raw asStringWithCommas. 448824 Transcript crtab; nextPutAll:'Avg. compression ratio: '; 448825 print: ((compressed / raw asFloat * 100.0) truncateTo: 0.01). 448826 Transcript endEntry.! ! 448827 448828!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:44'! 448829regressionCompress: aFile into: tempFile notifiying: progressBar stats: stats 448830 "Compress aFile into tempFile" 448831 | zip encoded buffer | 448832 aFile binary. 448833 aFile position: 0. 448834 tempFile binary. 448835 buffer := ByteArray new: 4096. 448836 zip := self on: (ByteArray new: 10000). 448837 encoded := zip encodedStream. 448838 [aFile atEnd] whileFalse:[ 448839 progressBar value: aFile position. 448840 zip nextPutAll: (aFile nextInto: buffer). 448841 encoded position > 0 ifTrue:[ 448842 tempFile nextPutAll: encoded contents. 448843 encoded position: 0]]. 448844 zip close. 448845 tempFile nextPutAll: encoded contents. 448846 ^true! ! 448847 448848!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:45'! 448849regressionDecompress: aFile from: tempFile notifying: progressBar stats: stats 448850 "Validate aFile as decompressed from tempFile" 448851 | unzip rawSize compressedSize buffer1 buffer2 | 448852 rawSize := aFile size. 448853 compressedSize := tempFile size. 448854 aFile ascii. 448855 aFile position: 0. 448856 tempFile ascii. 448857 tempFile position: 0. 448858 buffer1 := String new: 4096. 448859 buffer2 := buffer1 copy. 448860 unzip := FastInflateStream on: tempFile. 448861 [aFile atEnd] whileFalse:[ 448862 progressBar value: aFile position. 448863 buffer1 := aFile nextInto: buffer1. 448864 buffer2 := unzip nextInto: buffer2. 448865 buffer1 = buffer2 448866 ifFalse:[^self logProblem: 'contents ' for: aFile]. 448867 ]. 448868 unzip next = nil ifFalse:[^self logProblem: 'EOF' for: aFile]. 448869 stats at: #rawSize put: 448870 (stats at: #rawSize ifAbsent:[0]) + rawSize. 448871 stats at: #compressedSize put: 448872 (stats at: #compressedSize ifAbsent:[0]) + compressedSize. 448873 ^compressedSize asFloat / rawSize asFloat.! ! 448874 448875!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/31/1999 17:48'! 448876regressionTest "ZipWriteStream regressionTest" 448877 "Compress and decompress everything we can 448878 find to validate that compression works as expected." 448879 self regressionTestFrom: (FileDirectory default).! ! 448880 448881!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:46'! 448882regressionTestFrom: fd 448883 "ZipWriteStream regressionTestFrom: FileDirectory default" 448884 "ZipWriteStream regressionTestFrom: (FileDirectory on:'')" 448885 "ZipWriteStream regressionTestFrom: (FileDirectory on:'C:')" 448886 | tempName stats | 448887 Transcript clear. 448888 stats := Dictionary new. 448889 tempName := FileDirectory default fullNameFor: '$$sqcompress$$'. 448890 FileDirectory default deleteFileNamed: tempName. 448891 self regressionTestFrom: fd using: tempName stats: stats.! ! 448892 448893!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/31/1999 17:47'! 448894regressionTestFrom: fd using: tempName stats: stats 448895 | files file fullName | 448896 files := fd fileNames asSortedCollection. 448897 files do:[:fName| 448898 file := nil. 448899 fullName := fd fullNameFor: fName. 448900 fullName = tempName ifFalse:[ 448901 file := StandardFileStream new open: fullName forWrite: false]. 448902 self compressAndDecompress: file using: tempName stats: stats]. 448903 stats at: #numFiles put: (stats at: #numFiles ifAbsent:[0]) + files size. 448904 files := nil. 448905 self printRegressionStats: stats from: fd. 448906 fd directoryNames asSortedCollection do:[:dName| 448907 self regressionTestFrom: (fd directoryNamed: dName) using: tempName stats: stats. 448908 ].! ! 448909
